[clapack] 01/02: Imported Upstream version 3.2.1
Andreas Tille
tille at debian.org
Mon May 16 08:36:16 UTC 2016
This is an automated email from the git hooks/post-receive script.
tille pushed a commit to branch master
in repository clapack.
commit b6fe8266ff21eb6b57fc609ddbc3682c77768260
Author: Andreas Tille <tille at debian.org>
Date: Mon May 16 10:31:35 2016 +0200
Imported Upstream version 3.2.1
---
BLAS/CMakeLists.txt | 2 +
BLAS/SRC/CMakeLists.txt | 143 +
BLAS/SRC/Makefile | 171 +
BLAS/SRC/caxpy.c | 103 +
BLAS/SRC/ccopy.c | 88 +
BLAS/SRC/cdotc.c | 106 +
BLAS/SRC/cdotu.c | 100 +
BLAS/SRC/cgbmv.c | 477 +++
BLAS/SRC/cgemm.c | 697 ++++
BLAS/SRC/cgemv.c | 411 ++
BLAS/SRC/cgerc.c | 217 ++
BLAS/SRC/cgeru.c | 214 ++
BLAS/SRC/chbmv.c | 483 +++
BLAS/SRC/chemm.c | 495 +++
BLAS/SRC/chemv.c | 433 +++
BLAS/SRC/cher.c | 338 ++
BLAS/SRC/cher2.c | 446 +++
BLAS/SRC/cher2k.c | 671 ++++
BLAS/SRC/cherk.c | 533 +++
BLAS/SRC/chpmv.c | 434 +++
BLAS/SRC/chpr.c | 339 ++
BLAS/SRC/chpr2.c | 447 +++
BLAS/SRC/crotg.c | 72 +
BLAS/SRC/cscal.c | 81 +
BLAS/SRC/csrot.c | 153 +
BLAS/SRC/csscal.c | 88 +
BLAS/SRC/cswap.c | 93 +
BLAS/SRC/csymm.c | 495 +++
BLAS/SRC/csyr2k.c | 537 +++
BLAS/SRC/csyrk.c | 457 +++
BLAS/SRC/ctbmv.c | 641 ++++
BLAS/SRC/ctbsv.c | 609 +++
BLAS/SRC/ctpmv.c | 571 +++
BLAS/SRC/ctpsv.c | 539 +++
BLAS/SRC/ctrmm.c | 688 ++++
BLAS/SRC/ctrmv.c | 554 +++
BLAS/SRC/ctrsm.c | 698 ++++
BLAS/SRC/ctrsv.c | 523 +++
BLAS/SRC/dasum.c | 101 +
BLAS/SRC/daxpy.c | 107 +
BLAS/SRC/dcabs1.c | 36 +
BLAS/SRC/dcopy.c | 107 +
BLAS/SRC/ddot.c | 110 +
BLAS/SRC/dgbmv.c | 369 ++
BLAS/SRC/dgemm.c | 389 ++
BLAS/SRC/dgemv.c | 312 ++
BLAS/SRC/dger.c | 194 +
BLAS/SRC/dnrm2.c | 95 +
BLAS/SRC/drot.c | 86 +
BLAS/SRC/drotg.c | 79 +
BLAS/SRC/drotm.c | 215 ++
BLAS/SRC/drotmg.c | 293 ++
BLAS/SRC/dsbmv.c | 364 ++
BLAS/SRC/dscal.c | 96 +
BLAS/SRC/dsdot.c | 135 +
BLAS/SRC/dspmv.c | 312 ++
BLAS/SRC/dspr.c | 237 ++
BLAS/SRC/dspr2.c | 270 ++
BLAS/SRC/dswap.c | 114 +
BLAS/SRC/dsymm.c | 362 ++
BLAS/SRC/dsymv.c | 313 ++
BLAS/SRC/dsyr.c | 238 ++
BLAS/SRC/dsyr2.c | 275 ++
BLAS/SRC/dsyr2k.c | 407 ++
BLAS/SRC/dsyrk.c | 372 ++
BLAS/SRC/dtbmv.c | 422 +++
BLAS/SRC/dtbsv.c | 426 +++
BLAS/SRC/dtpmv.c | 357 ++
BLAS/SRC/dtpsv.c | 360 ++
BLAS/SRC/dtrmm.c | 453 +++
BLAS/SRC/dtrmv.c | 345 ++
BLAS/SRC/dtrsm.c | 490 +++
BLAS/SRC/dtrsv.c | 348 ++
BLAS/SRC/dzasum.c | 80 +
BLAS/SRC/dznrm2.c | 108 +
BLAS/SRC/icamax.c | 93 +
BLAS/SRC/idamax.c | 93 +
BLAS/SRC/isamax.c | 93 +
BLAS/SRC/izamax.c | 93 +
BLAS/SRC/lsame.c | 117 +
BLAS/SRC/sasum.c | 101 +
BLAS/SRC/saxpy.c | 107 +
BLAS/SRC/scabs1.c | 36 +
BLAS/SRC/scasum.c | 87 +
BLAS/SRC/scnrm2.c | 109 +
BLAS/SRC/scopy.c | 107 +
BLAS/SRC/sdot.c | 109 +
BLAS/SRC/sdsdot.c | 144 +
BLAS/SRC/sgbmv.c | 368 ++
BLAS/SRC/sgemm.c | 388 ++
BLAS/SRC/sgemv.c | 312 ++
BLAS/SRC/sger.c | 193 +
BLAS/SRC/snrm2.c | 97 +
BLAS/SRC/srot.c | 90 +
BLAS/SRC/srotg.c | 78 +
BLAS/SRC/srotm.c | 216 ++
BLAS/SRC/srotmg.c | 295 ++
BLAS/SRC/ssbmv.c | 364 ++
BLAS/SRC/sscal.c | 95 +
BLAS/SRC/sspmv.c | 311 ++
BLAS/SRC/sspr.c | 237 ++
BLAS/SRC/sspr2.c | 269 ++
BLAS/SRC/sswap.c | 114 +
BLAS/SRC/ssymm.c | 362 ++
BLAS/SRC/ssymv.c | 313 ++
BLAS/SRC/ssyr.c | 238 ++
BLAS/SRC/ssyr2.c | 274 ++
BLAS/SRC/ssyr2k.c | 409 ++
BLAS/SRC/ssyrk.c | 372 ++
BLAS/SRC/stbmv.c | 422 +++
BLAS/SRC/stbsv.c | 426 +++
BLAS/SRC/stpmv.c | 357 ++
BLAS/SRC/stpsv.c | 360 ++
BLAS/SRC/strmm.c | 453 +++
BLAS/SRC/strmv.c | 345 ++
BLAS/SRC/strsm.c | 490 +++
BLAS/SRC/strsv.c | 348 ++
BLAS/SRC/xerbla.c | 76 +
BLAS/SRC/xerbla_array.c | 102 +
BLAS/SRC/zaxpy.c | 99 +
BLAS/SRC/zcopy.c | 85 +
BLAS/SRC/zdotc.c | 105 +
BLAS/SRC/zdotu.c | 100 +
BLAS/SRC/zdrot.c | 153 +
BLAS/SRC/zdscal.c | 85 +
BLAS/SRC/zgbmv.c | 478 +++
BLAS/SRC/zgemm.c | 698 ++++
BLAS/SRC/zgemv.c | 412 ++
BLAS/SRC/zgerc.c | 218 ++
BLAS/SRC/zgeru.c | 215 ++
BLAS/SRC/zhbmv.c | 483 +++
BLAS/SRC/zhemm.c | 496 +++
BLAS/SRC/zhemv.c | 433 +++
BLAS/SRC/zher.c | 338 ++
BLAS/SRC/zher2.c | 447 +++
BLAS/SRC/zher2k.c | 671 ++++
BLAS/SRC/zherk.c | 533 +++
BLAS/SRC/zhpmv.c | 434 +++
BLAS/SRC/zhpr.c | 339 ++
BLAS/SRC/zhpr2.c | 448 +++
BLAS/SRC/zrotg.c | 77 +
BLAS/SRC/zscal.c | 81 +
BLAS/SRC/zswap.c | 93 +
BLAS/SRC/zsymm.c | 496 +++
BLAS/SRC/zsyr2k.c | 538 +++
BLAS/SRC/zsyrk.c | 457 +++
BLAS/SRC/ztbmv.c | 642 ++++
BLAS/SRC/ztbsv.c | 611 +++
BLAS/SRC/ztpmv.c | 571 +++
BLAS/SRC/ztpsv.c | 540 +++
BLAS/SRC/ztrmm.c | 688 ++++
BLAS/SRC/ztrmv.c | 554 +++
BLAS/SRC/ztrsm.c | 699 ++++
BLAS/SRC/ztrsv.c | 524 +++
BLAS/TESTING/CMakeLists.txt | 63 +
BLAS/TESTING/Makeblat1 | 74 +
BLAS/TESTING/Makeblat2 | 74 +
BLAS/TESTING/Makeblat3 | 74 +
BLAS/TESTING/cblat1.c | 789 ++++
BLAS/TESTING/cblat2.c | 5349 ++++++++++++++++++++++++++
BLAS/TESTING/cblat3.c | 5425 +++++++++++++++++++++++++++
BLAS/TESTING/dblat1.c | 876 +++++
BLAS/TESTING/dblat2.c | 5043 +++++++++++++++++++++++++
BLAS/TESTING/dblat3.c | 4348 +++++++++++++++++++++
BLAS/TESTING/sblat1.c | 883 +++++
BLAS/TESTING/sblat2.c | 5007 +++++++++++++++++++++++++
BLAS/TESTING/sblat3.c | 4324 +++++++++++++++++++++
BLAS/TESTING/zblat1.c | 771 ++++
BLAS/TESTING/zblat2.c | 5399 +++++++++++++++++++++++++++
BLAS/TESTING/zblat3.c | 5457 +++++++++++++++++++++++++++
BLAS/cblat2.in | 35 +
BLAS/cblat3.in | 23 +
BLAS/dblat2.in | 34 +
BLAS/dblat3.in | 20 +
BLAS/sblat2.in | 34 +
BLAS/sblat3.in | 20 +
BLAS/zblat2.in | 35 +
BLAS/zblat3.in | 23 +
CMakeLists.txt | 34 +
COPYING | 36 +
CTestConfig.cmake | 13 +
F2CLIBS/CMakeLists.txt | 1 +
F2CLIBS/libf2c/CMakeLists.txt | 62 +
F2CLIBS/libf2c/Makefile | 207 +
F2CLIBS/libf2c/Notice | 23 +
F2CLIBS/libf2c/README | 374 ++
F2CLIBS/libf2c/abort_.c | 22 +
F2CLIBS/libf2c/arithchk.c | 245 ++
F2CLIBS/libf2c/backspac.c | 76 +
F2CLIBS/libf2c/c_abs.c | 20 +
F2CLIBS/libf2c/c_cos.c | 23 +
F2CLIBS/libf2c/c_div.c | 53 +
F2CLIBS/libf2c/c_exp.c | 25 +
F2CLIBS/libf2c/c_log.c | 23 +
F2CLIBS/libf2c/c_sin.c | 23 +
F2CLIBS/libf2c/c_sqrt.c | 41 +
F2CLIBS/libf2c/cabs.c | 33 +
F2CLIBS/libf2c/close.c | 101 +
F2CLIBS/libf2c/comptry.bat | 5 +
F2CLIBS/libf2c/ctype.c | 2 +
F2CLIBS/libf2c/ctype.h | 47 +
F2CLIBS/libf2c/d_abs.c | 18 +
F2CLIBS/libf2c/d_acos.c | 19 +
F2CLIBS/libf2c/d_asin.c | 19 +
F2CLIBS/libf2c/d_atan.c | 19 +
F2CLIBS/libf2c/d_atn2.c | 19 +
F2CLIBS/libf2c/d_cnjg.c | 19 +
F2CLIBS/libf2c/d_cos.c | 19 +
F2CLIBS/libf2c/d_cosh.c | 19 +
F2CLIBS/libf2c/d_dim.c | 16 +
F2CLIBS/libf2c/d_exp.c | 19 +
F2CLIBS/libf2c/d_imag.c | 16 +
F2CLIBS/libf2c/d_int.c | 19 +
F2CLIBS/libf2c/d_lg10.c | 21 +
F2CLIBS/libf2c/d_log.c | 19 +
F2CLIBS/libf2c/d_mod.c | 46 +
F2CLIBS/libf2c/d_nint.c | 20 +
F2CLIBS/libf2c/d_prod.c | 16 +
F2CLIBS/libf2c/d_sign.c | 18 +
F2CLIBS/libf2c/d_sin.c | 19 +
F2CLIBS/libf2c/d_sinh.c | 19 +
F2CLIBS/libf2c/d_sqrt.c | 19 +
F2CLIBS/libf2c/d_tan.c | 19 +
F2CLIBS/libf2c/d_tanh.c | 19 +
F2CLIBS/libf2c/derf_.c | 18 +
F2CLIBS/libf2c/derfc_.c | 20 +
F2CLIBS/libf2c/dfe.c | 151 +
F2CLIBS/libf2c/dolio.c | 26 +
F2CLIBS/libf2c/dtime_.c | 63 +
F2CLIBS/libf2c/due.c | 77 +
F2CLIBS/libf2c/ef1asc_.c | 25 +
F2CLIBS/libf2c/ef1cmc_.c | 20 +
F2CLIBS/libf2c/endfile.c | 160 +
F2CLIBS/libf2c/erf_.c | 22 +
F2CLIBS/libf2c/erfc_.c | 22 +
F2CLIBS/libf2c/err.c | 293 ++
F2CLIBS/libf2c/etime_.c | 57 +
F2CLIBS/libf2c/exit_.c | 43 +
F2CLIBS/libf2c/f2c.h | 223 ++
F2CLIBS/libf2c/f2ch.add | 162 +
F2CLIBS/libf2c/f77_aloc.c | 44 +
F2CLIBS/libf2c/f77vers.c | 97 +
F2CLIBS/libf2c/fio.h | 141 +
F2CLIBS/libf2c/fmt.c | 530 +++
F2CLIBS/libf2c/fmt.h | 105 +
F2CLIBS/libf2c/fmtlib.c | 51 +
F2CLIBS/libf2c/fp.h | 28 +
F2CLIBS/libf2c/ftell64_.c | 52 +
F2CLIBS/libf2c/ftell_.c | 52 +
F2CLIBS/libf2c/getarg_.c | 36 +
F2CLIBS/libf2c/getenv_.c | 62 +
F2CLIBS/libf2c/h_abs.c | 18 +
F2CLIBS/libf2c/h_dim.c | 16 +
F2CLIBS/libf2c/h_dnnt.c | 19 +
F2CLIBS/libf2c/h_indx.c | 32 +
F2CLIBS/libf2c/h_len.c | 16 +
F2CLIBS/libf2c/h_mod.c | 16 +
F2CLIBS/libf2c/h_nint.c | 19 +
F2CLIBS/libf2c/h_sign.c | 18 +
F2CLIBS/libf2c/hl_ge.c | 18 +
F2CLIBS/libf2c/hl_gt.c | 18 +
F2CLIBS/libf2c/hl_le.c | 18 +
F2CLIBS/libf2c/hl_lt.c | 18 +
F2CLIBS/libf2c/i77vers.c | 343 ++
F2CLIBS/libf2c/i_abs.c | 18 +
F2CLIBS/libf2c/i_ceiling.c | 36 +
F2CLIBS/libf2c/i_dim.c | 16 +
F2CLIBS/libf2c/i_dnnt.c | 19 +
F2CLIBS/libf2c/i_indx.c | 32 +
F2CLIBS/libf2c/i_len.c | 16 +
F2CLIBS/libf2c/i_len_trim.c | 22 +
F2CLIBS/libf2c/i_mod.c | 16 +
F2CLIBS/libf2c/i_nint.c | 19 +
F2CLIBS/libf2c/i_sign.c | 18 +
F2CLIBS/libf2c/iargc_.c | 17 +
F2CLIBS/libf2c/iio.c | 159 +
F2CLIBS/libf2c/ilnw.c | 83 +
F2CLIBS/libf2c/inquire.c | 117 +
F2CLIBS/libf2c/l_ge.c | 18 +
F2CLIBS/libf2c/l_gt.c | 18 +
F2CLIBS/libf2c/l_le.c | 18 +
F2CLIBS/libf2c/l_lt.c | 18 +
F2CLIBS/libf2c/lbitbits.c | 68 +
F2CLIBS/libf2c/lbitshft.c | 17 +
F2CLIBS/libf2c/libf2c.lbc | 153 +
F2CLIBS/libf2c/libf2c.sy | 153 +
F2CLIBS/libf2c/lio.h | 74 +
F2CLIBS/libf2c/lread.c | 806 ++++
F2CLIBS/libf2c/lwrite.c | 314 ++
F2CLIBS/libf2c/main.c | 148 +
F2CLIBS/libf2c/math.hvc | 3 +
F2CLIBS/libf2c/mkfile.plan9 | 162 +
F2CLIBS/libf2c/open.c | 301 ++
F2CLIBS/libf2c/pow_ci.c | 26 +
F2CLIBS/libf2c/pow_dd.c | 19 +
F2CLIBS/libf2c/pow_di.c | 41 +
F2CLIBS/libf2c/pow_hh.c | 39 +
F2CLIBS/libf2c/pow_ii.c | 39 +
F2CLIBS/libf2c/pow_qq.c | 39 +
F2CLIBS/libf2c/pow_ri.c | 41 +
F2CLIBS/libf2c/pow_zi.c | 60 +
F2CLIBS/libf2c/pow_zz.c | 29 +
F2CLIBS/libf2c/qbitbits.c | 72 +
F2CLIBS/libf2c/qbitshft.c | 17 +
F2CLIBS/libf2c/r_abs.c | 18 +
F2CLIBS/libf2c/r_acos.c | 19 +
F2CLIBS/libf2c/r_asin.c | 19 +
F2CLIBS/libf2c/r_atan.c | 19 +
F2CLIBS/libf2c/r_atn2.c | 19 +
F2CLIBS/libf2c/r_cnjg.c | 18 +
F2CLIBS/libf2c/r_cos.c | 19 +
F2CLIBS/libf2c/r_cosh.c | 19 +
F2CLIBS/libf2c/r_dim.c | 16 +
F2CLIBS/libf2c/r_exp.c | 19 +
F2CLIBS/libf2c/r_imag.c | 16 +
F2CLIBS/libf2c/r_int.c | 19 +
F2CLIBS/libf2c/r_lg10.c | 21 +
F2CLIBS/libf2c/r_log.c | 19 +
F2CLIBS/libf2c/r_mod.c | 46 +
F2CLIBS/libf2c/r_nint.c | 20 +
F2CLIBS/libf2c/r_sign.c | 18 +
F2CLIBS/libf2c/r_sin.c | 19 +
F2CLIBS/libf2c/r_sinh.c | 19 +
F2CLIBS/libf2c/r_sqrt.c | 19 +
F2CLIBS/libf2c/r_tan.c | 19 +
F2CLIBS/libf2c/r_tanh.c | 19 +
F2CLIBS/libf2c/rawio.h | 41 +
F2CLIBS/libf2c/rdfmt.c | 553 +++
F2CLIBS/libf2c/rewind.c | 30 +
F2CLIBS/libf2c/rsfe.c | 91 +
F2CLIBS/libf2c/rsli.c | 109 +
F2CLIBS/libf2c/rsne.c | 618 +++
F2CLIBS/libf2c/s_cat.c | 86 +
F2CLIBS/libf2c/s_cmp.c | 50 +
F2CLIBS/libf2c/s_copy.c | 57 +
F2CLIBS/libf2c/s_paus.c | 96 +
F2CLIBS/libf2c/s_rnge.c | 32 +
F2CLIBS/libf2c/s_stop.c | 48 +
F2CLIBS/libf2c/scomptry.bat | 5 +
F2CLIBS/libf2c/sfe.c | 47 +
F2CLIBS/libf2c/sig_die.c | 51 +
F2CLIBS/libf2c/signal1.h | 35 +
F2CLIBS/libf2c/signal_.c | 21 +
F2CLIBS/libf2c/signbit.c | 24 +
F2CLIBS/libf2c/sue.c | 90 +
F2CLIBS/libf2c/sysdep1.h | 66 +
F2CLIBS/libf2c/system_.c | 42 +
F2CLIBS/libf2c/typesize.c | 18 +
F2CLIBS/libf2c/uio.c | 75 +
F2CLIBS/libf2c/uninit.c | 377 ++
F2CLIBS/libf2c/util.c | 57 +
F2CLIBS/libf2c/wref.c | 294 ++
F2CLIBS/libf2c/wrtfmt.c | 377 ++
F2CLIBS/libf2c/wsfe.c | 78 +
F2CLIBS/libf2c/wsle.c | 42 +
F2CLIBS/libf2c/wsne.c | 32 +
F2CLIBS/libf2c/xwsne.c | 77 +
F2CLIBS/libf2c/z_abs.c | 18 +
F2CLIBS/libf2c/z_cos.c | 21 +
F2CLIBS/libf2c/z_div.c | 50 +
F2CLIBS/libf2c/z_exp.c | 23 +
F2CLIBS/libf2c/z_log.c | 121 +
F2CLIBS/libf2c/z_sin.c | 21 +
F2CLIBS/libf2c/z_sqrt.c | 35 +
INCLUDE/blaswrap.h | 160 +
INCLUDE/clapack.h | 7254 ++++++++++++++++++++++++++++++++++++
INCLUDE/f2c.h | 223 ++
INSTALL/LAPACK_version.c | 53 +
INSTALL/Makefile | 34 +
INSTALL/dlamch.c | 1001 +++++
INSTALL/dlamchtst.c | 120 +
INSTALL/dsecnd.c | 18 +
INSTALL/dsecndtst.c | 162 +
INSTALL/ilaver.c | 50 +
INSTALL/lawn81.pdf | Bin 0 -> 217666 bytes
INSTALL/lawn81.tex | 1688 +++++++++
INSTALL/lsame.c | 117 +
INSTALL/lsametst.c | 172 +
INSTALL/psfig.tex | 391 ++
INSTALL/second.c | 17 +
INSTALL/secondtst.c | 162 +
INSTALL/slamch.c | 1000 +++++
INSTALL/slamchtst.c | 120 +
INSTALL/tstiee.c | 893 +++++
INSTALL/windsecnd.c | 27 +
INSTALL/winsecond.c | 27 +
Makefile | 93 +
README.install | 223 ++
SRC/CMakeLists.txt | 380 ++
SRC/Makefile | 423 +++
SRC/VARIANTS/Makefile | 67 +
SRC/VARIANTS/README | 84 +
SRC/VARIANTS/cholesky/RL/cpotrf.c | 233 ++
SRC/VARIANTS/cholesky/RL/dpotrf.c | 233 ++
SRC/VARIANTS/cholesky/RL/spotrf.c | 231 ++
SRC/VARIANTS/cholesky/RL/zpotrf.c | 233 ++
SRC/VARIANTS/cholesky/TOP/cpotrf.c | 227 ++
SRC/VARIANTS/cholesky/TOP/dpotrf.c | 225 ++
SRC/VARIANTS/cholesky/TOP/spotrf.c | 223 ++
SRC/VARIANTS/cholesky/TOP/zpotrf.c | 227 ++
SRC/VARIANTS/lu/CR/cgetrf.c | 224 ++
SRC/VARIANTS/lu/CR/dgetrf.c | 222 ++
SRC/VARIANTS/lu/CR/sgetrf.c | 220 ++
SRC/VARIANTS/lu/CR/zgetrf.c | 223 ++
SRC/VARIANTS/lu/LL/cgetrf.c | 260 ++
SRC/VARIANTS/lu/LL/dgetrf.c | 257 ++
SRC/VARIANTS/lu/LL/sgetrf.c | 256 ++
SRC/VARIANTS/lu/LL/zgetrf.c | 259 ++
SRC/VARIANTS/lu/REC/cgetrf.c | 280 ++
SRC/VARIANTS/lu/REC/dgetrf.c | 268 ++
SRC/VARIANTS/lu/REC/sgetrf.c | 268 ++
SRC/VARIANTS/lu/REC/zgetrf.c | 282 ++
SRC/VARIANTS/qr/LL/cgeqrf.c | 405 ++
SRC/VARIANTS/qr/LL/dgeqrf.c | 403 ++
SRC/VARIANTS/qr/LL/sceil.c | 44 +
SRC/VARIANTS/qr/LL/sgeqrf.c | 403 ++
SRC/VARIANTS/qr/LL/zgeqrf.c | 410 ++
SRC/cbdsqr.c | 912 +++++
SRC/cgbbrd.c | 649 ++++
SRC/cgbcon.c | 307 ++
SRC/cgbequ.c | 329 ++
SRC/cgbequb.c | 353 ++
SRC/cgbrfs.c | 492 +++
SRC/cgbrfsx.c | 686 ++++
SRC/cgbsv.c | 176 +
SRC/cgbsvx.c | 675 ++++
SRC/cgbsvxx.c | 747 ++++
SRC/cgbtf2.c | 267 ++
SRC/cgbtrf.c | 604 +++
SRC/cgbtrs.c | 281 ++
SRC/cgebak.c | 236 ++
SRC/cgebal.c | 414 ++
SRC/cgebd2.c | 345 ++
SRC/cgebrd.c | 348 ++
SRC/cgecon.c | 233 ++
SRC/cgeequ.c | 306 ++
SRC/cgeequb.c | 331 ++
SRC/cgees.c | 404 ++
SRC/cgeesx.c | 472 +++
SRC/cgeev.c | 529 +++
SRC/cgeevx.c | 680 ++++
SRC/cgegs.c | 536 +++
SRC/cgegv.c | 779 ++++
SRC/cgehd2.c | 198 +
SRC/cgehrd.c | 350 ++
SRC/cgelq2.c | 165 +
SRC/cgelqf.c | 252 ++
SRC/cgels.c | 520 +++
SRC/cgelsd.c | 717 ++++
SRC/cgelss.c | 822 ++++
SRC/cgelsx.c | 468 +++
SRC/cgelsy.c | 512 +++
SRC/cgeql2.c | 167 +
SRC/cgeqlf.c | 271 ++
SRC/cgeqp3.c | 361 ++
SRC/cgeqpf.c | 315 ++
SRC/cgeqr2.c | 169 +
SRC/cgeqrf.c | 253 ++
SRC/cgerfs.c | 460 +++
SRC/cgerfsx.c | 666 ++++
SRC/cgerq2.c | 162 +
SRC/cgerqf.c | 270 ++
SRC/cgesc2.c | 206 +
SRC/cgesdd.c | 2240 +++++++++++
SRC/cgesv.c | 138 +
SRC/cgesvd.c | 4164 +++++++++++++++++++++
SRC/cgesvx.c | 605 +++
SRC/cgesvxx.c | 714 ++++
SRC/cgetc2.c | 208 ++
SRC/cgetf2.c | 202 +
SRC/cgetrf.c | 220 ++
SRC/cgetri.c | 271 ++
SRC/cgetrs.c | 186 +
SRC/cggbak.c | 274 ++
SRC/cggbal.c | 652 ++++
SRC/cgges.c | 596 +++
SRC/cggesx.c | 701 ++++
SRC/cggev.c | 592 +++
SRC/cggevx.c | 802 ++++
SRC/cggglm.c | 334 ++
SRC/cgghrd.c | 336 ++
SRC/cgglse.c | 342 ++
SRC/cggqrf.c | 268 ++
SRC/cggrqf.c | 269 ++
SRC/cggsvd.c | 403 ++
SRC/cggsvp.c | 530 +++
SRC/cgtcon.c | 207 +
SRC/cgtrfs.c | 553 +++
SRC/cgtsv.c | 287 ++
SRC/cgtsvx.c | 347 ++
SRC/cgttrf.c | 274 ++
SRC/cgttrs.c | 192 +
SRC/cgtts2.c | 583 +++
SRC/chbev.c | 270 ++
SRC/chbevd.c | 377 ++
SRC/chbevx.c | 524 +++
SRC/chbgst.c | 2146 +++++++++++
SRC/chbgv.c | 235 ++
SRC/chbgvd.c | 355 ++
SRC/chbgvx.c | 472 +++
SRC/chbtrd.c | 808 ++++
SRC/checon.c | 201 +
SRC/cheequb.c | 440 +++
SRC/cheev.c | 284 ++
SRC/cheevd.c | 377 ++
SRC/cheevr.c | 687 ++++
SRC/cheevx.c | 542 +++
SRC/chegs2.c | 334 ++
SRC/chegst.c | 350 ++
SRC/chegv.c | 286 ++
SRC/chegvd.c | 364 ++
SRC/chegvx.c | 394 ++
SRC/cherfs.c | 472 +++
SRC/cherfsx.c | 627 ++++
SRC/chesv.c | 214 ++
SRC/chesvx.c | 368 ++
SRC/chesvxx.c | 627 ++++
SRC/chetd2.c | 358 ++
SRC/chetf2.c | 802 ++++
SRC/chetrd.c | 369 ++
SRC/chetrf.c | 334 ++
SRC/chetri.c | 510 +++
SRC/chetrs.c | 528 +++
SRC/chfrk.c | 530 +++
SRC/chgeqz.c | 1143 ++++++
SRC/chla_transtype.c | 62 +
SRC/chpcon.c | 195 +
SRC/chpev.c | 249 ++
SRC/chpevd.c | 346 ++
SRC/chpevx.c | 471 +++
SRC/chpgst.c | 312 ++
SRC/chpgv.c | 244 ++
SRC/chpgvd.c | 356 ++
SRC/chpgvx.c | 343 ++
SRC/chprfs.c | 462 +++
SRC/chpsv.c | 176 +
SRC/chpsvx.c | 320 ++
SRC/chptrd.c | 318 ++
SRC/chptrf.c | 821 ++++
SRC/chptri.c | 512 +++
SRC/chptrs.c | 530 +++
SRC/chsein.c | 432 +++
SRC/chseqr.c | 480 +++
SRC/cla_gbamv.c | 336 ++
SRC/cla_gbrcond_c.c | 349 ++
SRC/cla_gbrcond_x.c | 320 ++
SRC/cla_gbrfsx_extended.c | 643 ++++
SRC/cla_gbrpvgrw.c | 147 +
SRC/cla_geamv.c | 313 ++
SRC/cla_gercond_c.c | 307 ++
SRC/cla_gercond_x.c | 287 ++
SRC/cla_gerfsx_extended.c | 632 ++++
SRC/cla_heamv.c | 327 ++
SRC/cla_hercond_c.c | 330 ++
SRC/cla_hercond_x.c | 308 ++
SRC/cla_herfsx_extended.c | 621 +++
SRC/cla_herpvgrw.c | 355 ++
SRC/cla_lin_berr.c | 136 +
SRC/cla_porcond_c.c | 325 ++
SRC/cla_porcond_x.c | 303 ++
SRC/cla_porfsx_extended.c | 616 +++
SRC/cla_porpvgrw.c | 207 +
SRC/cla_rpvgrw.c | 128 +
SRC/cla_syamv.c | 327 ++
SRC/cla_syrcond_c.c | 330 ++
SRC/cla_syrcond_x.c | 308 ++
SRC/cla_syrfsx_extended.c | 622 ++++
SRC/cla_syrpvgrw.c | 355 ++
SRC/cla_wwaddw.c | 94 +
SRC/clabrd.c | 500 +++
SRC/clacgv.c | 95 +
SRC/clacn2.c | 283 ++
SRC/clacon.c | 275 ++
SRC/clacp2.c | 134 +
SRC/clacpy.c | 134 +
SRC/clacrm.c | 176 +
SRC/clacrt.c | 155 +
SRC/cladiv.c | 74 +
SRC/claed0.c | 367 ++
SRC/claed7.c | 325 ++
SRC/claed8.c | 436 +++
SRC/claein.c | 392 ++
SRC/claesy.c | 206 +
SRC/claev2.c | 123 +
SRC/clag2z.c | 101 +
SRC/clags2.c | 465 +++
SRC/clagtm.c | 598 +++
SRC/clahef.c | 933 +++++
SRC/clahqr.c | 754 ++++
SRC/clahr2.c | 329 ++
SRC/clahrd.c | 298 ++
SRC/claic1.c | 448 +++
SRC/clals0.c | 558 +++
SRC/clalsa.c | 663 ++++
SRC/clalsd.c | 755 ++++
SRC/clangb.c | 224 ++
SRC/clange.c | 199 +
SRC/clangt.c | 195 +
SRC/clanhb.c | 291 ++
SRC/clanhe.c | 265 ++
SRC/clanhf.c | 1803 +++++++++
SRC/clanhp.c | 277 ++
SRC/clanhs.c | 205 +
SRC/clanht.c | 166 +
SRC/clansb.c | 261 ++
SRC/clansp.c | 278 ++
SRC/clansy.c | 237 ++
SRC/clantb.c | 426 +++
SRC/clantp.c | 391 ++
SRC/clantr.c | 394 ++
SRC/clapll.c | 143 +
SRC/clapmt.c | 185 +
SRC/claqgb.c | 227 ++
SRC/claqge.c | 202 +
SRC/claqhb.c | 200 +
SRC/claqhe.c | 192 +
SRC/claqhp.c | 189 +
SRC/claqp2.c | 244 ++
SRC/claqps.c | 367 ++
SRC/claqr0.c | 784 ++++
SRC/claqr1.c | 197 +
SRC/claqr2.c | 603 +++
SRC/claqr3.c | 620 +++
SRC/claqr4.c | 782 ++++
SRC/claqr5.c | 1345 +++++++
SRC/claqsb.c | 192 +
SRC/claqsp.c | 179 +
SRC/claqsy.c | 182 +
SRC/clar1v.c | 500 +++
SRC/clar2v.c | 159 +
SRC/clarcm.c | 176 +
SRC/clarf.c | 198 +
SRC/clarfb.c | 837 +++++
SRC/clarfg.c | 190 +
SRC/clarfp.c | 234 ++
SRC/clarft.c | 361 ++
SRC/clarfx.c | 2048 ++++++++++
SRC/clargv.c | 335 ++
SRC/clarnv.c | 190 +
SRC/clarrv.c | 1015 +++++
SRC/clarscl2.c | 95 +
SRC/clartg.c | 284 ++
SRC/clartv.c | 125 +
SRC/clarz.c | 198 +
SRC/clarzb.c | 323 ++
SRC/clarzt.c | 236 ++
SRC/clascl.c | 377 ++
SRC/clascl2.c | 95 +
SRC/claset.c | 162 +
SRC/clasr.c | 609 +++
SRC/classq.c | 138 +
SRC/claswp.c | 166 +
SRC/clasyf.c | 829 ++++
SRC/clatbs.c | 1193 ++++++
SRC/clatdf.c | 357 ++
SRC/clatps.c | 1161 ++++++
SRC/clatrd.c | 418 +++
SRC/clatrs.c | 1147 ++++++
SRC/clatrz.c | 180 +
SRC/clatzm.c | 196 +
SRC/clauu2.c | 203 +
SRC/clauum.c | 217 ++
SRC/cpbcon.c | 238 ++
SRC/cpbequ.c | 204 +
SRC/cpbrfs.c | 482 +++
SRC/cpbstf.c | 334 ++
SRC/cpbsv.c | 182 +
SRC/cpbsvx.c | 523 +++
SRC/cpbtf2.c | 255 ++
SRC/cpbtrf.c | 489 +++
SRC/cpbtrs.c | 184 +
SRC/cpftrf.c | 475 +++
SRC/cpftri.c | 425 +++
SRC/cpftrs.c | 260 ++
SRC/cpocon.c | 224 ++
SRC/cpoequ.c | 176 +
SRC/cpoequb.c | 195 +
SRC/cporfs.c | 465 +++
SRC/cporfsx.c | 620 +++
SRC/cposv.c | 151 +
SRC/cposvx.c | 458 +++
SRC/cposvxx.c | 613 +++
SRC/cpotf2.c | 245 ++
SRC/cpotrf.c | 248 ++
SRC/cpotri.c | 125 +
SRC/cpotrs.c | 165 +
SRC/cppcon.c | 222 ++
SRC/cppequ.c | 210 ++
SRC/cpprfs.c | 457 +++
SRC/cppsv.c | 160 +
SRC/cppsvx.c | 461 +++
SRC/cpptrf.c | 234 ++
SRC/cpptri.c | 180 +
SRC/cpptrs.c | 170 +
SRC/cpstf2.c | 442 +++
SRC/cpstrf.c | 521 +++
SRC/cptcon.c | 186 +
SRC/cpteqr.c | 241 ++
SRC/cptrfs.c | 574 +++
SRC/cptsv.c | 129 +
SRC/cptsvx.c | 285 ++
SRC/cpttrf.c | 215 ++
SRC/cpttrs.c | 176 +
SRC/cptts2.c | 315 ++
SRC/crot.c | 155 +
SRC/cspcon.c | 195 +
SRC/cspmv.c | 428 +++
SRC/cspr.c | 339 ++
SRC/csprfs.c | 464 +++
SRC/cspsv.c | 176 +
SRC/cspsvx.c | 323 ++
SRC/csptrf.c | 763 ++++
SRC/csptri.c | 508 +++
SRC/csptrs.c | 502 +++
SRC/csrscl.c | 134 +
SRC/cstedc.c | 496 +++
SRC/cstegr.c | 210 ++
SRC/cstein.c | 468 +++
SRC/cstemr.c | 749 ++++
SRC/csteqr.c | 620 +++
SRC/csycon.c | 201 +
SRC/csyequb.c | 451 +++
SRC/csymv.c | 429 +++
SRC/csyr.c | 289 ++
SRC/csyrfs.c | 473 +++
SRC/csyrfsx.c | 627 ++++
SRC/csysv.c | 214 ++
SRC/csysvx.c | 368 ++
SRC/csysvxx.c | 631 ++++
SRC/csytf2.c | 727 ++++
SRC/csytrf.c | 340 ++
SRC/csytri.c | 489 +++
SRC/csytrs.c | 502 +++
SRC/ctbcon.c | 255 ++
SRC/ctbrfs.c | 584 +++
SRC/ctbtrs.c | 206 +
SRC/ctfsm.c | 1024 +++++
SRC/ctftri.c | 500 +++
SRC/ctfttp.c | 576 +++
SRC/ctfttr.c | 580 +++
SRC/ctgevc.c | 971 +++++
SRC/ctgex2.c | 373 ++
SRC/ctgexc.c | 248 ++
SRC/ctgsen.c | 762 ++++
SRC/ctgsja.c | 671 ++++
SRC/ctgsna.c | 484 +++
SRC/ctgsy2.c | 477 +++
SRC/ctgsyl.c | 689 ++++
SRC/ctpcon.c | 240 ++
SRC/ctprfs.c | 565 +++
SRC/ctptri.c | 236 ++
SRC/ctptrs.c | 194 +
SRC/ctpttf.c | 573 +++
SRC/ctpttr.c | 148 +
SRC/ctrcon.c | 249 ++
SRC/ctrevc.c | 532 +++
SRC/ctrexc.c | 215 ++
SRC/ctrrfs.c | 562 +++
SRC/ctrsen.c | 422 +++
SRC/ctrsna.c | 445 +++
SRC/ctrsyl.c | 544 +++
SRC/ctrti2.c | 198 +
SRC/ctrtri.c | 244 ++
SRC/ctrtrs.c | 184 +
SRC/ctrttf.c | 580 +++
SRC/ctrttp.c | 148 +
SRC/ctzrqf.c | 241 ++
SRC/ctzrzf.c | 310 ++
SRC/cung2l.c | 182 +
SRC/cung2r.c | 184 +
SRC/cungbr.c | 309 ++
SRC/cunghr.c | 223 ++
SRC/cungl2.c | 193 +
SRC/cunglq.c | 284 ++
SRC/cungql.c | 293 ++
SRC/cungqr.c | 285 ++
SRC/cungr2.c | 192 +
SRC/cungrq.c | 293 ++
SRC/cungtr.c | 260 ++
SRC/cunm2l.c | 245 ++
SRC/cunm2r.c | 249 ++
SRC/cunmbr.c | 373 ++
SRC/cunmhr.c | 257 ++
SRC/cunml2.c | 254 ++
SRC/cunmlq.c | 335 ++
SRC/cunmql.c | 328 ++
SRC/cunmqr.c | 328 ++
SRC/cunmr2.c | 246 ++
SRC/cunmr3.c | 253 ++
SRC/cunmrq.c | 336 ++
SRC/cunmrz.c | 370 ++
SRC/cunmtr.c | 294 ++
SRC/cupgtr.c | 219 ++
SRC/cupmtr.c | 320 ++
SRC/dbdsdc.c | 514 +++
SRC/dbdsqr.c | 918 +++++
SRC/ddisna.c | 227 ++
SRC/dgbbrd.c | 566 +++
SRC/dgbcon.c | 284 ++
SRC/dgbequ.c | 320 ++
SRC/dgbequb.c | 347 ++
SRC/dgbrfs.c | 455 +++
SRC/dgbrfsx.c | 687 ++++
SRC/dgbsv.c | 176 +
SRC/dgbsvx.c | 650 ++++
SRC/dgbsvxx.c | 745 ++++
SRC/dgbtf2.c | 262 ++
SRC/dgbtrf.c | 588 +++
SRC/dgbtrs.c | 244 ++
SRC/dgebak.c | 237 ++
SRC/dgebal.c | 402 ++
SRC/dgebd2.c | 304 ++
SRC/dgebrd.c | 336 ++
SRC/dgecon.c | 226 ++
SRC/dgeequ.c | 296 ++
SRC/dgeequb.c | 324 ++
SRC/dgees.c | 549 +++
SRC/dgeesx.c | 649 ++++
SRC/dgeev.c | 566 +++
SRC/dgeevx.c | 703 ++++
SRC/dgegs.c | 548 +++
SRC/dgegv.c | 842 +++++
SRC/dgehd2.c | 191 +
SRC/dgehrd.c | 342 ++
SRC/dgejsv.c | 2218 +++++++++++
SRC/dgelq2.c | 157 +
SRC/dgelqf.c | 251 ++
SRC/dgels.c | 515 +++
SRC/dgelsd.c | 693 ++++
SRC/dgelss.c | 828 ++++
SRC/dgelsx.c | 438 +++
SRC/dgelsy.c | 495 +++
SRC/dgeql2.c | 159 +
SRC/dgeqlf.c | 270 ++
SRC/dgeqp3.c | 358 ++
SRC/dgeqpf.c | 304 ++
SRC/dgeqr2.c | 161 +
SRC/dgeqrf.c | 252 ++
SRC/dgerfs.c | 424 +++
SRC/dgerfsx.c | 666 ++++
SRC/dgerq2.c | 155 +
SRC/dgerqf.c | 269 ++
SRC/dgesc2.c | 176 +
SRC/dgesdd.c | 1609 ++++++++
SRC/dgesv.c | 138 +
SRC/dgesvd.c | 4050 ++++++++++++++++++++
SRC/dgesvj.c | 1796 +++++++++
SRC/dgesvx.c | 587 +++
SRC/dgesvxx.c | 713 ++++
SRC/dgetc2.c | 199 +
SRC/dgetf2.c | 193 +
SRC/dgetrf.c | 219 ++
SRC/dgetri.c | 264 ++
SRC/dgetrs.c | 186 +
SRC/dggbak.c | 276 ++
SRC/dggbal.c | 627 ++++
SRC/dgges.c | 692 ++++
SRC/dggesx.c | 818 ++++
SRC/dggev.c | 641 ++++
SRC/dggevx.c | 885 +++++
SRC/dggglm.c | 331 ++
SRC/dgghrd.c | 329 ++
SRC/dgglse.c | 340 ++
SRC/dggqrf.c | 267 ++
SRC/dggrqf.c | 268 ++
SRC/dggsvd.c | 405 ++
SRC/dggsvp.c | 512 +++
SRC/dgsvj0.c | 1159 ++++++
SRC/dgsvj1.c | 798 ++++
SRC/dgtcon.c | 209 ++
SRC/dgtrfs.c | 451 +++
SRC/dgtsv.c | 315 ++
SRC/dgtsvx.c | 349 ++
SRC/dgttrf.c | 203 +
SRC/dgttrs.c | 189 +
SRC/dgtts2.c | 261 ++
SRC/dhgeqz.c | 1498 ++++++++
SRC/dhsein.c | 491 +++
SRC/dhseqr.c | 487 +++
SRC/disnan.c | 52 +
SRC/dla_gbamv.c | 316 ++
SRC/dla_gbrcond.c | 345 ++
SRC/dla_gbrfsx_extended.c | 630 ++++
SRC/dla_gbrpvgrw.c | 136 +
SRC/dla_geamv.c | 293 ++
SRC/dla_gercond.c | 299 ++
SRC/dla_gerfsx_extended.c | 622 ++++
SRC/dla_lin_berr.c | 124 +
SRC/dla_porcond.c | 309 ++
SRC/dla_porfsx_extended.c | 602 +++
SRC/dla_porpvgrw.c | 197 +
SRC/dla_rpvgrw.c | 117 +
SRC/dla_syamv.c | 299 ++
SRC/dla_syrcond.c | 322 ++
SRC/dla_syrfsx_extended.c | 608 +++
SRC/dla_syrpvgrw.c | 330 ++
SRC/dla_wwaddw.c | 80 +
SRC/dlabad.c | 72 +
SRC/dlabrd.c | 434 +++
SRC/dlacn2.c | 267 ++
SRC/dlacon.c | 258 ++
SRC/dlacpy.c | 125 +
SRC/dladiv.c | 78 +
SRC/dlae2.c | 142 +
SRC/dlaebz.c | 640 ++++
SRC/dlaed0.c | 440 +++
SRC/dlaed1.c | 249 ++
SRC/dlaed2.c | 532 +++
SRC/dlaed3.c | 338 ++
SRC/dlaed4.c | 954 +++++
SRC/dlaed5.c | 148 +
SRC/dlaed6.c | 374 ++
SRC/dlaed7.c | 354 ++
SRC/dlaed8.c | 475 +++
SRC/dlaed9.c | 274 ++
SRC/dlaeda.c | 287 ++
SRC/dlaein.c | 677 ++++
SRC/dlaev2.c | 188 +
SRC/dlaexc.c | 459 +++
SRC/dlag2.c | 356 ++
SRC/dlag2s.c | 115 +
SRC/dlags2.c | 292 ++
SRC/dlagtf.c | 224 ++
SRC/dlagtm.c | 254 ++
SRC/dlagts.c | 351 ++
SRC/dlagv2.c | 351 ++
SRC/dlahqr.c | 631 ++++
SRC/dlahr2.c | 315 ++
SRC/dlahrd.c | 285 ++
SRC/dlaic1.c | 326 ++
SRC/dlaisnan.c | 58 +
SRC/dlaln2.c | 575 +++
SRC/dlals0.c | 473 +++
SRC/dlalsa.c | 456 +++
SRC/dlalsd.c | 529 +++
SRC/dlamrg.c | 131 +
SRC/dlaneg.c | 218 ++
SRC/dlangb.c | 226 ++
SRC/dlange.c | 199 +
SRC/dlangt.c | 195 +
SRC/dlanhs.c | 205 +
SRC/dlansb.c | 263 ++
SRC/dlansf.c | 1012 +++++
SRC/dlansp.c | 263 ++
SRC/dlanst.c | 166 +
SRC/dlansy.c | 239 ++
SRC/dlantb.c | 434 +++
SRC/dlantp.c | 391 ++
SRC/dlantr.c | 398 ++
SRC/dlanv2.c | 235 ++
SRC/dlapll.c | 127 +
SRC/dlapmt.c | 178 +
SRC/dlapy2.c | 73 +
SRC/dlapy3.c | 83 +
SRC/dlaqgb.c | 216 ++
SRC/dlaqge.c | 188 +
SRC/dlaqp2.c | 237 ++
SRC/dlaqps.c | 345 ++
SRC/dlaqr0.c | 758 ++++
SRC/dlaqr1.c | 127 +
SRC/dlaqr2.c | 698 ++++
SRC/dlaqr3.c | 715 ++++
SRC/dlaqr4.c | 754 ++++
SRC/dlaqr5.c | 1025 +++++
SRC/dlaqsb.c | 185 +
SRC/dlaqsp.c | 169 +
SRC/dlaqsy.c | 172 +
SRC/dlaqtr.c | 832 +++++
SRC/dlar1v.c | 441 +++
SRC/dlar2v.c | 121 +
SRC/dlarf.c | 193 +
SRC/dlarfb.c | 774 ++++
SRC/dlarfg.c | 170 +
SRC/dlarfp.c | 192 +
SRC/dlarft.c | 325 ++
SRC/dlarfx.c | 730 ++++
SRC/dlargv.c | 130 +
SRC/dlarnv.c | 146 +
SRC/dlarra.c | 156 +
SRC/dlarrb.c | 350 ++
SRC/dlarrc.c | 183 +
SRC/dlarrd.c | 793 ++++
SRC/dlarre.c | 861 +++++
SRC/dlarrf.c | 423 +++
SRC/dlarrj.c | 338 ++
SRC/dlarrk.c | 193 +
SRC/dlarrr.c | 176 +
SRC/dlarrv.c | 988 +++++
SRC/dlarscl2.c | 90 +
SRC/dlartg.c | 190 +
SRC/dlartv.c | 106 +
SRC/dlaruv.c | 192 +
SRC/dlarz.c | 194 +
SRC/dlarzb.c | 288 ++
SRC/dlarzt.c | 229 ++
SRC/dlas2.c | 144 +
SRC/dlascl.c | 354 ++
SRC/dlascl2.c | 90 +
SRC/dlasd0.c | 291 ++
SRC/dlasd1.c | 288 ++
SRC/dlasd2.c | 609 +++
SRC/dlasd3.c | 452 +++
SRC/dlasd4.c | 1010 +++++
SRC/dlasd5.c | 189 +
SRC/dlasd6.c | 367 ++
SRC/dlasd7.c | 518 +++
SRC/dlasd8.c | 326 ++
SRC/dlasda.c | 488 +++
SRC/dlasdq.c | 380 ++
SRC/dlasdt.c | 136 +
SRC/dlaset.c | 152 +
SRC/dlasq1.c | 219 ++
SRC/dlasq2.c | 602 +++
SRC/dlasq3.c | 350 ++
SRC/dlasq4.c | 403 ++
SRC/dlasq5.c | 240 ++
SRC/dlasq6.c | 212 ++
SRC/dlasr.c | 453 +++
SRC/dlasrt.c | 286 ++
SRC/dlassq.c | 116 +
SRC/dlasv2.c | 274 ++
SRC/dlaswp.c | 158 +
SRC/dlasy2.c | 478 +++
SRC/dlasyf.c | 721 ++++
SRC/dlat2s.c | 137 +
SRC/dlatbs.c | 850 +++++
SRC/dlatdf.c | 303 ++
SRC/dlatps.c | 824 ++++
SRC/dlatrd.c | 355 ++
SRC/dlatrs.c | 815 ++++
SRC/dlatrz.c | 163 +
SRC/dlatzm.c | 193 +
SRC/dlauu2.c | 183 +
SRC/dlauum.c | 217 ++
SRC/dopgtr.c | 210 ++
SRC/dopmtr.c | 296 ++
SRC/dorg2l.c | 173 +
SRC/dorg2r.c | 175 +
SRC/dorgbr.c | 299 ++
SRC/dorghr.c | 216 ++
SRC/dorgl2.c | 175 +
SRC/dorglq.c | 280 ++
SRC/dorgql.c | 289 ++
SRC/dorgqr.c | 281 ++
SRC/dorgr2.c | 174 +
SRC/dorgrq.c | 289 ++
SRC/dorgtr.c | 250 ++
SRC/dorm2l.c | 231 ++
SRC/dorm2r.c | 235 ++
SRC/dormbr.c | 360 ++
SRC/dormhr.c | 257 ++
SRC/dorml2.c | 231 ++
SRC/dormlq.c | 334 ++
SRC/dormql.c | 327 ++
SRC/dormqr.c | 327 ++
SRC/dormr2.c | 227 ++
SRC/dormr3.c | 241 ++
SRC/dormrq.c | 335 ++
SRC/dormrz.c | 362 ++
SRC/dormtr.c | 295 ++
SRC/dpbcon.c | 233 ++
SRC/dpbequ.c | 203 +
SRC/dpbrfs.c | 438 +++
SRC/dpbstf.c | 312 ++
SRC/dpbsv.c | 182 +
SRC/dpbsvx.c | 515 +++
SRC/dpbtf2.c | 244 ++
SRC/dpbtrf.c | 471 +++
SRC/dpbtrs.c | 184 +
SRC/dpftrf.c | 452 +++
SRC/dpftri.c | 403 ++
SRC/dpftrs.c | 240 ++
SRC/dpocon.c | 220 ++
SRC/dpoequ.c | 174 +
SRC/dpoequb.c | 188 +
SRC/dporfs.c | 422 +++
SRC/dporfsx.c | 622 ++++
SRC/dposv.c | 151 +
SRC/dposvx.c | 450 +++
SRC/dposvxx.c | 611 +++
SRC/dpotf2.c | 224 ++
SRC/dpotrf.c | 245 ++
SRC/dpotri.c | 125 +
SRC/dpotrs.c | 166 +
SRC/dppcon.c | 215 ++
SRC/dppequ.c | 208 ++
SRC/dpprfs.c | 413 ++
SRC/dppsv.c | 161 +
SRC/dppsvx.c | 455 +++
SRC/dpptrf.c | 223 ++
SRC/dpptri.c | 173 +
SRC/dpptrs.c | 170 +
SRC/dpstf2.c | 395 ++
SRC/dpstrf.c | 471 +++
SRC/dptcon.c | 184 +
SRC/dpteqr.c | 244 ++
SRC/dptrfs.c | 365 ++
SRC/dptsv.c | 130 +
SRC/dptsvx.c | 283 ++
SRC/dpttrf.c | 181 +
SRC/dpttrs.c | 156 +
SRC/dptts2.c | 131 +
SRC/drscl.c | 134 +
SRC/dsbev.c | 268 ++
SRC/dsbevd.c | 338 ++
SRC/dsbevx.c | 520 +++
SRC/dsbgst.c | 1755 +++++++++
SRC/dsbgv.c | 234 ++
SRC/dsbgvd.c | 327 ++
SRC/dsbgvx.c | 466 +++
SRC/dsbtrd.c | 713 ++++
SRC/dsfrk.c | 517 +++
SRC/dsgesv.c | 416 +++
SRC/dspcon.c | 198 +
SRC/dspev.c | 246 ++
SRC/dspevd.c | 314 ++
SRC/dspevx.c | 467 +++
SRC/dspgst.c | 284 ++
SRC/dspgv.c | 243 ++
SRC/dspgvd.c | 334 ++
SRC/dspgvx.c | 341 ++
SRC/dsposv.c | 418 +++
SRC/dsprfs.c | 421 +++
SRC/dspsv.c | 176 +
SRC/dspsvx.c | 329 ++
SRC/dsptrd.c | 277 ++
SRC/dsptrf.c | 628 ++++
SRC/dsptri.c | 411 ++
SRC/dsptrs.c | 456 +++
SRC/dstebz.c | 774 ++++
SRC/dstedc.c | 488 +++
SRC/dstegr.c | 211 ++
SRC/dstein.c | 452 +++
SRC/dstemr.c | 728 ++++
SRC/dsteqr.c | 621 +++
SRC/dsterf.c | 461 +++
SRC/dstev.c | 212 ++
SRC/dstevd.c | 273 ++
SRC/dstevr.c | 550 +++
SRC/dstevx.c | 432 +++
SRC/dsycon.c | 204 +
SRC/dsyequb.c | 333 ++
SRC/dsyev.c | 283 ++
SRC/dsyevd.c | 353 ++
SRC/dsyevr.c | 652 ++++
SRC/dsyevx.c | 536 +++
SRC/dsygs2.c | 299 ++
SRC/dsygst.c | 347 ++
SRC/dsygv.c | 285 ++
SRC/dsygvd.c | 338 ++
SRC/dsygvx.c | 396 ++
SRC/dsyrfs.c | 429 +++
SRC/dsyrfsx.c | 629 ++++
SRC/dsysv.c | 215 ++
SRC/dsysvx.c | 370 ++
SRC/dsysvxx.c | 631 ++++
SRC/dsytd2.c | 306 ++
SRC/dsytf2.c | 608 +++
SRC/dsytrd.c | 360 ++
SRC/dsytrf.c | 341 ++
SRC/dsytri.c | 396 ++
SRC/dsytrs.c | 453 +++
SRC/dtbcon.c | 247 ++
SRC/dtbrfs.c | 519 +++
SRC/dtbtrs.c | 204 +
SRC/dtfsm.c | 976 +++++
SRC/dtftri.c | 474 +++
SRC/dtfttp.c | 514 +++
SRC/dtfttr.c | 491 +++
SRC/dtgevc.c | 1418 +++++++
SRC/dtgex2.c | 711 ++++
SRC/dtgexc.c | 514 +++
SRC/dtgsen.c | 836 +++++
SRC/dtgsja.c | 625 ++++
SRC/dtgsna.c | 695 ++++
SRC/dtgsy2.c | 1113 ++++++
SRC/dtgsyl.c | 692 ++++
SRC/dtpcon.c | 233 ++
SRC/dtprfs.c | 496 +++
SRC/dtptri.c | 219 ++
SRC/dtptrs.c | 193 +
SRC/dtpttf.c | 499 +++
SRC/dtpttr.c | 144 +
SRC/dtrcon.c | 241 ++
SRC/dtrevc.c | 1228 ++++++
SRC/dtrexc.c | 403 ++
SRC/dtrrfs.c | 493 +++
SRC/dtrsen.c | 530 +++
SRC/dtrsna.c | 606 +++
SRC/dtrsyl.c | 1319 +++++++
SRC/dtrti2.c | 183 +
SRC/dtrtri.c | 242 ++
SRC/dtrtrs.c | 183 +
SRC/dtrttf.c | 489 +++
SRC/dtrttp.c | 144 +
SRC/dtzrqf.c | 221 ++
SRC/dtzrzf.c | 308 ++
SRC/dzsum1.c | 114 +
SRC/icmax1.c | 127 +
SRC/ieeeck.c | 166 +
SRC/ilaclc.c | 94 +
SRC/ilaclr.c | 96 +
SRC/iladiag.c | 65 +
SRC/iladlc.c | 88 +
SRC/iladlr.c | 90 +
SRC/ilaenv.c | 654 ++++
SRC/ilaprec.c | 72 +
SRC/ilaslc.c | 88 +
SRC/ilaslr.c | 90 +
SRC/ilatrans.c | 69 +
SRC/ilauplo.c | 65 +
SRC/ilaver.c | 47 +
SRC/ilazlc.c | 94 +
SRC/ilazlr.c | 96 +
SRC/iparmq.c | 282 ++
SRC/izmax1.c | 127 +
SRC/lsamen.c | 98 +
SRC/maxloc.c | 71 +
SRC/sbdsdc.c | 511 +++
SRC/sbdsqr.c | 918 +++++
SRC/scsum1.c | 114 +
SRC/sdisna.c | 228 ++
SRC/sgbbrd.c | 562 +++
SRC/sgbcon.c | 282 ++
SRC/sgbequ.c | 319 ++
SRC/sgbequb.c | 346 ++
SRC/sgbrfs.c | 454 +++
SRC/sgbrfsx.c | 682 ++++
SRC/sgbsv.c | 176 +
SRC/sgbsvx.c | 650 ++++
SRC/sgbsvxx.c | 744 ++++
SRC/sgbtf2.c | 260 ++
SRC/sgbtrf.c | 583 +++
SRC/sgbtrs.c | 242 ++
SRC/sgebak.c | 235 ++
SRC/sgebal.c | 400 ++
SRC/sgebd2.c | 303 ++
SRC/sgebrd.c | 336 ++
SRC/sgecon.c | 224 ++
SRC/sgeequ.c | 296 ++
SRC/sgeequb.c | 324 ++
SRC/sgees.c | 547 +++
SRC/sgeesx.c | 643 ++++
SRC/sgeev.c | 558 +++
SRC/sgeevx.c | 696 ++++
SRC/sgegs.c | 545 +++
SRC/sgegv.c | 837 +++++
SRC/sgehd2.c | 190 +
SRC/sgehrd.c | 338 ++
SRC/sgejsv.c | 2210 +++++++++++
SRC/sgelq2.c | 157 +
SRC/sgelqf.c | 251 ++
SRC/sgels.c | 513 +++
SRC/sgelsd.c | 699 ++++
SRC/sgelss.c | 822 ++++
SRC/sgelsx.c | 433 +++
SRC/sgelsy.c | 488 +++
SRC/sgeql2.c | 159 +
SRC/sgeqlf.c | 270 ++
SRC/sgeqp3.c | 351 ++
SRC/sgeqpf.c | 303 ++
SRC/sgeqr2.c | 161 +
SRC/sgeqrf.c | 252 ++
SRC/sgerfs.c | 422 +++
SRC/sgerfsx.c | 663 ++++
SRC/sgerq2.c | 155 +
SRC/sgerqf.c | 272 ++
SRC/sgesc2.c | 176 +
SRC/sgesdd.c | 1611 ++++++++
SRC/sgesv.c | 139 +
SRC/sgesvd.c | 4047 ++++++++++++++++++++
SRC/sgesvj.c | 1785 +++++++++
SRC/sgesvx.c | 582 +++
SRC/sgesvxx.c | 711 ++++
SRC/sgetc2.c | 198 +
SRC/sgetf2.c | 192 +
SRC/sgetrf.c | 217 ++
SRC/sgetri.c | 259 ++
SRC/sgetrs.c | 185 +
SRC/sggbak.c | 274 ++
SRC/sggbal.c | 623 ++++
SRC/sgges.c | 687 ++++
SRC/sggesx.c | 811 ++++
SRC/sggev.c | 640 ++++
SRC/sggevx.c | 879 +++++
SRC/sggglm.c | 326 ++
SRC/sgghrd.c | 329 ++
SRC/sgglse.c | 334 ++
SRC/sggqrf.c | 268 ++
SRC/sggrqf.c | 269 ++
SRC/sggsvd.c | 402 ++
SRC/sggsvp.c | 508 +++
SRC/sgsvj0.c | 1150 ++++++
SRC/sgsvj1.c | 789 ++++
SRC/sgtcon.c | 206 +
SRC/sgtrfs.c | 444 +++
SRC/sgtsv.c | 318 ++
SRC/sgtsvx.c | 347 ++
SRC/sgttrf.c | 203 +
SRC/sgttrs.c | 189 +
SRC/sgtts2.c | 261 ++
SRC/shgeqz.c | 1494 ++++++++
SRC/shsein.c | 488 +++
SRC/shseqr.c | 484 +++
SRC/sisnan.c | 52 +
SRC/sla_gbamv.c | 316 ++
SRC/sla_gbrcond.c | 346 ++
SRC/sla_gbrfsx_extended.c | 625 ++++
SRC/sla_gbrpvgrw.c | 136 +
SRC/sla_geamv.c | 294 ++
SRC/sla_gercond.c | 296 ++
SRC/sla_gerfsx_extended.c | 616 +++
SRC/sla_lin_berr.c | 124 +
SRC/sla_porcond.c | 308 ++
SRC/sla_porfsx_extended.c | 593 +++
SRC/sla_porpvgrw.c | 197 +
SRC/sla_rpvgrw.c | 117 +
SRC/sla_syamv.c | 299 ++
SRC/sla_syrcond.c | 320 ++
SRC/sla_syrfsx_extended.c | 598 +++
SRC/sla_syrpvgrw.c | 330 ++
SRC/sla_wwaddw.c | 79 +
SRC/slabad.c | 72 +
SRC/slabrd.c | 432 +++
SRC/slacn2.c | 266 ++
SRC/slacon.c | 256 ++
SRC/slacpy.c | 125 +
SRC/sladiv.c | 78 +
SRC/slae2.c | 141 +
SRC/slaebz.c | 639 ++++
SRC/slaed0.c | 435 +++
SRC/slaed1.c | 246 ++
SRC/slaed2.c | 530 +++
SRC/slaed3.c | 336 ++
SRC/slaed4.c | 952 +++++
SRC/slaed5.c | 149 +
SRC/slaed6.c | 375 ++
SRC/slaed7.c | 352 ++
SRC/slaed8.c | 475 +++
SRC/slaed9.c | 272 ++
SRC/slaeda.c | 283 ++
SRC/slaein.c | 678 ++++
SRC/slaev2.c | 188 +
SRC/slaexc.c | 458 +++
SRC/slag2.c | 356 ++
SRC/slag2d.c | 100 +
SRC/slags2.c | 290 ++
SRC/slagtf.c | 223 ++
SRC/slagtm.c | 253 ++
SRC/slagts.c | 351 ++
SRC/slagv2.c | 347 ++
SRC/slahqr.c | 631 ++++
SRC/slahr2.c | 309 ++
SRC/slahrd.c | 282 ++
SRC/slaic1.c | 324 ++
SRC/slaisnan.c | 58 +
SRC/slaln2.c | 577 +++
SRC/slals0.c | 470 +++
SRC/slalsa.c | 454 +++
SRC/slalsd.c | 523 +++
SRC/slamrg.c | 131 +
SRC/slaneg.c | 218 ++
SRC/slangb.c | 226 ++
SRC/slange.c | 199 +
SRC/slangt.c | 196 +
SRC/slanhs.c | 204 +
SRC/slansb.c | 263 ++
SRC/slansf.c | 1013 +++++
SRC/slansp.c | 262 ++
SRC/slanst.c | 166 +
SRC/slansy.c | 239 ++
SRC/slantb.c | 434 +++
SRC/slantp.c | 391 ++
SRC/slantr.c | 398 ++
SRC/slanv2.c | 234 ++
SRC/slapll.c | 126 +
SRC/slapmt.c | 177 +
SRC/slapy2.c | 73 +
SRC/slapy3.c | 83 +
SRC/slaqgb.c | 216 ++
SRC/slaqge.c | 188 +
SRC/slaqp2.c | 238 ++
SRC/slaqps.c | 342 ++
SRC/slaqr0.c | 753 ++++
SRC/slaqr1.c | 126 +
SRC/slaqr2.c | 694 ++++
SRC/slaqr3.c | 710 ++++
SRC/slaqr4.c | 751 ++++
SRC/slaqr5.c | 1026 +++++
SRC/slaqsb.c | 184 +
SRC/slaqsp.c | 169 +
SRC/slaqsy.c | 172 +
SRC/slaqtr.c | 831 +++++
SRC/slar1v.c | 440 +++
SRC/slar2v.c | 120 +
SRC/slarf.c | 191 +
SRC/slarfb.c | 773 ++++
SRC/slarfg.c | 169 +
SRC/slarfp.c | 191 +
SRC/slarft.c | 323 ++
SRC/slarfx.c | 729 ++++
SRC/slargv.c | 130 +
SRC/slarnv.c | 146 +
SRC/slarra.c | 155 +
SRC/slarrb.c | 349 ++
SRC/slarrc.c | 183 +
SRC/slarrd.c | 790 ++++
SRC/slarre.c | 857 +++++
SRC/slarrf.c | 422 +++
SRC/slarrj.c | 337 ++
SRC/slarrk.c | 193 +
SRC/slarrr.c | 175 +
SRC/slarrv.c | 980 +++++
SRC/slarscl2.c | 90 +
SRC/slartg.c | 189 +
SRC/slartv.c | 105 +
SRC/slaruv.c | 193 +
SRC/slarz.c | 190 +
SRC/slarzb.c | 287 ++
SRC/slarzt.c | 227 ++
SRC/slas2.c | 145 +
SRC/slascl.c | 355 ++
SRC/slascl2.c | 90 +
SRC/slasd0.c | 286 ++
SRC/slasd1.c | 286 ++
SRC/slasd2.c | 607 +++
SRC/slasd3.c | 450 +++
SRC/slasd4.c | 1010 +++++
SRC/slasd5.c | 189 +
SRC/slasd6.c | 364 ++
SRC/slasd7.c | 516 +++
SRC/slasd8.c | 323 ++
SRC/slasda.c | 483 +++
SRC/slasdq.c | 379 ++
SRC/slasdt.c | 136 +
SRC/slaset.c | 152 +
SRC/slasq1.c | 216 ++
SRC/slasq2.c | 599 +++
SRC/slasq3.c | 346 ++
SRC/slasq4.c | 402 ++
SRC/slasq5.c | 239 ++
SRC/slasq6.c | 212 ++
SRC/slasr.c | 452 +++
SRC/slasrt.c | 285 ++
SRC/slassq.c | 116 +
SRC/slasv2.c | 273 ++
SRC/slaswp.c | 158 +
SRC/slasy2.c | 479 +++
SRC/slasyf.c | 719 ++++
SRC/slatbs.c | 849 +++++
SRC/slatdf.c | 301 ++
SRC/slatps.c | 822 ++++
SRC/slatrd.c | 351 ++
SRC/slatrs.c | 813 ++++
SRC/slatrz.c | 162 +
SRC/slatzm.c | 189 +
SRC/slauu2.c | 180 +
SRC/slauum.c | 215 ++
SRC/sopgtr.c | 209 ++
SRC/sopmtr.c | 295 ++
SRC/sorg2l.c | 173 +
SRC/sorg2r.c | 175 +
SRC/sorgbr.c | 299 ++
SRC/sorghr.c | 214 ++
SRC/sorgl2.c | 175 +
SRC/sorglq.c | 279 ++
SRC/sorgql.c | 288 ++
SRC/sorgqr.c | 280 ++
SRC/sorgr2.c | 174 +
SRC/sorgrq.c | 288 ++
SRC/sorgtr.c | 250 ++
SRC/sorm2l.c | 230 ++
SRC/sorm2r.c | 234 ++
SRC/sormbr.c | 358 ++
SRC/sormhr.c | 256 ++
SRC/sorml2.c | 230 ++
SRC/sormlq.c | 334 ++
SRC/sormql.c | 328 ++
SRC/sormqr.c | 327 ++
SRC/sormr2.c | 226 ++
SRC/sormr3.c | 241 ++
SRC/sormrq.c | 335 ++
SRC/sormrz.c | 358 ++
SRC/sormtr.c | 295 ++
SRC/spbcon.c | 232 ++
SRC/spbequ.c | 202 +
SRC/spbrfs.c | 434 +++
SRC/spbstf.c | 312 ++
SRC/spbsv.c | 181 +
SRC/spbsvx.c | 512 +++
SRC/spbtf2.c | 244 ++
SRC/spbtrf.c | 469 +++
SRC/spbtrs.c | 182 +
SRC/spftrf.c | 451 +++
SRC/spftri.c | 402 ++
SRC/spftrs.c | 238 ++
SRC/spocon.c | 217 ++
SRC/spoequ.c | 174 +
SRC/spoequb.c | 188 +
SRC/sporfs.c | 421 +++
SRC/sporfsx.c | 619 +++
SRC/sposv.c | 151 +
SRC/sposvx.c | 446 +++
SRC/sposvxx.c | 611 +++
SRC/spotf2.c | 221 ++
SRC/spotrf.c | 243 ++
SRC/spotri.c | 124 +
SRC/spotrs.c | 164 +
SRC/sppcon.c | 213 ++
SRC/sppequ.c | 208 ++
SRC/spprfs.c | 408 ++
SRC/sppsv.c | 160 +
SRC/sppsvx.c | 452 +++
SRC/spptrf.c | 221 ++
SRC/spptri.c | 171 +
SRC/spptrs.c | 170 +
SRC/spstf2.c | 392 ++
SRC/spstrf.c | 466 +++
SRC/sptcon.c | 184 +
SRC/spteqr.c | 240 ++
SRC/sptrfs.c | 365 ++
SRC/sptsv.c | 129 +
SRC/sptsvx.c | 279 ++
SRC/spttrf.c | 180 +
SRC/spttrs.c | 156 +
SRC/sptts2.c | 130 +
SRC/srscl.c | 133 +
SRC/ssbev.c | 265 ++
SRC/ssbevd.c | 332 ++
SRC/ssbevx.c | 513 +++
SRC/ssbgst.c | 1752 +++++++++
SRC/ssbgv.c | 232 ++
SRC/ssbgvd.c | 327 ++
SRC/ssbgvx.c | 461 +++
SRC/ssbtrd.c | 710 ++++
SRC/ssfrk.c | 516 +++
SRC/sspcon.c | 196 +
SRC/sspev.c | 240 ++
SRC/sspevd.c | 310 ++
SRC/sspevx.c | 461 +++
SRC/sspgst.c | 281 ++
SRC/sspgv.c | 240 ++
SRC/sspgvd.c | 330 ++
SRC/sspgvx.c | 339 ++
SRC/ssprfs.c | 417 +++
SRC/sspsv.c | 176 +
SRC/sspsvx.c | 325 ++
SRC/ssptrd.c | 275 ++
SRC/ssptrf.c | 627 ++++
SRC/ssptri.c | 407 ++
SRC/ssptrs.c | 452 +++
SRC/sstebz.c | 773 ++++
SRC/sstedc.c | 484 +++
SRC/sstegr.c | 209 ++
SRC/sstein.c | 449 +++
SRC/sstemr.c | 726 ++++
SRC/ssteqr.c | 617 +++
SRC/ssterf.c | 460 +++
SRC/sstev.c | 209 ++
SRC/sstevd.c | 270 ++
SRC/sstevr.c | 541 +++
SRC/sstevx.c | 427 +++
SRC/ssycon.c | 202 +
SRC/ssyequb.c | 334 ++
SRC/ssyev.c | 276 ++
SRC/ssyevd.c | 344 ++
SRC/ssyevr.c | 658 ++++
SRC/ssyevx.c | 531 +++
SRC/ssygs2.c | 296 ++
SRC/ssygst.c | 342 ++
SRC/ssygv.c | 283 ++
SRC/ssygvd.c | 337 ++
SRC/ssygvx.c | 395 ++
SRC/ssyrfs.c | 427 +++
SRC/ssyrfsx.c | 626 ++++
SRC/ssysv.c | 214 ++
SRC/ssysvx.c | 368 ++
SRC/ssysvxx.c | 630 ++++
SRC/ssytd2.c | 302 ++
SRC/ssytf2.c | 608 +++
SRC/ssytrd.c | 360 ++
SRC/ssytrf.c | 339 ++
SRC/ssytri.c | 394 ++
SRC/ssytrs.c | 449 +++
SRC/stbcon.c | 247 ++
SRC/stbrfs.c | 519 +++
SRC/stbtrs.c | 203 +
SRC/stfsm.c | 973 +++++
SRC/stftri.c | 473 +++
SRC/stfttp.c | 514 +++
SRC/stfttr.c | 491 +++
SRC/stgevc.c | 1415 +++++++
SRC/stgex2.c | 706 ++++
SRC/stgexc.c | 514 +++
SRC/stgsen.c | 832 +++++
SRC/stgsja.c | 619 +++
SRC/stgsna.c | 691 ++++
SRC/stgsy2.c | 1106 ++++++
SRC/stgsyl.c | 691 ++++
SRC/stpcon.c | 230 ++
SRC/stprfs.c | 493 +++
SRC/stptri.c | 218 ++
SRC/stptrs.c | 192 +
SRC/stpttf.c | 499 +++
SRC/stpttr.c | 144 +
SRC/strcon.c | 239 ++
SRC/strevc.c | 1223 ++++++
SRC/strexc.c | 403 ++
SRC/strrfs.c | 492 +++
SRC/strsen.c | 530 +++
SRC/strsna.c | 603 +++
SRC/strsyl.c | 1316 +++++++
SRC/strti2.c | 183 +
SRC/strtri.c | 241 ++
SRC/strtrs.c | 182 +
SRC/strttf.c | 489 +++
SRC/strttp.c | 143 +
SRC/stzrqf.c | 219 ++
SRC/stzrzf.c | 310 ++
SRC/xerbla.c | 65 +
SRC/xerbla_array.c | 102 +
SRC/zbdsqr.c | 909 +++++
SRC/zcgesv.c | 432 +++
SRC/zcposv.c | 440 +++
SRC/zdrscl.c | 135 +
SRC/zgbbrd.c | 654 ++++
SRC/zgbcon.c | 307 ++
SRC/zgbequ.c | 330 ++
SRC/zgbequb.c | 355 ++
SRC/zgbrfs.c | 494 +++
SRC/zgbrfsx.c | 690 ++++
SRC/zgbsv.c | 176 +
SRC/zgbsvx.c | 678 ++++
SRC/zgbsvxx.c | 747 ++++
SRC/zgbtf2.c | 268 ++
SRC/zgbtrf.c | 605 +++
SRC/zgbtrs.c | 281 ++
SRC/zgebak.c | 235 ++
SRC/zgebal.c | 414 ++
SRC/zgebd2.c | 345 ++
SRC/zgebrd.c | 351 ++
SRC/zgecon.c | 235 ++
SRC/zgeequ.c | 306 ++
SRC/zgeequb.c | 332 ++
SRC/zgees.c | 409 ++
SRC/zgeesx.c | 477 +++
SRC/zgeev.c | 533 +++
SRC/zgeevx.c | 686 ++++
SRC/zgegs.c | 543 +++
SRC/zgegv.c | 781 ++++
SRC/zgehd2.c | 199 +
SRC/zgehrd.c | 353 ++
SRC/zgelq2.c | 165 +
SRC/zgelqf.c | 257 ++
SRC/zgels.c | 520 +++
SRC/zgelsd.c | 724 ++++
SRC/zgelss.c | 828 ++++
SRC/zgelsx.c | 471 +++
SRC/zgelsy.c | 512 +++
SRC/zgeql2.c | 167 +
SRC/zgeqlf.c | 276 ++
SRC/zgeqp3.c | 361 ++
SRC/zgeqpf.c | 316 ++
SRC/zgeqr2.c | 169 +
SRC/zgeqrf.c | 258 ++
SRC/zgerfs.c | 461 +++
SRC/zgerfsx.c | 669 ++++
SRC/zgerq2.c | 162 +
SRC/zgerqf.c | 275 ++
SRC/zgesc2.c | 206 +
SRC/zgesdd.c | 2252 +++++++++++
SRC/zgesv.c | 140 +
SRC/zgesvd.c | 4173 +++++++++++++++++++++
SRC/zgesvx.c | 610 +++
SRC/zgesvxx.c | 716 ++++
SRC/zgetc2.c | 209 ++
SRC/zgetf2.c | 202 +
SRC/zgetrf.c | 219 ++
SRC/zgetri.c | 270 ++
SRC/zgetrs.c | 187 +
SRC/zggbak.c | 273 ++
SRC/zggbal.c | 657 ++++
SRC/zgges.c | 604 +++
SRC/zggesx.c | 708 ++++
SRC/zggev.c | 599 +++
SRC/zggevx.c | 812 ++++
SRC/zggglm.c | 337 ++
SRC/zgghrd.c | 336 ++
SRC/zgglse.c | 346 ++
SRC/zggqrf.c | 270 ++
SRC/zggrqf.c | 271 ++
SRC/zggsvd.c | 407 ++
SRC/zggsvp.c | 533 +++
SRC/zgtcon.c | 209 ++
SRC/zgtrfs.c | 553 +++
SRC/zgtsv.c | 288 ++
SRC/zgtsvx.c | 353 ++
SRC/zgttrf.c | 275 ++
SRC/zgttrs.c | 194 +
SRC/zgtts2.c | 584 +++
SRC/zhbev.c | 273 ++
SRC/zhbevd.c | 381 ++
SRC/zhbevx.c | 527 +++
SRC/zhbgst.c | 2152 +++++++++++
SRC/zhbgv.c | 238 ++
SRC/zhbgvd.c | 359 ++
SRC/zhbgvx.c | 473 +++
SRC/zhbtrd.c | 810 ++++
SRC/zhecon.c | 203 +
SRC/zheequb.c | 439 +++
SRC/zheev.c | 289 ++
SRC/zheevd.c | 382 ++
SRC/zheevr.c | 696 ++++
SRC/zheevx.c | 548 +++
SRC/zhegs2.c | 338 ++
SRC/zhegst.c | 353 ++
SRC/zhegv.c | 289 ++
SRC/zhegvd.c | 367 ++
SRC/zhegvx.c | 397 ++
SRC/zherfs.c | 473 +++
SRC/zherfsx.c | 630 ++++
SRC/zhesv.c | 213 ++
SRC/zhesvx.c | 368 ++
SRC/zhesvxx.c | 630 ++++
SRC/zhetd2.c | 361 ++
SRC/zhetf2.c | 802 ++++
SRC/zhetrd.c | 370 ++
SRC/zhetrf.c | 336 ++
SRC/zhetri.c | 510 +++
SRC/zhetrs.c | 529 +++
SRC/zhfrk.c | 531 +++
SRC/zhgeqz.c | 1149 ++++++
SRC/zhpcon.c | 197 +
SRC/zhpev.c | 254 ++
SRC/zhpevd.c | 349 ++
SRC/zhpevx.c | 475 +++
SRC/zhpgst.c | 313 ++
SRC/zhpgv.c | 246 ++
SRC/zhpgvd.c | 359 ++
SRC/zhpgvx.c | 344 ++
SRC/zhprfs.c | 462 +++
SRC/zhpsv.c | 177 +
SRC/zhpsvx.c | 326 ++
SRC/zhptrd.c | 319 ++
SRC/zhptrf.c | 821 ++++
SRC/zhptri.c | 513 +++
SRC/zhptrs.c | 532 +++
SRC/zhsein.c | 433 +++
SRC/zhseqr.c | 483 +++
SRC/zla_gbamv.c | 337 ++
SRC/zla_gbrcond_c.c | 351 ++
SRC/zla_gbrcond_x.c | 322 ++
SRC/zla_gbrfsx_extended.c | 648 ++++
SRC/zla_gbrpvgrw.c | 148 +
SRC/zla_geamv.c | 313 ++
SRC/zla_gercond_c.c | 310 ++
SRC/zla_gercond_x.c | 290 ++
SRC/zla_gerfsx_extended.c | 637 ++++
SRC/zla_heamv.c | 327 ++
SRC/zla_hercond_c.c | 333 ++
SRC/zla_hercond_x.c | 311 ++
SRC/zla_herfsx_extended.c | 626 ++++
SRC/zla_herpvgrw.c | 355 ++
SRC/zla_lin_berr.c | 136 +
SRC/zla_porcond_c.c | 327 ++
SRC/zla_porcond_x.c | 304 ++
SRC/zla_porfsx_extended.c | 619 +++
SRC/zla_porpvgrw.c | 208 ++
SRC/zla_rpvgrw.c | 128 +
SRC/zla_syamv.c | 327 ++
SRC/zla_syrcond_c.c | 333 ++
SRC/zla_syrcond_x.c | 311 ++
SRC/zla_syrfsx_extended.c | 626 ++++
SRC/zla_syrpvgrw.c | 355 ++
SRC/zla_wwaddw.c | 93 +
SRC/zlabrd.c | 502 +++
SRC/zlacgv.c | 95 +
SRC/zlacn2.c | 283 ++
SRC/zlacon.c | 275 ++
SRC/zlacp2.c | 134 +
SRC/zlacpy.c | 134 +
SRC/zlacrm.c | 177 +
SRC/zlacrt.c | 156 +
SRC/zladiv.c | 75 +
SRC/zlaed0.c | 366 ++
SRC/zlaed7.c | 327 ++
SRC/zlaed8.c | 436 +++
SRC/zlaein.c | 397 ++
SRC/zlaesy.c | 208 ++
SRC/zlaev2.c | 125 +
SRC/zlag2c.c | 124 +
SRC/zlags2.c | 468 +++
SRC/zlagtm.c | 599 +++
SRC/zlahef.c | 938 +++++
SRC/zlahqr.c | 755 ++++
SRC/zlahr2.c | 331 ++
SRC/zlahrd.c | 301 ++
SRC/zlaic1.c | 451 +++
SRC/zlals0.c | 563 +++
SRC/zlalsa.c | 664 ++++
SRC/zlalsd.c | 758 ++++
SRC/zlangb.c | 224 ++
SRC/zlange.c | 199 +
SRC/zlangt.c | 195 +
SRC/zlanhb.c | 291 ++
SRC/zlanhe.c | 265 ++
SRC/zlanhf.c | 1803 +++++++++
SRC/zlanhp.c | 277 ++
SRC/zlanhs.c | 205 +
SRC/zlanht.c | 167 +
SRC/zlansb.c | 261 ++
SRC/zlansp.c | 278 ++
SRC/zlansy.c | 237 ++
SRC/zlantb.c | 426 +++
SRC/zlantp.c | 391 ++
SRC/zlantr.c | 394 ++
SRC/zlapll.c | 143 +
SRC/zlapmt.c | 186 +
SRC/zlaqgb.c | 227 ++
SRC/zlaqge.c | 202 +
SRC/zlaqhb.c | 201 +
SRC/zlaqhe.c | 193 +
SRC/zlaqhp.c | 189 +
SRC/zlaqp2.c | 242 ++
SRC/zlaqps.c | 364 ++
SRC/zlaqr0.c | 787 ++++
SRC/zlaqr1.c | 197 +
SRC/zlaqr2.c | 611 +++
SRC/zlaqr3.c | 630 ++++
SRC/zlaqr4.c | 785 ++++
SRC/zlaqr5.c | 1349 +++++++
SRC/zlaqsb.c | 193 +
SRC/zlaqsp.c | 179 +
SRC/zlaqsy.c | 183 +
SRC/zlar1v.c | 501 +++
SRC/zlar2v.c | 160 +
SRC/zlarcm.c | 177 +
SRC/zlarf.c | 200 +
SRC/zlarfb.c | 839 +++++
SRC/zlarfg.c | 191 +
SRC/zlarfp.c | 236 ++
SRC/zlarft.c | 362 ++
SRC/zlarfx.c | 2050 ++++++++++
SRC/zlargv.c | 336 ++
SRC/zlarnv.c | 190 +
SRC/zlarrv.c | 1022 +++++
SRC/zlarscl2.c | 95 +
SRC/zlartg.c | 285 ++
SRC/zlartv.c | 126 +
SRC/zlarz.c | 200 +
SRC/zlarzb.c | 323 ++
SRC/zlarzt.c | 238 ++
SRC/zlascl.c | 376 ++
SRC/zlascl2.c | 95 +
SRC/zlaset.c | 163 +
SRC/zlasr.c | 610 +++
SRC/zlassq.c | 138 +
SRC/zlaswp.c | 166 +
SRC/zlasyf.c | 831 +++++
SRC/zlat2c.c | 152 +
SRC/zlatbs.c | 1195 ++++++
SRC/zlatdf.c | 359 ++
SRC/zlatps.c | 1163 ++++++
SRC/zlatrd.c | 420 +++
SRC/zlatrs.c | 1150 ++++++
SRC/zlatrz.c | 181 +
SRC/zlatzm.c | 198 +
SRC/zlauu2.c | 203 +
SRC/zlauum.c | 217 ++
SRC/zpbcon.c | 236 ++
SRC/zpbequ.c | 205 +
SRC/zpbrfs.c | 483 +++
SRC/zpbstf.c | 334 ++
SRC/zpbsv.c | 183 +
SRC/zpbsvx.c | 528 +++
SRC/zpbtf2.c | 255 ++
SRC/zpbtrf.c | 490 +++
SRC/zpbtrs.c | 183 +
SRC/zpftrf.c | 475 +++
SRC/zpftri.c | 426 +++
SRC/zpftrs.c | 260 ++
SRC/zpocon.c | 225 ++
SRC/zpoequ.c | 176 +
SRC/zpoequb.c | 195 +
SRC/zporfs.c | 465 +++
SRC/zporfsx.c | 625 ++++
SRC/zposv.c | 152 +
SRC/zposvx.c | 462 +++
SRC/zposvxx.c | 613 +++
SRC/zpotf2.c | 245 ++
SRC/zpotrf.c | 248 ++
SRC/zpotri.c | 125 +
SRC/zpotrs.c | 166 +
SRC/zppcon.c | 223 ++
SRC/zppequ.c | 210 ++
SRC/zpprfs.c | 457 +++
SRC/zppsv.c | 161 +
SRC/zppsvx.c | 465 +++
SRC/zpptrf.c | 233 ++
SRC/zpptri.c | 179 +
SRC/zpptrs.c | 169 +
SRC/zpstf2.c | 443 +++
SRC/zpstrf.c | 529 +++
SRC/zptcon.c | 187 +
SRC/zpteqr.c | 243 ++
SRC/zptrfs.c | 576 +++
SRC/zptsv.c | 130 +
SRC/zptsvx.c | 290 ++
SRC/zpttrf.c | 216 ++
SRC/zpttrs.c | 178 +
SRC/zptts2.c | 315 ++
SRC/zrot.c | 155 +
SRC/zspcon.c | 197 +
SRC/zspmv.c | 428 +++
SRC/zspr.c | 339 ++
SRC/zsprfs.c | 464 +++
SRC/zspsv.c | 177 +
SRC/zspsvx.c | 326 ++
SRC/zsptrf.c | 763 ++++
SRC/zsptri.c | 508 +++
SRC/zsptrs.c | 503 +++
SRC/zstedc.c | 497 +++
SRC/zstegr.c | 211 ++
SRC/zstein.c | 470 +++
SRC/zstemr.c | 752 ++++
SRC/zsteqr.c | 621 +++
SRC/zsycon.c | 203 +
SRC/zsyequb.c | 450 +++
SRC/zsymv.c | 429 +++
SRC/zsyr.c | 289 ++
SRC/zsyrfs.c | 474 +++
SRC/zsyrfsx.c | 631 ++++
SRC/zsysv.c | 213 ++
SRC/zsysvx.c | 368 ++
SRC/zsysvxx.c | 633 ++++
SRC/zsytf2.c | 727 ++++
SRC/zsytrf.c | 343 ++
SRC/zsytri.c | 489 +++
SRC/zsytrs.c | 502 +++
SRC/ztbcon.c | 254 ++
SRC/ztbrfs.c | 586 +++
SRC/ztbtrs.c | 205 +
SRC/ztfsm.c | 1024 +++++
SRC/ztftri.c | 500 +++
SRC/ztfttp.c | 575 +++
SRC/ztfttr.c | 580 +++
SRC/ztgevc.c | 972 +++++
SRC/ztgex2.c | 376 ++
SRC/ztgexc.c | 248 ++
SRC/ztgsen.c | 766 ++++
SRC/ztgsja.c | 672 ++++
SRC/ztgsna.c | 487 +++
SRC/ztgsy2.c | 478 +++
SRC/ztgsyl.c | 695 ++++
SRC/ztpcon.c | 242 ++
SRC/ztprfs.c | 561 +++
SRC/ztptri.c | 235 ++
SRC/ztptrs.c | 194 +
SRC/ztpttf.c | 573 +++
SRC/ztpttr.c | 148 +
SRC/ztrcon.c | 250 ++
SRC/ztrevc.c | 533 +++
SRC/ztrexc.c | 216 ++
SRC/ztrrfs.c | 565 +++
SRC/ztrsen.c | 422 +++
SRC/ztrsna.c | 446 +++
SRC/ztrsyl.c | 547 +++
SRC/ztrti2.c | 198 +
SRC/ztrtri.c | 244 ++
SRC/ztrtrs.c | 184 +
SRC/ztrttf.c | 580 +++
SRC/ztrttp.c | 149 +
SRC/ztzrqf.c | 241 ++
SRC/ztzrzf.c | 313 ++
SRC/zung2l.c | 183 +
SRC/zung2r.c | 185 +
SRC/zungbr.c | 310 ++
SRC/zunghr.c | 224 ++
SRC/zungl2.c | 193 +
SRC/zunglq.c | 287 ++
SRC/zungql.c | 296 ++
SRC/zungqr.c | 288 ++
SRC/zungr2.c | 192 +
SRC/zungrq.c | 296 ++
SRC/zungtr.c | 262 ++
SRC/zunm2l.c | 245 ++
SRC/zunm2r.c | 249 ++
SRC/zunmbr.c | 371 ++
SRC/zunmhr.c | 257 ++
SRC/zunml2.c | 253 ++
SRC/zunmlq.c | 338 ++
SRC/zunmql.c | 332 ++
SRC/zunmqr.c | 332 ++
SRC/zunmr2.c | 245 ++
SRC/zunmr3.c | 254 ++
SRC/zunmrq.c | 339 ++
SRC/zunmrz.c | 371 ++
SRC/zunmtr.c | 295 ++
SRC/zupgtr.c | 221 ++
SRC/zupmtr.c | 321 ++
TESTING/CMakeLists.txt | 296 ++
TESTING/EIG/CMakeLists.txt | 135 +
TESTING/EIG/Makefile | 176 +
TESTING/EIG/alahdg.c | 534 +++
TESTING/EIG/alareq.c | 277 ++
TESTING/EIG/alarqg.c | 277 ++
TESTING/EIG/alasmg.c | 100 +
TESTING/EIG/alasum.c | 100 +
TESTING/EIG/alasvm.c | 100 +
TESTING/EIG/cbdt01.c | 344 ++
TESTING/EIG/cbdt02.c | 176 +
TESTING/EIG/cbdt03.c | 299 ++
TESTING/EIG/cchkbb.c | 775 ++++
TESTING/EIG/cchkbd.c | 1123 ++++++
TESTING/EIG/cchkbk.c | 247 ++
TESTING/EIG/cchkbl.c | 277 ++
TESTING/EIG/cchkec.c | 212 ++
TESTING/EIG/cchkee.c | 3480 +++++++++++++++++
TESTING/EIG/cchkgg.c | 1541 ++++++++
TESTING/EIG/cchkgk.c | 362 ++
TESTING/EIG/cchkgl.c | 315 ++
TESTING/EIG/cchkhb.c | 827 ++++
TESTING/EIG/cchkhs.c | 1425 +++++++
TESTING/EIG/cchkst.c | 2454 ++++++++++++
TESTING/EIG/cckglm.c | 328 ++
TESTING/EIG/cckgqr.c | 420 +++
TESTING/EIG/cckgsv.c | 316 ++
TESTING/EIG/ccklse.c | 352 ++
TESTING/EIG/cdrges.c | 1131 ++++++
TESTING/EIG/cdrgev.c | 1143 ++++++
TESTING/EIG/cdrgsx.c | 1209 ++++++
TESTING/EIG/cdrgvx.c | 979 +++++
TESTING/EIG/cdrvbd.c | 969 +++++
TESTING/EIG/cdrves.c | 1044 ++++++
TESTING/EIG/cdrvev.c | 1103 ++++++
TESTING/EIG/cdrvgg.c | 1144 ++++++
TESTING/EIG/cdrvsg.c | 2007 ++++++++++
TESTING/EIG/cdrvst.c | 3200 ++++++++++++++++
TESTING/EIG/cdrvsx.c | 1081 ++++++
TESTING/EIG/cdrvvx.c | 1083 ++++++
TESTING/EIG/cerrbd.c | 352 ++
TESTING/EIG/cerrec.c | 352 ++
TESTING/EIG/cerred.c | 497 +++
TESTING/EIG/cerrgg.c | 1294 +++++++
TESTING/EIG/cerrhs.c | 531 +++
TESTING/EIG/cerrst.c | 1124 ++++++
TESTING/EIG/cget02.c | 187 +
TESTING/EIG/cget10.c | 151 +
TESTING/EIG/cget22.c | 344 ++
TESTING/EIG/cget23.c | 964 +++++
TESTING/EIG/cget24.c | 1175 ++++++
TESTING/EIG/cget35.c | 351 ++
TESTING/EIG/cget36.c | 272 ++
TESTING/EIG/cget37.c | 724 ++++
TESTING/EIG/cget38.c | 647 ++++
TESTING/EIG/cget51.c | 270 ++
TESTING/EIG/cget52.c | 296 ++
TESTING/EIG/cget54.c | 225 ++
TESTING/EIG/cglmts.c | 203 +
TESTING/EIG/cgqrts.c | 328 ++
TESTING/EIG/cgrqts.c | 331 ++
TESTING/EIG/cgsvts.c | 417 +++
TESTING/EIG/chbt21.c | 305 ++
TESTING/EIG/chet21.c | 506 +++
TESTING/EIG/chet22.c | 292 ++
TESTING/EIG/chkxer.c | 68 +
TESTING/EIG/chpt21.c | 532 +++
TESTING/EIG/chst01.c | 196 +
TESTING/EIG/clarfy.c | 143 +
TESTING/EIG/clarhs.c | 433 +++
TESTING/EIG/clatm4.c | 477 +++
TESTING/EIG/clctes.c | 95 +
TESTING/EIG/clctsx.c | 104 +
TESTING/EIG/clsets.c | 172 +
TESTING/EIG/csbmv.c | 479 +++
TESTING/EIG/csgt01.c | 224 ++
TESTING/EIG/cslect.c | 109 +
TESTING/EIG/cstt21.c | 255 ++
TESTING/EIG/cstt22.c | 288 ++
TESTING/EIG/cunt01.c | 239 ++
TESTING/EIG/cunt03.c | 311 ++
TESTING/EIG/dbdt01.c | 291 ++
TESTING/EIG/dbdt02.c | 173 +
TESTING/EIG/dbdt03.c | 263 ++
TESTING/EIG/dchkbb.c | 771 ++++
TESTING/EIG/dchkbd.c | 1274 +++++++
TESTING/EIG/dchkbk.c | 233 ++
TESTING/EIG/dchkbl.c | 263 ++
TESTING/EIG/dchkec.c | 309 ++
TESTING/EIG/dchkee.c | 3517 +++++++++++++++++
TESTING/EIG/dchkgg.c | 1483 ++++++++
TESTING/EIG/dchkgk.c | 346 ++
TESTING/EIG/dchkgl.c | 306 ++
TESTING/EIG/dchkhs.c | 1461 ++++++++
TESTING/EIG/dchksb.c | 809 ++++
TESTING/EIG/dchkst.c | 2404 ++++++++++++
TESTING/EIG/dckglm.c | 325 ++
TESTING/EIG/dckgqr.c | 430 +++
TESTING/EIG/dckgsv.c | 315 ++
TESTING/EIG/dcklse.c | 352 ++
TESTING/EIG/ddrges.c | 1139 ++++++
TESTING/EIG/ddrgev.c | 1070 ++++++
TESTING/EIG/ddrgsx.c | 1262 +++++++
TESTING/EIG/ddrgvx.c | 969 +++++
TESTING/EIG/ddrvbd.c | 1110 ++++++
TESTING/EIG/ddrves.c | 1099 ++++++
TESTING/EIG/ddrvev.c | 1112 ++++++
TESTING/EIG/ddrvgg.c | 1192 ++++++
TESTING/EIG/ddrvsg.c | 1893 ++++++++++
TESTING/EIG/ddrvst.c | 4161 +++++++++++++++++++++
TESTING/EIG/ddrvsx.c | 1088 ++++++
TESTING/EIG/ddrvvx.c | 1121 ++++++
TESTING/EIG/derrbd.c | 400 ++
TESTING/EIG/derrec.c | 359 ++
TESTING/EIG/derred.c | 501 +++
TESTING/EIG/derrgg.c | 1319 +++++++
TESTING/EIG/derrhs.c | 525 +++
TESTING/EIG/derrst.c | 1309 +++++++
TESTING/EIG/dget02.c | 187 +
TESTING/EIG/dget10.c | 150 +
TESTING/EIG/dget22.c | 401 ++
TESTING/EIG/dget23.c | 963 +++++
TESTING/EIG/dget24.c | 1181 ++++++
TESTING/EIG/dget31.c | 586 +++
TESTING/EIG/dget32.c | 448 +++
TESTING/EIG/dget33.c | 229 ++
TESTING/EIG/dget34.c | 461 +++
TESTING/EIG/dget35.c | 285 ++
TESTING/EIG/dget36.c | 289 ++
TESTING/EIG/dget37.c | 708 ++++
TESTING/EIG/dget38.c | 611 +++
TESTING/EIG/dget39.c | 418 +++
TESTING/EIG/dget51.c | 262 ++
TESTING/EIG/dget52.c | 397 ++
TESTING/EIG/dget53.c | 232 ++
TESTING/EIG/dget54.c | 223 ++
TESTING/EIG/dglmts.c | 205 +
TESTING/EIG/dgqrts.c | 328 ++
TESTING/EIG/dgrqts.c | 331 ++
TESTING/EIG/dgsvts.c | 399 ++
TESTING/EIG/dhst01.c | 192 +
TESTING/EIG/dlafts.c | 221 ++
TESTING/EIG/dlahd2.c | 678 ++++
TESTING/EIG/dlarfy.c | 139 +
TESTING/EIG/dlarhs.c | 398 ++
TESTING/EIG/dlasum.c | 76 +
TESTING/EIG/dlatb9.c | 308 ++
TESTING/EIG/dlatm4.c | 492 +++
TESTING/EIG/dlctes.c | 80 +
TESTING/EIG/dlctsx.c | 105 +
TESTING/EIG/dlsets.c | 174 +
TESTING/EIG/dort01.c | 219 ++
TESTING/EIG/dort03.c | 259 ++
TESTING/EIG/dsbt21.c | 291 ++
TESTING/EIG/dsgt01.c | 220 ++
TESTING/EIG/dslect.c | 108 +
TESTING/EIG/dspt21.c | 468 +++
TESTING/EIG/dstech.c | 220 ++
TESTING/EIG/dstect.c | 167 +
TESTING/EIG/dstt21.c | 244 ++
TESTING/EIG/dstt22.c | 248 ++
TESTING/EIG/dsvdch.c | 191 +
TESTING/EIG/dsvdct.c | 194 +
TESTING/EIG/dsxt1.c | 134 +
TESTING/EIG/dsyt21.c | 455 +++
TESTING/EIG/dsyt22.c | 277 ++
TESTING/EIG/ilaenv.c | 321 ++
TESTING/EIG/sbdt01.c | 288 ++
TESTING/EIG/sbdt02.c | 171 +
TESTING/EIG/sbdt03.c | 261 ++
TESTING/EIG/schkbb.c | 767 ++++
TESTING/EIG/schkbd.c | 1263 +++++++
TESTING/EIG/schkbk.c | 231 ++
TESTING/EIG/schkbl.c | 263 ++
TESTING/EIG/schkec.c | 310 ++
TESTING/EIG/schkee.c | 3483 +++++++++++++++++
TESTING/EIG/schkgg.c | 1478 ++++++++
TESTING/EIG/schkgk.c | 348 ++
TESTING/EIG/schkgl.c | 307 ++
TESTING/EIG/schkhs.c | 1449 +++++++
TESTING/EIG/schksb.c | 806 ++++
TESTING/EIG/schkst.c | 2389 ++++++++++++
TESTING/EIG/sckglm.c | 325 ++
TESTING/EIG/sckgqr.c | 426 +++
TESTING/EIG/sckgsv.c | 310 ++
TESTING/EIG/scklse.c | 350 ++
TESTING/EIG/sdrges.c | 1135 ++++++
TESTING/EIG/sdrgev.c | 1067 ++++++
TESTING/EIG/sdrgsx.c | 1255 +++++++
TESTING/EIG/sdrgvx.c | 963 +++++
TESTING/EIG/sdrvbd.c | 1108 ++++++
TESTING/EIG/sdrves.c | 1095 ++++++
TESTING/EIG/sdrvev.c | 1110 ++++++
TESTING/EIG/sdrvgg.c | 1187 ++++++
TESTING/EIG/sdrvsg.c | 1881 ++++++++++
TESTING/EIG/sdrvst.c | 4151 +++++++++++++++++++++
TESTING/EIG/sdrvsx.c | 1080 ++++++
TESTING/EIG/sdrvvx.c | 1113 ++++++
TESTING/EIG/serrbd.c | 396 ++
TESTING/EIG/serrec.c | 356 ++
TESTING/EIG/serred.c | 467 +++
TESTING/EIG/serrgg.c | 1311 +++++++
TESTING/EIG/serrhs.c | 524 +++
TESTING/EIG/serrst.c | 1292 +++++++
TESTING/EIG/sget02.c | 188 +
TESTING/EIG/sget10.c | 149 +
TESTING/EIG/sget22.c | 401 ++
TESTING/EIG/sget23.c | 961 +++++
TESTING/EIG/sget24.c | 1180 ++++++
TESTING/EIG/sget31.c | 587 +++
TESTING/EIG/sget32.c | 450 +++
TESTING/EIG/sget33.c | 227 ++
TESTING/EIG/sget34.c | 459 +++
TESTING/EIG/sget35.c | 285 ++
TESTING/EIG/sget36.c | 288 ++
TESTING/EIG/sget37.c | 703 ++++
TESTING/EIG/sget38.c | 609 +++
TESTING/EIG/sget39.c | 414 ++
TESTING/EIG/sget51.c | 261 ++
TESTING/EIG/sget52.c | 394 ++
TESTING/EIG/sget53.c | 231 ++
TESTING/EIG/sget54.c | 222 ++
TESTING/EIG/sglmts.c | 199 +
TESTING/EIG/sgqrts.c | 324 ++
TESTING/EIG/sgrqts.c | 327 ++
TESTING/EIG/sgsvts.c | 396 ++
TESTING/EIG/shst01.c | 192 +
TESTING/EIG/slafts.c | 217 ++
TESTING/EIG/slahd2.c | 678 ++++
TESTING/EIG/slarfy.c | 135 +
TESTING/EIG/slarhs.c | 394 ++
TESTING/EIG/slasum.c | 76 +
TESTING/EIG/slatb9.c | 307 ++
TESTING/EIG/slatm4.c | 494 +++
TESTING/EIG/slctes.c | 80 +
TESTING/EIG/slctsx.c | 105 +
TESTING/EIG/slsets.c | 172 +
TESTING/EIG/sort01.c | 217 ++
TESTING/EIG/sort03.c | 259 ++
TESTING/EIG/ssbt21.c | 289 ++
TESTING/EIG/ssgt01.c | 217 ++
TESTING/EIG/sslect.c | 108 +
TESTING/EIG/sspt21.c | 460 +++
TESTING/EIG/sstech.c | 220 ++
TESTING/EIG/sstect.c | 167 +
TESTING/EIG/sstt21.c | 242 ++
TESTING/EIG/sstt22.c | 246 ++
TESTING/EIG/ssvdch.c | 191 +
TESTING/EIG/ssvdct.c | 194 +
TESTING/EIG/ssxt1.c | 134 +
TESTING/EIG/ssyt21.c | 452 +++
TESTING/EIG/ssyt22.c | 277 ++
TESTING/EIG/xerbla.c | 142 +
TESTING/EIG/xlaenv.c | 94 +
TESTING/EIG/zbdt01.c | 344 ++
TESTING/EIG/zbdt02.c | 177 +
TESTING/EIG/zbdt03.c | 300 ++
TESTING/EIG/zchkbb.c | 782 ++++
TESTING/EIG/zchkbd.c | 1135 ++++++
TESTING/EIG/zchkbk.c | 249 ++
TESTING/EIG/zchkbl.c | 279 ++
TESTING/EIG/zchkec.c | 212 ++
TESTING/EIG/zchkee.c | 3515 +++++++++++++++++
TESTING/EIG/zchkgg.c | 1549 ++++++++
TESTING/EIG/zchkgk.c | 366 ++
TESTING/EIG/zchkgl.c | 320 ++
TESTING/EIG/zchkhb.c | 831 +++++
TESTING/EIG/zchkhs.c | 1434 +++++++
TESTING/EIG/zchkst.c | 2464 ++++++++++++
TESTING/EIG/zckglm.c | 333 ++
TESTING/EIG/zckgqr.c | 425 +++
TESTING/EIG/zckgsv.c | 319 ++
TESTING/EIG/zcklse.c | 355 ++
TESTING/EIG/zdrges.c | 1141 ++++++
TESTING/EIG/zdrgev.c | 1153 ++++++
TESTING/EIG/zdrgsx.c | 1218 ++++++
TESTING/EIG/zdrgvx.c | 986 +++++
TESTING/EIG/zdrvbd.c | 978 +++++
TESTING/EIG/zdrves.c | 1047 ++++++
TESTING/EIG/zdrvev.c | 1102 ++++++
TESTING/EIG/zdrvgg.c | 1155 ++++++
TESTING/EIG/zdrvsg.c | 2022 ++++++++++
TESTING/EIG/zdrvst.c | 3201 ++++++++++++++++
TESTING/EIG/zdrvsx.c | 1089 ++++++
TESTING/EIG/zdrvvx.c | 1091 ++++++
TESTING/EIG/zerrbd.c | 354 ++
TESTING/EIG/zerrec.c | 355 ++
TESTING/EIG/zerred.c | 501 +++
TESTING/EIG/zerrgg.c | 1314 +++++++
TESTING/EIG/zerrhs.c | 536 +++
TESTING/EIG/zerrst.c | 1138 ++++++
TESTING/EIG/zget02.c | 189 +
TESTING/EIG/zget10.c | 151 +
TESTING/EIG/zget22.c | 346 ++
TESTING/EIG/zget23.c | 969 +++++
TESTING/EIG/zget24.c | 1183 ++++++
TESTING/EIG/zget35.c | 352 ++
TESTING/EIG/zget36.c | 276 ++
TESTING/EIG/zget37.c | 729 ++++
TESTING/EIG/zget38.c | 655 ++++
TESTING/EIG/zget51.c | 273 ++
TESTING/EIG/zget52.c | 298 ++
TESTING/EIG/zget54.c | 228 ++
TESTING/EIG/zglmts.c | 204 +
TESTING/EIG/zgqrts.c | 332 ++
TESTING/EIG/zgrqts.c | 335 ++
TESTING/EIG/zgsvts.c | 420 +++
TESTING/EIG/zhbt21.c | 306 ++
TESTING/EIG/zhet21.c | 513 +++
TESTING/EIG/zhet22.c | 296 ++
TESTING/EIG/zhpt21.c | 537 +++
TESTING/EIG/zhst01.c | 198 +
TESTING/EIG/zlarfy.c | 146 +
TESTING/EIG/zlarhs.c | 442 +++
TESTING/EIG/zlatm4.c | 476 +++
TESTING/EIG/zlctes.c | 95 +
TESTING/EIG/zlctsx.c | 104 +
TESTING/EIG/zlsets.c | 176 +
TESTING/EIG/zsbmv.c | 479 +++
TESTING/EIG/zsgt01.c | 225 ++
TESTING/EIG/zslect.c | 109 +
TESTING/EIG/zstt21.c | 260 ++
TESTING/EIG/zstt22.c | 291 ++
TESTING/EIG/zunt01.c | 240 ++
TESTING/EIG/zunt03.c | 312 ++
TESTING/LIN/CMakeLists.txt | 223 ++
TESTING/LIN/Makefile | 313 ++
TESTING/LIN/aladhd.c | 788 ++++
TESTING/LIN/alaerh.c | 2000 ++++++++++
TESTING/LIN/alaesm.c | 83 +
TESTING/LIN/alahd.c | 1774 +++++++++
TESTING/LIN/alareq.c | 277 ++
TESTING/LIN/alasum.c | 100 +
TESTING/LIN/alasvm.c | 100 +
TESTING/LIN/cchkaa.c | 1435 +++++++
TESTING/LIN/cchkeq.c | 703 ++++
TESTING/LIN/cchkgb.c | 871 +++++
TESTING/LIN/cchkge.c | 685 ++++
TESTING/LIN/cchkgt.c | 664 ++++
TESTING/LIN/cchkhe.c | 682 ++++
TESTING/LIN/cchkhp.c | 651 ++++
TESTING/LIN/cchklq.c | 467 +++
TESTING/LIN/cchkpb.c | 708 ++++
TESTING/LIN/cchkpo.c | 604 +++
TESTING/LIN/cchkpp.c | 569 +++
TESTING/LIN/cchkps.c | 374 ++
TESTING/LIN/cchkpt.c | 653 ++++
TESTING/LIN/cchkq3.c | 395 ++
TESTING/LIN/cchkql.c | 475 +++
TESTING/LIN/cchkqp.c | 361 ++
TESTING/LIN/cchkqr.c | 457 +++
TESTING/LIN/cchkrfp.c | 478 +++
TESTING/LIN/cchkrq.c | 477 +++
TESTING/LIN/cchksp.c | 650 ++++
TESTING/LIN/cchksy.c | 688 ++++
TESTING/LIN/cchktb.c | 734 ++++
TESTING/LIN/cchktp.c | 684 ++++
TESTING/LIN/cchktr.c | 725 ++++
TESTING/LIN/cchktz.c | 387 ++
TESTING/LIN/cdrvgb.c | 1122 ++++++
TESTING/LIN/cdrvgbx.c | 1474 ++++++++
TESTING/LIN/cdrvge.c | 901 +++++
TESTING/LIN/cdrvgex.c | 1218 ++++++
TESTING/LIN/cdrvgt.c | 726 ++++
TESTING/LIN/cdrvhe.c | 687 ++++
TESTING/LIN/cdrvhp.c | 693 ++++
TESTING/LIN/cdrvls.c | 847 +++++
TESTING/LIN/cdrvpb.c | 827 ++++
TESTING/LIN/cdrvpo.c | 718 ++++
TESTING/LIN/cdrvpox.c | 883 +++++
TESTING/LIN/cdrvpp.c | 718 ++++
TESTING/LIN/cdrvpt.c | 676 ++++
TESTING/LIN/cdrvrf1.c | 353 ++
TESTING/LIN/cdrvrf2.c | 323 ++
TESTING/LIN/cdrvrf3.c | 470 +++
TESTING/LIN/cdrvrf4.c | 422 +++
TESTING/LIN/cdrvrfp.c | 595 +++
TESTING/LIN/cdrvsp.c | 696 ++++
TESTING/LIN/cdrvsy.c | 695 ++++
TESTING/LIN/cebchvxx.c | 675 ++++
TESTING/LIN/cerrge.c | 532 +++
TESTING/LIN/cerrgex.c | 737 ++++
TESTING/LIN/cerrgt.c | 308 ++
TESTING/LIN/cerrhe.c | 406 ++
TESTING/LIN/cerrlq.c | 392 ++
TESTING/LIN/cerrls.c | 300 ++
TESTING/LIN/cerrpo.c | 605 +++
TESTING/LIN/cerrpox.c | 685 ++++
TESTING/LIN/cerrps.c | 173 +
TESTING/LIN/cerrql.c | 392 ++
TESTING/LIN/cerrqp.c | 172 +
TESTING/LIN/cerrqr.c | 392 ++
TESTING/LIN/cerrrfp.c | 360 ++
TESTING/LIN/cerrrq.c | 392 ++
TESTING/LIN/cerrsy.c | 406 ++
TESTING/LIN/cerrtr.c | 600 +++
TESTING/LIN/cerrtz.c | 164 +
TESTING/LIN/cerrvx.c | 1042 ++++++
TESTING/LIN/cgbt01.c | 247 ++
TESTING/LIN/cgbt02.c | 207 +
TESTING/LIN/cgbt05.c | 306 ++
TESTING/LIN/cgelqs.c | 165 +
TESTING/LIN/cgennd.c | 86 +
TESTING/LIN/cgeqls.c | 158 +
TESTING/LIN/cgeqrs.c | 157 +
TESTING/LIN/cgerqs.c | 164 +
TESTING/LIN/cget01.c | 214 ++
TESTING/LIN/cget02.c | 188 +
TESTING/LIN/cget03.c | 160 +
TESTING/LIN/cget04.c | 173 +
TESTING/LIN/cget07.c | 289 ++
TESTING/LIN/cgtt01.c | 279 ++
TESTING/LIN/cgtt02.c | 178 +
TESTING/LIN/cgtt05.c | 377 ++
TESTING/LIN/chet01.c | 238 ++
TESTING/LIN/chkxer.c | 70 +
TESTING/LIN/chpt01.c | 245 ++
TESTING/LIN/clahilb.c | 277 ++
TESTING/LIN/claipd.c | 103 +
TESTING/LIN/claptm.c | 423 +++
TESTING/LIN/clarhs.c | 433 +++
TESTING/LIN/clatb4.c | 482 +++
TESTING/LIN/clatb5.c | 184 +
TESTING/LIN/clatsp.c | 357 ++
TESTING/LIN/clatsy.c | 361 ++
TESTING/LIN/clattb.c | 998 +++++
TESTING/LIN/clattp.c | 1146 ++++++
TESTING/LIN/clattr.c | 1018 +++++
TESTING/LIN/clavhe.c | 679 ++++
TESTING/LIN/clavhp.c | 681 ++++
TESTING/LIN/clavsp.c | 661 ++++
TESTING/LIN/clavsy.c | 651 ++++
TESTING/LIN/clqt01.c | 226 ++
TESTING/LIN/clqt02.c | 216 ++
TESTING/LIN/clqt03.c | 259 ++
TESTING/LIN/cpbt01.c | 284 ++
TESTING/LIN/cpbt02.c | 182 +
TESTING/LIN/cpbt05.c | 334 ++
TESTING/LIN/cpot01.c | 257 ++
TESTING/LIN/cpot02.c | 175 +
TESTING/LIN/cpot03.c | 206 +
TESTING/LIN/cpot05.c | 319 ++
TESTING/LIN/cppt01.c | 268 ++
TESTING/LIN/cppt02.c | 174 +
TESTING/LIN/cppt03.c | 253 ++
TESTING/LIN/cppt05.c | 317 ++
TESTING/LIN/cpst01.c | 353 ++
TESTING/LIN/cptt01.c | 173 +
TESTING/LIN/cptt02.c | 167 +
TESTING/LIN/cptt05.c | 300 ++
TESTING/LIN/cqlt01.c | 255 ++
TESTING/LIN/cqlt02.c | 239 ++
TESTING/LIN/cqlt03.c | 284 ++
TESTING/LIN/cqpt01.c | 197 +
TESTING/LIN/cqrt01.c | 222 ++
TESTING/LIN/cqrt02.c | 215 ++
TESTING/LIN/cqrt03.c | 259 ++
TESTING/LIN/cqrt11.c | 160 +
TESTING/LIN/cqrt12.c | 227 ++
TESTING/LIN/cqrt13.c | 166 +
TESTING/LIN/cqrt14.c | 268 ++
TESTING/LIN/cqrt15.c | 304 ++
TESTING/LIN/cqrt16.c | 185 +
TESTING/LIN/cqrt17.c | 240 ++
TESTING/LIN/crqt01.c | 255 ++
TESTING/LIN/crqt02.c | 238 ++
TESTING/LIN/crqt03.c | 285 ++
TESTING/LIN/crzt01.c | 173 +
TESTING/LIN/crzt02.c | 155 +
TESTING/LIN/csbmv.c | 479 +++
TESTING/LIN/cspt01.c | 203 +
TESTING/LIN/cspt02.c | 175 +
TESTING/LIN/cspt03.c | 347 ++
TESTING/LIN/csyt01.c | 209 ++
TESTING/LIN/csyt02.c | 175 +
TESTING/LIN/csyt03.c | 205 +
TESTING/LIN/ctbt02.c | 208 ++
TESTING/LIN/ctbt03.c | 261 ++
TESTING/LIN/ctbt05.c | 374 ++
TESTING/LIN/ctbt06.c | 160 +
TESTING/LIN/ctpt01.c | 197 +
TESTING/LIN/ctpt02.c | 196 +
TESTING/LIN/ctpt03.c | 253 ++
TESTING/LIN/ctpt05.c | 356 ++
TESTING/LIN/ctpt06.c | 149 +
TESTING/LIN/ctrt01.c | 200 +
TESTING/LIN/ctrt02.c | 201 +
TESTING/LIN/ctrt03.c | 247 ++
TESTING/LIN/ctrt05.c | 355 ++
TESTING/LIN/ctrt06.c | 157 +
TESTING/LIN/ctzt01.c | 177 +
TESTING/LIN/ctzt02.c | 164 +
TESTING/LIN/dchkaa.c | 1387 +++++++
TESTING/LIN/dchkab.c | 573 +++
TESTING/LIN/dchkeq.c | 673 ++++
TESTING/LIN/dchkgb.c | 873 +++++
TESTING/LIN/dchkge.c | 685 ++++
TESTING/LIN/dchkgt.c | 655 ++++
TESTING/LIN/dchklq.c | 473 +++
TESTING/LIN/dchkpb.c | 710 ++++
TESTING/LIN/dchkpo.c | 603 +++
TESTING/LIN/dchkpp.c | 567 +++
TESTING/LIN/dchkps.c | 379 ++
TESTING/LIN/dchkpt.c | 614 +++
TESTING/LIN/dchkq3.c | 400 ++
TESTING/LIN/dchkql.c | 481 +++
TESTING/LIN/dchkqp.c | 361 ++
TESTING/LIN/dchkqr.c | 467 +++
TESTING/LIN/dchkrfp.c | 477 +++
TESTING/LIN/dchkrq.c | 486 +++
TESTING/LIN/dchksp.c | 641 ++++
TESTING/LIN/dchksy.c | 679 ++++
TESTING/LIN/dchktb.c | 741 ++++
TESTING/LIN/dchktp.c | 693 ++++
TESTING/LIN/dchktr.c | 734 ++++
TESTING/LIN/dchktz.c | 392 ++
TESTING/LIN/ddrvab.c | 494 +++
TESTING/LIN/ddrvac.c | 529 +++
TESTING/LIN/ddrvgb.c | 1129 ++++++
TESTING/LIN/ddrvgbx.c | 1489 ++++++++
TESTING/LIN/ddrvge.c | 902 +++++
TESTING/LIN/ddrvgex.c | 1220 ++++++
TESTING/LIN/ddrvgt.c | 709 ++++
TESTING/LIN/ddrvls.c | 862 +++++
TESTING/LIN/ddrvpb.c | 827 ++++
TESTING/LIN/ddrvpo.c | 714 ++++
TESTING/LIN/ddrvpox.c | 879 +++++
TESTING/LIN/ddrvpp.c | 717 ++++
TESTING/LIN/ddrvpt.c | 658 ++++
TESTING/LIN/ddrvrf1.c | 342 ++
TESTING/LIN/ddrvrf2.c | 311 ++
TESTING/LIN/ddrvrf3.c | 439 +++
TESTING/LIN/ddrvrf4.c | 416 +++
TESTING/LIN/ddrvrfp.c | 590 +++
TESTING/LIN/ddrvsp.c | 680 ++++
TESTING/LIN/ddrvsy.c | 682 ++++
TESTING/LIN/debchvxx.c | 604 +++
TESTING/LIN/derrab.c | 177 +
TESTING/LIN/derrac.c | 181 +
TESTING/LIN/derrge.c | 511 +++
TESTING/LIN/derrgex.c | 716 ++++
TESTING/LIN/derrgt.c | 289 ++
TESTING/LIN/derrlq.c | 376 ++
TESTING/LIN/derrls.c | 295 ++
TESTING/LIN/derrpo.c | 573 +++
TESTING/LIN/derrpox.c | 656 ++++
TESTING/LIN/derrps.c | 166 +
TESTING/LIN/derrql.c | 376 ++
TESTING/LIN/derrqp.c | 169 +
TESTING/LIN/derrqr.c | 377 ++
TESTING/LIN/derrrfp.c | 357 ++
TESTING/LIN/derrrq.c | 377 ++
TESTING/LIN/derrsy.c | 392 ++
TESTING/LIN/derrtr.c | 609 +++
TESTING/LIN/derrtz.c | 163 +
TESTING/LIN/derrvx.c | 884 +++++
TESTING/LIN/dgbt01.c | 241 ++
TESTING/LIN/dgbt02.c | 206 +
TESTING/LIN/dgbt05.c | 281 ++
TESTING/LIN/dgelqs.c | 166 +
TESTING/LIN/dgennd.c | 80 +
TESTING/LIN/dgeqls.c | 158 +
TESTING/LIN/dgeqrs.c | 157 +
TESTING/LIN/dgerqs.c | 165 +
TESTING/LIN/dget01.c | 202 +
TESTING/LIN/dget02.c | 187 +
TESTING/LIN/dget03.c | 156 +
TESTING/LIN/dget04.c | 159 +
TESTING/LIN/dget06.c | 80 +
TESTING/LIN/dget07.c | 264 ++
TESTING/LIN/dget08.c | 189 +
TESTING/LIN/dgtt01.c | 232 ++
TESTING/LIN/dgtt02.c | 180 +
TESTING/LIN/dgtt05.c | 285 ++
TESTING/LIN/dlahilb.c | 202 +
TESTING/LIN/dlaord.c | 131 +
TESTING/LIN/dlaptm.c | 183 +
TESTING/LIN/dlarhs.c | 398 ++
TESTING/LIN/dlatb4.c | 483 +++
TESTING/LIN/dlatb5.c | 184 +
TESTING/LIN/dlattb.c | 858 +++++
TESTING/LIN/dlattp.c | 943 +++++
TESTING/LIN/dlattr.c | 852 +++++
TESTING/LIN/dlavsp.c | 560 +++
TESTING/LIN/dlavsy.c | 550 +++
TESTING/LIN/dlqt01.c | 224 ++
TESTING/LIN/dlqt02.c | 217 ++
TESTING/LIN/dlqt03.c | 262 ++
TESTING/LIN/dpbt01.c | 244 ++
TESTING/LIN/dpbt02.c | 181 +
TESTING/LIN/dpbt05.c | 291 ++
TESTING/LIN/dpot01.c | 213 ++
TESTING/LIN/dpot02.c | 175 +
TESTING/LIN/dpot03.c | 196 +
TESTING/LIN/dpot05.c | 277 ++
TESTING/LIN/dpot06.c | 180 +
TESTING/LIN/dppt01.c | 195 +
TESTING/LIN/dppt02.c | 176 +
TESTING/LIN/dppt03.c | 228 ++
TESTING/LIN/dppt05.c | 275 ++
TESTING/LIN/dpst01.c | 301 ++
TESTING/LIN/dptt01.c | 155 +
TESTING/LIN/dptt02.c | 162 +
TESTING/LIN/dptt05.c | 246 ++
TESTING/LIN/dqlt01.c | 253 ++
TESTING/LIN/dqlt02.c | 239 ++
TESTING/LIN/dqlt03.c | 287 ++
TESTING/LIN/dqpt01.c | 194 +
TESTING/LIN/dqrt01.c | 223 ++
TESTING/LIN/dqrt02.c | 217 ++
TESTING/LIN/dqrt03.c | 262 ++
TESTING/LIN/dqrt11.c | 156 +
TESTING/LIN/dqrt12.c | 221 ++
TESTING/LIN/dqrt13.c | 158 +
TESTING/LIN/dqrt14.c | 263 ++
TESTING/LIN/dqrt15.c | 303 ++
TESTING/LIN/dqrt16.c | 184 +
TESTING/LIN/dqrt17.c | 240 ++
TESTING/LIN/drqt01.c | 256 ++
TESTING/LIN/drqt02.c | 240 ++
TESTING/LIN/drqt03.c | 288 ++
TESTING/LIN/drzt01.c | 172 +
TESTING/LIN/drzt02.c | 152 +
TESTING/LIN/dspt01.c | 193 +
TESTING/LIN/dsyt01.c | 197 +
TESTING/LIN/dtbt02.c | 203 +
TESTING/LIN/dtbt03.c | 257 ++
TESTING/LIN/dtbt05.c | 334 ++
TESTING/LIN/dtbt06.c | 164 +
TESTING/LIN/dtpt01.c | 189 +
TESTING/LIN/dtpt02.c | 191 +
TESTING/LIN/dtpt03.c | 252 ++
TESTING/LIN/dtpt05.c | 315 ++
TESTING/LIN/dtpt06.c | 156 +
TESTING/LIN/dtrt01.c | 195 +
TESTING/LIN/dtrt02.c | 199 +
TESTING/LIN/dtrt03.c | 245 ++
TESTING/LIN/dtrt05.c | 314 ++
TESTING/LIN/dtrt06.c | 164 +
TESTING/LIN/dtzt01.c | 175 +
TESTING/LIN/dtzt02.c | 156 +
TESTING/LIN/icopy.c | 132 +
TESTING/LIN/ilaenv.c | 194 +
TESTING/LIN/memory_alloc.h | 12 +
TESTING/LIN/schkaa.c | 1360 +++++++
TESTING/LIN/schkeq.c | 671 ++++
TESTING/LIN/schkgb.c | 867 +++++
TESTING/LIN/schkge.c | 679 ++++
TESTING/LIN/schkgt.c | 641 ++++
TESTING/LIN/schklq.c | 459 +++
TESTING/LIN/schkpb.c | 698 ++++
TESTING/LIN/schkpo.c | 599 +++
TESTING/LIN/schkpp.c | 558 +++
TESTING/LIN/schkps.c | 376 ++
TESTING/LIN/schkpt.c | 607 +++
TESTING/LIN/schkq3.c | 397 ++
TESTING/LIN/schkql.c | 469 +++
TESTING/LIN/schkqp.c | 360 ++
TESTING/LIN/schkqr.c | 459 +++
TESTING/LIN/schkrfp.c | 472 +++
TESTING/LIN/schkrq.c | 469 +++
TESTING/LIN/schksp.c | 630 ++++
TESTING/LIN/schksy.c | 672 ++++
TESTING/LIN/schktb.c | 738 ++++
TESTING/LIN/schktp.c | 685 ++++
TESTING/LIN/schktr.c | 726 ++++
TESTING/LIN/schktz.c | 390 ++
TESTING/LIN/sdrvgb.c | 1115 ++++++
TESTING/LIN/sdrvgbx.c | 1472 ++++++++
TESTING/LIN/sdrvge.c | 899 +++++
TESTING/LIN/sdrvgex.c | 1216 ++++++
TESTING/LIN/sdrvgt.c | 698 ++++
TESTING/LIN/sdrvls.c | 850 +++++
TESTING/LIN/sdrvpb.c | 815 ++++
TESTING/LIN/sdrvpo.c | 707 ++++
TESTING/LIN/sdrvpox.c | 871 +++++
TESTING/LIN/sdrvpp.c | 705 ++++
TESTING/LIN/sdrvpt.c | 652 ++++
TESTING/LIN/sdrvrf1.c | 341 ++
TESTING/LIN/sdrvrf2.c | 309 ++
TESTING/LIN/sdrvrf3.c | 436 +++
TESTING/LIN/sdrvrf4.c | 411 ++
TESTING/LIN/sdrvrfp.c | 582 +++
TESTING/LIN/sdrvsp.c | 669 ++++
TESTING/LIN/sdrvsy.c | 672 ++++
TESTING/LIN/sebchvxx.c | 599 +++
TESTING/LIN/serrge.c | 508 +++
TESTING/LIN/serrgex.c | 709 ++++
TESTING/LIN/serrgt.c | 285 ++
TESTING/LIN/serrlq.c | 374 ++
TESTING/LIN/serrls.c | 293 ++
TESTING/LIN/serrpo.c | 564 +++
TESTING/LIN/serrpox.c | 644 ++++
TESTING/LIN/serrps.c | 167 +
TESTING/LIN/serrql.c | 374 ++
TESTING/LIN/serrqp.c | 168 +
TESTING/LIN/serrqr.c | 375 ++
TESTING/LIN/serrrfp.c | 355 ++
TESTING/LIN/serrrq.c | 375 ++
TESTING/LIN/serrsy.c | 388 ++
TESTING/LIN/serrtr.c | 607 +++
TESTING/LIN/serrtz.c | 162 +
TESTING/LIN/serrvx.c | 874 +++++
TESTING/LIN/sgbt01.c | 241 ++
TESTING/LIN/sgbt02.c | 207 +
TESTING/LIN/sgbt05.c | 282 ++
TESTING/LIN/sgelqs.c | 165 +
TESTING/LIN/sgennd.c | 80 +
TESTING/LIN/sgeqls.c | 157 +
TESTING/LIN/sgeqrs.c | 156 +
TESTING/LIN/sgerqs.c | 164 +
TESTING/LIN/sget01.c | 198 +
TESTING/LIN/sget02.c | 188 +
TESTING/LIN/sget03.c | 156 +
TESTING/LIN/sget04.c | 157 +
TESTING/LIN/sget06.c | 80 +
TESTING/LIN/sget07.c | 264 ++
TESTING/LIN/sgtt01.c | 231 ++
TESTING/LIN/sgtt02.c | 179 +
TESTING/LIN/sgtt05.c | 284 ++
TESTING/LIN/slahilb.c | 199 +
TESTING/LIN/slaord.c | 130 +
TESTING/LIN/slaptm.c | 183 +
TESTING/LIN/slarhs.c | 394 ++
TESTING/LIN/slatb4.c | 483 +++
TESTING/LIN/slatb5.c | 184 +
TESTING/LIN/slattb.c | 859 +++++
TESTING/LIN/slattp.c | 943 +++++
TESTING/LIN/slattr.c | 855 +++++
TESTING/LIN/slavsp.c | 558 +++
TESTING/LIN/slavsy.c | 548 +++
TESTING/LIN/slqt01.c | 223 ++
TESTING/LIN/slqt02.c | 215 ++
TESTING/LIN/slqt03.c | 260 ++
TESTING/LIN/spbt01.c | 242 ++
TESTING/LIN/spbt02.c | 180 +
TESTING/LIN/spbt05.c | 292 ++
TESTING/LIN/spot01.c | 211 ++
TESTING/LIN/spot02.c | 174 +
TESTING/LIN/spot03.c | 196 +
TESTING/LIN/spot05.c | 276 ++
TESTING/LIN/sppt01.c | 194 +
TESTING/LIN/sppt02.c | 174 +
TESTING/LIN/sppt03.c | 226 ++
TESTING/LIN/sppt05.c | 274 ++
TESTING/LIN/spst01.c | 299 ++
TESTING/LIN/sptt01.c | 155 +
TESTING/LIN/sptt02.c | 160 +
TESTING/LIN/sptt05.c | 245 ++
TESTING/LIN/sqlt01.c | 252 ++
TESTING/LIN/sqlt02.c | 237 ++
TESTING/LIN/sqlt03.c | 284 ++
TESTING/LIN/sqpt01.c | 193 +
TESTING/LIN/sqrt01.c | 221 ++
TESTING/LIN/sqrt02.c | 214 ++
TESTING/LIN/sqrt03.c | 259 ++
TESTING/LIN/sqrt11.c | 155 +
TESTING/LIN/sqrt12.c | 219 ++
TESTING/LIN/sqrt13.c | 155 +
TESTING/LIN/sqrt14.c | 260 ++
TESTING/LIN/sqrt15.c | 299 ++
TESTING/LIN/sqrt16.c | 185 +
TESTING/LIN/sqrt17.c | 238 ++
TESTING/LIN/srqt01.c | 254 ++
TESTING/LIN/srqt02.c | 237 ++
TESTING/LIN/srqt03.c | 284 ++
TESTING/LIN/srzt01.c | 169 +
TESTING/LIN/srzt02.c | 150 +
TESTING/LIN/sspt01.c | 190 +
TESTING/LIN/ssyt01.c | 197 +
TESTING/LIN/stbt02.c | 202 +
TESTING/LIN/stbt03.c | 256 ++
TESTING/LIN/stbt05.c | 333 ++
TESTING/LIN/stbt06.c | 166 +
TESTING/LIN/stpt01.c | 189 +
TESTING/LIN/stpt02.c | 192 +
TESTING/LIN/stpt03.c | 252 ++
TESTING/LIN/stpt05.c | 314 ++
TESTING/LIN/stpt06.c | 155 +
TESTING/LIN/strt01.c | 196 +
TESTING/LIN/strt02.c | 199 +
TESTING/LIN/strt03.c | 245 ++
TESTING/LIN/strt05.c | 314 ++
TESTING/LIN/strt06.c | 163 +
TESTING/LIN/stzt01.c | 172 +
TESTING/LIN/stzt02.c | 154 +
TESTING/LIN/tags | 460 +++
TESTING/LIN/xerbla.c | 142 +
TESTING/LIN/xlaenv.c | 91 +
TESTING/LIN/zchkaa.c | 1467 ++++++++
TESTING/LIN/zchkab.c | 574 +++
TESTING/LIN/zchkeq.c | 705 ++++
TESTING/LIN/zchkgb.c | 879 +++++
TESTING/LIN/zchkge.c | 691 ++++
TESTING/LIN/zchkgt.c | 674 ++++
TESTING/LIN/zchkhe.c | 692 ++++
TESTING/LIN/zchkhp.c | 659 ++++
TESTING/LIN/zchklq.c | 475 +++
TESTING/LIN/zchkpb.c | 716 ++++
TESTING/LIN/zchkpo.c | 611 +++
TESTING/LIN/zchkpp.c | 582 +++
TESTING/LIN/zchkps.c | 377 ++
TESTING/LIN/zchkpt.c | 659 ++++
TESTING/LIN/zchkq3.c | 399 ++
TESTING/LIN/zchkql.c | 483 +++
TESTING/LIN/zchkqp.c | 365 ++
TESTING/LIN/zchkqr.c | 463 +++
TESTING/LIN/zchkrfp.c | 481 +++
TESTING/LIN/zchkrq.c | 483 +++
TESTING/LIN/zchksp.c | 660 ++++
TESTING/LIN/zchksy.c | 694 ++++
TESTING/LIN/zchktb.c | 739 ++++
TESTING/LIN/zchktp.c | 692 ++++
TESTING/LIN/zchktr.c | 730 ++++
TESTING/LIN/zchktz.c | 392 ++
TESTING/LIN/zdrvab.c | 493 +++
TESTING/LIN/zdrvac.c | 544 +++
TESTING/LIN/zdrvgb.c | 1138 ++++++
TESTING/LIN/zdrvgbx.c | 1494 ++++++++
TESTING/LIN/zdrvge.c | 910 +++++
TESTING/LIN/zdrvgex.c | 1227 ++++++
TESTING/LIN/zdrvgt.c | 733 ++++
TESTING/LIN/zdrvhe.c | 693 ++++
TESTING/LIN/zdrvhp.c | 698 ++++
TESTING/LIN/zdrvls.c | 857 +++++
TESTING/LIN/zdrvpb.c | 836 +++++
TESTING/LIN/zdrvpo.c | 719 ++++
TESTING/LIN/zdrvpox.c | 886 +++++
TESTING/LIN/zdrvpp.c | 723 ++++
TESTING/LIN/zdrvpt.c | 685 ++++
TESTING/LIN/zdrvrf1.c | 356 ++
TESTING/LIN/zdrvrf2.c | 326 ++
TESTING/LIN/zdrvrf3.c | 474 +++
TESTING/LIN/zdrvrf4.c | 426 +++
TESTING/LIN/zdrvrfp.c | 605 +++
TESTING/LIN/zdrvsp.c | 701 ++++
TESTING/LIN/zdrvsy.c | 697 ++++
TESTING/LIN/zebchvxx.c | 688 ++++
TESTING/LIN/zerrab.c | 197 +
TESTING/LIN/zerrac.c | 199 +
TESTING/LIN/zerrge.c | 536 +++
TESTING/LIN/zerrgex.c | 747 ++++
TESTING/LIN/zerrgt.c | 313 ++
TESTING/LIN/zerrhe.c | 412 ++
TESTING/LIN/zerrlq.c | 394 ++
TESTING/LIN/zerrls.c | 302 ++
TESTING/LIN/zerrpo.c | 612 +++
TESTING/LIN/zerrpox.c | 693 ++++
TESTING/LIN/zerrps.c | 172 +
TESTING/LIN/zerrql.c | 394 ++
TESTING/LIN/zerrqp.c | 172 +
TESTING/LIN/zerrqr.c | 394 ++
TESTING/LIN/zerrrfp.c | 362 ++
TESTING/LIN/zerrrq.c | 394 ++
TESTING/LIN/zerrsy.c | 410 ++
TESTING/LIN/zerrtr.c | 605 +++
TESTING/LIN/zerrtz.c | 165 +
TESTING/LIN/zerrvx.c | 1056 ++++++
TESTING/LIN/zgbt01.c | 247 ++
TESTING/LIN/zgbt02.c | 210 ++
TESTING/LIN/zgbt05.c | 307 ++
TESTING/LIN/zgelqs.c | 167 +
TESTING/LIN/zgennd.c | 86 +
TESTING/LIN/zgeqls.c | 159 +
TESTING/LIN/zgeqrs.c | 158 +
TESTING/LIN/zgerqs.c | 166 +
TESTING/LIN/zget01.c | 213 ++
TESTING/LIN/zget02.c | 190 +
TESTING/LIN/zget03.c | 160 +
TESTING/LIN/zget04.c | 174 +
TESTING/LIN/zget07.c | 290 ++
TESTING/LIN/zget08.c | 201 +
TESTING/LIN/zgtt01.c | 281 ++
TESTING/LIN/zgtt02.c | 181 +
TESTING/LIN/zgtt05.c | 378 ++
TESTING/LIN/zhet01.c | 238 ++
TESTING/LIN/zhpt01.c | 244 ++
TESTING/LIN/zlahilb.c | 277 ++
TESTING/LIN/zlaipd.c | 103 +
TESTING/LIN/zlaptm.c | 423 +++
TESTING/LIN/zlarhs.c | 442 +++
TESTING/LIN/zlatb4.c | 482 +++
TESTING/LIN/zlatb5.c | 184 +
TESTING/LIN/zlatsp.c | 358 ++
TESTING/LIN/zlatsy.c | 362 ++
TESTING/LIN/zlattb.c | 997 +++++
TESTING/LIN/zlattp.c | 1143 ++++++
TESTING/LIN/zlattr.c | 1015 +++++
TESTING/LIN/zlavhe.c | 679 ++++
TESTING/LIN/zlavhp.c | 681 ++++
TESTING/LIN/zlavsp.c | 661 ++++
TESTING/LIN/zlavsy.c | 651 ++++
TESTING/LIN/zlqt01.c | 229 ++
TESTING/LIN/zlqt02.c | 220 ++
TESTING/LIN/zlqt03.c | 263 ++
TESTING/LIN/zpbt01.c | 284 ++
TESTING/LIN/zpbt02.c | 181 +
TESTING/LIN/zpbt05.c | 334 ++
TESTING/LIN/zpot01.c | 259 ++
TESTING/LIN/zpot02.c | 174 +
TESTING/LIN/zpot03.c | 208 ++
TESTING/LIN/zpot05.c | 320 ++
TESTING/LIN/zpot06.c | 190 +
TESTING/LIN/zppt01.c | 270 ++
TESTING/LIN/zppt02.c | 175 +
TESTING/LIN/zppt03.c | 255 ++
TESTING/LIN/zppt05.c | 318 ++
TESTING/LIN/zpst01.c | 355 ++
TESTING/LIN/zptt01.c | 174 +
TESTING/LIN/zptt02.c | 167 +
TESTING/LIN/zptt05.c | 301 ++
TESTING/LIN/zqlt01.c | 258 ++
TESTING/LIN/zqlt02.c | 243 ++
TESTING/LIN/zqlt03.c | 288 ++
TESTING/LIN/zqpt01.c | 197 +
TESTING/LIN/zqrt01.c | 226 ++
TESTING/LIN/zqrt02.c | 219 ++
TESTING/LIN/zqrt03.c | 262 ++
TESTING/LIN/zqrt11.c | 160 +
TESTING/LIN/zqrt12.c | 230 ++
TESTING/LIN/zqrt13.c | 166 +
TESTING/LIN/zqrt14.c | 270 ++
TESTING/LIN/zqrt15.c | 310 ++
TESTING/LIN/zqrt16.c | 187 +
TESTING/LIN/zqrt17.c | 244 ++
TESTING/LIN/zrqt01.c | 259 ++
TESTING/LIN/zrqt02.c | 242 ++
TESTING/LIN/zrqt03.c | 288 ++
TESTING/LIN/zrzt01.c | 174 +
TESTING/LIN/zrzt02.c | 156 +
TESTING/LIN/zsbmv.c | 479 +++
TESTING/LIN/zspt01.c | 205 +
TESTING/LIN/zspt02.c | 175 +
TESTING/LIN/zspt03.c | 348 ++
TESTING/LIN/zsyt01.c | 210 ++
TESTING/LIN/zsyt02.c | 174 +
TESTING/LIN/zsyt03.c | 206 +
TESTING/LIN/ztbt02.c | 208 ++
TESTING/LIN/ztbt03.c | 263 ++
TESTING/LIN/ztbt05.c | 375 ++
TESTING/LIN/ztbt06.c | 160 +
TESTING/LIN/ztpt01.c | 199 +
TESTING/LIN/ztpt02.c | 197 +
TESTING/LIN/ztpt03.c | 254 ++
TESTING/LIN/ztpt05.c | 356 ++
TESTING/LIN/ztpt06.c | 150 +
TESTING/LIN/ztrt01.c | 201 +
TESTING/LIN/ztrt02.c | 203 +
TESTING/LIN/ztrt03.c | 248 ++
TESTING/LIN/ztrt05.c | 356 ++
TESTING/LIN/ztrt06.c | 158 +
TESTING/LIN/ztzt01.c | 178 +
TESTING/LIN/ztzt02.c | 165 +
TESTING/MATGEN/CMakeLists.txt | 69 +
TESTING/MATGEN/Makefile | 99 +
TESTING/MATGEN/clagge.c | 478 +++
TESTING/MATGEN/claghe.c | 327 ++
TESTING/MATGEN/clagsy.c | 379 ++
TESTING/MATGEN/clahilb.c | 277 ++
TESTING/MATGEN/clakf2.c | 193 +
TESTING/MATGEN/clarge.c | 179 +
TESTING/MATGEN/clarnd.c | 139 +
TESTING/MATGEN/claror.c | 364 ++
TESTING/MATGEN/clarot.c | 374 ++
TESTING/MATGEN/clatm1.c | 315 ++
TESTING/MATGEN/clatm2.c | 295 ++
TESTING/MATGEN/clatm3.c | 306 ++
TESTING/MATGEN/clatm5.c | 693 ++++
TESTING/MATGEN/clatm6.c | 376 ++
TESTING/MATGEN/clatme.c | 635 ++++
TESTING/MATGEN/clatmr.c | 1504 ++++++++
TESTING/MATGEN/clatms.c | 1627 ++++++++
TESTING/MATGEN/clatmt.c | 1633 ++++++++
TESTING/MATGEN/dlagge.c | 414 ++
TESTING/MATGEN/dlagsy.c | 291 ++
TESTING/MATGEN/dlahilb.c | 202 +
TESTING/MATGEN/dlakf2.c | 187 +
TESTING/MATGEN/dlaran.c | 123 +
TESTING/MATGEN/dlarge.c | 170 +
TESTING/MATGEN/dlarnd.c | 108 +
TESTING/MATGEN/dlaror.c | 302 ++
TESTING/MATGEN/dlarot.c | 308 ++
TESTING/MATGEN/dlatm1.c | 283 ++
TESTING/MATGEN/dlatm2.c | 251 ++
TESTING/MATGEN/dlatm3.c | 261 ++
TESTING/MATGEN/dlatm5.c | 516 +++
TESTING/MATGEN/dlatm6.c | 311 ++
TESTING/MATGEN/dlatm7.c | 305 ++
TESTING/MATGEN/dlatme.c | 693 ++++
TESTING/MATGEN/dlatmr.c | 1288 +++++++
TESTING/MATGEN/dlatms.c | 1328 +++++++
TESTING/MATGEN/dlatmt.c | 1336 +++++++
TESTING/MATGEN/slagge.c | 414 ++
TESTING/MATGEN/slagsy.c | 285 ++
TESTING/MATGEN/slahilb.c | 199 +
TESTING/MATGEN/slakf2.c | 186 +
TESTING/MATGEN/slaran.c | 124 +
TESTING/MATGEN/slarge.c | 170 +
TESTING/MATGEN/slarnd.c | 108 +
TESTING/MATGEN/slaror.c | 299 ++
TESTING/MATGEN/slarot.c | 308 ++
TESTING/MATGEN/slatm1.c | 284 ++
TESTING/MATGEN/slatm2.c | 251 ++
TESTING/MATGEN/slatm3.c | 261 ++
TESTING/MATGEN/slatm5.c | 507 +++
TESTING/MATGEN/slatm6.c | 309 ++
TESTING/MATGEN/slatm7.c | 307 ++
TESTING/MATGEN/slatme.c | 688 ++++
TESTING/MATGEN/slatmr.c | 1288 +++++++
TESTING/MATGEN/slatms.c | 1326 +++++++
TESTING/MATGEN/slatmt.c | 1334 +++++++
TESTING/MATGEN/zlagge.c | 479 +++
TESTING/MATGEN/zlaghe.c | 332 ++
TESTING/MATGEN/zlagsy.c | 380 ++
TESTING/MATGEN/zlahilb.c | 277 ++
TESTING/MATGEN/zlakf2.c | 194 +
TESTING/MATGEN/zlarge.c | 180 +
TESTING/MATGEN/zlarnd.c | 140 +
TESTING/MATGEN/zlaror.c | 369 ++
TESTING/MATGEN/zlarot.c | 374 ++
TESTING/MATGEN/zlatm1.c | 314 ++
TESTING/MATGEN/zlatm2.c | 298 ++
TESTING/MATGEN/zlatm3.c | 308 ++
TESTING/MATGEN/zlatm5.c | 696 ++++
TESTING/MATGEN/zlatm6.c | 378 ++
TESTING/MATGEN/zlatme.c | 640 ++++
TESTING/MATGEN/zlatmr.c | 1506 ++++++++
TESTING/MATGEN/zlatms.c | 1632 ++++++++
TESTING/MATGEN/zlatmt.c | 1638 ++++++++
TESTING/Makefile | 564 +++
TESTING/cbak.in | 208 ++
TESTING/cbal.in | 350 ++
TESTING/cbb.in | 12 +
TESTING/cec.in | 517 +++
TESTING/ced.in | 1023 +++++
TESTING/cgbak.in | 446 +++
TESTING/cgbal.in | 660 ++++
TESTING/cgd.in | 182 +
TESTING/cgg.in | 15 +
TESTING/csb.in | 9 +
TESTING/csg.in | 13 +
TESTING/ctest.in | 39 +
TESTING/ctest_rfp.in | 9 +
TESTING/dbak.in | 130 +
TESTING/dbal.in | 215 ++
TESTING/dbb.in | 12 +
TESTING/dec.in | 950 +++++
TESTING/ded.in | 865 +++++
TESTING/dgbak.in | 266 ++
TESTING/dgbal.in | 304 ++
TESTING/dgd.in | 86 +
TESTING/dgg.in | 15 +
TESTING/dsb.in | 9 +
TESTING/dsg.in | 13 +
TESTING/dstest.in | 10 +
TESTING/dtest.in | 37 +
TESTING/dtest_rfp.in | 9 +
TESTING/glm.in | 9 +
TESTING/gqr.in | 9 +
TESTING/gsv.in | 9 +
TESTING/lse.in | 9 +
TESTING/nep.in | 16 +
TESTING/out | 4332 +++++++++++++++++++++
TESTING/runtest.cmake | 31 +
TESTING/sbak.in | 130 +
TESTING/sbal.in | 213 ++
TESTING/sbb.in | 12 +
TESTING/sec.in | 950 +++++
TESTING/sed.in | 865 +++++
TESTING/sep.in | 13 +
TESTING/sgbak.in | 266 ++
TESTING/sgbal.in | 304 ++
TESTING/sgd.in | 86 +
TESTING/sgg.in | 15 +
TESTING/ssb.in | 9 +
TESTING/ssg.in | 13 +
TESTING/stest.in | 37 +
TESTING/stest_rfp.in | 9 +
TESTING/svd.in | 15 +
TESTING/zbak.in | 208 ++
TESTING/zbal.in | 355 ++
TESTING/zbb.in | 12 +
TESTING/zctest.in | 10 +
TESTING/zec.in | 517 +++
TESTING/zed.in | 1023 +++++
TESTING/zgbak.in | 446 +++
TESTING/zgbal.in | 660 ++++
TESTING/zgd.in | 182 +
TESTING/zgg.in | 15 +
TESTING/zsb.in | 9 +
TESTING/zsg.in | 13 +
TESTING/ztest.in | 39 +
TESTING/ztest_rfp.in | 9 +
clapack-config-version.cmake.in | 8 +
clapack-config.cmake.in | 1 +
clapack_build.cmake | 238 ++
make.inc.example | 79 +
3097 files changed, 1273420 insertions(+)
diff --git a/BLAS/CMakeLists.txt b/BLAS/CMakeLists.txt
new file mode 100644
index 0000000..3387cd1
--- /dev/null
+++ b/BLAS/CMakeLists.txt
@@ -0,0 +1,2 @@
+add_subdirectory(SRC)
+add_subdirectory(TESTING)
diff --git a/BLAS/SRC/CMakeLists.txt b/BLAS/SRC/CMakeLists.txt
new file mode 100644
index 0000000..d1caff8
--- /dev/null
+++ b/BLAS/SRC/CMakeLists.txt
@@ -0,0 +1,143 @@
+#######################################################################
+# This is the makefile to create a library for the BLAS.
+# The files are grouped as follows:
+#
+# SBLAS1 -- Single precision real BLAS routines
+# CBLAS1 -- Single precision complex BLAS routines
+# DBLAS1 -- Double precision real BLAS routines
+# ZBLAS1 -- Double precision complex BLAS routines
+#
+# CB1AUX -- Real BLAS routines called by complex routines
+# ZB1AUX -- D.P. real BLAS routines called by d.p. complex
+# routines
+#
+# ALLBLAS -- Auxiliary routines for Level 2 and 3 BLAS
+#
+# SBLAS2 -- Single precision real BLAS2 routines
+# CBLAS2 -- Single precision complex BLAS2 routines
+# DBLAS2 -- Double precision real BLAS2 routines
+# ZBLAS2 -- Double precision complex BLAS2 routines
+#
+# SBLAS3 -- Single precision real BLAS3 routines
+# CBLAS3 -- Single precision complex BLAS3 routines
+# DBLAS3 -- Double precision real BLAS3 routines
+# ZBLAS3 -- Double precision complex BLAS3 routines
+#
+# The library can be set up to include routines for any combination
+# of the four precisions. To create or add to the library, enter make
+# followed by one or more of the precisions desired. Some examples:
+# make single
+# make single complex
+# make single double complex complex16
+# Note that these commands are not safe for parallel builds.
+#
+# Alternatively, the commands
+# make all
+# or
+# make
+# without any arguments creates a library of all four precisions.
+# The name of the library is held in BLASLIB, which is set in the
+# top-level make.inc
+#
+# To remove the object files after the library is created, enter
+# make clean
+# To force the source files to be recompiled, enter, for example,
+# make single FRC=FRC
+#
+#---------------------------------------------------------------------
+#
+# Edward Anderson, University of Tennessee
+# March 26, 1990
+# Susan Ostrouchov, Last updated September 30, 1994
+# ejr, May 2006.
+#
+#######################################################################
+
+#---------------------------------------------------------
+# Comment out the next 6 definitions if you already have
+# the Level 1 BLAS.
+#---------------------------------------------------------
+set(SBLAS1 isamax.c sasum.c saxpy.c scopy.c sdot.c snrm2.c
+ srot.c srotg.c sscal.c sswap.c sdsdot.c srotmg.c srotm.c)
+
+set(CBLAS1 scabs1.c scasum.c scnrm2.c icamax.c caxpy.c ccopy.c
+ cdotc.c cdotu.c csscal.c crotg.c cscal.c cswap.c csrot.c)
+
+set(DBLAS1 idamax.c dasum.c daxpy.c dcopy.c ddot.c dnrm2.c
+ drot.c drotg.c dscal.c dsdot.c dswap.c drotmg.c drotm.c)
+
+set(ZBLAS1 dcabs1.c dzasum.c dznrm2.c izamax.c zaxpy.c zcopy.c
+ zdotc.c zdotu.c zdscal.c zrotg.c zscal.c zswap.c zdrot.c)
+
+set(CB1AUX isamax.c sasum.c saxpy.c scopy.c snrm2.c sscal.c)
+
+set(ZB1AUX idamax.c dasum.c daxpy.c dcopy.c dnrm2.c dscal.c)
+
+#---------------------------------------------------------------------
+# The following line defines auxiliary routines needed by both the
+# Level 2 and Level 3 BLAS. Comment it out only if you already have
+# both the Level 2 and 3 BLAS.
+#---------------------------------------------------------------------
+set(ALLBLAS lsame.c xerbla.c xerbla_array.c)
+
+#---------------------------------------------------------
+# Comment out the next 4 definitions if you already have
+# the Level 2 BLAS.
+#---------------------------------------------------------
+set(SBLAS2 sgemv.c sgbmv.c ssymv.c ssbmv.c sspmv.c
+ strmv.c stbmv.c stpmv.c strsv.c stbsv.c stpsv.c
+ sger.c ssyr.c sspr.c ssyr2.c sspr2.c)
+
+set(CBLAS2 cgemv.c cgbmv.c chemv.c chbmv.c chpmv.c
+ ctrmv.c ctbmv.c ctpmv.c ctrsv.c ctbsv.c ctpsv.c
+ cgerc.c cgeru.c cher.c chpr.c cher2.c chpr2.c)
+
+set(DBLAS2 dgemv.c dgbmv.c dsymv.c dsbmv.c dspmv.c
+ dtrmv.c dtbmv.c dtpmv.c dtrsv.c dtbsv.c dtpsv.c
+ dger.c dsyr.c dspr.c dsyr2.c dspr2.c)
+
+set(ZBLAS2 zgemv.c zgbmv.c zhemv.c zhbmv.c zhpmv.c
+ ztrmv.c ztbmv.c ztpmv.c ztrsv.c ztbsv.c ztpsv.c
+ zgerc.c zgeru.c zher.c zhpr.c zher2.c zhpr2.c)
+
+#---------------------------------------------------------
+# Comment out the next 4 definitions if you already have
+# the Level 3 BLAS.
+#---------------------------------------------------------
+set(SBLAS3 sgemm.c ssymm.c ssyrk.c ssyr2k.c strmm.c strsm.c )
+
+set(CBLAS3 cgemm.c csymm.c csyrk.c csyr2k.c ctrmm.c ctrsm.c
+ chemm.c cherk.c cher2k.c)
+
+set(DBLAS3 dgemm.c dsymm.c dsyrk.c dsyr2k.c dtrmm.c dtrsm.c)
+
+set(ZBLAS3 zgemm.c zsymm.c zsyrk.c zsyr2k.c ztrmm.c ztrsm.c
+ zhemm.c zherk.c zher2k.c)
+# default build all of it
+set(ALLOBJ ${SBLAS1} ${SBLAS2} ${SBLAS3} ${DBLAS1} ${DBLAS2} ${DBLAS3}
+ ${CBLAS1} ${CBLAS2} ${CBLAS3} ${ZBLAS1}
+ ${ZBLAS2} ${ZBLAS3} ${ALLBLAS})
+
+if(BLAS_SINGLE)
+ set(ALLOBJ ${SBLAS1} ${ALLBLAS}
+ ${SBLAS2} ${SBLAS3})
+endif()
+if(BLAS_DOUBLE)
+ set(ALLOBJ ${DBLAS1} ${ALLBLAS}
+ ${DBLAS2} ${DBLAS3})
+endif()
+if(BLAS_COMPLEX)
+ set(ALLOBJ ${BLASLIB} ${CBLAS1} ${CB1AUX}
+ ${ALLBLAS} ${CBLAS2})
+endif()
+if(BLAS_COMPLEX16)
+ set(ALLOBJ ${BLASLIB} ${ZBLAS1} ${ZB1AUX}
+ ${ALLBLAS} ${ZBLAS2} ${ZBLAS3})
+endif()
+
+
+add_library(blas ${ALLOBJ})
+if(UNIX)
+ target_link_libraries(blas m)
+endif()
+target_link_libraries(blas f2c)
diff --git a/BLAS/SRC/Makefile b/BLAS/SRC/Makefile
new file mode 100644
index 0000000..75836eb
--- /dev/null
+++ b/BLAS/SRC/Makefile
@@ -0,0 +1,171 @@
+include ../../make.inc
+
+#######################################################################
+# This is the makefile to create a library for the BLAS.
+# The files are grouped as follows:
+#
+# SBLAS1 -- Single precision real BLAS routines
+# CBLAS1 -- Single precision complex BLAS routines
+# DBLAS1 -- Double precision real BLAS routines
+# ZBLAS1 -- Double precision complex BLAS routines
+#
+# CB1AUX -- Real BLAS routines called by complex routines
+# ZB1AUX -- D.P. real BLAS routines called by d.p. complex
+# routines
+#
+# ALLBLAS -- Auxiliary routines for Level 2 and 3 BLAS
+#
+# SBLAS2 -- Single precision real BLAS2 routines
+# CBLAS2 -- Single precision complex BLAS2 routines
+# DBLAS2 -- Double precision real BLAS2 routines
+# ZBLAS2 -- Double precision complex BLAS2 routines
+#
+# SBLAS3 -- Single precision real BLAS3 routines
+# CBLAS3 -- Single precision complex BLAS3 routines
+# DBLAS3 -- Double precision real BLAS3 routines
+# ZBLAS3 -- Double precision complex BLAS3 routines
+#
+# The library can be set up to include routines for any combination
+# of the four precisions. To create or add to the library, enter make
+# followed by one or more of the precisions desired. Some examples:
+# make single
+# make single complex
+# make single double complex complex16
+# Note that these commands are not safe for parallel builds.
+#
+# Alternatively, the commands
+# make all
+# or
+# make
+# without any arguments creates a library of all four precisions.
+# The name of the library is held in BLASLIB, which is set in the
+# top-level make.inc
+#
+# To remove the object files after the library is created, enter
+# make clean
+# To force the source files to be recompiled, enter, for example,
+# make single FRC=FRC
+#
+#---------------------------------------------------------------------
+#
+# Edward Anderson, University of Tennessee
+# March 26, 1990
+# Susan Ostrouchov, Last updated September 30, 1994
+# ejr, May 2006.
+#
+#######################################################################
+
+all: $(BLASLIB)
+
+#---------------------------------------------------------
+# Comment out the next 6 definitions if you already have
+# the Level 1 BLAS.
+#---------------------------------------------------------
+SBLAS1 = isamax.o sasum.o saxpy.o scopy.o sdot.o snrm2.o \
+ srot.o srotg.o sscal.o sswap.o sdsdot.o srotmg.o srotm.o
+$(SBLAS1): $(FRC)
+
+CBLAS1 = scabs1.o scasum.o scnrm2.o icamax.o caxpy.o ccopy.o \
+ cdotc.o cdotu.o csscal.o crotg.o cscal.o cswap.o csrot.o
+$(CBLAS1): $(FRC)
+
+DBLAS1 = idamax.o dasum.o daxpy.o dcopy.o ddot.o dnrm2.o \
+ drot.o drotg.o dscal.o dsdot.o dswap.o drotmg.o drotm.o
+$(DBLAS1): $(FRC)
+
+ZBLAS1 = dcabs1.o dzasum.o dznrm2.o izamax.o zaxpy.o zcopy.o \
+ zdotc.o zdotu.o zdscal.o zrotg.o zscal.o zswap.o zdrot.o
+$(ZBLAS1): $(FRC)
+
+CB1AUX = isamax.o sasum.o saxpy.o scopy.o snrm2.o sscal.o
+$(CB1AUX): $(FRC)
+
+ZB1AUX = idamax.o dasum.o daxpy.o dcopy.o dnrm2.o dscal.o
+$(ZB1AUX): $(FRC)
+
+#---------------------------------------------------------------------
+# The following line defines auxiliary routines needed by both the
+# Level 2 and Level 3 BLAS. Comment it out only if you already have
+# both the Level 2 and 3 BLAS.
+#---------------------------------------------------------------------
+ALLBLAS = lsame.o xerbla.o xerbla_array.o
+$(ALLBLAS) : $(FRC)
+
+#---------------------------------------------------------
+# Comment out the next 4 definitions if you already have
+# the Level 2 BLAS.
+#---------------------------------------------------------
+SBLAS2 = sgemv.o sgbmv.o ssymv.o ssbmv.o sspmv.o \
+ strmv.o stbmv.o stpmv.o strsv.o stbsv.o stpsv.o \
+ sger.o ssyr.o sspr.o ssyr2.o sspr2.o
+$(SBLAS2): $(FRC)
+
+CBLAS2 = cgemv.o cgbmv.o chemv.o chbmv.o chpmv.o \
+ ctrmv.o ctbmv.o ctpmv.o ctrsv.o ctbsv.o ctpsv.o \
+ cgerc.o cgeru.o cher.o chpr.o cher2.o chpr2.o
+$(CBLAS2): $(FRC)
+
+DBLAS2 = dgemv.o dgbmv.o dsymv.o dsbmv.o dspmv.o \
+ dtrmv.o dtbmv.o dtpmv.o dtrsv.o dtbsv.o dtpsv.o \
+ dger.o dsyr.o dspr.o dsyr2.o dspr2.o
+$(DBLAS2): $(FRC)
+
+ZBLAS2 = zgemv.o zgbmv.o zhemv.o zhbmv.o zhpmv.o \
+ ztrmv.o ztbmv.o ztpmv.o ztrsv.o ztbsv.o ztpsv.o \
+ zgerc.o zgeru.o zher.o zhpr.o zher2.o zhpr2.o
+$(ZBLAS2): $(FRC)
+
+#---------------------------------------------------------
+# Comment out the next 4 definitions if you already have
+# the Level 3 BLAS.
+#---------------------------------------------------------
+SBLAS3 = sgemm.o ssymm.o ssyrk.o ssyr2k.o strmm.o strsm.o
+$(SBLAS3): $(FRC)
+
+CBLAS3 = cgemm.o csymm.o csyrk.o csyr2k.o ctrmm.o ctrsm.o \
+ chemm.o cherk.o cher2k.o
+$(CBLAS3): $(FRC)
+
+DBLAS3 = dgemm.o dsymm.o dsyrk.o dsyr2k.o dtrmm.o dtrsm.o
+$(DBLAS3): $(FRC)
+
+ZBLAS3 = zgemm.o zsymm.o zsyrk.o zsyr2k.o ztrmm.o ztrsm.o \
+ zhemm.o zherk.o zher2k.o
+$(ZBLAS3): $(FRC)
+
+ALLOBJ=$(SBLAS1) $(SBLAS2) $(SBLAS3) $(DBLAS1) $(DBLAS2) $(DBLAS3) \
+ $(CBLAS1) $(CBLAS2) $(CBLAS3) $(ZBLAS1) \
+ $(ZBLAS2) $(ZBLAS3) $(ALLBLAS)
+
+$(BLASLIB): $(ALLOBJ)
+ $(ARCH) $(ARCHFLAGS) $@ $(ALLOBJ)
+ $(RANLIB) $@
+
+single: $(SBLAS1) $(ALLBLAS) $(SBLAS2) $(SBLAS3)
+ $(ARCH) $(ARCHFLAGS) $(BLASLIB) $(SBLAS1) $(ALLBLAS) \
+ $(SBLAS2) $(SBLAS3)
+ $(RANLIB) $(BLASLIB)
+
+double: $(DBLAS1) $(ALLBLAS) $(DBLAS2) $(DBLAS3)
+ $(ARCH) $(ARCHFLAGS) $(BLASLIB) $(DBLAS1) $(ALLBLAS) \
+ $(DBLAS2) $(DBLAS3)
+ $(RANLIB) $(BLASLIB)
+
+complex: $(CBLAS1) $(CB1AUX) $(ALLBLAS) $(CBLAS2) $(CBLAS3)
+ $(ARCH) $(ARCHFLAGS) $(BLASLIB) $(CBLAS1) $(CB1AUX) \
+ $(ALLBLAS) $(CBLAS2) $(CBLAS3)
+ $(RANLIB) $(BLASLIB)
+
+complex16: $(ZBLAS1) $(ZB1AUX) $(ALLBLAS) $(ZBLAS2) $(ZBLAS3)
+ $(ARCH) $(ARCHFLAGS) $(BLASLIB) $(ZBLAS1) $(ZB1AUX) \
+ $(ALLBLAS) $(ZBLAS2) $(ZBLAS3)
+ $(RANLIB) $(BLASLIB)
+
+FRC:
+ @FRC=$(FRC)
+
+clean:
+ rm -f *.o
+
+.c.o:
+ $(CC) $(CFLAGS) -I../../INCLUDE -c $< -o $@
diff --git a/BLAS/SRC/caxpy.c b/BLAS/SRC/caxpy.c
new file mode 100644
index 0000000..fe01b4e
--- /dev/null
+++ b/BLAS/SRC/caxpy.c
@@ -0,0 +1,103 @@
+/* caxpy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int caxpy_(integer *n, complex *ca, complex *cx, integer *
+ incx, complex *cy, integer *incy)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ complex q__1, q__2;
+
+ /* Local variables */
+ integer i__, ix, iy;
+ extern doublereal scabs1_(complex *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CAXPY constant times a vector plus a vector. */
+
+/* Further Details */
+/* =============== */
+
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --cy;
+ --cx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ if (scabs1_(ca) == 0.f) {
+ return 0;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* code for unequal increments or equal increments */
+/* not equal to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ i__3 = iy;
+ i__4 = ix;
+ q__2.r = ca->r * cx[i__4].r - ca->i * cx[i__4].i, q__2.i = ca->r * cx[
+ i__4].i + ca->i * cx[i__4].r;
+ q__1.r = cy[i__3].r + q__2.r, q__1.i = cy[i__3].i + q__2.i;
+ cy[i__2].r = q__1.r, cy[i__2].i = q__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ return 0;
+
+/* code for both increments equal to 1 */
+
+L20:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__2.r = ca->r * cx[i__4].r - ca->i * cx[i__4].i, q__2.i = ca->r * cx[
+ i__4].i + ca->i * cx[i__4].r;
+ q__1.r = cy[i__3].r + q__2.r, q__1.i = cy[i__3].i + q__2.i;
+ cy[i__2].r = q__1.r, cy[i__2].i = q__1.i;
+/* L30: */
+ }
+ return 0;
+} /* caxpy_ */
diff --git a/BLAS/SRC/ccopy.c b/BLAS/SRC/ccopy.c
new file mode 100644
index 0000000..32e9952
--- /dev/null
+++ b/BLAS/SRC/ccopy.c
@@ -0,0 +1,88 @@
+/* ccopy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ccopy_(integer *n, complex *cx, integer *incx, complex *
+ cy, integer *incy)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, ix, iy;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCOPY copies a vector x to a vector y. */
+
+/* Further Details */
+/* =============== */
+
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+/* .. Local Scalars .. */
+/* .. */
+ /* Parameter adjustments */
+ --cy;
+ --cx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* code for unequal increments or equal increments */
+/* not equal to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ i__3 = ix;
+ cy[i__2].r = cx[i__3].r, cy[i__2].i = cx[i__3].i;
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ return 0;
+
+/* code for both increments equal to 1 */
+
+L20:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ cy[i__2].r = cx[i__3].r, cy[i__2].i = cx[i__3].i;
+/* L30: */
+ }
+ return 0;
+} /* ccopy_ */
diff --git a/BLAS/SRC/cdotc.c b/BLAS/SRC/cdotc.c
new file mode 100644
index 0000000..a471573
--- /dev/null
+++ b/BLAS/SRC/cdotc.c
@@ -0,0 +1,106 @@
+/* cdotc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Complex */ VOID cdotc_(complex * ret_val, integer *n, complex *cx, integer
+ *incx, complex *cy, integer *incy)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, ix, iy;
+ complex ctemp;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* forms the dot product of two vectors, conjugating the first */
+/* vector. */
+
+/* Further Details */
+/* =============== */
+
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --cy;
+ --cx;
+
+ /* Function Body */
+ ctemp.r = 0.f, ctemp.i = 0.f;
+ ret_val->r = 0.f, ret_val->i = 0.f;
+ if (*n <= 0) {
+ return ;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* code for unequal increments or equal increments */
+/* not equal to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r_cnjg(&q__3, &cx[ix]);
+ i__2 = iy;
+ q__2.r = q__3.r * cy[i__2].r - q__3.i * cy[i__2].i, q__2.i = q__3.r *
+ cy[i__2].i + q__3.i * cy[i__2].r;
+ q__1.r = ctemp.r + q__2.r, q__1.i = ctemp.i + q__2.i;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ ret_val->r = ctemp.r, ret_val->i = ctemp.i;
+ return ;
+
+/* code for both increments equal to 1 */
+
+L20:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r_cnjg(&q__3, &cx[i__]);
+ i__2 = i__;
+ q__2.r = q__3.r * cy[i__2].r - q__3.i * cy[i__2].i, q__2.i = q__3.r *
+ cy[i__2].i + q__3.i * cy[i__2].r;
+ q__1.r = ctemp.r + q__2.r, q__1.i = ctemp.i + q__2.i;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+/* L30: */
+ }
+ ret_val->r = ctemp.r, ret_val->i = ctemp.i;
+ return ;
+} /* cdotc_ */
diff --git a/BLAS/SRC/cdotu.c b/BLAS/SRC/cdotu.c
new file mode 100644
index 0000000..3aa48a2
--- /dev/null
+++ b/BLAS/SRC/cdotu.c
@@ -0,0 +1,100 @@
+/* cdotu.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Complex */ VOID cdotu_(complex * ret_val, integer *n, complex *cx, integer
+ *incx, complex *cy, integer *incy)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ complex q__1, q__2;
+
+ /* Local variables */
+ integer i__, ix, iy;
+ complex ctemp;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDOTU forms the dot product of two vectors. */
+
+/* Further Details */
+/* =============== */
+
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+/* .. Local Scalars .. */
+/* .. */
+ /* Parameter adjustments */
+ --cy;
+ --cx;
+
+ /* Function Body */
+ ctemp.r = 0.f, ctemp.i = 0.f;
+ ret_val->r = 0.f, ret_val->i = 0.f;
+ if (*n <= 0) {
+ return ;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* code for unequal increments or equal increments */
+/* not equal to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ix;
+ i__3 = iy;
+ q__2.r = cx[i__2].r * cy[i__3].r - cx[i__2].i * cy[i__3].i, q__2.i =
+ cx[i__2].r * cy[i__3].i + cx[i__2].i * cy[i__3].r;
+ q__1.r = ctemp.r + q__2.r, q__1.i = ctemp.i + q__2.i;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ ret_val->r = ctemp.r, ret_val->i = ctemp.i;
+ return ;
+
+/* code for both increments equal to 1 */
+
+L20:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ q__2.r = cx[i__2].r * cy[i__3].r - cx[i__2].i * cy[i__3].i, q__2.i =
+ cx[i__2].r * cy[i__3].i + cx[i__2].i * cy[i__3].r;
+ q__1.r = ctemp.r + q__2.r, q__1.i = ctemp.i + q__2.i;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+/* L30: */
+ }
+ ret_val->r = ctemp.r, ret_val->i = ctemp.i;
+ return ;
+} /* cdotu_ */
diff --git a/BLAS/SRC/cgbmv.c b/BLAS/SRC/cgbmv.c
new file mode 100644
index 0000000..ec04382
--- /dev/null
+++ b/BLAS/SRC/cgbmv.c
@@ -0,0 +1,477 @@
+/* cgbmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cgbmv_(char *trans, integer *m, integer *n, integer *kl,
+ integer *ku, complex *alpha, complex *a, integer *lda, complex *x,
+ integer *incx, complex *beta, complex *y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k, ix, iy, jx, jy, kx, ky, kup1, info;
+ complex temp;
+ integer lenx, leny;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical noconj;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGBMV performs one of the matrix-vector operations */
+
+/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or */
+
+/* y := alpha*conjg( A' )*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are vectors and A is an */
+/* m by n band matrix, with kl sub-diagonals and ku super-diagonals. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */
+
+/* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. */
+
+/* TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix A. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* KL - INTEGER. */
+/* On entry, KL specifies the number of sub-diagonals of the */
+/* matrix A. KL must satisfy 0 .le. KL. */
+/* Unchanged on exit. */
+
+/* KU - INTEGER. */
+/* On entry, KU specifies the number of super-diagonals of the */
+/* matrix A. KU must satisfy 0 .le. KU. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, n ). */
+/* Before entry, the leading ( kl + ku + 1 ) by n part of the */
+/* array A must contain the matrix of coefficients, supplied */
+/* column by column, with the leading diagonal of the matrix in */
+/* row ( ku + 1 ) of the array, the first super-diagonal */
+/* starting at position 2 in row ku, the first sub-diagonal */
+/* starting at position 1 in row ( ku + 2 ), and so on. */
+/* Elements in the array A that do not correspond to elements */
+/* in the band matrix (such as the top left ku by ku triangle) */
+/* are not referenced. */
+/* The following program segment will transfer a band matrix */
+/* from conventional full matrix storage to band storage: */
+
+/* DO 20, J = 1, N */
+/* K = KU + 1 - J */
+/* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) */
+/* A( K + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* ( kl + ku + 1 ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - COMPLEX array of DIMENSION at least */
+/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
+/* Before entry, the incremented array Y must contain the */
+/* vector y. On exit, Y is overwritten by the updated vector y. */
+
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C")
+ ) {
+ info = 1;
+ } else if (*m < 0) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*kl < 0) {
+ info = 4;
+ } else if (*ku < 0) {
+ info = 5;
+ } else if (*lda < *kl + *ku + 1) {
+ info = 8;
+ } else if (*incx == 0) {
+ info = 10;
+ } else if (*incy == 0) {
+ info = 13;
+ }
+ if (info != 0) {
+ xerbla_("CGBMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r
+ == 1.f && beta->i == 0.f)) {
+ return 0;
+ }
+
+ noconj = lsame_(trans, "T");
+
+/* Set LENX and LENY, the lengths of the vectors x and y, and set */
+/* up the start points in X and Y. */
+
+ if (lsame_(trans, "N")) {
+ lenx = *n;
+ leny = *m;
+ } else {
+ lenx = *m;
+ leny = *n;
+ }
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (lenx - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (leny - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through the band part of A. */
+
+/* First form y := beta*y. */
+
+ if (beta->r != 1.f || beta->i != 0.f) {
+ if (*incy == 1) {
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ y[i__2].r = 0.f, y[i__2].i = 0.f;
+/* L10: */
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ y[i__2].r = 0.f, y[i__2].i = 0.f;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ i__3 = iy;
+ q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (alpha->r == 0.f && alpha->i == 0.f) {
+ return 0;
+ }
+ kup1 = *ku + 1;
+ if (lsame_(trans, "N")) {
+
+/* Form y := alpha*A*x + y. */
+
+ jx = kx;
+ if (*incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ i__2 = jx;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ k = kup1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__4 = min(i__5,i__6);
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__5 = k + i__ + j * a_dim1;
+ q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ q__2.i = temp.r * a[i__5].i + temp.i * a[i__5]
+ .r;
+ q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i +
+ q__2.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+/* L50: */
+ }
+ }
+ jx += *incx;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = jx;
+ if (x[i__4].r != 0.f || x[i__4].i != 0.f) {
+ i__4 = jx;
+ q__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i,
+ q__1.i = alpha->r * x[i__4].i + alpha->i * x[i__4]
+ .r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ iy = ky;
+ k = kup1 - j;
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__3 = min(i__5,i__6);
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ i__4 = iy;
+ i__2 = iy;
+ i__5 = k + i__ + j * a_dim1;
+ q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ q__2.i = temp.r * a[i__5].i + temp.i * a[i__5]
+ .r;
+ q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i +
+ q__2.i;
+ y[i__4].r = q__1.r, y[i__4].i = q__1.i;
+ iy += *incy;
+/* L70: */
+ }
+ }
+ jx += *incx;
+ if (j > *ku) {
+ ky += *incy;
+ }
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. */
+
+ jy = ky;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp.r = 0.f, temp.i = 0.f;
+ k = kup1 - j;
+ if (noconj) {
+/* Computing MAX */
+ i__3 = 1, i__4 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__2 = min(i__5,i__6);
+ for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) {
+ i__3 = k + i__ + j * a_dim1;
+ i__4 = i__;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4]
+ .i, q__2.i = a[i__3].r * x[i__4].i + a[i__3]
+ .i * x[i__4].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L90: */
+ }
+ } else {
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__4 = min(i__5,i__6);
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ r_cnjg(&q__3, &a[k + i__ + j * a_dim1]);
+ i__2 = i__;
+ q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i,
+ q__2.i = q__3.r * x[i__2].i + q__3.i * x[i__2]
+ .r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L100: */
+ }
+ }
+ i__4 = jy;
+ i__2 = jy;
+ q__2.r = alpha->r * temp.r - alpha->i * temp.i, q__2.i =
+ alpha->r * temp.i + alpha->i * temp.r;
+ q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
+ y[i__4].r = q__1.r, y[i__4].i = q__1.i;
+ jy += *incy;
+/* L110: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp.r = 0.f, temp.i = 0.f;
+ ix = kx;
+ k = kup1 - j;
+ if (noconj) {
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__3 = min(i__5,i__6);
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ i__4 = k + i__ + j * a_dim1;
+ i__2 = ix;
+ q__2.r = a[i__4].r * x[i__2].r - a[i__4].i * x[i__2]
+ .i, q__2.i = a[i__4].r * x[i__2].i + a[i__4]
+ .i * x[i__2].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix += *incx;
+/* L120: */
+ }
+ } else {
+/* Computing MAX */
+ i__3 = 1, i__4 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__2 = min(i__5,i__6);
+ for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) {
+ r_cnjg(&q__3, &a[k + i__ + j * a_dim1]);
+ i__3 = ix;
+ q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
+ q__2.i = q__3.r * x[i__3].i + q__3.i * x[i__3]
+ .r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix += *incx;
+/* L130: */
+ }
+ }
+ i__2 = jy;
+ i__3 = jy;
+ q__2.r = alpha->r * temp.r - alpha->i * temp.i, q__2.i =
+ alpha->r * temp.i + alpha->i * temp.r;
+ q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ jy += *incy;
+ if (j > *ku) {
+ kx += *incx;
+ }
+/* L140: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CGBMV . */
+
+} /* cgbmv_ */
diff --git a/BLAS/SRC/cgemm.c b/BLAS/SRC/cgemm.c
new file mode 100644
index 0000000..7568b5c
--- /dev/null
+++ b/BLAS/SRC/cgemm.c
@@ -0,0 +1,697 @@
+/* cgemm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cgemm_(char *transa, char *transb, integer *m, integer *
+ n, integer *k, complex *alpha, complex *a, integer *lda, complex *b,
+ integer *ldb, complex *beta, complex *c__, integer *ldc)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, l, info;
+ logical nota, notb;
+ complex temp;
+ logical conja, conjb;
+ integer ncola;
+ extern logical lsame_(char *, char *);
+ integer nrowa, nrowb;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGEMM performs one of the matrix-matrix operations */
+
+/* C := alpha*op( A )*op( B ) + beta*C, */
+
+/* where op( X ) is one of */
+
+/* op( X ) = X or op( X ) = X' or op( X ) = conjg( X' ), */
+
+/* alpha and beta are scalars, and A, B and C are matrices, with op( A ) */
+/* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANSA - CHARACTER*1. */
+/* On entry, TRANSA specifies the form of op( A ) to be used in */
+/* the matrix multiplication as follows: */
+
+/* TRANSA = 'N' or 'n', op( A ) = A. */
+
+/* TRANSA = 'T' or 't', op( A ) = A'. */
+
+/* TRANSA = 'C' or 'c', op( A ) = conjg( A' ). */
+
+/* Unchanged on exit. */
+
+/* TRANSB - CHARACTER*1. */
+/* On entry, TRANSB specifies the form of op( B ) to be used in */
+/* the matrix multiplication as follows: */
+
+/* TRANSB = 'N' or 'n', op( B ) = B. */
+
+/* TRANSB = 'T' or 't', op( B ) = B'. */
+
+/* TRANSB = 'C' or 'c', op( B ) = conjg( B' ). */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix */
+/* op( A ) and of the matrix C. M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix */
+/* op( B ) and the number of columns of the matrix C. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry, K specifies the number of columns of the matrix */
+/* op( A ) and the number of rows of the matrix op( B ). K must */
+/* be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is */
+/* k when TRANSA = 'N' or 'n', and is m otherwise. */
+/* Before entry with TRANSA = 'N' or 'n', the leading m by k */
+/* part of the array A must contain the matrix A, otherwise */
+/* the leading k by m part of the array A must contain the */
+/* matrix A. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When TRANSA = 'N' or 'n' then */
+/* LDA must be at least max( 1, m ), otherwise LDA must be at */
+/* least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is */
+/* n when TRANSB = 'N' or 'n', and is k otherwise. */
+/* Before entry with TRANSB = 'N' or 'n', the leading k by n */
+/* part of the array B must contain the matrix B, otherwise */
+/* the leading n by k part of the array B must contain the */
+/* matrix B. */
+/* Unchanged on exit. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. When TRANSB = 'N' or 'n' then */
+/* LDB must be at least max( 1, k ), otherwise LDB must be at */
+/* least max( 1, n ). */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then C need not be set on input. */
+/* Unchanged on exit. */
+
+/* C - COMPLEX array of DIMENSION ( LDC, n ). */
+/* Before entry, the leading m by n part of the array C must */
+/* contain the matrix C, except when beta is zero, in which */
+/* case C need not be set on entry. */
+/* On exit, the array C is overwritten by the m by n matrix */
+/* ( alpha*op( A )*op( B ) + beta*C ). */
+
+/* LDC - INTEGER. */
+/* On entry, LDC specifies the first dimension of C as declared */
+/* in the calling (sub) program. LDC must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Set NOTA and NOTB as true if A and B respectively are not */
+/* conjugated or transposed, set CONJA and CONJB as true if A and */
+/* B respectively are to be transposed but not conjugated and set */
+/* NROWA, NCOLA and NROWB as the number of rows and columns of A */
+/* and the number of rows of B respectively. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ nota = lsame_(transa, "N");
+ notb = lsame_(transb, "N");
+ conja = lsame_(transa, "C");
+ conjb = lsame_(transb, "C");
+ if (nota) {
+ nrowa = *m;
+ ncola = *k;
+ } else {
+ nrowa = *k;
+ ncola = *m;
+ }
+ if (notb) {
+ nrowb = *k;
+ } else {
+ nrowb = *n;
+ }
+
+/* Test the input parameters. */
+
+ info = 0;
+ if (! nota && ! conja && ! lsame_(transa, "T")) {
+ info = 1;
+ } else if (! notb && ! conjb && ! lsame_(transb, "T")) {
+ info = 2;
+ } else if (*m < 0) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*k < 0) {
+ info = 5;
+ } else if (*lda < max(1,nrowa)) {
+ info = 8;
+ } else if (*ldb < max(1,nrowb)) {
+ info = 10;
+ } else if (*ldc < max(1,*m)) {
+ info = 13;
+ }
+ if (info != 0) {
+ xerbla_("CGEMM ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || (alpha->r == 0.f && alpha->i == 0.f || *k == 0)
+ && (beta->r == 1.f && beta->i == 0.f)) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (alpha->r == 0.f && alpha->i == 0.f) {
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0.f, c__[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
+ q__1.i = beta->r * c__[i__4].i + beta->i * c__[
+ i__4].r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (notb) {
+ if (nota) {
+
+/* Form C := alpha*A*B + beta*C. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0.f, c__[i__3].i = 0.f;
+/* L50: */
+ }
+ } else if (beta->r != 1.f || beta->i != 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, q__1.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L60: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = l + j * b_dim1;
+ if (b[i__3].r != 0.f || b[i__3].i != 0.f) {
+ i__3 = l + j * b_dim1;
+ q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
+ q__1.i = alpha->r * b[i__3].i + alpha->i * b[
+ i__3].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + l * a_dim1;
+ q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
+ q__2.i = temp.r * a[i__6].i + temp.i * a[
+ i__6].r;
+ q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5]
+ .i + q__2.i;
+ c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
+/* L70: */
+ }
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+ } else if (conja) {
+
+/* Form C := alpha*conjg( A' )*B + beta*C. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp.r = 0.f, temp.i = 0.f;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ r_cnjg(&q__3, &a[l + i__ * a_dim1]);
+ i__4 = l + j * b_dim1;
+ q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4].i,
+ q__2.i = q__3.r * b[i__4].i + q__3.i * b[i__4]
+ .r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L100: */
+ }
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__3 = i__ + j * c_dim1;
+ q__1.r = alpha->r * temp.r - alpha->i * temp.i,
+ q__1.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ q__2.r = alpha->r * temp.r - alpha->i * temp.i,
+ q__2.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ i__4 = i__ + j * c_dim1;
+ q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, q__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+ } else {
+
+/* Form C := alpha*A'*B + beta*C */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp.r = 0.f, temp.i = 0.f;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ i__4 = l + i__ * a_dim1;
+ i__5 = l + j * b_dim1;
+ q__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5]
+ .i, q__2.i = a[i__4].r * b[i__5].i + a[i__4]
+ .i * b[i__5].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L130: */
+ }
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__3 = i__ + j * c_dim1;
+ q__1.r = alpha->r * temp.r - alpha->i * temp.i,
+ q__1.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ q__2.r = alpha->r * temp.r - alpha->i * temp.i,
+ q__2.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ i__4 = i__ + j * c_dim1;
+ q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, q__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+ }
+ } else if (nota) {
+ if (conjb) {
+
+/* Form C := alpha*A*conjg( B' ) + beta*C. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0.f, c__[i__3].i = 0.f;
+/* L160: */
+ }
+ } else if (beta->r != 1.f || beta->i != 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, q__1.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L170: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = j + l * b_dim1;
+ if (b[i__3].r != 0.f || b[i__3].i != 0.f) {
+ r_cnjg(&q__2, &b[j + l * b_dim1]);
+ q__1.r = alpha->r * q__2.r - alpha->i * q__2.i,
+ q__1.i = alpha->r * q__2.i + alpha->i *
+ q__2.r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + l * a_dim1;
+ q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
+ q__2.i = temp.r * a[i__6].i + temp.i * a[
+ i__6].r;
+ q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5]
+ .i + q__2.i;
+ c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
+/* L180: */
+ }
+ }
+/* L190: */
+ }
+/* L200: */
+ }
+ } else {
+
+/* Form C := alpha*A*B' + beta*C */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0.f, c__[i__3].i = 0.f;
+/* L210: */
+ }
+ } else if (beta->r != 1.f || beta->i != 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, q__1.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L220: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = j + l * b_dim1;
+ if (b[i__3].r != 0.f || b[i__3].i != 0.f) {
+ i__3 = j + l * b_dim1;
+ q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
+ q__1.i = alpha->r * b[i__3].i + alpha->i * b[
+ i__3].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + l * a_dim1;
+ q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
+ q__2.i = temp.r * a[i__6].i + temp.i * a[
+ i__6].r;
+ q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5]
+ .i + q__2.i;
+ c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
+/* L230: */
+ }
+ }
+/* L240: */
+ }
+/* L250: */
+ }
+ }
+ } else if (conja) {
+ if (conjb) {
+
+/* Form C := alpha*conjg( A' )*conjg( B' ) + beta*C. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp.r = 0.f, temp.i = 0.f;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ r_cnjg(&q__3, &a[l + i__ * a_dim1]);
+ r_cnjg(&q__4, &b[j + l * b_dim1]);
+ q__2.r = q__3.r * q__4.r - q__3.i * q__4.i, q__2.i =
+ q__3.r * q__4.i + q__3.i * q__4.r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L260: */
+ }
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__3 = i__ + j * c_dim1;
+ q__1.r = alpha->r * temp.r - alpha->i * temp.i,
+ q__1.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ q__2.r = alpha->r * temp.r - alpha->i * temp.i,
+ q__2.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ i__4 = i__ + j * c_dim1;
+ q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, q__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ }
+/* L270: */
+ }
+/* L280: */
+ }
+ } else {
+
+/* Form C := alpha*conjg( A' )*B' + beta*C */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp.r = 0.f, temp.i = 0.f;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ r_cnjg(&q__3, &a[l + i__ * a_dim1]);
+ i__4 = j + l * b_dim1;
+ q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4].i,
+ q__2.i = q__3.r * b[i__4].i + q__3.i * b[i__4]
+ .r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L290: */
+ }
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__3 = i__ + j * c_dim1;
+ q__1.r = alpha->r * temp.r - alpha->i * temp.i,
+ q__1.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ q__2.r = alpha->r * temp.r - alpha->i * temp.i,
+ q__2.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ i__4 = i__ + j * c_dim1;
+ q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, q__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ }
+/* L300: */
+ }
+/* L310: */
+ }
+ }
+ } else {
+ if (conjb) {
+
+/* Form C := alpha*A'*conjg( B' ) + beta*C */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp.r = 0.f, temp.i = 0.f;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ i__4 = l + i__ * a_dim1;
+ r_cnjg(&q__3, &b[j + l * b_dim1]);
+ q__2.r = a[i__4].r * q__3.r - a[i__4].i * q__3.i,
+ q__2.i = a[i__4].r * q__3.i + a[i__4].i *
+ q__3.r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L320: */
+ }
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__3 = i__ + j * c_dim1;
+ q__1.r = alpha->r * temp.r - alpha->i * temp.i,
+ q__1.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ q__2.r = alpha->r * temp.r - alpha->i * temp.i,
+ q__2.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ i__4 = i__ + j * c_dim1;
+ q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, q__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ }
+/* L330: */
+ }
+/* L340: */
+ }
+ } else {
+
+/* Form C := alpha*A'*B' + beta*C */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp.r = 0.f, temp.i = 0.f;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ i__4 = l + i__ * a_dim1;
+ i__5 = j + l * b_dim1;
+ q__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5]
+ .i, q__2.i = a[i__4].r * b[i__5].i + a[i__4]
+ .i * b[i__5].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L350: */
+ }
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__3 = i__ + j * c_dim1;
+ q__1.r = alpha->r * temp.r - alpha->i * temp.i,
+ q__1.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ q__2.r = alpha->r * temp.r - alpha->i * temp.i,
+ q__2.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ i__4 = i__ + j * c_dim1;
+ q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, q__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ }
+/* L360: */
+ }
+/* L370: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CGEMM . */
+
+} /* cgemm_ */
diff --git a/BLAS/SRC/cgemv.c b/BLAS/SRC/cgemv.c
new file mode 100644
index 0000000..bca5798
--- /dev/null
+++ b/BLAS/SRC/cgemv.c
@@ -0,0 +1,411 @@
+/* cgemv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cgemv_(char *trans, integer *m, integer *n, complex *
+ alpha, complex *a, integer *lda, complex *x, integer *incx, complex *
+ beta, complex *y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, ix, iy, jx, jy, kx, ky, info;
+ complex temp;
+ integer lenx, leny;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical noconj;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGEMV performs one of the matrix-vector operations */
+
+/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or */
+
+/* y := alpha*conjg( A' )*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are vectors and A is an */
+/* m by n matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */
+
+/* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. */
+
+/* TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix A. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, n ). */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - COMPLEX array of DIMENSION at least */
+/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
+/* Before entry with BETA non-zero, the incremented array Y */
+/* must contain the vector y. On exit, Y is overwritten by the */
+/* updated vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C")
+ ) {
+ info = 1;
+ } else if (*m < 0) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*lda < max(1,*m)) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ } else if (*incy == 0) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("CGEMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r
+ == 1.f && beta->i == 0.f)) {
+ return 0;
+ }
+
+ noconj = lsame_(trans, "T");
+
+/* Set LENX and LENY, the lengths of the vectors x and y, and set */
+/* up the start points in X and Y. */
+
+ if (lsame_(trans, "N")) {
+ lenx = *n;
+ leny = *m;
+ } else {
+ lenx = *m;
+ leny = *n;
+ }
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (lenx - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (leny - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through A. */
+
+/* First form y := beta*y. */
+
+ if (beta->r != 1.f || beta->i != 0.f) {
+ if (*incy == 1) {
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ y[i__2].r = 0.f, y[i__2].i = 0.f;
+/* L10: */
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ y[i__2].r = 0.f, y[i__2].i = 0.f;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ i__3 = iy;
+ q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (alpha->r == 0.f && alpha->i == 0.f) {
+ return 0;
+ }
+ if (lsame_(trans, "N")) {
+
+/* Form y := alpha*A*x + y. */
+
+ jx = kx;
+ if (*incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ i__2 = jx;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ q__2.i = temp.r * a[i__5].i + temp.i * a[i__5]
+ .r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i +
+ q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+/* L50: */
+ }
+ }
+ jx += *incx;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ i__2 = jx;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ iy = ky;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = iy;
+ i__4 = iy;
+ i__5 = i__ + j * a_dim1;
+ q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ q__2.i = temp.r * a[i__5].i + temp.i * a[i__5]
+ .r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i +
+ q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ iy += *incy;
+/* L70: */
+ }
+ }
+ jx += *incx;
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. */
+
+ jy = ky;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp.r = 0.f, temp.i = 0.f;
+ if (noconj) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4]
+ .i, q__2.i = a[i__3].r * x[i__4].i + a[i__3]
+ .i * x[i__4].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L90: */
+ }
+ } else {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ r_cnjg(&q__3, &a[i__ + j * a_dim1]);
+ i__3 = i__;
+ q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
+ q__2.i = q__3.r * x[i__3].i + q__3.i * x[i__3]
+ .r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L100: */
+ }
+ }
+ i__2 = jy;
+ i__3 = jy;
+ q__2.r = alpha->r * temp.r - alpha->i * temp.i, q__2.i =
+ alpha->r * temp.i + alpha->i * temp.r;
+ q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ jy += *incy;
+/* L110: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp.r = 0.f, temp.i = 0.f;
+ ix = kx;
+ if (noconj) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = ix;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4]
+ .i, q__2.i = a[i__3].r * x[i__4].i + a[i__3]
+ .i * x[i__4].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix += *incx;
+/* L120: */
+ }
+ } else {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ r_cnjg(&q__3, &a[i__ + j * a_dim1]);
+ i__3 = ix;
+ q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
+ q__2.i = q__3.r * x[i__3].i + q__3.i * x[i__3]
+ .r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix += *incx;
+/* L130: */
+ }
+ }
+ i__2 = jy;
+ i__3 = jy;
+ q__2.r = alpha->r * temp.r - alpha->i * temp.i, q__2.i =
+ alpha->r * temp.i + alpha->i * temp.r;
+ q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ jy += *incy;
+/* L140: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CGEMV . */
+
+} /* cgemv_ */
diff --git a/BLAS/SRC/cgerc.c b/BLAS/SRC/cgerc.c
new file mode 100644
index 0000000..378b9a7
--- /dev/null
+++ b/BLAS/SRC/cgerc.c
@@ -0,0 +1,217 @@
+/* cgerc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cgerc_(integer *m, integer *n, complex *alpha, complex *
+ x, integer *incx, complex *y, integer *incy, complex *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, ix, jy, kx, info;
+ complex temp;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGERC performs the rank 1 operation */
+
+/* A := alpha*x*conjg( y' ) + A, */
+
+/* where alpha is a scalar, x is an m element vector, y is an n element */
+/* vector and A is an m by n matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix A. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X - COMPLEX array of dimension at least */
+/* ( 1 + ( m - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the m */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* Y - COMPLEX array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. */
+/* Unchanged on exit. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, n ). */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. On exit, A is */
+/* overwritten by the updated matrix. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ --y;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ info = 0;
+ if (*m < 0) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ } else if (*incy == 0) {
+ info = 7;
+ } else if (*lda < max(1,*m)) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("CGERC ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || alpha->r == 0.f && alpha->i == 0.f) {
+ return 0;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through A. */
+
+ if (*incy > 0) {
+ jy = 1;
+ } else {
+ jy = 1 - (*n - 1) * *incy;
+ }
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jy;
+ if (y[i__2].r != 0.f || y[i__2].i != 0.f) {
+ r_cnjg(&q__2, &y[jy]);
+ q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
+ alpha->r * q__2.i + alpha->i * q__2.r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__;
+ q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, q__2.i =
+ x[i__5].r * temp.i + x[i__5].i * temp.r;
+ q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i + q__2.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L10: */
+ }
+ }
+ jy += *incy;
+/* L20: */
+ }
+ } else {
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*m - 1) * *incx;
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jy;
+ if (y[i__2].r != 0.f || y[i__2].i != 0.f) {
+ r_cnjg(&q__2, &y[jy]);
+ q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
+ alpha->r * q__2.i + alpha->i * q__2.r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix = kx;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = ix;
+ q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, q__2.i =
+ x[i__5].r * temp.i + x[i__5].i * temp.r;
+ q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i + q__2.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ ix += *incx;
+/* L30: */
+ }
+ }
+ jy += *incy;
+/* L40: */
+ }
+ }
+
+ return 0;
+
+/* End of CGERC . */
+
+} /* cgerc_ */
diff --git a/BLAS/SRC/cgeru.c b/BLAS/SRC/cgeru.c
new file mode 100644
index 0000000..ad87262
--- /dev/null
+++ b/BLAS/SRC/cgeru.c
@@ -0,0 +1,214 @@
+/* cgeru.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cgeru_(integer *m, integer *n, complex *alpha, complex *
+ x, integer *incx, complex *y, integer *incy, complex *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1, q__2;
+
+ /* Local variables */
+ integer i__, j, ix, jy, kx, info;
+ complex temp;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGERU performs the rank 1 operation */
+
+/* A := alpha*x*y' + A, */
+
+/* where alpha is a scalar, x is an m element vector, y is an n element */
+/* vector and A is an m by n matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix A. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X - COMPLEX array of dimension at least */
+/* ( 1 + ( m - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the m */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* Y - COMPLEX array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. */
+/* Unchanged on exit. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, n ). */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. On exit, A is */
+/* overwritten by the updated matrix. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ --y;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ info = 0;
+ if (*m < 0) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ } else if (*incy == 0) {
+ info = 7;
+ } else if (*lda < max(1,*m)) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("CGERU ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || alpha->r == 0.f && alpha->i == 0.f) {
+ return 0;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through A. */
+
+ if (*incy > 0) {
+ jy = 1;
+ } else {
+ jy = 1 - (*n - 1) * *incy;
+ }
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jy;
+ if (y[i__2].r != 0.f || y[i__2].i != 0.f) {
+ i__2 = jy;
+ q__1.r = alpha->r * y[i__2].r - alpha->i * y[i__2].i, q__1.i =
+ alpha->r * y[i__2].i + alpha->i * y[i__2].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__;
+ q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, q__2.i =
+ x[i__5].r * temp.i + x[i__5].i * temp.r;
+ q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i + q__2.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L10: */
+ }
+ }
+ jy += *incy;
+/* L20: */
+ }
+ } else {
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*m - 1) * *incx;
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jy;
+ if (y[i__2].r != 0.f || y[i__2].i != 0.f) {
+ i__2 = jy;
+ q__1.r = alpha->r * y[i__2].r - alpha->i * y[i__2].i, q__1.i =
+ alpha->r * y[i__2].i + alpha->i * y[i__2].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix = kx;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = ix;
+ q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, q__2.i =
+ x[i__5].r * temp.i + x[i__5].i * temp.r;
+ q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i + q__2.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ ix += *incx;
+/* L30: */
+ }
+ }
+ jy += *incy;
+/* L40: */
+ }
+ }
+
+ return 0;
+
+/* End of CGERU . */
+
+} /* cgeru_ */
diff --git a/BLAS/SRC/chbmv.c b/BLAS/SRC/chbmv.c
new file mode 100644
index 0000000..81e5da7
--- /dev/null
+++ b/BLAS/SRC/chbmv.c
@@ -0,0 +1,483 @@
+/* chbmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int chbmv_(char *uplo, integer *n, integer *k, complex *
+ alpha, complex *a, integer *lda, complex *x, integer *incx, complex *
+ beta, complex *y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, l, ix, iy, jx, jy, kx, ky, info;
+ complex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ integer kplus1;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHBMV performs the matrix-vector operation */
+
+/* y := alpha*A*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are n element vectors and */
+/* A is an n by n hermitian band matrix, with k super-diagonals. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the band matrix A is being supplied as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* being supplied. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* being supplied. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry, K specifies the number of super-diagonals of the */
+/* matrix A. K must satisfy 0 .le. K. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
+/* by n part of the array A must contain the upper triangular */
+/* band part of the hermitian matrix, supplied column by */
+/* column, with the leading diagonal of the matrix in row */
+/* ( k + 1 ) of the array, the first super-diagonal starting at */
+/* position 2 in row k, and so on. The top left k by k triangle */
+/* of the array A is not referenced. */
+/* The following program segment will transfer the upper */
+/* triangular part of a hermitian band matrix from conventional */
+/* full matrix storage to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = K + 1 - J */
+/* DO 10, I = MAX( 1, J - K ), J */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
+/* by n part of the array A must contain the lower triangular */
+/* band part of the hermitian matrix, supplied column by */
+/* column, with the leading diagonal of the matrix in row 1 of */
+/* the array, the first sub-diagonal starting at position 1 in */
+/* row 2, and so on. The bottom right k by k triangle of the */
+/* array A is not referenced. */
+/* The following program segment will transfer the lower */
+/* triangular part of a hermitian band matrix from conventional */
+/* full matrix storage to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = 1 - J */
+/* DO 10, I = J, MIN( N, J + K ) */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set and are assumed to be zero. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* ( k + 1 ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX . */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+/* Y - COMPLEX array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the */
+/* vector y. On exit, Y is overwritten by the updated vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*k < 0) {
+ info = 3;
+ } else if (*lda < *k + 1) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ } else if (*incy == 0) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("CHBMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f &&
+ beta->i == 0.f)) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of the array A */
+/* are accessed sequentially with one pass through A. */
+
+/* First form y := beta*y. */
+
+ if (beta->r != 1.f || beta->i != 0.f) {
+ if (*incy == 1) {
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ y[i__2].r = 0.f, y[i__2].i = 0.f;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ y[i__2].r = 0.f, y[i__2].i = 0.f;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ i__3 = iy;
+ q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (alpha->r == 0.f && alpha->i == 0.f) {
+ return 0;
+ }
+ if (lsame_(uplo, "U")) {
+
+/* Form y when upper triangle of A is stored. */
+
+ kplus1 = *k + 1;
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__5 = l + i__ + j * a_dim1;
+ q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
+ i__2 = i__;
+ q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i, q__2.i =
+ q__3.r * x[i__2].i + q__3.i * x[i__2].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L50: */
+ }
+ i__4 = j;
+ i__2 = j;
+ i__3 = kplus1 + j * a_dim1;
+ r__1 = a[i__3].r;
+ q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
+ q__2.r = y[i__2].r + q__3.r, q__2.i = y[i__2].i + q__3.i;
+ q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ y[i__4].r = q__1.r, y[i__4].i = q__1.i;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = jx;
+ q__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i, q__1.i =
+ alpha->r * x[i__4].i + alpha->i * x[i__4].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ ix = kx;
+ iy = ky;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *k;
+ i__3 = j - 1;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ i__4 = iy;
+ i__2 = iy;
+ i__5 = l + i__ + j * a_dim1;
+ q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
+ y[i__4].r = q__1.r, y[i__4].i = q__1.i;
+ r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
+ i__4 = ix;
+ q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i =
+ q__3.r * x[i__4].i + q__3.i * x[i__4].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ i__3 = jy;
+ i__4 = jy;
+ i__2 = kplus1 + j * a_dim1;
+ r__1 = a[i__2].r;
+ q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
+ q__2.r = y[i__4].r + q__3.r, q__2.i = y[i__4].i + q__3.i;
+ q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ jx += *incx;
+ jy += *incy;
+ if (j > *k) {
+ kx += *incx;
+ ky += *incy;
+ }
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y when lower triangle of A is stored. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = j;
+ q__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, q__1.i =
+ alpha->r * x[i__3].i + alpha->i * x[i__3].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__3 = j;
+ i__4 = j;
+ i__2 = j * a_dim1 + 1;
+ r__1 = a[i__2].r;
+ q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ l = 1 - j;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__2 = i__;
+ i__5 = l + i__ + j * a_dim1;
+ q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
+ y[i__4].r = q__1.r, y[i__4].i = q__1.i;
+ r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
+ i__4 = i__;
+ q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i =
+ q__3.r * x[i__4].i + q__3.i * x[i__4].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L90: */
+ }
+ i__3 = j;
+ i__4 = j;
+ q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = jx;
+ q__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, q__1.i =
+ alpha->r * x[i__3].i + alpha->i * x[i__3].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__3 = jy;
+ i__4 = jy;
+ i__2 = j * a_dim1 + 1;
+ r__1 = a[i__2].r;
+ q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ l = 1 - j;
+ ix = jx;
+ iy = jy;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ ix += *incx;
+ iy += *incy;
+ i__4 = iy;
+ i__2 = iy;
+ i__5 = l + i__ + j * a_dim1;
+ q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
+ y[i__4].r = q__1.r, y[i__4].i = q__1.i;
+ r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
+ i__4 = ix;
+ q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i =
+ q__3.r * x[i__4].i + q__3.i * x[i__4].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L110: */
+ }
+ i__3 = jy;
+ i__4 = jy;
+ q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ jx += *incx;
+ jy += *incy;
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CHBMV . */
+
+} /* chbmv_ */
diff --git a/BLAS/SRC/chemm.c b/BLAS/SRC/chemm.c
new file mode 100644
index 0000000..7404e5d
--- /dev/null
+++ b/BLAS/SRC/chemm.c
@@ -0,0 +1,495 @@
+/* chemm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int chemm_(char *side, char *uplo, integer *m, integer *n,
+ complex *alpha, complex *a, integer *lda, complex *b, integer *ldb,
+ complex *beta, complex *c__, integer *ldc)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6;
+ real r__1;
+ complex q__1, q__2, q__3, q__4, q__5;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k, info;
+ complex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHEMM performs one of the matrix-matrix operations */
+
+/* C := alpha*A*B + beta*C, */
+
+/* or */
+
+/* C := alpha*B*A + beta*C, */
+
+/* where alpha and beta are scalars, A is an hermitian matrix and B and */
+/* C are m by n matrices. */
+
+/* Arguments */
+/* ========== */
+
+/* SIDE - CHARACTER*1. */
+/* On entry, SIDE specifies whether the hermitian matrix A */
+/* appears on the left or right in the operation as follows: */
+
+/* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, */
+
+/* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, */
+
+/* Unchanged on exit. */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the hermitian matrix A is to be */
+/* referenced as follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of the */
+/* hermitian matrix is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of the */
+/* hermitian matrix is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix C. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix C. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is */
+/* m when SIDE = 'L' or 'l' and is n otherwise. */
+/* Before entry with SIDE = 'L' or 'l', the m by m part of */
+/* the array A must contain the hermitian matrix, such that */
+/* when UPLO = 'U' or 'u', the leading m by m upper triangular */
+/* part of the array A must contain the upper triangular part */
+/* of the hermitian matrix and the strictly lower triangular */
+/* part of A is not referenced, and when UPLO = 'L' or 'l', */
+/* the leading m by m lower triangular part of the array A */
+/* must contain the lower triangular part of the hermitian */
+/* matrix and the strictly upper triangular part of A is not */
+/* referenced. */
+/* Before entry with SIDE = 'R' or 'r', the n by n part of */
+/* the array A must contain the hermitian matrix, such that */
+/* when UPLO = 'U' or 'u', the leading n by n upper triangular */
+/* part of the array A must contain the upper triangular part */
+/* of the hermitian matrix and the strictly lower triangular */
+/* part of A is not referenced, and when UPLO = 'L' or 'l', */
+/* the leading n by n lower triangular part of the array A */
+/* must contain the lower triangular part of the hermitian */
+/* matrix and the strictly upper triangular part of A is not */
+/* referenced. */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set, they are assumed to be zero. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When SIDE = 'L' or 'l' then */
+/* LDA must be at least max( 1, m ), otherwise LDA must be at */
+/* least max( 1, n ). */
+/* Unchanged on exit. */
+
+/* B - COMPLEX array of DIMENSION ( LDB, n ). */
+/* Before entry, the leading m by n part of the array B must */
+/* contain the matrix B. */
+/* Unchanged on exit. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. LDB must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then C need not be set on input. */
+/* Unchanged on exit. */
+
+/* C - COMPLEX array of DIMENSION ( LDC, n ). */
+/* Before entry, the leading m by n part of the array C must */
+/* contain the matrix C, except when beta is zero, in which */
+/* case C need not be set on entry. */
+/* On exit, the array C is overwritten by the m by n updated */
+/* matrix. */
+
+/* LDC - INTEGER. */
+/* On entry, LDC specifies the first dimension of C as declared */
+/* in the calling (sub) program. LDC must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Set NROWA as the number of rows of A. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ if (lsame_(side, "L")) {
+ nrowa = *m;
+ } else {
+ nrowa = *n;
+ }
+ upper = lsame_(uplo, "U");
+
+/* Test the input parameters. */
+
+ info = 0;
+ if (! lsame_(side, "L") && ! lsame_(side, "R")) {
+ info = 1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ info = 2;
+ } else if (*m < 0) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*lda < max(1,nrowa)) {
+ info = 7;
+ } else if (*ldb < max(1,*m)) {
+ info = 9;
+ } else if (*ldc < max(1,*m)) {
+ info = 12;
+ }
+ if (info != 0) {
+ xerbla_("CHEMM ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r
+ == 1.f && beta->i == 0.f)) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (alpha->r == 0.f && alpha->i == 0.f) {
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0.f, c__[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
+ q__1.i = beta->r * c__[i__4].i + beta->i * c__[
+ i__4].r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lsame_(side, "L")) {
+
+/* Form C := alpha*A*B + beta*C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
+ q__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3]
+ .r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__3 = i__ - 1;
+ for (k = 1; k <= i__3; ++k) {
+ i__4 = k + j * c_dim1;
+ i__5 = k + j * c_dim1;
+ i__6 = k + i__ * a_dim1;
+ q__2.r = temp1.r * a[i__6].r - temp1.i * a[i__6].i,
+ q__2.i = temp1.r * a[i__6].i + temp1.i * a[
+ i__6].r;
+ q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i +
+ q__2.i;
+ c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
+ i__4 = k + j * b_dim1;
+ r_cnjg(&q__3, &a[k + i__ * a_dim1]);
+ q__2.r = b[i__4].r * q__3.r - b[i__4].i * q__3.i,
+ q__2.i = b[i__4].r * q__3.i + b[i__4].i *
+ q__3.r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L50: */
+ }
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + i__ * a_dim1;
+ r__1 = a[i__4].r;
+ q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
+ q__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ q__3.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, q__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ i__5 = i__ + i__ * a_dim1;
+ r__1 = a[i__5].r;
+ q__4.r = r__1 * temp1.r, q__4.i = r__1 * temp1.i;
+ q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i;
+ q__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ q__5.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (i__ = *m; i__ >= 1; --i__) {
+ i__2 = i__ + j * b_dim1;
+ q__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2].i,
+ q__1.i = alpha->r * b[i__2].i + alpha->i * b[i__2]
+ .r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__2 = *m;
+ for (k = i__ + 1; k <= i__2; ++k) {
+ i__3 = k + j * c_dim1;
+ i__4 = k + j * c_dim1;
+ i__5 = k + i__ * a_dim1;
+ q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ q__2.i = temp1.r * a[i__5].i + temp1.i * a[
+ i__5].r;
+ q__1.r = c__[i__4].r + q__2.r, q__1.i = c__[i__4].i +
+ q__2.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ i__3 = k + j * b_dim1;
+ r_cnjg(&q__3, &a[k + i__ * a_dim1]);
+ q__2.r = b[i__3].r * q__3.r - b[i__3].i * q__3.i,
+ q__2.i = b[i__3].r * q__3.i + b[i__3].i *
+ q__3.r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L80: */
+ }
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__2 = i__ + j * c_dim1;
+ i__3 = i__ + i__ * a_dim1;
+ r__1 = a[i__3].r;
+ q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
+ q__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ q__3.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ } else {
+ i__2 = i__ + j * c_dim1;
+ i__3 = i__ + j * c_dim1;
+ q__3.r = beta->r * c__[i__3].r - beta->i * c__[i__3]
+ .i, q__3.i = beta->r * c__[i__3].i + beta->i *
+ c__[i__3].r;
+ i__4 = i__ + i__ * a_dim1;
+ r__1 = a[i__4].r;
+ q__4.r = r__1 * temp1.r, q__4.i = r__1 * temp1.i;
+ q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i;
+ q__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ q__5.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+ }
+ } else {
+
+/* Form C := alpha*B*A + beta*C. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * a_dim1;
+ r__1 = a[i__2].r;
+ q__1.r = r__1 * alpha->r, q__1.i = r__1 * alpha->i;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * b_dim1;
+ q__1.r = temp1.r * b[i__4].r - temp1.i * b[i__4].i,
+ q__1.i = temp1.r * b[i__4].i + temp1.i * b[i__4]
+ .r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L110: */
+ }
+ } else {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__2.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
+ q__2.i = beta->r * c__[i__4].i + beta->i * c__[
+ i__4].r;
+ i__5 = i__ + j * b_dim1;
+ q__3.r = temp1.r * b[i__5].r - temp1.i * b[i__5].i,
+ q__3.i = temp1.r * b[i__5].i + temp1.i * b[i__5]
+ .r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L120: */
+ }
+ }
+ i__2 = j - 1;
+ for (k = 1; k <= i__2; ++k) {
+ if (upper) {
+ i__3 = k + j * a_dim1;
+ q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
+ .r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ } else {
+ r_cnjg(&q__2, &a[j + k * a_dim1]);
+ q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
+ alpha->r * q__2.i + alpha->i * q__2.r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ }
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + k * b_dim1;
+ q__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i,
+ q__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6]
+ .r;
+ q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i +
+ q__2.i;
+ c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
+/* L130: */
+ }
+/* L140: */
+ }
+ i__2 = *n;
+ for (k = j + 1; k <= i__2; ++k) {
+ if (upper) {
+ r_cnjg(&q__2, &a[j + k * a_dim1]);
+ q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
+ alpha->r * q__2.i + alpha->i * q__2.r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ } else {
+ i__3 = k + j * a_dim1;
+ q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
+ .r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ }
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + k * b_dim1;
+ q__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i,
+ q__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6]
+ .r;
+ q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i +
+ q__2.i;
+ c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
+/* L150: */
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+ }
+
+ return 0;
+
+/* End of CHEMM . */
+
+} /* chemm_ */
diff --git a/BLAS/SRC/chemv.c b/BLAS/SRC/chemv.c
new file mode 100644
index 0000000..163ceca
--- /dev/null
+++ b/BLAS/SRC/chemv.c
@@ -0,0 +1,433 @@
+/* chemv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int chemv_(char *uplo, integer *n, complex *alpha, complex *
+ a, integer *lda, complex *x, integer *incx, complex *beta, complex *y,
+ integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, ix, iy, jx, jy, kx, ky, info;
+ complex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHEMV performs the matrix-vector operation */
+
+/* y := alpha*A*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are n element vectors and */
+/* A is an n by n hermitian matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array A is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of A */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of A */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular part of the hermitian matrix and the strictly */
+/* lower triangular part of A is not referenced. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular part of the hermitian matrix and the strictly */
+/* upper triangular part of A is not referenced. */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set and are assumed to be zero. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - COMPLEX array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. On exit, Y is overwritten by the updated */
+/* vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*lda < max(1,*n)) {
+ info = 5;
+ } else if (*incx == 0) {
+ info = 7;
+ } else if (*incy == 0) {
+ info = 10;
+ }
+ if (info != 0) {
+ xerbla_("CHEMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f &&
+ beta->i == 0.f)) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through the triangular part */
+/* of A. */
+
+/* First form y := beta*y. */
+
+ if (beta->r != 1.f || beta->i != 0.f) {
+ if (*incy == 1) {
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ y[i__2].r = 0.f, y[i__2].i = 0.f;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ y[i__2].r = 0.f, y[i__2].i = 0.f;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ i__3 = iy;
+ q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (alpha->r == 0.f && alpha->i == 0.f) {
+ return 0;
+ }
+ if (lsame_(uplo, "U")) {
+
+/* Form y when A is stored in upper triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ r_cnjg(&q__3, &a[i__ + j * a_dim1]);
+ i__3 = i__;
+ q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
+ q__3.r * x[i__3].i + q__3.i * x[i__3].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L50: */
+ }
+ i__2 = j;
+ i__3 = j;
+ i__4 = j + j * a_dim1;
+ r__1 = a[i__4].r;
+ q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
+ q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i;
+ q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ ix = kx;
+ iy = ky;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = iy;
+ i__4 = iy;
+ i__5 = i__ + j * a_dim1;
+ q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ r_cnjg(&q__3, &a[i__ + j * a_dim1]);
+ i__3 = ix;
+ q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
+ q__3.r * x[i__3].i + q__3.i * x[i__3].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ i__2 = jy;
+ i__3 = jy;
+ i__4 = j + j * a_dim1;
+ r__1 = a[i__4].r;
+ q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
+ q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i;
+ q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ jx += *incx;
+ jy += *incy;
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y when A is stored in lower triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__2 = j;
+ i__3 = j;
+ i__4 = j + j * a_dim1;
+ r__1 = a[i__4].r;
+ q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
+ q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ r_cnjg(&q__3, &a[i__ + j * a_dim1]);
+ i__3 = i__;
+ q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
+ q__3.r * x[i__3].i + q__3.i * x[i__3].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L90: */
+ }
+ i__2 = j;
+ i__3 = j;
+ q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__2 = jy;
+ i__3 = jy;
+ i__4 = j + j * a_dim1;
+ r__1 = a[i__4].r;
+ q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
+ q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ ix = jx;
+ iy = jy;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ ix += *incx;
+ iy += *incy;
+ i__3 = iy;
+ i__4 = iy;
+ i__5 = i__ + j * a_dim1;
+ q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ r_cnjg(&q__3, &a[i__ + j * a_dim1]);
+ i__3 = ix;
+ q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
+ q__3.r * x[i__3].i + q__3.i * x[i__3].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L110: */
+ }
+ i__2 = jy;
+ i__3 = jy;
+ q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ jx += *incx;
+ jy += *incy;
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CHEMV . */
+
+} /* chemv_ */
diff --git a/BLAS/SRC/cher.c b/BLAS/SRC/cher.c
new file mode 100644
index 0000000..933de87
--- /dev/null
+++ b/BLAS/SRC/cher.c
@@ -0,0 +1,338 @@
+/* cher.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cher_(char *uplo, integer *n, real *alpha, complex *x,
+ integer *incx, complex *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, ix, jx, kx, info;
+ complex temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHER performs the hermitian rank 1 operation */
+
+/* A := alpha*x*conjg( x' ) + A, */
+
+/* where alpha is a real scalar, x is an n element vector and A is an */
+/* n by n hermitian matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array A is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of A */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of A */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X - COMPLEX array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular part of the hermitian matrix and the strictly */
+/* lower triangular part of A is not referenced. On exit, the */
+/* upper triangular part of the array A is overwritten by the */
+/* upper triangular part of the updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular part of the hermitian matrix and the strictly */
+/* upper triangular part of A is not referenced. On exit, the */
+/* lower triangular part of the array A is overwritten by the */
+/* lower triangular part of the updated matrix. */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set, they are assumed to be zero, and on exit they */
+/* are set to zero. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ } else if (*lda < max(1,*n)) {
+ info = 7;
+ }
+ if (info != 0) {
+ xerbla_("CHER ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0.f) {
+ return 0;
+ }
+
+/* Set the start point in X if the increment is not unity. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through the triangular part */
+/* of A. */
+
+ if (lsame_(uplo, "U")) {
+
+/* Form A when A is stored in upper triangle. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ r_cnjg(&q__2, &x[j]);
+ q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__;
+ q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ q__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i +
+ q__2.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L10: */
+ }
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ i__4 = j;
+ q__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, q__1.i =
+ x[i__4].r * temp.i + x[i__4].i * temp.r;
+ r__1 = a[i__3].r + q__1.r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ } else {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ r__1 = a[i__3].r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ }
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ r_cnjg(&q__2, &x[jx]);
+ q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix = kx;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = ix;
+ q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ q__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i +
+ q__2.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ ix += *incx;
+/* L30: */
+ }
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ i__4 = jx;
+ q__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, q__1.i =
+ x[i__4].r * temp.i + x[i__4].i * temp.r;
+ r__1 = a[i__3].r + q__1.r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ } else {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ r__1 = a[i__3].r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ }
+ jx += *incx;
+/* L40: */
+ }
+ }
+ } else {
+
+/* Form A when A is stored in lower triangle. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ r_cnjg(&q__2, &x[j]);
+ q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ i__4 = j;
+ q__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, q__1.i =
+ temp.r * x[i__4].i + temp.i * x[i__4].r;
+ r__1 = a[i__3].r + q__1.r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__;
+ q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ q__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i +
+ q__2.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L50: */
+ }
+ } else {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ r__1 = a[i__3].r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ }
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ r_cnjg(&q__2, &x[jx]);
+ q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ i__4 = jx;
+ q__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, q__1.i =
+ temp.r * x[i__4].i + temp.i * x[i__4].r;
+ r__1 = a[i__3].r + q__1.r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ ix = jx;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ ix += *incx;
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = ix;
+ q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ q__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i +
+ q__2.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L70: */
+ }
+ } else {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ r__1 = a[i__3].r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ }
+ jx += *incx;
+/* L80: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CHER . */
+
+} /* cher_ */
diff --git a/BLAS/SRC/cher2.c b/BLAS/SRC/cher2.c
new file mode 100644
index 0000000..2de3bab
--- /dev/null
+++ b/BLAS/SRC/cher2.c
@@ -0,0 +1,446 @@
+/* cher2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cher2_(char *uplo, integer *n, complex *alpha, complex *
+ x, integer *incx, complex *y, integer *incy, complex *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, ix, iy, jx, jy, kx, ky, info;
+ complex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHER2 performs the hermitian rank 2 operation */
+
+/* A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A, */
+
+/* where alpha is a scalar, x and y are n element vectors and A is an n */
+/* by n hermitian matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array A is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of A */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of A */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X - COMPLEX array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* Y - COMPLEX array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. */
+/* Unchanged on exit. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular part of the hermitian matrix and the strictly */
+/* lower triangular part of A is not referenced. On exit, the */
+/* upper triangular part of the array A is overwritten by the */
+/* upper triangular part of the updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular part of the hermitian matrix and the strictly */
+/* upper triangular part of A is not referenced. On exit, the */
+/* lower triangular part of the array A is overwritten by the */
+/* lower triangular part of the updated matrix. */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set, they are assumed to be zero, and on exit they */
+/* are set to zero. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ --y;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ } else if (*incy == 0) {
+ info = 7;
+ } else if (*lda < max(1,*n)) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("CHER2 ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y if the increments are not both */
+/* unity. */
+
+ if (*incx != 1 || *incy != 1) {
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+ jx = kx;
+ jy = ky;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through the triangular part */
+/* of A. */
+
+ if (lsame_(uplo, "U")) {
+
+/* Form A when A is stored in the upper triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ i__3 = j;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f
+ || y[i__3].i != 0.f)) {
+ r_cnjg(&q__2, &y[j]);
+ q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
+ alpha->r * q__2.i + alpha->i * q__2.r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ i__2 = j;
+ q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ r_cnjg(&q__1, &q__2);
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__;
+ q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
+ q__3.i = x[i__5].r * temp1.i + x[i__5].i *
+ temp1.r;
+ q__2.r = a[i__4].r + q__3.r, q__2.i = a[i__4].i +
+ q__3.i;
+ i__6 = i__;
+ q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
+ q__4.i = y[i__6].r * temp2.i + y[i__6].i *
+ temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L10: */
+ }
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ i__4 = j;
+ q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
+ q__2.i = x[i__4].r * temp1.i + x[i__4].i *
+ temp1.r;
+ i__5 = j;
+ q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
+ q__3.i = y[i__5].r * temp2.i + y[i__5].i *
+ temp2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ r__1 = a[i__3].r + q__1.r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ } else {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ r__1 = a[i__3].r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ i__3 = jy;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f
+ || y[i__3].i != 0.f)) {
+ r_cnjg(&q__2, &y[jy]);
+ q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
+ alpha->r * q__2.i + alpha->i * q__2.r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ i__2 = jx;
+ q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ r_cnjg(&q__1, &q__2);
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ ix = kx;
+ iy = ky;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = ix;
+ q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
+ q__3.i = x[i__5].r * temp1.i + x[i__5].i *
+ temp1.r;
+ q__2.r = a[i__4].r + q__3.r, q__2.i = a[i__4].i +
+ q__3.i;
+ i__6 = iy;
+ q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
+ q__4.i = y[i__6].r * temp2.i + y[i__6].i *
+ temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L30: */
+ }
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ i__4 = jx;
+ q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
+ q__2.i = x[i__4].r * temp1.i + x[i__4].i *
+ temp1.r;
+ i__5 = jy;
+ q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
+ q__3.i = y[i__5].r * temp2.i + y[i__5].i *
+ temp2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ r__1 = a[i__3].r + q__1.r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ } else {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ r__1 = a[i__3].r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ }
+ jx += *incx;
+ jy += *incy;
+/* L40: */
+ }
+ }
+ } else {
+
+/* Form A when A is stored in the lower triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ i__3 = j;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f
+ || y[i__3].i != 0.f)) {
+ r_cnjg(&q__2, &y[j]);
+ q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
+ alpha->r * q__2.i + alpha->i * q__2.r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ i__2 = j;
+ q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ r_cnjg(&q__1, &q__2);
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ i__4 = j;
+ q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
+ q__2.i = x[i__4].r * temp1.i + x[i__4].i *
+ temp1.r;
+ i__5 = j;
+ q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
+ q__3.i = y[i__5].r * temp2.i + y[i__5].i *
+ temp2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ r__1 = a[i__3].r + q__1.r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__;
+ q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
+ q__3.i = x[i__5].r * temp1.i + x[i__5].i *
+ temp1.r;
+ q__2.r = a[i__4].r + q__3.r, q__2.i = a[i__4].i +
+ q__3.i;
+ i__6 = i__;
+ q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
+ q__4.i = y[i__6].r * temp2.i + y[i__6].i *
+ temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L50: */
+ }
+ } else {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ r__1 = a[i__3].r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ i__3 = jy;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f
+ || y[i__3].i != 0.f)) {
+ r_cnjg(&q__2, &y[jy]);
+ q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
+ alpha->r * q__2.i + alpha->i * q__2.r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ i__2 = jx;
+ q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ r_cnjg(&q__1, &q__2);
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ i__4 = jx;
+ q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
+ q__2.i = x[i__4].r * temp1.i + x[i__4].i *
+ temp1.r;
+ i__5 = jy;
+ q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
+ q__3.i = y[i__5].r * temp2.i + y[i__5].i *
+ temp2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ r__1 = a[i__3].r + q__1.r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ ix = jx;
+ iy = jy;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ ix += *incx;
+ iy += *incy;
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = ix;
+ q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
+ q__3.i = x[i__5].r * temp1.i + x[i__5].i *
+ temp1.r;
+ q__2.r = a[i__4].r + q__3.r, q__2.i = a[i__4].i +
+ q__3.i;
+ i__6 = iy;
+ q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
+ q__4.i = y[i__6].r * temp2.i + y[i__6].i *
+ temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L70: */
+ }
+ } else {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ r__1 = a[i__3].r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ }
+ jx += *incx;
+ jy += *incy;
+/* L80: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CHER2 . */
+
+} /* cher2_ */
diff --git a/BLAS/SRC/cher2k.c b/BLAS/SRC/cher2k.c
new file mode 100644
index 0000000..c5f2d99
--- /dev/null
+++ b/BLAS/SRC/cher2k.c
@@ -0,0 +1,671 @@
+/* cher2k.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cher2k_(char *uplo, char *trans, integer *n, integer *k,
+ complex *alpha, complex *a, integer *lda, complex *b, integer *ldb,
+ real *beta, complex *c__, integer *ldc)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6, i__7;
+ real r__1;
+ complex q__1, q__2, q__3, q__4, q__5, q__6;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, l, info;
+ complex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHER2K performs one of the hermitian rank 2k operations */
+
+/* C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + beta*C, */
+
+/* or */
+
+/* C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + beta*C, */
+
+/* where alpha and beta are scalars with beta real, C is an n by n */
+/* hermitian matrix and A and B are n by k matrices in the first case */
+/* and k by n matrices in the second case. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array C is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of C */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of C */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' C := alpha*A*conjg( B' ) + */
+/* conjg( alpha )*B*conjg( A' ) + */
+/* beta*C. */
+
+/* TRANS = 'C' or 'c' C := alpha*conjg( A' )*B + */
+/* conjg( alpha )*conjg( B' )*A + */
+/* beta*C. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix C. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry with TRANS = 'N' or 'n', K specifies the number */
+/* of columns of the matrices A and B, and on entry with */
+/* TRANS = 'C' or 'c', K specifies the number of rows of the */
+/* matrices A and B. K must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is */
+/* k when TRANS = 'N' or 'n', and is n otherwise. */
+/* Before entry with TRANS = 'N' or 'n', the leading n by k */
+/* part of the array A must contain the matrix A, otherwise */
+/* the leading k by n part of the array A must contain the */
+/* matrix A. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When TRANS = 'N' or 'n' */
+/* then LDA must be at least max( 1, n ), otherwise LDA must */
+/* be at least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is */
+/* k when TRANS = 'N' or 'n', and is n otherwise. */
+/* Before entry with TRANS = 'N' or 'n', the leading n by k */
+/* part of the array B must contain the matrix B, otherwise */
+/* the leading k by n part of the array B must contain the */
+/* matrix B. */
+/* Unchanged on exit. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. When TRANS = 'N' or 'n' */
+/* then LDB must be at least max( 1, n ), otherwise LDB must */
+/* be at least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* BETA - REAL . */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+/* C - COMPLEX array of DIMENSION ( LDC, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array C must contain the upper */
+/* triangular part of the hermitian matrix and the strictly */
+/* lower triangular part of C is not referenced. On exit, the */
+/* upper triangular part of the array C is overwritten by the */
+/* upper triangular part of the updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array C must contain the lower */
+/* triangular part of the hermitian matrix and the strictly */
+/* upper triangular part of C is not referenced. On exit, the */
+/* lower triangular part of the array C is overwritten by the */
+/* lower triangular part of the updated matrix. */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set, they are assumed to be zero, and on exit they */
+/* are set to zero. */
+
+/* LDC - INTEGER. */
+/* On entry, LDC specifies the first dimension of C as declared */
+/* in the calling (sub) program. LDC must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* -- Modified 8-Nov-93 to set C(J,J) to REAL( C(J,J) ) when BETA = 1. */
+/* Ed Anderson, Cray Research Inc. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ if (lsame_(trans, "N")) {
+ nrowa = *n;
+ } else {
+ nrowa = *k;
+ }
+ upper = lsame_(uplo, "U");
+
+ info = 0;
+ if (! upper && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "C")) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*k < 0) {
+ info = 4;
+ } else if (*lda < max(1,nrowa)) {
+ info = 7;
+ } else if (*ldb < max(1,nrowa)) {
+ info = 9;
+ } else if (*ldc < max(1,*n)) {
+ info = 12;
+ }
+ if (info != 0) {
+ xerbla_("CHER2K", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f || *k == 0) && *beta ==
+ 1.f) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (alpha->r == 0.f && alpha->i == 0.f) {
+ if (upper) {
+ if (*beta == 0.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0.f, c__[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[
+ i__4].i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L30: */
+ }
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ r__1 = *beta * c__[i__3].r;
+ c__[i__2].r = r__1, c__[i__2].i = 0.f;
+/* L40: */
+ }
+ }
+ } else {
+ if (*beta == 0.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0.f, c__[i__3].i = 0.f;
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ r__1 = *beta * c__[i__3].r;
+ c__[i__2].r = r__1, c__[i__2].i = 0.f;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[
+ i__4].i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + */
+/* C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*beta == 0.f) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0.f, c__[i__3].i = 0.f;
+/* L90: */
+ }
+ } else if (*beta != 1.f) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[
+ i__4].i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L100: */
+ }
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ r__1 = *beta * c__[i__3].r;
+ c__[i__2].r = r__1, c__[i__2].i = 0.f;
+ } else {
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ r__1 = c__[i__3].r;
+ c__[i__2].r = r__1, c__[i__2].i = 0.f;
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = j + l * a_dim1;
+ i__4 = j + l * b_dim1;
+ if (a[i__3].r != 0.f || a[i__3].i != 0.f || (b[i__4].r !=
+ 0.f || b[i__4].i != 0.f)) {
+ r_cnjg(&q__2, &b[j + l * b_dim1]);
+ q__1.r = alpha->r * q__2.r - alpha->i * q__2.i,
+ q__1.i = alpha->r * q__2.i + alpha->i *
+ q__2.r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ i__3 = j + l * a_dim1;
+ q__2.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ q__2.i = alpha->r * a[i__3].i + alpha->i * a[
+ i__3].r;
+ r_cnjg(&q__1, &q__2);
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ i__3 = j - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + l * a_dim1;
+ q__3.r = a[i__6].r * temp1.r - a[i__6].i *
+ temp1.i, q__3.i = a[i__6].r * temp1.i + a[
+ i__6].i * temp1.r;
+ q__2.r = c__[i__5].r + q__3.r, q__2.i = c__[i__5]
+ .i + q__3.i;
+ i__7 = i__ + l * b_dim1;
+ q__4.r = b[i__7].r * temp2.r - b[i__7].i *
+ temp2.i, q__4.i = b[i__7].r * temp2.i + b[
+ i__7].i * temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i +
+ q__4.i;
+ c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
+/* L110: */
+ }
+ i__3 = j + j * c_dim1;
+ i__4 = j + j * c_dim1;
+ i__5 = j + l * a_dim1;
+ q__2.r = a[i__5].r * temp1.r - a[i__5].i * temp1.i,
+ q__2.i = a[i__5].r * temp1.i + a[i__5].i *
+ temp1.r;
+ i__6 = j + l * b_dim1;
+ q__3.r = b[i__6].r * temp2.r - b[i__6].i * temp2.i,
+ q__3.i = b[i__6].r * temp2.i + b[i__6].i *
+ temp2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ r__1 = c__[i__4].r + q__1.r;
+ c__[i__3].r = r__1, c__[i__3].i = 0.f;
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*beta == 0.f) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0.f, c__[i__3].i = 0.f;
+/* L140: */
+ }
+ } else if (*beta != 1.f) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[
+ i__4].i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L150: */
+ }
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ r__1 = *beta * c__[i__3].r;
+ c__[i__2].r = r__1, c__[i__2].i = 0.f;
+ } else {
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ r__1 = c__[i__3].r;
+ c__[i__2].r = r__1, c__[i__2].i = 0.f;
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = j + l * a_dim1;
+ i__4 = j + l * b_dim1;
+ if (a[i__3].r != 0.f || a[i__3].i != 0.f || (b[i__4].r !=
+ 0.f || b[i__4].i != 0.f)) {
+ r_cnjg(&q__2, &b[j + l * b_dim1]);
+ q__1.r = alpha->r * q__2.r - alpha->i * q__2.i,
+ q__1.i = alpha->r * q__2.i + alpha->i *
+ q__2.r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ i__3 = j + l * a_dim1;
+ q__2.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ q__2.i = alpha->r * a[i__3].i + alpha->i * a[
+ i__3].r;
+ r_cnjg(&q__1, &q__2);
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ i__3 = *n;
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + l * a_dim1;
+ q__3.r = a[i__6].r * temp1.r - a[i__6].i *
+ temp1.i, q__3.i = a[i__6].r * temp1.i + a[
+ i__6].i * temp1.r;
+ q__2.r = c__[i__5].r + q__3.r, q__2.i = c__[i__5]
+ .i + q__3.i;
+ i__7 = i__ + l * b_dim1;
+ q__4.r = b[i__7].r * temp2.r - b[i__7].i *
+ temp2.i, q__4.i = b[i__7].r * temp2.i + b[
+ i__7].i * temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i +
+ q__4.i;
+ c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
+/* L160: */
+ }
+ i__3 = j + j * c_dim1;
+ i__4 = j + j * c_dim1;
+ i__5 = j + l * a_dim1;
+ q__2.r = a[i__5].r * temp1.r - a[i__5].i * temp1.i,
+ q__2.i = a[i__5].r * temp1.i + a[i__5].i *
+ temp1.r;
+ i__6 = j + l * b_dim1;
+ q__3.r = b[i__6].r * temp2.r - b[i__6].i * temp2.i,
+ q__3.i = b[i__6].r * temp2.i + b[i__6].i *
+ temp2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ r__1 = c__[i__4].r + q__1.r;
+ c__[i__3].r = r__1, c__[i__3].i = 0.f;
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+ } else {
+
+/* Form C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + */
+/* C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp1.r = 0.f, temp1.i = 0.f;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ r_cnjg(&q__3, &a[l + i__ * a_dim1]);
+ i__4 = l + j * b_dim1;
+ q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4].i,
+ q__2.i = q__3.r * b[i__4].i + q__3.i * b[i__4]
+ .r;
+ q__1.r = temp1.r + q__2.r, q__1.i = temp1.i + q__2.i;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ r_cnjg(&q__3, &b[l + i__ * b_dim1]);
+ i__4 = l + j * a_dim1;
+ q__2.r = q__3.r * a[i__4].r - q__3.i * a[i__4].i,
+ q__2.i = q__3.r * a[i__4].i + q__3.i * a[i__4]
+ .r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L190: */
+ }
+ if (i__ == j) {
+ if (*beta == 0.f) {
+ i__3 = j + j * c_dim1;
+ q__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ q__2.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ r_cnjg(&q__4, alpha);
+ q__3.r = q__4.r * temp2.r - q__4.i * temp2.i,
+ q__3.i = q__4.r * temp2.i + q__4.i *
+ temp2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
+ q__3.i;
+ r__1 = q__1.r;
+ c__[i__3].r = r__1, c__[i__3].i = 0.f;
+ } else {
+ i__3 = j + j * c_dim1;
+ i__4 = j + j * c_dim1;
+ q__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ q__2.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ r_cnjg(&q__4, alpha);
+ q__3.r = q__4.r * temp2.r - q__4.i * temp2.i,
+ q__3.i = q__4.r * temp2.i + q__4.i *
+ temp2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
+ q__3.i;
+ r__1 = *beta * c__[i__4].r + q__1.r;
+ c__[i__3].r = r__1, c__[i__3].i = 0.f;
+ }
+ } else {
+ if (*beta == 0.f) {
+ i__3 = i__ + j * c_dim1;
+ q__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ q__2.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ r_cnjg(&q__4, alpha);
+ q__3.r = q__4.r * temp2.r - q__4.i * temp2.i,
+ q__3.i = q__4.r * temp2.i + q__4.i *
+ temp2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
+ q__3.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__3.r = *beta * c__[i__4].r, q__3.i = *beta *
+ c__[i__4].i;
+ q__4.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ q__4.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ q__2.r = q__3.r + q__4.r, q__2.i = q__3.i +
+ q__4.i;
+ r_cnjg(&q__6, alpha);
+ q__5.r = q__6.r * temp2.r - q__6.i * temp2.i,
+ q__5.i = q__6.r * temp2.i + q__6.i *
+ temp2.r;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i +
+ q__5.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ }
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ temp1.r = 0.f, temp1.i = 0.f;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ r_cnjg(&q__3, &a[l + i__ * a_dim1]);
+ i__4 = l + j * b_dim1;
+ q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4].i,
+ q__2.i = q__3.r * b[i__4].i + q__3.i * b[i__4]
+ .r;
+ q__1.r = temp1.r + q__2.r, q__1.i = temp1.i + q__2.i;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ r_cnjg(&q__3, &b[l + i__ * b_dim1]);
+ i__4 = l + j * a_dim1;
+ q__2.r = q__3.r * a[i__4].r - q__3.i * a[i__4].i,
+ q__2.i = q__3.r * a[i__4].i + q__3.i * a[i__4]
+ .r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L220: */
+ }
+ if (i__ == j) {
+ if (*beta == 0.f) {
+ i__3 = j + j * c_dim1;
+ q__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ q__2.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ r_cnjg(&q__4, alpha);
+ q__3.r = q__4.r * temp2.r - q__4.i * temp2.i,
+ q__3.i = q__4.r * temp2.i + q__4.i *
+ temp2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
+ q__3.i;
+ r__1 = q__1.r;
+ c__[i__3].r = r__1, c__[i__3].i = 0.f;
+ } else {
+ i__3 = j + j * c_dim1;
+ i__4 = j + j * c_dim1;
+ q__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ q__2.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ r_cnjg(&q__4, alpha);
+ q__3.r = q__4.r * temp2.r - q__4.i * temp2.i,
+ q__3.i = q__4.r * temp2.i + q__4.i *
+ temp2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
+ q__3.i;
+ r__1 = *beta * c__[i__4].r + q__1.r;
+ c__[i__3].r = r__1, c__[i__3].i = 0.f;
+ }
+ } else {
+ if (*beta == 0.f) {
+ i__3 = i__ + j * c_dim1;
+ q__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ q__2.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ r_cnjg(&q__4, alpha);
+ q__3.r = q__4.r * temp2.r - q__4.i * temp2.i,
+ q__3.i = q__4.r * temp2.i + q__4.i *
+ temp2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
+ q__3.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__3.r = *beta * c__[i__4].r, q__3.i = *beta *
+ c__[i__4].i;
+ q__4.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ q__4.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ q__2.r = q__3.r + q__4.r, q__2.i = q__3.i +
+ q__4.i;
+ r_cnjg(&q__6, alpha);
+ q__5.r = q__6.r * temp2.r - q__6.i * temp2.i,
+ q__5.i = q__6.r * temp2.i + q__6.i *
+ temp2.r;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i +
+ q__5.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ }
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CHER2K. */
+
+} /* cher2k_ */
diff --git a/BLAS/SRC/cherk.c b/BLAS/SRC/cherk.c
new file mode 100644
index 0000000..fae90fb
--- /dev/null
+++ b/BLAS/SRC/cherk.c
@@ -0,0 +1,533 @@
+/* cherk.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cherk_(char *uplo, char *trans, integer *n, integer *k,
+ real *alpha, complex *a, integer *lda, real *beta, complex *c__,
+ integer *ldc)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6;
+ real r__1;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, l, info;
+ complex temp;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ real rtemp;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHERK performs one of the hermitian rank k operations */
+
+/* C := alpha*A*conjg( A' ) + beta*C, */
+
+/* or */
+
+/* C := alpha*conjg( A' )*A + beta*C, */
+
+/* where alpha and beta are real scalars, C is an n by n hermitian */
+/* matrix and A is an n by k matrix in the first case and a k by n */
+/* matrix in the second case. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array C is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of C */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of C */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C. */
+
+/* TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix C. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry with TRANS = 'N' or 'n', K specifies the number */
+/* of columns of the matrix A, and on entry with */
+/* TRANS = 'C' or 'c', K specifies the number of rows of the */
+/* matrix A. K must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is */
+/* k when TRANS = 'N' or 'n', and is n otherwise. */
+/* Before entry with TRANS = 'N' or 'n', the leading n by k */
+/* part of the array A must contain the matrix A, otherwise */
+/* the leading k by n part of the array A must contain the */
+/* matrix A. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When TRANS = 'N' or 'n' */
+/* then LDA must be at least max( 1, n ), otherwise LDA must */
+/* be at least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* BETA - REAL . */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+/* C - COMPLEX array of DIMENSION ( LDC, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array C must contain the upper */
+/* triangular part of the hermitian matrix and the strictly */
+/* lower triangular part of C is not referenced. On exit, the */
+/* upper triangular part of the array C is overwritten by the */
+/* upper triangular part of the updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array C must contain the lower */
+/* triangular part of the hermitian matrix and the strictly */
+/* upper triangular part of C is not referenced. On exit, the */
+/* lower triangular part of the array C is overwritten by the */
+/* lower triangular part of the updated matrix. */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set, they are assumed to be zero, and on exit they */
+/* are set to zero. */
+
+/* LDC - INTEGER. */
+/* On entry, LDC specifies the first dimension of C as declared */
+/* in the calling (sub) program. LDC must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* -- Modified 8-Nov-93 to set C(J,J) to REAL( C(J,J) ) when BETA = 1. */
+/* Ed Anderson, Cray Research Inc. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ if (lsame_(trans, "N")) {
+ nrowa = *n;
+ } else {
+ nrowa = *k;
+ }
+ upper = lsame_(uplo, "U");
+
+ info = 0;
+ if (! upper && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "C")) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*k < 0) {
+ info = 4;
+ } else if (*lda < max(1,nrowa)) {
+ info = 7;
+ } else if (*ldc < max(1,*n)) {
+ info = 10;
+ }
+ if (info != 0) {
+ xerbla_("CHERK ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (*alpha == 0.f) {
+ if (upper) {
+ if (*beta == 0.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0.f, c__[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[
+ i__4].i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L30: */
+ }
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ r__1 = *beta * c__[i__3].r;
+ c__[i__2].r = r__1, c__[i__2].i = 0.f;
+/* L40: */
+ }
+ }
+ } else {
+ if (*beta == 0.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0.f, c__[i__3].i = 0.f;
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ r__1 = *beta * c__[i__3].r;
+ c__[i__2].r = r__1, c__[i__2].i = 0.f;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[
+ i__4].i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form C := alpha*A*conjg( A' ) + beta*C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*beta == 0.f) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0.f, c__[i__3].i = 0.f;
+/* L90: */
+ }
+ } else if (*beta != 1.f) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[
+ i__4].i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L100: */
+ }
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ r__1 = *beta * c__[i__3].r;
+ c__[i__2].r = r__1, c__[i__2].i = 0.f;
+ } else {
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ r__1 = c__[i__3].r;
+ c__[i__2].r = r__1, c__[i__2].i = 0.f;
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = j + l * a_dim1;
+ if (a[i__3].r != 0.f || a[i__3].i != 0.f) {
+ r_cnjg(&q__2, &a[j + l * a_dim1]);
+ q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__3 = j - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + l * a_dim1;
+ q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
+ q__2.i = temp.r * a[i__6].i + temp.i * a[
+ i__6].r;
+ q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5]
+ .i + q__2.i;
+ c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
+/* L110: */
+ }
+ i__3 = j + j * c_dim1;
+ i__4 = j + j * c_dim1;
+ i__5 = i__ + l * a_dim1;
+ q__1.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ q__1.i = temp.r * a[i__5].i + temp.i * a[i__5]
+ .r;
+ r__1 = c__[i__4].r + q__1.r;
+ c__[i__3].r = r__1, c__[i__3].i = 0.f;
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*beta == 0.f) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0.f, c__[i__3].i = 0.f;
+/* L140: */
+ }
+ } else if (*beta != 1.f) {
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ r__1 = *beta * c__[i__3].r;
+ c__[i__2].r = r__1, c__[i__2].i = 0.f;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__1.r = *beta * c__[i__4].r, q__1.i = *beta * c__[
+ i__4].i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L150: */
+ }
+ } else {
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ r__1 = c__[i__3].r;
+ c__[i__2].r = r__1, c__[i__2].i = 0.f;
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = j + l * a_dim1;
+ if (a[i__3].r != 0.f || a[i__3].i != 0.f) {
+ r_cnjg(&q__2, &a[j + l * a_dim1]);
+ q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__3 = j + j * c_dim1;
+ i__4 = j + j * c_dim1;
+ i__5 = j + l * a_dim1;
+ q__1.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ q__1.i = temp.r * a[i__5].i + temp.i * a[i__5]
+ .r;
+ r__1 = c__[i__4].r + q__1.r;
+ c__[i__3].r = r__1, c__[i__3].i = 0.f;
+ i__3 = *n;
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + l * a_dim1;
+ q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
+ q__2.i = temp.r * a[i__6].i + temp.i * a[
+ i__6].r;
+ q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5]
+ .i + q__2.i;
+ c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
+/* L160: */
+ }
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+ } else {
+
+/* Form C := alpha*conjg( A' )*A + beta*C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp.r = 0.f, temp.i = 0.f;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ r_cnjg(&q__3, &a[l + i__ * a_dim1]);
+ i__4 = l + j * a_dim1;
+ q__2.r = q__3.r * a[i__4].r - q__3.i * a[i__4].i,
+ q__2.i = q__3.r * a[i__4].i + q__3.i * a[i__4]
+ .r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L190: */
+ }
+ if (*beta == 0.f) {
+ i__3 = i__ + j * c_dim1;
+ q__1.r = *alpha * temp.r, q__1.i = *alpha * temp.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ q__2.r = *alpha * temp.r, q__2.i = *alpha * temp.i;
+ i__4 = i__ + j * c_dim1;
+ q__3.r = *beta * c__[i__4].r, q__3.i = *beta * c__[
+ i__4].i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ }
+/* L200: */
+ }
+ rtemp = 0.f;
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ r_cnjg(&q__3, &a[l + j * a_dim1]);
+ i__3 = l + j * a_dim1;
+ q__2.r = q__3.r * a[i__3].r - q__3.i * a[i__3].i, q__2.i =
+ q__3.r * a[i__3].i + q__3.i * a[i__3].r;
+ q__1.r = rtemp + q__2.r, q__1.i = q__2.i;
+ rtemp = q__1.r;
+/* L210: */
+ }
+ if (*beta == 0.f) {
+ i__2 = j + j * c_dim1;
+ r__1 = *alpha * rtemp;
+ c__[i__2].r = r__1, c__[i__2].i = 0.f;
+ } else {
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ r__1 = *alpha * rtemp + *beta * c__[i__3].r;
+ c__[i__2].r = r__1, c__[i__2].i = 0.f;
+ }
+/* L220: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ rtemp = 0.f;
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ r_cnjg(&q__3, &a[l + j * a_dim1]);
+ i__3 = l + j * a_dim1;
+ q__2.r = q__3.r * a[i__3].r - q__3.i * a[i__3].i, q__2.i =
+ q__3.r * a[i__3].i + q__3.i * a[i__3].r;
+ q__1.r = rtemp + q__2.r, q__1.i = q__2.i;
+ rtemp = q__1.r;
+/* L230: */
+ }
+ if (*beta == 0.f) {
+ i__2 = j + j * c_dim1;
+ r__1 = *alpha * rtemp;
+ c__[i__2].r = r__1, c__[i__2].i = 0.f;
+ } else {
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ r__1 = *alpha * rtemp + *beta * c__[i__3].r;
+ c__[i__2].r = r__1, c__[i__2].i = 0.f;
+ }
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ temp.r = 0.f, temp.i = 0.f;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ r_cnjg(&q__3, &a[l + i__ * a_dim1]);
+ i__4 = l + j * a_dim1;
+ q__2.r = q__3.r * a[i__4].r - q__3.i * a[i__4].i,
+ q__2.i = q__3.r * a[i__4].i + q__3.i * a[i__4]
+ .r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L240: */
+ }
+ if (*beta == 0.f) {
+ i__3 = i__ + j * c_dim1;
+ q__1.r = *alpha * temp.r, q__1.i = *alpha * temp.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ q__2.r = *alpha * temp.r, q__2.i = *alpha * temp.i;
+ i__4 = i__ + j * c_dim1;
+ q__3.r = *beta * c__[i__4].r, q__3.i = *beta * c__[
+ i__4].i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ }
+/* L250: */
+ }
+/* L260: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CHERK . */
+
+} /* cherk_ */
diff --git a/BLAS/SRC/chpmv.c b/BLAS/SRC/chpmv.c
new file mode 100644
index 0000000..29d580a
--- /dev/null
+++ b/BLAS/SRC/chpmv.c
@@ -0,0 +1,434 @@
+/* chpmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int chpmv_(char *uplo, integer *n, complex *alpha, complex *
+ ap, complex *x, integer *incx, complex *beta, complex *y, integer *
+ incy)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ real r__1;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
+ complex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHPMV performs the matrix-vector operation */
+
+/* y := alpha*A*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are n element vectors and */
+/* A is an n by n hermitian matrix, supplied in packed form. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the matrix A is supplied in the packed */
+/* array AP as follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* supplied in AP. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* supplied in AP. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* AP - COMPLEX array of DIMENSION at least */
+/* ( ( n*( n + 1 ) )/2 ). */
+/* Before entry with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular part of the hermitian matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
+/* and a( 2, 2 ) respectively, and so on. */
+/* Before entry with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular part of the hermitian matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
+/* and a( 3, 1 ) respectively, and so on. */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set and are assumed to be zero. */
+/* Unchanged on exit. */
+
+/* X - COMPLEX array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - COMPLEX array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. On exit, Y is overwritten by the updated */
+/* vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --y;
+ --x;
+ --ap;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 6;
+ } else if (*incy == 0) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("CHPMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f &&
+ beta->i == 0.f)) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of the array AP */
+/* are accessed sequentially with one pass through AP. */
+
+/* First form y := beta*y. */
+
+ if (beta->r != 1.f || beta->i != 0.f) {
+ if (*incy == 1) {
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ y[i__2].r = 0.f, y[i__2].i = 0.f;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ y[i__2].r = 0.f, y[i__2].i = 0.f;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ i__3 = iy;
+ q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (alpha->r == 0.f && alpha->i == 0.f) {
+ return 0;
+ }
+ kk = 1;
+ if (lsame_(uplo, "U")) {
+
+/* Form y when AP contains the upper triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ k = kk;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = k;
+ q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
+ q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
+ .r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ r_cnjg(&q__3, &ap[k]);
+ i__3 = i__;
+ q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
+ q__3.r * x[i__3].i + q__3.i * x[i__3].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ ++k;
+/* L50: */
+ }
+ i__2 = j;
+ i__3 = j;
+ i__4 = kk + j - 1;
+ r__1 = ap[i__4].r;
+ q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
+ q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i;
+ q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ kk += j;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ ix = kx;
+ iy = ky;
+ i__2 = kk + j - 2;
+ for (k = kk; k <= i__2; ++k) {
+ i__3 = iy;
+ i__4 = iy;
+ i__5 = k;
+ q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
+ q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
+ .r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ r_cnjg(&q__3, &ap[k]);
+ i__3 = ix;
+ q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
+ q__3.r * x[i__3].i + q__3.i * x[i__3].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ i__2 = jy;
+ i__3 = jy;
+ i__4 = kk + j - 1;
+ r__1 = ap[i__4].r;
+ q__3.r = r__1 * temp1.r, q__3.i = r__1 * temp1.i;
+ q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i;
+ q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ jx += *incx;
+ jy += *incy;
+ kk += j;
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y when AP contains the lower triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__2 = j;
+ i__3 = j;
+ i__4 = kk;
+ r__1 = ap[i__4].r;
+ q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
+ q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ k = kk + 1;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = k;
+ q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
+ q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
+ .r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ r_cnjg(&q__3, &ap[k]);
+ i__3 = i__;
+ q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
+ q__3.r * x[i__3].i + q__3.i * x[i__3].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ ++k;
+/* L90: */
+ }
+ i__2 = j;
+ i__3 = j;
+ q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ kk += *n - j + 1;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__2 = jy;
+ i__3 = jy;
+ i__4 = kk;
+ r__1 = ap[i__4].r;
+ q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
+ q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ ix = jx;
+ iy = jy;
+ i__2 = kk + *n - j;
+ for (k = kk + 1; k <= i__2; ++k) {
+ ix += *incx;
+ iy += *incy;
+ i__3 = iy;
+ i__4 = iy;
+ i__5 = k;
+ q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
+ q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
+ .r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ r_cnjg(&q__3, &ap[k]);
+ i__3 = ix;
+ q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i, q__2.i =
+ q__3.r * x[i__3].i + q__3.i * x[i__3].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L110: */
+ }
+ i__2 = jy;
+ i__3 = jy;
+ q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ jx += *incx;
+ jy += *incy;
+ kk += *n - j + 1;
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CHPMV . */
+
+} /* chpmv_ */
diff --git a/BLAS/SRC/chpr.c b/BLAS/SRC/chpr.c
new file mode 100644
index 0000000..2622f05
--- /dev/null
+++ b/BLAS/SRC/chpr.c
@@ -0,0 +1,339 @@
+/* chpr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int chpr_(char *uplo, integer *n, real *alpha, complex *x,
+ integer *incx, complex *ap)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ real r__1;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, jx, kx, info;
+ complex temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHPR performs the hermitian rank 1 operation */
+
+/* A := alpha*x*conjg( x' ) + A, */
+
+/* where alpha is a real scalar, x is an n element vector and A is an */
+/* n by n hermitian matrix, supplied in packed form. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the matrix A is supplied in the packed */
+/* array AP as follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* supplied in AP. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* supplied in AP. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X - COMPLEX array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* AP - COMPLEX array of DIMENSION at least */
+/* ( ( n*( n + 1 ) )/2 ). */
+/* Before entry with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular part of the hermitian matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
+/* and a( 2, 2 ) respectively, and so on. On exit, the array */
+/* AP is overwritten by the upper triangular part of the */
+/* updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular part of the hermitian matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
+/* and a( 3, 1 ) respectively, and so on. On exit, the array */
+/* AP is overwritten by the lower triangular part of the */
+/* updated matrix. */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set, they are assumed to be zero, and on exit they */
+/* are set to zero. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ }
+ if (info != 0) {
+ xerbla_("CHPR ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0.f) {
+ return 0;
+ }
+
+/* Set the start point in X if the increment is not unity. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of the array AP */
+/* are accessed sequentially with one pass through AP. */
+
+ kk = 1;
+ if (lsame_(uplo, "U")) {
+
+/* Form A when upper triangle is stored in AP. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ r_cnjg(&q__2, &x[j]);
+ q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ k = kk;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = k;
+ i__4 = k;
+ i__5 = i__;
+ q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ q__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ q__1.r = ap[i__4].r + q__2.r, q__1.i = ap[i__4].i +
+ q__2.i;
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+ ++k;
+/* L10: */
+ }
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ i__4 = j;
+ q__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, q__1.i =
+ x[i__4].r * temp.i + x[i__4].i * temp.r;
+ r__1 = ap[i__3].r + q__1.r;
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+ } else {
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ r__1 = ap[i__3].r;
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+ }
+ kk += j;
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ r_cnjg(&q__2, &x[jx]);
+ q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix = kx;
+ i__2 = kk + j - 2;
+ for (k = kk; k <= i__2; ++k) {
+ i__3 = k;
+ i__4 = k;
+ i__5 = ix;
+ q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ q__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ q__1.r = ap[i__4].r + q__2.r, q__1.i = ap[i__4].i +
+ q__2.i;
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+ ix += *incx;
+/* L30: */
+ }
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ i__4 = jx;
+ q__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, q__1.i =
+ x[i__4].r * temp.i + x[i__4].i * temp.r;
+ r__1 = ap[i__3].r + q__1.r;
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+ } else {
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ r__1 = ap[i__3].r;
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+ }
+ jx += *incx;
+ kk += j;
+/* L40: */
+ }
+ }
+ } else {
+
+/* Form A when lower triangle is stored in AP. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ r_cnjg(&q__2, &x[j]);
+ q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__2 = kk;
+ i__3 = kk;
+ i__4 = j;
+ q__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, q__1.i =
+ temp.r * x[i__4].i + temp.i * x[i__4].r;
+ r__1 = ap[i__3].r + q__1.r;
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+ k = kk + 1;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = k;
+ i__4 = k;
+ i__5 = i__;
+ q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ q__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ q__1.r = ap[i__4].r + q__2.r, q__1.i = ap[i__4].i +
+ q__2.i;
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+ ++k;
+/* L50: */
+ }
+ } else {
+ i__2 = kk;
+ i__3 = kk;
+ r__1 = ap[i__3].r;
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+ }
+ kk = kk + *n - j + 1;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ r_cnjg(&q__2, &x[jx]);
+ q__1.r = *alpha * q__2.r, q__1.i = *alpha * q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__2 = kk;
+ i__3 = kk;
+ i__4 = jx;
+ q__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, q__1.i =
+ temp.r * x[i__4].i + temp.i * x[i__4].r;
+ r__1 = ap[i__3].r + q__1.r;
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+ ix = jx;
+ i__2 = kk + *n - j;
+ for (k = kk + 1; k <= i__2; ++k) {
+ ix += *incx;
+ i__3 = k;
+ i__4 = k;
+ i__5 = ix;
+ q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ q__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ q__1.r = ap[i__4].r + q__2.r, q__1.i = ap[i__4].i +
+ q__2.i;
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+/* L70: */
+ }
+ } else {
+ i__2 = kk;
+ i__3 = kk;
+ r__1 = ap[i__3].r;
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+ }
+ jx += *incx;
+ kk = kk + *n - j + 1;
+/* L80: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CHPR . */
+
+} /* chpr_ */
diff --git a/BLAS/SRC/chpr2.c b/BLAS/SRC/chpr2.c
new file mode 100644
index 0000000..f16950a
--- /dev/null
+++ b/BLAS/SRC/chpr2.c
@@ -0,0 +1,447 @@
+/* chpr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int chpr2_(char *uplo, integer *n, complex *alpha, complex *
+ x, integer *incx, complex *y, integer *incy, complex *ap)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
+ complex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHPR2 performs the hermitian rank 2 operation */
+
+/* A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A, */
+
+/* where alpha is a scalar, x and y are n element vectors and A is an */
+/* n by n hermitian matrix, supplied in packed form. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the matrix A is supplied in the packed */
+/* array AP as follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* supplied in AP. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* supplied in AP. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X - COMPLEX array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* Y - COMPLEX array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. */
+/* Unchanged on exit. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* AP - COMPLEX array of DIMENSION at least */
+/* ( ( n*( n + 1 ) )/2 ). */
+/* Before entry with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular part of the hermitian matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
+/* and a( 2, 2 ) respectively, and so on. On exit, the array */
+/* AP is overwritten by the upper triangular part of the */
+/* updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular part of the hermitian matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
+/* and a( 3, 1 ) respectively, and so on. On exit, the array */
+/* AP is overwritten by the lower triangular part of the */
+/* updated matrix. */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set, they are assumed to be zero, and on exit they */
+/* are set to zero. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --y;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ } else if (*incy == 0) {
+ info = 7;
+ }
+ if (info != 0) {
+ xerbla_("CHPR2 ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y if the increments are not both */
+/* unity. */
+
+ if (*incx != 1 || *incy != 1) {
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+ jx = kx;
+ jy = ky;
+ }
+
+/* Start the operations. In this version the elements of the array AP */
+/* are accessed sequentially with one pass through AP. */
+
+ kk = 1;
+ if (lsame_(uplo, "U")) {
+
+/* Form A when upper triangle is stored in AP. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ i__3 = j;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f
+ || y[i__3].i != 0.f)) {
+ r_cnjg(&q__2, &y[j]);
+ q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
+ alpha->r * q__2.i + alpha->i * q__2.r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ i__2 = j;
+ q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ r_cnjg(&q__1, &q__2);
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ k = kk;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = k;
+ i__4 = k;
+ i__5 = i__;
+ q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
+ q__3.i = x[i__5].r * temp1.i + x[i__5].i *
+ temp1.r;
+ q__2.r = ap[i__4].r + q__3.r, q__2.i = ap[i__4].i +
+ q__3.i;
+ i__6 = i__;
+ q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
+ q__4.i = y[i__6].r * temp2.i + y[i__6].i *
+ temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+ ++k;
+/* L10: */
+ }
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ i__4 = j;
+ q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
+ q__2.i = x[i__4].r * temp1.i + x[i__4].i *
+ temp1.r;
+ i__5 = j;
+ q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
+ q__3.i = y[i__5].r * temp2.i + y[i__5].i *
+ temp2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ r__1 = ap[i__3].r + q__1.r;
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+ } else {
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ r__1 = ap[i__3].r;
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+ }
+ kk += j;
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ i__3 = jy;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f
+ || y[i__3].i != 0.f)) {
+ r_cnjg(&q__2, &y[jy]);
+ q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
+ alpha->r * q__2.i + alpha->i * q__2.r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ i__2 = jx;
+ q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ r_cnjg(&q__1, &q__2);
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ ix = kx;
+ iy = ky;
+ i__2 = kk + j - 2;
+ for (k = kk; k <= i__2; ++k) {
+ i__3 = k;
+ i__4 = k;
+ i__5 = ix;
+ q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
+ q__3.i = x[i__5].r * temp1.i + x[i__5].i *
+ temp1.r;
+ q__2.r = ap[i__4].r + q__3.r, q__2.i = ap[i__4].i +
+ q__3.i;
+ i__6 = iy;
+ q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
+ q__4.i = y[i__6].r * temp2.i + y[i__6].i *
+ temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L30: */
+ }
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ i__4 = jx;
+ q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
+ q__2.i = x[i__4].r * temp1.i + x[i__4].i *
+ temp1.r;
+ i__5 = jy;
+ q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
+ q__3.i = y[i__5].r * temp2.i + y[i__5].i *
+ temp2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ r__1 = ap[i__3].r + q__1.r;
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+ } else {
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ r__1 = ap[i__3].r;
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+ }
+ jx += *incx;
+ jy += *incy;
+ kk += j;
+/* L40: */
+ }
+ }
+ } else {
+
+/* Form A when lower triangle is stored in AP. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ i__3 = j;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f
+ || y[i__3].i != 0.f)) {
+ r_cnjg(&q__2, &y[j]);
+ q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
+ alpha->r * q__2.i + alpha->i * q__2.r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ i__2 = j;
+ q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ r_cnjg(&q__1, &q__2);
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ i__2 = kk;
+ i__3 = kk;
+ i__4 = j;
+ q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
+ q__2.i = x[i__4].r * temp1.i + x[i__4].i *
+ temp1.r;
+ i__5 = j;
+ q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
+ q__3.i = y[i__5].r * temp2.i + y[i__5].i *
+ temp2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ r__1 = ap[i__3].r + q__1.r;
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+ k = kk + 1;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = k;
+ i__4 = k;
+ i__5 = i__;
+ q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
+ q__3.i = x[i__5].r * temp1.i + x[i__5].i *
+ temp1.r;
+ q__2.r = ap[i__4].r + q__3.r, q__2.i = ap[i__4].i +
+ q__3.i;
+ i__6 = i__;
+ q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
+ q__4.i = y[i__6].r * temp2.i + y[i__6].i *
+ temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+ ++k;
+/* L50: */
+ }
+ } else {
+ i__2 = kk;
+ i__3 = kk;
+ r__1 = ap[i__3].r;
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+ }
+ kk = kk + *n - j + 1;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ i__3 = jy;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f || (y[i__3].r != 0.f
+ || y[i__3].i != 0.f)) {
+ r_cnjg(&q__2, &y[jy]);
+ q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
+ alpha->r * q__2.i + alpha->i * q__2.r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ i__2 = jx;
+ q__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ q__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ r_cnjg(&q__1, &q__2);
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ i__2 = kk;
+ i__3 = kk;
+ i__4 = jx;
+ q__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
+ q__2.i = x[i__4].r * temp1.i + x[i__4].i *
+ temp1.r;
+ i__5 = jy;
+ q__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
+ q__3.i = y[i__5].r * temp2.i + y[i__5].i *
+ temp2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ r__1 = ap[i__3].r + q__1.r;
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+ ix = jx;
+ iy = jy;
+ i__2 = kk + *n - j;
+ for (k = kk + 1; k <= i__2; ++k) {
+ ix += *incx;
+ iy += *incy;
+ i__3 = k;
+ i__4 = k;
+ i__5 = ix;
+ q__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
+ q__3.i = x[i__5].r * temp1.i + x[i__5].i *
+ temp1.r;
+ q__2.r = ap[i__4].r + q__3.r, q__2.i = ap[i__4].i +
+ q__3.i;
+ i__6 = iy;
+ q__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
+ q__4.i = y[i__6].r * temp2.i + y[i__6].i *
+ temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+/* L70: */
+ }
+ } else {
+ i__2 = kk;
+ i__3 = kk;
+ r__1 = ap[i__3].r;
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+ }
+ jx += *incx;
+ jy += *incy;
+ kk = kk + *n - j + 1;
+/* L80: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CHPR2 . */
+
+} /* chpr2_ */
diff --git a/BLAS/SRC/crotg.c b/BLAS/SRC/crotg.c
new file mode 100644
index 0000000..8edb25e
--- /dev/null
+++ b/BLAS/SRC/crotg.c
@@ -0,0 +1,72 @@
+/* crotg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int crotg_(complex *ca, complex *cb, real *c__, complex *s)
+{
+ /* System generated locals */
+ real r__1, r__2;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ double c_abs(complex *), sqrt(doublereal);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ real norm;
+ complex alpha;
+ real scale;
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CROTG determines a complex Givens rotation. */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ if (c_abs(ca) != 0.f) {
+ goto L10;
+ }
+ *c__ = 0.f;
+ s->r = 1.f, s->i = 0.f;
+ ca->r = cb->r, ca->i = cb->i;
+ goto L20;
+L10:
+ scale = c_abs(ca) + c_abs(cb);
+ q__1.r = ca->r / scale, q__1.i = ca->i / scale;
+/* Computing 2nd power */
+ r__1 = c_abs(&q__1);
+ q__2.r = cb->r / scale, q__2.i = cb->i / scale;
+/* Computing 2nd power */
+ r__2 = c_abs(&q__2);
+ norm = scale * sqrt(r__1 * r__1 + r__2 * r__2);
+ r__1 = c_abs(ca);
+ q__1.r = ca->r / r__1, q__1.i = ca->i / r__1;
+ alpha.r = q__1.r, alpha.i = q__1.i;
+ *c__ = c_abs(ca) / norm;
+ r_cnjg(&q__3, cb);
+ q__2.r = alpha.r * q__3.r - alpha.i * q__3.i, q__2.i = alpha.r * q__3.i +
+ alpha.i * q__3.r;
+ q__1.r = q__2.r / norm, q__1.i = q__2.i / norm;
+ s->r = q__1.r, s->i = q__1.i;
+ q__1.r = norm * alpha.r, q__1.i = norm * alpha.i;
+ ca->r = q__1.r, ca->i = q__1.i;
+L20:
+ return 0;
+} /* crotg_ */
diff --git a/BLAS/SRC/cscal.c b/BLAS/SRC/cscal.c
new file mode 100644
index 0000000..7c22710
--- /dev/null
+++ b/BLAS/SRC/cscal.c
@@ -0,0 +1,81 @@
+/* cscal.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cscal_(integer *n, complex *ca, complex *cx, integer *
+ incx)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, nincx;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* scales a vector by a constant. */
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 3/93 to return if incx .le. 0. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+ /* Parameter adjustments */
+ --cx;
+
+ /* Function Body */
+ if (*n <= 0 || *incx <= 0) {
+ return 0;
+ }
+ if (*incx == 1) {
+ goto L20;
+ }
+
+/* code for increment not equal to 1 */
+
+ nincx = *n * *incx;
+ i__1 = nincx;
+ i__2 = *incx;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = ca->r * cx[i__4].r - ca->i * cx[i__4].i, q__1.i = ca->r * cx[
+ i__4].i + ca->i * cx[i__4].r;
+ cx[i__3].r = q__1.r, cx[i__3].i = q__1.i;
+/* L10: */
+ }
+ return 0;
+
+/* code for increment equal to 1 */
+
+L20:
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__1 = i__;
+ i__3 = i__;
+ q__1.r = ca->r * cx[i__3].r - ca->i * cx[i__3].i, q__1.i = ca->r * cx[
+ i__3].i + ca->i * cx[i__3].r;
+ cx[i__1].r = q__1.r, cx[i__1].i = q__1.i;
+/* L30: */
+ }
+ return 0;
+} /* cscal_ */
diff --git a/BLAS/SRC/csrot.c b/BLAS/SRC/csrot.c
new file mode 100644
index 0000000..0010a2a
--- /dev/null
+++ b/BLAS/SRC/csrot.c
@@ -0,0 +1,153 @@
+/* csrot.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int csrot_(integer *n, complex *cx, integer *incx, complex *
+ cy, integer *incy, real *c__, real *s)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ complex q__1, q__2, q__3;
+
+ /* Local variables */
+ integer i__, ix, iy;
+ complex ctemp;
+
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Applies a plane rotation, where the cos and sin (c and s) are real */
+/* and the vectors cx and cy are complex. */
+/* jack dongarra, linpack, 3/11/78. */
+
+/* Arguments */
+/* ========== */
+
+/* N (input) INTEGER */
+/* On entry, N specifies the order of the vectors cx and cy. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* CX (input) COMPLEX array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array CX must contain the n */
+/* element vector cx. On exit, CX is overwritten by the updated */
+/* vector cx. */
+
+/* INCX (input) INTEGER */
+/* On entry, INCX specifies the increment for the elements of */
+/* CX. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* CY (input) COMPLEX array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array CY must contain the n */
+/* element vector cy. On exit, CY is overwritten by the updated */
+/* vector cy. */
+
+/* INCY (input) INTEGER */
+/* On entry, INCY specifies the increment for the elements of */
+/* CY. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* C (input) REAL */
+/* On entry, C specifies the cosine, cos. */
+/* Unchanged on exit. */
+
+/* S (input) REAL */
+/* On entry, S specifies the sine, sin. */
+/* Unchanged on exit. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --cy;
+ --cx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* code for unequal increments or equal increments not equal */
+/* to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ix;
+ q__2.r = *c__ * cx[i__2].r, q__2.i = *c__ * cx[i__2].i;
+ i__3 = iy;
+ q__3.r = *s * cy[i__3].r, q__3.i = *s * cy[i__3].i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__2 = iy;
+ i__3 = iy;
+ q__2.r = *c__ * cy[i__3].r, q__2.i = *c__ * cy[i__3].i;
+ i__4 = ix;
+ q__3.r = *s * cx[i__4].r, q__3.i = *s * cx[i__4].i;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ cy[i__2].r = q__1.r, cy[i__2].i = q__1.i;
+ i__2 = ix;
+ cx[i__2].r = ctemp.r, cx[i__2].i = ctemp.i;
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ return 0;
+
+/* code for both increments equal to 1 */
+
+L20:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ q__2.r = *c__ * cx[i__2].r, q__2.i = *c__ * cx[i__2].i;
+ i__3 = i__;
+ q__3.r = *s * cy[i__3].r, q__3.i = *s * cy[i__3].i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__2 = i__;
+ i__3 = i__;
+ q__2.r = *c__ * cy[i__3].r, q__2.i = *c__ * cy[i__3].i;
+ i__4 = i__;
+ q__3.r = *s * cx[i__4].r, q__3.i = *s * cx[i__4].i;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ cy[i__2].r = q__1.r, cy[i__2].i = q__1.i;
+ i__2 = i__;
+ cx[i__2].r = ctemp.r, cx[i__2].i = ctemp.i;
+/* L30: */
+ }
+ return 0;
+} /* csrot_ */
diff --git a/BLAS/SRC/csscal.c b/BLAS/SRC/csscal.c
new file mode 100644
index 0000000..f849d23
--- /dev/null
+++ b/BLAS/SRC/csscal.c
@@ -0,0 +1,88 @@
+/* csscal.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int csscal_(integer *n, real *sa, complex *cx, integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, nincx;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* scales a complex vector by a real constant. */
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 3/93 to return if incx .le. 0. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --cx;
+
+ /* Function Body */
+ if (*n <= 0 || *incx <= 0) {
+ return 0;
+ }
+ if (*incx == 1) {
+ goto L20;
+ }
+
+/* code for increment not equal to 1 */
+
+ nincx = *n * *incx;
+ i__1 = nincx;
+ i__2 = *incx;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ i__3 = i__;
+ i__4 = i__;
+ r__1 = *sa * cx[i__4].r;
+ r__2 = *sa * r_imag(&cx[i__]);
+ q__1.r = r__1, q__1.i = r__2;
+ cx[i__3].r = q__1.r, cx[i__3].i = q__1.i;
+/* L10: */
+ }
+ return 0;
+
+/* code for increment equal to 1 */
+
+L20:
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__1 = i__;
+ i__3 = i__;
+ r__1 = *sa * cx[i__3].r;
+ r__2 = *sa * r_imag(&cx[i__]);
+ q__1.r = r__1, q__1.i = r__2;
+ cx[i__1].r = q__1.r, cx[i__1].i = q__1.i;
+/* L30: */
+ }
+ return 0;
+} /* csscal_ */
diff --git a/BLAS/SRC/cswap.c b/BLAS/SRC/cswap.c
new file mode 100644
index 0000000..b007f86
--- /dev/null
+++ b/BLAS/SRC/cswap.c
@@ -0,0 +1,93 @@
+/* cswap.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cswap_(integer *n, complex *cx, integer *incx, complex *
+ cy, integer *incy)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, ix, iy;
+ complex ctemp;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* interchanges two vectors. */
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+ /* Parameter adjustments */
+ --cy;
+ --cx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* code for unequal increments or equal increments not equal */
+/* to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ix;
+ ctemp.r = cx[i__2].r, ctemp.i = cx[i__2].i;
+ i__2 = ix;
+ i__3 = iy;
+ cx[i__2].r = cy[i__3].r, cx[i__2].i = cy[i__3].i;
+ i__2 = iy;
+ cy[i__2].r = ctemp.r, cy[i__2].i = ctemp.i;
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ return 0;
+
+/* code for both increments equal to 1 */
+L20:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ ctemp.r = cx[i__2].r, ctemp.i = cx[i__2].i;
+ i__2 = i__;
+ i__3 = i__;
+ cx[i__2].r = cy[i__3].r, cx[i__2].i = cy[i__3].i;
+ i__2 = i__;
+ cy[i__2].r = ctemp.r, cy[i__2].i = ctemp.i;
+/* L30: */
+ }
+ return 0;
+} /* cswap_ */
diff --git a/BLAS/SRC/csymm.c b/BLAS/SRC/csymm.c
new file mode 100644
index 0000000..595b867
--- /dev/null
+++ b/BLAS/SRC/csymm.c
@@ -0,0 +1,495 @@
+/* csymm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int csymm_(char *side, char *uplo, integer *m, integer *n,
+ complex *alpha, complex *a, integer *lda, complex *b, integer *ldb,
+ complex *beta, complex *c__, integer *ldc)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6;
+ complex q__1, q__2, q__3, q__4, q__5;
+
+ /* Local variables */
+ integer i__, j, k, info;
+ complex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSYMM performs one of the matrix-matrix operations */
+
+/* C := alpha*A*B + beta*C, */
+
+/* or */
+
+/* C := alpha*B*A + beta*C, */
+
+/* where alpha and beta are scalars, A is a symmetric matrix and B and */
+/* C are m by n matrices. */
+
+/* Arguments */
+/* ========== */
+
+/* SIDE - CHARACTER*1. */
+/* On entry, SIDE specifies whether the symmetric matrix A */
+/* appears on the left or right in the operation as follows: */
+
+/* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, */
+
+/* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, */
+
+/* Unchanged on exit. */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the symmetric matrix A is to be */
+/* referenced as follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of the */
+/* symmetric matrix is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of the */
+/* symmetric matrix is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix C. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix C. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is */
+/* m when SIDE = 'L' or 'l' and is n otherwise. */
+/* Before entry with SIDE = 'L' or 'l', the m by m part of */
+/* the array A must contain the symmetric matrix, such that */
+/* when UPLO = 'U' or 'u', the leading m by m upper triangular */
+/* part of the array A must contain the upper triangular part */
+/* of the symmetric matrix and the strictly lower triangular */
+/* part of A is not referenced, and when UPLO = 'L' or 'l', */
+/* the leading m by m lower triangular part of the array A */
+/* must contain the lower triangular part of the symmetric */
+/* matrix and the strictly upper triangular part of A is not */
+/* referenced. */
+/* Before entry with SIDE = 'R' or 'r', the n by n part of */
+/* the array A must contain the symmetric matrix, such that */
+/* when UPLO = 'U' or 'u', the leading n by n upper triangular */
+/* part of the array A must contain the upper triangular part */
+/* of the symmetric matrix and the strictly lower triangular */
+/* part of A is not referenced, and when UPLO = 'L' or 'l', */
+/* the leading n by n lower triangular part of the array A */
+/* must contain the lower triangular part of the symmetric */
+/* matrix and the strictly upper triangular part of A is not */
+/* referenced. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When SIDE = 'L' or 'l' then */
+/* LDA must be at least max( 1, m ), otherwise LDA must be at */
+/* least max( 1, n ). */
+/* Unchanged on exit. */
+
+/* B - COMPLEX array of DIMENSION ( LDB, n ). */
+/* Before entry, the leading m by n part of the array B must */
+/* contain the matrix B. */
+/* Unchanged on exit. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. LDB must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then C need not be set on input. */
+/* Unchanged on exit. */
+
+/* C - COMPLEX array of DIMENSION ( LDC, n ). */
+/* Before entry, the leading m by n part of the array C must */
+/* contain the matrix C, except when beta is zero, in which */
+/* case C need not be set on entry. */
+/* On exit, the array C is overwritten by the m by n updated */
+/* matrix. */
+
+/* LDC - INTEGER. */
+/* On entry, LDC specifies the first dimension of C as declared */
+/* in the calling (sub) program. LDC must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Set NROWA as the number of rows of A. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ if (lsame_(side, "L")) {
+ nrowa = *m;
+ } else {
+ nrowa = *n;
+ }
+ upper = lsame_(uplo, "U");
+
+/* Test the input parameters. */
+
+ info = 0;
+ if (! lsame_(side, "L") && ! lsame_(side, "R")) {
+ info = 1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ info = 2;
+ } else if (*m < 0) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*lda < max(1,nrowa)) {
+ info = 7;
+ } else if (*ldb < max(1,*m)) {
+ info = 9;
+ } else if (*ldc < max(1,*m)) {
+ info = 12;
+ }
+ if (info != 0) {
+ xerbla_("CSYMM ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r
+ == 1.f && beta->i == 0.f)) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (alpha->r == 0.f && alpha->i == 0.f) {
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0.f, c__[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
+ q__1.i = beta->r * c__[i__4].i + beta->i * c__[
+ i__4].r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lsame_(side, "L")) {
+
+/* Form C := alpha*A*B + beta*C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
+ q__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3]
+ .r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__3 = i__ - 1;
+ for (k = 1; k <= i__3; ++k) {
+ i__4 = k + j * c_dim1;
+ i__5 = k + j * c_dim1;
+ i__6 = k + i__ * a_dim1;
+ q__2.r = temp1.r * a[i__6].r - temp1.i * a[i__6].i,
+ q__2.i = temp1.r * a[i__6].i + temp1.i * a[
+ i__6].r;
+ q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i +
+ q__2.i;
+ c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
+ i__4 = k + j * b_dim1;
+ i__5 = k + i__ * a_dim1;
+ q__2.r = b[i__4].r * a[i__5].r - b[i__4].i * a[i__5]
+ .i, q__2.i = b[i__4].r * a[i__5].i + b[i__4]
+ .i * a[i__5].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L50: */
+ }
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + i__ * a_dim1;
+ q__2.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i,
+ q__2.i = temp1.r * a[i__4].i + temp1.i * a[
+ i__4].r;
+ q__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ q__3.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, q__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ i__5 = i__ + i__ * a_dim1;
+ q__4.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ q__4.i = temp1.r * a[i__5].i + temp1.i * a[
+ i__5].r;
+ q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i;
+ q__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ q__5.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (i__ = *m; i__ >= 1; --i__) {
+ i__2 = i__ + j * b_dim1;
+ q__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2].i,
+ q__1.i = alpha->r * b[i__2].i + alpha->i * b[i__2]
+ .r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__2 = *m;
+ for (k = i__ + 1; k <= i__2; ++k) {
+ i__3 = k + j * c_dim1;
+ i__4 = k + j * c_dim1;
+ i__5 = k + i__ * a_dim1;
+ q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ q__2.i = temp1.r * a[i__5].i + temp1.i * a[
+ i__5].r;
+ q__1.r = c__[i__4].r + q__2.r, q__1.i = c__[i__4].i +
+ q__2.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ i__3 = k + j * b_dim1;
+ i__4 = k + i__ * a_dim1;
+ q__2.r = b[i__3].r * a[i__4].r - b[i__3].i * a[i__4]
+ .i, q__2.i = b[i__3].r * a[i__4].i + b[i__3]
+ .i * a[i__4].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L80: */
+ }
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__2 = i__ + j * c_dim1;
+ i__3 = i__ + i__ * a_dim1;
+ q__2.r = temp1.r * a[i__3].r - temp1.i * a[i__3].i,
+ q__2.i = temp1.r * a[i__3].i + temp1.i * a[
+ i__3].r;
+ q__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ q__3.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ } else {
+ i__2 = i__ + j * c_dim1;
+ i__3 = i__ + j * c_dim1;
+ q__3.r = beta->r * c__[i__3].r - beta->i * c__[i__3]
+ .i, q__3.i = beta->r * c__[i__3].i + beta->i *
+ c__[i__3].r;
+ i__4 = i__ + i__ * a_dim1;
+ q__4.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i,
+ q__4.i = temp1.r * a[i__4].i + temp1.i * a[
+ i__4].r;
+ q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i;
+ q__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ q__5.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+ }
+ } else {
+
+/* Form C := alpha*B*A + beta*C. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * a_dim1;
+ q__1.r = alpha->r * a[i__2].r - alpha->i * a[i__2].i, q__1.i =
+ alpha->r * a[i__2].i + alpha->i * a[i__2].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * b_dim1;
+ q__1.r = temp1.r * b[i__4].r - temp1.i * b[i__4].i,
+ q__1.i = temp1.r * b[i__4].i + temp1.i * b[i__4]
+ .r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L110: */
+ }
+ } else {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__2.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
+ q__2.i = beta->r * c__[i__4].i + beta->i * c__[
+ i__4].r;
+ i__5 = i__ + j * b_dim1;
+ q__3.r = temp1.r * b[i__5].r - temp1.i * b[i__5].i,
+ q__3.i = temp1.r * b[i__5].i + temp1.i * b[i__5]
+ .r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L120: */
+ }
+ }
+ i__2 = j - 1;
+ for (k = 1; k <= i__2; ++k) {
+ if (upper) {
+ i__3 = k + j * a_dim1;
+ q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
+ .r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ } else {
+ i__3 = j + k * a_dim1;
+ q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
+ .r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ }
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + k * b_dim1;
+ q__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i,
+ q__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6]
+ .r;
+ q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i +
+ q__2.i;
+ c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
+/* L130: */
+ }
+/* L140: */
+ }
+ i__2 = *n;
+ for (k = j + 1; k <= i__2; ++k) {
+ if (upper) {
+ i__3 = j + k * a_dim1;
+ q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
+ .r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ } else {
+ i__3 = k + j * a_dim1;
+ q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
+ .r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ }
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + k * b_dim1;
+ q__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i,
+ q__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6]
+ .r;
+ q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i +
+ q__2.i;
+ c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
+/* L150: */
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+ }
+
+ return 0;
+
+/* End of CSYMM . */
+
+} /* csymm_ */
diff --git a/BLAS/SRC/csyr2k.c b/BLAS/SRC/csyr2k.c
new file mode 100644
index 0000000..7828678
--- /dev/null
+++ b/BLAS/SRC/csyr2k.c
@@ -0,0 +1,537 @@
+/* csyr2k.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int csyr2k_(char *uplo, char *trans, integer *n, integer *k,
+ complex *alpha, complex *a, integer *lda, complex *b, integer *ldb,
+ complex *beta, complex *c__, integer *ldc)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6, i__7;
+ complex q__1, q__2, q__3, q__4, q__5;
+
+ /* Local variables */
+ integer i__, j, l, info;
+ complex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSYR2K performs one of the symmetric rank 2k operations */
+
+/* C := alpha*A*B' + alpha*B*A' + beta*C, */
+
+/* or */
+
+/* C := alpha*A'*B + alpha*B'*A + beta*C, */
+
+/* where alpha and beta are scalars, C is an n by n symmetric matrix */
+/* and A and B are n by k matrices in the first case and k by n */
+/* matrices in the second case. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array C is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of C */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of C */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + */
+/* beta*C. */
+
+/* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + */
+/* beta*C. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix C. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry with TRANS = 'N' or 'n', K specifies the number */
+/* of columns of the matrices A and B, and on entry with */
+/* TRANS = 'T' or 't', K specifies the number of rows of the */
+/* matrices A and B. K must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is */
+/* k when TRANS = 'N' or 'n', and is n otherwise. */
+/* Before entry with TRANS = 'N' or 'n', the leading n by k */
+/* part of the array A must contain the matrix A, otherwise */
+/* the leading k by n part of the array A must contain the */
+/* matrix A. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When TRANS = 'N' or 'n' */
+/* then LDA must be at least max( 1, n ), otherwise LDA must */
+/* be at least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is */
+/* k when TRANS = 'N' or 'n', and is n otherwise. */
+/* Before entry with TRANS = 'N' or 'n', the leading n by k */
+/* part of the array B must contain the matrix B, otherwise */
+/* the leading k by n part of the array B must contain the */
+/* matrix B. */
+/* Unchanged on exit. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. When TRANS = 'N' or 'n' */
+/* then LDB must be at least max( 1, n ), otherwise LDB must */
+/* be at least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX . */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+/* C - COMPLEX array of DIMENSION ( LDC, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array C must contain the upper */
+/* triangular part of the symmetric matrix and the strictly */
+/* lower triangular part of C is not referenced. On exit, the */
+/* upper triangular part of the array C is overwritten by the */
+/* upper triangular part of the updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array C must contain the lower */
+/* triangular part of the symmetric matrix and the strictly */
+/* upper triangular part of C is not referenced. On exit, the */
+/* lower triangular part of the array C is overwritten by the */
+/* lower triangular part of the updated matrix. */
+
+/* LDC - INTEGER. */
+/* On entry, LDC specifies the first dimension of C as declared */
+/* in the calling (sub) program. LDC must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ if (lsame_(trans, "N")) {
+ nrowa = *n;
+ } else {
+ nrowa = *k;
+ }
+ upper = lsame_(uplo, "U");
+
+ info = 0;
+ if (! upper && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T")) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*k < 0) {
+ info = 4;
+ } else if (*lda < max(1,nrowa)) {
+ info = 7;
+ } else if (*ldb < max(1,nrowa)) {
+ info = 9;
+ } else if (*ldc < max(1,*n)) {
+ info = 12;
+ }
+ if (info != 0) {
+ xerbla_("CSYR2K", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f || *k == 0) && (
+ beta->r == 1.f && beta->i == 0.f)) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (alpha->r == 0.f && alpha->i == 0.f) {
+ if (upper) {
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0.f, c__[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, q__1.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else {
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0.f, c__[i__3].i = 0.f;
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, q__1.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form C := alpha*A*B' + alpha*B*A' + C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0.f, c__[i__3].i = 0.f;
+/* L90: */
+ }
+ } else if (beta->r != 1.f || beta->i != 0.f) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, q__1.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L100: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = j + l * a_dim1;
+ i__4 = j + l * b_dim1;
+ if (a[i__3].r != 0.f || a[i__3].i != 0.f || (b[i__4].r !=
+ 0.f || b[i__4].i != 0.f)) {
+ i__3 = j + l * b_dim1;
+ q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
+ q__1.i = alpha->r * b[i__3].i + alpha->i * b[
+ i__3].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ i__3 = j + l * a_dim1;
+ q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ q__1.i = alpha->r * a[i__3].i + alpha->i * a[
+ i__3].r;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ i__3 = j;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + l * a_dim1;
+ q__3.r = a[i__6].r * temp1.r - a[i__6].i *
+ temp1.i, q__3.i = a[i__6].r * temp1.i + a[
+ i__6].i * temp1.r;
+ q__2.r = c__[i__5].r + q__3.r, q__2.i = c__[i__5]
+ .i + q__3.i;
+ i__7 = i__ + l * b_dim1;
+ q__4.r = b[i__7].r * temp2.r - b[i__7].i *
+ temp2.i, q__4.i = b[i__7].r * temp2.i + b[
+ i__7].i * temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i +
+ q__4.i;
+ c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
+/* L110: */
+ }
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0.f, c__[i__3].i = 0.f;
+/* L140: */
+ }
+ } else if (beta->r != 1.f || beta->i != 0.f) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, q__1.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L150: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = j + l * a_dim1;
+ i__4 = j + l * b_dim1;
+ if (a[i__3].r != 0.f || a[i__3].i != 0.f || (b[i__4].r !=
+ 0.f || b[i__4].i != 0.f)) {
+ i__3 = j + l * b_dim1;
+ q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
+ q__1.i = alpha->r * b[i__3].i + alpha->i * b[
+ i__3].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ i__3 = j + l * a_dim1;
+ q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ q__1.i = alpha->r * a[i__3].i + alpha->i * a[
+ i__3].r;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ i__3 = *n;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + l * a_dim1;
+ q__3.r = a[i__6].r * temp1.r - a[i__6].i *
+ temp1.i, q__3.i = a[i__6].r * temp1.i + a[
+ i__6].i * temp1.r;
+ q__2.r = c__[i__5].r + q__3.r, q__2.i = c__[i__5]
+ .i + q__3.i;
+ i__7 = i__ + l * b_dim1;
+ q__4.r = b[i__7].r * temp2.r - b[i__7].i *
+ temp2.i, q__4.i = b[i__7].r * temp2.i + b[
+ i__7].i * temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i +
+ q__4.i;
+ c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
+/* L160: */
+ }
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+ } else {
+
+/* Form C := alpha*A'*B + alpha*B'*A + C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp1.r = 0.f, temp1.i = 0.f;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ i__4 = l + i__ * a_dim1;
+ i__5 = l + j * b_dim1;
+ q__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5]
+ .i, q__2.i = a[i__4].r * b[i__5].i + a[i__4]
+ .i * b[i__5].r;
+ q__1.r = temp1.r + q__2.r, q__1.i = temp1.i + q__2.i;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ i__4 = l + i__ * b_dim1;
+ i__5 = l + j * a_dim1;
+ q__2.r = b[i__4].r * a[i__5].r - b[i__4].i * a[i__5]
+ .i, q__2.i = b[i__4].r * a[i__5].i + b[i__4]
+ .i * a[i__5].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L190: */
+ }
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__3 = i__ + j * c_dim1;
+ q__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ q__2.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ q__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ q__3.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, q__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ q__4.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ q__4.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i;
+ q__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ q__5.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ temp1.r = 0.f, temp1.i = 0.f;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ i__4 = l + i__ * a_dim1;
+ i__5 = l + j * b_dim1;
+ q__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5]
+ .i, q__2.i = a[i__4].r * b[i__5].i + a[i__4]
+ .i * b[i__5].r;
+ q__1.r = temp1.r + q__2.r, q__1.i = temp1.i + q__2.i;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ i__4 = l + i__ * b_dim1;
+ i__5 = l + j * a_dim1;
+ q__2.r = b[i__4].r * a[i__5].r - b[i__4].i * a[i__5]
+ .i, q__2.i = b[i__4].r * a[i__5].i + b[i__4]
+ .i * a[i__5].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L220: */
+ }
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__3 = i__ + j * c_dim1;
+ q__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ q__2.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ q__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ q__3.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, q__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ q__4.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ q__4.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i;
+ q__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ q__5.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CSYR2K. */
+
+} /* csyr2k_ */
diff --git a/BLAS/SRC/csyrk.c b/BLAS/SRC/csyrk.c
new file mode 100644
index 0000000..fdc8692
--- /dev/null
+++ b/BLAS/SRC/csyrk.c
@@ -0,0 +1,457 @@
+/* csyrk.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int csyrk_(char *uplo, char *trans, integer *n, integer *k,
+ complex *alpha, complex *a, integer *lda, complex *beta, complex *c__,
+ integer *ldc)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6;
+ complex q__1, q__2, q__3;
+
+ /* Local variables */
+ integer i__, j, l, info;
+ complex temp;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSYRK performs one of the symmetric rank k operations */
+
+/* C := alpha*A*A' + beta*C, */
+
+/* or */
+
+/* C := alpha*A'*A + beta*C, */
+
+/* where alpha and beta are scalars, C is an n by n symmetric matrix */
+/* and A is an n by k matrix in the first case and a k by n matrix */
+/* in the second case. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array C is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of C */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of C */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. */
+
+/* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix C. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry with TRANS = 'N' or 'n', K specifies the number */
+/* of columns of the matrix A, and on entry with */
+/* TRANS = 'T' or 't', K specifies the number of rows of the */
+/* matrix A. K must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is */
+/* k when TRANS = 'N' or 'n', and is n otherwise. */
+/* Before entry with TRANS = 'N' or 'n', the leading n by k */
+/* part of the array A must contain the matrix A, otherwise */
+/* the leading k by n part of the array A must contain the */
+/* matrix A. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When TRANS = 'N' or 'n' */
+/* then LDA must be at least max( 1, n ), otherwise LDA must */
+/* be at least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX . */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+/* C - COMPLEX array of DIMENSION ( LDC, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array C must contain the upper */
+/* triangular part of the symmetric matrix and the strictly */
+/* lower triangular part of C is not referenced. On exit, the */
+/* upper triangular part of the array C is overwritten by the */
+/* upper triangular part of the updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array C must contain the lower */
+/* triangular part of the symmetric matrix and the strictly */
+/* upper triangular part of C is not referenced. On exit, the */
+/* lower triangular part of the array C is overwritten by the */
+/* lower triangular part of the updated matrix. */
+
+/* LDC - INTEGER. */
+/* On entry, LDC specifies the first dimension of C as declared */
+/* in the calling (sub) program. LDC must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ if (lsame_(trans, "N")) {
+ nrowa = *n;
+ } else {
+ nrowa = *k;
+ }
+ upper = lsame_(uplo, "U");
+
+ info = 0;
+ if (! upper && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T")) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*k < 0) {
+ info = 4;
+ } else if (*lda < max(1,nrowa)) {
+ info = 7;
+ } else if (*ldc < max(1,*n)) {
+ info = 10;
+ }
+ if (info != 0) {
+ xerbla_("CSYRK ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || (alpha->r == 0.f && alpha->i == 0.f || *k == 0) && (
+ beta->r == 1.f && beta->i == 0.f)) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (alpha->r == 0.f && alpha->i == 0.f) {
+ if (upper) {
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0.f, c__[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, q__1.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else {
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0.f, c__[i__3].i = 0.f;
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, q__1.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form C := alpha*A*A' + beta*C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0.f, c__[i__3].i = 0.f;
+/* L90: */
+ }
+ } else if (beta->r != 1.f || beta->i != 0.f) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, q__1.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L100: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = j + l * a_dim1;
+ if (a[i__3].r != 0.f || a[i__3].i != 0.f) {
+ i__3 = j + l * a_dim1;
+ q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ q__1.i = alpha->r * a[i__3].i + alpha->i * a[
+ i__3].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__3 = j;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + l * a_dim1;
+ q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
+ q__2.i = temp.r * a[i__6].i + temp.i * a[
+ i__6].r;
+ q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5]
+ .i + q__2.i;
+ c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
+/* L110: */
+ }
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0.f, c__[i__3].i = 0.f;
+/* L140: */
+ }
+ } else if (beta->r != 1.f || beta->i != 0.f) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, q__1.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L150: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = j + l * a_dim1;
+ if (a[i__3].r != 0.f || a[i__3].i != 0.f) {
+ i__3 = j + l * a_dim1;
+ q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ q__1.i = alpha->r * a[i__3].i + alpha->i * a[
+ i__3].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__3 = *n;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + l * a_dim1;
+ q__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
+ q__2.i = temp.r * a[i__6].i + temp.i * a[
+ i__6].r;
+ q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5]
+ .i + q__2.i;
+ c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
+/* L160: */
+ }
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+ } else {
+
+/* Form C := alpha*A'*A + beta*C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp.r = 0.f, temp.i = 0.f;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ i__4 = l + i__ * a_dim1;
+ i__5 = l + j * a_dim1;
+ q__2.r = a[i__4].r * a[i__5].r - a[i__4].i * a[i__5]
+ .i, q__2.i = a[i__4].r * a[i__5].i + a[i__4]
+ .i * a[i__5].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L190: */
+ }
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__3 = i__ + j * c_dim1;
+ q__1.r = alpha->r * temp.r - alpha->i * temp.i,
+ q__1.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ q__2.r = alpha->r * temp.r - alpha->i * temp.i,
+ q__2.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ i__4 = i__ + j * c_dim1;
+ q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, q__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ temp.r = 0.f, temp.i = 0.f;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ i__4 = l + i__ * a_dim1;
+ i__5 = l + j * a_dim1;
+ q__2.r = a[i__4].r * a[i__5].r - a[i__4].i * a[i__5]
+ .i, q__2.i = a[i__4].r * a[i__5].i + a[i__4]
+ .i * a[i__5].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i + q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L220: */
+ }
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__3 = i__ + j * c_dim1;
+ q__1.r = alpha->r * temp.r - alpha->i * temp.i,
+ q__1.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ q__2.r = alpha->r * temp.r - alpha->i * temp.i,
+ q__2.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ i__4 = i__ + j * c_dim1;
+ q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, q__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CSYRK . */
+
+} /* csyrk_ */
diff --git a/BLAS/SRC/ctbmv.c b/BLAS/SRC/ctbmv.c
new file mode 100644
index 0000000..cbaf635
--- /dev/null
+++ b/BLAS/SRC/ctbmv.c
@@ -0,0 +1,641 @@
+/* ctbmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ctbmv_(char *uplo, char *trans, char *diag, integer *n,
+ integer *k, complex *a, integer *lda, complex *x, integer *incx)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, l, ix, jx, kx, info;
+ complex temp;
+ extern logical lsame_(char *, char *);
+ integer kplus1;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical noconj, nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTBMV performs one of the matrix-vector operations */
+
+/* x := A*x, or x := A'*x, or x := conjg( A' )*x, */
+
+/* where x is an n element vector and A is an n by n unit, or non-unit, */
+/* upper or lower triangular band matrix, with ( k + 1 ) diagonals. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' x := A*x. */
+
+/* TRANS = 'T' or 't' x := A'*x. */
+
+/* TRANS = 'C' or 'c' x := conjg( A' )*x. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry with UPLO = 'U' or 'u', K specifies the number of */
+/* super-diagonals of the matrix A. */
+/* On entry with UPLO = 'L' or 'l', K specifies the number of */
+/* sub-diagonals of the matrix A. */
+/* K must satisfy 0 .le. K. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
+/* by n part of the array A must contain the upper triangular */
+/* band part of the matrix of coefficients, supplied column by */
+/* column, with the leading diagonal of the matrix in row */
+/* ( k + 1 ) of the array, the first super-diagonal starting at */
+/* position 2 in row k, and so on. The top left k by k triangle */
+/* of the array A is not referenced. */
+/* The following program segment will transfer an upper */
+/* triangular band matrix from conventional full matrix storage */
+/* to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = K + 1 - J */
+/* DO 10, I = MAX( 1, J - K ), J */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
+/* by n part of the array A must contain the lower triangular */
+/* band part of the matrix of coefficients, supplied column by */
+/* column, with the leading diagonal of the matrix in row 1 of */
+/* the array, the first sub-diagonal starting at position 1 in */
+/* row 2, and so on. The bottom right k by k triangle of the */
+/* array A is not referenced. */
+/* The following program segment will transfer a lower */
+/* triangular band matrix from conventional full matrix storage */
+/* to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = 1 - J */
+/* DO 10, I = J, MIN( N, J + K ) */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Note that when DIAG = 'U' or 'u' the elements of the array A */
+/* corresponding to the diagonal elements of the matrix are not */
+/* referenced, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* ( k + 1 ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. On exit, X is overwritten with the */
+/* tranformed vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*k < 0) {
+ info = 5;
+ } else if (*lda < *k + 1) {
+ info = 7;
+ } else if (*incx == 0) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("CTBMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ noconj = lsame_(trans, "T");
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through A. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x := A*x. */
+
+ if (lsame_(uplo, "U")) {
+ kplus1 = *k + 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ i__2 = j;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__5 = l + i__ + j * a_dim1;
+ q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ q__2.i = temp.r * a[i__5].i + temp.i * a[
+ i__5].r;
+ q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i +
+ q__2.i;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+/* L10: */
+ }
+ if (nounit) {
+ i__4 = j;
+ i__2 = j;
+ i__3 = kplus1 + j * a_dim1;
+ q__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[
+ i__3].i, q__1.i = x[i__2].r * a[i__3].i +
+ x[i__2].i * a[i__3].r;
+ x[i__4].r = q__1.r, x[i__4].i = q__1.i;
+ }
+ }
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = jx;
+ if (x[i__4].r != 0.f || x[i__4].i != 0.f) {
+ i__4 = jx;
+ temp.r = x[i__4].r, temp.i = x[i__4].i;
+ ix = kx;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *k;
+ i__3 = j - 1;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ i__4 = ix;
+ i__2 = ix;
+ i__5 = l + i__ + j * a_dim1;
+ q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ q__2.i = temp.r * a[i__5].i + temp.i * a[
+ i__5].r;
+ q__1.r = x[i__2].r + q__2.r, q__1.i = x[i__2].i +
+ q__2.i;
+ x[i__4].r = q__1.r, x[i__4].i = q__1.i;
+ ix += *incx;
+/* L30: */
+ }
+ if (nounit) {
+ i__3 = jx;
+ i__4 = jx;
+ i__2 = kplus1 + j * a_dim1;
+ q__1.r = x[i__4].r * a[i__2].r - x[i__4].i * a[
+ i__2].i, q__1.i = x[i__4].r * a[i__2].i +
+ x[i__4].i * a[i__2].r;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ }
+ }
+ jx += *incx;
+ if (j > *k) {
+ kx += *incx;
+ }
+/* L40: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__1 = j;
+ if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
+ i__1 = j;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ l = 1 - j;
+/* Computing MIN */
+ i__1 = *n, i__3 = j + *k;
+ i__4 = j + 1;
+ for (i__ = min(i__1,i__3); i__ >= i__4; --i__) {
+ i__1 = i__;
+ i__3 = i__;
+ i__2 = l + i__ + j * a_dim1;
+ q__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
+ q__2.i = temp.r * a[i__2].i + temp.i * a[
+ i__2].r;
+ q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i +
+ q__2.i;
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+/* L50: */
+ }
+ if (nounit) {
+ i__4 = j;
+ i__1 = j;
+ i__3 = j * a_dim1 + 1;
+ q__1.r = x[i__1].r * a[i__3].r - x[i__1].i * a[
+ i__3].i, q__1.i = x[i__1].r * a[i__3].i +
+ x[i__1].i * a[i__3].r;
+ x[i__4].r = q__1.r, x[i__4].i = q__1.i;
+ }
+ }
+/* L60: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ i__4 = jx;
+ if (x[i__4].r != 0.f || x[i__4].i != 0.f) {
+ i__4 = jx;
+ temp.r = x[i__4].r, temp.i = x[i__4].i;
+ ix = kx;
+ l = 1 - j;
+/* Computing MIN */
+ i__4 = *n, i__1 = j + *k;
+ i__3 = j + 1;
+ for (i__ = min(i__4,i__1); i__ >= i__3; --i__) {
+ i__4 = ix;
+ i__1 = ix;
+ i__2 = l + i__ + j * a_dim1;
+ q__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
+ q__2.i = temp.r * a[i__2].i + temp.i * a[
+ i__2].r;
+ q__1.r = x[i__1].r + q__2.r, q__1.i = x[i__1].i +
+ q__2.i;
+ x[i__4].r = q__1.r, x[i__4].i = q__1.i;
+ ix -= *incx;
+/* L70: */
+ }
+ if (nounit) {
+ i__3 = jx;
+ i__4 = jx;
+ i__1 = j * a_dim1 + 1;
+ q__1.r = x[i__4].r * a[i__1].r - x[i__4].i * a[
+ i__1].i, q__1.i = x[i__4].r * a[i__1].i +
+ x[i__4].i * a[i__1].r;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ }
+ }
+ jx -= *incx;
+ if (*n - j >= *k) {
+ kx -= *incx;
+ }
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := A'*x or x := conjg( A' )*x. */
+
+ if (lsame_(uplo, "U")) {
+ kplus1 = *k + 1;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__3 = j;
+ temp.r = x[i__3].r, temp.i = x[i__3].i;
+ l = kplus1 - j;
+ if (noconj) {
+ if (nounit) {
+ i__3 = kplus1 + j * a_dim1;
+ q__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
+ q__1.i = temp.r * a[i__3].i + temp.i * a[
+ i__3].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+/* Computing MAX */
+ i__4 = 1, i__1 = j - *k;
+ i__3 = max(i__4,i__1);
+ for (i__ = j - 1; i__ >= i__3; --i__) {
+ i__4 = l + i__ + j * a_dim1;
+ i__1 = i__;
+ q__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[
+ i__1].i, q__2.i = a[i__4].r * x[i__1].i +
+ a[i__4].i * x[i__1].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L90: */
+ }
+ } else {
+ if (nounit) {
+ r_cnjg(&q__2, &a[kplus1 + j * a_dim1]);
+ q__1.r = temp.r * q__2.r - temp.i * q__2.i,
+ q__1.i = temp.r * q__2.i + temp.i *
+ q__2.r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+/* Computing MAX */
+ i__4 = 1, i__1 = j - *k;
+ i__3 = max(i__4,i__1);
+ for (i__ = j - 1; i__ >= i__3; --i__) {
+ r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
+ i__4 = i__;
+ q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
+ q__2.i = q__3.r * x[i__4].i + q__3.i * x[
+ i__4].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L100: */
+ }
+ }
+ i__3 = j;
+ x[i__3].r = temp.r, x[i__3].i = temp.i;
+/* L110: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ i__3 = jx;
+ temp.r = x[i__3].r, temp.i = x[i__3].i;
+ kx -= *incx;
+ ix = kx;
+ l = kplus1 - j;
+ if (noconj) {
+ if (nounit) {
+ i__3 = kplus1 + j * a_dim1;
+ q__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
+ q__1.i = temp.r * a[i__3].i + temp.i * a[
+ i__3].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+/* Computing MAX */
+ i__4 = 1, i__1 = j - *k;
+ i__3 = max(i__4,i__1);
+ for (i__ = j - 1; i__ >= i__3; --i__) {
+ i__4 = l + i__ + j * a_dim1;
+ i__1 = ix;
+ q__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[
+ i__1].i, q__2.i = a[i__4].r * x[i__1].i +
+ a[i__4].i * x[i__1].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix -= *incx;
+/* L120: */
+ }
+ } else {
+ if (nounit) {
+ r_cnjg(&q__2, &a[kplus1 + j * a_dim1]);
+ q__1.r = temp.r * q__2.r - temp.i * q__2.i,
+ q__1.i = temp.r * q__2.i + temp.i *
+ q__2.r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+/* Computing MAX */
+ i__4 = 1, i__1 = j - *k;
+ i__3 = max(i__4,i__1);
+ for (i__ = j - 1; i__ >= i__3; --i__) {
+ r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
+ i__4 = ix;
+ q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
+ q__2.i = q__3.r * x[i__4].i + q__3.i * x[
+ i__4].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix -= *incx;
+/* L130: */
+ }
+ }
+ i__3 = jx;
+ x[i__3].r = temp.r, x[i__3].i = temp.i;
+ jx -= *incx;
+/* L140: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ temp.r = x[i__4].r, temp.i = x[i__4].i;
+ l = 1 - j;
+ if (noconj) {
+ if (nounit) {
+ i__4 = j * a_dim1 + 1;
+ q__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
+ q__1.i = temp.r * a[i__4].i + temp.i * a[
+ i__4].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+/* Computing MIN */
+ i__1 = *n, i__2 = j + *k;
+ i__4 = min(i__1,i__2);
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ i__1 = l + i__ + j * a_dim1;
+ i__2 = i__;
+ q__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[
+ i__2].i, q__2.i = a[i__1].r * x[i__2].i +
+ a[i__1].i * x[i__2].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L150: */
+ }
+ } else {
+ if (nounit) {
+ r_cnjg(&q__2, &a[j * a_dim1 + 1]);
+ q__1.r = temp.r * q__2.r - temp.i * q__2.i,
+ q__1.i = temp.r * q__2.i + temp.i *
+ q__2.r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+/* Computing MIN */
+ i__1 = *n, i__2 = j + *k;
+ i__4 = min(i__1,i__2);
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
+ i__1 = i__;
+ q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i,
+ q__2.i = q__3.r * x[i__1].i + q__3.i * x[
+ i__1].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L160: */
+ }
+ }
+ i__4 = j;
+ x[i__4].r = temp.r, x[i__4].i = temp.i;
+/* L170: */
+ }
+ } else {
+ jx = kx;
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = jx;
+ temp.r = x[i__4].r, temp.i = x[i__4].i;
+ kx += *incx;
+ ix = kx;
+ l = 1 - j;
+ if (noconj) {
+ if (nounit) {
+ i__4 = j * a_dim1 + 1;
+ q__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
+ q__1.i = temp.r * a[i__4].i + temp.i * a[
+ i__4].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+/* Computing MIN */
+ i__1 = *n, i__2 = j + *k;
+ i__4 = min(i__1,i__2);
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ i__1 = l + i__ + j * a_dim1;
+ i__2 = ix;
+ q__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[
+ i__2].i, q__2.i = a[i__1].r * x[i__2].i +
+ a[i__1].i * x[i__2].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix += *incx;
+/* L180: */
+ }
+ } else {
+ if (nounit) {
+ r_cnjg(&q__2, &a[j * a_dim1 + 1]);
+ q__1.r = temp.r * q__2.r - temp.i * q__2.i,
+ q__1.i = temp.r * q__2.i + temp.i *
+ q__2.r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+/* Computing MIN */
+ i__1 = *n, i__2 = j + *k;
+ i__4 = min(i__1,i__2);
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
+ i__1 = ix;
+ q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i,
+ q__2.i = q__3.r * x[i__1].i + q__3.i * x[
+ i__1].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix += *incx;
+/* L190: */
+ }
+ }
+ i__4 = jx;
+ x[i__4].r = temp.r, x[i__4].i = temp.i;
+ jx += *incx;
+/* L200: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CTBMV . */
+
+} /* ctbmv_ */
diff --git a/BLAS/SRC/ctbsv.c b/BLAS/SRC/ctbsv.c
new file mode 100644
index 0000000..0f47dfb
--- /dev/null
+++ b/BLAS/SRC/ctbsv.c
@@ -0,0 +1,609 @@
+/* ctbsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ctbsv_(char *uplo, char *trans, char *diag, integer *n,
+ integer *k, complex *a, integer *lda, complex *x, integer *incx)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, l, ix, jx, kx, info;
+ complex temp;
+ extern logical lsame_(char *, char *);
+ integer kplus1;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical noconj, nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTBSV solves one of the systems of equations */
+
+/* A*x = b, or A'*x = b, or conjg( A' )*x = b, */
+
+/* where b and x are n element vectors and A is an n by n unit, or */
+/* non-unit, upper or lower triangular band matrix, with ( k + 1 ) */
+/* diagonals. */
+
+/* No test for singularity or near-singularity is included in this */
+/* routine. Such tests must be performed before calling this routine. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the equations to be solved as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' A*x = b. */
+
+/* TRANS = 'T' or 't' A'*x = b. */
+
+/* TRANS = 'C' or 'c' conjg( A' )*x = b. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry with UPLO = 'U' or 'u', K specifies the number of */
+/* super-diagonals of the matrix A. */
+/* On entry with UPLO = 'L' or 'l', K specifies the number of */
+/* sub-diagonals of the matrix A. */
+/* K must satisfy 0 .le. K. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
+/* by n part of the array A must contain the upper triangular */
+/* band part of the matrix of coefficients, supplied column by */
+/* column, with the leading diagonal of the matrix in row */
+/* ( k + 1 ) of the array, the first super-diagonal starting at */
+/* position 2 in row k, and so on. The top left k by k triangle */
+/* of the array A is not referenced. */
+/* The following program segment will transfer an upper */
+/* triangular band matrix from conventional full matrix storage */
+/* to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = K + 1 - J */
+/* DO 10, I = MAX( 1, J - K ), J */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
+/* by n part of the array A must contain the lower triangular */
+/* band part of the matrix of coefficients, supplied column by */
+/* column, with the leading diagonal of the matrix in row 1 of */
+/* the array, the first sub-diagonal starting at position 1 in */
+/* row 2, and so on. The bottom right k by k triangle of the */
+/* array A is not referenced. */
+/* The following program segment will transfer a lower */
+/* triangular band matrix from conventional full matrix storage */
+/* to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = 1 - J */
+/* DO 10, I = J, MIN( N, J + K ) */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Note that when DIAG = 'U' or 'u' the elements of the array A */
+/* corresponding to the diagonal elements of the matrix are not */
+/* referenced, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* ( k + 1 ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element right-hand side vector b. On exit, X is overwritten */
+/* with the solution vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*k < 0) {
+ info = 5;
+ } else if (*lda < *k + 1) {
+ info = 7;
+ } else if (*incx == 0) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("CTBSV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ noconj = lsame_(trans, "T");
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed by sequentially with one pass through A. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x := inv( A )*x. */
+
+ if (lsame_(uplo, "U")) {
+ kplus1 = *k + 1;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__1 = j;
+ if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
+ l = kplus1 - j;
+ if (nounit) {
+ i__1 = j;
+ c_div(&q__1, &x[j], &a[kplus1 + j * a_dim1]);
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ }
+ i__1 = j;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__1 = max(i__2,i__3);
+ for (i__ = j - 1; i__ >= i__1; --i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = l + i__ + j * a_dim1;
+ q__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
+ q__2.i = temp.r * a[i__4].i + temp.i * a[
+ i__4].r;
+ q__1.r = x[i__3].r - q__2.r, q__1.i = x[i__3].i -
+ q__2.i;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+/* L10: */
+ }
+ }
+/* L20: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ kx -= *incx;
+ i__1 = jx;
+ if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
+ ix = kx;
+ l = kplus1 - j;
+ if (nounit) {
+ i__1 = jx;
+ c_div(&q__1, &x[jx], &a[kplus1 + j * a_dim1]);
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ }
+ i__1 = jx;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__1 = max(i__2,i__3);
+ for (i__ = j - 1; i__ >= i__1; --i__) {
+ i__2 = ix;
+ i__3 = ix;
+ i__4 = l + i__ + j * a_dim1;
+ q__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
+ q__2.i = temp.r * a[i__4].i + temp.i * a[
+ i__4].r;
+ q__1.r = x[i__3].r - q__2.r, q__1.i = x[i__3].i -
+ q__2.i;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ ix -= *incx;
+/* L30: */
+ }
+ }
+ jx -= *incx;
+/* L40: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ l = 1 - j;
+ if (nounit) {
+ i__2 = j;
+ c_div(&q__1, &x[j], &a[j * a_dim1 + 1]);
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ }
+ i__2 = j;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+/* Computing MIN */
+ i__3 = *n, i__4 = j + *k;
+ i__2 = min(i__3,i__4);
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = l + i__ + j * a_dim1;
+ q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ q__2.i = temp.r * a[i__5].i + temp.i * a[
+ i__5].r;
+ q__1.r = x[i__4].r - q__2.r, q__1.i = x[i__4].i -
+ q__2.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ kx += *incx;
+ i__2 = jx;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ ix = kx;
+ l = 1 - j;
+ if (nounit) {
+ i__2 = jx;
+ c_div(&q__1, &x[jx], &a[j * a_dim1 + 1]);
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ }
+ i__2 = jx;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+/* Computing MIN */
+ i__3 = *n, i__4 = j + *k;
+ i__2 = min(i__3,i__4);
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = ix;
+ i__4 = ix;
+ i__5 = l + i__ + j * a_dim1;
+ q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ q__2.i = temp.r * a[i__5].i + temp.i * a[
+ i__5].r;
+ q__1.r = x[i__4].r - q__2.r, q__1.i = x[i__4].i -
+ q__2.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ ix += *incx;
+/* L70: */
+ }
+ }
+ jx += *incx;
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := inv( A' )*x or x := inv( conjg( A') )*x. */
+
+ if (lsame_(uplo, "U")) {
+ kplus1 = *k + 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ l = kplus1 - j;
+ if (noconj) {
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ i__2 = l + i__ + j * a_dim1;
+ i__3 = i__;
+ q__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[
+ i__3].i, q__2.i = a[i__2].r * x[i__3].i +
+ a[i__2].i * x[i__3].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L90: */
+ }
+ if (nounit) {
+ c_div(&q__1, &temp, &a[kplus1 + j * a_dim1]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ } else {
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *k;
+ i__3 = j - 1;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
+ i__4 = i__;
+ q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
+ q__2.i = q__3.r * x[i__4].i + q__3.i * x[
+ i__4].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L100: */
+ }
+ if (nounit) {
+ r_cnjg(&q__2, &a[kplus1 + j * a_dim1]);
+ c_div(&q__1, &temp, &q__2);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ }
+ i__3 = j;
+ x[i__3].r = temp.r, x[i__3].i = temp.i;
+/* L110: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = jx;
+ temp.r = x[i__3].r, temp.i = x[i__3].i;
+ ix = kx;
+ l = kplus1 - j;
+ if (noconj) {
+/* Computing MAX */
+ i__3 = 1, i__4 = j - *k;
+ i__2 = j - 1;
+ for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) {
+ i__3 = l + i__ + j * a_dim1;
+ i__4 = ix;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
+ i__4].i, q__2.i = a[i__3].r * x[i__4].i +
+ a[i__3].i * x[i__4].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix += *incx;
+/* L120: */
+ }
+ if (nounit) {
+ c_div(&q__1, &temp, &a[kplus1 + j * a_dim1]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ } else {
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
+ i__2 = ix;
+ q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i,
+ q__2.i = q__3.r * x[i__2].i + q__3.i * x[
+ i__2].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix += *incx;
+/* L130: */
+ }
+ if (nounit) {
+ r_cnjg(&q__2, &a[kplus1 + j * a_dim1]);
+ c_div(&q__1, &temp, &q__2);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ }
+ i__4 = jx;
+ x[i__4].r = temp.r, x[i__4].i = temp.i;
+ jx += *incx;
+ if (j > *k) {
+ kx += *incx;
+ }
+/* L140: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__1 = j;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ l = 1 - j;
+ if (noconj) {
+/* Computing MIN */
+ i__1 = *n, i__4 = j + *k;
+ i__2 = j + 1;
+ for (i__ = min(i__1,i__4); i__ >= i__2; --i__) {
+ i__1 = l + i__ + j * a_dim1;
+ i__4 = i__;
+ q__2.r = a[i__1].r * x[i__4].r - a[i__1].i * x[
+ i__4].i, q__2.i = a[i__1].r * x[i__4].i +
+ a[i__1].i * x[i__4].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L150: */
+ }
+ if (nounit) {
+ c_div(&q__1, &temp, &a[j * a_dim1 + 1]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ } else {
+/* Computing MIN */
+ i__2 = *n, i__1 = j + *k;
+ i__4 = j + 1;
+ for (i__ = min(i__2,i__1); i__ >= i__4; --i__) {
+ r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
+ i__2 = i__;
+ q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i,
+ q__2.i = q__3.r * x[i__2].i + q__3.i * x[
+ i__2].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L160: */
+ }
+ if (nounit) {
+ r_cnjg(&q__2, &a[j * a_dim1 + 1]);
+ c_div(&q__1, &temp, &q__2);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ }
+ i__4 = j;
+ x[i__4].r = temp.r, x[i__4].i = temp.i;
+/* L170: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ i__4 = jx;
+ temp.r = x[i__4].r, temp.i = x[i__4].i;
+ ix = kx;
+ l = 1 - j;
+ if (noconj) {
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__1 = j + 1;
+ for (i__ = min(i__4,i__2); i__ >= i__1; --i__) {
+ i__4 = l + i__ + j * a_dim1;
+ i__2 = ix;
+ q__2.r = a[i__4].r * x[i__2].r - a[i__4].i * x[
+ i__2].i, q__2.i = a[i__4].r * x[i__2].i +
+ a[i__4].i * x[i__2].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix -= *incx;
+/* L180: */
+ }
+ if (nounit) {
+ c_div(&q__1, &temp, &a[j * a_dim1 + 1]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ } else {
+/* Computing MIN */
+ i__1 = *n, i__4 = j + *k;
+ i__2 = j + 1;
+ for (i__ = min(i__1,i__4); i__ >= i__2; --i__) {
+ r_cnjg(&q__3, &a[l + i__ + j * a_dim1]);
+ i__1 = ix;
+ q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i,
+ q__2.i = q__3.r * x[i__1].i + q__3.i * x[
+ i__1].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix -= *incx;
+/* L190: */
+ }
+ if (nounit) {
+ r_cnjg(&q__2, &a[j * a_dim1 + 1]);
+ c_div(&q__1, &temp, &q__2);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ }
+ i__2 = jx;
+ x[i__2].r = temp.r, x[i__2].i = temp.i;
+ jx -= *incx;
+ if (*n - j >= *k) {
+ kx -= *incx;
+ }
+/* L200: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CTBSV . */
+
+} /* ctbsv_ */
diff --git a/BLAS/SRC/ctpmv.c b/BLAS/SRC/ctpmv.c
new file mode 100644
index 0000000..1a28e95
--- /dev/null
+++ b/BLAS/SRC/ctpmv.c
@@ -0,0 +1,571 @@
+/* ctpmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ctpmv_(char *uplo, char *trans, char *diag, integer *n,
+ complex *ap, complex *x, integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, jx, kx, info;
+ complex temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical noconj, nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTPMV performs one of the matrix-vector operations */
+
+/* x := A*x, or x := A'*x, or x := conjg( A' )*x, */
+
+/* where x is an n element vector and A is an n by n unit, or non-unit, */
+/* upper or lower triangular matrix, supplied in packed form. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' x := A*x. */
+
+/* TRANS = 'T' or 't' x := A'*x. */
+
+/* TRANS = 'C' or 'c' x := conjg( A' )*x. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* AP - COMPLEX array of DIMENSION at least */
+/* ( ( n*( n + 1 ) )/2 ). */
+/* Before entry with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular matrix packed sequentially, */
+/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
+/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */
+/* respectively, and so on. */
+/* Before entry with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular matrix packed sequentially, */
+/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
+/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */
+/* respectively, and so on. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* X - COMPLEX array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. On exit, X is overwritten with the */
+/* tranformed vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ --ap;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*incx == 0) {
+ info = 7;
+ }
+ if (info != 0) {
+ xerbla_("CTPMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ noconj = lsame_(trans, "T");
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of AP are */
+/* accessed sequentially with one pass through AP. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x:= A*x. */
+
+ if (lsame_(uplo, "U")) {
+ kk = 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ i__2 = j;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ k = kk;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = k;
+ q__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5]
+ .i, q__2.i = temp.r * ap[i__5].i + temp.i
+ * ap[i__5].r;
+ q__1.r = x[i__4].r + q__2.r, q__1.i = x[i__4].i +
+ q__2.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ ++k;
+/* L10: */
+ }
+ if (nounit) {
+ i__2 = j;
+ i__3 = j;
+ i__4 = kk + j - 1;
+ q__1.r = x[i__3].r * ap[i__4].r - x[i__3].i * ap[
+ i__4].i, q__1.i = x[i__3].r * ap[i__4].i
+ + x[i__3].i * ap[i__4].r;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ }
+ }
+ kk += j;
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ i__2 = jx;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ ix = kx;
+ i__2 = kk + j - 2;
+ for (k = kk; k <= i__2; ++k) {
+ i__3 = ix;
+ i__4 = ix;
+ i__5 = k;
+ q__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5]
+ .i, q__2.i = temp.r * ap[i__5].i + temp.i
+ * ap[i__5].r;
+ q__1.r = x[i__4].r + q__2.r, q__1.i = x[i__4].i +
+ q__2.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ ix += *incx;
+/* L30: */
+ }
+ if (nounit) {
+ i__2 = jx;
+ i__3 = jx;
+ i__4 = kk + j - 1;
+ q__1.r = x[i__3].r * ap[i__4].r - x[i__3].i * ap[
+ i__4].i, q__1.i = x[i__3].r * ap[i__4].i
+ + x[i__3].i * ap[i__4].r;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ }
+ }
+ jx += *incx;
+ kk += j;
+/* L40: */
+ }
+ }
+ } else {
+ kk = *n * (*n + 1) / 2;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__1 = j;
+ if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
+ i__1 = j;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ k = kk;
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = k;
+ q__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4]
+ .i, q__2.i = temp.r * ap[i__4].i + temp.i
+ * ap[i__4].r;
+ q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i +
+ q__2.i;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ --k;
+/* L50: */
+ }
+ if (nounit) {
+ i__1 = j;
+ i__2 = j;
+ i__3 = kk - *n + j;
+ q__1.r = x[i__2].r * ap[i__3].r - x[i__2].i * ap[
+ i__3].i, q__1.i = x[i__2].r * ap[i__3].i
+ + x[i__2].i * ap[i__3].r;
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ }
+ }
+ kk -= *n - j + 1;
+/* L60: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ i__1 = jx;
+ if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
+ i__1 = jx;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ ix = kx;
+ i__1 = kk - (*n - (j + 1));
+ for (k = kk; k >= i__1; --k) {
+ i__2 = ix;
+ i__3 = ix;
+ i__4 = k;
+ q__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4]
+ .i, q__2.i = temp.r * ap[i__4].i + temp.i
+ * ap[i__4].r;
+ q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i +
+ q__2.i;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ ix -= *incx;
+/* L70: */
+ }
+ if (nounit) {
+ i__1 = jx;
+ i__2 = jx;
+ i__3 = kk - *n + j;
+ q__1.r = x[i__2].r * ap[i__3].r - x[i__2].i * ap[
+ i__3].i, q__1.i = x[i__2].r * ap[i__3].i
+ + x[i__2].i * ap[i__3].r;
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ }
+ }
+ jx -= *incx;
+ kk -= *n - j + 1;
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := A'*x or x := conjg( A' )*x. */
+
+ if (lsame_(uplo, "U")) {
+ kk = *n * (*n + 1) / 2;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__1 = j;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ k = kk - 1;
+ if (noconj) {
+ if (nounit) {
+ i__1 = kk;
+ q__1.r = temp.r * ap[i__1].r - temp.i * ap[i__1]
+ .i, q__1.i = temp.r * ap[i__1].i + temp.i
+ * ap[i__1].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ i__1 = k;
+ i__2 = i__;
+ q__2.r = ap[i__1].r * x[i__2].r - ap[i__1].i * x[
+ i__2].i, q__2.i = ap[i__1].r * x[i__2].i
+ + ap[i__1].i * x[i__2].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ --k;
+/* L90: */
+ }
+ } else {
+ if (nounit) {
+ r_cnjg(&q__2, &ap[kk]);
+ q__1.r = temp.r * q__2.r - temp.i * q__2.i,
+ q__1.i = temp.r * q__2.i + temp.i *
+ q__2.r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ r_cnjg(&q__3, &ap[k]);
+ i__1 = i__;
+ q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i,
+ q__2.i = q__3.r * x[i__1].i + q__3.i * x[
+ i__1].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ --k;
+/* L100: */
+ }
+ }
+ i__1 = j;
+ x[i__1].r = temp.r, x[i__1].i = temp.i;
+ kk -= j;
+/* L110: */
+ }
+ } else {
+ jx = kx + (*n - 1) * *incx;
+ for (j = *n; j >= 1; --j) {
+ i__1 = jx;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ ix = jx;
+ if (noconj) {
+ if (nounit) {
+ i__1 = kk;
+ q__1.r = temp.r * ap[i__1].r - temp.i * ap[i__1]
+ .i, q__1.i = temp.r * ap[i__1].i + temp.i
+ * ap[i__1].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ i__1 = kk - j + 1;
+ for (k = kk - 1; k >= i__1; --k) {
+ ix -= *incx;
+ i__2 = k;
+ i__3 = ix;
+ q__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[
+ i__3].i, q__2.i = ap[i__2].r * x[i__3].i
+ + ap[i__2].i * x[i__3].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L120: */
+ }
+ } else {
+ if (nounit) {
+ r_cnjg(&q__2, &ap[kk]);
+ q__1.r = temp.r * q__2.r - temp.i * q__2.i,
+ q__1.i = temp.r * q__2.i + temp.i *
+ q__2.r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ i__1 = kk - j + 1;
+ for (k = kk - 1; k >= i__1; --k) {
+ ix -= *incx;
+ r_cnjg(&q__3, &ap[k]);
+ i__2 = ix;
+ q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i,
+ q__2.i = q__3.r * x[i__2].i + q__3.i * x[
+ i__2].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L130: */
+ }
+ }
+ i__1 = jx;
+ x[i__1].r = temp.r, x[i__1].i = temp.i;
+ jx -= *incx;
+ kk -= j;
+/* L140: */
+ }
+ }
+ } else {
+ kk = 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ k = kk + 1;
+ if (noconj) {
+ if (nounit) {
+ i__2 = kk;
+ q__1.r = temp.r * ap[i__2].r - temp.i * ap[i__2]
+ .i, q__1.i = temp.r * ap[i__2].i + temp.i
+ * ap[i__2].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = k;
+ i__4 = i__;
+ q__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[
+ i__4].i, q__2.i = ap[i__3].r * x[i__4].i
+ + ap[i__3].i * x[i__4].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ++k;
+/* L150: */
+ }
+ } else {
+ if (nounit) {
+ r_cnjg(&q__2, &ap[kk]);
+ q__1.r = temp.r * q__2.r - temp.i * q__2.i,
+ q__1.i = temp.r * q__2.i + temp.i *
+ q__2.r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ r_cnjg(&q__3, &ap[k]);
+ i__3 = i__;
+ q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
+ q__2.i = q__3.r * x[i__3].i + q__3.i * x[
+ i__3].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ++k;
+/* L160: */
+ }
+ }
+ i__2 = j;
+ x[i__2].r = temp.r, x[i__2].i = temp.i;
+ kk += *n - j + 1;
+/* L170: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ ix = jx;
+ if (noconj) {
+ if (nounit) {
+ i__2 = kk;
+ q__1.r = temp.r * ap[i__2].r - temp.i * ap[i__2]
+ .i, q__1.i = temp.r * ap[i__2].i + temp.i
+ * ap[i__2].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ i__2 = kk + *n - j;
+ for (k = kk + 1; k <= i__2; ++k) {
+ ix += *incx;
+ i__3 = k;
+ i__4 = ix;
+ q__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[
+ i__4].i, q__2.i = ap[i__3].r * x[i__4].i
+ + ap[i__3].i * x[i__4].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L180: */
+ }
+ } else {
+ if (nounit) {
+ r_cnjg(&q__2, &ap[kk]);
+ q__1.r = temp.r * q__2.r - temp.i * q__2.i,
+ q__1.i = temp.r * q__2.i + temp.i *
+ q__2.r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ i__2 = kk + *n - j;
+ for (k = kk + 1; k <= i__2; ++k) {
+ ix += *incx;
+ r_cnjg(&q__3, &ap[k]);
+ i__3 = ix;
+ q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
+ q__2.i = q__3.r * x[i__3].i + q__3.i * x[
+ i__3].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L190: */
+ }
+ }
+ i__2 = jx;
+ x[i__2].r = temp.r, x[i__2].i = temp.i;
+ jx += *incx;
+ kk += *n - j + 1;
+/* L200: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CTPMV . */
+
+} /* ctpmv_ */
diff --git a/BLAS/SRC/ctpsv.c b/BLAS/SRC/ctpsv.c
new file mode 100644
index 0000000..2e810f6
--- /dev/null
+++ b/BLAS/SRC/ctpsv.c
@@ -0,0 +1,539 @@
+/* ctpsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ctpsv_(char *uplo, char *trans, char *diag, integer *n,
+ complex *ap, complex *x, integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, jx, kx, info;
+ complex temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical noconj, nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTPSV solves one of the systems of equations */
+
+/* A*x = b, or A'*x = b, or conjg( A' )*x = b, */
+
+/* where b and x are n element vectors and A is an n by n unit, or */
+/* non-unit, upper or lower triangular matrix, supplied in packed form. */
+
+/* No test for singularity or near-singularity is included in this */
+/* routine. Such tests must be performed before calling this routine. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the equations to be solved as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' A*x = b. */
+
+/* TRANS = 'T' or 't' A'*x = b. */
+
+/* TRANS = 'C' or 'c' conjg( A' )*x = b. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* AP - COMPLEX array of DIMENSION at least */
+/* ( ( n*( n + 1 ) )/2 ). */
+/* Before entry with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular matrix packed sequentially, */
+/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
+/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */
+/* respectively, and so on. */
+/* Before entry with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular matrix packed sequentially, */
+/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
+/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */
+/* respectively, and so on. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* X - COMPLEX array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element right-hand side vector b. On exit, X is overwritten */
+/* with the solution vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ --ap;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*incx == 0) {
+ info = 7;
+ }
+ if (info != 0) {
+ xerbla_("CTPSV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ noconj = lsame_(trans, "T");
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of AP are */
+/* accessed sequentially with one pass through AP. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x := inv( A )*x. */
+
+ if (lsame_(uplo, "U")) {
+ kk = *n * (*n + 1) / 2;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__1 = j;
+ if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
+ if (nounit) {
+ i__1 = j;
+ c_div(&q__1, &x[j], &ap[kk]);
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ }
+ i__1 = j;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ k = kk - 1;
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ i__1 = i__;
+ i__2 = i__;
+ i__3 = k;
+ q__2.r = temp.r * ap[i__3].r - temp.i * ap[i__3]
+ .i, q__2.i = temp.r * ap[i__3].i + temp.i
+ * ap[i__3].r;
+ q__1.r = x[i__2].r - q__2.r, q__1.i = x[i__2].i -
+ q__2.i;
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ --k;
+/* L10: */
+ }
+ }
+ kk -= j;
+/* L20: */
+ }
+ } else {
+ jx = kx + (*n - 1) * *incx;
+ for (j = *n; j >= 1; --j) {
+ i__1 = jx;
+ if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
+ if (nounit) {
+ i__1 = jx;
+ c_div(&q__1, &x[jx], &ap[kk]);
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ }
+ i__1 = jx;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ ix = jx;
+ i__1 = kk - j + 1;
+ for (k = kk - 1; k >= i__1; --k) {
+ ix -= *incx;
+ i__2 = ix;
+ i__3 = ix;
+ i__4 = k;
+ q__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4]
+ .i, q__2.i = temp.r * ap[i__4].i + temp.i
+ * ap[i__4].r;
+ q__1.r = x[i__3].r - q__2.r, q__1.i = x[i__3].i -
+ q__2.i;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+/* L30: */
+ }
+ }
+ jx -= *incx;
+ kk -= j;
+/* L40: */
+ }
+ }
+ } else {
+ kk = 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ if (nounit) {
+ i__2 = j;
+ c_div(&q__1, &x[j], &ap[kk]);
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ }
+ i__2 = j;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ k = kk + 1;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = k;
+ q__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5]
+ .i, q__2.i = temp.r * ap[i__5].i + temp.i
+ * ap[i__5].r;
+ q__1.r = x[i__4].r - q__2.r, q__1.i = x[i__4].i -
+ q__2.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ ++k;
+/* L50: */
+ }
+ }
+ kk += *n - j + 1;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ if (nounit) {
+ i__2 = jx;
+ c_div(&q__1, &x[jx], &ap[kk]);
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ }
+ i__2 = jx;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ ix = jx;
+ i__2 = kk + *n - j;
+ for (k = kk + 1; k <= i__2; ++k) {
+ ix += *incx;
+ i__3 = ix;
+ i__4 = ix;
+ i__5 = k;
+ q__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5]
+ .i, q__2.i = temp.r * ap[i__5].i + temp.i
+ * ap[i__5].r;
+ q__1.r = x[i__4].r - q__2.r, q__1.i = x[i__4].i -
+ q__2.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+/* L70: */
+ }
+ }
+ jx += *incx;
+ kk += *n - j + 1;
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. */
+
+ if (lsame_(uplo, "U")) {
+ kk = 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ k = kk;
+ if (noconj) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = k;
+ i__4 = i__;
+ q__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[
+ i__4].i, q__2.i = ap[i__3].r * x[i__4].i
+ + ap[i__3].i * x[i__4].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ++k;
+/* L90: */
+ }
+ if (nounit) {
+ c_div(&q__1, &temp, &ap[kk + j - 1]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ } else {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ r_cnjg(&q__3, &ap[k]);
+ i__3 = i__;
+ q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
+ q__2.i = q__3.r * x[i__3].i + q__3.i * x[
+ i__3].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ++k;
+/* L100: */
+ }
+ if (nounit) {
+ r_cnjg(&q__2, &ap[kk + j - 1]);
+ c_div(&q__1, &temp, &q__2);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ }
+ i__2 = j;
+ x[i__2].r = temp.r, x[i__2].i = temp.i;
+ kk += j;
+/* L110: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ ix = kx;
+ if (noconj) {
+ i__2 = kk + j - 2;
+ for (k = kk; k <= i__2; ++k) {
+ i__3 = k;
+ i__4 = ix;
+ q__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[
+ i__4].i, q__2.i = ap[i__3].r * x[i__4].i
+ + ap[i__3].i * x[i__4].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix += *incx;
+/* L120: */
+ }
+ if (nounit) {
+ c_div(&q__1, &temp, &ap[kk + j - 1]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ } else {
+ i__2 = kk + j - 2;
+ for (k = kk; k <= i__2; ++k) {
+ r_cnjg(&q__3, &ap[k]);
+ i__3 = ix;
+ q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
+ q__2.i = q__3.r * x[i__3].i + q__3.i * x[
+ i__3].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix += *incx;
+/* L130: */
+ }
+ if (nounit) {
+ r_cnjg(&q__2, &ap[kk + j - 1]);
+ c_div(&q__1, &temp, &q__2);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ }
+ i__2 = jx;
+ x[i__2].r = temp.r, x[i__2].i = temp.i;
+ jx += *incx;
+ kk += j;
+/* L140: */
+ }
+ }
+ } else {
+ kk = *n * (*n + 1) / 2;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__1 = j;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ k = kk;
+ if (noconj) {
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ i__2 = k;
+ i__3 = i__;
+ q__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[
+ i__3].i, q__2.i = ap[i__2].r * x[i__3].i
+ + ap[i__2].i * x[i__3].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ --k;
+/* L150: */
+ }
+ if (nounit) {
+ c_div(&q__1, &temp, &ap[kk - *n + j]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ } else {
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ r_cnjg(&q__3, &ap[k]);
+ i__2 = i__;
+ q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i,
+ q__2.i = q__3.r * x[i__2].i + q__3.i * x[
+ i__2].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ --k;
+/* L160: */
+ }
+ if (nounit) {
+ r_cnjg(&q__2, &ap[kk - *n + j]);
+ c_div(&q__1, &temp, &q__2);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ }
+ i__1 = j;
+ x[i__1].r = temp.r, x[i__1].i = temp.i;
+ kk -= *n - j + 1;
+/* L170: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ i__1 = jx;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ ix = kx;
+ if (noconj) {
+ i__1 = kk - (*n - (j + 1));
+ for (k = kk; k >= i__1; --k) {
+ i__2 = k;
+ i__3 = ix;
+ q__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[
+ i__3].i, q__2.i = ap[i__2].r * x[i__3].i
+ + ap[i__2].i * x[i__3].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix -= *incx;
+/* L180: */
+ }
+ if (nounit) {
+ c_div(&q__1, &temp, &ap[kk - *n + j]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ } else {
+ i__1 = kk - (*n - (j + 1));
+ for (k = kk; k >= i__1; --k) {
+ r_cnjg(&q__3, &ap[k]);
+ i__2 = ix;
+ q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i,
+ q__2.i = q__3.r * x[i__2].i + q__3.i * x[
+ i__2].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix -= *incx;
+/* L190: */
+ }
+ if (nounit) {
+ r_cnjg(&q__2, &ap[kk - *n + j]);
+ c_div(&q__1, &temp, &q__2);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ }
+ i__1 = jx;
+ x[i__1].r = temp.r, x[i__1].i = temp.i;
+ jx -= *incx;
+ kk -= *n - j + 1;
+/* L200: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CTPSV . */
+
+} /* ctpsv_ */
diff --git a/BLAS/SRC/ctrmm.c b/BLAS/SRC/ctrmm.c
new file mode 100644
index 0000000..2b1f231
--- /dev/null
+++ b/BLAS/SRC/ctrmm.c
@@ -0,0 +1,688 @@
+/* ctrmm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ctrmm_(char *side, char *uplo, char *transa, char *diag,
+ integer *m, integer *n, complex *alpha, complex *a, integer *lda,
+ complex *b, integer *ldb)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k, info;
+ complex temp;
+ extern logical lsame_(char *, char *);
+ logical lside;
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical noconj, nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTRMM performs one of the matrix-matrix operations */
+
+/* B := alpha*op( A )*B, or B := alpha*B*op( A ) */
+
+/* where alpha is a scalar, B is an m by n matrix, A is a unit, or */
+/* non-unit, upper or lower triangular matrix and op( A ) is one of */
+
+/* op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). */
+
+/* Arguments */
+/* ========== */
+
+/* SIDE - CHARACTER*1. */
+/* On entry, SIDE specifies whether op( A ) multiplies B from */
+/* the left or right as follows: */
+
+/* SIDE = 'L' or 'l' B := alpha*op( A )*B. */
+
+/* SIDE = 'R' or 'r' B := alpha*B*op( A ). */
+
+/* Unchanged on exit. */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix A is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANSA - CHARACTER*1. */
+/* On entry, TRANSA specifies the form of op( A ) to be used in */
+/* the matrix multiplication as follows: */
+
+/* TRANSA = 'N' or 'n' op( A ) = A. */
+
+/* TRANSA = 'T' or 't' op( A ) = A'. */
+
+/* TRANSA = 'C' or 'c' op( A ) = conjg( A' ). */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit triangular */
+/* as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of B. M must be at */
+/* least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of B. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX . */
+/* On entry, ALPHA specifies the scalar alpha. When alpha is */
+/* zero then A is not referenced and B need not be set before */
+/* entry. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, k ), where k is m */
+/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */
+/* Before entry with UPLO = 'U' or 'u', the leading k by k */
+/* upper triangular part of the array A must contain the upper */
+/* triangular matrix and the strictly lower triangular part of */
+/* A is not referenced. */
+/* Before entry with UPLO = 'L' or 'l', the leading k by k */
+/* lower triangular part of the array A must contain the lower */
+/* triangular matrix and the strictly upper triangular part of */
+/* A is not referenced. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced either, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When SIDE = 'L' or 'l' then */
+/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */
+/* then LDA must be at least max( 1, n ). */
+/* Unchanged on exit. */
+
+/* B - COMPLEX array of DIMENSION ( LDB, n ). */
+/* Before entry, the leading m by n part of the array B must */
+/* contain the matrix B, and on exit is overwritten by the */
+/* transformed matrix. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. LDB must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ lside = lsame_(side, "L");
+ if (lside) {
+ nrowa = *m;
+ } else {
+ nrowa = *n;
+ }
+ noconj = lsame_(transa, "T");
+ nounit = lsame_(diag, "N");
+ upper = lsame_(uplo, "U");
+
+ info = 0;
+ if (! lside && ! lsame_(side, "R")) {
+ info = 1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ info = 2;
+ } else if (! lsame_(transa, "N") && ! lsame_(transa,
+ "T") && ! lsame_(transa, "C")) {
+ info = 3;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 4;
+ } else if (*m < 0) {
+ info = 5;
+ } else if (*n < 0) {
+ info = 6;
+ } else if (*lda < max(1,nrowa)) {
+ info = 9;
+ } else if (*ldb < max(1,*m)) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("CTRMM ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (alpha->r == 0.f && alpha->i == 0.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0.f, b[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lside) {
+ if (lsame_(transa, "N")) {
+
+/* Form B := alpha*A*B. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * b_dim1;
+ if (b[i__3].r != 0.f || b[i__3].i != 0.f) {
+ i__3 = k + j * b_dim1;
+ q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3]
+ .i, q__1.i = alpha->r * b[i__3].i +
+ alpha->i * b[i__3].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ + j * b_dim1;
+ i__6 = i__ + k * a_dim1;
+ q__2.r = temp.r * a[i__6].r - temp.i * a[i__6]
+ .i, q__2.i = temp.r * a[i__6].i +
+ temp.i * a[i__6].r;
+ q__1.r = b[i__5].r + q__2.r, q__1.i = b[i__5]
+ .i + q__2.i;
+ b[i__4].r = q__1.r, b[i__4].i = q__1.i;
+/* L30: */
+ }
+ if (nounit) {
+ i__3 = k + k * a_dim1;
+ q__1.r = temp.r * a[i__3].r - temp.i * a[i__3]
+ .i, q__1.i = temp.r * a[i__3].i +
+ temp.i * a[i__3].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ i__3 = k + j * b_dim1;
+ b[i__3].r = temp.r, b[i__3].i = temp.i;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (k = *m; k >= 1; --k) {
+ i__2 = k + j * b_dim1;
+ if (b[i__2].r != 0.f || b[i__2].i != 0.f) {
+ i__2 = k + j * b_dim1;
+ q__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2]
+ .i, q__1.i = alpha->r * b[i__2].i +
+ alpha->i * b[i__2].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__2 = k + j * b_dim1;
+ b[i__2].r = temp.r, b[i__2].i = temp.i;
+ if (nounit) {
+ i__2 = k + j * b_dim1;
+ i__3 = k + j * b_dim1;
+ i__4 = k + k * a_dim1;
+ q__1.r = b[i__3].r * a[i__4].r - b[i__3].i *
+ a[i__4].i, q__1.i = b[i__3].r * a[
+ i__4].i + b[i__3].i * a[i__4].r;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ }
+ i__2 = *m;
+ for (i__ = k + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ + k * a_dim1;
+ q__2.r = temp.r * a[i__5].r - temp.i * a[i__5]
+ .i, q__2.i = temp.r * a[i__5].i +
+ temp.i * a[i__5].r;
+ q__1.r = b[i__4].r + q__2.r, q__1.i = b[i__4]
+ .i + q__2.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L60: */
+ }
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form B := alpha*A'*B or B := alpha*conjg( A' )*B. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (i__ = *m; i__ >= 1; --i__) {
+ i__2 = i__ + j * b_dim1;
+ temp.r = b[i__2].r, temp.i = b[i__2].i;
+ if (noconj) {
+ if (nounit) {
+ i__2 = i__ + i__ * a_dim1;
+ q__1.r = temp.r * a[i__2].r - temp.i * a[i__2]
+ .i, q__1.i = temp.r * a[i__2].i +
+ temp.i * a[i__2].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ i__2 = i__ - 1;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + i__ * a_dim1;
+ i__4 = k + j * b_dim1;
+ q__2.r = a[i__3].r * b[i__4].r - a[i__3].i *
+ b[i__4].i, q__2.i = a[i__3].r * b[
+ i__4].i + a[i__3].i * b[i__4].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L90: */
+ }
+ } else {
+ if (nounit) {
+ r_cnjg(&q__2, &a[i__ + i__ * a_dim1]);
+ q__1.r = temp.r * q__2.r - temp.i * q__2.i,
+ q__1.i = temp.r * q__2.i + temp.i *
+ q__2.r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ i__2 = i__ - 1;
+ for (k = 1; k <= i__2; ++k) {
+ r_cnjg(&q__3, &a[k + i__ * a_dim1]);
+ i__3 = k + j * b_dim1;
+ q__2.r = q__3.r * b[i__3].r - q__3.i * b[i__3]
+ .i, q__2.i = q__3.r * b[i__3].i +
+ q__3.i * b[i__3].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L100: */
+ }
+ }
+ i__2 = i__ + j * b_dim1;
+ q__1.r = alpha->r * temp.r - alpha->i * temp.i,
+ q__1.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L110: */
+ }
+/* L120: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ temp.r = b[i__3].r, temp.i = b[i__3].i;
+ if (noconj) {
+ if (nounit) {
+ i__3 = i__ + i__ * a_dim1;
+ q__1.r = temp.r * a[i__3].r - temp.i * a[i__3]
+ .i, q__1.i = temp.r * a[i__3].i +
+ temp.i * a[i__3].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ i__3 = *m;
+ for (k = i__ + 1; k <= i__3; ++k) {
+ i__4 = k + i__ * a_dim1;
+ i__5 = k + j * b_dim1;
+ q__2.r = a[i__4].r * b[i__5].r - a[i__4].i *
+ b[i__5].i, q__2.i = a[i__4].r * b[
+ i__5].i + a[i__4].i * b[i__5].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L130: */
+ }
+ } else {
+ if (nounit) {
+ r_cnjg(&q__2, &a[i__ + i__ * a_dim1]);
+ q__1.r = temp.r * q__2.r - temp.i * q__2.i,
+ q__1.i = temp.r * q__2.i + temp.i *
+ q__2.r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ i__3 = *m;
+ for (k = i__ + 1; k <= i__3; ++k) {
+ r_cnjg(&q__3, &a[k + i__ * a_dim1]);
+ i__4 = k + j * b_dim1;
+ q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4]
+ .i, q__2.i = q__3.r * b[i__4].i +
+ q__3.i * b[i__4].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L140: */
+ }
+ }
+ i__3 = i__ + j * b_dim1;
+ q__1.r = alpha->r * temp.r - alpha->i * temp.i,
+ q__1.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L150: */
+ }
+/* L160: */
+ }
+ }
+ }
+ } else {
+ if (lsame_(transa, "N")) {
+
+/* Form B := alpha*B*A. */
+
+ if (upper) {
+ for (j = *n; j >= 1; --j) {
+ temp.r = alpha->r, temp.i = alpha->i;
+ if (nounit) {
+ i__1 = j + j * a_dim1;
+ q__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i,
+ q__1.i = temp.r * a[i__1].i + temp.i * a[i__1]
+ .r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ q__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i,
+ q__1.i = temp.r * b[i__3].i + temp.i * b[i__3]
+ .r;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L170: */
+ }
+ i__1 = j - 1;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = k + j * a_dim1;
+ if (a[i__2].r != 0.f || a[i__2].i != 0.f) {
+ i__2 = k + j * a_dim1;
+ q__1.r = alpha->r * a[i__2].r - alpha->i * a[i__2]
+ .i, q__1.i = alpha->r * a[i__2].i +
+ alpha->i * a[i__2].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ + k * b_dim1;
+ q__2.r = temp.r * b[i__5].r - temp.i * b[i__5]
+ .i, q__2.i = temp.r * b[i__5].i +
+ temp.i * b[i__5].r;
+ q__1.r = b[i__4].r + q__2.r, q__1.i = b[i__4]
+ .i + q__2.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L180: */
+ }
+ }
+/* L190: */
+ }
+/* L200: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp.r = alpha->r, temp.i = alpha->i;
+ if (nounit) {
+ i__2 = j + j * a_dim1;
+ q__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
+ q__1.i = temp.r * a[i__2].i + temp.i * a[i__2]
+ .r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ q__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i,
+ q__1.i = temp.r * b[i__4].i + temp.i * b[i__4]
+ .r;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L210: */
+ }
+ i__2 = *n;
+ for (k = j + 1; k <= i__2; ++k) {
+ i__3 = k + j * a_dim1;
+ if (a[i__3].r != 0.f || a[i__3].i != 0.f) {
+ i__3 = k + j * a_dim1;
+ q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3]
+ .i, q__1.i = alpha->r * a[i__3].i +
+ alpha->i * a[i__3].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ + j * b_dim1;
+ i__6 = i__ + k * b_dim1;
+ q__2.r = temp.r * b[i__6].r - temp.i * b[i__6]
+ .i, q__2.i = temp.r * b[i__6].i +
+ temp.i * b[i__6].r;
+ q__1.r = b[i__5].r + q__2.r, q__1.i = b[i__5]
+ .i + q__2.i;
+ b[i__4].r = q__1.r, b[i__4].i = q__1.i;
+/* L220: */
+ }
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+ }
+ } else {
+
+/* Form B := alpha*B*A' or B := alpha*B*conjg( A' ). */
+
+ if (upper) {
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = k - 1;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + k * a_dim1;
+ if (a[i__3].r != 0.f || a[i__3].i != 0.f) {
+ if (noconj) {
+ i__3 = j + k * a_dim1;
+ q__1.r = alpha->r * a[i__3].r - alpha->i * a[
+ i__3].i, q__1.i = alpha->r * a[i__3]
+ .i + alpha->i * a[i__3].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ } else {
+ r_cnjg(&q__2, &a[j + k * a_dim1]);
+ q__1.r = alpha->r * q__2.r - alpha->i *
+ q__2.i, q__1.i = alpha->r * q__2.i +
+ alpha->i * q__2.r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ + j * b_dim1;
+ i__6 = i__ + k * b_dim1;
+ q__2.r = temp.r * b[i__6].r - temp.i * b[i__6]
+ .i, q__2.i = temp.r * b[i__6].i +
+ temp.i * b[i__6].r;
+ q__1.r = b[i__5].r + q__2.r, q__1.i = b[i__5]
+ .i + q__2.i;
+ b[i__4].r = q__1.r, b[i__4].i = q__1.i;
+/* L250: */
+ }
+ }
+/* L260: */
+ }
+ temp.r = alpha->r, temp.i = alpha->i;
+ if (nounit) {
+ if (noconj) {
+ i__2 = k + k * a_dim1;
+ q__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
+ q__1.i = temp.r * a[i__2].i + temp.i * a[
+ i__2].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ } else {
+ r_cnjg(&q__2, &a[k + k * a_dim1]);
+ q__1.r = temp.r * q__2.r - temp.i * q__2.i,
+ q__1.i = temp.r * q__2.i + temp.i *
+ q__2.r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ }
+ if (temp.r != 1.f || temp.i != 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ i__4 = i__ + k * b_dim1;
+ q__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i,
+ q__1.i = temp.r * b[i__4].i + temp.i * b[
+ i__4].r;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L270: */
+ }
+ }
+/* L280: */
+ }
+ } else {
+ for (k = *n; k >= 1; --k) {
+ i__1 = *n;
+ for (j = k + 1; j <= i__1; ++j) {
+ i__2 = j + k * a_dim1;
+ if (a[i__2].r != 0.f || a[i__2].i != 0.f) {
+ if (noconj) {
+ i__2 = j + k * a_dim1;
+ q__1.r = alpha->r * a[i__2].r - alpha->i * a[
+ i__2].i, q__1.i = alpha->r * a[i__2]
+ .i + alpha->i * a[i__2].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ } else {
+ r_cnjg(&q__2, &a[j + k * a_dim1]);
+ q__1.r = alpha->r * q__2.r - alpha->i *
+ q__2.i, q__1.i = alpha->r * q__2.i +
+ alpha->i * q__2.r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ + k * b_dim1;
+ q__2.r = temp.r * b[i__5].r - temp.i * b[i__5]
+ .i, q__2.i = temp.r * b[i__5].i +
+ temp.i * b[i__5].r;
+ q__1.r = b[i__4].r + q__2.r, q__1.i = b[i__4]
+ .i + q__2.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L290: */
+ }
+ }
+/* L300: */
+ }
+ temp.r = alpha->r, temp.i = alpha->i;
+ if (nounit) {
+ if (noconj) {
+ i__1 = k + k * a_dim1;
+ q__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i,
+ q__1.i = temp.r * a[i__1].i + temp.i * a[
+ i__1].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ } else {
+ r_cnjg(&q__2, &a[k + k * a_dim1]);
+ q__1.r = temp.r * q__2.r - temp.i * q__2.i,
+ q__1.i = temp.r * q__2.i + temp.i *
+ q__2.r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ }
+ if (temp.r != 1.f || temp.i != 0.f) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + k * b_dim1;
+ i__3 = i__ + k * b_dim1;
+ q__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i,
+ q__1.i = temp.r * b[i__3].i + temp.i * b[
+ i__3].r;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L310: */
+ }
+ }
+/* L320: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CTRMM . */
+
+} /* ctrmm_ */
diff --git a/BLAS/SRC/ctrmv.c b/BLAS/SRC/ctrmv.c
new file mode 100644
index 0000000..9380189
--- /dev/null
+++ b/BLAS/SRC/ctrmv.c
@@ -0,0 +1,554 @@
+/* ctrmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ctrmv_(char *uplo, char *trans, char *diag, integer *n,
+ complex *a, integer *lda, complex *x, integer *incx)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, ix, jx, kx, info;
+ complex temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical noconj, nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTRMV performs one of the matrix-vector operations */
+
+/* x := A*x, or x := A'*x, or x := conjg( A' )*x, */
+
+/* where x is an n element vector and A is an n by n unit, or non-unit, */
+/* upper or lower triangular matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' x := A*x. */
+
+/* TRANS = 'T' or 't' x := A'*x. */
+
+/* TRANS = 'C' or 'c' x := conjg( A' )*x. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular matrix and the strictly lower triangular part of */
+/* A is not referenced. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular matrix and the strictly upper triangular part of */
+/* A is not referenced. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced either, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. On exit, X is overwritten with the */
+/* tranformed vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*lda < max(1,*n)) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ }
+ if (info != 0) {
+ xerbla_("CTRMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ noconj = lsame_(trans, "T");
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through A. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x := A*x. */
+
+ if (lsame_(uplo, "U")) {
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ i__2 = j;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ q__2.i = temp.r * a[i__5].i + temp.i * a[
+ i__5].r;
+ q__1.r = x[i__4].r + q__2.r, q__1.i = x[i__4].i +
+ q__2.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+/* L10: */
+ }
+ if (nounit) {
+ i__2 = j;
+ i__3 = j;
+ i__4 = j + j * a_dim1;
+ q__1.r = x[i__3].r * a[i__4].r - x[i__3].i * a[
+ i__4].i, q__1.i = x[i__3].r * a[i__4].i +
+ x[i__3].i * a[i__4].r;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ }
+ }
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ i__2 = jx;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ ix = kx;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = ix;
+ i__4 = ix;
+ i__5 = i__ + j * a_dim1;
+ q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ q__2.i = temp.r * a[i__5].i + temp.i * a[
+ i__5].r;
+ q__1.r = x[i__4].r + q__2.r, q__1.i = x[i__4].i +
+ q__2.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ ix += *incx;
+/* L30: */
+ }
+ if (nounit) {
+ i__2 = jx;
+ i__3 = jx;
+ i__4 = j + j * a_dim1;
+ q__1.r = x[i__3].r * a[i__4].r - x[i__3].i * a[
+ i__4].i, q__1.i = x[i__3].r * a[i__4].i +
+ x[i__3].i * a[i__4].r;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ }
+ }
+ jx += *incx;
+/* L40: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__1 = j;
+ if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
+ i__1 = j;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__ + j * a_dim1;
+ q__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
+ q__2.i = temp.r * a[i__4].i + temp.i * a[
+ i__4].r;
+ q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i +
+ q__2.i;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+/* L50: */
+ }
+ if (nounit) {
+ i__1 = j;
+ i__2 = j;
+ i__3 = j + j * a_dim1;
+ q__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[
+ i__3].i, q__1.i = x[i__2].r * a[i__3].i +
+ x[i__2].i * a[i__3].r;
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ }
+ }
+/* L60: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ i__1 = jx;
+ if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
+ i__1 = jx;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ ix = kx;
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ i__2 = ix;
+ i__3 = ix;
+ i__4 = i__ + j * a_dim1;
+ q__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
+ q__2.i = temp.r * a[i__4].i + temp.i * a[
+ i__4].r;
+ q__1.r = x[i__3].r + q__2.r, q__1.i = x[i__3].i +
+ q__2.i;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ ix -= *incx;
+/* L70: */
+ }
+ if (nounit) {
+ i__1 = jx;
+ i__2 = jx;
+ i__3 = j + j * a_dim1;
+ q__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[
+ i__3].i, q__1.i = x[i__2].r * a[i__3].i +
+ x[i__2].i * a[i__3].r;
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ }
+ }
+ jx -= *incx;
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := A'*x or x := conjg( A' )*x. */
+
+ if (lsame_(uplo, "U")) {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__1 = j;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ if (noconj) {
+ if (nounit) {
+ i__1 = j + j * a_dim1;
+ q__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i,
+ q__1.i = temp.r * a[i__1].i + temp.i * a[
+ i__1].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ i__1 = i__ + j * a_dim1;
+ i__2 = i__;
+ q__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[
+ i__2].i, q__2.i = a[i__1].r * x[i__2].i +
+ a[i__1].i * x[i__2].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L90: */
+ }
+ } else {
+ if (nounit) {
+ r_cnjg(&q__2, &a[j + j * a_dim1]);
+ q__1.r = temp.r * q__2.r - temp.i * q__2.i,
+ q__1.i = temp.r * q__2.i + temp.i *
+ q__2.r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ r_cnjg(&q__3, &a[i__ + j * a_dim1]);
+ i__1 = i__;
+ q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i,
+ q__2.i = q__3.r * x[i__1].i + q__3.i * x[
+ i__1].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L100: */
+ }
+ }
+ i__1 = j;
+ x[i__1].r = temp.r, x[i__1].i = temp.i;
+/* L110: */
+ }
+ } else {
+ jx = kx + (*n - 1) * *incx;
+ for (j = *n; j >= 1; --j) {
+ i__1 = jx;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ ix = jx;
+ if (noconj) {
+ if (nounit) {
+ i__1 = j + j * a_dim1;
+ q__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i,
+ q__1.i = temp.r * a[i__1].i + temp.i * a[
+ i__1].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ ix -= *incx;
+ i__1 = i__ + j * a_dim1;
+ i__2 = ix;
+ q__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[
+ i__2].i, q__2.i = a[i__1].r * x[i__2].i +
+ a[i__1].i * x[i__2].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L120: */
+ }
+ } else {
+ if (nounit) {
+ r_cnjg(&q__2, &a[j + j * a_dim1]);
+ q__1.r = temp.r * q__2.r - temp.i * q__2.i,
+ q__1.i = temp.r * q__2.i + temp.i *
+ q__2.r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ ix -= *incx;
+ r_cnjg(&q__3, &a[i__ + j * a_dim1]);
+ i__1 = ix;
+ q__2.r = q__3.r * x[i__1].r - q__3.i * x[i__1].i,
+ q__2.i = q__3.r * x[i__1].i + q__3.i * x[
+ i__1].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L130: */
+ }
+ }
+ i__1 = jx;
+ x[i__1].r = temp.r, x[i__1].i = temp.i;
+ jx -= *incx;
+/* L140: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ if (noconj) {
+ if (nounit) {
+ i__2 = j + j * a_dim1;
+ q__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
+ q__1.i = temp.r * a[i__2].i + temp.i * a[
+ i__2].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
+ i__4].i, q__2.i = a[i__3].r * x[i__4].i +
+ a[i__3].i * x[i__4].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L150: */
+ }
+ } else {
+ if (nounit) {
+ r_cnjg(&q__2, &a[j + j * a_dim1]);
+ q__1.r = temp.r * q__2.r - temp.i * q__2.i,
+ q__1.i = temp.r * q__2.i + temp.i *
+ q__2.r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ r_cnjg(&q__3, &a[i__ + j * a_dim1]);
+ i__3 = i__;
+ q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
+ q__2.i = q__3.r * x[i__3].i + q__3.i * x[
+ i__3].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L160: */
+ }
+ }
+ i__2 = j;
+ x[i__2].r = temp.r, x[i__2].i = temp.i;
+/* L170: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ ix = jx;
+ if (noconj) {
+ if (nounit) {
+ i__2 = j + j * a_dim1;
+ q__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
+ q__1.i = temp.r * a[i__2].i + temp.i * a[
+ i__2].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ ix += *incx;
+ i__3 = i__ + j * a_dim1;
+ i__4 = ix;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
+ i__4].i, q__2.i = a[i__3].r * x[i__4].i +
+ a[i__3].i * x[i__4].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L180: */
+ }
+ } else {
+ if (nounit) {
+ r_cnjg(&q__2, &a[j + j * a_dim1]);
+ q__1.r = temp.r * q__2.r - temp.i * q__2.i,
+ q__1.i = temp.r * q__2.i + temp.i *
+ q__2.r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ ix += *incx;
+ r_cnjg(&q__3, &a[i__ + j * a_dim1]);
+ i__3 = ix;
+ q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
+ q__2.i = q__3.r * x[i__3].i + q__3.i * x[
+ i__3].r;
+ q__1.r = temp.r + q__2.r, q__1.i = temp.i +
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L190: */
+ }
+ }
+ i__2 = jx;
+ x[i__2].r = temp.r, x[i__2].i = temp.i;
+ jx += *incx;
+/* L200: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CTRMV . */
+
+} /* ctrmv_ */
diff --git a/BLAS/SRC/ctrsm.c b/BLAS/SRC/ctrsm.c
new file mode 100644
index 0000000..ec893f6
--- /dev/null
+++ b/BLAS/SRC/ctrsm.c
@@ -0,0 +1,698 @@
+/* ctrsm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+
+/* Subroutine */ int ctrsm_(char *side, char *uplo, char *transa, char *diag,
+ integer *m, integer *n, complex *alpha, complex *a, integer *lda,
+ complex *b, integer *ldb)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6, i__7;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k, info;
+ complex temp;
+ extern logical lsame_(char *, char *);
+ logical lside;
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical noconj, nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTRSM solves one of the matrix equations */
+
+/* op( A )*X = alpha*B, or X*op( A ) = alpha*B, */
+
+/* where alpha is a scalar, X and B are m by n matrices, A is a unit, or */
+/* non-unit, upper or lower triangular matrix and op( A ) is one of */
+
+/* op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). */
+
+/* The matrix X is overwritten on B. */
+
+/* Arguments */
+/* ========== */
+
+/* SIDE - CHARACTER*1. */
+/* On entry, SIDE specifies whether op( A ) appears on the left */
+/* or right of X as follows: */
+
+/* SIDE = 'L' or 'l' op( A )*X = alpha*B. */
+
+/* SIDE = 'R' or 'r' X*op( A ) = alpha*B. */
+
+/* Unchanged on exit. */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix A is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANSA - CHARACTER*1. */
+/* On entry, TRANSA specifies the form of op( A ) to be used in */
+/* the matrix multiplication as follows: */
+
+/* TRANSA = 'N' or 'n' op( A ) = A. */
+
+/* TRANSA = 'T' or 't' op( A ) = A'. */
+
+/* TRANSA = 'C' or 'c' op( A ) = conjg( A' ). */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit triangular */
+/* as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of B. M must be at */
+/* least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of B. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX . */
+/* On entry, ALPHA specifies the scalar alpha. When alpha is */
+/* zero then A is not referenced and B need not be set before */
+/* entry. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, k ), where k is m */
+/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */
+/* Before entry with UPLO = 'U' or 'u', the leading k by k */
+/* upper triangular part of the array A must contain the upper */
+/* triangular matrix and the strictly lower triangular part of */
+/* A is not referenced. */
+/* Before entry with UPLO = 'L' or 'l', the leading k by k */
+/* lower triangular part of the array A must contain the lower */
+/* triangular matrix and the strictly upper triangular part of */
+/* A is not referenced. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced either, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When SIDE = 'L' or 'l' then */
+/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */
+/* then LDA must be at least max( 1, n ). */
+/* Unchanged on exit. */
+
+/* B - COMPLEX array of DIMENSION ( LDB, n ). */
+/* Before entry, the leading m by n part of the array B must */
+/* contain the right-hand side matrix B, and on exit is */
+/* overwritten by the solution matrix X. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. LDB must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ lside = lsame_(side, "L");
+ if (lside) {
+ nrowa = *m;
+ } else {
+ nrowa = *n;
+ }
+ noconj = lsame_(transa, "T");
+ nounit = lsame_(diag, "N");
+ upper = lsame_(uplo, "U");
+
+ info = 0;
+ if (! lside && ! lsame_(side, "R")) {
+ info = 1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ info = 2;
+ } else if (! lsame_(transa, "N") && ! lsame_(transa,
+ "T") && ! lsame_(transa, "C")) {
+ info = 3;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 4;
+ } else if (*m < 0) {
+ info = 5;
+ } else if (*n < 0) {
+ info = 6;
+ } else if (*lda < max(1,nrowa)) {
+ info = 9;
+ } else if (*ldb < max(1,*m)) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("CTRSM ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (alpha->r == 0.f && alpha->i == 0.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0.f, b[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lside) {
+ if (lsame_(transa, "N")) {
+
+/* Form B := alpha*inv( A )*B. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (alpha->r != 1.f || alpha->i != 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ q__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4]
+ .i, q__1.i = alpha->r * b[i__4].i +
+ alpha->i * b[i__4].r;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L30: */
+ }
+ }
+ for (k = *m; k >= 1; --k) {
+ i__2 = k + j * b_dim1;
+ if (b[i__2].r != 0.f || b[i__2].i != 0.f) {
+ if (nounit) {
+ i__2 = k + j * b_dim1;
+ c_div(&q__1, &b[k + j * b_dim1], &a[k + k *
+ a_dim1]);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ }
+ i__2 = k - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = k + j * b_dim1;
+ i__6 = i__ + k * a_dim1;
+ q__2.r = b[i__5].r * a[i__6].r - b[i__5].i *
+ a[i__6].i, q__2.i = b[i__5].r * a[
+ i__6].i + b[i__5].i * a[i__6].r;
+ q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4]
+ .i - q__2.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L40: */
+ }
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (alpha->r != 1.f || alpha->i != 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ q__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4]
+ .i, q__1.i = alpha->r * b[i__4].i +
+ alpha->i * b[i__4].r;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L70: */
+ }
+ }
+ i__2 = *m;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * b_dim1;
+ if (b[i__3].r != 0.f || b[i__3].i != 0.f) {
+ if (nounit) {
+ i__3 = k + j * b_dim1;
+ c_div(&q__1, &b[k + j * b_dim1], &a[k + k *
+ a_dim1]);
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+ }
+ i__3 = *m;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ + j * b_dim1;
+ i__6 = k + j * b_dim1;
+ i__7 = i__ + k * a_dim1;
+ q__2.r = b[i__6].r * a[i__7].r - b[i__6].i *
+ a[i__7].i, q__2.i = b[i__6].r * a[
+ i__7].i + b[i__6].i * a[i__7].r;
+ q__1.r = b[i__5].r - q__2.r, q__1.i = b[i__5]
+ .i - q__2.i;
+ b[i__4].r = q__1.r, b[i__4].i = q__1.i;
+/* L80: */
+ }
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+ }
+ } else {
+
+/* Form B := alpha*inv( A' )*B */
+/* or B := alpha*inv( conjg( A' ) )*B. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
+ q__1.i = alpha->r * b[i__3].i + alpha->i * b[
+ i__3].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ if (noconj) {
+ i__3 = i__ - 1;
+ for (k = 1; k <= i__3; ++k) {
+ i__4 = k + i__ * a_dim1;
+ i__5 = k + j * b_dim1;
+ q__2.r = a[i__4].r * b[i__5].r - a[i__4].i *
+ b[i__5].i, q__2.i = a[i__4].r * b[
+ i__5].i + a[i__4].i * b[i__5].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L110: */
+ }
+ if (nounit) {
+ c_div(&q__1, &temp, &a[i__ + i__ * a_dim1]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ } else {
+ i__3 = i__ - 1;
+ for (k = 1; k <= i__3; ++k) {
+ r_cnjg(&q__3, &a[k + i__ * a_dim1]);
+ i__4 = k + j * b_dim1;
+ q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4]
+ .i, q__2.i = q__3.r * b[i__4].i +
+ q__3.i * b[i__4].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L120: */
+ }
+ if (nounit) {
+ r_cnjg(&q__2, &a[i__ + i__ * a_dim1]);
+ c_div(&q__1, &temp, &q__2);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ }
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = temp.r, b[i__3].i = temp.i;
+/* L130: */
+ }
+/* L140: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (i__ = *m; i__ >= 1; --i__) {
+ i__2 = i__ + j * b_dim1;
+ q__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2].i,
+ q__1.i = alpha->r * b[i__2].i + alpha->i * b[
+ i__2].r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ if (noconj) {
+ i__2 = *m;
+ for (k = i__ + 1; k <= i__2; ++k) {
+ i__3 = k + i__ * a_dim1;
+ i__4 = k + j * b_dim1;
+ q__2.r = a[i__3].r * b[i__4].r - a[i__3].i *
+ b[i__4].i, q__2.i = a[i__3].r * b[
+ i__4].i + a[i__3].i * b[i__4].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L150: */
+ }
+ if (nounit) {
+ c_div(&q__1, &temp, &a[i__ + i__ * a_dim1]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ } else {
+ i__2 = *m;
+ for (k = i__ + 1; k <= i__2; ++k) {
+ r_cnjg(&q__3, &a[k + i__ * a_dim1]);
+ i__3 = k + j * b_dim1;
+ q__2.r = q__3.r * b[i__3].r - q__3.i * b[i__3]
+ .i, q__2.i = q__3.r * b[i__3].i +
+ q__3.i * b[i__3].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L160: */
+ }
+ if (nounit) {
+ r_cnjg(&q__2, &a[i__ + i__ * a_dim1]);
+ c_div(&q__1, &temp, &q__2);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ }
+ i__2 = i__ + j * b_dim1;
+ b[i__2].r = temp.r, b[i__2].i = temp.i;
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+ }
+ } else {
+ if (lsame_(transa, "N")) {
+
+/* Form B := alpha*B*inv( A ). */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (alpha->r != 1.f || alpha->i != 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ q__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4]
+ .i, q__1.i = alpha->r * b[i__4].i +
+ alpha->i * b[i__4].r;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L190: */
+ }
+ }
+ i__2 = j - 1;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * a_dim1;
+ if (a[i__3].r != 0.f || a[i__3].i != 0.f) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ + j * b_dim1;
+ i__6 = k + j * a_dim1;
+ i__7 = i__ + k * b_dim1;
+ q__2.r = a[i__6].r * b[i__7].r - a[i__6].i *
+ b[i__7].i, q__2.i = a[i__6].r * b[
+ i__7].i + a[i__6].i * b[i__7].r;
+ q__1.r = b[i__5].r - q__2.r, q__1.i = b[i__5]
+ .i - q__2.i;
+ b[i__4].r = q__1.r, b[i__4].i = q__1.i;
+/* L200: */
+ }
+ }
+/* L210: */
+ }
+ if (nounit) {
+ c_div(&q__1, &c_b1, &a[j + j * a_dim1]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ q__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i,
+ q__1.i = temp.r * b[i__4].i + temp.i * b[
+ i__4].r;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L220: */
+ }
+ }
+/* L230: */
+ }
+ } else {
+ for (j = *n; j >= 1; --j) {
+ if (alpha->r != 1.f || alpha->i != 0.f) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3]
+ .i, q__1.i = alpha->r * b[i__3].i +
+ alpha->i * b[i__3].r;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L240: */
+ }
+ }
+ i__1 = *n;
+ for (k = j + 1; k <= i__1; ++k) {
+ i__2 = k + j * a_dim1;
+ if (a[i__2].r != 0.f || a[i__2].i != 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = k + j * a_dim1;
+ i__6 = i__ + k * b_dim1;
+ q__2.r = a[i__5].r * b[i__6].r - a[i__5].i *
+ b[i__6].i, q__2.i = a[i__5].r * b[
+ i__6].i + a[i__5].i * b[i__6].r;
+ q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4]
+ .i - q__2.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L250: */
+ }
+ }
+/* L260: */
+ }
+ if (nounit) {
+ c_div(&q__1, &c_b1, &a[j + j * a_dim1]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ q__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i,
+ q__1.i = temp.r * b[i__3].i + temp.i * b[
+ i__3].r;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L270: */
+ }
+ }
+/* L280: */
+ }
+ }
+ } else {
+
+/* Form B := alpha*B*inv( A' ) */
+/* or B := alpha*B*inv( conjg( A' ) ). */
+
+ if (upper) {
+ for (k = *n; k >= 1; --k) {
+ if (nounit) {
+ if (noconj) {
+ c_div(&q__1, &c_b1, &a[k + k * a_dim1]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ } else {
+ r_cnjg(&q__2, &a[k + k * a_dim1]);
+ c_div(&q__1, &c_b1, &q__2);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + k * b_dim1;
+ i__3 = i__ + k * b_dim1;
+ q__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i,
+ q__1.i = temp.r * b[i__3].i + temp.i * b[
+ i__3].r;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L290: */
+ }
+ }
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + k * a_dim1;
+ if (a[i__2].r != 0.f || a[i__2].i != 0.f) {
+ if (noconj) {
+ i__2 = j + k * a_dim1;
+ temp.r = a[i__2].r, temp.i = a[i__2].i;
+ } else {
+ r_cnjg(&q__1, &a[j + k * a_dim1]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ + k * b_dim1;
+ q__2.r = temp.r * b[i__5].r - temp.i * b[i__5]
+ .i, q__2.i = temp.r * b[i__5].i +
+ temp.i * b[i__5].r;
+ q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4]
+ .i - q__2.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L300: */
+ }
+ }
+/* L310: */
+ }
+ if (alpha->r != 1.f || alpha->i != 0.f) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + k * b_dim1;
+ i__3 = i__ + k * b_dim1;
+ q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3]
+ .i, q__1.i = alpha->r * b[i__3].i +
+ alpha->i * b[i__3].r;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L320: */
+ }
+ }
+/* L330: */
+ }
+ } else {
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (nounit) {
+ if (noconj) {
+ c_div(&q__1, &c_b1, &a[k + k * a_dim1]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ } else {
+ r_cnjg(&q__2, &a[k + k * a_dim1]);
+ c_div(&q__1, &c_b1, &q__2);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ i__4 = i__ + k * b_dim1;
+ q__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i,
+ q__1.i = temp.r * b[i__4].i + temp.i * b[
+ i__4].r;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L340: */
+ }
+ }
+ i__2 = *n;
+ for (j = k + 1; j <= i__2; ++j) {
+ i__3 = j + k * a_dim1;
+ if (a[i__3].r != 0.f || a[i__3].i != 0.f) {
+ if (noconj) {
+ i__3 = j + k * a_dim1;
+ temp.r = a[i__3].r, temp.i = a[i__3].i;
+ } else {
+ r_cnjg(&q__1, &a[j + k * a_dim1]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ + j * b_dim1;
+ i__6 = i__ + k * b_dim1;
+ q__2.r = temp.r * b[i__6].r - temp.i * b[i__6]
+ .i, q__2.i = temp.r * b[i__6].i +
+ temp.i * b[i__6].r;
+ q__1.r = b[i__5].r - q__2.r, q__1.i = b[i__5]
+ .i - q__2.i;
+ b[i__4].r = q__1.r, b[i__4].i = q__1.i;
+/* L350: */
+ }
+ }
+/* L360: */
+ }
+ if (alpha->r != 1.f || alpha->i != 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ i__4 = i__ + k * b_dim1;
+ q__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4]
+ .i, q__1.i = alpha->r * b[i__4].i +
+ alpha->i * b[i__4].r;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L370: */
+ }
+ }
+/* L380: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CTRSM . */
+
+} /* ctrsm_ */
diff --git a/BLAS/SRC/ctrsv.c b/BLAS/SRC/ctrsv.c
new file mode 100644
index 0000000..9c46cac
--- /dev/null
+++ b/BLAS/SRC/ctrsv.c
@@ -0,0 +1,523 @@
+/* ctrsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ctrsv_(char *uplo, char *trans, char *diag, integer *n,
+ complex *a, integer *lda, complex *x, integer *incx)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, ix, jx, kx, info;
+ complex temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical noconj, nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTRSV solves one of the systems of equations */
+
+/* A*x = b, or A'*x = b, or conjg( A' )*x = b, */
+
+/* where b and x are n element vectors and A is an n by n unit, or */
+/* non-unit, upper or lower triangular matrix. */
+
+/* No test for singularity or near-singularity is included in this */
+/* routine. Such tests must be performed before calling this routine. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the equations to be solved as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' A*x = b. */
+
+/* TRANS = 'T' or 't' A'*x = b. */
+
+/* TRANS = 'C' or 'c' conjg( A' )*x = b. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular matrix and the strictly lower triangular part of */
+/* A is not referenced. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular matrix and the strictly upper triangular part of */
+/* A is not referenced. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced either, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element right-hand side vector b. On exit, X is overwritten */
+/* with the solution vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*lda < max(1,*n)) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ }
+ if (info != 0) {
+ xerbla_("CTRSV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ noconj = lsame_(trans, "T");
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through A. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x := inv( A )*x. */
+
+ if (lsame_(uplo, "U")) {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__1 = j;
+ if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
+ if (nounit) {
+ i__1 = j;
+ c_div(&q__1, &x[j], &a[j + j * a_dim1]);
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ }
+ i__1 = j;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ i__1 = i__;
+ i__2 = i__;
+ i__3 = i__ + j * a_dim1;
+ q__2.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
+ q__2.i = temp.r * a[i__3].i + temp.i * a[
+ i__3].r;
+ q__1.r = x[i__2].r - q__2.r, q__1.i = x[i__2].i -
+ q__2.i;
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+/* L10: */
+ }
+ }
+/* L20: */
+ }
+ } else {
+ jx = kx + (*n - 1) * *incx;
+ for (j = *n; j >= 1; --j) {
+ i__1 = jx;
+ if (x[i__1].r != 0.f || x[i__1].i != 0.f) {
+ if (nounit) {
+ i__1 = jx;
+ c_div(&q__1, &x[jx], &a[j + j * a_dim1]);
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ }
+ i__1 = jx;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ ix = jx;
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ ix -= *incx;
+ i__1 = ix;
+ i__2 = ix;
+ i__3 = i__ + j * a_dim1;
+ q__2.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
+ q__2.i = temp.r * a[i__3].i + temp.i * a[
+ i__3].r;
+ q__1.r = x[i__2].r - q__2.r, q__1.i = x[i__2].i -
+ q__2.i;
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+/* L30: */
+ }
+ }
+ jx -= *incx;
+/* L40: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ if (nounit) {
+ i__2 = j;
+ c_div(&q__1, &x[j], &a[j + j * a_dim1]);
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ }
+ i__2 = j;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ q__2.i = temp.r * a[i__5].i + temp.i * a[
+ i__5].r;
+ q__1.r = x[i__4].r - q__2.r, q__1.i = x[i__4].i -
+ q__2.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ if (nounit) {
+ i__2 = jx;
+ c_div(&q__1, &x[jx], &a[j + j * a_dim1]);
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ }
+ i__2 = jx;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ ix = jx;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ ix += *incx;
+ i__3 = ix;
+ i__4 = ix;
+ i__5 = i__ + j * a_dim1;
+ q__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ q__2.i = temp.r * a[i__5].i + temp.i * a[
+ i__5].r;
+ q__1.r = x[i__4].r - q__2.r, q__1.i = x[i__4].i -
+ q__2.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+/* L70: */
+ }
+ }
+ jx += *incx;
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. */
+
+ if (lsame_(uplo, "U")) {
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ if (noconj) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
+ i__4].i, q__2.i = a[i__3].r * x[i__4].i +
+ a[i__3].i * x[i__4].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L90: */
+ }
+ if (nounit) {
+ c_div(&q__1, &temp, &a[j + j * a_dim1]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ } else {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ r_cnjg(&q__3, &a[i__ + j * a_dim1]);
+ i__3 = i__;
+ q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
+ q__2.i = q__3.r * x[i__3].i + q__3.i * x[
+ i__3].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L100: */
+ }
+ if (nounit) {
+ r_cnjg(&q__2, &a[j + j * a_dim1]);
+ c_div(&q__1, &temp, &q__2);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ }
+ i__2 = j;
+ x[i__2].r = temp.r, x[i__2].i = temp.i;
+/* L110: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ix = kx;
+ i__2 = jx;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ if (noconj) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = ix;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
+ i__4].i, q__2.i = a[i__3].r * x[i__4].i +
+ a[i__3].i * x[i__4].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix += *incx;
+/* L120: */
+ }
+ if (nounit) {
+ c_div(&q__1, &temp, &a[j + j * a_dim1]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ } else {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ r_cnjg(&q__3, &a[i__ + j * a_dim1]);
+ i__3 = ix;
+ q__2.r = q__3.r * x[i__3].r - q__3.i * x[i__3].i,
+ q__2.i = q__3.r * x[i__3].i + q__3.i * x[
+ i__3].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix += *incx;
+/* L130: */
+ }
+ if (nounit) {
+ r_cnjg(&q__2, &a[j + j * a_dim1]);
+ c_div(&q__1, &temp, &q__2);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ }
+ i__2 = jx;
+ x[i__2].r = temp.r, x[i__2].i = temp.i;
+ jx += *incx;
+/* L140: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__1 = j;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ if (noconj) {
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ i__2 = i__ + j * a_dim1;
+ i__3 = i__;
+ q__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[
+ i__3].i, q__2.i = a[i__2].r * x[i__3].i +
+ a[i__2].i * x[i__3].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L150: */
+ }
+ if (nounit) {
+ c_div(&q__1, &temp, &a[j + j * a_dim1]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ } else {
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ r_cnjg(&q__3, &a[i__ + j * a_dim1]);
+ i__2 = i__;
+ q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i,
+ q__2.i = q__3.r * x[i__2].i + q__3.i * x[
+ i__2].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+/* L160: */
+ }
+ if (nounit) {
+ r_cnjg(&q__2, &a[j + j * a_dim1]);
+ c_div(&q__1, &temp, &q__2);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ }
+ i__1 = j;
+ x[i__1].r = temp.r, x[i__1].i = temp.i;
+/* L170: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ ix = kx;
+ i__1 = jx;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ if (noconj) {
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ i__2 = i__ + j * a_dim1;
+ i__3 = ix;
+ q__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[
+ i__3].i, q__2.i = a[i__2].r * x[i__3].i +
+ a[i__2].i * x[i__3].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix -= *incx;
+/* L180: */
+ }
+ if (nounit) {
+ c_div(&q__1, &temp, &a[j + j * a_dim1]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ } else {
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ r_cnjg(&q__3, &a[i__ + j * a_dim1]);
+ i__2 = ix;
+ q__2.r = q__3.r * x[i__2].r - q__3.i * x[i__2].i,
+ q__2.i = q__3.r * x[i__2].i + q__3.i * x[
+ i__2].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i -
+ q__2.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix -= *incx;
+/* L190: */
+ }
+ if (nounit) {
+ r_cnjg(&q__2, &a[j + j * a_dim1]);
+ c_div(&q__1, &temp, &q__2);
+ temp.r = q__1.r, temp.i = q__1.i;
+ }
+ }
+ i__1 = jx;
+ x[i__1].r = temp.r, x[i__1].i = temp.i;
+ jx -= *incx;
+/* L200: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CTRSV . */
+
+} /* ctrsv_ */
diff --git a/BLAS/SRC/dasum.c b/BLAS/SRC/dasum.c
new file mode 100644
index 0000000..6e5f54c
--- /dev/null
+++ b/BLAS/SRC/dasum.c
@@ -0,0 +1,101 @@
+/* dasum.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dasum_(integer *n, doublereal *dx, integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal ret_val, d__1, d__2, d__3, d__4, d__5, d__6;
+
+ /* Local variables */
+ integer i__, m, mp1;
+ doublereal dtemp;
+ integer nincx;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* takes the sum of the absolute values. */
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 3/93 to return if incx .le. 0. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --dx;
+
+ /* Function Body */
+ ret_val = 0.;
+ dtemp = 0.;
+ if (*n <= 0 || *incx <= 0) {
+ return ret_val;
+ }
+ if (*incx == 1) {
+ goto L20;
+ }
+
+/* code for increment not equal to 1 */
+
+ nincx = *n * *incx;
+ i__1 = nincx;
+ i__2 = *incx;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ dtemp += (d__1 = dx[i__], abs(d__1));
+/* L10: */
+ }
+ ret_val = dtemp;
+ return ret_val;
+
+/* code for increment equal to 1 */
+
+
+/* clean-up loop */
+
+L20:
+ m = *n % 6;
+ if (m == 0) {
+ goto L40;
+ }
+ i__2 = m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ dtemp += (d__1 = dx[i__], abs(d__1));
+/* L30: */
+ }
+ if (*n < 6) {
+ goto L60;
+ }
+L40:
+ mp1 = m + 1;
+ i__2 = *n;
+ for (i__ = mp1; i__ <= i__2; i__ += 6) {
+ dtemp = dtemp + (d__1 = dx[i__], abs(d__1)) + (d__2 = dx[i__ + 1],
+ abs(d__2)) + (d__3 = dx[i__ + 2], abs(d__3)) + (d__4 = dx[i__
+ + 3], abs(d__4)) + (d__5 = dx[i__ + 4], abs(d__5)) + (d__6 =
+ dx[i__ + 5], abs(d__6));
+/* L50: */
+ }
+L60:
+ ret_val = dtemp;
+ return ret_val;
+} /* dasum_ */
diff --git a/BLAS/SRC/daxpy.c b/BLAS/SRC/daxpy.c
new file mode 100644
index 0000000..d6ef828
--- /dev/null
+++ b/BLAS/SRC/daxpy.c
@@ -0,0 +1,107 @@
+/* daxpy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int daxpy_(integer *n, doublereal *da, doublereal *dx,
+ integer *incx, doublereal *dy, integer *incy)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, m, ix, iy, mp1;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* constant times a vector plus a vector. */
+/* uses unrolled loops for increments equal to one. */
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --dy;
+ --dx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ if (*da == 0.) {
+ return 0;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* code for unequal increments or equal increments */
+/* not equal to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dy[iy] += *da * dx[ix];
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ return 0;
+
+/* code for both increments equal to 1 */
+
+
+/* clean-up loop */
+
+L20:
+ m = *n % 4;
+ if (m == 0) {
+ goto L40;
+ }
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dy[i__] += *da * dx[i__];
+/* L30: */
+ }
+ if (*n < 4) {
+ return 0;
+ }
+L40:
+ mp1 = m + 1;
+ i__1 = *n;
+ for (i__ = mp1; i__ <= i__1; i__ += 4) {
+ dy[i__] += *da * dx[i__];
+ dy[i__ + 1] += *da * dx[i__ + 1];
+ dy[i__ + 2] += *da * dx[i__ + 2];
+ dy[i__ + 3] += *da * dx[i__ + 3];
+/* L50: */
+ }
+ return 0;
+} /* daxpy_ */
diff --git a/BLAS/SRC/dcabs1.c b/BLAS/SRC/dcabs1.c
new file mode 100644
index 0000000..0e926f0
--- /dev/null
+++ b/BLAS/SRC/dcabs1.c
@@ -0,0 +1,36 @@
+/* dcabs1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dcabs1_(doublecomplex *z__)
+{
+ /* System generated locals */
+ doublereal ret_val, d__1, d__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. */
+/* Purpose */
+/* ======= */
+
+/* DCABS1 computes absolute value of a double complex number */
+
+/* .. Intrinsic Functions .. */
+
+ ret_val = (d__1 = z__->r, abs(d__1)) + (d__2 = d_imag(z__), abs(d__2));
+ return ret_val;
+} /* dcabs1_ */
diff --git a/BLAS/SRC/dcopy.c b/BLAS/SRC/dcopy.c
new file mode 100644
index 0000000..9033cce
--- /dev/null
+++ b/BLAS/SRC/dcopy.c
@@ -0,0 +1,107 @@
+/* dcopy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dcopy_(integer *n, doublereal *dx, integer *incx,
+ doublereal *dy, integer *incy)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, m, ix, iy, mp1;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* copies a vector, x, to a vector, y. */
+/* uses unrolled loops for increments equal to one. */
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --dy;
+ --dx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* code for unequal increments or equal increments */
+/* not equal to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dy[iy] = dx[ix];
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ return 0;
+
+/* code for both increments equal to 1 */
+
+
+/* clean-up loop */
+
+L20:
+ m = *n % 7;
+ if (m == 0) {
+ goto L40;
+ }
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dy[i__] = dx[i__];
+/* L30: */
+ }
+ if (*n < 7) {
+ return 0;
+ }
+L40:
+ mp1 = m + 1;
+ i__1 = *n;
+ for (i__ = mp1; i__ <= i__1; i__ += 7) {
+ dy[i__] = dx[i__];
+ dy[i__ + 1] = dx[i__ + 1];
+ dy[i__ + 2] = dx[i__ + 2];
+ dy[i__ + 3] = dx[i__ + 3];
+ dy[i__ + 4] = dx[i__ + 4];
+ dy[i__ + 5] = dx[i__ + 5];
+ dy[i__ + 6] = dx[i__ + 6];
+/* L50: */
+ }
+ return 0;
+} /* dcopy_ */
diff --git a/BLAS/SRC/ddot.c b/BLAS/SRC/ddot.c
new file mode 100644
index 0000000..331fe0a
--- /dev/null
+++ b/BLAS/SRC/ddot.c
@@ -0,0 +1,110 @@
+/* ddot.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy,
+ integer *incy)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal ret_val;
+
+ /* Local variables */
+ integer i__, m, ix, iy, mp1;
+ doublereal dtemp;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* forms the dot product of two vectors. */
+/* uses unrolled loops for increments equal to one. */
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --dy;
+ --dx;
+
+ /* Function Body */
+ ret_val = 0.;
+ dtemp = 0.;
+ if (*n <= 0) {
+ return ret_val;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* code for unequal increments or equal increments */
+/* not equal to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dtemp += dx[ix] * dy[iy];
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ ret_val = dtemp;
+ return ret_val;
+
+/* code for both increments equal to 1 */
+
+
+/* clean-up loop */
+
+L20:
+ m = *n % 5;
+ if (m == 0) {
+ goto L40;
+ }
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dtemp += dx[i__] * dy[i__];
+/* L30: */
+ }
+ if (*n < 5) {
+ goto L60;
+ }
+L40:
+ mp1 = m + 1;
+ i__1 = *n;
+ for (i__ = mp1; i__ <= i__1; i__ += 5) {
+ dtemp = dtemp + dx[i__] * dy[i__] + dx[i__ + 1] * dy[i__ + 1] + dx[
+ i__ + 2] * dy[i__ + 2] + dx[i__ + 3] * dy[i__ + 3] + dx[i__ +
+ 4] * dy[i__ + 4];
+/* L50: */
+ }
+L60:
+ ret_val = dtemp;
+ return ret_val;
+} /* ddot_ */
diff --git a/BLAS/SRC/dgbmv.c b/BLAS/SRC/dgbmv.c
new file mode 100644
index 0000000..d734d27
--- /dev/null
+++ b/BLAS/SRC/dgbmv.c
@@ -0,0 +1,369 @@
+/* dgbmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgbmv_(char *trans, integer *m, integer *n, integer *kl,
+ integer *ku, doublereal *alpha, doublereal *a, integer *lda,
+ doublereal *x, integer *incx, doublereal *beta, doublereal *y,
+ integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+
+ /* Local variables */
+ integer i__, j, k, ix, iy, jx, jy, kx, ky, kup1, info;
+ doublereal temp;
+ integer lenx, leny;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGBMV performs one of the matrix-vector operations */
+
+/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are vectors and A is an */
+/* m by n band matrix, with kl sub-diagonals and ku super-diagonals. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */
+
+/* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. */
+
+/* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix A. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* KL - INTEGER. */
+/* On entry, KL specifies the number of sub-diagonals of the */
+/* matrix A. KL must satisfy 0 .le. KL. */
+/* Unchanged on exit. */
+
+/* KU - INTEGER. */
+/* On entry, KU specifies the number of super-diagonals of the */
+/* matrix A. KU must satisfy 0 .le. KU. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION. */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/* Before entry, the leading ( kl + ku + 1 ) by n part of the */
+/* array A must contain the matrix of coefficients, supplied */
+/* column by column, with the leading diagonal of the matrix in */
+/* row ( ku + 1 ) of the array, the first super-diagonal */
+/* starting at position 2 in row ku, the first sub-diagonal */
+/* starting at position 1 in row ( ku + 2 ), and so on. */
+/* Elements in the array A that do not correspond to elements */
+/* in the band matrix (such as the top left ku by ku triangle) */
+/* are not referenced. */
+/* The following program segment will transfer a band matrix */
+/* from conventional full matrix storage to band storage: */
+
+/* DO 20, J = 1, N */
+/* K = KU + 1 - J */
+/* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) */
+/* A( K + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* ( kl + ku + 1 ). */
+/* Unchanged on exit. */
+
+/* X - DOUBLE PRECISION array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - DOUBLE PRECISION. */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - DOUBLE PRECISION array of DIMENSION at least */
+/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
+/* Before entry, the incremented array Y must contain the */
+/* vector y. On exit, Y is overwritten by the updated vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C")
+ ) {
+ info = 1;
+ } else if (*m < 0) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*kl < 0) {
+ info = 4;
+ } else if (*ku < 0) {
+ info = 5;
+ } else if (*lda < *kl + *ku + 1) {
+ info = 8;
+ } else if (*incx == 0) {
+ info = 10;
+ } else if (*incy == 0) {
+ info = 13;
+ }
+ if (info != 0) {
+ xerbla_("DGBMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) {
+ return 0;
+ }
+
+/* Set LENX and LENY, the lengths of the vectors x and y, and set */
+/* up the start points in X and Y. */
+
+ if (lsame_(trans, "N")) {
+ lenx = *n;
+ leny = *m;
+ } else {
+ lenx = *m;
+ leny = *n;
+ }
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (lenx - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (leny - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through the band part of A. */
+
+/* First form y := beta*y. */
+
+ if (*beta != 1.) {
+ if (*incy == 1) {
+ if (*beta == 0.) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[i__] = 0.;
+/* L10: */
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[i__] = *beta * y[i__];
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (*beta == 0.) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[iy] = 0.;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[iy] = *beta * y[iy];
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (*alpha == 0.) {
+ return 0;
+ }
+ kup1 = *ku + 1;
+ if (lsame_(trans, "N")) {
+
+/* Form y := alpha*A*x + y. */
+
+ jx = kx;
+ if (*incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.) {
+ temp = *alpha * x[jx];
+ k = kup1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__4 = min(i__5,i__6);
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ y[i__] += temp * a[k + i__ + j * a_dim1];
+/* L50: */
+ }
+ }
+ jx += *incx;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.) {
+ temp = *alpha * x[jx];
+ iy = ky;
+ k = kup1 - j;
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__3 = min(i__5,i__6);
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ y[iy] += temp * a[k + i__ + j * a_dim1];
+ iy += *incy;
+/* L70: */
+ }
+ }
+ jx += *incx;
+ if (j > *ku) {
+ ky += *incy;
+ }
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y := alpha*A'*x + y. */
+
+ jy = ky;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = 0.;
+ k = kup1 - j;
+/* Computing MAX */
+ i__3 = 1, i__4 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__2 = min(i__5,i__6);
+ for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) {
+ temp += a[k + i__ + j * a_dim1] * x[i__];
+/* L90: */
+ }
+ y[jy] += *alpha * temp;
+ jy += *incy;
+/* L100: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = 0.;
+ ix = kx;
+ k = kup1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__4 = min(i__5,i__6);
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ temp += a[k + i__ + j * a_dim1] * x[ix];
+ ix += *incx;
+/* L110: */
+ }
+ y[jy] += *alpha * temp;
+ jy += *incy;
+ if (j > *ku) {
+ kx += *incx;
+ }
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DGBMV . */
+
+} /* dgbmv_ */
diff --git a/BLAS/SRC/dgemm.c b/BLAS/SRC/dgemm.c
new file mode 100644
index 0000000..b802cb0
--- /dev/null
+++ b/BLAS/SRC/dgemm.c
@@ -0,0 +1,389 @@
+/* dgemm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgemm_(char *transa, char *transb, integer *m, integer *
+ n, integer *k, doublereal *alpha, doublereal *a, integer *lda,
+ doublereal *b, integer *ldb, doublereal *beta, doublereal *c__,
+ integer *ldc)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3;
+
+ /* Local variables */
+ integer i__, j, l, info;
+ logical nota, notb;
+ doublereal temp;
+ integer ncola;
+ extern logical lsame_(char *, char *);
+ integer nrowa, nrowb;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGEMM performs one of the matrix-matrix operations */
+
+/* C := alpha*op( A )*op( B ) + beta*C, */
+
+/* where op( X ) is one of */
+
+/* op( X ) = X or op( X ) = X', */
+
+/* alpha and beta are scalars, and A, B and C are matrices, with op( A ) */
+/* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANSA - CHARACTER*1. */
+/* On entry, TRANSA specifies the form of op( A ) to be used in */
+/* the matrix multiplication as follows: */
+
+/* TRANSA = 'N' or 'n', op( A ) = A. */
+
+/* TRANSA = 'T' or 't', op( A ) = A'. */
+
+/* TRANSA = 'C' or 'c', op( A ) = A'. */
+
+/* Unchanged on exit. */
+
+/* TRANSB - CHARACTER*1. */
+/* On entry, TRANSB specifies the form of op( B ) to be used in */
+/* the matrix multiplication as follows: */
+
+/* TRANSB = 'N' or 'n', op( B ) = B. */
+
+/* TRANSB = 'T' or 't', op( B ) = B'. */
+
+/* TRANSB = 'C' or 'c', op( B ) = B'. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix */
+/* op( A ) and of the matrix C. M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix */
+/* op( B ) and the number of columns of the matrix C. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry, K specifies the number of columns of the matrix */
+/* op( A ) and the number of rows of the matrix op( B ). K must */
+/* be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION. */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is */
+/* k when TRANSA = 'N' or 'n', and is m otherwise. */
+/* Before entry with TRANSA = 'N' or 'n', the leading m by k */
+/* part of the array A must contain the matrix A, otherwise */
+/* the leading k by m part of the array A must contain the */
+/* matrix A. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When TRANSA = 'N' or 'n' then */
+/* LDA must be at least max( 1, m ), otherwise LDA must be at */
+/* least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is */
+/* n when TRANSB = 'N' or 'n', and is k otherwise. */
+/* Before entry with TRANSB = 'N' or 'n', the leading k by n */
+/* part of the array B must contain the matrix B, otherwise */
+/* the leading n by k part of the array B must contain the */
+/* matrix B. */
+/* Unchanged on exit. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. When TRANSB = 'N' or 'n' then */
+/* LDB must be at least max( 1, k ), otherwise LDB must be at */
+/* least max( 1, n ). */
+/* Unchanged on exit. */
+
+/* BETA - DOUBLE PRECISION. */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then C need not be set on input. */
+/* Unchanged on exit. */
+
+/* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */
+/* Before entry, the leading m by n part of the array C must */
+/* contain the matrix C, except when beta is zero, in which */
+/* case C need not be set on entry. */
+/* On exit, the array C is overwritten by the m by n matrix */
+/* ( alpha*op( A )*op( B ) + beta*C ). */
+
+/* LDC - INTEGER. */
+/* On entry, LDC specifies the first dimension of C as declared */
+/* in the calling (sub) program. LDC must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Set NOTA and NOTB as true if A and B respectively are not */
+/* transposed and set NROWA, NCOLA and NROWB as the number of rows */
+/* and columns of A and the number of rows of B respectively. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ nota = lsame_(transa, "N");
+ notb = lsame_(transb, "N");
+ if (nota) {
+ nrowa = *m;
+ ncola = *k;
+ } else {
+ nrowa = *k;
+ ncola = *m;
+ }
+ if (notb) {
+ nrowb = *k;
+ } else {
+ nrowb = *n;
+ }
+
+/* Test the input parameters. */
+
+ info = 0;
+ if (! nota && ! lsame_(transa, "C") && ! lsame_(
+ transa, "T")) {
+ info = 1;
+ } else if (! notb && ! lsame_(transb, "C") && !
+ lsame_(transb, "T")) {
+ info = 2;
+ } else if (*m < 0) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*k < 0) {
+ info = 5;
+ } else if (*lda < max(1,nrowa)) {
+ info = 8;
+ } else if (*ldb < max(1,nrowb)) {
+ info = 10;
+ } else if (*ldc < max(1,*m)) {
+ info = 13;
+ }
+ if (info != 0) {
+ xerbla_("DGEMM ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
+ return 0;
+ }
+
+/* And if alpha.eq.zero. */
+
+ if (*alpha == 0.) {
+ if (*beta == 0.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (notb) {
+ if (nota) {
+
+/* Form C := alpha*A*B + beta*C. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*beta == 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.;
+/* L50: */
+ }
+ } else if (*beta != 1.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L60: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ if (b[l + j * b_dim1] != 0.) {
+ temp = *alpha * b[l + j * b_dim1];
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ c__[i__ + j * c_dim1] += temp * a[i__ + l *
+ a_dim1];
+/* L70: */
+ }
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+ } else {
+
+/* Form C := alpha*A'*B + beta*C */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = 0.;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ temp += a[l + i__ * a_dim1] * b[l + j * b_dim1];
+/* L100: */
+ }
+ if (*beta == 0.) {
+ c__[i__ + j * c_dim1] = *alpha * temp;
+ } else {
+ c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
+ i__ + j * c_dim1];
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+ }
+ } else {
+ if (nota) {
+
+/* Form C := alpha*A*B' + beta*C */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*beta == 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.;
+/* L130: */
+ }
+ } else if (*beta != 1.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L140: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ if (b[j + l * b_dim1] != 0.) {
+ temp = *alpha * b[j + l * b_dim1];
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ c__[i__ + j * c_dim1] += temp * a[i__ + l *
+ a_dim1];
+/* L150: */
+ }
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+ } else {
+
+/* Form C := alpha*A'*B' + beta*C */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = 0.;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ temp += a[l + i__ * a_dim1] * b[j + l * b_dim1];
+/* L180: */
+ }
+ if (*beta == 0.) {
+ c__[i__ + j * c_dim1] = *alpha * temp;
+ } else {
+ c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
+ i__ + j * c_dim1];
+ }
+/* L190: */
+ }
+/* L200: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DGEMM . */
+
+} /* dgemm_ */
diff --git a/BLAS/SRC/dgemv.c b/BLAS/SRC/dgemv.c
new file mode 100644
index 0000000..b82a5b3
--- /dev/null
+++ b/BLAS/SRC/dgemv.c
@@ -0,0 +1,312 @@
+/* dgemv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgemv_(char *trans, integer *m, integer *n, doublereal *
+ alpha, doublereal *a, integer *lda, doublereal *x, integer *incx,
+ doublereal *beta, doublereal *y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, ix, iy, jx, jy, kx, ky, info;
+ doublereal temp;
+ integer lenx, leny;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGEMV performs one of the matrix-vector operations */
+
+/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are vectors and A is an */
+/* m by n matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */
+
+/* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. */
+
+/* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix A. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION. */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+/* X - DOUBLE PRECISION array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - DOUBLE PRECISION. */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - DOUBLE PRECISION array of DIMENSION at least */
+/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
+/* Before entry with BETA non-zero, the incremented array Y */
+/* must contain the vector y. On exit, Y is overwritten by the */
+/* updated vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C")
+ ) {
+ info = 1;
+ } else if (*m < 0) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*lda < max(1,*m)) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ } else if (*incy == 0) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("DGEMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) {
+ return 0;
+ }
+
+/* Set LENX and LENY, the lengths of the vectors x and y, and set */
+/* up the start points in X and Y. */
+
+ if (lsame_(trans, "N")) {
+ lenx = *n;
+ leny = *m;
+ } else {
+ lenx = *m;
+ leny = *n;
+ }
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (lenx - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (leny - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through A. */
+
+/* First form y := beta*y. */
+
+ if (*beta != 1.) {
+ if (*incy == 1) {
+ if (*beta == 0.) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[i__] = 0.;
+/* L10: */
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[i__] = *beta * y[i__];
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (*beta == 0.) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[iy] = 0.;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[iy] = *beta * y[iy];
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (*alpha == 0.) {
+ return 0;
+ }
+ if (lsame_(trans, "N")) {
+
+/* Form y := alpha*A*x + y. */
+
+ jx = kx;
+ if (*incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.) {
+ temp = *alpha * x[jx];
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ y[i__] += temp * a[i__ + j * a_dim1];
+/* L50: */
+ }
+ }
+ jx += *incx;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.) {
+ temp = *alpha * x[jx];
+ iy = ky;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ y[iy] += temp * a[i__ + j * a_dim1];
+ iy += *incy;
+/* L70: */
+ }
+ }
+ jx += *incx;
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y := alpha*A'*x + y. */
+
+ jy = ky;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = 0.;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp += a[i__ + j * a_dim1] * x[i__];
+/* L90: */
+ }
+ y[jy] += *alpha * temp;
+ jy += *incy;
+/* L100: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = 0.;
+ ix = kx;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp += a[i__ + j * a_dim1] * x[ix];
+ ix += *incx;
+/* L110: */
+ }
+ y[jy] += *alpha * temp;
+ jy += *incy;
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DGEMV . */
+
+} /* dgemv_ */
diff --git a/BLAS/SRC/dger.c b/BLAS/SRC/dger.c
new file mode 100644
index 0000000..085833b
--- /dev/null
+++ b/BLAS/SRC/dger.c
@@ -0,0 +1,194 @@
+/* dger.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dger_(integer *m, integer *n, doublereal *alpha,
+ doublereal *x, integer *incx, doublereal *y, integer *incy,
+ doublereal *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, ix, jy, kx, info;
+ doublereal temp;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGER performs the rank 1 operation */
+
+/* A := alpha*x*y' + A, */
+
+/* where alpha is a scalar, x is an m element vector, y is an n element */
+/* vector and A is an m by n matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix A. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION. */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X - DOUBLE PRECISION array of dimension at least */
+/* ( 1 + ( m - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the m */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* Y - DOUBLE PRECISION array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. */
+/* Unchanged on exit. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. On exit, A is */
+/* overwritten by the updated matrix. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ --y;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ info = 0;
+ if (*m < 0) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ } else if (*incy == 0) {
+ info = 7;
+ } else if (*lda < max(1,*m)) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("DGER ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || *alpha == 0.) {
+ return 0;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through A. */
+
+ if (*incy > 0) {
+ jy = 1;
+ } else {
+ jy = 1 - (*n - 1) * *incy;
+ }
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (y[jy] != 0.) {
+ temp = *alpha * y[jy];
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] += x[i__] * temp;
+/* L10: */
+ }
+ }
+ jy += *incy;
+/* L20: */
+ }
+ } else {
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*m - 1) * *incx;
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (y[jy] != 0.) {
+ temp = *alpha * y[jy];
+ ix = kx;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] += x[ix] * temp;
+ ix += *incx;
+/* L30: */
+ }
+ }
+ jy += *incy;
+/* L40: */
+ }
+ }
+
+ return 0;
+
+/* End of DGER . */
+
+} /* dger_ */
diff --git a/BLAS/SRC/dnrm2.c b/BLAS/SRC/dnrm2.c
new file mode 100644
index 0000000..8c50ff5
--- /dev/null
+++ b/BLAS/SRC/dnrm2.c
@@ -0,0 +1,95 @@
+/* dnrm2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dnrm2_(integer *n, doublereal *x, integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal ret_val, d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer ix;
+ doublereal ssq, norm, scale, absxi;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DNRM2 returns the euclidean norm of a vector via the function */
+/* name, so that */
+
+/* DNRM2 := sqrt( x'*x ) */
+
+
+/* -- This version written on 25-October-1982. */
+/* Modified on 14-October-1993 to inline the call to DLASSQ. */
+/* Sven Hammarling, Nag Ltd. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --x;
+
+ /* Function Body */
+ if (*n < 1 || *incx < 1) {
+ norm = 0.;
+ } else if (*n == 1) {
+ norm = abs(x[1]);
+ } else {
+ scale = 0.;
+ ssq = 1.;
+/* The following loop is equivalent to this call to the LAPACK */
+/* auxiliary routine: */
+/* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) */
+
+ i__1 = (*n - 1) * *incx + 1;
+ i__2 = *incx;
+ for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
+ if (x[ix] != 0.) {
+ absxi = (d__1 = x[ix], abs(d__1));
+ if (scale < absxi) {
+/* Computing 2nd power */
+ d__1 = scale / absxi;
+ ssq = ssq * (d__1 * d__1) + 1.;
+ scale = absxi;
+ } else {
+/* Computing 2nd power */
+ d__1 = absxi / scale;
+ ssq += d__1 * d__1;
+ }
+ }
+/* L10: */
+ }
+ norm = scale * sqrt(ssq);
+ }
+
+ ret_val = norm;
+ return ret_val;
+
+/* End of DNRM2. */
+
+} /* dnrm2_ */
diff --git a/BLAS/SRC/drot.c b/BLAS/SRC/drot.c
new file mode 100644
index 0000000..d4bc6bd
--- /dev/null
+++ b/BLAS/SRC/drot.c
@@ -0,0 +1,86 @@
+/* drot.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int drot_(integer *n, doublereal *dx, integer *incx,
+ doublereal *dy, integer *incy, doublereal *c__, doublereal *s)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, ix, iy;
+ doublereal dtemp;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* applies a plane rotation. */
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+ /* Parameter adjustments */
+ --dy;
+ --dx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* code for unequal increments or equal increments not equal */
+/* to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dtemp = *c__ * dx[ix] + *s * dy[iy];
+ dy[iy] = *c__ * dy[iy] - *s * dx[ix];
+ dx[ix] = dtemp;
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ return 0;
+
+/* code for both increments equal to 1 */
+
+L20:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dtemp = *c__ * dx[i__] + *s * dy[i__];
+ dy[i__] = *c__ * dy[i__] - *s * dx[i__];
+ dx[i__] = dtemp;
+/* L30: */
+ }
+ return 0;
+} /* drot_ */
diff --git a/BLAS/SRC/drotg.c b/BLAS/SRC/drotg.c
new file mode 100644
index 0000000..b2d9aa4
--- /dev/null
+++ b/BLAS/SRC/drotg.c
@@ -0,0 +1,79 @@
+/* drotg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b4 = 1.;
+
+/* Subroutine */ int drotg_(doublereal *da, doublereal *db, doublereal *c__,
+ doublereal *s)
+{
+ /* System generated locals */
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ doublereal r__, z__, roe, scale;
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* construct givens plane rotation. */
+/* jack dongarra, linpack, 3/11/78. */
+
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ roe = *db;
+ if (abs(*da) > abs(*db)) {
+ roe = *da;
+ }
+ scale = abs(*da) + abs(*db);
+ if (scale != 0.) {
+ goto L10;
+ }
+ *c__ = 1.;
+ *s = 0.;
+ r__ = 0.;
+ z__ = 0.;
+ goto L20;
+L10:
+/* Computing 2nd power */
+ d__1 = *da / scale;
+/* Computing 2nd power */
+ d__2 = *db / scale;
+ r__ = scale * sqrt(d__1 * d__1 + d__2 * d__2);
+ r__ = d_sign(&c_b4, &roe) * r__;
+ *c__ = *da / r__;
+ *s = *db / r__;
+ z__ = 1.;
+ if (abs(*da) > abs(*db)) {
+ z__ = *s;
+ }
+ if (abs(*db) >= abs(*da) && *c__ != 0.) {
+ z__ = 1. / *c__;
+ }
+L20:
+ *da = r__;
+ *db = z__;
+ return 0;
+} /* drotg_ */
diff --git a/BLAS/SRC/drotm.c b/BLAS/SRC/drotm.c
new file mode 100644
index 0000000..90815c2
--- /dev/null
+++ b/BLAS/SRC/drotm.c
@@ -0,0 +1,215 @@
+/* drotm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int drotm_(integer *n, doublereal *dx, integer *incx,
+ doublereal *dy, integer *incy, doublereal *dparam)
+{
+ /* Initialized data */
+
+ static doublereal zero = 0.;
+ static doublereal two = 2.;
+
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__;
+ doublereal w, z__;
+ integer kx, ky;
+ doublereal dh11, dh12, dh21, dh22, dflag;
+ integer nsteps;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX */
+
+/* (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN */
+/* (DY**T) */
+
+/* DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE */
+/* LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY. */
+/* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */
+
+/* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */
+
+/* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */
+/* H=( ) ( ) ( ) ( ) */
+/* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */
+/* SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* number of elements in input vector(s) */
+
+/* DX (input/output) DOUBLE PRECISION array, dimension N */
+/* double precision vector with N elements */
+
+/* INCX (input) INTEGER */
+/* storage spacing between elements of DX */
+
+/* DY (input/output) DOUBLE PRECISION array, dimension N */
+/* double precision vector with N elements */
+
+/* INCY (input) INTEGER */
+/* storage spacing between elements of DY */
+
+/* DPARAM (input/output) DOUBLE PRECISION array, dimension 5 */
+/* DPARAM(1)=DFLAG */
+/* DPARAM(2)=DH11 */
+/* DPARAM(3)=DH21 */
+/* DPARAM(4)=DH12 */
+/* DPARAM(5)=DH22 */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --dparam;
+ --dy;
+ --dx;
+
+ /* Function Body */
+/* .. */
+
+ dflag = dparam[1];
+ if (*n <= 0 || dflag + two == zero) {
+ goto L140;
+ }
+ if (! (*incx == *incy && *incx > 0)) {
+ goto L70;
+ }
+
+ nsteps = *n * *incx;
+ if (dflag < 0.) {
+ goto L50;
+ } else if (dflag == 0) {
+ goto L10;
+ } else {
+ goto L30;
+ }
+L10:
+ dh12 = dparam[4];
+ dh21 = dparam[3];
+ i__1 = nsteps;
+ i__2 = *incx;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ w = dx[i__];
+ z__ = dy[i__];
+ dx[i__] = w + z__ * dh12;
+ dy[i__] = w * dh21 + z__;
+/* L20: */
+ }
+ goto L140;
+L30:
+ dh11 = dparam[2];
+ dh22 = dparam[5];
+ i__2 = nsteps;
+ i__1 = *incx;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
+ w = dx[i__];
+ z__ = dy[i__];
+ dx[i__] = w * dh11 + z__;
+ dy[i__] = -w + dh22 * z__;
+/* L40: */
+ }
+ goto L140;
+L50:
+ dh11 = dparam[2];
+ dh12 = dparam[4];
+ dh21 = dparam[3];
+ dh22 = dparam[5];
+ i__1 = nsteps;
+ i__2 = *incx;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ w = dx[i__];
+ z__ = dy[i__];
+ dx[i__] = w * dh11 + z__ * dh12;
+ dy[i__] = w * dh21 + z__ * dh22;
+/* L60: */
+ }
+ goto L140;
+L70:
+ kx = 1;
+ ky = 1;
+ if (*incx < 0) {
+ kx = (1 - *n) * *incx + 1;
+ }
+ if (*incy < 0) {
+ ky = (1 - *n) * *incy + 1;
+ }
+
+ if (dflag < 0.) {
+ goto L120;
+ } else if (dflag == 0) {
+ goto L80;
+ } else {
+ goto L100;
+ }
+L80:
+ dh12 = dparam[4];
+ dh21 = dparam[3];
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ w = dx[kx];
+ z__ = dy[ky];
+ dx[kx] = w + z__ * dh12;
+ dy[ky] = w * dh21 + z__;
+ kx += *incx;
+ ky += *incy;
+/* L90: */
+ }
+ goto L140;
+L100:
+ dh11 = dparam[2];
+ dh22 = dparam[5];
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ w = dx[kx];
+ z__ = dy[ky];
+ dx[kx] = w * dh11 + z__;
+ dy[ky] = -w + dh22 * z__;
+ kx += *incx;
+ ky += *incy;
+/* L110: */
+ }
+ goto L140;
+L120:
+ dh11 = dparam[2];
+ dh12 = dparam[4];
+ dh21 = dparam[3];
+ dh22 = dparam[5];
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ w = dx[kx];
+ z__ = dy[ky];
+ dx[kx] = w * dh11 + z__ * dh12;
+ dy[ky] = w * dh21 + z__ * dh22;
+ kx += *incx;
+ ky += *incy;
+/* L130: */
+ }
+L140:
+ return 0;
+} /* drotm_ */
diff --git a/BLAS/SRC/drotmg.c b/BLAS/SRC/drotmg.c
new file mode 100644
index 0000000..9469417
--- /dev/null
+++ b/BLAS/SRC/drotmg.c
@@ -0,0 +1,293 @@
+/* drotmg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int drotmg_(doublereal *dd1, doublereal *dd2, doublereal *
+ dx1, doublereal *dy1, doublereal *dparam)
+{
+ /* Initialized data */
+
+ static doublereal zero = 0.;
+ static doublereal one = 1.;
+ static doublereal two = 2.;
+ static doublereal gam = 4096.;
+ static doublereal gamsq = 16777216.;
+ static doublereal rgamsq = 5.9604645e-8;
+
+ /* Format strings */
+ static char fmt_120[] = "";
+ static char fmt_150[] = "";
+ static char fmt_180[] = "";
+ static char fmt_210[] = "";
+
+ /* System generated locals */
+ doublereal d__1;
+
+ /* Local variables */
+ doublereal du, dp1, dp2, dq1, dq2, dh11, dh12, dh21, dh22;
+ integer igo;
+ doublereal dflag, dtemp;
+
+ /* Assigned format variables */
+ static char *igo_fmt;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */
+/* THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)* */
+/* DY2)**T. */
+/* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */
+
+/* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */
+
+/* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */
+/* H=( ) ( ) ( ) ( ) */
+/* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */
+/* LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 */
+/* RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE */
+/* VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) */
+
+/* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */
+/* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */
+/* OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */
+
+
+/* Arguments */
+/* ========= */
+
+/* DD1 (input/output) DOUBLE PRECISION */
+
+/* DD2 (input/output) DOUBLE PRECISION */
+
+/* DX1 (input/output) DOUBLE PRECISION */
+
+/* DY1 (input) DOUBLE PRECISION */
+
+/* DPARAM (input/output) DOUBLE PRECISION array, dimension 5 */
+/* DPARAM(1)=DFLAG */
+/* DPARAM(2)=DH11 */
+/* DPARAM(3)=DH21 */
+/* DPARAM(4)=DH12 */
+/* DPARAM(5)=DH22 */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+
+ /* Parameter adjustments */
+ --dparam;
+
+ /* Function Body */
+/* .. */
+ if (! (*dd1 < zero)) {
+ goto L10;
+ }
+/* GO ZERO-H-D-AND-DX1.. */
+ goto L60;
+L10:
+/* CASE-DD1-NONNEGATIVE */
+ dp2 = *dd2 * *dy1;
+ if (! (dp2 == zero)) {
+ goto L20;
+ }
+ dflag = -two;
+ goto L260;
+/* REGULAR-CASE.. */
+L20:
+ dp1 = *dd1 * *dx1;
+ dq2 = dp2 * *dy1;
+ dq1 = dp1 * *dx1;
+
+ if (! (abs(dq1) > abs(dq2))) {
+ goto L40;
+ }
+ dh21 = -(*dy1) / *dx1;
+ dh12 = dp2 / dp1;
+
+ du = one - dh12 * dh21;
+
+ if (! (du <= zero)) {
+ goto L30;
+ }
+/* GO ZERO-H-D-AND-DX1.. */
+ goto L60;
+L30:
+ dflag = zero;
+ *dd1 /= du;
+ *dd2 /= du;
+ *dx1 *= du;
+/* GO SCALE-CHECK.. */
+ goto L100;
+L40:
+ if (! (dq2 < zero)) {
+ goto L50;
+ }
+/* GO ZERO-H-D-AND-DX1.. */
+ goto L60;
+L50:
+ dflag = one;
+ dh11 = dp1 / dp2;
+ dh22 = *dx1 / *dy1;
+ du = one + dh11 * dh22;
+ dtemp = *dd2 / du;
+ *dd2 = *dd1 / du;
+ *dd1 = dtemp;
+ *dx1 = *dy1 * du;
+/* GO SCALE-CHECK */
+ goto L100;
+/* PROCEDURE..ZERO-H-D-AND-DX1.. */
+L60:
+ dflag = -one;
+ dh11 = zero;
+ dh12 = zero;
+ dh21 = zero;
+ dh22 = zero;
+
+ *dd1 = zero;
+ *dd2 = zero;
+ *dx1 = zero;
+/* RETURN.. */
+ goto L220;
+/* PROCEDURE..FIX-H.. */
+L70:
+ if (! (dflag >= zero)) {
+ goto L90;
+ }
+
+ if (! (dflag == zero)) {
+ goto L80;
+ }
+ dh11 = one;
+ dh22 = one;
+ dflag = -one;
+ goto L90;
+L80:
+ dh21 = -one;
+ dh12 = one;
+ dflag = -one;
+L90:
+ switch (igo) {
+ case 0: goto L120;
+ case 1: goto L150;
+ case 2: goto L180;
+ case 3: goto L210;
+ }
+/* PROCEDURE..SCALE-CHECK */
+L100:
+L110:
+ if (! (*dd1 <= rgamsq)) {
+ goto L130;
+ }
+ if (*dd1 == zero) {
+ goto L160;
+ }
+ igo = 0;
+ igo_fmt = fmt_120;
+/* FIX-H.. */
+ goto L70;
+L120:
+/* Computing 2nd power */
+ d__1 = gam;
+ *dd1 *= d__1 * d__1;
+ *dx1 /= gam;
+ dh11 /= gam;
+ dh12 /= gam;
+ goto L110;
+L130:
+L140:
+ if (! (*dd1 >= gamsq)) {
+ goto L160;
+ }
+ igo = 1;
+ igo_fmt = fmt_150;
+/* FIX-H.. */
+ goto L70;
+L150:
+/* Computing 2nd power */
+ d__1 = gam;
+ *dd1 /= d__1 * d__1;
+ *dx1 *= gam;
+ dh11 *= gam;
+ dh12 *= gam;
+ goto L140;
+L160:
+L170:
+ if (! (abs(*dd2) <= rgamsq)) {
+ goto L190;
+ }
+ if (*dd2 == zero) {
+ goto L220;
+ }
+ igo = 2;
+ igo_fmt = fmt_180;
+/* FIX-H.. */
+ goto L70;
+L180:
+/* Computing 2nd power */
+ d__1 = gam;
+ *dd2 *= d__1 * d__1;
+ dh21 /= gam;
+ dh22 /= gam;
+ goto L170;
+L190:
+L200:
+ if (! (abs(*dd2) >= gamsq)) {
+ goto L220;
+ }
+ igo = 3;
+ igo_fmt = fmt_210;
+/* FIX-H.. */
+ goto L70;
+L210:
+/* Computing 2nd power */
+ d__1 = gam;
+ *dd2 /= d__1 * d__1;
+ dh21 *= gam;
+ dh22 *= gam;
+ goto L200;
+L220:
+ if (dflag < 0.) {
+ goto L250;
+ } else if (dflag == 0) {
+ goto L230;
+ } else {
+ goto L240;
+ }
+L230:
+ dparam[3] = dh21;
+ dparam[4] = dh12;
+ goto L260;
+L240:
+ dparam[2] = dh11;
+ dparam[5] = dh22;
+ goto L260;
+L250:
+ dparam[2] = dh11;
+ dparam[3] = dh21;
+ dparam[4] = dh12;
+ dparam[5] = dh22;
+L260:
+ dparam[1] = dflag;
+ return 0;
+} /* drotmg_ */
diff --git a/BLAS/SRC/dsbmv.c b/BLAS/SRC/dsbmv.c
new file mode 100644
index 0000000..bdce6df
--- /dev/null
+++ b/BLAS/SRC/dsbmv.c
@@ -0,0 +1,364 @@
+/* dsbmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dsbmv_(char *uplo, integer *n, integer *k, doublereal *
+ alpha, doublereal *a, integer *lda, doublereal *x, integer *incx,
+ doublereal *beta, doublereal *y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, l, ix, iy, jx, jy, kx, ky, info;
+ doublereal temp1, temp2;
+ extern logical lsame_(char *, char *);
+ integer kplus1;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSBMV performs the matrix-vector operation */
+
+/* y := alpha*A*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are n element vectors and */
+/* A is an n by n symmetric band matrix, with k super-diagonals. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the band matrix A is being supplied as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* being supplied. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* being supplied. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry, K specifies the number of super-diagonals of the */
+/* matrix A. K must satisfy 0 .le. K. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION. */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
+/* by n part of the array A must contain the upper triangular */
+/* band part of the symmetric matrix, supplied column by */
+/* column, with the leading diagonal of the matrix in row */
+/* ( k + 1 ) of the array, the first super-diagonal starting at */
+/* position 2 in row k, and so on. The top left k by k triangle */
+/* of the array A is not referenced. */
+/* The following program segment will transfer the upper */
+/* triangular part of a symmetric band matrix from conventional */
+/* full matrix storage to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = K + 1 - J */
+/* DO 10, I = MAX( 1, J - K ), J */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
+/* by n part of the array A must contain the lower triangular */
+/* band part of the symmetric matrix, supplied column by */
+/* column, with the leading diagonal of the matrix in row 1 of */
+/* the array, the first sub-diagonal starting at position 1 in */
+/* row 2, and so on. The bottom right k by k triangle of the */
+/* array A is not referenced. */
+/* The following program segment will transfer the lower */
+/* triangular part of a symmetric band matrix from conventional */
+/* full matrix storage to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = 1 - J */
+/* DO 10, I = J, MIN( N, J + K ) */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* ( k + 1 ). */
+/* Unchanged on exit. */
+
+/* X - DOUBLE PRECISION array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - DOUBLE PRECISION. */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+/* Y - DOUBLE PRECISION array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the */
+/* vector y. On exit, Y is overwritten by the updated vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*k < 0) {
+ info = 3;
+ } else if (*lda < *k + 1) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ } else if (*incy == 0) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("DSBMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0. && *beta == 1.) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of the array A */
+/* are accessed sequentially with one pass through A. */
+
+/* First form y := beta*y. */
+
+ if (*beta != 1.) {
+ if (*incy == 1) {
+ if (*beta == 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[i__] = 0.;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[i__] = *beta * y[i__];
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (*beta == 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[iy] = 0.;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[iy] = *beta * y[iy];
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (*alpha == 0.) {
+ return 0;
+ }
+ if (lsame_(uplo, "U")) {
+
+/* Form y when upper triangle of A is stored. */
+
+ kplus1 = *k + 1;
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[j];
+ temp2 = 0.;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ y[i__] += temp1 * a[l + i__ + j * a_dim1];
+ temp2 += a[l + i__ + j * a_dim1] * x[i__];
+/* L50: */
+ }
+ y[j] = y[j] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[jx];
+ temp2 = 0.;
+ ix = kx;
+ iy = ky;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *k;
+ i__3 = j - 1;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ y[iy] += temp1 * a[l + i__ + j * a_dim1];
+ temp2 += a[l + i__ + j * a_dim1] * x[ix];
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ y[jy] = y[jy] + temp1 * a[kplus1 + j * a_dim1] + *alpha *
+ temp2;
+ jx += *incx;
+ jy += *incy;
+ if (j > *k) {
+ kx += *incx;
+ ky += *incy;
+ }
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y when lower triangle of A is stored. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[j];
+ temp2 = 0.;
+ y[j] += temp1 * a[j * a_dim1 + 1];
+ l = 1 - j;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ y[i__] += temp1 * a[l + i__ + j * a_dim1];
+ temp2 += a[l + i__ + j * a_dim1] * x[i__];
+/* L90: */
+ }
+ y[j] += *alpha * temp2;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[jx];
+ temp2 = 0.;
+ y[jy] += temp1 * a[j * a_dim1 + 1];
+ l = 1 - j;
+ ix = jx;
+ iy = jy;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ ix += *incx;
+ iy += *incy;
+ y[iy] += temp1 * a[l + i__ + j * a_dim1];
+ temp2 += a[l + i__ + j * a_dim1] * x[ix];
+/* L110: */
+ }
+ y[jy] += *alpha * temp2;
+ jx += *incx;
+ jy += *incy;
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DSBMV . */
+
+} /* dsbmv_ */
diff --git a/BLAS/SRC/dscal.c b/BLAS/SRC/dscal.c
new file mode 100644
index 0000000..11548be
--- /dev/null
+++ b/BLAS/SRC/dscal.c
@@ -0,0 +1,96 @@
+/* dscal.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dscal_(integer *n, doublereal *da, doublereal *dx,
+ integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, m, mp1, nincx;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+/* * */
+/* scales a vector by a constant. */
+/* uses unrolled loops for increment equal to one. */
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 3/93 to return if incx .le. 0. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --dx;
+
+ /* Function Body */
+ if (*n <= 0 || *incx <= 0) {
+ return 0;
+ }
+ if (*incx == 1) {
+ goto L20;
+ }
+
+/* code for increment not equal to 1 */
+
+ nincx = *n * *incx;
+ i__1 = nincx;
+ i__2 = *incx;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ dx[i__] = *da * dx[i__];
+/* L10: */
+ }
+ return 0;
+
+/* code for increment equal to 1 */
+
+
+/* clean-up loop */
+
+L20:
+ m = *n % 5;
+ if (m == 0) {
+ goto L40;
+ }
+ i__2 = m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ dx[i__] = *da * dx[i__];
+/* L30: */
+ }
+ if (*n < 5) {
+ return 0;
+ }
+L40:
+ mp1 = m + 1;
+ i__2 = *n;
+ for (i__ = mp1; i__ <= i__2; i__ += 5) {
+ dx[i__] = *da * dx[i__];
+ dx[i__ + 1] = *da * dx[i__ + 1];
+ dx[i__ + 2] = *da * dx[i__ + 2];
+ dx[i__ + 3] = *da * dx[i__ + 3];
+ dx[i__ + 4] = *da * dx[i__ + 4];
+/* L50: */
+ }
+ return 0;
+} /* dscal_ */
diff --git a/BLAS/SRC/dsdot.c b/BLAS/SRC/dsdot.c
new file mode 100644
index 0000000..26e66df
--- /dev/null
+++ b/BLAS/SRC/dsdot.c
@@ -0,0 +1,135 @@
+/* dsdot.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dsdot_(integer *n, real *sx, integer *incx, real *sy, integer *
+ incy)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal ret_val;
+
+ /* Local variables */
+ integer i__, ns, kx, ky;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* AUTHORS */
+/* ======= */
+/* Lawson, C. L., (JPL), Hanson, R. J., (SNLA), */
+/* Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL) */
+
+/* Purpose */
+/* ======= */
+/* Compute the inner product of two vectors with extended */
+/* precision accumulation and result. */
+
+/* Returns D.P. dot product accumulated in D.P., for S.P. SX and SY */
+/* DSDOT = sum for I = 0 to N-1 of SX(LX+I*INCX) * SY(LY+I*INCY), */
+/* where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is */
+/* defined in a similar way using INCY. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* number of elements in input vector(s) */
+
+/* SX (input) REAL array, dimension(N) */
+/* single precision vector with N elements */
+
+/* INCX (input) INTEGER */
+/* storage spacing between elements of SX */
+
+/* SY (input) REAL array, dimension(N) */
+/* single precision vector with N elements */
+
+/* INCY (input) INTEGER */
+/* storage spacing between elements of SY */
+
+/* DSDOT (output) DOUBLE PRECISION */
+/* DSDOT double precision dot product (zero if N.LE.0) */
+
+/* REFERENCES */
+/* ========== */
+
+/* C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. */
+/* Krogh, Basic linear algebra subprograms for Fortran */
+/* usage, Algorithm No. 539, Transactions on Mathematical */
+/* Software 5, 3 (September 1979), pp. 308-323. */
+
+/* REVISION HISTORY (YYMMDD) */
+/* ========================== */
+
+/* 791001 DATE WRITTEN */
+/* 890831 Modified array declarations. (WRB) */
+/* 890831 REVISION DATE from Version 3.2 */
+/* 891214 Prologue converted to Version 4.0 format. (BAB) */
+/* 920310 Corrected definition of LX in DESCRIPTION. (WRB) */
+/* 920501 Reformatted the REFERENCES section. (WRB) */
+/* 070118 Reformat to LAPACK style (JL) */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --sy;
+ --sx;
+
+ /* Function Body */
+ ret_val = 0.;
+ if (*n <= 0) {
+ return ret_val;
+ }
+ if (*incx == *incy && *incx > 0) {
+ goto L20;
+ }
+
+/* Code for unequal or nonpositive increments. */
+
+ kx = 1;
+ ky = 1;
+ if (*incx < 0) {
+ kx = (1 - *n) * *incx + 1;
+ }
+ if (*incy < 0) {
+ ky = (1 - *n) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ret_val += (doublereal) sx[kx] * (doublereal) sy[ky];
+ kx += *incx;
+ ky += *incy;
+/* L10: */
+ }
+ return ret_val;
+
+/* Code for equal, positive, non-unit increments. */
+
+L20:
+ ns = *n * *incx;
+ i__1 = ns;
+ i__2 = *incx;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ ret_val += (doublereal) sx[i__] * (doublereal) sy[i__];
+/* L30: */
+ }
+ return ret_val;
+} /* dsdot_ */
diff --git a/BLAS/SRC/dspmv.c b/BLAS/SRC/dspmv.c
new file mode 100644
index 0000000..24861dc
--- /dev/null
+++ b/BLAS/SRC/dspmv.c
@@ -0,0 +1,312 @@
+/* dspmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dspmv_(char *uplo, integer *n, doublereal *alpha,
+ doublereal *ap, doublereal *x, integer *incx, doublereal *beta,
+ doublereal *y, integer *incy)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
+ doublereal temp1, temp2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSPMV performs the matrix-vector operation */
+
+/* y := alpha*A*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are n element vectors and */
+/* A is an n by n symmetric matrix, supplied in packed form. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the matrix A is supplied in the packed */
+/* array AP as follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* supplied in AP. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* supplied in AP. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION. */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* AP - DOUBLE PRECISION array of DIMENSION at least */
+/* ( ( n*( n + 1 ) )/2 ). */
+/* Before entry with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular part of the symmetric matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
+/* and a( 2, 2 ) respectively, and so on. */
+/* Before entry with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular part of the symmetric matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
+/* and a( 3, 1 ) respectively, and so on. */
+/* Unchanged on exit. */
+
+/* X - DOUBLE PRECISION array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - DOUBLE PRECISION. */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - DOUBLE PRECISION array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. On exit, Y is overwritten by the updated */
+/* vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --y;
+ --x;
+ --ap;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 6;
+ } else if (*incy == 0) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("DSPMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0. && *beta == 1.) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of the array AP */
+/* are accessed sequentially with one pass through AP. */
+
+/* First form y := beta*y. */
+
+ if (*beta != 1.) {
+ if (*incy == 1) {
+ if (*beta == 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[i__] = 0.;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[i__] = *beta * y[i__];
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (*beta == 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[iy] = 0.;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[iy] = *beta * y[iy];
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (*alpha == 0.) {
+ return 0;
+ }
+ kk = 1;
+ if (lsame_(uplo, "U")) {
+
+/* Form y when AP contains the upper triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[j];
+ temp2 = 0.;
+ k = kk;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ y[i__] += temp1 * ap[k];
+ temp2 += ap[k] * x[i__];
+ ++k;
+/* L50: */
+ }
+ y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2;
+ kk += j;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[jx];
+ temp2 = 0.;
+ ix = kx;
+ iy = ky;
+ i__2 = kk + j - 2;
+ for (k = kk; k <= i__2; ++k) {
+ y[iy] += temp1 * ap[k];
+ temp2 += ap[k] * x[ix];
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2;
+ jx += *incx;
+ jy += *incy;
+ kk += j;
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y when AP contains the lower triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[j];
+ temp2 = 0.;
+ y[j] += temp1 * ap[kk];
+ k = kk + 1;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ y[i__] += temp1 * ap[k];
+ temp2 += ap[k] * x[i__];
+ ++k;
+/* L90: */
+ }
+ y[j] += *alpha * temp2;
+ kk += *n - j + 1;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[jx];
+ temp2 = 0.;
+ y[jy] += temp1 * ap[kk];
+ ix = jx;
+ iy = jy;
+ i__2 = kk + *n - j;
+ for (k = kk + 1; k <= i__2; ++k) {
+ ix += *incx;
+ iy += *incy;
+ y[iy] += temp1 * ap[k];
+ temp2 += ap[k] * x[ix];
+/* L110: */
+ }
+ y[jy] += *alpha * temp2;
+ jx += *incx;
+ jy += *incy;
+ kk += *n - j + 1;
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DSPMV . */
+
+} /* dspmv_ */
diff --git a/BLAS/SRC/dspr.c b/BLAS/SRC/dspr.c
new file mode 100644
index 0000000..7aa62e4
--- /dev/null
+++ b/BLAS/SRC/dspr.c
@@ -0,0 +1,237 @@
+/* dspr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dspr_(char *uplo, integer *n, doublereal *alpha,
+ doublereal *x, integer *incx, doublereal *ap)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, jx, kx, info;
+ doublereal temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSPR performs the symmetric rank 1 operation */
+
+/* A := alpha*x*x' + A, */
+
+/* where alpha is a real scalar, x is an n element vector and A is an */
+/* n by n symmetric matrix, supplied in packed form. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the matrix A is supplied in the packed */
+/* array AP as follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* supplied in AP. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* supplied in AP. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION. */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X - DOUBLE PRECISION array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* AP - DOUBLE PRECISION array of DIMENSION at least */
+/* ( ( n*( n + 1 ) )/2 ). */
+/* Before entry with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular part of the symmetric matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
+/* and a( 2, 2 ) respectively, and so on. On exit, the array */
+/* AP is overwritten by the upper triangular part of the */
+/* updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular part of the symmetric matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
+/* and a( 3, 1 ) respectively, and so on. On exit, the array */
+/* AP is overwritten by the lower triangular part of the */
+/* updated matrix. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ }
+ if (info != 0) {
+ xerbla_("DSPR ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0.) {
+ return 0;
+ }
+
+/* Set the start point in X if the increment is not unity. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of the array AP */
+/* are accessed sequentially with one pass through AP. */
+
+ kk = 1;
+ if (lsame_(uplo, "U")) {
+
+/* Form A when upper triangle is stored in AP. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.) {
+ temp = *alpha * x[j];
+ k = kk;
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ap[k] += x[i__] * temp;
+ ++k;
+/* L10: */
+ }
+ }
+ kk += j;
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.) {
+ temp = *alpha * x[jx];
+ ix = kx;
+ i__2 = kk + j - 1;
+ for (k = kk; k <= i__2; ++k) {
+ ap[k] += x[ix] * temp;
+ ix += *incx;
+/* L30: */
+ }
+ }
+ jx += *incx;
+ kk += j;
+/* L40: */
+ }
+ }
+ } else {
+
+/* Form A when lower triangle is stored in AP. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.) {
+ temp = *alpha * x[j];
+ k = kk;
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ap[k] += x[i__] * temp;
+ ++k;
+/* L50: */
+ }
+ }
+ kk = kk + *n - j + 1;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.) {
+ temp = *alpha * x[jx];
+ ix = jx;
+ i__2 = kk + *n - j;
+ for (k = kk; k <= i__2; ++k) {
+ ap[k] += x[ix] * temp;
+ ix += *incx;
+/* L70: */
+ }
+ }
+ jx += *incx;
+ kk = kk + *n - j + 1;
+/* L80: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DSPR . */
+
+} /* dspr_ */
diff --git a/BLAS/SRC/dspr2.c b/BLAS/SRC/dspr2.c
new file mode 100644
index 0000000..61e7532
--- /dev/null
+++ b/BLAS/SRC/dspr2.c
@@ -0,0 +1,270 @@
+/* dspr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dspr2_(char *uplo, integer *n, doublereal *alpha,
+ doublereal *x, integer *incx, doublereal *y, integer *incy,
+ doublereal *ap)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
+ doublereal temp1, temp2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSPR2 performs the symmetric rank 2 operation */
+
+/* A := alpha*x*y' + alpha*y*x' + A, */
+
+/* where alpha is a scalar, x and y are n element vectors and A is an */
+/* n by n symmetric matrix, supplied in packed form. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the matrix A is supplied in the packed */
+/* array AP as follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* supplied in AP. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* supplied in AP. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION. */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X - DOUBLE PRECISION array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* Y - DOUBLE PRECISION array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. */
+/* Unchanged on exit. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* AP - DOUBLE PRECISION array of DIMENSION at least */
+/* ( ( n*( n + 1 ) )/2 ). */
+/* Before entry with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular part of the symmetric matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
+/* and a( 2, 2 ) respectively, and so on. On exit, the array */
+/* AP is overwritten by the upper triangular part of the */
+/* updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular part of the symmetric matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
+/* and a( 3, 1 ) respectively, and so on. On exit, the array */
+/* AP is overwritten by the lower triangular part of the */
+/* updated matrix. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --y;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ } else if (*incy == 0) {
+ info = 7;
+ }
+ if (info != 0) {
+ xerbla_("DSPR2 ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0.) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y if the increments are not both */
+/* unity. */
+
+ if (*incx != 1 || *incy != 1) {
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+ jx = kx;
+ jy = ky;
+ }
+
+/* Start the operations. In this version the elements of the array AP */
+/* are accessed sequentially with one pass through AP. */
+
+ kk = 1;
+ if (lsame_(uplo, "U")) {
+
+/* Form A when upper triangle is stored in AP. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0. || y[j] != 0.) {
+ temp1 = *alpha * y[j];
+ temp2 = *alpha * x[j];
+ k = kk;
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2;
+ ++k;
+/* L10: */
+ }
+ }
+ kk += j;
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0. || y[jy] != 0.) {
+ temp1 = *alpha * y[jy];
+ temp2 = *alpha * x[jx];
+ ix = kx;
+ iy = ky;
+ i__2 = kk + j - 1;
+ for (k = kk; k <= i__2; ++k) {
+ ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2;
+ ix += *incx;
+ iy += *incy;
+/* L30: */
+ }
+ }
+ jx += *incx;
+ jy += *incy;
+ kk += j;
+/* L40: */
+ }
+ }
+ } else {
+
+/* Form A when lower triangle is stored in AP. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0. || y[j] != 0.) {
+ temp1 = *alpha * y[j];
+ temp2 = *alpha * x[j];
+ k = kk;
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2;
+ ++k;
+/* L50: */
+ }
+ }
+ kk = kk + *n - j + 1;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0. || y[jy] != 0.) {
+ temp1 = *alpha * y[jy];
+ temp2 = *alpha * x[jx];
+ ix = jx;
+ iy = jy;
+ i__2 = kk + *n - j;
+ for (k = kk; k <= i__2; ++k) {
+ ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2;
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ }
+ jx += *incx;
+ jy += *incy;
+ kk = kk + *n - j + 1;
+/* L80: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DSPR2 . */
+
+} /* dspr2_ */
diff --git a/BLAS/SRC/dswap.c b/BLAS/SRC/dswap.c
new file mode 100644
index 0000000..27a303e
--- /dev/null
+++ b/BLAS/SRC/dswap.c
@@ -0,0 +1,114 @@
+/* dswap.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dswap_(integer *n, doublereal *dx, integer *incx,
+ doublereal *dy, integer *incy)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, m, ix, iy, mp1;
+ doublereal dtemp;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* interchanges two vectors. */
+/* uses unrolled loops for increments equal one. */
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --dy;
+ --dx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* code for unequal increments or equal increments not equal */
+/* to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dtemp = dx[ix];
+ dx[ix] = dy[iy];
+ dy[iy] = dtemp;
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ return 0;
+
+/* code for both increments equal to 1 */
+
+
+/* clean-up loop */
+
+L20:
+ m = *n % 3;
+ if (m == 0) {
+ goto L40;
+ }
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dtemp = dx[i__];
+ dx[i__] = dy[i__];
+ dy[i__] = dtemp;
+/* L30: */
+ }
+ if (*n < 3) {
+ return 0;
+ }
+L40:
+ mp1 = m + 1;
+ i__1 = *n;
+ for (i__ = mp1; i__ <= i__1; i__ += 3) {
+ dtemp = dx[i__];
+ dx[i__] = dy[i__];
+ dy[i__] = dtemp;
+ dtemp = dx[i__ + 1];
+ dx[i__ + 1] = dy[i__ + 1];
+ dy[i__ + 1] = dtemp;
+ dtemp = dx[i__ + 2];
+ dx[i__ + 2] = dy[i__ + 2];
+ dy[i__ + 2] = dtemp;
+/* L50: */
+ }
+ return 0;
+} /* dswap_ */
diff --git a/BLAS/SRC/dsymm.c b/BLAS/SRC/dsymm.c
new file mode 100644
index 0000000..e5dcd5d
--- /dev/null
+++ b/BLAS/SRC/dsymm.c
@@ -0,0 +1,362 @@
+/* dsymm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dsymm_(char *side, char *uplo, integer *m, integer *n,
+ doublereal *alpha, doublereal *a, integer *lda, doublereal *b,
+ integer *ldb, doublereal *beta, doublereal *c__, integer *ldc)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3;
+
+ /* Local variables */
+ integer i__, j, k, info;
+ doublereal temp1, temp2;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYMM performs one of the matrix-matrix operations */
+
+/* C := alpha*A*B + beta*C, */
+
+/* or */
+
+/* C := alpha*B*A + beta*C, */
+
+/* where alpha and beta are scalars, A is a symmetric matrix and B and */
+/* C are m by n matrices. */
+
+/* Arguments */
+/* ========== */
+
+/* SIDE - CHARACTER*1. */
+/* On entry, SIDE specifies whether the symmetric matrix A */
+/* appears on the left or right in the operation as follows: */
+
+/* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, */
+
+/* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, */
+
+/* Unchanged on exit. */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the symmetric matrix A is to be */
+/* referenced as follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of the */
+/* symmetric matrix is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of the */
+/* symmetric matrix is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix C. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix C. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION. */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is */
+/* m when SIDE = 'L' or 'l' and is n otherwise. */
+/* Before entry with SIDE = 'L' or 'l', the m by m part of */
+/* the array A must contain the symmetric matrix, such that */
+/* when UPLO = 'U' or 'u', the leading m by m upper triangular */
+/* part of the array A must contain the upper triangular part */
+/* of the symmetric matrix and the strictly lower triangular */
+/* part of A is not referenced, and when UPLO = 'L' or 'l', */
+/* the leading m by m lower triangular part of the array A */
+/* must contain the lower triangular part of the symmetric */
+/* matrix and the strictly upper triangular part of A is not */
+/* referenced. */
+/* Before entry with SIDE = 'R' or 'r', the n by n part of */
+/* the array A must contain the symmetric matrix, such that */
+/* when UPLO = 'U' or 'u', the leading n by n upper triangular */
+/* part of the array A must contain the upper triangular part */
+/* of the symmetric matrix and the strictly lower triangular */
+/* part of A is not referenced, and when UPLO = 'L' or 'l', */
+/* the leading n by n lower triangular part of the array A */
+/* must contain the lower triangular part of the symmetric */
+/* matrix and the strictly upper triangular part of A is not */
+/* referenced. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When SIDE = 'L' or 'l' then */
+/* LDA must be at least max( 1, m ), otherwise LDA must be at */
+/* least max( 1, n ). */
+/* Unchanged on exit. */
+
+/* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). */
+/* Before entry, the leading m by n part of the array B must */
+/* contain the matrix B. */
+/* Unchanged on exit. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. LDB must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+/* BETA - DOUBLE PRECISION. */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then C need not be set on input. */
+/* Unchanged on exit. */
+
+/* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */
+/* Before entry, the leading m by n part of the array C must */
+/* contain the matrix C, except when beta is zero, in which */
+/* case C need not be set on entry. */
+/* On exit, the array C is overwritten by the m by n updated */
+/* matrix. */
+
+/* LDC - INTEGER. */
+/* On entry, LDC specifies the first dimension of C as declared */
+/* in the calling (sub) program. LDC must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Set NROWA as the number of rows of A. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ if (lsame_(side, "L")) {
+ nrowa = *m;
+ } else {
+ nrowa = *n;
+ }
+ upper = lsame_(uplo, "U");
+
+/* Test the input parameters. */
+
+ info = 0;
+ if (! lsame_(side, "L") && ! lsame_(side, "R")) {
+ info = 1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ info = 2;
+ } else if (*m < 0) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*lda < max(1,nrowa)) {
+ info = 7;
+ } else if (*ldb < max(1,*m)) {
+ info = 9;
+ } else if (*ldc < max(1,*m)) {
+ info = 12;
+ }
+ if (info != 0) {
+ xerbla_("DSYMM ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (*alpha == 0.) {
+ if (*beta == 0.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lsame_(side, "L")) {
+
+/* Form C := alpha*A*B + beta*C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp1 = *alpha * b[i__ + j * b_dim1];
+ temp2 = 0.;
+ i__3 = i__ - 1;
+ for (k = 1; k <= i__3; ++k) {
+ c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1];
+ temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1];
+/* L50: */
+ }
+ if (*beta == 0.) {
+ c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1]
+ + *alpha * temp2;
+ } else {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]
+ + temp1 * a[i__ + i__ * a_dim1] + *alpha *
+ temp2;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (i__ = *m; i__ >= 1; --i__) {
+ temp1 = *alpha * b[i__ + j * b_dim1];
+ temp2 = 0.;
+ i__2 = *m;
+ for (k = i__ + 1; k <= i__2; ++k) {
+ c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1];
+ temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1];
+/* L80: */
+ }
+ if (*beta == 0.) {
+ c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1]
+ + *alpha * temp2;
+ } else {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]
+ + temp1 * a[i__ + i__ * a_dim1] + *alpha *
+ temp2;
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+ }
+ } else {
+
+/* Form C := alpha*B*A + beta*C. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * a[j + j * a_dim1];
+ if (*beta == 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = temp1 * b[i__ + j * b_dim1];
+/* L110: */
+ }
+ } else {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] +
+ temp1 * b[i__ + j * b_dim1];
+/* L120: */
+ }
+ }
+ i__2 = j - 1;
+ for (k = 1; k <= i__2; ++k) {
+ if (upper) {
+ temp1 = *alpha * a[k + j * a_dim1];
+ } else {
+ temp1 = *alpha * a[j + k * a_dim1];
+ }
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1];
+/* L130: */
+ }
+/* L140: */
+ }
+ i__2 = *n;
+ for (k = j + 1; k <= i__2; ++k) {
+ if (upper) {
+ temp1 = *alpha * a[j + k * a_dim1];
+ } else {
+ temp1 = *alpha * a[k + j * a_dim1];
+ }
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1];
+/* L150: */
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+ }
+
+ return 0;
+
+/* End of DSYMM . */
+
+} /* dsymm_ */
diff --git a/BLAS/SRC/dsymv.c b/BLAS/SRC/dsymv.c
new file mode 100644
index 0000000..a557f1d
--- /dev/null
+++ b/BLAS/SRC/dsymv.c
@@ -0,0 +1,313 @@
+/* dsymv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dsymv_(char *uplo, integer *n, doublereal *alpha,
+ doublereal *a, integer *lda, doublereal *x, integer *incx, doublereal
+ *beta, doublereal *y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, ix, iy, jx, jy, kx, ky, info;
+ doublereal temp1, temp2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYMV performs the matrix-vector operation */
+
+/* y := alpha*A*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are n element vectors and */
+/* A is an n by n symmetric matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array A is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of A */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of A */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION. */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular part of the symmetric matrix and the strictly */
+/* lower triangular part of A is not referenced. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular part of the symmetric matrix and the strictly */
+/* upper triangular part of A is not referenced. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+/* X - DOUBLE PRECISION array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - DOUBLE PRECISION. */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - DOUBLE PRECISION array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. On exit, Y is overwritten by the updated */
+/* vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*lda < max(1,*n)) {
+ info = 5;
+ } else if (*incx == 0) {
+ info = 7;
+ } else if (*incy == 0) {
+ info = 10;
+ }
+ if (info != 0) {
+ xerbla_("DSYMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0. && *beta == 1.) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through the triangular part */
+/* of A. */
+
+/* First form y := beta*y. */
+
+ if (*beta != 1.) {
+ if (*incy == 1) {
+ if (*beta == 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[i__] = 0.;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[i__] = *beta * y[i__];
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (*beta == 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[iy] = 0.;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[iy] = *beta * y[iy];
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (*alpha == 0.) {
+ return 0;
+ }
+ if (lsame_(uplo, "U")) {
+
+/* Form y when A is stored in upper triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[j];
+ temp2 = 0.;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ y[i__] += temp1 * a[i__ + j * a_dim1];
+ temp2 += a[i__ + j * a_dim1] * x[i__];
+/* L50: */
+ }
+ y[j] = y[j] + temp1 * a[j + j * a_dim1] + *alpha * temp2;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[jx];
+ temp2 = 0.;
+ ix = kx;
+ iy = ky;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ y[iy] += temp1 * a[i__ + j * a_dim1];
+ temp2 += a[i__ + j * a_dim1] * x[ix];
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ y[jy] = y[jy] + temp1 * a[j + j * a_dim1] + *alpha * temp2;
+ jx += *incx;
+ jy += *incy;
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y when A is stored in lower triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[j];
+ temp2 = 0.;
+ y[j] += temp1 * a[j + j * a_dim1];
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ y[i__] += temp1 * a[i__ + j * a_dim1];
+ temp2 += a[i__ + j * a_dim1] * x[i__];
+/* L90: */
+ }
+ y[j] += *alpha * temp2;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[jx];
+ temp2 = 0.;
+ y[jy] += temp1 * a[j + j * a_dim1];
+ ix = jx;
+ iy = jy;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ ix += *incx;
+ iy += *incy;
+ y[iy] += temp1 * a[i__ + j * a_dim1];
+ temp2 += a[i__ + j * a_dim1] * x[ix];
+/* L110: */
+ }
+ y[jy] += *alpha * temp2;
+ jx += *incx;
+ jy += *incy;
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DSYMV . */
+
+} /* dsymv_ */
diff --git a/BLAS/SRC/dsyr.c b/BLAS/SRC/dsyr.c
new file mode 100644
index 0000000..fa15dcd
--- /dev/null
+++ b/BLAS/SRC/dsyr.c
@@ -0,0 +1,238 @@
+/* dsyr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dsyr_(char *uplo, integer *n, doublereal *alpha,
+ doublereal *x, integer *incx, doublereal *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, ix, jx, kx, info;
+ doublereal temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYR performs the symmetric rank 1 operation */
+
+/* A := alpha*x*x' + A, */
+
+/* where alpha is a real scalar, x is an n element vector and A is an */
+/* n by n symmetric matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array A is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of A */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of A */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION. */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X - DOUBLE PRECISION array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular part of the symmetric matrix and the strictly */
+/* lower triangular part of A is not referenced. On exit, the */
+/* upper triangular part of the array A is overwritten by the */
+/* upper triangular part of the updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular part of the symmetric matrix and the strictly */
+/* upper triangular part of A is not referenced. On exit, the */
+/* lower triangular part of the array A is overwritten by the */
+/* lower triangular part of the updated matrix. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ } else if (*lda < max(1,*n)) {
+ info = 7;
+ }
+ if (info != 0) {
+ xerbla_("DSYR ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0.) {
+ return 0;
+ }
+
+/* Set the start point in X if the increment is not unity. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through the triangular part */
+/* of A. */
+
+ if (lsame_(uplo, "U")) {
+
+/* Form A when A is stored in upper triangle. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.) {
+ temp = *alpha * x[j];
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] += x[i__] * temp;
+/* L10: */
+ }
+ }
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.) {
+ temp = *alpha * x[jx];
+ ix = kx;
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] += x[ix] * temp;
+ ix += *incx;
+/* L30: */
+ }
+ }
+ jx += *incx;
+/* L40: */
+ }
+ }
+ } else {
+
+/* Form A when A is stored in lower triangle. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.) {
+ temp = *alpha * x[j];
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] += x[i__] * temp;
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.) {
+ temp = *alpha * x[jx];
+ ix = jx;
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] += x[ix] * temp;
+ ix += *incx;
+/* L70: */
+ }
+ }
+ jx += *incx;
+/* L80: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DSYR . */
+
+} /* dsyr_ */
diff --git a/BLAS/SRC/dsyr2.c b/BLAS/SRC/dsyr2.c
new file mode 100644
index 0000000..d9dca76
--- /dev/null
+++ b/BLAS/SRC/dsyr2.c
@@ -0,0 +1,275 @@
+/* dsyr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dsyr2_(char *uplo, integer *n, doublereal *alpha,
+ doublereal *x, integer *incx, doublereal *y, integer *incy,
+ doublereal *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, ix, iy, jx, jy, kx, ky, info;
+ doublereal temp1, temp2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYR2 performs the symmetric rank 2 operation */
+
+/* A := alpha*x*y' + alpha*y*x' + A, */
+
+/* where alpha is a scalar, x and y are n element vectors and A is an n */
+/* by n symmetric matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array A is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of A */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of A */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION. */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X - DOUBLE PRECISION array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* Y - DOUBLE PRECISION array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. */
+/* Unchanged on exit. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular part of the symmetric matrix and the strictly */
+/* lower triangular part of A is not referenced. On exit, the */
+/* upper triangular part of the array A is overwritten by the */
+/* upper triangular part of the updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular part of the symmetric matrix and the strictly */
+/* upper triangular part of A is not referenced. On exit, the */
+/* lower triangular part of the array A is overwritten by the */
+/* lower triangular part of the updated matrix. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ --y;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ } else if (*incy == 0) {
+ info = 7;
+ } else if (*lda < max(1,*n)) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("DSYR2 ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0.) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y if the increments are not both */
+/* unity. */
+
+ if (*incx != 1 || *incy != 1) {
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+ jx = kx;
+ jy = ky;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through the triangular part */
+/* of A. */
+
+ if (lsame_(uplo, "U")) {
+
+/* Form A when A is stored in the upper triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0. || y[j] != 0.) {
+ temp1 = *alpha * y[j];
+ temp2 = *alpha * x[j];
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] *
+ temp1 + y[i__] * temp2;
+/* L10: */
+ }
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0. || y[jy] != 0.) {
+ temp1 = *alpha * y[jy];
+ temp2 = *alpha * x[jx];
+ ix = kx;
+ iy = ky;
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] *
+ temp1 + y[iy] * temp2;
+ ix += *incx;
+ iy += *incy;
+/* L30: */
+ }
+ }
+ jx += *incx;
+ jy += *incy;
+/* L40: */
+ }
+ }
+ } else {
+
+/* Form A when A is stored in the lower triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0. || y[j] != 0.) {
+ temp1 = *alpha * y[j];
+ temp2 = *alpha * x[j];
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] *
+ temp1 + y[i__] * temp2;
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0. || y[jy] != 0.) {
+ temp1 = *alpha * y[jy];
+ temp2 = *alpha * x[jx];
+ ix = jx;
+ iy = jy;
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] *
+ temp1 + y[iy] * temp2;
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ }
+ jx += *incx;
+ jy += *incy;
+/* L80: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DSYR2 . */
+
+} /* dsyr2_ */
diff --git a/BLAS/SRC/dsyr2k.c b/BLAS/SRC/dsyr2k.c
new file mode 100644
index 0000000..cbd6845
--- /dev/null
+++ b/BLAS/SRC/dsyr2k.c
@@ -0,0 +1,407 @@
+/* dsyr2k.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dsyr2k_(char *uplo, char *trans, integer *n, integer *k,
+ doublereal *alpha, doublereal *a, integer *lda, doublereal *b,
+ integer *ldb, doublereal *beta, doublereal *c__, integer *ldc)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3;
+
+ /* Local variables */
+ integer i__, j, l, info;
+ doublereal temp1, temp2;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYR2K performs one of the symmetric rank 2k operations */
+
+/* C := alpha*A*B' + alpha*B*A' + beta*C, */
+
+/* or */
+
+/* C := alpha*A'*B + alpha*B'*A + beta*C, */
+
+/* where alpha and beta are scalars, C is an n by n symmetric matrix */
+/* and A and B are n by k matrices in the first case and k by n */
+/* matrices in the second case. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array C is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of C */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of C */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + */
+/* beta*C. */
+
+/* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + */
+/* beta*C. */
+
+/* TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + */
+/* beta*C. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix C. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry with TRANS = 'N' or 'n', K specifies the number */
+/* of columns of the matrices A and B, and on entry with */
+/* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number */
+/* of rows of the matrices A and B. K must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION. */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is */
+/* k when TRANS = 'N' or 'n', and is n otherwise. */
+/* Before entry with TRANS = 'N' or 'n', the leading n by k */
+/* part of the array A must contain the matrix A, otherwise */
+/* the leading k by n part of the array A must contain the */
+/* matrix A. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When TRANS = 'N' or 'n' */
+/* then LDA must be at least max( 1, n ), otherwise LDA must */
+/* be at least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is */
+/* k when TRANS = 'N' or 'n', and is n otherwise. */
+/* Before entry with TRANS = 'N' or 'n', the leading n by k */
+/* part of the array B must contain the matrix B, otherwise */
+/* the leading k by n part of the array B must contain the */
+/* matrix B. */
+/* Unchanged on exit. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. When TRANS = 'N' or 'n' */
+/* then LDB must be at least max( 1, n ), otherwise LDB must */
+/* be at least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* BETA - DOUBLE PRECISION. */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+/* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array C must contain the upper */
+/* triangular part of the symmetric matrix and the strictly */
+/* lower triangular part of C is not referenced. On exit, the */
+/* upper triangular part of the array C is overwritten by the */
+/* upper triangular part of the updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array C must contain the lower */
+/* triangular part of the symmetric matrix and the strictly */
+/* upper triangular part of C is not referenced. On exit, the */
+/* lower triangular part of the array C is overwritten by the */
+/* lower triangular part of the updated matrix. */
+
+/* LDC - INTEGER. */
+/* On entry, LDC specifies the first dimension of C as declared */
+/* in the calling (sub) program. LDC must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ if (lsame_(trans, "N")) {
+ nrowa = *n;
+ } else {
+ nrowa = *k;
+ }
+ upper = lsame_(uplo, "U");
+
+ info = 0;
+ if (! upper && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*k < 0) {
+ info = 4;
+ } else if (*lda < max(1,nrowa)) {
+ info = 7;
+ } else if (*ldb < max(1,nrowa)) {
+ info = 9;
+ } else if (*ldc < max(1,*n)) {
+ info = 12;
+ }
+ if (info != 0) {
+ xerbla_("DSYR2K", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (*alpha == 0.) {
+ if (upper) {
+ if (*beta == 0.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else {
+ if (*beta == 0.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.;
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form C := alpha*A*B' + alpha*B*A' + C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*beta == 0.) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.;
+/* L90: */
+ }
+ } else if (*beta != 1.) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L100: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) {
+ temp1 = *alpha * b[j + l * b_dim1];
+ temp2 = *alpha * a[j + l * a_dim1];
+ i__3 = j;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[
+ i__ + l * a_dim1] * temp1 + b[i__ + l *
+ b_dim1] * temp2;
+/* L110: */
+ }
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*beta == 0.) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.;
+/* L140: */
+ }
+ } else if (*beta != 1.) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L150: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) {
+ temp1 = *alpha * b[j + l * b_dim1];
+ temp2 = *alpha * a[j + l * a_dim1];
+ i__3 = *n;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[
+ i__ + l * a_dim1] * temp1 + b[i__ + l *
+ b_dim1] * temp2;
+/* L160: */
+ }
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+ } else {
+
+/* Form C := alpha*A'*B + alpha*B'*A + C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1];
+ temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1];
+/* L190: */
+ }
+ if (*beta == 0.) {
+ c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha *
+ temp2;
+ } else {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]
+ + *alpha * temp1 + *alpha * temp2;
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1];
+ temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1];
+/* L220: */
+ }
+ if (*beta == 0.) {
+ c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha *
+ temp2;
+ } else {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]
+ + *alpha * temp1 + *alpha * temp2;
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DSYR2K. */
+
+} /* dsyr2k_ */
diff --git a/BLAS/SRC/dsyrk.c b/BLAS/SRC/dsyrk.c
new file mode 100644
index 0000000..393880d
--- /dev/null
+++ b/BLAS/SRC/dsyrk.c
@@ -0,0 +1,372 @@
+/* dsyrk.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dsyrk_(char *uplo, char *trans, integer *n, integer *k,
+ doublereal *alpha, doublereal *a, integer *lda, doublereal *beta,
+ doublereal *c__, integer *ldc)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, l, info;
+ doublereal temp;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYRK performs one of the symmetric rank k operations */
+
+/* C := alpha*A*A' + beta*C, */
+
+/* or */
+
+/* C := alpha*A'*A + beta*C, */
+
+/* where alpha and beta are scalars, C is an n by n symmetric matrix */
+/* and A is an n by k matrix in the first case and a k by n matrix */
+/* in the second case. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array C is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of C */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of C */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. */
+
+/* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. */
+
+/* TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix C. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry with TRANS = 'N' or 'n', K specifies the number */
+/* of columns of the matrix A, and on entry with */
+/* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number */
+/* of rows of the matrix A. K must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION. */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is */
+/* k when TRANS = 'N' or 'n', and is n otherwise. */
+/* Before entry with TRANS = 'N' or 'n', the leading n by k */
+/* part of the array A must contain the matrix A, otherwise */
+/* the leading k by n part of the array A must contain the */
+/* matrix A. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When TRANS = 'N' or 'n' */
+/* then LDA must be at least max( 1, n ), otherwise LDA must */
+/* be at least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* BETA - DOUBLE PRECISION. */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+/* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array C must contain the upper */
+/* triangular part of the symmetric matrix and the strictly */
+/* lower triangular part of C is not referenced. On exit, the */
+/* upper triangular part of the array C is overwritten by the */
+/* upper triangular part of the updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array C must contain the lower */
+/* triangular part of the symmetric matrix and the strictly */
+/* upper triangular part of C is not referenced. On exit, the */
+/* lower triangular part of the array C is overwritten by the */
+/* lower triangular part of the updated matrix. */
+
+/* LDC - INTEGER. */
+/* On entry, LDC specifies the first dimension of C as declared */
+/* in the calling (sub) program. LDC must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ if (lsame_(trans, "N")) {
+ nrowa = *n;
+ } else {
+ nrowa = *k;
+ }
+ upper = lsame_(uplo, "U");
+
+ info = 0;
+ if (! upper && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*k < 0) {
+ info = 4;
+ } else if (*lda < max(1,nrowa)) {
+ info = 7;
+ } else if (*ldc < max(1,*n)) {
+ info = 10;
+ }
+ if (info != 0) {
+ xerbla_("DSYRK ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (*alpha == 0.) {
+ if (upper) {
+ if (*beta == 0.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else {
+ if (*beta == 0.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.;
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form C := alpha*A*A' + beta*C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*beta == 0.) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.;
+/* L90: */
+ }
+ } else if (*beta != 1.) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L100: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ if (a[j + l * a_dim1] != 0.) {
+ temp = *alpha * a[j + l * a_dim1];
+ i__3 = j;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ c__[i__ + j * c_dim1] += temp * a[i__ + l *
+ a_dim1];
+/* L110: */
+ }
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*beta == 0.) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.;
+/* L140: */
+ }
+ } else if (*beta != 1.) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L150: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ if (a[j + l * a_dim1] != 0.) {
+ temp = *alpha * a[j + l * a_dim1];
+ i__3 = *n;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ c__[i__ + j * c_dim1] += temp * a[i__ + l *
+ a_dim1];
+/* L160: */
+ }
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+ } else {
+
+/* Form C := alpha*A'*A + beta*C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = 0.;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ temp += a[l + i__ * a_dim1] * a[l + j * a_dim1];
+/* L190: */
+ }
+ if (*beta == 0.) {
+ c__[i__ + j * c_dim1] = *alpha * temp;
+ } else {
+ c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
+ i__ + j * c_dim1];
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ temp = 0.;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ temp += a[l + i__ * a_dim1] * a[l + j * a_dim1];
+/* L220: */
+ }
+ if (*beta == 0.) {
+ c__[i__ + j * c_dim1] = *alpha * temp;
+ } else {
+ c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
+ i__ + j * c_dim1];
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DSYRK . */
+
+} /* dsyrk_ */
diff --git a/BLAS/SRC/dtbmv.c b/BLAS/SRC/dtbmv.c
new file mode 100644
index 0000000..2095d82
--- /dev/null
+++ b/BLAS/SRC/dtbmv.c
@@ -0,0 +1,422 @@
+/* dtbmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtbmv_(char *uplo, char *trans, char *diag, integer *n,
+ integer *k, doublereal *a, integer *lda, doublereal *x, integer *incx)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, l, ix, jx, kx, info;
+ doublereal temp;
+ extern logical lsame_(char *, char *);
+ integer kplus1;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTBMV performs one of the matrix-vector operations */
+
+/* x := A*x, or x := A'*x, */
+
+/* where x is an n element vector and A is an n by n unit, or non-unit, */
+/* upper or lower triangular band matrix, with ( k + 1 ) diagonals. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' x := A*x. */
+
+/* TRANS = 'T' or 't' x := A'*x. */
+
+/* TRANS = 'C' or 'c' x := A'*x. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry with UPLO = 'U' or 'u', K specifies the number of */
+/* super-diagonals of the matrix A. */
+/* On entry with UPLO = 'L' or 'l', K specifies the number of */
+/* sub-diagonals of the matrix A. */
+/* K must satisfy 0 .le. K. */
+/* Unchanged on exit. */
+
+/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
+/* by n part of the array A must contain the upper triangular */
+/* band part of the matrix of coefficients, supplied column by */
+/* column, with the leading diagonal of the matrix in row */
+/* ( k + 1 ) of the array, the first super-diagonal starting at */
+/* position 2 in row k, and so on. The top left k by k triangle */
+/* of the array A is not referenced. */
+/* The following program segment will transfer an upper */
+/* triangular band matrix from conventional full matrix storage */
+/* to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = K + 1 - J */
+/* DO 10, I = MAX( 1, J - K ), J */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
+/* by n part of the array A must contain the lower triangular */
+/* band part of the matrix of coefficients, supplied column by */
+/* column, with the leading diagonal of the matrix in row 1 of */
+/* the array, the first sub-diagonal starting at position 1 in */
+/* row 2, and so on. The bottom right k by k triangle of the */
+/* array A is not referenced. */
+/* The following program segment will transfer a lower */
+/* triangular band matrix from conventional full matrix storage */
+/* to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = 1 - J */
+/* DO 10, I = J, MIN( N, J + K ) */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Note that when DIAG = 'U' or 'u' the elements of the array A */
+/* corresponding to the diagonal elements of the matrix are not */
+/* referenced, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* ( k + 1 ). */
+/* Unchanged on exit. */
+
+/* X - DOUBLE PRECISION array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. On exit, X is overwritten with the */
+/* tranformed vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*k < 0) {
+ info = 5;
+ } else if (*lda < *k + 1) {
+ info = 7;
+ } else if (*incx == 0) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("DTBMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through A. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x := A*x. */
+
+ if (lsame_(uplo, "U")) {
+ kplus1 = *k + 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.) {
+ temp = x[j];
+ l = kplus1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ x[i__] += temp * a[l + i__ + j * a_dim1];
+/* L10: */
+ }
+ if (nounit) {
+ x[j] *= a[kplus1 + j * a_dim1];
+ }
+ }
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.) {
+ temp = x[jx];
+ ix = kx;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *k;
+ i__3 = j - 1;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ x[ix] += temp * a[l + i__ + j * a_dim1];
+ ix += *incx;
+/* L30: */
+ }
+ if (nounit) {
+ x[jx] *= a[kplus1 + j * a_dim1];
+ }
+ }
+ jx += *incx;
+ if (j > *k) {
+ kx += *incx;
+ }
+/* L40: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ if (x[j] != 0.) {
+ temp = x[j];
+ l = 1 - j;
+/* Computing MIN */
+ i__1 = *n, i__3 = j + *k;
+ i__4 = j + 1;
+ for (i__ = min(i__1,i__3); i__ >= i__4; --i__) {
+ x[i__] += temp * a[l + i__ + j * a_dim1];
+/* L50: */
+ }
+ if (nounit) {
+ x[j] *= a[j * a_dim1 + 1];
+ }
+ }
+/* L60: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ if (x[jx] != 0.) {
+ temp = x[jx];
+ ix = kx;
+ l = 1 - j;
+/* Computing MIN */
+ i__4 = *n, i__1 = j + *k;
+ i__3 = j + 1;
+ for (i__ = min(i__4,i__1); i__ >= i__3; --i__) {
+ x[ix] += temp * a[l + i__ + j * a_dim1];
+ ix -= *incx;
+/* L70: */
+ }
+ if (nounit) {
+ x[jx] *= a[j * a_dim1 + 1];
+ }
+ }
+ jx -= *incx;
+ if (*n - j >= *k) {
+ kx -= *incx;
+ }
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := A'*x. */
+
+ if (lsame_(uplo, "U")) {
+ kplus1 = *k + 1;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ temp = x[j];
+ l = kplus1 - j;
+ if (nounit) {
+ temp *= a[kplus1 + j * a_dim1];
+ }
+/* Computing MAX */
+ i__4 = 1, i__1 = j - *k;
+ i__3 = max(i__4,i__1);
+ for (i__ = j - 1; i__ >= i__3; --i__) {
+ temp += a[l + i__ + j * a_dim1] * x[i__];
+/* L90: */
+ }
+ x[j] = temp;
+/* L100: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ temp = x[jx];
+ kx -= *incx;
+ ix = kx;
+ l = kplus1 - j;
+ if (nounit) {
+ temp *= a[kplus1 + j * a_dim1];
+ }
+/* Computing MAX */
+ i__4 = 1, i__1 = j - *k;
+ i__3 = max(i__4,i__1);
+ for (i__ = j - 1; i__ >= i__3; --i__) {
+ temp += a[l + i__ + j * a_dim1] * x[ix];
+ ix -= *incx;
+/* L110: */
+ }
+ x[jx] = temp;
+ jx -= *incx;
+/* L120: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ temp = x[j];
+ l = 1 - j;
+ if (nounit) {
+ temp *= a[j * a_dim1 + 1];
+ }
+/* Computing MIN */
+ i__1 = *n, i__2 = j + *k;
+ i__4 = min(i__1,i__2);
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ temp += a[l + i__ + j * a_dim1] * x[i__];
+/* L130: */
+ }
+ x[j] = temp;
+/* L140: */
+ }
+ } else {
+ jx = kx;
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ temp = x[jx];
+ kx += *incx;
+ ix = kx;
+ l = 1 - j;
+ if (nounit) {
+ temp *= a[j * a_dim1 + 1];
+ }
+/* Computing MIN */
+ i__1 = *n, i__2 = j + *k;
+ i__4 = min(i__1,i__2);
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ temp += a[l + i__ + j * a_dim1] * x[ix];
+ ix += *incx;
+/* L150: */
+ }
+ x[jx] = temp;
+ jx += *incx;
+/* L160: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DTBMV . */
+
+} /* dtbmv_ */
diff --git a/BLAS/SRC/dtbsv.c b/BLAS/SRC/dtbsv.c
new file mode 100644
index 0000000..dd40400
--- /dev/null
+++ b/BLAS/SRC/dtbsv.c
@@ -0,0 +1,426 @@
+/* dtbsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtbsv_(char *uplo, char *trans, char *diag, integer *n,
+ integer *k, doublereal *a, integer *lda, doublereal *x, integer *incx)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, l, ix, jx, kx, info;
+ doublereal temp;
+ extern logical lsame_(char *, char *);
+ integer kplus1;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTBSV solves one of the systems of equations */
+
+/* A*x = b, or A'*x = b, */
+
+/* where b and x are n element vectors and A is an n by n unit, or */
+/* non-unit, upper or lower triangular band matrix, with ( k + 1 ) */
+/* diagonals. */
+
+/* No test for singularity or near-singularity is included in this */
+/* routine. Such tests must be performed before calling this routine. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the equations to be solved as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' A*x = b. */
+
+/* TRANS = 'T' or 't' A'*x = b. */
+
+/* TRANS = 'C' or 'c' A'*x = b. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry with UPLO = 'U' or 'u', K specifies the number of */
+/* super-diagonals of the matrix A. */
+/* On entry with UPLO = 'L' or 'l', K specifies the number of */
+/* sub-diagonals of the matrix A. */
+/* K must satisfy 0 .le. K. */
+/* Unchanged on exit. */
+
+/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
+/* by n part of the array A must contain the upper triangular */
+/* band part of the matrix of coefficients, supplied column by */
+/* column, with the leading diagonal of the matrix in row */
+/* ( k + 1 ) of the array, the first super-diagonal starting at */
+/* position 2 in row k, and so on. The top left k by k triangle */
+/* of the array A is not referenced. */
+/* The following program segment will transfer an upper */
+/* triangular band matrix from conventional full matrix storage */
+/* to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = K + 1 - J */
+/* DO 10, I = MAX( 1, J - K ), J */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
+/* by n part of the array A must contain the lower triangular */
+/* band part of the matrix of coefficients, supplied column by */
+/* column, with the leading diagonal of the matrix in row 1 of */
+/* the array, the first sub-diagonal starting at position 1 in */
+/* row 2, and so on. The bottom right k by k triangle of the */
+/* array A is not referenced. */
+/* The following program segment will transfer a lower */
+/* triangular band matrix from conventional full matrix storage */
+/* to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = 1 - J */
+/* DO 10, I = J, MIN( N, J + K ) */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Note that when DIAG = 'U' or 'u' the elements of the array A */
+/* corresponding to the diagonal elements of the matrix are not */
+/* referenced, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* ( k + 1 ). */
+/* Unchanged on exit. */
+
+/* X - DOUBLE PRECISION array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element right-hand side vector b. On exit, X is overwritten */
+/* with the solution vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*k < 0) {
+ info = 5;
+ } else if (*lda < *k + 1) {
+ info = 7;
+ } else if (*incx == 0) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("DTBSV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed by sequentially with one pass through A. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x := inv( A )*x. */
+
+ if (lsame_(uplo, "U")) {
+ kplus1 = *k + 1;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ if (x[j] != 0.) {
+ l = kplus1 - j;
+ if (nounit) {
+ x[j] /= a[kplus1 + j * a_dim1];
+ }
+ temp = x[j];
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__1 = max(i__2,i__3);
+ for (i__ = j - 1; i__ >= i__1; --i__) {
+ x[i__] -= temp * a[l + i__ + j * a_dim1];
+/* L10: */
+ }
+ }
+/* L20: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ kx -= *incx;
+ if (x[jx] != 0.) {
+ ix = kx;
+ l = kplus1 - j;
+ if (nounit) {
+ x[jx] /= a[kplus1 + j * a_dim1];
+ }
+ temp = x[jx];
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__1 = max(i__2,i__3);
+ for (i__ = j - 1; i__ >= i__1; --i__) {
+ x[ix] -= temp * a[l + i__ + j * a_dim1];
+ ix -= *incx;
+/* L30: */
+ }
+ }
+ jx -= *incx;
+/* L40: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.) {
+ l = 1 - j;
+ if (nounit) {
+ x[j] /= a[j * a_dim1 + 1];
+ }
+ temp = x[j];
+/* Computing MIN */
+ i__3 = *n, i__4 = j + *k;
+ i__2 = min(i__3,i__4);
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ x[i__] -= temp * a[l + i__ + j * a_dim1];
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ kx += *incx;
+ if (x[jx] != 0.) {
+ ix = kx;
+ l = 1 - j;
+ if (nounit) {
+ x[jx] /= a[j * a_dim1 + 1];
+ }
+ temp = x[jx];
+/* Computing MIN */
+ i__3 = *n, i__4 = j + *k;
+ i__2 = min(i__3,i__4);
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ x[ix] -= temp * a[l + i__ + j * a_dim1];
+ ix += *incx;
+/* L70: */
+ }
+ }
+ jx += *incx;
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := inv( A')*x. */
+
+ if (lsame_(uplo, "U")) {
+ kplus1 = *k + 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = x[j];
+ l = kplus1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ temp -= a[l + i__ + j * a_dim1] * x[i__];
+/* L90: */
+ }
+ if (nounit) {
+ temp /= a[kplus1 + j * a_dim1];
+ }
+ x[j] = temp;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = x[jx];
+ ix = kx;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *k;
+ i__3 = j - 1;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ temp -= a[l + i__ + j * a_dim1] * x[ix];
+ ix += *incx;
+/* L110: */
+ }
+ if (nounit) {
+ temp /= a[kplus1 + j * a_dim1];
+ }
+ x[jx] = temp;
+ jx += *incx;
+ if (j > *k) {
+ kx += *incx;
+ }
+/* L120: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ temp = x[j];
+ l = 1 - j;
+/* Computing MIN */
+ i__1 = *n, i__3 = j + *k;
+ i__4 = j + 1;
+ for (i__ = min(i__1,i__3); i__ >= i__4; --i__) {
+ temp -= a[l + i__ + j * a_dim1] * x[i__];
+/* L130: */
+ }
+ if (nounit) {
+ temp /= a[j * a_dim1 + 1];
+ }
+ x[j] = temp;
+/* L140: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ temp = x[jx];
+ ix = kx;
+ l = 1 - j;
+/* Computing MIN */
+ i__4 = *n, i__1 = j + *k;
+ i__3 = j + 1;
+ for (i__ = min(i__4,i__1); i__ >= i__3; --i__) {
+ temp -= a[l + i__ + j * a_dim1] * x[ix];
+ ix -= *incx;
+/* L150: */
+ }
+ if (nounit) {
+ temp /= a[j * a_dim1 + 1];
+ }
+ x[jx] = temp;
+ jx -= *incx;
+ if (*n - j >= *k) {
+ kx -= *incx;
+ }
+/* L160: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DTBSV . */
+
+} /* dtbsv_ */
diff --git a/BLAS/SRC/dtpmv.c b/BLAS/SRC/dtpmv.c
new file mode 100644
index 0000000..4bd5e70
--- /dev/null
+++ b/BLAS/SRC/dtpmv.c
@@ -0,0 +1,357 @@
+/* dtpmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtpmv_(char *uplo, char *trans, char *diag, integer *n,
+ doublereal *ap, doublereal *x, integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, jx, kx, info;
+ doublereal temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTPMV performs one of the matrix-vector operations */
+
+/* x := A*x, or x := A'*x, */
+
+/* where x is an n element vector and A is an n by n unit, or non-unit, */
+/* upper or lower triangular matrix, supplied in packed form. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' x := A*x. */
+
+/* TRANS = 'T' or 't' x := A'*x. */
+
+/* TRANS = 'C' or 'c' x := A'*x. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* AP - DOUBLE PRECISION array of DIMENSION at least */
+/* ( ( n*( n + 1 ) )/2 ). */
+/* Before entry with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular matrix packed sequentially, */
+/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
+/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */
+/* respectively, and so on. */
+/* Before entry with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular matrix packed sequentially, */
+/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
+/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */
+/* respectively, and so on. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* X - DOUBLE PRECISION array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. On exit, X is overwritten with the */
+/* tranformed vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ --ap;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*incx == 0) {
+ info = 7;
+ }
+ if (info != 0) {
+ xerbla_("DTPMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of AP are */
+/* accessed sequentially with one pass through AP. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x:= A*x. */
+
+ if (lsame_(uplo, "U")) {
+ kk = 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.) {
+ temp = x[j];
+ k = kk;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__] += temp * ap[k];
+ ++k;
+/* L10: */
+ }
+ if (nounit) {
+ x[j] *= ap[kk + j - 1];
+ }
+ }
+ kk += j;
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.) {
+ temp = x[jx];
+ ix = kx;
+ i__2 = kk + j - 2;
+ for (k = kk; k <= i__2; ++k) {
+ x[ix] += temp * ap[k];
+ ix += *incx;
+/* L30: */
+ }
+ if (nounit) {
+ x[jx] *= ap[kk + j - 1];
+ }
+ }
+ jx += *incx;
+ kk += j;
+/* L40: */
+ }
+ }
+ } else {
+ kk = *n * (*n + 1) / 2;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ if (x[j] != 0.) {
+ temp = x[j];
+ k = kk;
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ x[i__] += temp * ap[k];
+ --k;
+/* L50: */
+ }
+ if (nounit) {
+ x[j] *= ap[kk - *n + j];
+ }
+ }
+ kk -= *n - j + 1;
+/* L60: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ if (x[jx] != 0.) {
+ temp = x[jx];
+ ix = kx;
+ i__1 = kk - (*n - (j + 1));
+ for (k = kk; k >= i__1; --k) {
+ x[ix] += temp * ap[k];
+ ix -= *incx;
+/* L70: */
+ }
+ if (nounit) {
+ x[jx] *= ap[kk - *n + j];
+ }
+ }
+ jx -= *incx;
+ kk -= *n - j + 1;
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := A'*x. */
+
+ if (lsame_(uplo, "U")) {
+ kk = *n * (*n + 1) / 2;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ temp = x[j];
+ if (nounit) {
+ temp *= ap[kk];
+ }
+ k = kk - 1;
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ temp += ap[k] * x[i__];
+ --k;
+/* L90: */
+ }
+ x[j] = temp;
+ kk -= j;
+/* L100: */
+ }
+ } else {
+ jx = kx + (*n - 1) * *incx;
+ for (j = *n; j >= 1; --j) {
+ temp = x[jx];
+ ix = jx;
+ if (nounit) {
+ temp *= ap[kk];
+ }
+ i__1 = kk - j + 1;
+ for (k = kk - 1; k >= i__1; --k) {
+ ix -= *incx;
+ temp += ap[k] * x[ix];
+/* L110: */
+ }
+ x[jx] = temp;
+ jx -= *incx;
+ kk -= j;
+/* L120: */
+ }
+ }
+ } else {
+ kk = 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = x[j];
+ if (nounit) {
+ temp *= ap[kk];
+ }
+ k = kk + 1;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ temp += ap[k] * x[i__];
+ ++k;
+/* L130: */
+ }
+ x[j] = temp;
+ kk += *n - j + 1;
+/* L140: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = x[jx];
+ ix = jx;
+ if (nounit) {
+ temp *= ap[kk];
+ }
+ i__2 = kk + *n - j;
+ for (k = kk + 1; k <= i__2; ++k) {
+ ix += *incx;
+ temp += ap[k] * x[ix];
+/* L150: */
+ }
+ x[jx] = temp;
+ jx += *incx;
+ kk += *n - j + 1;
+/* L160: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DTPMV . */
+
+} /* dtpmv_ */
diff --git a/BLAS/SRC/dtpsv.c b/BLAS/SRC/dtpsv.c
new file mode 100644
index 0000000..5254245
--- /dev/null
+++ b/BLAS/SRC/dtpsv.c
@@ -0,0 +1,360 @@
+/* dtpsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtpsv_(char *uplo, char *trans, char *diag, integer *n,
+ doublereal *ap, doublereal *x, integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, jx, kx, info;
+ doublereal temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTPSV solves one of the systems of equations */
+
+/* A*x = b, or A'*x = b, */
+
+/* where b and x are n element vectors and A is an n by n unit, or */
+/* non-unit, upper or lower triangular matrix, supplied in packed form. */
+
+/* No test for singularity or near-singularity is included in this */
+/* routine. Such tests must be performed before calling this routine. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the equations to be solved as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' A*x = b. */
+
+/* TRANS = 'T' or 't' A'*x = b. */
+
+/* TRANS = 'C' or 'c' A'*x = b. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* AP - DOUBLE PRECISION array of DIMENSION at least */
+/* ( ( n*( n + 1 ) )/2 ). */
+/* Before entry with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular matrix packed sequentially, */
+/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
+/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */
+/* respectively, and so on. */
+/* Before entry with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular matrix packed sequentially, */
+/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
+/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */
+/* respectively, and so on. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* X - DOUBLE PRECISION array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element right-hand side vector b. On exit, X is overwritten */
+/* with the solution vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ --ap;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*incx == 0) {
+ info = 7;
+ }
+ if (info != 0) {
+ xerbla_("DTPSV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of AP are */
+/* accessed sequentially with one pass through AP. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x := inv( A )*x. */
+
+ if (lsame_(uplo, "U")) {
+ kk = *n * (*n + 1) / 2;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ if (x[j] != 0.) {
+ if (nounit) {
+ x[j] /= ap[kk];
+ }
+ temp = x[j];
+ k = kk - 1;
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ x[i__] -= temp * ap[k];
+ --k;
+/* L10: */
+ }
+ }
+ kk -= j;
+/* L20: */
+ }
+ } else {
+ jx = kx + (*n - 1) * *incx;
+ for (j = *n; j >= 1; --j) {
+ if (x[jx] != 0.) {
+ if (nounit) {
+ x[jx] /= ap[kk];
+ }
+ temp = x[jx];
+ ix = jx;
+ i__1 = kk - j + 1;
+ for (k = kk - 1; k >= i__1; --k) {
+ ix -= *incx;
+ x[ix] -= temp * ap[k];
+/* L30: */
+ }
+ }
+ jx -= *incx;
+ kk -= j;
+/* L40: */
+ }
+ }
+ } else {
+ kk = 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.) {
+ if (nounit) {
+ x[j] /= ap[kk];
+ }
+ temp = x[j];
+ k = kk + 1;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ x[i__] -= temp * ap[k];
+ ++k;
+/* L50: */
+ }
+ }
+ kk += *n - j + 1;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.) {
+ if (nounit) {
+ x[jx] /= ap[kk];
+ }
+ temp = x[jx];
+ ix = jx;
+ i__2 = kk + *n - j;
+ for (k = kk + 1; k <= i__2; ++k) {
+ ix += *incx;
+ x[ix] -= temp * ap[k];
+/* L70: */
+ }
+ }
+ jx += *incx;
+ kk += *n - j + 1;
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := inv( A' )*x. */
+
+ if (lsame_(uplo, "U")) {
+ kk = 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = x[j];
+ k = kk;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp -= ap[k] * x[i__];
+ ++k;
+/* L90: */
+ }
+ if (nounit) {
+ temp /= ap[kk + j - 1];
+ }
+ x[j] = temp;
+ kk += j;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = x[jx];
+ ix = kx;
+ i__2 = kk + j - 2;
+ for (k = kk; k <= i__2; ++k) {
+ temp -= ap[k] * x[ix];
+ ix += *incx;
+/* L110: */
+ }
+ if (nounit) {
+ temp /= ap[kk + j - 1];
+ }
+ x[jx] = temp;
+ jx += *incx;
+ kk += j;
+/* L120: */
+ }
+ }
+ } else {
+ kk = *n * (*n + 1) / 2;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ temp = x[j];
+ k = kk;
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ temp -= ap[k] * x[i__];
+ --k;
+/* L130: */
+ }
+ if (nounit) {
+ temp /= ap[kk - *n + j];
+ }
+ x[j] = temp;
+ kk -= *n - j + 1;
+/* L140: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ temp = x[jx];
+ ix = kx;
+ i__1 = kk - (*n - (j + 1));
+ for (k = kk; k >= i__1; --k) {
+ temp -= ap[k] * x[ix];
+ ix -= *incx;
+/* L150: */
+ }
+ if (nounit) {
+ temp /= ap[kk - *n + j];
+ }
+ x[jx] = temp;
+ jx -= *incx;
+ kk -= *n - j + 1;
+/* L160: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DTPSV . */
+
+} /* dtpsv_ */
diff --git a/BLAS/SRC/dtrmm.c b/BLAS/SRC/dtrmm.c
new file mode 100644
index 0000000..4bf834f
--- /dev/null
+++ b/BLAS/SRC/dtrmm.c
@@ -0,0 +1,453 @@
+/* dtrmm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtrmm_(char *side, char *uplo, char *transa, char *diag,
+ integer *m, integer *n, doublereal *alpha, doublereal *a, integer *
+ lda, doublereal *b, integer *ldb)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, k, info;
+ doublereal temp;
+ logical lside;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTRMM performs one of the matrix-matrix operations */
+
+/* B := alpha*op( A )*B, or B := alpha*B*op( A ), */
+
+/* where alpha is a scalar, B is an m by n matrix, A is a unit, or */
+/* non-unit, upper or lower triangular matrix and op( A ) is one of */
+
+/* op( A ) = A or op( A ) = A'. */
+
+/* Arguments */
+/* ========== */
+
+/* SIDE - CHARACTER*1. */
+/* On entry, SIDE specifies whether op( A ) multiplies B from */
+/* the left or right as follows: */
+
+/* SIDE = 'L' or 'l' B := alpha*op( A )*B. */
+
+/* SIDE = 'R' or 'r' B := alpha*B*op( A ). */
+
+/* Unchanged on exit. */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix A is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANSA - CHARACTER*1. */
+/* On entry, TRANSA specifies the form of op( A ) to be used in */
+/* the matrix multiplication as follows: */
+
+/* TRANSA = 'N' or 'n' op( A ) = A. */
+
+/* TRANSA = 'T' or 't' op( A ) = A'. */
+
+/* TRANSA = 'C' or 'c' op( A ) = A'. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit triangular */
+/* as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of B. M must be at */
+/* least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of B. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION. */
+/* On entry, ALPHA specifies the scalar alpha. When alpha is */
+/* zero then A is not referenced and B need not be set before */
+/* entry. */
+/* Unchanged on exit. */
+
+/* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m */
+/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */
+/* Before entry with UPLO = 'U' or 'u', the leading k by k */
+/* upper triangular part of the array A must contain the upper */
+/* triangular matrix and the strictly lower triangular part of */
+/* A is not referenced. */
+/* Before entry with UPLO = 'L' or 'l', the leading k by k */
+/* lower triangular part of the array A must contain the lower */
+/* triangular matrix and the strictly upper triangular part of */
+/* A is not referenced. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced either, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When SIDE = 'L' or 'l' then */
+/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */
+/* then LDA must be at least max( 1, n ). */
+/* Unchanged on exit. */
+
+/* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). */
+/* Before entry, the leading m by n part of the array B must */
+/* contain the matrix B, and on exit is overwritten by the */
+/* transformed matrix. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. LDB must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ lside = lsame_(side, "L");
+ if (lside) {
+ nrowa = *m;
+ } else {
+ nrowa = *n;
+ }
+ nounit = lsame_(diag, "N");
+ upper = lsame_(uplo, "U");
+
+ info = 0;
+ if (! lside && ! lsame_(side, "R")) {
+ info = 1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ info = 2;
+ } else if (! lsame_(transa, "N") && ! lsame_(transa,
+ "T") && ! lsame_(transa, "C")) {
+ info = 3;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 4;
+ } else if (*m < 0) {
+ info = 5;
+ } else if (*n < 0) {
+ info = 6;
+ } else if (*lda < max(1,nrowa)) {
+ info = 9;
+ } else if (*ldb < max(1,*m)) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("DTRMM ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (*alpha == 0.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lside) {
+ if (lsame_(transa, "N")) {
+
+/* Form B := alpha*A*B. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (k = 1; k <= i__2; ++k) {
+ if (b[k + j * b_dim1] != 0.) {
+ temp = *alpha * b[k + j * b_dim1];
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ b[i__ + j * b_dim1] += temp * a[i__ + k *
+ a_dim1];
+/* L30: */
+ }
+ if (nounit) {
+ temp *= a[k + k * a_dim1];
+ }
+ b[k + j * b_dim1] = temp;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (k = *m; k >= 1; --k) {
+ if (b[k + j * b_dim1] != 0.) {
+ temp = *alpha * b[k + j * b_dim1];
+ b[k + j * b_dim1] = temp;
+ if (nounit) {
+ b[k + j * b_dim1] *= a[k + k * a_dim1];
+ }
+ i__2 = *m;
+ for (i__ = k + 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] += temp * a[i__ + k *
+ a_dim1];
+/* L60: */
+ }
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form B := alpha*A'*B. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (i__ = *m; i__ >= 1; --i__) {
+ temp = b[i__ + j * b_dim1];
+ if (nounit) {
+ temp *= a[i__ + i__ * a_dim1];
+ }
+ i__2 = i__ - 1;
+ for (k = 1; k <= i__2; ++k) {
+ temp += a[k + i__ * a_dim1] * b[k + j * b_dim1];
+/* L90: */
+ }
+ b[i__ + j * b_dim1] = *alpha * temp;
+/* L100: */
+ }
+/* L110: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = b[i__ + j * b_dim1];
+ if (nounit) {
+ temp *= a[i__ + i__ * a_dim1];
+ }
+ i__3 = *m;
+ for (k = i__ + 1; k <= i__3; ++k) {
+ temp += a[k + i__ * a_dim1] * b[k + j * b_dim1];
+/* L120: */
+ }
+ b[i__ + j * b_dim1] = *alpha * temp;
+/* L130: */
+ }
+/* L140: */
+ }
+ }
+ }
+ } else {
+ if (lsame_(transa, "N")) {
+
+/* Form B := alpha*B*A. */
+
+ if (upper) {
+ for (j = *n; j >= 1; --j) {
+ temp = *alpha;
+ if (nounit) {
+ temp *= a[j + j * a_dim1];
+ }
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
+/* L150: */
+ }
+ i__1 = j - 1;
+ for (k = 1; k <= i__1; ++k) {
+ if (a[k + j * a_dim1] != 0.) {
+ temp = *alpha * a[k + j * a_dim1];
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] += temp * b[i__ + k *
+ b_dim1];
+/* L160: */
+ }
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = *alpha;
+ if (nounit) {
+ temp *= a[j + j * a_dim1];
+ }
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
+/* L190: */
+ }
+ i__2 = *n;
+ for (k = j + 1; k <= i__2; ++k) {
+ if (a[k + j * a_dim1] != 0.) {
+ temp = *alpha * a[k + j * a_dim1];
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ b[i__ + j * b_dim1] += temp * b[i__ + k *
+ b_dim1];
+/* L200: */
+ }
+ }
+/* L210: */
+ }
+/* L220: */
+ }
+ }
+ } else {
+
+/* Form B := alpha*B*A'. */
+
+ if (upper) {
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = k - 1;
+ for (j = 1; j <= i__2; ++j) {
+ if (a[j + k * a_dim1] != 0.) {
+ temp = *alpha * a[j + k * a_dim1];
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ b[i__ + j * b_dim1] += temp * b[i__ + k *
+ b_dim1];
+/* L230: */
+ }
+ }
+/* L240: */
+ }
+ temp = *alpha;
+ if (nounit) {
+ temp *= a[k + k * a_dim1];
+ }
+ if (temp != 1.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
+/* L250: */
+ }
+ }
+/* L260: */
+ }
+ } else {
+ for (k = *n; k >= 1; --k) {
+ i__1 = *n;
+ for (j = k + 1; j <= i__1; ++j) {
+ if (a[j + k * a_dim1] != 0.) {
+ temp = *alpha * a[j + k * a_dim1];
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] += temp * b[i__ + k *
+ b_dim1];
+/* L270: */
+ }
+ }
+/* L280: */
+ }
+ temp = *alpha;
+ if (nounit) {
+ temp *= a[k + k * a_dim1];
+ }
+ if (temp != 1.) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
+/* L290: */
+ }
+ }
+/* L300: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DTRMM . */
+
+} /* dtrmm_ */
diff --git a/BLAS/SRC/dtrmv.c b/BLAS/SRC/dtrmv.c
new file mode 100644
index 0000000..3acaa6d
--- /dev/null
+++ b/BLAS/SRC/dtrmv.c
@@ -0,0 +1,345 @@
+/* dtrmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtrmv_(char *uplo, char *trans, char *diag, integer *n,
+ doublereal *a, integer *lda, doublereal *x, integer *incx)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, ix, jx, kx, info;
+ doublereal temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTRMV performs one of the matrix-vector operations */
+
+/* x := A*x, or x := A'*x, */
+
+/* where x is an n element vector and A is an n by n unit, or non-unit, */
+/* upper or lower triangular matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' x := A*x. */
+
+/* TRANS = 'T' or 't' x := A'*x. */
+
+/* TRANS = 'C' or 'c' x := A'*x. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular matrix and the strictly lower triangular part of */
+/* A is not referenced. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular matrix and the strictly upper triangular part of */
+/* A is not referenced. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced either, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+/* X - DOUBLE PRECISION array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. On exit, X is overwritten with the */
+/* tranformed vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*lda < max(1,*n)) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ }
+ if (info != 0) {
+ xerbla_("DTRMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through A. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x := A*x. */
+
+ if (lsame_(uplo, "U")) {
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.) {
+ temp = x[j];
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__] += temp * a[i__ + j * a_dim1];
+/* L10: */
+ }
+ if (nounit) {
+ x[j] *= a[j + j * a_dim1];
+ }
+ }
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.) {
+ temp = x[jx];
+ ix = kx;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[ix] += temp * a[i__ + j * a_dim1];
+ ix += *incx;
+/* L30: */
+ }
+ if (nounit) {
+ x[jx] *= a[j + j * a_dim1];
+ }
+ }
+ jx += *incx;
+/* L40: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ if (x[j] != 0.) {
+ temp = x[j];
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ x[i__] += temp * a[i__ + j * a_dim1];
+/* L50: */
+ }
+ if (nounit) {
+ x[j] *= a[j + j * a_dim1];
+ }
+ }
+/* L60: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ if (x[jx] != 0.) {
+ temp = x[jx];
+ ix = kx;
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ x[ix] += temp * a[i__ + j * a_dim1];
+ ix -= *incx;
+/* L70: */
+ }
+ if (nounit) {
+ x[jx] *= a[j + j * a_dim1];
+ }
+ }
+ jx -= *incx;
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := A'*x. */
+
+ if (lsame_(uplo, "U")) {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ temp = x[j];
+ if (nounit) {
+ temp *= a[j + j * a_dim1];
+ }
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ temp += a[i__ + j * a_dim1] * x[i__];
+/* L90: */
+ }
+ x[j] = temp;
+/* L100: */
+ }
+ } else {
+ jx = kx + (*n - 1) * *incx;
+ for (j = *n; j >= 1; --j) {
+ temp = x[jx];
+ ix = jx;
+ if (nounit) {
+ temp *= a[j + j * a_dim1];
+ }
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ ix -= *incx;
+ temp += a[i__ + j * a_dim1] * x[ix];
+/* L110: */
+ }
+ x[jx] = temp;
+ jx -= *incx;
+/* L120: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = x[j];
+ if (nounit) {
+ temp *= a[j + j * a_dim1];
+ }
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ temp += a[i__ + j * a_dim1] * x[i__];
+/* L130: */
+ }
+ x[j] = temp;
+/* L140: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = x[jx];
+ ix = jx;
+ if (nounit) {
+ temp *= a[j + j * a_dim1];
+ }
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ ix += *incx;
+ temp += a[i__ + j * a_dim1] * x[ix];
+/* L150: */
+ }
+ x[jx] = temp;
+ jx += *incx;
+/* L160: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DTRMV . */
+
+} /* dtrmv_ */
diff --git a/BLAS/SRC/dtrsm.c b/BLAS/SRC/dtrsm.c
new file mode 100644
index 0000000..84ee3e7
--- /dev/null
+++ b/BLAS/SRC/dtrsm.c
@@ -0,0 +1,490 @@
+/* dtrsm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtrsm_(char *side, char *uplo, char *transa, char *diag,
+ integer *m, integer *n, doublereal *alpha, doublereal *a, integer *
+ lda, doublereal *b, integer *ldb)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, k, info;
+ doublereal temp;
+ logical lside;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTRSM solves one of the matrix equations */
+
+/* op( A )*X = alpha*B, or X*op( A ) = alpha*B, */
+
+/* where alpha is a scalar, X and B are m by n matrices, A is a unit, or */
+/* non-unit, upper or lower triangular matrix and op( A ) is one of */
+
+/* op( A ) = A or op( A ) = A'. */
+
+/* The matrix X is overwritten on B. */
+
+/* Arguments */
+/* ========== */
+
+/* SIDE - CHARACTER*1. */
+/* On entry, SIDE specifies whether op( A ) appears on the left */
+/* or right of X as follows: */
+
+/* SIDE = 'L' or 'l' op( A )*X = alpha*B. */
+
+/* SIDE = 'R' or 'r' X*op( A ) = alpha*B. */
+
+/* Unchanged on exit. */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix A is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANSA - CHARACTER*1. */
+/* On entry, TRANSA specifies the form of op( A ) to be used in */
+/* the matrix multiplication as follows: */
+
+/* TRANSA = 'N' or 'n' op( A ) = A. */
+
+/* TRANSA = 'T' or 't' op( A ) = A'. */
+
+/* TRANSA = 'C' or 'c' op( A ) = A'. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit triangular */
+/* as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of B. M must be at */
+/* least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of B. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION. */
+/* On entry, ALPHA specifies the scalar alpha. When alpha is */
+/* zero then A is not referenced and B need not be set before */
+/* entry. */
+/* Unchanged on exit. */
+
+/* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m */
+/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */
+/* Before entry with UPLO = 'U' or 'u', the leading k by k */
+/* upper triangular part of the array A must contain the upper */
+/* triangular matrix and the strictly lower triangular part of */
+/* A is not referenced. */
+/* Before entry with UPLO = 'L' or 'l', the leading k by k */
+/* lower triangular part of the array A must contain the lower */
+/* triangular matrix and the strictly upper triangular part of */
+/* A is not referenced. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced either, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When SIDE = 'L' or 'l' then */
+/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */
+/* then LDA must be at least max( 1, n ). */
+/* Unchanged on exit. */
+
+/* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). */
+/* Before entry, the leading m by n part of the array B must */
+/* contain the right-hand side matrix B, and on exit is */
+/* overwritten by the solution matrix X. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. LDB must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ lside = lsame_(side, "L");
+ if (lside) {
+ nrowa = *m;
+ } else {
+ nrowa = *n;
+ }
+ nounit = lsame_(diag, "N");
+ upper = lsame_(uplo, "U");
+
+ info = 0;
+ if (! lside && ! lsame_(side, "R")) {
+ info = 1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ info = 2;
+ } else if (! lsame_(transa, "N") && ! lsame_(transa,
+ "T") && ! lsame_(transa, "C")) {
+ info = 3;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 4;
+ } else if (*m < 0) {
+ info = 5;
+ } else if (*n < 0) {
+ info = 6;
+ } else if (*lda < max(1,nrowa)) {
+ info = 9;
+ } else if (*ldb < max(1,*m)) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("DTRSM ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (*alpha == 0.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lside) {
+ if (lsame_(transa, "N")) {
+
+/* Form B := alpha*inv( A )*B. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*alpha != 1.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
+ ;
+/* L30: */
+ }
+ }
+ for (k = *m; k >= 1; --k) {
+ if (b[k + j * b_dim1] != 0.) {
+ if (nounit) {
+ b[k + j * b_dim1] /= a[k + k * a_dim1];
+ }
+ i__2 = k - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[
+ i__ + k * a_dim1];
+/* L40: */
+ }
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*alpha != 1.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
+ ;
+/* L70: */
+ }
+ }
+ i__2 = *m;
+ for (k = 1; k <= i__2; ++k) {
+ if (b[k + j * b_dim1] != 0.) {
+ if (nounit) {
+ b[k + j * b_dim1] /= a[k + k * a_dim1];
+ }
+ i__3 = *m;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[
+ i__ + k * a_dim1];
+/* L80: */
+ }
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+ }
+ } else {
+
+/* Form B := alpha*inv( A' )*B. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = *alpha * b[i__ + j * b_dim1];
+ i__3 = i__ - 1;
+ for (k = 1; k <= i__3; ++k) {
+ temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1];
+/* L110: */
+ }
+ if (nounit) {
+ temp /= a[i__ + i__ * a_dim1];
+ }
+ b[i__ + j * b_dim1] = temp;
+/* L120: */
+ }
+/* L130: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (i__ = *m; i__ >= 1; --i__) {
+ temp = *alpha * b[i__ + j * b_dim1];
+ i__2 = *m;
+ for (k = i__ + 1; k <= i__2; ++k) {
+ temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1];
+/* L140: */
+ }
+ if (nounit) {
+ temp /= a[i__ + i__ * a_dim1];
+ }
+ b[i__ + j * b_dim1] = temp;
+/* L150: */
+ }
+/* L160: */
+ }
+ }
+ }
+ } else {
+ if (lsame_(transa, "N")) {
+
+/* Form B := alpha*B*inv( A ). */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*alpha != 1.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
+ ;
+/* L170: */
+ }
+ }
+ i__2 = j - 1;
+ for (k = 1; k <= i__2; ++k) {
+ if (a[k + j * a_dim1] != 0.) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[
+ i__ + k * b_dim1];
+/* L180: */
+ }
+ }
+/* L190: */
+ }
+ if (nounit) {
+ temp = 1. / a[j + j * a_dim1];
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
+/* L200: */
+ }
+ }
+/* L210: */
+ }
+ } else {
+ for (j = *n; j >= 1; --j) {
+ if (*alpha != 1.) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
+ ;
+/* L220: */
+ }
+ }
+ i__1 = *n;
+ for (k = j + 1; k <= i__1; ++k) {
+ if (a[k + j * a_dim1] != 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[
+ i__ + k * b_dim1];
+/* L230: */
+ }
+ }
+/* L240: */
+ }
+ if (nounit) {
+ temp = 1. / a[j + j * a_dim1];
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
+/* L250: */
+ }
+ }
+/* L260: */
+ }
+ }
+ } else {
+
+/* Form B := alpha*B*inv( A' ). */
+
+ if (upper) {
+ for (k = *n; k >= 1; --k) {
+ if (nounit) {
+ temp = 1. / a[k + k * a_dim1];
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
+/* L270: */
+ }
+ }
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ if (a[j + k * a_dim1] != 0.) {
+ temp = a[j + k * a_dim1];
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] -= temp * b[i__ + k *
+ b_dim1];
+/* L280: */
+ }
+ }
+/* L290: */
+ }
+ if (*alpha != 1.) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1]
+ ;
+/* L300: */
+ }
+ }
+/* L310: */
+ }
+ } else {
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (nounit) {
+ temp = 1. / a[k + k * a_dim1];
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
+/* L320: */
+ }
+ }
+ i__2 = *n;
+ for (j = k + 1; j <= i__2; ++j) {
+ if (a[j + k * a_dim1] != 0.) {
+ temp = a[j + k * a_dim1];
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ b[i__ + j * b_dim1] -= temp * b[i__ + k *
+ b_dim1];
+/* L330: */
+ }
+ }
+/* L340: */
+ }
+ if (*alpha != 1.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1]
+ ;
+/* L350: */
+ }
+ }
+/* L360: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DTRSM . */
+
+} /* dtrsm_ */
diff --git a/BLAS/SRC/dtrsv.c b/BLAS/SRC/dtrsv.c
new file mode 100644
index 0000000..ef9f1b4
--- /dev/null
+++ b/BLAS/SRC/dtrsv.c
@@ -0,0 +1,348 @@
+/* dtrsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtrsv_(char *uplo, char *trans, char *diag, integer *n,
+ doublereal *a, integer *lda, doublereal *x, integer *incx)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, ix, jx, kx, info;
+ doublereal temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTRSV solves one of the systems of equations */
+
+/* A*x = b, or A'*x = b, */
+
+/* where b and x are n element vectors and A is an n by n unit, or */
+/* non-unit, upper or lower triangular matrix. */
+
+/* No test for singularity or near-singularity is included in this */
+/* routine. Such tests must be performed before calling this routine. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the equations to be solved as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' A*x = b. */
+
+/* TRANS = 'T' or 't' A'*x = b. */
+
+/* TRANS = 'C' or 'c' A'*x = b. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular matrix and the strictly lower triangular part of */
+/* A is not referenced. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular matrix and the strictly upper triangular part of */
+/* A is not referenced. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced either, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+/* X - DOUBLE PRECISION array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element right-hand side vector b. On exit, X is overwritten */
+/* with the solution vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*lda < max(1,*n)) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ }
+ if (info != 0) {
+ xerbla_("DTRSV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through A. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x := inv( A )*x. */
+
+ if (lsame_(uplo, "U")) {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ if (x[j] != 0.) {
+ if (nounit) {
+ x[j] /= a[j + j * a_dim1];
+ }
+ temp = x[j];
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ x[i__] -= temp * a[i__ + j * a_dim1];
+/* L10: */
+ }
+ }
+/* L20: */
+ }
+ } else {
+ jx = kx + (*n - 1) * *incx;
+ for (j = *n; j >= 1; --j) {
+ if (x[jx] != 0.) {
+ if (nounit) {
+ x[jx] /= a[j + j * a_dim1];
+ }
+ temp = x[jx];
+ ix = jx;
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ ix -= *incx;
+ x[ix] -= temp * a[i__ + j * a_dim1];
+/* L30: */
+ }
+ }
+ jx -= *incx;
+/* L40: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.) {
+ if (nounit) {
+ x[j] /= a[j + j * a_dim1];
+ }
+ temp = x[j];
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ x[i__] -= temp * a[i__ + j * a_dim1];
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.) {
+ if (nounit) {
+ x[jx] /= a[j + j * a_dim1];
+ }
+ temp = x[jx];
+ ix = jx;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ ix += *incx;
+ x[ix] -= temp * a[i__ + j * a_dim1];
+/* L70: */
+ }
+ }
+ jx += *incx;
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := inv( A' )*x. */
+
+ if (lsame_(uplo, "U")) {
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = x[j];
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp -= a[i__ + j * a_dim1] * x[i__];
+/* L90: */
+ }
+ if (nounit) {
+ temp /= a[j + j * a_dim1];
+ }
+ x[j] = temp;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = x[jx];
+ ix = kx;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp -= a[i__ + j * a_dim1] * x[ix];
+ ix += *incx;
+/* L110: */
+ }
+ if (nounit) {
+ temp /= a[j + j * a_dim1];
+ }
+ x[jx] = temp;
+ jx += *incx;
+/* L120: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ temp = x[j];
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ temp -= a[i__ + j * a_dim1] * x[i__];
+/* L130: */
+ }
+ if (nounit) {
+ temp /= a[j + j * a_dim1];
+ }
+ x[j] = temp;
+/* L140: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ temp = x[jx];
+ ix = kx;
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ temp -= a[i__ + j * a_dim1] * x[ix];
+ ix -= *incx;
+/* L150: */
+ }
+ if (nounit) {
+ temp /= a[j + j * a_dim1];
+ }
+ x[jx] = temp;
+ jx -= *incx;
+/* L160: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DTRSV . */
+
+} /* dtrsv_ */
diff --git a/BLAS/SRC/dzasum.c b/BLAS/SRC/dzasum.c
new file mode 100644
index 0000000..6a93544
--- /dev/null
+++ b/BLAS/SRC/dzasum.c
@@ -0,0 +1,80 @@
+/* dzasum.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dzasum_(integer *n, doublecomplex *zx, integer *incx)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal ret_val;
+
+ /* Local variables */
+ integer i__, ix;
+ doublereal stemp;
+ extern doublereal dcabs1_(doublecomplex *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* takes the sum of the absolute values. */
+/* jack dongarra, 3/11/78. */
+/* modified 3/93 to return if incx .le. 0. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --zx;
+
+ /* Function Body */
+ ret_val = 0.;
+ stemp = 0.;
+ if (*n <= 0 || *incx <= 0) {
+ return ret_val;
+ }
+ if (*incx == 1) {
+ goto L20;
+ }
+
+/* code for increment not equal to 1 */
+
+ ix = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ stemp += dcabs1_(&zx[ix]);
+ ix += *incx;
+/* L10: */
+ }
+ ret_val = stemp;
+ return ret_val;
+
+/* code for increment equal to 1 */
+
+L20:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ stemp += dcabs1_(&zx[i__]);
+/* L30: */
+ }
+ ret_val = stemp;
+ return ret_val;
+} /* dzasum_ */
diff --git a/BLAS/SRC/dznrm2.c b/BLAS/SRC/dznrm2.c
new file mode 100644
index 0000000..e623544
--- /dev/null
+++ b/BLAS/SRC/dznrm2.c
@@ -0,0 +1,108 @@
+/* dznrm2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dznrm2_(integer *n, doublecomplex *x, integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublereal ret_val, d__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer ix;
+ doublereal ssq, temp, norm, scale;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DZNRM2 returns the euclidean norm of a vector via the function */
+/* name, so that */
+
+/* DZNRM2 := sqrt( conjg( x' )*x ) */
+
+
+/* -- This version written on 25-October-1982. */
+/* Modified on 14-October-1993 to inline the call to ZLASSQ. */
+/* Sven Hammarling, Nag Ltd. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --x;
+
+ /* Function Body */
+ if (*n < 1 || *incx < 1) {
+ norm = 0.;
+ } else {
+ scale = 0.;
+ ssq = 1.;
+/* The following loop is equivalent to this call to the LAPACK */
+/* auxiliary routine: */
+/* CALL ZLASSQ( N, X, INCX, SCALE, SSQ ) */
+
+ i__1 = (*n - 1) * *incx + 1;
+ i__2 = *incx;
+ for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
+ i__3 = ix;
+ if (x[i__3].r != 0.) {
+ i__3 = ix;
+ temp = (d__1 = x[i__3].r, abs(d__1));
+ if (scale < temp) {
+/* Computing 2nd power */
+ d__1 = scale / temp;
+ ssq = ssq * (d__1 * d__1) + 1.;
+ scale = temp;
+ } else {
+/* Computing 2nd power */
+ d__1 = temp / scale;
+ ssq += d__1 * d__1;
+ }
+ }
+ if (d_imag(&x[ix]) != 0.) {
+ temp = (d__1 = d_imag(&x[ix]), abs(d__1));
+ if (scale < temp) {
+/* Computing 2nd power */
+ d__1 = scale / temp;
+ ssq = ssq * (d__1 * d__1) + 1.;
+ scale = temp;
+ } else {
+/* Computing 2nd power */
+ d__1 = temp / scale;
+ ssq += d__1 * d__1;
+ }
+ }
+/* L10: */
+ }
+ norm = scale * sqrt(ssq);
+ }
+
+ ret_val = norm;
+ return ret_val;
+
+/* End of DZNRM2. */
+
+} /* dznrm2_ */
diff --git a/BLAS/SRC/icamax.c b/BLAS/SRC/icamax.c
new file mode 100644
index 0000000..30a6277
--- /dev/null
+++ b/BLAS/SRC/icamax.c
@@ -0,0 +1,93 @@
+/* icamax.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer icamax_(integer *n, complex *cx, integer *incx)
+{
+ /* System generated locals */
+ integer ret_val, i__1;
+
+ /* Local variables */
+ integer i__, ix;
+ real smax;
+ extern doublereal scabs1_(complex *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* finds the index of element having max. absolute value. */
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 3/93 to return if incx .le. 0. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --cx;
+
+ /* Function Body */
+ ret_val = 0;
+ if (*n < 1 || *incx <= 0) {
+ return ret_val;
+ }
+ ret_val = 1;
+ if (*n == 1) {
+ return ret_val;
+ }
+ if (*incx == 1) {
+ goto L20;
+ }
+
+/* code for increment not equal to 1 */
+
+ ix = 1;
+ smax = scabs1_(&cx[1]);
+ ix += *incx;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ if (scabs1_(&cx[ix]) <= smax) {
+ goto L5;
+ }
+ ret_val = i__;
+ smax = scabs1_(&cx[ix]);
+L5:
+ ix += *incx;
+/* L10: */
+ }
+ return ret_val;
+
+/* code for increment equal to 1 */
+
+L20:
+ smax = scabs1_(&cx[1]);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ if (scabs1_(&cx[i__]) <= smax) {
+ goto L30;
+ }
+ ret_val = i__;
+ smax = scabs1_(&cx[i__]);
+L30:
+ ;
+ }
+ return ret_val;
+} /* icamax_ */
diff --git a/BLAS/SRC/idamax.c b/BLAS/SRC/idamax.c
new file mode 100644
index 0000000..9b9636a
--- /dev/null
+++ b/BLAS/SRC/idamax.c
@@ -0,0 +1,93 @@
+/* idamax.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer idamax_(integer *n, doublereal *dx, integer *incx)
+{
+ /* System generated locals */
+ integer ret_val, i__1;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, ix;
+ doublereal dmax__;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* finds the index of element having max. absolute value. */
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 3/93 to return if incx .le. 0. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --dx;
+
+ /* Function Body */
+ ret_val = 0;
+ if (*n < 1 || *incx <= 0) {
+ return ret_val;
+ }
+ ret_val = 1;
+ if (*n == 1) {
+ return ret_val;
+ }
+ if (*incx == 1) {
+ goto L20;
+ }
+
+/* code for increment not equal to 1 */
+
+ ix = 1;
+ dmax__ = abs(dx[1]);
+ ix += *incx;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ if ((d__1 = dx[ix], abs(d__1)) <= dmax__) {
+ goto L5;
+ }
+ ret_val = i__;
+ dmax__ = (d__1 = dx[ix], abs(d__1));
+L5:
+ ix += *incx;
+/* L10: */
+ }
+ return ret_val;
+
+/* code for increment equal to 1 */
+
+L20:
+ dmax__ = abs(dx[1]);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ if ((d__1 = dx[i__], abs(d__1)) <= dmax__) {
+ goto L30;
+ }
+ ret_val = i__;
+ dmax__ = (d__1 = dx[i__], abs(d__1));
+L30:
+ ;
+ }
+ return ret_val;
+} /* idamax_ */
diff --git a/BLAS/SRC/isamax.c b/BLAS/SRC/isamax.c
new file mode 100644
index 0000000..2270054
--- /dev/null
+++ b/BLAS/SRC/isamax.c
@@ -0,0 +1,93 @@
+/* isamax.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer isamax_(integer *n, real *sx, integer *incx)
+{
+ /* System generated locals */
+ integer ret_val, i__1;
+ real r__1;
+
+ /* Local variables */
+ integer i__, ix;
+ real smax;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* finds the index of element having max. absolute value. */
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 3/93 to return if incx .le. 0. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --sx;
+
+ /* Function Body */
+ ret_val = 0;
+ if (*n < 1 || *incx <= 0) {
+ return ret_val;
+ }
+ ret_val = 1;
+ if (*n == 1) {
+ return ret_val;
+ }
+ if (*incx == 1) {
+ goto L20;
+ }
+
+/* code for increment not equal to 1 */
+
+ ix = 1;
+ smax = dabs(sx[1]);
+ ix += *incx;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ if ((r__1 = sx[ix], dabs(r__1)) <= smax) {
+ goto L5;
+ }
+ ret_val = i__;
+ smax = (r__1 = sx[ix], dabs(r__1));
+L5:
+ ix += *incx;
+/* L10: */
+ }
+ return ret_val;
+
+/* code for increment equal to 1 */
+
+L20:
+ smax = dabs(sx[1]);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ if ((r__1 = sx[i__], dabs(r__1)) <= smax) {
+ goto L30;
+ }
+ ret_val = i__;
+ smax = (r__1 = sx[i__], dabs(r__1));
+L30:
+ ;
+ }
+ return ret_val;
+} /* isamax_ */
diff --git a/BLAS/SRC/izamax.c b/BLAS/SRC/izamax.c
new file mode 100644
index 0000000..b4bd3c3
--- /dev/null
+++ b/BLAS/SRC/izamax.c
@@ -0,0 +1,93 @@
+/* izamax.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer izamax_(integer *n, doublecomplex *zx, integer *incx)
+{
+ /* System generated locals */
+ integer ret_val, i__1;
+
+ /* Local variables */
+ integer i__, ix;
+ doublereal smax;
+ extern doublereal dcabs1_(doublecomplex *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* finds the index of element having max. absolute value. */
+/* jack dongarra, 1/15/85. */
+/* modified 3/93 to return if incx .le. 0. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --zx;
+
+ /* Function Body */
+ ret_val = 0;
+ if (*n < 1 || *incx <= 0) {
+ return ret_val;
+ }
+ ret_val = 1;
+ if (*n == 1) {
+ return ret_val;
+ }
+ if (*incx == 1) {
+ goto L20;
+ }
+
+/* code for increment not equal to 1 */
+
+ ix = 1;
+ smax = dcabs1_(&zx[1]);
+ ix += *incx;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ if (dcabs1_(&zx[ix]) <= smax) {
+ goto L5;
+ }
+ ret_val = i__;
+ smax = dcabs1_(&zx[ix]);
+L5:
+ ix += *incx;
+/* L10: */
+ }
+ return ret_val;
+
+/* code for increment equal to 1 */
+
+L20:
+ smax = dcabs1_(&zx[1]);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ if (dcabs1_(&zx[i__]) <= smax) {
+ goto L30;
+ }
+ ret_val = i__;
+ smax = dcabs1_(&zx[i__]);
+L30:
+ ;
+ }
+ return ret_val;
+} /* izamax_ */
diff --git a/BLAS/SRC/lsame.c b/BLAS/SRC/lsame.c
new file mode 100644
index 0000000..0648674
--- /dev/null
+++ b/BLAS/SRC/lsame.c
@@ -0,0 +1,117 @@
+/* lsame.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+logical lsame_(char *ca, char *cb)
+{
+ /* System generated locals */
+ logical ret_val;
+
+ /* Local variables */
+ integer inta, intb, zcode;
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* LSAME returns .TRUE. if CA is the same letter as CB regardless of */
+/* case. */
+
+/* Arguments */
+/* ========= */
+
+/* CA (input) CHARACTER*1 */
+
+/* CB (input) CHARACTER*1 */
+/* CA and CB specify the single characters to be compared. */
+
+/* ===================================================================== */
+
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+
+/* Test if the characters are equal */
+
+ ret_val = *(unsigned char *)ca == *(unsigned char *)cb;
+ if (ret_val) {
+ return ret_val;
+ }
+
+/* Now test for equivalence if both characters are alphabetic. */
+
+ zcode = 'Z';
+
+/* Use 'Z' rather than 'A' so that ASCII can be detected on Prime */
+/* machines, on which ICHAR returns a value with bit 8 set. */
+/* ICHAR('A') on Prime machines returns 193 which is the same as */
+/* ICHAR('A') on an EBCDIC machine. */
+
+ inta = *(unsigned char *)ca;
+ intb = *(unsigned char *)cb;
+
+ if (zcode == 90 || zcode == 122) {
+
+/* ASCII is assumed - ZCODE is the ASCII code of either lower or */
+/* upper case 'Z'. */
+
+ if (inta >= 97 && inta <= 122) {
+ inta += -32;
+ }
+ if (intb >= 97 && intb <= 122) {
+ intb += -32;
+ }
+
+ } else if (zcode == 233 || zcode == 169) {
+
+/* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or */
+/* upper case 'Z'. */
+
+ if (inta >= 129 && inta <= 137 || inta >= 145 && inta <= 153 || inta
+ >= 162 && inta <= 169) {
+ inta += 64;
+ }
+ if (intb >= 129 && intb <= 137 || intb >= 145 && intb <= 153 || intb
+ >= 162 && intb <= 169) {
+ intb += 64;
+ }
+
+ } else if (zcode == 218 || zcode == 250) {
+
+/* ASCII is assumed, on Prime machines - ZCODE is the ASCII code */
+/* plus 128 of either lower or upper case 'Z'. */
+
+ if (inta >= 225 && inta <= 250) {
+ inta += -32;
+ }
+ if (intb >= 225 && intb <= 250) {
+ intb += -32;
+ }
+ }
+ ret_val = inta == intb;
+
+/* RETURN */
+
+/* End of LSAME */
+
+ return ret_val;
+} /* lsame_ */
diff --git a/BLAS/SRC/sasum.c b/BLAS/SRC/sasum.c
new file mode 100644
index 0000000..24d9799
--- /dev/null
+++ b/BLAS/SRC/sasum.c
@@ -0,0 +1,101 @@
+/* sasum.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal sasum_(integer *n, real *sx, integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real ret_val, r__1, r__2, r__3, r__4, r__5, r__6;
+
+ /* Local variables */
+ integer i__, m, mp1, nincx;
+ real stemp;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* takes the sum of the absolute values. */
+/* uses unrolled loops for increment equal to one. */
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 3/93 to return if incx .le. 0. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --sx;
+
+ /* Function Body */
+ ret_val = 0.f;
+ stemp = 0.f;
+ if (*n <= 0 || *incx <= 0) {
+ return ret_val;
+ }
+ if (*incx == 1) {
+ goto L20;
+ }
+
+/* code for increment not equal to 1 */
+
+ nincx = *n * *incx;
+ i__1 = nincx;
+ i__2 = *incx;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ stemp += (r__1 = sx[i__], dabs(r__1));
+/* L10: */
+ }
+ ret_val = stemp;
+ return ret_val;
+
+/* code for increment equal to 1 */
+
+
+/* clean-up loop */
+
+L20:
+ m = *n % 6;
+ if (m == 0) {
+ goto L40;
+ }
+ i__2 = m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ stemp += (r__1 = sx[i__], dabs(r__1));
+/* L30: */
+ }
+ if (*n < 6) {
+ goto L60;
+ }
+L40:
+ mp1 = m + 1;
+ i__2 = *n;
+ for (i__ = mp1; i__ <= i__2; i__ += 6) {
+ stemp = stemp + (r__1 = sx[i__], dabs(r__1)) + (r__2 = sx[i__ + 1],
+ dabs(r__2)) + (r__3 = sx[i__ + 2], dabs(r__3)) + (r__4 = sx[
+ i__ + 3], dabs(r__4)) + (r__5 = sx[i__ + 4], dabs(r__5)) + (
+ r__6 = sx[i__ + 5], dabs(r__6));
+/* L50: */
+ }
+L60:
+ ret_val = stemp;
+ return ret_val;
+} /* sasum_ */
diff --git a/BLAS/SRC/saxpy.c b/BLAS/SRC/saxpy.c
new file mode 100644
index 0000000..f591cca
--- /dev/null
+++ b/BLAS/SRC/saxpy.c
@@ -0,0 +1,107 @@
+/* saxpy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int saxpy_(integer *n, real *sa, real *sx, integer *incx,
+ real *sy, integer *incy)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, m, ix, iy, mp1;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SAXPY constant times a vector plus a vector. */
+/* uses unrolled loop for increments equal to one. */
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --sy;
+ --sx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ if (*sa == 0.f) {
+ return 0;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* code for unequal increments or equal increments */
+/* not equal to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sy[iy] += *sa * sx[ix];
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ return 0;
+
+/* code for both increments equal to 1 */
+
+
+/* clean-up loop */
+
+L20:
+ m = *n % 4;
+ if (m == 0) {
+ goto L40;
+ }
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sy[i__] += *sa * sx[i__];
+/* L30: */
+ }
+ if (*n < 4) {
+ return 0;
+ }
+L40:
+ mp1 = m + 1;
+ i__1 = *n;
+ for (i__ = mp1; i__ <= i__1; i__ += 4) {
+ sy[i__] += *sa * sx[i__];
+ sy[i__ + 1] += *sa * sx[i__ + 1];
+ sy[i__ + 2] += *sa * sx[i__ + 2];
+ sy[i__ + 3] += *sa * sx[i__ + 3];
+/* L50: */
+ }
+ return 0;
+} /* saxpy_ */
diff --git a/BLAS/SRC/scabs1.c b/BLAS/SRC/scabs1.c
new file mode 100644
index 0000000..d6c63fc
--- /dev/null
+++ b/BLAS/SRC/scabs1.c
@@ -0,0 +1,36 @@
+/* scabs1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal scabs1_(complex *z__)
+{
+ /* System generated locals */
+ real ret_val, r__1, r__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCABS1 computes absolute value of a complex number */
+
+/* .. Intrinsic Functions .. */
+/* .. */
+ ret_val = (r__1 = z__->r, dabs(r__1)) + (r__2 = r_imag(z__), dabs(r__2));
+ return ret_val;
+} /* scabs1_ */
diff --git a/BLAS/SRC/scasum.c b/BLAS/SRC/scasum.c
new file mode 100644
index 0000000..d9345df
--- /dev/null
+++ b/BLAS/SRC/scasum.c
@@ -0,0 +1,87 @@
+/* scasum.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal scasum_(integer *n, complex *cx, integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real ret_val, r__1, r__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, nincx;
+ real stemp;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* takes the sum of the absolute values of a complex vector and */
+/* returns a single precision result. */
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 3/93 to return if incx .le. 0. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --cx;
+
+ /* Function Body */
+ ret_val = 0.f;
+ stemp = 0.f;
+ if (*n <= 0 || *incx <= 0) {
+ return ret_val;
+ }
+ if (*incx == 1) {
+ goto L20;
+ }
+
+/* code for increment not equal to 1 */
+
+ nincx = *n * *incx;
+ i__1 = nincx;
+ i__2 = *incx;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ i__3 = i__;
+ stemp = stemp + (r__1 = cx[i__3].r, dabs(r__1)) + (r__2 = r_imag(&cx[
+ i__]), dabs(r__2));
+/* L10: */
+ }
+ ret_val = stemp;
+ return ret_val;
+
+/* code for increment equal to 1 */
+
+L20:
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__1 = i__;
+ stemp = stemp + (r__1 = cx[i__1].r, dabs(r__1)) + (r__2 = r_imag(&cx[
+ i__]), dabs(r__2));
+/* L30: */
+ }
+ ret_val = stemp;
+ return ret_val;
+} /* scasum_ */
diff --git a/BLAS/SRC/scnrm2.c b/BLAS/SRC/scnrm2.c
new file mode 100644
index 0000000..a965801
--- /dev/null
+++ b/BLAS/SRC/scnrm2.c
@@ -0,0 +1,109 @@
+/* scnrm2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal scnrm2_(integer *n, complex *x, integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real ret_val, r__1;
+
+ /* Builtin functions */
+ double r_imag(complex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer ix;
+ real ssq, temp, norm, scale;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCNRM2 returns the euclidean norm of a vector via the function */
+/* name, so that */
+
+/* SCNRM2 := sqrt( conjg( x' )*x ) */
+
+
+
+/* -- This version written on 25-October-1982. */
+/* Modified on 14-October-1993 to inline the call to CLASSQ. */
+/* Sven Hammarling, Nag Ltd. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --x;
+
+ /* Function Body */
+ if (*n < 1 || *incx < 1) {
+ norm = 0.f;
+ } else {
+ scale = 0.f;
+ ssq = 1.f;
+/* The following loop is equivalent to this call to the LAPACK */
+/* auxiliary routine: */
+/* CALL CLASSQ( N, X, INCX, SCALE, SSQ ) */
+
+ i__1 = (*n - 1) * *incx + 1;
+ i__2 = *incx;
+ for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
+ i__3 = ix;
+ if (x[i__3].r != 0.f) {
+ i__3 = ix;
+ temp = (r__1 = x[i__3].r, dabs(r__1));
+ if (scale < temp) {
+/* Computing 2nd power */
+ r__1 = scale / temp;
+ ssq = ssq * (r__1 * r__1) + 1.f;
+ scale = temp;
+ } else {
+/* Computing 2nd power */
+ r__1 = temp / scale;
+ ssq += r__1 * r__1;
+ }
+ }
+ if (r_imag(&x[ix]) != 0.f) {
+ temp = (r__1 = r_imag(&x[ix]), dabs(r__1));
+ if (scale < temp) {
+/* Computing 2nd power */
+ r__1 = scale / temp;
+ ssq = ssq * (r__1 * r__1) + 1.f;
+ scale = temp;
+ } else {
+/* Computing 2nd power */
+ r__1 = temp / scale;
+ ssq += r__1 * r__1;
+ }
+ }
+/* L10: */
+ }
+ norm = scale * sqrt(ssq);
+ }
+
+ ret_val = norm;
+ return ret_val;
+
+/* End of SCNRM2. */
+
+} /* scnrm2_ */
diff --git a/BLAS/SRC/scopy.c b/BLAS/SRC/scopy.c
new file mode 100644
index 0000000..13651fa
--- /dev/null
+++ b/BLAS/SRC/scopy.c
@@ -0,0 +1,107 @@
+/* scopy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int scopy_(integer *n, real *sx, integer *incx, real *sy,
+ integer *incy)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, m, ix, iy, mp1;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* copies a vector, x, to a vector, y. */
+/* uses unrolled loops for increments equal to 1. */
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --sy;
+ --sx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* code for unequal increments or equal increments */
+/* not equal to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sy[iy] = sx[ix];
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ return 0;
+
+/* code for both increments equal to 1 */
+
+
+/* clean-up loop */
+
+L20:
+ m = *n % 7;
+ if (m == 0) {
+ goto L40;
+ }
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sy[i__] = sx[i__];
+/* L30: */
+ }
+ if (*n < 7) {
+ return 0;
+ }
+L40:
+ mp1 = m + 1;
+ i__1 = *n;
+ for (i__ = mp1; i__ <= i__1; i__ += 7) {
+ sy[i__] = sx[i__];
+ sy[i__ + 1] = sx[i__ + 1];
+ sy[i__ + 2] = sx[i__ + 2];
+ sy[i__ + 3] = sx[i__ + 3];
+ sy[i__ + 4] = sx[i__ + 4];
+ sy[i__ + 5] = sx[i__ + 5];
+ sy[i__ + 6] = sx[i__ + 6];
+/* L50: */
+ }
+ return 0;
+} /* scopy_ */
diff --git a/BLAS/SRC/sdot.c b/BLAS/SRC/sdot.c
new file mode 100644
index 0000000..26e9129
--- /dev/null
+++ b/BLAS/SRC/sdot.c
@@ -0,0 +1,109 @@
+/* sdot.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal sdot_(integer *n, real *sx, integer *incx, real *sy, integer *incy)
+{
+ /* System generated locals */
+ integer i__1;
+ real ret_val;
+
+ /* Local variables */
+ integer i__, m, ix, iy, mp1;
+ real stemp;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* forms the dot product of two vectors. */
+/* uses unrolled loops for increments equal to one. */
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --sy;
+ --sx;
+
+ /* Function Body */
+ stemp = 0.f;
+ ret_val = 0.f;
+ if (*n <= 0) {
+ return ret_val;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* code for unequal increments or equal increments */
+/* not equal to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ stemp += sx[ix] * sy[iy];
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ ret_val = stemp;
+ return ret_val;
+
+/* code for both increments equal to 1 */
+
+
+/* clean-up loop */
+
+L20:
+ m = *n % 5;
+ if (m == 0) {
+ goto L40;
+ }
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ stemp += sx[i__] * sy[i__];
+/* L30: */
+ }
+ if (*n < 5) {
+ goto L60;
+ }
+L40:
+ mp1 = m + 1;
+ i__1 = *n;
+ for (i__ = mp1; i__ <= i__1; i__ += 5) {
+ stemp = stemp + sx[i__] * sy[i__] + sx[i__ + 1] * sy[i__ + 1] + sx[
+ i__ + 2] * sy[i__ + 2] + sx[i__ + 3] * sy[i__ + 3] + sx[i__ +
+ 4] * sy[i__ + 4];
+/* L50: */
+ }
+L60:
+ ret_val = stemp;
+ return ret_val;
+} /* sdot_ */
diff --git a/BLAS/SRC/sdsdot.c b/BLAS/SRC/sdsdot.c
new file mode 100644
index 0000000..ec5638a
--- /dev/null
+++ b/BLAS/SRC/sdsdot.c
@@ -0,0 +1,144 @@
+/* sdsdot.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal sdsdot_(integer *n, real *sb, real *sx, integer *incx, real *sy,
+ integer *incy)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real ret_val;
+
+ /* Local variables */
+ integer i__, ns, kx, ky;
+ doublereal dsdot;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* PURPOSE */
+/* ======= */
+
+/* Compute the inner product of two vectors with extended */
+/* precision accumulation. */
+
+/* Returns S.P. result with dot product accumulated in D.P. */
+/* SDSDOT = SB + sum for I = 0 to N-1 of SX(LX+I*INCX)*SY(LY+I*INCY), */
+/* where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is */
+/* defined in a similar way using INCY. */
+
+/* AUTHOR */
+/* ====== */
+/* Lawson, C. L., (JPL), Hanson, R. J., (SNLA), */
+/* Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL) */
+
+/* ARGUMENTS */
+/* ========= */
+
+/* N (input) INTEGER */
+/* number of elements in input vector(s) */
+
+/* SB (input) REAL */
+/* single precision scalar to be added to inner product */
+
+/* SX (input) REAL array, dimension (N) */
+/* single precision vector with N elements */
+
+/* INCX (input) INTEGER */
+/* storage spacing between elements of SX */
+
+/* SY (input) REAL array, dimension (N) */
+/* single precision vector with N elements */
+
+/* INCY (input) INTEGER */
+/* storage spacing between elements of SY */
+
+/* SDSDOT (output) REAL */
+/* single precision dot product (SB if N .LE. 0) */
+
+/* REFERENCES */
+/* ========== */
+
+/* C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. */
+/* Krogh, Basic linear algebra subprograms for Fortran */
+/* usage, Algorithm No. 539, Transactions on Mathematical */
+/* Software 5, 3 (September 1979), pp. 308-323. */
+
+/* REVISION HISTORY (YYMMDD) */
+/* ========================== */
+
+/* 791001 DATE WRITTEN */
+/* 890531 Changed all specific intrinsics to generic. (WRB) */
+/* 890831 Modified array declarations. (WRB) */
+/* 890831 REVISION DATE from Version 3.2 */
+/* 891214 Prologue converted to Version 4.0 format. (BAB) */
+/* 920310 Corrected definition of LX in DESCRIPTION. (WRB) */
+/* 920501 Reformatted the REFERENCES section. (WRB) */
+/* 070118 Reformat to LAPACK coding style */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --sy;
+ --sx;
+
+ /* Function Body */
+ dsdot = *sb;
+ if (*n <= 0) {
+ goto L30;
+ }
+ if (*incx == *incy && *incx > 0) {
+ goto L40;
+ }
+
+/* Code for unequal or nonpositive increments. */
+
+ kx = 1;
+ ky = 1;
+ if (*incx < 0) {
+ kx = (1 - *n) * *incx + 1;
+ }
+ if (*incy < 0) {
+ ky = (1 - *n) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dsdot += (doublereal) sx[kx] * (doublereal) sy[ky];
+ kx += *incx;
+ ky += *incy;
+/* L10: */
+ }
+L30:
+ ret_val = dsdot;
+ return ret_val;
+
+/* Code for equal and positive increments. */
+
+L40:
+ ns = *n * *incx;
+ i__1 = ns;
+ i__2 = *incx;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ dsdot += (doublereal) sx[i__] * (doublereal) sy[i__];
+/* L50: */
+ }
+ ret_val = dsdot;
+ return ret_val;
+} /* sdsdot_ */
diff --git a/BLAS/SRC/sgbmv.c b/BLAS/SRC/sgbmv.c
new file mode 100644
index 0000000..11db1d9
--- /dev/null
+++ b/BLAS/SRC/sgbmv.c
@@ -0,0 +1,368 @@
+/* sgbmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sgbmv_(char *trans, integer *m, integer *n, integer *kl,
+ integer *ku, real *alpha, real *a, integer *lda, real *x, integer *
+ incx, real *beta, real *y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+
+ /* Local variables */
+ integer i__, j, k, ix, iy, jx, jy, kx, ky, kup1, info;
+ real temp;
+ integer lenx, leny;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGBMV performs one of the matrix-vector operations */
+
+/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are vectors and A is an */
+/* m by n band matrix, with kl sub-diagonals and ku super-diagonals. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */
+
+/* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. */
+
+/* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix A. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* KL - INTEGER. */
+/* On entry, KL specifies the number of sub-diagonals of the */
+/* matrix A. KL must satisfy 0 .le. KL. */
+/* Unchanged on exit. */
+
+/* KU - INTEGER. */
+/* On entry, KU specifies the number of super-diagonals of the */
+/* matrix A. KU must satisfy 0 .le. KU. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - REAL array of DIMENSION ( LDA, n ). */
+/* Before entry, the leading ( kl + ku + 1 ) by n part of the */
+/* array A must contain the matrix of coefficients, supplied */
+/* column by column, with the leading diagonal of the matrix in */
+/* row ( ku + 1 ) of the array, the first super-diagonal */
+/* starting at position 2 in row ku, the first sub-diagonal */
+/* starting at position 1 in row ( ku + 2 ), and so on. */
+/* Elements in the array A that do not correspond to elements */
+/* in the band matrix (such as the top left ku by ku triangle) */
+/* are not referenced. */
+/* The following program segment will transfer a band matrix */
+/* from conventional full matrix storage to band storage: */
+
+/* DO 20, J = 1, N */
+/* K = KU + 1 - J */
+/* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) */
+/* A( K + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* ( kl + ku + 1 ). */
+/* Unchanged on exit. */
+
+/* X - REAL array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - REAL . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - REAL array of DIMENSION at least */
+/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
+/* Before entry, the incremented array Y must contain the */
+/* vector y. On exit, Y is overwritten by the updated vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C")
+ ) {
+ info = 1;
+ } else if (*m < 0) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*kl < 0) {
+ info = 4;
+ } else if (*ku < 0) {
+ info = 5;
+ } else if (*lda < *kl + *ku + 1) {
+ info = 8;
+ } else if (*incx == 0) {
+ info = 10;
+ } else if (*incy == 0) {
+ info = 13;
+ }
+ if (info != 0) {
+ xerbla_("SGBMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || *alpha == 0.f && *beta == 1.f) {
+ return 0;
+ }
+
+/* Set LENX and LENY, the lengths of the vectors x and y, and set */
+/* up the start points in X and Y. */
+
+ if (lsame_(trans, "N")) {
+ lenx = *n;
+ leny = *m;
+ } else {
+ lenx = *m;
+ leny = *n;
+ }
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (lenx - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (leny - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through the band part of A. */
+
+/* First form y := beta*y. */
+
+ if (*beta != 1.f) {
+ if (*incy == 1) {
+ if (*beta == 0.f) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[i__] = 0.f;
+/* L10: */
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[i__] = *beta * y[i__];
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (*beta == 0.f) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[iy] = 0.f;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[iy] = *beta * y[iy];
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (*alpha == 0.f) {
+ return 0;
+ }
+ kup1 = *ku + 1;
+ if (lsame_(trans, "N")) {
+
+/* Form y := alpha*A*x + y. */
+
+ jx = kx;
+ if (*incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.f) {
+ temp = *alpha * x[jx];
+ k = kup1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__4 = min(i__5,i__6);
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ y[i__] += temp * a[k + i__ + j * a_dim1];
+/* L50: */
+ }
+ }
+ jx += *incx;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.f) {
+ temp = *alpha * x[jx];
+ iy = ky;
+ k = kup1 - j;
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__3 = min(i__5,i__6);
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ y[iy] += temp * a[k + i__ + j * a_dim1];
+ iy += *incy;
+/* L70: */
+ }
+ }
+ jx += *incx;
+ if (j > *ku) {
+ ky += *incy;
+ }
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y := alpha*A'*x + y. */
+
+ jy = ky;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = 0.f;
+ k = kup1 - j;
+/* Computing MAX */
+ i__3 = 1, i__4 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__2 = min(i__5,i__6);
+ for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) {
+ temp += a[k + i__ + j * a_dim1] * x[i__];
+/* L90: */
+ }
+ y[jy] += *alpha * temp;
+ jy += *incy;
+/* L100: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = 0.f;
+ ix = kx;
+ k = kup1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__4 = min(i__5,i__6);
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ temp += a[k + i__ + j * a_dim1] * x[ix];
+ ix += *incx;
+/* L110: */
+ }
+ y[jy] += *alpha * temp;
+ jy += *incy;
+ if (j > *ku) {
+ kx += *incx;
+ }
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SGBMV . */
+
+} /* sgbmv_ */
diff --git a/BLAS/SRC/sgemm.c b/BLAS/SRC/sgemm.c
new file mode 100644
index 0000000..527735a
--- /dev/null
+++ b/BLAS/SRC/sgemm.c
@@ -0,0 +1,388 @@
+/* sgemm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sgemm_(char *transa, char *transb, integer *m, integer *
+ n, integer *k, real *alpha, real *a, integer *lda, real *b, integer *
+ ldb, real *beta, real *c__, integer *ldc)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3;
+
+ /* Local variables */
+ integer i__, j, l, info;
+ logical nota, notb;
+ real temp;
+ integer ncola;
+ extern logical lsame_(char *, char *);
+ integer nrowa, nrowb;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGEMM performs one of the matrix-matrix operations */
+
+/* C := alpha*op( A )*op( B ) + beta*C, */
+
+/* where op( X ) is one of */
+
+/* op( X ) = X or op( X ) = X', */
+
+/* alpha and beta are scalars, and A, B and C are matrices, with op( A ) */
+/* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANSA - CHARACTER*1. */
+/* On entry, TRANSA specifies the form of op( A ) to be used in */
+/* the matrix multiplication as follows: */
+
+/* TRANSA = 'N' or 'n', op( A ) = A. */
+
+/* TRANSA = 'T' or 't', op( A ) = A'. */
+
+/* TRANSA = 'C' or 'c', op( A ) = A'. */
+
+/* Unchanged on exit. */
+
+/* TRANSB - CHARACTER*1. */
+/* On entry, TRANSB specifies the form of op( B ) to be used in */
+/* the matrix multiplication as follows: */
+
+/* TRANSB = 'N' or 'n', op( B ) = B. */
+
+/* TRANSB = 'T' or 't', op( B ) = B'. */
+
+/* TRANSB = 'C' or 'c', op( B ) = B'. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix */
+/* op( A ) and of the matrix C. M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix */
+/* op( B ) and the number of columns of the matrix C. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry, K specifies the number of columns of the matrix */
+/* op( A ) and the number of rows of the matrix op( B ). K must */
+/* be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - REAL array of DIMENSION ( LDA, ka ), where ka is */
+/* k when TRANSA = 'N' or 'n', and is m otherwise. */
+/* Before entry with TRANSA = 'N' or 'n', the leading m by k */
+/* part of the array A must contain the matrix A, otherwise */
+/* the leading k by m part of the array A must contain the */
+/* matrix A. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When TRANSA = 'N' or 'n' then */
+/* LDA must be at least max( 1, m ), otherwise LDA must be at */
+/* least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* B - REAL array of DIMENSION ( LDB, kb ), where kb is */
+/* n when TRANSB = 'N' or 'n', and is k otherwise. */
+/* Before entry with TRANSB = 'N' or 'n', the leading k by n */
+/* part of the array B must contain the matrix B, otherwise */
+/* the leading n by k part of the array B must contain the */
+/* matrix B. */
+/* Unchanged on exit. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. When TRANSB = 'N' or 'n' then */
+/* LDB must be at least max( 1, k ), otherwise LDB must be at */
+/* least max( 1, n ). */
+/* Unchanged on exit. */
+
+/* BETA - REAL . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then C need not be set on input. */
+/* Unchanged on exit. */
+
+/* C - REAL array of DIMENSION ( LDC, n ). */
+/* Before entry, the leading m by n part of the array C must */
+/* contain the matrix C, except when beta is zero, in which */
+/* case C need not be set on entry. */
+/* On exit, the array C is overwritten by the m by n matrix */
+/* ( alpha*op( A )*op( B ) + beta*C ). */
+
+/* LDC - INTEGER. */
+/* On entry, LDC specifies the first dimension of C as declared */
+/* in the calling (sub) program. LDC must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Set NOTA and NOTB as true if A and B respectively are not */
+/* transposed and set NROWA, NCOLA and NROWB as the number of rows */
+/* and columns of A and the number of rows of B respectively. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ nota = lsame_(transa, "N");
+ notb = lsame_(transb, "N");
+ if (nota) {
+ nrowa = *m;
+ ncola = *k;
+ } else {
+ nrowa = *k;
+ ncola = *m;
+ }
+ if (notb) {
+ nrowb = *k;
+ } else {
+ nrowb = *n;
+ }
+
+/* Test the input parameters. */
+
+ info = 0;
+ if (! nota && ! lsame_(transa, "C") && ! lsame_(
+ transa, "T")) {
+ info = 1;
+ } else if (! notb && ! lsame_(transb, "C") && !
+ lsame_(transb, "T")) {
+ info = 2;
+ } else if (*m < 0) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*k < 0) {
+ info = 5;
+ } else if (*lda < max(1,nrowa)) {
+ info = 8;
+ } else if (*ldb < max(1,nrowb)) {
+ info = 10;
+ } else if (*ldc < max(1,*m)) {
+ info = 13;
+ }
+ if (info != 0) {
+ xerbla_("SGEMM ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) {
+ return 0;
+ }
+
+/* And if alpha.eq.zero. */
+
+ if (*alpha == 0.f) {
+ if (*beta == 0.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (notb) {
+ if (nota) {
+
+/* Form C := alpha*A*B + beta*C. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*beta == 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.f;
+/* L50: */
+ }
+ } else if (*beta != 1.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L60: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ if (b[l + j * b_dim1] != 0.f) {
+ temp = *alpha * b[l + j * b_dim1];
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ c__[i__ + j * c_dim1] += temp * a[i__ + l *
+ a_dim1];
+/* L70: */
+ }
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+ } else {
+
+/* Form C := alpha*A'*B + beta*C */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = 0.f;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ temp += a[l + i__ * a_dim1] * b[l + j * b_dim1];
+/* L100: */
+ }
+ if (*beta == 0.f) {
+ c__[i__ + j * c_dim1] = *alpha * temp;
+ } else {
+ c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
+ i__ + j * c_dim1];
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+ }
+ } else {
+ if (nota) {
+
+/* Form C := alpha*A*B' + beta*C */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*beta == 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.f;
+/* L130: */
+ }
+ } else if (*beta != 1.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L140: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ if (b[j + l * b_dim1] != 0.f) {
+ temp = *alpha * b[j + l * b_dim1];
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ c__[i__ + j * c_dim1] += temp * a[i__ + l *
+ a_dim1];
+/* L150: */
+ }
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+ } else {
+
+/* Form C := alpha*A'*B' + beta*C */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = 0.f;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ temp += a[l + i__ * a_dim1] * b[j + l * b_dim1];
+/* L180: */
+ }
+ if (*beta == 0.f) {
+ c__[i__ + j * c_dim1] = *alpha * temp;
+ } else {
+ c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
+ i__ + j * c_dim1];
+ }
+/* L190: */
+ }
+/* L200: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SGEMM . */
+
+} /* sgemm_ */
diff --git a/BLAS/SRC/sgemv.c b/BLAS/SRC/sgemv.c
new file mode 100644
index 0000000..10eacd3
--- /dev/null
+++ b/BLAS/SRC/sgemv.c
@@ -0,0 +1,312 @@
+/* sgemv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sgemv_(char *trans, integer *m, integer *n, real *alpha,
+ real *a, integer *lda, real *x, integer *incx, real *beta, real *y,
+ integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, ix, iy, jx, jy, kx, ky, info;
+ real temp;
+ integer lenx, leny;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGEMV performs one of the matrix-vector operations */
+
+/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are vectors and A is an */
+/* m by n matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */
+
+/* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. */
+
+/* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix A. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - REAL array of DIMENSION ( LDA, n ). */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+/* X - REAL array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - REAL . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - REAL array of DIMENSION at least */
+/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
+/* Before entry with BETA non-zero, the incremented array Y */
+/* must contain the vector y. On exit, Y is overwritten by the */
+/* updated vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C")
+ ) {
+ info = 1;
+ } else if (*m < 0) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*lda < max(1,*m)) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ } else if (*incy == 0) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("SGEMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || *alpha == 0.f && *beta == 1.f) {
+ return 0;
+ }
+
+/* Set LENX and LENY, the lengths of the vectors x and y, and set */
+/* up the start points in X and Y. */
+
+ if (lsame_(trans, "N")) {
+ lenx = *n;
+ leny = *m;
+ } else {
+ lenx = *m;
+ leny = *n;
+ }
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (lenx - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (leny - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through A. */
+
+/* First form y := beta*y. */
+
+ if (*beta != 1.f) {
+ if (*incy == 1) {
+ if (*beta == 0.f) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[i__] = 0.f;
+/* L10: */
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[i__] = *beta * y[i__];
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (*beta == 0.f) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[iy] = 0.f;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[iy] = *beta * y[iy];
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (*alpha == 0.f) {
+ return 0;
+ }
+ if (lsame_(trans, "N")) {
+
+/* Form y := alpha*A*x + y. */
+
+ jx = kx;
+ if (*incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.f) {
+ temp = *alpha * x[jx];
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ y[i__] += temp * a[i__ + j * a_dim1];
+/* L50: */
+ }
+ }
+ jx += *incx;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.f) {
+ temp = *alpha * x[jx];
+ iy = ky;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ y[iy] += temp * a[i__ + j * a_dim1];
+ iy += *incy;
+/* L70: */
+ }
+ }
+ jx += *incx;
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y := alpha*A'*x + y. */
+
+ jy = ky;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = 0.f;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp += a[i__ + j * a_dim1] * x[i__];
+/* L90: */
+ }
+ y[jy] += *alpha * temp;
+ jy += *incy;
+/* L100: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = 0.f;
+ ix = kx;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp += a[i__ + j * a_dim1] * x[ix];
+ ix += *incx;
+/* L110: */
+ }
+ y[jy] += *alpha * temp;
+ jy += *incy;
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SGEMV . */
+
+} /* sgemv_ */
diff --git a/BLAS/SRC/sger.c b/BLAS/SRC/sger.c
new file mode 100644
index 0000000..a6e0275
--- /dev/null
+++ b/BLAS/SRC/sger.c
@@ -0,0 +1,193 @@
+/* sger.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sger_(integer *m, integer *n, real *alpha, real *x,
+ integer *incx, real *y, integer *incy, real *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, ix, jy, kx, info;
+ real temp;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGER performs the rank 1 operation */
+
+/* A := alpha*x*y' + A, */
+
+/* where alpha is a scalar, x is an m element vector, y is an n element */
+/* vector and A is an m by n matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix A. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X - REAL array of dimension at least */
+/* ( 1 + ( m - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the m */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* Y - REAL array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. */
+/* Unchanged on exit. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* A - REAL array of DIMENSION ( LDA, n ). */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. On exit, A is */
+/* overwritten by the updated matrix. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ --y;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ info = 0;
+ if (*m < 0) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ } else if (*incy == 0) {
+ info = 7;
+ } else if (*lda < max(1,*m)) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("SGER ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || *alpha == 0.f) {
+ return 0;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through A. */
+
+ if (*incy > 0) {
+ jy = 1;
+ } else {
+ jy = 1 - (*n - 1) * *incy;
+ }
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (y[jy] != 0.f) {
+ temp = *alpha * y[jy];
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] += x[i__] * temp;
+/* L10: */
+ }
+ }
+ jy += *incy;
+/* L20: */
+ }
+ } else {
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*m - 1) * *incx;
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (y[jy] != 0.f) {
+ temp = *alpha * y[jy];
+ ix = kx;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] += x[ix] * temp;
+ ix += *incx;
+/* L30: */
+ }
+ }
+ jy += *incy;
+/* L40: */
+ }
+ }
+
+ return 0;
+
+/* End of SGER . */
+
+} /* sger_ */
diff --git a/BLAS/SRC/snrm2.c b/BLAS/SRC/snrm2.c
new file mode 100644
index 0000000..ca5233f
--- /dev/null
+++ b/BLAS/SRC/snrm2.c
@@ -0,0 +1,97 @@
+/* snrm2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal snrm2_(integer *n, real *x, integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real ret_val, r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer ix;
+ real ssq, norm, scale, absxi;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SNRM2 returns the euclidean norm of a vector via the function */
+/* name, so that */
+
+/* SNRM2 := sqrt( x'*x ). */
+
+/* Further Details */
+/* =============== */
+
+/* -- This version written on 25-October-1982. */
+/* Modified on 14-October-1993 to inline the call to SLASSQ. */
+/* Sven Hammarling, Nag Ltd. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --x;
+
+ /* Function Body */
+ if (*n < 1 || *incx < 1) {
+ norm = 0.f;
+ } else if (*n == 1) {
+ norm = dabs(x[1]);
+ } else {
+ scale = 0.f;
+ ssq = 1.f;
+/* The following loop is equivalent to this call to the LAPACK */
+/* auxiliary routine: */
+/* CALL SLASSQ( N, X, INCX, SCALE, SSQ ) */
+
+ i__1 = (*n - 1) * *incx + 1;
+ i__2 = *incx;
+ for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
+ if (x[ix] != 0.f) {
+ absxi = (r__1 = x[ix], dabs(r__1));
+ if (scale < absxi) {
+/* Computing 2nd power */
+ r__1 = scale / absxi;
+ ssq = ssq * (r__1 * r__1) + 1.f;
+ scale = absxi;
+ } else {
+/* Computing 2nd power */
+ r__1 = absxi / scale;
+ ssq += r__1 * r__1;
+ }
+ }
+/* L10: */
+ }
+ norm = scale * sqrt(ssq);
+ }
+
+ ret_val = norm;
+ return ret_val;
+
+/* End of SNRM2. */
+
+} /* snrm2_ */
diff --git a/BLAS/SRC/srot.c b/BLAS/SRC/srot.c
new file mode 100644
index 0000000..085677c
--- /dev/null
+++ b/BLAS/SRC/srot.c
@@ -0,0 +1,90 @@
+/* srot.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int srot_(integer *n, real *sx, integer *incx, real *sy,
+ integer *incy, real *c__, real *s)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, ix, iy;
+ real stemp;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* applies a plane rotation. */
+
+/* Further Details */
+/* =============== */
+
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+ /* Parameter adjustments */
+ --sy;
+ --sx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* code for unequal increments or equal increments not equal */
+/* to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ stemp = *c__ * sx[ix] + *s * sy[iy];
+ sy[iy] = *c__ * sy[iy] - *s * sx[ix];
+ sx[ix] = stemp;
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ return 0;
+
+/* code for both increments equal to 1 */
+
+L20:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ stemp = *c__ * sx[i__] + *s * sy[i__];
+ sy[i__] = *c__ * sy[i__] - *s * sx[i__];
+ sx[i__] = stemp;
+/* L30: */
+ }
+ return 0;
+} /* srot_ */
diff --git a/BLAS/SRC/srotg.c b/BLAS/SRC/srotg.c
new file mode 100644
index 0000000..99be0f8
--- /dev/null
+++ b/BLAS/SRC/srotg.c
@@ -0,0 +1,78 @@
+/* srotg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b4 = 1.f;
+
+/* Subroutine */ int srotg_(real *sa, real *sb, real *c__, real *s)
+{
+ /* System generated locals */
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_sign(real *, real *);
+
+ /* Local variables */
+ real r__, z__, roe, scale;
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* construct givens plane rotation. */
+/* jack dongarra, linpack, 3/11/78. */
+
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ roe = *sb;
+ if (dabs(*sa) > dabs(*sb)) {
+ roe = *sa;
+ }
+ scale = dabs(*sa) + dabs(*sb);
+ if (scale != 0.f) {
+ goto L10;
+ }
+ *c__ = 1.f;
+ *s = 0.f;
+ r__ = 0.f;
+ z__ = 0.f;
+ goto L20;
+L10:
+/* Computing 2nd power */
+ r__1 = *sa / scale;
+/* Computing 2nd power */
+ r__2 = *sb / scale;
+ r__ = scale * sqrt(r__1 * r__1 + r__2 * r__2);
+ r__ = r_sign(&c_b4, &roe) * r__;
+ *c__ = *sa / r__;
+ *s = *sb / r__;
+ z__ = 1.f;
+ if (dabs(*sa) > dabs(*sb)) {
+ z__ = *s;
+ }
+ if (dabs(*sb) >= dabs(*sa) && *c__ != 0.f) {
+ z__ = 1.f / *c__;
+ }
+L20:
+ *sa = r__;
+ *sb = z__;
+ return 0;
+} /* srotg_ */
diff --git a/BLAS/SRC/srotm.c b/BLAS/SRC/srotm.c
new file mode 100644
index 0000000..b83bf86
--- /dev/null
+++ b/BLAS/SRC/srotm.c
@@ -0,0 +1,216 @@
+/* srotm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int srotm_(integer *n, real *sx, integer *incx, real *sy,
+ integer *incy, real *sparam)
+{
+ /* Initialized data */
+
+ static real zero = 0.f;
+ static real two = 2.f;
+
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__;
+ real w, z__;
+ integer kx, ky;
+ real sh11, sh12, sh21, sh22, sflag;
+ integer nsteps;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX */
+
+/* (SX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN */
+/* (DX**T) */
+
+/* SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE */
+/* LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY. */
+/* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */
+
+/* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 */
+
+/* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) */
+/* H=( ) ( ) ( ) ( ) */
+/* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). */
+/* SEE SROTMG FOR A DESCRIPTION OF DATA STORAGE IN SPARAM. */
+
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* number of elements in input vector(s) */
+
+/* SX (input/output) REAL array, dimension N */
+/* double precision vector with N elements */
+
+/* INCX (input) INTEGER */
+/* storage spacing between elements of SX */
+
+/* SY (input/output) REAL array, dimension N */
+/* double precision vector with N elements */
+
+/* INCY (input) INTEGER */
+/* storage spacing between elements of SY */
+
+/* SPARAM (input/output) REAL array, dimension 5 */
+/* SPARAM(1)=SFLAG */
+/* SPARAM(2)=SH11 */
+/* SPARAM(3)=SH21 */
+/* SPARAM(4)=SH12 */
+/* SPARAM(5)=SH22 */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --sparam;
+ --sy;
+ --sx;
+
+ /* Function Body */
+/* .. */
+
+ sflag = sparam[1];
+ if (*n <= 0 || sflag + two == zero) {
+ goto L140;
+ }
+ if (! (*incx == *incy && *incx > 0)) {
+ goto L70;
+ }
+
+ nsteps = *n * *incx;
+ if (sflag < 0.f) {
+ goto L50;
+ } else if (sflag == 0) {
+ goto L10;
+ } else {
+ goto L30;
+ }
+L10:
+ sh12 = sparam[4];
+ sh21 = sparam[3];
+ i__1 = nsteps;
+ i__2 = *incx;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ w = sx[i__];
+ z__ = sy[i__];
+ sx[i__] = w + z__ * sh12;
+ sy[i__] = w * sh21 + z__;
+/* L20: */
+ }
+ goto L140;
+L30:
+ sh11 = sparam[2];
+ sh22 = sparam[5];
+ i__2 = nsteps;
+ i__1 = *incx;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
+ w = sx[i__];
+ z__ = sy[i__];
+ sx[i__] = w * sh11 + z__;
+ sy[i__] = -w + sh22 * z__;
+/* L40: */
+ }
+ goto L140;
+L50:
+ sh11 = sparam[2];
+ sh12 = sparam[4];
+ sh21 = sparam[3];
+ sh22 = sparam[5];
+ i__1 = nsteps;
+ i__2 = *incx;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ w = sx[i__];
+ z__ = sy[i__];
+ sx[i__] = w * sh11 + z__ * sh12;
+ sy[i__] = w * sh21 + z__ * sh22;
+/* L60: */
+ }
+ goto L140;
+L70:
+ kx = 1;
+ ky = 1;
+ if (*incx < 0) {
+ kx = (1 - *n) * *incx + 1;
+ }
+ if (*incy < 0) {
+ ky = (1 - *n) * *incy + 1;
+ }
+
+ if (sflag < 0.f) {
+ goto L120;
+ } else if (sflag == 0) {
+ goto L80;
+ } else {
+ goto L100;
+ }
+L80:
+ sh12 = sparam[4];
+ sh21 = sparam[3];
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ w = sx[kx];
+ z__ = sy[ky];
+ sx[kx] = w + z__ * sh12;
+ sy[ky] = w * sh21 + z__;
+ kx += *incx;
+ ky += *incy;
+/* L90: */
+ }
+ goto L140;
+L100:
+ sh11 = sparam[2];
+ sh22 = sparam[5];
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ w = sx[kx];
+ z__ = sy[ky];
+ sx[kx] = w * sh11 + z__;
+ sy[ky] = -w + sh22 * z__;
+ kx += *incx;
+ ky += *incy;
+/* L110: */
+ }
+ goto L140;
+L120:
+ sh11 = sparam[2];
+ sh12 = sparam[4];
+ sh21 = sparam[3];
+ sh22 = sparam[5];
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ w = sx[kx];
+ z__ = sy[ky];
+ sx[kx] = w * sh11 + z__ * sh12;
+ sy[ky] = w * sh21 + z__ * sh22;
+ kx += *incx;
+ ky += *incy;
+/* L130: */
+ }
+L140:
+ return 0;
+} /* srotm_ */
diff --git a/BLAS/SRC/srotmg.c b/BLAS/SRC/srotmg.c
new file mode 100644
index 0000000..912778b
--- /dev/null
+++ b/BLAS/SRC/srotmg.c
@@ -0,0 +1,295 @@
+/* srotmg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int srotmg_(real *sd1, real *sd2, real *sx1, real *sy1, real
+ *sparam)
+{
+ /* Initialized data */
+
+ static real zero = 0.f;
+ static real one = 1.f;
+ static real two = 2.f;
+ static real gam = 4096.f;
+ static real gamsq = 16777200.f;
+ static real rgamsq = 5.96046e-8f;
+
+ /* Format strings */
+ static char fmt_120[] = "";
+ static char fmt_150[] = "";
+ static char fmt_180[] = "";
+ static char fmt_210[] = "";
+
+ /* System generated locals */
+ real r__1;
+
+ /* Local variables */
+ real su, sp1, sp2, sq1, sq2, sh11, sh12, sh21, sh22;
+ integer igo;
+ real sflag, stemp;
+
+ /* Assigned format variables */
+ static char *igo_fmt;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */
+/* THE SECOND COMPONENT OF THE 2-VECTOR (SQRT(SD1)*SX1,SQRT(SD2)* */
+/* SY2)**T. */
+/* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */
+
+/* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 */
+
+/* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) */
+/* H=( ) ( ) ( ) ( ) */
+/* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). */
+/* LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22 */
+/* RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE */
+/* VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.) */
+
+/* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */
+/* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */
+/* OF SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */
+
+
+/* Arguments */
+/* ========= */
+
+
+/* SD1 (input/output) REAL */
+
+/* SD2 (input/output) REAL */
+
+/* SX1 (input/output) REAL */
+
+/* SY1 (input) REAL */
+
+
+/* SPARAM (input/output) REAL array, dimension 5 */
+/* SPARAM(1)=SFLAG */
+/* SPARAM(2)=SH11 */
+/* SPARAM(3)=SH21 */
+/* SPARAM(4)=SH12 */
+/* SPARAM(5)=SH22 */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+
+ /* Parameter adjustments */
+ --sparam;
+
+ /* Function Body */
+/* .. */
+ if (! (*sd1 < zero)) {
+ goto L10;
+ }
+/* GO ZERO-H-D-AND-SX1.. */
+ goto L60;
+L10:
+/* CASE-SD1-NONNEGATIVE */
+ sp2 = *sd2 * *sy1;
+ if (! (sp2 == zero)) {
+ goto L20;
+ }
+ sflag = -two;
+ goto L260;
+/* REGULAR-CASE.. */
+L20:
+ sp1 = *sd1 * *sx1;
+ sq2 = sp2 * *sy1;
+ sq1 = sp1 * *sx1;
+
+ if (! (dabs(sq1) > dabs(sq2))) {
+ goto L40;
+ }
+ sh21 = -(*sy1) / *sx1;
+ sh12 = sp2 / sp1;
+
+ su = one - sh12 * sh21;
+
+ if (! (su <= zero)) {
+ goto L30;
+ }
+/* GO ZERO-H-D-AND-SX1.. */
+ goto L60;
+L30:
+ sflag = zero;
+ *sd1 /= su;
+ *sd2 /= su;
+ *sx1 *= su;
+/* GO SCALE-CHECK.. */
+ goto L100;
+L40:
+ if (! (sq2 < zero)) {
+ goto L50;
+ }
+/* GO ZERO-H-D-AND-SX1.. */
+ goto L60;
+L50:
+ sflag = one;
+ sh11 = sp1 / sp2;
+ sh22 = *sx1 / *sy1;
+ su = one + sh11 * sh22;
+ stemp = *sd2 / su;
+ *sd2 = *sd1 / su;
+ *sd1 = stemp;
+ *sx1 = *sy1 * su;
+/* GO SCALE-CHECK */
+ goto L100;
+/* PROCEDURE..ZERO-H-D-AND-SX1.. */
+L60:
+ sflag = -one;
+ sh11 = zero;
+ sh12 = zero;
+ sh21 = zero;
+ sh22 = zero;
+
+ *sd1 = zero;
+ *sd2 = zero;
+ *sx1 = zero;
+/* RETURN.. */
+ goto L220;
+/* PROCEDURE..FIX-H.. */
+L70:
+ if (! (sflag >= zero)) {
+ goto L90;
+ }
+
+ if (! (sflag == zero)) {
+ goto L80;
+ }
+ sh11 = one;
+ sh22 = one;
+ sflag = -one;
+ goto L90;
+L80:
+ sh21 = -one;
+ sh12 = one;
+ sflag = -one;
+L90:
+ switch (igo) {
+ case 0: goto L120;
+ case 1: goto L150;
+ case 2: goto L180;
+ case 3: goto L210;
+ }
+/* PROCEDURE..SCALE-CHECK */
+L100:
+L110:
+ if (! (*sd1 <= rgamsq)) {
+ goto L130;
+ }
+ if (*sd1 == zero) {
+ goto L160;
+ }
+ igo = 0;
+ igo_fmt = fmt_120;
+/* FIX-H.. */
+ goto L70;
+L120:
+/* Computing 2nd power */
+ r__1 = gam;
+ *sd1 *= r__1 * r__1;
+ *sx1 /= gam;
+ sh11 /= gam;
+ sh12 /= gam;
+ goto L110;
+L130:
+L140:
+ if (! (*sd1 >= gamsq)) {
+ goto L160;
+ }
+ igo = 1;
+ igo_fmt = fmt_150;
+/* FIX-H.. */
+ goto L70;
+L150:
+/* Computing 2nd power */
+ r__1 = gam;
+ *sd1 /= r__1 * r__1;
+ *sx1 *= gam;
+ sh11 *= gam;
+ sh12 *= gam;
+ goto L140;
+L160:
+L170:
+ if (! (dabs(*sd2) <= rgamsq)) {
+ goto L190;
+ }
+ if (*sd2 == zero) {
+ goto L220;
+ }
+ igo = 2;
+ igo_fmt = fmt_180;
+/* FIX-H.. */
+ goto L70;
+L180:
+/* Computing 2nd power */
+ r__1 = gam;
+ *sd2 *= r__1 * r__1;
+ sh21 /= gam;
+ sh22 /= gam;
+ goto L170;
+L190:
+L200:
+ if (! (dabs(*sd2) >= gamsq)) {
+ goto L220;
+ }
+ igo = 3;
+ igo_fmt = fmt_210;
+/* FIX-H.. */
+ goto L70;
+L210:
+/* Computing 2nd power */
+ r__1 = gam;
+ *sd2 /= r__1 * r__1;
+ sh21 *= gam;
+ sh22 *= gam;
+ goto L200;
+L220:
+ if (sflag < 0.f) {
+ goto L250;
+ } else if (sflag == 0) {
+ goto L230;
+ } else {
+ goto L240;
+ }
+L230:
+ sparam[3] = sh21;
+ sparam[4] = sh12;
+ goto L260;
+L240:
+ sparam[2] = sh11;
+ sparam[5] = sh22;
+ goto L260;
+L250:
+ sparam[2] = sh11;
+ sparam[3] = sh21;
+ sparam[4] = sh12;
+ sparam[5] = sh22;
+L260:
+ sparam[1] = sflag;
+ return 0;
+} /* srotmg_ */
diff --git a/BLAS/SRC/ssbmv.c b/BLAS/SRC/ssbmv.c
new file mode 100644
index 0000000..9b22b21
--- /dev/null
+++ b/BLAS/SRC/ssbmv.c
@@ -0,0 +1,364 @@
+/* ssbmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ssbmv_(char *uplo, integer *n, integer *k, real *alpha,
+ real *a, integer *lda, real *x, integer *incx, real *beta, real *y,
+ integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, l, ix, iy, jx, jy, kx, ky, info;
+ real temp1, temp2;
+ extern logical lsame_(char *, char *);
+ integer kplus1;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSBMV performs the matrix-vector operation */
+
+/* y := alpha*A*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are n element vectors and */
+/* A is an n by n symmetric band matrix, with k super-diagonals. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the band matrix A is being supplied as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* being supplied. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* being supplied. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry, K specifies the number of super-diagonals of the */
+/* matrix A. K must satisfy 0 .le. K. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - REAL array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
+/* by n part of the array A must contain the upper triangular */
+/* band part of the symmetric matrix, supplied column by */
+/* column, with the leading diagonal of the matrix in row */
+/* ( k + 1 ) of the array, the first super-diagonal starting at */
+/* position 2 in row k, and so on. The top left k by k triangle */
+/* of the array A is not referenced. */
+/* The following program segment will transfer the upper */
+/* triangular part of a symmetric band matrix from conventional */
+/* full matrix storage to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = K + 1 - J */
+/* DO 10, I = MAX( 1, J - K ), J */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
+/* by n part of the array A must contain the lower triangular */
+/* band part of the symmetric matrix, supplied column by */
+/* column, with the leading diagonal of the matrix in row 1 of */
+/* the array, the first sub-diagonal starting at position 1 in */
+/* row 2, and so on. The bottom right k by k triangle of the */
+/* array A is not referenced. */
+/* The following program segment will transfer the lower */
+/* triangular part of a symmetric band matrix from conventional */
+/* full matrix storage to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = 1 - J */
+/* DO 10, I = J, MIN( N, J + K ) */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* ( k + 1 ). */
+/* Unchanged on exit. */
+
+/* X - REAL array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - REAL . */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+/* Y - REAL array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the */
+/* vector y. On exit, Y is overwritten by the updated vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*k < 0) {
+ info = 3;
+ } else if (*lda < *k + 1) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ } else if (*incy == 0) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("SSBMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0.f && *beta == 1.f) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of the array A */
+/* are accessed sequentially with one pass through A. */
+
+/* First form y := beta*y. */
+
+ if (*beta != 1.f) {
+ if (*incy == 1) {
+ if (*beta == 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[i__] = 0.f;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[i__] = *beta * y[i__];
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (*beta == 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[iy] = 0.f;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[iy] = *beta * y[iy];
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (*alpha == 0.f) {
+ return 0;
+ }
+ if (lsame_(uplo, "U")) {
+
+/* Form y when upper triangle of A is stored. */
+
+ kplus1 = *k + 1;
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[j];
+ temp2 = 0.f;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ y[i__] += temp1 * a[l + i__ + j * a_dim1];
+ temp2 += a[l + i__ + j * a_dim1] * x[i__];
+/* L50: */
+ }
+ y[j] = y[j] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[jx];
+ temp2 = 0.f;
+ ix = kx;
+ iy = ky;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *k;
+ i__3 = j - 1;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ y[iy] += temp1 * a[l + i__ + j * a_dim1];
+ temp2 += a[l + i__ + j * a_dim1] * x[ix];
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ y[jy] = y[jy] + temp1 * a[kplus1 + j * a_dim1] + *alpha *
+ temp2;
+ jx += *incx;
+ jy += *incy;
+ if (j > *k) {
+ kx += *incx;
+ ky += *incy;
+ }
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y when lower triangle of A is stored. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[j];
+ temp2 = 0.f;
+ y[j] += temp1 * a[j * a_dim1 + 1];
+ l = 1 - j;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ y[i__] += temp1 * a[l + i__ + j * a_dim1];
+ temp2 += a[l + i__ + j * a_dim1] * x[i__];
+/* L90: */
+ }
+ y[j] += *alpha * temp2;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[jx];
+ temp2 = 0.f;
+ y[jy] += temp1 * a[j * a_dim1 + 1];
+ l = 1 - j;
+ ix = jx;
+ iy = jy;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ ix += *incx;
+ iy += *incy;
+ y[iy] += temp1 * a[l + i__ + j * a_dim1];
+ temp2 += a[l + i__ + j * a_dim1] * x[ix];
+/* L110: */
+ }
+ y[jy] += *alpha * temp2;
+ jx += *incx;
+ jy += *incy;
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SSBMV . */
+
+} /* ssbmv_ */
diff --git a/BLAS/SRC/sscal.c b/BLAS/SRC/sscal.c
new file mode 100644
index 0000000..1bd2963
--- /dev/null
+++ b/BLAS/SRC/sscal.c
@@ -0,0 +1,95 @@
+/* sscal.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sscal_(integer *n, real *sa, real *sx, integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, m, mp1, nincx;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* scales a vector by a constant. */
+/* uses unrolled loops for increment equal to 1. */
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 3/93 to return if incx .le. 0. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --sx;
+
+ /* Function Body */
+ if (*n <= 0 || *incx <= 0) {
+ return 0;
+ }
+ if (*incx == 1) {
+ goto L20;
+ }
+
+/* code for increment not equal to 1 */
+
+ nincx = *n * *incx;
+ i__1 = nincx;
+ i__2 = *incx;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ sx[i__] = *sa * sx[i__];
+/* L10: */
+ }
+ return 0;
+
+/* code for increment equal to 1 */
+
+
+/* clean-up loop */
+
+L20:
+ m = *n % 5;
+ if (m == 0) {
+ goto L40;
+ }
+ i__2 = m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ sx[i__] = *sa * sx[i__];
+/* L30: */
+ }
+ if (*n < 5) {
+ return 0;
+ }
+L40:
+ mp1 = m + 1;
+ i__2 = *n;
+ for (i__ = mp1; i__ <= i__2; i__ += 5) {
+ sx[i__] = *sa * sx[i__];
+ sx[i__ + 1] = *sa * sx[i__ + 1];
+ sx[i__ + 2] = *sa * sx[i__ + 2];
+ sx[i__ + 3] = *sa * sx[i__ + 3];
+ sx[i__ + 4] = *sa * sx[i__ + 4];
+/* L50: */
+ }
+ return 0;
+} /* sscal_ */
diff --git a/BLAS/SRC/sspmv.c b/BLAS/SRC/sspmv.c
new file mode 100644
index 0000000..7a5db80
--- /dev/null
+++ b/BLAS/SRC/sspmv.c
@@ -0,0 +1,311 @@
+/* sspmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sspmv_(char *uplo, integer *n, real *alpha, real *ap,
+ real *x, integer *incx, real *beta, real *y, integer *incy)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
+ real temp1, temp2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSPMV performs the matrix-vector operation */
+
+/* y := alpha*A*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are n element vectors and */
+/* A is an n by n symmetric matrix, supplied in packed form. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the matrix A is supplied in the packed */
+/* array AP as follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* supplied in AP. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* supplied in AP. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* AP - REAL array of DIMENSION at least */
+/* ( ( n*( n + 1 ) )/2 ). */
+/* Before entry with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular part of the symmetric matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
+/* and a( 2, 2 ) respectively, and so on. */
+/* Before entry with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular part of the symmetric matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
+/* and a( 3, 1 ) respectively, and so on. */
+/* Unchanged on exit. */
+
+/* X - REAL array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - REAL . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - REAL array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. On exit, Y is overwritten by the updated */
+/* vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --y;
+ --x;
+ --ap;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 6;
+ } else if (*incy == 0) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("SSPMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0.f && *beta == 1.f) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of the array AP */
+/* are accessed sequentially with one pass through AP. */
+
+/* First form y := beta*y. */
+
+ if (*beta != 1.f) {
+ if (*incy == 1) {
+ if (*beta == 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[i__] = 0.f;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[i__] = *beta * y[i__];
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (*beta == 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[iy] = 0.f;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[iy] = *beta * y[iy];
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (*alpha == 0.f) {
+ return 0;
+ }
+ kk = 1;
+ if (lsame_(uplo, "U")) {
+
+/* Form y when AP contains the upper triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[j];
+ temp2 = 0.f;
+ k = kk;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ y[i__] += temp1 * ap[k];
+ temp2 += ap[k] * x[i__];
+ ++k;
+/* L50: */
+ }
+ y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2;
+ kk += j;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[jx];
+ temp2 = 0.f;
+ ix = kx;
+ iy = ky;
+ i__2 = kk + j - 2;
+ for (k = kk; k <= i__2; ++k) {
+ y[iy] += temp1 * ap[k];
+ temp2 += ap[k] * x[ix];
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2;
+ jx += *incx;
+ jy += *incy;
+ kk += j;
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y when AP contains the lower triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[j];
+ temp2 = 0.f;
+ y[j] += temp1 * ap[kk];
+ k = kk + 1;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ y[i__] += temp1 * ap[k];
+ temp2 += ap[k] * x[i__];
+ ++k;
+/* L90: */
+ }
+ y[j] += *alpha * temp2;
+ kk += *n - j + 1;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[jx];
+ temp2 = 0.f;
+ y[jy] += temp1 * ap[kk];
+ ix = jx;
+ iy = jy;
+ i__2 = kk + *n - j;
+ for (k = kk + 1; k <= i__2; ++k) {
+ ix += *incx;
+ iy += *incy;
+ y[iy] += temp1 * ap[k];
+ temp2 += ap[k] * x[ix];
+/* L110: */
+ }
+ y[jy] += *alpha * temp2;
+ jx += *incx;
+ jy += *incy;
+ kk += *n - j + 1;
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SSPMV . */
+
+} /* sspmv_ */
diff --git a/BLAS/SRC/sspr.c b/BLAS/SRC/sspr.c
new file mode 100644
index 0000000..97791a8
--- /dev/null
+++ b/BLAS/SRC/sspr.c
@@ -0,0 +1,237 @@
+/* sspr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sspr_(char *uplo, integer *n, real *alpha, real *x,
+ integer *incx, real *ap)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, jx, kx, info;
+ real temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSPR performs the symmetric rank 1 operation */
+
+/* A := alpha*x*x' + A, */
+
+/* where alpha is a real scalar, x is an n element vector and A is an */
+/* n by n symmetric matrix, supplied in packed form. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the matrix A is supplied in the packed */
+/* array AP as follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* supplied in AP. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* supplied in AP. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X - REAL array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* AP - REAL array of DIMENSION at least */
+/* ( ( n*( n + 1 ) )/2 ). */
+/* Before entry with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular part of the symmetric matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
+/* and a( 2, 2 ) respectively, and so on. On exit, the array */
+/* AP is overwritten by the upper triangular part of the */
+/* updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular part of the symmetric matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
+/* and a( 3, 1 ) respectively, and so on. On exit, the array */
+/* AP is overwritten by the lower triangular part of the */
+/* updated matrix. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ }
+ if (info != 0) {
+ xerbla_("SSPR ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0.f) {
+ return 0;
+ }
+
+/* Set the start point in X if the increment is not unity. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of the array AP */
+/* are accessed sequentially with one pass through AP. */
+
+ kk = 1;
+ if (lsame_(uplo, "U")) {
+
+/* Form A when upper triangle is stored in AP. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.f) {
+ temp = *alpha * x[j];
+ k = kk;
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ap[k] += x[i__] * temp;
+ ++k;
+/* L10: */
+ }
+ }
+ kk += j;
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.f) {
+ temp = *alpha * x[jx];
+ ix = kx;
+ i__2 = kk + j - 1;
+ for (k = kk; k <= i__2; ++k) {
+ ap[k] += x[ix] * temp;
+ ix += *incx;
+/* L30: */
+ }
+ }
+ jx += *incx;
+ kk += j;
+/* L40: */
+ }
+ }
+ } else {
+
+/* Form A when lower triangle is stored in AP. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.f) {
+ temp = *alpha * x[j];
+ k = kk;
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ap[k] += x[i__] * temp;
+ ++k;
+/* L50: */
+ }
+ }
+ kk = kk + *n - j + 1;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.f) {
+ temp = *alpha * x[jx];
+ ix = jx;
+ i__2 = kk + *n - j;
+ for (k = kk; k <= i__2; ++k) {
+ ap[k] += x[ix] * temp;
+ ix += *incx;
+/* L70: */
+ }
+ }
+ jx += *incx;
+ kk = kk + *n - j + 1;
+/* L80: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SSPR . */
+
+} /* sspr_ */
diff --git a/BLAS/SRC/sspr2.c b/BLAS/SRC/sspr2.c
new file mode 100644
index 0000000..3fb675a
--- /dev/null
+++ b/BLAS/SRC/sspr2.c
@@ -0,0 +1,269 @@
+/* sspr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sspr2_(char *uplo, integer *n, real *alpha, real *x,
+ integer *incx, real *y, integer *incy, real *ap)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
+ real temp1, temp2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSPR2 performs the symmetric rank 2 operation */
+
+/* A := alpha*x*y' + alpha*y*x' + A, */
+
+/* where alpha is a scalar, x and y are n element vectors and A is an */
+/* n by n symmetric matrix, supplied in packed form. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the matrix A is supplied in the packed */
+/* array AP as follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* supplied in AP. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* supplied in AP. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X - REAL array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* Y - REAL array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. */
+/* Unchanged on exit. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* AP - REAL array of DIMENSION at least */
+/* ( ( n*( n + 1 ) )/2 ). */
+/* Before entry with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular part of the symmetric matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
+/* and a( 2, 2 ) respectively, and so on. On exit, the array */
+/* AP is overwritten by the upper triangular part of the */
+/* updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular part of the symmetric matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
+/* and a( 3, 1 ) respectively, and so on. On exit, the array */
+/* AP is overwritten by the lower triangular part of the */
+/* updated matrix. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --y;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ } else if (*incy == 0) {
+ info = 7;
+ }
+ if (info != 0) {
+ xerbla_("SSPR2 ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0.f) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y if the increments are not both */
+/* unity. */
+
+ if (*incx != 1 || *incy != 1) {
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+ jx = kx;
+ jy = ky;
+ }
+
+/* Start the operations. In this version the elements of the array AP */
+/* are accessed sequentially with one pass through AP. */
+
+ kk = 1;
+ if (lsame_(uplo, "U")) {
+
+/* Form A when upper triangle is stored in AP. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.f || y[j] != 0.f) {
+ temp1 = *alpha * y[j];
+ temp2 = *alpha * x[j];
+ k = kk;
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2;
+ ++k;
+/* L10: */
+ }
+ }
+ kk += j;
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.f || y[jy] != 0.f) {
+ temp1 = *alpha * y[jy];
+ temp2 = *alpha * x[jx];
+ ix = kx;
+ iy = ky;
+ i__2 = kk + j - 1;
+ for (k = kk; k <= i__2; ++k) {
+ ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2;
+ ix += *incx;
+ iy += *incy;
+/* L30: */
+ }
+ }
+ jx += *incx;
+ jy += *incy;
+ kk += j;
+/* L40: */
+ }
+ }
+ } else {
+
+/* Form A when lower triangle is stored in AP. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.f || y[j] != 0.f) {
+ temp1 = *alpha * y[j];
+ temp2 = *alpha * x[j];
+ k = kk;
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2;
+ ++k;
+/* L50: */
+ }
+ }
+ kk = kk + *n - j + 1;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.f || y[jy] != 0.f) {
+ temp1 = *alpha * y[jy];
+ temp2 = *alpha * x[jx];
+ ix = jx;
+ iy = jy;
+ i__2 = kk + *n - j;
+ for (k = kk; k <= i__2; ++k) {
+ ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2;
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ }
+ jx += *incx;
+ jy += *incy;
+ kk = kk + *n - j + 1;
+/* L80: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SSPR2 . */
+
+} /* sspr2_ */
diff --git a/BLAS/SRC/sswap.c b/BLAS/SRC/sswap.c
new file mode 100644
index 0000000..6d6e9e4
--- /dev/null
+++ b/BLAS/SRC/sswap.c
@@ -0,0 +1,114 @@
+/* sswap.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sswap_(integer *n, real *sx, integer *incx, real *sy,
+ integer *incy)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, m, ix, iy, mp1;
+ real stemp;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* interchanges two vectors. */
+/* uses unrolled loops for increments equal to 1. */
+/* jack dongarra, linpack, 3/11/78. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --sy;
+ --sx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* code for unequal increments or equal increments not equal */
+/* to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ stemp = sx[ix];
+ sx[ix] = sy[iy];
+ sy[iy] = stemp;
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ return 0;
+
+/* code for both increments equal to 1 */
+
+
+/* clean-up loop */
+
+L20:
+ m = *n % 3;
+ if (m == 0) {
+ goto L40;
+ }
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ stemp = sx[i__];
+ sx[i__] = sy[i__];
+ sy[i__] = stemp;
+/* L30: */
+ }
+ if (*n < 3) {
+ return 0;
+ }
+L40:
+ mp1 = m + 1;
+ i__1 = *n;
+ for (i__ = mp1; i__ <= i__1; i__ += 3) {
+ stemp = sx[i__];
+ sx[i__] = sy[i__];
+ sy[i__] = stemp;
+ stemp = sx[i__ + 1];
+ sx[i__ + 1] = sy[i__ + 1];
+ sy[i__ + 1] = stemp;
+ stemp = sx[i__ + 2];
+ sx[i__ + 2] = sy[i__ + 2];
+ sy[i__ + 2] = stemp;
+/* L50: */
+ }
+ return 0;
+} /* sswap_ */
diff --git a/BLAS/SRC/ssymm.c b/BLAS/SRC/ssymm.c
new file mode 100644
index 0000000..df34242
--- /dev/null
+++ b/BLAS/SRC/ssymm.c
@@ -0,0 +1,362 @@
+/* ssymm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ssymm_(char *side, char *uplo, integer *m, integer *n,
+ real *alpha, real *a, integer *lda, real *b, integer *ldb, real *beta,
+ real *c__, integer *ldc)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3;
+
+ /* Local variables */
+ integer i__, j, k, info;
+ real temp1, temp2;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYMM performs one of the matrix-matrix operations */
+
+/* C := alpha*A*B + beta*C, */
+
+/* or */
+
+/* C := alpha*B*A + beta*C, */
+
+/* where alpha and beta are scalars, A is a symmetric matrix and B and */
+/* C are m by n matrices. */
+
+/* Arguments */
+/* ========== */
+
+/* SIDE - CHARACTER*1. */
+/* On entry, SIDE specifies whether the symmetric matrix A */
+/* appears on the left or right in the operation as follows: */
+
+/* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, */
+
+/* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, */
+
+/* Unchanged on exit. */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the symmetric matrix A is to be */
+/* referenced as follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of the */
+/* symmetric matrix is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of the */
+/* symmetric matrix is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix C. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix C. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - REAL array of DIMENSION ( LDA, ka ), where ka is */
+/* m when SIDE = 'L' or 'l' and is n otherwise. */
+/* Before entry with SIDE = 'L' or 'l', the m by m part of */
+/* the array A must contain the symmetric matrix, such that */
+/* when UPLO = 'U' or 'u', the leading m by m upper triangular */
+/* part of the array A must contain the upper triangular part */
+/* of the symmetric matrix and the strictly lower triangular */
+/* part of A is not referenced, and when UPLO = 'L' or 'l', */
+/* the leading m by m lower triangular part of the array A */
+/* must contain the lower triangular part of the symmetric */
+/* matrix and the strictly upper triangular part of A is not */
+/* referenced. */
+/* Before entry with SIDE = 'R' or 'r', the n by n part of */
+/* the array A must contain the symmetric matrix, such that */
+/* when UPLO = 'U' or 'u', the leading n by n upper triangular */
+/* part of the array A must contain the upper triangular part */
+/* of the symmetric matrix and the strictly lower triangular */
+/* part of A is not referenced, and when UPLO = 'L' or 'l', */
+/* the leading n by n lower triangular part of the array A */
+/* must contain the lower triangular part of the symmetric */
+/* matrix and the strictly upper triangular part of A is not */
+/* referenced. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When SIDE = 'L' or 'l' then */
+/* LDA must be at least max( 1, m ), otherwise LDA must be at */
+/* least max( 1, n ). */
+/* Unchanged on exit. */
+
+/* B - REAL array of DIMENSION ( LDB, n ). */
+/* Before entry, the leading m by n part of the array B must */
+/* contain the matrix B. */
+/* Unchanged on exit. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. LDB must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+/* BETA - REAL . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then C need not be set on input. */
+/* Unchanged on exit. */
+
+/* C - REAL array of DIMENSION ( LDC, n ). */
+/* Before entry, the leading m by n part of the array C must */
+/* contain the matrix C, except when beta is zero, in which */
+/* case C need not be set on entry. */
+/* On exit, the array C is overwritten by the m by n updated */
+/* matrix. */
+
+/* LDC - INTEGER. */
+/* On entry, LDC specifies the first dimension of C as declared */
+/* in the calling (sub) program. LDC must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Set NROWA as the number of rows of A. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ if (lsame_(side, "L")) {
+ nrowa = *m;
+ } else {
+ nrowa = *n;
+ }
+ upper = lsame_(uplo, "U");
+
+/* Test the input parameters. */
+
+ info = 0;
+ if (! lsame_(side, "L") && ! lsame_(side, "R")) {
+ info = 1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ info = 2;
+ } else if (*m < 0) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*lda < max(1,nrowa)) {
+ info = 7;
+ } else if (*ldb < max(1,*m)) {
+ info = 9;
+ } else if (*ldc < max(1,*m)) {
+ info = 12;
+ }
+ if (info != 0) {
+ xerbla_("SSYMM ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || *alpha == 0.f && *beta == 1.f) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (*alpha == 0.f) {
+ if (*beta == 0.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lsame_(side, "L")) {
+
+/* Form C := alpha*A*B + beta*C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp1 = *alpha * b[i__ + j * b_dim1];
+ temp2 = 0.f;
+ i__3 = i__ - 1;
+ for (k = 1; k <= i__3; ++k) {
+ c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1];
+ temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1];
+/* L50: */
+ }
+ if (*beta == 0.f) {
+ c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1]
+ + *alpha * temp2;
+ } else {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]
+ + temp1 * a[i__ + i__ * a_dim1] + *alpha *
+ temp2;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (i__ = *m; i__ >= 1; --i__) {
+ temp1 = *alpha * b[i__ + j * b_dim1];
+ temp2 = 0.f;
+ i__2 = *m;
+ for (k = i__ + 1; k <= i__2; ++k) {
+ c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1];
+ temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1];
+/* L80: */
+ }
+ if (*beta == 0.f) {
+ c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1]
+ + *alpha * temp2;
+ } else {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]
+ + temp1 * a[i__ + i__ * a_dim1] + *alpha *
+ temp2;
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+ }
+ } else {
+
+/* Form C := alpha*B*A + beta*C. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * a[j + j * a_dim1];
+ if (*beta == 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = temp1 * b[i__ + j * b_dim1];
+/* L110: */
+ }
+ } else {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] +
+ temp1 * b[i__ + j * b_dim1];
+/* L120: */
+ }
+ }
+ i__2 = j - 1;
+ for (k = 1; k <= i__2; ++k) {
+ if (upper) {
+ temp1 = *alpha * a[k + j * a_dim1];
+ } else {
+ temp1 = *alpha * a[j + k * a_dim1];
+ }
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1];
+/* L130: */
+ }
+/* L140: */
+ }
+ i__2 = *n;
+ for (k = j + 1; k <= i__2; ++k) {
+ if (upper) {
+ temp1 = *alpha * a[j + k * a_dim1];
+ } else {
+ temp1 = *alpha * a[k + j * a_dim1];
+ }
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1];
+/* L150: */
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+ }
+
+ return 0;
+
+/* End of SSYMM . */
+
+} /* ssymm_ */
diff --git a/BLAS/SRC/ssymv.c b/BLAS/SRC/ssymv.c
new file mode 100644
index 0000000..3a1502c
--- /dev/null
+++ b/BLAS/SRC/ssymv.c
@@ -0,0 +1,313 @@
+/* ssymv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ssymv_(char *uplo, integer *n, real *alpha, real *a,
+ integer *lda, real *x, integer *incx, real *beta, real *y, integer *
+ incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, ix, iy, jx, jy, kx, ky, info;
+ real temp1, temp2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYMV performs the matrix-vector operation */
+
+/* y := alpha*A*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are n element vectors and */
+/* A is an n by n symmetric matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array A is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of A */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of A */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - REAL array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular part of the symmetric matrix and the strictly */
+/* lower triangular part of A is not referenced. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular part of the symmetric matrix and the strictly */
+/* upper triangular part of A is not referenced. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+/* X - REAL array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - REAL . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - REAL array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. On exit, Y is overwritten by the updated */
+/* vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*lda < max(1,*n)) {
+ info = 5;
+ } else if (*incx == 0) {
+ info = 7;
+ } else if (*incy == 0) {
+ info = 10;
+ }
+ if (info != 0) {
+ xerbla_("SSYMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0.f && *beta == 1.f) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through the triangular part */
+/* of A. */
+
+/* First form y := beta*y. */
+
+ if (*beta != 1.f) {
+ if (*incy == 1) {
+ if (*beta == 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[i__] = 0.f;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[i__] = *beta * y[i__];
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (*beta == 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[iy] = 0.f;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[iy] = *beta * y[iy];
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (*alpha == 0.f) {
+ return 0;
+ }
+ if (lsame_(uplo, "U")) {
+
+/* Form y when A is stored in upper triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[j];
+ temp2 = 0.f;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ y[i__] += temp1 * a[i__ + j * a_dim1];
+ temp2 += a[i__ + j * a_dim1] * x[i__];
+/* L50: */
+ }
+ y[j] = y[j] + temp1 * a[j + j * a_dim1] + *alpha * temp2;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[jx];
+ temp2 = 0.f;
+ ix = kx;
+ iy = ky;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ y[iy] += temp1 * a[i__ + j * a_dim1];
+ temp2 += a[i__ + j * a_dim1] * x[ix];
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ y[jy] = y[jy] + temp1 * a[j + j * a_dim1] + *alpha * temp2;
+ jx += *incx;
+ jy += *incy;
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y when A is stored in lower triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[j];
+ temp2 = 0.f;
+ y[j] += temp1 * a[j + j * a_dim1];
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ y[i__] += temp1 * a[i__ + j * a_dim1];
+ temp2 += a[i__ + j * a_dim1] * x[i__];
+/* L90: */
+ }
+ y[j] += *alpha * temp2;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp1 = *alpha * x[jx];
+ temp2 = 0.f;
+ y[jy] += temp1 * a[j + j * a_dim1];
+ ix = jx;
+ iy = jy;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ ix += *incx;
+ iy += *incy;
+ y[iy] += temp1 * a[i__ + j * a_dim1];
+ temp2 += a[i__ + j * a_dim1] * x[ix];
+/* L110: */
+ }
+ y[jy] += *alpha * temp2;
+ jx += *incx;
+ jy += *incy;
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SSYMV . */
+
+} /* ssymv_ */
diff --git a/BLAS/SRC/ssyr.c b/BLAS/SRC/ssyr.c
new file mode 100644
index 0000000..dd433a3
--- /dev/null
+++ b/BLAS/SRC/ssyr.c
@@ -0,0 +1,238 @@
+/* ssyr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ssyr_(char *uplo, integer *n, real *alpha, real *x,
+ integer *incx, real *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, ix, jx, kx, info;
+ real temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYR performs the symmetric rank 1 operation */
+
+/* A := alpha*x*x' + A, */
+
+/* where alpha is a real scalar, x is an n element vector and A is an */
+/* n by n symmetric matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array A is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of A */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of A */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X - REAL array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* A - REAL array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular part of the symmetric matrix and the strictly */
+/* lower triangular part of A is not referenced. On exit, the */
+/* upper triangular part of the array A is overwritten by the */
+/* upper triangular part of the updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular part of the symmetric matrix and the strictly */
+/* upper triangular part of A is not referenced. On exit, the */
+/* lower triangular part of the array A is overwritten by the */
+/* lower triangular part of the updated matrix. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ } else if (*lda < max(1,*n)) {
+ info = 7;
+ }
+ if (info != 0) {
+ xerbla_("SSYR ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0.f) {
+ return 0;
+ }
+
+/* Set the start point in X if the increment is not unity. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through the triangular part */
+/* of A. */
+
+ if (lsame_(uplo, "U")) {
+
+/* Form A when A is stored in upper triangle. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.f) {
+ temp = *alpha * x[j];
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] += x[i__] * temp;
+/* L10: */
+ }
+ }
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.f) {
+ temp = *alpha * x[jx];
+ ix = kx;
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] += x[ix] * temp;
+ ix += *incx;
+/* L30: */
+ }
+ }
+ jx += *incx;
+/* L40: */
+ }
+ }
+ } else {
+
+/* Form A when A is stored in lower triangle. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.f) {
+ temp = *alpha * x[j];
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] += x[i__] * temp;
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.f) {
+ temp = *alpha * x[jx];
+ ix = jx;
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] += x[ix] * temp;
+ ix += *incx;
+/* L70: */
+ }
+ }
+ jx += *incx;
+/* L80: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SSYR . */
+
+} /* ssyr_ */
diff --git a/BLAS/SRC/ssyr2.c b/BLAS/SRC/ssyr2.c
new file mode 100644
index 0000000..738250e
--- /dev/null
+++ b/BLAS/SRC/ssyr2.c
@@ -0,0 +1,274 @@
+/* ssyr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ssyr2_(char *uplo, integer *n, real *alpha, real *x,
+ integer *incx, real *y, integer *incy, real *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, ix, iy, jx, jy, kx, ky, info;
+ real temp1, temp2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYR2 performs the symmetric rank 2 operation */
+
+/* A := alpha*x*y' + alpha*y*x' + A, */
+
+/* where alpha is a scalar, x and y are n element vectors and A is an n */
+/* by n symmetric matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array A is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of A */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of A */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X - REAL array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* Y - REAL array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. */
+/* Unchanged on exit. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* A - REAL array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular part of the symmetric matrix and the strictly */
+/* lower triangular part of A is not referenced. On exit, the */
+/* upper triangular part of the array A is overwritten by the */
+/* upper triangular part of the updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular part of the symmetric matrix and the strictly */
+/* upper triangular part of A is not referenced. On exit, the */
+/* lower triangular part of the array A is overwritten by the */
+/* lower triangular part of the updated matrix. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ --y;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ } else if (*incy == 0) {
+ info = 7;
+ } else if (*lda < max(1,*n)) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("SSYR2 ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0.f) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y if the increments are not both */
+/* unity. */
+
+ if (*incx != 1 || *incy != 1) {
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+ jx = kx;
+ jy = ky;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through the triangular part */
+/* of A. */
+
+ if (lsame_(uplo, "U")) {
+
+/* Form A when A is stored in the upper triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.f || y[j] != 0.f) {
+ temp1 = *alpha * y[j];
+ temp2 = *alpha * x[j];
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] *
+ temp1 + y[i__] * temp2;
+/* L10: */
+ }
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.f || y[jy] != 0.f) {
+ temp1 = *alpha * y[jy];
+ temp2 = *alpha * x[jx];
+ ix = kx;
+ iy = ky;
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] *
+ temp1 + y[iy] * temp2;
+ ix += *incx;
+ iy += *incy;
+/* L30: */
+ }
+ }
+ jx += *incx;
+ jy += *incy;
+/* L40: */
+ }
+ }
+ } else {
+
+/* Form A when A is stored in the lower triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.f || y[j] != 0.f) {
+ temp1 = *alpha * y[j];
+ temp2 = *alpha * x[j];
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] *
+ temp1 + y[i__] * temp2;
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.f || y[jy] != 0.f) {
+ temp1 = *alpha * y[jy];
+ temp2 = *alpha * x[jx];
+ ix = jx;
+ iy = jy;
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] *
+ temp1 + y[iy] * temp2;
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ }
+ jx += *incx;
+ jy += *incy;
+/* L80: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SSYR2 . */
+
+} /* ssyr2_ */
diff --git a/BLAS/SRC/ssyr2k.c b/BLAS/SRC/ssyr2k.c
new file mode 100644
index 0000000..2d082fc
--- /dev/null
+++ b/BLAS/SRC/ssyr2k.c
@@ -0,0 +1,409 @@
+/* ssyr2k.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ssyr2k_(char *uplo, char *trans, integer *n, integer *k,
+ real *alpha, real *a, integer *lda, real *b, integer *ldb, real *beta,
+ real *c__, integer *ldc)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3;
+
+ /* Local variables */
+ integer i__, j, l, info;
+ real temp1, temp2;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYR2K performs one of the symmetric rank 2k operations */
+
+/* C := alpha*A*B' + alpha*B*A' + beta*C, */
+
+/* or */
+
+/* C := alpha*A'*B + alpha*B'*A + beta*C, */
+
+/* where alpha and beta are scalars, C is an n by n symmetric matrix */
+/* and A and B are n by k matrices in the first case and k by n */
+/* matrices in the second case. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array C is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of C */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of C */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + */
+/* beta*C. */
+
+/* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + */
+/* beta*C. */
+
+/* TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + */
+/* beta*C. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix C. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry with TRANS = 'N' or 'n', K specifies the number */
+/* of columns of the matrices A and B, and on entry with */
+/* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number */
+/* of rows of the matrices A and B. K must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - REAL array of DIMENSION ( LDA, ka ), where ka is */
+/* k when TRANS = 'N' or 'n', and is n otherwise. */
+/* Before entry with TRANS = 'N' or 'n', the leading n by k */
+/* part of the array A must contain the matrix A, otherwise */
+/* the leading k by n part of the array A must contain the */
+/* matrix A. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When TRANS = 'N' or 'n' */
+/* then LDA must be at least max( 1, n ), otherwise LDA must */
+/* be at least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* B - REAL array of DIMENSION ( LDB, kb ), where kb is */
+/* k when TRANS = 'N' or 'n', and is n otherwise. */
+/* Before entry with TRANS = 'N' or 'n', the leading n by k */
+/* part of the array B must contain the matrix B, otherwise */
+/* the leading k by n part of the array B must contain the */
+/* matrix B. */
+/* Unchanged on exit. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. When TRANS = 'N' or 'n' */
+/* then LDB must be at least max( 1, n ), otherwise LDB must */
+/* be at least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* BETA - REAL . */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+/* C - REAL array of DIMENSION ( LDC, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array C must contain the upper */
+/* triangular part of the symmetric matrix and the strictly */
+/* lower triangular part of C is not referenced. On exit, the */
+/* upper triangular part of the array C is overwritten by the */
+/* upper triangular part of the updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array C must contain the lower */
+/* triangular part of the symmetric matrix and the strictly */
+/* upper triangular part of C is not referenced. On exit, the */
+/* lower triangular part of the array C is overwritten by the */
+/* lower triangular part of the updated matrix. */
+
+/* LDC - INTEGER. */
+/* On entry, LDC specifies the first dimension of C as declared */
+/* in the calling (sub) program. LDC must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ if (lsame_(trans, "N")) {
+ nrowa = *n;
+ } else {
+ nrowa = *k;
+ }
+ upper = lsame_(uplo, "U");
+
+ info = 0;
+ if (! upper && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*k < 0) {
+ info = 4;
+ } else if (*lda < max(1,nrowa)) {
+ info = 7;
+ } else if (*ldb < max(1,nrowa)) {
+ info = 9;
+ } else if (*ldc < max(1,*n)) {
+ info = 12;
+ }
+ if (info != 0) {
+ xerbla_("SSYR2K", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (*alpha == 0.f) {
+ if (upper) {
+ if (*beta == 0.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else {
+ if (*beta == 0.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.f;
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form C := alpha*A*B' + alpha*B*A' + C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*beta == 0.f) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.f;
+/* L90: */
+ }
+ } else if (*beta != 1.f) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L100: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ if (a[j + l * a_dim1] != 0.f || b[j + l * b_dim1] != 0.f)
+ {
+ temp1 = *alpha * b[j + l * b_dim1];
+ temp2 = *alpha * a[j + l * a_dim1];
+ i__3 = j;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[
+ i__ + l * a_dim1] * temp1 + b[i__ + l *
+ b_dim1] * temp2;
+/* L110: */
+ }
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*beta == 0.f) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.f;
+/* L140: */
+ }
+ } else if (*beta != 1.f) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L150: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ if (a[j + l * a_dim1] != 0.f || b[j + l * b_dim1] != 0.f)
+ {
+ temp1 = *alpha * b[j + l * b_dim1];
+ temp2 = *alpha * a[j + l * a_dim1];
+ i__3 = *n;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[
+ i__ + l * a_dim1] * temp1 + b[i__ + l *
+ b_dim1] * temp2;
+/* L160: */
+ }
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+ } else {
+
+/* Form C := alpha*A'*B + alpha*B'*A + C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1];
+ temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1];
+/* L190: */
+ }
+ if (*beta == 0.f) {
+ c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha *
+ temp2;
+ } else {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]
+ + *alpha * temp1 + *alpha * temp2;
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1];
+ temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1];
+/* L220: */
+ }
+ if (*beta == 0.f) {
+ c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha *
+ temp2;
+ } else {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1]
+ + *alpha * temp1 + *alpha * temp2;
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SSYR2K. */
+
+} /* ssyr2k_ */
diff --git a/BLAS/SRC/ssyrk.c b/BLAS/SRC/ssyrk.c
new file mode 100644
index 0000000..1c2bc37
--- /dev/null
+++ b/BLAS/SRC/ssyrk.c
@@ -0,0 +1,372 @@
+/* ssyrk.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ssyrk_(char *uplo, char *trans, integer *n, integer *k,
+ real *alpha, real *a, integer *lda, real *beta, real *c__, integer *
+ ldc)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, l, info;
+ real temp;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYRK performs one of the symmetric rank k operations */
+
+/* C := alpha*A*A' + beta*C, */
+
+/* or */
+
+/* C := alpha*A'*A + beta*C, */
+
+/* where alpha and beta are scalars, C is an n by n symmetric matrix */
+/* and A is an n by k matrix in the first case and a k by n matrix */
+/* in the second case. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array C is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of C */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of C */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. */
+
+/* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. */
+
+/* TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix C. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry with TRANS = 'N' or 'n', K specifies the number */
+/* of columns of the matrix A, and on entry with */
+/* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number */
+/* of rows of the matrix A. K must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - REAL array of DIMENSION ( LDA, ka ), where ka is */
+/* k when TRANS = 'N' or 'n', and is n otherwise. */
+/* Before entry with TRANS = 'N' or 'n', the leading n by k */
+/* part of the array A must contain the matrix A, otherwise */
+/* the leading k by n part of the array A must contain the */
+/* matrix A. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When TRANS = 'N' or 'n' */
+/* then LDA must be at least max( 1, n ), otherwise LDA must */
+/* be at least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* BETA - REAL . */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+/* C - REAL array of DIMENSION ( LDC, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array C must contain the upper */
+/* triangular part of the symmetric matrix and the strictly */
+/* lower triangular part of C is not referenced. On exit, the */
+/* upper triangular part of the array C is overwritten by the */
+/* upper triangular part of the updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array C must contain the lower */
+/* triangular part of the symmetric matrix and the strictly */
+/* upper triangular part of C is not referenced. On exit, the */
+/* lower triangular part of the array C is overwritten by the */
+/* lower triangular part of the updated matrix. */
+
+/* LDC - INTEGER. */
+/* On entry, LDC specifies the first dimension of C as declared */
+/* in the calling (sub) program. LDC must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ if (lsame_(trans, "N")) {
+ nrowa = *n;
+ } else {
+ nrowa = *k;
+ }
+ upper = lsame_(uplo, "U");
+
+ info = 0;
+ if (! upper && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*k < 0) {
+ info = 4;
+ } else if (*lda < max(1,nrowa)) {
+ info = 7;
+ } else if (*ldc < max(1,*n)) {
+ info = 10;
+ }
+ if (info != 0) {
+ xerbla_("SSYRK ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (*alpha == 0.f) {
+ if (upper) {
+ if (*beta == 0.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else {
+ if (*beta == 0.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.f;
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form C := alpha*A*A' + beta*C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*beta == 0.f) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.f;
+/* L90: */
+ }
+ } else if (*beta != 1.f) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L100: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ if (a[j + l * a_dim1] != 0.f) {
+ temp = *alpha * a[j + l * a_dim1];
+ i__3 = j;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ c__[i__ + j * c_dim1] += temp * a[i__ + l *
+ a_dim1];
+/* L110: */
+ }
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*beta == 0.f) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.f;
+/* L140: */
+ }
+ } else if (*beta != 1.f) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L150: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ if (a[j + l * a_dim1] != 0.f) {
+ temp = *alpha * a[j + l * a_dim1];
+ i__3 = *n;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ c__[i__ + j * c_dim1] += temp * a[i__ + l *
+ a_dim1];
+/* L160: */
+ }
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+ } else {
+
+/* Form C := alpha*A'*A + beta*C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = 0.f;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ temp += a[l + i__ * a_dim1] * a[l + j * a_dim1];
+/* L190: */
+ }
+ if (*beta == 0.f) {
+ c__[i__ + j * c_dim1] = *alpha * temp;
+ } else {
+ c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
+ i__ + j * c_dim1];
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ temp = 0.f;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ temp += a[l + i__ * a_dim1] * a[l + j * a_dim1];
+/* L220: */
+ }
+ if (*beta == 0.f) {
+ c__[i__ + j * c_dim1] = *alpha * temp;
+ } else {
+ c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
+ i__ + j * c_dim1];
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SSYRK . */
+
+} /* ssyrk_ */
diff --git a/BLAS/SRC/stbmv.c b/BLAS/SRC/stbmv.c
new file mode 100644
index 0000000..bea0335
--- /dev/null
+++ b/BLAS/SRC/stbmv.c
@@ -0,0 +1,422 @@
+/* stbmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int stbmv_(char *uplo, char *trans, char *diag, integer *n,
+ integer *k, real *a, integer *lda, real *x, integer *incx)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, l, ix, jx, kx, info;
+ real temp;
+ extern logical lsame_(char *, char *);
+ integer kplus1;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STBMV performs one of the matrix-vector operations */
+
+/* x := A*x, or x := A'*x, */
+
+/* where x is an n element vector and A is an n by n unit, or non-unit, */
+/* upper or lower triangular band matrix, with ( k + 1 ) diagonals. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' x := A*x. */
+
+/* TRANS = 'T' or 't' x := A'*x. */
+
+/* TRANS = 'C' or 'c' x := A'*x. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry with UPLO = 'U' or 'u', K specifies the number of */
+/* super-diagonals of the matrix A. */
+/* On entry with UPLO = 'L' or 'l', K specifies the number of */
+/* sub-diagonals of the matrix A. */
+/* K must satisfy 0 .le. K. */
+/* Unchanged on exit. */
+
+/* A - REAL array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
+/* by n part of the array A must contain the upper triangular */
+/* band part of the matrix of coefficients, supplied column by */
+/* column, with the leading diagonal of the matrix in row */
+/* ( k + 1 ) of the array, the first super-diagonal starting at */
+/* position 2 in row k, and so on. The top left k by k triangle */
+/* of the array A is not referenced. */
+/* The following program segment will transfer an upper */
+/* triangular band matrix from conventional full matrix storage */
+/* to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = K + 1 - J */
+/* DO 10, I = MAX( 1, J - K ), J */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
+/* by n part of the array A must contain the lower triangular */
+/* band part of the matrix of coefficients, supplied column by */
+/* column, with the leading diagonal of the matrix in row 1 of */
+/* the array, the first sub-diagonal starting at position 1 in */
+/* row 2, and so on. The bottom right k by k triangle of the */
+/* array A is not referenced. */
+/* The following program segment will transfer a lower */
+/* triangular band matrix from conventional full matrix storage */
+/* to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = 1 - J */
+/* DO 10, I = J, MIN( N, J + K ) */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Note that when DIAG = 'U' or 'u' the elements of the array A */
+/* corresponding to the diagonal elements of the matrix are not */
+/* referenced, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* ( k + 1 ). */
+/* Unchanged on exit. */
+
+/* X - REAL array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. On exit, X is overwritten with the */
+/* tranformed vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*k < 0) {
+ info = 5;
+ } else if (*lda < *k + 1) {
+ info = 7;
+ } else if (*incx == 0) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("STBMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through A. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x := A*x. */
+
+ if (lsame_(uplo, "U")) {
+ kplus1 = *k + 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.f) {
+ temp = x[j];
+ l = kplus1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ x[i__] += temp * a[l + i__ + j * a_dim1];
+/* L10: */
+ }
+ if (nounit) {
+ x[j] *= a[kplus1 + j * a_dim1];
+ }
+ }
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.f) {
+ temp = x[jx];
+ ix = kx;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *k;
+ i__3 = j - 1;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ x[ix] += temp * a[l + i__ + j * a_dim1];
+ ix += *incx;
+/* L30: */
+ }
+ if (nounit) {
+ x[jx] *= a[kplus1 + j * a_dim1];
+ }
+ }
+ jx += *incx;
+ if (j > *k) {
+ kx += *incx;
+ }
+/* L40: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ if (x[j] != 0.f) {
+ temp = x[j];
+ l = 1 - j;
+/* Computing MIN */
+ i__1 = *n, i__3 = j + *k;
+ i__4 = j + 1;
+ for (i__ = min(i__1,i__3); i__ >= i__4; --i__) {
+ x[i__] += temp * a[l + i__ + j * a_dim1];
+/* L50: */
+ }
+ if (nounit) {
+ x[j] *= a[j * a_dim1 + 1];
+ }
+ }
+/* L60: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ if (x[jx] != 0.f) {
+ temp = x[jx];
+ ix = kx;
+ l = 1 - j;
+/* Computing MIN */
+ i__4 = *n, i__1 = j + *k;
+ i__3 = j + 1;
+ for (i__ = min(i__4,i__1); i__ >= i__3; --i__) {
+ x[ix] += temp * a[l + i__ + j * a_dim1];
+ ix -= *incx;
+/* L70: */
+ }
+ if (nounit) {
+ x[jx] *= a[j * a_dim1 + 1];
+ }
+ }
+ jx -= *incx;
+ if (*n - j >= *k) {
+ kx -= *incx;
+ }
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := A'*x. */
+
+ if (lsame_(uplo, "U")) {
+ kplus1 = *k + 1;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ temp = x[j];
+ l = kplus1 - j;
+ if (nounit) {
+ temp *= a[kplus1 + j * a_dim1];
+ }
+/* Computing MAX */
+ i__4 = 1, i__1 = j - *k;
+ i__3 = max(i__4,i__1);
+ for (i__ = j - 1; i__ >= i__3; --i__) {
+ temp += a[l + i__ + j * a_dim1] * x[i__];
+/* L90: */
+ }
+ x[j] = temp;
+/* L100: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ temp = x[jx];
+ kx -= *incx;
+ ix = kx;
+ l = kplus1 - j;
+ if (nounit) {
+ temp *= a[kplus1 + j * a_dim1];
+ }
+/* Computing MAX */
+ i__4 = 1, i__1 = j - *k;
+ i__3 = max(i__4,i__1);
+ for (i__ = j - 1; i__ >= i__3; --i__) {
+ temp += a[l + i__ + j * a_dim1] * x[ix];
+ ix -= *incx;
+/* L110: */
+ }
+ x[jx] = temp;
+ jx -= *incx;
+/* L120: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ temp = x[j];
+ l = 1 - j;
+ if (nounit) {
+ temp *= a[j * a_dim1 + 1];
+ }
+/* Computing MIN */
+ i__1 = *n, i__2 = j + *k;
+ i__4 = min(i__1,i__2);
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ temp += a[l + i__ + j * a_dim1] * x[i__];
+/* L130: */
+ }
+ x[j] = temp;
+/* L140: */
+ }
+ } else {
+ jx = kx;
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ temp = x[jx];
+ kx += *incx;
+ ix = kx;
+ l = 1 - j;
+ if (nounit) {
+ temp *= a[j * a_dim1 + 1];
+ }
+/* Computing MIN */
+ i__1 = *n, i__2 = j + *k;
+ i__4 = min(i__1,i__2);
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ temp += a[l + i__ + j * a_dim1] * x[ix];
+ ix += *incx;
+/* L150: */
+ }
+ x[jx] = temp;
+ jx += *incx;
+/* L160: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of STBMV . */
+
+} /* stbmv_ */
diff --git a/BLAS/SRC/stbsv.c b/BLAS/SRC/stbsv.c
new file mode 100644
index 0000000..ef933a1
--- /dev/null
+++ b/BLAS/SRC/stbsv.c
@@ -0,0 +1,426 @@
+/* stbsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int stbsv_(char *uplo, char *trans, char *diag, integer *n,
+ integer *k, real *a, integer *lda, real *x, integer *incx)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, l, ix, jx, kx, info;
+ real temp;
+ extern logical lsame_(char *, char *);
+ integer kplus1;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STBSV solves one of the systems of equations */
+
+/* A*x = b, or A'*x = b, */
+
+/* where b and x are n element vectors and A is an n by n unit, or */
+/* non-unit, upper or lower triangular band matrix, with ( k + 1 ) */
+/* diagonals. */
+
+/* No test for singularity or near-singularity is included in this */
+/* routine. Such tests must be performed before calling this routine. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the equations to be solved as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' A*x = b. */
+
+/* TRANS = 'T' or 't' A'*x = b. */
+
+/* TRANS = 'C' or 'c' A'*x = b. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry with UPLO = 'U' or 'u', K specifies the number of */
+/* super-diagonals of the matrix A. */
+/* On entry with UPLO = 'L' or 'l', K specifies the number of */
+/* sub-diagonals of the matrix A. */
+/* K must satisfy 0 .le. K. */
+/* Unchanged on exit. */
+
+/* A - REAL array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
+/* by n part of the array A must contain the upper triangular */
+/* band part of the matrix of coefficients, supplied column by */
+/* column, with the leading diagonal of the matrix in row */
+/* ( k + 1 ) of the array, the first super-diagonal starting at */
+/* position 2 in row k, and so on. The top left k by k triangle */
+/* of the array A is not referenced. */
+/* The following program segment will transfer an upper */
+/* triangular band matrix from conventional full matrix storage */
+/* to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = K + 1 - J */
+/* DO 10, I = MAX( 1, J - K ), J */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
+/* by n part of the array A must contain the lower triangular */
+/* band part of the matrix of coefficients, supplied column by */
+/* column, with the leading diagonal of the matrix in row 1 of */
+/* the array, the first sub-diagonal starting at position 1 in */
+/* row 2, and so on. The bottom right k by k triangle of the */
+/* array A is not referenced. */
+/* The following program segment will transfer a lower */
+/* triangular band matrix from conventional full matrix storage */
+/* to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = 1 - J */
+/* DO 10, I = J, MIN( N, J + K ) */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Note that when DIAG = 'U' or 'u' the elements of the array A */
+/* corresponding to the diagonal elements of the matrix are not */
+/* referenced, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* ( k + 1 ). */
+/* Unchanged on exit. */
+
+/* X - REAL array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element right-hand side vector b. On exit, X is overwritten */
+/* with the solution vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*k < 0) {
+ info = 5;
+ } else if (*lda < *k + 1) {
+ info = 7;
+ } else if (*incx == 0) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("STBSV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed by sequentially with one pass through A. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x := inv( A )*x. */
+
+ if (lsame_(uplo, "U")) {
+ kplus1 = *k + 1;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ if (x[j] != 0.f) {
+ l = kplus1 - j;
+ if (nounit) {
+ x[j] /= a[kplus1 + j * a_dim1];
+ }
+ temp = x[j];
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__1 = max(i__2,i__3);
+ for (i__ = j - 1; i__ >= i__1; --i__) {
+ x[i__] -= temp * a[l + i__ + j * a_dim1];
+/* L10: */
+ }
+ }
+/* L20: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ kx -= *incx;
+ if (x[jx] != 0.f) {
+ ix = kx;
+ l = kplus1 - j;
+ if (nounit) {
+ x[jx] /= a[kplus1 + j * a_dim1];
+ }
+ temp = x[jx];
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__1 = max(i__2,i__3);
+ for (i__ = j - 1; i__ >= i__1; --i__) {
+ x[ix] -= temp * a[l + i__ + j * a_dim1];
+ ix -= *incx;
+/* L30: */
+ }
+ }
+ jx -= *incx;
+/* L40: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.f) {
+ l = 1 - j;
+ if (nounit) {
+ x[j] /= a[j * a_dim1 + 1];
+ }
+ temp = x[j];
+/* Computing MIN */
+ i__3 = *n, i__4 = j + *k;
+ i__2 = min(i__3,i__4);
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ x[i__] -= temp * a[l + i__ + j * a_dim1];
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ kx += *incx;
+ if (x[jx] != 0.f) {
+ ix = kx;
+ l = 1 - j;
+ if (nounit) {
+ x[jx] /= a[j * a_dim1 + 1];
+ }
+ temp = x[jx];
+/* Computing MIN */
+ i__3 = *n, i__4 = j + *k;
+ i__2 = min(i__3,i__4);
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ x[ix] -= temp * a[l + i__ + j * a_dim1];
+ ix += *incx;
+/* L70: */
+ }
+ }
+ jx += *incx;
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := inv( A')*x. */
+
+ if (lsame_(uplo, "U")) {
+ kplus1 = *k + 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = x[j];
+ l = kplus1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ temp -= a[l + i__ + j * a_dim1] * x[i__];
+/* L90: */
+ }
+ if (nounit) {
+ temp /= a[kplus1 + j * a_dim1];
+ }
+ x[j] = temp;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = x[jx];
+ ix = kx;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *k;
+ i__3 = j - 1;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ temp -= a[l + i__ + j * a_dim1] * x[ix];
+ ix += *incx;
+/* L110: */
+ }
+ if (nounit) {
+ temp /= a[kplus1 + j * a_dim1];
+ }
+ x[jx] = temp;
+ jx += *incx;
+ if (j > *k) {
+ kx += *incx;
+ }
+/* L120: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ temp = x[j];
+ l = 1 - j;
+/* Computing MIN */
+ i__1 = *n, i__3 = j + *k;
+ i__4 = j + 1;
+ for (i__ = min(i__1,i__3); i__ >= i__4; --i__) {
+ temp -= a[l + i__ + j * a_dim1] * x[i__];
+/* L130: */
+ }
+ if (nounit) {
+ temp /= a[j * a_dim1 + 1];
+ }
+ x[j] = temp;
+/* L140: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ temp = x[jx];
+ ix = kx;
+ l = 1 - j;
+/* Computing MIN */
+ i__4 = *n, i__1 = j + *k;
+ i__3 = j + 1;
+ for (i__ = min(i__4,i__1); i__ >= i__3; --i__) {
+ temp -= a[l + i__ + j * a_dim1] * x[ix];
+ ix -= *incx;
+/* L150: */
+ }
+ if (nounit) {
+ temp /= a[j * a_dim1 + 1];
+ }
+ x[jx] = temp;
+ jx -= *incx;
+ if (*n - j >= *k) {
+ kx -= *incx;
+ }
+/* L160: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of STBSV . */
+
+} /* stbsv_ */
diff --git a/BLAS/SRC/stpmv.c b/BLAS/SRC/stpmv.c
new file mode 100644
index 0000000..9d57e2e
--- /dev/null
+++ b/BLAS/SRC/stpmv.c
@@ -0,0 +1,357 @@
+/* stpmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int stpmv_(char *uplo, char *trans, char *diag, integer *n,
+ real *ap, real *x, integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, jx, kx, info;
+ real temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STPMV performs one of the matrix-vector operations */
+
+/* x := A*x, or x := A'*x, */
+
+/* where x is an n element vector and A is an n by n unit, or non-unit, */
+/* upper or lower triangular matrix, supplied in packed form. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' x := A*x. */
+
+/* TRANS = 'T' or 't' x := A'*x. */
+
+/* TRANS = 'C' or 'c' x := A'*x. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* AP - REAL array of DIMENSION at least */
+/* ( ( n*( n + 1 ) )/2 ). */
+/* Before entry with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular matrix packed sequentially, */
+/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
+/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */
+/* respectively, and so on. */
+/* Before entry with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular matrix packed sequentially, */
+/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
+/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */
+/* respectively, and so on. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* X - REAL array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. On exit, X is overwritten with the */
+/* tranformed vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ --ap;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*incx == 0) {
+ info = 7;
+ }
+ if (info != 0) {
+ xerbla_("STPMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of AP are */
+/* accessed sequentially with one pass through AP. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x:= A*x. */
+
+ if (lsame_(uplo, "U")) {
+ kk = 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.f) {
+ temp = x[j];
+ k = kk;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__] += temp * ap[k];
+ ++k;
+/* L10: */
+ }
+ if (nounit) {
+ x[j] *= ap[kk + j - 1];
+ }
+ }
+ kk += j;
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.f) {
+ temp = x[jx];
+ ix = kx;
+ i__2 = kk + j - 2;
+ for (k = kk; k <= i__2; ++k) {
+ x[ix] += temp * ap[k];
+ ix += *incx;
+/* L30: */
+ }
+ if (nounit) {
+ x[jx] *= ap[kk + j - 1];
+ }
+ }
+ jx += *incx;
+ kk += j;
+/* L40: */
+ }
+ }
+ } else {
+ kk = *n * (*n + 1) / 2;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ if (x[j] != 0.f) {
+ temp = x[j];
+ k = kk;
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ x[i__] += temp * ap[k];
+ --k;
+/* L50: */
+ }
+ if (nounit) {
+ x[j] *= ap[kk - *n + j];
+ }
+ }
+ kk -= *n - j + 1;
+/* L60: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ if (x[jx] != 0.f) {
+ temp = x[jx];
+ ix = kx;
+ i__1 = kk - (*n - (j + 1));
+ for (k = kk; k >= i__1; --k) {
+ x[ix] += temp * ap[k];
+ ix -= *incx;
+/* L70: */
+ }
+ if (nounit) {
+ x[jx] *= ap[kk - *n + j];
+ }
+ }
+ jx -= *incx;
+ kk -= *n - j + 1;
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := A'*x. */
+
+ if (lsame_(uplo, "U")) {
+ kk = *n * (*n + 1) / 2;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ temp = x[j];
+ if (nounit) {
+ temp *= ap[kk];
+ }
+ k = kk - 1;
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ temp += ap[k] * x[i__];
+ --k;
+/* L90: */
+ }
+ x[j] = temp;
+ kk -= j;
+/* L100: */
+ }
+ } else {
+ jx = kx + (*n - 1) * *incx;
+ for (j = *n; j >= 1; --j) {
+ temp = x[jx];
+ ix = jx;
+ if (nounit) {
+ temp *= ap[kk];
+ }
+ i__1 = kk - j + 1;
+ for (k = kk - 1; k >= i__1; --k) {
+ ix -= *incx;
+ temp += ap[k] * x[ix];
+/* L110: */
+ }
+ x[jx] = temp;
+ jx -= *incx;
+ kk -= j;
+/* L120: */
+ }
+ }
+ } else {
+ kk = 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = x[j];
+ if (nounit) {
+ temp *= ap[kk];
+ }
+ k = kk + 1;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ temp += ap[k] * x[i__];
+ ++k;
+/* L130: */
+ }
+ x[j] = temp;
+ kk += *n - j + 1;
+/* L140: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = x[jx];
+ ix = jx;
+ if (nounit) {
+ temp *= ap[kk];
+ }
+ i__2 = kk + *n - j;
+ for (k = kk + 1; k <= i__2; ++k) {
+ ix += *incx;
+ temp += ap[k] * x[ix];
+/* L150: */
+ }
+ x[jx] = temp;
+ jx += *incx;
+ kk += *n - j + 1;
+/* L160: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of STPMV . */
+
+} /* stpmv_ */
diff --git a/BLAS/SRC/stpsv.c b/BLAS/SRC/stpsv.c
new file mode 100644
index 0000000..f16be31
--- /dev/null
+++ b/BLAS/SRC/stpsv.c
@@ -0,0 +1,360 @@
+/* stpsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int stpsv_(char *uplo, char *trans, char *diag, integer *n,
+ real *ap, real *x, integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, jx, kx, info;
+ real temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STPSV solves one of the systems of equations */
+
+/* A*x = b, or A'*x = b, */
+
+/* where b and x are n element vectors and A is an n by n unit, or */
+/* non-unit, upper or lower triangular matrix, supplied in packed form. */
+
+/* No test for singularity or near-singularity is included in this */
+/* routine. Such tests must be performed before calling this routine. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the equations to be solved as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' A*x = b. */
+
+/* TRANS = 'T' or 't' A'*x = b. */
+
+/* TRANS = 'C' or 'c' A'*x = b. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* AP - REAL array of DIMENSION at least */
+/* ( ( n*( n + 1 ) )/2 ). */
+/* Before entry with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular matrix packed sequentially, */
+/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
+/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */
+/* respectively, and so on. */
+/* Before entry with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular matrix packed sequentially, */
+/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
+/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */
+/* respectively, and so on. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* X - REAL array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element right-hand side vector b. On exit, X is overwritten */
+/* with the solution vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ --ap;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*incx == 0) {
+ info = 7;
+ }
+ if (info != 0) {
+ xerbla_("STPSV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of AP are */
+/* accessed sequentially with one pass through AP. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x := inv( A )*x. */
+
+ if (lsame_(uplo, "U")) {
+ kk = *n * (*n + 1) / 2;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ if (x[j] != 0.f) {
+ if (nounit) {
+ x[j] /= ap[kk];
+ }
+ temp = x[j];
+ k = kk - 1;
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ x[i__] -= temp * ap[k];
+ --k;
+/* L10: */
+ }
+ }
+ kk -= j;
+/* L20: */
+ }
+ } else {
+ jx = kx + (*n - 1) * *incx;
+ for (j = *n; j >= 1; --j) {
+ if (x[jx] != 0.f) {
+ if (nounit) {
+ x[jx] /= ap[kk];
+ }
+ temp = x[jx];
+ ix = jx;
+ i__1 = kk - j + 1;
+ for (k = kk - 1; k >= i__1; --k) {
+ ix -= *incx;
+ x[ix] -= temp * ap[k];
+/* L30: */
+ }
+ }
+ jx -= *incx;
+ kk -= j;
+/* L40: */
+ }
+ }
+ } else {
+ kk = 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.f) {
+ if (nounit) {
+ x[j] /= ap[kk];
+ }
+ temp = x[j];
+ k = kk + 1;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ x[i__] -= temp * ap[k];
+ ++k;
+/* L50: */
+ }
+ }
+ kk += *n - j + 1;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.f) {
+ if (nounit) {
+ x[jx] /= ap[kk];
+ }
+ temp = x[jx];
+ ix = jx;
+ i__2 = kk + *n - j;
+ for (k = kk + 1; k <= i__2; ++k) {
+ ix += *incx;
+ x[ix] -= temp * ap[k];
+/* L70: */
+ }
+ }
+ jx += *incx;
+ kk += *n - j + 1;
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := inv( A' )*x. */
+
+ if (lsame_(uplo, "U")) {
+ kk = 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = x[j];
+ k = kk;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp -= ap[k] * x[i__];
+ ++k;
+/* L90: */
+ }
+ if (nounit) {
+ temp /= ap[kk + j - 1];
+ }
+ x[j] = temp;
+ kk += j;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = x[jx];
+ ix = kx;
+ i__2 = kk + j - 2;
+ for (k = kk; k <= i__2; ++k) {
+ temp -= ap[k] * x[ix];
+ ix += *incx;
+/* L110: */
+ }
+ if (nounit) {
+ temp /= ap[kk + j - 1];
+ }
+ x[jx] = temp;
+ jx += *incx;
+ kk += j;
+/* L120: */
+ }
+ }
+ } else {
+ kk = *n * (*n + 1) / 2;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ temp = x[j];
+ k = kk;
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ temp -= ap[k] * x[i__];
+ --k;
+/* L130: */
+ }
+ if (nounit) {
+ temp /= ap[kk - *n + j];
+ }
+ x[j] = temp;
+ kk -= *n - j + 1;
+/* L140: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ temp = x[jx];
+ ix = kx;
+ i__1 = kk - (*n - (j + 1));
+ for (k = kk; k >= i__1; --k) {
+ temp -= ap[k] * x[ix];
+ ix -= *incx;
+/* L150: */
+ }
+ if (nounit) {
+ temp /= ap[kk - *n + j];
+ }
+ x[jx] = temp;
+ jx -= *incx;
+ kk -= *n - j + 1;
+/* L160: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of STPSV . */
+
+} /* stpsv_ */
diff --git a/BLAS/SRC/strmm.c b/BLAS/SRC/strmm.c
new file mode 100644
index 0000000..0dfb68f
--- /dev/null
+++ b/BLAS/SRC/strmm.c
@@ -0,0 +1,453 @@
+/* strmm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int strmm_(char *side, char *uplo, char *transa, char *diag,
+ integer *m, integer *n, real *alpha, real *a, integer *lda, real *b,
+ integer *ldb)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, k, info;
+ real temp;
+ logical lside;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STRMM performs one of the matrix-matrix operations */
+
+/* B := alpha*op( A )*B, or B := alpha*B*op( A ), */
+
+/* where alpha is a scalar, B is an m by n matrix, A is a unit, or */
+/* non-unit, upper or lower triangular matrix and op( A ) is one of */
+
+/* op( A ) = A or op( A ) = A'. */
+
+/* Arguments */
+/* ========== */
+
+/* SIDE - CHARACTER*1. */
+/* On entry, SIDE specifies whether op( A ) multiplies B from */
+/* the left or right as follows: */
+
+/* SIDE = 'L' or 'l' B := alpha*op( A )*B. */
+
+/* SIDE = 'R' or 'r' B := alpha*B*op( A ). */
+
+/* Unchanged on exit. */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix A is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANSA - CHARACTER*1. */
+/* On entry, TRANSA specifies the form of op( A ) to be used in */
+/* the matrix multiplication as follows: */
+
+/* TRANSA = 'N' or 'n' op( A ) = A. */
+
+/* TRANSA = 'T' or 't' op( A ) = A'. */
+
+/* TRANSA = 'C' or 'c' op( A ) = A'. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit triangular */
+/* as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of B. M must be at */
+/* least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of B. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL . */
+/* On entry, ALPHA specifies the scalar alpha. When alpha is */
+/* zero then A is not referenced and B need not be set before */
+/* entry. */
+/* Unchanged on exit. */
+
+/* A - REAL array of DIMENSION ( LDA, k ), where k is m */
+/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */
+/* Before entry with UPLO = 'U' or 'u', the leading k by k */
+/* upper triangular part of the array A must contain the upper */
+/* triangular matrix and the strictly lower triangular part of */
+/* A is not referenced. */
+/* Before entry with UPLO = 'L' or 'l', the leading k by k */
+/* lower triangular part of the array A must contain the lower */
+/* triangular matrix and the strictly upper triangular part of */
+/* A is not referenced. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced either, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When SIDE = 'L' or 'l' then */
+/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */
+/* then LDA must be at least max( 1, n ). */
+/* Unchanged on exit. */
+
+/* B - REAL array of DIMENSION ( LDB, n ). */
+/* Before entry, the leading m by n part of the array B must */
+/* contain the matrix B, and on exit is overwritten by the */
+/* transformed matrix. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. LDB must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ lside = lsame_(side, "L");
+ if (lside) {
+ nrowa = *m;
+ } else {
+ nrowa = *n;
+ }
+ nounit = lsame_(diag, "N");
+ upper = lsame_(uplo, "U");
+
+ info = 0;
+ if (! lside && ! lsame_(side, "R")) {
+ info = 1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ info = 2;
+ } else if (! lsame_(transa, "N") && ! lsame_(transa,
+ "T") && ! lsame_(transa, "C")) {
+ info = 3;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 4;
+ } else if (*m < 0) {
+ info = 5;
+ } else if (*n < 0) {
+ info = 6;
+ } else if (*lda < max(1,nrowa)) {
+ info = 9;
+ } else if (*ldb < max(1,*m)) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("STRMM ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (*alpha == 0.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lside) {
+ if (lsame_(transa, "N")) {
+
+/* Form B := alpha*A*B. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (k = 1; k <= i__2; ++k) {
+ if (b[k + j * b_dim1] != 0.f) {
+ temp = *alpha * b[k + j * b_dim1];
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ b[i__ + j * b_dim1] += temp * a[i__ + k *
+ a_dim1];
+/* L30: */
+ }
+ if (nounit) {
+ temp *= a[k + k * a_dim1];
+ }
+ b[k + j * b_dim1] = temp;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (k = *m; k >= 1; --k) {
+ if (b[k + j * b_dim1] != 0.f) {
+ temp = *alpha * b[k + j * b_dim1];
+ b[k + j * b_dim1] = temp;
+ if (nounit) {
+ b[k + j * b_dim1] *= a[k + k * a_dim1];
+ }
+ i__2 = *m;
+ for (i__ = k + 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] += temp * a[i__ + k *
+ a_dim1];
+/* L60: */
+ }
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form B := alpha*A'*B. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (i__ = *m; i__ >= 1; --i__) {
+ temp = b[i__ + j * b_dim1];
+ if (nounit) {
+ temp *= a[i__ + i__ * a_dim1];
+ }
+ i__2 = i__ - 1;
+ for (k = 1; k <= i__2; ++k) {
+ temp += a[k + i__ * a_dim1] * b[k + j * b_dim1];
+/* L90: */
+ }
+ b[i__ + j * b_dim1] = *alpha * temp;
+/* L100: */
+ }
+/* L110: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = b[i__ + j * b_dim1];
+ if (nounit) {
+ temp *= a[i__ + i__ * a_dim1];
+ }
+ i__3 = *m;
+ for (k = i__ + 1; k <= i__3; ++k) {
+ temp += a[k + i__ * a_dim1] * b[k + j * b_dim1];
+/* L120: */
+ }
+ b[i__ + j * b_dim1] = *alpha * temp;
+/* L130: */
+ }
+/* L140: */
+ }
+ }
+ }
+ } else {
+ if (lsame_(transa, "N")) {
+
+/* Form B := alpha*B*A. */
+
+ if (upper) {
+ for (j = *n; j >= 1; --j) {
+ temp = *alpha;
+ if (nounit) {
+ temp *= a[j + j * a_dim1];
+ }
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
+/* L150: */
+ }
+ i__1 = j - 1;
+ for (k = 1; k <= i__1; ++k) {
+ if (a[k + j * a_dim1] != 0.f) {
+ temp = *alpha * a[k + j * a_dim1];
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] += temp * b[i__ + k *
+ b_dim1];
+/* L160: */
+ }
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = *alpha;
+ if (nounit) {
+ temp *= a[j + j * a_dim1];
+ }
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
+/* L190: */
+ }
+ i__2 = *n;
+ for (k = j + 1; k <= i__2; ++k) {
+ if (a[k + j * a_dim1] != 0.f) {
+ temp = *alpha * a[k + j * a_dim1];
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ b[i__ + j * b_dim1] += temp * b[i__ + k *
+ b_dim1];
+/* L200: */
+ }
+ }
+/* L210: */
+ }
+/* L220: */
+ }
+ }
+ } else {
+
+/* Form B := alpha*B*A'. */
+
+ if (upper) {
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = k - 1;
+ for (j = 1; j <= i__2; ++j) {
+ if (a[j + k * a_dim1] != 0.f) {
+ temp = *alpha * a[j + k * a_dim1];
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ b[i__ + j * b_dim1] += temp * b[i__ + k *
+ b_dim1];
+/* L230: */
+ }
+ }
+/* L240: */
+ }
+ temp = *alpha;
+ if (nounit) {
+ temp *= a[k + k * a_dim1];
+ }
+ if (temp != 1.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
+/* L250: */
+ }
+ }
+/* L260: */
+ }
+ } else {
+ for (k = *n; k >= 1; --k) {
+ i__1 = *n;
+ for (j = k + 1; j <= i__1; ++j) {
+ if (a[j + k * a_dim1] != 0.f) {
+ temp = *alpha * a[j + k * a_dim1];
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] += temp * b[i__ + k *
+ b_dim1];
+/* L270: */
+ }
+ }
+/* L280: */
+ }
+ temp = *alpha;
+ if (nounit) {
+ temp *= a[k + k * a_dim1];
+ }
+ if (temp != 1.f) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
+/* L290: */
+ }
+ }
+/* L300: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of STRMM . */
+
+} /* strmm_ */
diff --git a/BLAS/SRC/strmv.c b/BLAS/SRC/strmv.c
new file mode 100644
index 0000000..d4ff0b9
--- /dev/null
+++ b/BLAS/SRC/strmv.c
@@ -0,0 +1,345 @@
+/* strmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int strmv_(char *uplo, char *trans, char *diag, integer *n,
+ real *a, integer *lda, real *x, integer *incx)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, ix, jx, kx, info;
+ real temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STRMV performs one of the matrix-vector operations */
+
+/* x := A*x, or x := A'*x, */
+
+/* where x is an n element vector and A is an n by n unit, or non-unit, */
+/* upper or lower triangular matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' x := A*x. */
+
+/* TRANS = 'T' or 't' x := A'*x. */
+
+/* TRANS = 'C' or 'c' x := A'*x. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* A - REAL array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular matrix and the strictly lower triangular part of */
+/* A is not referenced. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular matrix and the strictly upper triangular part of */
+/* A is not referenced. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced either, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+/* X - REAL array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. On exit, X is overwritten with the */
+/* tranformed vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*lda < max(1,*n)) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ }
+ if (info != 0) {
+ xerbla_("STRMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through A. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x := A*x. */
+
+ if (lsame_(uplo, "U")) {
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.f) {
+ temp = x[j];
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__] += temp * a[i__ + j * a_dim1];
+/* L10: */
+ }
+ if (nounit) {
+ x[j] *= a[j + j * a_dim1];
+ }
+ }
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.f) {
+ temp = x[jx];
+ ix = kx;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[ix] += temp * a[i__ + j * a_dim1];
+ ix += *incx;
+/* L30: */
+ }
+ if (nounit) {
+ x[jx] *= a[j + j * a_dim1];
+ }
+ }
+ jx += *incx;
+/* L40: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ if (x[j] != 0.f) {
+ temp = x[j];
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ x[i__] += temp * a[i__ + j * a_dim1];
+/* L50: */
+ }
+ if (nounit) {
+ x[j] *= a[j + j * a_dim1];
+ }
+ }
+/* L60: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ if (x[jx] != 0.f) {
+ temp = x[jx];
+ ix = kx;
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ x[ix] += temp * a[i__ + j * a_dim1];
+ ix -= *incx;
+/* L70: */
+ }
+ if (nounit) {
+ x[jx] *= a[j + j * a_dim1];
+ }
+ }
+ jx -= *incx;
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := A'*x. */
+
+ if (lsame_(uplo, "U")) {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ temp = x[j];
+ if (nounit) {
+ temp *= a[j + j * a_dim1];
+ }
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ temp += a[i__ + j * a_dim1] * x[i__];
+/* L90: */
+ }
+ x[j] = temp;
+/* L100: */
+ }
+ } else {
+ jx = kx + (*n - 1) * *incx;
+ for (j = *n; j >= 1; --j) {
+ temp = x[jx];
+ ix = jx;
+ if (nounit) {
+ temp *= a[j + j * a_dim1];
+ }
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ ix -= *incx;
+ temp += a[i__ + j * a_dim1] * x[ix];
+/* L110: */
+ }
+ x[jx] = temp;
+ jx -= *incx;
+/* L120: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = x[j];
+ if (nounit) {
+ temp *= a[j + j * a_dim1];
+ }
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ temp += a[i__ + j * a_dim1] * x[i__];
+/* L130: */
+ }
+ x[j] = temp;
+/* L140: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = x[jx];
+ ix = jx;
+ if (nounit) {
+ temp *= a[j + j * a_dim1];
+ }
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ ix += *incx;
+ temp += a[i__ + j * a_dim1] * x[ix];
+/* L150: */
+ }
+ x[jx] = temp;
+ jx += *incx;
+/* L160: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of STRMV . */
+
+} /* strmv_ */
diff --git a/BLAS/SRC/strsm.c b/BLAS/SRC/strsm.c
new file mode 100644
index 0000000..8c50307
--- /dev/null
+++ b/BLAS/SRC/strsm.c
@@ -0,0 +1,490 @@
+/* strsm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int strsm_(char *side, char *uplo, char *transa, char *diag,
+ integer *m, integer *n, real *alpha, real *a, integer *lda, real *b,
+ integer *ldb)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, k, info;
+ real temp;
+ logical lside;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STRSM solves one of the matrix equations */
+
+/* op( A )*X = alpha*B, or X*op( A ) = alpha*B, */
+
+/* where alpha is a scalar, X and B are m by n matrices, A is a unit, or */
+/* non-unit, upper or lower triangular matrix and op( A ) is one of */
+
+/* op( A ) = A or op( A ) = A'. */
+
+/* The matrix X is overwritten on B. */
+
+/* Arguments */
+/* ========== */
+
+/* SIDE - CHARACTER*1. */
+/* On entry, SIDE specifies whether op( A ) appears on the left */
+/* or right of X as follows: */
+
+/* SIDE = 'L' or 'l' op( A )*X = alpha*B. */
+
+/* SIDE = 'R' or 'r' X*op( A ) = alpha*B. */
+
+/* Unchanged on exit. */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix A is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANSA - CHARACTER*1. */
+/* On entry, TRANSA specifies the form of op( A ) to be used in */
+/* the matrix multiplication as follows: */
+
+/* TRANSA = 'N' or 'n' op( A ) = A. */
+
+/* TRANSA = 'T' or 't' op( A ) = A'. */
+
+/* TRANSA = 'C' or 'c' op( A ) = A'. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit triangular */
+/* as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of B. M must be at */
+/* least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of B. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL . */
+/* On entry, ALPHA specifies the scalar alpha. When alpha is */
+/* zero then A is not referenced and B need not be set before */
+/* entry. */
+/* Unchanged on exit. */
+
+/* A - REAL array of DIMENSION ( LDA, k ), where k is m */
+/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */
+/* Before entry with UPLO = 'U' or 'u', the leading k by k */
+/* upper triangular part of the array A must contain the upper */
+/* triangular matrix and the strictly lower triangular part of */
+/* A is not referenced. */
+/* Before entry with UPLO = 'L' or 'l', the leading k by k */
+/* lower triangular part of the array A must contain the lower */
+/* triangular matrix and the strictly upper triangular part of */
+/* A is not referenced. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced either, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When SIDE = 'L' or 'l' then */
+/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */
+/* then LDA must be at least max( 1, n ). */
+/* Unchanged on exit. */
+
+/* B - REAL array of DIMENSION ( LDB, n ). */
+/* Before entry, the leading m by n part of the array B must */
+/* contain the right-hand side matrix B, and on exit is */
+/* overwritten by the solution matrix X. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. LDB must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ lside = lsame_(side, "L");
+ if (lside) {
+ nrowa = *m;
+ } else {
+ nrowa = *n;
+ }
+ nounit = lsame_(diag, "N");
+ upper = lsame_(uplo, "U");
+
+ info = 0;
+ if (! lside && ! lsame_(side, "R")) {
+ info = 1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ info = 2;
+ } else if (! lsame_(transa, "N") && ! lsame_(transa,
+ "T") && ! lsame_(transa, "C")) {
+ info = 3;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 4;
+ } else if (*m < 0) {
+ info = 5;
+ } else if (*n < 0) {
+ info = 6;
+ } else if (*lda < max(1,nrowa)) {
+ info = 9;
+ } else if (*ldb < max(1,*m)) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("STRSM ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (*alpha == 0.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lside) {
+ if (lsame_(transa, "N")) {
+
+/* Form B := alpha*inv( A )*B. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*alpha != 1.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
+ ;
+/* L30: */
+ }
+ }
+ for (k = *m; k >= 1; --k) {
+ if (b[k + j * b_dim1] != 0.f) {
+ if (nounit) {
+ b[k + j * b_dim1] /= a[k + k * a_dim1];
+ }
+ i__2 = k - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[
+ i__ + k * a_dim1];
+/* L40: */
+ }
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*alpha != 1.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
+ ;
+/* L70: */
+ }
+ }
+ i__2 = *m;
+ for (k = 1; k <= i__2; ++k) {
+ if (b[k + j * b_dim1] != 0.f) {
+ if (nounit) {
+ b[k + j * b_dim1] /= a[k + k * a_dim1];
+ }
+ i__3 = *m;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[
+ i__ + k * a_dim1];
+/* L80: */
+ }
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+ }
+ } else {
+
+/* Form B := alpha*inv( A' )*B. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = *alpha * b[i__ + j * b_dim1];
+ i__3 = i__ - 1;
+ for (k = 1; k <= i__3; ++k) {
+ temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1];
+/* L110: */
+ }
+ if (nounit) {
+ temp /= a[i__ + i__ * a_dim1];
+ }
+ b[i__ + j * b_dim1] = temp;
+/* L120: */
+ }
+/* L130: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (i__ = *m; i__ >= 1; --i__) {
+ temp = *alpha * b[i__ + j * b_dim1];
+ i__2 = *m;
+ for (k = i__ + 1; k <= i__2; ++k) {
+ temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1];
+/* L140: */
+ }
+ if (nounit) {
+ temp /= a[i__ + i__ * a_dim1];
+ }
+ b[i__ + j * b_dim1] = temp;
+/* L150: */
+ }
+/* L160: */
+ }
+ }
+ }
+ } else {
+ if (lsame_(transa, "N")) {
+
+/* Form B := alpha*B*inv( A ). */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*alpha != 1.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
+ ;
+/* L170: */
+ }
+ }
+ i__2 = j - 1;
+ for (k = 1; k <= i__2; ++k) {
+ if (a[k + j * a_dim1] != 0.f) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[
+ i__ + k * b_dim1];
+/* L180: */
+ }
+ }
+/* L190: */
+ }
+ if (nounit) {
+ temp = 1.f / a[j + j * a_dim1];
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
+/* L200: */
+ }
+ }
+/* L210: */
+ }
+ } else {
+ for (j = *n; j >= 1; --j) {
+ if (*alpha != 1.f) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
+ ;
+/* L220: */
+ }
+ }
+ i__1 = *n;
+ for (k = j + 1; k <= i__1; ++k) {
+ if (a[k + j * a_dim1] != 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[
+ i__ + k * b_dim1];
+/* L230: */
+ }
+ }
+/* L240: */
+ }
+ if (nounit) {
+ temp = 1.f / a[j + j * a_dim1];
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
+/* L250: */
+ }
+ }
+/* L260: */
+ }
+ }
+ } else {
+
+/* Form B := alpha*B*inv( A' ). */
+
+ if (upper) {
+ for (k = *n; k >= 1; --k) {
+ if (nounit) {
+ temp = 1.f / a[k + k * a_dim1];
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
+/* L270: */
+ }
+ }
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ if (a[j + k * a_dim1] != 0.f) {
+ temp = a[j + k * a_dim1];
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] -= temp * b[i__ + k *
+ b_dim1];
+/* L280: */
+ }
+ }
+/* L290: */
+ }
+ if (*alpha != 1.f) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1]
+ ;
+/* L300: */
+ }
+ }
+/* L310: */
+ }
+ } else {
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (nounit) {
+ temp = 1.f / a[k + k * a_dim1];
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
+/* L320: */
+ }
+ }
+ i__2 = *n;
+ for (j = k + 1; j <= i__2; ++j) {
+ if (a[j + k * a_dim1] != 0.f) {
+ temp = a[j + k * a_dim1];
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ b[i__ + j * b_dim1] -= temp * b[i__ + k *
+ b_dim1];
+/* L330: */
+ }
+ }
+/* L340: */
+ }
+ if (*alpha != 1.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1]
+ ;
+/* L350: */
+ }
+ }
+/* L360: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of STRSM . */
+
+} /* strsm_ */
diff --git a/BLAS/SRC/strsv.c b/BLAS/SRC/strsv.c
new file mode 100644
index 0000000..fe61b84
--- /dev/null
+++ b/BLAS/SRC/strsv.c
@@ -0,0 +1,348 @@
+/* strsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int strsv_(char *uplo, char *trans, char *diag, integer *n,
+ real *a, integer *lda, real *x, integer *incx)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, ix, jx, kx, info;
+ real temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STRSV solves one of the systems of equations */
+
+/* A*x = b, or A'*x = b, */
+
+/* where b and x are n element vectors and A is an n by n unit, or */
+/* non-unit, upper or lower triangular matrix. */
+
+/* No test for singularity or near-singularity is included in this */
+/* routine. Such tests must be performed before calling this routine. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the equations to be solved as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' A*x = b. */
+
+/* TRANS = 'T' or 't' A'*x = b. */
+
+/* TRANS = 'C' or 'c' A'*x = b. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* A - REAL array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular matrix and the strictly lower triangular part of */
+/* A is not referenced. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular matrix and the strictly upper triangular part of */
+/* A is not referenced. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced either, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+/* X - REAL array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element right-hand side vector b. On exit, X is overwritten */
+/* with the solution vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*lda < max(1,*n)) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ }
+ if (info != 0) {
+ xerbla_("STRSV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through A. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x := inv( A )*x. */
+
+ if (lsame_(uplo, "U")) {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ if (x[j] != 0.f) {
+ if (nounit) {
+ x[j] /= a[j + j * a_dim1];
+ }
+ temp = x[j];
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ x[i__] -= temp * a[i__ + j * a_dim1];
+/* L10: */
+ }
+ }
+/* L20: */
+ }
+ } else {
+ jx = kx + (*n - 1) * *incx;
+ for (j = *n; j >= 1; --j) {
+ if (x[jx] != 0.f) {
+ if (nounit) {
+ x[jx] /= a[j + j * a_dim1];
+ }
+ temp = x[jx];
+ ix = jx;
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ ix -= *incx;
+ x[ix] -= temp * a[i__ + j * a_dim1];
+/* L30: */
+ }
+ }
+ jx -= *incx;
+/* L40: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[j] != 0.f) {
+ if (nounit) {
+ x[j] /= a[j + j * a_dim1];
+ }
+ temp = x[j];
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ x[i__] -= temp * a[i__ + j * a_dim1];
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (x[jx] != 0.f) {
+ if (nounit) {
+ x[jx] /= a[j + j * a_dim1];
+ }
+ temp = x[jx];
+ ix = jx;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ ix += *incx;
+ x[ix] -= temp * a[i__ + j * a_dim1];
+/* L70: */
+ }
+ }
+ jx += *incx;
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := inv( A' )*x. */
+
+ if (lsame_(uplo, "U")) {
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = x[j];
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp -= a[i__ + j * a_dim1] * x[i__];
+/* L90: */
+ }
+ if (nounit) {
+ temp /= a[j + j * a_dim1];
+ }
+ x[j] = temp;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp = x[jx];
+ ix = kx;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp -= a[i__ + j * a_dim1] * x[ix];
+ ix += *incx;
+/* L110: */
+ }
+ if (nounit) {
+ temp /= a[j + j * a_dim1];
+ }
+ x[jx] = temp;
+ jx += *incx;
+/* L120: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ temp = x[j];
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ temp -= a[i__ + j * a_dim1] * x[i__];
+/* L130: */
+ }
+ if (nounit) {
+ temp /= a[j + j * a_dim1];
+ }
+ x[j] = temp;
+/* L140: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ temp = x[jx];
+ ix = kx;
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ temp -= a[i__ + j * a_dim1] * x[ix];
+ ix -= *incx;
+/* L150: */
+ }
+ if (nounit) {
+ temp /= a[j + j * a_dim1];
+ }
+ x[jx] = temp;
+ jx -= *incx;
+/* L160: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of STRSV . */
+
+} /* strsv_ */
diff --git a/BLAS/SRC/xerbla.c b/BLAS/SRC/xerbla.c
new file mode 100644
index 0000000..2d7baf5
--- /dev/null
+++ b/BLAS/SRC/xerbla.c
@@ -0,0 +1,76 @@
+/* xerbla.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int xerbla_(char *srname, integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ** On entry to \002,a,\002 parameter num"
+ "ber \002,i2,\002 had \002,\002an illegal value\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), i_len_trim(char *, ftnlen), do_fio(integer *,
+ char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 6, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK auxiliary routine (preliminary version) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* XERBLA is an error handler for the LAPACK routines. */
+/* It is called by an LAPACK routine if an input parameter has an */
+/* invalid value. A message is printed and execution stops. */
+
+/* Installers may consider modifying the STOP statement in order to */
+/* call system-specific exception-handling facilities. */
+
+/* Arguments */
+/* ========= */
+
+/* SRNAME (input) CHARACTER*(*) */
+/* The name of the routine which called XERBLA. */
+
+/* INFO (input) INTEGER */
+/* The position of the invalid parameter in the parameter list */
+/* of the calling routine. */
+
+/* ===================================================================== */
+
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ printf("** On entry to %6s, parameter number %2i had an illegal value\n",
+ srname, *info);
+
+
+/* End of XERBLA */
+
+ return 0;
+} /* xerbla_ */
diff --git a/BLAS/SRC/xerbla_array.c b/BLAS/SRC/xerbla_array.c
new file mode 100644
index 0000000..d4e4c24
--- /dev/null
+++ b/BLAS/SRC/xerbla_array.c
@@ -0,0 +1,102 @@
+/* xerbla_array.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int xerbla_array__(char *srname_array__, integer *
+ srname_len__, integer *info, ftnlen srname_array_len)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer i_len(char *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ char srname[32];
+
+
+/* -- LAPACK auxiliary routine (version 3.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
+/* September 19, 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* XERBLA_ARRAY assists other languages in calling XERBLA, the LAPACK */
+/* and BLAS error handler. Rather than taking a Fortran string argument */
+/* as the function's name, XERBLA_ARRAY takes an array of single */
+/* characters along with the array's length. XERBLA_ARRAY then copies */
+/* up to 32 characters of that array into a Fortran string and passes */
+/* that to XERBLA. If called with a non-positive SRNAME_LEN, */
+/* XERBLA_ARRAY will call XERBLA with a string of all blank characters. */
+
+/* Say some macro or other device makes XERBLA_ARRAY available to C99 */
+/* by a name lapack_xerbla and with a common Fortran calling convention. */
+/* Then a C99 program could invoke XERBLA via: */
+/* { */
+/* int flen = strlen(__func__); */
+/* lapack_xerbla(__func__, &flen, &info); */
+/* } */
+
+/* Providing XERBLA_ARRAY is not necessary for intercepting LAPACK */
+/* errors. XERBLA_ARRAY calls XERBLA. */
+
+/* Arguments */
+/* ========= */
+
+/* SRNAME_ARRAY (input) CHARACTER(1) array, dimension (SRNAME_LEN) */
+/* The name of the routine which called XERBLA_ARRAY. */
+
+/* SRNAME_LEN (input) INTEGER */
+/* The length of the name in SRNAME_ARRAY. */
+
+/* INFO (input) INTEGER */
+/* The position of the invalid parameter in the parameter list */
+/* of the calling routine. */
+
+/* ===================================================================== */
+
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ --srname_array__;
+
+ /* Function Body */
+ s_copy(srname, "", (ftnlen)32, (ftnlen)0);
+/* Computing MIN */
+ i__2 = *srname_len__, i__3 = i_len(srname, (ftnlen)32);
+ i__1 = min(i__2,i__3);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ *(unsigned char *)&srname[i__ - 1] = *(unsigned char *)&
+ srname_array__[i__];
+ }
+ xerbla_(srname, info);
+ return 0;
+} /* xerbla_array__ */
diff --git a/BLAS/SRC/zaxpy.c b/BLAS/SRC/zaxpy.c
new file mode 100644
index 0000000..1bbebba
--- /dev/null
+++ b/BLAS/SRC/zaxpy.c
@@ -0,0 +1,99 @@
+/* zaxpy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zaxpy_(integer *n, doublecomplex *za, doublecomplex *zx,
+ integer *incx, doublecomplex *zy, integer *incy)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublecomplex z__1, z__2;
+
+ /* Local variables */
+ integer i__, ix, iy;
+ extern doublereal dcabs1_(doublecomplex *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* constant times a vector plus a vector. */
+/* jack dongarra, 3/11/78. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --zy;
+ --zx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ if (dcabs1_(za) == 0.) {
+ return 0;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* code for unequal increments or equal increments */
+/* not equal to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ i__3 = iy;
+ i__4 = ix;
+ z__2.r = za->r * zx[i__4].r - za->i * zx[i__4].i, z__2.i = za->r * zx[
+ i__4].i + za->i * zx[i__4].r;
+ z__1.r = zy[i__3].r + z__2.r, z__1.i = zy[i__3].i + z__2.i;
+ zy[i__2].r = z__1.r, zy[i__2].i = z__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ return 0;
+
+/* code for both increments equal to 1 */
+
+L20:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__2.r = za->r * zx[i__4].r - za->i * zx[i__4].i, z__2.i = za->r * zx[
+ i__4].i + za->i * zx[i__4].r;
+ z__1.r = zy[i__3].r + z__2.r, z__1.i = zy[i__3].i + z__2.i;
+ zy[i__2].r = z__1.r, zy[i__2].i = z__1.i;
+/* L30: */
+ }
+ return 0;
+} /* zaxpy_ */
diff --git a/BLAS/SRC/zcopy.c b/BLAS/SRC/zcopy.c
new file mode 100644
index 0000000..5999a69
--- /dev/null
+++ b/BLAS/SRC/zcopy.c
@@ -0,0 +1,85 @@
+/* zcopy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zcopy_(integer *n, doublecomplex *zx, integer *incx,
+ doublecomplex *zy, integer *incy)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, ix, iy;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* copies a vector, x, to a vector, y. */
+/* jack dongarra, linpack, 4/11/78. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+ /* Parameter adjustments */
+ --zy;
+ --zx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* code for unequal increments or equal increments */
+/* not equal to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ i__3 = ix;
+ zy[i__2].r = zx[i__3].r, zy[i__2].i = zx[i__3].i;
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ return 0;
+
+/* code for both increments equal to 1 */
+
+L20:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ zy[i__2].r = zx[i__3].r, zy[i__2].i = zx[i__3].i;
+/* L30: */
+ }
+ return 0;
+} /* zcopy_ */
diff --git a/BLAS/SRC/zdotc.c b/BLAS/SRC/zdotc.c
new file mode 100644
index 0000000..383b2c2
--- /dev/null
+++ b/BLAS/SRC/zdotc.c
@@ -0,0 +1,105 @@
+/* zdotc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Double Complex */ VOID zdotc_(doublecomplex * ret_val, integer *n,
+ doublecomplex *zx, integer *incx, doublecomplex *zy, integer *incy)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, ix, iy;
+ doublecomplex ztemp;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDOTC forms the dot product of a vector. */
+
+/* Further Details */
+/* =============== */
+
+/* jack dongarra, 3/11/78. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --zy;
+ --zx;
+
+ /* Function Body */
+ ztemp.r = 0., ztemp.i = 0.;
+ ret_val->r = 0., ret_val->i = 0.;
+ if (*n <= 0) {
+ return ;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* code for unequal increments or equal increments */
+/* not equal to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d_cnjg(&z__3, &zx[ix]);
+ i__2 = iy;
+ z__2.r = z__3.r * zy[i__2].r - z__3.i * zy[i__2].i, z__2.i = z__3.r *
+ zy[i__2].i + z__3.i * zy[i__2].r;
+ z__1.r = ztemp.r + z__2.r, z__1.i = ztemp.i + z__2.i;
+ ztemp.r = z__1.r, ztemp.i = z__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ ret_val->r = ztemp.r, ret_val->i = ztemp.i;
+ return ;
+
+/* code for both increments equal to 1 */
+
+L20:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d_cnjg(&z__3, &zx[i__]);
+ i__2 = i__;
+ z__2.r = z__3.r * zy[i__2].r - z__3.i * zy[i__2].i, z__2.i = z__3.r *
+ zy[i__2].i + z__3.i * zy[i__2].r;
+ z__1.r = ztemp.r + z__2.r, z__1.i = ztemp.i + z__2.i;
+ ztemp.r = z__1.r, ztemp.i = z__1.i;
+/* L30: */
+ }
+ ret_val->r = ztemp.r, ret_val->i = ztemp.i;
+ return ;
+} /* zdotc_ */
diff --git a/BLAS/SRC/zdotu.c b/BLAS/SRC/zdotu.c
new file mode 100644
index 0000000..e32993a
--- /dev/null
+++ b/BLAS/SRC/zdotu.c
@@ -0,0 +1,100 @@
+/* zdotu.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Double Complex */ VOID zdotu_(doublecomplex * ret_val, integer *n,
+ doublecomplex *zx, integer *incx, doublecomplex *zy, integer *incy)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublecomplex z__1, z__2;
+
+ /* Local variables */
+ integer i__, ix, iy;
+ doublecomplex ztemp;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDOTU forms the dot product of two vectors. */
+
+/* Further Details */
+/* =============== */
+
+/* jack dongarra, 3/11/78. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+/* .. Local Scalars .. */
+/* .. */
+ /* Parameter adjustments */
+ --zy;
+ --zx;
+
+ /* Function Body */
+ ztemp.r = 0., ztemp.i = 0.;
+ ret_val->r = 0., ret_val->i = 0.;
+ if (*n <= 0) {
+ return ;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* code for unequal increments or equal increments */
+/* not equal to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ix;
+ i__3 = iy;
+ z__2.r = zx[i__2].r * zy[i__3].r - zx[i__2].i * zy[i__3].i, z__2.i =
+ zx[i__2].r * zy[i__3].i + zx[i__2].i * zy[i__3].r;
+ z__1.r = ztemp.r + z__2.r, z__1.i = ztemp.i + z__2.i;
+ ztemp.r = z__1.r, ztemp.i = z__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ ret_val->r = ztemp.r, ret_val->i = ztemp.i;
+ return ;
+
+/* code for both increments equal to 1 */
+
+L20:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ z__2.r = zx[i__2].r * zy[i__3].r - zx[i__2].i * zy[i__3].i, z__2.i =
+ zx[i__2].r * zy[i__3].i + zx[i__2].i * zy[i__3].r;
+ z__1.r = ztemp.r + z__2.r, z__1.i = ztemp.i + z__2.i;
+ ztemp.r = z__1.r, ztemp.i = z__1.i;
+/* L30: */
+ }
+ ret_val->r = ztemp.r, ret_val->i = ztemp.i;
+ return ;
+} /* zdotu_ */
diff --git a/BLAS/SRC/zdrot.c b/BLAS/SRC/zdrot.c
new file mode 100644
index 0000000..8101687
--- /dev/null
+++ b/BLAS/SRC/zdrot.c
@@ -0,0 +1,153 @@
+/* zdrot.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zdrot_(integer *n, doublecomplex *cx, integer *incx,
+ doublecomplex *cy, integer *incy, doublereal *c__, doublereal *s)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Local variables */
+ integer i__, ix, iy;
+ doublecomplex ctemp;
+
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Applies a plane rotation, where the cos and sin (c and s) are real */
+/* and the vectors cx and cy are complex. */
+/* jack dongarra, linpack, 3/11/78. */
+
+/* Arguments */
+/* ========== */
+
+/* N (input) INTEGER */
+/* On entry, N specifies the order of the vectors cx and cy. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* CX (input) COMPLEX*16 array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array CX must contain the n */
+/* element vector cx. On exit, CX is overwritten by the updated */
+/* vector cx. */
+
+/* INCX (input) INTEGER */
+/* On entry, INCX specifies the increment for the elements of */
+/* CX. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* CY (input) COMPLEX*16 array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array CY must contain the n */
+/* element vector cy. On exit, CY is overwritten by the updated */
+/* vector cy. */
+
+/* INCY (input) INTEGER */
+/* On entry, INCY specifies the increment for the elements of */
+/* CY. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* C (input) DOUBLE PRECISION */
+/* On entry, C specifies the cosine, cos. */
+/* Unchanged on exit. */
+
+/* S (input) DOUBLE PRECISION */
+/* On entry, S specifies the sine, sin. */
+/* Unchanged on exit. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --cy;
+ --cx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* code for unequal increments or equal increments not equal */
+/* to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ix;
+ z__2.r = *c__ * cx[i__2].r, z__2.i = *c__ * cx[i__2].i;
+ i__3 = iy;
+ z__3.r = *s * cy[i__3].r, z__3.i = *s * cy[i__3].i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__2 = iy;
+ i__3 = iy;
+ z__2.r = *c__ * cy[i__3].r, z__2.i = *c__ * cy[i__3].i;
+ i__4 = ix;
+ z__3.r = *s * cx[i__4].r, z__3.i = *s * cx[i__4].i;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ cy[i__2].r = z__1.r, cy[i__2].i = z__1.i;
+ i__2 = ix;
+ cx[i__2].r = ctemp.r, cx[i__2].i = ctemp.i;
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ return 0;
+
+/* code for both increments equal to 1 */
+
+L20:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ z__2.r = *c__ * cx[i__2].r, z__2.i = *c__ * cx[i__2].i;
+ i__3 = i__;
+ z__3.r = *s * cy[i__3].r, z__3.i = *s * cy[i__3].i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__2 = i__;
+ i__3 = i__;
+ z__2.r = *c__ * cy[i__3].r, z__2.i = *c__ * cy[i__3].i;
+ i__4 = i__;
+ z__3.r = *s * cx[i__4].r, z__3.i = *s * cx[i__4].i;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ cy[i__2].r = z__1.r, cy[i__2].i = z__1.i;
+ i__2 = i__;
+ cx[i__2].r = ctemp.r, cx[i__2].i = ctemp.i;
+/* L30: */
+ }
+ return 0;
+} /* zdrot_ */
diff --git a/BLAS/SRC/zdscal.c b/BLAS/SRC/zdscal.c
new file mode 100644
index 0000000..9cb7030
--- /dev/null
+++ b/BLAS/SRC/zdscal.c
@@ -0,0 +1,85 @@
+/* zdscal.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zdscal_(integer *n, doublereal *da, doublecomplex *zx,
+ integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublecomplex z__1, z__2;
+
+ /* Local variables */
+ integer i__, ix;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* scales a vector by a constant. */
+/* jack dongarra, 3/11/78. */
+/* modified 3/93 to return if incx .le. 0. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ /* Parameter adjustments */
+ --zx;
+
+ /* Function Body */
+ if (*n <= 0 || *incx <= 0) {
+ return 0;
+ }
+ if (*incx == 1) {
+ goto L20;
+ }
+
+/* code for increment not equal to 1 */
+
+ ix = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ix;
+ z__2.r = *da, z__2.i = 0.;
+ i__3 = ix;
+ z__1.r = z__2.r * zx[i__3].r - z__2.i * zx[i__3].i, z__1.i = z__2.r *
+ zx[i__3].i + z__2.i * zx[i__3].r;
+ zx[i__2].r = z__1.r, zx[i__2].i = z__1.i;
+ ix += *incx;
+/* L10: */
+ }
+ return 0;
+
+/* code for increment equal to 1 */
+
+L20:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ z__2.r = *da, z__2.i = 0.;
+ i__3 = i__;
+ z__1.r = z__2.r * zx[i__3].r - z__2.i * zx[i__3].i, z__1.i = z__2.r *
+ zx[i__3].i + z__2.i * zx[i__3].r;
+ zx[i__2].r = z__1.r, zx[i__2].i = z__1.i;
+/* L30: */
+ }
+ return 0;
+} /* zdscal_ */
diff --git a/BLAS/SRC/zgbmv.c b/BLAS/SRC/zgbmv.c
new file mode 100644
index 0000000..22ae8dd
--- /dev/null
+++ b/BLAS/SRC/zgbmv.c
@@ -0,0 +1,478 @@
+/* zgbmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zgbmv_(char *trans, integer *m, integer *n, integer *kl,
+ integer *ku, doublecomplex *alpha, doublecomplex *a, integer *lda,
+ doublecomplex *x, integer *incx, doublecomplex *beta, doublecomplex *
+ y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, ix, iy, jx, jy, kx, ky, kup1, info;
+ doublecomplex temp;
+ integer lenx, leny;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical noconj;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGBMV performs one of the matrix-vector operations */
+
+/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or */
+
+/* y := alpha*conjg( A' )*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are vectors and A is an */
+/* m by n band matrix, with kl sub-diagonals and ku super-diagonals. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */
+
+/* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. */
+
+/* TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix A. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* KL - INTEGER. */
+/* On entry, KL specifies the number of sub-diagonals of the */
+/* matrix A. KL must satisfy 0 .le. KL. */
+/* Unchanged on exit. */
+
+/* KU - INTEGER. */
+/* On entry, KU specifies the number of super-diagonals of the */
+/* matrix A. KU must satisfy 0 .le. KU. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX*16 . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */
+/* Before entry, the leading ( kl + ku + 1 ) by n part of the */
+/* array A must contain the matrix of coefficients, supplied */
+/* column by column, with the leading diagonal of the matrix in */
+/* row ( ku + 1 ) of the array, the first super-diagonal */
+/* starting at position 2 in row ku, the first sub-diagonal */
+/* starting at position 1 in row ( ku + 2 ), and so on. */
+/* Elements in the array A that do not correspond to elements */
+/* in the band matrix (such as the top left ku by ku triangle) */
+/* are not referenced. */
+/* The following program segment will transfer a band matrix */
+/* from conventional full matrix storage to band storage: */
+
+/* DO 20, J = 1, N */
+/* K = KU + 1 - J */
+/* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) */
+/* A( K + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* ( kl + ku + 1 ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX*16 array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX*16 . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - COMPLEX*16 array of DIMENSION at least */
+/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
+/* Before entry, the incremented array Y must contain the */
+/* vector y. On exit, Y is overwritten by the updated vector y. */
+
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C")
+ ) {
+ info = 1;
+ } else if (*m < 0) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*kl < 0) {
+ info = 4;
+ } else if (*ku < 0) {
+ info = 5;
+ } else if (*lda < *kl + *ku + 1) {
+ info = 8;
+ } else if (*incx == 0) {
+ info = 10;
+ } else if (*incy == 0) {
+ info = 13;
+ }
+ if (info != 0) {
+ xerbla_("ZGBMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r ==
+ 1. && beta->i == 0.)) {
+ return 0;
+ }
+
+ noconj = lsame_(trans, "T");
+
+/* Set LENX and LENY, the lengths of the vectors x and y, and set */
+/* up the start points in X and Y. */
+
+ if (lsame_(trans, "N")) {
+ lenx = *n;
+ leny = *m;
+ } else {
+ lenx = *m;
+ leny = *n;
+ }
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (lenx - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (leny - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through the band part of A. */
+
+/* First form y := beta*y. */
+
+ if (beta->r != 1. || beta->i != 0.) {
+ if (*incy == 1) {
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ y[i__2].r = 0., y[i__2].i = 0.;
+/* L10: */
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ y[i__2].r = 0., y[i__2].i = 0.;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ i__3 = iy;
+ z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (alpha->r == 0. && alpha->i == 0.) {
+ return 0;
+ }
+ kup1 = *ku + 1;
+ if (lsame_(trans, "N")) {
+
+/* Form y := alpha*A*x + y. */
+
+ jx = kx;
+ if (*incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ i__2 = jx;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ k = kup1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__4 = min(i__5,i__6);
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__5 = k + i__ + j * a_dim1;
+ z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ z__2.i = temp.r * a[i__5].i + temp.i * a[i__5]
+ .r;
+ z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i +
+ z__2.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+/* L50: */
+ }
+ }
+ jx += *incx;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = jx;
+ if (x[i__4].r != 0. || x[i__4].i != 0.) {
+ i__4 = jx;
+ z__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i,
+ z__1.i = alpha->r * x[i__4].i + alpha->i * x[i__4]
+ .r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ iy = ky;
+ k = kup1 - j;
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__3 = min(i__5,i__6);
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ i__4 = iy;
+ i__2 = iy;
+ i__5 = k + i__ + j * a_dim1;
+ z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ z__2.i = temp.r * a[i__5].i + temp.i * a[i__5]
+ .r;
+ z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i +
+ z__2.i;
+ y[i__4].r = z__1.r, y[i__4].i = z__1.i;
+ iy += *incy;
+/* L70: */
+ }
+ }
+ jx += *incx;
+ if (j > *ku) {
+ ky += *incy;
+ }
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. */
+
+ jy = ky;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp.r = 0., temp.i = 0.;
+ k = kup1 - j;
+ if (noconj) {
+/* Computing MAX */
+ i__3 = 1, i__4 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__2 = min(i__5,i__6);
+ for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) {
+ i__3 = k + i__ + j * a_dim1;
+ i__4 = i__;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4]
+ .i, z__2.i = a[i__3].r * x[i__4].i + a[i__3]
+ .i * x[i__4].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L90: */
+ }
+ } else {
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__4 = min(i__5,i__6);
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ d_cnjg(&z__3, &a[k + i__ + j * a_dim1]);
+ i__2 = i__;
+ z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i,
+ z__2.i = z__3.r * x[i__2].i + z__3.i * x[i__2]
+ .r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L100: */
+ }
+ }
+ i__4 = jy;
+ i__2 = jy;
+ z__2.r = alpha->r * temp.r - alpha->i * temp.i, z__2.i =
+ alpha->r * temp.i + alpha->i * temp.r;
+ z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i;
+ y[i__4].r = z__1.r, y[i__4].i = z__1.i;
+ jy += *incy;
+/* L110: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp.r = 0., temp.i = 0.;
+ ix = kx;
+ k = kup1 - j;
+ if (noconj) {
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__3 = min(i__5,i__6);
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ i__4 = k + i__ + j * a_dim1;
+ i__2 = ix;
+ z__2.r = a[i__4].r * x[i__2].r - a[i__4].i * x[i__2]
+ .i, z__2.i = a[i__4].r * x[i__2].i + a[i__4]
+ .i * x[i__2].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix += *incx;
+/* L120: */
+ }
+ } else {
+/* Computing MAX */
+ i__3 = 1, i__4 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__2 = min(i__5,i__6);
+ for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) {
+ d_cnjg(&z__3, &a[k + i__ + j * a_dim1]);
+ i__3 = ix;
+ z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
+ z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3]
+ .r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix += *incx;
+/* L130: */
+ }
+ }
+ i__2 = jy;
+ i__3 = jy;
+ z__2.r = alpha->r * temp.r - alpha->i * temp.i, z__2.i =
+ alpha->r * temp.i + alpha->i * temp.r;
+ z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ jy += *incy;
+ if (j > *ku) {
+ kx += *incx;
+ }
+/* L140: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZGBMV . */
+
+} /* zgbmv_ */
diff --git a/BLAS/SRC/zgemm.c b/BLAS/SRC/zgemm.c
new file mode 100644
index 0000000..f43a606
--- /dev/null
+++ b/BLAS/SRC/zgemm.c
@@ -0,0 +1,698 @@
+/* zgemm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zgemm_(char *transa, char *transb, integer *m, integer *
+ n, integer *k, doublecomplex *alpha, doublecomplex *a, integer *lda,
+ doublecomplex *b, integer *ldb, doublecomplex *beta, doublecomplex *
+ c__, integer *ldc)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, l, info;
+ logical nota, notb;
+ doublecomplex temp;
+ logical conja, conjb;
+ integer ncola;
+ extern logical lsame_(char *, char *);
+ integer nrowa, nrowb;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGEMM performs one of the matrix-matrix operations */
+
+/* C := alpha*op( A )*op( B ) + beta*C, */
+
+/* where op( X ) is one of */
+
+/* op( X ) = X or op( X ) = X' or op( X ) = conjg( X' ), */
+
+/* alpha and beta are scalars, and A, B and C are matrices, with op( A ) */
+/* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANSA - CHARACTER*1. */
+/* On entry, TRANSA specifies the form of op( A ) to be used in */
+/* the matrix multiplication as follows: */
+
+/* TRANSA = 'N' or 'n', op( A ) = A. */
+
+/* TRANSA = 'T' or 't', op( A ) = A'. */
+
+/* TRANSA = 'C' or 'c', op( A ) = conjg( A' ). */
+
+/* Unchanged on exit. */
+
+/* TRANSB - CHARACTER*1. */
+/* On entry, TRANSB specifies the form of op( B ) to be used in */
+/* the matrix multiplication as follows: */
+
+/* TRANSB = 'N' or 'n', op( B ) = B. */
+
+/* TRANSB = 'T' or 't', op( B ) = B'. */
+
+/* TRANSB = 'C' or 'c', op( B ) = conjg( B' ). */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix */
+/* op( A ) and of the matrix C. M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix */
+/* op( B ) and the number of columns of the matrix C. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry, K specifies the number of columns of the matrix */
+/* op( A ) and the number of rows of the matrix op( B ). K must */
+/* be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX*16 . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is */
+/* k when TRANSA = 'N' or 'n', and is m otherwise. */
+/* Before entry with TRANSA = 'N' or 'n', the leading m by k */
+/* part of the array A must contain the matrix A, otherwise */
+/* the leading k by m part of the array A must contain the */
+/* matrix A. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When TRANSA = 'N' or 'n' then */
+/* LDA must be at least max( 1, m ), otherwise LDA must be at */
+/* least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is */
+/* n when TRANSB = 'N' or 'n', and is k otherwise. */
+/* Before entry with TRANSB = 'N' or 'n', the leading k by n */
+/* part of the array B must contain the matrix B, otherwise */
+/* the leading n by k part of the array B must contain the */
+/* matrix B. */
+/* Unchanged on exit. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. When TRANSB = 'N' or 'n' then */
+/* LDB must be at least max( 1, k ), otherwise LDB must be at */
+/* least max( 1, n ). */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX*16 . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then C need not be set on input. */
+/* Unchanged on exit. */
+
+/* C - COMPLEX*16 array of DIMENSION ( LDC, n ). */
+/* Before entry, the leading m by n part of the array C must */
+/* contain the matrix C, except when beta is zero, in which */
+/* case C need not be set on entry. */
+/* On exit, the array C is overwritten by the m by n matrix */
+/* ( alpha*op( A )*op( B ) + beta*C ). */
+
+/* LDC - INTEGER. */
+/* On entry, LDC specifies the first dimension of C as declared */
+/* in the calling (sub) program. LDC must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Set NOTA and NOTB as true if A and B respectively are not */
+/* conjugated or transposed, set CONJA and CONJB as true if A and */
+/* B respectively are to be transposed but not conjugated and set */
+/* NROWA, NCOLA and NROWB as the number of rows and columns of A */
+/* and the number of rows of B respectively. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ nota = lsame_(transa, "N");
+ notb = lsame_(transb, "N");
+ conja = lsame_(transa, "C");
+ conjb = lsame_(transb, "C");
+ if (nota) {
+ nrowa = *m;
+ ncola = *k;
+ } else {
+ nrowa = *k;
+ ncola = *m;
+ }
+ if (notb) {
+ nrowb = *k;
+ } else {
+ nrowb = *n;
+ }
+
+/* Test the input parameters. */
+
+ info = 0;
+ if (! nota && ! conja && ! lsame_(transa, "T")) {
+ info = 1;
+ } else if (! notb && ! conjb && ! lsame_(transb, "T")) {
+ info = 2;
+ } else if (*m < 0) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*k < 0) {
+ info = 5;
+ } else if (*lda < max(1,nrowa)) {
+ info = 8;
+ } else if (*ldb < max(1,nrowb)) {
+ info = 10;
+ } else if (*ldc < max(1,*m)) {
+ info = 13;
+ }
+ if (info != 0) {
+ xerbla_("ZGEMM ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || (alpha->r == 0. && alpha->i == 0. || *k == 0) &&
+ (beta->r == 1. && beta->i == 0.)) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (alpha->r == 0. && alpha->i == 0.) {
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0., c__[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
+ z__1.i = beta->r * c__[i__4].i + beta->i * c__[
+ i__4].r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (notb) {
+ if (nota) {
+
+/* Form C := alpha*A*B + beta*C. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (beta->r == 0. && beta->i == 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0., c__[i__3].i = 0.;
+/* L50: */
+ }
+ } else if (beta->r != 1. || beta->i != 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, z__1.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L60: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = l + j * b_dim1;
+ if (b[i__3].r != 0. || b[i__3].i != 0.) {
+ i__3 = l + j * b_dim1;
+ z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
+ z__1.i = alpha->r * b[i__3].i + alpha->i * b[
+ i__3].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + l * a_dim1;
+ z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
+ z__2.i = temp.r * a[i__6].i + temp.i * a[
+ i__6].r;
+ z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5]
+ .i + z__2.i;
+ c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
+/* L70: */
+ }
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+ } else if (conja) {
+
+/* Form C := alpha*conjg( A' )*B + beta*C. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp.r = 0., temp.i = 0.;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ d_cnjg(&z__3, &a[l + i__ * a_dim1]);
+ i__4 = l + j * b_dim1;
+ z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i,
+ z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4]
+ .r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L100: */
+ }
+ if (beta->r == 0. && beta->i == 0.) {
+ i__3 = i__ + j * c_dim1;
+ z__1.r = alpha->r * temp.r - alpha->i * temp.i,
+ z__1.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ z__2.r = alpha->r * temp.r - alpha->i * temp.i,
+ z__2.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ i__4 = i__ + j * c_dim1;
+ z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, z__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+ } else {
+
+/* Form C := alpha*A'*B + beta*C */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp.r = 0., temp.i = 0.;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ i__4 = l + i__ * a_dim1;
+ i__5 = l + j * b_dim1;
+ z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5]
+ .i, z__2.i = a[i__4].r * b[i__5].i + a[i__4]
+ .i * b[i__5].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L130: */
+ }
+ if (beta->r == 0. && beta->i == 0.) {
+ i__3 = i__ + j * c_dim1;
+ z__1.r = alpha->r * temp.r - alpha->i * temp.i,
+ z__1.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ z__2.r = alpha->r * temp.r - alpha->i * temp.i,
+ z__2.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ i__4 = i__ + j * c_dim1;
+ z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, z__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+ }
+ } else if (nota) {
+ if (conjb) {
+
+/* Form C := alpha*A*conjg( B' ) + beta*C. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (beta->r == 0. && beta->i == 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0., c__[i__3].i = 0.;
+/* L160: */
+ }
+ } else if (beta->r != 1. || beta->i != 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, z__1.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L170: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = j + l * b_dim1;
+ if (b[i__3].r != 0. || b[i__3].i != 0.) {
+ d_cnjg(&z__2, &b[j + l * b_dim1]);
+ z__1.r = alpha->r * z__2.r - alpha->i * z__2.i,
+ z__1.i = alpha->r * z__2.i + alpha->i *
+ z__2.r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + l * a_dim1;
+ z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
+ z__2.i = temp.r * a[i__6].i + temp.i * a[
+ i__6].r;
+ z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5]
+ .i + z__2.i;
+ c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
+/* L180: */
+ }
+ }
+/* L190: */
+ }
+/* L200: */
+ }
+ } else {
+
+/* Form C := alpha*A*B' + beta*C */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (beta->r == 0. && beta->i == 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0., c__[i__3].i = 0.;
+/* L210: */
+ }
+ } else if (beta->r != 1. || beta->i != 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, z__1.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L220: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = j + l * b_dim1;
+ if (b[i__3].r != 0. || b[i__3].i != 0.) {
+ i__3 = j + l * b_dim1;
+ z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
+ z__1.i = alpha->r * b[i__3].i + alpha->i * b[
+ i__3].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + l * a_dim1;
+ z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
+ z__2.i = temp.r * a[i__6].i + temp.i * a[
+ i__6].r;
+ z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5]
+ .i + z__2.i;
+ c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
+/* L230: */
+ }
+ }
+/* L240: */
+ }
+/* L250: */
+ }
+ }
+ } else if (conja) {
+ if (conjb) {
+
+/* Form C := alpha*conjg( A' )*conjg( B' ) + beta*C. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp.r = 0., temp.i = 0.;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ d_cnjg(&z__3, &a[l + i__ * a_dim1]);
+ d_cnjg(&z__4, &b[j + l * b_dim1]);
+ z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i =
+ z__3.r * z__4.i + z__3.i * z__4.r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L260: */
+ }
+ if (beta->r == 0. && beta->i == 0.) {
+ i__3 = i__ + j * c_dim1;
+ z__1.r = alpha->r * temp.r - alpha->i * temp.i,
+ z__1.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ z__2.r = alpha->r * temp.r - alpha->i * temp.i,
+ z__2.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ i__4 = i__ + j * c_dim1;
+ z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, z__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ }
+/* L270: */
+ }
+/* L280: */
+ }
+ } else {
+
+/* Form C := alpha*conjg( A' )*B' + beta*C */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp.r = 0., temp.i = 0.;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ d_cnjg(&z__3, &a[l + i__ * a_dim1]);
+ i__4 = j + l * b_dim1;
+ z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i,
+ z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4]
+ .r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L290: */
+ }
+ if (beta->r == 0. && beta->i == 0.) {
+ i__3 = i__ + j * c_dim1;
+ z__1.r = alpha->r * temp.r - alpha->i * temp.i,
+ z__1.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ z__2.r = alpha->r * temp.r - alpha->i * temp.i,
+ z__2.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ i__4 = i__ + j * c_dim1;
+ z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, z__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ }
+/* L300: */
+ }
+/* L310: */
+ }
+ }
+ } else {
+ if (conjb) {
+
+/* Form C := alpha*A'*conjg( B' ) + beta*C */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp.r = 0., temp.i = 0.;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ i__4 = l + i__ * a_dim1;
+ d_cnjg(&z__3, &b[j + l * b_dim1]);
+ z__2.r = a[i__4].r * z__3.r - a[i__4].i * z__3.i,
+ z__2.i = a[i__4].r * z__3.i + a[i__4].i *
+ z__3.r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L320: */
+ }
+ if (beta->r == 0. && beta->i == 0.) {
+ i__3 = i__ + j * c_dim1;
+ z__1.r = alpha->r * temp.r - alpha->i * temp.i,
+ z__1.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ z__2.r = alpha->r * temp.r - alpha->i * temp.i,
+ z__2.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ i__4 = i__ + j * c_dim1;
+ z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, z__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ }
+/* L330: */
+ }
+/* L340: */
+ }
+ } else {
+
+/* Form C := alpha*A'*B' + beta*C */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp.r = 0., temp.i = 0.;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ i__4 = l + i__ * a_dim1;
+ i__5 = j + l * b_dim1;
+ z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5]
+ .i, z__2.i = a[i__4].r * b[i__5].i + a[i__4]
+ .i * b[i__5].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L350: */
+ }
+ if (beta->r == 0. && beta->i == 0.) {
+ i__3 = i__ + j * c_dim1;
+ z__1.r = alpha->r * temp.r - alpha->i * temp.i,
+ z__1.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ z__2.r = alpha->r * temp.r - alpha->i * temp.i,
+ z__2.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ i__4 = i__ + j * c_dim1;
+ z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, z__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ }
+/* L360: */
+ }
+/* L370: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZGEMM . */
+
+} /* zgemm_ */
diff --git a/BLAS/SRC/zgemv.c b/BLAS/SRC/zgemv.c
new file mode 100644
index 0000000..54e8356
--- /dev/null
+++ b/BLAS/SRC/zgemv.c
@@ -0,0 +1,412 @@
+/* zgemv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zgemv_(char *trans, integer *m, integer *n,
+ doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex *
+ x, integer *incx, doublecomplex *beta, doublecomplex *y, integer *
+ incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, ix, iy, jx, jy, kx, ky, info;
+ doublecomplex temp;
+ integer lenx, leny;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical noconj;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGEMV performs one of the matrix-vector operations */
+
+/* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or */
+
+/* y := alpha*conjg( A' )*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are vectors and A is an */
+/* m by n matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. */
+
+/* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. */
+
+/* TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix A. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX*16 . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX*16 array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX*16 . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - COMPLEX*16 array of DIMENSION at least */
+/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
+/* Before entry with BETA non-zero, the incremented array Y */
+/* must contain the vector y. On exit, Y is overwritten by the */
+/* updated vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C")
+ ) {
+ info = 1;
+ } else if (*m < 0) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*lda < max(1,*m)) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ } else if (*incy == 0) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("ZGEMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r ==
+ 1. && beta->i == 0.)) {
+ return 0;
+ }
+
+ noconj = lsame_(trans, "T");
+
+/* Set LENX and LENY, the lengths of the vectors x and y, and set */
+/* up the start points in X and Y. */
+
+ if (lsame_(trans, "N")) {
+ lenx = *n;
+ leny = *m;
+ } else {
+ lenx = *m;
+ leny = *n;
+ }
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (lenx - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (leny - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through A. */
+
+/* First form y := beta*y. */
+
+ if (beta->r != 1. || beta->i != 0.) {
+ if (*incy == 1) {
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ y[i__2].r = 0., y[i__2].i = 0.;
+/* L10: */
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ y[i__2].r = 0., y[i__2].i = 0.;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ i__3 = iy;
+ z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (alpha->r == 0. && alpha->i == 0.) {
+ return 0;
+ }
+ if (lsame_(trans, "N")) {
+
+/* Form y := alpha*A*x + y. */
+
+ jx = kx;
+ if (*incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ i__2 = jx;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ z__2.i = temp.r * a[i__5].i + temp.i * a[i__5]
+ .r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i +
+ z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+/* L50: */
+ }
+ }
+ jx += *incx;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ i__2 = jx;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ iy = ky;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = iy;
+ i__4 = iy;
+ i__5 = i__ + j * a_dim1;
+ z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ z__2.i = temp.r * a[i__5].i + temp.i * a[i__5]
+ .r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i +
+ z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ iy += *incy;
+/* L70: */
+ }
+ }
+ jx += *incx;
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. */
+
+ jy = ky;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp.r = 0., temp.i = 0.;
+ if (noconj) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4]
+ .i, z__2.i = a[i__3].r * x[i__4].i + a[i__3]
+ .i * x[i__4].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L90: */
+ }
+ } else {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ d_cnjg(&z__3, &a[i__ + j * a_dim1]);
+ i__3 = i__;
+ z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
+ z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3]
+ .r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L100: */
+ }
+ }
+ i__2 = jy;
+ i__3 = jy;
+ z__2.r = alpha->r * temp.r - alpha->i * temp.i, z__2.i =
+ alpha->r * temp.i + alpha->i * temp.r;
+ z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ jy += *incy;
+/* L110: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp.r = 0., temp.i = 0.;
+ ix = kx;
+ if (noconj) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = ix;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4]
+ .i, z__2.i = a[i__3].r * x[i__4].i + a[i__3]
+ .i * x[i__4].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix += *incx;
+/* L120: */
+ }
+ } else {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ d_cnjg(&z__3, &a[i__ + j * a_dim1]);
+ i__3 = ix;
+ z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
+ z__2.i = z__3.r * x[i__3].i + z__3.i * x[i__3]
+ .r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix += *incx;
+/* L130: */
+ }
+ }
+ i__2 = jy;
+ i__3 = jy;
+ z__2.r = alpha->r * temp.r - alpha->i * temp.i, z__2.i =
+ alpha->r * temp.i + alpha->i * temp.r;
+ z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ jy += *incy;
+/* L140: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZGEMV . */
+
+} /* zgemv_ */
diff --git a/BLAS/SRC/zgerc.c b/BLAS/SRC/zgerc.c
new file mode 100644
index 0000000..9792945
--- /dev/null
+++ b/BLAS/SRC/zgerc.c
@@ -0,0 +1,218 @@
+/* zgerc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zgerc_(integer *m, integer *n, doublecomplex *alpha,
+ doublecomplex *x, integer *incx, doublecomplex *y, integer *incy,
+ doublecomplex *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, ix, jy, kx, info;
+ doublecomplex temp;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGERC performs the rank 1 operation */
+
+/* A := alpha*x*conjg( y' ) + A, */
+
+/* where alpha is a scalar, x is an m element vector, y is an n element */
+/* vector and A is an m by n matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix A. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX*16 . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X - COMPLEX*16 array of dimension at least */
+/* ( 1 + ( m - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the m */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* Y - COMPLEX*16 array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. */
+/* Unchanged on exit. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. On exit, A is */
+/* overwritten by the updated matrix. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ --y;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ info = 0;
+ if (*m < 0) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ } else if (*incy == 0) {
+ info = 7;
+ } else if (*lda < max(1,*m)) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("ZGERC ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || alpha->r == 0. && alpha->i == 0.) {
+ return 0;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through A. */
+
+ if (*incy > 0) {
+ jy = 1;
+ } else {
+ jy = 1 - (*n - 1) * *incy;
+ }
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jy;
+ if (y[i__2].r != 0. || y[i__2].i != 0.) {
+ d_cnjg(&z__2, &y[jy]);
+ z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i =
+ alpha->r * z__2.i + alpha->i * z__2.r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__;
+ z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, z__2.i =
+ x[i__5].r * temp.i + x[i__5].i * temp.r;
+ z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L10: */
+ }
+ }
+ jy += *incy;
+/* L20: */
+ }
+ } else {
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*m - 1) * *incx;
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jy;
+ if (y[i__2].r != 0. || y[i__2].i != 0.) {
+ d_cnjg(&z__2, &y[jy]);
+ z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i =
+ alpha->r * z__2.i + alpha->i * z__2.r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix = kx;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = ix;
+ z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, z__2.i =
+ x[i__5].r * temp.i + x[i__5].i * temp.r;
+ z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ ix += *incx;
+/* L30: */
+ }
+ }
+ jy += *incy;
+/* L40: */
+ }
+ }
+
+ return 0;
+
+/* End of ZGERC . */
+
+} /* zgerc_ */
diff --git a/BLAS/SRC/zgeru.c b/BLAS/SRC/zgeru.c
new file mode 100644
index 0000000..f0b98c8
--- /dev/null
+++ b/BLAS/SRC/zgeru.c
@@ -0,0 +1,215 @@
+/* zgeru.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zgeru_(integer *m, integer *n, doublecomplex *alpha,
+ doublecomplex *x, integer *incx, doublecomplex *y, integer *incy,
+ doublecomplex *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1, z__2;
+
+ /* Local variables */
+ integer i__, j, ix, jy, kx, info;
+ doublecomplex temp;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGERU performs the rank 1 operation */
+
+/* A := alpha*x*y' + A, */
+
+/* where alpha is a scalar, x is an m element vector, y is an n element */
+/* vector and A is an m by n matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix A. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX*16 . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X - COMPLEX*16 array of dimension at least */
+/* ( 1 + ( m - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the m */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* Y - COMPLEX*16 array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. */
+/* Unchanged on exit. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. On exit, A is */
+/* overwritten by the updated matrix. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ --y;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ info = 0;
+ if (*m < 0) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ } else if (*incy == 0) {
+ info = 7;
+ } else if (*lda < max(1,*m)) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("ZGERU ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || alpha->r == 0. && alpha->i == 0.) {
+ return 0;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through A. */
+
+ if (*incy > 0) {
+ jy = 1;
+ } else {
+ jy = 1 - (*n - 1) * *incy;
+ }
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jy;
+ if (y[i__2].r != 0. || y[i__2].i != 0.) {
+ i__2 = jy;
+ z__1.r = alpha->r * y[i__2].r - alpha->i * y[i__2].i, z__1.i =
+ alpha->r * y[i__2].i + alpha->i * y[i__2].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__;
+ z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, z__2.i =
+ x[i__5].r * temp.i + x[i__5].i * temp.r;
+ z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L10: */
+ }
+ }
+ jy += *incy;
+/* L20: */
+ }
+ } else {
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*m - 1) * *incx;
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jy;
+ if (y[i__2].r != 0. || y[i__2].i != 0.) {
+ i__2 = jy;
+ z__1.r = alpha->r * y[i__2].r - alpha->i * y[i__2].i, z__1.i =
+ alpha->r * y[i__2].i + alpha->i * y[i__2].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix = kx;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = ix;
+ z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i, z__2.i =
+ x[i__5].r * temp.i + x[i__5].i * temp.r;
+ z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i + z__2.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ ix += *incx;
+/* L30: */
+ }
+ }
+ jy += *incy;
+/* L40: */
+ }
+ }
+
+ return 0;
+
+/* End of ZGERU . */
+
+} /* zgeru_ */
diff --git a/BLAS/SRC/zhbmv.c b/BLAS/SRC/zhbmv.c
new file mode 100644
index 0000000..01da701
--- /dev/null
+++ b/BLAS/SRC/zhbmv.c
@@ -0,0 +1,483 @@
+/* zhbmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zhbmv_(char *uplo, integer *n, integer *k, doublecomplex
+ *alpha, doublecomplex *a, integer *lda, doublecomplex *x, integer *
+ incx, doublecomplex *beta, doublecomplex *y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, l, ix, iy, jx, jy, kx, ky, info;
+ doublecomplex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ integer kplus1;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHBMV performs the matrix-vector operation */
+
+/* y := alpha*A*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are n element vectors and */
+/* A is an n by n hermitian band matrix, with k super-diagonals. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the band matrix A is being supplied as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* being supplied. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* being supplied. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry, K specifies the number of super-diagonals of the */
+/* matrix A. K must satisfy 0 .le. K. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX*16 . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
+/* by n part of the array A must contain the upper triangular */
+/* band part of the hermitian matrix, supplied column by */
+/* column, with the leading diagonal of the matrix in row */
+/* ( k + 1 ) of the array, the first super-diagonal starting at */
+/* position 2 in row k, and so on. The top left k by k triangle */
+/* of the array A is not referenced. */
+/* The following program segment will transfer the upper */
+/* triangular part of a hermitian band matrix from conventional */
+/* full matrix storage to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = K + 1 - J */
+/* DO 10, I = MAX( 1, J - K ), J */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
+/* by n part of the array A must contain the lower triangular */
+/* band part of the hermitian matrix, supplied column by */
+/* column, with the leading diagonal of the matrix in row 1 of */
+/* the array, the first sub-diagonal starting at position 1 in */
+/* row 2, and so on. The bottom right k by k triangle of the */
+/* array A is not referenced. */
+/* The following program segment will transfer the lower */
+/* triangular part of a hermitian band matrix from conventional */
+/* full matrix storage to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = 1 - J */
+/* DO 10, I = J, MIN( N, J + K ) */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set and are assumed to be zero. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* ( k + 1 ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX*16 array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX*16 . */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+/* Y - COMPLEX*16 array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the */
+/* vector y. On exit, Y is overwritten by the updated vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*k < 0) {
+ info = 3;
+ } else if (*lda < *k + 1) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ } else if (*incy == 0) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("ZHBMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r == 1. &&
+ beta->i == 0.)) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of the array A */
+/* are accessed sequentially with one pass through A. */
+
+/* First form y := beta*y. */
+
+ if (beta->r != 1. || beta->i != 0.) {
+ if (*incy == 1) {
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ y[i__2].r = 0., y[i__2].i = 0.;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ y[i__2].r = 0., y[i__2].i = 0.;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ i__3 = iy;
+ z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (alpha->r == 0. && alpha->i == 0.) {
+ return 0;
+ }
+ if (lsame_(uplo, "U")) {
+
+/* Form y when upper triangle of A is stored. */
+
+ kplus1 = *k + 1;
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__5 = l + i__ + j * a_dim1;
+ z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
+ i__2 = i__;
+ z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i, z__2.i =
+ z__3.r * x[i__2].i + z__3.i * x[i__2].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L50: */
+ }
+ i__4 = j;
+ i__2 = j;
+ i__3 = kplus1 + j * a_dim1;
+ d__1 = a[i__3].r;
+ z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i;
+ z__2.r = y[i__2].r + z__3.r, z__2.i = y[i__2].i + z__3.i;
+ z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ y[i__4].r = z__1.r, y[i__4].i = z__1.i;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = jx;
+ z__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i, z__1.i =
+ alpha->r * x[i__4].i + alpha->i * x[i__4].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ ix = kx;
+ iy = ky;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *k;
+ i__3 = j - 1;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ i__4 = iy;
+ i__2 = iy;
+ i__5 = l + i__ + j * a_dim1;
+ z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i;
+ y[i__4].r = z__1.r, y[i__4].i = z__1.i;
+ d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
+ i__4 = ix;
+ z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i =
+ z__3.r * x[i__4].i + z__3.i * x[i__4].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ i__3 = jy;
+ i__4 = jy;
+ i__2 = kplus1 + j * a_dim1;
+ d__1 = a[i__2].r;
+ z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i;
+ z__2.r = y[i__4].r + z__3.r, z__2.i = y[i__4].i + z__3.i;
+ z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ jx += *incx;
+ jy += *incy;
+ if (j > *k) {
+ kx += *incx;
+ ky += *incy;
+ }
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y when lower triangle of A is stored. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = j;
+ z__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, z__1.i =
+ alpha->r * x[i__3].i + alpha->i * x[i__3].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ i__3 = j;
+ i__4 = j;
+ i__2 = j * a_dim1 + 1;
+ d__1 = a[i__2].r;
+ z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ l = 1 - j;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__2 = i__;
+ i__5 = l + i__ + j * a_dim1;
+ z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i;
+ y[i__4].r = z__1.r, y[i__4].i = z__1.i;
+ d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
+ i__4 = i__;
+ z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i =
+ z__3.r * x[i__4].i + z__3.i * x[i__4].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L90: */
+ }
+ i__3 = j;
+ i__4 = j;
+ z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = jx;
+ z__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, z__1.i =
+ alpha->r * x[i__3].i + alpha->i * x[i__3].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ i__3 = jy;
+ i__4 = jy;
+ i__2 = j * a_dim1 + 1;
+ d__1 = a[i__2].r;
+ z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ l = 1 - j;
+ ix = jx;
+ iy = jy;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ ix += *incx;
+ iy += *incy;
+ i__4 = iy;
+ i__2 = iy;
+ i__5 = l + i__ + j * a_dim1;
+ z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i;
+ y[i__4].r = z__1.r, y[i__4].i = z__1.i;
+ d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
+ i__4 = ix;
+ z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i =
+ z__3.r * x[i__4].i + z__3.i * x[i__4].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L110: */
+ }
+ i__3 = jy;
+ i__4 = jy;
+ z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ jx += *incx;
+ jy += *incy;
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZHBMV . */
+
+} /* zhbmv_ */
diff --git a/BLAS/SRC/zhemm.c b/BLAS/SRC/zhemm.c
new file mode 100644
index 0000000..dc43c4f
--- /dev/null
+++ b/BLAS/SRC/zhemm.c
@@ -0,0 +1,496 @@
+/* zhemm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zhemm_(char *side, char *uplo, integer *m, integer *n,
+ doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex *
+ b, integer *ldb, doublecomplex *beta, doublecomplex *c__, integer *
+ ldc)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6;
+ doublereal d__1;
+ doublecomplex z__1, z__2, z__3, z__4, z__5;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, info;
+ doublecomplex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHEMM performs one of the matrix-matrix operations */
+
+/* C := alpha*A*B + beta*C, */
+
+/* or */
+
+/* C := alpha*B*A + beta*C, */
+
+/* where alpha and beta are scalars, A is an hermitian matrix and B and */
+/* C are m by n matrices. */
+
+/* Arguments */
+/* ========== */
+
+/* SIDE - CHARACTER*1. */
+/* On entry, SIDE specifies whether the hermitian matrix A */
+/* appears on the left or right in the operation as follows: */
+
+/* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, */
+
+/* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, */
+
+/* Unchanged on exit. */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the hermitian matrix A is to be */
+/* referenced as follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of the */
+/* hermitian matrix is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of the */
+/* hermitian matrix is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix C. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix C. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX*16 . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is */
+/* m when SIDE = 'L' or 'l' and is n otherwise. */
+/* Before entry with SIDE = 'L' or 'l', the m by m part of */
+/* the array A must contain the hermitian matrix, such that */
+/* when UPLO = 'U' or 'u', the leading m by m upper triangular */
+/* part of the array A must contain the upper triangular part */
+/* of the hermitian matrix and the strictly lower triangular */
+/* part of A is not referenced, and when UPLO = 'L' or 'l', */
+/* the leading m by m lower triangular part of the array A */
+/* must contain the lower triangular part of the hermitian */
+/* matrix and the strictly upper triangular part of A is not */
+/* referenced. */
+/* Before entry with SIDE = 'R' or 'r', the n by n part of */
+/* the array A must contain the hermitian matrix, such that */
+/* when UPLO = 'U' or 'u', the leading n by n upper triangular */
+/* part of the array A must contain the upper triangular part */
+/* of the hermitian matrix and the strictly lower triangular */
+/* part of A is not referenced, and when UPLO = 'L' or 'l', */
+/* the leading n by n lower triangular part of the array A */
+/* must contain the lower triangular part of the hermitian */
+/* matrix and the strictly upper triangular part of A is not */
+/* referenced. */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set, they are assumed to be zero. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When SIDE = 'L' or 'l' then */
+/* LDA must be at least max( 1, m ), otherwise LDA must be at */
+/* least max( 1, n ). */
+/* Unchanged on exit. */
+
+/* B - COMPLEX*16 array of DIMENSION ( LDB, n ). */
+/* Before entry, the leading m by n part of the array B must */
+/* contain the matrix B. */
+/* Unchanged on exit. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. LDB must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX*16 . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then C need not be set on input. */
+/* Unchanged on exit. */
+
+/* C - COMPLEX*16 array of DIMENSION ( LDC, n ). */
+/* Before entry, the leading m by n part of the array C must */
+/* contain the matrix C, except when beta is zero, in which */
+/* case C need not be set on entry. */
+/* On exit, the array C is overwritten by the m by n updated */
+/* matrix. */
+
+/* LDC - INTEGER. */
+/* On entry, LDC specifies the first dimension of C as declared */
+/* in the calling (sub) program. LDC must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Set NROWA as the number of rows of A. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ if (lsame_(side, "L")) {
+ nrowa = *m;
+ } else {
+ nrowa = *n;
+ }
+ upper = lsame_(uplo, "U");
+
+/* Test the input parameters. */
+
+ info = 0;
+ if (! lsame_(side, "L") && ! lsame_(side, "R")) {
+ info = 1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ info = 2;
+ } else if (*m < 0) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*lda < max(1,nrowa)) {
+ info = 7;
+ } else if (*ldb < max(1,*m)) {
+ info = 9;
+ } else if (*ldc < max(1,*m)) {
+ info = 12;
+ }
+ if (info != 0) {
+ xerbla_("ZHEMM ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r ==
+ 1. && beta->i == 0.)) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (alpha->r == 0. && alpha->i == 0.) {
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0., c__[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
+ z__1.i = beta->r * c__[i__4].i + beta->i * c__[
+ i__4].r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lsame_(side, "L")) {
+
+/* Form C := alpha*A*B + beta*C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
+ z__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3]
+ .r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ i__3 = i__ - 1;
+ for (k = 1; k <= i__3; ++k) {
+ i__4 = k + j * c_dim1;
+ i__5 = k + j * c_dim1;
+ i__6 = k + i__ * a_dim1;
+ z__2.r = temp1.r * a[i__6].r - temp1.i * a[i__6].i,
+ z__2.i = temp1.r * a[i__6].i + temp1.i * a[
+ i__6].r;
+ z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i +
+ z__2.i;
+ c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
+ i__4 = k + j * b_dim1;
+ d_cnjg(&z__3, &a[k + i__ * a_dim1]);
+ z__2.r = b[i__4].r * z__3.r - b[i__4].i * z__3.i,
+ z__2.i = b[i__4].r * z__3.i + b[i__4].i *
+ z__3.r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L50: */
+ }
+ if (beta->r == 0. && beta->i == 0.) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + i__ * a_dim1;
+ d__1 = a[i__4].r;
+ z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
+ z__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ z__3.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, z__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ i__5 = i__ + i__ * a_dim1;
+ d__1 = a[i__5].r;
+ z__4.r = d__1 * temp1.r, z__4.i = d__1 * temp1.i;
+ z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
+ z__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ z__5.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (i__ = *m; i__ >= 1; --i__) {
+ i__2 = i__ + j * b_dim1;
+ z__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2].i,
+ z__1.i = alpha->r * b[i__2].i + alpha->i * b[i__2]
+ .r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ i__2 = *m;
+ for (k = i__ + 1; k <= i__2; ++k) {
+ i__3 = k + j * c_dim1;
+ i__4 = k + j * c_dim1;
+ i__5 = k + i__ * a_dim1;
+ z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ z__2.i = temp1.r * a[i__5].i + temp1.i * a[
+ i__5].r;
+ z__1.r = c__[i__4].r + z__2.r, z__1.i = c__[i__4].i +
+ z__2.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ i__3 = k + j * b_dim1;
+ d_cnjg(&z__3, &a[k + i__ * a_dim1]);
+ z__2.r = b[i__3].r * z__3.r - b[i__3].i * z__3.i,
+ z__2.i = b[i__3].r * z__3.i + b[i__3].i *
+ z__3.r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L80: */
+ }
+ if (beta->r == 0. && beta->i == 0.) {
+ i__2 = i__ + j * c_dim1;
+ i__3 = i__ + i__ * a_dim1;
+ d__1 = a[i__3].r;
+ z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
+ z__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ z__3.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ } else {
+ i__2 = i__ + j * c_dim1;
+ i__3 = i__ + j * c_dim1;
+ z__3.r = beta->r * c__[i__3].r - beta->i * c__[i__3]
+ .i, z__3.i = beta->r * c__[i__3].i + beta->i *
+ c__[i__3].r;
+ i__4 = i__ + i__ * a_dim1;
+ d__1 = a[i__4].r;
+ z__4.r = d__1 * temp1.r, z__4.i = d__1 * temp1.i;
+ z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
+ z__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ z__5.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+ }
+ } else {
+
+/* Form C := alpha*B*A + beta*C. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * a_dim1;
+ d__1 = a[i__2].r;
+ z__1.r = d__1 * alpha->r, z__1.i = d__1 * alpha->i;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ if (beta->r == 0. && beta->i == 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * b_dim1;
+ z__1.r = temp1.r * b[i__4].r - temp1.i * b[i__4].i,
+ z__1.i = temp1.r * b[i__4].i + temp1.i * b[i__4]
+ .r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L110: */
+ }
+ } else {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__2.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
+ z__2.i = beta->r * c__[i__4].i + beta->i * c__[
+ i__4].r;
+ i__5 = i__ + j * b_dim1;
+ z__3.r = temp1.r * b[i__5].r - temp1.i * b[i__5].i,
+ z__3.i = temp1.r * b[i__5].i + temp1.i * b[i__5]
+ .r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L120: */
+ }
+ }
+ i__2 = j - 1;
+ for (k = 1; k <= i__2; ++k) {
+ if (upper) {
+ i__3 = k + j * a_dim1;
+ z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ z__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
+ .r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ } else {
+ d_cnjg(&z__2, &a[j + k * a_dim1]);
+ z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i =
+ alpha->r * z__2.i + alpha->i * z__2.r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ }
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + k * b_dim1;
+ z__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i,
+ z__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6]
+ .r;
+ z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i +
+ z__2.i;
+ c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
+/* L130: */
+ }
+/* L140: */
+ }
+ i__2 = *n;
+ for (k = j + 1; k <= i__2; ++k) {
+ if (upper) {
+ d_cnjg(&z__2, &a[j + k * a_dim1]);
+ z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i =
+ alpha->r * z__2.i + alpha->i * z__2.r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ } else {
+ i__3 = k + j * a_dim1;
+ z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ z__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
+ .r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ }
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + k * b_dim1;
+ z__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i,
+ z__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6]
+ .r;
+ z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i +
+ z__2.i;
+ c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
+/* L150: */
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+ }
+
+ return 0;
+
+/* End of ZHEMM . */
+
+} /* zhemm_ */
diff --git a/BLAS/SRC/zhemv.c b/BLAS/SRC/zhemv.c
new file mode 100644
index 0000000..646dc12
--- /dev/null
+++ b/BLAS/SRC/zhemv.c
@@ -0,0 +1,433 @@
+/* zhemv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zhemv_(char *uplo, integer *n, doublecomplex *alpha,
+ doublecomplex *a, integer *lda, doublecomplex *x, integer *incx,
+ doublecomplex *beta, doublecomplex *y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, ix, iy, jx, jy, kx, ky, info;
+ doublecomplex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHEMV performs the matrix-vector operation */
+
+/* y := alpha*A*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are n element vectors and */
+/* A is an n by n hermitian matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array A is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of A */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of A */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX*16 . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular part of the hermitian matrix and the strictly */
+/* lower triangular part of A is not referenced. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular part of the hermitian matrix and the strictly */
+/* upper triangular part of A is not referenced. */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set and are assumed to be zero. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX*16 array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX*16 . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - COMPLEX*16 array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. On exit, Y is overwritten by the updated */
+/* vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*lda < max(1,*n)) {
+ info = 5;
+ } else if (*incx == 0) {
+ info = 7;
+ } else if (*incy == 0) {
+ info = 10;
+ }
+ if (info != 0) {
+ xerbla_("ZHEMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r == 1. &&
+ beta->i == 0.)) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through the triangular part */
+/* of A. */
+
+/* First form y := beta*y. */
+
+ if (beta->r != 1. || beta->i != 0.) {
+ if (*incy == 1) {
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ y[i__2].r = 0., y[i__2].i = 0.;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ y[i__2].r = 0., y[i__2].i = 0.;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ i__3 = iy;
+ z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (alpha->r == 0. && alpha->i == 0.) {
+ return 0;
+ }
+ if (lsame_(uplo, "U")) {
+
+/* Form y when A is stored in upper triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ d_cnjg(&z__3, &a[i__ + j * a_dim1]);
+ i__3 = i__;
+ z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i =
+ z__3.r * x[i__3].i + z__3.i * x[i__3].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L50: */
+ }
+ i__2 = j;
+ i__3 = j;
+ i__4 = j + j * a_dim1;
+ d__1 = a[i__4].r;
+ z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i;
+ z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i;
+ z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ ix = kx;
+ iy = ky;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = iy;
+ i__4 = iy;
+ i__5 = i__ + j * a_dim1;
+ z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ d_cnjg(&z__3, &a[i__ + j * a_dim1]);
+ i__3 = ix;
+ z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i =
+ z__3.r * x[i__3].i + z__3.i * x[i__3].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ i__2 = jy;
+ i__3 = jy;
+ i__4 = j + j * a_dim1;
+ d__1 = a[i__4].r;
+ z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i;
+ z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i;
+ z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ jx += *incx;
+ jy += *incy;
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y when A is stored in lower triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ i__2 = j;
+ i__3 = j;
+ i__4 = j + j * a_dim1;
+ d__1 = a[i__4].r;
+ z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
+ z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ d_cnjg(&z__3, &a[i__ + j * a_dim1]);
+ i__3 = i__;
+ z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i =
+ z__3.r * x[i__3].i + z__3.i * x[i__3].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L90: */
+ }
+ i__2 = j;
+ i__3 = j;
+ z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ i__2 = jy;
+ i__3 = jy;
+ i__4 = j + j * a_dim1;
+ d__1 = a[i__4].r;
+ z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
+ z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ ix = jx;
+ iy = jy;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ ix += *incx;
+ iy += *incy;
+ i__3 = iy;
+ i__4 = iy;
+ i__5 = i__ + j * a_dim1;
+ z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ d_cnjg(&z__3, &a[i__ + j * a_dim1]);
+ i__3 = ix;
+ z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i =
+ z__3.r * x[i__3].i + z__3.i * x[i__3].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L110: */
+ }
+ i__2 = jy;
+ i__3 = jy;
+ z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ jx += *incx;
+ jy += *incy;
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZHEMV . */
+
+} /* zhemv_ */
diff --git a/BLAS/SRC/zher.c b/BLAS/SRC/zher.c
new file mode 100644
index 0000000..1aedcc6
--- /dev/null
+++ b/BLAS/SRC/zher.c
@@ -0,0 +1,338 @@
+/* zher.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zher_(char *uplo, integer *n, doublereal *alpha,
+ doublecomplex *x, integer *incx, doublecomplex *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, ix, jx, kx, info;
+ doublecomplex temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHER performs the hermitian rank 1 operation */
+
+/* A := alpha*x*conjg( x' ) + A, */
+
+/* where alpha is a real scalar, x is an n element vector and A is an */
+/* n by n hermitian matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array A is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of A */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of A */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION. */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X - COMPLEX*16 array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular part of the hermitian matrix and the strictly */
+/* lower triangular part of A is not referenced. On exit, the */
+/* upper triangular part of the array A is overwritten by the */
+/* upper triangular part of the updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular part of the hermitian matrix and the strictly */
+/* upper triangular part of A is not referenced. On exit, the */
+/* lower triangular part of the array A is overwritten by the */
+/* lower triangular part of the updated matrix. */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set, they are assumed to be zero, and on exit they */
+/* are set to zero. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ } else if (*lda < max(1,*n)) {
+ info = 7;
+ }
+ if (info != 0) {
+ xerbla_("ZHER ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0.) {
+ return 0;
+ }
+
+/* Set the start point in X if the increment is not unity. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through the triangular part */
+/* of A. */
+
+ if (lsame_(uplo, "U")) {
+
+/* Form A when A is stored in upper triangle. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ d_cnjg(&z__2, &x[j]);
+ z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__;
+ z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ z__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i +
+ z__2.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L10: */
+ }
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ i__4 = j;
+ z__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, z__1.i =
+ x[i__4].r * temp.i + x[i__4].i * temp.r;
+ d__1 = a[i__3].r + z__1.r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ } else {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ d__1 = a[i__3].r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ }
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ d_cnjg(&z__2, &x[jx]);
+ z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix = kx;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = ix;
+ z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ z__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i +
+ z__2.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ ix += *incx;
+/* L30: */
+ }
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ i__4 = jx;
+ z__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, z__1.i =
+ x[i__4].r * temp.i + x[i__4].i * temp.r;
+ d__1 = a[i__3].r + z__1.r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ } else {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ d__1 = a[i__3].r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ }
+ jx += *incx;
+/* L40: */
+ }
+ }
+ } else {
+
+/* Form A when A is stored in lower triangle. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ d_cnjg(&z__2, &x[j]);
+ z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ i__4 = j;
+ z__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, z__1.i =
+ temp.r * x[i__4].i + temp.i * x[i__4].r;
+ d__1 = a[i__3].r + z__1.r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__;
+ z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ z__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i +
+ z__2.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L50: */
+ }
+ } else {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ d__1 = a[i__3].r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ }
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ d_cnjg(&z__2, &x[jx]);
+ z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ i__4 = jx;
+ z__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, z__1.i =
+ temp.r * x[i__4].i + temp.i * x[i__4].r;
+ d__1 = a[i__3].r + z__1.r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ ix = jx;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ ix += *incx;
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = ix;
+ z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ z__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i +
+ z__2.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L70: */
+ }
+ } else {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ d__1 = a[i__3].r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ }
+ jx += *incx;
+/* L80: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZHER . */
+
+} /* zher_ */
diff --git a/BLAS/SRC/zher2.c b/BLAS/SRC/zher2.c
new file mode 100644
index 0000000..27b31bc
--- /dev/null
+++ b/BLAS/SRC/zher2.c
@@ -0,0 +1,447 @@
+/* zher2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zher2_(char *uplo, integer *n, doublecomplex *alpha,
+ doublecomplex *x, integer *incx, doublecomplex *y, integer *incy,
+ doublecomplex *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, ix, iy, jx, jy, kx, ky, info;
+ doublecomplex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHER2 performs the hermitian rank 2 operation */
+
+/* A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A, */
+
+/* where alpha is a scalar, x and y are n element vectors and A is an n */
+/* by n hermitian matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array A is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of A */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of A */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX*16 . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X - COMPLEX*16 array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* Y - COMPLEX*16 array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. */
+/* Unchanged on exit. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular part of the hermitian matrix and the strictly */
+/* lower triangular part of A is not referenced. On exit, the */
+/* upper triangular part of the array A is overwritten by the */
+/* upper triangular part of the updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular part of the hermitian matrix and the strictly */
+/* upper triangular part of A is not referenced. On exit, the */
+/* lower triangular part of the array A is overwritten by the */
+/* lower triangular part of the updated matrix. */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set, they are assumed to be zero, and on exit they */
+/* are set to zero. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ --y;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ } else if (*incy == 0) {
+ info = 7;
+ } else if (*lda < max(1,*n)) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("ZHER2 ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || alpha->r == 0. && alpha->i == 0.) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y if the increments are not both */
+/* unity. */
+
+ if (*incx != 1 || *incy != 1) {
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+ jx = kx;
+ jy = ky;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through the triangular part */
+/* of A. */
+
+ if (lsame_(uplo, "U")) {
+
+/* Form A when A is stored in the upper triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ i__3 = j;
+ if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. ||
+ y[i__3].i != 0.)) {
+ d_cnjg(&z__2, &y[j]);
+ z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i =
+ alpha->r * z__2.i + alpha->i * z__2.r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ i__2 = j;
+ z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ d_cnjg(&z__1, &z__2);
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__;
+ z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
+ z__3.i = x[i__5].r * temp1.i + x[i__5].i *
+ temp1.r;
+ z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i +
+ z__3.i;
+ i__6 = i__;
+ z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
+ z__4.i = y[i__6].r * temp2.i + y[i__6].i *
+ temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L10: */
+ }
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ i__4 = j;
+ z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
+ z__2.i = x[i__4].r * temp1.i + x[i__4].i *
+ temp1.r;
+ i__5 = j;
+ z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
+ z__3.i = y[i__5].r * temp2.i + y[i__5].i *
+ temp2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ d__1 = a[i__3].r + z__1.r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ } else {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ d__1 = a[i__3].r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ i__3 = jy;
+ if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. ||
+ y[i__3].i != 0.)) {
+ d_cnjg(&z__2, &y[jy]);
+ z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i =
+ alpha->r * z__2.i + alpha->i * z__2.r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ i__2 = jx;
+ z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ d_cnjg(&z__1, &z__2);
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ ix = kx;
+ iy = ky;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = ix;
+ z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
+ z__3.i = x[i__5].r * temp1.i + x[i__5].i *
+ temp1.r;
+ z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i +
+ z__3.i;
+ i__6 = iy;
+ z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
+ z__4.i = y[i__6].r * temp2.i + y[i__6].i *
+ temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L30: */
+ }
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ i__4 = jx;
+ z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
+ z__2.i = x[i__4].r * temp1.i + x[i__4].i *
+ temp1.r;
+ i__5 = jy;
+ z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
+ z__3.i = y[i__5].r * temp2.i + y[i__5].i *
+ temp2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ d__1 = a[i__3].r + z__1.r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ } else {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ d__1 = a[i__3].r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ }
+ jx += *incx;
+ jy += *incy;
+/* L40: */
+ }
+ }
+ } else {
+
+/* Form A when A is stored in the lower triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ i__3 = j;
+ if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. ||
+ y[i__3].i != 0.)) {
+ d_cnjg(&z__2, &y[j]);
+ z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i =
+ alpha->r * z__2.i + alpha->i * z__2.r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ i__2 = j;
+ z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ d_cnjg(&z__1, &z__2);
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ i__4 = j;
+ z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
+ z__2.i = x[i__4].r * temp1.i + x[i__4].i *
+ temp1.r;
+ i__5 = j;
+ z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
+ z__3.i = y[i__5].r * temp2.i + y[i__5].i *
+ temp2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ d__1 = a[i__3].r + z__1.r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__;
+ z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
+ z__3.i = x[i__5].r * temp1.i + x[i__5].i *
+ temp1.r;
+ z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i +
+ z__3.i;
+ i__6 = i__;
+ z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
+ z__4.i = y[i__6].r * temp2.i + y[i__6].i *
+ temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L50: */
+ }
+ } else {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ d__1 = a[i__3].r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ i__3 = jy;
+ if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. ||
+ y[i__3].i != 0.)) {
+ d_cnjg(&z__2, &y[jy]);
+ z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i =
+ alpha->r * z__2.i + alpha->i * z__2.r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ i__2 = jx;
+ z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ d_cnjg(&z__1, &z__2);
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ i__4 = jx;
+ z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
+ z__2.i = x[i__4].r * temp1.i + x[i__4].i *
+ temp1.r;
+ i__5 = jy;
+ z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
+ z__3.i = y[i__5].r * temp2.i + y[i__5].i *
+ temp2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ d__1 = a[i__3].r + z__1.r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ ix = jx;
+ iy = jy;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ ix += *incx;
+ iy += *incy;
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = ix;
+ z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
+ z__3.i = x[i__5].r * temp1.i + x[i__5].i *
+ temp1.r;
+ z__2.r = a[i__4].r + z__3.r, z__2.i = a[i__4].i +
+ z__3.i;
+ i__6 = iy;
+ z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
+ z__4.i = y[i__6].r * temp2.i + y[i__6].i *
+ temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L70: */
+ }
+ } else {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ d__1 = a[i__3].r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ }
+ jx += *incx;
+ jy += *incy;
+/* L80: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZHER2 . */
+
+} /* zher2_ */
diff --git a/BLAS/SRC/zher2k.c b/BLAS/SRC/zher2k.c
new file mode 100644
index 0000000..efe4ed6
--- /dev/null
+++ b/BLAS/SRC/zher2k.c
@@ -0,0 +1,671 @@
+/* zher2k.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zher2k_(char *uplo, char *trans, integer *n, integer *k,
+ doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex *
+ b, integer *ldb, doublereal *beta, doublecomplex *c__, integer *ldc)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6, i__7;
+ doublereal d__1;
+ doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, l, info;
+ doublecomplex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHER2K performs one of the hermitian rank 2k operations */
+
+/* C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + beta*C, */
+
+/* or */
+
+/* C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + beta*C, */
+
+/* where alpha and beta are scalars with beta real, C is an n by n */
+/* hermitian matrix and A and B are n by k matrices in the first case */
+/* and k by n matrices in the second case. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array C is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of C */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of C */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' C := alpha*A*conjg( B' ) + */
+/* conjg( alpha )*B*conjg( A' ) + */
+/* beta*C. */
+
+/* TRANS = 'C' or 'c' C := alpha*conjg( A' )*B + */
+/* conjg( alpha )*conjg( B' )*A + */
+/* beta*C. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix C. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry with TRANS = 'N' or 'n', K specifies the number */
+/* of columns of the matrices A and B, and on entry with */
+/* TRANS = 'C' or 'c', K specifies the number of rows of the */
+/* matrices A and B. K must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX*16 . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is */
+/* k when TRANS = 'N' or 'n', and is n otherwise. */
+/* Before entry with TRANS = 'N' or 'n', the leading n by k */
+/* part of the array A must contain the matrix A, otherwise */
+/* the leading k by n part of the array A must contain the */
+/* matrix A. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When TRANS = 'N' or 'n' */
+/* then LDA must be at least max( 1, n ), otherwise LDA must */
+/* be at least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is */
+/* k when TRANS = 'N' or 'n', and is n otherwise. */
+/* Before entry with TRANS = 'N' or 'n', the leading n by k */
+/* part of the array B must contain the matrix B, otherwise */
+/* the leading k by n part of the array B must contain the */
+/* matrix B. */
+/* Unchanged on exit. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. When TRANS = 'N' or 'n' */
+/* then LDB must be at least max( 1, n ), otherwise LDB must */
+/* be at least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* BETA - DOUBLE PRECISION . */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+/* C - COMPLEX*16 array of DIMENSION ( LDC, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array C must contain the upper */
+/* triangular part of the hermitian matrix and the strictly */
+/* lower triangular part of C is not referenced. On exit, the */
+/* upper triangular part of the array C is overwritten by the */
+/* upper triangular part of the updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array C must contain the lower */
+/* triangular part of the hermitian matrix and the strictly */
+/* upper triangular part of C is not referenced. On exit, the */
+/* lower triangular part of the array C is overwritten by the */
+/* lower triangular part of the updated matrix. */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set, they are assumed to be zero, and on exit they */
+/* are set to zero. */
+
+/* LDC - INTEGER. */
+/* On entry, LDC specifies the first dimension of C as declared */
+/* in the calling (sub) program. LDC must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1. */
+/* Ed Anderson, Cray Research Inc. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ if (lsame_(trans, "N")) {
+ nrowa = *n;
+ } else {
+ nrowa = *k;
+ }
+ upper = lsame_(uplo, "U");
+
+ info = 0;
+ if (! upper && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "C")) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*k < 0) {
+ info = 4;
+ } else if (*lda < max(1,nrowa)) {
+ info = 7;
+ } else if (*ldb < max(1,nrowa)) {
+ info = 9;
+ } else if (*ldc < max(1,*n)) {
+ info = 12;
+ }
+ if (info != 0) {
+ xerbla_("ZHER2K", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || (alpha->r == 0. && alpha->i == 0. || *k == 0) && *beta ==
+ 1.) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (alpha->r == 0. && alpha->i == 0.) {
+ if (upper) {
+ if (*beta == 0.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0., c__[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[
+ i__4].i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L30: */
+ }
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ d__1 = *beta * c__[i__3].r;
+ c__[i__2].r = d__1, c__[i__2].i = 0.;
+/* L40: */
+ }
+ }
+ } else {
+ if (*beta == 0.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0., c__[i__3].i = 0.;
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ d__1 = *beta * c__[i__3].r;
+ c__[i__2].r = d__1, c__[i__2].i = 0.;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[
+ i__4].i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + */
+/* C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*beta == 0.) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0., c__[i__3].i = 0.;
+/* L90: */
+ }
+ } else if (*beta != 1.) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[
+ i__4].i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L100: */
+ }
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ d__1 = *beta * c__[i__3].r;
+ c__[i__2].r = d__1, c__[i__2].i = 0.;
+ } else {
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ d__1 = c__[i__3].r;
+ c__[i__2].r = d__1, c__[i__2].i = 0.;
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = j + l * a_dim1;
+ i__4 = j + l * b_dim1;
+ if (a[i__3].r != 0. || a[i__3].i != 0. || (b[i__4].r !=
+ 0. || b[i__4].i != 0.)) {
+ d_cnjg(&z__2, &b[j + l * b_dim1]);
+ z__1.r = alpha->r * z__2.r - alpha->i * z__2.i,
+ z__1.i = alpha->r * z__2.i + alpha->i *
+ z__2.r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ i__3 = j + l * a_dim1;
+ z__2.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ z__2.i = alpha->r * a[i__3].i + alpha->i * a[
+ i__3].r;
+ d_cnjg(&z__1, &z__2);
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ i__3 = j - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + l * a_dim1;
+ z__3.r = a[i__6].r * temp1.r - a[i__6].i *
+ temp1.i, z__3.i = a[i__6].r * temp1.i + a[
+ i__6].i * temp1.r;
+ z__2.r = c__[i__5].r + z__3.r, z__2.i = c__[i__5]
+ .i + z__3.i;
+ i__7 = i__ + l * b_dim1;
+ z__4.r = b[i__7].r * temp2.r - b[i__7].i *
+ temp2.i, z__4.i = b[i__7].r * temp2.i + b[
+ i__7].i * temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i +
+ z__4.i;
+ c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
+/* L110: */
+ }
+ i__3 = j + j * c_dim1;
+ i__4 = j + j * c_dim1;
+ i__5 = j + l * a_dim1;
+ z__2.r = a[i__5].r * temp1.r - a[i__5].i * temp1.i,
+ z__2.i = a[i__5].r * temp1.i + a[i__5].i *
+ temp1.r;
+ i__6 = j + l * b_dim1;
+ z__3.r = b[i__6].r * temp2.r - b[i__6].i * temp2.i,
+ z__3.i = b[i__6].r * temp2.i + b[i__6].i *
+ temp2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ d__1 = c__[i__4].r + z__1.r;
+ c__[i__3].r = d__1, c__[i__3].i = 0.;
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*beta == 0.) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0., c__[i__3].i = 0.;
+/* L140: */
+ }
+ } else if (*beta != 1.) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[
+ i__4].i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L150: */
+ }
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ d__1 = *beta * c__[i__3].r;
+ c__[i__2].r = d__1, c__[i__2].i = 0.;
+ } else {
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ d__1 = c__[i__3].r;
+ c__[i__2].r = d__1, c__[i__2].i = 0.;
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = j + l * a_dim1;
+ i__4 = j + l * b_dim1;
+ if (a[i__3].r != 0. || a[i__3].i != 0. || (b[i__4].r !=
+ 0. || b[i__4].i != 0.)) {
+ d_cnjg(&z__2, &b[j + l * b_dim1]);
+ z__1.r = alpha->r * z__2.r - alpha->i * z__2.i,
+ z__1.i = alpha->r * z__2.i + alpha->i *
+ z__2.r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ i__3 = j + l * a_dim1;
+ z__2.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ z__2.i = alpha->r * a[i__3].i + alpha->i * a[
+ i__3].r;
+ d_cnjg(&z__1, &z__2);
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ i__3 = *n;
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + l * a_dim1;
+ z__3.r = a[i__6].r * temp1.r - a[i__6].i *
+ temp1.i, z__3.i = a[i__6].r * temp1.i + a[
+ i__6].i * temp1.r;
+ z__2.r = c__[i__5].r + z__3.r, z__2.i = c__[i__5]
+ .i + z__3.i;
+ i__7 = i__ + l * b_dim1;
+ z__4.r = b[i__7].r * temp2.r - b[i__7].i *
+ temp2.i, z__4.i = b[i__7].r * temp2.i + b[
+ i__7].i * temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i +
+ z__4.i;
+ c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
+/* L160: */
+ }
+ i__3 = j + j * c_dim1;
+ i__4 = j + j * c_dim1;
+ i__5 = j + l * a_dim1;
+ z__2.r = a[i__5].r * temp1.r - a[i__5].i * temp1.i,
+ z__2.i = a[i__5].r * temp1.i + a[i__5].i *
+ temp1.r;
+ i__6 = j + l * b_dim1;
+ z__3.r = b[i__6].r * temp2.r - b[i__6].i * temp2.i,
+ z__3.i = b[i__6].r * temp2.i + b[i__6].i *
+ temp2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ d__1 = c__[i__4].r + z__1.r;
+ c__[i__3].r = d__1, c__[i__3].i = 0.;
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+ } else {
+
+/* Form C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + */
+/* C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp1.r = 0., temp1.i = 0.;
+ temp2.r = 0., temp2.i = 0.;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ d_cnjg(&z__3, &a[l + i__ * a_dim1]);
+ i__4 = l + j * b_dim1;
+ z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i,
+ z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4]
+ .r;
+ z__1.r = temp1.r + z__2.r, z__1.i = temp1.i + z__2.i;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ d_cnjg(&z__3, &b[l + i__ * b_dim1]);
+ i__4 = l + j * a_dim1;
+ z__2.r = z__3.r * a[i__4].r - z__3.i * a[i__4].i,
+ z__2.i = z__3.r * a[i__4].i + z__3.i * a[i__4]
+ .r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L190: */
+ }
+ if (i__ == j) {
+ if (*beta == 0.) {
+ i__3 = j + j * c_dim1;
+ z__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ z__2.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ d_cnjg(&z__4, alpha);
+ z__3.r = z__4.r * temp2.r - z__4.i * temp2.i,
+ z__3.i = z__4.r * temp2.i + z__4.i *
+ temp2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
+ z__3.i;
+ d__1 = z__1.r;
+ c__[i__3].r = d__1, c__[i__3].i = 0.;
+ } else {
+ i__3 = j + j * c_dim1;
+ i__4 = j + j * c_dim1;
+ z__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ z__2.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ d_cnjg(&z__4, alpha);
+ z__3.r = z__4.r * temp2.r - z__4.i * temp2.i,
+ z__3.i = z__4.r * temp2.i + z__4.i *
+ temp2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
+ z__3.i;
+ d__1 = *beta * c__[i__4].r + z__1.r;
+ c__[i__3].r = d__1, c__[i__3].i = 0.;
+ }
+ } else {
+ if (*beta == 0.) {
+ i__3 = i__ + j * c_dim1;
+ z__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ z__2.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ d_cnjg(&z__4, alpha);
+ z__3.r = z__4.r * temp2.r - z__4.i * temp2.i,
+ z__3.i = z__4.r * temp2.i + z__4.i *
+ temp2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
+ z__3.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__3.r = *beta * c__[i__4].r, z__3.i = *beta *
+ c__[i__4].i;
+ z__4.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ z__4.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ z__2.r = z__3.r + z__4.r, z__2.i = z__3.i +
+ z__4.i;
+ d_cnjg(&z__6, alpha);
+ z__5.r = z__6.r * temp2.r - z__6.i * temp2.i,
+ z__5.i = z__6.r * temp2.i + z__6.i *
+ temp2.r;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i +
+ z__5.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ }
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ temp1.r = 0., temp1.i = 0.;
+ temp2.r = 0., temp2.i = 0.;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ d_cnjg(&z__3, &a[l + i__ * a_dim1]);
+ i__4 = l + j * b_dim1;
+ z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i,
+ z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4]
+ .r;
+ z__1.r = temp1.r + z__2.r, z__1.i = temp1.i + z__2.i;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ d_cnjg(&z__3, &b[l + i__ * b_dim1]);
+ i__4 = l + j * a_dim1;
+ z__2.r = z__3.r * a[i__4].r - z__3.i * a[i__4].i,
+ z__2.i = z__3.r * a[i__4].i + z__3.i * a[i__4]
+ .r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L220: */
+ }
+ if (i__ == j) {
+ if (*beta == 0.) {
+ i__3 = j + j * c_dim1;
+ z__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ z__2.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ d_cnjg(&z__4, alpha);
+ z__3.r = z__4.r * temp2.r - z__4.i * temp2.i,
+ z__3.i = z__4.r * temp2.i + z__4.i *
+ temp2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
+ z__3.i;
+ d__1 = z__1.r;
+ c__[i__3].r = d__1, c__[i__3].i = 0.;
+ } else {
+ i__3 = j + j * c_dim1;
+ i__4 = j + j * c_dim1;
+ z__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ z__2.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ d_cnjg(&z__4, alpha);
+ z__3.r = z__4.r * temp2.r - z__4.i * temp2.i,
+ z__3.i = z__4.r * temp2.i + z__4.i *
+ temp2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
+ z__3.i;
+ d__1 = *beta * c__[i__4].r + z__1.r;
+ c__[i__3].r = d__1, c__[i__3].i = 0.;
+ }
+ } else {
+ if (*beta == 0.) {
+ i__3 = i__ + j * c_dim1;
+ z__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ z__2.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ d_cnjg(&z__4, alpha);
+ z__3.r = z__4.r * temp2.r - z__4.i * temp2.i,
+ z__3.i = z__4.r * temp2.i + z__4.i *
+ temp2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
+ z__3.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__3.r = *beta * c__[i__4].r, z__3.i = *beta *
+ c__[i__4].i;
+ z__4.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ z__4.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ z__2.r = z__3.r + z__4.r, z__2.i = z__3.i +
+ z__4.i;
+ d_cnjg(&z__6, alpha);
+ z__5.r = z__6.r * temp2.r - z__6.i * temp2.i,
+ z__5.i = z__6.r * temp2.i + z__6.i *
+ temp2.r;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i +
+ z__5.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ }
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZHER2K. */
+
+} /* zher2k_ */
diff --git a/BLAS/SRC/zherk.c b/BLAS/SRC/zherk.c
new file mode 100644
index 0000000..611ebb0
--- /dev/null
+++ b/BLAS/SRC/zherk.c
@@ -0,0 +1,533 @@
+/* zherk.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zherk_(char *uplo, char *trans, integer *n, integer *k,
+ doublereal *alpha, doublecomplex *a, integer *lda, doublereal *beta,
+ doublecomplex *c__, integer *ldc)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6;
+ doublereal d__1;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, l, info;
+ doublecomplex temp;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ doublereal rtemp;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHERK performs one of the hermitian rank k operations */
+
+/* C := alpha*A*conjg( A' ) + beta*C, */
+
+/* or */
+
+/* C := alpha*conjg( A' )*A + beta*C, */
+
+/* where alpha and beta are real scalars, C is an n by n hermitian */
+/* matrix and A is an n by k matrix in the first case and a k by n */
+/* matrix in the second case. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array C is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of C */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of C */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C. */
+
+/* TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix C. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry with TRANS = 'N' or 'n', K specifies the number */
+/* of columns of the matrix A, and on entry with */
+/* TRANS = 'C' or 'c', K specifies the number of rows of the */
+/* matrix A. K must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is */
+/* k when TRANS = 'N' or 'n', and is n otherwise. */
+/* Before entry with TRANS = 'N' or 'n', the leading n by k */
+/* part of the array A must contain the matrix A, otherwise */
+/* the leading k by n part of the array A must contain the */
+/* matrix A. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When TRANS = 'N' or 'n' */
+/* then LDA must be at least max( 1, n ), otherwise LDA must */
+/* be at least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* BETA - DOUBLE PRECISION. */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+/* C - COMPLEX*16 array of DIMENSION ( LDC, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array C must contain the upper */
+/* triangular part of the hermitian matrix and the strictly */
+/* lower triangular part of C is not referenced. On exit, the */
+/* upper triangular part of the array C is overwritten by the */
+/* upper triangular part of the updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array C must contain the lower */
+/* triangular part of the hermitian matrix and the strictly */
+/* upper triangular part of C is not referenced. On exit, the */
+/* lower triangular part of the array C is overwritten by the */
+/* lower triangular part of the updated matrix. */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set, they are assumed to be zero, and on exit they */
+/* are set to zero. */
+
+/* LDC - INTEGER. */
+/* On entry, LDC specifies the first dimension of C as declared */
+/* in the calling (sub) program. LDC must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1. */
+/* Ed Anderson, Cray Research Inc. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ if (lsame_(trans, "N")) {
+ nrowa = *n;
+ } else {
+ nrowa = *k;
+ }
+ upper = lsame_(uplo, "U");
+
+ info = 0;
+ if (! upper && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "C")) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*k < 0) {
+ info = 4;
+ } else if (*lda < max(1,nrowa)) {
+ info = 7;
+ } else if (*ldc < max(1,*n)) {
+ info = 10;
+ }
+ if (info != 0) {
+ xerbla_("ZHERK ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (*alpha == 0.) {
+ if (upper) {
+ if (*beta == 0.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0., c__[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[
+ i__4].i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L30: */
+ }
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ d__1 = *beta * c__[i__3].r;
+ c__[i__2].r = d__1, c__[i__2].i = 0.;
+/* L40: */
+ }
+ }
+ } else {
+ if (*beta == 0.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0., c__[i__3].i = 0.;
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ d__1 = *beta * c__[i__3].r;
+ c__[i__2].r = d__1, c__[i__2].i = 0.;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[
+ i__4].i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form C := alpha*A*conjg( A' ) + beta*C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*beta == 0.) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0., c__[i__3].i = 0.;
+/* L90: */
+ }
+ } else if (*beta != 1.) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[
+ i__4].i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L100: */
+ }
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ d__1 = *beta * c__[i__3].r;
+ c__[i__2].r = d__1, c__[i__2].i = 0.;
+ } else {
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ d__1 = c__[i__3].r;
+ c__[i__2].r = d__1, c__[i__2].i = 0.;
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = j + l * a_dim1;
+ if (a[i__3].r != 0. || a[i__3].i != 0.) {
+ d_cnjg(&z__2, &a[j + l * a_dim1]);
+ z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__3 = j - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + l * a_dim1;
+ z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
+ z__2.i = temp.r * a[i__6].i + temp.i * a[
+ i__6].r;
+ z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5]
+ .i + z__2.i;
+ c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
+/* L110: */
+ }
+ i__3 = j + j * c_dim1;
+ i__4 = j + j * c_dim1;
+ i__5 = i__ + l * a_dim1;
+ z__1.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ z__1.i = temp.r * a[i__5].i + temp.i * a[i__5]
+ .r;
+ d__1 = c__[i__4].r + z__1.r;
+ c__[i__3].r = d__1, c__[i__3].i = 0.;
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*beta == 0.) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0., c__[i__3].i = 0.;
+/* L140: */
+ }
+ } else if (*beta != 1.) {
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ d__1 = *beta * c__[i__3].r;
+ c__[i__2].r = d__1, c__[i__2].i = 0.;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__1.r = *beta * c__[i__4].r, z__1.i = *beta * c__[
+ i__4].i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L150: */
+ }
+ } else {
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ d__1 = c__[i__3].r;
+ c__[i__2].r = d__1, c__[i__2].i = 0.;
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = j + l * a_dim1;
+ if (a[i__3].r != 0. || a[i__3].i != 0.) {
+ d_cnjg(&z__2, &a[j + l * a_dim1]);
+ z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__3 = j + j * c_dim1;
+ i__4 = j + j * c_dim1;
+ i__5 = j + l * a_dim1;
+ z__1.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ z__1.i = temp.r * a[i__5].i + temp.i * a[i__5]
+ .r;
+ d__1 = c__[i__4].r + z__1.r;
+ c__[i__3].r = d__1, c__[i__3].i = 0.;
+ i__3 = *n;
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + l * a_dim1;
+ z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
+ z__2.i = temp.r * a[i__6].i + temp.i * a[
+ i__6].r;
+ z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5]
+ .i + z__2.i;
+ c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
+/* L160: */
+ }
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+ } else {
+
+/* Form C := alpha*conjg( A' )*A + beta*C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp.r = 0., temp.i = 0.;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ d_cnjg(&z__3, &a[l + i__ * a_dim1]);
+ i__4 = l + j * a_dim1;
+ z__2.r = z__3.r * a[i__4].r - z__3.i * a[i__4].i,
+ z__2.i = z__3.r * a[i__4].i + z__3.i * a[i__4]
+ .r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L190: */
+ }
+ if (*beta == 0.) {
+ i__3 = i__ + j * c_dim1;
+ z__1.r = *alpha * temp.r, z__1.i = *alpha * temp.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ z__2.r = *alpha * temp.r, z__2.i = *alpha * temp.i;
+ i__4 = i__ + j * c_dim1;
+ z__3.r = *beta * c__[i__4].r, z__3.i = *beta * c__[
+ i__4].i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ }
+/* L200: */
+ }
+ rtemp = 0.;
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ d_cnjg(&z__3, &a[l + j * a_dim1]);
+ i__3 = l + j * a_dim1;
+ z__2.r = z__3.r * a[i__3].r - z__3.i * a[i__3].i, z__2.i =
+ z__3.r * a[i__3].i + z__3.i * a[i__3].r;
+ z__1.r = rtemp + z__2.r, z__1.i = z__2.i;
+ rtemp = z__1.r;
+/* L210: */
+ }
+ if (*beta == 0.) {
+ i__2 = j + j * c_dim1;
+ d__1 = *alpha * rtemp;
+ c__[i__2].r = d__1, c__[i__2].i = 0.;
+ } else {
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ d__1 = *alpha * rtemp + *beta * c__[i__3].r;
+ c__[i__2].r = d__1, c__[i__2].i = 0.;
+ }
+/* L220: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ rtemp = 0.;
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ d_cnjg(&z__3, &a[l + j * a_dim1]);
+ i__3 = l + j * a_dim1;
+ z__2.r = z__3.r * a[i__3].r - z__3.i * a[i__3].i, z__2.i =
+ z__3.r * a[i__3].i + z__3.i * a[i__3].r;
+ z__1.r = rtemp + z__2.r, z__1.i = z__2.i;
+ rtemp = z__1.r;
+/* L230: */
+ }
+ if (*beta == 0.) {
+ i__2 = j + j * c_dim1;
+ d__1 = *alpha * rtemp;
+ c__[i__2].r = d__1, c__[i__2].i = 0.;
+ } else {
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ d__1 = *alpha * rtemp + *beta * c__[i__3].r;
+ c__[i__2].r = d__1, c__[i__2].i = 0.;
+ }
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ temp.r = 0., temp.i = 0.;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ d_cnjg(&z__3, &a[l + i__ * a_dim1]);
+ i__4 = l + j * a_dim1;
+ z__2.r = z__3.r * a[i__4].r - z__3.i * a[i__4].i,
+ z__2.i = z__3.r * a[i__4].i + z__3.i * a[i__4]
+ .r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L240: */
+ }
+ if (*beta == 0.) {
+ i__3 = i__ + j * c_dim1;
+ z__1.r = *alpha * temp.r, z__1.i = *alpha * temp.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ z__2.r = *alpha * temp.r, z__2.i = *alpha * temp.i;
+ i__4 = i__ + j * c_dim1;
+ z__3.r = *beta * c__[i__4].r, z__3.i = *beta * c__[
+ i__4].i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ }
+/* L250: */
+ }
+/* L260: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZHERK . */
+
+} /* zherk_ */
diff --git a/BLAS/SRC/zhpmv.c b/BLAS/SRC/zhpmv.c
new file mode 100644
index 0000000..c631c86
--- /dev/null
+++ b/BLAS/SRC/zhpmv.c
@@ -0,0 +1,434 @@
+/* zhpmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zhpmv_(char *uplo, integer *n, doublecomplex *alpha,
+ doublecomplex *ap, doublecomplex *x, integer *incx, doublecomplex *
+ beta, doublecomplex *y, integer *incy)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
+ doublecomplex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHPMV performs the matrix-vector operation */
+
+/* y := alpha*A*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are n element vectors and */
+/* A is an n by n hermitian matrix, supplied in packed form. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the matrix A is supplied in the packed */
+/* array AP as follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* supplied in AP. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* supplied in AP. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX*16 . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* AP - COMPLEX*16 array of DIMENSION at least */
+/* ( ( n*( n + 1 ) )/2 ). */
+/* Before entry with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular part of the hermitian matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
+/* and a( 2, 2 ) respectively, and so on. */
+/* Before entry with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular part of the hermitian matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
+/* and a( 3, 1 ) respectively, and so on. */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set and are assumed to be zero. */
+/* Unchanged on exit. */
+
+/* X - COMPLEX*16 array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX*16 . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - COMPLEX*16 array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. On exit, Y is overwritten by the updated */
+/* vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --y;
+ --x;
+ --ap;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 6;
+ } else if (*incy == 0) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("ZHPMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r == 1. &&
+ beta->i == 0.)) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of the array AP */
+/* are accessed sequentially with one pass through AP. */
+
+/* First form y := beta*y. */
+
+ if (beta->r != 1. || beta->i != 0.) {
+ if (*incy == 1) {
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ y[i__2].r = 0., y[i__2].i = 0.;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ y[i__2].r = 0., y[i__2].i = 0.;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ i__3 = iy;
+ z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (alpha->r == 0. && alpha->i == 0.) {
+ return 0;
+ }
+ kk = 1;
+ if (lsame_(uplo, "U")) {
+
+/* Form y when AP contains the upper triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ k = kk;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = k;
+ z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
+ z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
+ .r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ d_cnjg(&z__3, &ap[k]);
+ i__3 = i__;
+ z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i =
+ z__3.r * x[i__3].i + z__3.i * x[i__3].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ ++k;
+/* L50: */
+ }
+ i__2 = j;
+ i__3 = j;
+ i__4 = kk + j - 1;
+ d__1 = ap[i__4].r;
+ z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i;
+ z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i;
+ z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ kk += j;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ ix = kx;
+ iy = ky;
+ i__2 = kk + j - 2;
+ for (k = kk; k <= i__2; ++k) {
+ i__3 = iy;
+ i__4 = iy;
+ i__5 = k;
+ z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
+ z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
+ .r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ d_cnjg(&z__3, &ap[k]);
+ i__3 = ix;
+ z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i =
+ z__3.r * x[i__3].i + z__3.i * x[i__3].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ i__2 = jy;
+ i__3 = jy;
+ i__4 = kk + j - 1;
+ d__1 = ap[i__4].r;
+ z__3.r = d__1 * temp1.r, z__3.i = d__1 * temp1.i;
+ z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i;
+ z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ jx += *incx;
+ jy += *incy;
+ kk += j;
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y when AP contains the lower triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ i__2 = j;
+ i__3 = j;
+ i__4 = kk;
+ d__1 = ap[i__4].r;
+ z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
+ z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ k = kk + 1;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = k;
+ z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
+ z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
+ .r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ d_cnjg(&z__3, &ap[k]);
+ i__3 = i__;
+ z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i =
+ z__3.r * x[i__3].i + z__3.i * x[i__3].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ ++k;
+/* L90: */
+ }
+ i__2 = j;
+ i__3 = j;
+ z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ kk += *n - j + 1;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ i__2 = jy;
+ i__3 = jy;
+ i__4 = kk;
+ d__1 = ap[i__4].r;
+ z__2.r = d__1 * temp1.r, z__2.i = d__1 * temp1.i;
+ z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ ix = jx;
+ iy = jy;
+ i__2 = kk + *n - j;
+ for (k = kk + 1; k <= i__2; ++k) {
+ ix += *incx;
+ iy += *incy;
+ i__3 = iy;
+ i__4 = iy;
+ i__5 = k;
+ z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
+ z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
+ .r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ d_cnjg(&z__3, &ap[k]);
+ i__3 = ix;
+ z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i, z__2.i =
+ z__3.r * x[i__3].i + z__3.i * x[i__3].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L110: */
+ }
+ i__2 = jy;
+ i__3 = jy;
+ z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ jx += *incx;
+ jy += *incy;
+ kk += *n - j + 1;
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZHPMV . */
+
+} /* zhpmv_ */
diff --git a/BLAS/SRC/zhpr.c b/BLAS/SRC/zhpr.c
new file mode 100644
index 0000000..a2c189b
--- /dev/null
+++ b/BLAS/SRC/zhpr.c
@@ -0,0 +1,339 @@
+/* zhpr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zhpr_(char *uplo, integer *n, doublereal *alpha,
+ doublecomplex *x, integer *incx, doublecomplex *ap)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, jx, kx, info;
+ doublecomplex temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHPR performs the hermitian rank 1 operation */
+
+/* A := alpha*x*conjg( x' ) + A, */
+
+/* where alpha is a real scalar, x is an n element vector and A is an */
+/* n by n hermitian matrix, supplied in packed form. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the matrix A is supplied in the packed */
+/* array AP as follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* supplied in AP. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* supplied in AP. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION. */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X - COMPLEX*16 array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* AP - COMPLEX*16 array of DIMENSION at least */
+/* ( ( n*( n + 1 ) )/2 ). */
+/* Before entry with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular part of the hermitian matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
+/* and a( 2, 2 ) respectively, and so on. On exit, the array */
+/* AP is overwritten by the upper triangular part of the */
+/* updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular part of the hermitian matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
+/* and a( 3, 1 ) respectively, and so on. On exit, the array */
+/* AP is overwritten by the lower triangular part of the */
+/* updated matrix. */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set, they are assumed to be zero, and on exit they */
+/* are set to zero. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ }
+ if (info != 0) {
+ xerbla_("ZHPR ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0.) {
+ return 0;
+ }
+
+/* Set the start point in X if the increment is not unity. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of the array AP */
+/* are accessed sequentially with one pass through AP. */
+
+ kk = 1;
+ if (lsame_(uplo, "U")) {
+
+/* Form A when upper triangle is stored in AP. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ d_cnjg(&z__2, &x[j]);
+ z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ k = kk;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = k;
+ i__4 = k;
+ i__5 = i__;
+ z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ z__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i +
+ z__2.i;
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+ ++k;
+/* L10: */
+ }
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ i__4 = j;
+ z__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, z__1.i =
+ x[i__4].r * temp.i + x[i__4].i * temp.r;
+ d__1 = ap[i__3].r + z__1.r;
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+ } else {
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ d__1 = ap[i__3].r;
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+ }
+ kk += j;
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ d_cnjg(&z__2, &x[jx]);
+ z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix = kx;
+ i__2 = kk + j - 2;
+ for (k = kk; k <= i__2; ++k) {
+ i__3 = k;
+ i__4 = k;
+ i__5 = ix;
+ z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ z__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i +
+ z__2.i;
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+ ix += *incx;
+/* L30: */
+ }
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ i__4 = jx;
+ z__1.r = x[i__4].r * temp.r - x[i__4].i * temp.i, z__1.i =
+ x[i__4].r * temp.i + x[i__4].i * temp.r;
+ d__1 = ap[i__3].r + z__1.r;
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+ } else {
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ d__1 = ap[i__3].r;
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+ }
+ jx += *incx;
+ kk += j;
+/* L40: */
+ }
+ }
+ } else {
+
+/* Form A when lower triangle is stored in AP. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ d_cnjg(&z__2, &x[j]);
+ z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__2 = kk;
+ i__3 = kk;
+ i__4 = j;
+ z__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, z__1.i =
+ temp.r * x[i__4].i + temp.i * x[i__4].r;
+ d__1 = ap[i__3].r + z__1.r;
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+ k = kk + 1;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = k;
+ i__4 = k;
+ i__5 = i__;
+ z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ z__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i +
+ z__2.i;
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+ ++k;
+/* L50: */
+ }
+ } else {
+ i__2 = kk;
+ i__3 = kk;
+ d__1 = ap[i__3].r;
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+ }
+ kk = kk + *n - j + 1;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ d_cnjg(&z__2, &x[jx]);
+ z__1.r = *alpha * z__2.r, z__1.i = *alpha * z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__2 = kk;
+ i__3 = kk;
+ i__4 = jx;
+ z__1.r = temp.r * x[i__4].r - temp.i * x[i__4].i, z__1.i =
+ temp.r * x[i__4].i + temp.i * x[i__4].r;
+ d__1 = ap[i__3].r + z__1.r;
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+ ix = jx;
+ i__2 = kk + *n - j;
+ for (k = kk + 1; k <= i__2; ++k) {
+ ix += *incx;
+ i__3 = k;
+ i__4 = k;
+ i__5 = ix;
+ z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ z__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i +
+ z__2.i;
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+/* L70: */
+ }
+ } else {
+ i__2 = kk;
+ i__3 = kk;
+ d__1 = ap[i__3].r;
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+ }
+ jx += *incx;
+ kk = kk + *n - j + 1;
+/* L80: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZHPR . */
+
+} /* zhpr_ */
diff --git a/BLAS/SRC/zhpr2.c b/BLAS/SRC/zhpr2.c
new file mode 100644
index 0000000..e116ba7
--- /dev/null
+++ b/BLAS/SRC/zhpr2.c
@@ -0,0 +1,448 @@
+/* zhpr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zhpr2_(char *uplo, integer *n, doublecomplex *alpha,
+ doublecomplex *x, integer *incx, doublecomplex *y, integer *incy,
+ doublecomplex *ap)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
+ doublecomplex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHPR2 performs the hermitian rank 2 operation */
+
+/* A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A, */
+
+/* where alpha is a scalar, x and y are n element vectors and A is an */
+/* n by n hermitian matrix, supplied in packed form. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the matrix A is supplied in the packed */
+/* array AP as follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* supplied in AP. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* supplied in AP. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX*16 . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X - COMPLEX*16 array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* Y - COMPLEX*16 array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. */
+/* Unchanged on exit. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* AP - COMPLEX*16 array of DIMENSION at least */
+/* ( ( n*( n + 1 ) )/2 ). */
+/* Before entry with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular part of the hermitian matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
+/* and a( 2, 2 ) respectively, and so on. On exit, the array */
+/* AP is overwritten by the upper triangular part of the */
+/* updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular part of the hermitian matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
+/* and a( 3, 1 ) respectively, and so on. On exit, the array */
+/* AP is overwritten by the lower triangular part of the */
+/* updated matrix. */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set, they are assumed to be zero, and on exit they */
+/* are set to zero. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --y;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ } else if (*incy == 0) {
+ info = 7;
+ }
+ if (info != 0) {
+ xerbla_("ZHPR2 ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || alpha->r == 0. && alpha->i == 0.) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y if the increments are not both */
+/* unity. */
+
+ if (*incx != 1 || *incy != 1) {
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+ jx = kx;
+ jy = ky;
+ }
+
+/* Start the operations. In this version the elements of the array AP */
+/* are accessed sequentially with one pass through AP. */
+
+ kk = 1;
+ if (lsame_(uplo, "U")) {
+
+/* Form A when upper triangle is stored in AP. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ i__3 = j;
+ if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. ||
+ y[i__3].i != 0.)) {
+ d_cnjg(&z__2, &y[j]);
+ z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i =
+ alpha->r * z__2.i + alpha->i * z__2.r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ i__2 = j;
+ z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ d_cnjg(&z__1, &z__2);
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ k = kk;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = k;
+ i__4 = k;
+ i__5 = i__;
+ z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
+ z__3.i = x[i__5].r * temp1.i + x[i__5].i *
+ temp1.r;
+ z__2.r = ap[i__4].r + z__3.r, z__2.i = ap[i__4].i +
+ z__3.i;
+ i__6 = i__;
+ z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
+ z__4.i = y[i__6].r * temp2.i + y[i__6].i *
+ temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+ ++k;
+/* L10: */
+ }
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ i__4 = j;
+ z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
+ z__2.i = x[i__4].r * temp1.i + x[i__4].i *
+ temp1.r;
+ i__5 = j;
+ z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
+ z__3.i = y[i__5].r * temp2.i + y[i__5].i *
+ temp2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ d__1 = ap[i__3].r + z__1.r;
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+ } else {
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ d__1 = ap[i__3].r;
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+ }
+ kk += j;
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ i__3 = jy;
+ if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. ||
+ y[i__3].i != 0.)) {
+ d_cnjg(&z__2, &y[jy]);
+ z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i =
+ alpha->r * z__2.i + alpha->i * z__2.r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ i__2 = jx;
+ z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ d_cnjg(&z__1, &z__2);
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ ix = kx;
+ iy = ky;
+ i__2 = kk + j - 2;
+ for (k = kk; k <= i__2; ++k) {
+ i__3 = k;
+ i__4 = k;
+ i__5 = ix;
+ z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
+ z__3.i = x[i__5].r * temp1.i + x[i__5].i *
+ temp1.r;
+ z__2.r = ap[i__4].r + z__3.r, z__2.i = ap[i__4].i +
+ z__3.i;
+ i__6 = iy;
+ z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
+ z__4.i = y[i__6].r * temp2.i + y[i__6].i *
+ temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L30: */
+ }
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ i__4 = jx;
+ z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
+ z__2.i = x[i__4].r * temp1.i + x[i__4].i *
+ temp1.r;
+ i__5 = jy;
+ z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
+ z__3.i = y[i__5].r * temp2.i + y[i__5].i *
+ temp2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ d__1 = ap[i__3].r + z__1.r;
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+ } else {
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ d__1 = ap[i__3].r;
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+ }
+ jx += *incx;
+ jy += *incy;
+ kk += j;
+/* L40: */
+ }
+ }
+ } else {
+
+/* Form A when lower triangle is stored in AP. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ i__3 = j;
+ if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. ||
+ y[i__3].i != 0.)) {
+ d_cnjg(&z__2, &y[j]);
+ z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i =
+ alpha->r * z__2.i + alpha->i * z__2.r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ i__2 = j;
+ z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ d_cnjg(&z__1, &z__2);
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ i__2 = kk;
+ i__3 = kk;
+ i__4 = j;
+ z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
+ z__2.i = x[i__4].r * temp1.i + x[i__4].i *
+ temp1.r;
+ i__5 = j;
+ z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
+ z__3.i = y[i__5].r * temp2.i + y[i__5].i *
+ temp2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ d__1 = ap[i__3].r + z__1.r;
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+ k = kk + 1;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = k;
+ i__4 = k;
+ i__5 = i__;
+ z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
+ z__3.i = x[i__5].r * temp1.i + x[i__5].i *
+ temp1.r;
+ z__2.r = ap[i__4].r + z__3.r, z__2.i = ap[i__4].i +
+ z__3.i;
+ i__6 = i__;
+ z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
+ z__4.i = y[i__6].r * temp2.i + y[i__6].i *
+ temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+ ++k;
+/* L50: */
+ }
+ } else {
+ i__2 = kk;
+ i__3 = kk;
+ d__1 = ap[i__3].r;
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+ }
+ kk = kk + *n - j + 1;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ i__3 = jy;
+ if (x[i__2].r != 0. || x[i__2].i != 0. || (y[i__3].r != 0. ||
+ y[i__3].i != 0.)) {
+ d_cnjg(&z__2, &y[jy]);
+ z__1.r = alpha->r * z__2.r - alpha->i * z__2.i, z__1.i =
+ alpha->r * z__2.i + alpha->i * z__2.r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ i__2 = jx;
+ z__2.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ z__2.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ d_cnjg(&z__1, &z__2);
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ i__2 = kk;
+ i__3 = kk;
+ i__4 = jx;
+ z__2.r = x[i__4].r * temp1.r - x[i__4].i * temp1.i,
+ z__2.i = x[i__4].r * temp1.i + x[i__4].i *
+ temp1.r;
+ i__5 = jy;
+ z__3.r = y[i__5].r * temp2.r - y[i__5].i * temp2.i,
+ z__3.i = y[i__5].r * temp2.i + y[i__5].i *
+ temp2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ d__1 = ap[i__3].r + z__1.r;
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+ ix = jx;
+ iy = jy;
+ i__2 = kk + *n - j;
+ for (k = kk + 1; k <= i__2; ++k) {
+ ix += *incx;
+ iy += *incy;
+ i__3 = k;
+ i__4 = k;
+ i__5 = ix;
+ z__3.r = x[i__5].r * temp1.r - x[i__5].i * temp1.i,
+ z__3.i = x[i__5].r * temp1.i + x[i__5].i *
+ temp1.r;
+ z__2.r = ap[i__4].r + z__3.r, z__2.i = ap[i__4].i +
+ z__3.i;
+ i__6 = iy;
+ z__4.r = y[i__6].r * temp2.r - y[i__6].i * temp2.i,
+ z__4.i = y[i__6].r * temp2.i + y[i__6].i *
+ temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+/* L70: */
+ }
+ } else {
+ i__2 = kk;
+ i__3 = kk;
+ d__1 = ap[i__3].r;
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+ }
+ jx += *incx;
+ jy += *incy;
+ kk = kk + *n - j + 1;
+/* L80: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZHPR2 . */
+
+} /* zhpr2_ */
diff --git a/BLAS/SRC/zrotg.c b/BLAS/SRC/zrotg.c
new file mode 100644
index 0000000..4f41c1a
--- /dev/null
+++ b/BLAS/SRC/zrotg.c
@@ -0,0 +1,77 @@
+/* zrotg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zrotg_(doublecomplex *ca, doublecomplex *cb, doublereal *
+ c__, doublecomplex *s)
+{
+ /* System generated locals */
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+ double sqrt(doublereal);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ doublereal norm;
+ doublecomplex alpha;
+ doublereal scale;
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* determines a double complex Givens rotation. */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+ if (z_abs(ca) != 0.) {
+ goto L10;
+ }
+ *c__ = 0.;
+ s->r = 1., s->i = 0.;
+ ca->r = cb->r, ca->i = cb->i;
+ goto L20;
+L10:
+ scale = z_abs(ca) + z_abs(cb);
+ z__2.r = scale, z__2.i = 0.;
+ z_div(&z__1, ca, &z__2);
+/* Computing 2nd power */
+ d__1 = z_abs(&z__1);
+ z__4.r = scale, z__4.i = 0.;
+ z_div(&z__3, cb, &z__4);
+/* Computing 2nd power */
+ d__2 = z_abs(&z__3);
+ norm = scale * sqrt(d__1 * d__1 + d__2 * d__2);
+ d__1 = z_abs(ca);
+ z__1.r = ca->r / d__1, z__1.i = ca->i / d__1;
+ alpha.r = z__1.r, alpha.i = z__1.i;
+ *c__ = z_abs(ca) / norm;
+ d_cnjg(&z__3, cb);
+ z__2.r = alpha.r * z__3.r - alpha.i * z__3.i, z__2.i = alpha.r * z__3.i +
+ alpha.i * z__3.r;
+ z__1.r = z__2.r / norm, z__1.i = z__2.i / norm;
+ s->r = z__1.r, s->i = z__1.i;
+ z__1.r = norm * alpha.r, z__1.i = norm * alpha.i;
+ ca->r = z__1.r, ca->i = z__1.i;
+L20:
+ return 0;
+} /* zrotg_ */
diff --git a/BLAS/SRC/zscal.c b/BLAS/SRC/zscal.c
new file mode 100644
index 0000000..0975b43
--- /dev/null
+++ b/BLAS/SRC/zscal.c
@@ -0,0 +1,81 @@
+/* zscal.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zscal_(integer *n, doublecomplex *za, doublecomplex *zx,
+ integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, ix;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* scales a vector by a constant. */
+/* jack dongarra, 3/11/78. */
+/* modified 3/93 to return if incx .le. 0. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+ /* Parameter adjustments */
+ --zx;
+
+ /* Function Body */
+ if (*n <= 0 || *incx <= 0) {
+ return 0;
+ }
+ if (*incx == 1) {
+ goto L20;
+ }
+
+/* code for increment not equal to 1 */
+
+ ix = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ix;
+ i__3 = ix;
+ z__1.r = za->r * zx[i__3].r - za->i * zx[i__3].i, z__1.i = za->r * zx[
+ i__3].i + za->i * zx[i__3].r;
+ zx[i__2].r = z__1.r, zx[i__2].i = z__1.i;
+ ix += *incx;
+/* L10: */
+ }
+ return 0;
+
+/* code for increment equal to 1 */
+
+L20:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ z__1.r = za->r * zx[i__3].r - za->i * zx[i__3].i, z__1.i = za->r * zx[
+ i__3].i + za->i * zx[i__3].r;
+ zx[i__2].r = z__1.r, zx[i__2].i = z__1.i;
+/* L30: */
+ }
+ return 0;
+} /* zscal_ */
diff --git a/BLAS/SRC/zswap.c b/BLAS/SRC/zswap.c
new file mode 100644
index 0000000..0eaed35
--- /dev/null
+++ b/BLAS/SRC/zswap.c
@@ -0,0 +1,93 @@
+/* zswap.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zswap_(integer *n, doublecomplex *zx, integer *incx,
+ doublecomplex *zy, integer *incy)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, ix, iy;
+ doublecomplex ztemp;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* interchanges two vectors. */
+/* jack dongarra, 3/11/78. */
+/* modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/* .. Local Scalars .. */
+/* .. */
+ /* Parameter adjustments */
+ --zy;
+ --zx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* code for unequal increments or equal increments not equal */
+/* to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ix;
+ ztemp.r = zx[i__2].r, ztemp.i = zx[i__2].i;
+ i__2 = ix;
+ i__3 = iy;
+ zx[i__2].r = zy[i__3].r, zx[i__2].i = zy[i__3].i;
+ i__2 = iy;
+ zy[i__2].r = ztemp.r, zy[i__2].i = ztemp.i;
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ return 0;
+
+/* code for both increments equal to 1 */
+L20:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ ztemp.r = zx[i__2].r, ztemp.i = zx[i__2].i;
+ i__2 = i__;
+ i__3 = i__;
+ zx[i__2].r = zy[i__3].r, zx[i__2].i = zy[i__3].i;
+ i__2 = i__;
+ zy[i__2].r = ztemp.r, zy[i__2].i = ztemp.i;
+/* L30: */
+ }
+ return 0;
+} /* zswap_ */
diff --git a/BLAS/SRC/zsymm.c b/BLAS/SRC/zsymm.c
new file mode 100644
index 0000000..f6c7671
--- /dev/null
+++ b/BLAS/SRC/zsymm.c
@@ -0,0 +1,496 @@
+/* zsymm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zsymm_(char *side, char *uplo, integer *m, integer *n,
+ doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex *
+ b, integer *ldb, doublecomplex *beta, doublecomplex *c__, integer *
+ ldc)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6;
+ doublecomplex z__1, z__2, z__3, z__4, z__5;
+
+ /* Local variables */
+ integer i__, j, k, info;
+ doublecomplex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSYMM performs one of the matrix-matrix operations */
+
+/* C := alpha*A*B + beta*C, */
+
+/* or */
+
+/* C := alpha*B*A + beta*C, */
+
+/* where alpha and beta are scalars, A is a symmetric matrix and B and */
+/* C are m by n matrices. */
+
+/* Arguments */
+/* ========== */
+
+/* SIDE - CHARACTER*1. */
+/* On entry, SIDE specifies whether the symmetric matrix A */
+/* appears on the left or right in the operation as follows: */
+
+/* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, */
+
+/* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, */
+
+/* Unchanged on exit. */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the symmetric matrix A is to be */
+/* referenced as follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of the */
+/* symmetric matrix is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of the */
+/* symmetric matrix is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of the matrix C. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix C. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX*16 . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is */
+/* m when SIDE = 'L' or 'l' and is n otherwise. */
+/* Before entry with SIDE = 'L' or 'l', the m by m part of */
+/* the array A must contain the symmetric matrix, such that */
+/* when UPLO = 'U' or 'u', the leading m by m upper triangular */
+/* part of the array A must contain the upper triangular part */
+/* of the symmetric matrix and the strictly lower triangular */
+/* part of A is not referenced, and when UPLO = 'L' or 'l', */
+/* the leading m by m lower triangular part of the array A */
+/* must contain the lower triangular part of the symmetric */
+/* matrix and the strictly upper triangular part of A is not */
+/* referenced. */
+/* Before entry with SIDE = 'R' or 'r', the n by n part of */
+/* the array A must contain the symmetric matrix, such that */
+/* when UPLO = 'U' or 'u', the leading n by n upper triangular */
+/* part of the array A must contain the upper triangular part */
+/* of the symmetric matrix and the strictly lower triangular */
+/* part of A is not referenced, and when UPLO = 'L' or 'l', */
+/* the leading n by n lower triangular part of the array A */
+/* must contain the lower triangular part of the symmetric */
+/* matrix and the strictly upper triangular part of A is not */
+/* referenced. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When SIDE = 'L' or 'l' then */
+/* LDA must be at least max( 1, m ), otherwise LDA must be at */
+/* least max( 1, n ). */
+/* Unchanged on exit. */
+
+/* B - COMPLEX*16 array of DIMENSION ( LDB, n ). */
+/* Before entry, the leading m by n part of the array B must */
+/* contain the matrix B. */
+/* Unchanged on exit. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. LDB must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX*16 . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then C need not be set on input. */
+/* Unchanged on exit. */
+
+/* C - COMPLEX*16 array of DIMENSION ( LDC, n ). */
+/* Before entry, the leading m by n part of the array C must */
+/* contain the matrix C, except when beta is zero, in which */
+/* case C need not be set on entry. */
+/* On exit, the array C is overwritten by the m by n updated */
+/* matrix. */
+
+/* LDC - INTEGER. */
+/* On entry, LDC specifies the first dimension of C as declared */
+/* in the calling (sub) program. LDC must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Set NROWA as the number of rows of A. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ if (lsame_(side, "L")) {
+ nrowa = *m;
+ } else {
+ nrowa = *n;
+ }
+ upper = lsame_(uplo, "U");
+
+/* Test the input parameters. */
+
+ info = 0;
+ if (! lsame_(side, "L") && ! lsame_(side, "R")) {
+ info = 1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ info = 2;
+ } else if (*m < 0) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*lda < max(1,nrowa)) {
+ info = 7;
+ } else if (*ldb < max(1,*m)) {
+ info = 9;
+ } else if (*ldc < max(1,*m)) {
+ info = 12;
+ }
+ if (info != 0) {
+ xerbla_("ZSYMM ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r ==
+ 1. && beta->i == 0.)) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (alpha->r == 0. && alpha->i == 0.) {
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0., c__[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
+ z__1.i = beta->r * c__[i__4].i + beta->i * c__[
+ i__4].r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lsame_(side, "L")) {
+
+/* Form C := alpha*A*B + beta*C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
+ z__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3]
+ .r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ i__3 = i__ - 1;
+ for (k = 1; k <= i__3; ++k) {
+ i__4 = k + j * c_dim1;
+ i__5 = k + j * c_dim1;
+ i__6 = k + i__ * a_dim1;
+ z__2.r = temp1.r * a[i__6].r - temp1.i * a[i__6].i,
+ z__2.i = temp1.r * a[i__6].i + temp1.i * a[
+ i__6].r;
+ z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i +
+ z__2.i;
+ c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
+ i__4 = k + j * b_dim1;
+ i__5 = k + i__ * a_dim1;
+ z__2.r = b[i__4].r * a[i__5].r - b[i__4].i * a[i__5]
+ .i, z__2.i = b[i__4].r * a[i__5].i + b[i__4]
+ .i * a[i__5].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L50: */
+ }
+ if (beta->r == 0. && beta->i == 0.) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + i__ * a_dim1;
+ z__2.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i,
+ z__2.i = temp1.r * a[i__4].i + temp1.i * a[
+ i__4].r;
+ z__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ z__3.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, z__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ i__5 = i__ + i__ * a_dim1;
+ z__4.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ z__4.i = temp1.r * a[i__5].i + temp1.i * a[
+ i__5].r;
+ z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
+ z__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ z__5.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (i__ = *m; i__ >= 1; --i__) {
+ i__2 = i__ + j * b_dim1;
+ z__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2].i,
+ z__1.i = alpha->r * b[i__2].i + alpha->i * b[i__2]
+ .r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ i__2 = *m;
+ for (k = i__ + 1; k <= i__2; ++k) {
+ i__3 = k + j * c_dim1;
+ i__4 = k + j * c_dim1;
+ i__5 = k + i__ * a_dim1;
+ z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ z__2.i = temp1.r * a[i__5].i + temp1.i * a[
+ i__5].r;
+ z__1.r = c__[i__4].r + z__2.r, z__1.i = c__[i__4].i +
+ z__2.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ i__3 = k + j * b_dim1;
+ i__4 = k + i__ * a_dim1;
+ z__2.r = b[i__3].r * a[i__4].r - b[i__3].i * a[i__4]
+ .i, z__2.i = b[i__3].r * a[i__4].i + b[i__3]
+ .i * a[i__4].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L80: */
+ }
+ if (beta->r == 0. && beta->i == 0.) {
+ i__2 = i__ + j * c_dim1;
+ i__3 = i__ + i__ * a_dim1;
+ z__2.r = temp1.r * a[i__3].r - temp1.i * a[i__3].i,
+ z__2.i = temp1.r * a[i__3].i + temp1.i * a[
+ i__3].r;
+ z__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ z__3.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ } else {
+ i__2 = i__ + j * c_dim1;
+ i__3 = i__ + j * c_dim1;
+ z__3.r = beta->r * c__[i__3].r - beta->i * c__[i__3]
+ .i, z__3.i = beta->r * c__[i__3].i + beta->i *
+ c__[i__3].r;
+ i__4 = i__ + i__ * a_dim1;
+ z__4.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i,
+ z__4.i = temp1.r * a[i__4].i + temp1.i * a[
+ i__4].r;
+ z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
+ z__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ z__5.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+ }
+ } else {
+
+/* Form C := alpha*B*A + beta*C. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * a_dim1;
+ z__1.r = alpha->r * a[i__2].r - alpha->i * a[i__2].i, z__1.i =
+ alpha->r * a[i__2].i + alpha->i * a[i__2].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ if (beta->r == 0. && beta->i == 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * b_dim1;
+ z__1.r = temp1.r * b[i__4].r - temp1.i * b[i__4].i,
+ z__1.i = temp1.r * b[i__4].i + temp1.i * b[i__4]
+ .r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L110: */
+ }
+ } else {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__2.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
+ z__2.i = beta->r * c__[i__4].i + beta->i * c__[
+ i__4].r;
+ i__5 = i__ + j * b_dim1;
+ z__3.r = temp1.r * b[i__5].r - temp1.i * b[i__5].i,
+ z__3.i = temp1.r * b[i__5].i + temp1.i * b[i__5]
+ .r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L120: */
+ }
+ }
+ i__2 = j - 1;
+ for (k = 1; k <= i__2; ++k) {
+ if (upper) {
+ i__3 = k + j * a_dim1;
+ z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ z__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
+ .r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ } else {
+ i__3 = j + k * a_dim1;
+ z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ z__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
+ .r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ }
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + k * b_dim1;
+ z__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i,
+ z__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6]
+ .r;
+ z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i +
+ z__2.i;
+ c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
+/* L130: */
+ }
+/* L140: */
+ }
+ i__2 = *n;
+ for (k = j + 1; k <= i__2; ++k) {
+ if (upper) {
+ i__3 = j + k * a_dim1;
+ z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ z__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
+ .r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ } else {
+ i__3 = k + j * a_dim1;
+ z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ z__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
+ .r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ }
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + k * b_dim1;
+ z__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i,
+ z__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6]
+ .r;
+ z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5].i +
+ z__2.i;
+ c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
+/* L150: */
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+ }
+
+ return 0;
+
+/* End of ZSYMM . */
+
+} /* zsymm_ */
diff --git a/BLAS/SRC/zsyr2k.c b/BLAS/SRC/zsyr2k.c
new file mode 100644
index 0000000..79c7609
--- /dev/null
+++ b/BLAS/SRC/zsyr2k.c
@@ -0,0 +1,538 @@
+/* zsyr2k.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zsyr2k_(char *uplo, char *trans, integer *n, integer *k,
+ doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex *
+ b, integer *ldb, doublecomplex *beta, doublecomplex *c__, integer *
+ ldc)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6, i__7;
+ doublecomplex z__1, z__2, z__3, z__4, z__5;
+
+ /* Local variables */
+ integer i__, j, l, info;
+ doublecomplex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSYR2K performs one of the symmetric rank 2k operations */
+
+/* C := alpha*A*B' + alpha*B*A' + beta*C, */
+
+/* or */
+
+/* C := alpha*A'*B + alpha*B'*A + beta*C, */
+
+/* where alpha and beta are scalars, C is an n by n symmetric matrix */
+/* and A and B are n by k matrices in the first case and k by n */
+/* matrices in the second case. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array C is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of C */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of C */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + */
+/* beta*C. */
+
+/* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + */
+/* beta*C. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix C. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry with TRANS = 'N' or 'n', K specifies the number */
+/* of columns of the matrices A and B, and on entry with */
+/* TRANS = 'T' or 't', K specifies the number of rows of the */
+/* matrices A and B. K must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX*16 . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is */
+/* k when TRANS = 'N' or 'n', and is n otherwise. */
+/* Before entry with TRANS = 'N' or 'n', the leading n by k */
+/* part of the array A must contain the matrix A, otherwise */
+/* the leading k by n part of the array A must contain the */
+/* matrix A. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When TRANS = 'N' or 'n' */
+/* then LDA must be at least max( 1, n ), otherwise LDA must */
+/* be at least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is */
+/* k when TRANS = 'N' or 'n', and is n otherwise. */
+/* Before entry with TRANS = 'N' or 'n', the leading n by k */
+/* part of the array B must contain the matrix B, otherwise */
+/* the leading k by n part of the array B must contain the */
+/* matrix B. */
+/* Unchanged on exit. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. When TRANS = 'N' or 'n' */
+/* then LDB must be at least max( 1, n ), otherwise LDB must */
+/* be at least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX*16 . */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+/* C - COMPLEX*16 array of DIMENSION ( LDC, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array C must contain the upper */
+/* triangular part of the symmetric matrix and the strictly */
+/* lower triangular part of C is not referenced. On exit, the */
+/* upper triangular part of the array C is overwritten by the */
+/* upper triangular part of the updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array C must contain the lower */
+/* triangular part of the symmetric matrix and the strictly */
+/* upper triangular part of C is not referenced. On exit, the */
+/* lower triangular part of the array C is overwritten by the */
+/* lower triangular part of the updated matrix. */
+
+/* LDC - INTEGER. */
+/* On entry, LDC specifies the first dimension of C as declared */
+/* in the calling (sub) program. LDC must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ if (lsame_(trans, "N")) {
+ nrowa = *n;
+ } else {
+ nrowa = *k;
+ }
+ upper = lsame_(uplo, "U");
+
+ info = 0;
+ if (! upper && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T")) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*k < 0) {
+ info = 4;
+ } else if (*lda < max(1,nrowa)) {
+ info = 7;
+ } else if (*ldb < max(1,nrowa)) {
+ info = 9;
+ } else if (*ldc < max(1,*n)) {
+ info = 12;
+ }
+ if (info != 0) {
+ xerbla_("ZSYR2K", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || (alpha->r == 0. && alpha->i == 0. || *k == 0) && (beta->r
+ == 1. && beta->i == 0.)) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (alpha->r == 0. && alpha->i == 0.) {
+ if (upper) {
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0., c__[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, z__1.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else {
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0., c__[i__3].i = 0.;
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, z__1.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form C := alpha*A*B' + alpha*B*A' + C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (beta->r == 0. && beta->i == 0.) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0., c__[i__3].i = 0.;
+/* L90: */
+ }
+ } else if (beta->r != 1. || beta->i != 0.) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, z__1.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L100: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = j + l * a_dim1;
+ i__4 = j + l * b_dim1;
+ if (a[i__3].r != 0. || a[i__3].i != 0. || (b[i__4].r !=
+ 0. || b[i__4].i != 0.)) {
+ i__3 = j + l * b_dim1;
+ z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
+ z__1.i = alpha->r * b[i__3].i + alpha->i * b[
+ i__3].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ i__3 = j + l * a_dim1;
+ z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ z__1.i = alpha->r * a[i__3].i + alpha->i * a[
+ i__3].r;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ i__3 = j;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + l * a_dim1;
+ z__3.r = a[i__6].r * temp1.r - a[i__6].i *
+ temp1.i, z__3.i = a[i__6].r * temp1.i + a[
+ i__6].i * temp1.r;
+ z__2.r = c__[i__5].r + z__3.r, z__2.i = c__[i__5]
+ .i + z__3.i;
+ i__7 = i__ + l * b_dim1;
+ z__4.r = b[i__7].r * temp2.r - b[i__7].i *
+ temp2.i, z__4.i = b[i__7].r * temp2.i + b[
+ i__7].i * temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i +
+ z__4.i;
+ c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
+/* L110: */
+ }
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (beta->r == 0. && beta->i == 0.) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0., c__[i__3].i = 0.;
+/* L140: */
+ }
+ } else if (beta->r != 1. || beta->i != 0.) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, z__1.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L150: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = j + l * a_dim1;
+ i__4 = j + l * b_dim1;
+ if (a[i__3].r != 0. || a[i__3].i != 0. || (b[i__4].r !=
+ 0. || b[i__4].i != 0.)) {
+ i__3 = j + l * b_dim1;
+ z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
+ z__1.i = alpha->r * b[i__3].i + alpha->i * b[
+ i__3].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ i__3 = j + l * a_dim1;
+ z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ z__1.i = alpha->r * a[i__3].i + alpha->i * a[
+ i__3].r;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ i__3 = *n;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + l * a_dim1;
+ z__3.r = a[i__6].r * temp1.r - a[i__6].i *
+ temp1.i, z__3.i = a[i__6].r * temp1.i + a[
+ i__6].i * temp1.r;
+ z__2.r = c__[i__5].r + z__3.r, z__2.i = c__[i__5]
+ .i + z__3.i;
+ i__7 = i__ + l * b_dim1;
+ z__4.r = b[i__7].r * temp2.r - b[i__7].i *
+ temp2.i, z__4.i = b[i__7].r * temp2.i + b[
+ i__7].i * temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i +
+ z__4.i;
+ c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
+/* L160: */
+ }
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+ } else {
+
+/* Form C := alpha*A'*B + alpha*B'*A + C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp1.r = 0., temp1.i = 0.;
+ temp2.r = 0., temp2.i = 0.;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ i__4 = l + i__ * a_dim1;
+ i__5 = l + j * b_dim1;
+ z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5]
+ .i, z__2.i = a[i__4].r * b[i__5].i + a[i__4]
+ .i * b[i__5].r;
+ z__1.r = temp1.r + z__2.r, z__1.i = temp1.i + z__2.i;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ i__4 = l + i__ * b_dim1;
+ i__5 = l + j * a_dim1;
+ z__2.r = b[i__4].r * a[i__5].r - b[i__4].i * a[i__5]
+ .i, z__2.i = b[i__4].r * a[i__5].i + b[i__4]
+ .i * a[i__5].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L190: */
+ }
+ if (beta->r == 0. && beta->i == 0.) {
+ i__3 = i__ + j * c_dim1;
+ z__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ z__2.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ z__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ z__3.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, z__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ z__4.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ z__4.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
+ z__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ z__5.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ temp1.r = 0., temp1.i = 0.;
+ temp2.r = 0., temp2.i = 0.;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ i__4 = l + i__ * a_dim1;
+ i__5 = l + j * b_dim1;
+ z__2.r = a[i__4].r * b[i__5].r - a[i__4].i * b[i__5]
+ .i, z__2.i = a[i__4].r * b[i__5].i + a[i__4]
+ .i * b[i__5].r;
+ z__1.r = temp1.r + z__2.r, z__1.i = temp1.i + z__2.i;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ i__4 = l + i__ * b_dim1;
+ i__5 = l + j * a_dim1;
+ z__2.r = b[i__4].r * a[i__5].r - b[i__4].i * a[i__5]
+ .i, z__2.i = b[i__4].r * a[i__5].i + b[i__4]
+ .i * a[i__5].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L220: */
+ }
+ if (beta->r == 0. && beta->i == 0.) {
+ i__3 = i__ + j * c_dim1;
+ z__2.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ z__2.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ z__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ z__3.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, z__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ z__4.r = alpha->r * temp1.r - alpha->i * temp1.i,
+ z__4.i = alpha->r * temp1.i + alpha->i *
+ temp1.r;
+ z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
+ z__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
+ z__5.i = alpha->r * temp2.i + alpha->i *
+ temp2.r;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZSYR2K. */
+
+} /* zsyr2k_ */
diff --git a/BLAS/SRC/zsyrk.c b/BLAS/SRC/zsyrk.c
new file mode 100644
index 0000000..c1a1c03
--- /dev/null
+++ b/BLAS/SRC/zsyrk.c
@@ -0,0 +1,457 @@
+/* zsyrk.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zsyrk_(char *uplo, char *trans, integer *n, integer *k,
+ doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex *
+ beta, doublecomplex *c__, integer *ldc)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Local variables */
+ integer i__, j, l, info;
+ doublecomplex temp;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSYRK performs one of the symmetric rank k operations */
+
+/* C := alpha*A*A' + beta*C, */
+
+/* or */
+
+/* C := alpha*A'*A + beta*C, */
+
+/* where alpha and beta are scalars, C is an n by n symmetric matrix */
+/* and A is an n by k matrix in the first case and a k by n matrix */
+/* in the second case. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array C is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of C */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of C */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. */
+
+/* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix C. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry with TRANS = 'N' or 'n', K specifies the number */
+/* of columns of the matrix A, and on entry with */
+/* TRANS = 'T' or 't', K specifies the number of rows of the */
+/* matrix A. K must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX*16 . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is */
+/* k when TRANS = 'N' or 'n', and is n otherwise. */
+/* Before entry with TRANS = 'N' or 'n', the leading n by k */
+/* part of the array A must contain the matrix A, otherwise */
+/* the leading k by n part of the array A must contain the */
+/* matrix A. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When TRANS = 'N' or 'n' */
+/* then LDA must be at least max( 1, n ), otherwise LDA must */
+/* be at least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX*16 . */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+/* C - COMPLEX*16 array of DIMENSION ( LDC, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array C must contain the upper */
+/* triangular part of the symmetric matrix and the strictly */
+/* lower triangular part of C is not referenced. On exit, the */
+/* upper triangular part of the array C is overwritten by the */
+/* upper triangular part of the updated matrix. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array C must contain the lower */
+/* triangular part of the symmetric matrix and the strictly */
+/* upper triangular part of C is not referenced. On exit, the */
+/* lower triangular part of the array C is overwritten by the */
+/* lower triangular part of the updated matrix. */
+
+/* LDC - INTEGER. */
+/* On entry, LDC specifies the first dimension of C as declared */
+/* in the calling (sub) program. LDC must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ if (lsame_(trans, "N")) {
+ nrowa = *n;
+ } else {
+ nrowa = *k;
+ }
+ upper = lsame_(uplo, "U");
+
+ info = 0;
+ if (! upper && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T")) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*k < 0) {
+ info = 4;
+ } else if (*lda < max(1,nrowa)) {
+ info = 7;
+ } else if (*ldc < max(1,*n)) {
+ info = 10;
+ }
+ if (info != 0) {
+ xerbla_("ZSYRK ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || (alpha->r == 0. && alpha->i == 0. || *k == 0) && (beta->r
+ == 1. && beta->i == 0.)) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (alpha->r == 0. && alpha->i == 0.) {
+ if (upper) {
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0., c__[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, z__1.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else {
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0., c__[i__3].i = 0.;
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, z__1.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form C := alpha*A*A' + beta*C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (beta->r == 0. && beta->i == 0.) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0., c__[i__3].i = 0.;
+/* L90: */
+ }
+ } else if (beta->r != 1. || beta->i != 0.) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, z__1.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L100: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = j + l * a_dim1;
+ if (a[i__3].r != 0. || a[i__3].i != 0.) {
+ i__3 = j + l * a_dim1;
+ z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ z__1.i = alpha->r * a[i__3].i + alpha->i * a[
+ i__3].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__3 = j;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + l * a_dim1;
+ z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
+ z__2.i = temp.r * a[i__6].i + temp.i * a[
+ i__6].r;
+ z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5]
+ .i + z__2.i;
+ c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
+/* L110: */
+ }
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (beta->r == 0. && beta->i == 0.) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0., c__[i__3].i = 0.;
+/* L140: */
+ }
+ } else if (beta->r != 1. || beta->i != 0.) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, z__1.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L150: */
+ }
+ }
+ i__2 = *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = j + l * a_dim1;
+ if (a[i__3].r != 0. || a[i__3].i != 0.) {
+ i__3 = j + l * a_dim1;
+ z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
+ z__1.i = alpha->r * a[i__3].i + alpha->i * a[
+ i__3].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__3 = *n;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * c_dim1;
+ i__6 = i__ + l * a_dim1;
+ z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
+ z__2.i = temp.r * a[i__6].i + temp.i * a[
+ i__6].r;
+ z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5]
+ .i + z__2.i;
+ c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
+/* L160: */
+ }
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+ } else {
+
+/* Form C := alpha*A'*A + beta*C. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp.r = 0., temp.i = 0.;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ i__4 = l + i__ * a_dim1;
+ i__5 = l + j * a_dim1;
+ z__2.r = a[i__4].r * a[i__5].r - a[i__4].i * a[i__5]
+ .i, z__2.i = a[i__4].r * a[i__5].i + a[i__4]
+ .i * a[i__5].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L190: */
+ }
+ if (beta->r == 0. && beta->i == 0.) {
+ i__3 = i__ + j * c_dim1;
+ z__1.r = alpha->r * temp.r - alpha->i * temp.i,
+ z__1.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ z__2.r = alpha->r * temp.r - alpha->i * temp.i,
+ z__2.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ i__4 = i__ + j * c_dim1;
+ z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, z__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ temp.r = 0., temp.i = 0.;
+ i__3 = *k;
+ for (l = 1; l <= i__3; ++l) {
+ i__4 = l + i__ * a_dim1;
+ i__5 = l + j * a_dim1;
+ z__2.r = a[i__4].r * a[i__5].r - a[i__4].i * a[i__5]
+ .i, z__2.i = a[i__4].r * a[i__5].i + a[i__4]
+ .i * a[i__5].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L220: */
+ }
+ if (beta->r == 0. && beta->i == 0.) {
+ i__3 = i__ + j * c_dim1;
+ z__1.r = alpha->r * temp.r - alpha->i * temp.i,
+ z__1.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ } else {
+ i__3 = i__ + j * c_dim1;
+ z__2.r = alpha->r * temp.r - alpha->i * temp.i,
+ z__2.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ i__4 = i__ + j * c_dim1;
+ z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
+ .i, z__3.i = beta->r * c__[i__4].i + beta->i *
+ c__[i__4].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZSYRK . */
+
+} /* zsyrk_ */
diff --git a/BLAS/SRC/ztbmv.c b/BLAS/SRC/ztbmv.c
new file mode 100644
index 0000000..2585383
--- /dev/null
+++ b/BLAS/SRC/ztbmv.c
@@ -0,0 +1,642 @@
+/* ztbmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ztbmv_(char *uplo, char *trans, char *diag, integer *n,
+ integer *k, doublecomplex *a, integer *lda, doublecomplex *x, integer
+ *incx)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, l, ix, jx, kx, info;
+ doublecomplex temp;
+ extern logical lsame_(char *, char *);
+ integer kplus1;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical noconj, nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTBMV performs one of the matrix-vector operations */
+
+/* x := A*x, or x := A'*x, or x := conjg( A' )*x, */
+
+/* where x is an n element vector and A is an n by n unit, or non-unit, */
+/* upper or lower triangular band matrix, with ( k + 1 ) diagonals. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' x := A*x. */
+
+/* TRANS = 'T' or 't' x := A'*x. */
+
+/* TRANS = 'C' or 'c' x := conjg( A' )*x. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry with UPLO = 'U' or 'u', K specifies the number of */
+/* super-diagonals of the matrix A. */
+/* On entry with UPLO = 'L' or 'l', K specifies the number of */
+/* sub-diagonals of the matrix A. */
+/* K must satisfy 0 .le. K. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
+/* by n part of the array A must contain the upper triangular */
+/* band part of the matrix of coefficients, supplied column by */
+/* column, with the leading diagonal of the matrix in row */
+/* ( k + 1 ) of the array, the first super-diagonal starting at */
+/* position 2 in row k, and so on. The top left k by k triangle */
+/* of the array A is not referenced. */
+/* The following program segment will transfer an upper */
+/* triangular band matrix from conventional full matrix storage */
+/* to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = K + 1 - J */
+/* DO 10, I = MAX( 1, J - K ), J */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
+/* by n part of the array A must contain the lower triangular */
+/* band part of the matrix of coefficients, supplied column by */
+/* column, with the leading diagonal of the matrix in row 1 of */
+/* the array, the first sub-diagonal starting at position 1 in */
+/* row 2, and so on. The bottom right k by k triangle of the */
+/* array A is not referenced. */
+/* The following program segment will transfer a lower */
+/* triangular band matrix from conventional full matrix storage */
+/* to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = 1 - J */
+/* DO 10, I = J, MIN( N, J + K ) */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Note that when DIAG = 'U' or 'u' the elements of the array A */
+/* corresponding to the diagonal elements of the matrix are not */
+/* referenced, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* ( k + 1 ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX*16 array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. On exit, X is overwritten with the */
+/* tranformed vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*k < 0) {
+ info = 5;
+ } else if (*lda < *k + 1) {
+ info = 7;
+ } else if (*incx == 0) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("ZTBMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ noconj = lsame_(trans, "T");
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through A. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x := A*x. */
+
+ if (lsame_(uplo, "U")) {
+ kplus1 = *k + 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ i__2 = j;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__5 = l + i__ + j * a_dim1;
+ z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ z__2.i = temp.r * a[i__5].i + temp.i * a[
+ i__5].r;
+ z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i +
+ z__2.i;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+/* L10: */
+ }
+ if (nounit) {
+ i__4 = j;
+ i__2 = j;
+ i__3 = kplus1 + j * a_dim1;
+ z__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[
+ i__3].i, z__1.i = x[i__2].r * a[i__3].i +
+ x[i__2].i * a[i__3].r;
+ x[i__4].r = z__1.r, x[i__4].i = z__1.i;
+ }
+ }
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = jx;
+ if (x[i__4].r != 0. || x[i__4].i != 0.) {
+ i__4 = jx;
+ temp.r = x[i__4].r, temp.i = x[i__4].i;
+ ix = kx;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *k;
+ i__3 = j - 1;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ i__4 = ix;
+ i__2 = ix;
+ i__5 = l + i__ + j * a_dim1;
+ z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ z__2.i = temp.r * a[i__5].i + temp.i * a[
+ i__5].r;
+ z__1.r = x[i__2].r + z__2.r, z__1.i = x[i__2].i +
+ z__2.i;
+ x[i__4].r = z__1.r, x[i__4].i = z__1.i;
+ ix += *incx;
+/* L30: */
+ }
+ if (nounit) {
+ i__3 = jx;
+ i__4 = jx;
+ i__2 = kplus1 + j * a_dim1;
+ z__1.r = x[i__4].r * a[i__2].r - x[i__4].i * a[
+ i__2].i, z__1.i = x[i__4].r * a[i__2].i +
+ x[i__4].i * a[i__2].r;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ }
+ }
+ jx += *incx;
+ if (j > *k) {
+ kx += *incx;
+ }
+/* L40: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__1 = j;
+ if (x[i__1].r != 0. || x[i__1].i != 0.) {
+ i__1 = j;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ l = 1 - j;
+/* Computing MIN */
+ i__1 = *n, i__3 = j + *k;
+ i__4 = j + 1;
+ for (i__ = min(i__1,i__3); i__ >= i__4; --i__) {
+ i__1 = i__;
+ i__3 = i__;
+ i__2 = l + i__ + j * a_dim1;
+ z__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
+ z__2.i = temp.r * a[i__2].i + temp.i * a[
+ i__2].r;
+ z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i +
+ z__2.i;
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+/* L50: */
+ }
+ if (nounit) {
+ i__4 = j;
+ i__1 = j;
+ i__3 = j * a_dim1 + 1;
+ z__1.r = x[i__1].r * a[i__3].r - x[i__1].i * a[
+ i__3].i, z__1.i = x[i__1].r * a[i__3].i +
+ x[i__1].i * a[i__3].r;
+ x[i__4].r = z__1.r, x[i__4].i = z__1.i;
+ }
+ }
+/* L60: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ i__4 = jx;
+ if (x[i__4].r != 0. || x[i__4].i != 0.) {
+ i__4 = jx;
+ temp.r = x[i__4].r, temp.i = x[i__4].i;
+ ix = kx;
+ l = 1 - j;
+/* Computing MIN */
+ i__4 = *n, i__1 = j + *k;
+ i__3 = j + 1;
+ for (i__ = min(i__4,i__1); i__ >= i__3; --i__) {
+ i__4 = ix;
+ i__1 = ix;
+ i__2 = l + i__ + j * a_dim1;
+ z__2.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
+ z__2.i = temp.r * a[i__2].i + temp.i * a[
+ i__2].r;
+ z__1.r = x[i__1].r + z__2.r, z__1.i = x[i__1].i +
+ z__2.i;
+ x[i__4].r = z__1.r, x[i__4].i = z__1.i;
+ ix -= *incx;
+/* L70: */
+ }
+ if (nounit) {
+ i__3 = jx;
+ i__4 = jx;
+ i__1 = j * a_dim1 + 1;
+ z__1.r = x[i__4].r * a[i__1].r - x[i__4].i * a[
+ i__1].i, z__1.i = x[i__4].r * a[i__1].i +
+ x[i__4].i * a[i__1].r;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ }
+ }
+ jx -= *incx;
+ if (*n - j >= *k) {
+ kx -= *incx;
+ }
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := A'*x or x := conjg( A' )*x. */
+
+ if (lsame_(uplo, "U")) {
+ kplus1 = *k + 1;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__3 = j;
+ temp.r = x[i__3].r, temp.i = x[i__3].i;
+ l = kplus1 - j;
+ if (noconj) {
+ if (nounit) {
+ i__3 = kplus1 + j * a_dim1;
+ z__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
+ z__1.i = temp.r * a[i__3].i + temp.i * a[
+ i__3].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+/* Computing MAX */
+ i__4 = 1, i__1 = j - *k;
+ i__3 = max(i__4,i__1);
+ for (i__ = j - 1; i__ >= i__3; --i__) {
+ i__4 = l + i__ + j * a_dim1;
+ i__1 = i__;
+ z__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[
+ i__1].i, z__2.i = a[i__4].r * x[i__1].i +
+ a[i__4].i * x[i__1].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L90: */
+ }
+ } else {
+ if (nounit) {
+ d_cnjg(&z__2, &a[kplus1 + j * a_dim1]);
+ z__1.r = temp.r * z__2.r - temp.i * z__2.i,
+ z__1.i = temp.r * z__2.i + temp.i *
+ z__2.r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+/* Computing MAX */
+ i__4 = 1, i__1 = j - *k;
+ i__3 = max(i__4,i__1);
+ for (i__ = j - 1; i__ >= i__3; --i__) {
+ d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
+ i__4 = i__;
+ z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i,
+ z__2.i = z__3.r * x[i__4].i + z__3.i * x[
+ i__4].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L100: */
+ }
+ }
+ i__3 = j;
+ x[i__3].r = temp.r, x[i__3].i = temp.i;
+/* L110: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ i__3 = jx;
+ temp.r = x[i__3].r, temp.i = x[i__3].i;
+ kx -= *incx;
+ ix = kx;
+ l = kplus1 - j;
+ if (noconj) {
+ if (nounit) {
+ i__3 = kplus1 + j * a_dim1;
+ z__1.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
+ z__1.i = temp.r * a[i__3].i + temp.i * a[
+ i__3].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+/* Computing MAX */
+ i__4 = 1, i__1 = j - *k;
+ i__3 = max(i__4,i__1);
+ for (i__ = j - 1; i__ >= i__3; --i__) {
+ i__4 = l + i__ + j * a_dim1;
+ i__1 = ix;
+ z__2.r = a[i__4].r * x[i__1].r - a[i__4].i * x[
+ i__1].i, z__2.i = a[i__4].r * x[i__1].i +
+ a[i__4].i * x[i__1].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix -= *incx;
+/* L120: */
+ }
+ } else {
+ if (nounit) {
+ d_cnjg(&z__2, &a[kplus1 + j * a_dim1]);
+ z__1.r = temp.r * z__2.r - temp.i * z__2.i,
+ z__1.i = temp.r * z__2.i + temp.i *
+ z__2.r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+/* Computing MAX */
+ i__4 = 1, i__1 = j - *k;
+ i__3 = max(i__4,i__1);
+ for (i__ = j - 1; i__ >= i__3; --i__) {
+ d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
+ i__4 = ix;
+ z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i,
+ z__2.i = z__3.r * x[i__4].i + z__3.i * x[
+ i__4].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix -= *incx;
+/* L130: */
+ }
+ }
+ i__3 = jx;
+ x[i__3].r = temp.r, x[i__3].i = temp.i;
+ jx -= *incx;
+/* L140: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ temp.r = x[i__4].r, temp.i = x[i__4].i;
+ l = 1 - j;
+ if (noconj) {
+ if (nounit) {
+ i__4 = j * a_dim1 + 1;
+ z__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
+ z__1.i = temp.r * a[i__4].i + temp.i * a[
+ i__4].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+/* Computing MIN */
+ i__1 = *n, i__2 = j + *k;
+ i__4 = min(i__1,i__2);
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ i__1 = l + i__ + j * a_dim1;
+ i__2 = i__;
+ z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[
+ i__2].i, z__2.i = a[i__1].r * x[i__2].i +
+ a[i__1].i * x[i__2].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L150: */
+ }
+ } else {
+ if (nounit) {
+ d_cnjg(&z__2, &a[j * a_dim1 + 1]);
+ z__1.r = temp.r * z__2.r - temp.i * z__2.i,
+ z__1.i = temp.r * z__2.i + temp.i *
+ z__2.r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+/* Computing MIN */
+ i__1 = *n, i__2 = j + *k;
+ i__4 = min(i__1,i__2);
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
+ i__1 = i__;
+ z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i,
+ z__2.i = z__3.r * x[i__1].i + z__3.i * x[
+ i__1].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L160: */
+ }
+ }
+ i__4 = j;
+ x[i__4].r = temp.r, x[i__4].i = temp.i;
+/* L170: */
+ }
+ } else {
+ jx = kx;
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = jx;
+ temp.r = x[i__4].r, temp.i = x[i__4].i;
+ kx += *incx;
+ ix = kx;
+ l = 1 - j;
+ if (noconj) {
+ if (nounit) {
+ i__4 = j * a_dim1 + 1;
+ z__1.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
+ z__1.i = temp.r * a[i__4].i + temp.i * a[
+ i__4].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+/* Computing MIN */
+ i__1 = *n, i__2 = j + *k;
+ i__4 = min(i__1,i__2);
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ i__1 = l + i__ + j * a_dim1;
+ i__2 = ix;
+ z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[
+ i__2].i, z__2.i = a[i__1].r * x[i__2].i +
+ a[i__1].i * x[i__2].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix += *incx;
+/* L180: */
+ }
+ } else {
+ if (nounit) {
+ d_cnjg(&z__2, &a[j * a_dim1 + 1]);
+ z__1.r = temp.r * z__2.r - temp.i * z__2.i,
+ z__1.i = temp.r * z__2.i + temp.i *
+ z__2.r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+/* Computing MIN */
+ i__1 = *n, i__2 = j + *k;
+ i__4 = min(i__1,i__2);
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
+ i__1 = ix;
+ z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i,
+ z__2.i = z__3.r * x[i__1].i + z__3.i * x[
+ i__1].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix += *incx;
+/* L190: */
+ }
+ }
+ i__4 = jx;
+ x[i__4].r = temp.r, x[i__4].i = temp.i;
+ jx += *incx;
+/* L200: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZTBMV . */
+
+} /* ztbmv_ */
diff --git a/BLAS/SRC/ztbsv.c b/BLAS/SRC/ztbsv.c
new file mode 100644
index 0000000..c09ac40
--- /dev/null
+++ b/BLAS/SRC/ztbsv.c
@@ -0,0 +1,611 @@
+/* ztbsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ztbsv_(char *uplo, char *trans, char *diag, integer *n,
+ integer *k, doublecomplex *a, integer *lda, doublecomplex *x, integer
+ *incx)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
+ doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, l, ix, jx, kx, info;
+ doublecomplex temp;
+ extern logical lsame_(char *, char *);
+ integer kplus1;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical noconj, nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTBSV solves one of the systems of equations */
+
+/* A*x = b, or A'*x = b, or conjg( A' )*x = b, */
+
+/* where b and x are n element vectors and A is an n by n unit, or */
+/* non-unit, upper or lower triangular band matrix, with ( k + 1 ) */
+/* diagonals. */
+
+/* No test for singularity or near-singularity is included in this */
+/* routine. Such tests must be performed before calling this routine. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the equations to be solved as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' A*x = b. */
+
+/* TRANS = 'T' or 't' A'*x = b. */
+
+/* TRANS = 'C' or 'c' conjg( A' )*x = b. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER. */
+/* On entry with UPLO = 'U' or 'u', K specifies the number of */
+/* super-diagonals of the matrix A. */
+/* On entry with UPLO = 'L' or 'l', K specifies the number of */
+/* sub-diagonals of the matrix A. */
+/* K must satisfy 0 .le. K. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
+/* by n part of the array A must contain the upper triangular */
+/* band part of the matrix of coefficients, supplied column by */
+/* column, with the leading diagonal of the matrix in row */
+/* ( k + 1 ) of the array, the first super-diagonal starting at */
+/* position 2 in row k, and so on. The top left k by k triangle */
+/* of the array A is not referenced. */
+/* The following program segment will transfer an upper */
+/* triangular band matrix from conventional full matrix storage */
+/* to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = K + 1 - J */
+/* DO 10, I = MAX( 1, J - K ), J */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
+/* by n part of the array A must contain the lower triangular */
+/* band part of the matrix of coefficients, supplied column by */
+/* column, with the leading diagonal of the matrix in row 1 of */
+/* the array, the first sub-diagonal starting at position 1 in */
+/* row 2, and so on. The bottom right k by k triangle of the */
+/* array A is not referenced. */
+/* The following program segment will transfer a lower */
+/* triangular band matrix from conventional full matrix storage */
+/* to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = 1 - J */
+/* DO 10, I = J, MIN( N, J + K ) */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Note that when DIAG = 'U' or 'u' the elements of the array A */
+/* corresponding to the diagonal elements of the matrix are not */
+/* referenced, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* ( k + 1 ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX*16 array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element right-hand side vector b. On exit, X is overwritten */
+/* with the solution vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*k < 0) {
+ info = 5;
+ } else if (*lda < *k + 1) {
+ info = 7;
+ } else if (*incx == 0) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("ZTBSV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ noconj = lsame_(trans, "T");
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed by sequentially with one pass through A. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x := inv( A )*x. */
+
+ if (lsame_(uplo, "U")) {
+ kplus1 = *k + 1;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__1 = j;
+ if (x[i__1].r != 0. || x[i__1].i != 0.) {
+ l = kplus1 - j;
+ if (nounit) {
+ i__1 = j;
+ z_div(&z__1, &x[j], &a[kplus1 + j * a_dim1]);
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ }
+ i__1 = j;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__1 = max(i__2,i__3);
+ for (i__ = j - 1; i__ >= i__1; --i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = l + i__ + j * a_dim1;
+ z__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
+ z__2.i = temp.r * a[i__4].i + temp.i * a[
+ i__4].r;
+ z__1.r = x[i__3].r - z__2.r, z__1.i = x[i__3].i -
+ z__2.i;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+/* L10: */
+ }
+ }
+/* L20: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ kx -= *incx;
+ i__1 = jx;
+ if (x[i__1].r != 0. || x[i__1].i != 0.) {
+ ix = kx;
+ l = kplus1 - j;
+ if (nounit) {
+ i__1 = jx;
+ z_div(&z__1, &x[jx], &a[kplus1 + j * a_dim1]);
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ }
+ i__1 = jx;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__1 = max(i__2,i__3);
+ for (i__ = j - 1; i__ >= i__1; --i__) {
+ i__2 = ix;
+ i__3 = ix;
+ i__4 = l + i__ + j * a_dim1;
+ z__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
+ z__2.i = temp.r * a[i__4].i + temp.i * a[
+ i__4].r;
+ z__1.r = x[i__3].r - z__2.r, z__1.i = x[i__3].i -
+ z__2.i;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ ix -= *incx;
+/* L30: */
+ }
+ }
+ jx -= *incx;
+/* L40: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ l = 1 - j;
+ if (nounit) {
+ i__2 = j;
+ z_div(&z__1, &x[j], &a[j * a_dim1 + 1]);
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ }
+ i__2 = j;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+/* Computing MIN */
+ i__3 = *n, i__4 = j + *k;
+ i__2 = min(i__3,i__4);
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = l + i__ + j * a_dim1;
+ z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ z__2.i = temp.r * a[i__5].i + temp.i * a[
+ i__5].r;
+ z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i -
+ z__2.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ kx += *incx;
+ i__2 = jx;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ ix = kx;
+ l = 1 - j;
+ if (nounit) {
+ i__2 = jx;
+ z_div(&z__1, &x[jx], &a[j * a_dim1 + 1]);
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ }
+ i__2 = jx;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+/* Computing MIN */
+ i__3 = *n, i__4 = j + *k;
+ i__2 = min(i__3,i__4);
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = ix;
+ i__4 = ix;
+ i__5 = l + i__ + j * a_dim1;
+ z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ z__2.i = temp.r * a[i__5].i + temp.i * a[
+ i__5].r;
+ z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i -
+ z__2.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ ix += *incx;
+/* L70: */
+ }
+ }
+ jx += *incx;
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := inv( A' )*x or x := inv( conjg( A') )*x. */
+
+ if (lsame_(uplo, "U")) {
+ kplus1 = *k + 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ l = kplus1 - j;
+ if (noconj) {
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ i__2 = l + i__ + j * a_dim1;
+ i__3 = i__;
+ z__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[
+ i__3].i, z__2.i = a[i__2].r * x[i__3].i +
+ a[i__2].i * x[i__3].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L90: */
+ }
+ if (nounit) {
+ z_div(&z__1, &temp, &a[kplus1 + j * a_dim1]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ } else {
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *k;
+ i__3 = j - 1;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
+ i__4 = i__;
+ z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i,
+ z__2.i = z__3.r * x[i__4].i + z__3.i * x[
+ i__4].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L100: */
+ }
+ if (nounit) {
+ d_cnjg(&z__2, &a[kplus1 + j * a_dim1]);
+ z_div(&z__1, &temp, &z__2);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ }
+ i__3 = j;
+ x[i__3].r = temp.r, x[i__3].i = temp.i;
+/* L110: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = jx;
+ temp.r = x[i__3].r, temp.i = x[i__3].i;
+ ix = kx;
+ l = kplus1 - j;
+ if (noconj) {
+/* Computing MAX */
+ i__3 = 1, i__4 = j - *k;
+ i__2 = j - 1;
+ for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) {
+ i__3 = l + i__ + j * a_dim1;
+ i__4 = ix;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
+ i__4].i, z__2.i = a[i__3].r * x[i__4].i +
+ a[i__3].i * x[i__4].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix += *incx;
+/* L120: */
+ }
+ if (nounit) {
+ z_div(&z__1, &temp, &a[kplus1 + j * a_dim1]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ } else {
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
+ i__2 = ix;
+ z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i,
+ z__2.i = z__3.r * x[i__2].i + z__3.i * x[
+ i__2].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix += *incx;
+/* L130: */
+ }
+ if (nounit) {
+ d_cnjg(&z__2, &a[kplus1 + j * a_dim1]);
+ z_div(&z__1, &temp, &z__2);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ }
+ i__4 = jx;
+ x[i__4].r = temp.r, x[i__4].i = temp.i;
+ jx += *incx;
+ if (j > *k) {
+ kx += *incx;
+ }
+/* L140: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__1 = j;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ l = 1 - j;
+ if (noconj) {
+/* Computing MIN */
+ i__1 = *n, i__4 = j + *k;
+ i__2 = j + 1;
+ for (i__ = min(i__1,i__4); i__ >= i__2; --i__) {
+ i__1 = l + i__ + j * a_dim1;
+ i__4 = i__;
+ z__2.r = a[i__1].r * x[i__4].r - a[i__1].i * x[
+ i__4].i, z__2.i = a[i__1].r * x[i__4].i +
+ a[i__1].i * x[i__4].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L150: */
+ }
+ if (nounit) {
+ z_div(&z__1, &temp, &a[j * a_dim1 + 1]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ } else {
+/* Computing MIN */
+ i__2 = *n, i__1 = j + *k;
+ i__4 = j + 1;
+ for (i__ = min(i__2,i__1); i__ >= i__4; --i__) {
+ d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
+ i__2 = i__;
+ z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i,
+ z__2.i = z__3.r * x[i__2].i + z__3.i * x[
+ i__2].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L160: */
+ }
+ if (nounit) {
+ d_cnjg(&z__2, &a[j * a_dim1 + 1]);
+ z_div(&z__1, &temp, &z__2);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ }
+ i__4 = j;
+ x[i__4].r = temp.r, x[i__4].i = temp.i;
+/* L170: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ i__4 = jx;
+ temp.r = x[i__4].r, temp.i = x[i__4].i;
+ ix = kx;
+ l = 1 - j;
+ if (noconj) {
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__1 = j + 1;
+ for (i__ = min(i__4,i__2); i__ >= i__1; --i__) {
+ i__4 = l + i__ + j * a_dim1;
+ i__2 = ix;
+ z__2.r = a[i__4].r * x[i__2].r - a[i__4].i * x[
+ i__2].i, z__2.i = a[i__4].r * x[i__2].i +
+ a[i__4].i * x[i__2].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix -= *incx;
+/* L180: */
+ }
+ if (nounit) {
+ z_div(&z__1, &temp, &a[j * a_dim1 + 1]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ } else {
+/* Computing MIN */
+ i__1 = *n, i__4 = j + *k;
+ i__2 = j + 1;
+ for (i__ = min(i__1,i__4); i__ >= i__2; --i__) {
+ d_cnjg(&z__3, &a[l + i__ + j * a_dim1]);
+ i__1 = ix;
+ z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i,
+ z__2.i = z__3.r * x[i__1].i + z__3.i * x[
+ i__1].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix -= *incx;
+/* L190: */
+ }
+ if (nounit) {
+ d_cnjg(&z__2, &a[j * a_dim1 + 1]);
+ z_div(&z__1, &temp, &z__2);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ }
+ i__2 = jx;
+ x[i__2].r = temp.r, x[i__2].i = temp.i;
+ jx -= *incx;
+ if (*n - j >= *k) {
+ kx -= *incx;
+ }
+/* L200: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZTBSV . */
+
+} /* ztbsv_ */
diff --git a/BLAS/SRC/ztpmv.c b/BLAS/SRC/ztpmv.c
new file mode 100644
index 0000000..3983feb
--- /dev/null
+++ b/BLAS/SRC/ztpmv.c
@@ -0,0 +1,571 @@
+/* ztpmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ztpmv_(char *uplo, char *trans, char *diag, integer *n,
+ doublecomplex *ap, doublecomplex *x, integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, jx, kx, info;
+ doublecomplex temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical noconj, nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTPMV performs one of the matrix-vector operations */
+
+/* x := A*x, or x := A'*x, or x := conjg( A' )*x, */
+
+/* where x is an n element vector and A is an n by n unit, or non-unit, */
+/* upper or lower triangular matrix, supplied in packed form. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' x := A*x. */
+
+/* TRANS = 'T' or 't' x := A'*x. */
+
+/* TRANS = 'C' or 'c' x := conjg( A' )*x. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* AP - COMPLEX*16 array of DIMENSION at least */
+/* ( ( n*( n + 1 ) )/2 ). */
+/* Before entry with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular matrix packed sequentially, */
+/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
+/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */
+/* respectively, and so on. */
+/* Before entry with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular matrix packed sequentially, */
+/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
+/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */
+/* respectively, and so on. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* X - COMPLEX*16 array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. On exit, X is overwritten with the */
+/* tranformed vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ --ap;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*incx == 0) {
+ info = 7;
+ }
+ if (info != 0) {
+ xerbla_("ZTPMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ noconj = lsame_(trans, "T");
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of AP are */
+/* accessed sequentially with one pass through AP. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x:= A*x. */
+
+ if (lsame_(uplo, "U")) {
+ kk = 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ i__2 = j;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ k = kk;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = k;
+ z__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5]
+ .i, z__2.i = temp.r * ap[i__5].i + temp.i
+ * ap[i__5].r;
+ z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i +
+ z__2.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ ++k;
+/* L10: */
+ }
+ if (nounit) {
+ i__2 = j;
+ i__3 = j;
+ i__4 = kk + j - 1;
+ z__1.r = x[i__3].r * ap[i__4].r - x[i__3].i * ap[
+ i__4].i, z__1.i = x[i__3].r * ap[i__4].i
+ + x[i__3].i * ap[i__4].r;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ }
+ }
+ kk += j;
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ i__2 = jx;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ ix = kx;
+ i__2 = kk + j - 2;
+ for (k = kk; k <= i__2; ++k) {
+ i__3 = ix;
+ i__4 = ix;
+ i__5 = k;
+ z__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5]
+ .i, z__2.i = temp.r * ap[i__5].i + temp.i
+ * ap[i__5].r;
+ z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i +
+ z__2.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ ix += *incx;
+/* L30: */
+ }
+ if (nounit) {
+ i__2 = jx;
+ i__3 = jx;
+ i__4 = kk + j - 1;
+ z__1.r = x[i__3].r * ap[i__4].r - x[i__3].i * ap[
+ i__4].i, z__1.i = x[i__3].r * ap[i__4].i
+ + x[i__3].i * ap[i__4].r;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ }
+ }
+ jx += *incx;
+ kk += j;
+/* L40: */
+ }
+ }
+ } else {
+ kk = *n * (*n + 1) / 2;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__1 = j;
+ if (x[i__1].r != 0. || x[i__1].i != 0.) {
+ i__1 = j;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ k = kk;
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = k;
+ z__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4]
+ .i, z__2.i = temp.r * ap[i__4].i + temp.i
+ * ap[i__4].r;
+ z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i +
+ z__2.i;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ --k;
+/* L50: */
+ }
+ if (nounit) {
+ i__1 = j;
+ i__2 = j;
+ i__3 = kk - *n + j;
+ z__1.r = x[i__2].r * ap[i__3].r - x[i__2].i * ap[
+ i__3].i, z__1.i = x[i__2].r * ap[i__3].i
+ + x[i__2].i * ap[i__3].r;
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ }
+ }
+ kk -= *n - j + 1;
+/* L60: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ i__1 = jx;
+ if (x[i__1].r != 0. || x[i__1].i != 0.) {
+ i__1 = jx;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ ix = kx;
+ i__1 = kk - (*n - (j + 1));
+ for (k = kk; k >= i__1; --k) {
+ i__2 = ix;
+ i__3 = ix;
+ i__4 = k;
+ z__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4]
+ .i, z__2.i = temp.r * ap[i__4].i + temp.i
+ * ap[i__4].r;
+ z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i +
+ z__2.i;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ ix -= *incx;
+/* L70: */
+ }
+ if (nounit) {
+ i__1 = jx;
+ i__2 = jx;
+ i__3 = kk - *n + j;
+ z__1.r = x[i__2].r * ap[i__3].r - x[i__2].i * ap[
+ i__3].i, z__1.i = x[i__2].r * ap[i__3].i
+ + x[i__2].i * ap[i__3].r;
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ }
+ }
+ jx -= *incx;
+ kk -= *n - j + 1;
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := A'*x or x := conjg( A' )*x. */
+
+ if (lsame_(uplo, "U")) {
+ kk = *n * (*n + 1) / 2;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__1 = j;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ k = kk - 1;
+ if (noconj) {
+ if (nounit) {
+ i__1 = kk;
+ z__1.r = temp.r * ap[i__1].r - temp.i * ap[i__1]
+ .i, z__1.i = temp.r * ap[i__1].i + temp.i
+ * ap[i__1].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ i__1 = k;
+ i__2 = i__;
+ z__2.r = ap[i__1].r * x[i__2].r - ap[i__1].i * x[
+ i__2].i, z__2.i = ap[i__1].r * x[i__2].i
+ + ap[i__1].i * x[i__2].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ --k;
+/* L90: */
+ }
+ } else {
+ if (nounit) {
+ d_cnjg(&z__2, &ap[kk]);
+ z__1.r = temp.r * z__2.r - temp.i * z__2.i,
+ z__1.i = temp.r * z__2.i + temp.i *
+ z__2.r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ d_cnjg(&z__3, &ap[k]);
+ i__1 = i__;
+ z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i,
+ z__2.i = z__3.r * x[i__1].i + z__3.i * x[
+ i__1].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ --k;
+/* L100: */
+ }
+ }
+ i__1 = j;
+ x[i__1].r = temp.r, x[i__1].i = temp.i;
+ kk -= j;
+/* L110: */
+ }
+ } else {
+ jx = kx + (*n - 1) * *incx;
+ for (j = *n; j >= 1; --j) {
+ i__1 = jx;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ ix = jx;
+ if (noconj) {
+ if (nounit) {
+ i__1 = kk;
+ z__1.r = temp.r * ap[i__1].r - temp.i * ap[i__1]
+ .i, z__1.i = temp.r * ap[i__1].i + temp.i
+ * ap[i__1].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ i__1 = kk - j + 1;
+ for (k = kk - 1; k >= i__1; --k) {
+ ix -= *incx;
+ i__2 = k;
+ i__3 = ix;
+ z__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[
+ i__3].i, z__2.i = ap[i__2].r * x[i__3].i
+ + ap[i__2].i * x[i__3].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L120: */
+ }
+ } else {
+ if (nounit) {
+ d_cnjg(&z__2, &ap[kk]);
+ z__1.r = temp.r * z__2.r - temp.i * z__2.i,
+ z__1.i = temp.r * z__2.i + temp.i *
+ z__2.r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ i__1 = kk - j + 1;
+ for (k = kk - 1; k >= i__1; --k) {
+ ix -= *incx;
+ d_cnjg(&z__3, &ap[k]);
+ i__2 = ix;
+ z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i,
+ z__2.i = z__3.r * x[i__2].i + z__3.i * x[
+ i__2].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L130: */
+ }
+ }
+ i__1 = jx;
+ x[i__1].r = temp.r, x[i__1].i = temp.i;
+ jx -= *incx;
+ kk -= j;
+/* L140: */
+ }
+ }
+ } else {
+ kk = 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ k = kk + 1;
+ if (noconj) {
+ if (nounit) {
+ i__2 = kk;
+ z__1.r = temp.r * ap[i__2].r - temp.i * ap[i__2]
+ .i, z__1.i = temp.r * ap[i__2].i + temp.i
+ * ap[i__2].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = k;
+ i__4 = i__;
+ z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[
+ i__4].i, z__2.i = ap[i__3].r * x[i__4].i
+ + ap[i__3].i * x[i__4].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ++k;
+/* L150: */
+ }
+ } else {
+ if (nounit) {
+ d_cnjg(&z__2, &ap[kk]);
+ z__1.r = temp.r * z__2.r - temp.i * z__2.i,
+ z__1.i = temp.r * z__2.i + temp.i *
+ z__2.r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ d_cnjg(&z__3, &ap[k]);
+ i__3 = i__;
+ z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
+ z__2.i = z__3.r * x[i__3].i + z__3.i * x[
+ i__3].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ++k;
+/* L160: */
+ }
+ }
+ i__2 = j;
+ x[i__2].r = temp.r, x[i__2].i = temp.i;
+ kk += *n - j + 1;
+/* L170: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ ix = jx;
+ if (noconj) {
+ if (nounit) {
+ i__2 = kk;
+ z__1.r = temp.r * ap[i__2].r - temp.i * ap[i__2]
+ .i, z__1.i = temp.r * ap[i__2].i + temp.i
+ * ap[i__2].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ i__2 = kk + *n - j;
+ for (k = kk + 1; k <= i__2; ++k) {
+ ix += *incx;
+ i__3 = k;
+ i__4 = ix;
+ z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[
+ i__4].i, z__2.i = ap[i__3].r * x[i__4].i
+ + ap[i__3].i * x[i__4].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L180: */
+ }
+ } else {
+ if (nounit) {
+ d_cnjg(&z__2, &ap[kk]);
+ z__1.r = temp.r * z__2.r - temp.i * z__2.i,
+ z__1.i = temp.r * z__2.i + temp.i *
+ z__2.r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ i__2 = kk + *n - j;
+ for (k = kk + 1; k <= i__2; ++k) {
+ ix += *incx;
+ d_cnjg(&z__3, &ap[k]);
+ i__3 = ix;
+ z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
+ z__2.i = z__3.r * x[i__3].i + z__3.i * x[
+ i__3].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L190: */
+ }
+ }
+ i__2 = jx;
+ x[i__2].r = temp.r, x[i__2].i = temp.i;
+ jx += *incx;
+ kk += *n - j + 1;
+/* L200: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZTPMV . */
+
+} /* ztpmv_ */
diff --git a/BLAS/SRC/ztpsv.c b/BLAS/SRC/ztpsv.c
new file mode 100644
index 0000000..9e5b585
--- /dev/null
+++ b/BLAS/SRC/ztpsv.c
@@ -0,0 +1,540 @@
+/* ztpsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ztpsv_(char *uplo, char *trans, char *diag, integer *n,
+ doublecomplex *ap, doublecomplex *x, integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
+ doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, jx, kx, info;
+ doublecomplex temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical noconj, nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTPSV solves one of the systems of equations */
+
+/* A*x = b, or A'*x = b, or conjg( A' )*x = b, */
+
+/* where b and x are n element vectors and A is an n by n unit, or */
+/* non-unit, upper or lower triangular matrix, supplied in packed form. */
+
+/* No test for singularity or near-singularity is included in this */
+/* routine. Such tests must be performed before calling this routine. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the equations to be solved as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' A*x = b. */
+
+/* TRANS = 'T' or 't' A'*x = b. */
+
+/* TRANS = 'C' or 'c' conjg( A' )*x = b. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* AP - COMPLEX*16 array of DIMENSION at least */
+/* ( ( n*( n + 1 ) )/2 ). */
+/* Before entry with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular matrix packed sequentially, */
+/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
+/* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */
+/* respectively, and so on. */
+/* Before entry with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular matrix packed sequentially, */
+/* column by column, so that AP( 1 ) contains a( 1, 1 ), */
+/* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */
+/* respectively, and so on. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* X - COMPLEX*16 array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element right-hand side vector b. On exit, X is overwritten */
+/* with the solution vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ --ap;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*incx == 0) {
+ info = 7;
+ }
+ if (info != 0) {
+ xerbla_("ZTPSV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ noconj = lsame_(trans, "T");
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of AP are */
+/* accessed sequentially with one pass through AP. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x := inv( A )*x. */
+
+ if (lsame_(uplo, "U")) {
+ kk = *n * (*n + 1) / 2;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__1 = j;
+ if (x[i__1].r != 0. || x[i__1].i != 0.) {
+ if (nounit) {
+ i__1 = j;
+ z_div(&z__1, &x[j], &ap[kk]);
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ }
+ i__1 = j;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ k = kk - 1;
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ i__1 = i__;
+ i__2 = i__;
+ i__3 = k;
+ z__2.r = temp.r * ap[i__3].r - temp.i * ap[i__3]
+ .i, z__2.i = temp.r * ap[i__3].i + temp.i
+ * ap[i__3].r;
+ z__1.r = x[i__2].r - z__2.r, z__1.i = x[i__2].i -
+ z__2.i;
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ --k;
+/* L10: */
+ }
+ }
+ kk -= j;
+/* L20: */
+ }
+ } else {
+ jx = kx + (*n - 1) * *incx;
+ for (j = *n; j >= 1; --j) {
+ i__1 = jx;
+ if (x[i__1].r != 0. || x[i__1].i != 0.) {
+ if (nounit) {
+ i__1 = jx;
+ z_div(&z__1, &x[jx], &ap[kk]);
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ }
+ i__1 = jx;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ ix = jx;
+ i__1 = kk - j + 1;
+ for (k = kk - 1; k >= i__1; --k) {
+ ix -= *incx;
+ i__2 = ix;
+ i__3 = ix;
+ i__4 = k;
+ z__2.r = temp.r * ap[i__4].r - temp.i * ap[i__4]
+ .i, z__2.i = temp.r * ap[i__4].i + temp.i
+ * ap[i__4].r;
+ z__1.r = x[i__3].r - z__2.r, z__1.i = x[i__3].i -
+ z__2.i;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+/* L30: */
+ }
+ }
+ jx -= *incx;
+ kk -= j;
+/* L40: */
+ }
+ }
+ } else {
+ kk = 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ if (nounit) {
+ i__2 = j;
+ z_div(&z__1, &x[j], &ap[kk]);
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ }
+ i__2 = j;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ k = kk + 1;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = k;
+ z__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5]
+ .i, z__2.i = temp.r * ap[i__5].i + temp.i
+ * ap[i__5].r;
+ z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i -
+ z__2.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ ++k;
+/* L50: */
+ }
+ }
+ kk += *n - j + 1;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ if (nounit) {
+ i__2 = jx;
+ z_div(&z__1, &x[jx], &ap[kk]);
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ }
+ i__2 = jx;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ ix = jx;
+ i__2 = kk + *n - j;
+ for (k = kk + 1; k <= i__2; ++k) {
+ ix += *incx;
+ i__3 = ix;
+ i__4 = ix;
+ i__5 = k;
+ z__2.r = temp.r * ap[i__5].r - temp.i * ap[i__5]
+ .i, z__2.i = temp.r * ap[i__5].i + temp.i
+ * ap[i__5].r;
+ z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i -
+ z__2.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+/* L70: */
+ }
+ }
+ jx += *incx;
+ kk += *n - j + 1;
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. */
+
+ if (lsame_(uplo, "U")) {
+ kk = 1;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ k = kk;
+ if (noconj) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = k;
+ i__4 = i__;
+ z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[
+ i__4].i, z__2.i = ap[i__3].r * x[i__4].i
+ + ap[i__3].i * x[i__4].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ++k;
+/* L90: */
+ }
+ if (nounit) {
+ z_div(&z__1, &temp, &ap[kk + j - 1]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ } else {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ d_cnjg(&z__3, &ap[k]);
+ i__3 = i__;
+ z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
+ z__2.i = z__3.r * x[i__3].i + z__3.i * x[
+ i__3].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ++k;
+/* L100: */
+ }
+ if (nounit) {
+ d_cnjg(&z__2, &ap[kk + j - 1]);
+ z_div(&z__1, &temp, &z__2);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ }
+ i__2 = j;
+ x[i__2].r = temp.r, x[i__2].i = temp.i;
+ kk += j;
+/* L110: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ ix = kx;
+ if (noconj) {
+ i__2 = kk + j - 2;
+ for (k = kk; k <= i__2; ++k) {
+ i__3 = k;
+ i__4 = ix;
+ z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[
+ i__4].i, z__2.i = ap[i__3].r * x[i__4].i
+ + ap[i__3].i * x[i__4].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix += *incx;
+/* L120: */
+ }
+ if (nounit) {
+ z_div(&z__1, &temp, &ap[kk + j - 1]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ } else {
+ i__2 = kk + j - 2;
+ for (k = kk; k <= i__2; ++k) {
+ d_cnjg(&z__3, &ap[k]);
+ i__3 = ix;
+ z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
+ z__2.i = z__3.r * x[i__3].i + z__3.i * x[
+ i__3].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix += *incx;
+/* L130: */
+ }
+ if (nounit) {
+ d_cnjg(&z__2, &ap[kk + j - 1]);
+ z_div(&z__1, &temp, &z__2);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ }
+ i__2 = jx;
+ x[i__2].r = temp.r, x[i__2].i = temp.i;
+ jx += *incx;
+ kk += j;
+/* L140: */
+ }
+ }
+ } else {
+ kk = *n * (*n + 1) / 2;
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__1 = j;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ k = kk;
+ if (noconj) {
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ i__2 = k;
+ i__3 = i__;
+ z__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[
+ i__3].i, z__2.i = ap[i__2].r * x[i__3].i
+ + ap[i__2].i * x[i__3].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ --k;
+/* L150: */
+ }
+ if (nounit) {
+ z_div(&z__1, &temp, &ap[kk - *n + j]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ } else {
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ d_cnjg(&z__3, &ap[k]);
+ i__2 = i__;
+ z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i,
+ z__2.i = z__3.r * x[i__2].i + z__3.i * x[
+ i__2].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ --k;
+/* L160: */
+ }
+ if (nounit) {
+ d_cnjg(&z__2, &ap[kk - *n + j]);
+ z_div(&z__1, &temp, &z__2);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ }
+ i__1 = j;
+ x[i__1].r = temp.r, x[i__1].i = temp.i;
+ kk -= *n - j + 1;
+/* L170: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ i__1 = jx;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ ix = kx;
+ if (noconj) {
+ i__1 = kk - (*n - (j + 1));
+ for (k = kk; k >= i__1; --k) {
+ i__2 = k;
+ i__3 = ix;
+ z__2.r = ap[i__2].r * x[i__3].r - ap[i__2].i * x[
+ i__3].i, z__2.i = ap[i__2].r * x[i__3].i
+ + ap[i__2].i * x[i__3].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix -= *incx;
+/* L180: */
+ }
+ if (nounit) {
+ z_div(&z__1, &temp, &ap[kk - *n + j]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ } else {
+ i__1 = kk - (*n - (j + 1));
+ for (k = kk; k >= i__1; --k) {
+ d_cnjg(&z__3, &ap[k]);
+ i__2 = ix;
+ z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i,
+ z__2.i = z__3.r * x[i__2].i + z__3.i * x[
+ i__2].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix -= *incx;
+/* L190: */
+ }
+ if (nounit) {
+ d_cnjg(&z__2, &ap[kk - *n + j]);
+ z_div(&z__1, &temp, &z__2);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ }
+ i__1 = jx;
+ x[i__1].r = temp.r, x[i__1].i = temp.i;
+ jx -= *incx;
+ kk -= *n - j + 1;
+/* L200: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZTPSV . */
+
+} /* ztpsv_ */
diff --git a/BLAS/SRC/ztrmm.c b/BLAS/SRC/ztrmm.c
new file mode 100644
index 0000000..c2af1d5
--- /dev/null
+++ b/BLAS/SRC/ztrmm.c
@@ -0,0 +1,688 @@
+/* ztrmm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ztrmm_(char *side, char *uplo, char *transa, char *diag,
+ integer *m, integer *n, doublecomplex *alpha, doublecomplex *a,
+ integer *lda, doublecomplex *b, integer *ldb)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, info;
+ doublecomplex temp;
+ logical lside;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical noconj, nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTRMM performs one of the matrix-matrix operations */
+
+/* B := alpha*op( A )*B, or B := alpha*B*op( A ) */
+
+/* where alpha is a scalar, B is an m by n matrix, A is a unit, or */
+/* non-unit, upper or lower triangular matrix and op( A ) is one of */
+
+/* op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). */
+
+/* Arguments */
+/* ========== */
+
+/* SIDE - CHARACTER*1. */
+/* On entry, SIDE specifies whether op( A ) multiplies B from */
+/* the left or right as follows: */
+
+/* SIDE = 'L' or 'l' B := alpha*op( A )*B. */
+
+/* SIDE = 'R' or 'r' B := alpha*B*op( A ). */
+
+/* Unchanged on exit. */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix A is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANSA - CHARACTER*1. */
+/* On entry, TRANSA specifies the form of op( A ) to be used in */
+/* the matrix multiplication as follows: */
+
+/* TRANSA = 'N' or 'n' op( A ) = A. */
+
+/* TRANSA = 'T' or 't' op( A ) = A'. */
+
+/* TRANSA = 'C' or 'c' op( A ) = conjg( A' ). */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit triangular */
+/* as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of B. M must be at */
+/* least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of B. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX*16 . */
+/* On entry, ALPHA specifies the scalar alpha. When alpha is */
+/* zero then A is not referenced and B need not be set before */
+/* entry. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m */
+/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */
+/* Before entry with UPLO = 'U' or 'u', the leading k by k */
+/* upper triangular part of the array A must contain the upper */
+/* triangular matrix and the strictly lower triangular part of */
+/* A is not referenced. */
+/* Before entry with UPLO = 'L' or 'l', the leading k by k */
+/* lower triangular part of the array A must contain the lower */
+/* triangular matrix and the strictly upper triangular part of */
+/* A is not referenced. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced either, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When SIDE = 'L' or 'l' then */
+/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */
+/* then LDA must be at least max( 1, n ). */
+/* Unchanged on exit. */
+
+/* B - COMPLEX*16 array of DIMENSION ( LDB, n ). */
+/* Before entry, the leading m by n part of the array B must */
+/* contain the matrix B, and on exit is overwritten by the */
+/* transformed matrix. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. LDB must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ lside = lsame_(side, "L");
+ if (lside) {
+ nrowa = *m;
+ } else {
+ nrowa = *n;
+ }
+ noconj = lsame_(transa, "T");
+ nounit = lsame_(diag, "N");
+ upper = lsame_(uplo, "U");
+
+ info = 0;
+ if (! lside && ! lsame_(side, "R")) {
+ info = 1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ info = 2;
+ } else if (! lsame_(transa, "N") && ! lsame_(transa,
+ "T") && ! lsame_(transa, "C")) {
+ info = 3;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 4;
+ } else if (*m < 0) {
+ info = 5;
+ } else if (*n < 0) {
+ info = 6;
+ } else if (*lda < max(1,nrowa)) {
+ info = 9;
+ } else if (*ldb < max(1,*m)) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("ZTRMM ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (alpha->r == 0. && alpha->i == 0.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0., b[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lside) {
+ if (lsame_(transa, "N")) {
+
+/* Form B := alpha*A*B. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * b_dim1;
+ if (b[i__3].r != 0. || b[i__3].i != 0.) {
+ i__3 = k + j * b_dim1;
+ z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3]
+ .i, z__1.i = alpha->r * b[i__3].i +
+ alpha->i * b[i__3].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ + j * b_dim1;
+ i__6 = i__ + k * a_dim1;
+ z__2.r = temp.r * a[i__6].r - temp.i * a[i__6]
+ .i, z__2.i = temp.r * a[i__6].i +
+ temp.i * a[i__6].r;
+ z__1.r = b[i__5].r + z__2.r, z__1.i = b[i__5]
+ .i + z__2.i;
+ b[i__4].r = z__1.r, b[i__4].i = z__1.i;
+/* L30: */
+ }
+ if (nounit) {
+ i__3 = k + k * a_dim1;
+ z__1.r = temp.r * a[i__3].r - temp.i * a[i__3]
+ .i, z__1.i = temp.r * a[i__3].i +
+ temp.i * a[i__3].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ i__3 = k + j * b_dim1;
+ b[i__3].r = temp.r, b[i__3].i = temp.i;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (k = *m; k >= 1; --k) {
+ i__2 = k + j * b_dim1;
+ if (b[i__2].r != 0. || b[i__2].i != 0.) {
+ i__2 = k + j * b_dim1;
+ z__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2]
+ .i, z__1.i = alpha->r * b[i__2].i +
+ alpha->i * b[i__2].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__2 = k + j * b_dim1;
+ b[i__2].r = temp.r, b[i__2].i = temp.i;
+ if (nounit) {
+ i__2 = k + j * b_dim1;
+ i__3 = k + j * b_dim1;
+ i__4 = k + k * a_dim1;
+ z__1.r = b[i__3].r * a[i__4].r - b[i__3].i *
+ a[i__4].i, z__1.i = b[i__3].r * a[
+ i__4].i + b[i__3].i * a[i__4].r;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ }
+ i__2 = *m;
+ for (i__ = k + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ + k * a_dim1;
+ z__2.r = temp.r * a[i__5].r - temp.i * a[i__5]
+ .i, z__2.i = temp.r * a[i__5].i +
+ temp.i * a[i__5].r;
+ z__1.r = b[i__4].r + z__2.r, z__1.i = b[i__4]
+ .i + z__2.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L60: */
+ }
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form B := alpha*A'*B or B := alpha*conjg( A' )*B. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (i__ = *m; i__ >= 1; --i__) {
+ i__2 = i__ + j * b_dim1;
+ temp.r = b[i__2].r, temp.i = b[i__2].i;
+ if (noconj) {
+ if (nounit) {
+ i__2 = i__ + i__ * a_dim1;
+ z__1.r = temp.r * a[i__2].r - temp.i * a[i__2]
+ .i, z__1.i = temp.r * a[i__2].i +
+ temp.i * a[i__2].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ i__2 = i__ - 1;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + i__ * a_dim1;
+ i__4 = k + j * b_dim1;
+ z__2.r = a[i__3].r * b[i__4].r - a[i__3].i *
+ b[i__4].i, z__2.i = a[i__3].r * b[
+ i__4].i + a[i__3].i * b[i__4].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L90: */
+ }
+ } else {
+ if (nounit) {
+ d_cnjg(&z__2, &a[i__ + i__ * a_dim1]);
+ z__1.r = temp.r * z__2.r - temp.i * z__2.i,
+ z__1.i = temp.r * z__2.i + temp.i *
+ z__2.r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ i__2 = i__ - 1;
+ for (k = 1; k <= i__2; ++k) {
+ d_cnjg(&z__3, &a[k + i__ * a_dim1]);
+ i__3 = k + j * b_dim1;
+ z__2.r = z__3.r * b[i__3].r - z__3.i * b[i__3]
+ .i, z__2.i = z__3.r * b[i__3].i +
+ z__3.i * b[i__3].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L100: */
+ }
+ }
+ i__2 = i__ + j * b_dim1;
+ z__1.r = alpha->r * temp.r - alpha->i * temp.i,
+ z__1.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L110: */
+ }
+/* L120: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ temp.r = b[i__3].r, temp.i = b[i__3].i;
+ if (noconj) {
+ if (nounit) {
+ i__3 = i__ + i__ * a_dim1;
+ z__1.r = temp.r * a[i__3].r - temp.i * a[i__3]
+ .i, z__1.i = temp.r * a[i__3].i +
+ temp.i * a[i__3].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ i__3 = *m;
+ for (k = i__ + 1; k <= i__3; ++k) {
+ i__4 = k + i__ * a_dim1;
+ i__5 = k + j * b_dim1;
+ z__2.r = a[i__4].r * b[i__5].r - a[i__4].i *
+ b[i__5].i, z__2.i = a[i__4].r * b[
+ i__5].i + a[i__4].i * b[i__5].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L130: */
+ }
+ } else {
+ if (nounit) {
+ d_cnjg(&z__2, &a[i__ + i__ * a_dim1]);
+ z__1.r = temp.r * z__2.r - temp.i * z__2.i,
+ z__1.i = temp.r * z__2.i + temp.i *
+ z__2.r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ i__3 = *m;
+ for (k = i__ + 1; k <= i__3; ++k) {
+ d_cnjg(&z__3, &a[k + i__ * a_dim1]);
+ i__4 = k + j * b_dim1;
+ z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4]
+ .i, z__2.i = z__3.r * b[i__4].i +
+ z__3.i * b[i__4].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L140: */
+ }
+ }
+ i__3 = i__ + j * b_dim1;
+ z__1.r = alpha->r * temp.r - alpha->i * temp.i,
+ z__1.i = alpha->r * temp.i + alpha->i *
+ temp.r;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L150: */
+ }
+/* L160: */
+ }
+ }
+ }
+ } else {
+ if (lsame_(transa, "N")) {
+
+/* Form B := alpha*B*A. */
+
+ if (upper) {
+ for (j = *n; j >= 1; --j) {
+ temp.r = alpha->r, temp.i = alpha->i;
+ if (nounit) {
+ i__1 = j + j * a_dim1;
+ z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i,
+ z__1.i = temp.r * a[i__1].i + temp.i * a[i__1]
+ .r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ z__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i,
+ z__1.i = temp.r * b[i__3].i + temp.i * b[i__3]
+ .r;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L170: */
+ }
+ i__1 = j - 1;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = k + j * a_dim1;
+ if (a[i__2].r != 0. || a[i__2].i != 0.) {
+ i__2 = k + j * a_dim1;
+ z__1.r = alpha->r * a[i__2].r - alpha->i * a[i__2]
+ .i, z__1.i = alpha->r * a[i__2].i +
+ alpha->i * a[i__2].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ + k * b_dim1;
+ z__2.r = temp.r * b[i__5].r - temp.i * b[i__5]
+ .i, z__2.i = temp.r * b[i__5].i +
+ temp.i * b[i__5].r;
+ z__1.r = b[i__4].r + z__2.r, z__1.i = b[i__4]
+ .i + z__2.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L180: */
+ }
+ }
+/* L190: */
+ }
+/* L200: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ temp.r = alpha->r, temp.i = alpha->i;
+ if (nounit) {
+ i__2 = j + j * a_dim1;
+ z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
+ z__1.i = temp.r * a[i__2].i + temp.i * a[i__2]
+ .r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ z__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i,
+ z__1.i = temp.r * b[i__4].i + temp.i * b[i__4]
+ .r;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L210: */
+ }
+ i__2 = *n;
+ for (k = j + 1; k <= i__2; ++k) {
+ i__3 = k + j * a_dim1;
+ if (a[i__3].r != 0. || a[i__3].i != 0.) {
+ i__3 = k + j * a_dim1;
+ z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3]
+ .i, z__1.i = alpha->r * a[i__3].i +
+ alpha->i * a[i__3].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ + j * b_dim1;
+ i__6 = i__ + k * b_dim1;
+ z__2.r = temp.r * b[i__6].r - temp.i * b[i__6]
+ .i, z__2.i = temp.r * b[i__6].i +
+ temp.i * b[i__6].r;
+ z__1.r = b[i__5].r + z__2.r, z__1.i = b[i__5]
+ .i + z__2.i;
+ b[i__4].r = z__1.r, b[i__4].i = z__1.i;
+/* L220: */
+ }
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+ }
+ } else {
+
+/* Form B := alpha*B*A' or B := alpha*B*conjg( A' ). */
+
+ if (upper) {
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = k - 1;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + k * a_dim1;
+ if (a[i__3].r != 0. || a[i__3].i != 0.) {
+ if (noconj) {
+ i__3 = j + k * a_dim1;
+ z__1.r = alpha->r * a[i__3].r - alpha->i * a[
+ i__3].i, z__1.i = alpha->r * a[i__3]
+ .i + alpha->i * a[i__3].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ } else {
+ d_cnjg(&z__2, &a[j + k * a_dim1]);
+ z__1.r = alpha->r * z__2.r - alpha->i *
+ z__2.i, z__1.i = alpha->r * z__2.i +
+ alpha->i * z__2.r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ + j * b_dim1;
+ i__6 = i__ + k * b_dim1;
+ z__2.r = temp.r * b[i__6].r - temp.i * b[i__6]
+ .i, z__2.i = temp.r * b[i__6].i +
+ temp.i * b[i__6].r;
+ z__1.r = b[i__5].r + z__2.r, z__1.i = b[i__5]
+ .i + z__2.i;
+ b[i__4].r = z__1.r, b[i__4].i = z__1.i;
+/* L250: */
+ }
+ }
+/* L260: */
+ }
+ temp.r = alpha->r, temp.i = alpha->i;
+ if (nounit) {
+ if (noconj) {
+ i__2 = k + k * a_dim1;
+ z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
+ z__1.i = temp.r * a[i__2].i + temp.i * a[
+ i__2].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ } else {
+ d_cnjg(&z__2, &a[k + k * a_dim1]);
+ z__1.r = temp.r * z__2.r - temp.i * z__2.i,
+ z__1.i = temp.r * z__2.i + temp.i *
+ z__2.r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ }
+ if (temp.r != 1. || temp.i != 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ i__4 = i__ + k * b_dim1;
+ z__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i,
+ z__1.i = temp.r * b[i__4].i + temp.i * b[
+ i__4].r;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L270: */
+ }
+ }
+/* L280: */
+ }
+ } else {
+ for (k = *n; k >= 1; --k) {
+ i__1 = *n;
+ for (j = k + 1; j <= i__1; ++j) {
+ i__2 = j + k * a_dim1;
+ if (a[i__2].r != 0. || a[i__2].i != 0.) {
+ if (noconj) {
+ i__2 = j + k * a_dim1;
+ z__1.r = alpha->r * a[i__2].r - alpha->i * a[
+ i__2].i, z__1.i = alpha->r * a[i__2]
+ .i + alpha->i * a[i__2].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ } else {
+ d_cnjg(&z__2, &a[j + k * a_dim1]);
+ z__1.r = alpha->r * z__2.r - alpha->i *
+ z__2.i, z__1.i = alpha->r * z__2.i +
+ alpha->i * z__2.r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ + k * b_dim1;
+ z__2.r = temp.r * b[i__5].r - temp.i * b[i__5]
+ .i, z__2.i = temp.r * b[i__5].i +
+ temp.i * b[i__5].r;
+ z__1.r = b[i__4].r + z__2.r, z__1.i = b[i__4]
+ .i + z__2.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L290: */
+ }
+ }
+/* L300: */
+ }
+ temp.r = alpha->r, temp.i = alpha->i;
+ if (nounit) {
+ if (noconj) {
+ i__1 = k + k * a_dim1;
+ z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i,
+ z__1.i = temp.r * a[i__1].i + temp.i * a[
+ i__1].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ } else {
+ d_cnjg(&z__2, &a[k + k * a_dim1]);
+ z__1.r = temp.r * z__2.r - temp.i * z__2.i,
+ z__1.i = temp.r * z__2.i + temp.i *
+ z__2.r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ }
+ if (temp.r != 1. || temp.i != 0.) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + k * b_dim1;
+ i__3 = i__ + k * b_dim1;
+ z__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i,
+ z__1.i = temp.r * b[i__3].i + temp.i * b[
+ i__3].r;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L310: */
+ }
+ }
+/* L320: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZTRMM . */
+
+} /* ztrmm_ */
diff --git a/BLAS/SRC/ztrmv.c b/BLAS/SRC/ztrmv.c
new file mode 100644
index 0000000..a4d8d3c
--- /dev/null
+++ b/BLAS/SRC/ztrmv.c
@@ -0,0 +1,554 @@
+/* ztrmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ztrmv_(char *uplo, char *trans, char *diag, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *x, integer *incx)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, ix, jx, kx, info;
+ doublecomplex temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical noconj, nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTRMV performs one of the matrix-vector operations */
+
+/* x := A*x, or x := A'*x, or x := conjg( A' )*x, */
+
+/* where x is an n element vector and A is an n by n unit, or non-unit, */
+/* upper or lower triangular matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' x := A*x. */
+
+/* TRANS = 'T' or 't' x := A'*x. */
+
+/* TRANS = 'C' or 'c' x := conjg( A' )*x. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular matrix and the strictly lower triangular part of */
+/* A is not referenced. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular matrix and the strictly upper triangular part of */
+/* A is not referenced. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced either, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX*16 array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element vector x. On exit, X is overwritten with the */
+/* tranformed vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*lda < max(1,*n)) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ }
+ if (info != 0) {
+ xerbla_("ZTRMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ noconj = lsame_(trans, "T");
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through A. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x := A*x. */
+
+ if (lsame_(uplo, "U")) {
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ i__2 = j;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ z__2.i = temp.r * a[i__5].i + temp.i * a[
+ i__5].r;
+ z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i +
+ z__2.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+/* L10: */
+ }
+ if (nounit) {
+ i__2 = j;
+ i__3 = j;
+ i__4 = j + j * a_dim1;
+ z__1.r = x[i__3].r * a[i__4].r - x[i__3].i * a[
+ i__4].i, z__1.i = x[i__3].r * a[i__4].i +
+ x[i__3].i * a[i__4].r;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ }
+ }
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ i__2 = jx;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ ix = kx;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = ix;
+ i__4 = ix;
+ i__5 = i__ + j * a_dim1;
+ z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ z__2.i = temp.r * a[i__5].i + temp.i * a[
+ i__5].r;
+ z__1.r = x[i__4].r + z__2.r, z__1.i = x[i__4].i +
+ z__2.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ ix += *incx;
+/* L30: */
+ }
+ if (nounit) {
+ i__2 = jx;
+ i__3 = jx;
+ i__4 = j + j * a_dim1;
+ z__1.r = x[i__3].r * a[i__4].r - x[i__3].i * a[
+ i__4].i, z__1.i = x[i__3].r * a[i__4].i +
+ x[i__3].i * a[i__4].r;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ }
+ }
+ jx += *incx;
+/* L40: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__1 = j;
+ if (x[i__1].r != 0. || x[i__1].i != 0.) {
+ i__1 = j;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__ + j * a_dim1;
+ z__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
+ z__2.i = temp.r * a[i__4].i + temp.i * a[
+ i__4].r;
+ z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i +
+ z__2.i;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+/* L50: */
+ }
+ if (nounit) {
+ i__1 = j;
+ i__2 = j;
+ i__3 = j + j * a_dim1;
+ z__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[
+ i__3].i, z__1.i = x[i__2].r * a[i__3].i +
+ x[i__2].i * a[i__3].r;
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ }
+ }
+/* L60: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ i__1 = jx;
+ if (x[i__1].r != 0. || x[i__1].i != 0.) {
+ i__1 = jx;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ ix = kx;
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ i__2 = ix;
+ i__3 = ix;
+ i__4 = i__ + j * a_dim1;
+ z__2.r = temp.r * a[i__4].r - temp.i * a[i__4].i,
+ z__2.i = temp.r * a[i__4].i + temp.i * a[
+ i__4].r;
+ z__1.r = x[i__3].r + z__2.r, z__1.i = x[i__3].i +
+ z__2.i;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ ix -= *incx;
+/* L70: */
+ }
+ if (nounit) {
+ i__1 = jx;
+ i__2 = jx;
+ i__3 = j + j * a_dim1;
+ z__1.r = x[i__2].r * a[i__3].r - x[i__2].i * a[
+ i__3].i, z__1.i = x[i__2].r * a[i__3].i +
+ x[i__2].i * a[i__3].r;
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ }
+ }
+ jx -= *incx;
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := A'*x or x := conjg( A' )*x. */
+
+ if (lsame_(uplo, "U")) {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__1 = j;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ if (noconj) {
+ if (nounit) {
+ i__1 = j + j * a_dim1;
+ z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i,
+ z__1.i = temp.r * a[i__1].i + temp.i * a[
+ i__1].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ i__1 = i__ + j * a_dim1;
+ i__2 = i__;
+ z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[
+ i__2].i, z__2.i = a[i__1].r * x[i__2].i +
+ a[i__1].i * x[i__2].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L90: */
+ }
+ } else {
+ if (nounit) {
+ d_cnjg(&z__2, &a[j + j * a_dim1]);
+ z__1.r = temp.r * z__2.r - temp.i * z__2.i,
+ z__1.i = temp.r * z__2.i + temp.i *
+ z__2.r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ d_cnjg(&z__3, &a[i__ + j * a_dim1]);
+ i__1 = i__;
+ z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i,
+ z__2.i = z__3.r * x[i__1].i + z__3.i * x[
+ i__1].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L100: */
+ }
+ }
+ i__1 = j;
+ x[i__1].r = temp.r, x[i__1].i = temp.i;
+/* L110: */
+ }
+ } else {
+ jx = kx + (*n - 1) * *incx;
+ for (j = *n; j >= 1; --j) {
+ i__1 = jx;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ ix = jx;
+ if (noconj) {
+ if (nounit) {
+ i__1 = j + j * a_dim1;
+ z__1.r = temp.r * a[i__1].r - temp.i * a[i__1].i,
+ z__1.i = temp.r * a[i__1].i + temp.i * a[
+ i__1].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ ix -= *incx;
+ i__1 = i__ + j * a_dim1;
+ i__2 = ix;
+ z__2.r = a[i__1].r * x[i__2].r - a[i__1].i * x[
+ i__2].i, z__2.i = a[i__1].r * x[i__2].i +
+ a[i__1].i * x[i__2].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L120: */
+ }
+ } else {
+ if (nounit) {
+ d_cnjg(&z__2, &a[j + j * a_dim1]);
+ z__1.r = temp.r * z__2.r - temp.i * z__2.i,
+ z__1.i = temp.r * z__2.i + temp.i *
+ z__2.r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ ix -= *incx;
+ d_cnjg(&z__3, &a[i__ + j * a_dim1]);
+ i__1 = ix;
+ z__2.r = z__3.r * x[i__1].r - z__3.i * x[i__1].i,
+ z__2.i = z__3.r * x[i__1].i + z__3.i * x[
+ i__1].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L130: */
+ }
+ }
+ i__1 = jx;
+ x[i__1].r = temp.r, x[i__1].i = temp.i;
+ jx -= *incx;
+/* L140: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ if (noconj) {
+ if (nounit) {
+ i__2 = j + j * a_dim1;
+ z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
+ z__1.i = temp.r * a[i__2].i + temp.i * a[
+ i__2].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
+ i__4].i, z__2.i = a[i__3].r * x[i__4].i +
+ a[i__3].i * x[i__4].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L150: */
+ }
+ } else {
+ if (nounit) {
+ d_cnjg(&z__2, &a[j + j * a_dim1]);
+ z__1.r = temp.r * z__2.r - temp.i * z__2.i,
+ z__1.i = temp.r * z__2.i + temp.i *
+ z__2.r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ d_cnjg(&z__3, &a[i__ + j * a_dim1]);
+ i__3 = i__;
+ z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
+ z__2.i = z__3.r * x[i__3].i + z__3.i * x[
+ i__3].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L160: */
+ }
+ }
+ i__2 = j;
+ x[i__2].r = temp.r, x[i__2].i = temp.i;
+/* L170: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ ix = jx;
+ if (noconj) {
+ if (nounit) {
+ i__2 = j + j * a_dim1;
+ z__1.r = temp.r * a[i__2].r - temp.i * a[i__2].i,
+ z__1.i = temp.r * a[i__2].i + temp.i * a[
+ i__2].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ ix += *incx;
+ i__3 = i__ + j * a_dim1;
+ i__4 = ix;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
+ i__4].i, z__2.i = a[i__3].r * x[i__4].i +
+ a[i__3].i * x[i__4].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L180: */
+ }
+ } else {
+ if (nounit) {
+ d_cnjg(&z__2, &a[j + j * a_dim1]);
+ z__1.r = temp.r * z__2.r - temp.i * z__2.i,
+ z__1.i = temp.r * z__2.i + temp.i *
+ z__2.r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ ix += *incx;
+ d_cnjg(&z__3, &a[i__ + j * a_dim1]);
+ i__3 = ix;
+ z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
+ z__2.i = z__3.r * x[i__3].i + z__3.i * x[
+ i__3].r;
+ z__1.r = temp.r + z__2.r, z__1.i = temp.i +
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L190: */
+ }
+ }
+ i__2 = jx;
+ x[i__2].r = temp.r, x[i__2].i = temp.i;
+ jx += *incx;
+/* L200: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZTRMV . */
+
+} /* ztrmv_ */
diff --git a/BLAS/SRC/ztrsm.c b/BLAS/SRC/ztrsm.c
new file mode 100644
index 0000000..068744c
--- /dev/null
+++ b/BLAS/SRC/ztrsm.c
@@ -0,0 +1,699 @@
+/* ztrsm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+
+/* Subroutine */ int ztrsm_(char *side, char *uplo, char *transa, char *diag,
+ integer *m, integer *n, doublecomplex *alpha, doublecomplex *a,
+ integer *lda, doublecomplex *b, integer *ldb)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6, i__7;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
+ doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, info;
+ doublecomplex temp;
+ logical lside;
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical noconj, nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTRSM solves one of the matrix equations */
+
+/* op( A )*X = alpha*B, or X*op( A ) = alpha*B, */
+
+/* where alpha is a scalar, X and B are m by n matrices, A is a unit, or */
+/* non-unit, upper or lower triangular matrix and op( A ) is one of */
+
+/* op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). */
+
+/* The matrix X is overwritten on B. */
+
+/* Arguments */
+/* ========== */
+
+/* SIDE - CHARACTER*1. */
+/* On entry, SIDE specifies whether op( A ) appears on the left */
+/* or right of X as follows: */
+
+/* SIDE = 'L' or 'l' op( A )*X = alpha*B. */
+
+/* SIDE = 'R' or 'r' X*op( A ) = alpha*B. */
+
+/* Unchanged on exit. */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix A is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANSA - CHARACTER*1. */
+/* On entry, TRANSA specifies the form of op( A ) to be used in */
+/* the matrix multiplication as follows: */
+
+/* TRANSA = 'N' or 'n' op( A ) = A. */
+
+/* TRANSA = 'T' or 't' op( A ) = A'. */
+
+/* TRANSA = 'C' or 'c' op( A ) = conjg( A' ). */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit triangular */
+/* as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER. */
+/* On entry, M specifies the number of rows of B. M must be at */
+/* least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of B. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX*16 . */
+/* On entry, ALPHA specifies the scalar alpha. When alpha is */
+/* zero then A is not referenced and B need not be set before */
+/* entry. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m */
+/* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. */
+/* Before entry with UPLO = 'U' or 'u', the leading k by k */
+/* upper triangular part of the array A must contain the upper */
+/* triangular matrix and the strictly lower triangular part of */
+/* A is not referenced. */
+/* Before entry with UPLO = 'L' or 'l', the leading k by k */
+/* lower triangular part of the array A must contain the lower */
+/* triangular matrix and the strictly upper triangular part of */
+/* A is not referenced. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced either, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When SIDE = 'L' or 'l' then */
+/* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' */
+/* then LDA must be at least max( 1, n ). */
+/* Unchanged on exit. */
+
+/* B - COMPLEX*16 array of DIMENSION ( LDB, n ). */
+/* Before entry, the leading m by n part of the array B must */
+/* contain the right-hand side matrix B, and on exit is */
+/* overwritten by the solution matrix X. */
+
+/* LDB - INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. LDB must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+
+/* Level 3 Blas routine. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ lside = lsame_(side, "L");
+ if (lside) {
+ nrowa = *m;
+ } else {
+ nrowa = *n;
+ }
+ noconj = lsame_(transa, "T");
+ nounit = lsame_(diag, "N");
+ upper = lsame_(uplo, "U");
+
+ info = 0;
+ if (! lside && ! lsame_(side, "R")) {
+ info = 1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ info = 2;
+ } else if (! lsame_(transa, "N") && ! lsame_(transa,
+ "T") && ! lsame_(transa, "C")) {
+ info = 3;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 4;
+ } else if (*m < 0) {
+ info = 5;
+ } else if (*n < 0) {
+ info = 6;
+ } else if (*lda < max(1,nrowa)) {
+ info = 9;
+ } else if (*ldb < max(1,*m)) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("ZTRSM ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* And when alpha.eq.zero. */
+
+ if (alpha->r == 0. && alpha->i == 0.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0., b[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ return 0;
+ }
+
+/* Start the operations. */
+
+ if (lside) {
+ if (lsame_(transa, "N")) {
+
+/* Form B := alpha*inv( A )*B. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (alpha->r != 1. || alpha->i != 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ z__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4]
+ .i, z__1.i = alpha->r * b[i__4].i +
+ alpha->i * b[i__4].r;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L30: */
+ }
+ }
+ for (k = *m; k >= 1; --k) {
+ i__2 = k + j * b_dim1;
+ if (b[i__2].r != 0. || b[i__2].i != 0.) {
+ if (nounit) {
+ i__2 = k + j * b_dim1;
+ z_div(&z__1, &b[k + j * b_dim1], &a[k + k *
+ a_dim1]);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ }
+ i__2 = k - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = k + j * b_dim1;
+ i__6 = i__ + k * a_dim1;
+ z__2.r = b[i__5].r * a[i__6].r - b[i__5].i *
+ a[i__6].i, z__2.i = b[i__5].r * a[
+ i__6].i + b[i__5].i * a[i__6].r;
+ z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4]
+ .i - z__2.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L40: */
+ }
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (alpha->r != 1. || alpha->i != 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ z__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4]
+ .i, z__1.i = alpha->r * b[i__4].i +
+ alpha->i * b[i__4].r;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L70: */
+ }
+ }
+ i__2 = *m;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * b_dim1;
+ if (b[i__3].r != 0. || b[i__3].i != 0.) {
+ if (nounit) {
+ i__3 = k + j * b_dim1;
+ z_div(&z__1, &b[k + j * b_dim1], &a[k + k *
+ a_dim1]);
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+ }
+ i__3 = *m;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ + j * b_dim1;
+ i__6 = k + j * b_dim1;
+ i__7 = i__ + k * a_dim1;
+ z__2.r = b[i__6].r * a[i__7].r - b[i__6].i *
+ a[i__7].i, z__2.i = b[i__6].r * a[
+ i__7].i + b[i__6].i * a[i__7].r;
+ z__1.r = b[i__5].r - z__2.r, z__1.i = b[i__5]
+ .i - z__2.i;
+ b[i__4].r = z__1.r, b[i__4].i = z__1.i;
+/* L80: */
+ }
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+ }
+ } else {
+
+/* Form B := alpha*inv( A' )*B */
+/* or B := alpha*inv( conjg( A' ) )*B. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
+ z__1.i = alpha->r * b[i__3].i + alpha->i * b[
+ i__3].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ if (noconj) {
+ i__3 = i__ - 1;
+ for (k = 1; k <= i__3; ++k) {
+ i__4 = k + i__ * a_dim1;
+ i__5 = k + j * b_dim1;
+ z__2.r = a[i__4].r * b[i__5].r - a[i__4].i *
+ b[i__5].i, z__2.i = a[i__4].r * b[
+ i__5].i + a[i__4].i * b[i__5].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L110: */
+ }
+ if (nounit) {
+ z_div(&z__1, &temp, &a[i__ + i__ * a_dim1]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ } else {
+ i__3 = i__ - 1;
+ for (k = 1; k <= i__3; ++k) {
+ d_cnjg(&z__3, &a[k + i__ * a_dim1]);
+ i__4 = k + j * b_dim1;
+ z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4]
+ .i, z__2.i = z__3.r * b[i__4].i +
+ z__3.i * b[i__4].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L120: */
+ }
+ if (nounit) {
+ d_cnjg(&z__2, &a[i__ + i__ * a_dim1]);
+ z_div(&z__1, &temp, &z__2);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ }
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = temp.r, b[i__3].i = temp.i;
+/* L130: */
+ }
+/* L140: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (i__ = *m; i__ >= 1; --i__) {
+ i__2 = i__ + j * b_dim1;
+ z__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2].i,
+ z__1.i = alpha->r * b[i__2].i + alpha->i * b[
+ i__2].r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ if (noconj) {
+ i__2 = *m;
+ for (k = i__ + 1; k <= i__2; ++k) {
+ i__3 = k + i__ * a_dim1;
+ i__4 = k + j * b_dim1;
+ z__2.r = a[i__3].r * b[i__4].r - a[i__3].i *
+ b[i__4].i, z__2.i = a[i__3].r * b[
+ i__4].i + a[i__3].i * b[i__4].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L150: */
+ }
+ if (nounit) {
+ z_div(&z__1, &temp, &a[i__ + i__ * a_dim1]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ } else {
+ i__2 = *m;
+ for (k = i__ + 1; k <= i__2; ++k) {
+ d_cnjg(&z__3, &a[k + i__ * a_dim1]);
+ i__3 = k + j * b_dim1;
+ z__2.r = z__3.r * b[i__3].r - z__3.i * b[i__3]
+ .i, z__2.i = z__3.r * b[i__3].i +
+ z__3.i * b[i__3].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L160: */
+ }
+ if (nounit) {
+ d_cnjg(&z__2, &a[i__ + i__ * a_dim1]);
+ z_div(&z__1, &temp, &z__2);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ }
+ i__2 = i__ + j * b_dim1;
+ b[i__2].r = temp.r, b[i__2].i = temp.i;
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+ }
+ } else {
+ if (lsame_(transa, "N")) {
+
+/* Form B := alpha*B*inv( A ). */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (alpha->r != 1. || alpha->i != 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ z__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4]
+ .i, z__1.i = alpha->r * b[i__4].i +
+ alpha->i * b[i__4].r;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L190: */
+ }
+ }
+ i__2 = j - 1;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * a_dim1;
+ if (a[i__3].r != 0. || a[i__3].i != 0.) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ + j * b_dim1;
+ i__6 = k + j * a_dim1;
+ i__7 = i__ + k * b_dim1;
+ z__2.r = a[i__6].r * b[i__7].r - a[i__6].i *
+ b[i__7].i, z__2.i = a[i__6].r * b[
+ i__7].i + a[i__6].i * b[i__7].r;
+ z__1.r = b[i__5].r - z__2.r, z__1.i = b[i__5]
+ .i - z__2.i;
+ b[i__4].r = z__1.r, b[i__4].i = z__1.i;
+/* L200: */
+ }
+ }
+/* L210: */
+ }
+ if (nounit) {
+ z_div(&z__1, &c_b1, &a[j + j * a_dim1]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ z__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i,
+ z__1.i = temp.r * b[i__4].i + temp.i * b[
+ i__4].r;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L220: */
+ }
+ }
+/* L230: */
+ }
+ } else {
+ for (j = *n; j >= 1; --j) {
+ if (alpha->r != 1. || alpha->i != 0.) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3]
+ .i, z__1.i = alpha->r * b[i__3].i +
+ alpha->i * b[i__3].r;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L240: */
+ }
+ }
+ i__1 = *n;
+ for (k = j + 1; k <= i__1; ++k) {
+ i__2 = k + j * a_dim1;
+ if (a[i__2].r != 0. || a[i__2].i != 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = k + j * a_dim1;
+ i__6 = i__ + k * b_dim1;
+ z__2.r = a[i__5].r * b[i__6].r - a[i__5].i *
+ b[i__6].i, z__2.i = a[i__5].r * b[
+ i__6].i + a[i__5].i * b[i__6].r;
+ z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4]
+ .i - z__2.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L250: */
+ }
+ }
+/* L260: */
+ }
+ if (nounit) {
+ z_div(&z__1, &c_b1, &a[j + j * a_dim1]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ z__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i,
+ z__1.i = temp.r * b[i__3].i + temp.i * b[
+ i__3].r;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L270: */
+ }
+ }
+/* L280: */
+ }
+ }
+ } else {
+
+/* Form B := alpha*B*inv( A' ) */
+/* or B := alpha*B*inv( conjg( A' ) ). */
+
+ if (upper) {
+ for (k = *n; k >= 1; --k) {
+ if (nounit) {
+ if (noconj) {
+ z_div(&z__1, &c_b1, &a[k + k * a_dim1]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ } else {
+ d_cnjg(&z__2, &a[k + k * a_dim1]);
+ z_div(&z__1, &c_b1, &z__2);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + k * b_dim1;
+ i__3 = i__ + k * b_dim1;
+ z__1.r = temp.r * b[i__3].r - temp.i * b[i__3].i,
+ z__1.i = temp.r * b[i__3].i + temp.i * b[
+ i__3].r;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L290: */
+ }
+ }
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + k * a_dim1;
+ if (a[i__2].r != 0. || a[i__2].i != 0.) {
+ if (noconj) {
+ i__2 = j + k * a_dim1;
+ temp.r = a[i__2].r, temp.i = a[i__2].i;
+ } else {
+ d_cnjg(&z__1, &a[j + k * a_dim1]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ + k * b_dim1;
+ z__2.r = temp.r * b[i__5].r - temp.i * b[i__5]
+ .i, z__2.i = temp.r * b[i__5].i +
+ temp.i * b[i__5].r;
+ z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4]
+ .i - z__2.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L300: */
+ }
+ }
+/* L310: */
+ }
+ if (alpha->r != 1. || alpha->i != 0.) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + k * b_dim1;
+ i__3 = i__ + k * b_dim1;
+ z__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3]
+ .i, z__1.i = alpha->r * b[i__3].i +
+ alpha->i * b[i__3].r;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L320: */
+ }
+ }
+/* L330: */
+ }
+ } else {
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (nounit) {
+ if (noconj) {
+ z_div(&z__1, &c_b1, &a[k + k * a_dim1]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ } else {
+ d_cnjg(&z__2, &a[k + k * a_dim1]);
+ z_div(&z__1, &c_b1, &z__2);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ i__4 = i__ + k * b_dim1;
+ z__1.r = temp.r * b[i__4].r - temp.i * b[i__4].i,
+ z__1.i = temp.r * b[i__4].i + temp.i * b[
+ i__4].r;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L340: */
+ }
+ }
+ i__2 = *n;
+ for (j = k + 1; j <= i__2; ++j) {
+ i__3 = j + k * a_dim1;
+ if (a[i__3].r != 0. || a[i__3].i != 0.) {
+ if (noconj) {
+ i__3 = j + k * a_dim1;
+ temp.r = a[i__3].r, temp.i = a[i__3].i;
+ } else {
+ d_cnjg(&z__1, &a[j + k * a_dim1]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ + j * b_dim1;
+ i__6 = i__ + k * b_dim1;
+ z__2.r = temp.r * b[i__6].r - temp.i * b[i__6]
+ .i, z__2.i = temp.r * b[i__6].i +
+ temp.i * b[i__6].r;
+ z__1.r = b[i__5].r - z__2.r, z__1.i = b[i__5]
+ .i - z__2.i;
+ b[i__4].r = z__1.r, b[i__4].i = z__1.i;
+/* L350: */
+ }
+ }
+/* L360: */
+ }
+ if (alpha->r != 1. || alpha->i != 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ i__4 = i__ + k * b_dim1;
+ z__1.r = alpha->r * b[i__4].r - alpha->i * b[i__4]
+ .i, z__1.i = alpha->r * b[i__4].i +
+ alpha->i * b[i__4].r;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L370: */
+ }
+ }
+/* L380: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZTRSM . */
+
+} /* ztrsm_ */
diff --git a/BLAS/SRC/ztrsv.c b/BLAS/SRC/ztrsv.c
new file mode 100644
index 0000000..df3205f
--- /dev/null
+++ b/BLAS/SRC/ztrsv.c
@@ -0,0 +1,524 @@
+/* ztrsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ztrsv_(char *uplo, char *trans, char *diag, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *x, integer *incx)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
+ doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, ix, jx, kx, info;
+ doublecomplex temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical noconj, nounit;
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTRSV solves one of the systems of equations */
+
+/* A*x = b, or A'*x = b, or conjg( A' )*x = b, */
+
+/* where b and x are n element vectors and A is an n by n unit, or */
+/* non-unit, upper or lower triangular matrix. */
+
+/* No test for singularity or near-singularity is included in this */
+/* routine. Such tests must be performed before calling this routine. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1. */
+/* On entry, UPLO specifies whether the matrix is an upper or */
+/* lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' A is an upper triangular matrix. */
+
+/* UPLO = 'L' or 'l' A is a lower triangular matrix. */
+
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1. */
+/* On entry, TRANS specifies the equations to be solved as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' A*x = b. */
+
+/* TRANS = 'T' or 't' A'*x = b. */
+
+/* TRANS = 'C' or 'c' conjg( A' )*x = b. */
+
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1. */
+/* On entry, DIAG specifies whether or not A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */
+/* Before entry with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular matrix and the strictly lower triangular part of */
+/* A is not referenced. */
+/* Before entry with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular matrix and the strictly upper triangular part of */
+/* A is not referenced. */
+/* Note that when DIAG = 'U' or 'u', the diagonal elements of */
+/* A are not referenced either, but are assumed to be unity. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX*16 array of dimension at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the n */
+/* element right-hand side vector b. On exit, X is overwritten */
+/* with the solution vector x. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ info = 2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ info = 3;
+ } else if (*n < 0) {
+ info = 4;
+ } else if (*lda < max(1,*n)) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ }
+ if (info != 0) {
+ xerbla_("ZTRSV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ noconj = lsame_(trans, "T");
+ nounit = lsame_(diag, "N");
+
+/* Set up the start point in X if the increment is not unity. This */
+/* will be ( N - 1 )*INCX too small for descending loops. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through A. */
+
+ if (lsame_(trans, "N")) {
+
+/* Form x := inv( A )*x. */
+
+ if (lsame_(uplo, "U")) {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__1 = j;
+ if (x[i__1].r != 0. || x[i__1].i != 0.) {
+ if (nounit) {
+ i__1 = j;
+ z_div(&z__1, &x[j], &a[j + j * a_dim1]);
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ }
+ i__1 = j;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ i__1 = i__;
+ i__2 = i__;
+ i__3 = i__ + j * a_dim1;
+ z__2.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
+ z__2.i = temp.r * a[i__3].i + temp.i * a[
+ i__3].r;
+ z__1.r = x[i__2].r - z__2.r, z__1.i = x[i__2].i -
+ z__2.i;
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+/* L10: */
+ }
+ }
+/* L20: */
+ }
+ } else {
+ jx = kx + (*n - 1) * *incx;
+ for (j = *n; j >= 1; --j) {
+ i__1 = jx;
+ if (x[i__1].r != 0. || x[i__1].i != 0.) {
+ if (nounit) {
+ i__1 = jx;
+ z_div(&z__1, &x[jx], &a[j + j * a_dim1]);
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ }
+ i__1 = jx;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ ix = jx;
+ for (i__ = j - 1; i__ >= 1; --i__) {
+ ix -= *incx;
+ i__1 = ix;
+ i__2 = ix;
+ i__3 = i__ + j * a_dim1;
+ z__2.r = temp.r * a[i__3].r - temp.i * a[i__3].i,
+ z__2.i = temp.r * a[i__3].i + temp.i * a[
+ i__3].r;
+ z__1.r = x[i__2].r - z__2.r, z__1.i = x[i__2].i -
+ z__2.i;
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+/* L30: */
+ }
+ }
+ jx -= *incx;
+/* L40: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ if (nounit) {
+ i__2 = j;
+ z_div(&z__1, &x[j], &a[j + j * a_dim1]);
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ }
+ i__2 = j;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ z__2.i = temp.r * a[i__5].i + temp.i * a[
+ i__5].r;
+ z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i -
+ z__2.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ if (nounit) {
+ i__2 = jx;
+ z_div(&z__1, &x[jx], &a[j + j * a_dim1]);
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ }
+ i__2 = jx;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ ix = jx;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ ix += *incx;
+ i__3 = ix;
+ i__4 = ix;
+ i__5 = i__ + j * a_dim1;
+ z__2.r = temp.r * a[i__5].r - temp.i * a[i__5].i,
+ z__2.i = temp.r * a[i__5].i + temp.i * a[
+ i__5].r;
+ z__1.r = x[i__4].r - z__2.r, z__1.i = x[i__4].i -
+ z__2.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+/* L70: */
+ }
+ }
+ jx += *incx;
+/* L80: */
+ }
+ }
+ }
+ } else {
+
+/* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. */
+
+ if (lsame_(uplo, "U")) {
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ if (noconj) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
+ i__4].i, z__2.i = a[i__3].r * x[i__4].i +
+ a[i__3].i * x[i__4].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L90: */
+ }
+ if (nounit) {
+ z_div(&z__1, &temp, &a[j + j * a_dim1]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ } else {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ d_cnjg(&z__3, &a[i__ + j * a_dim1]);
+ i__3 = i__;
+ z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
+ z__2.i = z__3.r * x[i__3].i + z__3.i * x[
+ i__3].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L100: */
+ }
+ if (nounit) {
+ d_cnjg(&z__2, &a[j + j * a_dim1]);
+ z_div(&z__1, &temp, &z__2);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ }
+ i__2 = j;
+ x[i__2].r = temp.r, x[i__2].i = temp.i;
+/* L110: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ix = kx;
+ i__2 = jx;
+ temp.r = x[i__2].r, temp.i = x[i__2].i;
+ if (noconj) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = ix;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[
+ i__4].i, z__2.i = a[i__3].r * x[i__4].i +
+ a[i__3].i * x[i__4].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix += *incx;
+/* L120: */
+ }
+ if (nounit) {
+ z_div(&z__1, &temp, &a[j + j * a_dim1]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ } else {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ d_cnjg(&z__3, &a[i__ + j * a_dim1]);
+ i__3 = ix;
+ z__2.r = z__3.r * x[i__3].r - z__3.i * x[i__3].i,
+ z__2.i = z__3.r * x[i__3].i + z__3.i * x[
+ i__3].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix += *incx;
+/* L130: */
+ }
+ if (nounit) {
+ d_cnjg(&z__2, &a[j + j * a_dim1]);
+ z_div(&z__1, &temp, &z__2);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ }
+ i__2 = jx;
+ x[i__2].r = temp.r, x[i__2].i = temp.i;
+ jx += *incx;
+/* L140: */
+ }
+ }
+ } else {
+ if (*incx == 1) {
+ for (j = *n; j >= 1; --j) {
+ i__1 = j;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ if (noconj) {
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ i__2 = i__ + j * a_dim1;
+ i__3 = i__;
+ z__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[
+ i__3].i, z__2.i = a[i__2].r * x[i__3].i +
+ a[i__2].i * x[i__3].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L150: */
+ }
+ if (nounit) {
+ z_div(&z__1, &temp, &a[j + j * a_dim1]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ } else {
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ d_cnjg(&z__3, &a[i__ + j * a_dim1]);
+ i__2 = i__;
+ z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i,
+ z__2.i = z__3.r * x[i__2].i + z__3.i * x[
+ i__2].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+/* L160: */
+ }
+ if (nounit) {
+ d_cnjg(&z__2, &a[j + j * a_dim1]);
+ z_div(&z__1, &temp, &z__2);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ }
+ i__1 = j;
+ x[i__1].r = temp.r, x[i__1].i = temp.i;
+/* L170: */
+ }
+ } else {
+ kx += (*n - 1) * *incx;
+ jx = kx;
+ for (j = *n; j >= 1; --j) {
+ ix = kx;
+ i__1 = jx;
+ temp.r = x[i__1].r, temp.i = x[i__1].i;
+ if (noconj) {
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ i__2 = i__ + j * a_dim1;
+ i__3 = ix;
+ z__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[
+ i__3].i, z__2.i = a[i__2].r * x[i__3].i +
+ a[i__2].i * x[i__3].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix -= *incx;
+/* L180: */
+ }
+ if (nounit) {
+ z_div(&z__1, &temp, &a[j + j * a_dim1]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ } else {
+ i__1 = j + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ d_cnjg(&z__3, &a[i__ + j * a_dim1]);
+ i__2 = ix;
+ z__2.r = z__3.r * x[i__2].r - z__3.i * x[i__2].i,
+ z__2.i = z__3.r * x[i__2].i + z__3.i * x[
+ i__2].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i -
+ z__2.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix -= *incx;
+/* L190: */
+ }
+ if (nounit) {
+ d_cnjg(&z__2, &a[j + j * a_dim1]);
+ z_div(&z__1, &temp, &z__2);
+ temp.r = z__1.r, temp.i = z__1.i;
+ }
+ }
+ i__1 = jx;
+ x[i__1].r = temp.r, x[i__1].i = temp.i;
+ jx -= *incx;
+/* L200: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZTRSV . */
+
+} /* ztrsv_ */
diff --git a/BLAS/TESTING/CMakeLists.txt b/BLAS/TESTING/CMakeLists.txt
new file mode 100644
index 0000000..ec2c587
--- /dev/null
+++ b/BLAS/TESTING/CMakeLists.txt
@@ -0,0 +1,63 @@
+#######################################################################
+# This makefile creates the test programs for the BLAS 1 routines.
+# The test files are grouped as follows:
+# SBLAT1 -- Single precision real test routines
+# CBLAT1 -- Single precision complex test routines
+# DBLAT1 -- Double precision real test routines
+# ZBLAT1 -- Double precision complex test routines
+#
+# Test programs can be generated for all or some of the four different
+# precisions. To create the test programs, enter make followed by one
+# or more of the precisions desired. Some examples:
+# make single
+# make single complex
+# make single double complex complex16
+# Alternatively, the command
+# make
+# without any arguments creates all four test programs.
+# The executable files which are created are called
+# ../xblat1s, ../xblat1d, ../xblat1c, and ../xblat1z
+#
+# To remove the object files after the executable files have been
+# created, enter
+# make clean
+# To force the source files to be recompiled, enter, for example,
+# make single FRC=FRC
+#
+#######################################################################
+
+macro(add_blas_test name src)
+ get_filename_component(baseNAME ${src} NAME_WE)
+ set(TEST_INPUT "${CLAPACK_SOURCE_DIR}/BLAS/${baseNAME}.in")
+ add_executable(${name} ${src})
+ get_target_property(TEST_LOC ${name} LOCATION)
+ target_link_libraries(${name} blas)
+ if(EXISTS "${TEST_INPUT}")
+ add_test(${name} "${CMAKE_COMMAND}"
+ -DTEST=${TEST_LOC}
+ -DINPUT=${TEST_INPUT}
+ -DINTDIR=${CMAKE_CFG_INTDIR}
+ -P "${CLAPACK_SOURCE_DIR}/TESTING/runtest.cmake")
+ else()
+ add_test(${name} "${CMAKE_COMMAND}"
+ -DTEST=${TEST_LOC}
+ -DINTDIR=${CMAKE_CFG_INTDIR}
+ -P "${CLAPACK_SOURCE_DIR}/TESTING/runtest.cmake")
+ endif()
+endmacro(add_blas_test)
+
+add_blas_test(xblat1s sblat1.c)
+add_blas_test(xblat1c cblat1.c)
+add_blas_test(xblat1d dblat1.c)
+add_blas_test(xblat1z zblat1.c)
+
+add_blas_test(xblat2s sblat2.c sblat2.in)
+add_blas_test(xblat2c cblat2.c )
+add_blas_test(xblat2d dblat2.c)
+add_blas_test(xblat2z zblat2.c)
+
+add_blas_test(xblat3s sblat3.c)
+add_blas_test(xblat3c cblat3.c)
+add_blas_test(xblat3d dblat3.c)
+add_blas_test(xblat3z zblat3.c)
+
diff --git a/BLAS/TESTING/Makeblat1 b/BLAS/TESTING/Makeblat1
new file mode 100644
index 0000000..c689338
--- /dev/null
+++ b/BLAS/TESTING/Makeblat1
@@ -0,0 +1,74 @@
+include ../../make.inc
+
+#######################################################################
+# This makefile creates the test programs for the BLAS 1 routines.
+# The test files are grouped as follows:
+# SBLAT1 -- Single precision real test routines
+# CBLAT1 -- Single precision complex test routines
+# DBLAT1 -- Double precision real test routines
+# ZBLAT1 -- Double precision complex test routines
+#
+# Test programs can be generated for all or some of the four different
+# precisions. To create the test programs, enter make followed by one
+# or more of the precisions desired. Some examples:
+# make single
+# make single complex
+# make single double complex complex16
+# Alternatively, the command
+# make
+# without any arguments creates all four test programs.
+# The executable files which are created are called
+# ../xblat1s, ../xblat1d, ../xblat1c, and ../xblat1z
+#
+# To remove the object files after the executable files have been
+# created, enter
+# make clean
+# To force the source files to be recompiled, enter, for example,
+# make single FRC=FRC
+#
+#######################################################################
+
+SBLAT1 = sblat1.o
+
+CBLAT1 = cblat1.o
+
+DBLAT1 = dblat1.o
+
+ZBLAT1 = zblat1.o
+
+all: single double complex complex16
+
+single: ../xblat1s
+double: ../xblat1d
+complex: ../xblat1c
+complex16: ../xblat1z
+
+../xblat1s: $(SBLAT1)
+ $(CC) $(LOADOPTS) $(SBLAT1) \
+ $(BLASLIB) $(F2CLIB) -lm -o ../xblat1s
+
+../xblat1c: $(CBLAT1)
+ $(CC) $(LOADOPTS) $(CBLAT1) \
+ $(BLASLIB) $(F2CLIB) -lm -o ../xblat1c
+
+../xblat1d: $(DBLAT1)
+ $(CC) $(LOADOPTS) $(DBLAT1) \
+ $(BLASLIB) $(F2CLIB) -lm -o ../xblat1d
+
+../xblat1z: $(ZBLAT1)
+ $(CC) $(LOADOPTS) $(ZBLAT1) \
+ $(BLASLIB) $(F2CLIB) -lm -o ../xblat1z
+
+$(SBLAT1): $(FRC)
+$(CBLAT1): $(FRC)
+$(DBLAT1): $(FRC)
+$(ZBLAT1): $(FRC)
+
+FRC:
+ @FRC=$(FRC)
+
+clean:
+ rm -f *.o
+
+.c.o:
+ $(CC) $(CFLAGS) -I../../INCLUDE -c $< -o $@
diff --git a/BLAS/TESTING/Makeblat2 b/BLAS/TESTING/Makeblat2
new file mode 100644
index 0000000..e2ff192
--- /dev/null
+++ b/BLAS/TESTING/Makeblat2
@@ -0,0 +1,74 @@
+include ../../make.inc
+
+#######################################################################
+# This makefile creates the test programs for the BLAS 2 routines.
+# The test files are grouped as follows:
+# SBLAT2 -- Single precision real test routines
+# CBLAT2 -- Single precision complex test routines
+# DBLAT2 -- Double precision real test routines
+# ZBLAT2 -- Double precision complex test routines
+#
+# Test programs can be generated for all or some of the four different
+# precisions. To create the test programs, enter make followed by one
+# or more of the precisions desired. Some examples:
+# make single
+# make single complex
+# make single double complex complex16
+# Alternatively, the command
+# make
+# without any arguments creates all four test programs.
+# The executable files which are created are called
+# ../xblat2s, ../xblat2d, ../xblat2c, and ../xblat2z
+#
+# To remove the object files after the executable files have been
+# created, enter
+# make clean
+# To force the source files to be recompiled, enter, for example,
+# make single FRC=FRC
+#
+#######################################################################
+
+SBLAT2 = sblat2.o
+
+CBLAT2 = cblat2.o
+
+DBLAT2 = dblat2.o
+
+ZBLAT2 = zblat2.o
+
+all: single double complex complex16
+
+single: ../xblat2s
+double: ../xblat2d
+complex: ../xblat2c
+complex16: ../xblat2z
+
+../xblat2s: $(SBLAT2)
+ $(CC) $(LOADOPTS) $(SBLAT2) \
+ $(BLASLIB) $(F2CLIB) -lm -o ../xblat2s
+
+../xblat2c: $(CBLAT2)
+ $(CC) $(LOADOPTS) $(CBLAT2) \
+ $(BLASLIB) $(F2CLIB) -lm -o ../xblat2c
+
+../xblat2d: $(DBLAT2)
+ $(CC) $(LOADOPTS) $(DBLAT2) \
+ $(BLASLIB) $(F2CLIB) -lm -o ../xblat2d
+
+../xblat2z: $(ZBLAT2)
+ $(CC) $(LOADOPTS) $(ZBLAT2) \
+ $(BLASLIB) $(F2CLIB) -lm -o ../xblat2z
+
+$(SBLAT2): $(FRC)
+$(CBLAT2): $(FRC)
+$(DBLAT2): $(FRC)
+$(ZBLAT2): $(FRC)
+
+FRC:
+ @FRC=$(FRC)
+
+clean:
+ rm -f *.o
+
+.c.o:
+ $(CC) $(CFLAGS) -I../../INCLUDE -c $< -o $@
diff --git a/BLAS/TESTING/Makeblat3 b/BLAS/TESTING/Makeblat3
new file mode 100644
index 0000000..4a2e232
--- /dev/null
+++ b/BLAS/TESTING/Makeblat3
@@ -0,0 +1,74 @@
+include ../../make.inc
+
+#######################################################################
+# This makefile creates the test programs for the BLAS 3 routines.
+# The test files are grouped as follows:
+# SBLAT3 -- Single precision real test routines
+# CBLAT3 -- Single precision complex test routines
+# DBLAT3 -- Double precision real test routines
+# ZBLAT3 -- Double precision complex test routines
+#
+# Test programs can be generated for all or some of the four different
+# precisions. To create the test programs, enter make followed by one
+# or more of the precisions desired. Some examples:
+# make single
+# make single complex
+# make single double complex complex16
+# Alternatively, the command
+# make
+# without any arguments creates all four test programs.
+# The executable files which are created are called
+# ../xblat3s, ../xblat3d, ../xblat3c, and ../xblat3z
+#
+# To remove the object files after the executable files have been
+# created, enter
+# make clean
+# To force the source files to be recompiled, enter, for example,
+# make single FRC=FRC
+#
+#######################################################################
+
+SBLAT3 = sblat3.o
+
+CBLAT3 = cblat3.o
+
+DBLAT3 = dblat3.o
+
+ZBLAT3 = zblat3.o
+
+all: single double complex complex16
+
+single: ../xblat3s
+double: ../xblat3d
+complex: ../xblat3c
+complex16: ../xblat3z
+
+../xblat3s: $(SBLAT3)
+ $(CC) $(LOADOPTS) $(SBLAT3) \
+ $(BLASLIB) $(F2CLIB) -lm -o ../xblat3s
+
+../xblat3c: $(CBLAT3)
+ $(CC) $(LOADOPTS) $(CBLAT3) \
+ $(BLASLIB) $(F2CLIB) -lm -o ../xblat3c
+
+../xblat3d: $(DBLAT3)
+ $(CC) $(LOADOPTS) $(DBLAT3) \
+ $(BLASLIB) $(F2CLIB) -lm -o ../xblat3d
+
+../xblat3z: $(ZBLAT3)
+ $(CC) $(LOADOPTS) $(ZBLAT3) \
+ $(BLASLIB) $(F2CLIB) -lm -o ../xblat3z
+
+$(SBLAT3): $(FRC)
+$(CBLAT3): $(FRC)
+$(DBLAT3): $(FRC)
+$(ZBLAT3): $(FRC)
+
+FRC:
+ @FRC=$(FRC)
+
+clean:
+ rm -f *.o
+
+.c.o:
+ $(CC) $(CFLAGS) -I../../INCLUDE -c $< -o $@
diff --git a/BLAS/TESTING/cblat1.c b/BLAS/TESTING/cblat1.c
new file mode 100644
index 0000000..c282339
--- /dev/null
+++ b/BLAS/TESTING/cblat1.c
@@ -0,0 +1,789 @@
+/* cblat1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer icase, n, incx, incy, mode;
+ logical pass;
+} combla_;
+
+#define combla_1 combla_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__9 = 9;
+static integer c__5 = 5;
+static real c_b43 = 1.f;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Initialized data */
+
+ static real sfac = 9.765625e-4f;
+
+ /* Format strings */
+ static char fmt_99999[] = "(\002 Complex BLAS Test Program Results\002,/"
+ "1x)";
+ static char fmt_99998[] = "(\002 ----"
+ "- PASS -----\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), e_wsfe(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+
+ /* Local variables */
+ integer ic;
+ extern /* Subroutine */ int check1_(real *), check2_(real *), header_(
+ void);
+
+ /* Fortran I/O blocks */
+ static cilist io___2 = { 0, 6, 0, fmt_99999, 0 };
+ static cilist io___4 = { 0, 6, 0, fmt_99998, 0 };
+
+
+/* Test program for the COMPLEX Level 1 BLAS. */
+/* Based upon the original BLAS test routine together with: */
+/* F06GAF Example Program Text */
+/* .. Parameters .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. External Subroutines .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+ s_wsfe(&io___2);
+ e_wsfe();
+ for (ic = 1; ic <= 10; ++ic) {
+ combla_1.icase = ic;
+ header_();
+
+/* Initialize PASS, INCX, INCY, and MODE for a new case. */
+/* The value 9999 for INCX, INCY or MODE will appear in the */
+/* detailed output, if any, for cases that do not involve */
+/* these parameters. */
+
+ combla_1.pass = TRUE_;
+ combla_1.incx = 9999;
+ combla_1.incy = 9999;
+ combla_1.mode = 9999;
+ if (combla_1.icase <= 5) {
+ check2_(&sfac);
+ } else if (combla_1.icase >= 6) {
+ check1_(&sfac);
+ }
+/* -- Print */
+ if (combla_1.pass) {
+ s_wsfe(&io___4);
+ e_wsfe();
+ }
+/* L20: */
+ }
+ s_stop("", (ftnlen)0);
+
+ return 0;
+} /* MAIN__ */
+
+/* Subroutine */ int header_(void)
+{
+ /* Initialized data */
+
+ static char l[6*10] = "CDOTC " "CDOTU " "CAXPY " "CCOPY " "CSWAP " "SCNR"
+ "M2" "SCASUM" "CSCAL " "CSSCAL" "ICAMAX";
+
+ /* Format strings */
+ static char fmt_99999[] = "(/\002 Test of subprogram number\002,i3,12x,a"
+ "6)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 6, 0, fmt_99999, 0 };
+
+
+/* .. Parameters .. */
+/* .. Scalars in Common .. */
+/* .. Local Arrays .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+ s_wsfe(&io___6);
+ do_fio(&c__1, (char *)&combla_1.icase, (ftnlen)sizeof(integer));
+ do_fio(&c__1, l + (0 + (0 + (combla_1.icase - 1) * 6)), (ftnlen)6);
+ e_wsfe();
+ return 0;
+
+} /* header_ */
+
+/* Subroutine */ int check1_(real *sfac)
+{
+ /* Initialized data */
+
+ static real strue2[5] = { 0.f,.5f,.6f,.7f,.8f };
+ static real strue4[5] = { 0.f,.7f,1.f,1.3f,1.6f };
+ static complex ctrue5[80] /* was [8][5][2] */ = { {.1f,.1f},{1.f,2.f},{
+ 1.f,2.f},{1.f,2.f},{1.f,2.f},{1.f,2.f},{1.f,2.f},{1.f,2.f},{-.16f,
+ -.37f},{3.f,4.f},{3.f,4.f},{3.f,4.f},{3.f,4.f},{3.f,4.f},{3.f,4.f}
+ ,{3.f,4.f},{-.17f,-.19f},{.13f,-.39f},{5.f,6.f},{5.f,6.f},{5.f,
+ 6.f},{5.f,6.f},{5.f,6.f},{5.f,6.f},{.11f,-.03f},{-.17f,.46f},{
+ -.17f,-.19f},{7.f,8.f},{7.f,8.f},{7.f,8.f},{7.f,8.f},{7.f,8.f},{
+ .19f,-.17f},{.2f,-.35f},{.35f,.2f},{.14f,.08f},{2.f,3.f},{2.f,3.f}
+ ,{2.f,3.f},{2.f,3.f},{.1f,.1f},{4.f,5.f},{4.f,5.f},{4.f,5.f},{4.f,
+ 5.f},{4.f,5.f},{4.f,5.f},{4.f,5.f},{-.16f,-.37f},{6.f,7.f},{6.f,
+ 7.f},{6.f,7.f},{6.f,7.f},{6.f,7.f},{6.f,7.f},{6.f,7.f},{-.17f,
+ -.19f},{8.f,9.f},{.13f,-.39f},{2.f,5.f},{2.f,5.f},{2.f,5.f},{2.f,
+ 5.f},{2.f,5.f},{.11f,-.03f},{3.f,6.f},{-.17f,.46f},{4.f,7.f},{
+ -.17f,-.19f},{7.f,2.f},{7.f,2.f},{7.f,2.f},{.19f,-.17f},{5.f,8.f},
+ {.2f,-.35f},{6.f,9.f},{.35f,.2f},{8.f,3.f},{.14f,.08f},{9.f,4.f} }
+ ;
+ static complex ctrue6[80] /* was [8][5][2] */ = { {.1f,.1f},{1.f,2.f},{
+ 1.f,2.f},{1.f,2.f},{1.f,2.f},{1.f,2.f},{1.f,2.f},{1.f,2.f},{.09f,
+ -.12f},{3.f,4.f},{3.f,4.f},{3.f,4.f},{3.f,4.f},{3.f,4.f},{3.f,4.f}
+ ,{3.f,4.f},{.03f,-.09f},{.15f,-.03f},{5.f,6.f},{5.f,6.f},{5.f,6.f}
+ ,{5.f,6.f},{5.f,6.f},{5.f,6.f},{.03f,.03f},{-.18f,.03f},{.03f,
+ -.09f},{7.f,8.f},{7.f,8.f},{7.f,8.f},{7.f,8.f},{7.f,8.f},{.09f,
+ .03f},{.15f,0.f},{0.f,.15f},{0.f,.06f},{2.f,3.f},{2.f,3.f},{2.f,
+ 3.f},{2.f,3.f},{.1f,.1f},{4.f,5.f},{4.f,5.f},{4.f,5.f},{4.f,5.f},{
+ 4.f,5.f},{4.f,5.f},{4.f,5.f},{.09f,-.12f},{6.f,7.f},{6.f,7.f},{
+ 6.f,7.f},{6.f,7.f},{6.f,7.f},{6.f,7.f},{6.f,7.f},{.03f,-.09f},{
+ 8.f,9.f},{.15f,-.03f},{2.f,5.f},{2.f,5.f},{2.f,5.f},{2.f,5.f},{
+ 2.f,5.f},{.03f,.03f},{3.f,6.f},{-.18f,.03f},{4.f,7.f},{.03f,-.09f}
+ ,{7.f,2.f},{7.f,2.f},{7.f,2.f},{.09f,.03f},{5.f,8.f},{.15f,0.f},{
+ 6.f,9.f},{0.f,.15f},{8.f,3.f},{0.f,.06f},{9.f,4.f} };
+ static integer itrue3[5] = { 0,1,2,2,2 };
+ static real sa = .3f;
+ static complex ca = {.4f,-.7f};
+ static complex cv[80] /* was [8][5][2] */ = { {.1f,.1f},{1.f,2.f},{
+ 1.f,2.f},{1.f,2.f},{1.f,2.f},{1.f,2.f},{1.f,2.f},{1.f,2.f},{.3f,
+ -.4f},{3.f,4.f},{3.f,4.f},{3.f,4.f},{3.f,4.f},{3.f,4.f},{3.f,4.f},
+ {3.f,4.f},{.1f,-.3f},{.5f,-.1f},{5.f,6.f},{5.f,6.f},{5.f,6.f},{
+ 5.f,6.f},{5.f,6.f},{5.f,6.f},{.1f,.1f},{-.6f,.1f},{.1f,-.3f},{7.f,
+ 8.f},{7.f,8.f},{7.f,8.f},{7.f,8.f},{7.f,8.f},{.3f,.1f},{.5f,0.f},{
+ 0.f,.5f},{0.f,.2f},{2.f,3.f},{2.f,3.f},{2.f,3.f},{2.f,3.f},{.1f,
+ .1f},{4.f,5.f},{4.f,5.f},{4.f,5.f},{4.f,5.f},{4.f,5.f},{4.f,5.f},{
+ 4.f,5.f},{.3f,-.4f},{6.f,7.f},{6.f,7.f},{6.f,7.f},{6.f,7.f},{6.f,
+ 7.f},{6.f,7.f},{6.f,7.f},{.1f,-.3f},{8.f,9.f},{.5f,-.1f},{2.f,5.f}
+ ,{2.f,5.f},{2.f,5.f},{2.f,5.f},{2.f,5.f},{.1f,.1f},{3.f,6.f},{
+ -.6f,.1f},{4.f,7.f},{.1f,-.3f},{7.f,2.f},{7.f,2.f},{7.f,2.f},{.3f,
+ .1f},{5.f,8.f},{.5f,0.f},{6.f,9.f},{0.f,.5f},{8.f,3.f},{0.f,.2f},{
+ 9.f,4.f} };
+
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real r__1;
+ complex q__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_wsle(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ complex cx[8];
+ integer np1, len;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *), ctest_(integer *, complex *, complex *, complex *,
+ real *);
+ complex mwpcs[5], mwpct[5];
+ extern doublereal scnrm2_(integer *, complex *, integer *);
+ extern /* Subroutine */ int itest1_(integer *, integer *), stest1_(real *,
+ real *, real *, real *);
+ extern integer icamax_(integer *, complex *, integer *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *);
+ extern doublereal scasum_(integer *, complex *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___19 = { 0, 6, 0, 0, 0 };
+
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+ for (combla_1.incx = 1; combla_1.incx <= 2; ++combla_1.incx) {
+ for (np1 = 1; np1 <= 5; ++np1) {
+ combla_1.n = np1 - 1;
+ len = max(combla_1.n,1) << 1;
+/* .. Set vector arguments .. */
+ i__1 = len;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ - 1;
+ i__3 = i__ + (np1 + combla_1.incx * 5 << 3) - 49;
+ cx[i__2].r = cv[i__3].r, cx[i__2].i = cv[i__3].i;
+/* L20: */
+ }
+ if (combla_1.icase == 6) {
+/* .. SCNRM2 .. */
+ r__1 = scnrm2_(&combla_1.n, cx, &combla_1.incx);
+ stest1_(&r__1, &strue2[np1 - 1], &strue2[np1 - 1], sfac);
+ } else if (combla_1.icase == 7) {
+/* .. SCASUM .. */
+ r__1 = scasum_(&combla_1.n, cx, &combla_1.incx);
+ stest1_(&r__1, &strue4[np1 - 1], &strue4[np1 - 1], sfac);
+ } else if (combla_1.icase == 8) {
+/* .. CSCAL .. */
+ cscal_(&combla_1.n, &ca, cx, &combla_1.incx);
+ ctest_(&len, cx, &ctrue5[(np1 + combla_1.incx * 5 << 3) - 48],
+ &ctrue5[(np1 + combla_1.incx * 5 << 3) - 48], sfac);
+ } else if (combla_1.icase == 9) {
+/* .. CSSCAL .. */
+ csscal_(&combla_1.n, &sa, cx, &combla_1.incx);
+ ctest_(&len, cx, &ctrue6[(np1 + combla_1.incx * 5 << 3) - 48],
+ &ctrue6[(np1 + combla_1.incx * 5 << 3) - 48], sfac);
+ } else if (combla_1.icase == 10) {
+/* .. ICAMAX .. */
+ i__1 = icamax_(&combla_1.n, cx, &combla_1.incx);
+ itest1_(&i__1, &itrue3[np1 - 1]);
+ } else {
+ s_wsle(&io___19);
+ do_lio(&c__9, &c__1, " Shouldn't be here in CHECK1", (ftnlen)
+ 28);
+ e_wsle();
+ s_stop("", (ftnlen)0);
+ }
+
+/* L40: */
+ }
+/* L60: */
+ }
+
+ combla_1.incx = 1;
+ if (combla_1.icase == 8) {
+/* CSCAL */
+/* Add a test for alpha equal to zero. */
+ ca.r = 0.f, ca.i = 0.f;
+ for (i__ = 1; i__ <= 5; ++i__) {
+ i__1 = i__ - 1;
+ mwpct[i__1].r = 0.f, mwpct[i__1].i = 0.f;
+ i__1 = i__ - 1;
+ mwpcs[i__1].r = 1.f, mwpcs[i__1].i = 1.f;
+/* L80: */
+ }
+ cscal_(&c__5, &ca, cx, &combla_1.incx);
+ ctest_(&c__5, cx, mwpct, mwpcs, sfac);
+ } else if (combla_1.icase == 9) {
+/* CSSCAL */
+/* Add a test for alpha equal to zero. */
+ sa = 0.f;
+ for (i__ = 1; i__ <= 5; ++i__) {
+ i__1 = i__ - 1;
+ mwpct[i__1].r = 0.f, mwpct[i__1].i = 0.f;
+ i__1 = i__ - 1;
+ mwpcs[i__1].r = 1.f, mwpcs[i__1].i = 1.f;
+/* L100: */
+ }
+ csscal_(&c__5, &sa, cx, &combla_1.incx);
+ ctest_(&c__5, cx, mwpct, mwpcs, sfac);
+/* Add a test for alpha equal to one. */
+ sa = 1.f;
+ for (i__ = 1; i__ <= 5; ++i__) {
+ i__1 = i__ - 1;
+ i__2 = i__ - 1;
+ mwpct[i__1].r = cx[i__2].r, mwpct[i__1].i = cx[i__2].i;
+ i__1 = i__ - 1;
+ i__2 = i__ - 1;
+ mwpcs[i__1].r = cx[i__2].r, mwpcs[i__1].i = cx[i__2].i;
+/* L120: */
+ }
+ csscal_(&c__5, &sa, cx, &combla_1.incx);
+ ctest_(&c__5, cx, mwpct, mwpcs, sfac);
+/* Add a test for alpha equal to minus one. */
+ sa = -1.f;
+ for (i__ = 1; i__ <= 5; ++i__) {
+ i__1 = i__ - 1;
+ i__2 = i__ - 1;
+ q__1.r = -cx[i__2].r, q__1.i = -cx[i__2].i;
+ mwpct[i__1].r = q__1.r, mwpct[i__1].i = q__1.i;
+ i__1 = i__ - 1;
+ i__2 = i__ - 1;
+ q__1.r = -cx[i__2].r, q__1.i = -cx[i__2].i;
+ mwpcs[i__1].r = q__1.r, mwpcs[i__1].i = q__1.i;
+/* L140: */
+ }
+ csscal_(&c__5, &sa, cx, &combla_1.incx);
+ ctest_(&c__5, cx, mwpct, mwpcs, sfac);
+ }
+ return 0;
+} /* check1_ */
+
+/* Subroutine */ int check2_(real *sfac)
+{
+ /* Initialized data */
+
+ static complex ca = {.4f,-.7f};
+ static integer incxs[4] = { 1,2,-2,-1 };
+ static integer incys[4] = { 1,-2,1,-2 };
+ static integer lens[8] /* was [4][2] */ = { 1,1,2,4,1,1,3,7 };
+ static integer ns[4] = { 0,1,2,4 };
+ static complex cx1[7] = { {.7f,-.8f},{-.4f,-.7f},{-.1f,-.9f},{.2f,-.8f},{
+ -.9f,-.4f},{.1f,.4f},{-.6f,.6f} };
+ static complex cy1[7] = { {.6f,-.6f},{-.9f,.5f},{.7f,-.6f},{.1f,-.5f},{
+ -.1f,-.2f},{-.5f,-.3f},{.8f,-.7f} };
+ static complex ct8[112] /* was [7][4][4] */ = { {.6f,-.6f},{0.f,0.f},{
+ 0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.32f,-1.41f},{
+ 0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.32f,
+ -1.41f},{-1.55f,.5f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,
+ 0.f},{.32f,-1.41f},{-1.55f,.5f},{.03f,-.89f},{-.38f,-.96f},{0.f,
+ 0.f},{0.f,0.f},{0.f,0.f},{.6f,-.6f},{0.f,0.f},{0.f,0.f},{0.f,0.f},
+ {0.f,0.f},{0.f,0.f},{0.f,0.f},{.32f,-1.41f},{0.f,0.f},{0.f,0.f},{
+ 0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{-.07f,-.89f},{-.9f,.5f},{
+ .42f,-1.41f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.78f,.06f},{
+ -.9f,.5f},{.06f,-.13f},{.1f,-.5f},{-.77f,-.49f},{-.5f,-.3f},{.52f,
+ -1.51f},{.6f,-.6f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,
+ 0.f},{0.f,0.f},{.32f,-1.41f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,
+ 0.f},{0.f,0.f},{0.f,0.f},{-.07f,-.89f},{-1.18f,-.31f},{0.f,0.f},{
+ 0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.78f,.06f},{-1.54f,.97f},{
+ .03f,-.89f},{-.18f,-1.31f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.6f,
+ -.6f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},
+ {.32f,-1.41f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{
+ 0.f,0.f},{.32f,-1.41f},{-.9f,.5f},{.05f,-.6f},{0.f,0.f},{0.f,0.f},
+ {0.f,0.f},{0.f,0.f},{.32f,-1.41f},{-.9f,.5f},{.05f,-.6f},{.1f,
+ -.5f},{-.77f,-.49f},{-.5f,-.3f},{.32f,-1.16f} };
+ static complex ct7[16] /* was [4][4] */ = { {0.f,0.f},{-.06f,-.9f},{
+ .65f,-.47f},{-.34f,-1.22f},{0.f,0.f},{-.06f,-.9f},{-.59f,-1.46f},{
+ -1.04f,-.04f},{0.f,0.f},{-.06f,-.9f},{-.83f,.59f},{.07f,-.37f},{
+ 0.f,0.f},{-.06f,-.9f},{-.76f,-1.15f},{-1.33f,-1.82f} };
+ static complex ct6[16] /* was [4][4] */ = { {0.f,0.f},{.9f,.06f},{
+ .91f,-.77f},{1.8f,-.1f},{0.f,0.f},{.9f,.06f},{1.45f,.74f},{.2f,
+ .9f},{0.f,0.f},{.9f,.06f},{-.55f,.23f},{.83f,-.39f},{0.f,0.f},{
+ .9f,.06f},{1.04f,.79f},{1.95f,1.22f} };
+ static complex ct10x[112] /* was [7][4][4] */ = { {.7f,-.8f},{0.f,0.f},{
+ 0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.6f,-.6f},{0.f,
+ 0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.6f,-.6f},
+ {-.9f,.5f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.6f,
+ -.6f},{-.9f,.5f},{.7f,-.6f},{.1f,-.5f},{0.f,0.f},{0.f,0.f},{0.f,
+ 0.f},{.7f,-.8f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},
+ {0.f,0.f},{.6f,-.6f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,
+ 0.f},{0.f,0.f},{.7f,-.6f},{-.4f,-.7f},{.6f,-.6f},{0.f,0.f},{0.f,
+ 0.f},{0.f,0.f},{0.f,0.f},{.8f,-.7f},{-.4f,-.7f},{-.1f,-.2f},{.2f,
+ -.8f},{.7f,-.6f},{.1f,.4f},{.6f,-.6f},{.7f,-.8f},{0.f,0.f},{0.f,
+ 0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.6f,-.6f},{0.f,0.f},
+ {0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{-.9f,.5f},{
+ -.4f,-.7f},{.6f,-.6f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{
+ .1f,-.5f},{-.4f,-.7f},{.7f,-.6f},{.2f,-.8f},{-.9f,.5f},{.1f,.4f},{
+ .6f,-.6f},{.7f,-.8f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,
+ 0.f},{0.f,0.f},{.6f,-.6f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},
+ {0.f,0.f},{0.f,0.f},{.6f,-.6f},{.7f,-.6f},{0.f,0.f},{0.f,0.f},{
+ 0.f,0.f},{0.f,0.f},{0.f,0.f},{.6f,-.6f},{.7f,-.6f},{-.1f,-.2f},{
+ .8f,-.7f},{0.f,0.f},{0.f,0.f},{0.f,0.f} };
+ static complex ct10y[112] /* was [7][4][4] */ = { {.6f,-.6f},{0.f,0.f},{
+ 0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.7f,-.8f},{0.f,
+ 0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.7f,-.8f},
+ {-.4f,-.7f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{
+ .7f,-.8f},{-.4f,-.7f},{-.1f,-.9f},{.2f,-.8f},{0.f,0.f},{0.f,0.f},{
+ 0.f,0.f},{.6f,-.6f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,
+ 0.f},{0.f,0.f},{.7f,-.8f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},
+ {0.f,0.f},{0.f,0.f},{-.1f,-.9f},{-.9f,.5f},{.7f,-.8f},{0.f,0.f},{
+ 0.f,0.f},{0.f,0.f},{0.f,0.f},{-.6f,.6f},{-.9f,.5f},{-.9f,-.4f},{
+ .1f,-.5f},{-.1f,-.9f},{-.5f,-.3f},{.7f,-.8f},{.6f,-.6f},{0.f,0.f},
+ {0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{.7f,-.8f},{0.f,
+ 0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{-.1f,-.9f}
+ ,{.7f,-.8f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{
+ -.6f,.6f},{-.9f,-.4f},{-.1f,-.9f},{.7f,-.8f},{0.f,0.f},{0.f,0.f},{
+ 0.f,0.f},{.6f,-.6f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,
+ 0.f},{0.f,0.f},{.7f,-.8f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},
+ {0.f,0.f},{0.f,0.f},{.7f,-.8f},{-.9f,.5f},{-.4f,-.7f},{0.f,0.f},{
+ 0.f,0.f},{0.f,0.f},{0.f,0.f},{.7f,-.8f},{-.9f,.5f},{-.4f,-.7f},{
+ .1f,-.5f},{-.1f,-.9f},{-.5f,-.3f},{.2f,-.8f} };
+ static complex csize1[4] = { {0.f,0.f},{.9f,.9f},{1.63f,1.73f},{2.9f,
+ 2.78f} };
+ static complex csize3[14] = { {0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{
+ 0.f,0.f},{0.f,0.f},{0.f,0.f},{1.17f,1.17f},{1.17f,1.17f},{1.17f,
+ 1.17f},{1.17f,1.17f},{1.17f,1.17f},{1.17f,1.17f},{1.17f,1.17f} };
+ static complex csize2[14] /* was [7][2] */ = { {0.f,0.f},{0.f,0.f},{0.f,
+ 0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{0.f,0.f},{1.54f,1.54f},{1.54f,
+ 1.54f},{1.54f,1.54f},{1.54f,1.54f},{1.54f,1.54f},{1.54f,1.54f},{
+ 1.54f,1.54f} };
+
+ /* System generated locals */
+ integer i__1, i__2;
+ complex q__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_wsle(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+
+ /* Local variables */
+ integer i__, ki, kn;
+ complex cx[7], cy[7];
+ integer mx, my;
+ complex cdot[1];
+ integer lenx, leny;
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *), ctest_(integer *, complex *, complex *,
+ complex *, real *);
+ integer ksize;
+ extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___48 = { 0, 6, 0, 0, 0 };
+
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+ for (ki = 1; ki <= 4; ++ki) {
+ combla_1.incx = incxs[ki - 1];
+ combla_1.incy = incys[ki - 1];
+ mx = abs(combla_1.incx);
+ my = abs(combla_1.incy);
+
+ for (kn = 1; kn <= 4; ++kn) {
+ combla_1.n = ns[kn - 1];
+ ksize = min(2,kn);
+ lenx = lens[kn + (mx << 2) - 5];
+ leny = lens[kn + (my << 2) - 5];
+/* .. initialize all argument arrays .. */
+ for (i__ = 1; i__ <= 7; ++i__) {
+ i__1 = i__ - 1;
+ i__2 = i__ - 1;
+ cx[i__1].r = cx1[i__2].r, cx[i__1].i = cx1[i__2].i;
+ i__1 = i__ - 1;
+ i__2 = i__ - 1;
+ cy[i__1].r = cy1[i__2].r, cy[i__1].i = cy1[i__2].i;
+/* L20: */
+ }
+ if (combla_1.icase == 1) {
+/* .. CDOTC .. */
+ cdotc_(&q__1, &combla_1.n, cx, &combla_1.incx, cy, &
+ combla_1.incy);
+ cdot[0].r = q__1.r, cdot[0].i = q__1.i;
+ ctest_(&c__1, cdot, &ct6[kn + (ki << 2) - 5], &csize1[kn - 1],
+ sfac);
+ } else if (combla_1.icase == 2) {
+/* .. CDOTU .. */
+ cdotu_(&q__1, &combla_1.n, cx, &combla_1.incx, cy, &
+ combla_1.incy);
+ cdot[0].r = q__1.r, cdot[0].i = q__1.i;
+ ctest_(&c__1, cdot, &ct7[kn + (ki << 2) - 5], &csize1[kn - 1],
+ sfac);
+ } else if (combla_1.icase == 3) {
+/* .. CAXPY .. */
+ caxpy_(&combla_1.n, &ca, cx, &combla_1.incx, cy, &
+ combla_1.incy);
+ ctest_(&leny, cy, &ct8[(kn + (ki << 2)) * 7 - 35], &csize2[
+ ksize * 7 - 7], sfac);
+ } else if (combla_1.icase == 4) {
+/* .. CCOPY .. */
+ ccopy_(&combla_1.n, cx, &combla_1.incx, cy, &combla_1.incy);
+ ctest_(&leny, cy, &ct10y[(kn + (ki << 2)) * 7 - 35], csize3, &
+ c_b43);
+ } else if (combla_1.icase == 5) {
+/* .. CSWAP .. */
+ cswap_(&combla_1.n, cx, &combla_1.incx, cy, &combla_1.incy);
+ ctest_(&lenx, cx, &ct10x[(kn + (ki << 2)) * 7 - 35], csize3, &
+ c_b43);
+ ctest_(&leny, cy, &ct10y[(kn + (ki << 2)) * 7 - 35], csize3, &
+ c_b43);
+ } else {
+ s_wsle(&io___48);
+ do_lio(&c__9, &c__1, " Shouldn't be here in CHECK2", (ftnlen)
+ 28);
+ e_wsle();
+ s_stop("", (ftnlen)0);
+ }
+
+/* L40: */
+ }
+/* L60: */
+ }
+ return 0;
+} /* check2_ */
+
+/* Subroutine */ int stest_(integer *len, real *scomp, real *strue, real *
+ ssize, real *sfac)
+{
+ /* Format strings */
+ static char fmt_99999[] = "(\002 F"
+ "AIL\002)";
+ static char fmt_99998[] = "(/\002 CASE N INCX INCY MODE I "
+ " \002,\002 COMP(I) TRU"
+ "E(I) DIFFERENCE\002,\002 SIZE(I)\002,/1x)";
+ static char fmt_99997[] = "(1x,i4,i3,3i5,i3,2e36.8,2e12.4)";
+
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2, r__3, r__4, r__5;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ real sd;
+ extern doublereal sdiff_(real *, real *);
+
+ /* Fortran I/O blocks */
+ static cilist io___51 = { 0, 6, 0, fmt_99999, 0 };
+ static cilist io___52 = { 0, 6, 0, fmt_99998, 0 };
+ static cilist io___53 = { 0, 6, 0, fmt_99997, 0 };
+
+
+/* ********************************* STEST ************************** */
+
+/* THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO */
+/* SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE */
+/* NEGLIGIBLE. */
+
+/* C. L. LAWSON, JPL, 1974 DEC 10 */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. External Functions .. */
+/* .. Intrinsic Functions .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ssize;
+ --strue;
+ --scomp;
+
+ /* Function Body */
+ i__1 = *len;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sd = scomp[i__] - strue[i__];
+ r__4 = (r__1 = ssize[i__], dabs(r__1)) + (r__2 = *sfac * sd, dabs(
+ r__2));
+ r__5 = (r__3 = ssize[i__], dabs(r__3));
+ if (sdiff_(&r__4, &r__5) == 0.f) {
+ goto L40;
+ }
+
+/* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I). */
+
+ if (! combla_1.pass) {
+ goto L20;
+ }
+/* PRINT FAIL MESSAGE AND HEADER. */
+ combla_1.pass = FALSE_;
+ s_wsfe(&io___51);
+ e_wsfe();
+ s_wsfe(&io___52);
+ e_wsfe();
+L20:
+ s_wsfe(&io___53);
+ do_fio(&c__1, (char *)&combla_1.icase, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.incy, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.mode, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&scomp[i__], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&strue[i__], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&sd, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&ssize[i__], (ftnlen)sizeof(real));
+ e_wsfe();
+L40:
+ ;
+ }
+ return 0;
+
+} /* stest_ */
+
+/* Subroutine */ int stest1_(real *scomp1, real *strue1, real *ssize, real *
+ sfac)
+{
+ real scomp[1], strue[1];
+ extern /* Subroutine */ int stest_(integer *, real *, real *, real *,
+ real *);
+
+/* ************************* STEST1 ***************************** */
+
+/* THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN */
+/* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE */
+/* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT. */
+
+/* C.L. LAWSON, JPL, 1978 DEC 6 */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Arrays .. */
+/* .. External Subroutines .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ssize;
+
+ /* Function Body */
+ scomp[0] = *scomp1;
+ strue[0] = *strue1;
+ stest_(&c__1, scomp, strue, &ssize[1], sfac);
+
+ return 0;
+} /* stest1_ */
+
+doublereal sdiff_(real *sa, real *sb)
+{
+ /* System generated locals */
+ real ret_val;
+
+/* ********************************* SDIFF ************************** */
+/* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 */
+
+/* .. Scalar Arguments .. */
+/* .. Executable Statements .. */
+ ret_val = *sa - *sb;
+ return ret_val;
+} /* sdiff_ */
+
+/* Subroutine */ int ctest_(integer *len, complex *ccomp, complex *ctrue,
+ complex *csize, real *sfac)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__;
+ real scomp[20], ssize[20], strue[20];
+ extern /* Subroutine */ int stest_(integer *, real *, real *, real *,
+ real *);
+
+/* **************************** CTEST ***************************** */
+
+/* C.L. LAWSON, JPL, 1978 DEC 6 */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ --csize;
+ --ctrue;
+ --ccomp;
+
+ /* Function Body */
+ i__1 = *len;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ scomp[(i__ << 1) - 2] = ccomp[i__2].r;
+ scomp[(i__ << 1) - 1] = r_imag(&ccomp[i__]);
+ i__2 = i__;
+ strue[(i__ << 1) - 2] = ctrue[i__2].r;
+ strue[(i__ << 1) - 1] = r_imag(&ctrue[i__]);
+ i__2 = i__;
+ ssize[(i__ << 1) - 2] = csize[i__2].r;
+ ssize[(i__ << 1) - 1] = r_imag(&csize[i__]);
+/* L20: */
+ }
+
+ i__1 = *len << 1;
+ stest_(&i__1, scomp, strue, ssize, sfac);
+ return 0;
+} /* ctest_ */
+
+/* Subroutine */ int itest1_(integer *icomp, integer *itrue)
+{
+ /* Format strings */
+ static char fmt_99999[] = "(\002 F"
+ "AIL\002)";
+ static char fmt_99998[] = "(/\002 CASE N INCX INCY MODE "
+ " \002,\002 COMP TRU"
+ "E DIFFERENCE\002,/1x)";
+ static char fmt_99997[] = "(1x,i4,i3,3i5,2i36,i12)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer id;
+
+ /* Fortran I/O blocks */
+ static cilist io___60 = { 0, 6, 0, fmt_99999, 0 };
+ static cilist io___61 = { 0, 6, 0, fmt_99998, 0 };
+ static cilist io___63 = { 0, 6, 0, fmt_99997, 0 };
+
+
+/* ********************************* ITEST1 ************************* */
+
+/* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR */
+/* EQUALITY. */
+/* C. L. LAWSON, JPL, 1974 DEC 10 */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+ if (*icomp == *itrue) {
+ goto L40;
+ }
+
+/* HERE ICOMP IS NOT EQUAL TO ITRUE. */
+
+ if (! combla_1.pass) {
+ goto L20;
+ }
+/* PRINT FAIL MESSAGE AND HEADER. */
+ combla_1.pass = FALSE_;
+ s_wsfe(&io___60);
+ e_wsfe();
+ s_wsfe(&io___61);
+ e_wsfe();
+L20:
+ id = *icomp - *itrue;
+ s_wsfe(&io___63);
+ do_fio(&c__1, (char *)&combla_1.icase, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.incy, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.mode, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*icomp), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*itrue), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&id, (ftnlen)sizeof(integer));
+ e_wsfe();
+L40:
+ return 0;
+
+} /* itest1_ */
+
+/* Main program alias */ int cblat1_ () { MAIN__ (); return 0; }
diff --git a/BLAS/TESTING/cblat2.c b/BLAS/TESTING/cblat2.c
new file mode 100644
index 0000000..5c46dce
--- /dev/null
+++ b/BLAS/TESTING/cblat2.c
@@ -0,0 +1,5349 @@
+/* cblat2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+union {
+ struct {
+ integer infot, noutc;
+ logical ok, lerr;
+ } _1;
+ struct {
+ integer infot, nout;
+ logical ok, lerr;
+ } _2;
+} infoc_;
+
+#define infoc_1 (infoc_._1)
+#define infoc_2 (infoc_._2)
+
+struct {
+ char srnamt[6];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__9 = 9;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__8 = 8;
+static integer c__4 = 4;
+static integer c__65 = 65;
+static integer c__7 = 7;
+static integer c__2 = 2;
+static integer c__6 = 6;
+static real c_b123 = 1.f;
+static logical c_true = TRUE_;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static logical c_false = FALSE_;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Initialized data */
+
+ static char snames[6*17] = "CGEMV " "CGBMV " "CHEMV " "CHBMV " "CHPMV "
+ "CTRMV " "CTBMV " "CTPMV " "CTRSV " "CTBSV " "CTPSV " "CGERC "
+ "CGERU " "CHER " "CHPR " "CHER2 " "CHPR2 ";
+
+ /* Format strings */
+ static char fmt_9997[] = "(\002 NUMBER OF VALUES OF \002,a,\002 IS LESS "
+ "THAN 1 OR GREATER \002,\002THAN \002,i2)";
+ static char fmt_9996[] = "(\002 VALUE OF N IS LESS THAN 0 OR GREATER THA"
+ "N \002,i2)";
+ static char fmt_9995[] = "(\002 VALUE OF K IS LESS THAN 0\002)";
+ static char fmt_9994[] = "(\002 ABSOLUTE VALUE OF INCX OR INCY IS 0 OR G"
+ "REATER THAN \002,i2)";
+ static char fmt_9993[] = "(\002 TESTS OF THE COMPLEX LEVEL 2 BL"
+ "AS\002,//\002 THE F\002,\002OLLOWING PARAMETER VALUES WILL BE US"
+ "ED:\002)";
+ static char fmt_9992[] = "(\002 FOR N \002,9i6)";
+ static char fmt_9991[] = "(\002 FOR K \002,7i6)";
+ static char fmt_9990[] = "(\002 FOR INCX AND INCY \002,7i6)";
+ static char fmt_9989[] = "(\002 FOR ALPHA \002,7(\002(\002,f4"
+ ".1,\002,\002,f4.1,\002) \002,:))";
+ static char fmt_9988[] = "(\002 FOR BETA \002,7(\002(\002,f4"
+ ".1,\002,\002,f4.1,\002) \002,:))";
+ static char fmt_9980[] = "(\002 ERROR-EXITS WILL NOT BE TESTED\002)";
+ static char fmt_9999[] = "(\002 ROUTINES PASS COMPUTATIONAL TESTS IF TES"
+ "T RATIO IS LES\002,\002S THAN\002,f8.2)";
+ static char fmt_9984[] = "(a6,l2)";
+ static char fmt_9986[] = "(\002 SUBPROGRAM NAME \002,a6,\002 NOT RECOGNI"
+ "ZED\002,/\002 ******* T\002,\002ESTS ABANDONED *******\002)";
+ static char fmt_9998[] = "(\002 RELATIVE MACHINE PRECISION IS TAKEN TO"
+ " BE\002,1p,e9.1)";
+ static char fmt_9985[] = "(\002 ERROR IN CMVCH - IN-LINE DOT PRODUCTS A"
+ "RE BEING EVALU\002,\002ATED WRONGLY.\002,/\002 CMVCH WAS CALLED "
+ "WITH TRANS = \002,a1,\002 AND RETURNED SAME = \002,l1,\002 AND E"
+ "RR = \002,f12.3,\002.\002,/\002 THIS MAY BE DUE TO FAULTS IN THE"
+ " ARITHMETIC OR THE COMPILER.\002,/\002 ******* TESTS ABANDONED *"
+ "******\002)";
+ static char fmt_9983[] = "(1x,a6,\002 WAS NOT TESTED\002)";
+ static char fmt_9982[] = "(/\002 END OF TESTS\002)";
+ static char fmt_9981[] = "(/\002 ******* FATAL ERROR - TESTS ABANDONED *"
+ "******\002)";
+ static char fmt_9987[] = "(\002 AMEND DATA FILE OR INCREASE ARRAY SIZES "
+ "IN PROGRAM\002,/\002 ******* TESTS ABANDONED *******\002)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ real r__1;
+ olist o__1;
+ cllist cl__1;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void), f_open(olist *), s_wsfe(cilist *), do_fio(integer *,
+ char *, ftnlen), e_wsfe(void), s_wsle(cilist *), e_wsle(void),
+ s_rsfe(cilist *), e_rsfe(void), s_cmp(char *, char *, ftnlen,
+ ftnlen);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+ integer f_clos(cllist *);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ complex a[4225] /* was [65][65] */;
+ real g[65];
+ integer i__, j, n;
+ complex x[65], y[65], z__[130], aa[4225];
+ integer kb[7];
+ complex as[4225], xs[130], ys[130], yt[65], xx[130], yy[130], alf[7];
+ extern logical lce_(complex *, complex *, integer *);
+ integer inc[7], nkb;
+ complex bet[7];
+ real eps, err;
+ integer nalf, idim[9];
+ logical same;
+ integer ninc, nbet, ntra;
+ logical rewi;
+ integer nout;
+ extern /* Subroutine */ int cchk1_(char *, real *, real *, integer *,
+ integer *, logical *, logical *, logical *, integer *, integer *,
+ integer *, integer *, integer *, complex *, integer *, complex *,
+ integer *, integer *, integer *, integer *, complex *, complex *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ complex *, complex *, real *, ftnlen), cchk2_(char *, real *,
+ real *, integer *, integer *, logical *, logical *, logical *,
+ integer *, integer *, integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, integer *, integer *, integer *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ complex *, complex *, complex *, complex *, real *, ftnlen),
+ cchk3_(char *, real *, real *, integer *, integer *, logical *,
+ logical *, logical *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, complex *, complex *,
+ complex *, complex *, complex *, complex *, complex *, real *,
+ complex *, ftnlen), cchk4_(char *, real *, real *, integer *,
+ integer *, logical *, logical *, logical *, integer *, integer *,
+ integer *, complex *, integer *, integer *, integer *, integer *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ complex *, complex *, complex *, complex *, real *, complex *,
+ ftnlen), cchk5_(char *, real *, real *, integer *, integer *,
+ logical *, logical *, logical *, integer *, integer *, integer *,
+ complex *, integer *, integer *, integer *, integer *, complex *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ complex *, complex *, complex *, real *, complex *, ftnlen),
+ cchk6_(char *, real *, real *, integer *, integer *, logical *,
+ logical *, logical *, integer *, integer *, integer *, complex *,
+ integer *, integer *, integer *, integer *, complex *, complex *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ complex *, complex *, real *, complex *, ftnlen), cchke_(integer *
+ , char *, integer *, ftnlen);
+ logical fatal;
+ extern doublereal sdiff_(real *, real *);
+ logical trace;
+ integer nidim;
+ extern /* Subroutine */ int cmvch_(char *, integer *, integer *, complex *
+ , complex *, integer *, complex *, integer *, complex *, complex *
+ , integer *, complex *, real *, complex *, real *, real *,
+ logical *, integer *, logical *, ftnlen);
+ char snaps[32], trans[1];
+ integer isnum;
+ logical ltest[17], sfatal;
+ char snamet[6];
+ real thresh;
+ logical ltestt, tsterr;
+ char summry[32];
+
+ /* Fortran I/O blocks */
+ static cilist io___2 = { 0, 5, 0, 0, 0 };
+ static cilist io___4 = { 0, 5, 0, 0, 0 };
+ static cilist io___6 = { 0, 5, 0, 0, 0 };
+ static cilist io___8 = { 0, 5, 0, 0, 0 };
+ static cilist io___11 = { 0, 5, 0, 0, 0 };
+ static cilist io___13 = { 0, 5, 0, 0, 0 };
+ static cilist io___15 = { 0, 5, 0, 0, 0 };
+ static cilist io___17 = { 0, 5, 0, 0, 0 };
+ static cilist io___19 = { 0, 5, 0, 0, 0 };
+ static cilist io___21 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___22 = { 0, 5, 0, 0, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___26 = { 0, 5, 0, 0, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___29 = { 0, 5, 0, 0, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___32 = { 0, 5, 0, 0, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___35 = { 0, 5, 0, 0, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___38 = { 0, 5, 0, 0, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___41 = { 0, 5, 0, 0, 0 };
+ static cilist io___43 = { 0, 5, 0, 0, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___46 = { 0, 5, 0, 0, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9988, 0 };
+ static cilist io___54 = { 0, 0, 0, 0, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9980, 0 };
+ static cilist io___56 = { 0, 0, 0, 0, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___58 = { 0, 0, 0, 0, 0 };
+ static cilist io___60 = { 0, 5, 1, fmt_9984, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9986, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9985, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9985, 0 };
+ static cilist io___81 = { 0, 0, 0, 0, 0 };
+ static cilist io___82 = { 0, 0, 0, fmt_9983, 0 };
+ static cilist io___83 = { 0, 0, 0, 0, 0 };
+ static cilist io___90 = { 0, 0, 0, fmt_9982, 0 };
+ static cilist io___91 = { 0, 0, 0, fmt_9981, 0 };
+ static cilist io___92 = { 0, 0, 0, fmt_9987, 0 };
+
+
+
+/* Test program for the COMPLEX Level 2 Blas. */
+
+/* The program must be driven by a short data file. The first 18 records */
+/* of the file are read using list-directed input, the last 17 records */
+/* are read using the format ( A6, L2 ). An annotated example of a data */
+/* file can be obtained by deleting the first 3 characters from the */
+/* following 35 lines: */
+/* 'cblat2.out' NAME OF SUMMARY OUTPUT FILE */
+/* 6 UNIT NUMBER OF SUMMARY FILE */
+/* 'CBLA2T.SNAP' NAME OF SNAPSHOT OUTPUT FILE */
+/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */
+/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */
+/* F LOGICAL FLAG, T TO STOP ON FAILURES. */
+/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */
+/* 16.0 THRESHOLD VALUE OF TEST RATIO */
+/* 6 NUMBER OF VALUES OF N */
+/* 0 1 2 3 5 9 VALUES OF N */
+/* 4 NUMBER OF VALUES OF K */
+/* 0 1 2 4 VALUES OF K */
+/* 4 NUMBER OF VALUES OF INCX AND INCY */
+/* 1 2 -1 -2 VALUES OF INCX AND INCY */
+/* 3 NUMBER OF VALUES OF ALPHA */
+/* (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA */
+/* 3 NUMBER OF VALUES OF BETA */
+/* (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA */
+/* CGEMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CGBMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CHEMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CHBMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CHPMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CTRMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CTBMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CTPMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CTRSV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CTBSV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CTPSV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CGERC T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CGERU T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CHER T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CHPR T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CHER2 T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CHPR2 T PUT F FOR NO TEST. SAME COLUMNS. */
+
+/* See: */
+
+/* Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. */
+/* An extended set of Fortran Basic Linear Algebra Subprograms. */
+
+/* Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics */
+/* and Computer Science Division, Argonne National Laboratory, */
+/* 9700 South Cass Avenue, Argonne, Illinois 60439, US. */
+
+/* Or */
+
+/* NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms */
+/* Group Ltd., NAG Central Office, 256 Banbury Road, Oxford */
+/* OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st */
+/* Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. */
+
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers */
+/* can be run multiple times without deleting generated */
+/* output files (susan) */
+
+/* .. Parameters .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+
+/* Read name and unit number for summary output file and open file. */
+
+ s_rsle(&io___2);
+ do_lio(&c__9, &c__1, summry, (ftnlen)32);
+ e_rsle();
+ s_rsle(&io___4);
+ do_lio(&c__3, &c__1, (char *)&nout, (ftnlen)sizeof(integer));
+ e_rsle();
+ o__1.oerr = 0;
+ o__1.ounit = nout;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = summry;
+ o__1.orl = 0;
+ o__1.osta = "UNKNOWN";
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);
+ infoc_1.noutc = nout;
+
+/* Read name and unit number for snapshot output file and open file. */
+
+ s_rsle(&io___6);
+ do_lio(&c__9, &c__1, snaps, (ftnlen)32);
+ e_rsle();
+ s_rsle(&io___8);
+ do_lio(&c__3, &c__1, (char *)&ntra, (ftnlen)sizeof(integer));
+ e_rsle();
+ trace = ntra >= 0;
+ if (trace) {
+ o__1.oerr = 0;
+ o__1.ounit = ntra;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = snaps;
+ o__1.orl = 0;
+ o__1.osta = "UNKNOWN";
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);
+ }
+/* Read the flag that directs rewinding of the snapshot file. */
+ s_rsle(&io___11);
+ do_lio(&c__8, &c__1, (char *)&rewi, (ftnlen)sizeof(logical));
+ e_rsle();
+ rewi = rewi && trace;
+/* Read the flag that directs stopping on any failure. */
+ s_rsle(&io___13);
+ do_lio(&c__8, &c__1, (char *)&sfatal, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the flag that indicates whether error exits are to be tested. */
+ s_rsle(&io___15);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the threshold value of the test ratio */
+ s_rsle(&io___17);
+ do_lio(&c__4, &c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_rsle();
+
+/* Read and check the parameter values for the tests. */
+
+/* Values of N */
+ s_rsle(&io___19);
+ do_lio(&c__3, &c__1, (char *)&nidim, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nidim < 1 || nidim > 9) {
+ io___21.ciunit = nout;
+ s_wsfe(&io___21);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+ s_rsle(&io___22);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {
+ io___25.ciunit = nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, (char *)&c__65, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+/* L10: */
+ }
+/* Values of K */
+ s_rsle(&io___26);
+ do_lio(&c__3, &c__1, (char *)&nkb, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nkb < 1 || nkb > 7) {
+ io___28.ciunit = nout;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "K", (ftnlen)1);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+ s_rsle(&io___29);
+ i__1 = nkb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&kb[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nkb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (kb[i__ - 1] < 0) {
+ io___31.ciunit = nout;
+ s_wsfe(&io___31);
+ e_wsfe();
+ goto L230;
+ }
+/* L20: */
+ }
+/* Values of INCX and INCY */
+ s_rsle(&io___32);
+ do_lio(&c__3, &c__1, (char *)&ninc, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (ninc < 1 || ninc > 7) {
+ io___34.ciunit = nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "INCX AND INCY", (ftnlen)13);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+ s_rsle(&io___35);
+ i__1 = ninc;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&inc[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = ninc;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (inc[i__ - 1] == 0 || (i__2 = inc[i__ - 1], abs(i__2)) > 2) {
+ io___37.ciunit = nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+/* L30: */
+ }
+/* Values of ALPHA */
+ s_rsle(&io___38);
+ do_lio(&c__3, &c__1, (char *)&nalf, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nalf < 1 || nalf > 7) {
+ io___40.ciunit = nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "ALPHA", (ftnlen)5);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+ s_rsle(&io___41);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__6, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(complex));
+ }
+ e_rsle();
+/* Values of BETA */
+ s_rsle(&io___43);
+ do_lio(&c__3, &c__1, (char *)&nbet, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nbet < 1 || nbet > 7) {
+ io___45.ciunit = nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "BETA", (ftnlen)4);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+ s_rsle(&io___46);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__6, &c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(complex));
+ }
+ e_rsle();
+
+/* Report values of parameters. */
+
+ io___48.ciunit = nout;
+ s_wsfe(&io___48);
+ e_wsfe();
+ io___49.ciunit = nout;
+ s_wsfe(&io___49);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ io___50.ciunit = nout;
+ s_wsfe(&io___50);
+ i__1 = nkb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&kb[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ io___51.ciunit = nout;
+ s_wsfe(&io___51);
+ i__1 = ninc;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&inc[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ io___52.ciunit = nout;
+ s_wsfe(&io___52);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__2, (char *)&alf[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_wsfe();
+ io___53.ciunit = nout;
+ s_wsfe(&io___53);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__2, (char *)&bet[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_wsfe();
+ if (! tsterr) {
+ io___54.ciunit = nout;
+ s_wsle(&io___54);
+ e_wsle();
+ io___55.ciunit = nout;
+ s_wsfe(&io___55);
+ e_wsfe();
+ }
+ io___56.ciunit = nout;
+ s_wsle(&io___56);
+ e_wsle();
+ io___57.ciunit = nout;
+ s_wsfe(&io___57);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_wsfe();
+ io___58.ciunit = nout;
+ s_wsle(&io___58);
+ e_wsle();
+
+/* Read names of subroutines and flags which indicate */
+/* whether they are to be tested. */
+
+ for (i__ = 1; i__ <= 17; ++i__) {
+ ltest[i__ - 1] = FALSE_;
+/* L40: */
+ }
+L50:
+ i__1 = s_rsfe(&io___60);
+ if (i__1 != 0) {
+ goto L80;
+ }
+ i__1 = do_fio(&c__1, snamet, (ftnlen)6);
+ if (i__1 != 0) {
+ goto L80;
+ }
+ i__1 = do_fio(&c__1, (char *)<estt, (ftnlen)sizeof(logical));
+ if (i__1 != 0) {
+ goto L80;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L80;
+ }
+ for (i__ = 1; i__ <= 17; ++i__) {
+ if (s_cmp(snamet, snames + (i__ - 1) * 6, (ftnlen)6, (ftnlen)6) == 0)
+ {
+ goto L70;
+ }
+/* L60: */
+ }
+ io___63.ciunit = nout;
+ s_wsfe(&io___63);
+ do_fio(&c__1, snamet, (ftnlen)6);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+L70:
+ ltest[i__ - 1] = ltestt;
+ goto L50;
+
+L80:
+ cl__1.cerr = 0;
+ cl__1.cunit = 5;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+
+/* Compute EPS (the machine precision). */
+
+ eps = 1.f;
+L90:
+ r__1 = eps + 1.f;
+ if (sdiff_(&r__1, &c_b123) == 0.f) {
+ goto L100;
+ }
+ eps *= .5f;
+ goto L90;
+L100:
+ eps += eps;
+ io___65.ciunit = nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+
+/* Check the reliability of CMVCH using exact data. */
+
+ n = 32;
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 65 - 66;
+/* Computing MAX */
+ i__5 = i__ - j + 1;
+ i__4 = max(i__5,0);
+ a[i__3].r = (real) i__4, a[i__3].i = 0.f;
+/* L110: */
+ }
+ i__2 = j - 1;
+ x[i__2].r = (real) j, x[i__2].i = 0.f;
+ i__2 = j - 1;
+ y[i__2].r = 0.f, y[i__2].i = 0.f;
+/* L120: */
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ i__3 = j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3;
+ yy[i__2].r = (real) i__3, yy[i__2].i = 0.f;
+/* L130: */
+ }
+/* YY holds the exact result. On exit from CMVCH YT holds */
+/* the result computed by CMVCH. */
+ *(unsigned char *)trans = 'N';
+ cmvch_(trans, &n, &n, &c_b2, a, &c__65, x, &c__1, &c_b1, y, &c__1, yt, g,
+ yy, &eps, &err, &fatal, &nout, &c_true, (ftnlen)1);
+ same = lce_(yy, yt, &n);
+ if (! same || err != 0.f) {
+ io___78.ciunit = nout;
+ s_wsfe(&io___78);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ *(unsigned char *)trans = 'T';
+ cmvch_(trans, &n, &n, &c_b2, a, &c__65, x, &c_n1, &c_b1, y, &c_n1, yt, g,
+ yy, &eps, &err, &fatal, &nout, &c_true, (ftnlen)1);
+ same = lce_(yy, yt, &n);
+ if (! same || err != 0.f) {
+ io___79.ciunit = nout;
+ s_wsfe(&io___79);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Test each subroutine in turn. */
+
+ for (isnum = 1; isnum <= 17; ++isnum) {
+ io___81.ciunit = nout;
+ s_wsle(&io___81);
+ e_wsle();
+ if (! ltest[isnum - 1]) {
+/* Subprogram is not to be tested. */
+ io___82.ciunit = nout;
+ s_wsfe(&io___82);
+ do_fio(&c__1, snames + (isnum - 1) * 6, (ftnlen)6);
+ e_wsfe();
+ } else {
+ s_copy(srnamc_1.srnamt, snames + (isnum - 1) * 6, (ftnlen)6, (
+ ftnlen)6);
+/* Test error exits. */
+ if (tsterr) {
+ cchke_(&isnum, snames + (isnum - 1) * 6, &nout, (ftnlen)6);
+ io___83.ciunit = nout;
+ s_wsle(&io___83);
+ e_wsle();
+ }
+/* Test computations. */
+ infoc_1.infot = 0;
+ infoc_1.ok = TRUE_;
+ fatal = FALSE_;
+ switch (isnum) {
+ case 1: goto L140;
+ case 2: goto L140;
+ case 3: goto L150;
+ case 4: goto L150;
+ case 5: goto L150;
+ case 6: goto L160;
+ case 7: goto L160;
+ case 8: goto L160;
+ case 9: goto L160;
+ case 10: goto L160;
+ case 11: goto L160;
+ case 12: goto L170;
+ case 13: goto L170;
+ case 14: goto L180;
+ case 15: goto L180;
+ case 16: goto L190;
+ case 17: goto L190;
+ }
+/* Test CGEMV, 01, and CGBMV, 02. */
+L140:
+ cchk1_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, alf,
+ &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, as, x, xx,
+ xs, y, yy, ys, yt, g, (ftnlen)6);
+ goto L200;
+/* Test CHEMV, 03, CHBMV, 04, and CHPMV, 05. */
+L150:
+ cchk2_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, alf,
+ &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, as, x, xx,
+ xs, y, yy, ys, yt, g, (ftnlen)6);
+ goto L200;
+/* Test CTRMV, 06, CTBMV, 07, CTPMV, 08, */
+/* CTRSV, 09, CTBSV, 10, and CTPSV, 11. */
+L160:
+ cchk3_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &ninc, inc,
+ &c__65, &c__2, a, aa, as, y, yy, ys, yt, g, z__, (ftnlen)
+ 6);
+ goto L200;
+/* Test CGERC, 12, CGERU, 13. */
+L170:
+ cchk4_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &ninc,
+ inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, ys, yt,
+ g, z__, (ftnlen)6);
+ goto L200;
+/* Test CHER, 14, and CHPR, 15. */
+L180:
+ cchk5_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &ninc,
+ inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, ys, yt,
+ g, z__, (ftnlen)6);
+ goto L200;
+/* Test CHER2, 16, and CHPR2, 17. */
+L190:
+ cchk6_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &ninc,
+ inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, ys, yt,
+ g, z__, (ftnlen)6);
+
+L200:
+ if (fatal && sfatal) {
+ goto L220;
+ }
+ }
+/* L210: */
+ }
+ io___90.ciunit = nout;
+ s_wsfe(&io___90);
+ e_wsfe();
+ goto L240;
+
+L220:
+ io___91.ciunit = nout;
+ s_wsfe(&io___91);
+ e_wsfe();
+ goto L240;
+
+L230:
+ io___92.ciunit = nout;
+ s_wsfe(&io___92);
+ e_wsfe();
+
+L240:
+ if (trace) {
+ cl__1.cerr = 0;
+ cl__1.cunit = ntra;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ }
+ cl__1.cerr = 0;
+ cl__1.cunit = nout;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ s_stop("", (ftnlen)0);
+
+
+/* End of CBLAT2. */
+
+ return 0;
+} /* MAIN__ */
+
+/* Subroutine */ int cchk1_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nkb, integer *kb, integer *
+ nalf, complex *alf, integer *nbet, complex *bet, integer *ninc,
+ integer *inc, integer *nmax, integer *incmax, complex *a, complex *aa,
+ complex *as, complex *x, complex *xx, complex *xs, complex *y,
+ complex *yy, complex *ys, complex *yt, real *g, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ich[3] = "NTC";
+
+ /* Format strings */
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "2(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,\002), A,\002,i3"
+ ",\002, X,\002,i2,\002,(\002,f4.1,\002,\002,f4.1,\002), Y,\002,i2,"
+ "\002) .\002)";
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "4(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,\002), A,\002,i3"
+ ",\002, X,\002,i2,\002,(\002,f4.1,\002,\002,f4.1,\002), Y,\002,i2,"
+ "\002) .\002)";
+ static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
+ i__9;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, m, n, ia, ib, ic, nc, nd, im, in, kl, ml, nk, nl, ku, ix, iy,
+ ms, lx, ly, ns, laa, lda;
+ extern logical lce_(complex *, complex *, integer *);
+ complex als, bls;
+ real err;
+ integer iku, kls, kus;
+ complex beta;
+ integer ldas;
+ logical same;
+ integer incx, incy;
+ logical full, tran, null;
+ extern /* Subroutine */ int cmake_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *, integer *,
+ integer *, logical *, complex *, ftnlen, ftnlen, ftnlen);
+ complex alpha;
+ logical isame[13];
+ extern /* Subroutine */ int cgbmv_(char *, integer *, integer *, integer *
+, integer *, complex *, complex *, integer *, complex *, integer *
+, complex *, complex *, integer *), cgemv_(char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *, complex *, complex *, integer *), cmvch_(char *
+ , integer *, integer *, complex *, complex *, integer *, complex *
+ , integer *, complex *, complex *, integer *, complex *, real *,
+ complex *, real *, real *, logical *, integer *, logical *,
+ ftnlen);
+ integer nargs;
+ logical reset;
+ integer incxs, incys;
+ char trans[1];
+ logical banded;
+ extern logical lceres_(char *, char *, integer *, integer *, complex *,
+ complex *, integer *, ftnlen, ftnlen);
+ real errmax;
+ complex transl;
+ char transs[1];
+
+ /* Fortran I/O blocks */
+ static cilist io___139 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___140 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___141 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___144 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___146 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___147 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___148 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___149 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___150 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests CGEMV and CGBMV. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --kb;
+ --alf;
+ --bet;
+ --inc;
+ --g;
+ --yt;
+ --y;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ys;
+ --yy;
+ --xs;
+ --xx;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ full = *(unsigned char *)&sname[2] == 'E';
+ banded = *(unsigned char *)&sname[2] == 'B';
+/* Define the number of arguments. */
+ if (full) {
+ nargs = 11;
+ } else if (banded) {
+ nargs = 13;
+ }
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.f;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+ nd = n / 2 + 1;
+
+ for (im = 1; im <= 2; ++im) {
+ if (im == 1) {
+/* Computing MAX */
+ i__2 = n - nd;
+ m = max(i__2,0);
+ }
+ if (im == 2) {
+/* Computing MIN */
+ i__2 = n + nd;
+ m = min(i__2,*nmax);
+ }
+
+ if (banded) {
+ nk = *nkb;
+ } else {
+ nk = 1;
+ }
+ i__2 = nk;
+ for (iku = 1; iku <= i__2; ++iku) {
+ if (banded) {
+ ku = kb[iku];
+/* Computing MAX */
+ i__3 = ku - 1;
+ kl = max(i__3,0);
+ } else {
+ ku = n - 1;
+ kl = m - 1;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ if (banded) {
+ lda = kl + ku + 1;
+ } else {
+ lda = m;
+ }
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L100;
+ }
+ laa = lda * n;
+ null = n <= 0 || m <= 0;
+
+/* Generate the matrix A. */
+
+ transl.r = 0.f, transl.i = 0.f;
+ cmake_(sname + 1, " ", " ", &m, &n, &a[a_offset], nmax, &aa[1]
+ , &lda, &kl, &ku, &reset, &transl, (ftnlen)2, (ftnlen)
+ 1, (ftnlen)1);
+
+ for (ic = 1; ic <= 3; ++ic) {
+ *(unsigned char *)trans = *(unsigned char *)&ich[ic - 1];
+ tran = *(unsigned char *)trans == 'T' || *(unsigned char *
+ )trans == 'C';
+
+ if (tran) {
+ ml = n;
+ nl = m;
+ } else {
+ ml = m;
+ nl = n;
+ }
+
+ i__3 = *ninc;
+ for (ix = 1; ix <= i__3; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * nl;
+
+/* Generate the vector X. */
+
+ transl.r = .5f, transl.i = 0.f;
+ i__4 = abs(incx);
+ i__5 = nl - 1;
+ cmake_("GE", " ", " ", &c__1, &nl, &x[1], &c__1, &xx[
+ 1], &i__4, &c__0, &i__5, &reset, &transl, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+ if (nl > 1) {
+ i__4 = nl / 2;
+ x[i__4].r = 0.f, x[i__4].i = 0.f;
+ i__4 = abs(incx) * (nl / 2 - 1) + 1;
+ xx[i__4].r = 0.f, xx[i__4].i = 0.f;
+ }
+
+ i__4 = *ninc;
+ for (iy = 1; iy <= i__4; ++iy) {
+ incy = inc[iy];
+ ly = abs(incy) * ml;
+
+ i__5 = *nalf;
+ for (ia = 1; ia <= i__5; ++ia) {
+ i__6 = ia;
+ alpha.r = alf[i__6].r, alpha.i = alf[i__6].i;
+
+ i__6 = *nbet;
+ for (ib = 1; ib <= i__6; ++ib) {
+ i__7 = ib;
+ beta.r = bet[i__7].r, beta.i = bet[i__7]
+ .i;
+
+/* Generate the vector Y. */
+
+ transl.r = 0.f, transl.i = 0.f;
+ i__7 = abs(incy);
+ i__8 = ml - 1;
+ cmake_("GE", " ", " ", &c__1, &ml, &y[1],
+ &c__1, &yy[1], &i__7, &c__0, &
+ i__8, &reset, &transl, (ftnlen)2,
+ (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the */
+/* subroutine. */
+
+ *(unsigned char *)transs = *(unsigned
+ char *)trans;
+ ms = m;
+ ns = n;
+ kls = kl;
+ kus = ku;
+ als.r = alpha.r, als.i = alpha.i;
+ i__7 = laa;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ i__8 = i__;
+ i__9 = i__;
+ as[i__8].r = aa[i__9].r, as[i__8].i =
+ aa[i__9].i;
+/* L10: */
+ }
+ ldas = lda;
+ i__7 = lx;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ i__8 = i__;
+ i__9 = i__;
+ xs[i__8].r = xx[i__9].r, xs[i__8].i =
+ xx[i__9].i;
+/* L20: */
+ }
+ incxs = incx;
+ bls.r = beta.r, bls.i = beta.i;
+ i__7 = ly;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ i__8 = i__;
+ i__9 = i__;
+ ys[i__8].r = yy[i__9].r, ys[i__8].i =
+ yy[i__9].i;
+/* L30: */
+ }
+ incys = incy;
+
+/* Call the subroutine. */
+
+ if (full) {
+ if (*trace) {
+ io___139.ciunit = *ntra;
+ s_wsfe(&io___139);
+ do_fio(&c__1, (char *)&nc, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (
+ ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (
+ ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incy, (
+ ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ cgemv_(trans, &m, &n, &alpha, &aa[1],
+ &lda, &xx[1], &incx, &beta, &
+ yy[1], &incy);
+ } else if (banded) {
+ if (*trace) {
+ io___140.ciunit = *ntra;
+ s_wsfe(&io___140);
+ do_fio(&c__1, (char *)&nc, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (
+ ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (
+ ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incy, (
+ ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ cgbmv_(trans, &m, &n, &kl, &ku, &
+ alpha, &aa[1], &lda, &xx[1], &
+ incx, &beta, &yy[1], &incy);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___141.ciunit = *nout;
+ s_wsfe(&io___141);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L130;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)trans == *(
+ unsigned char *)transs;
+ isame[1] = ms == m;
+ isame[2] = ns == n;
+ if (full) {
+ isame[3] = als.r == alpha.r && als.i
+ == alpha.i;
+ isame[4] = lce_(&as[1], &aa[1], &laa);
+ isame[5] = ldas == lda;
+ isame[6] = lce_(&xs[1], &xx[1], &lx);
+ isame[7] = incxs == incx;
+ isame[8] = bls.r == beta.r && bls.i ==
+ beta.i;
+ if (null) {
+ isame[9] = lce_(&ys[1], &yy[1], &
+ ly);
+ } else {
+ i__7 = abs(incy);
+ isame[9] = lceres_("GE", " ", &
+ c__1, &ml, &ys[1], &yy[1],
+ &i__7, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[10] = incys == incy;
+ } else if (banded) {
+ isame[3] = kls == kl;
+ isame[4] = kus == ku;
+ isame[5] = als.r == alpha.r && als.i
+ == alpha.i;
+ isame[6] = lce_(&as[1], &aa[1], &laa);
+ isame[7] = ldas == lda;
+ isame[8] = lce_(&xs[1], &xx[1], &lx);
+ isame[9] = incxs == incx;
+ isame[10] = bls.r == beta.r && bls.i
+ == beta.i;
+ if (null) {
+ isame[11] = lce_(&ys[1], &yy[1], &
+ ly);
+ } else {
+ i__7 = abs(incy);
+ isame[11] = lceres_("GE", " ", &
+ c__1, &ml, &ys[1], &yy[1],
+ &i__7, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[12] = incys == incy;
+ }
+
+/* If data was incorrectly changed, report */
+/* and return. */
+
+ same = TRUE_;
+ i__7 = nargs;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___144.ciunit = *nout;
+ s_wsfe(&io___144);
+ do_fio(&c__1, (char *)&i__, (
+ ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L130;
+ }
+
+ if (! null) {
+
+/* Check the result. */
+
+ cmvch_(trans, &m, &n, &alpha, &a[
+ a_offset], nmax, &x[1], &incx,
+ &beta, &y[1], &incy, &yt[1],
+ &g[1], &yy[1], eps, &err,
+ fatal, nout, &c_true, (ftnlen)
+ 1);
+ errmax = dmax(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L130;
+ }
+ } else {
+/* Avoid repeating tests with M.le.0 or */
+/* N.le.0. */
+ goto L110;
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+/* L70: */
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+L110:
+ ;
+ }
+
+/* L120: */
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___146.ciunit = *nout;
+ s_wsfe(&io___146);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___147.ciunit = *nout;
+ s_wsfe(&io___147);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ goto L140;
+
+L130:
+ io___148.ciunit = *nout;
+ s_wsfe(&io___148);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (full) {
+ io___149.ciunit = *nout;
+ s_wsfe(&io___149);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (banded) {
+ io___150.ciunit = *nout;
+ s_wsfe(&io___150);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L140:
+ return 0;
+
+
+/* End of CCHK1. */
+
+} /* cchk1_ */
+
+/* Subroutine */ int cchk2_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nkb, integer *kb, integer *
+ nalf, complex *alf, integer *nbet, complex *bet, integer *ninc,
+ integer *inc, integer *nmax, integer *incmax, complex *a, complex *aa,
+ complex *as, complex *x, complex *xx, complex *xs, complex *y,
+ complex *yy, complex *ys, complex *yt, real *g, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ich[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,(\002,f4.1,\002,\002,f4.1,\002), A,\002,i3,\002, X,\002,"
+ "i2,\002,(\002,f4.1,\002,\002,f4.1,\002), \002,\002Y,\002,i2,\002"
+ ") .\002)";
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "2(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,\002), A,\002,i3"
+ ",\002, X,\002,i2,\002,(\002,f4.1,\002,\002,f4.1,\002), Y,\002,i2,"
+ "\002) .\002)";
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,(\002,f4.1,\002,\002,f4.1,\002), AP, X,\002,i2,\002,("
+ "\002,f4.1,\002,\002,f4.1,\002), Y,\002,i2,\002) "
+ ".\002)";
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
+ i__9;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, k, n, ia, ib, ic, nc, ik, in, nk, ks, ix, iy, ns, lx, ly,
+ laa, lda;
+ extern logical lce_(complex *, complex *, integer *);
+ complex als, bls;
+ real err;
+ complex beta;
+ integer ldas;
+ logical same;
+ integer incx, incy;
+ logical full, null;
+ char uplo[1];
+ extern /* Subroutine */ int cmake_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *, integer *,
+ integer *, logical *, complex *, ftnlen, ftnlen, ftnlen);
+ complex alpha;
+ logical isame[13];
+ extern /* Subroutine */ int chbmv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *), chemv_(char *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, complex *,
+ integer *), cmvch_(char *, integer *, integer *, complex *
+ , complex *, integer *, complex *, integer *, complex *, complex *
+ , integer *, complex *, real *, complex *, real *, real *,
+ logical *, integer *, logical *, ftnlen);
+ integer nargs;
+ extern /* Subroutine */ int chpmv_(char *, integer *, complex *, complex *
+, complex *, integer *, complex *, complex *, integer *);
+ logical reset;
+ integer incxs, incys;
+ char uplos[1];
+ logical banded, packed;
+ extern logical lceres_(char *, char *, integer *, integer *, complex *,
+ complex *, integer *, ftnlen, ftnlen);
+ real errmax;
+ complex transl;
+
+ /* Fortran I/O blocks */
+ static cilist io___189 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___190 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___191 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___192 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___195 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___197 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___198 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___199 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___200 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___201 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___202 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests CHEMV, CHBMV and CHPMV. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --kb;
+ --alf;
+ --bet;
+ --inc;
+ --g;
+ --yt;
+ --y;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ys;
+ --yy;
+ --xs;
+ --xx;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ full = *(unsigned char *)&sname[2] == 'E';
+ banded = *(unsigned char *)&sname[2] == 'B';
+ packed = *(unsigned char *)&sname[2] == 'P';
+/* Define the number of arguments. */
+ if (full) {
+ nargs = 10;
+ } else if (banded) {
+ nargs = 11;
+ } else if (packed) {
+ nargs = 9;
+ }
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.f;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+
+ if (banded) {
+ nk = *nkb;
+ } else {
+ nk = 1;
+ }
+ i__2 = nk;
+ for (ik = 1; ik <= i__2; ++ik) {
+ if (banded) {
+ k = kb[ik];
+ } else {
+ k = n - 1;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ if (banded) {
+ lda = k + 1;
+ } else {
+ lda = n;
+ }
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L100;
+ }
+ if (packed) {
+ laa = n * (n + 1) / 2;
+ } else {
+ laa = lda * n;
+ }
+ null = n <= 0;
+
+ for (ic = 1; ic <= 2; ++ic) {
+ *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];
+
+/* Generate the matrix A. */
+
+ transl.r = 0.f, transl.i = 0.f;
+ cmake_(sname + 1, uplo, " ", &n, &n, &a[a_offset], nmax, &aa[
+ 1], &lda, &k, &k, &reset, &transl, (ftnlen)2, (ftnlen)
+ 1, (ftnlen)1);
+
+ i__3 = *ninc;
+ for (ix = 1; ix <= i__3; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * n;
+
+/* Generate the vector X. */
+
+ transl.r = .5f, transl.i = 0.f;
+ i__4 = abs(incx);
+ i__5 = n - 1;
+ cmake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &
+ i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (
+ ftnlen)1, (ftnlen)1);
+ if (n > 1) {
+ i__4 = n / 2;
+ x[i__4].r = 0.f, x[i__4].i = 0.f;
+ i__4 = abs(incx) * (n / 2 - 1) + 1;
+ xx[i__4].r = 0.f, xx[i__4].i = 0.f;
+ }
+
+ i__4 = *ninc;
+ for (iy = 1; iy <= i__4; ++iy) {
+ incy = inc[iy];
+ ly = abs(incy) * n;
+
+ i__5 = *nalf;
+ for (ia = 1; ia <= i__5; ++ia) {
+ i__6 = ia;
+ alpha.r = alf[i__6].r, alpha.i = alf[i__6].i;
+
+ i__6 = *nbet;
+ for (ib = 1; ib <= i__6; ++ib) {
+ i__7 = ib;
+ beta.r = bet[i__7].r, beta.i = bet[i__7].i;
+
+/* Generate the vector Y. */
+
+ transl.r = 0.f, transl.i = 0.f;
+ i__7 = abs(incy);
+ i__8 = n - 1;
+ cmake_("GE", " ", " ", &c__1, &n, &y[1], &
+ c__1, &yy[1], &i__7, &c__0, &i__8, &
+ reset, &transl, (ftnlen)2, (ftnlen)1,
+ (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the */
+/* subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)
+ uplo;
+ ns = n;
+ ks = k;
+ als.r = alpha.r, als.i = alpha.i;
+ i__7 = laa;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ i__8 = i__;
+ i__9 = i__;
+ as[i__8].r = aa[i__9].r, as[i__8].i = aa[
+ i__9].i;
+/* L10: */
+ }
+ ldas = lda;
+ i__7 = lx;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ i__8 = i__;
+ i__9 = i__;
+ xs[i__8].r = xx[i__9].r, xs[i__8].i = xx[
+ i__9].i;
+/* L20: */
+ }
+ incxs = incx;
+ bls.r = beta.r, bls.i = beta.i;
+ i__7 = ly;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ i__8 = i__;
+ i__9 = i__;
+ ys[i__8].r = yy[i__9].r, ys[i__8].i = yy[
+ i__9].i;
+/* L30: */
+ }
+ incys = incy;
+
+/* Call the subroutine. */
+
+ if (full) {
+ if (*trace) {
+ io___189.ciunit = *ntra;
+ s_wsfe(&io___189);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&incy, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ chemv_(uplo, &n, &alpha, &aa[1], &lda, &
+ xx[1], &incx, &beta, &yy[1], &
+ incy);
+ } else if (banded) {
+ if (*trace) {
+ io___190.ciunit = *ntra;
+ s_wsfe(&io___190);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&incy, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ chbmv_(uplo, &n, &k, &alpha, &aa[1], &lda,
+ &xx[1], &incx, &beta, &yy[1], &
+ incy);
+ } else if (packed) {
+ if (*trace) {
+ io___191.ciunit = *ntra;
+ s_wsfe(&io___191);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&incy, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ chpmv_(uplo, &n, &alpha, &aa[1], &xx[1], &
+ incx, &beta, &yy[1], &incy);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___192.ciunit = *nout;
+ s_wsfe(&io___192);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplo == *(
+ unsigned char *)uplos;
+ isame[1] = ns == n;
+ if (full) {
+ isame[2] = als.r == alpha.r && als.i ==
+ alpha.i;
+ isame[3] = lce_(&as[1], &aa[1], &laa);
+ isame[4] = ldas == lda;
+ isame[5] = lce_(&xs[1], &xx[1], &lx);
+ isame[6] = incxs == incx;
+ isame[7] = bls.r == beta.r && bls.i ==
+ beta.i;
+ if (null) {
+ isame[8] = lce_(&ys[1], &yy[1], &ly);
+ } else {
+ i__7 = abs(incy);
+ isame[8] = lceres_("GE", " ", &c__1, &
+ n, &ys[1], &yy[1], &i__7, (
+ ftnlen)2, (ftnlen)1);
+ }
+ isame[9] = incys == incy;
+ } else if (banded) {
+ isame[2] = ks == k;
+ isame[3] = als.r == alpha.r && als.i ==
+ alpha.i;
+ isame[4] = lce_(&as[1], &aa[1], &laa);
+ isame[5] = ldas == lda;
+ isame[6] = lce_(&xs[1], &xx[1], &lx);
+ isame[7] = incxs == incx;
+ isame[8] = bls.r == beta.r && bls.i ==
+ beta.i;
+ if (null) {
+ isame[9] = lce_(&ys[1], &yy[1], &ly);
+ } else {
+ i__7 = abs(incy);
+ isame[9] = lceres_("GE", " ", &c__1, &
+ n, &ys[1], &yy[1], &i__7, (
+ ftnlen)2, (ftnlen)1);
+ }
+ isame[10] = incys == incy;
+ } else if (packed) {
+ isame[2] = als.r == alpha.r && als.i ==
+ alpha.i;
+ isame[3] = lce_(&as[1], &aa[1], &laa);
+ isame[4] = lce_(&xs[1], &xx[1], &lx);
+ isame[5] = incxs == incx;
+ isame[6] = bls.r == beta.r && bls.i ==
+ beta.i;
+ if (null) {
+ isame[7] = lce_(&ys[1], &yy[1], &ly);
+ } else {
+ i__7 = abs(incy);
+ isame[7] = lceres_("GE", " ", &c__1, &
+ n, &ys[1], &yy[1], &i__7, (
+ ftnlen)2, (ftnlen)1);
+ }
+ isame[8] = incys == incy;
+ }
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__7 = nargs;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___195.ciunit = *nout;
+ s_wsfe(&io___195);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+
+/* Check the result. */
+
+ cmvch_("N", &n, &n, &alpha, &a[a_offset],
+ nmax, &x[1], &incx, &beta, &y[1],
+ &incy, &yt[1], &g[1], &yy[1], eps,
+ &err, fatal, nout, &c_true, (
+ ftnlen)1);
+ errmax = dmax(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L120;
+ }
+ } else {
+/* Avoid repeating tests with N.le.0 */
+ goto L110;
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+/* L70: */
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+L110:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___197.ciunit = *nout;
+ s_wsfe(&io___197);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___198.ciunit = *nout;
+ s_wsfe(&io___198);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ goto L130;
+
+L120:
+ io___199.ciunit = *nout;
+ s_wsfe(&io___199);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (full) {
+ io___200.ciunit = *nout;
+ s_wsfe(&io___200);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (banded) {
+ io___201.ciunit = *nout;
+ s_wsfe(&io___201);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (packed) {
+ io___202.ciunit = *nout;
+ s_wsfe(&io___202);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L130:
+ return 0;
+
+
+/* End of CCHK2. */
+
+} /* cchk2_ */
+
+/* Subroutine */ int cchk3_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nkb, integer *kb, integer *
+ ninc, integer *inc, integer *nmax, integer *incmax, complex *a,
+ complex *aa, complex *as, complex *x, complex *xx, complex *xs,
+ complex *xt, real *g, complex *z__, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ichu[2] = "UL";
+ static char icht[3] = "NTC";
+ static char ichd[2] = "UN";
+
+ /* Format strings */
+ static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002(\002,3(\002'\002,a1"
+ ",\002',\002),i3,\002, A,\002,i3,\002, X,\002,i2,\002) "
+ " .\002)";
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002(\002,3(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),\002 A,\002,i3,\002, X,\002,i2,\002"
+ ") .\002)";
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002(\002,3(\002'\002,a1"
+ ",\002',\002),i3,\002, AP, \002,\002X,\002,i2,\002) "
+ " .\002)";
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio(
+ integer *, char *, ftnlen), e_wsfe(void), f_rew(alist *);
+
+ /* Local variables */
+ integer i__, k, n, nc, ik, in, nk, ks, ix, ns, lx, laa, icd, lda;
+ extern logical lce_(complex *, complex *, integer *);
+ integer ict, icu;
+ real err;
+ char diag[1];
+ integer ldas;
+ logical same;
+ integer incx;
+ logical full, null;
+ char uplo[1];
+ extern /* Subroutine */ int cmake_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *, integer *,
+ integer *, logical *, complex *, ftnlen, ftnlen, ftnlen);
+ char diags[1];
+ logical isame[13];
+ extern /* Subroutine */ int cmvch_(char *, integer *, integer *, complex *
+ , complex *, integer *, complex *, integer *, complex *, complex *
+ , integer *, complex *, real *, complex *, real *, real *,
+ logical *, integer *, logical *, ftnlen);
+ integer nargs;
+ extern /* Subroutine */ int ctbmv_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *), ctbsv_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *);
+ logical reset;
+ integer incxs;
+ char trans[1];
+ extern /* Subroutine */ int ctpmv_(char *, char *, char *, integer *,
+ complex *, complex *, integer *), ctrmv_(
+ char *, char *, char *, integer *, complex *, integer *, complex *
+, integer *), ctpsv_(char *, char *, char
+ *, integer *, complex *, complex *, integer *);
+ char uplos[1];
+ extern /* Subroutine */ int ctrsv_(char *, char *, char *, integer *,
+ complex *, integer *, complex *, integer *);
+ logical banded, packed;
+ extern logical lceres_(char *, char *, integer *, integer *, complex *,
+ complex *, integer *, ftnlen, ftnlen);
+ real errmax;
+ complex transl;
+ char transs[1];
+
+ /* Fortran I/O blocks */
+ static cilist io___239 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___240 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___241 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___242 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___243 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___244 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___245 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___248 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___250 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___251 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___252 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___253 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___254 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___255 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests CTRMV, CTBMV, CTPMV, CTRSV, CTBSV and CTPSV. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --kb;
+ --inc;
+ --z__;
+ --g;
+ --xt;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --xs;
+ --xx;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ full = *(unsigned char *)&sname[2] == 'R';
+ banded = *(unsigned char *)&sname[2] == 'B';
+ packed = *(unsigned char *)&sname[2] == 'P';
+/* Define the number of arguments. */
+ if (full) {
+ nargs = 8;
+ } else if (banded) {
+ nargs = 9;
+ } else if (packed) {
+ nargs = 7;
+ }
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.f;
+/* Set up zero vector for CMVCH. */
+ i__1 = *nmax;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ z__[i__2].r = 0.f, z__[i__2].i = 0.f;
+/* L10: */
+ }
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+
+ if (banded) {
+ nk = *nkb;
+ } else {
+ nk = 1;
+ }
+ i__2 = nk;
+ for (ik = 1; ik <= i__2; ++ik) {
+ if (banded) {
+ k = kb[ik];
+ } else {
+ k = n - 1;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ if (banded) {
+ lda = k + 1;
+ } else {
+ lda = n;
+ }
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L100;
+ }
+ if (packed) {
+ laa = n * (n + 1) / 2;
+ } else {
+ laa = lda * n;
+ }
+ null = n <= 0;
+
+ for (icu = 1; icu <= 2; ++icu) {
+ *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
+
+ for (ict = 1; ict <= 3; ++ict) {
+ *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]
+ ;
+
+ for (icd = 1; icd <= 2; ++icd) {
+ *(unsigned char *)diag = *(unsigned char *)&ichd[icd
+ - 1];
+
+/* Generate the matrix A. */
+
+ transl.r = 0.f, transl.i = 0.f;
+ cmake_(sname + 1, uplo, diag, &n, &n, &a[a_offset],
+ nmax, &aa[1], &lda, &k, &k, &reset, &transl, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ i__3 = *ninc;
+ for (ix = 1; ix <= i__3; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * n;
+
+/* Generate the vector X. */
+
+ transl.r = .5f, transl.i = 0.f;
+ i__4 = abs(incx);
+ i__5 = n - 1;
+ cmake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &
+ xx[1], &i__4, &c__0, &i__5, &reset, &
+ transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);
+ if (n > 1) {
+ i__4 = n / 2;
+ x[i__4].r = 0.f, x[i__4].i = 0.f;
+ i__4 = abs(incx) * (n / 2 - 1) + 1;
+ xx[i__4].r = 0.f, xx[i__4].i = 0.f;
+ }
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ *(unsigned char *)transs = *(unsigned char *)
+ trans;
+ *(unsigned char *)diags = *(unsigned char *)diag;
+ ns = n;
+ ks = k;
+ i__4 = laa;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__;
+ i__6 = i__;
+ as[i__5].r = aa[i__6].r, as[i__5].i = aa[i__6]
+ .i;
+/* L20: */
+ }
+ ldas = lda;
+ i__4 = lx;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__;
+ i__6 = i__;
+ xs[i__5].r = xx[i__6].r, xs[i__5].i = xx[i__6]
+ .i;
+/* L30: */
+ }
+ incxs = incx;
+
+/* Call the subroutine. */
+
+ if (s_cmp(sname + 3, "MV", (ftnlen)2, (ftnlen)2)
+ == 0) {
+ if (full) {
+ if (*trace) {
+ io___239.ciunit = *ntra;
+ s_wsfe(&io___239);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ctrmv_(uplo, trans, diag, &n, &aa[1], &
+ lda, &xx[1], &incx);
+ } else if (banded) {
+ if (*trace) {
+ io___240.ciunit = *ntra;
+ s_wsfe(&io___240);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ctbmv_(uplo, trans, diag, &n, &k, &aa[1],
+ &lda, &xx[1], &incx);
+ } else if (packed) {
+ if (*trace) {
+ io___241.ciunit = *ntra;
+ s_wsfe(&io___241);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ctpmv_(uplo, trans, diag, &n, &aa[1], &xx[
+ 1], &incx);
+ }
+ } else if (s_cmp(sname + 3, "SV", (ftnlen)2, (
+ ftnlen)2) == 0) {
+ if (full) {
+ if (*trace) {
+ io___242.ciunit = *ntra;
+ s_wsfe(&io___242);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ctrsv_(uplo, trans, diag, &n, &aa[1], &
+ lda, &xx[1], &incx);
+ } else if (banded) {
+ if (*trace) {
+ io___243.ciunit = *ntra;
+ s_wsfe(&io___243);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ctbsv_(uplo, trans, diag, &n, &k, &aa[1],
+ &lda, &xx[1], &incx);
+ } else if (packed) {
+ if (*trace) {
+ io___244.ciunit = *ntra;
+ s_wsfe(&io___244);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ctpsv_(uplo, trans, diag, &n, &aa[1], &xx[
+ 1], &incx);
+ }
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___245.ciunit = *nout;
+ s_wsfe(&io___245);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplo == *(unsigned
+ char *)uplos;
+ isame[1] = *(unsigned char *)trans == *(unsigned
+ char *)transs;
+ isame[2] = *(unsigned char *)diag == *(unsigned
+ char *)diags;
+ isame[3] = ns == n;
+ if (full) {
+ isame[4] = lce_(&as[1], &aa[1], &laa);
+ isame[5] = ldas == lda;
+ if (null) {
+ isame[6] = lce_(&xs[1], &xx[1], &lx);
+ } else {
+ i__4 = abs(incx);
+ isame[6] = lceres_("GE", " ", &c__1, &n, &
+ xs[1], &xx[1], &i__4, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[7] = incxs == incx;
+ } else if (banded) {
+ isame[4] = ks == k;
+ isame[5] = lce_(&as[1], &aa[1], &laa);
+ isame[6] = ldas == lda;
+ if (null) {
+ isame[7] = lce_(&xs[1], &xx[1], &lx);
+ } else {
+ i__4 = abs(incx);
+ isame[7] = lceres_("GE", " ", &c__1, &n, &
+ xs[1], &xx[1], &i__4, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[8] = incxs == incx;
+ } else if (packed) {
+ isame[4] = lce_(&as[1], &aa[1], &laa);
+ if (null) {
+ isame[5] = lce_(&xs[1], &xx[1], &lx);
+ } else {
+ i__4 = abs(incx);
+ isame[5] = lceres_("GE", " ", &c__1, &n, &
+ xs[1], &xx[1], &i__4, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[6] = incxs == incx;
+ }
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__4 = nargs;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___248.ciunit = *nout;
+ s_wsfe(&io___248);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+ if (s_cmp(sname + 3, "MV", (ftnlen)2, (ftnlen)
+ 2) == 0) {
+
+/* Check the result. */
+
+ cmvch_(trans, &n, &n, &c_b2, &a[a_offset],
+ nmax, &x[1], &incx, &c_b1, &z__[
+ 1], &incx, &xt[1], &g[1], &xx[1],
+ eps, &err, fatal, nout, &c_true, (
+ ftnlen)1);
+ } else if (s_cmp(sname + 3, "SV", (ftnlen)2, (
+ ftnlen)2) == 0) {
+
+/* Compute approximation to original vector. */
+
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__;
+ i__6 = (i__ - 1) * abs(incx) + 1;
+ z__[i__5].r = xx[i__6].r, z__[i__5].i
+ = xx[i__6].i;
+ i__5 = (i__ - 1) * abs(incx) + 1;
+ i__6 = i__;
+ xx[i__5].r = x[i__6].r, xx[i__5].i =
+ x[i__6].i;
+/* L50: */
+ }
+ cmvch_(trans, &n, &n, &c_b2, &a[a_offset],
+ nmax, &z__[1], &incx, &c_b1, &x[
+ 1], &incx, &xt[1], &g[1], &xx[1],
+ eps, &err, fatal, nout, &c_false,
+ (ftnlen)1);
+ }
+ errmax = dmax(errmax,err);
+/* If got really bad answer, report and return. */
+ if (*fatal) {
+ goto L120;
+ }
+ } else {
+/* Avoid repeating tests with N.le.0. */
+ goto L110;
+ }
+
+/* L60: */
+ }
+
+/* L70: */
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+L110:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___250.ciunit = *nout;
+ s_wsfe(&io___250);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___251.ciunit = *nout;
+ s_wsfe(&io___251);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ goto L130;
+
+L120:
+ io___252.ciunit = *nout;
+ s_wsfe(&io___252);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (full) {
+ io___253.ciunit = *nout;
+ s_wsfe(&io___253);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (banded) {
+ io___254.ciunit = *nout;
+ s_wsfe(&io___254);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (packed) {
+ io___255.ciunit = *nout;
+ s_wsfe(&io___255);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L130:
+ return 0;
+
+
+/* End of CCHK3. */
+
+} /* cchk3_ */
+
+/* Subroutine */ int cchk4_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nalf, complex *alf, integer *
+ ninc, integer *inc, integer *nmax, integer *incmax, complex *a,
+ complex *aa, complex *as, complex *x, complex *xx, complex *xs,
+ complex *y, complex *yy, complex *ys, complex *yt, real *g, complex *
+ z__, ftnlen sname_len)
+{
+ /* Format strings */
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002(\002,2(i3,\002,"
+ "\002),\002(\002,f4.1,\002,\002,f4.1,\002), X,\002,i2,\002, Y,"
+ "\002,i2,\002, A,\002,i3,\002) \002,\002 "
+ ".\002)";
+ static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+ complex q__1;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, m, n;
+ complex w[1];
+ integer ia, nc, nd, im, in, ms, ix, iy, ns, lx, ly, laa, lda;
+ extern logical lce_(complex *, complex *, integer *);
+ complex als;
+ real err;
+ integer ldas;
+ logical same, conj;
+ integer incx, incy;
+ logical null;
+ extern /* Subroutine */ int cmake_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *, integer *,
+ integer *, logical *, complex *, ftnlen, ftnlen, ftnlen), cgerc_(
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *, complex *, integer *);
+ complex alpha;
+ logical isame[13];
+ extern /* Subroutine */ int cmvch_(char *, integer *, integer *, complex *
+ , complex *, integer *, complex *, integer *, complex *, complex *
+ , integer *, complex *, real *, complex *, real *, real *,
+ logical *, integer *, logical *, ftnlen), cgeru_(integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, integer *);
+ integer nargs;
+ logical reset;
+ integer incxs, incys;
+ extern logical lceres_(char *, char *, integer *, integer *, complex *,
+ complex *, integer *, ftnlen, ftnlen);
+ real errmax;
+ complex transl;
+
+ /* Fortran I/O blocks */
+ static cilist io___285 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___286 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___289 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___293 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___294 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___295 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___296 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___297 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* Tests CGERC and CGERU. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --inc;
+ --z__;
+ --g;
+ --yt;
+ --y;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ys;
+ --yy;
+ --xs;
+ --xx;
+
+ /* Function Body */
+ conj = *(unsigned char *)&sname[4] == 'C';
+/* Define the number of arguments. */
+ nargs = 9;
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.f;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+ nd = n / 2 + 1;
+
+ for (im = 1; im <= 2; ++im) {
+ if (im == 1) {
+/* Computing MAX */
+ i__2 = n - nd;
+ m = max(i__2,0);
+ }
+ if (im == 2) {
+/* Computing MIN */
+ i__2 = n + nd;
+ m = min(i__2,*nmax);
+ }
+
+/* Set LDA to 1 more than minimum value if room. */
+ lda = m;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L110;
+ }
+ laa = lda * n;
+ null = n <= 0 || m <= 0;
+
+ i__2 = *ninc;
+ for (ix = 1; ix <= i__2; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * m;
+
+/* Generate the vector X. */
+
+ transl.r = .5f, transl.i = 0.f;
+ i__3 = abs(incx);
+ i__4 = m - 1;
+ cmake_("GE", " ", " ", &c__1, &m, &x[1], &c__1, &xx[1], &i__3,
+ &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1,
+ (ftnlen)1);
+ if (m > 1) {
+ i__3 = m / 2;
+ x[i__3].r = 0.f, x[i__3].i = 0.f;
+ i__3 = abs(incx) * (m / 2 - 1) + 1;
+ xx[i__3].r = 0.f, xx[i__3].i = 0.f;
+ }
+
+ i__3 = *ninc;
+ for (iy = 1; iy <= i__3; ++iy) {
+ incy = inc[iy];
+ ly = abs(incy) * n;
+
+/* Generate the vector Y. */
+
+ transl.r = 0.f, transl.i = 0.f;
+ i__4 = abs(incy);
+ i__5 = n - 1;
+ cmake_("GE", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], &
+ i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (
+ ftnlen)1, (ftnlen)1);
+ if (n > 1) {
+ i__4 = n / 2;
+ y[i__4].r = 0.f, y[i__4].i = 0.f;
+ i__4 = abs(incy) * (n / 2 - 1) + 1;
+ yy[i__4].r = 0.f, yy[i__4].i = 0.f;
+ }
+
+ i__4 = *nalf;
+ for (ia = 1; ia <= i__4; ++ia) {
+ i__5 = ia;
+ alpha.r = alf[i__5].r, alpha.i = alf[i__5].i;
+
+/* Generate the matrix A. */
+
+ transl.r = 0.f, transl.i = 0.f;
+ i__5 = m - 1;
+ i__6 = n - 1;
+ cmake_(sname + 1, " ", " ", &m, &n, &a[a_offset],
+ nmax, &aa[1], &lda, &i__5, &i__6, &reset, &
+ transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ ms = m;
+ ns = n;
+ als.r = alpha.r, als.i = alpha.i;
+ i__5 = laa;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7].i;
+/* L10: */
+ }
+ ldas = lda;
+ i__5 = lx;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ xs[i__6].r = xx[i__7].r, xs[i__6].i = xx[i__7].i;
+/* L20: */
+ }
+ incxs = incx;
+ i__5 = ly;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ ys[i__6].r = yy[i__7].r, ys[i__6].i = yy[i__7].i;
+/* L30: */
+ }
+ incys = incy;
+
+/* Call the subroutine. */
+
+ if (*trace) {
+ io___285.ciunit = *ntra;
+ s_wsfe(&io___285);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(real)
+ );
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (conj) {
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ cgerc_(&m, &n, &alpha, &xx[1], &incx, &yy[1], &
+ incy, &aa[1], &lda);
+ } else {
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ cgeru_(&m, &n, &alpha, &xx[1], &incx, &yy[1], &
+ incy, &aa[1], &lda);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___286.ciunit = *nout;
+ s_wsfe(&io___286);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L140;
+ }
+
+/* See what data changed inside subroutine. */
+
+ isame[0] = ms == m;
+ isame[1] = ns == n;
+ isame[2] = als.r == alpha.r && als.i == alpha.i;
+ isame[3] = lce_(&xs[1], &xx[1], &lx);
+ isame[4] = incxs == incx;
+ isame[5] = lce_(&ys[1], &yy[1], &ly);
+ isame[6] = incys == incy;
+ if (null) {
+ isame[7] = lce_(&as[1], &aa[1], &laa);
+ } else {
+ isame[7] = lceres_("GE", " ", &m, &n, &as[1], &aa[
+ 1], &lda, (ftnlen)2, (ftnlen)1);
+ }
+ isame[8] = ldas == lda;
+
+/* If data was incorrectly changed, report and return. */
+
+ same = TRUE_;
+ i__5 = nargs;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___289.ciunit = *nout;
+ s_wsfe(&io___289);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L140;
+ }
+
+ if (! null) {
+
+/* Check the result column by column. */
+
+ if (incx > 0) {
+ i__5 = m;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ z__[i__6].r = x[i__7].r, z__[i__6].i = x[
+ i__7].i;
+/* L50: */
+ }
+ } else {
+ i__5 = m;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = m - i__ + 1;
+ z__[i__6].r = x[i__7].r, z__[i__6].i = x[
+ i__7].i;
+/* L60: */
+ }
+ }
+ i__5 = n;
+ for (j = 1; j <= i__5; ++j) {
+ if (incy > 0) {
+ i__6 = j;
+ w[0].r = y[i__6].r, w[0].i = y[i__6].i;
+ } else {
+ i__6 = n - j + 1;
+ w[0].r = y[i__6].r, w[0].i = y[i__6].i;
+ }
+ if (conj) {
+ r_cnjg(&q__1, w);
+ w[0].r = q__1.r, w[0].i = q__1.i;
+ }
+ cmvch_("N", &m, &c__1, &alpha, &z__[1], nmax,
+ w, &c__1, &c_b2, &a[j * a_dim1 + 1], &
+ c__1, &yt[1], &g[1], &aa[(j - 1) *
+ lda + 1], eps, &err, fatal, nout, &
+ c_true, (ftnlen)1);
+ errmax = dmax(errmax,err);
+/* If got really bad answer, report and return. */
+ if (*fatal) {
+ goto L130;
+ }
+/* L70: */
+ }
+ } else {
+/* Avoid repeating tests with M.le.0 or N.le.0. */
+ goto L110;
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+/* L100: */
+ }
+
+L110:
+ ;
+ }
+
+/* L120: */
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___293.ciunit = *nout;
+ s_wsfe(&io___293);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___294.ciunit = *nout;
+ s_wsfe(&io___294);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ goto L150;
+
+L130:
+ io___295.ciunit = *nout;
+ s_wsfe(&io___295);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L140:
+ io___296.ciunit = *nout;
+ s_wsfe(&io___296);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ io___297.ciunit = *nout;
+ s_wsfe(&io___297);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L150:
+ return 0;
+
+
+/* End of CCHK4. */
+
+} /* cchk4_ */
+
+/* Subroutine */ int cchk5_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nalf, complex *alf, integer *
+ ninc, integer *inc, integer *nmax, integer *incmax, complex *a,
+ complex *aa, complex *as, complex *x, complex *xx, complex *xs,
+ complex *y, complex *yy, complex *ys, complex *yt, real *g, complex *
+ z__, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ich[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,\002,f4.1,\002, X,\002,i2,\002, A,\002,i3,\002) "
+ " .\002)";
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,\002,f4.1,\002, X,\002,i2,\002, AP) "
+ " .\002)";
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ complex q__1;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, n;
+ complex w[1];
+ integer ia, ja, ic, nc, jj, lj, in, ix, ns, lx, laa, lda;
+ extern logical lce_(complex *, complex *, integer *);
+ real err;
+ extern /* Subroutine */ int cher_(char *, integer *, real *, complex *,
+ integer *, complex *, integer *);
+ integer ldas;
+ logical same;
+ extern /* Subroutine */ int chpr_(char *, integer *, real *, complex *,
+ integer *, complex *);
+ real rals;
+ integer incx;
+ logical full, null;
+ char uplo[1];
+ extern /* Subroutine */ int cmake_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *, integer *,
+ integer *, logical *, complex *, ftnlen, ftnlen, ftnlen);
+ complex alpha;
+ logical isame[13];
+ extern /* Subroutine */ int cmvch_(char *, integer *, integer *, complex *
+ , complex *, integer *, complex *, integer *, complex *, complex *
+ , integer *, complex *, real *, complex *, real *, real *,
+ logical *, integer *, logical *, ftnlen);
+ integer nargs;
+ logical reset;
+ integer incxs;
+ logical upper;
+ char uplos[1];
+ logical packed;
+ real ralpha;
+ extern logical lceres_(char *, char *, integer *, integer *, complex *,
+ complex *, integer *, ftnlen, ftnlen);
+ real errmax;
+ complex transl;
+
+ /* Fortran I/O blocks */
+ static cilist io___326 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___327 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___328 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___331 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___338 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___339 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___340 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___341 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___342 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___343 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* Tests CHER and CHPR. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --inc;
+ --z__;
+ --g;
+ --yt;
+ --y;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ys;
+ --yy;
+ --xs;
+ --xx;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ full = *(unsigned char *)&sname[2] == 'E';
+ packed = *(unsigned char *)&sname[2] == 'P';
+/* Define the number of arguments. */
+ if (full) {
+ nargs = 7;
+ } else if (packed) {
+ nargs = 6;
+ }
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.f;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+/* Set LDA to 1 more than minimum value if room. */
+ lda = n;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L100;
+ }
+ if (packed) {
+ laa = n * (n + 1) / 2;
+ } else {
+ laa = lda * n;
+ }
+
+ for (ic = 1; ic <= 2; ++ic) {
+ *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];
+ upper = *(unsigned char *)uplo == 'U';
+
+ i__2 = *ninc;
+ for (ix = 1; ix <= i__2; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * n;
+
+/* Generate the vector X. */
+
+ transl.r = .5f, transl.i = 0.f;
+ i__3 = abs(incx);
+ i__4 = n - 1;
+ cmake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3,
+ &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1,
+ (ftnlen)1);
+ if (n > 1) {
+ i__3 = n / 2;
+ x[i__3].r = 0.f, x[i__3].i = 0.f;
+ i__3 = abs(incx) * (n / 2 - 1) + 1;
+ xx[i__3].r = 0.f, xx[i__3].i = 0.f;
+ }
+
+ i__3 = *nalf;
+ for (ia = 1; ia <= i__3; ++ia) {
+ i__4 = ia;
+ ralpha = alf[i__4].r;
+ q__1.r = ralpha, q__1.i = 0.f;
+ alpha.r = q__1.r, alpha.i = q__1.i;
+ null = n <= 0 || ralpha == 0.f;
+
+/* Generate the matrix A. */
+
+ transl.r = 0.f, transl.i = 0.f;
+ i__4 = n - 1;
+ i__5 = n - 1;
+ cmake_(sname + 1, uplo, " ", &n, &n, &a[a_offset], nmax, &
+ aa[1], &lda, &i__4, &i__5, &reset, &transl, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ ns = n;
+ rals = ralpha;
+ i__4 = laa;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__;
+ i__6 = i__;
+ as[i__5].r = aa[i__6].r, as[i__5].i = aa[i__6].i;
+/* L10: */
+ }
+ ldas = lda;
+ i__4 = lx;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__;
+ i__6 = i__;
+ xs[i__5].r = xx[i__6].r, xs[i__5].i = xx[i__6].i;
+/* L20: */
+ }
+ incxs = incx;
+
+/* Call the subroutine. */
+
+ if (full) {
+ if (*trace) {
+ io___326.ciunit = *ntra;
+ s_wsfe(&io___326);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&ralpha, (ftnlen)sizeof(
+ real));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ cher_(uplo, &n, &ralpha, &xx[1], &incx, &aa[1], &lda);
+ } else if (packed) {
+ if (*trace) {
+ io___327.ciunit = *ntra;
+ s_wsfe(&io___327);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&ralpha, (ftnlen)sizeof(
+ real));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ chpr_(uplo, &n, &ralpha, &xx[1], &incx, &aa[1]);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___328.ciunit = *nout;
+ s_wsfe(&io___328);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplo == *(unsigned char *)
+ uplos;
+ isame[1] = ns == n;
+ isame[2] = rals == ralpha;
+ isame[3] = lce_(&xs[1], &xx[1], &lx);
+ isame[4] = incxs == incx;
+ if (null) {
+ isame[5] = lce_(&as[1], &aa[1], &laa);
+ } else {
+ isame[5] = lceres_(sname + 1, uplo, &n, &n, &as[1], &
+ aa[1], &lda, (ftnlen)2, (ftnlen)1);
+ }
+ if (! packed) {
+ isame[6] = ldas == lda;
+ }
+
+/* If data was incorrectly changed, report and return. */
+
+ same = TRUE_;
+ i__4 = nargs;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___331.ciunit = *nout;
+ s_wsfe(&io___331);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+/* L30: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+
+/* Check the result column by column. */
+
+ if (incx > 0) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__;
+ i__6 = i__;
+ z__[i__5].r = x[i__6].r, z__[i__5].i = x[i__6]
+ .i;
+/* L40: */
+ }
+ } else {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__;
+ i__6 = n - i__ + 1;
+ z__[i__5].r = x[i__6].r, z__[i__5].i = x[i__6]
+ .i;
+/* L50: */
+ }
+ }
+ ja = 1;
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ r_cnjg(&q__1, &z__[j]);
+ w[0].r = q__1.r, w[0].i = q__1.i;
+ if (upper) {
+ jj = 1;
+ lj = j;
+ } else {
+ jj = j;
+ lj = n - j + 1;
+ }
+ cmvch_("N", &lj, &c__1, &alpha, &z__[jj], &lj, w,
+ &c__1, &c_b2, &a[jj + j * a_dim1], &c__1,
+ &yt[1], &g[1], &aa[ja], eps, &err, fatal,
+ nout, &c_true, (ftnlen)1);
+ if (full) {
+ if (upper) {
+ ja += lda;
+ } else {
+ ja = ja + lda + 1;
+ }
+ } else {
+ ja += lj;
+ }
+ errmax = dmax(errmax,err);
+/* If got really bad answer, report and return. */
+ if (*fatal) {
+ goto L110;
+ }
+/* L60: */
+ }
+ } else {
+/* Avoid repeating tests if N.le.0. */
+ if (n <= 0) {
+ goto L100;
+ }
+ }
+
+/* L70: */
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___338.ciunit = *nout;
+ s_wsfe(&io___338);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___339.ciunit = *nout;
+ s_wsfe(&io___339);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ goto L130;
+
+L110:
+ io___340.ciunit = *nout;
+ s_wsfe(&io___340);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L120:
+ io___341.ciunit = *nout;
+ s_wsfe(&io___341);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (full) {
+ io___342.ciunit = *nout;
+ s_wsfe(&io___342);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ralpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (packed) {
+ io___343.ciunit = *nout;
+ s_wsfe(&io___343);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ralpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L130:
+ return 0;
+
+
+/* End of CCHK5. */
+
+} /* cchk5_ */
+
+/* Subroutine */ int cchk6_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nalf, complex *alf, integer *
+ ninc, integer *inc, integer *nmax, integer *incmax, complex *a,
+ complex *aa, complex *as, complex *x, complex *xx, complex *xs,
+ complex *y, complex *yy, complex *ys, complex *yt, real *g, complex *
+ z__, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ich[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,(\002,f4.1,\002,\002,f4.1,\002), X,\002,i2,\002, Y,\002,"
+ "i2,\002, A,\002,i3,\002) \002,\002 .\002)";
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,(\002,f4.1,\002,\002,f4.1,\002), X,\002,i2,\002, Y,\002,"
+ "i2,\002, AP) \002,\002 .\002)";
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6, i__7;
+ complex q__1, q__2, q__3;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, n;
+ complex w[2];
+ integer ia, ja, ic, nc, jj, lj, in, ix, iy, ns, lx, ly, laa, lda;
+ extern logical lce_(complex *, complex *, integer *);
+ complex als;
+ real err;
+ integer ldas;
+ logical same;
+ integer incx, incy;
+ logical full, null;
+ char uplo[1];
+ extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex *
+, integer *, complex *, integer *, complex *, integer *),
+ chpr2_(char *, integer *, complex *, complex *, integer *,
+ complex *, integer *, complex *), cmake_(char *, char *,
+ char *, integer *, integer *, complex *, integer *, complex *,
+ integer *, integer *, integer *, logical *, complex *, ftnlen,
+ ftnlen, ftnlen);
+ complex alpha;
+ logical isame[13];
+ extern /* Subroutine */ int cmvch_(char *, integer *, integer *, complex *
+ , complex *, integer *, complex *, integer *, complex *, complex *
+ , integer *, complex *, real *, complex *, real *, real *,
+ logical *, integer *, logical *, ftnlen);
+ integer nargs;
+ logical reset;
+ integer incxs, incys;
+ logical upper;
+ char uplos[1];
+ logical packed;
+ extern logical lceres_(char *, char *, integer *, integer *, complex *,
+ complex *, integer *, ftnlen, ftnlen);
+ real errmax;
+ complex transl;
+
+ /* Fortran I/O blocks */
+ static cilist io___375 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___376 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___377 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___380 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___387 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___388 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___389 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___390 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___391 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___392 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* Tests CHER2 and CHPR2. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --inc;
+ z_dim1 = *nmax;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --g;
+ --yt;
+ --y;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ys;
+ --yy;
+ --xs;
+ --xx;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ full = *(unsigned char *)&sname[2] == 'E';
+ packed = *(unsigned char *)&sname[2] == 'P';
+/* Define the number of arguments. */
+ if (full) {
+ nargs = 9;
+ } else if (packed) {
+ nargs = 8;
+ }
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.f;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+/* Set LDA to 1 more than minimum value if room. */
+ lda = n;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L140;
+ }
+ if (packed) {
+ laa = n * (n + 1) / 2;
+ } else {
+ laa = lda * n;
+ }
+
+ for (ic = 1; ic <= 2; ++ic) {
+ *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];
+ upper = *(unsigned char *)uplo == 'U';
+
+ i__2 = *ninc;
+ for (ix = 1; ix <= i__2; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * n;
+
+/* Generate the vector X. */
+
+ transl.r = .5f, transl.i = 0.f;
+ i__3 = abs(incx);
+ i__4 = n - 1;
+ cmake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3,
+ &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1,
+ (ftnlen)1);
+ if (n > 1) {
+ i__3 = n / 2;
+ x[i__3].r = 0.f, x[i__3].i = 0.f;
+ i__3 = abs(incx) * (n / 2 - 1) + 1;
+ xx[i__3].r = 0.f, xx[i__3].i = 0.f;
+ }
+
+ i__3 = *ninc;
+ for (iy = 1; iy <= i__3; ++iy) {
+ incy = inc[iy];
+ ly = abs(incy) * n;
+
+/* Generate the vector Y. */
+
+ transl.r = 0.f, transl.i = 0.f;
+ i__4 = abs(incy);
+ i__5 = n - 1;
+ cmake_("GE", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], &
+ i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (
+ ftnlen)1, (ftnlen)1);
+ if (n > 1) {
+ i__4 = n / 2;
+ y[i__4].r = 0.f, y[i__4].i = 0.f;
+ i__4 = abs(incy) * (n / 2 - 1) + 1;
+ yy[i__4].r = 0.f, yy[i__4].i = 0.f;
+ }
+
+ i__4 = *nalf;
+ for (ia = 1; ia <= i__4; ++ia) {
+ i__5 = ia;
+ alpha.r = alf[i__5].r, alpha.i = alf[i__5].i;
+ null = n <= 0 || alpha.r == 0.f && alpha.i == 0.f;
+
+/* Generate the matrix A. */
+
+ transl.r = 0.f, transl.i = 0.f;
+ i__5 = n - 1;
+ i__6 = n - 1;
+ cmake_(sname + 1, uplo, " ", &n, &n, &a[a_offset],
+ nmax, &aa[1], &lda, &i__5, &i__6, &reset, &
+ transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ ns = n;
+ als.r = alpha.r, als.i = alpha.i;
+ i__5 = laa;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7].i;
+/* L10: */
+ }
+ ldas = lda;
+ i__5 = lx;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ xs[i__6].r = xx[i__7].r, xs[i__6].i = xx[i__7].i;
+/* L20: */
+ }
+ incxs = incx;
+ i__5 = ly;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ ys[i__6].r = yy[i__7].r, ys[i__6].i = yy[i__7].i;
+/* L30: */
+ }
+ incys = incy;
+
+/* Call the subroutine. */
+
+ if (full) {
+ if (*trace) {
+ io___375.ciunit = *ntra;
+ s_wsfe(&io___375);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(
+ real));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ cher2_(uplo, &n, &alpha, &xx[1], &incx, &yy[1], &
+ incy, &aa[1], &lda);
+ } else if (packed) {
+ if (*trace) {
+ io___376.ciunit = *ntra;
+ s_wsfe(&io___376);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(
+ real));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ chpr2_(uplo, &n, &alpha, &xx[1], &incx, &yy[1], &
+ incy, &aa[1]);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___377.ciunit = *nout;
+ s_wsfe(&io___377);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L160;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplo == *(unsigned char *
+ )uplos;
+ isame[1] = ns == n;
+ isame[2] = als.r == alpha.r && als.i == alpha.i;
+ isame[3] = lce_(&xs[1], &xx[1], &lx);
+ isame[4] = incxs == incx;
+ isame[5] = lce_(&ys[1], &yy[1], &ly);
+ isame[6] = incys == incy;
+ if (null) {
+ isame[7] = lce_(&as[1], &aa[1], &laa);
+ } else {
+ isame[7] = lceres_(sname + 1, uplo, &n, &n, &as[1]
+ , &aa[1], &lda, (ftnlen)2, (ftnlen)1);
+ }
+ if (! packed) {
+ isame[8] = ldas == lda;
+ }
+
+/* If data was incorrectly changed, report and return. */
+
+ same = TRUE_;
+ i__5 = nargs;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___380.ciunit = *nout;
+ s_wsfe(&io___380);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L160;
+ }
+
+ if (! null) {
+
+/* Check the result column by column. */
+
+ if (incx > 0) {
+ i__5 = n;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__ + z_dim1;
+ i__7 = i__;
+ z__[i__6].r = x[i__7].r, z__[i__6].i = x[
+ i__7].i;
+/* L50: */
+ }
+ } else {
+ i__5 = n;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__ + z_dim1;
+ i__7 = n - i__ + 1;
+ z__[i__6].r = x[i__7].r, z__[i__6].i = x[
+ i__7].i;
+/* L60: */
+ }
+ }
+ if (incy > 0) {
+ i__5 = n;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__ + (z_dim1 << 1);
+ i__7 = i__;
+ z__[i__6].r = y[i__7].r, z__[i__6].i = y[
+ i__7].i;
+/* L70: */
+ }
+ } else {
+ i__5 = n;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__ + (z_dim1 << 1);
+ i__7 = n - i__ + 1;
+ z__[i__6].r = y[i__7].r, z__[i__6].i = y[
+ i__7].i;
+/* L80: */
+ }
+ }
+ ja = 1;
+ i__5 = n;
+ for (j = 1; j <= i__5; ++j) {
+ r_cnjg(&q__2, &z__[j + (z_dim1 << 1)]);
+ q__1.r = alpha.r * q__2.r - alpha.i * q__2.i,
+ q__1.i = alpha.r * q__2.i + alpha.i *
+ q__2.r;
+ w[0].r = q__1.r, w[0].i = q__1.i;
+ r_cnjg(&q__2, &alpha);
+ r_cnjg(&q__3, &z__[j + z_dim1]);
+ q__1.r = q__2.r * q__3.r - q__2.i * q__3.i,
+ q__1.i = q__2.r * q__3.i + q__2.i *
+ q__3.r;
+ w[1].r = q__1.r, w[1].i = q__1.i;
+ if (upper) {
+ jj = 1;
+ lj = j;
+ } else {
+ jj = j;
+ lj = n - j + 1;
+ }
+ cmvch_("N", &lj, &c__2, &c_b2, &z__[jj +
+ z_dim1], nmax, w, &c__1, &c_b2, &a[jj
+ + j * a_dim1], &c__1, &yt[1], &g[1], &
+ aa[ja], eps, &err, fatal, nout, &
+ c_true, (ftnlen)1);
+ if (full) {
+ if (upper) {
+ ja += lda;
+ } else {
+ ja = ja + lda + 1;
+ }
+ } else {
+ ja += lj;
+ }
+ errmax = dmax(errmax,err);
+/* If got really bad answer, report and return. */
+ if (*fatal) {
+ goto L150;
+ }
+/* L90: */
+ }
+ } else {
+/* Avoid repeating tests with N.le.0. */
+ if (n <= 0) {
+ goto L140;
+ }
+ }
+
+/* L100: */
+ }
+
+/* L110: */
+ }
+
+/* L120: */
+ }
+
+/* L130: */
+ }
+
+L140:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___387.ciunit = *nout;
+ s_wsfe(&io___387);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___388.ciunit = *nout;
+ s_wsfe(&io___388);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ goto L170;
+
+L150:
+ io___389.ciunit = *nout;
+ s_wsfe(&io___389);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L160:
+ io___390.ciunit = *nout;
+ s_wsfe(&io___390);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (full) {
+ io___391.ciunit = *nout;
+ s_wsfe(&io___391);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (packed) {
+ io___392.ciunit = *nout;
+ s_wsfe(&io___392);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L170:
+ return 0;
+
+
+/* End of CCHK6. */
+
+} /* cchk6_ */
+
+/* Subroutine */ int cchke_(integer *isnum, char *srnamt, integer *nout,
+ ftnlen srnamt_len)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE TESTS OF ERROR-E"
+ "XITS\002)";
+ static char fmt_9998[] = "(\002 ******* \002,a6,\002 FAILED THE TESTS OF"
+ " ERROR-EXITS *****\002,\002**\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ complex a[1] /* was [1][1] */, x[1], y[1], beta;
+ extern /* Subroutine */ int cher_(char *, integer *, real *, complex *,
+ integer *, complex *, integer *), chpr_(char *, integer *,
+ real *, complex *, integer *, complex *), cher2_(char *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, integer *), chpr2_(char *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *),
+ cgerc_(integer *, integer *, complex *, complex *, integer *,
+ complex *, integer *, complex *, integer *);
+ complex alpha;
+ extern /* Subroutine */ int cgbmv_(char *, integer *, integer *, integer *
+, integer *, complex *, complex *, integer *, complex *, integer *
+, complex *, complex *, integer *), chbmv_(char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *, complex *, complex *, integer *), cgemv_(char *
+, integer *, integer *, complex *, complex *, integer *, complex *
+, integer *, complex *, complex *, integer *), chemv_(
+ char *, integer *, complex *, complex *, integer *, complex *,
+ integer *, complex *, complex *, integer *), cgeru_(
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *, complex *, integer *), ctbmv_(char *, char *, char *,
+ integer *, integer *, complex *, integer *, complex *, integer *), chpmv_(char *, integer *, complex *,
+ complex *, complex *, integer *, complex *, complex *, integer *), ctbsv_(char *, char *, char *, integer *, integer *,
+ complex *, integer *, complex *, integer *), ctpmv_(char *, char *, char *, integer *, complex *,
+ complex *, integer *), ctrmv_(char *,
+ char *, char *, integer *, complex *, integer *, complex *,
+ integer *), ctpsv_(char *, char *, char *,
+ integer *, complex *, complex *, integer *), ctrsv_(char *, char *, char *, integer *, complex *,
+ integer *, complex *, integer *);
+ real ralpha;
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *);
+
+ /* Fortran I/O blocks */
+ static cilist io___399 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___400 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* Tests the error exits from the Level 2 Blas. */
+/* Requires a special version of the error-handling routine XERBLA. */
+/* ALPHA, RALPHA, BETA, A, X and Y should not need to be defined. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Subroutines .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+/* OK is set to .FALSE. by the special version of XERBLA or by CHKXER */
+/* if anything is wrong. */
+ infoc_1.ok = TRUE_;
+/* LERR is set to .TRUE. by the special version of XERBLA each time */
+/* it is called, and is then tested and re-set by CHKXER. */
+ infoc_1.lerr = FALSE_;
+ switch (*isnum) {
+ case 1: goto L10;
+ case 2: goto L20;
+ case 3: goto L30;
+ case 4: goto L40;
+ case 5: goto L50;
+ case 6: goto L60;
+ case 7: goto L70;
+ case 8: goto L80;
+ case 9: goto L90;
+ case 10: goto L100;
+ case 11: goto L110;
+ case 12: goto L120;
+ case 13: goto L130;
+ case 14: goto L140;
+ case 15: goto L150;
+ case 16: goto L160;
+ case 17: goto L170;
+ }
+L10:
+ infoc_1.infot = 1;
+ cgemv_("/", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ cgemv_("N", &c_n1, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ cgemv_("N", &c__0, &c_n1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ cgemv_("N", &c__2, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ cgemv_("N", &c__0, &c__0, &alpha, a, &c__1, x, &c__0, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ cgemv_("N", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L20:
+ infoc_1.infot = 1;
+ cgbmv_("/", &c__0, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ cgbmv_("N", &c_n1, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ cgbmv_("N", &c__0, &c_n1, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ cgbmv_("N", &c__0, &c__0, &c_n1, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ cgbmv_("N", &c__2, &c__0, &c__0, &c_n1, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ cgbmv_("N", &c__0, &c__0, &c__1, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ cgbmv_("N", &c__0, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__0, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ cgbmv_("N", &c__0, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L30:
+ infoc_1.infot = 1;
+ chemv_("/", &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ chemv_("U", &c_n1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ chemv_("U", &c__2, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ chemv_("U", &c__0, &alpha, a, &c__1, x, &c__0, &beta, y, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ chemv_("U", &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__0)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L40:
+ infoc_1.infot = 1;
+ chbmv_("/", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ chbmv_("U", &c_n1, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ chbmv_("U", &c__0, &c_n1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ chbmv_("U", &c__0, &c__1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ chbmv_("U", &c__0, &c__0, &alpha, a, &c__1, x, &c__0, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ chbmv_("U", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L50:
+ infoc_1.infot = 1;
+ chpmv_("/", &c__0, &alpha, a, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ chpmv_("U", &c_n1, &alpha, a, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ chpmv_("U", &c__0, &alpha, a, x, &c__0, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ chpmv_("U", &c__0, &alpha, a, x, &c__1, &beta, y, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L60:
+ infoc_1.infot = 1;
+ ctrmv_("/", "N", "N", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ ctrmv_("U", "/", "N", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ctrmv_("U", "N", "/", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ctrmv_("U", "N", "N", &c_n1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrmv_("U", "N", "N", &c__2, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ ctrmv_("U", "N", "N", &c__0, a, &c__1, x, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L70:
+ infoc_1.infot = 1;
+ ctbmv_("/", "N", "N", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ ctbmv_("U", "/", "N", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ctbmv_("U", "N", "/", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ctbmv_("U", "N", "N", &c_n1, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctbmv_("U", "N", "N", &c__0, &c_n1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ ctbmv_("U", "N", "N", &c__0, &c__1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctbmv_("U", "N", "N", &c__0, &c__0, a, &c__1, x, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L80:
+ infoc_1.infot = 1;
+ ctpmv_("/", "N", "N", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ ctpmv_("U", "/", "N", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ctpmv_("U", "N", "/", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ctpmv_("U", "N", "N", &c_n1, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ ctpmv_("U", "N", "N", &c__0, a, x, &c__0)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L90:
+ infoc_1.infot = 1;
+ ctrsv_("/", "N", "N", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ ctrsv_("U", "/", "N", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ctrsv_("U", "N", "/", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ctrsv_("U", "N", "N", &c_n1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrsv_("U", "N", "N", &c__2, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ ctrsv_("U", "N", "N", &c__0, a, &c__1, x, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L100:
+ infoc_1.infot = 1;
+ ctbsv_("/", "N", "N", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ ctbsv_("U", "/", "N", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ctbsv_("U", "N", "/", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ctbsv_("U", "N", "N", &c_n1, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctbsv_("U", "N", "N", &c__0, &c_n1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ ctbsv_("U", "N", "N", &c__0, &c__1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctbsv_("U", "N", "N", &c__0, &c__0, a, &c__1, x, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L110:
+ infoc_1.infot = 1;
+ ctpsv_("/", "N", "N", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ ctpsv_("U", "/", "N", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ctpsv_("U", "N", "/", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ctpsv_("U", "N", "N", &c_n1, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ ctpsv_("U", "N", "N", &c__0, a, x, &c__0)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L120:
+ infoc_1.infot = 1;
+ cgerc_(&c_n1, &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ cgerc_(&c__0, &c_n1, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ cgerc_(&c__0, &c__0, &alpha, x, &c__0, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ cgerc_(&c__0, &c__0, &alpha, x, &c__1, y, &c__0, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ cgerc_(&c__2, &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L130:
+ infoc_1.infot = 1;
+ cgeru_(&c_n1, &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ cgeru_(&c__0, &c_n1, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ cgeru_(&c__0, &c__0, &alpha, x, &c__0, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ cgeru_(&c__0, &c__0, &alpha, x, &c__1, y, &c__0, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ cgeru_(&c__2, &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L140:
+ infoc_1.infot = 1;
+ cher_("/", &c__0, &ralpha, x, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ cher_("U", &c_n1, &ralpha, x, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ cher_("U", &c__0, &ralpha, x, &c__0, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ cher_("U", &c__2, &ralpha, x, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L150:
+ infoc_1.infot = 1;
+ chpr_("/", &c__0, &ralpha, x, &c__1, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ chpr_("U", &c_n1, &ralpha, x, &c__1, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ chpr_("U", &c__0, &ralpha, x, &c__0, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L160:
+ infoc_1.infot = 1;
+ cher2_("/", &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ cher2_("U", &c_n1, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ cher2_("U", &c__0, &alpha, x, &c__0, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ cher2_("U", &c__0, &alpha, x, &c__1, y, &c__0, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ cher2_("U", &c__2, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L170:
+ infoc_1.infot = 1;
+ chpr2_("/", &c__0, &alpha, x, &c__1, y, &c__1, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ chpr2_("U", &c_n1, &alpha, x, &c__1, y, &c__1, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ chpr2_("U", &c__0, &alpha, x, &c__0, y, &c__1, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ chpr2_("U", &c__0, &alpha, x, &c__1, y, &c__0, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+
+L180:
+ if (infoc_1.ok) {
+ io___399.ciunit = *nout;
+ s_wsfe(&io___399);
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ } else {
+ io___400.ciunit = *nout;
+ s_wsfe(&io___400);
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ }
+ return 0;
+
+
+/* End of CCHKE. */
+
+} /* cchke_ */
+
+/* Subroutine */ int cmake_(char *type__, char *uplo, char *diag, integer *m,
+ integer *n, complex *a, integer *nmax, complex *aa, integer *lda,
+ integer *kl, integer *ku, logical *reset, complex *transl, ftnlen
+ type_len, ftnlen uplo_len, ftnlen diag_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ real r__1;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+ integer s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer i__, j, i1, i2, i3, jj, kk;
+ logical gen, tri, sym;
+ extern /* Complex */ VOID cbeg_(complex *, logical *);
+ integer ibeg, iend, ioff;
+ logical unit, lower, upper;
+
+
+/* Generates values for an M by N matrix A within the bandwidth */
+/* defined by KL and KU. */
+/* Stores the values in the array AA in the data structure required */
+/* by the routine, with unwanted elements set to rogue value. */
+
+/* TYPE is 'GE', 'GB', 'HE', 'HB', 'HP', 'TR', 'TB' OR 'TP'. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. External Functions .. */
+/* .. Intrinsic Functions .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --aa;
+
+ /* Function Body */
+ gen = *(unsigned char *)type__ == 'G';
+ sym = *(unsigned char *)type__ == 'H';
+ tri = *(unsigned char *)type__ == 'T';
+ upper = (sym || tri) && *(unsigned char *)uplo == 'U';
+ lower = (sym || tri) && *(unsigned char *)uplo == 'L';
+ unit = tri && *(unsigned char *)diag == 'U';
+
+/* Generate data in array A. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (gen || upper && i__ <= j || lower && i__ >= j) {
+ if (i__ <= j && j - i__ <= *ku || i__ >= j && i__ - j <= *kl)
+ {
+ i__3 = i__ + j * a_dim1;
+ cbeg_(&q__2, reset);
+ q__1.r = q__2.r + transl->r, q__1.i = q__2.i + transl->i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ } else {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ }
+ if (i__ != j) {
+ if (sym) {
+ i__3 = j + i__ * a_dim1;
+ r_cnjg(&q__1, &a[i__ + j * a_dim1]);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ } else if (tri) {
+ i__3 = j + i__ * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ }
+ }
+ }
+/* L10: */
+ }
+ if (sym) {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ r__1 = a[i__3].r;
+ q__1.r = r__1, q__1.i = 0.f;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ }
+ if (tri) {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ q__1.r = a[i__3].r + 1.f, q__1.i = a[i__3].i + 0.f;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ }
+ if (unit) {
+ i__2 = j + j * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+ }
+/* L20: */
+ }
+
+/* Store elements in array AS in data structure required by routine. */
+
+ if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ i__4 = i__ + j * a_dim1;
+ aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
+/* L30: */
+ }
+ i__2 = *lda;
+ for (i__ = *m + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ aa[i__3].r = -1e10f, aa[i__3].i = 1e10f;
+/* L40: */
+ }
+/* L50: */
+ }
+ } else if (s_cmp(type__, "GB", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *ku + 1 - j;
+ for (i1 = 1; i1 <= i__2; ++i1) {
+ i__3 = i1 + (j - 1) * *lda;
+ aa[i__3].r = -1e10f, aa[i__3].i = 1e10f;
+/* L60: */
+ }
+/* Computing MIN */
+ i__3 = *kl + *ku + 1, i__4 = *ku + 1 + *m - j;
+ i__2 = min(i__3,i__4);
+ for (i2 = i1; i2 <= i__2; ++i2) {
+ i__3 = i2 + (j - 1) * *lda;
+ i__4 = i2 + j - *ku - 1 + j * a_dim1;
+ aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
+/* L70: */
+ }
+ i__2 = *lda;
+ for (i3 = i2; i3 <= i__2; ++i3) {
+ i__3 = i3 + (j - 1) * *lda;
+ aa[i__3].r = -1e10f, aa[i__3].i = 1e10f;
+/* L80: */
+ }
+/* L90: */
+ }
+ } else if (s_cmp(type__, "HE", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
+ "TR", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ ibeg = 1;
+ if (unit) {
+ iend = j - 1;
+ } else {
+ iend = j;
+ }
+ } else {
+ if (unit) {
+ ibeg = j + 1;
+ } else {
+ ibeg = j;
+ }
+ iend = *n;
+ }
+ i__2 = ibeg - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ aa[i__3].r = -1e10f, aa[i__3].i = 1e10f;
+/* L100: */
+ }
+ i__2 = iend;
+ for (i__ = ibeg; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ i__4 = i__ + j * a_dim1;
+ aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
+/* L110: */
+ }
+ i__2 = *lda;
+ for (i__ = iend + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ aa[i__3].r = -1e10f, aa[i__3].i = 1e10f;
+/* L120: */
+ }
+ if (sym) {
+ jj = j + (j - 1) * *lda;
+ i__2 = jj;
+ i__3 = jj;
+ r__1 = aa[i__3].r;
+ q__1.r = r__1, q__1.i = -1e10f;
+ aa[i__2].r = q__1.r, aa[i__2].i = q__1.i;
+ }
+/* L130: */
+ }
+ } else if (s_cmp(type__, "HB", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
+ "TB", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ kk = *kl + 1;
+/* Computing MAX */
+ i__2 = 1, i__3 = *kl + 2 - j;
+ ibeg = max(i__2,i__3);
+ if (unit) {
+ iend = *kl;
+ } else {
+ iend = *kl + 1;
+ }
+ } else {
+ kk = 1;
+ if (unit) {
+ ibeg = 2;
+ } else {
+ ibeg = 1;
+ }
+/* Computing MIN */
+ i__2 = *kl + 1, i__3 = *m + 1 - j;
+ iend = min(i__2,i__3);
+ }
+ i__2 = ibeg - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ aa[i__3].r = -1e10f, aa[i__3].i = 1e10f;
+/* L140: */
+ }
+ i__2 = iend;
+ for (i__ = ibeg; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ i__4 = i__ + j - kk + j * a_dim1;
+ aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
+/* L150: */
+ }
+ i__2 = *lda;
+ for (i__ = iend + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ aa[i__3].r = -1e10f, aa[i__3].i = 1e10f;
+/* L160: */
+ }
+ if (sym) {
+ jj = kk + (j - 1) * *lda;
+ i__2 = jj;
+ i__3 = jj;
+ r__1 = aa[i__3].r;
+ q__1.r = r__1, q__1.i = -1e10f;
+ aa[i__2].r = q__1.r, aa[i__2].i = q__1.i;
+ }
+/* L170: */
+ }
+ } else if (s_cmp(type__, "HP", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
+ "TP", (ftnlen)2, (ftnlen)2) == 0) {
+ ioff = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ ibeg = 1;
+ iend = j;
+ } else {
+ ibeg = j;
+ iend = *n;
+ }
+ i__2 = iend;
+ for (i__ = ibeg; i__ <= i__2; ++i__) {
+ ++ioff;
+ i__3 = ioff;
+ i__4 = i__ + j * a_dim1;
+ aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
+ if (i__ == j) {
+ if (unit) {
+ i__3 = ioff;
+ aa[i__3].r = -1e10f, aa[i__3].i = 1e10f;
+ }
+ if (sym) {
+ i__3 = ioff;
+ i__4 = ioff;
+ r__1 = aa[i__4].r;
+ q__1.r = r__1, q__1.i = -1e10f;
+ aa[i__3].r = q__1.r, aa[i__3].i = q__1.i;
+ }
+ }
+/* L180: */
+ }
+/* L190: */
+ }
+ }
+ return 0;
+
+/* End of CMAKE. */
+
+} /* cmake_ */
+
+/* Subroutine */ int cmvch_(char *trans, integer *m, integer *n, complex *
+ alpha, complex *a, integer *nmax, complex *x, integer *incx, complex *
+ beta, complex *y, integer *incy, complex *yt, real *g, complex *yy,
+ real *eps, real *err, logical *fatal, integer *nout, logical *mv,
+ ftnlen trans_len)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
+ " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 "
+ " EXPECTED RE\002,\002SULT COMPUTED R"
+ "ESULT\002)";
+ static char fmt_9998[] = "(1x,i7,2(\002 (\002,g15.6,\002,\002,g15.6,"
+ "\002)\002))";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1, r__2, r__3, r__4, r__5, r__6;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void r_cnjg(complex *, complex *);
+ double c_abs(complex *), sqrt(doublereal);
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, ml, nl, iy, jx, kx, ky;
+ real erri;
+ logical tran, ctran;
+ integer incxl, incyl;
+
+ /* Fortran I/O blocks */
+ static cilist io___430 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___431 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___432 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* Checks the results of the computational tests. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Intrinsic Functions .. */
+/* .. Statement Functions .. */
+/* .. Statement Function definitions .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+ --yt;
+ --g;
+ --yy;
+
+ /* Function Body */
+ tran = *(unsigned char *)trans == 'T';
+ ctran = *(unsigned char *)trans == 'C';
+ if (tran || ctran) {
+ ml = *n;
+ nl = *m;
+ } else {
+ ml = *m;
+ nl = *n;
+ }
+ if (*incx < 0) {
+ kx = nl;
+ incxl = -1;
+ } else {
+ kx = 1;
+ incxl = 1;
+ }
+ if (*incy < 0) {
+ ky = ml;
+ incyl = -1;
+ } else {
+ ky = 1;
+ incyl = 1;
+ }
+
+/* Compute expected result in YT using data in A, X and Y. */
+/* Compute gauges in G. */
+
+ iy = ky;
+ i__1 = ml;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ yt[i__2].r = 0.f, yt[i__2].i = 0.f;
+ g[iy] = 0.f;
+ jx = kx;
+ if (tran) {
+ i__2 = nl;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = iy;
+ i__4 = iy;
+ i__5 = j + i__ * a_dim1;
+ i__6 = jx;
+ q__2.r = a[i__5].r * x[i__6].r - a[i__5].i * x[i__6].i,
+ q__2.i = a[i__5].r * x[i__6].i + a[i__5].i * x[i__6]
+ .r;
+ q__1.r = yt[i__4].r + q__2.r, q__1.i = yt[i__4].i + q__2.i;
+ yt[i__3].r = q__1.r, yt[i__3].i = q__1.i;
+ i__3 = j + i__ * a_dim1;
+ i__4 = jx;
+ g[iy] += ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ j + i__ * a_dim1]), dabs(r__2))) * ((r__3 = x[i__4].r,
+ dabs(r__3)) + (r__4 = r_imag(&x[jx]), dabs(r__4)));
+ jx += incxl;
+/* L10: */
+ }
+ } else if (ctran) {
+ i__2 = nl;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = iy;
+ i__4 = iy;
+ r_cnjg(&q__3, &a[j + i__ * a_dim1]);
+ i__5 = jx;
+ q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i, q__2.i =
+ q__3.r * x[i__5].i + q__3.i * x[i__5].r;
+ q__1.r = yt[i__4].r + q__2.r, q__1.i = yt[i__4].i + q__2.i;
+ yt[i__3].r = q__1.r, yt[i__3].i = q__1.i;
+ i__3 = j + i__ * a_dim1;
+ i__4 = jx;
+ g[iy] += ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ j + i__ * a_dim1]), dabs(r__2))) * ((r__3 = x[i__4].r,
+ dabs(r__3)) + (r__4 = r_imag(&x[jx]), dabs(r__4)));
+ jx += incxl;
+/* L20: */
+ }
+ } else {
+ i__2 = nl;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = iy;
+ i__4 = iy;
+ i__5 = i__ + j * a_dim1;
+ i__6 = jx;
+ q__2.r = a[i__5].r * x[i__6].r - a[i__5].i * x[i__6].i,
+ q__2.i = a[i__5].r * x[i__6].i + a[i__5].i * x[i__6]
+ .r;
+ q__1.r = yt[i__4].r + q__2.r, q__1.i = yt[i__4].i + q__2.i;
+ yt[i__3].r = q__1.r, yt[i__3].i = q__1.i;
+ i__3 = i__ + j * a_dim1;
+ i__4 = jx;
+ g[iy] += ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ i__ + j * a_dim1]), dabs(r__2))) * ((r__3 = x[i__4].r,
+ dabs(r__3)) + (r__4 = r_imag(&x[jx]), dabs(r__4)));
+ jx += incxl;
+/* L30: */
+ }
+ }
+ i__2 = iy;
+ i__3 = iy;
+ q__2.r = alpha->r * yt[i__3].r - alpha->i * yt[i__3].i, q__2.i =
+ alpha->r * yt[i__3].i + alpha->i * yt[i__3].r;
+ i__4 = iy;
+ q__3.r = beta->r * y[i__4].r - beta->i * y[i__4].i, q__3.i = beta->r *
+ y[i__4].i + beta->i * y[i__4].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ yt[i__2].r = q__1.r, yt[i__2].i = q__1.i;
+ i__2 = iy;
+ g[iy] = ((r__1 = alpha->r, dabs(r__1)) + (r__2 = r_imag(alpha), dabs(
+ r__2))) * g[iy] + ((r__3 = beta->r, dabs(r__3)) + (r__4 =
+ r_imag(beta), dabs(r__4))) * ((r__5 = y[i__2].r, dabs(r__5))
+ + (r__6 = r_imag(&y[iy]), dabs(r__6)));
+ iy += incyl;
+/* L40: */
+ }
+
+/* Compute the error ratio for this result. */
+
+ *err = 0.f;
+ i__1 = ml;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = (i__ - 1) * abs(*incy) + 1;
+ q__1.r = yt[i__2].r - yy[i__3].r, q__1.i = yt[i__2].i - yy[i__3].i;
+ erri = c_abs(&q__1) / *eps;
+ if (g[i__] != 0.f) {
+ erri /= g[i__];
+ }
+ *err = dmax(*err,erri);
+ if (*err * sqrt(*eps) >= 1.f) {
+ goto L60;
+ }
+/* L50: */
+ }
+/* If the loop completes, all results are at least half accurate. */
+ goto L80;
+
+/* Report fatal error. */
+
+L60:
+ *fatal = TRUE_;
+ io___430.ciunit = *nout;
+ s_wsfe(&io___430);
+ e_wsfe();
+ i__1 = ml;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*mv) {
+ io___431.ciunit = *nout;
+ s_wsfe(&io___431);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&yt[i__], (ftnlen)sizeof(real));
+ do_fio(&c__2, (char *)&yy[(i__ - 1) * abs(*incy) + 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___432.ciunit = *nout;
+ s_wsfe(&io___432);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&yy[(i__ - 1) * abs(*incy) + 1], (ftnlen)
+ sizeof(real));
+ do_fio(&c__2, (char *)&yt[i__], (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+/* L70: */
+ }
+
+L80:
+ return 0;
+
+
+/* End of CMVCH. */
+
+} /* cmvch_ */
+
+logical lce_(complex *ri, complex *rj, integer *lr)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ logical ret_val;
+
+ /* Local variables */
+ integer i__;
+
+
+/* Tests if two arrays are identical. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ --rj;
+ --ri;
+
+ /* Function Body */
+ i__1 = *lr;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ if (ri[i__2].r != rj[i__3].r || ri[i__2].i != rj[i__3].i) {
+ goto L20;
+ }
+/* L10: */
+ }
+ ret_val = TRUE_;
+ goto L30;
+L20:
+ ret_val = FALSE_;
+L30:
+ return ret_val;
+
+/* End of LCE. */
+
+} /* lce_ */
+
+logical lceres_(char *type__, char *uplo, integer *m, integer *n, complex *aa,
+ complex *as, integer *lda, ftnlen type_len, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2, i__3, i__4;
+ logical ret_val;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer i__, j, ibeg, iend;
+ logical upper;
+
+
+/* Tests if selected elements in two arrays are equal. */
+
+/* TYPE is 'GE', 'HE' or 'HP'. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ as_dim1 = *lda;
+ as_offset = 1 + as_dim1;
+ as -= as_offset;
+ aa_dim1 = *lda;
+ aa_offset = 1 + aa_dim1;
+ aa -= aa_offset;
+
+ /* Function Body */
+ upper = *(unsigned char *)uplo == 'U';
+ if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *lda;
+ for (i__ = *m + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * aa_dim1;
+ i__4 = i__ + j * as_dim1;
+ if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) {
+ goto L70;
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (s_cmp(type__, "HE", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ ibeg = 1;
+ iend = j;
+ } else {
+ ibeg = j;
+ iend = *n;
+ }
+ i__2 = ibeg - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * aa_dim1;
+ i__4 = i__ + j * as_dim1;
+ if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) {
+ goto L70;
+ }
+/* L30: */
+ }
+ i__2 = *lda;
+ for (i__ = iend + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * aa_dim1;
+ i__4 = i__ + j * as_dim1;
+ if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) {
+ goto L70;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+/* L60: */
+ ret_val = TRUE_;
+ goto L80;
+L70:
+ ret_val = FALSE_;
+L80:
+ return ret_val;
+
+/* End of LCERES. */
+
+} /* lceres_ */
+
+/* Complex */ VOID cbeg_(complex * ret_val, logical *reset)
+{
+ /* System generated locals */
+ real r__1, r__2;
+ complex q__1;
+
+ /* Local variables */
+ static integer i__, j, ic, mi, mj;
+
+
+/* Generates complex numbers as pairs of random numbers uniformly */
+/* distributed between -0.5 and 0.5. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Local Scalars .. */
+/* .. Save statement .. */
+/* .. Intrinsic Functions .. */
+/* .. Executable Statements .. */
+ if (*reset) {
+/* Initialize local variables. */
+ mi = 891;
+ mj = 457;
+ i__ = 7;
+ j = 7;
+ ic = 0;
+ *reset = FALSE_;
+ }
+
+/* The sequence of values of I or J is bounded between 1 and 999. */
+/* If initial I or J = 1,2,3,6,7 or 9, the period will be 50. */
+/* If initial I or J = 4 or 8, the period will be 25. */
+/* If initial I or J = 5, the period will be 10. */
+/* IC is used to break up the period by skipping 1 value of I or J */
+/* in 6. */
+
+ ++ic;
+L10:
+ i__ *= mi;
+ j *= mj;
+ i__ -= i__ / 1000 * 1000;
+ j -= j / 1000 * 1000;
+ if (ic >= 5) {
+ ic = 0;
+ goto L10;
+ }
+ r__1 = (i__ - 500) / 1001.f;
+ r__2 = (j - 500) / 1001.f;
+ q__1.r = r__1, q__1.i = r__2;
+ ret_val->r = q__1.r, ret_val->i = q__1.i;
+ return ;
+
+/* End of CBEG. */
+
+} /* cbeg_ */
+
+doublereal sdiff_(real *x, real *y)
+{
+ /* System generated locals */
+ real ret_val;
+
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+
+/* .. Scalar Arguments .. */
+/* .. Executable Statements .. */
+ ret_val = *x - *y;
+ return ret_val;
+
+/* End of SDIFF. */
+
+} /* sdiff_ */
+
+/* Subroutine */ int chkxer_(char *srnamt, integer *infot, integer *nout,
+ logical *lerr, logical *ok)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ***** ILLEGAL VALUE OF PARAMETER NUMBER"
+ " \002,i2,\002 NOT D\002,\002ETECTED BY \002,a6,\002 *****\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___444 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* Tests whether XERBLA has detected an error when it should. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Executable Statements .. */
+ if (! (*lerr)) {
+ io___444.ciunit = *nout;
+ s_wsfe(&io___444);
+ do_fio(&c__1, (char *)&(*infot), (ftnlen)sizeof(integer));
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ *ok = FALSE_;
+ }
+ *lerr = FALSE_;
+ return 0;
+
+
+/* End of CHKXER. */
+
+} /* chkxer_ */
+
+/* Subroutine */ int xerbla_(char *srname, integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* XERBLA WAS CALLED WITH INFO ="
+ " \002,i6,\002 INSTEAD\002,\002 OF \002,i2,\002 *******\002)";
+ static char fmt_9997[] = "(\002 ******* XERBLA WAS CALLED WITH INFO ="
+ " \002,i6,\002 *******\002)";
+ static char fmt_9998[] = "(\002 ******* XERBLA WAS CALLED WITH SRNAME ="
+ " \002,a6,\002 INSTE\002,\002AD OF \002,a6,\002 *******\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Fortran I/O blocks */
+ static cilist io___445 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___446 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___447 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* This is a special version of XERBLA to be used only as part of */
+/* the test program for testing error exits from the Level 2 BLAS */
+/* routines. */
+
+/* XERBLA is an error handler for the Level 2 BLAS routines. */
+
+/* It is called by the Level 2 BLAS routines if an input parameter is */
+/* invalid. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+ infoc_2.lerr = TRUE_;
+ if (*info != infoc_2.infot) {
+ if (infoc_2.infot != 0) {
+ io___445.ciunit = infoc_2.nout;
+ s_wsfe(&io___445);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&infoc_2.infot, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___446.ciunit = infoc_2.nout;
+ s_wsfe(&io___446);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ infoc_2.ok = FALSE_;
+ }
+ if (s_cmp(srname, srnamc_1.srnamt, (ftnlen)6, (ftnlen)6) != 0) {
+ io___447.ciunit = infoc_2.nout;
+ s_wsfe(&io___447);
+ do_fio(&c__1, srname, (ftnlen)6);
+ do_fio(&c__1, srnamc_1.srnamt, (ftnlen)6);
+ e_wsfe();
+ infoc_2.ok = FALSE_;
+ }
+ return 0;
+
+
+/* End of XERBLA */
+
+} /* xerbla_ */
+
+/* Main program alias */ int cblat2_ () { MAIN__ (); return 0; }
diff --git a/BLAS/TESTING/cblat3.c b/BLAS/TESTING/cblat3.c
new file mode 100644
index 0000000..0e6804e
--- /dev/null
+++ b/BLAS/TESTING/cblat3.c
@@ -0,0 +1,5425 @@
+/* cblat3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+union {
+ struct {
+ integer infot, noutc;
+ logical ok, lerr;
+ } _1;
+ struct {
+ integer infot, nout;
+ logical ok, lerr;
+ } _2;
+} infoc_;
+
+#define infoc_1 (infoc_._1)
+#define infoc_2 (infoc_._2)
+
+struct {
+ char srnamt[6];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__9 = 9;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__8 = 8;
+static integer c__4 = 4;
+static integer c__65 = 65;
+static integer c__7 = 7;
+static integer c__6 = 6;
+static integer c__2 = 2;
+static real c_b87 = 1.f;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Initialized data */
+
+ static char snames[6*9] = "CGEMM " "CHEMM " "CSYMM " "CTRMM " "CTRSM "
+ "CHERK " "CSYRK " "CHER2K" "CSYR2K";
+
+ /* Format strings */
+ static char fmt_9997[] = "(\002 NUMBER OF VALUES OF \002,a,\002 IS LESS "
+ "THAN 1 OR GREATER \002,\002THAN \002,i2)";
+ static char fmt_9996[] = "(\002 VALUE OF N IS LESS THAN 0 OR GREATER THA"
+ "N \002,i2)";
+ static char fmt_9995[] = "(\002 TESTS OF THE COMPLEX LEVEL 3 BL"
+ "AS\002,//\002 THE F\002,\002OLLOWING PARAMETER VALUES WILL BE US"
+ "ED:\002)";
+ static char fmt_9994[] = "(\002 FOR N \002,9i6)";
+ static char fmt_9993[] = "(\002 FOR ALPHA \002,7(\002(\002,f4"
+ ".1,\002,\002,f4.1,\002) \002,:))";
+ static char fmt_9992[] = "(\002 FOR BETA \002,7(\002(\002,f4"
+ ".1,\002,\002,f4.1,\002) \002,:))";
+ static char fmt_9984[] = "(\002 ERROR-EXITS WILL NOT BE TESTED\002)";
+ static char fmt_9999[] = "(\002 ROUTINES PASS COMPUTATIONAL TESTS IF TES"
+ "T RATIO IS LES\002,\002S THAN\002,f8.2)";
+ static char fmt_9988[] = "(a6,l2)";
+ static char fmt_9990[] = "(\002 SUBPROGRAM NAME \002,a6,\002 NOT RECOGNI"
+ "ZED\002,/\002 ******* T\002,\002ESTS ABANDONED *******\002)";
+ static char fmt_9998[] = "(\002 RELATIVE MACHINE PRECISION IS TAKEN TO"
+ " BE\002,1p,e9.1)";
+ static char fmt_9989[] = "(\002 ERROR IN CMMCH - IN-LINE DOT PRODUCTS A"
+ "RE BEING EVALU\002,\002ATED WRONGLY.\002,/\002 CMMCH WAS CALLED "
+ "WITH TRANSA = \002,a1,\002 AND TRANSB = \002,a1,/\002 AND RETURN"
+ "ED SAME = \002,l1,\002 AND \002,\002ERR = \002,f12.3,\002.\002,"
+ "/\002 THIS MAY BE DUE TO FAULTS IN THE \002,\002ARITHMETIC OR TH"
+ "E COMPILER.\002,/\002 ******* TESTS ABANDONED \002,\002******"
+ "*\002)";
+ static char fmt_9987[] = "(1x,a6,\002 WAS NOT TESTED\002)";
+ static char fmt_9986[] = "(/\002 END OF TESTS\002)";
+ static char fmt_9985[] = "(/\002 ******* FATAL ERROR - TESTS ABANDONED *"
+ "******\002)";
+ static char fmt_9991[] = "(\002 AMEND DATA FILE OR INCREASE ARRAY SIZES "
+ "IN PROGRAM\002,/\002 ******* TESTS ABANDONED *******\002)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ real r__1;
+ olist o__1;
+ cllist cl__1;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void), f_open(olist *), s_wsfe(cilist *), do_fio(integer *,
+ char *, ftnlen), e_wsfe(void), s_wsle(cilist *), e_wsle(void),
+ s_rsfe(cilist *), e_rsfe(void), s_cmp(char *, char *, ftnlen,
+ ftnlen);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+ integer f_clos(cllist *);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ complex c__[4225] /* was [65][65] */;
+ real g[65];
+ integer i__, j, n;
+ complex w[130], aa[4225], ab[8450] /* was [65][130] */, bb[4225], cc[
+ 4225], as[4225], bs[4225], cs[4225], ct[65], alf[7];
+ extern logical lce_(complex *, complex *, integer *);
+ complex bet[7];
+ real eps, err;
+ integer nalf, idim[9];
+ logical same;
+ integer nbet, ntra;
+ logical rewi;
+ integer nout;
+ extern /* Subroutine */ int cchk1_(char *, real *, real *, integer *,
+ integer *, logical *, logical *, logical *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ complex *, complex *, complex *, real *, ftnlen), cchk2_(char *,
+ real *, real *, integer *, integer *, logical *, logical *,
+ logical *, integer *, integer *, integer *, complex *, integer *,
+ complex *, integer *, complex *, complex *, complex *, complex *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ real *, ftnlen), cchk3_(char *, real *, real *, integer *,
+ integer *, logical *, logical *, logical *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, complex *,
+ complex *, complex *, complex *, complex *, real *, complex *,
+ ftnlen), cchk4_(char *, real *, real *, integer *, integer *,
+ logical *, logical *, logical *, integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, complex *, complex *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ complex *, complex *, real *, ftnlen), cchk5_(char *, real *,
+ real *, integer *, integer *, logical *, logical *, logical *,
+ integer *, integer *, integer *, complex *, integer *, complex *,
+ integer *, complex *, complex *, complex *, complex *, complex *,
+ complex *, complex *, complex *, complex *, real *, complex *,
+ ftnlen), cchke_(integer *, char *, integer *, ftnlen);
+ logical fatal;
+ extern /* Subroutine */ int cmmch_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *, complex *, real *, complex *,
+ integer *, real *, real *, logical *, integer *, logical *,
+ ftnlen, ftnlen);
+ extern doublereal sdiff_(real *, real *);
+ logical trace;
+ integer nidim;
+ char snaps[32];
+ integer isnum;
+ logical ltest[9], sfatal;
+ char snamet[6], transa[1], transb[1];
+ real thresh;
+ logical ltestt, tsterr;
+ char summry[32];
+
+ /* Fortran I/O blocks */
+ static cilist io___2 = { 0, 5, 0, 0, 0 };
+ static cilist io___4 = { 0, 5, 0, 0, 0 };
+ static cilist io___6 = { 0, 5, 0, 0, 0 };
+ static cilist io___8 = { 0, 5, 0, 0, 0 };
+ static cilist io___11 = { 0, 5, 0, 0, 0 };
+ static cilist io___13 = { 0, 5, 0, 0, 0 };
+ static cilist io___15 = { 0, 5, 0, 0, 0 };
+ static cilist io___17 = { 0, 5, 0, 0, 0 };
+ static cilist io___19 = { 0, 5, 0, 0, 0 };
+ static cilist io___21 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___22 = { 0, 5, 0, 0, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___26 = { 0, 5, 0, 0, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___29 = { 0, 5, 0, 0, 0 };
+ static cilist io___31 = { 0, 5, 0, 0, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___34 = { 0, 5, 0, 0, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___40 = { 0, 0, 0, 0, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9984, 0 };
+ static cilist io___42 = { 0, 0, 0, 0, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, 0, 0 };
+ static cilist io___46 = { 0, 5, 1, fmt_9988, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___69 = { 0, 0, 0, 0, 0 };
+ static cilist io___70 = { 0, 0, 0, fmt_9987, 0 };
+ static cilist io___71 = { 0, 0, 0, 0, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9986, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9985, 0 };
+ static cilist io___80 = { 0, 0, 0, fmt_9991, 0 };
+
+
+
+/* Test program for the COMPLEX Level 3 Blas. */
+
+/* The program must be driven by a short data file. The first 14 records */
+/* of the file are read using list-directed input, the last 9 records */
+/* are read using the format ( A6, L2 ). An annotated example of a data */
+/* file can be obtained by deleting the first 3 characters from the */
+/* following 23 lines: */
+/* 'cblat3.out' NAME OF SUMMARY OUTPUT FILE */
+/* 6 UNIT NUMBER OF SUMMARY FILE */
+/* 'CBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE */
+/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */
+/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */
+/* F LOGICAL FLAG, T TO STOP ON FAILURES. */
+/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */
+/* 16.0 THRESHOLD VALUE OF TEST RATIO */
+/* 6 NUMBER OF VALUES OF N */
+/* 0 1 2 3 5 9 VALUES OF N */
+/* 3 NUMBER OF VALUES OF ALPHA */
+/* (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA */
+/* 3 NUMBER OF VALUES OF BETA */
+/* (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA */
+/* CGEMM T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CHEMM T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CSYMM T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CTRMM T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CTRSM T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CHERK T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CSYRK T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CHER2K T PUT F FOR NO TEST. SAME COLUMNS. */
+/* CSYR2K T PUT F FOR NO TEST. SAME COLUMNS. */
+
+/* See: */
+
+/* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. */
+/* A Set of Level 3 Basic Linear Algebra Subprograms. */
+
+/* Technical Memorandum No.88 (Revision 1), Mathematics and */
+/* Computer Science Division, Argonne National Laboratory, 9700 */
+/* South Cass Avenue, Argonne, Illinois 60439, US. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers */
+/* can be run multiple times without deleting generated */
+/* output files (susan) */
+
+/* .. Parameters .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+
+/* Read name and unit number for summary output file and open file. */
+
+ s_rsle(&io___2);
+ do_lio(&c__9, &c__1, summry, (ftnlen)32);
+ e_rsle();
+ s_rsle(&io___4);
+ do_lio(&c__3, &c__1, (char *)&nout, (ftnlen)sizeof(integer));
+ e_rsle();
+ o__1.oerr = 0;
+ o__1.ounit = nout;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = summry;
+ o__1.orl = 0;
+ o__1.osta = 0;
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);
+ infoc_1.noutc = nout;
+
+/* Read name and unit number for snapshot output file and open file. */
+
+ s_rsle(&io___6);
+ do_lio(&c__9, &c__1, snaps, (ftnlen)32);
+ e_rsle();
+ s_rsle(&io___8);
+ do_lio(&c__3, &c__1, (char *)&ntra, (ftnlen)sizeof(integer));
+ e_rsle();
+ trace = ntra >= 0;
+ if (trace) {
+ o__1.oerr = 0;
+ o__1.ounit = ntra;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = snaps;
+ o__1.orl = 0;
+ o__1.osta = 0;
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);
+ }
+/* Read the flag that directs rewinding of the snapshot file. */
+ s_rsle(&io___11);
+ do_lio(&c__8, &c__1, (char *)&rewi, (ftnlen)sizeof(logical));
+ e_rsle();
+ rewi = rewi && trace;
+/* Read the flag that directs stopping on any failure. */
+ s_rsle(&io___13);
+ do_lio(&c__8, &c__1, (char *)&sfatal, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the flag that indicates whether error exits are to be tested. */
+ s_rsle(&io___15);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the threshold value of the test ratio */
+ s_rsle(&io___17);
+ do_lio(&c__4, &c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_rsle();
+
+/* Read and check the parameter values for the tests. */
+
+/* Values of N */
+ s_rsle(&io___19);
+ do_lio(&c__3, &c__1, (char *)&nidim, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nidim < 1 || nidim > 9) {
+ io___21.ciunit = nout;
+ s_wsfe(&io___21);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___22);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {
+ io___25.ciunit = nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, (char *)&c__65, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+/* L10: */
+ }
+/* Values of ALPHA */
+ s_rsle(&io___26);
+ do_lio(&c__3, &c__1, (char *)&nalf, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nalf < 1 || nalf > 7) {
+ io___28.ciunit = nout;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "ALPHA", (ftnlen)5);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___29);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__6, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(complex));
+ }
+ e_rsle();
+/* Values of BETA */
+ s_rsle(&io___31);
+ do_lio(&c__3, &c__1, (char *)&nbet, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nbet < 1 || nbet > 7) {
+ io___33.ciunit = nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, "BETA", (ftnlen)4);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___34);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__6, &c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(complex));
+ }
+ e_rsle();
+
+/* Report values of parameters. */
+
+ io___36.ciunit = nout;
+ s_wsfe(&io___36);
+ e_wsfe();
+ io___37.ciunit = nout;
+ s_wsfe(&io___37);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ io___38.ciunit = nout;
+ s_wsfe(&io___38);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__2, (char *)&alf[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_wsfe();
+ io___39.ciunit = nout;
+ s_wsfe(&io___39);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__2, (char *)&bet[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_wsfe();
+ if (! tsterr) {
+ io___40.ciunit = nout;
+ s_wsle(&io___40);
+ e_wsle();
+ io___41.ciunit = nout;
+ s_wsfe(&io___41);
+ e_wsfe();
+ }
+ io___42.ciunit = nout;
+ s_wsle(&io___42);
+ e_wsle();
+ io___43.ciunit = nout;
+ s_wsfe(&io___43);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_wsfe();
+ io___44.ciunit = nout;
+ s_wsle(&io___44);
+ e_wsle();
+
+/* Read names of subroutines and flags which indicate */
+/* whether they are to be tested. */
+
+ for (i__ = 1; i__ <= 9; ++i__) {
+ ltest[i__ - 1] = FALSE_;
+/* L20: */
+ }
+L30:
+ i__1 = s_rsfe(&io___46);
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = do_fio(&c__1, snamet, (ftnlen)6);
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = do_fio(&c__1, (char *)<estt, (ftnlen)sizeof(logical));
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L60;
+ }
+ for (i__ = 1; i__ <= 9; ++i__) {
+ if (s_cmp(snamet, snames + (i__ - 1) * 6, (ftnlen)6, (ftnlen)6) == 0)
+ {
+ goto L50;
+ }
+/* L40: */
+ }
+ io___49.ciunit = nout;
+ s_wsfe(&io___49);
+ do_fio(&c__1, snamet, (ftnlen)6);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+L50:
+ ltest[i__ - 1] = ltestt;
+ goto L30;
+
+L60:
+ cl__1.cerr = 0;
+ cl__1.cunit = 5;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+
+/* Compute EPS (the machine precision). */
+
+ eps = 1.f;
+L70:
+ r__1 = eps + 1.f;
+ if (sdiff_(&r__1, &c_b87) == 0.f) {
+ goto L80;
+ }
+ eps *= .5f;
+ goto L70;
+L80:
+ eps += eps;
+ io___51.ciunit = nout;
+ s_wsfe(&io___51);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+
+/* Check the reliability of CMMCH using exact data. */
+
+ n = 32;
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 65 - 66;
+/* Computing MAX */
+ i__5 = i__ - j + 1;
+ i__4 = max(i__5,0);
+ ab[i__3].r = (real) i__4, ab[i__3].i = 0.f;
+/* L90: */
+ }
+ i__2 = j + 4224;
+ ab[i__2].r = (real) j, ab[i__2].i = 0.f;
+ i__2 = (j + 65) * 65 - 65;
+ ab[i__2].r = (real) j, ab[i__2].i = 0.f;
+ i__2 = j - 1;
+ c__[i__2].r = 0.f, c__[i__2].i = 0.f;
+/* L100: */
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ i__3 = j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3;
+ cc[i__2].r = (real) i__3, cc[i__2].i = 0.f;
+/* L110: */
+ }
+/* CC holds the exact result. On exit from CMMCH CT holds */
+/* the result computed by CMMCH. */
+ *(unsigned char *)transa = 'N';
+ *(unsigned char *)transb = 'N';
+ cmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], &
+ c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal,
+ &nout, &c_true, (ftnlen)1, (ftnlen)1);
+ same = lce_(cc, ct, &n);
+ if (! same || err != 0.f) {
+ io___64.ciunit = nout;
+ s_wsfe(&io___64);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ *(unsigned char *)transb = 'C';
+ cmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], &
+ c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal,
+ &nout, &c_true, (ftnlen)1, (ftnlen)1);
+ same = lce_(cc, ct, &n);
+ if (! same || err != 0.f) {
+ io___65.ciunit = nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + 4224;
+ i__3 = n - j + 1;
+ ab[i__2].r = (real) i__3, ab[i__2].i = 0.f;
+ i__2 = (j + 65) * 65 - 65;
+ i__3 = n - j + 1;
+ ab[i__2].r = (real) i__3, ab[i__2].i = 0.f;
+/* L120: */
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = n - j;
+ i__3 = j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3;
+ cc[i__2].r = (real) i__3, cc[i__2].i = 0.f;
+/* L130: */
+ }
+ *(unsigned char *)transa = 'C';
+ *(unsigned char *)transb = 'N';
+ cmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], &
+ c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal,
+ &nout, &c_true, (ftnlen)1, (ftnlen)1);
+ same = lce_(cc, ct, &n);
+ if (! same || err != 0.f) {
+ io___66.ciunit = nout;
+ s_wsfe(&io___66);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ *(unsigned char *)transb = 'C';
+ cmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], &
+ c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal,
+ &nout, &c_true, (ftnlen)1, (ftnlen)1);
+ same = lce_(cc, ct, &n);
+ if (! same || err != 0.f) {
+ io___67.ciunit = nout;
+ s_wsfe(&io___67);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Test each subroutine in turn. */
+
+ for (isnum = 1; isnum <= 9; ++isnum) {
+ io___69.ciunit = nout;
+ s_wsle(&io___69);
+ e_wsle();
+ if (! ltest[isnum - 1]) {
+/* Subprogram is not to be tested. */
+ io___70.ciunit = nout;
+ s_wsfe(&io___70);
+ do_fio(&c__1, snames + (isnum - 1) * 6, (ftnlen)6);
+ e_wsfe();
+ } else {
+ s_copy(srnamc_1.srnamt, snames + (isnum - 1) * 6, (ftnlen)6, (
+ ftnlen)6);
+/* Test error exits. */
+ if (tsterr) {
+ cchke_(&isnum, snames + (isnum - 1) * 6, &nout, (ftnlen)6);
+ io___71.ciunit = nout;
+ s_wsle(&io___71);
+ e_wsle();
+ }
+/* Test computations. */
+ infoc_1.infot = 0;
+ infoc_1.ok = TRUE_;
+ fatal = FALSE_;
+ switch (isnum) {
+ case 1: goto L140;
+ case 2: goto L150;
+ case 3: goto L150;
+ case 4: goto L160;
+ case 5: goto L160;
+ case 6: goto L170;
+ case 7: goto L170;
+ case 8: goto L180;
+ case 9: goto L180;
+ }
+/* Test CGEMM, 01. */
+L140:
+ cchk1_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &nbet,
+ bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, cc, cs,
+ ct, g, (ftnlen)6);
+ goto L190;
+/* Test CHEMM, 02, CSYMM, 03. */
+L150:
+ cchk2_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &nbet,
+ bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, cc, cs,
+ ct, g, (ftnlen)6);
+ goto L190;
+/* Test CTRMM, 04, CTRSM, 05. */
+L160:
+ cchk3_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &c__65,
+ ab, aa, as, &ab[4225], bb, bs, ct, g, c__, (ftnlen)6);
+ goto L190;
+/* Test CHERK, 06, CSYRK, 07. */
+L170:
+ cchk4_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &nbet,
+ bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, cc, cs,
+ ct, g, (ftnlen)6);
+ goto L190;
+/* Test CHER2K, 08, CSYR2K, 09. */
+L180:
+ cchk5_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &nbet,
+ bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, ct, g, w, (
+ ftnlen)6);
+ goto L190;
+
+L190:
+ if (fatal && sfatal) {
+ goto L210;
+ }
+ }
+/* L200: */
+ }
+ io___78.ciunit = nout;
+ s_wsfe(&io___78);
+ e_wsfe();
+ goto L230;
+
+L210:
+ io___79.ciunit = nout;
+ s_wsfe(&io___79);
+ e_wsfe();
+ goto L230;
+
+L220:
+ io___80.ciunit = nout;
+ s_wsfe(&io___80);
+ e_wsfe();
+
+L230:
+ if (trace) {
+ cl__1.cerr = 0;
+ cl__1.cunit = ntra;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ }
+ cl__1.cerr = 0;
+ cl__1.cunit = nout;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ s_stop("", (ftnlen)0);
+
+
+/* End of CBLAT3. */
+
+ return 0;
+} /* MAIN__ */
+
+/* Subroutine */ int cchk1_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nalf, complex *alf, integer *
+ nbet, complex *bet, integer *nmax, complex *a, complex *aa, complex *
+ as, complex *b, complex *bb, complex *bs, complex *c__, complex *cc,
+ complex *cs, complex *ct, real *g, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ich[3] = "NTC";
+
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002','\002"
+ ",a1,\002',\002,3(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,"
+ "\002), A,\002,i3,\002, B,\002,i3,\002,(\002,f4.1,\002,\002,f4.1"
+ ",\002), C,\002,i3,\002).\002)";
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6, i__7, i__8;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, k, m, n, ia, ib, ma, mb, na, nb, nc, ik, im, in, ks, ms, ns,
+ ica, icb, laa, lbb, lda, lcc, ldb, ldc;
+ extern logical lce_(complex *, complex *, integer *);
+ complex als, bls;
+ real err;
+ complex beta;
+ integer ldas, ldbs, ldcs;
+ logical same, null;
+ extern /* Subroutine */ int cmake_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *, logical *,
+ complex *, ftnlen, ftnlen, ftnlen);
+ complex alpha;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), cmmch_(char *,
+ char *, integer *, integer *, integer *, complex *, complex *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, real *, complex *, integer *, real *, real *, logical *
+ , integer *, logical *, ftnlen, ftnlen);
+ logical isame[13], trana, tranb;
+ integer nargs;
+ logical reset;
+ extern logical lceres_(char *, char *, integer *, integer *, complex *,
+ complex *, integer *, ftnlen, ftnlen);
+ char tranas[1], tranbs[1], transa[1], transb[1];
+ real errmax;
+
+ /* Fortran I/O blocks */
+ static cilist io___124 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___125 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___128 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___130 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___131 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___132 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___133 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests CGEMM. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+
+ nargs = 13;
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.f;
+
+ i__1 = *nidim;
+ for (im = 1; im <= i__1; ++im) {
+ m = idim[im];
+
+ i__2 = *nidim;
+ for (in = 1; in <= i__2; ++in) {
+ n = idim[in];
+/* Set LDC to 1 more than minimum value if room. */
+ ldc = m;
+ if (ldc < *nmax) {
+ ++ldc;
+ }
+/* Skip tests if not enough room. */
+ if (ldc > *nmax) {
+ goto L100;
+ }
+ lcc = ldc * n;
+ null = n <= 0 || m <= 0;
+
+ i__3 = *nidim;
+ for (ik = 1; ik <= i__3; ++ik) {
+ k = idim[ik];
+
+ for (ica = 1; ica <= 3; ++ica) {
+ *(unsigned char *)transa = *(unsigned char *)&ich[ica - 1]
+ ;
+ trana = *(unsigned char *)transa == 'T' || *(unsigned
+ char *)transa == 'C';
+
+ if (trana) {
+ ma = k;
+ na = m;
+ } else {
+ ma = m;
+ na = k;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ lda = ma;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L80;
+ }
+ laa = lda * na;
+
+/* Generate the matrix A. */
+
+ cmake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[
+ 1], &lda, &reset, &c_b1, (ftnlen)2, (ftnlen)1, (
+ ftnlen)1);
+
+ for (icb = 1; icb <= 3; ++icb) {
+ *(unsigned char *)transb = *(unsigned char *)&ich[icb
+ - 1];
+ tranb = *(unsigned char *)transb == 'T' || *(unsigned
+ char *)transb == 'C';
+
+ if (tranb) {
+ mb = n;
+ nb = k;
+ } else {
+ mb = k;
+ nb = n;
+ }
+/* Set LDB to 1 more than minimum value if room. */
+ ldb = mb;
+ if (ldb < *nmax) {
+ ++ldb;
+ }
+/* Skip tests if not enough room. */
+ if (ldb > *nmax) {
+ goto L70;
+ }
+ lbb = ldb * nb;
+
+/* Generate the matrix B. */
+
+ cmake_("GE", " ", " ", &mb, &nb, &b[b_offset], nmax, &
+ bb[1], &ldb, &reset, &c_b1, (ftnlen)2, (
+ ftnlen)1, (ftnlen)1);
+
+ i__4 = *nalf;
+ for (ia = 1; ia <= i__4; ++ia) {
+ i__5 = ia;
+ alpha.r = alf[i__5].r, alpha.i = alf[i__5].i;
+
+ i__5 = *nbet;
+ for (ib = 1; ib <= i__5; ++ib) {
+ i__6 = ib;
+ beta.r = bet[i__6].r, beta.i = bet[i__6].i;
+
+/* Generate the matrix C. */
+
+ cmake_("GE", " ", " ", &m, &n, &c__[c_offset],
+ nmax, &cc[1], &ldc, &reset, &c_b1, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the */
+/* subroutine. */
+
+ *(unsigned char *)tranas = *(unsigned char *)
+ transa;
+ *(unsigned char *)tranbs = *(unsigned char *)
+ transb;
+ ms = m;
+ ns = n;
+ ks = k;
+ als.r = alpha.r, als.i = alpha.i;
+ i__6 = laa;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ i__7 = i__;
+ i__8 = i__;
+ as[i__7].r = aa[i__8].r, as[i__7].i = aa[
+ i__8].i;
+/* L10: */
+ }
+ ldas = lda;
+ i__6 = lbb;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ i__7 = i__;
+ i__8 = i__;
+ bs[i__7].r = bb[i__8].r, bs[i__7].i = bb[
+ i__8].i;
+/* L20: */
+ }
+ ldbs = ldb;
+ bls.r = beta.r, bls.i = beta.i;
+ i__6 = lcc;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ i__7 = i__;
+ i__8 = i__;
+ cs[i__7].r = cc[i__8].r, cs[i__7].i = cc[
+ i__8].i;
+/* L30: */
+ }
+ ldcs = ldc;
+
+/* Call the subroutine. */
+
+ if (*trace) {
+ io___124.ciunit = *ntra;
+ s_wsfe(&io___124);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ cgemm_(transa, transb, &m, &n, &k, &alpha, &
+ aa[1], &lda, &bb[1], &ldb, &beta, &cc[
+ 1], &ldc);
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___125.ciunit = *nout;
+ s_wsfe(&io___125);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)transa == *(
+ unsigned char *)tranas;
+ isame[1] = *(unsigned char *)transb == *(
+ unsigned char *)tranbs;
+ isame[2] = ms == m;
+ isame[3] = ns == n;
+ isame[4] = ks == k;
+ isame[5] = als.r == alpha.r && als.i ==
+ alpha.i;
+ isame[6] = lce_(&as[1], &aa[1], &laa);
+ isame[7] = ldas == lda;
+ isame[8] = lce_(&bs[1], &bb[1], &lbb);
+ isame[9] = ldbs == ldb;
+ isame[10] = bls.r == beta.r && bls.i ==
+ beta.i;
+ if (null) {
+ isame[11] = lce_(&cs[1], &cc[1], &lcc);
+ } else {
+ isame[11] = lceres_("GE", " ", &m, &n, &
+ cs[1], &cc[1], &ldc, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[12] = ldcs == ldc;
+
+/* If data was incorrectly changed, report */
+/* and return. */
+
+ same = TRUE_;
+ i__6 = nargs;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___128.ciunit = *nout;
+ s_wsfe(&io___128);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+
+/* Check the result. */
+
+ cmmch_(transa, transb, &m, &n, &k, &alpha,
+ &a[a_offset], nmax, &b[b_offset],
+ nmax, &beta, &c__[c_offset],
+ nmax, &ct[1], &g[1], &cc[1], &ldc,
+ eps, &err, fatal, nout, &c_true,
+ (ftnlen)1, (ftnlen)1);
+ errmax = dmax(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L120;
+ }
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+L70:
+ ;
+ }
+
+L80:
+ ;
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+/* L110: */
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___130.ciunit = *nout;
+ s_wsfe(&io___130);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___131.ciunit = *nout;
+ s_wsfe(&io___131);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ goto L130;
+
+L120:
+ io___132.ciunit = *nout;
+ s_wsfe(&io___132);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ io___133.ciunit = *nout;
+ s_wsfe(&io___133);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L130:
+ return 0;
+
+
+/* End of CCHK1. */
+
+} /* cchk1_ */
+
+/* Subroutine */ int cchk2_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nalf, complex *alf, integer *
+ nbet, complex *bet, integer *nmax, complex *a, complex *aa, complex *
+ as, complex *b, complex *bb, complex *bs, complex *c__, complex *cc,
+ complex *cs, complex *ct, real *g, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ichs[2] = "LR";
+ static char ichu[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002(\002,2(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,\002)"
+ ", A,\002,i3,\002, B,\002,i3,\002,(\002,f4.1,\002,\002,f4.1,\002)"
+ ", C,\002,i3,\002) .\002)";
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6, i__7;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio(
+ integer *, char *, ftnlen), e_wsfe(void), f_rew(alist *);
+
+ /* Local variables */
+ integer i__, m, n, ia, ib, na, nc, im, in, ms, ns, laa, lbb, lda, lcc,
+ ldb, ldc;
+ extern logical lce_(complex *, complex *, integer *);
+ integer ics;
+ complex als, bls;
+ integer icu;
+ real err;
+ complex beta;
+ integer ldas, ldbs, ldcs;
+ logical same;
+ char side[1];
+ logical conj, left, null;
+ char uplo[1];
+ extern /* Subroutine */ int cmake_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *, logical *,
+ complex *, ftnlen, ftnlen, ftnlen);
+ complex alpha;
+ extern /* Subroutine */ int cmmch_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *, complex *, real *, complex *,
+ integer *, real *, real *, logical *, integer *, logical *,
+ ftnlen, ftnlen), chemm_(char *, char *, integer *, integer *,
+ complex *, complex *, integer *, complex *, integer *, complex *,
+ complex *, integer *);
+ logical isame[13];
+ char sides[1];
+ integer nargs;
+ logical reset;
+ extern /* Subroutine */ int csymm_(char *, char *, integer *, integer *,
+ complex *, complex *, integer *, complex *, integer *, complex *,
+ complex *, integer *);
+ char uplos[1];
+ extern logical lceres_(char *, char *, integer *, integer *, complex *,
+ complex *, integer *, ftnlen, ftnlen);
+ real errmax;
+
+ /* Fortran I/O blocks */
+ static cilist io___172 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___173 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___176 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___178 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___179 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___180 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___181 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests CHEMM and CSYMM. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ conj = s_cmp(sname + 1, "HE", (ftnlen)2, (ftnlen)2) == 0;
+
+ nargs = 12;
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.f;
+
+ i__1 = *nidim;
+ for (im = 1; im <= i__1; ++im) {
+ m = idim[im];
+
+ i__2 = *nidim;
+ for (in = 1; in <= i__2; ++in) {
+ n = idim[in];
+/* Set LDC to 1 more than minimum value if room. */
+ ldc = m;
+ if (ldc < *nmax) {
+ ++ldc;
+ }
+/* Skip tests if not enough room. */
+ if (ldc > *nmax) {
+ goto L90;
+ }
+ lcc = ldc * n;
+ null = n <= 0 || m <= 0;
+/* Set LDB to 1 more than minimum value if room. */
+ ldb = m;
+ if (ldb < *nmax) {
+ ++ldb;
+ }
+/* Skip tests if not enough room. */
+ if (ldb > *nmax) {
+ goto L90;
+ }
+ lbb = ldb * n;
+
+/* Generate the matrix B. */
+
+ cmake_("GE", " ", " ", &m, &n, &b[b_offset], nmax, &bb[1], &ldb, &
+ reset, &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ for (ics = 1; ics <= 2; ++ics) {
+ *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1];
+ left = *(unsigned char *)side == 'L';
+
+ if (left) {
+ na = m;
+ } else {
+ na = n;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ lda = na;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L80;
+ }
+ laa = lda * na;
+
+ for (icu = 1; icu <= 2; ++icu) {
+ *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
+
+/* Generate the hermitian or symmetric matrix A. */
+
+ cmake_(sname + 1, uplo, " ", &na, &na, &a[a_offset], nmax,
+ &aa[1], &lda, &reset, &c_b1, (ftnlen)2, (ftnlen)
+ 1, (ftnlen)1);
+
+ i__3 = *nalf;
+ for (ia = 1; ia <= i__3; ++ia) {
+ i__4 = ia;
+ alpha.r = alf[i__4].r, alpha.i = alf[i__4].i;
+
+ i__4 = *nbet;
+ for (ib = 1; ib <= i__4; ++ib) {
+ i__5 = ib;
+ beta.r = bet[i__5].r, beta.i = bet[i__5].i;
+
+/* Generate the matrix C. */
+
+ cmake_("GE", " ", " ", &m, &n, &c__[c_offset],
+ nmax, &cc[1], &ldc, &reset, &c_b1, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the */
+/* subroutine. */
+
+ *(unsigned char *)sides = *(unsigned char *)side;
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ ms = m;
+ ns = n;
+ als.r = alpha.r, als.i = alpha.i;
+ i__5 = laa;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7]
+ .i;
+/* L10: */
+ }
+ ldas = lda;
+ i__5 = lbb;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ bs[i__6].r = bb[i__7].r, bs[i__6].i = bb[i__7]
+ .i;
+/* L20: */
+ }
+ ldbs = ldb;
+ bls.r = beta.r, bls.i = beta.i;
+ i__5 = lcc;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ cs[i__6].r = cc[i__7].r, cs[i__6].i = cc[i__7]
+ .i;
+/* L30: */
+ }
+ ldcs = ldc;
+
+/* Call the subroutine. */
+
+ if (*trace) {
+ io___172.ciunit = *ntra;
+ s_wsfe(&io___172);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(
+ real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(
+ real));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ if (conj) {
+ chemm_(side, uplo, &m, &n, &alpha, &aa[1], &
+ lda, &bb[1], &ldb, &beta, &cc[1], &
+ ldc);
+ } else {
+ csymm_(side, uplo, &m, &n, &alpha, &aa[1], &
+ lda, &bb[1], &ldb, &beta, &cc[1], &
+ ldc);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___173.ciunit = *nout;
+ s_wsfe(&io___173);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L110;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)sides == *(unsigned
+ char *)side;
+ isame[1] = *(unsigned char *)uplos == *(unsigned
+ char *)uplo;
+ isame[2] = ms == m;
+ isame[3] = ns == n;
+ isame[4] = als.r == alpha.r && als.i == alpha.i;
+ isame[5] = lce_(&as[1], &aa[1], &laa);
+ isame[6] = ldas == lda;
+ isame[7] = lce_(&bs[1], &bb[1], &lbb);
+ isame[8] = ldbs == ldb;
+ isame[9] = bls.r == beta.r && bls.i == beta.i;
+ if (null) {
+ isame[10] = lce_(&cs[1], &cc[1], &lcc);
+ } else {
+ isame[10] = lceres_("GE", " ", &m, &n, &cs[1],
+ &cc[1], &ldc, (ftnlen)2, (ftnlen)1);
+ }
+ isame[11] = ldcs == ldc;
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__5 = nargs;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___176.ciunit = *nout;
+ s_wsfe(&io___176);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L110;
+ }
+
+ if (! null) {
+
+/* Check the result. */
+
+ if (left) {
+ cmmch_("N", "N", &m, &n, &m, &alpha, &a[
+ a_offset], nmax, &b[b_offset],
+ nmax, &beta, &c__[c_offset], nmax,
+ &ct[1], &g[1], &cc[1], &ldc, eps,
+ &err, fatal, nout, &c_true, (
+ ftnlen)1, (ftnlen)1);
+ } else {
+ cmmch_("N", "N", &m, &n, &n, &alpha, &b[
+ b_offset], nmax, &a[a_offset],
+ nmax, &beta, &c__[c_offset], nmax,
+ &ct[1], &g[1], &cc[1], &ldc, eps,
+ &err, fatal, nout, &c_true, (
+ ftnlen)1, (ftnlen)1);
+ }
+ errmax = dmax(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L110;
+ }
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+/* L70: */
+ }
+
+L80:
+ ;
+ }
+
+L90:
+ ;
+ }
+
+/* L100: */
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___178.ciunit = *nout;
+ s_wsfe(&io___178);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___179.ciunit = *nout;
+ s_wsfe(&io___179);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ goto L120;
+
+L110:
+ io___180.ciunit = *nout;
+ s_wsfe(&io___180);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ io___181.ciunit = *nout;
+ s_wsfe(&io___181);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L120:
+ return 0;
+
+
+/* End of CCHK2. */
+
+} /* cchk2_ */
+
+/* Subroutine */ int cchk3_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nalf, complex *alf, integer *
+ nmax, complex *a, complex *aa, complex *as, complex *b, complex *bb,
+ complex *bs, complex *ct, real *g, complex *c__, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ichu[2] = "UL";
+ static char icht[3] = "NTC";
+ static char ichd[2] = "UN";
+ static char ichs[2] = "LR";
+
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002(\002,4(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,\002)"
+ ", A,\002,i3,\002, B,\002,i3,\002) \002,\002 .\002)";
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6, i__7;
+ complex q__1;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio(
+ integer *, char *, ftnlen), e_wsfe(void), f_rew(alist *);
+
+ /* Local variables */
+ integer i__, j, m, n, ia, na, nc, im, in, ms, ns, laa, icd, lbb, lda, ldb;
+ extern logical lce_(complex *, complex *, integer *);
+ integer ics;
+ complex als;
+ integer ict, icu;
+ real err;
+ char diag[1];
+ integer ldas, ldbs;
+ logical same;
+ char side[1];
+ logical left, null;
+ char uplo[1];
+ extern /* Subroutine */ int cmake_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *, logical *,
+ complex *, ftnlen, ftnlen, ftnlen);
+ complex alpha;
+ char diags[1];
+ extern /* Subroutine */ int cmmch_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *, complex *, real *, complex *,
+ integer *, real *, real *, logical *, integer *, logical *,
+ ftnlen, ftnlen);
+ logical isame[13];
+ char sides[1];
+ integer nargs;
+ logical reset;
+ extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *), ctrsm_(char *, char *,
+ char *, char *, integer *, integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ char uplos[1];
+ extern logical lceres_(char *, char *, integer *, integer *, complex *,
+ complex *, integer *, ftnlen, ftnlen);
+ char tranas[1], transa[1];
+ real errmax;
+
+ /* Fortran I/O blocks */
+ static cilist io___222 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___223 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___224 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___227 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___229 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___230 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___231 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___232 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests CTRMM and CTRSM. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --g;
+ --ct;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+
+ nargs = 11;
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.f;
+/* Set up zero matrix for CMMCH. */
+ i__1 = *nmax;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *nmax;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0.f, c__[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+
+ i__1 = *nidim;
+ for (im = 1; im <= i__1; ++im) {
+ m = idim[im];
+
+ i__2 = *nidim;
+ for (in = 1; in <= i__2; ++in) {
+ n = idim[in];
+/* Set LDB to 1 more than minimum value if room. */
+ ldb = m;
+ if (ldb < *nmax) {
+ ++ldb;
+ }
+/* Skip tests if not enough room. */
+ if (ldb > *nmax) {
+ goto L130;
+ }
+ lbb = ldb * n;
+ null = m <= 0 || n <= 0;
+
+ for (ics = 1; ics <= 2; ++ics) {
+ *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1];
+ left = *(unsigned char *)side == 'L';
+ if (left) {
+ na = m;
+ } else {
+ na = n;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ lda = na;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L130;
+ }
+ laa = lda * na;
+
+ for (icu = 1; icu <= 2; ++icu) {
+ *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
+
+ for (ict = 1; ict <= 3; ++ict) {
+ *(unsigned char *)transa = *(unsigned char *)&icht[
+ ict - 1];
+
+ for (icd = 1; icd <= 2; ++icd) {
+ *(unsigned char *)diag = *(unsigned char *)&ichd[
+ icd - 1];
+
+ i__3 = *nalf;
+ for (ia = 1; ia <= i__3; ++ia) {
+ i__4 = ia;
+ alpha.r = alf[i__4].r, alpha.i = alf[i__4].i;
+
+/* Generate the matrix A. */
+
+ cmake_("TR", uplo, diag, &na, &na, &a[
+ a_offset], nmax, &aa[1], &lda, &reset,
+ &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)
+ 1);
+
+/* Generate the matrix B. */
+
+ cmake_("GE", " ", " ", &m, &n, &b[b_offset],
+ nmax, &bb[1], &ldb, &reset, &c_b1, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the */
+/* subroutine. */
+
+ *(unsigned char *)sides = *(unsigned char *)
+ side;
+ *(unsigned char *)uplos = *(unsigned char *)
+ uplo;
+ *(unsigned char *)tranas = *(unsigned char *)
+ transa;
+ *(unsigned char *)diags = *(unsigned char *)
+ diag;
+ ms = m;
+ ns = n;
+ als.r = alpha.r, als.i = alpha.i;
+ i__4 = laa;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__;
+ i__6 = i__;
+ as[i__5].r = aa[i__6].r, as[i__5].i = aa[
+ i__6].i;
+/* L30: */
+ }
+ ldas = lda;
+ i__4 = lbb;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__;
+ i__6 = i__;
+ bs[i__5].r = bb[i__6].r, bs[i__5].i = bb[
+ i__6].i;
+/* L40: */
+ }
+ ldbs = ldb;
+
+/* Call the subroutine. */
+
+ if (s_cmp(sname + 3, "MM", (ftnlen)2, (ftnlen)
+ 2) == 0) {
+ if (*trace) {
+ io___222.ciunit = *ntra;
+ s_wsfe(&io___222);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ctrmm_(side, uplo, transa, diag, &m, &n, &
+ alpha, &aa[1], &lda, &bb[1], &ldb);
+ } else if (s_cmp(sname + 3, "SM", (ftnlen)2, (
+ ftnlen)2) == 0) {
+ if (*trace) {
+ io___223.ciunit = *ntra;
+ s_wsfe(&io___223);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ctrsm_(side, uplo, transa, diag, &m, &n, &
+ alpha, &aa[1], &lda, &bb[1], &ldb);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___224.ciunit = *nout;
+ s_wsfe(&io___224);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L150;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)sides == *(
+ unsigned char *)side;
+ isame[1] = *(unsigned char *)uplos == *(
+ unsigned char *)uplo;
+ isame[2] = *(unsigned char *)tranas == *(
+ unsigned char *)transa;
+ isame[3] = *(unsigned char *)diags == *(
+ unsigned char *)diag;
+ isame[4] = ms == m;
+ isame[5] = ns == n;
+ isame[6] = als.r == alpha.r && als.i ==
+ alpha.i;
+ isame[7] = lce_(&as[1], &aa[1], &laa);
+ isame[8] = ldas == lda;
+ if (null) {
+ isame[9] = lce_(&bs[1], &bb[1], &lbb);
+ } else {
+ isame[9] = lceres_("GE", " ", &m, &n, &bs[
+ 1], &bb[1], &ldb, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[10] = ldbs == ldb;
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__4 = nargs;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___227.ciunit = *nout;
+ s_wsfe(&io___227);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L50: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L150;
+ }
+
+ if (! null) {
+ if (s_cmp(sname + 3, "MM", (ftnlen)2, (
+ ftnlen)2) == 0) {
+
+/* Check the result. */
+
+ if (left) {
+ cmmch_(transa, "N", &m, &n, &m, &
+ alpha, &a[a_offset], nmax,
+ &b[b_offset], nmax, &
+ c_b1, &c__[c_offset],
+ nmax, &ct[1], &g[1], &bb[
+ 1], &ldb, eps, &err,
+ fatal, nout, &c_true, (
+ ftnlen)1, (ftnlen)1);
+ } else {
+ cmmch_("N", transa, &m, &n, &n, &
+ alpha, &b[b_offset], nmax,
+ &a[a_offset], nmax, &
+ c_b1, &c__[c_offset],
+ nmax, &ct[1], &g[1], &bb[
+ 1], &ldb, eps, &err,
+ fatal, nout, &c_true, (
+ ftnlen)1, (ftnlen)1);
+ }
+ } else if (s_cmp(sname + 3, "SM", (ftnlen)
+ 2, (ftnlen)2) == 0) {
+
+/* Compute approximation to original */
+/* matrix. */
+
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__5 = m;
+ for (i__ = 1; i__ <= i__5; ++i__)
+ {
+ i__6 = i__ + j * c_dim1;
+ i__7 = i__ + (j - 1) * ldb;
+ c__[i__6].r = bb[i__7].r, c__[i__6].i = bb[i__7].i;
+ i__6 = i__ + (j - 1) * ldb;
+ i__7 = i__ + j * b_dim1;
+ q__1.r = alpha.r * b[i__7].r - alpha.i * b[i__7].i,
+ q__1.i = alpha.r * b[i__7].i + alpha.i * b[
+ i__7].r;
+ bb[i__6].r = q__1.r, bb[i__6].i = q__1.i;
+/* L60: */
+ }
+/* L70: */
+ }
+
+ if (left) {
+ cmmch_(transa, "N", &m, &n, &m, &
+ c_b2, &a[a_offset], nmax,
+ &c__[c_offset], nmax, &
+ c_b1, &b[b_offset], nmax,
+ &ct[1], &g[1], &bb[1], &
+ ldb, eps, &err, fatal,
+ nout, &c_false, (ftnlen)1,
+ (ftnlen)1);
+ } else {
+ cmmch_("N", transa, &m, &n, &n, &
+ c_b2, &c__[c_offset],
+ nmax, &a[a_offset], nmax,
+ &c_b1, &b[b_offset], nmax,
+ &ct[1], &g[1], &bb[1], &
+ ldb, eps, &err, fatal,
+ nout, &c_false, (ftnlen)1,
+ (ftnlen)1);
+ }
+ }
+ errmax = dmax(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L150;
+ }
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+/* L100: */
+ }
+
+/* L110: */
+ }
+
+/* L120: */
+ }
+
+L130:
+ ;
+ }
+
+/* L140: */
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___229.ciunit = *nout;
+ s_wsfe(&io___229);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___230.ciunit = *nout;
+ s_wsfe(&io___230);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ goto L160;
+
+L150:
+ io___231.ciunit = *nout;
+ s_wsfe(&io___231);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ io___232.ciunit = *nout;
+ s_wsfe(&io___232);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L160:
+ return 0;
+
+
+/* End of CCHK3. */
+
+} /* cchk3_ */
+
+/* Subroutine */ int cchk4_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nalf, complex *alf, integer *
+ nbet, complex *bet, integer *nmax, complex *a, complex *aa, complex *
+ as, complex *b, complex *bb, complex *bs, complex *c__, complex *cc,
+ complex *cs, complex *ct, real *g, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char icht[2] = "NC";
+ static char ichu[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002(\002,2(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),f4.1,\002, A,\002,i3,\002,\002,f4.1,"
+ "\002, C,\002,i3,\002) \002,\002 .\002)";
+ static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002(\002,2(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,\002)"
+ " , A,\002,i3,\002,(\002,f4.1,\002,\002,f4.1,\002), C,\002,i3,"
+ "\002) .\002)";
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6, i__7;
+ complex q__1;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio(
+ integer *, char *, ftnlen), e_wsfe(void), f_rew(alist *);
+
+ /* Local variables */
+ integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
+ lda, lcc, ldc;
+ extern logical lce_(complex *, complex *, integer *);
+ complex als;
+ integer ict, icu;
+ real err;
+ complex beta;
+ integer ldas, ldcs;
+ logical same, conj;
+ complex bets;
+ real rals;
+ logical tran, null;
+ char uplo[1];
+ extern /* Subroutine */ int cmake_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *, logical *,
+ complex *, ftnlen, ftnlen, ftnlen);
+ complex alpha;
+ extern /* Subroutine */ int cmmch_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *, complex *, real *, complex *,
+ integer *, real *, real *, logical *, integer *, logical *,
+ ftnlen, ftnlen), cherk_(char *, char *, integer *, integer *,
+ real *, complex *, integer *, real *, complex *, integer *);
+ real rbeta;
+ logical isame[13];
+ integer nargs;
+ real rbets;
+ logical reset;
+ char trans[1];
+ logical upper;
+ extern /* Subroutine */ int csyrk_(char *, char *, integer *, integer *,
+ complex *, complex *, integer *, complex *, complex *, integer *);
+ char uplos[1];
+ real ralpha;
+ extern logical lceres_(char *, char *, integer *, integer *, complex *,
+ complex *, integer *, ftnlen, ftnlen);
+ real errmax;
+ char transs[1], transt[1];
+
+ /* Fortran I/O blocks */
+ static cilist io___274 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___275 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___276 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___279 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___286 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___287 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___288 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___289 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___290 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___291 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* Tests CHERK and CSYRK. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ conj = s_cmp(sname + 1, "HE", (ftnlen)2, (ftnlen)2) == 0;
+
+ nargs = 10;
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.f;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+/* Set LDC to 1 more than minimum value if room. */
+ ldc = n;
+ if (ldc < *nmax) {
+ ++ldc;
+ }
+/* Skip tests if not enough room. */
+ if (ldc > *nmax) {
+ goto L100;
+ }
+ lcc = ldc * n;
+
+ i__2 = *nidim;
+ for (ik = 1; ik <= i__2; ++ik) {
+ k = idim[ik];
+
+ for (ict = 1; ict <= 2; ++ict) {
+ *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1];
+ tran = *(unsigned char *)trans == 'C';
+ if (tran && ! conj) {
+ *(unsigned char *)trans = 'T';
+ }
+ if (tran) {
+ ma = k;
+ na = n;
+ } else {
+ ma = n;
+ na = k;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ lda = ma;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L80;
+ }
+ laa = lda * na;
+
+/* Generate the matrix A. */
+
+ cmake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[1], &
+ lda, &reset, &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ for (icu = 1; icu <= 2; ++icu) {
+ *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
+ upper = *(unsigned char *)uplo == 'U';
+
+ i__3 = *nalf;
+ for (ia = 1; ia <= i__3; ++ia) {
+ i__4 = ia;
+ alpha.r = alf[i__4].r, alpha.i = alf[i__4].i;
+ if (conj) {
+ ralpha = alpha.r;
+ q__1.r = ralpha, q__1.i = 0.f;
+ alpha.r = q__1.r, alpha.i = q__1.i;
+ }
+
+ i__4 = *nbet;
+ for (ib = 1; ib <= i__4; ++ib) {
+ i__5 = ib;
+ beta.r = bet[i__5].r, beta.i = bet[i__5].i;
+ if (conj) {
+ rbeta = beta.r;
+ q__1.r = rbeta, q__1.i = 0.f;
+ beta.r = q__1.r, beta.i = q__1.i;
+ }
+ null = n <= 0;
+ if (conj) {
+ null = null || (k <= 0 || ralpha == 0.f) &&
+ rbeta == 1.f;
+ }
+
+/* Generate the matrix C. */
+
+ cmake_(sname + 1, uplo, " ", &n, &n, &c__[
+ c_offset], nmax, &cc[1], &ldc, &reset, &
+ c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ *(unsigned char *)transs = *(unsigned char *)
+ trans;
+ ns = n;
+ ks = k;
+ if (conj) {
+ rals = ralpha;
+ } else {
+ als.r = alpha.r, als.i = alpha.i;
+ }
+ i__5 = laa;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7]
+ .i;
+/* L10: */
+ }
+ ldas = lda;
+ if (conj) {
+ rbets = rbeta;
+ } else {
+ bets.r = beta.r, bets.i = beta.i;
+ }
+ i__5 = lcc;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ cs[i__6].r = cc[i__7].r, cs[i__6].i = cc[i__7]
+ .i;
+/* L20: */
+ }
+ ldcs = ldc;
+
+/* Call the subroutine. */
+
+ if (conj) {
+ if (*trace) {
+ io___274.ciunit = *ntra;
+ s_wsfe(&io___274);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&ralpha, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&rbeta, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ cherk_(uplo, trans, &n, &k, &ralpha, &aa[1], &
+ lda, &rbeta, &cc[1], &ldc);
+ } else {
+ if (*trace) {
+ io___275.ciunit = *ntra;
+ s_wsfe(&io___275);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ csyrk_(uplo, trans, &n, &k, &alpha, &aa[1], &
+ lda, &beta, &cc[1], &ldc);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___276.ciunit = *nout;
+ s_wsfe(&io___276);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplos == *(unsigned
+ char *)uplo;
+ isame[1] = *(unsigned char *)transs == *(unsigned
+ char *)trans;
+ isame[2] = ns == n;
+ isame[3] = ks == k;
+ if (conj) {
+ isame[4] = rals == ralpha;
+ } else {
+ isame[4] = als.r == alpha.r && als.i ==
+ alpha.i;
+ }
+ isame[5] = lce_(&as[1], &aa[1], &laa);
+ isame[6] = ldas == lda;
+ if (conj) {
+ isame[7] = rbets == rbeta;
+ } else {
+ isame[7] = bets.r == beta.r && bets.i ==
+ beta.i;
+ }
+ if (null) {
+ isame[8] = lce_(&cs[1], &cc[1], &lcc);
+ } else {
+ isame[8] = lceres_(sname + 1, uplo, &n, &n, &
+ cs[1], &cc[1], &ldc, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[9] = ldcs == ldc;
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__5 = nargs;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___279.ciunit = *nout;
+ s_wsfe(&io___279);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L30: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+
+/* Check the result column by column. */
+
+ if (conj) {
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transt = 'T';
+ }
+ jc = 1;
+ i__5 = n;
+ for (j = 1; j <= i__5; ++j) {
+ if (upper) {
+ jj = 1;
+ lj = j;
+ } else {
+ jj = j;
+ lj = n - j + 1;
+ }
+ if (tran) {
+ cmmch_(transt, "N", &lj, &c__1, &k, &
+ alpha, &a[jj * a_dim1 + 1],
+ nmax, &a[j * a_dim1 + 1],
+ nmax, &beta, &c__[jj + j *
+ c_dim1], nmax, &ct[1], &g[1],
+ &cc[jc], &ldc, eps, &err,
+ fatal, nout, &c_true, (ftnlen)
+ 1, (ftnlen)1);
+ } else {
+ cmmch_("N", transt, &lj, &c__1, &k, &
+ alpha, &a[jj + a_dim1], nmax,
+ &a[j + a_dim1], nmax, &beta, &
+ c__[jj + j * c_dim1], nmax, &
+ ct[1], &g[1], &cc[jc], &ldc,
+ eps, &err, fatal, nout, &
+ c_true, (ftnlen)1, (ftnlen)1);
+ }
+ if (upper) {
+ jc += ldc;
+ } else {
+ jc = jc + ldc + 1;
+ }
+ errmax = dmax(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L110;
+ }
+/* L40: */
+ }
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+/* L70: */
+ }
+
+L80:
+ ;
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___286.ciunit = *nout;
+ s_wsfe(&io___286);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___287.ciunit = *nout;
+ s_wsfe(&io___287);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ goto L130;
+
+L110:
+ if (n > 1) {
+ io___288.ciunit = *nout;
+ s_wsfe(&io___288);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L120:
+ io___289.ciunit = *nout;
+ s_wsfe(&io___289);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (conj) {
+ io___290.ciunit = *nout;
+ s_wsfe(&io___290);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ralpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&rbeta, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___291.ciunit = *nout;
+ s_wsfe(&io___291);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L130:
+ return 0;
+
+
+/* End of CCHK4. */
+
+} /* cchk4_ */
+
+/* Subroutine */ int cchk5_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nalf, complex *alf, integer *
+ nbet, complex *bet, integer *nmax, complex *ab, complex *aa, complex *
+ as, complex *bb, complex *bs, complex *c__, complex *cc, complex *cs,
+ complex *ct, real *g, complex *w, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char icht[2] = "NC";
+ static char ichu[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002(\002,2(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,\002)"
+ ", A,\002,i3,\002, B,\002,i3,\002,\002,f4.1,\002, C,\002,i3,\002)"
+ " .\002)";
+ static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002(\002,2(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,\002)"
+ ", A,\002,i3,\002, B,\002,i3,\002,(\002,f4.1,\002,\002,f4.1,\002)"
+ ", C,\002,i3,\002) .\002)";
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
+ complex q__1, q__2;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio(
+ integer *, char *, ftnlen), e_wsfe(void), f_rew(alist *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
+ lbb, lda, lcc, ldb, ldc;
+ extern logical lce_(complex *, complex *, integer *);
+ complex als;
+ integer ict, icu;
+ real err;
+ integer jjab;
+ complex beta;
+ integer ldas, ldbs, ldcs;
+ logical same, conj;
+ complex bets;
+ logical tran, null;
+ char uplo[1];
+ extern /* Subroutine */ int cmake_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *, logical *,
+ complex *, ftnlen, ftnlen, ftnlen);
+ complex alpha;
+ extern /* Subroutine */ int cmmch_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *, complex *, real *, complex *,
+ integer *, real *, real *, logical *, integer *, logical *,
+ ftnlen, ftnlen);
+ real rbeta;
+ logical isame[13];
+ integer nargs;
+ real rbets;
+ logical reset;
+ char trans[1];
+ logical upper;
+ char uplos[1];
+ extern /* Subroutine */ int cher2k_(char *, char *, integer *, integer *,
+ complex *, complex *, integer *, complex *, integer *, real *,
+ complex *, integer *), csyr2k_(char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *, complex *, complex *, integer *);
+ extern logical lceres_(char *, char *, integer *, integer *, complex *,
+ complex *, integer *, ftnlen, ftnlen);
+ real errmax;
+ char transs[1], transt[1];
+
+ /* Fortran I/O blocks */
+ static cilist io___334 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___335 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___336 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___339 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___347 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___348 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___349 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___350 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___351 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___352 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* Tests CHER2K and CSYR2K. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --w;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ --as;
+ --aa;
+ --ab;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ conj = s_cmp(sname + 1, "HE", (ftnlen)2, (ftnlen)2) == 0;
+
+ nargs = 12;
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.f;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+/* Set LDC to 1 more than minimum value if room. */
+ ldc = n;
+ if (ldc < *nmax) {
+ ++ldc;
+ }
+/* Skip tests if not enough room. */
+ if (ldc > *nmax) {
+ goto L130;
+ }
+ lcc = ldc * n;
+
+ i__2 = *nidim;
+ for (ik = 1; ik <= i__2; ++ik) {
+ k = idim[ik];
+
+ for (ict = 1; ict <= 2; ++ict) {
+ *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1];
+ tran = *(unsigned char *)trans == 'C';
+ if (tran && ! conj) {
+ *(unsigned char *)trans = 'T';
+ }
+ if (tran) {
+ ma = k;
+ na = n;
+ } else {
+ ma = n;
+ na = k;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ lda = ma;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L110;
+ }
+ laa = lda * na;
+
+/* Generate the matrix A. */
+
+ if (tran) {
+ i__3 = *nmax << 1;
+ cmake_("GE", " ", " ", &ma, &na, &ab[1], &i__3, &aa[1], &
+ lda, &reset, &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)
+ 1);
+ } else {
+ cmake_("GE", " ", " ", &ma, &na, &ab[1], nmax, &aa[1], &
+ lda, &reset, &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)
+ 1);
+ }
+
+/* Generate the matrix B. */
+
+ ldb = lda;
+ lbb = laa;
+ if (tran) {
+ i__3 = *nmax << 1;
+ cmake_("GE", " ", " ", &ma, &na, &ab[k + 1], &i__3, &bb[1]
+ , &ldb, &reset, &c_b1, (ftnlen)2, (ftnlen)1, (
+ ftnlen)1);
+ } else {
+ cmake_("GE", " ", " ", &ma, &na, &ab[k * *nmax + 1], nmax,
+ &bb[1], &ldb, &reset, &c_b1, (ftnlen)2, (ftnlen)
+ 1, (ftnlen)1);
+ }
+
+ for (icu = 1; icu <= 2; ++icu) {
+ *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
+ upper = *(unsigned char *)uplo == 'U';
+
+ i__3 = *nalf;
+ for (ia = 1; ia <= i__3; ++ia) {
+ i__4 = ia;
+ alpha.r = alf[i__4].r, alpha.i = alf[i__4].i;
+
+ i__4 = *nbet;
+ for (ib = 1; ib <= i__4; ++ib) {
+ i__5 = ib;
+ beta.r = bet[i__5].r, beta.i = bet[i__5].i;
+ if (conj) {
+ rbeta = beta.r;
+ q__1.r = rbeta, q__1.i = 0.f;
+ beta.r = q__1.r, beta.i = q__1.i;
+ }
+ null = n <= 0;
+ if (conj) {
+ null = null || (k <= 0 || alpha.r == 0.f &&
+ alpha.i == 0.f) && rbeta == 1.f;
+ }
+
+/* Generate the matrix C. */
+
+ cmake_(sname + 1, uplo, " ", &n, &n, &c__[
+ c_offset], nmax, &cc[1], &ldc, &reset, &
+ c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ *(unsigned char *)transs = *(unsigned char *)
+ trans;
+ ns = n;
+ ks = k;
+ als.r = alpha.r, als.i = alpha.i;
+ i__5 = laa;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7]
+ .i;
+/* L10: */
+ }
+ ldas = lda;
+ i__5 = lbb;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ bs[i__6].r = bb[i__7].r, bs[i__6].i = bb[i__7]
+ .i;
+/* L20: */
+ }
+ ldbs = ldb;
+ if (conj) {
+ rbets = rbeta;
+ } else {
+ bets.r = beta.r, bets.i = beta.i;
+ }
+ i__5 = lcc;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ cs[i__6].r = cc[i__7].r, cs[i__6].i = cc[i__7]
+ .i;
+/* L30: */
+ }
+ ldcs = ldc;
+
+/* Call the subroutine. */
+
+ if (conj) {
+ if (*trace) {
+ io___334.ciunit = *ntra;
+ s_wsfe(&io___334);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&rbeta, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ cher2k_(uplo, trans, &n, &k, &alpha, &aa[1], &
+ lda, &bb[1], &ldb, &rbeta, &cc[1], &
+ ldc);
+ } else {
+ if (*trace) {
+ io___335.ciunit = *ntra;
+ s_wsfe(&io___335);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ csyr2k_(uplo, trans, &n, &k, &alpha, &aa[1], &
+ lda, &bb[1], &ldb, &beta, &cc[1], &
+ ldc);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___336.ciunit = *nout;
+ s_wsfe(&io___336);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L150;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplos == *(unsigned
+ char *)uplo;
+ isame[1] = *(unsigned char *)transs == *(unsigned
+ char *)trans;
+ isame[2] = ns == n;
+ isame[3] = ks == k;
+ isame[4] = als.r == alpha.r && als.i == alpha.i;
+ isame[5] = lce_(&as[1], &aa[1], &laa);
+ isame[6] = ldas == lda;
+ isame[7] = lce_(&bs[1], &bb[1], &lbb);
+ isame[8] = ldbs == ldb;
+ if (conj) {
+ isame[9] = rbets == rbeta;
+ } else {
+ isame[9] = bets.r == beta.r && bets.i ==
+ beta.i;
+ }
+ if (null) {
+ isame[10] = lce_(&cs[1], &cc[1], &lcc);
+ } else {
+ isame[10] = lceres_("HE", uplo, &n, &n, &cs[1]
+ , &cc[1], &ldc, (ftnlen)2, (ftnlen)1);
+ }
+ isame[11] = ldcs == ldc;
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__5 = nargs;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___339.ciunit = *nout;
+ s_wsfe(&io___339);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L150;
+ }
+
+ if (! null) {
+
+/* Check the result column by column. */
+
+ if (conj) {
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transt = 'T';
+ }
+ jjab = 1;
+ jc = 1;
+ i__5 = n;
+ for (j = 1; j <= i__5; ++j) {
+ if (upper) {
+ jj = 1;
+ lj = j;
+ } else {
+ jj = j;
+ lj = n - j + 1;
+ }
+ if (tran) {
+ i__6 = k;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ i__7 = i__;
+ i__8 = (j - 1 << 1) * *nmax + k +
+ i__;
+ q__1.r = alpha.r * ab[i__8].r -
+ alpha.i * ab[i__8].i,
+ q__1.i = alpha.r * ab[
+ i__8].i + alpha.i * ab[
+ i__8].r;
+ w[i__7].r = q__1.r, w[i__7].i =
+ q__1.i;
+ if (conj) {
+ i__7 = k + i__;
+ r_cnjg(&q__2, &alpha);
+ i__8 = (j - 1 << 1) * *nmax + i__;
+ q__1.r = q__2.r * ab[i__8].r - q__2.i * ab[i__8].i,
+ q__1.i = q__2.r * ab[i__8].i + q__2.i * ab[
+ i__8].r;
+ w[i__7].r = q__1.r, w[i__7].i = q__1.i;
+ } else {
+ i__7 = k + i__;
+ i__8 = (j - 1 << 1) * *nmax + i__;
+ q__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8]
+ .i, q__1.i = alpha.r * ab[i__8].i + alpha.i
+ * ab[i__8].r;
+ w[i__7].r = q__1.r, w[i__7].i = q__1.i;
+ }
+/* L50: */
+ }
+ i__6 = k << 1;
+ i__7 = *nmax << 1;
+ i__8 = *nmax << 1;
+ cmmch_(transt, "N", &lj, &c__1, &i__6,
+ &c_b2, &ab[jjab], &i__7, &w[
+ 1], &i__8, &beta, &c__[jj + j
+ * c_dim1], nmax, &ct[1], &g[1]
+ , &cc[jc], &ldc, eps, &err,
+ fatal, nout, &c_true, (ftnlen)
+ 1, (ftnlen)1);
+ } else {
+ i__6 = k;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ if (conj) {
+ i__7 = i__;
+ r_cnjg(&q__2, &ab[(k + i__ - 1) * *nmax + j]);
+ q__1.r = alpha.r * q__2.r - alpha.i * q__2.i,
+ q__1.i = alpha.r * q__2.i + alpha.i *
+ q__2.r;
+ w[i__7].r = q__1.r, w[i__7].i = q__1.i;
+ i__7 = k + i__;
+ i__8 = (i__ - 1) * *nmax + j;
+ q__2.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8]
+ .i, q__2.i = alpha.r * ab[i__8].i + alpha.i
+ * ab[i__8].r;
+ r_cnjg(&q__1, &q__2);
+ w[i__7].r = q__1.r, w[i__7].i = q__1.i;
+ } else {
+ i__7 = i__;
+ i__8 = (k + i__ - 1) * *nmax + j;
+ q__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8]
+ .i, q__1.i = alpha.r * ab[i__8].i + alpha.i
+ * ab[i__8].r;
+ w[i__7].r = q__1.r, w[i__7].i = q__1.i;
+ i__7 = k + i__;
+ i__8 = (i__ - 1) * *nmax + j;
+ q__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8]
+ .i, q__1.i = alpha.r * ab[i__8].i + alpha.i
+ * ab[i__8].r;
+ w[i__7].r = q__1.r, w[i__7].i = q__1.i;
+ }
+/* L60: */
+ }
+ i__6 = k << 1;
+ i__7 = *nmax << 1;
+ cmmch_("N", "N", &lj, &c__1, &i__6, &
+ c_b2, &ab[jj], nmax, &w[1], &
+ i__7, &beta, &c__[jj + j *
+ c_dim1], nmax, &ct[1], &g[1],
+ &cc[jc], &ldc, eps, &err,
+ fatal, nout, &c_true, (ftnlen)
+ 1, (ftnlen)1);
+ }
+ if (upper) {
+ jc += ldc;
+ } else {
+ jc = jc + ldc + 1;
+ if (tran) {
+ jjab += *nmax << 1;
+ }
+ }
+ errmax = dmax(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L140;
+ }
+/* L70: */
+ }
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+/* L100: */
+ }
+
+L110:
+ ;
+ }
+
+/* L120: */
+ }
+
+L130:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___347.ciunit = *nout;
+ s_wsfe(&io___347);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___348.ciunit = *nout;
+ s_wsfe(&io___348);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ goto L160;
+
+L140:
+ if (n > 1) {
+ io___349.ciunit = *nout;
+ s_wsfe(&io___349);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L150:
+ io___350.ciunit = *nout;
+ s_wsfe(&io___350);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (conj) {
+ io___351.ciunit = *nout;
+ s_wsfe(&io___351);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&rbeta, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___352.ciunit = *nout;
+ s_wsfe(&io___352);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L160:
+ return 0;
+
+
+/* End of CCHK5. */
+
+} /* cchk5_ */
+
+/* Subroutine */ int cchke_(integer *isnum, char *srnamt, integer *nout,
+ ftnlen srnamt_len)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE TESTS OF ERROR-E"
+ "XITS\002)";
+ static char fmt_9998[] = "(\002 ******* \002,a6,\002 FAILED THE TESTS OF"
+ " ERROR-EXITS *****\002,\002**\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ complex a[2] /* was [2][1] */, b[2] /* was [2][1] */, c__[2]
+ /* was [2][1] */, beta, alpha;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), chemm_(char *,
+ char *, integer *, integer *, complex *, complex *, integer *,
+ complex *, integer *, complex *, complex *, integer *), cherk_(char *, char *, integer *, integer *, real *,
+ complex *, integer *, real *, complex *, integer *);
+ real rbeta;
+ extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *), csymm_(char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *, complex *, complex *, integer *),
+ ctrsm_(char *, char *, char *, char *, integer *, integer *,
+ complex *, complex *, integer *, complex *, integer *), csyrk_(char *, char *, integer *,
+ integer *, complex *, complex *, integer *, complex *, complex *,
+ integer *), cher2k_(char *, char *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ real *, complex *, integer *), csyr2k_(char *,
+ char *, integer *, integer *, complex *, complex *, integer *,
+ complex *, integer *, complex *, complex *, integer *);
+ real ralpha;
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *);
+
+ /* Fortran I/O blocks */
+ static cilist io___360 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___361 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* Tests the error exits from the Level 3 Blas. */
+/* Requires a special version of the error-handling routine XERBLA. */
+/* A, B and C should not need to be defined. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* 3-19-92: Initialize ALPHA, BETA, RALPHA, and RBETA (eca) */
+/* 3-19-92: Fix argument 12 in calls to CSYMM and CHEMM */
+/* with INFOT = 9 (eca) */
+
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Parameters .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Subroutines .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+/* OK is set to .FALSE. by the special version of XERBLA or by CHKXER */
+/* if anything is wrong. */
+ infoc_1.ok = TRUE_;
+/* LERR is set to .TRUE. by the special version of XERBLA each time */
+/* it is called, and is then tested and re-set by CHKXER. */
+ infoc_1.lerr = FALSE_;
+
+/* Initialize ALPHA, BETA, RALPHA, and RBETA. */
+
+ alpha.r = 1.f, alpha.i = -1.f;
+ beta.r = 2.f, beta.i = -2.f;
+ ralpha = 1.f;
+ rbeta = 2.f;
+
+ switch (*isnum) {
+ case 1: goto L10;
+ case 2: goto L20;
+ case 3: goto L30;
+ case 4: goto L40;
+ case 5: goto L50;
+ case 6: goto L60;
+ case 7: goto L70;
+ case 8: goto L80;
+ case 9: goto L90;
+ }
+L10:
+ infoc_1.infot = 1;
+ cgemm_("/", "N", &c__0, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 1;
+ cgemm_("/", "C", &c__0, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 1;
+ cgemm_("/", "T", &c__0, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ cgemm_("N", "/", &c__0, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ cgemm_("C", "/", &c__0, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ cgemm_("T", "/", &c__0, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ cgemm_("N", "N", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ cgemm_("N", "C", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ cgemm_("N", "T", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ cgemm_("C", "N", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ cgemm_("C", "C", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ cgemm_("C", "T", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ cgemm_("T", "N", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ cgemm_("T", "C", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ cgemm_("T", "T", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ cgemm_("N", "N", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ cgemm_("N", "C", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ cgemm_("N", "T", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ cgemm_("C", "N", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ cgemm_("C", "C", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ cgemm_("C", "T", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ cgemm_("T", "N", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ cgemm_("T", "C", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ cgemm_("T", "T", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ cgemm_("N", "N", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ cgemm_("N", "C", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ cgemm_("N", "T", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ cgemm_("C", "N", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ cgemm_("C", "C", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ cgemm_("C", "T", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ cgemm_("T", "N", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ cgemm_("T", "C", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ cgemm_("T", "T", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ cgemm_("N", "N", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ cgemm_("N", "C", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ cgemm_("N", "T", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ cgemm_("C", "N", &c__0, &c__0, &c__2, &alpha, a, &c__1, b, &c__2, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ cgemm_("C", "C", &c__0, &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ cgemm_("C", "T", &c__0, &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ cgemm_("T", "N", &c__0, &c__0, &c__2, &alpha, a, &c__1, b, &c__2, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ cgemm_("T", "C", &c__0, &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ cgemm_("T", "T", &c__0, &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ cgemm_("N", "N", &c__0, &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ cgemm_("C", "N", &c__0, &c__0, &c__2, &alpha, a, &c__2, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ cgemm_("T", "N", &c__0, &c__0, &c__2, &alpha, a, &c__2, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ cgemm_("N", "C", &c__0, &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ cgemm_("C", "C", &c__0, &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ cgemm_("T", "C", &c__0, &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ cgemm_("N", "T", &c__0, &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ cgemm_("C", "T", &c__0, &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ cgemm_("T", "T", &c__0, &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ cgemm_("N", "N", &c__2, &c__0, &c__0, &alpha, a, &c__2, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ cgemm_("N", "C", &c__2, &c__0, &c__0, &alpha, a, &c__2, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ cgemm_("N", "T", &c__2, &c__0, &c__0, &alpha, a, &c__2, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ cgemm_("C", "N", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ cgemm_("C", "C", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ cgemm_("C", "T", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ cgemm_("T", "N", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ cgemm_("T", "C", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ cgemm_("T", "T", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L100;
+L20:
+ infoc_1.infot = 1;
+ chemm_("/", "U", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ chemm_("L", "/", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ chemm_("L", "U", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ chemm_("R", "U", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ chemm_("L", "L", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ chemm_("R", "L", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ chemm_("L", "U", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ chemm_("R", "U", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ chemm_("L", "L", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ chemm_("R", "L", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ chemm_("L", "U", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ chemm_("R", "U", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ chemm_("L", "L", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ chemm_("R", "L", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ chemm_("L", "U", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ chemm_("R", "U", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ chemm_("L", "L", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ chemm_("R", "L", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ chemm_("L", "U", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ chemm_("R", "U", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ chemm_("L", "L", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ chemm_("R", "L", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L100;
+L30:
+ infoc_1.infot = 1;
+ csymm_("/", "U", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ csymm_("L", "/", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ csymm_("L", "U", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ csymm_("R", "U", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ csymm_("L", "L", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ csymm_("R", "L", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ csymm_("L", "U", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ csymm_("R", "U", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ csymm_("L", "L", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ csymm_("R", "L", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ csymm_("L", "U", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ csymm_("R", "U", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ csymm_("L", "L", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ csymm_("R", "L", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ csymm_("L", "U", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ csymm_("R", "U", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ csymm_("L", "L", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ csymm_("R", "L", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ csymm_("L", "U", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ csymm_("R", "U", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ csymm_("L", "L", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ csymm_("R", "L", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L100;
+L40:
+ infoc_1.infot = 1;
+ ctrmm_("/", "U", "N", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ ctrmm_("L", "/", "N", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ctrmm_("L", "U", "/", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ctrmm_("L", "U", "N", "/", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrmm_("L", "U", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrmm_("L", "U", "C", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrmm_("L", "U", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrmm_("R", "U", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrmm_("R", "U", "C", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrmm_("R", "U", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrmm_("L", "L", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrmm_("L", "L", "C", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrmm_("L", "L", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrmm_("R", "L", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrmm_("R", "L", "C", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrmm_("R", "L", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrmm_("L", "U", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrmm_("L", "U", "C", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrmm_("L", "U", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrmm_("R", "U", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrmm_("R", "U", "C", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrmm_("R", "U", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrmm_("L", "L", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrmm_("L", "L", "C", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrmm_("L", "L", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrmm_("R", "L", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrmm_("R", "L", "C", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrmm_("R", "L", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrmm_("L", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrmm_("L", "U", "C", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrmm_("L", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrmm_("R", "U", "N", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrmm_("R", "U", "C", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrmm_("R", "U", "T", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrmm_("L", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrmm_("L", "L", "C", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrmm_("L", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrmm_("R", "L", "N", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrmm_("R", "L", "C", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrmm_("R", "L", "T", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrmm_("L", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrmm_("L", "U", "C", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrmm_("L", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrmm_("R", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrmm_("R", "U", "C", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrmm_("R", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrmm_("L", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrmm_("L", "L", "C", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrmm_("L", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrmm_("R", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrmm_("R", "L", "C", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrmm_("R", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L100;
+L50:
+ infoc_1.infot = 1;
+ ctrsm_("/", "U", "N", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ ctrsm_("L", "/", "N", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ctrsm_("L", "U", "/", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ctrsm_("L", "U", "N", "/", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrsm_("L", "U", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrsm_("L", "U", "C", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrsm_("L", "U", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrsm_("R", "U", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrsm_("R", "U", "C", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrsm_("R", "U", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrsm_("L", "L", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrsm_("L", "L", "C", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrsm_("L", "L", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrsm_("R", "L", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrsm_("R", "L", "C", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrsm_("R", "L", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrsm_("L", "U", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrsm_("L", "U", "C", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrsm_("L", "U", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrsm_("R", "U", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrsm_("R", "U", "C", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrsm_("R", "U", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrsm_("L", "L", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrsm_("L", "L", "C", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrsm_("L", "L", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrsm_("R", "L", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrsm_("R", "L", "C", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrsm_("R", "L", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrsm_("L", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrsm_("L", "U", "C", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrsm_("L", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrsm_("R", "U", "N", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrsm_("R", "U", "C", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrsm_("R", "U", "T", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrsm_("L", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrsm_("L", "L", "C", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrsm_("L", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrsm_("R", "L", "N", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrsm_("R", "L", "C", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrsm_("R", "L", "T", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrsm_("L", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrsm_("L", "U", "C", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrsm_("L", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrsm_("R", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrsm_("R", "U", "C", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrsm_("R", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrsm_("L", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrsm_("L", "L", "C", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrsm_("L", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrsm_("R", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrsm_("R", "L", "C", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrsm_("R", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L100;
+L60:
+ infoc_1.infot = 1;
+ cherk_("/", "N", &c__0, &c__0, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ cherk_("U", "T", &c__0, &c__0, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ cherk_("U", "N", &c_n1, &c__0, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ cherk_("U", "C", &c_n1, &c__0, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ cherk_("L", "N", &c_n1, &c__0, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ cherk_("L", "C", &c_n1, &c__0, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ cherk_("U", "N", &c__0, &c_n1, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ cherk_("U", "C", &c__0, &c_n1, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ cherk_("L", "N", &c__0, &c_n1, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ cherk_("L", "C", &c__0, &c_n1, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ cherk_("U", "N", &c__2, &c__0, &ralpha, a, &c__1, &rbeta, c__, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ cherk_("U", "C", &c__0, &c__2, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ cherk_("L", "N", &c__2, &c__0, &ralpha, a, &c__1, &rbeta, c__, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ cherk_("L", "C", &c__0, &c__2, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ cherk_("U", "N", &c__2, &c__0, &ralpha, a, &c__2, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ cherk_("U", "C", &c__2, &c__0, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ cherk_("L", "N", &c__2, &c__0, &ralpha, a, &c__2, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ cherk_("L", "C", &c__2, &c__0, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L100;
+L70:
+ infoc_1.infot = 1;
+ csyrk_("/", "N", &c__0, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ csyrk_("U", "C", &c__0, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ csyrk_("U", "N", &c_n1, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ csyrk_("U", "T", &c_n1, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ csyrk_("L", "N", &c_n1, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ csyrk_("L", "T", &c_n1, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ csyrk_("U", "N", &c__0, &c_n1, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ csyrk_("U", "T", &c__0, &c_n1, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ csyrk_("L", "N", &c__0, &c_n1, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ csyrk_("L", "T", &c__0, &c_n1, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ csyrk_("U", "N", &c__2, &c__0, &alpha, a, &c__1, &beta, c__, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ csyrk_("U", "T", &c__0, &c__2, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ csyrk_("L", "N", &c__2, &c__0, &alpha, a, &c__1, &beta, c__, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ csyrk_("L", "T", &c__0, &c__2, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ csyrk_("U", "N", &c__2, &c__0, &alpha, a, &c__2, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ csyrk_("U", "T", &c__2, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ csyrk_("L", "N", &c__2, &c__0, &alpha, a, &c__2, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ csyrk_("L", "T", &c__2, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L100;
+L80:
+ infoc_1.infot = 1;
+ cher2k_("/", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ cher2k_("U", "T", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ cher2k_("U", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ cher2k_("U", "C", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ cher2k_("L", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ cher2k_("L", "C", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ cher2k_("U", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ cher2k_("U", "C", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ cher2k_("L", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ cher2k_("L", "C", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ cher2k_("U", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ cher2k_("U", "C", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ cher2k_("L", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ cher2k_("L", "C", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ cher2k_("U", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &rbeta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ cher2k_("U", "C", &c__0, &c__2, &alpha, a, &c__2, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ cher2k_("L", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &rbeta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ cher2k_("L", "C", &c__0, &c__2, &alpha, a, &c__2, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ cher2k_("U", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ cher2k_("U", "C", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ cher2k_("L", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ cher2k_("L", "C", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L100;
+L90:
+ infoc_1.infot = 1;
+ csyr2k_("/", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ csyr2k_("U", "C", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ csyr2k_("U", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ csyr2k_("U", "T", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ csyr2k_("L", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ csyr2k_("L", "T", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ csyr2k_("U", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ csyr2k_("U", "T", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ csyr2k_("L", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ csyr2k_("L", "T", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ csyr2k_("U", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ csyr2k_("U", "T", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ csyr2k_("L", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ csyr2k_("L", "T", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ csyr2k_("U", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ csyr2k_("U", "T", &c__0, &c__2, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ csyr2k_("L", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ csyr2k_("L", "T", &c__0, &c__2, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ csyr2k_("U", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ csyr2k_("U", "T", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ csyr2k_("L", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ csyr2k_("L", "T", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+
+L100:
+ if (infoc_1.ok) {
+ io___360.ciunit = *nout;
+ s_wsfe(&io___360);
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ } else {
+ io___361.ciunit = *nout;
+ s_wsfe(&io___361);
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ }
+ return 0;
+
+
+/* End of CCHKE. */
+
+} /* cchke_ */
+
+/* Subroutine */ int cmake_(char *type__, char *uplo, char *diag, integer *m,
+ integer *n, complex *a, integer *nmax, complex *aa, integer *lda,
+ logical *reset, complex *transl, ftnlen type_len, ftnlen uplo_len,
+ ftnlen diag_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ real r__1;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, jj;
+ logical gen, her, tri, sym;
+ extern /* Complex */ VOID cbeg_(complex *, logical *);
+ integer ibeg, iend;
+ logical unit, lower, upper;
+
+
+/* Generates values for an M by N matrix A. */
+/* Stores the values in the array AA in the data structure required */
+/* by the routine, with unwanted elements set to rogue value. */
+
+/* TYPE is 'GE', 'HE', 'SY' or 'TR'. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. External Functions .. */
+/* .. Intrinsic Functions .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --aa;
+
+ /* Function Body */
+ gen = s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0;
+ her = s_cmp(type__, "HE", (ftnlen)2, (ftnlen)2) == 0;
+ sym = s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0;
+ tri = s_cmp(type__, "TR", (ftnlen)2, (ftnlen)2) == 0;
+ upper = (her || sym || tri) && *(unsigned char *)uplo == 'U';
+ lower = (her || sym || tri) && *(unsigned char *)uplo == 'L';
+ unit = tri && *(unsigned char *)diag == 'U';
+
+/* Generate data in array A. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (gen || upper && i__ <= j || lower && i__ >= j) {
+ i__3 = i__ + j * a_dim1;
+ cbeg_(&q__2, reset);
+ q__1.r = q__2.r + transl->r, q__1.i = q__2.i + transl->i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ if (i__ != j) {
+/* Set some elements to zero */
+ if (*n > 3 && j == *n / 2) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ }
+ if (her) {
+ i__3 = j + i__ * a_dim1;
+ r_cnjg(&q__1, &a[i__ + j * a_dim1]);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ } else if (sym) {
+ i__3 = j + i__ * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
+ } else if (tri) {
+ i__3 = j + i__ * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ }
+ }
+ }
+/* L10: */
+ }
+ if (her) {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ r__1 = a[i__3].r;
+ q__1.r = r__1, q__1.i = 0.f;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ }
+ if (tri) {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ q__1.r = a[i__3].r + 1.f, q__1.i = a[i__3].i + 0.f;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ }
+ if (unit) {
+ i__2 = j + j * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+ }
+/* L20: */
+ }
+
+/* Store elements in array AS in data structure required by routine. */
+
+ if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ i__4 = i__ + j * a_dim1;
+ aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
+/* L30: */
+ }
+ i__2 = *lda;
+ for (i__ = *m + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ aa[i__3].r = -1e10f, aa[i__3].i = 1e10f;
+/* L40: */
+ }
+/* L50: */
+ }
+ } else if (s_cmp(type__, "HE", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
+ "SY", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, "TR", (ftnlen)
+ 2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ ibeg = 1;
+ if (unit) {
+ iend = j - 1;
+ } else {
+ iend = j;
+ }
+ } else {
+ if (unit) {
+ ibeg = j + 1;
+ } else {
+ ibeg = j;
+ }
+ iend = *n;
+ }
+ i__2 = ibeg - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ aa[i__3].r = -1e10f, aa[i__3].i = 1e10f;
+/* L60: */
+ }
+ i__2 = iend;
+ for (i__ = ibeg; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ i__4 = i__ + j * a_dim1;
+ aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
+/* L70: */
+ }
+ i__2 = *lda;
+ for (i__ = iend + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ aa[i__3].r = -1e10f, aa[i__3].i = 1e10f;
+/* L80: */
+ }
+ if (her) {
+ jj = j + (j - 1) * *lda;
+ i__2 = jj;
+ i__3 = jj;
+ r__1 = aa[i__3].r;
+ q__1.r = r__1, q__1.i = -1e10f;
+ aa[i__2].r = q__1.r, aa[i__2].i = q__1.i;
+ }
+/* L90: */
+ }
+ }
+ return 0;
+
+/* End of CMAKE. */
+
+} /* cmake_ */
+
+/* Subroutine */ int cmmch_(char *transa, char *transb, integer *m, integer *
+ n, integer *kk, complex *alpha, complex *a, integer *lda, complex *b,
+ integer *ldb, complex *beta, complex *c__, integer *ldc, complex *ct,
+ real *g, complex *cc, integer *ldcc, real *eps, real *err, logical *
+ fatal, integer *nout, logical *mv, ftnlen transa_len, ftnlen
+ transb_len)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
+ " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 "
+ " EXPECTED RE\002,\002SULT COMPUTED R"
+ "ESULT\002)";
+ static char fmt_9998[] = "(1x,i7,2(\002 (\002,g15.6,\002,\002,g15.6,"
+ "\002)\002))";
+ static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1,
+ cc_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+ real r__1, r__2, r__3, r__4, r__5, r__6;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void r_cnjg(complex *, complex *);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k;
+ real erri;
+ logical trana, tranb, ctrana, ctranb;
+
+ /* Fortran I/O blocks */
+ static cilist io___382 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___383 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___384 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___385 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* Checks the results of the computational tests. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Intrinsic Functions .. */
+/* .. Statement Functions .. */
+/* .. Statement Function definitions .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --ct;
+ --g;
+ cc_dim1 = *ldcc;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+
+ /* Function Body */
+ trana = *(unsigned char *)transa == 'T' || *(unsigned char *)transa ==
+ 'C';
+ tranb = *(unsigned char *)transb == 'T' || *(unsigned char *)transb ==
+ 'C';
+ ctrana = *(unsigned char *)transa == 'C';
+ ctranb = *(unsigned char *)transb == 'C';
+
+/* Compute expected result, one column at a time, in CT using data */
+/* in A, B and C. */
+/* Compute gauges in G. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ ct[i__3].r = 0.f, ct[i__3].i = 0.f;
+ g[i__] = 0.f;
+/* L10: */
+ }
+ if (! trana && ! tranb) {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ i__6 = i__ + k * a_dim1;
+ i__7 = k + j * b_dim1;
+ q__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7].i,
+ q__2.i = a[i__6].r * b[i__7].i + a[i__6].i * b[
+ i__7].r;
+ q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i +
+ q__2.i;
+ ct[i__4].r = q__1.r, ct[i__4].i = q__1.i;
+ i__4 = i__ + k * a_dim1;
+ i__5 = k + j * b_dim1;
+ g[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + k * a_dim1]), dabs(r__2))) * ((
+ r__3 = b[i__5].r, dabs(r__3)) + (r__4 = r_imag(&b[
+ k + j * b_dim1]), dabs(r__4)));
+/* L20: */
+ }
+/* L30: */
+ }
+ } else if (trana && ! tranb) {
+ if (ctrana) {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ r_cnjg(&q__3, &a[k + i__ * a_dim1]);
+ i__6 = k + j * b_dim1;
+ q__2.r = q__3.r * b[i__6].r - q__3.i * b[i__6].i,
+ q__2.i = q__3.r * b[i__6].i + q__3.i * b[i__6]
+ .r;
+ q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i +
+ q__2.i;
+ ct[i__4].r = q__1.r, ct[i__4].i = q__1.i;
+ i__4 = k + i__ * a_dim1;
+ i__5 = k + j * b_dim1;
+ g[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[k + i__ * a_dim1]), dabs(r__2))) * (
+ (r__3 = b[i__5].r, dabs(r__3)) + (r__4 =
+ r_imag(&b[k + j * b_dim1]), dabs(r__4)));
+/* L40: */
+ }
+/* L50: */
+ }
+ } else {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ i__6 = k + i__ * a_dim1;
+ i__7 = k + j * b_dim1;
+ q__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7]
+ .i, q__2.i = a[i__6].r * b[i__7].i + a[i__6]
+ .i * b[i__7].r;
+ q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i +
+ q__2.i;
+ ct[i__4].r = q__1.r, ct[i__4].i = q__1.i;
+ i__4 = k + i__ * a_dim1;
+ i__5 = k + j * b_dim1;
+ g[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[k + i__ * a_dim1]), dabs(r__2))) * (
+ (r__3 = b[i__5].r, dabs(r__3)) + (r__4 =
+ r_imag(&b[k + j * b_dim1]), dabs(r__4)));
+/* L60: */
+ }
+/* L70: */
+ }
+ }
+ } else if (! trana && tranb) {
+ if (ctranb) {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ i__6 = i__ + k * a_dim1;
+ r_cnjg(&q__3, &b[j + k * b_dim1]);
+ q__2.r = a[i__6].r * q__3.r - a[i__6].i * q__3.i,
+ q__2.i = a[i__6].r * q__3.i + a[i__6].i *
+ q__3.r;
+ q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i +
+ q__2.i;
+ ct[i__4].r = q__1.r, ct[i__4].i = q__1.i;
+ i__4 = i__ + k * a_dim1;
+ i__5 = j + k * b_dim1;
+ g[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + k * a_dim1]), dabs(r__2))) * (
+ (r__3 = b[i__5].r, dabs(r__3)) + (r__4 =
+ r_imag(&b[j + k * b_dim1]), dabs(r__4)));
+/* L80: */
+ }
+/* L90: */
+ }
+ } else {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ i__6 = i__ + k * a_dim1;
+ i__7 = j + k * b_dim1;
+ q__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7]
+ .i, q__2.i = a[i__6].r * b[i__7].i + a[i__6]
+ .i * b[i__7].r;
+ q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i +
+ q__2.i;
+ ct[i__4].r = q__1.r, ct[i__4].i = q__1.i;
+ i__4 = i__ + k * a_dim1;
+ i__5 = j + k * b_dim1;
+ g[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + k * a_dim1]), dabs(r__2))) * (
+ (r__3 = b[i__5].r, dabs(r__3)) + (r__4 =
+ r_imag(&b[j + k * b_dim1]), dabs(r__4)));
+/* L100: */
+ }
+/* L110: */
+ }
+ }
+ } else if (trana && tranb) {
+ if (ctrana) {
+ if (ctranb) {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ r_cnjg(&q__3, &a[k + i__ * a_dim1]);
+ r_cnjg(&q__4, &b[j + k * b_dim1]);
+ q__2.r = q__3.r * q__4.r - q__3.i * q__4.i,
+ q__2.i = q__3.r * q__4.i + q__3.i *
+ q__4.r;
+ q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i
+ + q__2.i;
+ ct[i__4].r = q__1.r, ct[i__4].i = q__1.i;
+ i__4 = k + i__ * a_dim1;
+ i__5 = j + k * b_dim1;
+ g[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2
+ = r_imag(&a[k + i__ * a_dim1]), dabs(r__2)
+ )) * ((r__3 = b[i__5].r, dabs(r__3)) + (
+ r__4 = r_imag(&b[j + k * b_dim1]), dabs(
+ r__4)));
+/* L120: */
+ }
+/* L130: */
+ }
+ } else {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ r_cnjg(&q__3, &a[k + i__ * a_dim1]);
+ i__6 = j + k * b_dim1;
+ q__2.r = q__3.r * b[i__6].r - q__3.i * b[i__6].i,
+ q__2.i = q__3.r * b[i__6].i + q__3.i * b[
+ i__6].r;
+ q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i
+ + q__2.i;
+ ct[i__4].r = q__1.r, ct[i__4].i = q__1.i;
+ i__4 = k + i__ * a_dim1;
+ i__5 = j + k * b_dim1;
+ g[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2
+ = r_imag(&a[k + i__ * a_dim1]), dabs(r__2)
+ )) * ((r__3 = b[i__5].r, dabs(r__3)) + (
+ r__4 = r_imag(&b[j + k * b_dim1]), dabs(
+ r__4)));
+/* L140: */
+ }
+/* L150: */
+ }
+ }
+ } else {
+ if (ctranb) {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ i__6 = k + i__ * a_dim1;
+ r_cnjg(&q__3, &b[j + k * b_dim1]);
+ q__2.r = a[i__6].r * q__3.r - a[i__6].i * q__3.i,
+ q__2.i = a[i__6].r * q__3.i + a[i__6].i *
+ q__3.r;
+ q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i
+ + q__2.i;
+ ct[i__4].r = q__1.r, ct[i__4].i = q__1.i;
+ i__4 = k + i__ * a_dim1;
+ i__5 = j + k * b_dim1;
+ g[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2
+ = r_imag(&a[k + i__ * a_dim1]), dabs(r__2)
+ )) * ((r__3 = b[i__5].r, dabs(r__3)) + (
+ r__4 = r_imag(&b[j + k * b_dim1]), dabs(
+ r__4)));
+/* L160: */
+ }
+/* L170: */
+ }
+ } else {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ i__6 = k + i__ * a_dim1;
+ i__7 = j + k * b_dim1;
+ q__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[
+ i__7].i, q__2.i = a[i__6].r * b[i__7].i +
+ a[i__6].i * b[i__7].r;
+ q__1.r = ct[i__5].r + q__2.r, q__1.i = ct[i__5].i
+ + q__2.i;
+ ct[i__4].r = q__1.r, ct[i__4].i = q__1.i;
+ i__4 = k + i__ * a_dim1;
+ i__5 = j + k * b_dim1;
+ g[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2
+ = r_imag(&a[k + i__ * a_dim1]), dabs(r__2)
+ )) * ((r__3 = b[i__5].r, dabs(r__3)) + (
+ r__4 = r_imag(&b[j + k * b_dim1]), dabs(
+ r__4)));
+/* L180: */
+ }
+/* L190: */
+ }
+ }
+ }
+ }
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ q__2.r = alpha->r * ct[i__4].r - alpha->i * ct[i__4].i, q__2.i =
+ alpha->r * ct[i__4].i + alpha->i * ct[i__4].r;
+ i__5 = i__ + j * c_dim1;
+ q__3.r = beta->r * c__[i__5].r - beta->i * c__[i__5].i, q__3.i =
+ beta->r * c__[i__5].i + beta->i * c__[i__5].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ ct[i__3].r = q__1.r, ct[i__3].i = q__1.i;
+ i__3 = i__ + j * c_dim1;
+ g[i__] = ((r__1 = alpha->r, dabs(r__1)) + (r__2 = r_imag(alpha),
+ dabs(r__2))) * g[i__] + ((r__3 = beta->r, dabs(r__3)) + (
+ r__4 = r_imag(beta), dabs(r__4))) * ((r__5 = c__[i__3].r,
+ dabs(r__5)) + (r__6 = r_imag(&c__[i__ + j * c_dim1]),
+ dabs(r__6)));
+/* L200: */
+ }
+
+/* Compute the error ratio for this result. */
+
+ *err = 0.f;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__ + j * cc_dim1;
+ q__2.r = ct[i__3].r - cc[i__4].r, q__2.i = ct[i__3].i - cc[i__4]
+ .i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ erri = ((r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1), dabs(
+ r__2))) / *eps;
+ if (g[i__] != 0.f) {
+ erri /= g[i__];
+ }
+ *err = dmax(*err,erri);
+ if (*err * sqrt(*eps) >= 1.f) {
+ goto L230;
+ }
+/* L210: */
+ }
+
+/* L220: */
+ }
+
+/* If the loop completes, all results are at least half accurate. */
+ goto L250;
+
+/* Report fatal error. */
+
+L230:
+ *fatal = TRUE_;
+ io___382.ciunit = *nout;
+ s_wsfe(&io___382);
+ e_wsfe();
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*mv) {
+ io___383.ciunit = *nout;
+ s_wsfe(&io___383);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(real));
+ do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ } else {
+ io___384.ciunit = *nout;
+ s_wsfe(&io___384);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real)
+ );
+ do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+/* L240: */
+ }
+ if (*n > 1) {
+ io___385.ciunit = *nout;
+ s_wsfe(&io___385);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L250:
+ return 0;
+
+
+/* End of CMMCH. */
+
+} /* cmmch_ */
+
+logical lce_(complex *ri, complex *rj, integer *lr)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ logical ret_val;
+
+ /* Local variables */
+ integer i__;
+
+
+/* Tests if two arrays are identical. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ --rj;
+ --ri;
+
+ /* Function Body */
+ i__1 = *lr;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ if (ri[i__2].r != rj[i__3].r || ri[i__2].i != rj[i__3].i) {
+ goto L20;
+ }
+/* L10: */
+ }
+ ret_val = TRUE_;
+ goto L30;
+L20:
+ ret_val = FALSE_;
+L30:
+ return ret_val;
+
+/* End of LCE. */
+
+} /* lce_ */
+
+logical lceres_(char *type__, char *uplo, integer *m, integer *n, complex *aa,
+ complex *as, integer *lda, ftnlen type_len, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2, i__3, i__4;
+ logical ret_val;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer i__, j, ibeg, iend;
+ logical upper;
+
+
+/* Tests if selected elements in two arrays are equal. */
+
+/* TYPE is 'GE' or 'HE' or 'SY'. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ as_dim1 = *lda;
+ as_offset = 1 + as_dim1;
+ as -= as_offset;
+ aa_dim1 = *lda;
+ aa_offset = 1 + aa_dim1;
+ aa -= aa_offset;
+
+ /* Function Body */
+ upper = *(unsigned char *)uplo == 'U';
+ if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *lda;
+ for (i__ = *m + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * aa_dim1;
+ i__4 = i__ + j * as_dim1;
+ if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) {
+ goto L70;
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (s_cmp(type__, "HE", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
+ "SY", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ ibeg = 1;
+ iend = j;
+ } else {
+ ibeg = j;
+ iend = *n;
+ }
+ i__2 = ibeg - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * aa_dim1;
+ i__4 = i__ + j * as_dim1;
+ if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) {
+ goto L70;
+ }
+/* L30: */
+ }
+ i__2 = *lda;
+ for (i__ = iend + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * aa_dim1;
+ i__4 = i__ + j * as_dim1;
+ if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) {
+ goto L70;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+/* L60: */
+ ret_val = TRUE_;
+ goto L80;
+L70:
+ ret_val = FALSE_;
+L80:
+ return ret_val;
+
+/* End of LCERES. */
+
+} /* lceres_ */
+
+/* Complex */ VOID cbeg_(complex * ret_val, logical *reset)
+{
+ /* System generated locals */
+ real r__1, r__2;
+ complex q__1;
+
+ /* Local variables */
+ static integer i__, j, ic, mi, mj;
+
+
+/* Generates complex numbers as pairs of random numbers uniformly */
+/* distributed between -0.5 and 0.5. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Local Scalars .. */
+/* .. Save statement .. */
+/* .. Intrinsic Functions .. */
+/* .. Executable Statements .. */
+ if (*reset) {
+/* Initialize local variables. */
+ mi = 891;
+ mj = 457;
+ i__ = 7;
+ j = 7;
+ ic = 0;
+ *reset = FALSE_;
+ }
+
+/* The sequence of values of I or J is bounded between 1 and 999. */
+/* If initial I or J = 1,2,3,6,7 or 9, the period will be 50. */
+/* If initial I or J = 4 or 8, the period will be 25. */
+/* If initial I or J = 5, the period will be 10. */
+/* IC is used to break up the period by skipping 1 value of I or J */
+/* in 6. */
+
+ ++ic;
+L10:
+ i__ *= mi;
+ j *= mj;
+ i__ -= i__ / 1000 * 1000;
+ j -= j / 1000 * 1000;
+ if (ic >= 5) {
+ ic = 0;
+ goto L10;
+ }
+ r__1 = (i__ - 500) / 1001.f;
+ r__2 = (j - 500) / 1001.f;
+ q__1.r = r__1, q__1.i = r__2;
+ ret_val->r = q__1.r, ret_val->i = q__1.i;
+ return ;
+
+/* End of CBEG. */
+
+} /* cbeg_ */
+
+doublereal sdiff_(real *x, real *y)
+{
+ /* System generated locals */
+ real ret_val;
+
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Executable Statements .. */
+ ret_val = *x - *y;
+ return ret_val;
+
+/* End of SDIFF. */
+
+} /* sdiff_ */
+
+/* Subroutine */ int chkxer_(char *srnamt, integer *infot, integer *nout,
+ logical *lerr, logical *ok)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ***** ILLEGAL VALUE OF PARAMETER NUMBER"
+ " \002,i2,\002 NOT D\002,\002ETECTED BY \002,a6,\002 *****\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___397 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* Tests whether XERBLA has detected an error when it should. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Executable Statements .. */
+ if (! (*lerr)) {
+ io___397.ciunit = *nout;
+ s_wsfe(&io___397);
+ do_fio(&c__1, (char *)&(*infot), (ftnlen)sizeof(integer));
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ *ok = FALSE_;
+ }
+ *lerr = FALSE_;
+ return 0;
+
+
+/* End of CHKXER. */
+
+} /* chkxer_ */
+
+/* Subroutine */ int xerbla_(char *srname, integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* XERBLA WAS CALLED WITH INFO ="
+ " \002,i6,\002 INSTEAD\002,\002 OF \002,i2,\002 *******\002)";
+ static char fmt_9997[] = "(\002 ******* XERBLA WAS CALLED WITH INFO ="
+ " \002,i6,\002 *******\002)";
+ static char fmt_9998[] = "(\002 ******* XERBLA WAS CALLED WITH SRNAME ="
+ " \002,a6,\002 INSTE\002,\002AD OF \002,a6,\002 *******\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Fortran I/O blocks */
+ static cilist io___398 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___399 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___400 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* This is a special version of XERBLA to be used only as part of */
+/* the test program for testing error exits from the Level 3 BLAS */
+/* routines. */
+
+/* XERBLA is an error handler for the Level 3 BLAS routines. */
+
+/* It is called by the Level 3 BLAS routines if an input parameter is */
+/* invalid. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+ infoc_2.lerr = TRUE_;
+ if (*info != infoc_2.infot) {
+ if (infoc_2.infot != 0) {
+ io___398.ciunit = infoc_2.nout;
+ s_wsfe(&io___398);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&infoc_2.infot, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___399.ciunit = infoc_2.nout;
+ s_wsfe(&io___399);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ infoc_2.ok = FALSE_;
+ }
+ if (s_cmp(srname, srnamc_1.srnamt, (ftnlen)6, (ftnlen)6) != 0) {
+ io___400.ciunit = infoc_2.nout;
+ s_wsfe(&io___400);
+ do_fio(&c__1, srname, (ftnlen)6);
+ do_fio(&c__1, srnamc_1.srnamt, (ftnlen)6);
+ e_wsfe();
+ infoc_2.ok = FALSE_;
+ }
+ return 0;
+
+
+/* End of XERBLA */
+
+} /* xerbla_ */
+
+/* Main program alias */ int cblat3_ () { MAIN__ (); return 0; }
diff --git a/BLAS/TESTING/dblat1.c b/BLAS/TESTING/dblat1.c
new file mode 100644
index 0000000..c26e244
--- /dev/null
+++ b/BLAS/TESTING/dblat1.c
@@ -0,0 +1,876 @@
+/* dblat1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer icase, n, incx, incy, mode;
+ logical pass;
+} combla_;
+
+#define combla_1 combla_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__9 = 9;
+static doublereal c_b34 = 1.;
+static integer c__5 = 5;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Initialized data */
+
+ static doublereal sfac = 9.765625e-4;
+
+ /* Format strings */
+ static char fmt_99999[] = "(\002 Real BLAS Test Program Results\002,/1x)";
+ static char fmt_99998[] = "(\002 ----"
+ "- PASS -----\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), e_wsfe(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+
+ /* Local variables */
+ integer ic;
+ extern /* Subroutine */ int check0_(doublereal *), check1_(doublereal *),
+ check2_(doublereal *), check3_(doublereal *), header_(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___2 = { 0, 6, 0, fmt_99999, 0 };
+ static cilist io___4 = { 0, 6, 0, fmt_99998, 0 };
+
+
+/* Test program for the DOUBLE PRECISION Level 1 BLAS. */
+/* Based upon the original BLAS test routine together with: */
+/* F06EAF Example Program Text */
+/* .. Parameters .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. External Subroutines .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+ s_wsfe(&io___2);
+ e_wsfe();
+ for (ic = 1; ic <= 10; ++ic) {
+ combla_1.icase = ic;
+ header_();
+
+/* .. Initialize PASS, INCX, INCY, and MODE for a new case. .. */
+/* .. the value 9999 for INCX, INCY or MODE will appear in the .. */
+/* .. detailed output, if any, for cases that do not involve .. */
+/* .. these parameters .. */
+
+ combla_1.pass = TRUE_;
+ combla_1.incx = 9999;
+ combla_1.incy = 9999;
+ combla_1.mode = 9999;
+ if (combla_1.icase == 3) {
+ check0_(&sfac);
+ } else if (combla_1.icase == 7 || combla_1.icase == 8 ||
+ combla_1.icase == 9 || combla_1.icase == 10) {
+ check1_(&sfac);
+ } else if (combla_1.icase == 1 || combla_1.icase == 2 ||
+ combla_1.icase == 5 || combla_1.icase == 6) {
+ check2_(&sfac);
+ } else if (combla_1.icase == 4) {
+ check3_(&sfac);
+ }
+/* -- Print */
+ if (combla_1.pass) {
+ s_wsfe(&io___4);
+ e_wsfe();
+ }
+/* L20: */
+ }
+ s_stop("", (ftnlen)0);
+
+ return 0;
+} /* MAIN__ */
+
+/* Subroutine */ int header_(void)
+{
+ /* Initialized data */
+
+ static char l[6*10] = " DDOT " "DAXPY " "DROTG " " DROT " "DCOPY " "DSWA"
+ "P " "DNRM2 " "DASUM " "DSCAL " "IDAMAX";
+
+ /* Format strings */
+ static char fmt_99999[] = "(/\002 Test of subprogram number\002,i3,12x,a"
+ "6)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 6, 0, fmt_99999, 0 };
+
+
+/* .. Parameters .. */
+/* .. Scalars in Common .. */
+/* .. Local Arrays .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+ s_wsfe(&io___6);
+ do_fio(&c__1, (char *)&combla_1.icase, (ftnlen)sizeof(integer));
+ do_fio(&c__1, l + (0 + (0 + (combla_1.icase - 1) * 6)), (ftnlen)6);
+ e_wsfe();
+ return 0;
+
+} /* header_ */
+
+/* Subroutine */ int check0_(doublereal *sfac)
+{
+ /* Initialized data */
+
+ static doublereal ds1[8] = { .8,.6,.8,-.6,.8,0.,1.,0. };
+ static doublereal datrue[8] = { .5,.5,.5,-.5,-.5,0.,1.,1. };
+ static doublereal dbtrue[8] = { 0.,.6,0.,-.6,0.,0.,1.,0. };
+ static doublereal da1[8] = { .3,.4,-.3,-.4,-.3,0.,0.,1. };
+ static doublereal db1[8] = { .4,.3,.4,.3,-.4,0.,1.,0. };
+ static doublereal dc1[8] = { .6,.8,-.6,.8,.6,1.,0.,1. };
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_wsle(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+
+ /* Local variables */
+ integer k;
+ doublereal sa, sb, sc, ss;
+ extern /* Subroutine */ int drotg_(doublereal *, doublereal *, doublereal
+ *, doublereal *), stest1_(doublereal *, doublereal *, doublereal *
+ , doublereal *);
+
+ /* Fortran I/O blocks */
+ static cilist io___18 = { 0, 6, 0, 0, 0 };
+
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Subroutines .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+
+/* Compute true values which cannot be prestored */
+/* in decimal notation */
+
+ dbtrue[0] = 1.6666666666666667;
+ dbtrue[2] = -1.6666666666666667;
+ dbtrue[4] = 1.6666666666666667;
+
+ for (k = 1; k <= 8; ++k) {
+/* .. Set N=K for identification in output if any .. */
+ combla_1.n = k;
+ if (combla_1.icase == 3) {
+/* .. DROTG .. */
+ if (k > 8) {
+ goto L40;
+ }
+ sa = da1[k - 1];
+ sb = db1[k - 1];
+ drotg_(&sa, &sb, &sc, &ss);
+ stest1_(&sa, &datrue[k - 1], &datrue[k - 1], sfac);
+ stest1_(&sb, &dbtrue[k - 1], &dbtrue[k - 1], sfac);
+ stest1_(&sc, &dc1[k - 1], &dc1[k - 1], sfac);
+ stest1_(&ss, &ds1[k - 1], &ds1[k - 1], sfac);
+ } else {
+ s_wsle(&io___18);
+ do_lio(&c__9, &c__1, " Shouldn't be here in CHECK0", (ftnlen)28);
+ e_wsle();
+ s_stop("", (ftnlen)0);
+ }
+/* L20: */
+ }
+L40:
+ return 0;
+} /* check0_ */
+
+/* Subroutine */ int check1_(doublereal *sfac)
+{
+ /* Initialized data */
+
+ static doublereal sa[10] = { .3,-1.,0.,1.,.3,.3,.3,.3,.3,.3 };
+ static doublereal dv[80] /* was [8][5][2] */ = { .1,2.,2.,2.,2.,2.,2.,
+ 2.,.3,3.,3.,3.,3.,3.,3.,3.,.3,-.4,4.,4.,4.,4.,4.,4.,.2,-.6,.3,5.,
+ 5.,5.,5.,5.,.1,-.3,.5,-.1,6.,6.,6.,6.,.1,8.,8.,8.,8.,8.,8.,8.,.3,
+ 9.,9.,9.,9.,9.,9.,9.,.3,2.,-.4,2.,2.,2.,2.,2.,.2,3.,-.6,5.,.3,2.,
+ 2.,2.,.1,4.,-.3,6.,-.5,7.,-.1,3. };
+ static doublereal dtrue1[5] = { 0.,.3,.5,.7,.6 };
+ static doublereal dtrue3[5] = { 0.,.3,.7,1.1,1. };
+ static doublereal dtrue5[80] /* was [8][5][2] */ = { .1,2.,2.,2.,
+ 2.,2.,2.,2.,-.3,3.,3.,3.,3.,3.,3.,3.,0.,0.,4.,4.,4.,4.,4.,4.,.2,
+ -.6,.3,5.,5.,5.,5.,5.,.03,-.09,.15,-.03,6.,6.,6.,6.,.1,8.,8.,8.,
+ 8.,8.,8.,8.,.09,9.,9.,9.,9.,9.,9.,9.,.09,2.,-.12,2.,2.,2.,2.,2.,
+ .06,3.,-.18,5.,.09,2.,2.,2.,.03,4.,-.09,6.,-.15,7.,-.03,3. };
+ static integer itrue2[5] = { 0,1,2,2,3 };
+
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_wsle(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ doublereal sx[8];
+ integer np1, len;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal stemp[1], strue[8];
+ extern /* Subroutine */ int stest_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *), itest1_(integer *, integer *),
+ stest1_(doublereal *, doublereal *, doublereal *, doublereal *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___31 = { 0, 6, 0, 0, 0 };
+
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+ for (combla_1.incx = 1; combla_1.incx <= 2; ++combla_1.incx) {
+ for (np1 = 1; np1 <= 5; ++np1) {
+ combla_1.n = np1 - 1;
+ len = max(combla_1.n,1) << 1;
+/* .. Set vector arguments .. */
+ i__1 = len;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sx[i__ - 1] = dv[i__ + (np1 + combla_1.incx * 5 << 3) - 49];
+/* L20: */
+ }
+
+ if (combla_1.icase == 7) {
+/* .. DNRM2 .. */
+ stemp[0] = dtrue1[np1 - 1];
+ d__1 = dnrm2_(&combla_1.n, sx, &combla_1.incx);
+ stest1_(&d__1, stemp, stemp, sfac);
+ } else if (combla_1.icase == 8) {
+/* .. DASUM .. */
+ stemp[0] = dtrue3[np1 - 1];
+ d__1 = dasum_(&combla_1.n, sx, &combla_1.incx);
+ stest1_(&d__1, stemp, stemp, sfac);
+ } else if (combla_1.icase == 9) {
+/* .. DSCAL .. */
+ dscal_(&combla_1.n, &sa[(combla_1.incx - 1) * 5 + np1 - 1],
+ sx, &combla_1.incx);
+ i__1 = len;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ strue[i__ - 1] = dtrue5[i__ + (np1 + combla_1.incx * 5 <<
+ 3) - 49];
+/* L40: */
+ }
+ stest_(&len, sx, strue, strue, sfac);
+ } else if (combla_1.icase == 10) {
+/* .. IDAMAX .. */
+ i__1 = idamax_(&combla_1.n, sx, &combla_1.incx);
+ itest1_(&i__1, &itrue2[np1 - 1]);
+ } else {
+ s_wsle(&io___31);
+ do_lio(&c__9, &c__1, " Shouldn't be here in CHECK1", (ftnlen)
+ 28);
+ e_wsle();
+ s_stop("", (ftnlen)0);
+ }
+/* L60: */
+ }
+/* L80: */
+ }
+ return 0;
+} /* check1_ */
+
+/* Subroutine */ int check2_(doublereal *sfac)
+{
+ /* Initialized data */
+
+ static doublereal sa = .3;
+ static integer incxs[4] = { 1,2,-2,-1 };
+ static integer incys[4] = { 1,-2,1,-2 };
+ static integer lens[8] /* was [4][2] */ = { 1,1,2,4,1,1,3,7 };
+ static integer ns[4] = { 0,1,2,4 };
+ static doublereal dx1[7] = { .6,.1,-.5,.8,.9,-.3,-.4 };
+ static doublereal dy1[7] = { .5,-.9,.3,.7,-.6,.2,.8 };
+ static doublereal dt7[16] /* was [4][4] */ = { 0.,.3,.21,.62,0.,.3,-.07,
+ .85,0.,.3,-.79,-.74,0.,.3,.33,1.27 };
+ static doublereal dt8[112] /* was [7][4][4] */ = { .5,0.,0.,0.,0.,0.,0.,
+ .68,0.,0.,0.,0.,0.,0.,.68,-.87,0.,0.,0.,0.,0.,.68,-.87,.15,.94,0.,
+ 0.,0.,.5,0.,0.,0.,0.,0.,0.,.68,0.,0.,0.,0.,0.,0.,.35,-.9,.48,0.,
+ 0.,0.,0.,.38,-.9,.57,.7,-.75,.2,.98,.5,0.,0.,0.,0.,0.,0.,.68,0.,
+ 0.,0.,0.,0.,0.,.35,-.72,0.,0.,0.,0.,0.,.38,-.63,.15,.88,0.,0.,0.,
+ .5,0.,0.,0.,0.,0.,0.,.68,0.,0.,0.,0.,0.,0.,.68,-.9,.33,0.,0.,0.,
+ 0.,.68,-.9,.33,.7,-.75,.2,1.04 };
+ static doublereal dt10x[112] /* was [7][4][4] */ = { .6,0.,0.,0.,
+ 0.,0.,0.,.5,0.,0.,0.,0.,0.,0.,.5,-.9,0.,0.,0.,0.,0.,.5,-.9,.3,.7,
+ 0.,0.,0.,.6,0.,0.,0.,0.,0.,0.,.5,0.,0.,0.,0.,0.,0.,.3,.1,.5,0.,0.,
+ 0.,0.,.8,.1,-.6,.8,.3,-.3,.5,.6,0.,0.,0.,0.,0.,0.,.5,0.,0.,0.,0.,
+ 0.,0.,-.9,.1,.5,0.,0.,0.,0.,.7,.1,.3,.8,-.9,-.3,.5,.6,0.,0.,0.,0.,
+ 0.,0.,.5,0.,0.,0.,0.,0.,0.,.5,.3,0.,0.,0.,0.,0.,.5,.3,-.6,.8,0.,
+ 0.,0. };
+ static doublereal dt10y[112] /* was [7][4][4] */ = { .5,0.,0.,0.,
+ 0.,0.,0.,.6,0.,0.,0.,0.,0.,0.,.6,.1,0.,0.,0.,0.,0.,.6,.1,-.5,.8,
+ 0.,0.,0.,.5,0.,0.,0.,0.,0.,0.,.6,0.,0.,0.,0.,0.,0.,-.5,-.9,.6,0.,
+ 0.,0.,0.,-.4,-.9,.9,.7,-.5,.2,.6,.5,0.,0.,0.,0.,0.,0.,.6,0.,0.,0.,
+ 0.,0.,0.,-.5,.6,0.,0.,0.,0.,0.,-.4,.9,-.5,.6,0.,0.,0.,.5,0.,0.,0.,
+ 0.,0.,0.,.6,0.,0.,0.,0.,0.,0.,.6,-.9,.1,0.,0.,0.,0.,.6,-.9,.1,.7,
+ -.5,.2,.8 };
+ static doublereal ssize1[4] = { 0.,.3,1.6,3.2 };
+ static doublereal ssize2[28] /* was [14][2] */ = { 0.,0.,0.,0.,0.,
+ 0.,0.,0.,0.,0.,0.,0.,0.,0.,1.17,1.17,1.17,1.17,1.17,1.17,1.17,
+ 1.17,1.17,1.17,1.17,1.17,1.17,1.17 };
+
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_wsle(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, ki, kn, mx, my;
+ doublereal sx[7], sy[7], stx[7], sty[7];
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer lenx, leny;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dswap_(integer *, doublereal *, integer
+ *, doublereal *, integer *);
+ integer ksize;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *), stest_(integer *, doublereal
+ *, doublereal *, doublereal *, doublereal *), stest1_(doublereal *
+ , doublereal *, doublereal *, doublereal *);
+
+ /* Fortran I/O blocks */
+ static cilist io___58 = { 0, 6, 0, 0, 0 };
+
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+
+ for (ki = 1; ki <= 4; ++ki) {
+ combla_1.incx = incxs[ki - 1];
+ combla_1.incy = incys[ki - 1];
+ mx = abs(combla_1.incx);
+ my = abs(combla_1.incy);
+
+ for (kn = 1; kn <= 4; ++kn) {
+ combla_1.n = ns[kn - 1];
+ ksize = min(2,kn);
+ lenx = lens[kn + (mx << 2) - 5];
+ leny = lens[kn + (my << 2) - 5];
+/* .. Initialize all argument arrays .. */
+ for (i__ = 1; i__ <= 7; ++i__) {
+ sx[i__ - 1] = dx1[i__ - 1];
+ sy[i__ - 1] = dy1[i__ - 1];
+/* L20: */
+ }
+
+ if (combla_1.icase == 1) {
+/* .. DDOT .. */
+ d__1 = ddot_(&combla_1.n, sx, &combla_1.incx, sy, &
+ combla_1.incy);
+ stest1_(&d__1, &dt7[kn + (ki << 2) - 5], &ssize1[kn - 1],
+ sfac);
+ } else if (combla_1.icase == 2) {
+/* .. DAXPY .. */
+ daxpy_(&combla_1.n, &sa, sx, &combla_1.incx, sy, &
+ combla_1.incy);
+ i__1 = leny;
+ for (j = 1; j <= i__1; ++j) {
+ sty[j - 1] = dt8[j + (kn + (ki << 2)) * 7 - 36];
+/* L40: */
+ }
+ stest_(&leny, sy, sty, &ssize2[ksize * 14 - 14], sfac);
+ } else if (combla_1.icase == 5) {
+/* .. DCOPY .. */
+ for (i__ = 1; i__ <= 7; ++i__) {
+ sty[i__ - 1] = dt10y[i__ + (kn + (ki << 2)) * 7 - 36];
+/* L60: */
+ }
+ dcopy_(&combla_1.n, sx, &combla_1.incx, sy, &combla_1.incy);
+ stest_(&leny, sy, sty, ssize2, &c_b34);
+ } else if (combla_1.icase == 6) {
+/* .. DSWAP .. */
+ dswap_(&combla_1.n, sx, &combla_1.incx, sy, &combla_1.incy);
+ for (i__ = 1; i__ <= 7; ++i__) {
+ stx[i__ - 1] = dt10x[i__ + (kn + (ki << 2)) * 7 - 36];
+ sty[i__ - 1] = dt10y[i__ + (kn + (ki << 2)) * 7 - 36];
+/* L80: */
+ }
+ stest_(&lenx, sx, stx, ssize2, &c_b34);
+ stest_(&leny, sy, sty, ssize2, &c_b34);
+ } else {
+ s_wsle(&io___58);
+ do_lio(&c__9, &c__1, " Shouldn't be here in CHECK2", (ftnlen)
+ 28);
+ e_wsle();
+ s_stop("", (ftnlen)0);
+ }
+/* L100: */
+ }
+/* L120: */
+ }
+ return 0;
+} /* check2_ */
+
+/* Subroutine */ int check3_(doublereal *sfac)
+{
+ /* Initialized data */
+
+ static integer incxs[4] = { 1,2,-2,-1 };
+ static integer incys[4] = { 1,-2,1,-2 };
+ static integer lens[8] /* was [4][2] */ = { 1,1,2,4,1,1,3,7 };
+ static integer ns[4] = { 0,1,2,4 };
+ static doublereal dx1[7] = { .6,.1,-.5,.8,.9,-.3,-.4 };
+ static doublereal dy1[7] = { .5,-.9,.3,.7,-.6,.2,.8 };
+ static doublereal sc = .8;
+ static doublereal ss = .6;
+ static doublereal dt9x[112] /* was [7][4][4] */ = { .6,0.,0.,0.,0.,0.,0.,
+ .78,0.,0.,0.,0.,0.,0.,.78,-.46,0.,0.,0.,0.,0.,.78,-.46,-.22,1.06,
+ 0.,0.,0.,.6,0.,0.,0.,0.,0.,0.,.78,0.,0.,0.,0.,0.,0.,.66,.1,-.1,0.,
+ 0.,0.,0.,.96,.1,-.76,.8,.9,-.3,-.02,.6,0.,0.,0.,0.,0.,0.,.78,0.,
+ 0.,0.,0.,0.,0.,-.06,.1,-.1,0.,0.,0.,0.,.9,.1,-.22,.8,.18,-.3,-.02,
+ .6,0.,0.,0.,0.,0.,0.,.78,0.,0.,0.,0.,0.,0.,.78,.26,0.,0.,0.,0.,0.,
+ .78,.26,-.76,1.12,0.,0.,0. };
+ static doublereal dt9y[112] /* was [7][4][4] */ = { .5,0.,0.,0.,0.,0.,0.,
+ .04,0.,0.,0.,0.,0.,0.,.04,-.78,0.,0.,0.,0.,0.,.04,-.78,.54,.08,0.,
+ 0.,0.,.5,0.,0.,0.,0.,0.,0.,.04,0.,0.,0.,0.,0.,0.,.7,-.9,-.12,0.,
+ 0.,0.,0.,.64,-.9,-.3,.7,-.18,.2,.28,.5,0.,0.,0.,0.,0.,0.,.04,0.,
+ 0.,0.,0.,0.,0.,.7,-1.08,0.,0.,0.,0.,0.,.64,-1.26,.54,.2,0.,0.,0.,
+ .5,0.,0.,0.,0.,0.,0.,.04,0.,0.,0.,0.,0.,0.,.04,-.9,.18,0.,0.,0.,
+ 0.,.04,-.9,.18,.7,-.18,.2,.16 };
+ static doublereal ssize2[28] /* was [14][2] */ = { 0.,0.,0.,0.,0.,
+ 0.,0.,0.,0.,0.,0.,0.,0.,0.,1.17,1.17,1.17,1.17,1.17,1.17,1.17,
+ 1.17,1.17,1.17,1.17,1.17,1.17,1.17 };
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_wsle(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+
+ /* Local variables */
+ integer i__, k, ki, kn, mx, my;
+ doublereal sx[7], sy[7], stx[7], sty[7];
+ integer lenx, leny;
+ doublereal mwpc[11];
+ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ integer mwpn[11];
+ doublereal mwps[11], mwpx[5], mwpy[5];
+ integer ksize;
+ doublereal copyx[5], copyy[5];
+ extern /* Subroutine */ int stest_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *);
+ doublereal mwptx[55] /* was [11][5] */, mwpty[55] /* was [11][5]
+ */;
+ integer mwpinx[11], mwpiny[11];
+ doublereal mwpstx[5], mwpsty[5];
+
+ /* Fortran I/O blocks */
+ static cilist io___82 = { 0, 6, 0, 0, 0 };
+
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+
+ for (ki = 1; ki <= 4; ++ki) {
+ combla_1.incx = incxs[ki - 1];
+ combla_1.incy = incys[ki - 1];
+ mx = abs(combla_1.incx);
+ my = abs(combla_1.incy);
+
+ for (kn = 1; kn <= 4; ++kn) {
+ combla_1.n = ns[kn - 1];
+ ksize = min(2,kn);
+ lenx = lens[kn + (mx << 2) - 5];
+ leny = lens[kn + (my << 2) - 5];
+
+ if (combla_1.icase == 4) {
+/* .. DROT .. */
+ for (i__ = 1; i__ <= 7; ++i__) {
+ sx[i__ - 1] = dx1[i__ - 1];
+ sy[i__ - 1] = dy1[i__ - 1];
+ stx[i__ - 1] = dt9x[i__ + (kn + (ki << 2)) * 7 - 36];
+ sty[i__ - 1] = dt9y[i__ + (kn + (ki << 2)) * 7 - 36];
+/* L20: */
+ }
+ drot_(&combla_1.n, sx, &combla_1.incx, sy, &combla_1.incy, &
+ sc, &ss);
+ stest_(&lenx, sx, stx, &ssize2[ksize * 14 - 14], sfac);
+ stest_(&leny, sy, sty, &ssize2[ksize * 14 - 14], sfac);
+ } else {
+ s_wsle(&io___82);
+ do_lio(&c__9, &c__1, " Shouldn't be here in CHECK3", (ftnlen)
+ 28);
+ e_wsle();
+ s_stop("", (ftnlen)0);
+ }
+/* L40: */
+ }
+/* L60: */
+ }
+
+ mwpc[0] = 1.;
+ for (i__ = 2; i__ <= 11; ++i__) {
+ mwpc[i__ - 1] = 0.;
+/* L80: */
+ }
+ mwps[0] = 0.;
+ for (i__ = 2; i__ <= 6; ++i__) {
+ mwps[i__ - 1] = 1.;
+/* L100: */
+ }
+ for (i__ = 7; i__ <= 11; ++i__) {
+ mwps[i__ - 1] = -1.;
+/* L120: */
+ }
+ mwpinx[0] = 1;
+ mwpinx[1] = 1;
+ mwpinx[2] = 1;
+ mwpinx[3] = -1;
+ mwpinx[4] = 1;
+ mwpinx[5] = -1;
+ mwpinx[6] = 1;
+ mwpinx[7] = 1;
+ mwpinx[8] = -1;
+ mwpinx[9] = 1;
+ mwpinx[10] = -1;
+ mwpiny[0] = 1;
+ mwpiny[1] = 1;
+ mwpiny[2] = -1;
+ mwpiny[3] = -1;
+ mwpiny[4] = 2;
+ mwpiny[5] = 1;
+ mwpiny[6] = 1;
+ mwpiny[7] = -1;
+ mwpiny[8] = -1;
+ mwpiny[9] = 2;
+ mwpiny[10] = 1;
+ for (i__ = 1; i__ <= 11; ++i__) {
+ mwpn[i__ - 1] = 5;
+/* L140: */
+ }
+ mwpn[4] = 3;
+ mwpn[9] = 3;
+ for (i__ = 1; i__ <= 5; ++i__) {
+ mwpx[i__ - 1] = (doublereal) i__;
+ mwpy[i__ - 1] = (doublereal) i__;
+ mwptx[i__ * 11 - 11] = (doublereal) i__;
+ mwpty[i__ * 11 - 11] = (doublereal) i__;
+ mwptx[i__ * 11 - 10] = (doublereal) i__;
+ mwpty[i__ * 11 - 10] = (doublereal) (-i__);
+ mwptx[i__ * 11 - 9] = (doublereal) (6 - i__);
+ mwpty[i__ * 11 - 9] = (doublereal) (i__ - 6);
+ mwptx[i__ * 11 - 8] = (doublereal) i__;
+ mwpty[i__ * 11 - 8] = (doublereal) (-i__);
+ mwptx[i__ * 11 - 6] = (doublereal) (6 - i__);
+ mwpty[i__ * 11 - 6] = (doublereal) (i__ - 6);
+ mwptx[i__ * 11 - 5] = (doublereal) (-i__);
+ mwpty[i__ * 11 - 5] = (doublereal) i__;
+ mwptx[i__ * 11 - 4] = (doublereal) (i__ - 6);
+ mwpty[i__ * 11 - 4] = (doublereal) (6 - i__);
+ mwptx[i__ * 11 - 3] = (doublereal) (-i__);
+ mwpty[i__ * 11 - 3] = (doublereal) i__;
+ mwptx[i__ * 11 - 1] = (doublereal) (i__ - 6);
+ mwpty[i__ * 11 - 1] = (doublereal) (6 - i__);
+/* L160: */
+ }
+ mwptx[4] = 1.;
+ mwptx[15] = 3.;
+ mwptx[26] = 5.;
+ mwptx[37] = 4.;
+ mwptx[48] = 5.;
+ mwpty[4] = -1.;
+ mwpty[15] = 2.;
+ mwpty[26] = -2.;
+ mwpty[37] = 4.;
+ mwpty[48] = -3.;
+ mwptx[9] = -1.;
+ mwptx[20] = -3.;
+ mwptx[31] = -5.;
+ mwptx[42] = 4.;
+ mwptx[53] = 5.;
+ mwpty[9] = 1.;
+ mwpty[20] = 2.;
+ mwpty[31] = 2.;
+ mwpty[42] = 4.;
+ mwpty[53] = 3.;
+ for (i__ = 1; i__ <= 11; ++i__) {
+ combla_1.incx = mwpinx[i__ - 1];
+ combla_1.incy = mwpiny[i__ - 1];
+ for (k = 1; k <= 5; ++k) {
+ copyx[k - 1] = mwpx[k - 1];
+ copyy[k - 1] = mwpy[k - 1];
+ mwpstx[k - 1] = mwptx[i__ + k * 11 - 12];
+ mwpsty[k - 1] = mwpty[i__ + k * 11 - 12];
+/* L180: */
+ }
+ drot_(&mwpn[i__ - 1], copyx, &combla_1.incx, copyy, &combla_1.incy, &
+ mwpc[i__ - 1], &mwps[i__ - 1]);
+ stest_(&c__5, copyx, mwpstx, mwpstx, sfac);
+ stest_(&c__5, copyy, mwpsty, mwpsty, sfac);
+/* L200: */
+ }
+ return 0;
+} /* check3_ */
+
+/* Subroutine */ int stest_(integer *len, doublereal *scomp, doublereal *
+ strue, doublereal *ssize, doublereal *sfac)
+{
+ /* Format strings */
+ static char fmt_99999[] = "(\002 F"
+ "AIL\002)";
+ static char fmt_99998[] = "(/\002 CASE N INCX INCY MODE I "
+ " \002,\002 COMP(I) TRU"
+ "E(I) DIFFERENCE\002,\002 SIZE(I)\002,/1x)";
+ static char fmt_99997[] = "(1x,i4,i3,3i5,i3,2d36.8,2d12.4)";
+
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2, d__3, d__4, d__5;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ doublereal sd;
+ extern doublereal sdiff_(doublereal *, doublereal *);
+
+ /* Fortran I/O blocks */
+ static cilist io___99 = { 0, 6, 0, fmt_99999, 0 };
+ static cilist io___100 = { 0, 6, 0, fmt_99998, 0 };
+ static cilist io___101 = { 0, 6, 0, fmt_99997, 0 };
+
+
+/* ********************************* STEST ************************** */
+
+/* THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO */
+/* SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE */
+/* NEGLIGIBLE. */
+
+/* C. L. LAWSON, JPL, 1974 DEC 10 */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. External Functions .. */
+/* .. Intrinsic Functions .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ssize;
+ --strue;
+ --scomp;
+
+ /* Function Body */
+ i__1 = *len;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sd = scomp[i__] - strue[i__];
+ d__4 = (d__1 = ssize[i__], abs(d__1)) + (d__2 = *sfac * sd, abs(d__2))
+ ;
+ d__5 = (d__3 = ssize[i__], abs(d__3));
+ if (sdiff_(&d__4, &d__5) == 0.) {
+ goto L40;
+ }
+
+/* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I). */
+
+ if (! combla_1.pass) {
+ goto L20;
+ }
+/* PRINT FAIL MESSAGE AND HEADER. */
+ combla_1.pass = FALSE_;
+ s_wsfe(&io___99);
+ e_wsfe();
+ s_wsfe(&io___100);
+ e_wsfe();
+L20:
+ s_wsfe(&io___101);
+ do_fio(&c__1, (char *)&combla_1.icase, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.incy, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.mode, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&scomp[i__], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&strue[i__], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&sd, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&ssize[i__], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+L40:
+ ;
+ }
+ return 0;
+
+} /* stest_ */
+
+/* Subroutine */ int stest1_(doublereal *scomp1, doublereal *strue1,
+ doublereal *ssize, doublereal *sfac)
+{
+ doublereal scomp[1], strue[1];
+ extern /* Subroutine */ int stest_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *);
+
+/* ************************* STEST1 ***************************** */
+
+/* THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN */
+/* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE */
+/* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT. */
+
+/* C.L. LAWSON, JPL, 1978 DEC 6 */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Arrays .. */
+/* .. External Subroutines .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ssize;
+
+ /* Function Body */
+ scomp[0] = *scomp1;
+ strue[0] = *strue1;
+ stest_(&c__1, scomp, strue, &ssize[1], sfac);
+
+ return 0;
+} /* stest1_ */
+
+doublereal sdiff_(doublereal *sa, doublereal *sb)
+{
+ /* System generated locals */
+ doublereal ret_val;
+
+/* ********************************* SDIFF ************************** */
+/* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 */
+
+/* .. Scalar Arguments .. */
+/* .. Executable Statements .. */
+ ret_val = *sa - *sb;
+ return ret_val;
+} /* sdiff_ */
+
+/* Subroutine */ int itest1_(integer *icomp, integer *itrue)
+{
+ /* Format strings */
+ static char fmt_99999[] = "(\002 F"
+ "AIL\002)";
+ static char fmt_99998[] = "(/\002 CASE N INCX INCY MODE "
+ " \002,\002 COMP TRU"
+ "E DIFFERENCE\002,/1x)";
+ static char fmt_99997[] = "(1x,i4,i3,3i5,2i36,i12)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer id;
+
+ /* Fortran I/O blocks */
+ static cilist io___104 = { 0, 6, 0, fmt_99999, 0 };
+ static cilist io___105 = { 0, 6, 0, fmt_99998, 0 };
+ static cilist io___107 = { 0, 6, 0, fmt_99997, 0 };
+
+
+/* ********************************* ITEST1 ************************* */
+
+/* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR */
+/* EQUALITY. */
+/* C. L. LAWSON, JPL, 1974 DEC 10 */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+
+ if (*icomp == *itrue) {
+ goto L40;
+ }
+
+/* HERE ICOMP IS NOT EQUAL TO ITRUE. */
+
+ if (! combla_1.pass) {
+ goto L20;
+ }
+/* PRINT FAIL MESSAGE AND HEADER. */
+ combla_1.pass = FALSE_;
+ s_wsfe(&io___104);
+ e_wsfe();
+ s_wsfe(&io___105);
+ e_wsfe();
+L20:
+ id = *icomp - *itrue;
+ s_wsfe(&io___107);
+ do_fio(&c__1, (char *)&combla_1.icase, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.incy, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.mode, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*icomp), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*itrue), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&id, (ftnlen)sizeof(integer));
+ e_wsfe();
+L40:
+ return 0;
+
+} /* itest1_ */
+
+/* Main program alias */ int dblat1_ () { MAIN__ (); return 0; }
diff --git a/BLAS/TESTING/dblat2.c b/BLAS/TESTING/dblat2.c
new file mode 100644
index 0000000..bf89c3f
--- /dev/null
+++ b/BLAS/TESTING/dblat2.c
@@ -0,0 +1,5043 @@
+/* dblat2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+union {
+ struct {
+ integer infot, noutc;
+ logical ok, lerr;
+ } _1;
+ struct {
+ integer infot, nout;
+ logical ok, lerr;
+ } _2;
+} infoc_;
+
+#define infoc_1 (infoc_._1)
+#define infoc_2 (infoc_._2)
+
+struct {
+ char srnamt[6];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__9 = 9;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__8 = 8;
+static integer c__5 = 5;
+static integer c__65 = 65;
+static integer c__7 = 7;
+static integer c__2 = 2;
+static doublereal c_b121 = 1.;
+static doublereal c_b133 = 0.;
+static logical c_true = TRUE_;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static logical c_false = FALSE_;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Initialized data */
+
+ static char snames[6*16] = "DGEMV " "DGBMV " "DSYMV " "DSBMV " "DSPMV "
+ "DTRMV " "DTBMV " "DTPMV " "DTRSV " "DTBSV " "DTPSV " "DGER "
+ "DSYR " "DSPR " "DSYR2 " "DSPR2 ";
+
+ /* Format strings */
+ static char fmt_9997[] = "(\002 NUMBER OF VALUES OF \002,a,\002 IS LESS "
+ "THAN 1 OR GREATER \002,\002THAN \002,i2)";
+ static char fmt_9996[] = "(\002 VALUE OF N IS LESS THAN 0 OR GREATER THA"
+ "N \002,i2)";
+ static char fmt_9995[] = "(\002 VALUE OF K IS LESS THAN 0\002)";
+ static char fmt_9994[] = "(\002 ABSOLUTE VALUE OF INCX OR INCY IS 0 OR G"
+ "REATER THAN \002,i2)";
+ static char fmt_9993[] = "(\002 TESTS OF THE DOUBLE PRECISION LEVEL 2 BL"
+ "AS\002,//\002 THE F\002,\002OLLOWING PARAMETER VALUES WILL BE US"
+ "ED:\002)";
+ static char fmt_9992[] = "(\002 FOR N \002,9i6)";
+ static char fmt_9991[] = "(\002 FOR K \002,7i6)";
+ static char fmt_9990[] = "(\002 FOR INCX AND INCY \002,7i6)";
+ static char fmt_9989[] = "(\002 FOR ALPHA \002,7f6.1)";
+ static char fmt_9988[] = "(\002 FOR BETA \002,7f6.1)";
+ static char fmt_9980[] = "(\002 ERROR-EXITS WILL NOT BE TESTED\002)";
+ static char fmt_9999[] = "(\002 ROUTINES PASS COMPUTATIONAL TESTS IF TES"
+ "T RATIO IS LES\002,\002S THAN\002,f8.2)";
+ static char fmt_9984[] = "(a6,l2)";
+ static char fmt_9986[] = "(\002 SUBPROGRAM NAME \002,a6,\002 NOT RECOGNI"
+ "ZED\002,/\002 ******* T\002,\002ESTS ABANDONED *******\002)";
+ static char fmt_9998[] = "(\002 RELATIVE MACHINE PRECISION IS TAKEN TO"
+ " BE\002,1p,d9.1)";
+ static char fmt_9985[] = "(\002 ERROR IN DMVCH - IN-LINE DOT PRODUCTS A"
+ "RE BEING EVALU\002,\002ATED WRONGLY.\002,/\002 DMVCH WAS CALLED "
+ "WITH TRANS = \002,a1,\002 AND RETURNED SAME = \002,l1,\002 AND E"
+ "RR = \002,f12.3,\002.\002,/\002 THIS MAY BE DUE TO FAULTS IN THE"
+ " ARITHMETIC OR THE COMPILER.\002,/\002 ******* TESTS ABANDONED *"
+ "******\002)";
+ static char fmt_9983[] = "(1x,a6,\002 WAS NOT TESTED\002)";
+ static char fmt_9982[] = "(/\002 END OF TESTS\002)";
+ static char fmt_9981[] = "(/\002 ******* FATAL ERROR - TESTS ABANDONED *"
+ "******\002)";
+ static char fmt_9987[] = "(\002 AMEND DATA FILE OR INCREASE ARRAY SIZES "
+ "IN PROGRAM\002,/\002 ******* TESTS ABANDONED *******\002)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublereal d__1;
+ olist o__1;
+ cllist cl__1;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void), f_open(olist *), s_wsfe(cilist *), do_fio(integer *,
+ char *, ftnlen), e_wsfe(void), s_wsle(cilist *), e_wsle(void),
+ s_rsfe(cilist *), e_rsfe(void), s_cmp(char *, char *, ftnlen,
+ ftnlen);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+ integer f_clos(cllist *);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal a[4225] /* was [65][65] */, g[65];
+ integer i__, j, n;
+ doublereal x[65], y[65], z__[130], aa[4225];
+ integer kb[7];
+ doublereal as[4225], xs[130], ys[130], yt[65], xx[130], yy[130], alf[7];
+ extern logical lde_(doublereal *, doublereal *, integer *);
+ integer inc[7], nkb;
+ doublereal bet[7], eps, err;
+ integer nalf, idim[9];
+ logical same;
+ integer ninc, nbet, ntra;
+ logical rewi;
+ integer nout;
+ extern /* Subroutine */ int dchk1_(char *, doublereal *, doublereal *,
+ integer *, integer *, logical *, logical *, logical *, integer *,
+ integer *, integer *, integer *, integer *, doublereal *, integer
+ *, doublereal *, integer *, integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, ftnlen), dchk2_(char *,
+ doublereal *, doublereal *, integer *, integer *, logical *,
+ logical *, logical *, integer *, integer *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, ftnlen), dchk3_(char *, doublereal *, doublereal *,
+ integer *, integer *, logical *, logical *, logical *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, ftnlen), dchk4_(char *, doublereal *, doublereal *,
+ integer *, integer *, logical *, logical *, logical *, integer *,
+ integer *, integer *, doublereal *, integer *, integer *, integer
+ *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, ftnlen), dchk5_(char *, doublereal *, doublereal *,
+ integer *, integer *, logical *, logical *, logical *, integer *,
+ integer *, integer *, doublereal *, integer *, integer *, integer
+ *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, ftnlen), dchk6_(char *, doublereal *, doublereal *,
+ integer *, integer *, logical *, logical *, logical *, integer *,
+ integer *, integer *, doublereal *, integer *, integer *, integer
+ *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, ftnlen);
+ extern doublereal ddiff_(doublereal *, doublereal *);
+ extern /* Subroutine */ int dchke_(integer *, char *, integer *, ftnlen);
+ logical fatal, trace;
+ integer nidim;
+ extern /* Subroutine */ int dmvch_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, logical *, integer *,
+ logical *, ftnlen);
+ char snaps[32], trans[1];
+ integer isnum;
+ logical ltest[16], sfatal;
+ char snamet[6];
+ doublereal thresh;
+ logical ltestt, tsterr;
+ char summry[32];
+
+ /* Fortran I/O blocks */
+ static cilist io___2 = { 0, 5, 0, 0, 0 };
+ static cilist io___4 = { 0, 5, 0, 0, 0 };
+ static cilist io___6 = { 0, 5, 0, 0, 0 };
+ static cilist io___8 = { 0, 5, 0, 0, 0 };
+ static cilist io___11 = { 0, 5, 0, 0, 0 };
+ static cilist io___13 = { 0, 5, 0, 0, 0 };
+ static cilist io___15 = { 0, 5, 0, 0, 0 };
+ static cilist io___17 = { 0, 5, 0, 0, 0 };
+ static cilist io___19 = { 0, 5, 0, 0, 0 };
+ static cilist io___21 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___22 = { 0, 5, 0, 0, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___26 = { 0, 5, 0, 0, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___29 = { 0, 5, 0, 0, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___32 = { 0, 5, 0, 0, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___35 = { 0, 5, 0, 0, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___38 = { 0, 5, 0, 0, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___41 = { 0, 5, 0, 0, 0 };
+ static cilist io___43 = { 0, 5, 0, 0, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___46 = { 0, 5, 0, 0, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9988, 0 };
+ static cilist io___54 = { 0, 0, 0, 0, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9980, 0 };
+ static cilist io___56 = { 0, 0, 0, 0, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___58 = { 0, 0, 0, 0, 0 };
+ static cilist io___60 = { 0, 5, 1, fmt_9984, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9986, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9985, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9985, 0 };
+ static cilist io___81 = { 0, 0, 0, 0, 0 };
+ static cilist io___82 = { 0, 0, 0, fmt_9983, 0 };
+ static cilist io___83 = { 0, 0, 0, 0, 0 };
+ static cilist io___90 = { 0, 0, 0, fmt_9982, 0 };
+ static cilist io___91 = { 0, 0, 0, fmt_9981, 0 };
+ static cilist io___92 = { 0, 0, 0, fmt_9987, 0 };
+
+
+
+/* Test program for the DOUBLE PRECISION Level 2 Blas. */
+
+/* The program must be driven by a short data file. The first 18 records */
+/* of the file are read using list-directed input, the last 16 records */
+/* are read using the format ( A6, L2 ). An annotated example of a data */
+/* file can be obtained by deleting the first 3 characters from the */
+/* following 34 lines: */
+/* 'dblat2.out' NAME OF SUMMARY OUTPUT FILE */
+/* 6 UNIT NUMBER OF SUMMARY FILE */
+/* 'DBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE */
+/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */
+/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */
+/* F LOGICAL FLAG, T TO STOP ON FAILURES. */
+/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */
+/* 16.0 THRESHOLD VALUE OF TEST RATIO */
+/* 6 NUMBER OF VALUES OF N */
+/* 0 1 2 3 5 9 VALUES OF N */
+/* 4 NUMBER OF VALUES OF K */
+/* 0 1 2 4 VALUES OF K */
+/* 4 NUMBER OF VALUES OF INCX AND INCY */
+/* 1 2 -1 -2 VALUES OF INCX AND INCY */
+/* 3 NUMBER OF VALUES OF ALPHA */
+/* 0.0 1.0 0.7 VALUES OF ALPHA */
+/* 3 NUMBER OF VALUES OF BETA */
+/* 0.0 1.0 0.9 VALUES OF BETAC */
+/* DGEMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* DGBMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* DSYMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* DSBMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* DSPMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* DTRMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* DTBMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* DTPMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* DTRSV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* DTBSV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* DTPSV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* DGER T PUT F FOR NO TEST. SAME COLUMNS. */
+/* DSYR T PUT F FOR NO TEST. SAME COLUMNS. */
+/* DSPR T PUT F FOR NO TEST. SAME COLUMNS. */
+/* DSYR2 T PUT F FOR NO TEST. SAME COLUMNS. */
+/* DSPR2 T PUT F FOR NO TEST. SAME COLUMNS. */
+
+/* See: */
+
+/* Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. */
+/* An extended set of Fortran Basic Linear Algebra Subprograms. */
+
+/* Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics */
+/* and Computer Science Division, Argonne National Laboratory, */
+/* 9700 South Cass Avenue, Argonne, Illinois 60439, US. */
+
+/* Or */
+
+/* NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms */
+/* Group Ltd., NAG Central Office, 256 Banbury Road, Oxford */
+/* OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st */
+/* Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. */
+
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers */
+/* can be run multiple times without deleting generated */
+/* output files (susan) */
+
+/* .. Parameters .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+
+/* Read name and unit number for summary output file and open file. */
+
+ s_rsle(&io___2);
+ do_lio(&c__9, &c__1, summry, (ftnlen)32);
+ e_rsle();
+ s_rsle(&io___4);
+ do_lio(&c__3, &c__1, (char *)&nout, (ftnlen)sizeof(integer));
+ e_rsle();
+ o__1.oerr = 0;
+ o__1.ounit = nout;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = summry;
+ o__1.orl = 0;
+ o__1.osta = "UNKNOWN";
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);
+ infoc_1.noutc = nout;
+
+/* Read name and unit number for snapshot output file and open file. */
+
+ s_rsle(&io___6);
+ do_lio(&c__9, &c__1, snaps, (ftnlen)32);
+ e_rsle();
+ s_rsle(&io___8);
+ do_lio(&c__3, &c__1, (char *)&ntra, (ftnlen)sizeof(integer));
+ e_rsle();
+ trace = ntra >= 0;
+ if (trace) {
+ o__1.oerr = 0;
+ o__1.ounit = ntra;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = snaps;
+ o__1.orl = 0;
+ o__1.osta = "UNKNOWN";
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);
+ }
+/* Read the flag that directs rewinding of the snapshot file. */
+ s_rsle(&io___11);
+ do_lio(&c__8, &c__1, (char *)&rewi, (ftnlen)sizeof(logical));
+ e_rsle();
+ rewi = rewi && trace;
+/* Read the flag that directs stopping on any failure. */
+ s_rsle(&io___13);
+ do_lio(&c__8, &c__1, (char *)&sfatal, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the flag that indicates whether error exits are to be tested. */
+ s_rsle(&io___15);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the threshold value of the test ratio */
+ s_rsle(&io___17);
+ do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_rsle();
+
+/* Read and check the parameter values for the tests. */
+
+/* Values of N */
+ s_rsle(&io___19);
+ do_lio(&c__3, &c__1, (char *)&nidim, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nidim < 1 || nidim > 9) {
+ io___21.ciunit = nout;
+ s_wsfe(&io___21);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+ s_rsle(&io___22);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {
+ io___25.ciunit = nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, (char *)&c__65, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+/* L10: */
+ }
+/* Values of K */
+ s_rsle(&io___26);
+ do_lio(&c__3, &c__1, (char *)&nkb, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nkb < 1 || nkb > 7) {
+ io___28.ciunit = nout;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "K", (ftnlen)1);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+ s_rsle(&io___29);
+ i__1 = nkb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&kb[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nkb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (kb[i__ - 1] < 0) {
+ io___31.ciunit = nout;
+ s_wsfe(&io___31);
+ e_wsfe();
+ goto L230;
+ }
+/* L20: */
+ }
+/* Values of INCX and INCY */
+ s_rsle(&io___32);
+ do_lio(&c__3, &c__1, (char *)&ninc, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (ninc < 1 || ninc > 7) {
+ io___34.ciunit = nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "INCX AND INCY", (ftnlen)13);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+ s_rsle(&io___35);
+ i__1 = ninc;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&inc[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = ninc;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (inc[i__ - 1] == 0 || (i__2 = inc[i__ - 1], abs(i__2)) > 2) {
+ io___37.ciunit = nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+/* L30: */
+ }
+/* Values of ALPHA */
+ s_rsle(&io___38);
+ do_lio(&c__3, &c__1, (char *)&nalf, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nalf < 1 || nalf > 7) {
+ io___40.ciunit = nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "ALPHA", (ftnlen)5);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+ s_rsle(&io___41);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__5, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(doublereal)
+ );
+ }
+ e_rsle();
+/* Values of BETA */
+ s_rsle(&io___43);
+ do_lio(&c__3, &c__1, (char *)&nbet, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nbet < 1 || nbet > 7) {
+ io___45.ciunit = nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "BETA", (ftnlen)4);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+ s_rsle(&io___46);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__5, &c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(doublereal)
+ );
+ }
+ e_rsle();
+
+/* Report values of parameters. */
+
+ io___48.ciunit = nout;
+ s_wsfe(&io___48);
+ e_wsfe();
+ io___49.ciunit = nout;
+ s_wsfe(&io___49);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ io___50.ciunit = nout;
+ s_wsfe(&io___50);
+ i__1 = nkb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&kb[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ io___51.ciunit = nout;
+ s_wsfe(&io___51);
+ i__1 = ninc;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&inc[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ io___52.ciunit = nout;
+ s_wsfe(&io___52);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(doublereal));
+ }
+ e_wsfe();
+ io___53.ciunit = nout;
+ s_wsfe(&io___53);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(doublereal));
+ }
+ e_wsfe();
+ if (! tsterr) {
+ io___54.ciunit = nout;
+ s_wsle(&io___54);
+ e_wsle();
+ io___55.ciunit = nout;
+ s_wsfe(&io___55);
+ e_wsfe();
+ }
+ io___56.ciunit = nout;
+ s_wsle(&io___56);
+ e_wsle();
+ io___57.ciunit = nout;
+ s_wsfe(&io___57);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ io___58.ciunit = nout;
+ s_wsle(&io___58);
+ e_wsle();
+
+/* Read names of subroutines and flags which indicate */
+/* whether they are to be tested. */
+
+ for (i__ = 1; i__ <= 16; ++i__) {
+ ltest[i__ - 1] = FALSE_;
+/* L40: */
+ }
+L50:
+ i__1 = s_rsfe(&io___60);
+ if (i__1 != 0) {
+ goto L80;
+ }
+ i__1 = do_fio(&c__1, snamet, (ftnlen)6);
+ if (i__1 != 0) {
+ goto L80;
+ }
+ i__1 = do_fio(&c__1, (char *)<estt, (ftnlen)sizeof(logical));
+ if (i__1 != 0) {
+ goto L80;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L80;
+ }
+ for (i__ = 1; i__ <= 16; ++i__) {
+ if (s_cmp(snamet, snames + (i__ - 1) * 6, (ftnlen)6, (ftnlen)6) == 0)
+ {
+ goto L70;
+ }
+/* L60: */
+ }
+ io___63.ciunit = nout;
+ s_wsfe(&io___63);
+ do_fio(&c__1, snamet, (ftnlen)6);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+L70:
+ ltest[i__ - 1] = ltestt;
+ goto L50;
+
+L80:
+ cl__1.cerr = 0;
+ cl__1.cunit = 5;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+
+/* Compute EPS (the machine precision). */
+
+ eps = 1.;
+L90:
+ d__1 = eps + 1.;
+ if (ddiff_(&d__1, &c_b121) == 0.) {
+ goto L100;
+ }
+ eps *= .5;
+ goto L90;
+L100:
+ eps += eps;
+ io___65.ciunit = nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+/* Check the reliability of DMVCH using exact data. */
+
+ n = 32;
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ - j + 1;
+ a[i__ + j * 65 - 66] = (doublereal) max(i__3,0);
+/* L110: */
+ }
+ x[j - 1] = (doublereal) j;
+ y[j - 1] = 0.;
+/* L120: */
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ yy[j - 1] = (doublereal) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j -
+ 1) / 3);
+/* L130: */
+ }
+/* YY holds the exact result. On exit from DMVCH YT holds */
+/* the result computed by DMVCH. */
+ *(unsigned char *)trans = 'N';
+ dmvch_(trans, &n, &n, &c_b121, a, &c__65, x, &c__1, &c_b133, y, &c__1, yt,
+ g, yy, &eps, &err, &fatal, &nout, &c_true, (ftnlen)1);
+ same = lde_(yy, yt, &n);
+ if (! same || err != 0.) {
+ io___78.ciunit = nout;
+ s_wsfe(&io___78);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ *(unsigned char *)trans = 'T';
+ dmvch_(trans, &n, &n, &c_b121, a, &c__65, x, &c_n1, &c_b133, y, &c_n1, yt,
+ g, yy, &eps, &err, &fatal, &nout, &c_true, (ftnlen)1);
+ same = lde_(yy, yt, &n);
+ if (! same || err != 0.) {
+ io___79.ciunit = nout;
+ s_wsfe(&io___79);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Test each subroutine in turn. */
+
+ for (isnum = 1; isnum <= 16; ++isnum) {
+ io___81.ciunit = nout;
+ s_wsle(&io___81);
+ e_wsle();
+ if (! ltest[isnum - 1]) {
+/* Subprogram is not to be tested. */
+ io___82.ciunit = nout;
+ s_wsfe(&io___82);
+ do_fio(&c__1, snames + (isnum - 1) * 6, (ftnlen)6);
+ e_wsfe();
+ } else {
+ s_copy(srnamc_1.srnamt, snames + (isnum - 1) * 6, (ftnlen)6, (
+ ftnlen)6);
+/* Test error exits. */
+ if (tsterr) {
+ dchke_(&isnum, snames + (isnum - 1) * 6, &nout, (ftnlen)6);
+ io___83.ciunit = nout;
+ s_wsle(&io___83);
+ e_wsle();
+ }
+/* Test computations. */
+ infoc_1.infot = 0;
+ infoc_1.ok = TRUE_;
+ fatal = FALSE_;
+ switch (isnum) {
+ case 1: goto L140;
+ case 2: goto L140;
+ case 3: goto L150;
+ case 4: goto L150;
+ case 5: goto L150;
+ case 6: goto L160;
+ case 7: goto L160;
+ case 8: goto L160;
+ case 9: goto L160;
+ case 10: goto L160;
+ case 11: goto L160;
+ case 12: goto L170;
+ case 13: goto L180;
+ case 14: goto L180;
+ case 15: goto L190;
+ case 16: goto L190;
+ }
+/* Test DGEMV, 01, and DGBMV, 02. */
+L140:
+ dchk1_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, alf,
+ &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, as, x, xx,
+ xs, y, yy, ys, yt, g, (ftnlen)6);
+ goto L200;
+/* Test DSYMV, 03, DSBMV, 04, and DSPMV, 05. */
+L150:
+ dchk2_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, alf,
+ &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, as, x, xx,
+ xs, y, yy, ys, yt, g, (ftnlen)6);
+ goto L200;
+/* Test DTRMV, 06, DTBMV, 07, DTPMV, 08, */
+/* DTRSV, 09, DTBSV, 10, and DTPSV, 11. */
+L160:
+ dchk3_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &ninc, inc,
+ &c__65, &c__2, a, aa, as, y, yy, ys, yt, g, z__, (ftnlen)
+ 6);
+ goto L200;
+/* Test DGER, 12. */
+L170:
+ dchk4_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &ninc,
+ inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, ys, yt,
+ g, z__, (ftnlen)6);
+ goto L200;
+/* Test DSYR, 13, and DSPR, 14. */
+L180:
+ dchk5_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &ninc,
+ inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, ys, yt,
+ g, z__, (ftnlen)6);
+ goto L200;
+/* Test DSYR2, 15, and DSPR2, 16. */
+L190:
+ dchk6_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &ninc,
+ inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, ys, yt,
+ g, z__, (ftnlen)6);
+
+L200:
+ if (fatal && sfatal) {
+ goto L220;
+ }
+ }
+/* L210: */
+ }
+ io___90.ciunit = nout;
+ s_wsfe(&io___90);
+ e_wsfe();
+ goto L240;
+
+L220:
+ io___91.ciunit = nout;
+ s_wsfe(&io___91);
+ e_wsfe();
+ goto L240;
+
+L230:
+ io___92.ciunit = nout;
+ s_wsfe(&io___92);
+ e_wsfe();
+
+L240:
+ if (trace) {
+ cl__1.cerr = 0;
+ cl__1.cunit = ntra;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ }
+ cl__1.cerr = 0;
+ cl__1.cunit = nout;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ s_stop("", (ftnlen)0);
+
+
+/* End of DBLAT2. */
+
+ return 0;
+} /* MAIN__ */
+
+/* Subroutine */ int dchk1_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nkb, integer *kb,
+ integer *nalf, doublereal *alf, integer *nbet, doublereal *bet,
+ integer *ninc, integer *inc, integer *nmax, integer *incmax,
+ doublereal *a, doublereal *aa, doublereal *as, doublereal *x,
+ doublereal *xx, doublereal *xs, doublereal *y, doublereal *yy,
+ doublereal *ys, doublereal *yt, doublereal *g, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ich[3] = "NTC";
+
+ /* Format strings */
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "2(i3,\002,\002),f4.1,\002, A,\002,i3,\002, X,\002,i2,\002,\002,f"
+ "4.1,\002, Y,\002,i2,\002) .\002)";
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "4(i3,\002,\002),f4.1,\002, A,\002,i3,\002, X,\002,i2,\002,\002,f"
+ "4.1,\002, Y,\002,i2,\002) .\002)";
+ static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, m, n, ia, ib, ic, nc, nd, im, in, kl, ml, nk, nl, ku, ix, iy,
+ ms, lx, ly, ns, laa, lda;
+ extern logical lde_(doublereal *, doublereal *, integer *);
+ doublereal als, bls, err;
+ integer iku, kls, kus;
+ doublereal beta;
+ integer ldas;
+ logical same;
+ integer incx, incy;
+ logical full, tran, null;
+ extern /* Subroutine */ int dmake_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *, logical *, doublereal *, ftnlen, ftnlen,
+ ftnlen);
+ doublereal alpha;
+ logical isame[13];
+ extern /* Subroutine */ int dgbmv_(char *, integer *, integer *, integer *
+, integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *), dgemv_(
+ char *, integer *, integer *, doublereal *, doublereal *, integer
+ *, doublereal *, integer *, doublereal *, doublereal *, integer *), dmvch_(char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, logical *, integer *, logical *,
+ ftnlen);
+ integer nargs;
+ logical reset;
+ integer incxs, incys;
+ char trans[1];
+ logical banded;
+ extern logical lderes_(char *, char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, ftnlen, ftnlen);
+ doublereal errmax, transl;
+ char transs[1];
+
+ /* Fortran I/O blocks */
+ static cilist io___139 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___140 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___141 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___144 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___146 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___147 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___148 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___149 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___150 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests DGEMV and DGBMV. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --kb;
+ --alf;
+ --bet;
+ --inc;
+ --g;
+ --yt;
+ --y;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ys;
+ --yy;
+ --xs;
+ --xx;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ full = *(unsigned char *)&sname[2] == 'E';
+ banded = *(unsigned char *)&sname[2] == 'B';
+/* Define the number of arguments. */
+ if (full) {
+ nargs = 11;
+ } else if (banded) {
+ nargs = 13;
+ }
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+ nd = n / 2 + 1;
+
+ for (im = 1; im <= 2; ++im) {
+ if (im == 1) {
+/* Computing MAX */
+ i__2 = n - nd;
+ m = max(i__2,0);
+ }
+ if (im == 2) {
+/* Computing MIN */
+ i__2 = n + nd;
+ m = min(i__2,*nmax);
+ }
+
+ if (banded) {
+ nk = *nkb;
+ } else {
+ nk = 1;
+ }
+ i__2 = nk;
+ for (iku = 1; iku <= i__2; ++iku) {
+ if (banded) {
+ ku = kb[iku];
+/* Computing MAX */
+ i__3 = ku - 1;
+ kl = max(i__3,0);
+ } else {
+ ku = n - 1;
+ kl = m - 1;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ if (banded) {
+ lda = kl + ku + 1;
+ } else {
+ lda = m;
+ }
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L100;
+ }
+ laa = lda * n;
+ null = n <= 0 || m <= 0;
+
+/* Generate the matrix A. */
+
+ transl = 0.;
+ dmake_(sname + 1, " ", " ", &m, &n, &a[a_offset], nmax, &aa[1]
+ , &lda, &kl, &ku, &reset, &transl, (ftnlen)2, (ftnlen)
+ 1, (ftnlen)1);
+
+ for (ic = 1; ic <= 3; ++ic) {
+ *(unsigned char *)trans = *(unsigned char *)&ich[ic - 1];
+ tran = *(unsigned char *)trans == 'T' || *(unsigned char *
+ )trans == 'C';
+
+ if (tran) {
+ ml = n;
+ nl = m;
+ } else {
+ ml = m;
+ nl = n;
+ }
+
+ i__3 = *ninc;
+ for (ix = 1; ix <= i__3; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * nl;
+
+/* Generate the vector X. */
+
+ transl = .5;
+ i__4 = abs(incx);
+ i__5 = nl - 1;
+ dmake_("GE", " ", " ", &c__1, &nl, &x[1], &c__1, &xx[
+ 1], &i__4, &c__0, &i__5, &reset, &transl, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+ if (nl > 1) {
+ x[nl / 2] = 0.;
+ xx[abs(incx) * (nl / 2 - 1) + 1] = 0.;
+ }
+
+ i__4 = *ninc;
+ for (iy = 1; iy <= i__4; ++iy) {
+ incy = inc[iy];
+ ly = abs(incy) * ml;
+
+ i__5 = *nalf;
+ for (ia = 1; ia <= i__5; ++ia) {
+ alpha = alf[ia];
+
+ i__6 = *nbet;
+ for (ib = 1; ib <= i__6; ++ib) {
+ beta = bet[ib];
+
+/* Generate the vector Y. */
+
+ transl = 0.;
+ i__7 = abs(incy);
+ i__8 = ml - 1;
+ dmake_("GE", " ", " ", &c__1, &ml, &y[1],
+ &c__1, &yy[1], &i__7, &c__0, &
+ i__8, &reset, &transl, (ftnlen)2,
+ (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the */
+/* subroutine. */
+
+ *(unsigned char *)transs = *(unsigned
+ char *)trans;
+ ms = m;
+ ns = n;
+ kls = kl;
+ kus = ku;
+ als = alpha;
+ i__7 = laa;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ as[i__] = aa[i__];
+/* L10: */
+ }
+ ldas = lda;
+ i__7 = lx;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ xs[i__] = xx[i__];
+/* L20: */
+ }
+ incxs = incx;
+ bls = beta;
+ i__7 = ly;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ ys[i__] = yy[i__];
+/* L30: */
+ }
+ incys = incy;
+
+/* Call the subroutine. */
+
+ if (full) {
+ if (*trace) {
+ io___139.ciunit = *ntra;
+ s_wsfe(&io___139);
+ do_fio(&c__1, (char *)&nc, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (
+ ftnlen)sizeof(doublereal))
+ ;
+ do_fio(&c__1, (char *)&lda, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (
+ ftnlen)sizeof(doublereal))
+ ;
+ do_fio(&c__1, (char *)&incy, (
+ ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ dgemv_(trans, &m, &n, &alpha, &aa[1],
+ &lda, &xx[1], &incx, &beta, &
+ yy[1], &incy);
+ } else if (banded) {
+ if (*trace) {
+ io___140.ciunit = *ntra;
+ s_wsfe(&io___140);
+ do_fio(&c__1, (char *)&nc, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (
+ ftnlen)sizeof(doublereal))
+ ;
+ do_fio(&c__1, (char *)&lda, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (
+ ftnlen)sizeof(doublereal))
+ ;
+ do_fio(&c__1, (char *)&incy, (
+ ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ dgbmv_(trans, &m, &n, &kl, &ku, &
+ alpha, &aa[1], &lda, &xx[1], &
+ incx, &beta, &yy[1], &incy);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___141.ciunit = *nout;
+ s_wsfe(&io___141);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L130;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)trans == *(
+ unsigned char *)transs;
+ isame[1] = ms == m;
+ isame[2] = ns == n;
+ if (full) {
+ isame[3] = als == alpha;
+ isame[4] = lde_(&as[1], &aa[1], &laa);
+ isame[5] = ldas == lda;
+ isame[6] = lde_(&xs[1], &xx[1], &lx);
+ isame[7] = incxs == incx;
+ isame[8] = bls == beta;
+ if (null) {
+ isame[9] = lde_(&ys[1], &yy[1], &
+ ly);
+ } else {
+ i__7 = abs(incy);
+ isame[9] = lderes_("GE", " ", &
+ c__1, &ml, &ys[1], &yy[1],
+ &i__7, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[10] = incys == incy;
+ } else if (banded) {
+ isame[3] = kls == kl;
+ isame[4] = kus == ku;
+ isame[5] = als == alpha;
+ isame[6] = lde_(&as[1], &aa[1], &laa);
+ isame[7] = ldas == lda;
+ isame[8] = lde_(&xs[1], &xx[1], &lx);
+ isame[9] = incxs == incx;
+ isame[10] = bls == beta;
+ if (null) {
+ isame[11] = lde_(&ys[1], &yy[1], &
+ ly);
+ } else {
+ i__7 = abs(incy);
+ isame[11] = lderes_("GE", " ", &
+ c__1, &ml, &ys[1], &yy[1],
+ &i__7, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[12] = incys == incy;
+ }
+
+/* If data was incorrectly changed, report */
+/* and return. */
+
+ same = TRUE_;
+ i__7 = nargs;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___144.ciunit = *nout;
+ s_wsfe(&io___144);
+ do_fio(&c__1, (char *)&i__, (
+ ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L130;
+ }
+
+ if (! null) {
+
+/* Check the result. */
+
+ dmvch_(trans, &m, &n, &alpha, &a[
+ a_offset], nmax, &x[1], &incx,
+ &beta, &y[1], &incy, &yt[1],
+ &g[1], &yy[1], eps, &err,
+ fatal, nout, &c_true, (ftnlen)
+ 1);
+ errmax = max(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L130;
+ }
+ } else {
+/* Avoid repeating tests with M.le.0 or */
+/* N.le.0. */
+ goto L110;
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+/* L70: */
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+L110:
+ ;
+ }
+
+/* L120: */
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___146.ciunit = *nout;
+ s_wsfe(&io___146);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___147.ciunit = *nout;
+ s_wsfe(&io___147);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ goto L140;
+
+L130:
+ io___148.ciunit = *nout;
+ s_wsfe(&io___148);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (full) {
+ io___149.ciunit = *nout;
+ s_wsfe(&io___149);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (banded) {
+ io___150.ciunit = *nout;
+ s_wsfe(&io___150);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L140:
+ return 0;
+
+
+/* End of DCHK1. */
+
+} /* dchk1_ */
+
+/* Subroutine */ int dchk2_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nkb, integer *kb,
+ integer *nalf, doublereal *alf, integer *nbet, doublereal *bet,
+ integer *ninc, integer *inc, integer *nmax, integer *incmax,
+ doublereal *a, doublereal *aa, doublereal *as, doublereal *x,
+ doublereal *xx, doublereal *xs, doublereal *y, doublereal *yy,
+ doublereal *ys, doublereal *yt, doublereal *g, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ich[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,\002,f4.1,\002, A,\002,i3,\002, X,\002,i2,\002,\002,f4.1,"
+ "\002, Y,\002,i2,\002) .\002)";
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "2(i3,\002,\002),f4.1,\002, A,\002,i3,\002, X,\002,i2,\002,\002,f"
+ "4.1,\002, Y,\002,i2,\002) .\002)";
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,\002,f4.1,\002, AP\002,\002, X,\002,i2,\002,\002,f4.1"
+ ",\002, Y,\002,i2,\002) .\002)";
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, k, n, ia, ib, ic, nc, ik, in, nk, ks, ix, iy, ns, lx, ly,
+ laa, lda;
+ extern logical lde_(doublereal *, doublereal *, integer *);
+ doublereal als, bls, err, beta;
+ integer ldas;
+ logical same;
+ integer incx, incy;
+ logical full, null;
+ char uplo[1];
+ extern /* Subroutine */ int dmake_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *, logical *, doublereal *, ftnlen, ftnlen,
+ ftnlen);
+ doublereal alpha;
+ logical isame[13];
+ extern /* Subroutine */ int dmvch_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, logical *, integer *,
+ logical *, ftnlen);
+ integer nargs;
+ extern /* Subroutine */ int dsbmv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ logical reset;
+ integer incxs, incys;
+ extern /* Subroutine */ int dspmv_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ char uplos[1];
+ extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *);
+ logical banded, packed;
+ extern logical lderes_(char *, char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, ftnlen, ftnlen);
+ doublereal errmax, transl;
+
+ /* Fortran I/O blocks */
+ static cilist io___189 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___190 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___191 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___192 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___195 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___197 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___198 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___199 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___200 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___201 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___202 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests DSYMV, DSBMV and DSPMV. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --kb;
+ --alf;
+ --bet;
+ --inc;
+ --g;
+ --yt;
+ --y;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ys;
+ --yy;
+ --xs;
+ --xx;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ full = *(unsigned char *)&sname[2] == 'Y';
+ banded = *(unsigned char *)&sname[2] == 'B';
+ packed = *(unsigned char *)&sname[2] == 'P';
+/* Define the number of arguments. */
+ if (full) {
+ nargs = 10;
+ } else if (banded) {
+ nargs = 11;
+ } else if (packed) {
+ nargs = 9;
+ }
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+
+ if (banded) {
+ nk = *nkb;
+ } else {
+ nk = 1;
+ }
+ i__2 = nk;
+ for (ik = 1; ik <= i__2; ++ik) {
+ if (banded) {
+ k = kb[ik];
+ } else {
+ k = n - 1;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ if (banded) {
+ lda = k + 1;
+ } else {
+ lda = n;
+ }
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L100;
+ }
+ if (packed) {
+ laa = n * (n + 1) / 2;
+ } else {
+ laa = lda * n;
+ }
+ null = n <= 0;
+
+ for (ic = 1; ic <= 2; ++ic) {
+ *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];
+
+/* Generate the matrix A. */
+
+ transl = 0.;
+ dmake_(sname + 1, uplo, " ", &n, &n, &a[a_offset], nmax, &aa[
+ 1], &lda, &k, &k, &reset, &transl, (ftnlen)2, (ftnlen)
+ 1, (ftnlen)1);
+
+ i__3 = *ninc;
+ for (ix = 1; ix <= i__3; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * n;
+
+/* Generate the vector X. */
+
+ transl = .5;
+ i__4 = abs(incx);
+ i__5 = n - 1;
+ dmake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &
+ i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (
+ ftnlen)1, (ftnlen)1);
+ if (n > 1) {
+ x[n / 2] = 0.;
+ xx[abs(incx) * (n / 2 - 1) + 1] = 0.;
+ }
+
+ i__4 = *ninc;
+ for (iy = 1; iy <= i__4; ++iy) {
+ incy = inc[iy];
+ ly = abs(incy) * n;
+
+ i__5 = *nalf;
+ for (ia = 1; ia <= i__5; ++ia) {
+ alpha = alf[ia];
+
+ i__6 = *nbet;
+ for (ib = 1; ib <= i__6; ++ib) {
+ beta = bet[ib];
+
+/* Generate the vector Y. */
+
+ transl = 0.;
+ i__7 = abs(incy);
+ i__8 = n - 1;
+ dmake_("GE", " ", " ", &c__1, &n, &y[1], &
+ c__1, &yy[1], &i__7, &c__0, &i__8, &
+ reset, &transl, (ftnlen)2, (ftnlen)1,
+ (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the */
+/* subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)
+ uplo;
+ ns = n;
+ ks = k;
+ als = alpha;
+ i__7 = laa;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ as[i__] = aa[i__];
+/* L10: */
+ }
+ ldas = lda;
+ i__7 = lx;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ xs[i__] = xx[i__];
+/* L20: */
+ }
+ incxs = incx;
+ bls = beta;
+ i__7 = ly;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ ys[i__] = yy[i__];
+/* L30: */
+ }
+ incys = incy;
+
+/* Call the subroutine. */
+
+ if (full) {
+ if (*trace) {
+ io___189.ciunit = *ntra;
+ s_wsfe(&io___189);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&incy, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ dsymv_(uplo, &n, &alpha, &aa[1], &lda, &
+ xx[1], &incx, &beta, &yy[1], &
+ incy);
+ } else if (banded) {
+ if (*trace) {
+ io___190.ciunit = *ntra;
+ s_wsfe(&io___190);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&incy, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ dsbmv_(uplo, &n, &k, &alpha, &aa[1], &lda,
+ &xx[1], &incx, &beta, &yy[1], &
+ incy);
+ } else if (packed) {
+ if (*trace) {
+ io___191.ciunit = *ntra;
+ s_wsfe(&io___191);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&incy, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ dspmv_(uplo, &n, &alpha, &aa[1], &xx[1], &
+ incx, &beta, &yy[1], &incy);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___192.ciunit = *nout;
+ s_wsfe(&io___192);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplo == *(
+ unsigned char *)uplos;
+ isame[1] = ns == n;
+ if (full) {
+ isame[2] = als == alpha;
+ isame[3] = lde_(&as[1], &aa[1], &laa);
+ isame[4] = ldas == lda;
+ isame[5] = lde_(&xs[1], &xx[1], &lx);
+ isame[6] = incxs == incx;
+ isame[7] = bls == beta;
+ if (null) {
+ isame[8] = lde_(&ys[1], &yy[1], &ly);
+ } else {
+ i__7 = abs(incy);
+ isame[8] = lderes_("GE", " ", &c__1, &
+ n, &ys[1], &yy[1], &i__7, (
+ ftnlen)2, (ftnlen)1);
+ }
+ isame[9] = incys == incy;
+ } else if (banded) {
+ isame[2] = ks == k;
+ isame[3] = als == alpha;
+ isame[4] = lde_(&as[1], &aa[1], &laa);
+ isame[5] = ldas == lda;
+ isame[6] = lde_(&xs[1], &xx[1], &lx);
+ isame[7] = incxs == incx;
+ isame[8] = bls == beta;
+ if (null) {
+ isame[9] = lde_(&ys[1], &yy[1], &ly);
+ } else {
+ i__7 = abs(incy);
+ isame[9] = lderes_("GE", " ", &c__1, &
+ n, &ys[1], &yy[1], &i__7, (
+ ftnlen)2, (ftnlen)1);
+ }
+ isame[10] = incys == incy;
+ } else if (packed) {
+ isame[2] = als == alpha;
+ isame[3] = lde_(&as[1], &aa[1], &laa);
+ isame[4] = lde_(&xs[1], &xx[1], &lx);
+ isame[5] = incxs == incx;
+ isame[6] = bls == beta;
+ if (null) {
+ isame[7] = lde_(&ys[1], &yy[1], &ly);
+ } else {
+ i__7 = abs(incy);
+ isame[7] = lderes_("GE", " ", &c__1, &
+ n, &ys[1], &yy[1], &i__7, (
+ ftnlen)2, (ftnlen)1);
+ }
+ isame[8] = incys == incy;
+ }
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__7 = nargs;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___195.ciunit = *nout;
+ s_wsfe(&io___195);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+
+/* Check the result. */
+
+ dmvch_("N", &n, &n, &alpha, &a[a_offset],
+ nmax, &x[1], &incx, &beta, &y[1],
+ &incy, &yt[1], &g[1], &yy[1], eps,
+ &err, fatal, nout, &c_true, (
+ ftnlen)1);
+ errmax = max(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L120;
+ }
+ } else {
+/* Avoid repeating tests with N.le.0 */
+ goto L110;
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+/* L70: */
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+L110:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___197.ciunit = *nout;
+ s_wsfe(&io___197);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___198.ciunit = *nout;
+ s_wsfe(&io___198);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ goto L130;
+
+L120:
+ io___199.ciunit = *nout;
+ s_wsfe(&io___199);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (full) {
+ io___200.ciunit = *nout;
+ s_wsfe(&io___200);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (banded) {
+ io___201.ciunit = *nout;
+ s_wsfe(&io___201);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (packed) {
+ io___202.ciunit = *nout;
+ s_wsfe(&io___202);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L130:
+ return 0;
+
+
+/* End of DCHK2. */
+
+} /* dchk2_ */
+
+/* Subroutine */ int dchk3_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nkb, integer *kb,
+ integer *ninc, integer *inc, integer *nmax, integer *incmax,
+ doublereal *a, doublereal *aa, doublereal *as, doublereal *x,
+ doublereal *xx, doublereal *xs, doublereal *xt, doublereal *g,
+ doublereal *z__, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ichu[2] = "UL";
+ static char icht[3] = "NTC";
+ static char ichd[2] = "UN";
+
+ /* Format strings */
+ static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002(\002,3(\002'\002,a1"
+ ",\002',\002),i3,\002, A,\002,i3,\002, X,\002,i2,\002) "
+ " .\002)";
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002(\002,3(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),\002 A,\002,i3,\002, X,\002,i2,\002"
+ ") .\002)";
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002(\002,3(\002'\002,a1"
+ ",\002',\002),i3,\002, AP, \002,\002X,\002,i2,\002) "
+ " .\002)";
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio(
+ integer *, char *, ftnlen), e_wsfe(void), f_rew(alist *);
+
+ /* Local variables */
+ integer i__, k, n, nc, ik, in, nk, ks, ix, ns, lx, laa, icd, lda;
+ extern logical lde_(doublereal *, doublereal *, integer *);
+ integer ict, icu;
+ doublereal err;
+ char diag[1];
+ integer ldas;
+ logical same;
+ integer incx;
+ logical full, null;
+ char uplo[1];
+ extern /* Subroutine */ int dmake_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *, logical *, doublereal *, ftnlen, ftnlen,
+ ftnlen);
+ char diags[1];
+ logical isame[13];
+ extern /* Subroutine */ int dmvch_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, logical *, integer *,
+ logical *, ftnlen);
+ integer nargs;
+ extern /* Subroutine */ int dtbmv_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *);
+ logical reset;
+ extern /* Subroutine */ int dtbsv_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *);
+ integer incxs;
+ char trans[1];
+ extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *,
+ doublereal *, doublereal *, integer *),
+ dtrmv_(char *, char *, char *, integer *, doublereal *, integer *,
+ doublereal *, integer *), dtpsv_(char *,
+ char *, char *, integer *, doublereal *, doublereal *, integer *);
+ char uplos[1];
+ extern /* Subroutine */ int dtrsv_(char *, char *, char *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ logical banded, packed;
+ extern logical lderes_(char *, char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, ftnlen, ftnlen);
+ doublereal errmax, transl;
+ char transs[1];
+
+ /* Fortran I/O blocks */
+ static cilist io___239 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___240 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___241 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___242 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___243 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___244 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___245 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___248 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___250 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___251 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___252 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___253 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___254 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___255 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests DTRMV, DTBMV, DTPMV, DTRSV, DTBSV and DTPSV. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --kb;
+ --inc;
+ --z__;
+ --g;
+ --xt;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --xs;
+ --xx;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ full = *(unsigned char *)&sname[2] == 'R';
+ banded = *(unsigned char *)&sname[2] == 'B';
+ packed = *(unsigned char *)&sname[2] == 'P';
+/* Define the number of arguments. */
+ if (full) {
+ nargs = 8;
+ } else if (banded) {
+ nargs = 9;
+ } else if (packed) {
+ nargs = 7;
+ }
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.;
+/* Set up zero vector for DMVCH. */
+ i__1 = *nmax;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ z__[i__] = 0.;
+/* L10: */
+ }
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+
+ if (banded) {
+ nk = *nkb;
+ } else {
+ nk = 1;
+ }
+ i__2 = nk;
+ for (ik = 1; ik <= i__2; ++ik) {
+ if (banded) {
+ k = kb[ik];
+ } else {
+ k = n - 1;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ if (banded) {
+ lda = k + 1;
+ } else {
+ lda = n;
+ }
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L100;
+ }
+ if (packed) {
+ laa = n * (n + 1) / 2;
+ } else {
+ laa = lda * n;
+ }
+ null = n <= 0;
+
+ for (icu = 1; icu <= 2; ++icu) {
+ *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
+
+ for (ict = 1; ict <= 3; ++ict) {
+ *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]
+ ;
+
+ for (icd = 1; icd <= 2; ++icd) {
+ *(unsigned char *)diag = *(unsigned char *)&ichd[icd
+ - 1];
+
+/* Generate the matrix A. */
+
+ transl = 0.;
+ dmake_(sname + 1, uplo, diag, &n, &n, &a[a_offset],
+ nmax, &aa[1], &lda, &k, &k, &reset, &transl, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ i__3 = *ninc;
+ for (ix = 1; ix <= i__3; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * n;
+
+/* Generate the vector X. */
+
+ transl = .5;
+ i__4 = abs(incx);
+ i__5 = n - 1;
+ dmake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &
+ xx[1], &i__4, &c__0, &i__5, &reset, &
+ transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);
+ if (n > 1) {
+ x[n / 2] = 0.;
+ xx[abs(incx) * (n / 2 - 1) + 1] = 0.;
+ }
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ *(unsigned char *)transs = *(unsigned char *)
+ trans;
+ *(unsigned char *)diags = *(unsigned char *)diag;
+ ns = n;
+ ks = k;
+ i__4 = laa;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ as[i__] = aa[i__];
+/* L20: */
+ }
+ ldas = lda;
+ i__4 = lx;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ xs[i__] = xx[i__];
+/* L30: */
+ }
+ incxs = incx;
+
+/* Call the subroutine. */
+
+ if (s_cmp(sname + 3, "MV", (ftnlen)2, (ftnlen)2)
+ == 0) {
+ if (full) {
+ if (*trace) {
+ io___239.ciunit = *ntra;
+ s_wsfe(&io___239);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ dtrmv_(uplo, trans, diag, &n, &aa[1], &
+ lda, &xx[1], &incx);
+ } else if (banded) {
+ if (*trace) {
+ io___240.ciunit = *ntra;
+ s_wsfe(&io___240);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ dtbmv_(uplo, trans, diag, &n, &k, &aa[1],
+ &lda, &xx[1], &incx);
+ } else if (packed) {
+ if (*trace) {
+ io___241.ciunit = *ntra;
+ s_wsfe(&io___241);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ dtpmv_(uplo, trans, diag, &n, &aa[1], &xx[
+ 1], &incx);
+ }
+ } else if (s_cmp(sname + 3, "SV", (ftnlen)2, (
+ ftnlen)2) == 0) {
+ if (full) {
+ if (*trace) {
+ io___242.ciunit = *ntra;
+ s_wsfe(&io___242);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ dtrsv_(uplo, trans, diag, &n, &aa[1], &
+ lda, &xx[1], &incx);
+ } else if (banded) {
+ if (*trace) {
+ io___243.ciunit = *ntra;
+ s_wsfe(&io___243);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ dtbsv_(uplo, trans, diag, &n, &k, &aa[1],
+ &lda, &xx[1], &incx);
+ } else if (packed) {
+ if (*trace) {
+ io___244.ciunit = *ntra;
+ s_wsfe(&io___244);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ dtpsv_(uplo, trans, diag, &n, &aa[1], &xx[
+ 1], &incx);
+ }
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___245.ciunit = *nout;
+ s_wsfe(&io___245);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplo == *(unsigned
+ char *)uplos;
+ isame[1] = *(unsigned char *)trans == *(unsigned
+ char *)transs;
+ isame[2] = *(unsigned char *)diag == *(unsigned
+ char *)diags;
+ isame[3] = ns == n;
+ if (full) {
+ isame[4] = lde_(&as[1], &aa[1], &laa);
+ isame[5] = ldas == lda;
+ if (null) {
+ isame[6] = lde_(&xs[1], &xx[1], &lx);
+ } else {
+ i__4 = abs(incx);
+ isame[6] = lderes_("GE", " ", &c__1, &n, &
+ xs[1], &xx[1], &i__4, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[7] = incxs == incx;
+ } else if (banded) {
+ isame[4] = ks == k;
+ isame[5] = lde_(&as[1], &aa[1], &laa);
+ isame[6] = ldas == lda;
+ if (null) {
+ isame[7] = lde_(&xs[1], &xx[1], &lx);
+ } else {
+ i__4 = abs(incx);
+ isame[7] = lderes_("GE", " ", &c__1, &n, &
+ xs[1], &xx[1], &i__4, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[8] = incxs == incx;
+ } else if (packed) {
+ isame[4] = lde_(&as[1], &aa[1], &laa);
+ if (null) {
+ isame[5] = lde_(&xs[1], &xx[1], &lx);
+ } else {
+ i__4 = abs(incx);
+ isame[5] = lderes_("GE", " ", &c__1, &n, &
+ xs[1], &xx[1], &i__4, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[6] = incxs == incx;
+ }
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__4 = nargs;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___248.ciunit = *nout;
+ s_wsfe(&io___248);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+ if (s_cmp(sname + 3, "MV", (ftnlen)2, (ftnlen)
+ 2) == 0) {
+
+/* Check the result. */
+
+ dmvch_(trans, &n, &n, &c_b121, &a[
+ a_offset], nmax, &x[1], &incx, &
+ c_b133, &z__[1], &incx, &xt[1], &
+ g[1], &xx[1], eps, &err, fatal,
+ nout, &c_true, (ftnlen)1);
+ } else if (s_cmp(sname + 3, "SV", (ftnlen)2, (
+ ftnlen)2) == 0) {
+
+/* Compute approximation to original vector. */
+
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ z__[i__] = xx[(i__ - 1) * abs(incx) +
+ 1];
+ xx[(i__ - 1) * abs(incx) + 1] = x[i__]
+ ;
+/* L50: */
+ }
+ dmvch_(trans, &n, &n, &c_b121, &a[
+ a_offset], nmax, &z__[1], &incx, &
+ c_b133, &x[1], &incx, &xt[1], &g[
+ 1], &xx[1], eps, &err, fatal,
+ nout, &c_false, (ftnlen)1);
+ }
+ errmax = max(errmax,err);
+/* If got really bad answer, report and return. */
+ if (*fatal) {
+ goto L120;
+ }
+ } else {
+/* Avoid repeating tests with N.le.0. */
+ goto L110;
+ }
+
+/* L60: */
+ }
+
+/* L70: */
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+L110:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___250.ciunit = *nout;
+ s_wsfe(&io___250);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___251.ciunit = *nout;
+ s_wsfe(&io___251);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ goto L130;
+
+L120:
+ io___252.ciunit = *nout;
+ s_wsfe(&io___252);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (full) {
+ io___253.ciunit = *nout;
+ s_wsfe(&io___253);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (banded) {
+ io___254.ciunit = *nout;
+ s_wsfe(&io___254);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (packed) {
+ io___255.ciunit = *nout;
+ s_wsfe(&io___255);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L130:
+ return 0;
+
+
+/* End of DCHK3. */
+
+} /* dchk3_ */
+
+/* Subroutine */ int dchk4_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublereal *alf,
+ integer *ninc, integer *inc, integer *nmax, integer *incmax,
+ doublereal *a, doublereal *aa, doublereal *as, doublereal *x,
+ doublereal *xx, doublereal *xs, doublereal *y, doublereal *yy,
+ doublereal *ys, doublereal *yt, doublereal *g, doublereal *z__,
+ ftnlen sname_len)
+{
+ /* Format strings */
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002(\002,2(i3,\002,\002)"
+ ",f4.1,\002, X,\002,i2,\002, Y,\002,i2,\002, A,\002,i3,\002) "
+ " .\002)";
+ static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, j, m, n;
+ doublereal w[1];
+ integer ia, nc, nd, im, in, ms, ix, iy, ns, lx, ly, laa, lda;
+ extern logical lde_(doublereal *, doublereal *, integer *);
+ doublereal als, err;
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer ldas;
+ logical same;
+ integer incx, incy;
+ logical null;
+ extern /* Subroutine */ int dmake_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *, logical *, doublereal *, ftnlen, ftnlen,
+ ftnlen);
+ doublereal alpha;
+ logical isame[13];
+ extern /* Subroutine */ int dmvch_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, logical *, integer *,
+ logical *, ftnlen);
+ integer nargs;
+ logical reset;
+ integer incxs, incys;
+ extern logical lderes_(char *, char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, ftnlen, ftnlen);
+ doublereal errmax, transl;
+
+ /* Fortran I/O blocks */
+ static cilist io___284 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___285 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___288 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___292 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___293 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___294 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___295 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___296 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* Tests DGER. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+/* Define the number of arguments. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --inc;
+ --z__;
+ --g;
+ --yt;
+ --y;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ys;
+ --yy;
+ --xs;
+ --xx;
+
+ /* Function Body */
+ nargs = 9;
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+ nd = n / 2 + 1;
+
+ for (im = 1; im <= 2; ++im) {
+ if (im == 1) {
+/* Computing MAX */
+ i__2 = n - nd;
+ m = max(i__2,0);
+ }
+ if (im == 2) {
+/* Computing MIN */
+ i__2 = n + nd;
+ m = min(i__2,*nmax);
+ }
+
+/* Set LDA to 1 more than minimum value if room. */
+ lda = m;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L110;
+ }
+ laa = lda * n;
+ null = n <= 0 || m <= 0;
+
+ i__2 = *ninc;
+ for (ix = 1; ix <= i__2; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * m;
+
+/* Generate the vector X. */
+
+ transl = .5;
+ i__3 = abs(incx);
+ i__4 = m - 1;
+ dmake_("GE", " ", " ", &c__1, &m, &x[1], &c__1, &xx[1], &i__3,
+ &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1,
+ (ftnlen)1);
+ if (m > 1) {
+ x[m / 2] = 0.;
+ xx[abs(incx) * (m / 2 - 1) + 1] = 0.;
+ }
+
+ i__3 = *ninc;
+ for (iy = 1; iy <= i__3; ++iy) {
+ incy = inc[iy];
+ ly = abs(incy) * n;
+
+/* Generate the vector Y. */
+
+ transl = 0.;
+ i__4 = abs(incy);
+ i__5 = n - 1;
+ dmake_("GE", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], &
+ i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (
+ ftnlen)1, (ftnlen)1);
+ if (n > 1) {
+ y[n / 2] = 0.;
+ yy[abs(incy) * (n / 2 - 1) + 1] = 0.;
+ }
+
+ i__4 = *nalf;
+ for (ia = 1; ia <= i__4; ++ia) {
+ alpha = alf[ia];
+
+/* Generate the matrix A. */
+
+ transl = 0.;
+ i__5 = m - 1;
+ i__6 = n - 1;
+ dmake_(sname + 1, " ", " ", &m, &n, &a[a_offset],
+ nmax, &aa[1], &lda, &i__5, &i__6, &reset, &
+ transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ ms = m;
+ ns = n;
+ als = alpha;
+ i__5 = laa;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ as[i__] = aa[i__];
+/* L10: */
+ }
+ ldas = lda;
+ i__5 = lx;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ xs[i__] = xx[i__];
+/* L20: */
+ }
+ incxs = incx;
+ i__5 = ly;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ ys[i__] = yy[i__];
+/* L30: */
+ }
+ incys = incy;
+
+/* Call the subroutine. */
+
+ if (*trace) {
+ io___284.ciunit = *ntra;
+ s_wsfe(&io___284);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ dger_(&m, &n, &alpha, &xx[1], &incx, &yy[1], &incy, &
+ aa[1], &lda);
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___285.ciunit = *nout;
+ s_wsfe(&io___285);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L140;
+ }
+
+/* See what data changed inside subroutine. */
+
+ isame[0] = ms == m;
+ isame[1] = ns == n;
+ isame[2] = als == alpha;
+ isame[3] = lde_(&xs[1], &xx[1], &lx);
+ isame[4] = incxs == incx;
+ isame[5] = lde_(&ys[1], &yy[1], &ly);
+ isame[6] = incys == incy;
+ if (null) {
+ isame[7] = lde_(&as[1], &aa[1], &laa);
+ } else {
+ isame[7] = lderes_("GE", " ", &m, &n, &as[1], &aa[
+ 1], &lda, (ftnlen)2, (ftnlen)1);
+ }
+ isame[8] = ldas == lda;
+
+/* If data was incorrectly changed, report and return. */
+
+ same = TRUE_;
+ i__5 = nargs;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___288.ciunit = *nout;
+ s_wsfe(&io___288);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L140;
+ }
+
+ if (! null) {
+
+/* Check the result column by column. */
+
+ if (incx > 0) {
+ i__5 = m;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ z__[i__] = x[i__];
+/* L50: */
+ }
+ } else {
+ i__5 = m;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ z__[i__] = x[m - i__ + 1];
+/* L60: */
+ }
+ }
+ i__5 = n;
+ for (j = 1; j <= i__5; ++j) {
+ if (incy > 0) {
+ w[0] = y[j];
+ } else {
+ w[0] = y[n - j + 1];
+ }
+ dmvch_("N", &m, &c__1, &alpha, &z__[1], nmax,
+ w, &c__1, &c_b121, &a[j * a_dim1 + 1],
+ &c__1, &yt[1], &g[1], &aa[(j - 1) *
+ lda + 1], eps, &err, fatal, nout, &
+ c_true, (ftnlen)1);
+ errmax = max(errmax,err);
+/* If got really bad answer, report and return. */
+ if (*fatal) {
+ goto L130;
+ }
+/* L70: */
+ }
+ } else {
+/* Avoid repeating tests with M.le.0 or N.le.0. */
+ goto L110;
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+/* L100: */
+ }
+
+L110:
+ ;
+ }
+
+/* L120: */
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___292.ciunit = *nout;
+ s_wsfe(&io___292);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___293.ciunit = *nout;
+ s_wsfe(&io___293);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ goto L150;
+
+L130:
+ io___294.ciunit = *nout;
+ s_wsfe(&io___294);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L140:
+ io___295.ciunit = *nout;
+ s_wsfe(&io___295);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ io___296.ciunit = *nout;
+ s_wsfe(&io___296);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L150:
+ return 0;
+
+
+/* End of DCHK4. */
+
+} /* dchk4_ */
+
+/* Subroutine */ int dchk5_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublereal *alf,
+ integer *ninc, integer *inc, integer *nmax, integer *incmax,
+ doublereal *a, doublereal *aa, doublereal *as, doublereal *x,
+ doublereal *xx, doublereal *xs, doublereal *y, doublereal *yy,
+ doublereal *ys, doublereal *yt, doublereal *g, doublereal *z__,
+ ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ich[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,\002,f4.1,\002, X,\002,i2,\002, A,\002,i3,\002) "
+ " .\002)";
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,\002,f4.1,\002, X,\002,i2,\002, AP) "
+ " .\002)";
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, j, n;
+ doublereal w[1];
+ integer ia, ja, ic, nc, jj, lj, in, ix, ns, lx, laa, lda;
+ extern logical lde_(doublereal *, doublereal *, integer *);
+ doublereal als, err;
+ integer ldas;
+ logical same;
+ integer incx;
+ logical full;
+ extern /* Subroutine */ int dspr_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *);
+ logical null;
+ char uplo[1];
+ extern /* Subroutine */ int dsyr_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *), dmake_(
+ char *, char *, char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, integer *, logical
+ *, doublereal *, ftnlen, ftnlen, ftnlen);
+ doublereal alpha;
+ logical isame[13];
+ extern /* Subroutine */ int dmvch_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, logical *, integer *,
+ logical *, ftnlen);
+ integer nargs;
+ logical reset;
+ integer incxs;
+ logical upper;
+ char uplos[1];
+ logical packed;
+ extern logical lderes_(char *, char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, ftnlen, ftnlen);
+ doublereal errmax, transl;
+
+ /* Fortran I/O blocks */
+ static cilist io___324 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___325 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___326 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___329 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___336 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___337 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___338 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___339 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___340 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___341 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* Tests DSYR and DSPR. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --inc;
+ --z__;
+ --g;
+ --yt;
+ --y;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ys;
+ --yy;
+ --xs;
+ --xx;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ full = *(unsigned char *)&sname[2] == 'Y';
+ packed = *(unsigned char *)&sname[2] == 'P';
+/* Define the number of arguments. */
+ if (full) {
+ nargs = 7;
+ } else if (packed) {
+ nargs = 6;
+ }
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+/* Set LDA to 1 more than minimum value if room. */
+ lda = n;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L100;
+ }
+ if (packed) {
+ laa = n * (n + 1) / 2;
+ } else {
+ laa = lda * n;
+ }
+
+ for (ic = 1; ic <= 2; ++ic) {
+ *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];
+ upper = *(unsigned char *)uplo == 'U';
+
+ i__2 = *ninc;
+ for (ix = 1; ix <= i__2; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * n;
+
+/* Generate the vector X. */
+
+ transl = .5;
+ i__3 = abs(incx);
+ i__4 = n - 1;
+ dmake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3,
+ &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1,
+ (ftnlen)1);
+ if (n > 1) {
+ x[n / 2] = 0.;
+ xx[abs(incx) * (n / 2 - 1) + 1] = 0.;
+ }
+
+ i__3 = *nalf;
+ for (ia = 1; ia <= i__3; ++ia) {
+ alpha = alf[ia];
+ null = n <= 0 || alpha == 0.;
+
+/* Generate the matrix A. */
+
+ transl = 0.;
+ i__4 = n - 1;
+ i__5 = n - 1;
+ dmake_(sname + 1, uplo, " ", &n, &n, &a[a_offset], nmax, &
+ aa[1], &lda, &i__4, &i__5, &reset, &transl, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ ns = n;
+ als = alpha;
+ i__4 = laa;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ as[i__] = aa[i__];
+/* L10: */
+ }
+ ldas = lda;
+ i__4 = lx;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ xs[i__] = xx[i__];
+/* L20: */
+ }
+ incxs = incx;
+
+/* Call the subroutine. */
+
+ if (full) {
+ if (*trace) {
+ io___324.ciunit = *ntra;
+ s_wsfe(&io___324);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ dsyr_(uplo, &n, &alpha, &xx[1], &incx, &aa[1], &lda);
+ } else if (packed) {
+ if (*trace) {
+ io___325.ciunit = *ntra;
+ s_wsfe(&io___325);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ dspr_(uplo, &n, &alpha, &xx[1], &incx, &aa[1]);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___326.ciunit = *nout;
+ s_wsfe(&io___326);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplo == *(unsigned char *)
+ uplos;
+ isame[1] = ns == n;
+ isame[2] = als == alpha;
+ isame[3] = lde_(&xs[1], &xx[1], &lx);
+ isame[4] = incxs == incx;
+ if (null) {
+ isame[5] = lde_(&as[1], &aa[1], &laa);
+ } else {
+ isame[5] = lderes_(sname + 1, uplo, &n, &n, &as[1], &
+ aa[1], &lda, (ftnlen)2, (ftnlen)1);
+ }
+ if (! packed) {
+ isame[6] = ldas == lda;
+ }
+
+/* If data was incorrectly changed, report and return. */
+
+ same = TRUE_;
+ i__4 = nargs;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___329.ciunit = *nout;
+ s_wsfe(&io___329);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+/* L30: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+
+/* Check the result column by column. */
+
+ if (incx > 0) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ z__[i__] = x[i__];
+/* L40: */
+ }
+ } else {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ z__[i__] = x[n - i__ + 1];
+/* L50: */
+ }
+ }
+ ja = 1;
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ w[0] = z__[j];
+ if (upper) {
+ jj = 1;
+ lj = j;
+ } else {
+ jj = j;
+ lj = n - j + 1;
+ }
+ dmvch_("N", &lj, &c__1, &alpha, &z__[jj], &lj, w,
+ &c__1, &c_b121, &a[jj + j * a_dim1], &
+ c__1, &yt[1], &g[1], &aa[ja], eps, &err,
+ fatal, nout, &c_true, (ftnlen)1);
+ if (full) {
+ if (upper) {
+ ja += lda;
+ } else {
+ ja = ja + lda + 1;
+ }
+ } else {
+ ja += lj;
+ }
+ errmax = max(errmax,err);
+/* If got really bad answer, report and return. */
+ if (*fatal) {
+ goto L110;
+ }
+/* L60: */
+ }
+ } else {
+/* Avoid repeating tests if N.le.0. */
+ if (n <= 0) {
+ goto L100;
+ }
+ }
+
+/* L70: */
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___336.ciunit = *nout;
+ s_wsfe(&io___336);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___337.ciunit = *nout;
+ s_wsfe(&io___337);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ goto L130;
+
+L110:
+ io___338.ciunit = *nout;
+ s_wsfe(&io___338);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L120:
+ io___339.ciunit = *nout;
+ s_wsfe(&io___339);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (full) {
+ io___340.ciunit = *nout;
+ s_wsfe(&io___340);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (packed) {
+ io___341.ciunit = *nout;
+ s_wsfe(&io___341);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L130:
+ return 0;
+
+
+/* End of DCHK5. */
+
+} /* dchk5_ */
+
+/* Subroutine */ int dchk6_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublereal *alf,
+ integer *ninc, integer *inc, integer *nmax, integer *incmax,
+ doublereal *a, doublereal *aa, doublereal *as, doublereal *x,
+ doublereal *xx, doublereal *xs, doublereal *y, doublereal *yy,
+ doublereal *ys, doublereal *yt, doublereal *g, doublereal *z__,
+ ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ich[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,\002,f4.1,\002, X,\002,i2,\002, Y,\002,i2,\002, A,\002,i"
+ "3,\002) .\002)";
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,\002,f4.1,\002, X,\002,i2,\002, Y,\002,i2,\002, AP) "
+ " .\002)";
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, j, n;
+ doublereal w[2];
+ integer ia, ja, ic, nc, jj, lj, in, ix, iy, ns, lx, ly, laa, lda;
+ extern logical lde_(doublereal *, doublereal *, integer *);
+ doublereal als, err;
+ integer ldas;
+ logical same;
+ integer incx, incy;
+ logical full, null;
+ char uplo[1];
+ extern /* Subroutine */ int dspr2_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *), dsyr2_(char *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *), dmake_(char *, char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *, logical *, doublereal *, ftnlen, ftnlen, ftnlen);
+ doublereal alpha;
+ logical isame[13];
+ extern /* Subroutine */ int dmvch_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, logical *, integer *,
+ logical *, ftnlen);
+ integer nargs;
+ logical reset;
+ integer incxs, incys;
+ logical upper;
+ char uplos[1];
+ logical packed;
+ extern logical lderes_(char *, char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, ftnlen, ftnlen);
+ doublereal errmax, transl;
+
+ /* Fortran I/O blocks */
+ static cilist io___373 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___374 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___375 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___378 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___385 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___386 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___387 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___388 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___389 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___390 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* Tests DSYR2 and DSPR2. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --inc;
+ z_dim1 = *nmax;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --g;
+ --yt;
+ --y;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ys;
+ --yy;
+ --xs;
+ --xx;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ full = *(unsigned char *)&sname[2] == 'Y';
+ packed = *(unsigned char *)&sname[2] == 'P';
+/* Define the number of arguments. */
+ if (full) {
+ nargs = 9;
+ } else if (packed) {
+ nargs = 8;
+ }
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+/* Set LDA to 1 more than minimum value if room. */
+ lda = n;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L140;
+ }
+ if (packed) {
+ laa = n * (n + 1) / 2;
+ } else {
+ laa = lda * n;
+ }
+
+ for (ic = 1; ic <= 2; ++ic) {
+ *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];
+ upper = *(unsigned char *)uplo == 'U';
+
+ i__2 = *ninc;
+ for (ix = 1; ix <= i__2; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * n;
+
+/* Generate the vector X. */
+
+ transl = .5;
+ i__3 = abs(incx);
+ i__4 = n - 1;
+ dmake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3,
+ &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1,
+ (ftnlen)1);
+ if (n > 1) {
+ x[n / 2] = 0.;
+ xx[abs(incx) * (n / 2 - 1) + 1] = 0.;
+ }
+
+ i__3 = *ninc;
+ for (iy = 1; iy <= i__3; ++iy) {
+ incy = inc[iy];
+ ly = abs(incy) * n;
+
+/* Generate the vector Y. */
+
+ transl = 0.;
+ i__4 = abs(incy);
+ i__5 = n - 1;
+ dmake_("GE", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], &
+ i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (
+ ftnlen)1, (ftnlen)1);
+ if (n > 1) {
+ y[n / 2] = 0.;
+ yy[abs(incy) * (n / 2 - 1) + 1] = 0.;
+ }
+
+ i__4 = *nalf;
+ for (ia = 1; ia <= i__4; ++ia) {
+ alpha = alf[ia];
+ null = n <= 0 || alpha == 0.;
+
+/* Generate the matrix A. */
+
+ transl = 0.;
+ i__5 = n - 1;
+ i__6 = n - 1;
+ dmake_(sname + 1, uplo, " ", &n, &n, &a[a_offset],
+ nmax, &aa[1], &lda, &i__5, &i__6, &reset, &
+ transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ ns = n;
+ als = alpha;
+ i__5 = laa;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ as[i__] = aa[i__];
+/* L10: */
+ }
+ ldas = lda;
+ i__5 = lx;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ xs[i__] = xx[i__];
+/* L20: */
+ }
+ incxs = incx;
+ i__5 = ly;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ ys[i__] = yy[i__];
+/* L30: */
+ }
+ incys = incy;
+
+/* Call the subroutine. */
+
+ if (full) {
+ if (*trace) {
+ io___373.ciunit = *ntra;
+ s_wsfe(&io___373);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ dsyr2_(uplo, &n, &alpha, &xx[1], &incx, &yy[1], &
+ incy, &aa[1], &lda);
+ } else if (packed) {
+ if (*trace) {
+ io___374.ciunit = *ntra;
+ s_wsfe(&io___374);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ dspr2_(uplo, &n, &alpha, &xx[1], &incx, &yy[1], &
+ incy, &aa[1]);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___375.ciunit = *nout;
+ s_wsfe(&io___375);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L160;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplo == *(unsigned char *
+ )uplos;
+ isame[1] = ns == n;
+ isame[2] = als == alpha;
+ isame[3] = lde_(&xs[1], &xx[1], &lx);
+ isame[4] = incxs == incx;
+ isame[5] = lde_(&ys[1], &yy[1], &ly);
+ isame[6] = incys == incy;
+ if (null) {
+ isame[7] = lde_(&as[1], &aa[1], &laa);
+ } else {
+ isame[7] = lderes_(sname + 1, uplo, &n, &n, &as[1]
+ , &aa[1], &lda, (ftnlen)2, (ftnlen)1);
+ }
+ if (! packed) {
+ isame[8] = ldas == lda;
+ }
+
+/* If data was incorrectly changed, report and return. */
+
+ same = TRUE_;
+ i__5 = nargs;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___378.ciunit = *nout;
+ s_wsfe(&io___378);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L160;
+ }
+
+ if (! null) {
+
+/* Check the result column by column. */
+
+ if (incx > 0) {
+ i__5 = n;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ z__[i__ + z_dim1] = x[i__];
+/* L50: */
+ }
+ } else {
+ i__5 = n;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ z__[i__ + z_dim1] = x[n - i__ + 1];
+/* L60: */
+ }
+ }
+ if (incy > 0) {
+ i__5 = n;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ z__[i__ + (z_dim1 << 1)] = y[i__];
+/* L70: */
+ }
+ } else {
+ i__5 = n;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ z__[i__ + (z_dim1 << 1)] = y[n - i__ + 1];
+/* L80: */
+ }
+ }
+ ja = 1;
+ i__5 = n;
+ for (j = 1; j <= i__5; ++j) {
+ w[0] = z__[j + (z_dim1 << 1)];
+ w[1] = z__[j + z_dim1];
+ if (upper) {
+ jj = 1;
+ lj = j;
+ } else {
+ jj = j;
+ lj = n - j + 1;
+ }
+ dmvch_("N", &lj, &c__2, &alpha, &z__[jj +
+ z_dim1], nmax, w, &c__1, &c_b121, &a[
+ jj + j * a_dim1], &c__1, &yt[1], &g[1]
+ , &aa[ja], eps, &err, fatal, nout, &
+ c_true, (ftnlen)1);
+ if (full) {
+ if (upper) {
+ ja += lda;
+ } else {
+ ja = ja + lda + 1;
+ }
+ } else {
+ ja += lj;
+ }
+ errmax = max(errmax,err);
+/* If got really bad answer, report and return. */
+ if (*fatal) {
+ goto L150;
+ }
+/* L90: */
+ }
+ } else {
+/* Avoid repeating tests with N.le.0. */
+ if (n <= 0) {
+ goto L140;
+ }
+ }
+
+/* L100: */
+ }
+
+/* L110: */
+ }
+
+/* L120: */
+ }
+
+/* L130: */
+ }
+
+L140:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___385.ciunit = *nout;
+ s_wsfe(&io___385);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___386.ciunit = *nout;
+ s_wsfe(&io___386);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ goto L170;
+
+L150:
+ io___387.ciunit = *nout;
+ s_wsfe(&io___387);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L160:
+ io___388.ciunit = *nout;
+ s_wsfe(&io___388);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (full) {
+ io___389.ciunit = *nout;
+ s_wsfe(&io___389);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (packed) {
+ io___390.ciunit = *nout;
+ s_wsfe(&io___390);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L170:
+ return 0;
+
+
+/* End of DCHK6. */
+
+} /* dchk6_ */
+
+/* Subroutine */ int dchke_(integer *isnum, char *srnamt, integer *nout,
+ ftnlen srnamt_len)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE TESTS OF ERROR-E"
+ "XITS\002)";
+ static char fmt_9998[] = "(\002 ******* \002,a6,\002 FAILED THE TESTS OF"
+ " ERROR-EXITS *****\002,\002**\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublereal a[1] /* was [1][1] */, x[1], y[1], beta;
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dspr_(char *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *), dsyr_(char *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *), dspr2_(char *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *), dsyr2_(
+ char *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ doublereal alpha;
+ extern /* Subroutine */ int dgbmv_(char *, integer *, integer *, integer *
+, integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *), dgemv_(
+ char *, integer *, integer *, doublereal *, doublereal *, integer
+ *, doublereal *, integer *, doublereal *, doublereal *, integer *), dsbmv_(char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *), dtbmv_(char *, char *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dtbsv_(char *, char *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dspmv_(char *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *), dtpmv_(char *, char *, char *,
+ integer *, doublereal *, doublereal *, integer *), dtrmv_(char *, char *, char *, integer *, doublereal *,
+ integer *, doublereal *, integer *),
+ dtpsv_(char *, char *, char *, integer *, doublereal *,
+ doublereal *, integer *), dsymv_(char *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *), dtrsv_(
+ char *, char *, char *, integer *, doublereal *, integer *,
+ doublereal *, integer *), chkxer_(char *,
+ integer *, integer *, logical *, logical *);
+
+ /* Fortran I/O blocks */
+ static cilist io___396 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___397 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* Tests the error exits from the Level 2 Blas. */
+/* Requires a special version of the error-handling routine XERBLA. */
+/* ALPHA, BETA, A, X and Y should not need to be defined. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Subroutines .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+/* OK is set to .FALSE. by the special version of XERBLA or by CHKXER */
+/* if anything is wrong. */
+ infoc_1.ok = TRUE_;
+/* LERR is set to .TRUE. by the special version of XERBLA each time */
+/* it is called, and is then tested and re-set by CHKXER. */
+ infoc_1.lerr = FALSE_;
+ switch (*isnum) {
+ case 1: goto L10;
+ case 2: goto L20;
+ case 3: goto L30;
+ case 4: goto L40;
+ case 5: goto L50;
+ case 6: goto L60;
+ case 7: goto L70;
+ case 8: goto L80;
+ case 9: goto L90;
+ case 10: goto L100;
+ case 11: goto L110;
+ case 12: goto L120;
+ case 13: goto L130;
+ case 14: goto L140;
+ case 15: goto L150;
+ case 16: goto L160;
+ }
+L10:
+ infoc_1.infot = 1;
+ dgemv_("/", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ dgemv_("N", &c_n1, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dgemv_("N", &c__0, &c_n1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ dgemv_("N", &c__2, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ dgemv_("N", &c__0, &c__0, &alpha, a, &c__1, x, &c__0, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ dgemv_("N", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L20:
+ infoc_1.infot = 1;
+ dgbmv_("/", &c__0, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ dgbmv_("N", &c_n1, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dgbmv_("N", &c__0, &c_n1, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dgbmv_("N", &c__0, &c__0, &c_n1, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dgbmv_("N", &c__2, &c__0, &c__0, &c_n1, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ dgbmv_("N", &c__0, &c__0, &c__1, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ dgbmv_("N", &c__0, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__0, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ dgbmv_("N", &c__0, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L30:
+ infoc_1.infot = 1;
+ dsymv_("/", &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ dsymv_("U", &c_n1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dsymv_("U", &c__2, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ dsymv_("U", &c__0, &alpha, a, &c__1, x, &c__0, &beta, y, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ dsymv_("U", &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__0)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L40:
+ infoc_1.infot = 1;
+ dsbmv_("/", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ dsbmv_("U", &c_n1, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dsbmv_("U", &c__0, &c_n1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ dsbmv_("U", &c__0, &c__1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ dsbmv_("U", &c__0, &c__0, &alpha, a, &c__1, x, &c__0, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ dsbmv_("U", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L50:
+ infoc_1.infot = 1;
+ dspmv_("/", &c__0, &alpha, a, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ dspmv_("U", &c_n1, &alpha, a, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ dspmv_("U", &c__0, &alpha, a, x, &c__0, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dspmv_("U", &c__0, &alpha, a, x, &c__1, &beta, y, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L60:
+ infoc_1.infot = 1;
+ dtrmv_("/", "N", "N", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ dtrmv_("U", "/", "N", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dtrmv_("U", "N", "/", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dtrmv_("U", "N", "N", &c_n1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ dtrmv_("U", "N", "N", &c__2, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ dtrmv_("U", "N", "N", &c__0, a, &c__1, x, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L70:
+ infoc_1.infot = 1;
+ dtbmv_("/", "N", "N", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ dtbmv_("U", "/", "N", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dtbmv_("U", "N", "/", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dtbmv_("U", "N", "N", &c_n1, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dtbmv_("U", "N", "N", &c__0, &c_n1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ dtbmv_("U", "N", "N", &c__0, &c__1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dtbmv_("U", "N", "N", &c__0, &c__0, a, &c__1, x, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L80:
+ infoc_1.infot = 1;
+ dtpmv_("/", "N", "N", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ dtpmv_("U", "/", "N", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dtpmv_("U", "N", "/", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dtpmv_("U", "N", "N", &c_n1, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ dtpmv_("U", "N", "N", &c__0, a, x, &c__0)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L90:
+ infoc_1.infot = 1;
+ dtrsv_("/", "N", "N", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ dtrsv_("U", "/", "N", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dtrsv_("U", "N", "/", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dtrsv_("U", "N", "N", &c_n1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ dtrsv_("U", "N", "N", &c__2, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ dtrsv_("U", "N", "N", &c__0, a, &c__1, x, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L100:
+ infoc_1.infot = 1;
+ dtbsv_("/", "N", "N", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ dtbsv_("U", "/", "N", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dtbsv_("U", "N", "/", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dtbsv_("U", "N", "N", &c_n1, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dtbsv_("U", "N", "N", &c__0, &c_n1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ dtbsv_("U", "N", "N", &c__0, &c__1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dtbsv_("U", "N", "N", &c__0, &c__0, a, &c__1, x, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L110:
+ infoc_1.infot = 1;
+ dtpsv_("/", "N", "N", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ dtpsv_("U", "/", "N", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dtpsv_("U", "N", "/", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dtpsv_("U", "N", "N", &c_n1, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ dtpsv_("U", "N", "N", &c__0, a, x, &c__0)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L120:
+ infoc_1.infot = 1;
+ dger_(&c_n1, &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ dger_(&c__0, &c_n1, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dger_(&c__0, &c__0, &alpha, x, &c__0, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ dger_(&c__0, &c__0, &alpha, x, &c__1, y, &c__0, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dger_(&c__2, &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L130:
+ infoc_1.infot = 1;
+ dsyr_("/", &c__0, &alpha, x, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ dsyr_("U", &c_n1, &alpha, x, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dsyr_("U", &c__0, &alpha, x, &c__0, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ dsyr_("U", &c__2, &alpha, x, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L140:
+ infoc_1.infot = 1;
+ dspr_("/", &c__0, &alpha, x, &c__1, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ dspr_("U", &c_n1, &alpha, x, &c__1, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dspr_("U", &c__0, &alpha, x, &c__0, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L150:
+ infoc_1.infot = 1;
+ dsyr2_("/", &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ dsyr2_("U", &c_n1, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dsyr2_("U", &c__0, &alpha, x, &c__0, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ dsyr2_("U", &c__0, &alpha, x, &c__1, y, &c__0, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dsyr2_("U", &c__2, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L160:
+ infoc_1.infot = 1;
+ dspr2_("/", &c__0, &alpha, x, &c__1, y, &c__1, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ dspr2_("U", &c_n1, &alpha, x, &c__1, y, &c__1, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dspr2_("U", &c__0, &alpha, x, &c__0, y, &c__1, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ dspr2_("U", &c__0, &alpha, x, &c__1, y, &c__0, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+
+L170:
+ if (infoc_1.ok) {
+ io___396.ciunit = *nout;
+ s_wsfe(&io___396);
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ } else {
+ io___397.ciunit = *nout;
+ s_wsfe(&io___397);
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ }
+ return 0;
+
+
+/* End of DCHKE. */
+
+} /* dchke_ */
+
+/* Subroutine */ int dmake_(char *type__, char *uplo, char *diag, integer *m,
+ integer *n, doublereal *a, integer *nmax, doublereal *aa, integer *
+ lda, integer *kl, integer *ku, logical *reset, doublereal *transl,
+ ftnlen type_len, ftnlen uplo_len, ftnlen diag_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer i__, j, i1, i2, i3, kk;
+ logical gen, tri, sym;
+ extern doublereal dbeg_(logical *);
+ integer ibeg, iend, ioff;
+ logical unit, lower, upper;
+
+
+/* Generates values for an M by N matrix A within the bandwidth */
+/* defined by KL and KU. */
+/* Stores the values in the array AA in the data structure required */
+/* by the routine, with unwanted elements set to rogue value. */
+
+/* TYPE is 'GE', 'GB', 'SY', 'SB', 'SP', 'TR', 'TB' OR 'TP'. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. External Functions .. */
+/* .. Intrinsic Functions .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --aa;
+
+ /* Function Body */
+ gen = *(unsigned char *)type__ == 'G';
+ sym = *(unsigned char *)type__ == 'S';
+ tri = *(unsigned char *)type__ == 'T';
+ upper = (sym || tri) && *(unsigned char *)uplo == 'U';
+ lower = (sym || tri) && *(unsigned char *)uplo == 'L';
+ unit = tri && *(unsigned char *)diag == 'U';
+
+/* Generate data in array A. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (gen || upper && i__ <= j || lower && i__ >= j) {
+ if (i__ <= j && j - i__ <= *ku || i__ >= j && i__ - j <= *kl)
+ {
+ a[i__ + j * a_dim1] = dbeg_(reset) + *transl;
+ } else {
+ a[i__ + j * a_dim1] = 0.;
+ }
+ if (i__ != j) {
+ if (sym) {
+ a[j + i__ * a_dim1] = a[i__ + j * a_dim1];
+ } else if (tri) {
+ a[j + i__ * a_dim1] = 0.;
+ }
+ }
+ }
+/* L10: */
+ }
+ if (tri) {
+ a[j + j * a_dim1] += 1.;
+ }
+ if (unit) {
+ a[j + j * a_dim1] = 1.;
+ }
+/* L20: */
+ }
+
+/* Store elements in array AS in data structure required by routine. */
+
+ if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1];
+/* L30: */
+ }
+ i__2 = *lda;
+ for (i__ = *m + 1; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = -1e10;
+/* L40: */
+ }
+/* L50: */
+ }
+ } else if (s_cmp(type__, "GB", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *ku + 1 - j;
+ for (i1 = 1; i1 <= i__2; ++i1) {
+ aa[i1 + (j - 1) * *lda] = -1e10;
+/* L60: */
+ }
+/* Computing MIN */
+ i__3 = *kl + *ku + 1, i__4 = *ku + 1 + *m - j;
+ i__2 = min(i__3,i__4);
+ for (i2 = i1; i2 <= i__2; ++i2) {
+ aa[i2 + (j - 1) * *lda] = a[i2 + j - *ku - 1 + j * a_dim1];
+/* L70: */
+ }
+ i__2 = *lda;
+ for (i3 = i2; i3 <= i__2; ++i3) {
+ aa[i3 + (j - 1) * *lda] = -1e10;
+/* L80: */
+ }
+/* L90: */
+ }
+ } else if (s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
+ "TR", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ ibeg = 1;
+ if (unit) {
+ iend = j - 1;
+ } else {
+ iend = j;
+ }
+ } else {
+ if (unit) {
+ ibeg = j + 1;
+ } else {
+ ibeg = j;
+ }
+ iend = *n;
+ }
+ i__2 = ibeg - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = -1e10;
+/* L100: */
+ }
+ i__2 = iend;
+ for (i__ = ibeg; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1];
+/* L110: */
+ }
+ i__2 = *lda;
+ for (i__ = iend + 1; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = -1e10;
+/* L120: */
+ }
+/* L130: */
+ }
+ } else if (s_cmp(type__, "SB", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
+ "TB", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ kk = *kl + 1;
+/* Computing MAX */
+ i__2 = 1, i__3 = *kl + 2 - j;
+ ibeg = max(i__2,i__3);
+ if (unit) {
+ iend = *kl;
+ } else {
+ iend = *kl + 1;
+ }
+ } else {
+ kk = 1;
+ if (unit) {
+ ibeg = 2;
+ } else {
+ ibeg = 1;
+ }
+/* Computing MIN */
+ i__2 = *kl + 1, i__3 = *m + 1 - j;
+ iend = min(i__2,i__3);
+ }
+ i__2 = ibeg - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = -1e10;
+/* L140: */
+ }
+ i__2 = iend;
+ for (i__ = ibeg; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = a[i__ + j - kk + j * a_dim1];
+/* L150: */
+ }
+ i__2 = *lda;
+ for (i__ = iend + 1; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = -1e10;
+/* L160: */
+ }
+/* L170: */
+ }
+ } else if (s_cmp(type__, "SP", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
+ "TP", (ftnlen)2, (ftnlen)2) == 0) {
+ ioff = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ ibeg = 1;
+ iend = j;
+ } else {
+ ibeg = j;
+ iend = *n;
+ }
+ i__2 = iend;
+ for (i__ = ibeg; i__ <= i__2; ++i__) {
+ ++ioff;
+ aa[ioff] = a[i__ + j * a_dim1];
+ if (i__ == j) {
+ if (unit) {
+ aa[ioff] = -1e10;
+ }
+ }
+/* L180: */
+ }
+/* L190: */
+ }
+ }
+ return 0;
+
+/* End of DMAKE. */
+
+} /* dmake_ */
+
+/* Subroutine */ int dmvch_(char *trans, integer *m, integer *n, doublereal *
+ alpha, doublereal *a, integer *nmax, doublereal *x, integer *incx,
+ doublereal *beta, doublereal *y, integer *incy, doublereal *yt,
+ doublereal *g, doublereal *yy, doublereal *eps, doublereal *err,
+ logical *fatal, integer *nout, logical *mv, ftnlen trans_len)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
+ " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 EX"
+ "PECTED RESULT COMPU\002,\002TED RESULT\002)";
+ static char fmt_9998[] = "(1x,i7,2g18.6)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, ml, nl, iy, jx, kx, ky;
+ doublereal erri;
+ logical tran;
+ integer incxl, incyl;
+
+ /* Fortran I/O blocks */
+ static cilist io___425 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___426 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___427 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* Checks the results of the computational tests. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Intrinsic Functions .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+ --yt;
+ --g;
+ --yy;
+
+ /* Function Body */
+ tran = *(unsigned char *)trans == 'T' || *(unsigned char *)trans == 'C';
+ if (tran) {
+ ml = *n;
+ nl = *m;
+ } else {
+ ml = *m;
+ nl = *n;
+ }
+ if (*incx < 0) {
+ kx = nl;
+ incxl = -1;
+ } else {
+ kx = 1;
+ incxl = 1;
+ }
+ if (*incy < 0) {
+ ky = ml;
+ incyl = -1;
+ } else {
+ ky = 1;
+ incyl = 1;
+ }
+
+/* Compute expected result in YT using data in A, X and Y. */
+/* Compute gauges in G. */
+
+ iy = ky;
+ i__1 = ml;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ yt[iy] = 0.;
+ g[iy] = 0.;
+ jx = kx;
+ if (tran) {
+ i__2 = nl;
+ for (j = 1; j <= i__2; ++j) {
+ yt[iy] += a[j + i__ * a_dim1] * x[jx];
+ g[iy] += (d__1 = a[j + i__ * a_dim1] * x[jx], abs(d__1));
+ jx += incxl;
+/* L10: */
+ }
+ } else {
+ i__2 = nl;
+ for (j = 1; j <= i__2; ++j) {
+ yt[iy] += a[i__ + j * a_dim1] * x[jx];
+ g[iy] += (d__1 = a[i__ + j * a_dim1] * x[jx], abs(d__1));
+ jx += incxl;
+/* L20: */
+ }
+ }
+ yt[iy] = *alpha * yt[iy] + *beta * y[iy];
+ g[iy] = abs(*alpha) * g[iy] + (d__1 = *beta * y[iy], abs(d__1));
+ iy += incyl;
+/* L30: */
+ }
+
+/* Compute the error ratio for this result. */
+
+ *err = 0.;
+ i__1 = ml;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ erri = (d__1 = yt[i__] - yy[(i__ - 1) * abs(*incy) + 1], abs(d__1)) /
+ *eps;
+ if (g[i__] != 0.) {
+ erri /= g[i__];
+ }
+ *err = max(*err,erri);
+ if (*err * sqrt(*eps) >= 1.) {
+ goto L50;
+ }
+/* L40: */
+ }
+/* If the loop completes, all results are at least half accurate. */
+ goto L70;
+
+/* Report fatal error. */
+
+L50:
+ *fatal = TRUE_;
+ io___425.ciunit = *nout;
+ s_wsfe(&io___425);
+ e_wsfe();
+ i__1 = ml;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*mv) {
+ io___426.ciunit = *nout;
+ s_wsfe(&io___426);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&yt[i__], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&yy[(i__ - 1) * abs(*incy) + 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___427.ciunit = *nout;
+ s_wsfe(&io___427);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&yy[(i__ - 1) * abs(*incy) + 1], (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&yt[i__], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+/* L60: */
+ }
+
+L70:
+ return 0;
+
+
+/* End of DMVCH. */
+
+} /* dmvch_ */
+
+logical lde_(doublereal *ri, doublereal *rj, integer *lr)
+{
+ /* System generated locals */
+ integer i__1;
+ logical ret_val;
+
+ /* Local variables */
+ integer i__;
+
+
+/* Tests if two arrays are identical. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ --rj;
+ --ri;
+
+ /* Function Body */
+ i__1 = *lr;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (ri[i__] != rj[i__]) {
+ goto L20;
+ }
+/* L10: */
+ }
+ ret_val = TRUE_;
+ goto L30;
+L20:
+ ret_val = FALSE_;
+L30:
+ return ret_val;
+
+/* End of LDE. */
+
+} /* lde_ */
+
+logical lderes_(char *type__, char *uplo, integer *m, integer *n, doublereal *
+ aa, doublereal *as, integer *lda, ftnlen type_len, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2;
+ logical ret_val;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer i__, j, ibeg, iend;
+ logical upper;
+
+
+/* Tests if selected elements in two arrays are equal. */
+
+/* TYPE is 'GE', 'SY' or 'SP'. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ as_dim1 = *lda;
+ as_offset = 1 + as_dim1;
+ as -= as_offset;
+ aa_dim1 = *lda;
+ aa_offset = 1 + aa_dim1;
+ aa -= aa_offset;
+
+ /* Function Body */
+ upper = *(unsigned char *)uplo == 'U';
+ if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *lda;
+ for (i__ = *m + 1; i__ <= i__2; ++i__) {
+ if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) {
+ goto L70;
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ ibeg = 1;
+ iend = j;
+ } else {
+ ibeg = j;
+ iend = *n;
+ }
+ i__2 = ibeg - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) {
+ goto L70;
+ }
+/* L30: */
+ }
+ i__2 = *lda;
+ for (i__ = iend + 1; i__ <= i__2; ++i__) {
+ if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) {
+ goto L70;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+/* L60: */
+ ret_val = TRUE_;
+ goto L80;
+L70:
+ ret_val = FALSE_;
+L80:
+ return ret_val;
+
+/* End of LDERES. */
+
+} /* lderes_ */
+
+doublereal dbeg_(logical *reset)
+{
+ /* System generated locals */
+ doublereal ret_val;
+
+ /* Local variables */
+ static integer i__, ic, mi;
+
+
+/* Generates random numbers uniformly distributed between -0.5 and 0.5. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Local Scalars .. */
+/* .. Save statement .. */
+/* .. Intrinsic Functions .. */
+/* .. Executable Statements .. */
+ if (*reset) {
+/* Initialize local variables. */
+ mi = 891;
+ i__ = 7;
+ ic = 0;
+ *reset = FALSE_;
+ }
+
+/* The sequence of values of I is bounded between 1 and 999. */
+/* If initial I = 1,2,3,6,7 or 9, the period will be 50. */
+/* If initial I = 4 or 8, the period will be 25. */
+/* If initial I = 5, the period will be 10. */
+/* IC is used to break up the period by skipping 1 value of I in 6. */
+
+ ++ic;
+L10:
+ i__ *= mi;
+ i__ -= i__ / 1000 * 1000;
+ if (ic >= 5) {
+ ic = 0;
+ goto L10;
+ }
+ ret_val = (doublereal) (i__ - 500) / 1001.;
+ return ret_val;
+
+/* End of DBEG. */
+
+} /* dbeg_ */
+
+doublereal ddiff_(doublereal *x, doublereal *y)
+{
+ /* System generated locals */
+ doublereal ret_val;
+
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+
+/* .. Scalar Arguments .. */
+/* .. Executable Statements .. */
+ ret_val = *x - *y;
+ return ret_val;
+
+/* End of DDIFF. */
+
+} /* ddiff_ */
+
+/* Subroutine */ int chkxer_(char *srnamt, integer *infot, integer *nout,
+ logical *lerr, logical *ok)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ***** ILLEGAL VALUE OF PARAMETER NUMBER"
+ " \002,i2,\002 NOT D\002,\002ETECTED BY \002,a6,\002 *****\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___437 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* Tests whether XERBLA has detected an error when it should. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Executable Statements .. */
+ if (! (*lerr)) {
+ io___437.ciunit = *nout;
+ s_wsfe(&io___437);
+ do_fio(&c__1, (char *)&(*infot), (ftnlen)sizeof(integer));
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ *ok = FALSE_;
+ }
+ *lerr = FALSE_;
+ return 0;
+
+
+/* End of CHKXER. */
+
+} /* chkxer_ */
+
+/* Subroutine */ int xerbla_(char *srname, integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* XERBLA WAS CALLED WITH INFO ="
+ " \002,i6,\002 INSTEAD\002,\002 OF \002,i2,\002 *******\002)";
+ static char fmt_9997[] = "(\002 ******* XERBLA WAS CALLED WITH INFO ="
+ " \002,i6,\002 *******\002)";
+ static char fmt_9998[] = "(\002 ******* XERBLA WAS CALLED WITH SRNAME ="
+ " \002,a6,\002 INSTE\002,\002AD OF \002,a6,\002 *******\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Fortran I/O blocks */
+ static cilist io___438 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___439 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___440 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* This is a special version of XERBLA to be used only as part of */
+/* the test program for testing error exits from the Level 2 BLAS */
+/* routines. */
+
+/* XERBLA is an error handler for the Level 2 BLAS routines. */
+
+/* It is called by the Level 2 BLAS routines if an input parameter is */
+/* invalid. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+ infoc_2.lerr = TRUE_;
+ if (*info != infoc_2.infot) {
+ if (infoc_2.infot != 0) {
+ io___438.ciunit = infoc_2.nout;
+ s_wsfe(&io___438);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&infoc_2.infot, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___439.ciunit = infoc_2.nout;
+ s_wsfe(&io___439);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ infoc_2.ok = FALSE_;
+ }
+ if (s_cmp(srname, srnamc_1.srnamt, (ftnlen)6, (ftnlen)6) != 0) {
+ io___440.ciunit = infoc_2.nout;
+ s_wsfe(&io___440);
+ do_fio(&c__1, srname, (ftnlen)6);
+ do_fio(&c__1, srnamc_1.srnamt, (ftnlen)6);
+ e_wsfe();
+ infoc_2.ok = FALSE_;
+ }
+ return 0;
+
+
+/* End of XERBLA */
+
+} /* xerbla_ */
+
+/* Main program alias */ int dblat2_ () { MAIN__ (); return 0; }
diff --git a/BLAS/TESTING/dblat3.c b/BLAS/TESTING/dblat3.c
new file mode 100644
index 0000000..8088582
--- /dev/null
+++ b/BLAS/TESTING/dblat3.c
@@ -0,0 +1,4348 @@
+/* dblat3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+union {
+ struct {
+ integer infot, noutc;
+ logical ok, lerr;
+ } _1;
+ struct {
+ integer infot, nout;
+ logical ok, lerr;
+ } _2;
+} infoc_;
+
+#define infoc_1 (infoc_._1)
+#define infoc_2 (infoc_._2)
+
+struct {
+ char srnamt[6];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__9 = 9;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__8 = 8;
+static integer c__5 = 5;
+static integer c__65 = 65;
+static integer c__7 = 7;
+static doublereal c_b87 = 1.;
+static doublereal c_b101 = 0.;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Initialized data */
+
+ static char snames[6*6] = "DGEMM " "DSYMM " "DTRMM " "DTRSM " "DSYRK "
+ "DSYR2K";
+
+ /* Format strings */
+ static char fmt_9997[] = "(\002 NUMBER OF VALUES OF \002,a,\002 IS LESS "
+ "THAN 1 OR GREATER \002,\002THAN \002,i2)";
+ static char fmt_9996[] = "(\002 VALUE OF N IS LESS THAN 0 OR GREATER THA"
+ "N \002,i2)";
+ static char fmt_9995[] = "(\002 TESTS OF THE DOUBLE PRECISION LEVEL 3 BL"
+ "AS\002,//\002 THE F\002,\002OLLOWING PARAMETER VALUES WILL BE US"
+ "ED:\002)";
+ static char fmt_9994[] = "(\002 FOR N \002,9i6)";
+ static char fmt_9993[] = "(\002 FOR ALPHA \002,7f6.1)";
+ static char fmt_9992[] = "(\002 FOR BETA \002,7f6.1)";
+ static char fmt_9984[] = "(\002 ERROR-EXITS WILL NOT BE TESTED\002)";
+ static char fmt_9999[] = "(\002 ROUTINES PASS COMPUTATIONAL TESTS IF TES"
+ "T RATIO IS LES\002,\002S THAN\002,f8.2)";
+ static char fmt_9988[] = "(a6,l2)";
+ static char fmt_9990[] = "(\002 SUBPROGRAM NAME \002,a6,\002 NOT RECOGNI"
+ "ZED\002,/\002 ******* T\002,\002ESTS ABANDONED *******\002)";
+ static char fmt_9998[] = "(\002 RELATIVE MACHINE PRECISION IS TAKEN TO"
+ " BE\002,1p,d9.1)";
+ static char fmt_9989[] = "(\002 ERROR IN DMMCH - IN-LINE DOT PRODUCTS A"
+ "RE BEING EVALU\002,\002ATED WRONGLY.\002,/\002 DMMCH WAS CALLED "
+ "WITH TRANSA = \002,a1,\002 AND TRANSB = \002,a1,/\002 AND RETURN"
+ "ED SAME = \002,l1,\002 AND \002,\002ERR = \002,f12.3,\002.\002,"
+ "/\002 THIS MAY BE DUE TO FAULTS IN THE \002,\002ARITHMETIC OR TH"
+ "E COMPILER.\002,/\002 ******* TESTS ABANDONED \002,\002******"
+ "*\002)";
+ static char fmt_9987[] = "(1x,a6,\002 WAS NOT TESTED\002)";
+ static char fmt_9986[] = "(/\002 END OF TESTS\002)";
+ static char fmt_9985[] = "(/\002 ******* FATAL ERROR - TESTS ABANDONED *"
+ "******\002)";
+ static char fmt_9991[] = "(\002 AMEND DATA FILE OR INCREASE ARRAY SIZES "
+ "IN PROGRAM\002,/\002 ******* TESTS ABANDONED *******\002)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublereal d__1;
+ olist o__1;
+ cllist cl__1;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void), f_open(olist *), s_wsfe(cilist *), do_fio(integer *,
+ char *, ftnlen), e_wsfe(void), s_wsle(cilist *), e_wsle(void),
+ s_rsfe(cilist *), e_rsfe(void), s_cmp(char *, char *, ftnlen,
+ ftnlen);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+ integer f_clos(cllist *);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal c__[4225] /* was [65][65] */, g[65];
+ integer i__, j, n;
+ doublereal w[130], aa[4225], ab[8450] /* was [65][130] */, bb[4225],
+ cc[4225], as[4225], bs[4225], cs[4225], ct[65], alf[7];
+ extern logical lde_(doublereal *, doublereal *, integer *);
+ doublereal bet[7], eps, err;
+ integer nalf, idim[9];
+ logical same;
+ integer nbet, ntra;
+ logical rewi;
+ integer nout;
+ extern /* Subroutine */ int dchk1_(char *, doublereal *, doublereal *,
+ integer *, integer *, logical *, logical *, logical *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, ftnlen), dchk2_(char *,
+ doublereal *, doublereal *, integer *, integer *, logical *,
+ logical *, logical *, integer *, integer *, integer *, doublereal
+ *, integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, ftnlen), dchk3_(char *, doublereal *, doublereal *,
+ integer *, integer *, logical *, logical *, logical *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, ftnlen),
+ dchk4_(char *, doublereal *, doublereal *, integer *, integer *,
+ logical *, logical *, logical *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, ftnlen), dchk5_(char *, doublereal *,
+ doublereal *, integer *, integer *, logical *, logical *, logical
+ *, integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, ftnlen);
+ extern doublereal ddiff_(doublereal *, doublereal *);
+ extern /* Subroutine */ int dchke_(integer *, char *, integer *, ftnlen);
+ logical fatal;
+ extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ logical *, integer *, logical *, ftnlen, ftnlen);
+ logical trace;
+ integer nidim;
+ char snaps[32];
+ integer isnum;
+ logical ltest[6], sfatal;
+ char snamet[6], transa[1], transb[1];
+ doublereal thresh;
+ logical ltestt, tsterr;
+ char summry[32];
+
+ /* Fortran I/O blocks */
+ static cilist io___2 = { 0, 5, 0, 0, 0 };
+ static cilist io___4 = { 0, 5, 0, 0, 0 };
+ static cilist io___6 = { 0, 5, 0, 0, 0 };
+ static cilist io___8 = { 0, 5, 0, 0, 0 };
+ static cilist io___11 = { 0, 5, 0, 0, 0 };
+ static cilist io___13 = { 0, 5, 0, 0, 0 };
+ static cilist io___15 = { 0, 5, 0, 0, 0 };
+ static cilist io___17 = { 0, 5, 0, 0, 0 };
+ static cilist io___19 = { 0, 5, 0, 0, 0 };
+ static cilist io___21 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___22 = { 0, 5, 0, 0, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___26 = { 0, 5, 0, 0, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___29 = { 0, 5, 0, 0, 0 };
+ static cilist io___31 = { 0, 5, 0, 0, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___34 = { 0, 5, 0, 0, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___40 = { 0, 0, 0, 0, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9984, 0 };
+ static cilist io___42 = { 0, 0, 0, 0, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, 0, 0 };
+ static cilist io___46 = { 0, 5, 1, fmt_9988, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___69 = { 0, 0, 0, 0, 0 };
+ static cilist io___70 = { 0, 0, 0, fmt_9987, 0 };
+ static cilist io___71 = { 0, 0, 0, 0, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9986, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9985, 0 };
+ static cilist io___80 = { 0, 0, 0, fmt_9991, 0 };
+
+
+
+/* Test program for the DOUBLE PRECISION Level 3 Blas. */
+
+/* The program must be driven by a short data file. The first 14 records */
+/* of the file are read using list-directed input, the last 6 records */
+/* are read using the format ( A6, L2 ). An annotated example of a data */
+/* file can be obtained by deleting the first 3 characters from the */
+/* following 20 lines: */
+/* 'dblat3.out' NAME OF SUMMARY OUTPUT FILE */
+/* 6 UNIT NUMBER OF SUMMARY FILE */
+/* 'DBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE */
+/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */
+/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */
+/* F LOGICAL FLAG, T TO STOP ON FAILURES. */
+/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */
+/* 16.0 THRESHOLD VALUE OF TEST RATIO */
+/* 6 NUMBER OF VALUES OF N */
+/* 0 1 2 3 5 9 VALUES OF N */
+/* 3 NUMBER OF VALUES OF ALPHA */
+/* 0.0 1.0 0.7 VALUES OF ALPHA */
+/* 3 NUMBER OF VALUES OF BETA */
+/* 0.0 1.0 1.3 VALUES OF BETA */
+/* DGEMM T PUT F FOR NO TEST. SAME COLUMNS. */
+/* DSYMM T PUT F FOR NO TEST. SAME COLUMNS. */
+/* DTRMM T PUT F FOR NO TEST. SAME COLUMNS. */
+/* DTRSM T PUT F FOR NO TEST. SAME COLUMNS. */
+/* DSYRK T PUT F FOR NO TEST. SAME COLUMNS. */
+/* DSYR2K T PUT F FOR NO TEST. SAME COLUMNS. */
+
+/* See: */
+
+/* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. */
+/* A Set of Level 3 Basic Linear Algebra Subprograms. */
+
+/* Technical Memorandum No.88 (Revision 1), Mathematics and */
+/* Computer Science Division, Argonne National Laboratory, 9700 */
+/* South Cass Avenue, Argonne, Illinois 60439, US. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers */
+/* can be run multiple times without deleting generated */
+/* output files (susan) */
+
+/* .. Parameters .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+
+/* Read name and unit number for summary output file and open file. */
+
+ s_rsle(&io___2);
+ do_lio(&c__9, &c__1, summry, (ftnlen)32);
+ e_rsle();
+ s_rsle(&io___4);
+ do_lio(&c__3, &c__1, (char *)&nout, (ftnlen)sizeof(integer));
+ e_rsle();
+ o__1.oerr = 0;
+ o__1.ounit = nout;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = summry;
+ o__1.orl = 0;
+ o__1.osta = "UNKNOWN";
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);
+ infoc_1.noutc = nout;
+
+/* Read name and unit number for snapshot output file and open file. */
+
+ s_rsle(&io___6);
+ do_lio(&c__9, &c__1, snaps, (ftnlen)32);
+ e_rsle();
+ s_rsle(&io___8);
+ do_lio(&c__3, &c__1, (char *)&ntra, (ftnlen)sizeof(integer));
+ e_rsle();
+ trace = ntra >= 0;
+ if (trace) {
+ o__1.oerr = 0;
+ o__1.ounit = ntra;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = snaps;
+ o__1.orl = 0;
+ o__1.osta = "UNKNOWN";
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);
+ }
+/* Read the flag that directs rewinding of the snapshot file. */
+ s_rsle(&io___11);
+ do_lio(&c__8, &c__1, (char *)&rewi, (ftnlen)sizeof(logical));
+ e_rsle();
+ rewi = rewi && trace;
+/* Read the flag that directs stopping on any failure. */
+ s_rsle(&io___13);
+ do_lio(&c__8, &c__1, (char *)&sfatal, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the flag that indicates whether error exits are to be tested. */
+ s_rsle(&io___15);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the threshold value of the test ratio */
+ s_rsle(&io___17);
+ do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_rsle();
+
+/* Read and check the parameter values for the tests. */
+
+/* Values of N */
+ s_rsle(&io___19);
+ do_lio(&c__3, &c__1, (char *)&nidim, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nidim < 1 || nidim > 9) {
+ io___21.ciunit = nout;
+ s_wsfe(&io___21);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___22);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {
+ io___25.ciunit = nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, (char *)&c__65, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+/* L10: */
+ }
+/* Values of ALPHA */
+ s_rsle(&io___26);
+ do_lio(&c__3, &c__1, (char *)&nalf, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nalf < 1 || nalf > 7) {
+ io___28.ciunit = nout;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "ALPHA", (ftnlen)5);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___29);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__5, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(doublereal)
+ );
+ }
+ e_rsle();
+/* Values of BETA */
+ s_rsle(&io___31);
+ do_lio(&c__3, &c__1, (char *)&nbet, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nbet < 1 || nbet > 7) {
+ io___33.ciunit = nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, "BETA", (ftnlen)4);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___34);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__5, &c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(doublereal)
+ );
+ }
+ e_rsle();
+
+/* Report values of parameters. */
+
+ io___36.ciunit = nout;
+ s_wsfe(&io___36);
+ e_wsfe();
+ io___37.ciunit = nout;
+ s_wsfe(&io___37);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ io___38.ciunit = nout;
+ s_wsfe(&io___38);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(doublereal));
+ }
+ e_wsfe();
+ io___39.ciunit = nout;
+ s_wsfe(&io___39);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(doublereal));
+ }
+ e_wsfe();
+ if (! tsterr) {
+ io___40.ciunit = nout;
+ s_wsle(&io___40);
+ e_wsle();
+ io___41.ciunit = nout;
+ s_wsfe(&io___41);
+ e_wsfe();
+ }
+ io___42.ciunit = nout;
+ s_wsle(&io___42);
+ e_wsle();
+ io___43.ciunit = nout;
+ s_wsfe(&io___43);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ io___44.ciunit = nout;
+ s_wsle(&io___44);
+ e_wsle();
+
+/* Read names of subroutines and flags which indicate */
+/* whether they are to be tested. */
+
+ for (i__ = 1; i__ <= 6; ++i__) {
+ ltest[i__ - 1] = FALSE_;
+/* L20: */
+ }
+L30:
+ i__1 = s_rsfe(&io___46);
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = do_fio(&c__1, snamet, (ftnlen)6);
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = do_fio(&c__1, (char *)<estt, (ftnlen)sizeof(logical));
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L60;
+ }
+ for (i__ = 1; i__ <= 6; ++i__) {
+ if (s_cmp(snamet, snames + (i__ - 1) * 6, (ftnlen)6, (ftnlen)6) == 0)
+ {
+ goto L50;
+ }
+/* L40: */
+ }
+ io___49.ciunit = nout;
+ s_wsfe(&io___49);
+ do_fio(&c__1, snamet, (ftnlen)6);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+L50:
+ ltest[i__ - 1] = ltestt;
+ goto L30;
+
+L60:
+ cl__1.cerr = 0;
+ cl__1.cunit = 5;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+
+/* Compute EPS (the machine precision). */
+
+ eps = 1.;
+L70:
+ d__1 = eps + 1.;
+ if (ddiff_(&d__1, &c_b87) == 0.) {
+ goto L80;
+ }
+ eps *= .5;
+ goto L70;
+L80:
+ eps += eps;
+ io___51.ciunit = nout;
+ s_wsfe(&io___51);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+/* Check the reliability of DMMCH using exact data. */
+
+ n = 32;
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ - j + 1;
+ ab[i__ + j * 65 - 66] = (doublereal) max(i__3,0);
+/* L90: */
+ }
+ ab[j + 4224] = (doublereal) j;
+ ab[(j + 65) * 65 - 65] = (doublereal) j;
+ c__[j - 1] = 0.;
+/* L100: */
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ cc[j - 1] = (doublereal) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j -
+ 1) / 3);
+/* L110: */
+ }
+/* CC holds the exact result. On exit from DMMCH CT holds */
+/* the result computed by DMMCH. */
+ *(unsigned char *)transa = 'N';
+ *(unsigned char *)transb = 'N';
+ dmmch_(transa, transb, &n, &c__1, &n, &c_b87, ab, &c__65, &ab[4225], &
+ c__65, &c_b101, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &
+ fatal, &nout, &c_true, (ftnlen)1, (ftnlen)1);
+ same = lde_(cc, ct, &n);
+ if (! same || err != 0.) {
+ io___64.ciunit = nout;
+ s_wsfe(&io___64);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ *(unsigned char *)transb = 'T';
+ dmmch_(transa, transb, &n, &c__1, &n, &c_b87, ab, &c__65, &ab[4225], &
+ c__65, &c_b101, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &
+ fatal, &nout, &c_true, (ftnlen)1, (ftnlen)1);
+ same = lde_(cc, ct, &n);
+ if (! same || err != 0.) {
+ io___65.ciunit = nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ ab[j + 4224] = (doublereal) (n - j + 1);
+ ab[(j + 65) * 65 - 65] = (doublereal) (n - j + 1);
+/* L120: */
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ cc[n - j] = (doublereal) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j -
+ 1) / 3);
+/* L130: */
+ }
+ *(unsigned char *)transa = 'T';
+ *(unsigned char *)transb = 'N';
+ dmmch_(transa, transb, &n, &c__1, &n, &c_b87, ab, &c__65, &ab[4225], &
+ c__65, &c_b101, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &
+ fatal, &nout, &c_true, (ftnlen)1, (ftnlen)1);
+ same = lde_(cc, ct, &n);
+ if (! same || err != 0.) {
+ io___66.ciunit = nout;
+ s_wsfe(&io___66);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ *(unsigned char *)transb = 'T';
+ dmmch_(transa, transb, &n, &c__1, &n, &c_b87, ab, &c__65, &ab[4225], &
+ c__65, &c_b101, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &
+ fatal, &nout, &c_true, (ftnlen)1, (ftnlen)1);
+ same = lde_(cc, ct, &n);
+ if (! same || err != 0.) {
+ io___67.ciunit = nout;
+ s_wsfe(&io___67);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Test each subroutine in turn. */
+
+ for (isnum = 1; isnum <= 6; ++isnum) {
+ io___69.ciunit = nout;
+ s_wsle(&io___69);
+ e_wsle();
+ if (! ltest[isnum - 1]) {
+/* Subprogram is not to be tested. */
+ io___70.ciunit = nout;
+ s_wsfe(&io___70);
+ do_fio(&c__1, snames + (isnum - 1) * 6, (ftnlen)6);
+ e_wsfe();
+ } else {
+ s_copy(srnamc_1.srnamt, snames + (isnum - 1) * 6, (ftnlen)6, (
+ ftnlen)6);
+/* Test error exits. */
+ if (tsterr) {
+ dchke_(&isnum, snames + (isnum - 1) * 6, &nout, (ftnlen)6);
+ io___71.ciunit = nout;
+ s_wsle(&io___71);
+ e_wsle();
+ }
+/* Test computations. */
+ infoc_1.infot = 0;
+ infoc_1.ok = TRUE_;
+ fatal = FALSE_;
+ switch (isnum) {
+ case 1: goto L140;
+ case 2: goto L150;
+ case 3: goto L160;
+ case 4: goto L160;
+ case 5: goto L170;
+ case 6: goto L180;
+ }
+/* Test DGEMM, 01. */
+L140:
+ dchk1_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &nbet,
+ bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, cc, cs,
+ ct, g, (ftnlen)6);
+ goto L190;
+/* Test DSYMM, 02. */
+L150:
+ dchk2_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &nbet,
+ bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, cc, cs,
+ ct, g, (ftnlen)6);
+ goto L190;
+/* Test DTRMM, 03, DTRSM, 04. */
+L160:
+ dchk3_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &c__65,
+ ab, aa, as, &ab[4225], bb, bs, ct, g, c__, (ftnlen)6);
+ goto L190;
+/* Test DSYRK, 05. */
+L170:
+ dchk4_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &nbet,
+ bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, cc, cs,
+ ct, g, (ftnlen)6);
+ goto L190;
+/* Test DSYR2K, 06. */
+L180:
+ dchk5_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &nbet,
+ bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, ct, g, w, (
+ ftnlen)6);
+ goto L190;
+
+L190:
+ if (fatal && sfatal) {
+ goto L210;
+ }
+ }
+/* L200: */
+ }
+ io___78.ciunit = nout;
+ s_wsfe(&io___78);
+ e_wsfe();
+ goto L230;
+
+L210:
+ io___79.ciunit = nout;
+ s_wsfe(&io___79);
+ e_wsfe();
+ goto L230;
+
+L220:
+ io___80.ciunit = nout;
+ s_wsfe(&io___80);
+ e_wsfe();
+
+L230:
+ if (trace) {
+ cl__1.cerr = 0;
+ cl__1.cunit = ntra;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ }
+ cl__1.cerr = 0;
+ cl__1.cunit = nout;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ s_stop("", (ftnlen)0);
+
+
+/* End of DBLAT3. */
+
+ return 0;
+} /* MAIN__ */
+
+/* Subroutine */ int dchk1_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublereal *alf,
+ integer *nbet, doublereal *bet, integer *nmax, doublereal *a,
+ doublereal *aa, doublereal *as, doublereal *b, doublereal *bb,
+ doublereal *bs, doublereal *c__, doublereal *cc, doublereal *cs,
+ doublereal *ct, doublereal *g, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ich[3] = "NTC";
+
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002','\002"
+ ",a1,\002',\002,3(i3,\002,\002),f4.1,\002, A,\002,i3,\002, B,\002"
+ ",i3,\002,\002,f4.1,\002, \002,\002C,\002,i3,\002).\002)";
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, k, m, n, ia, ib, ma, mb, na, nb, nc, ik, im, in, ks, ms, ns,
+ ica, icb, laa, lbb, lda, lcc, ldb, ldc;
+ extern logical lde_(doublereal *, doublereal *, integer *);
+ doublereal als, bls, err, beta;
+ integer ldas, ldbs, ldcs;
+ logical same, null;
+ extern /* Subroutine */ int dmake_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ logical *, doublereal *, ftnlen, ftnlen, ftnlen);
+ doublereal alpha;
+ extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ logical *, integer *, logical *, ftnlen, ftnlen), dgemm_(char *,
+ char *, integer *, integer *, integer *, doublereal *, doublereal
+ *, integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ logical isame[13], trana, tranb;
+ integer nargs;
+ logical reset;
+ extern logical lderes_(char *, char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, ftnlen, ftnlen);
+ char tranas[1], tranbs[1], transa[1], transb[1];
+ doublereal errmax;
+
+ /* Fortran I/O blocks */
+ static cilist io___124 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___125 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___128 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___130 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___131 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___132 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___133 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests DGEMM. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+
+ nargs = 13;
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.;
+
+ i__1 = *nidim;
+ for (im = 1; im <= i__1; ++im) {
+ m = idim[im];
+
+ i__2 = *nidim;
+ for (in = 1; in <= i__2; ++in) {
+ n = idim[in];
+/* Set LDC to 1 more than minimum value if room. */
+ ldc = m;
+ if (ldc < *nmax) {
+ ++ldc;
+ }
+/* Skip tests if not enough room. */
+ if (ldc > *nmax) {
+ goto L100;
+ }
+ lcc = ldc * n;
+ null = n <= 0 || m <= 0;
+
+ i__3 = *nidim;
+ for (ik = 1; ik <= i__3; ++ik) {
+ k = idim[ik];
+
+ for (ica = 1; ica <= 3; ++ica) {
+ *(unsigned char *)transa = *(unsigned char *)&ich[ica - 1]
+ ;
+ trana = *(unsigned char *)transa == 'T' || *(unsigned
+ char *)transa == 'C';
+
+ if (trana) {
+ ma = k;
+ na = m;
+ } else {
+ ma = m;
+ na = k;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ lda = ma;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L80;
+ }
+ laa = lda * na;
+
+/* Generate the matrix A. */
+
+ dmake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[
+ 1], &lda, &reset, &c_b101, (ftnlen)2, (ftnlen)1, (
+ ftnlen)1);
+
+ for (icb = 1; icb <= 3; ++icb) {
+ *(unsigned char *)transb = *(unsigned char *)&ich[icb
+ - 1];
+ tranb = *(unsigned char *)transb == 'T' || *(unsigned
+ char *)transb == 'C';
+
+ if (tranb) {
+ mb = n;
+ nb = k;
+ } else {
+ mb = k;
+ nb = n;
+ }
+/* Set LDB to 1 more than minimum value if room. */
+ ldb = mb;
+ if (ldb < *nmax) {
+ ++ldb;
+ }
+/* Skip tests if not enough room. */
+ if (ldb > *nmax) {
+ goto L70;
+ }
+ lbb = ldb * nb;
+
+/* Generate the matrix B. */
+
+ dmake_("GE", " ", " ", &mb, &nb, &b[b_offset], nmax, &
+ bb[1], &ldb, &reset, &c_b101, (ftnlen)2, (
+ ftnlen)1, (ftnlen)1);
+
+ i__4 = *nalf;
+ for (ia = 1; ia <= i__4; ++ia) {
+ alpha = alf[ia];
+
+ i__5 = *nbet;
+ for (ib = 1; ib <= i__5; ++ib) {
+ beta = bet[ib];
+
+/* Generate the matrix C. */
+
+ dmake_("GE", " ", " ", &m, &n, &c__[c_offset],
+ nmax, &cc[1], &ldc, &reset, &c_b101,
+ (ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the */
+/* subroutine. */
+
+ *(unsigned char *)tranas = *(unsigned char *)
+ transa;
+ *(unsigned char *)tranbs = *(unsigned char *)
+ transb;
+ ms = m;
+ ns = n;
+ ks = k;
+ als = alpha;
+ i__6 = laa;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ as[i__] = aa[i__];
+/* L10: */
+ }
+ ldas = lda;
+ i__6 = lbb;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ bs[i__] = bb[i__];
+/* L20: */
+ }
+ ldbs = ldb;
+ bls = beta;
+ i__6 = lcc;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ cs[i__] = cc[i__];
+/* L30: */
+ }
+ ldcs = ldc;
+
+/* Call the subroutine. */
+
+ if (*trace) {
+ io___124.ciunit = *ntra;
+ s_wsfe(&io___124);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ dgemm_(transa, transb, &m, &n, &k, &alpha, &
+ aa[1], &lda, &bb[1], &ldb, &beta, &cc[
+ 1], &ldc);
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___125.ciunit = *nout;
+ s_wsfe(&io___125);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)transa == *(
+ unsigned char *)tranas;
+ isame[1] = *(unsigned char *)transb == *(
+ unsigned char *)tranbs;
+ isame[2] = ms == m;
+ isame[3] = ns == n;
+ isame[4] = ks == k;
+ isame[5] = als == alpha;
+ isame[6] = lde_(&as[1], &aa[1], &laa);
+ isame[7] = ldas == lda;
+ isame[8] = lde_(&bs[1], &bb[1], &lbb);
+ isame[9] = ldbs == ldb;
+ isame[10] = bls == beta;
+ if (null) {
+ isame[11] = lde_(&cs[1], &cc[1], &lcc);
+ } else {
+ isame[11] = lderes_("GE", " ", &m, &n, &
+ cs[1], &cc[1], &ldc, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[12] = ldcs == ldc;
+
+/* If data was incorrectly changed, report */
+/* and return. */
+
+ same = TRUE_;
+ i__6 = nargs;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___128.ciunit = *nout;
+ s_wsfe(&io___128);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+
+/* Check the result. */
+
+ dmmch_(transa, transb, &m, &n, &k, &alpha,
+ &a[a_offset], nmax, &b[b_offset],
+ nmax, &beta, &c__[c_offset],
+ nmax, &ct[1], &g[1], &cc[1], &ldc,
+ eps, &err, fatal, nout, &c_true,
+ (ftnlen)1, (ftnlen)1);
+ errmax = max(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L120;
+ }
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+L70:
+ ;
+ }
+
+L80:
+ ;
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+/* L110: */
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___130.ciunit = *nout;
+ s_wsfe(&io___130);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___131.ciunit = *nout;
+ s_wsfe(&io___131);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ goto L130;
+
+L120:
+ io___132.ciunit = *nout;
+ s_wsfe(&io___132);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ io___133.ciunit = *nout;
+ s_wsfe(&io___133);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L130:
+ return 0;
+
+
+/* End of DCHK1. */
+
+} /* dchk1_ */
+
+/* Subroutine */ int dchk2_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublereal *alf,
+ integer *nbet, doublereal *bet, integer *nmax, doublereal *a,
+ doublereal *aa, doublereal *as, doublereal *b, doublereal *bb,
+ doublereal *bs, doublereal *c__, doublereal *cc, doublereal *cs,
+ doublereal *ct, doublereal *g, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ichs[2] = "LR";
+ static char ichu[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002(\002,2(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),f4.1,\002, A,\002,i3,\002, B,\002,i"
+ "3,\002,\002,f4.1,\002, C,\002,i3,\002) \002,\002 .\002)";
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, m, n, ia, ib, na, nc, im, in, ms, ns, laa, lbb, lda, lcc,
+ ldb, ldc;
+ extern logical lde_(doublereal *, doublereal *, integer *);
+ integer ics;
+ doublereal als, bls;
+ integer icu;
+ doublereal err, beta;
+ integer ldas, ldbs, ldcs;
+ logical same;
+ char side[1];
+ logical left, null;
+ char uplo[1];
+ extern /* Subroutine */ int dmake_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ logical *, doublereal *, ftnlen, ftnlen, ftnlen);
+ doublereal alpha;
+ extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ logical *, integer *, logical *, ftnlen, ftnlen);
+ logical isame[13];
+ char sides[1];
+ integer nargs;
+ logical reset;
+ extern /* Subroutine */ int dsymm_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ char uplos[1];
+ extern logical lderes_(char *, char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, ftnlen, ftnlen);
+ doublereal errmax;
+
+ /* Fortran I/O blocks */
+ static cilist io___171 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___172 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___175 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___177 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___178 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___179 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___180 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests DSYMM. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+
+ nargs = 12;
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.;
+
+ i__1 = *nidim;
+ for (im = 1; im <= i__1; ++im) {
+ m = idim[im];
+
+ i__2 = *nidim;
+ for (in = 1; in <= i__2; ++in) {
+ n = idim[in];
+/* Set LDC to 1 more than minimum value if room. */
+ ldc = m;
+ if (ldc < *nmax) {
+ ++ldc;
+ }
+/* Skip tests if not enough room. */
+ if (ldc > *nmax) {
+ goto L90;
+ }
+ lcc = ldc * n;
+ null = n <= 0 || m <= 0;
+
+/* Set LDB to 1 more than minimum value if room. */
+ ldb = m;
+ if (ldb < *nmax) {
+ ++ldb;
+ }
+/* Skip tests if not enough room. */
+ if (ldb > *nmax) {
+ goto L90;
+ }
+ lbb = ldb * n;
+
+/* Generate the matrix B. */
+
+ dmake_("GE", " ", " ", &m, &n, &b[b_offset], nmax, &bb[1], &ldb, &
+ reset, &c_b101, (ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ for (ics = 1; ics <= 2; ++ics) {
+ *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1];
+ left = *(unsigned char *)side == 'L';
+
+ if (left) {
+ na = m;
+ } else {
+ na = n;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ lda = na;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L80;
+ }
+ laa = lda * na;
+
+ for (icu = 1; icu <= 2; ++icu) {
+ *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
+
+/* Generate the symmetric matrix A. */
+
+ dmake_("SY", uplo, " ", &na, &na, &a[a_offset], nmax, &aa[
+ 1], &lda, &reset, &c_b101, (ftnlen)2, (ftnlen)1, (
+ ftnlen)1);
+
+ i__3 = *nalf;
+ for (ia = 1; ia <= i__3; ++ia) {
+ alpha = alf[ia];
+
+ i__4 = *nbet;
+ for (ib = 1; ib <= i__4; ++ib) {
+ beta = bet[ib];
+
+/* Generate the matrix C. */
+
+ dmake_("GE", " ", " ", &m, &n, &c__[c_offset],
+ nmax, &cc[1], &ldc, &reset, &c_b101, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the */
+/* subroutine. */
+
+ *(unsigned char *)sides = *(unsigned char *)side;
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ ms = m;
+ ns = n;
+ als = alpha;
+ i__5 = laa;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ as[i__] = aa[i__];
+/* L10: */
+ }
+ ldas = lda;
+ i__5 = lbb;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ bs[i__] = bb[i__];
+/* L20: */
+ }
+ ldbs = ldb;
+ bls = beta;
+ i__5 = lcc;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ cs[i__] = cc[i__];
+/* L30: */
+ }
+ ldcs = ldc;
+
+/* Call the subroutine. */
+
+ if (*trace) {
+ io___171.ciunit = *ntra;
+ s_wsfe(&io___171);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ dsymm_(side, uplo, &m, &n, &alpha, &aa[1], &lda, &
+ bb[1], &ldb, &beta, &cc[1], &ldc);
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___172.ciunit = *nout;
+ s_wsfe(&io___172);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L110;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)sides == *(unsigned
+ char *)side;
+ isame[1] = *(unsigned char *)uplos == *(unsigned
+ char *)uplo;
+ isame[2] = ms == m;
+ isame[3] = ns == n;
+ isame[4] = als == alpha;
+ isame[5] = lde_(&as[1], &aa[1], &laa);
+ isame[6] = ldas == lda;
+ isame[7] = lde_(&bs[1], &bb[1], &lbb);
+ isame[8] = ldbs == ldb;
+ isame[9] = bls == beta;
+ if (null) {
+ isame[10] = lde_(&cs[1], &cc[1], &lcc);
+ } else {
+ isame[10] = lderes_("GE", " ", &m, &n, &cs[1],
+ &cc[1], &ldc, (ftnlen)2, (ftnlen)1);
+ }
+ isame[11] = ldcs == ldc;
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__5 = nargs;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___175.ciunit = *nout;
+ s_wsfe(&io___175);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L110;
+ }
+
+ if (! null) {
+
+/* Check the result. */
+
+ if (left) {
+ dmmch_("N", "N", &m, &n, &m, &alpha, &a[
+ a_offset], nmax, &b[b_offset],
+ nmax, &beta, &c__[c_offset], nmax,
+ &ct[1], &g[1], &cc[1], &ldc, eps,
+ &err, fatal, nout, &c_true, (
+ ftnlen)1, (ftnlen)1);
+ } else {
+ dmmch_("N", "N", &m, &n, &n, &alpha, &b[
+ b_offset], nmax, &a[a_offset],
+ nmax, &beta, &c__[c_offset], nmax,
+ &ct[1], &g[1], &cc[1], &ldc, eps,
+ &err, fatal, nout, &c_true, (
+ ftnlen)1, (ftnlen)1);
+ }
+ errmax = max(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L110;
+ }
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+/* L70: */
+ }
+
+L80:
+ ;
+ }
+
+L90:
+ ;
+ }
+
+/* L100: */
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___177.ciunit = *nout;
+ s_wsfe(&io___177);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___178.ciunit = *nout;
+ s_wsfe(&io___178);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ goto L120;
+
+L110:
+ io___179.ciunit = *nout;
+ s_wsfe(&io___179);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ io___180.ciunit = *nout;
+ s_wsfe(&io___180);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L120:
+ return 0;
+
+
+/* End of DCHK2. */
+
+} /* dchk2_ */
+
+/* Subroutine */ int dchk3_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublereal *alf,
+ integer *nmax, doublereal *a, doublereal *aa, doublereal *as,
+ doublereal *b, doublereal *bb, doublereal *bs, doublereal *ct,
+ doublereal *g, doublereal *c__, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ichu[2] = "UL";
+ static char icht[3] = "NTC";
+ static char ichd[2] = "UN";
+ static char ichs[2] = "LR";
+
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002(\002,4(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),f4.1,\002, A,\002,i3,\002, B,\002,i"
+ "3,\002) .\002)";
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio(
+ integer *, char *, ftnlen), e_wsfe(void), f_rew(alist *);
+
+ /* Local variables */
+ integer i__, j, m, n, ia, na, nc, im, in, ms, ns, laa, icd, lbb, lda, ldb;
+ extern logical lde_(doublereal *, doublereal *, integer *);
+ integer ics;
+ doublereal als;
+ integer ict, icu;
+ doublereal err;
+ char diag[1];
+ integer ldas, ldbs;
+ logical same;
+ char side[1];
+ logical left, null;
+ char uplo[1];
+ extern /* Subroutine */ int dmake_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ logical *, doublereal *, ftnlen, ftnlen, ftnlen);
+ doublereal alpha;
+ char diags[1];
+ extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ logical *, integer *, logical *, ftnlen, ftnlen);
+ logical isame[13];
+ char sides[1];
+ integer nargs;
+ logical reset;
+ extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), dtrsm_(
+ char *, char *, char *, char *, integer *, integer *, doublereal *
+, doublereal *, integer *, doublereal *, integer *);
+ char uplos[1];
+ extern logical lderes_(char *, char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, ftnlen, ftnlen);
+ char tranas[1], transa[1];
+ doublereal errmax;
+
+ /* Fortran I/O blocks */
+ static cilist io___221 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___222 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___223 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___226 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___228 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___229 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___230 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___231 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests DTRMM and DTRSM. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --g;
+ --ct;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+
+ nargs = 11;
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.;
+/* Set up zero matrix for DMMCH. */
+ i__1 = *nmax;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *nmax;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+
+ i__1 = *nidim;
+ for (im = 1; im <= i__1; ++im) {
+ m = idim[im];
+
+ i__2 = *nidim;
+ for (in = 1; in <= i__2; ++in) {
+ n = idim[in];
+/* Set LDB to 1 more than minimum value if room. */
+ ldb = m;
+ if (ldb < *nmax) {
+ ++ldb;
+ }
+/* Skip tests if not enough room. */
+ if (ldb > *nmax) {
+ goto L130;
+ }
+ lbb = ldb * n;
+ null = m <= 0 || n <= 0;
+
+ for (ics = 1; ics <= 2; ++ics) {
+ *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1];
+ left = *(unsigned char *)side == 'L';
+ if (left) {
+ na = m;
+ } else {
+ na = n;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ lda = na;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L130;
+ }
+ laa = lda * na;
+
+ for (icu = 1; icu <= 2; ++icu) {
+ *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
+
+ for (ict = 1; ict <= 3; ++ict) {
+ *(unsigned char *)transa = *(unsigned char *)&icht[
+ ict - 1];
+
+ for (icd = 1; icd <= 2; ++icd) {
+ *(unsigned char *)diag = *(unsigned char *)&ichd[
+ icd - 1];
+
+ i__3 = *nalf;
+ for (ia = 1; ia <= i__3; ++ia) {
+ alpha = alf[ia];
+
+/* Generate the matrix A. */
+
+ dmake_("TR", uplo, diag, &na, &na, &a[
+ a_offset], nmax, &aa[1], &lda, &reset,
+ &c_b101, (ftnlen)2, (ftnlen)1, (
+ ftnlen)1);
+
+/* Generate the matrix B. */
+
+ dmake_("GE", " ", " ", &m, &n, &b[b_offset],
+ nmax, &bb[1], &ldb, &reset, &c_b101, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the */
+/* subroutine. */
+
+ *(unsigned char *)sides = *(unsigned char *)
+ side;
+ *(unsigned char *)uplos = *(unsigned char *)
+ uplo;
+ *(unsigned char *)tranas = *(unsigned char *)
+ transa;
+ *(unsigned char *)diags = *(unsigned char *)
+ diag;
+ ms = m;
+ ns = n;
+ als = alpha;
+ i__4 = laa;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ as[i__] = aa[i__];
+/* L30: */
+ }
+ ldas = lda;
+ i__4 = lbb;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ bs[i__] = bb[i__];
+/* L40: */
+ }
+ ldbs = ldb;
+
+/* Call the subroutine. */
+
+ if (s_cmp(sname + 3, "MM", (ftnlen)2, (ftnlen)
+ 2) == 0) {
+ if (*trace) {
+ io___221.ciunit = *ntra;
+ s_wsfe(&io___221);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ dtrmm_(side, uplo, transa, diag, &m, &n, &
+ alpha, &aa[1], &lda, &bb[1], &ldb);
+ } else if (s_cmp(sname + 3, "SM", (ftnlen)2, (
+ ftnlen)2) == 0) {
+ if (*trace) {
+ io___222.ciunit = *ntra;
+ s_wsfe(&io___222);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ dtrsm_(side, uplo, transa, diag, &m, &n, &
+ alpha, &aa[1], &lda, &bb[1], &ldb);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___223.ciunit = *nout;
+ s_wsfe(&io___223);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L150;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)sides == *(
+ unsigned char *)side;
+ isame[1] = *(unsigned char *)uplos == *(
+ unsigned char *)uplo;
+ isame[2] = *(unsigned char *)tranas == *(
+ unsigned char *)transa;
+ isame[3] = *(unsigned char *)diags == *(
+ unsigned char *)diag;
+ isame[4] = ms == m;
+ isame[5] = ns == n;
+ isame[6] = als == alpha;
+ isame[7] = lde_(&as[1], &aa[1], &laa);
+ isame[8] = ldas == lda;
+ if (null) {
+ isame[9] = lde_(&bs[1], &bb[1], &lbb);
+ } else {
+ isame[9] = lderes_("GE", " ", &m, &n, &bs[
+ 1], &bb[1], &ldb, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[10] = ldbs == ldb;
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__4 = nargs;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___226.ciunit = *nout;
+ s_wsfe(&io___226);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L50: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L150;
+ }
+
+ if (! null) {
+ if (s_cmp(sname + 3, "MM", (ftnlen)2, (
+ ftnlen)2) == 0) {
+
+/* Check the result. */
+
+ if (left) {
+ dmmch_(transa, "N", &m, &n, &m, &
+ alpha, &a[a_offset], nmax,
+ &b[b_offset], nmax, &
+ c_b101, &c__[c_offset],
+ nmax, &ct[1], &g[1], &bb[
+ 1], &ldb, eps, &err,
+ fatal, nout, &c_true, (
+ ftnlen)1, (ftnlen)1);
+ } else {
+ dmmch_("N", transa, &m, &n, &n, &
+ alpha, &b[b_offset], nmax,
+ &a[a_offset], nmax, &
+ c_b101, &c__[c_offset],
+ nmax, &ct[1], &g[1], &bb[
+ 1], &ldb, eps, &err,
+ fatal, nout, &c_true, (
+ ftnlen)1, (ftnlen)1);
+ }
+ } else if (s_cmp(sname + 3, "SM", (ftnlen)
+ 2, (ftnlen)2) == 0) {
+
+/* Compute approximation to original */
+/* matrix. */
+
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__5 = m;
+ for (i__ = 1; i__ <= i__5; ++i__)
+ {
+ c__[i__ + j * c_dim1] = bb[i__ + (j - 1) * ldb];
+ bb[i__ + (j - 1) * ldb] = alpha * b[i__ + j *
+ b_dim1];
+/* L60: */
+ }
+/* L70: */
+ }
+
+ if (left) {
+ dmmch_(transa, "N", &m, &n, &m, &
+ c_b87, &a[a_offset], nmax,
+ &c__[c_offset], nmax, &
+ c_b101, &b[b_offset],
+ nmax, &ct[1], &g[1], &bb[
+ 1], &ldb, eps, &err,
+ fatal, nout, &c_false, (
+ ftnlen)1, (ftnlen)1);
+ } else {
+ dmmch_("N", transa, &m, &n, &n, &
+ c_b87, &c__[c_offset],
+ nmax, &a[a_offset], nmax,
+ &c_b101, &b[b_offset],
+ nmax, &ct[1], &g[1], &bb[
+ 1], &ldb, eps, &err,
+ fatal, nout, &c_false, (
+ ftnlen)1, (ftnlen)1);
+ }
+ }
+ errmax = max(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L150;
+ }
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+/* L100: */
+ }
+
+/* L110: */
+ }
+
+/* L120: */
+ }
+
+L130:
+ ;
+ }
+
+/* L140: */
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___228.ciunit = *nout;
+ s_wsfe(&io___228);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___229.ciunit = *nout;
+ s_wsfe(&io___229);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ goto L160;
+
+L150:
+ io___230.ciunit = *nout;
+ s_wsfe(&io___230);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ io___231.ciunit = *nout;
+ s_wsfe(&io___231);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L160:
+ return 0;
+
+
+/* End of DCHK3. */
+
+} /* dchk3_ */
+
+/* Subroutine */ int dchk4_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublereal *alf,
+ integer *nbet, doublereal *bet, integer *nmax, doublereal *a,
+ doublereal *aa, doublereal *as, doublereal *b, doublereal *bb,
+ doublereal *bs, doublereal *c__, doublereal *cc, doublereal *cs,
+ doublereal *ct, doublereal *g, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char icht[3] = "NTC";
+ static char ichu[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002(\002,2(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),f4.1,\002, A,\002,i3,\002,\002,f4.1,"
+ "\002, C,\002,i3,\002) .\002)";
+ static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
+ lda, lcc, ldc;
+ extern logical lde_(doublereal *, doublereal *, integer *);
+ doublereal als;
+ integer ict, icu;
+ doublereal err, beta;
+ integer ldas, ldcs;
+ logical same;
+ doublereal bets;
+ logical tran, null;
+ char uplo[1];
+ extern /* Subroutine */ int dmake_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ logical *, doublereal *, ftnlen, ftnlen, ftnlen);
+ doublereal alpha;
+ extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ logical *, integer *, logical *, ftnlen, ftnlen);
+ logical isame[13];
+ integer nargs;
+ logical reset;
+ char trans[1];
+ logical upper;
+ extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ char uplos[1];
+ extern logical lderes_(char *, char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, ftnlen, ftnlen);
+ doublereal errmax;
+ char transs[1];
+
+ /* Fortran I/O blocks */
+ static cilist io___268 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___269 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___272 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___278 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___279 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___280 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___281 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___282 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* Tests DSYRK. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+
+ nargs = 10;
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+/* Set LDC to 1 more than minimum value if room. */
+ ldc = n;
+ if (ldc < *nmax) {
+ ++ldc;
+ }
+/* Skip tests if not enough room. */
+ if (ldc > *nmax) {
+ goto L100;
+ }
+ lcc = ldc * n;
+ null = n <= 0;
+
+ i__2 = *nidim;
+ for (ik = 1; ik <= i__2; ++ik) {
+ k = idim[ik];
+
+ for (ict = 1; ict <= 3; ++ict) {
+ *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1];
+ tran = *(unsigned char *)trans == 'T' || *(unsigned char *)
+ trans == 'C';
+ if (tran) {
+ ma = k;
+ na = n;
+ } else {
+ ma = n;
+ na = k;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ lda = ma;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L80;
+ }
+ laa = lda * na;
+
+/* Generate the matrix A. */
+
+ dmake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[1], &
+ lda, &reset, &c_b101, (ftnlen)2, (ftnlen)1, (ftnlen)1)
+ ;
+
+ for (icu = 1; icu <= 2; ++icu) {
+ *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
+ upper = *(unsigned char *)uplo == 'U';
+
+ i__3 = *nalf;
+ for (ia = 1; ia <= i__3; ++ia) {
+ alpha = alf[ia];
+
+ i__4 = *nbet;
+ for (ib = 1; ib <= i__4; ++ib) {
+ beta = bet[ib];
+
+/* Generate the matrix C. */
+
+ dmake_("SY", uplo, " ", &n, &n, &c__[c_offset],
+ nmax, &cc[1], &ldc, &reset, &c_b101, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ *(unsigned char *)transs = *(unsigned char *)
+ trans;
+ ns = n;
+ ks = k;
+ als = alpha;
+ i__5 = laa;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ as[i__] = aa[i__];
+/* L10: */
+ }
+ ldas = lda;
+ bets = beta;
+ i__5 = lcc;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ cs[i__] = cc[i__];
+/* L20: */
+ }
+ ldcs = ldc;
+
+/* Call the subroutine. */
+
+ if (*trace) {
+ io___268.ciunit = *ntra;
+ s_wsfe(&io___268);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ dsyrk_(uplo, trans, &n, &k, &alpha, &aa[1], &lda,
+ &beta, &cc[1], &ldc)
+ ;
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___269.ciunit = *nout;
+ s_wsfe(&io___269);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplos == *(unsigned
+ char *)uplo;
+ isame[1] = *(unsigned char *)transs == *(unsigned
+ char *)trans;
+ isame[2] = ns == n;
+ isame[3] = ks == k;
+ isame[4] = als == alpha;
+ isame[5] = lde_(&as[1], &aa[1], &laa);
+ isame[6] = ldas == lda;
+ isame[7] = bets == beta;
+ if (null) {
+ isame[8] = lde_(&cs[1], &cc[1], &lcc);
+ } else {
+ isame[8] = lderes_("SY", uplo, &n, &n, &cs[1],
+ &cc[1], &ldc, (ftnlen)2, (ftnlen)1);
+ }
+ isame[9] = ldcs == ldc;
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__5 = nargs;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___272.ciunit = *nout;
+ s_wsfe(&io___272);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L30: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+
+/* Check the result column by column. */
+
+ jc = 1;
+ i__5 = n;
+ for (j = 1; j <= i__5; ++j) {
+ if (upper) {
+ jj = 1;
+ lj = j;
+ } else {
+ jj = j;
+ lj = n - j + 1;
+ }
+ if (tran) {
+ dmmch_("T", "N", &lj, &c__1, &k, &
+ alpha, &a[jj * a_dim1 + 1],
+ nmax, &a[j * a_dim1 + 1],
+ nmax, &beta, &c__[jj + j *
+ c_dim1], nmax, &ct[1], &g[1],
+ &cc[jc], &ldc, eps, &err,
+ fatal, nout, &c_true, (ftnlen)
+ 1, (ftnlen)1);
+ } else {
+ dmmch_("N", "T", &lj, &c__1, &k, &
+ alpha, &a[jj + a_dim1], nmax,
+ &a[j + a_dim1], nmax, &beta, &
+ c__[jj + j * c_dim1], nmax, &
+ ct[1], &g[1], &cc[jc], &ldc,
+ eps, &err, fatal, nout, &
+ c_true, (ftnlen)1, (ftnlen)1);
+ }
+ if (upper) {
+ jc += ldc;
+ } else {
+ jc = jc + ldc + 1;
+ }
+ errmax = max(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L110;
+ }
+/* L40: */
+ }
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+/* L70: */
+ }
+
+L80:
+ ;
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___278.ciunit = *nout;
+ s_wsfe(&io___278);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___279.ciunit = *nout;
+ s_wsfe(&io___279);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ goto L130;
+
+L110:
+ if (n > 1) {
+ io___280.ciunit = *nout;
+ s_wsfe(&io___280);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L120:
+ io___281.ciunit = *nout;
+ s_wsfe(&io___281);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ io___282.ciunit = *nout;
+ s_wsfe(&io___282);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L130:
+ return 0;
+
+
+/* End of DCHK4. */
+
+} /* dchk4_ */
+
+/* Subroutine */ int dchk5_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublereal *alf,
+ integer *nbet, doublereal *bet, integer *nmax, doublereal *ab,
+ doublereal *aa, doublereal *as, doublereal *bb, doublereal *bs,
+ doublereal *c__, doublereal *cc, doublereal *cs, doublereal *ct,
+ doublereal *g, doublereal *w, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char icht[3] = "NTC";
+ static char ichu[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002(\002,2(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),f4.1,\002, A,\002,i3,\002, B,\002,i"
+ "3,\002,\002,f4.1,\002, C,\002,i3,\002) \002,\002 .\002)";
+ static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
+ lbb, lda, lcc, ldb, ldc;
+ extern logical lde_(doublereal *, doublereal *, integer *);
+ doublereal als;
+ integer ict, icu;
+ doublereal err;
+ integer jjab;
+ doublereal beta;
+ integer ldas, ldbs, ldcs;
+ logical same;
+ doublereal bets;
+ logical tran, null;
+ char uplo[1];
+ extern /* Subroutine */ int dmake_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ logical *, doublereal *, ftnlen, ftnlen, ftnlen);
+ doublereal alpha;
+ extern /* Subroutine */ int dmmch_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ logical *, integer *, logical *, ftnlen, ftnlen);
+ logical isame[13];
+ integer nargs;
+ logical reset;
+ char trans[1];
+ logical upper;
+ char uplos[1];
+ extern /* Subroutine */ int dsyr2k_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ extern logical lderes_(char *, char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, ftnlen, ftnlen);
+ doublereal errmax;
+ char transs[1];
+
+ /* Fortran I/O blocks */
+ static cilist io___322 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___323 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___326 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___333 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___334 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___335 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___336 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___337 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* Tests DSYR2K. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --w;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ --as;
+ --aa;
+ --ab;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+
+ nargs = 12;
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+/* Set LDC to 1 more than minimum value if room. */
+ ldc = n;
+ if (ldc < *nmax) {
+ ++ldc;
+ }
+/* Skip tests if not enough room. */
+ if (ldc > *nmax) {
+ goto L130;
+ }
+ lcc = ldc * n;
+ null = n <= 0;
+
+ i__2 = *nidim;
+ for (ik = 1; ik <= i__2; ++ik) {
+ k = idim[ik];
+
+ for (ict = 1; ict <= 3; ++ict) {
+ *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1];
+ tran = *(unsigned char *)trans == 'T' || *(unsigned char *)
+ trans == 'C';
+ if (tran) {
+ ma = k;
+ na = n;
+ } else {
+ ma = n;
+ na = k;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ lda = ma;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L110;
+ }
+ laa = lda * na;
+
+/* Generate the matrix A. */
+
+ if (tran) {
+ i__3 = *nmax << 1;
+ dmake_("GE", " ", " ", &ma, &na, &ab[1], &i__3, &aa[1], &
+ lda, &reset, &c_b101, (ftnlen)2, (ftnlen)1, (
+ ftnlen)1);
+ } else {
+ dmake_("GE", " ", " ", &ma, &na, &ab[1], nmax, &aa[1], &
+ lda, &reset, &c_b101, (ftnlen)2, (ftnlen)1, (
+ ftnlen)1);
+ }
+
+/* Generate the matrix B. */
+
+ ldb = lda;
+ lbb = laa;
+ if (tran) {
+ i__3 = *nmax << 1;
+ dmake_("GE", " ", " ", &ma, &na, &ab[k + 1], &i__3, &bb[1]
+ , &ldb, &reset, &c_b101, (ftnlen)2, (ftnlen)1, (
+ ftnlen)1);
+ } else {
+ dmake_("GE", " ", " ", &ma, &na, &ab[k * *nmax + 1], nmax,
+ &bb[1], &ldb, &reset, &c_b101, (ftnlen)2, (
+ ftnlen)1, (ftnlen)1);
+ }
+
+ for (icu = 1; icu <= 2; ++icu) {
+ *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
+ upper = *(unsigned char *)uplo == 'U';
+
+ i__3 = *nalf;
+ for (ia = 1; ia <= i__3; ++ia) {
+ alpha = alf[ia];
+
+ i__4 = *nbet;
+ for (ib = 1; ib <= i__4; ++ib) {
+ beta = bet[ib];
+
+/* Generate the matrix C. */
+
+ dmake_("SY", uplo, " ", &n, &n, &c__[c_offset],
+ nmax, &cc[1], &ldc, &reset, &c_b101, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ *(unsigned char *)transs = *(unsigned char *)
+ trans;
+ ns = n;
+ ks = k;
+ als = alpha;
+ i__5 = laa;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ as[i__] = aa[i__];
+/* L10: */
+ }
+ ldas = lda;
+ i__5 = lbb;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ bs[i__] = bb[i__];
+/* L20: */
+ }
+ ldbs = ldb;
+ bets = beta;
+ i__5 = lcc;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ cs[i__] = cc[i__];
+/* L30: */
+ }
+ ldcs = ldc;
+
+/* Call the subroutine. */
+
+ if (*trace) {
+ io___322.ciunit = *ntra;
+ s_wsfe(&io___322);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ dsyr2k_(uplo, trans, &n, &k, &alpha, &aa[1], &lda,
+ &bb[1], &ldb, &beta, &cc[1], &ldc);
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___323.ciunit = *nout;
+ s_wsfe(&io___323);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L150;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplos == *(unsigned
+ char *)uplo;
+ isame[1] = *(unsigned char *)transs == *(unsigned
+ char *)trans;
+ isame[2] = ns == n;
+ isame[3] = ks == k;
+ isame[4] = als == alpha;
+ isame[5] = lde_(&as[1], &aa[1], &laa);
+ isame[6] = ldas == lda;
+ isame[7] = lde_(&bs[1], &bb[1], &lbb);
+ isame[8] = ldbs == ldb;
+ isame[9] = bets == beta;
+ if (null) {
+ isame[10] = lde_(&cs[1], &cc[1], &lcc);
+ } else {
+ isame[10] = lderes_("SY", uplo, &n, &n, &cs[1]
+ , &cc[1], &ldc, (ftnlen)2, (ftnlen)1);
+ }
+ isame[11] = ldcs == ldc;
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__5 = nargs;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___326.ciunit = *nout;
+ s_wsfe(&io___326);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L150;
+ }
+
+ if (! null) {
+
+/* Check the result column by column. */
+
+ jjab = 1;
+ jc = 1;
+ i__5 = n;
+ for (j = 1; j <= i__5; ++j) {
+ if (upper) {
+ jj = 1;
+ lj = j;
+ } else {
+ jj = j;
+ lj = n - j + 1;
+ }
+ if (tran) {
+ i__6 = k;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ w[i__] = ab[(j - 1 << 1) * *nmax
+ + k + i__];
+ w[k + i__] = ab[(j - 1 << 1) * *
+ nmax + i__];
+/* L50: */
+ }
+ i__6 = k << 1;
+ i__7 = *nmax << 1;
+ i__8 = *nmax << 1;
+ dmmch_("T", "N", &lj, &c__1, &i__6, &
+ alpha, &ab[jjab], &i__7, &w[1]
+ , &i__8, &beta, &c__[jj + j *
+ c_dim1], nmax, &ct[1], &g[1],
+ &cc[jc], &ldc, eps, &err,
+ fatal, nout, &c_true, (ftnlen)
+ 1, (ftnlen)1);
+ } else {
+ i__6 = k;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ w[i__] = ab[(k + i__ - 1) * *nmax
+ + j];
+ w[k + i__] = ab[(i__ - 1) * *nmax
+ + j];
+/* L60: */
+ }
+ i__6 = k << 1;
+ i__7 = *nmax << 1;
+ dmmch_("N", "N", &lj, &c__1, &i__6, &
+ alpha, &ab[jj], nmax, &w[1], &
+ i__7, &beta, &c__[jj + j *
+ c_dim1], nmax, &ct[1], &g[1],
+ &cc[jc], &ldc, eps, &err,
+ fatal, nout, &c_true, (ftnlen)
+ 1, (ftnlen)1);
+ }
+ if (upper) {
+ jc += ldc;
+ } else {
+ jc = jc + ldc + 1;
+ if (tran) {
+ jjab += *nmax << 1;
+ }
+ }
+ errmax = max(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L140;
+ }
+/* L70: */
+ }
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+/* L100: */
+ }
+
+L110:
+ ;
+ }
+
+/* L120: */
+ }
+
+L130:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___333.ciunit = *nout;
+ s_wsfe(&io___333);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___334.ciunit = *nout;
+ s_wsfe(&io___334);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ goto L160;
+
+L140:
+ if (n > 1) {
+ io___335.ciunit = *nout;
+ s_wsfe(&io___335);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L150:
+ io___336.ciunit = *nout;
+ s_wsfe(&io___336);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ io___337.ciunit = *nout;
+ s_wsfe(&io___337);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L160:
+ return 0;
+
+
+/* End of DCHK5. */
+
+} /* dchk5_ */
+
+/* Subroutine */ int dchke_(integer *isnum, char *srnamt, integer *nout,
+ ftnlen srnamt_len)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE TESTS OF ERROR-E"
+ "XITS\002)";
+ static char fmt_9998[] = "(\002 ******* \002,a6,\002 FAILED THE TESTS OF"
+ " ERROR-EXITS *****\002,\002**\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublereal a[2] /* was [2][1] */, b[2] /* was [2][1] */, c__[2]
+ /* was [2][1] */, beta, alpha;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *),
+ dtrmm_(char *, char *, char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *), dsymm_(char *, char *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *),
+ dtrsm_(char *, char *, char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *), dsyrk_(char *, char *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *), dsyr2k_(char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *), chkxer_(char *, integer *, integer *, logical *,
+ logical *);
+
+ /* Fortran I/O blocks */
+ static cilist io___343 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___344 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* Tests the error exits from the Level 3 Blas. */
+/* Requires a special version of the error-handling routine XERBLA. */
+/* A, B and C should not need to be defined. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* 3-19-92: Initialize ALPHA and BETA (eca) */
+/* 3-19-92: Fix argument 12 in calls to SSYMM with INFOT = 9 (eca) */
+
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Parameters .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Subroutines .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+/* OK is set to .FALSE. by the special version of XERBLA or by CHKXER */
+/* if anything is wrong. */
+ infoc_1.ok = TRUE_;
+/* LERR is set to .TRUE. by the special version of XERBLA each time */
+/* it is called, and is then tested and re-set by CHKXER. */
+ infoc_1.lerr = FALSE_;
+
+/* Initialize ALPHA and BETA. */
+
+ alpha = 1.;
+ beta = 2.;
+
+ switch (*isnum) {
+ case 1: goto L10;
+ case 2: goto L20;
+ case 3: goto L30;
+ case 4: goto L40;
+ case 5: goto L50;
+ case 6: goto L60;
+ }
+L10:
+ infoc_1.infot = 1;
+ dgemm_("/", "N", &c__0, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 1;
+ dgemm_("/", "T", &c__0, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ dgemm_("N", "/", &c__0, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ dgemm_("T", "/", &c__0, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dgemm_("N", "N", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dgemm_("N", "T", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dgemm_("T", "N", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dgemm_("T", "T", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dgemm_("N", "N", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dgemm_("N", "T", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dgemm_("T", "N", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dgemm_("T", "T", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dgemm_("N", "N", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dgemm_("N", "T", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dgemm_("T", "N", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dgemm_("T", "T", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ dgemm_("N", "N", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ dgemm_("N", "T", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ dgemm_("T", "N", &c__0, &c__0, &c__2, &alpha, a, &c__1, b, &c__2, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ dgemm_("T", "T", &c__0, &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ dgemm_("N", "N", &c__0, &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ dgemm_("T", "N", &c__0, &c__0, &c__2, &alpha, a, &c__2, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ dgemm_("N", "T", &c__0, &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ dgemm_("T", "T", &c__0, &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ dgemm_("N", "N", &c__2, &c__0, &c__0, &alpha, a, &c__2, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ dgemm_("N", "T", &c__2, &c__0, &c__0, &alpha, a, &c__2, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ dgemm_("T", "N", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ dgemm_("T", "T", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L70;
+L20:
+ infoc_1.infot = 1;
+ dsymm_("/", "U", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ dsymm_("L", "/", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dsymm_("L", "U", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dsymm_("R", "U", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dsymm_("L", "L", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dsymm_("R", "L", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dsymm_("L", "U", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dsymm_("R", "U", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dsymm_("L", "L", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dsymm_("R", "L", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ dsymm_("L", "U", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ dsymm_("R", "U", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ dsymm_("L", "L", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ dsymm_("R", "L", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dsymm_("L", "U", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dsymm_("R", "U", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dsymm_("L", "L", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dsymm_("R", "L", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ dsymm_("L", "U", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ dsymm_("R", "U", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ dsymm_("L", "L", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ dsymm_("R", "L", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L70;
+L30:
+ infoc_1.infot = 1;
+ dtrmm_("/", "U", "N", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ dtrmm_("L", "/", "N", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dtrmm_("L", "U", "/", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dtrmm_("L", "U", "N", "/", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dtrmm_("L", "U", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dtrmm_("L", "U", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dtrmm_("R", "U", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dtrmm_("R", "U", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dtrmm_("L", "L", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dtrmm_("L", "L", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dtrmm_("R", "L", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dtrmm_("R", "L", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ dtrmm_("L", "U", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ dtrmm_("L", "U", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ dtrmm_("R", "U", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ dtrmm_("R", "U", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ dtrmm_("L", "L", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ dtrmm_("L", "L", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ dtrmm_("R", "L", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ dtrmm_("R", "L", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dtrmm_("L", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dtrmm_("L", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dtrmm_("R", "U", "N", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dtrmm_("R", "U", "T", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dtrmm_("L", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dtrmm_("L", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dtrmm_("R", "L", "N", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dtrmm_("R", "L", "T", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ dtrmm_("L", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ dtrmm_("L", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ dtrmm_("R", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ dtrmm_("R", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ dtrmm_("L", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ dtrmm_("L", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ dtrmm_("R", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ dtrmm_("R", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L70;
+L40:
+ infoc_1.infot = 1;
+ dtrsm_("/", "U", "N", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ dtrsm_("L", "/", "N", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dtrsm_("L", "U", "/", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dtrsm_("L", "U", "N", "/", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dtrsm_("L", "U", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dtrsm_("L", "U", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dtrsm_("R", "U", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dtrsm_("R", "U", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dtrsm_("L", "L", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dtrsm_("L", "L", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dtrsm_("R", "L", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ dtrsm_("R", "L", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ dtrsm_("L", "U", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ dtrsm_("L", "U", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ dtrsm_("R", "U", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ dtrsm_("R", "U", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ dtrsm_("L", "L", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ dtrsm_("L", "L", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ dtrsm_("R", "L", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ dtrsm_("R", "L", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dtrsm_("L", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dtrsm_("L", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dtrsm_("R", "U", "N", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dtrsm_("R", "U", "T", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dtrsm_("L", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dtrsm_("L", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dtrsm_("R", "L", "N", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dtrsm_("R", "L", "T", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ dtrsm_("L", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ dtrsm_("L", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ dtrsm_("R", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ dtrsm_("R", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ dtrsm_("L", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ dtrsm_("L", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ dtrsm_("R", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ dtrsm_("R", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L70;
+L50:
+ infoc_1.infot = 1;
+ dsyrk_("/", "N", &c__0, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ dsyrk_("U", "/", &c__0, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dsyrk_("U", "N", &c_n1, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dsyrk_("U", "T", &c_n1, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dsyrk_("L", "N", &c_n1, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dsyrk_("L", "T", &c_n1, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dsyrk_("U", "N", &c__0, &c_n1, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dsyrk_("U", "T", &c__0, &c_n1, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dsyrk_("L", "N", &c__0, &c_n1, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dsyrk_("L", "T", &c__0, &c_n1, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ dsyrk_("U", "N", &c__2, &c__0, &alpha, a, &c__1, &beta, c__, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ dsyrk_("U", "T", &c__0, &c__2, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ dsyrk_("L", "N", &c__2, &c__0, &alpha, a, &c__1, &beta, c__, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ dsyrk_("L", "T", &c__0, &c__2, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ dsyrk_("U", "N", &c__2, &c__0, &alpha, a, &c__2, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ dsyrk_("U", "T", &c__2, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ dsyrk_("L", "N", &c__2, &c__0, &alpha, a, &c__2, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ dsyrk_("L", "T", &c__2, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L70;
+L60:
+ infoc_1.infot = 1;
+ dsyr2k_("/", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ dsyr2k_("U", "/", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dsyr2k_("U", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dsyr2k_("U", "T", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dsyr2k_("L", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ dsyr2k_("L", "T", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dsyr2k_("U", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dsyr2k_("U", "T", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dsyr2k_("L", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ dsyr2k_("L", "T", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ dsyr2k_("U", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ dsyr2k_("U", "T", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ dsyr2k_("L", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ dsyr2k_("L", "T", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dsyr2k_("U", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dsyr2k_("U", "T", &c__0, &c__2, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dsyr2k_("L", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ dsyr2k_("L", "T", &c__0, &c__2, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ dsyr2k_("U", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ dsyr2k_("U", "T", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ dsyr2k_("L", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ dsyr2k_("L", "T", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+
+L70:
+ if (infoc_1.ok) {
+ io___343.ciunit = *nout;
+ s_wsfe(&io___343);
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ } else {
+ io___344.ciunit = *nout;
+ s_wsfe(&io___344);
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ }
+ return 0;
+
+
+/* End of DCHKE. */
+
+} /* dchke_ */
+
+/* Subroutine */ int dmake_(char *type__, char *uplo, char *diag, integer *m,
+ integer *n, doublereal *a, integer *nmax, doublereal *aa, integer *
+ lda, logical *reset, doublereal *transl, ftnlen type_len, ftnlen
+ uplo_len, ftnlen diag_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer i__, j;
+ logical gen, tri, sym;
+ extern doublereal dbeg_(logical *);
+ integer ibeg, iend;
+ logical unit, lower, upper;
+
+
+/* Generates values for an M by N matrix A. */
+/* Stores the values in the array AA in the data structure required */
+/* by the routine, with unwanted elements set to rogue value. */
+
+/* TYPE is 'GE', 'SY' or 'TR'. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. External Functions .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --aa;
+
+ /* Function Body */
+ gen = s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0;
+ sym = s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0;
+ tri = s_cmp(type__, "TR", (ftnlen)2, (ftnlen)2) == 0;
+ upper = (sym || tri) && *(unsigned char *)uplo == 'U';
+ lower = (sym || tri) && *(unsigned char *)uplo == 'L';
+ unit = tri && *(unsigned char *)diag == 'U';
+
+/* Generate data in array A. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (gen || upper && i__ <= j || lower && i__ >= j) {
+ a[i__ + j * a_dim1] = dbeg_(reset) + *transl;
+ if (i__ != j) {
+/* Set some elements to zero */
+ if (*n > 3 && j == *n / 2) {
+ a[i__ + j * a_dim1] = 0.;
+ }
+ if (sym) {
+ a[j + i__ * a_dim1] = a[i__ + j * a_dim1];
+ } else if (tri) {
+ a[j + i__ * a_dim1] = 0.;
+ }
+ }
+ }
+/* L10: */
+ }
+ if (tri) {
+ a[j + j * a_dim1] += 1.;
+ }
+ if (unit) {
+ a[j + j * a_dim1] = 1.;
+ }
+/* L20: */
+ }
+
+/* Store elements in array AS in data structure required by routine. */
+
+ if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1];
+/* L30: */
+ }
+ i__2 = *lda;
+ for (i__ = *m + 1; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = -1e10;
+/* L40: */
+ }
+/* L50: */
+ }
+ } else if (s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
+ "TR", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ ibeg = 1;
+ if (unit) {
+ iend = j - 1;
+ } else {
+ iend = j;
+ }
+ } else {
+ if (unit) {
+ ibeg = j + 1;
+ } else {
+ ibeg = j;
+ }
+ iend = *n;
+ }
+ i__2 = ibeg - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = -1e10;
+/* L60: */
+ }
+ i__2 = iend;
+ for (i__ = ibeg; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1];
+/* L70: */
+ }
+ i__2 = *lda;
+ for (i__ = iend + 1; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = -1e10;
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+ return 0;
+
+/* End of DMAKE. */
+
+} /* dmake_ */
+
+/* Subroutine */ int dmmch_(char *transa, char *transb, integer *m, integer *
+ n, integer *kk, doublereal *alpha, doublereal *a, integer *lda,
+ doublereal *b, integer *ldb, doublereal *beta, doublereal *c__,
+ integer *ldc, doublereal *ct, doublereal *g, doublereal *cc, integer *
+ ldcc, doublereal *eps, doublereal *err, logical *fatal, integer *nout,
+ logical *mv, ftnlen transa_len, ftnlen transb_len)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
+ " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 EX"
+ "PECTED RESULT COMPU\002,\002TED RESULT\002)";
+ static char fmt_9998[] = "(1x,i7,2g18.6)";
+ static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1,
+ cc_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal erri;
+ logical trana, tranb;
+
+ /* Fortran I/O blocks */
+ static cilist io___361 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___362 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___363 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___364 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* Checks the results of the computational tests. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Intrinsic Functions .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --ct;
+ --g;
+ cc_dim1 = *ldcc;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+
+ /* Function Body */
+ trana = *(unsigned char *)transa == 'T' || *(unsigned char *)transa ==
+ 'C';
+ tranb = *(unsigned char *)transb == 'T' || *(unsigned char *)transb ==
+ 'C';
+
+/* Compute expected result, one column at a time, in CT using data */
+/* in A, B and C. */
+/* Compute gauges in G. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ct[i__] = 0.;
+ g[i__] = 0.;
+/* L10: */
+ }
+ if (! trana && ! tranb) {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ ct[i__] += a[i__ + k * a_dim1] * b[k + j * b_dim1];
+ g[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2
+ = b[k + j * b_dim1], abs(d__2));
+/* L20: */
+ }
+/* L30: */
+ }
+ } else if (trana && ! tranb) {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ ct[i__] += a[k + i__ * a_dim1] * b[k + j * b_dim1];
+ g[i__] += (d__1 = a[k + i__ * a_dim1], abs(d__1)) * (d__2
+ = b[k + j * b_dim1], abs(d__2));
+/* L40: */
+ }
+/* L50: */
+ }
+ } else if (! trana && tranb) {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ ct[i__] += a[i__ + k * a_dim1] * b[j + k * b_dim1];
+ g[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2
+ = b[j + k * b_dim1], abs(d__2));
+/* L60: */
+ }
+/* L70: */
+ }
+ } else if (trana && tranb) {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ ct[i__] += a[k + i__ * a_dim1] * b[j + k * b_dim1];
+ g[i__] += (d__1 = a[k + i__ * a_dim1], abs(d__1)) * (d__2
+ = b[j + k * b_dim1], abs(d__2));
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ct[i__] = *alpha * ct[i__] + *beta * c__[i__ + j * c_dim1];
+ g[i__] = abs(*alpha) * g[i__] + abs(*beta) * (d__1 = c__[i__ + j *
+ c_dim1], abs(d__1));
+/* L100: */
+ }
+
+/* Compute the error ratio for this result. */
+
+ *err = 0.;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ erri = (d__1 = ct[i__] - cc[i__ + j * cc_dim1], abs(d__1)) / *eps;
+ if (g[i__] != 0.) {
+ erri /= g[i__];
+ }
+ *err = max(*err,erri);
+ if (*err * sqrt(*eps) >= 1.) {
+ goto L130;
+ }
+/* L110: */
+ }
+
+/* L120: */
+ }
+
+/* If the loop completes, all results are at least half accurate. */
+ goto L150;
+
+/* Report fatal error. */
+
+L130:
+ *fatal = TRUE_;
+ io___361.ciunit = *nout;
+ s_wsfe(&io___361);
+ e_wsfe();
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*mv) {
+ io___362.ciunit = *nout;
+ s_wsfe(&io___362);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ } else {
+ io___363.ciunit = *nout;
+ s_wsfe(&io___363);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+/* L140: */
+ }
+ if (*n > 1) {
+ io___364.ciunit = *nout;
+ s_wsfe(&io___364);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L150:
+ return 0;
+
+
+/* End of DMMCH. */
+
+} /* dmmch_ */
+
+logical lde_(doublereal *ri, doublereal *rj, integer *lr)
+{
+ /* System generated locals */
+ integer i__1;
+ logical ret_val;
+
+ /* Local variables */
+ integer i__;
+
+
+/* Tests if two arrays are identical. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ --rj;
+ --ri;
+
+ /* Function Body */
+ i__1 = *lr;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (ri[i__] != rj[i__]) {
+ goto L20;
+ }
+/* L10: */
+ }
+ ret_val = TRUE_;
+ goto L30;
+L20:
+ ret_val = FALSE_;
+L30:
+ return ret_val;
+
+/* End of LDE. */
+
+} /* lde_ */
+
+logical lderes_(char *type__, char *uplo, integer *m, integer *n, doublereal *
+ aa, doublereal *as, integer *lda, ftnlen type_len, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2;
+ logical ret_val;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer i__, j, ibeg, iend;
+ logical upper;
+
+
+/* Tests if selected elements in two arrays are equal. */
+
+/* TYPE is 'GE' or 'SY'. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ as_dim1 = *lda;
+ as_offset = 1 + as_dim1;
+ as -= as_offset;
+ aa_dim1 = *lda;
+ aa_offset = 1 + aa_dim1;
+ aa -= aa_offset;
+
+ /* Function Body */
+ upper = *(unsigned char *)uplo == 'U';
+ if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *lda;
+ for (i__ = *m + 1; i__ <= i__2; ++i__) {
+ if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) {
+ goto L70;
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ ibeg = 1;
+ iend = j;
+ } else {
+ ibeg = j;
+ iend = *n;
+ }
+ i__2 = ibeg - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) {
+ goto L70;
+ }
+/* L30: */
+ }
+ i__2 = *lda;
+ for (i__ = iend + 1; i__ <= i__2; ++i__) {
+ if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) {
+ goto L70;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+/* L60: */
+ ret_val = TRUE_;
+ goto L80;
+L70:
+ ret_val = FALSE_;
+L80:
+ return ret_val;
+
+/* End of LDERES. */
+
+} /* lderes_ */
+
+doublereal dbeg_(logical *reset)
+{
+ /* System generated locals */
+ doublereal ret_val;
+
+ /* Local variables */
+ static integer i__, ic, mi;
+
+
+/* Generates random numbers uniformly distributed between -0.5 and 0.5. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Local Scalars .. */
+/* .. Save statement .. */
+/* .. Executable Statements .. */
+ if (*reset) {
+/* Initialize local variables. */
+ mi = 891;
+ i__ = 7;
+ ic = 0;
+ *reset = FALSE_;
+ }
+
+/* The sequence of values of I is bounded between 1 and 999. */
+/* If initial I = 1,2,3,6,7 or 9, the period will be 50. */
+/* If initial I = 4 or 8, the period will be 25. */
+/* If initial I = 5, the period will be 10. */
+/* IC is used to break up the period by skipping 1 value of I in 6. */
+
+ ++ic;
+L10:
+ i__ *= mi;
+ i__ -= i__ / 1000 * 1000;
+ if (ic >= 5) {
+ ic = 0;
+ goto L10;
+ }
+ ret_val = (i__ - 500) / 1001.;
+ return ret_val;
+
+/* End of DBEG. */
+
+} /* dbeg_ */
+
+doublereal ddiff_(doublereal *x, doublereal *y)
+{
+ /* System generated locals */
+ doublereal ret_val;
+
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Executable Statements .. */
+ ret_val = *x - *y;
+ return ret_val;
+
+/* End of DDIFF. */
+
+} /* ddiff_ */
+
+/* Subroutine */ int chkxer_(char *srnamt, integer *infot, integer *nout,
+ logical *lerr, logical *ok)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ***** ILLEGAL VALUE OF PARAMETER NUMBER"
+ " \002,i2,\002 NOT D\002,\002ETECTED BY \002,a6,\002 *****\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___374 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* Tests whether XERBLA has detected an error when it should. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Executable Statements .. */
+ if (! (*lerr)) {
+ io___374.ciunit = *nout;
+ s_wsfe(&io___374);
+ do_fio(&c__1, (char *)&(*infot), (ftnlen)sizeof(integer));
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ *ok = FALSE_;
+ }
+ *lerr = FALSE_;
+ return 0;
+
+
+/* End of CHKXER. */
+
+} /* chkxer_ */
+
+/* Subroutine */ int xerbla_(char *srname, integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* XERBLA WAS CALLED WITH INFO ="
+ " \002,i6,\002 INSTEAD\002,\002 OF \002,i2,\002 *******\002)";
+ static char fmt_9997[] = "(\002 ******* XERBLA WAS CALLED WITH INFO ="
+ " \002,i6,\002 *******\002)";
+ static char fmt_9998[] = "(\002 ******* XERBLA WAS CALLED WITH SRNAME ="
+ " \002,a6,\002 INSTE\002,\002AD OF \002,a6,\002 *******\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Fortran I/O blocks */
+ static cilist io___375 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___376 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___377 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* This is a special version of XERBLA to be used only as part of */
+/* the test program for testing error exits from the Level 3 BLAS */
+/* routines. */
+
+/* XERBLA is an error handler for the Level 3 BLAS routines. */
+
+/* It is called by the Level 3 BLAS routines if an input parameter is */
+/* invalid. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+ infoc_2.lerr = TRUE_;
+ if (*info != infoc_2.infot) {
+ if (infoc_2.infot != 0) {
+ io___375.ciunit = infoc_2.nout;
+ s_wsfe(&io___375);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&infoc_2.infot, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___376.ciunit = infoc_2.nout;
+ s_wsfe(&io___376);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ infoc_2.ok = FALSE_;
+ }
+ if (s_cmp(srname, srnamc_1.srnamt, (ftnlen)6, (ftnlen)6) != 0) {
+ io___377.ciunit = infoc_2.nout;
+ s_wsfe(&io___377);
+ do_fio(&c__1, srname, (ftnlen)6);
+ do_fio(&c__1, srnamc_1.srnamt, (ftnlen)6);
+ e_wsfe();
+ infoc_2.ok = FALSE_;
+ }
+ return 0;
+
+
+/* End of XERBLA */
+
+} /* xerbla_ */
+
+/* Main program alias */ int dblat3_ () { MAIN__ (); return 0; }
diff --git a/BLAS/TESTING/sblat1.c b/BLAS/TESTING/sblat1.c
new file mode 100644
index 0000000..46112d5
--- /dev/null
+++ b/BLAS/TESTING/sblat1.c
@@ -0,0 +1,883 @@
+/* sblat1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer icase, n, incx, incy, mode;
+ logical pass;
+} combla_;
+
+#define combla_1 combla_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__9 = 9;
+static real c_b34 = 1.f;
+static integer c__5 = 5;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Initialized data */
+
+ static real sfac = 9.765625e-4f;
+
+ /* Format strings */
+ static char fmt_99999[] = "(\002 Real BLAS Test Program Results\002,/1x)";
+ static char fmt_99998[] = "(\002 ----"
+ "- PASS -----\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), e_wsfe(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+
+ /* Local variables */
+ integer ic;
+ extern /* Subroutine */ int check0_(real *), check1_(real *), check2_(
+ real *), check3_(real *), header_(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___2 = { 0, 6, 0, fmt_99999, 0 };
+ static cilist io___4 = { 0, 6, 0, fmt_99998, 0 };
+
+
+/* Test program for the REAL Level 1 BLAS. */
+/* Based upon the original BLAS test routine together with: */
+/* F06EAF Example Program Text */
+/* .. Parameters .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. External Subroutines .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+ s_wsfe(&io___2);
+ e_wsfe();
+ for (ic = 1; ic <= 10; ++ic) {
+ combla_1.icase = ic;
+ header_();
+
+/* .. Initialize PASS, INCX, INCY, and MODE for a new case. .. */
+/* .. the value 9999 for INCX, INCY or MODE will appear in the .. */
+/* .. detailed output, if any, for cases that do not involve .. */
+/* .. these parameters .. */
+
+ combla_1.pass = TRUE_;
+ combla_1.incx = 9999;
+ combla_1.incy = 9999;
+ combla_1.mode = 9999;
+ if (combla_1.icase == 3) {
+ check0_(&sfac);
+ } else if (combla_1.icase == 7 || combla_1.icase == 8 ||
+ combla_1.icase == 9 || combla_1.icase == 10) {
+ check1_(&sfac);
+ } else if (combla_1.icase == 1 || combla_1.icase == 2 ||
+ combla_1.icase == 5 || combla_1.icase == 6) {
+ check2_(&sfac);
+ } else if (combla_1.icase == 4) {
+ check3_(&sfac);
+ }
+/* -- Print */
+ if (combla_1.pass) {
+ s_wsfe(&io___4);
+ e_wsfe();
+ }
+/* L20: */
+ }
+ s_stop("", (ftnlen)0);
+
+ return 0;
+} /* MAIN__ */
+
+/* Subroutine */ int header_(void)
+{
+ /* Initialized data */
+
+ static char l[6*10] = " SDOT " "SAXPY " "SROTG " " SROT " "SCOPY " "SSWA"
+ "P " "SNRM2 " "SASUM " "SSCAL " "ISAMAX";
+
+ /* Format strings */
+ static char fmt_99999[] = "(/\002 Test of subprogram number\002,i3,12x,a"
+ "6)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 6, 0, fmt_99999, 0 };
+
+
+/* .. Parameters .. */
+/* .. Scalars in Common .. */
+/* .. Local Arrays .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+ s_wsfe(&io___6);
+ do_fio(&c__1, (char *)&combla_1.icase, (ftnlen)sizeof(integer));
+ do_fio(&c__1, l + (0 + (0 + (combla_1.icase - 1) * 6)), (ftnlen)6);
+ e_wsfe();
+ return 0;
+
+} /* header_ */
+
+/* Subroutine */ int check0_(real *sfac)
+{
+ /* Initialized data */
+
+ static real ds1[8] = { .8f,.6f,.8f,-.6f,.8f,0.f,1.f,0.f };
+ static real datrue[8] = { .5f,.5f,.5f,-.5f,-.5f,0.f,1.f,1.f };
+ static real dbtrue[8] = { 0.f,.6f,0.f,-.6f,0.f,0.f,1.f,0.f };
+ static real da1[8] = { .3f,.4f,-.3f,-.4f,-.3f,0.f,0.f,1.f };
+ static real db1[8] = { .4f,.3f,.4f,.3f,-.4f,0.f,1.f,0.f };
+ static real dc1[8] = { .6f,.8f,-.6f,.8f,.6f,1.f,0.f,1.f };
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_wsle(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+
+ /* Local variables */
+ integer k;
+ real sa, sb, sc, ss;
+ extern /* Subroutine */ int srotg_(real *, real *, real *, real *),
+ stest1_(real *, real *, real *, real *);
+
+ /* Fortran I/O blocks */
+ static cilist io___18 = { 0, 6, 0, 0, 0 };
+
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Subroutines .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+
+/* Compute true values which cannot be prestored */
+/* in decimal notation */
+
+ dbtrue[0] = 1.6666666666666667f;
+ dbtrue[2] = -1.6666666666666667f;
+ dbtrue[4] = 1.6666666666666667f;
+
+ for (k = 1; k <= 8; ++k) {
+/* .. Set N=K for identification in output if any .. */
+ combla_1.n = k;
+ if (combla_1.icase == 3) {
+/* .. SROTG .. */
+ if (k > 8) {
+ goto L40;
+ }
+ sa = da1[k - 1];
+ sb = db1[k - 1];
+ srotg_(&sa, &sb, &sc, &ss);
+ stest1_(&sa, &datrue[k - 1], &datrue[k - 1], sfac);
+ stest1_(&sb, &dbtrue[k - 1], &dbtrue[k - 1], sfac);
+ stest1_(&sc, &dc1[k - 1], &dc1[k - 1], sfac);
+ stest1_(&ss, &ds1[k - 1], &ds1[k - 1], sfac);
+ } else {
+ s_wsle(&io___18);
+ do_lio(&c__9, &c__1, " Shouldn't be here in CHECK0", (ftnlen)28);
+ e_wsle();
+ s_stop("", (ftnlen)0);
+ }
+/* L20: */
+ }
+L40:
+ return 0;
+} /* check0_ */
+
+/* Subroutine */ int check1_(real *sfac)
+{
+ /* Initialized data */
+
+ static real sa[10] = { .3f,-1.f,0.f,1.f,.3f,.3f,.3f,.3f,.3f,.3f };
+ static real dv[80] /* was [8][5][2] */ = { .1f,2.f,2.f,2.f,2.f,2.f,2.f,
+ 2.f,.3f,3.f,3.f,3.f,3.f,3.f,3.f,3.f,.3f,-.4f,4.f,4.f,4.f,4.f,4.f,
+ 4.f,.2f,-.6f,.3f,5.f,5.f,5.f,5.f,5.f,.1f,-.3f,.5f,-.1f,6.f,6.f,
+ 6.f,6.f,.1f,8.f,8.f,8.f,8.f,8.f,8.f,8.f,.3f,9.f,9.f,9.f,9.f,9.f,
+ 9.f,9.f,.3f,2.f,-.4f,2.f,2.f,2.f,2.f,2.f,.2f,3.f,-.6f,5.f,.3f,2.f,
+ 2.f,2.f,.1f,4.f,-.3f,6.f,-.5f,7.f,-.1f,3.f };
+ static real dtrue1[5] = { 0.f,.3f,.5f,.7f,.6f };
+ static real dtrue3[5] = { 0.f,.3f,.7f,1.1f,1.f };
+ static real dtrue5[80] /* was [8][5][2] */ = { .1f,2.f,2.f,2.f,2.f,
+ 2.f,2.f,2.f,-.3f,3.f,3.f,3.f,3.f,3.f,3.f,3.f,0.f,0.f,4.f,4.f,4.f,
+ 4.f,4.f,4.f,.2f,-.6f,.3f,5.f,5.f,5.f,5.f,5.f,.03f,-.09f,.15f,
+ -.03f,6.f,6.f,6.f,6.f,.1f,8.f,8.f,8.f,8.f,8.f,8.f,8.f,.09f,9.f,
+ 9.f,9.f,9.f,9.f,9.f,9.f,.09f,2.f,-.12f,2.f,2.f,2.f,2.f,2.f,.06f,
+ 3.f,-.18f,5.f,.09f,2.f,2.f,2.f,.03f,4.f,-.09f,6.f,-.15f,7.f,-.03f,
+ 3.f };
+ static integer itrue2[5] = { 0,1,2,2,3 };
+
+ /* System generated locals */
+ integer i__1;
+ real r__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_wsle(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ real sx[8];
+ integer np1, len;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real stemp[1];
+ extern doublereal sasum_(integer *, real *, integer *);
+ real strue[8];
+ extern /* Subroutine */ int stest_(integer *, real *, real *, real *,
+ real *), itest1_(integer *, integer *), stest1_(real *, real *,
+ real *, real *);
+ extern integer isamax_(integer *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___31 = { 0, 6, 0, 0, 0 };
+
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+ for (combla_1.incx = 1; combla_1.incx <= 2; ++combla_1.incx) {
+ for (np1 = 1; np1 <= 5; ++np1) {
+ combla_1.n = np1 - 1;
+ len = max(combla_1.n,1) << 1;
+/* .. Set vector arguments .. */
+ i__1 = len;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sx[i__ - 1] = dv[i__ + (np1 + combla_1.incx * 5 << 3) - 49];
+/* L20: */
+ }
+
+ if (combla_1.icase == 7) {
+/* .. SNRM2 .. */
+ stemp[0] = dtrue1[np1 - 1];
+ r__1 = snrm2_(&combla_1.n, sx, &combla_1.incx);
+ stest1_(&r__1, stemp, stemp, sfac);
+ } else if (combla_1.icase == 8) {
+/* .. SASUM .. */
+ stemp[0] = dtrue3[np1 - 1];
+ r__1 = sasum_(&combla_1.n, sx, &combla_1.incx);
+ stest1_(&r__1, stemp, stemp, sfac);
+ } else if (combla_1.icase == 9) {
+/* .. SSCAL .. */
+ sscal_(&combla_1.n, &sa[(combla_1.incx - 1) * 5 + np1 - 1],
+ sx, &combla_1.incx);
+ i__1 = len;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ strue[i__ - 1] = dtrue5[i__ + (np1 + combla_1.incx * 5 <<
+ 3) - 49];
+/* L40: */
+ }
+ stest_(&len, sx, strue, strue, sfac);
+ } else if (combla_1.icase == 10) {
+/* .. ISAMAX .. */
+ i__1 = isamax_(&combla_1.n, sx, &combla_1.incx);
+ itest1_(&i__1, &itrue2[np1 - 1]);
+ } else {
+ s_wsle(&io___31);
+ do_lio(&c__9, &c__1, " Shouldn't be here in CHECK1", (ftnlen)
+ 28);
+ e_wsle();
+ s_stop("", (ftnlen)0);
+ }
+/* L60: */
+ }
+/* L80: */
+ }
+ return 0;
+} /* check1_ */
+
+/* Subroutine */ int check2_(real *sfac)
+{
+ /* Initialized data */
+
+ static real sa = .3f;
+ static integer incxs[4] = { 1,2,-2,-1 };
+ static integer incys[4] = { 1,-2,1,-2 };
+ static integer lens[8] /* was [4][2] */ = { 1,1,2,4,1,1,3,7 };
+ static integer ns[4] = { 0,1,2,4 };
+ static real dx1[7] = { .6f,.1f,-.5f,.8f,.9f,-.3f,-.4f };
+ static real dy1[7] = { .5f,-.9f,.3f,.7f,-.6f,.2f,.8f };
+ static real dt7[16] /* was [4][4] */ = { 0.f,.3f,.21f,.62f,0.f,.3f,-.07f,
+ .85f,0.f,.3f,-.79f,-.74f,0.f,.3f,.33f,1.27f };
+ static real dt8[112] /* was [7][4][4] */ = { .5f,0.f,0.f,0.f,0.f,
+ 0.f,0.f,.68f,0.f,0.f,0.f,0.f,0.f,0.f,.68f,-.87f,0.f,0.f,0.f,0.f,
+ 0.f,.68f,-.87f,.15f,.94f,0.f,0.f,0.f,.5f,0.f,0.f,0.f,0.f,0.f,0.f,
+ .68f,0.f,0.f,0.f,0.f,0.f,0.f,.35f,-.9f,.48f,0.f,0.f,0.f,0.f,.38f,
+ -.9f,.57f,.7f,-.75f,.2f,.98f,.5f,0.f,0.f,0.f,0.f,0.f,0.f,.68f,0.f,
+ 0.f,0.f,0.f,0.f,0.f,.35f,-.72f,0.f,0.f,0.f,0.f,0.f,.38f,-.63f,
+ .15f,.88f,0.f,0.f,0.f,.5f,0.f,0.f,0.f,0.f,0.f,0.f,.68f,0.f,0.f,
+ 0.f,0.f,0.f,0.f,.68f,-.9f,.33f,0.f,0.f,0.f,0.f,.68f,-.9f,.33f,.7f,
+ -.75f,.2f,1.04f };
+ static real dt10x[112] /* was [7][4][4] */ = { .6f,0.f,0.f,0.f,0.f,
+ 0.f,0.f,.5f,0.f,0.f,0.f,0.f,0.f,0.f,.5f,-.9f,0.f,0.f,0.f,0.f,0.f,
+ .5f,-.9f,.3f,.7f,0.f,0.f,0.f,.6f,0.f,0.f,0.f,0.f,0.f,0.f,.5f,0.f,
+ 0.f,0.f,0.f,0.f,0.f,.3f,.1f,.5f,0.f,0.f,0.f,0.f,.8f,.1f,-.6f,.8f,
+ .3f,-.3f,.5f,.6f,0.f,0.f,0.f,0.f,0.f,0.f,.5f,0.f,0.f,0.f,0.f,0.f,
+ 0.f,-.9f,.1f,.5f,0.f,0.f,0.f,0.f,.7f,.1f,.3f,.8f,-.9f,-.3f,.5f,
+ .6f,0.f,0.f,0.f,0.f,0.f,0.f,.5f,0.f,0.f,0.f,0.f,0.f,0.f,.5f,.3f,
+ 0.f,0.f,0.f,0.f,0.f,.5f,.3f,-.6f,.8f,0.f,0.f,0.f };
+ static real dt10y[112] /* was [7][4][4] */ = { .5f,0.f,0.f,0.f,0.f,
+ 0.f,0.f,.6f,0.f,0.f,0.f,0.f,0.f,0.f,.6f,.1f,0.f,0.f,0.f,0.f,0.f,
+ .6f,.1f,-.5f,.8f,0.f,0.f,0.f,.5f,0.f,0.f,0.f,0.f,0.f,0.f,.6f,0.f,
+ 0.f,0.f,0.f,0.f,0.f,-.5f,-.9f,.6f,0.f,0.f,0.f,0.f,-.4f,-.9f,.9f,
+ .7f,-.5f,.2f,.6f,.5f,0.f,0.f,0.f,0.f,0.f,0.f,.6f,0.f,0.f,0.f,0.f,
+ 0.f,0.f,-.5f,.6f,0.f,0.f,0.f,0.f,0.f,-.4f,.9f,-.5f,.6f,0.f,0.f,
+ 0.f,.5f,0.f,0.f,0.f,0.f,0.f,0.f,.6f,0.f,0.f,0.f,0.f,0.f,0.f,.6f,
+ -.9f,.1f,0.f,0.f,0.f,0.f,.6f,-.9f,.1f,.7f,-.5f,.2f,.8f };
+ static real ssize1[4] = { 0.f,.3f,1.6f,3.2f };
+ static real ssize2[28] /* was [14][2] */ = { 0.f,0.f,0.f,0.f,0.f,0.f,
+ 0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,1.17f,1.17f,1.17f,1.17f,1.17f,
+ 1.17f,1.17f,1.17f,1.17f,1.17f,1.17f,1.17f,1.17f,1.17f };
+
+ /* System generated locals */
+ integer i__1;
+ real r__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_wsle(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, ki, kn, mx, my;
+ real sx[7], sy[7], stx[7], sty[7];
+ integer lenx, leny;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ integer ksize;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), sswap_(integer *, real *, integer *, real *, integer *
+), stest_(integer *, real *, real *, real *, real *), saxpy_(
+ integer *, real *, real *, integer *, real *, integer *), stest1_(
+ real *, real *, real *, real *);
+
+ /* Fortran I/O blocks */
+ static cilist io___58 = { 0, 6, 0, 0, 0 };
+
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+
+ for (ki = 1; ki <= 4; ++ki) {
+ combla_1.incx = incxs[ki - 1];
+ combla_1.incy = incys[ki - 1];
+ mx = abs(combla_1.incx);
+ my = abs(combla_1.incy);
+
+ for (kn = 1; kn <= 4; ++kn) {
+ combla_1.n = ns[kn - 1];
+ ksize = min(2,kn);
+ lenx = lens[kn + (mx << 2) - 5];
+ leny = lens[kn + (my << 2) - 5];
+/* .. Initialize all argument arrays .. */
+ for (i__ = 1; i__ <= 7; ++i__) {
+ sx[i__ - 1] = dx1[i__ - 1];
+ sy[i__ - 1] = dy1[i__ - 1];
+/* L20: */
+ }
+
+ if (combla_1.icase == 1) {
+/* .. SDOT .. */
+ r__1 = sdot_(&combla_1.n, sx, &combla_1.incx, sy, &
+ combla_1.incy);
+ stest1_(&r__1, &dt7[kn + (ki << 2) - 5], &ssize1[kn - 1],
+ sfac);
+ } else if (combla_1.icase == 2) {
+/* .. SAXPY .. */
+ saxpy_(&combla_1.n, &sa, sx, &combla_1.incx, sy, &
+ combla_1.incy);
+ i__1 = leny;
+ for (j = 1; j <= i__1; ++j) {
+ sty[j - 1] = dt8[j + (kn + (ki << 2)) * 7 - 36];
+/* L40: */
+ }
+ stest_(&leny, sy, sty, &ssize2[ksize * 14 - 14], sfac);
+ } else if (combla_1.icase == 5) {
+/* .. SCOPY .. */
+ for (i__ = 1; i__ <= 7; ++i__) {
+ sty[i__ - 1] = dt10y[i__ + (kn + (ki << 2)) * 7 - 36];
+/* L60: */
+ }
+ scopy_(&combla_1.n, sx, &combla_1.incx, sy, &combla_1.incy);
+ stest_(&leny, sy, sty, ssize2, &c_b34);
+ } else if (combla_1.icase == 6) {
+/* .. SSWAP .. */
+ sswap_(&combla_1.n, sx, &combla_1.incx, sy, &combla_1.incy);
+ for (i__ = 1; i__ <= 7; ++i__) {
+ stx[i__ - 1] = dt10x[i__ + (kn + (ki << 2)) * 7 - 36];
+ sty[i__ - 1] = dt10y[i__ + (kn + (ki << 2)) * 7 - 36];
+/* L80: */
+ }
+ stest_(&lenx, sx, stx, ssize2, &c_b34);
+ stest_(&leny, sy, sty, ssize2, &c_b34);
+ } else {
+ s_wsle(&io___58);
+ do_lio(&c__9, &c__1, " Shouldn't be here in CHECK2", (ftnlen)
+ 28);
+ e_wsle();
+ s_stop("", (ftnlen)0);
+ }
+/* L100: */
+ }
+/* L120: */
+ }
+ return 0;
+} /* check2_ */
+
+/* Subroutine */ int check3_(real *sfac)
+{
+ /* Initialized data */
+
+ static integer incxs[4] = { 1,2,-2,-1 };
+ static integer incys[4] = { 1,-2,1,-2 };
+ static integer lens[8] /* was [4][2] */ = { 1,1,2,4,1,1,3,7 };
+ static integer ns[4] = { 0,1,2,4 };
+ static real dx1[7] = { .6f,.1f,-.5f,.8f,.9f,-.3f,-.4f };
+ static real dy1[7] = { .5f,-.9f,.3f,.7f,-.6f,.2f,.8f };
+ static real sc = .8f;
+ static real ss = .6f;
+ static real dt9x[112] /* was [7][4][4] */ = { .6f,0.f,0.f,0.f,0.f,
+ 0.f,0.f,.78f,0.f,0.f,0.f,0.f,0.f,0.f,.78f,-.46f,0.f,0.f,0.f,0.f,
+ 0.f,.78f,-.46f,-.22f,1.06f,0.f,0.f,0.f,.6f,0.f,0.f,0.f,0.f,0.f,
+ 0.f,.78f,0.f,0.f,0.f,0.f,0.f,0.f,.66f,.1f,-.1f,0.f,0.f,0.f,0.f,
+ .96f,.1f,-.76f,.8f,.9f,-.3f,-.02f,.6f,0.f,0.f,0.f,0.f,0.f,0.f,
+ .78f,0.f,0.f,0.f,0.f,0.f,0.f,-.06f,.1f,-.1f,0.f,0.f,0.f,0.f,.9f,
+ .1f,-.22f,.8f,.18f,-.3f,-.02f,.6f,0.f,0.f,0.f,0.f,0.f,0.f,.78f,
+ 0.f,0.f,0.f,0.f,0.f,0.f,.78f,.26f,0.f,0.f,0.f,0.f,0.f,.78f,.26f,
+ -.76f,1.12f,0.f,0.f,0.f };
+ static real dt9y[112] /* was [7][4][4] */ = { .5f,0.f,0.f,0.f,0.f,
+ 0.f,0.f,.04f,0.f,0.f,0.f,0.f,0.f,0.f,.04f,-.78f,0.f,0.f,0.f,0.f,
+ 0.f,.04f,-.78f,.54f,.08f,0.f,0.f,0.f,.5f,0.f,0.f,0.f,0.f,0.f,0.f,
+ .04f,0.f,0.f,0.f,0.f,0.f,0.f,.7f,-.9f,-.12f,0.f,0.f,0.f,0.f,.64f,
+ -.9f,-.3f,.7f,-.18f,.2f,.28f,.5f,0.f,0.f,0.f,0.f,0.f,0.f,.04f,0.f,
+ 0.f,0.f,0.f,0.f,0.f,.7f,-1.08f,0.f,0.f,0.f,0.f,0.f,.64f,-1.26f,
+ .54f,.2f,0.f,0.f,0.f,.5f,0.f,0.f,0.f,0.f,0.f,0.f,.04f,0.f,0.f,0.f,
+ 0.f,0.f,0.f,.04f,-.9f,.18f,0.f,0.f,0.f,0.f,.04f,-.9f,.18f,.7f,
+ -.18f,.2f,.16f };
+ static real ssize2[28] /* was [14][2] */ = { 0.f,0.f,0.f,0.f,0.f,0.f,
+ 0.f,0.f,0.f,0.f,0.f,0.f,0.f,0.f,1.17f,1.17f,1.17f,1.17f,1.17f,
+ 1.17f,1.17f,1.17f,1.17f,1.17f,1.17f,1.17f,1.17f,1.17f };
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_wsle(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+
+ /* Local variables */
+ integer i__, k, ki, kn, mx, my;
+ real sx[7], sy[7], stx[7], sty[7];
+ integer lenx, leny;
+ real mwpc[11];
+ integer mwpn[11];
+ real mwps[11];
+ extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
+ integer *, real *, real *);
+ real mwpx[5], mwpy[5];
+ integer ksize;
+ real copyx[5], copyy[5];
+ extern /* Subroutine */ int stest_(integer *, real *, real *, real *,
+ real *);
+ real mwptx[55] /* was [11][5] */, mwpty[55] /* was [11][5] */;
+ integer mwpinx[11], mwpiny[11];
+ real mwpstx[5], mwpsty[5];
+
+ /* Fortran I/O blocks */
+ static cilist io___82 = { 0, 6, 0, 0, 0 };
+
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+
+ for (ki = 1; ki <= 4; ++ki) {
+ combla_1.incx = incxs[ki - 1];
+ combla_1.incy = incys[ki - 1];
+ mx = abs(combla_1.incx);
+ my = abs(combla_1.incy);
+
+ for (kn = 1; kn <= 4; ++kn) {
+ combla_1.n = ns[kn - 1];
+ ksize = min(2,kn);
+ lenx = lens[kn + (mx << 2) - 5];
+ leny = lens[kn + (my << 2) - 5];
+
+ if (combla_1.icase == 4) {
+/* .. SROT .. */
+ for (i__ = 1; i__ <= 7; ++i__) {
+ sx[i__ - 1] = dx1[i__ - 1];
+ sy[i__ - 1] = dy1[i__ - 1];
+ stx[i__ - 1] = dt9x[i__ + (kn + (ki << 2)) * 7 - 36];
+ sty[i__ - 1] = dt9y[i__ + (kn + (ki << 2)) * 7 - 36];
+/* L20: */
+ }
+ srot_(&combla_1.n, sx, &combla_1.incx, sy, &combla_1.incy, &
+ sc, &ss);
+ stest_(&lenx, sx, stx, &ssize2[ksize * 14 - 14], sfac);
+ stest_(&leny, sy, sty, &ssize2[ksize * 14 - 14], sfac);
+ } else {
+ s_wsle(&io___82);
+ do_lio(&c__9, &c__1, " Shouldn't be here in CHECK3", (ftnlen)
+ 28);
+ e_wsle();
+ s_stop("", (ftnlen)0);
+ }
+/* L40: */
+ }
+/* L60: */
+ }
+
+ mwpc[0] = 1.f;
+ for (i__ = 2; i__ <= 11; ++i__) {
+ mwpc[i__ - 1] = 0.f;
+/* L80: */
+ }
+ mwps[0] = 0.f;
+ for (i__ = 2; i__ <= 6; ++i__) {
+ mwps[i__ - 1] = 1.f;
+/* L100: */
+ }
+ for (i__ = 7; i__ <= 11; ++i__) {
+ mwps[i__ - 1] = -1.f;
+/* L120: */
+ }
+ mwpinx[0] = 1;
+ mwpinx[1] = 1;
+ mwpinx[2] = 1;
+ mwpinx[3] = -1;
+ mwpinx[4] = 1;
+ mwpinx[5] = -1;
+ mwpinx[6] = 1;
+ mwpinx[7] = 1;
+ mwpinx[8] = -1;
+ mwpinx[9] = 1;
+ mwpinx[10] = -1;
+ mwpiny[0] = 1;
+ mwpiny[1] = 1;
+ mwpiny[2] = -1;
+ mwpiny[3] = -1;
+ mwpiny[4] = 2;
+ mwpiny[5] = 1;
+ mwpiny[6] = 1;
+ mwpiny[7] = -1;
+ mwpiny[8] = -1;
+ mwpiny[9] = 2;
+ mwpiny[10] = 1;
+ for (i__ = 1; i__ <= 11; ++i__) {
+ mwpn[i__ - 1] = 5;
+/* L140: */
+ }
+ mwpn[4] = 3;
+ mwpn[9] = 3;
+ for (i__ = 1; i__ <= 5; ++i__) {
+ mwpx[i__ - 1] = (real) i__;
+ mwpy[i__ - 1] = (real) i__;
+ mwptx[i__ * 11 - 11] = (real) i__;
+ mwpty[i__ * 11 - 11] = (real) i__;
+ mwptx[i__ * 11 - 10] = (real) i__;
+ mwpty[i__ * 11 - 10] = (real) (-i__);
+ mwptx[i__ * 11 - 9] = (real) (6 - i__);
+ mwpty[i__ * 11 - 9] = (real) (i__ - 6);
+ mwptx[i__ * 11 - 8] = (real) i__;
+ mwpty[i__ * 11 - 8] = (real) (-i__);
+ mwptx[i__ * 11 - 6] = (real) (6 - i__);
+ mwpty[i__ * 11 - 6] = (real) (i__ - 6);
+ mwptx[i__ * 11 - 5] = (real) (-i__);
+ mwpty[i__ * 11 - 5] = (real) i__;
+ mwptx[i__ * 11 - 4] = (real) (i__ - 6);
+ mwpty[i__ * 11 - 4] = (real) (6 - i__);
+ mwptx[i__ * 11 - 3] = (real) (-i__);
+ mwpty[i__ * 11 - 3] = (real) i__;
+ mwptx[i__ * 11 - 1] = (real) (i__ - 6);
+ mwpty[i__ * 11 - 1] = (real) (6 - i__);
+/* L160: */
+ }
+ mwptx[4] = 1.f;
+ mwptx[15] = 3.f;
+ mwptx[26] = 5.f;
+ mwptx[37] = 4.f;
+ mwptx[48] = 5.f;
+ mwpty[4] = -1.f;
+ mwpty[15] = 2.f;
+ mwpty[26] = -2.f;
+ mwpty[37] = 4.f;
+ mwpty[48] = -3.f;
+ mwptx[9] = -1.f;
+ mwptx[20] = -3.f;
+ mwptx[31] = -5.f;
+ mwptx[42] = 4.f;
+ mwptx[53] = 5.f;
+ mwpty[9] = 1.f;
+ mwpty[20] = 2.f;
+ mwpty[31] = 2.f;
+ mwpty[42] = 4.f;
+ mwpty[53] = 3.f;
+ for (i__ = 1; i__ <= 11; ++i__) {
+ combla_1.incx = mwpinx[i__ - 1];
+ combla_1.incy = mwpiny[i__ - 1];
+ for (k = 1; k <= 5; ++k) {
+ copyx[k - 1] = mwpx[k - 1];
+ copyy[k - 1] = mwpy[k - 1];
+ mwpstx[k - 1] = mwptx[i__ + k * 11 - 12];
+ mwpsty[k - 1] = mwpty[i__ + k * 11 - 12];
+/* L180: */
+ }
+ srot_(&mwpn[i__ - 1], copyx, &combla_1.incx, copyy, &combla_1.incy, &
+ mwpc[i__ - 1], &mwps[i__ - 1]);
+ stest_(&c__5, copyx, mwpstx, mwpstx, sfac);
+ stest_(&c__5, copyy, mwpsty, mwpsty, sfac);
+/* L200: */
+ }
+ return 0;
+} /* check3_ */
+
+/* Subroutine */ int stest_(integer *len, real *scomp, real *strue, real *
+ ssize, real *sfac)
+{
+ /* Format strings */
+ static char fmt_99999[] = "(\002 F"
+ "AIL\002)";
+ static char fmt_99998[] = "(/\002 CASE N INCX INCY MODE I "
+ " \002,\002 COMP(I) TRU"
+ "E(I) DIFFERENCE\002,\002 SIZE(I)\002,/1x)";
+ static char fmt_99997[] = "(1x,i4,i3,3i5,i3,2e36.8,2e12.4)";
+
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2, r__3, r__4, r__5;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ real sd;
+ extern doublereal sdiff_(real *, real *);
+
+ /* Fortran I/O blocks */
+ static cilist io___99 = { 0, 6, 0, fmt_99999, 0 };
+ static cilist io___100 = { 0, 6, 0, fmt_99998, 0 };
+ static cilist io___101 = { 0, 6, 0, fmt_99997, 0 };
+
+
+/* ********************************* STEST ************************** */
+
+/* THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO */
+/* SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE */
+/* NEGLIGIBLE. */
+
+/* C. L. LAWSON, JPL, 1974 DEC 10 */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. External Functions .. */
+/* .. Intrinsic Functions .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ssize;
+ --strue;
+ --scomp;
+
+ /* Function Body */
+ i__1 = *len;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sd = scomp[i__] - strue[i__];
+ r__4 = (r__1 = ssize[i__], dabs(r__1)) + (r__2 = *sfac * sd, dabs(
+ r__2));
+ r__5 = (r__3 = ssize[i__], dabs(r__3));
+ if (sdiff_(&r__4, &r__5) == 0.f) {
+ goto L40;
+ }
+
+/* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I). */
+
+ if (! combla_1.pass) {
+ goto L20;
+ }
+/* PRINT FAIL MESSAGE AND HEADER. */
+ combla_1.pass = FALSE_;
+ s_wsfe(&io___99);
+ e_wsfe();
+ s_wsfe(&io___100);
+ e_wsfe();
+L20:
+ s_wsfe(&io___101);
+ do_fio(&c__1, (char *)&combla_1.icase, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.incy, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.mode, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&scomp[i__], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&strue[i__], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&sd, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&ssize[i__], (ftnlen)sizeof(real));
+ e_wsfe();
+L40:
+ ;
+ }
+ return 0;
+
+} /* stest_ */
+
+/* Subroutine */ int stest1_(real *scomp1, real *strue1, real *ssize, real *
+ sfac)
+{
+ real scomp[1], strue[1];
+ extern /* Subroutine */ int stest_(integer *, real *, real *, real *,
+ real *);
+
+/* ************************* STEST1 ***************************** */
+
+/* THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN */
+/* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE */
+/* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT. */
+
+/* C.L. LAWSON, JPL, 1978 DEC 6 */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Arrays .. */
+/* .. External Subroutines .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ssize;
+
+ /* Function Body */
+ scomp[0] = *scomp1;
+ strue[0] = *strue1;
+ stest_(&c__1, scomp, strue, &ssize[1], sfac);
+
+ return 0;
+} /* stest1_ */
+
+doublereal sdiff_(real *sa, real *sb)
+{
+ /* System generated locals */
+ real ret_val;
+
+/* ********************************* SDIFF ************************** */
+/* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 */
+
+/* .. Scalar Arguments .. */
+/* .. Executable Statements .. */
+ ret_val = *sa - *sb;
+ return ret_val;
+} /* sdiff_ */
+
+/* Subroutine */ int itest1_(integer *icomp, integer *itrue)
+{
+ /* Format strings */
+ static char fmt_99999[] = "(\002 F"
+ "AIL\002)";
+ static char fmt_99998[] = "(/\002 CASE N INCX INCY MODE "
+ " \002,\002 COMP TRU"
+ "E DIFFERENCE\002,/1x)";
+ static char fmt_99997[] = "(1x,i4,i3,3i5,2i36,i12)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer id;
+
+ /* Fortran I/O blocks */
+ static cilist io___104 = { 0, 6, 0, fmt_99999, 0 };
+ static cilist io___105 = { 0, 6, 0, fmt_99998, 0 };
+ static cilist io___107 = { 0, 6, 0, fmt_99997, 0 };
+
+
+/* ********************************* ITEST1 ************************* */
+
+/* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR */
+/* EQUALITY. */
+/* C. L. LAWSON, JPL, 1974 DEC 10 */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+
+ if (*icomp == *itrue) {
+ goto L40;
+ }
+
+/* HERE ICOMP IS NOT EQUAL TO ITRUE. */
+
+ if (! combla_1.pass) {
+ goto L20;
+ }
+/* PRINT FAIL MESSAGE AND HEADER. */
+ combla_1.pass = FALSE_;
+ s_wsfe(&io___104);
+ e_wsfe();
+ s_wsfe(&io___105);
+ e_wsfe();
+L20:
+ id = *icomp - *itrue;
+ s_wsfe(&io___107);
+ do_fio(&c__1, (char *)&combla_1.icase, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.incy, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.mode, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*icomp), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*itrue), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&id, (ftnlen)sizeof(integer));
+ e_wsfe();
+L40:
+ return 0;
+
+} /* itest1_ */
+
+/* Main program alias */ int sblat1_ () { MAIN__ (); return 0; }
diff --git a/BLAS/TESTING/sblat2.c b/BLAS/TESTING/sblat2.c
new file mode 100644
index 0000000..bd3ca22
--- /dev/null
+++ b/BLAS/TESTING/sblat2.c
@@ -0,0 +1,5007 @@
+/* sblat2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+union {
+ struct {
+ integer infot, noutc;
+ logical ok, lerr;
+ } _1;
+ struct {
+ integer infot, nout;
+ logical ok, lerr;
+ } _2;
+} infoc_;
+
+#define infoc_1 (infoc_._1)
+#define infoc_2 (infoc_._2)
+
+struct {
+ char srnamt[6];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__9 = 9;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__8 = 8;
+static integer c__4 = 4;
+static integer c__65 = 65;
+static integer c__7 = 7;
+static integer c__2 = 2;
+static real c_b121 = 1.f;
+static real c_b133 = 0.f;
+static logical c_true = TRUE_;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static logical c_false = FALSE_;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Initialized data */
+
+ static char snames[6*16] = "SGEMV " "SGBMV " "SSYMV " "SSBMV " "SSPMV "
+ "STRMV " "STBMV " "STPMV " "STRSV " "STBSV " "STPSV " "SGER "
+ "SSYR " "SSPR " "SSYR2 " "SSPR2 ";
+
+ /* Format strings */
+ static char fmt_9997[] = "(\002 NUMBER OF VALUES OF \002,a,\002 IS LESS "
+ "THAN 1 OR GREATER \002,\002THAN \002,i2)";
+ static char fmt_9996[] = "(\002 VALUE OF N IS LESS THAN 0 OR GREATER THA"
+ "N \002,i2)";
+ static char fmt_9995[] = "(\002 VALUE OF K IS LESS THAN 0\002)";
+ static char fmt_9994[] = "(\002 ABSOLUTE VALUE OF INCX OR INCY IS 0 OR G"
+ "REATER THAN \002,i2)";
+ static char fmt_9993[] = "(\002 TESTS OF THE REAL LEVEL 2 BL"
+ "AS\002,//\002 THE F\002,\002OLLOWING PARAMETER VALUES WILL BE US"
+ "ED:\002)";
+ static char fmt_9992[] = "(\002 FOR N \002,9i6)";
+ static char fmt_9991[] = "(\002 FOR K \002,7i6)";
+ static char fmt_9990[] = "(\002 FOR INCX AND INCY \002,7i6)";
+ static char fmt_9989[] = "(\002 FOR ALPHA \002,7f6.1)";
+ static char fmt_9988[] = "(\002 FOR BETA \002,7f6.1)";
+ static char fmt_9980[] = "(\002 ERROR-EXITS WILL NOT BE TESTED\002)";
+ static char fmt_9999[] = "(\002 ROUTINES PASS COMPUTATIONAL TESTS IF TES"
+ "T RATIO IS LES\002,\002S THAN\002,f8.2)";
+ static char fmt_9984[] = "(a6,l2)";
+ static char fmt_9986[] = "(\002 SUBPROGRAM NAME \002,a6,\002 NOT RECOGNI"
+ "ZED\002,/\002 ******* T\002,\002ESTS ABANDONED *******\002)";
+ static char fmt_9998[] = "(\002 RELATIVE MACHINE PRECISION IS TAKEN TO"
+ " BE\002,1p,e9.1)";
+ static char fmt_9985[] = "(\002 ERROR IN SMVCH - IN-LINE DOT PRODUCTS A"
+ "RE BEING EVALU\002,\002ATED WRONGLY.\002,/\002 SMVCH WAS CALLED "
+ "WITH TRANS = \002,a1,\002 AND RETURNED SAME = \002,l1,\002 AND E"
+ "RR = \002,f12.3,\002.\002,/\002 THIS MAY BE DUE TO FAULTS IN THE"
+ " ARITHMETIC OR THE COMPILER.\002,/\002 ******* TESTS ABANDONED *"
+ "******\002)";
+ static char fmt_9983[] = "(1x,a6,\002 WAS NOT TESTED\002)";
+ static char fmt_9982[] = "(/\002 END OF TESTS\002)";
+ static char fmt_9981[] = "(/\002 ******* FATAL ERROR - TESTS ABANDONED *"
+ "******\002)";
+ static char fmt_9987[] = "(\002 AMEND DATA FILE OR INCREASE ARRAY SIZES "
+ "IN PROGRAM\002,/\002 ******* TESTS ABANDONED *******\002)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real r__1;
+ olist o__1;
+ cllist cl__1;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void), f_open(olist *), s_wsfe(cilist *), do_fio(integer *,
+ char *, ftnlen), e_wsfe(void), s_wsle(cilist *), e_wsle(void),
+ s_rsfe(cilist *), e_rsfe(void), s_cmp(char *, char *, ftnlen,
+ ftnlen);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+ integer f_clos(cllist *);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real a[4225] /* was [65][65] */, g[65];
+ integer i__, j, n;
+ real x[65], y[65], z__[130], aa[4225];
+ integer kb[7];
+ real as[4225], xs[130], ys[130], yt[65], xx[130], yy[130], alf[7];
+ integer inc[7], nkb;
+ real bet[7];
+ extern logical lse_(real *, real *, integer *);
+ real eps, err;
+ integer nalf, idim[9];
+ logical same;
+ integer ninc, nbet, ntra;
+ logical rewi;
+ integer nout;
+ extern /* Subroutine */ int schk1_(char *, real *, real *, integer *,
+ integer *, logical *, logical *, logical *, integer *, integer *,
+ integer *, integer *, integer *, real *, integer *, real *,
+ integer *, integer *, integer *, integer *, real *, real *, real *
+ , real *, real *, real *, real *, real *, real *, real *, real *,
+ ftnlen), schk2_(char *, real *, real *, integer *, integer *,
+ logical *, logical *, logical *, integer *, integer *, integer *,
+ integer *, integer *, real *, integer *, real *, integer *,
+ integer *, integer *, integer *, real *, real *, real *, real *,
+ real *, real *, real *, real *, real *, real *, real *, ftnlen),
+ schk3_(char *, real *, real *, integer *, integer *, logical *,
+ logical *, logical *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, real *, real *, real *
+ , real *, real *, real *, real *, real *, real *, ftnlen), schk4_(
+ char *, real *, real *, integer *, integer *, logical *, logical *
+ , logical *, integer *, integer *, integer *, real *, integer *,
+ integer *, integer *, integer *, real *, real *, real *, real *,
+ real *, real *, real *, real *, real *, real *, real *, real *,
+ ftnlen), schk5_(char *, real *, real *, integer *, integer *,
+ logical *, logical *, logical *, integer *, integer *, integer *,
+ real *, integer *, integer *, integer *, integer *, real *, real *
+ , real *, real *, real *, real *, real *, real *, real *, real *,
+ real *, real *, ftnlen), schk6_(char *, real *, real *, integer *,
+ integer *, logical *, logical *, logical *, integer *, integer *,
+ integer *, real *, integer *, integer *, integer *, integer *,
+ real *, real *, real *, real *, real *, real *, real *, real *,
+ real *, real *, real *, real *, ftnlen);
+ logical fatal;
+ extern doublereal sdiff_(real *, real *);
+ extern /* Subroutine */ int schke_(integer *, char *, integer *, ftnlen);
+ logical trace;
+ integer nidim;
+ extern /* Subroutine */ int smvch_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *,
+ real *, real *, real *, real *, real *, logical *, integer *,
+ logical *, ftnlen);
+ char snaps[32], trans[1];
+ integer isnum;
+ logical ltest[16], sfatal;
+ char snamet[6];
+ real thresh;
+ logical ltestt, tsterr;
+ char summry[32];
+
+ /* Fortran I/O blocks */
+ static cilist io___2 = { 0, 5, 0, 0, 0 };
+ static cilist io___4 = { 0, 5, 0, 0, 0 };
+ static cilist io___6 = { 0, 5, 0, 0, 0 };
+ static cilist io___8 = { 0, 5, 0, 0, 0 };
+ static cilist io___11 = { 0, 5, 0, 0, 0 };
+ static cilist io___13 = { 0, 5, 0, 0, 0 };
+ static cilist io___15 = { 0, 5, 0, 0, 0 };
+ static cilist io___17 = { 0, 5, 0, 0, 0 };
+ static cilist io___19 = { 0, 5, 0, 0, 0 };
+ static cilist io___21 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___22 = { 0, 5, 0, 0, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___26 = { 0, 5, 0, 0, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___29 = { 0, 5, 0, 0, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___32 = { 0, 5, 0, 0, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___35 = { 0, 5, 0, 0, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___38 = { 0, 5, 0, 0, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___41 = { 0, 5, 0, 0, 0 };
+ static cilist io___43 = { 0, 5, 0, 0, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___46 = { 0, 5, 0, 0, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9988, 0 };
+ static cilist io___54 = { 0, 0, 0, 0, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9980, 0 };
+ static cilist io___56 = { 0, 0, 0, 0, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___58 = { 0, 0, 0, 0, 0 };
+ static cilist io___60 = { 0, 5, 1, fmt_9984, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9986, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9985, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9985, 0 };
+ static cilist io___81 = { 0, 0, 0, 0, 0 };
+ static cilist io___82 = { 0, 0, 0, fmt_9983, 0 };
+ static cilist io___83 = { 0, 0, 0, 0, 0 };
+ static cilist io___90 = { 0, 0, 0, fmt_9982, 0 };
+ static cilist io___91 = { 0, 0, 0, fmt_9981, 0 };
+ static cilist io___92 = { 0, 0, 0, fmt_9987, 0 };
+
+
+
+/* Test program for the REAL Level 2 Blas. */
+
+/* The program must be driven by a short data file. The first 18 records */
+/* of the file are read using list-directed input, the last 16 records */
+/* are read using the format ( A6, L2 ). An annotated example of a data */
+/* file can be obtained by deleting the first 3 characters from the */
+/* following 34 lines: */
+/* 'sblat2.out' NAME OF SUMMARY OUTPUT FILE */
+/* 6 UNIT NUMBER OF SUMMARY FILE */
+/* 'SBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE */
+/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */
+/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */
+/* F LOGICAL FLAG, T TO STOP ON FAILURES. */
+/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */
+/* 16.0 THRESHOLD VALUE OF TEST RATIO */
+/* 6 NUMBER OF VALUES OF N */
+/* 0 1 2 3 5 9 VALUES OF N */
+/* 4 NUMBER OF VALUES OF K */
+/* 0 1 2 4 VALUES OF K */
+/* 4 NUMBER OF VALUES OF INCX AND INCY */
+/* 1 2 -1 -2 VALUES OF INCX AND INCY */
+/* 3 NUMBER OF VALUES OF ALPHA */
+/* 0.0 1.0 0.7 VALUES OF ALPHA */
+/* 3 NUMBER OF VALUES OF BETA */
+/* 0.0 1.0 0.9 VALUES OF BETA */
+/* SGEMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* SGBMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* SSYMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* SSBMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* SSPMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* STRMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* STBMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* STPMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* STRSV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* STBSV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* STPSV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* SGER T PUT F FOR NO TEST. SAME COLUMNS. */
+/* SSYR T PUT F FOR NO TEST. SAME COLUMNS. */
+/* SSPR T PUT F FOR NO TEST. SAME COLUMNS. */
+/* SSYR2 T PUT F FOR NO TEST. SAME COLUMNS. */
+/* SSPR2 T PUT F FOR NO TEST. SAME COLUMNS. */
+
+/* See: */
+
+/* Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. */
+/* An extended set of Fortran Basic Linear Algebra Subprograms. */
+
+/* Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics */
+/* and Computer Science Division, Argonne National Laboratory, */
+/* 9700 South Cass Avenue, Argonne, Illinois 60439, US. */
+
+/* Or */
+
+/* NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms */
+/* Group Ltd., NAG Central Office, 256 Banbury Road, Oxford */
+/* OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st */
+/* Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. */
+
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers */
+/* can be run multiple times without deleting generated */
+/* output files (susan) */
+
+/* .. Parameters .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+
+/* Read name and unit number for summary output file and open file. */
+
+ s_rsle(&io___2);
+ do_lio(&c__9, &c__1, summry, (ftnlen)32);
+ e_rsle();
+ s_rsle(&io___4);
+ do_lio(&c__3, &c__1, (char *)&nout, (ftnlen)sizeof(integer));
+ e_rsle();
+ o__1.oerr = 0;
+ o__1.ounit = nout;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = summry;
+ o__1.orl = 0;
+ o__1.osta = "UNKNOWN";
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);
+ infoc_1.noutc = nout;
+
+/* Read name and unit number for snapshot output file and open file. */
+
+ s_rsle(&io___6);
+ do_lio(&c__9, &c__1, snaps, (ftnlen)32);
+ e_rsle();
+ s_rsle(&io___8);
+ do_lio(&c__3, &c__1, (char *)&ntra, (ftnlen)sizeof(integer));
+ e_rsle();
+ trace = ntra >= 0;
+ if (trace) {
+ o__1.oerr = 0;
+ o__1.ounit = ntra;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = snaps;
+ o__1.orl = 0;
+ o__1.osta = "UNKNOWN";
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);
+ }
+/* Read the flag that directs rewinding of the snapshot file. */
+ s_rsle(&io___11);
+ do_lio(&c__8, &c__1, (char *)&rewi, (ftnlen)sizeof(logical));
+ e_rsle();
+ rewi = rewi && trace;
+/* Read the flag that directs stopping on any failure. */
+ s_rsle(&io___13);
+ do_lio(&c__8, &c__1, (char *)&sfatal, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the flag that indicates whether error exits are to be tested. */
+ s_rsle(&io___15);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the threshold value of the test ratio */
+ s_rsle(&io___17);
+ do_lio(&c__4, &c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_rsle();
+
+/* Read and check the parameter values for the tests. */
+
+/* Values of N */
+ s_rsle(&io___19);
+ do_lio(&c__3, &c__1, (char *)&nidim, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nidim < 1 || nidim > 9) {
+ io___21.ciunit = nout;
+ s_wsfe(&io___21);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+ s_rsle(&io___22);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {
+ io___25.ciunit = nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, (char *)&c__65, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+/* L10: */
+ }
+/* Values of K */
+ s_rsle(&io___26);
+ do_lio(&c__3, &c__1, (char *)&nkb, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nkb < 1 || nkb > 7) {
+ io___28.ciunit = nout;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "K", (ftnlen)1);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+ s_rsle(&io___29);
+ i__1 = nkb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&kb[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nkb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (kb[i__ - 1] < 0) {
+ io___31.ciunit = nout;
+ s_wsfe(&io___31);
+ e_wsfe();
+ goto L230;
+ }
+/* L20: */
+ }
+/* Values of INCX and INCY */
+ s_rsle(&io___32);
+ do_lio(&c__3, &c__1, (char *)&ninc, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (ninc < 1 || ninc > 7) {
+ io___34.ciunit = nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "INCX AND INCY", (ftnlen)13);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+ s_rsle(&io___35);
+ i__1 = ninc;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&inc[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = ninc;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (inc[i__ - 1] == 0 || (i__2 = inc[i__ - 1], abs(i__2)) > 2) {
+ io___37.ciunit = nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+/* L30: */
+ }
+/* Values of ALPHA */
+ s_rsle(&io___38);
+ do_lio(&c__3, &c__1, (char *)&nalf, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nalf < 1 || nalf > 7) {
+ io___40.ciunit = nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "ALPHA", (ftnlen)5);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+ s_rsle(&io___41);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__4, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_rsle();
+/* Values of BETA */
+ s_rsle(&io___43);
+ do_lio(&c__3, &c__1, (char *)&nbet, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nbet < 1 || nbet > 7) {
+ io___45.ciunit = nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "BETA", (ftnlen)4);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+ s_rsle(&io___46);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__4, &c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_rsle();
+
+/* Report values of parameters. */
+
+ io___48.ciunit = nout;
+ s_wsfe(&io___48);
+ e_wsfe();
+ io___49.ciunit = nout;
+ s_wsfe(&io___49);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ io___50.ciunit = nout;
+ s_wsfe(&io___50);
+ i__1 = nkb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&kb[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ io___51.ciunit = nout;
+ s_wsfe(&io___51);
+ i__1 = ninc;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&inc[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ io___52.ciunit = nout;
+ s_wsfe(&io___52);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_wsfe();
+ io___53.ciunit = nout;
+ s_wsfe(&io___53);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_wsfe();
+ if (! tsterr) {
+ io___54.ciunit = nout;
+ s_wsle(&io___54);
+ e_wsle();
+ io___55.ciunit = nout;
+ s_wsfe(&io___55);
+ e_wsfe();
+ }
+ io___56.ciunit = nout;
+ s_wsle(&io___56);
+ e_wsle();
+ io___57.ciunit = nout;
+ s_wsfe(&io___57);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_wsfe();
+ io___58.ciunit = nout;
+ s_wsle(&io___58);
+ e_wsle();
+
+/* Read names of subroutines and flags which indicate */
+/* whether they are to be tested. */
+
+ for (i__ = 1; i__ <= 16; ++i__) {
+ ltest[i__ - 1] = FALSE_;
+/* L40: */
+ }
+L50:
+ i__1 = s_rsfe(&io___60);
+ if (i__1 != 0) {
+ goto L80;
+ }
+ i__1 = do_fio(&c__1, snamet, (ftnlen)6);
+ if (i__1 != 0) {
+ goto L80;
+ }
+ i__1 = do_fio(&c__1, (char *)<estt, (ftnlen)sizeof(logical));
+ if (i__1 != 0) {
+ goto L80;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L80;
+ }
+ for (i__ = 1; i__ <= 16; ++i__) {
+ if (s_cmp(snamet, snames + (i__ - 1) * 6, (ftnlen)6, (ftnlen)6) == 0)
+ {
+ goto L70;
+ }
+/* L60: */
+ }
+ io___63.ciunit = nout;
+ s_wsfe(&io___63);
+ do_fio(&c__1, snamet, (ftnlen)6);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+L70:
+ ltest[i__ - 1] = ltestt;
+ goto L50;
+
+L80:
+ cl__1.cerr = 0;
+ cl__1.cunit = 5;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+
+/* Compute EPS (the machine precision). */
+
+ eps = 1.f;
+L90:
+ r__1 = eps + 1.f;
+ if (sdiff_(&r__1, &c_b121) == 0.f) {
+ goto L100;
+ }
+ eps *= .5f;
+ goto L90;
+L100:
+ eps += eps;
+ io___65.ciunit = nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+
+/* Check the reliability of SMVCH using exact data. */
+
+ n = 32;
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ - j + 1;
+ a[i__ + j * 65 - 66] = (real) max(i__3,0);
+/* L110: */
+ }
+ x[j - 1] = (real) j;
+ y[j - 1] = 0.f;
+/* L120: */
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ yy[j - 1] = (real) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3)
+ ;
+/* L130: */
+ }
+/* YY holds the exact result. On exit from SMVCH YT holds */
+/* the result computed by SMVCH. */
+ *(unsigned char *)trans = 'N';
+ smvch_(trans, &n, &n, &c_b121, a, &c__65, x, &c__1, &c_b133, y, &c__1, yt,
+ g, yy, &eps, &err, &fatal, &nout, &c_true, (ftnlen)1);
+ same = lse_(yy, yt, &n);
+ if (! same || err != 0.f) {
+ io___78.ciunit = nout;
+ s_wsfe(&io___78);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ *(unsigned char *)trans = 'T';
+ smvch_(trans, &n, &n, &c_b121, a, &c__65, x, &c_n1, &c_b133, y, &c_n1, yt,
+ g, yy, &eps, &err, &fatal, &nout, &c_true, (ftnlen)1);
+ same = lse_(yy, yt, &n);
+ if (! same || err != 0.f) {
+ io___79.ciunit = nout;
+ s_wsfe(&io___79);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Test each subroutine in turn. */
+
+ for (isnum = 1; isnum <= 16; ++isnum) {
+ io___81.ciunit = nout;
+ s_wsle(&io___81);
+ e_wsle();
+ if (! ltest[isnum - 1]) {
+/* Subprogram is not to be tested. */
+ io___82.ciunit = nout;
+ s_wsfe(&io___82);
+ do_fio(&c__1, snames + (isnum - 1) * 6, (ftnlen)6);
+ e_wsfe();
+ } else {
+ s_copy(srnamc_1.srnamt, snames + (isnum - 1) * 6, (ftnlen)6, (
+ ftnlen)6);
+/* Test error exits. */
+ if (tsterr) {
+ schke_(&isnum, snames + (isnum - 1) * 6, &nout, (ftnlen)6);
+ io___83.ciunit = nout;
+ s_wsle(&io___83);
+ e_wsle();
+ }
+/* Test computations. */
+ infoc_1.infot = 0;
+ infoc_1.ok = TRUE_;
+ fatal = FALSE_;
+ switch (isnum) {
+ case 1: goto L140;
+ case 2: goto L140;
+ case 3: goto L150;
+ case 4: goto L150;
+ case 5: goto L150;
+ case 6: goto L160;
+ case 7: goto L160;
+ case 8: goto L160;
+ case 9: goto L160;
+ case 10: goto L160;
+ case 11: goto L160;
+ case 12: goto L170;
+ case 13: goto L180;
+ case 14: goto L180;
+ case 15: goto L190;
+ case 16: goto L190;
+ }
+/* Test SGEMV, 01, and SGBMV, 02. */
+L140:
+ schk1_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, alf,
+ &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, as, x, xx,
+ xs, y, yy, ys, yt, g, (ftnlen)6);
+ goto L200;
+/* Test SSYMV, 03, SSBMV, 04, and SSPMV, 05. */
+L150:
+ schk2_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, alf,
+ &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, as, x, xx,
+ xs, y, yy, ys, yt, g, (ftnlen)6);
+ goto L200;
+/* Test STRMV, 06, STBMV, 07, STPMV, 08, */
+/* STRSV, 09, STBSV, 10, and STPSV, 11. */
+L160:
+ schk3_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &ninc, inc,
+ &c__65, &c__2, a, aa, as, y, yy, ys, yt, g, z__, (ftnlen)
+ 6);
+ goto L200;
+/* Test SGER, 12. */
+L170:
+ schk4_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &ninc,
+ inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, ys, yt,
+ g, z__, (ftnlen)6);
+ goto L200;
+/* Test SSYR, 13, and SSPR, 14. */
+L180:
+ schk5_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &ninc,
+ inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, ys, yt,
+ g, z__, (ftnlen)6);
+ goto L200;
+/* Test SSYR2, 15, and SSPR2, 16. */
+L190:
+ schk6_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &ninc,
+ inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, ys, yt,
+ g, z__, (ftnlen)6);
+
+L200:
+ if (fatal && sfatal) {
+ goto L220;
+ }
+ }
+/* L210: */
+ }
+ io___90.ciunit = nout;
+ s_wsfe(&io___90);
+ e_wsfe();
+ goto L240;
+
+L220:
+ io___91.ciunit = nout;
+ s_wsfe(&io___91);
+ e_wsfe();
+ goto L240;
+
+L230:
+ io___92.ciunit = nout;
+ s_wsfe(&io___92);
+ e_wsfe();
+
+L240:
+ if (trace) {
+ cl__1.cerr = 0;
+ cl__1.cunit = ntra;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ }
+ cl__1.cerr = 0;
+ cl__1.cunit = nout;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ s_stop("", (ftnlen)0);
+
+
+/* End of SBLAT2. */
+
+ return 0;
+} /* MAIN__ */
+
+/* Subroutine */ int schk1_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nkb, integer *kb, integer *
+ nalf, real *alf, integer *nbet, real *bet, integer *ninc, integer *
+ inc, integer *nmax, integer *incmax, real *a, real *aa, real *as,
+ real *x, real *xx, real *xs, real *y, real *yy, real *ys, real *yt,
+ real *g, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ich[3] = "NTC";
+
+ /* Format strings */
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "2(i3,\002,\002),f4.1,\002, A,\002,i3,\002, X,\002,i2,\002,\002,f"
+ "4.1,\002, Y,\002,i2,\002) .\002)";
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "4(i3,\002,\002),f4.1,\002, A,\002,i3,\002, X,\002,i2,\002,\002,f"
+ "4.1,\002, Y,\002,i2,\002) .\002)";
+ static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, m, n, ia, ib, ic, nc, nd, im, in, kl, ml, nk, nl, ku, ix, iy,
+ ms, lx, ly, ns, laa, lda;
+ real als, bls;
+ extern logical lse_(real *, real *, integer *);
+ real err;
+ integer iku, kls, kus;
+ real beta;
+ integer ldas;
+ logical same;
+ integer incx, incy;
+ logical full, tran, null;
+ real alpha;
+ logical isame[13];
+ extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *,
+ integer *, logical *, real *, ftnlen, ftnlen, ftnlen);
+ integer nargs;
+ extern /* Subroutine */ int sgbmv_(char *, integer *, integer *, integer *
+, integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *), smvch_(char *, integer *, integer *,
+ real *, real *, integer *, real *, integer *, real *, real *,
+ integer *, real *, real *, real *, real *, real *, logical *,
+ integer *, logical *, ftnlen), sgemv_(char *, integer *, integer *
+, real *, real *, integer *, real *, integer *, real *, real *,
+ integer *);
+ logical reset;
+ integer incxs, incys;
+ char trans[1];
+ logical banded;
+ real errmax;
+ extern logical lseres_(char *, char *, integer *, integer *, real *, real
+ *, integer *, ftnlen, ftnlen);
+ real transl;
+ char transs[1];
+
+ /* Fortran I/O blocks */
+ static cilist io___139 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___140 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___141 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___144 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___146 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___147 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___148 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___149 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___150 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests SGEMV and SGBMV. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --kb;
+ --alf;
+ --bet;
+ --inc;
+ --g;
+ --yt;
+ --y;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ys;
+ --yy;
+ --xs;
+ --xx;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ full = *(unsigned char *)&sname[2] == 'E';
+ banded = *(unsigned char *)&sname[2] == 'B';
+/* Define the number of arguments. */
+ if (full) {
+ nargs = 11;
+ } else if (banded) {
+ nargs = 13;
+ }
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.f;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+ nd = n / 2 + 1;
+
+ for (im = 1; im <= 2; ++im) {
+ if (im == 1) {
+/* Computing MAX */
+ i__2 = n - nd;
+ m = max(i__2,0);
+ }
+ if (im == 2) {
+/* Computing MIN */
+ i__2 = n + nd;
+ m = min(i__2,*nmax);
+ }
+
+ if (banded) {
+ nk = *nkb;
+ } else {
+ nk = 1;
+ }
+ i__2 = nk;
+ for (iku = 1; iku <= i__2; ++iku) {
+ if (banded) {
+ ku = kb[iku];
+/* Computing MAX */
+ i__3 = ku - 1;
+ kl = max(i__3,0);
+ } else {
+ ku = n - 1;
+ kl = m - 1;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ if (banded) {
+ lda = kl + ku + 1;
+ } else {
+ lda = m;
+ }
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L100;
+ }
+ laa = lda * n;
+ null = n <= 0 || m <= 0;
+
+/* Generate the matrix A. */
+
+ transl = 0.f;
+ smake_(sname + 1, " ", " ", &m, &n, &a[a_offset], nmax, &aa[1]
+ , &lda, &kl, &ku, &reset, &transl, (ftnlen)2, (ftnlen)
+ 1, (ftnlen)1);
+
+ for (ic = 1; ic <= 3; ++ic) {
+ *(unsigned char *)trans = *(unsigned char *)&ich[ic - 1];
+ tran = *(unsigned char *)trans == 'T' || *(unsigned char *
+ )trans == 'C';
+
+ if (tran) {
+ ml = n;
+ nl = m;
+ } else {
+ ml = m;
+ nl = n;
+ }
+
+ i__3 = *ninc;
+ for (ix = 1; ix <= i__3; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * nl;
+
+/* Generate the vector X. */
+
+ transl = .5f;
+ i__4 = abs(incx);
+ i__5 = nl - 1;
+ smake_("GE", " ", " ", &c__1, &nl, &x[1], &c__1, &xx[
+ 1], &i__4, &c__0, &i__5, &reset, &transl, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+ if (nl > 1) {
+ x[nl / 2] = 0.f;
+ xx[abs(incx) * (nl / 2 - 1) + 1] = 0.f;
+ }
+
+ i__4 = *ninc;
+ for (iy = 1; iy <= i__4; ++iy) {
+ incy = inc[iy];
+ ly = abs(incy) * ml;
+
+ i__5 = *nalf;
+ for (ia = 1; ia <= i__5; ++ia) {
+ alpha = alf[ia];
+
+ i__6 = *nbet;
+ for (ib = 1; ib <= i__6; ++ib) {
+ beta = bet[ib];
+
+/* Generate the vector Y. */
+
+ transl = 0.f;
+ i__7 = abs(incy);
+ i__8 = ml - 1;
+ smake_("GE", " ", " ", &c__1, &ml, &y[1],
+ &c__1, &yy[1], &i__7, &c__0, &
+ i__8, &reset, &transl, (ftnlen)2,
+ (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the */
+/* subroutine. */
+
+ *(unsigned char *)transs = *(unsigned
+ char *)trans;
+ ms = m;
+ ns = n;
+ kls = kl;
+ kus = ku;
+ als = alpha;
+ i__7 = laa;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ as[i__] = aa[i__];
+/* L10: */
+ }
+ ldas = lda;
+ i__7 = lx;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ xs[i__] = xx[i__];
+/* L20: */
+ }
+ incxs = incx;
+ bls = beta;
+ i__7 = ly;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ ys[i__] = yy[i__];
+/* L30: */
+ }
+ incys = incy;
+
+/* Call the subroutine. */
+
+ if (full) {
+ if (*trace) {
+ io___139.ciunit = *ntra;
+ s_wsfe(&io___139);
+ do_fio(&c__1, (char *)&nc, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (
+ ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (
+ ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incy, (
+ ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ sgemv_(trans, &m, &n, &alpha, &aa[1],
+ &lda, &xx[1], &incx, &beta, &
+ yy[1], &incy);
+ } else if (banded) {
+ if (*trace) {
+ io___140.ciunit = *ntra;
+ s_wsfe(&io___140);
+ do_fio(&c__1, (char *)&nc, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (
+ ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (
+ ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incy, (
+ ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ sgbmv_(trans, &m, &n, &kl, &ku, &
+ alpha, &aa[1], &lda, &xx[1], &
+ incx, &beta, &yy[1], &incy);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___141.ciunit = *nout;
+ s_wsfe(&io___141);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L130;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)trans == *(
+ unsigned char *)transs;
+ isame[1] = ms == m;
+ isame[2] = ns == n;
+ if (full) {
+ isame[3] = als == alpha;
+ isame[4] = lse_(&as[1], &aa[1], &laa);
+ isame[5] = ldas == lda;
+ isame[6] = lse_(&xs[1], &xx[1], &lx);
+ isame[7] = incxs == incx;
+ isame[8] = bls == beta;
+ if (null) {
+ isame[9] = lse_(&ys[1], &yy[1], &
+ ly);
+ } else {
+ i__7 = abs(incy);
+ isame[9] = lseres_("GE", " ", &
+ c__1, &ml, &ys[1], &yy[1],
+ &i__7, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[10] = incys == incy;
+ } else if (banded) {
+ isame[3] = kls == kl;
+ isame[4] = kus == ku;
+ isame[5] = als == alpha;
+ isame[6] = lse_(&as[1], &aa[1], &laa);
+ isame[7] = ldas == lda;
+ isame[8] = lse_(&xs[1], &xx[1], &lx);
+ isame[9] = incxs == incx;
+ isame[10] = bls == beta;
+ if (null) {
+ isame[11] = lse_(&ys[1], &yy[1], &
+ ly);
+ } else {
+ i__7 = abs(incy);
+ isame[11] = lseres_("GE", " ", &
+ c__1, &ml, &ys[1], &yy[1],
+ &i__7, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[12] = incys == incy;
+ }
+
+/* If data was incorrectly changed, report */
+/* and return. */
+
+ same = TRUE_;
+ i__7 = nargs;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___144.ciunit = *nout;
+ s_wsfe(&io___144);
+ do_fio(&c__1, (char *)&i__, (
+ ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L130;
+ }
+
+ if (! null) {
+
+/* Check the result. */
+
+ smvch_(trans, &m, &n, &alpha, &a[
+ a_offset], nmax, &x[1], &incx,
+ &beta, &y[1], &incy, &yt[1],
+ &g[1], &yy[1], eps, &err,
+ fatal, nout, &c_true, (ftnlen)
+ 1);
+ errmax = dmax(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L130;
+ }
+ } else {
+/* Avoid repeating tests with M.le.0 or */
+/* N.le.0. */
+ goto L110;
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+/* L70: */
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+L110:
+ ;
+ }
+
+/* L120: */
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___146.ciunit = *nout;
+ s_wsfe(&io___146);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___147.ciunit = *nout;
+ s_wsfe(&io___147);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ goto L140;
+
+L130:
+ io___148.ciunit = *nout;
+ s_wsfe(&io___148);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (full) {
+ io___149.ciunit = *nout;
+ s_wsfe(&io___149);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (banded) {
+ io___150.ciunit = *nout;
+ s_wsfe(&io___150);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L140:
+ return 0;
+
+
+/* End of SCHK1. */
+
+} /* schk1_ */
+
+/* Subroutine */ int schk2_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nkb, integer *kb, integer *
+ nalf, real *alf, integer *nbet, real *bet, integer *ninc, integer *
+ inc, integer *nmax, integer *incmax, real *a, real *aa, real *as,
+ real *x, real *xx, real *xs, real *y, real *yy, real *ys, real *yt,
+ real *g, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ich[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,\002,f4.1,\002, A,\002,i3,\002, X,\002,i2,\002,\002,f4.1,"
+ "\002, Y,\002,i2,\002) .\002)";
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "2(i3,\002,\002),f4.1,\002, A,\002,i3,\002, X,\002,i2,\002,\002,f"
+ "4.1,\002, Y,\002,i2,\002) .\002)";
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,\002,f4.1,\002, AP\002,\002, X,\002,i2,\002,\002,f4.1"
+ ",\002, Y,\002,i2,\002) .\002)";
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, k, n, ia, ib, ic, nc, ik, in, nk, ks, ix, iy, ns, lx, ly,
+ laa, lda;
+ real als, bls;
+ extern logical lse_(real *, real *, integer *);
+ real err, beta;
+ integer ldas;
+ logical same;
+ integer incx, incy;
+ logical full, null;
+ char uplo[1];
+ real alpha;
+ logical isame[13];
+ extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *,
+ integer *, logical *, real *, ftnlen, ftnlen, ftnlen);
+ integer nargs;
+ extern /* Subroutine */ int smvch_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *,
+ real *, real *, real *, real *, real *, logical *, integer *,
+ logical *, ftnlen);
+ logical reset;
+ integer incxs, incys;
+ extern /* Subroutine */ int ssbmv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ char uplos[1];
+ extern /* Subroutine */ int sspmv_(char *, integer *, real *, real *,
+ real *, integer *, real *, real *, integer *), ssymv_(
+ char *, integer *, real *, real *, integer *, real *, integer *,
+ real *, real *, integer *);
+ logical banded, packed;
+ real errmax;
+ extern logical lseres_(char *, char *, integer *, integer *, real *, real
+ *, integer *, ftnlen, ftnlen);
+ real transl;
+
+ /* Fortran I/O blocks */
+ static cilist io___189 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___190 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___191 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___192 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___195 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___197 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___198 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___199 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___200 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___201 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___202 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests SSYMV, SSBMV and SSPMV. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --kb;
+ --alf;
+ --bet;
+ --inc;
+ --g;
+ --yt;
+ --y;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ys;
+ --yy;
+ --xs;
+ --xx;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ full = *(unsigned char *)&sname[2] == 'Y';
+ banded = *(unsigned char *)&sname[2] == 'B';
+ packed = *(unsigned char *)&sname[2] == 'P';
+/* Define the number of arguments. */
+ if (full) {
+ nargs = 10;
+ } else if (banded) {
+ nargs = 11;
+ } else if (packed) {
+ nargs = 9;
+ }
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.f;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+
+ if (banded) {
+ nk = *nkb;
+ } else {
+ nk = 1;
+ }
+ i__2 = nk;
+ for (ik = 1; ik <= i__2; ++ik) {
+ if (banded) {
+ k = kb[ik];
+ } else {
+ k = n - 1;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ if (banded) {
+ lda = k + 1;
+ } else {
+ lda = n;
+ }
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L100;
+ }
+ if (packed) {
+ laa = n * (n + 1) / 2;
+ } else {
+ laa = lda * n;
+ }
+ null = n <= 0;
+
+ for (ic = 1; ic <= 2; ++ic) {
+ *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];
+
+/* Generate the matrix A. */
+
+ transl = 0.f;
+ smake_(sname + 1, uplo, " ", &n, &n, &a[a_offset], nmax, &aa[
+ 1], &lda, &k, &k, &reset, &transl, (ftnlen)2, (ftnlen)
+ 1, (ftnlen)1);
+
+ i__3 = *ninc;
+ for (ix = 1; ix <= i__3; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * n;
+
+/* Generate the vector X. */
+
+ transl = .5f;
+ i__4 = abs(incx);
+ i__5 = n - 1;
+ smake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &
+ i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (
+ ftnlen)1, (ftnlen)1);
+ if (n > 1) {
+ x[n / 2] = 0.f;
+ xx[abs(incx) * (n / 2 - 1) + 1] = 0.f;
+ }
+
+ i__4 = *ninc;
+ for (iy = 1; iy <= i__4; ++iy) {
+ incy = inc[iy];
+ ly = abs(incy) * n;
+
+ i__5 = *nalf;
+ for (ia = 1; ia <= i__5; ++ia) {
+ alpha = alf[ia];
+
+ i__6 = *nbet;
+ for (ib = 1; ib <= i__6; ++ib) {
+ beta = bet[ib];
+
+/* Generate the vector Y. */
+
+ transl = 0.f;
+ i__7 = abs(incy);
+ i__8 = n - 1;
+ smake_("GE", " ", " ", &c__1, &n, &y[1], &
+ c__1, &yy[1], &i__7, &c__0, &i__8, &
+ reset, &transl, (ftnlen)2, (ftnlen)1,
+ (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the */
+/* subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)
+ uplo;
+ ns = n;
+ ks = k;
+ als = alpha;
+ i__7 = laa;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ as[i__] = aa[i__];
+/* L10: */
+ }
+ ldas = lda;
+ i__7 = lx;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ xs[i__] = xx[i__];
+/* L20: */
+ }
+ incxs = incx;
+ bls = beta;
+ i__7 = ly;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ ys[i__] = yy[i__];
+/* L30: */
+ }
+ incys = incy;
+
+/* Call the subroutine. */
+
+ if (full) {
+ if (*trace) {
+ io___189.ciunit = *ntra;
+ s_wsfe(&io___189);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&incy, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ssymv_(uplo, &n, &alpha, &aa[1], &lda, &
+ xx[1], &incx, &beta, &yy[1], &
+ incy);
+ } else if (banded) {
+ if (*trace) {
+ io___190.ciunit = *ntra;
+ s_wsfe(&io___190);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&incy, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ssbmv_(uplo, &n, &k, &alpha, &aa[1], &lda,
+ &xx[1], &incx, &beta, &yy[1], &
+ incy);
+ } else if (packed) {
+ if (*trace) {
+ io___191.ciunit = *ntra;
+ s_wsfe(&io___191);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&incy, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ sspmv_(uplo, &n, &alpha, &aa[1], &xx[1], &
+ incx, &beta, &yy[1], &incy);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___192.ciunit = *nout;
+ s_wsfe(&io___192);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplo == *(
+ unsigned char *)uplos;
+ isame[1] = ns == n;
+ if (full) {
+ isame[2] = als == alpha;
+ isame[3] = lse_(&as[1], &aa[1], &laa);
+ isame[4] = ldas == lda;
+ isame[5] = lse_(&xs[1], &xx[1], &lx);
+ isame[6] = incxs == incx;
+ isame[7] = bls == beta;
+ if (null) {
+ isame[8] = lse_(&ys[1], &yy[1], &ly);
+ } else {
+ i__7 = abs(incy);
+ isame[8] = lseres_("GE", " ", &c__1, &
+ n, &ys[1], &yy[1], &i__7, (
+ ftnlen)2, (ftnlen)1);
+ }
+ isame[9] = incys == incy;
+ } else if (banded) {
+ isame[2] = ks == k;
+ isame[3] = als == alpha;
+ isame[4] = lse_(&as[1], &aa[1], &laa);
+ isame[5] = ldas == lda;
+ isame[6] = lse_(&xs[1], &xx[1], &lx);
+ isame[7] = incxs == incx;
+ isame[8] = bls == beta;
+ if (null) {
+ isame[9] = lse_(&ys[1], &yy[1], &ly);
+ } else {
+ i__7 = abs(incy);
+ isame[9] = lseres_("GE", " ", &c__1, &
+ n, &ys[1], &yy[1], &i__7, (
+ ftnlen)2, (ftnlen)1);
+ }
+ isame[10] = incys == incy;
+ } else if (packed) {
+ isame[2] = als == alpha;
+ isame[3] = lse_(&as[1], &aa[1], &laa);
+ isame[4] = lse_(&xs[1], &xx[1], &lx);
+ isame[5] = incxs == incx;
+ isame[6] = bls == beta;
+ if (null) {
+ isame[7] = lse_(&ys[1], &yy[1], &ly);
+ } else {
+ i__7 = abs(incy);
+ isame[7] = lseres_("GE", " ", &c__1, &
+ n, &ys[1], &yy[1], &i__7, (
+ ftnlen)2, (ftnlen)1);
+ }
+ isame[8] = incys == incy;
+ }
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__7 = nargs;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___195.ciunit = *nout;
+ s_wsfe(&io___195);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+
+/* Check the result. */
+
+ smvch_("N", &n, &n, &alpha, &a[a_offset],
+ nmax, &x[1], &incx, &beta, &y[1],
+ &incy, &yt[1], &g[1], &yy[1], eps,
+ &err, fatal, nout, &c_true, (
+ ftnlen)1);
+ errmax = dmax(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L120;
+ }
+ } else {
+/* Avoid repeating tests with N.le.0 */
+ goto L110;
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+/* L70: */
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+L110:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___197.ciunit = *nout;
+ s_wsfe(&io___197);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___198.ciunit = *nout;
+ s_wsfe(&io___198);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ goto L130;
+
+L120:
+ io___199.ciunit = *nout;
+ s_wsfe(&io___199);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (full) {
+ io___200.ciunit = *nout;
+ s_wsfe(&io___200);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (banded) {
+ io___201.ciunit = *nout;
+ s_wsfe(&io___201);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (packed) {
+ io___202.ciunit = *nout;
+ s_wsfe(&io___202);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L130:
+ return 0;
+
+
+/* End of SCHK2. */
+
+} /* schk2_ */
+
+/* Subroutine */ int schk3_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nkb, integer *kb, integer *
+ ninc, integer *inc, integer *nmax, integer *incmax, real *a, real *aa,
+ real *as, real *x, real *xx, real *xs, real *xt, real *g, real *z__,
+ ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ichu[2] = "UL";
+ static char icht[3] = "NTC";
+ static char ichd[2] = "UN";
+
+ /* Format strings */
+ static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002(\002,3(\002'\002,a1"
+ ",\002',\002),i3,\002, A,\002,i3,\002, X,\002,i2,\002) "
+ " .\002)";
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002(\002,3(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),\002 A,\002,i3,\002, X,\002,i2,\002"
+ ") .\002)";
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002(\002,3(\002'\002,a1"
+ ",\002',\002),i3,\002, AP, \002,\002X,\002,i2,\002) "
+ " .\002)";
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio(
+ integer *, char *, ftnlen), e_wsfe(void), f_rew(alist *);
+
+ /* Local variables */
+ integer i__, k, n, nc, ik, in, nk, ks, ix, ns, lx, laa, icd, lda, ict,
+ icu;
+ extern logical lse_(real *, real *, integer *);
+ real err;
+ char diag[1];
+ integer ldas;
+ logical same;
+ integer incx;
+ logical full, null;
+ char uplo[1], diags[1];
+ logical isame[13];
+ extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *,
+ integer *, logical *, real *, ftnlen, ftnlen, ftnlen);
+ integer nargs;
+ extern /* Subroutine */ int smvch_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *,
+ real *, real *, real *, real *, real *, logical *, integer *,
+ logical *, ftnlen);
+ logical reset;
+ integer incxs;
+ char trans[1];
+ extern /* Subroutine */ int stbmv_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *), stbsv_(char *, char *, char *, integer *, integer *,
+ real *, integer *, real *, integer *);
+ char uplos[1];
+ extern /* Subroutine */ int stpmv_(char *, char *, char *, integer *,
+ real *, real *, integer *), strmv_(char *,
+ char *, char *, integer *, real *, integer *, real *, integer *), stpsv_(char *, char *, char *, integer *,
+ real *, real *, integer *), strsv_(char *
+, char *, char *, integer *, real *, integer *, real *, integer *);
+ logical banded, packed;
+ real errmax;
+ extern logical lseres_(char *, char *, integer *, integer *, real *, real
+ *, integer *, ftnlen, ftnlen);
+ real transl;
+ char transs[1];
+
+ /* Fortran I/O blocks */
+ static cilist io___239 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___240 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___241 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___242 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___243 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___244 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___245 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___248 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___250 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___251 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___252 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___253 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___254 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___255 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests STRMV, STBMV, STPMV, STRSV, STBSV and STPSV. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --kb;
+ --inc;
+ --z__;
+ --g;
+ --xt;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --xs;
+ --xx;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ full = *(unsigned char *)&sname[2] == 'R';
+ banded = *(unsigned char *)&sname[2] == 'B';
+ packed = *(unsigned char *)&sname[2] == 'P';
+/* Define the number of arguments. */
+ if (full) {
+ nargs = 8;
+ } else if (banded) {
+ nargs = 9;
+ } else if (packed) {
+ nargs = 7;
+ }
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.f;
+/* Set up zero vector for SMVCH. */
+ i__1 = *nmax;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ z__[i__] = 0.f;
+/* L10: */
+ }
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+
+ if (banded) {
+ nk = *nkb;
+ } else {
+ nk = 1;
+ }
+ i__2 = nk;
+ for (ik = 1; ik <= i__2; ++ik) {
+ if (banded) {
+ k = kb[ik];
+ } else {
+ k = n - 1;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ if (banded) {
+ lda = k + 1;
+ } else {
+ lda = n;
+ }
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L100;
+ }
+ if (packed) {
+ laa = n * (n + 1) / 2;
+ } else {
+ laa = lda * n;
+ }
+ null = n <= 0;
+
+ for (icu = 1; icu <= 2; ++icu) {
+ *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
+
+ for (ict = 1; ict <= 3; ++ict) {
+ *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]
+ ;
+
+ for (icd = 1; icd <= 2; ++icd) {
+ *(unsigned char *)diag = *(unsigned char *)&ichd[icd
+ - 1];
+
+/* Generate the matrix A. */
+
+ transl = 0.f;
+ smake_(sname + 1, uplo, diag, &n, &n, &a[a_offset],
+ nmax, &aa[1], &lda, &k, &k, &reset, &transl, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ i__3 = *ninc;
+ for (ix = 1; ix <= i__3; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * n;
+
+/* Generate the vector X. */
+
+ transl = .5f;
+ i__4 = abs(incx);
+ i__5 = n - 1;
+ smake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &
+ xx[1], &i__4, &c__0, &i__5, &reset, &
+ transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);
+ if (n > 1) {
+ x[n / 2] = 0.f;
+ xx[abs(incx) * (n / 2 - 1) + 1] = 0.f;
+ }
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ *(unsigned char *)transs = *(unsigned char *)
+ trans;
+ *(unsigned char *)diags = *(unsigned char *)diag;
+ ns = n;
+ ks = k;
+ i__4 = laa;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ as[i__] = aa[i__];
+/* L20: */
+ }
+ ldas = lda;
+ i__4 = lx;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ xs[i__] = xx[i__];
+/* L30: */
+ }
+ incxs = incx;
+
+/* Call the subroutine. */
+
+ if (s_cmp(sname + 3, "MV", (ftnlen)2, (ftnlen)2)
+ == 0) {
+ if (full) {
+ if (*trace) {
+ io___239.ciunit = *ntra;
+ s_wsfe(&io___239);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ strmv_(uplo, trans, diag, &n, &aa[1], &
+ lda, &xx[1], &incx);
+ } else if (banded) {
+ if (*trace) {
+ io___240.ciunit = *ntra;
+ s_wsfe(&io___240);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ stbmv_(uplo, trans, diag, &n, &k, &aa[1],
+ &lda, &xx[1], &incx);
+ } else if (packed) {
+ if (*trace) {
+ io___241.ciunit = *ntra;
+ s_wsfe(&io___241);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ stpmv_(uplo, trans, diag, &n, &aa[1], &xx[
+ 1], &incx);
+ }
+ } else if (s_cmp(sname + 3, "SV", (ftnlen)2, (
+ ftnlen)2) == 0) {
+ if (full) {
+ if (*trace) {
+ io___242.ciunit = *ntra;
+ s_wsfe(&io___242);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ strsv_(uplo, trans, diag, &n, &aa[1], &
+ lda, &xx[1], &incx);
+ } else if (banded) {
+ if (*trace) {
+ io___243.ciunit = *ntra;
+ s_wsfe(&io___243);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ stbsv_(uplo, trans, diag, &n, &k, &aa[1],
+ &lda, &xx[1], &incx);
+ } else if (packed) {
+ if (*trace) {
+ io___244.ciunit = *ntra;
+ s_wsfe(&io___244);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ stpsv_(uplo, trans, diag, &n, &aa[1], &xx[
+ 1], &incx);
+ }
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___245.ciunit = *nout;
+ s_wsfe(&io___245);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplo == *(unsigned
+ char *)uplos;
+ isame[1] = *(unsigned char *)trans == *(unsigned
+ char *)transs;
+ isame[2] = *(unsigned char *)diag == *(unsigned
+ char *)diags;
+ isame[3] = ns == n;
+ if (full) {
+ isame[4] = lse_(&as[1], &aa[1], &laa);
+ isame[5] = ldas == lda;
+ if (null) {
+ isame[6] = lse_(&xs[1], &xx[1], &lx);
+ } else {
+ i__4 = abs(incx);
+ isame[6] = lseres_("GE", " ", &c__1, &n, &
+ xs[1], &xx[1], &i__4, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[7] = incxs == incx;
+ } else if (banded) {
+ isame[4] = ks == k;
+ isame[5] = lse_(&as[1], &aa[1], &laa);
+ isame[6] = ldas == lda;
+ if (null) {
+ isame[7] = lse_(&xs[1], &xx[1], &lx);
+ } else {
+ i__4 = abs(incx);
+ isame[7] = lseres_("GE", " ", &c__1, &n, &
+ xs[1], &xx[1], &i__4, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[8] = incxs == incx;
+ } else if (packed) {
+ isame[4] = lse_(&as[1], &aa[1], &laa);
+ if (null) {
+ isame[5] = lse_(&xs[1], &xx[1], &lx);
+ } else {
+ i__4 = abs(incx);
+ isame[5] = lseres_("GE", " ", &c__1, &n, &
+ xs[1], &xx[1], &i__4, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[6] = incxs == incx;
+ }
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__4 = nargs;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___248.ciunit = *nout;
+ s_wsfe(&io___248);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+ if (s_cmp(sname + 3, "MV", (ftnlen)2, (ftnlen)
+ 2) == 0) {
+
+/* Check the result. */
+
+ smvch_(trans, &n, &n, &c_b121, &a[
+ a_offset], nmax, &x[1], &incx, &
+ c_b133, &z__[1], &incx, &xt[1], &
+ g[1], &xx[1], eps, &err, fatal,
+ nout, &c_true, (ftnlen)1);
+ } else if (s_cmp(sname + 3, "SV", (ftnlen)2, (
+ ftnlen)2) == 0) {
+
+/* Compute approximation to original vector. */
+
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ z__[i__] = xx[(i__ - 1) * abs(incx) +
+ 1];
+ xx[(i__ - 1) * abs(incx) + 1] = x[i__]
+ ;
+/* L50: */
+ }
+ smvch_(trans, &n, &n, &c_b121, &a[
+ a_offset], nmax, &z__[1], &incx, &
+ c_b133, &x[1], &incx, &xt[1], &g[
+ 1], &xx[1], eps, &err, fatal,
+ nout, &c_false, (ftnlen)1);
+ }
+ errmax = dmax(errmax,err);
+/* If got really bad answer, report and return. */
+ if (*fatal) {
+ goto L120;
+ }
+ } else {
+/* Avoid repeating tests with N.le.0. */
+ goto L110;
+ }
+
+/* L60: */
+ }
+
+/* L70: */
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+L110:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___250.ciunit = *nout;
+ s_wsfe(&io___250);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___251.ciunit = *nout;
+ s_wsfe(&io___251);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ goto L130;
+
+L120:
+ io___252.ciunit = *nout;
+ s_wsfe(&io___252);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (full) {
+ io___253.ciunit = *nout;
+ s_wsfe(&io___253);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (banded) {
+ io___254.ciunit = *nout;
+ s_wsfe(&io___254);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (packed) {
+ io___255.ciunit = *nout;
+ s_wsfe(&io___255);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L130:
+ return 0;
+
+
+/* End of SCHK3. */
+
+} /* schk3_ */
+
+/* Subroutine */ int schk4_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nalf, real *alf, integer *
+ ninc, integer *inc, integer *nmax, integer *incmax, real *a, real *aa,
+ real *as, real *x, real *xx, real *xs, real *y, real *yy, real *ys,
+ real *yt, real *g, real *z__, ftnlen sname_len)
+{
+ /* Format strings */
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002(\002,2(i3,\002,\002)"
+ ",f4.1,\002, X,\002,i2,\002, Y,\002,i2,\002, A,\002,i3,\002) "
+ " .\002)";
+ static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, j, m, n;
+ real w[1];
+ integer ia, nc, nd, im, in, ms, ix, iy, ns, lx, ly, laa, lda;
+ real als;
+ extern logical lse_(real *, real *, integer *);
+ real err;
+ integer ldas;
+ logical same;
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ integer incx, incy;
+ logical null;
+ real alpha;
+ logical isame[13];
+ extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *,
+ integer *, logical *, real *, ftnlen, ftnlen, ftnlen);
+ integer nargs;
+ extern /* Subroutine */ int smvch_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *,
+ real *, real *, real *, real *, real *, logical *, integer *,
+ logical *, ftnlen);
+ logical reset;
+ integer incxs, incys;
+ real errmax;
+ extern logical lseres_(char *, char *, integer *, integer *, real *, real
+ *, integer *, ftnlen, ftnlen);
+ real transl;
+
+ /* Fortran I/O blocks */
+ static cilist io___284 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___285 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___288 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___292 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___293 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___294 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___295 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___296 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* Tests SGER. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+/* Define the number of arguments. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --inc;
+ --z__;
+ --g;
+ --yt;
+ --y;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ys;
+ --yy;
+ --xs;
+ --xx;
+
+ /* Function Body */
+ nargs = 9;
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.f;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+ nd = n / 2 + 1;
+
+ for (im = 1; im <= 2; ++im) {
+ if (im == 1) {
+/* Computing MAX */
+ i__2 = n - nd;
+ m = max(i__2,0);
+ }
+ if (im == 2) {
+/* Computing MIN */
+ i__2 = n + nd;
+ m = min(i__2,*nmax);
+ }
+
+/* Set LDA to 1 more than minimum value if room. */
+ lda = m;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L110;
+ }
+ laa = lda * n;
+ null = n <= 0 || m <= 0;
+
+ i__2 = *ninc;
+ for (ix = 1; ix <= i__2; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * m;
+
+/* Generate the vector X. */
+
+ transl = .5f;
+ i__3 = abs(incx);
+ i__4 = m - 1;
+ smake_("GE", " ", " ", &c__1, &m, &x[1], &c__1, &xx[1], &i__3,
+ &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1,
+ (ftnlen)1);
+ if (m > 1) {
+ x[m / 2] = 0.f;
+ xx[abs(incx) * (m / 2 - 1) + 1] = 0.f;
+ }
+
+ i__3 = *ninc;
+ for (iy = 1; iy <= i__3; ++iy) {
+ incy = inc[iy];
+ ly = abs(incy) * n;
+
+/* Generate the vector Y. */
+
+ transl = 0.f;
+ i__4 = abs(incy);
+ i__5 = n - 1;
+ smake_("GE", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], &
+ i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (
+ ftnlen)1, (ftnlen)1);
+ if (n > 1) {
+ y[n / 2] = 0.f;
+ yy[abs(incy) * (n / 2 - 1) + 1] = 0.f;
+ }
+
+ i__4 = *nalf;
+ for (ia = 1; ia <= i__4; ++ia) {
+ alpha = alf[ia];
+
+/* Generate the matrix A. */
+
+ transl = 0.f;
+ i__5 = m - 1;
+ i__6 = n - 1;
+ smake_(sname + 1, " ", " ", &m, &n, &a[a_offset],
+ nmax, &aa[1], &lda, &i__5, &i__6, &reset, &
+ transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ ms = m;
+ ns = n;
+ als = alpha;
+ i__5 = laa;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ as[i__] = aa[i__];
+/* L10: */
+ }
+ ldas = lda;
+ i__5 = lx;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ xs[i__] = xx[i__];
+/* L20: */
+ }
+ incxs = incx;
+ i__5 = ly;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ ys[i__] = yy[i__];
+/* L30: */
+ }
+ incys = incy;
+
+/* Call the subroutine. */
+
+ if (*trace) {
+ io___284.ciunit = *ntra;
+ s_wsfe(&io___284);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real)
+ );
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ sger_(&m, &n, &alpha, &xx[1], &incx, &yy[1], &incy, &
+ aa[1], &lda);
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___285.ciunit = *nout;
+ s_wsfe(&io___285);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L140;
+ }
+
+/* See what data changed inside subroutine. */
+
+ isame[0] = ms == m;
+ isame[1] = ns == n;
+ isame[2] = als == alpha;
+ isame[3] = lse_(&xs[1], &xx[1], &lx);
+ isame[4] = incxs == incx;
+ isame[5] = lse_(&ys[1], &yy[1], &ly);
+ isame[6] = incys == incy;
+ if (null) {
+ isame[7] = lse_(&as[1], &aa[1], &laa);
+ } else {
+ isame[7] = lseres_("GE", " ", &m, &n, &as[1], &aa[
+ 1], &lda, (ftnlen)2, (ftnlen)1);
+ }
+ isame[8] = ldas == lda;
+
+/* If data was incorrectly changed, report and return. */
+
+ same = TRUE_;
+ i__5 = nargs;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___288.ciunit = *nout;
+ s_wsfe(&io___288);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L140;
+ }
+
+ if (! null) {
+
+/* Check the result column by column. */
+
+ if (incx > 0) {
+ i__5 = m;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ z__[i__] = x[i__];
+/* L50: */
+ }
+ } else {
+ i__5 = m;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ z__[i__] = x[m - i__ + 1];
+/* L60: */
+ }
+ }
+ i__5 = n;
+ for (j = 1; j <= i__5; ++j) {
+ if (incy > 0) {
+ w[0] = y[j];
+ } else {
+ w[0] = y[n - j + 1];
+ }
+ smvch_("N", &m, &c__1, &alpha, &z__[1], nmax,
+ w, &c__1, &c_b121, &a[j * a_dim1 + 1],
+ &c__1, &yt[1], &g[1], &aa[(j - 1) *
+ lda + 1], eps, &err, fatal, nout, &
+ c_true, (ftnlen)1);
+ errmax = dmax(errmax,err);
+/* If got really bad answer, report and return. */
+ if (*fatal) {
+ goto L130;
+ }
+/* L70: */
+ }
+ } else {
+/* Avoid repeating tests with M.le.0 or N.le.0. */
+ goto L110;
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+/* L100: */
+ }
+
+L110:
+ ;
+ }
+
+/* L120: */
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___292.ciunit = *nout;
+ s_wsfe(&io___292);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___293.ciunit = *nout;
+ s_wsfe(&io___293);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ goto L150;
+
+L130:
+ io___294.ciunit = *nout;
+ s_wsfe(&io___294);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L140:
+ io___295.ciunit = *nout;
+ s_wsfe(&io___295);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ io___296.ciunit = *nout;
+ s_wsfe(&io___296);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L150:
+ return 0;
+
+
+/* End of SCHK4. */
+
+} /* schk4_ */
+
+/* Subroutine */ int schk5_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nalf, real *alf, integer *
+ ninc, integer *inc, integer *nmax, integer *incmax, real *a, real *aa,
+ real *as, real *x, real *xx, real *xs, real *y, real *yy, real *ys,
+ real *yt, real *g, real *z__, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ich[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,\002,f4.1,\002, X,\002,i2,\002, A,\002,i3,\002) "
+ " .\002)";
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,\002,f4.1,\002, X,\002,i2,\002, AP) "
+ " .\002)";
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, j, n;
+ real w[1];
+ integer ia, ja, ic, nc, jj, lj, in, ix, ns, lx, laa, lda;
+ real als;
+ extern logical lse_(real *, real *, integer *);
+ real err;
+ integer ldas;
+ logical same;
+ integer incx;
+ logical full, null;
+ char uplo[1];
+ extern /* Subroutine */ int sspr_(char *, integer *, real *, real *,
+ integer *, real *), ssyr_(char *, integer *, real *, real
+ *, integer *, real *, integer *);
+ real alpha;
+ logical isame[13];
+ extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *,
+ integer *, logical *, real *, ftnlen, ftnlen, ftnlen);
+ integer nargs;
+ extern /* Subroutine */ int smvch_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *,
+ real *, real *, real *, real *, real *, logical *, integer *,
+ logical *, ftnlen);
+ logical reset;
+ integer incxs;
+ logical upper;
+ char uplos[1];
+ logical packed;
+ real errmax;
+ extern logical lseres_(char *, char *, integer *, integer *, real *, real
+ *, integer *, ftnlen, ftnlen);
+ real transl;
+
+ /* Fortran I/O blocks */
+ static cilist io___324 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___325 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___326 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___329 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___336 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___337 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___338 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___339 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___340 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___341 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* Tests SSYR and SSPR. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --inc;
+ --z__;
+ --g;
+ --yt;
+ --y;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ys;
+ --yy;
+ --xs;
+ --xx;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ full = *(unsigned char *)&sname[2] == 'Y';
+ packed = *(unsigned char *)&sname[2] == 'P';
+/* Define the number of arguments. */
+ if (full) {
+ nargs = 7;
+ } else if (packed) {
+ nargs = 6;
+ }
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.f;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+/* Set LDA to 1 more than minimum value if room. */
+ lda = n;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L100;
+ }
+ if (packed) {
+ laa = n * (n + 1) / 2;
+ } else {
+ laa = lda * n;
+ }
+
+ for (ic = 1; ic <= 2; ++ic) {
+ *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];
+ upper = *(unsigned char *)uplo == 'U';
+
+ i__2 = *ninc;
+ for (ix = 1; ix <= i__2; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * n;
+
+/* Generate the vector X. */
+
+ transl = .5f;
+ i__3 = abs(incx);
+ i__4 = n - 1;
+ smake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3,
+ &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1,
+ (ftnlen)1);
+ if (n > 1) {
+ x[n / 2] = 0.f;
+ xx[abs(incx) * (n / 2 - 1) + 1] = 0.f;
+ }
+
+ i__3 = *nalf;
+ for (ia = 1; ia <= i__3; ++ia) {
+ alpha = alf[ia];
+ null = n <= 0 || alpha == 0.f;
+
+/* Generate the matrix A. */
+
+ transl = 0.f;
+ i__4 = n - 1;
+ i__5 = n - 1;
+ smake_(sname + 1, uplo, " ", &n, &n, &a[a_offset], nmax, &
+ aa[1], &lda, &i__4, &i__5, &reset, &transl, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ ns = n;
+ als = alpha;
+ i__4 = laa;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ as[i__] = aa[i__];
+/* L10: */
+ }
+ ldas = lda;
+ i__4 = lx;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ xs[i__] = xx[i__];
+/* L20: */
+ }
+ incxs = incx;
+
+/* Call the subroutine. */
+
+ if (full) {
+ if (*trace) {
+ io___324.ciunit = *ntra;
+ s_wsfe(&io___324);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real)
+ );
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ssyr_(uplo, &n, &alpha, &xx[1], &incx, &aa[1], &lda);
+ } else if (packed) {
+ if (*trace) {
+ io___325.ciunit = *ntra;
+ s_wsfe(&io___325);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real)
+ );
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ sspr_(uplo, &n, &alpha, &xx[1], &incx, &aa[1]);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___326.ciunit = *nout;
+ s_wsfe(&io___326);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplo == *(unsigned char *)
+ uplos;
+ isame[1] = ns == n;
+ isame[2] = als == alpha;
+ isame[3] = lse_(&xs[1], &xx[1], &lx);
+ isame[4] = incxs == incx;
+ if (null) {
+ isame[5] = lse_(&as[1], &aa[1], &laa);
+ } else {
+ isame[5] = lseres_(sname + 1, uplo, &n, &n, &as[1], &
+ aa[1], &lda, (ftnlen)2, (ftnlen)1);
+ }
+ if (! packed) {
+ isame[6] = ldas == lda;
+ }
+
+/* If data was incorrectly changed, report and return. */
+
+ same = TRUE_;
+ i__4 = nargs;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___329.ciunit = *nout;
+ s_wsfe(&io___329);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+/* L30: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+
+/* Check the result column by column. */
+
+ if (incx > 0) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ z__[i__] = x[i__];
+/* L40: */
+ }
+ } else {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ z__[i__] = x[n - i__ + 1];
+/* L50: */
+ }
+ }
+ ja = 1;
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ w[0] = z__[j];
+ if (upper) {
+ jj = 1;
+ lj = j;
+ } else {
+ jj = j;
+ lj = n - j + 1;
+ }
+ smvch_("N", &lj, &c__1, &alpha, &z__[jj], &lj, w,
+ &c__1, &c_b121, &a[jj + j * a_dim1], &
+ c__1, &yt[1], &g[1], &aa[ja], eps, &err,
+ fatal, nout, &c_true, (ftnlen)1);
+ if (full) {
+ if (upper) {
+ ja += lda;
+ } else {
+ ja = ja + lda + 1;
+ }
+ } else {
+ ja += lj;
+ }
+ errmax = dmax(errmax,err);
+/* If got really bad answer, report and return. */
+ if (*fatal) {
+ goto L110;
+ }
+/* L60: */
+ }
+ } else {
+/* Avoid repeating tests if N.le.0. */
+ if (n <= 0) {
+ goto L100;
+ }
+ }
+
+/* L70: */
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___336.ciunit = *nout;
+ s_wsfe(&io___336);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___337.ciunit = *nout;
+ s_wsfe(&io___337);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ goto L130;
+
+L110:
+ io___338.ciunit = *nout;
+ s_wsfe(&io___338);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L120:
+ io___339.ciunit = *nout;
+ s_wsfe(&io___339);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (full) {
+ io___340.ciunit = *nout;
+ s_wsfe(&io___340);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (packed) {
+ io___341.ciunit = *nout;
+ s_wsfe(&io___341);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L130:
+ return 0;
+
+
+/* End of SCHK5. */
+
+} /* schk5_ */
+
+/* Subroutine */ int schk6_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nalf, real *alf, integer *
+ ninc, integer *inc, integer *nmax, integer *incmax, real *a, real *aa,
+ real *as, real *x, real *xx, real *xs, real *y, real *yy, real *ys,
+ real *yt, real *g, real *z__, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ich[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,\002,f4.1,\002, X,\002,i2,\002, Y,\002,i2,\002, A,\002,i"
+ "3,\002) .\002)";
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,\002,f4.1,\002, X,\002,i2,\002, Y,\002,i2,\002, AP) "
+ " .\002)";
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, j, n;
+ real w[2];
+ integer ia, ja, ic, nc, jj, lj, in, ix, iy, ns, lx, ly, laa, lda;
+ real als;
+ extern logical lse_(real *, real *, integer *);
+ real err;
+ integer ldas;
+ logical same;
+ integer incx, incy;
+ logical full, null;
+ char uplo[1];
+ extern /* Subroutine */ int sspr2_(char *, integer *, real *, real *,
+ integer *, real *, integer *, real *), ssyr2_(char *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ integer *);
+ real alpha;
+ logical isame[13];
+ extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *,
+ integer *, logical *, real *, ftnlen, ftnlen, ftnlen);
+ integer nargs;
+ extern /* Subroutine */ int smvch_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *,
+ real *, real *, real *, real *, real *, logical *, integer *,
+ logical *, ftnlen);
+ logical reset;
+ integer incxs, incys;
+ logical upper;
+ char uplos[1];
+ logical packed;
+ real errmax;
+ extern logical lseres_(char *, char *, integer *, integer *, real *, real
+ *, integer *, ftnlen, ftnlen);
+ real transl;
+
+ /* Fortran I/O blocks */
+ static cilist io___373 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___374 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___375 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___378 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___385 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___386 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___387 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___388 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___389 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___390 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* Tests SSYR2 and SSPR2. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --inc;
+ z_dim1 = *nmax;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --g;
+ --yt;
+ --y;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ys;
+ --yy;
+ --xs;
+ --xx;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ full = *(unsigned char *)&sname[2] == 'Y';
+ packed = *(unsigned char *)&sname[2] == 'P';
+/* Define the number of arguments. */
+ if (full) {
+ nargs = 9;
+ } else if (packed) {
+ nargs = 8;
+ }
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.f;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+/* Set LDA to 1 more than minimum value if room. */
+ lda = n;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L140;
+ }
+ if (packed) {
+ laa = n * (n + 1) / 2;
+ } else {
+ laa = lda * n;
+ }
+
+ for (ic = 1; ic <= 2; ++ic) {
+ *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];
+ upper = *(unsigned char *)uplo == 'U';
+
+ i__2 = *ninc;
+ for (ix = 1; ix <= i__2; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * n;
+
+/* Generate the vector X. */
+
+ transl = .5f;
+ i__3 = abs(incx);
+ i__4 = n - 1;
+ smake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3,
+ &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1,
+ (ftnlen)1);
+ if (n > 1) {
+ x[n / 2] = 0.f;
+ xx[abs(incx) * (n / 2 - 1) + 1] = 0.f;
+ }
+
+ i__3 = *ninc;
+ for (iy = 1; iy <= i__3; ++iy) {
+ incy = inc[iy];
+ ly = abs(incy) * n;
+
+/* Generate the vector Y. */
+
+ transl = 0.f;
+ i__4 = abs(incy);
+ i__5 = n - 1;
+ smake_("GE", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], &
+ i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (
+ ftnlen)1, (ftnlen)1);
+ if (n > 1) {
+ y[n / 2] = 0.f;
+ yy[abs(incy) * (n / 2 - 1) + 1] = 0.f;
+ }
+
+ i__4 = *nalf;
+ for (ia = 1; ia <= i__4; ++ia) {
+ alpha = alf[ia];
+ null = n <= 0 || alpha == 0.f;
+
+/* Generate the matrix A. */
+
+ transl = 0.f;
+ i__5 = n - 1;
+ i__6 = n - 1;
+ smake_(sname + 1, uplo, " ", &n, &n, &a[a_offset],
+ nmax, &aa[1], &lda, &i__5, &i__6, &reset, &
+ transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ ns = n;
+ als = alpha;
+ i__5 = laa;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ as[i__] = aa[i__];
+/* L10: */
+ }
+ ldas = lda;
+ i__5 = lx;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ xs[i__] = xx[i__];
+/* L20: */
+ }
+ incxs = incx;
+ i__5 = ly;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ ys[i__] = yy[i__];
+/* L30: */
+ }
+ incys = incy;
+
+/* Call the subroutine. */
+
+ if (full) {
+ if (*trace) {
+ io___373.ciunit = *ntra;
+ s_wsfe(&io___373);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(
+ real));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ssyr2_(uplo, &n, &alpha, &xx[1], &incx, &yy[1], &
+ incy, &aa[1], &lda);
+ } else if (packed) {
+ if (*trace) {
+ io___374.ciunit = *ntra;
+ s_wsfe(&io___374);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(
+ real));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ sspr2_(uplo, &n, &alpha, &xx[1], &incx, &yy[1], &
+ incy, &aa[1]);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___375.ciunit = *nout;
+ s_wsfe(&io___375);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L160;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplo == *(unsigned char *
+ )uplos;
+ isame[1] = ns == n;
+ isame[2] = als == alpha;
+ isame[3] = lse_(&xs[1], &xx[1], &lx);
+ isame[4] = incxs == incx;
+ isame[5] = lse_(&ys[1], &yy[1], &ly);
+ isame[6] = incys == incy;
+ if (null) {
+ isame[7] = lse_(&as[1], &aa[1], &laa);
+ } else {
+ isame[7] = lseres_(sname + 1, uplo, &n, &n, &as[1]
+ , &aa[1], &lda, (ftnlen)2, (ftnlen)1);
+ }
+ if (! packed) {
+ isame[8] = ldas == lda;
+ }
+
+/* If data was incorrectly changed, report and return. */
+
+ same = TRUE_;
+ i__5 = nargs;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___378.ciunit = *nout;
+ s_wsfe(&io___378);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L160;
+ }
+
+ if (! null) {
+
+/* Check the result column by column. */
+
+ if (incx > 0) {
+ i__5 = n;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ z__[i__ + z_dim1] = x[i__];
+/* L50: */
+ }
+ } else {
+ i__5 = n;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ z__[i__ + z_dim1] = x[n - i__ + 1];
+/* L60: */
+ }
+ }
+ if (incy > 0) {
+ i__5 = n;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ z__[i__ + (z_dim1 << 1)] = y[i__];
+/* L70: */
+ }
+ } else {
+ i__5 = n;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ z__[i__ + (z_dim1 << 1)] = y[n - i__ + 1];
+/* L80: */
+ }
+ }
+ ja = 1;
+ i__5 = n;
+ for (j = 1; j <= i__5; ++j) {
+ w[0] = z__[j + (z_dim1 << 1)];
+ w[1] = z__[j + z_dim1];
+ if (upper) {
+ jj = 1;
+ lj = j;
+ } else {
+ jj = j;
+ lj = n - j + 1;
+ }
+ smvch_("N", &lj, &c__2, &alpha, &z__[jj +
+ z_dim1], nmax, w, &c__1, &c_b121, &a[
+ jj + j * a_dim1], &c__1, &yt[1], &g[1]
+ , &aa[ja], eps, &err, fatal, nout, &
+ c_true, (ftnlen)1);
+ if (full) {
+ if (upper) {
+ ja += lda;
+ } else {
+ ja = ja + lda + 1;
+ }
+ } else {
+ ja += lj;
+ }
+ errmax = dmax(errmax,err);
+/* If got really bad answer, report and return. */
+ if (*fatal) {
+ goto L150;
+ }
+/* L90: */
+ }
+ } else {
+/* Avoid repeating tests with N.le.0. */
+ if (n <= 0) {
+ goto L140;
+ }
+ }
+
+/* L100: */
+ }
+
+/* L110: */
+ }
+
+/* L120: */
+ }
+
+/* L130: */
+ }
+
+L140:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___385.ciunit = *nout;
+ s_wsfe(&io___385);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___386.ciunit = *nout;
+ s_wsfe(&io___386);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ goto L170;
+
+L150:
+ io___387.ciunit = *nout;
+ s_wsfe(&io___387);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L160:
+ io___388.ciunit = *nout;
+ s_wsfe(&io___388);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (full) {
+ io___389.ciunit = *nout;
+ s_wsfe(&io___389);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (packed) {
+ io___390.ciunit = *nout;
+ s_wsfe(&io___390);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L170:
+ return 0;
+
+
+/* End of SCHK6. */
+
+} /* schk6_ */
+
+/* Subroutine */ int schke_(integer *isnum, char *srnamt, integer *nout,
+ ftnlen srnamt_len)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE TESTS OF ERROR-E"
+ "XITS\002)";
+ static char fmt_9998[] = "(\002 ******* \002,a6,\002 FAILED THE TESTS OF"
+ " ERROR-EXITS *****\002,\002**\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ real a[1] /* was [1][1] */, x[1], y[1], beta;
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *), sspr_(char *,
+ integer *, real *, real *, integer *, real *), ssyr_(char
+ *, integer *, real *, real *, integer *, real *, integer *), sspr2_(char *, integer *, real *, real *, integer *,
+ real *, integer *, real *), ssyr2_(char *, integer *,
+ real *, real *, integer *, real *, integer *, real *, integer *);
+ real alpha;
+ extern /* Subroutine */ int sgbmv_(char *, integer *, integer *, integer *
+, integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *), sgemv_(char *, integer *, integer *,
+ real *, real *, integer *, real *, integer *, real *, real *,
+ integer *), ssbmv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *), stbmv_(char *, char *, char *, integer *, integer *,
+ real *, integer *, real *, integer *),
+ stbsv_(char *, char *, char *, integer *, integer *, real *,
+ integer *, real *, integer *), sspmv_(
+ char *, integer *, real *, real *, real *, integer *, real *,
+ real *, integer *), stpmv_(char *, char *, char *,
+ integer *, real *, real *, integer *),
+ strmv_(char *, char *, char *, integer *, real *, integer *, real
+ *, integer *), stpsv_(char *, char *,
+ char *, integer *, real *, real *, integer *), ssymv_(char *, integer *, real *, real *, integer *,
+ real *, integer *, real *, real *, integer *), strsv_(
+ char *, char *, char *, integer *, real *, integer *, real *,
+ integer *), chkxer_(char *, integer *,
+ integer *, logical *, logical *);
+
+ /* Fortran I/O blocks */
+ static cilist io___396 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___397 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* Tests the error exits from the Level 2 Blas. */
+/* Requires a special version of the error-handling routine XERBLA. */
+/* ALPHA, BETA, A, X and Y should not need to be defined. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Subroutines .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+/* OK is set to .FALSE. by the special version of XERBLA or by CHKXER */
+/* if anything is wrong. */
+ infoc_1.ok = TRUE_;
+/* LERR is set to .TRUE. by the special version of XERBLA each time */
+/* it is called, and is then tested and re-set by CHKXER. */
+ infoc_1.lerr = FALSE_;
+ switch (*isnum) {
+ case 1: goto L10;
+ case 2: goto L20;
+ case 3: goto L30;
+ case 4: goto L40;
+ case 5: goto L50;
+ case 6: goto L60;
+ case 7: goto L70;
+ case 8: goto L80;
+ case 9: goto L90;
+ case 10: goto L100;
+ case 11: goto L110;
+ case 12: goto L120;
+ case 13: goto L130;
+ case 14: goto L140;
+ case 15: goto L150;
+ case 16: goto L160;
+ }
+L10:
+ infoc_1.infot = 1;
+ sgemv_("/", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ sgemv_("N", &c_n1, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ sgemv_("N", &c__0, &c_n1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ sgemv_("N", &c__2, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ sgemv_("N", &c__0, &c__0, &alpha, a, &c__1, x, &c__0, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ sgemv_("N", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L20:
+ infoc_1.infot = 1;
+ sgbmv_("/", &c__0, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ sgbmv_("N", &c_n1, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ sgbmv_("N", &c__0, &c_n1, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ sgbmv_("N", &c__0, &c__0, &c_n1, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ sgbmv_("N", &c__2, &c__0, &c__0, &c_n1, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ sgbmv_("N", &c__0, &c__0, &c__1, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ sgbmv_("N", &c__0, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__0, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ sgbmv_("N", &c__0, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L30:
+ infoc_1.infot = 1;
+ ssymv_("/", &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ ssymv_("U", &c_n1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ssymv_("U", &c__2, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ ssymv_("U", &c__0, &alpha, a, &c__1, x, &c__0, &beta, y, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ ssymv_("U", &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__0)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L40:
+ infoc_1.infot = 1;
+ ssbmv_("/", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ ssbmv_("U", &c_n1, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ssbmv_("U", &c__0, &c_n1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ssbmv_("U", &c__0, &c__1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ ssbmv_("U", &c__0, &c__0, &alpha, a, &c__1, x, &c__0, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ssbmv_("U", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L50:
+ infoc_1.infot = 1;
+ sspmv_("/", &c__0, &alpha, a, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ sspmv_("U", &c_n1, &alpha, a, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ sspmv_("U", &c__0, &alpha, a, x, &c__0, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ sspmv_("U", &c__0, &alpha, a, x, &c__1, &beta, y, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L60:
+ infoc_1.infot = 1;
+ strmv_("/", "N", "N", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ strmv_("U", "/", "N", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ strmv_("U", "N", "/", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ strmv_("U", "N", "N", &c_n1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ strmv_("U", "N", "N", &c__2, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ strmv_("U", "N", "N", &c__0, a, &c__1, x, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L70:
+ infoc_1.infot = 1;
+ stbmv_("/", "N", "N", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ stbmv_("U", "/", "N", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ stbmv_("U", "N", "/", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ stbmv_("U", "N", "N", &c_n1, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ stbmv_("U", "N", "N", &c__0, &c_n1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ stbmv_("U", "N", "N", &c__0, &c__1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ stbmv_("U", "N", "N", &c__0, &c__0, a, &c__1, x, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L80:
+ infoc_1.infot = 1;
+ stpmv_("/", "N", "N", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ stpmv_("U", "/", "N", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ stpmv_("U", "N", "/", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ stpmv_("U", "N", "N", &c_n1, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ stpmv_("U", "N", "N", &c__0, a, x, &c__0)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L90:
+ infoc_1.infot = 1;
+ strsv_("/", "N", "N", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ strsv_("U", "/", "N", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ strsv_("U", "N", "/", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ strsv_("U", "N", "N", &c_n1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ strsv_("U", "N", "N", &c__2, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ strsv_("U", "N", "N", &c__0, a, &c__1, x, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L100:
+ infoc_1.infot = 1;
+ stbsv_("/", "N", "N", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ stbsv_("U", "/", "N", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ stbsv_("U", "N", "/", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ stbsv_("U", "N", "N", &c_n1, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ stbsv_("U", "N", "N", &c__0, &c_n1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ stbsv_("U", "N", "N", &c__0, &c__1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ stbsv_("U", "N", "N", &c__0, &c__0, a, &c__1, x, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L110:
+ infoc_1.infot = 1;
+ stpsv_("/", "N", "N", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ stpsv_("U", "/", "N", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ stpsv_("U", "N", "/", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ stpsv_("U", "N", "N", &c_n1, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ stpsv_("U", "N", "N", &c__0, a, x, &c__0)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L120:
+ infoc_1.infot = 1;
+ sger_(&c_n1, &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ sger_(&c__0, &c_n1, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ sger_(&c__0, &c__0, &alpha, x, &c__0, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ sger_(&c__0, &c__0, &alpha, x, &c__1, y, &c__0, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ sger_(&c__2, &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L130:
+ infoc_1.infot = 1;
+ ssyr_("/", &c__0, &alpha, x, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ ssyr_("U", &c_n1, &alpha, x, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ssyr_("U", &c__0, &alpha, x, &c__0, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ ssyr_("U", &c__2, &alpha, x, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L140:
+ infoc_1.infot = 1;
+ sspr_("/", &c__0, &alpha, x, &c__1, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ sspr_("U", &c_n1, &alpha, x, &c__1, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ sspr_("U", &c__0, &alpha, x, &c__0, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L150:
+ infoc_1.infot = 1;
+ ssyr2_("/", &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ ssyr2_("U", &c_n1, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ssyr2_("U", &c__0, &alpha, x, &c__0, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ ssyr2_("U", &c__0, &alpha, x, &c__1, y, &c__0, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ssyr2_("U", &c__2, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L170;
+L160:
+ infoc_1.infot = 1;
+ sspr2_("/", &c__0, &alpha, x, &c__1, y, &c__1, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ sspr2_("U", &c_n1, &alpha, x, &c__1, y, &c__1, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ sspr2_("U", &c__0, &alpha, x, &c__0, y, &c__1, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ sspr2_("U", &c__0, &alpha, x, &c__1, y, &c__0, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+
+L170:
+ if (infoc_1.ok) {
+ io___396.ciunit = *nout;
+ s_wsfe(&io___396);
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ } else {
+ io___397.ciunit = *nout;
+ s_wsfe(&io___397);
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ }
+ return 0;
+
+
+/* End of SCHKE. */
+
+} /* schke_ */
+
+/* Subroutine */ int smake_(char *type__, char *uplo, char *diag, integer *m,
+ integer *n, real *a, integer *nmax, real *aa, integer *lda, integer *
+ kl, integer *ku, logical *reset, real *transl, ftnlen type_len,
+ ftnlen uplo_len, ftnlen diag_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer i__, j, i1, i2, i3, kk;
+ logical gen, tri, sym;
+ integer ibeg, iend;
+ extern doublereal sbeg_(logical *);
+ integer ioff;
+ logical unit, lower, upper;
+
+
+/* Generates values for an M by N matrix A within the bandwidth */
+/* defined by KL and KU. */
+/* Stores the values in the array AA in the data structure required */
+/* by the routine, with unwanted elements set to rogue value. */
+
+/* TYPE is 'GE', 'GB', 'SY', 'SB', 'SP', 'TR', 'TB' OR 'TP'. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. External Functions .. */
+/* .. Intrinsic Functions .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --aa;
+
+ /* Function Body */
+ gen = *(unsigned char *)type__ == 'G';
+ sym = *(unsigned char *)type__ == 'S';
+ tri = *(unsigned char *)type__ == 'T';
+ upper = (sym || tri) && *(unsigned char *)uplo == 'U';
+ lower = (sym || tri) && *(unsigned char *)uplo == 'L';
+ unit = tri && *(unsigned char *)diag == 'U';
+
+/* Generate data in array A. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (gen || upper && i__ <= j || lower && i__ >= j) {
+ if (i__ <= j && j - i__ <= *ku || i__ >= j && i__ - j <= *kl)
+ {
+ a[i__ + j * a_dim1] = sbeg_(reset) + *transl;
+ } else {
+ a[i__ + j * a_dim1] = 0.f;
+ }
+ if (i__ != j) {
+ if (sym) {
+ a[j + i__ * a_dim1] = a[i__ + j * a_dim1];
+ } else if (tri) {
+ a[j + i__ * a_dim1] = 0.f;
+ }
+ }
+ }
+/* L10: */
+ }
+ if (tri) {
+ a[j + j * a_dim1] += 1.f;
+ }
+ if (unit) {
+ a[j + j * a_dim1] = 1.f;
+ }
+/* L20: */
+ }
+
+/* Store elements in array AS in data structure required by routine. */
+
+ if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1];
+/* L30: */
+ }
+ i__2 = *lda;
+ for (i__ = *m + 1; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = -1e10f;
+/* L40: */
+ }
+/* L50: */
+ }
+ } else if (s_cmp(type__, "GB", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *ku + 1 - j;
+ for (i1 = 1; i1 <= i__2; ++i1) {
+ aa[i1 + (j - 1) * *lda] = -1e10f;
+/* L60: */
+ }
+/* Computing MIN */
+ i__3 = *kl + *ku + 1, i__4 = *ku + 1 + *m - j;
+ i__2 = min(i__3,i__4);
+ for (i2 = i1; i2 <= i__2; ++i2) {
+ aa[i2 + (j - 1) * *lda] = a[i2 + j - *ku - 1 + j * a_dim1];
+/* L70: */
+ }
+ i__2 = *lda;
+ for (i3 = i2; i3 <= i__2; ++i3) {
+ aa[i3 + (j - 1) * *lda] = -1e10f;
+/* L80: */
+ }
+/* L90: */
+ }
+ } else if (s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
+ "TR", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ ibeg = 1;
+ if (unit) {
+ iend = j - 1;
+ } else {
+ iend = j;
+ }
+ } else {
+ if (unit) {
+ ibeg = j + 1;
+ } else {
+ ibeg = j;
+ }
+ iend = *n;
+ }
+ i__2 = ibeg - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = -1e10f;
+/* L100: */
+ }
+ i__2 = iend;
+ for (i__ = ibeg; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1];
+/* L110: */
+ }
+ i__2 = *lda;
+ for (i__ = iend + 1; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = -1e10f;
+/* L120: */
+ }
+/* L130: */
+ }
+ } else if (s_cmp(type__, "SB", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
+ "TB", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ kk = *kl + 1;
+/* Computing MAX */
+ i__2 = 1, i__3 = *kl + 2 - j;
+ ibeg = max(i__2,i__3);
+ if (unit) {
+ iend = *kl;
+ } else {
+ iend = *kl + 1;
+ }
+ } else {
+ kk = 1;
+ if (unit) {
+ ibeg = 2;
+ } else {
+ ibeg = 1;
+ }
+/* Computing MIN */
+ i__2 = *kl + 1, i__3 = *m + 1 - j;
+ iend = min(i__2,i__3);
+ }
+ i__2 = ibeg - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = -1e10f;
+/* L140: */
+ }
+ i__2 = iend;
+ for (i__ = ibeg; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = a[i__ + j - kk + j * a_dim1];
+/* L150: */
+ }
+ i__2 = *lda;
+ for (i__ = iend + 1; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = -1e10f;
+/* L160: */
+ }
+/* L170: */
+ }
+ } else if (s_cmp(type__, "SP", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
+ "TP", (ftnlen)2, (ftnlen)2) == 0) {
+ ioff = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ ibeg = 1;
+ iend = j;
+ } else {
+ ibeg = j;
+ iend = *n;
+ }
+ i__2 = iend;
+ for (i__ = ibeg; i__ <= i__2; ++i__) {
+ ++ioff;
+ aa[ioff] = a[i__ + j * a_dim1];
+ if (i__ == j) {
+ if (unit) {
+ aa[ioff] = -1e10f;
+ }
+ }
+/* L180: */
+ }
+/* L190: */
+ }
+ }
+ return 0;
+
+/* End of SMAKE. */
+
+} /* smake_ */
+
+/* Subroutine */ int smvch_(char *trans, integer *m, integer *n, real *alpha,
+ real *a, integer *nmax, real *x, integer *incx, real *beta, real *y,
+ integer *incy, real *yt, real *g, real *yy, real *eps, real *err,
+ logical *fatal, integer *nout, logical *mv, ftnlen trans_len)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
+ " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 EX"
+ "PECTED RESULT COMPU\002,\002TED RESULT\002)";
+ static char fmt_9998[] = "(1x,i7,2g18.6)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, ml, nl, iy, jx, kx, ky;
+ real erri;
+ logical tran;
+ integer incxl, incyl;
+
+ /* Fortran I/O blocks */
+ static cilist io___425 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___426 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___427 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* Checks the results of the computational tests. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Intrinsic Functions .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+ --yt;
+ --g;
+ --yy;
+
+ /* Function Body */
+ tran = *(unsigned char *)trans == 'T' || *(unsigned char *)trans == 'C';
+ if (tran) {
+ ml = *n;
+ nl = *m;
+ } else {
+ ml = *m;
+ nl = *n;
+ }
+ if (*incx < 0) {
+ kx = nl;
+ incxl = -1;
+ } else {
+ kx = 1;
+ incxl = 1;
+ }
+ if (*incy < 0) {
+ ky = ml;
+ incyl = -1;
+ } else {
+ ky = 1;
+ incyl = 1;
+ }
+
+/* Compute expected result in YT using data in A, X and Y. */
+/* Compute gauges in G. */
+
+ iy = ky;
+ i__1 = ml;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ yt[iy] = 0.f;
+ g[iy] = 0.f;
+ jx = kx;
+ if (tran) {
+ i__2 = nl;
+ for (j = 1; j <= i__2; ++j) {
+ yt[iy] += a[j + i__ * a_dim1] * x[jx];
+ g[iy] += (r__1 = a[j + i__ * a_dim1] * x[jx], dabs(r__1));
+ jx += incxl;
+/* L10: */
+ }
+ } else {
+ i__2 = nl;
+ for (j = 1; j <= i__2; ++j) {
+ yt[iy] += a[i__ + j * a_dim1] * x[jx];
+ g[iy] += (r__1 = a[i__ + j * a_dim1] * x[jx], dabs(r__1));
+ jx += incxl;
+/* L20: */
+ }
+ }
+ yt[iy] = *alpha * yt[iy] + *beta * y[iy];
+ g[iy] = dabs(*alpha) * g[iy] + (r__1 = *beta * y[iy], dabs(r__1));
+ iy += incyl;
+/* L30: */
+ }
+
+/* Compute the error ratio for this result. */
+
+ *err = 0.f;
+ i__1 = ml;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ erri = (r__1 = yt[i__] - yy[(i__ - 1) * abs(*incy) + 1], dabs(r__1)) /
+ *eps;
+ if (g[i__] != 0.f) {
+ erri /= g[i__];
+ }
+ *err = dmax(*err,erri);
+ if (*err * sqrt(*eps) >= 1.f) {
+ goto L50;
+ }
+/* L40: */
+ }
+/* If the loop completes, all results are at least half accurate. */
+ goto L70;
+
+/* Report fatal error. */
+
+L50:
+ *fatal = TRUE_;
+ io___425.ciunit = *nout;
+ s_wsfe(&io___425);
+ e_wsfe();
+ i__1 = ml;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*mv) {
+ io___426.ciunit = *nout;
+ s_wsfe(&io___426);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&yt[i__], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&yy[(i__ - 1) * abs(*incy) + 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___427.ciunit = *nout;
+ s_wsfe(&io___427);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&yy[(i__ - 1) * abs(*incy) + 1], (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&yt[i__], (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+/* L60: */
+ }
+
+L70:
+ return 0;
+
+
+/* End of SMVCH. */
+
+} /* smvch_ */
+
+logical lse_(real *ri, real *rj, integer *lr)
+{
+ /* System generated locals */
+ integer i__1;
+ logical ret_val;
+
+ /* Local variables */
+ integer i__;
+
+
+/* Tests if two arrays are identical. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ --rj;
+ --ri;
+
+ /* Function Body */
+ i__1 = *lr;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (ri[i__] != rj[i__]) {
+ goto L20;
+ }
+/* L10: */
+ }
+ ret_val = TRUE_;
+ goto L30;
+L20:
+ ret_val = FALSE_;
+L30:
+ return ret_val;
+
+/* End of LSE. */
+
+} /* lse_ */
+
+logical lseres_(char *type__, char *uplo, integer *m, integer *n, real *aa,
+ real *as, integer *lda, ftnlen type_len, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2;
+ logical ret_val;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer i__, j, ibeg, iend;
+ logical upper;
+
+
+/* Tests if selected elements in two arrays are equal. */
+
+/* TYPE is 'GE', 'SY' or 'SP'. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ as_dim1 = *lda;
+ as_offset = 1 + as_dim1;
+ as -= as_offset;
+ aa_dim1 = *lda;
+ aa_offset = 1 + aa_dim1;
+ aa -= aa_offset;
+
+ /* Function Body */
+ upper = *(unsigned char *)uplo == 'U';
+ if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *lda;
+ for (i__ = *m + 1; i__ <= i__2; ++i__) {
+ if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) {
+ goto L70;
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ ibeg = 1;
+ iend = j;
+ } else {
+ ibeg = j;
+ iend = *n;
+ }
+ i__2 = ibeg - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) {
+ goto L70;
+ }
+/* L30: */
+ }
+ i__2 = *lda;
+ for (i__ = iend + 1; i__ <= i__2; ++i__) {
+ if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) {
+ goto L70;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+/* L60: */
+ ret_val = TRUE_;
+ goto L80;
+L70:
+ ret_val = FALSE_;
+L80:
+ return ret_val;
+
+/* End of LSERES. */
+
+} /* lseres_ */
+
+doublereal sbeg_(logical *reset)
+{
+ /* System generated locals */
+ real ret_val;
+
+ /* Local variables */
+ static integer i__, ic, mi;
+
+
+/* Generates random numbers uniformly distributed between -0.5 and 0.5. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Local Scalars .. */
+/* .. Save statement .. */
+/* .. Intrinsic Functions .. */
+/* .. Executable Statements .. */
+ if (*reset) {
+/* Initialize local variables. */
+ mi = 891;
+ i__ = 7;
+ ic = 0;
+ *reset = FALSE_;
+ }
+
+/* The sequence of values of I is bounded between 1 and 999. */
+/* If initial I = 1,2,3,6,7 or 9, the period will be 50. */
+/* If initial I = 4 or 8, the period will be 25. */
+/* If initial I = 5, the period will be 10. */
+/* IC is used to break up the period by skipping 1 value of I in 6. */
+
+ ++ic;
+L10:
+ i__ *= mi;
+ i__ -= i__ / 1000 * 1000;
+ if (ic >= 5) {
+ ic = 0;
+ goto L10;
+ }
+ ret_val = (real) (i__ - 500) / 1001.f;
+ return ret_val;
+
+/* End of SBEG. */
+
+} /* sbeg_ */
+
+doublereal sdiff_(real *x, real *y)
+{
+ /* System generated locals */
+ real ret_val;
+
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+
+/* .. Scalar Arguments .. */
+/* .. Executable Statements .. */
+ ret_val = *x - *y;
+ return ret_val;
+
+/* End of SDIFF. */
+
+} /* sdiff_ */
+
+/* Subroutine */ int chkxer_(char *srnamt, integer *infot, integer *nout,
+ logical *lerr, logical *ok)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ***** ILLEGAL VALUE OF PARAMETER NUMBER"
+ " \002,i2,\002 NOT D\002,\002ETECTED BY \002,a6,\002 *****\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___437 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* Tests whether XERBLA has detected an error when it should. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Executable Statements .. */
+ if (! (*lerr)) {
+ io___437.ciunit = *nout;
+ s_wsfe(&io___437);
+ do_fio(&c__1, (char *)&(*infot), (ftnlen)sizeof(integer));
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ *ok = FALSE_;
+ }
+ *lerr = FALSE_;
+ return 0;
+
+
+/* End of CHKXER. */
+
+} /* chkxer_ */
+
+/* Subroutine */ int xerbla_(char *srname, integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* XERBLA WAS CALLED WITH INFO ="
+ " \002,i6,\002 INSTEAD\002,\002 OF \002,i2,\002 *******\002)";
+ static char fmt_9997[] = "(\002 ******* XERBLA WAS CALLED WITH INFO ="
+ " \002,i6,\002 *******\002)";
+ static char fmt_9998[] = "(\002 ******* XERBLA WAS CALLED WITH SRNAME ="
+ " \002,a6,\002 INSTE\002,\002AD OF \002,a6,\002 *******\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Fortran I/O blocks */
+ static cilist io___438 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___439 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___440 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* This is a special version of XERBLA to be used only as part of */
+/* the test program for testing error exits from the Level 2 BLAS */
+/* routines. */
+
+/* XERBLA is an error handler for the Level 2 BLAS routines. */
+
+/* It is called by the Level 2 BLAS routines if an input parameter is */
+/* invalid. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+ infoc_2.lerr = TRUE_;
+ if (*info != infoc_2.infot) {
+ if (infoc_2.infot != 0) {
+ io___438.ciunit = infoc_2.nout;
+ s_wsfe(&io___438);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&infoc_2.infot, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___439.ciunit = infoc_2.nout;
+ s_wsfe(&io___439);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ infoc_2.ok = FALSE_;
+ }
+ if (s_cmp(srname, srnamc_1.srnamt, (ftnlen)6, (ftnlen)6) != 0) {
+ io___440.ciunit = infoc_2.nout;
+ s_wsfe(&io___440);
+ do_fio(&c__1, srname, (ftnlen)6);
+ do_fio(&c__1, srnamc_1.srnamt, (ftnlen)6);
+ e_wsfe();
+ infoc_2.ok = FALSE_;
+ }
+ return 0;
+
+
+/* End of XERBLA */
+
+} /* xerbla_ */
+
+/* Main program alias */ int sblat2_ () { MAIN__ (); return 0; }
diff --git a/BLAS/TESTING/sblat3.c b/BLAS/TESTING/sblat3.c
new file mode 100644
index 0000000..bce6460
--- /dev/null
+++ b/BLAS/TESTING/sblat3.c
@@ -0,0 +1,4324 @@
+/* sblat3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+union {
+ struct {
+ integer infot, noutc;
+ logical ok, lerr;
+ } _1;
+ struct {
+ integer infot, nout;
+ logical ok, lerr;
+ } _2;
+} infoc_;
+
+#define infoc_1 (infoc_._1)
+#define infoc_2 (infoc_._2)
+
+struct {
+ char srnamt[6];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__9 = 9;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__8 = 8;
+static integer c__4 = 4;
+static integer c__65 = 65;
+static integer c__7 = 7;
+static real c_b85 = 1.f;
+static real c_b99 = 0.f;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Initialized data */
+
+ static char snames[6*6] = "SGEMM " "SSYMM " "STRMM " "STRSM " "SSYRK "
+ "SSYR2K";
+
+ /* Format strings */
+ static char fmt_9997[] = "(\002 NUMBER OF VALUES OF \002,a,\002 IS LESS "
+ "THAN 1 OR GREATER \002,\002THAN \002,i2)";
+ static char fmt_9996[] = "(\002 VALUE OF N IS LESS THAN 0 OR GREATER THA"
+ "N \002,i2)";
+ static char fmt_9995[] = "(\002 TESTS OF THE REAL LEVEL 3 BL"
+ "AS\002,//\002 THE F\002,\002OLLOWING PARAMETER VALUES WILL BE US"
+ "ED:\002)";
+ static char fmt_9994[] = "(\002 FOR N \002,9i6)";
+ static char fmt_9993[] = "(\002 FOR ALPHA \002,7f6.1)";
+ static char fmt_9992[] = "(\002 FOR BETA \002,7f6.1)";
+ static char fmt_9984[] = "(\002 ERROR-EXITS WILL NOT BE TESTED\002)";
+ static char fmt_9999[] = "(\002 ROUTINES PASS COMPUTATIONAL TESTS IF TES"
+ "T RATIO IS LES\002,\002S THAN\002,f8.2)";
+ static char fmt_9988[] = "(a6,l2)";
+ static char fmt_9990[] = "(\002 SUBPROGRAM NAME \002,a6,\002 NOT RECOGNI"
+ "ZED\002,/\002 ******* T\002,\002ESTS ABANDONED *******\002)";
+ static char fmt_9998[] = "(\002 RELATIVE MACHINE PRECISION IS TAKEN TO"
+ " BE\002,1p,e9.1)";
+ static char fmt_9989[] = "(\002 ERROR IN SMMCH - IN-LINE DOT PRODUCTS A"
+ "RE BEING EVALU\002,\002ATED WRONGLY.\002,/\002 SMMCH WAS CALLED "
+ "WITH TRANSA = \002,a1,\002 AND TRANSB = \002,a1,/\002 AND RETURN"
+ "ED SAME = \002,l1,\002 AND \002,\002ERR = \002,f12.3,\002.\002,"
+ "/\002 THIS MAY BE DUE TO FAULTS IN THE \002,\002ARITHMETIC OR TH"
+ "E COMPILER.\002,/\002 ******* TESTS ABANDONED \002,\002******"
+ "*\002)";
+ static char fmt_9987[] = "(1x,a6,\002 WAS NOT TESTED\002)";
+ static char fmt_9986[] = "(/\002 END OF TESTS\002)";
+ static char fmt_9985[] = "(/\002 ******* FATAL ERROR - TESTS ABANDONED *"
+ "******\002)";
+ static char fmt_9991[] = "(\002 AMEND DATA FILE OR INCREASE ARRAY SIZES "
+ "IN PROGRAM\002,/\002 ******* TESTS ABANDONED *******\002)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real r__1;
+ olist o__1;
+ cllist cl__1;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void), f_open(olist *), s_wsfe(cilist *), do_fio(integer *,
+ char *, ftnlen), e_wsfe(void), s_wsle(cilist *), e_wsle(void),
+ s_rsfe(cilist *), e_rsfe(void), s_cmp(char *, char *, ftnlen,
+ ftnlen);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+ integer f_clos(cllist *);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real c__[4225] /* was [65][65] */, g[65];
+ integer i__, j, n;
+ real w[130], aa[4225], ab[8450] /* was [65][130] */, bb[4225], cc[
+ 4225], as[4225], bs[4225], cs[4225], ct[65], alf[7], bet[7];
+ extern logical lse_(real *, real *, integer *);
+ real eps, err;
+ integer nalf, idim[9];
+ logical same;
+ integer nbet, ntra;
+ logical rewi;
+ integer nout;
+ extern /* Subroutine */ int schk1_(char *, real *, real *, integer *,
+ integer *, logical *, logical *, logical *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, real *,
+ real *, real *, real *, real *, real *, real *, real *, real *,
+ real *, ftnlen), schk2_(char *, real *, real *, integer *,
+ integer *, logical *, logical *, logical *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, real *,
+ real *, real *, real *, real *, real *, real *, real *, real *,
+ real *, ftnlen), schk3_(char *, real *, real *, integer *,
+ integer *, logical *, logical *, logical *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ real *, real *, real *, real *, real *, ftnlen), schk4_(char *,
+ real *, real *, integer *, integer *, logical *, logical *,
+ logical *, integer *, integer *, integer *, real *, integer *,
+ real *, integer *, real *, real *, real *, real *, real *, real *,
+ real *, real *, real *, real *, real *, ftnlen), schk5_(char *,
+ real *, real *, integer *, integer *, logical *, logical *,
+ logical *, integer *, integer *, integer *, real *, integer *,
+ real *, integer *, real *, real *, real *, real *, real *, real *,
+ real *, real *, real *, real *, real *, ftnlen);
+ logical fatal;
+ extern doublereal sdiff_(real *, real *);
+ extern /* Subroutine */ int schke_(integer *, char *, integer *, ftnlen);
+ logical trace;
+ integer nidim;
+ extern /* Subroutine */ int smmch_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *, real *, real *, real *, integer *, real *,
+ real *, logical *, integer *, logical *, ftnlen, ftnlen);
+ char snaps[32];
+ integer isnum;
+ logical ltest[6], sfatal;
+ char snamet[6], transa[1], transb[1];
+ real thresh;
+ logical ltestt, tsterr;
+ char summry[32];
+
+ /* Fortran I/O blocks */
+ static cilist io___2 = { 0, 5, 0, 0, 0 };
+ static cilist io___4 = { 0, 5, 0, 0, 0 };
+ static cilist io___6 = { 0, 5, 0, 0, 0 };
+ static cilist io___8 = { 0, 5, 0, 0, 0 };
+ static cilist io___11 = { 0, 5, 0, 0, 0 };
+ static cilist io___13 = { 0, 5, 0, 0, 0 };
+ static cilist io___15 = { 0, 5, 0, 0, 0 };
+ static cilist io___17 = { 0, 5, 0, 0, 0 };
+ static cilist io___19 = { 0, 5, 0, 0, 0 };
+ static cilist io___21 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___22 = { 0, 5, 0, 0, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___26 = { 0, 5, 0, 0, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___29 = { 0, 5, 0, 0, 0 };
+ static cilist io___31 = { 0, 5, 0, 0, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___34 = { 0, 5, 0, 0, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___40 = { 0, 0, 0, 0, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9984, 0 };
+ static cilist io___42 = { 0, 0, 0, 0, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, 0, 0 };
+ static cilist io___46 = { 0, 5, 1, fmt_9988, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___69 = { 0, 0, 0, 0, 0 };
+ static cilist io___70 = { 0, 0, 0, fmt_9987, 0 };
+ static cilist io___71 = { 0, 0, 0, 0, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9986, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9985, 0 };
+ static cilist io___80 = { 0, 0, 0, fmt_9991, 0 };
+
+
+
+/* Test program for the REAL Level 3 Blas. */
+
+/* The program must be driven by a short data file. The first 14 records */
+/* of the file are read using list-directed input, the last 6 records */
+/* are read using the format ( A6, L2 ). An annotated example of a data */
+/* file can be obtained by deleting the first 3 characters from the */
+/* following 20 lines: */
+/* 'sblat3.out' NAME OF SUMMARY OUTPUT FILE */
+/* 6 UNIT NUMBER OF SUMMARY FILE */
+/* 'SBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE */
+/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */
+/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */
+/* F LOGICAL FLAG, T TO STOP ON FAILURES. */
+/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */
+/* 16.0 THRESHOLD VALUE OF TEST RATIO */
+/* 6 NUMBER OF VALUES OF N */
+/* 0 1 2 3 5 9 VALUES OF N */
+/* 3 NUMBER OF VALUES OF ALPHA */
+/* 0.0 1.0 0.7 VALUES OF ALPHA */
+/* 3 NUMBER OF VALUES OF BETA */
+/* 0.0 1.0 1.3 VALUES OF BETA */
+/* SGEMM T PUT F FOR NO TEST. SAME COLUMNS. */
+/* SSYMM T PUT F FOR NO TEST. SAME COLUMNS. */
+/* STRMM T PUT F FOR NO TEST. SAME COLUMNS. */
+/* STRSM T PUT F FOR NO TEST. SAME COLUMNS. */
+/* SSYRK T PUT F FOR NO TEST. SAME COLUMNS. */
+/* SSYR2K T PUT F FOR NO TEST. SAME COLUMNS. */
+
+/* See: */
+
+/* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. */
+/* A Set of Level 3 Basic Linear Algebra Subprograms. */
+
+/* Technical Memorandum No.88 (Revision 1), Mathematics and */
+/* Computer Science Division, Argonne National Laboratory, 9700 */
+/* South Cass Avenue, Argonne, Illinois 60439, US. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers */
+/* can be run multiple times without deleting generated */
+/* output files (susan) */
+
+/* .. Parameters .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+
+/* Read name and unit number for summary output file and open file. */
+
+ s_rsle(&io___2);
+ do_lio(&c__9, &c__1, summry, (ftnlen)32);
+ e_rsle();
+ s_rsle(&io___4);
+ do_lio(&c__3, &c__1, (char *)&nout, (ftnlen)sizeof(integer));
+ e_rsle();
+ o__1.oerr = 0;
+ o__1.ounit = nout;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = summry;
+ o__1.orl = 0;
+ o__1.osta = 0;
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);
+ infoc_1.noutc = nout;
+
+/* Read name and unit number for snapshot output file and open file. */
+
+ s_rsle(&io___6);
+ do_lio(&c__9, &c__1, snaps, (ftnlen)32);
+ e_rsle();
+ s_rsle(&io___8);
+ do_lio(&c__3, &c__1, (char *)&ntra, (ftnlen)sizeof(integer));
+ e_rsle();
+ trace = ntra >= 0;
+ if (trace) {
+ o__1.oerr = 0;
+ o__1.ounit = ntra;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = snaps;
+ o__1.orl = 0;
+ o__1.osta = 0;
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);
+ }
+/* Read the flag that directs rewinding of the snapshot file. */
+ s_rsle(&io___11);
+ do_lio(&c__8, &c__1, (char *)&rewi, (ftnlen)sizeof(logical));
+ e_rsle();
+ rewi = rewi && trace;
+/* Read the flag that directs stopping on any failure. */
+ s_rsle(&io___13);
+ do_lio(&c__8, &c__1, (char *)&sfatal, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the flag that indicates whether error exits are to be tested. */
+ s_rsle(&io___15);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the threshold value of the test ratio */
+ s_rsle(&io___17);
+ do_lio(&c__4, &c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_rsle();
+
+/* Read and check the parameter values for the tests. */
+
+/* Values of N */
+ s_rsle(&io___19);
+ do_lio(&c__3, &c__1, (char *)&nidim, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nidim < 1 || nidim > 9) {
+ io___21.ciunit = nout;
+ s_wsfe(&io___21);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___22);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {
+ io___25.ciunit = nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, (char *)&c__65, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+/* L10: */
+ }
+/* Values of ALPHA */
+ s_rsle(&io___26);
+ do_lio(&c__3, &c__1, (char *)&nalf, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nalf < 1 || nalf > 7) {
+ io___28.ciunit = nout;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "ALPHA", (ftnlen)5);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___29);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__4, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_rsle();
+/* Values of BETA */
+ s_rsle(&io___31);
+ do_lio(&c__3, &c__1, (char *)&nbet, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nbet < 1 || nbet > 7) {
+ io___33.ciunit = nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, "BETA", (ftnlen)4);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___34);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__4, &c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_rsle();
+
+/* Report values of parameters. */
+
+ io___36.ciunit = nout;
+ s_wsfe(&io___36);
+ e_wsfe();
+ io___37.ciunit = nout;
+ s_wsfe(&io___37);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ io___38.ciunit = nout;
+ s_wsfe(&io___38);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_wsfe();
+ io___39.ciunit = nout;
+ s_wsfe(&io___39);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_wsfe();
+ if (! tsterr) {
+ io___40.ciunit = nout;
+ s_wsle(&io___40);
+ e_wsle();
+ io___41.ciunit = nout;
+ s_wsfe(&io___41);
+ e_wsfe();
+ }
+ io___42.ciunit = nout;
+ s_wsle(&io___42);
+ e_wsle();
+ io___43.ciunit = nout;
+ s_wsfe(&io___43);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_wsfe();
+ io___44.ciunit = nout;
+ s_wsle(&io___44);
+ e_wsle();
+
+/* Read names of subroutines and flags which indicate */
+/* whether they are to be tested. */
+
+ for (i__ = 1; i__ <= 6; ++i__) {
+ ltest[i__ - 1] = FALSE_;
+/* L20: */
+ }
+L30:
+ i__1 = s_rsfe(&io___46);
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = do_fio(&c__1, snamet, (ftnlen)6);
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = do_fio(&c__1, (char *)<estt, (ftnlen)sizeof(logical));
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L60;
+ }
+ for (i__ = 1; i__ <= 6; ++i__) {
+ if (s_cmp(snamet, snames + (i__ - 1) * 6, (ftnlen)6, (ftnlen)6) == 0)
+ {
+ goto L50;
+ }
+/* L40: */
+ }
+ io___49.ciunit = nout;
+ s_wsfe(&io___49);
+ do_fio(&c__1, snamet, (ftnlen)6);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+L50:
+ ltest[i__ - 1] = ltestt;
+ goto L30;
+
+L60:
+ cl__1.cerr = 0;
+ cl__1.cunit = 5;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+
+/* Compute EPS (the machine precision). */
+
+ eps = 1.f;
+L70:
+ r__1 = eps + 1.f;
+ if (sdiff_(&r__1, &c_b85) == 0.f) {
+ goto L80;
+ }
+ eps *= .5f;
+ goto L70;
+L80:
+ eps += eps;
+ io___51.ciunit = nout;
+ s_wsfe(&io___51);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+
+/* Check the reliability of SMMCH using exact data. */
+
+ n = 32;
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ - j + 1;
+ ab[i__ + j * 65 - 66] = (real) max(i__3,0);
+/* L90: */
+ }
+ ab[j + 4224] = (real) j;
+ ab[(j + 65) * 65 - 65] = (real) j;
+ c__[j - 1] = 0.f;
+/* L100: */
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ cc[j - 1] = (real) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3)
+ ;
+/* L110: */
+ }
+/* CC holds the exact result. On exit from SMMCH CT holds */
+/* the result computed by SMMCH. */
+ *(unsigned char *)transa = 'N';
+ *(unsigned char *)transb = 'N';
+ smmch_(transa, transb, &n, &c__1, &n, &c_b85, ab, &c__65, &ab[4225], &
+ c__65, &c_b99, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal,
+ &nout, &c_true, (ftnlen)1, (ftnlen)1);
+ same = lse_(cc, ct, &n);
+ if (! same || err != 0.f) {
+ io___64.ciunit = nout;
+ s_wsfe(&io___64);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ *(unsigned char *)transb = 'T';
+ smmch_(transa, transb, &n, &c__1, &n, &c_b85, ab, &c__65, &ab[4225], &
+ c__65, &c_b99, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal,
+ &nout, &c_true, (ftnlen)1, (ftnlen)1);
+ same = lse_(cc, ct, &n);
+ if (! same || err != 0.f) {
+ io___65.ciunit = nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ ab[j + 4224] = (real) (n - j + 1);
+ ab[(j + 65) * 65 - 65] = (real) (n - j + 1);
+/* L120: */
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ cc[n - j] = (real) (j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3)
+ ;
+/* L130: */
+ }
+ *(unsigned char *)transa = 'T';
+ *(unsigned char *)transb = 'N';
+ smmch_(transa, transb, &n, &c__1, &n, &c_b85, ab, &c__65, &ab[4225], &
+ c__65, &c_b99, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal,
+ &nout, &c_true, (ftnlen)1, (ftnlen)1);
+ same = lse_(cc, ct, &n);
+ if (! same || err != 0.f) {
+ io___66.ciunit = nout;
+ s_wsfe(&io___66);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ *(unsigned char *)transb = 'T';
+ smmch_(transa, transb, &n, &c__1, &n, &c_b85, ab, &c__65, &ab[4225], &
+ c__65, &c_b99, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal,
+ &nout, &c_true, (ftnlen)1, (ftnlen)1);
+ same = lse_(cc, ct, &n);
+ if (! same || err != 0.f) {
+ io___67.ciunit = nout;
+ s_wsfe(&io___67);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Test each subroutine in turn. */
+
+ for (isnum = 1; isnum <= 6; ++isnum) {
+ io___69.ciunit = nout;
+ s_wsle(&io___69);
+ e_wsle();
+ if (! ltest[isnum - 1]) {
+/* Subprogram is not to be tested. */
+ io___70.ciunit = nout;
+ s_wsfe(&io___70);
+ do_fio(&c__1, snames + (isnum - 1) * 6, (ftnlen)6);
+ e_wsfe();
+ } else {
+ s_copy(srnamc_1.srnamt, snames + (isnum - 1) * 6, (ftnlen)6, (
+ ftnlen)6);
+/* Test error exits. */
+ if (tsterr) {
+ schke_(&isnum, snames + (isnum - 1) * 6, &nout, (ftnlen)6);
+ io___71.ciunit = nout;
+ s_wsle(&io___71);
+ e_wsle();
+ }
+/* Test computations. */
+ infoc_1.infot = 0;
+ infoc_1.ok = TRUE_;
+ fatal = FALSE_;
+ switch (isnum) {
+ case 1: goto L140;
+ case 2: goto L150;
+ case 3: goto L160;
+ case 4: goto L160;
+ case 5: goto L170;
+ case 6: goto L180;
+ }
+/* Test SGEMM, 01. */
+L140:
+ schk1_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &nbet,
+ bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, cc, cs,
+ ct, g, (ftnlen)6);
+ goto L190;
+/* Test SSYMM, 02. */
+L150:
+ schk2_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &nbet,
+ bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, cc, cs,
+ ct, g, (ftnlen)6);
+ goto L190;
+/* Test STRMM, 03, STRSM, 04. */
+L160:
+ schk3_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &c__65,
+ ab, aa, as, &ab[4225], bb, bs, ct, g, c__, (ftnlen)6);
+ goto L190;
+/* Test SSYRK, 05. */
+L170:
+ schk4_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &nbet,
+ bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, cc, cs,
+ ct, g, (ftnlen)6);
+ goto L190;
+/* Test SSYR2K, 06. */
+L180:
+ schk5_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &nbet,
+ bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, ct, g, w, (
+ ftnlen)6);
+ goto L190;
+
+L190:
+ if (fatal && sfatal) {
+ goto L210;
+ }
+ }
+/* L200: */
+ }
+ io___78.ciunit = nout;
+ s_wsfe(&io___78);
+ e_wsfe();
+ goto L230;
+
+L210:
+ io___79.ciunit = nout;
+ s_wsfe(&io___79);
+ e_wsfe();
+ goto L230;
+
+L220:
+ io___80.ciunit = nout;
+ s_wsfe(&io___80);
+ e_wsfe();
+
+L230:
+ if (trace) {
+ cl__1.cerr = 0;
+ cl__1.cunit = ntra;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ }
+ cl__1.cerr = 0;
+ cl__1.cunit = nout;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ s_stop("", (ftnlen)0);
+
+
+/* End of SBLAT3. */
+
+ return 0;
+} /* MAIN__ */
+
+/* Subroutine */ int schk1_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nalf, real *alf, integer *
+ nbet, real *bet, integer *nmax, real *a, real *aa, real *as, real *b,
+ real *bb, real *bs, real *c__, real *cc, real *cs, real *ct, real *g,
+ ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ich[3] = "NTC";
+
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002','\002"
+ ",a1,\002',\002,3(i3,\002,\002),f4.1,\002, A,\002,i3,\002, B,\002"
+ ",i3,\002,\002,f4.1,\002, \002,\002C,\002,i3,\002).\002)";
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, k, m, n, ia, ib, ma, mb, na, nb, nc, ik, im, in, ks, ms, ns,
+ ica, icb, laa, lbb, lda, lcc, ldb, ldc;
+ real als, bls;
+ extern logical lse_(real *, real *, integer *);
+ real err, beta;
+ integer ldas, ldbs, ldcs;
+ logical same, null;
+ real alpha;
+ logical isame[13];
+ extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, logical *, real *
+ , ftnlen, ftnlen, ftnlen);
+ logical trana, tranb;
+ extern /* Subroutine */ int smmch_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *, real *, real *, real *, integer *, real *,
+ real *, logical *, integer *, logical *, ftnlen, ftnlen), sgemm_(
+ char *, char *, integer *, integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, real *, integer *);
+ integer nargs;
+ logical reset;
+ char tranas[1], tranbs[1], transa[1], transb[1];
+ real errmax;
+ extern logical lseres_(char *, char *, integer *, integer *, real *, real
+ *, integer *, ftnlen, ftnlen);
+
+ /* Fortran I/O blocks */
+ static cilist io___124 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___125 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___128 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___130 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___131 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___132 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___133 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests SGEMM. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+
+ nargs = 13;
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.f;
+
+ i__1 = *nidim;
+ for (im = 1; im <= i__1; ++im) {
+ m = idim[im];
+
+ i__2 = *nidim;
+ for (in = 1; in <= i__2; ++in) {
+ n = idim[in];
+/* Set LDC to 1 more than minimum value if room. */
+ ldc = m;
+ if (ldc < *nmax) {
+ ++ldc;
+ }
+/* Skip tests if not enough room. */
+ if (ldc > *nmax) {
+ goto L100;
+ }
+ lcc = ldc * n;
+ null = n <= 0 || m <= 0;
+
+ i__3 = *nidim;
+ for (ik = 1; ik <= i__3; ++ik) {
+ k = idim[ik];
+
+ for (ica = 1; ica <= 3; ++ica) {
+ *(unsigned char *)transa = *(unsigned char *)&ich[ica - 1]
+ ;
+ trana = *(unsigned char *)transa == 'T' || *(unsigned
+ char *)transa == 'C';
+
+ if (trana) {
+ ma = k;
+ na = m;
+ } else {
+ ma = m;
+ na = k;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ lda = ma;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L80;
+ }
+ laa = lda * na;
+
+/* Generate the matrix A. */
+
+ smake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[
+ 1], &lda, &reset, &c_b99, (ftnlen)2, (ftnlen)1, (
+ ftnlen)1);
+
+ for (icb = 1; icb <= 3; ++icb) {
+ *(unsigned char *)transb = *(unsigned char *)&ich[icb
+ - 1];
+ tranb = *(unsigned char *)transb == 'T' || *(unsigned
+ char *)transb == 'C';
+
+ if (tranb) {
+ mb = n;
+ nb = k;
+ } else {
+ mb = k;
+ nb = n;
+ }
+/* Set LDB to 1 more than minimum value if room. */
+ ldb = mb;
+ if (ldb < *nmax) {
+ ++ldb;
+ }
+/* Skip tests if not enough room. */
+ if (ldb > *nmax) {
+ goto L70;
+ }
+ lbb = ldb * nb;
+
+/* Generate the matrix B. */
+
+ smake_("GE", " ", " ", &mb, &nb, &b[b_offset], nmax, &
+ bb[1], &ldb, &reset, &c_b99, (ftnlen)2, (
+ ftnlen)1, (ftnlen)1);
+
+ i__4 = *nalf;
+ for (ia = 1; ia <= i__4; ++ia) {
+ alpha = alf[ia];
+
+ i__5 = *nbet;
+ for (ib = 1; ib <= i__5; ++ib) {
+ beta = bet[ib];
+
+/* Generate the matrix C. */
+
+ smake_("GE", " ", " ", &m, &n, &c__[c_offset],
+ nmax, &cc[1], &ldc, &reset, &c_b99, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the */
+/* subroutine. */
+
+ *(unsigned char *)tranas = *(unsigned char *)
+ transa;
+ *(unsigned char *)tranbs = *(unsigned char *)
+ transb;
+ ms = m;
+ ns = n;
+ ks = k;
+ als = alpha;
+ i__6 = laa;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ as[i__] = aa[i__];
+/* L10: */
+ }
+ ldas = lda;
+ i__6 = lbb;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ bs[i__] = bb[i__];
+/* L20: */
+ }
+ ldbs = ldb;
+ bls = beta;
+ i__6 = lcc;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ cs[i__] = cc[i__];
+/* L30: */
+ }
+ ldcs = ldc;
+
+/* Call the subroutine. */
+
+ if (*trace) {
+ io___124.ciunit = *ntra;
+ s_wsfe(&io___124);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ sgemm_(transa, transb, &m, &n, &k, &alpha, &
+ aa[1], &lda, &bb[1], &ldb, &beta, &cc[
+ 1], &ldc);
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___125.ciunit = *nout;
+ s_wsfe(&io___125);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)transa == *(
+ unsigned char *)tranas;
+ isame[1] = *(unsigned char *)transb == *(
+ unsigned char *)tranbs;
+ isame[2] = ms == m;
+ isame[3] = ns == n;
+ isame[4] = ks == k;
+ isame[5] = als == alpha;
+ isame[6] = lse_(&as[1], &aa[1], &laa);
+ isame[7] = ldas == lda;
+ isame[8] = lse_(&bs[1], &bb[1], &lbb);
+ isame[9] = ldbs == ldb;
+ isame[10] = bls == beta;
+ if (null) {
+ isame[11] = lse_(&cs[1], &cc[1], &lcc);
+ } else {
+ isame[11] = lseres_("GE", " ", &m, &n, &
+ cs[1], &cc[1], &ldc, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[12] = ldcs == ldc;
+
+/* If data was incorrectly changed, report */
+/* and return. */
+
+ same = TRUE_;
+ i__6 = nargs;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___128.ciunit = *nout;
+ s_wsfe(&io___128);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+
+/* Check the result. */
+
+ smmch_(transa, transb, &m, &n, &k, &alpha,
+ &a[a_offset], nmax, &b[b_offset],
+ nmax, &beta, &c__[c_offset],
+ nmax, &ct[1], &g[1], &cc[1], &ldc,
+ eps, &err, fatal, nout, &c_true,
+ (ftnlen)1, (ftnlen)1);
+ errmax = dmax(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L120;
+ }
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+L70:
+ ;
+ }
+
+L80:
+ ;
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+/* L110: */
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___130.ciunit = *nout;
+ s_wsfe(&io___130);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___131.ciunit = *nout;
+ s_wsfe(&io___131);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ goto L130;
+
+L120:
+ io___132.ciunit = *nout;
+ s_wsfe(&io___132);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ io___133.ciunit = *nout;
+ s_wsfe(&io___133);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L130:
+ return 0;
+
+
+/* End of SCHK1. */
+
+} /* schk1_ */
+
+/* Subroutine */ int schk2_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nalf, real *alf, integer *
+ nbet, real *bet, integer *nmax, real *a, real *aa, real *as, real *b,
+ real *bb, real *bs, real *c__, real *cc, real *cs, real *ct, real *g,
+ ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ichs[2] = "LR";
+ static char ichu[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002(\002,2(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),f4.1,\002, A,\002,i3,\002, B,\002,i"
+ "3,\002,\002,f4.1,\002, C,\002,i3,\002) \002,\002 .\002)";
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, m, n, ia, ib, na, nc, im, in, ms, ns, laa, lbb, lda, lcc,
+ ldb, ldc, ics;
+ real als, bls;
+ integer icu;
+ extern logical lse_(real *, real *, integer *);
+ real err, beta;
+ integer ldas, ldbs, ldcs;
+ logical same;
+ char side[1];
+ logical left, null;
+ char uplo[1];
+ real alpha;
+ logical isame[13];
+ extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, logical *, real *
+ , ftnlen, ftnlen, ftnlen);
+ char sides[1];
+ extern /* Subroutine */ int smmch_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *, real *, real *, real *, integer *, real *,
+ real *, logical *, integer *, logical *, ftnlen, ftnlen);
+ integer nargs;
+ logical reset;
+ char uplos[1];
+ extern /* Subroutine */ int ssymm_(char *, char *, integer *, integer *,
+ real *, real *, integer *, real *, integer *, real *, real *,
+ integer *);
+ real errmax;
+ extern logical lseres_(char *, char *, integer *, integer *, real *, real
+ *, integer *, ftnlen, ftnlen);
+
+ /* Fortran I/O blocks */
+ static cilist io___171 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___172 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___175 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___177 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___178 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___179 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___180 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests SSYMM. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+
+ nargs = 12;
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.f;
+
+ i__1 = *nidim;
+ for (im = 1; im <= i__1; ++im) {
+ m = idim[im];
+
+ i__2 = *nidim;
+ for (in = 1; in <= i__2; ++in) {
+ n = idim[in];
+/* Set LDC to 1 more than minimum value if room. */
+ ldc = m;
+ if (ldc < *nmax) {
+ ++ldc;
+ }
+/* Skip tests if not enough room. */
+ if (ldc > *nmax) {
+ goto L90;
+ }
+ lcc = ldc * n;
+ null = n <= 0 || m <= 0;
+
+/* Set LDB to 1 more than minimum value if room. */
+ ldb = m;
+ if (ldb < *nmax) {
+ ++ldb;
+ }
+/* Skip tests if not enough room. */
+ if (ldb > *nmax) {
+ goto L90;
+ }
+ lbb = ldb * n;
+
+/* Generate the matrix B. */
+
+ smake_("GE", " ", " ", &m, &n, &b[b_offset], nmax, &bb[1], &ldb, &
+ reset, &c_b99, (ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ for (ics = 1; ics <= 2; ++ics) {
+ *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1];
+ left = *(unsigned char *)side == 'L';
+
+ if (left) {
+ na = m;
+ } else {
+ na = n;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ lda = na;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L80;
+ }
+ laa = lda * na;
+
+ for (icu = 1; icu <= 2; ++icu) {
+ *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
+
+/* Generate the symmetric matrix A. */
+
+ smake_("SY", uplo, " ", &na, &na, &a[a_offset], nmax, &aa[
+ 1], &lda, &reset, &c_b99, (ftnlen)2, (ftnlen)1, (
+ ftnlen)1);
+
+ i__3 = *nalf;
+ for (ia = 1; ia <= i__3; ++ia) {
+ alpha = alf[ia];
+
+ i__4 = *nbet;
+ for (ib = 1; ib <= i__4; ++ib) {
+ beta = bet[ib];
+
+/* Generate the matrix C. */
+
+ smake_("GE", " ", " ", &m, &n, &c__[c_offset],
+ nmax, &cc[1], &ldc, &reset, &c_b99, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the */
+/* subroutine. */
+
+ *(unsigned char *)sides = *(unsigned char *)side;
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ ms = m;
+ ns = n;
+ als = alpha;
+ i__5 = laa;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ as[i__] = aa[i__];
+/* L10: */
+ }
+ ldas = lda;
+ i__5 = lbb;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ bs[i__] = bb[i__];
+/* L20: */
+ }
+ ldbs = ldb;
+ bls = beta;
+ i__5 = lcc;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ cs[i__] = cc[i__];
+/* L30: */
+ }
+ ldcs = ldc;
+
+/* Call the subroutine. */
+
+ if (*trace) {
+ io___171.ciunit = *ntra;
+ s_wsfe(&io___171);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(
+ real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(
+ real));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ssymm_(side, uplo, &m, &n, &alpha, &aa[1], &lda, &
+ bb[1], &ldb, &beta, &cc[1], &ldc);
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___172.ciunit = *nout;
+ s_wsfe(&io___172);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L110;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)sides == *(unsigned
+ char *)side;
+ isame[1] = *(unsigned char *)uplos == *(unsigned
+ char *)uplo;
+ isame[2] = ms == m;
+ isame[3] = ns == n;
+ isame[4] = als == alpha;
+ isame[5] = lse_(&as[1], &aa[1], &laa);
+ isame[6] = ldas == lda;
+ isame[7] = lse_(&bs[1], &bb[1], &lbb);
+ isame[8] = ldbs == ldb;
+ isame[9] = bls == beta;
+ if (null) {
+ isame[10] = lse_(&cs[1], &cc[1], &lcc);
+ } else {
+ isame[10] = lseres_("GE", " ", &m, &n, &cs[1],
+ &cc[1], &ldc, (ftnlen)2, (ftnlen)1);
+ }
+ isame[11] = ldcs == ldc;
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__5 = nargs;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___175.ciunit = *nout;
+ s_wsfe(&io___175);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L110;
+ }
+
+ if (! null) {
+
+/* Check the result. */
+
+ if (left) {
+ smmch_("N", "N", &m, &n, &m, &alpha, &a[
+ a_offset], nmax, &b[b_offset],
+ nmax, &beta, &c__[c_offset], nmax,
+ &ct[1], &g[1], &cc[1], &ldc, eps,
+ &err, fatal, nout, &c_true, (
+ ftnlen)1, (ftnlen)1);
+ } else {
+ smmch_("N", "N", &m, &n, &n, &alpha, &b[
+ b_offset], nmax, &a[a_offset],
+ nmax, &beta, &c__[c_offset], nmax,
+ &ct[1], &g[1], &cc[1], &ldc, eps,
+ &err, fatal, nout, &c_true, (
+ ftnlen)1, (ftnlen)1);
+ }
+ errmax = dmax(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L110;
+ }
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+/* L70: */
+ }
+
+L80:
+ ;
+ }
+
+L90:
+ ;
+ }
+
+/* L100: */
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___177.ciunit = *nout;
+ s_wsfe(&io___177);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___178.ciunit = *nout;
+ s_wsfe(&io___178);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ goto L120;
+
+L110:
+ io___179.ciunit = *nout;
+ s_wsfe(&io___179);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ io___180.ciunit = *nout;
+ s_wsfe(&io___180);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L120:
+ return 0;
+
+
+/* End of SCHK2. */
+
+} /* schk2_ */
+
+/* Subroutine */ int schk3_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nalf, real *alf, integer *
+ nmax, real *a, real *aa, real *as, real *b, real *bb, real *bs, real *
+ ct, real *g, real *c__, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ichu[2] = "UL";
+ static char icht[3] = "NTC";
+ static char ichd[2] = "UN";
+ static char ichs[2] = "LR";
+
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002(\002,4(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),f4.1,\002, A,\002,i3,\002, B,\002,i"
+ "3,\002) .\002)";
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio(
+ integer *, char *, ftnlen), e_wsfe(void), f_rew(alist *);
+
+ /* Local variables */
+ integer i__, j, m, n, ia, na, nc, im, in, ms, ns, laa, icd, lbb, lda, ldb,
+ ics;
+ real als;
+ integer ict, icu;
+ extern logical lse_(real *, real *, integer *);
+ real err;
+ char diag[1];
+ integer ldas, ldbs;
+ logical same;
+ char side[1];
+ logical left, null;
+ char uplo[1];
+ real alpha;
+ char diags[1];
+ logical isame[13];
+ extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, logical *, real *
+ , ftnlen, ftnlen, ftnlen);
+ char sides[1];
+ extern /* Subroutine */ int smmch_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *, real *, real *, real *, integer *, real *,
+ real *, logical *, integer *, logical *, ftnlen, ftnlen);
+ integer nargs;
+ logical reset;
+ char uplos[1];
+ extern /* Subroutine */ int strmm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), strsm_(char *, char *, char *,
+ char *, integer *, integer *, real *, real *, integer *, real *,
+ integer *);
+ char tranas[1], transa[1];
+ real errmax;
+ extern logical lseres_(char *, char *, integer *, integer *, real *, real
+ *, integer *, ftnlen, ftnlen);
+
+ /* Fortran I/O blocks */
+ static cilist io___221 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___222 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___223 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___226 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___228 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___229 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___230 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___231 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests STRMM and STRSM. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --g;
+ --ct;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+
+ nargs = 11;
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.f;
+/* Set up zero matrix for SMMCH. */
+ i__1 = *nmax;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *nmax;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+
+ i__1 = *nidim;
+ for (im = 1; im <= i__1; ++im) {
+ m = idim[im];
+
+ i__2 = *nidim;
+ for (in = 1; in <= i__2; ++in) {
+ n = idim[in];
+/* Set LDB to 1 more than minimum value if room. */
+ ldb = m;
+ if (ldb < *nmax) {
+ ++ldb;
+ }
+/* Skip tests if not enough room. */
+ if (ldb > *nmax) {
+ goto L130;
+ }
+ lbb = ldb * n;
+ null = m <= 0 || n <= 0;
+
+ for (ics = 1; ics <= 2; ++ics) {
+ *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1];
+ left = *(unsigned char *)side == 'L';
+ if (left) {
+ na = m;
+ } else {
+ na = n;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ lda = na;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L130;
+ }
+ laa = lda * na;
+
+ for (icu = 1; icu <= 2; ++icu) {
+ *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
+
+ for (ict = 1; ict <= 3; ++ict) {
+ *(unsigned char *)transa = *(unsigned char *)&icht[
+ ict - 1];
+
+ for (icd = 1; icd <= 2; ++icd) {
+ *(unsigned char *)diag = *(unsigned char *)&ichd[
+ icd - 1];
+
+ i__3 = *nalf;
+ for (ia = 1; ia <= i__3; ++ia) {
+ alpha = alf[ia];
+
+/* Generate the matrix A. */
+
+ smake_("TR", uplo, diag, &na, &na, &a[
+ a_offset], nmax, &aa[1], &lda, &reset,
+ &c_b99, (ftnlen)2, (ftnlen)1, (
+ ftnlen)1);
+
+/* Generate the matrix B. */
+
+ smake_("GE", " ", " ", &m, &n, &b[b_offset],
+ nmax, &bb[1], &ldb, &reset, &c_b99, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the */
+/* subroutine. */
+
+ *(unsigned char *)sides = *(unsigned char *)
+ side;
+ *(unsigned char *)uplos = *(unsigned char *)
+ uplo;
+ *(unsigned char *)tranas = *(unsigned char *)
+ transa;
+ *(unsigned char *)diags = *(unsigned char *)
+ diag;
+ ms = m;
+ ns = n;
+ als = alpha;
+ i__4 = laa;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ as[i__] = aa[i__];
+/* L30: */
+ }
+ ldas = lda;
+ i__4 = lbb;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ bs[i__] = bb[i__];
+/* L40: */
+ }
+ ldbs = ldb;
+
+/* Call the subroutine. */
+
+ if (s_cmp(sname + 3, "MM", (ftnlen)2, (ftnlen)
+ 2) == 0) {
+ if (*trace) {
+ io___221.ciunit = *ntra;
+ s_wsfe(&io___221);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ strmm_(side, uplo, transa, diag, &m, &n, &
+ alpha, &aa[1], &lda, &bb[1], &ldb);
+ } else if (s_cmp(sname + 3, "SM", (ftnlen)2, (
+ ftnlen)2) == 0) {
+ if (*trace) {
+ io___222.ciunit = *ntra;
+ s_wsfe(&io___222);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)
+ sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ strsm_(side, uplo, transa, diag, &m, &n, &
+ alpha, &aa[1], &lda, &bb[1], &ldb);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___223.ciunit = *nout;
+ s_wsfe(&io___223);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L150;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)sides == *(
+ unsigned char *)side;
+ isame[1] = *(unsigned char *)uplos == *(
+ unsigned char *)uplo;
+ isame[2] = *(unsigned char *)tranas == *(
+ unsigned char *)transa;
+ isame[3] = *(unsigned char *)diags == *(
+ unsigned char *)diag;
+ isame[4] = ms == m;
+ isame[5] = ns == n;
+ isame[6] = als == alpha;
+ isame[7] = lse_(&as[1], &aa[1], &laa);
+ isame[8] = ldas == lda;
+ if (null) {
+ isame[9] = lse_(&bs[1], &bb[1], &lbb);
+ } else {
+ isame[9] = lseres_("GE", " ", &m, &n, &bs[
+ 1], &bb[1], &ldb, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[10] = ldbs == ldb;
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__4 = nargs;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___226.ciunit = *nout;
+ s_wsfe(&io___226);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L50: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L150;
+ }
+
+ if (! null) {
+ if (s_cmp(sname + 3, "MM", (ftnlen)2, (
+ ftnlen)2) == 0) {
+
+/* Check the result. */
+
+ if (left) {
+ smmch_(transa, "N", &m, &n, &m, &
+ alpha, &a[a_offset], nmax,
+ &b[b_offset], nmax, &
+ c_b99, &c__[c_offset],
+ nmax, &ct[1], &g[1], &bb[
+ 1], &ldb, eps, &err,
+ fatal, nout, &c_true, (
+ ftnlen)1, (ftnlen)1);
+ } else {
+ smmch_("N", transa, &m, &n, &n, &
+ alpha, &b[b_offset], nmax,
+ &a[a_offset], nmax, &
+ c_b99, &c__[c_offset],
+ nmax, &ct[1], &g[1], &bb[
+ 1], &ldb, eps, &err,
+ fatal, nout, &c_true, (
+ ftnlen)1, (ftnlen)1);
+ }
+ } else if (s_cmp(sname + 3, "SM", (ftnlen)
+ 2, (ftnlen)2) == 0) {
+
+/* Compute approximation to original */
+/* matrix. */
+
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__5 = m;
+ for (i__ = 1; i__ <= i__5; ++i__)
+ {
+ c__[i__ + j * c_dim1] = bb[i__ + (j - 1) * ldb];
+ bb[i__ + (j - 1) * ldb] = alpha * b[i__ + j *
+ b_dim1];
+/* L60: */
+ }
+/* L70: */
+ }
+
+ if (left) {
+ smmch_(transa, "N", &m, &n, &m, &
+ c_b85, &a[a_offset], nmax,
+ &c__[c_offset], nmax, &
+ c_b99, &b[b_offset], nmax,
+ &ct[1], &g[1], &bb[1], &
+ ldb, eps, &err, fatal,
+ nout, &c_false, (ftnlen)1,
+ (ftnlen)1);
+ } else {
+ smmch_("N", transa, &m, &n, &n, &
+ c_b85, &c__[c_offset],
+ nmax, &a[a_offset], nmax,
+ &c_b99, &b[b_offset],
+ nmax, &ct[1], &g[1], &bb[
+ 1], &ldb, eps, &err,
+ fatal, nout, &c_false, (
+ ftnlen)1, (ftnlen)1);
+ }
+ }
+ errmax = dmax(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L150;
+ }
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+/* L100: */
+ }
+
+/* L110: */
+ }
+
+/* L120: */
+ }
+
+L130:
+ ;
+ }
+
+/* L140: */
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___228.ciunit = *nout;
+ s_wsfe(&io___228);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___229.ciunit = *nout;
+ s_wsfe(&io___229);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ goto L160;
+
+L150:
+ io___230.ciunit = *nout;
+ s_wsfe(&io___230);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ io___231.ciunit = *nout;
+ s_wsfe(&io___231);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L160:
+ return 0;
+
+
+/* End of SCHK3. */
+
+} /* schk3_ */
+
+/* Subroutine */ int schk4_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nalf, real *alf, integer *
+ nbet, real *bet, integer *nmax, real *a, real *aa, real *as, real *b,
+ real *bb, real *bs, real *c__, real *cc, real *cs, real *ct, real *g,
+ ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char icht[3] = "NTC";
+ static char ichu[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002(\002,2(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),f4.1,\002, A,\002,i3,\002,\002,f4.1,"
+ "\002, C,\002,i3,\002) .\002)";
+ static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
+ lda, lcc, ldc;
+ real als;
+ integer ict, icu;
+ extern logical lse_(real *, real *, integer *);
+ real err, beta;
+ integer ldas, ldcs;
+ logical same;
+ real bets;
+ logical tran, null;
+ char uplo[1];
+ real alpha;
+ logical isame[13];
+ extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, logical *, real *
+ , ftnlen, ftnlen, ftnlen), smmch_(char *, char *, integer *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+ , real *, real *, integer *, real *, real *, real *, integer *,
+ real *, real *, logical *, integer *, logical *, ftnlen, ftnlen);
+ integer nargs;
+ logical reset;
+ char trans[1];
+ logical upper;
+ char uplos[1];
+ extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *,
+ real *, real *, integer *, real *, real *, integer *);
+ real errmax;
+ extern logical lseres_(char *, char *, integer *, integer *, real *, real
+ *, integer *, ftnlen, ftnlen);
+ char transs[1];
+
+ /* Fortran I/O blocks */
+ static cilist io___268 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___269 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___272 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___278 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___279 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___280 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___281 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___282 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* Tests SSYRK. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+
+ nargs = 10;
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.f;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+/* Set LDC to 1 more than minimum value if room. */
+ ldc = n;
+ if (ldc < *nmax) {
+ ++ldc;
+ }
+/* Skip tests if not enough room. */
+ if (ldc > *nmax) {
+ goto L100;
+ }
+ lcc = ldc * n;
+ null = n <= 0;
+
+ i__2 = *nidim;
+ for (ik = 1; ik <= i__2; ++ik) {
+ k = idim[ik];
+
+ for (ict = 1; ict <= 3; ++ict) {
+ *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1];
+ tran = *(unsigned char *)trans == 'T' || *(unsigned char *)
+ trans == 'C';
+ if (tran) {
+ ma = k;
+ na = n;
+ } else {
+ ma = n;
+ na = k;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ lda = ma;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L80;
+ }
+ laa = lda * na;
+
+/* Generate the matrix A. */
+
+ smake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[1], &
+ lda, &reset, &c_b99, (ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ for (icu = 1; icu <= 2; ++icu) {
+ *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
+ upper = *(unsigned char *)uplo == 'U';
+
+ i__3 = *nalf;
+ for (ia = 1; ia <= i__3; ++ia) {
+ alpha = alf[ia];
+
+ i__4 = *nbet;
+ for (ib = 1; ib <= i__4; ++ib) {
+ beta = bet[ib];
+
+/* Generate the matrix C. */
+
+ smake_("SY", uplo, " ", &n, &n, &c__[c_offset],
+ nmax, &cc[1], &ldc, &reset, &c_b99, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ *(unsigned char *)transs = *(unsigned char *)
+ trans;
+ ns = n;
+ ks = k;
+ als = alpha;
+ i__5 = laa;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ as[i__] = aa[i__];
+/* L10: */
+ }
+ ldas = lda;
+ bets = beta;
+ i__5 = lcc;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ cs[i__] = cc[i__];
+/* L20: */
+ }
+ ldcs = ldc;
+
+/* Call the subroutine. */
+
+ if (*trace) {
+ io___268.ciunit = *ntra;
+ s_wsfe(&io___268);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(
+ real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(
+ real));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ssyrk_(uplo, trans, &n, &k, &alpha, &aa[1], &lda,
+ &beta, &cc[1], &ldc)
+ ;
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___269.ciunit = *nout;
+ s_wsfe(&io___269);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplos == *(unsigned
+ char *)uplo;
+ isame[1] = *(unsigned char *)transs == *(unsigned
+ char *)trans;
+ isame[2] = ns == n;
+ isame[3] = ks == k;
+ isame[4] = als == alpha;
+ isame[5] = lse_(&as[1], &aa[1], &laa);
+ isame[6] = ldas == lda;
+ isame[7] = bets == beta;
+ if (null) {
+ isame[8] = lse_(&cs[1], &cc[1], &lcc);
+ } else {
+ isame[8] = lseres_("SY", uplo, &n, &n, &cs[1],
+ &cc[1], &ldc, (ftnlen)2, (ftnlen)1);
+ }
+ isame[9] = ldcs == ldc;
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__5 = nargs;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___272.ciunit = *nout;
+ s_wsfe(&io___272);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L30: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+
+/* Check the result column by column. */
+
+ jc = 1;
+ i__5 = n;
+ for (j = 1; j <= i__5; ++j) {
+ if (upper) {
+ jj = 1;
+ lj = j;
+ } else {
+ jj = j;
+ lj = n - j + 1;
+ }
+ if (tran) {
+ smmch_("T", "N", &lj, &c__1, &k, &
+ alpha, &a[jj * a_dim1 + 1],
+ nmax, &a[j * a_dim1 + 1],
+ nmax, &beta, &c__[jj + j *
+ c_dim1], nmax, &ct[1], &g[1],
+ &cc[jc], &ldc, eps, &err,
+ fatal, nout, &c_true, (ftnlen)
+ 1, (ftnlen)1);
+ } else {
+ smmch_("N", "T", &lj, &c__1, &k, &
+ alpha, &a[jj + a_dim1], nmax,
+ &a[j + a_dim1], nmax, &beta, &
+ c__[jj + j * c_dim1], nmax, &
+ ct[1], &g[1], &cc[jc], &ldc,
+ eps, &err, fatal, nout, &
+ c_true, (ftnlen)1, (ftnlen)1);
+ }
+ if (upper) {
+ jc += ldc;
+ } else {
+ jc = jc + ldc + 1;
+ }
+ errmax = dmax(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L110;
+ }
+/* L40: */
+ }
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+/* L70: */
+ }
+
+L80:
+ ;
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___278.ciunit = *nout;
+ s_wsfe(&io___278);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___279.ciunit = *nout;
+ s_wsfe(&io___279);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ goto L130;
+
+L110:
+ if (n > 1) {
+ io___280.ciunit = *nout;
+ s_wsfe(&io___280);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L120:
+ io___281.ciunit = *nout;
+ s_wsfe(&io___281);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ io___282.ciunit = *nout;
+ s_wsfe(&io___282);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L130:
+ return 0;
+
+
+/* End of SCHK4. */
+
+} /* schk4_ */
+
+/* Subroutine */ int schk5_(char *sname, real *eps, real *thresh, integer *
+ nout, integer *ntra, logical *trace, logical *rewi, logical *fatal,
+ integer *nidim, integer *idim, integer *nalf, real *alf, integer *
+ nbet, real *bet, integer *nmax, real *ab, real *aa, real *as, real *
+ bb, real *bs, real *c__, real *cc, real *cs, real *ct, real *g, real *
+ w, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char icht[3] = "NTC";
+ static char ichu[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002(\002,2(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),f4.1,\002, A,\002,i3,\002, B,\002,i"
+ "3,\002,\002,f4.1,\002, C,\002,i3,\002) \002,\002 .\002)";
+ static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
+ lbb, lda, lcc, ldb, ldc;
+ real als;
+ integer ict, icu;
+ extern logical lse_(real *, real *, integer *);
+ real err;
+ integer jjab;
+ real beta;
+ integer ldas, ldbs, ldcs;
+ logical same;
+ real bets;
+ logical tran, null;
+ char uplo[1];
+ real alpha;
+ logical isame[13];
+ extern /* Subroutine */ int smake_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, logical *, real *
+ , ftnlen, ftnlen, ftnlen), smmch_(char *, char *, integer *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+ , real *, real *, integer *, real *, real *, real *, integer *,
+ real *, real *, logical *, integer *, logical *, ftnlen, ftnlen);
+ integer nargs;
+ logical reset;
+ char trans[1];
+ logical upper;
+ char uplos[1];
+ extern /* Subroutine */ int ssyr2k_(char *, char *, integer *, integer *,
+ real *, real *, integer *, real *, integer *, real *, real *,
+ integer *);
+ real errmax;
+ extern logical lseres_(char *, char *, integer *, integer *, real *, real
+ *, integer *, ftnlen, ftnlen);
+ char transs[1];
+
+ /* Fortran I/O blocks */
+ static cilist io___322 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___323 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___326 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___333 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___334 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___335 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___336 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___337 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* Tests SSYR2K. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --w;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ --as;
+ --aa;
+ --ab;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+
+ nargs = 12;
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.f;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+/* Set LDC to 1 more than minimum value if room. */
+ ldc = n;
+ if (ldc < *nmax) {
+ ++ldc;
+ }
+/* Skip tests if not enough room. */
+ if (ldc > *nmax) {
+ goto L130;
+ }
+ lcc = ldc * n;
+ null = n <= 0;
+
+ i__2 = *nidim;
+ for (ik = 1; ik <= i__2; ++ik) {
+ k = idim[ik];
+
+ for (ict = 1; ict <= 3; ++ict) {
+ *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1];
+ tran = *(unsigned char *)trans == 'T' || *(unsigned char *)
+ trans == 'C';
+ if (tran) {
+ ma = k;
+ na = n;
+ } else {
+ ma = n;
+ na = k;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ lda = ma;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L110;
+ }
+ laa = lda * na;
+
+/* Generate the matrix A. */
+
+ if (tran) {
+ i__3 = *nmax << 1;
+ smake_("GE", " ", " ", &ma, &na, &ab[1], &i__3, &aa[1], &
+ lda, &reset, &c_b99, (ftnlen)2, (ftnlen)1, (
+ ftnlen)1);
+ } else {
+ smake_("GE", " ", " ", &ma, &na, &ab[1], nmax, &aa[1], &
+ lda, &reset, &c_b99, (ftnlen)2, (ftnlen)1, (
+ ftnlen)1);
+ }
+
+/* Generate the matrix B. */
+
+ ldb = lda;
+ lbb = laa;
+ if (tran) {
+ i__3 = *nmax << 1;
+ smake_("GE", " ", " ", &ma, &na, &ab[k + 1], &i__3, &bb[1]
+ , &ldb, &reset, &c_b99, (ftnlen)2, (ftnlen)1, (
+ ftnlen)1);
+ } else {
+ smake_("GE", " ", " ", &ma, &na, &ab[k * *nmax + 1], nmax,
+ &bb[1], &ldb, &reset, &c_b99, (ftnlen)2, (ftnlen)
+ 1, (ftnlen)1);
+ }
+
+ for (icu = 1; icu <= 2; ++icu) {
+ *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
+ upper = *(unsigned char *)uplo == 'U';
+
+ i__3 = *nalf;
+ for (ia = 1; ia <= i__3; ++ia) {
+ alpha = alf[ia];
+
+ i__4 = *nbet;
+ for (ib = 1; ib <= i__4; ++ib) {
+ beta = bet[ib];
+
+/* Generate the matrix C. */
+
+ smake_("SY", uplo, " ", &n, &n, &c__[c_offset],
+ nmax, &cc[1], &ldc, &reset, &c_b99, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ *(unsigned char *)transs = *(unsigned char *)
+ trans;
+ ns = n;
+ ks = k;
+ als = alpha;
+ i__5 = laa;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ as[i__] = aa[i__];
+/* L10: */
+ }
+ ldas = lda;
+ i__5 = lbb;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ bs[i__] = bb[i__];
+/* L20: */
+ }
+ ldbs = ldb;
+ bets = beta;
+ i__5 = lcc;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ cs[i__] = cc[i__];
+/* L30: */
+ }
+ ldcs = ldc;
+
+/* Call the subroutine. */
+
+ if (*trace) {
+ io___322.ciunit = *ntra;
+ s_wsfe(&io___322);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(
+ real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(
+ real));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ssyr2k_(uplo, trans, &n, &k, &alpha, &aa[1], &lda,
+ &bb[1], &ldb, &beta, &cc[1], &ldc);
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___323.ciunit = *nout;
+ s_wsfe(&io___323);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L150;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplos == *(unsigned
+ char *)uplo;
+ isame[1] = *(unsigned char *)transs == *(unsigned
+ char *)trans;
+ isame[2] = ns == n;
+ isame[3] = ks == k;
+ isame[4] = als == alpha;
+ isame[5] = lse_(&as[1], &aa[1], &laa);
+ isame[6] = ldas == lda;
+ isame[7] = lse_(&bs[1], &bb[1], &lbb);
+ isame[8] = ldbs == ldb;
+ isame[9] = bets == beta;
+ if (null) {
+ isame[10] = lse_(&cs[1], &cc[1], &lcc);
+ } else {
+ isame[10] = lseres_("SY", uplo, &n, &n, &cs[1]
+ , &cc[1], &ldc, (ftnlen)2, (ftnlen)1);
+ }
+ isame[11] = ldcs == ldc;
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__5 = nargs;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___326.ciunit = *nout;
+ s_wsfe(&io___326);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L150;
+ }
+
+ if (! null) {
+
+/* Check the result column by column. */
+
+ jjab = 1;
+ jc = 1;
+ i__5 = n;
+ for (j = 1; j <= i__5; ++j) {
+ if (upper) {
+ jj = 1;
+ lj = j;
+ } else {
+ jj = j;
+ lj = n - j + 1;
+ }
+ if (tran) {
+ i__6 = k;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ w[i__] = ab[(j - 1 << 1) * *nmax
+ + k + i__];
+ w[k + i__] = ab[(j - 1 << 1) * *
+ nmax + i__];
+/* L50: */
+ }
+ i__6 = k << 1;
+ i__7 = *nmax << 1;
+ i__8 = *nmax << 1;
+ smmch_("T", "N", &lj, &c__1, &i__6, &
+ alpha, &ab[jjab], &i__7, &w[1]
+ , &i__8, &beta, &c__[jj + j *
+ c_dim1], nmax, &ct[1], &g[1],
+ &cc[jc], &ldc, eps, &err,
+ fatal, nout, &c_true, (ftnlen)
+ 1, (ftnlen)1);
+ } else {
+ i__6 = k;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ w[i__] = ab[(k + i__ - 1) * *nmax
+ + j];
+ w[k + i__] = ab[(i__ - 1) * *nmax
+ + j];
+/* L60: */
+ }
+ i__6 = k << 1;
+ i__7 = *nmax << 1;
+ smmch_("N", "N", &lj, &c__1, &i__6, &
+ alpha, &ab[jj], nmax, &w[1], &
+ i__7, &beta, &c__[jj + j *
+ c_dim1], nmax, &ct[1], &g[1],
+ &cc[jc], &ldc, eps, &err,
+ fatal, nout, &c_true, (ftnlen)
+ 1, (ftnlen)1);
+ }
+ if (upper) {
+ jc += ldc;
+ } else {
+ jc = jc + ldc + 1;
+ if (tran) {
+ jjab += *nmax << 1;
+ }
+ }
+ errmax = dmax(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L140;
+ }
+/* L70: */
+ }
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+/* L100: */
+ }
+
+L110:
+ ;
+ }
+
+/* L120: */
+ }
+
+L130:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___333.ciunit = *nout;
+ s_wsfe(&io___333);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___334.ciunit = *nout;
+ s_wsfe(&io___334);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ goto L160;
+
+L140:
+ if (n > 1) {
+ io___335.ciunit = *nout;
+ s_wsfe(&io___335);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L150:
+ io___336.ciunit = *nout;
+ s_wsfe(&io___336);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ io___337.ciunit = *nout;
+ s_wsfe(&io___337);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&alpha, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&beta, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L160:
+ return 0;
+
+
+/* End of SCHK5. */
+
+} /* schk5_ */
+
+/* Subroutine */ int schke_(integer *isnum, char *srnamt, integer *nout,
+ ftnlen srnamt_len)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE TESTS OF ERROR-E"
+ "XITS\002)";
+ static char fmt_9998[] = "(\002 ******* \002,a6,\002 FAILED THE TESTS OF"
+ " ERROR-EXITS *****\002,\002**\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ real a[2] /* was [2][1] */, b[2] /* was [2][1] */, c__[2] /*
+ was [2][1] */, beta, alpha;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *), strmm_(char *, char *, char *,
+ char *, integer *, integer *, real *, real *, integer *, real *,
+ integer *), ssymm_(char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer
+ *, real *, real *, integer *), strsm_(char *,
+ char *, char *, char *, integer *, integer *, real *, real *,
+ integer *, real *, integer *),
+ ssyrk_(char *, char *, integer *, integer *, real *, real *,
+ integer *, real *, real *, integer *), ssyr2k_(
+ char *, char *, integer *, integer *, real *, real *, integer *,
+ real *, integer *, real *, real *, integer *),
+ chkxer_(char *, integer *, integer *, logical *, logical *);
+
+ /* Fortran I/O blocks */
+ static cilist io___343 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___344 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* Tests the error exits from the Level 3 Blas. */
+/* Requires a special version of the error-handling routine XERBLA. */
+/* A, B and C should not need to be defined. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* 3-19-92: Initialize ALPHA and BETA (eca) */
+/* 3-19-92: Fix argument 12 in calls to SSYMM with INFOT = 9 (eca) */
+
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Parameters .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Subroutines .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+/* OK is set to .FALSE. by the special version of XERBLA or by CHKXER */
+/* if anything is wrong. */
+ infoc_1.ok = TRUE_;
+/* LERR is set to .TRUE. by the special version of XERBLA each time */
+/* it is called, and is then tested and re-set by CHKXER. */
+ infoc_1.lerr = FALSE_;
+
+/* Initialize ALPHA and BETA. */
+
+ alpha = 1.f;
+ beta = 2.f;
+
+ switch (*isnum) {
+ case 1: goto L10;
+ case 2: goto L20;
+ case 3: goto L30;
+ case 4: goto L40;
+ case 5: goto L50;
+ case 6: goto L60;
+ }
+L10:
+ infoc_1.infot = 1;
+ sgemm_("/", "N", &c__0, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 1;
+ sgemm_("/", "T", &c__0, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ sgemm_("N", "/", &c__0, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ sgemm_("T", "/", &c__0, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ sgemm_("N", "N", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ sgemm_("N", "T", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ sgemm_("T", "N", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ sgemm_("T", "T", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ sgemm_("N", "N", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ sgemm_("N", "T", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ sgemm_("T", "N", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ sgemm_("T", "T", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ sgemm_("N", "N", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ sgemm_("N", "T", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ sgemm_("T", "N", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ sgemm_("T", "T", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ sgemm_("N", "N", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ sgemm_("N", "T", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ sgemm_("T", "N", &c__0, &c__0, &c__2, &alpha, a, &c__1, b, &c__2, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ sgemm_("T", "T", &c__0, &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ sgemm_("N", "N", &c__0, &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ sgemm_("T", "N", &c__0, &c__0, &c__2, &alpha, a, &c__2, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ sgemm_("N", "T", &c__0, &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ sgemm_("T", "T", &c__0, &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ sgemm_("N", "N", &c__2, &c__0, &c__0, &alpha, a, &c__2, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ sgemm_("N", "T", &c__2, &c__0, &c__0, &alpha, a, &c__2, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ sgemm_("T", "N", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ sgemm_("T", "T", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L70;
+L20:
+ infoc_1.infot = 1;
+ ssymm_("/", "U", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ ssymm_("L", "/", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ssymm_("L", "U", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ssymm_("R", "U", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ssymm_("L", "L", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ssymm_("R", "L", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ssymm_("L", "U", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ssymm_("R", "U", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ssymm_("L", "L", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ssymm_("R", "L", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ ssymm_("L", "U", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ ssymm_("R", "U", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ ssymm_("L", "L", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ ssymm_("R", "L", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ssymm_("L", "U", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ssymm_("R", "U", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ssymm_("L", "L", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ssymm_("R", "L", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ ssymm_("L", "U", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ ssymm_("R", "U", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ ssymm_("L", "L", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ ssymm_("R", "L", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L70;
+L30:
+ infoc_1.infot = 1;
+ strmm_("/", "U", "N", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ strmm_("L", "/", "N", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ strmm_("L", "U", "/", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ strmm_("L", "U", "N", "/", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ strmm_("L", "U", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ strmm_("L", "U", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ strmm_("R", "U", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ strmm_("R", "U", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ strmm_("L", "L", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ strmm_("L", "L", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ strmm_("R", "L", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ strmm_("R", "L", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ strmm_("L", "U", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ strmm_("L", "U", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ strmm_("R", "U", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ strmm_("R", "U", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ strmm_("L", "L", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ strmm_("L", "L", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ strmm_("R", "L", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ strmm_("R", "L", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ strmm_("L", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ strmm_("L", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ strmm_("R", "U", "N", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ strmm_("R", "U", "T", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ strmm_("L", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ strmm_("L", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ strmm_("R", "L", "N", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ strmm_("R", "L", "T", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ strmm_("L", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ strmm_("L", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ strmm_("R", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ strmm_("R", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ strmm_("L", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ strmm_("L", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ strmm_("R", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ strmm_("R", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L70;
+L40:
+ infoc_1.infot = 1;
+ strsm_("/", "U", "N", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ strsm_("L", "/", "N", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ strsm_("L", "U", "/", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ strsm_("L", "U", "N", "/", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ strsm_("L", "U", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ strsm_("L", "U", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ strsm_("R", "U", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ strsm_("R", "U", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ strsm_("L", "L", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ strsm_("L", "L", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ strsm_("R", "L", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ strsm_("R", "L", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ strsm_("L", "U", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ strsm_("L", "U", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ strsm_("R", "U", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ strsm_("R", "U", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ strsm_("L", "L", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ strsm_("L", "L", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ strsm_("R", "L", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ strsm_("R", "L", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ strsm_("L", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ strsm_("L", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ strsm_("R", "U", "N", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ strsm_("R", "U", "T", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ strsm_("L", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ strsm_("L", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ strsm_("R", "L", "N", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ strsm_("R", "L", "T", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ strsm_("L", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ strsm_("L", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ strsm_("R", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ strsm_("R", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ strsm_("L", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ strsm_("L", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ strsm_("R", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ strsm_("R", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L70;
+L50:
+ infoc_1.infot = 1;
+ ssyrk_("/", "N", &c__0, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ ssyrk_("U", "/", &c__0, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ssyrk_("U", "N", &c_n1, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ssyrk_("U", "T", &c_n1, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ssyrk_("L", "N", &c_n1, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ssyrk_("L", "T", &c_n1, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ssyrk_("U", "N", &c__0, &c_n1, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ssyrk_("U", "T", &c__0, &c_n1, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ssyrk_("L", "N", &c__0, &c_n1, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ssyrk_("L", "T", &c__0, &c_n1, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ ssyrk_("U", "N", &c__2, &c__0, &alpha, a, &c__1, &beta, c__, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ ssyrk_("U", "T", &c__0, &c__2, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ ssyrk_("L", "N", &c__2, &c__0, &alpha, a, &c__1, &beta, c__, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ ssyrk_("L", "T", &c__0, &c__2, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ ssyrk_("U", "N", &c__2, &c__0, &alpha, a, &c__2, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ ssyrk_("U", "T", &c__2, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ ssyrk_("L", "N", &c__2, &c__0, &alpha, a, &c__2, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ ssyrk_("L", "T", &c__2, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L70;
+L60:
+ infoc_1.infot = 1;
+ ssyr2k_("/", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ ssyr2k_("U", "/", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ssyr2k_("U", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ssyr2k_("U", "T", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ssyr2k_("L", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ssyr2k_("L", "T", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ssyr2k_("U", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ssyr2k_("U", "T", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ssyr2k_("L", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ssyr2k_("L", "T", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ ssyr2k_("U", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ ssyr2k_("U", "T", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ ssyr2k_("L", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ ssyr2k_("L", "T", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ssyr2k_("U", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ssyr2k_("U", "T", &c__0, &c__2, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ssyr2k_("L", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ssyr2k_("L", "T", &c__0, &c__2, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ ssyr2k_("U", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ ssyr2k_("U", "T", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ ssyr2k_("L", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ ssyr2k_("L", "T", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+
+L70:
+ if (infoc_1.ok) {
+ io___343.ciunit = *nout;
+ s_wsfe(&io___343);
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ } else {
+ io___344.ciunit = *nout;
+ s_wsfe(&io___344);
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ }
+ return 0;
+
+
+/* End of SCHKE. */
+
+} /* schke_ */
+
+/* Subroutine */ int smake_(char *type__, char *uplo, char *diag, integer *m,
+ integer *n, real *a, integer *nmax, real *aa, integer *lda, logical *
+ reset, real *transl, ftnlen type_len, ftnlen uplo_len, ftnlen
+ diag_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer i__, j;
+ logical gen, tri, sym;
+ integer ibeg, iend;
+ extern doublereal sbeg_(logical *);
+ logical unit, lower, upper;
+
+
+/* Generates values for an M by N matrix A. */
+/* Stores the values in the array AA in the data structure required */
+/* by the routine, with unwanted elements set to rogue value. */
+
+/* TYPE is 'GE', 'SY' or 'TR'. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. External Functions .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --aa;
+
+ /* Function Body */
+ gen = s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0;
+ sym = s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0;
+ tri = s_cmp(type__, "TR", (ftnlen)2, (ftnlen)2) == 0;
+ upper = (sym || tri) && *(unsigned char *)uplo == 'U';
+ lower = (sym || tri) && *(unsigned char *)uplo == 'L';
+ unit = tri && *(unsigned char *)diag == 'U';
+
+/* Generate data in array A. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (gen || upper && i__ <= j || lower && i__ >= j) {
+ a[i__ + j * a_dim1] = sbeg_(reset) + *transl;
+ if (i__ != j) {
+/* Set some elements to zero */
+ if (*n > 3 && j == *n / 2) {
+ a[i__ + j * a_dim1] = 0.f;
+ }
+ if (sym) {
+ a[j + i__ * a_dim1] = a[i__ + j * a_dim1];
+ } else if (tri) {
+ a[j + i__ * a_dim1] = 0.f;
+ }
+ }
+ }
+/* L10: */
+ }
+ if (tri) {
+ a[j + j * a_dim1] += 1.f;
+ }
+ if (unit) {
+ a[j + j * a_dim1] = 1.f;
+ }
+/* L20: */
+ }
+
+/* Store elements in array AS in data structure required by routine. */
+
+ if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1];
+/* L30: */
+ }
+ i__2 = *lda;
+ for (i__ = *m + 1; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = -1e10f;
+/* L40: */
+ }
+/* L50: */
+ }
+ } else if (s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
+ "TR", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ ibeg = 1;
+ if (unit) {
+ iend = j - 1;
+ } else {
+ iend = j;
+ }
+ } else {
+ if (unit) {
+ ibeg = j + 1;
+ } else {
+ ibeg = j;
+ }
+ iend = *n;
+ }
+ i__2 = ibeg - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = -1e10f;
+/* L60: */
+ }
+ i__2 = iend;
+ for (i__ = ibeg; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = a[i__ + j * a_dim1];
+/* L70: */
+ }
+ i__2 = *lda;
+ for (i__ = iend + 1; i__ <= i__2; ++i__) {
+ aa[i__ + (j - 1) * *lda] = -1e10f;
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+ return 0;
+
+/* End of SMAKE. */
+
+} /* smake_ */
+
+/* Subroutine */ int smmch_(char *transa, char *transb, integer *m, integer *
+ n, integer *kk, real *alpha, real *a, integer *lda, real *b, integer *
+ ldb, real *beta, real *c__, integer *ldc, real *ct, real *g, real *cc,
+ integer *ldcc, real *eps, real *err, logical *fatal, integer *nout,
+ logical *mv, ftnlen transa_len, ftnlen transb_len)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
+ " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 EX"
+ "PECTED RESULT COMPU\002,\002TED RESULT\002)";
+ static char fmt_9998[] = "(1x,i7,2g18.6)";
+ static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1,
+ cc_offset, i__1, i__2, i__3;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k;
+ real erri;
+ logical trana, tranb;
+
+ /* Fortran I/O blocks */
+ static cilist io___361 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___362 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___363 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___364 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* Checks the results of the computational tests. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Intrinsic Functions .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --ct;
+ --g;
+ cc_dim1 = *ldcc;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+
+ /* Function Body */
+ trana = *(unsigned char *)transa == 'T' || *(unsigned char *)transa ==
+ 'C';
+ tranb = *(unsigned char *)transb == 'T' || *(unsigned char *)transb ==
+ 'C';
+
+/* Compute expected result, one column at a time, in CT using data */
+/* in A, B and C. */
+/* Compute gauges in G. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ct[i__] = 0.f;
+ g[i__] = 0.f;
+/* L10: */
+ }
+ if (! trana && ! tranb) {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ ct[i__] += a[i__ + k * a_dim1] * b[k + j * b_dim1];
+ g[i__] += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * (
+ r__2 = b[k + j * b_dim1], dabs(r__2));
+/* L20: */
+ }
+/* L30: */
+ }
+ } else if (trana && ! tranb) {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ ct[i__] += a[k + i__ * a_dim1] * b[k + j * b_dim1];
+ g[i__] += (r__1 = a[k + i__ * a_dim1], dabs(r__1)) * (
+ r__2 = b[k + j * b_dim1], dabs(r__2));
+/* L40: */
+ }
+/* L50: */
+ }
+ } else if (! trana && tranb) {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ ct[i__] += a[i__ + k * a_dim1] * b[j + k * b_dim1];
+ g[i__] += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * (
+ r__2 = b[j + k * b_dim1], dabs(r__2));
+/* L60: */
+ }
+/* L70: */
+ }
+ } else if (trana && tranb) {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ ct[i__] += a[k + i__ * a_dim1] * b[j + k * b_dim1];
+ g[i__] += (r__1 = a[k + i__ * a_dim1], dabs(r__1)) * (
+ r__2 = b[j + k * b_dim1], dabs(r__2));
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ct[i__] = *alpha * ct[i__] + *beta * c__[i__ + j * c_dim1];
+ g[i__] = dabs(*alpha) * g[i__] + dabs(*beta) * (r__1 = c__[i__ +
+ j * c_dim1], dabs(r__1));
+/* L100: */
+ }
+
+/* Compute the error ratio for this result. */
+
+ *err = 0.f;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ erri = (r__1 = ct[i__] - cc[i__ + j * cc_dim1], dabs(r__1)) / *
+ eps;
+ if (g[i__] != 0.f) {
+ erri /= g[i__];
+ }
+ *err = dmax(*err,erri);
+ if (*err * sqrt(*eps) >= 1.f) {
+ goto L130;
+ }
+/* L110: */
+ }
+
+/* L120: */
+ }
+
+/* If the loop completes, all results are at least half accurate. */
+ goto L150;
+
+/* Report fatal error. */
+
+L130:
+ *fatal = TRUE_;
+ io___361.ciunit = *nout;
+ s_wsfe(&io___361);
+ e_wsfe();
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*mv) {
+ io___362.ciunit = *nout;
+ s_wsfe(&io___362);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ } else {
+ io___363.ciunit = *nout;
+ s_wsfe(&io___363);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(real)
+ );
+ do_fio(&c__1, (char *)&ct[i__], (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+/* L140: */
+ }
+ if (*n > 1) {
+ io___364.ciunit = *nout;
+ s_wsfe(&io___364);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L150:
+ return 0;
+
+
+/* End of SMMCH. */
+
+} /* smmch_ */
+
+logical lse_(real *ri, real *rj, integer *lr)
+{
+ /* System generated locals */
+ integer i__1;
+ logical ret_val;
+
+ /* Local variables */
+ integer i__;
+
+
+/* Tests if two arrays are identical. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ --rj;
+ --ri;
+
+ /* Function Body */
+ i__1 = *lr;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (ri[i__] != rj[i__]) {
+ goto L20;
+ }
+/* L10: */
+ }
+ ret_val = TRUE_;
+ goto L30;
+L20:
+ ret_val = FALSE_;
+L30:
+ return ret_val;
+
+/* End of LSE. */
+
+} /* lse_ */
+
+logical lseres_(char *type__, char *uplo, integer *m, integer *n, real *aa,
+ real *as, integer *lda, ftnlen type_len, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2;
+ logical ret_val;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer i__, j, ibeg, iend;
+ logical upper;
+
+
+/* Tests if selected elements in two arrays are equal. */
+
+/* TYPE is 'GE' or 'SY'. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ as_dim1 = *lda;
+ as_offset = 1 + as_dim1;
+ as -= as_offset;
+ aa_dim1 = *lda;
+ aa_offset = 1 + aa_dim1;
+ aa -= aa_offset;
+
+ /* Function Body */
+ upper = *(unsigned char *)uplo == 'U';
+ if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *lda;
+ for (i__ = *m + 1; i__ <= i__2; ++i__) {
+ if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) {
+ goto L70;
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ ibeg = 1;
+ iend = j;
+ } else {
+ ibeg = j;
+ iend = *n;
+ }
+ i__2 = ibeg - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) {
+ goto L70;
+ }
+/* L30: */
+ }
+ i__2 = *lda;
+ for (i__ = iend + 1; i__ <= i__2; ++i__) {
+ if (aa[i__ + j * aa_dim1] != as[i__ + j * as_dim1]) {
+ goto L70;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+/* L60: */
+ ret_val = TRUE_;
+ goto L80;
+L70:
+ ret_val = FALSE_;
+L80:
+ return ret_val;
+
+/* End of LSERES. */
+
+} /* lseres_ */
+
+doublereal sbeg_(logical *reset)
+{
+ /* System generated locals */
+ real ret_val;
+
+ /* Local variables */
+ static integer i__, ic, mi;
+
+
+/* Generates random numbers uniformly distributed between -0.5 and 0.5. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Local Scalars .. */
+/* .. Save statement .. */
+/* .. Executable Statements .. */
+ if (*reset) {
+/* Initialize local variables. */
+ mi = 891;
+ i__ = 7;
+ ic = 0;
+ *reset = FALSE_;
+ }
+
+/* The sequence of values of I is bounded between 1 and 999. */
+/* If initial I = 1,2,3,6,7 or 9, the period will be 50. */
+/* If initial I = 4 or 8, the period will be 25. */
+/* If initial I = 5, the period will be 10. */
+/* IC is used to break up the period by skipping 1 value of I in 6. */
+
+ ++ic;
+L10:
+ i__ *= mi;
+ i__ -= i__ / 1000 * 1000;
+ if (ic >= 5) {
+ ic = 0;
+ goto L10;
+ }
+ ret_val = (i__ - 500) / 1001.f;
+ return ret_val;
+
+/* End of SBEG. */
+
+} /* sbeg_ */
+
+doublereal sdiff_(real *x, real *y)
+{
+ /* System generated locals */
+ real ret_val;
+
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Executable Statements .. */
+ ret_val = *x - *y;
+ return ret_val;
+
+/* End of SDIFF. */
+
+} /* sdiff_ */
+
+/* Subroutine */ int chkxer_(char *srnamt, integer *infot, integer *nout,
+ logical *lerr, logical *ok)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ***** ILLEGAL VALUE OF PARAMETER NUMBER"
+ " \002,i2,\002 NOT D\002,\002ETECTED BY \002,a6,\002 *****\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___374 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* Tests whether XERBLA has detected an error when it should. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Executable Statements .. */
+ if (! (*lerr)) {
+ io___374.ciunit = *nout;
+ s_wsfe(&io___374);
+ do_fio(&c__1, (char *)&(*infot), (ftnlen)sizeof(integer));
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ *ok = FALSE_;
+ }
+ *lerr = FALSE_;
+ return 0;
+
+
+/* End of CHKXER. */
+
+} /* chkxer_ */
+
+/* Subroutine */ int xerbla_(char *srname, integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* XERBLA WAS CALLED WITH INFO ="
+ " \002,i6,\002 INSTEAD\002,\002 OF \002,i2,\002 *******\002)";
+ static char fmt_9997[] = "(\002 ******* XERBLA WAS CALLED WITH INFO ="
+ " \002,i6,\002 *******\002)";
+ static char fmt_9998[] = "(\002 ******* XERBLA WAS CALLED WITH SRNAME ="
+ " \002,a6,\002 INSTE\002,\002AD OF \002,a6,\002 *******\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Fortran I/O blocks */
+ static cilist io___375 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___376 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___377 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* This is a special version of XERBLA to be used only as part of */
+/* the test program for testing error exits from the Level 3 BLAS */
+/* routines. */
+
+/* XERBLA is an error handler for the Level 3 BLAS routines. */
+
+/* It is called by the Level 3 BLAS routines if an input parameter is */
+/* invalid. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+ infoc_2.lerr = TRUE_;
+ if (*info != infoc_2.infot) {
+ if (infoc_2.infot != 0) {
+ io___375.ciunit = infoc_2.nout;
+ s_wsfe(&io___375);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&infoc_2.infot, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___376.ciunit = infoc_2.nout;
+ s_wsfe(&io___376);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ infoc_2.ok = FALSE_;
+ }
+ if (s_cmp(srname, srnamc_1.srnamt, (ftnlen)6, (ftnlen)6) != 0) {
+ io___377.ciunit = infoc_2.nout;
+ s_wsfe(&io___377);
+ do_fio(&c__1, srname, (ftnlen)6);
+ do_fio(&c__1, srnamc_1.srnamt, (ftnlen)6);
+ e_wsfe();
+ infoc_2.ok = FALSE_;
+ }
+ return 0;
+
+
+/* End of XERBLA */
+
+} /* xerbla_ */
+
+/* Main program alias */ int sblat3_ () { MAIN__ (); return 0; }
diff --git a/BLAS/TESTING/zblat1.c b/BLAS/TESTING/zblat1.c
new file mode 100644
index 0000000..04c6b1f
--- /dev/null
+++ b/BLAS/TESTING/zblat1.c
@@ -0,0 +1,771 @@
+/* zblat1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer icase, n, incx, incy, mode;
+ logical pass;
+} combla_;
+
+#define combla_1 combla_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__9 = 9;
+static integer c__5 = 5;
+static doublereal c_b43 = 1.;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Initialized data */
+
+ static doublereal sfac = 9.765625e-4;
+
+ /* Format strings */
+ static char fmt_99999[] = "(\002 Complex BLAS Test Program Results\002,/"
+ "1x)";
+ static char fmt_99998[] = "(\002 ----"
+ "- PASS -----\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), e_wsfe(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+
+ /* Local variables */
+ integer ic;
+ extern /* Subroutine */ int check1_(doublereal *), check2_(doublereal *),
+ header_(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___2 = { 0, 6, 0, fmt_99999, 0 };
+ static cilist io___4 = { 0, 6, 0, fmt_99998, 0 };
+
+
+/* Test program for the COMPLEX*16 Level 1 BLAS. */
+/* Based upon the original BLAS test routine together with: */
+/* F06GAF Example Program Text */
+/* .. Parameters .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. External Subroutines .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+ s_wsfe(&io___2);
+ e_wsfe();
+ for (ic = 1; ic <= 10; ++ic) {
+ combla_1.icase = ic;
+ header_();
+
+/* Initialize PASS, INCX, INCY, and MODE for a new case. */
+/* The value 9999 for INCX, INCY or MODE will appear in the */
+/* detailed output, if any, for cases that do not involve */
+/* these parameters. */
+
+ combla_1.pass = TRUE_;
+ combla_1.incx = 9999;
+ combla_1.incy = 9999;
+ combla_1.mode = 9999;
+ if (combla_1.icase <= 5) {
+ check2_(&sfac);
+ } else if (combla_1.icase >= 6) {
+ check1_(&sfac);
+ }
+/* -- Print */
+ if (combla_1.pass) {
+ s_wsfe(&io___4);
+ e_wsfe();
+ }
+/* L20: */
+ }
+ s_stop("", (ftnlen)0);
+
+ return 0;
+} /* MAIN__ */
+
+/* Subroutine */ int header_(void)
+{
+ /* Initialized data */
+
+ static char l[6*10] = "ZDOTC " "ZDOTU " "ZAXPY " "ZCOPY " "ZSWAP " "DZNR"
+ "M2" "DZASUM" "ZSCAL " "ZDSCAL" "IZAMAX";
+
+ /* Format strings */
+ static char fmt_99999[] = "(/\002 Test of subprogram number\002,i3,12x,a"
+ "6)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 6, 0, fmt_99999, 0 };
+
+
+/* .. Parameters .. */
+/* .. Scalars in Common .. */
+/* .. Local Arrays .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+ s_wsfe(&io___6);
+ do_fio(&c__1, (char *)&combla_1.icase, (ftnlen)sizeof(integer));
+ do_fio(&c__1, l + (0 + (0 + (combla_1.icase - 1) * 6)), (ftnlen)6);
+ e_wsfe();
+ return 0;
+
+} /* header_ */
+
+/* Subroutine */ int check1_(doublereal *sfac)
+{
+ /* Initialized data */
+
+ static doublereal strue2[5] = { 0.,.5,.6,.7,.8 };
+ static doublereal strue4[5] = { 0.,.7,1.,1.3,1.6 };
+ static doublecomplex ctrue5[80] /* was [8][5][2] */ = { {.1,.1},{1.,
+ 2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{-.16,-.37},{
+ 3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{-.17,-.19}
+ ,{.13,-.39},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{.11,
+ -.03},{-.17,.46},{-.17,-.19},{7.,8.},{7.,8.},{7.,8.},{7.,8.},{7.,
+ 8.},{.19,-.17},{.2,-.35},{.35,.2},{.14,.08},{2.,3.},{2.,3.},{2.,
+ 3.},{2.,3.},{.1,.1},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{4.,
+ 5.},{4.,5.},{-.16,-.37},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{
+ 6.,7.},{6.,7.},{-.17,-.19},{8.,9.},{.13,-.39},{2.,5.},{2.,5.},{2.,
+ 5.},{2.,5.},{2.,5.},{.11,-.03},{3.,6.},{-.17,.46},{4.,7.},{-.17,
+ -.19},{7.,2.},{7.,2.},{7.,2.},{.19,-.17},{5.,8.},{.2,-.35},{6.,9.}
+ ,{.35,.2},{8.,3.},{.14,.08},{9.,4.} };
+ static doublecomplex ctrue6[80] /* was [8][5][2] */ = { {.1,.1},{1.,
+ 2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{.09,-.12},{
+ 3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{.03,-.09},
+ {.15,-.03},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{.03,
+ .03},{-.18,.03},{.03,-.09},{7.,8.},{7.,8.},{7.,8.},{7.,8.},{7.,8.}
+ ,{.09,.03},{.15,0.},{0.,.15},{0.,.06},{2.,3.},{2.,3.},{2.,3.},{2.,
+ 3.},{.1,.1},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{4.,
+ 5.},{.09,-.12},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{
+ 6.,7.},{.03,-.09},{8.,9.},{.15,-.03},{2.,5.},{2.,5.},{2.,5.},{2.,
+ 5.},{2.,5.},{.03,.03},{3.,6.},{-.18,.03},{4.,7.},{.03,-.09},{7.,
+ 2.},{7.,2.},{7.,2.},{.09,.03},{5.,8.},{.15,0.},{6.,9.},{0.,.15},{
+ 8.,3.},{0.,.06},{9.,4.} };
+ static integer itrue3[5] = { 0,1,2,2,2 };
+ static doublereal sa = .3;
+ static doublecomplex ca = {.4,-.7};
+ static doublecomplex cv[80] /* was [8][5][2] */ = { {.1,.1},{1.,2.},{1.,
+ 2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{1.,2.},{.3,-.4},{3.,4.},{3.,
+ 4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{3.,4.},{.1,-.3},{.5,-.1},{5.,
+ 6.},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{5.,6.},{.1,.1},{-.6,.1},{.1,
+ -.3},{7.,8.},{7.,8.},{7.,8.},{7.,8.},{7.,8.},{.3,.1},{.5,0.},{0.,
+ .5},{0.,.2},{2.,3.},{2.,3.},{2.,3.},{2.,3.},{.1,.1},{4.,5.},{4.,
+ 5.},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{4.,5.},{.3,-.4},{6.,7.},{6.,
+ 7.},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{6.,7.},{.1,-.3},{8.,9.},{.5,
+ -.1},{2.,5.},{2.,5.},{2.,5.},{2.,5.},{2.,5.},{.1,.1},{3.,6.},{-.6,
+ .1},{4.,7.},{.1,-.3},{7.,2.},{7.,2.},{7.,2.},{.3,.1},{5.,8.},{.5,
+ 0.},{6.,9.},{0.,.5},{8.,3.},{0.,.2},{9.,4.} };
+
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_wsle(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ doublecomplex cx[8];
+ integer np1, len;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), ctest_(integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublereal *);
+ doublecomplex mwpcs[5], mwpct[5];
+ extern /* Subroutine */ int itest1_(integer *, integer *);
+ extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int stest1_(doublereal *, doublereal *,
+ doublereal *, doublereal *), zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ extern doublereal dzasum_(integer *, doublecomplex *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___19 = { 0, 6, 0, 0, 0 };
+
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+ for (combla_1.incx = 1; combla_1.incx <= 2; ++combla_1.incx) {
+ for (np1 = 1; np1 <= 5; ++np1) {
+ combla_1.n = np1 - 1;
+ len = max(combla_1.n,1) << 1;
+/* .. Set vector arguments .. */
+ i__1 = len;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ - 1;
+ i__3 = i__ + (np1 + combla_1.incx * 5 << 3) - 49;
+ cx[i__2].r = cv[i__3].r, cx[i__2].i = cv[i__3].i;
+/* L20: */
+ }
+ if (combla_1.icase == 6) {
+/* .. DZNRM2 .. */
+ d__1 = dznrm2_(&combla_1.n, cx, &combla_1.incx);
+ stest1_(&d__1, &strue2[np1 - 1], &strue2[np1 - 1], sfac);
+ } else if (combla_1.icase == 7) {
+/* .. DZASUM .. */
+ d__1 = dzasum_(&combla_1.n, cx, &combla_1.incx);
+ stest1_(&d__1, &strue4[np1 - 1], &strue4[np1 - 1], sfac);
+ } else if (combla_1.icase == 8) {
+/* .. ZSCAL .. */
+ zscal_(&combla_1.n, &ca, cx, &combla_1.incx);
+ ctest_(&len, cx, &ctrue5[(np1 + combla_1.incx * 5 << 3) - 48],
+ &ctrue5[(np1 + combla_1.incx * 5 << 3) - 48], sfac);
+ } else if (combla_1.icase == 9) {
+/* .. ZDSCAL .. */
+ zdscal_(&combla_1.n, &sa, cx, &combla_1.incx);
+ ctest_(&len, cx, &ctrue6[(np1 + combla_1.incx * 5 << 3) - 48],
+ &ctrue6[(np1 + combla_1.incx * 5 << 3) - 48], sfac);
+ } else if (combla_1.icase == 10) {
+/* .. IZAMAX .. */
+ i__1 = izamax_(&combla_1.n, cx, &combla_1.incx);
+ itest1_(&i__1, &itrue3[np1 - 1]);
+ } else {
+ s_wsle(&io___19);
+ do_lio(&c__9, &c__1, " Shouldn't be here in CHECK1", (ftnlen)
+ 28);
+ e_wsle();
+ s_stop("", (ftnlen)0);
+ }
+
+/* L40: */
+ }
+/* L60: */
+ }
+
+ combla_1.incx = 1;
+ if (combla_1.icase == 8) {
+/* ZSCAL */
+/* Add a test for alpha equal to zero. */
+ ca.r = 0., ca.i = 0.;
+ for (i__ = 1; i__ <= 5; ++i__) {
+ i__1 = i__ - 1;
+ mwpct[i__1].r = 0., mwpct[i__1].i = 0.;
+ i__1 = i__ - 1;
+ mwpcs[i__1].r = 1., mwpcs[i__1].i = 1.;
+/* L80: */
+ }
+ zscal_(&c__5, &ca, cx, &combla_1.incx);
+ ctest_(&c__5, cx, mwpct, mwpcs, sfac);
+ } else if (combla_1.icase == 9) {
+/* ZDSCAL */
+/* Add a test for alpha equal to zero. */
+ sa = 0.;
+ for (i__ = 1; i__ <= 5; ++i__) {
+ i__1 = i__ - 1;
+ mwpct[i__1].r = 0., mwpct[i__1].i = 0.;
+ i__1 = i__ - 1;
+ mwpcs[i__1].r = 1., mwpcs[i__1].i = 1.;
+/* L100: */
+ }
+ zdscal_(&c__5, &sa, cx, &combla_1.incx);
+ ctest_(&c__5, cx, mwpct, mwpcs, sfac);
+/* Add a test for alpha equal to one. */
+ sa = 1.;
+ for (i__ = 1; i__ <= 5; ++i__) {
+ i__1 = i__ - 1;
+ i__2 = i__ - 1;
+ mwpct[i__1].r = cx[i__2].r, mwpct[i__1].i = cx[i__2].i;
+ i__1 = i__ - 1;
+ i__2 = i__ - 1;
+ mwpcs[i__1].r = cx[i__2].r, mwpcs[i__1].i = cx[i__2].i;
+/* L120: */
+ }
+ zdscal_(&c__5, &sa, cx, &combla_1.incx);
+ ctest_(&c__5, cx, mwpct, mwpcs, sfac);
+/* Add a test for alpha equal to minus one. */
+ sa = -1.;
+ for (i__ = 1; i__ <= 5; ++i__) {
+ i__1 = i__ - 1;
+ i__2 = i__ - 1;
+ z__1.r = -cx[i__2].r, z__1.i = -cx[i__2].i;
+ mwpct[i__1].r = z__1.r, mwpct[i__1].i = z__1.i;
+ i__1 = i__ - 1;
+ i__2 = i__ - 1;
+ z__1.r = -cx[i__2].r, z__1.i = -cx[i__2].i;
+ mwpcs[i__1].r = z__1.r, mwpcs[i__1].i = z__1.i;
+/* L140: */
+ }
+ zdscal_(&c__5, &sa, cx, &combla_1.incx);
+ ctest_(&c__5, cx, mwpct, mwpcs, sfac);
+ }
+ return 0;
+} /* check1_ */
+
+/* Subroutine */ int check2_(doublereal *sfac)
+{
+ /* Initialized data */
+
+ static doublecomplex ca = {.4,-.7};
+ static integer incxs[4] = { 1,2,-2,-1 };
+ static integer incys[4] = { 1,-2,1,-2 };
+ static integer lens[8] /* was [4][2] */ = { 1,1,2,4,1,1,3,7 };
+ static integer ns[4] = { 0,1,2,4 };
+ static doublecomplex cx1[7] = { {.7,-.8},{-.4,-.7},{-.1,-.9},{.2,-.8},{
+ -.9,-.4},{.1,.4},{-.6,.6} };
+ static doublecomplex cy1[7] = { {.6,-.6},{-.9,.5},{.7,-.6},{.1,-.5},{-.1,
+ -.2},{-.5,-.3},{.8,-.7} };
+ static doublecomplex ct8[112] /* was [7][4][4] */ = { {.6,-.6},{0.,
+ 0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.32,-1.41},{0.,0.},{
+ 0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.32,-1.41},{-1.55,.5},{0.,
+ 0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.32,-1.41},{-1.55,.5},{.03,
+ -.89},{-.38,-.96},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{0.,0.}
+ ,{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.32,-1.41},{0.,0.},{0.,0.},{0.,
+ 0.},{0.,0.},{0.,0.},{0.,0.},{-.07,-.89},{-.9,.5},{.42,-1.41},{0.,
+ 0.},{0.,0.},{0.,0.},{0.,0.},{.78,.06},{-.9,.5},{.06,-.13},{.1,-.5}
+ ,{-.77,-.49},{-.5,-.3},{.52,-1.51},{.6,-.6},{0.,0.},{0.,0.},{0.,
+ 0.},{0.,0.},{0.,0.},{0.,0.},{.32,-1.41},{0.,0.},{0.,0.},{0.,0.},{
+ 0.,0.},{0.,0.},{0.,0.},{-.07,-.89},{-1.18,-.31},{0.,0.},{0.,0.},{
+ 0.,0.},{0.,0.},{0.,0.},{.78,.06},{-1.54,.97},{.03,-.89},{-.18,
+ -1.31},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{
+ 0.,0.},{0.,0.},{0.,0.},{.32,-1.41},{0.,0.},{0.,0.},{0.,0.},{0.,0.}
+ ,{0.,0.},{0.,0.},{.32,-1.41},{-.9,.5},{.05,-.6},{0.,0.},{0.,0.},{
+ 0.,0.},{0.,0.},{.32,-1.41},{-.9,.5},{.05,-.6},{.1,-.5},{-.77,-.49}
+ ,{-.5,-.3},{.32,-1.16} };
+ static doublecomplex ct7[16] /* was [4][4] */ = { {0.,0.},{-.06,
+ -.9},{.65,-.47},{-.34,-1.22},{0.,0.},{-.06,-.9},{-.59,-1.46},{
+ -1.04,-.04},{0.,0.},{-.06,-.9},{-.83,.59},{.07,-.37},{0.,0.},{
+ -.06,-.9},{-.76,-1.15},{-1.33,-1.82} };
+ static doublecomplex ct6[16] /* was [4][4] */ = { {0.,0.},{.9,.06},
+ {.91,-.77},{1.8,-.1},{0.,0.},{.9,.06},{1.45,.74},{.2,.9},{0.,0.},{
+ .9,.06},{-.55,.23},{.83,-.39},{0.,0.},{.9,.06},{1.04,.79},{1.95,
+ 1.22} };
+ static doublecomplex ct10x[112] /* was [7][4][4] */ = { {.7,-.8},{0.,
+ 0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{0.,
+ 0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{-.9,.5},{0.,0.},{0.,
+ 0.},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{-.9,.5},{.7,-.6},{.1,-.5},{
+ 0.,0.},{0.,0.},{0.,0.},{.7,-.8},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{
+ 0.,0.},{0.,0.},{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{
+ 0.,0.},{.7,-.6},{-.4,-.7},{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{0.,0.}
+ ,{.8,-.7},{-.4,-.7},{-.1,-.2},{.2,-.8},{.7,-.6},{.1,.4},{.6,-.6},{
+ .7,-.8},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{
+ 0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{-.9,.5},{-.4,-.7},
+ {.6,-.6},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.1,-.5},{-.4,-.7},{.7,
+ -.6},{.2,-.8},{-.9,.5},{.1,.4},{.6,-.6},{.7,-.8},{0.,0.},{0.,0.},{
+ 0.,0.},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{
+ 0.,0.},{0.,0.},{0.,0.},{.6,-.6},{.7,-.6},{0.,0.},{0.,0.},{0.,0.},{
+ 0.,0.},{0.,0.},{.6,-.6},{.7,-.6},{-.1,-.2},{.8,-.7},{0.,0.},{0.,
+ 0.},{0.,0.} };
+ static doublecomplex ct10y[112] /* was [7][4][4] */ = { {.6,-.6},{0.,
+ 0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{0.,0.},{0.,
+ 0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{-.4,-.7},{0.,0.},{
+ 0.,0.},{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{-.4,-.7},{-.1,-.9},{.2,
+ -.8},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{0.,
+ 0.},{0.,0.},{0.,0.},{.7,-.8},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,
+ 0.},{0.,0.},{-.1,-.9},{-.9,.5},{.7,-.8},{0.,0.},{0.,0.},{0.,0.},{
+ 0.,0.},{-.6,.6},{-.9,.5},{-.9,-.4},{.1,-.5},{-.1,-.9},{-.5,-.3},{
+ .7,-.8},{.6,-.6},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{
+ .7,-.8},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{-.1,-.9},
+ {.7,-.8},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{-.6,.6},{-.9,
+ -.4},{-.1,-.9},{.7,-.8},{0.,0.},{0.,0.},{0.,0.},{.6,-.6},{0.,0.},{
+ 0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{0.,0.},{0.,0.},{
+ 0.,0.},{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{-.9,.5},{-.4,-.7},{0.,0.}
+ ,{0.,0.},{0.,0.},{0.,0.},{.7,-.8},{-.9,.5},{-.4,-.7},{.1,-.5},{
+ -.1,-.9},{-.5,-.3},{.2,-.8} };
+ static doublecomplex csize1[4] = { {0.,0.},{.9,.9},{1.63,1.73},{2.9,2.78}
+ };
+ static doublecomplex csize3[14] = { {0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,
+ 0.},{0.,0.},{0.,0.},{1.17,1.17},{1.17,1.17},{1.17,1.17},{1.17,
+ 1.17},{1.17,1.17},{1.17,1.17},{1.17,1.17} };
+ static doublecomplex csize2[14] /* was [7][2] */ = { {0.,0.},{0.,0.},{
+ 0.,0.},{0.,0.},{0.,0.},{0.,0.},{0.,0.},{1.54,1.54},{1.54,1.54},{
+ 1.54,1.54},{1.54,1.54},{1.54,1.54},{1.54,1.54},{1.54,1.54} };
+
+ /* System generated locals */
+ integer i__1, i__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_wsle(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+
+ /* Local variables */
+ integer i__, ki, kn;
+ doublecomplex cx[7], cy[7];
+ integer mx, my;
+ doublecomplex cdot[1];
+ integer lenx, leny;
+ extern /* Subroutine */ int ctest_(integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublereal *);
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ integer ksize;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern /* Double Complex */ VOID zdotu_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___48 = { 0, 6, 0, 0, 0 };
+
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+ for (ki = 1; ki <= 4; ++ki) {
+ combla_1.incx = incxs[ki - 1];
+ combla_1.incy = incys[ki - 1];
+ mx = abs(combla_1.incx);
+ my = abs(combla_1.incy);
+
+ for (kn = 1; kn <= 4; ++kn) {
+ combla_1.n = ns[kn - 1];
+ ksize = min(2,kn);
+ lenx = lens[kn + (mx << 2) - 5];
+ leny = lens[kn + (my << 2) - 5];
+/* .. initialize all argument arrays .. */
+ for (i__ = 1; i__ <= 7; ++i__) {
+ i__1 = i__ - 1;
+ i__2 = i__ - 1;
+ cx[i__1].r = cx1[i__2].r, cx[i__1].i = cx1[i__2].i;
+ i__1 = i__ - 1;
+ i__2 = i__ - 1;
+ cy[i__1].r = cy1[i__2].r, cy[i__1].i = cy1[i__2].i;
+/* L20: */
+ }
+ if (combla_1.icase == 1) {
+/* .. ZDOTC .. */
+ zdotc_(&z__1, &combla_1.n, cx, &combla_1.incx, cy, &
+ combla_1.incy);
+ cdot[0].r = z__1.r, cdot[0].i = z__1.i;
+ ctest_(&c__1, cdot, &ct6[kn + (ki << 2) - 5], &csize1[kn - 1],
+ sfac);
+ } else if (combla_1.icase == 2) {
+/* .. ZDOTU .. */
+ zdotu_(&z__1, &combla_1.n, cx, &combla_1.incx, cy, &
+ combla_1.incy);
+ cdot[0].r = z__1.r, cdot[0].i = z__1.i;
+ ctest_(&c__1, cdot, &ct7[kn + (ki << 2) - 5], &csize1[kn - 1],
+ sfac);
+ } else if (combla_1.icase == 3) {
+/* .. ZAXPY .. */
+ zaxpy_(&combla_1.n, &ca, cx, &combla_1.incx, cy, &
+ combla_1.incy);
+ ctest_(&leny, cy, &ct8[(kn + (ki << 2)) * 7 - 35], &csize2[
+ ksize * 7 - 7], sfac);
+ } else if (combla_1.icase == 4) {
+/* .. ZCOPY .. */
+ zcopy_(&combla_1.n, cx, &combla_1.incx, cy, &combla_1.incy);
+ ctest_(&leny, cy, &ct10y[(kn + (ki << 2)) * 7 - 35], csize3, &
+ c_b43);
+ } else if (combla_1.icase == 5) {
+/* .. ZSWAP .. */
+ zswap_(&combla_1.n, cx, &combla_1.incx, cy, &combla_1.incy);
+ ctest_(&lenx, cx, &ct10x[(kn + (ki << 2)) * 7 - 35], csize3, &
+ c_b43);
+ ctest_(&leny, cy, &ct10y[(kn + (ki << 2)) * 7 - 35], csize3, &
+ c_b43);
+ } else {
+ s_wsle(&io___48);
+ do_lio(&c__9, &c__1, " Shouldn't be here in CHECK2", (ftnlen)
+ 28);
+ e_wsle();
+ s_stop("", (ftnlen)0);
+ }
+
+/* L40: */
+ }
+/* L60: */
+ }
+ return 0;
+} /* check2_ */
+
+/* Subroutine */ int stest_(integer *len, doublereal *scomp, doublereal *
+ strue, doublereal *ssize, doublereal *sfac)
+{
+ /* Format strings */
+ static char fmt_99999[] = "(\002 F"
+ "AIL\002)";
+ static char fmt_99998[] = "(/\002 CASE N INCX INCY MODE I "
+ " \002,\002 COMP(I) TRU"
+ "E(I) DIFFERENCE\002,\002 SIZE(I)\002,/1x)";
+ static char fmt_99997[] = "(1x,i4,i3,3i5,i3,2d36.8,2d12.4)";
+
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2, d__3, d__4, d__5;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ doublereal sd;
+ extern doublereal sdiff_(doublereal *, doublereal *);
+
+ /* Fortran I/O blocks */
+ static cilist io___51 = { 0, 6, 0, fmt_99999, 0 };
+ static cilist io___52 = { 0, 6, 0, fmt_99998, 0 };
+ static cilist io___53 = { 0, 6, 0, fmt_99997, 0 };
+
+
+/* ********************************* STEST ************************** */
+
+/* THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO */
+/* SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE */
+/* NEGLIGIBLE. */
+
+/* C. L. LAWSON, JPL, 1974 DEC 10 */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. External Functions .. */
+/* .. Intrinsic Functions .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ssize;
+ --strue;
+ --scomp;
+
+ /* Function Body */
+ i__1 = *len;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sd = scomp[i__] - strue[i__];
+ d__4 = (d__1 = ssize[i__], abs(d__1)) + (d__2 = *sfac * sd, abs(d__2))
+ ;
+ d__5 = (d__3 = ssize[i__], abs(d__3));
+ if (sdiff_(&d__4, &d__5) == 0.) {
+ goto L40;
+ }
+
+/* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I). */
+
+ if (! combla_1.pass) {
+ goto L20;
+ }
+/* PRINT FAIL MESSAGE AND HEADER. */
+ combla_1.pass = FALSE_;
+ s_wsfe(&io___51);
+ e_wsfe();
+ s_wsfe(&io___52);
+ e_wsfe();
+L20:
+ s_wsfe(&io___53);
+ do_fio(&c__1, (char *)&combla_1.icase, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.incy, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.mode, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&scomp[i__], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&strue[i__], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&sd, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&ssize[i__], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+L40:
+ ;
+ }
+ return 0;
+
+} /* stest_ */
+
+/* Subroutine */ int stest1_(doublereal *scomp1, doublereal *strue1,
+ doublereal *ssize, doublereal *sfac)
+{
+ doublereal scomp[1], strue[1];
+ extern /* Subroutine */ int stest_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *);
+
+/* ************************* STEST1 ***************************** */
+
+/* THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN */
+/* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE */
+/* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT. */
+
+/* C.L. LAWSON, JPL, 1978 DEC 6 */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Arrays .. */
+/* .. External Subroutines .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ssize;
+
+ /* Function Body */
+ scomp[0] = *scomp1;
+ strue[0] = *strue1;
+ stest_(&c__1, scomp, strue, &ssize[1], sfac);
+
+ return 0;
+} /* stest1_ */
+
+doublereal sdiff_(doublereal *sa, doublereal *sb)
+{
+ /* System generated locals */
+ doublereal ret_val;
+
+/* ********************************* SDIFF ************************** */
+/* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 */
+
+/* .. Scalar Arguments .. */
+/* .. Executable Statements .. */
+ ret_val = *sa - *sb;
+ return ret_val;
+} /* sdiff_ */
+
+/* Subroutine */ int ctest_(integer *len, doublecomplex *ccomp, doublecomplex
+ *ctrue, doublecomplex *csize, doublereal *sfac)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__;
+ doublereal scomp[20], ssize[20], strue[20];
+ extern /* Subroutine */ int stest_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *);
+
+/* **************************** CTEST ***************************** */
+
+/* C.L. LAWSON, JPL, 1978 DEC 6 */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ --csize;
+ --ctrue;
+ --ccomp;
+
+ /* Function Body */
+ i__1 = *len;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ scomp[(i__ << 1) - 2] = ccomp[i__2].r;
+ scomp[(i__ << 1) - 1] = d_imag(&ccomp[i__]);
+ i__2 = i__;
+ strue[(i__ << 1) - 2] = ctrue[i__2].r;
+ strue[(i__ << 1) - 1] = d_imag(&ctrue[i__]);
+ i__2 = i__;
+ ssize[(i__ << 1) - 2] = csize[i__2].r;
+ ssize[(i__ << 1) - 1] = d_imag(&csize[i__]);
+/* L20: */
+ }
+
+ i__1 = *len << 1;
+ stest_(&i__1, scomp, strue, ssize, sfac);
+ return 0;
+} /* ctest_ */
+
+/* Subroutine */ int itest1_(integer *icomp, integer *itrue)
+{
+ /* Format strings */
+ static char fmt_99999[] = "(\002 F"
+ "AIL\002)";
+ static char fmt_99998[] = "(/\002 CASE N INCX INCY MODE "
+ " \002,\002 COMP TRU"
+ "E DIFFERENCE\002,/1x)";
+ static char fmt_99997[] = "(1x,i4,i3,3i5,2i36,i12)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer id;
+
+ /* Fortran I/O blocks */
+ static cilist io___60 = { 0, 6, 0, fmt_99999, 0 };
+ static cilist io___61 = { 0, 6, 0, fmt_99998, 0 };
+ static cilist io___63 = { 0, 6, 0, fmt_99997, 0 };
+
+
+/* ********************************* ITEST1 ************************* */
+
+/* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR */
+/* EQUALITY. */
+/* C. L. LAWSON, JPL, 1974 DEC 10 */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+ if (*icomp == *itrue) {
+ goto L40;
+ }
+
+/* HERE ICOMP IS NOT EQUAL TO ITRUE. */
+
+ if (! combla_1.pass) {
+ goto L20;
+ }
+/* PRINT FAIL MESSAGE AND HEADER. */
+ combla_1.pass = FALSE_;
+ s_wsfe(&io___60);
+ e_wsfe();
+ s_wsfe(&io___61);
+ e_wsfe();
+L20:
+ id = *icomp - *itrue;
+ s_wsfe(&io___63);
+ do_fio(&c__1, (char *)&combla_1.icase, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.incy, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&combla_1.mode, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*icomp), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*itrue), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&id, (ftnlen)sizeof(integer));
+ e_wsfe();
+L40:
+ return 0;
+
+} /* itest1_ */
+
+/* Main program alias */ int zblat1_ () { MAIN__ (); return 0; }
diff --git a/BLAS/TESTING/zblat2.c b/BLAS/TESTING/zblat2.c
new file mode 100644
index 0000000..09a9cb8
--- /dev/null
+++ b/BLAS/TESTING/zblat2.c
@@ -0,0 +1,5399 @@
+/* zblat2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+union {
+ struct {
+ integer infot, noutc;
+ logical ok, lerr;
+ } _1;
+ struct {
+ integer infot, nout;
+ logical ok, lerr;
+ } _2;
+} infoc_;
+
+#define infoc_1 (infoc_._1)
+#define infoc_2 (infoc_._2)
+
+struct {
+ char srnamt[6];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__9 = 9;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__8 = 8;
+static integer c__5 = 5;
+static integer c__65 = 65;
+static integer c__7 = 7;
+static integer c__2 = 2;
+static doublereal c_b123 = 1.;
+static logical c_true = TRUE_;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static logical c_false = FALSE_;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Initialized data */
+
+ static char snames[6*17] = "ZGEMV " "ZGBMV " "ZHEMV " "ZHBMV " "ZHPMV "
+ "ZTRMV " "ZTBMV " "ZTPMV " "ZTRSV " "ZTBSV " "ZTPSV " "ZGERC "
+ "ZGERU " "ZHER " "ZHPR " "ZHER2 " "ZHPR2 ";
+
+ /* Format strings */
+ static char fmt_9997[] = "(\002 NUMBER OF VALUES OF \002,a,\002 IS LESS "
+ "THAN 1 OR GREATER \002,\002THAN \002,i2)";
+ static char fmt_9996[] = "(\002 VALUE OF N IS LESS THAN 0 OR GREATER THA"
+ "N \002,i2)";
+ static char fmt_9995[] = "(\002 VALUE OF K IS LESS THAN 0\002)";
+ static char fmt_9994[] = "(\002 ABSOLUTE VALUE OF INCX OR INCY IS 0 OR G"
+ "REATER THAN \002,i2)";
+ static char fmt_9993[] = "(\002 TESTS OF THE COMPLEX*16 LEVEL 2 BL"
+ "AS\002,//\002 THE F\002,\002OLLOWING PARAMETER VALUES WILL BE US"
+ "ED:\002)";
+ static char fmt_9992[] = "(\002 FOR N \002,9i6)";
+ static char fmt_9991[] = "(\002 FOR K \002,7i6)";
+ static char fmt_9990[] = "(\002 FOR INCX AND INCY \002,7i6)";
+ static char fmt_9989[] = "(\002 FOR ALPHA \002,7(\002(\002,f4"
+ ".1,\002,\002,f4.1,\002) \002,:))";
+ static char fmt_9988[] = "(\002 FOR BETA \002,7(\002(\002,f4"
+ ".1,\002,\002,f4.1,\002) \002,:))";
+ static char fmt_9980[] = "(\002 ERROR-EXITS WILL NOT BE TESTED\002)";
+ static char fmt_9999[] = "(\002 ROUTINES PASS COMPUTATIONAL TESTS IF TES"
+ "T RATIO IS LES\002,\002S THAN\002,f8.2)";
+ static char fmt_9984[] = "(a6,l2)";
+ static char fmt_9986[] = "(\002 SUBPROGRAM NAME \002,a6,\002 NOT RECOGNI"
+ "ZED\002,/\002 ******* T\002,\002ESTS ABANDONED *******\002)";
+ static char fmt_9998[] = "(\002 RELATIVE MACHINE PRECISION IS TAKEN TO"
+ " BE\002,1p,d9.1)";
+ static char fmt_9985[] = "(\002 ERROR IN ZMVCH - IN-LINE DOT PRODUCTS A"
+ "RE BEING EVALU\002,\002ATED WRONGLY.\002,/\002 ZMVCH WAS CALLED "
+ "WITH TRANS = \002,a1,\002 AND RETURNED SAME = \002,l1,\002 AND E"
+ "RR = \002,f12.3,\002.\002,/\002 THIS MAY BE DUE TO FAULTS IN THE"
+ " ARITHMETIC OR THE COMPILER.\002,/\002 ******* TESTS ABANDONED *"
+ "******\002)";
+ static char fmt_9983[] = "(1x,a6,\002 WAS NOT TESTED\002)";
+ static char fmt_9982[] = "(/\002 END OF TESTS\002)";
+ static char fmt_9981[] = "(/\002 ******* FATAL ERROR - TESTS ABANDONED *"
+ "******\002)";
+ static char fmt_9987[] = "(\002 AMEND DATA FILE OR INCREASE ARRAY SIZES "
+ "IN PROGRAM\002,/\002 ******* TESTS ABANDONED *******\002)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1;
+ olist o__1;
+ cllist cl__1;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void), f_open(olist *), s_wsfe(cilist *), do_fio(integer *,
+ char *, ftnlen), e_wsfe(void), s_wsle(cilist *), e_wsle(void),
+ s_rsfe(cilist *), e_rsfe(void), s_cmp(char *, char *, ftnlen,
+ ftnlen);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+ integer f_clos(cllist *);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublecomplex a[4225] /* was [65][65] */;
+ doublereal g[65];
+ integer i__, j, n;
+ doublecomplex x[65], y[65], z__[130], aa[4225];
+ integer kb[7];
+ doublecomplex as[4225], xs[130], ys[130], yt[65], xx[130], yy[130], alf[7]
+ ;
+ integer inc[7], nkb;
+ doublecomplex bet[7];
+ doublereal eps, err;
+ extern logical lze_(doublecomplex *, doublecomplex *, integer *);
+ integer nalf, idim[9];
+ logical same;
+ integer ninc, nbet, ntra;
+ logical rewi;
+ integer nout;
+ extern /* Subroutine */ int zchk1_(char *, doublereal *, doublereal *,
+ integer *, integer *, logical *, logical *, logical *, integer *,
+ integer *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+ , doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
+ ftnlen), zchk2_(char *, doublereal *, doublereal *, integer *,
+ integer *, logical *, logical *, logical *, integer *, integer *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+ , doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
+ ftnlen), zchk3_(char *, doublereal *, doublereal *, integer *,
+ integer *, logical *, logical *, logical *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+ , doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
+ doublecomplex *, ftnlen), zchk4_(char *, doublereal *,
+ doublereal *, integer *, integer *, logical *, logical *, logical
+ *, integer *, integer *, integer *, doublecomplex *, integer *,
+ integer *, integer *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex
+ *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublereal *, doublecomplex *, ftnlen), zchk5_(
+ char *, doublereal *, doublereal *, integer *, integer *, logical
+ *, logical *, logical *, integer *, integer *, integer *,
+ doublecomplex *, integer *, integer *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+ , doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
+ doublecomplex *, ftnlen), zchk6_(char *, doublereal *, doublereal
+ *, integer *, integer *, logical *, logical *, logical *, integer
+ *, integer *, integer *, doublecomplex *, integer *, integer *,
+ integer *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+ , doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublereal *, doublecomplex *, ftnlen);
+ extern doublereal ddiff_(doublereal *, doublereal *);
+ logical fatal, trace;
+ integer nidim;
+ extern /* Subroutine */ int zchke_(integer *, char *, integer *, ftnlen);
+ char snaps[32], trans[1];
+ extern /* Subroutine */ int zmvch_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublereal *, doublecomplex *, doublereal *,
+ doublereal *, logical *, integer *, logical *, ftnlen);
+ integer isnum;
+ logical ltest[17], sfatal;
+ char snamet[6];
+ doublereal thresh;
+ logical ltestt, tsterr;
+ char summry[32];
+
+ /* Fortran I/O blocks */
+ static cilist io___2 = { 0, 5, 0, 0, 0 };
+ static cilist io___4 = { 0, 5, 0, 0, 0 };
+ static cilist io___6 = { 0, 5, 0, 0, 0 };
+ static cilist io___8 = { 0, 5, 0, 0, 0 };
+ static cilist io___11 = { 0, 5, 0, 0, 0 };
+ static cilist io___13 = { 0, 5, 0, 0, 0 };
+ static cilist io___15 = { 0, 5, 0, 0, 0 };
+ static cilist io___17 = { 0, 5, 0, 0, 0 };
+ static cilist io___19 = { 0, 5, 0, 0, 0 };
+ static cilist io___21 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___22 = { 0, 5, 0, 0, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___26 = { 0, 5, 0, 0, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___29 = { 0, 5, 0, 0, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___32 = { 0, 5, 0, 0, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___35 = { 0, 5, 0, 0, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___38 = { 0, 5, 0, 0, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___41 = { 0, 5, 0, 0, 0 };
+ static cilist io___43 = { 0, 5, 0, 0, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___46 = { 0, 5, 0, 0, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9988, 0 };
+ static cilist io___54 = { 0, 0, 0, 0, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9980, 0 };
+ static cilist io___56 = { 0, 0, 0, 0, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___58 = { 0, 0, 0, 0, 0 };
+ static cilist io___60 = { 0, 5, 1, fmt_9984, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9986, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9985, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9985, 0 };
+ static cilist io___81 = { 0, 0, 0, 0, 0 };
+ static cilist io___82 = { 0, 0, 0, fmt_9983, 0 };
+ static cilist io___83 = { 0, 0, 0, 0, 0 };
+ static cilist io___90 = { 0, 0, 0, fmt_9982, 0 };
+ static cilist io___91 = { 0, 0, 0, fmt_9981, 0 };
+ static cilist io___92 = { 0, 0, 0, fmt_9987, 0 };
+
+
+
+/* Test program for the COMPLEX*16 Level 2 Blas. */
+
+/* The program must be driven by a short data file. The first 18 records */
+/* of the file are read using list-directed input, the last 17 records */
+/* are read using the format ( A6, L2 ). An annotated example of a data */
+/* file can be obtained by deleting the first 3 characters from the */
+/* following 35 lines: */
+/* 'zblat2.out' NAME OF SUMMARY OUTPUT FILE */
+/* 6 UNIT NUMBER OF SUMMARY FILE */
+/* 'CBLA2T.SNAP' NAME OF SNAPSHOT OUTPUT FILE */
+/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */
+/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */
+/* F LOGICAL FLAG, T TO STOP ON FAILURES. */
+/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */
+/* 16.0 THRESHOLD VALUE OF TEST RATIO */
+/* 6 NUMBER OF VALUES OF N */
+/* 0 1 2 3 5 9 VALUES OF N */
+/* 4 NUMBER OF VALUES OF K */
+/* 0 1 2 4 VALUES OF K */
+/* 4 NUMBER OF VALUES OF INCX AND INCY */
+/* 1 2 -1 -2 VALUES OF INCX AND INCY */
+/* 3 NUMBER OF VALUES OF ALPHA */
+/* (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA */
+/* 3 NUMBER OF VALUES OF BETA */
+/* (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA */
+/* ZGEMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZGBMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZHEMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZHBMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZHPMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZTRMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZTBMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZTPMV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZTRSV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZTBSV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZTPSV T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZGERC T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZGERU T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZHER T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZHPR T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZHER2 T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZHPR2 T PUT F FOR NO TEST. SAME COLUMNS. */
+
+/* See: */
+
+/* Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J.. */
+/* An extended set of Fortran Basic Linear Algebra Subprograms. */
+
+/* Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics */
+/* and Computer Science Division, Argonne National Laboratory, */
+/* 9700 South Cass Avenue, Argonne, Illinois 60439, US. */
+
+/* Or */
+
+/* NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms */
+/* Group Ltd., NAG Central Office, 256 Banbury Road, Oxford */
+/* OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st */
+/* Street, Suite 100, Downers Grove, Illinois 60515-1263, USA. */
+
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers */
+/* can be run multiple times without deleting generated */
+/* output files (susan) */
+
+/* .. Parameters .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+
+/* Read name and unit number for summary output file and open file. */
+
+ s_rsle(&io___2);
+ do_lio(&c__9, &c__1, summry, (ftnlen)32);
+ e_rsle();
+ s_rsle(&io___4);
+ do_lio(&c__3, &c__1, (char *)&nout, (ftnlen)sizeof(integer));
+ e_rsle();
+ o__1.oerr = 0;
+ o__1.ounit = nout;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = summry;
+ o__1.orl = 0;
+ o__1.osta = "UNKNOWN";
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);
+ infoc_1.noutc = nout;
+
+/* Read name and unit number for snapshot output file and open file. */
+
+ s_rsle(&io___6);
+ do_lio(&c__9, &c__1, snaps, (ftnlen)32);
+ e_rsle();
+ s_rsle(&io___8);
+ do_lio(&c__3, &c__1, (char *)&ntra, (ftnlen)sizeof(integer));
+ e_rsle();
+ trace = ntra >= 0;
+ if (trace) {
+ o__1.oerr = 0;
+ o__1.ounit = ntra;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = snaps;
+ o__1.orl = 0;
+ o__1.osta = "UNKNOWN";
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);
+ }
+/* Read the flag that directs rewinding of the snapshot file. */
+ s_rsle(&io___11);
+ do_lio(&c__8, &c__1, (char *)&rewi, (ftnlen)sizeof(logical));
+ e_rsle();
+ rewi = rewi && trace;
+/* Read the flag that directs stopping on any failure. */
+ s_rsle(&io___13);
+ do_lio(&c__8, &c__1, (char *)&sfatal, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the flag that indicates whether error exits are to be tested. */
+ s_rsle(&io___15);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the threshold value of the test ratio */
+ s_rsle(&io___17);
+ do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_rsle();
+
+/* Read and check the parameter values for the tests. */
+
+/* Values of N */
+ s_rsle(&io___19);
+ do_lio(&c__3, &c__1, (char *)&nidim, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nidim < 1 || nidim > 9) {
+ io___21.ciunit = nout;
+ s_wsfe(&io___21);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+ s_rsle(&io___22);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {
+ io___25.ciunit = nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, (char *)&c__65, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+/* L10: */
+ }
+/* Values of K */
+ s_rsle(&io___26);
+ do_lio(&c__3, &c__1, (char *)&nkb, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nkb < 1 || nkb > 7) {
+ io___28.ciunit = nout;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "K", (ftnlen)1);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+ s_rsle(&io___29);
+ i__1 = nkb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&kb[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nkb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (kb[i__ - 1] < 0) {
+ io___31.ciunit = nout;
+ s_wsfe(&io___31);
+ e_wsfe();
+ goto L230;
+ }
+/* L20: */
+ }
+/* Values of INCX and INCY */
+ s_rsle(&io___32);
+ do_lio(&c__3, &c__1, (char *)&ninc, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (ninc < 1 || ninc > 7) {
+ io___34.ciunit = nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "INCX AND INCY", (ftnlen)13);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+ s_rsle(&io___35);
+ i__1 = ninc;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&inc[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = ninc;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (inc[i__ - 1] == 0 || (i__2 = inc[i__ - 1], abs(i__2)) > 2) {
+ io___37.ciunit = nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+/* L30: */
+ }
+/* Values of ALPHA */
+ s_rsle(&io___38);
+ do_lio(&c__3, &c__1, (char *)&nalf, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nalf < 1 || nalf > 7) {
+ io___40.ciunit = nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "ALPHA", (ftnlen)5);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+ s_rsle(&io___41);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__7, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(
+ doublecomplex));
+ }
+ e_rsle();
+/* Values of BETA */
+ s_rsle(&io___43);
+ do_lio(&c__3, &c__1, (char *)&nbet, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nbet < 1 || nbet > 7) {
+ io___45.ciunit = nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "BETA", (ftnlen)4);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L230;
+ }
+ s_rsle(&io___46);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__7, &c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(
+ doublecomplex));
+ }
+ e_rsle();
+
+/* Report values of parameters. */
+
+ io___48.ciunit = nout;
+ s_wsfe(&io___48);
+ e_wsfe();
+ io___49.ciunit = nout;
+ s_wsfe(&io___49);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ io___50.ciunit = nout;
+ s_wsfe(&io___50);
+ i__1 = nkb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&kb[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ io___51.ciunit = nout;
+ s_wsfe(&io___51);
+ i__1 = ninc;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&inc[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ io___52.ciunit = nout;
+ s_wsfe(&io___52);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__2, (char *)&alf[i__ - 1], (ftnlen)sizeof(doublereal));
+ }
+ e_wsfe();
+ io___53.ciunit = nout;
+ s_wsfe(&io___53);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__2, (char *)&bet[i__ - 1], (ftnlen)sizeof(doublereal));
+ }
+ e_wsfe();
+ if (! tsterr) {
+ io___54.ciunit = nout;
+ s_wsle(&io___54);
+ e_wsle();
+ io___55.ciunit = nout;
+ s_wsfe(&io___55);
+ e_wsfe();
+ }
+ io___56.ciunit = nout;
+ s_wsle(&io___56);
+ e_wsle();
+ io___57.ciunit = nout;
+ s_wsfe(&io___57);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ io___58.ciunit = nout;
+ s_wsle(&io___58);
+ e_wsle();
+
+/* Read names of subroutines and flags which indicate */
+/* whether they are to be tested. */
+
+ for (i__ = 1; i__ <= 17; ++i__) {
+ ltest[i__ - 1] = FALSE_;
+/* L40: */
+ }
+L50:
+ i__1 = s_rsfe(&io___60);
+ if (i__1 != 0) {
+ goto L80;
+ }
+ i__1 = do_fio(&c__1, snamet, (ftnlen)6);
+ if (i__1 != 0) {
+ goto L80;
+ }
+ i__1 = do_fio(&c__1, (char *)<estt, (ftnlen)sizeof(logical));
+ if (i__1 != 0) {
+ goto L80;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L80;
+ }
+ for (i__ = 1; i__ <= 17; ++i__) {
+ if (s_cmp(snamet, snames + (i__ - 1) * 6, (ftnlen)6, (ftnlen)6) == 0)
+ {
+ goto L70;
+ }
+/* L60: */
+ }
+ io___63.ciunit = nout;
+ s_wsfe(&io___63);
+ do_fio(&c__1, snamet, (ftnlen)6);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+L70:
+ ltest[i__ - 1] = ltestt;
+ goto L50;
+
+L80:
+ cl__1.cerr = 0;
+ cl__1.cunit = 5;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+
+/* Compute EPS (the machine precision). */
+
+ eps = 1.;
+L90:
+ d__1 = eps + 1.;
+ if (ddiff_(&d__1, &c_b123) == 0.) {
+ goto L100;
+ }
+ eps *= .5;
+ goto L90;
+L100:
+ eps += eps;
+ io___65.ciunit = nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+/* Check the reliability of ZMVCH using exact data. */
+
+ n = 32;
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 65 - 66;
+/* Computing MAX */
+ i__5 = i__ - j + 1;
+ i__4 = max(i__5,0);
+ a[i__3].r = (doublereal) i__4, a[i__3].i = 0.;
+/* L110: */
+ }
+ i__2 = j - 1;
+ x[i__2].r = (doublereal) j, x[i__2].i = 0.;
+ i__2 = j - 1;
+ y[i__2].r = 0., y[i__2].i = 0.;
+/* L120: */
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ i__3 = j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3;
+ yy[i__2].r = (doublereal) i__3, yy[i__2].i = 0.;
+/* L130: */
+ }
+/* YY holds the exact result. On exit from ZMVCH YT holds */
+/* the result computed by ZMVCH. */
+ *(unsigned char *)trans = 'N';
+ zmvch_(trans, &n, &n, &c_b2, a, &c__65, x, &c__1, &c_b1, y, &c__1, yt, g,
+ yy, &eps, &err, &fatal, &nout, &c_true, (ftnlen)1);
+ same = lze_(yy, yt, &n);
+ if (! same || err != 0.) {
+ io___78.ciunit = nout;
+ s_wsfe(&io___78);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ *(unsigned char *)trans = 'T';
+ zmvch_(trans, &n, &n, &c_b2, a, &c__65, x, &c_n1, &c_b1, y, &c_n1, yt, g,
+ yy, &eps, &err, &fatal, &nout, &c_true, (ftnlen)1);
+ same = lze_(yy, yt, &n);
+ if (! same || err != 0.) {
+ io___79.ciunit = nout;
+ s_wsfe(&io___79);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Test each subroutine in turn. */
+
+ for (isnum = 1; isnum <= 17; ++isnum) {
+ io___81.ciunit = nout;
+ s_wsle(&io___81);
+ e_wsle();
+ if (! ltest[isnum - 1]) {
+/* Subprogram is not to be tested. */
+ io___82.ciunit = nout;
+ s_wsfe(&io___82);
+ do_fio(&c__1, snames + (isnum - 1) * 6, (ftnlen)6);
+ e_wsfe();
+ } else {
+ s_copy(srnamc_1.srnamt, snames + (isnum - 1) * 6, (ftnlen)6, (
+ ftnlen)6);
+/* Test error exits. */
+ if (tsterr) {
+ zchke_(&isnum, snames + (isnum - 1) * 6, &nout, (ftnlen)6);
+ io___83.ciunit = nout;
+ s_wsle(&io___83);
+ e_wsle();
+ }
+/* Test computations. */
+ infoc_1.infot = 0;
+ infoc_1.ok = TRUE_;
+ fatal = FALSE_;
+ switch (isnum) {
+ case 1: goto L140;
+ case 2: goto L140;
+ case 3: goto L150;
+ case 4: goto L150;
+ case 5: goto L150;
+ case 6: goto L160;
+ case 7: goto L160;
+ case 8: goto L160;
+ case 9: goto L160;
+ case 10: goto L160;
+ case 11: goto L160;
+ case 12: goto L170;
+ case 13: goto L170;
+ case 14: goto L180;
+ case 15: goto L180;
+ case 16: goto L190;
+ case 17: goto L190;
+ }
+/* Test ZGEMV, 01, and ZGBMV, 02. */
+L140:
+ zchk1_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, alf,
+ &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, as, x, xx,
+ xs, y, yy, ys, yt, g, (ftnlen)6);
+ goto L200;
+/* Test ZHEMV, 03, ZHBMV, 04, and ZHPMV, 05. */
+L150:
+ zchk2_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &nalf, alf,
+ &nbet, bet, &ninc, inc, &c__65, &c__2, a, aa, as, x, xx,
+ xs, y, yy, ys, yt, g, (ftnlen)6);
+ goto L200;
+/* Test ZTRMV, 06, ZTBMV, 07, ZTPMV, 08, */
+/* ZTRSV, 09, ZTBSV, 10, and ZTPSV, 11. */
+L160:
+ zchk3_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nkb, kb, &ninc, inc,
+ &c__65, &c__2, a, aa, as, y, yy, ys, yt, g, z__, (ftnlen)
+ 6);
+ goto L200;
+/* Test ZGERC, 12, ZGERU, 13. */
+L170:
+ zchk4_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &ninc,
+ inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, ys, yt,
+ g, z__, (ftnlen)6);
+ goto L200;
+/* Test ZHER, 14, and ZHPR, 15. */
+L180:
+ zchk5_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &ninc,
+ inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, ys, yt,
+ g, z__, (ftnlen)6);
+ goto L200;
+/* Test ZHER2, 16, and ZHPR2, 17. */
+L190:
+ zchk6_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &ninc,
+ inc, &c__65, &c__2, a, aa, as, x, xx, xs, y, yy, ys, yt,
+ g, z__, (ftnlen)6);
+
+L200:
+ if (fatal && sfatal) {
+ goto L220;
+ }
+ }
+/* L210: */
+ }
+ io___90.ciunit = nout;
+ s_wsfe(&io___90);
+ e_wsfe();
+ goto L240;
+
+L220:
+ io___91.ciunit = nout;
+ s_wsfe(&io___91);
+ e_wsfe();
+ goto L240;
+
+L230:
+ io___92.ciunit = nout;
+ s_wsfe(&io___92);
+ e_wsfe();
+
+L240:
+ if (trace) {
+ cl__1.cerr = 0;
+ cl__1.cunit = ntra;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ }
+ cl__1.cerr = 0;
+ cl__1.cunit = nout;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ s_stop("", (ftnlen)0);
+
+
+/* End of ZBLAT2. */
+
+ return 0;
+} /* MAIN__ */
+
+/* Subroutine */ int zchk1_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nkb, integer *kb,
+ integer *nalf, doublecomplex *alf, integer *nbet, doublecomplex *bet,
+ integer *ninc, integer *inc, integer *nmax, integer *incmax,
+ doublecomplex *a, doublecomplex *aa, doublecomplex *as, doublecomplex
+ *x, doublecomplex *xx, doublecomplex *xs, doublecomplex *y,
+ doublecomplex *yy, doublecomplex *ys, doublecomplex *yt, doublereal *
+ g, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ich[3] = "NTC";
+
+ /* Format strings */
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "2(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,\002), A,\002,i3"
+ ",\002, X,\002,i2,\002,(\002,f4.1,\002,\002,f4.1,\002), Y,\002,i2,"
+ "\002) .\002)";
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "4(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,\002), A,\002,i3"
+ ",\002, X,\002,i2,\002,(\002,f4.1,\002,\002,f4.1,\002), Y,\002,i2,"
+ "\002) .\002)";
+ static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
+ i__9;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, m, n, ia, ib, ic, nc, nd, im, in, kl, ml, nk, nl, ku, ix, iy,
+ ms, lx, ly, ns, laa, lda;
+ doublecomplex als, bls;
+ doublereal err;
+ integer iku, kls;
+ extern logical lze_(doublecomplex *, doublecomplex *, integer *);
+ integer kus;
+ doublecomplex beta;
+ integer ldas;
+ logical same;
+ integer incx, incy;
+ logical full, tran, null;
+ doublecomplex alpha;
+ logical isame[13];
+ extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *, integer *, logical *, doublecomplex *, ftnlen, ftnlen,
+ ftnlen);
+ integer nargs;
+ logical reset;
+ integer incxs, incys;
+ extern /* Subroutine */ int zgbmv_(char *, integer *, integer *, integer *
+, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ char trans[1];
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zmvch_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *, doublecomplex *, doublereal *, doublereal *,
+ logical *, integer *, logical *, ftnlen);
+ logical banded;
+ doublereal errmax;
+ doublecomplex transl;
+ extern logical lzeres_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen);
+ char transs[1];
+
+ /* Fortran I/O blocks */
+ static cilist io___139 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___140 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___141 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___144 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___146 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___147 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___148 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___149 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___150 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests ZGEMV and ZGBMV. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --kb;
+ --alf;
+ --bet;
+ --inc;
+ --g;
+ --yt;
+ --y;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ys;
+ --yy;
+ --xs;
+ --xx;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ full = *(unsigned char *)&sname[2] == 'E';
+ banded = *(unsigned char *)&sname[2] == 'B';
+/* Define the number of arguments. */
+ if (full) {
+ nargs = 11;
+ } else if (banded) {
+ nargs = 13;
+ }
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+ nd = n / 2 + 1;
+
+ for (im = 1; im <= 2; ++im) {
+ if (im == 1) {
+/* Computing MAX */
+ i__2 = n - nd;
+ m = max(i__2,0);
+ }
+ if (im == 2) {
+/* Computing MIN */
+ i__2 = n + nd;
+ m = min(i__2,*nmax);
+ }
+
+ if (banded) {
+ nk = *nkb;
+ } else {
+ nk = 1;
+ }
+ i__2 = nk;
+ for (iku = 1; iku <= i__2; ++iku) {
+ if (banded) {
+ ku = kb[iku];
+/* Computing MAX */
+ i__3 = ku - 1;
+ kl = max(i__3,0);
+ } else {
+ ku = n - 1;
+ kl = m - 1;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ if (banded) {
+ lda = kl + ku + 1;
+ } else {
+ lda = m;
+ }
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L100;
+ }
+ laa = lda * n;
+ null = n <= 0 || m <= 0;
+
+/* Generate the matrix A. */
+
+ transl.r = 0., transl.i = 0.;
+ zmake_(sname + 1, " ", " ", &m, &n, &a[a_offset], nmax, &aa[1]
+ , &lda, &kl, &ku, &reset, &transl, (ftnlen)2, (ftnlen)
+ 1, (ftnlen)1);
+
+ for (ic = 1; ic <= 3; ++ic) {
+ *(unsigned char *)trans = *(unsigned char *)&ich[ic - 1];
+ tran = *(unsigned char *)trans == 'T' || *(unsigned char *
+ )trans == 'C';
+
+ if (tran) {
+ ml = n;
+ nl = m;
+ } else {
+ ml = m;
+ nl = n;
+ }
+
+ i__3 = *ninc;
+ for (ix = 1; ix <= i__3; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * nl;
+
+/* Generate the vector X. */
+
+ transl.r = .5, transl.i = 0.;
+ i__4 = abs(incx);
+ i__5 = nl - 1;
+ zmake_("GE", " ", " ", &c__1, &nl, &x[1], &c__1, &xx[
+ 1], &i__4, &c__0, &i__5, &reset, &transl, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+ if (nl > 1) {
+ i__4 = nl / 2;
+ x[i__4].r = 0., x[i__4].i = 0.;
+ i__4 = abs(incx) * (nl / 2 - 1) + 1;
+ xx[i__4].r = 0., xx[i__4].i = 0.;
+ }
+
+ i__4 = *ninc;
+ for (iy = 1; iy <= i__4; ++iy) {
+ incy = inc[iy];
+ ly = abs(incy) * ml;
+
+ i__5 = *nalf;
+ for (ia = 1; ia <= i__5; ++ia) {
+ i__6 = ia;
+ alpha.r = alf[i__6].r, alpha.i = alf[i__6].i;
+
+ i__6 = *nbet;
+ for (ib = 1; ib <= i__6; ++ib) {
+ i__7 = ib;
+ beta.r = bet[i__7].r, beta.i = bet[i__7]
+ .i;
+
+/* Generate the vector Y. */
+
+ transl.r = 0., transl.i = 0.;
+ i__7 = abs(incy);
+ i__8 = ml - 1;
+ zmake_("GE", " ", " ", &c__1, &ml, &y[1],
+ &c__1, &yy[1], &i__7, &c__0, &
+ i__8, &reset, &transl, (ftnlen)2,
+ (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the */
+/* subroutine. */
+
+ *(unsigned char *)transs = *(unsigned
+ char *)trans;
+ ms = m;
+ ns = n;
+ kls = kl;
+ kus = ku;
+ als.r = alpha.r, als.i = alpha.i;
+ i__7 = laa;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ i__8 = i__;
+ i__9 = i__;
+ as[i__8].r = aa[i__9].r, as[i__8].i =
+ aa[i__9].i;
+/* L10: */
+ }
+ ldas = lda;
+ i__7 = lx;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ i__8 = i__;
+ i__9 = i__;
+ xs[i__8].r = xx[i__9].r, xs[i__8].i =
+ xx[i__9].i;
+/* L20: */
+ }
+ incxs = incx;
+ bls.r = beta.r, bls.i = beta.i;
+ i__7 = ly;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ i__8 = i__;
+ i__9 = i__;
+ ys[i__8].r = yy[i__9].r, ys[i__8].i =
+ yy[i__9].i;
+/* L30: */
+ }
+ incys = incy;
+
+/* Call the subroutine. */
+
+ if (full) {
+ if (*trace) {
+ io___139.ciunit = *ntra;
+ s_wsfe(&io___139);
+ do_fio(&c__1, (char *)&nc, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (
+ ftnlen)sizeof(doublereal))
+ ;
+ do_fio(&c__1, (char *)&lda, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (
+ ftnlen)sizeof(doublereal))
+ ;
+ do_fio(&c__1, (char *)&incy, (
+ ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ zgemv_(trans, &m, &n, &alpha, &aa[1],
+ &lda, &xx[1], &incx, &beta, &
+ yy[1], &incy);
+ } else if (banded) {
+ if (*trace) {
+ io___140.ciunit = *ntra;
+ s_wsfe(&io___140);
+ do_fio(&c__1, (char *)&nc, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (
+ ftnlen)sizeof(doublereal))
+ ;
+ do_fio(&c__1, (char *)&lda, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (
+ ftnlen)sizeof(doublereal))
+ ;
+ do_fio(&c__1, (char *)&incy, (
+ ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ zgbmv_(trans, &m, &n, &kl, &ku, &
+ alpha, &aa[1], &lda, &xx[1], &
+ incx, &beta, &yy[1], &incy);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___141.ciunit = *nout;
+ s_wsfe(&io___141);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L130;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)trans == *(
+ unsigned char *)transs;
+ isame[1] = ms == m;
+ isame[2] = ns == n;
+ if (full) {
+ isame[3] = als.r == alpha.r && als.i
+ == alpha.i;
+ isame[4] = lze_(&as[1], &aa[1], &laa);
+ isame[5] = ldas == lda;
+ isame[6] = lze_(&xs[1], &xx[1], &lx);
+ isame[7] = incxs == incx;
+ isame[8] = bls.r == beta.r && bls.i ==
+ beta.i;
+ if (null) {
+ isame[9] = lze_(&ys[1], &yy[1], &
+ ly);
+ } else {
+ i__7 = abs(incy);
+ isame[9] = lzeres_("GE", " ", &
+ c__1, &ml, &ys[1], &yy[1],
+ &i__7, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[10] = incys == incy;
+ } else if (banded) {
+ isame[3] = kls == kl;
+ isame[4] = kus == ku;
+ isame[5] = als.r == alpha.r && als.i
+ == alpha.i;
+ isame[6] = lze_(&as[1], &aa[1], &laa);
+ isame[7] = ldas == lda;
+ isame[8] = lze_(&xs[1], &xx[1], &lx);
+ isame[9] = incxs == incx;
+ isame[10] = bls.r == beta.r && bls.i
+ == beta.i;
+ if (null) {
+ isame[11] = lze_(&ys[1], &yy[1], &
+ ly);
+ } else {
+ i__7 = abs(incy);
+ isame[11] = lzeres_("GE", " ", &
+ c__1, &ml, &ys[1], &yy[1],
+ &i__7, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[12] = incys == incy;
+ }
+
+/* If data was incorrectly changed, report */
+/* and return. */
+
+ same = TRUE_;
+ i__7 = nargs;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___144.ciunit = *nout;
+ s_wsfe(&io___144);
+ do_fio(&c__1, (char *)&i__, (
+ ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L130;
+ }
+
+ if (! null) {
+
+/* Check the result. */
+
+ zmvch_(trans, &m, &n, &alpha, &a[
+ a_offset], nmax, &x[1], &incx,
+ &beta, &y[1], &incy, &yt[1],
+ &g[1], &yy[1], eps, &err,
+ fatal, nout, &c_true, (ftnlen)
+ 1);
+ errmax = max(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L130;
+ }
+ } else {
+/* Avoid repeating tests with M.le.0 or */
+/* N.le.0. */
+ goto L110;
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+/* L70: */
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+L110:
+ ;
+ }
+
+/* L120: */
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___146.ciunit = *nout;
+ s_wsfe(&io___146);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___147.ciunit = *nout;
+ s_wsfe(&io___147);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ goto L140;
+
+L130:
+ io___148.ciunit = *nout;
+ s_wsfe(&io___148);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (full) {
+ io___149.ciunit = *nout;
+ s_wsfe(&io___149);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (banded) {
+ io___150.ciunit = *nout;
+ s_wsfe(&io___150);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L140:
+ return 0;
+
+
+/* End of ZCHK1. */
+
+} /* zchk1_ */
+
+/* Subroutine */ int zchk2_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nkb, integer *kb,
+ integer *nalf, doublecomplex *alf, integer *nbet, doublecomplex *bet,
+ integer *ninc, integer *inc, integer *nmax, integer *incmax,
+ doublecomplex *a, doublecomplex *aa, doublecomplex *as, doublecomplex
+ *x, doublecomplex *xx, doublecomplex *xs, doublecomplex *y,
+ doublecomplex *yy, doublecomplex *ys, doublecomplex *yt, doublereal *
+ g, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ich[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,(\002,f4.1,\002,\002,f4.1,\002), A,\002,i3,\002, X,\002,"
+ "i2,\002,(\002,f4.1,\002,\002,f4.1,\002), \002,\002Y,\002,i2,\002"
+ ") .\002)";
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "2(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,\002), A,\002,i3"
+ ",\002, X,\002,i2,\002,(\002,f4.1,\002,\002,f4.1,\002), Y,\002,i2,"
+ "\002) .\002)";
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,(\002,f4.1,\002,\002,f4.1,\002), AP, X,\002,i2,\002,("
+ "\002,f4.1,\002,\002,f4.1,\002), Y,\002,i2,\002) "
+ ".\002)";
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
+ i__9;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, k, n, ia, ib, ic, nc, ik, in, nk, ks, ix, iy, ns, lx, ly,
+ laa, lda;
+ doublecomplex als, bls;
+ doublereal err;
+ extern logical lze_(doublecomplex *, doublecomplex *, integer *);
+ doublecomplex beta;
+ integer ldas;
+ logical same;
+ integer incx, incy;
+ logical full, null;
+ char uplo[1];
+ doublecomplex alpha;
+ logical isame[13];
+ extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *, integer *, logical *, doublecomplex *, ftnlen, ftnlen,
+ ftnlen);
+ integer nargs;
+ logical reset;
+ integer incxs, incys;
+ extern /* Subroutine */ int zhbmv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zmvch_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *, doublecomplex *, doublereal *, doublereal *,
+ logical *, integer *, logical *, ftnlen), zhemv_(char *, integer *
+, doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ char uplos[1];
+ extern /* Subroutine */ int zhpmv_(char *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ logical banded, packed;
+ doublereal errmax;
+ doublecomplex transl;
+ extern logical lzeres_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen);
+
+ /* Fortran I/O blocks */
+ static cilist io___189 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___190 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___191 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___192 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___195 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___197 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___198 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___199 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___200 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___201 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___202 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests ZHEMV, ZHBMV and ZHPMV. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --kb;
+ --alf;
+ --bet;
+ --inc;
+ --g;
+ --yt;
+ --y;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ys;
+ --yy;
+ --xs;
+ --xx;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ full = *(unsigned char *)&sname[2] == 'E';
+ banded = *(unsigned char *)&sname[2] == 'B';
+ packed = *(unsigned char *)&sname[2] == 'P';
+/* Define the number of arguments. */
+ if (full) {
+ nargs = 10;
+ } else if (banded) {
+ nargs = 11;
+ } else if (packed) {
+ nargs = 9;
+ }
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+
+ if (banded) {
+ nk = *nkb;
+ } else {
+ nk = 1;
+ }
+ i__2 = nk;
+ for (ik = 1; ik <= i__2; ++ik) {
+ if (banded) {
+ k = kb[ik];
+ } else {
+ k = n - 1;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ if (banded) {
+ lda = k + 1;
+ } else {
+ lda = n;
+ }
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L100;
+ }
+ if (packed) {
+ laa = n * (n + 1) / 2;
+ } else {
+ laa = lda * n;
+ }
+ null = n <= 0;
+
+ for (ic = 1; ic <= 2; ++ic) {
+ *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];
+
+/* Generate the matrix A. */
+
+ transl.r = 0., transl.i = 0.;
+ zmake_(sname + 1, uplo, " ", &n, &n, &a[a_offset], nmax, &aa[
+ 1], &lda, &k, &k, &reset, &transl, (ftnlen)2, (ftnlen)
+ 1, (ftnlen)1);
+
+ i__3 = *ninc;
+ for (ix = 1; ix <= i__3; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * n;
+
+/* Generate the vector X. */
+
+ transl.r = .5, transl.i = 0.;
+ i__4 = abs(incx);
+ i__5 = n - 1;
+ zmake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &
+ i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (
+ ftnlen)1, (ftnlen)1);
+ if (n > 1) {
+ i__4 = n / 2;
+ x[i__4].r = 0., x[i__4].i = 0.;
+ i__4 = abs(incx) * (n / 2 - 1) + 1;
+ xx[i__4].r = 0., xx[i__4].i = 0.;
+ }
+
+ i__4 = *ninc;
+ for (iy = 1; iy <= i__4; ++iy) {
+ incy = inc[iy];
+ ly = abs(incy) * n;
+
+ i__5 = *nalf;
+ for (ia = 1; ia <= i__5; ++ia) {
+ i__6 = ia;
+ alpha.r = alf[i__6].r, alpha.i = alf[i__6].i;
+
+ i__6 = *nbet;
+ for (ib = 1; ib <= i__6; ++ib) {
+ i__7 = ib;
+ beta.r = bet[i__7].r, beta.i = bet[i__7].i;
+
+/* Generate the vector Y. */
+
+ transl.r = 0., transl.i = 0.;
+ i__7 = abs(incy);
+ i__8 = n - 1;
+ zmake_("GE", " ", " ", &c__1, &n, &y[1], &
+ c__1, &yy[1], &i__7, &c__0, &i__8, &
+ reset, &transl, (ftnlen)2, (ftnlen)1,
+ (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the */
+/* subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)
+ uplo;
+ ns = n;
+ ks = k;
+ als.r = alpha.r, als.i = alpha.i;
+ i__7 = laa;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ i__8 = i__;
+ i__9 = i__;
+ as[i__8].r = aa[i__9].r, as[i__8].i = aa[
+ i__9].i;
+/* L10: */
+ }
+ ldas = lda;
+ i__7 = lx;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ i__8 = i__;
+ i__9 = i__;
+ xs[i__8].r = xx[i__9].r, xs[i__8].i = xx[
+ i__9].i;
+/* L20: */
+ }
+ incxs = incx;
+ bls.r = beta.r, bls.i = beta.i;
+ i__7 = ly;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ i__8 = i__;
+ i__9 = i__;
+ ys[i__8].r = yy[i__9].r, ys[i__8].i = yy[
+ i__9].i;
+/* L30: */
+ }
+ incys = incy;
+
+/* Call the subroutine. */
+
+ if (full) {
+ if (*trace) {
+ io___189.ciunit = *ntra;
+ s_wsfe(&io___189);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&incy, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ zhemv_(uplo, &n, &alpha, &aa[1], &lda, &
+ xx[1], &incx, &beta, &yy[1], &
+ incy);
+ } else if (banded) {
+ if (*trace) {
+ io___190.ciunit = *ntra;
+ s_wsfe(&io___190);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&incy, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ zhbmv_(uplo, &n, &k, &alpha, &aa[1], &lda,
+ &xx[1], &incx, &beta, &yy[1], &
+ incy);
+ } else if (packed) {
+ if (*trace) {
+ io___191.ciunit = *ntra;
+ s_wsfe(&io___191);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&incy, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ zhpmv_(uplo, &n, &alpha, &aa[1], &xx[1], &
+ incx, &beta, &yy[1], &incy);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___192.ciunit = *nout;
+ s_wsfe(&io___192);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplo == *(
+ unsigned char *)uplos;
+ isame[1] = ns == n;
+ if (full) {
+ isame[2] = als.r == alpha.r && als.i ==
+ alpha.i;
+ isame[3] = lze_(&as[1], &aa[1], &laa);
+ isame[4] = ldas == lda;
+ isame[5] = lze_(&xs[1], &xx[1], &lx);
+ isame[6] = incxs == incx;
+ isame[7] = bls.r == beta.r && bls.i ==
+ beta.i;
+ if (null) {
+ isame[8] = lze_(&ys[1], &yy[1], &ly);
+ } else {
+ i__7 = abs(incy);
+ isame[8] = lzeres_("GE", " ", &c__1, &
+ n, &ys[1], &yy[1], &i__7, (
+ ftnlen)2, (ftnlen)1);
+ }
+ isame[9] = incys == incy;
+ } else if (banded) {
+ isame[2] = ks == k;
+ isame[3] = als.r == alpha.r && als.i ==
+ alpha.i;
+ isame[4] = lze_(&as[1], &aa[1], &laa);
+ isame[5] = ldas == lda;
+ isame[6] = lze_(&xs[1], &xx[1], &lx);
+ isame[7] = incxs == incx;
+ isame[8] = bls.r == beta.r && bls.i ==
+ beta.i;
+ if (null) {
+ isame[9] = lze_(&ys[1], &yy[1], &ly);
+ } else {
+ i__7 = abs(incy);
+ isame[9] = lzeres_("GE", " ", &c__1, &
+ n, &ys[1], &yy[1], &i__7, (
+ ftnlen)2, (ftnlen)1);
+ }
+ isame[10] = incys == incy;
+ } else if (packed) {
+ isame[2] = als.r == alpha.r && als.i ==
+ alpha.i;
+ isame[3] = lze_(&as[1], &aa[1], &laa);
+ isame[4] = lze_(&xs[1], &xx[1], &lx);
+ isame[5] = incxs == incx;
+ isame[6] = bls.r == beta.r && bls.i ==
+ beta.i;
+ if (null) {
+ isame[7] = lze_(&ys[1], &yy[1], &ly);
+ } else {
+ i__7 = abs(incy);
+ isame[7] = lzeres_("GE", " ", &c__1, &
+ n, &ys[1], &yy[1], &i__7, (
+ ftnlen)2, (ftnlen)1);
+ }
+ isame[8] = incys == incy;
+ }
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__7 = nargs;
+ for (i__ = 1; i__ <= i__7; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___195.ciunit = *nout;
+ s_wsfe(&io___195);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+
+/* Check the result. */
+
+ zmvch_("N", &n, &n, &alpha, &a[a_offset],
+ nmax, &x[1], &incx, &beta, &y[1],
+ &incy, &yt[1], &g[1], &yy[1], eps,
+ &err, fatal, nout, &c_true, (
+ ftnlen)1);
+ errmax = max(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L120;
+ }
+ } else {
+/* Avoid repeating tests with N.le.0 */
+ goto L110;
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+/* L70: */
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+L110:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___197.ciunit = *nout;
+ s_wsfe(&io___197);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___198.ciunit = *nout;
+ s_wsfe(&io___198);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ goto L130;
+
+L120:
+ io___199.ciunit = *nout;
+ s_wsfe(&io___199);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (full) {
+ io___200.ciunit = *nout;
+ s_wsfe(&io___200);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (banded) {
+ io___201.ciunit = *nout;
+ s_wsfe(&io___201);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (packed) {
+ io___202.ciunit = *nout;
+ s_wsfe(&io___202);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L130:
+ return 0;
+
+
+/* End of ZCHK2. */
+
+} /* zchk2_ */
+
+/* Subroutine */ int zchk3_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nkb, integer *kb,
+ integer *ninc, integer *inc, integer *nmax, integer *incmax,
+ doublecomplex *a, doublecomplex *aa, doublecomplex *as, doublecomplex
+ *x, doublecomplex *xx, doublecomplex *xs, doublecomplex *xt,
+ doublereal *g, doublecomplex *z__, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ichu[2] = "UL";
+ static char icht[3] = "NTC";
+ static char ichd[2] = "UN";
+
+ /* Format strings */
+ static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002(\002,3(\002'\002,a1"
+ ",\002',\002),i3,\002, A,\002,i3,\002, X,\002,i2,\002) "
+ " .\002)";
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002(\002,3(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),\002 A,\002,i3,\002, X,\002,i2,\002"
+ ") .\002)";
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002(\002,3(\002'\002,a1"
+ ",\002',\002),i3,\002, AP, \002,\002X,\002,i2,\002) "
+ " .\002)";
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio(
+ integer *, char *, ftnlen), e_wsfe(void), f_rew(alist *);
+
+ /* Local variables */
+ integer i__, k, n, nc, ik, in, nk, ks, ix, ns, lx, laa, icd, lda, ict,
+ icu;
+ doublereal err;
+ extern logical lze_(doublecomplex *, doublecomplex *, integer *);
+ char diag[1];
+ integer ldas;
+ logical same;
+ integer incx;
+ logical full, null;
+ char uplo[1], diags[1];
+ logical isame[13];
+ extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *, integer *, logical *, doublecomplex *, ftnlen, ftnlen,
+ ftnlen);
+ integer nargs;
+ logical reset;
+ integer incxs;
+ char trans[1];
+ extern /* Subroutine */ int zmvch_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublereal *, doublecomplex *, doublereal *,
+ doublereal *, logical *, integer *, logical *, ftnlen);
+ char uplos[1];
+ extern /* Subroutine */ int ztbmv_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *), ztbsv_(char *, char *, char *, integer *
+, integer *, doublecomplex *, integer *, doublecomplex *, integer
+ *), ztpmv_(char *, char *, char *,
+ integer *, doublecomplex *, doublecomplex *, integer *), ztrmv_(char *, char *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *), ztpsv_(char *, char *, char *, integer *,
+ doublecomplex *, doublecomplex *, integer *), ztrsv_(char *, char *, char *, integer *, doublecomplex *
+, integer *, doublecomplex *, integer *);
+ logical banded, packed;
+ doublereal errmax;
+ doublecomplex transl;
+ extern logical lzeres_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen);
+ char transs[1];
+
+ /* Fortran I/O blocks */
+ static cilist io___239 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___240 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___241 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___242 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___243 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___244 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___245 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___248 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___250 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___251 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___252 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___253 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___254 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___255 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests ZTRMV, ZTBMV, ZTPMV, ZTRSV, ZTBSV and ZTPSV. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --kb;
+ --inc;
+ --z__;
+ --g;
+ --xt;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --xs;
+ --xx;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ full = *(unsigned char *)&sname[2] == 'R';
+ banded = *(unsigned char *)&sname[2] == 'B';
+ packed = *(unsigned char *)&sname[2] == 'P';
+/* Define the number of arguments. */
+ if (full) {
+ nargs = 8;
+ } else if (banded) {
+ nargs = 9;
+ } else if (packed) {
+ nargs = 7;
+ }
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.;
+/* Set up zero vector for ZMVCH. */
+ i__1 = *nmax;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ z__[i__2].r = 0., z__[i__2].i = 0.;
+/* L10: */
+ }
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+
+ if (banded) {
+ nk = *nkb;
+ } else {
+ nk = 1;
+ }
+ i__2 = nk;
+ for (ik = 1; ik <= i__2; ++ik) {
+ if (banded) {
+ k = kb[ik];
+ } else {
+ k = n - 1;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ if (banded) {
+ lda = k + 1;
+ } else {
+ lda = n;
+ }
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L100;
+ }
+ if (packed) {
+ laa = n * (n + 1) / 2;
+ } else {
+ laa = lda * n;
+ }
+ null = n <= 0;
+
+ for (icu = 1; icu <= 2; ++icu) {
+ *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
+
+ for (ict = 1; ict <= 3; ++ict) {
+ *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1]
+ ;
+
+ for (icd = 1; icd <= 2; ++icd) {
+ *(unsigned char *)diag = *(unsigned char *)&ichd[icd
+ - 1];
+
+/* Generate the matrix A. */
+
+ transl.r = 0., transl.i = 0.;
+ zmake_(sname + 1, uplo, diag, &n, &n, &a[a_offset],
+ nmax, &aa[1], &lda, &k, &k, &reset, &transl, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ i__3 = *ninc;
+ for (ix = 1; ix <= i__3; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * n;
+
+/* Generate the vector X. */
+
+ transl.r = .5, transl.i = 0.;
+ i__4 = abs(incx);
+ i__5 = n - 1;
+ zmake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &
+ xx[1], &i__4, &c__0, &i__5, &reset, &
+ transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);
+ if (n > 1) {
+ i__4 = n / 2;
+ x[i__4].r = 0., x[i__4].i = 0.;
+ i__4 = abs(incx) * (n / 2 - 1) + 1;
+ xx[i__4].r = 0., xx[i__4].i = 0.;
+ }
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ *(unsigned char *)transs = *(unsigned char *)
+ trans;
+ *(unsigned char *)diags = *(unsigned char *)diag;
+ ns = n;
+ ks = k;
+ i__4 = laa;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__;
+ i__6 = i__;
+ as[i__5].r = aa[i__6].r, as[i__5].i = aa[i__6]
+ .i;
+/* L20: */
+ }
+ ldas = lda;
+ i__4 = lx;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__;
+ i__6 = i__;
+ xs[i__5].r = xx[i__6].r, xs[i__5].i = xx[i__6]
+ .i;
+/* L30: */
+ }
+ incxs = incx;
+
+/* Call the subroutine. */
+
+ if (s_cmp(sname + 3, "MV", (ftnlen)2, (ftnlen)2)
+ == 0) {
+ if (full) {
+ if (*trace) {
+ io___239.ciunit = *ntra;
+ s_wsfe(&io___239);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ztrmv_(uplo, trans, diag, &n, &aa[1], &
+ lda, &xx[1], &incx);
+ } else if (banded) {
+ if (*trace) {
+ io___240.ciunit = *ntra;
+ s_wsfe(&io___240);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ztbmv_(uplo, trans, diag, &n, &k, &aa[1],
+ &lda, &xx[1], &incx);
+ } else if (packed) {
+ if (*trace) {
+ io___241.ciunit = *ntra;
+ s_wsfe(&io___241);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ztpmv_(uplo, trans, diag, &n, &aa[1], &xx[
+ 1], &incx);
+ }
+ } else if (s_cmp(sname + 3, "SV", (ftnlen)2, (
+ ftnlen)2) == 0) {
+ if (full) {
+ if (*trace) {
+ io___242.ciunit = *ntra;
+ s_wsfe(&io___242);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ztrsv_(uplo, trans, diag, &n, &aa[1], &
+ lda, &xx[1], &incx);
+ } else if (banded) {
+ if (*trace) {
+ io___243.ciunit = *ntra;
+ s_wsfe(&io___243);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ztbsv_(uplo, trans, diag, &n, &k, &aa[1],
+ &lda, &xx[1], &incx);
+ } else if (packed) {
+ if (*trace) {
+ io___244.ciunit = *ntra;
+ s_wsfe(&io___244);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ztpsv_(uplo, trans, diag, &n, &aa[1], &xx[
+ 1], &incx);
+ }
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___245.ciunit = *nout;
+ s_wsfe(&io___245);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplo == *(unsigned
+ char *)uplos;
+ isame[1] = *(unsigned char *)trans == *(unsigned
+ char *)transs;
+ isame[2] = *(unsigned char *)diag == *(unsigned
+ char *)diags;
+ isame[3] = ns == n;
+ if (full) {
+ isame[4] = lze_(&as[1], &aa[1], &laa);
+ isame[5] = ldas == lda;
+ if (null) {
+ isame[6] = lze_(&xs[1], &xx[1], &lx);
+ } else {
+ i__4 = abs(incx);
+ isame[6] = lzeres_("GE", " ", &c__1, &n, &
+ xs[1], &xx[1], &i__4, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[7] = incxs == incx;
+ } else if (banded) {
+ isame[4] = ks == k;
+ isame[5] = lze_(&as[1], &aa[1], &laa);
+ isame[6] = ldas == lda;
+ if (null) {
+ isame[7] = lze_(&xs[1], &xx[1], &lx);
+ } else {
+ i__4 = abs(incx);
+ isame[7] = lzeres_("GE", " ", &c__1, &n, &
+ xs[1], &xx[1], &i__4, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[8] = incxs == incx;
+ } else if (packed) {
+ isame[4] = lze_(&as[1], &aa[1], &laa);
+ if (null) {
+ isame[5] = lze_(&xs[1], &xx[1], &lx);
+ } else {
+ i__4 = abs(incx);
+ isame[5] = lzeres_("GE", " ", &c__1, &n, &
+ xs[1], &xx[1], &i__4, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[6] = incxs == incx;
+ }
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__4 = nargs;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___248.ciunit = *nout;
+ s_wsfe(&io___248);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+ if (s_cmp(sname + 3, "MV", (ftnlen)2, (ftnlen)
+ 2) == 0) {
+
+/* Check the result. */
+
+ zmvch_(trans, &n, &n, &c_b2, &a[a_offset],
+ nmax, &x[1], &incx, &c_b1, &z__[
+ 1], &incx, &xt[1], &g[1], &xx[1],
+ eps, &err, fatal, nout, &c_true, (
+ ftnlen)1);
+ } else if (s_cmp(sname + 3, "SV", (ftnlen)2, (
+ ftnlen)2) == 0) {
+
+/* Compute approximation to original vector. */
+
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__;
+ i__6 = (i__ - 1) * abs(incx) + 1;
+ z__[i__5].r = xx[i__6].r, z__[i__5].i
+ = xx[i__6].i;
+ i__5 = (i__ - 1) * abs(incx) + 1;
+ i__6 = i__;
+ xx[i__5].r = x[i__6].r, xx[i__5].i =
+ x[i__6].i;
+/* L50: */
+ }
+ zmvch_(trans, &n, &n, &c_b2, &a[a_offset],
+ nmax, &z__[1], &incx, &c_b1, &x[
+ 1], &incx, &xt[1], &g[1], &xx[1],
+ eps, &err, fatal, nout, &c_false,
+ (ftnlen)1);
+ }
+ errmax = max(errmax,err);
+/* If got really bad answer, report and return. */
+ if (*fatal) {
+ goto L120;
+ }
+ } else {
+/* Avoid repeating tests with N.le.0. */
+ goto L110;
+ }
+
+/* L60: */
+ }
+
+/* L70: */
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+L110:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___250.ciunit = *nout;
+ s_wsfe(&io___250);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___251.ciunit = *nout;
+ s_wsfe(&io___251);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ goto L130;
+
+L120:
+ io___252.ciunit = *nout;
+ s_wsfe(&io___252);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (full) {
+ io___253.ciunit = *nout;
+ s_wsfe(&io___253);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (banded) {
+ io___254.ciunit = *nout;
+ s_wsfe(&io___254);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (packed) {
+ io___255.ciunit = *nout;
+ s_wsfe(&io___255);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L130:
+ return 0;
+
+
+/* End of ZCHK3. */
+
+} /* zchk3_ */
+
+/* Subroutine */ int zchk4_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
+ alf, integer *ninc, integer *inc, integer *nmax, integer *incmax,
+ doublecomplex *a, doublecomplex *aa, doublecomplex *as, doublecomplex
+ *x, doublecomplex *xx, doublecomplex *xs, doublecomplex *y,
+ doublecomplex *yy, doublecomplex *ys, doublecomplex *yt, doublereal *
+ g, doublecomplex *z__, ftnlen sname_len)
+{
+ /* Format strings */
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002(\002,2(i3,\002,"
+ "\002),\002(\002,f4.1,\002,\002,f4.1,\002), X,\002,i2,\002, Y,"
+ "\002,i2,\002, A,\002,i3,\002) \002,\002 "
+ ".\002)";
+ static char fmt_9993[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+ doublecomplex z__1;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, m, n;
+ doublecomplex w[1];
+ integer ia, nc, nd, im, in, ms, ix, iy, ns, lx, ly, laa, lda;
+ doublecomplex als;
+ doublereal err;
+ extern logical lze_(doublecomplex *, doublecomplex *, integer *);
+ integer ldas;
+ logical same, conj;
+ integer incx, incy;
+ logical null;
+ doublecomplex alpha;
+ logical isame[13];
+ extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *, integer *, logical *, doublecomplex *, ftnlen, ftnlen,
+ ftnlen);
+ integer nargs;
+ extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ logical reset;
+ integer incxs, incys;
+ extern /* Subroutine */ int zmvch_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublereal *, doublecomplex *, doublereal *,
+ doublereal *, logical *, integer *, logical *, ftnlen), zgeru_(
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal errmax;
+ doublecomplex transl;
+ extern logical lzeres_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen);
+
+ /* Fortran I/O blocks */
+ static cilist io___285 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___286 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___289 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___293 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___294 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___295 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___296 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___297 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* Tests ZGERC and ZGERU. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --inc;
+ --z__;
+ --g;
+ --yt;
+ --y;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ys;
+ --yy;
+ --xs;
+ --xx;
+
+ /* Function Body */
+ conj = *(unsigned char *)&sname[4] == 'C';
+/* Define the number of arguments. */
+ nargs = 9;
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+ nd = n / 2 + 1;
+
+ for (im = 1; im <= 2; ++im) {
+ if (im == 1) {
+/* Computing MAX */
+ i__2 = n - nd;
+ m = max(i__2,0);
+ }
+ if (im == 2) {
+/* Computing MIN */
+ i__2 = n + nd;
+ m = min(i__2,*nmax);
+ }
+
+/* Set LDA to 1 more than minimum value if room. */
+ lda = m;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L110;
+ }
+ laa = lda * n;
+ null = n <= 0 || m <= 0;
+
+ i__2 = *ninc;
+ for (ix = 1; ix <= i__2; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * m;
+
+/* Generate the vector X. */
+
+ transl.r = .5, transl.i = 0.;
+ i__3 = abs(incx);
+ i__4 = m - 1;
+ zmake_("GE", " ", " ", &c__1, &m, &x[1], &c__1, &xx[1], &i__3,
+ &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1,
+ (ftnlen)1);
+ if (m > 1) {
+ i__3 = m / 2;
+ x[i__3].r = 0., x[i__3].i = 0.;
+ i__3 = abs(incx) * (m / 2 - 1) + 1;
+ xx[i__3].r = 0., xx[i__3].i = 0.;
+ }
+
+ i__3 = *ninc;
+ for (iy = 1; iy <= i__3; ++iy) {
+ incy = inc[iy];
+ ly = abs(incy) * n;
+
+/* Generate the vector Y. */
+
+ transl.r = 0., transl.i = 0.;
+ i__4 = abs(incy);
+ i__5 = n - 1;
+ zmake_("GE", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], &
+ i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (
+ ftnlen)1, (ftnlen)1);
+ if (n > 1) {
+ i__4 = n / 2;
+ y[i__4].r = 0., y[i__4].i = 0.;
+ i__4 = abs(incy) * (n / 2 - 1) + 1;
+ yy[i__4].r = 0., yy[i__4].i = 0.;
+ }
+
+ i__4 = *nalf;
+ for (ia = 1; ia <= i__4; ++ia) {
+ i__5 = ia;
+ alpha.r = alf[i__5].r, alpha.i = alf[i__5].i;
+
+/* Generate the matrix A. */
+
+ transl.r = 0., transl.i = 0.;
+ i__5 = m - 1;
+ i__6 = n - 1;
+ zmake_(sname + 1, " ", " ", &m, &n, &a[a_offset],
+ nmax, &aa[1], &lda, &i__5, &i__6, &reset, &
+ transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ ms = m;
+ ns = n;
+ als.r = alpha.r, als.i = alpha.i;
+ i__5 = laa;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7].i;
+/* L10: */
+ }
+ ldas = lda;
+ i__5 = lx;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ xs[i__6].r = xx[i__7].r, xs[i__6].i = xx[i__7].i;
+/* L20: */
+ }
+ incxs = incx;
+ i__5 = ly;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ ys[i__6].r = yy[i__7].r, ys[i__6].i = yy[i__7].i;
+/* L30: */
+ }
+ incys = incy;
+
+/* Call the subroutine. */
+
+ if (*trace) {
+ io___285.ciunit = *ntra;
+ s_wsfe(&io___285);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (conj) {
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ zgerc_(&m, &n, &alpha, &xx[1], &incx, &yy[1], &
+ incy, &aa[1], &lda);
+ } else {
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ zgeru_(&m, &n, &alpha, &xx[1], &incx, &yy[1], &
+ incy, &aa[1], &lda);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___286.ciunit = *nout;
+ s_wsfe(&io___286);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L140;
+ }
+
+/* See what data changed inside subroutine. */
+
+ isame[0] = ms == m;
+ isame[1] = ns == n;
+ isame[2] = als.r == alpha.r && als.i == alpha.i;
+ isame[3] = lze_(&xs[1], &xx[1], &lx);
+ isame[4] = incxs == incx;
+ isame[5] = lze_(&ys[1], &yy[1], &ly);
+ isame[6] = incys == incy;
+ if (null) {
+ isame[7] = lze_(&as[1], &aa[1], &laa);
+ } else {
+ isame[7] = lzeres_("GE", " ", &m, &n, &as[1], &aa[
+ 1], &lda, (ftnlen)2, (ftnlen)1);
+ }
+ isame[8] = ldas == lda;
+
+/* If data was incorrectly changed, report and return. */
+
+ same = TRUE_;
+ i__5 = nargs;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___289.ciunit = *nout;
+ s_wsfe(&io___289);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L140;
+ }
+
+ if (! null) {
+
+/* Check the result column by column. */
+
+ if (incx > 0) {
+ i__5 = m;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ z__[i__6].r = x[i__7].r, z__[i__6].i = x[
+ i__7].i;
+/* L50: */
+ }
+ } else {
+ i__5 = m;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = m - i__ + 1;
+ z__[i__6].r = x[i__7].r, z__[i__6].i = x[
+ i__7].i;
+/* L60: */
+ }
+ }
+ i__5 = n;
+ for (j = 1; j <= i__5; ++j) {
+ if (incy > 0) {
+ i__6 = j;
+ w[0].r = y[i__6].r, w[0].i = y[i__6].i;
+ } else {
+ i__6 = n - j + 1;
+ w[0].r = y[i__6].r, w[0].i = y[i__6].i;
+ }
+ if (conj) {
+ d_cnjg(&z__1, w);
+ w[0].r = z__1.r, w[0].i = z__1.i;
+ }
+ zmvch_("N", &m, &c__1, &alpha, &z__[1], nmax,
+ w, &c__1, &c_b2, &a[j * a_dim1 + 1], &
+ c__1, &yt[1], &g[1], &aa[(j - 1) *
+ lda + 1], eps, &err, fatal, nout, &
+ c_true, (ftnlen)1);
+ errmax = max(errmax,err);
+/* If got really bad answer, report and return. */
+ if (*fatal) {
+ goto L130;
+ }
+/* L70: */
+ }
+ } else {
+/* Avoid repeating tests with M.le.0 or N.le.0. */
+ goto L110;
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+/* L100: */
+ }
+
+L110:
+ ;
+ }
+
+/* L120: */
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___293.ciunit = *nout;
+ s_wsfe(&io___293);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___294.ciunit = *nout;
+ s_wsfe(&io___294);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ goto L150;
+
+L130:
+ io___295.ciunit = *nout;
+ s_wsfe(&io___295);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L140:
+ io___296.ciunit = *nout;
+ s_wsfe(&io___296);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ io___297.ciunit = *nout;
+ s_wsfe(&io___297);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L150:
+ return 0;
+
+
+/* End of ZCHK4. */
+
+} /* zchk4_ */
+
+/* Subroutine */ int zchk5_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
+ alf, integer *ninc, integer *inc, integer *nmax, integer *incmax,
+ doublecomplex *a, doublecomplex *aa, doublecomplex *as, doublecomplex
+ *x, doublecomplex *xx, doublecomplex *xs, doublecomplex *y,
+ doublecomplex *yy, doublecomplex *ys, doublecomplex *yt, doublereal *
+ g, doublecomplex *z__, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ich[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,\002,f4.1,\002, X,\002,i2,\002, A,\002,i3,\002) "
+ " .\002)";
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,\002,f4.1,\002, X,\002,i2,\002, AP) "
+ " .\002)";
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublecomplex z__1;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, n;
+ doublecomplex w[1];
+ integer ia, ja, ic, nc, jj, lj, in, ix, ns, lx, laa, lda;
+ doublereal err;
+ extern logical lze_(doublecomplex *, doublecomplex *, integer *);
+ integer ldas;
+ logical same;
+ doublereal rals;
+ integer incx;
+ logical full;
+ extern /* Subroutine */ int zher_(char *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ logical null;
+ char uplo[1];
+ extern /* Subroutine */ int zhpr_(char *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *);
+ doublecomplex alpha;
+ logical isame[13];
+ extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *, integer *, logical *, doublecomplex *, ftnlen, ftnlen,
+ ftnlen);
+ integer nargs;
+ logical reset;
+ integer incxs;
+ extern /* Subroutine */ int zmvch_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublereal *, doublecomplex *, doublereal *,
+ doublereal *, logical *, integer *, logical *, ftnlen);
+ logical upper;
+ char uplos[1];
+ logical packed;
+ doublereal ralpha, errmax;
+ doublecomplex transl;
+ extern logical lzeres_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen);
+
+ /* Fortran I/O blocks */
+ static cilist io___326 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___327 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___328 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___331 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___338 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___339 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___340 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___341 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___342 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___343 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* Tests ZHER and ZHPR. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --inc;
+ --z__;
+ --g;
+ --yt;
+ --y;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ys;
+ --yy;
+ --xs;
+ --xx;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ full = *(unsigned char *)&sname[2] == 'E';
+ packed = *(unsigned char *)&sname[2] == 'P';
+/* Define the number of arguments. */
+ if (full) {
+ nargs = 7;
+ } else if (packed) {
+ nargs = 6;
+ }
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+/* Set LDA to 1 more than minimum value if room. */
+ lda = n;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L100;
+ }
+ if (packed) {
+ laa = n * (n + 1) / 2;
+ } else {
+ laa = lda * n;
+ }
+
+ for (ic = 1; ic <= 2; ++ic) {
+ *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];
+ upper = *(unsigned char *)uplo == 'U';
+
+ i__2 = *ninc;
+ for (ix = 1; ix <= i__2; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * n;
+
+/* Generate the vector X. */
+
+ transl.r = .5, transl.i = 0.;
+ i__3 = abs(incx);
+ i__4 = n - 1;
+ zmake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3,
+ &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1,
+ (ftnlen)1);
+ if (n > 1) {
+ i__3 = n / 2;
+ x[i__3].r = 0., x[i__3].i = 0.;
+ i__3 = abs(incx) * (n / 2 - 1) + 1;
+ xx[i__3].r = 0., xx[i__3].i = 0.;
+ }
+
+ i__3 = *nalf;
+ for (ia = 1; ia <= i__3; ++ia) {
+ i__4 = ia;
+ ralpha = alf[i__4].r;
+ z__1.r = ralpha, z__1.i = 0.;
+ alpha.r = z__1.r, alpha.i = z__1.i;
+ null = n <= 0 || ralpha == 0.;
+
+/* Generate the matrix A. */
+
+ transl.r = 0., transl.i = 0.;
+ i__4 = n - 1;
+ i__5 = n - 1;
+ zmake_(sname + 1, uplo, " ", &n, &n, &a[a_offset], nmax, &
+ aa[1], &lda, &i__4, &i__5, &reset, &transl, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ ns = n;
+ rals = ralpha;
+ i__4 = laa;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__;
+ i__6 = i__;
+ as[i__5].r = aa[i__6].r, as[i__5].i = aa[i__6].i;
+/* L10: */
+ }
+ ldas = lda;
+ i__4 = lx;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__;
+ i__6 = i__;
+ xs[i__5].r = xx[i__6].r, xs[i__5].i = xx[i__6].i;
+/* L20: */
+ }
+ incxs = incx;
+
+/* Call the subroutine. */
+
+ if (full) {
+ if (*trace) {
+ io___326.ciunit = *ntra;
+ s_wsfe(&io___326);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&ralpha, (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ zher_(uplo, &n, &ralpha, &xx[1], &incx, &aa[1], &lda);
+ } else if (packed) {
+ if (*trace) {
+ io___327.ciunit = *ntra;
+ s_wsfe(&io___327);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&ralpha, (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ zhpr_(uplo, &n, &ralpha, &xx[1], &incx, &aa[1]);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___328.ciunit = *nout;
+ s_wsfe(&io___328);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplo == *(unsigned char *)
+ uplos;
+ isame[1] = ns == n;
+ isame[2] = rals == ralpha;
+ isame[3] = lze_(&xs[1], &xx[1], &lx);
+ isame[4] = incxs == incx;
+ if (null) {
+ isame[5] = lze_(&as[1], &aa[1], &laa);
+ } else {
+ isame[5] = lzeres_(sname + 1, uplo, &n, &n, &as[1], &
+ aa[1], &lda, (ftnlen)2, (ftnlen)1);
+ }
+ if (! packed) {
+ isame[6] = ldas == lda;
+ }
+
+/* If data was incorrectly changed, report and return. */
+
+ same = TRUE_;
+ i__4 = nargs;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___331.ciunit = *nout;
+ s_wsfe(&io___331);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+/* L30: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+
+/* Check the result column by column. */
+
+ if (incx > 0) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__;
+ i__6 = i__;
+ z__[i__5].r = x[i__6].r, z__[i__5].i = x[i__6]
+ .i;
+/* L40: */
+ }
+ } else {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__;
+ i__6 = n - i__ + 1;
+ z__[i__5].r = x[i__6].r, z__[i__5].i = x[i__6]
+ .i;
+/* L50: */
+ }
+ }
+ ja = 1;
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ d_cnjg(&z__1, &z__[j]);
+ w[0].r = z__1.r, w[0].i = z__1.i;
+ if (upper) {
+ jj = 1;
+ lj = j;
+ } else {
+ jj = j;
+ lj = n - j + 1;
+ }
+ zmvch_("N", &lj, &c__1, &alpha, &z__[jj], &lj, w,
+ &c__1, &c_b2, &a[jj + j * a_dim1], &c__1,
+ &yt[1], &g[1], &aa[ja], eps, &err, fatal,
+ nout, &c_true, (ftnlen)1);
+ if (full) {
+ if (upper) {
+ ja += lda;
+ } else {
+ ja = ja + lda + 1;
+ }
+ } else {
+ ja += lj;
+ }
+ errmax = max(errmax,err);
+/* If got really bad answer, report and return. */
+ if (*fatal) {
+ goto L110;
+ }
+/* L60: */
+ }
+ } else {
+/* Avoid repeating tests if N.le.0. */
+ if (n <= 0) {
+ goto L100;
+ }
+ }
+
+/* L70: */
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___338.ciunit = *nout;
+ s_wsfe(&io___338);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___339.ciunit = *nout;
+ s_wsfe(&io___339);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ goto L130;
+
+L110:
+ io___340.ciunit = *nout;
+ s_wsfe(&io___340);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L120:
+ io___341.ciunit = *nout;
+ s_wsfe(&io___341);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (full) {
+ io___342.ciunit = *nout;
+ s_wsfe(&io___342);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ralpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (packed) {
+ io___343.ciunit = *nout;
+ s_wsfe(&io___343);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ralpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L130:
+ return 0;
+
+
+/* End of ZCHK5. */
+
+} /* zchk5_ */
+
+/* Subroutine */ int zchk6_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
+ alf, integer *ninc, integer *inc, integer *nmax, integer *incmax,
+ doublecomplex *a, doublecomplex *aa, doublecomplex *as, doublecomplex
+ *x, doublecomplex *xx, doublecomplex *xs, doublecomplex *y,
+ doublecomplex *yy, doublecomplex *ys, doublecomplex *yt, doublereal *
+ g, doublecomplex *z__, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ich[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,(\002,f4.1,\002,\002,f4.1,\002), X,\002,i2,\002, Y,\002,"
+ "i2,\002, A,\002,i3,\002) \002,\002 .\002)";
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002',\002,"
+ "i3,\002,(\002,f4.1,\002,\002,f4.1,\002), X,\002,i2,\002, Y,\002,"
+ "i2,\002, AP) \002,\002 .\002)";
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6, i__7;
+ doublecomplex z__1, z__2, z__3;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, n;
+ doublecomplex w[2];
+ integer ia, ja, ic, nc, jj, lj, in, ix, iy, ns, lx, ly, laa, lda;
+ doublecomplex als;
+ doublereal err;
+ extern logical lze_(doublecomplex *, doublecomplex *, integer *);
+ integer ldas;
+ logical same;
+ integer incx, incy;
+ logical full, null;
+ char uplo[1];
+ extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zhpr2_(char *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *);
+ doublecomplex alpha;
+ logical isame[13];
+ extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *, integer *, logical *, doublecomplex *, ftnlen, ftnlen,
+ ftnlen);
+ integer nargs;
+ logical reset;
+ integer incxs, incys;
+ extern /* Subroutine */ int zmvch_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublereal *, doublecomplex *, doublereal *,
+ doublereal *, logical *, integer *, logical *, ftnlen);
+ logical upper;
+ char uplos[1];
+ logical packed;
+ doublereal errmax;
+ doublecomplex transl;
+ extern logical lzeres_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen);
+
+ /* Fortran I/O blocks */
+ static cilist io___375 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___376 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___377 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___380 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___387 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___388 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___389 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___390 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___391 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___392 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* Tests ZHER2 and ZHPR2. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --inc;
+ z_dim1 = *nmax;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --g;
+ --yt;
+ --y;
+ --x;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ys;
+ --yy;
+ --xs;
+ --xx;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ full = *(unsigned char *)&sname[2] == 'E';
+ packed = *(unsigned char *)&sname[2] == 'P';
+/* Define the number of arguments. */
+ if (full) {
+ nargs = 9;
+ } else if (packed) {
+ nargs = 8;
+ }
+
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+/* Set LDA to 1 more than minimum value if room. */
+ lda = n;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L140;
+ }
+ if (packed) {
+ laa = n * (n + 1) / 2;
+ } else {
+ laa = lda * n;
+ }
+
+ for (ic = 1; ic <= 2; ++ic) {
+ *(unsigned char *)uplo = *(unsigned char *)&ich[ic - 1];
+ upper = *(unsigned char *)uplo == 'U';
+
+ i__2 = *ninc;
+ for (ix = 1; ix <= i__2; ++ix) {
+ incx = inc[ix];
+ lx = abs(incx) * n;
+
+/* Generate the vector X. */
+
+ transl.r = .5, transl.i = 0.;
+ i__3 = abs(incx);
+ i__4 = n - 1;
+ zmake_("GE", " ", " ", &c__1, &n, &x[1], &c__1, &xx[1], &i__3,
+ &c__0, &i__4, &reset, &transl, (ftnlen)2, (ftnlen)1,
+ (ftnlen)1);
+ if (n > 1) {
+ i__3 = n / 2;
+ x[i__3].r = 0., x[i__3].i = 0.;
+ i__3 = abs(incx) * (n / 2 - 1) + 1;
+ xx[i__3].r = 0., xx[i__3].i = 0.;
+ }
+
+ i__3 = *ninc;
+ for (iy = 1; iy <= i__3; ++iy) {
+ incy = inc[iy];
+ ly = abs(incy) * n;
+
+/* Generate the vector Y. */
+
+ transl.r = 0., transl.i = 0.;
+ i__4 = abs(incy);
+ i__5 = n - 1;
+ zmake_("GE", " ", " ", &c__1, &n, &y[1], &c__1, &yy[1], &
+ i__4, &c__0, &i__5, &reset, &transl, (ftnlen)2, (
+ ftnlen)1, (ftnlen)1);
+ if (n > 1) {
+ i__4 = n / 2;
+ y[i__4].r = 0., y[i__4].i = 0.;
+ i__4 = abs(incy) * (n / 2 - 1) + 1;
+ yy[i__4].r = 0., yy[i__4].i = 0.;
+ }
+
+ i__4 = *nalf;
+ for (ia = 1; ia <= i__4; ++ia) {
+ i__5 = ia;
+ alpha.r = alf[i__5].r, alpha.i = alf[i__5].i;
+ null = n <= 0 || alpha.r == 0. && alpha.i == 0.;
+
+/* Generate the matrix A. */
+
+ transl.r = 0., transl.i = 0.;
+ i__5 = n - 1;
+ i__6 = n - 1;
+ zmake_(sname + 1, uplo, " ", &n, &n, &a[a_offset],
+ nmax, &aa[1], &lda, &i__5, &i__6, &reset, &
+ transl, (ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ ns = n;
+ als.r = alpha.r, als.i = alpha.i;
+ i__5 = laa;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7].i;
+/* L10: */
+ }
+ ldas = lda;
+ i__5 = lx;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ xs[i__6].r = xx[i__7].r, xs[i__6].i = xx[i__7].i;
+/* L20: */
+ }
+ incxs = incx;
+ i__5 = ly;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ ys[i__6].r = yy[i__7].r, ys[i__6].i = yy[i__7].i;
+/* L30: */
+ }
+ incys = incy;
+
+/* Call the subroutine. */
+
+ if (full) {
+ if (*trace) {
+ io___375.ciunit = *ntra;
+ s_wsfe(&io___375);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ zher2_(uplo, &n, &alpha, &xx[1], &incx, &yy[1], &
+ incy, &aa[1], &lda);
+ } else if (packed) {
+ if (*trace) {
+ io___376.ciunit = *ntra;
+ s_wsfe(&io___376);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ zhpr2_(uplo, &n, &alpha, &xx[1], &incx, &yy[1], &
+ incy, &aa[1]);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___377.ciunit = *nout;
+ s_wsfe(&io___377);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L160;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplo == *(unsigned char *
+ )uplos;
+ isame[1] = ns == n;
+ isame[2] = als.r == alpha.r && als.i == alpha.i;
+ isame[3] = lze_(&xs[1], &xx[1], &lx);
+ isame[4] = incxs == incx;
+ isame[5] = lze_(&ys[1], &yy[1], &ly);
+ isame[6] = incys == incy;
+ if (null) {
+ isame[7] = lze_(&as[1], &aa[1], &laa);
+ } else {
+ isame[7] = lzeres_(sname + 1, uplo, &n, &n, &as[1]
+ , &aa[1], &lda, (ftnlen)2, (ftnlen)1);
+ }
+ if (! packed) {
+ isame[8] = ldas == lda;
+ }
+
+/* If data was incorrectly changed, report and return. */
+
+ same = TRUE_;
+ i__5 = nargs;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___380.ciunit = *nout;
+ s_wsfe(&io___380);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L160;
+ }
+
+ if (! null) {
+
+/* Check the result column by column. */
+
+ if (incx > 0) {
+ i__5 = n;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__ + z_dim1;
+ i__7 = i__;
+ z__[i__6].r = x[i__7].r, z__[i__6].i = x[
+ i__7].i;
+/* L50: */
+ }
+ } else {
+ i__5 = n;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__ + z_dim1;
+ i__7 = n - i__ + 1;
+ z__[i__6].r = x[i__7].r, z__[i__6].i = x[
+ i__7].i;
+/* L60: */
+ }
+ }
+ if (incy > 0) {
+ i__5 = n;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__ + (z_dim1 << 1);
+ i__7 = i__;
+ z__[i__6].r = y[i__7].r, z__[i__6].i = y[
+ i__7].i;
+/* L70: */
+ }
+ } else {
+ i__5 = n;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__ + (z_dim1 << 1);
+ i__7 = n - i__ + 1;
+ z__[i__6].r = y[i__7].r, z__[i__6].i = y[
+ i__7].i;
+/* L80: */
+ }
+ }
+ ja = 1;
+ i__5 = n;
+ for (j = 1; j <= i__5; ++j) {
+ d_cnjg(&z__2, &z__[j + (z_dim1 << 1)]);
+ z__1.r = alpha.r * z__2.r - alpha.i * z__2.i,
+ z__1.i = alpha.r * z__2.i + alpha.i *
+ z__2.r;
+ w[0].r = z__1.r, w[0].i = z__1.i;
+ d_cnjg(&z__2, &alpha);
+ d_cnjg(&z__3, &z__[j + z_dim1]);
+ z__1.r = z__2.r * z__3.r - z__2.i * z__3.i,
+ z__1.i = z__2.r * z__3.i + z__2.i *
+ z__3.r;
+ w[1].r = z__1.r, w[1].i = z__1.i;
+ if (upper) {
+ jj = 1;
+ lj = j;
+ } else {
+ jj = j;
+ lj = n - j + 1;
+ }
+ zmvch_("N", &lj, &c__2, &c_b2, &z__[jj +
+ z_dim1], nmax, w, &c__1, &c_b2, &a[jj
+ + j * a_dim1], &c__1, &yt[1], &g[1], &
+ aa[ja], eps, &err, fatal, nout, &
+ c_true, (ftnlen)1);
+ if (full) {
+ if (upper) {
+ ja += lda;
+ } else {
+ ja = ja + lda + 1;
+ }
+ } else {
+ ja += lj;
+ }
+ errmax = max(errmax,err);
+/* If got really bad answer, report and return. */
+ if (*fatal) {
+ goto L150;
+ }
+/* L90: */
+ }
+ } else {
+/* Avoid repeating tests with N.le.0. */
+ if (n <= 0) {
+ goto L140;
+ }
+ }
+
+/* L100: */
+ }
+
+/* L110: */
+ }
+
+/* L120: */
+ }
+
+/* L130: */
+ }
+
+L140:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___387.ciunit = *nout;
+ s_wsfe(&io___387);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___388.ciunit = *nout;
+ s_wsfe(&io___388);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ goto L170;
+
+L150:
+ io___389.ciunit = *nout;
+ s_wsfe(&io___389);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L160:
+ io___390.ciunit = *nout;
+ s_wsfe(&io___390);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (full) {
+ io___391.ciunit = *nout;
+ s_wsfe(&io___391);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (packed) {
+ io___392.ciunit = *nout;
+ s_wsfe(&io___392);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&incx, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&incy, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L170:
+ return 0;
+
+
+/* End of ZCHK6. */
+
+} /* zchk6_ */
+
+/* Subroutine */ int zchke_(integer *isnum, char *srnamt, integer *nout,
+ ftnlen srnamt_len)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE TESTS OF ERROR-E"
+ "XITS\002)";
+ static char fmt_9998[] = "(\002 ******* \002,a6,\002 FAILED THE TESTS OF"
+ " ERROR-EXITS *****\002,\002**\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublecomplex a[1] /* was [1][1] */, x[1], y[1], beta;
+ extern /* Subroutine */ int zher_(char *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zhpr_(char *, integer *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *), zher2_(char *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), zhpr2_(char *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *);
+ doublecomplex alpha;
+ extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zgbmv_(char *, integer *, integer *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zhbmv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zgemv_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *), zhemv_(char
+ *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zgeru_(integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), ztbmv_(char *, char *, char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zhpmv_(char *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *), ztbsv_(char
+ *, char *, char *, integer *, integer *, doublecomplex *, integer
+ *, doublecomplex *, integer *), ztpmv_(
+ char *, char *, char *, integer *, doublecomplex *, doublecomplex
+ *, integer *), ztrmv_(char *, char *,
+ char *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), ztpsv_(char *, char *, char *,
+ integer *, doublecomplex *, doublecomplex *, integer *), ztrsv_(char *, char *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal ralpha;
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *);
+
+ /* Fortran I/O blocks */
+ static cilist io___399 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___400 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* Tests the error exits from the Level 2 Blas. */
+/* Requires a special version of the error-handling routine XERBLA. */
+/* ALPHA, RALPHA, BETA, A, X and Y should not need to be defined. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Subroutines .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+/* OK is set to .FALSE. by the special version of XERBLA or by CHKXER */
+/* if anything is wrong. */
+ infoc_1.ok = TRUE_;
+/* LERR is set to .TRUE. by the special version of XERBLA each time */
+/* it is called, and is then tested and re-set by CHKXER. */
+ infoc_1.lerr = FALSE_;
+ switch (*isnum) {
+ case 1: goto L10;
+ case 2: goto L20;
+ case 3: goto L30;
+ case 4: goto L40;
+ case 5: goto L50;
+ case 6: goto L60;
+ case 7: goto L70;
+ case 8: goto L80;
+ case 9: goto L90;
+ case 10: goto L100;
+ case 11: goto L110;
+ case 12: goto L120;
+ case 13: goto L130;
+ case 14: goto L140;
+ case 15: goto L150;
+ case 16: goto L160;
+ case 17: goto L170;
+ }
+L10:
+ infoc_1.infot = 1;
+ zgemv_("/", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ zgemv_("N", &c_n1, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zgemv_("N", &c__0, &c_n1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ zgemv_("N", &c__2, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ zgemv_("N", &c__0, &c__0, &alpha, a, &c__1, x, &c__0, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ zgemv_("N", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L20:
+ infoc_1.infot = 1;
+ zgbmv_("/", &c__0, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ zgbmv_("N", &c_n1, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zgbmv_("N", &c__0, &c_n1, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zgbmv_("N", &c__0, &c__0, &c_n1, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ zgbmv_("N", &c__2, &c__0, &c__0, &c_n1, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ zgbmv_("N", &c__0, &c__0, &c__1, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ zgbmv_("N", &c__0, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__0, &beta,
+ y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ zgbmv_("N", &c__0, &c__0, &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta,
+ y, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L30:
+ infoc_1.infot = 1;
+ zhemv_("/", &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ zhemv_("U", &c_n1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ zhemv_("U", &c__2, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zhemv_("U", &c__0, &alpha, a, &c__1, x, &c__0, &beta, y, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ zhemv_("U", &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__0)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L40:
+ infoc_1.infot = 1;
+ zhbmv_("/", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ zhbmv_("U", &c_n1, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zhbmv_("U", &c__0, &c_n1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ zhbmv_("U", &c__0, &c__1, &alpha, a, &c__1, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ zhbmv_("U", &c__0, &c__0, &alpha, a, &c__1, x, &c__0, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ zhbmv_("U", &c__0, &c__0, &alpha, a, &c__1, x, &c__1, &beta, y, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L50:
+ infoc_1.infot = 1;
+ zhpmv_("/", &c__0, &alpha, a, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ zhpmv_("U", &c_n1, &alpha, a, x, &c__1, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ zhpmv_("U", &c__0, &alpha, a, x, &c__0, &beta, y, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ zhpmv_("U", &c__0, &alpha, a, x, &c__1, &beta, y, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L60:
+ infoc_1.infot = 1;
+ ztrmv_("/", "N", "N", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ ztrmv_("U", "/", "N", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ztrmv_("U", "N", "/", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ztrmv_("U", "N", "N", &c_n1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrmv_("U", "N", "N", &c__2, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ ztrmv_("U", "N", "N", &c__0, a, &c__1, x, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L70:
+ infoc_1.infot = 1;
+ ztbmv_("/", "N", "N", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ ztbmv_("U", "/", "N", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ztbmv_("U", "N", "/", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ztbmv_("U", "N", "N", &c_n1, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztbmv_("U", "N", "N", &c__0, &c_n1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ ztbmv_("U", "N", "N", &c__0, &c__1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztbmv_("U", "N", "N", &c__0, &c__0, a, &c__1, x, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L80:
+ infoc_1.infot = 1;
+ ztpmv_("/", "N", "N", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ ztpmv_("U", "/", "N", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ztpmv_("U", "N", "/", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ztpmv_("U", "N", "N", &c_n1, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ ztpmv_("U", "N", "N", &c__0, a, x, &c__0)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L90:
+ infoc_1.infot = 1;
+ ztrsv_("/", "N", "N", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ ztrsv_("U", "/", "N", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ztrsv_("U", "N", "/", &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ztrsv_("U", "N", "N", &c_n1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrsv_("U", "N", "N", &c__2, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ ztrsv_("U", "N", "N", &c__0, a, &c__1, x, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L100:
+ infoc_1.infot = 1;
+ ztbsv_("/", "N", "N", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ ztbsv_("U", "/", "N", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ztbsv_("U", "N", "/", &c__0, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ztbsv_("U", "N", "N", &c_n1, &c__0, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztbsv_("U", "N", "N", &c__0, &c_n1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ ztbsv_("U", "N", "N", &c__0, &c__1, a, &c__1, x, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztbsv_("U", "N", "N", &c__0, &c__0, a, &c__1, x, &c__0);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L110:
+ infoc_1.infot = 1;
+ ztpsv_("/", "N", "N", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ ztpsv_("U", "/", "N", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ztpsv_("U", "N", "/", &c__0, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ztpsv_("U", "N", "N", &c_n1, a, x, &c__1)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ ztpsv_("U", "N", "N", &c__0, a, x, &c__0)
+ ;
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L120:
+ infoc_1.infot = 1;
+ zgerc_(&c_n1, &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ zgerc_(&c__0, &c_n1, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ zgerc_(&c__0, &c__0, &alpha, x, &c__0, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zgerc_(&c__0, &c__0, &alpha, x, &c__1, y, &c__0, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ zgerc_(&c__2, &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L130:
+ infoc_1.infot = 1;
+ zgeru_(&c_n1, &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ zgeru_(&c__0, &c_n1, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ zgeru_(&c__0, &c__0, &alpha, x, &c__0, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zgeru_(&c__0, &c__0, &alpha, x, &c__1, y, &c__0, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ zgeru_(&c__2, &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L140:
+ infoc_1.infot = 1;
+ zher_("/", &c__0, &ralpha, x, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ zher_("U", &c_n1, &ralpha, x, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ zher_("U", &c__0, &ralpha, x, &c__0, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zher_("U", &c__2, &ralpha, x, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L150:
+ infoc_1.infot = 1;
+ zhpr_("/", &c__0, &ralpha, x, &c__1, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ zhpr_("U", &c_n1, &ralpha, x, &c__1, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ zhpr_("U", &c__0, &ralpha, x, &c__0, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L160:
+ infoc_1.infot = 1;
+ zher2_("/", &c__0, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ zher2_("U", &c_n1, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ zher2_("U", &c__0, &alpha, x, &c__0, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zher2_("U", &c__0, &alpha, x, &c__1, y, &c__0, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ zher2_("U", &c__2, &alpha, x, &c__1, y, &c__1, a, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L180;
+L170:
+ infoc_1.infot = 1;
+ zhpr2_("/", &c__0, &alpha, x, &c__1, y, &c__1, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ zhpr2_("U", &c_n1, &alpha, x, &c__1, y, &c__1, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ zhpr2_("U", &c__0, &alpha, x, &c__0, y, &c__1, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zhpr2_("U", &c__0, &alpha, x, &c__1, y, &c__0, a);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+
+L180:
+ if (infoc_1.ok) {
+ io___399.ciunit = *nout;
+ s_wsfe(&io___399);
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ } else {
+ io___400.ciunit = *nout;
+ s_wsfe(&io___400);
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ }
+ return 0;
+
+
+/* End of ZCHKE. */
+
+} /* zchke_ */
+
+/* Subroutine */ int zmake_(char *type__, char *uplo, char *diag, integer *m,
+ integer *n, doublecomplex *a, integer *nmax, doublecomplex *aa,
+ integer *lda, integer *kl, integer *ku, logical *reset, doublecomplex
+ *transl, ftnlen type_len, ftnlen uplo_len, ftnlen diag_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ integer s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer i__, j, i1, i2, i3, jj, kk;
+ logical gen, tri, sym;
+ integer ibeg, iend, ioff;
+ extern /* Double Complex */ VOID zbeg_(doublecomplex *, logical *);
+ logical unit, lower, upper;
+
+
+/* Generates values for an M by N matrix A within the bandwidth */
+/* defined by KL and KU. */
+/* Stores the values in the array AA in the data structure required */
+/* by the routine, with unwanted elements set to rogue value. */
+
+/* TYPE is 'GE', 'GB', 'HE', 'HB', 'HP', 'TR', 'TB' OR 'TP'. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. External Functions .. */
+/* .. Intrinsic Functions .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --aa;
+
+ /* Function Body */
+ gen = *(unsigned char *)type__ == 'G';
+ sym = *(unsigned char *)type__ == 'H';
+ tri = *(unsigned char *)type__ == 'T';
+ upper = (sym || tri) && *(unsigned char *)uplo == 'U';
+ lower = (sym || tri) && *(unsigned char *)uplo == 'L';
+ unit = tri && *(unsigned char *)diag == 'U';
+
+/* Generate data in array A. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (gen || upper && i__ <= j || lower && i__ >= j) {
+ if (i__ <= j && j - i__ <= *ku || i__ >= j && i__ - j <= *kl)
+ {
+ i__3 = i__ + j * a_dim1;
+ zbeg_(&z__2, reset);
+ z__1.r = z__2.r + transl->r, z__1.i = z__2.i + transl->i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ } else {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ }
+ if (i__ != j) {
+ if (sym) {
+ i__3 = j + i__ * a_dim1;
+ d_cnjg(&z__1, &a[i__ + j * a_dim1]);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ } else if (tri) {
+ i__3 = j + i__ * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ }
+ }
+ }
+/* L10: */
+ }
+ if (sym) {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ d__1 = a[i__3].r;
+ z__1.r = d__1, z__1.i = 0.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ }
+ if (tri) {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ z__1.r = a[i__3].r + 1., z__1.i = a[i__3].i + 0.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ }
+ if (unit) {
+ i__2 = j + j * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+ }
+/* L20: */
+ }
+
+/* Store elements in array AS in data structure required by routine. */
+
+ if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ i__4 = i__ + j * a_dim1;
+ aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
+/* L30: */
+ }
+ i__2 = *lda;
+ for (i__ = *m + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ aa[i__3].r = -1e10, aa[i__3].i = 1e10;
+/* L40: */
+ }
+/* L50: */
+ }
+ } else if (s_cmp(type__, "GB", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *ku + 1 - j;
+ for (i1 = 1; i1 <= i__2; ++i1) {
+ i__3 = i1 + (j - 1) * *lda;
+ aa[i__3].r = -1e10, aa[i__3].i = 1e10;
+/* L60: */
+ }
+/* Computing MIN */
+ i__3 = *kl + *ku + 1, i__4 = *ku + 1 + *m - j;
+ i__2 = min(i__3,i__4);
+ for (i2 = i1; i2 <= i__2; ++i2) {
+ i__3 = i2 + (j - 1) * *lda;
+ i__4 = i2 + j - *ku - 1 + j * a_dim1;
+ aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
+/* L70: */
+ }
+ i__2 = *lda;
+ for (i3 = i2; i3 <= i__2; ++i3) {
+ i__3 = i3 + (j - 1) * *lda;
+ aa[i__3].r = -1e10, aa[i__3].i = 1e10;
+/* L80: */
+ }
+/* L90: */
+ }
+ } else if (s_cmp(type__, "HE", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
+ "TR", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ ibeg = 1;
+ if (unit) {
+ iend = j - 1;
+ } else {
+ iend = j;
+ }
+ } else {
+ if (unit) {
+ ibeg = j + 1;
+ } else {
+ ibeg = j;
+ }
+ iend = *n;
+ }
+ i__2 = ibeg - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ aa[i__3].r = -1e10, aa[i__3].i = 1e10;
+/* L100: */
+ }
+ i__2 = iend;
+ for (i__ = ibeg; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ i__4 = i__ + j * a_dim1;
+ aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
+/* L110: */
+ }
+ i__2 = *lda;
+ for (i__ = iend + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ aa[i__3].r = -1e10, aa[i__3].i = 1e10;
+/* L120: */
+ }
+ if (sym) {
+ jj = j + (j - 1) * *lda;
+ i__2 = jj;
+ i__3 = jj;
+ d__1 = aa[i__3].r;
+ z__1.r = d__1, z__1.i = -1e10;
+ aa[i__2].r = z__1.r, aa[i__2].i = z__1.i;
+ }
+/* L130: */
+ }
+ } else if (s_cmp(type__, "HB", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
+ "TB", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ kk = *kl + 1;
+/* Computing MAX */
+ i__2 = 1, i__3 = *kl + 2 - j;
+ ibeg = max(i__2,i__3);
+ if (unit) {
+ iend = *kl;
+ } else {
+ iend = *kl + 1;
+ }
+ } else {
+ kk = 1;
+ if (unit) {
+ ibeg = 2;
+ } else {
+ ibeg = 1;
+ }
+/* Computing MIN */
+ i__2 = *kl + 1, i__3 = *m + 1 - j;
+ iend = min(i__2,i__3);
+ }
+ i__2 = ibeg - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ aa[i__3].r = -1e10, aa[i__3].i = 1e10;
+/* L140: */
+ }
+ i__2 = iend;
+ for (i__ = ibeg; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ i__4 = i__ + j - kk + j * a_dim1;
+ aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
+/* L150: */
+ }
+ i__2 = *lda;
+ for (i__ = iend + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ aa[i__3].r = -1e10, aa[i__3].i = 1e10;
+/* L160: */
+ }
+ if (sym) {
+ jj = kk + (j - 1) * *lda;
+ i__2 = jj;
+ i__3 = jj;
+ d__1 = aa[i__3].r;
+ z__1.r = d__1, z__1.i = -1e10;
+ aa[i__2].r = z__1.r, aa[i__2].i = z__1.i;
+ }
+/* L170: */
+ }
+ } else if (s_cmp(type__, "HP", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
+ "TP", (ftnlen)2, (ftnlen)2) == 0) {
+ ioff = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ ibeg = 1;
+ iend = j;
+ } else {
+ ibeg = j;
+ iend = *n;
+ }
+ i__2 = iend;
+ for (i__ = ibeg; i__ <= i__2; ++i__) {
+ ++ioff;
+ i__3 = ioff;
+ i__4 = i__ + j * a_dim1;
+ aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
+ if (i__ == j) {
+ if (unit) {
+ i__3 = ioff;
+ aa[i__3].r = -1e10, aa[i__3].i = 1e10;
+ }
+ if (sym) {
+ i__3 = ioff;
+ i__4 = ioff;
+ d__1 = aa[i__4].r;
+ z__1.r = d__1, z__1.i = -1e10;
+ aa[i__3].r = z__1.r, aa[i__3].i = z__1.i;
+ }
+ }
+/* L180: */
+ }
+/* L190: */
+ }
+ }
+ return 0;
+
+/* End of ZMAKE. */
+
+} /* zmake_ */
+
+/* Subroutine */ int zmvch_(char *trans, integer *m, integer *n,
+ doublecomplex *alpha, doublecomplex *a, integer *nmax, doublecomplex *
+ x, integer *incx, doublecomplex *beta, doublecomplex *y, integer *
+ incy, doublecomplex *yt, doublereal *g, doublecomplex *yy, doublereal
+ *eps, doublereal *err, logical *fatal, integer *nout, logical *mv,
+ ftnlen trans_len)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
+ " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 "
+ " EXPECTED RE\002,\002SULT COMPUTED R"
+ "ESULT\002)";
+ static char fmt_9998[] = "(1x,i7,2(\002 (\002,g15.6,\002,\002,g15.6,"
+ "\002)\002))";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ double z_abs(doublecomplex *), sqrt(doublereal);
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, ml, nl, iy, jx, kx, ky;
+ doublereal erri;
+ logical tran, ctran;
+ integer incxl, incyl;
+
+ /* Fortran I/O blocks */
+ static cilist io___430 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___431 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___432 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* Checks the results of the computational tests. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Intrinsic Functions .. */
+/* .. Statement Functions .. */
+/* .. Statement Function definitions .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+ --yt;
+ --g;
+ --yy;
+
+ /* Function Body */
+ tran = *(unsigned char *)trans == 'T';
+ ctran = *(unsigned char *)trans == 'C';
+ if (tran || ctran) {
+ ml = *n;
+ nl = *m;
+ } else {
+ ml = *m;
+ nl = *n;
+ }
+ if (*incx < 0) {
+ kx = nl;
+ incxl = -1;
+ } else {
+ kx = 1;
+ incxl = 1;
+ }
+ if (*incy < 0) {
+ ky = ml;
+ incyl = -1;
+ } else {
+ ky = 1;
+ incyl = 1;
+ }
+
+/* Compute expected result in YT using data in A, X and Y. */
+/* Compute gauges in G. */
+
+ iy = ky;
+ i__1 = ml;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ yt[i__2].r = 0., yt[i__2].i = 0.;
+ g[iy] = 0.;
+ jx = kx;
+ if (tran) {
+ i__2 = nl;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = iy;
+ i__4 = iy;
+ i__5 = j + i__ * a_dim1;
+ i__6 = jx;
+ z__2.r = a[i__5].r * x[i__6].r - a[i__5].i * x[i__6].i,
+ z__2.i = a[i__5].r * x[i__6].i + a[i__5].i * x[i__6]
+ .r;
+ z__1.r = yt[i__4].r + z__2.r, z__1.i = yt[i__4].i + z__2.i;
+ yt[i__3].r = z__1.r, yt[i__3].i = z__1.i;
+ i__3 = j + i__ * a_dim1;
+ i__4 = jx;
+ g[iy] += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[j
+ + i__ * a_dim1]), abs(d__2))) * ((d__3 = x[i__4].r,
+ abs(d__3)) + (d__4 = d_imag(&x[jx]), abs(d__4)));
+ jx += incxl;
+/* L10: */
+ }
+ } else if (ctran) {
+ i__2 = nl;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = iy;
+ i__4 = iy;
+ d_cnjg(&z__3, &a[j + i__ * a_dim1]);
+ i__5 = jx;
+ z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i, z__2.i =
+ z__3.r * x[i__5].i + z__3.i * x[i__5].r;
+ z__1.r = yt[i__4].r + z__2.r, z__1.i = yt[i__4].i + z__2.i;
+ yt[i__3].r = z__1.r, yt[i__3].i = z__1.i;
+ i__3 = j + i__ * a_dim1;
+ i__4 = jx;
+ g[iy] += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[j
+ + i__ * a_dim1]), abs(d__2))) * ((d__3 = x[i__4].r,
+ abs(d__3)) + (d__4 = d_imag(&x[jx]), abs(d__4)));
+ jx += incxl;
+/* L20: */
+ }
+ } else {
+ i__2 = nl;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = iy;
+ i__4 = iy;
+ i__5 = i__ + j * a_dim1;
+ i__6 = jx;
+ z__2.r = a[i__5].r * x[i__6].r - a[i__5].i * x[i__6].i,
+ z__2.i = a[i__5].r * x[i__6].i + a[i__5].i * x[i__6]
+ .r;
+ z__1.r = yt[i__4].r + z__2.r, z__1.i = yt[i__4].i + z__2.i;
+ yt[i__3].r = z__1.r, yt[i__3].i = z__1.i;
+ i__3 = i__ + j * a_dim1;
+ i__4 = jx;
+ g[iy] += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2))) * ((d__3 = x[i__4].r,
+ abs(d__3)) + (d__4 = d_imag(&x[jx]), abs(d__4)));
+ jx += incxl;
+/* L30: */
+ }
+ }
+ i__2 = iy;
+ i__3 = iy;
+ z__2.r = alpha->r * yt[i__3].r - alpha->i * yt[i__3].i, z__2.i =
+ alpha->r * yt[i__3].i + alpha->i * yt[i__3].r;
+ i__4 = iy;
+ z__3.r = beta->r * y[i__4].r - beta->i * y[i__4].i, z__3.i = beta->r *
+ y[i__4].i + beta->i * y[i__4].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ yt[i__2].r = z__1.r, yt[i__2].i = z__1.i;
+ i__2 = iy;
+ g[iy] = ((d__1 = alpha->r, abs(d__1)) + (d__2 = d_imag(alpha), abs(
+ d__2))) * g[iy] + ((d__3 = beta->r, abs(d__3)) + (d__4 =
+ d_imag(beta), abs(d__4))) * ((d__5 = y[i__2].r, abs(d__5)) + (
+ d__6 = d_imag(&y[iy]), abs(d__6)));
+ iy += incyl;
+/* L40: */
+ }
+
+/* Compute the error ratio for this result. */
+
+ *err = 0.;
+ i__1 = ml;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = (i__ - 1) * abs(*incy) + 1;
+ z__1.r = yt[i__2].r - yy[i__3].r, z__1.i = yt[i__2].i - yy[i__3].i;
+ erri = z_abs(&z__1) / *eps;
+ if (g[i__] != 0.) {
+ erri /= g[i__];
+ }
+ *err = max(*err,erri);
+ if (*err * sqrt(*eps) >= 1.) {
+ goto L60;
+ }
+/* L50: */
+ }
+/* If the loop completes, all results are at least half accurate. */
+ goto L80;
+
+/* Report fatal error. */
+
+L60:
+ *fatal = TRUE_;
+ io___430.ciunit = *nout;
+ s_wsfe(&io___430);
+ e_wsfe();
+ i__1 = ml;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*mv) {
+ io___431.ciunit = *nout;
+ s_wsfe(&io___431);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&yt[i__], (ftnlen)sizeof(doublereal));
+ do_fio(&c__2, (char *)&yy[(i__ - 1) * abs(*incy) + 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___432.ciunit = *nout;
+ s_wsfe(&io___432);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&yy[(i__ - 1) * abs(*incy) + 1], (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__2, (char *)&yt[i__], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+/* L70: */
+ }
+
+L80:
+ return 0;
+
+
+/* End of ZMVCH. */
+
+} /* zmvch_ */
+
+logical lze_(doublecomplex *ri, doublecomplex *rj, integer *lr)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ logical ret_val;
+
+ /* Local variables */
+ integer i__;
+
+
+/* Tests if two arrays are identical. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ --rj;
+ --ri;
+
+ /* Function Body */
+ i__1 = *lr;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ if (ri[i__2].r != rj[i__3].r || ri[i__2].i != rj[i__3].i) {
+ goto L20;
+ }
+/* L10: */
+ }
+ ret_val = TRUE_;
+ goto L30;
+L20:
+ ret_val = FALSE_;
+L30:
+ return ret_val;
+
+/* End of LZE. */
+
+} /* lze_ */
+
+logical lzeres_(char *type__, char *uplo, integer *m, integer *n,
+ doublecomplex *aa, doublecomplex *as, integer *lda, ftnlen type_len,
+ ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2, i__3, i__4;
+ logical ret_val;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer i__, j, ibeg, iend;
+ logical upper;
+
+
+/* Tests if selected elements in two arrays are equal. */
+
+/* TYPE is 'GE', 'HE' or 'HP'. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ as_dim1 = *lda;
+ as_offset = 1 + as_dim1;
+ as -= as_offset;
+ aa_dim1 = *lda;
+ aa_offset = 1 + aa_dim1;
+ aa -= aa_offset;
+
+ /* Function Body */
+ upper = *(unsigned char *)uplo == 'U';
+ if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *lda;
+ for (i__ = *m + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * aa_dim1;
+ i__4 = i__ + j * as_dim1;
+ if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) {
+ goto L70;
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (s_cmp(type__, "HE", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ ibeg = 1;
+ iend = j;
+ } else {
+ ibeg = j;
+ iend = *n;
+ }
+ i__2 = ibeg - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * aa_dim1;
+ i__4 = i__ + j * as_dim1;
+ if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) {
+ goto L70;
+ }
+/* L30: */
+ }
+ i__2 = *lda;
+ for (i__ = iend + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * aa_dim1;
+ i__4 = i__ + j * as_dim1;
+ if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) {
+ goto L70;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+/* L60: */
+ ret_val = TRUE_;
+ goto L80;
+L70:
+ ret_val = FALSE_;
+L80:
+ return ret_val;
+
+/* End of LZERES. */
+
+} /* lzeres_ */
+
+/* Double Complex */ VOID zbeg_(doublecomplex * ret_val, logical *reset)
+{
+ /* System generated locals */
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Local variables */
+ static integer i__, j, ic, mi, mj;
+
+
+/* Generates complex numbers as pairs of random numbers uniformly */
+/* distributed between -0.5 and 0.5. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Local Scalars .. */
+/* .. Save statement .. */
+/* .. Intrinsic Functions .. */
+/* .. Executable Statements .. */
+ if (*reset) {
+/* Initialize local variables. */
+ mi = 891;
+ mj = 457;
+ i__ = 7;
+ j = 7;
+ ic = 0;
+ *reset = FALSE_;
+ }
+
+/* The sequence of values of I or J is bounded between 1 and 999. */
+/* If initial I or J = 1,2,3,6,7 or 9, the period will be 50. */
+/* If initial I or J = 4 or 8, the period will be 25. */
+/* If initial I or J = 5, the period will be 10. */
+/* IC is used to break up the period by skipping 1 value of I or J */
+/* in 6. */
+
+ ++ic;
+L10:
+ i__ *= mi;
+ j *= mj;
+ i__ -= i__ / 1000 * 1000;
+ j -= j / 1000 * 1000;
+ if (ic >= 5) {
+ ic = 0;
+ goto L10;
+ }
+ d__1 = (i__ - 500) / 1001.;
+ d__2 = (j - 500) / 1001.;
+ z__1.r = d__1, z__1.i = d__2;
+ ret_val->r = z__1.r, ret_val->i = z__1.i;
+ return ;
+
+/* End of ZBEG. */
+
+} /* zbeg_ */
+
+doublereal ddiff_(doublereal *x, doublereal *y)
+{
+ /* System generated locals */
+ doublereal ret_val;
+
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+
+/* .. Scalar Arguments .. */
+/* .. Executable Statements .. */
+ ret_val = *x - *y;
+ return ret_val;
+
+/* End of DDIFF. */
+
+} /* ddiff_ */
+
+/* Subroutine */ int chkxer_(char *srnamt, integer *infot, integer *nout,
+ logical *lerr, logical *ok)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ***** ILLEGAL VALUE OF PARAMETER NUMBER"
+ " \002,i2,\002 NOT D\002,\002ETECTED BY \002,a6,\002 *****\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___444 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* Tests whether XERBLA has detected an error when it should. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Executable Statements .. */
+ if (! (*lerr)) {
+ io___444.ciunit = *nout;
+ s_wsfe(&io___444);
+ do_fio(&c__1, (char *)&(*infot), (ftnlen)sizeof(integer));
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ *ok = FALSE_;
+ }
+ *lerr = FALSE_;
+ return 0;
+
+
+/* End of CHKXER. */
+
+} /* chkxer_ */
+
+/* Subroutine */ int xerbla_(char *srname, integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* XERBLA WAS CALLED WITH INFO ="
+ " \002,i6,\002 INSTEAD\002,\002 OF \002,i2,\002 *******\002)";
+ static char fmt_9997[] = "(\002 ******* XERBLA WAS CALLED WITH INFO ="
+ " \002,i6,\002 *******\002)";
+ static char fmt_9998[] = "(\002 ******* XERBLA WAS CALLED WITH SRNAME ="
+ " \002,a6,\002 INSTE\002,\002AD OF \002,a6,\002 *******\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Fortran I/O blocks */
+ static cilist io___445 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___446 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___447 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* This is a special version of XERBLA to be used only as part of */
+/* the test program for testing error exits from the Level 2 BLAS */
+/* routines. */
+
+/* XERBLA is an error handler for the Level 2 BLAS routines. */
+
+/* It is called by the Level 2 BLAS routines if an input parameter is */
+/* invalid. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+ infoc_2.lerr = TRUE_;
+ if (*info != infoc_2.infot) {
+ if (infoc_2.infot != 0) {
+ io___445.ciunit = infoc_2.nout;
+ s_wsfe(&io___445);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&infoc_2.infot, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___446.ciunit = infoc_2.nout;
+ s_wsfe(&io___446);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ infoc_2.ok = FALSE_;
+ }
+ if (s_cmp(srname, srnamc_1.srnamt, (ftnlen)6, (ftnlen)6) != 0) {
+ io___447.ciunit = infoc_2.nout;
+ s_wsfe(&io___447);
+ do_fio(&c__1, srname, (ftnlen)6);
+ do_fio(&c__1, srnamc_1.srnamt, (ftnlen)6);
+ e_wsfe();
+ infoc_2.ok = FALSE_;
+ }
+ return 0;
+
+
+/* End of XERBLA */
+
+} /* xerbla_ */
+
+/* Main program alias */ int zblat2_ () { MAIN__ (); return 0; }
diff --git a/BLAS/TESTING/zblat3.c b/BLAS/TESTING/zblat3.c
new file mode 100644
index 0000000..756efab
--- /dev/null
+++ b/BLAS/TESTING/zblat3.c
@@ -0,0 +1,5457 @@
+/* zblat3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+union {
+ struct {
+ integer infot, noutc;
+ logical ok, lerr;
+ } _1;
+ struct {
+ integer infot, nout;
+ logical ok, lerr;
+ } _2;
+} infoc_;
+
+#define infoc_1 (infoc_._1)
+#define infoc_2 (infoc_._2)
+
+struct {
+ char srnamt[6];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__9 = 9;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__8 = 8;
+static integer c__5 = 5;
+static integer c__65 = 65;
+static integer c__7 = 7;
+static integer c__2 = 2;
+static doublereal c_b89 = 1.;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Initialized data */
+
+ static char snames[6*9] = "ZGEMM " "ZHEMM " "ZSYMM " "ZTRMM " "ZTRSM "
+ "ZHERK " "ZSYRK " "ZHER2K" "ZSYR2K";
+
+ /* Format strings */
+ static char fmt_9997[] = "(\002 NUMBER OF VALUES OF \002,a,\002 IS LESS "
+ "THAN 1 OR GREATER \002,\002THAN \002,i2)";
+ static char fmt_9996[] = "(\002 VALUE OF N IS LESS THAN 0 OR GREATER THA"
+ "N \002,i2)";
+ static char fmt_9995[] = "(\002 TESTS OF THE COMPLEX*16 LEVEL 3 BL"
+ "AS\002,//\002 THE F\002,\002OLLOWING PARAMETER VALUES WILL BE US"
+ "ED:\002)";
+ static char fmt_9994[] = "(\002 FOR N \002,9i6)";
+ static char fmt_9993[] = "(\002 FOR ALPHA \002,7(\002(\002,f4"
+ ".1,\002,\002,f4.1,\002) \002,:))";
+ static char fmt_9992[] = "(\002 FOR BETA \002,7(\002(\002,f4"
+ ".1,\002,\002,f4.1,\002) \002,:))";
+ static char fmt_9984[] = "(\002 ERROR-EXITS WILL NOT BE TESTED\002)";
+ static char fmt_9999[] = "(\002 ROUTINES PASS COMPUTATIONAL TESTS IF TES"
+ "T RATIO IS LES\002,\002S THAN\002,f8.2)";
+ static char fmt_9988[] = "(a6,l2)";
+ static char fmt_9990[] = "(\002 SUBPROGRAM NAME \002,a6,\002 NOT RECOGNI"
+ "ZED\002,/\002 ******* T\002,\002ESTS ABANDONED *******\002)";
+ static char fmt_9998[] = "(\002 RELATIVE MACHINE PRECISION IS TAKEN TO"
+ " BE\002,1p,d9.1)";
+ static char fmt_9989[] = "(\002 ERROR IN ZMMCH - IN-LINE DOT PRODUCTS A"
+ "RE BEING EVALU\002,\002ATED WRONGLY.\002,/\002 ZMMCH WAS CALLED "
+ "WITH TRANSA = \002,a1,\002 AND TRANSB = \002,a1,/\002 AND RETURN"
+ "ED SAME = \002,l1,\002 AND \002,\002ERR = \002,f12.3,\002.\002,"
+ "/\002 THIS MAY BE DUE TO FAULTS IN THE \002,\002ARITHMETIC OR TH"
+ "E COMPILER.\002,/\002 ******* TESTS ABANDONED \002,\002******"
+ "*\002)";
+ static char fmt_9987[] = "(1x,a6,\002 WAS NOT TESTED\002)";
+ static char fmt_9986[] = "(/\002 END OF TESTS\002)";
+ static char fmt_9985[] = "(/\002 ******* FATAL ERROR - TESTS ABANDONED *"
+ "******\002)";
+ static char fmt_9991[] = "(\002 AMEND DATA FILE OR INCREASE ARRAY SIZES "
+ "IN PROGRAM\002,/\002 ******* TESTS ABANDONED *******\002)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1;
+ olist o__1;
+ cllist cl__1;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void), f_open(olist *), s_wsfe(cilist *), do_fio(integer *,
+ char *, ftnlen), e_wsfe(void), s_wsle(cilist *), e_wsle(void),
+ s_rsfe(cilist *), e_rsfe(void), s_cmp(char *, char *, ftnlen,
+ ftnlen);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+ integer f_clos(cllist *);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublecomplex c__[4225] /* was [65][65] */;
+ doublereal g[65];
+ integer i__, j, n;
+ doublecomplex w[130], aa[4225], ab[8450] /* was [65][130] */, bb[4225],
+ cc[4225], as[4225], bs[4225], cs[4225], ct[65], alf[7], bet[7];
+ doublereal eps, err;
+ extern logical lze_(doublecomplex *, doublecomplex *, integer *);
+ integer nalf, idim[9];
+ logical same;
+ integer nbet, ntra;
+ logical rewi;
+ integer nout;
+ extern /* Subroutine */ int zchk1_(char *, doublereal *, doublereal *,
+ integer *, integer *, logical *, logical *, logical *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+ , doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
+ ftnlen), zchk2_(char *, doublereal *, doublereal *, integer *,
+ integer *, logical *, logical *, logical *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex
+ *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
+ ftnlen), zchk3_(char *, doublereal *, doublereal *, integer *,
+ integer *, logical *, logical *, logical *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+ , doublecomplex *, doublecomplex *, doublereal *, doublecomplex *,
+ ftnlen), zchk4_(char *, doublereal *, doublereal *, integer *,
+ integer *, logical *, logical *, logical *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex
+ *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
+ ftnlen), zchk5_(char *, doublereal *, doublereal *, integer *,
+ integer *, logical *, logical *, logical *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex
+ *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublereal *, doublecomplex *,
+ ftnlen);
+ extern doublereal ddiff_(doublereal *, doublereal *);
+ logical fatal, trace;
+ integer nidim;
+ extern /* Subroutine */ int zchke_(integer *, char *, integer *, ftnlen),
+ zmmch_(char *, char *, integer *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublereal *, doublecomplex *, integer *,
+ doublereal *, doublereal *, logical *, integer *, logical *,
+ ftnlen, ftnlen);
+ char snaps[32];
+ integer isnum;
+ logical ltest[9], sfatal;
+ char snamet[6], transa[1], transb[1];
+ doublereal thresh;
+ logical ltestt, tsterr;
+ char summry[32];
+
+ /* Fortran I/O blocks */
+ static cilist io___2 = { 0, 5, 0, 0, 0 };
+ static cilist io___4 = { 0, 5, 0, 0, 0 };
+ static cilist io___6 = { 0, 5, 0, 0, 0 };
+ static cilist io___8 = { 0, 5, 0, 0, 0 };
+ static cilist io___11 = { 0, 5, 0, 0, 0 };
+ static cilist io___13 = { 0, 5, 0, 0, 0 };
+ static cilist io___15 = { 0, 5, 0, 0, 0 };
+ static cilist io___17 = { 0, 5, 0, 0, 0 };
+ static cilist io___19 = { 0, 5, 0, 0, 0 };
+ static cilist io___21 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___22 = { 0, 5, 0, 0, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___26 = { 0, 5, 0, 0, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___29 = { 0, 5, 0, 0, 0 };
+ static cilist io___31 = { 0, 5, 0, 0, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___34 = { 0, 5, 0, 0, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___40 = { 0, 0, 0, 0, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9984, 0 };
+ static cilist io___42 = { 0, 0, 0, 0, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, 0, 0 };
+ static cilist io___46 = { 0, 5, 1, fmt_9988, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___69 = { 0, 0, 0, 0, 0 };
+ static cilist io___70 = { 0, 0, 0, fmt_9987, 0 };
+ static cilist io___71 = { 0, 0, 0, 0, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9986, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9985, 0 };
+ static cilist io___80 = { 0, 0, 0, fmt_9991, 0 };
+
+
+
+/* Test program for the COMPLEX*16 Level 3 Blas. */
+
+/* The program must be driven by a short data file. The first 14 records */
+/* of the file are read using list-directed input, the last 9 records */
+/* are read using the format ( A6, L2 ). An annotated example of a data */
+/* file can be obtained by deleting the first 3 characters from the */
+/* following 23 lines: */
+/* 'zblat3.out' NAME OF SUMMARY OUTPUT FILE */
+/* 6 UNIT NUMBER OF SUMMARY FILE */
+/* 'ZBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE */
+/* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) */
+/* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. */
+/* F LOGICAL FLAG, T TO STOP ON FAILURES. */
+/* T LOGICAL FLAG, T TO TEST ERROR EXITS. */
+/* 16.0 THRESHOLD VALUE OF TEST RATIO */
+/* 6 NUMBER OF VALUES OF N */
+/* 0 1 2 3 5 9 VALUES OF N */
+/* 3 NUMBER OF VALUES OF ALPHA */
+/* (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA */
+/* 3 NUMBER OF VALUES OF BETA */
+/* (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA */
+/* ZGEMM T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZHEMM T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZSYMM T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZTRMM T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZTRSM T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZHERK T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZSYRK T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZHER2K T PUT F FOR NO TEST. SAME COLUMNS. */
+/* ZSYR2K T PUT F FOR NO TEST. SAME COLUMNS. */
+
+/* See: */
+
+/* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. */
+/* A Set of Level 3 Basic Linear Algebra Subprograms. */
+
+/* Technical Memorandum No.88 (Revision 1), Mathematics and */
+/* Computer Science Division, Argonne National Laboratory, 9700 */
+/* South Cass Avenue, Argonne, Illinois 60439, US. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers */
+/* can be run multiple times without deleting generated */
+/* output files (susan) */
+
+/* .. Parameters .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+/* .. Executable Statements .. */
+
+/* Read name and unit number for summary output file and open file. */
+
+ s_rsle(&io___2);
+ do_lio(&c__9, &c__1, summry, (ftnlen)32);
+ e_rsle();
+ s_rsle(&io___4);
+ do_lio(&c__3, &c__1, (char *)&nout, (ftnlen)sizeof(integer));
+ e_rsle();
+ o__1.oerr = 0;
+ o__1.ounit = nout;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = summry;
+ o__1.orl = 0;
+ o__1.osta = "UNKNOWN";
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);
+ infoc_1.noutc = nout;
+
+/* Read name and unit number for snapshot output file and open file. */
+
+ s_rsle(&io___6);
+ do_lio(&c__9, &c__1, snaps, (ftnlen)32);
+ e_rsle();
+ s_rsle(&io___8);
+ do_lio(&c__3, &c__1, (char *)&ntra, (ftnlen)sizeof(integer));
+ e_rsle();
+ trace = ntra >= 0;
+ if (trace) {
+ o__1.oerr = 0;
+ o__1.ounit = ntra;
+ o__1.ofnmlen = 32;
+ o__1.ofnm = snaps;
+ o__1.orl = 0;
+ o__1.osta = "UNKNOWN";
+ o__1.oacc = 0;
+ o__1.ofm = 0;
+ o__1.oblnk = 0;
+ f_open(&o__1);
+ }
+/* Read the flag that directs rewinding of the snapshot file. */
+ s_rsle(&io___11);
+ do_lio(&c__8, &c__1, (char *)&rewi, (ftnlen)sizeof(logical));
+ e_rsle();
+ rewi = rewi && trace;
+/* Read the flag that directs stopping on any failure. */
+ s_rsle(&io___13);
+ do_lio(&c__8, &c__1, (char *)&sfatal, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the flag that indicates whether error exits are to be tested. */
+ s_rsle(&io___15);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+/* Read the threshold value of the test ratio */
+ s_rsle(&io___17);
+ do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_rsle();
+
+/* Read and check the parameter values for the tests. */
+
+/* Values of N */
+ s_rsle(&io___19);
+ do_lio(&c__3, &c__1, (char *)&nidim, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nidim < 1 || nidim > 9) {
+ io___21.ciunit = nout;
+ s_wsfe(&io___21);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___22);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (idim[i__ - 1] < 0 || idim[i__ - 1] > 65) {
+ io___25.ciunit = nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, (char *)&c__65, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+/* L10: */
+ }
+/* Values of ALPHA */
+ s_rsle(&io___26);
+ do_lio(&c__3, &c__1, (char *)&nalf, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nalf < 1 || nalf > 7) {
+ io___28.ciunit = nout;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "ALPHA", (ftnlen)5);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___29);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__7, &c__1, (char *)&alf[i__ - 1], (ftnlen)sizeof(
+ doublecomplex));
+ }
+ e_rsle();
+/* Values of BETA */
+ s_rsle(&io___31);
+ do_lio(&c__3, &c__1, (char *)&nbet, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nbet < 1 || nbet > 7) {
+ io___33.ciunit = nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, "BETA", (ftnlen)4);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L220;
+ }
+ s_rsle(&io___34);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__7, &c__1, (char *)&bet[i__ - 1], (ftnlen)sizeof(
+ doublecomplex));
+ }
+ e_rsle();
+
+/* Report values of parameters. */
+
+ io___36.ciunit = nout;
+ s_wsfe(&io___36);
+ e_wsfe();
+ io___37.ciunit = nout;
+ s_wsfe(&io___37);
+ i__1 = nidim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&idim[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ io___38.ciunit = nout;
+ s_wsfe(&io___38);
+ i__1 = nalf;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__2, (char *)&alf[i__ - 1], (ftnlen)sizeof(doublereal));
+ }
+ e_wsfe();
+ io___39.ciunit = nout;
+ s_wsfe(&io___39);
+ i__1 = nbet;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__2, (char *)&bet[i__ - 1], (ftnlen)sizeof(doublereal));
+ }
+ e_wsfe();
+ if (! tsterr) {
+ io___40.ciunit = nout;
+ s_wsle(&io___40);
+ e_wsle();
+ io___41.ciunit = nout;
+ s_wsfe(&io___41);
+ e_wsfe();
+ }
+ io___42.ciunit = nout;
+ s_wsle(&io___42);
+ e_wsle();
+ io___43.ciunit = nout;
+ s_wsfe(&io___43);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ io___44.ciunit = nout;
+ s_wsle(&io___44);
+ e_wsle();
+
+/* Read names of subroutines and flags which indicate */
+/* whether they are to be tested. */
+
+ for (i__ = 1; i__ <= 9; ++i__) {
+ ltest[i__ - 1] = FALSE_;
+/* L20: */
+ }
+L30:
+ i__1 = s_rsfe(&io___46);
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = do_fio(&c__1, snamet, (ftnlen)6);
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = do_fio(&c__1, (char *)<estt, (ftnlen)sizeof(logical));
+ if (i__1 != 0) {
+ goto L60;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L60;
+ }
+ for (i__ = 1; i__ <= 9; ++i__) {
+ if (s_cmp(snamet, snames + (i__ - 1) * 6, (ftnlen)6, (ftnlen)6) == 0)
+ {
+ goto L50;
+ }
+/* L40: */
+ }
+ io___49.ciunit = nout;
+ s_wsfe(&io___49);
+ do_fio(&c__1, snamet, (ftnlen)6);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+L50:
+ ltest[i__ - 1] = ltestt;
+ goto L30;
+
+L60:
+ cl__1.cerr = 0;
+ cl__1.cunit = 5;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+
+/* Compute EPS (the machine precision). */
+
+ eps = 1.;
+L70:
+ d__1 = eps + 1.;
+ if (ddiff_(&d__1, &c_b89) == 0.) {
+ goto L80;
+ }
+ eps *= .5;
+ goto L70;
+L80:
+ eps += eps;
+ io___51.ciunit = nout;
+ s_wsfe(&io___51);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+/* Check the reliability of ZMMCH using exact data. */
+
+ n = 32;
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 65 - 66;
+/* Computing MAX */
+ i__5 = i__ - j + 1;
+ i__4 = max(i__5,0);
+ ab[i__3].r = (doublereal) i__4, ab[i__3].i = 0.;
+/* L90: */
+ }
+ i__2 = j + 4224;
+ ab[i__2].r = (doublereal) j, ab[i__2].i = 0.;
+ i__2 = (j + 65) * 65 - 65;
+ ab[i__2].r = (doublereal) j, ab[i__2].i = 0.;
+ i__2 = j - 1;
+ c__[i__2].r = 0., c__[i__2].i = 0.;
+/* L100: */
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ i__3 = j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3;
+ cc[i__2].r = (doublereal) i__3, cc[i__2].i = 0.;
+/* L110: */
+ }
+/* CC holds the exact result. On exit from ZMMCH CT holds */
+/* the result computed by ZMMCH. */
+ *(unsigned char *)transa = 'N';
+ *(unsigned char *)transb = 'N';
+ zmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], &
+ c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal,
+ &nout, &c_true, (ftnlen)1, (ftnlen)1);
+ same = lze_(cc, ct, &n);
+ if (! same || err != 0.) {
+ io___64.ciunit = nout;
+ s_wsfe(&io___64);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ *(unsigned char *)transb = 'C';
+ zmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], &
+ c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal,
+ &nout, &c_true, (ftnlen)1, (ftnlen)1);
+ same = lze_(cc, ct, &n);
+ if (! same || err != 0.) {
+ io___65.ciunit = nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + 4224;
+ i__3 = n - j + 1;
+ ab[i__2].r = (doublereal) i__3, ab[i__2].i = 0.;
+ i__2 = (j + 65) * 65 - 65;
+ i__3 = n - j + 1;
+ ab[i__2].r = (doublereal) i__3, ab[i__2].i = 0.;
+/* L120: */
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = n - j;
+ i__3 = j * ((j + 1) * j) / 2 - (j + 1) * j * (j - 1) / 3;
+ cc[i__2].r = (doublereal) i__3, cc[i__2].i = 0.;
+/* L130: */
+ }
+ *(unsigned char *)transa = 'C';
+ *(unsigned char *)transb = 'N';
+ zmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], &
+ c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal,
+ &nout, &c_true, (ftnlen)1, (ftnlen)1);
+ same = lze_(cc, ct, &n);
+ if (! same || err != 0.) {
+ io___66.ciunit = nout;
+ s_wsfe(&io___66);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+ *(unsigned char *)transb = 'C';
+ zmmch_(transa, transb, &n, &c__1, &n, &c_b2, ab, &c__65, &ab[4225], &
+ c__65, &c_b1, c__, &c__65, ct, g, cc, &c__65, &eps, &err, &fatal,
+ &nout, &c_true, (ftnlen)1, (ftnlen)1);
+ same = lze_(cc, ct, &n);
+ if (! same || err != 0.) {
+ io___67.ciunit = nout;
+ s_wsfe(&io___67);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&same, (ftnlen)sizeof(logical));
+ do_fio(&c__1, (char *)&err, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Test each subroutine in turn. */
+
+ for (isnum = 1; isnum <= 9; ++isnum) {
+ io___69.ciunit = nout;
+ s_wsle(&io___69);
+ e_wsle();
+ if (! ltest[isnum - 1]) {
+/* Subprogram is not to be tested. */
+ io___70.ciunit = nout;
+ s_wsfe(&io___70);
+ do_fio(&c__1, snames + (isnum - 1) * 6, (ftnlen)6);
+ e_wsfe();
+ } else {
+ s_copy(srnamc_1.srnamt, snames + (isnum - 1) * 6, (ftnlen)6, (
+ ftnlen)6);
+/* Test error exits. */
+ if (tsterr) {
+ zchke_(&isnum, snames + (isnum - 1) * 6, &nout, (ftnlen)6);
+ io___71.ciunit = nout;
+ s_wsle(&io___71);
+ e_wsle();
+ }
+/* Test computations. */
+ infoc_1.infot = 0;
+ infoc_1.ok = TRUE_;
+ fatal = FALSE_;
+ switch (isnum) {
+ case 1: goto L140;
+ case 2: goto L150;
+ case 3: goto L150;
+ case 4: goto L160;
+ case 5: goto L160;
+ case 6: goto L170;
+ case 7: goto L170;
+ case 8: goto L180;
+ case 9: goto L180;
+ }
+/* Test ZGEMM, 01. */
+L140:
+ zchk1_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &nbet,
+ bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, cc, cs,
+ ct, g, (ftnlen)6);
+ goto L190;
+/* Test ZHEMM, 02, ZSYMM, 03. */
+L150:
+ zchk2_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &nbet,
+ bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, cc, cs,
+ ct, g, (ftnlen)6);
+ goto L190;
+/* Test ZTRMM, 04, ZTRSM, 05. */
+L160:
+ zchk3_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &c__65,
+ ab, aa, as, &ab[4225], bb, bs, ct, g, c__, (ftnlen)6);
+ goto L190;
+/* Test ZHERK, 06, ZSYRK, 07. */
+L170:
+ zchk4_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &nbet,
+ bet, &c__65, ab, aa, as, &ab[4225], bb, bs, c__, cc, cs,
+ ct, g, (ftnlen)6);
+ goto L190;
+/* Test ZHER2K, 08, ZSYR2K, 09. */
+L180:
+ zchk5_(snames + (isnum - 1) * 6, &eps, &thresh, &nout, &ntra, &
+ trace, &rewi, &fatal, &nidim, idim, &nalf, alf, &nbet,
+ bet, &c__65, ab, aa, as, bb, bs, c__, cc, cs, ct, g, w, (
+ ftnlen)6);
+ goto L190;
+
+L190:
+ if (fatal && sfatal) {
+ goto L210;
+ }
+ }
+/* L200: */
+ }
+ io___78.ciunit = nout;
+ s_wsfe(&io___78);
+ e_wsfe();
+ goto L230;
+
+L210:
+ io___79.ciunit = nout;
+ s_wsfe(&io___79);
+ e_wsfe();
+ goto L230;
+
+L220:
+ io___80.ciunit = nout;
+ s_wsfe(&io___80);
+ e_wsfe();
+
+L230:
+ if (trace) {
+ cl__1.cerr = 0;
+ cl__1.cunit = ntra;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ }
+ cl__1.cerr = 0;
+ cl__1.cunit = nout;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ s_stop("", (ftnlen)0);
+
+
+/* End of ZBLAT3. */
+
+ return 0;
+} /* MAIN__ */
+
+/* Subroutine */ int zchk1_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
+ alf, integer *nbet, doublecomplex *bet, integer *nmax, doublecomplex *
+ a, doublecomplex *aa, doublecomplex *as, doublecomplex *b,
+ doublecomplex *bb, doublecomplex *bs, doublecomplex *c__,
+ doublecomplex *cc, doublecomplex *cs, doublecomplex *ct, doublereal *
+ g, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ich[3] = "NTC";
+
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002('\002,a1,\002','\002"
+ ",a1,\002',\002,3(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,"
+ "\002), A,\002,i3,\002, B,\002,i3,\002,(\002,f4.1,\002,\002,f4.1"
+ ",\002), C,\002,i3,\002).\002)";
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6, i__7, i__8;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ f_rew(alist *);
+
+ /* Local variables */
+ integer i__, k, m, n, ia, ib, ma, mb, na, nb, nc, ik, im, in, ks, ms, ns,
+ ica, icb, laa, lbb, lda, lcc, ldb, ldc;
+ doublecomplex als, bls;
+ doublereal err;
+ extern logical lze_(doublecomplex *, doublecomplex *, integer *);
+ doublecomplex beta;
+ integer ldas, ldbs, ldcs;
+ logical same, null;
+ doublecomplex alpha;
+ logical isame[13], trana, tranb;
+ extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ logical *, doublecomplex *, ftnlen, ftnlen, ftnlen);
+ integer nargs;
+ extern /* Subroutine */ int zmmch_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, doublereal *, doublecomplex *,
+ integer *, doublereal *, doublereal *, logical *, integer *,
+ logical *, ftnlen, ftnlen), zgemm_(char *, char *, integer *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ logical reset;
+ char tranas[1], tranbs[1], transa[1], transb[1];
+ doublereal errmax;
+ extern logical lzeres_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen);
+
+ /* Fortran I/O blocks */
+ static cilist io___124 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___125 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___128 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___130 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___131 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___132 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___133 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests ZGEMM. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+
+ nargs = 13;
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.;
+
+ i__1 = *nidim;
+ for (im = 1; im <= i__1; ++im) {
+ m = idim[im];
+
+ i__2 = *nidim;
+ for (in = 1; in <= i__2; ++in) {
+ n = idim[in];
+/* Set LDC to 1 more than minimum value if room. */
+ ldc = m;
+ if (ldc < *nmax) {
+ ++ldc;
+ }
+/* Skip tests if not enough room. */
+ if (ldc > *nmax) {
+ goto L100;
+ }
+ lcc = ldc * n;
+ null = n <= 0 || m <= 0;
+
+ i__3 = *nidim;
+ for (ik = 1; ik <= i__3; ++ik) {
+ k = idim[ik];
+
+ for (ica = 1; ica <= 3; ++ica) {
+ *(unsigned char *)transa = *(unsigned char *)&ich[ica - 1]
+ ;
+ trana = *(unsigned char *)transa == 'T' || *(unsigned
+ char *)transa == 'C';
+
+ if (trana) {
+ ma = k;
+ na = m;
+ } else {
+ ma = m;
+ na = k;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ lda = ma;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L80;
+ }
+ laa = lda * na;
+
+/* Generate the matrix A. */
+
+ zmake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[
+ 1], &lda, &reset, &c_b1, (ftnlen)2, (ftnlen)1, (
+ ftnlen)1);
+
+ for (icb = 1; icb <= 3; ++icb) {
+ *(unsigned char *)transb = *(unsigned char *)&ich[icb
+ - 1];
+ tranb = *(unsigned char *)transb == 'T' || *(unsigned
+ char *)transb == 'C';
+
+ if (tranb) {
+ mb = n;
+ nb = k;
+ } else {
+ mb = k;
+ nb = n;
+ }
+/* Set LDB to 1 more than minimum value if room. */
+ ldb = mb;
+ if (ldb < *nmax) {
+ ++ldb;
+ }
+/* Skip tests if not enough room. */
+ if (ldb > *nmax) {
+ goto L70;
+ }
+ lbb = ldb * nb;
+
+/* Generate the matrix B. */
+
+ zmake_("GE", " ", " ", &mb, &nb, &b[b_offset], nmax, &
+ bb[1], &ldb, &reset, &c_b1, (ftnlen)2, (
+ ftnlen)1, (ftnlen)1);
+
+ i__4 = *nalf;
+ for (ia = 1; ia <= i__4; ++ia) {
+ i__5 = ia;
+ alpha.r = alf[i__5].r, alpha.i = alf[i__5].i;
+
+ i__5 = *nbet;
+ for (ib = 1; ib <= i__5; ++ib) {
+ i__6 = ib;
+ beta.r = bet[i__6].r, beta.i = bet[i__6].i;
+
+/* Generate the matrix C. */
+
+ zmake_("GE", " ", " ", &m, &n, &c__[c_offset],
+ nmax, &cc[1], &ldc, &reset, &c_b1, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the */
+/* subroutine. */
+
+ *(unsigned char *)tranas = *(unsigned char *)
+ transa;
+ *(unsigned char *)tranbs = *(unsigned char *)
+ transb;
+ ms = m;
+ ns = n;
+ ks = k;
+ als.r = alpha.r, als.i = alpha.i;
+ i__6 = laa;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ i__7 = i__;
+ i__8 = i__;
+ as[i__7].r = aa[i__8].r, as[i__7].i = aa[
+ i__8].i;
+/* L10: */
+ }
+ ldas = lda;
+ i__6 = lbb;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ i__7 = i__;
+ i__8 = i__;
+ bs[i__7].r = bb[i__8].r, bs[i__7].i = bb[
+ i__8].i;
+/* L20: */
+ }
+ ldbs = ldb;
+ bls.r = beta.r, bls.i = beta.i;
+ i__6 = lcc;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ i__7 = i__;
+ i__8 = i__;
+ cs[i__7].r = cc[i__8].r, cs[i__7].i = cc[
+ i__8].i;
+/* L30: */
+ }
+ ldcs = ldc;
+
+/* Call the subroutine. */
+
+ if (*trace) {
+ io___124.ciunit = *ntra;
+ s_wsfe(&io___124);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ zgemm_(transa, transb, &m, &n, &k, &alpha, &
+ aa[1], &lda, &bb[1], &ldb, &beta, &cc[
+ 1], &ldc);
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___125.ciunit = *nout;
+ s_wsfe(&io___125);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)transa == *(
+ unsigned char *)tranas;
+ isame[1] = *(unsigned char *)transb == *(
+ unsigned char *)tranbs;
+ isame[2] = ms == m;
+ isame[3] = ns == n;
+ isame[4] = ks == k;
+ isame[5] = als.r == alpha.r && als.i ==
+ alpha.i;
+ isame[6] = lze_(&as[1], &aa[1], &laa);
+ isame[7] = ldas == lda;
+ isame[8] = lze_(&bs[1], &bb[1], &lbb);
+ isame[9] = ldbs == ldb;
+ isame[10] = bls.r == beta.r && bls.i ==
+ beta.i;
+ if (null) {
+ isame[11] = lze_(&cs[1], &cc[1], &lcc);
+ } else {
+ isame[11] = lzeres_("GE", " ", &m, &n, &
+ cs[1], &cc[1], &ldc, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[12] = ldcs == ldc;
+
+/* If data was incorrectly changed, report */
+/* and return. */
+
+ same = TRUE_;
+ i__6 = nargs;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___128.ciunit = *nout;
+ s_wsfe(&io___128);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+
+/* Check the result. */
+
+ zmmch_(transa, transb, &m, &n, &k, &alpha,
+ &a[a_offset], nmax, &b[b_offset],
+ nmax, &beta, &c__[c_offset],
+ nmax, &ct[1], &g[1], &cc[1], &ldc,
+ eps, &err, fatal, nout, &c_true,
+ (ftnlen)1, (ftnlen)1);
+ errmax = max(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L120;
+ }
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+L70:
+ ;
+ }
+
+L80:
+ ;
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+/* L110: */
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___130.ciunit = *nout;
+ s_wsfe(&io___130);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___131.ciunit = *nout;
+ s_wsfe(&io___131);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ goto L130;
+
+L120:
+ io___132.ciunit = *nout;
+ s_wsfe(&io___132);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ io___133.ciunit = *nout;
+ s_wsfe(&io___133);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, transb, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L130:
+ return 0;
+
+
+/* End of ZCHK1. */
+
+} /* zchk1_ */
+
+/* Subroutine */ int zchk2_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
+ alf, integer *nbet, doublecomplex *bet, integer *nmax, doublecomplex *
+ a, doublecomplex *aa, doublecomplex *as, doublecomplex *b,
+ doublecomplex *bb, doublecomplex *bs, doublecomplex *c__,
+ doublecomplex *cc, doublecomplex *cs, doublecomplex *ct, doublereal *
+ g, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char ichs[2] = "LR";
+ static char ichu[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002(\002,2(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,\002)"
+ ", A,\002,i3,\002, B,\002,i3,\002,(\002,f4.1,\002,\002,f4.1,\002)"
+ ", C,\002,i3,\002) .\002)";
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6, i__7;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio(
+ integer *, char *, ftnlen), e_wsfe(void), f_rew(alist *);
+
+ /* Local variables */
+ integer i__, m, n, ia, ib, na, nc, im, in, ms, ns, laa, lbb, lda, lcc,
+ ldb, ldc, ics;
+ doublecomplex als, bls;
+ integer icu;
+ doublereal err;
+ extern logical lze_(doublecomplex *, doublecomplex *, integer *);
+ doublecomplex beta;
+ integer ldas, ldbs, ldcs;
+ logical same;
+ char side[1];
+ logical conj, left, null;
+ char uplo[1];
+ doublecomplex alpha;
+ logical isame[13];
+ char sides[1];
+ extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ logical *, doublecomplex *, ftnlen, ftnlen, ftnlen);
+ integer nargs;
+ extern /* Subroutine */ int zmmch_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, doublereal *, doublecomplex *,
+ integer *, doublereal *, doublereal *, logical *, integer *,
+ logical *, ftnlen, ftnlen), zhemm_(char *, char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ logical reset;
+ char uplos[1];
+ extern /* Subroutine */ int zsymm_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ doublereal errmax;
+ extern logical lzeres_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen);
+
+ /* Fortran I/O blocks */
+ static cilist io___172 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___173 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___176 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___178 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___179 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___180 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___181 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests ZHEMM and ZSYMM. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ conj = s_cmp(sname + 1, "HE", (ftnlen)2, (ftnlen)2) == 0;
+
+ nargs = 12;
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.;
+
+ i__1 = *nidim;
+ for (im = 1; im <= i__1; ++im) {
+ m = idim[im];
+
+ i__2 = *nidim;
+ for (in = 1; in <= i__2; ++in) {
+ n = idim[in];
+/* Set LDC to 1 more than minimum value if room. */
+ ldc = m;
+ if (ldc < *nmax) {
+ ++ldc;
+ }
+/* Skip tests if not enough room. */
+ if (ldc > *nmax) {
+ goto L90;
+ }
+ lcc = ldc * n;
+ null = n <= 0 || m <= 0;
+/* Set LDB to 1 more than minimum value if room. */
+ ldb = m;
+ if (ldb < *nmax) {
+ ++ldb;
+ }
+/* Skip tests if not enough room. */
+ if (ldb > *nmax) {
+ goto L90;
+ }
+ lbb = ldb * n;
+
+/* Generate the matrix B. */
+
+ zmake_("GE", " ", " ", &m, &n, &b[b_offset], nmax, &bb[1], &ldb, &
+ reset, &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ for (ics = 1; ics <= 2; ++ics) {
+ *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1];
+ left = *(unsigned char *)side == 'L';
+
+ if (left) {
+ na = m;
+ } else {
+ na = n;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ lda = na;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L80;
+ }
+ laa = lda * na;
+
+ for (icu = 1; icu <= 2; ++icu) {
+ *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
+
+/* Generate the hermitian or symmetric matrix A. */
+
+ zmake_(sname + 1, uplo, " ", &na, &na, &a[a_offset], nmax,
+ &aa[1], &lda, &reset, &c_b1, (ftnlen)2, (ftnlen)
+ 1, (ftnlen)1);
+
+ i__3 = *nalf;
+ for (ia = 1; ia <= i__3; ++ia) {
+ i__4 = ia;
+ alpha.r = alf[i__4].r, alpha.i = alf[i__4].i;
+
+ i__4 = *nbet;
+ for (ib = 1; ib <= i__4; ++ib) {
+ i__5 = ib;
+ beta.r = bet[i__5].r, beta.i = bet[i__5].i;
+
+/* Generate the matrix C. */
+
+ zmake_("GE", " ", " ", &m, &n, &c__[c_offset],
+ nmax, &cc[1], &ldc, &reset, &c_b1, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the */
+/* subroutine. */
+
+ *(unsigned char *)sides = *(unsigned char *)side;
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ ms = m;
+ ns = n;
+ als.r = alpha.r, als.i = alpha.i;
+ i__5 = laa;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7]
+ .i;
+/* L10: */
+ }
+ ldas = lda;
+ i__5 = lbb;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ bs[i__6].r = bb[i__7].r, bs[i__6].i = bb[i__7]
+ .i;
+/* L20: */
+ }
+ ldbs = ldb;
+ bls.r = beta.r, bls.i = beta.i;
+ i__5 = lcc;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ cs[i__6].r = cc[i__7].r, cs[i__6].i = cc[i__7]
+ .i;
+/* L30: */
+ }
+ ldcs = ldc;
+
+/* Call the subroutine. */
+
+ if (*trace) {
+ io___172.ciunit = *ntra;
+ s_wsfe(&io___172);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ if (conj) {
+ zhemm_(side, uplo, &m, &n, &alpha, &aa[1], &
+ lda, &bb[1], &ldb, &beta, &cc[1], &
+ ldc);
+ } else {
+ zsymm_(side, uplo, &m, &n, &alpha, &aa[1], &
+ lda, &bb[1], &ldb, &beta, &cc[1], &
+ ldc);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___173.ciunit = *nout;
+ s_wsfe(&io___173);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L110;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)sides == *(unsigned
+ char *)side;
+ isame[1] = *(unsigned char *)uplos == *(unsigned
+ char *)uplo;
+ isame[2] = ms == m;
+ isame[3] = ns == n;
+ isame[4] = als.r == alpha.r && als.i == alpha.i;
+ isame[5] = lze_(&as[1], &aa[1], &laa);
+ isame[6] = ldas == lda;
+ isame[7] = lze_(&bs[1], &bb[1], &lbb);
+ isame[8] = ldbs == ldb;
+ isame[9] = bls.r == beta.r && bls.i == beta.i;
+ if (null) {
+ isame[10] = lze_(&cs[1], &cc[1], &lcc);
+ } else {
+ isame[10] = lzeres_("GE", " ", &m, &n, &cs[1],
+ &cc[1], &ldc, (ftnlen)2, (ftnlen)1);
+ }
+ isame[11] = ldcs == ldc;
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__5 = nargs;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___176.ciunit = *nout;
+ s_wsfe(&io___176);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L110;
+ }
+
+ if (! null) {
+
+/* Check the result. */
+
+ if (left) {
+ zmmch_("N", "N", &m, &n, &m, &alpha, &a[
+ a_offset], nmax, &b[b_offset],
+ nmax, &beta, &c__[c_offset], nmax,
+ &ct[1], &g[1], &cc[1], &ldc, eps,
+ &err, fatal, nout, &c_true, (
+ ftnlen)1, (ftnlen)1);
+ } else {
+ zmmch_("N", "N", &m, &n, &n, &alpha, &b[
+ b_offset], nmax, &a[a_offset],
+ nmax, &beta, &c__[c_offset], nmax,
+ &ct[1], &g[1], &cc[1], &ldc, eps,
+ &err, fatal, nout, &c_true, (
+ ftnlen)1, (ftnlen)1);
+ }
+ errmax = max(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L110;
+ }
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+/* L70: */
+ }
+
+L80:
+ ;
+ }
+
+L90:
+ ;
+ }
+
+/* L100: */
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___178.ciunit = *nout;
+ s_wsfe(&io___178);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___179.ciunit = *nout;
+ s_wsfe(&io___179);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ goto L120;
+
+L110:
+ io___180.ciunit = *nout;
+ s_wsfe(&io___180);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ io___181.ciunit = *nout;
+ s_wsfe(&io___181);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L120:
+ return 0;
+
+
+/* End of ZCHK2. */
+
+} /* zchk2_ */
+
+/* Subroutine */ int zchk3_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
+ alf, integer *nmax, doublecomplex *a, doublecomplex *aa,
+ doublecomplex *as, doublecomplex *b, doublecomplex *bb, doublecomplex
+ *bs, doublecomplex *ct, doublereal *g, doublecomplex *c__, ftnlen
+ sname_len)
+{
+ /* Initialized data */
+
+ static char ichu[2] = "UL";
+ static char icht[3] = "NTC";
+ static char ichd[2] = "UN";
+ static char ichs[2] = "LR";
+
+ /* Format strings */
+ static char fmt_9995[] = "(1x,i6,\002: \002,a6,\002(\002,4(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,\002)"
+ ", A,\002,i3,\002, B,\002,i3,\002) \002,\002 .\002)";
+ static char fmt_9994[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6, i__7;
+ doublecomplex z__1;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio(
+ integer *, char *, ftnlen), e_wsfe(void), f_rew(alist *);
+
+ /* Local variables */
+ integer i__, j, m, n, ia, na, nc, im, in, ms, ns, laa, icd, lbb, lda, ldb,
+ ics;
+ doublecomplex als;
+ integer ict, icu;
+ doublereal err;
+ extern logical lze_(doublecomplex *, doublecomplex *, integer *);
+ char diag[1];
+ integer ldas, ldbs;
+ logical same;
+ char side[1];
+ logical left, null;
+ char uplo[1];
+ doublecomplex alpha;
+ char diags[1];
+ logical isame[13];
+ char sides[1];
+ extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ logical *, doublecomplex *, ftnlen, ftnlen, ftnlen);
+ integer nargs;
+ extern /* Subroutine */ int zmmch_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, doublereal *, doublecomplex *,
+ integer *, doublereal *, doublereal *, logical *, integer *,
+ logical *, ftnlen, ftnlen);
+ logical reset;
+ char uplos[1];
+ extern /* Subroutine */ int ztrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ ztrsm_(char *, char *, char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *);
+ char tranas[1], transa[1];
+ doublereal errmax;
+ extern logical lzeres_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen);
+
+ /* Fortran I/O blocks */
+ static cilist io___222 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___223 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___224 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___227 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___229 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___230 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___231 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___232 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* Tests ZTRMM and ZTRSM. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --g;
+ --ct;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+
+ nargs = 11;
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.;
+/* Set up zero matrix for ZMMCH. */
+ i__1 = *nmax;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *nmax;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ c__[i__3].r = 0., c__[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+
+ i__1 = *nidim;
+ for (im = 1; im <= i__1; ++im) {
+ m = idim[im];
+
+ i__2 = *nidim;
+ for (in = 1; in <= i__2; ++in) {
+ n = idim[in];
+/* Set LDB to 1 more than minimum value if room. */
+ ldb = m;
+ if (ldb < *nmax) {
+ ++ldb;
+ }
+/* Skip tests if not enough room. */
+ if (ldb > *nmax) {
+ goto L130;
+ }
+ lbb = ldb * n;
+ null = m <= 0 || n <= 0;
+
+ for (ics = 1; ics <= 2; ++ics) {
+ *(unsigned char *)side = *(unsigned char *)&ichs[ics - 1];
+ left = *(unsigned char *)side == 'L';
+ if (left) {
+ na = m;
+ } else {
+ na = n;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ lda = na;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L130;
+ }
+ laa = lda * na;
+
+ for (icu = 1; icu <= 2; ++icu) {
+ *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
+
+ for (ict = 1; ict <= 3; ++ict) {
+ *(unsigned char *)transa = *(unsigned char *)&icht[
+ ict - 1];
+
+ for (icd = 1; icd <= 2; ++icd) {
+ *(unsigned char *)diag = *(unsigned char *)&ichd[
+ icd - 1];
+
+ i__3 = *nalf;
+ for (ia = 1; ia <= i__3; ++ia) {
+ i__4 = ia;
+ alpha.r = alf[i__4].r, alpha.i = alf[i__4].i;
+
+/* Generate the matrix A. */
+
+ zmake_("TR", uplo, diag, &na, &na, &a[
+ a_offset], nmax, &aa[1], &lda, &reset,
+ &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)
+ 1);
+
+/* Generate the matrix B. */
+
+ zmake_("GE", " ", " ", &m, &n, &b[b_offset],
+ nmax, &bb[1], &ldb, &reset, &c_b1, (
+ ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the */
+/* subroutine. */
+
+ *(unsigned char *)sides = *(unsigned char *)
+ side;
+ *(unsigned char *)uplos = *(unsigned char *)
+ uplo;
+ *(unsigned char *)tranas = *(unsigned char *)
+ transa;
+ *(unsigned char *)diags = *(unsigned char *)
+ diag;
+ ms = m;
+ ns = n;
+ als.r = alpha.r, als.i = alpha.i;
+ i__4 = laa;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__;
+ i__6 = i__;
+ as[i__5].r = aa[i__6].r, as[i__5].i = aa[
+ i__6].i;
+/* L30: */
+ }
+ ldas = lda;
+ i__4 = lbb;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__;
+ i__6 = i__;
+ bs[i__5].r = bb[i__6].r, bs[i__5].i = bb[
+ i__6].i;
+/* L40: */
+ }
+ ldbs = ldb;
+
+/* Call the subroutine. */
+
+ if (s_cmp(sname + 3, "MM", (ftnlen)2, (ftnlen)
+ 2) == 0) {
+ if (*trace) {
+ io___222.ciunit = *ntra;
+ s_wsfe(&io___222);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ztrmm_(side, uplo, transa, diag, &m, &n, &
+ alpha, &aa[1], &lda, &bb[1], &ldb);
+ } else if (s_cmp(sname + 3, "SM", (ftnlen)2, (
+ ftnlen)2) == 0) {
+ if (*trace) {
+ io___223.ciunit = *ntra;
+ s_wsfe(&io___223);
+ do_fio(&c__1, (char *)&nc, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ ztrsm_(side, uplo, transa, diag, &m, &n, &
+ alpha, &aa[1], &lda, &bb[1], &ldb);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___224.ciunit = *nout;
+ s_wsfe(&io___224);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L150;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)sides == *(
+ unsigned char *)side;
+ isame[1] = *(unsigned char *)uplos == *(
+ unsigned char *)uplo;
+ isame[2] = *(unsigned char *)tranas == *(
+ unsigned char *)transa;
+ isame[3] = *(unsigned char *)diags == *(
+ unsigned char *)diag;
+ isame[4] = ms == m;
+ isame[5] = ns == n;
+ isame[6] = als.r == alpha.r && als.i ==
+ alpha.i;
+ isame[7] = lze_(&as[1], &aa[1], &laa);
+ isame[8] = ldas == lda;
+ if (null) {
+ isame[9] = lze_(&bs[1], &bb[1], &lbb);
+ } else {
+ isame[9] = lzeres_("GE", " ", &m, &n, &bs[
+ 1], &bb[1], &ldb, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[10] = ldbs == ldb;
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__4 = nargs;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___227.ciunit = *nout;
+ s_wsfe(&io___227);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L50: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L150;
+ }
+
+ if (! null) {
+ if (s_cmp(sname + 3, "MM", (ftnlen)2, (
+ ftnlen)2) == 0) {
+
+/* Check the result. */
+
+ if (left) {
+ zmmch_(transa, "N", &m, &n, &m, &
+ alpha, &a[a_offset], nmax,
+ &b[b_offset], nmax, &
+ c_b1, &c__[c_offset],
+ nmax, &ct[1], &g[1], &bb[
+ 1], &ldb, eps, &err,
+ fatal, nout, &c_true, (
+ ftnlen)1, (ftnlen)1);
+ } else {
+ zmmch_("N", transa, &m, &n, &n, &
+ alpha, &b[b_offset], nmax,
+ &a[a_offset], nmax, &
+ c_b1, &c__[c_offset],
+ nmax, &ct[1], &g[1], &bb[
+ 1], &ldb, eps, &err,
+ fatal, nout, &c_true, (
+ ftnlen)1, (ftnlen)1);
+ }
+ } else if (s_cmp(sname + 3, "SM", (ftnlen)
+ 2, (ftnlen)2) == 0) {
+
+/* Compute approximation to original */
+/* matrix. */
+
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__5 = m;
+ for (i__ = 1; i__ <= i__5; ++i__)
+ {
+ i__6 = i__ + j * c_dim1;
+ i__7 = i__ + (j - 1) * ldb;
+ c__[i__6].r = bb[i__7].r, c__[i__6].i = bb[i__7].i;
+ i__6 = i__ + (j - 1) * ldb;
+ i__7 = i__ + j * b_dim1;
+ z__1.r = alpha.r * b[i__7].r - alpha.i * b[i__7].i,
+ z__1.i = alpha.r * b[i__7].i + alpha.i * b[
+ i__7].r;
+ bb[i__6].r = z__1.r, bb[i__6].i = z__1.i;
+/* L60: */
+ }
+/* L70: */
+ }
+
+ if (left) {
+ zmmch_(transa, "N", &m, &n, &m, &
+ c_b2, &a[a_offset], nmax,
+ &c__[c_offset], nmax, &
+ c_b1, &b[b_offset], nmax,
+ &ct[1], &g[1], &bb[1], &
+ ldb, eps, &err, fatal,
+ nout, &c_false, (ftnlen)1,
+ (ftnlen)1);
+ } else {
+ zmmch_("N", transa, &m, &n, &n, &
+ c_b2, &c__[c_offset],
+ nmax, &a[a_offset], nmax,
+ &c_b1, &b[b_offset], nmax,
+ &ct[1], &g[1], &bb[1], &
+ ldb, eps, &err, fatal,
+ nout, &c_false, (ftnlen)1,
+ (ftnlen)1);
+ }
+ }
+ errmax = max(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L150;
+ }
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+/* L100: */
+ }
+
+/* L110: */
+ }
+
+/* L120: */
+ }
+
+L130:
+ ;
+ }
+
+/* L140: */
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___229.ciunit = *nout;
+ s_wsfe(&io___229);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___230.ciunit = *nout;
+ s_wsfe(&io___230);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ goto L160;
+
+L150:
+ io___231.ciunit = *nout;
+ s_wsfe(&io___231);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ io___232.ciunit = *nout;
+ s_wsfe(&io___232);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, transa, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+L160:
+ return 0;
+
+
+/* End of ZCHK3. */
+
+} /* zchk3_ */
+
+/* Subroutine */ int zchk4_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
+ alf, integer *nbet, doublecomplex *bet, integer *nmax, doublecomplex *
+ a, doublecomplex *aa, doublecomplex *as, doublecomplex *b,
+ doublecomplex *bb, doublecomplex *bs, doublecomplex *c__,
+ doublecomplex *cc, doublecomplex *cs, doublecomplex *ct, doublereal *
+ g, ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char icht[2] = "NC";
+ static char ichu[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002(\002,2(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),f4.1,\002, A,\002,i3,\002,\002,f4.1,"
+ "\002, C,\002,i3,\002) \002,\002 .\002)";
+ static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002(\002,2(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,\002)"
+ " , A,\002,i3,\002,(\002,f4.1,\002,\002,f4.1,\002), C,\002,i3,"
+ "\002) .\002)";
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6, i__7;
+ doublecomplex z__1;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio(
+ integer *, char *, ftnlen), e_wsfe(void), f_rew(alist *);
+
+ /* Local variables */
+ integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
+ lda, lcc, ldc;
+ doublecomplex als;
+ integer ict, icu;
+ doublereal err;
+ extern logical lze_(doublecomplex *, doublecomplex *, integer *);
+ doublecomplex beta;
+ integer ldas, ldcs;
+ logical same, conj;
+ doublecomplex bets;
+ doublereal rals;
+ logical tran, null;
+ char uplo[1];
+ doublecomplex alpha;
+ doublereal rbeta;
+ logical isame[13];
+ extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ logical *, doublecomplex *, ftnlen, ftnlen, ftnlen);
+ integer nargs;
+ extern /* Subroutine */ int zmmch_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, doublereal *, doublecomplex *,
+ integer *, doublereal *, doublereal *, logical *, integer *,
+ logical *, ftnlen, ftnlen);
+ doublereal rbets;
+ logical reset;
+ extern /* Subroutine */ int zherk_(char *, char *, integer *, integer *,
+ doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *);
+ char trans[1];
+ logical upper;
+ char uplos[1];
+ extern /* Subroutine */ int zsyrk_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ doublereal ralpha, errmax;
+ extern logical lzeres_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen);
+ char transs[1], transt[1];
+
+ /* Fortran I/O blocks */
+ static cilist io___274 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___275 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___276 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___279 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___286 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___287 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___288 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___289 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___290 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___291 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* Tests ZHERK and ZSYRK. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ b_dim1 = *nmax;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --as;
+ --aa;
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ conj = s_cmp(sname + 1, "HE", (ftnlen)2, (ftnlen)2) == 0;
+
+ nargs = 10;
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+/* Set LDC to 1 more than minimum value if room. */
+ ldc = n;
+ if (ldc < *nmax) {
+ ++ldc;
+ }
+/* Skip tests if not enough room. */
+ if (ldc > *nmax) {
+ goto L100;
+ }
+ lcc = ldc * n;
+
+ i__2 = *nidim;
+ for (ik = 1; ik <= i__2; ++ik) {
+ k = idim[ik];
+
+ for (ict = 1; ict <= 2; ++ict) {
+ *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1];
+ tran = *(unsigned char *)trans == 'C';
+ if (tran && ! conj) {
+ *(unsigned char *)trans = 'T';
+ }
+ if (tran) {
+ ma = k;
+ na = n;
+ } else {
+ ma = n;
+ na = k;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ lda = ma;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L80;
+ }
+ laa = lda * na;
+
+/* Generate the matrix A. */
+
+ zmake_("GE", " ", " ", &ma, &na, &a[a_offset], nmax, &aa[1], &
+ lda, &reset, &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ for (icu = 1; icu <= 2; ++icu) {
+ *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
+ upper = *(unsigned char *)uplo == 'U';
+
+ i__3 = *nalf;
+ for (ia = 1; ia <= i__3; ++ia) {
+ i__4 = ia;
+ alpha.r = alf[i__4].r, alpha.i = alf[i__4].i;
+ if (conj) {
+ ralpha = alpha.r;
+ z__1.r = ralpha, z__1.i = 0.;
+ alpha.r = z__1.r, alpha.i = z__1.i;
+ }
+
+ i__4 = *nbet;
+ for (ib = 1; ib <= i__4; ++ib) {
+ i__5 = ib;
+ beta.r = bet[i__5].r, beta.i = bet[i__5].i;
+ if (conj) {
+ rbeta = beta.r;
+ z__1.r = rbeta, z__1.i = 0.;
+ beta.r = z__1.r, beta.i = z__1.i;
+ }
+ null = n <= 0;
+ if (conj) {
+ null = null || (k <= 0 || ralpha == 0.) &&
+ rbeta == 1.;
+ }
+
+/* Generate the matrix C. */
+
+ zmake_(sname + 1, uplo, " ", &n, &n, &c__[
+ c_offset], nmax, &cc[1], &ldc, &reset, &
+ c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ *(unsigned char *)transs = *(unsigned char *)
+ trans;
+ ns = n;
+ ks = k;
+ if (conj) {
+ rals = ralpha;
+ } else {
+ als.r = alpha.r, als.i = alpha.i;
+ }
+ i__5 = laa;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7]
+ .i;
+/* L10: */
+ }
+ ldas = lda;
+ if (conj) {
+ rbets = rbeta;
+ } else {
+ bets.r = beta.r, bets.i = beta.i;
+ }
+ i__5 = lcc;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ cs[i__6].r = cc[i__7].r, cs[i__6].i = cc[i__7]
+ .i;
+/* L20: */
+ }
+ ldcs = ldc;
+
+/* Call the subroutine. */
+
+ if (conj) {
+ if (*trace) {
+ io___274.ciunit = *ntra;
+ s_wsfe(&io___274);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&ralpha, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&rbeta, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ zherk_(uplo, trans, &n, &k, &ralpha, &aa[1], &
+ lda, &rbeta, &cc[1], &ldc);
+ } else {
+ if (*trace) {
+ io___275.ciunit = *ntra;
+ s_wsfe(&io___275);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ zsyrk_(uplo, trans, &n, &k, &alpha, &aa[1], &
+ lda, &beta, &cc[1], &ldc);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___276.ciunit = *nout;
+ s_wsfe(&io___276);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplos == *(unsigned
+ char *)uplo;
+ isame[1] = *(unsigned char *)transs == *(unsigned
+ char *)trans;
+ isame[2] = ns == n;
+ isame[3] = ks == k;
+ if (conj) {
+ isame[4] = rals == ralpha;
+ } else {
+ isame[4] = als.r == alpha.r && als.i ==
+ alpha.i;
+ }
+ isame[5] = lze_(&as[1], &aa[1], &laa);
+ isame[6] = ldas == lda;
+ if (conj) {
+ isame[7] = rbets == rbeta;
+ } else {
+ isame[7] = bets.r == beta.r && bets.i ==
+ beta.i;
+ }
+ if (null) {
+ isame[8] = lze_(&cs[1], &cc[1], &lcc);
+ } else {
+ isame[8] = lzeres_(sname + 1, uplo, &n, &n, &
+ cs[1], &cc[1], &ldc, (ftnlen)2, (
+ ftnlen)1);
+ }
+ isame[9] = ldcs == ldc;
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__5 = nargs;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___279.ciunit = *nout;
+ s_wsfe(&io___279);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L30: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L120;
+ }
+
+ if (! null) {
+
+/* Check the result column by column. */
+
+ if (conj) {
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transt = 'T';
+ }
+ jc = 1;
+ i__5 = n;
+ for (j = 1; j <= i__5; ++j) {
+ if (upper) {
+ jj = 1;
+ lj = j;
+ } else {
+ jj = j;
+ lj = n - j + 1;
+ }
+ if (tran) {
+ zmmch_(transt, "N", &lj, &c__1, &k, &
+ alpha, &a[jj * a_dim1 + 1],
+ nmax, &a[j * a_dim1 + 1],
+ nmax, &beta, &c__[jj + j *
+ c_dim1], nmax, &ct[1], &g[1],
+ &cc[jc], &ldc, eps, &err,
+ fatal, nout, &c_true, (ftnlen)
+ 1, (ftnlen)1);
+ } else {
+ zmmch_("N", transt, &lj, &c__1, &k, &
+ alpha, &a[jj + a_dim1], nmax,
+ &a[j + a_dim1], nmax, &beta, &
+ c__[jj + j * c_dim1], nmax, &
+ ct[1], &g[1], &cc[jc], &ldc,
+ eps, &err, fatal, nout, &
+ c_true, (ftnlen)1, (ftnlen)1);
+ }
+ if (upper) {
+ jc += ldc;
+ } else {
+ jc = jc + ldc + 1;
+ }
+ errmax = max(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L110;
+ }
+/* L40: */
+ }
+ }
+
+/* L50: */
+ }
+
+/* L60: */
+ }
+
+/* L70: */
+ }
+
+L80:
+ ;
+ }
+
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___286.ciunit = *nout;
+ s_wsfe(&io___286);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___287.ciunit = *nout;
+ s_wsfe(&io___287);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ goto L130;
+
+L110:
+ if (n > 1) {
+ io___288.ciunit = *nout;
+ s_wsfe(&io___288);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L120:
+ io___289.ciunit = *nout;
+ s_wsfe(&io___289);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (conj) {
+ io___290.ciunit = *nout;
+ s_wsfe(&io___290);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ralpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&rbeta, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___291.ciunit = *nout;
+ s_wsfe(&io___291);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L130:
+ return 0;
+
+
+/* End of ZCHK4. */
+
+} /* zchk4_ */
+
+/* Subroutine */ int zchk5_(char *sname, doublereal *eps, doublereal *thresh,
+ integer *nout, integer *ntra, logical *trace, logical *rewi, logical *
+ fatal, integer *nidim, integer *idim, integer *nalf, doublecomplex *
+ alf, integer *nbet, doublecomplex *bet, integer *nmax, doublecomplex *
+ ab, doublecomplex *aa, doublecomplex *as, doublecomplex *bb,
+ doublecomplex *bs, doublecomplex *c__, doublecomplex *cc,
+ doublecomplex *cs, doublecomplex *ct, doublereal *g, doublecomplex *w,
+ ftnlen sname_len)
+{
+ /* Initialized data */
+
+ static char icht[2] = "NC";
+ static char ichu[2] = "UL";
+
+ /* Format strings */
+ static char fmt_9994[] = "(1x,i6,\002: \002,a6,\002(\002,2(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,\002)"
+ ", A,\002,i3,\002, B,\002,i3,\002,\002,f4.1,\002, C,\002,i3,\002)"
+ " .\002)";
+ static char fmt_9993[] = "(1x,i6,\002: \002,a6,\002(\002,2(\002'\002,a1"
+ ",\002',\002),2(i3,\002,\002),\002(\002,f4.1,\002,\002,f4.1,\002)"
+ ", A,\002,i3,\002, B,\002,i3,\002,(\002,f4.1,\002,\002,f4.1,\002)"
+ ", C,\002,i3,\002) .\002)";
+ static char fmt_9992[] = "(\002 ******* FATAL ERROR - ERROR-EXIT TAKEN O"
+ "N VALID CALL *\002,\002******\002)";
+ static char fmt_9998[] = "(\002 ******* FATAL ERROR - PARAMETER NUMBER"
+ " \002,i2,\002 WAS CH\002,\002ANGED INCORRECTLY *******\002)";
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE COMPUTATIONAL TE"
+ "STS (\002,i6,\002 CALL\002,\002S)\002)";
+ static char fmt_9997[] = "(\002 \002,a6,\002 COMPLETED THE COMPUTATIONAL"
+ " TESTS (\002,i6,\002 C\002,\002ALLS)\002,/\002 ******* BUT WITH "
+ "MAXIMUM TEST RATIO\002,f8.2,\002 - SUSPECT *******\002)";
+ static char fmt_9995[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+ static char fmt_9996[] = "(\002 ******* \002,a6,\002 FAILED ON CALL NUMB"
+ "ER:\002)";
+
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
+ doublecomplex z__1, z__2;
+ alist al__1;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), do_fio(
+ integer *, char *, ftnlen), e_wsfe(void), f_rew(alist *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, n, ia, ib, jc, ma, na, nc, ik, in, jj, lj, ks, ns, laa,
+ lbb, lda, lcc, ldb, ldc;
+ doublecomplex als;
+ integer ict, icu;
+ doublereal err;
+ extern logical lze_(doublecomplex *, doublecomplex *, integer *);
+ integer jjab;
+ doublecomplex beta;
+ integer ldas, ldbs, ldcs;
+ logical same, conj;
+ doublecomplex bets;
+ logical tran, null;
+ char uplo[1];
+ doublecomplex alpha;
+ doublereal rbeta;
+ logical isame[13];
+ extern /* Subroutine */ int zmake_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ logical *, doublecomplex *, ftnlen, ftnlen, ftnlen);
+ integer nargs;
+ extern /* Subroutine */ int zmmch_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, doublereal *, doublecomplex *,
+ integer *, doublereal *, doublereal *, logical *, integer *,
+ logical *, ftnlen, ftnlen);
+ doublereal rbets;
+ logical reset;
+ char trans[1];
+ logical upper;
+ char uplos[1];
+ extern /* Subroutine */ int zher2k_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, doublecomplex *, integer *), zsyr2k_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ doublereal errmax;
+ extern logical lzeres_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, ftnlen, ftnlen);
+ char transs[1], transt[1];
+
+ /* Fortran I/O blocks */
+ static cilist io___334 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___335 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___336 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___339 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___347 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___348 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___349 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___350 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___351 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___352 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* Tests ZHER2K and ZSYR2K. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --idim;
+ --alf;
+ --bet;
+ --w;
+ --g;
+ --ct;
+ --cs;
+ --cc;
+ c_dim1 = *nmax;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --bs;
+ --bb;
+ --as;
+ --aa;
+ --ab;
+
+ /* Function Body */
+/* .. Executable Statements .. */
+ conj = s_cmp(sname + 1, "HE", (ftnlen)2, (ftnlen)2) == 0;
+
+ nargs = 12;
+ nc = 0;
+ reset = TRUE_;
+ errmax = 0.;
+
+ i__1 = *nidim;
+ for (in = 1; in <= i__1; ++in) {
+ n = idim[in];
+/* Set LDC to 1 more than minimum value if room. */
+ ldc = n;
+ if (ldc < *nmax) {
+ ++ldc;
+ }
+/* Skip tests if not enough room. */
+ if (ldc > *nmax) {
+ goto L130;
+ }
+ lcc = ldc * n;
+
+ i__2 = *nidim;
+ for (ik = 1; ik <= i__2; ++ik) {
+ k = idim[ik];
+
+ for (ict = 1; ict <= 2; ++ict) {
+ *(unsigned char *)trans = *(unsigned char *)&icht[ict - 1];
+ tran = *(unsigned char *)trans == 'C';
+ if (tran && ! conj) {
+ *(unsigned char *)trans = 'T';
+ }
+ if (tran) {
+ ma = k;
+ na = n;
+ } else {
+ ma = n;
+ na = k;
+ }
+/* Set LDA to 1 more than minimum value if room. */
+ lda = ma;
+ if (lda < *nmax) {
+ ++lda;
+ }
+/* Skip tests if not enough room. */
+ if (lda > *nmax) {
+ goto L110;
+ }
+ laa = lda * na;
+
+/* Generate the matrix A. */
+
+ if (tran) {
+ i__3 = *nmax << 1;
+ zmake_("GE", " ", " ", &ma, &na, &ab[1], &i__3, &aa[1], &
+ lda, &reset, &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)
+ 1);
+ } else {
+ zmake_("GE", " ", " ", &ma, &na, &ab[1], nmax, &aa[1], &
+ lda, &reset, &c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)
+ 1);
+ }
+
+/* Generate the matrix B. */
+
+ ldb = lda;
+ lbb = laa;
+ if (tran) {
+ i__3 = *nmax << 1;
+ zmake_("GE", " ", " ", &ma, &na, &ab[k + 1], &i__3, &bb[1]
+ , &ldb, &reset, &c_b1, (ftnlen)2, (ftnlen)1, (
+ ftnlen)1);
+ } else {
+ zmake_("GE", " ", " ", &ma, &na, &ab[k * *nmax + 1], nmax,
+ &bb[1], &ldb, &reset, &c_b1, (ftnlen)2, (ftnlen)
+ 1, (ftnlen)1);
+ }
+
+ for (icu = 1; icu <= 2; ++icu) {
+ *(unsigned char *)uplo = *(unsigned char *)&ichu[icu - 1];
+ upper = *(unsigned char *)uplo == 'U';
+
+ i__3 = *nalf;
+ for (ia = 1; ia <= i__3; ++ia) {
+ i__4 = ia;
+ alpha.r = alf[i__4].r, alpha.i = alf[i__4].i;
+
+ i__4 = *nbet;
+ for (ib = 1; ib <= i__4; ++ib) {
+ i__5 = ib;
+ beta.r = bet[i__5].r, beta.i = bet[i__5].i;
+ if (conj) {
+ rbeta = beta.r;
+ z__1.r = rbeta, z__1.i = 0.;
+ beta.r = z__1.r, beta.i = z__1.i;
+ }
+ null = n <= 0;
+ if (conj) {
+ null = null || (k <= 0 || alpha.r == 0. &&
+ alpha.i == 0.) && rbeta == 1.;
+ }
+
+/* Generate the matrix C. */
+
+ zmake_(sname + 1, uplo, " ", &n, &n, &c__[
+ c_offset], nmax, &cc[1], &ldc, &reset, &
+ c_b1, (ftnlen)2, (ftnlen)1, (ftnlen)1);
+
+ ++nc;
+
+/* Save every datum before calling the subroutine. */
+
+ *(unsigned char *)uplos = *(unsigned char *)uplo;
+ *(unsigned char *)transs = *(unsigned char *)
+ trans;
+ ns = n;
+ ks = k;
+ als.r = alpha.r, als.i = alpha.i;
+ i__5 = laa;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ as[i__6].r = aa[i__7].r, as[i__6].i = aa[i__7]
+ .i;
+/* L10: */
+ }
+ ldas = lda;
+ i__5 = lbb;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ bs[i__6].r = bb[i__7].r, bs[i__6].i = bb[i__7]
+ .i;
+/* L20: */
+ }
+ ldbs = ldb;
+ if (conj) {
+ rbets = rbeta;
+ } else {
+ bets.r = beta.r, bets.i = beta.i;
+ }
+ i__5 = lcc;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = i__;
+ i__7 = i__;
+ cs[i__6].r = cc[i__7].r, cs[i__6].i = cc[i__7]
+ .i;
+/* L30: */
+ }
+ ldcs = ldc;
+
+/* Call the subroutine. */
+
+ if (conj) {
+ if (*trace) {
+ io___334.ciunit = *ntra;
+ s_wsfe(&io___334);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&rbeta, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ zher2k_(uplo, trans, &n, &k, &alpha, &aa[1], &
+ lda, &bb[1], &ldb, &rbeta, &cc[1], &
+ ldc);
+ } else {
+ if (*trace) {
+ io___335.ciunit = *ntra;
+ s_wsfe(&io___335);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)
+ sizeof(doublereal));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+ if (*rewi) {
+ al__1.aerr = 0;
+ al__1.aunit = *ntra;
+ f_rew(&al__1);
+ }
+ zsyr2k_(uplo, trans, &n, &k, &alpha, &aa[1], &
+ lda, &bb[1], &ldb, &beta, &cc[1], &
+ ldc);
+ }
+
+/* Check if error-exit was taken incorrectly. */
+
+ if (! infoc_1.ok) {
+ io___336.ciunit = *nout;
+ s_wsfe(&io___336);
+ e_wsfe();
+ *fatal = TRUE_;
+ goto L150;
+ }
+
+/* See what data changed inside subroutines. */
+
+ isame[0] = *(unsigned char *)uplos == *(unsigned
+ char *)uplo;
+ isame[1] = *(unsigned char *)transs == *(unsigned
+ char *)trans;
+ isame[2] = ns == n;
+ isame[3] = ks == k;
+ isame[4] = als.r == alpha.r && als.i == alpha.i;
+ isame[5] = lze_(&as[1], &aa[1], &laa);
+ isame[6] = ldas == lda;
+ isame[7] = lze_(&bs[1], &bb[1], &lbb);
+ isame[8] = ldbs == ldb;
+ if (conj) {
+ isame[9] = rbets == rbeta;
+ } else {
+ isame[9] = bets.r == beta.r && bets.i ==
+ beta.i;
+ }
+ if (null) {
+ isame[10] = lze_(&cs[1], &cc[1], &lcc);
+ } else {
+ isame[10] = lzeres_("HE", uplo, &n, &n, &cs[1]
+ , &cc[1], &ldc, (ftnlen)2, (ftnlen)1);
+ }
+ isame[11] = ldcs == ldc;
+
+/* If data was incorrectly changed, report and */
+/* return. */
+
+ same = TRUE_;
+ i__5 = nargs;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ same = same && isame[i__ - 1];
+ if (! isame[i__ - 1]) {
+ io___339.ciunit = *nout;
+ s_wsfe(&io___339);
+ do_fio(&c__1, (char *)&i__, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ }
+/* L40: */
+ }
+ if (! same) {
+ *fatal = TRUE_;
+ goto L150;
+ }
+
+ if (! null) {
+
+/* Check the result column by column. */
+
+ if (conj) {
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transt = 'T';
+ }
+ jjab = 1;
+ jc = 1;
+ i__5 = n;
+ for (j = 1; j <= i__5; ++j) {
+ if (upper) {
+ jj = 1;
+ lj = j;
+ } else {
+ jj = j;
+ lj = n - j + 1;
+ }
+ if (tran) {
+ i__6 = k;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ i__7 = i__;
+ i__8 = (j - 1 << 1) * *nmax + k +
+ i__;
+ z__1.r = alpha.r * ab[i__8].r -
+ alpha.i * ab[i__8].i,
+ z__1.i = alpha.r * ab[
+ i__8].i + alpha.i * ab[
+ i__8].r;
+ w[i__7].r = z__1.r, w[i__7].i =
+ z__1.i;
+ if (conj) {
+ i__7 = k + i__;
+ d_cnjg(&z__2, &alpha);
+ i__8 = (j - 1 << 1) * *nmax + i__;
+ z__1.r = z__2.r * ab[i__8].r - z__2.i * ab[i__8].i,
+ z__1.i = z__2.r * ab[i__8].i + z__2.i * ab[
+ i__8].r;
+ w[i__7].r = z__1.r, w[i__7].i = z__1.i;
+ } else {
+ i__7 = k + i__;
+ i__8 = (j - 1 << 1) * *nmax + i__;
+ z__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8]
+ .i, z__1.i = alpha.r * ab[i__8].i + alpha.i
+ * ab[i__8].r;
+ w[i__7].r = z__1.r, w[i__7].i = z__1.i;
+ }
+/* L50: */
+ }
+ i__6 = k << 1;
+ i__7 = *nmax << 1;
+ i__8 = *nmax << 1;
+ zmmch_(transt, "N", &lj, &c__1, &i__6,
+ &c_b2, &ab[jjab], &i__7, &w[
+ 1], &i__8, &beta, &c__[jj + j
+ * c_dim1], nmax, &ct[1], &g[1]
+ , &cc[jc], &ldc, eps, &err,
+ fatal, nout, &c_true, (ftnlen)
+ 1, (ftnlen)1);
+ } else {
+ i__6 = k;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ if (conj) {
+ i__7 = i__;
+ d_cnjg(&z__2, &ab[(k + i__ - 1) * *nmax + j]);
+ z__1.r = alpha.r * z__2.r - alpha.i * z__2.i,
+ z__1.i = alpha.r * z__2.i + alpha.i *
+ z__2.r;
+ w[i__7].r = z__1.r, w[i__7].i = z__1.i;
+ i__7 = k + i__;
+ i__8 = (i__ - 1) * *nmax + j;
+ z__2.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8]
+ .i, z__2.i = alpha.r * ab[i__8].i + alpha.i
+ * ab[i__8].r;
+ d_cnjg(&z__1, &z__2);
+ w[i__7].r = z__1.r, w[i__7].i = z__1.i;
+ } else {
+ i__7 = i__;
+ i__8 = (k + i__ - 1) * *nmax + j;
+ z__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8]
+ .i, z__1.i = alpha.r * ab[i__8].i + alpha.i
+ * ab[i__8].r;
+ w[i__7].r = z__1.r, w[i__7].i = z__1.i;
+ i__7 = k + i__;
+ i__8 = (i__ - 1) * *nmax + j;
+ z__1.r = alpha.r * ab[i__8].r - alpha.i * ab[i__8]
+ .i, z__1.i = alpha.r * ab[i__8].i + alpha.i
+ * ab[i__8].r;
+ w[i__7].r = z__1.r, w[i__7].i = z__1.i;
+ }
+/* L60: */
+ }
+ i__6 = k << 1;
+ i__7 = *nmax << 1;
+ zmmch_("N", "N", &lj, &c__1, &i__6, &
+ c_b2, &ab[jj], nmax, &w[1], &
+ i__7, &beta, &c__[jj + j *
+ c_dim1], nmax, &ct[1], &g[1],
+ &cc[jc], &ldc, eps, &err,
+ fatal, nout, &c_true, (ftnlen)
+ 1, (ftnlen)1);
+ }
+ if (upper) {
+ jc += ldc;
+ } else {
+ jc = jc + ldc + 1;
+ if (tran) {
+ jjab += *nmax << 1;
+ }
+ }
+ errmax = max(errmax,err);
+/* If got really bad answer, report and */
+/* return. */
+ if (*fatal) {
+ goto L140;
+ }
+/* L70: */
+ }
+ }
+
+/* L80: */
+ }
+
+/* L90: */
+ }
+
+/* L100: */
+ }
+
+L110:
+ ;
+ }
+
+/* L120: */
+ }
+
+L130:
+ ;
+ }
+
+/* Report result. */
+
+ if (errmax < *thresh) {
+ io___347.ciunit = *nout;
+ s_wsfe(&io___347);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___348.ciunit = *nout;
+ s_wsfe(&io___348);
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&errmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ goto L160;
+
+L140:
+ if (n > 1) {
+ io___349.ciunit = *nout;
+ s_wsfe(&io___349);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L150:
+ io___350.ciunit = *nout;
+ s_wsfe(&io___350);
+ do_fio(&c__1, sname, (ftnlen)6);
+ e_wsfe();
+ if (conj) {
+ io___351.ciunit = *nout;
+ s_wsfe(&io___351);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&rbeta, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___352.ciunit = *nout;
+ s_wsfe(&io___352);
+ do_fio(&c__1, (char *)&nc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, sname, (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&alpha, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&lda, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ldb, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&beta, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&ldc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L160:
+ return 0;
+
+
+/* End of ZCHK5. */
+
+} /* zchk5_ */
+
+/* Subroutine */ int zchke_(integer *isnum, char *srnamt, integer *nout,
+ ftnlen srnamt_len)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 \002,a6,\002 PASSED THE TESTS OF ERROR-E"
+ "XITS\002)";
+ static char fmt_9998[] = "(\002 ******* \002,a6,\002 FAILED THE TESTS OF"
+ " ERROR-EXITS *****\002,\002**\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublecomplex a[2] /* was [2][1] */, b[2] /* was [2][1] */, c__[2]
+ /* was [2][1] */, beta, alpha;
+ doublereal rbeta;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zhemm_(char *, char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zherk_(char *, char *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *), ztrmm_(char *, char
+ *, char *, char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), zsymm_(char *, char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), ztrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *
+, doublecomplex *, integer *),
+ zsyrk_(char *, char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zher2k_(char *, char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ integer *), zsyr2k_(char *, char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ doublereal ralpha;
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *);
+
+ /* Fortran I/O blocks */
+ static cilist io___360 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___361 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* Tests the error exits from the Level 3 Blas. */
+/* Requires a special version of the error-handling routine XERBLA. */
+/* A, B and C should not need to be defined. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* 3-19-92: Initialize ALPHA, BETA, RALPHA, and RBETA (eca) */
+/* 3-19-92: Fix argument 12 in calls to ZSYMM and ZHEMM */
+/* with INFOT = 9 (eca) */
+/* 10-9-00: Declared INTRINSIC DCMPLX (susan) */
+
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Parameters .. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+/* OK is set to .FALSE. by the special version of XERBLA or by CHKXER */
+/* if anything is wrong. */
+ infoc_1.ok = TRUE_;
+/* LERR is set to .TRUE. by the special version of XERBLA each time */
+/* it is called, and is then tested and re-set by CHKXER. */
+ infoc_1.lerr = FALSE_;
+
+/* Initialize ALPHA, BETA, RALPHA, and RBETA. */
+
+ alpha.r = 1., alpha.i = -1.;
+ beta.r = 2., beta.i = -2.;
+ ralpha = 1.f;
+ rbeta = 2.f;
+
+ switch (*isnum) {
+ case 1: goto L10;
+ case 2: goto L20;
+ case 3: goto L30;
+ case 4: goto L40;
+ case 5: goto L50;
+ case 6: goto L60;
+ case 7: goto L70;
+ case 8: goto L80;
+ case 9: goto L90;
+ }
+L10:
+ infoc_1.infot = 1;
+ zgemm_("/", "N", &c__0, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 1;
+ zgemm_("/", "C", &c__0, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 1;
+ zgemm_("/", "T", &c__0, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ zgemm_("N", "/", &c__0, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ zgemm_("C", "/", &c__0, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ zgemm_("T", "/", &c__0, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zgemm_("N", "N", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zgemm_("N", "C", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zgemm_("N", "T", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zgemm_("C", "N", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zgemm_("C", "C", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zgemm_("C", "T", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zgemm_("T", "N", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zgemm_("T", "C", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zgemm_("T", "T", &c_n1, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zgemm_("N", "N", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zgemm_("N", "C", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zgemm_("N", "T", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zgemm_("C", "N", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zgemm_("C", "C", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zgemm_("C", "T", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zgemm_("T", "N", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zgemm_("T", "C", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zgemm_("T", "T", &c__0, &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ zgemm_("N", "N", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ zgemm_("N", "C", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ zgemm_("N", "T", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ zgemm_("C", "N", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ zgemm_("C", "C", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ zgemm_("C", "T", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ zgemm_("T", "N", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ zgemm_("T", "C", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ zgemm_("T", "T", &c__0, &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ zgemm_("N", "N", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ zgemm_("N", "C", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ zgemm_("N", "T", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ zgemm_("C", "N", &c__0, &c__0, &c__2, &alpha, a, &c__1, b, &c__2, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ zgemm_("C", "C", &c__0, &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ zgemm_("C", "T", &c__0, &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ zgemm_("T", "N", &c__0, &c__0, &c__2, &alpha, a, &c__1, b, &c__2, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ zgemm_("T", "C", &c__0, &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 8;
+ zgemm_("T", "T", &c__0, &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ zgemm_("N", "N", &c__0, &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ zgemm_("C", "N", &c__0, &c__0, &c__2, &alpha, a, &c__2, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ zgemm_("T", "N", &c__0, &c__0, &c__2, &alpha, a, &c__2, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ zgemm_("N", "C", &c__0, &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ zgemm_("C", "C", &c__0, &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ zgemm_("T", "C", &c__0, &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ zgemm_("N", "T", &c__0, &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ zgemm_("C", "T", &c__0, &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ zgemm_("T", "T", &c__0, &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ zgemm_("N", "N", &c__2, &c__0, &c__0, &alpha, a, &c__2, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ zgemm_("N", "C", &c__2, &c__0, &c__0, &alpha, a, &c__2, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ zgemm_("N", "T", &c__2, &c__0, &c__0, &alpha, a, &c__2, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ zgemm_("C", "N", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ zgemm_("C", "C", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ zgemm_("C", "T", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ zgemm_("T", "N", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ zgemm_("T", "C", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 13;
+ zgemm_("T", "T", &c__2, &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta,
+ c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L100;
+L20:
+ infoc_1.infot = 1;
+ zhemm_("/", "U", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ zhemm_("L", "/", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zhemm_("L", "U", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zhemm_("R", "U", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zhemm_("L", "L", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zhemm_("R", "L", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zhemm_("L", "U", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zhemm_("R", "U", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zhemm_("L", "L", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zhemm_("R", "L", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zhemm_("L", "U", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zhemm_("R", "U", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zhemm_("L", "L", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zhemm_("R", "L", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ zhemm_("L", "U", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ zhemm_("R", "U", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ zhemm_("L", "L", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ zhemm_("R", "L", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ zhemm_("L", "U", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ zhemm_("R", "U", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ zhemm_("L", "L", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ zhemm_("R", "L", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L100;
+L30:
+ infoc_1.infot = 1;
+ zsymm_("/", "U", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ zsymm_("L", "/", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zsymm_("L", "U", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zsymm_("R", "U", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zsymm_("L", "L", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zsymm_("R", "L", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zsymm_("L", "U", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zsymm_("R", "U", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zsymm_("L", "L", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zsymm_("R", "L", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zsymm_("L", "U", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zsymm_("R", "U", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zsymm_("L", "L", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zsymm_("R", "L", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ zsymm_("L", "U", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ zsymm_("R", "U", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ zsymm_("L", "L", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ zsymm_("R", "L", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ zsymm_("L", "U", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ zsymm_("R", "U", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ zsymm_("L", "L", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ zsymm_("R", "L", &c__2, &c__0, &alpha, a, &c__1, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L100;
+L40:
+ infoc_1.infot = 1;
+ ztrmm_("/", "U", "N", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ ztrmm_("L", "/", "N", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ztrmm_("L", "U", "/", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ztrmm_("L", "U", "N", "/", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrmm_("L", "U", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrmm_("L", "U", "C", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrmm_("L", "U", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrmm_("R", "U", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrmm_("R", "U", "C", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrmm_("R", "U", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrmm_("L", "L", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrmm_("L", "L", "C", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrmm_("L", "L", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrmm_("R", "L", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrmm_("R", "L", "C", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrmm_("R", "L", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrmm_("L", "U", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrmm_("L", "U", "C", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrmm_("L", "U", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrmm_("R", "U", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrmm_("R", "U", "C", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrmm_("R", "U", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrmm_("L", "L", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrmm_("L", "L", "C", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrmm_("L", "L", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrmm_("R", "L", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrmm_("R", "L", "C", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrmm_("R", "L", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrmm_("L", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrmm_("L", "U", "C", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrmm_("L", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrmm_("R", "U", "N", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrmm_("R", "U", "C", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrmm_("R", "U", "T", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrmm_("L", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrmm_("L", "L", "C", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrmm_("L", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrmm_("R", "L", "N", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrmm_("R", "L", "C", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrmm_("R", "L", "T", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrmm_("L", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrmm_("L", "U", "C", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrmm_("L", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrmm_("R", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrmm_("R", "U", "C", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrmm_("R", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrmm_("L", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrmm_("L", "L", "C", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrmm_("L", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrmm_("R", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrmm_("R", "L", "C", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrmm_("R", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L100;
+L50:
+ infoc_1.infot = 1;
+ ztrsm_("/", "U", "N", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ ztrsm_("L", "/", "N", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ ztrsm_("L", "U", "/", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ ztrsm_("L", "U", "N", "/", &c__0, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrsm_("L", "U", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrsm_("L", "U", "C", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrsm_("L", "U", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrsm_("R", "U", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrsm_("R", "U", "C", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrsm_("R", "U", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrsm_("L", "L", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrsm_("L", "L", "C", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrsm_("L", "L", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrsm_("R", "L", "N", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrsm_("R", "L", "C", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrsm_("R", "L", "T", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrsm_("L", "U", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrsm_("L", "U", "C", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrsm_("L", "U", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrsm_("R", "U", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrsm_("R", "U", "C", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrsm_("R", "U", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrsm_("L", "L", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrsm_("L", "L", "C", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrsm_("L", "L", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrsm_("R", "L", "N", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrsm_("R", "L", "C", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrsm_("R", "L", "T", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrsm_("L", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrsm_("L", "U", "C", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrsm_("L", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrsm_("R", "U", "N", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrsm_("R", "U", "C", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrsm_("R", "U", "T", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrsm_("L", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrsm_("L", "L", "C", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrsm_("L", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrsm_("R", "L", "N", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrsm_("R", "L", "C", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrsm_("R", "L", "T", "N", &c__0, &c__2, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrsm_("L", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrsm_("L", "U", "C", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrsm_("L", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrsm_("R", "U", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrsm_("R", "U", "C", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrsm_("R", "U", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrsm_("L", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrsm_("L", "L", "C", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrsm_("L", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrsm_("R", "L", "N", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrsm_("R", "L", "C", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrsm_("R", "L", "T", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L100;
+L60:
+ infoc_1.infot = 1;
+ zherk_("/", "N", &c__0, &c__0, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ zherk_("U", "T", &c__0, &c__0, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zherk_("U", "N", &c_n1, &c__0, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zherk_("U", "C", &c_n1, &c__0, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zherk_("L", "N", &c_n1, &c__0, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zherk_("L", "C", &c_n1, &c__0, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zherk_("U", "N", &c__0, &c_n1, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zherk_("U", "C", &c__0, &c_n1, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zherk_("L", "N", &c__0, &c_n1, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zherk_("L", "C", &c__0, &c_n1, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zherk_("U", "N", &c__2, &c__0, &ralpha, a, &c__1, &rbeta, c__, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zherk_("U", "C", &c__0, &c__2, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zherk_("L", "N", &c__2, &c__0, &ralpha, a, &c__1, &rbeta, c__, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zherk_("L", "C", &c__0, &c__2, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ zherk_("U", "N", &c__2, &c__0, &ralpha, a, &c__2, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ zherk_("U", "C", &c__2, &c__0, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ zherk_("L", "N", &c__2, &c__0, &ralpha, a, &c__2, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ zherk_("L", "C", &c__2, &c__0, &ralpha, a, &c__1, &rbeta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L100;
+L70:
+ infoc_1.infot = 1;
+ zsyrk_("/", "N", &c__0, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ zsyrk_("U", "C", &c__0, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zsyrk_("U", "N", &c_n1, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zsyrk_("U", "T", &c_n1, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zsyrk_("L", "N", &c_n1, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zsyrk_("L", "T", &c_n1, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zsyrk_("U", "N", &c__0, &c_n1, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zsyrk_("U", "T", &c__0, &c_n1, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zsyrk_("L", "N", &c__0, &c_n1, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zsyrk_("L", "T", &c__0, &c_n1, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zsyrk_("U", "N", &c__2, &c__0, &alpha, a, &c__1, &beta, c__, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zsyrk_("U", "T", &c__0, &c__2, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zsyrk_("L", "N", &c__2, &c__0, &alpha, a, &c__1, &beta, c__, &c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zsyrk_("L", "T", &c__0, &c__2, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ zsyrk_("U", "N", &c__2, &c__0, &alpha, a, &c__2, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ zsyrk_("U", "T", &c__2, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ zsyrk_("L", "N", &c__2, &c__0, &alpha, a, &c__2, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 10;
+ zsyrk_("L", "T", &c__2, &c__0, &alpha, a, &c__1, &beta, c__, &c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L100;
+L80:
+ infoc_1.infot = 1;
+ zher2k_("/", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ zher2k_("U", "T", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zher2k_("U", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zher2k_("U", "C", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zher2k_("L", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zher2k_("L", "C", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zher2k_("U", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zher2k_("U", "C", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zher2k_("L", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zher2k_("L", "C", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zher2k_("U", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zher2k_("U", "C", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zher2k_("L", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zher2k_("L", "C", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ zher2k_("U", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &rbeta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ zher2k_("U", "C", &c__0, &c__2, &alpha, a, &c__2, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ zher2k_("L", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &rbeta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ zher2k_("L", "C", &c__0, &c__2, &alpha, a, &c__2, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ zher2k_("U", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ zher2k_("U", "C", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ zher2k_("L", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ zher2k_("L", "C", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &rbeta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ goto L100;
+L90:
+ infoc_1.infot = 1;
+ zsyr2k_("/", "N", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 2;
+ zsyr2k_("U", "C", &c__0, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zsyr2k_("U", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zsyr2k_("U", "T", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zsyr2k_("L", "N", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 3;
+ zsyr2k_("L", "T", &c_n1, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zsyr2k_("U", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zsyr2k_("U", "T", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zsyr2k_("L", "N", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 4;
+ zsyr2k_("L", "T", &c__0, &c_n1, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zsyr2k_("U", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zsyr2k_("U", "T", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zsyr2k_("L", "N", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 7;
+ zsyr2k_("L", "T", &c__0, &c__2, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ zsyr2k_("U", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ zsyr2k_("U", "T", &c__0, &c__2, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ zsyr2k_("L", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__2);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 9;
+ zsyr2k_("L", "T", &c__0, &c__2, &alpha, a, &c__2, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ zsyr2k_("U", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ zsyr2k_("U", "T", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ zsyr2k_("L", "N", &c__2, &c__0, &alpha, a, &c__2, b, &c__2, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+ infoc_1.infot = 12;
+ zsyr2k_("L", "T", &c__2, &c__0, &alpha, a, &c__1, b, &c__1, &beta, c__, &
+ c__1);
+ chkxer_(srnamt, &infoc_1.infot, nout, &infoc_1.lerr, &infoc_1.ok);
+
+L100:
+ if (infoc_1.ok) {
+ io___360.ciunit = *nout;
+ s_wsfe(&io___360);
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ } else {
+ io___361.ciunit = *nout;
+ s_wsfe(&io___361);
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ }
+ return 0;
+
+
+/* End of ZCHKE. */
+
+} /* zchke_ */
+
+/* Subroutine */ int zmake_(char *type__, char *uplo, char *diag, integer *m,
+ integer *n, doublecomplex *a, integer *nmax, doublecomplex *aa,
+ integer *lda, logical *reset, doublecomplex *transl, ftnlen type_len,
+ ftnlen uplo_len, ftnlen diag_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, jj;
+ logical gen, her, tri, sym;
+ integer ibeg, iend;
+ extern /* Double Complex */ VOID zbeg_(doublecomplex *, logical *);
+ logical unit, lower, upper;
+
+
+/* Generates values for an M by N matrix A. */
+/* Stores the values in the array AA in the data structure required */
+/* by the routine, with unwanted elements set to rogue value. */
+
+/* TYPE is 'GE', 'HE', 'SY' or 'TR'. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. External Functions .. */
+/* .. Intrinsic Functions .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *nmax;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --aa;
+
+ /* Function Body */
+ gen = s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0;
+ her = s_cmp(type__, "HE", (ftnlen)2, (ftnlen)2) == 0;
+ sym = s_cmp(type__, "SY", (ftnlen)2, (ftnlen)2) == 0;
+ tri = s_cmp(type__, "TR", (ftnlen)2, (ftnlen)2) == 0;
+ upper = (her || sym || tri) && *(unsigned char *)uplo == 'U';
+ lower = (her || sym || tri) && *(unsigned char *)uplo == 'L';
+ unit = tri && *(unsigned char *)diag == 'U';
+
+/* Generate data in array A. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (gen || upper && i__ <= j || lower && i__ >= j) {
+ i__3 = i__ + j * a_dim1;
+ zbeg_(&z__2, reset);
+ z__1.r = z__2.r + transl->r, z__1.i = z__2.i + transl->i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ if (i__ != j) {
+/* Set some elements to zero */
+ if (*n > 3 && j == *n / 2) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ }
+ if (her) {
+ i__3 = j + i__ * a_dim1;
+ d_cnjg(&z__1, &a[i__ + j * a_dim1]);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ } else if (sym) {
+ i__3 = j + i__ * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
+ } else if (tri) {
+ i__3 = j + i__ * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ }
+ }
+ }
+/* L10: */
+ }
+ if (her) {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ d__1 = a[i__3].r;
+ z__1.r = d__1, z__1.i = 0.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ }
+ if (tri) {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ z__1.r = a[i__3].r + 1., z__1.i = a[i__3].i + 0.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ }
+ if (unit) {
+ i__2 = j + j * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+ }
+/* L20: */
+ }
+
+/* Store elements in array AS in data structure required by routine. */
+
+ if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ i__4 = i__ + j * a_dim1;
+ aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
+/* L30: */
+ }
+ i__2 = *lda;
+ for (i__ = *m + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ aa[i__3].r = -1e10, aa[i__3].i = 1e10;
+/* L40: */
+ }
+/* L50: */
+ }
+ } else if (s_cmp(type__, "HE", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
+ "SY", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__, "TR", (ftnlen)
+ 2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ ibeg = 1;
+ if (unit) {
+ iend = j - 1;
+ } else {
+ iend = j;
+ }
+ } else {
+ if (unit) {
+ ibeg = j + 1;
+ } else {
+ ibeg = j;
+ }
+ iend = *n;
+ }
+ i__2 = ibeg - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ aa[i__3].r = -1e10, aa[i__3].i = 1e10;
+/* L60: */
+ }
+ i__2 = iend;
+ for (i__ = ibeg; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ i__4 = i__ + j * a_dim1;
+ aa[i__3].r = a[i__4].r, aa[i__3].i = a[i__4].i;
+/* L70: */
+ }
+ i__2 = *lda;
+ for (i__ = iend + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * *lda;
+ aa[i__3].r = -1e10, aa[i__3].i = 1e10;
+/* L80: */
+ }
+ if (her) {
+ jj = j + (j - 1) * *lda;
+ i__2 = jj;
+ i__3 = jj;
+ d__1 = aa[i__3].r;
+ z__1.r = d__1, z__1.i = -1e10;
+ aa[i__2].r = z__1.r, aa[i__2].i = z__1.i;
+ }
+/* L90: */
+ }
+ }
+ return 0;
+
+/* End of ZMAKE. */
+
+} /* zmake_ */
+
+/* Subroutine */ int zmmch_(char *transa, char *transb, integer *m, integer *
+ n, integer *kk, doublecomplex *alpha, doublecomplex *a, integer *lda,
+ doublecomplex *b, integer *ldb, doublecomplex *beta, doublecomplex *
+ c__, integer *ldc, doublecomplex *ct, doublereal *g, doublecomplex *
+ cc, integer *ldcc, doublereal *eps, doublereal *err, logical *fatal,
+ integer *nout, logical *mv, ftnlen transa_len, ftnlen transb_len)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* FATAL ERROR - COMPUTED RESULT IS"
+ " LESS THAN HAL\002,\002F ACCURATE *******\002,/\002 "
+ " EXPECTED RE\002,\002SULT COMPUTED R"
+ "ESULT\002)";
+ static char fmt_9998[] = "(1x,i7,2(\002 (\002,g15.6,\002,\002,g15.6,"
+ "\002)\002))";
+ static char fmt_9997[] = "(\002 THESE ARE THE RESULTS FOR COLUMN"
+ " \002,i3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, cc_dim1,
+ cc_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal erri;
+ logical trana, tranb, ctrana, ctranb;
+
+ /* Fortran I/O blocks */
+ static cilist io___382 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___383 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___384 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___385 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* Checks the results of the computational tests. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Parameters .. */
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Intrinsic Functions .. */
+/* .. Statement Functions .. */
+/* .. Statement Function definitions .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --ct;
+ --g;
+ cc_dim1 = *ldcc;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+
+ /* Function Body */
+ trana = *(unsigned char *)transa == 'T' || *(unsigned char *)transa ==
+ 'C';
+ tranb = *(unsigned char *)transb == 'T' || *(unsigned char *)transb ==
+ 'C';
+ ctrana = *(unsigned char *)transa == 'C';
+ ctranb = *(unsigned char *)transb == 'C';
+
+/* Compute expected result, one column at a time, in CT using data */
+/* in A, B and C. */
+/* Compute gauges in G. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ ct[i__3].r = 0., ct[i__3].i = 0.;
+ g[i__] = 0.;
+/* L10: */
+ }
+ if (! trana && ! tranb) {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ i__6 = i__ + k * a_dim1;
+ i__7 = k + j * b_dim1;
+ z__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7].i,
+ z__2.i = a[i__6].r * b[i__7].i + a[i__6].i * b[
+ i__7].r;
+ z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i +
+ z__2.i;
+ ct[i__4].r = z__1.r, ct[i__4].i = z__1.i;
+ i__4 = i__ + k * a_dim1;
+ i__5 = k + j * b_dim1;
+ g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(
+ &a[i__ + k * a_dim1]), abs(d__2))) * ((d__3 = b[
+ i__5].r, abs(d__3)) + (d__4 = d_imag(&b[k + j *
+ b_dim1]), abs(d__4)));
+/* L20: */
+ }
+/* L30: */
+ }
+ } else if (trana && ! tranb) {
+ if (ctrana) {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ d_cnjg(&z__3, &a[k + i__ * a_dim1]);
+ i__6 = k + j * b_dim1;
+ z__2.r = z__3.r * b[i__6].r - z__3.i * b[i__6].i,
+ z__2.i = z__3.r * b[i__6].i + z__3.i * b[i__6]
+ .r;
+ z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i +
+ z__2.i;
+ ct[i__4].r = z__1.r, ct[i__4].i = z__1.i;
+ i__4 = k + i__ * a_dim1;
+ i__5 = k + j * b_dim1;
+ g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&a[k + i__ * a_dim1]), abs(d__2))) * ((
+ d__3 = b[i__5].r, abs(d__3)) + (d__4 = d_imag(
+ &b[k + j * b_dim1]), abs(d__4)));
+/* L40: */
+ }
+/* L50: */
+ }
+ } else {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ i__6 = k + i__ * a_dim1;
+ i__7 = k + j * b_dim1;
+ z__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7]
+ .i, z__2.i = a[i__6].r * b[i__7].i + a[i__6]
+ .i * b[i__7].r;
+ z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i +
+ z__2.i;
+ ct[i__4].r = z__1.r, ct[i__4].i = z__1.i;
+ i__4 = k + i__ * a_dim1;
+ i__5 = k + j * b_dim1;
+ g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&a[k + i__ * a_dim1]), abs(d__2))) * ((
+ d__3 = b[i__5].r, abs(d__3)) + (d__4 = d_imag(
+ &b[k + j * b_dim1]), abs(d__4)));
+/* L60: */
+ }
+/* L70: */
+ }
+ }
+ } else if (! trana && tranb) {
+ if (ctranb) {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ i__6 = i__ + k * a_dim1;
+ d_cnjg(&z__3, &b[j + k * b_dim1]);
+ z__2.r = a[i__6].r * z__3.r - a[i__6].i * z__3.i,
+ z__2.i = a[i__6].r * z__3.i + a[i__6].i *
+ z__3.r;
+ z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i +
+ z__2.i;
+ ct[i__4].r = z__1.r, ct[i__4].i = z__1.i;
+ i__4 = i__ + k * a_dim1;
+ i__5 = j + k * b_dim1;
+ g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + k * a_dim1]), abs(d__2))) * ((
+ d__3 = b[i__5].r, abs(d__3)) + (d__4 = d_imag(
+ &b[j + k * b_dim1]), abs(d__4)));
+/* L80: */
+ }
+/* L90: */
+ }
+ } else {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ i__6 = i__ + k * a_dim1;
+ i__7 = j + k * b_dim1;
+ z__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[i__7]
+ .i, z__2.i = a[i__6].r * b[i__7].i + a[i__6]
+ .i * b[i__7].r;
+ z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i +
+ z__2.i;
+ ct[i__4].r = z__1.r, ct[i__4].i = z__1.i;
+ i__4 = i__ + k * a_dim1;
+ i__5 = j + k * b_dim1;
+ g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + k * a_dim1]), abs(d__2))) * ((
+ d__3 = b[i__5].r, abs(d__3)) + (d__4 = d_imag(
+ &b[j + k * b_dim1]), abs(d__4)));
+/* L100: */
+ }
+/* L110: */
+ }
+ }
+ } else if (trana && tranb) {
+ if (ctrana) {
+ if (ctranb) {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ d_cnjg(&z__3, &a[k + i__ * a_dim1]);
+ d_cnjg(&z__4, &b[j + k * b_dim1]);
+ z__2.r = z__3.r * z__4.r - z__3.i * z__4.i,
+ z__2.i = z__3.r * z__4.i + z__3.i *
+ z__4.r;
+ z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i
+ + z__2.i;
+ ct[i__4].r = z__1.r, ct[i__4].i = z__1.i;
+ i__4 = k + i__ * a_dim1;
+ i__5 = j + k * b_dim1;
+ g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&a[k + i__ * a_dim1]), abs(d__2)))
+ * ((d__3 = b[i__5].r, abs(d__3)) + (d__4
+ = d_imag(&b[j + k * b_dim1]), abs(d__4)));
+/* L120: */
+ }
+/* L130: */
+ }
+ } else {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ d_cnjg(&z__3, &a[k + i__ * a_dim1]);
+ i__6 = j + k * b_dim1;
+ z__2.r = z__3.r * b[i__6].r - z__3.i * b[i__6].i,
+ z__2.i = z__3.r * b[i__6].i + z__3.i * b[
+ i__6].r;
+ z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i
+ + z__2.i;
+ ct[i__4].r = z__1.r, ct[i__4].i = z__1.i;
+ i__4 = k + i__ * a_dim1;
+ i__5 = j + k * b_dim1;
+ g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&a[k + i__ * a_dim1]), abs(d__2)))
+ * ((d__3 = b[i__5].r, abs(d__3)) + (d__4
+ = d_imag(&b[j + k * b_dim1]), abs(d__4)));
+/* L140: */
+ }
+/* L150: */
+ }
+ }
+ } else {
+ if (ctranb) {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ i__6 = k + i__ * a_dim1;
+ d_cnjg(&z__3, &b[j + k * b_dim1]);
+ z__2.r = a[i__6].r * z__3.r - a[i__6].i * z__3.i,
+ z__2.i = a[i__6].r * z__3.i + a[i__6].i *
+ z__3.r;
+ z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i
+ + z__2.i;
+ ct[i__4].r = z__1.r, ct[i__4].i = z__1.i;
+ i__4 = k + i__ * a_dim1;
+ i__5 = j + k * b_dim1;
+ g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&a[k + i__ * a_dim1]), abs(d__2)))
+ * ((d__3 = b[i__5].r, abs(d__3)) + (d__4
+ = d_imag(&b[j + k * b_dim1]), abs(d__4)));
+/* L160: */
+ }
+/* L170: */
+ }
+ } else {
+ i__2 = *kk;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ i__6 = k + i__ * a_dim1;
+ i__7 = j + k * b_dim1;
+ z__2.r = a[i__6].r * b[i__7].r - a[i__6].i * b[
+ i__7].i, z__2.i = a[i__6].r * b[i__7].i +
+ a[i__6].i * b[i__7].r;
+ z__1.r = ct[i__5].r + z__2.r, z__1.i = ct[i__5].i
+ + z__2.i;
+ ct[i__4].r = z__1.r, ct[i__4].i = z__1.i;
+ i__4 = k + i__ * a_dim1;
+ i__5 = j + k * b_dim1;
+ g[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&a[k + i__ * a_dim1]), abs(d__2)))
+ * ((d__3 = b[i__5].r, abs(d__3)) + (d__4
+ = d_imag(&b[j + k * b_dim1]), abs(d__4)));
+/* L180: */
+ }
+/* L190: */
+ }
+ }
+ }
+ }
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ z__2.r = alpha->r * ct[i__4].r - alpha->i * ct[i__4].i, z__2.i =
+ alpha->r * ct[i__4].i + alpha->i * ct[i__4].r;
+ i__5 = i__ + j * c_dim1;
+ z__3.r = beta->r * c__[i__5].r - beta->i * c__[i__5].i, z__3.i =
+ beta->r * c__[i__5].i + beta->i * c__[i__5].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ ct[i__3].r = z__1.r, ct[i__3].i = z__1.i;
+ i__3 = i__ + j * c_dim1;
+ g[i__] = ((d__1 = alpha->r, abs(d__1)) + (d__2 = d_imag(alpha),
+ abs(d__2))) * g[i__] + ((d__3 = beta->r, abs(d__3)) + (
+ d__4 = d_imag(beta), abs(d__4))) * ((d__5 = c__[i__3].r,
+ abs(d__5)) + (d__6 = d_imag(&c__[i__ + j * c_dim1]), abs(
+ d__6)));
+/* L200: */
+ }
+
+/* Compute the error ratio for this result. */
+
+ *err = 0.;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__ + j * cc_dim1;
+ z__2.r = ct[i__3].r - cc[i__4].r, z__2.i = ct[i__3].i - cc[i__4]
+ .i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ erri = ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), abs(
+ d__2))) / *eps;
+ if (g[i__] != 0.) {
+ erri /= g[i__];
+ }
+ *err = max(*err,erri);
+ if (*err * sqrt(*eps) >= 1.) {
+ goto L230;
+ }
+/* L210: */
+ }
+
+/* L220: */
+ }
+
+/* If the loop completes, all results are at least half accurate. */
+ goto L250;
+
+/* Report fatal error. */
+
+L230:
+ *fatal = TRUE_;
+ io___382.ciunit = *nout;
+ s_wsfe(&io___382);
+ e_wsfe();
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*mv) {
+ io___383.ciunit = *nout;
+ s_wsfe(&io___383);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(doublereal));
+ do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ } else {
+ io___384.ciunit = *nout;
+ s_wsfe(&io___384);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&cc[i__ + j * cc_dim1], (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__2, (char *)&ct[i__], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+/* L240: */
+ }
+ if (*n > 1) {
+ io___385.ciunit = *nout;
+ s_wsfe(&io___385);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+L250:
+ return 0;
+
+
+/* End of ZMMCH. */
+
+} /* zmmch_ */
+
+logical lze_(doublecomplex *ri, doublecomplex *rj, integer *lr)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ logical ret_val;
+
+ /* Local variables */
+ integer i__;
+
+
+/* Tests if two arrays are identical. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ --rj;
+ --ri;
+
+ /* Function Body */
+ i__1 = *lr;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ if (ri[i__2].r != rj[i__3].r || ri[i__2].i != rj[i__3].i) {
+ goto L20;
+ }
+/* L10: */
+ }
+ ret_val = TRUE_;
+ goto L30;
+L20:
+ ret_val = FALSE_;
+L30:
+ return ret_val;
+
+/* End of LZE. */
+
+} /* lze_ */
+
+logical lzeres_(char *type__, char *uplo, integer *m, integer *n,
+ doublecomplex *aa, doublecomplex *as, integer *lda, ftnlen type_len,
+ ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer aa_dim1, aa_offset, as_dim1, as_offset, i__1, i__2, i__3, i__4;
+ logical ret_val;
+
+ /* Builtin functions */
+ integer s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer i__, j, ibeg, iend;
+ logical upper;
+
+
+/* Tests if selected elements in two arrays are equal. */
+
+/* TYPE is 'GE' or 'HE' or 'SY'. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. Local Scalars .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ as_dim1 = *lda;
+ as_offset = 1 + as_dim1;
+ as -= as_offset;
+ aa_dim1 = *lda;
+ aa_offset = 1 + aa_dim1;
+ aa -= aa_offset;
+
+ /* Function Body */
+ upper = *(unsigned char *)uplo == 'U';
+ if (s_cmp(type__, "GE", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *lda;
+ for (i__ = *m + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * aa_dim1;
+ i__4 = i__ + j * as_dim1;
+ if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) {
+ goto L70;
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (s_cmp(type__, "HE", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(type__,
+ "SY", (ftnlen)2, (ftnlen)2) == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (upper) {
+ ibeg = 1;
+ iend = j;
+ } else {
+ ibeg = j;
+ iend = *n;
+ }
+ i__2 = ibeg - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * aa_dim1;
+ i__4 = i__ + j * as_dim1;
+ if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) {
+ goto L70;
+ }
+/* L30: */
+ }
+ i__2 = *lda;
+ for (i__ = iend + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * aa_dim1;
+ i__4 = i__ + j * as_dim1;
+ if (aa[i__3].r != as[i__4].r || aa[i__3].i != as[i__4].i) {
+ goto L70;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+/* L60: */
+ ret_val = TRUE_;
+ goto L80;
+L70:
+ ret_val = FALSE_;
+L80:
+ return ret_val;
+
+/* End of LZERES. */
+
+} /* lzeres_ */
+
+/* Double Complex */ VOID zbeg_(doublecomplex * ret_val, logical *reset)
+{
+ /* System generated locals */
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Local variables */
+ static integer i__, j, ic, mi, mj;
+
+
+/* Generates complex numbers as pairs of random numbers uniformly */
+/* distributed between -0.5 and 0.5. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Local Scalars .. */
+/* .. Save statement .. */
+/* .. Intrinsic Functions .. */
+/* .. Executable Statements .. */
+ if (*reset) {
+/* Initialize local variables. */
+ mi = 891;
+ mj = 457;
+ i__ = 7;
+ j = 7;
+ ic = 0;
+ *reset = FALSE_;
+ }
+
+/* The sequence of values of I or J is bounded between 1 and 999. */
+/* If initial I or J = 1,2,3,6,7 or 9, the period will be 50. */
+/* If initial I or J = 4 or 8, the period will be 25. */
+/* If initial I or J = 5, the period will be 10. */
+/* IC is used to break up the period by skipping 1 value of I or J */
+/* in 6. */
+
+ ++ic;
+L10:
+ i__ *= mi;
+ j *= mj;
+ i__ -= i__ / 1000 * 1000;
+ j -= j / 1000 * 1000;
+ if (ic >= 5) {
+ ic = 0;
+ goto L10;
+ }
+ d__1 = (i__ - 500) / 1001.;
+ d__2 = (j - 500) / 1001.;
+ z__1.r = d__1, z__1.i = d__2;
+ ret_val->r = z__1.r, ret_val->i = z__1.i;
+ return ;
+
+/* End of ZBEG. */
+
+} /* zbeg_ */
+
+doublereal ddiff_(doublereal *x, doublereal *y)
+{
+ /* System generated locals */
+ doublereal ret_val;
+
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Executable Statements .. */
+ ret_val = *x - *y;
+ return ret_val;
+
+/* End of DDIFF. */
+
+} /* ddiff_ */
+
+/* Subroutine */ int chkxer_(char *srnamt, integer *infot, integer *nout,
+ logical *lerr, logical *ok)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ***** ILLEGAL VALUE OF PARAMETER NUMBER"
+ " \002,i2,\002 NOT D\002,\002ETECTED BY \002,a6,\002 *****\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___397 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* Tests whether XERBLA has detected an error when it should. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Executable Statements .. */
+ if (! (*lerr)) {
+ io___397.ciunit = *nout;
+ s_wsfe(&io___397);
+ do_fio(&c__1, (char *)&(*infot), (ftnlen)sizeof(integer));
+ do_fio(&c__1, srnamt, (ftnlen)6);
+ e_wsfe();
+ *ok = FALSE_;
+ }
+ *lerr = FALSE_;
+ return 0;
+
+
+/* End of CHKXER. */
+
+} /* chkxer_ */
+
+/* Subroutine */ int xerbla_(char *srname, integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ******* XERBLA WAS CALLED WITH INFO ="
+ " \002,i6,\002 INSTEAD\002,\002 OF \002,i2,\002 *******\002)";
+ static char fmt_9997[] = "(\002 ******* XERBLA WAS CALLED WITH INFO ="
+ " \002,i6,\002 *******\002)";
+ static char fmt_9998[] = "(\002 ******* XERBLA WAS CALLED WITH SRNAME ="
+ " \002,a6,\002 INSTE\002,\002AD OF \002,a6,\002 *******\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Fortran I/O blocks */
+ static cilist io___398 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___399 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___400 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* This is a special version of XERBLA to be used only as part of */
+/* the test program for testing error exits from the Level 3 BLAS */
+/* routines. */
+
+/* XERBLA is an error handler for the Level 3 BLAS routines. */
+
+/* It is called by the Level 3 BLAS routines if an input parameter is */
+/* invalid. */
+
+/* Auxiliary routine for test program for Level 3 Blas. */
+
+/* -- Written on 8-February-1989. */
+/* Jack Dongarra, Argonne National Laboratory. */
+/* Iain Duff, AERE Harwell. */
+/* Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/* Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+/* .. Scalar Arguments .. */
+/* .. Scalars in Common .. */
+/* .. Common blocks .. */
+/* .. Executable Statements .. */
+ infoc_2.lerr = TRUE_;
+ if (*info != infoc_2.infot) {
+ if (infoc_2.infot != 0) {
+ io___398.ciunit = infoc_2.nout;
+ s_wsfe(&io___398);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&infoc_2.infot, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___399.ciunit = infoc_2.nout;
+ s_wsfe(&io___399);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ infoc_2.ok = FALSE_;
+ }
+ if (s_cmp(srname, srnamc_1.srnamt, (ftnlen)6, (ftnlen)6) != 0) {
+ io___400.ciunit = infoc_2.nout;
+ s_wsfe(&io___400);
+ do_fio(&c__1, srname, (ftnlen)6);
+ do_fio(&c__1, srnamc_1.srnamt, (ftnlen)6);
+ e_wsfe();
+ infoc_2.ok = FALSE_;
+ }
+ return 0;
+
+
+/* End of XERBLA */
+
+} /* xerbla_ */
+
+/* Main program alias */ int zblat3_ () { MAIN__ (); return 0; }
diff --git a/BLAS/cblat2.in b/BLAS/cblat2.in
new file mode 100644
index 0000000..e76d8a0
--- /dev/null
+++ b/BLAS/cblat2.in
@@ -0,0 +1,35 @@
+'cblat2.out' NAME OF SUMMARY OUTPUT FILE
+6 UNIT NUMBER OF SUMMARY FILE
+'CBLA2T.SNAP' NAME OF SNAPSHOT OUTPUT FILE
+-1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
+F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
+F LOGICAL FLAG, T TO STOP ON FAILURES.
+T LOGICAL FLAG, T TO TEST ERROR EXITS.
+16.0 THRESHOLD VALUE OF TEST RATIO
+6 NUMBER OF VALUES OF N
+0 1 2 3 5 9 VALUES OF N
+4 NUMBER OF VALUES OF K
+0 1 2 4 VALUES OF K
+4 NUMBER OF VALUES OF INCX AND INCY
+1 2 -1 -2 VALUES OF INCX AND INCY
+3 NUMBER OF VALUES OF ALPHA
+(0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA
+3 NUMBER OF VALUES OF BETA
+(0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA
+CGEMV T PUT F FOR NO TEST. SAME COLUMNS.
+CGBMV T PUT F FOR NO TEST. SAME COLUMNS.
+CHEMV T PUT F FOR NO TEST. SAME COLUMNS.
+CHBMV T PUT F FOR NO TEST. SAME COLUMNS.
+CHPMV T PUT F FOR NO TEST. SAME COLUMNS.
+CTRMV T PUT F FOR NO TEST. SAME COLUMNS.
+CTBMV T PUT F FOR NO TEST. SAME COLUMNS.
+CTPMV T PUT F FOR NO TEST. SAME COLUMNS.
+CTRSV T PUT F FOR NO TEST. SAME COLUMNS.
+CTBSV T PUT F FOR NO TEST. SAME COLUMNS.
+CTPSV T PUT F FOR NO TEST. SAME COLUMNS.
+CGERC T PUT F FOR NO TEST. SAME COLUMNS.
+CGERU T PUT F FOR NO TEST. SAME COLUMNS.
+CHER T PUT F FOR NO TEST. SAME COLUMNS.
+CHPR T PUT F FOR NO TEST. SAME COLUMNS.
+CHER2 T PUT F FOR NO TEST. SAME COLUMNS.
+CHPR2 T PUT F FOR NO TEST. SAME COLUMNS.
diff --git a/BLAS/cblat3.in b/BLAS/cblat3.in
new file mode 100644
index 0000000..f148055
--- /dev/null
+++ b/BLAS/cblat3.in
@@ -0,0 +1,23 @@
+'cblat3.out' NAME OF SUMMARY OUTPUT FILE
+6 UNIT NUMBER OF SUMMARY FILE
+'CBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
+-1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
+F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
+F LOGICAL FLAG, T TO STOP ON FAILURES.
+T LOGICAL FLAG, T TO TEST ERROR EXITS.
+16.0 THRESHOLD VALUE OF TEST RATIO
+6 NUMBER OF VALUES OF N
+0 1 2 3 5 9 VALUES OF N
+3 NUMBER OF VALUES OF ALPHA
+(0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA
+3 NUMBER OF VALUES OF BETA
+(0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA
+CGEMM T PUT F FOR NO TEST. SAME COLUMNS.
+CHEMM T PUT F FOR NO TEST. SAME COLUMNS.
+CSYMM T PUT F FOR NO TEST. SAME COLUMNS.
+CTRMM T PUT F FOR NO TEST. SAME COLUMNS.
+CTRSM T PUT F FOR NO TEST. SAME COLUMNS.
+CHERK T PUT F FOR NO TEST. SAME COLUMNS.
+CSYRK T PUT F FOR NO TEST. SAME COLUMNS.
+CHER2K T PUT F FOR NO TEST. SAME COLUMNS.
+CSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
diff --git a/BLAS/dblat2.in b/BLAS/dblat2.in
new file mode 100644
index 0000000..d436350
--- /dev/null
+++ b/BLAS/dblat2.in
@@ -0,0 +1,34 @@
+'dblat2.out' NAME OF SUMMARY OUTPUT FILE
+6 UNIT NUMBER OF SUMMARY FILE
+'DBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE
+-1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
+F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
+F LOGICAL FLAG, T TO STOP ON FAILURES.
+T LOGICAL FLAG, T TO TEST ERROR EXITS.
+16.0 THRESHOLD VALUE OF TEST RATIO
+6 NUMBER OF VALUES OF N
+0 1 2 3 5 9 VALUES OF N
+4 NUMBER OF VALUES OF K
+0 1 2 4 VALUES OF K
+4 NUMBER OF VALUES OF INCX AND INCY
+1 2 -1 -2 VALUES OF INCX AND INCY
+3 NUMBER OF VALUES OF ALPHA
+0.0 1.0 0.7 VALUES OF ALPHA
+3 NUMBER OF VALUES OF BETA
+0.0 1.0 0.9 VALUES OF BETA
+DGEMV T PUT F FOR NO TEST. SAME COLUMNS.
+DGBMV T PUT F FOR NO TEST. SAME COLUMNS.
+DSYMV T PUT F FOR NO TEST. SAME COLUMNS.
+DSBMV T PUT F FOR NO TEST. SAME COLUMNS.
+DSPMV T PUT F FOR NO TEST. SAME COLUMNS.
+DTRMV T PUT F FOR NO TEST. SAME COLUMNS.
+DTBMV T PUT F FOR NO TEST. SAME COLUMNS.
+DTPMV T PUT F FOR NO TEST. SAME COLUMNS.
+DTRSV T PUT F FOR NO TEST. SAME COLUMNS.
+DTBSV T PUT F FOR NO TEST. SAME COLUMNS.
+DTPSV T PUT F FOR NO TEST. SAME COLUMNS.
+DGER T PUT F FOR NO TEST. SAME COLUMNS.
+DSYR T PUT F FOR NO TEST. SAME COLUMNS.
+DSPR T PUT F FOR NO TEST. SAME COLUMNS.
+DSYR2 T PUT F FOR NO TEST. SAME COLUMNS.
+DSPR2 T PUT F FOR NO TEST. SAME COLUMNS.
diff --git a/BLAS/dblat3.in b/BLAS/dblat3.in
new file mode 100644
index 0000000..0098f3e
--- /dev/null
+++ b/BLAS/dblat3.in
@@ -0,0 +1,20 @@
+'dblat3.out' NAME OF SUMMARY OUTPUT FILE
+6 UNIT NUMBER OF SUMMARY FILE
+'DBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
+-1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
+F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
+F LOGICAL FLAG, T TO STOP ON FAILURES.
+T LOGICAL FLAG, T TO TEST ERROR EXITS.
+16.0 THRESHOLD VALUE OF TEST RATIO
+6 NUMBER OF VALUES OF N
+0 1 2 3 5 9 VALUES OF N
+3 NUMBER OF VALUES OF ALPHA
+0.0 1.0 0.7 VALUES OF ALPHA
+3 NUMBER OF VALUES OF BETA
+0.0 1.0 1.3 VALUES OF BETA
+DGEMM T PUT F FOR NO TEST. SAME COLUMNS.
+DSYMM T PUT F FOR NO TEST. SAME COLUMNS.
+DTRMM T PUT F FOR NO TEST. SAME COLUMNS.
+DTRSM T PUT F FOR NO TEST. SAME COLUMNS.
+DSYRK T PUT F FOR NO TEST. SAME COLUMNS.
+DSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
diff --git a/BLAS/sblat2.in b/BLAS/sblat2.in
new file mode 100644
index 0000000..fefc7e9
--- /dev/null
+++ b/BLAS/sblat2.in
@@ -0,0 +1,34 @@
+'sblat2.out' NAME OF SUMMARY OUTPUT FILE
+6 UNIT NUMBER OF SUMMARY FILE
+'SBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE
+-1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
+F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
+F LOGICAL FLAG, T TO STOP ON FAILURES.
+T LOGICAL FLAG, T TO TEST ERROR EXITS.
+16.0 THRESHOLD VALUE OF TEST RATIO
+6 NUMBER OF VALUES OF N
+0 1 2 3 5 9 VALUES OF N
+4 NUMBER OF VALUES OF K
+0 1 2 4 VALUES OF K
+4 NUMBER OF VALUES OF INCX AND INCY
+1 2 -1 -2 VALUES OF INCX AND INCY
+3 NUMBER OF VALUES OF ALPHA
+0.0 1.0 0.7 VALUES OF ALPHA
+3 NUMBER OF VALUES OF BETA
+0.0 1.0 0.9 VALUES OF BETA
+SGEMV T PUT F FOR NO TEST. SAME COLUMNS.
+SGBMV T PUT F FOR NO TEST. SAME COLUMNS.
+SSYMV T PUT F FOR NO TEST. SAME COLUMNS.
+SSBMV T PUT F FOR NO TEST. SAME COLUMNS.
+SSPMV T PUT F FOR NO TEST. SAME COLUMNS.
+STRMV T PUT F FOR NO TEST. SAME COLUMNS.
+STBMV T PUT F FOR NO TEST. SAME COLUMNS.
+STPMV T PUT F FOR NO TEST. SAME COLUMNS.
+STRSV T PUT F FOR NO TEST. SAME COLUMNS.
+STBSV T PUT F FOR NO TEST. SAME COLUMNS.
+STPSV T PUT F FOR NO TEST. SAME COLUMNS.
+SGER T PUT F FOR NO TEST. SAME COLUMNS.
+SSYR T PUT F FOR NO TEST. SAME COLUMNS.
+SSPR T PUT F FOR NO TEST. SAME COLUMNS.
+SSYR2 T PUT F FOR NO TEST. SAME COLUMNS.
+SSPR2 T PUT F FOR NO TEST. SAME COLUMNS.
diff --git a/BLAS/sblat3.in b/BLAS/sblat3.in
new file mode 100644
index 0000000..5c4e3b8
--- /dev/null
+++ b/BLAS/sblat3.in
@@ -0,0 +1,20 @@
+'sblat3.out' NAME OF SUMMARY OUTPUT FILE
+6 UNIT NUMBER OF SUMMARY FILE
+'SBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
+-1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
+F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
+F LOGICAL FLAG, T TO STOP ON FAILURES.
+T LOGICAL FLAG, T TO TEST ERROR EXITS.
+16.0 THRESHOLD VALUE OF TEST RATIO
+6 NUMBER OF VALUES OF N
+0 1 2 3 5 9 VALUES OF N
+3 NUMBER OF VALUES OF ALPHA
+0.0 1.0 0.7 VALUES OF ALPHA
+3 NUMBER OF VALUES OF BETA
+0.0 1.0 1.3 VALUES OF BETA
+SGEMM T PUT F FOR NO TEST. SAME COLUMNS.
+SSYMM T PUT F FOR NO TEST. SAME COLUMNS.
+STRMM T PUT F FOR NO TEST. SAME COLUMNS.
+STRSM T PUT F FOR NO TEST. SAME COLUMNS.
+SSYRK T PUT F FOR NO TEST. SAME COLUMNS.
+SSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
diff --git a/BLAS/zblat2.in b/BLAS/zblat2.in
new file mode 100644
index 0000000..276911c
--- /dev/null
+++ b/BLAS/zblat2.in
@@ -0,0 +1,35 @@
+'zblat2.out' NAME OF SUMMARY OUTPUT FILE
+6 UNIT NUMBER OF SUMMARY FILE
+'CBLA2T.SNAP' NAME OF SNAPSHOT OUTPUT FILE
+-1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
+F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
+F LOGICAL FLAG, T TO STOP ON FAILURES.
+T LOGICAL FLAG, T TO TEST ERROR EXITS.
+16.0 THRESHOLD VALUE OF TEST RATIO
+6 NUMBER OF VALUES OF N
+0 1 2 3 5 9 VALUES OF N
+4 NUMBER OF VALUES OF K
+0 1 2 4 VALUES OF K
+4 NUMBER OF VALUES OF INCX AND INCY
+1 2 -1 -2 VALUES OF INCX AND INCY
+3 NUMBER OF VALUES OF ALPHA
+(0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA
+3 NUMBER OF VALUES OF BETA
+(0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA
+ZGEMV T PUT F FOR NO TEST. SAME COLUMNS.
+ZGBMV T PUT F FOR NO TEST. SAME COLUMNS.
+ZHEMV T PUT F FOR NO TEST. SAME COLUMNS.
+ZHBMV T PUT F FOR NO TEST. SAME COLUMNS.
+ZHPMV T PUT F FOR NO TEST. SAME COLUMNS.
+ZTRMV T PUT F FOR NO TEST. SAME COLUMNS.
+ZTBMV T PUT F FOR NO TEST. SAME COLUMNS.
+ZTPMV T PUT F FOR NO TEST. SAME COLUMNS.
+ZTRSV T PUT F FOR NO TEST. SAME COLUMNS.
+ZTBSV T PUT F FOR NO TEST. SAME COLUMNS.
+ZTPSV T PUT F FOR NO TEST. SAME COLUMNS.
+ZGERC T PUT F FOR NO TEST. SAME COLUMNS.
+ZGERU T PUT F FOR NO TEST. SAME COLUMNS.
+ZHER T PUT F FOR NO TEST. SAME COLUMNS.
+ZHPR T PUT F FOR NO TEST. SAME COLUMNS.
+ZHER2 T PUT F FOR NO TEST. SAME COLUMNS.
+ZHPR2 T PUT F FOR NO TEST. SAME COLUMNS.
diff --git a/BLAS/zblat3.in b/BLAS/zblat3.in
new file mode 100644
index 0000000..a3618b0
--- /dev/null
+++ b/BLAS/zblat3.in
@@ -0,0 +1,23 @@
+'zblat3.out' NAME OF SUMMARY OUTPUT FILE
+6 UNIT NUMBER OF SUMMARY FILE
+'ZBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
+-1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
+F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
+F LOGICAL FLAG, T TO STOP ON FAILURES.
+T LOGICAL FLAG, T TO TEST ERROR EXITS.
+16.0 THRESHOLD VALUE OF TEST RATIO
+6 NUMBER OF VALUES OF N
+0 1 2 3 5 9 VALUES OF N
+3 NUMBER OF VALUES OF ALPHA
+(0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA
+3 NUMBER OF VALUES OF BETA
+(0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA
+ZGEMM T PUT F FOR NO TEST. SAME COLUMNS.
+ZHEMM T PUT F FOR NO TEST. SAME COLUMNS.
+ZSYMM T PUT F FOR NO TEST. SAME COLUMNS.
+ZTRMM T PUT F FOR NO TEST. SAME COLUMNS.
+ZTRSM T PUT F FOR NO TEST. SAME COLUMNS.
+ZHERK T PUT F FOR NO TEST. SAME COLUMNS.
+ZSYRK T PUT F FOR NO TEST. SAME COLUMNS.
+ZHER2K T PUT F FOR NO TEST. SAME COLUMNS.
+ZSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
diff --git a/CMakeLists.txt b/CMakeLists.txt
new file mode 100644
index 0000000..320ccc6
--- /dev/null
+++ b/CMakeLists.txt
@@ -0,0 +1,34 @@
+cmake_minimum_required(VERSION 2.6)
+project(CLAPACK C)
+enable_testing()
+include(CTest)
+
+if(WIN32 AND NOT CYGWIN)
+ set(SECOND_SRC ${CLAPACK_SOURCE_DIR}/INSTALL/winsecond.c)
+ set(DSECOND_SRC ${CLAPACK_SOURCE_DIR}/INSTALL/windsecnd.c)
+ add_definitions(-DNO_ISATTY -DMSDOS -DUSE_CLOCK)
+else()
+ set(SECOND_SRC ${CLAPACK_SOURCE_DIR}/INSTALL/second.c)
+ set(DSECOND_SRC ${CLAPACK_SOURCE_DIR}/INSTALL/dsecnd.c)
+endif()
+enable_testing()
+option(USE_BLAS_WRAP "pre-pend f2c_ to each function in blas" OFF)
+if(NOT USE_BLAS_WRAP)
+# _zrotg_ seems to be missing in the wrap header
+ add_definitions(-DNO_BLAS_WRAP)
+endif()
+include_directories(${CLAPACK_SOURCE_DIR}/INCLUDE)
+add_subdirectory(F2CLIBS)
+add_subdirectory(BLAS)
+add_subdirectory(SRC)
+add_subdirectory(TESTING)
+set(CLAPACK_VERSION 3.2.1)
+set(CPACK_PACKAGE_VERSION_MAJOR 3)
+set(CPACK_PACKAGE_VERSION_MINOR 2)
+set(CPACK_PACKAGE_VERSION_PATCH 1)
+include(CPack)
+export(TARGETS f2c blas lapack FILE clapack-targets.cmake)
+configure_file(${CLAPACK_SOURCE_DIR}/clapack-config-version.cmake.in
+ ${CLAPACK_BINARY_DIR}/clapack-config-version.cmake @ONLY)
+configure_file(${CLAPACK_SOURCE_DIR}/clapack-config.cmake.in
+ ${CLAPACK_BINARY_DIR}/clapack-config.cmake @ONLY)
diff --git a/COPYING b/COPYING
new file mode 100644
index 0000000..d7bf953
--- /dev/null
+++ b/COPYING
@@ -0,0 +1,36 @@
+Copyright (c) 1992-2008 The University of Tennessee. All rights reserved.
+
+$COPYRIGHT$
+
+Additional copyrights may follow
+
+$HEADER$
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer listed
+ in this license in the documentation and/or other materials
+ provided with the distribution.
+
+- Neither the name of the copyright holders nor the names of its
+ contributors may be used to endorse or promote products derived from
+ this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
diff --git a/CTestConfig.cmake b/CTestConfig.cmake
new file mode 100644
index 0000000..f5b01a3
--- /dev/null
+++ b/CTestConfig.cmake
@@ -0,0 +1,13 @@
+## This file should be placed in the root directory of your project.
+## Then modify the CMakeLists.txt file in the root directory of your
+## project to incorporate the testing dashboard.
+## # The following are required to uses Dart and the Cdash dashboard
+## ENABLE_TESTING()
+## INCLUDE(CTest)
+set(CTEST_PROJECT_NAME "CLAPACK")
+set(CTEST_NIGHTLY_START_TIME "00:00:00 EDT")
+
+set(CTEST_DROP_METHOD "http")
+set(CTEST_DROP_SITE "my.cdash.org")
+set(CTEST_DROP_LOCATION "/submit.php?project=CLAPACK")
+set(CTEST_DROP_SITE_CDASH TRUE)
diff --git a/F2CLIBS/CMakeLists.txt b/F2CLIBS/CMakeLists.txt
new file mode 100644
index 0000000..4c4a92e
--- /dev/null
+++ b/F2CLIBS/CMakeLists.txt
@@ -0,0 +1 @@
+add_subdirectory(libf2c)
diff --git a/F2CLIBS/libf2c/CMakeLists.txt b/F2CLIBS/libf2c/CMakeLists.txt
new file mode 100644
index 0000000..43d7b3f
--- /dev/null
+++ b/F2CLIBS/libf2c/CMakeLists.txt
@@ -0,0 +1,62 @@
+set(MISC
+ f77vers.c i77vers.c main.c s_rnge.c abort_.c exit_.c getarg_.c iargc_.c
+ getenv_.c signal_.c s_stop.c s_paus.c system_.c cabs.c ctype.c
+ derf_.c derfc_.c erf_.c erfc_.c sig_die.c uninit.c)
+set(POW pow_ci.c pow_dd.c pow_di.c pow_hh.c pow_ii.c pow_ri.c pow_zi.c pow_zz.c)
+set(CX c_abs.c c_cos.c c_div.c c_exp.c c_log.c c_sin.c c_sqrt.c)
+set(DCX z_abs.c z_cos.c z_div.c z_exp.c z_log.c z_sin.c z_sqrt.c)
+set(REAL r_abs.c r_acos.c r_asin.c r_atan.c r_atn2.c r_cnjg.c r_cos.c
+ r_cosh.c r_dim.c r_exp.c r_imag.c r_int.c
+ r_lg10.c r_log.c r_mod.c r_nint.c r_sign.c
+ r_sin.c r_sinh.c r_sqrt.c r_tan.c r_tanh.c)
+set(DBL d_abs.c d_acos.c d_asin.c d_atan.c d_atn2.c
+ d_cnjg.c d_cos.c d_cosh.c d_dim.c d_exp.c
+ d_imag.c d_int.c d_lg10.c d_log.c d_mod.c
+ d_nint.c d_prod.c d_sign.c d_sin.c d_sinh.c
+ d_sqrt.c d_tan.c d_tanh.c)
+set(INT i_abs.c
+ i_dim.c i_dnnt.c i_indx.c i_len.c i_len_trim.c i_mod.c i_nint.c i_sign.c
+ lbitbits.c lbitshft.c i_ceiling.c)
+set(HALF h_abs.c h_dim.c h_dnnt.c h_indx.c h_len.c h_mod.c h_nint.c h_sign.c)
+set(CMP l_ge.c l_gt.c l_le.c l_lt.c hl_ge.c hl_gt.c hl_le.c hl_lt.c)
+set(EFL ef1asc_.c ef1cmc_.c)
+set(CHAR f77_aloc.c s_cat.c s_cmp.c s_copy.c)
+set(I77 backspac.c close.c dfe.c dolio.c due.c endfile.c err.c
+ fmt.c fmtlib.c ftell_.c iio.c ilnw.c inquire.c lread.c lwrite.c
+ open.c rdfmt.c rewind.c rsfe.c rsli.c rsne.c sfe.c sue.c
+ typesize.c uio.c util.c wref.c wrtfmt.c wsfe.c wsle.c wsne.c xwsne.c)
+set(QINT pow_qq.c qbitbits.c qbitshft.c ftell64_.c)
+set(TIME dtime_.c etime_.c)
+
+# If you get an error compiling dtime_.c or etime_.c, try adding
+# -DUSE_CLOCK to the CFLAGS assignment above; if that does not work,
+# omit ${TIME} from OFILES assignment below.
+
+# To get signed zeros in write statements on IEEE-arithmetic systems,
+# add -DSIGNED_ZEROS to the CFLAGS assignment below and add signbit.c
+# to the end of the OFILES assignment below.
+
+# For INTEGER*8 support (which requires system-dependent adjustments to
+# f2c.h), add ${QINT} to the OFILES assignment below...
+add_executable(arithchk arithchk.c)
+if(UNIX)
+ target_link_libraries(arithchk m)
+endif()
+set_target_properties(arithchk PROPERTIES COMPILE_DEFINITIONS
+ "NO_FPINIT;NO_LONG_LONG")
+ADD_CUSTOM_COMMAND(
+ OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/arith.h
+ COMMAND arithchk > ${CMAKE_CURRENT_BINARY_DIR}/arith.h
+ DEPENDS arithchk
+ )
+
+
+set(OFILES ${MISC} ${POW} ${CX} ${DCX} ${REAL} ${DBL} ${INT}
+ ${HALF} ${CMP} ${EFL} ${CHAR} ${I77} ${TIME})
+if(WIN32)
+ add_definitions(-D_COMPLEX_DEFINED)
+endif()
+include_directories(${CLAPACK_SOURCE_DIR}/F2CLIBS/libf2c)
+include_directories(${CLAPACK_BINARY_DIR}/F2CLIBS/libf2c)
+add_library(f2c ${OFILES} ${CMAKE_CURRENT_BINARY_DIR}/arith.h)
+set_property(TARGET f2c PROPERTY PREFIX lib)
diff --git a/F2CLIBS/libf2c/Makefile b/F2CLIBS/libf2c/Makefile
new file mode 100644
index 0000000..0a3ed0d
--- /dev/null
+++ b/F2CLIBS/libf2c/Makefile
@@ -0,0 +1,207 @@
+include ../../make.inc
+
+# Unix makefile: see README.
+# For C++, first "make hadd".
+# If your compiler does not recognize ANSI C, add
+# -DKR_headers
+# to the CFLAGS = line below.
+# On Sun and other BSD systems that do not provide an ANSI sprintf, add
+# -DUSE_STRLEN
+# to the CFLAGS = line below.
+# On Linux systems, add
+# -DNON_UNIX_STDIO
+# to the CFLAGS = line below. For libf2c.so under Linux, also add
+# -fPIC
+# to the CFLAGS = line below.
+
+.SUFFIXES: .c .o
+
+# compile, then strip unnecessary symbols
+.c.o:
+ $(CC) -c -DSkip_f2c_Undefs $(CFLAGS) $*.c
+ ld -r -x -o $*.xxx $*.o
+ mv $*.xxx $*.o
+## Under Solaris (and other systems that do not understand ld -x),
+## omit -x in the ld line above.
+## If your system does not have the ld command, comment out
+## or remove both the ld and mv lines above.
+
+MISC = f77vers.o i77vers.o main.o s_rnge.o abort_.o exit_.o getarg_.o iargc_.o\
+ getenv_.o signal_.o s_stop.o s_paus.o system_.o cabs.o ctype.o\
+ derf_.o derfc_.o erf_.o erfc_.o sig_die.o uninit.o
+POW = pow_ci.o pow_dd.o pow_di.o pow_hh.o pow_ii.o pow_ri.o pow_zi.o pow_zz.o
+CX = c_abs.o c_cos.o c_div.o c_exp.o c_log.o c_sin.o c_sqrt.o
+DCX = z_abs.o z_cos.o z_div.o z_exp.o z_log.o z_sin.o z_sqrt.o
+REAL = r_abs.o r_acos.o r_asin.o r_atan.o r_atn2.o r_cnjg.o r_cos.o\
+ r_cosh.o r_dim.o r_exp.o r_imag.o r_int.o\
+ r_lg10.o r_log.o r_mod.o r_nint.o r_sign.o\
+ r_sin.o r_sinh.o r_sqrt.o r_tan.o r_tanh.o
+DBL = d_abs.o d_acos.o d_asin.o d_atan.o d_atn2.o\
+ d_cnjg.o d_cos.o d_cosh.o d_dim.o d_exp.o\
+ d_imag.o d_int.o d_lg10.o d_log.o d_mod.o\
+ d_nint.o d_prod.o d_sign.o d_sin.o d_sinh.o\
+ d_sqrt.o d_tan.o d_tanh.o
+INT = i_abs.o i_dim.o i_dnnt.o i_indx.o i_len.o i_len_trim.o i_mod.o i_nint.o i_sign.o\
+ lbitbits.o lbitshft.o i_ceiling.o
+HALF = h_abs.o h_dim.o h_dnnt.o h_indx.o h_len.o h_mod.o h_nint.o h_sign.o
+CMP = l_ge.o l_gt.o l_le.o l_lt.o hl_ge.o hl_gt.o hl_le.o hl_lt.o
+EFL = ef1asc_.o ef1cmc_.o
+CHAR = f77_aloc.o s_cat.o s_cmp.o s_copy.o
+I77 = backspac.o close.o dfe.o dolio.o due.o endfile.o err.o\
+ fmt.o fmtlib.o ftell_.o iio.o ilnw.o inquire.o lread.o lwrite.o\
+ open.o rdfmt.o rewind.o rsfe.o rsli.o rsne.o sfe.o sue.o\
+ typesize.o uio.o util.o wref.o wrtfmt.o wsfe.o wsle.o wsne.o xwsne.o
+QINT = pow_qq.o qbitbits.o qbitshft.o ftell64_.o
+TIME = dtime_.o etime_.o
+
+# If you get an error compiling dtime_.c or etime_.c, try adding
+# -DUSE_CLOCK to the CFLAGS assignment above; if that does not work,
+# omit $(TIME) from OFILES = assignment below.
+
+# To get signed zeros in write statements on IEEE-arithmetic systems,
+# add -DSIGNED_ZEROS to the CFLAGS assignment below and add signbit.o
+# to the end of the OFILES = assignment below.
+
+# For INTEGER*8 support (which requires system-dependent adjustments to
+# f2c.h), add $(QINT) to the OFILES = assignment below...
+
+OFILES = $(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \
+ $(HALF) $(CMP) $(EFL) $(CHAR) $(I77) $(TIME)
+
+all: libf2c.a clapack_install
+
+libf2c.a: $(OFILES)
+ ar r libf2c.a $?
+ -ranlib libf2c.a
+
+## Shared-library variant: the following rule works on Linux
+## systems. Details are system-dependent. Under Linux, -fPIC
+## must appear in the CFLAGS assignment when making libf2c.so.
+## Under Solaris, use -Kpic in CFLAGS and use "ld -G" instead
+## of "cc -shared".
+
+libf2c.so: $(OFILES)
+ cc -shared -o libf2c.so $(OFILES)
+
+### If your system lacks ranlib, you don't need it; see README.
+
+f77vers.o: f77vers.c
+ $(CC) -c f77vers.c
+
+i77vers.o: i77vers.c
+ $(CC) -c i77vers.c
+
+# To get an "f2c.h" for use with "f2c -C++", first "make hadd"
+hadd: f2c.h f2ch.add
+ cat f2c.h f2ch.add >temp
+ mv temp f2c.h
+
+# If your system lacks onexit() and you are not using an
+# ANSI C compiler, then you should uncomment the following
+# two lines (for compiling main.o):
+#main.o: main.c
+# $(CC) -c -DNO_ONEXIT -DSkip_f2c_Undefs main.c
+# On at least some Sun systems, it is more appropriate to
+# uncomment the following two lines:
+#main.o: main.c
+# $(CC) -c -Donexit=on_exit -DSkip_f2c_Undefs main.c
+
+install: libf2c.a
+ cp libf2c.a $(LIBDIR)
+ -ranlib $(LIBDIR)/libf2c.a
+
+clapack_install: libf2c.a
+ mv libf2c.a ..
+
+clean:
+ rm -f libf2c.a *.o arith.h signal1.h sysdep1.h
+
+backspac.o: fio.h
+close.o: fio.h
+dfe.o: fio.h
+dfe.o: fmt.h
+due.o: fio.h
+endfile.o: fio.h rawio.h
+err.o: fio.h rawio.h
+fmt.o: fio.h
+fmt.o: fmt.h
+iio.o: fio.h
+iio.o: fmt.h
+ilnw.o: fio.h
+ilnw.o: lio.h
+inquire.o: fio.h
+lread.o: fio.h
+lread.o: fmt.h
+lread.o: lio.h
+lread.o: fp.h
+lwrite.o: fio.h
+lwrite.o: fmt.h
+lwrite.o: lio.h
+open.o: fio.h rawio.h
+rdfmt.o: fio.h
+rdfmt.o: fmt.h
+rdfmt.o: fp.h
+rewind.o: fio.h
+rsfe.o: fio.h
+rsfe.o: fmt.h
+rsli.o: fio.h
+rsli.o: lio.h
+rsne.o: fio.h
+rsne.o: lio.h
+sfe.o: fio.h
+signbit.o: arith.h
+sue.o: fio.h
+uio.o: fio.h
+uninit.o: arith.h
+util.o: fio.h
+wref.o: fio.h
+wref.o: fmt.h
+wref.o: fp.h
+wrtfmt.o: fio.h
+wrtfmt.o: fmt.h
+wsfe.o: fio.h
+wsfe.o: fmt.h
+wsle.o: fio.h
+wsle.o: fmt.h
+wsle.o: lio.h
+wsne.o: fio.h
+wsne.o: lio.h
+xwsne.o: fio.h
+xwsne.o: lio.h
+xwsne.o: fmt.h
+
+arith.h: arithchk.c
+ $(CC) $(CFLAGS) -DNO_FPINIT arithchk.c -lm ||\
+ $(CC) -DNO_LONG_LONG $(CFLAGS) -DNO_FPINIT arithchk.c -lm
+ ./a.out >arith.h
+ rm -f a.out arithchk.o
+
+check:
+ xsum Notice README abort_.c arithchk.c backspac.c c_abs.c c_cos.c \
+ c_div.c c_exp.c c_log.c c_sin.c c_sqrt.c cabs.c close.c comptry.bat \
+ ctype.c ctype.h \
+ d_abs.c d_acos.c d_asin.c d_atan.c d_atn2.c d_cnjg.c d_cos.c d_cosh.c \
+ d_dim.c d_exp.c d_imag.c d_int.c d_lg10.c d_log.c d_mod.c \
+ d_nint.c d_prod.c d_sign.c d_sin.c d_sinh.c d_sqrt.c d_tan.c \
+ d_tanh.c derf_.c derfc_.c dfe.c dolio.c dtime_.c due.c ef1asc_.c \
+ ef1cmc_.c endfile.c erf_.c erfc_.c err.c etime_.c exit_.c f2c.h0 \
+ f2ch.add f77_aloc.c f77vers.c fio.h fmt.c fmt.h fmtlib.c \
+ fp.h ftell_.c ftell64_.c i_ceiling.c \
+ getarg_.c getenv_.c h_abs.c h_dim.c h_dnnt.c h_indx.c h_len.c \
+ h_mod.c h_nint.c h_sign.c hl_ge.c hl_gt.c hl_le.c hl_lt.c \
+ i77vers.c i_abs.c i_dim.c i_dnnt.c i_indx.c i_len.c i_len_trim.c i_mod.c \
+ i_nint.c i_sign.c iargc_.c iio.c ilnw.c inquire.c l_ge.c l_gt.c \
+ l_le.c l_lt.c lbitbits.c lbitshft.c libf2c.lbc libf2c.sy lio.h \
+ lread.c lwrite.c main.c makefile.sy makefile.u makefile.vc \
+ makefile.wat math.hvc mkfile.plan9 open.c pow_ci.c pow_dd.c \
+ pow_di.c pow_hh.c pow_ii.c pow_qq.c pow_ri.c pow_zi.c pow_zz.c \
+ qbitbits.c qbitshft.c r_abs.c r_acos.c r_asin.c r_atan.c r_atn2.c \
+ r_cnjg.c r_cos.c r_cosh.c r_dim.c r_exp.c r_imag.c r_int.c r_lg10.c \
+ r_log.c r_mod.c r_nint.c r_sign.c r_sin.c r_sinh.c r_sqrt.c \
+ r_tan.c r_tanh.c rawio.h rdfmt.c rewind.c rsfe.c rsli.c rsne.c \
+ s_cat.c s_cmp.c s_copy.c s_paus.c s_rnge.c s_stop.c scomptry.bat sfe.c \
+ sig_die.c signal1.h0 signal_.c signbit.c sue.c sysdep1.h0 system_.c \
+ typesize.c \
+ uio.c uninit.c util.c wref.c wrtfmt.c wsfe.c wsle.c wsne.c xwsne.c \
+ z_abs.c z_cos.c z_div.c z_exp.c z_log.c z_sin.c z_sqrt.c >xsum1.out
+ cmp xsum0.out xsum1.out && mv xsum1.out xsum.out || diff xsum[01].out
diff --git a/F2CLIBS/libf2c/Notice b/F2CLIBS/libf2c/Notice
new file mode 100644
index 0000000..261b719
--- /dev/null
+++ b/F2CLIBS/libf2c/Notice
@@ -0,0 +1,23 @@
+/****************************************************************
+Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T, Bell Laboratories,
+Lucent or Bellcore or any of their entities not be used in
+advertising or publicity pertaining to distribution of the
+software without specific, written prior permission.
+
+AT&T, Lucent and Bellcore disclaim all warranties with regard to
+this software, including all implied warranties of
+merchantability and fitness. In no event shall AT&T, Lucent or
+Bellcore be liable for any special, indirect or consequential
+damages or any damages whatsoever resulting from loss of use,
+data or profits, whether in an action of contract, negligence or
+other tortious action, arising out of or in connection with the
+use or performance of this software.
+****************************************************************/
+
diff --git a/F2CLIBS/libf2c/README b/F2CLIBS/libf2c/README
new file mode 100644
index 0000000..940a354
--- /dev/null
+++ b/F2CLIBS/libf2c/README
@@ -0,0 +1,374 @@
+As shipped, "makefile" is a copy of "makefile.u", a Unix makefile.
+Variants for other systems have names of the form makefile.* and
+have initial comments saying how to invoke them. You may wish to
+copy one of the other makefile.* files to makefile.
+
+If you use a C++ compiler, first say
+
+ make hadd
+
+to create a suitable f2c.h from f2c.h0 and f2ch.add. Otherwise,
+
+ make f2c.h
+
+will just copy f2c.h0 to f2c.h .
+
+If your compiler does not recognize ANSI C headers,
+compile with KR_headers defined: either add -DKR_headers
+to the definition of CFLAGS in the makefile, or insert
+
+#define KR_headers
+
+at the top of f2c.h .
+
+If your system lacks onexit() and you are not using an ANSI C
+compiler, then you should compile main.c with NO_ONEXIT defined.
+See the comments about onexit in makefile.u.
+
+If your system has a double drem() function such that drem(a,b)
+is the IEEE remainder function (with double a, b), then you may
+wish to compile r_mod.c and d_mod.c with IEEE_drem defined.
+
+To check for transmission errors, issue the command
+ make check
+or
+ make -f makefile.u check
+
+This assumes you have the xsum program whose source, xsum.c,
+is distributed as part of "all from f2c/src", and that it
+is installed somewhere in your search path. If you do not
+have xsum, you can obtain xsum.c by sending the following E-mail
+message to netlib at netlib.bell-labs.com
+ send xsum.c from f2c/src
+
+For convenience, the f2c.h0 in this directory is a copy of netlib's
+"f2c.h from f2c". It is best to install f2c.h in a standard place,
+so "include f2c.h" will work in any directory without further ado.
+Beware that the makefiles do not cause recompilation when f2c.h is
+changed.
+
+On machines, such as those using a DEC Alpha processor, on which
+sizeof(short) == 2, sizeof(int) == sizeof(float) == 4, and
+sizeof(long) == sizeof(double) == 8, it suffices to modify f2c.h by
+removing the first occurrence of "long " on each line containing
+"long ". On Unix systems, you can do this by issuing the commands
+ mv f2c.h f2c.h0
+ sed 's/long int /int /' f2c.h0 >f2c.h
+On such machines, one can enable INTEGER*8 by uncommenting the typedefs
+of longint and ulongint in f2c.h and adjusting them, so they read
+ typedef long longint;
+ typedef unsigned long ulongint;
+and by compiling libf2c with -DAllow_TYQUAD, as discussed below.
+
+
+Most of the routines in libf2c are support routines for Fortran
+intrinsic functions or for operations that f2c chooses not
+to do "in line". There are a few exceptions, summarized below --
+functions and subroutines that appear to your program as ordinary
+external Fortran routines.
+
+If you use the REAL valued functions listed below (ERF, ERFC,
+DTIME, and ETIME) with "f2c -R", then you need to compile the
+corresponding source files with -DREAL=float. To do this, it is
+perhaps simplest to add "-DREAL=float" to CFLAGS in the makefile.
+
+1. CALL ABORT prints a message and causes a core dump.
+
+2. ERF(r) and DERF(d) and the REAL and DOUBLE PRECISION
+ error functions (with x REAL and d DOUBLE PRECISION);
+ DERF must be declared DOUBLE PRECISION in your program.
+ Both ERF and DERF assume your C library provides the
+ underlying erf() function (which not all systems do).
+
+3. ERFC(r) and DERFC(d) are the complementary error functions:
+ ERFC(r) = 1 - ERF(r) and DERFC(d) = 1.d0 - DERFC(d)
+ (except that their results may be more accurate than
+ explicitly evaluating the above formulae would give).
+ Again, ERFC and r are REAL, and DERFC and d are DOUBLE
+ PRECISION (and must be declared as such in your program),
+ and ERFC and DERFC rely on your system's erfc().
+
+4. CALL GETARG(n,s), where n is an INTEGER and s is a CHARACTER
+ variable, sets s to the n-th command-line argument (or to
+ all blanks if there are fewer than n command-line arguments);
+ CALL GETARG(0,s) sets s to the name of the program (on systems
+ that support this feature). See IARGC below.
+
+5. CALL GETENV(name, value), where name and value are of type
+ CHARACTER, sets value to the environment value, $name, of
+ name (or to blanks if $name has not been set).
+
+6. NARGS = IARGC() sets NARGS to the number of command-line
+ arguments (an INTEGER value).
+
+7. CALL SIGNAL(n,func), where n is an INTEGER and func is an
+ EXTERNAL procedure, arranges for func to be invoked when n
+ occurs (on systems where this makes sense).
+
+If your compiler complains about the signal calls in main.c, s_paus.c,
+and signal_.c, you may need to adjust signal1.h suitably. See the
+comments in signal1.h.
+
+8. ETIME(ARR) and DTIME(ARR) are REAL functions that return
+ execution times. ARR is declared REAL ARR(2). The elapsed
+ user and system CPU times are stored in ARR(1) and ARR(2),
+ respectively. ETIME returns the total elapsed CPU time,
+ i.e., ARR(1) + ARR(2). DTIME returns total elapsed CPU
+ time since the previous call on DTIME.
+
+9. CALL SYSTEM(cmd), where cmd is of type CHARACTER, passes
+ cmd to the system's command processor (on systems where
+ this can be done).
+
+10. CALL FLUSH flushes all buffers.
+
+11. FTELL(i) is an INTEGER function that returns the current
+ offset of Fortran unit i (or -1 if unit i is not open).
+
+12. CALL FSEEK(i, offset, whence, *errlab) attemps to move
+ Fortran unit i to the specified offset: absolute offset
+ if whence = 0; relative to the current offset if whence = 1;
+ relative to the end of the file if whence = 2. It branches
+ to label errlab if unit i is not open or if the call
+ otherwise fails.
+
+The routines whose objects are makefile.u's $(I77) are for I/O.
+The following comments apply to them.
+
+If your system lacks /usr/include/local.h ,
+then you should create an appropriate local.h in
+this directory. An appropriate local.h may simply
+be empty, or it may #define VAX or #define CRAY
+(or whatever else you must do to make fp.h work right).
+Alternatively, edit fp.h to suite your machine.
+
+If your system lacks /usr/include/fcntl.h , then you
+should simply create an empty fcntl.h in this directory.
+If your compiler then complains about creat and open not
+having a prototype, compile with OPEN_DECL defined.
+On many systems, open and creat are declared in fcntl.h .
+
+If your system's sprintf does not work the way ANSI C
+specifies -- specifically, if it does not return the
+number of characters transmitted -- then insert the line
+
+#define USE_STRLEN
+
+at the end of fmt.h . This is necessary with
+at least some versions of Sun software.
+In particular, if you get a warning about an improper
+pointer/integer combination in compiling wref.c, then
+you need to compile with -DUSE_STRLEN .
+
+If your system's fopen does not like the ANSI binary
+reading and writing modes "rb" and "wb", then you should
+compile open.c with NON_ANSI_RW_MODES #defined.
+
+If you get error messages about references to cf->_ptr
+and cf->_base when compiling wrtfmt.c and wsfe.c or to
+stderr->_flag when compiling err.c, then insert the line
+
+#define NON_UNIX_STDIO
+
+at the beginning of fio.h, and recompile everything (or
+at least those modules that contain NON_UNIX_STDIO).
+
+Unformatted sequential records consist of a length of record
+contents, the record contents themselves, and the length of
+record contents again (for backspace). Prior to 17 Oct. 1991,
+the length was of type int; now it is of type long, but you
+can change it back to int by inserting
+
+#define UIOLEN_int
+
+at the beginning of fio.h. This affects only sue.c and uio.c .
+
+If you have a really ancient K&R C compiler that does not understand
+void, add -Dvoid=int to the definition of CFLAGS in the makefile.
+
+On VAX, Cray, or Research Tenth-Edition Unix systems, you may
+need to add -DVAX, -DCRAY, or -DV10 (respectively) to CFLAGS
+to make fp.h work correctly. Alternatively, you may need to
+edit fp.h to suit your machine.
+
+If your compiler complains about the signal calls in main.c, s_paus.c,
+and signal_.c, you may need to adjust signal1.h suitably. See the
+comments in signal1.h.
+
+You may need to supply the following non-ANSI routines:
+
+ fstat(int fileds, struct stat *buf) is similar
+to stat(char *name, struct stat *buf), except that
+the first argument, fileds, is the file descriptor
+returned by open rather than the name of the file.
+fstat is used in the system-dependent routine
+canseek (in the libf2c source file err.c), which
+is supposed to return 1 if it's possible to issue
+seeks on the file in question, 0 if it's not; you may
+need to suitably modify err.c . On non-UNIX systems,
+you can avoid references to fstat and stat by compiling
+with NON_UNIX_STDIO defined; in that case, you may need
+to supply access(char *Name,0), which is supposed to
+return 0 if file Name exists, nonzero otherwise.
+
+ char * mktemp(char *buf) is supposed to replace the
+6 trailing X's in buf with a unique number and then
+return buf. The idea is to get a unique name for
+a temporary file.
+
+On non-UNIX systems, you may need to change a few other,
+e.g.: the form of name computed by mktemp() in endfile.c and
+open.c; the use of the open(), close(), and creat() system
+calls in endfile.c, err.c, open.c; and the modes in calls on
+fopen() and fdopen() (and perhaps the use of fdopen() itself
+-- it's supposed to return a FILE* corresponding to a given
+an integer file descriptor) in err.c and open.c (component ufmt
+of struct unit is 1 for formatted I/O -- text mode on some systems
+-- and 0 for unformatted I/O -- binary mode on some systems).
+Compiling with -DNON_UNIX_STDIO omits all references to creat()
+and almost all references to open() and close(), the exception
+being in the function f__isdev() (in open.c).
+
+If you wish to use translated Fortran that has funny notions
+of record length for direct unformatted I/O (i.e., that assumes
+RECL= values in OPEN statements are not bytes but rather counts
+of some other units -- e.g., 4-character words for VMS), then you
+should insert an appropriate #define for url_Adjust at the
+beginning of open.c . For VMS Fortran, for example,
+#define url_Adjust(x) x *= 4
+would suffice.
+
+By default, Fortran I/O units 5, 6, and 0 are pre-connected to
+stdin, stdout, and stderr, respectively. You can change this
+behavior by changing f_init() in err.c to suit your needs.
+Note that f2c assumes READ(*... means READ(5... and WRITE(*...
+means WRITE(6... . Moreover, an OPEN(n,... statement that does
+not specify a file name (and does not specify STATUS='SCRATCH')
+assumes FILE='fort.n' . You can change this by editing open.c
+and endfile.c suitably.
+
+Unless you adjust the "#define MXUNIT" line in fio.h, Fortran units
+0, 1, ..., 99 are available, i.e., the highest allowed unit number
+is MXUNIT - 1.
+
+Lines protected from compilation by #ifdef Allow_TYQUAD
+are for a possible extension to 64-bit integers in which
+integer = int = 32 bits and longint = long = 64 bits.
+
+The makefile does not attempt to compile pow_qq.c, qbitbits.c,
+and qbitshft.c, which are meant for use with INTEGER*8. To use
+INTEGER*8, you must modify f2c.h to declare longint and ulongint
+appropriately; then add $(QINT) to the end of the makefile's
+dependency list for libf2c.a (if makefile is a copy of makefile.u;
+for the PC makefiles, add pow_qq.obj qbitbits.obj qbitshft.obj
+to the library's dependency list and adjust libf2c.lbc or libf2c.sy
+accordingly). Also add -DAllow_TYQUAD to the makefile's CFLAGS
+assignment. To make longint and ulongint available, it may suffice
+to add -DINTEGER_STAR_8 to the CFLAGS assignment.
+
+Following Fortran 90, s_cat.c and s_copy.c allow the target of a
+(character string) assignment to be appear on its right-hand, at
+the cost of some extra overhead for all run-time concatenations.
+If you prefer the extra efficiency that comes with the Fortran 77
+requirement that the left-hand side of a character assignment not
+be involved in the right-hand side, compile s_cat.c and s_copy.c
+with -DNO_OVERWRITE .
+
+Extensions (Feb. 1993) to NAMELIST processing:
+ 1. Reading a ? instead of &name (the start of a namelist) causes
+the namelist being sought to be written to stdout (unit 6);
+to omit this feature, compile rsne.c with -DNo_Namelist_Questions.
+ 2. Reading the wrong namelist name now leads to an error message
+and an attempt to skip input until the right namelist name is found;
+to omit this feature, compile rsne.c with -DNo_Bad_Namelist_Skip.
+ 3. Namelist writes now insert newlines before each variable; to omit
+this feature, compile xwsne.c with -DNo_Extra_Namelist_Newlines.
+ 4. (Sept. 1995) When looking for the &name that starts namelist
+input, lines whose first non-blank character is something other
+than &, $, or ? are treated as comment lines and ignored, unless
+rsne.c is compiled with -DNo_Namelist_Comments.
+
+Nonstandard extension (Feb. 1993) to open: for sequential files,
+ACCESS='APPEND' (or access='anything else starting with "A" or "a"')
+causes the file to be positioned at end-of-file, so a write will
+append to the file.
+
+Some buggy Fortran programs use unformatted direct I/O to write
+an incomplete record and later read more from that record than
+they have written. For records other than the last, the unwritten
+portion of the record reads as binary zeros. The last record is
+a special case: attempting to read more from it than was written
+gives end-of-file -- which may help one find a bug. Some other
+Fortran I/O libraries treat the last record no differently than
+others and thus give no help in finding the bug of reading more
+than was written. If you wish to have this behavior, compile
+uio.c with -DPad_UDread .
+
+If you want to be able to catch write failures (e.g., due to a
+disk being full) with an ERR= specifier, compile dfe.c, due.c,
+sfe.c, sue.c, and wsle.c with -DALWAYS_FLUSH. This will lead to
+slower execution and more I/O, but should make ERR= work as
+expected, provided fflush returns an error return when its
+physical write fails.
+
+Carriage controls are meant to be interpreted by the UNIX col
+program (or a similar program). Sometimes it's convenient to use
+only ' ' as the carriage control character (normal single spacing).
+If you compile lwrite.c and wsfe.c with -DOMIT_BLANK_CC, formatted
+external output lines will have an initial ' ' quietly omitted,
+making use of the col program unnecessary with output that only
+has ' ' for carriage control.
+
+The Fortran 77 Standard leaves it up to the implementation whether
+formatted writes of floating-point numbers of absolute value < 1 have
+a zero before the decimal point. By default, libI77 omits such
+superfluous zeros, but you can cause them to appear by compiling
+lwrite.c, wref.c, and wrtfmt.c with -DWANT_LEAD_0 .
+
+If your (Unix) system lacks a ranlib command, you don't need it.
+Either comment out the makefile's ranlib invocation, or install
+a harmless "ranlib" command somewhere in your PATH, such as the
+one-line shell script
+
+ exit 0
+
+or (on some systems)
+
+ exec /usr/bin/ar lts $1 >/dev/null
+
+By default, the routines that implement complex and double complex
+division, c_div.c and z_div.c, call sig_die to print an error message
+and exit if they see a divisor of 0, as this is sometimes helpful for
+debugging. On systems with IEEE arithmetic, compiling c_div.c and
+z_div.c with -DIEEE_COMPLEX_DIVIDE causes them instead to set both
+the real and imaginary parts of the result to +INFINITY if the
+numerator is nonzero, or to NaN if it vanishes.
+
+Nowadays most Unix and Linux systems have function
+ int ftruncate(int fildes, off_t len);
+defined in system header file unistd.h that adjusts the length of file
+descriptor fildes to length len. Unless endfile.c is compiled with
+-DNO_TRUNCATE, endfile.c #includes "unistd.h" and calls ftruncate() if
+necessary to shorten files. If your system lacks ftruncate(), compile
+endfile.c with -DNO_TRUNCATE to make endfile.c use the older and more
+portable scheme of shortening a file by copying to a temporary file
+and back again.
+
+The initializations for "f2c -trapuv" are done by _uninit_f2c(),
+whose source is uninit.c, introduced June 2001. On IEEE-arithmetic
+systems, _uninit_f2c should initialize floating-point variables to
+signaling NaNs and, at its first invocation, should enable the
+invalid operation exception. Alas, the rules for distinguishing
+signaling from quiet NaNs were not specified in the IEEE P754 standard,
+nor were the precise means of enabling and disabling IEEE-arithmetic
+exceptions, and these details are thus system dependent. There are
+#ifdef's in uninit.c that specify them for some popular systems. If
+yours is not one of these systems, it may take some detective work to
+discover the appropriate details for your system. Sometimes it helps
+to look in the standard include directories for header files with
+relevant-sounding names, such as ieeefp.h, nan.h, or trap.h, and
+it may be simplest to run experiments to see what distinguishes a
+signaling from a quiet NaN. (If x is initialized to a signaling
+NaN and the invalid operation exception is masked off, as it should
+be by default on IEEE-arithmetic systems, then computing, say,
+y = x + 1 will yield a quiet NaN.)
diff --git a/F2CLIBS/libf2c/abort_.c b/F2CLIBS/libf2c/abort_.c
new file mode 100644
index 0000000..92c841a
--- /dev/null
+++ b/F2CLIBS/libf2c/abort_.c
@@ -0,0 +1,22 @@
+#include "stdio.h"
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+extern VOID sig_die();
+
+int abort_()
+#else
+extern void sig_die(const char*,int);
+
+int abort_(void)
+#endif
+{
+sig_die("Fortran abort routine called", 1);
+return 0; /* not reached */
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/arithchk.c b/F2CLIBS/libf2c/arithchk.c
new file mode 100644
index 0000000..0522d96
--- /dev/null
+++ b/F2CLIBS/libf2c/arithchk.c
@@ -0,0 +1,245 @@
+/****************************************************************
+Copyright (C) 1997, 1998, 2000 Lucent Technologies
+All Rights Reserved
+
+Permission to use, copy, modify, and distribute this software and
+its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the name of Lucent or any of its entities
+not be used in advertising or publicity pertaining to
+distribution of the software without specific, written prior
+permission.
+
+LUCENT DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,
+INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS.
+IN NO EVENT SHALL LUCENT OR ANY OF ITS ENTITIES BE LIABLE FOR ANY
+SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER
+IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF
+THIS SOFTWARE.
+****************************************************************/
+
+/* Try to deduce arith.h from arithmetic properties. */
+
+#include <stdio.h>
+#include <math.h>
+#include <errno.h>
+
+#ifdef NO_FPINIT
+#define fpinit_ASL()
+#else
+#ifndef KR_headers
+extern
+#ifdef __cplusplus
+ "C"
+#endif
+ void fpinit_ASL(void);
+#endif /*KR_headers*/
+#endif /*NO_FPINIT*/
+
+ static int dalign;
+ typedef struct
+Akind {
+ char *name;
+ int kind;
+ } Akind;
+
+ static Akind
+IEEE_8087 = { "IEEE_8087", 1 },
+IEEE_MC68k = { "IEEE_MC68k", 2 },
+IBM = { "IBM", 3 },
+VAX = { "VAX", 4 },
+CRAY = { "CRAY", 5};
+
+ static double t_nan;
+
+ static Akind *
+Lcheck(void)
+{
+ union {
+ double d;
+ long L[2];
+ } u;
+ struct {
+ double d;
+ long L;
+ } x[2];
+
+ if (sizeof(x) > 2*(sizeof(double) + sizeof(long)))
+ dalign = 1;
+ u.L[0] = u.L[1] = 0;
+ u.d = 1e13;
+ if (u.L[0] == 1117925532 && u.L[1] == -448790528)
+ return &IEEE_MC68k;
+ if (u.L[1] == 1117925532 && u.L[0] == -448790528)
+ return &IEEE_8087;
+ if (u.L[0] == -2065213935 && u.L[1] == 10752)
+ return &VAX;
+ if (u.L[0] == 1267827943 && u.L[1] == 704643072)
+ return &IBM;
+ return 0;
+ }
+
+ static Akind *
+icheck(void)
+{
+ union {
+ double d;
+ int L[2];
+ } u;
+ struct {
+ double d;
+ int L;
+ } x[2];
+
+ if (sizeof(x) > 2*(sizeof(double) + sizeof(int)))
+ dalign = 1;
+ u.L[0] = u.L[1] = 0;
+ u.d = 1e13;
+ if (u.L[0] == 1117925532 && u.L[1] == -448790528)
+ return &IEEE_MC68k;
+ if (u.L[1] == 1117925532 && u.L[0] == -448790528)
+ return &IEEE_8087;
+ if (u.L[0] == -2065213935 && u.L[1] == 10752)
+ return &VAX;
+ if (u.L[0] == 1267827943 && u.L[1] == 704643072)
+ return &IBM;
+ return 0;
+ }
+
+char *emptyfmt = ""; /* avoid possible warning message with printf("") */
+
+ static Akind *
+ccheck(void)
+{
+ union {
+ double d;
+ long L;
+ } u;
+ long Cray1;
+
+ /* Cray1 = 4617762693716115456 -- without overflow on non-Crays */
+ Cray1 = printf(emptyfmt) < 0 ? 0 : 4617762;
+ if (printf(emptyfmt, Cray1) >= 0)
+ Cray1 = 1000000*Cray1 + 693716;
+ if (printf(emptyfmt, Cray1) >= 0)
+ Cray1 = 1000000*Cray1 + 115456;
+ u.d = 1e13;
+ if (u.L == Cray1)
+ return &CRAY;
+ return 0;
+ }
+
+ static int
+fzcheck(void)
+{
+ double a, b;
+ int i;
+
+ a = 1.;
+ b = .1;
+ for(i = 155;; b *= b, i >>= 1) {
+ if (i & 1) {
+ a *= b;
+ if (i == 1)
+ break;
+ }
+ }
+ b = a * a;
+ return b == 0.;
+ }
+
+ static int
+need_nancheck(void)
+{
+ double t;
+
+ errno = 0;
+ t = log(t_nan);
+ if (errno == 0)
+ return 1;
+ errno = 0;
+ t = sqrt(t_nan);
+ return errno == 0;
+ }
+
+ void
+get_nanbits(unsigned int *b, int k)
+{
+ union { double d; unsigned int z[2]; } u, u1, u2;
+
+ k = 2 - k;
+ u1.z[k] = u2.z[k] = 0x7ff00000;
+ u1.z[1-k] = u2.z[1-k] = 0;
+ u.d = u1.d - u2.d; /* Infinity - Infinity */
+ b[0] = u.z[0];
+ b[1] = u.z[1];
+ }
+
+ int
+main(void)
+{
+ FILE *f;
+ Akind *a = 0;
+ int Ldef = 0;
+ unsigned int nanbits[2];
+
+ fpinit_ASL();
+#ifdef WRITE_ARITH_H /* for Symantec's buggy "make" */
+ f = fopen("arith.h", "w");
+ if (!f) {
+ printf("Cannot open arith.h\n");
+ return 1;
+ }
+#else
+ f = stdout;
+#endif
+
+ if (sizeof(double) == 2*sizeof(long))
+ a = Lcheck();
+ else if (sizeof(double) == 2*sizeof(int)) {
+ Ldef = 1;
+ a = icheck();
+ }
+ else if (sizeof(double) == sizeof(long))
+ a = ccheck();
+ if (a) {
+ fprintf(f, "#define %s\n#define Arith_Kind_ASL %d\n",
+ a->name, a->kind);
+ if (Ldef)
+ fprintf(f, "#define Long int\n#define Intcast (int)(long)\n");
+ if (dalign)
+ fprintf(f, "#define Double_Align\n");
+ if (sizeof(char*) == 8)
+ fprintf(f, "#define X64_bit_pointers\n");
+#ifndef NO_LONG_LONG
+ if (sizeof(long long) < 8)
+#endif
+ fprintf(f, "#define NO_LONG_LONG\n");
+ if (a->kind <= 2) {
+ if (fzcheck())
+ fprintf(f, "#define Sudden_Underflow\n");
+ t_nan = -a->kind;
+ if (need_nancheck())
+ fprintf(f, "#define NANCHECK\n");
+ if (sizeof(double) == 2*sizeof(unsigned int)) {
+ get_nanbits(nanbits, a->kind);
+ fprintf(f, "#define QNaN0 0x%x\n", nanbits[0]);
+ fprintf(f, "#define QNaN1 0x%x\n", nanbits[1]);
+ }
+ }
+ return 0;
+ }
+ fprintf(f, "/* Unknown arithmetic */\n");
+ return 1;
+ }
+
+#ifdef __sun
+#ifdef __i386
+/* kludge for Intel Solaris */
+void fpsetprec(int x) { }
+#endif
+#endif
diff --git a/F2CLIBS/libf2c/backspac.c b/F2CLIBS/libf2c/backspac.c
new file mode 100644
index 0000000..908a618
--- /dev/null
+++ b/F2CLIBS/libf2c/backspac.c
@@ -0,0 +1,76 @@
+#include "f2c.h"
+#include "fio.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+#ifdef KR_headers
+integer f_back(a) alist *a;
+#else
+integer f_back(alist *a)
+#endif
+{ unit *b;
+ OFF_T v, w, x, y, z;
+ uiolen n;
+ FILE *f;
+
+ f__curunit = b = &f__units[a->aunit]; /* curunit for error messages */
+ if(a->aunit >= MXUNIT || a->aunit < 0)
+ err(a->aerr,101,"backspace")
+ if(b->useek==0) err(a->aerr,106,"backspace")
+ if(b->ufd == NULL) {
+ fk_open(1, 1, a->aunit);
+ return(0);
+ }
+ if(b->uend==1)
+ { b->uend=0;
+ return(0);
+ }
+ if(b->uwrt) {
+ t_runc(a);
+ if (f__nowreading(b))
+ err(a->aerr,errno,"backspace")
+ }
+ f = b->ufd; /* may have changed in t_runc() */
+ if(b->url>0)
+ {
+ x=FTELL(f);
+ y = x % b->url;
+ if(y == 0) x--;
+ x /= b->url;
+ x *= b->url;
+ (void) FSEEK(f,x,SEEK_SET);
+ return(0);
+ }
+
+ if(b->ufmt==0)
+ { FSEEK(f,-(OFF_T)sizeof(uiolen),SEEK_CUR);
+ fread((char *)&n,sizeof(uiolen),1,f);
+ FSEEK(f,-(OFF_T)n-2*sizeof(uiolen),SEEK_CUR);
+ return(0);
+ }
+ w = x = FTELL(f);
+ z = 0;
+ loop:
+ while(x) {
+ x -= x < 64 ? x : 64;
+ FSEEK(f,x,SEEK_SET);
+ for(y = x; y < w; y++) {
+ if (getc(f) != '\n')
+ continue;
+ v = FTELL(f);
+ if (v == w) {
+ if (z)
+ goto break2;
+ goto loop;
+ }
+ z = v;
+ }
+ err(a->aerr,(EOF),"backspace")
+ }
+ break2:
+ FSEEK(f, z, SEEK_SET);
+ return 0;
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/c_abs.c b/F2CLIBS/libf2c/c_abs.c
new file mode 100644
index 0000000..858f2c8
--- /dev/null
+++ b/F2CLIBS/libf2c/c_abs.c
@@ -0,0 +1,20 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+extern double f__cabs();
+
+double c_abs(z) complex *z;
+#else
+extern double f__cabs(double, double);
+
+double c_abs(complex *z)
+#endif
+{
+return( f__cabs( z->r, z->i ) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/c_cos.c b/F2CLIBS/libf2c/c_cos.c
new file mode 100644
index 0000000..29fe49e
--- /dev/null
+++ b/F2CLIBS/libf2c/c_cos.c
@@ -0,0 +1,23 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+extern double sin(), cos(), sinh(), cosh();
+
+VOID c_cos(r, z) complex *r, *z;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+void c_cos(complex *r, complex *z)
+#endif
+{
+ double zi = z->i, zr = z->r;
+ r->r = cos(zr) * cosh(zi);
+ r->i = - sin(zr) * sinh(zi);
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/c_div.c b/F2CLIBS/libf2c/c_div.c
new file mode 100644
index 0000000..9463a43
--- /dev/null
+++ b/F2CLIBS/libf2c/c_div.c
@@ -0,0 +1,53 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+extern VOID sig_die();
+VOID c_div(c, a, b)
+complex *a, *b, *c;
+#else
+extern void sig_die(const char*,int);
+void c_div(complex *c, complex *a, complex *b)
+#endif
+{
+ double ratio, den;
+ double abr, abi, cr;
+
+ if( (abr = b->r) < 0.)
+ abr = - abr;
+ if( (abi = b->i) < 0.)
+ abi = - abi;
+ if( abr <= abi )
+ {
+ if(abi == 0) {
+#ifdef IEEE_COMPLEX_DIVIDE
+ float af, bf;
+ af = bf = abr;
+ if (a->i != 0 || a->r != 0)
+ af = 1.;
+ c->i = c->r = af / bf;
+ return;
+#else
+ sig_die("complex division by zero", 1);
+#endif
+ }
+ ratio = (double)b->r / b->i ;
+ den = b->i * (1 + ratio*ratio);
+ cr = (a->r*ratio + a->i) / den;
+ c->i = (a->i*ratio - a->r) / den;
+ }
+
+ else
+ {
+ ratio = (double)b->i / b->r ;
+ den = b->r * (1 + ratio*ratio);
+ cr = (a->r + a->i*ratio) / den;
+ c->i = (a->i - a->r*ratio) / den;
+ }
+ c->r = cr;
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/c_exp.c b/F2CLIBS/libf2c/c_exp.c
new file mode 100644
index 0000000..f46508d
--- /dev/null
+++ b/F2CLIBS/libf2c/c_exp.c
@@ -0,0 +1,25 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+extern double exp(), cos(), sin();
+
+ VOID c_exp(r, z) complex *r, *z;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+void c_exp(complex *r, complex *z)
+#endif
+{
+ double expx, zi = z->i;
+
+ expx = exp(z->r);
+ r->r = expx * cos(zi);
+ r->i = expx * sin(zi);
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/c_log.c b/F2CLIBS/libf2c/c_log.c
new file mode 100644
index 0000000..a0ba3f0
--- /dev/null
+++ b/F2CLIBS/libf2c/c_log.c
@@ -0,0 +1,23 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+extern double log(), f__cabs(), atan2();
+VOID c_log(r, z) complex *r, *z;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern double f__cabs(double, double);
+
+void c_log(complex *r, complex *z)
+#endif
+{
+ double zi, zr;
+ r->i = atan2(zi = z->i, zr = z->r);
+ r->r = log( f__cabs(zr, zi) );
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/c_sin.c b/F2CLIBS/libf2c/c_sin.c
new file mode 100644
index 0000000..c8bc30f
--- /dev/null
+++ b/F2CLIBS/libf2c/c_sin.c
@@ -0,0 +1,23 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+extern double sin(), cos(), sinh(), cosh();
+
+VOID c_sin(r, z) complex *r, *z;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+void c_sin(complex *r, complex *z)
+#endif
+{
+ double zi = z->i, zr = z->r;
+ r->r = sin(zr) * cosh(zi);
+ r->i = cos(zr) * sinh(zi);
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/c_sqrt.c b/F2CLIBS/libf2c/c_sqrt.c
new file mode 100644
index 0000000..1678c53
--- /dev/null
+++ b/F2CLIBS/libf2c/c_sqrt.c
@@ -0,0 +1,41 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+extern double sqrt(), f__cabs();
+
+VOID c_sqrt(r, z) complex *r, *z;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern double f__cabs(double, double);
+
+void c_sqrt(complex *r, complex *z)
+#endif
+{
+ double mag, t;
+ double zi = z->i, zr = z->r;
+
+ if( (mag = f__cabs(zr, zi)) == 0.)
+ r->r = r->i = 0.;
+ else if(zr > 0)
+ {
+ r->r = t = sqrt(0.5 * (mag + zr) );
+ t = zi / t;
+ r->i = 0.5 * t;
+ }
+ else
+ {
+ t = sqrt(0.5 * (mag - zr) );
+ if(zi < 0)
+ t = -t;
+ r->i = t;
+ t = zi / t;
+ r->r = 0.5 * t;
+ }
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/cabs.c b/F2CLIBS/libf2c/cabs.c
new file mode 100644
index 0000000..84750d5
--- /dev/null
+++ b/F2CLIBS/libf2c/cabs.c
@@ -0,0 +1,33 @@
+#ifdef KR_headers
+extern double sqrt();
+double f__cabs(real, imag) double real, imag;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double f__cabs(double real, double imag)
+#endif
+{
+double temp;
+
+if(real < 0)
+ real = -real;
+if(imag < 0)
+ imag = -imag;
+if(imag > real){
+ temp = real;
+ real = imag;
+ imag = temp;
+}
+if((real+imag) == real)
+ return(real);
+
+temp = imag/real;
+temp = real*sqrt(1.0 + temp*temp); /*overflow!!*/
+return(temp);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/close.c b/F2CLIBS/libf2c/close.c
new file mode 100644
index 0000000..e958c71
--- /dev/null
+++ b/F2CLIBS/libf2c/close.c
@@ -0,0 +1,101 @@
+#include "f2c.h"
+#include "fio.h"
+#ifdef KR_headers
+integer f_clos(a) cllist *a;
+#else
+#undef abs
+#undef min
+#undef max
+#include "stdlib.h"
+#ifdef NON_UNIX_STDIO
+#ifndef unlink
+#define unlink remove
+#endif
+#else
+#ifdef MSDOS
+#include "io.h"
+#else
+#ifdef __cplusplus
+extern "C" int unlink(const char*);
+#else
+extern int unlink(const char*);
+#endif
+#endif
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+integer f_clos(cllist *a)
+#endif
+{ unit *b;
+
+ if(a->cunit >= MXUNIT) return(0);
+ b= &f__units[a->cunit];
+ if(b->ufd==NULL)
+ goto done;
+ if (b->uscrtch == 1)
+ goto Delete;
+ if (!a->csta)
+ goto Keep;
+ switch(*a->csta) {
+ default:
+ Keep:
+ case 'k':
+ case 'K':
+ if(b->uwrt == 1)
+ t_runc((alist *)a);
+ if(b->ufnm) {
+ fclose(b->ufd);
+ free(b->ufnm);
+ }
+ break;
+ case 'd':
+ case 'D':
+ Delete:
+ fclose(b->ufd);
+ if(b->ufnm) {
+ unlink(b->ufnm); /*SYSDEP*/
+ free(b->ufnm);
+ }
+ }
+ b->ufd=NULL;
+ done:
+ b->uend=0;
+ b->ufnm=NULL;
+ return(0);
+ }
+ void
+#ifdef KR_headers
+f_exit()
+#else
+f_exit(void)
+#endif
+{ int i;
+ static cllist xx;
+ if (!xx.cerr) {
+ xx.cerr=1;
+ xx.csta=NULL;
+ for(i=0;i<MXUNIT;i++)
+ {
+ xx.cunit=i;
+ (void) f_clos(&xx);
+ }
+ }
+}
+ int
+#ifdef KR_headers
+flush_()
+#else
+flush_(void)
+#endif
+{ int i;
+ for(i=0;i<MXUNIT;i++)
+ if(f__units[i].ufd != NULL && f__units[i].uwrt)
+ fflush(f__units[i].ufd);
+return 0;
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/comptry.bat b/F2CLIBS/libf2c/comptry.bat
new file mode 100644
index 0000000..0dc8453
--- /dev/null
+++ b/F2CLIBS/libf2c/comptry.bat
@@ -0,0 +1,5 @@
+%1 %2 %3 %4 %5 %6 %7 %8 %9
+if errorlevel 1 goto nolonglong
+exit 0
+:nolonglong
+%1 -DNO_LONG_LONG %2 %3 %4 %5 %6 %7 %8 %9
diff --git a/F2CLIBS/libf2c/ctype.c b/F2CLIBS/libf2c/ctype.c
new file mode 100644
index 0000000..96bdf1c
--- /dev/null
+++ b/F2CLIBS/libf2c/ctype.c
@@ -0,0 +1,2 @@
+#define My_ctype_DEF
+#include "ctype.h"
diff --git a/F2CLIBS/libf2c/ctype.h b/F2CLIBS/libf2c/ctype.h
new file mode 100644
index 0000000..2915615
--- /dev/null
+++ b/F2CLIBS/libf2c/ctype.h
@@ -0,0 +1,47 @@
+/* Custom ctype.h to overcome trouble with recent versions of Linux libc.a */
+
+#ifdef NO_My_ctype
+#include <ctype.h>
+#else /*{*/
+#ifndef My_ctype_DEF
+extern char My_ctype[];
+#else /*{*/
+char My_ctype[264] = {
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 2, 2, 2, 2, 2, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 2, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0};
+#endif /*}*/
+
+#define isdigit(x) (My_ctype[(x)+8] & 1)
+#define isspace(x) (My_ctype[(x)+8] & 2)
+#endif
diff --git a/F2CLIBS/libf2c/d_abs.c b/F2CLIBS/libf2c/d_abs.c
new file mode 100644
index 0000000..2f7a153
--- /dev/null
+++ b/F2CLIBS/libf2c/d_abs.c
@@ -0,0 +1,18 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+double d_abs(x) doublereal *x;
+#else
+double d_abs(doublereal *x)
+#endif
+{
+if(*x >= 0)
+ return(*x);
+return(- *x);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/d_acos.c b/F2CLIBS/libf2c/d_acos.c
new file mode 100644
index 0000000..69005b5
--- /dev/null
+++ b/F2CLIBS/libf2c/d_acos.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double acos();
+double d_acos(x) doublereal *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double d_acos(doublereal *x)
+#endif
+{
+return( acos(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/d_asin.c b/F2CLIBS/libf2c/d_asin.c
new file mode 100644
index 0000000..d5196ab
--- /dev/null
+++ b/F2CLIBS/libf2c/d_asin.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double asin();
+double d_asin(x) doublereal *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double d_asin(doublereal *x)
+#endif
+{
+return( asin(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/d_atan.c b/F2CLIBS/libf2c/d_atan.c
new file mode 100644
index 0000000..d8856f8
--- /dev/null
+++ b/F2CLIBS/libf2c/d_atan.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double atan();
+double d_atan(x) doublereal *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double d_atan(doublereal *x)
+#endif
+{
+return( atan(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/d_atn2.c b/F2CLIBS/libf2c/d_atn2.c
new file mode 100644
index 0000000..5611385
--- /dev/null
+++ b/F2CLIBS/libf2c/d_atn2.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double atan2();
+double d_atn2(x,y) doublereal *x, *y;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double d_atn2(doublereal *x, doublereal *y)
+#endif
+{
+return( atan2(*x,*y) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/d_cnjg.c b/F2CLIBS/libf2c/d_cnjg.c
new file mode 100644
index 0000000..38471d9
--- /dev/null
+++ b/F2CLIBS/libf2c/d_cnjg.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+ VOID
+#ifdef KR_headers
+d_cnjg(r, z) doublecomplex *r, *z;
+#else
+d_cnjg(doublecomplex *r, doublecomplex *z)
+#endif
+{
+ doublereal zi = z->i;
+ r->r = z->r;
+ r->i = -zi;
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/d_cos.c b/F2CLIBS/libf2c/d_cos.c
new file mode 100644
index 0000000..12def9a
--- /dev/null
+++ b/F2CLIBS/libf2c/d_cos.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double cos();
+double d_cos(x) doublereal *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double d_cos(doublereal *x)
+#endif
+{
+return( cos(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/d_cosh.c b/F2CLIBS/libf2c/d_cosh.c
new file mode 100644
index 0000000..9214c7a
--- /dev/null
+++ b/F2CLIBS/libf2c/d_cosh.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double cosh();
+double d_cosh(x) doublereal *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double d_cosh(doublereal *x)
+#endif
+{
+return( cosh(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/d_dim.c b/F2CLIBS/libf2c/d_dim.c
new file mode 100644
index 0000000..627ddb6
--- /dev/null
+++ b/F2CLIBS/libf2c/d_dim.c
@@ -0,0 +1,16 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+double d_dim(a,b) doublereal *a, *b;
+#else
+double d_dim(doublereal *a, doublereal *b)
+#endif
+{
+return( *a > *b ? *a - *b : 0);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/d_exp.c b/F2CLIBS/libf2c/d_exp.c
new file mode 100644
index 0000000..e9ab5d4
--- /dev/null
+++ b/F2CLIBS/libf2c/d_exp.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double exp();
+double d_exp(x) doublereal *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double d_exp(doublereal *x)
+#endif
+{
+return( exp(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/d_imag.c b/F2CLIBS/libf2c/d_imag.c
new file mode 100644
index 0000000..d17b9dd
--- /dev/null
+++ b/F2CLIBS/libf2c/d_imag.c
@@ -0,0 +1,16 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+double d_imag(z) doublecomplex *z;
+#else
+double d_imag(doublecomplex *z)
+#endif
+{
+return(z->i);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/d_int.c b/F2CLIBS/libf2c/d_int.c
new file mode 100644
index 0000000..6da4ce3
--- /dev/null
+++ b/F2CLIBS/libf2c/d_int.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double floor();
+double d_int(x) doublereal *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double d_int(doublereal *x)
+#endif
+{
+return( (*x>0) ? floor(*x) : -floor(- *x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/d_lg10.c b/F2CLIBS/libf2c/d_lg10.c
new file mode 100644
index 0000000..664c19d
--- /dev/null
+++ b/F2CLIBS/libf2c/d_lg10.c
@@ -0,0 +1,21 @@
+#include "f2c.h"
+
+#define log10e 0.43429448190325182765
+
+#ifdef KR_headers
+double log();
+double d_lg10(x) doublereal *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double d_lg10(doublereal *x)
+#endif
+{
+return( log10e * log(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/d_log.c b/F2CLIBS/libf2c/d_log.c
new file mode 100644
index 0000000..e74be02
--- /dev/null
+++ b/F2CLIBS/libf2c/d_log.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double log();
+double d_log(x) doublereal *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double d_log(doublereal *x)
+#endif
+{
+return( log(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/d_mod.c b/F2CLIBS/libf2c/d_mod.c
new file mode 100644
index 0000000..3766d9f
--- /dev/null
+++ b/F2CLIBS/libf2c/d_mod.c
@@ -0,0 +1,46 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+#ifdef IEEE_drem
+double drem();
+#else
+double floor();
+#endif
+double d_mod(x,y) doublereal *x, *y;
+#else
+#ifdef IEEE_drem
+double drem(double, double);
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+#endif
+double d_mod(doublereal *x, doublereal *y)
+#endif
+{
+#ifdef IEEE_drem
+ double xa, ya, z;
+ if ((ya = *y) < 0.)
+ ya = -ya;
+ z = drem(xa = *x, ya);
+ if (xa > 0) {
+ if (z < 0)
+ z += ya;
+ }
+ else if (z > 0)
+ z -= ya;
+ return z;
+#else
+ double quotient;
+ if( (quotient = *x / *y) >= 0)
+ quotient = floor(quotient);
+ else
+ quotient = -floor(-quotient);
+ return(*x - (*y) * quotient );
+#endif
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/d_nint.c b/F2CLIBS/libf2c/d_nint.c
new file mode 100644
index 0000000..66f2dd0
--- /dev/null
+++ b/F2CLIBS/libf2c/d_nint.c
@@ -0,0 +1,20 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double floor();
+double d_nint(x) doublereal *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double d_nint(doublereal *x)
+#endif
+{
+return( (*x)>=0 ?
+ floor(*x + .5) : -floor(.5 - *x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/d_prod.c b/F2CLIBS/libf2c/d_prod.c
new file mode 100644
index 0000000..f9f348b
--- /dev/null
+++ b/F2CLIBS/libf2c/d_prod.c
@@ -0,0 +1,16 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+double d_prod(x,y) real *x, *y;
+#else
+double d_prod(real *x, real *y)
+#endif
+{
+return( (*x) * (*y) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/d_sign.c b/F2CLIBS/libf2c/d_sign.c
new file mode 100644
index 0000000..d06e0d1
--- /dev/null
+++ b/F2CLIBS/libf2c/d_sign.c
@@ -0,0 +1,18 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+double d_sign(a,b) doublereal *a, *b;
+#else
+double d_sign(doublereal *a, doublereal *b)
+#endif
+{
+double x;
+x = (*a >= 0 ? *a : - *a);
+return( *b >= 0 ? x : -x);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/d_sin.c b/F2CLIBS/libf2c/d_sin.c
new file mode 100644
index 0000000..ebd4eec
--- /dev/null
+++ b/F2CLIBS/libf2c/d_sin.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double sin();
+double d_sin(x) doublereal *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double d_sin(doublereal *x)
+#endif
+{
+return( sin(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/d_sinh.c b/F2CLIBS/libf2c/d_sinh.c
new file mode 100644
index 0000000..2479a6f
--- /dev/null
+++ b/F2CLIBS/libf2c/d_sinh.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double sinh();
+double d_sinh(x) doublereal *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double d_sinh(doublereal *x)
+#endif
+{
+return( sinh(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/d_sqrt.c b/F2CLIBS/libf2c/d_sqrt.c
new file mode 100644
index 0000000..a7fa66c
--- /dev/null
+++ b/F2CLIBS/libf2c/d_sqrt.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double sqrt();
+double d_sqrt(x) doublereal *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double d_sqrt(doublereal *x)
+#endif
+{
+return( sqrt(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/d_tan.c b/F2CLIBS/libf2c/d_tan.c
new file mode 100644
index 0000000..7d252c4
--- /dev/null
+++ b/F2CLIBS/libf2c/d_tan.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double tan();
+double d_tan(x) doublereal *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double d_tan(doublereal *x)
+#endif
+{
+return( tan(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/d_tanh.c b/F2CLIBS/libf2c/d_tanh.c
new file mode 100644
index 0000000..415b585
--- /dev/null
+++ b/F2CLIBS/libf2c/d_tanh.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double tanh();
+double d_tanh(x) doublereal *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double d_tanh(doublereal *x)
+#endif
+{
+return( tanh(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/derf_.c b/F2CLIBS/libf2c/derf_.c
new file mode 100644
index 0000000..d935d31
--- /dev/null
+++ b/F2CLIBS/libf2c/derf_.c
@@ -0,0 +1,18 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+double erf();
+double derf_(x) doublereal *x;
+#else
+extern double erf(double);
+double derf_(doublereal *x)
+#endif
+{
+return( erf(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/derfc_.c b/F2CLIBS/libf2c/derfc_.c
new file mode 100644
index 0000000..18f5c61
--- /dev/null
+++ b/F2CLIBS/libf2c/derfc_.c
@@ -0,0 +1,20 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+extern double erfc();
+
+double derfc_(x) doublereal *x;
+#else
+extern double erfc(double);
+
+double derfc_(doublereal *x)
+#endif
+{
+return( erfc(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/dfe.c b/F2CLIBS/libf2c/dfe.c
new file mode 100644
index 0000000..c6b10d0
--- /dev/null
+++ b/F2CLIBS/libf2c/dfe.c
@@ -0,0 +1,151 @@
+#include "f2c.h"
+#include "fio.h"
+#include "fmt.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+ int
+y_rsk(Void)
+{
+ if(f__curunit->uend || f__curunit->url <= f__recpos
+ || f__curunit->url == 1) return 0;
+ do {
+ getc(f__cf);
+ } while(++f__recpos < f__curunit->url);
+ return 0;
+}
+
+ int
+y_getc(Void)
+{
+ int ch;
+ if(f__curunit->uend) return(-1);
+ if((ch=getc(f__cf))!=EOF)
+ {
+ f__recpos++;
+ if(f__curunit->url>=f__recpos ||
+ f__curunit->url==1)
+ return(ch);
+ else return(' ');
+ }
+ if(feof(f__cf))
+ {
+ f__curunit->uend=1;
+ errno=0;
+ return(-1);
+ }
+ err(f__elist->cierr,errno,"readingd");
+}
+
+ static int
+y_rev(Void)
+{
+ if (f__recpos < f__hiwater)
+ f__recpos = f__hiwater;
+ if (f__curunit->url > 1)
+ while(f__recpos < f__curunit->url)
+ (*f__putn)(' ');
+ if (f__recpos)
+ f__putbuf(0);
+ f__recpos = 0;
+ return(0);
+}
+
+ static int
+y_err(Void)
+{
+ err(f__elist->cierr, 110, "dfe");
+}
+
+ static int
+y_newrec(Void)
+{
+ y_rev();
+ f__hiwater = f__cursor = 0;
+ return(1);
+}
+
+ int
+#ifdef KR_headers
+c_dfe(a) cilist *a;
+#else
+c_dfe(cilist *a)
+#endif
+{
+ f__sequential=0;
+ f__formatted=f__external=1;
+ f__elist=a;
+ f__cursor=f__scale=f__recpos=0;
+ f__curunit = &f__units[a->ciunit];
+ if(a->ciunit>MXUNIT || a->ciunit<0)
+ err(a->cierr,101,"startchk");
+ if(f__curunit->ufd==NULL && fk_open(DIR,FMT,a->ciunit))
+ err(a->cierr,104,"dfe");
+ f__cf=f__curunit->ufd;
+ if(!f__curunit->ufmt) err(a->cierr,102,"dfe")
+ if(!f__curunit->useek) err(a->cierr,104,"dfe")
+ f__fmtbuf=a->cifmt;
+ if(a->cirec <= 0)
+ err(a->cierr,130,"dfe")
+ FSEEK(f__cf,(OFF_T)f__curunit->url * (a->cirec-1),SEEK_SET);
+ f__curunit->uend = 0;
+ return(0);
+}
+#ifdef KR_headers
+integer s_rdfe(a) cilist *a;
+#else
+integer s_rdfe(cilist *a)
+#endif
+{
+ int n;
+ if(!f__init) f_init();
+ f__reading=1;
+ if(n=c_dfe(a))return(n);
+ if(f__curunit->uwrt && f__nowreading(f__curunit))
+ err(a->cierr,errno,"read start");
+ f__getn = y_getc;
+ f__doed = rd_ed;
+ f__doned = rd_ned;
+ f__dorevert = f__donewrec = y_err;
+ f__doend = y_rsk;
+ if(pars_f(f__fmtbuf)<0)
+ err(a->cierr,100,"read start");
+ fmt_bg();
+ return(0);
+}
+#ifdef KR_headers
+integer s_wdfe(a) cilist *a;
+#else
+integer s_wdfe(cilist *a)
+#endif
+{
+ int n;
+ if(!f__init) f_init();
+ f__reading=0;
+ if(n=c_dfe(a)) return(n);
+ if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
+ err(a->cierr,errno,"startwrt");
+ f__putn = x_putc;
+ f__doed = w_ed;
+ f__doned= w_ned;
+ f__dorevert = y_err;
+ f__donewrec = y_newrec;
+ f__doend = y_rev;
+ if(pars_f(f__fmtbuf)<0)
+ err(a->cierr,100,"startwrt");
+ fmt_bg();
+ return(0);
+}
+integer e_rdfe(Void)
+{
+ en_fio();
+ return 0;
+}
+integer e_wdfe(Void)
+{
+ return en_fio();
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/dolio.c b/F2CLIBS/libf2c/dolio.c
new file mode 100644
index 0000000..4070d87
--- /dev/null
+++ b/F2CLIBS/libf2c/dolio.c
@@ -0,0 +1,26 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+#ifdef KR_headers
+extern int (*f__lioproc)();
+
+integer do_lio(type,number,ptr,len) ftnint *number,*type; char *ptr; ftnlen len;
+#else
+extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint);
+
+integer do_lio(ftnint *type, ftnint *number, char *ptr, ftnlen len)
+#endif
+{
+ return((*f__lioproc)(number,ptr,len,*type));
+}
+#ifdef __cplusplus
+ }
+#endif
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/dtime_.c b/F2CLIBS/libf2c/dtime_.c
new file mode 100644
index 0000000..6a09b3e
--- /dev/null
+++ b/F2CLIBS/libf2c/dtime_.c
@@ -0,0 +1,63 @@
+#include "time.h"
+
+#ifdef MSDOS
+#undef USE_CLOCK
+#define USE_CLOCK
+#endif
+
+#ifndef REAL
+#define REAL double
+#endif
+
+#ifndef USE_CLOCK
+#define _INCLUDE_POSIX_SOURCE /* for HP-UX */
+#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */
+#include "sys/types.h"
+#include "sys/times.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+#endif
+
+#undef Hz
+#ifdef CLK_TCK
+#define Hz CLK_TCK
+#else
+#ifdef HZ
+#define Hz HZ
+#else
+#define Hz 60
+#endif
+#endif
+
+ REAL
+#ifdef KR_headers
+dtime_(tarray) float *tarray;
+#else
+dtime_(float *tarray)
+#endif
+{
+#ifdef USE_CLOCK
+#ifndef CLOCKS_PER_SECOND
+#define CLOCKS_PER_SECOND Hz
+#endif
+ static double t0;
+ double t = clock();
+ tarray[1] = 0;
+ tarray[0] = (t - t0) / CLOCKS_PER_SECOND;
+ t0 = t;
+ return tarray[0];
+#else
+ struct tms t;
+ static struct tms t0;
+
+ times(&t);
+ tarray[0] = (double)(t.tms_utime - t0.tms_utime) / Hz;
+ tarray[1] = (double)(t.tms_stime - t0.tms_stime) / Hz;
+ t0 = t;
+ return tarray[0] + tarray[1];
+#endif
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/due.c b/F2CLIBS/libf2c/due.c
new file mode 100644
index 0000000..a7f4cec
--- /dev/null
+++ b/F2CLIBS/libf2c/due.c
@@ -0,0 +1,77 @@
+#include "f2c.h"
+#include "fio.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+ int
+#ifdef KR_headers
+c_due(a) cilist *a;
+#else
+c_due(cilist *a)
+#endif
+{
+ if(!f__init) f_init();
+ f__sequential=f__formatted=f__recpos=0;
+ f__external=1;
+ f__curunit = &f__units[a->ciunit];
+ if(a->ciunit>=MXUNIT || a->ciunit<0)
+ err(a->cierr,101,"startio");
+ f__elist=a;
+ if(f__curunit->ufd==NULL && fk_open(DIR,UNF,a->ciunit) ) err(a->cierr,104,"due");
+ f__cf=f__curunit->ufd;
+ if(f__curunit->ufmt) err(a->cierr,102,"cdue")
+ if(!f__curunit->useek) err(a->cierr,104,"cdue")
+ if(f__curunit->ufd==NULL) err(a->cierr,114,"cdue")
+ if(a->cirec <= 0)
+ err(a->cierr,130,"due")
+ FSEEK(f__cf,(OFF_T)(a->cirec-1)*f__curunit->url,SEEK_SET);
+ f__curunit->uend = 0;
+ return(0);
+}
+#ifdef KR_headers
+integer s_rdue(a) cilist *a;
+#else
+integer s_rdue(cilist *a)
+#endif
+{
+ int n;
+ f__reading=1;
+ if(n=c_due(a)) return(n);
+ if(f__curunit->uwrt && f__nowreading(f__curunit))
+ err(a->cierr,errno,"read start");
+ return(0);
+}
+#ifdef KR_headers
+integer s_wdue(a) cilist *a;
+#else
+integer s_wdue(cilist *a)
+#endif
+{
+ int n;
+ f__reading=0;
+ if(n=c_due(a)) return(n);
+ if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
+ err(a->cierr,errno,"write start");
+ return(0);
+}
+integer e_rdue(Void)
+{
+ if(f__curunit->url==1 || f__recpos==f__curunit->url)
+ return(0);
+ FSEEK(f__cf,(OFF_T)(f__curunit->url-f__recpos),SEEK_CUR);
+ if(FTELL(f__cf)%f__curunit->url)
+ err(f__elist->cierr,200,"syserr");
+ return(0);
+}
+integer e_wdue(Void)
+{
+#ifdef ALWAYS_FLUSH
+ if (fflush(f__cf))
+ err(f__elist->cierr,errno,"write end");
+#endif
+ return(e_rdue());
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/ef1asc_.c b/F2CLIBS/libf2c/ef1asc_.c
new file mode 100644
index 0000000..70be0bc
--- /dev/null
+++ b/F2CLIBS/libf2c/ef1asc_.c
@@ -0,0 +1,25 @@
+/* EFL support routine to copy string b to string a */
+
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+
+#define M ( (long) (sizeof(long) - 1) )
+#define EVEN(x) ( ( (x)+ M) & (~M) )
+
+#ifdef KR_headers
+extern VOID s_copy();
+ef1asc_(a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb;
+#else
+extern void s_copy(char*,char*,ftnlen,ftnlen);
+int ef1asc_(ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb)
+#endif
+{
+s_copy( (char *)a, (char *)b, EVEN(*la), *lb );
+return 0; /* ignored return value */
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/ef1cmc_.c b/F2CLIBS/libf2c/ef1cmc_.c
new file mode 100644
index 0000000..4b420ae
--- /dev/null
+++ b/F2CLIBS/libf2c/ef1cmc_.c
@@ -0,0 +1,20 @@
+/* EFL support routine to compare two character strings */
+
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+extern integer s_cmp();
+integer ef1cmc_(a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb;
+#else
+extern integer s_cmp(char*,char*,ftnlen,ftnlen);
+integer ef1cmc_(ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb)
+#endif
+{
+return( s_cmp( (char *)a, (char *)b, *la, *lb) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/endfile.c b/F2CLIBS/libf2c/endfile.c
new file mode 100644
index 0000000..04020d3
--- /dev/null
+++ b/F2CLIBS/libf2c/endfile.c
@@ -0,0 +1,160 @@
+#include "f2c.h"
+#include "fio.h"
+
+/* Compile this with -DNO_TRUNCATE if unistd.h does not exist or */
+/* if it does not define int truncate(const char *name, off_t). */
+
+#ifdef MSDOS
+#undef NO_TRUNCATE
+#define NO_TRUNCATE
+#endif
+
+#ifndef NO_TRUNCATE
+#include "unistd.h"
+#endif
+
+#ifdef KR_headers
+extern char *strcpy();
+extern FILE *tmpfile();
+#else
+#undef abs
+#undef min
+#undef max
+#include "stdlib.h"
+#include "string.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+#endif
+
+extern char *f__r_mode[], *f__w_mode[];
+
+#ifdef KR_headers
+integer f_end(a) alist *a;
+#else
+integer f_end(alist *a)
+#endif
+{
+ unit *b;
+ FILE *tf;
+
+ if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile");
+ b = &f__units[a->aunit];
+ if(b->ufd==NULL) {
+ char nbuf[10];
+ sprintf(nbuf,"fort.%ld",(long)a->aunit);
+ if (tf = FOPEN(nbuf, f__w_mode[0]))
+ fclose(tf);
+ return(0);
+ }
+ b->uend=1;
+ return(b->useek ? t_runc(a) : 0);
+}
+
+#ifdef NO_TRUNCATE
+ static int
+#ifdef KR_headers
+copy(from, len, to) FILE *from, *to; register long len;
+#else
+copy(FILE *from, register long len, FILE *to)
+#endif
+{
+ int len1;
+ char buf[BUFSIZ];
+
+ while(fread(buf, len1 = len > BUFSIZ ? BUFSIZ : (int)len, 1, from)) {
+ if (!fwrite(buf, len1, 1, to))
+ return 1;
+ if ((len -= len1) <= 0)
+ break;
+ }
+ return 0;
+ }
+#endif /* NO_TRUNCATE */
+
+ int
+#ifdef KR_headers
+t_runc(a) alist *a;
+#else
+t_runc(alist *a)
+#endif
+{
+ OFF_T loc, len;
+ unit *b;
+ int rc;
+ FILE *bf;
+#ifdef NO_TRUNCATE
+ FILE *tf;
+#endif
+
+ b = &f__units[a->aunit];
+ if(b->url)
+ return(0); /*don't truncate direct files*/
+ loc=FTELL(bf = b->ufd);
+ FSEEK(bf,(OFF_T)0,SEEK_END);
+ len=FTELL(bf);
+ if (loc >= len || b->useek == 0)
+ return(0);
+#ifdef NO_TRUNCATE
+ if (b->ufnm == NULL)
+ return 0;
+ rc = 0;
+ fclose(b->ufd);
+ if (!loc) {
+ if (!(bf = FOPEN(b->ufnm, f__w_mode[b->ufmt])))
+ rc = 1;
+ if (b->uwrt)
+ b->uwrt = 1;
+ goto done;
+ }
+ if (!(bf = FOPEN(b->ufnm, f__r_mode[0]))
+ || !(tf = tmpfile())) {
+#ifdef NON_UNIX_STDIO
+ bad:
+#endif
+ rc = 1;
+ goto done;
+ }
+ if (copy(bf, (long)loc, tf)) {
+ bad1:
+ rc = 1;
+ goto done1;
+ }
+ if (!(bf = FREOPEN(b->ufnm, f__w_mode[0], bf)))
+ goto bad1;
+ rewind(tf);
+ if (copy(tf, (long)loc, bf))
+ goto bad1;
+ b->uwrt = 1;
+ b->urw = 2;
+#ifdef NON_UNIX_STDIO
+ if (b->ufmt) {
+ fclose(bf);
+ if (!(bf = FOPEN(b->ufnm, f__w_mode[3])))
+ goto bad;
+ FSEEK(bf,(OFF_T)0,SEEK_END);
+ b->urw = 3;
+ }
+#endif
+done1:
+ fclose(tf);
+done:
+ f__cf = b->ufd = bf;
+#else /* NO_TRUNCATE */
+ if (b->urw & 2)
+ fflush(b->ufd); /* necessary on some Linux systems */
+#ifndef FTRUNCATE
+#define FTRUNCATE ftruncate
+#endif
+ rc = FTRUNCATE(fileno(b->ufd), loc);
+ /* The following FSEEK is unnecessary on some systems, */
+ /* but should be harmless. */
+ FSEEK(b->ufd, (OFF_T)0, SEEK_END);
+#endif /* NO_TRUNCATE */
+ if (rc)
+ err(a->aerr,111,"endfile");
+ return 0;
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/erf_.c b/F2CLIBS/libf2c/erf_.c
new file mode 100644
index 0000000..532fec6
--- /dev/null
+++ b/F2CLIBS/libf2c/erf_.c
@@ -0,0 +1,22 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifndef REAL
+#define REAL double
+#endif
+
+#ifdef KR_headers
+double erf();
+REAL erf_(x) real *x;
+#else
+extern double erf(double);
+REAL erf_(real *x)
+#endif
+{
+return( erf((double)*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/erfc_.c b/F2CLIBS/libf2c/erfc_.c
new file mode 100644
index 0000000..6f6c9f1
--- /dev/null
+++ b/F2CLIBS/libf2c/erfc_.c
@@ -0,0 +1,22 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifndef REAL
+#define REAL double
+#endif
+
+#ifdef KR_headers
+double erfc();
+REAL erfc_(x) real *x;
+#else
+extern double erfc(double);
+REAL erfc_(real *x)
+#endif
+{
+return( erfc((double)*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/err.c b/F2CLIBS/libf2c/err.c
new file mode 100644
index 0000000..80a3b74
--- /dev/null
+++ b/F2CLIBS/libf2c/err.c
@@ -0,0 +1,293 @@
+#include "sysdep1.h" /* here to get stat64 on some badly designed Linux systems */
+#include "f2c.h"
+#ifdef KR_headers
+#define Const /*nothing*/
+extern char *malloc();
+#else
+#define Const const
+#undef abs
+#undef min
+#undef max
+#include "stdlib.h"
+#endif
+#include "fio.h"
+#include "fmt.h" /* for struct syl */
+
+/* Compile this with -DNO_ISATTY if unistd.h does not exist or */
+/* if it does not define int isatty(int). */
+#ifdef NO_ISATTY
+#define isatty(x) 0
+#else
+#include <unistd.h>
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/*global definitions*/
+unit f__units[MXUNIT]; /*unit table*/
+flag f__init; /*0 on entry, 1 after initializations*/
+cilist *f__elist; /*active external io list*/
+icilist *f__svic; /*active internal io list*/
+flag f__reading; /*1 if reading, 0 if writing*/
+flag f__cplus,f__cblank;
+Const char *f__fmtbuf;
+flag f__external; /*1 if external io, 0 if internal */
+#ifdef KR_headers
+int (*f__doed)(),(*f__doned)();
+int (*f__doend)(),(*f__donewrec)(),(*f__dorevert)();
+int (*f__getn)(); /* for formatted input */
+void (*f__putn)(); /* for formatted output */
+#else
+int (*f__getn)(void); /* for formatted input */
+void (*f__putn)(int); /* for formatted output */
+int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*);
+int (*f__dorevert)(void),(*f__donewrec)(void),(*f__doend)(void);
+#endif
+flag f__sequential; /*1 if sequential io, 0 if direct*/
+flag f__formatted; /*1 if formatted io, 0 if unformatted*/
+FILE *f__cf; /*current file*/
+unit *f__curunit; /*current unit*/
+int f__recpos; /*place in current record*/
+OFF_T f__cursor, f__hiwater;
+int f__scale;
+char *f__icptr;
+
+/*error messages*/
+Const char *F_err[] =
+{
+ "error in format", /* 100 */
+ "illegal unit number", /* 101 */
+ "formatted io not allowed", /* 102 */
+ "unformatted io not allowed", /* 103 */
+ "direct io not allowed", /* 104 */
+ "sequential io not allowed", /* 105 */
+ "can't backspace file", /* 106 */
+ "null file name", /* 107 */
+ "can't stat file", /* 108 */
+ "unit not connected", /* 109 */
+ "off end of record", /* 110 */
+ "truncation failed in endfile", /* 111 */
+ "incomprehensible list input", /* 112 */
+ "out of free space", /* 113 */
+ "unit not connected", /* 114 */
+ "read unexpected character", /* 115 */
+ "bad logical input field", /* 116 */
+ "bad variable type", /* 117 */
+ "bad namelist name", /* 118 */
+ "variable not in namelist", /* 119 */
+ "no end record", /* 120 */
+ "variable count incorrect", /* 121 */
+ "subscript for scalar variable", /* 122 */
+ "invalid array section", /* 123 */
+ "substring out of bounds", /* 124 */
+ "subscript out of bounds", /* 125 */
+ "can't read file", /* 126 */
+ "can't write file", /* 127 */
+ "'new' file exists", /* 128 */
+ "can't append to file", /* 129 */
+ "non-positive record number", /* 130 */
+ "nmLbuf overflow" /* 131 */
+};
+#define MAXERR (sizeof(F_err)/sizeof(char *)+100)
+
+ int
+#ifdef KR_headers
+f__canseek(f) FILE *f; /*SYSDEP*/
+#else
+f__canseek(FILE *f) /*SYSDEP*/
+#endif
+{
+#ifdef NON_UNIX_STDIO
+ return !isatty(fileno(f));
+#else
+ struct STAT_ST x;
+
+ if (FSTAT(fileno(f),&x) < 0)
+ return(0);
+#ifdef S_IFMT
+ switch(x.st_mode & S_IFMT) {
+ case S_IFDIR:
+ case S_IFREG:
+ if(x.st_nlink > 0) /* !pipe */
+ return(1);
+ else
+ return(0);
+ case S_IFCHR:
+ if(isatty(fileno(f)))
+ return(0);
+ return(1);
+#ifdef S_IFBLK
+ case S_IFBLK:
+ return(1);
+#endif
+ }
+#else
+#ifdef S_ISDIR
+ /* POSIX version */
+ if (S_ISREG(x.st_mode) || S_ISDIR(x.st_mode)) {
+ if(x.st_nlink > 0) /* !pipe */
+ return(1);
+ else
+ return(0);
+ }
+ if (S_ISCHR(x.st_mode)) {
+ if(isatty(fileno(f)))
+ return(0);
+ return(1);
+ }
+ if (S_ISBLK(x.st_mode))
+ return(1);
+#else
+ Help! How does fstat work on this system?
+#endif
+#endif
+ return(0); /* who knows what it is? */
+#endif
+}
+
+ void
+#ifdef KR_headers
+f__fatal(n,s) char *s;
+#else
+f__fatal(int n, const char *s)
+#endif
+{
+ if(n<100 && n>=0) perror(s); /*SYSDEP*/
+ else if(n >= (int)MAXERR || n < -1)
+ { fprintf(stderr,"%s: illegal error number %d\n",s,n);
+ }
+ else if(n == -1) fprintf(stderr,"%s: end of file\n",s);
+ else
+ fprintf(stderr,"%s: %s\n",s,F_err[n-100]);
+ if (f__curunit) {
+ fprintf(stderr,"apparent state: unit %d ",
+ (int)(f__curunit-f__units));
+ fprintf(stderr, f__curunit->ufnm ? "named %s\n" : "(unnamed)\n",
+ f__curunit->ufnm);
+ }
+ else
+ fprintf(stderr,"apparent state: internal I/O\n");
+ if (f__fmtbuf)
+ fprintf(stderr,"last format: %s\n",f__fmtbuf);
+ fprintf(stderr,"lately %s %s %s %s",f__reading?"reading":"writing",
+ f__sequential?"sequential":"direct",f__formatted?"formatted":"unformatted",
+ f__external?"external":"internal");
+ sig_die(" IO", 1);
+}
+/*initialization routine*/
+ VOID
+f_init(Void)
+{ unit *p;
+
+ f__init=1;
+ p= &f__units[0];
+ p->ufd=stderr;
+ p->useek=f__canseek(stderr);
+ p->ufmt=1;
+ p->uwrt=1;
+ p = &f__units[5];
+ p->ufd=stdin;
+ p->useek=f__canseek(stdin);
+ p->ufmt=1;
+ p->uwrt=0;
+ p= &f__units[6];
+ p->ufd=stdout;
+ p->useek=f__canseek(stdout);
+ p->ufmt=1;
+ p->uwrt=1;
+}
+
+ int
+#ifdef KR_headers
+f__nowreading(x) unit *x;
+#else
+f__nowreading(unit *x)
+#endif
+{
+ OFF_T loc;
+ int ufmt, urw;
+ extern char *f__r_mode[], *f__w_mode[];
+
+ if (x->urw & 1)
+ goto done;
+ if (!x->ufnm)
+ goto cantread;
+ ufmt = x->url ? 0 : x->ufmt;
+ loc = FTELL(x->ufd);
+ urw = 3;
+ if (!FREOPEN(x->ufnm, f__w_mode[ufmt|2], x->ufd)) {
+ urw = 1;
+ if(!FREOPEN(x->ufnm, f__r_mode[ufmt], x->ufd)) {
+ cantread:
+ errno = 126;
+ return 1;
+ }
+ }
+ FSEEK(x->ufd,loc,SEEK_SET);
+ x->urw = urw;
+ done:
+ x->uwrt = 0;
+ return 0;
+}
+
+ int
+#ifdef KR_headers
+f__nowwriting(x) unit *x;
+#else
+f__nowwriting(unit *x)
+#endif
+{
+ OFF_T loc;
+ int ufmt;
+ extern char *f__w_mode[];
+
+ if (x->urw & 2) {
+ if (x->urw & 1)
+ FSEEK(x->ufd, (OFF_T)0, SEEK_CUR);
+ goto done;
+ }
+ if (!x->ufnm)
+ goto cantwrite;
+ ufmt = x->url ? 0 : x->ufmt;
+ if (x->uwrt == 3) { /* just did write, rewind */
+ if (!(f__cf = x->ufd =
+ FREOPEN(x->ufnm,f__w_mode[ufmt],x->ufd)))
+ goto cantwrite;
+ x->urw = 2;
+ }
+ else {
+ loc=FTELL(x->ufd);
+ if (!(f__cf = x->ufd =
+ FREOPEN(x->ufnm, f__w_mode[ufmt | 2], x->ufd)))
+ {
+ x->ufd = NULL;
+ cantwrite:
+ errno = 127;
+ return(1);
+ }
+ x->urw = 3;
+ FSEEK(x->ufd,loc,SEEK_SET);
+ }
+ done:
+ x->uwrt = 1;
+ return 0;
+}
+
+ int
+#ifdef KR_headers
+err__fl(f, m, s) int f, m; char *s;
+#else
+err__fl(int f, int m, const char *s)
+#endif
+{
+ if (!f)
+ f__fatal(m, s);
+ if (f__doend)
+ (*f__doend)();
+ return errno = m;
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/etime_.c b/F2CLIBS/libf2c/etime_.c
new file mode 100644
index 0000000..2d9a36d
--- /dev/null
+++ b/F2CLIBS/libf2c/etime_.c
@@ -0,0 +1,57 @@
+#include "time.h"
+
+#ifdef MSDOS
+#undef USE_CLOCK
+#define USE_CLOCK
+#endif
+
+#ifndef REAL
+#define REAL double
+#endif
+
+#ifndef USE_CLOCK
+#define _INCLUDE_POSIX_SOURCE /* for HP-UX */
+#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */
+#include "sys/types.h"
+#include "sys/times.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+#endif
+
+#undef Hz
+#ifdef CLK_TCK
+#define Hz CLK_TCK
+#else
+#ifdef HZ
+#define Hz HZ
+#else
+#define Hz 60
+#endif
+#endif
+
+ REAL
+#ifdef KR_headers
+etime_(tarray) float *tarray;
+#else
+etime_(float *tarray)
+#endif
+{
+#ifdef USE_CLOCK
+#ifndef CLOCKS_PER_SECOND
+#define CLOCKS_PER_SECOND Hz
+#endif
+ double t = clock();
+ tarray[1] = 0;
+ return tarray[0] = t / CLOCKS_PER_SECOND;
+#else
+ struct tms t;
+
+ times(&t);
+ return (tarray[0] = (double)t.tms_utime/Hz)
+ + (tarray[1] = (double)t.tms_stime/Hz);
+#endif
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/exit_.c b/F2CLIBS/libf2c/exit_.c
new file mode 100644
index 0000000..08e9d07
--- /dev/null
+++ b/F2CLIBS/libf2c/exit_.c
@@ -0,0 +1,43 @@
+/* This gives the effect of
+
+ subroutine exit(rc)
+ integer*4 rc
+ stop
+ end
+
+ * with the added side effect of supplying rc as the program's exit code.
+ */
+
+#include "f2c.h"
+#undef abs
+#undef min
+#undef max
+#ifndef KR_headers
+#include "stdlib.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern void f_exit(void);
+#endif
+
+ void
+#ifdef KR_headers
+exit_(rc) integer *rc;
+#else
+exit_(integer *rc)
+#endif
+{
+#ifdef NO_ONEXIT
+ f_exit();
+#endif
+ exit(*rc);
+ }
+#ifdef __cplusplus
+}
+#endif
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/f2c.h b/F2CLIBS/libf2c/f2c.h
new file mode 100644
index 0000000..b94ee7c
--- /dev/null
+++ b/F2CLIBS/libf2c/f2c.h
@@ -0,0 +1,223 @@
+/* f2c.h -- Standard Fortran to C header file */
+
+/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
+
+ - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+typedef long int integer;
+typedef unsigned long int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+typedef long int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+#ifdef INTEGER_STAR_8 /* Adjust for integer*8. */
+typedef long long longint; /* system-dependent */
+typedef unsigned long long ulongint; /* system-dependent */
+#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b)))
+#define qbit_set(a,b) ((a) | ((ulongint)1 << (b)))
+#endif
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+#ifdef f2c_i2
+/* for -i2 */
+typedef short flag;
+typedef short ftnlen;
+typedef short ftnint;
+#else
+typedef long int flag;
+typedef long int ftnlen;
+typedef long int ftnint;
+#endif
+
+/*external read, write*/
+typedef struct
+{ flag cierr;
+ ftnint ciunit;
+ flag ciend;
+ char *cifmt;
+ ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{ flag icierr;
+ char *iciunit;
+ flag iciend;
+ char *icifmt;
+ ftnint icirlen;
+ ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{ flag oerr;
+ ftnint ounit;
+ char *ofnm;
+ ftnlen ofnmlen;
+ char *osta;
+ char *oacc;
+ char *ofm;
+ ftnint orl;
+ char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{ flag cerr;
+ ftnint cunit;
+ char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{ flag aerr;
+ ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{ flag inerr;
+ ftnint inunit;
+ char *infile;
+ ftnlen infilen;
+ ftnint *inex; /*parameters in standard's order*/
+ ftnint *inopen;
+ ftnint *innum;
+ ftnint *innamed;
+ char *inname;
+ ftnlen innamlen;
+ char *inacc;
+ ftnlen inacclen;
+ char *inseq;
+ ftnlen inseqlen;
+ char *indir;
+ ftnlen indirlen;
+ char *infmt;
+ ftnlen infmtlen;
+ char *inform;
+ ftnint informlen;
+ char *inunf;
+ ftnlen inunflen;
+ ftnint *inrecl;
+ ftnint *innrec;
+ char *inblank;
+ ftnlen inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype { /* for multiple entry points */
+ integer1 g;
+ shortint h;
+ integer i;
+ /* longint j; */
+ real r;
+ doublereal d;
+ complex c;
+ doublecomplex z;
+ };
+
+typedef union Multitype Multitype;
+
+/*typedef long int Long;*/ /* No longer used; formerly in Namelist */
+
+struct Vardesc { /* for Namelist */
+ char *name;
+ char *addr;
+ ftnlen *dims;
+ int type;
+ };
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+ char *name;
+ Vardesc **vars;
+ int nvars;
+ };
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (doublereal)abs(x)
+#define min(a,b) ((a) <= (b) ? (a) : (b))
+#define max(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (doublereal)min(a,b)
+#define dmax(a,b) (doublereal)max(a,b)
+#define bit_test(a,b) ((a) >> (b) & 1)
+#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b) ((a) | ((uinteger)1 << (b)))
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef int /* Unknown procedure type */ (*U_fp)(...);
+typedef shortint (*J_fp)(...);
+typedef integer (*I_fp)(...);
+typedef real (*R_fp)(...);
+typedef doublereal (*D_fp)(...), (*E_fp)(...);
+typedef /* Complex */ VOID (*C_fp)(...);
+typedef /* Double Complex */ VOID (*Z_fp)(...);
+typedef logical (*L_fp)(...);
+typedef shortlogical (*K_fp)(...);
+typedef /* Character */ VOID (*H_fp)(...);
+typedef /* Subroutine */ int (*S_fp)(...);
+#else
+typedef int /* Unknown procedure type */ (*U_fp)();
+typedef shortint (*J_fp)();
+typedef integer (*I_fp)();
+typedef real (*R_fp)();
+typedef doublereal (*D_fp)(), (*E_fp)();
+typedef /* Complex */ VOID (*C_fp)();
+typedef /* Double Complex */ VOID (*Z_fp)();
+typedef logical (*L_fp)();
+typedef shortlogical (*K_fp)();
+typedef /* Character */ VOID (*H_fp)();
+typedef /* Subroutine */ int (*S_fp)();
+#endif
+/* E_fp is for real functions when -R is not specified */
+typedef VOID C_f; /* complex function */
+typedef VOID H_f; /* character function */
+typedef VOID Z_f; /* double complex function */
+typedef doublereal E_f; /* real function with -R not specified */
+
+/* undef any lower-case symbols that your C compiler predefines, e.g.: */
+
+#ifndef Skip_f2c_Undefs
+#undef cray
+#undef gcos
+#undef mc68010
+#undef mc68020
+#undef mips
+#undef pdp11
+#undef sgi
+#undef sparc
+#undef sun
+#undef sun2
+#undef sun3
+#undef sun4
+#undef u370
+#undef u3b
+#undef u3b2
+#undef u3b5
+#undef unix
+#undef vax
+#endif
+#endif
diff --git a/F2CLIBS/libf2c/f2ch.add b/F2CLIBS/libf2c/f2ch.add
new file mode 100644
index 0000000..a2acc17
--- /dev/null
+++ b/F2CLIBS/libf2c/f2ch.add
@@ -0,0 +1,162 @@
+/* If you are using a C++ compiler, append the following to f2c.h
+ for compiling libF77 and libI77. */
+
+#ifdef __cplusplus
+extern "C" {
+extern int abort_(void);
+extern double c_abs(complex *);
+extern void c_cos(complex *, complex *);
+extern void c_div(complex *, complex *, complex *);
+extern void c_exp(complex *, complex *);
+extern void c_log(complex *, complex *);
+extern void c_sin(complex *, complex *);
+extern void c_sqrt(complex *, complex *);
+extern double d_abs(double *);
+extern double d_acos(double *);
+extern double d_asin(double *);
+extern double d_atan(double *);
+extern double d_atn2(double *, double *);
+extern void d_cnjg(doublecomplex *, doublecomplex *);
+extern double d_cos(double *);
+extern double d_cosh(double *);
+extern double d_dim(double *, double *);
+extern double d_exp(double *);
+extern double d_imag(doublecomplex *);
+extern double d_int(double *);
+extern double d_lg10(double *);
+extern double d_log(double *);
+extern double d_mod(double *, double *);
+extern double d_nint(double *);
+extern double d_prod(float *, float *);
+extern double d_sign(double *, double *);
+extern double d_sin(double *);
+extern double d_sinh(double *);
+extern double d_sqrt(double *);
+extern double d_tan(double *);
+extern double d_tanh(double *);
+extern double derf_(double *);
+extern double derfc_(double *);
+extern integer do_fio(ftnint *, char *, ftnlen);
+extern integer do_lio(ftnint *, ftnint *, char *, ftnlen);
+extern integer do_uio(ftnint *, char *, ftnlen);
+extern integer e_rdfe(void);
+extern integer e_rdue(void);
+extern integer e_rsfe(void);
+extern integer e_rsfi(void);
+extern integer e_rsle(void);
+extern integer e_rsli(void);
+extern integer e_rsue(void);
+extern integer e_wdfe(void);
+extern integer e_wdue(void);
+extern integer e_wsfe(void);
+extern integer e_wsfi(void);
+extern integer e_wsle(void);
+extern integer e_wsli(void);
+extern integer e_wsue(void);
+extern int ef1asc_(ftnint *, ftnlen *, ftnint *, ftnlen *);
+extern integer ef1cmc_(ftnint *, ftnlen *, ftnint *, ftnlen *);
+extern double erf(double);
+extern double erf_(float *);
+extern double erfc(double);
+extern double erfc_(float *);
+extern integer f_back(alist *);
+extern integer f_clos(cllist *);
+extern integer f_end(alist *);
+extern void f_exit(void);
+extern integer f_inqu(inlist *);
+extern integer f_open(olist *);
+extern integer f_rew(alist *);
+extern int flush_(void);
+extern void getarg_(integer *, char *, ftnlen);
+extern void getenv_(char *, char *, ftnlen, ftnlen);
+extern short h_abs(short *);
+extern short h_dim(short *, short *);
+extern short h_dnnt(double *);
+extern short h_indx(char *, char *, ftnlen, ftnlen);
+extern short h_len(char *, ftnlen);
+extern short h_mod(short *, short *);
+extern short h_nint(float *);
+extern short h_sign(short *, short *);
+extern short hl_ge(char *, char *, ftnlen, ftnlen);
+extern short hl_gt(char *, char *, ftnlen, ftnlen);
+extern short hl_le(char *, char *, ftnlen, ftnlen);
+extern short hl_lt(char *, char *, ftnlen, ftnlen);
+extern integer i_abs(integer *);
+extern integer i_dim(integer *, integer *);
+extern integer i_dnnt(double *);
+extern integer i_indx(char *, char *, ftnlen, ftnlen);
+extern integer i_len(char *, ftnlen);
+extern integer i_mod(integer *, integer *);
+extern integer i_nint(float *);
+extern integer i_sign(integer *, integer *);
+extern integer iargc_(void);
+extern ftnlen l_ge(char *, char *, ftnlen, ftnlen);
+extern ftnlen l_gt(char *, char *, ftnlen, ftnlen);
+extern ftnlen l_le(char *, char *, ftnlen, ftnlen);
+extern ftnlen l_lt(char *, char *, ftnlen, ftnlen);
+extern void pow_ci(complex *, complex *, integer *);
+extern double pow_dd(double *, double *);
+extern double pow_di(double *, integer *);
+extern short pow_hh(short *, shortint *);
+extern integer pow_ii(integer *, integer *);
+extern double pow_ri(float *, integer *);
+extern void pow_zi(doublecomplex *, doublecomplex *, integer *);
+extern void pow_zz(doublecomplex *, doublecomplex *, doublecomplex *);
+extern double r_abs(float *);
+extern double r_acos(float *);
+extern double r_asin(float *);
+extern double r_atan(float *);
+extern double r_atn2(float *, float *);
+extern void r_cnjg(complex *, complex *);
+extern double r_cos(float *);
+extern double r_cosh(float *);
+extern double r_dim(float *, float *);
+extern double r_exp(float *);
+extern double r_imag(complex *);
+extern double r_int(float *);
+extern double r_lg10(float *);
+extern double r_log(float *);
+extern double r_mod(float *, float *);
+extern double r_nint(float *);
+extern double r_sign(float *, float *);
+extern double r_sin(float *);
+extern double r_sinh(float *);
+extern double r_sqrt(float *);
+extern double r_tan(float *);
+extern double r_tanh(float *);
+extern void s_cat(char *, char **, integer *, integer *, ftnlen);
+extern integer s_cmp(char *, char *, ftnlen, ftnlen);
+extern void s_copy(char *, char *, ftnlen, ftnlen);
+extern int s_paus(char *, ftnlen);
+extern integer s_rdfe(cilist *);
+extern integer s_rdue(cilist *);
+extern integer s_rnge(char *, integer, char *, integer);
+extern integer s_rsfe(cilist *);
+extern integer s_rsfi(icilist *);
+extern integer s_rsle(cilist *);
+extern integer s_rsli(icilist *);
+extern integer s_rsne(cilist *);
+extern integer s_rsni(icilist *);
+extern integer s_rsue(cilist *);
+extern int s_stop(char *, ftnlen);
+extern integer s_wdfe(cilist *);
+extern integer s_wdue(cilist *);
+extern integer s_wsfe(cilist *);
+extern integer s_wsfi(icilist *);
+extern integer s_wsle(cilist *);
+extern integer s_wsli(icilist *);
+extern integer s_wsne(cilist *);
+extern integer s_wsni(icilist *);
+extern integer s_wsue(cilist *);
+extern void sig_die(char *, int);
+extern integer signal_(integer *, void (*)(int));
+extern integer system_(char *, ftnlen);
+extern double z_abs(doublecomplex *);
+extern void z_cos(doublecomplex *, doublecomplex *);
+extern void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+extern void z_exp(doublecomplex *, doublecomplex *);
+extern void z_log(doublecomplex *, doublecomplex *);
+extern void z_sin(doublecomplex *, doublecomplex *);
+extern void z_sqrt(doublecomplex *, doublecomplex *);
+ }
+#endif
diff --git a/F2CLIBS/libf2c/f77_aloc.c b/F2CLIBS/libf2c/f77_aloc.c
new file mode 100644
index 0000000..f536099
--- /dev/null
+++ b/F2CLIBS/libf2c/f77_aloc.c
@@ -0,0 +1,44 @@
+#include "f2c.h"
+#undef abs
+#undef min
+#undef max
+#include "stdio.h"
+
+static integer memfailure = 3;
+
+#ifdef KR_headers
+extern char *malloc();
+extern void exit_();
+
+ char *
+F77_aloc(Len, whence) integer Len; char *whence;
+#else
+#include "stdlib.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern void exit_(integer*);
+#ifdef __cplusplus
+ }
+#endif
+
+ char *
+F77_aloc(integer Len, const char *whence)
+#endif
+{
+ char *rv;
+ unsigned int uLen = (unsigned int) Len; /* for K&R C */
+
+ if (!(rv = (char*)malloc(uLen))) {
+ fprintf(stderr, "malloc(%u) failure in %s\n",
+ uLen, whence);
+ exit_(&memfailure);
+ }
+ return rv;
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/f77vers.c b/F2CLIBS/libf2c/f77vers.c
new file mode 100644
index 0000000..70cd6fe
--- /dev/null
+++ b/F2CLIBS/libf2c/f77vers.c
@@ -0,0 +1,97 @@
+ char
+_libf77_version_f2c[] = "\n@(#) LIBF77 VERSION (f2c) 20051004\n";
+
+/*
+2.00 11 June 1980. File version.c added to library.
+2.01 31 May 1988. s_paus() flushes stderr; names of hl_* fixed
+ [ d]erf[c ] added
+ 8 Aug. 1989: #ifdefs for f2c -i2 added to s_cat.c
+ 29 Nov. 1989: s_cmp returns long (for f2c)
+ 30 Nov. 1989: arg types from f2c.h
+ 12 Dec. 1989: s_rnge allows long names
+ 19 Dec. 1989: getenv_ allows unsorted environment
+ 28 Mar. 1990: add exit(0) to end of main()
+ 2 Oct. 1990: test signal(...) == SIG_IGN rather than & 01 in main
+ 17 Oct. 1990: abort() calls changed to sig_die(...,1)
+ 22 Oct. 1990: separate sig_die from main
+ 25 Apr. 1991: minor, theoretically invisible tweaks to s_cat, sig_die
+ 31 May 1991: make system_ return status
+ 18 Dec. 1991: change long to ftnlen (for -i2) many places
+ 28 Feb. 1992: repair z_sqrt.c (scribbled on input, gave wrong answer)
+ 18 July 1992: for n < 0, repair handling of 0**n in pow_[dr]i.c
+ and m**n in pow_hh.c and pow_ii.c;
+ catch SIGTRAP in main() for error msg before abort
+ 23 July 1992: switch to ANSI prototypes unless KR_headers is #defined
+ 23 Oct. 1992: fix botch in signal_.c (erroneous deref of 2nd arg);
+ change Cabs to f__cabs.
+ 12 March 1993: various tweaks for C++
+ 2 June 1994: adjust so abnormal terminations invoke f_exit just once
+ 16 Sept. 1994: s_cmp: treat characters as unsigned in comparisons.
+ 19 Sept. 1994: s_paus: flush after end of PAUSE; add -DMSDOS
+ 12 Jan. 1995: pow_[dhiqrz][hiq]: adjust x**i to work on machines
+ that sign-extend right shifts when i is the most
+ negative integer.
+ 26 Jan. 1995: adjust s_cat.c, s_copy.c to permit the left-hand side
+ of character assignments to appear on the right-hand
+ side (unless compiled with -DNO_OVERWRITE).
+ 27 Jan. 1995: minor tweak to s_copy.c: copy forward whenever
+ possible (for better cache behavior).
+ 30 May 1995: added subroutine exit(rc) integer rc. Version not changed.
+ 29 Aug. 1995: add F77_aloc.c; use it in s_cat.c and system_.c.
+ 6 Sept. 1995: fix return type of system_ under -DKR_headers.
+ 19 Dec. 1995: s_cat.c: fix bug when 2nd or later arg overlaps lhs.
+ 19 Mar. 1996: s_cat.c: supply missing break after overlap detection.
+ 13 May 1996: add [lq]bitbits.c and [lq]bitshft.c (f90 bit intrinsics).
+ 19 June 1996: add casts to unsigned in [lq]bitshft.c.
+ 26 Feb. 1997: adjust functions with a complex output argument
+ to permit aliasing it with input arguments.
+ (For now, at least, this is just for possible
+ benefit of g77.)
+ 4 April 1997: [cz]_div.c: tweaks invisible on most systems (that may
+ affect systems using gratuitous extra precision).
+ 19 Sept. 1997: [de]time_.c (Unix systems only): change return
+ type to double.
+ 2 May 1999: getenv_.c: omit environ in favor of getenv().
+ c_cos.c, c_exp.c, c_sin.c, d_cnjg.c, r_cnjg.c,
+ z_cos.c, z_exp.c, z_log.c, z_sin.c: cope fully with
+ overlapping arguments caused by equivalence.
+ 3 May 1999: "invisible" tweaks to omit compiler warnings in
+ abort_.c, ef1asc_.c, s_rnge.c, s_stop.c.
+
+ 7 Sept. 1999: [cz]_div.c: arrange for compilation under
+ -DIEEE_COMPLEX_DIVIDE to make these routines
+ avoid calling sig_die when the denominator
+ vanishes; instead, they return pairs of NaNs
+ or Infinities, depending whether the numerator
+ also vanishes or not. VERSION not changed.
+ 15 Nov. 1999: s_rnge.c: add casts for the case of
+ sizeof(ftnint) == sizeof(int) < sizeof(long).
+ 10 March 2000: z_log.c: improve accuracy of Real(log(z)) for, e.g.,
+ z near (+-1,eps) with |eps| small. For the old
+ evaluation, compile with -DPre20000310 .
+ 20 April 2000: s_cat.c: tweak argument types to accord with
+ calls by f2c when ftnint and ftnlen are of
+ different sizes (different numbers of bits).
+ 4 July 2000: adjustments to permit compilation by C++ compilers;
+ VERSION string remains unchanged.
+ 29 Sept. 2000: dtime_.c, etime_.c: use floating-point divide.
+ dtime_.d, erf_.c, erfc_.c, etime.c: for use with
+ "f2c -R", compile with -DREAL=float.
+ 23 June 2001: add uninit.c; [fi]77vers.c: make version strings
+ visible as extern char _lib[fi]77_version_f2c[].
+ 5 July 2001: modify uninit.c for __mc68k__ under Linux.
+ 16 Nov. 2001: uninit.c: Linux Power PC logic supplied by Alan Bain.
+ 18 Jan. 2002: fix glitches in qbit_bits(): wrong return type,
+ missing ~ on y in return value.
+ 14 March 2002: z_log.c: add code to cope with buggy compilers
+ (e.g., some versions of gcc under -O2 or -O3)
+ that do floating-point comparisons against values
+ computed into extended-precision registers on some
+ systems (such as Intel IA32 systems). Compile with
+ -DNO_DOUBLE_EXTENDED to omit the new logic.
+ 4 Oct. 2002: uninit.c: on IRIX systems, omit use of shell variables.
+ 10 Oct 2005: uninit.c: on IA32 Linux systems, leave the rounding
+ precision alone rather than forcing it to 53 bits;
+ compile with -DUNINIT_F2C_PRECISION_53 to get the
+ former behavior.
+*/
diff --git a/F2CLIBS/libf2c/fio.h b/F2CLIBS/libf2c/fio.h
new file mode 100644
index 0000000..ebf7696
--- /dev/null
+++ b/F2CLIBS/libf2c/fio.h
@@ -0,0 +1,141 @@
+#ifndef SYSDEP_H_INCLUDED
+#include "sysdep1.h"
+#endif
+#include "stdio.h"
+#include "errno.h"
+#ifndef NULL
+/* ANSI C */
+#include "stddef.h"
+#endif
+
+#ifndef SEEK_SET
+#define SEEK_SET 0
+#define SEEK_CUR 1
+#define SEEK_END 2
+#endif
+
+#ifndef FOPEN
+#define FOPEN fopen
+#endif
+
+#ifndef FREOPEN
+#define FREOPEN freopen
+#endif
+
+#ifndef FSEEK
+#define FSEEK fseek
+#endif
+
+#ifndef FSTAT
+#define FSTAT fstat
+#endif
+
+#ifndef FTELL
+#define FTELL ftell
+#endif
+
+#ifndef OFF_T
+#define OFF_T long
+#endif
+
+#ifndef STAT_ST
+#define STAT_ST stat
+#endif
+
+#ifndef STAT
+#define STAT stat
+#endif
+
+#ifdef MSDOS
+#ifndef NON_UNIX_STDIO
+#define NON_UNIX_STDIO
+#endif
+#endif
+
+#ifdef UIOLEN_int
+typedef int uiolen;
+#else
+typedef long uiolen;
+#endif
+
+/*units*/
+typedef struct
+{ FILE *ufd; /*0=unconnected*/
+ char *ufnm;
+#ifndef MSDOS
+ long uinode;
+ int udev;
+#endif
+ int url; /*0=sequential*/
+ flag useek; /*true=can backspace, use dir, ...*/
+ flag ufmt;
+ flag urw; /* (1 for can read) | (2 for can write) */
+ flag ublnk;
+ flag uend;
+ flag uwrt; /*last io was write*/
+ flag uscrtch;
+} unit;
+
+#undef Void
+#ifdef KR_headers
+#define Void /*void*/
+extern int (*f__getn)(); /* for formatted input */
+extern void (*f__putn)(); /* for formatted output */
+extern void x_putc();
+extern long f__inode();
+extern VOID sig_die();
+extern int (*f__donewrec)(), t_putc(), x_wSL();
+extern int c_sfe(), err__fl(), xrd_SL(), f__putbuf();
+#else
+#define Void void
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern int (*f__getn)(void); /* for formatted input */
+extern void (*f__putn)(int); /* for formatted output */
+extern void x_putc(int);
+extern long f__inode(char*,int*);
+extern void sig_die(const char*,int);
+extern void f__fatal(int, const char*);
+extern int t_runc(alist*);
+extern int f__nowreading(unit*), f__nowwriting(unit*);
+extern int fk_open(int,int,ftnint);
+extern int en_fio(void);
+extern void f_init(void);
+extern int (*f__donewrec)(void), t_putc(int), x_wSL(void);
+extern void b_char(const char*,char*,ftnlen), g_char(const char*,ftnlen,char*);
+extern int c_sfe(cilist*), z_rnew(void);
+extern int err__fl(int,int,const char*);
+extern int xrd_SL(void);
+extern int f__putbuf(int);
+#endif
+extern flag f__init;
+extern cilist *f__elist; /*active external io list*/
+extern flag f__reading,f__external,f__sequential,f__formatted;
+extern int (*f__doend)(Void);
+extern FILE *f__cf; /*current file*/
+extern unit *f__curunit; /*current unit*/
+extern unit f__units[];
+#define err(f,m,s) {if(f) errno= m; else f__fatal(m,s); return(m);}
+#define errfl(f,m,s) return err__fl((int)f,m,s)
+
+/*Table sizes*/
+#define MXUNIT 100
+
+extern int f__recpos; /*position in current record*/
+extern OFF_T f__cursor; /* offset to move to */
+extern OFF_T f__hiwater; /* so TL doesn't confuse us */
+#ifdef __cplusplus
+ }
+#endif
+
+#define WRITE 1
+#define READ 2
+#define SEQ 3
+#define DIR 4
+#define FMT 5
+#define UNF 6
+#define EXT 7
+#define INT 8
+
+#define buf_end(x) (x->_flag & _IONBF ? x->_ptr : x->_base + BUFSIZ)
diff --git a/F2CLIBS/libf2c/fmt.c b/F2CLIBS/libf2c/fmt.c
new file mode 100644
index 0000000..286c98f
--- /dev/null
+++ b/F2CLIBS/libf2c/fmt.c
@@ -0,0 +1,530 @@
+#include "f2c.h"
+#include "fio.h"
+#include "fmt.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+#define skip(s) while(*s==' ') s++
+#ifdef interdata
+#define SYLMX 300
+#endif
+#ifdef pdp11
+#define SYLMX 300
+#endif
+#ifdef vax
+#define SYLMX 300
+#endif
+#ifndef SYLMX
+#define SYLMX 300
+#endif
+#define GLITCH '\2'
+ /* special quote character for stu */
+extern flag f__cblank,f__cplus; /*blanks in I and compulsory plus*/
+static struct syl f__syl[SYLMX];
+int f__parenlvl,f__pc,f__revloc;
+#ifdef KR_headers
+#define Const /*nothing*/
+#else
+#define Const const
+#endif
+
+ static
+#ifdef KR_headers
+char *ap_end(s) char *s;
+#else
+const char *ap_end(const char *s)
+#endif
+{ char quote;
+ quote= *s++;
+ for(;*s;s++)
+ { if(*s!=quote) continue;
+ if(*++s!=quote) return(s);
+ }
+ if(f__elist->cierr) {
+ errno = 100;
+ return(NULL);
+ }
+ f__fatal(100, "bad string");
+ /*NOTREACHED*/ return 0;
+}
+ static int
+#ifdef KR_headers
+op_gen(a,b,c,d)
+#else
+op_gen(int a, int b, int c, int d)
+#endif
+{ struct syl *p= &f__syl[f__pc];
+ if(f__pc>=SYLMX)
+ { fprintf(stderr,"format too complicated:\n");
+ sig_die(f__fmtbuf, 1);
+ }
+ p->op=a;
+ p->p1=b;
+ p->p2.i[0]=c;
+ p->p2.i[1]=d;
+ return(f__pc++);
+}
+#ifdef KR_headers
+static char *f_list();
+static char *gt_num(s,n,n1) char *s; int *n, n1;
+#else
+static const char *f_list(const char*);
+static const char *gt_num(const char *s, int *n, int n1)
+#endif
+{ int m=0,f__cnt=0;
+ char c;
+ for(c= *s;;c = *s)
+ { if(c==' ')
+ { s++;
+ continue;
+ }
+ if(c>'9' || c<'0') break;
+ m=10*m+c-'0';
+ f__cnt++;
+ s++;
+ }
+ if(f__cnt==0) {
+ if (!n1)
+ s = 0;
+ *n=n1;
+ }
+ else *n=m;
+ return(s);
+}
+
+ static
+#ifdef KR_headers
+char *f_s(s,curloc) char *s;
+#else
+const char *f_s(const char *s, int curloc)
+#endif
+{
+ skip(s);
+ if(*s++!='(')
+ {
+ return(NULL);
+ }
+ if(f__parenlvl++ ==1) f__revloc=curloc;
+ if(op_gen(RET1,curloc,0,0)<0 ||
+ (s=f_list(s))==NULL)
+ {
+ return(NULL);
+ }
+ skip(s);
+ return(s);
+}
+
+ static int
+#ifdef KR_headers
+ne_d(s,p) char *s,**p;
+#else
+ne_d(const char *s, const char **p)
+#endif
+{ int n,x,sign=0;
+ struct syl *sp;
+ switch(*s)
+ {
+ default:
+ return(0);
+ case ':': (void) op_gen(COLON,0,0,0); break;
+ case '$':
+ (void) op_gen(NONL, 0, 0, 0); break;
+ case 'B':
+ case 'b':
+ if(*++s=='z' || *s == 'Z') (void) op_gen(BZ,0,0,0);
+ else (void) op_gen(BN,0,0,0);
+ break;
+ case 'S':
+ case 's':
+ if(*(s+1)=='s' || *(s+1) == 'S')
+ { x=SS;
+ s++;
+ }
+ else if(*(s+1)=='p' || *(s+1) == 'P')
+ { x=SP;
+ s++;
+ }
+ else x=S;
+ (void) op_gen(x,0,0,0);
+ break;
+ case '/': (void) op_gen(SLASH,0,0,0); break;
+ case '-': sign=1;
+ case '+': s++; /*OUTRAGEOUS CODING TRICK*/
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ if (!(s=gt_num(s,&n,0))) {
+ bad: *p = 0;
+ return 1;
+ }
+ switch(*s)
+ {
+ default:
+ return(0);
+ case 'P':
+ case 'p': if(sign) n= -n; (void) op_gen(P,n,0,0); break;
+ case 'X':
+ case 'x': (void) op_gen(X,n,0,0); break;
+ case 'H':
+ case 'h':
+ sp = &f__syl[op_gen(H,n,0,0)];
+ sp->p2.s = (char*)s + 1;
+ s+=n;
+ break;
+ }
+ break;
+ case GLITCH:
+ case '"':
+ case '\'':
+ sp = &f__syl[op_gen(APOS,0,0,0)];
+ sp->p2.s = (char*)s;
+ if((*p = ap_end(s)) == NULL)
+ return(0);
+ return(1);
+ case 'T':
+ case 't':
+ if(*(s+1)=='l' || *(s+1) == 'L')
+ { x=TL;
+ s++;
+ }
+ else if(*(s+1)=='r'|| *(s+1) == 'R')
+ { x=TR;
+ s++;
+ }
+ else x=T;
+ if (!(s=gt_num(s+1,&n,0)))
+ goto bad;
+ s--;
+ (void) op_gen(x,n,0,0);
+ break;
+ case 'X':
+ case 'x': (void) op_gen(X,1,0,0); break;
+ case 'P':
+ case 'p': (void) op_gen(P,1,0,0); break;
+ }
+ s++;
+ *p=s;
+ return(1);
+}
+
+ static int
+#ifdef KR_headers
+e_d(s,p) char *s,**p;
+#else
+e_d(const char *s, const char **p)
+#endif
+{ int i,im,n,w,d,e,found=0,x=0;
+ Const char *sv=s;
+ s=gt_num(s,&n,1);
+ (void) op_gen(STACK,n,0,0);
+ switch(*s++)
+ {
+ default: break;
+ case 'E':
+ case 'e': x=1;
+ case 'G':
+ case 'g':
+ found=1;
+ if (!(s=gt_num(s,&w,0))) {
+ bad:
+ *p = 0;
+ return 1;
+ }
+ if(w==0) break;
+ if(*s=='.') {
+ if (!(s=gt_num(s+1,&d,0)))
+ goto bad;
+ }
+ else d=0;
+ if(*s!='E' && *s != 'e')
+ (void) op_gen(x==1?E:G,w,d,0); /* default is Ew.dE2 */
+ else {
+ if (!(s=gt_num(s+1,&e,0)))
+ goto bad;
+ (void) op_gen(x==1?EE:GE,w,d,e);
+ }
+ break;
+ case 'O':
+ case 'o':
+ i = O;
+ im = OM;
+ goto finish_I;
+ case 'Z':
+ case 'z':
+ i = Z;
+ im = ZM;
+ goto finish_I;
+ case 'L':
+ case 'l':
+ found=1;
+ if (!(s=gt_num(s,&w,0)))
+ goto bad;
+ if(w==0) break;
+ (void) op_gen(L,w,0,0);
+ break;
+ case 'A':
+ case 'a':
+ found=1;
+ skip(s);
+ if(*s>='0' && *s<='9')
+ { s=gt_num(s,&w,1);
+ if(w==0) break;
+ (void) op_gen(AW,w,0,0);
+ break;
+ }
+ (void) op_gen(A,0,0,0);
+ break;
+ case 'F':
+ case 'f':
+ if (!(s=gt_num(s,&w,0)))
+ goto bad;
+ found=1;
+ if(w==0) break;
+ if(*s=='.') {
+ if (!(s=gt_num(s+1,&d,0)))
+ goto bad;
+ }
+ else d=0;
+ (void) op_gen(F,w,d,0);
+ break;
+ case 'D':
+ case 'd':
+ found=1;
+ if (!(s=gt_num(s,&w,0)))
+ goto bad;
+ if(w==0) break;
+ if(*s=='.') {
+ if (!(s=gt_num(s+1,&d,0)))
+ goto bad;
+ }
+ else d=0;
+ (void) op_gen(D,w,d,0);
+ break;
+ case 'I':
+ case 'i':
+ i = I;
+ im = IM;
+ finish_I:
+ if (!(s=gt_num(s,&w,0)))
+ goto bad;
+ found=1;
+ if(w==0) break;
+ if(*s!='.')
+ { (void) op_gen(i,w,0,0);
+ break;
+ }
+ if (!(s=gt_num(s+1,&d,0)))
+ goto bad;
+ (void) op_gen(im,w,d,0);
+ break;
+ }
+ if(found==0)
+ { f__pc--; /*unSTACK*/
+ *p=sv;
+ return(0);
+ }
+ *p=s;
+ return(1);
+}
+ static
+#ifdef KR_headers
+char *i_tem(s) char *s;
+#else
+const char *i_tem(const char *s)
+#endif
+{ const char *t;
+ int n,curloc;
+ if(*s==')') return(s);
+ if(ne_d(s,&t)) return(t);
+ if(e_d(s,&t)) return(t);
+ s=gt_num(s,&n,1);
+ if((curloc=op_gen(STACK,n,0,0))<0) return(NULL);
+ return(f_s(s,curloc));
+}
+
+ static
+#ifdef KR_headers
+char *f_list(s) char *s;
+#else
+const char *f_list(const char *s)
+#endif
+{
+ for(;*s!=0;)
+ { skip(s);
+ if((s=i_tem(s))==NULL) return(NULL);
+ skip(s);
+ if(*s==',') s++;
+ else if(*s==')')
+ { if(--f__parenlvl==0)
+ {
+ (void) op_gen(REVERT,f__revloc,0,0);
+ return(++s);
+ }
+ (void) op_gen(GOTO,0,0,0);
+ return(++s);
+ }
+ }
+ return(NULL);
+}
+
+ int
+#ifdef KR_headers
+pars_f(s) char *s;
+#else
+pars_f(const char *s)
+#endif
+{
+ f__parenlvl=f__revloc=f__pc=0;
+ if(f_s(s,0) == NULL)
+ {
+ return(-1);
+ }
+ return(0);
+}
+#define STKSZ 10
+int f__cnt[STKSZ],f__ret[STKSZ],f__cp,f__rp;
+flag f__workdone, f__nonl;
+
+ static int
+#ifdef KR_headers
+type_f(n)
+#else
+type_f(int n)
+#endif
+{
+ switch(n)
+ {
+ default:
+ return(n);
+ case RET1:
+ return(RET1);
+ case REVERT: return(REVERT);
+ case GOTO: return(GOTO);
+ case STACK: return(STACK);
+ case X:
+ case SLASH:
+ case APOS: case H:
+ case T: case TL: case TR:
+ return(NED);
+ case F:
+ case I:
+ case IM:
+ case A: case AW:
+ case O: case OM:
+ case L:
+ case E: case EE: case D:
+ case G: case GE:
+ case Z: case ZM:
+ return(ED);
+ }
+}
+#ifdef KR_headers
+integer do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
+#else
+integer do_fio(ftnint *number, char *ptr, ftnlen len)
+#endif
+{ struct syl *p;
+ int n,i;
+ for(i=0;i<*number;i++,ptr+=len)
+ {
+loop: switch(type_f((p= &f__syl[f__pc])->op))
+ {
+ default:
+ fprintf(stderr,"unknown code in do_fio: %d\n%s\n",
+ p->op,f__fmtbuf);
+ err(f__elist->cierr,100,"do_fio");
+ case NED:
+ if((*f__doned)(p))
+ { f__pc++;
+ goto loop;
+ }
+ f__pc++;
+ continue;
+ case ED:
+ if(f__cnt[f__cp]<=0)
+ { f__cp--;
+ f__pc++;
+ goto loop;
+ }
+ if(ptr==NULL)
+ return((*f__doend)());
+ f__cnt[f__cp]--;
+ f__workdone=1;
+ if((n=(*f__doed)(p,ptr,len))>0)
+ errfl(f__elist->cierr,errno,"fmt");
+ if(n<0)
+ err(f__elist->ciend,(EOF),"fmt");
+ continue;
+ case STACK:
+ f__cnt[++f__cp]=p->p1;
+ f__pc++;
+ goto loop;
+ case RET1:
+ f__ret[++f__rp]=p->p1;
+ f__pc++;
+ goto loop;
+ case GOTO:
+ if(--f__cnt[f__cp]<=0)
+ { f__cp--;
+ f__rp--;
+ f__pc++;
+ goto loop;
+ }
+ f__pc=1+f__ret[f__rp--];
+ goto loop;
+ case REVERT:
+ f__rp=f__cp=0;
+ f__pc = p->p1;
+ if(ptr==NULL)
+ return((*f__doend)());
+ if(!f__workdone) return(0);
+ if((n=(*f__dorevert)()) != 0) return(n);
+ goto loop;
+ case COLON:
+ if(ptr==NULL)
+ return((*f__doend)());
+ f__pc++;
+ goto loop;
+ case NONL:
+ f__nonl = 1;
+ f__pc++;
+ goto loop;
+ case S:
+ case SS:
+ f__cplus=0;
+ f__pc++;
+ goto loop;
+ case SP:
+ f__cplus = 1;
+ f__pc++;
+ goto loop;
+ case P: f__scale=p->p1;
+ f__pc++;
+ goto loop;
+ case BN:
+ f__cblank=0;
+ f__pc++;
+ goto loop;
+ case BZ:
+ f__cblank=1;
+ f__pc++;
+ goto loop;
+ }
+ }
+ return(0);
+}
+
+ int
+en_fio(Void)
+{ ftnint one=1;
+ return(do_fio(&one,(char *)NULL,(ftnint)0));
+}
+
+ VOID
+fmt_bg(Void)
+{
+ f__workdone=f__cp=f__rp=f__pc=f__cursor=0;
+ f__cnt[0]=f__ret[0]=0;
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/fmt.h b/F2CLIBS/libf2c/fmt.h
new file mode 100644
index 0000000..ddfa551
--- /dev/null
+++ b/F2CLIBS/libf2c/fmt.h
@@ -0,0 +1,105 @@
+struct syl
+{ int op;
+ int p1;
+ union { int i[2]; char *s;} p2;
+ };
+#define RET1 1
+#define REVERT 2
+#define GOTO 3
+#define X 4
+#define SLASH 5
+#define STACK 6
+#define I 7
+#define ED 8
+#define NED 9
+#define IM 10
+#define APOS 11
+#define H 12
+#define TL 13
+#define TR 14
+#define T 15
+#define COLON 16
+#define S 17
+#define SP 18
+#define SS 19
+#define P 20
+#define BN 21
+#define BZ 22
+#define F 23
+#define E 24
+#define EE 25
+#define D 26
+#define G 27
+#define GE 28
+#define L 29
+#define A 30
+#define AW 31
+#define O 32
+#define NONL 33
+#define OM 34
+#define Z 35
+#define ZM 36
+typedef union
+{ real pf;
+ doublereal pd;
+} ufloat;
+typedef union
+{ short is;
+#ifndef KR_headers
+ signed
+#endif
+ char ic;
+ integer il;
+#ifdef Allow_TYQUAD
+ longint ili;
+#endif
+} Uint;
+#ifdef KR_headers
+extern int (*f__doed)(),(*f__doned)();
+extern int (*f__dorevert)();
+extern int rd_ed(),rd_ned();
+extern int w_ed(),w_ned();
+extern int signbit_f2c();
+extern char *f__fmtbuf;
+#else
+#ifdef __cplusplus
+extern "C" {
+#define Cextern extern "C"
+#else
+#define Cextern extern
+#endif
+extern const char *f__fmtbuf;
+extern int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*);
+extern int (*f__dorevert)(void);
+extern void fmt_bg(void);
+extern int pars_f(const char*);
+extern int rd_ed(struct syl*, char*, ftnlen),rd_ned(struct syl*);
+extern int signbit_f2c(double*);
+extern int w_ed(struct syl*, char*, ftnlen),w_ned(struct syl*);
+extern int wrt_E(ufloat*, int, int, int, ftnlen);
+extern int wrt_F(ufloat*, int, int, ftnlen);
+extern int wrt_L(Uint*, int, ftnlen);
+#endif
+extern int f__pc,f__parenlvl,f__revloc;
+extern flag f__cblank,f__cplus,f__workdone, f__nonl;
+extern int f__scale;
+#ifdef __cplusplus
+ }
+#endif
+#define GET(x) if((x=(*f__getn)())<0) return(x)
+#define VAL(x) (x!='\n'?x:' ')
+#define PUT(x) (*f__putn)(x)
+
+#undef TYQUAD
+#ifndef Allow_TYQUAD
+#undef longint
+#define longint long
+#else
+#define TYQUAD 14
+#endif
+
+#ifdef KR_headers
+extern char *f__icvt();
+#else
+Cextern char *f__icvt(longint, int*, int*, int);
+#endif
diff --git a/F2CLIBS/libf2c/fmtlib.c b/F2CLIBS/libf2c/fmtlib.c
new file mode 100644
index 0000000..279f66f
--- /dev/null
+++ b/F2CLIBS/libf2c/fmtlib.c
@@ -0,0 +1,51 @@
+/* @(#)fmtlib.c 1.2 */
+#define MAXINTLENGTH 23
+
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+#ifndef Allow_TYQUAD
+#undef longint
+#define longint long
+#undef ulongint
+#define ulongint unsigned long
+#endif
+
+#ifdef KR_headers
+char *f__icvt(value,ndigit,sign, base) longint value; int *ndigit,*sign;
+ register int base;
+#else
+char *f__icvt(longint value, int *ndigit, int *sign, int base)
+#endif
+{
+ static char buf[MAXINTLENGTH+1];
+ register int i;
+ ulongint uvalue;
+
+ if(value > 0) {
+ uvalue = value;
+ *sign = 0;
+ }
+ else if (value < 0) {
+ uvalue = -value;
+ *sign = 1;
+ }
+ else {
+ *sign = 0;
+ *ndigit = 1;
+ buf[MAXINTLENGTH-1] = '0';
+ return &buf[MAXINTLENGTH-1];
+ }
+ i = MAXINTLENGTH;
+ do {
+ buf[--i] = (uvalue%base) + '0';
+ uvalue /= base;
+ }
+ while(uvalue > 0);
+ *ndigit = MAXINTLENGTH - i;
+ return &buf[i];
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/fp.h b/F2CLIBS/libf2c/fp.h
new file mode 100644
index 0000000..40743d7
--- /dev/null
+++ b/F2CLIBS/libf2c/fp.h
@@ -0,0 +1,28 @@
+#define FMAX 40
+#define EXPMAXDIGS 8
+#define EXPMAX 99999999
+/* FMAX = max number of nonzero digits passed to atof() */
+/* EXPMAX = 10^EXPMAXDIGS - 1 = largest allowed exponent absolute value */
+
+#ifdef V10 /* Research Tenth-Edition Unix */
+#include "local.h"
+#endif
+
+/* MAXFRACDIGS and MAXINTDIGS are for wrt_F -- bounds (not necessarily
+ tight) on the maximum number of digits to the right and left of
+ * the decimal point.
+ */
+
+#ifdef VAX
+#define MAXFRACDIGS 56
+#define MAXINTDIGS 38
+#else
+#ifdef CRAY
+#define MAXFRACDIGS 9880
+#define MAXINTDIGS 9864
+#else
+/* values that suffice for IEEE double */
+#define MAXFRACDIGS 344
+#define MAXINTDIGS 308
+#endif
+#endif
diff --git a/F2CLIBS/libf2c/ftell64_.c b/F2CLIBS/libf2c/ftell64_.c
new file mode 100644
index 0000000..9cc00cb
--- /dev/null
+++ b/F2CLIBS/libf2c/ftell64_.c
@@ -0,0 +1,52 @@
+#include "f2c.h"
+#include "fio.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+ static FILE *
+#ifdef KR_headers
+unit_chk(Unit, who) integer Unit; char *who;
+#else
+unit_chk(integer Unit, char *who)
+#endif
+{
+ if (Unit >= MXUNIT || Unit < 0)
+ f__fatal(101, who);
+ return f__units[Unit].ufd;
+ }
+
+ longint
+#ifdef KR_headers
+ftell64_(Unit) integer *Unit;
+#else
+ftell64_(integer *Unit)
+#endif
+{
+ FILE *f;
+ return (f = unit_chk(*Unit, "ftell")) ? FTELL(f) : -1L;
+ }
+
+ int
+#ifdef KR_headers
+fseek64_(Unit, offset, whence) integer *Unit, *whence; longint *offset;
+#else
+fseek64_(integer *Unit, longint *offset, integer *whence)
+#endif
+{
+ FILE *f;
+ int w = (int)*whence;
+#ifdef SEEK_SET
+ static int wohin[3] = { SEEK_SET, SEEK_CUR, SEEK_END };
+#endif
+ if (w < 0 || w > 2)
+ w = 0;
+#ifdef SEEK_SET
+ w = wohin[w];
+#endif
+ return !(f = unit_chk(*Unit, "fseek"))
+ || FSEEK(f, (OFF_T)*offset, w) ? 1 : 0;
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/ftell_.c b/F2CLIBS/libf2c/ftell_.c
new file mode 100644
index 0000000..0acd60f
--- /dev/null
+++ b/F2CLIBS/libf2c/ftell_.c
@@ -0,0 +1,52 @@
+#include "f2c.h"
+#include "fio.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+ static FILE *
+#ifdef KR_headers
+unit_chk(Unit, who) integer Unit; char *who;
+#else
+unit_chk(integer Unit, const char *who)
+#endif
+{
+ if (Unit >= MXUNIT || Unit < 0)
+ f__fatal(101, who);
+ return f__units[Unit].ufd;
+ }
+
+ integer
+#ifdef KR_headers
+ftell_(Unit) integer *Unit;
+#else
+ftell_(integer *Unit)
+#endif
+{
+ FILE *f;
+ return (f = unit_chk(*Unit, "ftell")) ? ftell(f) : -1L;
+ }
+
+ int
+#ifdef KR_headers
+fseek_(Unit, offset, whence) integer *Unit, *offset, *whence;
+#else
+fseek_(integer *Unit, integer *offset, integer *whence)
+#endif
+{
+ FILE *f;
+ int w = (int)*whence;
+#ifdef SEEK_SET
+ static int wohin[3] = { SEEK_SET, SEEK_CUR, SEEK_END };
+#endif
+ if (w < 0 || w > 2)
+ w = 0;
+#ifdef SEEK_SET
+ w = wohin[w];
+#endif
+ return !(f = unit_chk(*Unit, "fseek"))
+ || fseek(f, *offset, w) ? 1 : 0;
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/getarg_.c b/F2CLIBS/libf2c/getarg_.c
new file mode 100644
index 0000000..2b69a1e
--- /dev/null
+++ b/F2CLIBS/libf2c/getarg_.c
@@ -0,0 +1,36 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/*
+ * subroutine getarg(k, c)
+ * returns the kth unix command argument in fortran character
+ * variable argument c
+*/
+
+#ifdef KR_headers
+VOID getarg_(n, s, ls) ftnint *n; char *s; ftnlen ls;
+#define Const /*nothing*/
+#else
+#define Const const
+void getarg_(ftnint *n, char *s, ftnlen ls)
+#endif
+{
+ extern int xargc;
+ extern char **xargv;
+ Const char *t;
+ int i;
+
+ if(*n>=0 && *n<xargc)
+ t = xargv[*n];
+ else
+ t = "";
+ for(i = 0; i<ls && *t!='\0' ; ++i)
+ *s++ = *t++;
+ for( ; i<ls ; ++i)
+ *s++ = ' ';
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/getenv_.c b/F2CLIBS/libf2c/getenv_.c
new file mode 100644
index 0000000..b615a37
--- /dev/null
+++ b/F2CLIBS/libf2c/getenv_.c
@@ -0,0 +1,62 @@
+#include "f2c.h"
+#undef abs
+#ifdef KR_headers
+extern char *F77_aloc(), *getenv();
+#else
+#include <stdlib.h>
+#include <string.h>
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern char *F77_aloc(ftnlen, const char*);
+#endif
+
+/*
+ * getenv - f77 subroutine to return environment variables
+ *
+ * called by:
+ * call getenv (ENV_NAME, char_var)
+ * where:
+ * ENV_NAME is the name of an environment variable
+ * char_var is a character variable which will receive
+ * the current value of ENV_NAME, or all blanks
+ * if ENV_NAME is not defined
+ */
+
+#ifdef KR_headers
+ VOID
+getenv_(fname, value, flen, vlen) char *value, *fname; ftnlen vlen, flen;
+#else
+ void
+getenv_(char *fname, char *value, ftnlen flen, ftnlen vlen)
+#endif
+{
+ char buf[256], *ep, *fp;
+ integer i;
+
+ if (flen <= 0)
+ goto add_blanks;
+ for(i = 0; i < sizeof(buf); i++) {
+ if (i == flen || (buf[i] = fname[i]) == ' ') {
+ buf[i] = 0;
+ ep = getenv(buf);
+ goto have_ep;
+ }
+ }
+ while(i < flen && fname[i] != ' ')
+ i++;
+ strncpy(fp = F77_aloc(i+1, "getenv_"), fname, (int)i);
+ fp[i] = 0;
+ ep = getenv(fp);
+ free(fp);
+ have_ep:
+ if (ep)
+ while(*ep && vlen-- > 0)
+ *value++ = *ep++;
+ add_blanks:
+ while(vlen-- > 0)
+ *value++ = ' ';
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/h_abs.c b/F2CLIBS/libf2c/h_abs.c
new file mode 100644
index 0000000..db69068
--- /dev/null
+++ b/F2CLIBS/libf2c/h_abs.c
@@ -0,0 +1,18 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+shortint h_abs(x) shortint *x;
+#else
+shortint h_abs(shortint *x)
+#endif
+{
+if(*x >= 0)
+ return(*x);
+return(- *x);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/h_dim.c b/F2CLIBS/libf2c/h_dim.c
new file mode 100644
index 0000000..443427a
--- /dev/null
+++ b/F2CLIBS/libf2c/h_dim.c
@@ -0,0 +1,16 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+shortint h_dim(a,b) shortint *a, *b;
+#else
+shortint h_dim(shortint *a, shortint *b)
+#endif
+{
+return( *a > *b ? *a - *b : 0);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/h_dnnt.c b/F2CLIBS/libf2c/h_dnnt.c
new file mode 100644
index 0000000..1ec641c
--- /dev/null
+++ b/F2CLIBS/libf2c/h_dnnt.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double floor();
+shortint h_dnnt(x) doublereal *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+shortint h_dnnt(doublereal *x)
+#endif
+{
+return (shortint)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x));
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/h_indx.c b/F2CLIBS/libf2c/h_indx.c
new file mode 100644
index 0000000..018f2f4
--- /dev/null
+++ b/F2CLIBS/libf2c/h_indx.c
@@ -0,0 +1,32 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+shortint h_indx(a, b, la, lb) char *a, *b; ftnlen la, lb;
+#else
+shortint h_indx(char *a, char *b, ftnlen la, ftnlen lb)
+#endif
+{
+ftnlen i, n;
+char *s, *t, *bend;
+
+n = la - lb + 1;
+bend = b + lb;
+
+for(i = 0 ; i < n ; ++i)
+ {
+ s = a + i;
+ t = b;
+ while(t < bend)
+ if(*s++ != *t++)
+ goto no;
+ return((shortint)i+1);
+ no: ;
+ }
+return(0);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/h_len.c b/F2CLIBS/libf2c/h_len.c
new file mode 100644
index 0000000..8b0aea9
--- /dev/null
+++ b/F2CLIBS/libf2c/h_len.c
@@ -0,0 +1,16 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+shortint h_len(s, n) char *s; ftnlen n;
+#else
+shortint h_len(char *s, ftnlen n)
+#endif
+{
+return(n);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/h_mod.c b/F2CLIBS/libf2c/h_mod.c
new file mode 100644
index 0000000..611ef0a
--- /dev/null
+++ b/F2CLIBS/libf2c/h_mod.c
@@ -0,0 +1,16 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+shortint h_mod(a,b) short *a, *b;
+#else
+shortint h_mod(short *a, short *b)
+#endif
+{
+return( *a % *b);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/h_nint.c b/F2CLIBS/libf2c/h_nint.c
new file mode 100644
index 0000000..9e2282f
--- /dev/null
+++ b/F2CLIBS/libf2c/h_nint.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double floor();
+shortint h_nint(x) real *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+shortint h_nint(real *x)
+#endif
+{
+return (shortint)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x));
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/h_sign.c b/F2CLIBS/libf2c/h_sign.c
new file mode 100644
index 0000000..4e21438
--- /dev/null
+++ b/F2CLIBS/libf2c/h_sign.c
@@ -0,0 +1,18 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+shortint h_sign(a,b) shortint *a, *b;
+#else
+shortint h_sign(shortint *a, shortint *b)
+#endif
+{
+shortint x;
+x = (*a >= 0 ? *a : - *a);
+return( *b >= 0 ? x : -x);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/hl_ge.c b/F2CLIBS/libf2c/hl_ge.c
new file mode 100644
index 0000000..8c72f03
--- /dev/null
+++ b/F2CLIBS/libf2c/hl_ge.c
@@ -0,0 +1,18 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+extern integer s_cmp();
+shortlogical hl_ge(a,b,la,lb) char *a, *b; ftnlen la, lb;
+#else
+extern integer s_cmp(char *, char *, ftnlen, ftnlen);
+shortlogical hl_ge(char *a, char *b, ftnlen la, ftnlen lb)
+#endif
+{
+return(s_cmp(a,b,la,lb) >= 0);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/hl_gt.c b/F2CLIBS/libf2c/hl_gt.c
new file mode 100644
index 0000000..a448522
--- /dev/null
+++ b/F2CLIBS/libf2c/hl_gt.c
@@ -0,0 +1,18 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+extern integer s_cmp();
+shortlogical hl_gt(a,b,la,lb) char *a, *b; ftnlen la, lb;
+#else
+extern integer s_cmp(char *, char *, ftnlen, ftnlen);
+shortlogical hl_gt(char *a, char *b, ftnlen la, ftnlen lb)
+#endif
+{
+return(s_cmp(a,b,la,lb) > 0);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/hl_le.c b/F2CLIBS/libf2c/hl_le.c
new file mode 100644
index 0000000..31cbc43
--- /dev/null
+++ b/F2CLIBS/libf2c/hl_le.c
@@ -0,0 +1,18 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+extern integer s_cmp();
+shortlogical hl_le(a,b,la,lb) char *a, *b; ftnlen la, lb;
+#else
+extern integer s_cmp(char *, char *, ftnlen, ftnlen);
+shortlogical hl_le(char *a, char *b, ftnlen la, ftnlen lb)
+#endif
+{
+return(s_cmp(a,b,la,lb) <= 0);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/hl_lt.c b/F2CLIBS/libf2c/hl_lt.c
new file mode 100644
index 0000000..7ad3c71
--- /dev/null
+++ b/F2CLIBS/libf2c/hl_lt.c
@@ -0,0 +1,18 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+extern integer s_cmp();
+shortlogical hl_lt(a,b,la,lb) char *a, *b; ftnlen la, lb;
+#else
+extern integer s_cmp(char *, char *, ftnlen, ftnlen);
+shortlogical hl_lt(char *a, char *b, ftnlen la, ftnlen lb)
+#endif
+{
+return(s_cmp(a,b,la,lb) < 0);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/i77vers.c b/F2CLIBS/libf2c/i77vers.c
new file mode 100644
index 0000000..60cc24e
--- /dev/null
+++ b/F2CLIBS/libf2c/i77vers.c
@@ -0,0 +1,343 @@
+ char
+_libi77_version_f2c[] = "\n@(#) LIBI77 VERSION (f2c) pjw,dmg-mods 20030321\n";
+
+/*
+2.01 $ format added
+2.02 Coding bug in open.c repaired
+2.03 fixed bugs in lread.c (read * with negative f-format) and lio.c
+ and lio.h (e-format conforming to spec)
+2.04 changed open.c and err.c (fopen and freopen respectively) to
+ update to new c-library (append mode)
+2.05 added namelist capability
+2.06 allow internal list and namelist I/O
+*/
+
+/*
+close.c:
+ allow upper-case STATUS= values
+endfile.c
+ create fort.nnn if unit nnn not open;
+ else if (file length == 0) use creat() rather than copy;
+ use local copy() rather than forking /bin/cp;
+ rewind, fseek to clear buffer (for no reading past EOF)
+err.c
+ use neither setbuf nor setvbuf; make stderr buffered
+fio.h
+ #define _bufend
+inquire.c
+ upper case responses;
+ omit byfile test from SEQUENTIAL=
+ answer "YES" to DIRECT= for unopened file (open to debate)
+lio.c
+ flush stderr, stdout at end of each stmt
+ space before character strings in list output only at line start
+lio.h
+ adjust LEW, LED consistent with old libI77
+lread.c
+ use atof()
+ allow "nnn*," when reading complex constants
+open.c
+ try opening for writing when open for read fails, with
+ special uwrt value (2) delaying creat() to first write;
+ set curunit so error messages don't drop core;
+ no file name ==> fort.nnn except for STATUS='SCRATCH'
+rdfmt.c
+ use atof(); trust EOF == end-of-file (so don't read past
+ end-of-file after endfile stmt)
+sfe.c
+ flush stderr, stdout at end of each stmt
+wrtfmt.c:
+ use upper case
+ put wrt_E and wrt_F into wref.c, use sprintf()
+ rather than ecvt() and fcvt() [more accurate on VAX]
+*/
+
+/* 16 Oct. 1988: uwrt = 3 after write, rewind, so close won't zap the file. */
+
+/* 10 July 1989: change _bufend to buf_end in fio.h, wsfe.c, wrtfmt.c */
+
+/* 28 Nov. 1989: corrections for IEEE and Cray arithmetic */
+/* 29 Nov. 1989: change various int return types to long for f2c */
+/* 30 Nov. 1989: various types from f2c.h */
+/* 6 Dec. 1989: types corrected various places */
+/* 19 Dec. 1989: make iostat= work right for internal I/O */
+/* 8 Jan. 1990: add rsne, wsne -- routines for handling NAMELIST */
+/* 28 Jan. 1990: have NAMELIST read treat $ as &, general white
+ space as blank */
+/* 27 Mar. 1990: change an = to == in rd_L(rdfmt.c) so formatted reads
+ of logical values reject letters other than fFtT;
+ have nowwriting reset cf */
+/* 14 Aug. 1990: adjust lread.c to treat tabs as spaces in list input */
+/* 17 Aug. 1990: adjust open.c to recognize blank='Z...' as well as
+ blank='z...' when reopening an open file */
+/* 30 Aug. 1990: prevent embedded blanks in list output of complex values;
+ omit exponent field in list output of values of
+ magnitude between 10 and 1e8; prevent writing stdin
+ and reading stdout or stderr; don't close stdin, stdout,
+ or stderr when reopening units 5, 6, 0. */
+/* 18 Sep. 1990: add component udev to unit and consider old == new file
+ iff uinode and udev values agree; use stat rather than
+ access to check existence of file (when STATUS='OLD')*/
+/* 2 Oct. 1990: adjust rewind.c so two successive rewinds after a write
+ don't clobber the file. */
+/* 9 Oct. 1990: add #include "fcntl.h" to endfile.c, err.c, open.c;
+ adjust g_char in util.c for segmented memories. */
+/* 17 Oct. 1990: replace abort() and _cleanup() with calls on
+ sig_die(...,1) (defined in main.c). */
+/* 5 Nov. 1990: changes to open.c: complain if new= is specified and the
+ file already exists; allow file= to be omitted in open stmts
+ and allow status='replace' (Fortran 90 extensions). */
+/* 11 Dec. 1990: adjustments for POSIX. */
+/* 15 Jan. 1991: tweak i_ungetc in rsli.c to allow reading from
+ strings in read-only memory. */
+/* 25 Apr. 1991: adjust namelist stuff to work with f2c -i2 */
+/* 26 Apr. 1991: fix some bugs with NAMELIST read of multi-dim. arrays */
+/* 16 May 1991: increase LEFBL in lio.h to bypass NeXT bug */
+/* 17 Oct. 1991: change type of length field in sequential unformatted
+ records from int to long (for systems where sizeof(int)
+ can vary, depending on the compiler or compiler options). */
+/* 14 Nov. 1991: change uint to Uint in fmt.h, rdfmt.c, wrtfmt.c. */
+/* 25 Nov. 1991: change uint to Uint in lwrite.c; change sizeof(int) to
+ sizeof(uioint) in fseeks in sue.c (missed on 17 Oct.). */
+/* 1 Dec. 1991: uio.c: add test for read failure (seq. unformatted reads);
+ adjust an error return from EOF to off end of record */
+/* 12 Dec. 1991: rsli.c: fix bug with internal list input that caused
+ the last character of each record to be ignored.
+ iio.c: adjust error message in internal formatted
+ input from "end-of-file" to "off end of record" if
+ the format specifies more characters than the
+ record contains. */
+/* 17 Jan. 1992: lread.c, rsne.c: in list and namelist input,
+ treat "r* ," and "r*," alike (where r is a
+ positive integer constant), and fix a bug in
+ handling null values following items with repeat
+ counts (e.g., 2*1,,3); for namelist reading
+ of a numeric array, allow a new name-value subsequence
+ to terminate the current one (as though the current
+ one ended with the right number of null values).
+ lio.h, lwrite.c: omit insignificant zeros in
+ list and namelist output. To get the old
+ behavior, compile with -DOld_list_output . */
+/* 18 Jan. 1992: make list output consistent with F format by
+ printing .1 rather than 0.1 (introduced yesterday). */
+/* 3 Feb. 1992: rsne.c: fix namelist read bug that caused the
+ character following a comma to be ignored. */
+/* 19 May 1992: adjust iio.c, ilnw.c, rdfmt.c and rsli.c to make err=
+ work with internal list and formatted I/O. */
+/* 18 July 1992: adjust rsne.c to allow namelist input to stop at
+ an & (e.g. &end). */
+/* 23 July 1992: switch to ANSI prototypes unless KR_headers is #defined ;
+ recognize Z format (assuming 8-bit bytes). */
+/* 14 Aug. 1992: tweak wrt_E in wref.c to avoid -NaN */
+/* 23 Oct. 1992: Supply missing l_eof = 0 assignment to s_rsne() in rsne.c
+ (so end-of-file on other files won't confuse namelist
+ reads of external files). Prepend f__ to external
+ names that are only of internal interest to lib[FI]77. */
+/* 1 Feb. 1993: backspace.c: fix bug that bit when last char of 2nd
+ buffer == '\n'.
+ endfile.c: guard against tiny L_tmpnam; close and reopen
+ files in t_runc().
+ lio.h: lengthen LINTW (buffer size in lwrite.c).
+ err.c, open.c: more prepending of f__ (to [rw]_mode). */
+/* 5 Feb. 1993: tweaks to NAMELIST: rsne.c: ? prints the namelist being
+ sought; namelists of the wrong name are skipped (after
+ an error message; xwsne.c: namelist writes have a
+ newline before each new variable.
+ open.c: ACCESS='APPEND' positions sequential files
+ at EOF (nonstandard extension -- that doesn't require
+ changing data structures). */
+/* 9 Feb. 1993: Change some #ifdef MSDOS lines to #ifdef NON_UNIX_STDIO.
+ err.c: under NON_UNIX_STDIO, avoid close(creat(name,0666))
+ when the unit has another file descriptor for name. */
+/* 4 March 1993: err.c, open.c: take declaration of fdopen from rawio.h;
+ open.c: always give f__w_mode[] 4 elements for use
+ in t_runc (in endfile.c -- for change of 1 Feb. 1993). */
+/* 6 March 1993: uio.c: adjust off-end-of-record test for sequential
+ unformatted reads to respond to err= rather than end=. */
+/* 12 March 1993: various tweaks for C++ */
+/* 6 April 1993: adjust error returns for formatted inputs to flush
+ the current input line when err=label is specified.
+ To restore the old behavior (input left mid-line),
+ either adjust the #definition of errfl in fio.h or
+ omit the invocation of f__doend in err__fl (in err.c). */
+/* 23 June 1993: iio.c: fix bug in format reversions for internal writes. */
+/* 5 Aug. 1993: lread.c: fix bug in handling repetition counts for
+ logical data (during list or namelist input).
+ Change struct f__syl to struct syl (for buggy compilers). */
+/* 7 Aug. 1993: lread.c: fix bug in namelist reading of incomplete
+ logical arrays. */
+/* 9 Aug. 1993: lread.c: fix bug in namelist reading of an incomplete
+ array of numeric data followed by another namelist
+ item whose name starts with 'd', 'D', 'e', or 'E'. */
+/* 8 Sept. 1993: open.c: protect #include "sys/..." with
+ #ifndef NON_UNIX_STDIO; Version date not changed. */
+/* 10 Nov. 1993: backspace.c: add nonsense for #ifdef MSDOS */
+/* 8 Dec. 1993: iio.c: adjust internal formatted reads to treat
+ short records as though padded with blanks
+ (rather than causing an "off end of record" error). */
+/* 22 Feb. 1994: lread.c: check that realloc did not return NULL. */
+/* 6 June 1994: Under NON_UNIX_STDIO, use binary mode for direct
+ formatted files (avoiding any confusion regarding \n). */
+/* 5 July 1994: Fix bug (introduced 6 June 1994?) in reopening files
+ under NON_UNIX_STDIO. */
+/* 6 July 1994: wref.c: protect with #ifdef GOOD_SPRINTF_EXPONENT an
+ optimization that requires exponents to have 2 digits
+ when 2 digits suffice.
+ lwrite.c wsfe.c (list and formatted external output):
+ omit ' ' carriage-control when compiled with
+ -DOMIT_BLANK_CC . Off-by-one bug fixed in character
+ count for list output of character strings.
+ Omit '.' in list-directed printing of Nan, Infinity. */
+/* 12 July 1994: wrtfmt.c: under G11.4, write 0. as " .0000 " rather
+ than " .0000E+00". */
+/* 3 Aug. 1994: lwrite.c: do not insert a newline when appending an
+ oversize item to an empty line. */
+/* 12 Aug. 1994: rsli.c rsne.c: fix glitch (reset nml_read) that kept
+ ERR= (in list- or format-directed input) from working
+ after a NAMELIST READ. */
+/* 7 Sept. 1994: typesize.c: adjust to allow types LOGICAL*1, LOGICAL*2,
+ INTEGER*1, and (under -DAllow_TYQUAD) INTEGER*8
+ in NAMELISTs. */
+/* 6 Oct. 1994: util.c: omit f__mvgbt, as it is never used. */
+/* 2 Nov. 1994: add #ifdef ALWAYS_FLUSH logic. */
+/* 26 Jan. 1995: wref.c: fix glitch in printing the exponent of 0 when
+ GOOD_SPRINTF_EXPONENT is not #defined. */
+/* 24 Feb. 1995: iio.c: z_getc: insert (unsigned char *) to allow
+ internal reading of characters with high-bit set
+ (on machines that sign-extend characters). */
+/* 14 March 1995:lread.c and rsfe.c: adjust s_rsle and s_rsfe to
+ check for end-of-file (to prevent infinite loops
+ with empty read statements). */
+/* 26 May 1995: iio.c: z_wnew: fix bug in handling T format items
+ in internal writes whose last item is written to
+ an earlier position than some previous item. */
+/* 29 Aug. 1995: backspace.c: adjust MSDOS logic. */
+/* 6 Sept. 1995: Adjust namelist input to treat a subscripted name
+ whose subscripts do not involve colons similarly
+ to the name without a subscript: accept several
+ values, stored in successive elements starting at
+ the indicated subscript. Adjust namelist output
+ to quote character strings (avoiding confusion with
+ arrays of character strings). Adjust f_init calls
+ for people who don't use libF77's main(); now open and
+ namelist read statements invoke f_init if needed. */
+/* 7 Sept. 1995: Fix some bugs with -DAllow_TYQUAD (for integer*8).
+ Add -DNo_Namelist_Comments lines to rsne.c. */
+/* 5 Oct. 1995: wrtfmt.c: fix bug with t editing (f__cursor was not
+ always zeroed in mv_cur). */
+/* 11 Oct. 1995: move defs of f__hiwater, f__svic, f__icptr from wrtfmt.c
+ to err.c */
+/* 15 Mar. 1996: lread.c, rsfe.c: honor END= in READ stmt with empty iolist */
+
+/* 13 May 1996: add ftell_.c and fseek_.c */
+/* 9 June 1996: Adjust rsli.c and lread.c so internal list input with
+ too few items in the input string will honor end= . */
+/* 12 Sept. 1995:fmtlib.c: fix glitch in printing the most negative integer. */
+/* 25 Sept. 1995:fmt.h: for formatted writes of negative integer*1 values,
+ make ic signed on ANSI systems. If formatted writes of
+ integer*1 values trouble you when using a K&R C compiler,
+ switch to an ANSI compiler or use a compiler flag that
+ makes characters signed. */
+/* 9 Dec. 1996: d[fu]e.c, err.c: complain about non-positive rec=
+ in direct read and write statements.
+ ftell_.c: change param "unit" to "Unit" for -DKR_headers. */
+/* 26 Feb. 1997: ftell_.c: on systems that define SEEK_SET, etc., use
+ SEEK_SET, SEEK_CUR, SEEK_END for *whence = 0, 1, 2. */
+/* 7 Apr. 1997: fmt.c: adjust to complain at missing numbers in formats
+ (but still treat missing ".nnn" as ".0"). */
+/* 11 Apr. 1997: err.c: attempt to make stderr line buffered rather
+ than fully buffered. (Buffering is needed for format
+ items T and TR.) */
+/* 27 May 1997: ftell_.c: fix typo (that caused the third argument to be
+ treated as 2 on some systems). */
+/* 5 Aug. 1997: lread.c: adjust to accord with a change to the Fortran 8X
+ draft (in 1990 or 1991) that rescinded permission to elide
+ quote marks in namelist input of character data; compile
+ with -DF8X_NML_ELIDE_QUOTES to get the old behavior.
+ wrtfmt.o: wrt_G: tweak to print the right number of 0's
+ for zero under G format. */
+/* 16 Aug. 1997: iio.c: fix bug in internal writes to an array of character
+ strings that sometimes caused one more array element than
+ required by the format to be blank-filled. Example:
+ format(1x). */
+/* 16 Sept. 1997:fmt.[ch] rdfmt.c wrtfmt.c: tweak struct syl for machines
+ with 64-bit pointers and 32-bit ints that did not 64-bit
+ align struct syl (e.g., Linux on the DEC Alpha). */
+/* 19 Jan. 1998: backspace.c: for b->ufmt==0, change sizeof(int) to
+ sizeof(uiolen). On machines where this would make a
+ difference, it is best for portability to compile libI77 with
+ -DUIOLEN_int (which will render the change invisible). */
+/* 4 March 1998: open.c: fix glitch in comparing file names under
+ -DNON_UNIX_STDIO */
+/* 17 March 1998: endfile.c, open.c: acquire temporary files from tmpfile(),
+ unless compiled with -DNON_ANSI_STDIO, which uses mktemp().
+ New buffering scheme independent of NON_UNIX_STDIO for
+ handling T format items. Now -DNON_UNIX_STDIO is no
+ longer be necessary for Linux, and libf2c no longer
+ causes stderr to be buffered -- the former setbuf or
+ setvbuf call for stderr was to make T format items work.
+ open.c: use the Posix access() function to check existence
+ or nonexistence of files, except under -DNON_POSIX_STDIO,
+ where trial fopen calls are used. */
+/* 5 April 1998: wsfe.c: make $ format item work: this was lost in the
+ changes of 17 March 1998. */
+/* 28 May 1998: backspace.c dfe.c due.c iio.c lread.c rsfe.c sue.c wsfe.c:
+ set f__curunit sooner so various error messages will
+ correctly identify the I/O unit involved. */
+/* 17 June 1998: lread.c: unless compiled with
+ ALLOW_FLOAT_IN_INTEGER_LIST_INPUT #defined, treat
+ floating-point numbers (containing either a decimal point
+ or an exponent field) as errors when they appear as list
+ input for integer data. */
+/* 7 Sept. 1998: move e_wdfe from sfe.c to dfe.c, where it was originally.
+ Why did it ever move to sfe.c? */
+/* 2 May 1999: open.c: set f__external (to get "external" versus "internal"
+ right in the error message if we cannot open the file).
+ err.c: cast a pointer difference to (int) for %d.
+ rdfmt.c: omit fixed-length buffer that could be overwritten
+ by formats Inn or Lnn with nn > 83. */
+/* 3 May 1999: open.c: insert two casts for machines with 64-bit longs. */
+/* 18 June 1999: backspace.c: allow for b->ufd changing in t_runc */
+/* 27 June 1999: rsne.c: fix bug in namelist input: a misplaced increment */
+/* could cause wrong array elements to be assigned; e.g., */
+/* "&input k(5)=10*1 &end" assigned k(5) and k(15..23) */
+/* 15 Nov. 1999: endfile.c: set state to writing (b->uwrt = 1) when an */
+/* endfile statement requires copying the file. */
+/* (Otherwise an immediately following rewind statement */
+/* could make the file appear empty.) Also, supply a */
+/* missing (long) cast in the sprintf call. */
+/* sfe.c: add #ifdef ALWAYS_FLUSH logic, for formatted I/O: */
+/* Compiling libf2c with -DALWAYS_FLUSH should prevent losing */
+/* any data in buffers should the program fault. It also */
+/* makes the program run more slowly. */
+/* 20 April 2000: rsne.c, xwsne.c: tweaks that only matter if ftnint and */
+/* ftnlen are of different fundamental types (different numbers */
+/* of bits). Since these files will not compile when this */
+/* change matters, the above VERSION string remains unchanged. */
+/* 4 July 2000: adjustments to permit compilation by C++ compilers; */
+/* VERSION string remains unchanged. */
+/* 5 Dec. 2000: lread.c: under namelist input, when reading a logical array, */
+/* treat Tstuff= and Fstuff= as new assignments rather than as */
+/* logical constants. */
+/* 22 Feb. 2001: endfile.c: adjust to use truncate() unless compiled with */
+/* -DNO_TRUNCATE (or with -DMSDOS). */
+/* 1 March 2001: endfile.c: switch to ftruncate (absent -DNO_TRUNCATE), */
+/* thus permitting truncation of scratch files on true Unix */
+/* systems, where scratch files have no name. Add an fflush() */
+/* (surprisingly) needed on some Linux systems. */
+/* 11 Oct. 2001: backspac.c dfe.c due.c endfile.c err.c fio.h fmt.c fmt.h */
+/* inquire.c open.c rdfmt.c sue.c util.c: change fseek and */
+/* ftell to FSEEK and FTELL (#defined to be fseek and ftell, */
+/* respectively, in fio.h unless otherwise #defined), and use */
+/* type OFF_T (#defined to be long unless otherwise #defined) */
+/* to permit handling files over 2GB long where possible, */
+/* with suitable -D options, provided for some systems in new */
+/* header file sysdep1.h (copied from sysdep1.h0 by default). */
+/* 15 Nov. 2001: endfile.c: add FSEEK after FTRUNCATE. */
+/* 28 Nov. 2001: fmt.h lwrite.c wref.c and (new) signbit.c: on IEEE systems, */
+/* print -0 as -0 when compiled with -DSIGNED_ZEROS. See */
+/* comments in makefile or (better) libf2c/makefile.* . */
+/* 6 Sept. 2002: rsne.c: fix bug with multiple repeat counts in reading */
+/* namelists, e.g., &nl a(2) = 3*1.0, 2*2.0, 3*3.0 / */
+/* 21 March 2003: err.c: before writing to a file after reading from it, */
+/* f_seek(file, 0, SEEK_CUR) to make writing legal in ANSI C. */
diff --git a/F2CLIBS/libf2c/i_abs.c b/F2CLIBS/libf2c/i_abs.c
new file mode 100644
index 0000000..2b92c4a
--- /dev/null
+++ b/F2CLIBS/libf2c/i_abs.c
@@ -0,0 +1,18 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+integer i_abs(x) integer *x;
+#else
+integer i_abs(integer *x)
+#endif
+{
+if(*x >= 0)
+ return(*x);
+return(- *x);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/i_ceiling.c b/F2CLIBS/libf2c/i_ceiling.c
new file mode 100644
index 0000000..f708a8b
--- /dev/null
+++ b/F2CLIBS/libf2c/i_ceiling.c
@@ -0,0 +1,36 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+integer i_sceiling(x) real *x;
+#else
+#ifdef __cplusplus
+extern "C" {
+#endif
+integer i_sceiling(real *x)
+#endif
+{
+#define CEIL(x) ((int)(x) + ((x) > 0 && (x) != (int)(x)))
+
+ return (integer) CEIL(*x);
+}
+#ifdef __cplusplus
+}
+#endif
+
+
+#ifdef KR_headers
+integer i_dceiling(x) doublereal *x;
+#else
+#ifdef __cplusplus
+extern "C" {
+#endif
+integer i_dceiling(doublereal *x)
+#endif
+{
+#define CEIL(x) ((int)(x) + ((x) > 0 && (x) != (int)(x)))
+
+ return (integer) CEIL(*x);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/i_dim.c b/F2CLIBS/libf2c/i_dim.c
new file mode 100644
index 0000000..60ed4d8
--- /dev/null
+++ b/F2CLIBS/libf2c/i_dim.c
@@ -0,0 +1,16 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+integer i_dim(a,b) integer *a, *b;
+#else
+integer i_dim(integer *a, integer *b)
+#endif
+{
+return( *a > *b ? *a - *b : 0);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/i_dnnt.c b/F2CLIBS/libf2c/i_dnnt.c
new file mode 100644
index 0000000..3abc2dc
--- /dev/null
+++ b/F2CLIBS/libf2c/i_dnnt.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double floor();
+integer i_dnnt(x) doublereal *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+integer i_dnnt(doublereal *x)
+#endif
+{
+return (integer)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x));
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/i_indx.c b/F2CLIBS/libf2c/i_indx.c
new file mode 100644
index 0000000..1925639
--- /dev/null
+++ b/F2CLIBS/libf2c/i_indx.c
@@ -0,0 +1,32 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+integer i_indx(a, b, la, lb) char *a, *b; ftnlen la, lb;
+#else
+integer i_indx(char *a, char *b, ftnlen la, ftnlen lb)
+#endif
+{
+ftnlen i, n;
+char *s, *t, *bend;
+
+n = la - lb + 1;
+bend = b + lb;
+
+for(i = 0 ; i < n ; ++i)
+ {
+ s = a + i;
+ t = b;
+ while(t < bend)
+ if(*s++ != *t++)
+ goto no;
+ return(i+1);
+ no: ;
+ }
+return(0);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/i_len.c b/F2CLIBS/libf2c/i_len.c
new file mode 100644
index 0000000..0f7b188
--- /dev/null
+++ b/F2CLIBS/libf2c/i_len.c
@@ -0,0 +1,16 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+integer i_len(s, n) char *s; ftnlen n;
+#else
+integer i_len(char *s, ftnlen n)
+#endif
+{
+return(n);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/i_len_trim.c b/F2CLIBS/libf2c/i_len_trim.c
new file mode 100644
index 0000000..c7b7680
--- /dev/null
+++ b/F2CLIBS/libf2c/i_len_trim.c
@@ -0,0 +1,22 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+integer i_len_trim(s, n) char *s; ftnlen n;
+#else
+integer i_len_trim(char *s, ftnlen n)
+#endif
+{
+ int i;
+
+ for(i=n-1;i>=0;i--)
+ if(s[i] != ' ')
+ return i + 1;
+
+ return(0);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/i_mod.c b/F2CLIBS/libf2c/i_mod.c
new file mode 100644
index 0000000..4a9b560
--- /dev/null
+++ b/F2CLIBS/libf2c/i_mod.c
@@ -0,0 +1,16 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+integer i_mod(a,b) integer *a, *b;
+#else
+integer i_mod(integer *a, integer *b)
+#endif
+{
+return( *a % *b);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/i_nint.c b/F2CLIBS/libf2c/i_nint.c
new file mode 100644
index 0000000..fe9fd68
--- /dev/null
+++ b/F2CLIBS/libf2c/i_nint.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double floor();
+integer i_nint(x) real *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+integer i_nint(real *x)
+#endif
+{
+return (integer)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x));
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/i_sign.c b/F2CLIBS/libf2c/i_sign.c
new file mode 100644
index 0000000..4c20e94
--- /dev/null
+++ b/F2CLIBS/libf2c/i_sign.c
@@ -0,0 +1,18 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+integer i_sign(a,b) integer *a, *b;
+#else
+integer i_sign(integer *a, integer *b)
+#endif
+{
+integer x;
+x = (*a >= 0 ? *a : - *a);
+return( *b >= 0 ? x : -x);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/iargc_.c b/F2CLIBS/libf2c/iargc_.c
new file mode 100644
index 0000000..2f29da0
--- /dev/null
+++ b/F2CLIBS/libf2c/iargc_.c
@@ -0,0 +1,17 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+ftnint iargc_()
+#else
+ftnint iargc_(void)
+#endif
+{
+extern int xargc;
+return ( xargc - 1 );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/iio.c b/F2CLIBS/libf2c/iio.c
new file mode 100644
index 0000000..8553efc
--- /dev/null
+++ b/F2CLIBS/libf2c/iio.c
@@ -0,0 +1,159 @@
+#include "f2c.h"
+#include "fio.h"
+#include "fmt.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern char *f__icptr;
+char *f__icend;
+extern icilist *f__svic;
+int f__icnum;
+
+ int
+z_getc(Void)
+{
+ if(f__recpos++ < f__svic->icirlen) {
+ if(f__icptr >= f__icend) err(f__svic->iciend,(EOF),"endfile");
+ return(*(unsigned char *)f__icptr++);
+ }
+ return '\n';
+}
+
+ void
+#ifdef KR_headers
+z_putc(c)
+#else
+z_putc(int c)
+#endif
+{
+ if (f__icptr < f__icend && f__recpos++ < f__svic->icirlen)
+ *f__icptr++ = c;
+}
+
+ int
+z_rnew(Void)
+{
+ f__icptr = f__svic->iciunit + (++f__icnum)*f__svic->icirlen;
+ f__recpos = 0;
+ f__cursor = 0;
+ f__hiwater = 0;
+ return 1;
+}
+
+ static int
+z_endp(Void)
+{
+ (*f__donewrec)();
+ return 0;
+ }
+
+ int
+#ifdef KR_headers
+c_si(a) icilist *a;
+#else
+c_si(icilist *a)
+#endif
+{
+ f__elist = (cilist *)a;
+ f__fmtbuf=a->icifmt;
+ f__curunit = 0;
+ f__sequential=f__formatted=1;
+ f__external=0;
+ if(pars_f(f__fmtbuf)<0)
+ err(a->icierr,100,"startint");
+ fmt_bg();
+ f__cblank=f__cplus=f__scale=0;
+ f__svic=a;
+ f__icnum=f__recpos=0;
+ f__cursor = 0;
+ f__hiwater = 0;
+ f__icptr = a->iciunit;
+ f__icend = f__icptr + a->icirlen*a->icirnum;
+ f__cf = 0;
+ return(0);
+}
+
+ int
+iw_rev(Void)
+{
+ if(f__workdone)
+ z_endp();
+ f__hiwater = f__recpos = f__cursor = 0;
+ return(f__workdone=0);
+ }
+
+#ifdef KR_headers
+integer s_rsfi(a) icilist *a;
+#else
+integer s_rsfi(icilist *a)
+#endif
+{ int n;
+ if(n=c_si(a)) return(n);
+ f__reading=1;
+ f__doed=rd_ed;
+ f__doned=rd_ned;
+ f__getn=z_getc;
+ f__dorevert = z_endp;
+ f__donewrec = z_rnew;
+ f__doend = z_endp;
+ return(0);
+}
+
+ int
+z_wnew(Void)
+{
+ if (f__recpos < f__hiwater) {
+ f__icptr += f__hiwater - f__recpos;
+ f__recpos = f__hiwater;
+ }
+ while(f__recpos++ < f__svic->icirlen)
+ *f__icptr++ = ' ';
+ f__recpos = 0;
+ f__cursor = 0;
+ f__hiwater = 0;
+ f__icnum++;
+ return 1;
+}
+#ifdef KR_headers
+integer s_wsfi(a) icilist *a;
+#else
+integer s_wsfi(icilist *a)
+#endif
+{ int n;
+ if(n=c_si(a)) return(n);
+ f__reading=0;
+ f__doed=w_ed;
+ f__doned=w_ned;
+ f__putn=z_putc;
+ f__dorevert = iw_rev;
+ f__donewrec = z_wnew;
+ f__doend = z_endp;
+ return(0);
+}
+integer e_rsfi(Void)
+{ int n = en_fio();
+ f__fmtbuf = NULL;
+ return(n);
+}
+integer e_wsfi(Void)
+{
+ int n;
+ n = en_fio();
+ f__fmtbuf = NULL;
+ if(f__svic->icirnum != 1
+ && (f__icnum > f__svic->icirnum
+ || (f__icnum == f__svic->icirnum && (f__recpos | f__hiwater))))
+ err(f__svic->icierr,110,"inwrite");
+ if (f__recpos < f__hiwater)
+ f__recpos = f__hiwater;
+ if (f__recpos >= f__svic->icirlen)
+ err(f__svic->icierr,110,"recend");
+ if (!f__recpos && f__icnum)
+ return n;
+ while(f__recpos++ < f__svic->icirlen)
+ *f__icptr++ = ' ';
+ return n;
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/ilnw.c b/F2CLIBS/libf2c/ilnw.c
new file mode 100644
index 0000000..e8b3d49
--- /dev/null
+++ b/F2CLIBS/libf2c/ilnw.c
@@ -0,0 +1,83 @@
+#include "f2c.h"
+#include "fio.h"
+#include "lio.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern char *f__icptr;
+extern char *f__icend;
+extern icilist *f__svic;
+extern int f__icnum;
+#ifdef KR_headers
+extern void z_putc();
+#else
+extern void z_putc(int);
+#endif
+
+ static int
+z_wSL(Void)
+{
+ while(f__recpos < f__svic->icirlen)
+ z_putc(' ');
+ return z_rnew();
+ }
+
+ static void
+#ifdef KR_headers
+c_liw(a) icilist *a;
+#else
+c_liw(icilist *a)
+#endif
+{
+ f__reading = 0;
+ f__external = 0;
+ f__formatted = 1;
+ f__putn = z_putc;
+ L_len = a->icirlen;
+ f__donewrec = z_wSL;
+ f__svic = a;
+ f__icnum = f__recpos = 0;
+ f__cursor = 0;
+ f__cf = 0;
+ f__curunit = 0;
+ f__icptr = a->iciunit;
+ f__icend = f__icptr + a->icirlen*a->icirnum;
+ f__elist = (cilist *)a;
+ }
+
+ integer
+#ifdef KR_headers
+s_wsni(a) icilist *a;
+#else
+s_wsni(icilist *a)
+#endif
+{
+ cilist ca;
+
+ c_liw(a);
+ ca.cifmt = a->icifmt;
+ x_wsne(&ca);
+ z_wSL();
+ return 0;
+ }
+
+ integer
+#ifdef KR_headers
+s_wsli(a) icilist *a;
+#else
+s_wsli(icilist *a)
+#endif
+{
+ f__lioproc = l_write;
+ c_liw(a);
+ return(0);
+ }
+
+integer e_wsli(Void)
+{
+ z_wSL();
+ return(0);
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/inquire.c b/F2CLIBS/libf2c/inquire.c
new file mode 100644
index 0000000..5936a67
--- /dev/null
+++ b/F2CLIBS/libf2c/inquire.c
@@ -0,0 +1,117 @@
+#include "f2c.h"
+#include "fio.h"
+#include "string.h"
+#ifdef NON_UNIX_STDIO
+#ifndef MSDOS
+#include "unistd.h" /* for access() */
+#endif
+#endif
+#ifdef KR_headers
+integer f_inqu(a) inlist *a;
+#else
+#ifdef __cplusplus
+extern "C" integer f_inqu(inlist*);
+#endif
+#ifdef MSDOS
+#undef abs
+#undef min
+#undef max
+#include "io.h"
+#endif
+integer f_inqu(inlist *a)
+#endif
+{ flag byfile;
+ int i;
+#ifndef NON_UNIX_STDIO
+ int n;
+#endif
+ unit *p;
+ char buf[256];
+ long x;
+ if(a->infile!=NULL)
+ { byfile=1;
+ g_char(a->infile,a->infilen,buf);
+#ifdef NON_UNIX_STDIO
+ x = access(buf,0) ? -1 : 0;
+ for(i=0,p=NULL;i<MXUNIT;i++)
+ if(f__units[i].ufd != NULL
+ && f__units[i].ufnm != NULL
+ && !strcmp(f__units[i].ufnm,buf)) {
+ p = &f__units[i];
+ break;
+ }
+#else
+ x=f__inode(buf, &n);
+ for(i=0,p=NULL;i<MXUNIT;i++)
+ if(f__units[i].uinode==x
+ && f__units[i].ufd!=NULL
+ && f__units[i].udev == n) {
+ p = &f__units[i];
+ break;
+ }
+#endif
+ }
+ else
+ {
+ byfile=0;
+ if(a->inunit<MXUNIT && a->inunit>=0)
+ {
+ p= &f__units[a->inunit];
+ }
+ else
+ {
+ p=NULL;
+ }
+ }
+ if(a->inex!=NULL)
+ if(byfile && x != -1 || !byfile && p!=NULL)
+ *a->inex=1;
+ else *a->inex=0;
+ if(a->inopen!=NULL)
+ if(byfile) *a->inopen=(p!=NULL);
+ else *a->inopen=(p!=NULL && p->ufd!=NULL);
+ if(a->innum!=NULL) *a->innum= p-f__units;
+ if(a->innamed!=NULL)
+ if(byfile || p!=NULL && p->ufnm!=NULL)
+ *a->innamed=1;
+ else *a->innamed=0;
+ if(a->inname!=NULL)
+ if(byfile)
+ b_char(buf,a->inname,a->innamlen);
+ else if(p!=NULL && p->ufnm!=NULL)
+ b_char(p->ufnm,a->inname,a->innamlen);
+ if(a->inacc!=NULL && p!=NULL && p->ufd!=NULL)
+ if(p->url)
+ b_char("DIRECT",a->inacc,a->inacclen);
+ else b_char("SEQUENTIAL",a->inacc,a->inacclen);
+ if(a->inseq!=NULL)
+ if(p!=NULL && p->url)
+ b_char("NO",a->inseq,a->inseqlen);
+ else b_char("YES",a->inseq,a->inseqlen);
+ if(a->indir!=NULL)
+ if(p==NULL || p->url)
+ b_char("YES",a->indir,a->indirlen);
+ else b_char("NO",a->indir,a->indirlen);
+ if(a->infmt!=NULL)
+ if(p!=NULL && p->ufmt==0)
+ b_char("UNFORMATTED",a->infmt,a->infmtlen);
+ else b_char("FORMATTED",a->infmt,a->infmtlen);
+ if(a->inform!=NULL)
+ if(p!=NULL && p->ufmt==0)
+ b_char("NO",a->inform,a->informlen);
+ else b_char("YES",a->inform,a->informlen);
+ if(a->inunf)
+ if(p!=NULL && p->ufmt==0)
+ b_char("YES",a->inunf,a->inunflen);
+ else if (p!=NULL) b_char("NO",a->inunf,a->inunflen);
+ else b_char("UNKNOWN",a->inunf,a->inunflen);
+ if(a->inrecl!=NULL && p!=NULL)
+ *a->inrecl=p->url;
+ if(a->innrec!=NULL && p!=NULL && p->url>0)
+ *a->innrec=(ftnint)(FTELL(p->ufd)/p->url+1);
+ if(a->inblank && p!=NULL && p->ufmt)
+ if(p->ublnk)
+ b_char("ZERO",a->inblank,a->inblanklen);
+ else b_char("NULL",a->inblank,a->inblanklen);
+ return(0);
+}
diff --git a/F2CLIBS/libf2c/l_ge.c b/F2CLIBS/libf2c/l_ge.c
new file mode 100644
index 0000000..a84f0ee
--- /dev/null
+++ b/F2CLIBS/libf2c/l_ge.c
@@ -0,0 +1,18 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+extern integer s_cmp();
+logical l_ge(a,b,la,lb) char *a, *b; ftnlen la, lb;
+#else
+extern integer s_cmp(char *, char *, ftnlen, ftnlen);
+logical l_ge(char *a, char *b, ftnlen la, ftnlen lb)
+#endif
+{
+return(s_cmp(a,b,la,lb) >= 0);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/l_gt.c b/F2CLIBS/libf2c/l_gt.c
new file mode 100644
index 0000000..ae6950d
--- /dev/null
+++ b/F2CLIBS/libf2c/l_gt.c
@@ -0,0 +1,18 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+extern integer s_cmp();
+logical l_gt(a,b,la,lb) char *a, *b; ftnlen la, lb;
+#else
+extern integer s_cmp(char *, char *, ftnlen, ftnlen);
+logical l_gt(char *a, char *b, ftnlen la, ftnlen lb)
+#endif
+{
+return(s_cmp(a,b,la,lb) > 0);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/l_le.c b/F2CLIBS/libf2c/l_le.c
new file mode 100644
index 0000000..625b49a
--- /dev/null
+++ b/F2CLIBS/libf2c/l_le.c
@@ -0,0 +1,18 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+extern integer s_cmp();
+logical l_le(a,b,la,lb) char *a, *b; ftnlen la, lb;
+#else
+extern integer s_cmp(char *, char *, ftnlen, ftnlen);
+logical l_le(char *a, char *b, ftnlen la, ftnlen lb)
+#endif
+{
+return(s_cmp(a,b,la,lb) <= 0);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/l_lt.c b/F2CLIBS/libf2c/l_lt.c
new file mode 100644
index 0000000..ab21b36
--- /dev/null
+++ b/F2CLIBS/libf2c/l_lt.c
@@ -0,0 +1,18 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+extern integer s_cmp();
+logical l_lt(a,b,la,lb) char *a, *b; ftnlen la, lb;
+#else
+extern integer s_cmp(char *, char *, ftnlen, ftnlen);
+logical l_lt(char *a, char *b, ftnlen la, ftnlen lb)
+#endif
+{
+return(s_cmp(a,b,la,lb) < 0);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/lbitbits.c b/F2CLIBS/libf2c/lbitbits.c
new file mode 100644
index 0000000..5b6ccf7
--- /dev/null
+++ b/F2CLIBS/libf2c/lbitbits.c
@@ -0,0 +1,68 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifndef LONGBITS
+#define LONGBITS 32
+#endif
+
+ integer
+#ifdef KR_headers
+lbit_bits(a, b, len) integer a, b, len;
+#else
+lbit_bits(integer a, integer b, integer len)
+#endif
+{
+ /* Assume 2's complement arithmetic */
+
+ unsigned long x, y;
+
+ x = (unsigned long) a;
+ y = (unsigned long)-1L;
+ x >>= b;
+ y <<= len;
+ return (integer)(x & ~y);
+ }
+
+ integer
+#ifdef KR_headers
+lbit_cshift(a, b, len) integer a, b, len;
+#else
+lbit_cshift(integer a, integer b, integer len)
+#endif
+{
+ unsigned long x, y, z;
+
+ x = (unsigned long)a;
+ if (len <= 0) {
+ if (len == 0)
+ return 0;
+ goto full_len;
+ }
+ if (len >= LONGBITS) {
+ full_len:
+ if (b >= 0) {
+ b %= LONGBITS;
+ return (integer)(x << b | x >> LONGBITS -b );
+ }
+ b = -b;
+ b %= LONGBITS;
+ return (integer)(x << LONGBITS - b | x >> b);
+ }
+ y = z = (unsigned long)-1;
+ y <<= len;
+ z &= ~y;
+ y &= x;
+ x &= z;
+ if (b >= 0) {
+ b %= len;
+ return (integer)(y | z & (x << b | x >> len - b));
+ }
+ b = -b;
+ b %= len;
+ return (integer)(y | z & (x >> b | x << len - b));
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/lbitshft.c b/F2CLIBS/libf2c/lbitshft.c
new file mode 100644
index 0000000..fbee94f
--- /dev/null
+++ b/F2CLIBS/libf2c/lbitshft.c
@@ -0,0 +1,17 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+ integer
+#ifdef KR_headers
+lbit_shift(a, b) integer a; integer b;
+#else
+lbit_shift(integer a, integer b)
+#endif
+{
+ return b >= 0 ? a << b : (integer)((uinteger)a >> -b);
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/libf2c.lbc b/F2CLIBS/libf2c/libf2c.lbc
new file mode 100644
index 0000000..c51c0aa
--- /dev/null
+++ b/F2CLIBS/libf2c/libf2c.lbc
@@ -0,0 +1,153 @@
+abort_.obj
+backspac.obj
+c_abs.obj
+c_cos.obj
+c_div.obj
+c_exp.obj
+c_log.obj
+c_sin.obj
+c_sqrt.obj
+cabs.obj
+close.obj
+d_abs.obj
+d_acos.obj
+d_asin.obj
+d_atan.obj
+d_atn2.obj
+d_cnjg.obj
+d_cos.obj
+d_cosh.obj
+d_dim.obj
+d_exp.obj
+d_imag.obj
+d_int.obj
+d_lg10.obj
+d_log.obj
+d_mod.obj
+d_nint.obj
+d_prod.obj
+d_sign.obj
+d_sin.obj
+d_sinh.obj
+d_sqrt.obj
+d_tan.obj
+d_tanh.obj
+derf_.obj
+derfc_.obj
+dfe.obj
+dolio.obj
+dtime_.obj
+due.obj
+ef1asc_.obj
+ef1cmc_.obj
+endfile.obj
+erf_.obj
+erfc_.obj
+err.obj
+etime_.obj
+exit_.obj
+f77_aloc.obj
+f77vers.obj
+fmt.obj
+fmtlib.obj
+ftell_.obj
+getarg_.obj
+getenv_.obj
+h_abs.obj
+h_dim.obj
+h_dnnt.obj
+h_indx.obj
+h_len.obj
+h_mod.obj
+h_nint.obj
+h_sign.obj
+hl_ge.obj
+hl_gt.obj
+hl_le.obj
+hl_lt.obj
+i77vers.obj
+i_abs.obj
+i_dim.obj
+i_dnnt.obj
+i_indx.obj
+i_len.obj
+i_mod.obj
+i_nint.obj
+i_sign.obj
+iargc_.obj
+iio.obj
+ilnw.obj
+inquire.obj
+l_ge.obj
+l_gt.obj
+l_le.obj
+l_lt.obj
+lbitbits.obj
+lbitshft.obj
+lread.obj
+lwrite.obj
+main.obj
+open.obj
+pow_ci.obj
+pow_dd.obj
+pow_di.obj
+pow_hh.obj
+pow_ii.obj
+pow_ri.obj
+pow_zi.obj
+pow_zz.obj
+r_abs.obj
+r_acos.obj
+r_asin.obj
+r_atan.obj
+r_atn2.obj
+r_cnjg.obj
+r_cos.obj
+r_cosh.obj
+r_dim.obj
+r_exp.obj
+r_imag.obj
+r_int.obj
+r_lg10.obj
+r_log.obj
+r_mod.obj
+r_nint.obj
+r_sign.obj
+r_sin.obj
+r_sinh.obj
+r_sqrt.obj
+r_tan.obj
+r_tanh.obj
+rdfmt.obj
+rewind.obj
+rsfe.obj
+rsli.obj
+rsne.obj
+s_cat.obj
+s_cmp.obj
+s_copy.obj
+s_paus.obj
+s_rnge.obj
+s_stop.obj
+sfe.obj
+sig_die.obj
+signal_.obj
+sue.obj
+system_.obj
+typesize.obj
+uio.obj
+uninit.obj
+util.obj
+wref.obj
+wrtfmt.obj
+wsfe.obj
+wsle.obj
+wsne.obj
+xwsne.obj
+z_abs.obj
+z_cos.obj
+z_div.obj
+z_exp.obj
+z_log.obj
+z_sin.obj
+z_sqrt.obj
diff --git a/F2CLIBS/libf2c/libf2c.sy b/F2CLIBS/libf2c/libf2c.sy
new file mode 100644
index 0000000..bcba643
--- /dev/null
+++ b/F2CLIBS/libf2c/libf2c.sy
@@ -0,0 +1,153 @@
++abort_.obj &
++backspac.obj &
++c_abs.obj &
++c_cos.obj &
++c_div.obj &
++c_exp.obj &
++c_log.obj &
++c_sin.obj &
++c_sqrt.obj &
++cabs.obj &
++close.obj &
++d_abs.obj &
++d_acos.obj &
++d_asin.obj &
++d_atan.obj &
++d_atn2.obj &
++d_cnjg.obj &
++d_cos.obj &
++d_cosh.obj &
++d_dim.obj &
++d_exp.obj &
++d_imag.obj &
++d_int.obj &
++d_lg10.obj &
++d_log.obj &
++d_mod.obj &
++d_nint.obj &
++d_prod.obj &
++d_sign.obj &
++d_sin.obj &
++d_sinh.obj &
++d_sqrt.obj &
++d_tan.obj &
++d_tanh.obj &
++derf_.obj &
++derfc_.obj &
++dfe.obj &
++dolio.obj &
++dtime_.obj &
++due.obj &
++ef1asc_.obj &
++ef1cmc_.obj &
++endfile.obj &
++erf_.obj &
++erfc_.obj &
++err.obj &
++etime_.obj &
++exit_.obj &
++f77_aloc.obj &
++f77vers.obj &
++fmt.obj &
++fmtlib.obj &
++ftell_.obj &
++getarg_.obj &
++getenv_.obj &
++h_abs.obj &
++h_dim.obj &
++h_dnnt.obj &
++h_indx.obj &
++h_len.obj &
++h_mod.obj &
++h_nint.obj &
++h_sign.obj &
++hl_ge.obj &
++hl_gt.obj &
++hl_le.obj &
++hl_lt.obj &
++i77vers.obj &
++i_abs.obj &
++i_dim.obj &
++i_dnnt.obj &
++i_indx.obj &
++i_len.obj &
++i_mod.obj &
++i_nint.obj &
++i_sign.obj &
++iargc_.obj &
++iio.obj &
++ilnw.obj &
++inquire.obj &
++l_ge.obj &
++l_gt.obj &
++l_le.obj &
++l_lt.obj &
++lbitbits.obj &
++lbitshft.obj &
++lread.obj &
++lwrite.obj &
++main.obj &
++open.obj &
++pow_ci.obj &
++pow_dd.obj &
++pow_di.obj &
++pow_hh.obj &
++pow_ii.obj &
++pow_ri.obj &
++pow_zi.obj &
++pow_zz.obj &
++r_abs.obj &
++r_acos.obj &
++r_asin.obj &
++r_atan.obj &
++r_atn2.obj &
++r_cnjg.obj &
++r_cos.obj &
++r_cosh.obj &
++r_dim.obj &
++r_exp.obj &
++r_imag.obj &
++r_int.obj &
++r_lg10.obj &
++r_log.obj &
++r_mod.obj &
++r_nint.obj &
++r_sign.obj &
++r_sin.obj &
++r_sinh.obj &
++r_sqrt.obj &
++r_tan.obj &
++r_tanh.obj &
++rdfmt.obj &
++rewind.obj &
++rsfe.obj &
++rsli.obj &
++rsne.obj &
++s_cat.obj &
++s_cmp.obj &
++s_copy.obj &
++s_paus.obj &
++s_rnge.obj &
++s_stop.obj &
++sfe.obj &
++sig_die.obj &
++signal_.obj &
++sue.obj &
++system_.obj &
++typesize.obj &
++uio.obj &
++uninit.obj &
++util.obj &
++wref.obj &
++wrtfmt.obj &
++wsfe.obj &
++wsle.obj &
++wsne.obj &
++xwsne.obj &
++z_abs.obj &
++z_cos.obj &
++z_div.obj &
++z_exp.obj &
++z_log.obj &
++z_sin.obj &
++z_sqrt.obj
diff --git a/F2CLIBS/libf2c/lio.h b/F2CLIBS/libf2c/lio.h
new file mode 100644
index 0000000..f9fd1cd
--- /dev/null
+++ b/F2CLIBS/libf2c/lio.h
@@ -0,0 +1,74 @@
+/* copy of ftypes from the compiler */
+/* variable types
+ * numeric assumptions:
+ * int < reals < complexes
+ * TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX
+ */
+
+/* 0-10 retain their old (pre LOGICAL*1, etc.) */
+/* values to allow mixing old and new objects. */
+
+#define TYUNKNOWN 0
+#define TYADDR 1
+#define TYSHORT 2
+#define TYLONG 3
+#define TYREAL 4
+#define TYDREAL 5
+#define TYCOMPLEX 6
+#define TYDCOMPLEX 7
+#define TYLOGICAL 8
+#define TYCHAR 9
+#define TYSUBR 10
+#define TYINT1 11
+#define TYLOGICAL1 12
+#define TYLOGICAL2 13
+#ifdef Allow_TYQUAD
+#undef TYQUAD
+#define TYQUAD 14
+#endif
+
+#define LINTW 24
+#define LINE 80
+#define LLOGW 2
+#ifdef Old_list_output
+#define LLOW 1.0
+#define LHIGH 1.e9
+#define LEFMT " %# .8E"
+#define LFFMT " %# .9g"
+#else
+#define LGFMT "%.9G"
+#endif
+/* LEFBL 20 should suffice; 24 overcomes a NeXT bug. */
+#define LEFBL 24
+
+typedef union
+{
+ char flchar;
+ short flshort;
+ ftnint flint;
+#ifdef Allow_TYQUAD
+ longint fllongint;
+#endif
+ real flreal;
+ doublereal fldouble;
+} flex;
+#ifdef KR_headers
+extern int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)();
+extern int l_read(), l_write();
+#else
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint);
+extern int l_write(ftnint*, char*, ftnlen, ftnint);
+extern void x_wsne(cilist*);
+extern int c_le(cilist*), (*l_getc)(void), (*l_ungetc)(int,FILE*);
+extern int l_read(ftnint*,char*,ftnlen,ftnint);
+extern integer e_rsle(void), e_wsle(void), s_wsne(cilist*);
+extern int z_rnew(void);
+#endif
+extern ftnint L_len;
+extern int f__scale;
+#ifdef __cplusplus
+ }
+#endif
diff --git a/F2CLIBS/libf2c/lread.c b/F2CLIBS/libf2c/lread.c
new file mode 100644
index 0000000..699cda1
--- /dev/null
+++ b/F2CLIBS/libf2c/lread.c
@@ -0,0 +1,806 @@
+#include "f2c.h"
+#include "fio.h"
+
+/* Compile with -DF8X_NML_ELIDE_QUOTES to permit eliding quotation */
+/* marks in namelist input a la the Fortran 8X Draft published in */
+/* the May 1989 issue of Fortran Forum. */
+
+
+#ifdef Allow_TYQUAD
+static longint f__llx;
+#endif
+
+#ifdef KR_headers
+extern double atof();
+extern char *malloc(), *realloc();
+int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)();
+#else
+#undef abs
+#undef min
+#undef max
+#include "stdlib.h"
+#endif
+
+#include "fmt.h"
+#include "lio.h"
+#include "ctype.h"
+#include "fp.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+extern char *f__fmtbuf;
+#else
+extern const char *f__fmtbuf;
+int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void),
+ (*l_ungetc)(int,FILE*);
+#endif
+
+int l_eof;
+
+#define isblnk(x) (f__ltab[x+1]&B)
+#define issep(x) (f__ltab[x+1]&SX)
+#define isapos(x) (f__ltab[x+1]&AX)
+#define isexp(x) (f__ltab[x+1]&EX)
+#define issign(x) (f__ltab[x+1]&SG)
+#define iswhit(x) (f__ltab[x+1]&WH)
+#define SX 1
+#define B 2
+#define AX 4
+#define EX 8
+#define SG 16
+#define WH 32
+char f__ltab[128+1] = { /* offset one for EOF */
+ 0,
+ 0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
+};
+
+#ifdef ungetc
+ static int
+#ifdef KR_headers
+un_getc(x,f__cf) int x; FILE *f__cf;
+#else
+un_getc(int x, FILE *f__cf)
+#endif
+{ return ungetc(x,f__cf); }
+#else
+#define un_getc ungetc
+#ifdef KR_headers
+ extern int ungetc();
+#else
+extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */
+#endif
+#endif
+
+ int
+t_getc(Void)
+{ int ch;
+ if(f__curunit->uend) return(EOF);
+ if((ch=getc(f__cf))!=EOF) return(ch);
+ if(feof(f__cf))
+ f__curunit->uend = l_eof = 1;
+ return(EOF);
+}
+integer e_rsle(Void)
+{
+ int ch;
+ if(f__curunit->uend) return(0);
+ while((ch=t_getc())!='\n')
+ if (ch == EOF) {
+ if(feof(f__cf))
+ f__curunit->uend = l_eof = 1;
+ return EOF;
+ }
+ return(0);
+}
+
+flag f__lquit;
+int f__lcount,f__ltype,nml_read;
+char *f__lchar;
+double f__lx,f__ly;
+#define ERR(x) if(n=(x)) return(n)
+#define GETC(x) (x=(*l_getc)())
+#define Ungetc(x,y) (*l_ungetc)(x,y)
+
+ static int
+#ifdef KR_headers
+l_R(poststar, reqint) int poststar, reqint;
+#else
+l_R(int poststar, int reqint)
+#endif
+{
+ char s[FMAX+EXPMAXDIGS+4];
+ register int ch;
+ register char *sp, *spe, *sp1;
+ long e, exp;
+ int havenum, havestar, se;
+
+ if (!poststar) {
+ if (f__lcount > 0)
+ return(0);
+ f__lcount = 1;
+ }
+#ifdef Allow_TYQUAD
+ f__llx = 0;
+#endif
+ f__ltype = 0;
+ exp = 0;
+ havestar = 0;
+retry:
+ sp1 = sp = s;
+ spe = sp + FMAX;
+ havenum = 0;
+
+ switch(GETC(ch)) {
+ case '-': *sp++ = ch; sp1++; spe++;
+ case '+':
+ GETC(ch);
+ }
+ while(ch == '0') {
+ ++havenum;
+ GETC(ch);
+ }
+ while(isdigit(ch)) {
+ if (sp < spe) *sp++ = ch;
+ else ++exp;
+ GETC(ch);
+ }
+ if (ch == '*' && !poststar) {
+ if (sp == sp1 || exp || *s == '-') {
+ errfl(f__elist->cierr,112,"bad repetition count");
+ }
+ poststar = havestar = 1;
+ *sp = 0;
+ f__lcount = atoi(s);
+ goto retry;
+ }
+ if (ch == '.') {
+#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
+ if (reqint)
+ errfl(f__elist->cierr,115,"invalid integer");
+#endif
+ GETC(ch);
+ if (sp == sp1)
+ while(ch == '0') {
+ ++havenum;
+ --exp;
+ GETC(ch);
+ }
+ while(isdigit(ch)) {
+ if (sp < spe)
+ { *sp++ = ch; --exp; }
+ GETC(ch);
+ }
+ }
+ havenum += sp - sp1;
+ se = 0;
+ if (issign(ch))
+ goto signonly;
+ if (havenum && isexp(ch)) {
+#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
+ if (reqint)
+ errfl(f__elist->cierr,115,"invalid integer");
+#endif
+ GETC(ch);
+ if (issign(ch)) {
+signonly:
+ if (ch == '-') se = 1;
+ GETC(ch);
+ }
+ if (!isdigit(ch)) {
+bad:
+ errfl(f__elist->cierr,112,"exponent field");
+ }
+
+ e = ch - '0';
+ while(isdigit(GETC(ch))) {
+ e = 10*e + ch - '0';
+ if (e > EXPMAX)
+ goto bad;
+ }
+ if (se)
+ exp -= e;
+ else
+ exp += e;
+ }
+ (void) Ungetc(ch, f__cf);
+ if (sp > sp1) {
+ ++havenum;
+ while(*--sp == '0')
+ ++exp;
+ if (exp)
+ sprintf(sp+1, "e%ld", exp);
+ else
+ sp[1] = 0;
+ f__lx = atof(s);
+#ifdef Allow_TYQUAD
+ if (reqint&2 && (se = sp - sp1 + exp) > 14 && se < 20) {
+ /* Assuming 64-bit longint and 32-bit long. */
+ if (exp < 0)
+ sp += exp;
+ if (sp1 <= sp) {
+ f__llx = *sp1 - '0';
+ while(++sp1 <= sp)
+ f__llx = 10*f__llx + (*sp1 - '0');
+ }
+ while(--exp >= 0)
+ f__llx *= 10;
+ if (*s == '-')
+ f__llx = -f__llx;
+ }
+#endif
+ }
+ else
+ f__lx = 0.;
+ if (havenum)
+ f__ltype = TYLONG;
+ else
+ switch(ch) {
+ case ',':
+ case '/':
+ break;
+ default:
+ if (havestar && ( ch == ' '
+ ||ch == '\t'
+ ||ch == '\n'))
+ break;
+ if (nml_read > 1) {
+ f__lquit = 2;
+ return 0;
+ }
+ errfl(f__elist->cierr,112,"invalid number");
+ }
+ return 0;
+ }
+
+ static int
+#ifdef KR_headers
+rd_count(ch) register int ch;
+#else
+rd_count(register int ch)
+#endif
+{
+ if (ch < '0' || ch > '9')
+ return 1;
+ f__lcount = ch - '0';
+ while(GETC(ch) >= '0' && ch <= '9')
+ f__lcount = 10*f__lcount + ch - '0';
+ Ungetc(ch,f__cf);
+ return f__lcount <= 0;
+ }
+
+ static int
+l_C(Void)
+{ int ch, nml_save;
+ double lz;
+ if(f__lcount>0) return(0);
+ f__ltype=0;
+ GETC(ch);
+ if(ch!='(')
+ {
+ if (nml_read > 1 && (ch < '0' || ch > '9')) {
+ Ungetc(ch,f__cf);
+ f__lquit = 2;
+ return 0;
+ }
+ if (rd_count(ch))
+ if(!f__cf || !feof(f__cf))
+ errfl(f__elist->cierr,112,"complex format");
+ else
+ err(f__elist->cierr,(EOF),"lread");
+ if(GETC(ch)!='*')
+ {
+ if(!f__cf || !feof(f__cf))
+ errfl(f__elist->cierr,112,"no star");
+ else
+ err(f__elist->cierr,(EOF),"lread");
+ }
+ if(GETC(ch)!='(')
+ { Ungetc(ch,f__cf);
+ return(0);
+ }
+ }
+ else
+ f__lcount = 1;
+ while(iswhit(GETC(ch)));
+ Ungetc(ch,f__cf);
+ nml_save = nml_read;
+ nml_read = 0;
+ if (ch = l_R(1,0))
+ return ch;
+ if (!f__ltype)
+ errfl(f__elist->cierr,112,"no real part");
+ lz = f__lx;
+ while(iswhit(GETC(ch)));
+ if(ch!=',')
+ { (void) Ungetc(ch,f__cf);
+ errfl(f__elist->cierr,112,"no comma");
+ }
+ while(iswhit(GETC(ch)));
+ (void) Ungetc(ch,f__cf);
+ if (ch = l_R(1,0))
+ return ch;
+ if (!f__ltype)
+ errfl(f__elist->cierr,112,"no imaginary part");
+ while(iswhit(GETC(ch)));
+ if(ch!=')') errfl(f__elist->cierr,112,"no )");
+ f__ly = f__lx;
+ f__lx = lz;
+#ifdef Allow_TYQUAD
+ f__llx = 0;
+#endif
+ nml_read = nml_save;
+ return(0);
+}
+
+ static char nmLbuf[256], *nmL_next;
+ static int (*nmL_getc_save)(Void);
+#ifdef KR_headers
+ static int (*nmL_ungetc_save)(/* int, FILE* */);
+#else
+ static int (*nmL_ungetc_save)(int, FILE*);
+#endif
+
+ static int
+nmL_getc(Void)
+{
+ int rv;
+ if (rv = *nmL_next++)
+ return rv;
+ l_getc = nmL_getc_save;
+ l_ungetc = nmL_ungetc_save;
+ return (*l_getc)();
+ }
+
+ static int
+#ifdef KR_headers
+nmL_ungetc(x, f) int x; FILE *f;
+#else
+nmL_ungetc(int x, FILE *f)
+#endif
+{
+ f = f; /* banish non-use warning */
+ return *--nmL_next = x;
+ }
+
+ static int
+#ifdef KR_headers
+Lfinish(ch, dot, rvp) int ch, dot, *rvp;
+#else
+Lfinish(int ch, int dot, int *rvp)
+#endif
+{
+ char *s, *se;
+ static char what[] = "namelist input";
+
+ s = nmLbuf + 2;
+ se = nmLbuf + sizeof(nmLbuf) - 1;
+ *s++ = ch;
+ while(!issep(GETC(ch)) && ch!=EOF) {
+ if (s >= se) {
+ nmLbuf_ovfl:
+ return *rvp = err__fl(f__elist->cierr,131,what);
+ }
+ *s++ = ch;
+ if (ch != '=')
+ continue;
+ if (dot)
+ return *rvp = err__fl(f__elist->cierr,112,what);
+ got_eq:
+ *s = 0;
+ nmL_getc_save = l_getc;
+ l_getc = nmL_getc;
+ nmL_ungetc_save = l_ungetc;
+ l_ungetc = nmL_ungetc;
+ nmLbuf[1] = *(nmL_next = nmLbuf) = ',';
+ *rvp = f__lcount = 0;
+ return 1;
+ }
+ if (dot)
+ goto done;
+ for(;;) {
+ if (s >= se)
+ goto nmLbuf_ovfl;
+ *s++ = ch;
+ if (!isblnk(ch))
+ break;
+ if (GETC(ch) == EOF)
+ goto done;
+ }
+ if (ch == '=')
+ goto got_eq;
+ done:
+ Ungetc(ch, f__cf);
+ return 0;
+ }
+
+ static int
+l_L(Void)
+{
+ int ch, rv, sawdot;
+
+ if(f__lcount>0)
+ return(0);
+ f__lcount = 1;
+ f__ltype=0;
+ GETC(ch);
+ if(isdigit(ch))
+ {
+ rd_count(ch);
+ if(GETC(ch)!='*')
+ if(!f__cf || !feof(f__cf))
+ errfl(f__elist->cierr,112,"no star");
+ else
+ err(f__elist->cierr,(EOF),"lread");
+ GETC(ch);
+ }
+ sawdot = 0;
+ if(ch == '.') {
+ sawdot = 1;
+ GETC(ch);
+ }
+ switch(ch)
+ {
+ case 't':
+ case 'T':
+ if (nml_read && Lfinish(ch, sawdot, &rv))
+ return rv;
+ f__lx=1;
+ break;
+ case 'f':
+ case 'F':
+ if (nml_read && Lfinish(ch, sawdot, &rv))
+ return rv;
+ f__lx=0;
+ break;
+ default:
+ if(isblnk(ch) || issep(ch) || ch==EOF)
+ { (void) Ungetc(ch,f__cf);
+ return(0);
+ }
+ if (nml_read > 1) {
+ Ungetc(ch,f__cf);
+ f__lquit = 2;
+ return 0;
+ }
+ errfl(f__elist->cierr,112,"logical");
+ }
+ f__ltype=TYLONG;
+ while(!issep(GETC(ch)) && ch!=EOF);
+ Ungetc(ch, f__cf);
+ return(0);
+}
+
+#define BUFSIZE 128
+
+ static int
+l_CHAR(Void)
+{ int ch,size,i;
+ static char rafail[] = "realloc failure";
+ char quote,*p;
+ if(f__lcount>0) return(0);
+ f__ltype=0;
+ if(f__lchar!=NULL) free(f__lchar);
+ size=BUFSIZE;
+ p=f__lchar = (char *)malloc((unsigned int)size);
+ if(f__lchar == NULL)
+ errfl(f__elist->cierr,113,"no space");
+
+ GETC(ch);
+ if(isdigit(ch)) {
+ /* allow Fortran 8x-style unquoted string... */
+ /* either find a repetition count or the string */
+ f__lcount = ch - '0';
+ *p++ = ch;
+ for(i = 1;;) {
+ switch(GETC(ch)) {
+ case '*':
+ if (f__lcount == 0) {
+ f__lcount = 1;
+#ifndef F8X_NML_ELIDE_QUOTES
+ if (nml_read)
+ goto no_quote;
+#endif
+ goto noquote;
+ }
+ p = f__lchar;
+ goto have_lcount;
+ case ',':
+ case ' ':
+ case '\t':
+ case '\n':
+ case '/':
+ Ungetc(ch,f__cf);
+ /* no break */
+ case EOF:
+ f__lcount = 1;
+ f__ltype = TYCHAR;
+ return *p = 0;
+ }
+ if (!isdigit(ch)) {
+ f__lcount = 1;
+#ifndef F8X_NML_ELIDE_QUOTES
+ if (nml_read) {
+ no_quote:
+ errfl(f__elist->cierr,112,
+ "undelimited character string");
+ }
+#endif
+ goto noquote;
+ }
+ *p++ = ch;
+ f__lcount = 10*f__lcount + ch - '0';
+ if (++i == size) {
+ f__lchar = (char *)realloc(f__lchar,
+ (unsigned int)(size += BUFSIZE));
+ if(f__lchar == NULL)
+ errfl(f__elist->cierr,113,rafail);
+ p = f__lchar + i;
+ }
+ }
+ }
+ else (void) Ungetc(ch,f__cf);
+ have_lcount:
+ if(GETC(ch)=='\'' || ch=='"') quote=ch;
+ else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) {
+ Ungetc(ch,f__cf);
+ return 0;
+ }
+#ifndef F8X_NML_ELIDE_QUOTES
+ else if (nml_read > 1) {
+ Ungetc(ch,f__cf);
+ f__lquit = 2;
+ return 0;
+ }
+#endif
+ else {
+ /* Fortran 8x-style unquoted string */
+ *p++ = ch;
+ for(i = 1;;) {
+ switch(GETC(ch)) {
+ case ',':
+ case ' ':
+ case '\t':
+ case '\n':
+ case '/':
+ Ungetc(ch,f__cf);
+ /* no break */
+ case EOF:
+ f__ltype = TYCHAR;
+ return *p = 0;
+ }
+ noquote:
+ *p++ = ch;
+ if (++i == size) {
+ f__lchar = (char *)realloc(f__lchar,
+ (unsigned int)(size += BUFSIZE));
+ if(f__lchar == NULL)
+ errfl(f__elist->cierr,113,rafail);
+ p = f__lchar + i;
+ }
+ }
+ }
+ f__ltype=TYCHAR;
+ for(i=0;;)
+ { while(GETC(ch)!=quote && ch!='\n'
+ && ch!=EOF && ++i<size) *p++ = ch;
+ if(i==size)
+ {
+ newone:
+ f__lchar= (char *)realloc(f__lchar,
+ (unsigned int)(size += BUFSIZE));
+ if(f__lchar == NULL)
+ errfl(f__elist->cierr,113,rafail);
+ p=f__lchar+i-1;
+ *p++ = ch;
+ }
+ else if(ch==EOF) return(EOF);
+ else if(ch=='\n')
+ { if(*(p-1) != '\\') continue;
+ i--;
+ p--;
+ if(++i<size) *p++ = ch;
+ else goto newone;
+ }
+ else if(GETC(ch)==quote)
+ { if(++i<size) *p++ = ch;
+ else goto newone;
+ }
+ else
+ { (void) Ungetc(ch,f__cf);
+ *p = 0;
+ return(0);
+ }
+ }
+}
+
+ int
+#ifdef KR_headers
+c_le(a) cilist *a;
+#else
+c_le(cilist *a)
+#endif
+{
+ if(!f__init)
+ f_init();
+ f__fmtbuf="list io";
+ f__curunit = &f__units[a->ciunit];
+ if(a->ciunit>=MXUNIT || a->ciunit<0)
+ err(a->cierr,101,"stler");
+ f__scale=f__recpos=0;
+ f__elist=a;
+ if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
+ err(a->cierr,102,"lio");
+ f__cf=f__curunit->ufd;
+ if(!f__curunit->ufmt) err(a->cierr,103,"lio")
+ return(0);
+}
+
+ int
+#ifdef KR_headers
+l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
+#else
+l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
+#endif
+{
+#define Ptr ((flex *)ptr)
+ int i,n,ch;
+ doublereal *yy;
+ real *xx;
+ for(i=0;i<*number;i++)
+ {
+ if(f__lquit) return(0);
+ if(l_eof)
+ err(f__elist->ciend, EOF, "list in")
+ if(f__lcount == 0) {
+ f__ltype = 0;
+ for(;;) {
+ GETC(ch);
+ switch(ch) {
+ case EOF:
+ err(f__elist->ciend,(EOF),"list in")
+ case ' ':
+ case '\t':
+ case '\n':
+ continue;
+ case '/':
+ f__lquit = 1;
+ goto loopend;
+ case ',':
+ f__lcount = 1;
+ goto loopend;
+ default:
+ (void) Ungetc(ch, f__cf);
+ goto rddata;
+ }
+ }
+ }
+ rddata:
+ switch((int)type)
+ {
+ case TYINT1:
+ case TYSHORT:
+ case TYLONG:
+#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
+ ERR(l_R(0,1));
+ break;
+#endif
+ case TYREAL:
+ case TYDREAL:
+ ERR(l_R(0,0));
+ break;
+#ifdef TYQUAD
+ case TYQUAD:
+ n = l_R(0,2);
+ if (n)
+ return n;
+ break;
+#endif
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ ERR(l_C());
+ break;
+ case TYLOGICAL1:
+ case TYLOGICAL2:
+ case TYLOGICAL:
+ ERR(l_L());
+ break;
+ case TYCHAR:
+ ERR(l_CHAR());
+ break;
+ }
+ while (GETC(ch) == ' ' || ch == '\t');
+ if (ch != ',' || f__lcount > 1)
+ Ungetc(ch,f__cf);
+ loopend:
+ if(f__lquit) return(0);
+ if(f__cf && ferror(f__cf)) {
+ clearerr(f__cf);
+ errfl(f__elist->cierr,errno,"list in");
+ }
+ if(f__ltype==0) goto bump;
+ switch((int)type)
+ {
+ case TYINT1:
+ case TYLOGICAL1:
+ Ptr->flchar = (char)f__lx;
+ break;
+ case TYLOGICAL2:
+ case TYSHORT:
+ Ptr->flshort = (short)f__lx;
+ break;
+ case TYLOGICAL:
+ case TYLONG:
+ Ptr->flint = (ftnint)f__lx;
+ break;
+#ifdef Allow_TYQUAD
+ case TYQUAD:
+ if (!(Ptr->fllongint = f__llx))
+ Ptr->fllongint = f__lx;
+ break;
+#endif
+ case TYREAL:
+ Ptr->flreal=f__lx;
+ break;
+ case TYDREAL:
+ Ptr->fldouble=f__lx;
+ break;
+ case TYCOMPLEX:
+ xx=(real *)ptr;
+ *xx++ = f__lx;
+ *xx = f__ly;
+ break;
+ case TYDCOMPLEX:
+ yy=(doublereal *)ptr;
+ *yy++ = f__lx;
+ *yy = f__ly;
+ break;
+ case TYCHAR:
+ b_char(f__lchar,ptr,len);
+ break;
+ }
+ bump:
+ if(f__lcount>0) f__lcount--;
+ ptr += len;
+ if (nml_read)
+ nml_read++;
+ }
+ return(0);
+#undef Ptr
+}
+#ifdef KR_headers
+integer s_rsle(a) cilist *a;
+#else
+integer s_rsle(cilist *a)
+#endif
+{
+ int n;
+
+ f__reading=1;
+ f__external=1;
+ f__formatted=1;
+ if(n=c_le(a)) return(n);
+ f__lioproc = l_read;
+ f__lquit = 0;
+ f__lcount = 0;
+ l_eof = 0;
+ if(f__curunit->uwrt && f__nowreading(f__curunit))
+ err(a->cierr,errno,"read start");
+ if(f__curunit->uend)
+ err(f__elist->ciend,(EOF),"read start");
+ l_getc = t_getc;
+ l_ungetc = un_getc;
+ f__doend = xrd_SL;
+ return(0);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/lwrite.c b/F2CLIBS/libf2c/lwrite.c
new file mode 100644
index 0000000..9e0d93d
--- /dev/null
+++ b/F2CLIBS/libf2c/lwrite.c
@@ -0,0 +1,314 @@
+#include "f2c.h"
+#include "fio.h"
+#include "fmt.h"
+#include "lio.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+ftnint L_len;
+int f__Aquote;
+
+ static VOID
+donewrec(Void)
+{
+ if (f__recpos)
+ (*f__donewrec)();
+ }
+
+ static VOID
+#ifdef KR_headers
+lwrt_I(n) longint n;
+#else
+lwrt_I(longint n)
+#endif
+{
+ char *p;
+ int ndigit, sign;
+
+ p = f__icvt(n, &ndigit, &sign, 10);
+ if(f__recpos + ndigit >= L_len)
+ donewrec();
+ PUT(' ');
+ if (sign)
+ PUT('-');
+ while(*p)
+ PUT(*p++);
+}
+ static VOID
+#ifdef KR_headers
+lwrt_L(n, len) ftnint n; ftnlen len;
+#else
+lwrt_L(ftnint n, ftnlen len)
+#endif
+{
+ if(f__recpos+LLOGW>=L_len)
+ donewrec();
+ wrt_L((Uint *)&n,LLOGW, len);
+}
+ static VOID
+#ifdef KR_headers
+lwrt_A(p,len) char *p; ftnlen len;
+#else
+lwrt_A(char *p, ftnlen len)
+#endif
+{
+ int a;
+ char *p1, *pe;
+
+ a = 0;
+ pe = p + len;
+ if (f__Aquote) {
+ a = 3;
+ if (len > 1 && p[len-1] == ' ') {
+ while(--len > 1 && p[len-1] == ' ');
+ pe = p + len;
+ }
+ p1 = p;
+ while(p1 < pe)
+ if (*p1++ == '\'')
+ a++;
+ }
+ if(f__recpos+len+a >= L_len)
+ donewrec();
+ if (a
+#ifndef OMIT_BLANK_CC
+ || !f__recpos
+#endif
+ )
+ PUT(' ');
+ if (a) {
+ PUT('\'');
+ while(p < pe) {
+ if (*p == '\'')
+ PUT('\'');
+ PUT(*p++);
+ }
+ PUT('\'');
+ }
+ else
+ while(p < pe)
+ PUT(*p++);
+}
+
+ static int
+#ifdef KR_headers
+l_g(buf, n) char *buf; double n;
+#else
+l_g(char *buf, double n)
+#endif
+{
+#ifdef Old_list_output
+ doublereal absn;
+ char *fmt;
+
+ absn = n;
+ if (absn < 0)
+ absn = -absn;
+ fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT;
+#ifdef USE_STRLEN
+ sprintf(buf, fmt, n);
+ return strlen(buf);
+#else
+ return sprintf(buf, fmt, n);
+#endif
+
+#else
+ register char *b, c, c1;
+
+ b = buf;
+ *b++ = ' ';
+ if (n < 0) {
+ *b++ = '-';
+ n = -n;
+ }
+ else
+ *b++ = ' ';
+ if (n == 0) {
+#ifdef SIGNED_ZEROS
+ if (signbit_f2c(&n))
+ *b++ = '-';
+#endif
+ *b++ = '0';
+ *b++ = '.';
+ *b = 0;
+ goto f__ret;
+ }
+ sprintf(b, LGFMT, n);
+ switch(*b) {
+#ifndef WANT_LEAD_0
+ case '0':
+ while(b[0] = b[1])
+ b++;
+ break;
+#endif
+ case 'i':
+ case 'I':
+ /* Infinity */
+ case 'n':
+ case 'N':
+ /* NaN */
+ while(*++b);
+ break;
+
+ default:
+ /* Fortran 77 insists on having a decimal point... */
+ for(;; b++)
+ switch(*b) {
+ case 0:
+ *b++ = '.';
+ *b = 0;
+ goto f__ret;
+ case '.':
+ while(*++b);
+ goto f__ret;
+ case 'E':
+ for(c1 = '.', c = 'E'; *b = c1;
+ c1 = c, c = *++b);
+ goto f__ret;
+ }
+ }
+ f__ret:
+ return b - buf;
+#endif
+ }
+
+ static VOID
+#ifdef KR_headers
+l_put(s) register char *s;
+#else
+l_put(register char *s)
+#endif
+{
+#ifdef KR_headers
+ register void (*pn)() = f__putn;
+#else
+ register void (*pn)(int) = f__putn;
+#endif
+ register int c;
+
+ while(c = *s++)
+ (*pn)(c);
+ }
+
+ static VOID
+#ifdef KR_headers
+lwrt_F(n) double n;
+#else
+lwrt_F(double n)
+#endif
+{
+ char buf[LEFBL];
+
+ if(f__recpos + l_g(buf,n) >= L_len)
+ donewrec();
+ l_put(buf);
+}
+ static VOID
+#ifdef KR_headers
+lwrt_C(a,b) double a,b;
+#else
+lwrt_C(double a, double b)
+#endif
+{
+ char *ba, *bb, bufa[LEFBL], bufb[LEFBL];
+ int al, bl;
+
+ al = l_g(bufa, a);
+ for(ba = bufa; *ba == ' '; ba++)
+ --al;
+ bl = l_g(bufb, b) + 1; /* intentionally high by 1 */
+ for(bb = bufb; *bb == ' '; bb++)
+ --bl;
+ if(f__recpos + al + bl + 3 >= L_len)
+ donewrec();
+#ifdef OMIT_BLANK_CC
+ else
+#endif
+ PUT(' ');
+ PUT('(');
+ l_put(ba);
+ PUT(',');
+ if (f__recpos + bl >= L_len) {
+ (*f__donewrec)();
+#ifndef OMIT_BLANK_CC
+ PUT(' ');
+#endif
+ }
+ l_put(bb);
+ PUT(')');
+}
+
+ int
+#ifdef KR_headers
+l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
+#else
+l_write(ftnint *number, char *ptr, ftnlen len, ftnint type)
+#endif
+{
+#define Ptr ((flex *)ptr)
+ int i;
+ longint x;
+ double y,z;
+ real *xx;
+ doublereal *yy;
+ for(i=0;i< *number; i++)
+ {
+ switch((int)type)
+ {
+ default: f__fatal(117,"unknown type in lio");
+ case TYINT1:
+ x = Ptr->flchar;
+ goto xint;
+ case TYSHORT:
+ x=Ptr->flshort;
+ goto xint;
+#ifdef Allow_TYQUAD
+ case TYQUAD:
+ x = Ptr->fllongint;
+ goto xint;
+#endif
+ case TYLONG:
+ x=Ptr->flint;
+ xint: lwrt_I(x);
+ break;
+ case TYREAL:
+ y=Ptr->flreal;
+ goto xfloat;
+ case TYDREAL:
+ y=Ptr->fldouble;
+ xfloat: lwrt_F(y);
+ break;
+ case TYCOMPLEX:
+ xx= &Ptr->flreal;
+ y = *xx++;
+ z = *xx;
+ goto xcomplex;
+ case TYDCOMPLEX:
+ yy = &Ptr->fldouble;
+ y= *yy++;
+ z = *yy;
+ xcomplex:
+ lwrt_C(y,z);
+ break;
+ case TYLOGICAL1:
+ x = Ptr->flchar;
+ goto xlog;
+ case TYLOGICAL2:
+ x = Ptr->flshort;
+ goto xlog;
+ case TYLOGICAL:
+ x = Ptr->flint;
+ xlog: lwrt_L(Ptr->flint, len);
+ break;
+ case TYCHAR:
+ lwrt_A(ptr,len);
+ break;
+ }
+ ptr += len;
+ }
+ return(0);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/main.c b/F2CLIBS/libf2c/main.c
new file mode 100644
index 0000000..d95fdc9
--- /dev/null
+++ b/F2CLIBS/libf2c/main.c
@@ -0,0 +1,148 @@
+/* STARTUP PROCEDURE FOR UNIX FORTRAN PROGRAMS */
+
+#include "stdio.h"
+#include "signal1.h"
+
+#ifndef SIGIOT
+#ifdef SIGABRT
+#define SIGIOT SIGABRT
+#endif
+#endif
+
+#ifndef KR_headers
+#undef VOID
+#include "stdlib.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+#endif
+
+#ifndef VOID
+#define VOID void
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef NO__STDC
+#define ONEXIT onexit
+extern VOID f_exit();
+#else
+#ifndef KR_headers
+extern void f_exit(void);
+#ifndef NO_ONEXIT
+#define ONEXIT atexit
+extern int atexit(void (*)(void));
+#endif
+#else
+#ifndef NO_ONEXIT
+#define ONEXIT onexit
+extern VOID f_exit();
+#endif
+#endif
+#endif
+
+#ifdef KR_headers
+extern VOID f_init(), sig_die();
+extern int MAIN__();
+#define Int /* int */
+#else
+extern void f_init(void), sig_die(const char*, int);
+extern int MAIN__(void);
+#define Int int
+#endif
+
+static VOID sigfdie(Sigarg)
+{
+Use_Sigarg;
+sig_die("Floating Exception", 1);
+}
+
+
+static VOID sigidie(Sigarg)
+{
+Use_Sigarg;
+sig_die("IOT Trap", 1);
+}
+
+#ifdef SIGQUIT
+static VOID sigqdie(Sigarg)
+{
+Use_Sigarg;
+sig_die("Quit signal", 1);
+}
+#endif
+
+
+static VOID sigindie(Sigarg)
+{
+Use_Sigarg;
+sig_die("Interrupt", 0);
+}
+
+static VOID sigtdie(Sigarg)
+{
+Use_Sigarg;
+sig_die("Killed", 0);
+}
+
+#ifdef SIGTRAP
+static VOID sigtrdie(Sigarg)
+{
+Use_Sigarg;
+sig_die("Trace trap", 1);
+}
+#endif
+
+
+int xargc;
+char **xargv;
+
+#ifdef __cplusplus
+ }
+#endif
+
+ int
+#ifdef KR_headers
+main(argc, argv) int argc; char **argv;
+#else
+main(int argc, char **argv)
+#endif
+{
+xargc = argc;
+xargv = argv;
+signal1(SIGFPE, sigfdie); /* ignore underflow, enable overflow */
+#ifdef SIGIOT
+signal1(SIGIOT, sigidie);
+#endif
+#ifdef SIGTRAP
+signal1(SIGTRAP, sigtrdie);
+#endif
+#ifdef SIGQUIT
+if(signal1(SIGQUIT,sigqdie) == SIG_IGN)
+ signal1(SIGQUIT, SIG_IGN);
+#endif
+if(signal1(SIGINT, sigindie) == SIG_IGN)
+ signal1(SIGINT, SIG_IGN);
+signal1(SIGTERM,sigtdie);
+
+#ifdef pdp11
+ ldfps(01200); /* detect overflow as an exception */
+#endif
+
+f_init();
+#ifndef NO_ONEXIT
+ONEXIT(f_exit);
+#endif
+MAIN__();
+#ifdef NO_ONEXIT
+f_exit();
+#endif
+exit(0); /* exit(0) rather than return(0) to bypass Cray bug */
+return 0; /* For compilers that complain of missing return values; */
+ /* others will complain that this is unreachable code. */
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/math.hvc b/F2CLIBS/libf2c/math.hvc
new file mode 100644
index 0000000..52cfcee
--- /dev/null
+++ b/F2CLIBS/libf2c/math.hvc
@@ -0,0 +1,3 @@
+/* for VC 4.2 */
+#include <math.h>
+#undef complex
diff --git a/F2CLIBS/libf2c/mkfile.plan9 b/F2CLIBS/libf2c/mkfile.plan9
new file mode 100644
index 0000000..645e33d
--- /dev/null
+++ b/F2CLIBS/libf2c/mkfile.plan9
@@ -0,0 +1,162 @@
+# Plan 9 mkfile for libf2c.a$O
+
+</$objtype/mkfile
+
+CC = pcc
+CFLAGS = -D_POSIX_SOURCE -DNON_UNIX_STDIO -DNO_TRUNCATE
+
+%.$O: %.c
+ $CC -c $CFLAGS $stem.c
+
+MISC = f77vers.$O i77vers.$O main.$O s_rnge.$O abort_.$O exit_.$O\
+ getarg_.$O iargc_.$O\
+ getenv_.$O signal_.$O s_stop.$O s_paus.$O system_.$O cabs.$O\
+ derf_.$O derfc_.$O erf_.$O erfc_.$O sig_die.$O uninit.$O
+POW = pow_ci.$O pow_dd.$O pow_di.$O pow_hh.$O pow_ii.$O pow_ri.$O\
+ pow_zi.$O pow_zz.$O
+CX = c_abs.$O c_cos.$O c_div.$O c_exp.$O c_log.$O c_sin.$O c_sqrt.$O
+DCX = z_abs.$O z_cos.$O z_div.$O z_exp.$O z_log.$O z_sin.$O z_sqrt.$O
+REAL = r_abs.$O r_acos.$O r_asin.$O r_atan.$O r_atn2.$O r_cnjg.$O r_cos.$O\
+ r_cosh.$O r_dim.$O r_exp.$O r_imag.$O r_int.$O\
+ r_lg10.$O r_log.$O r_mod.$O r_nint.$O r_sign.$O\
+ r_sin.$O r_sinh.$O r_sqrt.$O r_tan.$O r_tanh.$O
+DBL = d_abs.$O d_acos.$O d_asin.$O d_atan.$O d_atn2.$O\
+ d_cnjg.$O d_cos.$O d_cosh.$O d_dim.$O d_exp.$O\
+ d_imag.$O d_int.$O d_lg10.$O d_log.$O d_mod.$O\
+ d_nint.$O d_prod.$O d_sign.$O d_sin.$O d_sinh.$O\
+ d_sqrt.$O d_tan.$O d_tanh.$O
+INT = i_abs.$O i_dim.$O i_dnnt.$O i_indx.$O i_len.$O i_mod.$O\
+ i_nint.$O i_sign.$O lbitbits.$O lbitshft.$O
+HALF = h_abs.$O h_dim.$O h_dnnt.$O h_indx.$O h_len.$O h_mod.$O\
+ h_nint.$O h_sign.$O
+CMP = l_ge.$O l_gt.$O l_le.$O l_lt.$O hl_ge.$O hl_gt.$O hl_le.$O hl_lt.$O
+EFL = ef1asc_.$O ef1cmc_.$O
+CHAR = f77_aloc.$O s_cat.$O s_cmp.$O s_copy.$O
+I77 = backspac.$O close.$O dfe.$O dolio.$O due.$O endfile.$O err.$O\
+ fmt.$O fmtlib.$O ftell_.$O iio.$O ilnw.$O inquire.$O lread.$O\
+ lwrite.$O open.$O rdfmt.$O rewind.$O rsfe.$O rsli.$O rsne.$O\
+ sfe.$O sue.$O typesize.$O uio.$O util.$O wref.$O wrtfmt.$O\
+ wsfe.$O wsle.$O wsne.$O xwsne.$O
+QINT = pow_qq.$O qbitbits.$O qbitshft.$O
+TIME = dtime_.$O etime_.$O
+
+# pcc does not currently (20010222) understand unsigned long long
+# so we omit $QINT from the dependency list for libf2c.a$O.
+
+all:N: f2c.h signal1.h libf2c.a$O
+
+libf2c.a$O: $MISC $POW $CX $DCX $REAL $DBL $INT \
+ $HALF $CMP $EFL $CHAR $I77 $TIME
+ ar r $target $newprereq
+ rm $newprereq
+
+### If your system lacks ranlib, you don't need it; see README.; set -e
+
+f77vers.$O: f77vers.c
+ $CC -c f77vers.c
+
+i77vers.$O: i77vers.c
+ $CC -c i77vers.c
+
+# To get an "f2c.h" for use with "f2c -C++", first "make hadd"
+hadd: f2c.h0 f2ch.add
+ cat f2c.h0 f2ch.add >f2c.h
+
+# For use with "f2c" and "f2c -A":
+f2c.h: f2c.h0
+ cp f2c.h0 f2c.h
+
+# You may need to adjust signal1.h suitably for your system...
+signal1.h: signal1.h0
+ cp signal1.h0 signal1.h
+
+clean:
+ rm -f libf2c.a$O *.$O arith.h
+
+backspac.$O: fio.h
+close.$O: fio.h
+dfe.$O: fio.h
+dfe.$O: fmt.h
+due.$O: fio.h
+endfile.$O: fio.h rawio.h
+err.$O: fio.h rawio.h
+fmt.$O: fio.h
+fmt.$O: fmt.h
+iio.$O: fio.h
+iio.$O: fmt.h
+ilnw.$O: fio.h
+ilnw.$O: lio.h
+inquire.$O: fio.h
+lread.$O: fio.h
+lread.$O: fmt.h
+lread.$O: lio.h
+lread.$O: fp.h
+lwrite.$O: fio.h
+lwrite.$O: fmt.h
+lwrite.$O: lio.h
+open.$O: fio.h rawio.h
+rdfmt.$O: fio.h
+rdfmt.$O: fmt.h
+rdfmt.$O: fp.h
+rewind.$O: fio.h
+rsfe.$O: fio.h
+rsfe.$O: fmt.h
+rsli.$O: fio.h
+rsli.$O: lio.h
+rsne.$O: fio.h
+rsne.$O: lio.h
+sfe.$O: fio.h
+sue.$O: fio.h
+uio.$O: fio.h
+uninit.$O: arith.h
+util.$O: fio.h
+wref.$O: fio.h
+wref.$O: fmt.h
+wref.$O: fp.h
+wrtfmt.$O: fio.h
+wrtfmt.$O: fmt.h
+wsfe.$O: fio.h
+wsfe.$O: fmt.h
+wsle.$O: fio.h
+wsle.$O: fmt.h
+wsle.$O: lio.h
+wsne.$O: fio.h
+wsne.$O: lio.h
+xwsne.$O: fio.h
+xwsne.$O: lio.h
+xwsne.$O: fmt.h
+
+arith.h: arithchk.c
+ pcc -DNO_FPINIT -o arithchk arithchk.c
+ arithchk >$target
+ rm arithchk
+
+xsum.out:V: check
+
+check:
+ xsum Notice README abort_.c arithchk.c backspac.c c_abs.c c_cos.c \
+ c_div.c c_exp.c c_log.c c_sin.c c_sqrt.c cabs.c close.c comptry.bat \
+ d_abs.c d_acos.c d_asin.c d_atan.c d_atn2.c d_cnjg.c d_cos.c d_cosh.c \
+ d_dim.c d_exp.c d_imag.c d_int.c d_lg10.c d_log.c d_mod.c \
+ d_nint.c d_prod.c d_sign.c d_sin.c d_sinh.c d_sqrt.c d_tan.c \
+ d_tanh.c derf_.c derfc_.c dfe.c dolio.c dtime_.c due.c ef1asc_.c \
+ ef1cmc_.c endfile.c erf_.c erfc_.c err.c etime_.c exit_.c f2c.h0 \
+ f2ch.add f77_aloc.c f77vers.c fio.h fmt.c fmt.h fmtlib.c \
+ fp.h ftell_.c \
+ getarg_.c getenv_.c h_abs.c h_dim.c h_dnnt.c h_indx.c h_len.c \
+ h_mod.c h_nint.c h_sign.c hl_ge.c hl_gt.c hl_le.c hl_lt.c \
+ i77vers.c i_abs.c i_dim.c i_dnnt.c i_indx.c i_len.c i_mod.c \
+ i_nint.c i_sign.c iargc_.c iio.c ilnw.c inquire.c l_ge.c l_gt.c \
+ l_le.c l_lt.c lbitbits.c lbitshft.c libf2c.lbc libf2c.sy lio.h \
+ lread.c lwrite.c main.c makefile.sy makefile.u makefile.vc \
+ makefile.wat math.hvc mkfile.plan9 open.c pow_ci.c pow_dd.c \
+ pow_di.c pow_hh.c pow_ii.c pow_qq.c pow_ri.c pow_zi.c pow_zz.c \
+ qbitbits.c qbitshft.c r_abs.c r_acos.c r_asin.c r_atan.c r_atn2.c \
+ r_cnjg.c r_cos.c r_cosh.c r_dim.c r_exp.c r_imag.c r_int.c r_lg10.c \
+ r_log.c r_mod.c r_nint.c r_sign.c r_sin.c r_sinh.c r_sqrt.c \
+ r_tan.c r_tanh.c rawio.h rdfmt.c rewind.c rsfe.c rsli.c rsne.c \
+ s_cat.c s_cmp.c s_copy.c s_paus.c s_rnge.c s_stop.c sfe.c \
+ sig_die.c signal1.h0 signal_.c sue.c system_.c typesize.c uio.c \
+ uninit.c util.c wref.c wrtfmt.c wsfe.c wsle.c wsne.c xwsne.c \
+ z_abs.c z_cos.c z_div.c z_exp.c z_log.c z_sin.c z_sqrt.c >xsum1.out
+ cmp xsum0.out xsum1.out && mv xsum1.out xsum.out || diff xsum[01].out
diff --git a/F2CLIBS/libf2c/open.c b/F2CLIBS/libf2c/open.c
new file mode 100644
index 0000000..a06428d
--- /dev/null
+++ b/F2CLIBS/libf2c/open.c
@@ -0,0 +1,301 @@
+#include "f2c.h"
+#include "fio.h"
+#include "string.h"
+#ifndef NON_POSIX_STDIO
+#ifdef MSDOS
+#include "io.h"
+#else
+#include "unistd.h" /* for access */
+#endif
+#endif
+
+#ifdef KR_headers
+extern char *malloc();
+#ifdef NON_ANSI_STDIO
+extern char *mktemp();
+#endif
+extern integer f_clos();
+#define Const /*nothing*/
+#else
+#define Const const
+#undef abs
+#undef min
+#undef max
+#include "stdlib.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern int f__canseek(FILE*);
+extern integer f_clos(cllist*);
+#endif
+
+#ifdef NON_ANSI_RW_MODES
+Const char *f__r_mode[2] = {"r", "r"};
+Const char *f__w_mode[4] = {"w", "w", "r+w", "r+w"};
+#else
+Const char *f__r_mode[2] = {"rb", "r"};
+Const char *f__w_mode[4] = {"wb", "w", "r+b", "r+"};
+#endif
+
+ static char f__buf0[400], *f__buf = f__buf0;
+ int f__buflen = (int)sizeof(f__buf0);
+
+ static void
+#ifdef KR_headers
+f__bufadj(n, c) int n, c;
+#else
+f__bufadj(int n, int c)
+#endif
+{
+ unsigned int len;
+ char *nbuf, *s, *t, *te;
+
+ if (f__buf == f__buf0)
+ f__buflen = 1024;
+ while(f__buflen <= n)
+ f__buflen <<= 1;
+ len = (unsigned int)f__buflen;
+ if (len != f__buflen || !(nbuf = (char*)malloc(len)))
+ f__fatal(113, "malloc failure");
+ s = nbuf;
+ t = f__buf;
+ te = t + c;
+ while(t < te)
+ *s++ = *t++;
+ if (f__buf != f__buf0)
+ free(f__buf);
+ f__buf = nbuf;
+ }
+
+ int
+#ifdef KR_headers
+f__putbuf(c) int c;
+#else
+f__putbuf(int c)
+#endif
+{
+ char *s, *se;
+ int n;
+
+ if (f__hiwater > f__recpos)
+ f__recpos = f__hiwater;
+ n = f__recpos + 1;
+ if (n >= f__buflen)
+ f__bufadj(n, f__recpos);
+ s = f__buf;
+ se = s + f__recpos;
+ if (c)
+ *se++ = c;
+ *se = 0;
+ for(;;) {
+ fputs(s, f__cf);
+ s += strlen(s);
+ if (s >= se)
+ break; /* normally happens the first time */
+ putc(*s++, f__cf);
+ }
+ return 0;
+ }
+
+ void
+#ifdef KR_headers
+x_putc(c)
+#else
+x_putc(int c)
+#endif
+{
+ if (f__recpos >= f__buflen)
+ f__bufadj(f__recpos, f__buflen);
+ f__buf[f__recpos++] = c;
+ }
+
+#define opnerr(f,m,s) {if(f) errno= m; else opn_err(m,s,a); return(m);}
+
+ static void
+#ifdef KR_headers
+opn_err(m, s, a) int m; char *s; olist *a;
+#else
+opn_err(int m, const char *s, olist *a)
+#endif
+{
+ if (a->ofnm) {
+ /* supply file name to error message */
+ if (a->ofnmlen >= f__buflen)
+ f__bufadj((int)a->ofnmlen, 0);
+ g_char(a->ofnm, a->ofnmlen, f__curunit->ufnm = f__buf);
+ }
+ f__fatal(m, s);
+ }
+
+#ifdef KR_headers
+integer f_open(a) olist *a;
+#else
+integer f_open(olist *a)
+#endif
+{ unit *b;
+ integer rv;
+ char buf[256], *s;
+ cllist x;
+ int ufmt;
+ FILE *tf;
+#ifndef NON_UNIX_STDIO
+ int n;
+#endif
+ f__external = 1;
+ if(a->ounit>=MXUNIT || a->ounit<0)
+ err(a->oerr,101,"open")
+ if (!f__init)
+ f_init();
+ f__curunit = b = &f__units[a->ounit];
+ if(b->ufd) {
+ if(a->ofnm==0)
+ {
+ same: if (a->oblnk)
+ b->ublnk = *a->oblnk == 'z' || *a->oblnk == 'Z';
+ return(0);
+ }
+#ifdef NON_UNIX_STDIO
+ if (b->ufnm
+ && strlen(b->ufnm) == a->ofnmlen
+ && !strncmp(b->ufnm, a->ofnm, (unsigned)a->ofnmlen))
+ goto same;
+#else
+ g_char(a->ofnm,a->ofnmlen,buf);
+ if (f__inode(buf,&n) == b->uinode && n == b->udev)
+ goto same;
+#endif
+ x.cunit=a->ounit;
+ x.csta=0;
+ x.cerr=a->oerr;
+ if ((rv = f_clos(&x)) != 0)
+ return rv;
+ }
+ b->url = (int)a->orl;
+ b->ublnk = a->oblnk && (*a->oblnk == 'z' || *a->oblnk == 'Z');
+ if(a->ofm==0)
+ { if(b->url>0) b->ufmt=0;
+ else b->ufmt=1;
+ }
+ else if(*a->ofm=='f' || *a->ofm == 'F') b->ufmt=1;
+ else b->ufmt=0;
+ ufmt = b->ufmt;
+#ifdef url_Adjust
+ if (b->url && !ufmt)
+ url_Adjust(b->url);
+#endif
+ if (a->ofnm) {
+ g_char(a->ofnm,a->ofnmlen,buf);
+ if (!buf[0])
+ opnerr(a->oerr,107,"open")
+ }
+ else
+ sprintf(buf, "fort.%ld", (long)a->ounit);
+ b->uscrtch = 0;
+ b->uend=0;
+ b->uwrt = 0;
+ b->ufd = 0;
+ b->urw = 3;
+ switch(a->osta ? *a->osta : 'u')
+ {
+ case 'o':
+ case 'O':
+#ifdef NON_POSIX_STDIO
+ if (!(tf = FOPEN(buf,"r")))
+ opnerr(a->oerr,errno,"open")
+ fclose(tf);
+#else
+ if (access(buf,0))
+ opnerr(a->oerr,errno,"open")
+#endif
+ break;
+ case 's':
+ case 'S':
+ b->uscrtch=1;
+#ifdef NON_ANSI_STDIO
+ (void) strcpy(buf,"tmp.FXXXXXX");
+ (void) mktemp(buf);
+ goto replace;
+#else
+ if (!(b->ufd = tmpfile()))
+ opnerr(a->oerr,errno,"open")
+ b->ufnm = 0;
+#ifndef NON_UNIX_STDIO
+ b->uinode = b->udev = -1;
+#endif
+ b->useek = 1;
+ return 0;
+#endif
+
+ case 'n':
+ case 'N':
+#ifdef NON_POSIX_STDIO
+ if ((tf = FOPEN(buf,"r")) || (tf = FOPEN(buf,"a"))) {
+ fclose(tf);
+ opnerr(a->oerr,128,"open")
+ }
+#else
+ if (!access(buf,0))
+ opnerr(a->oerr,128,"open")
+#endif
+ /* no break */
+ case 'r': /* Fortran 90 replace option */
+ case 'R':
+#ifdef NON_ANSI_STDIO
+ replace:
+#endif
+ if (tf = FOPEN(buf,f__w_mode[0]))
+ fclose(tf);
+ }
+
+ b->ufnm=(char *) malloc((unsigned int)(strlen(buf)+1));
+ if(b->ufnm==NULL) opnerr(a->oerr,113,"no space");
+ (void) strcpy(b->ufnm,buf);
+ if ((s = a->oacc) && b->url)
+ ufmt = 0;
+ if(!(tf = FOPEN(buf, f__w_mode[ufmt|2]))) {
+ if (tf = FOPEN(buf, f__r_mode[ufmt]))
+ b->urw = 1;
+ else if (tf = FOPEN(buf, f__w_mode[ufmt])) {
+ b->uwrt = 1;
+ b->urw = 2;
+ }
+ else
+ err(a->oerr, errno, "open");
+ }
+ b->useek = f__canseek(b->ufd = tf);
+#ifndef NON_UNIX_STDIO
+ if((b->uinode = f__inode(buf,&b->udev)) == -1)
+ opnerr(a->oerr,108,"open")
+#endif
+ if(b->useek)
+ if (a->orl)
+ rewind(b->ufd);
+ else if ((s = a->oacc) && (*s == 'a' || *s == 'A')
+ && FSEEK(b->ufd, 0L, SEEK_END))
+ opnerr(a->oerr,129,"open");
+ return(0);
+}
+
+ int
+#ifdef KR_headers
+fk_open(seq,fmt,n) ftnint n;
+#else
+fk_open(int seq, int fmt, ftnint n)
+#endif
+{ char nbuf[10];
+ olist a;
+ (void) sprintf(nbuf,"fort.%ld",(long)n);
+ a.oerr=1;
+ a.ounit=n;
+ a.ofnm=nbuf;
+ a.ofnmlen=strlen(nbuf);
+ a.osta=NULL;
+ a.oacc= (char*)(seq==SEQ?"s":"d");
+ a.ofm = (char*)(fmt==FMT?"f":"u");
+ a.orl = seq==DIR?1:0;
+ a.oblnk=NULL;
+ return(f_open(&a));
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/pow_ci.c b/F2CLIBS/libf2c/pow_ci.c
new file mode 100644
index 0000000..574e0b1
--- /dev/null
+++ b/F2CLIBS/libf2c/pow_ci.c
@@ -0,0 +1,26 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+VOID pow_ci(p, a, b) /* p = a**b */
+ complex *p, *a; integer *b;
+#else
+extern void pow_zi(doublecomplex*, doublecomplex*, integer*);
+void pow_ci(complex *p, complex *a, integer *b) /* p = a**b */
+#endif
+{
+doublecomplex p1, a1;
+
+a1.r = a->r;
+a1.i = a->i;
+
+pow_zi(&p1, &a1, b);
+
+p->r = p1.r;
+p->i = p1.i;
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/pow_dd.c b/F2CLIBS/libf2c/pow_dd.c
new file mode 100644
index 0000000..08fc208
--- /dev/null
+++ b/F2CLIBS/libf2c/pow_dd.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double pow();
+double pow_dd(ap, bp) doublereal *ap, *bp;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double pow_dd(doublereal *ap, doublereal *bp)
+#endif
+{
+return(pow(*ap, *bp) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/pow_di.c b/F2CLIBS/libf2c/pow_di.c
new file mode 100644
index 0000000..abf36cb
--- /dev/null
+++ b/F2CLIBS/libf2c/pow_di.c
@@ -0,0 +1,41 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+double pow_di(ap, bp) doublereal *ap; integer *bp;
+#else
+double pow_di(doublereal *ap, integer *bp)
+#endif
+{
+double pow, x;
+integer n;
+unsigned long u;
+
+pow = 1;
+x = *ap;
+n = *bp;
+
+if(n != 0)
+ {
+ if(n < 0)
+ {
+ n = -n;
+ x = 1/x;
+ }
+ for(u = n; ; )
+ {
+ if(u & 01)
+ pow *= x;
+ if(u >>= 1)
+ x *= x;
+ else
+ break;
+ }
+ }
+return(pow);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/pow_hh.c b/F2CLIBS/libf2c/pow_hh.c
new file mode 100644
index 0000000..8821685
--- /dev/null
+++ b/F2CLIBS/libf2c/pow_hh.c
@@ -0,0 +1,39 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+shortint pow_hh(ap, bp) shortint *ap, *bp;
+#else
+shortint pow_hh(shortint *ap, shortint *bp)
+#endif
+{
+ shortint pow, x, n;
+ unsigned u;
+
+ x = *ap;
+ n = *bp;
+
+ if (n <= 0) {
+ if (n == 0 || x == 1)
+ return 1;
+ if (x != -1)
+ return x == 0 ? 1/x : 0;
+ n = -n;
+ }
+ u = n;
+ for(pow = 1; ; )
+ {
+ if(u & 01)
+ pow *= x;
+ if(u >>= 1)
+ x *= x;
+ else
+ break;
+ }
+ return(pow);
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/pow_ii.c b/F2CLIBS/libf2c/pow_ii.c
new file mode 100644
index 0000000..748d121
--- /dev/null
+++ b/F2CLIBS/libf2c/pow_ii.c
@@ -0,0 +1,39 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+integer pow_ii(ap, bp) integer *ap, *bp;
+#else
+integer pow_ii(integer *ap, integer *bp)
+#endif
+{
+ integer pow, x, n;
+ unsigned long u;
+
+ x = *ap;
+ n = *bp;
+
+ if (n <= 0) {
+ if (n == 0 || x == 1)
+ return 1;
+ if (x != -1)
+ return x == 0 ? 1/x : 0;
+ n = -n;
+ }
+ u = n;
+ for(pow = 1; ; )
+ {
+ if(u & 01)
+ pow *= x;
+ if(u >>= 1)
+ x *= x;
+ else
+ break;
+ }
+ return(pow);
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/pow_qq.c b/F2CLIBS/libf2c/pow_qq.c
new file mode 100644
index 0000000..09fe18e
--- /dev/null
+++ b/F2CLIBS/libf2c/pow_qq.c
@@ -0,0 +1,39 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+longint pow_qq(ap, bp) longint *ap, *bp;
+#else
+longint pow_qq(longint *ap, longint *bp)
+#endif
+{
+ longint pow, x, n;
+ unsigned long long u; /* system-dependent */
+
+ x = *ap;
+ n = *bp;
+
+ if (n <= 0) {
+ if (n == 0 || x == 1)
+ return 1;
+ if (x != -1)
+ return x == 0 ? 1/x : 0;
+ n = -n;
+ }
+ u = n;
+ for(pow = 1; ; )
+ {
+ if(u & 01)
+ pow *= x;
+ if(u >>= 1)
+ x *= x;
+ else
+ break;
+ }
+ return(pow);
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/pow_ri.c b/F2CLIBS/libf2c/pow_ri.c
new file mode 100644
index 0000000..e29d416
--- /dev/null
+++ b/F2CLIBS/libf2c/pow_ri.c
@@ -0,0 +1,41 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+double pow_ri(ap, bp) real *ap; integer *bp;
+#else
+double pow_ri(real *ap, integer *bp)
+#endif
+{
+double pow, x;
+integer n;
+unsigned long u;
+
+pow = 1;
+x = *ap;
+n = *bp;
+
+if(n != 0)
+ {
+ if(n < 0)
+ {
+ n = -n;
+ x = 1/x;
+ }
+ for(u = n; ; )
+ {
+ if(u & 01)
+ pow *= x;
+ if(u >>= 1)
+ x *= x;
+ else
+ break;
+ }
+ }
+return(pow);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/pow_zi.c b/F2CLIBS/libf2c/pow_zi.c
new file mode 100644
index 0000000..1c0a4b0
--- /dev/null
+++ b/F2CLIBS/libf2c/pow_zi.c
@@ -0,0 +1,60 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+VOID pow_zi(p, a, b) /* p = a**b */
+ doublecomplex *p, *a; integer *b;
+#else
+extern void z_div(doublecomplex*, doublecomplex*, doublecomplex*);
+void pow_zi(doublecomplex *p, doublecomplex *a, integer *b) /* p = a**b */
+#endif
+{
+ integer n;
+ unsigned long u;
+ double t;
+ doublecomplex q, x;
+ static doublecomplex one = {1.0, 0.0};
+
+ n = *b;
+ q.r = 1;
+ q.i = 0;
+
+ if(n == 0)
+ goto done;
+ if(n < 0)
+ {
+ n = -n;
+ z_div(&x, &one, a);
+ }
+ else
+ {
+ x.r = a->r;
+ x.i = a->i;
+ }
+
+ for(u = n; ; )
+ {
+ if(u & 01)
+ {
+ t = q.r * x.r - q.i * x.i;
+ q.i = q.r * x.i + q.i * x.r;
+ q.r = t;
+ }
+ if(u >>= 1)
+ {
+ t = x.r * x.r - x.i * x.i;
+ x.i = 2 * x.r * x.i;
+ x.r = t;
+ }
+ else
+ break;
+ }
+ done:
+ p->i = q.i;
+ p->r = q.r;
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/pow_zz.c b/F2CLIBS/libf2c/pow_zz.c
new file mode 100644
index 0000000..b5ffd33
--- /dev/null
+++ b/F2CLIBS/libf2c/pow_zz.c
@@ -0,0 +1,29 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double log(), exp(), cos(), sin(), atan2(), f__cabs();
+VOID pow_zz(r,a,b) doublecomplex *r, *a, *b;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern double f__cabs(double,double);
+void pow_zz(doublecomplex *r, doublecomplex *a, doublecomplex *b)
+#endif
+{
+double logr, logi, x, y;
+
+logr = log( f__cabs(a->r, a->i) );
+logi = atan2(a->i, a->r);
+
+x = exp( logr * b->r - logi * b->i );
+y = logr * b->i + logi * b->r;
+
+r->r = x * cos(y);
+r->i = x * sin(y);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/qbitbits.c b/F2CLIBS/libf2c/qbitbits.c
new file mode 100644
index 0000000..ba1b5bd
--- /dev/null
+++ b/F2CLIBS/libf2c/qbitbits.c
@@ -0,0 +1,72 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifndef LONGBITS
+#define LONGBITS 32
+#endif
+
+#ifndef LONG8BITS
+#define LONG8BITS (2*LONGBITS)
+#endif
+
+ longint
+#ifdef KR_headers
+qbit_bits(a, b, len) longint a; integer b, len;
+#else
+qbit_bits(longint a, integer b, integer len)
+#endif
+{
+ /* Assume 2's complement arithmetic */
+
+ ulongint x, y;
+
+ x = (ulongint) a;
+ y = (ulongint)-1L;
+ x >>= b;
+ y <<= len;
+ return (longint)(x & ~y);
+ }
+
+ longint
+#ifdef KR_headers
+qbit_cshift(a, b, len) longint a; integer b, len;
+#else
+qbit_cshift(longint a, integer b, integer len)
+#endif
+{
+ ulongint x, y, z;
+
+ x = (ulongint)a;
+ if (len <= 0) {
+ if (len == 0)
+ return 0;
+ goto full_len;
+ }
+ if (len >= LONG8BITS) {
+ full_len:
+ if (b >= 0) {
+ b %= LONG8BITS;
+ return (longint)(x << b | x >> LONG8BITS - b );
+ }
+ b = -b;
+ b %= LONG8BITS;
+ return (longint)(x << LONG8BITS - b | x >> b);
+ }
+ y = z = (unsigned long)-1;
+ y <<= len;
+ z &= ~y;
+ y &= x;
+ x &= z;
+ if (b >= 0) {
+ b %= len;
+ return (longint)(y | z & (x << b | x >> len - b));
+ }
+ b = -b;
+ b %= len;
+ return (longint)(y | z & (x >> b | x << len - b));
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/qbitshft.c b/F2CLIBS/libf2c/qbitshft.c
new file mode 100644
index 0000000..78e7b95
--- /dev/null
+++ b/F2CLIBS/libf2c/qbitshft.c
@@ -0,0 +1,17 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+ longint
+#ifdef KR_headers
+qbit_shift(a, b) longint a; integer b;
+#else
+qbit_shift(longint a, integer b)
+#endif
+{
+ return b >= 0 ? a << b : (longint)((ulongint)a >> -b);
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/r_abs.c b/F2CLIBS/libf2c/r_abs.c
new file mode 100644
index 0000000..f3291fb
--- /dev/null
+++ b/F2CLIBS/libf2c/r_abs.c
@@ -0,0 +1,18 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+double r_abs(x) real *x;
+#else
+double r_abs(real *x)
+#endif
+{
+if(*x >= 0)
+ return(*x);
+return(- *x);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/r_acos.c b/F2CLIBS/libf2c/r_acos.c
new file mode 100644
index 0000000..103c7ff
--- /dev/null
+++ b/F2CLIBS/libf2c/r_acos.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double acos();
+double r_acos(x) real *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double r_acos(real *x)
+#endif
+{
+return( acos(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/r_asin.c b/F2CLIBS/libf2c/r_asin.c
new file mode 100644
index 0000000..432b940
--- /dev/null
+++ b/F2CLIBS/libf2c/r_asin.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double asin();
+double r_asin(x) real *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double r_asin(real *x)
+#endif
+{
+return( asin(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/r_atan.c b/F2CLIBS/libf2c/r_atan.c
new file mode 100644
index 0000000..7656982
--- /dev/null
+++ b/F2CLIBS/libf2c/r_atan.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double atan();
+double r_atan(x) real *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double r_atan(real *x)
+#endif
+{
+return( atan(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/r_atn2.c b/F2CLIBS/libf2c/r_atn2.c
new file mode 100644
index 0000000..ab957b8
--- /dev/null
+++ b/F2CLIBS/libf2c/r_atn2.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double atan2();
+double r_atn2(x,y) real *x, *y;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double r_atn2(real *x, real *y)
+#endif
+{
+return( atan2(*x,*y) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/r_cnjg.c b/F2CLIBS/libf2c/r_cnjg.c
new file mode 100644
index 0000000..cef0e4b
--- /dev/null
+++ b/F2CLIBS/libf2c/r_cnjg.c
@@ -0,0 +1,18 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+VOID r_cnjg(r, z) complex *r, *z;
+#else
+VOID r_cnjg(complex *r, complex *z)
+#endif
+{
+ real zi = z->i;
+ r->r = z->r;
+ r->i = -zi;
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/r_cos.c b/F2CLIBS/libf2c/r_cos.c
new file mode 100644
index 0000000..4418f0c
--- /dev/null
+++ b/F2CLIBS/libf2c/r_cos.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double cos();
+double r_cos(x) real *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double r_cos(real *x)
+#endif
+{
+return( cos(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/r_cosh.c b/F2CLIBS/libf2c/r_cosh.c
new file mode 100644
index 0000000..f547835
--- /dev/null
+++ b/F2CLIBS/libf2c/r_cosh.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double cosh();
+double r_cosh(x) real *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double r_cosh(real *x)
+#endif
+{
+return( cosh(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/r_dim.c b/F2CLIBS/libf2c/r_dim.c
new file mode 100644
index 0000000..d573ca3
--- /dev/null
+++ b/F2CLIBS/libf2c/r_dim.c
@@ -0,0 +1,16 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+double r_dim(a,b) real *a, *b;
+#else
+double r_dim(real *a, real *b)
+#endif
+{
+return( *a > *b ? *a - *b : 0);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/r_exp.c b/F2CLIBS/libf2c/r_exp.c
new file mode 100644
index 0000000..4e67979
--- /dev/null
+++ b/F2CLIBS/libf2c/r_exp.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double exp();
+double r_exp(x) real *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double r_exp(real *x)
+#endif
+{
+return( exp(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/r_imag.c b/F2CLIBS/libf2c/r_imag.c
new file mode 100644
index 0000000..1b4de14
--- /dev/null
+++ b/F2CLIBS/libf2c/r_imag.c
@@ -0,0 +1,16 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+double r_imag(z) complex *z;
+#else
+double r_imag(complex *z)
+#endif
+{
+return(z->i);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/r_int.c b/F2CLIBS/libf2c/r_int.c
new file mode 100644
index 0000000..bff8717
--- /dev/null
+++ b/F2CLIBS/libf2c/r_int.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double floor();
+double r_int(x) real *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double r_int(real *x)
+#endif
+{
+return( (*x>0) ? floor(*x) : -floor(- *x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/r_lg10.c b/F2CLIBS/libf2c/r_lg10.c
new file mode 100644
index 0000000..64ffddf
--- /dev/null
+++ b/F2CLIBS/libf2c/r_lg10.c
@@ -0,0 +1,21 @@
+#include "f2c.h"
+
+#define log10e 0.43429448190325182765
+
+#ifdef KR_headers
+double log();
+double r_lg10(x) real *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double r_lg10(real *x)
+#endif
+{
+return( log10e * log(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/r_log.c b/F2CLIBS/libf2c/r_log.c
new file mode 100644
index 0000000..94c79b0
--- /dev/null
+++ b/F2CLIBS/libf2c/r_log.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double log();
+double r_log(x) real *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double r_log(real *x)
+#endif
+{
+return( log(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/r_mod.c b/F2CLIBS/libf2c/r_mod.c
new file mode 100644
index 0000000..63ed175
--- /dev/null
+++ b/F2CLIBS/libf2c/r_mod.c
@@ -0,0 +1,46 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+#ifdef IEEE_drem
+double drem();
+#else
+double floor();
+#endif
+double r_mod(x,y) real *x, *y;
+#else
+#ifdef IEEE_drem
+double drem(double, double);
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+#endif
+double r_mod(real *x, real *y)
+#endif
+{
+#ifdef IEEE_drem
+ double xa, ya, z;
+ if ((ya = *y) < 0.)
+ ya = -ya;
+ z = drem(xa = *x, ya);
+ if (xa > 0) {
+ if (z < 0)
+ z += ya;
+ }
+ else if (z > 0)
+ z -= ya;
+ return z;
+#else
+ double quotient;
+ if( (quotient = (double)*x / *y) >= 0)
+ quotient = floor(quotient);
+ else
+ quotient = -floor(-quotient);
+ return(*x - (*y) * quotient );
+#endif
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/r_nint.c b/F2CLIBS/libf2c/r_nint.c
new file mode 100644
index 0000000..7cc3f1b
--- /dev/null
+++ b/F2CLIBS/libf2c/r_nint.c
@@ -0,0 +1,20 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double floor();
+double r_nint(x) real *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double r_nint(real *x)
+#endif
+{
+return( (*x)>=0 ?
+ floor(*x + .5) : -floor(.5 - *x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/r_sign.c b/F2CLIBS/libf2c/r_sign.c
new file mode 100644
index 0000000..797db1a
--- /dev/null
+++ b/F2CLIBS/libf2c/r_sign.c
@@ -0,0 +1,18 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+double r_sign(a,b) real *a, *b;
+#else
+double r_sign(real *a, real *b)
+#endif
+{
+double x;
+x = (*a >= 0 ? *a : - *a);
+return( *b >= 0 ? x : -x);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/r_sin.c b/F2CLIBS/libf2c/r_sin.c
new file mode 100644
index 0000000..37e0df2
--- /dev/null
+++ b/F2CLIBS/libf2c/r_sin.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double sin();
+double r_sin(x) real *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double r_sin(real *x)
+#endif
+{
+return( sin(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/r_sinh.c b/F2CLIBS/libf2c/r_sinh.c
new file mode 100644
index 0000000..39878f0
--- /dev/null
+++ b/F2CLIBS/libf2c/r_sinh.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double sinh();
+double r_sinh(x) real *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double r_sinh(real *x)
+#endif
+{
+return( sinh(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/r_sqrt.c b/F2CLIBS/libf2c/r_sqrt.c
new file mode 100644
index 0000000..e7b2c1c
--- /dev/null
+++ b/F2CLIBS/libf2c/r_sqrt.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double sqrt();
+double r_sqrt(x) real *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double r_sqrt(real *x)
+#endif
+{
+return( sqrt(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/r_tan.c b/F2CLIBS/libf2c/r_tan.c
new file mode 100644
index 0000000..1774bed
--- /dev/null
+++ b/F2CLIBS/libf2c/r_tan.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double tan();
+double r_tan(x) real *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double r_tan(real *x)
+#endif
+{
+return( tan(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/r_tanh.c b/F2CLIBS/libf2c/r_tanh.c
new file mode 100644
index 0000000..7739c6c
--- /dev/null
+++ b/F2CLIBS/libf2c/r_tanh.c
@@ -0,0 +1,19 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double tanh();
+double r_tanh(x) real *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double r_tanh(real *x)
+#endif
+{
+return( tanh(*x) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/rawio.h b/F2CLIBS/libf2c/rawio.h
new file mode 100644
index 0000000..fd36a48
--- /dev/null
+++ b/F2CLIBS/libf2c/rawio.h
@@ -0,0 +1,41 @@
+#ifndef KR_headers
+#ifdef MSDOS
+#include "io.h"
+#ifndef WATCOM
+#define close _close
+#define creat _creat
+#define open _open
+#define read _read
+#define write _write
+#endif /*WATCOM*/
+#endif /*MSDOS*/
+#ifdef __cplusplus
+extern "C" {
+#endif
+#ifndef MSDOS
+#ifdef OPEN_DECL
+extern int creat(const char*,int), open(const char*,int);
+#endif
+extern int close(int);
+extern int read(int,void*,size_t), write(int,void*,size_t);
+extern int unlink(const char*);
+#ifndef _POSIX_SOURCE
+#ifndef NON_UNIX_STDIO
+extern FILE *fdopen(int, const char*);
+#endif
+#endif
+#endif /*KR_HEADERS*/
+
+extern char *mktemp(char*);
+
+#ifdef __cplusplus
+ }
+#endif
+#endif
+
+#include "fcntl.h"
+
+#ifndef O_WRONLY
+#define O_RDONLY 0
+#define O_WRONLY 1
+#endif
diff --git a/F2CLIBS/libf2c/rdfmt.c b/F2CLIBS/libf2c/rdfmt.c
new file mode 100644
index 0000000..09f3ccf
--- /dev/null
+++ b/F2CLIBS/libf2c/rdfmt.c
@@ -0,0 +1,553 @@
+#include "f2c.h"
+#include "fio.h"
+
+#ifdef KR_headers
+extern double atof();
+#define Const /*nothing*/
+#else
+#define Const const
+#undef abs
+#undef min
+#undef max
+#include "stdlib.h"
+#endif
+
+#include "fmt.h"
+#include "fp.h"
+#include "ctype.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+ static int
+#ifdef KR_headers
+rd_Z(n,w,len) Uint *n; ftnlen len;
+#else
+rd_Z(Uint *n, int w, ftnlen len)
+#endif
+{
+ long x[9];
+ char *s, *s0, *s1, *se, *t;
+ Const char *sc;
+ int ch, i, w1, w2;
+ static char hex[256];
+ static int one = 1;
+ int bad = 0;
+
+ if (!hex['0']) {
+ sc = "0123456789";
+ while(ch = *sc++)
+ hex[ch] = ch - '0' + 1;
+ sc = "ABCDEF";
+ while(ch = *sc++)
+ hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11;
+ }
+ s = s0 = (char *)x;
+ s1 = (char *)&x[4];
+ se = (char *)&x[8];
+ if (len > 4*sizeof(long))
+ return errno = 117;
+ while (w) {
+ GET(ch);
+ if (ch==',' || ch=='\n')
+ break;
+ w--;
+ if (ch > ' ') {
+ if (!hex[ch & 0xff])
+ bad++;
+ *s++ = ch;
+ if (s == se) {
+ /* discard excess characters */
+ for(t = s0, s = s1; t < s1;)
+ *t++ = *s++;
+ s = s1;
+ }
+ }
+ }
+ if (bad)
+ return errno = 115;
+ w = (int)len;
+ w1 = s - s0;
+ w2 = w1+1 >> 1;
+ t = (char *)n;
+ if (*(char *)&one) {
+ /* little endian */
+ t += w - 1;
+ i = -1;
+ }
+ else
+ i = 1;
+ for(; w > w2; t += i, --w)
+ *t = 0;
+ if (!w)
+ return 0;
+ if (w < w2)
+ s0 = s - (w << 1);
+ else if (w1 & 1) {
+ *t = hex[*s0++ & 0xff] - 1;
+ if (!--w)
+ return 0;
+ t += i;
+ }
+ do {
+ *t = hex[*s0 & 0xff]-1 << 4 | hex[s0[1] & 0xff]-1;
+ t += i;
+ s0 += 2;
+ }
+ while(--w);
+ return 0;
+ }
+
+ static int
+#ifdef KR_headers
+rd_I(n,w,len, base) Uint *n; int w; ftnlen len; register int base;
+#else
+rd_I(Uint *n, int w, ftnlen len, register int base)
+#endif
+{
+ int ch, sign;
+ longint x = 0;
+
+ if (w <= 0)
+ goto have_x;
+ for(;;) {
+ GET(ch);
+ if (ch != ' ')
+ break;
+ if (!--w)
+ goto have_x;
+ }
+ sign = 0;
+ switch(ch) {
+ case ',':
+ case '\n':
+ w = 0;
+ goto have_x;
+ case '-':
+ sign = 1;
+ case '+':
+ break;
+ default:
+ if (ch >= '0' && ch <= '9') {
+ x = ch - '0';
+ break;
+ }
+ goto have_x;
+ }
+ while(--w) {
+ GET(ch);
+ if (ch >= '0' && ch <= '9') {
+ x = x*base + ch - '0';
+ continue;
+ }
+ if (ch != ' ') {
+ if (ch == '\n' || ch == ',')
+ w = 0;
+ break;
+ }
+ if (f__cblank)
+ x *= base;
+ }
+ if (sign)
+ x = -x;
+ have_x:
+ if(len == sizeof(integer))
+ n->il=x;
+ else if(len == sizeof(char))
+ n->ic = (char)x;
+#ifdef Allow_TYQUAD
+ else if (len == sizeof(longint))
+ n->ili = x;
+#endif
+ else
+ n->is = (short)x;
+ if (w) {
+ while(--w)
+ GET(ch);
+ return errno = 115;
+ }
+ return 0;
+}
+
+ static int
+#ifdef KR_headers
+rd_L(n,w,len) ftnint *n; ftnlen len;
+#else
+rd_L(ftnint *n, int w, ftnlen len)
+#endif
+{ int ch, dot, lv;
+
+ if (w <= 0)
+ goto bad;
+ for(;;) {
+ GET(ch);
+ --w;
+ if (ch != ' ')
+ break;
+ if (!w)
+ goto bad;
+ }
+ dot = 0;
+ retry:
+ switch(ch) {
+ case '.':
+ if (dot++ || !w)
+ goto bad;
+ GET(ch);
+ --w;
+ goto retry;
+ case 't':
+ case 'T':
+ lv = 1;
+ break;
+ case 'f':
+ case 'F':
+ lv = 0;
+ break;
+ default:
+ bad:
+ for(; w > 0; --w)
+ GET(ch);
+ /* no break */
+ case ',':
+ case '\n':
+ return errno = 116;
+ }
+ switch(len) {
+ case sizeof(char): *(char *)n = (char)lv; break;
+ case sizeof(short): *(short *)n = (short)lv; break;
+ default: *n = lv;
+ }
+ while(w-- > 0) {
+ GET(ch);
+ if (ch == ',' || ch == '\n')
+ break;
+ }
+ return 0;
+}
+
+ static int
+#ifdef KR_headers
+rd_F(p, w, d, len) ufloat *p; ftnlen len;
+#else
+rd_F(ufloat *p, int w, int d, ftnlen len)
+#endif
+{
+ char s[FMAX+EXPMAXDIGS+4];
+ register int ch;
+ register char *sp, *spe, *sp1;
+ double x;
+ int scale1, se;
+ long e, exp;
+
+ sp1 = sp = s;
+ spe = sp + FMAX;
+ exp = -d;
+ x = 0.;
+
+ do {
+ GET(ch);
+ w--;
+ } while (ch == ' ' && w);
+ switch(ch) {
+ case '-': *sp++ = ch; sp1++; spe++;
+ case '+':
+ if (!w) goto zero;
+ --w;
+ GET(ch);
+ }
+ while(ch == ' ') {
+blankdrop:
+ if (!w--) goto zero; GET(ch); }
+ while(ch == '0')
+ { if (!w--) goto zero; GET(ch); }
+ if (ch == ' ' && f__cblank)
+ goto blankdrop;
+ scale1 = f__scale;
+ while(isdigit(ch)) {
+digloop1:
+ if (sp < spe) *sp++ = ch;
+ else ++exp;
+digloop1e:
+ if (!w--) goto done;
+ GET(ch);
+ }
+ if (ch == ' ') {
+ if (f__cblank)
+ { ch = '0'; goto digloop1; }
+ goto digloop1e;
+ }
+ if (ch == '.') {
+ exp += d;
+ if (!w--) goto done;
+ GET(ch);
+ if (sp == sp1) { /* no digits yet */
+ while(ch == '0') {
+skip01:
+ --exp;
+skip0:
+ if (!w--) goto done;
+ GET(ch);
+ }
+ if (ch == ' ') {
+ if (f__cblank) goto skip01;
+ goto skip0;
+ }
+ }
+ while(isdigit(ch)) {
+digloop2:
+ if (sp < spe)
+ { *sp++ = ch; --exp; }
+digloop2e:
+ if (!w--) goto done;
+ GET(ch);
+ }
+ if (ch == ' ') {
+ if (f__cblank)
+ { ch = '0'; goto digloop2; }
+ goto digloop2e;
+ }
+ }
+ switch(ch) {
+ default:
+ break;
+ case '-': se = 1; goto signonly;
+ case '+': se = 0; goto signonly;
+ case 'e':
+ case 'E':
+ case 'd':
+ case 'D':
+ if (!w--)
+ goto bad;
+ GET(ch);
+ while(ch == ' ') {
+ if (!w--)
+ goto bad;
+ GET(ch);
+ }
+ se = 0;
+ switch(ch) {
+ case '-': se = 1;
+ case '+':
+signonly:
+ if (!w--)
+ goto bad;
+ GET(ch);
+ }
+ while(ch == ' ') {
+ if (!w--)
+ goto bad;
+ GET(ch);
+ }
+ if (!isdigit(ch))
+ goto bad;
+
+ e = ch - '0';
+ for(;;) {
+ if (!w--)
+ { ch = '\n'; break; }
+ GET(ch);
+ if (!isdigit(ch)) {
+ if (ch == ' ') {
+ if (f__cblank)
+ ch = '0';
+ else continue;
+ }
+ else
+ break;
+ }
+ e = 10*e + ch - '0';
+ if (e > EXPMAX && sp > sp1)
+ goto bad;
+ }
+ if (se)
+ exp -= e;
+ else
+ exp += e;
+ scale1 = 0;
+ }
+ switch(ch) {
+ case '\n':
+ case ',':
+ break;
+ default:
+bad:
+ return (errno = 115);
+ }
+done:
+ if (sp > sp1) {
+ while(*--sp == '0')
+ ++exp;
+ if (exp -= scale1)
+ sprintf(sp+1, "e%ld", exp);
+ else
+ sp[1] = 0;
+ x = atof(s);
+ }
+zero:
+ if (len == sizeof(real))
+ p->pf = x;
+ else
+ p->pd = x;
+ return(0);
+ }
+
+
+ static int
+#ifdef KR_headers
+rd_A(p,len) char *p; ftnlen len;
+#else
+rd_A(char *p, ftnlen len)
+#endif
+{ int i,ch;
+ for(i=0;i<len;i++)
+ { GET(ch);
+ *p++=VAL(ch);
+ }
+ return(0);
+}
+ static int
+#ifdef KR_headers
+rd_AW(p,w,len) char *p; ftnlen len;
+#else
+rd_AW(char *p, int w, ftnlen len)
+#endif
+{ int i,ch;
+ if(w>=len)
+ { for(i=0;i<w-len;i++)
+ GET(ch);
+ for(i=0;i<len;i++)
+ { GET(ch);
+ *p++=VAL(ch);
+ }
+ return(0);
+ }
+ for(i=0;i<w;i++)
+ { GET(ch);
+ *p++=VAL(ch);
+ }
+ for(i=0;i<len-w;i++) *p++=' ';
+ return(0);
+}
+ static int
+#ifdef KR_headers
+rd_H(n,s) char *s;
+#else
+rd_H(int n, char *s)
+#endif
+{ int i,ch;
+ for(i=0;i<n;i++)
+ if((ch=(*f__getn)())<0) return(ch);
+ else *s++ = ch=='\n'?' ':ch;
+ return(1);
+}
+ static int
+#ifdef KR_headers
+rd_POS(s) char *s;
+#else
+rd_POS(char *s)
+#endif
+{ char quote;
+ int ch;
+ quote= *s++;
+ for(;*s;s++)
+ if(*s==quote && *(s+1)!=quote) break;
+ else if((ch=(*f__getn)())<0) return(ch);
+ else *s = ch=='\n'?' ':ch;
+ return(1);
+}
+
+ int
+#ifdef KR_headers
+rd_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len;
+#else
+rd_ed(struct syl *p, char *ptr, ftnlen len)
+#endif
+{ int ch;
+ for(;f__cursor>0;f__cursor--) if((ch=(*f__getn)())<0) return(ch);
+ if(f__cursor<0)
+ { if(f__recpos+f__cursor < 0) /*err(elist->cierr,110,"fmt")*/
+ f__cursor = -f__recpos; /* is this in the standard? */
+ if(f__external == 0) {
+ extern char *f__icptr;
+ f__icptr += f__cursor;
+ }
+ else if(f__curunit && f__curunit->useek)
+ (void) FSEEK(f__cf, f__cursor,SEEK_CUR);
+ else
+ err(f__elist->cierr,106,"fmt");
+ f__recpos += f__cursor;
+ f__cursor=0;
+ }
+ switch(p->op)
+ {
+ default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op);
+ sig_die(f__fmtbuf, 1);
+ case IM:
+ case I: ch = rd_I((Uint *)ptr,p->p1,len, 10);
+ break;
+
+ /* O and OM don't work right for character, double, complex, */
+ /* or doublecomplex, and they differ from Fortran 90 in */
+ /* showing a minus sign for negative values. */
+
+ case OM:
+ case O: ch = rd_I((Uint *)ptr, p->p1, len, 8);
+ break;
+ case L: ch = rd_L((ftnint *)ptr,p->p1,len);
+ break;
+ case A: ch = rd_A(ptr,len);
+ break;
+ case AW:
+ ch = rd_AW(ptr,p->p1,len);
+ break;
+ case E: case EE:
+ case D:
+ case G:
+ case GE:
+ case F: ch = rd_F((ufloat *)ptr,p->p1,p->p2.i[0],len);
+ break;
+
+ /* Z and ZM assume 8-bit bytes. */
+
+ case ZM:
+ case Z:
+ ch = rd_Z((Uint *)ptr, p->p1, len);
+ break;
+ }
+ if(ch == 0) return(ch);
+ else if(ch == EOF) return(EOF);
+ if (f__cf)
+ clearerr(f__cf);
+ return(errno);
+}
+
+ int
+#ifdef KR_headers
+rd_ned(p) struct syl *p;
+#else
+rd_ned(struct syl *p)
+#endif
+{
+ switch(p->op)
+ {
+ default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op);
+ sig_die(f__fmtbuf, 1);
+ case APOS:
+ return(rd_POS(p->p2.s));
+ case H: return(rd_H(p->p1,p->p2.s));
+ case SLASH: return((*f__donewrec)());
+ case TR:
+ case X: f__cursor += p->p1;
+ return(1);
+ case T: f__cursor=p->p1-f__recpos - 1;
+ return(1);
+ case TL: f__cursor -= p->p1;
+ if(f__cursor < -f__recpos) /* TL1000, 1X */
+ f__cursor = -f__recpos;
+ return(1);
+ }
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/rewind.c b/F2CLIBS/libf2c/rewind.c
new file mode 100644
index 0000000..9a0e07e
--- /dev/null
+++ b/F2CLIBS/libf2c/rewind.c
@@ -0,0 +1,30 @@
+#include "f2c.h"
+#include "fio.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+#ifdef KR_headers
+integer f_rew(a) alist *a;
+#else
+integer f_rew(alist *a)
+#endif
+{
+ unit *b;
+ if(a->aunit>=MXUNIT || a->aunit<0)
+ err(a->aerr,101,"rewind");
+ b = &f__units[a->aunit];
+ if(b->ufd == NULL || b->uwrt == 3)
+ return(0);
+ if(!b->useek)
+ err(a->aerr,106,"rewind")
+ if(b->uwrt) {
+ (void) t_runc(a);
+ b->uwrt = 3;
+ }
+ rewind(b->ufd);
+ b->uend=0;
+ return(0);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/rsfe.c b/F2CLIBS/libf2c/rsfe.c
new file mode 100644
index 0000000..abe9724
--- /dev/null
+++ b/F2CLIBS/libf2c/rsfe.c
@@ -0,0 +1,91 @@
+/* read sequential formatted external */
+#include "f2c.h"
+#include "fio.h"
+#include "fmt.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+ int
+xrd_SL(Void)
+{ int ch;
+ if(!f__curunit->uend)
+ while((ch=getc(f__cf))!='\n')
+ if (ch == EOF) {
+ f__curunit->uend = 1;
+ break;
+ }
+ f__cursor=f__recpos=0;
+ return(1);
+}
+
+ int
+x_getc(Void)
+{ int ch;
+ if(f__curunit->uend) return(EOF);
+ ch = getc(f__cf);
+ if(ch!=EOF && ch!='\n')
+ { f__recpos++;
+ return(ch);
+ }
+ if(ch=='\n')
+ { (void) ungetc(ch,f__cf);
+ return(ch);
+ }
+ if(f__curunit->uend || feof(f__cf))
+ { errno=0;
+ f__curunit->uend=1;
+ return(-1);
+ }
+ return(-1);
+}
+
+ int
+x_endp(Void)
+{
+ xrd_SL();
+ return f__curunit->uend == 1 ? EOF : 0;
+}
+
+ int
+x_rev(Void)
+{
+ (void) xrd_SL();
+ return(0);
+}
+#ifdef KR_headers
+integer s_rsfe(a) cilist *a; /* start */
+#else
+integer s_rsfe(cilist *a) /* start */
+#endif
+{ int n;
+ if(!f__init) f_init();
+ f__reading=1;
+ f__sequential=1;
+ f__formatted=1;
+ f__external=1;
+ if(n=c_sfe(a)) return(n);
+ f__elist=a;
+ f__cursor=f__recpos=0;
+ f__scale=0;
+ f__fmtbuf=a->cifmt;
+ f__cf=f__curunit->ufd;
+ if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio");
+ f__getn= x_getc;
+ f__doed= rd_ed;
+ f__doned= rd_ned;
+ fmt_bg();
+ f__doend=x_endp;
+ f__donewrec=xrd_SL;
+ f__dorevert=x_rev;
+ f__cblank=f__curunit->ublnk;
+ f__cplus=0;
+ if(f__curunit->uwrt && f__nowreading(f__curunit))
+ err(a->cierr,errno,"read start");
+ if(f__curunit->uend)
+ err(f__elist->ciend,(EOF),"read start");
+ return(0);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/rsli.c b/F2CLIBS/libf2c/rsli.c
new file mode 100644
index 0000000..3d4ea42
--- /dev/null
+++ b/F2CLIBS/libf2c/rsli.c
@@ -0,0 +1,109 @@
+#include "f2c.h"
+#include "fio.h"
+#include "lio.h"
+#include "fmt.h" /* for f__doend */
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+extern flag f__lquit;
+extern int f__lcount;
+extern char *f__icptr;
+extern char *f__icend;
+extern icilist *f__svic;
+extern int f__icnum, f__recpos;
+
+static int i_getc(Void)
+{
+ if(f__recpos >= f__svic->icirlen) {
+ if (f__recpos++ == f__svic->icirlen)
+ return '\n';
+ z_rnew();
+ }
+ f__recpos++;
+ if(f__icptr >= f__icend)
+ return EOF;
+ return(*f__icptr++);
+ }
+
+ static
+#ifdef KR_headers
+int i_ungetc(ch, f) int ch; FILE *f;
+#else
+int i_ungetc(int ch, FILE *f)
+#endif
+{
+ if (--f__recpos == f__svic->icirlen)
+ return '\n';
+ if (f__recpos < -1)
+ err(f__svic->icierr,110,"recend");
+ /* *--icptr == ch, and icptr may point to read-only memory */
+ return *--f__icptr /* = ch */;
+ }
+
+ static void
+#ifdef KR_headers
+c_lir(a) icilist *a;
+#else
+c_lir(icilist *a)
+#endif
+{
+ extern int l_eof;
+ f__reading = 1;
+ f__external = 0;
+ f__formatted = 1;
+ f__svic = a;
+ L_len = a->icirlen;
+ f__recpos = -1;
+ f__icnum = f__recpos = 0;
+ f__cursor = 0;
+ l_getc = i_getc;
+ l_ungetc = i_ungetc;
+ l_eof = 0;
+ f__icptr = a->iciunit;
+ f__icend = f__icptr + a->icirlen*a->icirnum;
+ f__cf = 0;
+ f__curunit = 0;
+ f__elist = (cilist *)a;
+ }
+
+
+#ifdef KR_headers
+integer s_rsli(a) icilist *a;
+#else
+integer s_rsli(icilist *a)
+#endif
+{
+ f__lioproc = l_read;
+ f__lquit = 0;
+ f__lcount = 0;
+ c_lir(a);
+ f__doend = 0;
+ return(0);
+ }
+
+integer e_rsli(Void)
+{ return 0; }
+
+#ifdef KR_headers
+integer s_rsni(a) icilist *a;
+#else
+extern int x_rsne(cilist*);
+
+integer s_rsni(icilist *a)
+#endif
+{
+ extern int nml_read;
+ integer rv;
+ cilist ca;
+ ca.ciend = a->iciend;
+ ca.cierr = a->icierr;
+ ca.cifmt = a->icifmt;
+ c_lir(a);
+ rv = x_rsne(&ca);
+ nml_read = 0;
+ return rv;
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/rsne.c b/F2CLIBS/libf2c/rsne.c
new file mode 100644
index 0000000..e8e9dae
--- /dev/null
+++ b/F2CLIBS/libf2c/rsne.c
@@ -0,0 +1,618 @@
+#include "f2c.h"
+#include "fio.h"
+#include "lio.h"
+
+#define MAX_NL_CACHE 3 /* maximum number of namelist hash tables to cache */
+#define MAXDIM 20 /* maximum number of subscripts */
+
+ struct dimen {
+ ftnlen extent;
+ ftnlen curval;
+ ftnlen delta;
+ ftnlen stride;
+ };
+ typedef struct dimen dimen;
+
+ struct hashentry {
+ struct hashentry *next;
+ char *name;
+ Vardesc *vd;
+ };
+ typedef struct hashentry hashentry;
+
+ struct hashtab {
+ struct hashtab *next;
+ Namelist *nl;
+ int htsize;
+ hashentry *tab[1];
+ };
+ typedef struct hashtab hashtab;
+
+ static hashtab *nl_cache;
+ static int n_nlcache;
+ static hashentry **zot;
+ static int colonseen;
+ extern ftnlen f__typesize[];
+
+ extern flag f__lquit;
+ extern int f__lcount, nml_read;
+ extern int t_getc(Void);
+
+#ifdef KR_headers
+ extern char *malloc(), *memset();
+#define Const /*nothing*/
+
+#ifdef ungetc
+ static int
+un_getc(x,f__cf) int x; FILE *f__cf;
+{ return ungetc(x,f__cf); }
+#else
+#define un_getc ungetc
+ extern int ungetc();
+#endif
+
+#else
+#define Const const
+#undef abs
+#undef min
+#undef max
+#include "stdlib.h"
+#include "string.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef ungetc
+ static int
+un_getc(int x, FILE *f__cf)
+{ return ungetc(x,f__cf); }
+#else
+#define un_getc ungetc
+extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */
+#endif
+#endif
+
+ static Vardesc *
+#ifdef KR_headers
+hash(ht, s) hashtab *ht; register char *s;
+#else
+hash(hashtab *ht, register char *s)
+#endif
+{
+ register int c, x;
+ register hashentry *h;
+ char *s0 = s;
+
+ for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1)
+ x += c;
+ for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next)
+ if (!strcmp(s0, h->name))
+ return h->vd;
+ return 0;
+ }
+
+ hashtab *
+#ifdef KR_headers
+mk_hashtab(nl) Namelist *nl;
+#else
+mk_hashtab(Namelist *nl)
+#endif
+{
+ int nht, nv;
+ hashtab *ht;
+ Vardesc *v, **vd, **vde;
+ hashentry *he;
+
+ hashtab **x, **x0, *y;
+ for(x = &nl_cache; y = *x; x0 = x, x = &y->next)
+ if (nl == y->nl)
+ return y;
+ if (n_nlcache >= MAX_NL_CACHE) {
+ /* discard least recently used namelist hash table */
+ y = *x0;
+ free((char *)y->next);
+ y->next = 0;
+ }
+ else
+ n_nlcache++;
+ nv = nl->nvars;
+ if (nv >= 0x4000)
+ nht = 0x7fff;
+ else {
+ for(nht = 1; nht < nv; nht <<= 1);
+ nht += nht - 1;
+ }
+ ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *)
+ + nv*sizeof(hashentry));
+ if (!ht)
+ return 0;
+ he = (hashentry *)&ht->tab[nht];
+ ht->nl = nl;
+ ht->htsize = nht;
+ ht->next = nl_cache;
+ nl_cache = ht;
+ memset((char *)ht->tab, 0, nht*sizeof(hashentry *));
+ vd = nl->vars;
+ vde = vd + nv;
+ while(vd < vde) {
+ v = *vd++;
+ if (!hash(ht, v->name)) {
+ he->next = *zot;
+ *zot = he;
+ he->name = v->name;
+ he->vd = v;
+ he++;
+ }
+ }
+ return ht;
+ }
+
+static char Alpha[256], Alphanum[256];
+
+ static VOID
+nl_init(Void) {
+ Const char *s;
+ int c;
+
+ if(!f__init)
+ f_init();
+ for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; )
+ Alpha[c]
+ = Alphanum[c]
+ = Alpha[c + 'a' - 'A']
+ = Alphanum[c + 'a' - 'A']
+ = c;
+ for(s = "0123456789_"; c = *s++; )
+ Alphanum[c] = c;
+ }
+
+#define GETC(x) (x=(*l_getc)())
+#define Ungetc(x,y) (*l_ungetc)(x,y)
+
+ static int
+#ifdef KR_headers
+getname(s, slen) register char *s; int slen;
+#else
+getname(register char *s, int slen)
+#endif
+{
+ register char *se = s + slen - 1;
+ register int ch;
+
+ GETC(ch);
+ if (!(*s++ = Alpha[ch & 0xff])) {
+ if (ch != EOF)
+ ch = 115;
+ errfl(f__elist->cierr, ch, "namelist read");
+ }
+ while(*s = Alphanum[GETC(ch) & 0xff])
+ if (s < se)
+ s++;
+ if (ch == EOF)
+ err(f__elist->cierr, EOF, "namelist read");
+ if (ch > ' ')
+ Ungetc(ch,f__cf);
+ return *s = 0;
+ }
+
+ static int
+#ifdef KR_headers
+getnum(chp, val) int *chp; ftnlen *val;
+#else
+getnum(int *chp, ftnlen *val)
+#endif
+{
+ register int ch, sign;
+ register ftnlen x;
+
+ while(GETC(ch) <= ' ' && ch >= 0);
+ if (ch == '-') {
+ sign = 1;
+ GETC(ch);
+ }
+ else {
+ sign = 0;
+ if (ch == '+')
+ GETC(ch);
+ }
+ x = ch - '0';
+ if (x < 0 || x > 9)
+ return 115;
+ while(GETC(ch) >= '0' && ch <= '9')
+ x = 10*x + ch - '0';
+ while(ch <= ' ' && ch >= 0)
+ GETC(ch);
+ if (ch == EOF)
+ return EOF;
+ *val = sign ? -x : x;
+ *chp = ch;
+ return 0;
+ }
+
+ static int
+#ifdef KR_headers
+getdimen(chp, d, delta, extent, x1)
+ int *chp; dimen *d; ftnlen delta, extent, *x1;
+#else
+getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1)
+#endif
+{
+ register int k;
+ ftnlen x2, x3;
+
+ if (k = getnum(chp, x1))
+ return k;
+ x3 = 1;
+ if (*chp == ':') {
+ if (k = getnum(chp, &x2))
+ return k;
+ x2 -= *x1;
+ if (*chp == ':') {
+ if (k = getnum(chp, &x3))
+ return k;
+ if (!x3)
+ return 123;
+ x2 /= x3;
+ colonseen = 1;
+ }
+ if (x2 < 0 || x2 >= extent)
+ return 123;
+ d->extent = x2 + 1;
+ }
+ else
+ d->extent = 1;
+ d->curval = 0;
+ d->delta = delta;
+ d->stride = x3;
+ return 0;
+ }
+
+#ifndef No_Namelist_Questions
+ static Void
+#ifdef KR_headers
+print_ne(a) cilist *a;
+#else
+print_ne(cilist *a)
+#endif
+{
+ flag intext = f__external;
+ int rpsave = f__recpos;
+ FILE *cfsave = f__cf;
+ unit *usave = f__curunit;
+ cilist t;
+ t = *a;
+ t.ciunit = 6;
+ s_wsne(&t);
+ fflush(f__cf);
+ f__external = intext;
+ f__reading = 1;
+ f__recpos = rpsave;
+ f__cf = cfsave;
+ f__curunit = usave;
+ f__elist = a;
+ }
+#endif
+
+ static char where0[] = "namelist read start ";
+
+ int
+#ifdef KR_headers
+x_rsne(a) cilist *a;
+#else
+x_rsne(cilist *a)
+#endif
+{
+ int ch, got1, k, n, nd, quote, readall;
+ Namelist *nl;
+ static char where[] = "namelist read";
+ char buf[64];
+ hashtab *ht;
+ Vardesc *v;
+ dimen *dn, *dn0, *dn1;
+ ftnlen *dims, *dims1;
+ ftnlen b, b0, b1, ex, no, nomax, size, span;
+ ftnint no1, no2, type;
+ char *vaddr;
+ long iva, ivae;
+ dimen dimens[MAXDIM], substr;
+
+ if (!Alpha['a'])
+ nl_init();
+ f__reading=1;
+ f__formatted=1;
+ got1 = 0;
+ top:
+ for(;;) switch(GETC(ch)) {
+ case EOF:
+ eof:
+ err(a->ciend,(EOF),where0);
+ case '&':
+ case '$':
+ goto have_amp;
+#ifndef No_Namelist_Questions
+ case '?':
+ print_ne(a);
+ continue;
+#endif
+ default:
+ if (ch <= ' ' && ch >= 0)
+ continue;
+#ifndef No_Namelist_Comments
+ while(GETC(ch) != '\n')
+ if (ch == EOF)
+ goto eof;
+#else
+ errfl(a->cierr, 115, where0);
+#endif
+ }
+ have_amp:
+ if (ch = getname(buf,sizeof(buf)))
+ return ch;
+ nl = (Namelist *)a->cifmt;
+ if (strcmp(buf, nl->name))
+#ifdef No_Bad_Namelist_Skip
+ errfl(a->cierr, 118, where0);
+#else
+ {
+ fprintf(stderr,
+ "Skipping namelist \"%s\": seeking namelist \"%s\".\n",
+ buf, nl->name);
+ fflush(stderr);
+ for(;;) switch(GETC(ch)) {
+ case EOF:
+ err(a->ciend, EOF, where0);
+ case '/':
+ case '&':
+ case '$':
+ if (f__external)
+ e_rsle();
+ else
+ z_rnew();
+ goto top;
+ case '"':
+ case '\'':
+ quote = ch;
+ more_quoted:
+ while(GETC(ch) != quote)
+ if (ch == EOF)
+ err(a->ciend, EOF, where0);
+ if (GETC(ch) == quote)
+ goto more_quoted;
+ Ungetc(ch,f__cf);
+ default:
+ continue;
+ }
+ }
+#endif
+ ht = mk_hashtab(nl);
+ if (!ht)
+ errfl(f__elist->cierr, 113, where0);
+ for(;;) {
+ for(;;) switch(GETC(ch)) {
+ case EOF:
+ if (got1)
+ return 0;
+ err(a->ciend, EOF, where0);
+ case '/':
+ case '$':
+ case '&':
+ return 0;
+ default:
+ if (ch <= ' ' && ch >= 0 || ch == ',')
+ continue;
+ Ungetc(ch,f__cf);
+ if (ch = getname(buf,sizeof(buf)))
+ return ch;
+ goto havename;
+ }
+ havename:
+ v = hash(ht,buf);
+ if (!v)
+ errfl(a->cierr, 119, where);
+ while(GETC(ch) <= ' ' && ch >= 0);
+ vaddr = v->addr;
+ type = v->type;
+ if (type < 0) {
+ size = -type;
+ type = TYCHAR;
+ }
+ else
+ size = f__typesize[type];
+ ivae = size;
+ iva = readall = 0;
+ if (ch == '(' /*)*/ ) {
+ dn = dimens;
+ if (!(dims = v->dims)) {
+ if (type != TYCHAR)
+ errfl(a->cierr, 122, where);
+ if (k = getdimen(&ch, dn, (ftnlen)size,
+ (ftnlen)size, &b))
+ errfl(a->cierr, k, where);
+ if (ch != ')')
+ errfl(a->cierr, 115, where);
+ b1 = dn->extent;
+ if (--b < 0 || b + b1 > size)
+ return 124;
+ iva += b;
+ size = b1;
+ while(GETC(ch) <= ' ' && ch >= 0);
+ goto scalar;
+ }
+ nd = (int)dims[0];
+ nomax = span = dims[1];
+ ivae = iva + size*nomax;
+ colonseen = 0;
+ if (k = getdimen(&ch, dn, size, nomax, &b))
+ errfl(a->cierr, k, where);
+ no = dn->extent;
+ b0 = dims[2];
+ dims1 = dims += 3;
+ ex = 1;
+ for(n = 1; n++ < nd; dims++) {
+ if (ch != ',')
+ errfl(a->cierr, 115, where);
+ dn1 = dn + 1;
+ span /= *dims;
+ if (k = getdimen(&ch, dn1, dn->delta**dims,
+ span, &b1))
+ errfl(a->cierr, k, where);
+ ex *= *dims;
+ b += b1*ex;
+ no *= dn1->extent;
+ dn = dn1;
+ }
+ if (ch != ')')
+ errfl(a->cierr, 115, where);
+ readall = 1 - colonseen;
+ b -= b0;
+ if (b < 0 || b >= nomax)
+ errfl(a->cierr, 125, where);
+ iva += size * b;
+ dims = dims1;
+ while(GETC(ch) <= ' ' && ch >= 0);
+ no1 = 1;
+ dn0 = dimens;
+ if (type == TYCHAR && ch == '(' /*)*/) {
+ if (k = getdimen(&ch, &substr, size, size, &b))
+ errfl(a->cierr, k, where);
+ if (ch != ')')
+ errfl(a->cierr, 115, where);
+ b1 = substr.extent;
+ if (--b < 0 || b + b1 > size)
+ return 124;
+ iva += b;
+ b0 = size;
+ size = b1;
+ while(GETC(ch) <= ' ' && ch >= 0);
+ if (b1 < b0)
+ goto delta_adj;
+ }
+ if (readall)
+ goto delta_adj;
+ for(; dn0 < dn; dn0++) {
+ if (dn0->extent != *dims++ || dn0->stride != 1)
+ break;
+ no1 *= dn0->extent;
+ }
+ if (dn0 == dimens && dimens[0].stride == 1) {
+ no1 = dimens[0].extent;
+ dn0++;
+ }
+ delta_adj:
+ ex = 0;
+ for(dn1 = dn0; dn1 <= dn; dn1++)
+ ex += (dn1->extent-1)
+ * (dn1->delta *= dn1->stride);
+ for(dn1 = dn; dn1 > dn0; dn1--) {
+ ex -= (dn1->extent - 1) * dn1->delta;
+ dn1->delta -= ex;
+ }
+ }
+ else if (dims = v->dims) {
+ no = no1 = dims[1];
+ ivae = iva + no*size;
+ }
+ else
+ scalar:
+ no = no1 = 1;
+ if (ch != '=')
+ errfl(a->cierr, 115, where);
+ got1 = nml_read = 1;
+ f__lcount = 0;
+ readloop:
+ for(;;) {
+ if (iva >= ivae || iva < 0) {
+ f__lquit = 1;
+ goto mustend;
+ }
+ else if (iva + no1*size > ivae)
+ no1 = (ivae - iva)/size;
+ f__lquit = 0;
+ if (k = l_read(&no1, vaddr + iva, size, type))
+ return k;
+ if (f__lquit == 1)
+ return 0;
+ if (readall) {
+ iva += dn0->delta;
+ if (f__lcount > 0) {
+ no2 = (ivae - iva)/size;
+ if (no2 > f__lcount)
+ no2 = f__lcount;
+ if (k = l_read(&no2, vaddr + iva,
+ size, type))
+ return k;
+ iva += no2 * dn0->delta;
+ }
+ }
+ mustend:
+ GETC(ch);
+ if (readall)
+ if (iva >= ivae)
+ readall = 0;
+ else for(;;) {
+ switch(ch) {
+ case ' ':
+ case '\t':
+ case '\n':
+ GETC(ch);
+ continue;
+ }
+ break;
+ }
+ if (ch == '/' || ch == '$' || ch == '&') {
+ f__lquit = 1;
+ return 0;
+ }
+ else if (f__lquit) {
+ while(ch <= ' ' && ch >= 0)
+ GETC(ch);
+ Ungetc(ch,f__cf);
+ if (!Alpha[ch & 0xff] && ch >= 0)
+ errfl(a->cierr, 125, where);
+ break;
+ }
+ Ungetc(ch,f__cf);
+ if (readall && !Alpha[ch & 0xff])
+ goto readloop;
+ if ((no -= no1) <= 0)
+ break;
+ for(dn1 = dn0; dn1 <= dn; dn1++) {
+ if (++dn1->curval < dn1->extent) {
+ iva += dn1->delta;
+ goto readloop;
+ }
+ dn1->curval = 0;
+ }
+ break;
+ }
+ }
+ }
+
+ integer
+#ifdef KR_headers
+s_rsne(a) cilist *a;
+#else
+s_rsne(cilist *a)
+#endif
+{
+ extern int l_eof;
+ int n;
+
+ f__external=1;
+ l_eof = 0;
+ if(n = c_le(a))
+ return n;
+ if(f__curunit->uwrt && f__nowreading(f__curunit))
+ err(a->cierr,errno,where0);
+ l_getc = t_getc;
+ l_ungetc = un_getc;
+ f__doend = xrd_SL;
+ n = x_rsne(a);
+ nml_read = 0;
+ if (n)
+ return n;
+ return e_rsle();
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/s_cat.c b/F2CLIBS/libf2c/s_cat.c
new file mode 100644
index 0000000..8d92a63
--- /dev/null
+++ b/F2CLIBS/libf2c/s_cat.c
@@ -0,0 +1,86 @@
+/* Unless compiled with -DNO_OVERWRITE, this variant of s_cat allows the
+ * target of a concatenation to appear on its right-hand side (contrary
+ * to the Fortran 77 Standard, but in accordance with Fortran 90).
+ */
+
+#include "f2c.h"
+#ifndef NO_OVERWRITE
+#include "stdio.h"
+#undef abs
+#ifdef KR_headers
+ extern char *F77_aloc();
+ extern void free();
+ extern void exit_();
+#else
+#undef min
+#undef max
+#include "stdlib.h"
+extern
+#ifdef __cplusplus
+ "C"
+#endif
+ char *F77_aloc(ftnlen, const char*);
+#endif
+#include "string.h"
+#endif /* NO_OVERWRITE */
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+ VOID
+#ifdef KR_headers
+s_cat(lp, rpp, rnp, np, ll) char *lp, *rpp[]; ftnint rnp[], *np; ftnlen ll;
+#else
+s_cat(char *lp, char *rpp[], ftnint rnp[], ftnint *np, ftnlen ll)
+#endif
+{
+ ftnlen i, nc;
+ char *rp;
+ ftnlen n = *np;
+#ifndef NO_OVERWRITE
+ ftnlen L, m;
+ char *lp0, *lp1;
+
+ lp0 = 0;
+ lp1 = lp;
+ L = ll;
+ i = 0;
+ while(i < n) {
+ rp = rpp[i];
+ m = rnp[i++];
+ if (rp >= lp1 || rp + m <= lp) {
+ if ((L -= m) <= 0) {
+ n = i;
+ break;
+ }
+ lp1 += m;
+ continue;
+ }
+ lp0 = lp;
+ lp = lp1 = F77_aloc(L = ll, "s_cat");
+ break;
+ }
+ lp1 = lp;
+#endif /* NO_OVERWRITE */
+ for(i = 0 ; i < n ; ++i) {
+ nc = ll;
+ if(rnp[i] < nc)
+ nc = rnp[i];
+ ll -= nc;
+ rp = rpp[i];
+ while(--nc >= 0)
+ *lp++ = *rp++;
+ }
+ while(--ll >= 0)
+ *lp++ = ' ';
+#ifndef NO_OVERWRITE
+ if (lp0) {
+ memcpy(lp0, lp1, L);
+ free(lp1);
+ }
+#endif
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/s_cmp.c b/F2CLIBS/libf2c/s_cmp.c
new file mode 100644
index 0000000..3a2ea67
--- /dev/null
+++ b/F2CLIBS/libf2c/s_cmp.c
@@ -0,0 +1,50 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/* compare two strings */
+
+#ifdef KR_headers
+integer s_cmp(a0, b0, la, lb) char *a0, *b0; ftnlen la, lb;
+#else
+integer s_cmp(char *a0, char *b0, ftnlen la, ftnlen lb)
+#endif
+{
+register unsigned char *a, *aend, *b, *bend;
+a = (unsigned char *)a0;
+b = (unsigned char *)b0;
+aend = a + la;
+bend = b + lb;
+
+if(la <= lb)
+ {
+ while(a < aend)
+ if(*a != *b)
+ return( *a - *b );
+ else
+ { ++a; ++b; }
+
+ while(b < bend)
+ if(*b != ' ')
+ return( ' ' - *b );
+ else ++b;
+ }
+
+else
+ {
+ while(b < bend)
+ if(*a == *b)
+ { ++a; ++b; }
+ else
+ return( *a - *b );
+ while(a < aend)
+ if(*a != ' ')
+ return(*a - ' ');
+ else ++a;
+ }
+return(0);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/s_copy.c b/F2CLIBS/libf2c/s_copy.c
new file mode 100644
index 0000000..9dacfc7
--- /dev/null
+++ b/F2CLIBS/libf2c/s_copy.c
@@ -0,0 +1,57 @@
+/* Unless compiled with -DNO_OVERWRITE, this variant of s_copy allows the
+ * target of an assignment to appear on its right-hand side (contrary
+ * to the Fortran 77 Standard, but in accordance with Fortran 90),
+ * as in a(2:5) = a(4:7) .
+ */
+
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/* assign strings: a = b */
+
+#ifdef KR_headers
+VOID s_copy(a, b, la, lb) register char *a, *b; ftnlen la, lb;
+#else
+void s_copy(register char *a, register char *b, ftnlen la, ftnlen lb)
+#endif
+{
+ register char *aend, *bend;
+
+ aend = a + la;
+
+ if(la <= lb)
+#ifndef NO_OVERWRITE
+ if (a <= b || a >= b + la)
+#endif
+ while(a < aend)
+ *a++ = *b++;
+#ifndef NO_OVERWRITE
+ else
+ for(b += la; a < aend; )
+ *--aend = *--b;
+#endif
+
+ else {
+ bend = b + lb;
+#ifndef NO_OVERWRITE
+ if (a <= b || a >= bend)
+#endif
+ while(b < bend)
+ *a++ = *b++;
+#ifndef NO_OVERWRITE
+ else {
+ a += lb;
+ while(b < bend)
+ *--a = *--bend;
+ a += lb;
+ }
+#endif
+ while(a < aend)
+ *a++ = ' ';
+ }
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/s_paus.c b/F2CLIBS/libf2c/s_paus.c
new file mode 100644
index 0000000..51d80eb
--- /dev/null
+++ b/F2CLIBS/libf2c/s_paus.c
@@ -0,0 +1,96 @@
+#include "stdio.h"
+#include "f2c.h"
+#define PAUSESIG 15
+
+#include "signal1.h"
+#ifdef KR_headers
+#define Void /* void */
+#define Int /* int */
+#else
+#define Void void
+#define Int int
+#undef abs
+#undef min
+#undef max
+#include "stdlib.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern int getpid(void), isatty(int), pause(void);
+#endif
+
+extern VOID f_exit(Void);
+
+#ifndef MSDOS
+ static VOID
+waitpause(Sigarg)
+{ Use_Sigarg;
+ return;
+ }
+#endif
+
+ static VOID
+#ifdef KR_headers
+s_1paus(fin) FILE *fin;
+#else
+s_1paus(FILE *fin)
+#endif
+{
+ fprintf(stderr,
+ "To resume execution, type go. Other input will terminate the job.\n");
+ fflush(stderr);
+ if( getc(fin)!='g' || getc(fin)!='o' || getc(fin)!='\n' ) {
+ fprintf(stderr, "STOP\n");
+#ifdef NO_ONEXIT
+ f_exit();
+#endif
+ exit(0);
+ }
+ }
+
+ int
+#ifdef KR_headers
+s_paus(s, n) char *s; ftnlen n;
+#else
+s_paus(char *s, ftnlen n)
+#endif
+{
+ fprintf(stderr, "PAUSE ");
+ if(n > 0)
+ fprintf(stderr, " %.*s", (int)n, s);
+ fprintf(stderr, " statement executed\n");
+ if( isatty(fileno(stdin)) )
+ s_1paus(stdin);
+ else {
+#ifdef MSDOS
+ FILE *fin;
+ fin = fopen("con", "r");
+ if (!fin) {
+ fprintf(stderr, "s_paus: can't open con!\n");
+ fflush(stderr);
+ exit(1);
+ }
+ s_1paus(fin);
+ fclose(fin);
+#else
+ fprintf(stderr,
+ "To resume execution, execute a kill -%d %d command\n",
+ PAUSESIG, getpid() );
+ signal1(PAUSESIG, waitpause);
+ fflush(stderr);
+ pause();
+#endif
+ }
+ fprintf(stderr, "Execution resumes after PAUSE.\n");
+ fflush(stderr);
+ return 0; /* NOT REACHED */
+#ifdef __cplusplus
+ }
+#endif
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/s_rnge.c b/F2CLIBS/libf2c/s_rnge.c
new file mode 100644
index 0000000..3dbc513
--- /dev/null
+++ b/F2CLIBS/libf2c/s_rnge.c
@@ -0,0 +1,32 @@
+#include "stdio.h"
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/* called when a subscript is out of range */
+
+#ifdef KR_headers
+extern VOID sig_die();
+integer s_rnge(varn, offset, procn, line) char *varn, *procn; ftnint offset, line;
+#else
+extern VOID sig_die(const char*,int);
+integer s_rnge(char *varn, ftnint offset, char *procn, ftnint line)
+#endif
+{
+register int i;
+
+fprintf(stderr, "Subscript out of range on file line %ld, procedure ",
+ (long)line);
+while((i = *procn) && i != '_' && i != ' ')
+ putc(*procn++, stderr);
+fprintf(stderr, ".\nAttempt to access the %ld-th element of variable ",
+ (long)offset+1);
+while((i = *varn) && i != ' ')
+ putc(*varn++, stderr);
+sig_die(".", 1);
+return 0; /* not reached */
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/s_stop.c b/F2CLIBS/libf2c/s_stop.c
new file mode 100644
index 0000000..68233ae
--- /dev/null
+++ b/F2CLIBS/libf2c/s_stop.c
@@ -0,0 +1,48 @@
+#include "stdio.h"
+#include "f2c.h"
+
+#ifdef KR_headers
+extern void f_exit();
+int s_stop(s, n) char *s; ftnlen n;
+#else
+#undef abs
+#undef min
+#undef max
+#include "stdlib.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+#ifdef __cplusplus
+extern "C" {
+#endif
+void f_exit(void);
+
+int s_stop(char *s, ftnlen n)
+#endif
+{
+int i;
+
+if(n > 0)
+ {
+ fprintf(stderr, "STOP ");
+ for(i = 0; i<n ; ++i)
+ putc(*s++, stderr);
+ fprintf(stderr, " statement executed\n");
+ }
+#ifdef NO_ONEXIT
+f_exit();
+#endif
+exit(0);
+
+/* We cannot avoid (useless) compiler diagnostics here: */
+/* some compilers complain if there is no return statement, */
+/* and others complain that this one cannot be reached. */
+
+return 0; /* NOT REACHED */
+}
+#ifdef __cplusplus
+}
+#endif
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/scomptry.bat b/F2CLIBS/libf2c/scomptry.bat
new file mode 100644
index 0000000..2c11a97
--- /dev/null
+++ b/F2CLIBS/libf2c/scomptry.bat
@@ -0,0 +1,5 @@
+%1 -DWRITE_ARITH_H -DNO_FPINIT %2 %3 %4 %5 %6 %7 %8 %9
+if errorlevel 1 goto nolonglong
+exit 0
+:nolonglong
+%1 -DNO_LONG_LONG -DWRITE_ARITH_H -DNO_FPINIT %2 %3 %4 %5 %6 %7 %8 %9
diff --git a/F2CLIBS/libf2c/sfe.c b/F2CLIBS/libf2c/sfe.c
new file mode 100644
index 0000000..d24af6d
--- /dev/null
+++ b/F2CLIBS/libf2c/sfe.c
@@ -0,0 +1,47 @@
+/* sequential formatted external common routines*/
+#include "f2c.h"
+#include "fio.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+extern char *f__fmtbuf;
+#else
+extern const char *f__fmtbuf;
+#endif
+
+integer e_rsfe(Void)
+{ int n;
+ n=en_fio();
+ f__fmtbuf=NULL;
+ return(n);
+}
+
+ int
+#ifdef KR_headers
+c_sfe(a) cilist *a; /* check */
+#else
+c_sfe(cilist *a) /* check */
+#endif
+{ unit *p;
+ f__curunit = p = &f__units[a->ciunit];
+ if(a->ciunit >= MXUNIT || a->ciunit<0)
+ err(a->cierr,101,"startio");
+ if(p->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) err(a->cierr,114,"sfe")
+ if(!p->ufmt) err(a->cierr,102,"sfe")
+ return(0);
+}
+integer e_wsfe(Void)
+{
+ int n = en_fio();
+ f__fmtbuf = NULL;
+#ifdef ALWAYS_FLUSH
+ if (!n && fflush(f__cf))
+ err(f__elist->cierr, errno, "write end");
+#endif
+ return n;
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/sig_die.c b/F2CLIBS/libf2c/sig_die.c
new file mode 100644
index 0000000..63a73d9
--- /dev/null
+++ b/F2CLIBS/libf2c/sig_die.c
@@ -0,0 +1,51 @@
+#include "stdio.h"
+#include "signal.h"
+
+#ifndef SIGIOT
+#ifdef SIGABRT
+#define SIGIOT SIGABRT
+#endif
+#endif
+
+#ifdef KR_headers
+void sig_die(s, kill) char *s; int kill;
+#else
+#include "stdlib.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+#ifdef __cplusplus
+extern "C" {
+#endif
+ extern void f_exit(void);
+
+void sig_die(const char *s, int kill)
+#endif
+{
+ /* print error message, then clear buffers */
+ fprintf(stderr, "%s\n", s);
+
+ if(kill)
+ {
+ fflush(stderr);
+ f_exit();
+ fflush(stderr);
+ /* now get a core */
+#ifdef SIGIOT
+ signal(SIGIOT, SIG_DFL);
+#endif
+ abort();
+ }
+ else {
+#ifdef NO_ONEXIT
+ f_exit();
+#endif
+ exit(1);
+ }
+ }
+#ifdef __cplusplus
+}
+#endif
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/signal1.h b/F2CLIBS/libf2c/signal1.h
new file mode 100644
index 0000000..a383774
--- /dev/null
+++ b/F2CLIBS/libf2c/signal1.h
@@ -0,0 +1,35 @@
+/* You may need to adjust the definition of signal1 to supply a */
+/* cast to the correct argument type. This detail is system- and */
+/* compiler-dependent. The #define below assumes signal.h declares */
+/* type SIG_PF for the signal function's second argument. */
+
+/* For some C++ compilers, "#define Sigarg_t ..." may be appropriate. */
+
+#include <signal.h>
+
+#ifndef Sigret_t
+#define Sigret_t void
+#endif
+#ifndef Sigarg_t
+#ifdef KR_headers
+#define Sigarg_t
+#else
+#define Sigarg_t int
+#endif
+#endif /*Sigarg_t*/
+
+#ifdef USE_SIG_PF /* compile with -DUSE_SIG_PF under IRIX */
+#define sig_pf SIG_PF
+#else
+typedef Sigret_t (*sig_pf)(Sigarg_t);
+#endif
+
+#define signal1(a,b) signal(a,(sig_pf)b)
+
+#ifdef __cplusplus
+#define Sigarg ...
+#define Use_Sigarg
+#else
+#define Sigarg Int n
+#define Use_Sigarg n = n /* shut up compiler warning */
+#endif
diff --git a/F2CLIBS/libf2c/signal_.c b/F2CLIBS/libf2c/signal_.c
new file mode 100644
index 0000000..3b0e6cf
--- /dev/null
+++ b/F2CLIBS/libf2c/signal_.c
@@ -0,0 +1,21 @@
+#include "f2c.h"
+#include "signal1.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+ ftnint
+#ifdef KR_headers
+signal_(sigp, proc) integer *sigp; sig_pf proc;
+#else
+signal_(integer *sigp, sig_pf proc)
+#endif
+{
+ int sig;
+ sig = (int)*sigp;
+
+ return (ftnint)signal(sig, proc);
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/signbit.c b/F2CLIBS/libf2c/signbit.c
new file mode 100644
index 0000000..de95a3b
--- /dev/null
+++ b/F2CLIBS/libf2c/signbit.c
@@ -0,0 +1,24 @@
+#include "arith.h"
+
+#ifndef Long
+#define Long long
+#endif
+
+ int
+#ifdef KR_headers
+signbit_f2c(x) double *x;
+#else
+signbit_f2c(double *x)
+#endif
+{
+#ifdef IEEE_MC68k
+ if (*(Long*)x & 0x80000000)
+ return 1;
+#else
+#ifdef IEEE_8087
+ if (((Long*)x)[1] & 0x80000000)
+ return 1;
+#endif /*IEEE_8087*/
+#endif /*IEEE_MC68k*/
+ return 0;
+ }
diff --git a/F2CLIBS/libf2c/sue.c b/F2CLIBS/libf2c/sue.c
new file mode 100644
index 0000000..191e326
--- /dev/null
+++ b/F2CLIBS/libf2c/sue.c
@@ -0,0 +1,90 @@
+#include "f2c.h"
+#include "fio.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern uiolen f__reclen;
+OFF_T f__recloc;
+
+ int
+#ifdef KR_headers
+c_sue(a) cilist *a;
+#else
+c_sue(cilist *a)
+#endif
+{
+ f__external=f__sequential=1;
+ f__formatted=0;
+ f__curunit = &f__units[a->ciunit];
+ if(a->ciunit >= MXUNIT || a->ciunit < 0)
+ err(a->cierr,101,"startio");
+ f__elist=a;
+ if(f__curunit->ufd==NULL && fk_open(SEQ,UNF,a->ciunit))
+ err(a->cierr,114,"sue");
+ f__cf=f__curunit->ufd;
+ if(f__curunit->ufmt) err(a->cierr,103,"sue")
+ if(!f__curunit->useek) err(a->cierr,103,"sue")
+ return(0);
+}
+#ifdef KR_headers
+integer s_rsue(a) cilist *a;
+#else
+integer s_rsue(cilist *a)
+#endif
+{
+ int n;
+ if(!f__init) f_init();
+ f__reading=1;
+ if(n=c_sue(a)) return(n);
+ f__recpos=0;
+ if(f__curunit->uwrt && f__nowreading(f__curunit))
+ err(a->cierr, errno, "read start");
+ if(fread((char *)&f__reclen,sizeof(uiolen),1,f__cf)
+ != 1)
+ { if(feof(f__cf))
+ { f__curunit->uend = 1;
+ err(a->ciend, EOF, "start");
+ }
+ clearerr(f__cf);
+ err(a->cierr, errno, "start");
+ }
+ return(0);
+}
+#ifdef KR_headers
+integer s_wsue(a) cilist *a;
+#else
+integer s_wsue(cilist *a)
+#endif
+{
+ int n;
+ if(!f__init) f_init();
+ if(n=c_sue(a)) return(n);
+ f__reading=0;
+ f__reclen=0;
+ if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
+ err(a->cierr, errno, "write start");
+ f__recloc=FTELL(f__cf);
+ FSEEK(f__cf,(OFF_T)sizeof(uiolen),SEEK_CUR);
+ return(0);
+}
+integer e_wsue(Void)
+{ OFF_T loc;
+ fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf);
+#ifdef ALWAYS_FLUSH
+ if (fflush(f__cf))
+ err(f__elist->cierr, errno, "write end");
+#endif
+ loc=FTELL(f__cf);
+ FSEEK(f__cf,f__recloc,SEEK_SET);
+ fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf);
+ FSEEK(f__cf,loc,SEEK_SET);
+ return(0);
+}
+integer e_rsue(Void)
+{
+ FSEEK(f__cf,(OFF_T)(f__reclen-f__recpos+sizeof(uiolen)),SEEK_CUR);
+ return(0);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/sysdep1.h b/F2CLIBS/libf2c/sysdep1.h
new file mode 100644
index 0000000..4c026a2
--- /dev/null
+++ b/F2CLIBS/libf2c/sysdep1.h
@@ -0,0 +1,66 @@
+#ifndef SYSDEP_H_INCLUDED
+#define SYSDEP_H_INCLUDED
+#undef USE_LARGEFILE
+#ifndef NO_LONG_LONG
+
+#ifdef __sun__
+#define USE_LARGEFILE
+#define OFF_T off64_t
+#endif
+
+#ifdef __linux__
+#define USE_LARGEFILE
+#define OFF_T __off64_t
+#endif
+
+#ifdef _AIX43
+#define _LARGE_FILES
+#define _LARGE_FILE_API
+#define USE_LARGEFILE
+#endif /*_AIX43*/
+
+#ifdef __hpux
+#define _FILE64
+#define _LARGEFILE64_SOURCE
+#define USE_LARGEFILE
+#endif /*__hpux*/
+
+#ifdef __sgi
+#define USE_LARGEFILE
+#endif /*__sgi*/
+
+#ifdef __FreeBSD__
+#define OFF_T off_t
+#define FSEEK fseeko
+#define FTELL ftello
+#endif
+
+#ifdef USE_LARGEFILE
+#ifndef OFF_T
+#define OFF_T off64_t
+#endif
+#define _LARGEFILE_SOURCE
+#define _LARGEFILE64_SOURCE
+#include <sys/types.h>
+#include <sys/stat.h>
+#define FOPEN fopen64
+#define FREOPEN freopen64
+#define FSEEK fseeko64
+#define FSTAT fstat64
+#define FTELL ftello64
+#define FTRUNCATE ftruncate64
+#define STAT stat64
+#define STAT_ST stat64
+#endif /*USE_LARGEFILE*/
+#endif /*NO_LONG_LONG*/
+
+#ifndef NON_UNIX_STDIO
+#ifndef USE_LARGEFILE
+#define _INCLUDE_POSIX_SOURCE /* for HP-UX */
+#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */
+#include "sys/types.h"
+#include "sys/stat.h"
+#endif
+#endif
+
+#endif /*SYSDEP_H_INCLUDED*/
diff --git a/F2CLIBS/libf2c/system_.c b/F2CLIBS/libf2c/system_.c
new file mode 100644
index 0000000..b18e8a6
--- /dev/null
+++ b/F2CLIBS/libf2c/system_.c
@@ -0,0 +1,42 @@
+/* f77 interface to system routine */
+
+#include "f2c.h"
+
+#ifdef KR_headers
+extern char *F77_aloc();
+
+ integer
+system_(s, n) register char *s; ftnlen n;
+#else
+#undef abs
+#undef min
+#undef max
+#include "stdlib.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern char *F77_aloc(ftnlen, const char*);
+
+ integer
+system_(register char *s, ftnlen n)
+#endif
+{
+ char buff0[256], *buff;
+ register char *bp, *blast;
+ integer rv;
+
+ buff = bp = n < sizeof(buff0)
+ ? buff0 : F77_aloc(n+1, "system_");
+ blast = bp + n;
+
+ while(bp < blast && *s)
+ *bp++ = *s++;
+ *bp = 0;
+ rv = system(buff);
+ if (buff != buff0)
+ free(buff);
+ return rv;
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/typesize.c b/F2CLIBS/libf2c/typesize.c
new file mode 100644
index 0000000..39097f4
--- /dev/null
+++ b/F2CLIBS/libf2c/typesize.c
@@ -0,0 +1,18 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+ftnlen f__typesize[] = { 0, 0, sizeof(shortint), sizeof(integer),
+ sizeof(real), sizeof(doublereal),
+ sizeof(complex), sizeof(doublecomplex),
+ sizeof(logical), sizeof(char),
+ 0, sizeof(integer1),
+ sizeof(logical1), sizeof(shortlogical),
+#ifdef Allow_TYQUAD
+ sizeof(longint),
+#endif
+ 0};
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/uio.c b/F2CLIBS/libf2c/uio.c
new file mode 100644
index 0000000..44f768d
--- /dev/null
+++ b/F2CLIBS/libf2c/uio.c
@@ -0,0 +1,75 @@
+#include "f2c.h"
+#include "fio.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+uiolen f__reclen;
+
+ int
+#ifdef KR_headers
+do_us(number,ptr,len) ftnint *number; char *ptr; ftnlen len;
+#else
+do_us(ftnint *number, char *ptr, ftnlen len)
+#endif
+{
+ if(f__reading)
+ {
+ f__recpos += (int)(*number * len);
+ if(f__recpos>f__reclen)
+ err(f__elist->cierr, 110, "do_us");
+ if (fread(ptr,(int)len,(int)(*number),f__cf) != *number)
+ err(f__elist->ciend, EOF, "do_us");
+ return(0);
+ }
+ else
+ {
+ f__reclen += *number * len;
+ (void) fwrite(ptr,(int)len,(int)(*number),f__cf);
+ return(0);
+ }
+}
+#ifdef KR_headers
+integer do_ud(number,ptr,len) ftnint *number; char *ptr; ftnlen len;
+#else
+integer do_ud(ftnint *number, char *ptr, ftnlen len)
+#endif
+{
+ f__recpos += (int)(*number * len);
+ if(f__recpos > f__curunit->url && f__curunit->url!=1)
+ err(f__elist->cierr,110,"do_ud");
+ if(f__reading)
+ {
+#ifdef Pad_UDread
+#ifdef KR_headers
+ int i;
+#else
+ size_t i;
+#endif
+ if (!(i = fread(ptr,(int)len,(int)(*number),f__cf))
+ && !(f__recpos - *number*len))
+ err(f__elist->cierr,EOF,"do_ud")
+ if (i < *number)
+ memset(ptr + i*len, 0, (*number - i)*len);
+ return 0;
+#else
+ if(fread(ptr,(int)len,(int)(*number),f__cf) != *number)
+ err(f__elist->cierr,EOF,"do_ud")
+ else return(0);
+#endif
+ }
+ (void) fwrite(ptr,(int)len,(int)(*number),f__cf);
+ return(0);
+}
+#ifdef KR_headers
+integer do_uio(number,ptr,len) ftnint *number; char *ptr; ftnlen len;
+#else
+integer do_uio(ftnint *number, char *ptr, ftnlen len)
+#endif
+{
+ if(f__sequential)
+ return(do_us(number,ptr,len));
+ else return(do_ud(number,ptr,len));
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/uninit.c b/F2CLIBS/libf2c/uninit.c
new file mode 100644
index 0000000..f15fe39
--- /dev/null
+++ b/F2CLIBS/libf2c/uninit.c
@@ -0,0 +1,377 @@
+#include <stdio.h>
+#include <string.h>
+#include "arith.h"
+
+#define TYSHORT 2
+#define TYLONG 3
+#define TYREAL 4
+#define TYDREAL 5
+#define TYCOMPLEX 6
+#define TYDCOMPLEX 7
+#define TYINT1 11
+#define TYQUAD 14
+#ifndef Long
+#define Long long
+#endif
+
+#ifdef __mips
+#define RNAN 0xffc00000
+#define DNAN0 0xfff80000
+#define DNAN1 0
+#endif
+
+#ifdef _PA_RISC1_1
+#define RNAN 0xffc00000
+#define DNAN0 0xfff80000
+#define DNAN1 0
+#endif
+
+#ifndef RNAN
+#define RNAN 0xff800001
+#ifdef IEEE_MC68k
+#define DNAN0 0xfff00000
+#define DNAN1 1
+#else
+#define DNAN0 1
+#define DNAN1 0xfff00000
+#endif
+#endif /*RNAN*/
+
+#ifdef KR_headers
+#define Void /*void*/
+#define FA7UL (unsigned Long) 0xfa7a7a7aL
+#else
+#define Void void
+#define FA7UL 0xfa7a7a7aUL
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+static void ieee0(Void);
+
+static unsigned Long rnan = RNAN,
+ dnan0 = DNAN0,
+ dnan1 = DNAN1;
+
+double _0 = 0.;
+
+ void
+#ifdef KR_headers
+_uninit_f2c(x, type, len) void *x; int type; long len;
+#else
+_uninit_f2c(void *x, int type, long len)
+#endif
+{
+ static int first = 1;
+
+ unsigned Long *lx, *lxe;
+
+ if (first) {
+ first = 0;
+ ieee0();
+ }
+ if (len == 1)
+ switch(type) {
+ case TYINT1:
+ *(char*)x = 'Z';
+ return;
+ case TYSHORT:
+ *(short*)x = 0xfa7a;
+ break;
+ case TYLONG:
+ *(unsigned Long*)x = FA7UL;
+ return;
+ case TYQUAD:
+ case TYCOMPLEX:
+ case TYDCOMPLEX:
+ break;
+ case TYREAL:
+ *(unsigned Long*)x = rnan;
+ return;
+ case TYDREAL:
+ lx = (unsigned Long*)x;
+ lx[0] = dnan0;
+ lx[1] = dnan1;
+ return;
+ default:
+ printf("Surprise type %d in _uninit_f2c\n", type);
+ }
+ switch(type) {
+ case TYINT1:
+ memset(x, 'Z', len);
+ break;
+ case TYSHORT:
+ *(short*)x = 0xfa7a;
+ break;
+ case TYQUAD:
+ len *= 2;
+ /* no break */
+ case TYLONG:
+ lx = (unsigned Long*)x;
+ lxe = lx + len;
+ while(lx < lxe)
+ *lx++ = FA7UL;
+ break;
+ case TYCOMPLEX:
+ len *= 2;
+ /* no break */
+ case TYREAL:
+ lx = (unsigned Long*)x;
+ lxe = lx + len;
+ while(lx < lxe)
+ *lx++ = rnan;
+ break;
+ case TYDCOMPLEX:
+ len *= 2;
+ /* no break */
+ case TYDREAL:
+ lx = (unsigned Long*)x;
+ for(lxe = lx + 2*len; lx < lxe; lx += 2) {
+ lx[0] = dnan0;
+ lx[1] = dnan1;
+ }
+ }
+ }
+#ifdef __cplusplus
+}
+#endif
+
+#ifndef MSpc
+#ifdef MSDOS
+#define MSpc
+#else
+#ifdef _WIN32
+#define MSpc
+#endif
+#endif
+#endif
+
+#ifdef MSpc
+#define IEEE0_done
+#include "float.h"
+#include "signal.h"
+
+ static void
+ieee0(Void)
+{
+#ifndef __alpha
+#ifndef EM_DENORMAL
+#define EM_DENORMAL _EM_DENORMAL
+#endif
+#ifndef EM_UNDERFLOW
+#define EM_UNDERFLOW _EM_UNDERFLOW
+#endif
+#ifndef EM_INEXACT
+#define EM_INEXACT _EM_INEXACT
+#endif
+#ifndef MCW_EM
+#define MCW_EM _MCW_EM
+#endif
+ _control87(EM_DENORMAL | EM_UNDERFLOW | EM_INEXACT, MCW_EM);
+#endif
+ /* With MS VC++, compiling and linking with -Zi will permit */
+ /* clicking to invoke the MS C++ debugger, which will show */
+ /* the point of error -- provided SIGFPE is SIG_DFL. */
+ signal(SIGFPE, SIG_DFL);
+ }
+#endif /* MSpc */
+
+#ifdef __mips /* must link with -lfpe */
+#define IEEE0_done
+/* code from Eric Grosse */
+#include <stdlib.h>
+#include <stdio.h>
+#include "/usr/include/sigfpe.h" /* full pathname for lcc -N */
+#include "/usr/include/sys/fpu.h"
+
+ static void
+#ifdef KR_headers
+ieeeuserhand(exception, val) unsigned exception[5]; int val[2];
+#else
+ieeeuserhand(unsigned exception[5], int val[2])
+#endif
+{
+ fflush(stdout);
+ fprintf(stderr,"ieee0() aborting because of ");
+ if(exception[0]==_OVERFL) fprintf(stderr,"overflow\n");
+ else if(exception[0]==_UNDERFL) fprintf(stderr,"underflow\n");
+ else if(exception[0]==_DIVZERO) fprintf(stderr,"divide by 0\n");
+ else if(exception[0]==_INVALID) fprintf(stderr,"invalid operation\n");
+ else fprintf(stderr,"\tunknown reason\n");
+ fflush(stderr);
+ abort();
+}
+
+ static void
+#ifdef KR_headers
+ieeeuserhand2(j) unsigned int **j;
+#else
+ieeeuserhand2(unsigned int **j)
+#endif
+{
+ fprintf(stderr,"ieee0() aborting because of confusion\n");
+ abort();
+}
+
+ static void
+ieee0(Void)
+{
+ int i;
+ for(i=1; i<=4; i++){
+ sigfpe_[i].count = 1000;
+ sigfpe_[i].trace = 1;
+ sigfpe_[i].repls = _USER_DETERMINED;
+ }
+ sigfpe_[1].repls = _ZERO; /* underflow */
+ handle_sigfpes( _ON,
+ _EN_UNDERFL|_EN_OVERFL|_EN_DIVZERO|_EN_INVALID,
+ ieeeuserhand,_ABORT_ON_ERROR,ieeeuserhand2);
+ }
+#endif /* mips */
+
+#ifdef __linux__
+#define IEEE0_done
+#include "fpu_control.h"
+
+#ifdef __alpha__
+#ifndef USE_setfpucw
+#define __setfpucw(x) __fpu_control = (x)
+#endif
+#endif
+
+#ifndef _FPU_SETCW
+#undef Can_use__setfpucw
+#define Can_use__setfpucw
+#endif
+
+ static void
+ieee0(Void)
+{
+#if (defined(__mc68000__) || defined(__mc68020__) || defined(mc68020) || defined (__mc68k__))
+/* Reported 20010705 by Alan Bain <alanb at chiark.greenend.org.uk> */
+/* Note that IEEE 754 IOP (illegal operation) */
+/* = Signaling NAN (SNAN) + operation error (OPERR). */
+#ifdef Can_use__setfpucw
+ __setfpucw(_FPU_IEEE + _FPU_DOUBLE + _FPU_MASK_OPERR + _FPU_MASK_DZ + _FPU_MASK_SNAN+_FPU_MASK_OVFL);
+#else
+ __fpu_control = _FPU_IEEE + _FPU_DOUBLE + _FPU_MASK_OPERR + _FPU_MASK_DZ + _FPU_MASK_SNAN+_FPU_MASK_OVFL;
+ _FPU_SETCW(__fpu_control);
+#endif
+
+#elif (defined(__powerpc__)||defined(_ARCH_PPC)||defined(_ARCH_PWR)) /* !__mc68k__ */
+/* Reported 20011109 by Alan Bain <alanb at chiark.greenend.org.uk> */
+
+#ifdef Can_use__setfpucw
+
+/* The following is NOT a mistake -- the author of the fpu_control.h
+for the PPC has erroneously defined IEEE mode to turn on exceptions
+other than Inexact! Start from default then and turn on only the ones
+which we want*/
+
+ __setfpucw(_FPU_DEFAULT + _FPU_MASK_IM+_FPU_MASK_OM+_FPU_MASK_UM);
+
+#else /* PPC && !Can_use__setfpucw */
+
+ __fpu_control = _FPU_DEFAULT +_FPU_MASK_OM+_FPU_MASK_IM+_FPU_MASK_UM;
+ _FPU_SETCW(__fpu_control);
+
+#endif /*Can_use__setfpucw*/
+
+#else /* !(mc68000||powerpc) */
+
+#ifdef _FPU_IEEE
+#ifndef _FPU_EXTENDED /* e.g., ARM processor under Linux */
+#define _FPU_EXTENDED 0
+#endif
+#ifndef _FPU_DOUBLE
+#define _FPU_DOUBLE 0
+#endif
+#ifdef Can_use__setfpucw /* pre-1997 (?) Linux */
+ __setfpucw(_FPU_IEEE - _FPU_MASK_IM - _FPU_MASK_ZM - _FPU_MASK_OM);
+#else
+#ifdef UNINIT_F2C_PRECISION_53 /* 20051004 */
+ /* unmask invalid, etc., and change rounding precision to double */
+ __fpu_control = _FPU_IEEE - _FPU_EXTENDED + _FPU_DOUBLE - _FPU_MASK_IM - _FPU_MASK_ZM - _FPU_MASK_OM;
+ _FPU_SETCW(__fpu_control);
+#else
+ /* unmask invalid, etc., and keep current rounding precision */
+ fpu_control_t cw;
+ _FPU_GETCW(cw);
+ cw &= ~(_FPU_MASK_IM | _FPU_MASK_ZM | _FPU_MASK_OM);
+ _FPU_SETCW(cw);
+#endif
+#endif
+
+#else /* !_FPU_IEEE */
+
+ fprintf(stderr, "\n%s\n%s\n%s\n%s\n",
+ "WARNING: _uninit_f2c in libf2c does not know how",
+ "to enable trapping on this system, so f2c's -trapuv",
+ "option will not detect uninitialized variables unless",
+ "you can enable trapping manually.");
+ fflush(stderr);
+
+#endif /* _FPU_IEEE */
+#endif /* __mc68k__ */
+ }
+#endif /* __linux__ */
+
+#ifdef __alpha
+#ifndef IEEE0_done
+#define IEEE0_done
+#include <machine/fpu.h>
+ static void
+ieee0(Void)
+{
+ ieee_set_fp_control(IEEE_TRAP_ENABLE_INV);
+ }
+#endif /*IEEE0_done*/
+#endif /*__alpha*/
+
+#ifdef __hpux
+#define IEEE0_done
+#define _INCLUDE_HPUX_SOURCE
+#include <math.h>
+
+#ifndef FP_X_INV
+#include <fenv.h>
+#define fpsetmask fesettrapenable
+#define FP_X_INV FE_INVALID
+#endif
+
+ static void
+ieee0(Void)
+{
+ fpsetmask(FP_X_INV);
+ }
+#endif /*__hpux*/
+
+#ifdef _AIX
+#define IEEE0_done
+#include <fptrap.h>
+
+ static void
+ieee0(Void)
+{
+ fp_enable(TRP_INVALID);
+ fp_trap(FP_TRAP_SYNC);
+ }
+#endif /*_AIX*/
+
+#ifdef __sun
+#define IEEE0_done
+#include <ieeefp.h>
+
+ static void
+ieee0(Void)
+{
+ fpsetmask(FP_X_INV);
+ }
+#endif /*__sparc*/
+
+#ifndef IEEE0_done
+ static void
+ieee0(Void) {}
+#endif
diff --git a/F2CLIBS/libf2c/util.c b/F2CLIBS/libf2c/util.c
new file mode 100644
index 0000000..ad4bec5
--- /dev/null
+++ b/F2CLIBS/libf2c/util.c
@@ -0,0 +1,57 @@
+#include "sysdep1.h" /* here to get stat64 on some badly designed Linux systems */
+#include "f2c.h"
+#include "fio.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+ VOID
+#ifdef KR_headers
+#define Const /*nothing*/
+g_char(a,alen,b) char *a,*b; ftnlen alen;
+#else
+#define Const const
+g_char(const char *a, ftnlen alen, char *b)
+#endif
+{
+ Const char *x = a + alen;
+ char *y = b + alen;
+
+ for(;; y--) {
+ if (x <= a) {
+ *b = 0;
+ return;
+ }
+ if (*--x != ' ')
+ break;
+ }
+ *y-- = 0;
+ do *y-- = *x;
+ while(x-- > a);
+ }
+
+ VOID
+#ifdef KR_headers
+b_char(a,b,blen) char *a,*b; ftnlen blen;
+#else
+b_char(const char *a, char *b, ftnlen blen)
+#endif
+{ int i;
+ for(i=0;i<blen && *a!=0;i++) *b++= *a++;
+ for(;i<blen;i++) *b++=' ';
+}
+#ifndef NON_UNIX_STDIO
+#ifdef KR_headers
+long f__inode(a, dev) char *a; int *dev;
+#else
+long f__inode(char *a, int *dev)
+#endif
+{ struct STAT_ST x;
+ if(STAT(a,&x)<0) return(-1);
+ *dev = x.st_dev;
+ return(x.st_ino);
+}
+#endif
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/wref.c b/F2CLIBS/libf2c/wref.c
new file mode 100644
index 0000000..f2074b7
--- /dev/null
+++ b/F2CLIBS/libf2c/wref.c
@@ -0,0 +1,294 @@
+#include "f2c.h"
+#include "fio.h"
+
+#ifndef KR_headers
+#undef abs
+#undef min
+#undef max
+#include "stdlib.h"
+#include "string.h"
+#endif
+
+#include "fmt.h"
+#include "fp.h"
+#ifndef VAX
+#include "ctype.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+#endif
+
+ int
+#ifdef KR_headers
+wrt_E(p,w,d,e,len) ufloat *p; ftnlen len;
+#else
+wrt_E(ufloat *p, int w, int d, int e, ftnlen len)
+#endif
+{
+ char buf[FMAX+EXPMAXDIGS+4], *s, *se;
+ int d1, delta, e1, i, sign, signspace;
+ double dd;
+#ifdef WANT_LEAD_0
+ int insert0 = 0;
+#endif
+#ifndef VAX
+ int e0 = e;
+#endif
+
+ if(e <= 0)
+ e = 2;
+ if(f__scale) {
+ if(f__scale >= d + 2 || f__scale <= -d)
+ goto nogood;
+ }
+ if(f__scale <= 0)
+ --d;
+ if (len == sizeof(real))
+ dd = p->pf;
+ else
+ dd = p->pd;
+ if (dd < 0.) {
+ signspace = sign = 1;
+ dd = -dd;
+ }
+ else {
+ sign = 0;
+ signspace = (int)f__cplus;
+#ifndef VAX
+ if (!dd) {
+#ifdef SIGNED_ZEROS
+ if (signbit_f2c(&dd))
+ signspace = sign = 1;
+#endif
+ dd = 0.; /* avoid -0 */
+ }
+#endif
+ }
+ delta = w - (2 /* for the . and the d adjustment above */
+ + 2 /* for the E+ */ + signspace + d + e);
+#ifdef WANT_LEAD_0
+ if (f__scale <= 0 && delta > 0) {
+ delta--;
+ insert0 = 1;
+ }
+ else
+#endif
+ if (delta < 0) {
+nogood:
+ while(--w >= 0)
+ PUT('*');
+ return(0);
+ }
+ if (f__scale < 0)
+ d += f__scale;
+ if (d > FMAX) {
+ d1 = d - FMAX;
+ d = FMAX;
+ }
+ else
+ d1 = 0;
+ sprintf(buf,"%#.*E", d, dd);
+#ifndef VAX
+ /* check for NaN, Infinity */
+ if (!isdigit(buf[0])) {
+ switch(buf[0]) {
+ case 'n':
+ case 'N':
+ signspace = 0; /* no sign for NaNs */
+ }
+ delta = w - strlen(buf) - signspace;
+ if (delta < 0)
+ goto nogood;
+ while(--delta >= 0)
+ PUT(' ');
+ if (signspace)
+ PUT(sign ? '-' : '+');
+ for(s = buf; *s; s++)
+ PUT(*s);
+ return 0;
+ }
+#endif
+ se = buf + d + 3;
+#ifdef GOOD_SPRINTF_EXPONENT /* When possible, exponent has 2 digits. */
+ if (f__scale != 1 && dd)
+ sprintf(se, "%+.2d", atoi(se) + 1 - f__scale);
+#else
+ if (dd)
+ sprintf(se, "%+.2d", atoi(se) + 1 - f__scale);
+ else
+ strcpy(se, "+00");
+#endif
+ s = ++se;
+ if (e < 2) {
+ if (*s != '0')
+ goto nogood;
+ }
+#ifndef VAX
+ /* accommodate 3 significant digits in exponent */
+ if (s[2]) {
+#ifdef Pedantic
+ if (!e0 && !s[3])
+ for(s -= 2, e1 = 2; s[0] = s[1]; s++);
+
+ /* Pedantic gives the behavior that Fortran 77 specifies, */
+ /* i.e., requires that E be specified for exponent fields */
+ /* of more than 3 digits. With Pedantic undefined, we get */
+ /* the behavior that Cray displays -- you get a bigger */
+ /* exponent field if it fits. */
+#else
+ if (!e0) {
+ for(s -= 2, e1 = 2; s[0] = s[1]; s++)
+#ifdef CRAY
+ delta--;
+ if ((delta += 4) < 0)
+ goto nogood
+#endif
+ ;
+ }
+#endif
+ else if (e0 >= 0)
+ goto shift;
+ else
+ e1 = e;
+ }
+ else
+ shift:
+#endif
+ for(s += 2, e1 = 2; *s; ++e1, ++s)
+ if (e1 >= e)
+ goto nogood;
+ while(--delta >= 0)
+ PUT(' ');
+ if (signspace)
+ PUT(sign ? '-' : '+');
+ s = buf;
+ i = f__scale;
+ if (f__scale <= 0) {
+#ifdef WANT_LEAD_0
+ if (insert0)
+ PUT('0');
+#endif
+ PUT('.');
+ for(; i < 0; ++i)
+ PUT('0');
+ PUT(*s);
+ s += 2;
+ }
+ else if (f__scale > 1) {
+ PUT(*s);
+ s += 2;
+ while(--i > 0)
+ PUT(*s++);
+ PUT('.');
+ }
+ if (d1) {
+ se -= 2;
+ while(s < se) PUT(*s++);
+ se += 2;
+ do PUT('0'); while(--d1 > 0);
+ }
+ while(s < se)
+ PUT(*s++);
+ if (e < 2)
+ PUT(s[1]);
+ else {
+ while(++e1 <= e)
+ PUT('0');
+ while(*s)
+ PUT(*s++);
+ }
+ return 0;
+ }
+
+ int
+#ifdef KR_headers
+wrt_F(p,w,d,len) ufloat *p; ftnlen len;
+#else
+wrt_F(ufloat *p, int w, int d, ftnlen len)
+#endif
+{
+ int d1, sign, n;
+ double x;
+ char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s;
+
+ x= (len==sizeof(real)?p->pf:p->pd);
+ if (d < MAXFRACDIGS)
+ d1 = 0;
+ else {
+ d1 = d - MAXFRACDIGS;
+ d = MAXFRACDIGS;
+ }
+ if (x < 0.)
+ { x = -x; sign = 1; }
+ else {
+ sign = 0;
+#ifndef VAX
+ if (!x) {
+#ifdef SIGNED_ZEROS
+ if (signbit_f2c(&x))
+ sign = 2;
+#endif
+ x = 0.;
+ }
+#endif
+ }
+
+ if (n = f__scale)
+ if (n > 0)
+ do x *= 10.; while(--n > 0);
+ else
+ do x *= 0.1; while(++n < 0);
+
+#ifdef USE_STRLEN
+ sprintf(b = buf, "%#.*f", d, x);
+ n = strlen(b) + d1;
+#else
+ n = sprintf(b = buf, "%#.*f", d, x) + d1;
+#endif
+
+#ifndef WANT_LEAD_0
+ if (buf[0] == '0' && d)
+ { ++b; --n; }
+#endif
+ if (sign == 1) {
+ /* check for all zeros */
+ for(s = b;;) {
+ while(*s == '0') s++;
+ switch(*s) {
+ case '.':
+ s++; continue;
+ case 0:
+ sign = 0;
+ }
+ break;
+ }
+ }
+ if (sign || f__cplus)
+ ++n;
+ if (n > w) {
+#ifdef WANT_LEAD_0
+ if (buf[0] == '0' && --n == w)
+ ++b;
+ else
+#endif
+ {
+ while(--w >= 0)
+ PUT('*');
+ return 0;
+ }
+ }
+ for(w -= n; --w >= 0; )
+ PUT(' ');
+ if (sign)
+ PUT('-');
+ else if (f__cplus)
+ PUT('+');
+ while(n = *b++)
+ PUT(n);
+ while(--d1 >= 0)
+ PUT('0');
+ return 0;
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/wrtfmt.c b/F2CLIBS/libf2c/wrtfmt.c
new file mode 100644
index 0000000..a970db9
--- /dev/null
+++ b/F2CLIBS/libf2c/wrtfmt.c
@@ -0,0 +1,377 @@
+#include "f2c.h"
+#include "fio.h"
+#include "fmt.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+extern icilist *f__svic;
+extern char *f__icptr;
+
+ static int
+mv_cur(Void) /* shouldn't use fseek because it insists on calling fflush */
+ /* instead we know too much about stdio */
+{
+ int cursor = f__cursor;
+ f__cursor = 0;
+ if(f__external == 0) {
+ if(cursor < 0) {
+ if(f__hiwater < f__recpos)
+ f__hiwater = f__recpos;
+ f__recpos += cursor;
+ f__icptr += cursor;
+ if(f__recpos < 0)
+ err(f__elist->cierr, 110, "left off");
+ }
+ else if(cursor > 0) {
+ if(f__recpos + cursor >= f__svic->icirlen)
+ err(f__elist->cierr, 110, "recend");
+ if(f__hiwater <= f__recpos)
+ for(; cursor > 0; cursor--)
+ (*f__putn)(' ');
+ else if(f__hiwater <= f__recpos + cursor) {
+ cursor -= f__hiwater - f__recpos;
+ f__icptr += f__hiwater - f__recpos;
+ f__recpos = f__hiwater;
+ for(; cursor > 0; cursor--)
+ (*f__putn)(' ');
+ }
+ else {
+ f__icptr += cursor;
+ f__recpos += cursor;
+ }
+ }
+ return(0);
+ }
+ if (cursor > 0) {
+ if(f__hiwater <= f__recpos)
+ for(;cursor>0;cursor--) (*f__putn)(' ');
+ else if(f__hiwater <= f__recpos + cursor) {
+ cursor -= f__hiwater - f__recpos;
+ f__recpos = f__hiwater;
+ for(; cursor > 0; cursor--)
+ (*f__putn)(' ');
+ }
+ else {
+ f__recpos += cursor;
+ }
+ }
+ else if (cursor < 0)
+ {
+ if(cursor + f__recpos < 0)
+ err(f__elist->cierr,110,"left off");
+ if(f__hiwater < f__recpos)
+ f__hiwater = f__recpos;
+ f__recpos += cursor;
+ }
+ return(0);
+}
+
+ static int
+#ifdef KR_headers
+wrt_Z(n,w,minlen,len) Uint *n; int w, minlen; ftnlen len;
+#else
+wrt_Z(Uint *n, int w, int minlen, ftnlen len)
+#endif
+{
+ register char *s, *se;
+ register int i, w1;
+ static int one = 1;
+ static char hex[] = "0123456789ABCDEF";
+ s = (char *)n;
+ --len;
+ if (*(char *)&one) {
+ /* little endian */
+ se = s;
+ s += len;
+ i = -1;
+ }
+ else {
+ se = s + len;
+ i = 1;
+ }
+ for(;; s += i)
+ if (s == se || *s)
+ break;
+ w1 = (i*(se-s) << 1) + 1;
+ if (*s & 0xf0)
+ w1++;
+ if (w1 > w)
+ for(i = 0; i < w; i++)
+ (*f__putn)('*');
+ else {
+ if ((minlen -= w1) > 0)
+ w1 += minlen;
+ while(--w >= w1)
+ (*f__putn)(' ');
+ while(--minlen >= 0)
+ (*f__putn)('0');
+ if (!(*s & 0xf0)) {
+ (*f__putn)(hex[*s & 0xf]);
+ if (s == se)
+ return 0;
+ s += i;
+ }
+ for(;; s += i) {
+ (*f__putn)(hex[*s >> 4 & 0xf]);
+ (*f__putn)(hex[*s & 0xf]);
+ if (s == se)
+ break;
+ }
+ }
+ return 0;
+ }
+
+ static int
+#ifdef KR_headers
+wrt_I(n,w,len, base) Uint *n; ftnlen len; register int base;
+#else
+wrt_I(Uint *n, int w, ftnlen len, register int base)
+#endif
+{ int ndigit,sign,spare,i;
+ longint x;
+ char *ans;
+ if(len==sizeof(integer)) x=n->il;
+ else if(len == sizeof(char)) x = n->ic;
+#ifdef Allow_TYQUAD
+ else if (len == sizeof(longint)) x = n->ili;
+#endif
+ else x=n->is;
+ ans=f__icvt(x,&ndigit,&sign, base);
+ spare=w-ndigit;
+ if(sign || f__cplus) spare--;
+ if(spare<0)
+ for(i=0;i<w;i++) (*f__putn)('*');
+ else
+ { for(i=0;i<spare;i++) (*f__putn)(' ');
+ if(sign) (*f__putn)('-');
+ else if(f__cplus) (*f__putn)('+');
+ for(i=0;i<ndigit;i++) (*f__putn)(*ans++);
+ }
+ return(0);
+}
+ static int
+#ifdef KR_headers
+wrt_IM(n,w,m,len,base) Uint *n; ftnlen len; int base;
+#else
+wrt_IM(Uint *n, int w, int m, ftnlen len, int base)
+#endif
+{ int ndigit,sign,spare,i,xsign;
+ longint x;
+ char *ans;
+ if(sizeof(integer)==len) x=n->il;
+ else if(len == sizeof(char)) x = n->ic;
+#ifdef Allow_TYQUAD
+ else if (len == sizeof(longint)) x = n->ili;
+#endif
+ else x=n->is;
+ ans=f__icvt(x,&ndigit,&sign, base);
+ if(sign || f__cplus) xsign=1;
+ else xsign=0;
+ if(ndigit+xsign>w || m+xsign>w)
+ { for(i=0;i<w;i++) (*f__putn)('*');
+ return(0);
+ }
+ if(x==0 && m==0)
+ { for(i=0;i<w;i++) (*f__putn)(' ');
+ return(0);
+ }
+ if(ndigit>=m)
+ spare=w-ndigit-xsign;
+ else
+ spare=w-m-xsign;
+ for(i=0;i<spare;i++) (*f__putn)(' ');
+ if(sign) (*f__putn)('-');
+ else if(f__cplus) (*f__putn)('+');
+ for(i=0;i<m-ndigit;i++) (*f__putn)('0');
+ for(i=0;i<ndigit;i++) (*f__putn)(*ans++);
+ return(0);
+}
+ static int
+#ifdef KR_headers
+wrt_AP(s) char *s;
+#else
+wrt_AP(char *s)
+#endif
+{ char quote;
+ int i;
+
+ if(f__cursor && (i = mv_cur()))
+ return i;
+ quote = *s++;
+ for(;*s;s++)
+ { if(*s!=quote) (*f__putn)(*s);
+ else if(*++s==quote) (*f__putn)(*s);
+ else return(1);
+ }
+ return(1);
+}
+ static int
+#ifdef KR_headers
+wrt_H(a,s) char *s;
+#else
+wrt_H(int a, char *s)
+#endif
+{
+ int i;
+
+ if(f__cursor && (i = mv_cur()))
+ return i;
+ while(a--) (*f__putn)(*s++);
+ return(1);
+}
+
+ int
+#ifdef KR_headers
+wrt_L(n,len, sz) Uint *n; ftnlen sz;
+#else
+wrt_L(Uint *n, int len, ftnlen sz)
+#endif
+{ int i;
+ long x;
+ if(sizeof(long)==sz) x=n->il;
+ else if(sz == sizeof(char)) x = n->ic;
+ else x=n->is;
+ for(i=0;i<len-1;i++)
+ (*f__putn)(' ');
+ if(x) (*f__putn)('T');
+ else (*f__putn)('F');
+ return(0);
+}
+ static int
+#ifdef KR_headers
+wrt_A(p,len) char *p; ftnlen len;
+#else
+wrt_A(char *p, ftnlen len)
+#endif
+{
+ while(len-- > 0) (*f__putn)(*p++);
+ return(0);
+}
+ static int
+#ifdef KR_headers
+wrt_AW(p,w,len) char * p; ftnlen len;
+#else
+wrt_AW(char * p, int w, ftnlen len)
+#endif
+{
+ while(w>len)
+ { w--;
+ (*f__putn)(' ');
+ }
+ while(w-- > 0)
+ (*f__putn)(*p++);
+ return(0);
+}
+
+ static int
+#ifdef KR_headers
+wrt_G(p,w,d,e,len) ufloat *p; ftnlen len;
+#else
+wrt_G(ufloat *p, int w, int d, int e, ftnlen len)
+#endif
+{ double up = 1,x;
+ int i=0,oldscale,n,j;
+ x = len==sizeof(real)?p->pf:p->pd;
+ if(x < 0 ) x = -x;
+ if(x<.1) {
+ if (x != 0.)
+ return(wrt_E(p,w,d,e,len));
+ i = 1;
+ goto have_i;
+ }
+ for(;i<=d;i++,up*=10)
+ { if(x>=up) continue;
+ have_i:
+ oldscale = f__scale;
+ f__scale = 0;
+ if(e==0) n=4;
+ else n=e+2;
+ i=wrt_F(p,w-n,d-i,len);
+ for(j=0;j<n;j++) (*f__putn)(' ');
+ f__scale=oldscale;
+ return(i);
+ }
+ return(wrt_E(p,w,d,e,len));
+}
+
+ int
+#ifdef KR_headers
+w_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len;
+#else
+w_ed(struct syl *p, char *ptr, ftnlen len)
+#endif
+{
+ int i;
+
+ if(f__cursor && (i = mv_cur()))
+ return i;
+ switch(p->op)
+ {
+ default:
+ fprintf(stderr,"w_ed, unexpected code: %d\n", p->op);
+ sig_die(f__fmtbuf, 1);
+ case I: return(wrt_I((Uint *)ptr,p->p1,len, 10));
+ case IM:
+ return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,10));
+
+ /* O and OM don't work right for character, double, complex, */
+ /* or doublecomplex, and they differ from Fortran 90 in */
+ /* showing a minus sign for negative values. */
+
+ case O: return(wrt_I((Uint *)ptr, p->p1, len, 8));
+ case OM:
+ return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,8));
+ case L: return(wrt_L((Uint *)ptr,p->p1, len));
+ case A: return(wrt_A(ptr,len));
+ case AW:
+ return(wrt_AW(ptr,p->p1,len));
+ case D:
+ case E:
+ case EE:
+ return(wrt_E((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len));
+ case G:
+ case GE:
+ return(wrt_G((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len));
+ case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2.i[0],len));
+
+ /* Z and ZM assume 8-bit bytes. */
+
+ case Z: return(wrt_Z((Uint *)ptr,p->p1,0,len));
+ case ZM:
+ return(wrt_Z((Uint *)ptr,p->p1,p->p2.i[0],len));
+ }
+}
+
+ int
+#ifdef KR_headers
+w_ned(p) struct syl *p;
+#else
+w_ned(struct syl *p)
+#endif
+{
+ switch(p->op)
+ {
+ default: fprintf(stderr,"w_ned, unexpected code: %d\n", p->op);
+ sig_die(f__fmtbuf, 1);
+ case SLASH:
+ return((*f__donewrec)());
+ case T: f__cursor = p->p1-f__recpos - 1;
+ return(1);
+ case TL: f__cursor -= p->p1;
+ if(f__cursor < -f__recpos) /* TL1000, 1X */
+ f__cursor = -f__recpos;
+ return(1);
+ case TR:
+ case X:
+ f__cursor += p->p1;
+ return(1);
+ case APOS:
+ return(wrt_AP(p->p2.s));
+ case H:
+ return(wrt_H(p->p1,p->p2.s));
+ }
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/wsfe.c b/F2CLIBS/libf2c/wsfe.c
new file mode 100644
index 0000000..8709f3b
--- /dev/null
+++ b/F2CLIBS/libf2c/wsfe.c
@@ -0,0 +1,78 @@
+/*write sequential formatted external*/
+#include "f2c.h"
+#include "fio.h"
+#include "fmt.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+ int
+x_wSL(Void)
+{
+ int n = f__putbuf('\n');
+ f__hiwater = f__recpos = f__cursor = 0;
+ return(n == 0);
+}
+
+ static int
+xw_end(Void)
+{
+ int n;
+
+ if(f__nonl) {
+ f__putbuf(n = 0);
+ fflush(f__cf);
+ }
+ else
+ n = f__putbuf('\n');
+ f__hiwater = f__recpos = f__cursor = 0;
+ return n;
+}
+
+ static int
+xw_rev(Void)
+{
+ int n = 0;
+ if(f__workdone) {
+ n = f__putbuf('\n');
+ f__workdone = 0;
+ }
+ f__hiwater = f__recpos = f__cursor = 0;
+ return n;
+}
+
+#ifdef KR_headers
+integer s_wsfe(a) cilist *a; /*start*/
+#else
+integer s_wsfe(cilist *a) /*start*/
+#endif
+{ int n;
+ if(!f__init) f_init();
+ f__reading=0;
+ f__sequential=1;
+ f__formatted=1;
+ f__external=1;
+ if(n=c_sfe(a)) return(n);
+ f__elist=a;
+ f__hiwater = f__cursor=f__recpos=0;
+ f__nonl = 0;
+ f__scale=0;
+ f__fmtbuf=a->cifmt;
+ f__cf=f__curunit->ufd;
+ if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio");
+ f__putn= x_putc;
+ f__doed= w_ed;
+ f__doned= w_ned;
+ f__doend=xw_end;
+ f__dorevert=xw_rev;
+ f__donewrec=x_wSL;
+ fmt_bg();
+ f__cplus=0;
+ f__cblank=f__curunit->ublnk;
+ if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
+ err(a->cierr,errno,"write start");
+ return(0);
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/wsle.c b/F2CLIBS/libf2c/wsle.c
new file mode 100644
index 0000000..3e60270
--- /dev/null
+++ b/F2CLIBS/libf2c/wsle.c
@@ -0,0 +1,42 @@
+#include "f2c.h"
+#include "fio.h"
+#include "fmt.h"
+#include "lio.h"
+#include "string.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+integer s_wsle(a) cilist *a;
+#else
+integer s_wsle(cilist *a)
+#endif
+{
+ int n;
+ if(n=c_le(a)) return(n);
+ f__reading=0;
+ f__external=1;
+ f__formatted=1;
+ f__putn = x_putc;
+ f__lioproc = l_write;
+ L_len = LINE;
+ f__donewrec = x_wSL;
+ if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
+ err(a->cierr, errno, "list output start");
+ return(0);
+ }
+
+integer e_wsle(Void)
+{
+ int n = f__putbuf('\n');
+ f__recpos=0;
+#ifdef ALWAYS_FLUSH
+ if (!n && fflush(f__cf))
+ err(f__elist->cierr, errno, "write end");
+#endif
+ return(n);
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/wsne.c b/F2CLIBS/libf2c/wsne.c
new file mode 100644
index 0000000..e204a51
--- /dev/null
+++ b/F2CLIBS/libf2c/wsne.c
@@ -0,0 +1,32 @@
+#include "f2c.h"
+#include "fio.h"
+#include "lio.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+ integer
+#ifdef KR_headers
+s_wsne(a) cilist *a;
+#else
+s_wsne(cilist *a)
+#endif
+{
+ int n;
+
+ if(n=c_le(a))
+ return(n);
+ f__reading=0;
+ f__external=1;
+ f__formatted=1;
+ f__putn = x_putc;
+ L_len = LINE;
+ f__donewrec = x_wSL;
+ if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
+ err(a->cierr, errno, "namelist output start");
+ x_wsne(a);
+ return e_wsle();
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/xwsne.c b/F2CLIBS/libf2c/xwsne.c
new file mode 100644
index 0000000..f810d3e
--- /dev/null
+++ b/F2CLIBS/libf2c/xwsne.c
@@ -0,0 +1,77 @@
+#include "f2c.h"
+#include "fio.h"
+#include "lio.h"
+#include "fmt.h"
+
+extern int f__Aquote;
+
+ static VOID
+nl_donewrec(Void)
+{
+ (*f__donewrec)();
+ PUT(' ');
+ }
+
+#ifdef KR_headers
+x_wsne(a) cilist *a;
+#else
+#include "string.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+ VOID
+x_wsne(cilist *a)
+#endif
+{
+ Namelist *nl;
+ char *s;
+ Vardesc *v, **vd, **vde;
+ ftnint number, type;
+ ftnlen *dims;
+ ftnlen size;
+ extern ftnlen f__typesize[];
+
+ nl = (Namelist *)a->cifmt;
+ PUT('&');
+ for(s = nl->name; *s; s++)
+ PUT(*s);
+ PUT(' ');
+ f__Aquote = 1;
+ vd = nl->vars;
+ vde = vd + nl->nvars;
+ while(vd < vde) {
+ v = *vd++;
+ s = v->name;
+#ifdef No_Extra_Namelist_Newlines
+ if (f__recpos+strlen(s)+2 >= L_len)
+#endif
+ nl_donewrec();
+ while(*s)
+ PUT(*s++);
+ PUT(' ');
+ PUT('=');
+ number = (dims = v->dims) ? dims[1] : 1;
+ type = v->type;
+ if (type < 0) {
+ size = -type;
+ type = TYCHAR;
+ }
+ else
+ size = f__typesize[type];
+ l_write(&number, v->addr, size, type);
+ if (vd < vde) {
+ if (f__recpos+2 >= L_len)
+ nl_donewrec();
+ PUT(',');
+ PUT(' ');
+ }
+ else if (f__recpos+1 >= L_len)
+ nl_donewrec();
+ }
+ f__Aquote = 0;
+ PUT('/');
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/z_abs.c b/F2CLIBS/libf2c/z_abs.c
new file mode 100644
index 0000000..4d8a015
--- /dev/null
+++ b/F2CLIBS/libf2c/z_abs.c
@@ -0,0 +1,18 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+double f__cabs();
+double z_abs(z) doublecomplex *z;
+#else
+double f__cabs(double, double);
+double z_abs(doublecomplex *z)
+#endif
+{
+return( f__cabs( z->r, z->i ) );
+}
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/z_cos.c b/F2CLIBS/libf2c/z_cos.c
new file mode 100644
index 0000000..4abe8bf
--- /dev/null
+++ b/F2CLIBS/libf2c/z_cos.c
@@ -0,0 +1,21 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double sin(), cos(), sinh(), cosh();
+VOID z_cos(r, z) doublecomplex *r, *z;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+void z_cos(doublecomplex *r, doublecomplex *z)
+#endif
+{
+ double zi = z->i, zr = z->r;
+ r->r = cos(zr) * cosh(zi);
+ r->i = - sin(zr) * sinh(zi);
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/z_div.c b/F2CLIBS/libf2c/z_div.c
new file mode 100644
index 0000000..e45f360
--- /dev/null
+++ b/F2CLIBS/libf2c/z_div.c
@@ -0,0 +1,50 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+extern VOID sig_die();
+VOID z_div(c, a, b) doublecomplex *a, *b, *c;
+#else
+extern void sig_die(const char*, int);
+void z_div(doublecomplex *c, doublecomplex *a, doublecomplex *b)
+#endif
+{
+ double ratio, den;
+ double abr, abi, cr;
+
+ if( (abr = b->r) < 0.)
+ abr = - abr;
+ if( (abi = b->i) < 0.)
+ abi = - abi;
+ if( abr <= abi )
+ {
+ if(abi == 0) {
+#ifdef IEEE_COMPLEX_DIVIDE
+ if (a->i != 0 || a->r != 0)
+ abi = 1.;
+ c->i = c->r = abi / abr;
+ return;
+#else
+ sig_die("complex division by zero", 1);
+#endif
+ }
+ ratio = b->r / b->i ;
+ den = b->i * (1 + ratio*ratio);
+ cr = (a->r*ratio + a->i) / den;
+ c->i = (a->i*ratio - a->r) / den;
+ }
+
+ else
+ {
+ ratio = b->i / b->r ;
+ den = b->r * (1 + ratio*ratio);
+ cr = (a->r + a->i*ratio) / den;
+ c->i = (a->i - a->r*ratio) / den;
+ }
+ c->r = cr;
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/z_exp.c b/F2CLIBS/libf2c/z_exp.c
new file mode 100644
index 0000000..7b8edfe
--- /dev/null
+++ b/F2CLIBS/libf2c/z_exp.c
@@ -0,0 +1,23 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double exp(), cos(), sin();
+VOID z_exp(r, z) doublecomplex *r, *z;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+void z_exp(doublecomplex *r, doublecomplex *z)
+#endif
+{
+ double expx, zi = z->i;
+
+ expx = exp(z->r);
+ r->r = expx * cos(zi);
+ r->i = expx * sin(zi);
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/z_log.c b/F2CLIBS/libf2c/z_log.c
new file mode 100644
index 0000000..4f11bbe
--- /dev/null
+++ b/F2CLIBS/libf2c/z_log.c
@@ -0,0 +1,121 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double log(), f__cabs(), atan2();
+#define ANSI(x) ()
+#else
+#define ANSI(x) x
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern double f__cabs(double, double);
+#endif
+
+#ifndef NO_DOUBLE_EXTENDED
+#ifndef GCC_COMPARE_BUG_FIXED
+#ifndef Pre20000310
+#ifdef Comment
+Some versions of gcc, such as 2.95.3 and 3.0.4, are buggy under -O2 or -O3:
+on IA32 (Intel 80x87) systems, they may do comparisons on values computed
+in extended-precision registers. This can lead to the test "s > s0" that
+was used below being carried out incorrectly. The fix below cannot be
+spoiled by overzealous optimization, since the compiler cannot know
+whether gcc_bug_bypass_diff_F2C will be nonzero. (We expect it always
+to be zero. The weird name is unlikely to collide with anything.)
+
+An example (provided by Ulrich Jakobus) where the bug fix matters is
+
+ double complex a, b
+ a = (.1099557428756427618354862829619, .9857360542953131909982289471372)
+ b = log(a)
+
+An alternative to the fix below would be to use 53-bit rounding precision,
+but the means of specifying this 80x87 feature are highly unportable.
+#endif /*Comment*/
+#define BYPASS_GCC_COMPARE_BUG
+double (*gcc_bug_bypass_diff_F2C) ANSI((double*,double*));
+ static double
+#ifdef KR_headers
+diff1(a,b) double *a, *b;
+#else
+diff1(double *a, double *b)
+#endif
+{ return *a - *b; }
+#endif /*Pre20000310*/
+#endif /*GCC_COMPARE_BUG_FIXED*/
+#endif /*NO_DOUBLE_EXTENDED*/
+
+#ifdef KR_headers
+VOID z_log(r, z) doublecomplex *r, *z;
+#else
+void z_log(doublecomplex *r, doublecomplex *z)
+#endif
+{
+ double s, s0, t, t2, u, v;
+ double zi = z->i, zr = z->r;
+#ifdef BYPASS_GCC_COMPARE_BUG
+ double (*diff) ANSI((double*,double*));
+#endif
+
+ r->i = atan2(zi, zr);
+#ifdef Pre20000310
+ r->r = log( f__cabs( zr, zi ) );
+#else
+ if (zi < 0)
+ zi = -zi;
+ if (zr < 0)
+ zr = -zr;
+ if (zr < zi) {
+ t = zi;
+ zi = zr;
+ zr = t;
+ }
+ t = zi/zr;
+ s = zr * sqrt(1 + t*t);
+ /* now s = f__cabs(zi,zr), and zr = |zr| >= |zi| = zi */
+ if ((t = s - 1) < 0)
+ t = -t;
+ if (t > .01)
+ r->r = log(s);
+ else {
+
+#ifdef Comment
+
+ log(1+x) = x - x^2/2 + x^3/3 - x^4/4 + - ...
+
+ = x(1 - x/2 + x^2/3 -+...)
+
+ [sqrt(y^2 + z^2) - 1] * [sqrt(y^2 + z^2) + 1] = y^2 + z^2 - 1, so
+
+ sqrt(y^2 + z^2) - 1 = (y^2 + z^2 - 1) / [sqrt(y^2 + z^2) + 1]
+
+#endif /*Comment*/
+
+#ifdef BYPASS_GCC_COMPARE_BUG
+ if (!(diff = gcc_bug_bypass_diff_F2C))
+ diff = diff1;
+#endif
+ t = ((zr*zr - 1.) + zi*zi) / (s + 1);
+ t2 = t*t;
+ s = 1. - 0.5*t;
+ u = v = 1;
+ do {
+ s0 = s;
+ u *= t2;
+ v += 2;
+ s += u/v - t*u/(v+1);
+ }
+#ifdef BYPASS_GCC_COMPARE_BUG
+ while(s - s0 > 1e-18 || (*diff)(&s,&s0) > 0.);
+#else
+ while(s > s0);
+#endif
+ r->r = s*t;
+ }
+#endif
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/z_sin.c b/F2CLIBS/libf2c/z_sin.c
new file mode 100644
index 0000000..01225a9
--- /dev/null
+++ b/F2CLIBS/libf2c/z_sin.c
@@ -0,0 +1,21 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double sin(), cos(), sinh(), cosh();
+VOID z_sin(r, z) doublecomplex *r, *z;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+void z_sin(doublecomplex *r, doublecomplex *z)
+#endif
+{
+ double zi = z->i, zr = z->r;
+ r->r = sin(zr) * cosh(zi);
+ r->i = cos(zr) * sinh(zi);
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/F2CLIBS/libf2c/z_sqrt.c b/F2CLIBS/libf2c/z_sqrt.c
new file mode 100644
index 0000000..35bd44c
--- /dev/null
+++ b/F2CLIBS/libf2c/z_sqrt.c
@@ -0,0 +1,35 @@
+#include "f2c.h"
+
+#ifdef KR_headers
+double sqrt(), f__cabs();
+VOID z_sqrt(r, z) doublecomplex *r, *z;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern double f__cabs(double, double);
+void z_sqrt(doublecomplex *r, doublecomplex *z)
+#endif
+{
+ double mag, zi = z->i, zr = z->r;
+
+ if( (mag = f__cabs(zr, zi)) == 0.)
+ r->r = r->i = 0.;
+ else if(zr > 0)
+ {
+ r->r = sqrt(0.5 * (mag + zr) );
+ r->i = zi / r->r / 2;
+ }
+ else
+ {
+ r->i = sqrt(0.5 * (mag - zr) );
+ if(zi < 0)
+ r->i = - r->i;
+ r->r = zi / r->i / 2;
+ }
+ }
+#ifdef __cplusplus
+}
+#endif
diff --git a/INCLUDE/blaswrap.h b/INCLUDE/blaswrap.h
new file mode 100644
index 0000000..333a17a
--- /dev/null
+++ b/INCLUDE/blaswrap.h
@@ -0,0 +1,160 @@
+/* CLAPACK 3.0 BLAS wrapper macros
+ * Feb 5, 2000
+ */
+
+#ifndef __BLASWRAP_H
+#define __BLASWRAP_H
+
+#ifndef NO_BLAS_WRAP
+
+/* BLAS1 routines */
+#define srotg_ f2c_srotg
+#define drotg_ f2c_drotg
+#define srotmg_ f2c_srotmg
+#define drotmg_ f2c_drotmg
+#define srot_ f2c_srot
+#define drot_ f2c_drot
+#define srotm_ f2c_srotm
+#define drotm_ f2c_drotm
+#define csrot_ f2c_csrot
+#define zdrot_ f2c_zdrot
+#define sswap_ f2c_sswap
+#define dswap_ f2c_dswap
+#define cswap_ f2c_cswap
+#define zswap_ f2c_zswap
+#define sscal_ f2c_sscal
+#define dscal_ f2c_dscal
+#define cscal_ f2c_cscal
+#define zscal_ f2c_zscal
+#define csscal_ f2c_csscal
+#define zdscal_ f2c_zdscal
+#define scopy_ f2c_scopy
+#define dcopy_ f2c_dcopy
+#define ccopy_ f2c_ccopy
+#define zcopy_ f2c_zcopy
+#define saxpy_ f2c_saxpy
+#define daxpy_ f2c_daxpy
+#define caxpy_ f2c_caxpy
+#define zaxpy_ f2c_zaxpy
+#define sdot_ f2c_sdot
+#define ddot_ f2c_ddot
+#define cdotu_ f2c_cdotu
+#define zdotu_ f2c_zdotu
+#define cdotc_ f2c_cdotc
+#define zdotc_ f2c_zdotc
+#define snrm2_ f2c_snrm2
+#define dnrm2_ f2c_dnrm2
+#define scnrm2_ f2c_scnrm2
+#define dznrm2_ f2c_dznrm2
+#define sasum_ f2c_sasum
+#define dasum_ f2c_dasum
+#define scasum_ f2c_scasum
+#define dzasum_ f2c_dzasum
+#define isamax_ f2c_isamax
+#define idamax_ f2c_idamax
+#define icamax_ f2c_icamax
+#define izamax_ f2c_izamax
+
+/* BLAS2 routines */
+#define sgemv_ f2c_sgemv
+#define dgemv_ f2c_dgemv
+#define cgemv_ f2c_cgemv
+#define zgemv_ f2c_zgemv
+#define sgbmv_ f2c_sgbmv
+#define dgbmv_ f2c_dgbmv
+#define cgbmv_ f2c_cgbmv
+#define zgbmv_ f2c_zgbmv
+#define chemv_ f2c_chemv
+#define zhemv_ f2c_zhemv
+#define chbmv_ f2c_chbmv
+#define zhbmv_ f2c_zhbmv
+#define chpmv_ f2c_chpmv
+#define zhpmv_ f2c_zhpmv
+#define ssymv_ f2c_ssymv
+#define dsymv_ f2c_dsymv
+#define ssbmv_ f2c_ssbmv
+#define dsbmv_ f2c_dsbmv
+#define sspmv_ f2c_sspmv
+#define dspmv_ f2c_dspmv
+#define strmv_ f2c_strmv
+#define dtrmv_ f2c_dtrmv
+#define ctrmv_ f2c_ctrmv
+#define ztrmv_ f2c_ztrmv
+#define stbmv_ f2c_stbmv
+#define dtbmv_ f2c_dtbmv
+#define ctbmv_ f2c_ctbmv
+#define ztbmv_ f2c_ztbmv
+#define stpmv_ f2c_stpmv
+#define dtpmv_ f2c_dtpmv
+#define ctpmv_ f2c_ctpmv
+#define ztpmv_ f2c_ztpmv
+#define strsv_ f2c_strsv
+#define dtrsv_ f2c_dtrsv
+#define ctrsv_ f2c_ctrsv
+#define ztrsv_ f2c_ztrsv
+#define stbsv_ f2c_stbsv
+#define dtbsv_ f2c_dtbsv
+#define ctbsv_ f2c_ctbsv
+#define ztbsv_ f2c_ztbsv
+#define stpsv_ f2c_stpsv
+#define dtpsv_ f2c_dtpsv
+#define ctpsv_ f2c_ctpsv
+#define ztpsv_ f2c_ztpsv
+#define sger_ f2c_sger
+#define dger_ f2c_dger
+#define cgeru_ f2c_cgeru
+#define zgeru_ f2c_zgeru
+#define cgerc_ f2c_cgerc
+#define zgerc_ f2c_zgerc
+#define cher_ f2c_cher
+#define zher_ f2c_zher
+#define chpr_ f2c_chpr
+#define zhpr_ f2c_zhpr
+#define cher2_ f2c_cher2
+#define zher2_ f2c_zher2
+#define chpr2_ f2c_chpr2
+#define zhpr2_ f2c_zhpr2
+#define ssyr_ f2c_ssyr
+#define dsyr_ f2c_dsyr
+#define sspr_ f2c_sspr
+#define dspr_ f2c_dspr
+#define ssyr2_ f2c_ssyr2
+#define dsyr2_ f2c_dsyr2
+#define sspr2_ f2c_sspr2
+#define dspr2_ f2c_dspr2
+
+/* BLAS3 routines */
+#define sgemm_ f2c_sgemm
+#define dgemm_ f2c_dgemm
+#define cgemm_ f2c_cgemm
+#define zgemm_ f2c_zgemm
+#define ssymm_ f2c_ssymm
+#define dsymm_ f2c_dsymm
+#define csymm_ f2c_csymm
+#define zsymm_ f2c_zsymm
+#define chemm_ f2c_chemm
+#define zhemm_ f2c_zhemm
+#define ssyrk_ f2c_ssyrk
+#define dsyrk_ f2c_dsyrk
+#define csyrk_ f2c_csyrk
+#define zsyrk_ f2c_zsyrk
+#define cherk_ f2c_cherk
+#define zherk_ f2c_zherk
+#define ssyr2k_ f2c_ssyr2k
+#define dsyr2k_ f2c_dsyr2k
+#define csyr2k_ f2c_csyr2k
+#define zsyr2k_ f2c_zsyr2k
+#define cher2k_ f2c_cher2k
+#define zher2k_ f2c_zher2k
+#define strmm_ f2c_strmm
+#define dtrmm_ f2c_dtrmm
+#define ctrmm_ f2c_ctrmm
+#define ztrmm_ f2c_ztrmm
+#define strsm_ f2c_strsm
+#define dtrsm_ f2c_dtrsm
+#define ctrsm_ f2c_ctrsm
+#define ztrsm_ f2c_ztrsm
+
+#endif /* NO_BLAS_WRAP */
+
+#endif /* __BLASWRAP_H */
diff --git a/INCLUDE/clapack.h b/INCLUDE/clapack.h
new file mode 100644
index 0000000..d22da98
--- /dev/null
+++ b/INCLUDE/clapack.h
@@ -0,0 +1,7254 @@
+/* header file for clapack 3.2.1 */
+
+#ifndef __CLAPACK_H
+#define __CLAPACK_H
+
+/* Subroutine */ int caxpy_(integer *n, complex *ca, complex *cx, integer *
+ incx, complex *cy, integer *incy);
+
+/* Subroutine */ int ccopy_(integer *n, complex *cx, integer *incx, complex *
+ cy, integer *incy);
+
+/* Complex */ VOID cdotc_(complex * ret_val, integer *n, complex *cx, integer
+ *incx, complex *cy, integer *incy);
+
+/* Complex */ VOID cdotu_(complex * ret_val, integer *n, complex *cx, integer
+ *incx, complex *cy, integer *incy);
+
+/* Subroutine */ int cgbmv_(char *trans, integer *m, integer *n, integer *kl,
+ integer *ku, complex *alpha, complex *a, integer *lda, complex *x,
+ integer *incx, complex *beta, complex *y, integer *incy);
+
+/* Subroutine */ int cgemm_(char *transa, char *transb, integer *m, integer *
+ n, integer *k, complex *alpha, complex *a, integer *lda, complex *b,
+ integer *ldb, complex *beta, complex *c__, integer *ldc);
+
+/* Subroutine */ int cgemv_(char *trans, integer *m, integer *n, complex *
+ alpha, complex *a, integer *lda, complex *x, integer *incx, complex *
+ beta, complex *y, integer *incy);
+
+/* Subroutine */ int cgerc_(integer *m, integer *n, complex *alpha, complex *
+ x, integer *incx, complex *y, integer *incy, complex *a, integer *lda);
+
+/* Subroutine */ int cgeru_(integer *m, integer *n, complex *alpha, complex *
+ x, integer *incx, complex *y, integer *incy, complex *a, integer *lda);
+
+/* Subroutine */ int chbmv_(char *uplo, integer *n, integer *k, complex *
+ alpha, complex *a, integer *lda, complex *x, integer *incx, complex *
+ beta, complex *y, integer *incy);
+
+/* Subroutine */ int chemm_(char *side, char *uplo, integer *m, integer *n,
+ complex *alpha, complex *a, integer *lda, complex *b, integer *ldb,
+ complex *beta, complex *c__, integer *ldc);
+
+/* Subroutine */ int chemv_(char *uplo, integer *n, complex *alpha, complex *
+ a, integer *lda, complex *x, integer *incx, complex *beta, complex *y,
+ integer *incy);
+
+/* Subroutine */ int cher_(char *uplo, integer *n, real *alpha, complex *x,
+ integer *incx, complex *a, integer *lda);
+
+/* Subroutine */ int cher2_(char *uplo, integer *n, complex *alpha, complex *
+ x, integer *incx, complex *y, integer *incy, complex *a, integer *lda);
+
+/* Subroutine */ int cher2k_(char *uplo, char *trans, integer *n, integer *k,
+ complex *alpha, complex *a, integer *lda, complex *b, integer *ldb,
+ real *beta, complex *c__, integer *ldc);
+
+/* Subroutine */ int cherk_(char *uplo, char *trans, integer *n, integer *k,
+ real *alpha, complex *a, integer *lda, real *beta, complex *c__,
+ integer *ldc);
+
+/* Subroutine */ int chpmv_(char *uplo, integer *n, complex *alpha, complex *
+ ap, complex *x, integer *incx, complex *beta, complex *y, integer *
+ incy);
+
+/* Subroutine */ int chpr_(char *uplo, integer *n, real *alpha, complex *x,
+ integer *incx, complex *ap);
+
+/* Subroutine */ int chpr2_(char *uplo, integer *n, complex *alpha, complex *
+ x, integer *incx, complex *y, integer *incy, complex *ap);
+
+/* Subroutine */ int crotg_(complex *ca, complex *cb, real *c__, complex *s);
+
+/* Subroutine */ int cscal_(integer *n, complex *ca, complex *cx, integer *
+ incx);
+
+/* Subroutine */ int csrot_(integer *n, complex *cx, integer *incx, complex *
+ cy, integer *incy, real *c__, real *s);
+
+/* Subroutine */ int csscal_(integer *n, real *sa, complex *cx, integer *incx);
+
+/* Subroutine */ int cswap_(integer *n, complex *cx, integer *incx, complex *
+ cy, integer *incy);
+
+/* Subroutine */ int csymm_(char *side, char *uplo, integer *m, integer *n,
+ complex *alpha, complex *a, integer *lda, complex *b, integer *ldb,
+ complex *beta, complex *c__, integer *ldc);
+
+/* Subroutine */ int csyr2k_(char *uplo, char *trans, integer *n, integer *k,
+ complex *alpha, complex *a, integer *lda, complex *b, integer *ldb,
+ complex *beta, complex *c__, integer *ldc);
+
+/* Subroutine */ int csyrk_(char *uplo, char *trans, integer *n, integer *k,
+ complex *alpha, complex *a, integer *lda, complex *beta, complex *c__,
+ integer *ldc);
+
+/* Subroutine */ int ctbmv_(char *uplo, char *trans, char *diag, integer *n,
+ integer *k, complex *a, integer *lda, complex *x, integer *incx);
+
+/* Subroutine */ int ctbsv_(char *uplo, char *trans, char *diag, integer *n,
+ integer *k, complex *a, integer *lda, complex *x, integer *incx);
+
+/* Subroutine */ int ctpmv_(char *uplo, char *trans, char *diag, integer *n,
+ complex *ap, complex *x, integer *incx);
+
+/* Subroutine */ int ctpsv_(char *uplo, char *trans, char *diag, integer *n,
+ complex *ap, complex *x, integer *incx);
+
+/* Subroutine */ int ctrmm_(char *side, char *uplo, char *transa, char *diag,
+ integer *m, integer *n, complex *alpha, complex *a, integer *lda,
+ complex *b, integer *ldb);
+
+/* Subroutine */ int ctrmv_(char *uplo, char *trans, char *diag, integer *n,
+ complex *a, integer *lda, complex *x, integer *incx);
+
+/* Subroutine */ int ctrsm_(char *side, char *uplo, char *transa, char *diag,
+ integer *m, integer *n, complex *alpha, complex *a, integer *lda,
+ complex *b, integer *ldb);
+
+/* Subroutine */ int ctrsv_(char *uplo, char *trans, char *diag, integer *n,
+ complex *a, integer *lda, complex *x, integer *incx);
+
+doublereal dasum_(integer *n, doublereal *dx, integer *incx);
+
+/* Subroutine */ int daxpy_(integer *n, doublereal *da, doublereal *dx,
+ integer *incx, doublereal *dy, integer *incy);
+
+doublereal dcabs1_(doublecomplex *z__);
+
+/* Subroutine */ int dcopy_(integer *n, doublereal *dx, integer *incx,
+ doublereal *dy, integer *incy);
+
+doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy,
+ integer *incy);
+
+/* Subroutine */ int dgbmv_(char *trans, integer *m, integer *n, integer *kl,
+ integer *ku, doublereal *alpha, doublereal *a, integer *lda,
+ doublereal *x, integer *incx, doublereal *beta, doublereal *y,
+ integer *incy);
+
+/* Subroutine */ int dgemm_(char *transa, char *transb, integer *m, integer *
+ n, integer *k, doublereal *alpha, doublereal *a, integer *lda,
+ doublereal *b, integer *ldb, doublereal *beta, doublereal *c__,
+ integer *ldc);
+
+/* Subroutine */ int dgemv_(char *trans, integer *m, integer *n, doublereal *
+ alpha, doublereal *a, integer *lda, doublereal *x, integer *incx,
+ doublereal *beta, doublereal *y, integer *incy);
+
+/* Subroutine */ int dger_(integer *m, integer *n, doublereal *alpha,
+ doublereal *x, integer *incx, doublereal *y, integer *incy,
+ doublereal *a, integer *lda);
+
+doublereal dnrm2_(integer *n, doublereal *x, integer *incx);
+
+/* Subroutine */ int drot_(integer *n, doublereal *dx, integer *incx,
+ doublereal *dy, integer *incy, doublereal *c__, doublereal *s);
+
+/* Subroutine */ int drotg_(doublereal *da, doublereal *db, doublereal *c__,
+ doublereal *s);
+
+/* Subroutine */ int drotm_(integer *n, doublereal *dx, integer *incx,
+ doublereal *dy, integer *incy, doublereal *dparam);
+
+/* Subroutine */ int drotmg_(doublereal *dd1, doublereal *dd2, doublereal *
+ dx1, doublereal *dy1, doublereal *dparam);
+
+/* Subroutine */ int dsbmv_(char *uplo, integer *n, integer *k, doublereal *
+ alpha, doublereal *a, integer *lda, doublereal *x, integer *incx,
+ doublereal *beta, doublereal *y, integer *incy);
+
+/* Subroutine */ int dscal_(integer *n, doublereal *da, doublereal *dx,
+ integer *incx);
+
+doublereal dsdot_(integer *n, real *sx, integer *incx, real *sy, integer *
+ incy);
+
+/* Subroutine */ int dspmv_(char *uplo, integer *n, doublereal *alpha,
+ doublereal *ap, doublereal *x, integer *incx, doublereal *beta,
+ doublereal *y, integer *incy);
+
+/* Subroutine */ int dspr_(char *uplo, integer *n, doublereal *alpha,
+ doublereal *x, integer *incx, doublereal *ap);
+
+/* Subroutine */ int dspr2_(char *uplo, integer *n, doublereal *alpha,
+ doublereal *x, integer *incx, doublereal *y, integer *incy,
+ doublereal *ap);
+
+/* Subroutine */ int dswap_(integer *n, doublereal *dx, integer *incx,
+ doublereal *dy, integer *incy);
+
+/* Subroutine */ int dsymm_(char *side, char *uplo, integer *m, integer *n,
+ doublereal *alpha, doublereal *a, integer *lda, doublereal *b,
+ integer *ldb, doublereal *beta, doublereal *c__, integer *ldc);
+
+/* Subroutine */ int dsymv_(char *uplo, integer *n, doublereal *alpha,
+ doublereal *a, integer *lda, doublereal *x, integer *incx, doublereal
+ *beta, doublereal *y, integer *incy);
+
+/* Subroutine */ int dsyr_(char *uplo, integer *n, doublereal *alpha,
+ doublereal *x, integer *incx, doublereal *a, integer *lda);
+
+/* Subroutine */ int dsyr2_(char *uplo, integer *n, doublereal *alpha,
+ doublereal *x, integer *incx, doublereal *y, integer *incy,
+ doublereal *a, integer *lda);
+
+/* Subroutine */ int dsyr2k_(char *uplo, char *trans, integer *n, integer *k,
+ doublereal *alpha, doublereal *a, integer *lda, doublereal *b,
+ integer *ldb, doublereal *beta, doublereal *c__, integer *ldc);
+
+/* Subroutine */ int dsyrk_(char *uplo, char *trans, integer *n, integer *k,
+ doublereal *alpha, doublereal *a, integer *lda, doublereal *beta,
+ doublereal *c__, integer *ldc);
+
+/* Subroutine */ int dtbmv_(char *uplo, char *trans, char *diag, integer *n,
+ integer *k, doublereal *a, integer *lda, doublereal *x, integer *incx);
+
+/* Subroutine */ int dtbsv_(char *uplo, char *trans, char *diag, integer *n,
+ integer *k, doublereal *a, integer *lda, doublereal *x, integer *incx);
+
+/* Subroutine */ int dtpmv_(char *uplo, char *trans, char *diag, integer *n,
+ doublereal *ap, doublereal *x, integer *incx);
+
+/* Subroutine */ int dtpsv_(char *uplo, char *trans, char *diag, integer *n,
+ doublereal *ap, doublereal *x, integer *incx);
+
+/* Subroutine */ int dtrmm_(char *side, char *uplo, char *transa, char *diag,
+ integer *m, integer *n, doublereal *alpha, doublereal *a, integer *
+ lda, doublereal *b, integer *ldb);
+
+/* Subroutine */ int dtrmv_(char *uplo, char *trans, char *diag, integer *n,
+ doublereal *a, integer *lda, doublereal *x, integer *incx);
+
+/* Subroutine */ int dtrsm_(char *side, char *uplo, char *transa, char *diag,
+ integer *m, integer *n, doublereal *alpha, doublereal *a, integer *
+ lda, doublereal *b, integer *ldb);
+
+/* Subroutine */ int dtrsv_(char *uplo, char *trans, char *diag, integer *n,
+ doublereal *a, integer *lda, doublereal *x, integer *incx);
+
+doublereal dzasum_(integer *n, doublecomplex *zx, integer *incx);
+
+doublereal dznrm2_(integer *n, doublecomplex *x, integer *incx);
+
+integer icamax_(integer *n, complex *cx, integer *incx);
+
+integer idamax_(integer *n, doublereal *dx, integer *incx);
+
+integer isamax_(integer *n, real *sx, integer *incx);
+
+integer izamax_(integer *n, doublecomplex *zx, integer *incx);
+
+logical lsame_(char *ca, char *cb);
+
+doublereal sasum_(integer *n, real *sx, integer *incx);
+
+/* Subroutine */ int saxpy_(integer *n, real *sa, real *sx, integer *incx,
+ real *sy, integer *incy);
+
+doublereal scabs1_(complex *z__);
+
+doublereal scasum_(integer *n, complex *cx, integer *incx);
+
+doublereal scnrm2_(integer *n, complex *x, integer *incx);
+
+/* Subroutine */ int scopy_(integer *n, real *sx, integer *incx, real *sy,
+ integer *incy);
+
+doublereal sdot_(integer *n, real *sx, integer *incx, real *sy, integer *incy);
+
+doublereal sdsdot_(integer *n, real *sb, real *sx, integer *incx, real *sy,
+ integer *incy);
+
+/* Subroutine */ int sgbmv_(char *trans, integer *m, integer *n, integer *kl,
+ integer *ku, real *alpha, real *a, integer *lda, real *x, integer *
+ incx, real *beta, real *y, integer *incy);
+
+/* Subroutine */ int sgemm_(char *transa, char *transb, integer *m, integer *
+ n, integer *k, real *alpha, real *a, integer *lda, real *b, integer *
+ ldb, real *beta, real *c__, integer *ldc);
+
+/* Subroutine */ int sgemv_(char *trans, integer *m, integer *n, real *alpha,
+ real *a, integer *lda, real *x, integer *incx, real *beta, real *y,
+ integer *incy);
+
+/* Subroutine */ int sger_(integer *m, integer *n, real *alpha, real *x,
+ integer *incx, real *y, integer *incy, real *a, integer *lda);
+
+doublereal snrm2_(integer *n, real *x, integer *incx);
+
+/* Subroutine */ int srot_(integer *n, real *sx, integer *incx, real *sy,
+ integer *incy, real *c__, real *s);
+
+/* Subroutine */ int srotg_(real *sa, real *sb, real *c__, real *s);
+
+/* Subroutine */ int srotm_(integer *n, real *sx, integer *incx, real *sy,
+ integer *incy, real *sparam);
+
+/* Subroutine */ int srotmg_(real *sd1, real *sd2, real *sx1, real *sy1, real
+ *sparam);
+
+/* Subroutine */ int ssbmv_(char *uplo, integer *n, integer *k, real *alpha,
+ real *a, integer *lda, real *x, integer *incx, real *beta, real *y,
+ integer *incy);
+
+/* Subroutine */ int sscal_(integer *n, real *sa, real *sx, integer *incx);
+
+/* Subroutine */ int sspmv_(char *uplo, integer *n, real *alpha, real *ap,
+ real *x, integer *incx, real *beta, real *y, integer *incy);
+
+/* Subroutine */ int sspr_(char *uplo, integer *n, real *alpha, real *x,
+ integer *incx, real *ap);
+
+/* Subroutine */ int sspr2_(char *uplo, integer *n, real *alpha, real *x,
+ integer *incx, real *y, integer *incy, real *ap);
+
+/* Subroutine */ int sswap_(integer *n, real *sx, integer *incx, real *sy,
+ integer *incy);
+
+/* Subroutine */ int ssymm_(char *side, char *uplo, integer *m, integer *n,
+ real *alpha, real *a, integer *lda, real *b, integer *ldb, real *beta,
+ real *c__, integer *ldc);
+
+/* Subroutine */ int ssymv_(char *uplo, integer *n, real *alpha, real *a,
+ integer *lda, real *x, integer *incx, real *beta, real *y, integer *
+ incy);
+
+/* Subroutine */ int ssyr_(char *uplo, integer *n, real *alpha, real *x,
+ integer *incx, real *a, integer *lda);
+
+/* Subroutine */ int ssyr2_(char *uplo, integer *n, real *alpha, real *x,
+ integer *incx, real *y, integer *incy, real *a, integer *lda);
+
+/* Subroutine */ int ssyr2k_(char *uplo, char *trans, integer *n, integer *k,
+ real *alpha, real *a, integer *lda, real *b, integer *ldb, real *beta,
+ real *c__, integer *ldc);
+
+/* Subroutine */ int ssyrk_(char *uplo, char *trans, integer *n, integer *k,
+ real *alpha, real *a, integer *lda, real *beta, real *c__, integer *
+ ldc);
+
+/* Subroutine */ int stbmv_(char *uplo, char *trans, char *diag, integer *n,
+ integer *k, real *a, integer *lda, real *x, integer *incx);
+
+/* Subroutine */ int stbsv_(char *uplo, char *trans, char *diag, integer *n,
+ integer *k, real *a, integer *lda, real *x, integer *incx);
+
+/* Subroutine */ int stpmv_(char *uplo, char *trans, char *diag, integer *n,
+ real *ap, real *x, integer *incx);
+
+/* Subroutine */ int stpsv_(char *uplo, char *trans, char *diag, integer *n,
+ real *ap, real *x, integer *incx);
+
+/* Subroutine */ int strmm_(char *side, char *uplo, char *transa, char *diag,
+ integer *m, integer *n, real *alpha, real *a, integer *lda, real *b,
+ integer *ldb);
+
+/* Subroutine */ int strmv_(char *uplo, char *trans, char *diag, integer *n,
+ real *a, integer *lda, real *x, integer *incx);
+
+/* Subroutine */ int strsm_(char *side, char *uplo, char *transa, char *diag,
+ integer *m, integer *n, real *alpha, real *a, integer *lda, real *b,
+ integer *ldb);
+
+/* Subroutine */ int strsv_(char *uplo, char *trans, char *diag, integer *n,
+ real *a, integer *lda, real *x, integer *incx);
+
+/* Subroutine */ int xerbla_(char *srname, integer *info);
+
+/* Subroutine */ int xerbla_array__(char *srname_array__, integer *
+ srname_len__, integer *info, ftnlen srname_array_len);
+
+/* Subroutine */ int zaxpy_(integer *n, doublecomplex *za, doublecomplex *zx,
+ integer *incx, doublecomplex *zy, integer *incy);
+
+/* Subroutine */ int zcopy_(integer *n, doublecomplex *zx, integer *incx,
+ doublecomplex *zy, integer *incy);
+
+/* Double Complex */ VOID zdotc_(doublecomplex * ret_val, integer *n,
+ doublecomplex *zx, integer *incx, doublecomplex *zy, integer *incy);
+
+/* Double Complex */ VOID zdotu_(doublecomplex * ret_val, integer *n,
+ doublecomplex *zx, integer *incx, doublecomplex *zy, integer *incy);
+
+/* Subroutine */ int zdrot_(integer *n, doublecomplex *cx, integer *incx,
+ doublecomplex *cy, integer *incy, doublereal *c__, doublereal *s);
+
+/* Subroutine */ int zdscal_(integer *n, doublereal *da, doublecomplex *zx,
+ integer *incx);
+
+/* Subroutine */ int zgbmv_(char *trans, integer *m, integer *n, integer *kl,
+ integer *ku, doublecomplex *alpha, doublecomplex *a, integer *lda,
+ doublecomplex *x, integer *incx, doublecomplex *beta, doublecomplex *
+ y, integer *incy);
+
+/* Subroutine */ int zgemm_(char *transa, char *transb, integer *m, integer *
+ n, integer *k, doublecomplex *alpha, doublecomplex *a, integer *lda,
+ doublecomplex *b, integer *ldb, doublecomplex *beta, doublecomplex *
+ c__, integer *ldc);
+
+/* Subroutine */ int zgemv_(char *trans, integer *m, integer *n,
+ doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex *
+ x, integer *incx, doublecomplex *beta, doublecomplex *y, integer *
+ incy);
+
+/* Subroutine */ int zgerc_(integer *m, integer *n, doublecomplex *alpha,
+ doublecomplex *x, integer *incx, doublecomplex *y, integer *incy,
+ doublecomplex *a, integer *lda);
+
+/* Subroutine */ int zgeru_(integer *m, integer *n, doublecomplex *alpha,
+ doublecomplex *x, integer *incx, doublecomplex *y, integer *incy,
+ doublecomplex *a, integer *lda);
+
+/* Subroutine */ int zhbmv_(char *uplo, integer *n, integer *k, doublecomplex
+ *alpha, doublecomplex *a, integer *lda, doublecomplex *x, integer *
+ incx, doublecomplex *beta, doublecomplex *y, integer *incy);
+
+/* Subroutine */ int zhemm_(char *side, char *uplo, integer *m, integer *n,
+ doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex *
+ b, integer *ldb, doublecomplex *beta, doublecomplex *c__, integer *
+ ldc);
+
+/* Subroutine */ int zhemv_(char *uplo, integer *n, doublecomplex *alpha,
+ doublecomplex *a, integer *lda, doublecomplex *x, integer *incx,
+ doublecomplex *beta, doublecomplex *y, integer *incy);
+
+/* Subroutine */ int zher_(char *uplo, integer *n, doublereal *alpha,
+ doublecomplex *x, integer *incx, doublecomplex *a, integer *lda);
+
+/* Subroutine */ int zher2_(char *uplo, integer *n, doublecomplex *alpha,
+ doublecomplex *x, integer *incx, doublecomplex *y, integer *incy,
+ doublecomplex *a, integer *lda);
+
+/* Subroutine */ int zher2k_(char *uplo, char *trans, integer *n, integer *k,
+ doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex *
+ b, integer *ldb, doublereal *beta, doublecomplex *c__, integer *ldc);
+
+/* Subroutine */ int zherk_(char *uplo, char *trans, integer *n, integer *k,
+ doublereal *alpha, doublecomplex *a, integer *lda, doublereal *beta,
+ doublecomplex *c__, integer *ldc);
+
+/* Subroutine */ int zhpmv_(char *uplo, integer *n, doublecomplex *alpha,
+ doublecomplex *ap, doublecomplex *x, integer *incx, doublecomplex *
+ beta, doublecomplex *y, integer *incy);
+
+/* Subroutine */ int zhpr_(char *uplo, integer *n, doublereal *alpha,
+ doublecomplex *x, integer *incx, doublecomplex *ap);
+
+/* Subroutine */ int zhpr2_(char *uplo, integer *n, doublecomplex *alpha,
+ doublecomplex *x, integer *incx, doublecomplex *y, integer *incy,
+ doublecomplex *ap);
+
+/* Subroutine */ int zrotg_(doublecomplex *ca, doublecomplex *cb, doublereal *
+ c__, doublecomplex *s);
+
+/* Subroutine */ int zscal_(integer *n, doublecomplex *za, doublecomplex *zx,
+ integer *incx);
+
+/* Subroutine */ int zswap_(integer *n, doublecomplex *zx, integer *incx,
+ doublecomplex *zy, integer *incy);
+
+/* Subroutine */ int zsymm_(char *side, char *uplo, integer *m, integer *n,
+ doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex *
+ b, integer *ldb, doublecomplex *beta, doublecomplex *c__, integer *
+ ldc);
+
+/* Subroutine */ int zsyr2k_(char *uplo, char *trans, integer *n, integer *k,
+ doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex *
+ b, integer *ldb, doublecomplex *beta, doublecomplex *c__, integer *
+ ldc);
+
+/* Subroutine */ int zsyrk_(char *uplo, char *trans, integer *n, integer *k,
+ doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex *
+ beta, doublecomplex *c__, integer *ldc);
+
+/* Subroutine */ int ztbmv_(char *uplo, char *trans, char *diag, integer *n,
+ integer *k, doublecomplex *a, integer *lda, doublecomplex *x, integer
+ *incx);
+
+/* Subroutine */ int ztbsv_(char *uplo, char *trans, char *diag, integer *n,
+ integer *k, doublecomplex *a, integer *lda, doublecomplex *x, integer
+ *incx);
+
+/* Subroutine */ int ztpmv_(char *uplo, char *trans, char *diag, integer *n,
+ doublecomplex *ap, doublecomplex *x, integer *incx);
+
+/* Subroutine */ int ztpsv_(char *uplo, char *trans, char *diag, integer *n,
+ doublecomplex *ap, doublecomplex *x, integer *incx);
+
+/* Subroutine */ int ztrmm_(char *side, char *uplo, char *transa, char *diag,
+ integer *m, integer *n, doublecomplex *alpha, doublecomplex *a,
+ integer *lda, doublecomplex *b, integer *ldb);
+
+/* Subroutine */ int ztrmv_(char *uplo, char *trans, char *diag, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *x, integer *incx);
+
+/* Subroutine */ int ztrsm_(char *side, char *uplo, char *transa, char *diag,
+ integer *m, integer *n, doublecomplex *alpha, doublecomplex *a,
+ integer *lda, doublecomplex *b, integer *ldb);
+
+/* Subroutine */ int ztrsv_(char *uplo, char *trans, char *diag, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *x, integer *incx);
+
+/* Subroutine */ int cbdsqr_(char *uplo, integer *n, integer *ncvt, integer *
+ nru, integer *ncc, real *d__, real *e, complex *vt, integer *ldvt,
+ complex *u, integer *ldu, complex *c__, integer *ldc, real *rwork,
+ integer *info);
+
+/* Subroutine */ int cgbbrd_(char *vect, integer *m, integer *n, integer *ncc,
+ integer *kl, integer *ku, complex *ab, integer *ldab, real *d__,
+ real *e, complex *q, integer *ldq, complex *pt, integer *ldpt,
+ complex *c__, integer *ldc, complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int cgbcon_(char *norm, integer *n, integer *kl, integer *ku,
+ complex *ab, integer *ldab, integer *ipiv, real *anorm, real *rcond,
+ complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int cgbequ_(integer *m, integer *n, integer *kl, integer *ku,
+ complex *ab, integer *ldab, real *r__, real *c__, real *rowcnd, real
+ *colcnd, real *amax, integer *info);
+
+/* Subroutine */ int cgbequb_(integer *m, integer *n, integer *kl, integer *
+ ku, complex *ab, integer *ldab, real *r__, real *c__, real *rowcnd,
+ real *colcnd, real *amax, integer *info);
+
+/* Subroutine */ int cgbrfs_(char *trans, integer *n, integer *kl, integer *
+ ku, integer *nrhs, complex *ab, integer *ldab, complex *afb, integer *
+ ldafb, integer *ipiv, complex *b, integer *ldb, complex *x, integer *
+ ldx, real *ferr, real *berr, complex *work, real *rwork, integer *
+ info);
+
+/* Subroutine */ int cgbrfsx_(char *trans, char *equed, integer *n, integer *
+ kl, integer *ku, integer *nrhs, complex *ab, integer *ldab, complex *
+ afb, integer *ldafb, integer *ipiv, real *r__, real *c__, complex *b,
+ integer *ldb, complex *x, integer *ldx, real *rcond, real *berr,
+ integer *n_err_bnds__, real *err_bnds_norm__, real *err_bnds_comp__,
+ integer *nparams, real *params, complex *work, real *rwork, integer *
+ info);
+
+/* Subroutine */ int cgbsv_(integer *n, integer *kl, integer *ku, integer *
+ nrhs, complex *ab, integer *ldab, integer *ipiv, complex *b, integer *
+ ldb, integer *info);
+
+/* Subroutine */ int cgbsvx_(char *fact, char *trans, integer *n, integer *kl,
+ integer *ku, integer *nrhs, complex *ab, integer *ldab, complex *afb,
+ integer *ldafb, integer *ipiv, char *equed, real *r__, real *c__,
+ complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real
+ *ferr, real *berr, complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int cgbsvxx_(char *fact, char *trans, integer *n, integer *
+ kl, integer *ku, integer *nrhs, complex *ab, integer *ldab, complex *
+ afb, integer *ldafb, integer *ipiv, char *equed, real *r__, real *c__,
+ complex *b, integer *ldb, complex *x, integer *ldx, real *rcond,
+ real *rpvgrw, real *berr, integer *n_err_bnds__, real *
+ err_bnds_norm__, real *err_bnds_comp__, integer *nparams, real *
+ params, complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int cgbtf2_(integer *m, integer *n, integer *kl, integer *ku,
+ complex *ab, integer *ldab, integer *ipiv, integer *info);
+
+/* Subroutine */ int cgbtrf_(integer *m, integer *n, integer *kl, integer *ku,
+ complex *ab, integer *ldab, integer *ipiv, integer *info);
+
+/* Subroutine */ int cgbtrs_(char *trans, integer *n, integer *kl, integer *
+ ku, integer *nrhs, complex *ab, integer *ldab, integer *ipiv, complex
+ *b, integer *ldb, integer *info);
+
+/* Subroutine */ int cgebak_(char *job, char *side, integer *n, integer *ilo,
+ integer *ihi, real *scale, integer *m, complex *v, integer *ldv,
+ integer *info);
+
+/* Subroutine */ int cgebal_(char *job, integer *n, complex *a, integer *lda,
+ integer *ilo, integer *ihi, real *scale, integer *info);
+
+/* Subroutine */ int cgebd2_(integer *m, integer *n, complex *a, integer *lda,
+ real *d__, real *e, complex *tauq, complex *taup, complex *work,
+ integer *info);
+
+/* Subroutine */ int cgebrd_(integer *m, integer *n, complex *a, integer *lda,
+ real *d__, real *e, complex *tauq, complex *taup, complex *work,
+ integer *lwork, integer *info);
+
+/* Subroutine */ int cgecon_(char *norm, integer *n, complex *a, integer *lda,
+ real *anorm, real *rcond, complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int cgeequ_(integer *m, integer *n, complex *a, integer *lda,
+ real *r__, real *c__, real *rowcnd, real *colcnd, real *amax,
+ integer *info);
+
+/* Subroutine */ int cgeequb_(integer *m, integer *n, complex *a, integer *
+ lda, real *r__, real *c__, real *rowcnd, real *colcnd, real *amax,
+ integer *info);
+
+/* Subroutine */ int cgees_(char *jobvs, char *sort, L_fp select, integer *n,
+ complex *a, integer *lda, integer *sdim, complex *w, complex *vs,
+ integer *ldvs, complex *work, integer *lwork, real *rwork, logical *
+ bwork, integer *info);
+
+/* Subroutine */ int cgeesx_(char *jobvs, char *sort, L_fp select, char *
+ sense, integer *n, complex *a, integer *lda, integer *sdim, complex *
+ w, complex *vs, integer *ldvs, real *rconde, real *rcondv, complex *
+ work, integer *lwork, real *rwork, logical *bwork, integer *info);
+
+/* Subroutine */ int cgeev_(char *jobvl, char *jobvr, integer *n, complex *a,
+ integer *lda, complex *w, complex *vl, integer *ldvl, complex *vr,
+ integer *ldvr, complex *work, integer *lwork, real *rwork, integer *
+ info);
+
+/* Subroutine */ int cgeevx_(char *balanc, char *jobvl, char *jobvr, char *
+ sense, integer *n, complex *a, integer *lda, complex *w, complex *vl,
+ integer *ldvl, complex *vr, integer *ldvr, integer *ilo, integer *ihi,
+ real *scale, real *abnrm, real *rconde, real *rcondv, complex *work,
+ integer *lwork, real *rwork, integer *info);
+
+/* Subroutine */ int cgegs_(char *jobvsl, char *jobvsr, integer *n, complex *
+ a, integer *lda, complex *b, integer *ldb, complex *alpha, complex *
+ beta, complex *vsl, integer *ldvsl, complex *vsr, integer *ldvsr,
+ complex *work, integer *lwork, real *rwork, integer *info);
+
+/* Subroutine */ int cgegv_(char *jobvl, char *jobvr, integer *n, complex *a,
+ integer *lda, complex *b, integer *ldb, complex *alpha, complex *beta,
+ complex *vl, integer *ldvl, complex *vr, integer *ldvr, complex *
+ work, integer *lwork, real *rwork, integer *info);
+
+/* Subroutine */ int cgehd2_(integer *n, integer *ilo, integer *ihi, complex *
+ a, integer *lda, complex *tau, complex *work, integer *info);
+
+/* Subroutine */ int cgehrd_(integer *n, integer *ilo, integer *ihi, complex *
+ a, integer *lda, complex *tau, complex *work, integer *lwork, integer
+ *info);
+
+/* Subroutine */ int cgelq2_(integer *m, integer *n, complex *a, integer *lda,
+ complex *tau, complex *work, integer *info);
+
+/* Subroutine */ int cgelqf_(integer *m, integer *n, complex *a, integer *lda,
+ complex *tau, complex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int cgels_(char *trans, integer *m, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *b, integer *ldb, complex *
+ work, integer *lwork, integer *info);
+
+/* Subroutine */ int cgelsd_(integer *m, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *b, integer *ldb, real *s, real *rcond,
+ integer *rank, complex *work, integer *lwork, real *rwork, integer *
+ iwork, integer *info);
+
+/* Subroutine */ int cgelss_(integer *m, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *b, integer *ldb, real *s, real *rcond,
+ integer *rank, complex *work, integer *lwork, real *rwork, integer *
+ info);
+
+/* Subroutine */ int cgelsx_(integer *m, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *b, integer *ldb, integer *jpvt, real *rcond,
+ integer *rank, complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int cgelsy_(integer *m, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *b, integer *ldb, integer *jpvt, real *rcond,
+ integer *rank, complex *work, integer *lwork, real *rwork, integer *
+ info);
+
+/* Subroutine */ int cgeql2_(integer *m, integer *n, complex *a, integer *lda,
+ complex *tau, complex *work, integer *info);
+
+/* Subroutine */ int cgeqlf_(integer *m, integer *n, complex *a, integer *lda,
+ complex *tau, complex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int cgeqp3_(integer *m, integer *n, complex *a, integer *lda,
+ integer *jpvt, complex *tau, complex *work, integer *lwork, real *
+ rwork, integer *info);
+
+/* Subroutine */ int cgeqpf_(integer *m, integer *n, complex *a, integer *lda,
+ integer *jpvt, complex *tau, complex *work, real *rwork, integer *
+ info);
+
+/* Subroutine */ int cgeqr2_(integer *m, integer *n, complex *a, integer *lda,
+ complex *tau, complex *work, integer *info);
+
+/* Subroutine */ int cgeqrf_(integer *m, integer *n, complex *a, integer *lda,
+ complex *tau, complex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int cgerfs_(char *trans, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex *
+ b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr,
+ complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int cgerfsx_(char *trans, char *equed, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *
+ ipiv, real *r__, real *c__, complex *b, integer *ldb, complex *x,
+ integer *ldx, real *rcond, real *berr, integer *n_err_bnds__, real *
+ err_bnds_norm__, real *err_bnds_comp__, integer *nparams, real *
+ params, complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int cgerq2_(integer *m, integer *n, complex *a, integer *lda,
+ complex *tau, complex *work, integer *info);
+
+/* Subroutine */ int cgerqf_(integer *m, integer *n, complex *a, integer *lda,
+ complex *tau, complex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int cgesc2_(integer *n, complex *a, integer *lda, complex *
+ rhs, integer *ipiv, integer *jpiv, real *scale);
+
+/* Subroutine */ int cgesdd_(char *jobz, integer *m, integer *n, complex *a,
+ integer *lda, real *s, complex *u, integer *ldu, complex *vt, integer
+ *ldvt, complex *work, integer *lwork, real *rwork, integer *iwork,
+ integer *info);
+
+/* Subroutine */ int cgesv_(integer *n, integer *nrhs, complex *a, integer *
+ lda, integer *ipiv, complex *b, integer *ldb, integer *info);
+
+/* Subroutine */ int cgesvd_(char *jobu, char *jobvt, integer *m, integer *n,
+ complex *a, integer *lda, real *s, complex *u, integer *ldu, complex *
+ vt, integer *ldvt, complex *work, integer *lwork, real *rwork,
+ integer *info);
+
+/* Subroutine */ int cgesvx_(char *fact, char *trans, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *
+ ipiv, char *equed, real *r__, real *c__, complex *b, integer *ldb,
+ complex *x, integer *ldx, real *rcond, real *ferr, real *berr,
+ complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int cgesvxx_(char *fact, char *trans, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *
+ ipiv, char *equed, real *r__, real *c__, complex *b, integer *ldb,
+ complex *x, integer *ldx, real *rcond, real *rpvgrw, real *berr,
+ integer *n_err_bnds__, real *err_bnds_norm__, real *err_bnds_comp__,
+ integer *nparams, real *params, complex *work, real *rwork, integer *
+ info);
+
+/* Subroutine */ int cgetc2_(integer *n, complex *a, integer *lda, integer *
+ ipiv, integer *jpiv, integer *info);
+
+/* Subroutine */ int cgetf2_(integer *m, integer *n, complex *a, integer *lda,
+ integer *ipiv, integer *info);
+
+/* Subroutine */ int cgetrf_(integer *m, integer *n, complex *a, integer *lda,
+ integer *ipiv, integer *info);
+
+/* Subroutine */ int cgetri_(integer *n, complex *a, integer *lda, integer *
+ ipiv, complex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int cgetrs_(char *trans, integer *n, integer *nrhs, complex *
+ a, integer *lda, integer *ipiv, complex *b, integer *ldb, integer *
+ info);
+
+/* Subroutine */ int cggbak_(char *job, char *side, integer *n, integer *ilo,
+ integer *ihi, real *lscale, real *rscale, integer *m, complex *v,
+ integer *ldv, integer *info);
+
+/* Subroutine */ int cggbal_(char *job, integer *n, complex *a, integer *lda,
+ complex *b, integer *ldb, integer *ilo, integer *ihi, real *lscale,
+ real *rscale, real *work, integer *info);
+
+/* Subroutine */ int cgges_(char *jobvsl, char *jobvsr, char *sort, L_fp
+ selctg, integer *n, complex *a, integer *lda, complex *b, integer *
+ ldb, integer *sdim, complex *alpha, complex *beta, complex *vsl,
+ integer *ldvsl, complex *vsr, integer *ldvsr, complex *work, integer *
+ lwork, real *rwork, logical *bwork, integer *info);
+
+/* Subroutine */ int cggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp
+ selctg, char *sense, integer *n, complex *a, integer *lda, complex *b,
+ integer *ldb, integer *sdim, complex *alpha, complex *beta, complex *
+ vsl, integer *ldvsl, complex *vsr, integer *ldvsr, real *rconde, real
+ *rcondv, complex *work, integer *lwork, real *rwork, integer *iwork,
+ integer *liwork, logical *bwork, integer *info);
+
+/* Subroutine */ int cggev_(char *jobvl, char *jobvr, integer *n, complex *a,
+ integer *lda, complex *b, integer *ldb, complex *alpha, complex *beta,
+ complex *vl, integer *ldvl, complex *vr, integer *ldvr, complex *
+ work, integer *lwork, real *rwork, integer *info);
+
+/* Subroutine */ int cggevx_(char *balanc, char *jobvl, char *jobvr, char *
+ sense, integer *n, complex *a, integer *lda, complex *b, integer *ldb,
+ complex *alpha, complex *beta, complex *vl, integer *ldvl, complex *
+ vr, integer *ldvr, integer *ilo, integer *ihi, real *lscale, real *
+ rscale, real *abnrm, real *bbnrm, real *rconde, real *rcondv, complex
+ *work, integer *lwork, real *rwork, integer *iwork, logical *bwork,
+ integer *info);
+
+/* Subroutine */ int cggglm_(integer *n, integer *m, integer *p, complex *a,
+ integer *lda, complex *b, integer *ldb, complex *d__, complex *x,
+ complex *y, complex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int cgghrd_(char *compq, char *compz, integer *n, integer *
+ ilo, integer *ihi, complex *a, integer *lda, complex *b, integer *ldb,
+ complex *q, integer *ldq, complex *z__, integer *ldz, integer *info);
+
+/* Subroutine */ int cgglse_(integer *m, integer *n, integer *p, complex *a,
+ integer *lda, complex *b, integer *ldb, complex *c__, complex *d__,
+ complex *x, complex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int cggqrf_(integer *n, integer *m, integer *p, complex *a,
+ integer *lda, complex *taua, complex *b, integer *ldb, complex *taub,
+ complex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int cggrqf_(integer *m, integer *p, integer *n, complex *a,
+ integer *lda, complex *taua, complex *b, integer *ldb, complex *taub,
+ complex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int cggsvd_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *n, integer *p, integer *k, integer *l, complex *a, integer *
+ lda, complex *b, integer *ldb, real *alpha, real *beta, complex *u,
+ integer *ldu, complex *v, integer *ldv, complex *q, integer *ldq,
+ complex *work, real *rwork, integer *iwork, integer *info);
+
+/* Subroutine */ int cggsvp_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *p, integer *n, complex *a, integer *lda, complex *b, integer
+ *ldb, real *tola, real *tolb, integer *k, integer *l, complex *u,
+ integer *ldu, complex *v, integer *ldv, complex *q, integer *ldq,
+ integer *iwork, real *rwork, complex *tau, complex *work, integer *
+ info);
+
+/* Subroutine */ int cgtcon_(char *norm, integer *n, complex *dl, complex *
+ d__, complex *du, complex *du2, integer *ipiv, real *anorm, real *
+ rcond, complex *work, integer *info);
+
+/* Subroutine */ int cgtrfs_(char *trans, integer *n, integer *nrhs, complex *
+ dl, complex *d__, complex *du, complex *dlf, complex *df, complex *
+ duf, complex *du2, integer *ipiv, complex *b, integer *ldb, complex *
+ x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork,
+ integer *info);
+
+/* Subroutine */ int cgtsv_(integer *n, integer *nrhs, complex *dl, complex *
+ d__, complex *du, complex *b, integer *ldb, integer *info);
+
+/* Subroutine */ int cgtsvx_(char *fact, char *trans, integer *n, integer *
+ nrhs, complex *dl, complex *d__, complex *du, complex *dlf, complex *
+ df, complex *duf, complex *du2, integer *ipiv, complex *b, integer *
+ ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr,
+ complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int cgttrf_(integer *n, complex *dl, complex *d__, complex *
+ du, complex *du2, integer *ipiv, integer *info);
+
+/* Subroutine */ int cgttrs_(char *trans, integer *n, integer *nrhs, complex *
+ dl, complex *d__, complex *du, complex *du2, integer *ipiv, complex *
+ b, integer *ldb, integer *info);
+
+/* Subroutine */ int cgtts2_(integer *itrans, integer *n, integer *nrhs,
+ complex *dl, complex *d__, complex *du, complex *du2, integer *ipiv,
+ complex *b, integer *ldb);
+
+/* Subroutine */ int chbev_(char *jobz, char *uplo, integer *n, integer *kd,
+ complex *ab, integer *ldab, real *w, complex *z__, integer *ldz,
+ complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int chbevd_(char *jobz, char *uplo, integer *n, integer *kd,
+ complex *ab, integer *ldab, real *w, complex *z__, integer *ldz,
+ complex *work, integer *lwork, real *rwork, integer *lrwork, integer *
+ iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int chbevx_(char *jobz, char *range, char *uplo, integer *n,
+ integer *kd, complex *ab, integer *ldab, complex *q, integer *ldq,
+ real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *
+ m, real *w, complex *z__, integer *ldz, complex *work, real *rwork,
+ integer *iwork, integer *ifail, integer *info);
+
+/* Subroutine */ int chbgst_(char *vect, char *uplo, integer *n, integer *ka,
+ integer *kb, complex *ab, integer *ldab, complex *bb, integer *ldbb,
+ complex *x, integer *ldx, complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int chbgv_(char *jobz, char *uplo, integer *n, integer *ka,
+ integer *kb, complex *ab, integer *ldab, complex *bb, integer *ldbb,
+ real *w, complex *z__, integer *ldz, complex *work, real *rwork,
+ integer *info);
+
+/* Subroutine */ int chbgvd_(char *jobz, char *uplo, integer *n, integer *ka,
+ integer *kb, complex *ab, integer *ldab, complex *bb, integer *ldbb,
+ real *w, complex *z__, integer *ldz, complex *work, integer *lwork,
+ real *rwork, integer *lrwork, integer *iwork, integer *liwork,
+ integer *info);
+
+/* Subroutine */ int chbgvx_(char *jobz, char *range, char *uplo, integer *n,
+ integer *ka, integer *kb, complex *ab, integer *ldab, complex *bb,
+ integer *ldbb, complex *q, integer *ldq, real *vl, real *vu, integer *
+ il, integer *iu, real *abstol, integer *m, real *w, complex *z__,
+ integer *ldz, complex *work, real *rwork, integer *iwork, integer *
+ ifail, integer *info);
+
+/* Subroutine */ int chbtrd_(char *vect, char *uplo, integer *n, integer *kd,
+ complex *ab, integer *ldab, real *d__, real *e, complex *q, integer *
+ ldq, complex *work, integer *info);
+
+/* Subroutine */ int checon_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *ipiv, real *anorm, real *rcond, complex *work, integer *
+ info);
+
+/* Subroutine */ int cheequb_(char *uplo, integer *n, complex *a, integer *
+ lda, real *s, real *scond, real *amax, complex *work, integer *info);
+
+/* Subroutine */ int cheev_(char *jobz, char *uplo, integer *n, complex *a,
+ integer *lda, real *w, complex *work, integer *lwork, real *rwork,
+ integer *info);
+
+/* Subroutine */ int cheevd_(char *jobz, char *uplo, integer *n, complex *a,
+ integer *lda, real *w, complex *work, integer *lwork, real *rwork,
+ integer *lrwork, integer *iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int cheevr_(char *jobz, char *range, char *uplo, integer *n,
+ complex *a, integer *lda, real *vl, real *vu, integer *il, integer *
+ iu, real *abstol, integer *m, real *w, complex *z__, integer *ldz,
+ integer *isuppz, complex *work, integer *lwork, real *rwork, integer *
+ lrwork, integer *iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int cheevx_(char *jobz, char *range, char *uplo, integer *n,
+ complex *a, integer *lda, real *vl, real *vu, integer *il, integer *
+ iu, real *abstol, integer *m, real *w, complex *z__, integer *ldz,
+ complex *work, integer *lwork, real *rwork, integer *iwork, integer *
+ ifail, integer *info);
+
+/* Subroutine */ int chegs2_(integer *itype, char *uplo, integer *n, complex *
+ a, integer *lda, complex *b, integer *ldb, integer *info);
+
+/* Subroutine */ int chegst_(integer *itype, char *uplo, integer *n, complex *
+ a, integer *lda, complex *b, integer *ldb, integer *info);
+
+/* Subroutine */ int chegv_(integer *itype, char *jobz, char *uplo, integer *
+ n, complex *a, integer *lda, complex *b, integer *ldb, real *w,
+ complex *work, integer *lwork, real *rwork, integer *info);
+
+/* Subroutine */ int chegvd_(integer *itype, char *jobz, char *uplo, integer *
+ n, complex *a, integer *lda, complex *b, integer *ldb, real *w,
+ complex *work, integer *lwork, real *rwork, integer *lrwork, integer *
+ iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int chegvx_(integer *itype, char *jobz, char *range, char *
+ uplo, integer *n, complex *a, integer *lda, complex *b, integer *ldb,
+ real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *
+ m, real *w, complex *z__, integer *ldz, complex *work, integer *lwork,
+ real *rwork, integer *iwork, integer *ifail, integer *info);
+
+/* Subroutine */ int cherfs_(char *uplo, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex *
+ b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr,
+ complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int cherfsx_(char *uplo, char *equed, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *
+ ipiv, real *s, complex *b, integer *ldb, complex *x, integer *ldx,
+ real *rcond, real *berr, integer *n_err_bnds__, real *err_bnds_norm__,
+ real *err_bnds_comp__, integer *nparams, real *params, complex *work,
+ real *rwork, integer *info);
+
+/* Subroutine */ int chesv_(char *uplo, integer *n, integer *nrhs, complex *a,
+ integer *lda, integer *ipiv, complex *b, integer *ldb, complex *work,
+ integer *lwork, integer *info);
+
+/* Subroutine */ int chesvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *
+ ipiv, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond,
+ real *ferr, real *berr, complex *work, integer *lwork, real *rwork,
+ integer *info);
+
+/* Subroutine */ int chesvxx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *
+ ipiv, char *equed, real *s, complex *b, integer *ldb, complex *x,
+ integer *ldx, real *rcond, real *rpvgrw, real *berr, integer *
+ n_err_bnds__, real *err_bnds_norm__, real *err_bnds_comp__, integer *
+ nparams, real *params, complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int chetd2_(char *uplo, integer *n, complex *a, integer *lda,
+ real *d__, real *e, complex *tau, integer *info);
+
+/* Subroutine */ int chetf2_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *ipiv, integer *info);
+
+/* Subroutine */ int chetrd_(char *uplo, integer *n, complex *a, integer *lda,
+ real *d__, real *e, complex *tau, complex *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int chetrf_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *ipiv, complex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int chetri_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *ipiv, complex *work, integer *info);
+
+/* Subroutine */ int chetrs_(char *uplo, integer *n, integer *nrhs, complex *
+ a, integer *lda, integer *ipiv, complex *b, integer *ldb, integer *
+ info);
+
+/* Subroutine */ int chfrk_(char *transr, char *uplo, char *trans, integer *n,
+ integer *k, real *alpha, complex *a, integer *lda, real *beta,
+ complex *c__);
+
+/* Subroutine */ int chgeqz_(char *job, char *compq, char *compz, integer *n,
+ integer *ilo, integer *ihi, complex *h__, integer *ldh, complex *t,
+ integer *ldt, complex *alpha, complex *beta, complex *q, integer *ldq,
+ complex *z__, integer *ldz, complex *work, integer *lwork, real *
+ rwork, integer *info);
+
+/* Character */ VOID chla_transtype__(char *ret_val, ftnlen ret_val_len,
+ integer *trans);
+
+/* Subroutine */ int chpcon_(char *uplo, integer *n, complex *ap, integer *
+ ipiv, real *anorm, real *rcond, complex *work, integer *info);
+
+/* Subroutine */ int chpev_(char *jobz, char *uplo, integer *n, complex *ap,
+ real *w, complex *z__, integer *ldz, complex *work, real *rwork,
+ integer *info);
+
+/* Subroutine */ int chpevd_(char *jobz, char *uplo, integer *n, complex *ap,
+ real *w, complex *z__, integer *ldz, complex *work, integer *lwork,
+ real *rwork, integer *lrwork, integer *iwork, integer *liwork,
+ integer *info);
+
+/* Subroutine */ int chpevx_(char *jobz, char *range, char *uplo, integer *n,
+ complex *ap, real *vl, real *vu, integer *il, integer *iu, real *
+ abstol, integer *m, real *w, complex *z__, integer *ldz, complex *
+ work, real *rwork, integer *iwork, integer *ifail, integer *info);
+
+/* Subroutine */ int chpgst_(integer *itype, char *uplo, integer *n, complex *
+ ap, complex *bp, integer *info);
+
+/* Subroutine */ int chpgv_(integer *itype, char *jobz, char *uplo, integer *
+ n, complex *ap, complex *bp, real *w, complex *z__, integer *ldz,
+ complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int chpgvd_(integer *itype, char *jobz, char *uplo, integer *
+ n, complex *ap, complex *bp, real *w, complex *z__, integer *ldz,
+ complex *work, integer *lwork, real *rwork, integer *lrwork, integer *
+ iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int chpgvx_(integer *itype, char *jobz, char *range, char *
+ uplo, integer *n, complex *ap, complex *bp, real *vl, real *vu,
+ integer *il, integer *iu, real *abstol, integer *m, real *w, complex *
+ z__, integer *ldz, complex *work, real *rwork, integer *iwork,
+ integer *ifail, integer *info);
+
+/* Subroutine */ int chprfs_(char *uplo, integer *n, integer *nrhs, complex *
+ ap, complex *afp, integer *ipiv, complex *b, integer *ldb, complex *x,
+ integer *ldx, real *ferr, real *berr, complex *work, real *rwork,
+ integer *info);
+
+/* Subroutine */ int chpsv_(char *uplo, integer *n, integer *nrhs, complex *
+ ap, integer *ipiv, complex *b, integer *ldb, integer *info);
+
+/* Subroutine */ int chpsvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, complex *ap, complex *afp, integer *ipiv, complex *b, integer *
+ ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr,
+ complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int chptrd_(char *uplo, integer *n, complex *ap, real *d__,
+ real *e, complex *tau, integer *info);
+
+/* Subroutine */ int chptrf_(char *uplo, integer *n, complex *ap, integer *
+ ipiv, integer *info);
+
+/* Subroutine */ int chptri_(char *uplo, integer *n, complex *ap, integer *
+ ipiv, complex *work, integer *info);
+
+/* Subroutine */ int chptrs_(char *uplo, integer *n, integer *nrhs, complex *
+ ap, integer *ipiv, complex *b, integer *ldb, integer *info);
+
+/* Subroutine */ int chsein_(char *side, char *eigsrc, char *initv, logical *
+ select, integer *n, complex *h__, integer *ldh, complex *w, complex *
+ vl, integer *ldvl, complex *vr, integer *ldvr, integer *mm, integer *
+ m, complex *work, real *rwork, integer *ifaill, integer *ifailr,
+ integer *info);
+
+/* Subroutine */ int chseqr_(char *job, char *compz, integer *n, integer *ilo,
+ integer *ihi, complex *h__, integer *ldh, complex *w, complex *z__,
+ integer *ldz, complex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int cla_gbamv__(integer *trans, integer *m, integer *n,
+ integer *kl, integer *ku, real *alpha, complex *ab, integer *ldab,
+ complex *x, integer *incx, real *beta, real *y, integer *incy);
+
+doublereal cla_gbrcond_c__(char *trans, integer *n, integer *kl, integer *ku,
+ complex *ab, integer *ldab, complex *afb, integer *ldafb, integer *
+ ipiv, real *c__, logical *capply, integer *info, complex *work, real *
+ rwork, ftnlen trans_len);
+
+doublereal cla_gbrcond_x__(char *trans, integer *n, integer *kl, integer *ku,
+ complex *ab, integer *ldab, complex *afb, integer *ldafb, integer *
+ ipiv, complex *x, integer *info, complex *work, real *rwork, ftnlen
+ trans_len);
+
+/* Subroutine */ int cla_gbrfsx_extended__(integer *prec_type__, integer *
+ trans_type__, integer *n, integer *kl, integer *ku, integer *nrhs,
+ complex *ab, integer *ldab, complex *afb, integer *ldafb, integer *
+ ipiv, logical *colequ, real *c__, complex *b, integer *ldb, complex *
+ y, integer *ldy, real *berr_out__, integer *n_norms__, real *errs_n__,
+ real *errs_c__, complex *res, real *ayb, complex *dy, complex *
+ y_tail__, real *rcond, integer *ithresh, real *rthresh, real *dz_ub__,
+ logical *ignore_cwise__, integer *info);
+
+doublereal cla_gbrpvgrw__(integer *n, integer *kl, integer *ku, integer *
+ ncols, complex *ab, integer *ldab, complex *afb, integer *ldafb);
+
+/* Subroutine */ int cla_geamv__(integer *trans, integer *m, integer *n, real
+ *alpha, complex *a, integer *lda, complex *x, integer *incx, real *
+ beta, real *y, integer *incy);
+
+doublereal cla_gercond_c__(char *trans, integer *n, complex *a, integer *lda,
+ complex *af, integer *ldaf, integer *ipiv, real *c__, logical *capply,
+ integer *info, complex *work, real *rwork, ftnlen trans_len);
+
+doublereal cla_gercond_x__(char *trans, integer *n, complex *a, integer *lda,
+ complex *af, integer *ldaf, integer *ipiv, complex *x, integer *info,
+ complex *work, real *rwork, ftnlen trans_len);
+
+/* Subroutine */ int cla_gerfsx_extended__(integer *prec_type__, integer *
+ trans_type__, integer *n, integer *nrhs, complex *a, integer *lda,
+ complex *af, integer *ldaf, integer *ipiv, logical *colequ, real *c__,
+ complex *b, integer *ldb, complex *y, integer *ldy, real *berr_out__,
+ integer *n_norms__, real *errs_n__, real *errs_c__, complex *res,
+ real *ayb, complex *dy, complex *y_tail__, real *rcond, integer *
+ ithresh, real *rthresh, real *dz_ub__, logical *ignore_cwise__,
+ integer *info);
+
+/* Subroutine */ int cla_heamv__(integer *uplo, integer *n, real *alpha,
+ complex *a, integer *lda, complex *x, integer *incx, real *beta, real
+ *y, integer *incy);
+
+doublereal cla_hercond_c__(char *uplo, integer *n, complex *a, integer *lda,
+ complex *af, integer *ldaf, integer *ipiv, real *c__, logical *capply,
+ integer *info, complex *work, real *rwork, ftnlen uplo_len);
+
+doublereal cla_hercond_x__(char *uplo, integer *n, complex *a, integer *lda,
+ complex *af, integer *ldaf, integer *ipiv, complex *x, integer *info,
+ complex *work, real *rwork, ftnlen uplo_len);
+
+/* Subroutine */ int cla_herfsx_extended__(integer *prec_type__, char *uplo,
+ integer *n, integer *nrhs, complex *a, integer *lda, complex *af,
+ integer *ldaf, integer *ipiv, logical *colequ, real *c__, complex *b,
+ integer *ldb, complex *y, integer *ldy, real *berr_out__, integer *
+ n_norms__, real *errs_n__, real *errs_c__, complex *res, real *ayb,
+ complex *dy, complex *y_tail__, real *rcond, integer *ithresh, real *
+ rthresh, real *dz_ub__, logical *ignore_cwise__, integer *info,
+ ftnlen uplo_len);
+
+doublereal cla_herpvgrw__(char *uplo, integer *n, integer *info, complex *a,
+ integer *lda, complex *af, integer *ldaf, integer *ipiv, real *work,
+ ftnlen uplo_len);
+
+/* Subroutine */ int cla_lin_berr__(integer *n, integer *nz, integer *nrhs,
+ complex *res, real *ayb, real *berr);
+
+doublereal cla_porcond_c__(char *uplo, integer *n, complex *a, integer *lda,
+ complex *af, integer *ldaf, real *c__, logical *capply, integer *info,
+ complex *work, real *rwork, ftnlen uplo_len);
+
+doublereal cla_porcond_x__(char *uplo, integer *n, complex *a, integer *lda,
+ complex *af, integer *ldaf, complex *x, integer *info, complex *work,
+ real *rwork, ftnlen uplo_len);
+
+/* Subroutine */ int cla_porfsx_extended__(integer *prec_type__, char *uplo,
+ integer *n, integer *nrhs, complex *a, integer *lda, complex *af,
+ integer *ldaf, logical *colequ, real *c__, complex *b, integer *ldb,
+ complex *y, integer *ldy, real *berr_out__, integer *n_norms__, real *
+ errs_n__, real *errs_c__, complex *res, real *ayb, complex *dy,
+ complex *y_tail__, real *rcond, integer *ithresh, real *rthresh, real
+ *dz_ub__, logical *ignore_cwise__, integer *info, ftnlen uplo_len);
+
+doublereal cla_porpvgrw__(char *uplo, integer *ncols, complex *a, integer *
+ lda, complex *af, integer *ldaf, real *work, ftnlen uplo_len);
+
+doublereal cla_rpvgrw__(integer *n, integer *ncols, complex *a, integer *lda,
+ complex *af, integer *ldaf);
+
+/* Subroutine */ int cla_syamv__(integer *uplo, integer *n, real *alpha,
+ complex *a, integer *lda, complex *x, integer *incx, real *beta, real
+ *y, integer *incy);
+
+doublereal cla_syrcond_c__(char *uplo, integer *n, complex *a, integer *lda,
+ complex *af, integer *ldaf, integer *ipiv, real *c__, logical *capply,
+ integer *info, complex *work, real *rwork, ftnlen uplo_len);
+
+doublereal cla_syrcond_x__(char *uplo, integer *n, complex *a, integer *lda,
+ complex *af, integer *ldaf, integer *ipiv, complex *x, integer *info,
+ complex *work, real *rwork, ftnlen uplo_len);
+
+/* Subroutine */ int cla_syrfsx_extended__(integer *prec_type__, char *uplo,
+ integer *n, integer *nrhs, complex *a, integer *lda, complex *af,
+ integer *ldaf, integer *ipiv, logical *colequ, real *c__, complex *b,
+ integer *ldb, complex *y, integer *ldy, real *berr_out__, integer *
+ n_norms__, real *errs_n__, real *errs_c__, complex *res, real *ayb,
+ complex *dy, complex *y_tail__, real *rcond, integer *ithresh, real *
+ rthresh, real *dz_ub__, logical *ignore_cwise__, integer *info,
+ ftnlen uplo_len);
+
+doublereal cla_syrpvgrw__(char *uplo, integer *n, integer *info, complex *a,
+ integer *lda, complex *af, integer *ldaf, integer *ipiv, real *work,
+ ftnlen uplo_len);
+
+/* Subroutine */ int cla_wwaddw__(integer *n, complex *x, complex *y, complex
+ *w);
+
+/* Subroutine */ int clabrd_(integer *m, integer *n, integer *nb, complex *a,
+ integer *lda, real *d__, real *e, complex *tauq, complex *taup,
+ complex *x, integer *ldx, complex *y, integer *ldy);
+
+/* Subroutine */ int clacgv_(integer *n, complex *x, integer *incx);
+
+/* Subroutine */ int clacn2_(integer *n, complex *v, complex *x, real *est,
+ integer *kase, integer *isave);
+
+/* Subroutine */ int clacon_(integer *n, complex *v, complex *x, real *est,
+ integer *kase);
+
+/* Subroutine */ int clacp2_(char *uplo, integer *m, integer *n, real *a,
+ integer *lda, complex *b, integer *ldb);
+
+/* Subroutine */ int clacpy_(char *uplo, integer *m, integer *n, complex *a,
+ integer *lda, complex *b, integer *ldb);
+
+/* Subroutine */ int clacrm_(integer *m, integer *n, complex *a, integer *lda,
+ real *b, integer *ldb, complex *c__, integer *ldc, real *rwork);
+
+/* Subroutine */ int clacrt_(integer *n, complex *cx, integer *incx, complex *
+ cy, integer *incy, complex *c__, complex *s);
+
+/* Complex */ VOID cladiv_(complex * ret_val, complex *x, complex *y);
+
+/* Subroutine */ int claed0_(integer *qsiz, integer *n, real *d__, real *e,
+ complex *q, integer *ldq, complex *qstore, integer *ldqs, real *rwork,
+ integer *iwork, integer *info);
+
+/* Subroutine */ int claed7_(integer *n, integer *cutpnt, integer *qsiz,
+ integer *tlvls, integer *curlvl, integer *curpbm, real *d__, complex *
+ q, integer *ldq, real *rho, integer *indxq, real *qstore, integer *
+ qptr, integer *prmptr, integer *perm, integer *givptr, integer *
+ givcol, real *givnum, complex *work, real *rwork, integer *iwork,
+ integer *info);
+
+/* Subroutine */ int claed8_(integer *k, integer *n, integer *qsiz, complex *
+ q, integer *ldq, real *d__, real *rho, integer *cutpnt, real *z__,
+ real *dlamda, complex *q2, integer *ldq2, real *w, integer *indxp,
+ integer *indx, integer *indxq, integer *perm, integer *givptr,
+ integer *givcol, real *givnum, integer *info);
+
+/* Subroutine */ int claein_(logical *rightv, logical *noinit, integer *n,
+ complex *h__, integer *ldh, complex *w, complex *v, complex *b,
+ integer *ldb, real *rwork, real *eps3, real *smlnum, integer *info);
+
+/* Subroutine */ int claesy_(complex *a, complex *b, complex *c__, complex *
+ rt1, complex *rt2, complex *evscal, complex *cs1, complex *sn1);
+
+/* Subroutine */ int claev2_(complex *a, complex *b, complex *c__, real *rt1,
+ real *rt2, real *cs1, complex *sn1);
+
+/* Subroutine */ int clag2z_(integer *m, integer *n, complex *sa, integer *
+ ldsa, doublecomplex *a, integer *lda, integer *info);
+
+/* Subroutine */ int clags2_(logical *upper, real *a1, complex *a2, real *a3,
+ real *b1, complex *b2, real *b3, real *csu, complex *snu, real *csv,
+ complex *snv, real *csq, complex *snq);
+
+/* Subroutine */ int clagtm_(char *trans, integer *n, integer *nrhs, real *
+ alpha, complex *dl, complex *d__, complex *du, complex *x, integer *
+ ldx, real *beta, complex *b, integer *ldb);
+
+/* Subroutine */ int clahef_(char *uplo, integer *n, integer *nb, integer *kb,
+ complex *a, integer *lda, integer *ipiv, complex *w, integer *ldw,
+ integer *info);
+
+/* Subroutine */ int clahqr_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, complex *h__, integer *ldh, complex *w,
+ integer *iloz, integer *ihiz, complex *z__, integer *ldz, integer *
+ info);
+
+/* Subroutine */ int clahr2_(integer *n, integer *k, integer *nb, complex *a,
+ integer *lda, complex *tau, complex *t, integer *ldt, complex *y,
+ integer *ldy);
+
+/* Subroutine */ int clahrd_(integer *n, integer *k, integer *nb, complex *a,
+ integer *lda, complex *tau, complex *t, integer *ldt, complex *y,
+ integer *ldy);
+
+/* Subroutine */ int claic1_(integer *job, integer *j, complex *x, real *sest,
+ complex *w, complex *gamma, real *sestpr, complex *s, complex *c__);
+
+/* Subroutine */ int clals0_(integer *icompq, integer *nl, integer *nr,
+ integer *sqre, integer *nrhs, complex *b, integer *ldb, complex *bx,
+ integer *ldbx, integer *perm, integer *givptr, integer *givcol,
+ integer *ldgcol, real *givnum, integer *ldgnum, real *poles, real *
+ difl, real *difr, real *z__, integer *k, real *c__, real *s, real *
+ rwork, integer *info);
+
+/* Subroutine */ int clalsa_(integer *icompq, integer *smlsiz, integer *n,
+ integer *nrhs, complex *b, integer *ldb, complex *bx, integer *ldbx,
+ real *u, integer *ldu, real *vt, integer *k, real *difl, real *difr,
+ real *z__, real *poles, integer *givptr, integer *givcol, integer *
+ ldgcol, integer *perm, real *givnum, real *c__, real *s, real *rwork,
+ integer *iwork, integer *info);
+
+/* Subroutine */ int clalsd_(char *uplo, integer *smlsiz, integer *n, integer
+ *nrhs, real *d__, real *e, complex *b, integer *ldb, real *rcond,
+ integer *rank, complex *work, real *rwork, integer *iwork, integer *
+ info);
+
+doublereal clangb_(char *norm, integer *n, integer *kl, integer *ku, complex *
+ ab, integer *ldab, real *work);
+
+doublereal clange_(char *norm, integer *m, integer *n, complex *a, integer *
+ lda, real *work);
+
+doublereal clangt_(char *norm, integer *n, complex *dl, complex *d__, complex
+ *du);
+
+doublereal clanhb_(char *norm, char *uplo, integer *n, integer *k, complex *
+ ab, integer *ldab, real *work);
+
+doublereal clanhe_(char *norm, char *uplo, integer *n, complex *a, integer *
+ lda, real *work);
+
+doublereal clanhf_(char *norm, char *transr, char *uplo, integer *n, complex *
+ a, real *work);
+
+doublereal clanhp_(char *norm, char *uplo, integer *n, complex *ap, real *
+ work);
+
+doublereal clanhs_(char *norm, integer *n, complex *a, integer *lda, real *
+ work);
+
+doublereal clanht_(char *norm, integer *n, real *d__, complex *e);
+
+doublereal clansb_(char *norm, char *uplo, integer *n, integer *k, complex *
+ ab, integer *ldab, real *work);
+
+doublereal clansp_(char *norm, char *uplo, integer *n, complex *ap, real *
+ work);
+
+doublereal clansy_(char *norm, char *uplo, integer *n, complex *a, integer *
+ lda, real *work);
+
+doublereal clantb_(char *norm, char *uplo, char *diag, integer *n, integer *k,
+ complex *ab, integer *ldab, real *work);
+
+doublereal clantp_(char *norm, char *uplo, char *diag, integer *n, complex *
+ ap, real *work);
+
+doublereal clantr_(char *norm, char *uplo, char *diag, integer *m, integer *n,
+ complex *a, integer *lda, real *work);
+
+/* Subroutine */ int clapll_(integer *n, complex *x, integer *incx, complex *
+ y, integer *incy, real *ssmin);
+
+/* Subroutine */ int clapmt_(logical *forwrd, integer *m, integer *n, complex
+ *x, integer *ldx, integer *k);
+
+/* Subroutine */ int claqgb_(integer *m, integer *n, integer *kl, integer *ku,
+ complex *ab, integer *ldab, real *r__, real *c__, real *rowcnd, real
+ *colcnd, real *amax, char *equed);
+
+/* Subroutine */ int claqge_(integer *m, integer *n, complex *a, integer *lda,
+ real *r__, real *c__, real *rowcnd, real *colcnd, real *amax, char *
+ equed);
+
+/* Subroutine */ int claqhb_(char *uplo, integer *n, integer *kd, complex *ab,
+ integer *ldab, real *s, real *scond, real *amax, char *equed);
+
+/* Subroutine */ int claqhe_(char *uplo, integer *n, complex *a, integer *lda,
+ real *s, real *scond, real *amax, char *equed);
+
+/* Subroutine */ int claqhp_(char *uplo, integer *n, complex *ap, real *s,
+ real *scond, real *amax, char *equed);
+
+/* Subroutine */ int claqp2_(integer *m, integer *n, integer *offset, complex
+ *a, integer *lda, integer *jpvt, complex *tau, real *vn1, real *vn2,
+ complex *work);
+
+/* Subroutine */ int claqps_(integer *m, integer *n, integer *offset, integer
+ *nb, integer *kb, complex *a, integer *lda, integer *jpvt, complex *
+ tau, real *vn1, real *vn2, complex *auxv, complex *f, integer *ldf);
+
+/* Subroutine */ int claqr0_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, complex *h__, integer *ldh, complex *w,
+ integer *iloz, integer *ihiz, complex *z__, integer *ldz, complex *
+ work, integer *lwork, integer *info);
+
+/* Subroutine */ int claqr1_(integer *n, complex *h__, integer *ldh, complex *
+ s1, complex *s2, complex *v);
+
+/* Subroutine */ int claqr2_(logical *wantt, logical *wantz, integer *n,
+ integer *ktop, integer *kbot, integer *nw, complex *h__, integer *ldh,
+ integer *iloz, integer *ihiz, complex *z__, integer *ldz, integer *
+ ns, integer *nd, complex *sh, complex *v, integer *ldv, integer *nh,
+ complex *t, integer *ldt, integer *nv, complex *wv, integer *ldwv,
+ complex *work, integer *lwork);
+
+/* Subroutine */ int claqr3_(logical *wantt, logical *wantz, integer *n,
+ integer *ktop, integer *kbot, integer *nw, complex *h__, integer *ldh,
+ integer *iloz, integer *ihiz, complex *z__, integer *ldz, integer *
+ ns, integer *nd, complex *sh, complex *v, integer *ldv, integer *nh,
+ complex *t, integer *ldt, integer *nv, complex *wv, integer *ldwv,
+ complex *work, integer *lwork);
+
+/* Subroutine */ int claqr4_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, complex *h__, integer *ldh, complex *w,
+ integer *iloz, integer *ihiz, complex *z__, integer *ldz, complex *
+ work, integer *lwork, integer *info);
+
+/* Subroutine */ int claqr5_(logical *wantt, logical *wantz, integer *kacc22,
+ integer *n, integer *ktop, integer *kbot, integer *nshfts, complex *s,
+ complex *h__, integer *ldh, integer *iloz, integer *ihiz, complex *
+ z__, integer *ldz, complex *v, integer *ldv, complex *u, integer *ldu,
+ integer *nv, complex *wv, integer *ldwv, integer *nh, complex *wh,
+ integer *ldwh);
+
+/* Subroutine */ int claqsb_(char *uplo, integer *n, integer *kd, complex *ab,
+ integer *ldab, real *s, real *scond, real *amax, char *equed);
+
+/* Subroutine */ int claqsp_(char *uplo, integer *n, complex *ap, real *s,
+ real *scond, real *amax, char *equed);
+
+/* Subroutine */ int claqsy_(char *uplo, integer *n, complex *a, integer *lda,
+ real *s, real *scond, real *amax, char *equed);
+
+/* Subroutine */ int clar1v_(integer *n, integer *b1, integer *bn, real *
+ lambda, real *d__, real *l, real *ld, real *lld, real *pivmin, real *
+ gaptol, complex *z__, logical *wantnc, integer *negcnt, real *ztz,
+ real *mingma, integer *r__, integer *isuppz, real *nrminv, real *
+ resid, real *rqcorr, real *work);
+
+/* Subroutine */ int clar2v_(integer *n, complex *x, complex *y, complex *z__,
+ integer *incx, real *c__, complex *s, integer *incc);
+
+/* Subroutine */ int clarcm_(integer *m, integer *n, real *a, integer *lda,
+ complex *b, integer *ldb, complex *c__, integer *ldc, real *rwork);
+
+/* Subroutine */ int clarf_(char *side, integer *m, integer *n, complex *v,
+ integer *incv, complex *tau, complex *c__, integer *ldc, complex *
+ work);
+
+/* Subroutine */ int clarfb_(char *side, char *trans, char *direct, char *
+ storev, integer *m, integer *n, integer *k, complex *v, integer *ldv,
+ complex *t, integer *ldt, complex *c__, integer *ldc, complex *work,
+ integer *ldwork);
+
+/* Subroutine */ int clarfg_(integer *n, complex *alpha, complex *x, integer *
+ incx, complex *tau);
+
+/* Subroutine */ int clarfp_(integer *n, complex *alpha, complex *x, integer *
+ incx, complex *tau);
+
+/* Subroutine */ int clarft_(char *direct, char *storev, integer *n, integer *
+ k, complex *v, integer *ldv, complex *tau, complex *t, integer *ldt);
+
+/* Subroutine */ int clarfx_(char *side, integer *m, integer *n, complex *v,
+ complex *tau, complex *c__, integer *ldc, complex *work);
+
+/* Subroutine */ int clargv_(integer *n, complex *x, integer *incx, complex *
+ y, integer *incy, real *c__, integer *incc);
+
+/* Subroutine */ int clarnv_(integer *idist, integer *iseed, integer *n,
+ complex *x);
+
+/* Subroutine */ int clarrv_(integer *n, real *vl, real *vu, real *d__, real *
+ l, real *pivmin, integer *isplit, integer *m, integer *dol, integer *
+ dou, real *minrgp, real *rtol1, real *rtol2, real *w, real *werr,
+ real *wgap, integer *iblock, integer *indexw, real *gers, complex *
+ z__, integer *ldz, integer *isuppz, real *work, integer *iwork,
+ integer *info);
+
+/* Subroutine */ int clarscl2_(integer *m, integer *n, real *d__, complex *x,
+ integer *ldx);
+
+/* Subroutine */ int clartg_(complex *f, complex *g, real *cs, complex *sn,
+ complex *r__);
+
+/* Subroutine */ int clartv_(integer *n, complex *x, integer *incx, complex *
+ y, integer *incy, real *c__, complex *s, integer *incc);
+
+/* Subroutine */ int clarz_(char *side, integer *m, integer *n, integer *l,
+ complex *v, integer *incv, complex *tau, complex *c__, integer *ldc,
+ complex *work);
+
+/* Subroutine */ int clarzb_(char *side, char *trans, char *direct, char *
+ storev, integer *m, integer *n, integer *k, integer *l, complex *v,
+ integer *ldv, complex *t, integer *ldt, complex *c__, integer *ldc,
+ complex *work, integer *ldwork);
+
+/* Subroutine */ int clarzt_(char *direct, char *storev, integer *n, integer *
+ k, complex *v, integer *ldv, complex *tau, complex *t, integer *ldt);
+
+/* Subroutine */ int clascl_(char *type__, integer *kl, integer *ku, real *
+ cfrom, real *cto, integer *m, integer *n, complex *a, integer *lda,
+ integer *info);
+
+/* Subroutine */ int clascl2_(integer *m, integer *n, real *d__, complex *x,
+ integer *ldx);
+
+/* Subroutine */ int claset_(char *uplo, integer *m, integer *n, complex *
+ alpha, complex *beta, complex *a, integer *lda);
+
+/* Subroutine */ int clasr_(char *side, char *pivot, char *direct, integer *m,
+ integer *n, real *c__, real *s, complex *a, integer *lda);
+
+/* Subroutine */ int classq_(integer *n, complex *x, integer *incx, real *
+ scale, real *sumsq);
+
+/* Subroutine */ int claswp_(integer *n, complex *a, integer *lda, integer *
+ k1, integer *k2, integer *ipiv, integer *incx);
+
+/* Subroutine */ int clasyf_(char *uplo, integer *n, integer *nb, integer *kb,
+ complex *a, integer *lda, integer *ipiv, complex *w, integer *ldw,
+ integer *info);
+
+/* Subroutine */ int clatbs_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, integer *kd, complex *ab, integer *ldab, complex *
+ x, real *scale, real *cnorm, integer *info);
+
+/* Subroutine */ int clatdf_(integer *ijob, integer *n, complex *z__, integer
+ *ldz, complex *rhs, real *rdsum, real *rdscal, integer *ipiv, integer
+ *jpiv);
+
+/* Subroutine */ int clatps_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, complex *ap, complex *x, real *scale, real *cnorm,
+ integer *info);
+
+/* Subroutine */ int clatrd_(char *uplo, integer *n, integer *nb, complex *a,
+ integer *lda, real *e, complex *tau, complex *w, integer *ldw);
+
+/* Subroutine */ int clatrs_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, complex *a, integer *lda, complex *x, real *scale,
+ real *cnorm, integer *info);
+
+/* Subroutine */ int clatrz_(integer *m, integer *n, integer *l, complex *a,
+ integer *lda, complex *tau, complex *work);
+
+/* Subroutine */ int clatzm_(char *side, integer *m, integer *n, complex *v,
+ integer *incv, complex *tau, complex *c1, complex *c2, integer *ldc,
+ complex *work);
+
+/* Subroutine */ int clauu2_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *info);
+
+/* Subroutine */ int clauum_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *info);
+
+/* Subroutine */ int cpbcon_(char *uplo, integer *n, integer *kd, complex *ab,
+ integer *ldab, real *anorm, real *rcond, complex *work, real *rwork,
+ integer *info);
+
+/* Subroutine */ int cpbequ_(char *uplo, integer *n, integer *kd, complex *ab,
+ integer *ldab, real *s, real *scond, real *amax, integer *info);
+
+/* Subroutine */ int cpbrfs_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, complex *ab, integer *ldab, complex *afb, integer *ldafb,
+ complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *
+ berr, complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int cpbstf_(char *uplo, integer *n, integer *kd, complex *ab,
+ integer *ldab, integer *info);
+
+/* Subroutine */ int cpbsv_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, complex *ab, integer *ldab, complex *b, integer *ldb, integer *
+ info);
+
+/* Subroutine */ int cpbsvx_(char *fact, char *uplo, integer *n, integer *kd,
+ integer *nrhs, complex *ab, integer *ldab, complex *afb, integer *
+ ldafb, char *equed, real *s, complex *b, integer *ldb, complex *x,
+ integer *ldx, real *rcond, real *ferr, real *berr, complex *work,
+ real *rwork, integer *info);
+
+/* Subroutine */ int cpbtf2_(char *uplo, integer *n, integer *kd, complex *ab,
+ integer *ldab, integer *info);
+
+/* Subroutine */ int cpbtrf_(char *uplo, integer *n, integer *kd, complex *ab,
+ integer *ldab, integer *info);
+
+/* Subroutine */ int cpbtrs_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, complex *ab, integer *ldab, complex *b, integer *ldb, integer *
+ info);
+
+/* Subroutine */ int cpftrf_(char *transr, char *uplo, integer *n, complex *a,
+ integer *info);
+
+/* Subroutine */ int cpftri_(char *transr, char *uplo, integer *n, complex *a,
+ integer *info);
+
+/* Subroutine */ int cpftrs_(char *transr, char *uplo, integer *n, integer *
+ nrhs, complex *a, complex *b, integer *ldb, integer *info);
+
+/* Subroutine */ int cpocon_(char *uplo, integer *n, complex *a, integer *lda,
+ real *anorm, real *rcond, complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int cpoequ_(integer *n, complex *a, integer *lda, real *s,
+ real *scond, real *amax, integer *info);
+
+/* Subroutine */ int cpoequb_(integer *n, complex *a, integer *lda, real *s,
+ real *scond, real *amax, integer *info);
+
+/* Subroutine */ int cporfs_(char *uplo, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *af, integer *ldaf, complex *b, integer *ldb,
+ complex *x, integer *ldx, real *ferr, real *berr, complex *work,
+ real *rwork, integer *info);
+
+/* Subroutine */ int cporfsx_(char *uplo, char *equed, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, real *s,
+ complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real
+ *berr, integer *n_err_bnds__, real *err_bnds_norm__, real *
+ err_bnds_comp__, integer *nparams, real *params, complex *work, real *
+ rwork, integer *info);
+
+/* Subroutine */ int cposv_(char *uplo, integer *n, integer *nrhs, complex *a,
+ integer *lda, complex *b, integer *ldb, integer *info);
+
+/* Subroutine */ int cposvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, char *
+ equed, real *s, complex *b, integer *ldb, complex *x, integer *ldx,
+ real *rcond, real *ferr, real *berr, complex *work, real *rwork,
+ integer *info);
+
+/* Subroutine */ int cposvxx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, char *
+ equed, real *s, complex *b, integer *ldb, complex *x, integer *ldx,
+ real *rcond, real *rpvgrw, real *berr, integer *n_err_bnds__, real *
+ err_bnds_norm__, real *err_bnds_comp__, integer *nparams, real *
+ params, complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int cpotf2_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *info);
+
+/* Subroutine */ int cpotrf_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *info);
+
+/* Subroutine */ int cpotri_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *info);
+
+/* Subroutine */ int cpotrs_(char *uplo, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *b, integer *ldb, integer *info);
+
+/* Subroutine */ int cppcon_(char *uplo, integer *n, complex *ap, real *anorm,
+ real *rcond, complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int cppequ_(char *uplo, integer *n, complex *ap, real *s,
+ real *scond, real *amax, integer *info);
+
+/* Subroutine */ int cpprfs_(char *uplo, integer *n, integer *nrhs, complex *
+ ap, complex *afp, complex *b, integer *ldb, complex *x, integer *ldx,
+ real *ferr, real *berr, complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int cppsv_(char *uplo, integer *n, integer *nrhs, complex *
+ ap, complex *b, integer *ldb, integer *info);
+
+/* Subroutine */ int cppsvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, complex *ap, complex *afp, char *equed, real *s, complex *b,
+ integer *ldb, complex *x, integer *ldx, real *rcond, real *ferr, real
+ *berr, complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int cpptrf_(char *uplo, integer *n, complex *ap, integer *
+ info);
+
+/* Subroutine */ int cpptri_(char *uplo, integer *n, complex *ap, integer *
+ info);
+
+/* Subroutine */ int cpptrs_(char *uplo, integer *n, integer *nrhs, complex *
+ ap, complex *b, integer *ldb, integer *info);
+
+/* Subroutine */ int cpstf2_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *piv, integer *rank, real *tol, real *work, integer *info);
+
+/* Subroutine */ int cpstrf_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *piv, integer *rank, real *tol, real *work, integer *info);
+
+/* Subroutine */ int cptcon_(integer *n, real *d__, complex *e, real *anorm,
+ real *rcond, real *rwork, integer *info);
+
+/* Subroutine */ int cpteqr_(char *compz, integer *n, real *d__, real *e,
+ complex *z__, integer *ldz, real *work, integer *info);
+
+/* Subroutine */ int cptrfs_(char *uplo, integer *n, integer *nrhs, real *d__,
+ complex *e, real *df, complex *ef, complex *b, integer *ldb, complex
+ *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork,
+ integer *info);
+
+/* Subroutine */ int cptsv_(integer *n, integer *nrhs, real *d__, complex *e,
+ complex *b, integer *ldb, integer *info);
+
+/* Subroutine */ int cptsvx_(char *fact, integer *n, integer *nrhs, real *d__,
+ complex *e, real *df, complex *ef, complex *b, integer *ldb, complex
+ *x, integer *ldx, real *rcond, real *ferr, real *berr, complex *work,
+ real *rwork, integer *info);
+
+/* Subroutine */ int cpttrf_(integer *n, real *d__, complex *e, integer *info);
+
+/* Subroutine */ int cpttrs_(char *uplo, integer *n, integer *nrhs, real *d__,
+ complex *e, complex *b, integer *ldb, integer *info);
+
+/* Subroutine */ int cptts2_(integer *iuplo, integer *n, integer *nrhs, real *
+ d__, complex *e, complex *b, integer *ldb);
+
+/* Subroutine */ int crot_(integer *n, complex *cx, integer *incx, complex *
+ cy, integer *incy, real *c__, complex *s);
+
+/* Subroutine */ int cspcon_(char *uplo, integer *n, complex *ap, integer *
+ ipiv, real *anorm, real *rcond, complex *work, integer *info);
+
+/* Subroutine */ int cspmv_(char *uplo, integer *n, complex *alpha, complex *
+ ap, complex *x, integer *incx, complex *beta, complex *y, integer *
+ incy);
+
+/* Subroutine */ int cspr_(char *uplo, integer *n, complex *alpha, complex *x,
+ integer *incx, complex *ap);
+
+/* Subroutine */ int csprfs_(char *uplo, integer *n, integer *nrhs, complex *
+ ap, complex *afp, integer *ipiv, complex *b, integer *ldb, complex *x,
+ integer *ldx, real *ferr, real *berr, complex *work, real *rwork,
+ integer *info);
+
+/* Subroutine */ int cspsv_(char *uplo, integer *n, integer *nrhs, complex *
+ ap, integer *ipiv, complex *b, integer *ldb, integer *info);
+
+/* Subroutine */ int cspsvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, complex *ap, complex *afp, integer *ipiv, complex *b, integer *
+ ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr,
+ complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int csptrf_(char *uplo, integer *n, complex *ap, integer *
+ ipiv, integer *info);
+
+/* Subroutine */ int csptri_(char *uplo, integer *n, complex *ap, integer *
+ ipiv, complex *work, integer *info);
+
+/* Subroutine */ int csptrs_(char *uplo, integer *n, integer *nrhs, complex *
+ ap, integer *ipiv, complex *b, integer *ldb, integer *info);
+
+/* Subroutine */ int csrscl_(integer *n, real *sa, complex *sx, integer *incx);
+
+/* Subroutine */ int cstedc_(char *compz, integer *n, real *d__, real *e,
+ complex *z__, integer *ldz, complex *work, integer *lwork, real *
+ rwork, integer *lrwork, integer *iwork, integer *liwork, integer *
+ info);
+
+/* Subroutine */ int cstegr_(char *jobz, char *range, integer *n, real *d__,
+ real *e, real *vl, real *vu, integer *il, integer *iu, real *abstol,
+ integer *m, real *w, complex *z__, integer *ldz, integer *isuppz,
+ real *work, integer *lwork, integer *iwork, integer *liwork, integer *
+ info);
+
+/* Subroutine */ int cstein_(integer *n, real *d__, real *e, integer *m, real
+ *w, integer *iblock, integer *isplit, complex *z__, integer *ldz,
+ real *work, integer *iwork, integer *ifail, integer *info);
+
+/* Subroutine */ int cstemr_(char *jobz, char *range, integer *n, real *d__,
+ real *e, real *vl, real *vu, integer *il, integer *iu, integer *m,
+ real *w, complex *z__, integer *ldz, integer *nzc, integer *isuppz,
+ logical *tryrac, real *work, integer *lwork, integer *iwork, integer *
+ liwork, integer *info);
+
+/* Subroutine */ int csteqr_(char *compz, integer *n, real *d__, real *e,
+ complex *z__, integer *ldz, real *work, integer *info);
+
+/* Subroutine */ int csycon_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *ipiv, real *anorm, real *rcond, complex *work, integer *
+ info);
+
+/* Subroutine */ int csyequb_(char *uplo, integer *n, complex *a, integer *
+ lda, real *s, real *scond, real *amax, complex *work, integer *info);
+
+/* Subroutine */ int csymv_(char *uplo, integer *n, complex *alpha, complex *
+ a, integer *lda, complex *x, integer *incx, complex *beta, complex *y,
+ integer *incy);
+
+/* Subroutine */ int csyr_(char *uplo, integer *n, complex *alpha, complex *x,
+ integer *incx, complex *a, integer *lda);
+
+/* Subroutine */ int csyrfs_(char *uplo, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex *
+ b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr,
+ complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int csyrfsx_(char *uplo, char *equed, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *
+ ipiv, real *s, complex *b, integer *ldb, complex *x, integer *ldx,
+ real *rcond, real *berr, integer *n_err_bnds__, real *err_bnds_norm__,
+ real *err_bnds_comp__, integer *nparams, real *params, complex *work,
+ real *rwork, integer *info);
+
+/* Subroutine */ int csysv_(char *uplo, integer *n, integer *nrhs, complex *a,
+ integer *lda, integer *ipiv, complex *b, integer *ldb, complex *work,
+ integer *lwork, integer *info);
+
+/* Subroutine */ int csysvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *
+ ipiv, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond,
+ real *ferr, real *berr, complex *work, integer *lwork, real *rwork,
+ integer *info);
+
+/* Subroutine */ int csysvxx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *
+ ipiv, char *equed, real *s, complex *b, integer *ldb, complex *x,
+ integer *ldx, real *rcond, real *rpvgrw, real *berr, integer *
+ n_err_bnds__, real *err_bnds_norm__, real *err_bnds_comp__, integer *
+ nparams, real *params, complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int csytf2_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *ipiv, integer *info);
+
+/* Subroutine */ int csytrf_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *ipiv, complex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int csytri_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *ipiv, complex *work, integer *info);
+
+/* Subroutine */ int csytrs_(char *uplo, integer *n, integer *nrhs, complex *
+ a, integer *lda, integer *ipiv, complex *b, integer *ldb, integer *
+ info);
+
+/* Subroutine */ int ctbcon_(char *norm, char *uplo, char *diag, integer *n,
+ integer *kd, complex *ab, integer *ldab, real *rcond, complex *work,
+ real *rwork, integer *info);
+
+/* Subroutine */ int ctbrfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, complex *ab, integer *ldab, complex *b,
+ integer *ldb, complex *x, integer *ldx, real *ferr, real *berr,
+ complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int ctbtrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, complex *ab, integer *ldab, complex *b,
+ integer *ldb, integer *info);
+
+/* Subroutine */ int ctfsm_(char *transr, char *side, char *uplo, char *trans,
+ char *diag, integer *m, integer *n, complex *alpha, complex *a,
+ complex *b, integer *ldb);
+
+/* Subroutine */ int ctftri_(char *transr, char *uplo, char *diag, integer *n,
+ complex *a, integer *info);
+
+/* Subroutine */ int ctfttp_(char *transr, char *uplo, integer *n, complex *
+ arf, complex *ap, integer *info);
+
+/* Subroutine */ int ctfttr_(char *transr, char *uplo, integer *n, complex *
+ arf, complex *a, integer *lda, integer *info);
+
+/* Subroutine */ int ctgevc_(char *side, char *howmny, logical *select,
+ integer *n, complex *s, integer *lds, complex *p, integer *ldp,
+ complex *vl, integer *ldvl, complex *vr, integer *ldvr, integer *mm,
+ integer *m, complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int ctgex2_(logical *wantq, logical *wantz, integer *n,
+ complex *a, integer *lda, complex *b, integer *ldb, complex *q,
+ integer *ldq, complex *z__, integer *ldz, integer *j1, integer *info);
+
+/* Subroutine */ int ctgexc_(logical *wantq, logical *wantz, integer *n,
+ complex *a, integer *lda, complex *b, integer *ldb, complex *q,
+ integer *ldq, complex *z__, integer *ldz, integer *ifst, integer *
+ ilst, integer *info);
+
+/* Subroutine */ int ctgsen_(integer *ijob, logical *wantq, logical *wantz,
+ logical *select, integer *n, complex *a, integer *lda, complex *b,
+ integer *ldb, complex *alpha, complex *beta, complex *q, integer *ldq,
+ complex *z__, integer *ldz, integer *m, real *pl, real *pr, real *
+ dif, complex *work, integer *lwork, integer *iwork, integer *liwork,
+ integer *info);
+
+/* Subroutine */ int ctgsja_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *p, integer *n, integer *k, integer *l, complex *a, integer *
+ lda, complex *b, integer *ldb, real *tola, real *tolb, real *alpha,
+ real *beta, complex *u, integer *ldu, complex *v, integer *ldv,
+ complex *q, integer *ldq, complex *work, integer *ncycle, integer *
+ info);
+
+/* Subroutine */ int ctgsna_(char *job, char *howmny, logical *select,
+ integer *n, complex *a, integer *lda, complex *b, integer *ldb,
+ complex *vl, integer *ldvl, complex *vr, integer *ldvr, real *s, real
+ *dif, integer *mm, integer *m, complex *work, integer *lwork, integer
+ *iwork, integer *info);
+
+/* Subroutine */ int ctgsy2_(char *trans, integer *ijob, integer *m, integer *
+ n, complex *a, integer *lda, complex *b, integer *ldb, complex *c__,
+ integer *ldc, complex *d__, integer *ldd, complex *e, integer *lde,
+ complex *f, integer *ldf, real *scale, real *rdsum, real *rdscal,
+ integer *info);
+
+/* Subroutine */ int ctgsyl_(char *trans, integer *ijob, integer *m, integer *
+ n, complex *a, integer *lda, complex *b, integer *ldb, complex *c__,
+ integer *ldc, complex *d__, integer *ldd, complex *e, integer *lde,
+ complex *f, integer *ldf, real *scale, real *dif, complex *work,
+ integer *lwork, integer *iwork, integer *info);
+
+/* Subroutine */ int ctpcon_(char *norm, char *uplo, char *diag, integer *n,
+ complex *ap, real *rcond, complex *work, real *rwork, integer *info);
+
+/* Subroutine */ int ctprfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, complex *ap, complex *b, integer *ldb, complex *x,
+ integer *ldx, real *ferr, real *berr, complex *work, real *rwork,
+ integer *info);
+
+/* Subroutine */ int ctptri_(char *uplo, char *diag, integer *n, complex *ap,
+ integer *info);
+
+/* Subroutine */ int ctptrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, complex *ap, complex *b, integer *ldb, integer *info);
+
+/* Subroutine */ int ctpttf_(char *transr, char *uplo, integer *n, complex *
+ ap, complex *arf, integer *info);
+
+/* Subroutine */ int ctpttr_(char *uplo, integer *n, complex *ap, complex *a,
+ integer *lda, integer *info);
+
+/* Subroutine */ int ctrcon_(char *norm, char *uplo, char *diag, integer *n,
+ complex *a, integer *lda, real *rcond, complex *work, real *rwork,
+ integer *info);
+
+/* Subroutine */ int ctrevc_(char *side, char *howmny, logical *select,
+ integer *n, complex *t, integer *ldt, complex *vl, integer *ldvl,
+ complex *vr, integer *ldvr, integer *mm, integer *m, complex *work,
+ real *rwork, integer *info);
+
+/* Subroutine */ int ctrexc_(char *compq, integer *n, complex *t, integer *
+ ldt, complex *q, integer *ldq, integer *ifst, integer *ilst, integer *
+ info);
+
+/* Subroutine */ int ctrrfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, complex *a, integer *lda, complex *b, integer *ldb,
+ complex *x, integer *ldx, real *ferr, real *berr, complex *work, real
+ *rwork, integer *info);
+
+/* Subroutine */ int ctrsen_(char *job, char *compq, logical *select, integer
+ *n, complex *t, integer *ldt, complex *q, integer *ldq, complex *w,
+ integer *m, real *s, real *sep, complex *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int ctrsna_(char *job, char *howmny, logical *select,
+ integer *n, complex *t, integer *ldt, complex *vl, integer *ldvl,
+ complex *vr, integer *ldvr, real *s, real *sep, integer *mm, integer *
+ m, complex *work, integer *ldwork, real *rwork, integer *info);
+
+/* Subroutine */ int ctrsyl_(char *trana, char *tranb, integer *isgn, integer
+ *m, integer *n, complex *a, integer *lda, complex *b, integer *ldb,
+ complex *c__, integer *ldc, real *scale, integer *info);
+
+/* Subroutine */ int ctrti2_(char *uplo, char *diag, integer *n, complex *a,
+ integer *lda, integer *info);
+
+/* Subroutine */ int ctrtri_(char *uplo, char *diag, integer *n, complex *a,
+ integer *lda, integer *info);
+
+/* Subroutine */ int ctrtrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, complex *a, integer *lda, complex *b, integer *ldb,
+ integer *info);
+
+/* Subroutine */ int ctrttf_(char *transr, char *uplo, integer *n, complex *a,
+ integer *lda, complex *arf, integer *info);
+
+/* Subroutine */ int ctrttp_(char *uplo, integer *n, complex *a, integer *lda,
+ complex *ap, integer *info);
+
+/* Subroutine */ int ctzrqf_(integer *m, integer *n, complex *a, integer *lda,
+ complex *tau, integer *info);
+
+/* Subroutine */ int ctzrzf_(integer *m, integer *n, complex *a, integer *lda,
+ complex *tau, complex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int cung2l_(integer *m, integer *n, integer *k, complex *a,
+ integer *lda, complex *tau, complex *work, integer *info);
+
+/* Subroutine */ int cung2r_(integer *m, integer *n, integer *k, complex *a,
+ integer *lda, complex *tau, complex *work, integer *info);
+
+/* Subroutine */ int cungbr_(char *vect, integer *m, integer *n, integer *k,
+ complex *a, integer *lda, complex *tau, complex *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int cunghr_(integer *n, integer *ilo, integer *ihi, complex *
+ a, integer *lda, complex *tau, complex *work, integer *lwork, integer
+ *info);
+
+/* Subroutine */ int cungl2_(integer *m, integer *n, integer *k, complex *a,
+ integer *lda, complex *tau, complex *work, integer *info);
+
+/* Subroutine */ int cunglq_(integer *m, integer *n, integer *k, complex *a,
+ integer *lda, complex *tau, complex *work, integer *lwork, integer *
+ info);
+
+/* Subroutine */ int cungql_(integer *m, integer *n, integer *k, complex *a,
+ integer *lda, complex *tau, complex *work, integer *lwork, integer *
+ info);
+
+/* Subroutine */ int cungqr_(integer *m, integer *n, integer *k, complex *a,
+ integer *lda, complex *tau, complex *work, integer *lwork, integer *
+ info);
+
+/* Subroutine */ int cungr2_(integer *m, integer *n, integer *k, complex *a,
+ integer *lda, complex *tau, complex *work, integer *info);
+
+/* Subroutine */ int cungrq_(integer *m, integer *n, integer *k, complex *a,
+ integer *lda, complex *tau, complex *work, integer *lwork, integer *
+ info);
+
+/* Subroutine */ int cungtr_(char *uplo, integer *n, complex *a, integer *lda,
+ complex *tau, complex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int cunm2l_(char *side, char *trans, integer *m, integer *n,
+ integer *k, complex *a, integer *lda, complex *tau, complex *c__,
+ integer *ldc, complex *work, integer *info);
+
+/* Subroutine */ int cunm2r_(char *side, char *trans, integer *m, integer *n,
+ integer *k, complex *a, integer *lda, complex *tau, complex *c__,
+ integer *ldc, complex *work, integer *info);
+
+/* Subroutine */ int cunmbr_(char *vect, char *side, char *trans, integer *m,
+ integer *n, integer *k, complex *a, integer *lda, complex *tau,
+ complex *c__, integer *ldc, complex *work, integer *lwork, integer *
+ info);
+
+/* Subroutine */ int cunmhr_(char *side, char *trans, integer *m, integer *n,
+ integer *ilo, integer *ihi, complex *a, integer *lda, complex *tau,
+ complex *c__, integer *ldc, complex *work, integer *lwork, integer *
+ info);
+
+/* Subroutine */ int cunml2_(char *side, char *trans, integer *m, integer *n,
+ integer *k, complex *a, integer *lda, complex *tau, complex *c__,
+ integer *ldc, complex *work, integer *info);
+
+/* Subroutine */ int cunmlq_(char *side, char *trans, integer *m, integer *n,
+ integer *k, complex *a, integer *lda, complex *tau, complex *c__,
+ integer *ldc, complex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int cunmql_(char *side, char *trans, integer *m, integer *n,
+ integer *k, complex *a, integer *lda, complex *tau, complex *c__,
+ integer *ldc, complex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int cunmqr_(char *side, char *trans, integer *m, integer *n,
+ integer *k, complex *a, integer *lda, complex *tau, complex *c__,
+ integer *ldc, complex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int cunmr2_(char *side, char *trans, integer *m, integer *n,
+ integer *k, complex *a, integer *lda, complex *tau, complex *c__,
+ integer *ldc, complex *work, integer *info);
+
+/* Subroutine */ int cunmr3_(char *side, char *trans, integer *m, integer *n,
+ integer *k, integer *l, complex *a, integer *lda, complex *tau,
+ complex *c__, integer *ldc, complex *work, integer *info);
+
+/* Subroutine */ int cunmrq_(char *side, char *trans, integer *m, integer *n,
+ integer *k, complex *a, integer *lda, complex *tau, complex *c__,
+ integer *ldc, complex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int cunmrz_(char *side, char *trans, integer *m, integer *n,
+ integer *k, integer *l, complex *a, integer *lda, complex *tau,
+ complex *c__, integer *ldc, complex *work, integer *lwork, integer *
+ info);
+
+/* Subroutine */ int cunmtr_(char *side, char *uplo, char *trans, integer *m,
+ integer *n, complex *a, integer *lda, complex *tau, complex *c__,
+ integer *ldc, complex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int cupgtr_(char *uplo, integer *n, complex *ap, complex *
+ tau, complex *q, integer *ldq, complex *work, integer *info);
+
+/* Subroutine */ int cupmtr_(char *side, char *uplo, char *trans, integer *m,
+ integer *n, complex *ap, complex *tau, complex *c__, integer *ldc,
+ complex *work, integer *info);
+
+/* Subroutine */ int dbdsdc_(char *uplo, char *compq, integer *n, doublereal *
+ d__, doublereal *e, doublereal *u, integer *ldu, doublereal *vt,
+ integer *ldvt, doublereal *q, integer *iq, doublereal *work, integer *
+ iwork, integer *info);
+
+/* Subroutine */ int dbdsqr_(char *uplo, integer *n, integer *ncvt, integer *
+ nru, integer *ncc, doublereal *d__, doublereal *e, doublereal *vt,
+ integer *ldvt, doublereal *u, integer *ldu, doublereal *c__, integer *
+ ldc, doublereal *work, integer *info);
+
+/* Subroutine */ int ddisna_(char *job, integer *m, integer *n, doublereal *
+ d__, doublereal *sep, integer *info);
+
+/* Subroutine */ int dgbbrd_(char *vect, integer *m, integer *n, integer *ncc,
+ integer *kl, integer *ku, doublereal *ab, integer *ldab, doublereal *
+ d__, doublereal *e, doublereal *q, integer *ldq, doublereal *pt,
+ integer *ldpt, doublereal *c__, integer *ldc, doublereal *work,
+ integer *info);
+
+/* Subroutine */ int dgbcon_(char *norm, integer *n, integer *kl, integer *ku,
+ doublereal *ab, integer *ldab, integer *ipiv, doublereal *anorm,
+ doublereal *rcond, doublereal *work, integer *iwork, integer *info);
+
+/* Subroutine */ int dgbequ_(integer *m, integer *n, integer *kl, integer *ku,
+ doublereal *ab, integer *ldab, doublereal *r__, doublereal *c__,
+ doublereal *rowcnd, doublereal *colcnd, doublereal *amax, integer *
+ info);
+
+/* Subroutine */ int dgbequb_(integer *m, integer *n, integer *kl, integer *
+ ku, doublereal *ab, integer *ldab, doublereal *r__, doublereal *c__,
+ doublereal *rowcnd, doublereal *colcnd, doublereal *amax, integer *
+ info);
+
+/* Subroutine */ int dgbrfs_(char *trans, integer *n, integer *kl, integer *
+ ku, integer *nrhs, doublereal *ab, integer *ldab, doublereal *afb,
+ integer *ldafb, integer *ipiv, doublereal *b, integer *ldb,
+ doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr,
+ doublereal *work, integer *iwork, integer *info);
+
+/* Subroutine */ int dgbrfsx_(char *trans, char *equed, integer *n, integer *
+ kl, integer *ku, integer *nrhs, doublereal *ab, integer *ldab,
+ doublereal *afb, integer *ldafb, integer *ipiv, doublereal *r__,
+ doublereal *c__, doublereal *b, integer *ldb, doublereal *x, integer *
+ ldx, doublereal *rcond, doublereal *berr, integer *n_err_bnds__,
+ doublereal *err_bnds_norm__, doublereal *err_bnds_comp__, integer *
+ nparams, doublereal *params, doublereal *work, integer *iwork,
+ integer *info);
+
+/* Subroutine */ int dgbsv_(integer *n, integer *kl, integer *ku, integer *
+ nrhs, doublereal *ab, integer *ldab, integer *ipiv, doublereal *b,
+ integer *ldb, integer *info);
+
+/* Subroutine */ int dgbsvx_(char *fact, char *trans, integer *n, integer *kl,
+ integer *ku, integer *nrhs, doublereal *ab, integer *ldab,
+ doublereal *afb, integer *ldafb, integer *ipiv, char *equed,
+ doublereal *r__, doublereal *c__, doublereal *b, integer *ldb,
+ doublereal *x, integer *ldx, doublereal *rcond, doublereal *ferr,
+ doublereal *berr, doublereal *work, integer *iwork, integer *info);
+
+/* Subroutine */ int dgbsvxx_(char *fact, char *trans, integer *n, integer *
+ kl, integer *ku, integer *nrhs, doublereal *ab, integer *ldab,
+ doublereal *afb, integer *ldafb, integer *ipiv, char *equed,
+ doublereal *r__, doublereal *c__, doublereal *b, integer *ldb,
+ doublereal *x, integer *ldx, doublereal *rcond, doublereal *rpvgrw,
+ doublereal *berr, integer *n_err_bnds__, doublereal *err_bnds_norm__,
+ doublereal *err_bnds_comp__, integer *nparams, doublereal *params,
+ doublereal *work, integer *iwork, integer *info);
+
+/* Subroutine */ int dgbtf2_(integer *m, integer *n, integer *kl, integer *ku,
+ doublereal *ab, integer *ldab, integer *ipiv, integer *info);
+
+/* Subroutine */ int dgbtrf_(integer *m, integer *n, integer *kl, integer *ku,
+ doublereal *ab, integer *ldab, integer *ipiv, integer *info);
+
+/* Subroutine */ int dgbtrs_(char *trans, integer *n, integer *kl, integer *
+ ku, integer *nrhs, doublereal *ab, integer *ldab, integer *ipiv,
+ doublereal *b, integer *ldb, integer *info);
+
+/* Subroutine */ int dgebak_(char *job, char *side, integer *n, integer *ilo,
+ integer *ihi, doublereal *scale, integer *m, doublereal *v, integer *
+ ldv, integer *info);
+
+/* Subroutine */ int dgebal_(char *job, integer *n, doublereal *a, integer *
+ lda, integer *ilo, integer *ihi, doublereal *scale, integer *info);
+
+/* Subroutine */ int dgebd2_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *d__, doublereal *e, doublereal *tauq, doublereal *
+ taup, doublereal *work, integer *info);
+
+/* Subroutine */ int dgebrd_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *d__, doublereal *e, doublereal *tauq, doublereal *
+ taup, doublereal *work, integer *lwork, integer *info);
+
+/* Subroutine */ int dgecon_(char *norm, integer *n, doublereal *a, integer *
+ lda, doublereal *anorm, doublereal *rcond, doublereal *work, integer *
+ iwork, integer *info);
+
+/* Subroutine */ int dgeequ_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *r__, doublereal *c__, doublereal *rowcnd, doublereal
+ *colcnd, doublereal *amax, integer *info);
+
+/* Subroutine */ int dgeequb_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *r__, doublereal *c__, doublereal *rowcnd, doublereal
+ *colcnd, doublereal *amax, integer *info);
+
+/* Subroutine */ int dgees_(char *jobvs, char *sort, L_fp select, integer *n,
+ doublereal *a, integer *lda, integer *sdim, doublereal *wr,
+ doublereal *wi, doublereal *vs, integer *ldvs, doublereal *work,
+ integer *lwork, logical *bwork, integer *info);
+
+/* Subroutine */ int dgeesx_(char *jobvs, char *sort, L_fp select, char *
+ sense, integer *n, doublereal *a, integer *lda, integer *sdim,
+ doublereal *wr, doublereal *wi, doublereal *vs, integer *ldvs,
+ doublereal *rconde, doublereal *rcondv, doublereal *work, integer *
+ lwork, integer *iwork, integer *liwork, logical *bwork, integer *info);
+
+/* Subroutine */ int dgeev_(char *jobvl, char *jobvr, integer *n, doublereal *
+ a, integer *lda, doublereal *wr, doublereal *wi, doublereal *vl,
+ integer *ldvl, doublereal *vr, integer *ldvr, doublereal *work,
+ integer *lwork, integer *info);
+
+/* Subroutine */ int dgeevx_(char *balanc, char *jobvl, char *jobvr, char *
+ sense, integer *n, doublereal *a, integer *lda, doublereal *wr,
+ doublereal *wi, doublereal *vl, integer *ldvl, doublereal *vr,
+ integer *ldvr, integer *ilo, integer *ihi, doublereal *scale,
+ doublereal *abnrm, doublereal *rconde, doublereal *rcondv, doublereal
+ *work, integer *lwork, integer *iwork, integer *info);
+
+/* Subroutine */ int dgegs_(char *jobvsl, char *jobvsr, integer *n,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
+ alphar, doublereal *alphai, doublereal *beta, doublereal *vsl,
+ integer *ldvsl, doublereal *vsr, integer *ldvsr, doublereal *work,
+ integer *lwork, integer *info);
+
+/* Subroutine */ int dgegv_(char *jobvl, char *jobvr, integer *n, doublereal *
+ a, integer *lda, doublereal *b, integer *ldb, doublereal *alphar,
+ doublereal *alphai, doublereal *beta, doublereal *vl, integer *ldvl,
+ doublereal *vr, integer *ldvr, doublereal *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int dgehd2_(integer *n, integer *ilo, integer *ihi,
+ doublereal *a, integer *lda, doublereal *tau, doublereal *work,
+ integer *info);
+
+/* Subroutine */ int dgehrd_(integer *n, integer *ilo, integer *ihi,
+ doublereal *a, integer *lda, doublereal *tau, doublereal *work,
+ integer *lwork, integer *info);
+
+/* Subroutine */ int dgejsv_(char *joba, char *jobu, char *jobv, char *jobr,
+ char *jobt, char *jobp, integer *m, integer *n, doublereal *a,
+ integer *lda, doublereal *sva, doublereal *u, integer *ldu,
+ doublereal *v, integer *ldv, doublereal *work, integer *lwork,
+ integer *iwork, integer *info);
+
+/* Subroutine */ int dgelq2_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *tau, doublereal *work, integer *info);
+
+/* Subroutine */ int dgelqf_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);
+
+/* Subroutine */ int dgels_(char *trans, integer *m, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb,
+ doublereal *work, integer *lwork, integer *info);
+
+/* Subroutine */ int dgelsd_(integer *m, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
+ s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork,
+ integer *iwork, integer *info);
+
+/* Subroutine */ int dgelss_(integer *m, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
+ s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int dgelsx_(integer *m, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *
+ jpvt, doublereal *rcond, integer *rank, doublereal *work, integer *
+ info);
+
+/* Subroutine */ int dgelsy_(integer *m, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *
+ jpvt, doublereal *rcond, integer *rank, doublereal *work, integer *
+ lwork, integer *info);
+
+/* Subroutine */ int dgeql2_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *tau, doublereal *work, integer *info);
+
+/* Subroutine */ int dgeqlf_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);
+
+/* Subroutine */ int dgeqp3_(integer *m, integer *n, doublereal *a, integer *
+ lda, integer *jpvt, doublereal *tau, doublereal *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int dgeqpf_(integer *m, integer *n, doublereal *a, integer *
+ lda, integer *jpvt, doublereal *tau, doublereal *work, integer *info);
+
+/* Subroutine */ int dgeqr2_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *tau, doublereal *work, integer *info);
+
+/* Subroutine */ int dgeqrf_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);
+
+/* Subroutine */ int dgerfs_(char *trans, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *
+ ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx,
+ doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork,
+ integer *info);
+
+/* Subroutine */ int dgerfsx_(char *trans, char *equed, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
+ integer *ipiv, doublereal *r__, doublereal *c__, doublereal *b,
+ integer *ldb, doublereal *x, integer *ldx, doublereal *rcond,
+ doublereal *berr, integer *n_err_bnds__, doublereal *err_bnds_norm__,
+ doublereal *err_bnds_comp__, integer *nparams, doublereal *params,
+ doublereal *work, integer *iwork, integer *info);
+
+/* Subroutine */ int dgerq2_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *tau, doublereal *work, integer *info);
+
+/* Subroutine */ int dgerqf_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);
+
+/* Subroutine */ int dgesc2_(integer *n, doublereal *a, integer *lda,
+ doublereal *rhs, integer *ipiv, integer *jpiv, doublereal *scale);
+
+/* Subroutine */ int dgesdd_(char *jobz, integer *m, integer *n, doublereal *
+ a, integer *lda, doublereal *s, doublereal *u, integer *ldu,
+ doublereal *vt, integer *ldvt, doublereal *work, integer *lwork,
+ integer *iwork, integer *info);
+
+/* Subroutine */ int dgesv_(integer *n, integer *nrhs, doublereal *a, integer
+ *lda, integer *ipiv, doublereal *b, integer *ldb, integer *info);
+
+/* Subroutine */ int dgesvd_(char *jobu, char *jobvt, integer *m, integer *n,
+ doublereal *a, integer *lda, doublereal *s, doublereal *u, integer *
+ ldu, doublereal *vt, integer *ldvt, doublereal *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int dgesvj_(char *joba, char *jobu, char *jobv, integer *m,
+ integer *n, doublereal *a, integer *lda, doublereal *sva, integer *mv,
+ doublereal *v, integer *ldv, doublereal *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int dgesvx_(char *fact, char *trans, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
+ integer *ipiv, char *equed, doublereal *r__, doublereal *c__,
+ doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
+ rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *
+ iwork, integer *info);
+
+/* Subroutine */ int dgesvxx_(char *fact, char *trans, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
+ integer *ipiv, char *equed, doublereal *r__, doublereal *c__,
+ doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
+ rcond, doublereal *rpvgrw, doublereal *berr, integer *n_err_bnds__,
+ doublereal *err_bnds_norm__, doublereal *err_bnds_comp__, integer *
+ nparams, doublereal *params, doublereal *work, integer *iwork,
+ integer *info);
+
+/* Subroutine */ int dgetc2_(integer *n, doublereal *a, integer *lda, integer
+ *ipiv, integer *jpiv, integer *info);
+
+/* Subroutine */ int dgetf2_(integer *m, integer *n, doublereal *a, integer *
+ lda, integer *ipiv, integer *info);
+
+/* Subroutine */ int dgetrf_(integer *m, integer *n, doublereal *a, integer *
+ lda, integer *ipiv, integer *info);
+
+/* Subroutine */ int dgetri_(integer *n, doublereal *a, integer *lda, integer
+ *ipiv, doublereal *work, integer *lwork, integer *info);
+
+/* Subroutine */ int dgetrs_(char *trans, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer *
+ ldb, integer *info);
+
+/* Subroutine */ int dggbak_(char *job, char *side, integer *n, integer *ilo,
+ integer *ihi, doublereal *lscale, doublereal *rscale, integer *m,
+ doublereal *v, integer *ldv, integer *info);
+
+/* Subroutine */ int dggbal_(char *job, integer *n, doublereal *a, integer *
+ lda, doublereal *b, integer *ldb, integer *ilo, integer *ihi,
+ doublereal *lscale, doublereal *rscale, doublereal *work, integer *
+ info);
+
+/* Subroutine */ int dgges_(char *jobvsl, char *jobvsr, char *sort, L_fp
+ selctg, integer *n, doublereal *a, integer *lda, doublereal *b,
+ integer *ldb, integer *sdim, doublereal *alphar, doublereal *alphai,
+ doublereal *beta, doublereal *vsl, integer *ldvsl, doublereal *vsr,
+ integer *ldvsr, doublereal *work, integer *lwork, logical *bwork,
+ integer *info);
+
+/* Subroutine */ int dggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp
+ selctg, char *sense, integer *n, doublereal *a, integer *lda,
+ doublereal *b, integer *ldb, integer *sdim, doublereal *alphar,
+ doublereal *alphai, doublereal *beta, doublereal *vsl, integer *ldvsl,
+ doublereal *vsr, integer *ldvsr, doublereal *rconde, doublereal *
+ rcondv, doublereal *work, integer *lwork, integer *iwork, integer *
+ liwork, logical *bwork, integer *info);
+
+/* Subroutine */ int dggev_(char *jobvl, char *jobvr, integer *n, doublereal *
+ a, integer *lda, doublereal *b, integer *ldb, doublereal *alphar,
+ doublereal *alphai, doublereal *beta, doublereal *vl, integer *ldvl,
+ doublereal *vr, integer *ldvr, doublereal *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int dggevx_(char *balanc, char *jobvl, char *jobvr, char *
+ sense, integer *n, doublereal *a, integer *lda, doublereal *b,
+ integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *
+ beta, doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr,
+ integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale,
+ doublereal *abnrm, doublereal *bbnrm, doublereal *rconde, doublereal *
+ rcondv, doublereal *work, integer *lwork, integer *iwork, logical *
+ bwork, integer *info);
+
+/* Subroutine */ int dggglm_(integer *n, integer *m, integer *p, doublereal *
+ a, integer *lda, doublereal *b, integer *ldb, doublereal *d__,
+ doublereal *x, doublereal *y, doublereal *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int dgghrd_(char *compq, char *compz, integer *n, integer *
+ ilo, integer *ihi, doublereal *a, integer *lda, doublereal *b,
+ integer *ldb, doublereal *q, integer *ldq, doublereal *z__, integer *
+ ldz, integer *info);
+
+/* Subroutine */ int dgglse_(integer *m, integer *n, integer *p, doublereal *
+ a, integer *lda, doublereal *b, integer *ldb, doublereal *c__,
+ doublereal *d__, doublereal *x, doublereal *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int dggqrf_(integer *n, integer *m, integer *p, doublereal *
+ a, integer *lda, doublereal *taua, doublereal *b, integer *ldb,
+ doublereal *taub, doublereal *work, integer *lwork, integer *info);
+
+/* Subroutine */ int dggrqf_(integer *m, integer *p, integer *n, doublereal *
+ a, integer *lda, doublereal *taua, doublereal *b, integer *ldb,
+ doublereal *taub, doublereal *work, integer *lwork, integer *info);
+
+/* Subroutine */ int dggsvd_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *n, integer *p, integer *k, integer *l, doublereal *a,
+ integer *lda, doublereal *b, integer *ldb, doublereal *alpha,
+ doublereal *beta, doublereal *u, integer *ldu, doublereal *v, integer
+ *ldv, doublereal *q, integer *ldq, doublereal *work, integer *iwork,
+ integer *info);
+
+/* Subroutine */ int dggsvp_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *p, integer *n, doublereal *a, integer *lda, doublereal *b,
+ integer *ldb, doublereal *tola, doublereal *tolb, integer *k, integer
+ *l, doublereal *u, integer *ldu, doublereal *v, integer *ldv,
+ doublereal *q, integer *ldq, integer *iwork, doublereal *tau,
+ doublereal *work, integer *info);
+
+/* Subroutine */ int dgsvj0_(char *jobv, integer *m, integer *n, doublereal *
+ a, integer *lda, doublereal *d__, doublereal *sva, integer *mv,
+ doublereal *v, integer *ldv, doublereal *eps, doublereal *sfmin,
+ doublereal *tol, integer *nsweep, doublereal *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int dgsvj1_(char *jobv, integer *m, integer *n, integer *n1,
+ doublereal *a, integer *lda, doublereal *d__, doublereal *sva,
+ integer *mv, doublereal *v, integer *ldv, doublereal *eps, doublereal
+ *sfmin, doublereal *tol, integer *nsweep, doublereal *work, integer *
+ lwork, integer *info);
+
+/* Subroutine */ int dgtcon_(char *norm, integer *n, doublereal *dl,
+ doublereal *d__, doublereal *du, doublereal *du2, integer *ipiv,
+ doublereal *anorm, doublereal *rcond, doublereal *work, integer *
+ iwork, integer *info);
+
+/* Subroutine */ int dgtrfs_(char *trans, integer *n, integer *nrhs,
+ doublereal *dl, doublereal *d__, doublereal *du, doublereal *dlf,
+ doublereal *df, doublereal *duf, doublereal *du2, integer *ipiv,
+ doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
+ ferr, doublereal *berr, doublereal *work, integer *iwork, integer *
+ info);
+
+/* Subroutine */ int dgtsv_(integer *n, integer *nrhs, doublereal *dl,
+ doublereal *d__, doublereal *du, doublereal *b, integer *ldb, integer
+ *info);
+
+/* Subroutine */ int dgtsvx_(char *fact, char *trans, integer *n, integer *
+ nrhs, doublereal *dl, doublereal *d__, doublereal *du, doublereal *
+ dlf, doublereal *df, doublereal *duf, doublereal *du2, integer *ipiv,
+ doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
+ rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *
+ iwork, integer *info);
+
+/* Subroutine */ int dgttrf_(integer *n, doublereal *dl, doublereal *d__,
+ doublereal *du, doublereal *du2, integer *ipiv, integer *info);
+
+/* Subroutine */ int dgttrs_(char *trans, integer *n, integer *nrhs,
+ doublereal *dl, doublereal *d__, doublereal *du, doublereal *du2,
+ integer *ipiv, doublereal *b, integer *ldb, integer *info);
+
+/* Subroutine */ int dgtts2_(integer *itrans, integer *n, integer *nrhs,
+ doublereal *dl, doublereal *d__, doublereal *du, doublereal *du2,
+ integer *ipiv, doublereal *b, integer *ldb);
+
+/* Subroutine */ int dhgeqz_(char *job, char *compq, char *compz, integer *n,
+ integer *ilo, integer *ihi, doublereal *h__, integer *ldh, doublereal
+ *t, integer *ldt, doublereal *alphar, doublereal *alphai, doublereal *
+ beta, doublereal *q, integer *ldq, doublereal *z__, integer *ldz,
+ doublereal *work, integer *lwork, integer *info);
+
+/* Subroutine */ int dhsein_(char *side, char *eigsrc, char *initv, logical *
+ select, integer *n, doublereal *h__, integer *ldh, doublereal *wr,
+ doublereal *wi, doublereal *vl, integer *ldvl, doublereal *vr,
+ integer *ldvr, integer *mm, integer *m, doublereal *work, integer *
+ ifaill, integer *ifailr, integer *info);
+
+/* Subroutine */ int dhseqr_(char *job, char *compz, integer *n, integer *ilo,
+ integer *ihi, doublereal *h__, integer *ldh, doublereal *wr,
+ doublereal *wi, doublereal *z__, integer *ldz, doublereal *work,
+ integer *lwork, integer *info);
+
+logical disnan_(doublereal *din);
+
+/* Subroutine */ int dla_gbamv__(integer *trans, integer *m, integer *n,
+ integer *kl, integer *ku, doublereal *alpha, doublereal *ab, integer *
+ ldab, doublereal *x, integer *incx, doublereal *beta, doublereal *y,
+ integer *incy);
+
+doublereal dla_gbrcond__(char *trans, integer *n, integer *kl, integer *ku,
+ doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb,
+ integer *ipiv, integer *cmode, doublereal *c__, integer *info,
+ doublereal *work, integer *iwork, ftnlen trans_len);
+
+/* Subroutine */ int dla_gbrfsx_extended__(integer *prec_type__, integer *
+ trans_type__, integer *n, integer *kl, integer *ku, integer *nrhs,
+ doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb,
+ integer *ipiv, logical *colequ, doublereal *c__, doublereal *b,
+ integer *ldb, doublereal *y, integer *ldy, doublereal *berr_out__,
+ integer *n_norms__, doublereal *errs_n__, doublereal *errs_c__,
+ doublereal *res, doublereal *ayb, doublereal *dy, doublereal *
+ y_tail__, doublereal *rcond, integer *ithresh, doublereal *rthresh,
+ doublereal *dz_ub__, logical *ignore_cwise__, integer *info);
+
+doublereal dla_gbrpvgrw__(integer *n, integer *kl, integer *ku, integer *
+ ncols, doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb);
+
+/* Subroutine */ int dla_geamv__(integer *trans, integer *m, integer *n,
+ doublereal *alpha, doublereal *a, integer *lda, doublereal *x,
+ integer *incx, doublereal *beta, doublereal *y, integer *incy);
+
+doublereal dla_gercond__(char *trans, integer *n, doublereal *a, integer *lda,
+ doublereal *af, integer *ldaf, integer *ipiv, integer *cmode,
+ doublereal *c__, integer *info, doublereal *work, integer *iwork,
+ ftnlen trans_len);
+
+/* Subroutine */ int dla_gerfsx_extended__(integer *prec_type__, integer *
+ trans_type__, integer *n, integer *nrhs, doublereal *a, integer *lda,
+ doublereal *af, integer *ldaf, integer *ipiv, logical *colequ,
+ doublereal *c__, doublereal *b, integer *ldb, doublereal *y, integer *
+ ldy, doublereal *berr_out__, integer *n_norms__, doublereal *errs_n__,
+ doublereal *errs_c__, doublereal *res, doublereal *ayb, doublereal *
+ dy, doublereal *y_tail__, doublereal *rcond, integer *ithresh,
+ doublereal *rthresh, doublereal *dz_ub__, logical *ignore_cwise__,
+ integer *info);
+
+/* Subroutine */ int dla_lin_berr__(integer *n, integer *nz, integer *nrhs,
+ doublereal *res, doublereal *ayb, doublereal *berr);
+
+doublereal dla_porcond__(char *uplo, integer *n, doublereal *a, integer *lda,
+ doublereal *af, integer *ldaf, integer *cmode, doublereal *c__,
+ integer *info, doublereal *work, integer *iwork, ftnlen uplo_len);
+
+/* Subroutine */ int dla_porfsx_extended__(integer *prec_type__, char *uplo,
+ integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *
+ af, integer *ldaf, logical *colequ, doublereal *c__, doublereal *b,
+ integer *ldb, doublereal *y, integer *ldy, doublereal *berr_out__,
+ integer *n_norms__, doublereal *errs_n__, doublereal *errs_c__,
+ doublereal *res, doublereal *ayb, doublereal *dy, doublereal *
+ y_tail__, doublereal *rcond, integer *ithresh, doublereal *rthresh,
+ doublereal *dz_ub__, logical *ignore_cwise__, integer *info, ftnlen
+ uplo_len);
+
+doublereal dla_porpvgrw__(char *uplo, integer *ncols, doublereal *a, integer *
+ lda, doublereal *af, integer *ldaf, doublereal *work, ftnlen uplo_len);
+
+doublereal dla_rpvgrw__(integer *n, integer *ncols, doublereal *a, integer *
+ lda, doublereal *af, integer *ldaf);
+
+/* Subroutine */ int dla_syamv__(integer *uplo, integer *n, doublereal *alpha,
+ doublereal *a, integer *lda, doublereal *x, integer *incx,
+ doublereal *beta, doublereal *y, integer *incy);
+
+doublereal dla_syrcond__(char *uplo, integer *n, doublereal *a, integer *lda,
+ doublereal *af, integer *ldaf, integer *ipiv, integer *cmode,
+ doublereal *c__, integer *info, doublereal *work, integer *iwork,
+ ftnlen uplo_len);
+
+/* Subroutine */ int dla_syrfsx_extended__(integer *prec_type__, char *uplo,
+ integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *
+ af, integer *ldaf, integer *ipiv, logical *colequ, doublereal *c__,
+ doublereal *b, integer *ldb, doublereal *y, integer *ldy, doublereal *
+ berr_out__, integer *n_norms__, doublereal *errs_n__, doublereal *
+ errs_c__, doublereal *res, doublereal *ayb, doublereal *dy,
+ doublereal *y_tail__, doublereal *rcond, integer *ithresh, doublereal
+ *rthresh, doublereal *dz_ub__, logical *ignore_cwise__, integer *info,
+ ftnlen uplo_len);
+
+doublereal dla_syrpvgrw__(char *uplo, integer *n, integer *info, doublereal *
+ a, integer *lda, doublereal *af, integer *ldaf, integer *ipiv,
+ doublereal *work, ftnlen uplo_len);
+
+/* Subroutine */ int dla_wwaddw__(integer *n, doublereal *x, doublereal *y,
+ doublereal *w);
+
+/* Subroutine */ int dlabad_(doublereal *small, doublereal *large);
+
+/* Subroutine */ int dlabrd_(integer *m, integer *n, integer *nb, doublereal *
+ a, integer *lda, doublereal *d__, doublereal *e, doublereal *tauq,
+ doublereal *taup, doublereal *x, integer *ldx, doublereal *y, integer
+ *ldy);
+
+/* Subroutine */ int dlacn2_(integer *n, doublereal *v, doublereal *x,
+ integer *isgn, doublereal *est, integer *kase, integer *isave);
+
+/* Subroutine */ int dlacon_(integer *n, doublereal *v, doublereal *x,
+ integer *isgn, doublereal *est, integer *kase);
+
+/* Subroutine */ int dlacpy_(char *uplo, integer *m, integer *n, doublereal *
+ a, integer *lda, doublereal *b, integer *ldb);
+
+/* Subroutine */ int dladiv_(doublereal *a, doublereal *b, doublereal *c__,
+ doublereal *d__, doublereal *p, doublereal *q);
+
+/* Subroutine */ int dlae2_(doublereal *a, doublereal *b, doublereal *c__,
+ doublereal *rt1, doublereal *rt2);
+
+/* Subroutine */ int dlaebz_(integer *ijob, integer *nitmax, integer *n,
+ integer *mmax, integer *minp, integer *nbmin, doublereal *abstol,
+ doublereal *reltol, doublereal *pivmin, doublereal *d__, doublereal *
+ e, doublereal *e2, integer *nval, doublereal *ab, doublereal *c__,
+ integer *mout, integer *nab, doublereal *work, integer *iwork,
+ integer *info);
+
+/* Subroutine */ int dlaed0_(integer *icompq, integer *qsiz, integer *n,
+ doublereal *d__, doublereal *e, doublereal *q, integer *ldq,
+ doublereal *qstore, integer *ldqs, doublereal *work, integer *iwork,
+ integer *info);
+
+/* Subroutine */ int dlaed1_(integer *n, doublereal *d__, doublereal *q,
+ integer *ldq, integer *indxq, doublereal *rho, integer *cutpnt,
+ doublereal *work, integer *iwork, integer *info);
+
+/* Subroutine */ int dlaed2_(integer *k, integer *n, integer *n1, doublereal *
+ d__, doublereal *q, integer *ldq, integer *indxq, doublereal *rho,
+ doublereal *z__, doublereal *dlamda, doublereal *w, doublereal *q2,
+ integer *indx, integer *indxc, integer *indxp, integer *coltyp,
+ integer *info);
+
+/* Subroutine */ int dlaed3_(integer *k, integer *n, integer *n1, doublereal *
+ d__, doublereal *q, integer *ldq, doublereal *rho, doublereal *dlamda,
+ doublereal *q2, integer *indx, integer *ctot, doublereal *w,
+ doublereal *s, integer *info);
+
+/* Subroutine */ int dlaed4_(integer *n, integer *i__, doublereal *d__,
+ doublereal *z__, doublereal *delta, doublereal *rho, doublereal *dlam,
+ integer *info);
+
+/* Subroutine */ int dlaed5_(integer *i__, doublereal *d__, doublereal *z__,
+ doublereal *delta, doublereal *rho, doublereal *dlam);
+
+/* Subroutine */ int dlaed6_(integer *kniter, logical *orgati, doublereal *
+ rho, doublereal *d__, doublereal *z__, doublereal *finit, doublereal *
+ tau, integer *info);
+
+/* Subroutine */ int dlaed7_(integer *icompq, integer *n, integer *qsiz,
+ integer *tlvls, integer *curlvl, integer *curpbm, doublereal *d__,
+ doublereal *q, integer *ldq, integer *indxq, doublereal *rho, integer
+ *cutpnt, doublereal *qstore, integer *qptr, integer *prmptr, integer *
+ perm, integer *givptr, integer *givcol, doublereal *givnum,
+ doublereal *work, integer *iwork, integer *info);
+
+/* Subroutine */ int dlaed8_(integer *icompq, integer *k, integer *n, integer
+ *qsiz, doublereal *d__, doublereal *q, integer *ldq, integer *indxq,
+ doublereal *rho, integer *cutpnt, doublereal *z__, doublereal *dlamda,
+ doublereal *q2, integer *ldq2, doublereal *w, integer *perm, integer
+ *givptr, integer *givcol, doublereal *givnum, integer *indxp, integer
+ *indx, integer *info);
+
+/* Subroutine */ int dlaed9_(integer *k, integer *kstart, integer *kstop,
+ integer *n, doublereal *d__, doublereal *q, integer *ldq, doublereal *
+ rho, doublereal *dlamda, doublereal *w, doublereal *s, integer *lds,
+ integer *info);
+
+/* Subroutine */ int dlaeda_(integer *n, integer *tlvls, integer *curlvl,
+ integer *curpbm, integer *prmptr, integer *perm, integer *givptr,
+ integer *givcol, doublereal *givnum, doublereal *q, integer *qptr,
+ doublereal *z__, doublereal *ztemp, integer *info);
+
+/* Subroutine */ int dlaein_(logical *rightv, logical *noinit, integer *n,
+ doublereal *h__, integer *ldh, doublereal *wr, doublereal *wi,
+ doublereal *vr, doublereal *vi, doublereal *b, integer *ldb,
+ doublereal *work, doublereal *eps3, doublereal *smlnum, doublereal *
+ bignum, integer *info);
+
+/* Subroutine */ int dlaev2_(doublereal *a, doublereal *b, doublereal *c__,
+ doublereal *rt1, doublereal *rt2, doublereal *cs1, doublereal *sn1);
+
+/* Subroutine */ int dlaexc_(logical *wantq, integer *n, doublereal *t,
+ integer *ldt, doublereal *q, integer *ldq, integer *j1, integer *n1,
+ integer *n2, doublereal *work, integer *info);
+
+/* Subroutine */ int dlag2_(doublereal *a, integer *lda, doublereal *b,
+ integer *ldb, doublereal *safmin, doublereal *scale1, doublereal *
+ scale2, doublereal *wr1, doublereal *wr2, doublereal *wi);
+
+/* Subroutine */ int dlag2s_(integer *m, integer *n, doublereal *a, integer *
+ lda, real *sa, integer *ldsa, integer *info);
+
+/* Subroutine */ int dlags2_(logical *upper, doublereal *a1, doublereal *a2,
+ doublereal *a3, doublereal *b1, doublereal *b2, doublereal *b3,
+ doublereal *csu, doublereal *snu, doublereal *csv, doublereal *snv,
+ doublereal *csq, doublereal *snq);
+
+/* Subroutine */ int dlagtf_(integer *n, doublereal *a, doublereal *lambda,
+ doublereal *b, doublereal *c__, doublereal *tol, doublereal *d__,
+ integer *in, integer *info);
+
+/* Subroutine */ int dlagtm_(char *trans, integer *n, integer *nrhs,
+ doublereal *alpha, doublereal *dl, doublereal *d__, doublereal *du,
+ doublereal *x, integer *ldx, doublereal *beta, doublereal *b, integer
+ *ldb);
+
+/* Subroutine */ int dlagts_(integer *job, integer *n, doublereal *a,
+ doublereal *b, doublereal *c__, doublereal *d__, integer *in,
+ doublereal *y, doublereal *tol, integer *info);
+
+/* Subroutine */ int dlagv2_(doublereal *a, integer *lda, doublereal *b,
+ integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *
+ beta, doublereal *csl, doublereal *snl, doublereal *csr, doublereal *
+ snr);
+
+/* Subroutine */ int dlahqr_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, doublereal *h__, integer *ldh, doublereal
+ *wr, doublereal *wi, integer *iloz, integer *ihiz, doublereal *z__,
+ integer *ldz, integer *info);
+
+/* Subroutine */ int dlahr2_(integer *n, integer *k, integer *nb, doublereal *
+ a, integer *lda, doublereal *tau, doublereal *t, integer *ldt,
+ doublereal *y, integer *ldy);
+
+/* Subroutine */ int dlahrd_(integer *n, integer *k, integer *nb, doublereal *
+ a, integer *lda, doublereal *tau, doublereal *t, integer *ldt,
+ doublereal *y, integer *ldy);
+
+/* Subroutine */ int dlaic1_(integer *job, integer *j, doublereal *x,
+ doublereal *sest, doublereal *w, doublereal *gamma, doublereal *
+ sestpr, doublereal *s, doublereal *c__);
+
+logical dlaisnan_(doublereal *din1, doublereal *din2);
+
+/* Subroutine */ int dlaln2_(logical *ltrans, integer *na, integer *nw,
+ doublereal *smin, doublereal *ca, doublereal *a, integer *lda,
+ doublereal *d1, doublereal *d2, doublereal *b, integer *ldb,
+ doublereal *wr, doublereal *wi, doublereal *x, integer *ldx,
+ doublereal *scale, doublereal *xnorm, integer *info);
+
+/* Subroutine */ int dlals0_(integer *icompq, integer *nl, integer *nr,
+ integer *sqre, integer *nrhs, doublereal *b, integer *ldb, doublereal
+ *bx, integer *ldbx, integer *perm, integer *givptr, integer *givcol,
+ integer *ldgcol, doublereal *givnum, integer *ldgnum, doublereal *
+ poles, doublereal *difl, doublereal *difr, doublereal *z__, integer *
+ k, doublereal *c__, doublereal *s, doublereal *work, integer *info);
+
+/* Subroutine */ int dlalsa_(integer *icompq, integer *smlsiz, integer *n,
+ integer *nrhs, doublereal *b, integer *ldb, doublereal *bx, integer *
+ ldbx, doublereal *u, integer *ldu, doublereal *vt, integer *k,
+ doublereal *difl, doublereal *difr, doublereal *z__, doublereal *
+ poles, integer *givptr, integer *givcol, integer *ldgcol, integer *
+ perm, doublereal *givnum, doublereal *c__, doublereal *s, doublereal *
+ work, integer *iwork, integer *info);
+
+/* Subroutine */ int dlalsd_(char *uplo, integer *smlsiz, integer *n, integer
+ *nrhs, doublereal *d__, doublereal *e, doublereal *b, integer *ldb,
+ doublereal *rcond, integer *rank, doublereal *work, integer *iwork,
+ integer *info);
+
+/* Subroutine */ int dlamrg_(integer *n1, integer *n2, doublereal *a, integer
+ *dtrd1, integer *dtrd2, integer *index);
+
+integer dlaneg_(integer *n, doublereal *d__, doublereal *lld, doublereal *
+ sigma, doublereal *pivmin, integer *r__);
+
+doublereal dlangb_(char *norm, integer *n, integer *kl, integer *ku,
+ doublereal *ab, integer *ldab, doublereal *work);
+
+doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer
+ *lda, doublereal *work);
+
+doublereal dlangt_(char *norm, integer *n, doublereal *dl, doublereal *d__,
+ doublereal *du);
+
+doublereal dlanhs_(char *norm, integer *n, doublereal *a, integer *lda,
+ doublereal *work);
+
+doublereal dlansb_(char *norm, char *uplo, integer *n, integer *k, doublereal
+ *ab, integer *ldab, doublereal *work);
+
+doublereal dlansf_(char *norm, char *transr, char *uplo, integer *n,
+ doublereal *a, doublereal *work);
+
+doublereal dlansp_(char *norm, char *uplo, integer *n, doublereal *ap,
+ doublereal *work);
+
+doublereal dlanst_(char *norm, integer *n, doublereal *d__, doublereal *e);
+
+doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer
+ *lda, doublereal *work);
+
+doublereal dlantb_(char *norm, char *uplo, char *diag, integer *n, integer *k,
+ doublereal *ab, integer *ldab, doublereal *work);
+
+doublereal dlantp_(char *norm, char *uplo, char *diag, integer *n, doublereal
+ *ap, doublereal *work);
+
+doublereal dlantr_(char *norm, char *uplo, char *diag, integer *m, integer *n,
+ doublereal *a, integer *lda, doublereal *work);
+
+/* Subroutine */ int dlanv2_(doublereal *a, doublereal *b, doublereal *c__,
+ doublereal *d__, doublereal *rt1r, doublereal *rt1i, doublereal *rt2r,
+ doublereal *rt2i, doublereal *cs, doublereal *sn);
+
+/* Subroutine */ int dlapll_(integer *n, doublereal *x, integer *incx,
+ doublereal *y, integer *incy, doublereal *ssmin);
+
+/* Subroutine */ int dlapmt_(logical *forwrd, integer *m, integer *n,
+ doublereal *x, integer *ldx, integer *k);
+
+doublereal dlapy2_(doublereal *x, doublereal *y);
+
+doublereal dlapy3_(doublereal *x, doublereal *y, doublereal *z__);
+
+/* Subroutine */ int dlaqgb_(integer *m, integer *n, integer *kl, integer *ku,
+ doublereal *ab, integer *ldab, doublereal *r__, doublereal *c__,
+ doublereal *rowcnd, doublereal *colcnd, doublereal *amax, char *equed);
+
+/* Subroutine */ int dlaqge_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *r__, doublereal *c__, doublereal *rowcnd, doublereal
+ *colcnd, doublereal *amax, char *equed);
+
+/* Subroutine */ int dlaqp2_(integer *m, integer *n, integer *offset,
+ doublereal *a, integer *lda, integer *jpvt, doublereal *tau,
+ doublereal *vn1, doublereal *vn2, doublereal *work);
+
+/* Subroutine */ int dlaqps_(integer *m, integer *n, integer *offset, integer
+ *nb, integer *kb, doublereal *a, integer *lda, integer *jpvt,
+ doublereal *tau, doublereal *vn1, doublereal *vn2, doublereal *auxv,
+ doublereal *f, integer *ldf);
+
+/* Subroutine */ int dlaqr0_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, doublereal *h__, integer *ldh, doublereal
+ *wr, doublereal *wi, integer *iloz, integer *ihiz, doublereal *z__,
+ integer *ldz, doublereal *work, integer *lwork, integer *info);
+
+/* Subroutine */ int dlaqr1_(integer *n, doublereal *h__, integer *ldh,
+ doublereal *sr1, doublereal *si1, doublereal *sr2, doublereal *si2,
+ doublereal *v);
+
+/* Subroutine */ int dlaqr2_(logical *wantt, logical *wantz, integer *n,
+ integer *ktop, integer *kbot, integer *nw, doublereal *h__, integer *
+ ldh, integer *iloz, integer *ihiz, doublereal *z__, integer *ldz,
+ integer *ns, integer *nd, doublereal *sr, doublereal *si, doublereal *
+ v, integer *ldv, integer *nh, doublereal *t, integer *ldt, integer *
+ nv, doublereal *wv, integer *ldwv, doublereal *work, integer *lwork);
+
+/* Subroutine */ int dlaqr3_(logical *wantt, logical *wantz, integer *n,
+ integer *ktop, integer *kbot, integer *nw, doublereal *h__, integer *
+ ldh, integer *iloz, integer *ihiz, doublereal *z__, integer *ldz,
+ integer *ns, integer *nd, doublereal *sr, doublereal *si, doublereal *
+ v, integer *ldv, integer *nh, doublereal *t, integer *ldt, integer *
+ nv, doublereal *wv, integer *ldwv, doublereal *work, integer *lwork);
+
+/* Subroutine */ int dlaqr4_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, doublereal *h__, integer *ldh, doublereal
+ *wr, doublereal *wi, integer *iloz, integer *ihiz, doublereal *z__,
+ integer *ldz, doublereal *work, integer *lwork, integer *info);
+
+/* Subroutine */ int dlaqr5_(logical *wantt, logical *wantz, integer *kacc22,
+ integer *n, integer *ktop, integer *kbot, integer *nshfts, doublereal
+ *sr, doublereal *si, doublereal *h__, integer *ldh, integer *iloz,
+ integer *ihiz, doublereal *z__, integer *ldz, doublereal *v, integer *
+ ldv, doublereal *u, integer *ldu, integer *nv, doublereal *wv,
+ integer *ldwv, integer *nh, doublereal *wh, integer *ldwh);
+
+/* Subroutine */ int dlaqsb_(char *uplo, integer *n, integer *kd, doublereal *
+ ab, integer *ldab, doublereal *s, doublereal *scond, doublereal *amax,
+ char *equed);
+
+/* Subroutine */ int dlaqsp_(char *uplo, integer *n, doublereal *ap,
+ doublereal *s, doublereal *scond, doublereal *amax, char *equed);
+
+/* Subroutine */ int dlaqsy_(char *uplo, integer *n, doublereal *a, integer *
+ lda, doublereal *s, doublereal *scond, doublereal *amax, char *equed);
+
+/* Subroutine */ int dlaqtr_(logical *ltran, logical *lreal, integer *n,
+ doublereal *t, integer *ldt, doublereal *b, doublereal *w, doublereal
+ *scale, doublereal *x, doublereal *work, integer *info);
+
+/* Subroutine */ int dlar1v_(integer *n, integer *b1, integer *bn, doublereal
+ *lambda, doublereal *d__, doublereal *l, doublereal *ld, doublereal *
+ lld, doublereal *pivmin, doublereal *gaptol, doublereal *z__, logical
+ *wantnc, integer *negcnt, doublereal *ztz, doublereal *mingma,
+ integer *r__, integer *isuppz, doublereal *nrminv, doublereal *resid,
+ doublereal *rqcorr, doublereal *work);
+
+/* Subroutine */ int dlar2v_(integer *n, doublereal *x, doublereal *y,
+ doublereal *z__, integer *incx, doublereal *c__, doublereal *s,
+ integer *incc);
+
+/* Subroutine */ int dlarf_(char *side, integer *m, integer *n, doublereal *v,
+ integer *incv, doublereal *tau, doublereal *c__, integer *ldc,
+ doublereal *work);
+
+/* Subroutine */ int dlarfb_(char *side, char *trans, char *direct, char *
+ storev, integer *m, integer *n, integer *k, doublereal *v, integer *
+ ldv, doublereal *t, integer *ldt, doublereal *c__, integer *ldc,
+ doublereal *work, integer *ldwork);
+
+/* Subroutine */ int dlarfg_(integer *n, doublereal *alpha, doublereal *x,
+ integer *incx, doublereal *tau);
+
+/* Subroutine */ int dlarfp_(integer *n, doublereal *alpha, doublereal *x,
+ integer *incx, doublereal *tau);
+
+/* Subroutine */ int dlarft_(char *direct, char *storev, integer *n, integer *
+ k, doublereal *v, integer *ldv, doublereal *tau, doublereal *t,
+ integer *ldt);
+
+/* Subroutine */ int dlarfx_(char *side, integer *m, integer *n, doublereal *
+ v, doublereal *tau, doublereal *c__, integer *ldc, doublereal *work);
+
+/* Subroutine */ int dlargv_(integer *n, doublereal *x, integer *incx,
+ doublereal *y, integer *incy, doublereal *c__, integer *incc);
+
+/* Subroutine */ int dlarnv_(integer *idist, integer *iseed, integer *n,
+ doublereal *x);
+
+/* Subroutine */ int dlarra_(integer *n, doublereal *d__, doublereal *e,
+ doublereal *e2, doublereal *spltol, doublereal *tnrm, integer *nsplit,
+ integer *isplit, integer *info);
+
+/* Subroutine */ int dlarrb_(integer *n, doublereal *d__, doublereal *lld,
+ integer *ifirst, integer *ilast, doublereal *rtol1, doublereal *rtol2,
+ integer *offset, doublereal *w, doublereal *wgap, doublereal *werr,
+ doublereal *work, integer *iwork, doublereal *pivmin, doublereal *
+ spdiam, integer *twist, integer *info);
+
+/* Subroutine */ int dlarrc_(char *jobt, integer *n, doublereal *vl,
+ doublereal *vu, doublereal *d__, doublereal *e, doublereal *pivmin,
+ integer *eigcnt, integer *lcnt, integer *rcnt, integer *info);
+
+/* Subroutine */ int dlarrd_(char *range, char *order, integer *n, doublereal
+ *vl, doublereal *vu, integer *il, integer *iu, doublereal *gers,
+ doublereal *reltol, doublereal *d__, doublereal *e, doublereal *e2,
+ doublereal *pivmin, integer *nsplit, integer *isplit, integer *m,
+ doublereal *w, doublereal *werr, doublereal *wl, doublereal *wu,
+ integer *iblock, integer *indexw, doublereal *work, integer *iwork,
+ integer *info);
+
+/* Subroutine */ int dlarre_(char *range, integer *n, doublereal *vl,
+ doublereal *vu, integer *il, integer *iu, doublereal *d__, doublereal
+ *e, doublereal *e2, doublereal *rtol1, doublereal *rtol2, doublereal *
+ spltol, integer *nsplit, integer *isplit, integer *m, doublereal *w,
+ doublereal *werr, doublereal *wgap, integer *iblock, integer *indexw,
+ doublereal *gers, doublereal *pivmin, doublereal *work, integer *
+ iwork, integer *info);
+
+/* Subroutine */ int dlarrf_(integer *n, doublereal *d__, doublereal *l,
+ doublereal *ld, integer *clstrt, integer *clend, doublereal *w,
+ doublereal *wgap, doublereal *werr, doublereal *spdiam, doublereal *
+ clgapl, doublereal *clgapr, doublereal *pivmin, doublereal *sigma,
+ doublereal *dplus, doublereal *lplus, doublereal *work, integer *info);
+
+/* Subroutine */ int dlarrj_(integer *n, doublereal *d__, doublereal *e2,
+ integer *ifirst, integer *ilast, doublereal *rtol, integer *offset,
+ doublereal *w, doublereal *werr, doublereal *work, integer *iwork,
+ doublereal *pivmin, doublereal *spdiam, integer *info);
+
+/* Subroutine */ int dlarrk_(integer *n, integer *iw, doublereal *gl,
+ doublereal *gu, doublereal *d__, doublereal *e2, doublereal *pivmin,
+ doublereal *reltol, doublereal *w, doublereal *werr, integer *info);
+
+/* Subroutine */ int dlarrr_(integer *n, doublereal *d__, doublereal *e,
+ integer *info);
+
+/* Subroutine */ int dlarrv_(integer *n, doublereal *vl, doublereal *vu,
+ doublereal *d__, doublereal *l, doublereal *pivmin, integer *isplit,
+ integer *m, integer *dol, integer *dou, doublereal *minrgp,
+ doublereal *rtol1, doublereal *rtol2, doublereal *w, doublereal *werr,
+ doublereal *wgap, integer *iblock, integer *indexw, doublereal *gers,
+ doublereal *z__, integer *ldz, integer *isuppz, doublereal *work,
+ integer *iwork, integer *info);
+
+/* Subroutine */ int dlarscl2_(integer *m, integer *n, doublereal *d__,
+ doublereal *x, integer *ldx);
+
+/* Subroutine */ int dlartg_(doublereal *f, doublereal *g, doublereal *cs,
+ doublereal *sn, doublereal *r__);
+
+/* Subroutine */ int dlartv_(integer *n, doublereal *x, integer *incx,
+ doublereal *y, integer *incy, doublereal *c__, doublereal *s, integer
+ *incc);
+
+/* Subroutine */ int dlaruv_(integer *iseed, integer *n, doublereal *x);
+
+/* Subroutine */ int dlarz_(char *side, integer *m, integer *n, integer *l,
+ doublereal *v, integer *incv, doublereal *tau, doublereal *c__,
+ integer *ldc, doublereal *work);
+
+/* Subroutine */ int dlarzb_(char *side, char *trans, char *direct, char *
+ storev, integer *m, integer *n, integer *k, integer *l, doublereal *v,
+ integer *ldv, doublereal *t, integer *ldt, doublereal *c__, integer *
+ ldc, doublereal *work, integer *ldwork);
+
+/* Subroutine */ int dlarzt_(char *direct, char *storev, integer *n, integer *
+ k, doublereal *v, integer *ldv, doublereal *tau, doublereal *t,
+ integer *ldt);
+
+/* Subroutine */ int dlas2_(doublereal *f, doublereal *g, doublereal *h__,
+ doublereal *ssmin, doublereal *ssmax);
+
+/* Subroutine */ int dlascl_(char *type__, integer *kl, integer *ku,
+ doublereal *cfrom, doublereal *cto, integer *m, integer *n,
+ doublereal *a, integer *lda, integer *info);
+
+/* Subroutine */ int dlascl2_(integer *m, integer *n, doublereal *d__,
+ doublereal *x, integer *ldx);
+
+/* Subroutine */ int dlasd0_(integer *n, integer *sqre, doublereal *d__,
+ doublereal *e, doublereal *u, integer *ldu, doublereal *vt, integer *
+ ldvt, integer *smlsiz, integer *iwork, doublereal *work, integer *
+ info);
+
+/* Subroutine */ int dlasd1_(integer *nl, integer *nr, integer *sqre,
+ doublereal *d__, doublereal *alpha, doublereal *beta, doublereal *u,
+ integer *ldu, doublereal *vt, integer *ldvt, integer *idxq, integer *
+ iwork, doublereal *work, integer *info);
+
+/* Subroutine */ int dlasd2_(integer *nl, integer *nr, integer *sqre, integer
+ *k, doublereal *d__, doublereal *z__, doublereal *alpha, doublereal *
+ beta, doublereal *u, integer *ldu, doublereal *vt, integer *ldvt,
+ doublereal *dsigma, doublereal *u2, integer *ldu2, doublereal *vt2,
+ integer *ldvt2, integer *idxp, integer *idx, integer *idxc, integer *
+ idxq, integer *coltyp, integer *info);
+
+/* Subroutine */ int dlasd3_(integer *nl, integer *nr, integer *sqre, integer
+ *k, doublereal *d__, doublereal *q, integer *ldq, doublereal *dsigma,
+ doublereal *u, integer *ldu, doublereal *u2, integer *ldu2,
+ doublereal *vt, integer *ldvt, doublereal *vt2, integer *ldvt2,
+ integer *idxc, integer *ctot, doublereal *z__, integer *info);
+
+/* Subroutine */ int dlasd4_(integer *n, integer *i__, doublereal *d__,
+ doublereal *z__, doublereal *delta, doublereal *rho, doublereal *
+ sigma, doublereal *work, integer *info);
+
+/* Subroutine */ int dlasd5_(integer *i__, doublereal *d__, doublereal *z__,
+ doublereal *delta, doublereal *rho, doublereal *dsigma, doublereal *
+ work);
+
+/* Subroutine */ int dlasd6_(integer *icompq, integer *nl, integer *nr,
+ integer *sqre, doublereal *d__, doublereal *vf, doublereal *vl,
+ doublereal *alpha, doublereal *beta, integer *idxq, integer *perm,
+ integer *givptr, integer *givcol, integer *ldgcol, doublereal *givnum,
+ integer *ldgnum, doublereal *poles, doublereal *difl, doublereal *
+ difr, doublereal *z__, integer *k, doublereal *c__, doublereal *s,
+ doublereal *work, integer *iwork, integer *info);
+
+/* Subroutine */ int dlasd7_(integer *icompq, integer *nl, integer *nr,
+ integer *sqre, integer *k, doublereal *d__, doublereal *z__,
+ doublereal *zw, doublereal *vf, doublereal *vfw, doublereal *vl,
+ doublereal *vlw, doublereal *alpha, doublereal *beta, doublereal *
+ dsigma, integer *idx, integer *idxp, integer *idxq, integer *perm,
+ integer *givptr, integer *givcol, integer *ldgcol, doublereal *givnum,
+ integer *ldgnum, doublereal *c__, doublereal *s, integer *info);
+
+/* Subroutine */ int dlasd8_(integer *icompq, integer *k, doublereal *d__,
+ doublereal *z__, doublereal *vf, doublereal *vl, doublereal *difl,
+ doublereal *difr, integer *lddifr, doublereal *dsigma, doublereal *
+ work, integer *info);
+
+/* Subroutine */ int dlasda_(integer *icompq, integer *smlsiz, integer *n,
+ integer *sqre, doublereal *d__, doublereal *e, doublereal *u, integer
+ *ldu, doublereal *vt, integer *k, doublereal *difl, doublereal *difr,
+ doublereal *z__, doublereal *poles, integer *givptr, integer *givcol,
+ integer *ldgcol, integer *perm, doublereal *givnum, doublereal *c__,
+ doublereal *s, doublereal *work, integer *iwork, integer *info);
+
+/* Subroutine */ int dlasdq_(char *uplo, integer *sqre, integer *n, integer *
+ ncvt, integer *nru, integer *ncc, doublereal *d__, doublereal *e,
+ doublereal *vt, integer *ldvt, doublereal *u, integer *ldu,
+ doublereal *c__, integer *ldc, doublereal *work, integer *info);
+
+/* Subroutine */ int dlasdt_(integer *n, integer *lvl, integer *nd, integer *
+ inode, integer *ndiml, integer *ndimr, integer *msub);
+
+/* Subroutine */ int dlaset_(char *uplo, integer *m, integer *n, doublereal *
+ alpha, doublereal *beta, doublereal *a, integer *lda);
+
+/* Subroutine */ int dlasq1_(integer *n, doublereal *d__, doublereal *e,
+ doublereal *work, integer *info);
+
+/* Subroutine */ int dlasq2_(integer *n, doublereal *z__, integer *info);
+
+/* Subroutine */ int dlasq3_(integer *i0, integer *n0, doublereal *z__,
+ integer *pp, doublereal *dmin__, doublereal *sigma, doublereal *desig,
+ doublereal *qmax, integer *nfail, integer *iter, integer *ndiv,
+ logical *ieee, integer *ttype, doublereal *dmin1, doublereal *dmin2,
+ doublereal *dn, doublereal *dn1, doublereal *dn2, doublereal *g,
+ doublereal *tau);
+
+/* Subroutine */ int dlasq4_(integer *i0, integer *n0, doublereal *z__,
+ integer *pp, integer *n0in, doublereal *dmin__, doublereal *dmin1,
+ doublereal *dmin2, doublereal *dn, doublereal *dn1, doublereal *dn2,
+ doublereal *tau, integer *ttype, doublereal *g);
+
+/* Subroutine */ int dlasq5_(integer *i0, integer *n0, doublereal *z__,
+ integer *pp, doublereal *tau, doublereal *dmin__, doublereal *dmin1,
+ doublereal *dmin2, doublereal *dn, doublereal *dnm1, doublereal *dnm2,
+ logical *ieee);
+
+/* Subroutine */ int dlasq6_(integer *i0, integer *n0, doublereal *z__,
+ integer *pp, doublereal *dmin__, doublereal *dmin1, doublereal *dmin2,
+ doublereal *dn, doublereal *dnm1, doublereal *dnm2);
+
+/* Subroutine */ int dlasr_(char *side, char *pivot, char *direct, integer *m,
+ integer *n, doublereal *c__, doublereal *s, doublereal *a, integer *
+ lda);
+
+/* Subroutine */ int dlasrt_(char *id, integer *n, doublereal *d__, integer *
+ info);
+
+/* Subroutine */ int dlassq_(integer *n, doublereal *x, integer *incx,
+ doublereal *scale, doublereal *sumsq);
+
+/* Subroutine */ int dlasv2_(doublereal *f, doublereal *g, doublereal *h__,
+ doublereal *ssmin, doublereal *ssmax, doublereal *snr, doublereal *
+ csr, doublereal *snl, doublereal *csl);
+
+/* Subroutine */ int dlaswp_(integer *n, doublereal *a, integer *lda, integer
+ *k1, integer *k2, integer *ipiv, integer *incx);
+
+/* Subroutine */ int dlasy2_(logical *ltranl, logical *ltranr, integer *isgn,
+ integer *n1, integer *n2, doublereal *tl, integer *ldtl, doublereal *
+ tr, integer *ldtr, doublereal *b, integer *ldb, doublereal *scale,
+ doublereal *x, integer *ldx, doublereal *xnorm, integer *info);
+
+/* Subroutine */ int dlasyf_(char *uplo, integer *n, integer *nb, integer *kb,
+ doublereal *a, integer *lda, integer *ipiv, doublereal *w, integer *
+ ldw, integer *info);
+
+/* Subroutine */ int dlat2s_(char *uplo, integer *n, doublereal *a, integer *
+ lda, real *sa, integer *ldsa, integer *info);
+
+/* Subroutine */ int dlatbs_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, integer *kd, doublereal *ab, integer *ldab,
+ doublereal *x, doublereal *scale, doublereal *cnorm, integer *info);
+
+/* Subroutine */ int dlatdf_(integer *ijob, integer *n, doublereal *z__,
+ integer *ldz, doublereal *rhs, doublereal *rdsum, doublereal *rdscal,
+ integer *ipiv, integer *jpiv);
+
+/* Subroutine */ int dlatps_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, doublereal *ap, doublereal *x, doublereal *scale,
+ doublereal *cnorm, integer *info);
+
+/* Subroutine */ int dlatrd_(char *uplo, integer *n, integer *nb, doublereal *
+ a, integer *lda, doublereal *e, doublereal *tau, doublereal *w,
+ integer *ldw);
+
+/* Subroutine */ int dlatrs_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, doublereal *a, integer *lda, doublereal *x,
+ doublereal *scale, doublereal *cnorm, integer *info);
+
+/* Subroutine */ int dlatrz_(integer *m, integer *n, integer *l, doublereal *
+ a, integer *lda, doublereal *tau, doublereal *work);
+
+/* Subroutine */ int dlatzm_(char *side, integer *m, integer *n, doublereal *
+ v, integer *incv, doublereal *tau, doublereal *c1, doublereal *c2,
+ integer *ldc, doublereal *work);
+
+/* Subroutine */ int dlauu2_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *info);
+
+/* Subroutine */ int dlauum_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *info);
+
+/* Subroutine */ int dopgtr_(char *uplo, integer *n, doublereal *ap,
+ doublereal *tau, doublereal *q, integer *ldq, doublereal *work,
+ integer *info);
+
+/* Subroutine */ int dopmtr_(char *side, char *uplo, char *trans, integer *m,
+ integer *n, doublereal *ap, doublereal *tau, doublereal *c__, integer
+ *ldc, doublereal *work, integer *info);
+
+/* Subroutine */ int dorg2l_(integer *m, integer *n, integer *k, doublereal *
+ a, integer *lda, doublereal *tau, doublereal *work, integer *info);
+
+/* Subroutine */ int dorg2r_(integer *m, integer *n, integer *k, doublereal *
+ a, integer *lda, doublereal *tau, doublereal *work, integer *info);
+
+/* Subroutine */ int dorgbr_(char *vect, integer *m, integer *n, integer *k,
+ doublereal *a, integer *lda, doublereal *tau, doublereal *work,
+ integer *lwork, integer *info);
+
+/* Subroutine */ int dorghr_(integer *n, integer *ilo, integer *ihi,
+ doublereal *a, integer *lda, doublereal *tau, doublereal *work,
+ integer *lwork, integer *info);
+
+/* Subroutine */ int dorgl2_(integer *m, integer *n, integer *k, doublereal *
+ a, integer *lda, doublereal *tau, doublereal *work, integer *info);
+
+/* Subroutine */ int dorglq_(integer *m, integer *n, integer *k, doublereal *
+ a, integer *lda, doublereal *tau, doublereal *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int dorgql_(integer *m, integer *n, integer *k, doublereal *
+ a, integer *lda, doublereal *tau, doublereal *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int dorgqr_(integer *m, integer *n, integer *k, doublereal *
+ a, integer *lda, doublereal *tau, doublereal *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int dorgr2_(integer *m, integer *n, integer *k, doublereal *
+ a, integer *lda, doublereal *tau, doublereal *work, integer *info);
+
+/* Subroutine */ int dorgrq_(integer *m, integer *n, integer *k, doublereal *
+ a, integer *lda, doublereal *tau, doublereal *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int dorgtr_(char *uplo, integer *n, doublereal *a, integer *
+ lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);
+
+/* Subroutine */ int dorm2l_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
+ c__, integer *ldc, doublereal *work, integer *info);
+
+/* Subroutine */ int dorm2r_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
+ c__, integer *ldc, doublereal *work, integer *info);
+
+/* Subroutine */ int dormbr_(char *vect, char *side, char *trans, integer *m,
+ integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau,
+ doublereal *c__, integer *ldc, doublereal *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int dormhr_(char *side, char *trans, integer *m, integer *n,
+ integer *ilo, integer *ihi, doublereal *a, integer *lda, doublereal *
+ tau, doublereal *c__, integer *ldc, doublereal *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int dorml2_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
+ c__, integer *ldc, doublereal *work, integer *info);
+
+/* Subroutine */ int dormlq_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
+ c__, integer *ldc, doublereal *work, integer *lwork, integer *info);
+
+/* Subroutine */ int dormql_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
+ c__, integer *ldc, doublereal *work, integer *lwork, integer *info);
+
+/* Subroutine */ int dormqr_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
+ c__, integer *ldc, doublereal *work, integer *lwork, integer *info);
+
+/* Subroutine */ int dormr2_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
+ c__, integer *ldc, doublereal *work, integer *info);
+
+/* Subroutine */ int dormr3_(char *side, char *trans, integer *m, integer *n,
+ integer *k, integer *l, doublereal *a, integer *lda, doublereal *tau,
+ doublereal *c__, integer *ldc, doublereal *work, integer *info);
+
+/* Subroutine */ int dormrq_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
+ c__, integer *ldc, doublereal *work, integer *lwork, integer *info);
+
+/* Subroutine */ int dormrz_(char *side, char *trans, integer *m, integer *n,
+ integer *k, integer *l, doublereal *a, integer *lda, doublereal *tau,
+ doublereal *c__, integer *ldc, doublereal *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int dormtr_(char *side, char *uplo, char *trans, integer *m,
+ integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *
+ c__, integer *ldc, doublereal *work, integer *lwork, integer *info);
+
+/* Subroutine */ int dpbcon_(char *uplo, integer *n, integer *kd, doublereal *
+ ab, integer *ldab, doublereal *anorm, doublereal *rcond, doublereal *
+ work, integer *iwork, integer *info);
+
+/* Subroutine */ int dpbequ_(char *uplo, integer *n, integer *kd, doublereal *
+ ab, integer *ldab, doublereal *s, doublereal *scond, doublereal *amax,
+ integer *info);
+
+/* Subroutine */ int dpbrfs_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb,
+ doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
+ ferr, doublereal *berr, doublereal *work, integer *iwork, integer *
+ info);
+
+/* Subroutine */ int dpbstf_(char *uplo, integer *n, integer *kd, doublereal *
+ ab, integer *ldab, integer *info);
+
+/* Subroutine */ int dpbsv_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, doublereal *ab, integer *ldab, doublereal *b, integer *ldb,
+ integer *info);
+
+/* Subroutine */ int dpbsvx_(char *fact, char *uplo, integer *n, integer *kd,
+ integer *nrhs, doublereal *ab, integer *ldab, doublereal *afb,
+ integer *ldafb, char *equed, doublereal *s, doublereal *b, integer *
+ ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *ferr,
+ doublereal *berr, doublereal *work, integer *iwork, integer *info);
+
+/* Subroutine */ int dpbtf2_(char *uplo, integer *n, integer *kd, doublereal *
+ ab, integer *ldab, integer *info);
+
+/* Subroutine */ int dpbtrf_(char *uplo, integer *n, integer *kd, doublereal *
+ ab, integer *ldab, integer *info);
+
+/* Subroutine */ int dpbtrs_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, doublereal *ab, integer *ldab, doublereal *b, integer *ldb,
+ integer *info);
+
+/* Subroutine */ int dpftrf_(char *transr, char *uplo, integer *n, doublereal
+ *a, integer *info);
+
+/* Subroutine */ int dpftri_(char *transr, char *uplo, integer *n, doublereal
+ *a, integer *info);
+
+/* Subroutine */ int dpftrs_(char *transr, char *uplo, integer *n, integer *
+ nrhs, doublereal *a, doublereal *b, integer *ldb, integer *info);
+
+/* Subroutine */ int dpocon_(char *uplo, integer *n, doublereal *a, integer *
+ lda, doublereal *anorm, doublereal *rcond, doublereal *work, integer *
+ iwork, integer *info);
+
+/* Subroutine */ int dpoequ_(integer *n, doublereal *a, integer *lda,
+ doublereal *s, doublereal *scond, doublereal *amax, integer *info);
+
+/* Subroutine */ int dpoequb_(integer *n, doublereal *a, integer *lda,
+ doublereal *s, doublereal *scond, doublereal *amax, integer *info);
+
+/* Subroutine */ int dporfs_(char *uplo, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *af, integer *ldaf,
+ doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
+ ferr, doublereal *berr, doublereal *work, integer *iwork, integer *
+ info);
+
+/* Subroutine */ int dporfsx_(char *uplo, char *equed, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
+ doublereal *s, doublereal *b, integer *ldb, doublereal *x, integer *
+ ldx, doublereal *rcond, doublereal *berr, integer *n_err_bnds__,
+ doublereal *err_bnds_norm__, doublereal *err_bnds_comp__, integer *
+ nparams, doublereal *params, doublereal *work, integer *iwork,
+ integer *info);
+
+/* Subroutine */ int dposv_(char *uplo, integer *n, integer *nrhs, doublereal
+ *a, integer *lda, doublereal *b, integer *ldb, integer *info);
+
+/* Subroutine */ int dposvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
+ char *equed, doublereal *s, doublereal *b, integer *ldb, doublereal *
+ x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *
+ berr, doublereal *work, integer *iwork, integer *info);
+
+/* Subroutine */ int dposvxx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
+ char *equed, doublereal *s, doublereal *b, integer *ldb, doublereal *
+ x, integer *ldx, doublereal *rcond, doublereal *rpvgrw, doublereal *
+ berr, integer *n_err_bnds__, doublereal *err_bnds_norm__, doublereal *
+ err_bnds_comp__, integer *nparams, doublereal *params, doublereal *
+ work, integer *iwork, integer *info);
+
+/* Subroutine */ int dpotf2_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *info);
+
+/* Subroutine */ int dpotrf_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *info);
+
+/* Subroutine */ int dpotri_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *info);
+
+/* Subroutine */ int dpotrs_(char *uplo, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *
+ info);
+
+/* Subroutine */ int dppcon_(char *uplo, integer *n, doublereal *ap,
+ doublereal *anorm, doublereal *rcond, doublereal *work, integer *
+ iwork, integer *info);
+
+/* Subroutine */ int dppequ_(char *uplo, integer *n, doublereal *ap,
+ doublereal *s, doublereal *scond, doublereal *amax, integer *info);
+
+/* Subroutine */ int dpprfs_(char *uplo, integer *n, integer *nrhs,
+ doublereal *ap, doublereal *afp, doublereal *b, integer *ldb,
+ doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr,
+ doublereal *work, integer *iwork, integer *info);
+
+/* Subroutine */ int dppsv_(char *uplo, integer *n, integer *nrhs, doublereal
+ *ap, doublereal *b, integer *ldb, integer *info);
+
+/* Subroutine */ int dppsvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublereal *ap, doublereal *afp, char *equed, doublereal *s,
+ doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
+ rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *
+ iwork, integer *info);
+
+/* Subroutine */ int dpptrf_(char *uplo, integer *n, doublereal *ap, integer *
+ info);
+
+/* Subroutine */ int dpptri_(char *uplo, integer *n, doublereal *ap, integer *
+ info);
+
+/* Subroutine */ int dpptrs_(char *uplo, integer *n, integer *nrhs,
+ doublereal *ap, doublereal *b, integer *ldb, integer *info);
+
+/* Subroutine */ int dpstf2_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *piv, integer *rank, doublereal *tol, doublereal *work,
+ integer *info);
+
+/* Subroutine */ int dpstrf_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *piv, integer *rank, doublereal *tol, doublereal *work,
+ integer *info);
+
+/* Subroutine */ int dptcon_(integer *n, doublereal *d__, doublereal *e,
+ doublereal *anorm, doublereal *rcond, doublereal *work, integer *info);
+
+/* Subroutine */ int dpteqr_(char *compz, integer *n, doublereal *d__,
+ doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
+ integer *info);
+
+/* Subroutine */ int dptrfs_(integer *n, integer *nrhs, doublereal *d__,
+ doublereal *e, doublereal *df, doublereal *ef, doublereal *b, integer
+ *ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr,
+ doublereal *work, integer *info);
+
+/* Subroutine */ int dptsv_(integer *n, integer *nrhs, doublereal *d__,
+ doublereal *e, doublereal *b, integer *ldb, integer *info);
+
+/* Subroutine */ int dptsvx_(char *fact, integer *n, integer *nrhs,
+ doublereal *d__, doublereal *e, doublereal *df, doublereal *ef,
+ doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
+ rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *
+ info);
+
+/* Subroutine */ int dpttrf_(integer *n, doublereal *d__, doublereal *e,
+ integer *info);
+
+/* Subroutine */ int dpttrs_(integer *n, integer *nrhs, doublereal *d__,
+ doublereal *e, doublereal *b, integer *ldb, integer *info);
+
+/* Subroutine */ int dptts2_(integer *n, integer *nrhs, doublereal *d__,
+ doublereal *e, doublereal *b, integer *ldb);
+
+/* Subroutine */ int drscl_(integer *n, doublereal *sa, doublereal *sx,
+ integer *incx);
+
+/* Subroutine */ int dsbev_(char *jobz, char *uplo, integer *n, integer *kd,
+ doublereal *ab, integer *ldab, doublereal *w, doublereal *z__,
+ integer *ldz, doublereal *work, integer *info);
+
+/* Subroutine */ int dsbevd_(char *jobz, char *uplo, integer *n, integer *kd,
+ doublereal *ab, integer *ldab, doublereal *w, doublereal *z__,
+ integer *ldz, doublereal *work, integer *lwork, integer *iwork,
+ integer *liwork, integer *info);
+
+/* Subroutine */ int dsbevx_(char *jobz, char *range, char *uplo, integer *n,
+ integer *kd, doublereal *ab, integer *ldab, doublereal *q, integer *
+ ldq, doublereal *vl, doublereal *vu, integer *il, integer *iu,
+ doublereal *abstol, integer *m, doublereal *w, doublereal *z__,
+ integer *ldz, doublereal *work, integer *iwork, integer *ifail,
+ integer *info);
+
+/* Subroutine */ int dsbgst_(char *vect, char *uplo, integer *n, integer *ka,
+ integer *kb, doublereal *ab, integer *ldab, doublereal *bb, integer *
+ ldbb, doublereal *x, integer *ldx, doublereal *work, integer *info);
+
+/* Subroutine */ int dsbgv_(char *jobz, char *uplo, integer *n, integer *ka,
+ integer *kb, doublereal *ab, integer *ldab, doublereal *bb, integer *
+ ldbb, doublereal *w, doublereal *z__, integer *ldz, doublereal *work,
+ integer *info);
+
+/* Subroutine */ int dsbgvd_(char *jobz, char *uplo, integer *n, integer *ka,
+ integer *kb, doublereal *ab, integer *ldab, doublereal *bb, integer *
+ ldbb, doublereal *w, doublereal *z__, integer *ldz, doublereal *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int dsbgvx_(char *jobz, char *range, char *uplo, integer *n,
+ integer *ka, integer *kb, doublereal *ab, integer *ldab, doublereal *
+ bb, integer *ldbb, doublereal *q, integer *ldq, doublereal *vl,
+ doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer
+ *m, doublereal *w, doublereal *z__, integer *ldz, doublereal *work,
+ integer *iwork, integer *ifail, integer *info);
+
+/* Subroutine */ int dsbtrd_(char *vect, char *uplo, integer *n, integer *kd,
+ doublereal *ab, integer *ldab, doublereal *d__, doublereal *e,
+ doublereal *q, integer *ldq, doublereal *work, integer *info);
+
+/* Subroutine */ int dsfrk_(char *transr, char *uplo, char *trans, integer *n,
+ integer *k, doublereal *alpha, doublereal *a, integer *lda,
+ doublereal *beta, doublereal *c__);
+
+/* Subroutine */ int dsgesv_(integer *n, integer *nrhs, doublereal *a,
+ integer *lda, integer *ipiv, doublereal *b, integer *ldb, doublereal *
+ x, integer *ldx, doublereal *work, real *swork, integer *iter,
+ integer *info);
+
+/* Subroutine */ int dspcon_(char *uplo, integer *n, doublereal *ap, integer *
+ ipiv, doublereal *anorm, doublereal *rcond, doublereal *work, integer
+ *iwork, integer *info);
+
+/* Subroutine */ int dspev_(char *jobz, char *uplo, integer *n, doublereal *
+ ap, doublereal *w, doublereal *z__, integer *ldz, doublereal *work,
+ integer *info);
+
+/* Subroutine */ int dspevd_(char *jobz, char *uplo, integer *n, doublereal *
+ ap, doublereal *w, doublereal *z__, integer *ldz, doublereal *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int dspevx_(char *jobz, char *range, char *uplo, integer *n,
+ doublereal *ap, doublereal *vl, doublereal *vu, integer *il, integer *
+ iu, doublereal *abstol, integer *m, doublereal *w, doublereal *z__,
+ integer *ldz, doublereal *work, integer *iwork, integer *ifail,
+ integer *info);
+
+/* Subroutine */ int dspgst_(integer *itype, char *uplo, integer *n,
+ doublereal *ap, doublereal *bp, integer *info);
+
+/* Subroutine */ int dspgv_(integer *itype, char *jobz, char *uplo, integer *
+ n, doublereal *ap, doublereal *bp, doublereal *w, doublereal *z__,
+ integer *ldz, doublereal *work, integer *info);
+
+/* Subroutine */ int dspgvd_(integer *itype, char *jobz, char *uplo, integer *
+ n, doublereal *ap, doublereal *bp, doublereal *w, doublereal *z__,
+ integer *ldz, doublereal *work, integer *lwork, integer *iwork,
+ integer *liwork, integer *info);
+
+/* Subroutine */ int dspgvx_(integer *itype, char *jobz, char *range, char *
+ uplo, integer *n, doublereal *ap, doublereal *bp, doublereal *vl,
+ doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer
+ *m, doublereal *w, doublereal *z__, integer *ldz, doublereal *work,
+ integer *iwork, integer *ifail, integer *info);
+
+/* Subroutine */ int dsposv_(char *uplo, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
+ x, integer *ldx, doublereal *work, real *swork, integer *iter,
+ integer *info);
+
+/* Subroutine */ int dsprfs_(char *uplo, integer *n, integer *nrhs,
+ doublereal *ap, doublereal *afp, integer *ipiv, doublereal *b,
+ integer *ldb, doublereal *x, integer *ldx, doublereal *ferr,
+ doublereal *berr, doublereal *work, integer *iwork, integer *info);
+
+/* Subroutine */ int dspsv_(char *uplo, integer *n, integer *nrhs, doublereal
+ *ap, integer *ipiv, doublereal *b, integer *ldb, integer *info);
+
+/* Subroutine */ int dspsvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublereal *ap, doublereal *afp, integer *ipiv, doublereal *b,
+ integer *ldb, doublereal *x, integer *ldx, doublereal *rcond,
+ doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork,
+ integer *info);
+
+/* Subroutine */ int dsptrd_(char *uplo, integer *n, doublereal *ap,
+ doublereal *d__, doublereal *e, doublereal *tau, integer *info);
+
+/* Subroutine */ int dsptrf_(char *uplo, integer *n, doublereal *ap, integer *
+ ipiv, integer *info);
+
+/* Subroutine */ int dsptri_(char *uplo, integer *n, doublereal *ap, integer *
+ ipiv, doublereal *work, integer *info);
+
+/* Subroutine */ int dsptrs_(char *uplo, integer *n, integer *nrhs,
+ doublereal *ap, integer *ipiv, doublereal *b, integer *ldb, integer *
+ info);
+
+/* Subroutine */ int dstebz_(char *range, char *order, integer *n, doublereal
+ *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol,
+ doublereal *d__, doublereal *e, integer *m, integer *nsplit,
+ doublereal *w, integer *iblock, integer *isplit, doublereal *work,
+ integer *iwork, integer *info);
+
+/* Subroutine */ int dstedc_(char *compz, integer *n, doublereal *d__,
+ doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int dstegr_(char *jobz, char *range, integer *n, doublereal *
+ d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il,
+ integer *iu, doublereal *abstol, integer *m, doublereal *w,
+ doublereal *z__, integer *ldz, integer *isuppz, doublereal *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int dstein_(integer *n, doublereal *d__, doublereal *e,
+ integer *m, doublereal *w, integer *iblock, integer *isplit,
+ doublereal *z__, integer *ldz, doublereal *work, integer *iwork,
+ integer *ifail, integer *info);
+
+/* Subroutine */ int dstemr_(char *jobz, char *range, integer *n, doublereal *
+ d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il,
+ integer *iu, integer *m, doublereal *w, doublereal *z__, integer *ldz,
+ integer *nzc, integer *isuppz, logical *tryrac, doublereal *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int dsteqr_(char *compz, integer *n, doublereal *d__,
+ doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
+ integer *info);
+
+/* Subroutine */ int dsterf_(integer *n, doublereal *d__, doublereal *e,
+ integer *info);
+
+/* Subroutine */ int dstev_(char *jobz, integer *n, doublereal *d__,
+ doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
+ integer *info);
+
+/* Subroutine */ int dstevd_(char *jobz, integer *n, doublereal *d__,
+ doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int dstevr_(char *jobz, char *range, integer *n, doublereal *
+ d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il,
+ integer *iu, doublereal *abstol, integer *m, doublereal *w,
+ doublereal *z__, integer *ldz, integer *isuppz, doublereal *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int dstevx_(char *jobz, char *range, integer *n, doublereal *
+ d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il,
+ integer *iu, doublereal *abstol, integer *m, doublereal *w,
+ doublereal *z__, integer *ldz, doublereal *work, integer *iwork,
+ integer *ifail, integer *info);
+
+/* Subroutine */ int dsycon_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *ipiv, doublereal *anorm, doublereal *rcond, doublereal *
+ work, integer *iwork, integer *info);
+
+/* Subroutine */ int dsyequb_(char *uplo, integer *n, doublereal *a, integer *
+ lda, doublereal *s, doublereal *scond, doublereal *amax, doublereal *
+ work, integer *info);
+
+/* Subroutine */ int dsyev_(char *jobz, char *uplo, integer *n, doublereal *a,
+ integer *lda, doublereal *w, doublereal *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int dsyevd_(char *jobz, char *uplo, integer *n, doublereal *
+ a, integer *lda, doublereal *w, doublereal *work, integer *lwork,
+ integer *iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int dsyevr_(char *jobz, char *range, char *uplo, integer *n,
+ doublereal *a, integer *lda, doublereal *vl, doublereal *vu, integer *
+ il, integer *iu, doublereal *abstol, integer *m, doublereal *w,
+ doublereal *z__, integer *ldz, integer *isuppz, doublereal *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int dsyevx_(char *jobz, char *range, char *uplo, integer *n,
+ doublereal *a, integer *lda, doublereal *vl, doublereal *vu, integer *
+ il, integer *iu, doublereal *abstol, integer *m, doublereal *w,
+ doublereal *z__, integer *ldz, doublereal *work, integer *lwork,
+ integer *iwork, integer *ifail, integer *info);
+
+/* Subroutine */ int dsygs2_(integer *itype, char *uplo, integer *n,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *
+ info);
+
+/* Subroutine */ int dsygst_(integer *itype, char *uplo, integer *n,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *
+ info);
+
+/* Subroutine */ int dsygv_(integer *itype, char *jobz, char *uplo, integer *
+ n, doublereal *a, integer *lda, doublereal *b, integer *ldb,
+ doublereal *w, doublereal *work, integer *lwork, integer *info);
+
+/* Subroutine */ int dsygvd_(integer *itype, char *jobz, char *uplo, integer *
+ n, doublereal *a, integer *lda, doublereal *b, integer *ldb,
+ doublereal *w, doublereal *work, integer *lwork, integer *iwork,
+ integer *liwork, integer *info);
+
+/* Subroutine */ int dsygvx_(integer *itype, char *jobz, char *range, char *
+ uplo, integer *n, doublereal *a, integer *lda, doublereal *b, integer
+ *ldb, doublereal *vl, doublereal *vu, integer *il, integer *iu,
+ doublereal *abstol, integer *m, doublereal *w, doublereal *z__,
+ integer *ldz, doublereal *work, integer *lwork, integer *iwork,
+ integer *ifail, integer *info);
+
+/* Subroutine */ int dsyrfs_(char *uplo, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *
+ ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx,
+ doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork,
+ integer *info);
+
+/* Subroutine */ int dsyrfsx_(char *uplo, char *equed, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
+ integer *ipiv, doublereal *s, doublereal *b, integer *ldb, doublereal
+ *x, integer *ldx, doublereal *rcond, doublereal *berr, integer *
+ n_err_bnds__, doublereal *err_bnds_norm__, doublereal *
+ err_bnds_comp__, integer *nparams, doublereal *params, doublereal *
+ work, integer *iwork, integer *info);
+
+/* Subroutine */ int dsysv_(char *uplo, integer *n, integer *nrhs, doublereal
+ *a, integer *lda, integer *ipiv, doublereal *b, integer *ldb,
+ doublereal *work, integer *lwork, integer *info);
+
+/* Subroutine */ int dsysvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
+ integer *ipiv, doublereal *b, integer *ldb, doublereal *x, integer *
+ ldx, doublereal *rcond, doublereal *ferr, doublereal *berr,
+ doublereal *work, integer *lwork, integer *iwork, integer *info);
+
+/* Subroutine */ int dsysvxx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
+ integer *ipiv, char *equed, doublereal *s, doublereal *b, integer *
+ ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *
+ rpvgrw, doublereal *berr, integer *n_err_bnds__, doublereal *
+ err_bnds_norm__, doublereal *err_bnds_comp__, integer *nparams,
+ doublereal *params, doublereal *work, integer *iwork, integer *info);
+
+/* Subroutine */ int dsytd2_(char *uplo, integer *n, doublereal *a, integer *
+ lda, doublereal *d__, doublereal *e, doublereal *tau, integer *info);
+
+/* Subroutine */ int dsytf2_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *ipiv, integer *info);
+
+/* Subroutine */ int dsytrd_(char *uplo, integer *n, doublereal *a, integer *
+ lda, doublereal *d__, doublereal *e, doublereal *tau, doublereal *
+ work, integer *lwork, integer *info);
+
+/* Subroutine */ int dsytrf_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *ipiv, doublereal *work, integer *lwork, integer *info);
+
+/* Subroutine */ int dsytri_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *ipiv, doublereal *work, integer *info);
+
+/* Subroutine */ int dsytrs_(char *uplo, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer *
+ ldb, integer *info);
+
+/* Subroutine */ int dtbcon_(char *norm, char *uplo, char *diag, integer *n,
+ integer *kd, doublereal *ab, integer *ldab, doublereal *rcond,
+ doublereal *work, integer *iwork, integer *info);
+
+/* Subroutine */ int dtbrfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, doublereal *ab, integer *ldab, doublereal
+ *b, integer *ldb, doublereal *x, integer *ldx, doublereal *ferr,
+ doublereal *berr, doublereal *work, integer *iwork, integer *info);
+
+/* Subroutine */ int dtbtrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, doublereal *ab, integer *ldab, doublereal
+ *b, integer *ldb, integer *info);
+
+/* Subroutine */ int dtfsm_(char *transr, char *side, char *uplo, char *trans,
+ char *diag, integer *m, integer *n, doublereal *alpha, doublereal *a,
+ doublereal *b, integer *ldb);
+
+/* Subroutine */ int dtftri_(char *transr, char *uplo, char *diag, integer *n,
+ doublereal *a, integer *info);
+
+/* Subroutine */ int dtfttp_(char *transr, char *uplo, integer *n, doublereal
+ *arf, doublereal *ap, integer *info);
+
+/* Subroutine */ int dtfttr_(char *transr, char *uplo, integer *n, doublereal
+ *arf, doublereal *a, integer *lda, integer *info);
+
+/* Subroutine */ int dtgevc_(char *side, char *howmny, logical *select,
+ integer *n, doublereal *s, integer *lds, doublereal *p, integer *ldp,
+ doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, integer
+ *mm, integer *m, doublereal *work, integer *info);
+
+/* Subroutine */ int dtgex2_(logical *wantq, logical *wantz, integer *n,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
+ q, integer *ldq, doublereal *z__, integer *ldz, integer *j1, integer *
+ n1, integer *n2, doublereal *work, integer *lwork, integer *info);
+
+/* Subroutine */ int dtgexc_(logical *wantq, logical *wantz, integer *n,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
+ q, integer *ldq, doublereal *z__, integer *ldz, integer *ifst,
+ integer *ilst, doublereal *work, integer *lwork, integer *info);
+
+/* Subroutine */ int dtgsen_(integer *ijob, logical *wantq, logical *wantz,
+ logical *select, integer *n, doublereal *a, integer *lda, doublereal *
+ b, integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *
+ beta, doublereal *q, integer *ldq, doublereal *z__, integer *ldz,
+ integer *m, doublereal *pl, doublereal *pr, doublereal *dif,
+ doublereal *work, integer *lwork, integer *iwork, integer *liwork,
+ integer *info);
+
+/* Subroutine */ int dtgsja_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *p, integer *n, integer *k, integer *l, doublereal *a,
+ integer *lda, doublereal *b, integer *ldb, doublereal *tola,
+ doublereal *tolb, doublereal *alpha, doublereal *beta, doublereal *u,
+ integer *ldu, doublereal *v, integer *ldv, doublereal *q, integer *
+ ldq, doublereal *work, integer *ncycle, integer *info);
+
+/* Subroutine */ int dtgsna_(char *job, char *howmny, logical *select,
+ integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb,
+ doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr,
+ doublereal *s, doublereal *dif, integer *mm, integer *m, doublereal *
+ work, integer *lwork, integer *iwork, integer *info);
+
+/* Subroutine */ int dtgsy2_(char *trans, integer *ijob, integer *m, integer *
+ n, doublereal *a, integer *lda, doublereal *b, integer *ldb,
+ doublereal *c__, integer *ldc, doublereal *d__, integer *ldd,
+ doublereal *e, integer *lde, doublereal *f, integer *ldf, doublereal *
+ scale, doublereal *rdsum, doublereal *rdscal, integer *iwork, integer
+ *pq, integer *info);
+
+/* Subroutine */ int dtgsyl_(char *trans, integer *ijob, integer *m, integer *
+ n, doublereal *a, integer *lda, doublereal *b, integer *ldb,
+ doublereal *c__, integer *ldc, doublereal *d__, integer *ldd,
+ doublereal *e, integer *lde, doublereal *f, integer *ldf, doublereal *
+ scale, doublereal *dif, doublereal *work, integer *lwork, integer *
+ iwork, integer *info);
+
+/* Subroutine */ int dtpcon_(char *norm, char *uplo, char *diag, integer *n,
+ doublereal *ap, doublereal *rcond, doublereal *work, integer *iwork,
+ integer *info);
+
+/* Subroutine */ int dtprfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublereal *ap, doublereal *b, integer *ldb,
+ doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr,
+ doublereal *work, integer *iwork, integer *info);
+
+/* Subroutine */ int dtptri_(char *uplo, char *diag, integer *n, doublereal *
+ ap, integer *info);
+
+/* Subroutine */ int dtptrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublereal *ap, doublereal *b, integer *ldb, integer *
+ info);
+
+/* Subroutine */ int dtpttf_(char *transr, char *uplo, integer *n, doublereal
+ *ap, doublereal *arf, integer *info);
+
+/* Subroutine */ int dtpttr_(char *uplo, integer *n, doublereal *ap,
+ doublereal *a, integer *lda, integer *info);
+
+/* Subroutine */ int dtrcon_(char *norm, char *uplo, char *diag, integer *n,
+ doublereal *a, integer *lda, doublereal *rcond, doublereal *work,
+ integer *iwork, integer *info);
+
+/* Subroutine */ int dtrevc_(char *side, char *howmny, logical *select,
+ integer *n, doublereal *t, integer *ldt, doublereal *vl, integer *
+ ldvl, doublereal *vr, integer *ldvr, integer *mm, integer *m,
+ doublereal *work, integer *info);
+
+/* Subroutine */ int dtrexc_(char *compq, integer *n, doublereal *t, integer *
+ ldt, doublereal *q, integer *ldq, integer *ifst, integer *ilst,
+ doublereal *work, integer *info);
+
+/* Subroutine */ int dtrrfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *
+ ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr,
+ doublereal *work, integer *iwork, integer *info);
+
+/* Subroutine */ int dtrsen_(char *job, char *compq, logical *select, integer
+ *n, doublereal *t, integer *ldt, doublereal *q, integer *ldq,
+ doublereal *wr, doublereal *wi, integer *m, doublereal *s, doublereal
+ *sep, doublereal *work, integer *lwork, integer *iwork, integer *
+ liwork, integer *info);
+
+/* Subroutine */ int dtrsna_(char *job, char *howmny, logical *select,
+ integer *n, doublereal *t, integer *ldt, doublereal *vl, integer *
+ ldvl, doublereal *vr, integer *ldvr, doublereal *s, doublereal *sep,
+ integer *mm, integer *m, doublereal *work, integer *ldwork, integer *
+ iwork, integer *info);
+
+/* Subroutine */ int dtrsyl_(char *trana, char *tranb, integer *isgn, integer
+ *m, integer *n, doublereal *a, integer *lda, doublereal *b, integer *
+ ldb, doublereal *c__, integer *ldc, doublereal *scale, integer *info);
+
+/* Subroutine */ int dtrti2_(char *uplo, char *diag, integer *n, doublereal *
+ a, integer *lda, integer *info);
+
+/* Subroutine */ int dtrtri_(char *uplo, char *diag, integer *n, doublereal *
+ a, integer *lda, integer *info);
+
+/* Subroutine */ int dtrtrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *
+ ldb, integer *info);
+
+/* Subroutine */ int dtrttf_(char *transr, char *uplo, integer *n, doublereal
+ *a, integer *lda, doublereal *arf, integer *info);
+
+/* Subroutine */ int dtrttp_(char *uplo, integer *n, doublereal *a, integer *
+ lda, doublereal *ap, integer *info);
+
+/* Subroutine */ int dtzrqf_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *tau, integer *info);
+
+/* Subroutine */ int dtzrzf_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);
+
+doublereal dzsum1_(integer *n, doublecomplex *cx, integer *incx);
+
+integer icmax1_(integer *n, complex *cx, integer *incx);
+
+integer ieeeck_(integer *ispec, real *zero, real *one);
+
+integer ilaclc_(integer *m, integer *n, complex *a, integer *lda);
+
+integer ilaclr_(integer *m, integer *n, complex *a, integer *lda);
+
+integer iladiag_(char *diag);
+
+integer iladlc_(integer *m, integer *n, doublereal *a, integer *lda);
+
+integer iladlr_(integer *m, integer *n, doublereal *a, integer *lda);
+
+integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1,
+ integer *n2, integer *n3, integer *n4);
+
+integer ilaprec_(char *prec);
+
+integer ilaslc_(integer *m, integer *n, real *a, integer *lda);
+
+integer ilaslr_(integer *m, integer *n, real *a, integer *lda);
+
+integer ilatrans_(char *trans);
+
+integer ilauplo_(char *uplo);
+
+/* Subroutine */ int ilaver_(integer *vers_major__, integer *vers_minor__,
+ integer *vers_patch__);
+
+integer ilazlc_(integer *m, integer *n, doublecomplex *a, integer *lda);
+
+integer ilazlr_(integer *m, integer *n, doublecomplex *a, integer *lda);
+
+integer iparmq_(integer *ispec, char *name__, char *opts, integer *n, integer
+ *ilo, integer *ihi, integer *lwork);
+
+integer izmax1_(integer *n, doublecomplex *cx, integer *incx);
+
+logical lsamen_(integer *n, char *ca, char *cb);
+
+integer smaxloc_(real *a, integer *dimm);
+
+/* Subroutine */ int sbdsdc_(char *uplo, char *compq, integer *n, real *d__,
+ real *e, real *u, integer *ldu, real *vt, integer *ldvt, real *q,
+ integer *iq, real *work, integer *iwork, integer *info);
+
+/* Subroutine */ int sbdsqr_(char *uplo, integer *n, integer *ncvt, integer *
+ nru, integer *ncc, real *d__, real *e, real *vt, integer *ldvt, real *
+ u, integer *ldu, real *c__, integer *ldc, real *work, integer *info);
+
+doublereal scsum1_(integer *n, complex *cx, integer *incx);
+
+/* Subroutine */ int sdisna_(char *job, integer *m, integer *n, real *d__,
+ real *sep, integer *info);
+
+/* Subroutine */ int sgbbrd_(char *vect, integer *m, integer *n, integer *ncc,
+ integer *kl, integer *ku, real *ab, integer *ldab, real *d__, real *
+ e, real *q, integer *ldq, real *pt, integer *ldpt, real *c__, integer
+ *ldc, real *work, integer *info);
+
+/* Subroutine */ int sgbcon_(char *norm, integer *n, integer *kl, integer *ku,
+ real *ab, integer *ldab, integer *ipiv, real *anorm, real *rcond,
+ real *work, integer *iwork, integer *info);
+
+/* Subroutine */ int sgbequ_(integer *m, integer *n, integer *kl, integer *ku,
+ real *ab, integer *ldab, real *r__, real *c__, real *rowcnd, real *
+ colcnd, real *amax, integer *info);
+
+/* Subroutine */ int sgbequb_(integer *m, integer *n, integer *kl, integer *
+ ku, real *ab, integer *ldab, real *r__, real *c__, real *rowcnd, real
+ *colcnd, real *amax, integer *info);
+
+/* Subroutine */ int sgbrfs_(char *trans, integer *n, integer *kl, integer *
+ ku, integer *nrhs, real *ab, integer *ldab, real *afb, integer *ldafb,
+ integer *ipiv, real *b, integer *ldb, real *x, integer *ldx, real *
+ ferr, real *berr, real *work, integer *iwork, integer *info);
+
+/* Subroutine */ int sgbrfsx_(char *trans, char *equed, integer *n, integer *
+ kl, integer *ku, integer *nrhs, real *ab, integer *ldab, real *afb,
+ integer *ldafb, integer *ipiv, real *r__, real *c__, real *b, integer
+ *ldb, real *x, integer *ldx, real *rcond, real *berr, integer *
+ n_err_bnds__, real *err_bnds_norm__, real *err_bnds_comp__, integer *
+ nparams, real *params, real *work, integer *iwork, integer *info);
+
+/* Subroutine */ int sgbsv_(integer *n, integer *kl, integer *ku, integer *
+ nrhs, real *ab, integer *ldab, integer *ipiv, real *b, integer *ldb,
+ integer *info);
+
+/* Subroutine */ int sgbsvx_(char *fact, char *trans, integer *n, integer *kl,
+ integer *ku, integer *nrhs, real *ab, integer *ldab, real *afb,
+ integer *ldafb, integer *ipiv, char *equed, real *r__, real *c__,
+ real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *ferr,
+ real *berr, real *work, integer *iwork, integer *info);
+
+/* Subroutine */ int sgbsvxx_(char *fact, char *trans, integer *n, integer *
+ kl, integer *ku, integer *nrhs, real *ab, integer *ldab, real *afb,
+ integer *ldafb, integer *ipiv, char *equed, real *r__, real *c__,
+ real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *
+ rpvgrw, real *berr, integer *n_err_bnds__, real *err_bnds_norm__,
+ real *err_bnds_comp__, integer *nparams, real *params, real *work,
+ integer *iwork, integer *info);
+
+/* Subroutine */ int sgbtf2_(integer *m, integer *n, integer *kl, integer *ku,
+ real *ab, integer *ldab, integer *ipiv, integer *info);
+
+/* Subroutine */ int sgbtrf_(integer *m, integer *n, integer *kl, integer *ku,
+ real *ab, integer *ldab, integer *ipiv, integer *info);
+
+/* Subroutine */ int sgbtrs_(char *trans, integer *n, integer *kl, integer *
+ ku, integer *nrhs, real *ab, integer *ldab, integer *ipiv, real *b,
+ integer *ldb, integer *info);
+
+/* Subroutine */ int sgebak_(char *job, char *side, integer *n, integer *ilo,
+ integer *ihi, real *scale, integer *m, real *v, integer *ldv, integer
+ *info);
+
+/* Subroutine */ int sgebal_(char *job, integer *n, real *a, integer *lda,
+ integer *ilo, integer *ihi, real *scale, integer *info);
+
+/* Subroutine */ int sgebd2_(integer *m, integer *n, real *a, integer *lda,
+ real *d__, real *e, real *tauq, real *taup, real *work, integer *info);
+
+/* Subroutine */ int sgebrd_(integer *m, integer *n, real *a, integer *lda,
+ real *d__, real *e, real *tauq, real *taup, real *work, integer *
+ lwork, integer *info);
+
+/* Subroutine */ int sgecon_(char *norm, integer *n, real *a, integer *lda,
+ real *anorm, real *rcond, real *work, integer *iwork, integer *info);
+
+/* Subroutine */ int sgeequ_(integer *m, integer *n, real *a, integer *lda,
+ real *r__, real *c__, real *rowcnd, real *colcnd, real *amax, integer
+ *info);
+
+/* Subroutine */ int sgeequb_(integer *m, integer *n, real *a, integer *lda,
+ real *r__, real *c__, real *rowcnd, real *colcnd, real *amax, integer
+ *info);
+
+/* Subroutine */ int sgees_(char *jobvs, char *sort, L_fp select, integer *n,
+ real *a, integer *lda, integer *sdim, real *wr, real *wi, real *vs,
+ integer *ldvs, real *work, integer *lwork, logical *bwork, integer *
+ info);
+
+/* Subroutine */ int sgeesx_(char *jobvs, char *sort, L_fp select, char *
+ sense, integer *n, real *a, integer *lda, integer *sdim, real *wr,
+ real *wi, real *vs, integer *ldvs, real *rconde, real *rcondv, real *
+ work, integer *lwork, integer *iwork, integer *liwork, logical *bwork,
+ integer *info);
+
+/* Subroutine */ int sgeev_(char *jobvl, char *jobvr, integer *n, real *a,
+ integer *lda, real *wr, real *wi, real *vl, integer *ldvl, real *vr,
+ integer *ldvr, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sgeevx_(char *balanc, char *jobvl, char *jobvr, char *
+ sense, integer *n, real *a, integer *lda, real *wr, real *wi, real *
+ vl, integer *ldvl, real *vr, integer *ldvr, integer *ilo, integer *
+ ihi, real *scale, real *abnrm, real *rconde, real *rcondv, real *work,
+ integer *lwork, integer *iwork, integer *info);
+
+/* Subroutine */ int sgegs_(char *jobvsl, char *jobvsr, integer *n, real *a,
+ integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real
+ *beta, real *vsl, integer *ldvsl, real *vsr, integer *ldvsr, real *
+ work, integer *lwork, integer *info);
+
+/* Subroutine */ int sgegv_(char *jobvl, char *jobvr, integer *n, real *a,
+ integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real
+ *beta, real *vl, integer *ldvl, real *vr, integer *ldvr, real *work,
+ integer *lwork, integer *info);
+
+/* Subroutine */ int sgehd2_(integer *n, integer *ilo, integer *ihi, real *a,
+ integer *lda, real *tau, real *work, integer *info);
+
+/* Subroutine */ int sgehrd_(integer *n, integer *ilo, integer *ihi, real *a,
+ integer *lda, real *tau, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sgejsv_(char *joba, char *jobu, char *jobv, char *jobr,
+ char *jobt, char *jobp, integer *m, integer *n, real *a, integer *lda,
+ real *sva, real *u, integer *ldu, real *v, integer *ldv, real *work,
+ integer *lwork, integer *iwork, integer *info);
+
+/* Subroutine */ int sgelq2_(integer *m, integer *n, real *a, integer *lda,
+ real *tau, real *work, integer *info);
+
+/* Subroutine */ int sgelqf_(integer *m, integer *n, real *a, integer *lda,
+ real *tau, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sgels_(char *trans, integer *m, integer *n, integer *
+ nrhs, real *a, integer *lda, real *b, integer *ldb, real *work,
+ integer *lwork, integer *info);
+
+/* Subroutine */ int sgelsd_(integer *m, integer *n, integer *nrhs, real *a,
+ integer *lda, real *b, integer *ldb, real *s, real *rcond, integer *
+ rank, real *work, integer *lwork, integer *iwork, integer *info);
+
+/* Subroutine */ int sgelss_(integer *m, integer *n, integer *nrhs, real *a,
+ integer *lda, real *b, integer *ldb, real *s, real *rcond, integer *
+ rank, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sgelsx_(integer *m, integer *n, integer *nrhs, real *a,
+ integer *lda, real *b, integer *ldb, integer *jpvt, real *rcond,
+ integer *rank, real *work, integer *info);
+
+/* Subroutine */ int sgelsy_(integer *m, integer *n, integer *nrhs, real *a,
+ integer *lda, real *b, integer *ldb, integer *jpvt, real *rcond,
+ integer *rank, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sgeql2_(integer *m, integer *n, real *a, integer *lda,
+ real *tau, real *work, integer *info);
+
+/* Subroutine */ int sgeqlf_(integer *m, integer *n, real *a, integer *lda,
+ real *tau, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sgeqp3_(integer *m, integer *n, real *a, integer *lda,
+ integer *jpvt, real *tau, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sgeqpf_(integer *m, integer *n, real *a, integer *lda,
+ integer *jpvt, real *tau, real *work, integer *info);
+
+/* Subroutine */ int sgeqr2_(integer *m, integer *n, real *a, integer *lda,
+ real *tau, real *work, integer *info);
+
+/* Subroutine */ int sgeqrf_(integer *m, integer *n, real *a, integer *lda,
+ real *tau, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sgerfs_(char *trans, integer *n, integer *nrhs, real *a,
+ integer *lda, real *af, integer *ldaf, integer *ipiv, real *b,
+ integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *
+ work, integer *iwork, integer *info);
+
+/* Subroutine */ int sgerfsx_(char *trans, char *equed, integer *n, integer *
+ nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv,
+ real *r__, real *c__, real *b, integer *ldb, real *x, integer *ldx,
+ real *rcond, real *berr, integer *n_err_bnds__, real *err_bnds_norm__,
+ real *err_bnds_comp__, integer *nparams, real *params, real *work,
+ integer *iwork, integer *info);
+
+/* Subroutine */ int sgerq2_(integer *m, integer *n, real *a, integer *lda,
+ real *tau, real *work, integer *info);
+
+/* Subroutine */ int sgerqf_(integer *m, integer *n, real *a, integer *lda,
+ real *tau, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sgesc2_(integer *n, real *a, integer *lda, real *rhs,
+ integer *ipiv, integer *jpiv, real *scale);
+
+/* Subroutine */ int sgesdd_(char *jobz, integer *m, integer *n, real *a,
+ integer *lda, real *s, real *u, integer *ldu, real *vt, integer *ldvt,
+ real *work, integer *lwork, integer *iwork, integer *info);
+
+/* Subroutine */ int sgesv_(integer *n, integer *nrhs, real *a, integer *lda,
+ integer *ipiv, real *b, integer *ldb, integer *info);
+
+/* Subroutine */ int sgesvd_(char *jobu, char *jobvt, integer *m, integer *n,
+ real *a, integer *lda, real *s, real *u, integer *ldu, real *vt,
+ integer *ldvt, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sgesvj_(char *joba, char *jobu, char *jobv, integer *m,
+ integer *n, real *a, integer *lda, real *sva, integer *mv, real *v,
+ integer *ldv, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sgesvx_(char *fact, char *trans, integer *n, integer *
+ nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv,
+ char *equed, real *r__, real *c__, real *b, integer *ldb, real *x,
+ integer *ldx, real *rcond, real *ferr, real *berr, real *work,
+ integer *iwork, integer *info);
+
+/* Subroutine */ int sgesvxx_(char *fact, char *trans, integer *n, integer *
+ nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv,
+ char *equed, real *r__, real *c__, real *b, integer *ldb, real *x,
+ integer *ldx, real *rcond, real *rpvgrw, real *berr, integer *
+ n_err_bnds__, real *err_bnds_norm__, real *err_bnds_comp__, integer *
+ nparams, real *params, real *work, integer *iwork, integer *info);
+
+/* Subroutine */ int sgetc2_(integer *n, real *a, integer *lda, integer *ipiv,
+ integer *jpiv, integer *info);
+
+/* Subroutine */ int sgetf2_(integer *m, integer *n, real *a, integer *lda,
+ integer *ipiv, integer *info);
+
+/* Subroutine */ int sgetrf_(integer *m, integer *n, real *a, integer *lda,
+ integer *ipiv, integer *info);
+
+/* Subroutine */ int sgetri_(integer *n, real *a, integer *lda, integer *ipiv,
+ real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sgetrs_(char *trans, integer *n, integer *nrhs, real *a,
+ integer *lda, integer *ipiv, real *b, integer *ldb, integer *info);
+
+/* Subroutine */ int sggbak_(char *job, char *side, integer *n, integer *ilo,
+ integer *ihi, real *lscale, real *rscale, integer *m, real *v,
+ integer *ldv, integer *info);
+
+/* Subroutine */ int sggbal_(char *job, integer *n, real *a, integer *lda,
+ real *b, integer *ldb, integer *ilo, integer *ihi, real *lscale, real
+ *rscale, real *work, integer *info);
+
+/* Subroutine */ int sgges_(char *jobvsl, char *jobvsr, char *sort, L_fp
+ selctg, integer *n, real *a, integer *lda, real *b, integer *ldb,
+ integer *sdim, real *alphar, real *alphai, real *beta, real *vsl,
+ integer *ldvsl, real *vsr, integer *ldvsr, real *work, integer *lwork,
+ logical *bwork, integer *info);
+
+/* Subroutine */ int sggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp
+ selctg, char *sense, integer *n, real *a, integer *lda, real *b,
+ integer *ldb, integer *sdim, real *alphar, real *alphai, real *beta,
+ real *vsl, integer *ldvsl, real *vsr, integer *ldvsr, real *rconde,
+ real *rcondv, real *work, integer *lwork, integer *iwork, integer *
+ liwork, logical *bwork, integer *info);
+
+/* Subroutine */ int sggev_(char *jobvl, char *jobvr, integer *n, real *a,
+ integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real
+ *beta, real *vl, integer *ldvl, real *vr, integer *ldvr, real *work,
+ integer *lwork, integer *info);
+
+/* Subroutine */ int sggevx_(char *balanc, char *jobvl, char *jobvr, char *
+ sense, integer *n, real *a, integer *lda, real *b, integer *ldb, real
+ *alphar, real *alphai, real *beta, real *vl, integer *ldvl, real *vr,
+ integer *ldvr, integer *ilo, integer *ihi, real *lscale, real *rscale,
+ real *abnrm, real *bbnrm, real *rconde, real *rcondv, real *work,
+ integer *lwork, integer *iwork, logical *bwork, integer *info);
+
+/* Subroutine */ int sggglm_(integer *n, integer *m, integer *p, real *a,
+ integer *lda, real *b, integer *ldb, real *d__, real *x, real *y,
+ real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sgghrd_(char *compq, char *compz, integer *n, integer *
+ ilo, integer *ihi, real *a, integer *lda, real *b, integer *ldb, real
+ *q, integer *ldq, real *z__, integer *ldz, integer *info);
+
+/* Subroutine */ int sgglse_(integer *m, integer *n, integer *p, real *a,
+ integer *lda, real *b, integer *ldb, real *c__, real *d__, real *x,
+ real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sggqrf_(integer *n, integer *m, integer *p, real *a,
+ integer *lda, real *taua, real *b, integer *ldb, real *taub, real *
+ work, integer *lwork, integer *info);
+
+/* Subroutine */ int sggrqf_(integer *m, integer *p, integer *n, real *a,
+ integer *lda, real *taua, real *b, integer *ldb, real *taub, real *
+ work, integer *lwork, integer *info);
+
+/* Subroutine */ int sggsvd_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *n, integer *p, integer *k, integer *l, real *a, integer *lda,
+ real *b, integer *ldb, real *alpha, real *beta, real *u, integer *
+ ldu, real *v, integer *ldv, real *q, integer *ldq, real *work,
+ integer *iwork, integer *info);
+
+/* Subroutine */ int sggsvp_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *p, integer *n, real *a, integer *lda, real *b, integer *ldb,
+ real *tola, real *tolb, integer *k, integer *l, real *u, integer *ldu,
+ real *v, integer *ldv, real *q, integer *ldq, integer *iwork, real *
+ tau, real *work, integer *info);
+
+/* Subroutine */ int sgsvj0_(char *jobv, integer *m, integer *n, real *a,
+ integer *lda, real *d__, real *sva, integer *mv, real *v, integer *
+ ldv, real *eps, real *sfmin, real *tol, integer *nsweep, real *work,
+ integer *lwork, integer *info);
+
+/* Subroutine */ int sgsvj1_(char *jobv, integer *m, integer *n, integer *n1,
+ real *a, integer *lda, real *d__, real *sva, integer *mv, real *v,
+ integer *ldv, real *eps, real *sfmin, real *tol, integer *nsweep,
+ real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sgtcon_(char *norm, integer *n, real *dl, real *d__,
+ real *du, real *du2, integer *ipiv, real *anorm, real *rcond, real *
+ work, integer *iwork, integer *info);
+
+/* Subroutine */ int sgtrfs_(char *trans, integer *n, integer *nrhs, real *dl,
+ real *d__, real *du, real *dlf, real *df, real *duf, real *du2,
+ integer *ipiv, real *b, integer *ldb, real *x, integer *ldx, real *
+ ferr, real *berr, real *work, integer *iwork, integer *info);
+
+/* Subroutine */ int sgtsv_(integer *n, integer *nrhs, real *dl, real *d__,
+ real *du, real *b, integer *ldb, integer *info);
+
+/* Subroutine */ int sgtsvx_(char *fact, char *trans, integer *n, integer *
+ nrhs, real *dl, real *d__, real *du, real *dlf, real *df, real *duf,
+ real *du2, integer *ipiv, real *b, integer *ldb, real *x, integer *
+ ldx, real *rcond, real *ferr, real *berr, real *work, integer *iwork,
+ integer *info);
+
+/* Subroutine */ int sgttrf_(integer *n, real *dl, real *d__, real *du, real *
+ du2, integer *ipiv, integer *info);
+
+/* Subroutine */ int sgttrs_(char *trans, integer *n, integer *nrhs, real *dl,
+ real *d__, real *du, real *du2, integer *ipiv, real *b, integer *ldb,
+ integer *info);
+
+/* Subroutine */ int sgtts2_(integer *itrans, integer *n, integer *nrhs, real
+ *dl, real *d__, real *du, real *du2, integer *ipiv, real *b, integer *
+ ldb);
+
+/* Subroutine */ int shgeqz_(char *job, char *compq, char *compz, integer *n,
+ integer *ilo, integer *ihi, real *h__, integer *ldh, real *t, integer
+ *ldt, real *alphar, real *alphai, real *beta, real *q, integer *ldq,
+ real *z__, integer *ldz, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int shsein_(char *side, char *eigsrc, char *initv, logical *
+ select, integer *n, real *h__, integer *ldh, real *wr, real *wi, real
+ *vl, integer *ldvl, real *vr, integer *ldvr, integer *mm, integer *m,
+ real *work, integer *ifaill, integer *ifailr, integer *info);
+
+/* Subroutine */ int shseqr_(char *job, char *compz, integer *n, integer *ilo,
+ integer *ihi, real *h__, integer *ldh, real *wr, real *wi, real *z__,
+ integer *ldz, real *work, integer *lwork, integer *info);
+
+logical sisnan_(real *sin__);
+
+/* Subroutine */ int sla_gbamv__(integer *trans, integer *m, integer *n,
+ integer *kl, integer *ku, real *alpha, real *ab, integer *ldab, real *
+ x, integer *incx, real *beta, real *y, integer *incy);
+
+doublereal sla_gbrcond__(char *trans, integer *n, integer *kl, integer *ku,
+ real *ab, integer *ldab, real *afb, integer *ldafb, integer *ipiv,
+ integer *cmode, real *c__, integer *info, real *work, integer *iwork,
+ ftnlen trans_len);
+
+/* Subroutine */ int sla_gbrfsx_extended__(integer *prec_type__, integer *
+ trans_type__, integer *n, integer *kl, integer *ku, integer *nrhs,
+ real *ab, integer *ldab, real *afb, integer *ldafb, integer *ipiv,
+ logical *colequ, real *c__, real *b, integer *ldb, real *y, integer *
+ ldy, real *berr_out__, integer *n_norms__, real *errs_n__, real *
+ errs_c__, real *res, real *ayb, real *dy, real *y_tail__, real *rcond,
+ integer *ithresh, real *rthresh, real *dz_ub__, logical *
+ ignore_cwise__, integer *info);
+
+doublereal sla_gbrpvgrw__(integer *n, integer *kl, integer *ku, integer *
+ ncols, real *ab, integer *ldab, real *afb, integer *ldafb);
+
+/* Subroutine */ int sla_geamv__(integer *trans, integer *m, integer *n, real
+ *alpha, real *a, integer *lda, real *x, integer *incx, real *beta,
+ real *y, integer *incy);
+
+doublereal sla_gercond__(char *trans, integer *n, real *a, integer *lda, real
+ *af, integer *ldaf, integer *ipiv, integer *cmode, real *c__, integer
+ *info, real *work, integer *iwork, ftnlen trans_len);
+
+/* Subroutine */ int sla_gerfsx_extended__(integer *prec_type__, integer *
+ trans_type__, integer *n, integer *nrhs, real *a, integer *lda, real *
+ af, integer *ldaf, integer *ipiv, logical *colequ, real *c__, real *b,
+ integer *ldb, real *y, integer *ldy, real *berr_out__, integer *
+ n_norms__, real *errs_n__, real *errs_c__, real *res, real *ayb, real
+ *dy, real *y_tail__, real *rcond, integer *ithresh, real *rthresh,
+ real *dz_ub__, logical *ignore_cwise__, integer *info);
+
+/* Subroutine */ int sla_lin_berr__(integer *n, integer *nz, integer *nrhs,
+ real *res, real *ayb, real *berr);
+
+doublereal sla_porcond__(char *uplo, integer *n, real *a, integer *lda, real *
+ af, integer *ldaf, integer *cmode, real *c__, integer *info, real *
+ work, integer *iwork, ftnlen uplo_len);
+
+/* Subroutine */ int sla_porfsx_extended__(integer *prec_type__, char *uplo,
+ integer *n, integer *nrhs, real *a, integer *lda, real *af, integer *
+ ldaf, logical *colequ, real *c__, real *b, integer *ldb, real *y,
+ integer *ldy, real *berr_out__, integer *n_norms__, real *errs_n__,
+ real *errs_c__, real *res, real *ayb, real *dy, real *y_tail__, real *
+ rcond, integer *ithresh, real *rthresh, real *dz_ub__, logical *
+ ignore_cwise__, integer *info, ftnlen uplo_len);
+
+doublereal sla_porpvgrw__(char *uplo, integer *ncols, real *a, integer *lda,
+ real *af, integer *ldaf, real *work, ftnlen uplo_len);
+
+doublereal sla_rpvgrw__(integer *n, integer *ncols, real *a, integer *lda,
+ real *af, integer *ldaf);
+
+/* Subroutine */ int sla_syamv__(integer *uplo, integer *n, real *alpha, real
+ *a, integer *lda, real *x, integer *incx, real *beta, real *y,
+ integer *incy);
+
+doublereal sla_syrcond__(char *uplo, integer *n, real *a, integer *lda, real *
+ af, integer *ldaf, integer *ipiv, integer *cmode, real *c__, integer *
+ info, real *work, integer *iwork, ftnlen uplo_len);
+
+/* Subroutine */ int sla_syrfsx_extended__(integer *prec_type__, char *uplo,
+ integer *n, integer *nrhs, real *a, integer *lda, real *af, integer *
+ ldaf, integer *ipiv, logical *colequ, real *c__, real *b, integer *
+ ldb, real *y, integer *ldy, real *berr_out__, integer *n_norms__,
+ real *errs_n__, real *errs_c__, real *res, real *ayb, real *dy, real *
+ y_tail__, real *rcond, integer *ithresh, real *rthresh, real *dz_ub__,
+ logical *ignore_cwise__, integer *info, ftnlen uplo_len);
+
+doublereal sla_syrpvgrw__(char *uplo, integer *n, integer *info, real *a,
+ integer *lda, real *af, integer *ldaf, integer *ipiv, real *work,
+ ftnlen uplo_len);
+
+/* Subroutine */ int sla_wwaddw__(integer *n, real *x, real *y, real *w);
+
+/* Subroutine */ int slabad_(real *small, real *large);
+
+/* Subroutine */ int slabrd_(integer *m, integer *n, integer *nb, real *a,
+ integer *lda, real *d__, real *e, real *tauq, real *taup, real *x,
+ integer *ldx, real *y, integer *ldy);
+
+/* Subroutine */ int slacn2_(integer *n, real *v, real *x, integer *isgn,
+ real *est, integer *kase, integer *isave);
+
+/* Subroutine */ int slacon_(integer *n, real *v, real *x, integer *isgn,
+ real *est, integer *kase);
+
+/* Subroutine */ int slacpy_(char *uplo, integer *m, integer *n, real *a,
+ integer *lda, real *b, integer *ldb);
+
+/* Subroutine */ int sladiv_(real *a, real *b, real *c__, real *d__, real *p,
+ real *q);
+
+/* Subroutine */ int slae2_(real *a, real *b, real *c__, real *rt1, real *rt2);
+
+/* Subroutine */ int slaebz_(integer *ijob, integer *nitmax, integer *n,
+ integer *mmax, integer *minp, integer *nbmin, real *abstol, real *
+ reltol, real *pivmin, real *d__, real *e, real *e2, integer *nval,
+ real *ab, real *c__, integer *mout, integer *nab, real *work, integer
+ *iwork, integer *info);
+
+/* Subroutine */ int slaed0_(integer *icompq, integer *qsiz, integer *n, real
+ *d__, real *e, real *q, integer *ldq, real *qstore, integer *ldqs,
+ real *work, integer *iwork, integer *info);
+
+/* Subroutine */ int slaed1_(integer *n, real *d__, real *q, integer *ldq,
+ integer *indxq, real *rho, integer *cutpnt, real *work, integer *
+ iwork, integer *info);
+
+/* Subroutine */ int slaed2_(integer *k, integer *n, integer *n1, real *d__,
+ real *q, integer *ldq, integer *indxq, real *rho, real *z__, real *
+ dlamda, real *w, real *q2, integer *indx, integer *indxc, integer *
+ indxp, integer *coltyp, integer *info);
+
+/* Subroutine */ int slaed3_(integer *k, integer *n, integer *n1, real *d__,
+ real *q, integer *ldq, real *rho, real *dlamda, real *q2, integer *
+ indx, integer *ctot, real *w, real *s, integer *info);
+
+/* Subroutine */ int slaed4_(integer *n, integer *i__, real *d__, real *z__,
+ real *delta, real *rho, real *dlam, integer *info);
+
+/* Subroutine */ int slaed5_(integer *i__, real *d__, real *z__, real *delta,
+ real *rho, real *dlam);
+
+/* Subroutine */ int slaed6_(integer *kniter, logical *orgati, real *rho,
+ real *d__, real *z__, real *finit, real *tau, integer *info);
+
+/* Subroutine */ int slaed7_(integer *icompq, integer *n, integer *qsiz,
+ integer *tlvls, integer *curlvl, integer *curpbm, real *d__, real *q,
+ integer *ldq, integer *indxq, real *rho, integer *cutpnt, real *
+ qstore, integer *qptr, integer *prmptr, integer *perm, integer *
+ givptr, integer *givcol, real *givnum, real *work, integer *iwork,
+ integer *info);
+
+/* Subroutine */ int slaed8_(integer *icompq, integer *k, integer *n, integer
+ *qsiz, real *d__, real *q, integer *ldq, integer *indxq, real *rho,
+ integer *cutpnt, real *z__, real *dlamda, real *q2, integer *ldq2,
+ real *w, integer *perm, integer *givptr, integer *givcol, real *
+ givnum, integer *indxp, integer *indx, integer *info);
+
+/* Subroutine */ int slaed9_(integer *k, integer *kstart, integer *kstop,
+ integer *n, real *d__, real *q, integer *ldq, real *rho, real *dlamda,
+ real *w, real *s, integer *lds, integer *info);
+
+/* Subroutine */ int slaeda_(integer *n, integer *tlvls, integer *curlvl,
+ integer *curpbm, integer *prmptr, integer *perm, integer *givptr,
+ integer *givcol, real *givnum, real *q, integer *qptr, real *z__,
+ real *ztemp, integer *info);
+
+/* Subroutine */ int slaein_(logical *rightv, logical *noinit, integer *n,
+ real *h__, integer *ldh, real *wr, real *wi, real *vr, real *vi, real
+ *b, integer *ldb, real *work, real *eps3, real *smlnum, real *bignum,
+ integer *info);
+
+/* Subroutine */ int slaev2_(real *a, real *b, real *c__, real *rt1, real *
+ rt2, real *cs1, real *sn1);
+
+/* Subroutine */ int slaexc_(logical *wantq, integer *n, real *t, integer *
+ ldt, real *q, integer *ldq, integer *j1, integer *n1, integer *n2,
+ real *work, integer *info);
+
+/* Subroutine */ int slag2_(real *a, integer *lda, real *b, integer *ldb,
+ real *safmin, real *scale1, real *scale2, real *wr1, real *wr2, real *
+ wi);
+
+/* Subroutine */ int slag2d_(integer *m, integer *n, real *sa, integer *ldsa,
+ doublereal *a, integer *lda, integer *info);
+
+/* Subroutine */ int slags2_(logical *upper, real *a1, real *a2, real *a3,
+ real *b1, real *b2, real *b3, real *csu, real *snu, real *csv, real *
+ snv, real *csq, real *snq);
+
+/* Subroutine */ int slagtf_(integer *n, real *a, real *lambda, real *b, real
+ *c__, real *tol, real *d__, integer *in, integer *info);
+
+/* Subroutine */ int slagtm_(char *trans, integer *n, integer *nrhs, real *
+ alpha, real *dl, real *d__, real *du, real *x, integer *ldx, real *
+ beta, real *b, integer *ldb);
+
+/* Subroutine */ int slagts_(integer *job, integer *n, real *a, real *b, real
+ *c__, real *d__, integer *in, real *y, real *tol, integer *info);
+
+/* Subroutine */ int slagv2_(real *a, integer *lda, real *b, integer *ldb,
+ real *alphar, real *alphai, real *beta, real *csl, real *snl, real *
+ csr, real *snr);
+
+/* Subroutine */ int slahqr_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, real *h__, integer *ldh, real *wr, real *
+ wi, integer *iloz, integer *ihiz, real *z__, integer *ldz, integer *
+ info);
+
+/* Subroutine */ int slahr2_(integer *n, integer *k, integer *nb, real *a,
+ integer *lda, real *tau, real *t, integer *ldt, real *y, integer *ldy);
+
+/* Subroutine */ int slahrd_(integer *n, integer *k, integer *nb, real *a,
+ integer *lda, real *tau, real *t, integer *ldt, real *y, integer *ldy);
+
+/* Subroutine */ int slaic1_(integer *job, integer *j, real *x, real *sest,
+ real *w, real *gamma, real *sestpr, real *s, real *c__);
+
+logical slaisnan_(real *sin1, real *sin2);
+
+/* Subroutine */ int slaln2_(logical *ltrans, integer *na, integer *nw, real *
+ smin, real *ca, real *a, integer *lda, real *d1, real *d2, real *b,
+ integer *ldb, real *wr, real *wi, real *x, integer *ldx, real *scale,
+ real *xnorm, integer *info);
+
+/* Subroutine */ int slals0_(integer *icompq, integer *nl, integer *nr,
+ integer *sqre, integer *nrhs, real *b, integer *ldb, real *bx,
+ integer *ldbx, integer *perm, integer *givptr, integer *givcol,
+ integer *ldgcol, real *givnum, integer *ldgnum, real *poles, real *
+ difl, real *difr, real *z__, integer *k, real *c__, real *s, real *
+ work, integer *info);
+
+/* Subroutine */ int slalsa_(integer *icompq, integer *smlsiz, integer *n,
+ integer *nrhs, real *b, integer *ldb, real *bx, integer *ldbx, real *
+ u, integer *ldu, real *vt, integer *k, real *difl, real *difr, real *
+ z__, real *poles, integer *givptr, integer *givcol, integer *ldgcol,
+ integer *perm, real *givnum, real *c__, real *s, real *work, integer *
+ iwork, integer *info);
+
+/* Subroutine */ int slalsd_(char *uplo, integer *smlsiz, integer *n, integer
+ *nrhs, real *d__, real *e, real *b, integer *ldb, real *rcond,
+ integer *rank, real *work, integer *iwork, integer *info);
+
+/* Subroutine */ int slamrg_(integer *n1, integer *n2, real *a, integer *
+ strd1, integer *strd2, integer *index);
+
+integer slaneg_(integer *n, real *d__, real *lld, real *sigma, real *pivmin,
+ integer *r__);
+
+doublereal slangb_(char *norm, integer *n, integer *kl, integer *ku, real *ab,
+ integer *ldab, real *work);
+
+doublereal slange_(char *norm, integer *m, integer *n, real *a, integer *lda,
+ real *work);
+
+doublereal slangt_(char *norm, integer *n, real *dl, real *d__, real *du);
+
+doublereal slanhs_(char *norm, integer *n, real *a, integer *lda, real *work);
+
+doublereal slansb_(char *norm, char *uplo, integer *n, integer *k, real *ab,
+ integer *ldab, real *work);
+
+doublereal slansf_(char *norm, char *transr, char *uplo, integer *n, real *a,
+ real *work);
+
+doublereal slansp_(char *norm, char *uplo, integer *n, real *ap, real *work);
+
+doublereal slanst_(char *norm, integer *n, real *d__, real *e);
+
+doublereal slansy_(char *norm, char *uplo, integer *n, real *a, integer *lda,
+ real *work);
+
+doublereal slantb_(char *norm, char *uplo, char *diag, integer *n, integer *k,
+ real *ab, integer *ldab, real *work);
+
+doublereal slantp_(char *norm, char *uplo, char *diag, integer *n, real *ap,
+ real *work);
+
+doublereal slantr_(char *norm, char *uplo, char *diag, integer *m, integer *n,
+ real *a, integer *lda, real *work);
+
+/* Subroutine */ int slanv2_(real *a, real *b, real *c__, real *d__, real *
+ rt1r, real *rt1i, real *rt2r, real *rt2i, real *cs, real *sn);
+
+/* Subroutine */ int slapll_(integer *n, real *x, integer *incx, real *y,
+ integer *incy, real *ssmin);
+
+/* Subroutine */ int slapmt_(logical *forwrd, integer *m, integer *n, real *x,
+ integer *ldx, integer *k);
+
+doublereal slapy2_(real *x, real *y);
+
+doublereal slapy3_(real *x, real *y, real *z__);
+
+/* Subroutine */ int slaqgb_(integer *m, integer *n, integer *kl, integer *ku,
+ real *ab, integer *ldab, real *r__, real *c__, real *rowcnd, real *
+ colcnd, real *amax, char *equed);
+
+/* Subroutine */ int slaqge_(integer *m, integer *n, real *a, integer *lda,
+ real *r__, real *c__, real *rowcnd, real *colcnd, real *amax, char *
+ equed);
+
+/* Subroutine */ int slaqp2_(integer *m, integer *n, integer *offset, real *a,
+ integer *lda, integer *jpvt, real *tau, real *vn1, real *vn2, real *
+ work);
+
+/* Subroutine */ int slaqps_(integer *m, integer *n, integer *offset, integer
+ *nb, integer *kb, real *a, integer *lda, integer *jpvt, real *tau,
+ real *vn1, real *vn2, real *auxv, real *f, integer *ldf);
+
+/* Subroutine */ int slaqr0_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, real *h__, integer *ldh, real *wr, real *
+ wi, integer *iloz, integer *ihiz, real *z__, integer *ldz, real *work,
+ integer *lwork, integer *info);
+
+/* Subroutine */ int slaqr1_(integer *n, real *h__, integer *ldh, real *sr1,
+ real *si1, real *sr2, real *si2, real *v);
+
+/* Subroutine */ int slaqr2_(logical *wantt, logical *wantz, integer *n,
+ integer *ktop, integer *kbot, integer *nw, real *h__, integer *ldh,
+ integer *iloz, integer *ihiz, real *z__, integer *ldz, integer *ns,
+ integer *nd, real *sr, real *si, real *v, integer *ldv, integer *nh,
+ real *t, integer *ldt, integer *nv, real *wv, integer *ldwv, real *
+ work, integer *lwork);
+
+/* Subroutine */ int slaqr3_(logical *wantt, logical *wantz, integer *n,
+ integer *ktop, integer *kbot, integer *nw, real *h__, integer *ldh,
+ integer *iloz, integer *ihiz, real *z__, integer *ldz, integer *ns,
+ integer *nd, real *sr, real *si, real *v, integer *ldv, integer *nh,
+ real *t, integer *ldt, integer *nv, real *wv, integer *ldwv, real *
+ work, integer *lwork);
+
+/* Subroutine */ int slaqr4_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, real *h__, integer *ldh, real *wr, real *
+ wi, integer *iloz, integer *ihiz, real *z__, integer *ldz, real *work,
+ integer *lwork, integer *info);
+
+/* Subroutine */ int slaqr5_(logical *wantt, logical *wantz, integer *kacc22,
+ integer *n, integer *ktop, integer *kbot, integer *nshfts, real *sr,
+ real *si, real *h__, integer *ldh, integer *iloz, integer *ihiz, real
+ *z__, integer *ldz, real *v, integer *ldv, real *u, integer *ldu,
+ integer *nv, real *wv, integer *ldwv, integer *nh, real *wh, integer *
+ ldwh);
+
+/* Subroutine */ int slaqsb_(char *uplo, integer *n, integer *kd, real *ab,
+ integer *ldab, real *s, real *scond, real *amax, char *equed);
+
+/* Subroutine */ int slaqsp_(char *uplo, integer *n, real *ap, real *s, real *
+ scond, real *amax, char *equed);
+
+/* Subroutine */ int slaqsy_(char *uplo, integer *n, real *a, integer *lda,
+ real *s, real *scond, real *amax, char *equed);
+
+/* Subroutine */ int slaqtr_(logical *ltran, logical *lreal, integer *n, real
+ *t, integer *ldt, real *b, real *w, real *scale, real *x, real *work,
+ integer *info);
+
+/* Subroutine */ int slar1v_(integer *n, integer *b1, integer *bn, real *
+ lambda, real *d__, real *l, real *ld, real *lld, real *pivmin, real *
+ gaptol, real *z__, logical *wantnc, integer *negcnt, real *ztz, real *
+ mingma, integer *r__, integer *isuppz, real *nrminv, real *resid,
+ real *rqcorr, real *work);
+
+/* Subroutine */ int slar2v_(integer *n, real *x, real *y, real *z__, integer
+ *incx, real *c__, real *s, integer *incc);
+
+/* Subroutine */ int slarf_(char *side, integer *m, integer *n, real *v,
+ integer *incv, real *tau, real *c__, integer *ldc, real *work);
+
+/* Subroutine */ int slarfb_(char *side, char *trans, char *direct, char *
+ storev, integer *m, integer *n, integer *k, real *v, integer *ldv,
+ real *t, integer *ldt, real *c__, integer *ldc, real *work, integer *
+ ldwork);
+
+/* Subroutine */ int slarfg_(integer *n, real *alpha, real *x, integer *incx,
+ real *tau);
+
+/* Subroutine */ int slarfp_(integer *n, real *alpha, real *x, integer *incx,
+ real *tau);
+
+/* Subroutine */ int slarft_(char *direct, char *storev, integer *n, integer *
+ k, real *v, integer *ldv, real *tau, real *t, integer *ldt);
+
+/* Subroutine */ int slarfx_(char *side, integer *m, integer *n, real *v,
+ real *tau, real *c__, integer *ldc, real *work);
+
+/* Subroutine */ int slargv_(integer *n, real *x, integer *incx, real *y,
+ integer *incy, real *c__, integer *incc);
+
+/* Subroutine */ int slarnv_(integer *idist, integer *iseed, integer *n, real
+ *x);
+
+/* Subroutine */ int slarra_(integer *n, real *d__, real *e, real *e2, real *
+ spltol, real *tnrm, integer *nsplit, integer *isplit, integer *info);
+
+/* Subroutine */ int slarrb_(integer *n, real *d__, real *lld, integer *
+ ifirst, integer *ilast, real *rtol1, real *rtol2, integer *offset,
+ real *w, real *wgap, real *werr, real *work, integer *iwork, real *
+ pivmin, real *spdiam, integer *twist, integer *info);
+
+/* Subroutine */ int slarrc_(char *jobt, integer *n, real *vl, real *vu, real
+ *d__, real *e, real *pivmin, integer *eigcnt, integer *lcnt, integer *
+ rcnt, integer *info);
+
+/* Subroutine */ int slarrd_(char *range, char *order, integer *n, real *vl,
+ real *vu, integer *il, integer *iu, real *gers, real *reltol, real *
+ d__, real *e, real *e2, real *pivmin, integer *nsplit, integer *
+ isplit, integer *m, real *w, real *werr, real *wl, real *wu, integer *
+ iblock, integer *indexw, real *work, integer *iwork, integer *info);
+
+/* Subroutine */ int slarre_(char *range, integer *n, real *vl, real *vu,
+ integer *il, integer *iu, real *d__, real *e, real *e2, real *rtol1,
+ real *rtol2, real *spltol, integer *nsplit, integer *isplit, integer *
+ m, real *w, real *werr, real *wgap, integer *iblock, integer *indexw,
+ real *gers, real *pivmin, real *work, integer *iwork, integer *info);
+
+/* Subroutine */ int slarrf_(integer *n, real *d__, real *l, real *ld,
+ integer *clstrt, integer *clend, real *w, real *wgap, real *werr,
+ real *spdiam, real *clgapl, real *clgapr, real *pivmin, real *sigma,
+ real *dplus, real *lplus, real *work, integer *info);
+
+/* Subroutine */ int slarrj_(integer *n, real *d__, real *e2, integer *ifirst,
+ integer *ilast, real *rtol, integer *offset, real *w, real *werr,
+ real *work, integer *iwork, real *pivmin, real *spdiam, integer *info);
+
+/* Subroutine */ int slarrk_(integer *n, integer *iw, real *gl, real *gu,
+ real *d__, real *e2, real *pivmin, real *reltol, real *w, real *werr,
+ integer *info);
+
+/* Subroutine */ int slarrr_(integer *n, real *d__, real *e, integer *info);
+
+/* Subroutine */ int slarrv_(integer *n, real *vl, real *vu, real *d__, real *
+ l, real *pivmin, integer *isplit, integer *m, integer *dol, integer *
+ dou, real *minrgp, real *rtol1, real *rtol2, real *w, real *werr,
+ real *wgap, integer *iblock, integer *indexw, real *gers, real *z__,
+ integer *ldz, integer *isuppz, real *work, integer *iwork, integer *
+ info);
+
+/* Subroutine */ int slarscl2_(integer *m, integer *n, real *d__, real *x,
+ integer *ldx);
+
+/* Subroutine */ int slartg_(real *f, real *g, real *cs, real *sn, real *r__);
+
+/* Subroutine */ int slartv_(integer *n, real *x, integer *incx, real *y,
+ integer *incy, real *c__, real *s, integer *incc);
+
+/* Subroutine */ int slaruv_(integer *iseed, integer *n, real *x);
+
+/* Subroutine */ int slarz_(char *side, integer *m, integer *n, integer *l,
+ real *v, integer *incv, real *tau, real *c__, integer *ldc, real *
+ work);
+
+/* Subroutine */ int slarzb_(char *side, char *trans, char *direct, char *
+ storev, integer *m, integer *n, integer *k, integer *l, real *v,
+ integer *ldv, real *t, integer *ldt, real *c__, integer *ldc, real *
+ work, integer *ldwork);
+
+/* Subroutine */ int slarzt_(char *direct, char *storev, integer *n, integer *
+ k, real *v, integer *ldv, real *tau, real *t, integer *ldt);
+
+/* Subroutine */ int slas2_(real *f, real *g, real *h__, real *ssmin, real *
+ ssmax);
+
+/* Subroutine */ int slascl_(char *type__, integer *kl, integer *ku, real *
+ cfrom, real *cto, integer *m, integer *n, real *a, integer *lda,
+ integer *info);
+
+/* Subroutine */ int slascl2_(integer *m, integer *n, real *d__, real *x,
+ integer *ldx);
+
+/* Subroutine */ int slasd0_(integer *n, integer *sqre, real *d__, real *e,
+ real *u, integer *ldu, real *vt, integer *ldvt, integer *smlsiz,
+ integer *iwork, real *work, integer *info);
+
+/* Subroutine */ int slasd1_(integer *nl, integer *nr, integer *sqre, real *
+ d__, real *alpha, real *beta, real *u, integer *ldu, real *vt,
+ integer *ldvt, integer *idxq, integer *iwork, real *work, integer *
+ info);
+
+/* Subroutine */ int slasd2_(integer *nl, integer *nr, integer *sqre, integer
+ *k, real *d__, real *z__, real *alpha, real *beta, real *u, integer *
+ ldu, real *vt, integer *ldvt, real *dsigma, real *u2, integer *ldu2,
+ real *vt2, integer *ldvt2, integer *idxp, integer *idx, integer *idxc,
+ integer *idxq, integer *coltyp, integer *info);
+
+/* Subroutine */ int slasd3_(integer *nl, integer *nr, integer *sqre, integer
+ *k, real *d__, real *q, integer *ldq, real *dsigma, real *u, integer *
+ ldu, real *u2, integer *ldu2, real *vt, integer *ldvt, real *vt2,
+ integer *ldvt2, integer *idxc, integer *ctot, real *z__, integer *
+ info);
+
+/* Subroutine */ int slasd4_(integer *n, integer *i__, real *d__, real *z__,
+ real *delta, real *rho, real *sigma, real *work, integer *info);
+
+/* Subroutine */ int slasd5_(integer *i__, real *d__, real *z__, real *delta,
+ real *rho, real *dsigma, real *work);
+
+/* Subroutine */ int slasd6_(integer *icompq, integer *nl, integer *nr,
+ integer *sqre, real *d__, real *vf, real *vl, real *alpha, real *beta,
+ integer *idxq, integer *perm, integer *givptr, integer *givcol,
+ integer *ldgcol, real *givnum, integer *ldgnum, real *poles, real *
+ difl, real *difr, real *z__, integer *k, real *c__, real *s, real *
+ work, integer *iwork, integer *info);
+
+/* Subroutine */ int slasd7_(integer *icompq, integer *nl, integer *nr,
+ integer *sqre, integer *k, real *d__, real *z__, real *zw, real *vf,
+ real *vfw, real *vl, real *vlw, real *alpha, real *beta, real *dsigma,
+ integer *idx, integer *idxp, integer *idxq, integer *perm, integer *
+ givptr, integer *givcol, integer *ldgcol, real *givnum, integer *
+ ldgnum, real *c__, real *s, integer *info);
+
+/* Subroutine */ int slasd8_(integer *icompq, integer *k, real *d__, real *
+ z__, real *vf, real *vl, real *difl, real *difr, integer *lddifr,
+ real *dsigma, real *work, integer *info);
+
+/* Subroutine */ int slasda_(integer *icompq, integer *smlsiz, integer *n,
+ integer *sqre, real *d__, real *e, real *u, integer *ldu, real *vt,
+ integer *k, real *difl, real *difr, real *z__, real *poles, integer *
+ givptr, integer *givcol, integer *ldgcol, integer *perm, real *givnum,
+ real *c__, real *s, real *work, integer *iwork, integer *info);
+
+/* Subroutine */ int slasdq_(char *uplo, integer *sqre, integer *n, integer *
+ ncvt, integer *nru, integer *ncc, real *d__, real *e, real *vt,
+ integer *ldvt, real *u, integer *ldu, real *c__, integer *ldc, real *
+ work, integer *info);
+
+/* Subroutine */ int slasdt_(integer *n, integer *lvl, integer *nd, integer *
+ inode, integer *ndiml, integer *ndimr, integer *msub);
+
+/* Subroutine */ int slaset_(char *uplo, integer *m, integer *n, real *alpha,
+ real *beta, real *a, integer *lda);
+
+/* Subroutine */ int slasq1_(integer *n, real *d__, real *e, real *work,
+ integer *info);
+
+/* Subroutine */ int slasq2_(integer *n, real *z__, integer *info);
+
+/* Subroutine */ int slasq3_(integer *i0, integer *n0, real *z__, integer *pp,
+ real *dmin__, real *sigma, real *desig, real *qmax, integer *nfail,
+ integer *iter, integer *ndiv, logical *ieee, integer *ttype, real *
+ dmin1, real *dmin2, real *dn, real *dn1, real *dn2, real *g, real *
+ tau);
+
+/* Subroutine */ int slasq4_(integer *i0, integer *n0, real *z__, integer *pp,
+ integer *n0in, real *dmin__, real *dmin1, real *dmin2, real *dn,
+ real *dn1, real *dn2, real *tau, integer *ttype, real *g);
+
+/* Subroutine */ int slasq5_(integer *i0, integer *n0, real *z__, integer *pp,
+ real *tau, real *dmin__, real *dmin1, real *dmin2, real *dn, real *
+ dnm1, real *dnm2, logical *ieee);
+
+/* Subroutine */ int slasq6_(integer *i0, integer *n0, real *z__, integer *pp,
+ real *dmin__, real *dmin1, real *dmin2, real *dn, real *dnm1, real *
+ dnm2);
+
+/* Subroutine */ int slasr_(char *side, char *pivot, char *direct, integer *m,
+ integer *n, real *c__, real *s, real *a, integer *lda);
+
+/* Subroutine */ int slasrt_(char *id, integer *n, real *d__, integer *info);
+
+/* Subroutine */ int slassq_(integer *n, real *x, integer *incx, real *scale,
+ real *sumsq);
+
+/* Subroutine */ int slasv2_(real *f, real *g, real *h__, real *ssmin, real *
+ ssmax, real *snr, real *csr, real *snl, real *csl);
+
+/* Subroutine */ int slaswp_(integer *n, real *a, integer *lda, integer *k1,
+ integer *k2, integer *ipiv, integer *incx);
+
+/* Subroutine */ int slasy2_(logical *ltranl, logical *ltranr, integer *isgn,
+ integer *n1, integer *n2, real *tl, integer *ldtl, real *tr, integer *
+ ldtr, real *b, integer *ldb, real *scale, real *x, integer *ldx, real
+ *xnorm, integer *info);
+
+/* Subroutine */ int slasyf_(char *uplo, integer *n, integer *nb, integer *kb,
+ real *a, integer *lda, integer *ipiv, real *w, integer *ldw, integer
+ *info);
+
+/* Subroutine */ int slatbs_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, integer *kd, real *ab, integer *ldab, real *x,
+ real *scale, real *cnorm, integer *info);
+
+/* Subroutine */ int slatdf_(integer *ijob, integer *n, real *z__, integer *
+ ldz, real *rhs, real *rdsum, real *rdscal, integer *ipiv, integer *
+ jpiv);
+
+/* Subroutine */ int slatps_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, real *ap, real *x, real *scale, real *cnorm,
+ integer *info);
+
+/* Subroutine */ int slatrd_(char *uplo, integer *n, integer *nb, real *a,
+ integer *lda, real *e, real *tau, real *w, integer *ldw);
+
+/* Subroutine */ int slatrs_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, real *a, integer *lda, real *x, real *scale, real
+ *cnorm, integer *info);
+
+/* Subroutine */ int slatrz_(integer *m, integer *n, integer *l, real *a,
+ integer *lda, real *tau, real *work);
+
+/* Subroutine */ int slatzm_(char *side, integer *m, integer *n, real *v,
+ integer *incv, real *tau, real *c1, real *c2, integer *ldc, real *
+ work);
+
+/* Subroutine */ int slauu2_(char *uplo, integer *n, real *a, integer *lda,
+ integer *info);
+
+/* Subroutine */ int slauum_(char *uplo, integer *n, real *a, integer *lda,
+ integer *info);
+
+/* Subroutine */ int sopgtr_(char *uplo, integer *n, real *ap, real *tau,
+ real *q, integer *ldq, real *work, integer *info);
+
+/* Subroutine */ int sopmtr_(char *side, char *uplo, char *trans, integer *m,
+ integer *n, real *ap, real *tau, real *c__, integer *ldc, real *work,
+ integer *info);
+
+/* Subroutine */ int sorg2l_(integer *m, integer *n, integer *k, real *a,
+ integer *lda, real *tau, real *work, integer *info);
+
+/* Subroutine */ int sorg2r_(integer *m, integer *n, integer *k, real *a,
+ integer *lda, real *tau, real *work, integer *info);
+
+/* Subroutine */ int sorgbr_(char *vect, integer *m, integer *n, integer *k,
+ real *a, integer *lda, real *tau, real *work, integer *lwork, integer
+ *info);
+
+/* Subroutine */ int sorghr_(integer *n, integer *ilo, integer *ihi, real *a,
+ integer *lda, real *tau, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sorgl2_(integer *m, integer *n, integer *k, real *a,
+ integer *lda, real *tau, real *work, integer *info);
+
+/* Subroutine */ int sorglq_(integer *m, integer *n, integer *k, real *a,
+ integer *lda, real *tau, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sorgql_(integer *m, integer *n, integer *k, real *a,
+ integer *lda, real *tau, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sorgqr_(integer *m, integer *n, integer *k, real *a,
+ integer *lda, real *tau, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sorgr2_(integer *m, integer *n, integer *k, real *a,
+ integer *lda, real *tau, real *work, integer *info);
+
+/* Subroutine */ int sorgrq_(integer *m, integer *n, integer *k, real *a,
+ integer *lda, real *tau, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sorgtr_(char *uplo, integer *n, real *a, integer *lda,
+ real *tau, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sorm2l_(char *side, char *trans, integer *m, integer *n,
+ integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
+ real *work, integer *info);
+
+/* Subroutine */ int sorm2r_(char *side, char *trans, integer *m, integer *n,
+ integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
+ real *work, integer *info);
+
+/* Subroutine */ int sormbr_(char *vect, char *side, char *trans, integer *m,
+ integer *n, integer *k, real *a, integer *lda, real *tau, real *c__,
+ integer *ldc, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sormhr_(char *side, char *trans, integer *m, integer *n,
+ integer *ilo, integer *ihi, real *a, integer *lda, real *tau, real *
+ c__, integer *ldc, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sorml2_(char *side, char *trans, integer *m, integer *n,
+ integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
+ real *work, integer *info);
+
+/* Subroutine */ int sormlq_(char *side, char *trans, integer *m, integer *n,
+ integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
+ real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sormql_(char *side, char *trans, integer *m, integer *n,
+ integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
+ real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sormqr_(char *side, char *trans, integer *m, integer *n,
+ integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
+ real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sormr2_(char *side, char *trans, integer *m, integer *n,
+ integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
+ real *work, integer *info);
+
+/* Subroutine */ int sormr3_(char *side, char *trans, integer *m, integer *n,
+ integer *k, integer *l, real *a, integer *lda, real *tau, real *c__,
+ integer *ldc, real *work, integer *info);
+
+/* Subroutine */ int sormrq_(char *side, char *trans, integer *m, integer *n,
+ integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
+ real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sormrz_(char *side, char *trans, integer *m, integer *n,
+ integer *k, integer *l, real *a, integer *lda, real *tau, real *c__,
+ integer *ldc, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int sormtr_(char *side, char *uplo, char *trans, integer *m,
+ integer *n, real *a, integer *lda, real *tau, real *c__, integer *ldc,
+ real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int spbcon_(char *uplo, integer *n, integer *kd, real *ab,
+ integer *ldab, real *anorm, real *rcond, real *work, integer *iwork,
+ integer *info);
+
+/* Subroutine */ int spbequ_(char *uplo, integer *n, integer *kd, real *ab,
+ integer *ldab, real *s, real *scond, real *amax, integer *info);
+
+/* Subroutine */ int spbrfs_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, real *ab, integer *ldab, real *afb, integer *ldafb, real *b,
+ integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *
+ work, integer *iwork, integer *info);
+
+/* Subroutine */ int spbstf_(char *uplo, integer *n, integer *kd, real *ab,
+ integer *ldab, integer *info);
+
+/* Subroutine */ int spbsv_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, real *ab, integer *ldab, real *b, integer *ldb, integer *info);
+
+/* Subroutine */ int spbsvx_(char *fact, char *uplo, integer *n, integer *kd,
+ integer *nrhs, real *ab, integer *ldab, real *afb, integer *ldafb,
+ char *equed, real *s, real *b, integer *ldb, real *x, integer *ldx,
+ real *rcond, real *ferr, real *berr, real *work, integer *iwork,
+ integer *info);
+
+/* Subroutine */ int spbtf2_(char *uplo, integer *n, integer *kd, real *ab,
+ integer *ldab, integer *info);
+
+/* Subroutine */ int spbtrf_(char *uplo, integer *n, integer *kd, real *ab,
+ integer *ldab, integer *info);
+
+/* Subroutine */ int spbtrs_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, real *ab, integer *ldab, real *b, integer *ldb, integer *info);
+
+/* Subroutine */ int spftrf_(char *transr, char *uplo, integer *n, real *a,
+ integer *info);
+
+/* Subroutine */ int spftri_(char *transr, char *uplo, integer *n, real *a,
+ integer *info);
+
+/* Subroutine */ int spftrs_(char *transr, char *uplo, integer *n, integer *
+ nrhs, real *a, real *b, integer *ldb, integer *info);
+
+/* Subroutine */ int spocon_(char *uplo, integer *n, real *a, integer *lda,
+ real *anorm, real *rcond, real *work, integer *iwork, integer *info);
+
+/* Subroutine */ int spoequ_(integer *n, real *a, integer *lda, real *s, real
+ *scond, real *amax, integer *info);
+
+/* Subroutine */ int spoequb_(integer *n, real *a, integer *lda, real *s,
+ real *scond, real *amax, integer *info);
+
+/* Subroutine */ int sporfs_(char *uplo, integer *n, integer *nrhs, real *a,
+ integer *lda, real *af, integer *ldaf, real *b, integer *ldb, real *x,
+ integer *ldx, real *ferr, real *berr, real *work, integer *iwork,
+ integer *info);
+
+/* Subroutine */ int sporfsx_(char *uplo, char *equed, integer *n, integer *
+ nrhs, real *a, integer *lda, real *af, integer *ldaf, real *s, real *
+ b, integer *ldb, real *x, integer *ldx, real *rcond, real *berr,
+ integer *n_err_bnds__, real *err_bnds_norm__, real *err_bnds_comp__,
+ integer *nparams, real *params, real *work, integer *iwork, integer *
+ info);
+
+/* Subroutine */ int sposv_(char *uplo, integer *n, integer *nrhs, real *a,
+ integer *lda, real *b, integer *ldb, integer *info);
+
+/* Subroutine */ int sposvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, real *a, integer *lda, real *af, integer *ldaf, char *equed,
+ real *s, real *b, integer *ldb, real *x, integer *ldx, real *rcond,
+ real *ferr, real *berr, real *work, integer *iwork, integer *info);
+
+/* Subroutine */ int sposvxx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, real *a, integer *lda, real *af, integer *ldaf, char *equed,
+ real *s, real *b, integer *ldb, real *x, integer *ldx, real *rcond,
+ real *rpvgrw, real *berr, integer *n_err_bnds__, real *
+ err_bnds_norm__, real *err_bnds_comp__, integer *nparams, real *
+ params, real *work, integer *iwork, integer *info);
+
+/* Subroutine */ int spotf2_(char *uplo, integer *n, real *a, integer *lda,
+ integer *info);
+
+/* Subroutine */ int spotrf_(char *uplo, integer *n, real *a, integer *lda,
+ integer *info);
+
+/* Subroutine */ int spotri_(char *uplo, integer *n, real *a, integer *lda,
+ integer *info);
+
+/* Subroutine */ int spotrs_(char *uplo, integer *n, integer *nrhs, real *a,
+ integer *lda, real *b, integer *ldb, integer *info);
+
+/* Subroutine */ int sppcon_(char *uplo, integer *n, real *ap, real *anorm,
+ real *rcond, real *work, integer *iwork, integer *info);
+
+/* Subroutine */ int sppequ_(char *uplo, integer *n, real *ap, real *s, real *
+ scond, real *amax, integer *info);
+
+/* Subroutine */ int spprfs_(char *uplo, integer *n, integer *nrhs, real *ap,
+ real *afp, real *b, integer *ldb, real *x, integer *ldx, real *ferr,
+ real *berr, real *work, integer *iwork, integer *info);
+
+/* Subroutine */ int sppsv_(char *uplo, integer *n, integer *nrhs, real *ap,
+ real *b, integer *ldb, integer *info);
+
+/* Subroutine */ int sppsvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, real *ap, real *afp, char *equed, real *s, real *b, integer *
+ ldb, real *x, integer *ldx, real *rcond, real *ferr, real *berr, real
+ *work, integer *iwork, integer *info);
+
+/* Subroutine */ int spptrf_(char *uplo, integer *n, real *ap, integer *info);
+
+/* Subroutine */ int spptri_(char *uplo, integer *n, real *ap, integer *info);
+
+/* Subroutine */ int spptrs_(char *uplo, integer *n, integer *nrhs, real *ap,
+ real *b, integer *ldb, integer *info);
+
+/* Subroutine */ int spstf2_(char *uplo, integer *n, real *a, integer *lda,
+ integer *piv, integer *rank, real *tol, real *work, integer *info);
+
+/* Subroutine */ int spstrf_(char *uplo, integer *n, real *a, integer *lda,
+ integer *piv, integer *rank, real *tol, real *work, integer *info);
+
+/* Subroutine */ int sptcon_(integer *n, real *d__, real *e, real *anorm,
+ real *rcond, real *work, integer *info);
+
+/* Subroutine */ int spteqr_(char *compz, integer *n, real *d__, real *e,
+ real *z__, integer *ldz, real *work, integer *info);
+
+/* Subroutine */ int sptrfs_(integer *n, integer *nrhs, real *d__, real *e,
+ real *df, real *ef, real *b, integer *ldb, real *x, integer *ldx,
+ real *ferr, real *berr, real *work, integer *info);
+
+/* Subroutine */ int sptsv_(integer *n, integer *nrhs, real *d__, real *e,
+ real *b, integer *ldb, integer *info);
+
+/* Subroutine */ int sptsvx_(char *fact, integer *n, integer *nrhs, real *d__,
+ real *e, real *df, real *ef, real *b, integer *ldb, real *x, integer
+ *ldx, real *rcond, real *ferr, real *berr, real *work, integer *info);
+
+/* Subroutine */ int spttrf_(integer *n, real *d__, real *e, integer *info);
+
+/* Subroutine */ int spttrs_(integer *n, integer *nrhs, real *d__, real *e,
+ real *b, integer *ldb, integer *info);
+
+/* Subroutine */ int sptts2_(integer *n, integer *nrhs, real *d__, real *e,
+ real *b, integer *ldb);
+
+/* Subroutine */ int srscl_(integer *n, real *sa, real *sx, integer *incx);
+
+/* Subroutine */ int ssbev_(char *jobz, char *uplo, integer *n, integer *kd,
+ real *ab, integer *ldab, real *w, real *z__, integer *ldz, real *work,
+ integer *info);
+
+/* Subroutine */ int ssbevd_(char *jobz, char *uplo, integer *n, integer *kd,
+ real *ab, integer *ldab, real *w, real *z__, integer *ldz, real *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int ssbevx_(char *jobz, char *range, char *uplo, integer *n,
+ integer *kd, real *ab, integer *ldab, real *q, integer *ldq, real *vl,
+ real *vu, integer *il, integer *iu, real *abstol, integer *m, real *
+ w, real *z__, integer *ldz, real *work, integer *iwork, integer *
+ ifail, integer *info);
+
+/* Subroutine */ int ssbgst_(char *vect, char *uplo, integer *n, integer *ka,
+ integer *kb, real *ab, integer *ldab, real *bb, integer *ldbb, real *
+ x, integer *ldx, real *work, integer *info);
+
+/* Subroutine */ int ssbgv_(char *jobz, char *uplo, integer *n, integer *ka,
+ integer *kb, real *ab, integer *ldab, real *bb, integer *ldbb, real *
+ w, real *z__, integer *ldz, real *work, integer *info);
+
+/* Subroutine */ int ssbgvd_(char *jobz, char *uplo, integer *n, integer *ka,
+ integer *kb, real *ab, integer *ldab, real *bb, integer *ldbb, real *
+ w, real *z__, integer *ldz, real *work, integer *lwork, integer *
+ iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int ssbgvx_(char *jobz, char *range, char *uplo, integer *n,
+ integer *ka, integer *kb, real *ab, integer *ldab, real *bb, integer *
+ ldbb, real *q, integer *ldq, real *vl, real *vu, integer *il, integer
+ *iu, real *abstol, integer *m, real *w, real *z__, integer *ldz, real
+ *work, integer *iwork, integer *ifail, integer *info);
+
+/* Subroutine */ int ssbtrd_(char *vect, char *uplo, integer *n, integer *kd,
+ real *ab, integer *ldab, real *d__, real *e, real *q, integer *ldq,
+ real *work, integer *info);
+
+/* Subroutine */ int ssfrk_(char *transr, char *uplo, char *trans, integer *n,
+ integer *k, real *alpha, real *a, integer *lda, real *beta, real *
+ c__);
+
+/* Subroutine */ int sspcon_(char *uplo, integer *n, real *ap, integer *ipiv,
+ real *anorm, real *rcond, real *work, integer *iwork, integer *info);
+
+/* Subroutine */ int sspev_(char *jobz, char *uplo, integer *n, real *ap,
+ real *w, real *z__, integer *ldz, real *work, integer *info);
+
+/* Subroutine */ int sspevd_(char *jobz, char *uplo, integer *n, real *ap,
+ real *w, real *z__, integer *ldz, real *work, integer *lwork, integer
+ *iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int sspevx_(char *jobz, char *range, char *uplo, integer *n,
+ real *ap, real *vl, real *vu, integer *il, integer *iu, real *abstol,
+ integer *m, real *w, real *z__, integer *ldz, real *work, integer *
+ iwork, integer *ifail, integer *info);
+
+/* Subroutine */ int sspgst_(integer *itype, char *uplo, integer *n, real *ap,
+ real *bp, integer *info);
+
+/* Subroutine */ int sspgv_(integer *itype, char *jobz, char *uplo, integer *
+ n, real *ap, real *bp, real *w, real *z__, integer *ldz, real *work,
+ integer *info);
+
+/* Subroutine */ int sspgvd_(integer *itype, char *jobz, char *uplo, integer *
+ n, real *ap, real *bp, real *w, real *z__, integer *ldz, real *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int sspgvx_(integer *itype, char *jobz, char *range, char *
+ uplo, integer *n, real *ap, real *bp, real *vl, real *vu, integer *il,
+ integer *iu, real *abstol, integer *m, real *w, real *z__, integer *
+ ldz, real *work, integer *iwork, integer *ifail, integer *info);
+
+/* Subroutine */ int ssprfs_(char *uplo, integer *n, integer *nrhs, real *ap,
+ real *afp, integer *ipiv, real *b, integer *ldb, real *x, integer *
+ ldx, real *ferr, real *berr, real *work, integer *iwork, integer *
+ info);
+
+/* Subroutine */ int sspsv_(char *uplo, integer *n, integer *nrhs, real *ap,
+ integer *ipiv, real *b, integer *ldb, integer *info);
+
+/* Subroutine */ int sspsvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, real *ap, real *afp, integer *ipiv, real *b, integer *ldb, real
+ *x, integer *ldx, real *rcond, real *ferr, real *berr, real *work,
+ integer *iwork, integer *info);
+
+/* Subroutine */ int ssptrd_(char *uplo, integer *n, real *ap, real *d__,
+ real *e, real *tau, integer *info);
+
+/* Subroutine */ int ssptrf_(char *uplo, integer *n, real *ap, integer *ipiv,
+ integer *info);
+
+/* Subroutine */ int ssptri_(char *uplo, integer *n, real *ap, integer *ipiv,
+ real *work, integer *info);
+
+/* Subroutine */ int ssptrs_(char *uplo, integer *n, integer *nrhs, real *ap,
+ integer *ipiv, real *b, integer *ldb, integer *info);
+
+/* Subroutine */ int sstebz_(char *range, char *order, integer *n, real *vl,
+ real *vu, integer *il, integer *iu, real *abstol, real *d__, real *e,
+ integer *m, integer *nsplit, real *w, integer *iblock, integer *
+ isplit, real *work, integer *iwork, integer *info);
+
+/* Subroutine */ int sstedc_(char *compz, integer *n, real *d__, real *e,
+ real *z__, integer *ldz, real *work, integer *lwork, integer *iwork,
+ integer *liwork, integer *info);
+
+/* Subroutine */ int sstegr_(char *jobz, char *range, integer *n, real *d__,
+ real *e, real *vl, real *vu, integer *il, integer *iu, real *abstol,
+ integer *m, real *w, real *z__, integer *ldz, integer *isuppz, real *
+ work, integer *lwork, integer *iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int sstein_(integer *n, real *d__, real *e, integer *m, real
+ *w, integer *iblock, integer *isplit, real *z__, integer *ldz, real *
+ work, integer *iwork, integer *ifail, integer *info);
+
+/* Subroutine */ int sstemr_(char *jobz, char *range, integer *n, real *d__,
+ real *e, real *vl, real *vu, integer *il, integer *iu, integer *m,
+ real *w, real *z__, integer *ldz, integer *nzc, integer *isuppz,
+ logical *tryrac, real *work, integer *lwork, integer *iwork, integer *
+ liwork, integer *info);
+
+/* Subroutine */ int ssteqr_(char *compz, integer *n, real *d__, real *e,
+ real *z__, integer *ldz, real *work, integer *info);
+
+/* Subroutine */ int ssterf_(integer *n, real *d__, real *e, integer *info);
+
+/* Subroutine */ int sstev_(char *jobz, integer *n, real *d__, real *e, real *
+ z__, integer *ldz, real *work, integer *info);
+
+/* Subroutine */ int sstevd_(char *jobz, integer *n, real *d__, real *e, real
+ *z__, integer *ldz, real *work, integer *lwork, integer *iwork,
+ integer *liwork, integer *info);
+
+/* Subroutine */ int sstevr_(char *jobz, char *range, integer *n, real *d__,
+ real *e, real *vl, real *vu, integer *il, integer *iu, real *abstol,
+ integer *m, real *w, real *z__, integer *ldz, integer *isuppz, real *
+ work, integer *lwork, integer *iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int sstevx_(char *jobz, char *range, integer *n, real *d__,
+ real *e, real *vl, real *vu, integer *il, integer *iu, real *abstol,
+ integer *m, real *w, real *z__, integer *ldz, real *work, integer *
+ iwork, integer *ifail, integer *info);
+
+/* Subroutine */ int ssycon_(char *uplo, integer *n, real *a, integer *lda,
+ integer *ipiv, real *anorm, real *rcond, real *work, integer *iwork,
+ integer *info);
+
+/* Subroutine */ int ssyequb_(char *uplo, integer *n, real *a, integer *lda,
+ real *s, real *scond, real *amax, real *work, integer *info);
+
+/* Subroutine */ int ssyev_(char *jobz, char *uplo, integer *n, real *a,
+ integer *lda, real *w, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int ssyevd_(char *jobz, char *uplo, integer *n, real *a,
+ integer *lda, real *w, real *work, integer *lwork, integer *iwork,
+ integer *liwork, integer *info);
+
+/* Subroutine */ int ssyevr_(char *jobz, char *range, char *uplo, integer *n,
+ real *a, integer *lda, real *vl, real *vu, integer *il, integer *iu,
+ real *abstol, integer *m, real *w, real *z__, integer *ldz, integer *
+ isuppz, real *work, integer *lwork, integer *iwork, integer *liwork,
+ integer *info);
+
+/* Subroutine */ int ssyevx_(char *jobz, char *range, char *uplo, integer *n,
+ real *a, integer *lda, real *vl, real *vu, integer *il, integer *iu,
+ real *abstol, integer *m, real *w, real *z__, integer *ldz, real *
+ work, integer *lwork, integer *iwork, integer *ifail, integer *info);
+
+/* Subroutine */ int ssygs2_(integer *itype, char *uplo, integer *n, real *a,
+ integer *lda, real *b, integer *ldb, integer *info);
+
+/* Subroutine */ int ssygst_(integer *itype, char *uplo, integer *n, real *a,
+ integer *lda, real *b, integer *ldb, integer *info);
+
+/* Subroutine */ int ssygv_(integer *itype, char *jobz, char *uplo, integer *
+ n, real *a, integer *lda, real *b, integer *ldb, real *w, real *work,
+ integer *lwork, integer *info);
+
+/* Subroutine */ int ssygvd_(integer *itype, char *jobz, char *uplo, integer *
+ n, real *a, integer *lda, real *b, integer *ldb, real *w, real *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int ssygvx_(integer *itype, char *jobz, char *range, char *
+ uplo, integer *n, real *a, integer *lda, real *b, integer *ldb, real *
+ vl, real *vu, integer *il, integer *iu, real *abstol, integer *m,
+ real *w, real *z__, integer *ldz, real *work, integer *lwork, integer
+ *iwork, integer *ifail, integer *info);
+
+/* Subroutine */ int ssyrfs_(char *uplo, integer *n, integer *nrhs, real *a,
+ integer *lda, real *af, integer *ldaf, integer *ipiv, real *b,
+ integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *
+ work, integer *iwork, integer *info);
+
+/* Subroutine */ int ssyrfsx_(char *uplo, char *equed, integer *n, integer *
+ nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv,
+ real *s, real *b, integer *ldb, real *x, integer *ldx, real *rcond,
+ real *berr, integer *n_err_bnds__, real *err_bnds_norm__, real *
+ err_bnds_comp__, integer *nparams, real *params, real *work, integer *
+ iwork, integer *info);
+
+/* Subroutine */ int ssysv_(char *uplo, integer *n, integer *nrhs, real *a,
+ integer *lda, integer *ipiv, real *b, integer *ldb, real *work,
+ integer *lwork, integer *info);
+
+/* Subroutine */ int ssysvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv,
+ real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *ferr,
+ real *berr, real *work, integer *lwork, integer *iwork, integer *
+ info);
+
+/* Subroutine */ int ssysvxx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv,
+ char *equed, real *s, real *b, integer *ldb, real *x, integer *ldx,
+ real *rcond, real *rpvgrw, real *berr, integer *n_err_bnds__, real *
+ err_bnds_norm__, real *err_bnds_comp__, integer *nparams, real *
+ params, real *work, integer *iwork, integer *info);
+
+/* Subroutine */ int ssytd2_(char *uplo, integer *n, real *a, integer *lda,
+ real *d__, real *e, real *tau, integer *info);
+
+/* Subroutine */ int ssytf2_(char *uplo, integer *n, real *a, integer *lda,
+ integer *ipiv, integer *info);
+
+/* Subroutine */ int ssytrd_(char *uplo, integer *n, real *a, integer *lda,
+ real *d__, real *e, real *tau, real *work, integer *lwork, integer *
+ info);
+
+/* Subroutine */ int ssytrf_(char *uplo, integer *n, real *a, integer *lda,
+ integer *ipiv, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int ssytri_(char *uplo, integer *n, real *a, integer *lda,
+ integer *ipiv, real *work, integer *info);
+
+/* Subroutine */ int ssytrs_(char *uplo, integer *n, integer *nrhs, real *a,
+ integer *lda, integer *ipiv, real *b, integer *ldb, integer *info);
+
+/* Subroutine */ int stbcon_(char *norm, char *uplo, char *diag, integer *n,
+ integer *kd, real *ab, integer *ldab, real *rcond, real *work,
+ integer *iwork, integer *info);
+
+/* Subroutine */ int stbrfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, real *ab, integer *ldab, real *b, integer
+ *ldb, real *x, integer *ldx, real *ferr, real *berr, real *work,
+ integer *iwork, integer *info);
+
+/* Subroutine */ int stbtrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, real *ab, integer *ldab, real *b, integer
+ *ldb, integer *info);
+
+/* Subroutine */ int stfsm_(char *transr, char *side, char *uplo, char *trans,
+ char *diag, integer *m, integer *n, real *alpha, real *a, real *b,
+ integer *ldb);
+
+/* Subroutine */ int stftri_(char *transr, char *uplo, char *diag, integer *n,
+ real *a, integer *info);
+
+/* Subroutine */ int stfttp_(char *transr, char *uplo, integer *n, real *arf,
+ real *ap, integer *info);
+
+/* Subroutine */ int stfttr_(char *transr, char *uplo, integer *n, real *arf,
+ real *a, integer *lda, integer *info);
+
+/* Subroutine */ int stgevc_(char *side, char *howmny, logical *select,
+ integer *n, real *s, integer *lds, real *p, integer *ldp, real *vl,
+ integer *ldvl, real *vr, integer *ldvr, integer *mm, integer *m, real
+ *work, integer *info);
+
+/* Subroutine */ int stgex2_(logical *wantq, logical *wantz, integer *n, real
+ *a, integer *lda, real *b, integer *ldb, real *q, integer *ldq, real *
+ z__, integer *ldz, integer *j1, integer *n1, integer *n2, real *work,
+ integer *lwork, integer *info);
+
+/* Subroutine */ int stgexc_(logical *wantq, logical *wantz, integer *n, real
+ *a, integer *lda, real *b, integer *ldb, real *q, integer *ldq, real *
+ z__, integer *ldz, integer *ifst, integer *ilst, real *work, integer *
+ lwork, integer *info);
+
+/* Subroutine */ int stgsen_(integer *ijob, logical *wantq, logical *wantz,
+ logical *select, integer *n, real *a, integer *lda, real *b, integer *
+ ldb, real *alphar, real *alphai, real *beta, real *q, integer *ldq,
+ real *z__, integer *ldz, integer *m, real *pl, real *pr, real *dif,
+ real *work, integer *lwork, integer *iwork, integer *liwork, integer *
+ info);
+
+/* Subroutine */ int stgsja_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *p, integer *n, integer *k, integer *l, real *a, integer *lda,
+ real *b, integer *ldb, real *tola, real *tolb, real *alpha, real *
+ beta, real *u, integer *ldu, real *v, integer *ldv, real *q, integer *
+ ldq, real *work, integer *ncycle, integer *info);
+
+/* Subroutine */ int stgsna_(char *job, char *howmny, logical *select,
+ integer *n, real *a, integer *lda, real *b, integer *ldb, real *vl,
+ integer *ldvl, real *vr, integer *ldvr, real *s, real *dif, integer *
+ mm, integer *m, real *work, integer *lwork, integer *iwork, integer *
+ info);
+
+/* Subroutine */ int stgsy2_(char *trans, integer *ijob, integer *m, integer *
+ n, real *a, integer *lda, real *b, integer *ldb, real *c__, integer *
+ ldc, real *d__, integer *ldd, real *e, integer *lde, real *f, integer
+ *ldf, real *scale, real *rdsum, real *rdscal, integer *iwork, integer
+ *pq, integer *info);
+
+/* Subroutine */ int stgsyl_(char *trans, integer *ijob, integer *m, integer *
+ n, real *a, integer *lda, real *b, integer *ldb, real *c__, integer *
+ ldc, real *d__, integer *ldd, real *e, integer *lde, real *f, integer
+ *ldf, real *scale, real *dif, real *work, integer *lwork, integer *
+ iwork, integer *info);
+
+/* Subroutine */ int stpcon_(char *norm, char *uplo, char *diag, integer *n,
+ real *ap, real *rcond, real *work, integer *iwork, integer *info);
+
+/* Subroutine */ int stprfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, real *ap, real *b, integer *ldb, real *x, integer *ldx,
+ real *ferr, real *berr, real *work, integer *iwork, integer *info);
+
+/* Subroutine */ int stptri_(char *uplo, char *diag, integer *n, real *ap,
+ integer *info);
+
+/* Subroutine */ int stptrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, real *ap, real *b, integer *ldb, integer *info);
+
+/* Subroutine */ int stpttf_(char *transr, char *uplo, integer *n, real *ap,
+ real *arf, integer *info);
+
+/* Subroutine */ int stpttr_(char *uplo, integer *n, real *ap, real *a,
+ integer *lda, integer *info);
+
+/* Subroutine */ int strcon_(char *norm, char *uplo, char *diag, integer *n,
+ real *a, integer *lda, real *rcond, real *work, integer *iwork,
+ integer *info);
+
+/* Subroutine */ int strevc_(char *side, char *howmny, logical *select,
+ integer *n, real *t, integer *ldt, real *vl, integer *ldvl, real *vr,
+ integer *ldvr, integer *mm, integer *m, real *work, integer *info);
+
+/* Subroutine */ int strexc_(char *compq, integer *n, real *t, integer *ldt,
+ real *q, integer *ldq, integer *ifst, integer *ilst, real *work,
+ integer *info);
+
+/* Subroutine */ int strrfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, real *a, integer *lda, real *b, integer *ldb, real *x,
+ integer *ldx, real *ferr, real *berr, real *work, integer *iwork,
+ integer *info);
+
+/* Subroutine */ int strsen_(char *job, char *compq, logical *select, integer
+ *n, real *t, integer *ldt, real *q, integer *ldq, real *wr, real *wi,
+ integer *m, real *s, real *sep, real *work, integer *lwork, integer *
+ iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int strsna_(char *job, char *howmny, logical *select,
+ integer *n, real *t, integer *ldt, real *vl, integer *ldvl, real *vr,
+ integer *ldvr, real *s, real *sep, integer *mm, integer *m, real *
+ work, integer *ldwork, integer *iwork, integer *info);
+
+/* Subroutine */ int strsyl_(char *trana, char *tranb, integer *isgn, integer
+ *m, integer *n, real *a, integer *lda, real *b, integer *ldb, real *
+ c__, integer *ldc, real *scale, integer *info);
+
+/* Subroutine */ int strti2_(char *uplo, char *diag, integer *n, real *a,
+ integer *lda, integer *info);
+
+/* Subroutine */ int strtri_(char *uplo, char *diag, integer *n, real *a,
+ integer *lda, integer *info);
+
+/* Subroutine */ int strtrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, real *a, integer *lda, real *b, integer *ldb, integer *
+ info);
+
+/* Subroutine */ int strttf_(char *transr, char *uplo, integer *n, real *a,
+ integer *lda, real *arf, integer *info);
+
+/* Subroutine */ int strttp_(char *uplo, integer *n, real *a, integer *lda,
+ real *ap, integer *info);
+
+/* Subroutine */ int stzrqf_(integer *m, integer *n, real *a, integer *lda,
+ real *tau, integer *info);
+
+/* Subroutine */ int stzrzf_(integer *m, integer *n, real *a, integer *lda,
+ real *tau, real *work, integer *lwork, integer *info);
+
+/* Subroutine */ int xerbla_(char *srname, integer *info);
+
+/* Subroutine */ int xerbla_array__(char *srname_array__, integer *
+ srname_len__, integer *info, ftnlen srname_array_len);
+
+/* Subroutine */ int zbdsqr_(char *uplo, integer *n, integer *ncvt, integer *
+ nru, integer *ncc, doublereal *d__, doublereal *e, doublecomplex *vt,
+ integer *ldvt, doublecomplex *u, integer *ldu, doublecomplex *c__,
+ integer *ldc, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zcgesv_(integer *n, integer *nrhs, doublecomplex *a,
+ integer *lda, integer *ipiv, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublecomplex *work, complex *swork,
+ doublereal *rwork, integer *iter, integer *info);
+
+/* Subroutine */ int zcposv_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublecomplex *work, complex *swork,
+ doublereal *rwork, integer *iter, integer *info);
+
+/* Subroutine */ int zdrscl_(integer *n, doublereal *sa, doublecomplex *sx,
+ integer *incx);
+
+/* Subroutine */ int zgbbrd_(char *vect, integer *m, integer *n, integer *ncc,
+ integer *kl, integer *ku, doublecomplex *ab, integer *ldab,
+ doublereal *d__, doublereal *e, doublecomplex *q, integer *ldq,
+ doublecomplex *pt, integer *ldpt, doublecomplex *c__, integer *ldc,
+ doublecomplex *work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zgbcon_(char *norm, integer *n, integer *kl, integer *ku,
+ doublecomplex *ab, integer *ldab, integer *ipiv, doublereal *anorm,
+ doublereal *rcond, doublecomplex *work, doublereal *rwork, integer *
+ info);
+
+/* Subroutine */ int zgbequ_(integer *m, integer *n, integer *kl, integer *ku,
+ doublecomplex *ab, integer *ldab, doublereal *r__, doublereal *c__,
+ doublereal *rowcnd, doublereal *colcnd, doublereal *amax, integer *
+ info);
+
+/* Subroutine */ int zgbequb_(integer *m, integer *n, integer *kl, integer *
+ ku, doublecomplex *ab, integer *ldab, doublereal *r__, doublereal *
+ c__, doublereal *rowcnd, doublereal *colcnd, doublereal *amax,
+ integer *info);
+
+/* Subroutine */ int zgbrfs_(char *trans, integer *n, integer *kl, integer *
+ ku, integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *
+ afb, integer *ldafb, integer *ipiv, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr,
+ doublecomplex *work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zgbrfsx_(char *trans, char *equed, integer *n, integer *
+ kl, integer *ku, integer *nrhs, doublecomplex *ab, integer *ldab,
+ doublecomplex *afb, integer *ldafb, integer *ipiv, doublereal *r__,
+ doublereal *c__, doublecomplex *b, integer *ldb, doublecomplex *x,
+ integer *ldx, doublereal *rcond, doublereal *berr, integer *
+ n_err_bnds__, doublereal *err_bnds_norm__, doublereal *
+ err_bnds_comp__, integer *nparams, doublereal *params, doublecomplex *
+ work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zgbsv_(integer *n, integer *kl, integer *ku, integer *
+ nrhs, doublecomplex *ab, integer *ldab, integer *ipiv, doublecomplex *
+ b, integer *ldb, integer *info);
+
+/* Subroutine */ int zgbsvx_(char *fact, char *trans, integer *n, integer *kl,
+ integer *ku, integer *nrhs, doublecomplex *ab, integer *ldab,
+ doublecomplex *afb, integer *ldafb, integer *ipiv, char *equed,
+ doublereal *r__, doublereal *c__, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr,
+ doublereal *berr, doublecomplex *work, doublereal *rwork, integer *
+ info);
+
+/* Subroutine */ int zgbsvxx_(char *fact, char *trans, integer *n, integer *
+ kl, integer *ku, integer *nrhs, doublecomplex *ab, integer *ldab,
+ doublecomplex *afb, integer *ldafb, integer *ipiv, char *equed,
+ doublereal *r__, doublereal *c__, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *rpvgrw,
+ doublereal *berr, integer *n_err_bnds__, doublereal *err_bnds_norm__,
+ doublereal *err_bnds_comp__, integer *nparams, doublereal *params,
+ doublecomplex *work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zgbtf2_(integer *m, integer *n, integer *kl, integer *ku,
+ doublecomplex *ab, integer *ldab, integer *ipiv, integer *info);
+
+/* Subroutine */ int zgbtrf_(integer *m, integer *n, integer *kl, integer *ku,
+ doublecomplex *ab, integer *ldab, integer *ipiv, integer *info);
+
+/* Subroutine */ int zgbtrs_(char *trans, integer *n, integer *kl, integer *
+ ku, integer *nrhs, doublecomplex *ab, integer *ldab, integer *ipiv,
+ doublecomplex *b, integer *ldb, integer *info);
+
+/* Subroutine */ int zgebak_(char *job, char *side, integer *n, integer *ilo,
+ integer *ihi, doublereal *scale, integer *m, doublecomplex *v,
+ integer *ldv, integer *info);
+
+/* Subroutine */ int zgebal_(char *job, integer *n, doublecomplex *a, integer
+ *lda, integer *ilo, integer *ihi, doublereal *scale, integer *info);
+
+/* Subroutine */ int zgebd2_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublereal *d__, doublereal *e, doublecomplex *tauq,
+ doublecomplex *taup, doublecomplex *work, integer *info);
+
+/* Subroutine */ int zgebrd_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublereal *d__, doublereal *e, doublecomplex *tauq,
+ doublecomplex *taup, doublecomplex *work, integer *lwork, integer *
+ info);
+
+/* Subroutine */ int zgecon_(char *norm, integer *n, doublecomplex *a,
+ integer *lda, doublereal *anorm, doublereal *rcond, doublecomplex *
+ work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zgeequ_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublereal *r__, doublereal *c__, doublereal *rowcnd,
+ doublereal *colcnd, doublereal *amax, integer *info);
+
+/* Subroutine */ int zgeequb_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublereal *r__, doublereal *c__, doublereal *rowcnd,
+ doublereal *colcnd, doublereal *amax, integer *info);
+
+/* Subroutine */ int zgees_(char *jobvs, char *sort, L_fp select, integer *n,
+ doublecomplex *a, integer *lda, integer *sdim, doublecomplex *w,
+ doublecomplex *vs, integer *ldvs, doublecomplex *work, integer *lwork,
+ doublereal *rwork, logical *bwork, integer *info);
+
+/* Subroutine */ int zgeesx_(char *jobvs, char *sort, L_fp select, char *
+ sense, integer *n, doublecomplex *a, integer *lda, integer *sdim,
+ doublecomplex *w, doublecomplex *vs, integer *ldvs, doublereal *
+ rconde, doublereal *rcondv, doublecomplex *work, integer *lwork,
+ doublereal *rwork, logical *bwork, integer *info);
+
+/* Subroutine */ int zgeev_(char *jobvl, char *jobvr, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *w, doublecomplex *vl,
+ integer *ldvl, doublecomplex *vr, integer *ldvr, doublecomplex *work,
+ integer *lwork, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zgeevx_(char *balanc, char *jobvl, char *jobvr, char *
+ sense, integer *n, doublecomplex *a, integer *lda, doublecomplex *w,
+ doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr,
+ integer *ilo, integer *ihi, doublereal *scale, doublereal *abnrm,
+ doublereal *rconde, doublereal *rcondv, doublecomplex *work, integer *
+ lwork, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zgegs_(char *jobvsl, char *jobvsr, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *alpha, doublecomplex *beta, doublecomplex *vsl,
+ integer *ldvsl, doublecomplex *vsr, integer *ldvsr, doublecomplex *
+ work, integer *lwork, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zgegv_(char *jobvl, char *jobvr, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *alpha, doublecomplex *beta, doublecomplex *vl, integer
+ *ldvl, doublecomplex *vr, integer *ldvr, doublecomplex *work, integer
+ *lwork, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zgehd2_(integer *n, integer *ilo, integer *ihi,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *info);
+
+/* Subroutine */ int zgehrd_(integer *n, integer *ilo, integer *ihi,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *lwork, integer *info);
+
+/* Subroutine */ int zgelq2_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *tau, doublecomplex *work, integer *info);
+
+/* Subroutine */ int zgelqf_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int zgels_(char *trans, integer *m, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int zgelsd_(integer *m, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublereal *s, doublereal *rcond, integer *rank, doublecomplex *work,
+ integer *lwork, doublereal *rwork, integer *iwork, integer *info);
+
+/* Subroutine */ int zgelss_(integer *m, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublereal *s, doublereal *rcond, integer *rank, doublecomplex *work,
+ integer *lwork, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zgelsx_(integer *m, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ integer *jpvt, doublereal *rcond, integer *rank, doublecomplex *work,
+ doublereal *rwork, integer *info);
+
+/* Subroutine */ int zgelsy_(integer *m, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ integer *jpvt, doublereal *rcond, integer *rank, doublecomplex *work,
+ integer *lwork, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zgeql2_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *tau, doublecomplex *work, integer *info);
+
+/* Subroutine */ int zgeqlf_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int zgeqp3_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, integer *jpvt, doublecomplex *tau, doublecomplex *work,
+ integer *lwork, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zgeqpf_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, integer *jpvt, doublecomplex *tau, doublecomplex *work,
+ doublereal *rwork, integer *info);
+
+/* Subroutine */ int zgeqr2_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *tau, doublecomplex *work, integer *info);
+
+/* Subroutine */ int zgeqrf_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int zgerfs_(char *trans, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf,
+ integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x,
+ integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work,
+ doublereal *rwork, integer *info);
+
+/* Subroutine */ int zgerfsx_(char *trans, char *equed, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, integer *ipiv, doublereal *r__, doublereal *c__, doublecomplex *
+ b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond,
+ doublereal *berr, integer *n_err_bnds__, doublereal *err_bnds_norm__,
+ doublereal *err_bnds_comp__, integer *nparams, doublereal *params,
+ doublecomplex *work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zgerq2_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *tau, doublecomplex *work, integer *info);
+
+/* Subroutine */ int zgerqf_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int zgesc2_(integer *n, doublecomplex *a, integer *lda,
+ doublecomplex *rhs, integer *ipiv, integer *jpiv, doublereal *scale);
+
+/* Subroutine */ int zgesdd_(char *jobz, integer *m, integer *n,
+ doublecomplex *a, integer *lda, doublereal *s, doublecomplex *u,
+ integer *ldu, doublecomplex *vt, integer *ldvt, doublecomplex *work,
+ integer *lwork, doublereal *rwork, integer *iwork, integer *info);
+
+/* Subroutine */ int zgesv_(integer *n, integer *nrhs, doublecomplex *a,
+ integer *lda, integer *ipiv, doublecomplex *b, integer *ldb, integer *
+ info);
+
+/* Subroutine */ int zgesvd_(char *jobu, char *jobvt, integer *m, integer *n,
+ doublecomplex *a, integer *lda, doublereal *s, doublecomplex *u,
+ integer *ldu, doublecomplex *vt, integer *ldvt, doublecomplex *work,
+ integer *lwork, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zgesvx_(char *fact, char *trans, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, integer *ipiv, char *equed, doublereal *r__, doublereal *c__,
+ doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
+ doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *
+ work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zgesvxx_(char *fact, char *trans, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, integer *ipiv, char *equed, doublereal *r__, doublereal *c__,
+ doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
+ doublereal *rcond, doublereal *rpvgrw, doublereal *berr, integer *
+ n_err_bnds__, doublereal *err_bnds_norm__, doublereal *
+ err_bnds_comp__, integer *nparams, doublereal *params, doublecomplex *
+ work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zgetc2_(integer *n, doublecomplex *a, integer *lda,
+ integer *ipiv, integer *jpiv, integer *info);
+
+/* Subroutine */ int zgetf2_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, integer *ipiv, integer *info);
+
+/* Subroutine */ int zgetrf_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, integer *ipiv, integer *info);
+
+/* Subroutine */ int zgetri_(integer *n, doublecomplex *a, integer *lda,
+ integer *ipiv, doublecomplex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int zgetrs_(char *trans, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b,
+ integer *ldb, integer *info);
+
+/* Subroutine */ int zggbak_(char *job, char *side, integer *n, integer *ilo,
+ integer *ihi, doublereal *lscale, doublereal *rscale, integer *m,
+ doublecomplex *v, integer *ldv, integer *info);
+
+/* Subroutine */ int zggbal_(char *job, integer *n, doublecomplex *a, integer
+ *lda, doublecomplex *b, integer *ldb, integer *ilo, integer *ihi,
+ doublereal *lscale, doublereal *rscale, doublereal *work, integer *
+ info);
+
+/* Subroutine */ int zgges_(char *jobvsl, char *jobvsr, char *sort, L_fp
+ selctg, integer *n, doublecomplex *a, integer *lda, doublecomplex *b,
+ integer *ldb, integer *sdim, doublecomplex *alpha, doublecomplex *
+ beta, doublecomplex *vsl, integer *ldvsl, doublecomplex *vsr, integer
+ *ldvsr, doublecomplex *work, integer *lwork, doublereal *rwork,
+ logical *bwork, integer *info);
+
+/* Subroutine */ int zggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp
+ selctg, char *sense, integer *n, doublecomplex *a, integer *lda,
+ doublecomplex *b, integer *ldb, integer *sdim, doublecomplex *alpha,
+ doublecomplex *beta, doublecomplex *vsl, integer *ldvsl,
+ doublecomplex *vsr, integer *ldvsr, doublereal *rconde, doublereal *
+ rcondv, doublecomplex *work, integer *lwork, doublereal *rwork,
+ integer *iwork, integer *liwork, logical *bwork, integer *info);
+
+/* Subroutine */ int zggev_(char *jobvl, char *jobvr, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *alpha, doublecomplex *beta, doublecomplex *vl, integer
+ *ldvl, doublecomplex *vr, integer *ldvr, doublecomplex *work, integer
+ *lwork, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zggevx_(char *balanc, char *jobvl, char *jobvr, char *
+ sense, integer *n, doublecomplex *a, integer *lda, doublecomplex *b,
+ integer *ldb, doublecomplex *alpha, doublecomplex *beta,
+ doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr,
+ integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale,
+ doublereal *abnrm, doublereal *bbnrm, doublereal *rconde, doublereal *
+ rcondv, doublecomplex *work, integer *lwork, doublereal *rwork,
+ integer *iwork, logical *bwork, integer *info);
+
+/* Subroutine */ int zggglm_(integer *n, integer *m, integer *p,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *d__, doublecomplex *x, doublecomplex *y, doublecomplex
+ *work, integer *lwork, integer *info);
+
+/* Subroutine */ int zgghrd_(char *compq, char *compz, integer *n, integer *
+ ilo, integer *ihi, doublecomplex *a, integer *lda, doublecomplex *b,
+ integer *ldb, doublecomplex *q, integer *ldq, doublecomplex *z__,
+ integer *ldz, integer *info);
+
+/* Subroutine */ int zgglse_(integer *m, integer *n, integer *p,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *c__, doublecomplex *d__, doublecomplex *x,
+ doublecomplex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int zggqrf_(integer *n, integer *m, integer *p,
+ doublecomplex *a, integer *lda, doublecomplex *taua, doublecomplex *b,
+ integer *ldb, doublecomplex *taub, doublecomplex *work, integer *
+ lwork, integer *info);
+
+/* Subroutine */ int zggrqf_(integer *m, integer *p, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *taua, doublecomplex *b,
+ integer *ldb, doublecomplex *taub, doublecomplex *work, integer *
+ lwork, integer *info);
+
+/* Subroutine */ int zggsvd_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *n, integer *p, integer *k, integer *l, doublecomplex *a,
+ integer *lda, doublecomplex *b, integer *ldb, doublereal *alpha,
+ doublereal *beta, doublecomplex *u, integer *ldu, doublecomplex *v,
+ integer *ldv, doublecomplex *q, integer *ldq, doublecomplex *work,
+ doublereal *rwork, integer *iwork, integer *info);
+
+/* Subroutine */ int zggsvp_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *p, integer *n, doublecomplex *a, integer *lda, doublecomplex
+ *b, integer *ldb, doublereal *tola, doublereal *tolb, integer *k,
+ integer *l, doublecomplex *u, integer *ldu, doublecomplex *v, integer
+ *ldv, doublecomplex *q, integer *ldq, integer *iwork, doublereal *
+ rwork, doublecomplex *tau, doublecomplex *work, integer *info);
+
+/* Subroutine */ int zgtcon_(char *norm, integer *n, doublecomplex *dl,
+ doublecomplex *d__, doublecomplex *du, doublecomplex *du2, integer *
+ ipiv, doublereal *anorm, doublereal *rcond, doublecomplex *work,
+ integer *info);
+
+/* Subroutine */ int zgtrfs_(char *trans, integer *n, integer *nrhs,
+ doublecomplex *dl, doublecomplex *d__, doublecomplex *du,
+ doublecomplex *dlf, doublecomplex *df, doublecomplex *duf,
+ doublecomplex *du2, integer *ipiv, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr,
+ doublecomplex *work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zgtsv_(integer *n, integer *nrhs, doublecomplex *dl,
+ doublecomplex *d__, doublecomplex *du, doublecomplex *b, integer *ldb,
+ integer *info);
+
+/* Subroutine */ int zgtsvx_(char *fact, char *trans, integer *n, integer *
+ nrhs, doublecomplex *dl, doublecomplex *d__, doublecomplex *du,
+ doublecomplex *dlf, doublecomplex *df, doublecomplex *duf,
+ doublecomplex *du2, integer *ipiv, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr,
+ doublereal *berr, doublecomplex *work, doublereal *rwork, integer *
+ info);
+
+/* Subroutine */ int zgttrf_(integer *n, doublecomplex *dl, doublecomplex *
+ d__, doublecomplex *du, doublecomplex *du2, integer *ipiv, integer *
+ info);
+
+/* Subroutine */ int zgttrs_(char *trans, integer *n, integer *nrhs,
+ doublecomplex *dl, doublecomplex *d__, doublecomplex *du,
+ doublecomplex *du2, integer *ipiv, doublecomplex *b, integer *ldb,
+ integer *info);
+
+/* Subroutine */ int zgtts2_(integer *itrans, integer *n, integer *nrhs,
+ doublecomplex *dl, doublecomplex *d__, doublecomplex *du,
+ doublecomplex *du2, integer *ipiv, doublecomplex *b, integer *ldb);
+
+/* Subroutine */ int zhbev_(char *jobz, char *uplo, integer *n, integer *kd,
+ doublecomplex *ab, integer *ldab, doublereal *w, doublecomplex *z__,
+ integer *ldz, doublecomplex *work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zhbevd_(char *jobz, char *uplo, integer *n, integer *kd,
+ doublecomplex *ab, integer *ldab, doublereal *w, doublecomplex *z__,
+ integer *ldz, doublecomplex *work, integer *lwork, doublereal *rwork,
+ integer *lrwork, integer *iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int zhbevx_(char *jobz, char *range, char *uplo, integer *n,
+ integer *kd, doublecomplex *ab, integer *ldab, doublecomplex *q,
+ integer *ldq, doublereal *vl, doublereal *vu, integer *il, integer *
+ iu, doublereal *abstol, integer *m, doublereal *w, doublecomplex *z__,
+ integer *ldz, doublecomplex *work, doublereal *rwork, integer *iwork,
+ integer *ifail, integer *info);
+
+/* Subroutine */ int zhbgst_(char *vect, char *uplo, integer *n, integer *ka,
+ integer *kb, doublecomplex *ab, integer *ldab, doublecomplex *bb,
+ integer *ldbb, doublecomplex *x, integer *ldx, doublecomplex *work,
+ doublereal *rwork, integer *info);
+
+/* Subroutine */ int zhbgv_(char *jobz, char *uplo, integer *n, integer *ka,
+ integer *kb, doublecomplex *ab, integer *ldab, doublecomplex *bb,
+ integer *ldbb, doublereal *w, doublecomplex *z__, integer *ldz,
+ doublecomplex *work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zhbgvd_(char *jobz, char *uplo, integer *n, integer *ka,
+ integer *kb, doublecomplex *ab, integer *ldab, doublecomplex *bb,
+ integer *ldbb, doublereal *w, doublecomplex *z__, integer *ldz,
+ doublecomplex *work, integer *lwork, doublereal *rwork, integer *
+ lrwork, integer *iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int zhbgvx_(char *jobz, char *range, char *uplo, integer *n,
+ integer *ka, integer *kb, doublecomplex *ab, integer *ldab,
+ doublecomplex *bb, integer *ldbb, doublecomplex *q, integer *ldq,
+ doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *
+ abstol, integer *m, doublereal *w, doublecomplex *z__, integer *ldz,
+ doublecomplex *work, doublereal *rwork, integer *iwork, integer *
+ ifail, integer *info);
+
+/* Subroutine */ int zhbtrd_(char *vect, char *uplo, integer *n, integer *kd,
+ doublecomplex *ab, integer *ldab, doublereal *d__, doublereal *e,
+ doublecomplex *q, integer *ldq, doublecomplex *work, integer *info);
+
+/* Subroutine */ int zhecon_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *ipiv, doublereal *anorm, doublereal *rcond,
+ doublecomplex *work, integer *info);
+
+/* Subroutine */ int zheequb_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublereal *s, doublereal *scond, doublereal *amax,
+ doublecomplex *work, integer *info);
+
+/* Subroutine */ int zheev_(char *jobz, char *uplo, integer *n, doublecomplex
+ *a, integer *lda, doublereal *w, doublecomplex *work, integer *lwork,
+ doublereal *rwork, integer *info);
+
+/* Subroutine */ int zheevd_(char *jobz, char *uplo, integer *n,
+ doublecomplex *a, integer *lda, doublereal *w, doublecomplex *work,
+ integer *lwork, doublereal *rwork, integer *lrwork, integer *iwork,
+ integer *liwork, integer *info);
+
+/* Subroutine */ int zheevr_(char *jobz, char *range, char *uplo, integer *n,
+ doublecomplex *a, integer *lda, doublereal *vl, doublereal *vu,
+ integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *
+ w, doublecomplex *z__, integer *ldz, integer *isuppz, doublecomplex *
+ work, integer *lwork, doublereal *rwork, integer *lrwork, integer *
+ iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int zheevx_(char *jobz, char *range, char *uplo, integer *n,
+ doublecomplex *a, integer *lda, doublereal *vl, doublereal *vu,
+ integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *
+ w, doublecomplex *z__, integer *ldz, doublecomplex *work, integer *
+ lwork, doublereal *rwork, integer *iwork, integer *ifail, integer *
+ info);
+
+/* Subroutine */ int zhegs2_(integer *itype, char *uplo, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ integer *info);
+
+/* Subroutine */ int zhegst_(integer *itype, char *uplo, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ integer *info);
+
+/* Subroutine */ int zhegv_(integer *itype, char *jobz, char *uplo, integer *
+ n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublereal *w, doublecomplex *work, integer *lwork, doublereal *rwork,
+ integer *info);
+
+/* Subroutine */ int zhegvd_(integer *itype, char *jobz, char *uplo, integer *
+ n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublereal *w, doublecomplex *work, integer *lwork, doublereal *rwork,
+ integer *lrwork, integer *iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int zhegvx_(integer *itype, char *jobz, char *range, char *
+ uplo, integer *n, doublecomplex *a, integer *lda, doublecomplex *b,
+ integer *ldb, doublereal *vl, doublereal *vu, integer *il, integer *
+ iu, doublereal *abstol, integer *m, doublereal *w, doublecomplex *z__,
+ integer *ldz, doublecomplex *work, integer *lwork, doublereal *rwork,
+ integer *iwork, integer *ifail, integer *info);
+
+/* Subroutine */ int zherfs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf,
+ integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x,
+ integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work,
+ doublereal *rwork, integer *info);
+
+/* Subroutine */ int zherfsx_(char *uplo, char *equed, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, integer *ipiv, doublereal *s, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *berr,
+ integer *n_err_bnds__, doublereal *err_bnds_norm__, doublereal *
+ err_bnds_comp__, integer *nparams, doublereal *params, doublecomplex *
+ work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zhesv_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b,
+ integer *ldb, doublecomplex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int zhesvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x,
+ integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr,
+ doublecomplex *work, integer *lwork, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zhesvxx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, integer *ipiv, char *equed, doublereal *s, doublecomplex *b,
+ integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond,
+ doublereal *rpvgrw, doublereal *berr, integer *n_err_bnds__,
+ doublereal *err_bnds_norm__, doublereal *err_bnds_comp__, integer *
+ nparams, doublereal *params, doublecomplex *work, doublereal *rwork,
+ integer *info);
+
+/* Subroutine */ int zhetd2_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublereal *d__, doublereal *e, doublecomplex *tau,
+ integer *info);
+
+/* Subroutine */ int zhetf2_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *ipiv, integer *info);
+
+/* Subroutine */ int zhetrd_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublereal *d__, doublereal *e, doublecomplex *tau,
+ doublecomplex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int zhetrf_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *ipiv, doublecomplex *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int zhetri_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *ipiv, doublecomplex *work, integer *info);
+
+/* Subroutine */ int zhetrs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b,
+ integer *ldb, integer *info);
+
+/* Subroutine */ int zhfrk_(char *transr, char *uplo, char *trans, integer *n,
+ integer *k, doublereal *alpha, doublecomplex *a, integer *lda,
+ doublereal *beta, doublecomplex *c__);
+
+/* Subroutine */ int zhgeqz_(char *job, char *compq, char *compz, integer *n,
+ integer *ilo, integer *ihi, doublecomplex *h__, integer *ldh,
+ doublecomplex *t, integer *ldt, doublecomplex *alpha, doublecomplex *
+ beta, doublecomplex *q, integer *ldq, doublecomplex *z__, integer *
+ ldz, doublecomplex *work, integer *lwork, doublereal *rwork, integer *
+ info);
+
+/* Subroutine */ int zhpcon_(char *uplo, integer *n, doublecomplex *ap,
+ integer *ipiv, doublereal *anorm, doublereal *rcond, doublecomplex *
+ work, integer *info);
+
+/* Subroutine */ int zhpev_(char *jobz, char *uplo, integer *n, doublecomplex
+ *ap, doublereal *w, doublecomplex *z__, integer *ldz, doublecomplex *
+ work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zhpevd_(char *jobz, char *uplo, integer *n,
+ doublecomplex *ap, doublereal *w, doublecomplex *z__, integer *ldz,
+ doublecomplex *work, integer *lwork, doublereal *rwork, integer *
+ lrwork, integer *iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int zhpevx_(char *jobz, char *range, char *uplo, integer *n,
+ doublecomplex *ap, doublereal *vl, doublereal *vu, integer *il,
+ integer *iu, doublereal *abstol, integer *m, doublereal *w,
+ doublecomplex *z__, integer *ldz, doublecomplex *work, doublereal *
+ rwork, integer *iwork, integer *ifail, integer *info);
+
+/* Subroutine */ int zhpgst_(integer *itype, char *uplo, integer *n,
+ doublecomplex *ap, doublecomplex *bp, integer *info);
+
+/* Subroutine */ int zhpgv_(integer *itype, char *jobz, char *uplo, integer *
+ n, doublecomplex *ap, doublecomplex *bp, doublereal *w, doublecomplex
+ *z__, integer *ldz, doublecomplex *work, doublereal *rwork, integer *
+ info);
+
+/* Subroutine */ int zhpgvd_(integer *itype, char *jobz, char *uplo, integer *
+ n, doublecomplex *ap, doublecomplex *bp, doublereal *w, doublecomplex
+ *z__, integer *ldz, doublecomplex *work, integer *lwork, doublereal *
+ rwork, integer *lrwork, integer *iwork, integer *liwork, integer *
+ info);
+
+/* Subroutine */ int zhpgvx_(integer *itype, char *jobz, char *range, char *
+ uplo, integer *n, doublecomplex *ap, doublecomplex *bp, doublereal *
+ vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol,
+ integer *m, doublereal *w, doublecomplex *z__, integer *ldz,
+ doublecomplex *work, doublereal *rwork, integer *iwork, integer *
+ ifail, integer *info);
+
+/* Subroutine */ int zhprfs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *ap, doublecomplex *afp, integer *ipiv, doublecomplex *
+ b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr,
+ doublereal *berr, doublecomplex *work, doublereal *rwork, integer *
+ info);
+
+/* Subroutine */ int zhpsv_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *ap, integer *ipiv, doublecomplex *b, integer *ldb,
+ integer *info);
+
+/* Subroutine */ int zhpsvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublecomplex *ap, doublecomplex *afp, integer *ipiv,
+ doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
+ doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *
+ work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zhptrd_(char *uplo, integer *n, doublecomplex *ap,
+ doublereal *d__, doublereal *e, doublecomplex *tau, integer *info);
+
+/* Subroutine */ int zhptrf_(char *uplo, integer *n, doublecomplex *ap,
+ integer *ipiv, integer *info);
+
+/* Subroutine */ int zhptri_(char *uplo, integer *n, doublecomplex *ap,
+ integer *ipiv, doublecomplex *work, integer *info);
+
+/* Subroutine */ int zhptrs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *ap, integer *ipiv, doublecomplex *b, integer *ldb,
+ integer *info);
+
+/* Subroutine */ int zhsein_(char *side, char *eigsrc, char *initv, logical *
+ select, integer *n, doublecomplex *h__, integer *ldh, doublecomplex *
+ w, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr,
+ integer *mm, integer *m, doublecomplex *work, doublereal *rwork,
+ integer *ifaill, integer *ifailr, integer *info);
+
+/* Subroutine */ int zhseqr_(char *job, char *compz, integer *n, integer *ilo,
+ integer *ihi, doublecomplex *h__, integer *ldh, doublecomplex *w,
+ doublecomplex *z__, integer *ldz, doublecomplex *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int zla_gbamv__(integer *trans, integer *m, integer *n,
+ integer *kl, integer *ku, doublereal *alpha, doublecomplex *ab,
+ integer *ldab, doublecomplex *x, integer *incx, doublereal *beta,
+ doublereal *y, integer *incy);
+
+doublereal zla_gbrcond_c__(char *trans, integer *n, integer *kl, integer *ku,
+ doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *ldafb,
+ integer *ipiv, doublereal *c__, logical *capply, integer *info,
+ doublecomplex *work, doublereal *rwork, ftnlen trans_len);
+
+doublereal zla_gbrcond_x__(char *trans, integer *n, integer *kl, integer *ku,
+ doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *ldafb,
+ integer *ipiv, doublecomplex *x, integer *info, doublecomplex *work,
+ doublereal *rwork, ftnlen trans_len);
+
+/* Subroutine */ int zla_gbrfsx_extended__(integer *prec_type__, integer *
+ trans_type__, integer *n, integer *kl, integer *ku, integer *nrhs,
+ doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *ldafb,
+ integer *ipiv, logical *colequ, doublereal *c__, doublecomplex *b,
+ integer *ldb, doublecomplex *y, integer *ldy, doublereal *berr_out__,
+ integer *n_norms__, doublereal *errs_n__, doublereal *errs_c__,
+ doublecomplex *res, doublereal *ayb, doublecomplex *dy, doublecomplex
+ *y_tail__, doublereal *rcond, integer *ithresh, doublereal *rthresh,
+ doublereal *dz_ub__, logical *ignore_cwise__, integer *info);
+
+doublereal zla_gbrpvgrw__(integer *n, integer *kl, integer *ku, integer *
+ ncols, doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *
+ ldafb);
+
+/* Subroutine */ int zla_geamv__(integer *trans, integer *m, integer *n,
+ doublereal *alpha, doublecomplex *a, integer *lda, doublecomplex *x,
+ integer *incx, doublereal *beta, doublereal *y, integer *incy);
+
+doublereal zla_gercond_c__(char *trans, integer *n, doublecomplex *a, integer
+ *lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublereal *
+ c__, logical *capply, integer *info, doublecomplex *work, doublereal *
+ rwork, ftnlen trans_len);
+
+doublereal zla_gercond_x__(char *trans, integer *n, doublecomplex *a, integer
+ *lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublecomplex *
+ x, integer *info, doublecomplex *work, doublereal *rwork, ftnlen
+ trans_len);
+
+/* Subroutine */ int zla_gerfsx_extended__(integer *prec_type__, integer *
+ trans_type__, integer *n, integer *nrhs, doublecomplex *a, integer *
+ lda, doublecomplex *af, integer *ldaf, integer *ipiv, logical *colequ,
+ doublereal *c__, doublecomplex *b, integer *ldb, doublecomplex *y,
+ integer *ldy, doublereal *berr_out__, integer *n_norms__, doublereal *
+ errs_n__, doublereal *errs_c__, doublecomplex *res, doublereal *ayb,
+ doublecomplex *dy, doublecomplex *y_tail__, doublereal *rcond,
+ integer *ithresh, doublereal *rthresh, doublereal *dz_ub__, logical *
+ ignore_cwise__, integer *info);
+
+/* Subroutine */ int zla_heamv__(integer *uplo, integer *n, doublereal *alpha,
+ doublecomplex *a, integer *lda, doublecomplex *x, integer *incx,
+ doublereal *beta, doublereal *y, integer *incy);
+
+doublereal zla_hercond_c__(char *uplo, integer *n, doublecomplex *a, integer *
+ lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublereal *c__,
+ logical *capply, integer *info, doublecomplex *work, doublereal *
+ rwork, ftnlen uplo_len);
+
+doublereal zla_hercond_x__(char *uplo, integer *n, doublecomplex *a, integer *
+ lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublecomplex *
+ x, integer *info, doublecomplex *work, doublereal *rwork, ftnlen
+ uplo_len);
+
+/* Subroutine */ int zla_herfsx_extended__(integer *prec_type__, char *uplo,
+ integer *n, integer *nrhs, doublecomplex *a, integer *lda,
+ doublecomplex *af, integer *ldaf, integer *ipiv, logical *colequ,
+ doublereal *c__, doublecomplex *b, integer *ldb, doublecomplex *y,
+ integer *ldy, doublereal *berr_out__, integer *n_norms__, doublereal *
+ errs_n__, doublereal *errs_c__, doublecomplex *res, doublereal *ayb,
+ doublecomplex *dy, doublecomplex *y_tail__, doublereal *rcond,
+ integer *ithresh, doublereal *rthresh, doublereal *dz_ub__, logical *
+ ignore_cwise__, integer *info, ftnlen uplo_len);
+
+doublereal zla_herpvgrw__(char *uplo, integer *n, integer *info,
+ doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf,
+ integer *ipiv, doublereal *work, ftnlen uplo_len);
+
+/* Subroutine */ int zla_lin_berr__(integer *n, integer *nz, integer *nrhs,
+ doublecomplex *res, doublereal *ayb, doublereal *berr);
+
+doublereal zla_porcond_c__(char *uplo, integer *n, doublecomplex *a, integer *
+ lda, doublecomplex *af, integer *ldaf, doublereal *c__, logical *
+ capply, integer *info, doublecomplex *work, doublereal *rwork, ftnlen
+ uplo_len);
+
+doublereal zla_porcond_x__(char *uplo, integer *n, doublecomplex *a, integer *
+ lda, doublecomplex *af, integer *ldaf, doublecomplex *x, integer *
+ info, doublecomplex *work, doublereal *rwork, ftnlen uplo_len);
+
+/* Subroutine */ int zla_porfsx_extended__(integer *prec_type__, char *uplo,
+ integer *n, integer *nrhs, doublecomplex *a, integer *lda,
+ doublecomplex *af, integer *ldaf, logical *colequ, doublereal *c__,
+ doublecomplex *b, integer *ldb, doublecomplex *y, integer *ldy,
+ doublereal *berr_out__, integer *n_norms__, doublereal *errs_n__,
+ doublereal *errs_c__, doublecomplex *res, doublereal *ayb,
+ doublecomplex *dy, doublecomplex *y_tail__, doublereal *rcond,
+ integer *ithresh, doublereal *rthresh, doublereal *dz_ub__, logical *
+ ignore_cwise__, integer *info, ftnlen uplo_len);
+
+doublereal zla_porpvgrw__(char *uplo, integer *ncols, doublecomplex *a,
+ integer *lda, doublecomplex *af, integer *ldaf, doublereal *work,
+ ftnlen uplo_len);
+
+doublereal zla_rpvgrw__(integer *n, integer *ncols, doublecomplex *a, integer
+ *lda, doublecomplex *af, integer *ldaf);
+
+/* Subroutine */ int zla_syamv__(integer *uplo, integer *n, doublereal *alpha,
+ doublecomplex *a, integer *lda, doublecomplex *x, integer *incx,
+ doublereal *beta, doublereal *y, integer *incy);
+
+doublereal zla_syrcond_c__(char *uplo, integer *n, doublecomplex *a, integer *
+ lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublereal *c__,
+ logical *capply, integer *info, doublecomplex *work, doublereal *
+ rwork, ftnlen uplo_len);
+
+doublereal zla_syrcond_x__(char *uplo, integer *n, doublecomplex *a, integer *
+ lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublecomplex *
+ x, integer *info, doublecomplex *work, doublereal *rwork, ftnlen
+ uplo_len);
+
+/* Subroutine */ int zla_syrfsx_extended__(integer *prec_type__, char *uplo,
+ integer *n, integer *nrhs, doublecomplex *a, integer *lda,
+ doublecomplex *af, integer *ldaf, integer *ipiv, logical *colequ,
+ doublereal *c__, doublecomplex *b, integer *ldb, doublecomplex *y,
+ integer *ldy, doublereal *berr_out__, integer *n_norms__, doublereal *
+ errs_n__, doublereal *errs_c__, doublecomplex *res, doublereal *ayb,
+ doublecomplex *dy, doublecomplex *y_tail__, doublereal *rcond,
+ integer *ithresh, doublereal *rthresh, doublereal *dz_ub__, logical *
+ ignore_cwise__, integer *info, ftnlen uplo_len);
+
+doublereal zla_syrpvgrw__(char *uplo, integer *n, integer *info,
+ doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf,
+ integer *ipiv, doublereal *work, ftnlen uplo_len);
+
+/* Subroutine */ int zla_wwaddw__(integer *n, doublecomplex *x, doublecomplex
+ *y, doublecomplex *w);
+
+/* Subroutine */ int zlabrd_(integer *m, integer *n, integer *nb,
+ doublecomplex *a, integer *lda, doublereal *d__, doublereal *e,
+ doublecomplex *tauq, doublecomplex *taup, doublecomplex *x, integer *
+ ldx, doublecomplex *y, integer *ldy);
+
+/* Subroutine */ int zlacgv_(integer *n, doublecomplex *x, integer *incx);
+
+/* Subroutine */ int zlacn2_(integer *n, doublecomplex *v, doublecomplex *x,
+ doublereal *est, integer *kase, integer *isave);
+
+/* Subroutine */ int zlacon_(integer *n, doublecomplex *v, doublecomplex *x,
+ doublereal *est, integer *kase);
+
+/* Subroutine */ int zlacp2_(char *uplo, integer *m, integer *n, doublereal *
+ a, integer *lda, doublecomplex *b, integer *ldb);
+
+/* Subroutine */ int zlacpy_(char *uplo, integer *m, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb);
+
+/* Subroutine */ int zlacrm_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublereal *b, integer *ldb, doublecomplex *c__,
+ integer *ldc, doublereal *rwork);
+
+/* Subroutine */ int zlacrt_(integer *n, doublecomplex *cx, integer *incx,
+ doublecomplex *cy, integer *incy, doublecomplex *c__, doublecomplex *
+ s);
+
+/* Double Complex */ VOID zladiv_(doublecomplex * ret_val, doublecomplex *x,
+ doublecomplex *y);
+
+/* Subroutine */ int zlaed0_(integer *qsiz, integer *n, doublereal *d__,
+ doublereal *e, doublecomplex *q, integer *ldq, doublecomplex *qstore,
+ integer *ldqs, doublereal *rwork, integer *iwork, integer *info);
+
+/* Subroutine */ int zlaed7_(integer *n, integer *cutpnt, integer *qsiz,
+ integer *tlvls, integer *curlvl, integer *curpbm, doublereal *d__,
+ doublecomplex *q, integer *ldq, doublereal *rho, integer *indxq,
+ doublereal *qstore, integer *qptr, integer *prmptr, integer *perm,
+ integer *givptr, integer *givcol, doublereal *givnum, doublecomplex *
+ work, doublereal *rwork, integer *iwork, integer *info);
+
+/* Subroutine */ int zlaed8_(integer *k, integer *n, integer *qsiz,
+ doublecomplex *q, integer *ldq, doublereal *d__, doublereal *rho,
+ integer *cutpnt, doublereal *z__, doublereal *dlamda, doublecomplex *
+ q2, integer *ldq2, doublereal *w, integer *indxp, integer *indx,
+ integer *indxq, integer *perm, integer *givptr, integer *givcol,
+ doublereal *givnum, integer *info);
+
+/* Subroutine */ int zlaein_(logical *rightv, logical *noinit, integer *n,
+ doublecomplex *h__, integer *ldh, doublecomplex *w, doublecomplex *v,
+ doublecomplex *b, integer *ldb, doublereal *rwork, doublereal *eps3,
+ doublereal *smlnum, integer *info);
+
+/* Subroutine */ int zlaesy_(doublecomplex *a, doublecomplex *b,
+ doublecomplex *c__, doublecomplex *rt1, doublecomplex *rt2,
+ doublecomplex *evscal, doublecomplex *cs1, doublecomplex *sn1);
+
+/* Subroutine */ int zlaev2_(doublecomplex *a, doublecomplex *b,
+ doublecomplex *c__, doublereal *rt1, doublereal *rt2, doublereal *cs1,
+ doublecomplex *sn1);
+
+/* Subroutine */ int zlag2c_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, complex *sa, integer *ldsa, integer *info);
+
+/* Subroutine */ int zlags2_(logical *upper, doublereal *a1, doublecomplex *
+ a2, doublereal *a3, doublereal *b1, doublecomplex *b2, doublereal *b3,
+ doublereal *csu, doublecomplex *snu, doublereal *csv, doublecomplex *
+ snv, doublereal *csq, doublecomplex *snq);
+
+/* Subroutine */ int zlagtm_(char *trans, integer *n, integer *nrhs,
+ doublereal *alpha, doublecomplex *dl, doublecomplex *d__,
+ doublecomplex *du, doublecomplex *x, integer *ldx, doublereal *beta,
+ doublecomplex *b, integer *ldb);
+
+/* Subroutine */ int zlahef_(char *uplo, integer *n, integer *nb, integer *kb,
+ doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *w,
+ integer *ldw, integer *info);
+
+/* Subroutine */ int zlahqr_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, doublecomplex *h__, integer *ldh,
+ doublecomplex *w, integer *iloz, integer *ihiz, doublecomplex *z__,
+ integer *ldz, integer *info);
+
+/* Subroutine */ int zlahr2_(integer *n, integer *k, integer *nb,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *t,
+ integer *ldt, doublecomplex *y, integer *ldy);
+
+/* Subroutine */ int zlahrd_(integer *n, integer *k, integer *nb,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *t,
+ integer *ldt, doublecomplex *y, integer *ldy);
+
+/* Subroutine */ int zlaic1_(integer *job, integer *j, doublecomplex *x,
+ doublereal *sest, doublecomplex *w, doublecomplex *gamma, doublereal *
+ sestpr, doublecomplex *s, doublecomplex *c__);
+
+/* Subroutine */ int zlals0_(integer *icompq, integer *nl, integer *nr,
+ integer *sqre, integer *nrhs, doublecomplex *b, integer *ldb,
+ doublecomplex *bx, integer *ldbx, integer *perm, integer *givptr,
+ integer *givcol, integer *ldgcol, doublereal *givnum, integer *ldgnum,
+ doublereal *poles, doublereal *difl, doublereal *difr, doublereal *
+ z__, integer *k, doublereal *c__, doublereal *s, doublereal *rwork,
+ integer *info);
+
+/* Subroutine */ int zlalsa_(integer *icompq, integer *smlsiz, integer *n,
+ integer *nrhs, doublecomplex *b, integer *ldb, doublecomplex *bx,
+ integer *ldbx, doublereal *u, integer *ldu, doublereal *vt, integer *
+ k, doublereal *difl, doublereal *difr, doublereal *z__, doublereal *
+ poles, integer *givptr, integer *givcol, integer *ldgcol, integer *
+ perm, doublereal *givnum, doublereal *c__, doublereal *s, doublereal *
+ rwork, integer *iwork, integer *info);
+
+/* Subroutine */ int zlalsd_(char *uplo, integer *smlsiz, integer *n, integer
+ *nrhs, doublereal *d__, doublereal *e, doublecomplex *b, integer *ldb,
+ doublereal *rcond, integer *rank, doublecomplex *work, doublereal *
+ rwork, integer *iwork, integer *info);
+
+doublereal zlangb_(char *norm, integer *n, integer *kl, integer *ku,
+ doublecomplex *ab, integer *ldab, doublereal *work);
+
+doublereal zlange_(char *norm, integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublereal *work);
+
+doublereal zlangt_(char *norm, integer *n, doublecomplex *dl, doublecomplex *
+ d__, doublecomplex *du);
+
+doublereal zlanhb_(char *norm, char *uplo, integer *n, integer *k,
+ doublecomplex *ab, integer *ldab, doublereal *work);
+
+doublereal zlanhe_(char *norm, char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublereal *work);
+
+doublereal zlanhf_(char *norm, char *transr, char *uplo, integer *n,
+ doublecomplex *a, doublereal *work);
+
+doublereal zlanhp_(char *norm, char *uplo, integer *n, doublecomplex *ap,
+ doublereal *work);
+
+doublereal zlanhs_(char *norm, integer *n, doublecomplex *a, integer *lda,
+ doublereal *work);
+
+doublereal zlanht_(char *norm, integer *n, doublereal *d__, doublecomplex *e);
+
+doublereal zlansb_(char *norm, char *uplo, integer *n, integer *k,
+ doublecomplex *ab, integer *ldab, doublereal *work);
+
+doublereal zlansp_(char *norm, char *uplo, integer *n, doublecomplex *ap,
+ doublereal *work);
+
+doublereal zlansy_(char *norm, char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublereal *work);
+
+doublereal zlantb_(char *norm, char *uplo, char *diag, integer *n, integer *k,
+ doublecomplex *ab, integer *ldab, doublereal *work);
+
+doublereal zlantp_(char *norm, char *uplo, char *diag, integer *n,
+ doublecomplex *ap, doublereal *work);
+
+doublereal zlantr_(char *norm, char *uplo, char *diag, integer *m, integer *n,
+ doublecomplex *a, integer *lda, doublereal *work);
+
+/* Subroutine */ int zlapll_(integer *n, doublecomplex *x, integer *incx,
+ doublecomplex *y, integer *incy, doublereal *ssmin);
+
+/* Subroutine */ int zlapmt_(logical *forwrd, integer *m, integer *n,
+ doublecomplex *x, integer *ldx, integer *k);
+
+/* Subroutine */ int zlaqgb_(integer *m, integer *n, integer *kl, integer *ku,
+ doublecomplex *ab, integer *ldab, doublereal *r__, doublereal *c__,
+ doublereal *rowcnd, doublereal *colcnd, doublereal *amax, char *equed);
+
+/* Subroutine */ int zlaqge_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublereal *r__, doublereal *c__, doublereal *rowcnd,
+ doublereal *colcnd, doublereal *amax, char *equed);
+
+/* Subroutine */ int zlaqhb_(char *uplo, integer *n, integer *kd,
+ doublecomplex *ab, integer *ldab, doublereal *s, doublereal *scond,
+ doublereal *amax, char *equed);
+
+/* Subroutine */ int zlaqhe_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublereal *s, doublereal *scond, doublereal *amax,
+ char *equed);
+
+/* Subroutine */ int zlaqhp_(char *uplo, integer *n, doublecomplex *ap,
+ doublereal *s, doublereal *scond, doublereal *amax, char *equed);
+
+/* Subroutine */ int zlaqp2_(integer *m, integer *n, integer *offset,
+ doublecomplex *a, integer *lda, integer *jpvt, doublecomplex *tau,
+ doublereal *vn1, doublereal *vn2, doublecomplex *work);
+
+/* Subroutine */ int zlaqps_(integer *m, integer *n, integer *offset, integer
+ *nb, integer *kb, doublecomplex *a, integer *lda, integer *jpvt,
+ doublecomplex *tau, doublereal *vn1, doublereal *vn2, doublecomplex *
+ auxv, doublecomplex *f, integer *ldf);
+
+/* Subroutine */ int zlaqr0_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, doublecomplex *h__, integer *ldh,
+ doublecomplex *w, integer *iloz, integer *ihiz, doublecomplex *z__,
+ integer *ldz, doublecomplex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int zlaqr1_(integer *n, doublecomplex *h__, integer *ldh,
+ doublecomplex *s1, doublecomplex *s2, doublecomplex *v);
+
+/* Subroutine */ int zlaqr2_(logical *wantt, logical *wantz, integer *n,
+ integer *ktop, integer *kbot, integer *nw, doublecomplex *h__,
+ integer *ldh, integer *iloz, integer *ihiz, doublecomplex *z__,
+ integer *ldz, integer *ns, integer *nd, doublecomplex *sh,
+ doublecomplex *v, integer *ldv, integer *nh, doublecomplex *t,
+ integer *ldt, integer *nv, doublecomplex *wv, integer *ldwv,
+ doublecomplex *work, integer *lwork);
+
+/* Subroutine */ int zlaqr3_(logical *wantt, logical *wantz, integer *n,
+ integer *ktop, integer *kbot, integer *nw, doublecomplex *h__,
+ integer *ldh, integer *iloz, integer *ihiz, doublecomplex *z__,
+ integer *ldz, integer *ns, integer *nd, doublecomplex *sh,
+ doublecomplex *v, integer *ldv, integer *nh, doublecomplex *t,
+ integer *ldt, integer *nv, doublecomplex *wv, integer *ldwv,
+ doublecomplex *work, integer *lwork);
+
+/* Subroutine */ int zlaqr4_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, doublecomplex *h__, integer *ldh,
+ doublecomplex *w, integer *iloz, integer *ihiz, doublecomplex *z__,
+ integer *ldz, doublecomplex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int zlaqr5_(logical *wantt, logical *wantz, integer *kacc22,
+ integer *n, integer *ktop, integer *kbot, integer *nshfts,
+ doublecomplex *s, doublecomplex *h__, integer *ldh, integer *iloz,
+ integer *ihiz, doublecomplex *z__, integer *ldz, doublecomplex *v,
+ integer *ldv, doublecomplex *u, integer *ldu, integer *nv,
+ doublecomplex *wv, integer *ldwv, integer *nh, doublecomplex *wh,
+ integer *ldwh);
+
+/* Subroutine */ int zlaqsb_(char *uplo, integer *n, integer *kd,
+ doublecomplex *ab, integer *ldab, doublereal *s, doublereal *scond,
+ doublereal *amax, char *equed);
+
+/* Subroutine */ int zlaqsp_(char *uplo, integer *n, doublecomplex *ap,
+ doublereal *s, doublereal *scond, doublereal *amax, char *equed);
+
+/* Subroutine */ int zlaqsy_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublereal *s, doublereal *scond, doublereal *amax,
+ char *equed);
+
+/* Subroutine */ int zlar1v_(integer *n, integer *b1, integer *bn, doublereal
+ *lambda, doublereal *d__, doublereal *l, doublereal *ld, doublereal *
+ lld, doublereal *pivmin, doublereal *gaptol, doublecomplex *z__,
+ logical *wantnc, integer *negcnt, doublereal *ztz, doublereal *mingma,
+ integer *r__, integer *isuppz, doublereal *nrminv, doublereal *resid,
+ doublereal *rqcorr, doublereal *work);
+
+/* Subroutine */ int zlar2v_(integer *n, doublecomplex *x, doublecomplex *y,
+ doublecomplex *z__, integer *incx, doublereal *c__, doublecomplex *s,
+ integer *incc);
+
+/* Subroutine */ int zlarcm_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublecomplex *b, integer *ldb, doublecomplex *c__, integer *ldc,
+ doublereal *rwork);
+
+/* Subroutine */ int zlarf_(char *side, integer *m, integer *n, doublecomplex
+ *v, integer *incv, doublecomplex *tau, doublecomplex *c__, integer *
+ ldc, doublecomplex *work);
+
+/* Subroutine */ int zlarfb_(char *side, char *trans, char *direct, char *
+ storev, integer *m, integer *n, integer *k, doublecomplex *v, integer
+ *ldv, doublecomplex *t, integer *ldt, doublecomplex *c__, integer *
+ ldc, doublecomplex *work, integer *ldwork);
+
+/* Subroutine */ int zlarfg_(integer *n, doublecomplex *alpha, doublecomplex *
+ x, integer *incx, doublecomplex *tau);
+
+/* Subroutine */ int zlarfp_(integer *n, doublecomplex *alpha, doublecomplex *
+ x, integer *incx, doublecomplex *tau);
+
+/* Subroutine */ int zlarft_(char *direct, char *storev, integer *n, integer *
+ k, doublecomplex *v, integer *ldv, doublecomplex *tau, doublecomplex *
+ t, integer *ldt);
+
+/* Subroutine */ int zlarfx_(char *side, integer *m, integer *n,
+ doublecomplex *v, doublecomplex *tau, doublecomplex *c__, integer *
+ ldc, doublecomplex *work);
+
+/* Subroutine */ int zlargv_(integer *n, doublecomplex *x, integer *incx,
+ doublecomplex *y, integer *incy, doublereal *c__, integer *incc);
+
+/* Subroutine */ int zlarnv_(integer *idist, integer *iseed, integer *n,
+ doublecomplex *x);
+
+/* Subroutine */ int zlarrv_(integer *n, doublereal *vl, doublereal *vu,
+ doublereal *d__, doublereal *l, doublereal *pivmin, integer *isplit,
+ integer *m, integer *dol, integer *dou, doublereal *minrgp,
+ doublereal *rtol1, doublereal *rtol2, doublereal *w, doublereal *werr,
+ doublereal *wgap, integer *iblock, integer *indexw, doublereal *gers,
+ doublecomplex *z__, integer *ldz, integer *isuppz, doublereal *work,
+ integer *iwork, integer *info);
+
+/* Subroutine */ int zlarscl2_(integer *m, integer *n, doublereal *d__,
+ doublecomplex *x, integer *ldx);
+
+/* Subroutine */ int zlartg_(doublecomplex *f, doublecomplex *g, doublereal *
+ cs, doublecomplex *sn, doublecomplex *r__);
+
+/* Subroutine */ int zlartv_(integer *n, doublecomplex *x, integer *incx,
+ doublecomplex *y, integer *incy, doublereal *c__, doublecomplex *s,
+ integer *incc);
+
+/* Subroutine */ int zlarz_(char *side, integer *m, integer *n, integer *l,
+ doublecomplex *v, integer *incv, doublecomplex *tau, doublecomplex *
+ c__, integer *ldc, doublecomplex *work);
+
+/* Subroutine */ int zlarzb_(char *side, char *trans, char *direct, char *
+ storev, integer *m, integer *n, integer *k, integer *l, doublecomplex
+ *v, integer *ldv, doublecomplex *t, integer *ldt, doublecomplex *c__,
+ integer *ldc, doublecomplex *work, integer *ldwork);
+
+/* Subroutine */ int zlarzt_(char *direct, char *storev, integer *n, integer *
+ k, doublecomplex *v, integer *ldv, doublecomplex *tau, doublecomplex *
+ t, integer *ldt);
+
+/* Subroutine */ int zlascl_(char *type__, integer *kl, integer *ku,
+ doublereal *cfrom, doublereal *cto, integer *m, integer *n,
+ doublecomplex *a, integer *lda, integer *info);
+
+/* Subroutine */ int zlascl2_(integer *m, integer *n, doublereal *d__,
+ doublecomplex *x, integer *ldx);
+
+/* Subroutine */ int zlaset_(char *uplo, integer *m, integer *n,
+ doublecomplex *alpha, doublecomplex *beta, doublecomplex *a, integer *
+ lda);
+
+/* Subroutine */ int zlasr_(char *side, char *pivot, char *direct, integer *m,
+ integer *n, doublereal *c__, doublereal *s, doublecomplex *a,
+ integer *lda);
+
+/* Subroutine */ int zlassq_(integer *n, doublecomplex *x, integer *incx,
+ doublereal *scale, doublereal *sumsq);
+
+/* Subroutine */ int zlaswp_(integer *n, doublecomplex *a, integer *lda,
+ integer *k1, integer *k2, integer *ipiv, integer *incx);
+
+/* Subroutine */ int zlasyf_(char *uplo, integer *n, integer *nb, integer *kb,
+ doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *w,
+ integer *ldw, integer *info);
+
+/* Subroutine */ int zlat2c_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, complex *sa, integer *ldsa, integer *info);
+
+/* Subroutine */ int zlatbs_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, integer *kd, doublecomplex *ab, integer *ldab,
+ doublecomplex *x, doublereal *scale, doublereal *cnorm, integer *info);
+
+/* Subroutine */ int zlatdf_(integer *ijob, integer *n, doublecomplex *z__,
+ integer *ldz, doublecomplex *rhs, doublereal *rdsum, doublereal *
+ rdscal, integer *ipiv, integer *jpiv);
+
+/* Subroutine */ int zlatps_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, doublecomplex *ap, doublecomplex *x, doublereal *
+ scale, doublereal *cnorm, integer *info);
+
+/* Subroutine */ int zlatrd_(char *uplo, integer *n, integer *nb,
+ doublecomplex *a, integer *lda, doublereal *e, doublecomplex *tau,
+ doublecomplex *w, integer *ldw);
+
+/* Subroutine */ int zlatrs_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, doublecomplex *a, integer *lda, doublecomplex *x,
+ doublereal *scale, doublereal *cnorm, integer *info);
+
+/* Subroutine */ int zlatrz_(integer *m, integer *n, integer *l,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work);
+
+/* Subroutine */ int zlatzm_(char *side, integer *m, integer *n,
+ doublecomplex *v, integer *incv, doublecomplex *tau, doublecomplex *
+ c1, doublecomplex *c2, integer *ldc, doublecomplex *work);
+
+/* Subroutine */ int zlauu2_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *info);
+
+/* Subroutine */ int zlauum_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *info);
+
+/* Subroutine */ int zpbcon_(char *uplo, integer *n, integer *kd,
+ doublecomplex *ab, integer *ldab, doublereal *anorm, doublereal *
+ rcond, doublecomplex *work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zpbequ_(char *uplo, integer *n, integer *kd,
+ doublecomplex *ab, integer *ldab, doublereal *s, doublereal *scond,
+ doublereal *amax, integer *info);
+
+/* Subroutine */ int zpbrfs_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *
+ ldafb, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
+ doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *
+ rwork, integer *info);
+
+/* Subroutine */ int zpbstf_(char *uplo, integer *n, integer *kd,
+ doublecomplex *ab, integer *ldab, integer *info);
+
+/* Subroutine */ int zpbsv_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, doublecomplex *ab, integer *ldab, doublecomplex *b, integer *
+ ldb, integer *info);
+
+/* Subroutine */ int zpbsvx_(char *fact, char *uplo, integer *n, integer *kd,
+ integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *afb,
+ integer *ldafb, char *equed, doublereal *s, doublecomplex *b, integer
+ *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *
+ ferr, doublereal *berr, doublecomplex *work, doublereal *rwork,
+ integer *info);
+
+/* Subroutine */ int zpbtf2_(char *uplo, integer *n, integer *kd,
+ doublecomplex *ab, integer *ldab, integer *info);
+
+/* Subroutine */ int zpbtrf_(char *uplo, integer *n, integer *kd,
+ doublecomplex *ab, integer *ldab, integer *info);
+
+/* Subroutine */ int zpbtrs_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, doublecomplex *ab, integer *ldab, doublecomplex *b, integer *
+ ldb, integer *info);
+
+/* Subroutine */ int zpftrf_(char *transr, char *uplo, integer *n,
+ doublecomplex *a, integer *info);
+
+/* Subroutine */ int zpftri_(char *transr, char *uplo, integer *n,
+ doublecomplex *a, integer *info);
+
+/* Subroutine */ int zpftrs_(char *transr, char *uplo, integer *n, integer *
+ nrhs, doublecomplex *a, doublecomplex *b, integer *ldb, integer *info);
+
+/* Subroutine */ int zpocon_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublereal *anorm, doublereal *rcond, doublecomplex *
+ work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zpoequ_(integer *n, doublecomplex *a, integer *lda,
+ doublereal *s, doublereal *scond, doublereal *amax, integer *info);
+
+/* Subroutine */ int zpoequb_(integer *n, doublecomplex *a, integer *lda,
+ doublereal *s, doublereal *scond, doublereal *amax, integer *info);
+
+/* Subroutine */ int zporfs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf,
+ doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
+ doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *
+ rwork, integer *info);
+
+/* Subroutine */ int zporfsx_(char *uplo, char *equed, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, doublereal *s, doublecomplex *b, integer *ldb, doublecomplex *x,
+ integer *ldx, doublereal *rcond, doublereal *berr, integer *
+ n_err_bnds__, doublereal *err_bnds_norm__, doublereal *
+ err_bnds_comp__, integer *nparams, doublereal *params, doublecomplex *
+ work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zposv_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ integer *info);
+
+/* Subroutine */ int zposvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, char *equed, doublereal *s, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr,
+ doublereal *berr, doublecomplex *work, doublereal *rwork, integer *
+ info);
+
+/* Subroutine */ int zposvxx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, char *equed, doublereal *s, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *rpvgrw,
+ doublereal *berr, integer *n_err_bnds__, doublereal *err_bnds_norm__,
+ doublereal *err_bnds_comp__, integer *nparams, doublereal *params,
+ doublecomplex *work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zpotf2_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *info);
+
+/* Subroutine */ int zpotrf_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *info);
+
+/* Subroutine */ int zpotri_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *info);
+
+/* Subroutine */ int zpotrs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ integer *info);
+
+/* Subroutine */ int zppcon_(char *uplo, integer *n, doublecomplex *ap,
+ doublereal *anorm, doublereal *rcond, doublecomplex *work, doublereal
+ *rwork, integer *info);
+
+/* Subroutine */ int zppequ_(char *uplo, integer *n, doublecomplex *ap,
+ doublereal *s, doublereal *scond, doublereal *amax, integer *info);
+
+/* Subroutine */ int zpprfs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *ap, doublecomplex *afp, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr,
+ doublecomplex *work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zppsv_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *ap, doublecomplex *b, integer *ldb, integer *info);
+
+/* Subroutine */ int zppsvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublecomplex *ap, doublecomplex *afp, char *equed, doublereal *
+ s, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
+ doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *
+ work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zpptrf_(char *uplo, integer *n, doublecomplex *ap,
+ integer *info);
+
+/* Subroutine */ int zpptri_(char *uplo, integer *n, doublecomplex *ap,
+ integer *info);
+
+/* Subroutine */ int zpptrs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *ap, doublecomplex *b, integer *ldb, integer *info);
+
+/* Subroutine */ int zpstf2_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *piv, integer *rank, doublereal *tol,
+ doublereal *work, integer *info);
+
+/* Subroutine */ int zpstrf_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *piv, integer *rank, doublereal *tol,
+ doublereal *work, integer *info);
+
+/* Subroutine */ int zptcon_(integer *n, doublereal *d__, doublecomplex *e,
+ doublereal *anorm, doublereal *rcond, doublereal *rwork, integer *
+ info);
+
+/* Subroutine */ int zpteqr_(char *compz, integer *n, doublereal *d__,
+ doublereal *e, doublecomplex *z__, integer *ldz, doublereal *work,
+ integer *info);
+
+/* Subroutine */ int zptrfs_(char *uplo, integer *n, integer *nrhs,
+ doublereal *d__, doublecomplex *e, doublereal *df, doublecomplex *ef,
+ doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
+ doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *
+ rwork, integer *info);
+
+/* Subroutine */ int zptsv_(integer *n, integer *nrhs, doublereal *d__,
+ doublecomplex *e, doublecomplex *b, integer *ldb, integer *info);
+
+/* Subroutine */ int zptsvx_(char *fact, integer *n, integer *nrhs,
+ doublereal *d__, doublecomplex *e, doublereal *df, doublecomplex *ef,
+ doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
+ doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *
+ work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zpttrf_(integer *n, doublereal *d__, doublecomplex *e,
+ integer *info);
+
+/* Subroutine */ int zpttrs_(char *uplo, integer *n, integer *nrhs,
+ doublereal *d__, doublecomplex *e, doublecomplex *b, integer *ldb,
+ integer *info);
+
+/* Subroutine */ int zptts2_(integer *iuplo, integer *n, integer *nrhs,
+ doublereal *d__, doublecomplex *e, doublecomplex *b, integer *ldb);
+
+/* Subroutine */ int zrot_(integer *n, doublecomplex *cx, integer *incx,
+ doublecomplex *cy, integer *incy, doublereal *c__, doublecomplex *s);
+
+/* Subroutine */ int zspcon_(char *uplo, integer *n, doublecomplex *ap,
+ integer *ipiv, doublereal *anorm, doublereal *rcond, doublecomplex *
+ work, integer *info);
+
+/* Subroutine */ int zspmv_(char *uplo, integer *n, doublecomplex *alpha,
+ doublecomplex *ap, doublecomplex *x, integer *incx, doublecomplex *
+ beta, doublecomplex *y, integer *incy);
+
+/* Subroutine */ int zspr_(char *uplo, integer *n, doublecomplex *alpha,
+ doublecomplex *x, integer *incx, doublecomplex *ap);
+
+/* Subroutine */ int zsprfs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *ap, doublecomplex *afp, integer *ipiv, doublecomplex *
+ b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr,
+ doublereal *berr, doublecomplex *work, doublereal *rwork, integer *
+ info);
+
+/* Subroutine */ int zspsv_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *ap, integer *ipiv, doublecomplex *b, integer *ldb,
+ integer *info);
+
+/* Subroutine */ int zspsvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublecomplex *ap, doublecomplex *afp, integer *ipiv,
+ doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
+ doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *
+ work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zsptrf_(char *uplo, integer *n, doublecomplex *ap,
+ integer *ipiv, integer *info);
+
+/* Subroutine */ int zsptri_(char *uplo, integer *n, doublecomplex *ap,
+ integer *ipiv, doublecomplex *work, integer *info);
+
+/* Subroutine */ int zsptrs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *ap, integer *ipiv, doublecomplex *b, integer *ldb,
+ integer *info);
+
+/* Subroutine */ int zstedc_(char *compz, integer *n, doublereal *d__,
+ doublereal *e, doublecomplex *z__, integer *ldz, doublecomplex *work,
+ integer *lwork, doublereal *rwork, integer *lrwork, integer *iwork,
+ integer *liwork, integer *info);
+
+/* Subroutine */ int zstegr_(char *jobz, char *range, integer *n, doublereal *
+ d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il,
+ integer *iu, doublereal *abstol, integer *m, doublereal *w,
+ doublecomplex *z__, integer *ldz, integer *isuppz, doublereal *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int zstein_(integer *n, doublereal *d__, doublereal *e,
+ integer *m, doublereal *w, integer *iblock, integer *isplit,
+ doublecomplex *z__, integer *ldz, doublereal *work, integer *iwork,
+ integer *ifail, integer *info);
+
+/* Subroutine */ int zstemr_(char *jobz, char *range, integer *n, doublereal *
+ d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il,
+ integer *iu, integer *m, doublereal *w, doublecomplex *z__, integer *
+ ldz, integer *nzc, integer *isuppz, logical *tryrac, doublereal *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info);
+
+/* Subroutine */ int zsteqr_(char *compz, integer *n, doublereal *d__,
+ doublereal *e, doublecomplex *z__, integer *ldz, doublereal *work,
+ integer *info);
+
+/* Subroutine */ int zsycon_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *ipiv, doublereal *anorm, doublereal *rcond,
+ doublecomplex *work, integer *info);
+
+/* Subroutine */ int zsyequb_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublereal *s, doublereal *scond, doublereal *amax,
+ doublecomplex *work, integer *info);
+
+/* Subroutine */ int zsymv_(char *uplo, integer *n, doublecomplex *alpha,
+ doublecomplex *a, integer *lda, doublecomplex *x, integer *incx,
+ doublecomplex *beta, doublecomplex *y, integer *incy);
+
+/* Subroutine */ int zsyr_(char *uplo, integer *n, doublecomplex *alpha,
+ doublecomplex *x, integer *incx, doublecomplex *a, integer *lda);
+
+/* Subroutine */ int zsyrfs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf,
+ integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x,
+ integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work,
+ doublereal *rwork, integer *info);
+
+/* Subroutine */ int zsyrfsx_(char *uplo, char *equed, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, integer *ipiv, doublereal *s, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *berr,
+ integer *n_err_bnds__, doublereal *err_bnds_norm__, doublereal *
+ err_bnds_comp__, integer *nparams, doublereal *params, doublecomplex *
+ work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zsysv_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b,
+ integer *ldb, doublecomplex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int zsysvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x,
+ integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr,
+ doublecomplex *work, integer *lwork, doublereal *rwork, integer *info);
+
+/* Subroutine */ int zsysvxx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, integer *ipiv, char *equed, doublereal *s, doublecomplex *b,
+ integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond,
+ doublereal *rpvgrw, doublereal *berr, integer *n_err_bnds__,
+ doublereal *err_bnds_norm__, doublereal *err_bnds_comp__, integer *
+ nparams, doublereal *params, doublecomplex *work, doublereal *rwork,
+ integer *info);
+
+/* Subroutine */ int zsytf2_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *ipiv, integer *info);
+
+/* Subroutine */ int zsytrf_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *ipiv, doublecomplex *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int zsytri_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *ipiv, doublecomplex *work, integer *info);
+
+/* Subroutine */ int zsytrs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b,
+ integer *ldb, integer *info);
+
+/* Subroutine */ int ztbcon_(char *norm, char *uplo, char *diag, integer *n,
+ integer *kd, doublecomplex *ab, integer *ldab, doublereal *rcond,
+ doublecomplex *work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int ztbrfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, doublecomplex *ab, integer *ldab,
+ doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
+ doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *
+ rwork, integer *info);
+
+/* Subroutine */ int ztbtrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, doublecomplex *ab, integer *ldab,
+ doublecomplex *b, integer *ldb, integer *info);
+
+/* Subroutine */ int ztfsm_(char *transr, char *side, char *uplo, char *trans,
+ char *diag, integer *m, integer *n, doublecomplex *alpha,
+ doublecomplex *a, doublecomplex *b, integer *ldb);
+
+/* Subroutine */ int ztftri_(char *transr, char *uplo, char *diag, integer *n,
+ doublecomplex *a, integer *info);
+
+/* Subroutine */ int ztfttp_(char *transr, char *uplo, integer *n,
+ doublecomplex *arf, doublecomplex *ap, integer *info);
+
+/* Subroutine */ int ztfttr_(char *transr, char *uplo, integer *n,
+ doublecomplex *arf, doublecomplex *a, integer *lda, integer *info);
+
+/* Subroutine */ int ztgevc_(char *side, char *howmny, logical *select,
+ integer *n, doublecomplex *s, integer *lds, doublecomplex *p, integer
+ *ldp, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *
+ ldvr, integer *mm, integer *m, doublecomplex *work, doublereal *rwork,
+ integer *info);
+
+/* Subroutine */ int ztgex2_(logical *wantq, logical *wantz, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *q, integer *ldq, doublecomplex *z__, integer *ldz,
+ integer *j1, integer *info);
+
+/* Subroutine */ int ztgexc_(logical *wantq, logical *wantz, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *q, integer *ldq, doublecomplex *z__, integer *ldz,
+ integer *ifst, integer *ilst, integer *info);
+
+/* Subroutine */ int ztgsen_(integer *ijob, logical *wantq, logical *wantz,
+ logical *select, integer *n, doublecomplex *a, integer *lda,
+ doublecomplex *b, integer *ldb, doublecomplex *alpha, doublecomplex *
+ beta, doublecomplex *q, integer *ldq, doublecomplex *z__, integer *
+ ldz, integer *m, doublereal *pl, doublereal *pr, doublereal *dif,
+ doublecomplex *work, integer *lwork, integer *iwork, integer *liwork,
+ integer *info);
+
+/* Subroutine */ int ztgsja_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *p, integer *n, integer *k, integer *l, doublecomplex *a,
+ integer *lda, doublecomplex *b, integer *ldb, doublereal *tola,
+ doublereal *tolb, doublereal *alpha, doublereal *beta, doublecomplex *
+ u, integer *ldu, doublecomplex *v, integer *ldv, doublecomplex *q,
+ integer *ldq, doublecomplex *work, integer *ncycle, integer *info);
+
+/* Subroutine */ int ztgsna_(char *job, char *howmny, logical *select,
+ integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer
+ *ldb, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *
+ ldvr, doublereal *s, doublereal *dif, integer *mm, integer *m,
+ doublecomplex *work, integer *lwork, integer *iwork, integer *info);
+
+/* Subroutine */ int ztgsy2_(char *trans, integer *ijob, integer *m, integer *
+ n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *c__, integer *ldc, doublecomplex *d__, integer *ldd,
+ doublecomplex *e, integer *lde, doublecomplex *f, integer *ldf,
+ doublereal *scale, doublereal *rdsum, doublereal *rdscal, integer *
+ info);
+
+/* Subroutine */ int ztgsyl_(char *trans, integer *ijob, integer *m, integer *
+ n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *c__, integer *ldc, doublecomplex *d__, integer *ldd,
+ doublecomplex *e, integer *lde, doublecomplex *f, integer *ldf,
+ doublereal *scale, doublereal *dif, doublecomplex *work, integer *
+ lwork, integer *iwork, integer *info);
+
+/* Subroutine */ int ztpcon_(char *norm, char *uplo, char *diag, integer *n,
+ doublecomplex *ap, doublereal *rcond, doublecomplex *work, doublereal
+ *rwork, integer *info);
+
+/* Subroutine */ int ztprfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublecomplex *ap, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr,
+ doublecomplex *work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int ztptri_(char *uplo, char *diag, integer *n,
+ doublecomplex *ap, integer *info);
+
+/* Subroutine */ int ztptrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublecomplex *ap, doublecomplex *b, integer *ldb,
+ integer *info);
+
+/* Subroutine */ int ztpttf_(char *transr, char *uplo, integer *n,
+ doublecomplex *ap, doublecomplex *arf, integer *info);
+
+/* Subroutine */ int ztpttr_(char *uplo, integer *n, doublecomplex *ap,
+ doublecomplex *a, integer *lda, integer *info);
+
+/* Subroutine */ int ztrcon_(char *norm, char *uplo, char *diag, integer *n,
+ doublecomplex *a, integer *lda, doublereal *rcond, doublecomplex *
+ work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int ztrevc_(char *side, char *howmny, logical *select,
+ integer *n, doublecomplex *t, integer *ldt, doublecomplex *vl,
+ integer *ldvl, doublecomplex *vr, integer *ldvr, integer *mm, integer
+ *m, doublecomplex *work, doublereal *rwork, integer *info);
+
+/* Subroutine */ int ztrexc_(char *compq, integer *n, doublecomplex *t,
+ integer *ldt, doublecomplex *q, integer *ldq, integer *ifst, integer *
+ ilst, integer *info);
+
+/* Subroutine */ int ztrrfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b,
+ integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr,
+ doublereal *berr, doublecomplex *work, doublereal *rwork, integer *
+ info);
+
+/* Subroutine */ int ztrsen_(char *job, char *compq, logical *select, integer
+ *n, doublecomplex *t, integer *ldt, doublecomplex *q, integer *ldq,
+ doublecomplex *w, integer *m, doublereal *s, doublereal *sep,
+ doublecomplex *work, integer *lwork, integer *info);
+
+/* Subroutine */ int ztrsna_(char *job, char *howmny, logical *select,
+ integer *n, doublecomplex *t, integer *ldt, doublecomplex *vl,
+ integer *ldvl, doublecomplex *vr, integer *ldvr, doublereal *s,
+ doublereal *sep, integer *mm, integer *m, doublecomplex *work,
+ integer *ldwork, doublereal *rwork, integer *info);
+
+/* Subroutine */ int ztrsyl_(char *trana, char *tranb, integer *isgn, integer
+ *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *b,
+ integer *ldb, doublecomplex *c__, integer *ldc, doublereal *scale,
+ integer *info);
+
+/* Subroutine */ int ztrti2_(char *uplo, char *diag, integer *n,
+ doublecomplex *a, integer *lda, integer *info);
+
+/* Subroutine */ int ztrtri_(char *uplo, char *diag, integer *n,
+ doublecomplex *a, integer *lda, integer *info);
+
+/* Subroutine */ int ztrtrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b,
+ integer *ldb, integer *info);
+
+/* Subroutine */ int ztrttf_(char *transr, char *uplo, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *arf, integer *info);
+
+/* Subroutine */ int ztrttp_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *ap, integer *info);
+
+/* Subroutine */ int ztzrqf_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *tau, integer *info);
+
+/* Subroutine */ int ztzrzf_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int zung2l_(integer *m, integer *n, integer *k,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *info);
+
+/* Subroutine */ int zung2r_(integer *m, integer *n, integer *k,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *info);
+
+/* Subroutine */ int zungbr_(char *vect, integer *m, integer *n, integer *k,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *lwork, integer *info);
+
+/* Subroutine */ int zunghr_(integer *n, integer *ilo, integer *ihi,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *lwork, integer *info);
+
+/* Subroutine */ int zungl2_(integer *m, integer *n, integer *k,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *info);
+
+/* Subroutine */ int zunglq_(integer *m, integer *n, integer *k,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *lwork, integer *info);
+
+/* Subroutine */ int zungql_(integer *m, integer *n, integer *k,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *lwork, integer *info);
+
+/* Subroutine */ int zungqr_(integer *m, integer *n, integer *k,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *lwork, integer *info);
+
+/* Subroutine */ int zungr2_(integer *m, integer *n, integer *k,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *info);
+
+/* Subroutine */ int zungrq_(integer *m, integer *n, integer *k,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *lwork, integer *info);
+
+/* Subroutine */ int zungtr_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int zunm2l_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublecomplex *a, integer *lda, doublecomplex *tau,
+ doublecomplex *c__, integer *ldc, doublecomplex *work, integer *info);
+
+/* Subroutine */ int zunm2r_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublecomplex *a, integer *lda, doublecomplex *tau,
+ doublecomplex *c__, integer *ldc, doublecomplex *work, integer *info);
+
+/* Subroutine */ int zunmbr_(char *vect, char *side, char *trans, integer *m,
+ integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex
+ *tau, doublecomplex *c__, integer *ldc, doublecomplex *work, integer *
+ lwork, integer *info);
+
+/* Subroutine */ int zunmhr_(char *side, char *trans, integer *m, integer *n,
+ integer *ilo, integer *ihi, doublecomplex *a, integer *lda,
+ doublecomplex *tau, doublecomplex *c__, integer *ldc, doublecomplex *
+ work, integer *lwork, integer *info);
+
+/* Subroutine */ int zunml2_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublecomplex *a, integer *lda, doublecomplex *tau,
+ doublecomplex *c__, integer *ldc, doublecomplex *work, integer *info);
+
+/* Subroutine */ int zunmlq_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublecomplex *a, integer *lda, doublecomplex *tau,
+ doublecomplex *c__, integer *ldc, doublecomplex *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int zunmql_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublecomplex *a, integer *lda, doublecomplex *tau,
+ doublecomplex *c__, integer *ldc, doublecomplex *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int zunmqr_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublecomplex *a, integer *lda, doublecomplex *tau,
+ doublecomplex *c__, integer *ldc, doublecomplex *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int zunmr2_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublecomplex *a, integer *lda, doublecomplex *tau,
+ doublecomplex *c__, integer *ldc, doublecomplex *work, integer *info);
+
+/* Subroutine */ int zunmr3_(char *side, char *trans, integer *m, integer *n,
+ integer *k, integer *l, doublecomplex *a, integer *lda, doublecomplex
+ *tau, doublecomplex *c__, integer *ldc, doublecomplex *work, integer *
+ info);
+
+/* Subroutine */ int zunmrq_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublecomplex *a, integer *lda, doublecomplex *tau,
+ doublecomplex *c__, integer *ldc, doublecomplex *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int zunmrz_(char *side, char *trans, integer *m, integer *n,
+ integer *k, integer *l, doublecomplex *a, integer *lda, doublecomplex
+ *tau, doublecomplex *c__, integer *ldc, doublecomplex *work, integer *
+ lwork, integer *info);
+
+/* Subroutine */ int zunmtr_(char *side, char *uplo, char *trans, integer *m,
+ integer *n, doublecomplex *a, integer *lda, doublecomplex *tau,
+ doublecomplex *c__, integer *ldc, doublecomplex *work, integer *lwork,
+ integer *info);
+
+/* Subroutine */ int zupgtr_(char *uplo, integer *n, doublecomplex *ap,
+ doublecomplex *tau, doublecomplex *q, integer *ldq, doublecomplex *
+ work, integer *info);
+
+/* Subroutine */ int zupmtr_(char *side, char *uplo, char *trans, integer *m,
+ integer *n, doublecomplex *ap, doublecomplex *tau, doublecomplex *c__,
+ integer *ldc, doublecomplex *work, integer *info);
+
+/* Subroutine */ int dlamc1_(integer *beta, integer *t, logical *rnd, logical
+ *ieee1);
+
+doublereal dsecnd_();
+
+/* Subroutine */ int ilaver_(integer *vers_major__, integer *vers_minor__,
+ integer *vers_patch__);
+
+logical lsame_(char *ca, char *cb);
+
+doublereal second_();
+
+doublereal slamch_(char *cmach);
+
+/* Subroutine */ int slamc1_(integer *beta, integer *t, logical *rnd, logical
+ *ieee1);
+
+/* Subroutine */ int slamc2_(integer *beta, integer *t, logical *rnd, real *
+ eps, integer *emin, real *rmin, integer *emax, real *rmax);
+
+doublereal slamc3_(real *a, real *b);
+
+/* Subroutine */ int slamc4_(integer *emin, real *start, integer *base);
+
+/* Subroutine */ int slamc5_(integer *beta, integer *p, integer *emin,
+ logical *ieee, integer *emax, real *rmax);
+
+
+doublereal dlamch_(char *cmach);
+
+/* Subroutine */ int dlamc1_(integer *beta, integer *t, logical *rnd, logical
+ *ieee1);
+
+/* Subroutine */ int dlamc2_(integer *beta, integer *t, logical *rnd,
+ doublereal *eps, integer *emin, doublereal *rmin, integer *emax,
+ doublereal *rmax);
+
+doublereal dlamc3_(doublereal *a, doublereal *b);
+
+/* Subroutine */ int dlamc4_(integer *emin, doublereal *start, integer *base);
+
+/* Subroutine */ int dlamc5_(integer *beta, integer *p, integer *emin,
+ logical *ieee, integer *emax, doublereal *rmax);
+
+integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1,
+ integer *n2, integer *n3, integer *n4);
+
+
+#endif /* __CLAPACK_H */
diff --git a/INCLUDE/f2c.h b/INCLUDE/f2c.h
new file mode 100644
index 0000000..b94ee7c
--- /dev/null
+++ b/INCLUDE/f2c.h
@@ -0,0 +1,223 @@
+/* f2c.h -- Standard Fortran to C header file */
+
+/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
+
+ - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+typedef long int integer;
+typedef unsigned long int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+typedef long int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+#ifdef INTEGER_STAR_8 /* Adjust for integer*8. */
+typedef long long longint; /* system-dependent */
+typedef unsigned long long ulongint; /* system-dependent */
+#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b)))
+#define qbit_set(a,b) ((a) | ((ulongint)1 << (b)))
+#endif
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+#ifdef f2c_i2
+/* for -i2 */
+typedef short flag;
+typedef short ftnlen;
+typedef short ftnint;
+#else
+typedef long int flag;
+typedef long int ftnlen;
+typedef long int ftnint;
+#endif
+
+/*external read, write*/
+typedef struct
+{ flag cierr;
+ ftnint ciunit;
+ flag ciend;
+ char *cifmt;
+ ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{ flag icierr;
+ char *iciunit;
+ flag iciend;
+ char *icifmt;
+ ftnint icirlen;
+ ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{ flag oerr;
+ ftnint ounit;
+ char *ofnm;
+ ftnlen ofnmlen;
+ char *osta;
+ char *oacc;
+ char *ofm;
+ ftnint orl;
+ char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{ flag cerr;
+ ftnint cunit;
+ char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{ flag aerr;
+ ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{ flag inerr;
+ ftnint inunit;
+ char *infile;
+ ftnlen infilen;
+ ftnint *inex; /*parameters in standard's order*/
+ ftnint *inopen;
+ ftnint *innum;
+ ftnint *innamed;
+ char *inname;
+ ftnlen innamlen;
+ char *inacc;
+ ftnlen inacclen;
+ char *inseq;
+ ftnlen inseqlen;
+ char *indir;
+ ftnlen indirlen;
+ char *infmt;
+ ftnlen infmtlen;
+ char *inform;
+ ftnint informlen;
+ char *inunf;
+ ftnlen inunflen;
+ ftnint *inrecl;
+ ftnint *innrec;
+ char *inblank;
+ ftnlen inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype { /* for multiple entry points */
+ integer1 g;
+ shortint h;
+ integer i;
+ /* longint j; */
+ real r;
+ doublereal d;
+ complex c;
+ doublecomplex z;
+ };
+
+typedef union Multitype Multitype;
+
+/*typedef long int Long;*/ /* No longer used; formerly in Namelist */
+
+struct Vardesc { /* for Namelist */
+ char *name;
+ char *addr;
+ ftnlen *dims;
+ int type;
+ };
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+ char *name;
+ Vardesc **vars;
+ int nvars;
+ };
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (doublereal)abs(x)
+#define min(a,b) ((a) <= (b) ? (a) : (b))
+#define max(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (doublereal)min(a,b)
+#define dmax(a,b) (doublereal)max(a,b)
+#define bit_test(a,b) ((a) >> (b) & 1)
+#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b) ((a) | ((uinteger)1 << (b)))
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef int /* Unknown procedure type */ (*U_fp)(...);
+typedef shortint (*J_fp)(...);
+typedef integer (*I_fp)(...);
+typedef real (*R_fp)(...);
+typedef doublereal (*D_fp)(...), (*E_fp)(...);
+typedef /* Complex */ VOID (*C_fp)(...);
+typedef /* Double Complex */ VOID (*Z_fp)(...);
+typedef logical (*L_fp)(...);
+typedef shortlogical (*K_fp)(...);
+typedef /* Character */ VOID (*H_fp)(...);
+typedef /* Subroutine */ int (*S_fp)(...);
+#else
+typedef int /* Unknown procedure type */ (*U_fp)();
+typedef shortint (*J_fp)();
+typedef integer (*I_fp)();
+typedef real (*R_fp)();
+typedef doublereal (*D_fp)(), (*E_fp)();
+typedef /* Complex */ VOID (*C_fp)();
+typedef /* Double Complex */ VOID (*Z_fp)();
+typedef logical (*L_fp)();
+typedef shortlogical (*K_fp)();
+typedef /* Character */ VOID (*H_fp)();
+typedef /* Subroutine */ int (*S_fp)();
+#endif
+/* E_fp is for real functions when -R is not specified */
+typedef VOID C_f; /* complex function */
+typedef VOID H_f; /* character function */
+typedef VOID Z_f; /* double complex function */
+typedef doublereal E_f; /* real function with -R not specified */
+
+/* undef any lower-case symbols that your C compiler predefines, e.g.: */
+
+#ifndef Skip_f2c_Undefs
+#undef cray
+#undef gcos
+#undef mc68010
+#undef mc68020
+#undef mips
+#undef pdp11
+#undef sgi
+#undef sparc
+#undef sun
+#undef sun2
+#undef sun3
+#undef sun4
+#undef u370
+#undef u3b
+#undef u3b2
+#undef u3b5
+#undef unix
+#undef vax
+#endif
+#endif
diff --git a/INSTALL/LAPACK_version.c b/INSTALL/LAPACK_version.c
new file mode 100644
index 0000000..2e21fc1
--- /dev/null
+++ b/INSTALL/LAPACK_version.c
@@ -0,0 +1,53 @@
+/* LAPACK_version.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__9 = 9;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_wsle(void);
+
+ /* Local variables */
+ integer patch, major, minor;
+ extern /* Subroutine */ int ilaver_(integer *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___4 = { 0, 6, 0, 0, 0 };
+
+
+
+
+
+
+ ilaver_(&major, &minor, &patch);
+ s_wsle(&io___4);
+ do_lio(&c__9, &c__1, "LAPACK ", (ftnlen)7);
+ do_lio(&c__3, &c__1, (char *)&major, (ftnlen)sizeof(integer));
+ do_lio(&c__9, &c__1, ".", (ftnlen)1);
+ do_lio(&c__3, &c__1, (char *)&minor, (ftnlen)sizeof(integer));
+ do_lio(&c__9, &c__1, ".", (ftnlen)1);
+ do_lio(&c__3, &c__1, (char *)&patch, (ftnlen)sizeof(integer));
+ e_wsle();
+
+ return 0;
+} /* MAIN__ */
+
+/* Main program alias */ int lapack_version__ () { MAIN__ (); return 0; }
diff --git a/INSTALL/Makefile b/INSTALL/Makefile
new file mode 100644
index 0000000..45ac070
--- /dev/null
+++ b/INSTALL/Makefile
@@ -0,0 +1,34 @@
+include ../make.inc
+F2CLIB = ../F2CLIBS/libf2c.a
+
+.SUFFIXES : .o .c
+all: testlsame testslamch testdlamch testsecond testdsecnd testieee testversion
+
+testlsame: lsame.o lsametst.o
+ $(CC) $(LOADOPTS) -o testlsame lsame.o lsametst.o $(F2CLIB) -lm
+
+testslamch: slamch.o lsame.o slamchtst.o
+ $(CC) $(LOADOPTS) -o testslamch slamch.o lsame.o slamchtst.o $(F2CLIB) -lm
+
+testdlamch: dlamch.o lsame.o dlamchtst.o
+ $(CC) $(LOADOPTS) -o testdlamch dlamch.o lsame.o dlamchtst.o $(F2CLIB) -lm
+
+testsecond: second.o secondtst.o
+ $(CC) $(LOADOPTS) -o testsecond second.o secondtst.o $(F2CLIB) -lm
+
+testdsecnd: dsecnd.o dsecndtst.o
+ $(CC) $(LOADOPTS) -o testdsecnd dsecnd.o dsecndtst.o $(F2CLIB) -lm
+
+testieee: tstiee.o
+ $(CC) $(LOADOPTS) -o testieee tstiee.o $(F2CLIB) -lm
+
+testversion: ilaver.o LAPACK_version.o
+ $(CC) $(LOADOPTS) -o testversion ilaver.o LAPACK_version.o $(F2CLIB) -lm
+
+clean:
+ rm -f *.o
+
+slamch.o: slamch.c ; $(CC) $(NOOPT) -I../INCLUDE -c $< -o $@
+dlamch.o: dlamch.c ; $(CC) $(NOOPT) -I../INCLUDE -c $< -o $@
+
+.c.o: ; $(CC) $(CFLAGS) -I../INCLUDE -c $< -o $@
diff --git a/INSTALL/dlamch.c b/INSTALL/dlamch.c
new file mode 100644
index 0000000..1243e82
--- /dev/null
+++ b/INSTALL/dlamch.c
@@ -0,0 +1,1001 @@
+/* dlamch.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b32 = 0.;
+
+doublereal dlamch_(char *cmach)
+{
+ /* Initialized data */
+
+ static logical first = TRUE_;
+
+ /* System generated locals */
+ integer i__1;
+ doublereal ret_val;
+
+ /* Builtin functions */
+ double pow_di(doublereal *, integer *);
+
+ /* Local variables */
+ static doublereal t;
+ integer it;
+ static doublereal rnd, eps, base;
+ integer beta;
+ static doublereal emin, prec, emax;
+ integer imin, imax;
+ logical lrnd;
+ static doublereal rmin, rmax;
+ doublereal rmach;
+ extern logical lsame_(char *, char *);
+ doublereal small;
+ static doublereal sfmin;
+ extern /* Subroutine */ int dlamc2_(integer *, integer *, logical *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAMCH determines double precision machine parameters. */
+
+/* Arguments */
+/* ========= */
+
+/* CMACH (input) CHARACTER*1 */
+/* Specifies the value to be returned by DLAMCH: */
+/* = 'E' or 'e', DLAMCH := eps */
+/* = 'S' or 's , DLAMCH := sfmin */
+/* = 'B' or 'b', DLAMCH := base */
+/* = 'P' or 'p', DLAMCH := eps*base */
+/* = 'N' or 'n', DLAMCH := t */
+/* = 'R' or 'r', DLAMCH := rnd */
+/* = 'M' or 'm', DLAMCH := emin */
+/* = 'U' or 'u', DLAMCH := rmin */
+/* = 'L' or 'l', DLAMCH := emax */
+/* = 'O' or 'o', DLAMCH := rmax */
+
+/* where */
+
+/* eps = relative machine precision */
+/* sfmin = safe minimum, such that 1/sfmin does not overflow */
+/* base = base of the machine */
+/* prec = eps*base */
+/* t = number of (base) digits in the mantissa */
+/* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise */
+/* emin = minimum exponent before (gradual) underflow */
+/* rmin = underflow threshold - base**(emin-1) */
+/* emax = largest exponent before overflow */
+/* rmax = overflow threshold - (base**emax)*(1-eps) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (first) {
+ dlamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax);
+ base = (doublereal) beta;
+ t = (doublereal) it;
+ if (lrnd) {
+ rnd = 1.;
+ i__1 = 1 - it;
+ eps = pow_di(&base, &i__1) / 2;
+ } else {
+ rnd = 0.;
+ i__1 = 1 - it;
+ eps = pow_di(&base, &i__1);
+ }
+ prec = eps * base;
+ emin = (doublereal) imin;
+ emax = (doublereal) imax;
+ sfmin = rmin;
+ small = 1. / rmax;
+ if (small >= sfmin) {
+
+/* Use SMALL plus a bit, to avoid the possibility of rounding */
+/* causing overflow when computing 1/sfmin. */
+
+ sfmin = small * (eps + 1.);
+ }
+ }
+
+ if (lsame_(cmach, "E")) {
+ rmach = eps;
+ } else if (lsame_(cmach, "S")) {
+ rmach = sfmin;
+ } else if (lsame_(cmach, "B")) {
+ rmach = base;
+ } else if (lsame_(cmach, "P")) {
+ rmach = prec;
+ } else if (lsame_(cmach, "N")) {
+ rmach = t;
+ } else if (lsame_(cmach, "R")) {
+ rmach = rnd;
+ } else if (lsame_(cmach, "M")) {
+ rmach = emin;
+ } else if (lsame_(cmach, "U")) {
+ rmach = rmin;
+ } else if (lsame_(cmach, "L")) {
+ rmach = emax;
+ } else if (lsame_(cmach, "O")) {
+ rmach = rmax;
+ }
+
+ ret_val = rmach;
+ first = FALSE_;
+ return ret_val;
+
+/* End of DLAMCH */
+
+} /* dlamch_ */
+
+
+/* *********************************************************************** */
+
+/* Subroutine */ int dlamc1_(integer *beta, integer *t, logical *rnd, logical
+ *ieee1)
+{
+ /* Initialized data */
+
+ static logical first = TRUE_;
+
+ /* System generated locals */
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ doublereal a, b, c__, f, t1, t2;
+ static integer lt;
+ doublereal one, qtr;
+ static logical lrnd;
+ static integer lbeta;
+ doublereal savec;
+ extern doublereal dlamc3_(doublereal *, doublereal *);
+ static logical lieee1;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAMC1 determines the machine parameters given by BETA, T, RND, and */
+/* IEEE1. */
+
+/* Arguments */
+/* ========= */
+
+/* BETA (output) INTEGER */
+/* The base of the machine. */
+
+/* T (output) INTEGER */
+/* The number of ( BETA ) digits in the mantissa. */
+
+/* RND (output) LOGICAL */
+/* Specifies whether proper rounding ( RND = .TRUE. ) or */
+/* chopping ( RND = .FALSE. ) occurs in addition. This may not */
+/* be a reliable guide to the way in which the machine performs */
+/* its arithmetic. */
+
+/* IEEE1 (output) LOGICAL */
+/* Specifies whether rounding appears to be done in the IEEE */
+/* 'round to nearest' style. */
+
+/* Further Details */
+/* =============== */
+
+/* The routine is based on the routine ENVRON by Malcolm and */
+/* incorporates suggestions by Gentleman and Marovich. See */
+
+/* Malcolm M. A. (1972) Algorithms to reveal properties of */
+/* floating-point arithmetic. Comms. of the ACM, 15, 949-951. */
+
+/* Gentleman W. M. and Marovich S. B. (1974) More on algorithms */
+/* that reveal properties of floating point arithmetic units. */
+/* Comms. of the ACM, 17, 276-277. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (first) {
+ one = 1.;
+
+/* LBETA, LIEEE1, LT and LRND are the local values of BETA, */
+/* IEEE1, T and RND. */
+
+/* Throughout this routine we use the function DLAMC3 to ensure */
+/* that relevant values are stored and not held in registers, or */
+/* are not affected by optimizers. */
+
+/* Compute a = 2.0**m with the smallest positive integer m such */
+/* that */
+
+/* fl( a + 1.0 ) = a. */
+
+ a = 1.;
+ c__ = 1.;
+
+/* + WHILE( C.EQ.ONE )LOOP */
+L10:
+ if (c__ == one) {
+ a *= 2;
+ c__ = dlamc3_(&a, &one);
+ d__1 = -a;
+ c__ = dlamc3_(&c__, &d__1);
+ goto L10;
+ }
+/* + END WHILE */
+
+/* Now compute b = 2.0**m with the smallest positive integer m */
+/* such that */
+
+/* fl( a + b ) .gt. a. */
+
+ b = 1.;
+ c__ = dlamc3_(&a, &b);
+
+/* + WHILE( C.EQ.A )LOOP */
+L20:
+ if (c__ == a) {
+ b *= 2;
+ c__ = dlamc3_(&a, &b);
+ goto L20;
+ }
+/* + END WHILE */
+
+/* Now compute the base. a and c are neighbouring floating point */
+/* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so */
+/* their difference is beta. Adding 0.25 to c is to ensure that it */
+/* is truncated to beta and not ( beta - 1 ). */
+
+ qtr = one / 4;
+ savec = c__;
+ d__1 = -a;
+ c__ = dlamc3_(&c__, &d__1);
+ lbeta = (integer) (c__ + qtr);
+
+/* Now determine whether rounding or chopping occurs, by adding a */
+/* bit less than beta/2 and a bit more than beta/2 to a. */
+
+ b = (doublereal) lbeta;
+ d__1 = b / 2;
+ d__2 = -b / 100;
+ f = dlamc3_(&d__1, &d__2);
+ c__ = dlamc3_(&f, &a);
+ if (c__ == a) {
+ lrnd = TRUE_;
+ } else {
+ lrnd = FALSE_;
+ }
+ d__1 = b / 2;
+ d__2 = b / 100;
+ f = dlamc3_(&d__1, &d__2);
+ c__ = dlamc3_(&f, &a);
+ if (lrnd && c__ == a) {
+ lrnd = FALSE_;
+ }
+
+/* Try and decide whether rounding is done in the IEEE 'round to */
+/* nearest' style. B/2 is half a unit in the last place of the two */
+/* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit */
+/* zero, and SAVEC is odd. Thus adding B/2 to A should not change */
+/* A, but adding B/2 to SAVEC should change SAVEC. */
+
+ d__1 = b / 2;
+ t1 = dlamc3_(&d__1, &a);
+ d__1 = b / 2;
+ t2 = dlamc3_(&d__1, &savec);
+ lieee1 = t1 == a && t2 > savec && lrnd;
+
+/* Now find the mantissa, t. It should be the integer part of */
+/* log to the base beta of a, however it is safer to determine t */
+/* by powering. So we find t as the smallest positive integer for */
+/* which */
+
+/* fl( beta**t + 1.0 ) = 1.0. */
+
+ lt = 0;
+ a = 1.;
+ c__ = 1.;
+
+/* + WHILE( C.EQ.ONE )LOOP */
+L30:
+ if (c__ == one) {
+ ++lt;
+ a *= lbeta;
+ c__ = dlamc3_(&a, &one);
+ d__1 = -a;
+ c__ = dlamc3_(&c__, &d__1);
+ goto L30;
+ }
+/* + END WHILE */
+
+ }
+
+ *beta = lbeta;
+ *t = lt;
+ *rnd = lrnd;
+ *ieee1 = lieee1;
+ first = FALSE_;
+ return 0;
+
+/* End of DLAMC1 */
+
+} /* dlamc1_ */
+
+
+/* *********************************************************************** */
+
+/* Subroutine */ int dlamc2_(integer *beta, integer *t, logical *rnd,
+ doublereal *eps, integer *emin, doublereal *rmin, integer *emax,
+ doublereal *rmax)
+{
+ /* Initialized data */
+
+ static logical first = TRUE_;
+ static logical iwarn = FALSE_;
+
+ /* Format strings */
+ static char fmt_9999[] = "(//\002 WARNING. The value EMIN may be incorre"
+ "ct:-\002,\002 EMIN = \002,i8,/\002 If, after inspection, the va"
+ "lue EMIN looks\002,\002 acceptable please comment out \002,/\002"
+ " the IF block as marked within the code of routine\002,\002 DLAM"
+ "C2,\002,/\002 otherwise supply EMIN explicitly.\002,/)";
+
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2, d__3, d__4, d__5;
+
+ /* Builtin functions */
+ double pow_di(doublereal *, integer *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublereal a, b, c__;
+ integer i__;
+ static integer lt;
+ doublereal one, two;
+ logical ieee;
+ doublereal half;
+ logical lrnd;
+ static doublereal leps;
+ doublereal zero;
+ static integer lbeta;
+ doublereal rbase;
+ static integer lemin, lemax;
+ integer gnmin;
+ doublereal small;
+ integer gpmin;
+ doublereal third;
+ static doublereal lrmin, lrmax;
+ doublereal sixth;
+ extern /* Subroutine */ int dlamc1_(integer *, integer *, logical *,
+ logical *);
+ extern doublereal dlamc3_(doublereal *, doublereal *);
+ logical lieee1;
+ extern /* Subroutine */ int dlamc4_(integer *, doublereal *, integer *),
+ dlamc5_(integer *, integer *, integer *, logical *, integer *,
+ doublereal *);
+ integer ngnmin, ngpmin;
+
+ /* Fortran I/O blocks */
+ static cilist io___58 = { 0, 6, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAMC2 determines the machine parameters specified in its argument */
+/* list. */
+
+/* Arguments */
+/* ========= */
+
+/* BETA (output) INTEGER */
+/* The base of the machine. */
+
+/* T (output) INTEGER */
+/* The number of ( BETA ) digits in the mantissa. */
+
+/* RND (output) LOGICAL */
+/* Specifies whether proper rounding ( RND = .TRUE. ) or */
+/* chopping ( RND = .FALSE. ) occurs in addition. This may not */
+/* be a reliable guide to the way in which the machine performs */
+/* its arithmetic. */
+
+/* EPS (output) DOUBLE PRECISION */
+/* The smallest positive number such that */
+
+/* fl( 1.0 - EPS ) .LT. 1.0, */
+
+/* where fl denotes the computed value. */
+
+/* EMIN (output) INTEGER */
+/* The minimum exponent before (gradual) underflow occurs. */
+
+/* RMIN (output) DOUBLE PRECISION */
+/* The smallest normalized number for the machine, given by */
+/* BASE**( EMIN - 1 ), where BASE is the floating point value */
+/* of BETA. */
+
+/* EMAX (output) INTEGER */
+/* The maximum exponent before overflow occurs. */
+
+/* RMAX (output) DOUBLE PRECISION */
+/* The largest positive number for the machine, given by */
+/* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point */
+/* value of BETA. */
+
+/* Further Details */
+/* =============== */
+
+/* The computation of EPS is based on a routine PARANOIA by */
+/* W. Kahan of the University of California at Berkeley. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (first) {
+ zero = 0.;
+ one = 1.;
+ two = 2.;
+
+/* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of */
+/* BETA, T, RND, EPS, EMIN and RMIN. */
+
+/* Throughout this routine we use the function DLAMC3 to ensure */
+/* that relevant values are stored and not held in registers, or */
+/* are not affected by optimizers. */
+
+/* DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. */
+
+ dlamc1_(&lbeta, <, &lrnd, &lieee1);
+
+/* Start to find EPS. */
+
+ b = (doublereal) lbeta;
+ i__1 = -lt;
+ a = pow_di(&b, &i__1);
+ leps = a;
+
+/* Try some tricks to see whether or not this is the correct EPS. */
+
+ b = two / 3;
+ half = one / 2;
+ d__1 = -half;
+ sixth = dlamc3_(&b, &d__1);
+ third = dlamc3_(&sixth, &sixth);
+ d__1 = -half;
+ b = dlamc3_(&third, &d__1);
+ b = dlamc3_(&b, &sixth);
+ b = abs(b);
+ if (b < leps) {
+ b = leps;
+ }
+
+ leps = 1.;
+
+/* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */
+L10:
+ if (leps > b && b > zero) {
+ leps = b;
+ d__1 = half * leps;
+/* Computing 5th power */
+ d__3 = two, d__4 = d__3, d__3 *= d__3;
+/* Computing 2nd power */
+ d__5 = leps;
+ d__2 = d__4 * (d__3 * d__3) * (d__5 * d__5);
+ c__ = dlamc3_(&d__1, &d__2);
+ d__1 = -c__;
+ c__ = dlamc3_(&half, &d__1);
+ b = dlamc3_(&half, &c__);
+ d__1 = -b;
+ c__ = dlamc3_(&half, &d__1);
+ b = dlamc3_(&half, &c__);
+ goto L10;
+ }
+/* + END WHILE */
+
+ if (a < leps) {
+ leps = a;
+ }
+
+/* Computation of EPS complete. */
+
+/* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). */
+/* Keep dividing A by BETA until (gradual) underflow occurs. This */
+/* is detected when we cannot recover the previous A. */
+
+ rbase = one / lbeta;
+ small = one;
+ for (i__ = 1; i__ <= 3; ++i__) {
+ d__1 = small * rbase;
+ small = dlamc3_(&d__1, &zero);
+/* L20: */
+ }
+ a = dlamc3_(&one, &small);
+ dlamc4_(&ngpmin, &one, &lbeta);
+ d__1 = -one;
+ dlamc4_(&ngnmin, &d__1, &lbeta);
+ dlamc4_(&gpmin, &a, &lbeta);
+ d__1 = -a;
+ dlamc4_(&gnmin, &d__1, &lbeta);
+ ieee = FALSE_;
+
+ if (ngpmin == ngnmin && gpmin == gnmin) {
+ if (ngpmin == gpmin) {
+ lemin = ngpmin;
+/* ( Non twos-complement machines, no gradual underflow; */
+/* e.g., VAX ) */
+ } else if (gpmin - ngpmin == 3) {
+ lemin = ngpmin - 1 + lt;
+ ieee = TRUE_;
+/* ( Non twos-complement machines, with gradual underflow; */
+/* e.g., IEEE standard followers ) */
+ } else {
+ lemin = min(ngpmin,gpmin);
+/* ( A guess; no known machine ) */
+ iwarn = TRUE_;
+ }
+
+ } else if (ngpmin == gpmin && ngnmin == gnmin) {
+ if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) {
+ lemin = max(ngpmin,ngnmin);
+/* ( Twos-complement machines, no gradual underflow; */
+/* e.g., CYBER 205 ) */
+ } else {
+ lemin = min(ngpmin,ngnmin);
+/* ( A guess; no known machine ) */
+ iwarn = TRUE_;
+ }
+
+ } else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin)
+ {
+ if (gpmin - min(ngpmin,ngnmin) == 3) {
+ lemin = max(ngpmin,ngnmin) - 1 + lt;
+/* ( Twos-complement machines with gradual underflow; */
+/* no known machine ) */
+ } else {
+ lemin = min(ngpmin,ngnmin);
+/* ( A guess; no known machine ) */
+ iwarn = TRUE_;
+ }
+
+ } else {
+/* Computing MIN */
+ i__1 = min(ngpmin,ngnmin), i__1 = min(i__1,gpmin);
+ lemin = min(i__1,gnmin);
+/* ( A guess; no known machine ) */
+ iwarn = TRUE_;
+ }
+ first = FALSE_;
+/* ** */
+/* Comment out this if block if EMIN is ok */
+ if (iwarn) {
+ first = TRUE_;
+ s_wsfe(&io___58);
+ do_fio(&c__1, (char *)&lemin, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* ** */
+
+/* Assume IEEE arithmetic if we found denormalised numbers above, */
+/* or if arithmetic seems to round in the IEEE style, determined */
+/* in routine DLAMC1. A true IEEE machine should have both things */
+/* true; however, faulty machines may have one or the other. */
+
+ ieee = ieee || lieee1;
+
+/* Compute RMIN by successive division by BETA. We could compute */
+/* RMIN as BASE**( EMIN - 1 ), but some machines underflow during */
+/* this computation. */
+
+ lrmin = 1.;
+ i__1 = 1 - lemin;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__1 = lrmin * rbase;
+ lrmin = dlamc3_(&d__1, &zero);
+/* L30: */
+ }
+
+/* Finally, call DLAMC5 to compute EMAX and RMAX. */
+
+ dlamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax);
+ }
+
+ *beta = lbeta;
+ *t = lt;
+ *rnd = lrnd;
+ *eps = leps;
+ *emin = lemin;
+ *rmin = lrmin;
+ *emax = lemax;
+ *rmax = lrmax;
+
+ return 0;
+
+
+/* End of DLAMC2 */
+
+} /* dlamc2_ */
+
+
+/* *********************************************************************** */
+
+doublereal dlamc3_(doublereal *a, doublereal *b)
+{
+ /* System generated locals */
+ doublereal ret_val;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAMC3 is intended to force A and B to be stored prior to doing */
+/* the addition of A and B , for use in situations where optimizers */
+/* might hold one of these in a register. */
+
+/* Arguments */
+/* ========= */
+
+/* A (input) DOUBLE PRECISION */
+/* B (input) DOUBLE PRECISION */
+/* The values A and B. */
+
+/* ===================================================================== */
+
+/* .. Executable Statements .. */
+
+ ret_val = *a + *b;
+
+ return ret_val;
+
+/* End of DLAMC3 */
+
+} /* dlamc3_ */
+
+
+/* *********************************************************************** */
+
+/* Subroutine */ int dlamc4_(integer *emin, doublereal *start, integer *base)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Local variables */
+ doublereal a;
+ integer i__;
+ doublereal b1, b2, c1, c2, d1, d2, one, zero, rbase;
+ extern doublereal dlamc3_(doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAMC4 is a service routine for DLAMC2. */
+
+/* Arguments */
+/* ========= */
+
+/* EMIN (output) INTEGER */
+/* The minimum exponent before (gradual) underflow, computed by */
+/* setting A = START and dividing by BASE until the previous A */
+/* can not be recovered. */
+
+/* START (input) DOUBLE PRECISION */
+/* The starting point for determining EMIN. */
+
+/* BASE (input) INTEGER */
+/* The base of the machine. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ a = *start;
+ one = 1.;
+ rbase = one / *base;
+ zero = 0.;
+ *emin = 1;
+ d__1 = a * rbase;
+ b1 = dlamc3_(&d__1, &zero);
+ c1 = a;
+ c2 = a;
+ d1 = a;
+ d2 = a;
+/* + WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. */
+/* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP */
+L10:
+ if (c1 == a && c2 == a && d1 == a && d2 == a) {
+ --(*emin);
+ a = b1;
+ d__1 = a / *base;
+ b1 = dlamc3_(&d__1, &zero);
+ d__1 = b1 * *base;
+ c1 = dlamc3_(&d__1, &zero);
+ d1 = zero;
+ i__1 = *base;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d1 += b1;
+/* L20: */
+ }
+ d__1 = a * rbase;
+ b2 = dlamc3_(&d__1, &zero);
+ d__1 = b2 / rbase;
+ c2 = dlamc3_(&d__1, &zero);
+ d2 = zero;
+ i__1 = *base;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d2 += b2;
+/* L30: */
+ }
+ goto L10;
+ }
+/* + END WHILE */
+
+ return 0;
+
+/* End of DLAMC4 */
+
+} /* dlamc4_ */
+
+
+/* *********************************************************************** */
+
+/* Subroutine */ int dlamc5_(integer *beta, integer *p, integer *emin,
+ logical *ieee, integer *emax, doublereal *rmax)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__;
+ doublereal y, z__;
+ integer try__, lexp;
+ doublereal oldy;
+ integer uexp, nbits;
+ extern doublereal dlamc3_(doublereal *, doublereal *);
+ doublereal recbas;
+ integer exbits, expsum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAMC5 attempts to compute RMAX, the largest machine floating-point */
+/* number, without overflow. It assumes that EMAX + abs(EMIN) sum */
+/* approximately to a power of 2. It will fail on machines where this */
+/* assumption does not hold, for example, the Cyber 205 (EMIN = -28625, */
+/* EMAX = 28718). It will also fail if the value supplied for EMIN is */
+/* too large (i.e. too close to zero), probably with overflow. */
+
+/* Arguments */
+/* ========= */
+
+/* BETA (input) INTEGER */
+/* The base of floating-point arithmetic. */
+
+/* P (input) INTEGER */
+/* The number of base BETA digits in the mantissa of a */
+/* floating-point value. */
+
+/* EMIN (input) INTEGER */
+/* The minimum exponent before (gradual) underflow. */
+
+/* IEEE (input) LOGICAL */
+/* A logical flag specifying whether or not the arithmetic */
+/* system is thought to comply with the IEEE standard. */
+
+/* EMAX (output) INTEGER */
+/* The largest exponent before overflow */
+
+/* RMAX (output) DOUBLE PRECISION */
+/* The largest machine floating-point number. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* First compute LEXP and UEXP, two powers of 2 that bound */
+/* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum */
+/* approximately to the bound that is closest to abs(EMIN). */
+/* (EMAX is the exponent of the required number RMAX). */
+
+ lexp = 1;
+ exbits = 1;
+L10:
+ try__ = lexp << 1;
+ if (try__ <= -(*emin)) {
+ lexp = try__;
+ ++exbits;
+ goto L10;
+ }
+ if (lexp == -(*emin)) {
+ uexp = lexp;
+ } else {
+ uexp = try__;
+ ++exbits;
+ }
+
+/* Now -LEXP is less than or equal to EMIN, and -UEXP is greater */
+/* than or equal to EMIN. EXBITS is the number of bits needed to */
+/* store the exponent. */
+
+ if (uexp + *emin > -lexp - *emin) {
+ expsum = lexp << 1;
+ } else {
+ expsum = uexp << 1;
+ }
+
+/* EXPSUM is the exponent range, approximately equal to */
+/* EMAX - EMIN + 1 . */
+
+ *emax = expsum + *emin - 1;
+ nbits = exbits + 1 + *p;
+
+/* NBITS is the total number of bits needed to store a */
+/* floating-point number. */
+
+ if (nbits % 2 == 1 && *beta == 2) {
+
+/* Either there are an odd number of bits used to store a */
+/* floating-point number, which is unlikely, or some bits are */
+/* not used in the representation of numbers, which is possible, */
+/* (e.g. Cray machines) or the mantissa has an implicit bit, */
+/* (e.g. IEEE machines, Dec Vax machines), which is perhaps the */
+/* most likely. We have to assume the last alternative. */
+/* If this is true, then we need to reduce EMAX by one because */
+/* there must be some way of representing zero in an implicit-bit */
+/* system. On machines like Cray, we are reducing EMAX by one */
+/* unnecessarily. */
+
+ --(*emax);
+ }
+
+ if (*ieee) {
+
+/* Assume we are on an IEEE machine which reserves one exponent */
+/* for infinity and NaN. */
+
+ --(*emax);
+ }
+
+/* Now create RMAX, the largest machine number, which should */
+/* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . */
+
+/* First compute 1.0 - BETA**(-P), being careful that the */
+/* result is less than 1.0 . */
+
+ recbas = 1. / *beta;
+ z__ = *beta - 1.;
+ y = 0.;
+ i__1 = *p;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ z__ *= recbas;
+ if (y < 1.) {
+ oldy = y;
+ }
+ y = dlamc3_(&y, &z__);
+/* L20: */
+ }
+ if (y >= 1.) {
+ y = oldy;
+ }
+
+/* Now multiply by BETA**EMAX to get RMAX. */
+
+ i__1 = *emax;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__1 = y * *beta;
+ y = dlamc3_(&d__1, &c_b32);
+/* L30: */
+ }
+
+ *rmax = y;
+ return 0;
+
+/* End of DLAMC5 */
+
+} /* dlamc5_ */
diff --git a/INSTALL/dlamchtst.c b/INSTALL/dlamchtst.c
new file mode 100644
index 0000000..ec2ebb2
--- /dev/null
+++ b/INSTALL/dlamchtst.c
@@ -0,0 +1,120 @@
+/* dlamchtst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__9 = 9;
+static integer c__1 = 1;
+static integer c__5 = 5;
+
+/* Main program */ int MAIN__(void)
+{
+ /* System generated locals */
+ doublereal d__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_wsle(void);
+
+ /* Local variables */
+ doublereal t, rnd, eps, base, emin, prec, emax, rmin, rmax, sfmin;
+ extern doublereal dlamch_(char *);
+
+ /* Fortran I/O blocks */
+ static cilist io___11 = { 0, 6, 0, 0, 0 };
+ static cilist io___12 = { 0, 6, 0, 0, 0 };
+ static cilist io___13 = { 0, 6, 0, 0, 0 };
+ static cilist io___14 = { 0, 6, 0, 0, 0 };
+ static cilist io___15 = { 0, 6, 0, 0, 0 };
+ static cilist io___16 = { 0, 6, 0, 0, 0 };
+ static cilist io___17 = { 0, 6, 0, 0, 0 };
+ static cilist io___18 = { 0, 6, 0, 0, 0 };
+ static cilist io___19 = { 0, 6, 0, 0, 0 };
+ static cilist io___20 = { 0, 6, 0, 0, 0 };
+ static cilist io___21 = { 0, 6, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = dlamch_("Epsilon");
+ sfmin = dlamch_("Safe minimum");
+ base = dlamch_("Base");
+ prec = dlamch_("Precision");
+ t = dlamch_("Number of digits in mantissa");
+ rnd = dlamch_("Rounding mode");
+ emin = dlamch_("Minimum exponent");
+ rmin = dlamch_("Underflow threshold");
+ emax = dlamch_("Largest exponent");
+ rmax = dlamch_("Overflow threshold");
+
+ s_wsle(&io___11);
+ do_lio(&c__9, &c__1, " Epsilon = ", (ftnlen)32);
+ do_lio(&c__5, &c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsle();
+ s_wsle(&io___12);
+ do_lio(&c__9, &c__1, " Safe minimum = ", (ftnlen)32);
+ do_lio(&c__5, &c__1, (char *)&sfmin, (ftnlen)sizeof(doublereal));
+ e_wsle();
+ s_wsle(&io___13);
+ do_lio(&c__9, &c__1, " Base = ", (ftnlen)32);
+ do_lio(&c__5, &c__1, (char *)&base, (ftnlen)sizeof(doublereal));
+ e_wsle();
+ s_wsle(&io___14);
+ do_lio(&c__9, &c__1, " Precision = ", (ftnlen)32);
+ do_lio(&c__5, &c__1, (char *)&prec, (ftnlen)sizeof(doublereal));
+ e_wsle();
+ s_wsle(&io___15);
+ do_lio(&c__9, &c__1, " Number of digits in mantissa = ", (ftnlen)32);
+ do_lio(&c__5, &c__1, (char *)&t, (ftnlen)sizeof(doublereal));
+ e_wsle();
+ s_wsle(&io___16);
+ do_lio(&c__9, &c__1, " Rounding mode = ", (ftnlen)32);
+ do_lio(&c__5, &c__1, (char *)&rnd, (ftnlen)sizeof(doublereal));
+ e_wsle();
+ s_wsle(&io___17);
+ do_lio(&c__9, &c__1, " Minimum exponent = ", (ftnlen)32);
+ do_lio(&c__5, &c__1, (char *)&emin, (ftnlen)sizeof(doublereal));
+ e_wsle();
+ s_wsle(&io___18);
+ do_lio(&c__9, &c__1, " Underflow threshold = ", (ftnlen)32);
+ do_lio(&c__5, &c__1, (char *)&rmin, (ftnlen)sizeof(doublereal));
+ e_wsle();
+ s_wsle(&io___19);
+ do_lio(&c__9, &c__1, " Largest exponent = ", (ftnlen)32);
+ do_lio(&c__5, &c__1, (char *)&emax, (ftnlen)sizeof(doublereal));
+ e_wsle();
+ s_wsle(&io___20);
+ do_lio(&c__9, &c__1, " Overflow threshold = ", (ftnlen)32);
+ do_lio(&c__5, &c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
+ e_wsle();
+ s_wsle(&io___21);
+ do_lio(&c__9, &c__1, " Reciprocal of safe minimum = ", (ftnlen)32);
+ d__1 = 1 / sfmin;
+ do_lio(&c__5, &c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
+ e_wsle();
+
+ return 0;
+} /* MAIN__ */
+
+/* Main program alias */ int test3_ () { MAIN__ (); return 0; }
diff --git a/INSTALL/dsecnd.c b/INSTALL/dsecnd.c
new file mode 100644
index 0000000..d74f805
--- /dev/null
+++ b/INSTALL/dsecnd.c
@@ -0,0 +1,18 @@
+#include "blaswrap.h"
+#include "f2c.h"
+#include <sys/times.h>
+#include <sys/types.h>
+#include <time.h>
+
+#ifndef CLK_TCK
+#define CLK_TCK 60
+#endif
+
+doublereal dsecnd_()
+{
+ struct tms rusage;
+
+ times(&rusage);
+ return (doublereal)(rusage.tms_utime) / CLK_TCK;
+
+} /* dsecnd_ */
diff --git a/INSTALL/dsecndtst.c b/INSTALL/dsecndtst.c
new file mode 100644
index 0000000..22fb9ec
--- /dev/null
+++ b/INSTALL/dsecndtst.c
@@ -0,0 +1,162 @@
+/* dsecndtst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__100 = 100;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 Time for 1,000,000 DAXPY ops = \002,g10"
+ ".3,\002 seconds\002)";
+ static char fmt_9998[] = "(\002 DAXPY performance rate = \002,g10"
+ ".3,\002 mflops \002)";
+ static char fmt_9994[] = "(\002 *** Error: Time for operations was zer"
+ "o\002)";
+ static char fmt_9997[] = "(\002 Including DSECND, time = \002,g10"
+ ".3,\002 seconds\002)";
+ static char fmt_9996[] = "(\002 Average time for DSECND = \002,g10"
+ ".3,\002 milliseconds\002)";
+ static char fmt_9995[] = "(\002 Equivalent floating point ops = \002,g10"
+ ".3,\002 ops\002)";
+
+ /* System generated locals */
+ doublereal d__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal x[100], y[100], t1, t2, avg, alpha;
+ extern /* Subroutine */ int mysub_(integer *, doublereal *, doublereal *);
+ extern doublereal dsecnd_(void);
+ doublereal tnosec;
+
+ /* Fortran I/O blocks */
+ static cilist io___8 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___9 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___10 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___12 = { 0, 6, 0, fmt_9997, 0 };
+ static cilist io___14 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___15 = { 0, 6, 0, fmt_9995, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+
+/* Initialize X and Y */
+
+ for (i__ = 1; i__ <= 100; ++i__) {
+ x[i__ - 1] = 1. / (doublereal) i__;
+ y[i__ - 1] = (doublereal) (100 - i__) / 100.;
+/* L10: */
+ }
+ alpha = .315;
+
+/* Time 1,000,000 DAXPY operations */
+
+ t1 = dsecnd_();
+ for (j = 1; j <= 5000; ++j) {
+ for (i__ = 1; i__ <= 100; ++i__) {
+ y[i__ - 1] += alpha * x[i__ - 1];
+/* L20: */
+ }
+ alpha = -alpha;
+/* L30: */
+ }
+ t2 = dsecnd_();
+ s_wsfe(&io___8);
+ d__1 = t2 - t1;
+ do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ if (t2 - t1 > 0.) {
+ s_wsfe(&io___9);
+ d__1 = 1. / (t2 - t1);
+ do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ } else {
+ s_wsfe(&io___10);
+ e_wsfe();
+ }
+ tnosec = t2 - t1;
+
+/* Time 1,000,000 DAXPY operations with DSECND in the outer loop */
+
+ t1 = dsecnd_();
+ for (j = 1; j <= 5000; ++j) {
+ for (i__ = 1; i__ <= 100; ++i__) {
+ y[i__ - 1] += alpha * x[i__ - 1];
+/* L40: */
+ }
+ alpha = -alpha;
+ t2 = dsecnd_();
+/* L50: */
+ }
+
+/* Compute the time in milliseconds used by an average call */
+/* to DSECND. */
+
+ s_wsfe(&io___12);
+ d__1 = t2 - t1;
+ do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ avg = (t2 - t1 - tnosec) * 1e3 / 5e3;
+ s_wsfe(&io___14);
+ do_fio(&c__1, (char *)&avg, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+/* Compute the equivalent number of floating point operations used */
+/* by an average call to DSECND. */
+
+ if (tnosec > 0.) {
+ s_wsfe(&io___15);
+ d__1 = avg * 1e3 / tnosec;
+ do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+
+ mysub_(&c__100, x, y);
+ return 0;
+} /* MAIN__ */
+
+/* Subroutine */ int mysub_(integer *n, doublereal *x, doublereal *y)
+{
+ /* Parameter adjustments */
+ --y;
+ --x;
+
+ /* Function Body */
+ return 0;
+} /* mysub_ */
+
+/* Main program alias */ int test5_ () { MAIN__ (); return 0; }
diff --git a/INSTALL/ilaver.c b/INSTALL/ilaver.c
new file mode 100644
index 0000000..7ab30d6
--- /dev/null
+++ b/INSTALL/ilaver.c
@@ -0,0 +1,50 @@
+/* ilaver.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ilaver_(integer *vers_major__, integer *vers_minor__,
+ integer *vers_patch__)
+{
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This subroutine return the Lapack version. */
+
+/* Arguments */
+/* ========= */
+
+/* VERS_MAJOR (output) INTEGER */
+/* return the lapack major version */
+/* VERS_MINOR (output) INTEGER */
+/* return the lapack minor version from the major version */
+/* VERS_PATCH (output) INTEGER */
+/* return the lapack patch version from the minor version */
+
+/* .. Executable Statements .. */
+
+ *vers_major__ = 3;
+ *vers_minor__ = 2;
+ *vers_patch__ = 0;
+/* ===================================================================== */
+
+ return 0;
+} /* ilaver_ */
diff --git a/INSTALL/lawn81.pdf b/INSTALL/lawn81.pdf
new file mode 100644
index 0000000..38bb77e
Binary files /dev/null and b/INSTALL/lawn81.pdf differ
diff --git a/INSTALL/lawn81.tex b/INSTALL/lawn81.tex
new file mode 100644
index 0000000..16efef7
--- /dev/null
+++ b/INSTALL/lawn81.tex
@@ -0,0 +1,1688 @@
+\documentclass[11pt]{report}
+
+\usepackage{indentfirst}
+\usepackage[body={6in,8.5in}]{geometry}
+\usepackage{hyperref}
+\usepackage{graphicx}
+\DeclareGraphicsRule{.ps}{eps}{}{}
+
+\renewcommand{\thesection}{\arabic{section}}
+\setcounter{tocdepth}{3}
+\setcounter{secnumdepth}{3}
+
+\begin{document}
+\begin{center}
+ {\Large LAPACK Working Note 81\\
+ Quick Installation Guide for LAPACK on Unix Systems\footnote{This work was
+ supported by NSF Grant No. ASC-8715728 and NSF Grant No. 0444486}}
+\end{center}
+\begin{center}
+% Edward Anderson\footnote{Current address: Cray Research Inc.,
+% 655F Lone Oak Drive, Eagan, MN 55121},
+ The LAPACK Authors\\
+ Department of Computer Science \\
+ University of Tennessee \\
+ Knoxville, Tennessee 37996-1301 \\
+\end{center}
+\begin{center}
+ REVISED: VERSION 3.1.1, February 2007 \\
+ REVISED: VERSION 3.2.0, November 2008
+\end{center}
+
+\begin{center}
+Abstract
+\end{center}
+This working note describes how to install, and test version 3.2.0
+of LAPACK, a linear algebra package for high-performance
+computers, on a Unix System. The timing routines are not actually included in
+release 3.2.0, and that part of the LAWN refers to release 3.0. Also,
+version 3.2.0 contains many prototype routines needing user feedback.
+Non-Unix installation instructions and
+further details of the testing and timing suites are only contained in
+LAPACK Working Note 41, and not in this abbreviated version.
+%Separate instructions are provided for the Unix and non-Unix
+%versions of the test package.
+%Further details are also given on the design of the test and timing
+%programs.
+\newpage
+
+\tableofcontents
+
+\newpage
+% Introduction to Implementation Guide
+
+\section{Introduction}
+
+LAPACK is a linear algebra library for high-performance
+computers.
+The library includes Fortran subroutines for
+the analysis and solution of systems of simultaneous linear algebraic
+equations, linear least-squares problems, and matrix eigenvalue
+problems.
+Our approach to achieving high efficiency is based on the use of
+a standard set of Basic Linear Algebra Subprograms (the BLAS),
+which can be optimized for each computing environment.
+By confining most of the computational work to the BLAS,
+the subroutines should be
+transportable and efficient across a wide range of computers.
+
+This working note describes how to install, test, and time this
+release of LAPACK on a Unix System.
+
+The instructions for installing, testing, and timing
+\footnote{timing are only provided in LAPACK 3.0 and before}
+are designed for a person whose
+responsibility is the maintenance of a mathematical software library.
+We assume the installer has experience in compiling and running
+Fortran programs and in creating object libraries.
+The installation process involves untarring the file, creating a set of
+libraries, and compiling and running the test and timing programs
+\footnotemark[\value{footnote}].
+
+%This guide combines the instructions for the Unix and non-Unix
+%versions of the LAPACK test package (the non-Unix version is in Appendix
+%~\ref{appendixe}).
+%At this time, the non-Unix version of LAPACK can only be obtained
+%after first untarring the Unix tar tape and then following the instructions in
+%Appendix ~\ref{appendixe}.
+
+Section~\ref{fileformat} describes how the files are organized in the
+file, and
+Section~\ref{overview} gives a general overview of the parts of the test package.
+Step-by-step instructions appear in Section~\ref{installation}.
+%for the Unix version and in the appendix for the non-Unix version.
+
+For users desiring additional information, please refer to LAPACK
+Working Note 41.
+% Sections~\ref{moretesting}
+%and ~\ref{moretiming} give
+%details of the test and timing programs and their input files.
+%Appendices ~\ref{appendixa} and ~\ref{appendixb} briefly describe
+%the LAPACK routines and auxiliary routines provided
+%in this release.
+%Appendix ~\ref{appendixc} lists the operation counts we have computed
+%for the BLAS and for some of the LAPACK routines.
+Appendix ~\ref{appendixd}, entitled ``Caveats'', is a compendium of the known
+problems from our own experiences, with suggestions on how to
+overcome them.
+
+\textbf{It is strongly advised that the user read Appendix
+A before proceeding with the installation process.}
+%Appendix E contains the execution times of the different test
+%and timing runs on two sample machines.
+%Appendix ~\ref{appendixe} contains the instructions to install LAPACK on a non-Unix
+%system.
+
+\section{Revisions Since the First Public Release}
+
+Since its first public release in February, 1992, LAPACK has had
+several updates, which have encompassed the introduction of new routines
+as well as extending the functionality of existing routines. The first
+update,
+June 30, 1992, was version 1.0a; the second update, October 31, 1992,
+was version 1.0b; the third update, March 31, 1993, was version 1.1;
+version 2.0 on September 30, 1994, coincided with the release of the
+Second Edition of the LAPACK Users' Guide;
+version 3.0 on June 30, 1999 coincided with the release of the Third Edition of
+the LAPACK Users' Guide;
+version 3.1 was released on November, 2006;
+version 3.1.1 was released on November, 2007;
+and version 3.2.0 was released on November, 2008.
+
+All LAPACK routines reflect the current version number with the date
+on the routine indicating when it was last modified.
+For more information on revisions in the latest release, please refer
+to the \texttt{revisions.info} file in the lapack directory on netlib.
+\begin{quote}
+\url{http://www.netlib.org/lapack/revisions.info}
+\end{quote}
+
+%The distribution \texttt{tar} file \texttt{lapack.tar.z} that is
+%available on netlib is always the most up-to-date.
+%
+%On-line manpages (troff files) for LAPACK driver and computational
+%routines, as well as most of the BLAS routines, are available via
+%the \texttt{lapack} index on netlib.
+
+\section{File Format}\label{fileformat}
+
+The software for LAPACK is distributed in the form of a
+gzipped tar file (via anonymous ftp or the World Wide Web),
+which contains the Fortran source for LAPACK,
+the Basic Linear Algebra Subprograms
+(the Level 1, 2, and 3 BLAS) needed by LAPACK, the testing programs,
+and the timing programs\footnotemark[\value{footnote}].
+Users who wish to have a non-Unix installation should refer to LAPACK
+Working Note 41,
+although the overview in section~\ref{overview} applies to both the Unix and non-Unix
+versions.
+%Users who wish to have a non-Unix installation should go to Appendix ~\ref{appendixe},
+%although the overview in section ~\ref{overview} applies to both the Unix and non-Unix
+%versions.
+
+The package may be accessed via the World Wide Web through
+the URL address:
+\begin{quote}
+\url{http://www.netlib.org/lapack/lapack.tgz}
+\end{quote}
+
+Or, you can retrieve the file via anonymous ftp at netlib:
+
+\begin{verbatim}
+ ftp ftp.netlib.org
+ login: anonymous
+ password: <your email address>
+ cd lapack
+ binary
+ get lapack.tgz
+ quit
+\end{verbatim}
+
+The software in the \texttt{tar} file
+is organized in a number of essential directories as shown
+in Figure 1. Please note that this figure does not reflect everything
+that is contained in the \texttt{LAPACK} directory. Input and instructional
+files are also located at various levels.
+\begin{figure}
+\vspace{11pt}
+\centerline{\includegraphics[width=6.5in,height=3in]{org2.ps}}
+\caption{Unix organization of LAPACK 3.0}
+\vspace{11pt}
+\end{figure}
+Libraries are created in the LAPACK directory and
+executable files are created in one of the directories BLAS, TESTING,
+or TIMING\footnotemark[\value{footnote}]. Input files for the test and
+timing\footnotemark[\value{footnote}] programs are also
+found in these three directories so that testing may be carried out
+in the directories LAPACK/BLAS, LAPACK/TESTING, and LAPACK/TIMING \footnotemark[\value{footnote}].
+A top-level makefile in the LAPACK directory is provided to perform the
+entire installation procedure.
+
+\section{Overview of Tape Contents}\label{overview}
+
+Most routines in LAPACK occur in four versions: REAL,
+DOUBLE PRECISION, COMPLEX, and COMPLEX*16.
+The first three versions (REAL, DOUBLE PRECISION, and COMPLEX)
+are written in standard Fortran and are completely portable;
+the COMPLEX*16 version is provided for
+those compilers which allow this data type.
+Some routines use features of Fortran 90.
+For convenience, we often refer to routines by their single precision
+names; the leading `S' can be replaced by a `D' for double precision,
+a `C' for complex, or a `Z' for complex*16.
+For LAPACK use and testing you must decide which version(s)
+of the package you intend to install at your site (for example,
+REAL and COMPLEX on a Cray computer or DOUBLE PRECISION and
+COMPLEX*16 on an IBM computer).
+
+\subsection{LAPACK Routines}
+
+There are three classes of LAPACK routines:
+\begin{itemize}
+
+\item \textbf{driver} routines solve a complete problem, such as solving
+a system of linear equations or computing the eigenvalues of a real
+symmetric matrix. Users are encouraged to use a driver routine if there
+is one that meets their requirements. The driver routines are listed
+in LAPACK Working Note 41~\cite{WN41} and the LAPACK Users' Guide~\cite{LUG}.
+%in Appendix ~\ref{appendixa}.
+
+\item \textbf{computational} routines, also called simply LAPACK routines,
+perform a distinct computational task, such as computing
+the $LU$ decomposition of an $m$-by-$n$ matrix or finding the
+eigenvalues and eigenvectors of a symmetric tridiagonal matrix using
+the $QR$ algorithm.
+The LAPACK routines are listed in LAPACK Working Note 41~\cite{WN41}
+and the LAPACK Users' Guide~\cite{LUG}.
+%The LAPACK routines are listed in Appendix ~\ref{appendixa}; see also LAPACK
+%Working Note \#5 \cite{WN5}.
+
+\item \textbf{auxiliary} routines are all the other subroutines called
+by the driver routines and computational routines.
+%Among them are subroutines to perform subtasks of block algorithms,
+%in particular, the unblocked versions of the block algorithms;
+%extensions to the BLAS, such as matrix-vector operations involving
+%complex symmetric matrices;
+%the special routines LSAME and XERBLA which first appeared with the
+%BLAS;
+%and a number of routines to perform common low-level computations,
+%such as computing a matrix norm, generating an elementary Householder
+%transformation, and applying a sequence of plane rotations.
+%Many of the auxiliary routines may be of use to numerical analysts
+%or software developers, so we have documented the Fortran source for
+%these routines with the same level of detail used for the LAPACK
+%routines and driver routines.
+The auxiliary routines are listed in LAPACK Working Note 41~\cite{WN41}
+and the LAPACK Users' Guide~\cite{LUG}.
+%The auxiliary routines are listed in Appendix ~\ref{appendixb}.
+\end{itemize}
+
+\subsection{Level 1, 2, and 3 BLAS}
+
+The BLAS are a set of Basic Linear Algebra Subprograms that perform
+vector-vector, matrix-vector, and matrix-matrix operations.
+LAPACK is designed around the Level 1, 2, and 3 BLAS, and nearly all
+of the parallelism in the LAPACK routines is contained in the BLAS.
+Therefore,
+the key to getting good performance from LAPACK lies in having an
+efficient version of the BLAS optimized for your particular machine.
+Optimized BLAS libraries are available on a variety of architectures,
+refer to the BLAS FAQ on netlib for further information.
+\begin{quote}
+\url{http://www.netlib.org/blas/faq.html}
+\end{quote}
+There are also freely available BLAS generators that automatically
+tune a subset of the BLAS for a given architecture. E.g.,
+\begin{quote}
+\url{http://www.netlib.org/atlas/}
+\end{quote}
+And, if all else fails, there is the Fortran~77 reference implementation
+of the Level 1, 2, and 3 BLAS available on netlib (also included in
+the LAPACK distribution tar file).
+\begin{quote}
+\url{http://www.netlib.org/blas/blas.tgz}
+\end{quote}
+No matter which BLAS library is used, the BLAS test programs should
+always be run.
+
+Users should not expect too much from the Fortran~77 reference implementation
+BLAS; these versions were written to define the basic operations and do not
+employ the standard tricks for optimizing Fortran code.
+
+The formal definitions of the Level 1, 2, and 3 BLAS
+are in \cite{BLAS1}, \cite{BLAS2}, and \cite{BLAS3}.
+The BLAS Quick Reference card is available on netlib.
+
+\subsection{Mixed- and Extended-Precision BLAS: XBLAS}
+
+The XBLAS extend the BLAS to work with mixed input and output
+precisions as well as using extra precision internally. The XBLAS are
+used in the prototype extra-precise iterative refinement codes.
+
+The current release of the XBLAS is available through
+Netlib\footnote{Development versions may be available through
+ \url{http://www.cs.berkeley.edu/~yozo/} or
+ \url{http://www.nersc.gov/~xiaoye/XBLAS/}.} at
+\begin{quote}
+ \url{http://www.netlib.org/xblas}
+\end{quote}
+Their formal definition is in \cite{XBLAS}.
+
+\subsection{LAPACK Test Routines}
+
+This release contains two distinct test programs for LAPACK routines
+in each data type. One test program tests the routines for solving
+linear equations and linear least squares problems,
+and the other tests routines for the matrix eigenvalue problem.
+The routines for generating test matrices are used by both test
+programs and are compiled into a library for use by both test programs.
+
+\subsection{LAPACK Timing Routines (for LAPACK 3.0 and before) }
+
+This release also contains two distinct timing programs for the
+LAPACK routines in each data type.
+The linear equation timing program gathers performance data in
+megaflops on the factor, solve, and inverse routines for solving
+linear systems, the routines to generate or apply an orthogonal matrix
+given as a sequence of elementary transformations, and the reductions
+to bidiagonal, tridiagonal, or Hessenberg form for eigenvalue
+computations.
+The operation counts used in computing the megaflop rates are computed
+from a formula;
+see LAPACK Working Note 41~\cite{WN41}.
+% see Appendix ~\ref{appendixc}.
+The eigenvalue timing program is used with the eigensystem routines
+and returns the execution time, number of floating point operations, and
+megaflop rate for each of the requested subroutines.
+In this program, the number of operations is computed while the
+code is executing using special instrumented versions of the LAPACK
+subroutines.
+
+\section{Installing LAPACK on a Unix System}\label{installation}
+
+Installing, testing, and timing\footnotemark[\value{footnote}] the Unix version of LAPACK
+involves the following steps:
+\begin{enumerate}
+\item Gunzip and tar the file.
+
+\item Copy and edit the file \texttt{LAPACK/make.inc.example to LAPACK/make.inc}.
+
+\item Edit the file \texttt{LAPACK/Makefile} and type \texttt{make}.
+
+%\item Test and Install the Machine-Dependent Routines \\
+%\emph{(WARNING: You may need to supply a correct version of second.f and
+%dsecnd.f for your machine)}
+%{\tt
+%\begin{list}{}{}
+%\item cd LAPACK
+%\item make install
+%\end{list} }
+%
+%\item Create the BLAS Library, \emph{if necessary} \\
+%\emph{(NOTE: For best performance, it is recommended you use the manufacturers' BLAS)}
+%{\tt
+%\begin{list}{}{}
+%\item \texttt{cd LAPACK}
+%\item \texttt{make blaslib}
+%\end{list} }
+%
+%\item Run the Level 1, 2, and 3 BLAS Test Programs
+%\begin{list}{}{}
+%\item \texttt{cd LAPACK}
+%\item \texttt{make blas\_testing}
+%\end{list}
+%
+%\item Create the LAPACK Library
+%\begin{list}{}{}
+%\item \texttt{cd LAPACK}
+%\item \texttt{make lapacklib}
+%\end{list}
+%
+%\item Create the Library of Test Matrix Generators
+%\begin{list}{}{}
+%\item \texttt{cd LAPACK}
+%\item \texttt{make tmglib}
+%\end{list}
+%
+%\item Run the LAPACK Test Programs
+%\begin{list}{}{}
+%\item \texttt{cd LAPACK}
+%\item \texttt{make testing}
+%\end{list}
+%
+%\item Run the LAPACK Timing Programs
+%\begin{list}{}{}
+%\item \texttt{cd LAPACK}
+%\item \texttt{make timing}
+%\end{list}
+%
+%\item Run the BLAS Timing Programs
+%\begin{list}{}{}
+%\item \texttt{cd LAPACK}
+%\item \texttt{make blas\_timing}
+%\end{list}
+\end{enumerate}
+
+\subsection{Untar the File}
+
+If you received a tar file of LAPACK via the World Wide
+Web or anonymous ftp, enter the following command:
+
+\begin{list}{}
+\item{\texttt{gunzip -c lapack.tgz | tar xvf -}}
+\end{list}
+
+\noindent
+This will create a top-level directory called \texttt{LAPACK}, which
+requires approximately 34 Mbytes of disk space.
+The total space requirements including the object files and executables
+is approximately 100 Mbytes for all four data types.
+
+\subsection{Copy and edit the file \texttt{LAPACK/make.inc.example to LAPACK/make.inc}}
+
+Before the libraries can be built, or the testing and timing\footnotemark[\value{footnote}] programs
+run, you must define all machine-specific parameters for the
+architecture to which you are installing LAPACK. All machine-specific
+parameters are contained in the file \texttt{LAPACK/make.inc}.
+An example of \texttt{LAPACK/make.inc} for a LINUX machine with GNU compilers is given
+in \texttt{LAPACK/make.inc.example}, copy that file to LAPACK/make.inc by entering the following command:
+
+\begin{list}{}
+\item{\texttt{cp LAPACK/make.inc.example LAPACK/make.inc}}
+\end{list}
+
+\noindent
+Now modify your \texttt{LAPACK/make.inc} by applying the following recommendations.
+The first line of this \texttt{make.inc} file is:
+\begin{quote}
+SHELL = /bin/sh
+\end{quote}
+and it will need to be modified to \texttt{SHELL = /sbin/sh} if you are
+installing LAPACK on an SGI architecture.
+Second, you will
+need to modify the \texttt{PLAT} definition, which is appended to all
+library names, to specify the architecture to which you are installing
+LAPACK. This features avoids confusion in library names when you are
+installing LAPACK on more than one architecture. Next, you will need
+to modify \texttt{FORTRAN}, \texttt{OPTS}, \texttt{DRVOPTS}, \texttt{NOOPT}, \texttt{LOADER},
+and \texttt{LOADOPTS} to specify
+the compiler, compiler options, compiler options for the testing and
+timing\footnotemark[\value{footnote}] main programs, loader, loader options.
+Next you will have to choose which function you will use to time in the \texttt{SECOND} and \texttt{DSECND} routines.
+\begin{verbatim}
+#The Default : SECOND and DSECND will use a call to the EXTERNAL FUNCTION ETIME
+TIMER = EXT_ETIME
+# For RS6K : SECOND and DSECND will use a call to the EXTERNAL FUNCTION ETIME_
+# TIMER = EXT_ETIME_
+# For gfortran compiler: SECOND and DSECND will use the INTERNAL FUNCTION ETIME
+# TIMER = INT_ETIME
+# If your Fortran compiler does not provide etime (like Nag Fortran Compiler, etc...)
+# SECOND and DSECND will use a call to the INTERNAL FUNCTION CPU_TIME
+# TIMER = INT_CPU_TIME
+# If neither of this works...you can use the NONE value...
+# In that case, SECOND and DSECND will always return 0
+# TIMER = NONE
+\end{verbatim}
+Refer to the section~\ref{second} to get more information.
+
+
+Next, you will need to modify \texttt{ARCH}, \texttt{ARCHFLAGS}, and \texttt{RANLIB} to specify archiver,
+archiver options, and ranlib for your machine. If your architecture
+does not require \texttt{ranlib} to be run after each archive command (as
+is the case with CRAY computers running UNICOS, Hewlett Packard
+computers running HP-UX, or SUN SPARCstations running Solaris), set
+\texttt{ranlib=echo}. And finally, you must
+modify the \texttt{BLASLIB} definition to specify the BLAS library to which
+you will be linking. If an optimized version of the BLAS is available
+on your machine, you are highly recommended to link to that library.
+Otherwise, by default, \texttt{BLASLIB} is set to the Fortran~77 version.
+
+If you want to enable the XBLAS, define the variable \texttt{USEXBLAS}
+to some value, for example \texttt{USEXBLAS = Yes}. Then set the
+variable \texttt{XBLASLIB} to point at the XBLAS library. Note that
+the prototype iterative refinement routines and their testers will not
+be built unless \texttt{USEXBLAS} is defined.
+
+\textbf{NOTE:} Example \texttt{make.inc} include files are contained in the
+\texttt{LAPACK/INSTALL} directory. Please refer to
+Appendix~\ref{appendixd} for machine-specific installation hints, and/or
+the \texttt{release\_notes} file on \texttt{netlib}.
+\begin{quote}
+\url{http://www.netlib.org/lapack/release\_notes}
+\end{quote}
+
+\subsection{Edit the file \texttt{LAPACK/Makefile}}\label{toplevelmakefile}
+
+This \texttt{Makefile} can be modified to perform as much of the
+installation process as the user desires. Ideally, this is the ONLY
+makefile the user must modify. However, modification of lower-level
+makefiles may be necessary if a specific routine needs to be compiled
+with a different level of optimization.
+
+First, edit the definitions of \texttt{blaslib}, \texttt{lapacklib},
+\texttt{tmglib}, \texttt{lapack\_testing}, and \texttt{timing}\footnotemark[\value{footnote}] in the file \texttt{LAPACK/Makefile}
+to specify the data types desired. For example,
+if you only wish to compile the single precision real version of the
+LAPACK library, you would modify the \texttt{lapacklib} definition to be:
+
+\begin{verbatim}
+lapacklib:
+ ( cd SRC; $(MAKE) single )
+\end{verbatim}
+
+Likewise, you could specify \texttt{double, complex, or complex16} to
+build the double precision real, single precision complex, or double
+precision complex libraries, respectively. By default, the presence of
+no arguments following the \texttt{make} command will result in the
+building of all four data types.
+The make command can be run more than once to add another
+data type to the library if necessary.
+
+%If you are installing LAPACK on a Silicon Graphics machine, you must
+%modify the respective definitions of \texttt{testing} and \texttt{timing} to be
+%\begin{verbatim}
+%testing:
+% ( cd TESTING; $(MAKE) -f Makefile.sgi )
+%\end{verbatim}
+%and
+%\begin{verbatim}
+%timing:
+% ( cd TIMING; $(MAKE) -f Makefile.sgi )
+%\end{verbatim}
+
+Next, if you will be using a locally available BLAS library, you will need
+to remove \texttt{blaslib} from the \texttt{lib} definition. And finally,
+if you do not wish to build all of the libraries individually and
+likewise run all of the testing and timing separately, you can
+modify the \texttt{all} definition to specify the amount of the
+installation process that you want performed. By default,
+the \texttt{all} definition is set to
+\begin{verbatim}
+all: lapack_install lib lapack_testing blas_testing
+\end{verbatim}
+which will perform all phases of the installation
+process -- testing of machine-dependent routines, building the libraries,
+BLAS testing and LAPACK testing.
+
+The entire installation process will then be performed by typing
+\texttt{make}.
+
+Questions and/or comments can be directed to the
+authors as described in Section~\ref{sendresults}. If test failures
+occur, please refer to the appropriate subsection in
+Section~\ref{furtherdetails}.
+
+If disk space is limited, we suggest building each data type separately
+and/or deleting all object files after building the libraries. Likewise, all
+testing and timing executables can be deleted after the testing and timing
+process is completed. The removal of all object files and executables
+can be accomplished by the following:
+
+\begin{list}{}{}
+\item \texttt{cd LAPACK}
+\item \texttt{make clean}
+\end{list}
+
+\section{Further Details of the Installation Process}\label{furtherdetails}
+
+Alternatively, you can choose to run each of the phases of the
+installation process separately. The following sections give details
+on how this may be achieved.
+
+\subsection{Test and Install the Machine-Dependent Routines.}
+
+There are six machine-dependent functions in the test and timing
+package, at least three of which must be installed. They are
+
+\begin{tabbing}
+MONOMO \= DOUBLE PRECYSION \= \kill
+LSAME \> LOGICAL \> Test if two characters are the same regardless of case \\
+SLAMCH \> REAL \> Determine machine-dependent parameters \\
+DLAMCH \> DOUBLE PRECISION \> Determine machine-dependent parameters \\
+SECOND \> REAL \> Return time in seconds from a fixed starting time \\
+DSECND \> DOUBLE PRECISION \> Return time in seconds from a fixed starting time\\
+ILAENV \> INTEGER \> Checks that NaN and infinity arithmetic are IEEE-754 compliant
+\end{tabbing}
+
+\noindent
+If you are working only in single precision, you do not need to install
+DLAMCH and DSECND, and if you are working only in double precision,
+you do not need to install SLAMCH and SECOND.
+
+These six subroutines are provided in \texttt{LAPACK/INSTALL},
+along with six test programs.
+To compile the six test programs and run the tests, go to \texttt{LAPACK} and
+type \texttt{make lapack\_install}. The test programs are called
+\texttt{testlsame, testslamch, testdlamch, testsecond, testdsecnd} and
+\texttt{testieee}.
+If you do not wish to run all tests, you will need to modify the
+\texttt{lapack\_install} definition in the \texttt{LAPACK/Makefile} to only include the
+tests you wish to run. Otherwise, all tests will be performed.
+The expected results of each test program are described below.
+
+\subsubsection{Installing LSAME}
+
+LSAME is a logical function with two character parameters, A and B.
+It returns .TRUE. if A and B are the same regardless of case, or .FALSE.
+if they are different.
+For example, the expression
+
+\begin{list}{}{}
+\item \texttt{LSAME( UPLO, 'U' )}
+\end{list}
+\noindent
+is equivalent to
+\begin{list}{}{}
+\item \texttt{( UPLO.EQ.'U' ).OR.( UPLO.EQ.'u' )}
+\end{list}
+
+The test program in \texttt{lsametst.f} tests all combinations of
+the same character in upper and lower case for A and B, and two
+cases where A and B are different characters.
+
+Run the test program by typing \texttt{testlsame}.
+If LSAME works correctly, the only message you should see after the
+execution of \texttt{testlsame} is
+\begin{verbatim}
+ ASCII character set
+ Tests completed
+\end{verbatim}
+The file \texttt{lsame.f} is automatically copied to
+\texttt{LAPACK/BLAS/SRC/} and \texttt{LAPACK/SRC/}.
+The function LSAME is needed by both the BLAS and LAPACK, so it is safer
+to have it in both libraries as long as this does not cause trouble
+in the link phase when both libraries are used.
+
+\subsubsection{Installing SLAMCH and DLAMCH}
+
+SLAMCH and DLAMCH are real functions with a single character parameter
+that indicates the machine parameter to be returned. The test
+program in \texttt{slamchtst.f}
+simply prints out the different values computed by SLAMCH,
+so you need to know something about what the values should be.
+For example, the output of the test program executable \texttt{testslamch}
+for SLAMCH on a Sun SPARCstation is
+\begin{verbatim}
+ Epsilon = 5.96046E-08
+ Safe minimum = 1.17549E-38
+ Base = 2.00000
+ Precision = 1.19209E-07
+ Number of digits in mantissa = 24.0000
+ Rounding mode = 1.00000
+ Minimum exponent = -125.000
+ Underflow threshold = 1.17549E-38
+ Largest exponent = 128.000
+ Overflow threshold = 3.40282E+38
+ Reciprocal of safe minimum = 8.50706E+37
+\end{verbatim}
+On a Cray machine, the safe minimum underflows its output
+representation and the overflow threshold overflows its output
+representation, so the safe minimum is printed as 0.00000 and overflow
+is printed as R. This is normal.
+If you would prefer to print a representable number, you can modify
+the test program to print SFMIN*100. and RMAX/100. for the safe
+minimum and overflow thresholds.
+
+Likewise, the test executable \texttt{testdlamch} is run for DLAMCH.
+
+If both tests were successful, go to Section~\ref{second}.
+
+If SLAMCH (or DLAMCH) returns an invalid value, you will have to create
+your own version of this function. The following options are used in
+LAPACK and must be set:
+
+\begin{list}{}{}
+\item {`B': } Base of the machine
+\item {`E': } Epsilon (relative machine precision)
+\item {`O': } Overflow threshold
+\item {`P': } Precision = Epsilon*Base
+\item {`S': } Safe minimum (often same as underflow threshold)
+\item {`U': } Underflow threshold
+\end{list}
+
+Some people may be familiar with R1MACH (D1MACH), a primitive
+routine for setting machine parameters in which the user must
+comment out the appropriate assignment statements for the target
+machine. If a version of R1MACH is on hand, the assignments in
+SLAMCH can be made to refer to R1MACH using the correspondence
+
+\begin{list}{}{}
+\item {SLAMCH( `U' )} $=$ R1MACH( 1 )
+\item {SLAMCH( `O' )} $=$ R1MACH( 2 )
+\item {SLAMCH( `E' )} $=$ R1MACH( 3 )
+\item {SLAMCH( `B' )} $=$ R1MACH( 5 )
+\end{list}
+
+\noindent
+The safe minimum returned by SLAMCH( 'S' ) is initially set to the
+underflow value, but if $1/(\mathrm{overflow}) \geq (\mathrm{underflow})$
+it is recomputed as $(1/(\mathrm{overflow})) * ( 1 + \varepsilon )$,
+where $\varepsilon$ is the machine precision.
+
+BE AWARE that the initial call to SLAMCH or DLAMCH is expensive.
+We suggest that installers run it once, save the results, and hard-code
+the constants in the version they put in their library.
+
+\subsubsection{Installing SECOND and DSECND}\label{second}
+
+Both the timing routines\footnotemark[\value{footnote}] and the test routines call SECOND
+(DSECND), a real function with no arguments that returns the time
+in seconds from some fixed starting time.
+Our version of this routine
+returns only ``user time'', and not ``user time $+$ system time''.
+The following version of SECOND in \texttt{second\_EXT\_ETIME.f, second\_INT\_ETIME.f} calls
+ETIME, a Fortran library routine available on some computer systems.
+If ETIME is not available or a better local timing function exists,
+you will have to provide the correct interface to SECOND and DSECND
+on your machine.
+
+Since LAPACK 3.1.1 we provide 5 different flavours of the SECOND and DSECND routines.
+The version that will be used depends on the value of the TIMER variable in the make.inc
+
+\begin{itemize}
+\item If ETIME is available as an external function, set the value of the TIMER variable in your
+make.inc to \texttt{EXT\_ETIME}:\texttt{second\_EXT\_ETIME.f} and \texttt{dsecnd\_EXT\_ETIME.f} will be used.
+Usually on HPPA architectures,
+the compiler and loader flag \texttt{+U77} should be included to access
+the function \texttt{ETIME}.
+
+\item If ETIME\_ is available as an external function, set the value of the TIMER variable in your make.inc
+to \texttt{EXT\_ETIME\_}:\texttt{second\_EXT\_ETIME\_.f} and \texttt{dsecnd\_EXT\_ETIME\_.f} will be used.
+It is the case on some IBM architectures such as IBM RS/6000s.
+
+\item If ETIME is available as an internal function, set the value of the TIMER variable in your make.inc
+to \texttt{INT\_ETIME}:\texttt{second\_INT\_ETIME.f} and \texttt{dsecnd\_INT\_ETIME.f} will be used.
+This is the case with gfortan.
+
+\item If CPU\_TIME is available as an internal function, set the value of the TIMER variable in your make.inc
+to \texttt{INT\_CPU\_TIME}:\texttt{second\_INT\_CPU\_TIME.f} and \texttt{dsecnd\_INT\_CPU\_TIME.f} will be used.
+
+\item If none of these function is available, set the value of the TIMER variable in your make.inc
+to \texttt{NONE:}\texttt{second\_NONE.f} and \texttt{dsecnd\_NONE.f} will be used.
+These routines will always return zero.
+\end{itemize}
+
+The test program in \texttt{secondtst.f}
+performs a million operations using 5000 iterations of
+the SAXPY operation $y := y + \alpha x$ on a vector of length 100.
+The total time and megaflops for this test is reported, then
+the operation is repeated including a call to SECOND on each of
+the 5000 iterations to determine the overhead due to calling SECOND.
+The test program executable is called \texttt{testsecond} (or \texttt{testdsecnd}).
+There is no single right answer, but the times
+in seconds should be positive and the megaflop ratios should be
+appropriate for your machine.
+
+\subsubsection{Testing IEEE arithmetic and ILAENV}\label{testieee}
+
+%\textbf{If you are installing LAPACK on a non-IEEE machine, you MUST
+%modify ILAENV! Otherwise, ILAENV will crash . By default, ILAENV
+%assumes an IEEE machine, and does a test for IEEE-754 compliance.}
+
+As some new routines in LAPACK rely on IEEE-754 compliance,
+two settings (\texttt{ISPEC=10} and \texttt{ISPEC=11}) have been added to ILAENV
+(\texttt{LAPACK/SRC/ilaenv.f}) to denote IEEE-754 compliance for NaN and
+infinity arithmetic, respectively. By default, ILAENV assumes an IEEE
+machine, and does a test for IEEE-754 compliance. \textbf{NOTE: If you
+are installing LAPACK on a non-IEEE machine, you MUST modify ILAENV,
+as this test inside ILAENV will crash!}
+
+If \texttt{ILAENV( 10, $\ldots$ )} or \texttt{ILAENV( 11, $\ldots$ )} is
+issued, then \texttt{ILAENV=1} is returned to signal IEEE-754 compliance,
+and \texttt{ILAENV=0} if the architecture is non-IEEE-754 compliant.
+
+Thus, for non-IEEE machines, the user must hard-code the setting of
+(\texttt{ILAENV=0}) for (\texttt{ISPEC=10} and \texttt{ISPEC=11}) in the version
+of \texttt{LAPACK/SRC/ilaenv.f} to be put in
+his library. There are also specialized testing and timing\footnotemark[\value{footnote}] versions of
+ILAENV that will also need to be modified.
+\begin{itemize}
+\item Testing/timing version of \texttt{LAPACK/TESTING/LIN/ilaenv.f}
+\item Testing/timing version of \texttt{LAPACK/TESTING/EIG/ilaenv.f}
+\item Testing/timing version of \texttt{LAPACK/TIMING/LIN/ilaenv.f}
+\item Testing/timing version of \texttt{LAPACK/TIMING/EIG/ilaenv.f}
+\end{itemize}
+
+%Some new routines in LAPACK rely on IEEE-754 compliance, and if non-compliance
+%is detected (via a call to the function ILAENV), alternative (slower)
+%algorithms will be chosen.
+%For further details, refer to the leading comments of routines such
+%as \texttt{LAPACK/SRC/sstevr.f}.
+
+The test program in \texttt{LAPACK/INSTALL/tstiee.f} checks an installation
+architecture
+to see if infinity arithmetic and NaN arithmetic are IEEE-754 compliant.
+A warning message to the user is printed if non-compliance is detected.
+This same test is performed inside the function ILAENV. If
+\texttt{ILAENV( 10, $\ldots$ )} or \texttt{ILAENV( 11, $\ldots$ )} is
+issued, then \texttt{ILAENV=1} is returned to signal IEEE-754 compliance,
+and \texttt{ILAENV=0} if the architecture is non-IEEE-754 compliant.
+
+To avoid this IEEE test being run every time you call
+\texttt{ILAENV( 10, $\ldots$)} or \texttt{ILAENV( 11, $\ldots$ )}, we suggest
+that the user hard-code the setting of
+\texttt{ILAENV=1} or \texttt{ILAENV=0} in the version of \texttt{LAPACK/SRC/ilaenv.f} to be put in
+his library. As aforementioned, there are also specialized testing and
+timing\footnotemark[\value{footnote}] versions of ILAENV that will also need to be modified.
+
+\subsection{Create the BLAS Library}
+
+Ideally, a highly optimized version of the BLAS library already
+exists on your machine.
+In this case you can go directly to Section~\ref{testblas} to
+make the BLAS test programs.
+
+\begin{itemize}
+\item[a)]
+Go to \texttt{LAPACK} and edit the definition of \texttt{blaslib} in the
+file \texttt{Makefile} to specify the data types desired, as in the example
+in Section~\ref{toplevelmakefile}.
+
+If you already have some of the BLAS, you will need to edit the file
+\texttt{LAPACK/BLAS/SRC/Makefile} to comment out the lines
+defining the BLAS you have.
+
+\item[b)]
+Type \texttt{make blaslib}.
+The make command can be run more than once to add another
+data type to the library if necessary.
+\end{itemize}
+
+\noindent
+The BLAS library is created in \texttt{LAPACK/blas\_PLAT.a}, where
+\texttt{PLAT} is the user-defined architecture suffix specified in the file
+\texttt{LAPACK/make.inc}.
+
+\subsection{Run the BLAS Test Programs}\label{testblas}
+
+Test programs for the Level 1, 2, and 3 BLAS are in the directory
+\texttt{LAPACK/BLAS/TESTING}.
+
+To compile and run the Level 1, 2, and 3 BLAS test programs,
+go to \texttt{LAPACK} and type \texttt{make blas\_testing}. The executable
+files are called \texttt{xblat\_s}, \texttt{xblat\_d}, \texttt{xblat\_c}, and
+\texttt{xblat\_z}, where the \_ (underscore) is replaced by 1, 2, or 3,
+depending upon the level of BLAS that it is testing. All executable and
+output files are created in \texttt{LAPACK/BLAS/}.
+For the Level 1 BLAS tests, the output file names are \texttt{sblat1.out},
+\texttt{dblat1.out}, \texttt{cblat1.out}, and \texttt{zblat1.out}. For the Level
+2 and 3 BLAS, the name of the output file is indicated on the first line of the
+input file and is currently defined to be \texttt{sblat2.out} for
+the Level 2 REAL version, and \texttt{sblat3.out} for the Level 3 REAL
+version, with similar names for the other data types.
+
+If the tests using the supplied data files were completed successfully,
+consider whether the tests were sufficiently thorough.
+For example, on a machine with vector registers, at least one value
+of $N$ greater than the length of the vector registers should be used;
+otherwise, important parts of the compiled code may not be
+exercised by the tests.
+If the tests were not successful, either because the program did not
+finish or the test ratios did not pass the threshold, you will
+probably have to find and correct the problem before continuing.
+If you have been testing a system-specific
+BLAS library, try using the Fortran BLAS for the routines that
+did not pass the tests.
+For more details on the BLAS test programs,
+see \cite{BLAS2-test} and \cite{BLAS3-test}.
+
+\subsection{Create the LAPACK Library}
+
+\begin{itemize}
+\item[a)]
+Go to the directory \texttt{LAPACK} and edit the definition of
+\texttt{lapacklib} in the file \texttt{Makefile} to specify the data types desired,
+as in the example in Section~\ref{toplevelmakefile}.
+
+\item[b)]
+Type \texttt{make lapacklib}.
+The make command can be run more than once to add another
+data type to the library if necessary.
+
+\end{itemize}
+
+\noindent
+The LAPACK library is created in \texttt{LAPACK/lapack\_PLAT.a}, where
+\texttt{PLAT} is the user-defined architecture suffix specified in the file
+\texttt{LAPACK/make.inc}.
+
+\subsection{Create the Test Matrix Generator Library}
+
+\begin{itemize}
+\item[a)]
+Go to the directory \texttt{LAPACK} and edit the definition of \texttt{tmglib}
+in the file \texttt{Makefile} to specify the data types desired, as in the
+example in Section~\ref{toplevelmakefile}.
+
+\item[b)]
+Type \texttt{make tmglib}.
+The make command can be run more than once to add another
+data type to the library if necessary.
+
+\end{itemize}
+
+\noindent
+The test matrix generator library is created in \texttt{LAPACK/tmglib\_PLAT.a},
+where \texttt{PLAT} is the user-defined architecture suffix specified in the
+file \texttt{LAPACK/make.inc}.
+
+\subsection{Run the LAPACK Test Programs}
+
+There are two distinct test programs for LAPACK routines
+in each data type, one for the linear equation routines and
+one for the eigensystem routines.
+In each data type, there is one input file for testing the linear
+equation routines and eighteen input files for testing the eigenvalue
+routines.
+The input files reside in \texttt{LAPACK/TESTING}.
+For more information on the test programs and how to modify the
+input files, please refer to LAPACK Working Note 41~\cite{WN41}.
+% see Section~\ref{moretesting}.
+
+If you do not wish to run each of the tests individually, you can
+go to \texttt{LAPACK}, edit the definition \texttt{lapack\_testing} in the file
+\texttt{Makefile} to specify the data types desired, and type \texttt{make
+lapack\_testing}. This will
+compile and run the tests as described in sections~\ref{testlin}
+and ~\ref{testeig}.
+
+%If you are installing LAPACK on a Silicon Graphics machine, you must
+%modify the definition of \texttt{testing} to be
+%\begin{verbatim}
+%testing:
+% ( cd TESTING; $(MAKE) -f Makefile.sgi )
+%\end{verbatim}
+
+\subsubsection{Testing the Linear Equations Routines}\label{testlin}
+
+\begin{itemize}
+
+\item[a)]
+Go to \texttt{LAPACK/TESTING/LIN} and type \texttt{make} followed by the data types
+desired. The executable files are called \texttt{xlintsts, xlintstc,
+xlintstd}, or \texttt{xlintstz} and are created in \texttt{LAPACK/TESTING}.
+
+\item[b)]
+Go to \texttt{LAPACK/TESTING} and run the tests for each data type.
+For the REAL version, the command is
+\begin{list}{}{}
+\item{} \texttt{xlintsts < stest.in > stest.out}
+\end{list}
+
+\noindent
+The tests using \texttt{xlintstd}, \texttt{xlintstc}, and \texttt{xlintstz} are similar
+with the leading `s' in the input and output file names replaced
+by `d', `c', or `z'.
+
+\end{itemize}
+
+If you encountered failures in this phase of the testing process, please
+refer to Section~\ref{sendresults}.
+
+\subsubsection{Testing the Eigensystem Routines}\label{testeig}
+
+\begin{itemize}
+
+\item[a)]
+Go to \texttt{LAPACK/TESTING/EIG} and type \texttt{make} followed by the data types
+desired. The executable files are called \texttt{xeigtsts,
+xeigtstc, xeigtstd}, and \texttt{xeigtstz} and are created
+in \texttt{LAPACK/TESTING}.
+
+\item[b)]
+Go to \texttt{LAPACK/TESTING} and run the tests for each data type.
+The tests for the eigensystem routines use eighteen separate input files
+for testing the nonsymmetric eigenvalue problem,
+the symmetric eigenvalue problem, the banded symmetric eigenvalue
+problem, the generalized symmetric eigenvalue
+problem, the generalized nonsymmetric eigenvalue problem, the
+singular value decomposition, the banded singular value decomposition,
+the generalized singular value
+decomposition, the generalized QR and RQ factorizations, the generalized
+linear regression model, and the constrained linear least squares
+problem.
+The tests for the REAL version are as follows:
+\begin{list}{}{}
+\item \texttt{xeigtsts < nep.in > snep.out}
+\item \texttt{xeigtsts < sep.in > ssep.out}
+\item \texttt{xeigtsts < svd.in > ssvd.out}
+\item \texttt{xeigtsts < sec.in > sec.out}
+\item \texttt{xeigtsts < sed.in > sed.out}
+\item \texttt{xeigtsts < sgg.in > sgg.out}
+\item \texttt{xeigtsts < sgd.in > sgd.out}
+\item \texttt{xeigtsts < ssg.in > ssg.out}
+\item \texttt{xeigtsts < ssb.in > ssb.out}
+\item \texttt{xeigtsts < sbb.in > sbb.out}
+\item \texttt{xeigtsts < sbal.in > sbal.out}
+\item \texttt{xeigtsts < sbak.in > sbak.out}
+\item \texttt{xeigtsts < sgbal.in > sgbal.out}
+\item \texttt{xeigtsts < sgbak.in > sgbak.out}
+\item \texttt{xeigtsts < glm.in > sglm.out}
+\item \texttt{xeigtsts < gqr.in > sgqr.out}
+\item \texttt{xeigtsts < gsv.in > sgsv.out}
+\item \texttt{xeigtsts < lse.in > slse.out}
+\end{list}
+The tests using \texttt{xeigtstc}, \texttt{xeigtstd}, and \texttt{xeigtstz} also
+use the input files \texttt{nep.in}, \texttt{sep.in}, \texttt{svd.in},
+\texttt{glm.in}, \texttt{gqr.in}, \texttt{gsv.in}, and \texttt{lse.in},
+but the leading `s' in the other input file names must be changed
+to `c', `d', or `z'.
+\end{itemize}
+
+If you encountered failures in this phase of the testing process, please
+refer to Section~\ref{sendresults}.
+
+\subsection{Run the LAPACK Timing Programs (For LAPACK 3.0 and before)}
+
+There are two distinct timing programs for LAPACK routines
+in each data type, one for the linear equation routines and
+one for the eigensystem routines. The timing program for the
+linear equation routines is also used to time the BLAS.
+We encourage you to conduct these timing experiments
+in REAL and COMPLEX or in DOUBLE PRECISION and COMPLEX*16; it is
+not necessary to send timing results in all four data types.
+
+Two sets of input files are provided, a small set and a large set.
+The small data sets are appropriate for a standard workstation or
+other non-vector machine.
+The large data sets are appropriate for supercomputers, vector
+computers, and high-performance workstations.
+We are mainly interested in results from the large data sets, and
+it is not necessary to run both the large and small sets.
+The values of N in the large data sets are about five times larger
+than those in the small data set,
+and the large data sets use additional values for parameters such as the
+block size NB and the leading array dimension LDA.
+Small data sets finished with the \_small in their name , such as
+\texttt{stime\_small.in}, and large data sets finished with \_large in their name,
+such as \texttt{stime\_large.in}.
+Except as noted, the leading `s' in the input file name must be
+replaced by `d', `c', or `z' for the other data types.
+
+We encourage you to obtain timing results with the large data sets,
+as this allows us to compare different machines.
+If this would take too much time, suggestions for paring back the large
+data sets are given in the instructions below.
+We also encourage you to experiment with these timing
+programs and send us any interesting results, such as results for
+larger problems or for a wider range of block sizes.
+The main programs are dimensioned for the large data sets,
+so the parameters in the main program may have to be reduced in order
+to run the small data sets on a small machine, or increased to run
+experiments with larger problems.
+
+The minimum time each subroutine will be timed is set to 0.0 in
+the large data files and to 0.05 in the small data files, and on
+many machines this value should be increased.
+If the timing interval is not long
+enough, the time for the subroutine after subtracting the overhead
+may be very small or zero, resulting in megaflop rates that are
+very large or zero. (To avoid division by zero, the megaflop rate is
+set to zero if the time is less than or equal to zero.)
+The minimum time that should be used depends on the machine and the
+resolution of the clock.
+
+For more information on the timing programs and how to modify the
+input files, please refer to LAPACK Working Note 41~\cite{WN41}.
+% see Section~\ref{moretiming}.
+
+If you do not wish to run each of the timings individually, you can
+go to \texttt{LAPACK}, edit the definition \texttt{lapack\_timing} in the file
+\texttt{Makefile} to specify the data types desired, and type \texttt{make
+lapack\_timing}. This will compile
+and run the timings for the linear equation routines and the eigensystem
+routines (see Sections~\ref{timelin} and ~\ref{timeeig}).
+
+%If you are installing LAPACK on a Silicon Graphics machine, you must
+%modify the definition of \texttt{timing} to be
+%\begin{verbatim}
+%timing:
+% ( cd TIMING; $(MAKE) -f Makefile.sgi )
+%\end{verbatim}
+
+If you encounter failures in any phase of the timing process, please
+feel free to contact the authors as directed in Section~\ref{sendresults}.
+Tell us the
+type of machine on which the tests were run, the version of the operating
+system, the compiler and compiler options that were used,
+and details of the BLAS library or libraries that you used. You should
+also include a copy of the output file in which the failure occurs.
+
+Please note that the BLAS
+timing runs will still need to be run as instructed in ~\ref{timeblas}.
+
+\subsubsection{Timing the Linear Equations Routines}\label{timelin}
+
+The linear equation timing program is found in \texttt{LAPACK/TIMING/LIN}
+and the input files are in \texttt{LAPACK/TIMING}.
+Three input files are provided in each data type for timing the
+linear equation routines, one for square matrices, one for band
+matrices, and one for rectangular matrices. The small data sets for the REAL version
+are \texttt{stime\_small.in}, \texttt{sband\_small.in}, and \texttt{stime2\_small.in}, respectively,
+and the large data sets are
+\texttt{stime\_large.in}, \texttt{sband\_large.in}, and \texttt{stime2\_large.in}.
+
+The timing program for the least squares routines uses special instrumented
+versions of the LAPACK routines to time individual sections of the code.
+The first step in compiling the timing program is therefore to make a library
+of the instrumented routines.
+
+\begin{itemize}
+\item[a)]
+\begin{sloppypar}
+To make a library of the instrumented LAPACK routines, first
+go to \texttt{LAPACK/TIMING/LIN/LINSRC} and type \texttt{make} followed
+by the data types desired, as in the examples of Section~\ref{toplevelmakefile}.
+The library of instrumented code is created in
+\texttt{LAPACK/TIMING/LIN/linsrc\_PLAT.a},
+where \texttt{PLAT} is the user-defined architecture suffix specified in the
+file \texttt{LAPACK/make.inc}.
+\end{sloppypar}
+
+\item[b)]
+To make the linear equation timing programs,
+go to \texttt{LAPACK/TIMING/LIN} and type \texttt{make} followed by the data
+types desired, as in the examples in Section~\ref{toplevelmakefile}.
+The executable files are called \texttt{xlintims},
+\texttt{xlintimc}, \texttt{xlintimd}, and \texttt{xlintimz} and are created
+in \texttt{LAPACK/TIMING}.
+
+\item[c)]
+Go to \texttt{LAPACK/TIMING} and
+make any necessary modifications to the input files.
+You may need to set the minimum time a subroutine will
+be timed to a positive value, or to restrict the size of the tests
+if you are using a computer with performance in between that of a
+workstation and that of a supercomputer.
+The computational requirements can be cut in half by using only one
+value of LDA.
+If it is necessary to also reduce the matrix sizes or the values of
+the blocksize, corresponding changes should be made to the
+BLAS input files (see Section~\ref{timeblas}).
+
+\item[d)]
+Run the programs for each data type you are using.
+For the REAL version, the commands for the small data sets are
+
+\begin{list}{}{}
+\item{} \texttt{xlintims < stime\_small.in > stime\_small.out }
+\item{} \texttt{xlintims < sband\_small.in > sband\_small.out }
+\item{} \texttt{xlintims < stime2\_small.in > stime2\_small.out }
+\end{list}
+or the commands for the large data sets are
+\begin{list}{}{}
+\item{} \texttt{xlintims < stime\_large.in > stime\_large.out }
+\item{} \texttt{xlintims < sband\_large.in > sband\_large.out }
+\item{} \texttt{xlintims < stime2\_large.in > stime2\_large.out }
+\end{list}
+
+\noindent
+Similar commands should be used for the other data types.
+\end{itemize}
+
+\subsubsection{Timing the BLAS}\label{timeblas}
+
+The linear equation timing program is also used to time the BLAS.
+Three input files are provided in each data type for timing the Level
+2 and 3 BLAS.
+These input files time the BLAS using the matrix shapes encountered
+in the LAPACK routines, and we will use the results to analyze the
+performance of the LAPACK routines.
+For the REAL version, the small data files are
+\texttt{sblasa\_small.in}, \texttt{sblasb\_small.in}, and \texttt{sblasc\_small.in}
+and the large data files are
+\texttt{sblasa\_large.in}, \texttt{sblasb\_large.in}, and \texttt{sblasc\_large.in}.
+There are three sets of inputs because there are three
+parameters in the Level 3 BLAS, M, N, and K, and
+in most applications one of these parameters is small (on the order
+of the blocksize) while the other two are large (on the order of the
+matrix size).
+In \texttt{sblasa\_small.in}, M and N are large but K is
+small, while in \texttt{sblasb\_small.in} the small parameter is M, and
+in \texttt{sblasc\_small.in} the small parameter is N.
+The Level 2 BLAS are timed only in the first data set, where K
+is also used as the bandwidth for the banded routines.
+
+\begin{itemize}
+
+\item[a)]
+Go to \texttt{LAPACK/TIMING} and
+make any necessary modifications to the input files.
+You may need to set the minimum time a subroutine will
+be timed to a positive value.
+If you modified the values of N or NB
+in Section~\ref{timelin}, set M, N, and K accordingly.
+The large parameters among M, N, and K
+should be the same as the matrix sizes used in timing the linear
+equation routines,
+and the small parameter should be the same as the
+blocksizes used in timing the linear equation routines.
+If necessary, the large data set can be simplified by using only one
+value of LDA.
+
+\item[b)]
+Run the programs for each data type you are using.
+For the REAL version, the commands for the small data sets are
+
+\begin{list}{}{}
+\item{} \texttt{xlintims < sblasa\_small.in > sblasa\_small.out }
+\item{} \texttt{xlintims < sblasb\_small.in > sblasb\_small.out }
+\item{} \texttt{xlintims < sblasc\_small.in > sblasc\_small.out }
+\end{list}
+or the commands for the large data sets are
+\begin{list}{}{}
+\item{} \texttt{xlintims < sblasa\_large.in > sblasa\_large.out }
+\item{} \texttt{xlintims < sblasb\_large.in > sblasb\_large.out }
+\item{} \texttt{xlintims < sblasc\_large.in > sblasc\_large.out }
+\end{list}
+
+\noindent
+Similar commands should be used for the other data types.
+\end{itemize}
+
+\subsubsection{Timing the Eigensystem Routines}\label{timeeig}
+
+The eigensystem timing program is found in \texttt{LAPACK/TIMING/EIG}
+and the input files are in \texttt{LAPACK/TIMING}.
+Four input files are provided in each data type for timing the
+eigensystem routines,
+one for the generalized nonsymmetric eigenvalue problem,
+one for the nonsymmetric eigenvalue problem,
+one for the symmetric and generalized symmetric eigenvalue problem,
+and one for the singular value decomposition.
+For the REAL version, the small data sets are called \texttt{sgeptim\_small.in},
+\texttt{sneptim\_small.in}, \texttt{sseptim\_small.in}, and \texttt{ssvdtim\_small.in}, respectively.
+and the large data sets are called \texttt{sgeptim\_large.in}, \texttt{sneptim\_large.in},
+\texttt{sseptim\_large.in}, and \texttt{ssvdtim\_large.in}.
+Each of the four input files reads a different set of parameters,
+and the format of the input is indicated by a 3-character code
+on the first line.
+
+The timing program for eigenvalue/singular value routines accumulates
+the operation count as the routines are executing using special
+instrumented versions of the LAPACK routines. The first step in
+compiling the timing program is therefore to make a library of the
+instrumented routines.
+
+\begin{itemize}
+\item[a)]
+\begin{sloppypar}
+To make a library of the instrumented LAPACK routines, first
+go to \texttt{LAPACK/TIMING/EIG/EIGSRC} and type \texttt{make} followed
+by the data types desired, as in the examples of Section~\ref{toplevelmakefile}.
+The library of instrumented code is created in
+\texttt{LAPACK/TIMING/EIG/eigsrc\_PLAT.a},
+where \texttt{PLAT} is the user-defined architecture suffix specified in the
+file \texttt{LAPACK/make.inc}.
+\end{sloppypar}
+
+\item[b)]
+To make the eigensystem timing programs,
+go to \texttt{LAPACK/TIMING/EIG} and
+type \texttt{make} followed by the data types desired, as in the examples
+of Section~\ref{toplevelmakefile}. The executable files are called
+\texttt{xeigtims}, \texttt{xeigtimc}, \texttt{xeigtimd}, and \texttt{xeigtimz}
+and are created in \texttt{LAPACK/TIMING}.
+
+\item[c)]
+Go to \texttt{LAPACK/TIMING} and
+make any necessary modifications to the input files.
+You may need to set the minimum time a subroutine will
+be timed to a positive value, or to restrict the number of tests
+if you are using a computer with performance in between that of a
+workstation and that of a supercomputer.
+Instead of decreasing the matrix dimensions to reduce the time,
+it would be better to reduce the number of matrix types to be timed,
+since the performance varies more with the matrix size than with the
+type. For example, for the nonsymmetric eigenvalue routines,
+you could use only one matrix of type 4 instead of four matrices of
+types 1, 3, 4, and 6.
+Refer to LAPACK Working Note 41~\cite{WN41} for further details.
+% See Section~\ref{moretiming} for further details.
+
+\item[d)]
+Run the programs for each data type you are using.
+For the REAL version, the commands for the small data sets are
+
+\begin{list}{}{}
+\item{} \texttt{xeigtims < sgeptim\_small.in > sgeptim\_small.out }
+\item{} \texttt{xeigtims < sneptim\_small.in > sneptim\_small.out }
+\item{} \texttt{xeigtims < sseptim\_small.in > sseptim\_small.out }
+\item{} \texttt{xeigtims < ssvdtim\_small.in > ssvdtim\_small.out }
+\end{list}
+or the commands for the large data sets are
+\begin{list}{}{}
+\item{} \texttt{xeigtims < sgeptim\_large.in > sgeptim\_large.out }
+\item{} \texttt{xeigtims < sneptim\_large.in > sneptim\_large.out }
+\item{} \texttt{xeigtims < sseptim\_large.in > sseptim\_large.out }
+\item{} \texttt{xeigtims < ssvdtim\_large.in > ssvdtim\_large.out }
+\end{list}
+
+\noindent
+Similar commands should be used for the other data types.
+\end{itemize}
+
+\subsection{Send the Results to Tennessee}\label{sendresults}
+
+Congratulations! You have now finished installing, testing, and
+timing LAPACK. If you encountered failures in any phase of the
+testing or timing process, please
+consult our \texttt{release\_notes} file on netlib.
+\begin{quote}
+\url{http://www.netlib.org/lapack/release\_notes}
+\end{quote}
+This file contains machine-dependent installation clues which hopefully will
+alleviate your difficulties or at least let you know that other users
+have had similar difficulties on that machine. If there is not an entry
+for your machine or the suggestions do not fix your problem, please feel
+free to contact the authors at
+\begin{list}{}{}
+\item \href{mailto:lapack at cs.utk.edu}{\texttt{lapack at cs.utk.edu}}.
+\end{list}
+Tell us the
+type of machine on which the tests were run, the version of the operating
+system, the compiler and compiler options that were used,
+and details of the BLAS library or libraries that you used. You should
+also include a copy of the output file in which the failure occurs.
+
+We would like to keep our \texttt{release\_notes} file as up-to-date as possible.
+Therefore, if you do not see an entry for your machine, please contact us
+with your testing results.
+
+Comments and suggestions are also welcome.
+
+We encourage you to make the LAPACK library available to your
+users and provide us with feedback from their experiences.
+%This release of LAPACK is not guaranteed to be compatible
+%with any previous test release.
+
+\subsection{Get support}\label{getsupport}
+First, take a look at the complete installation manual in the LAPACK Working Note 41~\cite{WN41}.
+if you still cannot solve your problem, you have 2 ways to go:
+\begin{itemize}
+\item
+either send a post in the LAPACK forum
+\begin{quote}
+\url{http://icl.cs.utk.edu/lapack-forum}
+\end{quote}
+\item
+or send an email to the LAPACK mailing list:
+\begin{list}{}{}
+\item \href{mailto:lapack at cs.utk.edu}{\texttt{lapack at cs.utk.edu}}.
+\end{list}
+\end{itemize}
+\section*{Acknowledgments}
+
+Ed Anderson and Susan Blackford contributed to previous versions of this report.
+
+\appendix
+
+\chapter{Caveats}\label{appendixd}
+
+In this appendix we list a few of the machine-specific difficulties we
+have
+encountered in our own experience with LAPACK. A more detailed list
+of machine-dependent problems, bugs, and compiler errors encountered
+in the LAPACK installation process is maintained
+on \emph{netlib}.
+\begin{quote}
+\url{http://www.netlib.org/lapack/release\_notes}
+\end{quote}
+
+We assume the user has installed the machine-specific routines
+correctly and that the Level 1, 2 and 3 BLAS test programs have run
+successfully, so we do not list any warnings associated with those
+routines.
+
+\section{\texttt{LAPACK/make.inc}}
+
+All machine-specific
+parameters are specified in the file \texttt{LAPACK/make.inc}.
+
+The first line of this \texttt{make.inc} file is:
+\begin{quote}
+SHELL = /bin/sh
+\end{quote}
+and will need to be modified to \texttt{SHELL = /sbin/sh} if you are
+installing LAPACK on an SGI architecture.
+
+\section{ETIME}
+
+On HPPA architectures,
+the compiler and loader flag \texttt{+U77} should be included to access
+the function \texttt{ETIME}.
+
+\section{ILAENV and IEEE-754 compliance}
+
+%By default, ILAENV (\texttt{LAPACK/SRC/ilaenv.f}) assumes an IEEE and IEEE-754
+%compliant architecture, and thus sets (\texttt{ILAENV=1}) for (\texttt{ISPEC=10})
+%and (\texttt{ISPEC=11}) settings in ILAENV.
+%
+%If you are installing LAPACK on a non-IEEE machine, you MUST modify ILAENV,
+%as this test inside ILAENV will crash!
+
+As some new routines in LAPACK rely on IEEE-754 compliance,
+two settings (\texttt{ISPEC=10} and \texttt{ISPEC=11}) have been added to ILAENV
+(\texttt{LAPACK/SRC/ilaenv.f}) to denote IEEE-754 compliance for NaN and
+infinity arithmetic, respectively. By default, ILAENV assumes an IEEE
+machine, and does a test for IEEE-754 compliance. \textbf{NOTE: If you
+are installing LAPACK on a non-IEEE machine, you MUST modify ILAENV,
+as this test inside ILAENV will crash!}
+
+Thus, for non-IEEE machines, the user must hard-code the setting of
+(\texttt{ILAENV=0}) for (\texttt{ISPEC=10} and \texttt{ISPEC=11}) in the version
+of \texttt{LAPACK/SRC/ilaenv.f} to be put in
+his library. For further details, refer to section~\ref{testieee}.
+
+Be aware
+that some IEEE compilers by default do not enforce IEEE-754 compliance, and
+a compiler flag must be explicitly set by the user.
+
+On SGIs for example, you must set the \texttt{-OPT:IEEE\_NaN\_inf=ON} compiler
+flag to enable IEEE-754 compliance.
+
+And lastly, the test inside ILAENV to detect IEEE-754 compliance, will
+result in IEEE exceptions for ``Divide by Zero'' and ``Invalid Operation''.
+Thus, if the user is installing on a machine that issues IEEE exception
+warning messages (like a Sun SPARCstation), the user can disregard these
+messages. To avoid these messages, the user can hard-code the values
+inside ILAENV as explained in section~\ref{testieee}.
+
+\section{Lack of \texttt{/tmp} space}
+
+If \texttt{/tmp} space is small (i.e., less than approximately 16 MB) on your
+architecture, you may run out of space
+when compiling. There are a few possible solutions to this problem.
+\begin{enumerate}
+\item You can ask your system administrator to increase the size of the
+\texttt{/tmp} partition.
+\item You can change the environment variable \texttt{TMPDIR} to point to
+your home directory for temporary space. E.g.,
+\begin{quote}
+\texttt{setenv TMPDIR /home/userid/}
+\end{quote}
+where \texttt{/home/userid/} is the user's home directory.
+\item If your archive command has an \texttt{l} option, you can change the
+archive command to \texttt{ar crl} so that the
+archive command will only place temporary files in the current working
+directory rather than in the default temporary directory /tmp.
+\end{enumerate}
+
+\section{BLAS}
+
+If you suspect a BLAS-related problem and you are linking
+with an optimized version of the BLAS, we would strongly suggest
+as a first step that you link to the Fortran~77 version of
+the suspected BLAS routine and see if the error has disappeared.
+
+We have included test programs for the Level 1 BLAS.
+Users should therefore beware of a common problem in machine-specific
+implementations of xNRM2,
+the function to compute the 2-norm of a vector.
+The Fortran version of xNRM2 avoids underflow or overflow
+by scaling intermediate results, but some library versions of xNRM2
+are not so careful about scaling.
+If xNRM2 is implemented without scaling intermediate results, some of
+the LAPACK test ratios may be unusually high, or
+a floating point exception may occur in the problems scaled near
+underflow or overflow.
+The solution to these problems is to link the Fortran version of
+xNRM2 with the test program. \emph{On some CRAY architectures, the Fortran77
+version of xNRM2 should be used.}
+
+\section{Optimization}
+
+If a large numbers of test failures occur for a specific matrix type
+or operation, it could be that there is an optimization problem with
+your compiler. Thus, the user could try reducing the level of
+optimization or eliminating optimization entirely for those routines
+to see if the failures disappear when you rerun the tests.
+
+%LAPACK is written in Fortran 77. Prospective users with only a
+%Fortran 66 compiler will not be able to use this package.
+
+\section{Compiling testing/timing drivers}
+
+The testing and timing main programs (xCHKAA, xCHKEE, xTIMAA, and
+xTIMEE)
+allocate large amounts of local variables. Therefore, it is vitally
+important that the user know if his compiler by default allocates local
+variables statically or on the stack. It is not uncommon for those
+compilers which place local variables on the stack to cause a stack
+overflow at runtime in the testing or timing process. The user then
+has two options: increase your stack size, or force all local variables
+to be allocated statically.
+
+On HPPA architectures, the
+compiler and loader flag \texttt{-K} should be used when compiling these testing
+and timing main programs to avoid such a stack overflow. I.e., set
+\texttt{DRVOPTS = -K} in the \texttt{LAPACK/make.inc} file.
+
+For similar reasons,
+on SGI architectures, the compiler and loader flag \texttt{-static} should be
+used. I.e., set \texttt{DRVOPTS = -static} in the \texttt{LAPACK/make.inc} file.
+
+\section{IEEE arithmetic}
+
+Some of our test matrices are scaled near overflow or underflow,
+but on the Crays, problems with the arithmetic near overflow and
+underflow forced us to scale by only the square root of overflow
+and underflow.
+The LAPACK auxiliary routine SLABAD (or DLABAD) is called to
+take the square root of underflow and overflow in cases where it
+could cause difficulties.
+We assume we are on a Cray if $ \log_{10} (\mathrm{overflow})$
+is greater than 2000
+and take the square root of underflow and overflow in this case.
+The test in SLABAD is as follows:
+\begin{verbatim}
+ IF( LOG10( LARGE ).GT.2000. ) THEN
+ SMALL = SQRT( SMALL )
+ LARGE = SQRT( LARGE )
+ END IF
+\end{verbatim}
+Users of other machines with similar restrictions on the effective
+range of usable numbers may have to modify this test so that the
+square roots are done on their machine as well. \emph{Usually on
+HPPA architectures, a similar restriction in SLABAD should be enforced
+for all testing involving complex arithmetic.}
+SLABAD is located in \texttt{LAPACK/SRC}.
+
+For machines which have a narrow exponent range or lack gradual
+underflow (DEC VAXes for example), it is not uncommon to experience
+failures in sec.out and/or dec.out with SLAQTR/DLAQTR or DTRSYL.
+The failures in SLAQTR/DLAQTR and DTRSYL
+occur with test problems which are very badly scaled when the norm of
+the solution is very close to the underflow
+threshold (or even underflows to zero). We believe that these failures
+could probably be avoided by an even greater degree of care in scaling,
+but we did not want to delay the release of LAPACK any further. These
+tests pass successfully on most other machines. An example failure in
+dec.out on a MicroVAX II looks like the following:
+
+\begin{verbatim}
+Tests of the Nonsymmetric eigenproblem condition estimation routines
+DLALN2, DLASY2, DLANV2, DLAEXC, DTRSYL, DTREXC, DTRSNA, DTRSEN, DLAQTR
+
+Relative machine precision (EPS) = 0.277556D-16
+Safe minimum (SFMIN) = 0.587747D-38
+
+Routines pass computational tests if test ratio is less than 20.00
+
+DEC routines passed the tests of the error exits ( 35 tests done)
+Error in DTRSYL: RMAX = 0.155D+07
+LMAX = 5323 NINFO= 1600 KNT= 27648
+Error in DLAQTR: RMAX = 0.344D+04
+LMAX = 15792 NINFO= 26720 KNT= 45000
+\end{verbatim}
+
+\section{Timing programs}
+
+In the eigensystem timing program, calls are made to the LINPACK
+and EISPACK equivalents of the LAPACK routines to allow a direct
+comparison of performance measures.
+In some cases we have increased the minimum number of
+iterations in the LINPACK and EISPACK routines to allow
+them to converge for our test problems, but
+even this may not be enough.
+One goal of the LAPACK project is to improve the convergence
+properties of these routines, so error messages in the output
+file indicating that a LINPACK or EISPACK routine did not
+converge should not be regarded with alarm.
+
+In the eigensystem timing program, we have equivalenced some work
+arrays and then passed them to a subroutine, where both arrays are
+modified. This is a violation of the Fortran~77 standard, which
+says ``if a subprogram reference causes a dummy argument in the
+referenced subprogram to become associated with another dummy
+argument in the referenced subprogram, neither dummy argument may
+become defined during execution of the subprogram.''
+\footnote{ ANSI X3.9-1978, sec. 15.9.3.6}
+If this causes any difficulties, the equivalence
+can be commented out as explained in the comments for the main
+eigensystem timing programs.
+
+%\section*{MACHINE-SPECIFIC DIFFICULTIES}
+%Some IBM compilers do not recognize DBLE as a generic function as used
+%in LAPACK. The software tools we use to convert from single precision
+%to double precision convert REAL(C) and AIMAG(C), where C is COMPLEX,
+%to DBLE(Z) and DIMAG(Z), where Z is COMPLEX*16, but
+%IBM compilers use DREAL(Z) and DIMAG(Z) to take the real and
+%imaginary parts of a double complex number.
+%IBM users can fix this problem by changing DBLE to DREAL when the
+%argument of DBLE is COMPLEX*16.
+%
+%IBM compilers do not permit the data type COMPLEX*16 in a FUNCTION
+%subprogram definition. The data type on the first line of the
+%function subprogram must be changed from COMPLEX*16 to DOUBLE COMPLEX
+%for the following functions:
+%
+%\begin{tabbing}
+%\dent ZLATMOO \= from the test matrix generator library \kill
+%\dent ZBEG \> from the Level 2 BLAS test program \\
+%\dent ZBEG \> from the Level 3 BLAS test program \\
+%\dent ZLADIV \> from the LAPACK library \\
+%\dent ZLARND \> from the test matrix generator library \\
+%\dent ZLATM2 \> from the test matrix generator library \\
+%\dent ZLATM3 \> from the test matrix generator library
+%\end{tabbing}
+%The functions ZDOTC and ZDOTU from the Level 1 BLAS are already
+%declared DOUBLE COMPLEX. If that doesn't work, try the declaration
+%COMPLEX FUNCTION*16.
+
+
+\newpage
+\addcontentsline{toc}{section}{Bibliography}
+
+\begin{thebibliography}{9}
+
+\bibitem{LUG}
+E. Anderson, Z. Bai, C. Bischof, J. Demmel, J. Dongarra,
+J. Du Croz, A. Greenbaum, S. Hammarling, A. McKenney,
+S. Ostrouchov, and D. Sorensen,
+\textit{LAPACK Users' Guide}, Second Edition,
+{SIAM}, Philadelphia, PA, 1995.
+
+\bibitem{WN16}
+E. Anderson and J. Dongarra,
+\textit{LAPACK Working Note 16:
+Results from the Initial Release of LAPACK},
+University of Tennessee, CS-89-89, November 1989.
+
+\bibitem{WN41}
+E. Anderson, J. Dongarra, and S. Ostrouchov,
+\textit{LAPACK Working Note 41:
+Installation Guide for LAPACK},
+University of Tennessee, CS-92-151, February 1992 (revised June 1999).
+
+\bibitem{WN5}
+C. Bischof, J. Demmel, J. Dongarra, J. Du Croz, A. Greenbaum,
+S. Hammarling, and D. Sorensen,
+\textit{LAPACK Working Note \#5: Provisional Contents},
+Argonne National Laboratory, ANL-88-38, September 1988.
+
+\bibitem{WN13}
+Z. Bai, J. Demmel, and A. McKenney,
+\textit{LAPACK Working Note \#13: On the Conditioning of the Nonsymmetric
+Eigenvalue Problem: Theory and Software},
+University of Tennessee, CS-89-86, October 1989.
+
+\bibitem{XBLAS}
+X. S. Li, J. W. Demmel, D. H. Bailey, G. Henry, Y. Hida, J. Iskandar,
+W. Kahan, S. Y. Kang, A. Kapur, M. C. Martin, B. J. Thompson, T. Tung,
+and D. J. Yoo, \textit{Design, implementation and testing of extended
+ and mixed precision BLAS},
+\textit{ACM Trans. Math. Soft.}, 28, 2:152--205, June 2002.
+
+\bibitem{BLAS3}
+J. Dongarra, J. Du Croz, I. Duff, and S. Hammarling,
+``A Set of Level 3 Basic Linear Algebra Subprograms,''
+\textit{ACM Trans. Math. Soft.}, 16, 1:1-17, March 1990
+%Argonne National Laboratory, ANL-MCS-P88-1, August 1988.
+
+\bibitem{BLAS3-test}
+J. Dongarra, J. Du Croz, I. Duff, and S. Hammarling,
+``A Set of Level 3 Basic Linear Algebra Subprograms:
+Model Implementation and Test Programs,''
+\textit{ACM Trans. Math. Soft.}, 16, 1:18-28, March 1990
+%Argonne National Laboratory, ANL-MCS-TM-119, June 1988.
+
+\bibitem{BLAS2}
+J. Dongarra, J. Du Croz, S. Hammarling, and R. Hanson,
+``An Extended Set of Fortran Basic Linear Algebra Subprograms,''
+\textit{ACM Trans. Math. Soft.}, 14, 1:1-17, March 1988.
+
+\bibitem{BLAS2-test}
+J. Dongarra, J. Du Croz, S. Hammarling, and R. Hanson,
+``An Extended Set of Fortran Basic Linear Algebra Subprograms:
+Model Implementation and Test Programs,''
+\textit{ACM Trans. Math. Soft.}, 14, 1:18-32, March 1988.
+
+\bibitem{BLAS1}
+C. L. Lawson, R. J. Hanson, D. R. Kincaid, and F. T. Krogh,
+``Basic Linear Algebra Subprograms for Fortran Usage,''
+\textit{ACM Trans. Math. Soft.}, 5, 3:308-323, September 1979.
+
+\end{thebibliography}
+
+\end{document}
diff --git a/INSTALL/lsame.c b/INSTALL/lsame.c
new file mode 100644
index 0000000..d19dde1
--- /dev/null
+++ b/INSTALL/lsame.c
@@ -0,0 +1,117 @@
+/* lsame.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+logical lsame_(char *ca, char *cb)
+{
+ /* System generated locals */
+ logical ret_val;
+
+ /* Local variables */
+ integer inta, intb, zcode;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* LSAME returns .TRUE. if CA is the same letter as CB regardless of */
+/* case. */
+
+/* Arguments */
+/* ========= */
+
+/* CA (input) CHARACTER*1 */
+/* CB (input) CHARACTER*1 */
+/* CA and CB specify the single characters to be compared. */
+
+/* ===================================================================== */
+
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test if the characters are equal */
+
+ ret_val = *(unsigned char *)ca == *(unsigned char *)cb;
+ if (ret_val) {
+ return ret_val;
+ }
+
+/* Now test for equivalence if both characters are alphabetic. */
+
+ zcode = 'Z';
+
+/* Use 'Z' rather than 'A' so that ASCII can be detected on Prime */
+/* machines, on which ICHAR returns a value with bit 8 set. */
+/* ICHAR('A') on Prime machines returns 193 which is the same as */
+/* ICHAR('A') on an EBCDIC machine. */
+
+ inta = *(unsigned char *)ca;
+ intb = *(unsigned char *)cb;
+
+ if (zcode == 90 || zcode == 122) {
+
+/* ASCII is assumed - ZCODE is the ASCII code of either lower or */
+/* upper case 'Z'. */
+
+ if (inta >= 97 && inta <= 122) {
+ inta += -32;
+ }
+ if (intb >= 97 && intb <= 122) {
+ intb += -32;
+ }
+
+ } else if (zcode == 233 || zcode == 169) {
+
+/* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or */
+/* upper case 'Z'. */
+
+ if (inta >= 129 && inta <= 137 || inta >= 145 && inta <= 153 || inta
+ >= 162 && inta <= 169) {
+ inta += 64;
+ }
+ if (intb >= 129 && intb <= 137 || intb >= 145 && intb <= 153 || intb
+ >= 162 && intb <= 169) {
+ intb += 64;
+ }
+
+ } else if (zcode == 218 || zcode == 250) {
+
+/* ASCII is assumed, on Prime machines - ZCODE is the ASCII code */
+/* plus 128 of either lower or upper case 'Z'. */
+
+ if (inta >= 225 && inta <= 250) {
+ inta += -32;
+ }
+ if (intb >= 225 && intb <= 250) {
+ intb += -32;
+ }
+ }
+ ret_val = inta == intb;
+
+/* RETURN */
+
+/* End of LSAME */
+
+ return ret_val;
+} /* lsame_ */
diff --git a/INSTALL/lsametst.c b/INSTALL/lsametst.c
new file mode 100644
index 0000000..e5f88bd
--- /dev/null
+++ b/INSTALL/lsametst.c
@@ -0,0 +1,172 @@
+/* lsametst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__9 = 9;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 *** Error: LSAME( \002,a1,\002, \002,"
+ "a1,\002) is .FALSE.\002)";
+ static char fmt_9998[] = "(\002 *** Error: LSAME( \002,a1,\002, \002,"
+ "a1,\002) is .TRUE.\002)";
+
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_wsle(void), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen),
+ e_wsfe(void);
+
+ /* Local variables */
+ integer i1, i2;
+ extern logical lsame_(char *, char *);
+
+ /* Fortran I/O blocks */
+ static cilist io___3 = { 0, 6, 0, 0, 0 };
+ static cilist io___4 = { 0, 6, 0, 0, 0 };
+ static cilist io___5 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___6 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___7 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___8 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___9 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___10 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___11 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___12 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___13 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___14 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___15 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___16 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___17 = { 0, 6, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+
+/* Determine the character set. */
+
+ i1 = 'A';
+ i2 = 'a';
+ if (i2 - i1 == 32) {
+ s_wsle(&io___3);
+ do_lio(&c__9, &c__1, " ASCII character set", (ftnlen)20);
+ e_wsle();
+ } else {
+ s_wsle(&io___4);
+ do_lio(&c__9, &c__1, " Non-ASCII character set, IOFF should be ", (
+ ftnlen)41);
+ i__1 = i2 - i1;
+ do_lio(&c__3, &c__1, (char *)&i__1, (ftnlen)sizeof(integer));
+ e_wsle();
+ }
+
+/* Test LSAME. */
+
+ if (! lsame_("A", "A")) {
+ s_wsfe(&io___5);
+ do_fio(&c__1, "A", (ftnlen)1);
+ do_fio(&c__1, "A", (ftnlen)1);
+ e_wsfe();
+ }
+ if (! lsame_("A", "a")) {
+ s_wsfe(&io___6);
+ do_fio(&c__1, "A", (ftnlen)1);
+ do_fio(&c__1, "a", (ftnlen)1);
+ e_wsfe();
+ }
+ if (! lsame_("a", "A")) {
+ s_wsfe(&io___7);
+ do_fio(&c__1, "a", (ftnlen)1);
+ do_fio(&c__1, "A", (ftnlen)1);
+ e_wsfe();
+ }
+ if (! lsame_("a", "a")) {
+ s_wsfe(&io___8);
+ do_fio(&c__1, "a", (ftnlen)1);
+ do_fio(&c__1, "a", (ftnlen)1);
+ e_wsfe();
+ }
+ if (lsame_("A", "B")) {
+ s_wsfe(&io___9);
+ do_fio(&c__1, "A", (ftnlen)1);
+ do_fio(&c__1, "B", (ftnlen)1);
+ e_wsfe();
+ }
+ if (lsame_("A", "b")) {
+ s_wsfe(&io___10);
+ do_fio(&c__1, "A", (ftnlen)1);
+ do_fio(&c__1, "b", (ftnlen)1);
+ e_wsfe();
+ }
+ if (lsame_("a", "B")) {
+ s_wsfe(&io___11);
+ do_fio(&c__1, "a", (ftnlen)1);
+ do_fio(&c__1, "B", (ftnlen)1);
+ e_wsfe();
+ }
+ if (lsame_("a", "b")) {
+ s_wsfe(&io___12);
+ do_fio(&c__1, "a", (ftnlen)1);
+ do_fio(&c__1, "b", (ftnlen)1);
+ e_wsfe();
+ }
+ if (lsame_("O", "/")) {
+ s_wsfe(&io___13);
+ do_fio(&c__1, "O", (ftnlen)1);
+ do_fio(&c__1, "/", (ftnlen)1);
+ e_wsfe();
+ }
+ if (lsame_("/", "O")) {
+ s_wsfe(&io___14);
+ do_fio(&c__1, "/", (ftnlen)1);
+ do_fio(&c__1, "O", (ftnlen)1);
+ e_wsfe();
+ }
+ if (lsame_("o", "/")) {
+ s_wsfe(&io___15);
+ do_fio(&c__1, "o", (ftnlen)1);
+ do_fio(&c__1, "/", (ftnlen)1);
+ e_wsfe();
+ }
+ if (lsame_("/", "o")) {
+ s_wsfe(&io___16);
+ do_fio(&c__1, "/", (ftnlen)1);
+ do_fio(&c__1, "o", (ftnlen)1);
+ e_wsfe();
+ }
+ s_wsle(&io___17);
+ do_lio(&c__9, &c__1, " Tests completed", (ftnlen)16);
+ e_wsle();
+
+ return 0;
+} /* MAIN__ */
+
+/* Main program alias */ int test1_ () { MAIN__ (); return 0; }
diff --git a/INSTALL/psfig.tex b/INSTALL/psfig.tex
new file mode 100644
index 0000000..e1e65a9
--- /dev/null
+++ b/INSTALL/psfig.tex
@@ -0,0 +1,391 @@
+% Psfig/TeX Release 1.2
+% dvi2ps-li version
+%
+% All software, documentation, and related files in this distribution of
+% psfig/tex are Copyright 1987, 1988 Trevor J. Darrell
+%
+% Permission is granted for use and non-profit distribution of psfig/tex
+% providing that this notice be clearly maintained, but the right to
+% distribute any portion of psfig/tex for profit or as part of any commercial
+% product is specifically reserved for the author.
+%
+% $Header$
+% $Source$
+%
+% Thanks to Greg Hager (GDH) and Ned Batchelder for their contributions
+% to this project.
+%
+\catcode`\@=11\relax
+\newwrite\@unused
+\def\typeout#1{{\let\protect\string\immediate\write\@unused{#1}}}
+\typeout{psfig/tex 1.2-dvi2ps-li}
+
+%% Here's how you define your figure path. Should be set up with null
+%% default and a user useable definition.
+
+\def\figurepath{./}
+\def\psfigurepath#1{\edef\figurepath{#1}}
+
+%
+% @psdo control structure -- similar to Latex @for.
+% I redefined these with different names so that psfig can
+% be used with TeX as well as LaTeX, and so that it will not
+% be vunerable to future changes in LaTeX's internal
+% control structure,
+%
+\def\@nnil{\@nil}
+\def\@empty{}
+\def\@psdonoop#1\@@#2#3{}
+\def\@psdo#1:=#2\do#3{\edef\@psdotmp{#2}\ifx\@psdotmp\@empty \else
+ \expandafter\@psdoloop#2,\@nil,\@nil\@@#1{#3}\fi}
+\def\@psdoloop#1,#2,#3\@@#4#5{\def#4{#1}\ifx #4\@nnil \else
+ #5\def#4{#2}\ifx #4\@nnil \else#5\@ipsdoloop #3\@@#4{#5}\fi\fi}
+\def\@ipsdoloop#1,#2\@@#3#4{\def#3{#1}\ifx #3\@nnil
+ \let\@nextwhile=\@psdonoop \else
+ #4\relax\let\@nextwhile=\@ipsdoloop\fi\@nextwhile#2\@@#3{#4}}
+\def\@tpsdo#1:=#2\do#3{\xdef\@psdotmp{#2}\ifx\@psdotmp\@empty \else
+ \@tpsdoloop#2\@nil\@nil\@@#1{#3}\fi}
+\def\@tpsdoloop#1#2\@@#3#4{\def#3{#1}\ifx #3\@nnil
+ \let\@nextwhile=\@psdonoop \else
+ #4\relax\let\@nextwhile=\@tpsdoloop\fi\@nextwhile#2\@@#3{#4}}
+%
+%
+\def\psdraft{
+ \def\@psdraft{0}
+ %\typeout{draft level now is \@psdraft \space . }
+}
+\def\psfull{
+ \def\@psdraft{100}
+ %\typeout{draft level now is \@psdraft \space . }
+}
+\psfull
+\newif\if at prologfile
+\newif\if at postlogfile
+\newif\if at noisy
+\def\pssilent{
+ \@noisyfalse
+}
+\def\psnoisy{
+ \@noisytrue
+}
+\psnoisy
+%%% These are for the option list.
+%%% A specification of the form a = b maps to calling \@p@@sa{b}
+\newif\if at bbllx
+\newif\if at bblly
+\newif\if at bburx
+\newif\if at bbury
+\newif\if at height
+\newif\if at width
+\newif\if at rheight
+\newif\if at rwidth
+\newif\if at clip
+\newif\if at verbose
+\def\@p@@sclip#1{\@cliptrue}
+
+%%% GDH 7/26/87 -- changed so that it first looks in the local directory,
+%%% then in a specified global directory for the ps file.
+
+\def\@p@@sfile#1{\def\@p at sfile{null}%
+ \openin1=#1
+ \ifeof1\closein1%
+ \openin1=\figurepath#1
+ \ifeof1\typeout{Error, File #1 not found}
+ \else\closein1
+ \edef\@p at sfile{\figurepath#1}%
+ \fi%
+ \else\closein1%
+ \def\@p at sfile{#1}%
+ \fi}
+\def\@p@@sfigure#1{\def\@p at sfile{null}%
+ \openin1=#1
+ \ifeof1\closein1%
+ \openin1=\figurepath#1
+ \ifeof1\typeout{Error, File #1 not found}
+ \else\closein1
+ \def\@p at sfile{\figurepath#1}%
+ \fi%
+ \else\closein1%
+ \def\@p at sfile{#1}%
+ \fi}
+
+\def\@p@@sbbllx#1{
+ %\typeout{bbllx is #1}
+ \@bbllxtrue
+ \dimen100=#1
+ \edef\@p at sbbllx{\number\dimen100}
+}
+\def\@p@@sbblly#1{
+ %\typeout{bblly is #1}
+ \@bbllytrue
+ \dimen100=#1
+ \edef\@p at sbblly{\number\dimen100}
+}
+\def\@p@@sbburx#1{
+ %\typeout{bburx is #1}
+ \@bburxtrue
+ \dimen100=#1
+ \edef\@p at sbburx{\number\dimen100}
+}
+\def\@p@@sbbury#1{
+ %\typeout{bbury is #1}
+ \@bburytrue
+ \dimen100=#1
+ \edef\@p at sbbury{\number\dimen100}
+}
+\def\@p@@sheight#1{
+ \@heighttrue
+ \dimen100=#1
+ \edef\@p at sheight{\number\dimen100}
+ %\typeout{Height is \@p at sheight}
+}
+\def\@p@@swidth#1{
+ %\typeout{Width is #1}
+ \@widthtrue
+ \dimen100=#1
+ \edef\@p at swidth{\number\dimen100}
+}
+\def\@p@@srheight#1{
+ %\typeout{Reserved height is #1}
+ \@rheighttrue
+ \dimen100=#1
+ \edef\@p at srheight{\number\dimen100}
+}
+\def\@p@@srwidth#1{
+ %\typeout{Reserved width is #1}
+ \@rwidthtrue
+ \dimen100=#1
+ \edef\@p at srwidth{\number\dimen100}
+}
+\def\@p@@ssilent#1{
+ \@verbosefalse
+}
+\def\@p@@sprolog#1{\@prologfiletrue\def\@prologfileval{#1}}
+\def\@p@@spostlog#1{\@postlogfiletrue\def\@postlogfileval{#1}}
+\def\@cs at name#1{\csname #1\endcsname}
+\def\@setparms#1=#2,{\@cs at name{@p@@s#1}{#2}}
+%
+% initialize the defaults (size the size of the figure)
+%
+\def\ps at init@parms{
+ \@bbllxfalse \@bbllyfalse
+ \@bburxfalse \@bburyfalse
+ \@heightfalse \@widthfalse
+ \@rheightfalse \@rwidthfalse
+ \def\@p at sbbllx{}\def\@p at sbblly{}
+ \def\@p at sbburx{}\def\@p at sbbury{}
+ \def\@p at sheight{}\def\@p at swidth{}
+ \def\@p at srheight{}\def\@p at srwidth{}
+ \def\@p at sfile{}
+ \def\@p at scost{10}
+ \def\@sc{}
+ \@prologfilefalse
+ \@postlogfilefalse
+ \@clipfalse
+ \if at noisy
+ \@verbosetrue
+ \else
+ \@verbosefalse
+ \fi
+
+}
+%
+% Go through the options setting things up.
+%
+\def\parse at ps@parms#1{
+ \@psdo\@psfiga:=#1\do
+ {\expandafter\@setparms\@psfiga,}}
+%
+% Compute bb height and width
+%
+\newif\ifno at bb
+\newif\ifnot at eof
+\newread\ps at stream
+\def\bb at missing{
+ \if at verbose{
+ \typeout{psfig: searching \@p at sfile \space for bounding box}
+ }\fi
+ \openin\ps at stream=\@p at sfile
+ \no at bbtrue
+ \not at eoftrue
+ \catcode`\%=12
+ \loop
+ \read\ps at stream to \line at in
+ \global\toks200=\expandafter{\line at in}
+ \ifeof\ps at stream \not at eoffalse \fi
+ %\typeout{ looking at :: \the\toks200 }
+ \@bbtest{\toks200}
+ \if at bbmatch\not at eoffalse\expandafter\bb at cull\the\toks200\fi
+ \ifnot at eof \repeat
+ \catcode`\%=14
+}
+\catcode`\%=12
+\newif\if at bbmatch
+\def\@bbtest#1{\expandafter\@a@\the#1%%BoundingBox:\@bbtest\@a@}
+\long\def\@a@#1%%BoundingBox:#2#3\@a@{\ifx\@bbtest#2\@bbmatchfalse\else\@bbmatchtrue\fi}
+\long\def\bb at cull#1 #2 #3 #4 #5 {
+ \dimen100=#2 bp\edef\@p at sbbllx{\number\dimen100}
+ \dimen100=#3 bp\edef\@p at sbblly{\number\dimen100}
+ \dimen100=#4 bp\edef\@p at sbburx{\number\dimen100}
+ \dimen100=#5 bp\edef\@p at sbbury{\number\dimen100}
+ \no at bbfalse
+}
+\catcode`\%=14
+%
+\def\compute at bb{
+ \no at bbfalse
+ \if at bbllx \else \no at bbtrue \fi
+ \if at bblly \else \no at bbtrue \fi
+ \if at bburx \else \no at bbtrue \fi
+ \if at bbury \else \no at bbtrue \fi
+ \ifno at bb \bb at missing \fi
+ \ifno at bb \typeout{FATAL ERROR: no bb supplied or found}
+ \no-bb-error
+ \fi
+ %
+ \count203=\@p at sbburx
+ \count204=\@p at sbbury
+ \advance\count203 by -\@p at sbbllx
+ \advance\count204 by -\@p at sbblly
+ \edef\@bbw{\number\count203}
+ \edef\@bbh{\number\count204}
+ %\typeout{ bbh = \@bbh, bbw = \@bbw }
+}
+%
+% \in at hundreds performs #1 * (#2 / #3) correct to the hundreds,
+% then leaves the result in @result
+%
+\def\in at hundreds#1#2#3{\count240=#2 \count241=#3
+ \count100=\count240 % 100 is first digit #2/#3
+ \divide\count100 by \count241
+ \count101=\count100
+ \multiply\count101 by \count241
+ \advance\count240 by -\count101
+ \multiply\count240 by 10
+ \count101=\count240 %101 is second digit of #2/#3
+ \divide\count101 by \count241
+ \count102=\count101
+ \multiply\count102 by \count241
+ \advance\count240 by -\count102
+ \multiply\count240 by 10
+ \count102=\count240 % 102 is the third digit
+ \divide\count102 by \count241
+ \count200=#1\count205=0
+ \count201=\count200
+ \multiply\count201 by \count100
+ \advance\count205 by \count201
+ \count201=\count200
+ \divide\count201 by 10
+ \multiply\count201 by \count101
+ \advance\count205 by \count201
+ %
+ \count201=\count200
+ \divide\count201 by 100
+ \multiply\count201 by \count102
+ \advance\count205 by \count201
+ %
+ \edef\@result{\number\count205}
+}
+\def\compute at wfromh{
+ % computing : width = height * (bbw / bbh)
+ \in at hundreds{\@p at sheight}{\@bbw}{\@bbh}
+ %\typeout{ \@p at sheight * \@bbw / \@bbh, = \@result }
+ \edef\@p at swidth{\@result}
+ %\typeout{w from h: width is \@p at swidth}
+}
+\def\compute at hfromw{
+ % computing : height = width * (bbh / bbw)
+ \in at hundreds{\@p at swidth}{\@bbh}{\@bbw}
+ %\typeout{ \@p at swidth * \@bbh / \@bbw = \@result }
+ \edef\@p at sheight{\@result}
+ %\typeout{h from w : height is \@p at sheight}
+}
+\def\compute at handw{
+ \if at height
+ \if at width
+ \else
+ \compute at wfromh
+ \fi
+ \else
+ \if at width
+ \compute at hfromw
+ \else
+ \edef\@p at sheight{\@bbh}
+ \edef\@p at swidth{\@bbw}
+ \fi
+ \fi
+}
+\def\compute at resv{
+ \if at rheight \else \edef\@p at srheight{\@p at sheight} \fi
+ \if at rwidth \else \edef\@p at srwidth{\@p at swidth} \fi
+}
+%
+% Compute any missing values
+\def\compute at sizes{
+ \compute at bb
+ \compute at handw
+ \compute at resv
+}
+%
+% \psfig
+% usage : \psfig{file=, height=, width=, bbllx=, bblly=, bburx=, bbury=,
+% rheight=, rwidth=, clip=}
+%
+% "clip=" is a switch and takes no value, but the `=' must be present.
+\def\psfig#1{\vbox {
+ % do a zero width hard space so that a single
+ % \psfig in a centering enviornment will behave nicely
+ %{\setbox0=\hbox{\ }\ \hskip-\wd0}
+ %
+ \ps at init@parms
+ \parse at ps@parms{#1}
+ \compute at sizes
+ %
+ \ifnum\@p at scost<\@psdraft{
+ \if at verbose{
+ \typeout{psfig: including \@p at sfile \space }
+ }\fi
+ %
+ \special{ pstext="\@p at swidth \space
+ \@p at sheight \space
+ \@p at sbbllx \space \@p at sbblly \space
+ \@p at sbburx \space
+ \@p at sbbury \space startTexFig" \space}
+ \if at clip{
+ \if at verbose{
+ \typeout{(clip)}
+ }\fi
+ \special{ pstext="doclip \space"}
+ }\fi
+ \if at prologfile
+ \special{psfile=\@prologfileval \space } \fi
+ \special{psfile=\@p at sfile \space }
+ \if at postlogfile
+ \special{psfile=\@postlogfileval \space } \fi
+ \special{pstext=endTexFig \space }
+ % Create the vbox to reserve the space for the figure
+ \vbox to \@p at srheight true sp{
+ \hbox to \@p at srwidth true sp{
+ \hss
+ }
+ \vss
+ }
+ }\else{
+ % draft figure, just reserve the space and print the
+ % path name.
+ \vbox to \@p at srheight true sp{
+ \vss
+ \hbox to \@p at srwidth true sp{
+ \hss
+ \if at verbose{
+ \@p at sfile
+ }\fi
+ \hss
+ }
+ \vss
+ }
+ }\fi
+}}
+\def\psglobal{\typeout{psfig: PSGLOBAL is OBSOLETE; use psprint -m instead}}
+\catcode`\@=12\relax
+
diff --git a/INSTALL/second.c b/INSTALL/second.c
new file mode 100644
index 0000000..33c7dde
--- /dev/null
+++ b/INSTALL/second.c
@@ -0,0 +1,17 @@
+#include "f2c.h"
+#include <sys/times.h>
+#include <sys/types.h>
+#include <time.h>
+
+#ifndef CLK_TCK
+#define CLK_TCK 60
+#endif
+
+doublereal second_()
+{
+ struct tms rusage;
+
+ times(&rusage);
+ return (doublereal)(rusage.tms_utime) / CLK_TCK;
+
+} /* second_ */
diff --git a/INSTALL/secondtst.c b/INSTALL/secondtst.c
new file mode 100644
index 0000000..00c7322
--- /dev/null
+++ b/INSTALL/secondtst.c
@@ -0,0 +1,162 @@
+/* secondtst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__100 = 100;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 Time for 1,000,000 SAXPY ops = \002,g10"
+ ".3,\002 seconds\002)";
+ static char fmt_9998[] = "(\002 SAXPY performance rate = \002,g10"
+ ".3,\002 mflops \002)";
+ static char fmt_9994[] = "(\002 *** Error: Time for operations was zer"
+ "o\002)";
+ static char fmt_9997[] = "(\002 Including SECOND, time = \002,g10"
+ ".3,\002 seconds\002)";
+ static char fmt_9996[] = "(\002 Average time for SECOND = \002,g10"
+ ".3,\002 milliseconds\002)";
+ static char fmt_9995[] = "(\002 Equivalent floating point ops = \002,g10"
+ ".3,\002 ops\002)";
+
+ /* System generated locals */
+ real r__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j;
+ real x[100], y[100], t1, t2, avg, alpha;
+ extern /* Subroutine */ int mysub_(integer *, real *, real *);
+ extern doublereal second_(void);
+ real tnosec;
+
+ /* Fortran I/O blocks */
+ static cilist io___8 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___9 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___10 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___12 = { 0, 6, 0, fmt_9997, 0 };
+ static cilist io___14 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___15 = { 0, 6, 0, fmt_9995, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+
+/* Initialize X and Y */
+
+ for (i__ = 1; i__ <= 100; ++i__) {
+ x[i__ - 1] = 1.f / (real) i__;
+ y[i__ - 1] = (real) (100 - i__) / 100.f;
+/* L10: */
+ }
+ alpha = .315f;
+
+/* Time 1,000,000 SAXPY operations */
+
+ t1 = second_();
+ for (j = 1; j <= 5000; ++j) {
+ for (i__ = 1; i__ <= 100; ++i__) {
+ y[i__ - 1] += alpha * x[i__ - 1];
+/* L20: */
+ }
+ alpha = -alpha;
+/* L30: */
+ }
+ t2 = second_();
+ s_wsfe(&io___8);
+ r__1 = t2 - t1;
+ do_fio(&c__1, (char *)&r__1, (ftnlen)sizeof(real));
+ e_wsfe();
+ if (t2 - t1 > 0.f) {
+ s_wsfe(&io___9);
+ r__1 = 1.f / (t2 - t1);
+ do_fio(&c__1, (char *)&r__1, (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ s_wsfe(&io___10);
+ e_wsfe();
+ }
+ tnosec = t2 - t1;
+
+/* Time 1,000,000 SAXPY operations with SECOND in the outer loop */
+
+ t1 = second_();
+ for (j = 1; j <= 5000; ++j) {
+ for (i__ = 1; i__ <= 100; ++i__) {
+ y[i__ - 1] += alpha * x[i__ - 1];
+/* L40: */
+ }
+ alpha = -alpha;
+ t2 = second_();
+/* L50: */
+ }
+
+/* Compute the time used in milliseconds used by an average call */
+/* to SECOND. */
+
+ s_wsfe(&io___12);
+ r__1 = t2 - t1;
+ do_fio(&c__1, (char *)&r__1, (ftnlen)sizeof(real));
+ e_wsfe();
+ avg = (t2 - t1 - tnosec) * 1e3f / 5e3f;
+ s_wsfe(&io___14);
+ do_fio(&c__1, (char *)&avg, (ftnlen)sizeof(real));
+ e_wsfe();
+
+/* Compute the equivalent number of floating point operations used */
+/* by an average call to SECOND. */
+
+ if (tnosec > 0.f) {
+ s_wsfe(&io___15);
+ r__1 = avg * 1e3f / tnosec;
+ do_fio(&c__1, (char *)&r__1, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+
+ mysub_(&c__100, x, y);
+ return 0;
+} /* MAIN__ */
+
+/* Subroutine */ int mysub_(integer *n, real *x, real *y)
+{
+ /* Parameter adjustments */
+ --y;
+ --x;
+
+ /* Function Body */
+ return 0;
+} /* mysub_ */
+
+/* Main program alias */ int test4_ () { MAIN__ (); return 0; }
diff --git a/INSTALL/slamch.c b/INSTALL/slamch.c
new file mode 100644
index 0000000..afd17fd
--- /dev/null
+++ b/INSTALL/slamch.c
@@ -0,0 +1,1000 @@
+/* slamch.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b32 = 0.f;
+
+doublereal slamch_(char *cmach)
+{
+ /* Initialized data */
+
+ static logical first = TRUE_;
+
+ /* System generated locals */
+ integer i__1;
+ real ret_val;
+
+ /* Builtin functions */
+ double pow_ri(real *, integer *);
+
+ /* Local variables */
+ static real t;
+ integer it;
+ static real rnd, eps, base;
+ integer beta;
+ static real emin, prec, emax;
+ integer imin, imax;
+ logical lrnd;
+ static real rmin, rmax;
+ real rmach;
+ extern logical lsame_(char *, char *);
+ real small;
+ static real sfmin;
+ extern /* Subroutine */ int slamc2_(integer *, integer *, logical *, real
+ *, integer *, real *, integer *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAMCH determines single precision machine parameters. */
+
+/* Arguments */
+/* ========= */
+
+/* CMACH (input) CHARACTER*1 */
+/* Specifies the value to be returned by SLAMCH: */
+/* = 'E' or 'e', SLAMCH := eps */
+/* = 'S' or 's , SLAMCH := sfmin */
+/* = 'B' or 'b', SLAMCH := base */
+/* = 'P' or 'p', SLAMCH := eps*base */
+/* = 'N' or 'n', SLAMCH := t */
+/* = 'R' or 'r', SLAMCH := rnd */
+/* = 'M' or 'm', SLAMCH := emin */
+/* = 'U' or 'u', SLAMCH := rmin */
+/* = 'L' or 'l', SLAMCH := emax */
+/* = 'O' or 'o', SLAMCH := rmax */
+
+/* where */
+
+/* eps = relative machine precision */
+/* sfmin = safe minimum, such that 1/sfmin does not overflow */
+/* base = base of the machine */
+/* prec = eps*base */
+/* t = number of (base) digits in the mantissa */
+/* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise */
+/* emin = minimum exponent before (gradual) underflow */
+/* rmin = underflow threshold - base**(emin-1) */
+/* emax = largest exponent before overflow */
+/* rmax = overflow threshold - (base**emax)*(1-eps) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (first) {
+ slamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax);
+ base = (real) beta;
+ t = (real) it;
+ if (lrnd) {
+ rnd = 1.f;
+ i__1 = 1 - it;
+ eps = pow_ri(&base, &i__1) / 2;
+ } else {
+ rnd = 0.f;
+ i__1 = 1 - it;
+ eps = pow_ri(&base, &i__1);
+ }
+ prec = eps * base;
+ emin = (real) imin;
+ emax = (real) imax;
+ sfmin = rmin;
+ small = 1.f / rmax;
+ if (small >= sfmin) {
+
+/* Use SMALL plus a bit, to avoid the possibility of rounding */
+/* causing overflow when computing 1/sfmin. */
+
+ sfmin = small * (eps + 1.f);
+ }
+ }
+
+ if (lsame_(cmach, "E")) {
+ rmach = eps;
+ } else if (lsame_(cmach, "S")) {
+ rmach = sfmin;
+ } else if (lsame_(cmach, "B")) {
+ rmach = base;
+ } else if (lsame_(cmach, "P")) {
+ rmach = prec;
+ } else if (lsame_(cmach, "N")) {
+ rmach = t;
+ } else if (lsame_(cmach, "R")) {
+ rmach = rnd;
+ } else if (lsame_(cmach, "M")) {
+ rmach = emin;
+ } else if (lsame_(cmach, "U")) {
+ rmach = rmin;
+ } else if (lsame_(cmach, "L")) {
+ rmach = emax;
+ } else if (lsame_(cmach, "O")) {
+ rmach = rmax;
+ }
+
+ ret_val = rmach;
+ first = FALSE_;
+ return ret_val;
+
+/* End of SLAMCH */
+
+} /* slamch_ */
+
+
+/* *********************************************************************** */
+
+/* Subroutine */ int slamc1_(integer *beta, integer *t, logical *rnd, logical
+ *ieee1)
+{
+ /* Initialized data */
+
+ static logical first = TRUE_;
+
+ /* System generated locals */
+ real r__1, r__2;
+
+ /* Local variables */
+ real a, b, c__, f, t1, t2;
+ static integer lt;
+ real one, qtr;
+ static logical lrnd;
+ static integer lbeta;
+ real savec;
+ static logical lieee1;
+ extern doublereal slamc3_(real *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAMC1 determines the machine parameters given by BETA, T, RND, and */
+/* IEEE1. */
+
+/* Arguments */
+/* ========= */
+
+/* BETA (output) INTEGER */
+/* The base of the machine. */
+
+/* T (output) INTEGER */
+/* The number of ( BETA ) digits in the mantissa. */
+
+/* RND (output) LOGICAL */
+/* Specifies whether proper rounding ( RND = .TRUE. ) or */
+/* chopping ( RND = .FALSE. ) occurs in addition. This may not */
+/* be a reliable guide to the way in which the machine performs */
+/* its arithmetic. */
+
+/* IEEE1 (output) LOGICAL */
+/* Specifies whether rounding appears to be done in the IEEE */
+/* 'round to nearest' style. */
+
+/* Further Details */
+/* =============== */
+
+/* The routine is based on the routine ENVRON by Malcolm and */
+/* incorporates suggestions by Gentleman and Marovich. See */
+
+/* Malcolm M. A. (1972) Algorithms to reveal properties of */
+/* floating-point arithmetic. Comms. of the ACM, 15, 949-951. */
+
+/* Gentleman W. M. and Marovich S. B. (1974) More on algorithms */
+/* that reveal properties of floating point arithmetic units. */
+/* Comms. of the ACM, 17, 276-277. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (first) {
+ one = 1.f;
+
+/* LBETA, LIEEE1, LT and LRND are the local values of BETA, */
+/* IEEE1, T and RND. */
+
+/* Throughout this routine we use the function SLAMC3 to ensure */
+/* that relevant values are stored and not held in registers, or */
+/* are not affected by optimizers. */
+
+/* Compute a = 2.0**m with the smallest positive integer m such */
+/* that */
+
+/* fl( a + 1.0 ) = a. */
+
+ a = 1.f;
+ c__ = 1.f;
+
+/* + WHILE( C.EQ.ONE )LOOP */
+L10:
+ if (c__ == one) {
+ a *= 2;
+ c__ = slamc3_(&a, &one);
+ r__1 = -a;
+ c__ = slamc3_(&c__, &r__1);
+ goto L10;
+ }
+/* + END WHILE */
+
+/* Now compute b = 2.0**m with the smallest positive integer m */
+/* such that */
+
+/* fl( a + b ) .gt. a. */
+
+ b = 1.f;
+ c__ = slamc3_(&a, &b);
+
+/* + WHILE( C.EQ.A )LOOP */
+L20:
+ if (c__ == a) {
+ b *= 2;
+ c__ = slamc3_(&a, &b);
+ goto L20;
+ }
+/* + END WHILE */
+
+/* Now compute the base. a and c are neighbouring floating point */
+/* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so */
+/* their difference is beta. Adding 0.25 to c is to ensure that it */
+/* is truncated to beta and not ( beta - 1 ). */
+
+ qtr = one / 4;
+ savec = c__;
+ r__1 = -a;
+ c__ = slamc3_(&c__, &r__1);
+ lbeta = c__ + qtr;
+
+/* Now determine whether rounding or chopping occurs, by adding a */
+/* bit less than beta/2 and a bit more than beta/2 to a. */
+
+ b = (real) lbeta;
+ r__1 = b / 2;
+ r__2 = -b / 100;
+ f = slamc3_(&r__1, &r__2);
+ c__ = slamc3_(&f, &a);
+ if (c__ == a) {
+ lrnd = TRUE_;
+ } else {
+ lrnd = FALSE_;
+ }
+ r__1 = b / 2;
+ r__2 = b / 100;
+ f = slamc3_(&r__1, &r__2);
+ c__ = slamc3_(&f, &a);
+ if (lrnd && c__ == a) {
+ lrnd = FALSE_;
+ }
+
+/* Try and decide whether rounding is done in the IEEE 'round to */
+/* nearest' style. B/2 is half a unit in the last place of the two */
+/* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit */
+/* zero, and SAVEC is odd. Thus adding B/2 to A should not change */
+/* A, but adding B/2 to SAVEC should change SAVEC. */
+
+ r__1 = b / 2;
+ t1 = slamc3_(&r__1, &a);
+ r__1 = b / 2;
+ t2 = slamc3_(&r__1, &savec);
+ lieee1 = t1 == a && t2 > savec && lrnd;
+
+/* Now find the mantissa, t. It should be the integer part of */
+/* log to the base beta of a, however it is safer to determine t */
+/* by powering. So we find t as the smallest positive integer for */
+/* which */
+
+/* fl( beta**t + 1.0 ) = 1.0. */
+
+ lt = 0;
+ a = 1.f;
+ c__ = 1.f;
+
+/* + WHILE( C.EQ.ONE )LOOP */
+L30:
+ if (c__ == one) {
+ ++lt;
+ a *= lbeta;
+ c__ = slamc3_(&a, &one);
+ r__1 = -a;
+ c__ = slamc3_(&c__, &r__1);
+ goto L30;
+ }
+/* + END WHILE */
+
+ }
+
+ *beta = lbeta;
+ *t = lt;
+ *rnd = lrnd;
+ *ieee1 = lieee1;
+ first = FALSE_;
+ return 0;
+
+/* End of SLAMC1 */
+
+} /* slamc1_ */
+
+
+/* *********************************************************************** */
+
+/* Subroutine */ int slamc2_(integer *beta, integer *t, logical *rnd, real *
+ eps, integer *emin, real *rmin, integer *emax, real *rmax)
+{
+ /* Initialized data */
+
+ static logical first = TRUE_;
+ static logical iwarn = FALSE_;
+
+ /* Format strings */
+ static char fmt_9999[] = "(//\002 WARNING. The value EMIN may be incorre"
+ "ct:-\002,\002 EMIN = \002,i8,/\002 If, after inspection, the va"
+ "lue EMIN looks\002,\002 acceptable please comment out \002,/\002"
+ " the IF block as marked within the code of routine\002,\002 SLAM"
+ "C2,\002,/\002 otherwise supply EMIN explicitly.\002,/)";
+
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2, r__3, r__4, r__5;
+
+ /* Builtin functions */
+ double pow_ri(real *, integer *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ real a, b, c__;
+ integer i__;
+ static integer lt;
+ real one, two;
+ logical ieee;
+ real half;
+ logical lrnd;
+ static real leps;
+ real zero;
+ static integer lbeta;
+ real rbase;
+ static integer lemin, lemax;
+ integer gnmin;
+ real small;
+ integer gpmin;
+ real third;
+ static real lrmin, lrmax;
+ real sixth;
+ logical lieee1;
+ extern /* Subroutine */ int slamc1_(integer *, integer *, logical *,
+ logical *);
+ extern doublereal slamc3_(real *, real *);
+ extern /* Subroutine */ int slamc4_(integer *, real *, integer *),
+ slamc5_(integer *, integer *, integer *, logical *, integer *,
+ real *);
+ integer ngnmin, ngpmin;
+
+ /* Fortran I/O blocks */
+ static cilist io___58 = { 0, 6, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAMC2 determines the machine parameters specified in its argument */
+/* list. */
+
+/* Arguments */
+/* ========= */
+
+/* BETA (output) INTEGER */
+/* The base of the machine. */
+
+/* T (output) INTEGER */
+/* The number of ( BETA ) digits in the mantissa. */
+
+/* RND (output) LOGICAL */
+/* Specifies whether proper rounding ( RND = .TRUE. ) or */
+/* chopping ( RND = .FALSE. ) occurs in addition. This may not */
+/* be a reliable guide to the way in which the machine performs */
+/* its arithmetic. */
+
+/* EPS (output) REAL */
+/* The smallest positive number such that */
+
+/* fl( 1.0 - EPS ) .LT. 1.0, */
+
+/* where fl denotes the computed value. */
+
+/* EMIN (output) INTEGER */
+/* The minimum exponent before (gradual) underflow occurs. */
+
+/* RMIN (output) REAL */
+/* The smallest normalized number for the machine, given by */
+/* BASE**( EMIN - 1 ), where BASE is the floating point value */
+/* of BETA. */
+
+/* EMAX (output) INTEGER */
+/* The maximum exponent before overflow occurs. */
+
+/* RMAX (output) REAL */
+/* The largest positive number for the machine, given by */
+/* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point */
+/* value of BETA. */
+
+/* Further Details */
+/* =============== */
+
+/* The computation of EPS is based on a routine PARANOIA by */
+/* W. Kahan of the University of California at Berkeley. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (first) {
+ zero = 0.f;
+ one = 1.f;
+ two = 2.f;
+
+/* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of */
+/* BETA, T, RND, EPS, EMIN and RMIN. */
+
+/* Throughout this routine we use the function SLAMC3 to ensure */
+/* that relevant values are stored and not held in registers, or */
+/* are not affected by optimizers. */
+
+/* SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. */
+
+ slamc1_(&lbeta, <, &lrnd, &lieee1);
+
+/* Start to find EPS. */
+
+ b = (real) lbeta;
+ i__1 = -lt;
+ a = pow_ri(&b, &i__1);
+ leps = a;
+
+/* Try some tricks to see whether or not this is the correct EPS. */
+
+ b = two / 3;
+ half = one / 2;
+ r__1 = -half;
+ sixth = slamc3_(&b, &r__1);
+ third = slamc3_(&sixth, &sixth);
+ r__1 = -half;
+ b = slamc3_(&third, &r__1);
+ b = slamc3_(&b, &sixth);
+ b = dabs(b);
+ if (b < leps) {
+ b = leps;
+ }
+
+ leps = 1.f;
+
+/* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */
+L10:
+ if (leps > b && b > zero) {
+ leps = b;
+ r__1 = half * leps;
+/* Computing 5th power */
+ r__3 = two, r__4 = r__3, r__3 *= r__3;
+/* Computing 2nd power */
+ r__5 = leps;
+ r__2 = r__4 * (r__3 * r__3) * (r__5 * r__5);
+ c__ = slamc3_(&r__1, &r__2);
+ r__1 = -c__;
+ c__ = slamc3_(&half, &r__1);
+ b = slamc3_(&half, &c__);
+ r__1 = -b;
+ c__ = slamc3_(&half, &r__1);
+ b = slamc3_(&half, &c__);
+ goto L10;
+ }
+/* + END WHILE */
+
+ if (a < leps) {
+ leps = a;
+ }
+
+/* Computation of EPS complete. */
+
+/* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). */
+/* Keep dividing A by BETA until (gradual) underflow occurs. This */
+/* is detected when we cannot recover the previous A. */
+
+ rbase = one / lbeta;
+ small = one;
+ for (i__ = 1; i__ <= 3; ++i__) {
+ r__1 = small * rbase;
+ small = slamc3_(&r__1, &zero);
+/* L20: */
+ }
+ a = slamc3_(&one, &small);
+ slamc4_(&ngpmin, &one, &lbeta);
+ r__1 = -one;
+ slamc4_(&ngnmin, &r__1, &lbeta);
+ slamc4_(&gpmin, &a, &lbeta);
+ r__1 = -a;
+ slamc4_(&gnmin, &r__1, &lbeta);
+ ieee = FALSE_;
+
+ if (ngpmin == ngnmin && gpmin == gnmin) {
+ if (ngpmin == gpmin) {
+ lemin = ngpmin;
+/* ( Non twos-complement machines, no gradual underflow; */
+/* e.g., VAX ) */
+ } else if (gpmin - ngpmin == 3) {
+ lemin = ngpmin - 1 + lt;
+ ieee = TRUE_;
+/* ( Non twos-complement machines, with gradual underflow; */
+/* e.g., IEEE standard followers ) */
+ } else {
+ lemin = min(ngpmin,gpmin);
+/* ( A guess; no known machine ) */
+ iwarn = TRUE_;
+ }
+
+ } else if (ngpmin == gpmin && ngnmin == gnmin) {
+ if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) {
+ lemin = max(ngpmin,ngnmin);
+/* ( Twos-complement machines, no gradual underflow; */
+/* e.g., CYBER 205 ) */
+ } else {
+ lemin = min(ngpmin,ngnmin);
+/* ( A guess; no known machine ) */
+ iwarn = TRUE_;
+ }
+
+ } else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin)
+ {
+ if (gpmin - min(ngpmin,ngnmin) == 3) {
+ lemin = max(ngpmin,ngnmin) - 1 + lt;
+/* ( Twos-complement machines with gradual underflow; */
+/* no known machine ) */
+ } else {
+ lemin = min(ngpmin,ngnmin);
+/* ( A guess; no known machine ) */
+ iwarn = TRUE_;
+ }
+
+ } else {
+/* Computing MIN */
+ i__1 = min(ngpmin,ngnmin), i__1 = min(i__1,gpmin);
+ lemin = min(i__1,gnmin);
+/* ( A guess; no known machine ) */
+ iwarn = TRUE_;
+ }
+ first = FALSE_;
+/* ** */
+/* Comment out this if block if EMIN is ok */
+ if (iwarn) {
+ first = TRUE_;
+ s_wsfe(&io___58);
+ do_fio(&c__1, (char *)&lemin, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* ** */
+
+/* Assume IEEE arithmetic if we found denormalised numbers above, */
+/* or if arithmetic seems to round in the IEEE style, determined */
+/* in routine SLAMC1. A true IEEE machine should have both things */
+/* true; however, faulty machines may have one or the other. */
+
+ ieee = ieee || lieee1;
+
+/* Compute RMIN by successive division by BETA. We could compute */
+/* RMIN as BASE**( EMIN - 1 ), but some machines underflow during */
+/* this computation. */
+
+ lrmin = 1.f;
+ i__1 = 1 - lemin;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__1 = lrmin * rbase;
+ lrmin = slamc3_(&r__1, &zero);
+/* L30: */
+ }
+
+/* Finally, call SLAMC5 to compute EMAX and RMAX. */
+
+ slamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax);
+ }
+
+ *beta = lbeta;
+ *t = lt;
+ *rnd = lrnd;
+ *eps = leps;
+ *emin = lemin;
+ *rmin = lrmin;
+ *emax = lemax;
+ *rmax = lrmax;
+
+ return 0;
+
+
+/* End of SLAMC2 */
+
+} /* slamc2_ */
+
+
+/* *********************************************************************** */
+
+doublereal slamc3_(real *a, real *b)
+{
+ /* System generated locals */
+ real ret_val;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAMC3 is intended to force A and B to be stored prior to doing */
+/* the addition of A and B , for use in situations where optimizers */
+/* might hold one of these in a register. */
+
+/* Arguments */
+/* ========= */
+
+/* A (input) REAL */
+/* B (input) REAL */
+/* The values A and B. */
+
+/* ===================================================================== */
+
+/* .. Executable Statements .. */
+
+ ret_val = *a + *b;
+
+ return ret_val;
+
+/* End of SLAMC3 */
+
+} /* slamc3_ */
+
+
+/* *********************************************************************** */
+
+/* Subroutine */ int slamc4_(integer *emin, real *start, integer *base)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1;
+
+ /* Local variables */
+ real a;
+ integer i__;
+ real b1, b2, c1, c2, d1, d2, one, zero, rbase;
+ extern doublereal slamc3_(real *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAMC4 is a service routine for SLAMC2. */
+
+/* Arguments */
+/* ========= */
+
+/* EMIN (output) INTEGER */
+/* The minimum exponent before (gradual) underflow, computed by */
+/* setting A = START and dividing by BASE until the previous A */
+/* can not be recovered. */
+
+/* START (input) REAL */
+/* The starting point for determining EMIN. */
+
+/* BASE (input) INTEGER */
+/* The base of the machine. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ a = *start;
+ one = 1.f;
+ rbase = one / *base;
+ zero = 0.f;
+ *emin = 1;
+ r__1 = a * rbase;
+ b1 = slamc3_(&r__1, &zero);
+ c1 = a;
+ c2 = a;
+ d1 = a;
+ d2 = a;
+/* + WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. */
+/* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP */
+L10:
+ if (c1 == a && c2 == a && d1 == a && d2 == a) {
+ --(*emin);
+ a = b1;
+ r__1 = a / *base;
+ b1 = slamc3_(&r__1, &zero);
+ r__1 = b1 * *base;
+ c1 = slamc3_(&r__1, &zero);
+ d1 = zero;
+ i__1 = *base;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d1 += b1;
+/* L20: */
+ }
+ r__1 = a * rbase;
+ b2 = slamc3_(&r__1, &zero);
+ r__1 = b2 / rbase;
+ c2 = slamc3_(&r__1, &zero);
+ d2 = zero;
+ i__1 = *base;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d2 += b2;
+/* L30: */
+ }
+ goto L10;
+ }
+/* + END WHILE */
+
+ return 0;
+
+/* End of SLAMC4 */
+
+} /* slamc4_ */
+
+
+/* *********************************************************************** */
+
+/* Subroutine */ int slamc5_(integer *beta, integer *p, integer *emin,
+ logical *ieee, integer *emax, real *rmax)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1;
+
+ /* Local variables */
+ integer i__;
+ real y, z__;
+ integer try__, lexp;
+ real oldy;
+ integer uexp, nbits;
+ extern doublereal slamc3_(real *, real *);
+ real recbas;
+ integer exbits, expsum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAMC5 attempts to compute RMAX, the largest machine floating-point */
+/* number, without overflow. It assumes that EMAX + abs(EMIN) sum */
+/* approximately to a power of 2. It will fail on machines where this */
+/* assumption does not hold, for example, the Cyber 205 (EMIN = -28625, */
+/* EMAX = 28718). It will also fail if the value supplied for EMIN is */
+/* too large (i.e. too close to zero), probably with overflow. */
+
+/* Arguments */
+/* ========= */
+
+/* BETA (input) INTEGER */
+/* The base of floating-point arithmetic. */
+
+/* P (input) INTEGER */
+/* The number of base BETA digits in the mantissa of a */
+/* floating-point value. */
+
+/* EMIN (input) INTEGER */
+/* The minimum exponent before (gradual) underflow. */
+
+/* IEEE (input) LOGICAL */
+/* A logical flag specifying whether or not the arithmetic */
+/* system is thought to comply with the IEEE standard. */
+
+/* EMAX (output) INTEGER */
+/* The largest exponent before overflow */
+
+/* RMAX (output) REAL */
+/* The largest machine floating-point number. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* First compute LEXP and UEXP, two powers of 2 that bound */
+/* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum */
+/* approximately to the bound that is closest to abs(EMIN). */
+/* (EMAX is the exponent of the required number RMAX). */
+
+ lexp = 1;
+ exbits = 1;
+L10:
+ try__ = lexp << 1;
+ if (try__ <= -(*emin)) {
+ lexp = try__;
+ ++exbits;
+ goto L10;
+ }
+ if (lexp == -(*emin)) {
+ uexp = lexp;
+ } else {
+ uexp = try__;
+ ++exbits;
+ }
+
+/* Now -LEXP is less than or equal to EMIN, and -UEXP is greater */
+/* than or equal to EMIN. EXBITS is the number of bits needed to */
+/* store the exponent. */
+
+ if (uexp + *emin > -lexp - *emin) {
+ expsum = lexp << 1;
+ } else {
+ expsum = uexp << 1;
+ }
+
+/* EXPSUM is the exponent range, approximately equal to */
+/* EMAX - EMIN + 1 . */
+
+ *emax = expsum + *emin - 1;
+ nbits = exbits + 1 + *p;
+
+/* NBITS is the total number of bits needed to store a */
+/* floating-point number. */
+
+ if (nbits % 2 == 1 && *beta == 2) {
+
+/* Either there are an odd number of bits used to store a */
+/* floating-point number, which is unlikely, or some bits are */
+/* not used in the representation of numbers, which is possible, */
+/* (e.g. Cray machines) or the mantissa has an implicit bit, */
+/* (e.g. IEEE machines, Dec Vax machines), which is perhaps the */
+/* most likely. We have to assume the last alternative. */
+/* If this is true, then we need to reduce EMAX by one because */
+/* there must be some way of representing zero in an implicit-bit */
+/* system. On machines like Cray, we are reducing EMAX by one */
+/* unnecessarily. */
+
+ --(*emax);
+ }
+
+ if (*ieee) {
+
+/* Assume we are on an IEEE machine which reserves one exponent */
+/* for infinity and NaN. */
+
+ --(*emax);
+ }
+
+/* Now create RMAX, the largest machine number, which should */
+/* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . */
+
+/* First compute 1.0 - BETA**(-P), being careful that the */
+/* result is less than 1.0 . */
+
+ recbas = 1.f / *beta;
+ z__ = *beta - 1.f;
+ y = 0.f;
+ i__1 = *p;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ z__ *= recbas;
+ if (y < 1.f) {
+ oldy = y;
+ }
+ y = slamc3_(&y, &z__);
+/* L20: */
+ }
+ if (y >= 1.f) {
+ y = oldy;
+ }
+
+/* Now multiply by BETA**EMAX to get RMAX. */
+
+ i__1 = *emax;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__1 = y * *beta;
+ y = slamc3_(&r__1, &c_b32);
+/* L30: */
+ }
+
+ *rmax = y;
+ return 0;
+
+/* End of SLAMC5 */
+
+} /* slamc5_ */
diff --git a/INSTALL/slamchtst.c b/INSTALL/slamchtst.c
new file mode 100644
index 0000000..e792e3f
--- /dev/null
+++ b/INSTALL/slamchtst.c
@@ -0,0 +1,120 @@
+/* slamchtst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__9 = 9;
+static integer c__1 = 1;
+static integer c__4 = 4;
+
+/* Main program */ int MAIN__(void)
+{
+ /* System generated locals */
+ real r__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_wsle(void);
+
+ /* Local variables */
+ real t, rnd, eps, base, emin, prec, emax, rmin, rmax, sfmin;
+ extern doublereal slamch_(char *);
+
+ /* Fortran I/O blocks */
+ static cilist io___11 = { 0, 6, 0, 0, 0 };
+ static cilist io___12 = { 0, 6, 0, 0, 0 };
+ static cilist io___13 = { 0, 6, 0, 0, 0 };
+ static cilist io___14 = { 0, 6, 0, 0, 0 };
+ static cilist io___15 = { 0, 6, 0, 0, 0 };
+ static cilist io___16 = { 0, 6, 0, 0, 0 };
+ static cilist io___17 = { 0, 6, 0, 0, 0 };
+ static cilist io___18 = { 0, 6, 0, 0, 0 };
+ static cilist io___19 = { 0, 6, 0, 0, 0 };
+ static cilist io___20 = { 0, 6, 0, 0, 0 };
+ static cilist io___21 = { 0, 6, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = slamch_("Epsilon");
+ sfmin = slamch_("Safe minimum");
+ base = slamch_("Base");
+ prec = slamch_("Precision");
+ t = slamch_("Number of digits in mantissa");
+ rnd = slamch_("Rounding mode");
+ emin = slamch_("Minimum exponent");
+ rmin = slamch_("Underflow threshold");
+ emax = slamch_("Largest exponent");
+ rmax = slamch_("Overflow threshold");
+
+ s_wsle(&io___11);
+ do_lio(&c__9, &c__1, " Epsilon = ", (ftnlen)32);
+ do_lio(&c__4, &c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsle();
+ s_wsle(&io___12);
+ do_lio(&c__9, &c__1, " Safe minimum = ", (ftnlen)32);
+ do_lio(&c__4, &c__1, (char *)&sfmin, (ftnlen)sizeof(real));
+ e_wsle();
+ s_wsle(&io___13);
+ do_lio(&c__9, &c__1, " Base = ", (ftnlen)32);
+ do_lio(&c__4, &c__1, (char *)&base, (ftnlen)sizeof(real));
+ e_wsle();
+ s_wsle(&io___14);
+ do_lio(&c__9, &c__1, " Precision = ", (ftnlen)32);
+ do_lio(&c__4, &c__1, (char *)&prec, (ftnlen)sizeof(real));
+ e_wsle();
+ s_wsle(&io___15);
+ do_lio(&c__9, &c__1, " Number of digits in mantissa = ", (ftnlen)32);
+ do_lio(&c__4, &c__1, (char *)&t, (ftnlen)sizeof(real));
+ e_wsle();
+ s_wsle(&io___16);
+ do_lio(&c__9, &c__1, " Rounding mode = ", (ftnlen)32);
+ do_lio(&c__4, &c__1, (char *)&rnd, (ftnlen)sizeof(real));
+ e_wsle();
+ s_wsle(&io___17);
+ do_lio(&c__9, &c__1, " Minimum exponent = ", (ftnlen)32);
+ do_lio(&c__4, &c__1, (char *)&emin, (ftnlen)sizeof(real));
+ e_wsle();
+ s_wsle(&io___18);
+ do_lio(&c__9, &c__1, " Underflow threshold = ", (ftnlen)32);
+ do_lio(&c__4, &c__1, (char *)&rmin, (ftnlen)sizeof(real));
+ e_wsle();
+ s_wsle(&io___19);
+ do_lio(&c__9, &c__1, " Largest exponent = ", (ftnlen)32);
+ do_lio(&c__4, &c__1, (char *)&emax, (ftnlen)sizeof(real));
+ e_wsle();
+ s_wsle(&io___20);
+ do_lio(&c__9, &c__1, " Overflow threshold = ", (ftnlen)32);
+ do_lio(&c__4, &c__1, (char *)&rmax, (ftnlen)sizeof(real));
+ e_wsle();
+ s_wsle(&io___21);
+ do_lio(&c__9, &c__1, " Reciprocal of safe minimum = ", (ftnlen)32);
+ r__1 = 1 / sfmin;
+ do_lio(&c__4, &c__1, (char *)&r__1, (ftnlen)sizeof(real));
+ e_wsle();
+
+ return 0;
+} /* MAIN__ */
+
+/* Main program alias */ int test2_ () { MAIN__ (); return 0; }
diff --git a/INSTALL/tstiee.c b/INSTALL/tstiee.c
new file mode 100644
index 0000000..2b5426f
--- /dev/null
+++ b/INSTALL/tstiee.c
@@ -0,0 +1,893 @@
+/* tstiee.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+#include "string.h"
+
+/* Table of constant values */
+
+static integer c__9 = 9;
+static integer c__1 = 1;
+static integer c__10 = 10;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static integer c__11 = 11;
+static integer c__0 = 0;
+static real c_b227 = 0.f;
+static real c_b228 = 1.f;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_wsle(void);
+
+ /* Local variables */
+ integer ieeeok;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 6, 0, 0, 0 };
+ static cilist io___2 = { 0, 6, 0, 0, 0 };
+ static cilist io___3 = { 0, 6, 0, 0, 0 };
+ static cilist io___5 = { 0, 6, 0, 0, 0 };
+ static cilist io___6 = { 0, 6, 0, 0, 0 };
+ static cilist io___7 = { 0, 6, 0, 0, 0 };
+ static cilist io___8 = { 0, 6, 0, 0, 0 };
+ static cilist io___9 = { 0, 6, 0, 0, 0 };
+ static cilist io___10 = { 0, 6, 0, 0, 0 };
+ static cilist io___11 = { 0, 6, 0, 0, 0 };
+ static cilist io___12 = { 0, 6, 0, 0, 0 };
+ static cilist io___13 = { 0, 6, 0, 0, 0 };
+ static cilist io___14 = { 0, 6, 0, 0, 0 };
+ static cilist io___15 = { 0, 6, 0, 0, 0 };
+ static cilist io___16 = { 0, 6, 0, 0, 0 };
+ static cilist io___17 = { 0, 6, 0, 0, 0 };
+ static cilist io___18 = { 0, 6, 0, 0, 0 };
+ static cilist io___19 = { 0, 6, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. External Functions .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_wsle(&io___1);
+ do_lio(&c__9, &c__1, "We are about to check whether infinity arithmetic",
+ (ftnlen)49);
+ e_wsle();
+ s_wsle(&io___2);
+ do_lio(&c__9, &c__1, "can be trusted. If this test hangs, set", (ftnlen)
+ 40);
+ e_wsle();
+ s_wsle(&io___3);
+ do_lio(&c__9, &c__1, "ILAENV = 0 for ISPEC = 10 in LAPACK/SRC/ilaenv.f", (
+ ftnlen)48);
+ e_wsle();
+
+ ieeeok = ilaenv_(&c__10, "ILAENV", "N", &c__1, &c__2, &c__3, &c__4);
+ s_wsle(&io___5);
+ e_wsle();
+
+ if (ieeeok == 0) {
+ s_wsle(&io___6);
+ do_lio(&c__9, &c__1, "Infinity arithmetic did not perform per the ie"
+ "ee spec", (ftnlen)53);
+ e_wsle();
+ } else {
+ s_wsle(&io___7);
+ do_lio(&c__9, &c__1, "Infinity arithmetic performed as per the ieee "
+ "spec.", (ftnlen)51);
+ e_wsle();
+ s_wsle(&io___8);
+ do_lio(&c__9, &c__1, "However, this is not an exhaustive test and do"
+ "es not", (ftnlen)52);
+ e_wsle();
+ s_wsle(&io___9);
+ do_lio(&c__9, &c__1, "guarantee that infinity arithmetic meets the", (
+ ftnlen)44);
+ do_lio(&c__9, &c__1, " ieee spec.", (ftnlen)11);
+ e_wsle();
+ }
+
+ s_wsle(&io___10);
+ e_wsle();
+ s_wsle(&io___11);
+ do_lio(&c__9, &c__1, "We are about to check whether NaN arithmetic", (
+ ftnlen)44);
+ e_wsle();
+ s_wsle(&io___12);
+ do_lio(&c__9, &c__1, "can be trusted. If this test hangs, set", (ftnlen)
+ 40);
+ e_wsle();
+ s_wsle(&io___13);
+ do_lio(&c__9, &c__1, "ILAENV = 0 for ISPEC = 11 in LAPACK/SRC/ilaenv.f", (
+ ftnlen)48);
+ e_wsle();
+ ieeeok = ilaenv_(&c__11, "ILAENV", "N", &c__1, &c__2, &c__3, &c__4);
+
+ s_wsle(&io___14);
+ e_wsle();
+ if (ieeeok == 0) {
+ s_wsle(&io___15);
+ do_lio(&c__9, &c__1, "NaN arithmetic did not perform per the ieee sp"
+ "ec", (ftnlen)48);
+ e_wsle();
+ } else {
+ s_wsle(&io___16);
+ do_lio(&c__9, &c__1, "NaN arithmetic performed as per the ieee", (
+ ftnlen)40);
+ do_lio(&c__9, &c__1, " spec.", (ftnlen)6);
+ e_wsle();
+ s_wsle(&io___17);
+ do_lio(&c__9, &c__1, "However, this is not an exhaustive test and do"
+ "es not", (ftnlen)52);
+ e_wsle();
+ s_wsle(&io___18);
+ do_lio(&c__9, &c__1, "guarantee that NaN arithmetic meets the", (
+ ftnlen)39);
+ do_lio(&c__9, &c__1, " ieee spec.", (ftnlen)11);
+ e_wsle();
+ }
+ s_wsle(&io___19);
+ e_wsle();
+
+ return 0;
+} /* MAIN__ */
+
+integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1,
+ integer *n2, integer *n3, integer *n4)
+{
+ /* System generated locals */
+ integer ret_val;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ char c1[1], c2[2], c3[3], c4[2];
+ integer ic, nb, iz, nx;
+ logical cname, sname;
+ integer nbmin;
+ extern integer ieeeck_(integer *, real *, real *);
+ char subnam[6];
+ ftnlen name_len;
+ name_len = strlen (name__);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ILAENV is called from the LAPACK routines to choose problem-dependent */
+/* parameters for the local environment. See ISPEC for a description of */
+/* the parameters. */
+
+/* This version provides a set of parameters which should give good, */
+/* but not optimal, performance on many of the currently available */
+/* computers. Users are encouraged to modify this subroutine to set */
+/* the tuning parameters for their particular machine using the option */
+/* and problem size information in the arguments. */
+
+/* This routine will not function correctly if it is converted to all */
+/* lower case. Converting it to all upper case is allowed. */
+
+/* Arguments */
+/* ========= */
+
+/* ISPEC (input) INTEGER */
+/* Specifies the parameter to be returned as the value of */
+/* ILAENV. */
+/* = 1: the optimal blocksize; if this value is 1, an unblocked */
+/* algorithm will give the best performance. */
+/* = 2: the minimum block size for which the block routine */
+/* should be used; if the usable block size is less than */
+/* this value, an unblocked routine should be used. */
+/* = 3: the crossover point (in a block routine, for N less */
+/* than this value, an unblocked routine should be used) */
+/* = 4: the number of shifts, used in the nonsymmetric */
+/* eigenvalue routines */
+/* = 5: the minimum column dimension for blocking to be used; */
+/* rectangular blocks must have dimension at least k by m, */
+/* where k is given by ILAENV(2,...) and m by ILAENV(5,...) */
+/* = 6: the crossover point for the SVD (when reducing an m by n */
+/* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds */
+/* this value, a QR factorization is used first to reduce */
+/* the matrix to a triangular form.) */
+/* = 7: the number of processors */
+/* = 8: the crossover point for the multishift QR and QZ methods */
+/* for nonsymmetric eigenvalue problems. */
+/* = 9: maximum size of the subproblems at the bottom of the */
+/* computation tree in the divide-and-conquer algorithm */
+/* (used by xGELSD and xGESDD) */
+/* =10: ieee NaN arithmetic can be trusted not to trap */
+/* =11: infinity arithmetic can be trusted not to trap */
+
+/* NAME (input) CHARACTER*(*) */
+/* The name of the calling subroutine, in either upper case or */
+/* lower case. */
+
+/* OPTS (input) CHARACTER*(*) */
+/* The character options to the subroutine NAME, concatenated */
+/* into a single character string. For example, UPLO = 'U', */
+/* TRANS = 'T', and DIAG = 'N' for a triangular routine would */
+/* be specified as OPTS = 'UTN'. */
+
+/* N1 (input) INTEGER */
+/* N2 (input) INTEGER */
+/* N3 (input) INTEGER */
+/* N4 (input) INTEGER */
+/* Problem dimensions for the subroutine NAME; these may not all */
+/* be required. */
+
+/* (ILAENV) (output) INTEGER */
+/* >= 0: the value of the parameter specified by ISPEC */
+/* < 0: if ILAENV = -k, the k-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The following conventions have been used when calling ILAENV from the */
+/* LAPACK routines: */
+/* 1) OPTS is a concatenation of all of the character options to */
+/* subroutine NAME, in the same order that they appear in the */
+/* argument list for NAME, even if they are not used in determining */
+/* the value of the parameter specified by ISPEC. */
+/* 2) The problem dimensions N1, N2, N3, N4 are specified in the order */
+/* that they appear in the argument list for NAME. N1 is used */
+/* first, N2 second, and so on, and unused problem dimensions are */
+/* passed a value of -1. */
+/* 3) The parameter value returned by ILAENV is checked for validity in */
+/* the calling subroutine. For example, ILAENV is used to retrieve */
+/* the optimal blocksize for STRTRI as follows: */
+
+/* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) */
+/* IF( NB.LE.1 ) NB = MAX( 1, N ) */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ switch (*ispec) {
+ case 1: goto L100;
+ case 2: goto L100;
+ case 3: goto L100;
+ case 4: goto L400;
+ case 5: goto L500;
+ case 6: goto L600;
+ case 7: goto L700;
+ case 8: goto L800;
+ case 9: goto L900;
+ case 10: goto L1000;
+ case 11: goto L1100;
+ }
+
+/* Invalid value for ISPEC */
+
+ ret_val = -1;
+ return ret_val;
+
+L100:
+
+/* Convert NAME to upper case if the first character is lower case. */
+
+ ret_val = 1;
+ s_copy(subnam, name__, (ftnlen)6, name_len);
+ ic = *(unsigned char *)subnam;
+ iz = 'Z';
+ if (iz == 90 || iz == 122) {
+
+/* ASCII character set */
+
+ if (ic >= 97 && ic <= 122) {
+ *(unsigned char *)subnam = (char) (ic - 32);
+ for (i__ = 2; i__ <= 6; ++i__) {
+ ic = *(unsigned char *)&subnam[i__ - 1];
+ if (ic >= 97 && ic <= 122) {
+ *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32);
+ }
+/* L10: */
+ }
+ }
+
+ } else if (iz == 233 || iz == 169) {
+
+/* EBCDIC character set */
+
+ if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 &&
+ ic <= 169) {
+ *(unsigned char *)subnam = (char) (ic + 64);
+ for (i__ = 2; i__ <= 6; ++i__) {
+ ic = *(unsigned char *)&subnam[i__ - 1];
+ if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >=
+ 162 && ic <= 169) {
+ *(unsigned char *)&subnam[i__ - 1] = (char) (ic + 64);
+ }
+/* L20: */
+ }
+ }
+
+ } else if (iz == 218 || iz == 250) {
+
+/* Prime machines: ASCII+128 */
+
+ if (ic >= 225 && ic <= 250) {
+ *(unsigned char *)subnam = (char) (ic - 32);
+ for (i__ = 2; i__ <= 6; ++i__) {
+ ic = *(unsigned char *)&subnam[i__ - 1];
+ if (ic >= 225 && ic <= 250) {
+ *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32);
+ }
+/* L30: */
+ }
+ }
+ }
+
+ *(unsigned char *)c1 = *(unsigned char *)subnam;
+ sname = *(unsigned char *)c1 == 'S' || *(unsigned char *)c1 == 'D';
+ cname = *(unsigned char *)c1 == 'C' || *(unsigned char *)c1 == 'Z';
+ if (! (cname || sname)) {
+ return ret_val;
+ }
+ s_copy(c2, subnam + 1, (ftnlen)2, (ftnlen)2);
+ s_copy(c3, subnam + 3, (ftnlen)3, (ftnlen)3);
+ s_copy(c4, c3 + 1, (ftnlen)2, (ftnlen)2);
+
+ switch (*ispec) {
+ case 1: goto L110;
+ case 2: goto L200;
+ case 3: goto L300;
+ }
+
+L110:
+
+/* ISPEC = 1: block size */
+
+/* In these examples, separate code is provided for setting NB for */
+/* real and complex. We assume that NB will take the same value in */
+/* single or double precision. */
+
+ nb = 1;
+
+ if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
+ if (sname) {
+ nb = 64;
+ } else {
+ nb = 64;
+ }
+ } else if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3,
+ "RQF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)
+ 3, (ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3)
+ == 0) {
+ if (sname) {
+ nb = 32;
+ } else {
+ nb = 32;
+ }
+ } else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) {
+ if (sname) {
+ nb = 32;
+ } else {
+ nb = 32;
+ }
+ } else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) {
+ if (sname) {
+ nb = 32;
+ } else {
+ nb = 32;
+ }
+ } else if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) {
+ if (sname) {
+ nb = 64;
+ } else {
+ nb = 64;
+ }
+ }
+ } else if (s_cmp(c2, "PO", (ftnlen)2, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
+ if (sname) {
+ nb = 64;
+ } else {
+ nb = 64;
+ }
+ }
+ } else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
+ if (sname) {
+ nb = 64;
+ } else {
+ nb = 64;
+ }
+ } else if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
+ nb = 32;
+ } else if (sname && s_cmp(c3, "GST", (ftnlen)3, (ftnlen)3) == 0) {
+ nb = 64;
+ }
+ } else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
+ nb = 64;
+ } else if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
+ nb = 32;
+ } else if (s_cmp(c3, "GST", (ftnlen)3, (ftnlen)3) == 0) {
+ nb = 64;
+ }
+ } else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) {
+ if (*(unsigned char *)c3 == 'G') {
+ if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
+ (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
+ ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
+ 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
+ c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+ ftnlen)2, (ftnlen)2) == 0) {
+ nb = 32;
+ }
+ } else if (*(unsigned char *)c3 == 'M') {
+ if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
+ (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
+ ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
+ 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
+ c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+ ftnlen)2, (ftnlen)2) == 0) {
+ nb = 32;
+ }
+ }
+ } else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) {
+ if (*(unsigned char *)c3 == 'G') {
+ if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
+ (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
+ ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
+ 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
+ c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+ ftnlen)2, (ftnlen)2) == 0) {
+ nb = 32;
+ }
+ } else if (*(unsigned char *)c3 == 'M') {
+ if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
+ (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
+ ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
+ 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
+ c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+ ftnlen)2, (ftnlen)2) == 0) {
+ nb = 32;
+ }
+ }
+ } else if (s_cmp(c2, "GB", (ftnlen)2, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
+ if (sname) {
+ if (*n4 <= 64) {
+ nb = 1;
+ } else {
+ nb = 32;
+ }
+ } else {
+ if (*n4 <= 64) {
+ nb = 1;
+ } else {
+ nb = 32;
+ }
+ }
+ }
+ } else if (s_cmp(c2, "PB", (ftnlen)2, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
+ if (sname) {
+ if (*n2 <= 64) {
+ nb = 1;
+ } else {
+ nb = 32;
+ }
+ } else {
+ if (*n2 <= 64) {
+ nb = 1;
+ } else {
+ nb = 32;
+ }
+ }
+ }
+ } else if (s_cmp(c2, "TR", (ftnlen)2, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) {
+ if (sname) {
+ nb = 64;
+ } else {
+ nb = 64;
+ }
+ }
+ } else if (s_cmp(c2, "LA", (ftnlen)2, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "UUM", (ftnlen)3, (ftnlen)3) == 0) {
+ if (sname) {
+ nb = 64;
+ } else {
+ nb = 64;
+ }
+ }
+ } else if (sname && s_cmp(c2, "ST", (ftnlen)2, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "EBZ", (ftnlen)3, (ftnlen)3) == 0) {
+ nb = 1;
+ }
+ }
+ ret_val = nb;
+ return ret_val;
+
+L200:
+
+/* ISPEC = 2: minimum block size */
+
+ nbmin = 2;
+ if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "RQF", (
+ ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)3, (
+ ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3) == 0)
+ {
+ if (sname) {
+ nbmin = 2;
+ } else {
+ nbmin = 2;
+ }
+ } else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) {
+ if (sname) {
+ nbmin = 2;
+ } else {
+ nbmin = 2;
+ }
+ } else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) {
+ if (sname) {
+ nbmin = 2;
+ } else {
+ nbmin = 2;
+ }
+ } else if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) {
+ if (sname) {
+ nbmin = 2;
+ } else {
+ nbmin = 2;
+ }
+ }
+ } else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
+ if (sname) {
+ nbmin = 8;
+ } else {
+ nbmin = 8;
+ }
+ } else if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
+ nbmin = 2;
+ }
+ } else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
+ nbmin = 2;
+ }
+ } else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) {
+ if (*(unsigned char *)c3 == 'G') {
+ if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
+ (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
+ ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
+ 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
+ c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+ ftnlen)2, (ftnlen)2) == 0) {
+ nbmin = 2;
+ }
+ } else if (*(unsigned char *)c3 == 'M') {
+ if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
+ (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
+ ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
+ 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
+ c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+ ftnlen)2, (ftnlen)2) == 0) {
+ nbmin = 2;
+ }
+ }
+ } else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) {
+ if (*(unsigned char *)c3 == 'G') {
+ if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
+ (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
+ ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
+ 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
+ c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+ ftnlen)2, (ftnlen)2) == 0) {
+ nbmin = 2;
+ }
+ } else if (*(unsigned char *)c3 == 'M') {
+ if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
+ (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
+ ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
+ 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
+ c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+ ftnlen)2, (ftnlen)2) == 0) {
+ nbmin = 2;
+ }
+ }
+ }
+ ret_val = nbmin;
+ return ret_val;
+
+L300:
+
+/* ISPEC = 3: crossover point */
+
+ nx = 0;
+ if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "RQF", (
+ ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)3, (
+ ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3) == 0)
+ {
+ if (sname) {
+ nx = 128;
+ } else {
+ nx = 128;
+ }
+ } else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) {
+ if (sname) {
+ nx = 128;
+ } else {
+ nx = 128;
+ }
+ } else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) {
+ if (sname) {
+ nx = 128;
+ } else {
+ nx = 128;
+ }
+ }
+ } else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) {
+ if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
+ nx = 32;
+ }
+ } else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
+ nx = 32;
+ }
+ } else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) {
+ if (*(unsigned char *)c3 == 'G') {
+ if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
+ (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
+ ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
+ 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
+ c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+ ftnlen)2, (ftnlen)2) == 0) {
+ nx = 128;
+ }
+ }
+ } else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) {
+ if (*(unsigned char *)c3 == 'G') {
+ if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
+ (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
+ ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
+ 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
+ c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+ ftnlen)2, (ftnlen)2) == 0) {
+ nx = 128;
+ }
+ }
+ }
+ ret_val = nx;
+ return ret_val;
+
+L400:
+
+/* ISPEC = 4: number of shifts (used by xHSEQR) */
+
+ ret_val = 6;
+ return ret_val;
+
+L500:
+
+/* ISPEC = 5: minimum column dimension (not used) */
+
+ ret_val = 2;
+ return ret_val;
+
+L600:
+
+/* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) */
+
+ ret_val = (integer) ((real) min(*n1,*n2) * 1.6f);
+ return ret_val;
+
+L700:
+
+/* ISPEC = 7: number of processors (not used) */
+
+ ret_val = 1;
+ return ret_val;
+
+L800:
+
+/* ISPEC = 8: crossover point for multishift (used by xHSEQR) */
+
+ ret_val = 50;
+ return ret_val;
+
+L900:
+
+/* ISPEC = 9: maximum size of the subproblems at the bottom of the */
+/* computation tree in the divide-and-conquer algorithm */
+/* (used by xGELSD and xGESDD) */
+
+ ret_val = 25;
+ return ret_val;
+
+L1000:
+
+/* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap */
+
+ ret_val = 1;
+ if (ret_val == 1) {
+ ret_val = ieeeck_(&c__0, &c_b227, &c_b228);
+ }
+ return ret_val;
+
+L1100:
+
+/* ISPEC = 11: infinity arithmetic can be trusted not to trap */
+
+ ret_val = 1;
+ if (ret_val == 1) {
+ ret_val = ieeeck_(&c__1, &c_b227, &c_b228);
+ }
+ return ret_val;
+
+/* End of ILAENV */
+
+} /* ilaenv_ */
+
+integer ieeeck_(integer *ispec, real *zero, real *one)
+{
+ /* System generated locals */
+ integer ret_val;
+
+ /* Local variables */
+ real nan1, nan2, nan3, nan4, nan5, nan6, neginf, posinf, negzro, newzro;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* IEEECK is called from the ILAENV to verify that Inifinity and */
+/* possibly NaN arithmetic is safe (i.e. will not trap). */
+
+/* Arguments */
+/* ========= */
+
+/* ISPEC (input) INTEGER */
+/* Specifies whether to test just for inifinity arithmetic */
+/* or whether to test for infinity and NaN arithmetic. */
+/* = 0: Verify infinity arithmetic only. */
+/* = 1: Verify infinity and NaN arithmetic. */
+
+/* ZERO (input) REAL */
+/* Must contain the value 0.0 */
+/* This is passed to prevent the compiler from optimizing */
+/* away this code. */
+
+/* ONE (input) REAL */
+/* Must contain the value 1.0 */
+/* This is passed to prevent the compiler from optimizing */
+/* away this code. */
+
+/* RETURN VALUE: INTEGER */
+/* = 0: Arithmetic failed to produce the correct answers */
+/* = 1: Arithmetic produced the correct answers */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+ ret_val = 1;
+ posinf = *one / *zero;
+ if (posinf <= *one) {
+ ret_val = 0;
+ return ret_val;
+ }
+ neginf = -(*one) / *zero;
+ if (neginf >= *zero) {
+ ret_val = 0;
+ return ret_val;
+ }
+ negzro = *one / (neginf + *one);
+ if (negzro != *zero) {
+ ret_val = 0;
+ return ret_val;
+ }
+ neginf = *one / negzro;
+ if (neginf >= *zero) {
+ ret_val = 0;
+ return ret_val;
+ }
+ newzro = negzro + *zero;
+ if (newzro != *zero) {
+ ret_val = 0;
+ return ret_val;
+ }
+ posinf = *one / newzro;
+ if (posinf <= *one) {
+ ret_val = 0;
+ return ret_val;
+ }
+ neginf *= posinf;
+ if (neginf >= *zero) {
+ ret_val = 0;
+ return ret_val;
+ }
+ posinf *= posinf;
+ if (posinf <= *one) {
+ ret_val = 0;
+ return ret_val;
+ }
+
+/* Return if we were only asked to check infinity arithmetic */
+
+ if (*ispec == 0) {
+ return ret_val;
+ }
+ nan1 = posinf + neginf;
+ nan2 = posinf / neginf;
+ nan3 = posinf / posinf;
+ nan4 = posinf * *zero;
+ nan5 = neginf * negzro;
+ nan6 = nan5 * 0.f;
+ if (nan1 == nan1) {
+ ret_val = 0;
+ return ret_val;
+ }
+ if (nan2 == nan2) {
+ ret_val = 0;
+ return ret_val;
+ }
+ if (nan3 == nan3) {
+ ret_val = 0;
+ return ret_val;
+ }
+ if (nan4 == nan4) {
+ ret_val = 0;
+ return ret_val;
+ }
+ if (nan5 == nan5) {
+ ret_val = 0;
+ return ret_val;
+ }
+ if (nan6 == nan6) {
+ ret_val = 0;
+ return ret_val;
+ }
+ return ret_val;
+} /* ieeeck_ */
+
+/* Main program alias */ int main_ () { MAIN__ (); return 0; }
diff --git a/INSTALL/windsecnd.c b/INSTALL/windsecnd.c
new file mode 100644
index 0000000..3b52282
--- /dev/null
+++ b/INSTALL/windsecnd.c
@@ -0,0 +1,27 @@
+/* rbd 14-Dec-99 for Win32 */
+#include "f2c.h"
+#if !defined _WIN32
+#include <sys/times.h>
+#endif
+#include <sys/types.h>
+#include <time.h>
+
+#ifndef CLK_TCK
+#define CLK_TCK 60
+#endif
+
+doublereal dsecnd_()
+{
+#if defined _WIN32
+ clock_t rusage;
+
+ rusage = clock();
+ return (doublereal)(rusage) / CLOCKS_PER_SEC;
+#else
+ struct tms rusage;
+
+ times(&rusage);
+ return (doublereal)(rusage.tms_utime) / CLK_TCK;
+#endif
+} /* dsecnd_ */
+
diff --git a/INSTALL/winsecond.c b/INSTALL/winsecond.c
new file mode 100644
index 0000000..5acde43
--- /dev/null
+++ b/INSTALL/winsecond.c
@@ -0,0 +1,27 @@
+/* rbd 14-Dec-99 for Win32 */
+#include "f2c.h"
+#if !defined _WIN32
+#include <sys/times.h>
+#endif
+#include <sys/types.h>
+#include <time.h>
+
+#ifndef CLK_TCK
+#define CLK_TCK 60
+#endif
+
+doublereal second_()
+{
+#if defined _WIN32
+ clock_t rusage;
+
+ rusage = clock();
+ return (doublereal)(rusage) / CLOCKS_PER_SEC;
+#else
+ struct tms rusage;
+
+ times(&rusage);
+ return (doublereal)(rusage.tms_utime) / CLK_TCK;
+#endif
+} /* second_ */
+
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..36c6a0d
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,93 @@
+#
+# Top Level Makefile for LAPACK
+# Version 3.2.1
+# June 2009
+#
+
+include make.inc
+
+all: f2clib lapack_install lib lapack_testing blas_testing
+#all: f2clib lapack_install lib lapack_testing blas_testing variants_testing
+
+#lib: lapacklib tmglib
+#lib: f2clib lapacklib tmglib
+lib: f2clib blaslib variants lapacklib tmglib
+
+clean: cleanlib cleantesting cleanblas_testing
+
+lapack_install:
+ ( cd INSTALL; $(MAKE); ./testlsame; ./testslamch; \
+ ./testdlamch; ./testsecond; ./testdsecnd; ./testversion )
+
+blaslib:
+ ( cd BLAS/SRC; $(MAKE) )
+
+lapacklib: lapack_install
+ ( cd SRC; $(MAKE) )
+
+variants:
+ ( cd SRC/VARIANTS ; $(MAKE))
+
+tmglib:
+ ( cd TESTING/MATGEN; $(MAKE) )
+
+f2clib:
+ ( cd F2CLIBS/libf2c; $(MAKE) )
+
+lapack_testing: lib
+ ( cd TESTING ; $(MAKE) )
+
+variants_testing: lib
+ ( cd TESTING ; rm -f xlintst* ; $(MAKE) VARLIB='SRC/VARIANTS/LIB/cholrl.a' ; \
+ mv stest.out stest_cholrl.out ; mv dtest.out dtest_cholrl.out ; mv ctest.out ctest_cholrl.out ; mv ztest.out ztest_cholrl.out )
+ ( cd TESTING ; rm -f xlintst* ; $(MAKE) VARLIB='SRC/VARIANTS/LIB/choltop.a' ; \
+ mv stest.out stest_choltop.out ; mv dtest.out dtest_choltop.out ; mv ctest.out ctest_choltop.out ; mv ztest.out ztest_choltop.out )
+ ( cd TESTING ; rm -f xlintst* ; $(MAKE) VARLIB='SRC/VARIANTS/LIB/lucr.a' ; \
+ mv stest.out stest_lucr.out ; mv dtest.out dtest_lucr.out ; mv ctest.out ctest_lucr.out ; mv ztest.out ztest_lucr.out )
+ ( cd TESTING ; rm -f xlintst* ; $(MAKE) VARLIB='SRC/VARIANTS/LIB/lull.a' ; \
+ mv stest.out stest_lull.out ; mv dtest.out dtest_lull.out ; mv ctest.out ctest_lull.out ; mv ztest.out ztest_lull.out )
+ ( cd TESTING ; rm -f xlintst* ; $(MAKE) VARLIB='SRC/VARIANTS/LIB/lurec.a' ; \
+ mv stest.out stest_lurec.out ; mv dtest.out dtest_lurec.out ; mv ctest.out ctest_lurec.out ; mv ztest.out ztest_lurec.out )
+ ( cd TESTING ; rm -f xlintst* ; $(MAKE) VARLIB='SRC/VARIANTS/LIB/qrll.a' ; \
+ mv stest.out stest_qrll.out ; mv dtest.out dtest_qrll.out ; mv ctest.out ctest_qrll.out ; mv ztest.out ztest_qrll.out )
+
+blas_testing:
+ ( cd BLAS/TESTING; $(MAKE) -f Makeblat1 )
+ ( cd BLAS; ./xblat1s > sblat1.out ; \
+ ./xblat1d > dblat1.out ; \
+ ./xblat1c > cblat1.out ; \
+ ./xblat1z > zblat1.out )
+ ( cd BLAS/TESTING; $(MAKE) -f Makeblat2 )
+ ( cd BLAS; ./xblat2s < sblat2.in ; \
+ ./xblat2d < dblat2.in ; \
+ ./xblat2c < cblat2.in ; \
+ ./xblat2z < zblat2.in )
+ ( cd BLAS/TESTING; $(MAKE) -f Makeblat3 )
+ ( cd BLAS; ./xblat3s < sblat3.in ; \
+ ./xblat3d < dblat3.in ; \
+ ./xblat3c < cblat3.in ; \
+ ./xblat3z < zblat3.in )
+
+cleanlib:
+ ( cd INSTALL; $(MAKE) clean )
+ ( cd BLAS/SRC; $(MAKE) clean )
+ ( cd SRC; $(MAKE) clean )
+ ( cd SRC/VARIANTS; $(MAKE) clean )
+ ( cd TESTING/MATGEN; $(MAKE) clean )
+ ( cd F2CLIBS/libf2c; $(MAKE) clean )
+ ( cd F2CLIBS; rm *.a)
+
+cleanblas_testing:
+ ( cd BLAS/TESTING; $(MAKE) -f Makeblat1 clean )
+ ( cd BLAS/TESTING; $(MAKE) -f Makeblat2 clean )
+ ( cd BLAS/TESTING; $(MAKE) -f Makeblat3 clean )
+ ( cd BLAS; rm -f xblat* )
+
+cleantesting:
+ ( cd TESTING/LIN; $(MAKE) clean )
+ ( cd TESTING/EIG; $(MAKE) clean )
+ ( cd TESTING; rm -f xlin* xeig* )
+
+cleanall: cleanlib cleanblas_testing cleantesting
+ rm -f *.a TESTING/*.out INSTALL/test* BLAS/*.out
+
diff --git a/README.install b/README.install
new file mode 100644
index 0000000..6c8d7eb
--- /dev/null
+++ b/README.install
@@ -0,0 +1,223 @@
+ ===================
+ CLAPACK README FILE
+ ===================
+
+============================================================================================
+ Version 3.2.1 (threadsafe)
+ Release date: June 2009
+ F2C translation of LAPACK 3.2.1
+To get revisions info about LAPACK 3.2.1, please see http://www.netlib.org/lapack/lapack-3.2.1.html
+============================================================================================
+
+This README file describes how and how to install the ANSI C translation of the
+LAPACK library, called CLAPACK. CLAPACK must be compiled with an ANSI Standard
+C compiler. If the C compiler on your machine is an old-style C compiler, you
+will have to use gcc to compile the package.
+
+IMPORTANT NOTE:
+
+ You *CANNOT* just go to www.netlib.org/clapack, download a routine like
+ sgesv.c and have it work unless you properly install and link to the
+ f2c and BLAS routines as described below. If your linker complains about
+ missing functions, you have probably accidentally neglected this step.
+ Also, you will need the file "f2c.h" (included with the f2c libraries)
+in order to compile these routines.
+ The default BLAS routines included with CLAPACK in the BLAS/SRC
+ subdirectory may also be used these will most likely be
+ slower than a BLAS library optimized for your machine. If you do
+ not have such an optimized BLAS library, you can get one at
+
+ http://www.netlib.org/atlas
+
+
+==============================================================================
+
+For a fast default installation, you will need to
+ - Untar clapack.tar and modify the make.inc file (see step 1 below)
+ - Make the f2c libraries (see step 2 below)
+ - Make the BLAS library (see step 2 below)
+ - Make the main library, test it, and time it by simply typing
+ make
+
+If you encounter difficulties, you may find the installation manual for
+the FORTRAN version (INSTALL/lawn81.*) useful.
+
+
+ Procedure for installing CLAPACK:
+==============================================================================
+
+(1) 'tar xvf clapack.tar' to build the following directory structure:
+ CLAPACK/README.install this file
+ CLAPACK/BLAS/ C source for BLAS
+ CLAPACK/F2CLIBS/ f2c I/O functions (libI77) and math functions (libF77)
+ CLAPACK/INSTALL/ Testing functions and pre-tested make.inc files
+ for various platforms.
+ CLAPACK/SRC/ C source of LAPACK routines
+ CLAPACK/TESTING/ driver routines to test correctness
+ CLAPACK/make.inc compiler, compile flags and library definitions,
+ included in all Makefiles.
+ NOTE: It's better to use gcc compiler on some older
+ Sun systems.
+ CLAPACK/clapack.h A header file including C prototypes of all the
+ CLAPACK routines.
+ You should be sure to modify the make.inc file for your system. Sample
+ make.inc files for several platforms are included in the INSTALL
+ subdirectory.
+
+(2) Build the f2c libraries by doing:
+ make f2clib
+
+##############################################################################
+WARNING: 1) If your system lacks onexit() and you are not using an ANSI C
+ compiler, then you should change your F2CCFLAGS line in
+ make.inc to
+ F2CCFLAGS=$(CFLAGS) -DNO_ONEXIT
+ On at least some Sun systems, it is better to use
+ F2CCFLAGS=$(CFLAGS) -Donexit=on_exit
+ 2) On at least some Sun systems, the type declaration in
+ F2CLIBS/libI77/rawio.h: extern FILE *fdopen(int, char*)
+ is not consistent with the one defined in stdio.h. In this case
+ you should comment out this line.
+
+##############################################################################
+
+(3) To run CLAPACK, you need to create a BLAS library.
+ The performance of CLAPACK largely depends on the performance
+ of the BLAS library.
+
+ You can either use the reference BLAS library included with
+ this distribution, which is easy to install but not optimized to be
+ fast on any particular machine, or else find a version of the
+ BLAS optimized for your machine.
+
+ If you want to use the reference BLAS library included with
+ this distribution, build it by doing
+ make blaslib
+ from the main directory.
+
+ If you want to find a BLAS library optimized for your machine,
+ see the note below for more details;
+ see also the README in the BLAS/WRAP directory.
+
+(4) Compile and run the BLAS TESTING code by doing:
+ cd CLAPACK/BLAS/TESTING; make -f Makeblat2
+ cd CLAPACK/BLAS
+ xblat2s < sblat2.in
+ xblat2d < dblat2.in
+ xblat2c < cblat2.in
+ xblat2z < zblat2.in
+ cd CLAPACK/BLAS/TESTING; make -f Makeblat3
+ cd CLAPACK/BLAS
+ xblat3s < sblat3.in
+ xblat3d < dblat3.in
+ xblat3c < cblat3.in
+ xblat3z < zblat3.in
+
+ Inspect the output files *.SUMM to confirm that no errors occurred.
+
+{NOTE: If a compiling error involving _atexit appears then see information
+ within the WARNING above.}
+
+{NOTE: For the highest performance, it is best to use a version of the BLAS
+ optimized for your particular machine. This may be done by modifying
+ the line
+ BLASLIB = ../../blas$(PLAT).a
+ in CLAPACK/make.inc to point to the optimized BLAS.
+
+{NOTE: There is a clapack.h file in INCLUDE directory which has all the routine
+ declaration. Users are recommended to include this file to compile their
+ code. Some problem has been reported on 64-bit machine that is caused by
+ not using the correct declaration.
+
+Link with BLAS which provides the standard CBLAS interface
+==========================================================
+ If you are using a version of the BLAS which provides the standard
+ CBLAS interface (e.g. ATLAS), you need to add the appropriate "wrapper" library.
+ you can make the wrapper library libcblaswr.a by typing
+ "make cblaswrap" from the main directory. For this setup
+ (ATLAS with the CBLAS wrapper), the BLASLIB line might look like
+Example:
+Modification to make.inc
+CC = gcc
+BLASLIB = ../../libcblaswr.a -lcblas -latlas
+Creation of libcblaswr.a : make cblaswrap
+
+Link with BLAS which Fortran calling interface
+===============================================
+Two possibilities:
+ - add -DNO_BLAS_WRAP to the CC variable to when compiling and no need of a "wrapper" library
+Example:
+CC = gcc -DNO_BLAS_WRAP
+BLASLIB = -lgoto -lpthread
+
+ - add the sample Fortran calling interface (libfblaswr.a) for systems with
+ Sun-style Fortran calling conventions is also provided; however,
+ this interface will need modifications to work on other
+ architectures which have different Fortran calling convensions.
+ See the README in the BLAS/WRAP subdirectory for further information.
+Example:
+CC = gcc
+BLASLIB = ../../libfblaswr.a -lgoto -lpthread
+Creation of libfblaswr.a : make fblaswrap
+}
+
+(5) Build the archive containing lapack source code by doing:
+ cd CLAPACK/SRC; make
+
+(6) Compile the matrix generation software, the eigenroutine TESTING
+ code, the linear system TESTING code, and run the LAPACK tests
+ by doing:
+ cd CLAPACK/TESTING/MATGEN; make
+ cd CLAPACK/TESTING; make
+
+ Inspect the output files *.out to confirm that no errors occurred.
+
+I. Compile the matrix generation software, the eigenroutine TESTING code,
+ the linear system TESTING code, and run the LAPACK tests separately
+ by doing:
+ cd CLAPACK/TESTING/MATGEN; make
+ cd CLAPACK/TESTING/EIG; make
+ cd CLAPACK/TESTING/LIN; make
+ cd CLAPACK/TESTING; make
+II. After the executable files and libraries have been created for each
+ of the compiles, the object files should be removed by doing:
+ make clean
+III. Each 'make' may be accomplished just for one or a subset of the
+ precisions desired. For example:
+ make single
+ make single complex
+ make single double complex complex16
+ Using make without any arguments will compile all four precisions.
+
+James Demmel
+Xiaoye Li
+Chris Puscasiu
+Steve Timson
+
+UC Berkeley
+Sept 27 1993
+
+
+{Revised by Susan Ostrouchov and Jude Toth}
+ {The University of Tennessee at Knoxville}
+ {October 15, 1993}
+
+{Revised by Xiaoye Li and James Demmel}
+ {University of California at Berkeley}
+ {November 22, 1994}
+
+{Revised by David Bindel and James Demmel}
+ {University of California at Berkeley}
+ {July 19, 2000}
+
+{Revised by Julie Langou}
+ {University of Tennessee}
+ {February 2008}
+
+{Revised by Julie Langou}
+{University of Tennessee}
+ {October 2008}
+
+{Revised by Peng Du}
+{University of Tennessee}
+ {August 2009}
diff --git a/SRC/CMakeLists.txt b/SRC/CMakeLists.txt
new file mode 100644
index 0000000..ac4cce3
--- /dev/null
+++ b/SRC/CMakeLists.txt
@@ -0,0 +1,380 @@
+#######################################################################
+# This is the makefile to create a library for LAPACK.
+# The files are organized as follows:
+# ALLAUX -- Auxiliary routines called from all precisions
+# ALLXAUX -- Auxiliary routines called from all precisions but
+# only from routines using extra precision.
+# SCLAUX -- Auxiliary routines called from both REAL and COMPLEX
+# DZLAUX -- Auxiliary routines called from both DOUBLE PRECISION
+# and COMPLEX*16
+# SLASRC -- Single precision real LAPACK routines
+# SXLASRC -- Single precision real LAPACK routines using extra
+# precision.
+# CLASRC -- Single precision complex LAPACK routines
+# CXLASRC -- Single precision complex LAPACK routines using extra
+# precision.
+# DLASRC -- Double precision real LAPACK routines
+# DXLASRC -- Double precision real LAPACK routines using extra
+# precision.
+# ZLASRC -- Double precision complex LAPACK routines
+# ZXLASRC -- Double precision complex LAPACK routines using extra
+# precision.
+#
+# The library can be set up to include routines for any combination
+# of the four precisions. To create or add to the library, enter make
+# followed by one or more of the precisions desired. Some examples:
+# make single
+# make single complex
+# make single double complex complex16
+# Alternatively, the command
+# make
+# without any arguments creates a library of all four precisions.
+# The library is called
+# lapack.a
+# and is created at the next higher directory level.
+#
+# To remove the object files after the library is created, enter
+# make clean
+# On some systems, you can force the source files to be recompiled by
+# entering (for example)
+# make single FRC=FRC
+#
+# ***Note***
+# The functions lsame, second, dsecnd, slamch, and dlamch may have
+# to be installed before compiling the library. Refer to the
+# installation guide, LAPACK Working Note 41, for instructions.
+#
+#######################################################################
+
+set(ALLAUX maxloc.c ilaenv.c ieeeck.c lsamen.c iparmq.c
+ ilaprec.c ilatrans.c ilauplo.c iladiag.c chla_transtype.c
+ ../INSTALL/ilaver.c ../INSTALL/lsame.c) # xerbla.c xerbla_array.c
+
+set(ALLXAUX )
+
+set(SCLAUX
+ sbdsdc.c
+ sbdsqr.c sdisna.c slabad.c slacpy.c sladiv.c slae2.c slaebz.c
+ slaed0.c slaed1.c slaed2.c slaed3.c slaed4.c slaed5.c slaed6.c
+ slaed7.c slaed8.c slaed9.c slaeda.c slaev2.c slagtf.c
+ slagts.c slamrg.c slanst.c
+ slapy2.c slapy3.c slarnv.c
+ slarra.c slarrb.c slarrc.c slarrd.c slarre.c slarrf.c slarrj.c
+ slarrk.c slarrr.c slaneg.c
+ slartg.c slaruv.c slas2.c slascl.c
+ slasd0.c slasd1.c slasd2.c slasd3.c slasd4.c slasd5.c slasd6.c
+ slasd7.c slasd8.c slasda.c slasdq.c slasdt.c
+ slaset.c slasq1.c slasq2.c slasq3.c slasq4.c slasq5.c slasq6.c
+ slasr.c slasrt.c slassq.c slasv2.c spttrf.c sstebz.c sstedc.c
+ ssteqr.c ssterf.c slaisnan.c sisnan.c
+ ../INSTALL/slamch.c ${SECOND_SRC})
+
+set(DZLAUX
+ dbdsdc.c
+ dbdsqr.c ddisna.c dlabad.c dlacpy.c dladiv.c dlae2.c dlaebz.c
+ dlaed0.c dlaed1.c dlaed2.c dlaed3.c dlaed4.c dlaed5.c dlaed6.c
+ dlaed7.c dlaed8.c dlaed9.c dlaeda.c dlaev2.c dlagtf.c
+ dlagts.c dlamrg.c dlanst.c
+ dlapy2.c dlapy3.c dlarnv.c
+ dlarra.c dlarrb.c dlarrc.c dlarrd.c dlarre.c dlarrf.c dlarrj.c
+ dlarrk.c dlarrr.c dlaneg.c
+ dlartg.c dlaruv.c dlas2.c dlascl.c
+ dlasd0.c dlasd1.c dlasd2.c dlasd3.c dlasd4.c dlasd5.c dlasd6.c
+ dlasd7.c dlasd8.c dlasda.c dlasdq.c dlasdt.c
+ dlaset.c dlasq1.c dlasq2.c dlasq3.c dlasq4.c dlasq5.c dlasq6.c
+ dlasr.c dlasrt.c dlassq.c dlasv2.c dpttrf.c dstebz.c dstedc.c
+ dsteqr.c dsterf.c dlaisnan.c disnan.c
+ ../INSTALL/dlamch.c ${DSECOND_SRC})
+
+set(SLASRC
+ sgbbrd.c sgbcon.c sgbequ.c sgbrfs.c sgbsv.c
+ sgbsvx.c sgbtf2.c sgbtrf.c sgbtrs.c sgebak.c sgebal.c sgebd2.c
+ sgebrd.c sgecon.c sgeequ.c sgees.c sgeesx.c sgeev.c sgeevx.c
+ sgegs.c sgegv.c sgehd2.c sgehrd.c sgelq2.c sgelqf.c
+ sgels.c sgelsd.c sgelss.c sgelsx.c sgelsy.c sgeql2.c sgeqlf.c
+ sgeqp3.c sgeqpf.c sgeqr2.c sgeqrf.c sgerfs.c sgerq2.c sgerqf.c
+ sgesc2.c sgesdd.c sgesv.c sgesvd.c sgesvx.c sgetc2.c sgetf2.c
+ sgetrf.c sgetri.c
+ sgetrs.c sggbak.c sggbal.c sgges.c sggesx.c sggev.c sggevx.c
+ sggglm.c sgghrd.c sgglse.c sggqrf.c
+ sggrqf.c sggsvd.c sggsvp.c sgtcon.c sgtrfs.c sgtsv.c
+ sgtsvx.c sgttrf.c sgttrs.c sgtts2.c shgeqz.c
+ shsein.c shseqr.c slabrd.c slacon.c slacn2.c
+ slaein.c slaexc.c slag2.c slags2.c slagtm.c slagv2.c slahqr.c
+ slahrd.c slahr2.c slaic1.c slaln2.c slals0.c slalsa.c slalsd.c
+ slangb.c slange.c slangt.c slanhs.c slansb.c slansp.c
+ slansy.c slantb.c slantp.c slantr.c slanv2.c
+ slapll.c slapmt.c
+ slaqgb.c slaqge.c slaqp2.c slaqps.c slaqsb.c slaqsp.c slaqsy.c
+ slaqr0.c slaqr1.c slaqr2.c slaqr3.c slaqr4.c slaqr5.c
+ slaqtr.c slar1v.c slar2v.c ilaslr.c ilaslc.c
+ slarf.c slarfb.c slarfg.c slarft.c slarfx.c slargv.c
+ slarrv.c slartv.c slarfp.c
+ slarz.c slarzb.c slarzt.c slaswp.c slasy2.c slasyf.c
+ slatbs.c slatdf.c slatps.c slatrd.c slatrs.c slatrz.c slatzm.c
+ slauu2.c slauum.c sopgtr.c sopmtr.c sorg2l.c sorg2r.c
+ sorgbr.c sorghr.c sorgl2.c sorglq.c sorgql.c sorgqr.c sorgr2.c
+ sorgrq.c sorgtr.c sorm2l.c sorm2r.c
+ sormbr.c sormhr.c sorml2.c sormlq.c sormql.c sormqr.c sormr2.c
+ sormr3.c sormrq.c sormrz.c sormtr.c spbcon.c spbequ.c spbrfs.c
+ spbstf.c spbsv.c spbsvx.c
+ spbtf2.c spbtrf.c spbtrs.c spocon.c spoequ.c sporfs.c sposv.c
+ sposvx.c spotf2.c spotrf.c spotri.c spotrs.c spstrf.c spstf2.c
+ sppcon.c sppequ.c
+ spprfs.c sppsv.c sppsvx.c spptrf.c spptri.c spptrs.c sptcon.c
+ spteqr.c sptrfs.c sptsv.c sptsvx.c spttrs.c sptts2.c srscl.c
+ ssbev.c ssbevd.c ssbevx.c ssbgst.c ssbgv.c ssbgvd.c ssbgvx.c
+ ssbtrd.c sspcon.c sspev.c sspevd.c sspevx.c sspgst.c
+ sspgv.c sspgvd.c sspgvx.c ssprfs.c sspsv.c sspsvx.c ssptrd.c
+ ssptrf.c ssptri.c ssptrs.c sstegr.c sstein.c sstev.c sstevd.c sstevr.c
+ sstevx.c ssycon.c ssyev.c ssyevd.c ssyevr.c ssyevx.c ssygs2.c
+ ssygst.c ssygv.c ssygvd.c ssygvx.c ssyrfs.c ssysv.c ssysvx.c
+ ssytd2.c ssytf2.c ssytrd.c ssytrf.c ssytri.c ssytrs.c stbcon.c
+ stbrfs.c stbtrs.c stgevc.c stgex2.c stgexc.c stgsen.c
+ stgsja.c stgsna.c stgsy2.c stgsyl.c stpcon.c stprfs.c stptri.c
+ stptrs.c
+ strcon.c strevc.c strexc.c strrfs.c strsen.c strsna.c strsyl.c
+ strti2.c strtri.c strtrs.c stzrqf.c stzrzf.c sstemr.c
+ slansf.c spftrf.c spftri.c spftrs.c ssfrk.c stfsm.c stftri.c stfttp.c
+ stfttr.c stpttf.c stpttr.c strttf.c strttp.c
+ sgejsv.c sgesvj.c sgsvj0.c sgsvj1.c
+ sgeequb.c ssyequb.c spoequb.c sgbequb.c)
+
+set(SXLASRC sgesvxx.c sgerfsx.c sla_gerfsx_extended.c sla_geamv.c
+ sla_gercond.c sla_rpvgrw.c ssysvxx.c ssyrfsx.c
+ sla_syrfsx_extended.c sla_syamv.c sla_syrcond.c sla_syrpvgrw.c
+ sposvxx.c sporfsx.c sla_porfsx_extended.c sla_porcond.c
+ sla_porpvgrw.c sgbsvxx.c sgbrfsx.c sla_gbrfsx_extended.c
+ sla_gbamv.c sla_gbrcond.c sla_gbrpvgrw.c sla_lin_berr.c slarscl2.c
+ slascl2.c sla_wwaddw.c)
+
+set(CLASRC
+ cbdsqr.c cgbbrd.c cgbcon.c cgbequ.c cgbrfs.c cgbsv.c cgbsvx.c
+ cgbtf2.c cgbtrf.c cgbtrs.c cgebak.c cgebal.c cgebd2.c cgebrd.c
+ cgecon.c cgeequ.c cgees.c cgeesx.c cgeev.c cgeevx.c
+ cgegs.c cgegv.c cgehd2.c cgehrd.c cgelq2.c cgelqf.c
+ cgels.c cgelsd.c cgelss.c cgelsx.c cgelsy.c cgeql2.c cgeqlf.c cgeqp3.c
+ cgeqpf.c cgeqr2.c cgeqrf.c cgerfs.c cgerq2.c cgerqf.c
+ cgesc2.c cgesdd.c cgesv.c cgesvd.c cgesvx.c cgetc2.c cgetf2.c cgetrf.c
+ cgetri.c cgetrs.c
+ cggbak.c cggbal.c cgges.c cggesx.c cggev.c cggevx.c cggglm.c
+ cgghrd.c cgglse.c cggqrf.c cggrqf.c
+ cggsvd.c cggsvp.c
+ cgtcon.c cgtrfs.c cgtsv.c cgtsvx.c cgttrf.c cgttrs.c cgtts2.c chbev.c
+ chbevd.c chbevx.c chbgst.c chbgv.c chbgvd.c chbgvx.c chbtrd.c
+ checon.c cheev.c cheevd.c cheevr.c cheevx.c chegs2.c chegst.c
+ chegv.c chegvd.c chegvx.c cherfs.c chesv.c chesvx.c chetd2.c
+ chetf2.c chetrd.c
+ chetrf.c chetri.c chetrs.c chgeqz.c chpcon.c chpev.c chpevd.c
+ chpevx.c chpgst.c chpgv.c chpgvd.c chpgvx.c chprfs.c chpsv.c
+ chpsvx.c
+ chptrd.c chptrf.c chptri.c chptrs.c chsein.c chseqr.c clabrd.c
+ clacgv.c clacon.c clacn2.c clacp2.c clacpy.c clacrm.c clacrt.c cladiv.c
+ claed0.c claed7.c claed8.c
+ claein.c claesy.c claev2.c clags2.c clagtm.c
+ clahef.c clahqr.c
+ clahrd.c clahr2.c claic1.c clals0.c clalsa.c clalsd.c clangb.c clange.c clangt.c
+ clanhb.c clanhe.c
+ clanhp.c clanhs.c clanht.c clansb.c clansp.c clansy.c clantb.c
+ clantp.c clantr.c clapll.c clapmt.c clarcm.c claqgb.c claqge.c
+ claqhb.c claqhe.c claqhp.c claqp2.c claqps.c claqsb.c
+ claqr0.c claqr1.c claqr2.c claqr3.c claqr4.c claqr5.c
+ claqsp.c claqsy.c clar1v.c clar2v.c ilaclr.c ilaclc.c
+ clarf.c clarfb.c clarfg.c clarft.c clarfp.c
+ clarfx.c clargv.c clarnv.c clarrv.c clartg.c clartv.c
+ clarz.c clarzb.c clarzt.c clascl.c claset.c clasr.c classq.c
+ claswp.c clasyf.c clatbs.c clatdf.c clatps.c clatrd.c clatrs.c clatrz.c
+ clatzm.c clauu2.c clauum.c cpbcon.c cpbequ.c cpbrfs.c cpbstf.c cpbsv.c
+ cpbsvx.c cpbtf2.c cpbtrf.c cpbtrs.c cpocon.c cpoequ.c cporfs.c
+ cposv.c cposvx.c cpotf2.c cpotrf.c cpotri.c cpotrs.c cpstrf.c cpstf2.c
+ cppcon.c cppequ.c cpprfs.c cppsv.c cppsvx.c cpptrf.c cpptri.c cpptrs.c
+ cptcon.c cpteqr.c cptrfs.c cptsv.c cptsvx.c cpttrf.c cpttrs.c cptts2.c
+ crot.c cspcon.c cspmv.c cspr.c csprfs.c cspsv.c
+ cspsvx.c csptrf.c csptri.c csptrs.c csrscl.c cstedc.c
+ cstegr.c cstein.c csteqr.c csycon.c csymv.c
+ csyr.c csyrfs.c csysv.c csysvx.c csytf2.c csytrf.c csytri.c
+ csytrs.c ctbcon.c ctbrfs.c ctbtrs.c ctgevc.c ctgex2.c
+ ctgexc.c ctgsen.c ctgsja.c ctgsna.c ctgsy2.c ctgsyl.c ctpcon.c
+ ctprfs.c ctptri.c
+ ctptrs.c ctrcon.c ctrevc.c ctrexc.c ctrrfs.c ctrsen.c ctrsna.c
+ ctrsyl.c ctrti2.c ctrtri.c ctrtrs.c ctzrqf.c ctzrzf.c cung2l.c cung2r.c
+ cungbr.c cunghr.c cungl2.c cunglq.c cungql.c cungqr.c cungr2.c
+ cungrq.c cungtr.c cunm2l.c cunm2r.c cunmbr.c cunmhr.c cunml2.c
+ cunmlq.c cunmql.c cunmqr.c cunmr2.c cunmr3.c cunmrq.c cunmrz.c
+ cunmtr.c cupgtr.c cupmtr.c icmax1.c scsum1.c cstemr.c
+ chfrk.c ctfttp.c clanhf.c cpftrf.c cpftri.c cpftrs.c ctfsm.c ctftri.c
+ ctfttr.c ctpttf.c ctpttr.c ctrttf.c ctrttp.c
+ cgeequb.c cgbequb.c csyequb.c cpoequb.c cheequb.c)
+
+set(CXLASRC cgesvxx.c cgerfsx.c cla_gerfsx_extended.c cla_geamv.c
+ cla_gercond_c.c cla_gercond_x.c cla_rpvgrw.c
+ csysvxx.c csyrfsx.c cla_syrfsx_extended.c cla_syamv.c
+ cla_syrcond_c.c cla_syrcond_x.c cla_syrpvgrw.c
+ cposvxx.c cporfsx.c cla_porfsx_extended.c
+ cla_porcond_c.c cla_porcond_x.c cla_porpvgrw.c
+ cgbsvxx.c cgbrfsx.c cla_gbrfsx_extended.c cla_gbamv.c
+ cla_gbrcond_c.c cla_gbrcond_x.c cla_gbrpvgrw.c
+ chesvxx.c cherfsx.c cla_herfsx_extended.c cla_heamv.c
+ cla_hercond_c.c cla_hercond_x.c cla_herpvgrw.c
+ cla_lin_berr.c clarscl2.c clascl2.c cla_wwaddw.c)
+
+set(DLASRC
+ dgbbrd.c dgbcon.c dgbequ.c dgbrfs.c dgbsv.c
+ dgbsvx.c dgbtf2.c dgbtrf.c dgbtrs.c dgebak.c dgebal.c dgebd2.c
+ dgebrd.c dgecon.c dgeequ.c dgees.c dgeesx.c dgeev.c dgeevx.c
+ dgegs.c dgegv.c dgehd2.c dgehrd.c dgelq2.c dgelqf.c
+ dgels.c dgelsd.c dgelss.c dgelsx.c dgelsy.c dgeql2.c dgeqlf.c
+ dgeqp3.c dgeqpf.c dgeqr2.c dgeqrf.c dgerfs.c dgerq2.c dgerqf.c
+ dgesc2.c dgesdd.c dgesv.c dgesvd.c dgesvx.c dgetc2.c dgetf2.c
+ dgetrf.c dgetri.c
+ dgetrs.c dggbak.c dggbal.c dgges.c dggesx.c dggev.c dggevx.c
+ dggglm.c dgghrd.c dgglse.c dggqrf.c
+ dggrqf.c dggsvd.c dggsvp.c dgtcon.c dgtrfs.c dgtsv.c
+ dgtsvx.c dgttrf.c dgttrs.c dgtts2.c dhgeqz.c
+ dhsein.c dhseqr.c dlabrd.c dlacon.c dlacn2.c
+ dlaein.c dlaexc.c dlag2.c dlags2.c dlagtm.c dlagv2.c dlahqr.c
+ dlahrd.c dlahr2.c dlaic1.c dlaln2.c dlals0.c dlalsa.c dlalsd.c
+ dlangb.c dlange.c dlangt.c dlanhs.c dlansb.c dlansp.c
+ dlansy.c dlantb.c dlantp.c dlantr.c dlanv2.c
+ dlapll.c dlapmt.c
+ dlaqgb.c dlaqge.c dlaqp2.c dlaqps.c dlaqsb.c dlaqsp.c dlaqsy.c
+ dlaqr0.c dlaqr1.c dlaqr2.c dlaqr3.c dlaqr4.c dlaqr5.c
+ dlaqtr.c dlar1v.c dlar2v.c iladlr.c iladlc.c
+ dlarf.c dlarfb.c dlarfg.c dlarft.c dlarfx.c dlargv.c
+ dlarrv.c dlartv.c dlarfp.c
+ dlarz.c dlarzb.c dlarzt.c dlaswp.c dlasy2.c dlasyf.c
+ dlatbs.c dlatdf.c dlatps.c dlatrd.c dlatrs.c dlatrz.c dlatzm.c dlauu2.c
+ dlauum.c dopgtr.c dopmtr.c dorg2l.c dorg2r.c
+ dorgbr.c dorghr.c dorgl2.c dorglq.c dorgql.c dorgqr.c dorgr2.c
+ dorgrq.c dorgtr.c dorm2l.c dorm2r.c
+ dormbr.c dormhr.c dorml2.c dormlq.c dormql.c dormqr.c dormr2.c
+ dormr3.c dormrq.c dormrz.c dormtr.c dpbcon.c dpbequ.c dpbrfs.c
+ dpbstf.c dpbsv.c dpbsvx.c
+ dpbtf2.c dpbtrf.c dpbtrs.c dpocon.c dpoequ.c dporfs.c dposv.c
+ dposvx.c dpotf2.c dpotrf.c dpotri.c dpotrs.c dpstrf.c dpstf2.c
+ dppcon.c dppequ.c
+ dpprfs.c dppsv.c dppsvx.c dpptrf.c dpptri.c dpptrs.c dptcon.c
+ dpteqr.c dptrfs.c dptsv.c dptsvx.c dpttrs.c dptts2.c drscl.c
+ dsbev.c dsbevd.c dsbevx.c dsbgst.c dsbgv.c dsbgvd.c dsbgvx.c
+ dsbtrd.c dspcon.c dspev.c dspevd.c dspevx.c dspgst.c
+ dspgv.c dspgvd.c dspgvx.c dsprfs.c dspsv.c dspsvx.c dsptrd.c
+ dsptrf.c dsptri.c dsptrs.c dstegr.c dstein.c dstev.c dstevd.c dstevr.c
+ dstevx.c dsycon.c dsyev.c dsyevd.c dsyevr.c
+ dsyevx.c dsygs2.c dsygst.c dsygv.c dsygvd.c dsygvx.c dsyrfs.c
+ dsysv.c dsysvx.c
+ dsytd2.c dsytf2.c dsytrd.c dsytrf.c dsytri.c dsytrs.c dtbcon.c
+ dtbrfs.c dtbtrs.c dtgevc.c dtgex2.c dtgexc.c dtgsen.c
+ dtgsja.c dtgsna.c dtgsy2.c dtgsyl.c dtpcon.c dtprfs.c dtptri.c
+ dtptrs.c
+ dtrcon.c dtrevc.c dtrexc.c dtrrfs.c dtrsen.c dtrsna.c dtrsyl.c
+ dtrti2.c dtrtri.c dtrtrs.c dtzrqf.c dtzrzf.c dstemr.c
+ dsgesv.c dsposv.c dlag2s.c slag2d.c dlat2s.c
+ dlansf.c dpftrf.c dpftri.c dpftrs.c dsfrk.c dtfsm.c dtftri.c dtfttp.c
+ dtfttr.c dtpttf.c dtpttr.c dtrttf.c dtrttp.c
+ dgejsv.c dgesvj.c dgsvj0.c dgsvj1.c
+ dgeequb.c dsyequb.c dpoequb.c dgbequb.c)
+
+set(DXLASRC dgesvxx.c dgerfsx.c dla_gerfsx_extended.c dla_geamv.c
+ dla_gercond.c dla_rpvgrw.c dsysvxx.c dsyrfsx.c
+ dla_syrfsx_extended.c dla_syamv.c dla_syrcond.c dla_syrpvgrw.c
+ dposvxx.c dporfsx.c dla_porfsx_extended.c dla_porcond.c
+ dla_porpvgrw.c dgbsvxx.c dgbrfsx.c dla_gbrfsx_extended.c
+ dla_gbamv.c dla_gbrcond.c dla_gbrpvgrw.c dla_lin_berr.c dlarscl2.c
+ dlascl2.c dla_wwaddw.c)
+
+set(ZLASRC
+ zbdsqr.c zgbbrd.c zgbcon.c zgbequ.c zgbrfs.c zgbsv.c zgbsvx.c
+ zgbtf2.c zgbtrf.c zgbtrs.c zgebak.c zgebal.c zgebd2.c zgebrd.c
+ zgecon.c zgeequ.c zgees.c zgeesx.c zgeev.c zgeevx.c
+ zgegs.c zgegv.c zgehd2.c zgehrd.c zgelq2.c zgelqf.c
+ zgels.c zgelsd.c zgelss.c zgelsx.c zgelsy.c zgeql2.c zgeqlf.c zgeqp3.c
+ zgeqpf.c zgeqr2.c zgeqrf.c zgerfs.c zgerq2.c zgerqf.c
+ zgesc2.c zgesdd.c zgesv.c zgesvd.c zgesvx.c zgetc2.c zgetf2.c zgetrf.c
+ zgetri.c zgetrs.c
+ zggbak.c zggbal.c zgges.c zggesx.c zggev.c zggevx.c zggglm.c
+ zgghrd.c zgglse.c zggqrf.c zggrqf.c
+ zggsvd.c zggsvp.c
+ zgtcon.c zgtrfs.c zgtsv.c zgtsvx.c zgttrf.c zgttrs.c zgtts2.c zhbev.c
+ zhbevd.c zhbevx.c zhbgst.c zhbgv.c zhbgvd.c zhbgvx.c zhbtrd.c
+ zhecon.c zheev.c zheevd.c zheevr.c zheevx.c zhegs2.c zhegst.c
+ zhegv.c zhegvd.c zhegvx.c zherfs.c zhesv.c zhesvx.c zhetd2.c
+ zhetf2.c zhetrd.c
+ zhetrf.c zhetri.c zhetrs.c zhgeqz.c zhpcon.c zhpev.c zhpevd.c
+ zhpevx.c zhpgst.c zhpgv.c zhpgvd.c zhpgvx.c zhprfs.c zhpsv.c
+ zhpsvx.c
+ zhptrd.c zhptrf.c zhptri.c zhptrs.c zhsein.c zhseqr.c zlabrd.c
+ zlacgv.c zlacon.c zlacn2.c zlacp2.c zlacpy.c zlacrm.c zlacrt.c zladiv.c
+ zlaed0.c zlaed7.c zlaed8.c
+ zlaein.c zlaesy.c zlaev2.c zlags2.c zlagtm.c
+ zlahef.c zlahqr.c
+ zlahrd.c zlahr2.c zlaic1.c zlals0.c zlalsa.c zlalsd.c zlangb.c zlange.c
+ zlangt.c zlanhb.c
+ zlanhe.c
+ zlanhp.c zlanhs.c zlanht.c zlansb.c zlansp.c zlansy.c zlantb.c
+ zlantp.c zlantr.c zlapll.c zlapmt.c zlaqgb.c zlaqge.c
+ zlaqhb.c zlaqhe.c zlaqhp.c zlaqp2.c zlaqps.c zlaqsb.c
+ zlaqr0.c zlaqr1.c zlaqr2.c zlaqr3.c zlaqr4.c zlaqr5.c
+ zlaqsp.c zlaqsy.c zlar1v.c zlar2v.c ilazlr.c ilazlc.c
+ zlarcm.c zlarf.c zlarfb.c
+ zlarfg.c zlarft.c zlarfp.c
+ zlarfx.c zlargv.c zlarnv.c zlarrv.c zlartg.c zlartv.c
+ zlarz.c zlarzb.c zlarzt.c zlascl.c zlaset.c zlasr.c
+ zlassq.c zlaswp.c zlasyf.c
+ zlatbs.c zlatdf.c zlatps.c zlatrd.c zlatrs.c zlatrz.c zlatzm.c zlauu2.c
+ zlauum.c zpbcon.c zpbequ.c zpbrfs.c zpbstf.c zpbsv.c
+ zpbsvx.c zpbtf2.c zpbtrf.c zpbtrs.c zpocon.c zpoequ.c zporfs.c
+ zposv.c zposvx.c zpotf2.c zpotrf.c zpotri.c zpotrs.c zpstrf.c zpstf2.c
+ zppcon.c zppequ.c zpprfs.c zppsv.c zppsvx.c zpptrf.c zpptri.c zpptrs.c
+ zptcon.c zpteqr.c zptrfs.c zptsv.c zptsvx.c zpttrf.c zpttrs.c zptts2.c
+ zrot.c zspcon.c zspmv.c zspr.c zsprfs.c zspsv.c
+ zspsvx.c zsptrf.c zsptri.c zsptrs.c zdrscl.c zstedc.c
+ zstegr.c zstein.c zsteqr.c zsycon.c zsymv.c
+ zsyr.c zsyrfs.c zsysv.c zsysvx.c zsytf2.c zsytrf.c zsytri.c
+ zsytrs.c ztbcon.c ztbrfs.c ztbtrs.c ztgevc.c ztgex2.c
+ ztgexc.c ztgsen.c ztgsja.c ztgsna.c ztgsy2.c ztgsyl.c ztpcon.c
+ ztprfs.c ztptri.c
+ ztptrs.c ztrcon.c ztrevc.c ztrexc.c ztrrfs.c ztrsen.c ztrsna.c
+ ztrsyl.c ztrti2.c ztrtri.c ztrtrs.c ztzrqf.c ztzrzf.c zung2l.c
+ zung2r.c zungbr.c zunghr.c zungl2.c zunglq.c zungql.c zungqr.c zungr2.c
+ zungrq.c zungtr.c zunm2l.c zunm2r.c zunmbr.c zunmhr.c zunml2.c
+ zunmlq.c zunmql.c zunmqr.c zunmr2.c zunmr3.c zunmrq.c zunmrz.c
+ zunmtr.c zupgtr.c
+ zupmtr.c izmax1.c dzsum1.c zstemr.c
+ zcgesv.c zcposv.c zlag2c.c clag2z.c zlat2c.c
+ zhfrk.c ztfttp.c zlanhf.c zpftrf.c zpftri.c zpftrs.c ztfsm.c ztftri.c
+ ztfttr.c ztpttf.c ztpttr.c ztrttf.c ztrttp.c
+ zgeequb.c zgbequb.c zsyequb.c zpoequb.c zheequb.c)
+
+set(ZXLASRC zgesvxx.c zgerfsx.c zla_gerfsx_extended.c zla_geamv.c
+ zla_gercond_c.c zla_gercond_x.c zla_rpvgrw.c zsysvxx.c zsyrfsx.c
+ zla_syrfsx_extended.c zla_syamv.c zla_syrcond_c.c zla_syrcond_x.c
+ zla_syrpvgrw.c zposvxx.c zporfsx.c zla_porfsx_extended.c
+ zla_porcond_c.c zla_porcond_x.c zla_porpvgrw.c zgbsvxx.c zgbrfsx.c
+ zla_gbrfsx_extended.c zla_gbamv.c zla_gbrcond_c.c zla_gbrcond_x.c
+ zla_gbrpvgrw.c zhesvxx.c zherfsx.c zla_herfsx_extended.c
+ zla_heamv.c zla_hercond_c.c zla_hercond_x.c zla_herpvgrw.c
+ zla_lin_berr.c zlarscl2.c zlascl2.c zla_wwaddw.c)
+
+
+if( USEXBLAS)
+ set(ALLXOBJ ${SXLASRC} ${DXLASRC} ${CXLASRC} ${ZXLASRC} ${ALLXAUX})
+endif()
+
+set(ALLOBJ ${SLASRC} ${DLASRC} ${CLASRC} ${ZLASRC} ${SCLAUX} ${DZLAUX}
+ ${ALLAUX})
+if(BUILD_SINGLE)
+set(ALLOBJ ${SLASRC} ${ALLAUX}
+ ${SCLAUX})
+endif()
+if(BUILD_DOUBLE)
+ set(ALLOBJ ${DLASRC} ${ALLAUX} ${DZLAUX})
+endif()
+if(BUILD_COMPLEX)
+ set(ALLOBJ ${CLASRC} ${ALLAUX} ${SCLAUX})
+endif()
+if(BUILD_COMPLEX16)
+ set(ALLOBJ ${ZLASRC} ${ALLAUX} ${DZLAUX})
+endif()
+add_library(lapack ${ALLOBJ} ${ALLXOBJ})
+target_link_libraries(lapack blas)
+
diff --git a/SRC/Makefile b/SRC/Makefile
new file mode 100644
index 0000000..5f1eb22
--- /dev/null
+++ b/SRC/Makefile
@@ -0,0 +1,423 @@
+include ../make.inc
+
+#######################################################################
+# This is the makefile to create a library for LAPACK.
+# The files are organized as follows:
+# ALLAUX -- Auxiliary routines called from all precisions
+# ALLXAUX -- Auxiliary routines called from all precisions but
+# only from routines using extra precision.
+# SCLAUX -- Auxiliary routines called from both REAL and COMPLEX
+# DZLAUX -- Auxiliary routines called from both DOUBLE PRECISION
+# and COMPLEX*16
+# SLASRC -- Single precision real LAPACK routines
+# SXLASRC -- Single precision real LAPACK routines using extra
+# precision.
+# CLASRC -- Single precision complex LAPACK routines
+# CXLASRC -- Single precision complex LAPACK routines using extra
+# precision.
+# DLASRC -- Double precision real LAPACK routines
+# DXLASRC -- Double precision real LAPACK routines using extra
+# precision.
+# ZLASRC -- Double precision complex LAPACK routines
+# ZXLASRC -- Double precision complex LAPACK routines using extra
+# precision.
+#
+# The library can be set up to include routines for any combination
+# of the four precisions. To create or add to the library, enter make
+# followed by one or more of the precisions desired. Some examples:
+# make single
+# make single complex
+# make single double complex complex16
+# Alternatively, the command
+# make
+# without any arguments creates a library of all four precisions.
+# The library is called
+# lapack.a
+# and is created at the next higher directory level.
+#
+# To remove the object files after the library is created, enter
+# make clean
+# On some systems, you can force the source files to be recompiled by
+# entering (for example)
+# make single FRC=FRC
+#
+# ***Note***
+# The functions lsame, second, dsecnd, slamch, and dlamch may have
+# to be installed before compiling the library. Refer to the
+# installation guide, LAPACK Working Note 41, for instructions.
+#
+#######################################################################
+
+ALLAUX = maxloc.o ilaenv.o ieeeck.o lsamen.o xerbla.o xerbla_array.o iparmq.o \
+ ilaprec.o ilatrans.o ilauplo.o iladiag.o chla_transtype.o \
+ ../INSTALL/ilaver.o ../INSTALL/lsame.o
+
+ALLXAUX =
+
+SCLAUX = \
+ sbdsdc.o \
+ sbdsqr.o sdisna.o slabad.o slacpy.o sladiv.o slae2.o slaebz.o \
+ slaed0.o slaed1.o slaed2.o slaed3.o slaed4.o slaed5.o slaed6.o \
+ slaed7.o slaed8.o slaed9.o slaeda.o slaev2.o slagtf.o \
+ slagts.o slamrg.o slanst.o \
+ slapy2.o slapy3.o slarnv.o \
+ slarra.o slarrb.o slarrc.o slarrd.o slarre.o slarrf.o slarrj.o \
+ slarrk.o slarrr.o slaneg.o \
+ slartg.o slaruv.o slas2.o slascl.o \
+ slasd0.o slasd1.o slasd2.o slasd3.o slasd4.o slasd5.o slasd6.o \
+ slasd7.o slasd8.o slasda.o slasdq.o slasdt.o \
+ slaset.o slasq1.o slasq2.o slasq3.o slasq4.o slasq5.o slasq6.o \
+ slasr.o slasrt.o slassq.o slasv2.o spttrf.o sstebz.o sstedc.o \
+ ssteqr.o ssterf.o slaisnan.o sisnan.o \
+ ../INSTALL/slamch.o ../INSTALL/second.o
+
+DZLAUX = \
+ dbdsdc.o \
+ dbdsqr.o ddisna.o dlabad.o dlacpy.o dladiv.o dlae2.o dlaebz.o \
+ dlaed0.o dlaed1.o dlaed2.o dlaed3.o dlaed4.o dlaed5.o dlaed6.o \
+ dlaed7.o dlaed8.o dlaed9.o dlaeda.o dlaev2.o dlagtf.o \
+ dlagts.o dlamrg.o dlanst.o \
+ dlapy2.o dlapy3.o dlarnv.o \
+ dlarra.o dlarrb.o dlarrc.o dlarrd.o dlarre.o dlarrf.o dlarrj.o \
+ dlarrk.o dlarrr.o dlaneg.o \
+ dlartg.o dlaruv.o dlas2.o dlascl.o \
+ dlasd0.o dlasd1.o dlasd2.o dlasd3.o dlasd4.o dlasd5.o dlasd6.o \
+ dlasd7.o dlasd8.o dlasda.o dlasdq.o dlasdt.o \
+ dlaset.o dlasq1.o dlasq2.o dlasq3.o dlasq4.o dlasq5.o dlasq6.o \
+ dlasr.o dlasrt.o dlassq.o dlasv2.o dpttrf.o dstebz.o dstedc.o \
+ dsteqr.o dsterf.o dlaisnan.o disnan.o \
+ ../INSTALL/dlamch.o ../INSTALL/dsecnd.o
+
+SLASRC = \
+ sgbbrd.o sgbcon.o sgbequ.o sgbrfs.o sgbsv.o \
+ sgbsvx.o sgbtf2.o sgbtrf.o sgbtrs.o sgebak.o sgebal.o sgebd2.o \
+ sgebrd.o sgecon.o sgeequ.o sgees.o sgeesx.o sgeev.o sgeevx.o \
+ sgegs.o sgegv.o sgehd2.o sgehrd.o sgelq2.o sgelqf.o \
+ sgels.o sgelsd.o sgelss.o sgelsx.o sgelsy.o sgeql2.o sgeqlf.o \
+ sgeqp3.o sgeqpf.o sgeqr2.o sgeqrf.o sgerfs.o sgerq2.o sgerqf.o \
+ sgesc2.o sgesdd.o sgesv.o sgesvd.o sgesvx.o sgetc2.o sgetf2.o \
+ sgetrf.o sgetri.o \
+ sgetrs.o sggbak.o sggbal.o sgges.o sggesx.o sggev.o sggevx.o \
+ sggglm.o sgghrd.o sgglse.o sggqrf.o \
+ sggrqf.o sggsvd.o sggsvp.o sgtcon.o sgtrfs.o sgtsv.o \
+ sgtsvx.o sgttrf.o sgttrs.o sgtts2.o shgeqz.o \
+ shsein.o shseqr.o slabrd.o slacon.o slacn2.o \
+ slaein.o slaexc.o slag2.o slags2.o slagtm.o slagv2.o slahqr.o \
+ slahrd.o slahr2.o slaic1.o slaln2.o slals0.o slalsa.o slalsd.o \
+ slangb.o slange.o slangt.o slanhs.o slansb.o slansp.o \
+ slansy.o slantb.o slantp.o slantr.o slanv2.o \
+ slapll.o slapmt.o \
+ slaqgb.o slaqge.o slaqp2.o slaqps.o slaqsb.o slaqsp.o slaqsy.o \
+ slaqr0.o slaqr1.o slaqr2.o slaqr3.o slaqr4.o slaqr5.o \
+ slaqtr.o slar1v.o slar2v.o ilaslr.o ilaslc.o \
+ slarf.o slarfb.o slarfg.o slarft.o slarfx.o slargv.o \
+ slarrv.o slartv.o slarfp.o \
+ slarz.o slarzb.o slarzt.o slaswp.o slasy2.o slasyf.o \
+ slatbs.o slatdf.o slatps.o slatrd.o slatrs.o slatrz.o slatzm.o \
+ slauu2.o slauum.o sopgtr.o sopmtr.o sorg2l.o sorg2r.o \
+ sorgbr.o sorghr.o sorgl2.o sorglq.o sorgql.o sorgqr.o sorgr2.o \
+ sorgrq.o sorgtr.o sorm2l.o sorm2r.o \
+ sormbr.o sormhr.o sorml2.o sormlq.o sormql.o sormqr.o sormr2.o \
+ sormr3.o sormrq.o sormrz.o sormtr.o spbcon.o spbequ.o spbrfs.o \
+ spbstf.o spbsv.o spbsvx.o \
+ spbtf2.o spbtrf.o spbtrs.o spocon.o spoequ.o sporfs.o sposv.o \
+ sposvx.o spotf2.o spotrf.o spotri.o spotrs.o spstrf.o spstf2.o \
+ sppcon.o sppequ.o \
+ spprfs.o sppsv.o sppsvx.o spptrf.o spptri.o spptrs.o sptcon.o \
+ spteqr.o sptrfs.o sptsv.o sptsvx.o spttrs.o sptts2.o srscl.o \
+ ssbev.o ssbevd.o ssbevx.o ssbgst.o ssbgv.o ssbgvd.o ssbgvx.o \
+ ssbtrd.o sspcon.o sspev.o sspevd.o sspevx.o sspgst.o \
+ sspgv.o sspgvd.o sspgvx.o ssprfs.o sspsv.o sspsvx.o ssptrd.o \
+ ssptrf.o ssptri.o ssptrs.o sstegr.o sstein.o sstev.o sstevd.o sstevr.o \
+ sstevx.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 ssytrs.o stbcon.o \
+ stbrfs.o stbtrs.o stgevc.o stgex2.o stgexc.o stgsen.o \
+ stgsja.o stgsna.o stgsy2.o stgsyl.o stpcon.o stprfs.o stptri.o \
+ stptrs.o \
+ strcon.o strevc.o strexc.o strrfs.o strsen.o strsna.o strsyl.o \
+ strti2.o strtri.o strtrs.o stzrqf.o stzrzf.o sstemr.o \
+ slansf.o spftrf.o spftri.o spftrs.o ssfrk.o stfsm.o stftri.o stfttp.o \
+ stfttr.o stpttf.o stpttr.o strttf.o strttp.o \
+ sgejsv.o sgesvj.o sgsvj0.o sgsvj1.o \
+ sgeequb.o ssyequb.o spoequb.o sgbequb.o
+
+SXLASRC = sgesvxx.o sgerfsx.o sla_gerfsx_extended.o sla_geamv.o \
+ sla_gercond.o sla_rpvgrw.o ssysvxx.o ssyrfsx.o \
+ sla_syrfsx_extended.o sla_syamv.o sla_syrcond.o sla_syrpvgrw.o \
+ sposvxx.o sporfsx.o sla_porfsx_extended.o sla_porcond.o \
+ sla_porpvgrw.o sgbsvxx.o sgbrfsx.o sla_gbrfsx_extended.o \
+ sla_gbamv.o sla_gbrcond.o sla_gbrpvgrw.o sla_lin_berr.o slarscl2.o \
+ slascl2.o sla_wwaddw.o
+
+CLASRC = \
+ cbdsqr.o cgbbrd.o cgbcon.o cgbequ.o cgbrfs.o cgbsv.o cgbsvx.o \
+ cgbtf2.o cgbtrf.o cgbtrs.o cgebak.o cgebal.o cgebd2.o cgebrd.o \
+ cgecon.o cgeequ.o cgees.o cgeesx.o cgeev.o cgeevx.o \
+ cgegs.o cgegv.o cgehd2.o cgehrd.o cgelq2.o cgelqf.o \
+ cgels.o cgelsd.o cgelss.o cgelsx.o cgelsy.o cgeql2.o cgeqlf.o cgeqp3.o \
+ cgeqpf.o cgeqr2.o cgeqrf.o cgerfs.o cgerq2.o cgerqf.o \
+ cgesc2.o cgesdd.o cgesv.o cgesvd.o cgesvx.o cgetc2.o cgetf2.o cgetrf.o \
+ cgetri.o cgetrs.o \
+ cggbak.o cggbal.o cgges.o cggesx.o cggev.o cggevx.o cggglm.o \
+ cgghrd.o cgglse.o cggqrf.o cggrqf.o \
+ cggsvd.o cggsvp.o \
+ cgtcon.o cgtrfs.o cgtsv.o cgtsvx.o cgttrf.o cgttrs.o cgtts2.o chbev.o \
+ chbevd.o chbevx.o chbgst.o chbgv.o chbgvd.o chbgvx.o chbtrd.o \
+ checon.o cheev.o cheevd.o cheevr.o cheevx.o chegs2.o chegst.o \
+ chegv.o chegvd.o chegvx.o cherfs.o chesv.o chesvx.o chetd2.o \
+ chetf2.o chetrd.o \
+ chetrf.o chetri.o chetrs.o chgeqz.o chpcon.o chpev.o chpevd.o \
+ chpevx.o chpgst.o chpgv.o chpgvd.o chpgvx.o chprfs.o chpsv.o \
+ chpsvx.o \
+ chptrd.o chptrf.o chptri.o chptrs.o chsein.o chseqr.o clabrd.o \
+ clacgv.o clacon.o clacn2.o clacp2.o clacpy.o clacrm.o clacrt.o cladiv.o \
+ claed0.o claed7.o claed8.o \
+ claein.o claesy.o claev2.o clags2.o clagtm.o \
+ clahef.o clahqr.o \
+ clahrd.o clahr2.o claic1.o clals0.o clalsa.o clalsd.o clangb.o clange.o clangt.o \
+ clanhb.o clanhe.o \
+ clanhp.o clanhs.o clanht.o clansb.o clansp.o clansy.o clantb.o \
+ clantp.o clantr.o clapll.o clapmt.o clarcm.o claqgb.o claqge.o \
+ claqhb.o claqhe.o claqhp.o claqp2.o claqps.o claqsb.o \
+ claqr0.o claqr1.o claqr2.o claqr3.o claqr4.o claqr5.o \
+ claqsp.o claqsy.o clar1v.o clar2v.o ilaclr.o ilaclc.o \
+ clarf.o clarfb.o clarfg.o clarft.o clarfp.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 clatbs.o clatdf.o clatps.o clatrd.o clatrs.o clatrz.o \
+ clatzm.o clauu2.o clauum.o cpbcon.o cpbequ.o cpbrfs.o cpbstf.o cpbsv.o \
+ cpbsvx.o cpbtf2.o cpbtrf.o cpbtrs.o cpocon.o cpoequ.o cporfs.o \
+ cposv.o cposvx.o cpotf2.o cpotrf.o cpotri.o cpotrs.o cpstrf.o cpstf2.o \
+ cppcon.o cppequ.o cpprfs.o cppsv.o cppsvx.o cpptrf.o cpptri.o cpptrs.o \
+ cptcon.o cpteqr.o cptrfs.o cptsv.o cptsvx.o cpttrf.o cpttrs.o cptts2.o \
+ crot.o cspcon.o cspmv.o cspr.o csprfs.o cspsv.o \
+ cspsvx.o csptrf.o csptri.o csptrs.o csrscl.o cstedc.o \
+ cstegr.o cstein.o csteqr.o csycon.o csymv.o \
+ csyr.o csyrfs.o csysv.o csysvx.o csytf2.o csytrf.o csytri.o \
+ csytrs.o ctbcon.o ctbrfs.o ctbtrs.o ctgevc.o ctgex2.o \
+ ctgexc.o ctgsen.o ctgsja.o ctgsna.o ctgsy2.o ctgsyl.o ctpcon.o \
+ ctprfs.o ctptri.o \
+ ctptrs.o ctrcon.o ctrevc.o ctrexc.o ctrrfs.o ctrsen.o ctrsna.o \
+ ctrsyl.o ctrti2.o ctrtri.o ctrtrs.o ctzrqf.o ctzrzf.o cung2l.o cung2r.o \
+ cungbr.o cunghr.o cungl2.o cunglq.o cungql.o cungqr.o cungr2.o \
+ cungrq.o cungtr.o cunm2l.o cunm2r.o cunmbr.o cunmhr.o cunml2.o \
+ cunmlq.o cunmql.o cunmqr.o cunmr2.o cunmr3.o cunmrq.o cunmrz.o \
+ cunmtr.o cupgtr.o cupmtr.o icmax1.o scsum1.o cstemr.o \
+ chfrk.o ctfttp.o clanhf.o cpftrf.o cpftri.o cpftrs.o ctfsm.o ctftri.o \
+ ctfttr.o ctpttf.o ctpttr.o ctrttf.o ctrttp.o \
+ cgeequb.o cgbequb.o csyequb.o cpoequb.o cheequb.o
+
+CXLASRC = cgesvxx.o cgerfsx.o cla_gerfsx_extended.o cla_geamv.o \
+ cla_gercond_c.o cla_gercond_x.o cla_rpvgrw.o \
+ csysvxx.o csyrfsx.o cla_syrfsx_extended.o cla_syamv.o \
+ cla_syrcond_c.o cla_syrcond_x.o cla_syrpvgrw.o \
+ cposvxx.o cporfsx.o cla_porfsx_extended.o \
+ cla_porcond_c.o cla_porcond_x.o cla_porpvgrw.o \
+ cgbsvxx.o cgbrfsx.o cla_gbrfsx_extended.o cla_gbamv.o \
+ cla_gbrcond_c.o cla_gbrcond_x.o cla_gbrpvgrw.o \
+ chesvxx.o cherfsx.o cla_herfsx_extended.o cla_heamv.o \
+ cla_hercond_c.o cla_hercond_x.o cla_herpvgrw.o \
+ cla_lin_berr.o clarscl2.o clascl2.o cla_wwaddw.o
+
+DLASRC = \
+ dgbbrd.o dgbcon.o dgbequ.o dgbrfs.o dgbsv.o \
+ dgbsvx.o dgbtf2.o dgbtrf.o dgbtrs.o dgebak.o dgebal.o dgebd2.o \
+ dgebrd.o dgecon.o dgeequ.o dgees.o dgeesx.o dgeev.o dgeevx.o \
+ dgegs.o dgegv.o dgehd2.o dgehrd.o dgelq2.o dgelqf.o \
+ dgels.o dgelsd.o dgelss.o dgelsx.o dgelsy.o dgeql2.o dgeqlf.o \
+ dgeqp3.o dgeqpf.o dgeqr2.o dgeqrf.o dgerfs.o dgerq2.o dgerqf.o \
+ dgesc2.o dgesdd.o dgesv.o dgesvd.o dgesvx.o dgetc2.o dgetf2.o \
+ dgetrf.o dgetri.o \
+ dgetrs.o dggbak.o dggbal.o dgges.o dggesx.o dggev.o dggevx.o \
+ dggglm.o dgghrd.o dgglse.o dggqrf.o \
+ dggrqf.o dggsvd.o dggsvp.o dgtcon.o dgtrfs.o dgtsv.o \
+ dgtsvx.o dgttrf.o dgttrs.o dgtts2.o dhgeqz.o \
+ dhsein.o dhseqr.o dlabrd.o dlacon.o dlacn2.o \
+ dlaein.o dlaexc.o dlag2.o dlags2.o dlagtm.o dlagv2.o dlahqr.o \
+ dlahrd.o dlahr2.o dlaic1.o dlaln2.o dlals0.o dlalsa.o dlalsd.o \
+ dlangb.o dlange.o dlangt.o dlanhs.o dlansb.o dlansp.o \
+ dlansy.o dlantb.o dlantp.o dlantr.o dlanv2.o \
+ dlapll.o dlapmt.o \
+ dlaqgb.o dlaqge.o dlaqp2.o dlaqps.o dlaqsb.o dlaqsp.o dlaqsy.o \
+ dlaqr0.o dlaqr1.o dlaqr2.o dlaqr3.o dlaqr4.o dlaqr5.o \
+ dlaqtr.o dlar1v.o dlar2v.o iladlr.o iladlc.o \
+ dlarf.o dlarfb.o dlarfg.o dlarft.o dlarfx.o dlargv.o \
+ dlarrv.o dlartv.o dlarfp.o \
+ dlarz.o dlarzb.o dlarzt.o dlaswp.o dlasy2.o dlasyf.o \
+ dlatbs.o dlatdf.o dlatps.o dlatrd.o dlatrs.o dlatrz.o dlatzm.o dlauu2.o \
+ dlauum.o dopgtr.o dopmtr.o dorg2l.o dorg2r.o \
+ dorgbr.o dorghr.o dorgl2.o dorglq.o dorgql.o dorgqr.o dorgr2.o \
+ dorgrq.o dorgtr.o dorm2l.o dorm2r.o \
+ dormbr.o dormhr.o dorml2.o dormlq.o dormql.o dormqr.o dormr2.o \
+ dormr3.o dormrq.o dormrz.o dormtr.o dpbcon.o dpbequ.o dpbrfs.o \
+ dpbstf.o dpbsv.o dpbsvx.o \
+ dpbtf2.o dpbtrf.o dpbtrs.o dpocon.o dpoequ.o dporfs.o dposv.o \
+ dposvx.o dpotf2.o dpotrf.o dpotri.o dpotrs.o dpstrf.o dpstf2.o \
+ dppcon.o dppequ.o \
+ dpprfs.o dppsv.o dppsvx.o dpptrf.o dpptri.o dpptrs.o dptcon.o \
+ dpteqr.o dptrfs.o dptsv.o dptsvx.o dpttrs.o dptts2.o drscl.o \
+ dsbev.o dsbevd.o dsbevx.o dsbgst.o dsbgv.o dsbgvd.o dsbgvx.o \
+ dsbtrd.o dspcon.o dspev.o dspevd.o dspevx.o dspgst.o \
+ dspgv.o dspgvd.o dspgvx.o dsprfs.o dspsv.o dspsvx.o dsptrd.o \
+ dsptrf.o dsptri.o dsptrs.o dstegr.o dstein.o dstev.o dstevd.o dstevr.o \
+ dstevx.o dsycon.o dsyev.o dsyevd.o dsyevr.o \
+ dsyevx.o dsygs2.o dsygst.o dsygv.o dsygvd.o dsygvx.o dsyrfs.o \
+ dsysv.o dsysvx.o \
+ dsytd2.o dsytf2.o dsytrd.o dsytrf.o dsytri.o dsytrs.o dtbcon.o \
+ dtbrfs.o dtbtrs.o dtgevc.o dtgex2.o dtgexc.o dtgsen.o \
+ dtgsja.o dtgsna.o dtgsy2.o dtgsyl.o dtpcon.o dtprfs.o dtptri.o \
+ dtptrs.o \
+ dtrcon.o dtrevc.o dtrexc.o dtrrfs.o dtrsen.o dtrsna.o dtrsyl.o \
+ dtrti2.o dtrtri.o dtrtrs.o dtzrqf.o dtzrzf.o dstemr.o \
+ dsgesv.o dsposv.o dlag2s.o slag2d.o dlat2s.o \
+ dlansf.o dpftrf.o dpftri.o dpftrs.o dsfrk.o dtfsm.o dtftri.o dtfttp.o \
+ dtfttr.o dtpttf.o dtpttr.o dtrttf.o dtrttp.o \
+ dgejsv.o dgesvj.o dgsvj0.o dgsvj1.o \
+ dgeequb.o dsyequb.o dpoequb.o dgbequb.o
+
+DXLASRC = dgesvxx.o dgerfsx.o dla_gerfsx_extended.o dla_geamv.o \
+ dla_gercond.o dla_rpvgrw.o dsysvxx.o dsyrfsx.o \
+ dla_syrfsx_extended.o dla_syamv.o dla_syrcond.o dla_syrpvgrw.o \
+ dposvxx.o dporfsx.o dla_porfsx_extended.o dla_porcond.o \
+ dla_porpvgrw.o dgbsvxx.o dgbrfsx.o dla_gbrfsx_extended.o \
+ dla_gbamv.o dla_gbrcond.o dla_gbrpvgrw.o dla_lin_berr.o dlarscl2.o \
+ dlascl2.o dla_wwaddw.o
+
+ZLASRC = \
+ zbdsqr.o zgbbrd.o zgbcon.o zgbequ.o zgbrfs.o zgbsv.o zgbsvx.o \
+ zgbtf2.o zgbtrf.o zgbtrs.o zgebak.o zgebal.o zgebd2.o zgebrd.o \
+ zgecon.o zgeequ.o zgees.o zgeesx.o zgeev.o zgeevx.o \
+ zgegs.o zgegv.o zgehd2.o zgehrd.o zgelq2.o zgelqf.o \
+ zgels.o zgelsd.o zgelss.o zgelsx.o zgelsy.o zgeql2.o zgeqlf.o zgeqp3.o \
+ zgeqpf.o zgeqr2.o zgeqrf.o zgerfs.o zgerq2.o zgerqf.o \
+ zgesc2.o zgesdd.o zgesv.o zgesvd.o zgesvx.o zgetc2.o zgetf2.o zgetrf.o \
+ zgetri.o zgetrs.o \
+ zggbak.o zggbal.o zgges.o zggesx.o zggev.o zggevx.o zggglm.o \
+ zgghrd.o zgglse.o zggqrf.o zggrqf.o \
+ zggsvd.o zggsvp.o \
+ zgtcon.o zgtrfs.o zgtsv.o zgtsvx.o zgttrf.o zgttrs.o zgtts2.o zhbev.o \
+ zhbevd.o zhbevx.o zhbgst.o zhbgv.o zhbgvd.o zhbgvx.o zhbtrd.o \
+ zhecon.o zheev.o zheevd.o zheevr.o zheevx.o zhegs2.o zhegst.o \
+ zhegv.o zhegvd.o zhegvx.o zherfs.o zhesv.o zhesvx.o zhetd2.o \
+ zhetf2.o zhetrd.o \
+ zhetrf.o zhetri.o zhetrs.o zhgeqz.o zhpcon.o zhpev.o zhpevd.o \
+ zhpevx.o zhpgst.o zhpgv.o zhpgvd.o zhpgvx.o zhprfs.o zhpsv.o \
+ zhpsvx.o \
+ zhptrd.o zhptrf.o zhptri.o zhptrs.o zhsein.o zhseqr.o zlabrd.o \
+ zlacgv.o zlacon.o zlacn2.o zlacp2.o zlacpy.o zlacrm.o zlacrt.o zladiv.o \
+ zlaed0.o zlaed7.o zlaed8.o \
+ zlaein.o zlaesy.o zlaev2.o zlags2.o zlagtm.o \
+ zlahef.o zlahqr.o \
+ zlahrd.o zlahr2.o zlaic1.o zlals0.o zlalsa.o zlalsd.o zlangb.o zlange.o \
+ zlangt.o zlanhb.o \
+ zlanhe.o \
+ zlanhp.o zlanhs.o zlanht.o zlansb.o zlansp.o zlansy.o zlantb.o \
+ zlantp.o zlantr.o zlapll.o zlapmt.o zlaqgb.o zlaqge.o \
+ zlaqhb.o zlaqhe.o zlaqhp.o zlaqp2.o zlaqps.o zlaqsb.o \
+ zlaqr0.o zlaqr1.o zlaqr2.o zlaqr3.o zlaqr4.o zlaqr5.o \
+ zlaqsp.o zlaqsy.o zlar1v.o zlar2v.o ilazlr.o ilazlc.o \
+ zlarcm.o zlarf.o zlarfb.o \
+ zlarfg.o zlarft.o zlarfp.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 \
+ zlatbs.o zlatdf.o zlatps.o zlatrd.o zlatrs.o zlatrz.o zlatzm.o zlauu2.o \
+ zlauum.o zpbcon.o zpbequ.o zpbrfs.o zpbstf.o zpbsv.o \
+ zpbsvx.o zpbtf2.o zpbtrf.o zpbtrs.o zpocon.o zpoequ.o zporfs.o \
+ zposv.o zposvx.o zpotf2.o zpotrf.o zpotri.o zpotrs.o zpstrf.o zpstf2.o \
+ zppcon.o zppequ.o zpprfs.o zppsv.o zppsvx.o zpptrf.o zpptri.o zpptrs.o \
+ zptcon.o zpteqr.o zptrfs.o zptsv.o zptsvx.o zpttrf.o zpttrs.o zptts2.o \
+ zrot.o zspcon.o zspmv.o zspr.o zsprfs.o zspsv.o \
+ zspsvx.o zsptrf.o zsptri.o zsptrs.o zdrscl.o zstedc.o \
+ zstegr.o zstein.o zsteqr.o zsycon.o zsymv.o \
+ zsyr.o zsyrfs.o zsysv.o zsysvx.o zsytf2.o zsytrf.o zsytri.o \
+ zsytrs.o ztbcon.o ztbrfs.o ztbtrs.o ztgevc.o ztgex2.o \
+ ztgexc.o ztgsen.o ztgsja.o ztgsna.o ztgsy2.o ztgsyl.o ztpcon.o \
+ ztprfs.o ztptri.o \
+ ztptrs.o ztrcon.o ztrevc.o ztrexc.o ztrrfs.o ztrsen.o ztrsna.o \
+ ztrsyl.o ztrti2.o ztrtri.o ztrtrs.o ztzrqf.o ztzrzf.o zung2l.o \
+ zung2r.o zungbr.o zunghr.o zungl2.o zunglq.o zungql.o zungqr.o zungr2.o \
+ zungrq.o zungtr.o zunm2l.o zunm2r.o zunmbr.o zunmhr.o zunml2.o \
+ zunmlq.o zunmql.o zunmqr.o zunmr2.o zunmr3.o zunmrq.o zunmrz.o \
+ zunmtr.o zupgtr.o \
+ zupmtr.o izmax1.o dzsum1.o zstemr.o \
+ zcgesv.o zcposv.o zlag2c.o clag2z.o zlat2c.o \
+ zhfrk.o ztfttp.o zlanhf.o zpftrf.o zpftri.o zpftrs.o ztfsm.o ztftri.o \
+ ztfttr.o ztpttf.o ztpttr.o ztrttf.o ztrttp.o \
+ zgeequb.o zgbequb.o zsyequb.o zpoequb.o zheequb.o
+
+ZXLASRC = zgesvxx.o zgerfsx.o zla_gerfsx_extended.o zla_geamv.o \
+ zla_gercond_c.o zla_gercond_x.o zla_rpvgrw.o zsysvxx.o zsyrfsx.o \
+ zla_syrfsx_extended.o zla_syamv.o zla_syrcond_c.o zla_syrcond_x.o \
+ zla_syrpvgrw.o zposvxx.o zporfsx.o zla_porfsx_extended.o \
+ zla_porcond_c.o zla_porcond_x.o zla_porpvgrw.o zgbsvxx.o zgbrfsx.o \
+ zla_gbrfsx_extended.o zla_gbamv.o zla_gbrcond_c.o zla_gbrcond_x.o \
+ zla_gbrpvgrw.o zhesvxx.o zherfsx.o zla_herfsx_extended.o \
+ zla_heamv.o zla_hercond_c.o zla_hercond_x.o zla_herpvgrw.o \
+ zla_lin_berr.o zlarscl2.o zlascl2.o zla_wwaddw.o
+
+all: ../$(LAPACKLIB)
+
+ifdef USEXBLAS
+ALLXOBJ=$(SXLASRC) $(DXLASRC) $(CXLASRC) $(ZXLASRC) $(ALLXAUX)
+endif
+
+ALLOBJ=$(SLASRC) $(DLASRC) $(CLASRC) $(ZLASRC) $(SCLAUX) $(DZLAUX) \
+ $(ALLAUX)
+
+../$(LAPACKLIB): $(ALLOBJ) $(ALLXOBJ)
+ $(ARCH) $(ARCHFLAGS) $@ $(ALLOBJ) $(ALLXOBJ)
+ $(RANLIB) $@
+
+single: $(SLASRC) $(ALLAUX) $(SCLAUX)
+ $(ARCH) $(ARCHFLAGS) ../$(LAPACKLIB) $(SLASRC) $(ALLAUX) \
+ $(SCLAUX)
+ $(RANLIB) ../$(LAPACKLIB)
+
+complex: $(CLASRC) $(ALLAUX) $(SCLAUX)
+ $(ARCH) $(ARCHFLAGS) ../$(LAPACKLIB) $(CLASRC) $(ALLAUX) \
+ $(SCLAUX)
+ $(RANLIB) ../$(LAPACKLIB)
+
+double: $(DLASRC) $(ALLAUX) $(DZLAUX)
+ $(ARCH) $(ARCHFLAGS) ../$(LAPACKLIB) $(DLASRC) $(ALLAUX) \
+ $(DZLAUX)
+ $(RANLIB) ../$(LAPACKLIB)
+
+complex16: $(ZLASRC) $(ALLAUX) $(DZLAUX)
+ $(ARCH) $(ARCHFLAGS) ../$(LAPACKLIB) $(ZLASRC) $(ALLAUX) \
+ $(DZLAUX)
+ $(RANLIB) ../$(LAPACKLIB)
+
+$(ALLAUX): $(FRC)
+$(SCLAUX): $(FRC)
+$(DZLAUX): $(FRC)
+$(SLASRC): $(FRC)
+$(CLASRC): $(FRC)
+$(DLASRC): $(FRC)
+$(ZLASRC): $(FRC)
+ifdef USEXBLAS
+$(ALLXAUX): $(FRC)
+$(SXLASRC): $(FRC)
+$(CXLASRC): $(FRC)
+$(DXLASRC): $(FRC)
+$(ZXLASRC): $(FRC)
+endif
+
+FRC:
+ @FRC=$(FRC)
+
+clean:
+ rm -f *.o
+
+.c.o:
+ $(CC) $(CFLAGS) -I../INCLUDE -c $<
+
+slaruv.o: slaruv.c ; $(CC) $(NOOPT) -I../INCLUDE -c $< -o $@
+dlaruv.o: dlaruv.c ; $(CC) $(NOOPT) -I../INCLUDE -c $< -o $@
+sla_wwaddw.o: sla_wwaddw.c ; $(CC) $(NOOPT) -I../INCLUDE -c $< -o $@
+dla_wwaddw.o: dla_wwaddw.c ; $(CC) $(NOOPT) -I../INCLUDE -c $< -o $@
+cla_wwaddw.o: cla_wwaddw.c ; $(CC) $(NOOPT) -I../INCLUDE -c $< -o $@
+zla_wwaddw.o: zla_wwaddw.c ; $(CC) $(NOOPT) -I../INCLUDE -c $< -o $@
+
diff --git a/SRC/VARIANTS/Makefile b/SRC/VARIANTS/Makefile
new file mode 100644
index 0000000..e67beae
--- /dev/null
+++ b/SRC/VARIANTS/Makefile
@@ -0,0 +1,67 @@
+include ../../make.inc
+
+#######################################################################
+# This is the makefile to create a the variants libraries for LAPACK.
+# The files are organized as follows:
+# CHOLRL -- Right looking block version of the algorithm, calling Level 3 BLAS
+# CHOLTOP -- Top looking block version of the algorithm, calling Level 3 BLAS
+# LUCR -- Crout Level 3 BLAS version of LU factorization
+# LULL -- left-looking Level 3 BLAS version of LU factorization
+# QRLL -- left-looking Level 3 BLAS version of QR factorization
+# LUREC -- an iterative version of Sivan Toledo's recursive LU algorithm[1].
+# For square matrices, this iterative versions should
+# be within a factor of two of the optimum number of memory transfers.
+#
+# [1] Toledo, S. 1997. Locality of Reference in LU Decomposition with
+# Partial Pivoting. SIAM J. Matrix Anal. Appl. 18, 4 (Oct. 1997),
+# 1065-1081. http://dx.doi.org/10.1137/S0895479896297744
+#######################################################################
+
+VARIANTSDIR=LIB
+
+CHOLRL = cholesky/RL/cpotrf.o cholesky/RL/dpotrf.o cholesky/RL/spotrf.o cholesky/RL/zpotrf.o
+
+CHOLTOP = cholesky/TOP/cpotrf.o cholesky/TOP/dpotrf.o cholesky/TOP/spotrf.o cholesky/TOP/zpotrf.o
+
+LUCR = lu/CR/cgetrf.o lu/CR/dgetrf.o lu/CR/sgetrf.o lu/CR/zgetrf.o
+
+LULL = lu/LL/cgetrf.o lu/LL/dgetrf.o lu/LL/sgetrf.o lu/LL/zgetrf.o
+
+LUREC = lu/REC/cgetrf.o lu/REC/dgetrf.o lu/REC/sgetrf.o lu/REC/zgetrf.o
+
+QRLL = qr/LL/cgeqrf.o qr/LL/dgeqrf.o qr/LL/sgeqrf.o qr/LL/zgeqrf.o qr/LL/sceil.o
+
+
+all: cholrl choltop lucr lull lurec qrll
+
+cholrl: $(CHOLRL)
+ $(ARCH) $(ARCHFLAGS) $(VARIANTSDIR)/cholrl.a $(CHOLRL)
+ $(RANLIB) $(VARIANTSDIR)/cholrl.a
+
+choltop: $(CHOLTOP)
+ $(ARCH) $(ARCHFLAGS) $(VARIANTSDIR)/choltop.a $(CHOLTOP)
+ $(RANLIB) $(VARIANTSDIR)/choltop.a
+
+lucr: $(LUCR)
+ $(ARCH) $(ARCHFLAGS) $(VARIANTSDIR)/lucr.a $(LUCR)
+ $(RANLIB) $(VARIANTSDIR)/lucr.a
+
+lull: $(LULL)
+ $(ARCH) $(ARCHFLAGS) $(VARIANTSDIR)/lull.a $(LULL)
+ $(RANLIB) $(VARIANTSDIR)/lull.a
+
+lurec: $(LUREC)
+ $(ARCH) $(ARCHFLAGS) $(VARIANTSDIR)/lurec.a $(LUREC)
+ $(RANLIB) $(VARIANTSDIR)/lurec.a
+
+qrll: $(QRLL)
+ $(ARCH) $(ARCHFLAGS) $(VARIANTSDIR)/qrll.a $(QRLL)
+ $(RANLIB) $(VARIANTSDIR)/qrll.a
+
+
+.c.o:
+ $(CC) $(CFLAGS) -I../../INCLUDE -c $< -o $@
+
+clean:
+ rm -f $(CHOLRL) $(CHOLTOP) $(LUCR) $(LULL) $(LUREC) $(QRLL) \
+ $(VARIANTSDIR)/*.a
diff --git a/SRC/VARIANTS/README b/SRC/VARIANTS/README
new file mode 100644
index 0000000..6b4f325
--- /dev/null
+++ b/SRC/VARIANTS/README
@@ -0,0 +1,84 @@
+ ===============
+ = README File =
+ ===============
+
+This README File is for the LAPACK driver variants.
+It is composed of 5 sections:
+ - Description: contents a quick description of each of the variants. For a more detailed description please refer to LAWN XXX.
+ - Build
+ - Testing
+ - Linking your program
+ - Support
+
+Author: Julie LANGOU, May 2008
+
+===============
+= DESCRIPTION =
+===============
+
+This directory contains several variants of LAPACK routines in single/double/complex/double complex precision:
+ - [sdcz]getrf with LU Crout Level 3 BLAS version algorithm [2]- Directory: SRC/VARIANTS/lu/CR
+ - [sdcz]getrf with LU Left Looking Level 3 BLAS version algorithm [2]- Directory: SRC/VARIANTS/lu/LL
+ - [sdcz]getrf with Sivan Toledo's recursive LU algorithm [1] - Directory: SRC/VARIANTS/lu/REC
+ - [sdcz]geqrf with QR Left Looking Level 3 BLAS version algorithm [2]- Directory: SRC/VARIANTS/qr/LL
+ - [sdcz]potrf with Cholesky Right Looking Level 3 BLAS version algorithm [2]- Directory: SRC/VARIANTS/cholesky/RL
+ - [sdcz]potrf with Cholesky Top Level 3 BLAS version algorithm [2]- Directory: SRC/VARIANTS/cholesky/TOP
+
+References:For a more detailed description please refer to
+ - [1] Toledo, S. 1997. Locality of Reference in LU Decomposition with Partial Pivoting. SIAM J. Matrix Anal. Appl. 18, 4 (Oct. 1997),
+ 1065-1081. http://dx.doi.org/10.1137/S0895479896297744
+ - [2]LAWN XXX
+
+=========
+= BUILD =
+=========
+
+These variants are compiled by default in the build process but they are not tested by default.
+The build process creates one new library per variants in the four arithmetics (singel/double/comple/double complex).
+The libraries are in the SRC/VARIANTS/LIB directory.
+
+Corresponding libraries created in SRC/VARIANTS/LIB:
+ - LU Crout : lucr.a
+ - LU Left Looking : lull.a
+ - LU Sivan Toledo's recursive : lurec.a
+ - QR Left Looking : qrll.a
+ - Cholesky Right Looking : cholrl.a
+ - Cholesky Top : choltop.a
+
+
+===========
+= TESTING =
+===========
+
+To test these variants you can type 'make variants-testing'
+This will rerun the linear methods testings once per variants and append the short name of the variants to the output files.
+You should then see the following files in the TESTING directory:
+[scdz]test_cholrl.out
+[scdz]test_choltop.out
+[scdz]test_lucr.out
+[scdz]test_lull.out
+[scdz]test_lurec.out
+[scdz]test_qrll.out
+
+========================
+= LINKING YOUR PROGRAM =
+========================
+
+You just need to add the variants methods library in your linking sequence before your lapack libary.
+Here is a quick example for LU
+
+Default using LU Right Looking version:
+ $(FORTRAN) -c myprog.f
+ $(FORTRAN) -o myexe myprog.o $(LAPACKLIB) $(BLASLIB)
+
+Using LU Left Looking version:
+ $(FORTRAN) -c myprog.f
+ $(FORTRAN) -o myexe myprog.o $(PATH TO LAPACK/SRC/VARIANTS/LIB)/lull.a $(LAPACKLIB) $(BLASLIB)
+
+===========
+= SUPPORT =
+===========
+
+You can use either LAPACK forum or the LAPACK mailing list to get support.
+LAPACK forum : http://icl.cs.utk.edu/lapack-forum
+LAPACK mailing list : lapack at cs.utk.edu
diff --git a/SRC/VARIANTS/cholesky/RL/cpotrf.c b/SRC/VARIANTS/cholesky/RL/cpotrf.c
new file mode 100644
index 0000000..d354b17
--- /dev/null
+++ b/SRC/VARIANTS/cholesky/RL/cpotrf.c
@@ -0,0 +1,233 @@
+/* cpotrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b20 = -1.f;
+static real c_b21 = 1.f;
+
+/* Subroutine */ int cpotrf_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer j, jb, nb;
+ extern /* Subroutine */ int cherk_(char *, char *, integer *, integer *,
+ real *, complex *, integer *, real *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *);
+ logical upper;
+ extern /* Subroutine */ int cpotf2_(char *, integer *, complex *, integer
+ *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* March 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPOTRF computes the Cholesky factorization of a real Hermitian */
+/* positive definite matrix A. */
+
+/* The factorization has the form */
+/* A = U**H * U, if UPLO = 'U', or */
+/* A = L * L**H, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* This is the right looking block version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (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, the factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPOTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "CPOTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code. */
+
+ cpotf2_(uplo, n, &a[a_offset], lda, info);
+ } else {
+
+/* Use blocked code. */
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+ cpotf2_("Upper", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+ if (j + jb <= *n) {
+
+/* Updating the trailing submatrix. */
+
+ i__3 = *n - j - jb + 1;
+ ctrsm_("Left", "Upper", "Conjugate Transpose", "Non-unit",
+ &jb, &i__3, &c_b1, &a[j + j * a_dim1], lda, &a[j
+ + (j + jb) * a_dim1], lda);
+ i__3 = *n - j - jb + 1;
+ cherk_("Upper", "Conjugate transpose", &i__3, &jb, &c_b20,
+ &a[j + (j + jb) * a_dim1], lda, &c_b21, &a[j +
+ jb + (j + jb) * a_dim1], lda);
+ }
+/* L10: */
+ }
+
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+ cpotf2_("Lower", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+ if (j + jb <= *n) {
+
+/* Updating the trailing submatrix. */
+
+ i__3 = *n - j - jb + 1;
+ ctrsm_("Right", "Lower", "Conjugate Transpose", "Non-unit"
+, &i__3, &jb, &c_b1, &a[j + j * a_dim1], lda, &a[
+ j + jb + j * a_dim1], lda);
+ i__3 = *n - j - jb + 1;
+ cherk_("Lower", "No Transpose", &i__3, &jb, &c_b20, &a[j
+ + jb + j * a_dim1], lda, &c_b21, &a[j + jb + (j +
+ jb) * a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+ }
+ goto L40;
+
+L30:
+ *info = *info + j - 1;
+
+L40:
+ return 0;
+
+/* End of CPOTRF */
+
+} /* cpotrf_ */
diff --git a/SRC/VARIANTS/cholesky/RL/dpotrf.c b/SRC/VARIANTS/cholesky/RL/dpotrf.c
new file mode 100644
index 0000000..7ce6fb0
--- /dev/null
+++ b/SRC/VARIANTS/cholesky/RL/dpotrf.c
@@ -0,0 +1,233 @@
+/* dpotrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b17 = 1.;
+static doublereal c_b20 = -1.;
+
+/* Subroutine */ int dpotrf_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer j, jb, nb;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *), dpotf2_(char *, integer *,
+ doublereal *, integer *, integer *), xerbla_(char *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* March 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPOTRF computes the Cholesky factorization of a real symmetric */
+/* positive definite matrix A. */
+
+/* The factorization has the form */
+/* A = U**T * U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* This is the right looking block version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPOTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "DPOTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code. */
+
+ dpotf2_(uplo, n, &a[a_offset], lda, info);
+ } else {
+
+/* Use blocked code. */
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+ dpotf2_("Upper", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+ if (j + jb <= *n) {
+
+/* Updating the trailing submatrix. */
+
+ i__3 = *n - j - jb + 1;
+ dtrsm_("Left", "Upper", "Transpose", "Non-unit", &jb, &
+ i__3, &c_b17, &a[j + j * a_dim1], lda, &a[j + (j
+ + jb) * a_dim1], lda);
+ i__3 = *n - j - jb + 1;
+ dsyrk_("Upper", "Transpose", &i__3, &jb, &c_b20, &a[j + (
+ j + jb) * a_dim1], lda, &c_b17, &a[j + jb + (j +
+ jb) * a_dim1], lda);
+ }
+/* L10: */
+ }
+
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+ dpotf2_("Lower", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+ if (j + jb <= *n) {
+
+/* Updating the trailing submatrix. */
+
+ i__3 = *n - j - jb + 1;
+ dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i__3, &
+ jb, &c_b17, &a[j + j * a_dim1], lda, &a[j + jb +
+ j * a_dim1], lda);
+ i__3 = *n - j - jb + 1;
+ dsyrk_("Lower", "No Transpose", &i__3, &jb, &c_b20, &a[j
+ + jb + j * a_dim1], lda, &c_b17, &a[j + jb + (j +
+ jb) * a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+ }
+ goto L40;
+
+L30:
+ *info = *info + j - 1;
+
+L40:
+ return 0;
+
+/* End of DPOTRF */
+
+} /* dpotrf_ */
diff --git a/SRC/VARIANTS/cholesky/RL/spotrf.c b/SRC/VARIANTS/cholesky/RL/spotrf.c
new file mode 100644
index 0000000..f358e27
--- /dev/null
+++ b/SRC/VARIANTS/cholesky/RL/spotrf.c
@@ -0,0 +1,231 @@
+/* spotrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b17 = 1.f;
+static real c_b20 = -1.f;
+
+/* Subroutine */ int spotrf_(char *uplo, integer *n, real *a, integer *lda,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer j, jb, nb;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), ssyrk_(char *, char *, integer
+ *, integer *, real *, real *, integer *, real *, real *, integer *
+), spotf2_(char *, integer *, real *, integer *,
+ integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* March 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPOTRF computes the Cholesky factorization of a real symmetric */
+/* positive definite matrix A. */
+
+/* The factorization has the form */
+/* A = U**T * U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* This is the right looking block version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPOTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "SPOTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code. */
+
+ spotf2_(uplo, n, &a[a_offset], lda, info);
+ } else {
+
+/* Use blocked code. */
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+ spotf2_("Upper", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+ if (j + jb <= *n) {
+
+/* Updating the trailing submatrix. */
+
+ i__3 = *n - j - jb + 1;
+ strsm_("Left", "Upper", "Transpose", "Non-unit", &jb, &
+ i__3, &c_b17, &a[j + j * a_dim1], lda, &a[j + (j
+ + jb) * a_dim1], lda);
+ i__3 = *n - j - jb + 1;
+ ssyrk_("Upper", "Transpose", &i__3, &jb, &c_b20, &a[j + (
+ j + jb) * a_dim1], lda, &c_b17, &a[j + jb + (j +
+ jb) * a_dim1], lda);
+ }
+/* L10: */
+ }
+
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+ spotf2_("Lower", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+ if (j + jb <= *n) {
+
+/* Updating the trailing submatrix. */
+
+ i__3 = *n - j - jb + 1;
+ strsm_("Right", "Lower", "Transpose", "Non-unit", &i__3, &
+ jb, &c_b17, &a[j + j * a_dim1], lda, &a[j + jb +
+ j * a_dim1], lda);
+ i__3 = *n - j - jb + 1;
+ ssyrk_("Lower", "No Transpose", &i__3, &jb, &c_b20, &a[j
+ + jb + j * a_dim1], lda, &c_b17, &a[j + jb + (j +
+ jb) * a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+ }
+ goto L40;
+
+L30:
+ *info = *info + j - 1;
+
+L40:
+ return 0;
+
+/* End of SPOTRF */
+
+} /* spotrf_ */
diff --git a/SRC/VARIANTS/cholesky/RL/zpotrf.c b/SRC/VARIANTS/cholesky/RL/zpotrf.c
new file mode 100644
index 0000000..c4defaf
--- /dev/null
+++ b/SRC/VARIANTS/cholesky/RL/zpotrf.c
@@ -0,0 +1,233 @@
+/* zpotrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b20 = -1.;
+static doublereal c_b21 = 1.;
+
+/* Subroutine */ int zpotrf_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer j, jb, nb;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zherk_(char *, char *, integer *, integer *,
+ doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ zpotf2_(char *, integer *, doublecomplex *, integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* March 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPOTRF computes the Cholesky factorization of a real Hermitian */
+/* positive definite matrix A. */
+
+/* The factorization has the form */
+/* A = U**H * U, if UPLO = 'U', or */
+/* A = L * L**H, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* This is the right looking block version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (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, the factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPOTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "ZPOTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code. */
+
+ zpotf2_(uplo, n, &a[a_offset], lda, info);
+ } else {
+
+/* Use blocked code. */
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+ zpotf2_("Upper", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+ if (j + jb <= *n) {
+
+/* Updating the trailing submatrix. */
+
+ i__3 = *n - j - jb + 1;
+ ztrsm_("Left", "Upper", "Conjugate Transpose", "Non-unit",
+ &jb, &i__3, &c_b1, &a[j + j * a_dim1], lda, &a[j
+ + (j + jb) * a_dim1], lda);
+ i__3 = *n - j - jb + 1;
+ zherk_("Upper", "Conjugate transpose", &i__3, &jb, &c_b20,
+ &a[j + (j + jb) * a_dim1], lda, &c_b21, &a[j +
+ jb + (j + jb) * a_dim1], lda);
+ }
+/* L10: */
+ }
+
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+ zpotf2_("Lower", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+ if (j + jb <= *n) {
+
+/* Updating the trailing submatrix. */
+
+ i__3 = *n - j - jb + 1;
+ ztrsm_("Right", "Lower", "Conjugate Transpose", "Non-unit"
+, &i__3, &jb, &c_b1, &a[j + j * a_dim1], lda, &a[
+ j + jb + j * a_dim1], lda);
+ i__3 = *n - j - jb + 1;
+ zherk_("Lower", "No Transpose", &i__3, &jb, &c_b20, &a[j
+ + jb + j * a_dim1], lda, &c_b21, &a[j + jb + (j +
+ jb) * a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+ }
+ goto L40;
+
+L30:
+ *info = *info + j - 1;
+
+L40:
+ return 0;
+
+/* End of ZPOTRF */
+
+} /* zpotrf_ */
diff --git a/SRC/VARIANTS/cholesky/TOP/cpotrf.c b/SRC/VARIANTS/cholesky/TOP/cpotrf.c
new file mode 100644
index 0000000..7078269
--- /dev/null
+++ b/SRC/VARIANTS/cholesky/TOP/cpotrf.c
@@ -0,0 +1,227 @@
+/* cpotrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b18 = -1.f;
+static real c_b19 = 1.f;
+
+/* Subroutine */ int cpotrf_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer j, jb, nb;
+ extern /* Subroutine */ int cherk_(char *, char *, integer *, integer *,
+ real *, complex *, integer *, real *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *);
+ logical upper;
+ extern /* Subroutine */ int cpotf2_(char *, integer *, complex *, integer
+ *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* March 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPOTRF computes the Cholesky factorization of a real symmetric */
+/* positive definite matrix A. */
+
+/* The factorization has the form */
+/* A = U**H * U, if UPLO = 'U', or */
+/* A = L * L**H, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* This is the top-looking block version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPOTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "CPOTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code. */
+
+ cpotf2_(uplo, n, &a[a_offset], lda, info);
+ } else {
+
+/* Use blocked code. */
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+
+/* Compute the current block. */
+
+ i__3 = j - 1;
+ ctrsm_("Left", "Upper", "Conjugate Transpose", "Non-unit", &
+ i__3, &jb, &c_b1, &a[a_dim1 + 1], lda, &a[j * a_dim1
+ + 1], lda);
+ i__3 = j - 1;
+ cherk_("Upper", "Conjugate Transpose", &jb, &i__3, &c_b18, &a[
+ j * a_dim1 + 1], lda, &c_b19, &a[j + j * a_dim1], lda);
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+ cpotf2_("Upper", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+/* L10: */
+ }
+
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+
+/* Compute the current block. */
+
+ i__3 = j - 1;
+ ctrsm_("Right", "Lower", "Conjugate Transpose", "Non-unit", &
+ jb, &i__3, &c_b1, &a[a_dim1 + 1], lda, &a[j + a_dim1],
+ lda);
+ i__3 = j - 1;
+ cherk_("Lower", "No Transpose", &jb, &i__3, &c_b18, &a[j +
+ a_dim1], lda, &c_b19, &a[j + j * a_dim1], lda);
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+ cpotf2_("Lower", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+/* L20: */
+ }
+ }
+ }
+ goto L40;
+
+L30:
+ *info = *info + j - 1;
+
+L40:
+ return 0;
+
+/* End of CPOTRF */
+
+} /* cpotrf_ */
diff --git a/SRC/VARIANTS/cholesky/TOP/dpotrf.c b/SRC/VARIANTS/cholesky/TOP/dpotrf.c
new file mode 100644
index 0000000..f521553
--- /dev/null
+++ b/SRC/VARIANTS/cholesky/TOP/dpotrf.c
@@ -0,0 +1,225 @@
+/* dpotrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b15 = 1.;
+static doublereal c_b18 = -1.;
+
+/* Subroutine */ int dpotrf_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer j, jb, nb;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *), dpotf2_(char *, integer *,
+ doublereal *, integer *, integer *), xerbla_(char *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* March 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPOTRF computes the Cholesky factorization of a real symmetric */
+/* positive definite matrix A. */
+
+/* The factorization has the form */
+/* A = U**T * U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* This is the top-looking block version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPOTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "DPOTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code. */
+
+ dpotf2_(uplo, n, &a[a_offset], lda, info);
+ } else {
+
+/* Use blocked code. */
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+
+/* Compute the current block. */
+
+ i__3 = j - 1;
+ dtrsm_("Left", "Upper", "Transpose", "Non-unit", &i__3, &jb, &
+ c_b15, &a[a_dim1 + 1], lda, &a[j * a_dim1 + 1], lda);
+ i__3 = j - 1;
+ dsyrk_("Upper", "Transpose", &jb, &i__3, &c_b18, &a[j *
+ a_dim1 + 1], lda, &c_b15, &a[j + j * a_dim1], lda);
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+ dpotf2_("Upper", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+/* L10: */
+ }
+
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+
+/* Compute the current block. */
+
+ i__3 = j - 1;
+ dtrsm_("Right", "Lower", "Transpose", "Non-unit", &jb, &i__3,
+ &c_b15, &a[a_dim1 + 1], lda, &a[j + a_dim1], lda);
+ i__3 = j - 1;
+ dsyrk_("Lower", "No Transpose", &jb, &i__3, &c_b18, &a[j +
+ a_dim1], lda, &c_b15, &a[j + j * a_dim1], lda);
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+ dpotf2_("Lower", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+/* L20: */
+ }
+ }
+ }
+ goto L40;
+
+L30:
+ *info = *info + j - 1;
+
+L40:
+ return 0;
+
+/* End of DPOTRF */
+
+} /* dpotrf_ */
diff --git a/SRC/VARIANTS/cholesky/TOP/spotrf.c b/SRC/VARIANTS/cholesky/TOP/spotrf.c
new file mode 100644
index 0000000..23fb363
--- /dev/null
+++ b/SRC/VARIANTS/cholesky/TOP/spotrf.c
@@ -0,0 +1,223 @@
+/* spotrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b15 = 1.f;
+static real c_b18 = -1.f;
+
+/* Subroutine */ int spotrf_(char *uplo, integer *n, real *a, integer *lda,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer j, jb, nb;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), ssyrk_(char *, char *, integer
+ *, integer *, real *, real *, integer *, real *, real *, integer *
+), spotf2_(char *, integer *, real *, integer *,
+ integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* March 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPOTRF computes the Cholesky factorization of a real symmetric */
+/* positive definite matrix A. */
+
+/* The factorization has the form */
+/* A = U**T * U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* This is the top-looking block version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPOTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "SPOTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code. */
+
+ spotf2_(uplo, n, &a[a_offset], lda, info);
+ } else {
+
+/* Use blocked code. */
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+
+/* Compute the current block. */
+
+ i__3 = j - 1;
+ strsm_("Left", "Upper", "Transpose", "Non-unit", &i__3, &jb, &
+ c_b15, &a[a_dim1 + 1], lda, &a[j * a_dim1 + 1], lda);
+ i__3 = j - 1;
+ ssyrk_("Upper", "Transpose", &jb, &i__3, &c_b18, &a[j *
+ a_dim1 + 1], lda, &c_b15, &a[j + j * a_dim1], lda);
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+ spotf2_("Upper", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+/* L10: */
+ }
+
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+
+/* Compute the current block. */
+
+ i__3 = j - 1;
+ strsm_("Right", "Lower", "Transpose", "Non-unit", &jb, &i__3,
+ &c_b15, &a[a_dim1 + 1], lda, &a[j + a_dim1], lda);
+ i__3 = j - 1;
+ ssyrk_("Lower", "No Transpose", &jb, &i__3, &c_b18, &a[j +
+ a_dim1], lda, &c_b15, &a[j + j * a_dim1], lda);
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+ spotf2_("Lower", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+/* L20: */
+ }
+ }
+ }
+ goto L40;
+
+L30:
+ *info = *info + j - 1;
+
+L40:
+ return 0;
+
+/* End of SPOTRF */
+
+} /* spotrf_ */
diff --git a/SRC/VARIANTS/cholesky/TOP/zpotrf.c b/SRC/VARIANTS/cholesky/TOP/zpotrf.c
new file mode 100644
index 0000000..448f781
--- /dev/null
+++ b/SRC/VARIANTS/cholesky/TOP/zpotrf.c
@@ -0,0 +1,227 @@
+/* zpotrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b18 = -1.;
+static doublereal c_b19 = 1.;
+
+/* Subroutine */ int zpotrf_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer j, jb, nb;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zherk_(char *, char *, integer *, integer *,
+ doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ zpotf2_(char *, integer *, doublecomplex *, integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* March 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPOTRF computes the Cholesky factorization of a real symmetric */
+/* positive definite matrix A. */
+
+/* The factorization has the form */
+/* A = U**H * U, if UPLO = 'U', or */
+/* A = L * L**H, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* This is the top-looking block version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPOTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "ZPOTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code. */
+
+ zpotf2_(uplo, n, &a[a_offset], lda, info);
+ } else {
+
+/* Use blocked code. */
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+
+/* Compute the current block. */
+
+ i__3 = j - 1;
+ ztrsm_("Left", "Upper", "Conjugate Transpose", "Non-unit", &
+ i__3, &jb, &c_b1, &a[a_dim1 + 1], lda, &a[j * a_dim1
+ + 1], lda);
+ i__3 = j - 1;
+ zherk_("Upper", "Conjugate Transpose", &jb, &i__3, &c_b18, &a[
+ j * a_dim1 + 1], lda, &c_b19, &a[j + j * a_dim1], lda);
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+ zpotf2_("Upper", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+/* L10: */
+ }
+
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+
+/* Compute the current block. */
+
+ i__3 = j - 1;
+ ztrsm_("Right", "Lower", "Conjugate Transpose", "Non-unit", &
+ jb, &i__3, &c_b1, &a[a_dim1 + 1], lda, &a[j + a_dim1],
+ lda);
+ i__3 = j - 1;
+ zherk_("Lower", "No Transpose", &jb, &i__3, &c_b18, &a[j +
+ a_dim1], lda, &c_b19, &a[j + j * a_dim1], lda);
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+ zpotf2_("Lower", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+/* L20: */
+ }
+ }
+ }
+ goto L40;
+
+L30:
+ *info = *info + j - 1;
+
+L40:
+ return 0;
+
+/* End of ZPOTRF */
+
+} /* zpotrf_ */
diff --git a/SRC/VARIANTS/lu/CR/cgetrf.c b/SRC/VARIANTS/lu/CR/cgetrf.c
new file mode 100644
index 0000000..a973c6a
--- /dev/null
+++ b/SRC/VARIANTS/lu/CR/cgetrf.c
@@ -0,0 +1,224 @@
+/* cgetrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cgetrf_(integer *m, integer *n, complex *a, integer *lda,
+ integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j, jb, nb;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ integer iinfo;
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *), cgetf2_(integer *,
+ integer *, complex *, integer *, integer *, integer *), xerbla_(
+ char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int claswp_(integer *, complex *, integer *,
+ integer *, integer *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* March 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGETRF computes an LU factorization of a general M-by-N matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* The factorization has the form */
+/* A = P * L * U */
+/* where P is a permutation matrix, L is lower triangular with unit */
+/* diagonal elements (lower trapezoidal if m > n), and U is upper */
+/* triangular (upper trapezoidal if m < n). */
+
+/* This is the Crout Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGETRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "CGETRF", " ", m, n, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= min(*m,*n)) {
+
+/* Use unblocked code. */
+
+ cgetf2_(m, n, &a[a_offset], lda, &ipiv[1], info);
+ } else {
+
+/* Use blocked code. */
+
+ i__1 = min(*m,*n);
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = min(*m,*n) - j + 1;
+ jb = min(i__3,nb);
+
+/* Update current block. */
+
+ i__3 = *m - j + 1;
+ i__4 = j - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "No transpose", &i__3, &jb, &i__4, &q__1, &
+ a[j + a_dim1], lda, &a[j * a_dim1 + 1], lda, &c_b1, &a[j
+ + j * a_dim1], lda);
+
+/* Factor diagonal and subdiagonal blocks and test for exact */
+/* singularity. */
+
+ i__3 = *m - j + 1;
+ cgetf2_(&i__3, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo);
+
+/* Adjust INFO and the pivot indices. */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo + j - 1;
+ }
+/* Computing MIN */
+ i__4 = *m, i__5 = j + jb - 1;
+ i__3 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__3; ++i__) {
+ ipiv[i__] = j - 1 + ipiv[i__];
+/* L10: */
+ }
+
+/* Apply interchanges to column 1:J-1 */
+
+ i__3 = j - 1;
+ i__4 = j + jb - 1;
+ claswp_(&i__3, &a[a_offset], lda, &j, &i__4, &ipiv[1], &c__1);
+
+ if (j + jb <= *n) {
+
+/* Apply interchanges to column J+JB:N */
+
+ i__3 = *n - j - jb + 1;
+ i__4 = j + jb - 1;
+ claswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, &
+ ipiv[1], &c__1);
+
+ i__3 = *n - j - jb + 1;
+ i__4 = j - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "No transpose", &jb, &i__3, &i__4, &
+ q__1, &a[j + a_dim1], lda, &a[(j + jb) * a_dim1 + 1],
+ lda, &c_b1, &a[j + (j + jb) * a_dim1], lda);
+
+/* Compute block row of U. */
+
+ i__3 = *n - j - jb + 1;
+ ctrsm_("Left", "Lower", "No transpose", "Unit", &jb, &i__3, &
+ c_b1, &a[j + j * a_dim1], lda, &a[j + (j + jb) *
+ a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+/* End of CGETRF */
+
+} /* cgetrf_ */
diff --git a/SRC/VARIANTS/lu/CR/dgetrf.c b/SRC/VARIANTS/lu/CR/dgetrf.c
new file mode 100644
index 0000000..5aa935d
--- /dev/null
+++ b/SRC/VARIANTS/lu/CR/dgetrf.c
@@ -0,0 +1,222 @@
+/* dgetrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b11 = -1.;
+static doublereal c_b12 = 1.;
+
+/* Subroutine */ int dgetrf_(integer *m, integer *n, doublereal *a, integer *
+ lda, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+
+ /* Local variables */
+ integer i__, j, jb, nb;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ integer iinfo;
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), dgetf2_(
+ integer *, integer *, doublereal *, integer *, integer *, integer
+ *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dlaswp_(integer *, doublereal *, integer *,
+ integer *, integer *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* March 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGETRF computes an LU factorization of a general M-by-N matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* The factorization has the form */
+/* A = P * L * U */
+/* where P is a permutation matrix, L is lower triangular with unit */
+/* diagonal elements (lower trapezoidal if m > n), and U is upper */
+/* triangular (upper trapezoidal if m < n). */
+
+/* This is the Crout Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGETRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "DGETRF", " ", m, n, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= min(*m,*n)) {
+
+/* Use unblocked code. */
+
+ dgetf2_(m, n, &a[a_offset], lda, &ipiv[1], info);
+ } else {
+
+/* Use blocked code. */
+
+ i__1 = min(*m,*n);
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = min(*m,*n) - j + 1;
+ jb = min(i__3,nb);
+
+/* Update current block. */
+
+ i__3 = *m - j + 1;
+ i__4 = j - 1;
+ dgemm_("No transpose", "No transpose", &i__3, &jb, &i__4, &c_b11,
+ &a[j + a_dim1], lda, &a[j * a_dim1 + 1], lda, &c_b12, &a[
+ j + j * a_dim1], lda);
+
+/* Factor diagonal and subdiagonal blocks and test for exact */
+/* singularity. */
+
+ i__3 = *m - j + 1;
+ dgetf2_(&i__3, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo);
+
+/* Adjust INFO and the pivot indices. */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo + j - 1;
+ }
+/* Computing MIN */
+ i__4 = *m, i__5 = j + jb - 1;
+ i__3 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__3; ++i__) {
+ ipiv[i__] = j - 1 + ipiv[i__];
+/* L10: */
+ }
+
+/* Apply interchanges to column 1:J-1 */
+
+ i__3 = j - 1;
+ i__4 = j + jb - 1;
+ dlaswp_(&i__3, &a[a_offset], lda, &j, &i__4, &ipiv[1], &c__1);
+
+ if (j + jb <= *n) {
+
+/* Apply interchanges to column J+JB:N */
+
+ i__3 = *n - j - jb + 1;
+ i__4 = j + jb - 1;
+ dlaswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, &
+ ipiv[1], &c__1);
+
+ i__3 = *n - j - jb + 1;
+ i__4 = j - 1;
+ dgemm_("No transpose", "No transpose", &jb, &i__3, &i__4, &
+ c_b11, &a[j + a_dim1], lda, &a[(j + jb) * a_dim1 + 1],
+ lda, &c_b12, &a[j + (j + jb) * a_dim1], lda);
+
+/* Compute block row of U. */
+
+ i__3 = *n - j - jb + 1;
+ dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &i__3, &
+ c_b12, &a[j + j * a_dim1], lda, &a[j + (j + jb) *
+ a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+/* End of DGETRF */
+
+} /* dgetrf_ */
diff --git a/SRC/VARIANTS/lu/CR/sgetrf.c b/SRC/VARIANTS/lu/CR/sgetrf.c
new file mode 100644
index 0000000..9225f55
--- /dev/null
+++ b/SRC/VARIANTS/lu/CR/sgetrf.c
@@ -0,0 +1,220 @@
+/* sgetrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b11 = -1.f;
+static real c_b12 = 1.f;
+
+/* Subroutine */ int sgetrf_(integer *m, integer *n, real *a, integer *lda,
+ integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+
+ /* Local variables */
+ integer i__, j, jb, nb, iinfo;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *), strsm_(char *, char *, char *,
+ char *, integer *, integer *, real *, real *, integer *, real *,
+ integer *), sgetf2_(integer *,
+ integer *, real *, integer *, integer *, integer *), xerbla_(char
+ *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slaswp_(integer *, real *, integer *, integer
+ *, integer *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* March 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGETRF computes an LU factorization of a general M-by-N matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* The factorization has the form */
+/* A = P * L * U */
+/* where P is a permutation matrix, L is lower triangular with unit */
+/* diagonal elements (lower trapezoidal if m > n), and U is upper */
+/* triangular (upper trapezoidal if m < n). */
+
+/* This is the Crout Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGETRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "SGETRF", " ", m, n, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= min(*m,*n)) {
+
+/* Use unblocked code. */
+
+ sgetf2_(m, n, &a[a_offset], lda, &ipiv[1], info);
+ } else {
+
+/* Use blocked code. */
+
+ i__1 = min(*m,*n);
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = min(*m,*n) - j + 1;
+ jb = min(i__3,nb);
+
+/* Update current block. */
+
+ i__3 = *m - j + 1;
+ i__4 = j - 1;
+ sgemm_("No transpose", "No transpose", &i__3, &jb, &i__4, &c_b11,
+ &a[j + a_dim1], lda, &a[j * a_dim1 + 1], lda, &c_b12, &a[
+ j + j * a_dim1], lda);
+
+/* Factor diagonal and subdiagonal blocks and test for exact */
+/* singularity. */
+
+ i__3 = *m - j + 1;
+ sgetf2_(&i__3, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo);
+
+/* Adjust INFO and the pivot indices. */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo + j - 1;
+ }
+/* Computing MIN */
+ i__4 = *m, i__5 = j + jb - 1;
+ i__3 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__3; ++i__) {
+ ipiv[i__] = j - 1 + ipiv[i__];
+/* L10: */
+ }
+
+/* Apply interchanges to column 1:J-1 */
+
+ i__3 = j - 1;
+ i__4 = j + jb - 1;
+ slaswp_(&i__3, &a[a_offset], lda, &j, &i__4, &ipiv[1], &c__1);
+
+ if (j + jb <= *n) {
+
+/* Apply interchanges to column J+JB:N */
+
+ i__3 = *n - j - jb + 1;
+ i__4 = j + jb - 1;
+ slaswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, &
+ ipiv[1], &c__1);
+
+ i__3 = *n - j - jb + 1;
+ i__4 = j - 1;
+ sgemm_("No transpose", "No transpose", &jb, &i__3, &i__4, &
+ c_b11, &a[j + a_dim1], lda, &a[(j + jb) * a_dim1 + 1],
+ lda, &c_b12, &a[j + (j + jb) * a_dim1], lda);
+
+/* Compute block row of U. */
+
+ i__3 = *n - j - jb + 1;
+ strsm_("Left", "Lower", "No transpose", "Unit", &jb, &i__3, &
+ c_b12, &a[j + j * a_dim1], lda, &a[j + (j + jb) *
+ a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+/* End of SGETRF */
+
+} /* sgetrf_ */
diff --git a/SRC/VARIANTS/lu/CR/zgetrf.c b/SRC/VARIANTS/lu/CR/zgetrf.c
new file mode 100644
index 0000000..658b786
--- /dev/null
+++ b/SRC/VARIANTS/lu/CR/zgetrf.c
@@ -0,0 +1,223 @@
+/* zgetrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zgetrf_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j, jb, nb, iinfo;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), ztrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *
+, doublecomplex *, integer *),
+ zgetf2_(integer *, integer *, doublecomplex *, integer *, integer
+ *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zlaswp_(integer *, doublecomplex *, integer *,
+ integer *, integer *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* March 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGETRF computes an LU factorization of a general M-by-N matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* The factorization has the form */
+/* A = P * L * U */
+/* where P is a permutation matrix, L is lower triangular with unit */
+/* diagonal elements (lower trapezoidal if m > n), and U is upper */
+/* triangular (upper trapezoidal if m < n). */
+
+/* This is the Crout Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGETRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "ZGETRF", " ", m, n, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= min(*m,*n)) {
+
+/* Use unblocked code. */
+
+ zgetf2_(m, n, &a[a_offset], lda, &ipiv[1], info);
+ } else {
+
+/* Use blocked code. */
+
+ i__1 = min(*m,*n);
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = min(*m,*n) - j + 1;
+ jb = min(i__3,nb);
+
+/* Update current block. */
+
+ i__3 = *m - j + 1;
+ i__4 = j - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "No transpose", &i__3, &jb, &i__4, &z__1, &
+ a[j + a_dim1], lda, &a[j * a_dim1 + 1], lda, &c_b1, &a[j
+ + j * a_dim1], lda);
+
+/* Factor diagonal and subdiagonal blocks and test for exact */
+/* singularity. */
+
+ i__3 = *m - j + 1;
+ zgetf2_(&i__3, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo);
+
+/* Adjust INFO and the pivot indices. */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo + j - 1;
+ }
+/* Computing MIN */
+ i__4 = *m, i__5 = j + jb - 1;
+ i__3 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__3; ++i__) {
+ ipiv[i__] = j - 1 + ipiv[i__];
+/* L10: */
+ }
+
+/* Apply interchanges to column 1:J-1 */
+
+ i__3 = j - 1;
+ i__4 = j + jb - 1;
+ zlaswp_(&i__3, &a[a_offset], lda, &j, &i__4, &ipiv[1], &c__1);
+
+ if (j + jb <= *n) {
+
+/* Apply interchanges to column J+JB:N */
+
+ i__3 = *n - j - jb + 1;
+ i__4 = j + jb - 1;
+ zlaswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, &
+ ipiv[1], &c__1);
+
+ i__3 = *n - j - jb + 1;
+ i__4 = j - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "No transpose", &jb, &i__3, &i__4, &
+ z__1, &a[j + a_dim1], lda, &a[(j + jb) * a_dim1 + 1],
+ lda, &c_b1, &a[j + (j + jb) * a_dim1], lda);
+
+/* Compute block row of U. */
+
+ i__3 = *n - j - jb + 1;
+ ztrsm_("Left", "Lower", "No transpose", "Unit", &jb, &i__3, &
+ c_b1, &a[j + j * a_dim1], lda, &a[j + (j + jb) *
+ a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+/* End of ZGETRF */
+
+} /* zgetrf_ */
diff --git a/SRC/VARIANTS/lu/LL/cgetrf.c b/SRC/VARIANTS/lu/LL/cgetrf.c
new file mode 100644
index 0000000..57feb9e
--- /dev/null
+++ b/SRC/VARIANTS/lu/LL/cgetrf.c
@@ -0,0 +1,260 @@
+/* cgetrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cgetrf_(integer *m, integer *n, complex *a, integer *lda,
+ integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j, k, jb, nb;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ integer iinfo;
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *), cgetf2_(integer *,
+ integer *, complex *, integer *, integer *, integer *), xerbla_(
+ char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int claswp_(integer *, complex *, integer *,
+ integer *, integer *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* March 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGETRF computes an LU factorization of a general M-by-N matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* The factorization has the form */
+/* A = P * L * U */
+/* where P is a permutation matrix, L is lower triangular with unit */
+/* diagonal elements (lower trapezoidal if m > n), and U is upper */
+/* triangular (upper trapezoidal if m < n). */
+
+/* This is the left-looking Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGETRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "CGETRF", " ", m, n, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= min(*m,*n)) {
+
+/* Use unblocked code. */
+
+ cgetf2_(m, n, &a[a_offset], lda, &ipiv[1], info);
+ } else {
+
+/* Use blocked code. */
+
+ i__1 = min(*m,*n);
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = min(*m,*n) - j + 1;
+ jb = min(i__3,nb);
+
+
+/* Update before factoring the current panel */
+
+ i__3 = j - nb;
+ i__4 = nb;
+ for (k = 1; i__4 < 0 ? k >= i__3 : k <= i__3; k += i__4) {
+
+/* Apply interchanges to rows K:K+NB-1. */
+
+ i__5 = k + nb - 1;
+ claswp_(&jb, &a[j * a_dim1 + 1], lda, &k, &i__5, &ipiv[1], &
+ c__1);
+
+/* Compute block row of U. */
+
+ ctrsm_("Left", "Lower", "No transpose", "Unit", &nb, &jb, &
+ c_b1, &a[k + k * a_dim1], lda, &a[k + j * a_dim1],
+ lda);
+
+/* Update trailing submatrix. */
+
+ i__5 = *m - k - nb + 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "No transpose", &i__5, &jb, &nb, &q__1,
+ &a[k + nb + k * a_dim1], lda, &a[k + j * a_dim1],
+ lda, &c_b1, &a[k + nb + j * a_dim1], lda);
+/* L30: */
+ }
+
+/* Factor diagonal and subdiagonal blocks and test for exact */
+/* singularity. */
+
+ i__4 = *m - j + 1;
+ cgetf2_(&i__4, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo);
+
+/* Adjust INFO and the pivot indices. */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo + j - 1;
+ }
+/* Computing MIN */
+ i__3 = *m, i__5 = j + jb - 1;
+ i__4 = min(i__3,i__5);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ ipiv[i__] = j - 1 + ipiv[i__];
+/* L10: */
+ }
+
+/* L20: */
+ }
+
+/* Apply interchanges to the left-overs */
+
+ i__2 = min(*m,*n);
+ i__1 = nb;
+ for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+ i__4 = k - 1;
+/* Computing MIN */
+ i__5 = k + nb - 1, i__6 = min(*m,*n);
+ i__3 = min(i__5,i__6);
+ claswp_(&i__4, &a[a_dim1 + 1], lda, &k, &i__3, &ipiv[1], &c__1);
+/* L40: */
+ }
+
+/* Apply update to the M+1:N columns when N > M */
+
+ if (*n > *m) {
+ i__1 = *n - *m;
+ claswp_(&i__1, &a[(*m + 1) * a_dim1 + 1], lda, &c__1, m, &ipiv[1],
+ &c__1);
+ i__1 = *m;
+ i__2 = nb;
+ for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+/* Computing MIN */
+ i__4 = *m - k + 1;
+ jb = min(i__4,nb);
+
+ i__4 = *n - *m;
+ ctrsm_("Left", "Lower", "No transpose", "Unit", &jb, &i__4, &
+ c_b1, &a[k + k * a_dim1], lda, &a[k + (*m + 1) *
+ a_dim1], lda);
+
+ if (k + nb <= *m) {
+ i__4 = *m - k - nb + 1;
+ i__3 = *n - *m;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "No transpose", &i__4, &i__3, &nb,
+ &q__1, &a[k + nb + k * a_dim1], lda, &a[k + (*m +
+ 1) * a_dim1], lda, &c_b1, &a[k + nb + (*m + 1) *
+ a_dim1], lda);
+ }
+/* L50: */
+ }
+ }
+
+ }
+ return 0;
+
+/* End of CGETRF */
+
+} /* cgetrf_ */
diff --git a/SRC/VARIANTS/lu/LL/dgetrf.c b/SRC/VARIANTS/lu/LL/dgetrf.c
new file mode 100644
index 0000000..139b975
--- /dev/null
+++ b/SRC/VARIANTS/lu/LL/dgetrf.c
@@ -0,0 +1,257 @@
+/* dgetrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b15 = 1.;
+static doublereal c_b18 = -1.;
+
+/* Subroutine */ int dgetrf_(integer *m, integer *n, doublereal *a, integer *
+ lda, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+
+ /* Local variables */
+ integer i__, j, k, jb, nb;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ integer iinfo;
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), dgetf2_(
+ integer *, integer *, doublereal *, integer *, integer *, integer
+ *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dlaswp_(integer *, doublereal *, integer *,
+ integer *, integer *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* March 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGETRF computes an LU factorization of a general M-by-N matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* The factorization has the form */
+/* A = P * L * U */
+/* where P is a permutation matrix, L is lower triangular with unit */
+/* diagonal elements (lower trapezoidal if m > n), and U is upper */
+/* triangular (upper trapezoidal if m < n). */
+
+/* This is the left-looking Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGETRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "DGETRF", " ", m, n, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= min(*m,*n)) {
+
+/* Use unblocked code. */
+
+ dgetf2_(m, n, &a[a_offset], lda, &ipiv[1], info);
+ } else {
+
+/* Use blocked code. */
+
+ i__1 = min(*m,*n);
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = min(*m,*n) - j + 1;
+ jb = min(i__3,nb);
+
+/* Update before factoring the current panel */
+
+ i__3 = j - nb;
+ i__4 = nb;
+ for (k = 1; i__4 < 0 ? k >= i__3 : k <= i__3; k += i__4) {
+
+/* Apply interchanges to rows K:K+NB-1. */
+
+ i__5 = k + nb - 1;
+ dlaswp_(&jb, &a[j * a_dim1 + 1], lda, &k, &i__5, &ipiv[1], &
+ c__1);
+
+/* Compute block row of U. */
+
+ dtrsm_("Left", "Lower", "No transpose", "Unit", &nb, &jb, &
+ c_b15, &a[k + k * a_dim1], lda, &a[k + j * a_dim1],
+ lda);
+
+/* Update trailing submatrix. */
+
+ i__5 = *m - k - nb + 1;
+ dgemm_("No transpose", "No transpose", &i__5, &jb, &nb, &
+ c_b18, &a[k + nb + k * a_dim1], lda, &a[k + j *
+ a_dim1], lda, &c_b15, &a[k + nb + j * a_dim1], lda);
+/* L30: */
+ }
+
+/* Factor diagonal and subdiagonal blocks and test for exact */
+/* singularity. */
+
+ i__4 = *m - j + 1;
+ dgetf2_(&i__4, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo);
+
+/* Adjust INFO and the pivot indices. */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo + j - 1;
+ }
+/* Computing MIN */
+ i__3 = *m, i__5 = j + jb - 1;
+ i__4 = min(i__3,i__5);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ ipiv[i__] = j - 1 + ipiv[i__];
+/* L10: */
+ }
+
+/* L20: */
+ }
+
+/* Apply interchanges to the left-overs */
+
+ i__2 = min(*m,*n);
+ i__1 = nb;
+ for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+ i__4 = k - 1;
+/* Computing MIN */
+ i__5 = k + nb - 1, i__6 = min(*m,*n);
+ i__3 = min(i__5,i__6);
+ dlaswp_(&i__4, &a[a_dim1 + 1], lda, &k, &i__3, &ipiv[1], &c__1);
+/* L40: */
+ }
+
+/* Apply update to the M+1:N columns when N > M */
+
+ if (*n > *m) {
+ i__1 = *n - *m;
+ dlaswp_(&i__1, &a[(*m + 1) * a_dim1 + 1], lda, &c__1, m, &ipiv[1],
+ &c__1);
+ i__1 = *m;
+ i__2 = nb;
+ for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+/* Computing MIN */
+ i__4 = *m - k + 1;
+ jb = min(i__4,nb);
+
+ i__4 = *n - *m;
+ dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &i__4, &
+ c_b15, &a[k + k * a_dim1], lda, &a[k + (*m + 1) *
+ a_dim1], lda);
+
+ if (k + nb <= *m) {
+ i__4 = *m - k - nb + 1;
+ i__3 = *n - *m;
+ dgemm_("No transpose", "No transpose", &i__4, &i__3, &nb,
+ &c_b18, &a[k + nb + k * a_dim1], lda, &a[k + (*m
+ + 1) * a_dim1], lda, &c_b15, &a[k + nb + (*m + 1)
+ * a_dim1], lda);
+ }
+/* L50: */
+ }
+ }
+
+ }
+ return 0;
+
+/* End of DGETRF */
+
+} /* dgetrf_ */
diff --git a/SRC/VARIANTS/lu/LL/sgetrf.c b/SRC/VARIANTS/lu/LL/sgetrf.c
new file mode 100644
index 0000000..2dbd3e3
--- /dev/null
+++ b/SRC/VARIANTS/lu/LL/sgetrf.c
@@ -0,0 +1,256 @@
+/* sgetrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b15 = 1.f;
+static real c_b18 = -1.f;
+
+/* Subroutine */ int sgetrf_(integer *m, integer *n, real *a, integer *lda,
+ integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+
+ /* Local variables */
+ integer i__, j, k, jb, nb, iinfo;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *), strsm_(char *, char *, char *,
+ char *, integer *, integer *, real *, real *, integer *, real *,
+ integer *), sgetf2_(integer *,
+ integer *, real *, integer *, integer *, integer *), xerbla_(char
+ *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slaswp_(integer *, real *, integer *, integer
+ *, integer *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* March 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGETRF computes an LU factorization of a general M-by-N matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* The factorization has the form */
+/* A = P * L * U */
+/* where P is a permutation matrix, L is lower triangular with unit */
+/* diagonal elements (lower trapezoidal if m > n), and U is upper */
+/* triangular (upper trapezoidal if m < n). */
+
+/* This is the left-looking Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGETRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "SGETRF", " ", m, n, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= min(*m,*n)) {
+
+/* Use unblocked code. */
+
+ sgetf2_(m, n, &a[a_offset], lda, &ipiv[1], info);
+ } else {
+
+/* Use blocked code. */
+
+ i__1 = min(*m,*n);
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = min(*m,*n) - j + 1;
+ jb = min(i__3,nb);
+
+
+/* Update before factoring the current panel */
+
+ i__3 = j - nb;
+ i__4 = nb;
+ for (k = 1; i__4 < 0 ? k >= i__3 : k <= i__3; k += i__4) {
+
+/* Apply interchanges to rows K:K+NB-1. */
+
+ i__5 = k + nb - 1;
+ slaswp_(&jb, &a[j * a_dim1 + 1], lda, &k, &i__5, &ipiv[1], &
+ c__1);
+
+/* Compute block row of U. */
+
+ strsm_("Left", "Lower", "No transpose", "Unit", &nb, &jb, &
+ c_b15, &a[k + k * a_dim1], lda, &a[k + j * a_dim1],
+ lda);
+
+/* Update trailing submatrix. */
+
+ i__5 = *m - k - nb + 1;
+ sgemm_("No transpose", "No transpose", &i__5, &jb, &nb, &
+ c_b18, &a[k + nb + k * a_dim1], lda, &a[k + j *
+ a_dim1], lda, &c_b15, &a[k + nb + j * a_dim1], lda);
+/* L30: */
+ }
+
+/* Factor diagonal and subdiagonal blocks and test for exact */
+/* singularity. */
+
+ i__4 = *m - j + 1;
+ sgetf2_(&i__4, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo);
+
+/* Adjust INFO and the pivot indices. */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo + j - 1;
+ }
+/* Computing MIN */
+ i__3 = *m, i__5 = j + jb - 1;
+ i__4 = min(i__3,i__5);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ ipiv[i__] = j - 1 + ipiv[i__];
+/* L10: */
+ }
+
+/* L20: */
+ }
+
+/* Apply interchanges to the left-overs */
+
+ i__2 = min(*m,*n);
+ i__1 = nb;
+ for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+ i__4 = k - 1;
+/* Computing MIN */
+ i__5 = k + nb - 1, i__6 = min(*m,*n);
+ i__3 = min(i__5,i__6);
+ slaswp_(&i__4, &a[a_dim1 + 1], lda, &k, &i__3, &ipiv[1], &c__1);
+/* L40: */
+ }
+
+/* Apply update to the M+1:N columns when N > M */
+
+ if (*n > *m) {
+ i__1 = *n - *m;
+ slaswp_(&i__1, &a[(*m + 1) * a_dim1 + 1], lda, &c__1, m, &ipiv[1],
+ &c__1);
+ i__1 = *m;
+ i__2 = nb;
+ for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+/* Computing MIN */
+ i__4 = *m - k + 1;
+ jb = min(i__4,nb);
+
+ i__4 = *n - *m;
+ strsm_("Left", "Lower", "No transpose", "Unit", &jb, &i__4, &
+ c_b15, &a[k + k * a_dim1], lda, &a[k + (*m + 1) *
+ a_dim1], lda);
+
+ if (k + nb <= *m) {
+ i__4 = *m - k - nb + 1;
+ i__3 = *n - *m;
+ sgemm_("No transpose", "No transpose", &i__4, &i__3, &nb,
+ &c_b18, &a[k + nb + k * a_dim1], lda, &a[k + (*m
+ + 1) * a_dim1], lda, &c_b15, &a[k + nb + (*m + 1)
+ * a_dim1], lda);
+ }
+/* L50: */
+ }
+ }
+
+ }
+ return 0;
+
+/* End of SGETRF */
+
+} /* sgetrf_ */
diff --git a/SRC/VARIANTS/lu/LL/zgetrf.c b/SRC/VARIANTS/lu/LL/zgetrf.c
new file mode 100644
index 0000000..c469971
--- /dev/null
+++ b/SRC/VARIANTS/lu/LL/zgetrf.c
@@ -0,0 +1,259 @@
+/* zgetrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zgetrf_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j, k, jb, nb, iinfo;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), ztrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *
+, doublecomplex *, integer *),
+ zgetf2_(integer *, integer *, doublecomplex *, integer *, integer
+ *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zlaswp_(integer *, doublecomplex *, integer *,
+ integer *, integer *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* March 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGETRF computes an LU factorization of a general M-by-N matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* The factorization has the form */
+/* A = P * L * U */
+/* where P is a permutation matrix, L is lower triangular with unit */
+/* diagonal elements (lower trapezoidal if m > n), and U is upper */
+/* triangular (upper trapezoidal if m < n). */
+
+/* This is the left-looking Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGETRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "ZGETRF", " ", m, n, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= min(*m,*n)) {
+
+/* Use unblocked code. */
+
+ zgetf2_(m, n, &a[a_offset], lda, &ipiv[1], info);
+ } else {
+
+/* Use blocked code. */
+
+ i__1 = min(*m,*n);
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = min(*m,*n) - j + 1;
+ jb = min(i__3,nb);
+
+
+/* Update before factoring the current panel */
+
+ i__3 = j - nb;
+ i__4 = nb;
+ for (k = 1; i__4 < 0 ? k >= i__3 : k <= i__3; k += i__4) {
+
+/* Apply interchanges to rows K:K+NB-1. */
+
+ i__5 = k + nb - 1;
+ zlaswp_(&jb, &a[j * a_dim1 + 1], lda, &k, &i__5, &ipiv[1], &
+ c__1);
+
+/* Compute block row of U. */
+
+ ztrsm_("Left", "Lower", "No transpose", "Unit", &nb, &jb, &
+ c_b1, &a[k + k * a_dim1], lda, &a[k + j * a_dim1],
+ lda);
+
+/* Update trailing submatrix. */
+
+ i__5 = *m - k - nb + 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "No transpose", &i__5, &jb, &nb, &z__1,
+ &a[k + nb + k * a_dim1], lda, &a[k + j * a_dim1],
+ lda, &c_b1, &a[k + nb + j * a_dim1], lda);
+/* L30: */
+ }
+
+/* Factor diagonal and subdiagonal blocks and test for exact */
+/* singularity. */
+
+ i__4 = *m - j + 1;
+ zgetf2_(&i__4, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo);
+
+/* Adjust INFO and the pivot indices. */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo + j - 1;
+ }
+/* Computing MIN */
+ i__3 = *m, i__5 = j + jb - 1;
+ i__4 = min(i__3,i__5);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ ipiv[i__] = j - 1 + ipiv[i__];
+/* L10: */
+ }
+
+/* L20: */
+ }
+
+/* Apply interchanges to the left-overs */
+
+ i__2 = min(*m,*n);
+ i__1 = nb;
+ for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+ i__4 = k - 1;
+/* Computing MIN */
+ i__5 = k + nb - 1, i__6 = min(*m,*n);
+ i__3 = min(i__5,i__6);
+ zlaswp_(&i__4, &a[a_dim1 + 1], lda, &k, &i__3, &ipiv[1], &c__1);
+/* L40: */
+ }
+
+/* Apply update to the M+1:N columns when N > M */
+
+ if (*n > *m) {
+ i__1 = *n - *m;
+ zlaswp_(&i__1, &a[(*m + 1) * a_dim1 + 1], lda, &c__1, m, &ipiv[1],
+ &c__1);
+ i__1 = *m;
+ i__2 = nb;
+ for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+/* Computing MIN */
+ i__4 = *m - k + 1;
+ jb = min(i__4,nb);
+
+ i__4 = *n - *m;
+ ztrsm_("Left", "Lower", "No transpose", "Unit", &jb, &i__4, &
+ c_b1, &a[k + k * a_dim1], lda, &a[k + (*m + 1) *
+ a_dim1], lda);
+
+ if (k + nb <= *m) {
+ i__4 = *m - k - nb + 1;
+ i__3 = *n - *m;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "No transpose", &i__4, &i__3, &nb,
+ &z__1, &a[k + nb + k * a_dim1], lda, &a[k + (*m +
+ 1) * a_dim1], lda, &c_b1, &a[k + nb + (*m + 1) *
+ a_dim1], lda);
+ }
+/* L50: */
+ }
+ }
+
+ }
+ return 0;
+
+/* End of ZGETRF */
+
+} /* zgetrf_ */
diff --git a/SRC/VARIANTS/lu/REC/cgetrf.c b/SRC/VARIANTS/lu/REC/cgetrf.c
new file mode 100644
index 0000000..e568646
--- /dev/null
+++ b/SRC/VARIANTS/lu/REC/cgetrf.c
@@ -0,0 +1,280 @@
+/* cgetrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static complex c_b2 = {-1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cgetrf_(integer *m, integer *n, complex *a, integer *lda,
+ integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ complex q__1;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, ipivstart, jpivstart, jp;
+ complex tmp;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *), cgemm_(char *, char *, integer *, integer *, integer *
+, complex *, complex *, integer *, complex *, integer *, complex *
+, complex *, integer *);
+ integer kcols;
+ real sfmin;
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *);
+ integer nstep, kahead;
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real pivmag;
+ integer npived;
+ extern /* Subroutine */ int claswp_(integer *, complex *, integer *,
+ integer *, integer *, integer *, integer *);
+ extern logical sisnan_(real *);
+ integer kstart, ntopiv;
+
+
+/* -- LAPACK routine (version 3.X) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* May 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGETRF computes an LU factorization of a general M-by-N matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* The factorization has the form */
+/* A = P * L * U */
+/* where P is a permutation matrix, L is lower triangular with unit */
+/* diagonal elements (lower trapezoidal if m > n), and U is upper */
+/* triangular (upper trapezoidal if m < n). */
+
+/* This code implements an iterative version of Sivan Toledo's recursive */
+/* LU algorithm[1]. For square matrices, this iterative versions should */
+/* be within a factor of two of the optimum number of memory transfers. */
+
+/* The pattern is as follows, with the large blocks of U being updated */
+/* in one call to DTRSM, and the dotted lines denoting sections that */
+/* have had all pending permutations applied: */
+
+/* 1 2 3 4 5 6 7 8 */
+/* +-+-+---+-------+------ */
+/* | |1| | | */
+/* |.+-+ 2 | | */
+/* | | | | | */
+/* |.|.+-+-+ 4 | */
+/* | | | |1| | */
+/* | | |.+-+ | */
+/* | | | | | | */
+/* |.|.|.|.+-+-+---+ 8 */
+/* | | | | | |1| | */
+/* | | | | |.+-+ 2 | */
+/* | | | | | | | | */
+/* | | | | |.|.+-+-+ */
+/* | | | | | | | |1| */
+/* | | | | | | |.+-+ */
+/* | | | | | | | | | */
+/* |.|.|.|.|.|.|.|.+----- */
+/* | | | | | | | | | */
+
+/* The 1-2-1-4-1-2-1-8-... pattern is the position of the last 1 bit in */
+/* the binary expansion of the current column. Each Schur update is */
+/* applied as soon as the necessary portion of U is available. */
+
+/* [1] Toledo, S. 1997. Locality of Reference in LU Decomposition with */
+/* Partial Pivoting. SIAM J. Matrix Anal. Appl. 18, 4 (Oct. 1997), */
+/* 1065-1081. http://dx.doi.org/10.1137/S0895479896297744 */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGETRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Compute machine safe minimum */
+
+ sfmin = slamch_("S");
+
+ nstep = min(*m,*n);
+ i__1 = nstep;
+ for (j = 1; j <= i__1; ++j) {
+ kahead = j & -j;
+ kstart = j + 1 - kahead;
+/* Computing MIN */
+ i__2 = kahead, i__3 = *m - j;
+ kcols = min(i__2,i__3);
+
+/* Find pivot. */
+
+ i__2 = *m - j + 1;
+ jp = j - 1 + icamax_(&i__2, &a[j + j * a_dim1], &c__1);
+ ipiv[j] = jp;
+/* Permute just this column. */
+ if (jp != j) {
+ i__2 = j + j * a_dim1;
+ tmp.r = a[i__2].r, tmp.i = a[i__2].i;
+ i__2 = j + j * a_dim1;
+ i__3 = jp + j * a_dim1;
+ a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
+ i__2 = jp + j * a_dim1;
+ a[i__2].r = tmp.r, a[i__2].i = tmp.i;
+ }
+/* Apply pending permutations to L */
+ ntopiv = 1;
+ ipivstart = j;
+ jpivstart = j - ntopiv;
+ while(ntopiv < kahead) {
+ claswp_(&ntopiv, &a[jpivstart * a_dim1 + 1], lda, &ipivstart, &j,
+ &ipiv[1], &c__1);
+ ipivstart -= ntopiv;
+ ntopiv <<= 1;
+ jpivstart -= ntopiv;
+ }
+/* Permute U block to match L */
+ claswp_(&kcols, &a[(j + 1) * a_dim1 + 1], lda, &kstart, &j, &ipiv[1],
+ &c__1);
+/* Factor the current column */
+ pivmag = c_abs(&a[j + j * a_dim1]);
+ if (pivmag != 0.f && ! sisnan_(&pivmag)) {
+ if (pivmag >= sfmin) {
+ i__2 = *m - j;
+ c_div(&q__1, &c_b1, &a[j + j * a_dim1]);
+ cscal_(&i__2, &q__1, &a[j + 1 + j * a_dim1], &c__1);
+ } else {
+ i__2 = *m - j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ + j * a_dim1;
+ c_div(&q__1, &a[j + i__ + j * a_dim1], &a[j + j * a_dim1])
+ ;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ }
+ }
+ } else if (pivmag == 0.f && *info == 0) {
+ *info = j;
+ }
+/* Solve for U block. */
+ ctrsm_("Left", "Lower", "No transpose", "Unit", &kahead, &kcols, &
+ c_b1, &a[kstart + kstart * a_dim1], lda, &a[kstart + (j + 1) *
+ a_dim1], lda);
+/* Schur complement. */
+ i__2 = *m - j;
+ cgemm_("No transpose", "No transpose", &i__2, &kcols, &kahead, &c_b2,
+ &a[j + 1 + kstart * a_dim1], lda, &a[kstart + (j + 1) *
+ a_dim1], lda, &c_b1, &a[j + 1 + (j + 1) * a_dim1], lda);
+ }
+/* Handle pivot permutations on the way out of the recursion */
+ npived = nstep & -nstep;
+ j = nstep - npived;
+ while(j > 0) {
+ ntopiv = j & -j;
+ i__1 = j + 1;
+ claswp_(&ntopiv, &a[(j - ntopiv + 1) * a_dim1 + 1], lda, &i__1, &
+ nstep, &ipiv[1], &c__1);
+ j -= ntopiv;
+ }
+/* If short and wide, handle the rest of the columns. */
+ if (*m < *n) {
+ i__1 = *n - *m;
+ claswp_(&i__1, &a[(*m + kcols + 1) * a_dim1 + 1], lda, &c__1, m, &
+ ipiv[1], &c__1);
+ i__1 = *n - *m;
+ ctrsm_("Left", "Lower", "No transpose", "Unit", m, &i__1, &c_b1, &a[
+ a_offset], lda, &a[(*m + kcols + 1) * a_dim1 + 1], lda);
+ }
+ return 0;
+
+/* End of CGETRF */
+
+} /* cgetrf_ */
diff --git a/SRC/VARIANTS/lu/REC/dgetrf.c b/SRC/VARIANTS/lu/REC/dgetrf.c
new file mode 100644
index 0000000..dd63ffc
--- /dev/null
+++ b/SRC/VARIANTS/lu/REC/dgetrf.c
@@ -0,0 +1,268 @@
+/* dgetrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b12 = 1.;
+static doublereal c_b15 = -1.;
+
+/* Subroutine */ int dgetrf_(integer *m, integer *n, doublereal *a, integer *
+ lda, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, j, ipivstart, jpivstart, jp;
+ doublereal tmp;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *), dgemm_(char *, char *, integer *, integer *, integer *
+, doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ integer kcols;
+ doublereal sfmin;
+ integer nstep;
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer kahead;
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern logical disnan_(doublereal *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer npived;
+ extern /* Subroutine */ int dlaswp_(integer *, doublereal *, integer *,
+ integer *, integer *, integer *, integer *);
+ integer kstart, ntopiv;
+
+
+/* -- LAPACK routine (version 3.X) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* May 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGETRF computes an LU factorization of a general M-by-N matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* The factorization has the form */
+/* A = P * L * U */
+/* where P is a permutation matrix, L is lower triangular with unit */
+/* diagonal elements (lower trapezoidal if m > n), and U is upper */
+/* triangular (upper trapezoidal if m < n). */
+
+/* This code implements an iterative version of Sivan Toledo's recursive */
+/* LU algorithm[1]. For square matrices, this iterative versions should */
+/* be within a factor of two of the optimum number of memory transfers. */
+
+/* The pattern is as follows, with the large blocks of U being updated */
+/* in one call to DTRSM, and the dotted lines denoting sections that */
+/* have had all pending permutations applied: */
+
+/* 1 2 3 4 5 6 7 8 */
+/* +-+-+---+-------+------ */
+/* | |1| | | */
+/* |.+-+ 2 | | */
+/* | | | | | */
+/* |.|.+-+-+ 4 | */
+/* | | | |1| | */
+/* | | |.+-+ | */
+/* | | | | | | */
+/* |.|.|.|.+-+-+---+ 8 */
+/* | | | | | |1| | */
+/* | | | | |.+-+ 2 | */
+/* | | | | | | | | */
+/* | | | | |.|.+-+-+ */
+/* | | | | | | | |1| */
+/* | | | | | | |.+-+ */
+/* | | | | | | | | | */
+/* |.|.|.|.|.|.|.|.+----- */
+/* | | | | | | | | | */
+
+/* The 1-2-1-4-1-2-1-8-... pattern is the position of the last 1 bit in */
+/* the binary expansion of the current column. Each Schur update is */
+/* applied as soon as the necessary portion of U is available. */
+
+/* [1] Toledo, S. 1997. Locality of Reference in LU Decomposition with */
+/* Partial Pivoting. SIAM J. Matrix Anal. Appl. 18, 4 (Oct. 1997), */
+/* 1065-1081. http://dx.doi.org/10.1137/S0895479896297744 */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGETRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Compute machine safe minimum */
+
+ sfmin = dlamch_("S");
+
+ nstep = min(*m,*n);
+ i__1 = nstep;
+ for (j = 1; j <= i__1; ++j) {
+ kahead = j & -j;
+ kstart = j + 1 - kahead;
+/* Computing MIN */
+ i__2 = kahead, i__3 = *m - j;
+ kcols = min(i__2,i__3);
+
+/* Find pivot. */
+
+ i__2 = *m - j + 1;
+ jp = j - 1 + idamax_(&i__2, &a[j + j * a_dim1], &c__1);
+ ipiv[j] = jp;
+/* Permute just this column. */
+ if (jp != j) {
+ tmp = a[j + j * a_dim1];
+ a[j + j * a_dim1] = a[jp + j * a_dim1];
+ a[jp + j * a_dim1] = tmp;
+ }
+/* Apply pending permutations to L */
+ ntopiv = 1;
+ ipivstart = j;
+ jpivstart = j - ntopiv;
+ while(ntopiv < kahead) {
+ dlaswp_(&ntopiv, &a[jpivstart * a_dim1 + 1], lda, &ipivstart, &j,
+ &ipiv[1], &c__1);
+ ipivstart -= ntopiv;
+ ntopiv <<= 1;
+ jpivstart -= ntopiv;
+ }
+/* Permute U block to match L */
+ dlaswp_(&kcols, &a[(j + 1) * a_dim1 + 1], lda, &kstart, &j, &ipiv[1],
+ &c__1);
+/* Factor the current column */
+ if (a[j + j * a_dim1] != 0. && ! disnan_(&a[j + j * a_dim1])) {
+ if ((d__1 = a[j + j * a_dim1], abs(d__1)) >= sfmin) {
+ i__2 = *m - j;
+ d__1 = 1. / a[j + j * a_dim1];
+ dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1);
+ } else {
+ i__2 = *m - j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[j + i__ + j * a_dim1] /= a[j + j * a_dim1];
+ }
+ }
+ } else if (a[j + j * a_dim1] == 0. && *info == 0) {
+ *info = j;
+ }
+/* Solve for U block. */
+ dtrsm_("Left", "Lower", "No transpose", "Unit", &kahead, &kcols, &
+ c_b12, &a[kstart + kstart * a_dim1], lda, &a[kstart + (j + 1)
+ * a_dim1], lda);
+/* Schur complement. */
+ i__2 = *m - j;
+ dgemm_("No transpose", "No transpose", &i__2, &kcols, &kahead, &c_b15,
+ &a[j + 1 + kstart * a_dim1], lda, &a[kstart + (j + 1) *
+ a_dim1], lda, &c_b12, &a[j + 1 + (j + 1) * a_dim1], lda);
+ }
+/* Handle pivot permutations on the way out of the recursion */
+ npived = nstep & -nstep;
+ j = nstep - npived;
+ while(j > 0) {
+ ntopiv = j & -j;
+ i__1 = j + 1;
+ dlaswp_(&ntopiv, &a[(j - ntopiv + 1) * a_dim1 + 1], lda, &i__1, &
+ nstep, &ipiv[1], &c__1);
+ j -= ntopiv;
+ }
+/* If short and wide, handle the rest of the columns. */
+ if (*m < *n) {
+ i__1 = *n - *m;
+ dlaswp_(&i__1, &a[(*m + kcols + 1) * a_dim1 + 1], lda, &c__1, m, &
+ ipiv[1], &c__1);
+ i__1 = *n - *m;
+ dtrsm_("Left", "Lower", "No transpose", "Unit", m, &i__1, &c_b12, &a[
+ a_offset], lda, &a[(*m + kcols + 1) * a_dim1 + 1], lda);
+ }
+ return 0;
+
+/* End of DGETRF */
+
+} /* dgetrf_ */
diff --git a/SRC/VARIANTS/lu/REC/sgetrf.c b/SRC/VARIANTS/lu/REC/sgetrf.c
new file mode 100644
index 0000000..4620f28
--- /dev/null
+++ b/SRC/VARIANTS/lu/REC/sgetrf.c
@@ -0,0 +1,268 @@
+/* sgetrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b12 = 1.f;
+static real c_b15 = -1.f;
+
+/* Subroutine */ int sgetrf_(integer *m, integer *n, real *a, integer *lda,
+ integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j, ipivstart, jpivstart, jp;
+ real tmp;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ sgemm_(char *, char *, integer *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ integer kcols;
+ real sfmin;
+ integer nstep;
+ extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+);
+ integer kahead;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ integer npived;
+ extern logical sisnan_(real *);
+ integer kstart;
+ extern /* Subroutine */ int slaswp_(integer *, real *, integer *, integer
+ *, integer *, integer *, integer *);
+ integer ntopiv;
+
+
+/* -- LAPACK routine (version 3.X) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* May 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGETRF computes an LU factorization of a general M-by-N matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* The factorization has the form */
+/* A = P * L * U */
+/* where P is a permutation matrix, L is lower triangular with unit */
+/* diagonal elements (lower trapezoidal if m > n), and U is upper */
+/* triangular (upper trapezoidal if m < n). */
+
+/* This code implements an iterative version of Sivan Toledo's recursive */
+/* LU algorithm[1]. For square matrices, this iterative versions should */
+/* be within a factor of two of the optimum number of memory transfers. */
+
+/* The pattern is as follows, with the large blocks of U being updated */
+/* in one call to STRSM, and the dotted lines denoting sections that */
+/* have had all pending permutations applied: */
+
+/* 1 2 3 4 5 6 7 8 */
+/* +-+-+---+-------+------ */
+/* | |1| | | */
+/* |.+-+ 2 | | */
+/* | | | | | */
+/* |.|.+-+-+ 4 | */
+/* | | | |1| | */
+/* | | |.+-+ | */
+/* | | | | | | */
+/* |.|.|.|.+-+-+---+ 8 */
+/* | | | | | |1| | */
+/* | | | | |.+-+ 2 | */
+/* | | | | | | | | */
+/* | | | | |.|.+-+-+ */
+/* | | | | | | | |1| */
+/* | | | | | | |.+-+ */
+/* | | | | | | | | | */
+/* |.|.|.|.|.|.|.|.+----- */
+/* | | | | | | | | | */
+
+/* The 1-2-1-4-1-2-1-8-... pattern is the position of the last 1 bit in */
+/* the binary expansion of the current column. Each Schur update is */
+/* applied as soon as the necessary portion of U is available. */
+
+/* [1] Toledo, S. 1997. Locality of Reference in LU Decomposition with */
+/* Partial Pivoting. SIAM J. Matrix Anal. Appl. 18, 4 (Oct. 1997), */
+/* 1065-1081. http://dx.doi.org/10.1137/S0895479896297744 */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGETRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Compute machine safe minimum */
+
+ sfmin = slamch_("S");
+
+ nstep = min(*m,*n);
+ i__1 = nstep;
+ for (j = 1; j <= i__1; ++j) {
+ kahead = j & -j;
+ kstart = j + 1 - kahead;
+/* Computing MIN */
+ i__2 = kahead, i__3 = *m - j;
+ kcols = min(i__2,i__3);
+
+/* Find pivot. */
+
+ i__2 = *m - j + 1;
+ jp = j - 1 + isamax_(&i__2, &a[j + j * a_dim1], &c__1);
+ ipiv[j] = jp;
+/* Permute just this column. */
+ if (jp != j) {
+ tmp = a[j + j * a_dim1];
+ a[j + j * a_dim1] = a[jp + j * a_dim1];
+ a[jp + j * a_dim1] = tmp;
+ }
+/* Apply pending permutations to L */
+ ntopiv = 1;
+ ipivstart = j;
+ jpivstart = j - ntopiv;
+ while(ntopiv < kahead) {
+ slaswp_(&ntopiv, &a[jpivstart * a_dim1 + 1], lda, &ipivstart, &j,
+ &ipiv[1], &c__1);
+ ipivstart -= ntopiv;
+ ntopiv <<= 1;
+ jpivstart -= ntopiv;
+ }
+/* Permute U block to match L */
+ slaswp_(&kcols, &a[(j + 1) * a_dim1 + 1], lda, &kstart, &j, &ipiv[1],
+ &c__1);
+/* Factor the current column */
+ if (a[j + j * a_dim1] != 0.f && ! sisnan_(&a[j + j * a_dim1])) {
+ if ((r__1 = a[j + j * a_dim1], dabs(r__1)) >= sfmin) {
+ i__2 = *m - j;
+ r__1 = 1.f / a[j + j * a_dim1];
+ sscal_(&i__2, &r__1, &a[j + 1 + j * a_dim1], &c__1);
+ } else {
+ i__2 = *m - j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[j + i__ + j * a_dim1] /= a[j + j * a_dim1];
+ }
+ }
+ } else if (a[j + j * a_dim1] == 0.f && *info == 0) {
+ *info = j;
+ }
+/* Solve for U block. */
+ strsm_("Left", "Lower", "No transpose", "Unit", &kahead, &kcols, &
+ c_b12, &a[kstart + kstart * a_dim1], lda, &a[kstart + (j + 1)
+ * a_dim1], lda);
+/* Schur complement. */
+ i__2 = *m - j;
+ sgemm_("No transpose", "No transpose", &i__2, &kcols, &kahead, &c_b15,
+ &a[j + 1 + kstart * a_dim1], lda, &a[kstart + (j + 1) *
+ a_dim1], lda, &c_b12, &a[j + 1 + (j + 1) * a_dim1], lda);
+ }
+/* Handle pivot permutations on the way out of the recursion */
+ npived = nstep & -nstep;
+ j = nstep - npived;
+ while(j > 0) {
+ ntopiv = j & -j;
+ i__1 = j + 1;
+ slaswp_(&ntopiv, &a[(j - ntopiv + 1) * a_dim1 + 1], lda, &i__1, &
+ nstep, &ipiv[1], &c__1);
+ j -= ntopiv;
+ }
+/* If short and wide, handle the rest of the columns. */
+ if (*m < *n) {
+ i__1 = *n - *m;
+ slaswp_(&i__1, &a[(*m + kcols + 1) * a_dim1 + 1], lda, &c__1, m, &
+ ipiv[1], &c__1);
+ i__1 = *n - *m;
+ strsm_("Left", "Lower", "No transpose", "Unit", m, &i__1, &c_b12, &a[
+ a_offset], lda, &a[(*m + kcols + 1) * a_dim1 + 1], lda);
+ }
+ return 0;
+
+/* End of SGETRF */
+
+} /* sgetrf_ */
diff --git a/SRC/VARIANTS/lu/REC/zgetrf.c b/SRC/VARIANTS/lu/REC/zgetrf.c
new file mode 100644
index 0000000..dd3be9f
--- /dev/null
+++ b/SRC/VARIANTS/lu/REC/zgetrf.c
@@ -0,0 +1,282 @@
+/* zgetrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static doublecomplex c_b2 = {-1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zgetrf_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, ipivstart, jpivstart, jp;
+ doublecomplex tmp;
+ integer kcols;
+ doublereal sfmin;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zgemm_(char *, char *, integer *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer nstep;
+ extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ integer kahead;
+ extern doublereal dlamch_(char *);
+ extern logical disnan_(doublereal *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal pivmag;
+ integer npived;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ integer kstart, ntopiv;
+ extern /* Subroutine */ int zlaswp_(integer *, doublecomplex *, integer *,
+ integer *, integer *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.X) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* May 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGETRF computes an LU factorization of a general M-by-N matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* The factorization has the form */
+/* A = P * L * U */
+/* where P is a permutation matrix, L is lower triangular with unit */
+/* diagonal elements (lower trapezoidal if m > n), and U is upper */
+/* triangular (upper trapezoidal if m < n). */
+
+/* This code implements an iterative version of Sivan Toledo's recursive */
+/* LU algorithm[1]. For square matrices, this iterative versions should */
+/* be within a factor of two of the optimum number of memory transfers. */
+
+/* The pattern is as follows, with the large blocks of U being updated */
+/* in one call to DTRSM, and the dotted lines denoting sections that */
+/* have had all pending permutations applied: */
+
+/* 1 2 3 4 5 6 7 8 */
+/* +-+-+---+-------+------ */
+/* | |1| | | */
+/* |.+-+ 2 | | */
+/* | | | | | */
+/* |.|.+-+-+ 4 | */
+/* | | | |1| | */
+/* | | |.+-+ | */
+/* | | | | | | */
+/* |.|.|.|.+-+-+---+ 8 */
+/* | | | | | |1| | */
+/* | | | | |.+-+ 2 | */
+/* | | | | | | | | */
+/* | | | | |.|.+-+-+ */
+/* | | | | | | | |1| */
+/* | | | | | | |.+-+ */
+/* | | | | | | | | | */
+/* |.|.|.|.|.|.|.|.+----- */
+/* | | | | | | | | | */
+
+/* The 1-2-1-4-1-2-1-8-... pattern is the position of the last 1 bit in */
+/* the binary expansion of the current column. Each Schur update is */
+/* applied as soon as the necessary portion of U is available. */
+
+/* [1] Toledo, S. 1997. Locality of Reference in LU Decomposition with */
+/* Partial Pivoting. SIAM J. Matrix Anal. Appl. 18, 4 (Oct. 1997), */
+/* 1065-1081. http://dx.doi.org/10.1137/S0895479896297744 */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGETRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Compute machine safe minimum */
+
+ sfmin = dlamch_("S");
+
+ nstep = min(*m,*n);
+ i__1 = nstep;
+ for (j = 1; j <= i__1; ++j) {
+ kahead = j & -j;
+ kstart = j + 1 - kahead;
+/* Computing MIN */
+ i__2 = kahead, i__3 = *m - j;
+ kcols = min(i__2,i__3);
+
+/* Find pivot. */
+
+ i__2 = *m - j + 1;
+ jp = j - 1 + izamax_(&i__2, &a[j + j * a_dim1], &c__1);
+ ipiv[j] = jp;
+/* Permute just this column. */
+ if (jp != j) {
+ i__2 = j + j * a_dim1;
+ tmp.r = a[i__2].r, tmp.i = a[i__2].i;
+ i__2 = j + j * a_dim1;
+ i__3 = jp + j * a_dim1;
+ a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
+ i__2 = jp + j * a_dim1;
+ a[i__2].r = tmp.r, a[i__2].i = tmp.i;
+ }
+/* Apply pending permutations to L */
+ ntopiv = 1;
+ ipivstart = j;
+ jpivstart = j - ntopiv;
+ while(ntopiv < kahead) {
+ zlaswp_(&ntopiv, &a[jpivstart * a_dim1 + 1], lda, &ipivstart, &j,
+ &ipiv[1], &c__1);
+ ipivstart -= ntopiv;
+ ntopiv <<= 1;
+ jpivstart -= ntopiv;
+ }
+/* Permute U block to match L */
+ zlaswp_(&kcols, &a[(j + 1) * a_dim1 + 1], lda, &kstart, &j, &ipiv[1],
+ &c__1);
+/* Factor the current column */
+ pivmag = z_abs(&a[j + j * a_dim1]);
+ if (pivmag != 0. && ! disnan_(&pivmag)) {
+ if (pivmag >= sfmin) {
+ i__2 = *m - j;
+ z_div(&z__1, &c_b1, &a[j + j * a_dim1]);
+ zscal_(&i__2, &z__1, &a[j + 1 + j * a_dim1], &c__1);
+ } else {
+ i__2 = *m - j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ + j * a_dim1;
+ z_div(&z__1, &a[j + i__ + j * a_dim1], &a[j + j * a_dim1])
+ ;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ }
+ }
+ } else if (pivmag == 0. && *info == 0) {
+ *info = j;
+ }
+/* Solve for U block. */
+ ztrsm_("Left", "Lower", "No transpose", "Unit", &kahead, &kcols, &
+ c_b1, &a[kstart + kstart * a_dim1], lda, &a[kstart + (j + 1) *
+ a_dim1], lda);
+/* Schur complement. */
+ i__2 = *m - j;
+ zgemm_("No transpose", "No transpose", &i__2, &kcols, &kahead, &c_b2,
+ &a[j + 1 + kstart * a_dim1], lda, &a[kstart + (j + 1) *
+ a_dim1], lda, &c_b1, &a[j + 1 + (j + 1) * a_dim1], lda);
+ }
+/* Handle pivot permutations on the way out of the recursion */
+ npived = nstep & -nstep;
+ j = nstep - npived;
+ while(j > 0) {
+ ntopiv = j & -j;
+ i__1 = j + 1;
+ zlaswp_(&ntopiv, &a[(j - ntopiv + 1) * a_dim1 + 1], lda, &i__1, &
+ nstep, &ipiv[1], &c__1);
+ j -= ntopiv;
+ }
+/* If short and wide, handle the rest of the columns. */
+ if (*m < *n) {
+ i__1 = *n - *m;
+ zlaswp_(&i__1, &a[(*m + kcols + 1) * a_dim1 + 1], lda, &c__1, m, &
+ ipiv[1], &c__1);
+ i__1 = *n - *m;
+ ztrsm_("Left", "Lower", "No transpose", "Unit", m, &i__1, &c_b1, &a[
+ a_offset], lda, &a[(*m + kcols + 1) * a_dim1 + 1], lda);
+ }
+ return 0;
+
+/* End of ZGETRF */
+
+} /* zgetrf_ */
diff --git a/SRC/VARIANTS/qr/LL/cgeqrf.c b/SRC/VARIANTS/qr/LL/cgeqrf.c
new file mode 100644
index 0000000..44a249d
--- /dev/null
+++ b/SRC/VARIANTS/qr/LL/cgeqrf.c
@@ -0,0 +1,405 @@
+/* cgeqrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int cgeqrf_(integer *m, integer *n, complex *a, integer *lda,
+ complex *tau, complex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j, k, ib, nb, nt, nx, iws;
+ extern doublereal sceil_(real *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int cgeqr2_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *), clarfb_(char *, char
+ *, char *, char *, integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *), clarft_(char *, char *
+, integer *, integer *, complex *, integer *, complex *, complex *
+, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer lbwork, llwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* March 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGEQRF computes a QR factorization of a real M-by-N matrix A: */
+/* A = Q * R. */
+
+/* This is the left-looking Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(M,N)-by-N upper trapezoidal matrix R (R is */
+/* upper triangular if m >= n); the elements below the diagonal, */
+/* with the array TAU, represent the orthogonal matrix Q as a */
+/* product of min(m,n) elementary reflectors (see Further */
+/* Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+
+/* The dimension of the array WORK. The dimension can be divided into three parts. */
+
+/* 1) The part for the triangular factor T. If the very last T is not bigger */
+/* than any of the rest, then this part is NB x ceiling(K/NB), otherwise, */
+/* NB x (K-NT), where K = min(M,N) and NT is the dimension of the very last T */
+
+/* 2) The part for the very last T when T is bigger than any of the rest T. */
+/* The size of this part is NT x NT, where NT = K - ceiling ((K-NX)/NB) x NB, */
+/* where K = min(M,N), NX is calculated by */
+/* NX = MAX( 0, ILAENV( 3, 'CGEQRF', ' ', M, N, -1, -1 ) ) */
+
+/* 3) The part for dlarfb is of size max((N-M)*K, (N-M)*NB, K*NB, NB*NB) */
+
+/* So LWORK = part1 + part2 + part3 */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */
+/* and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nbmin = 2;
+ nx = 0;
+ iws = *n;
+ k = min(*m,*n);
+ nb = ilaenv_(&c__1, "CGEQRF", " ", m, n, &c_n1, &c_n1);
+ if (nb > 1 && nb < k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "CGEQRF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ }
+
+/* Get NT, the size of the very last T, which is the left-over from in-between K-NX and K to K, eg.: */
+
+/* NB=3 2NB=6 K=10 */
+/* | | | */
+/* 1--2--3--4--5--6--7--8--9--10 */
+/* | \________/ */
+/* K-NX=5 NT=4 */
+
+/* So here 4 x 4 is the last T stored in the workspace */
+
+ r__1 = (real) (k - nx) / (real) nb;
+ nt = k - sceil_(&r__1) * nb;
+
+/* optimal workspace = space for dlarfb + space for normal T's + space for the last T */
+
+/* Computing MAX */
+/* Computing MAX */
+ i__3 = (*n - *m) * k, i__4 = (*n - *m) * nb;
+/* Computing MAX */
+ i__5 = k * nb, i__6 = nb * nb;
+ i__1 = max(i__3,i__4), i__2 = max(i__5,i__6);
+ llwork = max(i__1,i__2);
+ r__1 = (real) llwork / (real) nb;
+ llwork = sceil_(&r__1);
+ if (nt > nb) {
+ lbwork = k - nt;
+
+/* Optimal workspace for dlarfb = MAX(1,N)*NT */
+
+ lwkopt = (lbwork + llwork) * nb;
+ i__1 = lwkopt + nt * nt;
+ work[1].r = (real) i__1, work[1].i = 0.f;
+ } else {
+ r__1 = (real) k / (real) nb;
+ lbwork = sceil_(&r__1) * nb;
+ lwkopt = (lbwork + llwork - nb) * nb;
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ }
+
+/* Test the input arguments */
+
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGEQRF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (k == 0) {
+ work[1].r = 1.f, work[1].i = 0.f;
+ return 0;
+ }
+
+ if (nb > 1 && nb < k) {
+ if (nx < k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ if (nt <= nb) {
+ iws = (lbwork + llwork - nb) * nb;
+ } else {
+ iws = (lbwork + llwork) * nb + nt * nt;
+ }
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ if (nt <= nb) {
+ nb = *lwork / (llwork + (lbwork - nb));
+ } else {
+ nb = (*lwork - nt * nt) / (lbwork + llwork);
+ }
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "CGEQRF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < k && nx < k) {
+
+/* Use blocked code initially */
+
+ i__1 = k - nx;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = k - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Update the current column using old T's */
+
+ i__3 = i__ - nb;
+ i__4 = nb;
+ for (j = 1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+
+/* Apply H' to A(J:M,I:I+IB-1) from the left */
+
+ i__5 = *m - j + 1;
+ clarfb_("Left", "Transpose", "Forward", "Columnwise", &i__5, &
+ ib, &nb, &a[j + j * a_dim1], lda, &work[j], &lbwork, &
+ a[j + i__ * a_dim1], lda, &work[lbwork * nb + nt * nt
+ + 1], &ib);
+/* L20: */
+ }
+
+/* Compute the QR factorization of the current block */
+/* A(I:M,I:I+IB-1) */
+
+ i__4 = *m - i__ + 1;
+ cgeqr2_(&i__4, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
+ lbwork * nb + nt * nt + 1], &iinfo);
+ if (i__ + ib <= *n) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__4 = *m - i__ + 1;
+ clarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[i__], &lbwork);
+
+ }
+/* L10: */
+ }
+ } else {
+ i__ = 1;
+ }
+
+/* Use unblocked code to factor the last or only block. */
+
+ if (i__ <= k) {
+ if (i__ != 1) {
+ i__2 = i__ - nb;
+ i__1 = nb;
+ for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Apply H' to A(J:M,I:K) from the left */
+
+ i__4 = *m - j + 1;
+ i__3 = k - i__ + 1;
+ i__5 = k - i__ + 1;
+ clarfb_("Left", "Transpose", "Forward", "Columnwise", &i__4, &
+ i__3, &nb, &a[j + j * a_dim1], lda, &work[j], &lbwork,
+ &a[j + i__ * a_dim1], lda, &work[lbwork * nb + nt *
+ nt + 1], &i__5);
+/* L30: */
+ }
+ i__1 = *m - i__ + 1;
+ i__2 = k - i__ + 1;
+ cgeqr2_(&i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
+ work[lbwork * nb + nt * nt + 1], &iinfo);
+ } else {
+
+/* Use unblocked code to factor the last or only block. */
+
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__ + 1;
+ cgeqr2_(&i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
+ work[1], &iinfo);
+ }
+ }
+
+/* Apply update to the column M+1:N when N > M */
+
+ if (*m < *n && i__ != 1) {
+
+/* Form the last triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ if (nt <= nb) {
+ i__1 = *m - i__ + 1;
+ i__2 = k - i__ + 1;
+ clarft_("Forward", "Columnwise", &i__1, &i__2, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[i__], &lbwork);
+ } else {
+ i__1 = *m - i__ + 1;
+ i__2 = k - i__ + 1;
+ clarft_("Forward", "Columnwise", &i__1, &i__2, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[lbwork * nb + 1], &nt);
+ }
+
+/* Apply H' to A(1:M,M+1:N) from the left */
+
+ i__1 = k - nx;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__4 = k - j + 1;
+ ib = min(i__4,nb);
+ i__4 = *m - j + 1;
+ i__3 = *n - *m;
+ i__5 = *n - *m;
+ clarfb_("Left", "Transpose", "Forward", "Columnwise", &i__4, &
+ i__3, &ib, &a[j + j * a_dim1], lda, &work[j], &lbwork, &a[
+ j + (*m + 1) * a_dim1], lda, &work[lbwork * nb + nt * nt
+ + 1], &i__5);
+/* L40: */
+ }
+ if (nt <= nb) {
+ i__2 = *m - j + 1;
+ i__1 = *n - *m;
+ i__4 = k - j + 1;
+ i__3 = *n - *m;
+ clarfb_("Left", "Transpose", "Forward", "Columnwise", &i__2, &
+ i__1, &i__4, &a[j + j * a_dim1], lda, &work[j], &lbwork, &
+ a[j + (*m + 1) * a_dim1], lda, &work[lbwork * nb + nt *
+ nt + 1], &i__3);
+ } else {
+ i__2 = *m - j + 1;
+ i__1 = *n - *m;
+ i__4 = k - j + 1;
+ i__3 = *n - *m;
+ clarfb_("Left", "Transpose", "Forward", "Columnwise", &i__2, &
+ i__1, &i__4, &a[j + j * a_dim1], lda, &work[lbwork * nb +
+ 1], &nt, &a[j + (*m + 1) * a_dim1], lda, &work[lbwork *
+ nb + nt * nt + 1], &i__3);
+ }
+ }
+ work[1].r = (real) iws, work[1].i = 0.f;
+ return 0;
+
+/* End of CGEQRF */
+
+} /* cgeqrf_ */
diff --git a/SRC/VARIANTS/qr/LL/dgeqrf.c b/SRC/VARIANTS/qr/LL/dgeqrf.c
new file mode 100644
index 0000000..deac6b3
--- /dev/null
+++ b/SRC/VARIANTS/qr/LL/dgeqrf.c
@@ -0,0 +1,403 @@
+/* dgeqrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int dgeqrf_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *tau, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j, k, ib, nb, nt, nx, iws;
+ extern doublereal sceil_(real *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *), dlarfb_(char *,
+ char *, char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *), dlarft_(char *, char *, integer *, integer *, doublereal
+ *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer lbwork, llwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* March 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGEQRF computes a QR factorization of a real M-by-N matrix A: */
+/* A = Q * R. */
+
+/* This is the left-looking Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(M,N)-by-N upper trapezoidal matrix R (R is */
+/* upper triangular if m >= n); the elements below the diagonal, */
+/* with the array TAU, represent the orthogonal matrix Q as a */
+/* product of min(m,n) elementary reflectors (see Further */
+/* Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+
+/* The dimension of the array WORK. The dimension can be divided into three parts. */
+
+/* 1) The part for the triangular factor T. If the very last T is not bigger */
+/* than any of the rest, then this part is NB x ceiling(K/NB), otherwise, */
+/* NB x (K-NT), where K = min(M,N) and NT is the dimension of the very last T */
+
+/* 2) The part for the very last T when T is bigger than any of the rest T. */
+/* The size of this part is NT x NT, where NT = K - ceiling ((K-NX)/NB) x NB, */
+/* where K = min(M,N), NX is calculated by */
+/* NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) ) */
+
+/* 3) The part for dlarfb is of size max((N-M)*K, (N-M)*NB, K*NB, NB*NB) */
+
+/* So LWORK = part1 + part2 + part3 */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */
+/* and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nbmin = 2;
+ nx = 0;
+ iws = *n;
+ k = min(*m,*n);
+ nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1);
+ if (nb > 1 && nb < k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "DGEQRF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ }
+
+/* Get NT, the size of the very last T, which is the left-over from in-between K-NX and K to K, eg.: */
+
+/* NB=3 2NB=6 K=10 */
+/* | | | */
+/* 1--2--3--4--5--6--7--8--9--10 */
+/* | \________/ */
+/* K-NX=5 NT=4 */
+
+/* So here 4 x 4 is the last T stored in the workspace */
+
+ r__1 = (real) (k - nx) / (real) nb;
+ nt = k - sceil_(&r__1) * nb;
+
+/* optimal workspace = space for dlarfb + space for normal T's + space for the last T */
+
+/* Computing MAX */
+/* Computing MAX */
+ i__3 = (*n - *m) * k, i__4 = (*n - *m) * nb;
+/* Computing MAX */
+ i__5 = k * nb, i__6 = nb * nb;
+ i__1 = max(i__3,i__4), i__2 = max(i__5,i__6);
+ llwork = max(i__1,i__2);
+ r__1 = (real) llwork / (real) nb;
+ llwork = sceil_(&r__1);
+ if (nt > nb) {
+ lbwork = k - nt;
+
+/* Optimal workspace for dlarfb = MAX(1,N)*NT */
+
+ lwkopt = (lbwork + llwork) * nb;
+ work[1] = (doublereal) (lwkopt + nt * nt);
+ } else {
+ r__1 = (real) k / (real) nb;
+ lbwork = sceil_(&r__1) * nb;
+ lwkopt = (lbwork + llwork - nb) * nb;
+ work[1] = (doublereal) lwkopt;
+ }
+
+/* Test the input arguments */
+
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGEQRF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (k == 0) {
+ work[1] = 1.;
+ return 0;
+ }
+
+ if (nb > 1 && nb < k) {
+ if (nx < k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ if (nt <= nb) {
+ iws = (lbwork + llwork - nb) * nb;
+ } else {
+ iws = (lbwork + llwork) * nb + nt * nt;
+ }
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ if (nt <= nb) {
+ nb = *lwork / (llwork + (lbwork - nb));
+ } else {
+ nb = (*lwork - nt * nt) / (lbwork + llwork);
+ }
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "DGEQRF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < k && nx < k) {
+
+/* Use blocked code initially */
+
+ i__1 = k - nx;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = k - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Update the current column using old T's */
+
+ i__3 = i__ - nb;
+ i__4 = nb;
+ for (j = 1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+
+/* Apply H' to A(J:M,I:I+IB-1) from the left */
+
+ i__5 = *m - j + 1;
+ dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__5, &
+ ib, &nb, &a[j + j * a_dim1], lda, &work[j], &lbwork, &
+ a[j + i__ * a_dim1], lda, &work[lbwork * nb + nt * nt
+ + 1], &ib);
+/* L20: */
+ }
+
+/* Compute the QR factorization of the current block */
+/* A(I:M,I:I+IB-1) */
+
+ i__4 = *m - i__ + 1;
+ dgeqr2_(&i__4, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
+ lbwork * nb + nt * nt + 1], &iinfo);
+ if (i__ + ib <= *n) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__4 = *m - i__ + 1;
+ dlarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[i__], &lbwork);
+
+ }
+/* L10: */
+ }
+ } else {
+ i__ = 1;
+ }
+
+/* Use unblocked code to factor the last or only block. */
+
+ if (i__ <= k) {
+ if (i__ != 1) {
+ i__2 = i__ - nb;
+ i__1 = nb;
+ for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Apply H' to A(J:M,I:K) from the left */
+
+ i__4 = *m - j + 1;
+ i__3 = k - i__ + 1;
+ i__5 = k - i__ + 1;
+ dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__4, &
+ i__3, &nb, &a[j + j * a_dim1], lda, &work[j], &lbwork,
+ &a[j + i__ * a_dim1], lda, &work[lbwork * nb + nt *
+ nt + 1], &i__5);
+/* L30: */
+ }
+ i__1 = *m - i__ + 1;
+ i__2 = k - i__ + 1;
+ dgeqr2_(&i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
+ work[lbwork * nb + nt * nt + 1], &iinfo);
+ } else {
+
+/* Use unblocked code to factor the last or only block. */
+
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__ + 1;
+ dgeqr2_(&i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
+ work[1], &iinfo);
+ }
+ }
+
+/* Apply update to the column M+1:N when N > M */
+
+ if (*m < *n && i__ != 1) {
+
+/* Form the last triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ if (nt <= nb) {
+ i__1 = *m - i__ + 1;
+ i__2 = k - i__ + 1;
+ dlarft_("Forward", "Columnwise", &i__1, &i__2, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[i__], &lbwork);
+ } else {
+ i__1 = *m - i__ + 1;
+ i__2 = k - i__ + 1;
+ dlarft_("Forward", "Columnwise", &i__1, &i__2, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[lbwork * nb + 1], &nt);
+ }
+
+/* Apply H' to A(1:M,M+1:N) from the left */
+
+ i__1 = k - nx;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__4 = k - j + 1;
+ ib = min(i__4,nb);
+ i__4 = *m - j + 1;
+ i__3 = *n - *m;
+ i__5 = *n - *m;
+ dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__4, &
+ i__3, &ib, &a[j + j * a_dim1], lda, &work[j], &lbwork, &a[
+ j + (*m + 1) * a_dim1], lda, &work[lbwork * nb + nt * nt
+ + 1], &i__5);
+/* L40: */
+ }
+ if (nt <= nb) {
+ i__2 = *m - j + 1;
+ i__1 = *n - *m;
+ i__4 = k - j + 1;
+ i__3 = *n - *m;
+ dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__2, &
+ i__1, &i__4, &a[j + j * a_dim1], lda, &work[j], &lbwork, &
+ a[j + (*m + 1) * a_dim1], lda, &work[lbwork * nb + nt *
+ nt + 1], &i__3);
+ } else {
+ i__2 = *m - j + 1;
+ i__1 = *n - *m;
+ i__4 = k - j + 1;
+ i__3 = *n - *m;
+ dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__2, &
+ i__1, &i__4, &a[j + j * a_dim1], lda, &work[lbwork * nb +
+ 1], &nt, &a[j + (*m + 1) * a_dim1], lda, &work[lbwork *
+ nb + nt * nt + 1], &i__3);
+ }
+ }
+ work[1] = (doublereal) iws;
+ return 0;
+
+/* End of DGEQRF */
+
+} /* dgeqrf_ */
diff --git a/SRC/VARIANTS/qr/LL/sceil.c b/SRC/VARIANTS/qr/LL/sceil.c
new file mode 100644
index 0000000..520b50a
--- /dev/null
+++ b/SRC/VARIANTS/qr/LL/sceil.c
@@ -0,0 +1,44 @@
+/* sceil.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal sceil_(real *a)
+{
+ /* System generated locals */
+ real ret_val;
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* June 2008 */
+
+/* .. Scalar Arguments ..* */
+/* .. */
+
+/* ===================================================================== */
+
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements ..* */
+
+ if (*a - (integer) (*a) == 0.f) {
+ ret_val = *a;
+ } else if (*a > 0.f) {
+ ret_val = (real) ((integer) (*a) + 1);
+ } else {
+ ret_val = (real) ((integer) (*a));
+ }
+ return ret_val;
+
+} /* sceil_ */
diff --git a/SRC/VARIANTS/qr/LL/sgeqrf.c b/SRC/VARIANTS/qr/LL/sgeqrf.c
new file mode 100644
index 0000000..ccf8754
--- /dev/null
+++ b/SRC/VARIANTS/qr/LL/sgeqrf.c
@@ -0,0 +1,403 @@
+/* sgeqrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int sgeqrf_(integer *m, integer *n, real *a, integer *lda,
+ real *tau, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j, k, ib, nb, nt, nx, iws;
+ extern doublereal sceil_(real *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int sgeqr2_(integer *, integer *, real *, integer
+ *, real *, real *, integer *), slarfb_(char *, char *, char *,
+ char *, integer *, integer *, integer *, real *, integer *, real *
+, integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slarft_(char *, char *, integer *, integer *,
+ real *, integer *, real *, real *, integer *);
+ integer lbwork, llwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* March 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGEQRF computes a QR factorization of a real M-by-N matrix A: */
+/* A = Q * R. */
+
+/* This is the left-looking Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(M,N)-by-N upper trapezoidal matrix R (R is */
+/* upper triangular if m >= n); the elements below the diagonal, */
+/* with the array TAU, represent the orthogonal matrix Q as a */
+/* product of min(m,n) elementary reflectors (see Further */
+/* Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+
+/* The dimension of the array WORK. The dimension can be divided into three parts. */
+
+/* 1) The part for the triangular factor T. If the very last T is not bigger */
+/* than any of the rest, then this part is NB x ceiling(K/NB), otherwise, */
+/* NB x (K-NT), where K = min(M,N) and NT is the dimension of the very last T */
+
+/* 2) The part for the very last T when T is bigger than any of the rest T. */
+/* The size of this part is NT x NT, where NT = K - ceiling ((K-NX)/NB) x NB, */
+/* where K = min(M,N), NX is calculated by */
+/* NX = MAX( 0, ILAENV( 3, 'SGEQRF', ' ', M, N, -1, -1 ) ) */
+
+/* 3) The part for dlarfb is of size max((N-M)*K, (N-M)*NB, K*NB, NB*NB) */
+
+/* So LWORK = part1 + part2 + part3 */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */
+/* and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nbmin = 2;
+ nx = 0;
+ iws = *n;
+ k = min(*m,*n);
+ nb = ilaenv_(&c__1, "SGEQRF", " ", m, n, &c_n1, &c_n1);
+ if (nb > 1 && nb < k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "SGEQRF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ }
+
+/* Get NT, the size of the very last T, which is the left-over from in-between K-NX and K to K, eg.: */
+
+/* NB=3 2NB=6 K=10 */
+/* | | | */
+/* 1--2--3--4--5--6--7--8--9--10 */
+/* | \________/ */
+/* K-NX=5 NT=4 */
+
+/* So here 4 x 4 is the last T stored in the workspace */
+
+ r__1 = (real) (k - nx) / (real) nb;
+ nt = k - sceil_(&r__1) * nb;
+
+/* optimal workspace = space for dlarfb + space for normal T's + space for the last T */
+
+/* Computing MAX */
+/* Computing MAX */
+ i__3 = (*n - *m) * k, i__4 = (*n - *m) * nb;
+/* Computing MAX */
+ i__5 = k * nb, i__6 = nb * nb;
+ i__1 = max(i__3,i__4), i__2 = max(i__5,i__6);
+ llwork = max(i__1,i__2);
+ r__1 = (real) llwork / (real) nb;
+ llwork = sceil_(&r__1);
+ if (nt > nb) {
+ lbwork = k - nt;
+
+/* Optimal workspace for dlarfb = MAX(1,N)*NT */
+
+ lwkopt = (lbwork + llwork) * nb;
+ work[1] = (real) (lwkopt + nt * nt);
+ } else {
+ r__1 = (real) k / (real) nb;
+ lbwork = sceil_(&r__1) * nb;
+ lwkopt = (lbwork + llwork - nb) * nb;
+ work[1] = (real) lwkopt;
+ }
+
+/* Test the input arguments */
+
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGEQRF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (k == 0) {
+ work[1] = 1.f;
+ return 0;
+ }
+
+ if (nb > 1 && nb < k) {
+ if (nx < k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ if (nt <= nb) {
+ iws = (lbwork + llwork - nb) * nb;
+ } else {
+ iws = (lbwork + llwork) * nb + nt * nt;
+ }
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ if (nt <= nb) {
+ nb = *lwork / (llwork + (lbwork - nb));
+ } else {
+ nb = (*lwork - nt * nt) / (lbwork + llwork);
+ }
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "SGEQRF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < k && nx < k) {
+
+/* Use blocked code initially */
+
+ i__1 = k - nx;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = k - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Update the current column using old T's */
+
+ i__3 = i__ - nb;
+ i__4 = nb;
+ for (j = 1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+
+/* Apply H' to A(J:M,I:I+IB-1) from the left */
+
+ i__5 = *m - j + 1;
+ slarfb_("Left", "Transpose", "Forward", "Columnwise", &i__5, &
+ ib, &nb, &a[j + j * a_dim1], lda, &work[j], &lbwork, &
+ a[j + i__ * a_dim1], lda, &work[lbwork * nb + nt * nt
+ + 1], &ib);
+/* L20: */
+ }
+
+/* Compute the QR factorization of the current block */
+/* A(I:M,I:I+IB-1) */
+
+ i__4 = *m - i__ + 1;
+ sgeqr2_(&i__4, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
+ lbwork * nb + nt * nt + 1], &iinfo);
+ if (i__ + ib <= *n) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__4 = *m - i__ + 1;
+ slarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[i__], &lbwork);
+
+ }
+/* L10: */
+ }
+ } else {
+ i__ = 1;
+ }
+
+/* Use unblocked code to factor the last or only block. */
+
+ if (i__ <= k) {
+ if (i__ != 1) {
+ i__2 = i__ - nb;
+ i__1 = nb;
+ for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Apply H' to A(J:M,I:K) from the left */
+
+ i__4 = *m - j + 1;
+ i__3 = k - i__ + 1;
+ i__5 = k - i__ + 1;
+ slarfb_("Left", "Transpose", "Forward", "Columnwise", &i__4, &
+ i__3, &nb, &a[j + j * a_dim1], lda, &work[j], &lbwork,
+ &a[j + i__ * a_dim1], lda, &work[lbwork * nb + nt *
+ nt + 1], &i__5);
+/* L30: */
+ }
+ i__1 = *m - i__ + 1;
+ i__2 = k - i__ + 1;
+ sgeqr2_(&i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
+ work[lbwork * nb + nt * nt + 1], &iinfo);
+ } else {
+
+/* Use unblocked code to factor the last or only block. */
+
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__ + 1;
+ sgeqr2_(&i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
+ work[1], &iinfo);
+ }
+ }
+
+/* Apply update to the column M+1:N when N > M */
+
+ if (*m < *n && i__ != 1) {
+
+/* Form the last triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ if (nt <= nb) {
+ i__1 = *m - i__ + 1;
+ i__2 = k - i__ + 1;
+ slarft_("Forward", "Columnwise", &i__1, &i__2, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[i__], &lbwork);
+ } else {
+ i__1 = *m - i__ + 1;
+ i__2 = k - i__ + 1;
+ slarft_("Forward", "Columnwise", &i__1, &i__2, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[lbwork * nb + 1], &nt);
+ }
+
+/* Apply H' to A(1:M,M+1:N) from the left */
+
+ i__1 = k - nx;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__4 = k - j + 1;
+ ib = min(i__4,nb);
+ i__4 = *m - j + 1;
+ i__3 = *n - *m;
+ i__5 = *n - *m;
+ slarfb_("Left", "Transpose", "Forward", "Columnwise", &i__4, &
+ i__3, &ib, &a[j + j * a_dim1], lda, &work[j], &lbwork, &a[
+ j + (*m + 1) * a_dim1], lda, &work[lbwork * nb + nt * nt
+ + 1], &i__5);
+/* L40: */
+ }
+ if (nt <= nb) {
+ i__2 = *m - j + 1;
+ i__1 = *n - *m;
+ i__4 = k - j + 1;
+ i__3 = *n - *m;
+ slarfb_("Left", "Transpose", "Forward", "Columnwise", &i__2, &
+ i__1, &i__4, &a[j + j * a_dim1], lda, &work[j], &lbwork, &
+ a[j + (*m + 1) * a_dim1], lda, &work[lbwork * nb + nt *
+ nt + 1], &i__3);
+ } else {
+ i__2 = *m - j + 1;
+ i__1 = *n - *m;
+ i__4 = k - j + 1;
+ i__3 = *n - *m;
+ slarfb_("Left", "Transpose", "Forward", "Columnwise", &i__2, &
+ i__1, &i__4, &a[j + j * a_dim1], lda, &work[lbwork * nb +
+ 1], &nt, &a[j + (*m + 1) * a_dim1], lda, &work[lbwork *
+ nb + nt * nt + 1], &i__3);
+ }
+ }
+ work[1] = (real) iws;
+ return 0;
+
+/* End of SGEQRF */
+
+} /* sgeqrf_ */
diff --git a/SRC/VARIANTS/qr/LL/zgeqrf.c b/SRC/VARIANTS/qr/LL/zgeqrf.c
new file mode 100644
index 0000000..fc99ada
--- /dev/null
+++ b/SRC/VARIANTS/qr/LL/zgeqrf.c
@@ -0,0 +1,410 @@
+/* zgeqrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int zgeqrf_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j, k, ib, nb, nt, nx, iws;
+ extern doublereal sceil_(real *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *), xerbla_(
+ char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ integer lbwork;
+ extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer llwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* March 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGEQRF computes a QR factorization of a real M-by-N matrix A: */
+/* A = Q * R. */
+
+/* This is the left-looking Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(M,N)-by-N upper trapezoidal matrix R (R is */
+/* upper triangular if m >= n); the elements below the diagonal, */
+/* with the array TAU, represent the orthogonal matrix Q as a */
+/* product of min(m,n) elementary reflectors (see Further */
+/* Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+
+/* The dimension of the array WORK. The dimension can be divided into three parts. */
+
+/* 1) The part for the triangular factor T. If the very last T is not bigger */
+/* than any of the rest, then this part is NB x ceiling(K/NB), otherwise, */
+/* NB x (K-NT), where K = min(M,N) and NT is the dimension of the very last T */
+
+/* 2) The part for the very last T when T is bigger than any of the rest T. */
+/* The size of this part is NT x NT, where NT = K - ceiling ((K-NX)/NB) x NB, */
+/* where K = min(M,N), NX is calculated by */
+/* NX = MAX( 0, ILAENV( 3, 'ZGEQRF', ' ', M, N, -1, -1 ) ) */
+
+/* 3) The part for dlarfb is of size max((N-M)*K, (N-M)*NB, K*NB, NB*NB) */
+
+/* So LWORK = part1 + part2 + part3 */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */
+/* and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nbmin = 2;
+ nx = 0;
+ iws = *n;
+ k = min(*m,*n);
+ nb = ilaenv_(&c__1, "ZGEQRF", " ", m, n, &c_n1, &c_n1);
+ if (nb > 1 && nb < k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "ZGEQRF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ }
+
+/* Get NT, the size of the very last T, which is the left-over from in-between K-NX and K to K, eg.: */
+
+/* NB=3 2NB=6 K=10 */
+/* | | | */
+/* 1--2--3--4--5--6--7--8--9--10 */
+/* | \________/ */
+/* K-NX=5 NT=4 */
+
+/* So here 4 x 4 is the last T stored in the workspace */
+
+ r__1 = (real) (k - nx) / (real) nb;
+ nt = k - sceil_(&r__1) * nb;
+
+/* optimal workspace = space for dlarfb + space for normal T's + space for the last T */
+
+/* Computing MAX */
+/* Computing MAX */
+ i__3 = (*n - *m) * k, i__4 = (*n - *m) * nb;
+/* Computing MAX */
+ i__5 = k * nb, i__6 = nb * nb;
+ i__1 = max(i__3,i__4), i__2 = max(i__5,i__6);
+ llwork = max(i__1,i__2);
+ r__1 = (real) llwork / (real) nb;
+ llwork = sceil_(&r__1);
+ if (nt > nb) {
+ lbwork = k - nt;
+
+/* Optimal workspace for dlarfb = MAX(1,N)*NT */
+
+ lwkopt = (lbwork + llwork) * nb;
+ i__1 = lwkopt + nt * nt;
+ work[1].r = (doublereal) i__1, work[1].i = 0.;
+ } else {
+ r__1 = (real) k / (real) nb;
+ lbwork = sceil_(&r__1) * nb;
+ lwkopt = (lbwork + llwork - nb) * nb;
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ }
+
+/* Test the input arguments */
+
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGEQRF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (k == 0) {
+ work[1].r = 1., work[1].i = 0.;
+ return 0;
+ }
+
+ if (nb > 1 && nb < k) {
+ if (nx < k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ if (nt <= nb) {
+ iws = (lbwork + llwork - nb) * nb;
+ } else {
+ iws = (lbwork + llwork) * nb + nt * nt;
+ }
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ if (nt <= nb) {
+ nb = *lwork / (llwork + (lbwork - nb));
+ } else {
+ nb = (*lwork - nt * nt) / (lbwork + llwork);
+ }
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "ZGEQRF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < k && nx < k) {
+
+/* Use blocked code initially */
+
+ i__1 = k - nx;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = k - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Update the current column using old T's */
+
+ i__3 = i__ - nb;
+ i__4 = nb;
+ for (j = 1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+
+/* Apply H' to A(J:M,I:I+IB-1) from the left */
+
+ i__5 = *m - j + 1;
+ zlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__5, &
+ ib, &nb, &a[j + j * a_dim1], lda, &work[j], &lbwork, &
+ a[j + i__ * a_dim1], lda, &work[lbwork * nb + nt * nt
+ + 1], &ib);
+/* L20: */
+ }
+
+/* Compute the QR factorization of the current block */
+/* A(I:M,I:I+IB-1) */
+
+ i__4 = *m - i__ + 1;
+ zgeqr2_(&i__4, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
+ lbwork * nb + nt * nt + 1], &iinfo);
+ if (i__ + ib <= *n) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__4 = *m - i__ + 1;
+ zlarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[i__], &lbwork);
+
+ }
+/* L10: */
+ }
+ } else {
+ i__ = 1;
+ }
+
+/* Use unblocked code to factor the last or only block. */
+
+ if (i__ <= k) {
+ if (i__ != 1) {
+ i__2 = i__ - nb;
+ i__1 = nb;
+ for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Apply H' to A(J:M,I:K) from the left */
+
+ i__4 = *m - j + 1;
+ i__3 = k - i__ + 1;
+ i__5 = k - i__ + 1;
+ zlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__4, &
+ i__3, &nb, &a[j + j * a_dim1], lda, &work[j], &lbwork,
+ &a[j + i__ * a_dim1], lda, &work[lbwork * nb + nt *
+ nt + 1], &i__5);
+/* L30: */
+ }
+ i__1 = *m - i__ + 1;
+ i__2 = k - i__ + 1;
+ zgeqr2_(&i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
+ work[lbwork * nb + nt * nt + 1], &iinfo);
+ } else {
+
+/* Use unblocked code to factor the last or only block. */
+
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__ + 1;
+ zgeqr2_(&i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
+ work[1], &iinfo);
+ }
+ }
+
+/* Apply update to the column M+1:N when N > M */
+
+ if (*m < *n && i__ != 1) {
+
+/* Form the last triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ if (nt <= nb) {
+ i__1 = *m - i__ + 1;
+ i__2 = k - i__ + 1;
+ zlarft_("Forward", "Columnwise", &i__1, &i__2, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[i__], &lbwork);
+ } else {
+ i__1 = *m - i__ + 1;
+ i__2 = k - i__ + 1;
+ zlarft_("Forward", "Columnwise", &i__1, &i__2, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[lbwork * nb + 1], &nt);
+ }
+
+/* Apply H' to A(1:M,M+1:N) from the left */
+
+ i__1 = k - nx;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__4 = k - j + 1;
+ ib = min(i__4,nb);
+ i__4 = *m - j + 1;
+ i__3 = *n - *m;
+ i__5 = *n - *m;
+ zlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__4, &
+ i__3, &ib, &a[j + j * a_dim1], lda, &work[j], &lbwork, &a[
+ j + (*m + 1) * a_dim1], lda, &work[lbwork * nb + nt * nt
+ + 1], &i__5);
+/* L40: */
+ }
+ if (nt <= nb) {
+ i__2 = *m - j + 1;
+ i__1 = *n - *m;
+ i__4 = k - j + 1;
+ i__3 = *n - *m;
+ zlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__2, &
+ i__1, &i__4, &a[j + j * a_dim1], lda, &work[j], &lbwork, &
+ a[j + (*m + 1) * a_dim1], lda, &work[lbwork * nb + nt *
+ nt + 1], &i__3);
+ } else {
+ i__2 = *m - j + 1;
+ i__1 = *n - *m;
+ i__4 = k - j + 1;
+ i__3 = *n - *m;
+ zlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__2, &
+ i__1, &i__4, &a[j + j * a_dim1], lda, &work[lbwork * nb +
+ 1], &nt, &a[j + (*m + 1) * a_dim1], lda, &work[lbwork *
+ nb + nt * nt + 1], &i__3);
+ }
+ }
+ work[1].r = (doublereal) iws, work[1].i = 0.;
+ return 0;
+
+/* End of ZGEQRF */
+
+} /* zgeqrf_ */
diff --git a/SRC/cbdsqr.c b/SRC/cbdsqr.c
new file mode 100644
index 0000000..97c02ec
--- /dev/null
+++ b/SRC/cbdsqr.c
@@ -0,0 +1,912 @@
+/* cbdsqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b15 = -.125;
+static integer c__1 = 1;
+static real c_b49 = 1.f;
+static real c_b72 = -1.f;
+
+/* Subroutine */ int cbdsqr_(char *uplo, integer *n, integer *ncvt, integer *
+ nru, integer *ncc, real *d__, real *e, complex *vt, integer *ldvt,
+ complex *u, integer *ldu, complex *c__, integer *ldc, real *rwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
+ i__2;
+ real r__1, r__2, r__3, r__4;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double pow_dd(doublereal *, doublereal *), sqrt(doublereal), r_sign(real *
+ , real *);
+
+ /* Local variables */
+ real f, g, h__;
+ integer i__, j, m;
+ real r__, cs;
+ integer ll;
+ real sn, mu;
+ integer nm1, nm12, nm13, lll;
+ real eps, sll, tol, abse;
+ integer idir;
+ real abss;
+ integer oldm;
+ real cosl;
+ integer isub, iter;
+ real unfl, sinl, cosr, smin, smax, sinr;
+ extern /* Subroutine */ int slas2_(real *, real *, real *, real *, real *)
+ ;
+ extern logical lsame_(char *, char *);
+ real oldcs;
+ extern /* Subroutine */ int clasr_(char *, char *, char *, integer *,
+ integer *, real *, real *, complex *, integer *);
+ integer oldll;
+ real shift, sigmn, oldsn;
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer maxit;
+ real sminl, sigmx;
+ logical lower;
+ extern /* Subroutine */ int csrot_(integer *, complex *, integer *,
+ complex *, integer *, real *, real *), slasq1_(integer *, real *,
+ real *, real *, integer *), slasv2_(real *, real *, real *, real *
+, real *, real *, real *, real *, real *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), xerbla_(char *, integer *);
+ real sminoa;
+ extern /* Subroutine */ int slartg_(real *, real *, real *, real *, real *
+);
+ real thresh;
+ logical rotate;
+ real tolmul;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CBDSQR computes the singular values and, optionally, the right and/or */
+/* left singular vectors from the singular value decomposition (SVD) of */
+/* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit */
+/* zero-shift QR algorithm. The SVD of B has the form */
+
+/* B = Q * S * P**H */
+
+/* where S is the diagonal matrix of singular values, Q is an orthogonal */
+/* matrix of left singular vectors, and P is an orthogonal matrix of */
+/* right singular vectors. If left singular vectors are requested, this */
+/* subroutine actually returns U*Q instead of Q, and, if right singular */
+/* vectors are requested, this subroutine returns P**H*VT instead of */
+/* P**H, for given complex input matrices U and VT. When U and VT are */
+/* the unitary matrices that reduce a general matrix A to bidiagonal */
+/* form: A = U*B*VT, as computed by CGEBRD, then */
+
+/* A = (U*Q) * S * (P**H*VT) */
+
+/* is the SVD of A. Optionally, the subroutine may also compute Q**H*C */
+/* for a given complex input matrix C. */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices With */
+/* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, */
+/* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, */
+/* no. 5, pp. 873-912, Sept 1990) and */
+/* "Accurate singular values and differential qd algorithms," by */
+/* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics */
+/* Department, University of California at Berkeley, July 1992 */
+/* for a detailed description of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': B is upper bidiagonal; */
+/* = 'L': B is lower bidiagonal. */
+
+/* N (input) INTEGER */
+/* The order of the matrix B. N >= 0. */
+
+/* NCVT (input) INTEGER */
+/* The number of columns of the matrix VT. NCVT >= 0. */
+
+/* NRU (input) INTEGER */
+/* The number of rows of the matrix U. NRU >= 0. */
+
+/* NCC (input) INTEGER */
+/* The number of columns of the matrix C. NCC >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the n diagonal elements of the bidiagonal matrix B. */
+/* On exit, if INFO=0, the singular values of B in decreasing */
+/* order. */
+
+/* E (input/output) REAL array, dimension (N-1) */
+/* On entry, the N-1 offdiagonal elements of the bidiagonal */
+/* matrix B. */
+/* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E */
+/* will contain the diagonal and superdiagonal elements of a */
+/* bidiagonal matrix orthogonally equivalent to the one given */
+/* as input. */
+
+/* VT (input/output) COMPLEX array, dimension (LDVT, NCVT) */
+/* On entry, an N-by-NCVT matrix VT. */
+/* On exit, VT is overwritten by P**H * VT. */
+/* Not referenced if NCVT = 0. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. */
+/* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. */
+
+/* U (input/output) COMPLEX array, dimension (LDU, N) */
+/* On entry, an NRU-by-N matrix U. */
+/* On exit, U is overwritten by U * Q. */
+/* Not referenced if NRU = 0. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,NRU). */
+
+/* C (input/output) COMPLEX array, dimension (LDC, NCC) */
+/* On entry, an N-by-NCC matrix C. */
+/* On exit, C is overwritten by Q**H * C. */
+/* Not referenced if NCC = 0. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. */
+/* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. */
+
+/* RWORK (workspace) REAL array, dimension (2*N) */
+/* if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0: the algorithm did not converge; D and E contain the */
+/* elements of a bidiagonal matrix which is orthogonally */
+/* similar to the input matrix B; if INFO = i, i */
+/* elements of E have not converged to zero. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* TOLMUL REAL, default = max(10,min(100,EPS**(-1/8))) */
+/* TOLMUL controls the convergence criterion of the QR loop. */
+/* If it is positive, TOLMUL*EPS is the desired relative */
+/* precision in the computed singular values. */
+/* If it is negative, abs(TOLMUL*EPS*sigma_max) is the */
+/* desired absolute accuracy in the computed singular */
+/* values (corresponds to relative accuracy */
+/* abs(TOLMUL*EPS) in the largest singular value. */
+/* abs(TOLMUL) should be between 1 and 1/EPS, and preferably */
+/* between 10 (for fast convergence) and .1/EPS */
+/* (for there to be some accuracy in the results). */
+/* Default is to lose at either one eighth or 2 of the */
+/* available decimal digits in each computed singular value */
+/* (whichever is smaller). */
+
+/* MAXITR INTEGER, default = 6 */
+/* MAXITR controls the maximum number of passes of the */
+/* algorithm through its inner loop. The algorithms stops */
+/* (and so fails to converge) if the number of passes */
+/* through the inner loop exceeds MAXITR*N**2. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ lower = lsame_(uplo, "L");
+ if (! lsame_(uplo, "U") && ! lower) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ncvt < 0) {
+ *info = -3;
+ } else if (*nru < 0) {
+ *info = -4;
+ } else if (*ncc < 0) {
+ *info = -5;
+ } else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1,*n)) {
+ *info = -9;
+ } else if (*ldu < max(1,*nru)) {
+ *info = -11;
+ } else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1,*n)) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CBDSQR", &i__1);
+ return 0;
+ }
+ if (*n == 0) {
+ return 0;
+ }
+ if (*n == 1) {
+ goto L160;
+ }
+
+/* ROTATE is true if any singular vectors desired, false otherwise */
+
+ rotate = *ncvt > 0 || *nru > 0 || *ncc > 0;
+
+/* If no singular vectors desired, use qd algorithm */
+
+ if (! rotate) {
+ slasq1_(n, &d__[1], &e[1], &rwork[1], info);
+ return 0;
+ }
+
+ nm1 = *n - 1;
+ nm12 = nm1 + nm1;
+ nm13 = nm12 + nm1;
+ idir = 0;
+
+/* Get machine constants */
+
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+
+/* If matrix lower bidiagonal, rotate to be upper bidiagonal */
+/* by applying Givens rotations on the left */
+
+ if (lower) {
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ slartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
+ d__[i__] = r__;
+ e[i__] = sn * d__[i__ + 1];
+ d__[i__ + 1] = cs * d__[i__ + 1];
+ rwork[i__] = cs;
+ rwork[nm1 + i__] = sn;
+/* L10: */
+ }
+
+/* Update singular vectors if desired */
+
+ if (*nru > 0) {
+ clasr_("R", "V", "F", nru, n, &rwork[1], &rwork[*n], &u[u_offset],
+ ldu);
+ }
+ if (*ncc > 0) {
+ clasr_("L", "V", "F", n, ncc, &rwork[1], &rwork[*n], &c__[
+ c_offset], ldc);
+ }
+ }
+
+/* Compute singular values to relative accuracy TOL */
+/* (By setting TOL to be negative, algorithm will compute */
+/* singular values to absolute accuracy ABS(TOL)*norm(input matrix)) */
+
+/* Computing MAX */
+/* Computing MIN */
+ d__1 = (doublereal) eps;
+ r__3 = 100.f, r__4 = pow_dd(&d__1, &c_b15);
+ r__1 = 10.f, r__2 = dmin(r__3,r__4);
+ tolmul = dmax(r__1,r__2);
+ tol = tolmul * eps;
+
+/* Compute approximate maximum, minimum singular values */
+
+ smax = 0.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = smax, r__3 = (r__1 = d__[i__], dabs(r__1));
+ smax = dmax(r__2,r__3);
+/* L20: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = smax, r__3 = (r__1 = e[i__], dabs(r__1));
+ smax = dmax(r__2,r__3);
+/* L30: */
+ }
+ sminl = 0.f;
+ if (tol >= 0.f) {
+
+/* Relative accuracy desired */
+
+ sminoa = dabs(d__[1]);
+ if (sminoa == 0.f) {
+ goto L50;
+ }
+ mu = sminoa;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ mu = (r__2 = d__[i__], dabs(r__2)) * (mu / (mu + (r__1 = e[i__ -
+ 1], dabs(r__1))));
+ sminoa = dmin(sminoa,mu);
+ if (sminoa == 0.f) {
+ goto L50;
+ }
+/* L40: */
+ }
+L50:
+ sminoa /= sqrt((real) (*n));
+/* Computing MAX */
+ r__1 = tol * sminoa, r__2 = *n * 6 * *n * unfl;
+ thresh = dmax(r__1,r__2);
+ } else {
+
+/* Absolute accuracy desired */
+
+/* Computing MAX */
+ r__1 = dabs(tol) * smax, r__2 = *n * 6 * *n * unfl;
+ thresh = dmax(r__1,r__2);
+ }
+
+/* Prepare for main iteration loop for the singular values */
+/* (MAXIT is the maximum number of passes through the inner */
+/* loop permitted before nonconvergence signalled.) */
+
+ maxit = *n * 6 * *n;
+ iter = 0;
+ oldll = -1;
+ oldm = -1;
+
+/* M points to last element of unconverged part of matrix */
+
+ m = *n;
+
+/* Begin main iteration loop */
+
+L60:
+
+/* Check for convergence or exceeding iteration count */
+
+ if (m <= 1) {
+ goto L160;
+ }
+ if (iter > maxit) {
+ goto L200;
+ }
+
+/* Find diagonal block of matrix to work on */
+
+ if (tol < 0.f && (r__1 = d__[m], dabs(r__1)) <= thresh) {
+ d__[m] = 0.f;
+ }
+ smax = (r__1 = d__[m], dabs(r__1));
+ smin = smax;
+ i__1 = m - 1;
+ for (lll = 1; lll <= i__1; ++lll) {
+ ll = m - lll;
+ abss = (r__1 = d__[ll], dabs(r__1));
+ abse = (r__1 = e[ll], dabs(r__1));
+ if (tol < 0.f && abss <= thresh) {
+ d__[ll] = 0.f;
+ }
+ if (abse <= thresh) {
+ goto L80;
+ }
+ smin = dmin(smin,abss);
+/* Computing MAX */
+ r__1 = max(smax,abss);
+ smax = dmax(r__1,abse);
+/* L70: */
+ }
+ ll = 0;
+ goto L90;
+L80:
+ e[ll] = 0.f;
+
+/* Matrix splits since E(LL) = 0 */
+
+ if (ll == m - 1) {
+
+/* Convergence of bottom singular value, return to top of loop */
+
+ --m;
+ goto L60;
+ }
+L90:
+ ++ll;
+
+/* E(LL) through E(M-1) are nonzero, E(LL-1) is zero */
+
+ if (ll == m - 1) {
+
+/* 2 by 2 block, handle separately */
+
+ slasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr,
+ &sinl, &cosl);
+ d__[m - 1] = sigmx;
+ e[m - 1] = 0.f;
+ d__[m] = sigmn;
+
+/* Compute singular vectors, if desired */
+
+ if (*ncvt > 0) {
+ csrot_(ncvt, &vt[m - 1 + vt_dim1], ldvt, &vt[m + vt_dim1], ldvt, &
+ cosr, &sinr);
+ }
+ if (*nru > 0) {
+ csrot_(nru, &u[(m - 1) * u_dim1 + 1], &c__1, &u[m * u_dim1 + 1], &
+ c__1, &cosl, &sinl);
+ }
+ if (*ncc > 0) {
+ csrot_(ncc, &c__[m - 1 + c_dim1], ldc, &c__[m + c_dim1], ldc, &
+ cosl, &sinl);
+ }
+ m += -2;
+ goto L60;
+ }
+
+/* If working on new submatrix, choose shift direction */
+/* (from larger end diagonal element towards smaller) */
+
+ if (ll > oldm || m < oldll) {
+ if ((r__1 = d__[ll], dabs(r__1)) >= (r__2 = d__[m], dabs(r__2))) {
+
+/* Chase bulge from top (big end) to bottom (small end) */
+
+ idir = 1;
+ } else {
+
+/* Chase bulge from bottom (big end) to top (small end) */
+
+ idir = 2;
+ }
+ }
+
+/* Apply convergence tests */
+
+ if (idir == 1) {
+
+/* Run convergence test in forward direction */
+/* First apply standard test to bottom of matrix */
+
+ if ((r__2 = e[m - 1], dabs(r__2)) <= dabs(tol) * (r__1 = d__[m], dabs(
+ r__1)) || tol < 0.f && (r__3 = e[m - 1], dabs(r__3)) <=
+ thresh) {
+ e[m - 1] = 0.f;
+ goto L60;
+ }
+
+ if (tol >= 0.f) {
+
+/* If relative accuracy desired, */
+/* apply convergence criterion forward */
+
+ mu = (r__1 = d__[ll], dabs(r__1));
+ sminl = mu;
+ i__1 = m - 1;
+ for (lll = ll; lll <= i__1; ++lll) {
+ if ((r__1 = e[lll], dabs(r__1)) <= tol * mu) {
+ e[lll] = 0.f;
+ goto L60;
+ }
+ mu = (r__2 = d__[lll + 1], dabs(r__2)) * (mu / (mu + (r__1 =
+ e[lll], dabs(r__1))));
+ sminl = dmin(sminl,mu);
+/* L100: */
+ }
+ }
+
+ } else {
+
+/* Run convergence test in backward direction */
+/* First apply standard test to top of matrix */
+
+ if ((r__2 = e[ll], dabs(r__2)) <= dabs(tol) * (r__1 = d__[ll], dabs(
+ r__1)) || tol < 0.f && (r__3 = e[ll], dabs(r__3)) <= thresh) {
+ e[ll] = 0.f;
+ goto L60;
+ }
+
+ if (tol >= 0.f) {
+
+/* If relative accuracy desired, */
+/* apply convergence criterion backward */
+
+ mu = (r__1 = d__[m], dabs(r__1));
+ sminl = mu;
+ i__1 = ll;
+ for (lll = m - 1; lll >= i__1; --lll) {
+ if ((r__1 = e[lll], dabs(r__1)) <= tol * mu) {
+ e[lll] = 0.f;
+ goto L60;
+ }
+ mu = (r__2 = d__[lll], dabs(r__2)) * (mu / (mu + (r__1 = e[
+ lll], dabs(r__1))));
+ sminl = dmin(sminl,mu);
+/* L110: */
+ }
+ }
+ }
+ oldll = ll;
+ oldm = m;
+
+/* Compute shift. First, test if shifting would ruin relative */
+/* accuracy, and if so set the shift to zero. */
+
+/* Computing MAX */
+ r__1 = eps, r__2 = tol * .01f;
+ if (tol >= 0.f && *n * tol * (sminl / smax) <= dmax(r__1,r__2)) {
+
+/* Use a zero shift to avoid loss of relative accuracy */
+
+ shift = 0.f;
+ } else {
+
+/* Compute the shift from 2-by-2 block at end of matrix */
+
+ if (idir == 1) {
+ sll = (r__1 = d__[ll], dabs(r__1));
+ slas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__);
+ } else {
+ sll = (r__1 = d__[m], dabs(r__1));
+ slas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__);
+ }
+
+/* Test if shift negligible, and if so set to zero */
+
+ if (sll > 0.f) {
+/* Computing 2nd power */
+ r__1 = shift / sll;
+ if (r__1 * r__1 < eps) {
+ shift = 0.f;
+ }
+ }
+ }
+
+/* Increment iteration count */
+
+ iter = iter + m - ll;
+
+/* If SHIFT = 0, do simplified QR iteration */
+
+ if (shift == 0.f) {
+ if (idir == 1) {
+
+/* Chase bulge from top to bottom */
+/* Save cosines and sines for later singular vector updates */
+
+ cs = 1.f;
+ oldcs = 1.f;
+ i__1 = m - 1;
+ for (i__ = ll; i__ <= i__1; ++i__) {
+ r__1 = d__[i__] * cs;
+ slartg_(&r__1, &e[i__], &cs, &sn, &r__);
+ if (i__ > ll) {
+ e[i__ - 1] = oldsn * r__;
+ }
+ r__1 = oldcs * r__;
+ r__2 = d__[i__ + 1] * sn;
+ slartg_(&r__1, &r__2, &oldcs, &oldsn, &d__[i__]);
+ rwork[i__ - ll + 1] = cs;
+ rwork[i__ - ll + 1 + nm1] = sn;
+ rwork[i__ - ll + 1 + nm12] = oldcs;
+ rwork[i__ - ll + 1 + nm13] = oldsn;
+/* L120: */
+ }
+ h__ = d__[m] * cs;
+ d__[m] = h__ * oldcs;
+ e[m - 1] = h__ * oldsn;
+
+/* Update singular vectors */
+
+ if (*ncvt > 0) {
+ i__1 = m - ll + 1;
+ clasr_("L", "V", "F", &i__1, ncvt, &rwork[1], &rwork[*n], &vt[
+ ll + vt_dim1], ldvt);
+ }
+ if (*nru > 0) {
+ i__1 = m - ll + 1;
+ clasr_("R", "V", "F", nru, &i__1, &rwork[nm12 + 1], &rwork[
+ nm13 + 1], &u[ll * u_dim1 + 1], ldu);
+ }
+ if (*ncc > 0) {
+ i__1 = m - ll + 1;
+ clasr_("L", "V", "F", &i__1, ncc, &rwork[nm12 + 1], &rwork[
+ nm13 + 1], &c__[ll + c_dim1], ldc);
+ }
+
+/* Test convergence */
+
+ if ((r__1 = e[m - 1], dabs(r__1)) <= thresh) {
+ e[m - 1] = 0.f;
+ }
+
+ } else {
+
+/* Chase bulge from bottom to top */
+/* Save cosines and sines for later singular vector updates */
+
+ cs = 1.f;
+ oldcs = 1.f;
+ i__1 = ll + 1;
+ for (i__ = m; i__ >= i__1; --i__) {
+ r__1 = d__[i__] * cs;
+ slartg_(&r__1, &e[i__ - 1], &cs, &sn, &r__);
+ if (i__ < m) {
+ e[i__] = oldsn * r__;
+ }
+ r__1 = oldcs * r__;
+ r__2 = d__[i__ - 1] * sn;
+ slartg_(&r__1, &r__2, &oldcs, &oldsn, &d__[i__]);
+ rwork[i__ - ll] = cs;
+ rwork[i__ - ll + nm1] = -sn;
+ rwork[i__ - ll + nm12] = oldcs;
+ rwork[i__ - ll + nm13] = -oldsn;
+/* L130: */
+ }
+ h__ = d__[ll] * cs;
+ d__[ll] = h__ * oldcs;
+ e[ll] = h__ * oldsn;
+
+/* Update singular vectors */
+
+ if (*ncvt > 0) {
+ i__1 = m - ll + 1;
+ clasr_("L", "V", "B", &i__1, ncvt, &rwork[nm12 + 1], &rwork[
+ nm13 + 1], &vt[ll + vt_dim1], ldvt);
+ }
+ if (*nru > 0) {
+ i__1 = m - ll + 1;
+ clasr_("R", "V", "B", nru, &i__1, &rwork[1], &rwork[*n], &u[
+ ll * u_dim1 + 1], ldu);
+ }
+ if (*ncc > 0) {
+ i__1 = m - ll + 1;
+ clasr_("L", "V", "B", &i__1, ncc, &rwork[1], &rwork[*n], &c__[
+ ll + c_dim1], ldc);
+ }
+
+/* Test convergence */
+
+ if ((r__1 = e[ll], dabs(r__1)) <= thresh) {
+ e[ll] = 0.f;
+ }
+ }
+ } else {
+
+/* Use nonzero shift */
+
+ if (idir == 1) {
+
+/* Chase bulge from top to bottom */
+/* Save cosines and sines for later singular vector updates */
+
+ f = ((r__1 = d__[ll], dabs(r__1)) - shift) * (r_sign(&c_b49, &d__[
+ ll]) + shift / d__[ll]);
+ g = e[ll];
+ i__1 = m - 1;
+ for (i__ = ll; i__ <= i__1; ++i__) {
+ slartg_(&f, &g, &cosr, &sinr, &r__);
+ if (i__ > ll) {
+ e[i__ - 1] = r__;
+ }
+ f = cosr * d__[i__] + sinr * e[i__];
+ e[i__] = cosr * e[i__] - sinr * d__[i__];
+ g = sinr * d__[i__ + 1];
+ d__[i__ + 1] = cosr * d__[i__ + 1];
+ slartg_(&f, &g, &cosl, &sinl, &r__);
+ d__[i__] = r__;
+ f = cosl * e[i__] + sinl * d__[i__ + 1];
+ d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__];
+ if (i__ < m - 1) {
+ g = sinl * e[i__ + 1];
+ e[i__ + 1] = cosl * e[i__ + 1];
+ }
+ rwork[i__ - ll + 1] = cosr;
+ rwork[i__ - ll + 1 + nm1] = sinr;
+ rwork[i__ - ll + 1 + nm12] = cosl;
+ rwork[i__ - ll + 1 + nm13] = sinl;
+/* L140: */
+ }
+ e[m - 1] = f;
+
+/* Update singular vectors */
+
+ if (*ncvt > 0) {
+ i__1 = m - ll + 1;
+ clasr_("L", "V", "F", &i__1, ncvt, &rwork[1], &rwork[*n], &vt[
+ ll + vt_dim1], ldvt);
+ }
+ if (*nru > 0) {
+ i__1 = m - ll + 1;
+ clasr_("R", "V", "F", nru, &i__1, &rwork[nm12 + 1], &rwork[
+ nm13 + 1], &u[ll * u_dim1 + 1], ldu);
+ }
+ if (*ncc > 0) {
+ i__1 = m - ll + 1;
+ clasr_("L", "V", "F", &i__1, ncc, &rwork[nm12 + 1], &rwork[
+ nm13 + 1], &c__[ll + c_dim1], ldc);
+ }
+
+/* Test convergence */
+
+ if ((r__1 = e[m - 1], dabs(r__1)) <= thresh) {
+ e[m - 1] = 0.f;
+ }
+
+ } else {
+
+/* Chase bulge from bottom to top */
+/* Save cosines and sines for later singular vector updates */
+
+ f = ((r__1 = d__[m], dabs(r__1)) - shift) * (r_sign(&c_b49, &d__[
+ m]) + shift / d__[m]);
+ g = e[m - 1];
+ i__1 = ll + 1;
+ for (i__ = m; i__ >= i__1; --i__) {
+ slartg_(&f, &g, &cosr, &sinr, &r__);
+ if (i__ < m) {
+ e[i__] = r__;
+ }
+ f = cosr * d__[i__] + sinr * e[i__ - 1];
+ e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__];
+ g = sinr * d__[i__ - 1];
+ d__[i__ - 1] = cosr * d__[i__ - 1];
+ slartg_(&f, &g, &cosl, &sinl, &r__);
+ d__[i__] = r__;
+ f = cosl * e[i__ - 1] + sinl * d__[i__ - 1];
+ d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1];
+ if (i__ > ll + 1) {
+ g = sinl * e[i__ - 2];
+ e[i__ - 2] = cosl * e[i__ - 2];
+ }
+ rwork[i__ - ll] = cosr;
+ rwork[i__ - ll + nm1] = -sinr;
+ rwork[i__ - ll + nm12] = cosl;
+ rwork[i__ - ll + nm13] = -sinl;
+/* L150: */
+ }
+ e[ll] = f;
+
+/* Test convergence */
+
+ if ((r__1 = e[ll], dabs(r__1)) <= thresh) {
+ e[ll] = 0.f;
+ }
+
+/* Update singular vectors if desired */
+
+ if (*ncvt > 0) {
+ i__1 = m - ll + 1;
+ clasr_("L", "V", "B", &i__1, ncvt, &rwork[nm12 + 1], &rwork[
+ nm13 + 1], &vt[ll + vt_dim1], ldvt);
+ }
+ if (*nru > 0) {
+ i__1 = m - ll + 1;
+ clasr_("R", "V", "B", nru, &i__1, &rwork[1], &rwork[*n], &u[
+ ll * u_dim1 + 1], ldu);
+ }
+ if (*ncc > 0) {
+ i__1 = m - ll + 1;
+ clasr_("L", "V", "B", &i__1, ncc, &rwork[1], &rwork[*n], &c__[
+ ll + c_dim1], ldc);
+ }
+ }
+ }
+
+/* QR iteration finished, go back and check convergence */
+
+ goto L60;
+
+/* All singular values converged, so make them positive */
+
+L160:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (d__[i__] < 0.f) {
+ d__[i__] = -d__[i__];
+
+/* Change sign of singular vectors, if desired */
+
+ if (*ncvt > 0) {
+ csscal_(ncvt, &c_b72, &vt[i__ + vt_dim1], ldvt);
+ }
+ }
+/* L170: */
+ }
+
+/* Sort the singular values into decreasing order (insertion sort on */
+/* singular values, but only one transposition per singular vector) */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Scan for smallest D(I) */
+
+ isub = 1;
+ smin = d__[1];
+ i__2 = *n + 1 - i__;
+ for (j = 2; j <= i__2; ++j) {
+ if (d__[j] <= smin) {
+ isub = j;
+ smin = d__[j];
+ }
+/* L180: */
+ }
+ if (isub != *n + 1 - i__) {
+
+/* Swap singular values and vectors */
+
+ d__[isub] = d__[*n + 1 - i__];
+ d__[*n + 1 - i__] = smin;
+ if (*ncvt > 0) {
+ cswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[*n + 1 - i__ +
+ vt_dim1], ldvt);
+ }
+ if (*nru > 0) {
+ cswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[(*n + 1 - i__) *
+ u_dim1 + 1], &c__1);
+ }
+ if (*ncc > 0) {
+ cswap_(ncc, &c__[isub + c_dim1], ldc, &c__[*n + 1 - i__ +
+ c_dim1], ldc);
+ }
+ }
+/* L190: */
+ }
+ goto L220;
+
+/* Maximum number of iterations exceeded, failure to converge */
+
+L200:
+ *info = 0;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (e[i__] != 0.f) {
+ ++(*info);
+ }
+/* L210: */
+ }
+L220:
+ return 0;
+
+/* End of CBDSQR */
+
+} /* cbdsqr_ */
diff --git a/SRC/cgbbrd.c b/SRC/cgbbrd.c
new file mode 100644
index 0000000..113b54a
--- /dev/null
+++ b/SRC/cgbbrd.c
@@ -0,0 +1,649 @@
+/* cgbbrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cgbbrd_(char *vect, integer *m, integer *n, integer *ncc,
+ integer *kl, integer *ku, complex *ab, integer *ldab, real *d__,
+ real *e, complex *q, integer *ldq, complex *pt, integer *ldpt,
+ complex *c__, integer *ldc, complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, c_dim1, c_offset, pt_dim1, pt_offset, q_dim1,
+ q_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+ double c_abs(complex *);
+
+ /* Local variables */
+ integer i__, j, l;
+ complex t;
+ integer j1, j2, kb;
+ complex ra, rb;
+ real rc;
+ integer kk, ml, nr, mu;
+ complex rs;
+ integer kb1, ml0, mu0, klm, kun, nrt, klu1, inca;
+ real abst;
+ extern /* Subroutine */ int crot_(integer *, complex *, integer *,
+ complex *, integer *, real *, complex *), cscal_(integer *,
+ complex *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ logical wantb, wantc;
+ integer minmn;
+ logical wantq;
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), clartg_(complex *,
+ complex *, real *, complex *, complex *), xerbla_(char *, integer
+ *), clargv_(integer *, complex *, integer *, complex *,
+ integer *, real *, integer *), clartv_(integer *, complex *,
+ integer *, complex *, integer *, real *, complex *, integer *);
+ logical wantpt;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGBBRD reduces a complex general m-by-n band matrix A to real upper */
+/* bidiagonal form B by a unitary transformation: Q' * A * P = B. */
+
+/* The routine computes B, and optionally forms Q or P', or computes */
+/* Q'*C for a given matrix C. */
+
+/* Arguments */
+/* ========= */
+
+/* VECT (input) CHARACTER*1 */
+/* Specifies whether or not the matrices Q and P' are to be */
+/* formed. */
+/* = 'N': do not form Q or P'; */
+/* = 'Q': form Q only; */
+/* = 'P': form P' only; */
+/* = 'B': form both. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NCC (input) INTEGER */
+/* The number of columns of the matrix C. NCC >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals of the matrix A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals of the matrix A. KU >= 0. */
+
+/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
+/* On entry, the m-by-n band matrix A, stored in rows 1 to */
+/* KL+KU+1. The j-th column of A is stored in the j-th column of */
+/* the array AB as follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). */
+/* On exit, A is overwritten by values generated during the */
+/* reduction. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array A. LDAB >= KL+KU+1. */
+
+/* D (output) REAL array, dimension (min(M,N)) */
+/* The diagonal elements of the bidiagonal matrix B. */
+
+/* E (output) REAL array, dimension (min(M,N)-1) */
+/* The superdiagonal elements of the bidiagonal matrix B. */
+
+/* Q (output) COMPLEX array, dimension (LDQ,M) */
+/* If VECT = 'Q' or 'B', the m-by-m unitary matrix Q. */
+/* If VECT = 'N' or 'P', the array Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. */
+/* LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise. */
+
+/* PT (output) COMPLEX array, dimension (LDPT,N) */
+/* If VECT = 'P' or 'B', the n-by-n unitary matrix P'. */
+/* If VECT = 'N' or 'Q', the array PT is not referenced. */
+
+/* LDPT (input) INTEGER */
+/* The leading dimension of the array PT. */
+/* LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise. */
+
+/* C (input/output) COMPLEX array, dimension (LDC,NCC) */
+/* On entry, an m-by-ncc matrix C. */
+/* On exit, C is overwritten by Q'*C. */
+/* C is not referenced if NCC = 0. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. */
+/* LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0. */
+
+/* WORK (workspace) COMPLEX array, dimension (max(M,N)) */
+
+/* RWORK (workspace) REAL array, dimension (max(M,N)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --d__;
+ --e;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ pt_dim1 = *ldpt;
+ pt_offset = 1 + pt_dim1;
+ pt -= pt_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ wantb = lsame_(vect, "B");
+ wantq = lsame_(vect, "Q") || wantb;
+ wantpt = lsame_(vect, "P") || wantb;
+ wantc = *ncc > 0;
+ klu1 = *kl + *ku + 1;
+ *info = 0;
+ if (! wantq && ! wantpt && ! lsame_(vect, "N")) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ncc < 0) {
+ *info = -4;
+ } else if (*kl < 0) {
+ *info = -5;
+ } else if (*ku < 0) {
+ *info = -6;
+ } else if (*ldab < klu1) {
+ *info = -8;
+ } else if (*ldq < 1 || wantq && *ldq < max(1,*m)) {
+ *info = -12;
+ } else if (*ldpt < 1 || wantpt && *ldpt < max(1,*n)) {
+ *info = -14;
+ } else if (*ldc < 1 || wantc && *ldc < max(1,*m)) {
+ *info = -16;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGBBRD", &i__1);
+ return 0;
+ }
+
+/* Initialize Q and P' to the unit matrix, if needed */
+
+ if (wantq) {
+ claset_("Full", m, m, &c_b1, &c_b2, &q[q_offset], ldq);
+ }
+ if (wantpt) {
+ claset_("Full", n, n, &c_b1, &c_b2, &pt[pt_offset], ldpt);
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ minmn = min(*m,*n);
+
+ if (*kl + *ku > 1) {
+
+/* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce */
+/* first to lower bidiagonal form and then transform to upper */
+/* bidiagonal */
+
+ if (*ku > 0) {
+ ml0 = 1;
+ mu0 = 2;
+ } else {
+ ml0 = 2;
+ mu0 = 1;
+ }
+
+/* Wherever possible, plane rotations are generated and applied in */
+/* vector operations of length NR over the index set J1:J2:KLU1. */
+
+/* The complex sines of the plane rotations are stored in WORK, */
+/* and the real cosines in RWORK. */
+
+/* Computing MIN */
+ i__1 = *m - 1;
+ klm = min(i__1,*kl);
+/* Computing MIN */
+ i__1 = *n - 1;
+ kun = min(i__1,*ku);
+ kb = klm + kun;
+ kb1 = kb + 1;
+ inca = kb1 * *ldab;
+ nr = 0;
+ j1 = klm + 2;
+ j2 = 1 - kun;
+
+ i__1 = minmn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Reduce i-th column and i-th row of matrix to bidiagonal form */
+
+ ml = klm + 1;
+ mu = kun + 1;
+ i__2 = kb;
+ for (kk = 1; kk <= i__2; ++kk) {
+ j1 += kb;
+ j2 += kb;
+
+/* generate plane rotations to annihilate nonzero elements */
+/* which have been created below the band */
+
+ if (nr > 0) {
+ clargv_(&nr, &ab[klu1 + (j1 - klm - 1) * ab_dim1], &inca,
+ &work[j1], &kb1, &rwork[j1], &kb1);
+ }
+
+/* apply plane rotations from the left */
+
+ i__3 = kb;
+ for (l = 1; l <= i__3; ++l) {
+ if (j2 - klm + l - 1 > *n) {
+ nrt = nr - 1;
+ } else {
+ nrt = nr;
+ }
+ if (nrt > 0) {
+ clartv_(&nrt, &ab[klu1 - l + (j1 - klm + l - 1) *
+ ab_dim1], &inca, &ab[klu1 - l + 1 + (j1 - klm
+ + l - 1) * ab_dim1], &inca, &rwork[j1], &work[
+ j1], &kb1);
+ }
+/* L10: */
+ }
+
+ if (ml > ml0) {
+ if (ml <= *m - i__ + 1) {
+
+/* generate plane rotation to annihilate a(i+ml-1,i) */
+/* within the band, and apply rotation from the left */
+
+ clartg_(&ab[*ku + ml - 1 + i__ * ab_dim1], &ab[*ku +
+ ml + i__ * ab_dim1], &rwork[i__ + ml - 1], &
+ work[i__ + ml - 1], &ra);
+ i__3 = *ku + ml - 1 + i__ * ab_dim1;
+ ab[i__3].r = ra.r, ab[i__3].i = ra.i;
+ if (i__ < *n) {
+/* Computing MIN */
+ i__4 = *ku + ml - 2, i__5 = *n - i__;
+ i__3 = min(i__4,i__5);
+ i__6 = *ldab - 1;
+ i__7 = *ldab - 1;
+ crot_(&i__3, &ab[*ku + ml - 2 + (i__ + 1) *
+ ab_dim1], &i__6, &ab[*ku + ml - 1 + (i__
+ + 1) * ab_dim1], &i__7, &rwork[i__ + ml -
+ 1], &work[i__ + ml - 1]);
+ }
+ }
+ ++nr;
+ j1 -= kb1;
+ }
+
+ if (wantq) {
+
+/* accumulate product of plane rotations in Q */
+
+ i__3 = j2;
+ i__4 = kb1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4)
+ {
+ r_cnjg(&q__1, &work[j]);
+ crot_(m, &q[(j - 1) * q_dim1 + 1], &c__1, &q[j *
+ q_dim1 + 1], &c__1, &rwork[j], &q__1);
+/* L20: */
+ }
+ }
+
+ if (wantc) {
+
+/* apply plane rotations to C */
+
+ i__4 = j2;
+ i__3 = kb1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3)
+ {
+ crot_(ncc, &c__[j - 1 + c_dim1], ldc, &c__[j + c_dim1]
+, ldc, &rwork[j], &work[j]);
+/* L30: */
+ }
+ }
+
+ if (j2 + kun > *n) {
+
+/* adjust J2 to keep within the bounds of the matrix */
+
+ --nr;
+ j2 -= kb1;
+ }
+
+ i__3 = j2;
+ i__4 = kb1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+
+/* create nonzero element a(j-1,j+ku) above the band */
+/* and store it in WORK(n+1:2*n) */
+
+ i__5 = j + kun;
+ i__6 = j;
+ i__7 = (j + kun) * ab_dim1 + 1;
+ q__1.r = work[i__6].r * ab[i__7].r - work[i__6].i * ab[
+ i__7].i, q__1.i = work[i__6].r * ab[i__7].i +
+ work[i__6].i * ab[i__7].r;
+ work[i__5].r = q__1.r, work[i__5].i = q__1.i;
+ i__5 = (j + kun) * ab_dim1 + 1;
+ i__6 = j;
+ i__7 = (j + kun) * ab_dim1 + 1;
+ q__1.r = rwork[i__6] * ab[i__7].r, q__1.i = rwork[i__6] *
+ ab[i__7].i;
+ ab[i__5].r = q__1.r, ab[i__5].i = q__1.i;
+/* L40: */
+ }
+
+/* generate plane rotations to annihilate nonzero elements */
+/* which have been generated above the band */
+
+ if (nr > 0) {
+ clargv_(&nr, &ab[(j1 + kun - 1) * ab_dim1 + 1], &inca, &
+ work[j1 + kun], &kb1, &rwork[j1 + kun], &kb1);
+ }
+
+/* apply plane rotations from the right */
+
+ i__4 = kb;
+ for (l = 1; l <= i__4; ++l) {
+ if (j2 + l - 1 > *m) {
+ nrt = nr - 1;
+ } else {
+ nrt = nr;
+ }
+ if (nrt > 0) {
+ clartv_(&nrt, &ab[l + 1 + (j1 + kun - 1) * ab_dim1], &
+ inca, &ab[l + (j1 + kun) * ab_dim1], &inca, &
+ rwork[j1 + kun], &work[j1 + kun], &kb1);
+ }
+/* L50: */
+ }
+
+ if (ml == ml0 && mu > mu0) {
+ if (mu <= *n - i__ + 1) {
+
+/* generate plane rotation to annihilate a(i,i+mu-1) */
+/* within the band, and apply rotation from the right */
+
+ clartg_(&ab[*ku - mu + 3 + (i__ + mu - 2) * ab_dim1],
+ &ab[*ku - mu + 2 + (i__ + mu - 1) * ab_dim1],
+ &rwork[i__ + mu - 1], &work[i__ + mu - 1], &
+ ra);
+ i__4 = *ku - mu + 3 + (i__ + mu - 2) * ab_dim1;
+ ab[i__4].r = ra.r, ab[i__4].i = ra.i;
+/* Computing MIN */
+ i__3 = *kl + mu - 2, i__5 = *m - i__;
+ i__4 = min(i__3,i__5);
+ crot_(&i__4, &ab[*ku - mu + 4 + (i__ + mu - 2) *
+ ab_dim1], &c__1, &ab[*ku - mu + 3 + (i__ + mu
+ - 1) * ab_dim1], &c__1, &rwork[i__ + mu - 1],
+ &work[i__ + mu - 1]);
+ }
+ ++nr;
+ j1 -= kb1;
+ }
+
+ if (wantpt) {
+
+/* accumulate product of plane rotations in P' */
+
+ i__4 = j2;
+ i__3 = kb1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3)
+ {
+ r_cnjg(&q__1, &work[j + kun]);
+ crot_(n, &pt[j + kun - 1 + pt_dim1], ldpt, &pt[j +
+ kun + pt_dim1], ldpt, &rwork[j + kun], &q__1);
+/* L60: */
+ }
+ }
+
+ if (j2 + kb > *m) {
+
+/* adjust J2 to keep within the bounds of the matrix */
+
+ --nr;
+ j2 -= kb1;
+ }
+
+ i__3 = j2;
+ i__4 = kb1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+
+/* create nonzero element a(j+kl+ku,j+ku-1) below the */
+/* band and store it in WORK(1:n) */
+
+ i__5 = j + kb;
+ i__6 = j + kun;
+ i__7 = klu1 + (j + kun) * ab_dim1;
+ q__1.r = work[i__6].r * ab[i__7].r - work[i__6].i * ab[
+ i__7].i, q__1.i = work[i__6].r * ab[i__7].i +
+ work[i__6].i * ab[i__7].r;
+ work[i__5].r = q__1.r, work[i__5].i = q__1.i;
+ i__5 = klu1 + (j + kun) * ab_dim1;
+ i__6 = j + kun;
+ i__7 = klu1 + (j + kun) * ab_dim1;
+ q__1.r = rwork[i__6] * ab[i__7].r, q__1.i = rwork[i__6] *
+ ab[i__7].i;
+ ab[i__5].r = q__1.r, ab[i__5].i = q__1.i;
+/* L70: */
+ }
+
+ if (ml > ml0) {
+ --ml;
+ } else {
+ --mu;
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+
+ if (*ku == 0 && *kl > 0) {
+
+/* A has been reduced to complex lower bidiagonal form */
+
+/* Transform lower bidiagonal form to upper bidiagonal by applying */
+/* plane rotations from the left, overwriting superdiagonal */
+/* elements on subdiagonal elements */
+
+/* Computing MIN */
+ i__2 = *m - 1;
+ i__1 = min(i__2,*n);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ clartg_(&ab[i__ * ab_dim1 + 1], &ab[i__ * ab_dim1 + 2], &rc, &rs,
+ &ra);
+ i__2 = i__ * ab_dim1 + 1;
+ ab[i__2].r = ra.r, ab[i__2].i = ra.i;
+ if (i__ < *n) {
+ i__2 = i__ * ab_dim1 + 2;
+ i__4 = (i__ + 1) * ab_dim1 + 1;
+ q__1.r = rs.r * ab[i__4].r - rs.i * ab[i__4].i, q__1.i = rs.r
+ * ab[i__4].i + rs.i * ab[i__4].r;
+ ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
+ i__2 = (i__ + 1) * ab_dim1 + 1;
+ i__4 = (i__ + 1) * ab_dim1 + 1;
+ q__1.r = rc * ab[i__4].r, q__1.i = rc * ab[i__4].i;
+ ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
+ }
+ if (wantq) {
+ r_cnjg(&q__1, &rs);
+ crot_(m, &q[i__ * q_dim1 + 1], &c__1, &q[(i__ + 1) * q_dim1 +
+ 1], &c__1, &rc, &q__1);
+ }
+ if (wantc) {
+ crot_(ncc, &c__[i__ + c_dim1], ldc, &c__[i__ + 1 + c_dim1],
+ ldc, &rc, &rs);
+ }
+/* L100: */
+ }
+ } else {
+
+/* A has been reduced to complex upper bidiagonal form or is */
+/* diagonal */
+
+ if (*ku > 0 && *m < *n) {
+
+/* Annihilate a(m,m+1) by applying plane rotations from the */
+/* right */
+
+ i__1 = *ku + (*m + 1) * ab_dim1;
+ rb.r = ab[i__1].r, rb.i = ab[i__1].i;
+ for (i__ = *m; i__ >= 1; --i__) {
+ clartg_(&ab[*ku + 1 + i__ * ab_dim1], &rb, &rc, &rs, &ra);
+ i__1 = *ku + 1 + i__ * ab_dim1;
+ ab[i__1].r = ra.r, ab[i__1].i = ra.i;
+ if (i__ > 1) {
+ r_cnjg(&q__3, &rs);
+ q__2.r = -q__3.r, q__2.i = -q__3.i;
+ i__1 = *ku + i__ * ab_dim1;
+ q__1.r = q__2.r * ab[i__1].r - q__2.i * ab[i__1].i,
+ q__1.i = q__2.r * ab[i__1].i + q__2.i * ab[i__1]
+ .r;
+ rb.r = q__1.r, rb.i = q__1.i;
+ i__1 = *ku + i__ * ab_dim1;
+ i__2 = *ku + i__ * ab_dim1;
+ q__1.r = rc * ab[i__2].r, q__1.i = rc * ab[i__2].i;
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+ }
+ if (wantpt) {
+ r_cnjg(&q__1, &rs);
+ crot_(n, &pt[i__ + pt_dim1], ldpt, &pt[*m + 1 + pt_dim1],
+ ldpt, &rc, &q__1);
+ }
+/* L110: */
+ }
+ }
+ }
+
+/* Make diagonal and superdiagonal elements real, storing them in D */
+/* and E */
+
+ i__1 = *ku + 1 + ab_dim1;
+ t.r = ab[i__1].r, t.i = ab[i__1].i;
+ i__1 = minmn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ abst = c_abs(&t);
+ d__[i__] = abst;
+ if (abst != 0.f) {
+ q__1.r = t.r / abst, q__1.i = t.i / abst;
+ t.r = q__1.r, t.i = q__1.i;
+ } else {
+ t.r = 1.f, t.i = 0.f;
+ }
+ if (wantq) {
+ cscal_(m, &t, &q[i__ * q_dim1 + 1], &c__1);
+ }
+ if (wantc) {
+ r_cnjg(&q__1, &t);
+ cscal_(ncc, &q__1, &c__[i__ + c_dim1], ldc);
+ }
+ if (i__ < minmn) {
+ if (*ku == 0 && *kl == 0) {
+ e[i__] = 0.f;
+ i__2 = (i__ + 1) * ab_dim1 + 1;
+ t.r = ab[i__2].r, t.i = ab[i__2].i;
+ } else {
+ if (*ku == 0) {
+ i__2 = i__ * ab_dim1 + 2;
+ r_cnjg(&q__2, &t);
+ q__1.r = ab[i__2].r * q__2.r - ab[i__2].i * q__2.i,
+ q__1.i = ab[i__2].r * q__2.i + ab[i__2].i *
+ q__2.r;
+ t.r = q__1.r, t.i = q__1.i;
+ } else {
+ i__2 = *ku + (i__ + 1) * ab_dim1;
+ r_cnjg(&q__2, &t);
+ q__1.r = ab[i__2].r * q__2.r - ab[i__2].i * q__2.i,
+ q__1.i = ab[i__2].r * q__2.i + ab[i__2].i *
+ q__2.r;
+ t.r = q__1.r, t.i = q__1.i;
+ }
+ abst = c_abs(&t);
+ e[i__] = abst;
+ if (abst != 0.f) {
+ q__1.r = t.r / abst, q__1.i = t.i / abst;
+ t.r = q__1.r, t.i = q__1.i;
+ } else {
+ t.r = 1.f, t.i = 0.f;
+ }
+ if (wantpt) {
+ cscal_(n, &t, &pt[i__ + 1 + pt_dim1], ldpt);
+ }
+ i__2 = *ku + 1 + (i__ + 1) * ab_dim1;
+ r_cnjg(&q__2, &t);
+ q__1.r = ab[i__2].r * q__2.r - ab[i__2].i * q__2.i, q__1.i =
+ ab[i__2].r * q__2.i + ab[i__2].i * q__2.r;
+ t.r = q__1.r, t.i = q__1.i;
+ }
+ }
+/* L120: */
+ }
+ return 0;
+
+/* End of CGBBRD */
+
+} /* cgbbrd_ */
diff --git a/SRC/cgbcon.c b/SRC/cgbcon.c
new file mode 100644
index 0000000..3e75842
--- /dev/null
+++ b/SRC/cgbcon.c
@@ -0,0 +1,307 @@
+/* cgbcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cgbcon_(char *norm, integer *n, integer *kl, integer *ku,
+ complex *ab, integer *ldab, integer *ipiv, real *anorm, real *rcond,
+ complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3;
+ real r__1, r__2;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer j;
+ complex t;
+ integer kd, lm, jp, ix, kase, kase1;
+ real scale;
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ logical lnoti;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *);
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clatbs_(char *, char *, char *, char *,
+ integer *, integer *, complex *, integer *, complex *, real *,
+ real *, integer *), xerbla_(char *
+, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int csrscl_(integer *, real *, complex *, integer
+ *);
+ logical onenrm;
+ char normin[1];
+ real smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGBCON estimates the reciprocal of the condition number of a complex */
+/* general band matrix A, in either the 1-norm or the infinity-norm, */
+/* using the LU factorization computed by CGBTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as */
+/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by CGBTRF. U is stored as an upper triangular band */
+/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
+/* the multipliers used during the factorization are stored in */
+/* rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= N, row i of the matrix was */
+/* interchanged with row IPIV(i). */
+
+/* ANORM (input) REAL */
+/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */
+/* If NORM = 'I', the infinity-norm of the original matrix A. */
+
+/* RCOND (output) REAL */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --ipiv;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*ldab < (*kl << 1) + *ku + 1) {
+ *info = -6;
+ } else if (*anorm < 0.f) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGBCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.f;
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ } else if (*anorm == 0.f) {
+ return 0;
+ }
+
+ smlnum = slamch_("Safe minimum");
+
+/* Estimate the norm of inv(A). */
+
+ ainvnm = 0.f;
+ *(unsigned char *)normin = 'N';
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kd = *kl + *ku + 1;
+ lnoti = *kl > 0;
+ kase = 0;
+L10:
+ clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(L). */
+
+ if (lnoti) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *kl, i__3 = *n - j;
+ lm = min(i__2,i__3);
+ jp = ipiv[j];
+ i__2 = jp;
+ t.r = work[i__2].r, t.i = work[i__2].i;
+ if (jp != j) {
+ i__2 = jp;
+ i__3 = j;
+ work[i__2].r = work[i__3].r, work[i__2].i = work[i__3]
+ .i;
+ i__2 = j;
+ work[i__2].r = t.r, work[i__2].i = t.i;
+ }
+ q__1.r = -t.r, q__1.i = -t.i;
+ caxpy_(&lm, &q__1, &ab[kd + 1 + j * ab_dim1], &c__1, &
+ work[j + 1], &c__1);
+/* L20: */
+ }
+ }
+
+/* Multiply by inv(U). */
+
+ i__1 = *kl + *ku;
+ clatbs_("Upper", "No transpose", "Non-unit", normin, n, &i__1, &
+ ab[ab_offset], ldab, &work[1], &scale, &rwork[1], info);
+ } else {
+
+/* Multiply by inv(U'). */
+
+ i__1 = *kl + *ku;
+ clatbs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &
+ i__1, &ab[ab_offset], ldab, &work[1], &scale, &rwork[1],
+ info);
+
+/* Multiply by inv(L'). */
+
+ if (lnoti) {
+ for (j = *n - 1; j >= 1; --j) {
+/* Computing MIN */
+ i__1 = *kl, i__2 = *n - j;
+ lm = min(i__1,i__2);
+ i__1 = j;
+ i__2 = j;
+ cdotc_(&q__2, &lm, &ab[kd + 1 + j * ab_dim1], &c__1, &
+ work[j + 1], &c__1);
+ q__1.r = work[i__2].r - q__2.r, q__1.i = work[i__2].i -
+ q__2.i;
+ work[i__1].r = q__1.r, work[i__1].i = q__1.i;
+ jp = ipiv[j];
+ if (jp != j) {
+ i__1 = jp;
+ t.r = work[i__1].r, t.i = work[i__1].i;
+ i__1 = jp;
+ i__2 = j;
+ work[i__1].r = work[i__2].r, work[i__1].i = work[i__2]
+ .i;
+ i__1 = j;
+ work[i__1].r = t.r, work[i__1].i = t.i;
+ }
+/* L30: */
+ }
+ }
+ }
+
+/* Divide X by 1/SCALE if doing so will not cause overflow. */
+
+ *(unsigned char *)normin = 'Y';
+ if (scale != 1.f) {
+ ix = icamax_(n, &work[1], &c__1);
+ i__1 = ix;
+ if (scale < ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
+ work[ix]), dabs(r__2))) * smlnum || scale == 0.f) {
+ goto L40;
+ }
+ csrscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / ainvnm / *anorm;
+ }
+
+L40:
+ return 0;
+
+/* End of CGBCON */
+
+} /* cgbcon_ */
diff --git a/SRC/cgbequ.c b/SRC/cgbequ.c
new file mode 100644
index 0000000..1469460
--- /dev/null
+++ b/SRC/cgbequ.c
@@ -0,0 +1,329 @@
+/* cgbequ.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cgbequ_(integer *m, integer *n, integer *kl, integer *ku,
+ complex *ab, integer *ldab, real *r__, real *c__, real *rowcnd, real
+ *colcnd, real *amax, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, kd;
+ real rcmin, rcmax;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum, smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGBEQU computes row and column scalings intended to equilibrate an */
+/* M-by-N band matrix A and reduce its condition number. R returns the */
+/* row scale factors and C the column scale factors, chosen to try to */
+/* make the largest element in each row and column of the matrix B with */
+/* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. */
+
+/* R(i) and C(j) are restricted to be between SMLNUM = smallest safe */
+/* number and BIGNUM = largest safe number. Use of these scaling */
+/* factors is not guaranteed to reduce the condition number of A but */
+/* works well in practice. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* The band matrix A, stored in rows 1 to KL+KU+1. The j-th */
+/* column of A is stored in the j-th column of the array AB as */
+/* follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* R (output) REAL array, dimension (M) */
+/* If INFO = 0, or INFO > M, R contains the row scale factors */
+/* for A. */
+
+/* C (output) REAL array, dimension (N) */
+/* If INFO = 0, C contains the column scale factors for A. */
+
+/* ROWCND (output) REAL */
+/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */
+/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */
+/* AMAX is neither too large nor too small, it is not worth */
+/* scaling by R. */
+
+/* COLCND (output) REAL */
+/* If INFO = 0, COLCND contains the ratio of the smallest */
+/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */
+/* worth scaling by C. */
+
+/* AMAX (output) REAL */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= M: the i-th row of A is exactly zero */
+/* > M: the (i-M)-th column of A is exactly zero */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGBEQU", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ *rowcnd = 1.f;
+ *colcnd = 1.f;
+ *amax = 0.f;
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+
+/* Compute row scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__[i__] = 0.f;
+/* L10: */
+ }
+
+/* Find the maximum element in each row. */
+
+ kd = *ku + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j - *ku;
+/* Computing MIN */
+ i__4 = j + *kl;
+ i__3 = min(i__4,*m);
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ i__2 = kd + i__ - j + j * ab_dim1;
+ r__3 = r__[i__], r__4 = (r__1 = ab[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&ab[kd + i__ - j + j * ab_dim1]), dabs(r__2));
+ r__[i__] = dmax(r__3,r__4);
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = rcmax, r__2 = r__[i__];
+ rcmax = dmax(r__1,r__2);
+/* Computing MIN */
+ r__1 = rcmin, r__2 = r__[i__];
+ rcmin = dmin(r__1,r__2);
+/* L40: */
+ }
+ *amax = rcmax;
+
+ if (rcmin == 0.f) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] == 0.f) {
+ *info = i__;
+ return 0;
+ }
+/* L50: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MIN */
+/* Computing MAX */
+ r__2 = r__[i__];
+ r__1 = dmax(r__2,smlnum);
+ r__[i__] = 1.f / dmin(r__1,bignum);
+/* L60: */
+ }
+
+/* Compute ROWCND = min(R(I)) / max(R(I)) */
+
+ *rowcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ }
+
+/* Compute column scale factors */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 0.f;
+/* L70: */
+ }
+
+/* Find the maximum element in each column, */
+/* assuming the row scaling computed above. */
+
+ kd = *ku + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__3 = j - *ku;
+/* Computing MIN */
+ i__4 = j + *kl;
+ i__2 = min(i__4,*m);
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = kd + i__ - j + j * ab_dim1;
+ r__3 = c__[j], r__4 = ((r__1 = ab[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&ab[kd + i__ - j + j * ab_dim1]), dabs(r__2))) *
+ r__[i__];
+ c__[j] = dmax(r__3,r__4);
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = c__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = c__[j];
+ rcmax = dmax(r__1,r__2);
+/* L100: */
+ }
+
+ if (rcmin == 0.f) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (c__[j] == 0.f) {
+ *info = *m + j;
+ return 0;
+ }
+/* L110: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+/* Computing MAX */
+ r__2 = c__[j];
+ r__1 = dmax(r__2,smlnum);
+ c__[j] = 1.f / dmin(r__1,bignum);
+/* L120: */
+ }
+
+/* Compute COLCND = min(C(J)) / max(C(J)) */
+
+ *colcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ }
+
+ return 0;
+
+/* End of CGBEQU */
+
+} /* cgbequ_ */
diff --git a/SRC/cgbequb.c b/SRC/cgbequb.c
new file mode 100644
index 0000000..76cfdf9
--- /dev/null
+++ b/SRC/cgbequb.c
@@ -0,0 +1,353 @@
+/* cgbequb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cgbequb_(integer *m, integer *n, integer *kl, integer *
+ ku, complex *ab, integer *ldab, real *r__, real *c__, real *rowcnd,
+ real *colcnd, real *amax, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ double log(doublereal), r_imag(complex *), pow_ri(real *, integer *);
+
+ /* Local variables */
+ integer i__, j, kd;
+ real radix, rcmin, rcmax;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum, logrdx, smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGBEQUB computes row and column scalings intended to equilibrate an */
+/* M-by-N matrix A and reduce its condition number. R returns the row */
+/* scale factors and C the column scale factors, chosen to try to make */
+/* the largest element in each row and column of the matrix B with */
+/* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most */
+/* the radix. */
+
+/* R(i) and C(j) are restricted to be a power of the radix between */
+/* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use */
+/* of these scaling factors is not guaranteed to reduce the condition */
+/* number of A but works well in practice. */
+
+/* This routine differs from CGEEQU by restricting the scaling factors */
+/* to a power of the radix. Baring over- and underflow, scaling by */
+/* these factors introduces no additional rounding errors. However, the */
+/* scaled entries' magnitured are no longer approximately 1 but lie */
+/* between sqrt(radix) and 1/sqrt(radix). */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array A. LDAB >= max(1,M). */
+
+/* R (output) REAL array, dimension (M) */
+/* If INFO = 0 or INFO > M, R contains the row scale factors */
+/* for A. */
+
+/* C (output) REAL array, dimension (N) */
+/* If INFO = 0, C contains the column scale factors for A. */
+
+/* ROWCND (output) REAL */
+/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */
+/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */
+/* AMAX is neither too large nor too small, it is not worth */
+/* scaling by R. */
+
+/* COLCND (output) REAL */
+/* If INFO = 0, COLCND contains the ratio of the smallest */
+/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */
+/* worth scaling by C. */
+
+/* AMAX (output) REAL */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= M: the i-th row of A is exactly zero */
+/* > M: the (i-M)-th column of A is exactly zero */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGBEQUB", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ *rowcnd = 1.f;
+ *colcnd = 1.f;
+ *amax = 0.f;
+ return 0;
+ }
+
+/* Get machine constants. Assume SMLNUM is a power of the radix. */
+
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+ radix = slamch_("B");
+ logrdx = log(radix);
+
+/* Compute row scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__[i__] = 0.f;
+/* L10: */
+ }
+
+/* Find the maximum element in each row. */
+
+ kd = *ku + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j - *ku;
+/* Computing MIN */
+ i__4 = j + *kl;
+ i__3 = min(i__4,*m);
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ i__2 = kd + i__ - j + j * ab_dim1;
+ r__3 = r__[i__], r__4 = (r__1 = ab[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&ab[kd + i__ - j + j * ab_dim1]), dabs(r__2));
+ r__[i__] = dmax(r__3,r__4);
+/* L20: */
+ }
+/* L30: */
+ }
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] > 0.f) {
+ i__3 = (integer) (log(r__[i__]) / logrdx);
+ r__[i__] = pow_ri(&radix, &i__3);
+ }
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = rcmax, r__2 = r__[i__];
+ rcmax = dmax(r__1,r__2);
+/* Computing MIN */
+ r__1 = rcmin, r__2 = r__[i__];
+ rcmin = dmin(r__1,r__2);
+/* L40: */
+ }
+ *amax = rcmax;
+
+ if (rcmin == 0.f) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] == 0.f) {
+ *info = i__;
+ return 0;
+ }
+/* L50: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MIN */
+/* Computing MAX */
+ r__2 = r__[i__];
+ r__1 = dmax(r__2,smlnum);
+ r__[i__] = 1.f / dmin(r__1,bignum);
+/* L60: */
+ }
+
+/* Compute ROWCND = min(R(I)) / max(R(I)). */
+
+ *rowcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ }
+
+/* Compute column scale factors. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 0.f;
+/* L70: */
+ }
+
+/* Find the maximum element in each column, */
+/* assuming the row scaling computed above. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__3 = j - *ku;
+/* Computing MIN */
+ i__4 = j + *kl;
+ i__2 = min(i__4,*m);
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = kd + i__ - j + j * ab_dim1;
+ r__3 = c__[j], r__4 = ((r__1 = ab[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&ab[kd + i__ - j + j * ab_dim1]), dabs(r__2))) *
+ r__[i__];
+ c__[j] = dmax(r__3,r__4);
+/* L80: */
+ }
+ if (c__[j] > 0.f) {
+ i__2 = (integer) (log(c__[j]) / logrdx);
+ c__[j] = pow_ri(&radix, &i__2);
+ }
+/* L90: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = c__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = c__[j];
+ rcmax = dmax(r__1,r__2);
+/* L100: */
+ }
+
+ if (rcmin == 0.f) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (c__[j] == 0.f) {
+ *info = *m + j;
+ return 0;
+ }
+/* L110: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+/* Computing MAX */
+ r__2 = c__[j];
+ r__1 = dmax(r__2,smlnum);
+ c__[j] = 1.f / dmin(r__1,bignum);
+/* L120: */
+ }
+
+/* Compute COLCND = min(C(J)) / max(C(J)). */
+
+ *colcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ }
+
+ return 0;
+
+/* End of CGBEQUB */
+
+} /* cgbequb_ */
diff --git a/SRC/cgbrfs.c b/SRC/cgbrfs.c
new file mode 100644
index 0000000..e2a720d
--- /dev/null
+++ b/SRC/cgbrfs.c
@@ -0,0 +1,492 @@
+/* cgbrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cgbrfs_(char *trans, integer *n, integer *kl, integer *
+ ku, integer *nrhs, complex *ab, integer *ldab, complex *afb, integer *
+ ldafb, integer *ipiv, complex *b, integer *ldb, complex *x, integer *
+ ldx, real *ferr, real *berr, complex *work, real *rwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+ real r__1, r__2, r__3, r__4;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ real s;
+ integer kk;
+ real xk;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern /* Subroutine */ int cgbmv_(char *, integer *, integer *, integer *
+, integer *, complex *, complex *, integer *, complex *, integer *
+, complex *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ integer count;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *), cgbtrs_(
+ char *, integer *, integer *, integer *, integer *, complex *,
+ integer *, integer *, complex *, integer *, integer *);
+ logical notran;
+ char transn[1], transt[1];
+ real lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGBRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is banded, and provides */
+/* error bounds and backward error estimates for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* The original band matrix A, stored in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input) COMPLEX array, dimension (LDAFB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by CGBTRF. U is stored as an upper triangular band */
+/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
+/* the multipliers used during the factorization are stored in */
+/* rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from CGBTRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by CGBTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -7;
+ } else if (*ldafb < (*kl << 1) + *ku + 1) {
+ *info = -9;
+ } else if (*ldb < max(1,*n)) {
+ *info = -12;
+ } else if (*ldx < max(1,*n)) {
+ *info = -14;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGBRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transn = 'N';
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transn = 'C';
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+/* Computing MIN */
+ i__1 = *kl + *ku + 2, i__2 = *n + 1;
+ nz = min(i__1,i__2);
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.f;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A, A**T, or A**H, depending on TRANS. */
+
+ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgbmv_(trans, n, n, kl, ku, &q__1, &ab[ab_offset], ldab, &x[j *
+ x_dim1 + 1], &c__1, &c_b1, &work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[
+ i__ + j * b_dim1]), dabs(r__2));
+/* L30: */
+ }
+
+/* Compute abs(op(A))*abs(X) + abs(B). */
+
+ if (notran) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ kk = *ku + 1 - k;
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j
+ * x_dim1]), dabs(r__2));
+/* Computing MAX */
+ i__3 = 1, i__4 = k - *ku;
+/* Computing MIN */
+ i__6 = *n, i__7 = k + *kl;
+ i__5 = min(i__6,i__7);
+ for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
+ i__3 = kk + i__ + k * ab_dim1;
+ rwork[i__] += ((r__1 = ab[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&ab[kk + i__ + k * ab_dim1]), dabs(r__2)))
+ * xk;
+/* L40: */
+ }
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ kk = *ku + 1 - k;
+/* Computing MAX */
+ i__5 = 1, i__3 = k - *ku;
+/* Computing MIN */
+ i__6 = *n, i__7 = k + *kl;
+ i__4 = min(i__6,i__7);
+ for (i__ = max(i__5,i__3); i__ <= i__4; ++i__) {
+ i__5 = kk + i__ + k * ab_dim1;
+ i__3 = i__ + j * x_dim1;
+ s += ((r__1 = ab[i__5].r, dabs(r__1)) + (r__2 = r_imag(&
+ ab[kk + i__ + k * ab_dim1]), dabs(r__2))) * ((
+ r__3 = x[i__3].r, dabs(r__3)) + (r__4 = r_imag(&x[
+ i__ + j * x_dim1]), dabs(r__4)));
+/* L60: */
+ }
+ rwork[k] += s;
+/* L70: */
+ }
+ }
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__4 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
+ s = dmax(r__3,r__4);
+ } else {
+/* Computing MAX */
+ i__4 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = dmax(r__3,r__4);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ cgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1]
+, &work[1], n, info);
+ caxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use CLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__4 = i__;
+ rwork[i__] = (r__1 = work[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__];
+ } else {
+ i__4 = i__;
+ rwork[i__] = (r__1 = work[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__] + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)**H). */
+
+ cgbtrs_(transt, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &
+ ipiv[1], &work[1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ i__3 = i__;
+ q__1.r = rwork[i__5] * work[i__3].r, q__1.i = rwork[i__5]
+ * work[i__3].i;
+ work[i__4].r = q__1.r, work[i__4].i = q__1.i;
+/* L110: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ i__3 = i__;
+ q__1.r = rwork[i__5] * work[i__3].r, q__1.i = rwork[i__5]
+ * work[i__3].i;
+ work[i__4].r = q__1.r, work[i__4].i = q__1.i;
+/* L120: */
+ }
+ cgbtrs_(transn, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &
+ ipiv[1], &work[1], n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__4 = i__ + j * x_dim1;
+ r__3 = lstres, r__4 = (r__1 = x[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + j * x_dim1]), dabs(r__2));
+ lstres = dmax(r__3,r__4);
+/* L130: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of CGBRFS */
+
+} /* cgbrfs_ */
diff --git a/SRC/cgbrfsx.c b/SRC/cgbrfsx.c
new file mode 100644
index 0000000..4d24a80
--- /dev/null
+++ b/SRC/cgbrfsx.c
@@ -0,0 +1,686 @@
+/* cgbrfsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int cgbrfsx_(char *trans, char *equed, integer *n, integer *
+ kl, integer *ku, integer *nrhs, complex *ab, integer *ldab, complex *
+ afb, integer *ldafb, integer *ipiv, real *r__, real *c__, complex *b,
+ integer *ldb, complex *x, integer *ldx, real *rcond, real *berr,
+ integer *n_err_bnds__, real *err_bnds_norm__, real *err_bnds_comp__,
+ integer *nparams, real *params, complex *work, real *rwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real illrcond_thresh__, unstable_thresh__, err_lbnd__;
+ integer ref_type__;
+ extern integer ilatrans_(char *);
+ integer j;
+ real rcond_tmp__;
+ integer prec_type__, trans_type__;
+ real cwise_wrong__;
+ extern /* Subroutine */ int cla_gbrfsx_extended__(integer *, integer *,
+ integer *, integer *, integer *, integer *, complex *, integer *,
+ complex *, integer *, integer *, logical *, real *, complex *,
+ integer *, complex *, integer *, real *, integer *, real *, real *
+ , complex *, real *, complex *, complex *, real *, integer *,
+ real *, real *, logical *, integer *);
+ char norm[1];
+ logical ignore_cwise__;
+ extern doublereal cla_gbrcond_c__(char *, integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, integer *, real *,
+ logical *, integer *, complex *, real *, ftnlen);
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern doublereal cla_gbrcond_x__(char *, integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, integer *, complex *,
+ integer *, complex *, real *, ftnlen), clangb_(char *, integer *,
+ integer *, integer *, complex *, integer *, real *);
+ extern /* Subroutine */ int cgbcon_(char *, integer *, integer *, integer
+ *, complex *, integer *, integer *, real *, real *, complex *,
+ real *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical colequ, notran, rowequ;
+ extern integer ilaprec_(char *);
+ integer ithresh, n_norms__;
+ real rthresh;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGBRFSX improves the computed solution to a system of linear */
+/* equations and provides error bounds and backward error estimates */
+/* for the solution. In addition to normwise error bound, the code */
+/* provides maximum componentwise error bound if possible. See */
+/* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the */
+/* error bounds. */
+
+/* The original system of linear equations may have been equilibrated */
+/* before calling this routine, as described by arguments EQUED, R */
+/* and C below. In this case, the solution and error bounds returned */
+/* are for the original unequilibrated system. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* EQUED (input) CHARACTER*1 */
+/* Specifies the form of equilibration that was done to A */
+/* before calling this routine. This is needed to compute */
+/* the solution and error bounds correctly. */
+/* = 'N': No equilibration */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* The right hand side B has been changed accordingly. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The original band matrix A, stored in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by DGBTRF. U is stored as an upper triangular band */
+/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
+/* the multipliers used during the factorization are stored in */
+/* rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from SGETRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* R (input or output) REAL array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+/* If R is output, each element of R is a power of the radix. */
+/* If R is input, each element of R should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* C (input or output) REAL array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+/* If C is output, each element of C is a power of the radix. */
+/* If C is input, each element of C should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) REAL array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by SGETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) REAL array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check the input parameters. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ trans_type__ = ilatrans_(trans);
+ ref_type__ = 1;
+ if (*nparams >= 1) {
+ if (params[1] < 0.f) {
+ params[1] = 1.f;
+ } else {
+ ref_type__ = params[1];
+ }
+ }
+
+/* Set default parameters. */
+
+ illrcond_thresh__ = (real) (*n) * slamch_("Epsilon");
+ ithresh = 10;
+ rthresh = .5f;
+ unstable_thresh__ = .25f;
+ ignore_cwise__ = FALSE_;
+
+ if (*nparams >= 2) {
+ if (params[2] < 0.f) {
+ params[2] = (real) ithresh;
+ } else {
+ ithresh = (integer) params[2];
+ }
+ }
+ if (*nparams >= 3) {
+ if (params[3] < 0.f) {
+ if (ignore_cwise__) {
+ params[3] = 0.f;
+ } else {
+ params[3] = 1.f;
+ }
+ } else {
+ ignore_cwise__ = params[3] == 0.f;
+ }
+ }
+ if (ref_type__ == 0 || *n_err_bnds__ == 0) {
+ n_norms__ = 0;
+ } else if (ignore_cwise__) {
+ n_norms__ = 1;
+ } else {
+ n_norms__ = 2;
+ }
+
+ notran = lsame_(trans, "N");
+ rowequ = lsame_(equed, "R") || lsame_(equed, "B");
+ colequ = lsame_(equed, "C") || lsame_(equed, "B");
+
+/* Test input parameters. */
+
+ if (trans_type__ == -1) {
+ *info = -1;
+ } else if (! rowequ && ! colequ && ! lsame_(equed, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kl < 0) {
+ *info = -4;
+ } else if (*ku < 0) {
+ *info = -5;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -8;
+ } else if (*ldafb < (*kl << 1) + *ku + 1) {
+ *info = -10;
+ } else if (*ldb < max(1,*n)) {
+ *info = -13;
+ } else if (*ldx < max(1,*n)) {
+ *info = -15;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGBRFSX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *nrhs == 0) {
+ *rcond = 1.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 0.f;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.f;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.f;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.f;
+ }
+ }
+ return 0;
+ }
+
+/* Default to failure. */
+
+ *rcond = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 1.f;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.f;
+ }
+ }
+
+/* Compute the norm of A and the reciprocal of the condition */
+/* number of A. */
+
+ if (notran) {
+ *(unsigned char *)norm = 'I';
+ } else {
+ *(unsigned char *)norm = '1';
+ }
+ anorm = clangb_(norm, n, kl, ku, &ab[ab_offset], ldab, &rwork[1]);
+ cgbcon_(norm, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], &anorm, rcond,
+ &work[1], &rwork[1], info);
+
+/* Perform refinement on each right-hand side */
+
+ if (ref_type__ != 0) {
+ prec_type__ = ilaprec_("D");
+ if (notran) {
+ cla_gbrfsx_extended__(&prec_type__, &trans_type__, n, kl, ku,
+ nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, &
+ ipiv[1], &colequ, &c__[1], &b[b_offset], ldb, &x[x_offset]
+ , ldx, &berr[1], &n_norms__, &err_bnds_norm__[
+ err_bnds_norm_offset], &err_bnds_comp__[
+ err_bnds_comp_offset], &work[1], &rwork[1], &work[*n + 1],
+ (complex *)(&rwork[1]), rcond, &ithresh, &rthresh, &unstable_thresh__, &
+ ignore_cwise__, info);
+ } else {
+ cla_gbrfsx_extended__(&prec_type__, &trans_type__, n, kl, ku,
+ nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, &
+ ipiv[1], &rowequ, &r__[1], &b[b_offset], ldb, &x[x_offset]
+ , ldx, &berr[1], &n_norms__, &err_bnds_norm__[
+ err_bnds_norm_offset], &err_bnds_comp__[
+ err_bnds_comp_offset], &work[1], &rwork[1], &work[*n + 1],
+ (complex *)(&rwork[1]), rcond, &ithresh, &rthresh, &unstable_thresh__, &
+ ignore_cwise__, info);
+ }
+ }
+/* Computing MAX */
+ r__1 = 10.f, r__2 = sqrt((real) (*n));
+ err_lbnd__ = dmax(r__1,r__2) * slamch_("Epsilon");
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {
+
+/* Compute scaled normwise condition number cond(A*C). */
+
+ if (colequ && notran) {
+ rcond_tmp__ = cla_gbrcond_c__(trans, n, kl, ku, &ab[ab_offset],
+ ldab, &afb[afb_offset], ldafb, &ipiv[1], &c__[1], &c_true,
+ info, &work[1], &rwork[1], (ftnlen)1);
+ } else if (rowequ && ! notran) {
+ rcond_tmp__ = cla_gbrcond_c__(trans, n, kl, ku, &ab[ab_offset],
+ ldab, &afb[afb_offset], ldafb, &ipiv[1], &r__[1], &c_true,
+ info, &work[1], &rwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = cla_gbrcond_c__(trans, n, kl, ku, &ab[ab_offset],
+ ldab, &afb[afb_offset], ldafb, &ipiv[1], &c__[1], &
+ c_false, info, &work[1], &rwork[1], (ftnlen)1);
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1
+ << 1)] > 1.f) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 0.f;
+ if (*info <= *n) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {
+
+/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
+/* each right-hand side using the current solution as an estimate of */
+/* the true solution. If the componentwise error estimate is too */
+/* large, then the solution is a lousy estimate of truth and the */
+/* estimated RCOND may be too optimistic. To avoid misleading users, */
+/* the inverse condition number is set to 0.0 when the estimated */
+/* cwise error is at least CWISE_WRONG. */
+
+ cwise_wrong__ = sqrt(slamch_("Epsilon"));
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ cwise_wrong__) {
+ rcond_tmp__ = cla_gbrcond_x__(trans, n, kl, ku, &ab[ab_offset]
+ , ldab, &afb[afb_offset], ldafb, &ipiv[1], &x[j *
+ x_dim1 + 1], info, &work[1], &rwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = 0.f;
+ }
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1
+ << 1)] > 1.f) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 0.f;
+ if (params[3] == 1.f && *info < *n + j) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CGBRFSX */
+
+} /* cgbrfsx_ */
diff --git a/SRC/cgbsv.c b/SRC/cgbsv.c
new file mode 100644
index 0000000..fbbdc81
--- /dev/null
+++ b/SRC/cgbsv.c
@@ -0,0 +1,176 @@
+/* cgbsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cgbsv_(integer *n, integer *kl, integer *ku, integer *
+ nrhs, complex *ab, integer *ldab, integer *ipiv, complex *b, integer *
+ ldb, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int cgbtrf_(integer *, integer *, integer *,
+ integer *, complex *, integer *, integer *, integer *), xerbla_(
+ char *, integer *), cgbtrs_(char *, integer *, integer *,
+ integer *, integer *, complex *, integer *, integer *, complex *,
+ integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGBSV computes the solution to a complex system of linear equations */
+/* A * X = B, where A is a band matrix of order N with KL subdiagonals */
+/* and KU superdiagonals, and X and B are N-by-NRHS matrices. */
+
+/* The LU decomposition with partial pivoting and row interchanges is */
+/* used to factor A as A = L * U, where L is a product of permutation */
+/* and unit lower triangular matrices with KL subdiagonals, and U is */
+/* upper triangular with KL+KU superdiagonals. The factored form of A */
+/* is then used to solve the system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows KL+1 to */
+/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL) */
+/* On exit, details of the factorization: U is stored as an */
+/* upper triangular band matrix with KL+KU superdiagonals in */
+/* rows 1 to KL+KU+1, and the multipliers used during the */
+/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */
+/* See below for further details. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* The pivot indices that define the permutation matrix P; */
+/* row i of the matrix was interchanged with row IPIV(i). */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and the solution has not been computed. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* M = N = 6, KL = 2, KU = 1: */
+
+/* On entry: On exit: */
+
+/* * * * + + + * * * u14 u25 u36 */
+/* * * + + + + * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */
+/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */
+
+/* Array elements marked * are not used by the routine; elements marked */
+/* + need not be set on entry, but are required by the routine to store */
+/* elements of U because of fill-in resulting from the row interchanges. */
+
+/* ===================================================================== */
+
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*kl < 0) {
+ *info = -2;
+ } else if (*ku < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldab < (*kl << 1) + *ku + 1) {
+ *info = -6;
+ } else if (*ldb < max(*n,1)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGBSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the LU factorization of the band matrix A. */
+
+ cgbtrf_(n, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ cgbtrs_("No transpose", n, kl, ku, nrhs, &ab[ab_offset], ldab, &ipiv[
+ 1], &b[b_offset], ldb, info);
+ }
+ return 0;
+
+/* End of CGBSV */
+
+} /* cgbsv_ */
diff --git a/SRC/cgbsvx.c b/SRC/cgbsvx.c
new file mode 100644
index 0000000..ed72200
--- /dev/null
+++ b/SRC/cgbsvx.c
@@ -0,0 +1,675 @@
+/* cgbsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cgbsvx_(char *fact, char *trans, integer *n, integer *kl,
+ integer *ku, integer *nrhs, complex *ab, integer *ldab, complex *afb,
+ integer *ldafb, integer *ipiv, char *equed, real *r__, real *c__,
+ complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real
+ *ferr, real *berr, complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+
+ /* Local variables */
+ integer i__, j, j1, j2;
+ real amax;
+ char norm[1];
+ extern logical lsame_(char *, char *);
+ real rcmin, rcmax, anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ logical equil;
+ extern doublereal clangb_(char *, integer *, integer *, integer *,
+ complex *, integer *, real *);
+ extern /* Subroutine */ int claqgb_(integer *, integer *, integer *,
+ integer *, complex *, integer *, real *, real *, real *, real *,
+ real *, char *), cgbcon_(char *, integer *, integer *,
+ integer *, complex *, integer *, integer *, real *, real *,
+ complex *, real *, integer *);
+ real colcnd;
+ extern doublereal clantb_(char *, char *, char *, integer *, integer *,
+ complex *, integer *, real *);
+ extern /* Subroutine */ int cgbequ_(integer *, integer *, integer *,
+ integer *, complex *, integer *, real *, real *, real *, real *,
+ real *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int cgbrfs_(char *, integer *, integer *, integer
+ *, integer *, complex *, integer *, complex *, integer *, integer
+ *, complex *, integer *, complex *, integer *, real *, real *,
+ complex *, real *, integer *), cgbtrf_(integer *, integer
+ *, integer *, integer *, complex *, integer *, integer *, integer
+ *);
+ logical nofact;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), xerbla_(char *,
+ integer *);
+ real bignum;
+ extern /* Subroutine */ int cgbtrs_(char *, integer *, integer *, integer
+ *, integer *, complex *, integer *, integer *, complex *, integer
+ *, integer *);
+ integer infequ;
+ logical colequ;
+ real rowcnd;
+ logical notran;
+ real smlnum;
+ logical rowequ;
+ real rpvgrw;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGBSVX uses the LU factorization to compute the solution to a complex */
+/* system of linear equations A * X = B, A**T * X = B, or A**H * X = B, */
+/* where A is a band matrix of order N with KL subdiagonals and KU */
+/* superdiagonals, and X and B are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed by this subroutine: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */
+/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */
+/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */
+/* or diag(C)*B (if TRANS = 'T' or 'C'). */
+
+/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the */
+/* matrix A (after equilibration if FACT = 'E') as */
+/* A = L * U, */
+/* where L is a product of permutation and unit lower triangular */
+/* matrices with KL subdiagonals, and U is upper triangular with */
+/* KL+KU superdiagonals. */
+
+/* 3. If some U(i,i)=0, so that U is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */
+/* that it solves the original system before equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AFB and IPIV contain the factored form of */
+/* A. If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by R and C. */
+/* AB, AFB, and IPIV are not modified. */
+/* = 'N': The matrix A will be copied to AFB and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AFB and factored. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
+
+/* If FACT = 'F' and EQUED is not 'N', then A must have been */
+/* equilibrated by the scaling factors in R and/or C. AB is not */
+/* modified if FACT = 'F' or 'N', or if FACT = 'E' and */
+/* EQUED = 'N' on exit. */
+
+/* On exit, if EQUED .ne. 'N', A is scaled as follows: */
+/* EQUED = 'R': A := diag(R) * A */
+/* EQUED = 'C': A := A * diag(C) */
+/* EQUED = 'B': A := diag(R) * A * diag(C). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input or output) COMPLEX array, dimension (LDAFB,N) */
+/* If FACT = 'F', then AFB is an input argument and on entry */
+/* contains details of the LU factorization of the band matrix */
+/* A, as computed by CGBTRF. U is stored as an upper triangular */
+/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */
+/* and the multipliers used during the factorization are stored */
+/* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is */
+/* the factored form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AFB is an output argument and on exit */
+/* returns details of the LU factorization of A. */
+
+/* If FACT = 'E', then AFB is an output argument and on exit */
+/* returns details of the LU factorization of the equilibrated */
+/* matrix A (see the description of AB for the form of the */
+/* equilibrated matrix). */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains the pivot indices from the factorization A = L*U */
+/* as computed by CGBTRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = L*U */
+/* of the equilibrated matrix A. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* R (input or output) REAL array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+
+/* C (input or output) REAL array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */
+/* diag(R)*B; */
+/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */
+/* overwritten by diag(C)*B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X */
+/* to the original system of equations. Note that A and B are */
+/* modified on exit if EQUED .ne. 'N', and the solution to the */
+/* equilibrated system is inv(diag(C))*X if TRANS = 'N' and */
+/* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' */
+/* and EQUED = 'R' or 'B'. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A after equilibration (if done). If RCOND is less than the */
+/* machine precision (in particular, if RCOND = 0), the matrix */
+/* is singular to working precision. This condition is */
+/* indicated by a return code of INFO > 0. */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace/output) REAL array, dimension (N) */
+/* On exit, RWORK(1) contains the reciprocal pivot growth */
+/* factor norm(A)/norm(U). The "max absolute element" norm is */
+/* used. If RWORK(1) is much less than 1, then the stability */
+/* of the LU factorization of the (equilibrated) matrix A */
+/* could be poor. This also means that the solution X, condition */
+/* estimator RCOND, and forward error bound FERR could be */
+/* unreliable. If factorization fails with 0<INFO<=N, then */
+/* RWORK(1) contains the reciprocal pivot growth factor for the */
+/* leading INFO columns of A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, so the solution and error bounds */
+/* could not be computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+/* Moved setting of INFO = N+1 so INFO does not subsequently get */
+/* overwritten. Sven, 17 Mar 05. */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ notran = lsame_(trans, "N");
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rowequ = FALSE_;
+ colequ = FALSE_;
+ } else {
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ }
+
+/* Test the input parameters. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kl < 0) {
+ *info = -4;
+ } else if (*ku < 0) {
+ *info = -5;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -8;
+ } else if (*ldafb < (*kl << 1) + *ku + 1) {
+ *info = -10;
+ } else if (lsame_(fact, "F") && ! (rowequ || colequ
+ || lsame_(equed, "N"))) {
+ *info = -12;
+ } else {
+ if (rowequ) {
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = r__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = r__[j];
+ rcmax = dmax(r__1,r__2);
+/* L10: */
+ }
+ if (rcmin <= 0.f) {
+ *info = -13;
+ } else if (*n > 0) {
+ rowcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ } else {
+ rowcnd = 1.f;
+ }
+ }
+ if (colequ && *info == 0) {
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = c__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = c__[j];
+ rcmax = dmax(r__1,r__2);
+/* L20: */
+ }
+ if (rcmin <= 0.f) {
+ *info = -14;
+ } else if (*n > 0) {
+ colcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ } else {
+ colcnd = 1.f;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -16;
+ } else if (*ldx < max(1,*n)) {
+ *info = -18;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGBSVX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ cgbequ_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &rowcnd,
+ &colcnd, &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ claqgb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &
+ rowcnd, &colcnd, &amax, equed);
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+ }
+
+/* Scale the right hand side. */
+
+ if (notran) {
+ if (rowequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * b_dim1;
+ q__1.r = r__[i__4] * b[i__5].r, q__1.i = r__[i__4] * b[
+ i__5].i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else if (colequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * b_dim1;
+ q__1.r = c__[i__4] * b[i__5].r, q__1.i = c__[i__4] * b[i__5]
+ .i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of the band matrix A. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j - *ku;
+ j1 = max(i__2,1);
+/* Computing MIN */
+ i__2 = j + *kl;
+ j2 = min(i__2,*n);
+ i__2 = j2 - j1 + 1;
+ ccopy_(&i__2, &ab[*ku + 1 - j + j1 + j * ab_dim1], &c__1, &afb[*
+ kl + *ku + 1 - j + j1 + j * afb_dim1], &c__1);
+/* L70: */
+ }
+
+ cgbtrf_(n, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ anorm = 0.f;
+ i__1 = *info;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = *ku + 2 - j;
+/* Computing MIN */
+ i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1;
+ i__3 = min(i__4,i__5);
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ r__1 = anorm, r__2 = c_abs(&ab[i__ + j * ab_dim1]);
+ anorm = dmax(r__1,r__2);
+/* L80: */
+ }
+/* L90: */
+ }
+/* Computing MIN */
+ i__3 = *info - 1, i__2 = *kl + *ku;
+ i__1 = min(i__3,i__2);
+/* Computing MAX */
+ i__4 = 1, i__5 = *kl + *ku + 2 - *info;
+ rpvgrw = clantb_("M", "U", "N", info, &i__1, &afb[max(i__4, i__5)
+ + afb_dim1], ldafb, &rwork[1]);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = anorm / rpvgrw;
+ }
+ rwork[1] = rpvgrw;
+ *rcond = 0.f;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A and the */
+/* reciprocal pivot growth factor RPVGRW. */
+
+ if (notran) {
+ *(unsigned char *)norm = '1';
+ } else {
+ *(unsigned char *)norm = 'I';
+ }
+ anorm = clangb_(norm, n, kl, ku, &ab[ab_offset], ldab, &rwork[1]);
+ i__1 = *kl + *ku;
+ rpvgrw = clantb_("M", "U", "N", n, &i__1, &afb[afb_offset], ldafb, &rwork[
+ 1]);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = clangb_("M", n, kl, ku, &ab[ab_offset], ldab, &rwork[1]) / rpvgrw;
+ }
+
+/* Compute the reciprocal of the condition number of A. */
+
+ cgbcon_(norm, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], &anorm, rcond,
+ &work[1], &rwork[1], info);
+
+/* Compute the solution matrix X. */
+
+ clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ cgbtrs_(trans, n, kl, ku, nrhs, &afb[afb_offset], ldafb, &ipiv[1], &x[
+ x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ cgbrfs_(trans, n, kl, ku, nrhs, &ab[ab_offset], ldab, &afb[afb_offset],
+ ldafb, &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &
+ berr[1], &work[1], &rwork[1], info);
+
+/* Transform the solution matrix X to a solution of the original */
+/* system. */
+
+ if (notran) {
+ if (colequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__2 = i__ + j * x_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * x_dim1;
+ q__1.r = c__[i__4] * x[i__5].r, q__1.i = c__[i__4] * x[
+ i__5].i;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+/* L100: */
+ }
+/* L110: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= colcnd;
+/* L120: */
+ }
+ }
+ } else if (rowequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__2 = i__ + j * x_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * x_dim1;
+ q__1.r = r__[i__4] * x[i__5].r, q__1.i = r__[i__4] * x[i__5]
+ .i;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+/* L130: */
+ }
+/* L140: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= rowcnd;
+/* L150: */
+ }
+ }
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < slamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ rwork[1] = rpvgrw;
+ return 0;
+
+/* End of CGBSVX */
+
+} /* cgbsvx_ */
diff --git a/SRC/cgbsvxx.c b/SRC/cgbsvxx.c
new file mode 100644
index 0000000..ace9940
--- /dev/null
+++ b/SRC/cgbsvxx.c
@@ -0,0 +1,747 @@
+/* cgbsvxx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cgbsvxx_(char *fact, char *trans, integer *n, integer *
+ kl, integer *ku, integer *nrhs, complex *ab, integer *ldab, complex *
+ afb, integer *ldafb, integer *ipiv, char *equed, real *r__, real *c__,
+ complex *b, integer *ldb, complex *x, integer *ldx, real *rcond,
+ real *rpvgrw, real *berr, integer *n_err_bnds__, real *
+ err_bnds_norm__, real *err_bnds_comp__, integer *nparams, real *
+ params, complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer i__, j;
+ real amax;
+ extern doublereal cla_gbrpvgrw__(integer *, integer *, integer *, integer
+ *, complex *, integer *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ real rcmin, rcmax;
+ logical equil;
+ extern /* Subroutine */ int claqgb_(integer *, integer *, integer *,
+ integer *, complex *, integer *, real *, real *, real *, real *,
+ real *, char *);
+ real colcnd;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int cgbtrf_(integer *, integer *, integer *,
+ integer *, complex *, integer *, integer *, integer *);
+ logical nofact;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), xerbla_(char *,
+ integer *);
+ real bignum;
+ extern /* Subroutine */ int cgbtrs_(char *, integer *, integer *, integer
+ *, integer *, complex *, integer *, integer *, complex *, integer
+ *, integer *);
+ integer infequ;
+ logical colequ;
+ real rowcnd;
+ logical notran;
+ real smlnum;
+ logical rowequ;
+ extern /* Subroutine */ int clascl2_(integer *, integer *, real *,
+ complex *, integer *), cgbequb_(integer *, integer *, integer *,
+ integer *, complex *, integer *, real *, real *, real *, real *,
+ real *, integer *), cgbrfsx_(char *, char *, integer *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ integer *, real *, real *, complex *, integer *, complex *,
+ integer *, real *, real *, integer *, real *, real *, integer *,
+ real *, complex *, real *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGBSVXX uses the LU factorization to compute the solution to a */
+/* complex system of linear equations A * X = B, where A is an */
+/* N-by-N matrix and X and B are N-by-NRHS matrices. */
+
+/* If requested, both normwise and maximum componentwise error bounds */
+/* are returned. CGBSVXX will return a solution with a tiny */
+/* guaranteed error (O(eps) where eps is the working machine */
+/* precision) unless the matrix is very ill-conditioned, in which */
+/* case a warning is returned. Relevant condition numbers also are */
+/* calculated and returned. */
+
+/* CGBSVXX accepts user-provided factorizations and equilibration */
+/* factors; see the definitions of the FACT and EQUED options. */
+/* Solving with refinement and using a factorization from a previous */
+/* CGBSVXX call will also produce a solution with either O(eps) */
+/* errors or warnings, but we cannot make that claim for general */
+/* user-provided factorizations and equilibration factors if they */
+/* differ from what CGBSVXX would itself produce. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+
+/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */
+/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */
+/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */
+
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */
+/* or diag(C)*B (if TRANS = 'T' or 'C'). */
+
+/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */
+/* the matrix A (after equilibration if FACT = 'E') as */
+
+/* A = P * L * U, */
+
+/* where P is a permutation matrix, L is a unit lower triangular */
+/* matrix, and U is upper triangular. */
+
+/* 3. If some U(i,i)=0, so that U is exactly singular, then the */
+/* routine returns with INFO = i. Otherwise, the factored form of A */
+/* is used to estimate the condition number of the matrix A (see */
+/* argument RCOND). If the reciprocal of the condition number is less */
+/* than machine precision, the routine still goes on to solve for X */
+/* and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */
+/* the routine will use iterative refinement to try to get a small */
+/* error and error bounds. Refinement calculates the residual to at */
+/* least twice the working precision. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */
+/* that it solves the original system before equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF and IPIV contain the factored form of A. */
+/* If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by R and C. */
+/* A, AF, and IPIV are not modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input/output) REAL array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
+
+/* If FACT = 'F' and EQUED is not 'N', then AB must have been */
+/* equilibrated by the scaling factors in R and/or C. AB is not */
+/* modified if FACT = 'F' or 'N', or if FACT = 'E' and */
+/* EQUED = 'N' on exit. */
+
+/* On exit, if EQUED .ne. 'N', A is scaled as follows: */
+/* EQUED = 'R': A := diag(R) * A */
+/* EQUED = 'C': A := A * diag(C) */
+/* EQUED = 'B': A := diag(R) * A * diag(C). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input or output) REAL array, dimension (LDAFB,N) */
+/* If FACT = 'F', then AFB is an input argument and on entry */
+/* contains details of the LU factorization of the band matrix */
+/* A, as computed by CGBTRF. U is stored as an upper triangular */
+/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */
+/* and the multipliers used during the factorization are stored */
+/* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is */
+/* the factored form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the equilibrated matrix A (see the description of A for */
+/* the form of the equilibrated matrix). */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* as computed by SGETRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the equilibrated matrix A. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* R (input or output) REAL array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+/* If R is output, each element of R is a power of the radix. */
+/* If R is input, each element of R should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* C (input or output) REAL array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+/* If C is output, each element of C is a power of the radix. */
+/* If C is input, each element of C should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */
+/* diag(R)*B; */
+/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */
+/* overwritten by diag(C)*B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) REAL array, dimension (LDX,NRHS) */
+/* If INFO = 0, the N-by-NRHS solution matrix X to the original */
+/* system of equations. Note that A and B are modified on exit */
+/* if EQUED .ne. 'N', and the solution to the equilibrated system is */
+/* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or */
+/* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* RPVGRW (output) REAL */
+/* Reciprocal pivot growth. On exit, this contains the reciprocal */
+/* pivot growth factor norm(A)/norm(U). The "max absolute element" */
+/* norm is used. If this is much less than 1, then the stability of */
+/* the LU factorization of the (equilibrated) matrix A could be poor. */
+/* This also means that the solution X, estimated condition numbers, */
+/* and error bounds could be unreliable. If factorization fails with */
+/* 0<INFO<=N, then this contains the reciprocal pivot growth factor */
+/* for the leading INFO columns of A. In SGESVX, this quantity is */
+/* returned in WORK(1). */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) REAL array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) REAL array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ notran = lsame_(trans, "N");
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rowequ = FALSE_;
+ colequ = FALSE_;
+ } else {
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+
+/* Default is failure. If an input parameter is wrong or */
+/* factorization fails, make everything look horrible. Only the */
+/* pivot growth is set here, the rest is initialized in CGBRFSX. */
+
+ *rpvgrw = 0.f;
+
+/* Test the input parameters. PARAMS is not tested until SGERFSX. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kl < 0) {
+ *info = -4;
+ } else if (*ku < 0) {
+ *info = -5;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -8;
+ } else if (*ldafb < (*kl << 1) + *ku + 1) {
+ *info = -10;
+ } else if (lsame_(fact, "F") && ! (rowequ || colequ
+ || lsame_(equed, "N"))) {
+ *info = -12;
+ } else {
+ if (rowequ) {
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = r__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = r__[j];
+ rcmax = dmax(r__1,r__2);
+/* L10: */
+ }
+ if (rcmin <= 0.f) {
+ *info = -13;
+ } else if (*n > 0) {
+ rowcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ } else {
+ rowcnd = 1.f;
+ }
+ }
+ if (colequ && *info == 0) {
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = c__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = c__[j];
+ rcmax = dmax(r__1,r__2);
+/* L20: */
+ }
+ if (rcmin <= 0.f) {
+ *info = -14;
+ } else if (*n > 0) {
+ colcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ } else {
+ colcnd = 1.f;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -15;
+ } else if (*ldx < max(1,*n)) {
+ *info = -16;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGBSVXX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ cgbequb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &
+ rowcnd, &colcnd, &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ claqgb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &
+ rowcnd, &colcnd, &amax, equed);
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+
+/* If the scaling factors are not applied, set them to 1.0. */
+
+ if (! rowequ) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ r__[j] = 1.f;
+ }
+ }
+ if (! colequ) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 1.f;
+ }
+ }
+ }
+
+/* Scale the right-hand side. */
+
+ if (notran) {
+ if (rowequ) {
+ clascl2_(n, nrhs, &r__[1], &b[b_offset], ldb);
+ }
+ } else {
+ if (colequ) {
+ clascl2_(n, nrhs, &c__[1], &b[b_offset], ldb);
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of A. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (*kl << 1) + *ku + 1;
+ for (i__ = *kl + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * afb_dim1;
+ i__4 = i__ - *kl + j * ab_dim1;
+ afb[i__3].r = ab[i__4].r, afb[i__3].i = ab[i__4].i;
+/* L30: */
+ }
+/* L40: */
+ }
+ cgbtrf_(n, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Pivot in column INFO is exactly 0 */
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ *rpvgrw = cla_gbrpvgrw__(n, kl, ku, info, &ab[ab_offset], ldab, &
+ afb[afb_offset], ldafb);
+ return 0;
+ }
+ }
+
+/* Compute the reciprocal pivot growth factor RPVGRW. */
+
+ *rpvgrw = cla_gbrpvgrw__(n, kl, ku, n, &ab[ab_offset], ldab, &afb[
+ afb_offset], ldafb);
+
+/* Compute the solution matrix X. */
+
+ clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ cgbtrs_(trans, n, kl, ku, nrhs, &afb[afb_offset], ldafb, &ipiv[1], &x[
+ x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ cgbrfsx_(trans, equed, n, kl, ku, nrhs, &ab[ab_offset], ldab, &afb[
+ afb_offset], ldafb, &ipiv[1], &r__[1], &c__[1], &b[b_offset], ldb,
+ &x[x_offset], ldx, rcond, &berr[1], n_err_bnds__, &
+ err_bnds_norm__[err_bnds_norm_offset], &err_bnds_comp__[
+ err_bnds_comp_offset], nparams, ¶ms[1], &work[1], &rwork[1],
+ info);
+
+/* Scale solutions. */
+
+ if (colequ && notran) {
+ clascl2_(n, nrhs, &c__[1], &x[x_offset], ldx);
+ } else if (rowequ && ! notran) {
+ clascl2_(n, nrhs, &r__[1], &x[x_offset], ldx);
+ }
+
+ return 0;
+
+/* End of CGBSVXX */
+
+} /* cgbsvxx_ */
diff --git a/SRC/cgbtf2.c b/SRC/cgbtf2.c
new file mode 100644
index 0000000..ddf5cf5
--- /dev/null
+++ b/SRC/cgbtf2.c
@@ -0,0 +1,267 @@
+/* cgbtf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cgbtf2_(integer *m, integer *n, integer *kl, integer *ku,
+ complex *ab, integer *ldab, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ complex q__1;
+
+ /* Builtin functions */
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, km, jp, ju, kv;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *), cgeru_(integer *, integer *, complex *, complex *,
+ integer *, complex *, integer *, complex *, integer *), cswap_(
+ integer *, complex *, integer *, complex *, integer *);
+ extern integer icamax_(integer *, complex *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGBTF2 computes an LU factorization of a complex m-by-n band matrix */
+/* A using partial pivoting with row interchanges. */
+
+/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows KL+1 to */
+/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */
+
+/* On exit, details of the factorization: U is stored as an */
+/* upper triangular band matrix with KL+KU superdiagonals in */
+/* rows 1 to KL+KU+1, and the multipliers used during the */
+/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */
+/* See below for further details. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* M = N = 6, KL = 2, KU = 1: */
+
+/* On entry: On exit: */
+
+/* * * * + + + * * * u14 u25 u36 */
+/* * * + + + + * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */
+/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */
+
+/* Array elements marked * are not used by the routine; elements marked */
+/* + need not be set on entry, but are required by the routine to store */
+/* elements of U, because of fill-in resulting from the row */
+/* interchanges. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* KV is the number of superdiagonals in the factor U, allowing for */
+/* fill-in. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --ipiv;
+
+ /* Function Body */
+ kv = *ku + *kl;
+
+/* Test the input parameters. */
+
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*ldab < *kl + kv + 1) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGBTF2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Gaussian elimination with partial pivoting */
+
+/* Set fill-in elements in columns KU+2 to KV to zero. */
+
+ i__1 = min(kv,*n);
+ for (j = *ku + 2; j <= i__1; ++j) {
+ i__2 = *kl;
+ for (i__ = kv - j + 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * ab_dim1;
+ ab[i__3].r = 0.f, ab[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* JU is the index of the last column affected by the current stage */
+/* of the factorization. */
+
+ ju = 1;
+
+ i__1 = min(*m,*n);
+ for (j = 1; j <= i__1; ++j) {
+
+/* Set fill-in elements in column J+KV to zero. */
+
+ if (j + kv <= *n) {
+ i__2 = *kl;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j + kv) * ab_dim1;
+ ab[i__3].r = 0.f, ab[i__3].i = 0.f;
+/* L30: */
+ }
+ }
+
+/* Find pivot and test for singularity. KM is the number of */
+/* subdiagonal elements in the current column. */
+
+/* Computing MIN */
+ i__2 = *kl, i__3 = *m - j;
+ km = min(i__2,i__3);
+ i__2 = km + 1;
+ jp = icamax_(&i__2, &ab[kv + 1 + j * ab_dim1], &c__1);
+ ipiv[j] = jp + j - 1;
+ i__2 = kv + jp + j * ab_dim1;
+ if (ab[i__2].r != 0.f || ab[i__2].i != 0.f) {
+/* Computing MAX */
+/* Computing MIN */
+ i__4 = j + *ku + jp - 1;
+ i__2 = ju, i__3 = min(i__4,*n);
+ ju = max(i__2,i__3);
+
+/* Apply interchange to columns J to JU. */
+
+ if (jp != 1) {
+ i__2 = ju - j + 1;
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ cswap_(&i__2, &ab[kv + jp + j * ab_dim1], &i__3, &ab[kv + 1 +
+ j * ab_dim1], &i__4);
+ }
+ if (km > 0) {
+
+/* Compute multipliers. */
+
+ c_div(&q__1, &c_b1, &ab[kv + 1 + j * ab_dim1]);
+ cscal_(&km, &q__1, &ab[kv + 2 + j * ab_dim1], &c__1);
+
+/* Update trailing submatrix within the band. */
+
+ if (ju > j) {
+ i__2 = ju - j;
+ q__1.r = -1.f, q__1.i = -0.f;
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ cgeru_(&km, &i__2, &q__1, &ab[kv + 2 + j * ab_dim1], &
+ c__1, &ab[kv + (j + 1) * ab_dim1], &i__3, &ab[kv
+ + 1 + (j + 1) * ab_dim1], &i__4);
+ }
+ }
+ } else {
+
+/* If pivot is zero, set INFO to the index of the pivot */
+/* unless a zero pivot has already been found. */
+
+ if (*info == 0) {
+ *info = j;
+ }
+ }
+/* L40: */
+ }
+ return 0;
+
+/* End of CGBTF2 */
+
+} /* cgbtf2_ */
diff --git a/SRC/cgbtrf.c b/SRC/cgbtrf.c
new file mode 100644
index 0000000..491eb8d
--- /dev/null
+++ b/SRC/cgbtrf.c
@@ -0,0 +1,604 @@
+/* cgbtrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c__65 = 65;
+
+/* Subroutine */ int cgbtrf_(integer *m, integer *n, integer *kl, integer *ku,
+ complex *ab, integer *ldab, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ complex q__1;
+
+ /* Builtin functions */
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, i2, i3, j2, j3, k2, jb, nb, ii, jj, jm, ip, jp, km, ju,
+ kv, nw;
+ complex temp;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *), cgemm_(char *, char *, integer *, integer *, integer *
+, complex *, complex *, integer *, complex *, integer *, complex *
+, complex *, integer *), cgeru_(integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, integer *), ccopy_(integer *, complex *, integer *,
+ complex *, integer *), cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ complex work13[4160] /* was [65][64] */, work31[4160] /*
+ was [65][64] */;
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *), cgbtf2_(integer *,
+ integer *, integer *, integer *, complex *, integer *, integer *,
+ integer *);
+ extern integer icamax_(integer *, complex *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int claswp_(integer *, complex *, integer *,
+ integer *, integer *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGBTRF computes an LU factorization of a complex m-by-n band matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* This is the blocked version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows KL+1 to */
+/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */
+
+/* On exit, details of the factorization: U is stored as an */
+/* upper triangular band matrix with KL+KU superdiagonals in */
+/* rows 1 to KL+KU+1, and the multipliers used during the */
+/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */
+/* See below for further details. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* M = N = 6, KL = 2, KU = 1: */
+
+/* On entry: On exit: */
+
+/* * * * + + + * * * u14 u25 u36 */
+/* * * + + + + * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */
+/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */
+
+/* Array elements marked * are not used by the routine; elements marked */
+/* + need not be set on entry, but are required by the routine to store */
+/* elements of U because of fill-in resulting from the row interchanges. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* KV is the number of superdiagonals in the factor U, allowing for */
+/* fill-in */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --ipiv;
+
+ /* Function Body */
+ kv = *ku + *kl;
+
+/* Test the input parameters. */
+
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*ldab < *kl + kv + 1) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGBTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment */
+
+ nb = ilaenv_(&c__1, "CGBTRF", " ", m, n, kl, ku);
+
+/* The block size must not exceed the limit set by the size of the */
+/* local arrays WORK13 and WORK31. */
+
+ nb = min(nb,64);
+
+ if (nb <= 1 || nb > *kl) {
+
+/* Use unblocked code */
+
+ cgbtf2_(m, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info);
+ } else {
+
+/* Use blocked code */
+
+/* Zero the superdiagonal elements of the work array WORK13 */
+
+ i__1 = nb;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 65 - 66;
+ work13[i__3].r = 0.f, work13[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Zero the subdiagonal elements of the work array WORK31 */
+
+ i__1 = nb;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = nb;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 65 - 66;
+ work31[i__3].r = 0.f, work31[i__3].i = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Gaussian elimination with partial pivoting */
+
+/* Set fill-in elements in columns KU+2 to KV to zero */
+
+ i__1 = min(kv,*n);
+ for (j = *ku + 2; j <= i__1; ++j) {
+ i__2 = *kl;
+ for (i__ = kv - j + 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * ab_dim1;
+ ab[i__3].r = 0.f, ab[i__3].i = 0.f;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* JU is the index of the last column affected by the current */
+/* stage of the factorization */
+
+ ju = 1;
+
+ i__1 = min(*m,*n);
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = min(*m,*n) - j + 1;
+ jb = min(i__3,i__4);
+
+/* The active part of the matrix is partitioned */
+
+/* A11 A12 A13 */
+/* A21 A22 A23 */
+/* A31 A32 A33 */
+
+/* Here A11, A21 and A31 denote the current block of JB columns */
+/* which is about to be factorized. The number of rows in the */
+/* partitioning are JB, I2, I3 respectively, and the numbers */
+/* of columns are JB, J2, J3. The superdiagonal elements of A13 */
+/* and the subdiagonal elements of A31 lie outside the band. */
+
+/* Computing MIN */
+ i__3 = *kl - jb, i__4 = *m - j - jb + 1;
+ i2 = min(i__3,i__4);
+/* Computing MIN */
+ i__3 = jb, i__4 = *m - j - *kl + 1;
+ i3 = min(i__3,i__4);
+
+/* J2 and J3 are computed after JU has been updated. */
+
+/* Factorize the current block of JB columns */
+
+ i__3 = j + jb - 1;
+ for (jj = j; jj <= i__3; ++jj) {
+
+/* Set fill-in elements in column JJ+KV to zero */
+
+ if (jj + kv <= *n) {
+ i__4 = *kl;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__ + (jj + kv) * ab_dim1;
+ ab[i__5].r = 0.f, ab[i__5].i = 0.f;
+/* L70: */
+ }
+ }
+
+/* Find pivot and test for singularity. KM is the number of */
+/* subdiagonal elements in the current column. */
+
+/* Computing MIN */
+ i__4 = *kl, i__5 = *m - jj;
+ km = min(i__4,i__5);
+ i__4 = km + 1;
+ jp = icamax_(&i__4, &ab[kv + 1 + jj * ab_dim1], &c__1);
+ ipiv[jj] = jp + jj - j;
+ i__4 = kv + jp + jj * ab_dim1;
+ if (ab[i__4].r != 0.f || ab[i__4].i != 0.f) {
+/* Computing MAX */
+/* Computing MIN */
+ i__6 = jj + *ku + jp - 1;
+ i__4 = ju, i__5 = min(i__6,*n);
+ ju = max(i__4,i__5);
+ if (jp != 1) {
+
+/* Apply interchange to columns J to J+JB-1 */
+
+ if (jp + jj - 1 < j + *kl) {
+
+ i__4 = *ldab - 1;
+ i__5 = *ldab - 1;
+ cswap_(&jb, &ab[kv + 1 + jj - j + j * ab_dim1], &
+ i__4, &ab[kv + jp + jj - j + j * ab_dim1],
+ &i__5);
+ } else {
+
+/* The interchange affects columns J to JJ-1 of A31 */
+/* which are stored in the work array WORK31 */
+
+ i__4 = jj - j;
+ i__5 = *ldab - 1;
+ cswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1],
+ &i__5, &work31[jp + jj - j - *kl - 1], &
+ c__65);
+ i__4 = j + jb - jj;
+ i__5 = *ldab - 1;
+ i__6 = *ldab - 1;
+ cswap_(&i__4, &ab[kv + 1 + jj * ab_dim1], &i__5, &
+ ab[kv + jp + jj * ab_dim1], &i__6);
+ }
+ }
+
+/* Compute multipliers */
+
+ c_div(&q__1, &c_b1, &ab[kv + 1 + jj * ab_dim1]);
+ cscal_(&km, &q__1, &ab[kv + 2 + jj * ab_dim1], &c__1);
+
+/* Update trailing submatrix within the band and within */
+/* the current block. JM is the index of the last column */
+/* which needs to be updated. */
+
+/* Computing MIN */
+ i__4 = ju, i__5 = j + jb - 1;
+ jm = min(i__4,i__5);
+ if (jm > jj) {
+ i__4 = jm - jj;
+ q__1.r = -1.f, q__1.i = -0.f;
+ i__5 = *ldab - 1;
+ i__6 = *ldab - 1;
+ cgeru_(&km, &i__4, &q__1, &ab[kv + 2 + jj * ab_dim1],
+ &c__1, &ab[kv + (jj + 1) * ab_dim1], &i__5, &
+ ab[kv + 1 + (jj + 1) * ab_dim1], &i__6);
+ }
+ } else {
+
+/* If pivot is zero, set INFO to the index of the pivot */
+/* unless a zero pivot has already been found. */
+
+ if (*info == 0) {
+ *info = jj;
+ }
+ }
+
+/* Copy current column of A31 into the work array WORK31 */
+
+/* Computing MIN */
+ i__4 = jj - j + 1;
+ nw = min(i__4,i3);
+ if (nw > 0) {
+ ccopy_(&nw, &ab[kv + *kl + 1 - jj + j + jj * ab_dim1], &
+ c__1, &work31[(jj - j + 1) * 65 - 65], &c__1);
+ }
+/* L80: */
+ }
+ if (j + jb <= *n) {
+
+/* Apply the row interchanges to the other blocks. */
+
+/* Computing MIN */
+ i__3 = ju - j + 1;
+ j2 = min(i__3,kv) - jb;
+/* Computing MAX */
+ i__3 = 0, i__4 = ju - j - kv + 1;
+ j3 = max(i__3,i__4);
+
+/* Use CLASWP to apply the row interchanges to A12, A22, and */
+/* A32. */
+
+ i__3 = *ldab - 1;
+ claswp_(&j2, &ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__3, &
+ c__1, &jb, &ipiv[j], &c__1);
+
+/* Adjust the pivot indices. */
+
+ i__3 = j + jb - 1;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ ipiv[i__] = ipiv[i__] + j - 1;
+/* L90: */
+ }
+
+/* Apply the row interchanges to A13, A23, and A33 */
+/* columnwise. */
+
+ k2 = j - 1 + jb + j2;
+ i__3 = j3;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ jj = k2 + i__;
+ i__4 = j + jb - 1;
+ for (ii = j + i__ - 1; ii <= i__4; ++ii) {
+ ip = ipiv[ii];
+ if (ip != ii) {
+ i__5 = kv + 1 + ii - jj + jj * ab_dim1;
+ temp.r = ab[i__5].r, temp.i = ab[i__5].i;
+ i__5 = kv + 1 + ii - jj + jj * ab_dim1;
+ i__6 = kv + 1 + ip - jj + jj * ab_dim1;
+ ab[i__5].r = ab[i__6].r, ab[i__5].i = ab[i__6].i;
+ i__5 = kv + 1 + ip - jj + jj * ab_dim1;
+ ab[i__5].r = temp.r, ab[i__5].i = temp.i;
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+
+/* Update the relevant part of the trailing submatrix */
+
+ if (j2 > 0) {
+
+/* Update A12 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ ctrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j2,
+ &c_b1, &ab[kv + 1 + j * ab_dim1], &i__3, &ab[kv +
+ 1 - jb + (j + jb) * ab_dim1], &i__4);
+
+ if (i2 > 0) {
+
+/* Update A22 */
+
+ q__1.r = -1.f, q__1.i = -0.f;
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ i__5 = *ldab - 1;
+ cgemm_("No transpose", "No transpose", &i2, &j2, &jb,
+ &q__1, &ab[kv + 1 + jb + j * ab_dim1], &i__3,
+ &ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__4,
+ &c_b1, &ab[kv + 1 + (j + jb) * ab_dim1], &
+ i__5);
+ }
+
+ if (i3 > 0) {
+
+/* Update A32 */
+
+ q__1.r = -1.f, q__1.i = -0.f;
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ cgemm_("No transpose", "No transpose", &i3, &j2, &jb,
+ &q__1, work31, &c__65, &ab[kv + 1 - jb + (j +
+ jb) * ab_dim1], &i__3, &c_b1, &ab[kv + *kl +
+ 1 - jb + (j + jb) * ab_dim1], &i__4);
+ }
+ }
+
+ if (j3 > 0) {
+
+/* Copy the lower triangle of A13 into the work array */
+/* WORK13 */
+
+ i__3 = j3;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = jb;
+ for (ii = jj; ii <= i__4; ++ii) {
+ i__5 = ii + jj * 65 - 66;
+ i__6 = ii - jj + 1 + (jj + j + kv - 1) * ab_dim1;
+ work13[i__5].r = ab[i__6].r, work13[i__5].i = ab[
+ i__6].i;
+/* L120: */
+ }
+/* L130: */
+ }
+
+/* Update A13 in the work array */
+
+ i__3 = *ldab - 1;
+ ctrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j3,
+ &c_b1, &ab[kv + 1 + j * ab_dim1], &i__3, work13, &
+ c__65);
+
+ if (i2 > 0) {
+
+/* Update A23 */
+
+ q__1.r = -1.f, q__1.i = -0.f;
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ cgemm_("No transpose", "No transpose", &i2, &j3, &jb,
+ &q__1, &ab[kv + 1 + jb + j * ab_dim1], &i__3,
+ work13, &c__65, &c_b1, &ab[jb + 1 + (j + kv) *
+ ab_dim1], &i__4);
+ }
+
+ if (i3 > 0) {
+
+/* Update A33 */
+
+ q__1.r = -1.f, q__1.i = -0.f;
+ i__3 = *ldab - 1;
+ cgemm_("No transpose", "No transpose", &i3, &j3, &jb,
+ &q__1, work31, &c__65, work13, &c__65, &c_b1,
+ &ab[*kl + 1 + (j + kv) * ab_dim1], &i__3);
+ }
+
+/* Copy the lower triangle of A13 back into place */
+
+ i__3 = j3;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = jb;
+ for (ii = jj; ii <= i__4; ++ii) {
+ i__5 = ii - jj + 1 + (jj + j + kv - 1) * ab_dim1;
+ i__6 = ii + jj * 65 - 66;
+ ab[i__5].r = work13[i__6].r, ab[i__5].i = work13[
+ i__6].i;
+/* L140: */
+ }
+/* L150: */
+ }
+ }
+ } else {
+
+/* Adjust the pivot indices. */
+
+ i__3 = j + jb - 1;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ ipiv[i__] = ipiv[i__] + j - 1;
+/* L160: */
+ }
+ }
+
+/* Partially undo the interchanges in the current block to */
+/* restore the upper triangular form of A31 and copy the upper */
+/* triangle of A31 back into place */
+
+ i__3 = j;
+ for (jj = j + jb - 1; jj >= i__3; --jj) {
+ jp = ipiv[jj] - jj + 1;
+ if (jp != 1) {
+
+/* Apply interchange to columns J to JJ-1 */
+
+ if (jp + jj - 1 < j + *kl) {
+
+/* The interchange does not affect A31 */
+
+ i__4 = jj - j;
+ i__5 = *ldab - 1;
+ i__6 = *ldab - 1;
+ cswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], &
+ i__5, &ab[kv + jp + jj - j + j * ab_dim1], &
+ i__6);
+ } else {
+
+/* The interchange does affect A31 */
+
+ i__4 = jj - j;
+ i__5 = *ldab - 1;
+ cswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], &
+ i__5, &work31[jp + jj - j - *kl - 1], &c__65);
+ }
+ }
+
+/* Copy the current column of A31 back into place */
+
+/* Computing MIN */
+ i__4 = i3, i__5 = jj - j + 1;
+ nw = min(i__4,i__5);
+ if (nw > 0) {
+ ccopy_(&nw, &work31[(jj - j + 1) * 65 - 65], &c__1, &ab[
+ kv + *kl + 1 - jj + j + jj * ab_dim1], &c__1);
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+
+ return 0;
+
+/* End of CGBTRF */
+
+} /* cgbtrf_ */
diff --git a/SRC/cgbtrs.c b/SRC/cgbtrs.c
new file mode 100644
index 0000000..358ed1a
--- /dev/null
+++ b/SRC/cgbtrs.c
@@ -0,0 +1,281 @@
+/* cgbtrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cgbtrs_(char *trans, integer *n, integer *kl, integer *
+ ku, integer *nrhs, complex *ab, integer *ldab, integer *ipiv, complex
+ *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1, i__2, i__3;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j, l, kd, lm;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *), cgeru_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *),
+ cswap_(integer *, complex *, integer *, complex *, integer *),
+ ctbsv_(char *, char *, char *, integer *, integer *, complex *,
+ integer *, complex *, integer *);
+ logical lnoti;
+ extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
+ xerbla_(char *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGBTRS solves a system of linear equations */
+/* A * X = B, A**T * X = B, or A**H * X = B */
+/* with a general band matrix A using the LU factorization computed */
+/* by CGBTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by CGBTRF. U is stored as an upper triangular band */
+/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
+/* the multipliers used during the factorization are stored in */
+/* rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= N, row i of the matrix was */
+/* interchanged with row IPIV(i). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*ldab < (*kl << 1) + *ku + 1) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGBTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ kd = *ku + *kl + 1;
+ lnoti = *kl > 0;
+
+ if (notran) {
+
+/* Solve A*X = B. */
+
+/* Solve L*X = B, overwriting B with X. */
+
+/* L is represented as a product of permutations and unit lower */
+/* triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), */
+/* where each transformation L(i) is a rank-one modification of */
+/* the identity matrix. */
+
+ if (lnoti) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *kl, i__3 = *n - j;
+ lm = min(i__2,i__3);
+ l = ipiv[j];
+ if (l != j) {
+ cswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb);
+ }
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&lm, nrhs, &q__1, &ab[kd + 1 + j * ab_dim1], &c__1, &b[
+ j + b_dim1], ldb, &b[j + 1 + b_dim1], ldb);
+/* L10: */
+ }
+ }
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Solve U*X = B, overwriting B with X. */
+
+ i__2 = *kl + *ku;
+ ctbsv_("Upper", "No transpose", "Non-unit", n, &i__2, &ab[
+ ab_offset], ldab, &b[i__ * b_dim1 + 1], &c__1);
+/* L20: */
+ }
+
+ } else if (lsame_(trans, "T")) {
+
+/* Solve A**T * X = B. */
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Solve U**T * X = B, overwriting B with X. */
+
+ i__2 = *kl + *ku;
+ ctbsv_("Upper", "Transpose", "Non-unit", n, &i__2, &ab[ab_offset],
+ ldab, &b[i__ * b_dim1 + 1], &c__1);
+/* L30: */
+ }
+
+/* Solve L**T * X = B, overwriting B with X. */
+
+ if (lnoti) {
+ for (j = *n - 1; j >= 1; --j) {
+/* Computing MIN */
+ i__1 = *kl, i__2 = *n - j;
+ lm = min(i__1,i__2);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Transpose", &lm, nrhs, &q__1, &b[j + 1 + b_dim1], ldb,
+ &ab[kd + 1 + j * ab_dim1], &c__1, &c_b1, &b[j +
+ b_dim1], ldb);
+ l = ipiv[j];
+ if (l != j) {
+ cswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb);
+ }
+/* L40: */
+ }
+ }
+
+ } else {
+
+/* Solve A**H * X = B. */
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Solve U**H * X = B, overwriting B with X. */
+
+ i__2 = *kl + *ku;
+ ctbsv_("Upper", "Conjugate transpose", "Non-unit", n, &i__2, &ab[
+ ab_offset], ldab, &b[i__ * b_dim1 + 1], &c__1);
+/* L50: */
+ }
+
+/* Solve L**H * X = B, overwriting B with X. */
+
+ if (lnoti) {
+ for (j = *n - 1; j >= 1; --j) {
+/* Computing MIN */
+ i__1 = *kl, i__2 = *n - j;
+ lm = min(i__1,i__2);
+ clacgv_(nrhs, &b[j + b_dim1], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Conjugate transpose", &lm, nrhs, &q__1, &b[j + 1 +
+ b_dim1], ldb, &ab[kd + 1 + j * ab_dim1], &c__1, &c_b1,
+ &b[j + b_dim1], ldb);
+ clacgv_(nrhs, &b[j + b_dim1], ldb);
+ l = ipiv[j];
+ if (l != j) {
+ cswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb);
+ }
+/* L60: */
+ }
+ }
+ }
+ return 0;
+
+/* End of CGBTRS */
+
+} /* cgbtrs_ */
diff --git a/SRC/cgebak.c b/SRC/cgebak.c
new file mode 100644
index 0000000..d84eacb
--- /dev/null
+++ b/SRC/cgebak.c
@@ -0,0 +1,236 @@
+/* cgebak.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cgebak_(char *job, char *side, integer *n, integer *ilo,
+ integer *ihi, real *scale, integer *m, complex *v, integer *ldv,
+ integer *info)
+{
+ /* System generated locals */
+ integer v_dim1, v_offset, i__1;
+
+ /* Local variables */
+ integer i__, k;
+ real s;
+ integer ii;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ logical leftv;
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), xerbla_(char *, integer *);
+ logical rightv;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGEBAK forms the right or left eigenvectors of a complex general */
+/* matrix by backward transformation on the computed eigenvectors of the */
+/* balanced matrix output by CGEBAL. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies the type of backward transformation required: */
+/* = 'N', do nothing, return immediately; */
+/* = 'P', do backward transformation for permutation only; */
+/* = 'S', do backward transformation for scaling only; */
+/* = 'B', do backward transformations for both permutation and */
+/* scaling. */
+/* JOB must be the same as the argument JOB supplied to CGEBAL. */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'R': V contains right eigenvectors; */
+/* = 'L': V contains left eigenvectors. */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrix V. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* The integers ILO and IHI determined by CGEBAL. */
+/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
+
+/* SCALE (input) REAL array, dimension (N) */
+/* Details of the permutation and scaling factors, as returned */
+/* by CGEBAL. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix V. M >= 0. */
+
+/* V (input/output) COMPLEX array, dimension (LDV,M) */
+/* On entry, the matrix of right or left eigenvectors to be */
+/* transformed, as returned by CHSEIN or CTREVC. */
+/* On exit, V is overwritten by the transformed eigenvectors. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. LDV >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and Test the input parameters */
+
+ /* Parameter adjustments */
+ --scale;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+
+ /* Function Body */
+ rightv = lsame_(side, "R");
+ leftv = lsame_(side, "L");
+
+ *info = 0;
+ if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
+ && ! lsame_(job, "B")) {
+ *info = -1;
+ } else if (! rightv && ! leftv) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ilo < 1 || *ilo > max(1,*n)) {
+ *info = -4;
+ } else if (*ihi < min(*ilo,*n) || *ihi > *n) {
+ *info = -5;
+ } else if (*m < 0) {
+ *info = -7;
+ } else if (*ldv < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGEBAK", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+ if (*m == 0) {
+ return 0;
+ }
+ if (lsame_(job, "N")) {
+ return 0;
+ }
+
+ if (*ilo == *ihi) {
+ goto L30;
+ }
+
+/* Backward balance */
+
+ if (lsame_(job, "S") || lsame_(job, "B")) {
+
+ if (rightv) {
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ s = scale[i__];
+ csscal_(m, &s, &v[i__ + v_dim1], ldv);
+/* L10: */
+ }
+ }
+
+ if (leftv) {
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ s = 1.f / scale[i__];
+ csscal_(m, &s, &v[i__ + v_dim1], ldv);
+/* L20: */
+ }
+ }
+
+ }
+
+/* Backward permutation */
+
+/* For I = ILO-1 step -1 until 1, */
+/* IHI+1 step 1 until N do -- */
+
+L30:
+ if (lsame_(job, "P") || lsame_(job, "B")) {
+ if (rightv) {
+ i__1 = *n;
+ for (ii = 1; ii <= i__1; ++ii) {
+ i__ = ii;
+ if (i__ >= *ilo && i__ <= *ihi) {
+ goto L40;
+ }
+ if (i__ < *ilo) {
+ i__ = *ilo - ii;
+ }
+ k = scale[i__];
+ if (k == i__) {
+ goto L40;
+ }
+ cswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L40:
+ ;
+ }
+ }
+
+ if (leftv) {
+ i__1 = *n;
+ for (ii = 1; ii <= i__1; ++ii) {
+ i__ = ii;
+ if (i__ >= *ilo && i__ <= *ihi) {
+ goto L50;
+ }
+ if (i__ < *ilo) {
+ i__ = *ilo - ii;
+ }
+ k = scale[i__];
+ if (k == i__) {
+ goto L50;
+ }
+ cswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L50:
+ ;
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CGEBAK */
+
+} /* cgebak_ */
diff --git a/SRC/cgebal.c b/SRC/cgebal.c
new file mode 100644
index 0000000..435e9a7
--- /dev/null
+++ b/SRC/cgebal.c
@@ -0,0 +1,414 @@
+/* cgebal.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cgebal_(char *job, integer *n, complex *a, integer *lda,
+ integer *ilo, integer *ihi, real *scale, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double r_imag(complex *), c_abs(complex *);
+
+ /* Local variables */
+ real c__, f, g;
+ integer i__, j, k, l, m;
+ real r__, s, ca, ra;
+ integer ica, ira, iexc;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ real sfmin1, sfmin2, sfmax1, sfmax2;
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), xerbla_(char *, integer *);
+ logical noconv;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGEBAL balances a general complex matrix A. This involves, first, */
+/* permuting A by a similarity transformation to isolate eigenvalues */
+/* in the first 1 to ILO-1 and last IHI+1 to N elements on the */
+/* diagonal; and second, applying a diagonal similarity transformation */
+/* to rows and columns ILO to IHI to make the rows and columns as */
+/* close in norm as possible. Both steps are optional. */
+
+/* Balancing may reduce the 1-norm of the matrix, and improve the */
+/* accuracy of the computed eigenvalues and/or eigenvectors. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies the operations to be performed on A: */
+/* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 */
+/* for i = 1,...,N; */
+/* = 'P': permute only; */
+/* = 'S': scale only; */
+/* = 'B': both permute and scale. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the input matrix A. */
+/* On exit, A is overwritten by the balanced matrix. */
+/* If JOB = 'N', A is not referenced. */
+/* See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* ILO (output) INTEGER */
+/* IHI (output) INTEGER */
+/* ILO and IHI are set to integers such that on exit */
+/* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. */
+/* If JOB = 'N' or 'S', ILO = 1 and IHI = N. */
+
+/* SCALE (output) REAL array, dimension (N) */
+/* Details of the permutations and scaling factors applied to */
+/* A. If P(j) is the index of the row and column interchanged */
+/* with row and column j and D(j) is the scaling factor */
+/* applied to row and column j, then */
+/* SCALE(j) = P(j) for j = 1,...,ILO-1 */
+/* = D(j) for j = ILO,...,IHI */
+/* = P(j) for j = IHI+1,...,N. */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The permutations consist of row and column interchanges which put */
+/* the matrix in the form */
+
+/* ( T1 X Y ) */
+/* P A P = ( 0 B Z ) */
+/* ( 0 0 T2 ) */
+
+/* where T1 and T2 are upper triangular matrices whose eigenvalues lie */
+/* along the diagonal. The column indices ILO and IHI mark the starting */
+/* and ending columns of the submatrix B. Balancing consists of applying */
+/* a diagonal similarity transformation inv(D) * B * D to make the */
+/* 1-norms of each row of B and its corresponding column nearly equal. */
+/* The output matrix is */
+
+/* ( T1 X*D Y ) */
+/* ( 0 inv(D)*B*D inv(D)*Z ). */
+/* ( 0 0 T2 ) */
+
+/* Information about the permutations P and the diagonal matrix D is */
+/* returned in the vector SCALE. */
+
+/* This subroutine is based on the EISPACK routine CBAL. */
+
+/* Modified by Tzu-Yi Chen, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --scale;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
+ && ! lsame_(job, "B")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGEBAL", &i__1);
+ return 0;
+ }
+
+ k = 1;
+ l = *n;
+
+ if (*n == 0) {
+ goto L210;
+ }
+
+ if (lsame_(job, "N")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ scale[i__] = 1.f;
+/* L10: */
+ }
+ goto L210;
+ }
+
+ if (lsame_(job, "S")) {
+ goto L120;
+ }
+
+/* Permutation to isolate eigenvalues if possible */
+
+ goto L50;
+
+/* Row and column exchange. */
+
+L20:
+ scale[m] = (real) j;
+ if (j == m) {
+ goto L30;
+ }
+
+ cswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
+ i__1 = *n - k + 1;
+ cswap_(&i__1, &a[j + k * a_dim1], lda, &a[m + k * a_dim1], lda);
+
+L30:
+ switch (iexc) {
+ case 1: goto L40;
+ case 2: goto L80;
+ }
+
+/* Search for rows isolating an eigenvalue and push them down. */
+
+L40:
+ if (l == 1) {
+ goto L210;
+ }
+ --l;
+
+L50:
+ for (j = l; j >= 1; --j) {
+
+ i__1 = l;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (i__ == j) {
+ goto L60;
+ }
+ i__2 = j + i__ * a_dim1;
+ if (a[i__2].r != 0.f || r_imag(&a[j + i__ * a_dim1]) != 0.f) {
+ goto L70;
+ }
+L60:
+ ;
+ }
+
+ m = l;
+ iexc = 1;
+ goto L20;
+L70:
+ ;
+ }
+
+ goto L90;
+
+/* Search for columns isolating an eigenvalue and push them left. */
+
+L80:
+ ++k;
+
+L90:
+ i__1 = l;
+ for (j = k; j <= i__1; ++j) {
+
+ i__2 = l;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ if (i__ == j) {
+ goto L100;
+ }
+ i__3 = i__ + j * a_dim1;
+ if (a[i__3].r != 0.f || r_imag(&a[i__ + j * a_dim1]) != 0.f) {
+ goto L110;
+ }
+L100:
+ ;
+ }
+
+ m = k;
+ iexc = 2;
+ goto L20;
+L110:
+ ;
+ }
+
+L120:
+ i__1 = l;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ scale[i__] = 1.f;
+/* L130: */
+ }
+
+ if (lsame_(job, "P")) {
+ goto L210;
+ }
+
+/* Balance the submatrix in rows K to L. */
+
+/* Iterative loop for norm reduction */
+
+ sfmin1 = slamch_("S") / slamch_("P");
+ sfmax1 = 1.f / sfmin1;
+ sfmin2 = sfmin1 * 2.f;
+ sfmax2 = 1.f / sfmin2;
+L140:
+ noconv = FALSE_;
+
+ i__1 = l;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ c__ = 0.f;
+ r__ = 0.f;
+
+ i__2 = l;
+ for (j = k; j <= i__2; ++j) {
+ if (j == i__) {
+ goto L150;
+ }
+ i__3 = j + i__ * a_dim1;
+ c__ += (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[j + i__
+ * a_dim1]), dabs(r__2));
+ i__3 = i__ + j * a_dim1;
+ r__ += (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[i__ + j
+ * a_dim1]), dabs(r__2));
+L150:
+ ;
+ }
+ ica = icamax_(&l, &a[i__ * a_dim1 + 1], &c__1);
+ ca = c_abs(&a[ica + i__ * a_dim1]);
+ i__2 = *n - k + 1;
+ ira = icamax_(&i__2, &a[i__ + k * a_dim1], lda);
+ ra = c_abs(&a[i__ + (ira + k - 1) * a_dim1]);
+
+/* Guard against zero C or R due to underflow. */
+
+ if (c__ == 0.f || r__ == 0.f) {
+ goto L200;
+ }
+ g = r__ / 2.f;
+ f = 1.f;
+ s = c__ + r__;
+L160:
+/* Computing MAX */
+ r__1 = max(f,c__);
+/* Computing MIN */
+ r__2 = min(r__,g);
+ if (c__ >= g || dmax(r__1,ca) >= sfmax2 || dmin(r__2,ra) <= sfmin2) {
+ goto L170;
+ }
+ f *= 2.f;
+ c__ *= 2.f;
+ ca *= 2.f;
+ r__ /= 2.f;
+ g /= 2.f;
+ ra /= 2.f;
+ goto L160;
+
+L170:
+ g = c__ / 2.f;
+L180:
+/* Computing MIN */
+ r__1 = min(f,c__), r__1 = min(r__1,g);
+ if (g < r__ || dmax(r__,ra) >= sfmax2 || dmin(r__1,ca) <= sfmin2) {
+ goto L190;
+ }
+ f /= 2.f;
+ c__ /= 2.f;
+ g /= 2.f;
+ ca /= 2.f;
+ r__ *= 2.f;
+ ra *= 2.f;
+ goto L180;
+
+/* Now balance. */
+
+L190:
+ if (c__ + r__ >= s * .95f) {
+ goto L200;
+ }
+ if (f < 1.f && scale[i__] < 1.f) {
+ if (f * scale[i__] <= sfmin1) {
+ goto L200;
+ }
+ }
+ if (f > 1.f && scale[i__] > 1.f) {
+ if (scale[i__] >= sfmax1 / f) {
+ goto L200;
+ }
+ }
+ g = 1.f / f;
+ scale[i__] *= f;
+ noconv = TRUE_;
+
+ i__2 = *n - k + 1;
+ csscal_(&i__2, &g, &a[i__ + k * a_dim1], lda);
+ csscal_(&l, &f, &a[i__ * a_dim1 + 1], &c__1);
+
+L200:
+ ;
+ }
+
+ if (noconv) {
+ goto L140;
+ }
+
+L210:
+ *ilo = k;
+ *ihi = l;
+
+ return 0;
+
+/* End of CGEBAL */
+
+} /* cgebal_ */
diff --git a/SRC/cgebd2.c b/SRC/cgebd2.c
new file mode 100644
index 0000000..0b30141
--- /dev/null
+++ b/SRC/cgebd2.c
@@ -0,0 +1,345 @@
+/* cgebd2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cgebd2_(integer *m, integer *n, complex *a, integer *lda,
+ real *d__, real *e, complex *tauq, complex *taup, complex *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ complex q__1;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__;
+ complex alpha;
+ extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
+, integer *, complex *, complex *, integer *, complex *),
+ clarfg_(integer *, complex *, complex *, integer *, complex *),
+ clacgv_(integer *, complex *, integer *), xerbla_(char *, integer
+ *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGEBD2 reduces a complex general m by n matrix A to upper or lower */
+/* real bidiagonal form B by a unitary transformation: Q' * A * P = B. */
+
+/* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows in the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns in the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the m by n general matrix to be reduced. */
+/* On exit, */
+/* if m >= n, the diagonal and the first superdiagonal are */
+/* overwritten with the upper bidiagonal matrix B; the */
+/* elements below the diagonal, with the array TAUQ, represent */
+/* the unitary matrix Q as a product of elementary */
+/* reflectors, and the elements above the first superdiagonal, */
+/* with the array TAUP, represent the unitary matrix P as */
+/* a product of elementary reflectors; */
+/* if m < n, the diagonal and the first subdiagonal are */
+/* overwritten with the lower bidiagonal matrix B; the */
+/* elements below the first subdiagonal, with the array TAUQ, */
+/* represent the unitary matrix Q as a product of */
+/* elementary reflectors, and the elements above the diagonal, */
+/* with the array TAUP, represent the unitary matrix P as */
+/* a product of elementary reflectors. */
+/* See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* D (output) REAL array, dimension (min(M,N)) */
+/* The diagonal elements of the bidiagonal matrix B: */
+/* D(i) = A(i,i). */
+
+/* E (output) REAL array, dimension (min(M,N)-1) */
+/* The off-diagonal elements of the bidiagonal matrix B: */
+/* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */
+/* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */
+
+/* TAUQ (output) COMPLEX array dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the unitary matrix Q. See Further Details. */
+
+/* TAUP (output) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the unitary matrix P. See Further Details. */
+
+/* WORK (workspace) COMPLEX array, dimension (max(M,N)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrices Q and P are represented as products of elementary */
+/* reflectors: */
+
+/* If m >= n, */
+
+/* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) */
+
+/* Each H(i) and G(i) has the form: */
+
+/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
+
+/* where tauq and taup are complex scalars, and v and u are complex */
+/* vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in */
+/* A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in */
+/* A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* If m < n, */
+
+/* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) */
+
+/* Each H(i) and G(i) has the form: */
+
+/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
+
+/* where tauq and taup are complex scalars, v and u are complex vectors; */
+/* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); */
+/* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); */
+/* tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* The contents of A on exit are illustrated by the following examples: */
+
+/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
+
+/* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) */
+/* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) */
+/* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) */
+/* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) */
+/* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) */
+/* ( v1 v2 v3 v4 v5 ) */
+
+/* where d and e denote diagonal and off-diagonal elements of B, vi */
+/* denotes an element of the vector defining H(i), and ui an element of */
+/* the vector defining G(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ --tauq;
+ --taup;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("CGEBD2", &i__1);
+ return 0;
+ }
+
+ if (*m >= *n) {
+
+/* Reduce to upper bidiagonal form */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
+
+ i__2 = i__ + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *m - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ clarfg_(&i__2, &alpha, &a[min(i__3, *m)+ i__ * a_dim1], &c__1, &
+ tauq[i__]);
+ i__2 = i__;
+ d__[i__2] = alpha.r;
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+
+/* Apply H(i)' to A(i:m,i+1:n) from the left */
+
+ if (i__ < *n) {
+ i__2 = *m - i__ + 1;
+ i__3 = *n - i__;
+ r_cnjg(&q__1, &tauq[i__]);
+ clarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
+ q__1, &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
+ }
+ i__2 = i__ + i__ * a_dim1;
+ i__3 = i__;
+ a[i__2].r = d__[i__3], a[i__2].i = 0.f;
+
+ if (i__ < *n) {
+
+/* Generate elementary reflector G(i) to annihilate */
+/* A(i,i+2:n) */
+
+ i__2 = *n - i__;
+ clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
+ i__2 = i__ + (i__ + 1) * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *n - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ clarfg_(&i__2, &alpha, &a[i__ + min(i__3, *n)* a_dim1], lda, &
+ taup[i__]);
+ i__2 = i__;
+ e[i__2] = alpha.r;
+ i__2 = i__ + (i__ + 1) * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+
+/* Apply G(i) to A(i+1:m,i+1:n) from the right */
+
+ i__2 = *m - i__;
+ i__3 = *n - i__;
+ clarf_("Right", &i__2, &i__3, &a[i__ + (i__ + 1) * a_dim1],
+ lda, &taup[i__], &a[i__ + 1 + (i__ + 1) * a_dim1],
+ lda, &work[1]);
+ i__2 = *n - i__;
+ clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
+ i__2 = i__ + (i__ + 1) * a_dim1;
+ i__3 = i__;
+ a[i__2].r = e[i__3], a[i__2].i = 0.f;
+ } else {
+ i__2 = i__;
+ taup[i__2].r = 0.f, taup[i__2].i = 0.f;
+ }
+/* L10: */
+ }
+ } else {
+
+/* Reduce to lower bidiagonal form */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Generate elementary reflector G(i) to annihilate A(i,i+1:n) */
+
+ i__2 = *n - i__ + 1;
+ clacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
+ i__2 = i__ + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *n - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ clarfg_(&i__2, &alpha, &a[i__ + min(i__3, *n)* a_dim1], lda, &
+ taup[i__]);
+ i__2 = i__;
+ d__[i__2] = alpha.r;
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+
+/* Apply G(i) to A(i+1:m,i:n) from the right */
+
+ if (i__ < *m) {
+ i__2 = *m - i__;
+ i__3 = *n - i__ + 1;
+ clarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &
+ taup[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]);
+ }
+ i__2 = *n - i__ + 1;
+ clacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
+ i__2 = i__ + i__ * a_dim1;
+ i__3 = i__;
+ a[i__2].r = d__[i__3], a[i__2].i = 0.f;
+
+ if (i__ < *m) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* A(i+2:m,i) */
+
+ i__2 = i__ + 1 + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *m - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ clarfg_(&i__2, &alpha, &a[min(i__3, *m)+ i__ * a_dim1], &c__1,
+ &tauq[i__]);
+ i__2 = i__;
+ e[i__2] = alpha.r;
+ i__2 = i__ + 1 + i__ * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+
+/* Apply H(i)' to A(i+1:m,i+1:n) from the left */
+
+ i__2 = *m - i__;
+ i__3 = *n - i__;
+ r_cnjg(&q__1, &tauq[i__]);
+ clarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &
+ c__1, &q__1, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &
+ work[1]);
+ i__2 = i__ + 1 + i__ * a_dim1;
+ i__3 = i__;
+ a[i__2].r = e[i__3], a[i__2].i = 0.f;
+ } else {
+ i__2 = i__;
+ tauq[i__2].r = 0.f, tauq[i__2].i = 0.f;
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+/* End of CGEBD2 */
+
+} /* cgebd2_ */
diff --git a/SRC/cgebrd.c b/SRC/cgebrd.c
new file mode 100644
index 0000000..8e8e753
--- /dev/null
+++ b/SRC/cgebrd.c
@@ -0,0 +1,348 @@
+/* cgebrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int cgebrd_(integer *m, integer *n, complex *a, integer *lda,
+ real *d__, real *e, complex *tauq, complex *taup, complex *work,
+ integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j, nb, nx;
+ real ws;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ integer nbmin, iinfo, minmn;
+ extern /* Subroutine */ int cgebd2_(integer *, integer *, complex *,
+ integer *, real *, real *, complex *, complex *, complex *,
+ integer *), clabrd_(integer *, integer *, integer *, complex *,
+ integer *, real *, real *, complex *, complex *, complex *,
+ integer *, complex *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwrkx, ldwrky, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGEBRD reduces a general complex M-by-N matrix A to upper or lower */
+/* bidiagonal form B by a unitary transformation: Q**H * A * P = B. */
+
+/* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows in the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns in the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N general matrix to be reduced. */
+/* On exit, */
+/* if m >= n, the diagonal and the first superdiagonal are */
+/* overwritten with the upper bidiagonal matrix B; the */
+/* elements below the diagonal, with the array TAUQ, represent */
+/* the unitary matrix Q as a product of elementary */
+/* reflectors, and the elements above the first superdiagonal, */
+/* with the array TAUP, represent the unitary matrix P as */
+/* a product of elementary reflectors; */
+/* if m < n, the diagonal and the first subdiagonal are */
+/* overwritten with the lower bidiagonal matrix B; the */
+/* elements below the first subdiagonal, with the array TAUQ, */
+/* represent the unitary matrix Q as a product of */
+/* elementary reflectors, and the elements above the diagonal, */
+/* with the array TAUP, represent the unitary matrix P as */
+/* a product of elementary reflectors. */
+/* See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* D (output) REAL array, dimension (min(M,N)) */
+/* The diagonal elements of the bidiagonal matrix B: */
+/* D(i) = A(i,i). */
+
+/* E (output) REAL array, dimension (min(M,N)-1) */
+/* The off-diagonal elements of the bidiagonal matrix B: */
+/* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */
+/* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */
+
+/* TAUQ (output) COMPLEX array dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the unitary matrix Q. See Further Details. */
+
+/* TAUP (output) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the unitary matrix P. See Further Details. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(1,M,N). */
+/* For optimum performance LWORK >= (M+N)*NB, where NB */
+/* is the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrices Q and P are represented as products of elementary */
+/* reflectors: */
+
+/* If m >= n, */
+
+/* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) */
+
+/* Each H(i) and G(i) has the form: */
+
+/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
+
+/* where tauq and taup are complex scalars, and v and u are complex */
+/* vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in */
+/* A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in */
+/* A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* If m < n, */
+
+/* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) */
+
+/* Each H(i) and G(i) has the form: */
+
+/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
+
+/* where tauq and taup are complex scalars, and v and u are complex */
+/* vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in */
+/* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in */
+/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* The contents of A on exit are illustrated by the following examples: */
+
+/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
+
+/* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) */
+/* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) */
+/* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) */
+/* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) */
+/* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) */
+/* ( v1 v2 v3 v4 v5 ) */
+
+/* where d and e denote diagonal and off-diagonal elements of B, vi */
+/* denotes an element of the vector defining H(i), and ui an element of */
+/* the vector defining G(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ --tauq;
+ --taup;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+/* Computing MAX */
+ i__1 = 1, i__2 = ilaenv_(&c__1, "CGEBRD", " ", m, n, &c_n1, &c_n1);
+ nb = max(i__1,i__2);
+ lwkopt = (*m + *n) * nb;
+ r__1 = (real) lwkopt;
+ work[1].r = r__1, work[1].i = 0.f;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ if (*lwork < max(i__1,*n) && ! lquery) {
+ *info = -10;
+ }
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("CGEBRD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ minmn = min(*m,*n);
+ if (minmn == 0) {
+ work[1].r = 1.f, work[1].i = 0.f;
+ return 0;
+ }
+
+ ws = (real) max(*m,*n);
+ ldwrkx = *m;
+ ldwrky = *n;
+
+ if (nb > 1 && nb < minmn) {
+
+/* Set the crossover point NX. */
+
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__3, "CGEBRD", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+
+/* Determine when to switch from blocked to unblocked code. */
+
+ if (nx < minmn) {
+ ws = (real) ((*m + *n) * nb);
+ if ((real) (*lwork) < ws) {
+
+/* Not enough work space for the optimal NB, consider using */
+/* a smaller block size. */
+
+ nbmin = ilaenv_(&c__2, "CGEBRD", " ", m, n, &c_n1, &c_n1);
+ if (*lwork >= (*m + *n) * nbmin) {
+ nb = *lwork / (*m + *n);
+ } else {
+ nb = 1;
+ nx = minmn;
+ }
+ }
+ }
+ } else {
+ nx = minmn;
+ }
+
+ i__1 = minmn - nx;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+
+/* Reduce rows and columns i:i+ib-1 to bidiagonal form and return */
+/* the matrices X and Y which are needed to update the unreduced */
+/* part of the matrix */
+
+ i__3 = *m - i__ + 1;
+ i__4 = *n - i__ + 1;
+ clabrd_(&i__3, &i__4, &nb, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[
+ i__], &tauq[i__], &taup[i__], &work[1], &ldwrkx, &work[ldwrkx
+ * nb + 1], &ldwrky);
+
+/* Update the trailing submatrix A(i+ib:m,i+ib:n), using */
+/* an update of the form A := A - V*Y' - X*U' */
+
+ i__3 = *m - i__ - nb + 1;
+ i__4 = *n - i__ - nb + 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "Conjugate transpose", &i__3, &i__4, &nb, &
+ q__1, &a[i__ + nb + i__ * a_dim1], lda, &work[ldwrkx * nb +
+ nb + 1], &ldwrky, &c_b1, &a[i__ + nb + (i__ + nb) * a_dim1],
+ lda);
+ i__3 = *m - i__ - nb + 1;
+ i__4 = *n - i__ - nb + 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "No transpose", &i__3, &i__4, &nb, &q__1, &
+ work[nb + 1], &ldwrkx, &a[i__ + (i__ + nb) * a_dim1], lda, &
+ c_b1, &a[i__ + nb + (i__ + nb) * a_dim1], lda);
+
+/* Copy diagonal and off-diagonal elements of B back into A */
+
+ if (*m >= *n) {
+ i__3 = i__ + nb - 1;
+ for (j = i__; j <= i__3; ++j) {
+ i__4 = j + j * a_dim1;
+ i__5 = j;
+ a[i__4].r = d__[i__5], a[i__4].i = 0.f;
+ i__4 = j + (j + 1) * a_dim1;
+ i__5 = j;
+ a[i__4].r = e[i__5], a[i__4].i = 0.f;
+/* L10: */
+ }
+ } else {
+ i__3 = i__ + nb - 1;
+ for (j = i__; j <= i__3; ++j) {
+ i__4 = j + j * a_dim1;
+ i__5 = j;
+ a[i__4].r = d__[i__5], a[i__4].i = 0.f;
+ i__4 = j + 1 + j * a_dim1;
+ i__5 = j;
+ a[i__4].r = e[i__5], a[i__4].i = 0.f;
+/* L20: */
+ }
+ }
+/* L30: */
+ }
+
+/* Use unblocked code to reduce the remainder of the matrix */
+
+ i__2 = *m - i__ + 1;
+ i__1 = *n - i__ + 1;
+ cgebd2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], &
+ tauq[i__], &taup[i__], &work[1], &iinfo);
+ work[1].r = ws, work[1].i = 0.f;
+ return 0;
+
+/* End of CGEBRD */
+
+} /* cgebrd_ */
diff --git a/SRC/cgecon.c b/SRC/cgecon.c
new file mode 100644
index 0000000..fe9d614
--- /dev/null
+++ b/SRC/cgecon.c
@@ -0,0 +1,233 @@
+/* cgecon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cgecon_(char *norm, integer *n, complex *a, integer *lda,
+ real *anorm, real *rcond, complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ real sl;
+ integer ix;
+ real su;
+ integer kase, kase1;
+ real scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *);
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int clatrs_(char *, char *, char *, char *,
+ integer *, complex *, integer *, complex *, real *, real *,
+ integer *), csrscl_(integer *,
+ real *, complex *, integer *);
+ logical onenrm;
+ char normin[1];
+ real smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGECON estimates the reciprocal of the condition number of a general */
+/* complex matrix A, in either the 1-norm or the infinity-norm, using */
+/* the LU factorization computed by CGETRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as */
+/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The factors L and U from the factorization A = P*L*U */
+/* as computed by CGETRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* ANORM (input) REAL */
+/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */
+/* If NORM = 'I', the infinity-norm of the original matrix A. */
+
+/* RCOND (output) REAL */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*anorm < 0.f) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGECON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.f;
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ } else if (*anorm == 0.f) {
+ return 0;
+ }
+
+ smlnum = slamch_("Safe minimum");
+
+/* Estimate the norm of inv(A). */
+
+ ainvnm = 0.f;
+ *(unsigned char *)normin = 'N';
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kase = 0;
+L10:
+ clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(L). */
+
+ clatrs_("Lower", "No transpose", "Unit", normin, n, &a[a_offset],
+ lda, &work[1], &sl, &rwork[1], info);
+
+/* Multiply by inv(U). */
+
+ clatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[
+ a_offset], lda, &work[1], &su, &rwork[*n + 1], info);
+ } else {
+
+/* Multiply by inv(U'). */
+
+ clatrs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &a[
+ a_offset], lda, &work[1], &su, &rwork[*n + 1], info);
+
+/* Multiply by inv(L'). */
+
+ clatrs_("Lower", "Conjugate transpose", "Unit", normin, n, &a[
+ a_offset], lda, &work[1], &sl, &rwork[1], info);
+ }
+
+/* Divide X by 1/(SL*SU) if doing so will not cause overflow. */
+
+ scale = sl * su;
+ *(unsigned char *)normin = 'Y';
+ if (scale != 1.f) {
+ ix = icamax_(n, &work[1], &c__1);
+ i__1 = ix;
+ if (scale < ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
+ work[ix]), dabs(r__2))) * smlnum || scale == 0.f) {
+ goto L20;
+ }
+ csrscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / ainvnm / *anorm;
+ }
+
+L20:
+ return 0;
+
+/* End of CGECON */
+
+} /* cgecon_ */
diff --git a/SRC/cgeequ.c b/SRC/cgeequ.c
new file mode 100644
index 0000000..84cf694
--- /dev/null
+++ b/SRC/cgeequ.c
@@ -0,0 +1,306 @@
+/* cgeequ.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cgeequ_(integer *m, integer *n, complex *a, integer *lda,
+ real *r__, real *c__, real *rowcnd, real *colcnd, real *amax,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j;
+ real rcmin, rcmax;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum, smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGEEQU computes row and column scalings intended to equilibrate an */
+/* M-by-N matrix A and reduce its condition number. R returns the row */
+/* scale factors and C the column scale factors, chosen to try to make */
+/* the largest element in each row and column of the matrix B with */
+/* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. */
+
+/* R(i) and C(j) are restricted to be between SMLNUM = smallest safe */
+/* number and BIGNUM = largest safe number. Use of these scaling */
+/* factors is not guaranteed to reduce the condition number of A but */
+/* works well in practice. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The M-by-N matrix whose equilibration factors are */
+/* to be computed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* R (output) REAL array, dimension (M) */
+/* If INFO = 0 or INFO > M, R contains the row scale factors */
+/* for A. */
+
+/* C (output) REAL array, dimension (N) */
+/* If INFO = 0, C contains the column scale factors for A. */
+
+/* ROWCND (output) REAL */
+/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */
+/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */
+/* AMAX is neither too large nor too small, it is not worth */
+/* scaling by R. */
+
+/* COLCND (output) REAL */
+/* If INFO = 0, COLCND contains the ratio of the smallest */
+/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */
+/* worth scaling by C. */
+
+/* AMAX (output) REAL */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= M: the i-th row of A is exactly zero */
+/* > M: the (i-M)-th column of A is exactly zero */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGEEQU", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ *rowcnd = 1.f;
+ *colcnd = 1.f;
+ *amax = 0.f;
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+
+/* Compute row scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__[i__] = 0.f;
+/* L10: */
+ }
+
+/* Find the maximum element in each row. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = r__[i__], r__4 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ r__[i__] = dmax(r__3,r__4);
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = rcmax, r__2 = r__[i__];
+ rcmax = dmax(r__1,r__2);
+/* Computing MIN */
+ r__1 = rcmin, r__2 = r__[i__];
+ rcmin = dmin(r__1,r__2);
+/* L40: */
+ }
+ *amax = rcmax;
+
+ if (rcmin == 0.f) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] == 0.f) {
+ *info = i__;
+ return 0;
+ }
+/* L50: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MIN */
+/* Computing MAX */
+ r__2 = r__[i__];
+ r__1 = dmax(r__2,smlnum);
+ r__[i__] = 1.f / dmin(r__1,bignum);
+/* L60: */
+ }
+
+/* Compute ROWCND = min(R(I)) / max(R(I)) */
+
+ *rowcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ }
+
+/* Compute column scale factors */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 0.f;
+/* L70: */
+ }
+
+/* Find the maximum element in each column, */
+/* assuming the row scaling computed above. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = c__[j], r__4 = ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2))) * r__[i__];
+ c__[j] = dmax(r__3,r__4);
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = c__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = c__[j];
+ rcmax = dmax(r__1,r__2);
+/* L100: */
+ }
+
+ if (rcmin == 0.f) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (c__[j] == 0.f) {
+ *info = *m + j;
+ return 0;
+ }
+/* L110: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+/* Computing MAX */
+ r__2 = c__[j];
+ r__1 = dmax(r__2,smlnum);
+ c__[j] = 1.f / dmin(r__1,bignum);
+/* L120: */
+ }
+
+/* Compute COLCND = min(C(J)) / max(C(J)) */
+
+ *colcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ }
+
+ return 0;
+
+/* End of CGEEQU */
+
+} /* cgeequ_ */
diff --git a/SRC/cgeequb.c b/SRC/cgeequb.c
new file mode 100644
index 0000000..93318d0
--- /dev/null
+++ b/SRC/cgeequb.c
@@ -0,0 +1,331 @@
+/* cgeequb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cgeequb_(integer *m, integer *n, complex *a, integer *
+ lda, real *r__, real *c__, real *rowcnd, real *colcnd, real *amax,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ double log(doublereal), r_imag(complex *), pow_ri(real *, integer *);
+
+ /* Local variables */
+ integer i__, j;
+ real radix, rcmin, rcmax;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum, logrdx, smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGEEQUB computes row and column scalings intended to equilibrate an */
+/* M-by-N matrix A and reduce its condition number. R returns the row */
+/* scale factors and C the column scale factors, chosen to try to make */
+/* the largest element in each row and column of the matrix B with */
+/* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most */
+/* the radix. */
+
+/* R(i) and C(j) are restricted to be a power of the radix between */
+/* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use */
+/* of these scaling factors is not guaranteed to reduce the condition */
+/* number of A but works well in practice. */
+
+/* This routine differs from CGEEQU by restricting the scaling factors */
+/* to a power of the radix. Baring over- and underflow, scaling by */
+/* these factors introduces no additional rounding errors. However, the */
+/* scaled entries' magnitured are no longer approximately 1 but lie */
+/* between sqrt(radix) and 1/sqrt(radix). */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The M-by-N matrix whose equilibration factors are */
+/* to be computed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* R (output) REAL array, dimension (M) */
+/* If INFO = 0 or INFO > M, R contains the row scale factors */
+/* for A. */
+
+/* C (output) REAL array, dimension (N) */
+/* If INFO = 0, C contains the column scale factors for A. */
+
+/* ROWCND (output) REAL */
+/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */
+/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */
+/* AMAX is neither too large nor too small, it is not worth */
+/* scaling by R. */
+
+/* COLCND (output) REAL */
+/* If INFO = 0, COLCND contains the ratio of the smallest */
+/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */
+/* worth scaling by C. */
+
+/* AMAX (output) REAL */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= M: the i-th row of A is exactly zero */
+/* > M: the (i-M)-th column of A is exactly zero */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGEEQUB", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ *rowcnd = 1.f;
+ *colcnd = 1.f;
+ *amax = 0.f;
+ return 0;
+ }
+
+/* Get machine constants. Assume SMLNUM is a power of the radix. */
+
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+ radix = slamch_("B");
+ logrdx = log(radix);
+
+/* Compute row scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__[i__] = 0.f;
+/* L10: */
+ }
+
+/* Find the maximum element in each row. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = r__[i__], r__4 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ r__[i__] = dmax(r__3,r__4);
+/* L20: */
+ }
+/* L30: */
+ }
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] > 0.f) {
+ i__2 = (integer) (log(r__[i__]) / logrdx);
+ r__[i__] = pow_ri(&radix, &i__2);
+ }
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = rcmax, r__2 = r__[i__];
+ rcmax = dmax(r__1,r__2);
+/* Computing MIN */
+ r__1 = rcmin, r__2 = r__[i__];
+ rcmin = dmin(r__1,r__2);
+/* L40: */
+ }
+ *amax = rcmax;
+
+ if (rcmin == 0.f) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] == 0.f) {
+ *info = i__;
+ return 0;
+ }
+/* L50: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MIN */
+/* Computing MAX */
+ r__2 = r__[i__];
+ r__1 = dmax(r__2,smlnum);
+ r__[i__] = 1.f / dmin(r__1,bignum);
+/* L60: */
+ }
+
+/* Compute ROWCND = min(R(I)) / max(R(I)). */
+
+ *rowcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ }
+
+/* Compute column scale factors. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 0.f;
+/* L70: */
+ }
+
+/* Find the maximum element in each column, */
+/* assuming the row scaling computed above. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = c__[j], r__4 = ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2))) * r__[i__];
+ c__[j] = dmax(r__3,r__4);
+/* L80: */
+ }
+ if (c__[j] > 0.f) {
+ i__2 = (integer) (log(c__[j]) / logrdx);
+ c__[j] = pow_ri(&radix, &i__2);
+ }
+/* L90: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = c__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = c__[j];
+ rcmax = dmax(r__1,r__2);
+/* L100: */
+ }
+
+ if (rcmin == 0.f) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (c__[j] == 0.f) {
+ *info = *m + j;
+ return 0;
+ }
+/* L110: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+/* Computing MAX */
+ r__2 = c__[j];
+ r__1 = dmax(r__2,smlnum);
+ c__[j] = 1.f / dmin(r__1,bignum);
+/* L120: */
+ }
+
+/* Compute COLCND = min(C(J)) / max(C(J)). */
+
+ *colcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ }
+
+ return 0;
+
+/* End of CGEEQUB */
+
+} /* cgeequb_ */
diff --git a/SRC/cgees.c b/SRC/cgees.c
new file mode 100644
index 0000000..d113eb3
--- /dev/null
+++ b/SRC/cgees.c
@@ -0,0 +1,404 @@
+/* cgees.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cgees_(char *jobvs, char *sort, L_fp select, integer *n,
+ complex *a, integer *lda, integer *sdim, complex *w, complex *vs,
+ integer *ldvs, complex *work, integer *lwork, real *rwork, logical *
+ bwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real s;
+ integer ihi, ilo;
+ real dum[1], eps, sep;
+ integer ibal;
+ real anrm;
+ integer ierr, itau, iwrk, icond, ieval;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), cgebak_(char *, char *, integer *, integer
+ *, integer *, real *, integer *, complex *, integer *, integer *), cgebal_(char *, integer *, complex *, integer *,
+ integer *, integer *, real *, integer *), slabad_(real *,
+ real *);
+ logical scalea;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ real cscale;
+ extern /* Subroutine */ int cgehrd_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *),
+ clascl_(char *, integer *, integer *, real *, real *, integer *,
+ integer *, complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), xerbla_(char *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ real bignum;
+ extern /* Subroutine */ int chseqr_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *), cunghr_(integer
+ *, integer *, integer *, complex *, integer *, complex *, complex
+ *, integer *, integer *), ctrsen_(char *, char *, logical *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, real *, real *, complex *, integer *, integer *);
+ integer minwrk, maxwrk;
+ real smlnum;
+ integer hswork;
+ logical wantst, lquery, wantvs;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+/* .. Function Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGEES computes for an N-by-N complex nonsymmetric matrix A, the */
+/* eigenvalues, the Schur form T, and, optionally, the matrix of Schur */
+/* vectors Z. This gives the Schur factorization A = Z*T*(Z**H). */
+
+/* Optionally, it also orders the eigenvalues on the diagonal of the */
+/* Schur form so that selected eigenvalues are at the top left. */
+/* The leading columns of Z then form an orthonormal basis for the */
+/* invariant subspace corresponding to the selected eigenvalues. */
+/* A complex matrix is in Schur form if it is upper triangular. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVS (input) CHARACTER*1 */
+/* = 'N': Schur vectors are not computed; */
+/* = 'V': Schur vectors are computed. */
+
+/* SORT (input) CHARACTER*1 */
+/* Specifies whether or not to order the eigenvalues on the */
+/* diagonal of the Schur form. */
+/* = 'N': Eigenvalues are not ordered: */
+/* = 'S': Eigenvalues are ordered (see SELECT). */
+
+/* SELECT (external procedure) LOGICAL FUNCTION of one COMPLEX argument */
+/* SELECT must be declared EXTERNAL in the calling subroutine. */
+/* If SORT = 'S', SELECT is used to select eigenvalues to order */
+/* to the top left of the Schur form. */
+/* IF SORT = 'N', SELECT is not referenced. */
+/* The eigenvalue W(j) is selected if SELECT(W(j)) is true. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+/* On exit, A has been overwritten by its Schur form T. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* SDIM (output) INTEGER */
+/* If SORT = 'N', SDIM = 0. */
+/* If SORT = 'S', SDIM = number of eigenvalues for which */
+/* SELECT is true. */
+
+/* W (output) COMPLEX array, dimension (N) */
+/* W contains the computed eigenvalues, in the same order that */
+/* they appear on the diagonal of the output Schur form T. */
+
+/* VS (output) COMPLEX array, dimension (LDVS,N) */
+/* If JOBVS = 'V', VS contains the unitary matrix Z of Schur */
+/* vectors. */
+/* If JOBVS = 'N', VS is not referenced. */
+
+/* LDVS (input) INTEGER */
+/* The leading dimension of the array VS. LDVS >= 1; if */
+/* JOBVS = 'V', LDVS >= N. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,2*N). */
+/* For good performance, LWORK must generally be larger. */
+
+/* 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. */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+/* Not referenced if SORT = 'N'. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, and i is */
+/* <= N: the QR algorithm failed to compute all the */
+/* eigenvalues; elements 1:ILO-1 and i+1:N of W */
+/* contain those eigenvalues which have converged; */
+/* if JOBVS = 'V', VS contains the matrix which */
+/* reduces A to its partially converged Schur form. */
+/* = N+1: the eigenvalues could not be reordered because */
+/* some eigenvalues were too close to separate (the */
+/* problem is very ill-conditioned); */
+/* = N+2: after reordering, roundoff changed values of */
+/* some complex eigenvalues so that leading */
+/* eigenvalues in the Schur form no longer satisfy */
+/* SELECT = .TRUE.. This could also be caused by */
+/* underflow due to scaling. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ vs_dim1 = *ldvs;
+ vs_offset = 1 + vs_dim1;
+ vs -= vs_offset;
+ --work;
+ --rwork;
+ --bwork;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ wantvs = lsame_(jobvs, "V");
+ wantst = lsame_(sort, "S");
+ if (! wantvs && ! lsame_(jobvs, "N")) {
+ *info = -1;
+ } else if (! wantst && ! lsame_(sort, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldvs < 1 || wantvs && *ldvs < *n) {
+ *info = -10;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* CWorkspace refers to complex workspace, and RWorkspace to real */
+/* workspace. NB refers to the optimal block size for the */
+/* immediately following subroutine, as returned by ILAENV. */
+/* HSWORK refers to the workspace preferred by CHSEQR, as */
+/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
+/* the worst case.) */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ } else {
+ maxwrk = *n + *n * ilaenv_(&c__1, "CGEHRD", " ", n, &c__1, n, &
+ c__0);
+ minwrk = *n << 1;
+
+ chseqr_("S", jobvs, n, &c__1, n, &a[a_offset], lda, &w[1], &vs[
+ vs_offset], ldvs, &work[1], &c_n1, &ieval);
+ hswork = work[1].r;
+
+ if (! wantvs) {
+ maxwrk = max(maxwrk,hswork);
+ } else {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "CUNGHR",
+ " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ maxwrk = max(maxwrk,hswork);
+ }
+ }
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGEES ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *sdim = 0;
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1.f / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = clange_("M", n, n, &a[a_offset], lda, dum);
+ scalea = FALSE_;
+ if (anrm > 0.f && anrm < smlnum) {
+ scalea = TRUE_;
+ cscale = smlnum;
+ } else if (anrm > bignum) {
+ scalea = TRUE_;
+ cscale = bignum;
+ }
+ if (scalea) {
+ clascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Permute the matrix to make it more nearly triangular */
+/* (CWorkspace: none) */
+/* (RWorkspace: need N) */
+
+ ibal = 1;
+ cgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &rwork[ibal], &ierr);
+
+/* Reduce to upper Hessenberg form */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: none) */
+
+ itau = 1;
+ iwrk = *n + itau;
+ i__1 = *lwork - iwrk + 1;
+ cgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
+ &ierr);
+
+ if (wantvs) {
+
+/* Copy Householder vectors to VS */
+
+ clacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs)
+ ;
+
+/* Generate unitary matrix in VS */
+/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwrk + 1;
+ cunghr_(n, &ilo, &ihi, &vs[vs_offset], ldvs, &work[itau], &work[iwrk],
+ &i__1, &ierr);
+ }
+
+ *sdim = 0;
+
+/* Perform QR iteration, accumulating Schur vectors in VS if desired */
+/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
+/* (RWorkspace: none) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ chseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vs[
+ vs_offset], ldvs, &work[iwrk], &i__1, &ieval);
+ if (ieval > 0) {
+ *info = ieval;
+ }
+
+/* Sort eigenvalues if desired */
+
+ if (wantst && *info == 0) {
+ if (scalea) {
+ clascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &w[1], n, &
+ ierr);
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ bwork[i__] = (*select)(&w[i__]);
+/* L10: */
+ }
+
+/* Reorder eigenvalues and transform Schur vectors */
+/* (CWorkspace: none) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwrk + 1;
+ ctrsen_("N", jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset],
+ ldvs, &w[1], sdim, &s, &sep, &work[iwrk], &i__1, &icond);
+ }
+
+ if (wantvs) {
+
+/* Undo balancing */
+/* (CWorkspace: none) */
+/* (RWorkspace: need N) */
+
+ cgebak_("P", "R", n, &ilo, &ihi, &rwork[ibal], n, &vs[vs_offset],
+ ldvs, &ierr);
+ }
+
+ if (scalea) {
+
+/* Undo scaling for the Schur form of A */
+
+ clascl_("U", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, &
+ ierr);
+ i__1 = *lda + 1;
+ ccopy_(n, &a[a_offset], &i__1, &w[1], &c__1);
+ }
+
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+ return 0;
+
+/* End of CGEES */
+
+} /* cgees_ */
diff --git a/SRC/cgeesx.c b/SRC/cgeesx.c
new file mode 100644
index 0000000..ea9c236
--- /dev/null
+++ b/SRC/cgeesx.c
@@ -0,0 +1,472 @@
+/* cgeesx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cgeesx_(char *jobvs, char *sort, L_fp select, char *
+ sense, integer *n, complex *a, integer *lda, integer *sdim, complex *
+ w, complex *vs, integer *ldvs, real *rconde, real *rcondv, complex *
+ work, integer *lwork, real *rwork, logical *bwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, ihi, ilo;
+ real dum[1], eps;
+ integer ibal;
+ real anrm;
+ integer ierr, itau, iwrk, lwrk, icond, ieval;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), cgebak_(char *, char *, integer *, integer
+ *, integer *, real *, integer *, complex *, integer *, integer *), cgebal_(char *, integer *, complex *, integer *,
+ integer *, integer *, real *, integer *), slabad_(real *,
+ real *);
+ logical scalea;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ real cscale;
+ extern /* Subroutine */ int cgehrd_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *),
+ clascl_(char *, integer *, integer *, real *, real *, integer *,
+ integer *, complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), xerbla_(char *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ real bignum;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *), chseqr_(char *, char *, integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, complex *,
+ integer *, integer *), cunghr_(integer *, integer
+ *, integer *, complex *, integer *, complex *, complex *, integer
+ *, integer *);
+ logical wantsb;
+ extern /* Subroutine */ int ctrsen_(char *, char *, logical *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ real *, real *, complex *, integer *, integer *);
+ logical wantse;
+ integer minwrk, maxwrk;
+ logical wantsn;
+ real smlnum;
+ integer hswork;
+ logical wantst, wantsv, wantvs;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+/* .. Function Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGEESX computes for an N-by-N complex nonsymmetric matrix A, the */
+/* eigenvalues, the Schur form T, and, optionally, the matrix of Schur */
+/* vectors Z. This gives the Schur factorization A = Z*T*(Z**H). */
+
+/* Optionally, it also orders the eigenvalues on the diagonal of the */
+/* Schur form so that selected eigenvalues are at the top left; */
+/* computes a reciprocal condition number for the average of the */
+/* selected eigenvalues (RCONDE); and computes a reciprocal condition */
+/* number for the right invariant subspace corresponding to the */
+/* selected eigenvalues (RCONDV). The leading columns of Z form an */
+/* orthonormal basis for this invariant subspace. */
+
+/* For further explanation of the reciprocal condition numbers RCONDE */
+/* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where */
+/* these quantities are called s and sep respectively). */
+
+/* A complex matrix is in Schur form if it is upper triangular. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVS (input) CHARACTER*1 */
+/* = 'N': Schur vectors are not computed; */
+/* = 'V': Schur vectors are computed. */
+
+/* SORT (input) CHARACTER*1 */
+/* Specifies whether or not to order the eigenvalues on the */
+/* diagonal of the Schur form. */
+/* = 'N': Eigenvalues are not ordered; */
+/* = 'S': Eigenvalues are ordered (see SELECT). */
+
+/* SELECT (external procedure) LOGICAL FUNCTION of one COMPLEX argument */
+/* SELECT must be declared EXTERNAL in the calling subroutine. */
+/* If SORT = 'S', SELECT is used to select eigenvalues to order */
+/* to the top left of the Schur form. */
+/* If SORT = 'N', SELECT is not referenced. */
+/* An eigenvalue W(j) is selected if SELECT(W(j)) is true. */
+
+/* SENSE (input) CHARACTER*1 */
+/* Determines which reciprocal condition numbers are computed. */
+/* = 'N': None are computed; */
+/* = 'E': Computed for average of selected eigenvalues only; */
+/* = 'V': Computed for selected right invariant subspace only; */
+/* = 'B': Computed for both. */
+/* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA, N) */
+/* On entry, the N-by-N matrix A. */
+/* On exit, A is overwritten by its Schur form T. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* SDIM (output) INTEGER */
+/* If SORT = 'N', SDIM = 0. */
+/* If SORT = 'S', SDIM = number of eigenvalues for which */
+/* SELECT is true. */
+
+/* W (output) COMPLEX array, dimension (N) */
+/* W contains the computed eigenvalues, in the same order */
+/* that they appear on the diagonal of the output Schur form T. */
+
+/* VS (output) COMPLEX array, dimension (LDVS,N) */
+/* If JOBVS = 'V', VS contains the unitary matrix Z of Schur */
+/* vectors. */
+/* If JOBVS = 'N', VS is not referenced. */
+
+/* LDVS (input) INTEGER */
+/* The leading dimension of the array VS. LDVS >= 1, and if */
+/* JOBVS = 'V', LDVS >= N. */
+
+/* RCONDE (output) REAL */
+/* If SENSE = 'E' or 'B', RCONDE contains the reciprocal */
+/* condition number for the average of the selected eigenvalues. */
+/* Not referenced if SENSE = 'N' or 'V'. */
+
+/* RCONDV (output) REAL */
+/* If SENSE = 'V' or 'B', RCONDV contains the reciprocal */
+/* condition number for the selected right invariant subspace. */
+/* Not referenced if SENSE = 'N' or 'E'. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,2*N). */
+/* Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM), */
+/* where SDIM is the number of selected eigenvalues computed by */
+/* this routine. Note that 2*SDIM*(N-SDIM) <= N*N/2. Note also */
+/* that an error is only returned if LWORK < max(1,2*N), but if */
+/* SENSE = 'E' or 'V' or 'B' this may not be large enough. */
+/* For good performance, LWORK must generally be larger. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates upper bound on the optimal size of the */
+/* array WORK, returns this value as the first entry of the WORK */
+/* array, and no error message related to LWORK is issued by */
+/* XERBLA. */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+/* Not referenced if SORT = 'N'. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, and i is */
+/* <= N: the QR algorithm failed to compute all the */
+/* eigenvalues; elements 1:ILO-1 and i+1:N of W */
+/* contain those eigenvalues which have converged; if */
+/* JOBVS = 'V', VS contains the transformation which */
+/* reduces A to its partially converged Schur form. */
+/* = N+1: the eigenvalues could not be reordered because some */
+/* eigenvalues were too close to separate (the problem */
+/* is very ill-conditioned); */
+/* = N+2: after reordering, roundoff changed values of some */
+/* complex eigenvalues so that leading eigenvalues in */
+/* the Schur form no longer satisfy SELECT=.TRUE. This */
+/* could also be caused by underflow due to scaling. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ vs_dim1 = *ldvs;
+ vs_offset = 1 + vs_dim1;
+ vs -= vs_offset;
+ --work;
+ --rwork;
+ --bwork;
+
+ /* Function Body */
+ *info = 0;
+ wantvs = lsame_(jobvs, "V");
+ wantst = lsame_(sort, "S");
+ wantsn = lsame_(sense, "N");
+ wantse = lsame_(sense, "E");
+ wantsv = lsame_(sense, "V");
+ wantsb = lsame_(sense, "B");
+ if (! wantvs && ! lsame_(jobvs, "N")) {
+ *info = -1;
+ } else if (! wantst && ! lsame_(sort, "N")) {
+ *info = -2;
+ } else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && !
+ wantsn) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvs < 1 || wantvs && *ldvs < *n) {
+ *info = -11;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of real workspace needed at that point in the */
+/* code, as well as the preferred amount for good performance. */
+/* CWorkspace refers to complex workspace, and RWorkspace to real */
+/* workspace. NB refers to the optimal block size for the */
+/* immediately following subroutine, as returned by ILAENV. */
+/* HSWORK refers to the workspace preferred by CHSEQR, as */
+/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
+/* the worst case. */
+/* If SENSE = 'E', 'V' or 'B', then the amount of workspace needed */
+/* depends on SDIM, which is computed by the routine CTRSEN later */
+/* in the code.) */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ minwrk = 1;
+ lwrk = 1;
+ } else {
+ maxwrk = *n + *n * ilaenv_(&c__1, "CGEHRD", " ", n, &c__1, n, &
+ c__0);
+ minwrk = *n << 1;
+
+ chseqr_("S", jobvs, n, &c__1, n, &a[a_offset], lda, &w[1], &vs[
+ vs_offset], ldvs, &work[1], &c_n1, &ieval);
+ hswork = work[1].r;
+
+ if (! wantvs) {
+ maxwrk = max(maxwrk,hswork);
+ } else {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "CUNGHR",
+ " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ maxwrk = max(maxwrk,hswork);
+ }
+ lwrk = maxwrk;
+ if (! wantsn) {
+/* Computing MAX */
+ i__1 = lwrk, i__2 = *n * *n / 2;
+ lwrk = max(i__1,i__2);
+ }
+ }
+ work[1].r = (real) lwrk, work[1].i = 0.f;
+
+ if (*lwork < minwrk) {
+ *info = -15;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGEESX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *sdim = 0;
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1.f / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = clange_("M", n, n, &a[a_offset], lda, dum);
+ scalea = FALSE_;
+ if (anrm > 0.f && anrm < smlnum) {
+ scalea = TRUE_;
+ cscale = smlnum;
+ } else if (anrm > bignum) {
+ scalea = TRUE_;
+ cscale = bignum;
+ }
+ if (scalea) {
+ clascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+
+/* Permute the matrix to make it more nearly triangular */
+/* (CWorkspace: none) */
+/* (RWorkspace: need N) */
+
+ ibal = 1;
+ cgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &rwork[ibal], &ierr);
+
+/* Reduce to upper Hessenberg form */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: none) */
+
+ itau = 1;
+ iwrk = *n + itau;
+ i__1 = *lwork - iwrk + 1;
+ cgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
+ &ierr);
+
+ if (wantvs) {
+
+/* Copy Householder vectors to VS */
+
+ clacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs)
+ ;
+
+/* Generate unitary matrix in VS */
+/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwrk + 1;
+ cunghr_(n, &ilo, &ihi, &vs[vs_offset], ldvs, &work[itau], &work[iwrk],
+ &i__1, &ierr);
+ }
+
+ *sdim = 0;
+
+/* Perform QR iteration, accumulating Schur vectors in VS if desired */
+/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
+/* (RWorkspace: none) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ chseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vs[
+ vs_offset], ldvs, &work[iwrk], &i__1, &ieval);
+ if (ieval > 0) {
+ *info = ieval;
+ }
+
+/* Sort eigenvalues if desired */
+
+ if (wantst && *info == 0) {
+ if (scalea) {
+ clascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &w[1], n, &
+ ierr);
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ bwork[i__] = (*select)(&w[i__]);
+/* L10: */
+ }
+
+/* Reorder eigenvalues, transform Schur vectors, and compute */
+/* reciprocal condition numbers */
+/* (CWorkspace: if SENSE is not 'N', need 2*SDIM*(N-SDIM) */
+/* otherwise, need none ) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwrk + 1;
+ ctrsen_(sense, jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset],
+ ldvs, &w[1], sdim, rconde, rcondv, &work[iwrk], &i__1, &
+ icond);
+ if (! wantsn) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*sdim << 1) * (*n - *sdim);
+ maxwrk = max(i__1,i__2);
+ }
+ if (icond == -14) {
+
+/* Not enough complex workspace */
+
+ *info = -15;
+ }
+ }
+
+ if (wantvs) {
+
+/* Undo balancing */
+/* (CWorkspace: none) */
+/* (RWorkspace: need N) */
+
+ cgebak_("P", "R", n, &ilo, &ihi, &rwork[ibal], n, &vs[vs_offset],
+ ldvs, &ierr);
+ }
+
+ if (scalea) {
+
+/* Undo scaling for the Schur form of A */
+
+ clascl_("U", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, &
+ ierr);
+ i__1 = *lda + 1;
+ ccopy_(n, &a[a_offset], &i__1, &w[1], &c__1);
+ if ((wantsv || wantsb) && *info == 0) {
+ dum[0] = *rcondv;
+ slascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &
+ c__1, &ierr);
+ *rcondv = dum[0];
+ }
+ }
+
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+ return 0;
+
+/* End of CGEESX */
+
+} /* cgeesx_ */
diff --git a/SRC/cgeev.c b/SRC/cgeev.c
new file mode 100644
index 0000000..81a7b98
--- /dev/null
+++ b/SRC/cgeev.c
@@ -0,0 +1,529 @@
+/* cgeev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cgeev_(char *jobvl, char *jobvr, integer *n, complex *a,
+ integer *lda, complex *w, complex *vl, integer *ldvl, complex *vr,
+ integer *ldvr, complex *work, integer *lwork, real *rwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
+ i__2, i__3;
+ real r__1, r__2;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_imag(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, k, ihi;
+ real scl;
+ integer ilo;
+ real dum[1], eps;
+ complex tmp;
+ integer ibal;
+ char side[1];
+ real anrm;
+ integer ierr, itau, iwrk, nout;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern doublereal scnrm2_(integer *, complex *, integer *);
+ extern /* Subroutine */ int cgebak_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, complex *, integer *, integer *), cgebal_(char *, integer *, complex *, integer *,
+ integer *, integer *, real *, integer *), slabad_(real *,
+ real *);
+ logical scalea;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ real cscale;
+ extern /* Subroutine */ int cgehrd_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *),
+ clascl_(char *, integer *, integer *, real *, real *, integer *,
+ integer *, complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), clacpy_(char *, integer *, integer *, complex *, integer *,
+ complex *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical select[1];
+ real bignum;
+ extern integer isamax_(integer *, real *, integer *);
+ extern /* Subroutine */ int chseqr_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *), ctrevc_(char *,
+ char *, logical *, integer *, complex *, integer *, complex *,
+ integer *, complex *, integer *, integer *, integer *, complex *,
+ real *, integer *), cunghr_(integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ integer *);
+ integer minwrk, maxwrk;
+ logical wantvl;
+ real smlnum;
+ integer hswork, irwork;
+ logical lquery, wantvr;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGEEV computes for an N-by-N complex nonsymmetric matrix A, the */
+/* eigenvalues and, optionally, the left and/or right eigenvectors. */
+
+/* The right eigenvector v(j) of A satisfies */
+/* A * v(j) = lambda(j) * v(j) */
+/* where lambda(j) is its eigenvalue. */
+/* The left eigenvector u(j) of A satisfies */
+/* u(j)**H * A = lambda(j) * u(j)**H */
+/* where u(j)**H denotes the conjugate transpose of u(j). */
+
+/* The computed eigenvectors are normalized to have Euclidean norm */
+/* equal to 1 and largest component real. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVL (input) CHARACTER*1 */
+/* = 'N': left eigenvectors of A are not computed; */
+/* = 'V': left eigenvectors of are computed. */
+
+/* JOBVR (input) CHARACTER*1 */
+/* = 'N': right eigenvectors of A are not computed; */
+/* = 'V': right eigenvectors of A are computed. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+/* On exit, A has been overwritten. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* W (output) COMPLEX array, dimension (N) */
+/* W contains the computed eigenvalues. */
+
+/* VL (output) COMPLEX array, dimension (LDVL,N) */
+/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
+/* after another in the columns of VL, in the same order */
+/* as their eigenvalues. */
+/* If JOBVL = 'N', VL is not referenced. */
+/* u(j) = VL(:,j), the j-th column of VL. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. LDVL >= 1; if */
+/* JOBVL = 'V', LDVL >= N. */
+
+/* VR (output) COMPLEX array, dimension (LDVR,N) */
+/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
+/* after another in the columns of VR, in the same order */
+/* as their eigenvalues. */
+/* If JOBVR = 'N', VR is not referenced. */
+/* v(j) = VR(:,j), the j-th column of VR. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. LDVR >= 1; if */
+/* JOBVR = 'V', LDVR >= N. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,2*N). */
+/* For good performance, LWORK must generally be larger. */
+
+/* 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. */
+
+/* RWORK (workspace) REAL array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the QR algorithm failed to compute all the */
+/* eigenvalues, and no eigenvectors have been computed; */
+/* elements and i+1:N of W contain eigenvalues which have */
+/* converged. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ wantvl = lsame_(jobvl, "V");
+ wantvr = lsame_(jobvr, "V");
+ if (! wantvl && ! lsame_(jobvl, "N")) {
+ *info = -1;
+ } else if (! wantvr && ! lsame_(jobvr, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldvl < 1 || wantvl && *ldvl < *n) {
+ *info = -8;
+ } else if (*ldvr < 1 || wantvr && *ldvr < *n) {
+ *info = -10;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* CWorkspace refers to complex workspace, and RWorkspace to real */
+/* workspace. NB refers to the optimal block size for the */
+/* immediately following subroutine, as returned by ILAENV. */
+/* HSWORK refers to the workspace preferred by CHSEQR, as */
+/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
+/* the worst case.) */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ } else {
+ maxwrk = *n + *n * ilaenv_(&c__1, "CGEHRD", " ", n, &c__1, n, &
+ c__0);
+ minwrk = *n << 1;
+ if (wantvl) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "CUNGHR",
+ " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ chseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vl[
+ vl_offset], ldvl, &work[1], &c_n1, info);
+ } else if (wantvr) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "CUNGHR",
+ " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ chseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[
+ vr_offset], ldvr, &work[1], &c_n1, info);
+ } else {
+ chseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[
+ vr_offset], ldvr, &work[1], &c_n1, info);
+ }
+ hswork = work[1].r;
+/* Computing MAX */
+ i__1 = max(maxwrk,hswork);
+ maxwrk = max(i__1,minwrk);
+ }
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGEEV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1.f / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = clange_("M", n, n, &a[a_offset], lda, dum);
+ scalea = FALSE_;
+ if (anrm > 0.f && anrm < smlnum) {
+ scalea = TRUE_;
+ cscale = smlnum;
+ } else if (anrm > bignum) {
+ scalea = TRUE_;
+ cscale = bignum;
+ }
+ if (scalea) {
+ clascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Balance the matrix */
+/* (CWorkspace: none) */
+/* (RWorkspace: need N) */
+
+ ibal = 1;
+ cgebal_("B", n, &a[a_offset], lda, &ilo, &ihi, &rwork[ibal], &ierr);
+
+/* Reduce to upper Hessenberg form */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: none) */
+
+ itau = 1;
+ iwrk = itau + *n;
+ i__1 = *lwork - iwrk + 1;
+ cgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
+ &ierr);
+
+ if (wantvl) {
+
+/* Want left eigenvectors */
+/* Copy Householder vectors to VL */
+
+ *(unsigned char *)side = 'L';
+ clacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
+ ;
+
+/* Generate unitary matrix in VL */
+/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwrk + 1;
+ cunghr_(n, &ilo, &ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk],
+ &i__1, &ierr);
+
+/* Perform QR iteration, accumulating Schur vectors in VL */
+/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
+/* (RWorkspace: none) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ chseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vl[
+ vl_offset], ldvl, &work[iwrk], &i__1, info);
+
+ if (wantvr) {
+
+/* Want left and right eigenvectors */
+/* Copy Schur vectors to VR */
+
+ *(unsigned char *)side = 'B';
+ clacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
+ }
+
+ } else if (wantvr) {
+
+/* Want right eigenvectors */
+/* Copy Householder vectors to VR */
+
+ *(unsigned char *)side = 'R';
+ clacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
+ ;
+
+/* Generate unitary matrix in VR */
+/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwrk + 1;
+ cunghr_(n, &ilo, &ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk],
+ &i__1, &ierr);
+
+/* Perform QR iteration, accumulating Schur vectors in VR */
+/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
+/* (RWorkspace: none) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ chseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vr[
+ vr_offset], ldvr, &work[iwrk], &i__1, info);
+
+ } else {
+
+/* Compute eigenvalues only */
+/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
+/* (RWorkspace: none) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ chseqr_("E", "N", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vr[
+ vr_offset], ldvr, &work[iwrk], &i__1, info);
+ }
+
+/* If INFO > 0 from CHSEQR, then quit */
+
+ if (*info > 0) {
+ goto L50;
+ }
+
+ if (wantvl || wantvr) {
+
+/* Compute left and/or right eigenvectors */
+/* (CWorkspace: need 2*N) */
+/* (RWorkspace: need 2*N) */
+
+ irwork = ibal + *n;
+ ctrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
+ &vr[vr_offset], ldvr, n, &nout, &work[iwrk], &rwork[irwork],
+ &ierr);
+ }
+
+ if (wantvl) {
+
+/* Undo balancing of left eigenvectors */
+/* (CWorkspace: none) */
+/* (RWorkspace: need N) */
+
+ cgebak_("B", "L", n, &ilo, &ihi, &rwork[ibal], n, &vl[vl_offset],
+ ldvl, &ierr);
+
+/* Normalize left eigenvectors and make largest component real */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ scl = 1.f / scnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
+ csscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + i__ * vl_dim1;
+/* Computing 2nd power */
+ r__1 = vl[i__3].r;
+/* Computing 2nd power */
+ r__2 = r_imag(&vl[k + i__ * vl_dim1]);
+ rwork[irwork + k - 1] = r__1 * r__1 + r__2 * r__2;
+/* L10: */
+ }
+ k = isamax_(n, &rwork[irwork], &c__1);
+ r_cnjg(&q__2, &vl[k + i__ * vl_dim1]);
+ r__1 = sqrt(rwork[irwork + k - 1]);
+ q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
+ tmp.r = q__1.r, tmp.i = q__1.i;
+ cscal_(n, &tmp, &vl[i__ * vl_dim1 + 1], &c__1);
+ i__2 = k + i__ * vl_dim1;
+ i__3 = k + i__ * vl_dim1;
+ r__1 = vl[i__3].r;
+ q__1.r = r__1, q__1.i = 0.f;
+ vl[i__2].r = q__1.r, vl[i__2].i = q__1.i;
+/* L20: */
+ }
+ }
+
+ if (wantvr) {
+
+/* Undo balancing of right eigenvectors */
+/* (CWorkspace: none) */
+/* (RWorkspace: need N) */
+
+ cgebak_("B", "R", n, &ilo, &ihi, &rwork[ibal], n, &vr[vr_offset],
+ ldvr, &ierr);
+
+/* Normalize right eigenvectors and make largest component real */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ scl = 1.f / scnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
+ csscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + i__ * vr_dim1;
+/* Computing 2nd power */
+ r__1 = vr[i__3].r;
+/* Computing 2nd power */
+ r__2 = r_imag(&vr[k + i__ * vr_dim1]);
+ rwork[irwork + k - 1] = r__1 * r__1 + r__2 * r__2;
+/* L30: */
+ }
+ k = isamax_(n, &rwork[irwork], &c__1);
+ r_cnjg(&q__2, &vr[k + i__ * vr_dim1]);
+ r__1 = sqrt(rwork[irwork + k - 1]);
+ q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
+ tmp.r = q__1.r, tmp.i = q__1.i;
+ cscal_(n, &tmp, &vr[i__ * vr_dim1 + 1], &c__1);
+ i__2 = k + i__ * vr_dim1;
+ i__3 = k + i__ * vr_dim1;
+ r__1 = vr[i__3].r;
+ q__1.r = r__1, q__1.i = 0.f;
+ vr[i__2].r = q__1.r, vr[i__2].i = q__1.i;
+/* L40: */
+ }
+ }
+
+/* Undo scaling if necessary */
+
+L50:
+ if (scalea) {
+ i__1 = *n - *info;
+/* Computing MAX */
+ i__3 = *n - *info;
+ i__2 = max(i__3,1);
+ clascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[*info + 1]
+, &i__2, &ierr);
+ if (*info > 0) {
+ i__1 = ilo - 1;
+ clascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[1], n,
+ &ierr);
+ }
+ }
+
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+ return 0;
+
+/* End of CGEEV */
+
+} /* cgeev_ */
diff --git a/SRC/cgeevx.c b/SRC/cgeevx.c
new file mode 100644
index 0000000..589c88d
--- /dev/null
+++ b/SRC/cgeevx.c
@@ -0,0 +1,680 @@
+/* cgeevx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cgeevx_(char *balanc, char *jobvl, char *jobvr, char *
+ sense, integer *n, complex *a, integer *lda, complex *w, complex *vl,
+ integer *ldvl, complex *vr, integer *ldvr, integer *ilo, integer *ihi,
+ real *scale, real *abnrm, real *rconde, real *rcondv, complex *work,
+ integer *lwork, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
+ i__2, i__3;
+ real r__1, r__2;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_imag(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, k;
+ char job[1];
+ real scl, dum[1], eps;
+ complex tmp;
+ char side[1];
+ real anrm;
+ integer ierr, itau, iwrk, nout;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *);
+ integer icond;
+ extern logical lsame_(char *, char *);
+ extern doublereal scnrm2_(integer *, complex *, integer *);
+ extern /* Subroutine */ int cgebak_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, complex *, integer *, integer *), cgebal_(char *, integer *, complex *, integer *,
+ integer *, integer *, real *, integer *), slabad_(real *,
+ real *);
+ logical scalea;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ real cscale;
+ extern /* Subroutine */ int cgehrd_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *),
+ clascl_(char *, integer *, integer *, real *, real *, integer *,
+ integer *, complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), clacpy_(char *, integer *, integer *, complex *, integer *,
+ complex *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical select[1];
+ real bignum;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ extern /* Subroutine */ int chseqr_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *), ctrevc_(char *,
+ char *, logical *, integer *, complex *, integer *, complex *,
+ integer *, complex *, integer *, integer *, integer *, complex *,
+ real *, integer *), cunghr_(integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ integer *), ctrsna_(char *, char *, logical *, integer *, complex
+ *, integer *, complex *, integer *, complex *, integer *, real *,
+ real *, integer *, integer *, complex *, integer *, real *,
+ integer *);
+ integer minwrk, maxwrk;
+ logical wantvl, wntsnb;
+ integer hswork;
+ logical wntsne;
+ real smlnum;
+ logical lquery, wantvr, wntsnn, wntsnv;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGEEVX computes for an N-by-N complex nonsymmetric matrix A, the */
+/* eigenvalues and, optionally, the left and/or right eigenvectors. */
+
+/* Optionally also, it computes a balancing transformation to improve */
+/* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */
+/* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues */
+/* (RCONDE), and reciprocal condition numbers for the right */
+/* eigenvectors (RCONDV). */
+
+/* The right eigenvector v(j) of A satisfies */
+/* A * v(j) = lambda(j) * v(j) */
+/* where lambda(j) is its eigenvalue. */
+/* The left eigenvector u(j) of A satisfies */
+/* u(j)**H * A = lambda(j) * u(j)**H */
+/* where u(j)**H denotes the conjugate transpose of u(j). */
+
+/* The computed eigenvectors are normalized to have Euclidean norm */
+/* equal to 1 and largest component real. */
+
+/* Balancing a matrix means permuting the rows and columns to make it */
+/* more nearly upper triangular, and applying a diagonal similarity */
+/* transformation D * A * D**(-1), where D is a diagonal matrix, to */
+/* make its rows and columns closer in norm and the condition numbers */
+/* of its eigenvalues and eigenvectors smaller. The computed */
+/* reciprocal condition numbers correspond to the balanced matrix. */
+/* Permuting rows and columns will not change the condition numbers */
+/* (in exact arithmetic) but diagonal scaling will. For further */
+/* explanation of balancing, see section 4.10.2 of the LAPACK */
+/* Users' Guide. */
+
+/* Arguments */
+/* ========= */
+
+/* BALANC (input) CHARACTER*1 */
+/* Indicates how the input matrix should be diagonally scaled */
+/* and/or permuted to improve the conditioning of its */
+/* eigenvalues. */
+/* = 'N': Do not diagonally scale or permute; */
+/* = 'P': Perform permutations to make the matrix more nearly */
+/* upper triangular. Do not diagonally scale; */
+/* = 'S': Diagonally scale the matrix, ie. replace A by */
+/* D*A*D**(-1), where D is a diagonal matrix chosen */
+/* to make the rows and columns of A more equal in */
+/* norm. Do not permute; */
+/* = 'B': Both diagonally scale and permute A. */
+
+/* Computed reciprocal condition numbers will be for the matrix */
+/* after balancing and/or permuting. Permuting does not change */
+/* condition numbers (in exact arithmetic), but balancing does. */
+
+/* JOBVL (input) CHARACTER*1 */
+/* = 'N': left eigenvectors of A are not computed; */
+/* = 'V': left eigenvectors of A are computed. */
+/* If SENSE = 'E' or 'B', JOBVL must = 'V'. */
+
+/* JOBVR (input) CHARACTER*1 */
+/* = 'N': right eigenvectors of A are not computed; */
+/* = 'V': right eigenvectors of A are computed. */
+/* If SENSE = 'E' or 'B', JOBVR must = 'V'. */
+
+/* SENSE (input) CHARACTER*1 */
+/* Determines which reciprocal condition numbers are computed. */
+/* = 'N': None are computed; */
+/* = 'E': Computed for eigenvalues only; */
+/* = 'V': Computed for right eigenvectors only; */
+/* = 'B': Computed for eigenvalues and right eigenvectors. */
+
+/* If SENSE = 'E' or 'B', both left and right eigenvectors */
+/* must also be computed (JOBVL = 'V' and JOBVR = 'V'). */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+/* On exit, A has been overwritten. If JOBVL = 'V' or */
+/* JOBVR = 'V', A contains the Schur form of the balanced */
+/* version of the matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* W (output) COMPLEX array, dimension (N) */
+/* W contains the computed eigenvalues. */
+
+/* VL (output) COMPLEX array, dimension (LDVL,N) */
+/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
+/* after another in the columns of VL, in the same order */
+/* as their eigenvalues. */
+/* If JOBVL = 'N', VL is not referenced. */
+/* u(j) = VL(:,j), the j-th column of VL. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. LDVL >= 1; if */
+/* JOBVL = 'V', LDVL >= N. */
+
+/* VR (output) COMPLEX array, dimension (LDVR,N) */
+/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
+/* after another in the columns of VR, in the same order */
+/* as their eigenvalues. */
+/* If JOBVR = 'N', VR is not referenced. */
+/* v(j) = VR(:,j), the j-th column of VR. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. LDVR >= 1; if */
+/* JOBVR = 'V', LDVR >= N. */
+
+/* ILO (output) INTEGER */
+/* IHI (output) INTEGER */
+/* ILO and IHI are integer values determined when A was */
+/* balanced. The balanced A(i,j) = 0 if I > J and */
+/* J = 1,...,ILO-1 or I = IHI+1,...,N. */
+
+/* SCALE (output) REAL array, dimension (N) */
+/* Details of the permutations and scaling factors applied */
+/* when balancing A. If P(j) is the index of the row and column */
+/* interchanged with row and column j, and D(j) is the scaling */
+/* factor applied to row and column j, then */
+/* SCALE(J) = P(J), for J = 1,...,ILO-1 */
+/* = D(J), for J = ILO,...,IHI */
+/* = P(J) for J = IHI+1,...,N. */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* ABNRM (output) REAL */
+/* The one-norm of the balanced matrix (the maximum */
+/* of the sum of absolute values of elements of any column). */
+
+/* RCONDE (output) REAL array, dimension (N) */
+/* RCONDE(j) is the reciprocal condition number of the j-th */
+/* eigenvalue. */
+
+/* RCONDV (output) REAL array, dimension (N) */
+/* RCONDV(j) is the reciprocal condition number of the j-th */
+/* right eigenvector. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. If SENSE = 'N' or 'E', */
+/* LWORK >= max(1,2*N), and if SENSE = 'V' or 'B', */
+/* LWORK >= N*N+2*N. */
+/* For good performance, LWORK must generally be larger. */
+
+/* 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. */
+
+/* RWORK (workspace) REAL array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the QR algorithm failed to compute all the */
+/* eigenvalues, and no eigenvectors or condition numbers */
+/* have been computed; elements 1:ILO-1 and i+1:N of W */
+/* contain eigenvalues which have converged. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --scale;
+ --rconde;
+ --rcondv;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ wantvl = lsame_(jobvl, "V");
+ wantvr = lsame_(jobvr, "V");
+ wntsnn = lsame_(sense, "N");
+ wntsne = lsame_(sense, "E");
+ wntsnv = lsame_(sense, "V");
+ wntsnb = lsame_(sense, "B");
+ if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P")
+ || lsame_(balanc, "B"))) {
+ *info = -1;
+ } else if (! wantvl && ! lsame_(jobvl, "N")) {
+ *info = -2;
+ } else if (! wantvr && ! lsame_(jobvr, "N")) {
+ *info = -3;
+ } else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb)
+ && ! (wantvl && wantvr)) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvl < 1 || wantvl && *ldvl < *n) {
+ *info = -10;
+ } else if (*ldvr < 1 || wantvr && *ldvr < *n) {
+ *info = -12;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* CWorkspace refers to complex workspace, and RWorkspace to real */
+/* workspace. NB refers to the optimal block size for the */
+/* immediately following subroutine, as returned by ILAENV. */
+/* HSWORK refers to the workspace preferred by CHSEQR, as */
+/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
+/* the worst case.) */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ } else {
+ maxwrk = *n + *n * ilaenv_(&c__1, "CGEHRD", " ", n, &c__1, n, &
+ c__0);
+
+ if (wantvl) {
+ chseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vl[
+ vl_offset], ldvl, &work[1], &c_n1, info);
+ } else if (wantvr) {
+ chseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[
+ vr_offset], ldvr, &work[1], &c_n1, info);
+ } else {
+ if (wntsnn) {
+ chseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &w[1], &
+ vr[vr_offset], ldvr, &work[1], &c_n1, info);
+ } else {
+ chseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &w[1], &
+ vr[vr_offset], ldvr, &work[1], &c_n1, info);
+ }
+ }
+ hswork = work[1].r;
+
+ if (! wantvl && ! wantvr) {
+ minwrk = *n << 1;
+ if (! (wntsnn || wntsne)) {
+/* Computing MAX */
+ i__1 = minwrk, i__2 = *n * *n + (*n << 1);
+ minwrk = max(i__1,i__2);
+ }
+ maxwrk = max(maxwrk,hswork);
+ if (! (wntsnn || wntsne)) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * *n + (*n << 1);
+ maxwrk = max(i__1,i__2);
+ }
+ } else {
+ minwrk = *n << 1;
+ if (! (wntsnn || wntsne)) {
+/* Computing MAX */
+ i__1 = minwrk, i__2 = *n * *n + (*n << 1);
+ minwrk = max(i__1,i__2);
+ }
+ maxwrk = max(maxwrk,hswork);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "CUNGHR",
+ " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ if (! (wntsnn || wntsne)) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * *n + (*n << 1);
+ maxwrk = max(i__1,i__2);
+ }
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n << 1;
+ maxwrk = max(i__1,i__2);
+ }
+ maxwrk = max(maxwrk,minwrk);
+ }
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -20;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGEEVX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1.f / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ icond = 0;
+ anrm = clange_("M", n, n, &a[a_offset], lda, dum);
+ scalea = FALSE_;
+ if (anrm > 0.f && anrm < smlnum) {
+ scalea = TRUE_;
+ cscale = smlnum;
+ } else if (anrm > bignum) {
+ scalea = TRUE_;
+ cscale = bignum;
+ }
+ if (scalea) {
+ clascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Balance the matrix and compute ABNRM */
+
+ cgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr);
+ *abnrm = clange_("1", n, n, &a[a_offset], lda, dum);
+ if (scalea) {
+ dum[0] = *abnrm;
+ slascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, &
+ ierr);
+ *abnrm = dum[0];
+ }
+
+/* Reduce to upper Hessenberg form */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: none) */
+
+ itau = 1;
+ iwrk = itau + *n;
+ i__1 = *lwork - iwrk + 1;
+ cgehrd_(n, ilo, ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, &
+ ierr);
+
+ if (wantvl) {
+
+/* Want left eigenvectors */
+/* Copy Householder vectors to VL */
+
+ *(unsigned char *)side = 'L';
+ clacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
+ ;
+
+/* Generate unitary matrix in VL */
+/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwrk + 1;
+ cunghr_(n, ilo, ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], &
+ i__1, &ierr);
+
+/* Perform QR iteration, accumulating Schur vectors in VL */
+/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
+/* (RWorkspace: none) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ chseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &w[1], &vl[
+ vl_offset], ldvl, &work[iwrk], &i__1, info);
+
+ if (wantvr) {
+
+/* Want left and right eigenvectors */
+/* Copy Schur vectors to VR */
+
+ *(unsigned char *)side = 'B';
+ clacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
+ }
+
+ } else if (wantvr) {
+
+/* Want right eigenvectors */
+/* Copy Householder vectors to VR */
+
+ *(unsigned char *)side = 'R';
+ clacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
+ ;
+
+/* Generate unitary matrix in VR */
+/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwrk + 1;
+ cunghr_(n, ilo, ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], &
+ i__1, &ierr);
+
+/* Perform QR iteration, accumulating Schur vectors in VR */
+/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
+/* (RWorkspace: none) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ chseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &w[1], &vr[
+ vr_offset], ldvr, &work[iwrk], &i__1, info);
+
+ } else {
+
+/* Compute eigenvalues only */
+/* If condition numbers desired, compute Schur form */
+
+ if (wntsnn) {
+ *(unsigned char *)job = 'E';
+ } else {
+ *(unsigned char *)job = 'S';
+ }
+
+/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
+/* (RWorkspace: none) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ chseqr_(job, "N", n, ilo, ihi, &a[a_offset], lda, &w[1], &vr[
+ vr_offset], ldvr, &work[iwrk], &i__1, info);
+ }
+
+/* If INFO > 0 from CHSEQR, then quit */
+
+ if (*info > 0) {
+ goto L50;
+ }
+
+ if (wantvl || wantvr) {
+
+/* Compute left and/or right eigenvectors */
+/* (CWorkspace: need 2*N) */
+/* (RWorkspace: need N) */
+
+ ctrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
+ &vr[vr_offset], ldvr, n, &nout, &work[iwrk], &rwork[1], &
+ ierr);
+ }
+
+/* Compute condition numbers if desired */
+/* (CWorkspace: need N*N+2*N unless SENSE = 'E') */
+/* (RWorkspace: need 2*N unless SENSE = 'E') */
+
+ if (! wntsnn) {
+ ctrsna_(sense, "A", select, n, &a[a_offset], lda, &vl[vl_offset],
+ ldvl, &vr[vr_offset], ldvr, &rconde[1], &rcondv[1], n, &nout,
+ &work[iwrk], n, &rwork[1], &icond);
+ }
+
+ if (wantvl) {
+
+/* Undo balancing of left eigenvectors */
+
+ cgebak_(balanc, "L", n, ilo, ihi, &scale[1], n, &vl[vl_offset], ldvl,
+ &ierr);
+
+/* Normalize left eigenvectors and make largest component real */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ scl = 1.f / scnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
+ csscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + i__ * vl_dim1;
+/* Computing 2nd power */
+ r__1 = vl[i__3].r;
+/* Computing 2nd power */
+ r__2 = r_imag(&vl[k + i__ * vl_dim1]);
+ rwork[k] = r__1 * r__1 + r__2 * r__2;
+/* L10: */
+ }
+ k = isamax_(n, &rwork[1], &c__1);
+ r_cnjg(&q__2, &vl[k + i__ * vl_dim1]);
+ r__1 = sqrt(rwork[k]);
+ q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
+ tmp.r = q__1.r, tmp.i = q__1.i;
+ cscal_(n, &tmp, &vl[i__ * vl_dim1 + 1], &c__1);
+ i__2 = k + i__ * vl_dim1;
+ i__3 = k + i__ * vl_dim1;
+ r__1 = vl[i__3].r;
+ q__1.r = r__1, q__1.i = 0.f;
+ vl[i__2].r = q__1.r, vl[i__2].i = q__1.i;
+/* L20: */
+ }
+ }
+
+ if (wantvr) {
+
+/* Undo balancing of right eigenvectors */
+
+ cgebak_(balanc, "R", n, ilo, ihi, &scale[1], n, &vr[vr_offset], ldvr,
+ &ierr);
+
+/* Normalize right eigenvectors and make largest component real */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ scl = 1.f / scnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
+ csscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + i__ * vr_dim1;
+/* Computing 2nd power */
+ r__1 = vr[i__3].r;
+/* Computing 2nd power */
+ r__2 = r_imag(&vr[k + i__ * vr_dim1]);
+ rwork[k] = r__1 * r__1 + r__2 * r__2;
+/* L30: */
+ }
+ k = isamax_(n, &rwork[1], &c__1);
+ r_cnjg(&q__2, &vr[k + i__ * vr_dim1]);
+ r__1 = sqrt(rwork[k]);
+ q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
+ tmp.r = q__1.r, tmp.i = q__1.i;
+ cscal_(n, &tmp, &vr[i__ * vr_dim1 + 1], &c__1);
+ i__2 = k + i__ * vr_dim1;
+ i__3 = k + i__ * vr_dim1;
+ r__1 = vr[i__3].r;
+ q__1.r = r__1, q__1.i = 0.f;
+ vr[i__2].r = q__1.r, vr[i__2].i = q__1.i;
+/* L40: */
+ }
+ }
+
+/* Undo scaling if necessary */
+
+L50:
+ if (scalea) {
+ i__1 = *n - *info;
+/* Computing MAX */
+ i__3 = *n - *info;
+ i__2 = max(i__3,1);
+ clascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[*info + 1]
+, &i__2, &ierr);
+ if (*info == 0) {
+ if ((wntsnv || wntsnb) && icond == 0) {
+ slascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &rcondv[
+ 1], n, &ierr);
+ }
+ } else {
+ i__1 = *ilo - 1;
+ clascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[1], n,
+ &ierr);
+ }
+ }
+
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+ return 0;
+
+/* End of CGEEVX */
+
+} /* cgeevx_ */
diff --git a/SRC/cgegs.c b/SRC/cgegs.c
new file mode 100644
index 0000000..f4d2a8e
--- /dev/null
+++ b/SRC/cgegs.c
@@ -0,0 +1,536 @@
+/* cgegs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cgegs_(char *jobvsl, char *jobvsr, integer *n, complex *
+ a, integer *lda, complex *b, integer *ldb, complex *alpha, complex *
+ beta, complex *vsl, integer *ldvsl, complex *vsr, integer *ldvsr,
+ complex *work, integer *lwork, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
+ vsr_dim1, vsr_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer nb, nb1, nb2, nb3, ihi, ilo;
+ real eps, anrm, bnrm;
+ integer itau, lopt;
+ extern logical lsame_(char *, char *);
+ integer ileft, iinfo, icols;
+ logical ilvsl;
+ integer iwork;
+ logical ilvsr;
+ integer irows;
+ extern /* Subroutine */ int cggbak_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, complex *, integer *,
+ integer *), cggbal_(char *, integer *, complex *,
+ integer *, complex *, integer *, integer *, integer *, real *,
+ real *, real *, integer *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int cgghrd_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, complex *, integer *, integer *),
+ clascl_(char *, integer *, integer *, real *, real *, integer *,
+ integer *, complex *, integer *, integer *);
+ logical ilascl, ilbscl;
+ extern /* Subroutine */ int cgeqrf_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ real bignum;
+ extern /* Subroutine */ int chgeqz_(char *, char *, char *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ complex *, complex *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, integer *);
+ integer ijobvl, iright, ijobvr;
+ real anrmto;
+ integer lwkmin;
+ real bnrmto;
+ extern /* Subroutine */ int cungqr_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *),
+ cunmqr_(char *, char *, integer *, integer *, integer *, complex
+ *, integer *, complex *, complex *, integer *, complex *, integer
+ *, integer *);
+ real smlnum;
+ integer irwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine CGGES. */
+
+/* CGEGS computes the eigenvalues, Schur form, and, optionally, the */
+/* left and or/right Schur vectors of a complex matrix pair (A,B). */
+/* Given two square matrices A and B, the generalized Schur */
+/* factorization has the form */
+
+/* A = Q*S*Z**H, B = Q*T*Z**H */
+
+/* where Q and Z are unitary matrices and S and T are upper triangular. */
+/* The columns of Q are the left Schur vectors */
+/* and the columns of Z are the right Schur vectors. */
+
+/* If only the eigenvalues of (A,B) are needed, the driver routine */
+/* CGEGV should be used instead. See CGEGV for a description of the */
+/* eigenvalues of the generalized nonsymmetric eigenvalue problem */
+/* (GNEP). */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVSL (input) CHARACTER*1 */
+/* = 'N': do not compute the left Schur vectors; */
+/* = 'V': compute the left Schur vectors (returned in VSL). */
+
+/* JOBVSR (input) CHARACTER*1 */
+/* = 'N': do not compute the right Schur vectors; */
+/* = 'V': compute the right Schur vectors (returned in VSR). */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VSL, and VSR. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA, N) */
+/* On entry, the matrix A. */
+/* On exit, the upper triangular matrix S from the generalized */
+/* Schur factorization. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX array, dimension (LDB, N) */
+/* On entry, the matrix B. */
+/* On exit, the upper triangular matrix T from the generalized */
+/* Schur factorization. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* ALPHA (output) COMPLEX array, dimension (N) */
+/* The complex scalars alpha that define the eigenvalues of */
+/* GNEP. ALPHA(j) = S(j,j), the diagonal element of the Schur */
+/* form of A. */
+
+/* BETA (output) COMPLEX array, dimension (N) */
+/* The non-negative real scalars beta that define the */
+/* eigenvalues of GNEP. BETA(j) = T(j,j), the diagonal element */
+/* of the triangular factor T. */
+
+/* Together, the quantities alpha = ALPHA(j) and beta = BETA(j) */
+/* represent the j-th eigenvalue of the matrix pair (A,B), in */
+/* one of the forms lambda = alpha/beta or mu = beta/alpha. */
+/* Since either lambda or mu may overflow, they should not, */
+/* in general, be computed. */
+
+/* VSL (output) COMPLEX array, dimension (LDVSL,N) */
+/* If JOBVSL = 'V', the matrix of left Schur vectors Q. */
+/* Not referenced if JOBVSL = 'N'. */
+
+/* LDVSL (input) INTEGER */
+/* The leading dimension of the matrix VSL. LDVSL >= 1, and */
+/* if JOBVSL = 'V', LDVSL >= N. */
+
+/* VSR (output) COMPLEX array, dimension (LDVSR,N) */
+/* If JOBVSR = 'V', the matrix of right Schur vectors Z. */
+/* Not referenced if JOBVSR = 'N'. */
+
+/* LDVSR (input) INTEGER */
+/* The leading dimension of the matrix VSR. LDVSR >= 1, and */
+/* if JOBVSR = 'V', LDVSR >= N. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,2*N). */
+/* For good performance, LWORK must generally be larger. */
+/* To compute the optimal value of LWORK, call ILAENV to get */
+/* blocksizes (for CGEQRF, CUNMQR, and CUNGQR.) Then compute: */
+/* NB -- MAX of the blocksizes for CGEQRF, CUNMQR, and CUNGQR; */
+/* the optimal LWORK is N*(NB+1). */
+
+/* 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. */
+
+/* RWORK (workspace) REAL array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* =1,...,N: */
+/* The QZ iteration failed. (A,B) are not in Schur */
+/* form, but ALPHA(j) and BETA(j) should be correct for */
+/* j=INFO+1,...,N. */
+/* > N: errors that usually indicate LAPACK problems: */
+/* =N+1: error return from CGGBAL */
+/* =N+2: error return from CGEQRF */
+/* =N+3: error return from CUNMQR */
+/* =N+4: error return from CUNGQR */
+/* =N+5: error return from CGGHRD */
+/* =N+6: error return from CHGEQZ (other than failed */
+/* iteration) */
+/* =N+7: error return from CGGBAK (computing VSL) */
+/* =N+8: error return from CGGBAK (computing VSR) */
+/* =N+9: error return from CLASCL (various places) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alpha;
+ --beta;
+ vsl_dim1 = *ldvsl;
+ vsl_offset = 1 + vsl_dim1;
+ vsl -= vsl_offset;
+ vsr_dim1 = *ldvsr;
+ vsr_offset = 1 + vsr_dim1;
+ vsr -= vsr_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ if (lsame_(jobvsl, "N")) {
+ ijobvl = 1;
+ ilvsl = FALSE_;
+ } else if (lsame_(jobvsl, "V")) {
+ ijobvl = 2;
+ ilvsl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvsl = FALSE_;
+ }
+
+ if (lsame_(jobvsr, "N")) {
+ ijobvr = 1;
+ ilvsr = FALSE_;
+ } else if (lsame_(jobvsr, "V")) {
+ ijobvr = 2;
+ ilvsr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvsr = FALSE_;
+ }
+
+/* Test the input arguments */
+
+/* Computing MAX */
+ i__1 = *n << 1;
+ lwkmin = max(i__1,1);
+ lwkopt = lwkmin;
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ lquery = *lwork == -1;
+ *info = 0;
+ if (ijobvl <= 0) {
+ *info = -1;
+ } else if (ijobvr <= 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
+ *info = -11;
+ } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
+ *info = -13;
+ } else if (*lwork < lwkmin && ! lquery) {
+ *info = -15;
+ }
+
+ if (*info == 0) {
+ nb1 = ilaenv_(&c__1, "CGEQRF", " ", n, n, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "CUNMQR", " ", n, n, n, &c_n1);
+ nb3 = ilaenv_(&c__1, "CUNGQR", " ", n, n, n, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2);
+ nb = max(i__1,nb3);
+ lopt = *n * (nb + 1);
+ work[1].r = (real) lopt, work[1].i = 0.f;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGEGS ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("E") * slamch_("B");
+ safmin = slamch_("S");
+ smlnum = *n * safmin / eps;
+ bignum = 1.f / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = clange_("M", n, n, &a[a_offset], lda, &rwork[1]);
+ ilascl = FALSE_;
+ if (anrm > 0.f && anrm < smlnum) {
+ anrmto = smlnum;
+ ilascl = TRUE_;
+ } else if (anrm > bignum) {
+ anrmto = bignum;
+ ilascl = TRUE_;
+ }
+
+ if (ilascl) {
+ clascl_("G", &c_n1, &c_n1, &anrm, &anrmto, n, n, &a[a_offset], lda, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = clange_("M", n, n, &b[b_offset], ldb, &rwork[1]);
+ ilbscl = FALSE_;
+ if (bnrm > 0.f && bnrm < smlnum) {
+ bnrmto = smlnum;
+ ilbscl = TRUE_;
+ } else if (bnrm > bignum) {
+ bnrmto = bignum;
+ ilbscl = TRUE_;
+ }
+
+ if (ilbscl) {
+ clascl_("G", &c_n1, &c_n1, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ }
+
+/* Permute the matrix to make it more nearly triangular */
+
+ ileft = 1;
+ iright = *n + 1;
+ irwork = iright + *n;
+ iwork = 1;
+ cggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &rwork[
+ ileft], &rwork[iright], &rwork[irwork], &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 1;
+ goto L10;
+ }
+
+/* Reduce B to triangular form, and initialize VSL and/or VSR */
+
+ irows = ihi + 1 - ilo;
+ icols = *n + 1 - ilo;
+ itau = iwork;
+ iwork = itau + irows;
+ i__1 = *lwork + 1 - iwork;
+ cgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
+ iwork], &i__1, &iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__3 = iwork;
+ i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 2;
+ goto L10;
+ }
+
+ i__1 = *lwork + 1 - iwork;
+ cunmqr_("L", "C", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
+ work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, &
+ iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__3 = iwork;
+ i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 3;
+ goto L10;
+ }
+
+ if (ilvsl) {
+ claset_("Full", n, n, &c_b1, &c_b2, &vsl[vsl_offset], ldvsl);
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ clacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[ilo
+ + 1 + ilo * vsl_dim1], ldvsl);
+ i__1 = *lwork + 1 - iwork;
+ cungqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, &
+ work[itau], &work[iwork], &i__1, &iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__3 = iwork;
+ i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 4;
+ goto L10;
+ }
+ }
+
+ if (ilvsr) {
+ claset_("Full", n, n, &c_b1, &c_b2, &vsr[vsr_offset], ldvsr);
+ }
+
+/* Reduce to generalized Hessenberg form */
+
+ cgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 5;
+ goto L10;
+ }
+
+/* Perform QZ algorithm, computing Schur vectors if desired */
+
+ iwork = itau;
+ i__1 = *lwork + 1 - iwork;
+ chgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[
+ b_offset], ldb, &alpha[1], &beta[1], &vsl[vsl_offset], ldvsl, &
+ vsr[vsr_offset], ldvsr, &work[iwork], &i__1, &rwork[irwork], &
+ iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__3 = iwork;
+ i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ if (iinfo > 0 && iinfo <= *n) {
+ *info = iinfo;
+ } else if (iinfo > *n && iinfo <= *n << 1) {
+ *info = iinfo - *n;
+ } else {
+ *info = *n + 6;
+ }
+ goto L10;
+ }
+
+/* Apply permutation to VSL and VSR */
+
+ if (ilvsl) {
+ cggbak_("P", "L", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &
+ vsl[vsl_offset], ldvsl, &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 7;
+ goto L10;
+ }
+ }
+ if (ilvsr) {
+ cggbak_("P", "R", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &
+ vsr[vsr_offset], ldvsr, &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 8;
+ goto L10;
+ }
+ }
+
+/* Undo scaling */
+
+ if (ilascl) {
+ clascl_("U", &c_n1, &c_n1, &anrmto, &anrm, n, n, &a[a_offset], lda, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ clascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alpha[1], n, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ }
+
+ if (ilbscl) {
+ clascl_("U", &c_n1, &c_n1, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ clascl_("G", &c_n1, &c_n1, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ }
+
+L10:
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CGEGS */
+
+} /* cgegs_ */
diff --git a/SRC/cgegv.c b/SRC/cgegv.c
new file mode 100644
index 0000000..4841b04
--- /dev/null
+++ b/SRC/cgegv.c
@@ -0,0 +1,779 @@
+/* cgegv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b29 = 1.f;
+
+/* Subroutine */ int cgegv_(char *jobvl, char *jobvr, integer *n, complex *a,
+ integer *lda, complex *b, integer *ldb, complex *alpha, complex *beta,
+ complex *vl, integer *ldvl, complex *vr, integer *ldvr, complex *
+ work, integer *lwork, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
+ vr_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer jc, nb, in, jr, nb1, nb2, nb3, ihi, ilo;
+ real eps;
+ logical ilv;
+ real absb, anrm, bnrm;
+ integer itau;
+ real temp;
+ logical ilvl, ilvr;
+ integer lopt;
+ real anrm1, anrm2, bnrm1, bnrm2, absai, scale, absar, sbeta;
+ extern logical lsame_(char *, char *);
+ integer ileft, iinfo, icols, iwork, irows;
+ extern /* Subroutine */ int cggbak_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, complex *, integer *,
+ integer *), cggbal_(char *, integer *, complex *,
+ integer *, complex *, integer *, integer *, integer *, real *,
+ real *, real *, integer *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int cgghrd_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, complex *, integer *, integer *);
+ real salfai;
+ extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, complex *, integer *, integer *), cgeqrf_(integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *, integer *);
+ real salfar;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *);
+ real safmin;
+ extern /* Subroutine */ int ctgevc_(char *, char *, logical *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, integer *, integer *, complex *, real *,
+ integer *);
+ real safmax;
+ char chtemp[1];
+ logical ldumma[1];
+ extern /* Subroutine */ int chgeqz_(char *, char *, char *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ complex *, complex *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, integer *),
+ xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ijobvl, iright;
+ logical ilimit;
+ integer ijobvr;
+ extern /* Subroutine */ int cungqr_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *);
+ integer lwkmin;
+ extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *);
+ integer irwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine CGGEV. */
+
+/* CGEGV computes the eigenvalues and, optionally, the left and/or right */
+/* eigenvectors of a complex matrix pair (A,B). */
+/* Given two square matrices A and B, */
+/* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the */
+/* eigenvalues lambda and corresponding (non-zero) eigenvectors x such */
+/* that */
+/* A*x = lambda*B*x. */
+
+/* An alternate form is to find the eigenvalues mu and corresponding */
+/* eigenvectors y such that */
+/* mu*A*y = B*y. */
+
+/* These two forms are equivalent with mu = 1/lambda and x = y if */
+/* neither lambda nor mu is zero. In order to deal with the case that */
+/* lambda or mu is zero or small, two values alpha and beta are returned */
+/* for each eigenvalue, such that lambda = alpha/beta and */
+/* mu = beta/alpha. */
+
+/* The vectors x and y in the above equations are right eigenvectors of */
+/* the matrix pair (A,B). Vectors u and v satisfying */
+/* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B */
+/* are left eigenvectors of (A,B). */
+
+/* Note: this routine performs "full balancing" on A and B -- see */
+/* "Further Details", below. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVL (input) CHARACTER*1 */
+/* = 'N': do not compute the left generalized eigenvectors; */
+/* = 'V': compute the left generalized eigenvectors (returned */
+/* in VL). */
+
+/* JOBVR (input) CHARACTER*1 */
+/* = 'N': do not compute the right generalized eigenvectors; */
+/* = 'V': compute the right generalized eigenvectors (returned */
+/* in VR). */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VL, and VR. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA, N) */
+/* On entry, the matrix A. */
+/* If JOBVL = 'V' or JOBVR = 'V', then on exit A */
+/* contains the Schur form of A from the generalized Schur */
+/* factorization of the pair (A,B) after balancing. If no */
+/* eigenvectors were computed, then only the diagonal elements */
+/* of the Schur form will be correct. See CGGHRD and CHGEQZ */
+/* for details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX array, dimension (LDB, N) */
+/* On entry, the matrix B. */
+/* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the */
+/* upper triangular matrix obtained from B in the generalized */
+/* Schur factorization of the pair (A,B) after balancing. */
+/* If no eigenvectors were computed, then only the diagonal */
+/* elements of B will be correct. See CGGHRD and CHGEQZ for */
+/* details. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* ALPHA (output) COMPLEX array, dimension (N) */
+/* The complex scalars alpha that define the eigenvalues of */
+/* GNEP. */
+
+/* BETA (output) COMPLEX array, dimension (N) */
+/* The complex scalars beta that define the eigenvalues of GNEP. */
+
+/* Together, the quantities alpha = ALPHA(j) and beta = BETA(j) */
+/* represent the j-th eigenvalue of the matrix pair (A,B), in */
+/* one of the forms lambda = alpha/beta or mu = beta/alpha. */
+/* Since either lambda or mu may overflow, they should not, */
+/* in general, be computed. */
+
+/* VL (output) COMPLEX array, dimension (LDVL,N) */
+/* If JOBVL = 'V', the left eigenvectors u(j) are stored */
+/* in the columns of VL, in the same order as their eigenvalues. */
+/* Each eigenvector is scaled so that its largest component has */
+/* abs(real part) + abs(imag. part) = 1, except for eigenvectors */
+/* corresponding to an eigenvalue with alpha = beta = 0, which */
+/* are set to zero. */
+/* Not referenced if JOBVL = 'N'. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the matrix VL. LDVL >= 1, and */
+/* if JOBVL = 'V', LDVL >= N. */
+
+/* VR (output) COMPLEX array, dimension (LDVR,N) */
+/* If JOBVR = 'V', the right eigenvectors x(j) are stored */
+/* in the columns of VR, in the same order as their eigenvalues. */
+/* Each eigenvector is scaled so that its largest component has */
+/* abs(real part) + abs(imag. part) = 1, except for eigenvectors */
+/* corresponding to an eigenvalue with alpha = beta = 0, which */
+/* are set to zero. */
+/* Not referenced if JOBVR = 'N'. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the matrix VR. LDVR >= 1, and */
+/* if JOBVR = 'V', LDVR >= N. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,2*N). */
+/* For good performance, LWORK must generally be larger. */
+/* To compute the optimal value of LWORK, call ILAENV to get */
+/* blocksizes (for CGEQRF, CUNMQR, and CUNGQR.) Then compute: */
+/* NB -- MAX of the blocksizes for CGEQRF, CUNMQR, and CUNGQR; */
+/* The optimal LWORK is MAX( 2*N, N*(NB+1) ). */
+
+/* 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. */
+
+/* RWORK (workspace/output) REAL array, dimension (8*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* =1,...,N: */
+/* The QZ iteration failed. No eigenvectors have been */
+/* calculated, but ALPHA(j) and BETA(j) should be */
+/* correct for j=INFO+1,...,N. */
+/* > N: errors that usually indicate LAPACK problems: */
+/* =N+1: error return from CGGBAL */
+/* =N+2: error return from CGEQRF */
+/* =N+3: error return from CUNMQR */
+/* =N+4: error return from CUNGQR */
+/* =N+5: error return from CGGHRD */
+/* =N+6: error return from CHGEQZ (other than failed */
+/* iteration) */
+/* =N+7: error return from CTGEVC */
+/* =N+8: error return from CGGBAK (computing VL) */
+/* =N+9: error return from CGGBAK (computing VR) */
+/* =N+10: error return from CLASCL (various calls) */
+
+/* Further Details */
+/* =============== */
+
+/* Balancing */
+/* --------- */
+
+/* This driver calls CGGBAL to both permute and scale rows and columns */
+/* of A and B. The permutations PL and PR are chosen so that PL*A*PR */
+/* and PL*B*R will be upper triangular except for the diagonal blocks */
+/* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as */
+/* possible. The diagonal scaling matrices DL and DR are chosen so */
+/* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to */
+/* one (except for the elements that start out zero.) */
+
+/* After the eigenvalues and eigenvectors of the balanced matrices */
+/* have been computed, CGGBAK transforms the eigenvectors back to what */
+/* they would have been (in perfect arithmetic) if they had not been */
+/* balanced. */
+
+/* Contents of A and B on Exit */
+/* -------- -- - --- - -- ---- */
+
+/* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or */
+/* both), then on exit the arrays A and B will contain the complex Schur */
+/* form[*] of the "balanced" versions of A and B. If no eigenvectors */
+/* are computed, then only the diagonal blocks will be correct. */
+
+/* [*] In other words, upper triangular form. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alpha;
+ --beta;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ if (lsame_(jobvl, "N")) {
+ ijobvl = 1;
+ ilvl = FALSE_;
+ } else if (lsame_(jobvl, "V")) {
+ ijobvl = 2;
+ ilvl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvl = FALSE_;
+ }
+
+ if (lsame_(jobvr, "N")) {
+ ijobvr = 1;
+ ilvr = FALSE_;
+ } else if (lsame_(jobvr, "V")) {
+ ijobvr = 2;
+ ilvr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvr = FALSE_;
+ }
+ ilv = ilvl || ilvr;
+
+/* Test the input arguments */
+
+/* Computing MAX */
+ i__1 = *n << 1;
+ lwkmin = max(i__1,1);
+ lwkopt = lwkmin;
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ lquery = *lwork == -1;
+ *info = 0;
+ if (ijobvl <= 0) {
+ *info = -1;
+ } else if (ijobvr <= 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvl < 1 || ilvl && *ldvl < *n) {
+ *info = -11;
+ } else if (*ldvr < 1 || ilvr && *ldvr < *n) {
+ *info = -13;
+ } else if (*lwork < lwkmin && ! lquery) {
+ *info = -15;
+ }
+
+ if (*info == 0) {
+ nb1 = ilaenv_(&c__1, "CGEQRF", " ", n, n, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "CUNMQR", " ", n, n, n, &c_n1);
+ nb3 = ilaenv_(&c__1, "CUNGQR", " ", n, n, n, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2);
+ nb = max(i__1,nb3);
+/* Computing MAX */
+ i__1 = *n << 1, i__2 = *n * (nb + 1);
+ lopt = max(i__1,i__2);
+ work[1].r = (real) lopt, work[1].i = 0.f;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGEGV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("E") * slamch_("B");
+ safmin = slamch_("S");
+ safmin += safmin;
+ safmax = 1.f / safmin;
+
+/* Scale A */
+
+ anrm = clange_("M", n, n, &a[a_offset], lda, &rwork[1]);
+ anrm1 = anrm;
+ anrm2 = 1.f;
+ if (anrm < 1.f) {
+ if (safmax * anrm < 1.f) {
+ anrm1 = safmin;
+ anrm2 = safmax * anrm;
+ }
+ }
+
+ if (anrm > 0.f) {
+ clascl_("G", &c_n1, &c_n1, &anrm, &c_b29, n, n, &a[a_offset], lda, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 10;
+ return 0;
+ }
+ }
+
+/* Scale B */
+
+ bnrm = clange_("M", n, n, &b[b_offset], ldb, &rwork[1]);
+ bnrm1 = bnrm;
+ bnrm2 = 1.f;
+ if (bnrm < 1.f) {
+ if (safmax * bnrm < 1.f) {
+ bnrm1 = safmin;
+ bnrm2 = safmax * bnrm;
+ }
+ }
+
+ if (bnrm > 0.f) {
+ clascl_("G", &c_n1, &c_n1, &bnrm, &c_b29, n, n, &b[b_offset], ldb, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 10;
+ return 0;
+ }
+ }
+
+/* Permute the matrix to make it more nearly triangular */
+/* Also "balance" the matrix. */
+
+ ileft = 1;
+ iright = *n + 1;
+ irwork = iright + *n;
+ cggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &rwork[
+ ileft], &rwork[iright], &rwork[irwork], &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 1;
+ goto L80;
+ }
+
+/* Reduce B to triangular form, and initialize VL and/or VR */
+
+ irows = ihi + 1 - ilo;
+ if (ilv) {
+ icols = *n + 1 - ilo;
+ } else {
+ icols = irows;
+ }
+ itau = 1;
+ iwork = itau + irows;
+ i__1 = *lwork + 1 - iwork;
+ cgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
+ iwork], &i__1, &iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__3 = iwork;
+ i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 2;
+ goto L80;
+ }
+
+ i__1 = *lwork + 1 - iwork;
+ cunmqr_("L", "C", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
+ work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, &
+ iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__3 = iwork;
+ i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 3;
+ goto L80;
+ }
+
+ if (ilvl) {
+ claset_("Full", n, n, &c_b1, &c_b2, &vl[vl_offset], ldvl);
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ clacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vl[ilo +
+ 1 + ilo * vl_dim1], ldvl);
+ i__1 = *lwork + 1 - iwork;
+ cungqr_(&irows, &irows, &irows, &vl[ilo + ilo * vl_dim1], ldvl, &work[
+ itau], &work[iwork], &i__1, &iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__3 = iwork;
+ i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 4;
+ goto L80;
+ }
+ }
+
+ if (ilvr) {
+ claset_("Full", n, n, &c_b1, &c_b2, &vr[vr_offset], ldvr);
+ }
+
+/* Reduce to generalized Hessenberg form */
+
+ if (ilv) {
+
+/* Eigenvectors requested -- work on whole matrix. */
+
+ cgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &iinfo);
+ } else {
+ cgghrd_("N", "N", &irows, &c__1, &irows, &a[ilo + ilo * a_dim1], lda,
+ &b[ilo + ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[
+ vr_offset], ldvr, &iinfo);
+ }
+ if (iinfo != 0) {
+ *info = *n + 5;
+ goto L80;
+ }
+
+/* Perform QZ algorithm */
+
+ iwork = itau;
+ if (ilv) {
+ *(unsigned char *)chtemp = 'S';
+ } else {
+ *(unsigned char *)chtemp = 'E';
+ }
+ i__1 = *lwork + 1 - iwork;
+ chgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[
+ b_offset], ldb, &alpha[1], &beta[1], &vl[vl_offset], ldvl, &vr[
+ vr_offset], ldvr, &work[iwork], &i__1, &rwork[irwork], &iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__3 = iwork;
+ i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ if (iinfo > 0 && iinfo <= *n) {
+ *info = iinfo;
+ } else if (iinfo > *n && iinfo <= *n << 1) {
+ *info = iinfo - *n;
+ } else {
+ *info = *n + 6;
+ }
+ goto L80;
+ }
+
+ if (ilv) {
+
+/* Compute Eigenvectors */
+
+ if (ilvl) {
+ if (ilvr) {
+ *(unsigned char *)chtemp = 'B';
+ } else {
+ *(unsigned char *)chtemp = 'L';
+ }
+ } else {
+ *(unsigned char *)chtemp = 'R';
+ }
+
+ ctgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb,
+ &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[
+ iwork], &rwork[irwork], &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 7;
+ goto L80;
+ }
+
+/* Undo balancing on VL and VR, rescale */
+
+ if (ilvl) {
+ cggbak_("P", "L", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n,
+ &vl[vl_offset], ldvl, &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 8;
+ goto L80;
+ }
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ temp = 0.f;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ i__3 = jr + jc * vl_dim1;
+ r__3 = temp, r__4 = (r__1 = vl[i__3].r, dabs(r__1)) + (
+ r__2 = r_imag(&vl[jr + jc * vl_dim1]), dabs(r__2))
+ ;
+ temp = dmax(r__3,r__4);
+/* L10: */
+ }
+ if (temp < safmin) {
+ goto L30;
+ }
+ temp = 1.f / temp;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = jr + jc * vl_dim1;
+ i__4 = jr + jc * vl_dim1;
+ q__1.r = temp * vl[i__4].r, q__1.i = temp * vl[i__4].i;
+ vl[i__3].r = q__1.r, vl[i__3].i = q__1.i;
+/* L20: */
+ }
+L30:
+ ;
+ }
+ }
+ if (ilvr) {
+ cggbak_("P", "R", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n,
+ &vr[vr_offset], ldvr, &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ goto L80;
+ }
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ temp = 0.f;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ i__3 = jr + jc * vr_dim1;
+ r__3 = temp, r__4 = (r__1 = vr[i__3].r, dabs(r__1)) + (
+ r__2 = r_imag(&vr[jr + jc * vr_dim1]), dabs(r__2))
+ ;
+ temp = dmax(r__3,r__4);
+/* L40: */
+ }
+ if (temp < safmin) {
+ goto L60;
+ }
+ temp = 1.f / temp;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = jr + jc * vr_dim1;
+ i__4 = jr + jc * vr_dim1;
+ q__1.r = temp * vr[i__4].r, q__1.i = temp * vr[i__4].i;
+ vr[i__3].r = q__1.r, vr[i__3].i = q__1.i;
+/* L50: */
+ }
+L60:
+ ;
+ }
+ }
+
+/* End of eigenvector calculation */
+
+ }
+
+/* Undo scaling in alpha, beta */
+
+/* Note: this does not give the alpha and beta for the unscaled */
+/* problem. */
+
+/* Un-scaling is limited to avoid underflow in alpha and beta */
+/* if they are significant. */
+
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ i__2 = jc;
+ absar = (r__1 = alpha[i__2].r, dabs(r__1));
+ absai = (r__1 = r_imag(&alpha[jc]), dabs(r__1));
+ i__2 = jc;
+ absb = (r__1 = beta[i__2].r, dabs(r__1));
+ i__2 = jc;
+ salfar = anrm * alpha[i__2].r;
+ salfai = anrm * r_imag(&alpha[jc]);
+ i__2 = jc;
+ sbeta = bnrm * beta[i__2].r;
+ ilimit = FALSE_;
+ scale = 1.f;
+
+/* Check for significant underflow in imaginary part of ALPHA */
+
+/* Computing MAX */
+ r__1 = safmin, r__2 = eps * absar, r__1 = max(r__1,r__2), r__2 = eps *
+ absb;
+ if (dabs(salfai) < safmin && absai >= dmax(r__1,r__2)) {
+ ilimit = TRUE_;
+/* Computing MAX */
+ r__1 = safmin, r__2 = anrm2 * absai;
+ scale = safmin / anrm1 / dmax(r__1,r__2);
+ }
+
+/* Check for significant underflow in real part of ALPHA */
+
+/* Computing MAX */
+ r__1 = safmin, r__2 = eps * absai, r__1 = max(r__1,r__2), r__2 = eps *
+ absb;
+ if (dabs(salfar) < safmin && absar >= dmax(r__1,r__2)) {
+ ilimit = TRUE_;
+/* Computing MAX */
+/* Computing MAX */
+ r__3 = safmin, r__4 = anrm2 * absar;
+ r__1 = scale, r__2 = safmin / anrm1 / dmax(r__3,r__4);
+ scale = dmax(r__1,r__2);
+ }
+
+/* Check for significant underflow in BETA */
+
+/* Computing MAX */
+ r__1 = safmin, r__2 = eps * absar, r__1 = max(r__1,r__2), r__2 = eps *
+ absai;
+ if (dabs(sbeta) < safmin && absb >= dmax(r__1,r__2)) {
+ ilimit = TRUE_;
+/* Computing MAX */
+/* Computing MAX */
+ r__3 = safmin, r__4 = bnrm2 * absb;
+ r__1 = scale, r__2 = safmin / bnrm1 / dmax(r__3,r__4);
+ scale = dmax(r__1,r__2);
+ }
+
+/* Check for possible overflow when limiting scaling */
+
+ if (ilimit) {
+/* Computing MAX */
+ r__1 = dabs(salfar), r__2 = dabs(salfai), r__1 = max(r__1,r__2),
+ r__2 = dabs(sbeta);
+ temp = scale * safmin * dmax(r__1,r__2);
+ if (temp > 1.f) {
+ scale /= temp;
+ }
+ if (scale < 1.f) {
+ ilimit = FALSE_;
+ }
+ }
+
+/* Recompute un-scaled ALPHA, BETA if necessary. */
+
+ if (ilimit) {
+ i__2 = jc;
+ salfar = scale * alpha[i__2].r * anrm;
+ salfai = scale * r_imag(&alpha[jc]) * anrm;
+ i__2 = jc;
+ q__2.r = scale * beta[i__2].r, q__2.i = scale * beta[i__2].i;
+ q__1.r = bnrm * q__2.r, q__1.i = bnrm * q__2.i;
+ sbeta = q__1.r;
+ }
+ i__2 = jc;
+ q__1.r = salfar, q__1.i = salfai;
+ alpha[i__2].r = q__1.r, alpha[i__2].i = q__1.i;
+ i__2 = jc;
+ beta[i__2].r = sbeta, beta[i__2].i = 0.f;
+/* L70: */
+ }
+
+L80:
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CGEGV */
+
+} /* cgegv_ */
diff --git a/SRC/cgehd2.c b/SRC/cgehd2.c
new file mode 100644
index 0000000..8cbc13f
--- /dev/null
+++ b/SRC/cgehd2.c
@@ -0,0 +1,198 @@
+/* cgehd2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cgehd2_(integer *n, integer *ilo, integer *ihi, complex *
+ a, integer *lda, complex *tau, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ complex q__1;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__;
+ complex alpha;
+ extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
+, integer *, complex *, complex *, integer *, complex *),
+ clarfg_(integer *, complex *, complex *, integer *, complex *),
+ xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGEHD2 reduces a complex general matrix A to upper Hessenberg form H */
+/* by a unitary similarity transformation: Q' * A * Q = H . */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that A is already upper triangular in rows */
+/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
+/* set by a previous call to CGEBAL; otherwise they should be */
+/* set to 1 and N respectively. See Further Details. */
+/* 1 <= ILO <= IHI <= max(1,N). */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the n by n general matrix to be reduced. */
+/* On exit, the upper triangle and the first subdiagonal of A */
+/* are overwritten with the upper Hessenberg matrix H, and the */
+/* elements below the first subdiagonal, with the array TAU, */
+/* represent the unitary matrix Q as a product of elementary */
+/* reflectors. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAU (output) COMPLEX array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of (ihi-ilo) elementary */
+/* reflectors */
+
+/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */
+/* exit in A(i+2:ihi,i), and tau in TAU(i). */
+
+/* The contents of A are illustrated by the following example, with */
+/* n = 7, ilo = 2 and ihi = 6: */
+
+/* on entry, on exit, */
+
+/* ( a a a a a a a ) ( a a h h h h a ) */
+/* ( a a a a a a ) ( a h h h h a ) */
+/* ( a a a a a a ) ( h h h h h h ) */
+/* ( a a a a a a ) ( v2 h h h h h ) */
+/* ( a a a a a a ) ( v2 v3 h h h h ) */
+/* ( a a a a a a ) ( v2 v3 v4 h h h ) */
+/* ( a ) ( a ) */
+
+/* where a denotes an element of the original matrix A, h denotes a */
+/* modified element of the upper Hessenberg matrix H, and vi denotes an */
+/* element of the vector defining H(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*ilo < 1 || *ilo > max(1,*n)) {
+ *info = -2;
+ } else if (*ihi < min(*ilo,*n) || *ihi > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGEHD2", &i__1);
+ return 0;
+ }
+
+ i__1 = *ihi - 1;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+
+/* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) */
+
+ i__2 = i__ + 1 + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *ihi - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ clarfg_(&i__2, &alpha, &a[min(i__3, *n)+ i__ * a_dim1], &c__1, &tau[
+ i__]);
+ i__2 = i__ + 1 + i__ * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+
+/* Apply H(i) to A(1:ihi,i+1:ihi) from the right */
+
+ i__2 = *ihi - i__;
+ clarf_("Right", ihi, &i__2, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
+ i__], &a[(i__ + 1) * a_dim1 + 1], lda, &work[1]);
+
+/* Apply H(i)' to A(i+1:ihi,i+1:n) from the left */
+
+ i__2 = *ihi - i__;
+ i__3 = *n - i__;
+ r_cnjg(&q__1, &tau[i__]);
+ clarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &q__1,
+ &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1]);
+
+ i__2 = i__ + 1 + i__ * a_dim1;
+ a[i__2].r = alpha.r, a[i__2].i = alpha.i;
+/* L10: */
+ }
+
+ return 0;
+
+/* End of CGEHD2 */
+
+} /* cgehd2_ */
diff --git a/SRC/cgehrd.c b/SRC/cgehrd.c
new file mode 100644
index 0000000..0cf4b2d
--- /dev/null
+++ b/SRC/cgehrd.c
@@ -0,0 +1,350 @@
+/* cgehrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int cgehrd_(integer *n, integer *ilo, integer *ihi, complex *
+ a, integer *lda, complex *tau, complex *work, integer *lwork, integer
+ *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j;
+ complex t[4160] /* was [65][64] */;
+ integer ib;
+ complex ei;
+ integer nb, nh, nx, iws;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *), caxpy_(integer *,
+ complex *, complex *, integer *, complex *, integer *), cgehd2_(
+ integer *, integer *, integer *, complex *, integer *, complex *,
+ complex *, integer *), clahr2_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, complex *,
+ integer *), clarfb_(char *, char *, char *, char *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, complex *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGEHRD reduces a complex general matrix A to upper Hessenberg form H by */
+/* an unitary similarity transformation: Q' * A * Q = H . */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that A is already upper triangular in rows */
+/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
+/* set by a previous call to CGEBAL; otherwise they should be */
+/* set to 1 and N respectively. See Further Details. */
+/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N general matrix to be reduced. */
+/* On exit, the upper triangle and the first subdiagonal of A */
+/* are overwritten with the upper Hessenberg matrix H, and the */
+/* elements below the first subdiagonal, with the array TAU, */
+/* represent the unitary matrix Q as a product of elementary */
+/* reflectors. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAU (output) COMPLEX array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to */
+/* zero. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(1,N). */
+/* For optimum performance LWORK >= N*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of (ihi-ilo) elementary */
+/* reflectors */
+
+/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */
+/* exit in A(i+2:ihi,i), and tau in TAU(i). */
+
+/* The contents of A are illustrated by the following example, with */
+/* n = 7, ilo = 2 and ihi = 6: */
+
+/* on entry, on exit, */
+
+/* ( a a a a a a a ) ( a a h h h h a ) */
+/* ( a a a a a a ) ( a h h h h a ) */
+/* ( a a a a a a ) ( h h h h h h ) */
+/* ( a a a a a a ) ( v2 h h h h h ) */
+/* ( a a a a a a ) ( v2 v3 h h h h ) */
+/* ( a a a a a a ) ( v2 v3 v4 h h h ) */
+/* ( a ) ( a ) */
+
+/* where a denotes an element of the original matrix A, h denotes a */
+/* modified element of the upper Hessenberg matrix H, and vi denotes an */
+/* element of the vector defining H(i). */
+
+/* This file is a slight modification of LAPACK-3.0's CGEHRD */
+/* subroutine incorporating improvements proposed by Quintana-Orti and */
+/* Van de Geijn (2005). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+/* Computing MIN */
+ i__1 = 64, i__2 = ilaenv_(&c__1, "CGEHRD", " ", n, ilo, ihi, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = *n * nb;
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ lquery = *lwork == -1;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*ilo < 1 || *ilo > max(1,*n)) {
+ *info = -2;
+ } else if (*ihi < min(*ilo,*n) || *ihi > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGEHRD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero */
+
+ i__1 = *ilo - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ tau[i__2].r = 0.f, tau[i__2].i = 0.f;
+/* L10: */
+ }
+ i__1 = *n - 1;
+ for (i__ = max(1,*ihi); i__ <= i__1; ++i__) {
+ i__2 = i__;
+ tau[i__2].r = 0.f, tau[i__2].i = 0.f;
+/* L20: */
+ }
+
+/* Quick return if possible */
+
+ nh = *ihi - *ilo + 1;
+ if (nh <= 1) {
+ work[1].r = 1.f, work[1].i = 0.f;
+ return 0;
+ }
+
+/* Determine the block size */
+
+/* Computing MIN */
+ i__1 = 64, i__2 = ilaenv_(&c__1, "CGEHRD", " ", n, ilo, ihi, &c_n1);
+ nb = min(i__1,i__2);
+ nbmin = 2;
+ iws = 1;
+ if (nb > 1 && nb < nh) {
+
+/* Determine when to cross over from blocked to unblocked code */
+/* (last block is always handled by unblocked code) */
+
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__3, "CGEHRD", " ", n, ilo, ihi, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < nh) {
+
+/* Determine if workspace is large enough for blocked code */
+
+ iws = *n * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: determine the */
+/* minimum value of NB, and reduce NB or force use of */
+/* unblocked code */
+
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "CGEHRD", " ", n, ilo, ihi, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ if (*lwork >= *n * nbmin) {
+ nb = *lwork / *n;
+ } else {
+ nb = 1;
+ }
+ }
+ }
+ }
+ ldwork = *n;
+
+ if (nb < nbmin || nb >= nh) {
+
+/* Use unblocked code below */
+
+ i__ = *ilo;
+
+ } else {
+
+/* Use blocked code */
+
+ i__1 = *ihi - 1 - nx;
+ i__2 = nb;
+ for (i__ = *ilo; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *ihi - i__;
+ ib = min(i__3,i__4);
+
+/* Reduce columns i:i+ib-1 to Hessenberg form, returning the */
+/* matrices V and T of the block reflector H = I - V*T*V' */
+/* which performs the reduction, and also the matrix Y = A*V*T */
+
+ clahr2_(ihi, &i__, &ib, &a[i__ * a_dim1 + 1], lda, &tau[i__], t, &
+ c__65, &work[1], &ldwork);
+
+/* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the */
+/* right, computing A := A - Y * V'. V(i+ib,ib-1) must be set */
+/* to 1 */
+
+ i__3 = i__ + ib + (i__ + ib - 1) * a_dim1;
+ ei.r = a[i__3].r, ei.i = a[i__3].i;
+ i__3 = i__ + ib + (i__ + ib - 1) * a_dim1;
+ a[i__3].r = 1.f, a[i__3].i = 0.f;
+ i__3 = *ihi - i__ - ib + 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "Conjugate transpose", ihi, &i__3, &ib, &
+ q__1, &work[1], &ldwork, &a[i__ + ib + i__ * a_dim1], lda,
+ &c_b2, &a[(i__ + ib) * a_dim1 + 1], lda);
+ i__3 = i__ + ib + (i__ + ib - 1) * a_dim1;
+ a[i__3].r = ei.r, a[i__3].i = ei.i;
+
+/* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the */
+/* right */
+
+ i__3 = ib - 1;
+ ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", &i__, &
+ i__3, &c_b2, &a[i__ + 1 + i__ * a_dim1], lda, &work[1], &
+ ldwork);
+ i__3 = ib - 2;
+ for (j = 0; j <= i__3; ++j) {
+ q__1.r = -1.f, q__1.i = -0.f;
+ caxpy_(&i__, &q__1, &work[ldwork * j + 1], &c__1, &a[(i__ + j
+ + 1) * a_dim1 + 1], &c__1);
+/* L30: */
+ }
+
+/* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the */
+/* left */
+
+ i__3 = *ihi - i__;
+ i__4 = *n - i__ - ib + 1;
+ clarfb_("Left", "Conjugate transpose", "Forward", "Columnwise", &
+ i__3, &i__4, &ib, &a[i__ + 1 + i__ * a_dim1], lda, t, &
+ c__65, &a[i__ + 1 + (i__ + ib) * a_dim1], lda, &work[1], &
+ ldwork);
+/* L40: */
+ }
+ }
+
+/* Use unblocked code to reduce the rest of the matrix */
+
+ cgehd2_(n, &i__, ihi, &a[a_offset], lda, &tau[1], &work[1], &iinfo);
+ work[1].r = (real) iws, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CGEHRD */
+
+} /* cgehrd_ */
diff --git a/SRC/cgelq2.c b/SRC/cgelq2.c
new file mode 100644
index 0000000..04a23f8
--- /dev/null
+++ b/SRC/cgelq2.c
@@ -0,0 +1,165 @@
+/* cgelq2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cgelq2_(integer *m, integer *n, complex *a, integer *lda,
+ complex *tau, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, k;
+ complex alpha;
+ extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
+, integer *, complex *, complex *, integer *, complex *),
+ clacgv_(integer *, complex *, integer *), clarfp_(integer *,
+ complex *, complex *, integer *, complex *), xerbla_(char *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGELQ2 computes an LQ factorization of a complex m by n matrix A: */
+/* A = L * Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the m by n matrix A. */
+/* On exit, the elements on and below the diagonal of the array */
+/* contain the m by min(m,n) lower trapezoidal matrix L (L is */
+/* lower triangular if m <= n); the elements above the diagonal, */
+/* with the array TAU, represent the unitary matrix Q as a */
+/* product of elementary reflectors (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace) COMPLEX array, dimension (M) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(k)' . . . H(2)' H(1)', where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in */
+/* A(i,i+1:n), and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGELQ2", &i__1);
+ return 0;
+ }
+
+ k = min(*m,*n);
+
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Generate elementary reflector H(i) to annihilate A(i,i+1:n) */
+
+ i__2 = *n - i__ + 1;
+ clacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
+ i__2 = i__ + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *n - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ clarfp_(&i__2, &alpha, &a[i__ + min(i__3, *n)* a_dim1], lda, &tau[i__]
+);
+ if (i__ < *m) {
+
+/* Apply H(i) to A(i+1:m,i:n) from the right */
+
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+ i__2 = *m - i__;
+ i__3 = *n - i__ + 1;
+ clarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[
+ i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]);
+ }
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = alpha.r, a[i__2].i = alpha.i;
+ i__2 = *n - i__ + 1;
+ clacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
+/* L10: */
+ }
+ return 0;
+
+/* End of CGELQ2 */
+
+} /* cgelq2_ */
diff --git a/SRC/cgelqf.c b/SRC/cgelqf.c
new file mode 100644
index 0000000..9c62f96
--- /dev/null
+++ b/SRC/cgelqf.c
@@ -0,0 +1,252 @@
+/* cgelqf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int cgelqf_(integer *m, integer *n, complex *a, integer *lda,
+ complex *tau, complex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, k, ib, nb, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int cgelq2_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *), clarfb_(char *, char
+ *, char *, char *, integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *), clarft_(char *, char *
+, integer *, integer *, complex *, integer *, complex *, complex *
+, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGELQF computes an LQ factorization of a complex M-by-N matrix A: */
+/* A = L * Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the elements on and below the diagonal of the array */
+/* contain the m-by-min(m,n) lower trapezoidal matrix L (L is */
+/* lower triangular if m <= n); the elements above the diagonal, */
+/* with the array TAU, represent the unitary matrix Q as a */
+/* product of elementary reflectors (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M). */
+/* For optimum performance LWORK >= M*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(k)' . . . H(2)' H(1)', where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in */
+/* A(i,i+1:n), and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb = ilaenv_(&c__1, "CGELQF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = *m * nb;
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ } else if (*lwork < max(1,*m) && ! lquery) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGELQF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ k = min(*m,*n);
+ if (k == 0) {
+ work[1].r = 1.f, work[1].i = 0.f;
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *m;
+ if (nb > 1 && nb < k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "CGELQF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *m;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "CGELQF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < k && nx < k) {
+
+/* Use blocked code initially */
+
+ i__1 = k - nx;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = k - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Compute the LQ factorization of the current block */
+/* A(i:i+ib-1,i:n) */
+
+ i__3 = *n - i__ + 1;
+ cgelq2_(&ib, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
+ 1], &iinfo);
+ if (i__ + ib <= *m) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__3 = *n - i__ + 1;
+ clarft_("Forward", "Rowwise", &i__3, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H to A(i+ib:m,i:n) from the right */
+
+ i__3 = *m - i__ - ib + 1;
+ i__4 = *n - i__ + 1;
+ clarfb_("Right", "No transpose", "Forward", "Rowwise", &i__3,
+ &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
+ ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib +
+ 1], &ldwork);
+ }
+/* L10: */
+ }
+ } else {
+ i__ = 1;
+ }
+
+/* Use unblocked code to factor the last or only block. */
+
+ if (i__ <= k) {
+ i__2 = *m - i__ + 1;
+ i__1 = *n - i__ + 1;
+ cgelq2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
+, &iinfo);
+ }
+
+ work[1].r = (real) iws, work[1].i = 0.f;
+ return 0;
+
+/* End of CGELQF */
+
+} /* cgelqf_ */
diff --git a/SRC/cgels.c b/SRC/cgels.c
new file mode 100644
index 0000000..3385ab8
--- /dev/null
+++ b/SRC/cgels.c
@@ -0,0 +1,520 @@
+/* cgels.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+
+/* Subroutine */ int cgels_(char *trans, integer *m, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *b, integer *ldb, complex *
+ work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j, nb, mn;
+ real anrm, bnrm;
+ integer brow;
+ logical tpsd;
+ integer iascl, ibscl;
+ extern logical lsame_(char *, char *);
+ integer wsize;
+ real rwork[1];
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int cgelqf_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *), clascl_(
+ char *, integer *, integer *, real *, real *, integer *, integer *
+, complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int cgeqrf_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *), claset_(
+ char *, integer *, integer *, complex *, complex *, complex *,
+ integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer scllen;
+ real bignum;
+ extern /* Subroutine */ int cunmlq_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *), cunmqr_(char *,
+ char *, integer *, integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *, complex *, integer *, integer *);
+ real smlnum;
+ logical lquery;
+ extern /* Subroutine */ int ctrtrs_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGELS solves overdetermined or underdetermined complex linear systems */
+/* involving an M-by-N matrix A, or its conjugate-transpose, using a QR */
+/* or LQ factorization of A. It is assumed that A has full rank. */
+
+/* The following options are provided: */
+
+/* 1. If TRANS = 'N' and m >= n: find the least squares solution of */
+/* an overdetermined system, i.e., solve the least squares problem */
+/* minimize || B - A*X ||. */
+
+/* 2. If TRANS = 'N' and m < n: find the minimum norm solution of */
+/* an underdetermined system A * X = B. */
+
+/* 3. If TRANS = 'C' and m >= n: find the minimum norm solution of */
+/* an undetermined system A**H * X = B. */
+
+/* 4. If TRANS = 'C' and m < n: find the least squares solution of */
+/* an overdetermined system, i.e., solve the least squares problem */
+/* minimize || B - A**H * X ||. */
+
+/* Several right hand side vectors b and solution vectors x can be */
+/* handled in a single call; they are stored as the columns of the */
+/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
+/* matrix X. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': the linear system involves A; */
+/* = 'C': the linear system involves A**H. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of */
+/* columns of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* if M >= N, A is overwritten by details of its QR */
+/* factorization as returned by CGEQRF; */
+/* if M < N, A is overwritten by details of its LQ */
+/* factorization as returned by CGELQF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the matrix B of right hand side vectors, stored */
+/* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS */
+/* if TRANS = 'C'. */
+/* On exit, if INFO = 0, B is overwritten by the solution */
+/* vectors, stored columnwise: */
+/* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least */
+/* squares solution vectors; the residual sum of squares for the */
+/* solution in each column is given by the sum of squares of the */
+/* modulus of elements N+1 to M in that column; */
+/* if TRANS = 'N' and m < n, rows 1 to N of B contain the */
+/* minimum norm solution vectors; */
+/* if TRANS = 'C' and m >= n, rows 1 to M of B contain the */
+/* minimum norm solution vectors; */
+/* if TRANS = 'C' and m < n, rows 1 to M of B contain the */
+/* least squares solution vectors; the residual sum of squares */
+/* for the solution in each column is given by the sum of */
+/* squares of the modulus of elements M+1 to N in that column. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= MAX(1,M,N). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* LWORK >= max( 1, MN + max( MN, NRHS ) ). */
+/* For optimal performance, */
+/* LWORK >= max( 1, MN + max( MN, NRHS )*NB ). */
+/* where MN = min(M,N) and NB is the optimum block size. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element of the */
+/* triangular factor of A is zero, so that A does not have */
+/* full rank; the least squares solution could not be */
+/* computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ mn = min(*m,*n);
+ lquery = *lwork == -1;
+ if (! (lsame_(trans, "N") || lsame_(trans, "C"))) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -6;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ if (*ldb < max(i__1,*n)) {
+ *info = -8;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = 1, i__2 = mn + max(mn,*nrhs);
+ if (*lwork < max(i__1,i__2) && ! lquery) {
+ *info = -10;
+ }
+ }
+ }
+
+/* Figure out optimal block size */
+
+ if (*info == 0 || *info == -10) {
+
+ tpsd = TRUE_;
+ if (lsame_(trans, "N")) {
+ tpsd = FALSE_;
+ }
+
+ if (*m >= *n) {
+ nb = ilaenv_(&c__1, "CGEQRF", " ", m, n, &c_n1, &c_n1);
+ if (tpsd) {
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "CUNMQR", "LN", m, nrhs, n, &
+ c_n1);
+ nb = max(i__1,i__2);
+ } else {
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "CUNMQR", "LC", m, nrhs, n, &
+ c_n1);
+ nb = max(i__1,i__2);
+ }
+ } else {
+ nb = ilaenv_(&c__1, "CGELQF", " ", m, n, &c_n1, &c_n1);
+ if (tpsd) {
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "CUNMLQ", "LC", n, nrhs, m, &
+ c_n1);
+ nb = max(i__1,i__2);
+ } else {
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "CUNMLQ", "LN", n, nrhs, m, &
+ c_n1);
+ nb = max(i__1,i__2);
+ }
+ }
+
+/* Computing MAX */
+ i__1 = 1, i__2 = mn + max(mn,*nrhs) * nb;
+ wsize = max(i__1,i__2);
+ r__1 = (real) wsize;
+ work[1].r = r__1, work[1].i = 0.f;
+
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGELS ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+/* Computing MIN */
+ i__1 = min(*m,*n);
+ if (min(i__1,*nrhs) == 0) {
+ i__1 = max(*m,*n);
+ claset_("Full", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ smlnum = slamch_("S") / slamch_("P");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Scale A, B if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = clange_("M", m, n, &a[a_offset], lda, rwork);
+ iascl = 0;
+ if (anrm > 0.f && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ clascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ clascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 2;
+ } else if (anrm == 0.f) {
+
+/* Matrix all zero. Return zero solution. */
+
+ i__1 = max(*m,*n);
+ claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+ goto L50;
+ }
+
+ brow = *m;
+ if (tpsd) {
+ brow = *n;
+ }
+ bnrm = clange_("M", &brow, nrhs, &b[b_offset], ldb, rwork);
+ ibscl = 0;
+ if (bnrm > 0.f && bnrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ clascl_("G", &c__0, &c__0, &bnrm, &smlnum, &brow, nrhs, &b[b_offset],
+ ldb, info);
+ ibscl = 1;
+ } else if (bnrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ clascl_("G", &c__0, &c__0, &bnrm, &bignum, &brow, nrhs, &b[b_offset],
+ ldb, info);
+ ibscl = 2;
+ }
+
+ if (*m >= *n) {
+
+/* compute QR factorization of A */
+
+ i__1 = *lwork - mn;
+ cgeqrf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
+ ;
+
+/* workspace at least N, optimally N*NB */
+
+ if (! tpsd) {
+
+/* Least-Squares Problem min || A * X - B || */
+
+/* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */
+
+ i__1 = *lwork - mn;
+ cunmqr_("Left", "Conjugate transpose", m, nrhs, n, &a[a_offset],
+ lda, &work[1], &b[b_offset], ldb, &work[mn + 1], &i__1,
+ info);
+
+/* workspace at least NRHS, optimally NRHS*NB */
+
+/* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) */
+
+ ctrtrs_("Upper", "No transpose", "Non-unit", n, nrhs, &a[a_offset]
+, lda, &b[b_offset], ldb, info);
+
+ if (*info > 0) {
+ return 0;
+ }
+
+ scllen = *n;
+
+ } else {
+
+/* Overdetermined system of equations A' * X = B */
+
+/* B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS) */
+
+ ctrtrs_("Upper", "Conjugate transpose", "Non-unit", n, nrhs, &a[
+ a_offset], lda, &b[b_offset], ldb, info);
+
+ if (*info > 0) {
+ return 0;
+ }
+
+/* B(N+1:M,1:NRHS) = ZERO */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = *n + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0.f, b[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) */
+
+ i__1 = *lwork - mn;
+ cunmqr_("Left", "No transpose", m, nrhs, n, &a[a_offset], lda, &
+ work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
+
+/* workspace at least NRHS, optimally NRHS*NB */
+
+ scllen = *m;
+
+ }
+
+ } else {
+
+/* Compute LQ factorization of A */
+
+ i__1 = *lwork - mn;
+ cgelqf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
+ ;
+
+/* workspace at least M, optimally M*NB. */
+
+ if (! tpsd) {
+
+/* underdetermined system of equations A * X = B */
+
+/* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) */
+
+ ctrtrs_("Lower", "No transpose", "Non-unit", m, nrhs, &a[a_offset]
+, lda, &b[b_offset], ldb, info);
+
+ if (*info > 0) {
+ return 0;
+ }
+
+/* B(M+1:N,1:NRHS) = 0 */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = *m + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0.f, b[i__3].i = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS) */
+
+ i__1 = *lwork - mn;
+ cunmlq_("Left", "Conjugate transpose", n, nrhs, m, &a[a_offset],
+ lda, &work[1], &b[b_offset], ldb, &work[mn + 1], &i__1,
+ info);
+
+/* workspace at least NRHS, optimally NRHS*NB */
+
+ scllen = *n;
+
+ } else {
+
+/* overdetermined system min || A' * X - B || */
+
+/* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) */
+
+ i__1 = *lwork - mn;
+ cunmlq_("Left", "No transpose", n, nrhs, m, &a[a_offset], lda, &
+ work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
+
+/* workspace at least NRHS, optimally NRHS*NB */
+
+/* B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS) */
+
+ ctrtrs_("Lower", "Conjugate transpose", "Non-unit", m, nrhs, &a[
+ a_offset], lda, &b[b_offset], ldb, info);
+
+ if (*info > 0) {
+ return 0;
+ }
+
+ scllen = *m;
+
+ }
+
+ }
+
+/* Undo scaling */
+
+ if (iascl == 1) {
+ clascl_("G", &c__0, &c__0, &anrm, &smlnum, &scllen, nrhs, &b[b_offset]
+, ldb, info);
+ } else if (iascl == 2) {
+ clascl_("G", &c__0, &c__0, &anrm, &bignum, &scllen, nrhs, &b[b_offset]
+, ldb, info);
+ }
+ if (ibscl == 1) {
+ clascl_("G", &c__0, &c__0, &smlnum, &bnrm, &scllen, nrhs, &b[b_offset]
+, ldb, info);
+ } else if (ibscl == 2) {
+ clascl_("G", &c__0, &c__0, &bignum, &bnrm, &scllen, nrhs, &b[b_offset]
+, ldb, info);
+ }
+
+L50:
+ r__1 = (real) wsize;
+ work[1].r = r__1, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CGELS */
+
+} /* cgels_ */
diff --git a/SRC/cgelsd.c b/SRC/cgelsd.c
new file mode 100644
index 0000000..c949a93
--- /dev/null
+++ b/SRC/cgelsd.c
@@ -0,0 +1,717 @@
+/* cgelsd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static integer c__9 = 9;
+static integer c__0 = 0;
+static integer c__6 = 6;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static real c_b80 = 0.f;
+
+/* Subroutine */ int cgelsd_(integer *m, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *b, integer *ldb, real *s, real *rcond,
+ integer *rank, complex *work, integer *lwork, real *rwork, integer *
+ iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ double log(doublereal);
+
+ /* Local variables */
+ integer ie, il, mm;
+ real eps, anrm, bnrm;
+ integer itau, nlvl, iascl, ibscl;
+ real sfmin;
+ integer minmn, maxmn, itaup, itauq, mnthr, nwork;
+ extern /* Subroutine */ int cgebrd_(integer *, integer *, complex *,
+ integer *, real *, real *, complex *, complex *, complex *,
+ integer *, integer *), slabad_(real *, real *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int cgelqf_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *), clalsd_(
+ char *, integer *, integer *, integer *, real *, real *, complex *
+, integer *, real *, integer *, complex *, real *, integer *,
+ integer *), clascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, complex *, integer *, integer *), cgeqrf_(integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ real bignum;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *), cunmbr_(char *, char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *), slaset_(
+ char *, integer *, integer *, real *, real *, real *, integer *), cunmlq_(char *, char *, integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, complex *,
+ integer *, integer *);
+ integer ldwork;
+ extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *);
+ integer liwork, minwrk, maxwrk;
+ real smlnum;
+ integer lrwork;
+ logical lquery;
+ integer nrwork, smlsiz;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGELSD computes the minimum-norm solution to a real linear least */
+/* squares problem: */
+/* minimize 2-norm(| b - A*x |) */
+/* using the singular value decomposition (SVD) of A. A is an M-by-N */
+/* matrix which may be rank-deficient. */
+
+/* Several right hand side vectors b and solution vectors x can be */
+/* handled in a single call; they are stored as the columns of the */
+/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
+/* matrix X. */
+
+/* The problem is solved in three steps: */
+/* (1) Reduce the coefficient matrix A to bidiagonal form with */
+/* Householder tranformations, reducing the original problem */
+/* into a "bidiagonal least squares problem" (BLS) */
+/* (2) Solve the BLS using a divide and conquer approach. */
+/* (3) Apply back all the Householder tranformations to solve */
+/* the original least squares problem. */
+
+/* The effective rank of A is determined by treating as zero those */
+/* singular values which are less than RCOND times the largest singular */
+/* value. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A has been destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the M-by-NRHS right hand side matrix B. */
+/* On exit, B is overwritten by the N-by-NRHS solution matrix X. */
+/* If m >= n and RANK = n, the residual sum-of-squares for */
+/* the solution in the i-th column is given by the sum of */
+/* squares of the modulus of elements n+1:m in that column. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M,N). */
+
+/* S (output) REAL array, dimension (min(M,N)) */
+/* The singular values of A in decreasing order. */
+/* The condition number of A in the 2-norm = S(1)/S(min(m,n)). */
+
+/* RCOND (input) REAL */
+/* RCOND is used to determine the effective rank of A. */
+/* Singular values S(i) <= RCOND*S(1) are treated as zero. */
+/* If RCOND < 0, machine precision is used instead. */
+
+/* RANK (output) INTEGER */
+/* The effective rank of A, i.e., the number of singular values */
+/* which are greater than RCOND*S(1). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK must be at least 1. */
+/* The exact minimum amount of workspace needed depends on M, */
+/* N and NRHS. As long as LWORK is at least */
+/* 2 * N + N * NRHS */
+/* if M is greater than or equal to N or */
+/* 2 * M + M * NRHS */
+/* if M is less than N, the code will execute correctly. */
+/* For good performance, LWORK should generally be larger. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal size of the array WORK and the */
+/* minimum sizes of the arrays RWORK and IWORK, and returns */
+/* these values as the first entries of the WORK, RWORK and */
+/* IWORK arrays, and no error message related to LWORK is issued */
+/* by XERBLA. */
+
+/* RWORK (workspace) REAL array, dimension (MAX(1,LRWORK)) */
+/* LRWORK >= */
+/* 10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS + */
+/* (SMLSIZ+1)**2 */
+/* if M is greater than or equal to N or */
+/* 10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS + */
+/* (SMLSIZ+1)**2 */
+/* if M is less than N, the code will execute correctly. */
+/* SMLSIZ is returned by ILAENV and is equal to the maximum */
+/* size of the subproblems at the bottom of the computation */
+/* tree (usually about 25), and */
+/* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) */
+/* On exit, if INFO = 0, RWORK(1) returns the minimum LRWORK. */
+
+/* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN), */
+/* where MINMN = MIN( M,N ). */
+/* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: the algorithm for computing the SVD failed to converge; */
+/* if INFO = i, i off-diagonal elements of an intermediate */
+/* bidiagonal form did not converge to zero. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */
+/* California at Berkeley, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --s;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ minmn = min(*m,*n);
+ maxmn = max(*m,*n);
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,maxmn)) {
+ *info = -7;
+ }
+
+/* Compute workspace. */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ if (*info == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ liwork = 1;
+ lrwork = 1;
+ if (minmn > 0) {
+ smlsiz = ilaenv_(&c__9, "CGELSD", " ", &c__0, &c__0, &c__0, &c__0);
+ mnthr = ilaenv_(&c__6, "CGELSD", " ", m, n, nrhs, &c_n1);
+/* Computing MAX */
+ i__1 = (integer) (log((real) minmn / (real) (smlsiz + 1)) / log(
+ 2.f)) + 1;
+ nlvl = max(i__1,0);
+ liwork = minmn * 3 * nlvl + minmn * 11;
+ mm = *m;
+ if (*m >= *n && *m >= mnthr) {
+
+/* Path 1a - overdetermined, with many more rows than */
+/* columns. */
+
+ mm = *n;
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * ilaenv_(&c__1, "CGEQRF", " ", m, n,
+ &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *nrhs * ilaenv_(&c__1, "CUNMQR", "LC",
+ m, nrhs, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ }
+ if (*m >= *n) {
+
+/* Path 1 - overdetermined or exactly determined. */
+
+/* Computing 2nd power */
+ i__1 = smlsiz + 1;
+ lrwork = *n * 10 + (*n << 1) * smlsiz + (*n << 3) * nlvl +
+ smlsiz * 3 * *nrhs + i__1 * i__1;
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + (mm + *n) * ilaenv_(&c__1,
+ "CGEBRD", " ", &mm, n, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *nrhs * ilaenv_(&c__1,
+ "CUNMBR", "QLC", &mm, nrhs, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
+ "CUNMBR", "PLN", n, nrhs, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *n * *nrhs;
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = (*n << 1) + mm, i__2 = (*n << 1) + *n * *nrhs;
+ minwrk = max(i__1,i__2);
+ }
+ if (*n > *m) {
+/* Computing 2nd power */
+ i__1 = smlsiz + 1;
+ lrwork = *m * 10 + (*m << 1) * smlsiz + (*m << 3) * nlvl +
+ smlsiz * 3 * *nrhs + i__1 * i__1;
+ if (*n >= mnthr) {
+
+/* Path 2a - underdetermined, with many more columns */
+/* than rows. */
+
+ maxwrk = *m + *m * ilaenv_(&c__1, "CGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) *
+ ilaenv_(&c__1, "CGEBRD", " ", m, m, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs *
+ ilaenv_(&c__1, "CUNMBR", "QLC", m, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) *
+ ilaenv_(&c__1, "CUNMLQ", "LC", n, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+ if (*nrhs > 1) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs;
+ maxwrk = max(i__1,i__2);
+ } else {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 1);
+ maxwrk = max(i__1,i__2);
+ }
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *m * *nrhs;
+ maxwrk = max(i__1,i__2);
+/* XXX: Ensure the Path 2a case below is triggered. The workspace */
+/* calculation should use queries for all routines eventually. */
+/* Computing MAX */
+/* Computing MAX */
+ i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4),
+ i__3 = max(i__3,*nrhs), i__4 = *n - *m * 3;
+ i__1 = maxwrk, i__2 = (*m << 2) + *m * *m + max(i__3,i__4)
+ ;
+ maxwrk = max(i__1,i__2);
+ } else {
+
+/* Path 2 - underdetermined. */
+
+ maxwrk = (*m << 1) + (*n + *m) * ilaenv_(&c__1, "CGEBRD",
+ " ", m, n, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *nrhs * ilaenv_(&c__1,
+ "CUNMBR", "QLC", m, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNMBR", "PLN", n, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * *nrhs;
+ maxwrk = max(i__1,i__2);
+ }
+/* Computing MAX */
+ i__1 = (*m << 1) + *n, i__2 = (*m << 1) + *m * *nrhs;
+ minwrk = max(i__1,i__2);
+ }
+ }
+ minwrk = min(minwrk,maxwrk);
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+ iwork[1] = liwork;
+ rwork[1] = (real) lrwork;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGELSD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ *rank = 0;
+ return 0;
+ }
+
+/* Get machine parameters. */
+
+ eps = slamch_("P");
+ sfmin = slamch_("S");
+ smlnum = sfmin / eps;
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Scale A if max entry outside range [SMLNUM,BIGNUM]. */
+
+ anrm = clange_("M", m, n, &a[a_offset], lda, &rwork[1]);
+ iascl = 0;
+ if (anrm > 0.f && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ clascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM. */
+
+ clascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 2;
+ } else if (anrm == 0.f) {
+
+/* Matrix all zero. Return zero solution. */
+
+ i__1 = max(*m,*n);
+ claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+ slaset_("F", &minmn, &c__1, &c_b80, &c_b80, &s[1], &c__1);
+ *rank = 0;
+ goto L10;
+ }
+
+/* Scale B if max entry outside range [SMLNUM,BIGNUM]. */
+
+ bnrm = clange_("M", m, nrhs, &b[b_offset], ldb, &rwork[1]);
+ ibscl = 0;
+ if (bnrm > 0.f && bnrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM. */
+
+ clascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 1;
+ } else if (bnrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM. */
+
+ clascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 2;
+ }
+
+/* If M < N make sure B(M+1:N,:) = 0 */
+
+ if (*m < *n) {
+ i__1 = *n - *m;
+ claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[*m + 1 + b_dim1], ldb);
+ }
+
+/* Overdetermined case. */
+
+ if (*m >= *n) {
+
+/* Path 1 - overdetermined or exactly determined. */
+
+ mm = *m;
+ if (*m >= mnthr) {
+
+/* Path 1a - overdetermined, with many more rows than columns */
+
+ mm = *n;
+ itau = 1;
+ nwork = itau + *n;
+
+/* Compute A=Q*R. */
+/* (RWorkspace: need N) */
+/* (CWorkspace: need N, prefer N*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1,
+ info);
+
+/* Multiply B by transpose(Q). */
+/* (RWorkspace: need N) */
+/* (CWorkspace: need NRHS, prefer NRHS*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ cunmqr_("L", "C", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[
+ b_offset], ldb, &work[nwork], &i__1, info);
+
+/* Zero out below R. */
+
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ claset_("L", &i__1, &i__2, &c_b1, &c_b1, &a[a_dim1 + 2], lda);
+ }
+ }
+
+ itauq = 1;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+ ie = 1;
+ nrwork = ie + *n;
+
+/* Bidiagonalize R in A. */
+/* (RWorkspace: need N) */
+/* (CWorkspace: need 2*N+MM, prefer 2*N+(MM+N)*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ cgebrd_(&mm, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq], &
+ work[itaup], &work[nwork], &i__1, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors of R. */
+/* (CWorkspace: need 2*N+NRHS, prefer 2*N+NRHS*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ cunmbr_("Q", "L", "C", &mm, nrhs, n, &a[a_offset], lda, &work[itauq],
+ &b[b_offset], ldb, &work[nwork], &i__1, info);
+
+/* Solve the bidiagonal least squares problem. */
+
+ clalsd_("U", &smlsiz, n, nrhs, &s[1], &rwork[ie], &b[b_offset], ldb,
+ rcond, rank, &work[nwork], &rwork[nrwork], &iwork[1], info);
+ if (*info != 0) {
+ goto L10;
+ }
+
+/* Multiply B by right bidiagonalizing vectors of R. */
+
+ i__1 = *lwork - nwork + 1;
+ cunmbr_("P", "L", "N", n, nrhs, n, &a[a_offset], lda, &work[itaup], &
+ b[b_offset], ldb, &work[nwork], &i__1, info);
+
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = *m, i__2 = (*m << 1) - 4, i__1 = max(i__1,i__2), i__1 = max(
+ i__1,*nrhs), i__2 = *n - *m * 3;
+ if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__1,i__2)) {
+
+/* Path 2a - underdetermined, with many more columns than rows */
+/* and sufficient workspace for an efficient algorithm. */
+
+ ldwork = *m;
+/* Computing MAX */
+/* Computing MAX */
+ i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 =
+ max(i__3,*nrhs), i__4 = *n - *m * 3;
+ i__1 = (*m << 2) + *m * *lda + max(i__3,i__4), i__2 = *m * *lda +
+ *m + *m * *nrhs;
+ if (*lwork >= max(i__1,i__2)) {
+ ldwork = *lda;
+ }
+ itau = 1;
+ nwork = *m + 1;
+
+/* Compute A=L*Q. */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1,
+ info);
+ il = nwork;
+
+/* Copy L to WORK(IL), zeroing out above its diagonal. */
+
+ clacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork);
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ claset_("U", &i__1, &i__2, &c_b1, &c_b1, &work[il + ldwork], &
+ ldwork);
+ itauq = il + ldwork * *m;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+ ie = 1;
+ nrwork = ie + *m;
+
+/* Bidiagonalize L in WORK(IL). */
+/* (RWorkspace: need M) */
+/* (CWorkspace: need M*M+4*M, prefer M*M+4*M+2*M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ cgebrd_(m, m, &work[il], &ldwork, &s[1], &rwork[ie], &work[itauq],
+ &work[itaup], &work[nwork], &i__1, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors of L. */
+/* (CWorkspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ cunmbr_("Q", "L", "C", m, nrhs, m, &work[il], &ldwork, &work[
+ itauq], &b[b_offset], ldb, &work[nwork], &i__1, info);
+
+/* Solve the bidiagonal least squares problem. */
+
+ clalsd_("U", &smlsiz, m, nrhs, &s[1], &rwork[ie], &b[b_offset],
+ ldb, rcond, rank, &work[nwork], &rwork[nrwork], &iwork[1],
+ info);
+ if (*info != 0) {
+ goto L10;
+ }
+
+/* Multiply B by right bidiagonalizing vectors of L. */
+
+ i__1 = *lwork - nwork + 1;
+ cunmbr_("P", "L", "N", m, nrhs, m, &work[il], &ldwork, &work[
+ itaup], &b[b_offset], ldb, &work[nwork], &i__1, info);
+
+/* Zero out below first M rows of B. */
+
+ i__1 = *n - *m;
+ claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[*m + 1 + b_dim1], ldb);
+ nwork = itau + *m;
+
+/* Multiply transpose(Q) by B. */
+/* (CWorkspace: need NRHS, prefer NRHS*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ cunmlq_("L", "C", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[
+ b_offset], ldb, &work[nwork], &i__1, info);
+
+ } else {
+
+/* Path 2 - remaining underdetermined cases. */
+
+ itauq = 1;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+ ie = 1;
+ nrwork = ie + *m;
+
+/* Bidiagonalize A. */
+/* (RWorkspace: need M) */
+/* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ cgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq],
+ &work[itaup], &work[nwork], &i__1, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors. */
+/* (CWorkspace: need 2*M+NRHS, prefer 2*M+NRHS*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ cunmbr_("Q", "L", "C", m, nrhs, n, &a[a_offset], lda, &work[itauq]
+, &b[b_offset], ldb, &work[nwork], &i__1, info);
+
+/* Solve the bidiagonal least squares problem. */
+
+ clalsd_("L", &smlsiz, m, nrhs, &s[1], &rwork[ie], &b[b_offset],
+ ldb, rcond, rank, &work[nwork], &rwork[nrwork], &iwork[1],
+ info);
+ if (*info != 0) {
+ goto L10;
+ }
+
+/* Multiply B by right bidiagonalizing vectors of A. */
+
+ i__1 = *lwork - nwork + 1;
+ cunmbr_("P", "L", "N", n, nrhs, m, &a[a_offset], lda, &work[itaup]
+, &b[b_offset], ldb, &work[nwork], &i__1, info);
+
+ }
+ }
+
+/* Undo scaling. */
+
+ if (iascl == 1) {
+ clascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
+ info);
+ slascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, info);
+ } else if (iascl == 2) {
+ clascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
+ info);
+ slascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, info);
+ }
+ if (ibscl == 1) {
+ clascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ } else if (ibscl == 2) {
+ clascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ }
+
+L10:
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+ iwork[1] = liwork;
+ rwork[1] = (real) lrwork;
+ return 0;
+
+/* End of CGELSD */
+
+} /* cgelsd_ */
diff --git a/SRC/cgelss.c b/SRC/cgelss.c
new file mode 100644
index 0000000..24729a7
--- /dev/null
+++ b/SRC/cgelss.c
@@ -0,0 +1,822 @@
+/* cgelss.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__6 = 6;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__0 = 0;
+static real c_b78 = 0.f;
+
+/* Subroutine */ int cgelss_(integer *m, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *b, integer *ldb, real *s, real *rcond,
+ integer *rank, complex *work, integer *lwork, real *rwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+ real r__1;
+
+ /* Local variables */
+ integer i__, bl, ie, il, mm;
+ real eps, thr, anrm, bnrm;
+ integer itau;
+ complex vdum[1];
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ integer iascl, ibscl;
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *);
+ integer chunk;
+ real sfmin;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer minmn, maxmn, itaup, itauq, mnthr, iwork;
+ extern /* Subroutine */ int cgebrd_(integer *, integer *, complex *,
+ integer *, real *, real *, complex *, complex *, complex *,
+ integer *, integer *), slabad_(real *, real *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int cgelqf_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *), clascl_(
+ char *, integer *, integer *, real *, real *, integer *, integer *
+, complex *, integer *, integer *), cgeqrf_(integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), xerbla_(char *, integer *), cbdsqr_(char *,
+ integer *, integer *, integer *, integer *, real *, real *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ real *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ real bignum;
+ extern /* Subroutine */ int cungbr_(char *, integer *, integer *, integer
+ *, complex *, integer *, complex *, complex *, integer *, integer
+ *), slascl_(char *, integer *, integer *, real *, real *,
+ integer *, integer *, real *, integer *, integer *),
+ cunmbr_(char *, char *, char *, integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, complex *,
+ integer *, integer *), csrscl_(integer *,
+ real *, complex *, integer *), slaset_(char *, integer *, integer
+ *, real *, real *, real *, integer *), cunmlq_(char *,
+ char *, integer *, integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *, complex *, integer *, integer *);
+ integer ldwork;
+ extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *);
+ integer minwrk, maxwrk;
+ real smlnum;
+ integer irwork;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGELSS computes the minimum norm solution to a complex linear */
+/* least squares problem: */
+
+/* Minimize 2-norm(| b - A*x |). */
+
+/* using the singular value decomposition (SVD) of A. A is an M-by-N */
+/* matrix which may be rank-deficient. */
+
+/* Several right hand side vectors b and solution vectors x can be */
+/* handled in a single call; they are stored as the columns of the */
+/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix */
+/* X. */
+
+/* The effective rank of A is determined by treating as zero those */
+/* singular values which are less than RCOND times the largest singular */
+/* value. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the first min(m,n) rows of A are overwritten with */
+/* its right singular vectors, stored rowwise. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the M-by-NRHS right hand side matrix B. */
+/* On exit, B is overwritten by the N-by-NRHS solution matrix X. */
+/* If m >= n and RANK = n, the residual sum-of-squares for */
+/* the solution in the i-th column is given by the sum of */
+/* squares of the modulus of elements n+1:m in that column. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M,N). */
+
+/* S (output) REAL array, dimension (min(M,N)) */
+/* The singular values of A in decreasing order. */
+/* The condition number of A in the 2-norm = S(1)/S(min(m,n)). */
+
+/* RCOND (input) REAL */
+/* RCOND is used to determine the effective rank of A. */
+/* Singular values S(i) <= RCOND*S(1) are treated as zero. */
+/* If RCOND < 0, machine precision is used instead. */
+
+/* RANK (output) INTEGER */
+/* The effective rank of A, i.e., the number of singular values */
+/* which are greater than RCOND*S(1). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= 1, and also: */
+/* LWORK >= 2*min(M,N) + max(M,N,NRHS) */
+/* For good performance, LWORK should generally be larger. */
+
+/* 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. */
+
+/* RWORK (workspace) REAL array, dimension (5*min(M,N)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: the algorithm for computing the SVD failed to converge; */
+/* if INFO = i, i off-diagonal elements of an intermediate */
+/* bidiagonal form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --s;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ minmn = min(*m,*n);
+ maxmn = max(*m,*n);
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,maxmn)) {
+ *info = -7;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* CWorkspace refers to complex workspace, and RWorkspace refers */
+/* to real workspace. NB refers to the optimal block size for the */
+/* immediately following subroutine, as returned by ILAENV.) */
+
+ if (*info == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ if (minmn > 0) {
+ mm = *m;
+ mnthr = ilaenv_(&c__6, "CGELSS", " ", m, n, nrhs, &c_n1);
+ if (*m >= *n && *m >= mnthr) {
+
+/* Path 1a - overdetermined, with many more rows than */
+/* columns */
+
+ mm = *n;
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "CGEQRF",
+ " ", m, n, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "CUNMQR",
+ "LC", m, nrhs, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ }
+ if (*m >= *n) {
+
+/* Path 1 - overdetermined or exactly determined */
+
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + (mm + *n) * ilaenv_(&c__1,
+ "CGEBRD", " ", &mm, n, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *nrhs * ilaenv_(&c__1,
+ "CUNMBR", "QLC", &mm, nrhs, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
+ "CUNGBR", "P", n, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * *nrhs;
+ maxwrk = max(i__1,i__2);
+ minwrk = (*n << 1) + max(*nrhs,*m);
+ }
+ if (*n > *m) {
+ minwrk = (*m << 1) + max(*nrhs,*n);
+ if (*n >= mnthr) {
+
+/* Path 2a - underdetermined, with many more columns */
+/* than rows */
+
+ maxwrk = *m + *m * ilaenv_(&c__1, "CGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * 3 + *m * *m + (*m << 1) *
+ ilaenv_(&c__1, "CGEBRD", " ", m, m, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * 3 + *m * *m + *nrhs * ilaenv_(&
+ c__1, "CUNMBR", "QLC", m, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * 3 + *m * *m + (*m - 1) *
+ ilaenv_(&c__1, "CUNGBR", "P", m, m, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+ if (*nrhs > 1) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs;
+ maxwrk = max(i__1,i__2);
+ } else {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 1);
+ maxwrk = max(i__1,i__2);
+ }
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, "CUNMLQ"
+, "LC", n, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+ } else {
+
+/* Path 2 - underdetermined */
+
+ maxwrk = (*m << 1) + (*n + *m) * ilaenv_(&c__1, "CGEBRD",
+ " ", m, n, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *nrhs * ilaenv_(&c__1,
+ "CUNMBR", "QLC", m, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNGBR", "P", m, n, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * *nrhs;
+ maxwrk = max(i__1,i__2);
+ }
+ }
+ maxwrk = max(minwrk,maxwrk);
+ }
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGELSS", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ *rank = 0;
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ eps = slamch_("P");
+ sfmin = slamch_("S");
+ smlnum = sfmin / eps;
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = clange_("M", m, n, &a[a_offset], lda, &rwork[1]);
+ iascl = 0;
+ if (anrm > 0.f && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ clascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ clascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 2;
+ } else if (anrm == 0.f) {
+
+/* Matrix all zero. Return zero solution. */
+
+ i__1 = max(*m,*n);
+ claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+ slaset_("F", &minmn, &c__1, &c_b78, &c_b78, &s[1], &minmn);
+ *rank = 0;
+ goto L70;
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = clange_("M", m, nrhs, &b[b_offset], ldb, &rwork[1]);
+ ibscl = 0;
+ if (bnrm > 0.f && bnrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ clascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 1;
+ } else if (bnrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ clascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 2;
+ }
+
+/* Overdetermined case */
+
+ if (*m >= *n) {
+
+/* Path 1 - overdetermined or exactly determined */
+
+ mm = *m;
+ if (*m >= mnthr) {
+
+/* Path 1a - overdetermined, with many more rows than columns */
+
+ mm = *n;
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwork + 1;
+ cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__1,
+ info);
+
+/* Multiply B by transpose(Q) */
+/* (CWorkspace: need N+NRHS, prefer N+NRHS*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwork + 1;
+ cunmqr_("L", "C", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[
+ b_offset], ldb, &work[iwork], &i__1, info);
+
+/* Zero out below R */
+
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ claset_("L", &i__1, &i__2, &c_b1, &c_b1, &a[a_dim1 + 2], lda);
+ }
+ }
+
+ ie = 1;
+ itauq = 1;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in A */
+/* (CWorkspace: need 2*N+MM, prefer 2*N+(MM+N)*NB) */
+/* (RWorkspace: need N) */
+
+ i__1 = *lwork - iwork + 1;
+ cgebrd_(&mm, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq], &
+ work[itaup], &work[iwork], &i__1, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors of R */
+/* (CWorkspace: need 2*N+NRHS, prefer 2*N+NRHS*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwork + 1;
+ cunmbr_("Q", "L", "C", &mm, nrhs, n, &a[a_offset], lda, &work[itauq],
+ &b[b_offset], ldb, &work[iwork], &i__1, info);
+
+/* Generate right bidiagonalizing vectors of R in A */
+/* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwork + 1;
+ cungbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[iwork], &
+ i__1, info);
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration */
+/* multiply B by transpose of left singular vectors */
+/* compute right singular vectors in A */
+/* (CWorkspace: none) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", n, n, &c__0, nrhs, &s[1], &rwork[ie], &a[a_offset], lda,
+ vdum, &c__1, &b[b_offset], ldb, &rwork[irwork], info);
+ if (*info != 0) {
+ goto L70;
+ }
+
+/* Multiply B by reciprocals of singular values */
+
+/* Computing MAX */
+ r__1 = *rcond * s[1];
+ thr = dmax(r__1,sfmin);
+ if (*rcond < 0.f) {
+/* Computing MAX */
+ r__1 = eps * s[1];
+ thr = dmax(r__1,sfmin);
+ }
+ *rank = 0;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] > thr) {
+ csrscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb);
+ ++(*rank);
+ } else {
+ claset_("F", &c__1, nrhs, &c_b1, &c_b1, &b[i__ + b_dim1], ldb);
+ }
+/* L10: */
+ }
+
+/* Multiply B by right singular vectors */
+/* (CWorkspace: need N, prefer N*NRHS) */
+/* (RWorkspace: none) */
+
+ if (*lwork >= *ldb * *nrhs && *nrhs > 1) {
+ cgemm_("C", "N", n, nrhs, n, &c_b2, &a[a_offset], lda, &b[
+ b_offset], ldb, &c_b1, &work[1], ldb);
+ clacpy_("G", n, nrhs, &work[1], ldb, &b[b_offset], ldb)
+ ;
+ } else if (*nrhs > 1) {
+ chunk = *lwork / *n;
+ i__1 = *nrhs;
+ i__2 = chunk;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = *nrhs - i__ + 1;
+ bl = min(i__3,chunk);
+ cgemm_("C", "N", n, &bl, n, &c_b2, &a[a_offset], lda, &b[i__ *
+ b_dim1 + 1], ldb, &c_b1, &work[1], n);
+ clacpy_("G", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1], ldb);
+/* L20: */
+ }
+ } else {
+ cgemv_("C", n, n, &c_b2, &a[a_offset], lda, &b[b_offset], &c__1, &
+ c_b1, &work[1], &c__1);
+ ccopy_(n, &work[1], &c__1, &b[b_offset], &c__1);
+ }
+
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__2 = max(*m,*nrhs), i__1 = *n - (*m << 1);
+ if (*n >= mnthr && *lwork >= *m * 3 + *m * *m + max(i__2,i__1)) {
+
+/* Underdetermined case, M much less than N */
+
+/* Path 2a - underdetermined, with many more columns than rows */
+/* and sufficient workspace for an efficient algorithm */
+
+ ldwork = *m;
+/* Computing MAX */
+ i__2 = max(*m,*nrhs), i__1 = *n - (*m << 1);
+ if (*lwork >= *m * 3 + *m * *lda + max(i__2,i__1)) {
+ ldwork = *lda;
+ }
+ itau = 1;
+ iwork = *m + 1;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: none) */
+
+ i__2 = *lwork - iwork + 1;
+ cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2,
+ info);
+ il = iwork;
+
+/* Copy L to WORK(IL), zeroing out above it */
+
+ clacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork);
+ i__2 = *m - 1;
+ i__1 = *m - 1;
+ claset_("U", &i__2, &i__1, &c_b1, &c_b1, &work[il + ldwork], &
+ ldwork);
+ ie = 1;
+ itauq = il + ldwork * *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IL) */
+/* (CWorkspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(m, m, &work[il], &ldwork, &s[1], &rwork[ie], &work[itauq],
+ &work[itaup], &work[iwork], &i__2, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors of L */
+/* (CWorkspace: need M*M+3*M+NRHS, prefer M*M+3*M+NRHS*NB) */
+/* (RWorkspace: none) */
+
+ i__2 = *lwork - iwork + 1;
+ cunmbr_("Q", "L", "C", m, nrhs, m, &work[il], &ldwork, &work[
+ itauq], &b[b_offset], ldb, &work[iwork], &i__2, info);
+
+/* Generate right bidiagonalizing vectors of R in WORK(IL) */
+/* (CWorkspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB) */
+/* (RWorkspace: none) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("P", m, m, m, &work[il], &ldwork, &work[itaup], &work[
+ iwork], &i__2, info);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right singular */
+/* vectors of L in WORK(IL) and multiplying B by transpose of */
+/* left singular vectors */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", m, m, &c__0, nrhs, &s[1], &rwork[ie], &work[il], &
+ ldwork, &a[a_offset], lda, &b[b_offset], ldb, &rwork[
+ irwork], info);
+ if (*info != 0) {
+ goto L70;
+ }
+
+/* Multiply B by reciprocals of singular values */
+
+/* Computing MAX */
+ r__1 = *rcond * s[1];
+ thr = dmax(r__1,sfmin);
+ if (*rcond < 0.f) {
+/* Computing MAX */
+ r__1 = eps * s[1];
+ thr = dmax(r__1,sfmin);
+ }
+ *rank = 0;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (s[i__] > thr) {
+ csrscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb);
+ ++(*rank);
+ } else {
+ claset_("F", &c__1, nrhs, &c_b1, &c_b1, &b[i__ + b_dim1],
+ ldb);
+ }
+/* L30: */
+ }
+ iwork = il + *m * ldwork;
+
+/* Multiply B by right singular vectors of L in WORK(IL) */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NRHS) */
+/* (RWorkspace: none) */
+
+ if (*lwork >= *ldb * *nrhs + iwork - 1 && *nrhs > 1) {
+ cgemm_("C", "N", m, nrhs, m, &c_b2, &work[il], &ldwork, &b[
+ b_offset], ldb, &c_b1, &work[iwork], ldb);
+ clacpy_("G", m, nrhs, &work[iwork], ldb, &b[b_offset], ldb);
+ } else if (*nrhs > 1) {
+ chunk = (*lwork - iwork + 1) / *m;
+ i__2 = *nrhs;
+ i__1 = chunk;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
+ i__1) {
+/* Computing MIN */
+ i__3 = *nrhs - i__ + 1;
+ bl = min(i__3,chunk);
+ cgemm_("C", "N", m, &bl, m, &c_b2, &work[il], &ldwork, &b[
+ i__ * b_dim1 + 1], ldb, &c_b1, &work[iwork], m);
+ clacpy_("G", m, &bl, &work[iwork], m, &b[i__ * b_dim1 + 1]
+, ldb);
+/* L40: */
+ }
+ } else {
+ cgemv_("C", m, m, &c_b2, &work[il], &ldwork, &b[b_dim1 + 1], &
+ c__1, &c_b1, &work[iwork], &c__1);
+ ccopy_(m, &work[iwork], &c__1, &b[b_dim1 + 1], &c__1);
+ }
+
+/* Zero out below first M rows of B */
+
+ i__1 = *n - *m;
+ claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[*m + 1 + b_dim1], ldb);
+ iwork = itau + *m;
+
+/* Multiply transpose(Q) by B */
+/* (CWorkspace: need M+NRHS, prefer M+NHRS*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwork + 1;
+ cunmlq_("L", "C", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[
+ b_offset], ldb, &work[iwork], &i__1, info);
+
+ } else {
+
+/* Path 2 - remaining underdetermined cases */
+
+ ie = 1;
+ itauq = 1;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize A */
+/* (CWorkspace: need 3*M, prefer 2*M+(M+N)*NB) */
+/* (RWorkspace: need N) */
+
+ i__1 = *lwork - iwork + 1;
+ cgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq],
+ &work[itaup], &work[iwork], &i__1, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors */
+/* (CWorkspace: need 2*M+NRHS, prefer 2*M+NRHS*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwork + 1;
+ cunmbr_("Q", "L", "C", m, nrhs, n, &a[a_offset], lda, &work[itauq]
+, &b[b_offset], ldb, &work[iwork], &i__1, info);
+
+/* Generate right bidiagonalizing vectors in A */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwork + 1;
+ cungbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[
+ iwork], &i__1, info);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, */
+/* computing right singular vectors of A in A and */
+/* multiplying B by transpose of left singular vectors */
+/* (CWorkspace: none) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("L", m, n, &c__0, nrhs, &s[1], &rwork[ie], &a[a_offset],
+ lda, vdum, &c__1, &b[b_offset], ldb, &rwork[irwork], info);
+ if (*info != 0) {
+ goto L70;
+ }
+
+/* Multiply B by reciprocals of singular values */
+
+/* Computing MAX */
+ r__1 = *rcond * s[1];
+ thr = dmax(r__1,sfmin);
+ if (*rcond < 0.f) {
+/* Computing MAX */
+ r__1 = eps * s[1];
+ thr = dmax(r__1,sfmin);
+ }
+ *rank = 0;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] > thr) {
+ csrscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb);
+ ++(*rank);
+ } else {
+ claset_("F", &c__1, nrhs, &c_b1, &c_b1, &b[i__ + b_dim1],
+ ldb);
+ }
+/* L50: */
+ }
+
+/* Multiply B by right singular vectors of A */
+/* (CWorkspace: need N, prefer N*NRHS) */
+/* (RWorkspace: none) */
+
+ if (*lwork >= *ldb * *nrhs && *nrhs > 1) {
+ cgemm_("C", "N", n, nrhs, m, &c_b2, &a[a_offset], lda, &b[
+ b_offset], ldb, &c_b1, &work[1], ldb);
+ clacpy_("G", n, nrhs, &work[1], ldb, &b[b_offset], ldb);
+ } else if (*nrhs > 1) {
+ chunk = *lwork / *n;
+ i__1 = *nrhs;
+ i__2 = chunk;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *nrhs - i__ + 1;
+ bl = min(i__3,chunk);
+ cgemm_("C", "N", n, &bl, m, &c_b2, &a[a_offset], lda, &b[
+ i__ * b_dim1 + 1], ldb, &c_b1, &work[1], n);
+ clacpy_("F", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1],
+ ldb);
+/* L60: */
+ }
+ } else {
+ cgemv_("C", m, n, &c_b2, &a[a_offset], lda, &b[b_offset], &
+ c__1, &c_b1, &work[1], &c__1);
+ ccopy_(n, &work[1], &c__1, &b[b_offset], &c__1);
+ }
+ }
+ }
+
+/* Undo scaling */
+
+ if (iascl == 1) {
+ clascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
+ info);
+ slascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, info);
+ } else if (iascl == 2) {
+ clascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
+ info);
+ slascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, info);
+ }
+ if (ibscl == 1) {
+ clascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ } else if (ibscl == 2) {
+ clascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ }
+L70:
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+ return 0;
+
+/* End of CGELSS */
+
+} /* cgelss_ */
diff --git a/SRC/cgelsx.c b/SRC/cgelsx.c
new file mode 100644
index 0000000..d75a178
--- /dev/null
+++ b/SRC/cgelsx.c
@@ -0,0 +1,468 @@
+/* cgelsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__0 = 0;
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* Subroutine */ int cgelsx_(integer *m, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *b, integer *ldb, integer *jpvt, real *rcond,
+ integer *rank, complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+ complex q__1;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ complex c1, c2, s1, s2, t1, t2;
+ integer mn;
+ real anrm, bnrm, smin, smax;
+ integer iascl, ibscl, ismin, ismax;
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *), claic1_(integer *,
+ integer *, complex *, real *, complex *, complex *, real *,
+ complex *, complex *), cunm2r_(char *, char *, integer *, integer
+ *, integer *, complex *, integer *, complex *, complex *, integer
+ *, complex *, integer *), slabad_(real *, real *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, complex *, integer *, integer *), cgeqpf_(integer *, integer *, complex *, integer *,
+ integer *, complex *, complex *, real *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), xerbla_(char *,
+ integer *);
+ real bignum;
+ extern /* Subroutine */ int clatzm_(char *, integer *, integer *, complex
+ *, integer *, complex *, complex *, complex *, integer *, complex
+ *);
+ real sminpr;
+ extern /* Subroutine */ int ctzrqf_(integer *, integer *, complex *,
+ integer *, complex *, integer *);
+ real smaxpr, smlnum;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine CGELSY. */
+
+/* CGELSX computes the minimum-norm solution to a complex linear least */
+/* squares problem: */
+/* minimize || A * X - B || */
+/* using a complete orthogonal factorization of A. A is an M-by-N */
+/* matrix which may be rank-deficient. */
+
+/* Several right hand side vectors b and solution vectors x can be */
+/* handled in a single call; they are stored as the columns of the */
+/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
+/* matrix X. */
+
+/* The routine first computes a QR factorization with column pivoting: */
+/* A * P = Q * [ R11 R12 ] */
+/* [ 0 R22 ] */
+/* with R11 defined as the largest leading submatrix whose estimated */
+/* condition number is less than 1/RCOND. The order of R11, RANK, */
+/* is the effective rank of A. */
+
+/* Then, R22 is considered to be negligible, and R12 is annihilated */
+/* by unitary transformations from the right, arriving at the */
+/* complete orthogonal factorization: */
+/* A * P = Q * [ T11 0 ] * Z */
+/* [ 0 0 ] */
+/* The minimum-norm solution is then */
+/* X = P * Z' [ inv(T11)*Q1'*B ] */
+/* [ 0 ] */
+/* where Q1 consists of the first RANK columns of Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of */
+/* columns of matrices B and X. NRHS >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A has been overwritten by details of its */
+/* complete orthogonal factorization. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the M-by-NRHS right hand side matrix B. */
+/* On exit, the N-by-NRHS solution matrix X. */
+/* If m >= n and RANK = n, the residual sum-of-squares for */
+/* the solution in the i-th column is given by the sum of */
+/* squares of elements N+1:M in that column. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M,N). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* On entry, if JPVT(i) .ne. 0, the i-th column of A is an */
+/* initial column, otherwise it is a free column. Before */
+/* the QR factorization of A, all initial columns are */
+/* permuted to the leading positions; only the remaining */
+/* free columns are moved as a result of column pivoting */
+/* during the factorization. */
+/* On exit, if JPVT(i) = k, then the i-th column of A*P */
+/* was the k-th column of A. */
+
+/* RCOND (input) REAL */
+/* RCOND is used to determine the effective rank of A, which */
+/* is defined as the order of the largest leading triangular */
+/* submatrix R11 in the QR factorization with pivoting of A, */
+/* whose estimated condition number < 1/RCOND. */
+
+/* RANK (output) INTEGER */
+/* The effective rank of A, i.e., the order of the submatrix */
+/* R11. This is the same as the order of the submatrix T11 */
+/* in the complete orthogonal factorization of A. */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (min(M,N) + max( N, 2*min(M,N)+NRHS )), */
+
+/* RWORK (workspace) REAL array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --jpvt;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ mn = min(*m,*n);
+ ismin = mn + 1;
+ ismax = (mn << 1) + 1;
+
+/* Test the input arguments. */
+
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ if (*ldb < max(i__1,*n)) {
+ *info = -7;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGELSX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+/* Computing MIN */
+ i__1 = min(*m,*n);
+ if (min(i__1,*nrhs) == 0) {
+ *rank = 0;
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ smlnum = slamch_("S") / slamch_("P");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Scale A, B if max elements outside range [SMLNUM,BIGNUM] */
+
+ anrm = clange_("M", m, n, &a[a_offset], lda, &rwork[1]);
+ iascl = 0;
+ if (anrm > 0.f && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ clascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ clascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 2;
+ } else if (anrm == 0.f) {
+
+/* Matrix all zero. Return zero solution. */
+
+ i__1 = max(*m,*n);
+ claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+ *rank = 0;
+ goto L100;
+ }
+
+ bnrm = clange_("M", m, nrhs, &b[b_offset], ldb, &rwork[1]);
+ ibscl = 0;
+ if (bnrm > 0.f && bnrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ clascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 1;
+ } else if (bnrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ clascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 2;
+ }
+
+/* Compute QR factorization with column pivoting of A: */
+/* A * P = Q * R */
+
+ cgeqpf_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], &
+ rwork[1], info);
+
+/* complex workspace MN+N. Real workspace 2*N. Details of Householder */
+/* rotations stored in WORK(1:MN). */
+
+/* Determine RANK using incremental condition estimation */
+
+ i__1 = ismin;
+ work[i__1].r = 1.f, work[i__1].i = 0.f;
+ i__1 = ismax;
+ work[i__1].r = 1.f, work[i__1].i = 0.f;
+ smax = c_abs(&a[a_dim1 + 1]);
+ smin = smax;
+ if (c_abs(&a[a_dim1 + 1]) == 0.f) {
+ *rank = 0;
+ i__1 = max(*m,*n);
+ claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+ goto L100;
+ } else {
+ *rank = 1;
+ }
+
+L10:
+ if (*rank < mn) {
+ i__ = *rank + 1;
+ claic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[
+ i__ + i__ * a_dim1], &sminpr, &s1, &c1);
+ claic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[
+ i__ + i__ * a_dim1], &smaxpr, &s2, &c2);
+
+ if (smaxpr * *rcond <= sminpr) {
+ i__1 = *rank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ismin + i__ - 1;
+ i__3 = ismin + i__ - 1;
+ q__1.r = s1.r * work[i__3].r - s1.i * work[i__3].i, q__1.i =
+ s1.r * work[i__3].i + s1.i * work[i__3].r;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ i__2 = ismax + i__ - 1;
+ i__3 = ismax + i__ - 1;
+ q__1.r = s2.r * work[i__3].r - s2.i * work[i__3].i, q__1.i =
+ s2.r * work[i__3].i + s2.i * work[i__3].r;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L20: */
+ }
+ i__1 = ismin + *rank;
+ work[i__1].r = c1.r, work[i__1].i = c1.i;
+ i__1 = ismax + *rank;
+ work[i__1].r = c2.r, work[i__1].i = c2.i;
+ smin = sminpr;
+ smax = smaxpr;
+ ++(*rank);
+ goto L10;
+ }
+ }
+
+/* Logically partition R = [ R11 R12 ] */
+/* [ 0 R22 ] */
+/* where R11 = R(1:RANK,1:RANK) */
+
+/* [R11,R12] = [ T11, 0 ] * Y */
+
+ if (*rank < *n) {
+ ctzrqf_(rank, n, &a[a_offset], lda, &work[mn + 1], info);
+ }
+
+/* Details of Householder rotations stored in WORK(MN+1:2*MN) */
+
+/* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */
+
+ cunm2r_("Left", "Conjugate transpose", m, nrhs, &mn, &a[a_offset], lda, &
+ work[1], &b[b_offset], ldb, &work[(mn << 1) + 1], info);
+
+/* workspace NRHS */
+
+/* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */
+
+ ctrsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b2, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+ i__1 = *n;
+ for (i__ = *rank + 1; i__ <= i__1; ++i__) {
+ i__2 = *nrhs;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0.f, b[i__3].i = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) */
+
+ if (*rank < *n) {
+ i__1 = *rank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n - *rank + 1;
+ r_cnjg(&q__1, &work[mn + i__]);
+ clatzm_("Left", &i__2, nrhs, &a[i__ + (*rank + 1) * a_dim1], lda,
+ &q__1, &b[i__ + b_dim1], &b[*rank + 1 + b_dim1], ldb, &
+ work[(mn << 1) + 1]);
+/* L50: */
+ }
+ }
+
+/* workspace NRHS */
+
+/* B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = (mn << 1) + i__;
+ work[i__3].r = 1.f, work[i__3].i = 0.f;
+/* L60: */
+ }
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = (mn << 1) + i__;
+ if (work[i__3].r == 1.f && work[i__3].i == 0.f) {
+ if (jpvt[i__] != i__) {
+ k = i__;
+ i__3 = k + j * b_dim1;
+ t1.r = b[i__3].r, t1.i = b[i__3].i;
+ i__3 = jpvt[k] + j * b_dim1;
+ t2.r = b[i__3].r, t2.i = b[i__3].i;
+L70:
+ i__3 = jpvt[k] + j * b_dim1;
+ b[i__3].r = t1.r, b[i__3].i = t1.i;
+ i__3 = (mn << 1) + k;
+ work[i__3].r = 0.f, work[i__3].i = 0.f;
+ t1.r = t2.r, t1.i = t2.i;
+ k = jpvt[k];
+ i__3 = jpvt[k] + j * b_dim1;
+ t2.r = b[i__3].r, t2.i = b[i__3].i;
+ if (jpvt[k] != i__) {
+ goto L70;
+ }
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = t1.r, b[i__3].i = t1.i;
+ i__3 = (mn << 1) + k;
+ work[i__3].r = 0.f, work[i__3].i = 0.f;
+ }
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Undo scaling */
+
+ if (iascl == 1) {
+ clascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
+ info);
+ clascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset],
+ lda, info);
+ } else if (iascl == 2) {
+ clascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
+ info);
+ clascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset],
+ lda, info);
+ }
+ if (ibscl == 1) {
+ clascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ } else if (ibscl == 2) {
+ clascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ }
+
+L100:
+
+ return 0;
+
+/* End of CGELSX */
+
+} /* cgelsx_ */
diff --git a/SRC/cgelsy.c b/SRC/cgelsy.c
new file mode 100644
index 0000000..836bfd0
--- /dev/null
+++ b/SRC/cgelsy.c
@@ -0,0 +1,512 @@
+/* cgelsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__2 = 2;
+
+/* Subroutine */ int cgelsy_(integer *m, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *b, integer *ldb, integer *jpvt, real *rcond,
+ integer *rank, complex *work, integer *lwork, real *rwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+
+ /* Local variables */
+ integer i__, j;
+ complex c1, c2, s1, s2;
+ integer nb, mn, nb1, nb2, nb3, nb4;
+ real anrm, bnrm, smin, smax;
+ integer iascl, ibscl;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer ismin, ismax;
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *), claic1_(integer *,
+ integer *, complex *, real *, complex *, complex *, real *,
+ complex *, complex *);
+ real wsize;
+ extern /* Subroutine */ int cgeqp3_(integer *, integer *, complex *,
+ integer *, integer *, complex *, complex *, integer *, real *,
+ integer *), slabad_(real *, real *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), xerbla_(char *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ real bignum;
+ extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *);
+ real sminpr, smaxpr, smlnum;
+ extern /* Subroutine */ int cunmrz_(char *, char *, integer *, integer *,
+ integer *, integer *, complex *, integer *, complex *, complex *,
+ integer *, complex *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int ctzrzf_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGELSY computes the minimum-norm solution to a complex linear least */
+/* squares problem: */
+/* minimize || A * X - B || */
+/* using a complete orthogonal factorization of A. A is an M-by-N */
+/* matrix which may be rank-deficient. */
+
+/* Several right hand side vectors b and solution vectors x can be */
+/* handled in a single call; they are stored as the columns of the */
+/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
+/* matrix X. */
+
+/* The routine first computes a QR factorization with column pivoting: */
+/* A * P = Q * [ R11 R12 ] */
+/* [ 0 R22 ] */
+/* with R11 defined as the largest leading submatrix whose estimated */
+/* condition number is less than 1/RCOND. The order of R11, RANK, */
+/* is the effective rank of A. */
+
+/* Then, R22 is considered to be negligible, and R12 is annihilated */
+/* by unitary transformations from the right, arriving at the */
+/* complete orthogonal factorization: */
+/* A * P = Q * [ T11 0 ] * Z */
+/* [ 0 0 ] */
+/* The minimum-norm solution is then */
+/* X = P * Z' [ inv(T11)*Q1'*B ] */
+/* [ 0 ] */
+/* where Q1 consists of the first RANK columns of Q. */
+
+/* This routine is basically identical to the original xGELSX except */
+/* three differences: */
+/* o The permutation of matrix B (the right hand side) is faster and */
+/* more simple. */
+/* o The call to the subroutine xGEQPF has been substituted by the */
+/* the call to the subroutine xGEQP3. This subroutine is a Blas-3 */
+/* version of the QR factorization with column pivoting. */
+/* o Matrix B (the right hand side) is updated with Blas-3. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of */
+/* columns of matrices B and X. NRHS >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A has been overwritten by details of its */
+/* complete orthogonal factorization. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the M-by-NRHS right hand side matrix B. */
+/* On exit, the N-by-NRHS solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M,N). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
+/* to the front of AP, otherwise column i is a free column. */
+/* On exit, if JPVT(i) = k, then the i-th column of A*P */
+/* was the k-th column of A. */
+
+/* RCOND (input) REAL */
+/* RCOND is used to determine the effective rank of A, which */
+/* is defined as the order of the largest leading triangular */
+/* submatrix R11 in the QR factorization with pivoting of A, */
+/* whose estimated condition number < 1/RCOND. */
+
+/* RANK (output) INTEGER */
+/* The effective rank of A, i.e., the order of the submatrix */
+/* R11. This is the same as the order of the submatrix T11 */
+/* in the complete orthogonal factorization of A. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* The unblocked strategy requires that: */
+/* LWORK >= MN + MAX( 2*MN, N+1, MN+NRHS ) */
+/* where MN = min(M,N). */
+/* The block algorithm requires that: */
+/* LWORK >= MN + MAX( 2*MN, NB*(N+1), MN+MN*NB, MN+NB*NRHS ) */
+/* where NB is an upper bound on the blocksize returned */
+/* by ILAENV for the routines CGEQP3, CTZRZF, CTZRQF, CUNMQR, */
+/* and CUNMRZ. */
+
+/* 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. */
+
+/* RWORK (workspace) REAL array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+/* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
+/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --jpvt;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ mn = min(*m,*n);
+ ismin = mn + 1;
+ ismax = (mn << 1) + 1;
+
+/* Test the input arguments. */
+
+ *info = 0;
+ nb1 = ilaenv_(&c__1, "CGEQRF", " ", m, n, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "CGERQF", " ", m, n, &c_n1, &c_n1);
+ nb3 = ilaenv_(&c__1, "CUNMQR", " ", m, n, nrhs, &c_n1);
+ nb4 = ilaenv_(&c__1, "CUNMRQ", " ", m, n, nrhs, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2), i__1 = max(i__1,nb3);
+ nb = max(i__1,nb4);
+/* Computing MAX */
+ i__1 = 1, i__2 = mn + (*n << 1) + nb * (*n + 1), i__1 = max(i__1,i__2),
+ i__2 = (mn << 1) + nb * *nrhs;
+ lwkopt = max(i__1,i__2);
+ q__1.r = (real) lwkopt, q__1.i = 0.f;
+ work[1].r = q__1.r, work[1].i = q__1.i;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ if (*ldb < max(i__1,*n)) {
+ *info = -7;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = mn << 1, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = mn +
+ *nrhs;
+ if (*lwork < mn + max(i__1,i__2) && ! lquery) {
+ *info = -12;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGELSY", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+/* Computing MIN */
+ i__1 = min(*m,*n);
+ if (min(i__1,*nrhs) == 0) {
+ *rank = 0;
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ smlnum = slamch_("S") / slamch_("P");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Scale A, B if max entries outside range [SMLNUM,BIGNUM] */
+
+ anrm = clange_("M", m, n, &a[a_offset], lda, &rwork[1]);
+ iascl = 0;
+ if (anrm > 0.f && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ clascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ clascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 2;
+ } else if (anrm == 0.f) {
+
+/* Matrix all zero. Return zero solution. */
+
+ i__1 = max(*m,*n);
+ claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+ *rank = 0;
+ goto L70;
+ }
+
+ bnrm = clange_("M", m, nrhs, &b[b_offset], ldb, &rwork[1]);
+ ibscl = 0;
+ if (bnrm > 0.f && bnrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ clascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 1;
+ } else if (bnrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ clascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 2;
+ }
+
+/* Compute QR factorization with column pivoting of A: */
+/* A * P = Q * R */
+
+ i__1 = *lwork - mn;
+ cgeqp3_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], &i__1,
+ &rwork[1], info);
+ i__1 = mn + 1;
+ wsize = mn + work[i__1].r;
+
+/* complex workspace: MN+NB*(N+1). real workspace 2*N. */
+/* Details of Householder rotations stored in WORK(1:MN). */
+
+/* Determine RANK using incremental condition estimation */
+
+ i__1 = ismin;
+ work[i__1].r = 1.f, work[i__1].i = 0.f;
+ i__1 = ismax;
+ work[i__1].r = 1.f, work[i__1].i = 0.f;
+ smax = c_abs(&a[a_dim1 + 1]);
+ smin = smax;
+ if (c_abs(&a[a_dim1 + 1]) == 0.f) {
+ *rank = 0;
+ i__1 = max(*m,*n);
+ claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+ goto L70;
+ } else {
+ *rank = 1;
+ }
+
+L10:
+ if (*rank < mn) {
+ i__ = *rank + 1;
+ claic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[
+ i__ + i__ * a_dim1], &sminpr, &s1, &c1);
+ claic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[
+ i__ + i__ * a_dim1], &smaxpr, &s2, &c2);
+
+ if (smaxpr * *rcond <= sminpr) {
+ i__1 = *rank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ismin + i__ - 1;
+ i__3 = ismin + i__ - 1;
+ q__1.r = s1.r * work[i__3].r - s1.i * work[i__3].i, q__1.i =
+ s1.r * work[i__3].i + s1.i * work[i__3].r;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ i__2 = ismax + i__ - 1;
+ i__3 = ismax + i__ - 1;
+ q__1.r = s2.r * work[i__3].r - s2.i * work[i__3].i, q__1.i =
+ s2.r * work[i__3].i + s2.i * work[i__3].r;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L20: */
+ }
+ i__1 = ismin + *rank;
+ work[i__1].r = c1.r, work[i__1].i = c1.i;
+ i__1 = ismax + *rank;
+ work[i__1].r = c2.r, work[i__1].i = c2.i;
+ smin = sminpr;
+ smax = smaxpr;
+ ++(*rank);
+ goto L10;
+ }
+ }
+
+/* complex workspace: 3*MN. */
+
+/* Logically partition R = [ R11 R12 ] */
+/* [ 0 R22 ] */
+/* where R11 = R(1:RANK,1:RANK) */
+
+/* [R11,R12] = [ T11, 0 ] * Y */
+
+ if (*rank < *n) {
+ i__1 = *lwork - (mn << 1);
+ ctzrzf_(rank, n, &a[a_offset], lda, &work[mn + 1], &work[(mn << 1) +
+ 1], &i__1, info);
+ }
+
+/* complex workspace: 2*MN. */
+/* Details of Householder rotations stored in WORK(MN+1:2*MN) */
+
+/* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */
+
+ i__1 = *lwork - (mn << 1);
+ cunmqr_("Left", "Conjugate transpose", m, nrhs, &mn, &a[a_offset], lda, &
+ work[1], &b[b_offset], ldb, &work[(mn << 1) + 1], &i__1, info);
+/* Computing MAX */
+ i__1 = (mn << 1) + 1;
+ r__1 = wsize, r__2 = (mn << 1) + work[i__1].r;
+ wsize = dmax(r__1,r__2);
+
+/* complex workspace: 2*MN+NB*NRHS. */
+
+/* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */
+
+ ctrsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b2, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = *rank + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0.f, b[i__3].i = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) */
+
+ if (*rank < *n) {
+ i__1 = *n - *rank;
+ i__2 = *lwork - (mn << 1);
+ cunmrz_("Left", "Conjugate transpose", n, nrhs, rank, &i__1, &a[
+ a_offset], lda, &work[mn + 1], &b[b_offset], ldb, &work[(mn <<
+ 1) + 1], &i__2, info);
+ }
+
+/* complex workspace: 2*MN+NRHS. */
+
+/* B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = jpvt[i__];
+ i__4 = i__ + j * b_dim1;
+ work[i__3].r = b[i__4].r, work[i__3].i = b[i__4].i;
+/* L50: */
+ }
+ ccopy_(n, &work[1], &c__1, &b[j * b_dim1 + 1], &c__1);
+/* L60: */
+ }
+
+/* complex workspace: N. */
+
+/* Undo scaling */
+
+ if (iascl == 1) {
+ clascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
+ info);
+ clascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset],
+ lda, info);
+ } else if (iascl == 2) {
+ clascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
+ info);
+ clascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset],
+ lda, info);
+ }
+ if (ibscl == 1) {
+ clascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ } else if (ibscl == 2) {
+ clascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ }
+
+L70:
+ q__1.r = (real) lwkopt, q__1.i = 0.f;
+ work[1].r = q__1.r, work[1].i = q__1.i;
+
+ return 0;
+
+/* End of CGELSY */
+
+} /* cgelsy_ */
diff --git a/SRC/cgeql2.c b/SRC/cgeql2.c
new file mode 100644
index 0000000..e261411
--- /dev/null
+++ b/SRC/cgeql2.c
@@ -0,0 +1,167 @@
+/* cgeql2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cgeql2_(integer *m, integer *n, complex *a, integer *lda,
+ complex *tau, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ complex q__1;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, k;
+ complex alpha;
+ extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
+, integer *, complex *, complex *, integer *, complex *),
+ clarfp_(integer *, complex *, complex *, integer *, complex *),
+ xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGEQL2 computes a QL factorization of a complex m by n matrix A: */
+/* A = Q * L. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the m by n matrix A. */
+/* On exit, if m >= n, the lower triangle of the subarray */
+/* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L; */
+/* if m <= n, the elements on and below the (n-m)-th */
+/* superdiagonal contain the m by n lower trapezoidal matrix L; */
+/* the remaining elements, with the array TAU, represent the */
+/* unitary matrix Q as a product of elementary reflectors */
+/* (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in */
+/* A(1:m-k+i-1,n-k+i), and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGEQL2", &i__1);
+ return 0;
+ }
+
+ k = min(*m,*n);
+
+ for (i__ = k; i__ >= 1; --i__) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* A(1:m-k+i-1,n-k+i) */
+
+ i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
+ alpha.r = a[i__1].r, alpha.i = a[i__1].i;
+ i__1 = *m - k + i__;
+ clarfp_(&i__1, &alpha, &a[(*n - k + i__) * a_dim1 + 1], &c__1, &tau[
+ i__]);
+
+/* Apply H(i)' to A(1:m-k+i,1:n-k+i-1) from the left */
+
+ i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
+ a[i__1].r = 1.f, a[i__1].i = 0.f;
+ i__1 = *m - k + i__;
+ i__2 = *n - k + i__ - 1;
+ r_cnjg(&q__1, &tau[i__]);
+ clarf_("Left", &i__1, &i__2, &a[(*n - k + i__) * a_dim1 + 1], &c__1, &
+ q__1, &a[a_offset], lda, &work[1]);
+ i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
+ a[i__1].r = alpha.r, a[i__1].i = alpha.i;
+/* L10: */
+ }
+ return 0;
+
+/* End of CGEQL2 */
+
+} /* cgeql2_ */
diff --git a/SRC/cgeqlf.c b/SRC/cgeqlf.c
new file mode 100644
index 0000000..9437d05
--- /dev/null
+++ b/SRC/cgeqlf.c
@@ -0,0 +1,271 @@
+/* cgeqlf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int cgeqlf_(integer *m, integer *n, complex *a, integer *lda,
+ complex *tau, complex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, k, ib, nb, ki, kk, mu, nu, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int cgeql2_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *), clarfb_(char *, char
+ *, char *, char *, integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *), clarft_(char *, char *
+, integer *, integer *, complex *, integer *, complex *, complex *
+, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGEQLF computes a QL factorization of a complex M-by-N matrix A: */
+/* A = Q * L. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, */
+/* if m >= n, the lower triangle of the subarray */
+/* A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L; */
+/* if m <= n, the elements on and below the (n-m)-th */
+/* superdiagonal contain the M-by-N lower trapezoidal matrix L; */
+/* the remaining elements, with the array TAU, represent the */
+/* unitary matrix Q as a product of elementary reflectors */
+/* (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* For optimum performance LWORK >= N*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in */
+/* A(1:m-k+i-1,n-k+i), and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+
+ if (*info == 0) {
+ k = min(*m,*n);
+ if (k == 0) {
+ lwkopt = 1;
+ } else {
+ nb = ilaenv_(&c__1, "CGEQLF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ if (*lwork < max(1,*n) && ! lquery) {
+ *info = -7;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGEQLF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (k == 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 1;
+ iws = *n;
+ if (nb > 1 && nb < k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "CGEQLF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *n;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "CGEQLF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < k && nx < k) {
+
+/* Use blocked code initially. */
+/* The last kk columns are handled by the block method. */
+
+ ki = (k - nx - 1) / nb * nb;
+/* Computing MIN */
+ i__1 = k, i__2 = ki + nb;
+ kk = min(i__1,i__2);
+
+ i__1 = k - kk + 1;
+ i__2 = -nb;
+ for (i__ = k - kk + ki + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__
+ += i__2) {
+/* Computing MIN */
+ i__3 = k - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Compute the QL factorization of the current block */
+/* A(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1) */
+
+ i__3 = *m - k + i__ + ib - 1;
+ cgeql2_(&i__3, &ib, &a[(*n - k + i__) * a_dim1 + 1], lda, &tau[
+ i__], &work[1], &iinfo);
+ if (*n - k + i__ > 1) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__3 = *m - k + i__ + ib - 1;
+ clarft_("Backward", "Columnwise", &i__3, &ib, &a[(*n - k +
+ i__) * a_dim1 + 1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H' to A(1:m-k+i+ib-1,1:n-k+i-1) from the left */
+
+ i__3 = *m - k + i__ + ib - 1;
+ i__4 = *n - k + i__ - 1;
+ clarfb_("Left", "Conjugate transpose", "Backward", "Columnwi"
+ "se", &i__3, &i__4, &ib, &a[(*n - k + i__) * a_dim1 +
+ 1], lda, &work[1], &ldwork, &a[a_offset], lda, &work[
+ ib + 1], &ldwork);
+ }
+/* L10: */
+ }
+ mu = *m - k + i__ + nb - 1;
+ nu = *n - k + i__ + nb - 1;
+ } else {
+ mu = *m;
+ nu = *n;
+ }
+
+/* Use unblocked code to factor the last or only block */
+
+ if (mu > 0 && nu > 0) {
+ cgeql2_(&mu, &nu, &a[a_offset], lda, &tau[1], &work[1], &iinfo);
+ }
+
+ work[1].r = (real) iws, work[1].i = 0.f;
+ return 0;
+
+/* End of CGEQLF */
+
+} /* cgeqlf_ */
diff --git a/SRC/cgeqp3.c b/SRC/cgeqp3.c
new file mode 100644
index 0000000..f07fa2d
--- /dev/null
+++ b/SRC/cgeqp3.c
@@ -0,0 +1,361 @@
+/* cgeqp3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int cgeqp3_(integer *m, integer *n, complex *a, integer *lda,
+ integer *jpvt, complex *tau, complex *work, integer *lwork, real *
+ rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer j, jb, na, nb, sm, sn, nx, fjb, iws, nfxd, nbmin;
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer minmn, minws;
+ extern /* Subroutine */ int claqp2_(integer *, integer *, integer *,
+ complex *, integer *, integer *, complex *, real *, real *,
+ complex *);
+ extern doublereal scnrm2_(integer *, complex *, integer *);
+ extern /* Subroutine */ int cgeqrf_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *), xerbla_(
+ char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int claqps_(integer *, integer *, integer *,
+ integer *, integer *, complex *, integer *, integer *, complex *,
+ real *, real *, complex *, complex *, integer *);
+ integer topbmn, sminmn;
+ extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGEQP3 computes a QR factorization with column pivoting of a */
+/* matrix A: A*P = Q*R using Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the upper triangle of the array contains the */
+/* min(M,N)-by-N upper trapezoidal matrix R; the elements below */
+/* the diagonal, together with the array TAU, represent the */
+/* unitary matrix Q as a product of min(M,N) elementary */
+/* reflectors. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* On entry, if JPVT(J).ne.0, the J-th column of A is permuted */
+/* to the front of A*P (a leading column); if JPVT(J)=0, */
+/* the J-th column of A is a free column. */
+/* On exit, if JPVT(J)=K, then the J-th column of A*P was the */
+/* the K-th column of A. */
+
+/* TAU (output) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO=0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= N+1. */
+/* For optimal performance LWORK >= ( N+1 )*NB, where NB */
+/* is the optimal blocksize. */
+
+/* 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. */
+
+/* RWORK (workspace) REAL array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real/complex scalar, and v is a real/complex vector */
+/* with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in */
+/* A(i+1:m,i), and tau in TAU(i). */
+
+/* Based on contributions by */
+/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
+/* X. Sun, Computer Science Dept., Duke University, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test input arguments */
+/* ==================== */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --jpvt;
+ --tau;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+
+ if (*info == 0) {
+ minmn = min(*m,*n);
+ if (minmn == 0) {
+ iws = 1;
+ lwkopt = 1;
+ } else {
+ iws = *n + 1;
+ nb = ilaenv_(&c__1, "CGEQRF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = (*n + 1) * nb;
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ if (*lwork < iws && ! lquery) {
+ *info = -8;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGEQP3", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (minmn == 0) {
+ return 0;
+ }
+
+/* Move initial columns up front. */
+
+ nfxd = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (jpvt[j] != 0) {
+ if (j != nfxd) {
+ cswap_(m, &a[j * a_dim1 + 1], &c__1, &a[nfxd * a_dim1 + 1], &
+ c__1);
+ jpvt[j] = jpvt[nfxd];
+ jpvt[nfxd] = j;
+ } else {
+ jpvt[j] = j;
+ }
+ ++nfxd;
+ } else {
+ jpvt[j] = j;
+ }
+/* L10: */
+ }
+ --nfxd;
+
+/* Factorize fixed columns */
+/* ======================= */
+
+/* Compute the QR factorization of fixed columns and update */
+/* remaining columns. */
+
+ if (nfxd > 0) {
+ na = min(*m,nfxd);
+/* CC CALL CGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) */
+ cgeqrf_(m, &na, &a[a_offset], lda, &tau[1], &work[1], lwork, info);
+/* Computing MAX */
+ i__1 = iws, i__2 = (integer) work[1].r;
+ iws = max(i__1,i__2);
+ if (na < *n) {
+/* CC CALL CUNM2R( 'Left', 'Conjugate Transpose', M, N-NA, */
+/* CC $ NA, A, LDA, TAU, A( 1, NA+1 ), LDA, WORK, */
+/* CC $ INFO ) */
+ i__1 = *n - na;
+ cunmqr_("Left", "Conjugate Transpose", m, &i__1, &na, &a[a_offset]
+, lda, &tau[1], &a[(na + 1) * a_dim1 + 1], lda, &work[1],
+ lwork, info);
+/* Computing MAX */
+ i__1 = iws, i__2 = (integer) work[1].r;
+ iws = max(i__1,i__2);
+ }
+ }
+
+/* Factorize free columns */
+/* ====================== */
+
+ if (nfxd < minmn) {
+
+ sm = *m - nfxd;
+ sn = *n - nfxd;
+ sminmn = minmn - nfxd;
+
+/* Determine the block size. */
+
+ nb = ilaenv_(&c__1, "CGEQRF", " ", &sm, &sn, &c_n1, &c_n1);
+ nbmin = 2;
+ nx = 0;
+
+ if (nb > 1 && nb < sminmn) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "CGEQRF", " ", &sm, &sn, &c_n1, &
+ c_n1);
+ nx = max(i__1,i__2);
+
+
+ if (nx < sminmn) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ minws = (sn + 1) * nb;
+ iws = max(iws,minws);
+ if (*lwork < minws) {
+
+/* Not enough workspace to use optimal NB: Reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / (sn + 1);
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "CGEQRF", " ", &sm, &sn, &
+ c_n1, &c_n1);
+ nbmin = max(i__1,i__2);
+
+
+ }
+ }
+ }
+
+/* Initialize partial column norms. The first N elements of work */
+/* store the exact column norms. */
+
+ i__1 = *n;
+ for (j = nfxd + 1; j <= i__1; ++j) {
+ rwork[j] = scnrm2_(&sm, &a[nfxd + 1 + j * a_dim1], &c__1);
+ rwork[*n + j] = rwork[j];
+/* L20: */
+ }
+
+ if (nb >= nbmin && nb < sminmn && nx < sminmn) {
+
+/* Use blocked code initially. */
+
+ j = nfxd + 1;
+
+/* Compute factorization: while loop. */
+
+
+ topbmn = minmn - nx;
+L30:
+ if (j <= topbmn) {
+/* Computing MIN */
+ i__1 = nb, i__2 = topbmn - j + 1;
+ jb = min(i__1,i__2);
+
+/* Factorize JB columns among columns J:N. */
+
+ i__1 = *n - j + 1;
+ i__2 = j - 1;
+ i__3 = *n - j + 1;
+ claqps_(m, &i__1, &i__2, &jb, &fjb, &a[j * a_dim1 + 1], lda, &
+ jpvt[j], &tau[j], &rwork[j], &rwork[*n + j], &work[1],
+ &work[jb + 1], &i__3);
+
+ j += fjb;
+ goto L30;
+ }
+ } else {
+ j = nfxd + 1;
+ }
+
+/* Use unblocked code to factor the last or only block. */
+
+
+ if (j <= minmn) {
+ i__1 = *n - j + 1;
+ i__2 = j - 1;
+ claqp2_(m, &i__1, &i__2, &a[j * a_dim1 + 1], lda, &jpvt[j], &tau[
+ j], &rwork[j], &rwork[*n + j], &work[1]);
+ }
+
+ }
+
+ work[1].r = (real) iws, work[1].i = 0.f;
+ return 0;
+
+/* End of CGEQP3 */
+
+} /* cgeqp3_ */
diff --git a/SRC/cgeqpf.c b/SRC/cgeqpf.c
new file mode 100644
index 0000000..b341824
--- /dev/null
+++ b/SRC/cgeqpf.c
@@ -0,0 +1,315 @@
+/* cgeqpf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cgeqpf_(integer *m, integer *n, complex *a, integer *lda,
+ integer *jpvt, complex *tau, complex *work, real *rwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ void r_cnjg(complex *, complex *);
+ double c_abs(complex *);
+
+ /* Local variables */
+ integer i__, j, ma, mn;
+ complex aii;
+ integer pvt;
+ real temp, temp2, tol3z;
+ extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
+, integer *, complex *, complex *, integer *, complex *),
+ cswap_(integer *, complex *, integer *, complex *, integer *);
+ integer itemp;
+ extern /* Subroutine */ int cgeqr2_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *);
+ extern doublereal scnrm2_(integer *, complex *, integer *);
+ extern /* Subroutine */ int cunm2r_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *), clarfp_(integer *, complex
+ *, complex *, integer *, complex *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+
+
+/* -- LAPACK deprecated driver routine (version 3.2) -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine CGEQP3. */
+
+/* CGEQPF computes a QR factorization with column pivoting of a */
+/* complex M-by-N matrix A: A*P = Q*R. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0 */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the upper triangle of the array contains the */
+/* min(M,N)-by-N upper triangular matrix R; the elements */
+/* below the diagonal, together with the array TAU, */
+/* represent the unitary matrix Q as a product of */
+/* min(m,n) elementary reflectors. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
+/* to the front of A*P (a leading column); if JPVT(i) = 0, */
+/* the i-th column of A is a free column. */
+/* On exit, if JPVT(i) = k, then the i-th column of A*P */
+/* was the k-th column of A. */
+
+/* TAU (output) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors. */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* RWORK (workspace) REAL array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(n) */
+
+/* Each H(i) has the form */
+
+/* H = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). */
+
+/* The matrix P is represented in jpvt as follows: If */
+/* jpvt(j) = i */
+/* then the jth column of P is the ith canonical unit vector. */
+
+/* Partial column norm updating strategy modified by */
+/* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */
+/* University of Zagreb, Croatia. */
+/* June 2006. */
+/* For more details see LAPACK Working Note 176. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --jpvt;
+ --tau;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGEQPF", &i__1);
+ return 0;
+ }
+
+ mn = min(*m,*n);
+ tol3z = sqrt(slamch_("Epsilon"));
+
+/* Move initial columns up front */
+
+ itemp = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (jpvt[i__] != 0) {
+ if (i__ != itemp) {
+ cswap_(m, &a[i__ * a_dim1 + 1], &c__1, &a[itemp * a_dim1 + 1],
+ &c__1);
+ jpvt[i__] = jpvt[itemp];
+ jpvt[itemp] = i__;
+ } else {
+ jpvt[i__] = i__;
+ }
+ ++itemp;
+ } else {
+ jpvt[i__] = i__;
+ }
+/* L10: */
+ }
+ --itemp;
+
+/* Compute the QR factorization and update remaining columns */
+
+ if (itemp > 0) {
+ ma = min(itemp,*m);
+ cgeqr2_(m, &ma, &a[a_offset], lda, &tau[1], &work[1], info);
+ if (ma < *n) {
+ i__1 = *n - ma;
+ cunm2r_("Left", "Conjugate transpose", m, &i__1, &ma, &a[a_offset]
+, lda, &tau[1], &a[(ma + 1) * a_dim1 + 1], lda, &work[1],
+ info);
+ }
+ }
+
+ if (itemp < mn) {
+
+/* Initialize partial column norms. The first n elements of */
+/* work store the exact column norms. */
+
+ i__1 = *n;
+ for (i__ = itemp + 1; i__ <= i__1; ++i__) {
+ i__2 = *m - itemp;
+ rwork[i__] = scnrm2_(&i__2, &a[itemp + 1 + i__ * a_dim1], &c__1);
+ rwork[*n + i__] = rwork[i__];
+/* L20: */
+ }
+
+/* Compute factorization */
+
+ i__1 = mn;
+ for (i__ = itemp + 1; i__ <= i__1; ++i__) {
+
+/* Determine ith pivot column and swap if necessary */
+
+ i__2 = *n - i__ + 1;
+ pvt = i__ - 1 + isamax_(&i__2, &rwork[i__], &c__1);
+
+ if (pvt != i__) {
+ cswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
+ c__1);
+ itemp = jpvt[pvt];
+ jpvt[pvt] = jpvt[i__];
+ jpvt[i__] = itemp;
+ rwork[pvt] = rwork[i__];
+ rwork[*n + pvt] = rwork[*n + i__];
+ }
+
+/* Generate elementary reflector H(i) */
+
+ i__2 = i__ + i__ * a_dim1;
+ aii.r = a[i__2].r, aii.i = a[i__2].i;
+ i__2 = *m - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ clarfp_(&i__2, &aii, &a[min(i__3, *m)+ i__ * a_dim1], &c__1, &tau[
+ i__]);
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = aii.r, a[i__2].i = aii.i;
+
+ if (i__ < *n) {
+
+/* Apply H(i) to A(i:m,i+1:n) from the left */
+
+ i__2 = i__ + i__ * a_dim1;
+ aii.r = a[i__2].r, aii.i = a[i__2].i;
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+ i__2 = *m - i__ + 1;
+ i__3 = *n - i__;
+ r_cnjg(&q__1, &tau[i__]);
+ clarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
+ q__1, &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = aii.r, a[i__2].i = aii.i;
+ }
+
+/* Update partial column norms */
+
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (rwork[j] != 0.f) {
+
+/* NOTE: The following 4 lines follow from the analysis in */
+/* Lapack Working Note 176. */
+
+ temp = c_abs(&a[i__ + j * a_dim1]) / rwork[j];
+/* Computing MAX */
+ r__1 = 0.f, r__2 = (temp + 1.f) * (1.f - temp);
+ temp = dmax(r__1,r__2);
+/* Computing 2nd power */
+ r__1 = rwork[j] / rwork[*n + j];
+ temp2 = temp * (r__1 * r__1);
+ if (temp2 <= tol3z) {
+ if (*m - i__ > 0) {
+ i__3 = *m - i__;
+ rwork[j] = scnrm2_(&i__3, &a[i__ + 1 + j * a_dim1]
+, &c__1);
+ rwork[*n + j] = rwork[j];
+ } else {
+ rwork[j] = 0.f;
+ rwork[*n + j] = 0.f;
+ }
+ } else {
+ rwork[j] *= sqrt(temp);
+ }
+ }
+/* L30: */
+ }
+
+/* L40: */
+ }
+ }
+ return 0;
+
+/* End of CGEQPF */
+
+} /* cgeqpf_ */
diff --git a/SRC/cgeqr2.c b/SRC/cgeqr2.c
new file mode 100644
index 0000000..8c46a05
--- /dev/null
+++ b/SRC/cgeqr2.c
@@ -0,0 +1,169 @@
+/* cgeqr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cgeqr2_(integer *m, integer *n, complex *a, integer *lda,
+ complex *tau, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ complex q__1;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, k;
+ complex alpha;
+ extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
+, integer *, complex *, complex *, integer *, complex *),
+ clarfp_(integer *, complex *, complex *, integer *, complex *),
+ xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGEQR2 computes a QR factorization of a complex m by n matrix A: */
+/* A = Q * R. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the m by n matrix A. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(m,n) by n upper trapezoidal matrix R (R is */
+/* upper triangular if m >= n); the elements below the diagonal, */
+/* with the array TAU, represent the unitary matrix Q as a */
+/* product of elementary reflectors (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */
+/* and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGEQR2", &i__1);
+ return 0;
+ }
+
+ k = min(*m,*n);
+
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
+
+ i__2 = *m - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ clarfp_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3, *m)+ i__ * a_dim1]
+, &c__1, &tau[i__]);
+ if (i__ < *n) {
+
+/* Apply H(i)' to A(i:m,i+1:n) from the left */
+
+ i__2 = i__ + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+ i__2 = *m - i__ + 1;
+ i__3 = *n - i__;
+ r_cnjg(&q__1, &tau[i__]);
+ clarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &q__1,
+ &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = alpha.r, a[i__2].i = alpha.i;
+ }
+/* L10: */
+ }
+ return 0;
+
+/* End of CGEQR2 */
+
+} /* cgeqr2_ */
diff --git a/SRC/cgeqrf.c b/SRC/cgeqrf.c
new file mode 100644
index 0000000..c473abe
--- /dev/null
+++ b/SRC/cgeqrf.c
@@ -0,0 +1,253 @@
+/* cgeqrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int cgeqrf_(integer *m, integer *n, complex *a, integer *lda,
+ complex *tau, complex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, k, ib, nb, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int cgeqr2_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *), clarfb_(char *, char
+ *, char *, char *, integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *), clarft_(char *, char *
+, integer *, integer *, complex *, integer *, complex *, complex *
+, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGEQRF computes a QR factorization of a complex M-by-N matrix A: */
+/* A = Q * R. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(M,N)-by-N upper trapezoidal matrix R (R is */
+/* upper triangular if m >= n); the elements below the diagonal, */
+/* with the array TAU, represent the unitary matrix Q as a */
+/* product of min(m,n) elementary reflectors (see Further */
+/* Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* For optimum performance LWORK >= N*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */
+/* and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb = ilaenv_(&c__1, "CGEQRF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGEQRF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ k = min(*m,*n);
+ if (k == 0) {
+ work[1].r = 1.f, work[1].i = 0.f;
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *n;
+ if (nb > 1 && nb < k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "CGEQRF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *n;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "CGEQRF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < k && nx < k) {
+
+/* Use blocked code initially */
+
+ i__1 = k - nx;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = k - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Compute the QR factorization of the current block */
+/* A(i:m,i:i+ib-1) */
+
+ i__3 = *m - i__ + 1;
+ cgeqr2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
+ 1], &iinfo);
+ if (i__ + ib <= *n) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__3 = *m - i__ + 1;
+ clarft_("Forward", "Columnwise", &i__3, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H' to A(i:m,i+ib:n) from the left */
+
+ i__3 = *m - i__ + 1;
+ i__4 = *n - i__ - ib + 1;
+ clarfb_("Left", "Conjugate transpose", "Forward", "Columnwise"
+, &i__3, &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &
+ work[1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda,
+ &work[ib + 1], &ldwork);
+ }
+/* L10: */
+ }
+ } else {
+ i__ = 1;
+ }
+
+/* Use unblocked code to factor the last or only block. */
+
+ if (i__ <= k) {
+ i__2 = *m - i__ + 1;
+ i__1 = *n - i__ + 1;
+ cgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
+, &iinfo);
+ }
+
+ work[1].r = (real) iws, work[1].i = 0.f;
+ return 0;
+
+/* End of CGEQRF */
+
+} /* cgeqrf_ */
diff --git a/SRC/cgerfs.c b/SRC/cgerfs.c
new file mode 100644
index 0000000..c9f854c
--- /dev/null
+++ b/SRC/cgerfs.c
@@ -0,0 +1,460 @@
+/* cgerfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cgerfs_(char *trans, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex *
+ b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr,
+ complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ real s, xk;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *);
+ integer isave[3];
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ integer count;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *), cgetrs_(
+ char *, integer *, integer *, complex *, integer *, integer *,
+ complex *, integer *, integer *);
+ logical notran;
+ char transn[1], transt[1];
+ real lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGERFS improves the computed solution to a system of linear */
+/* equations and provides error bounds and backward error estimates for */
+/* the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The original N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The factors L and U from the factorization A = P*L*U */
+/* as computed by CGETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from CGETRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by CGETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldx < max(1,*n)) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGERFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transn = 'N';
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transn = 'C';
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.f;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A, A**T, or A**H, depending on TRANS. */
+
+ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_(trans, n, n, &q__1, &a[a_offset], lda, &x[j * x_dim1 + 1], &
+ c__1, &c_b1, &work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[
+ i__ + j * b_dim1]), dabs(r__2));
+/* L30: */
+ }
+
+/* Compute abs(op(A))*abs(X) + abs(B). */
+
+ if (notran) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j
+ * x_dim1]), dabs(r__2));
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + k * a_dim1]), dabs(r__2))) * xk;
+/* L40: */
+ }
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ i__ + k * a_dim1]), dabs(r__2))) * ((r__3 = x[
+ i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[i__ + j *
+ x_dim1]), dabs(r__4)));
+/* L60: */
+ }
+ rwork[k] += s;
+/* L70: */
+ }
+ }
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__3 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
+ s = dmax(r__3,r__4);
+ } else {
+/* Computing MAX */
+ i__3 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = dmax(r__3,r__4);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ cgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[1],
+ n, info);
+ caxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use CLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__3 = i__;
+ rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__];
+ } else {
+ i__3 = i__;
+ rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__] + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)**H). */
+
+ cgetrs_(transt, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &
+ work[1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L110: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L120: */
+ }
+ cgetrs_(transn, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &
+ work[1], n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * x_dim1;
+ r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + j * x_dim1]), dabs(r__2));
+ lstres = dmax(r__3,r__4);
+/* L130: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of CGERFS */
+
+} /* cgerfs_ */
diff --git a/SRC/cgerfsx.c b/SRC/cgerfsx.c
new file mode 100644
index 0000000..ffc7073
--- /dev/null
+++ b/SRC/cgerfsx.c
@@ -0,0 +1,666 @@
+/* cgerfsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int cgerfsx_(char *trans, char *equed, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *
+ ipiv, real *r__, real *c__, complex *b, integer *ldb, complex *x,
+ integer *ldx, real *rcond, real *berr, integer *n_err_bnds__, real *
+ err_bnds_norm__, real *err_bnds_comp__, integer *nparams, real *
+ params, complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real illrcond_thresh__, unstable_thresh__, err_lbnd__;
+ integer ref_type__;
+ extern integer ilatrans_(char *);
+ integer j;
+ real rcond_tmp__;
+ integer prec_type__, trans_type__;
+ real cwise_wrong__;
+ extern /* Subroutine */ int cla_gerfsx_extended__(integer *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ integer *, logical *, real *, complex *, integer *, complex *,
+ integer *, real *, integer *, real *, real *, complex *, real *,
+ complex *, complex *, real *, integer *, real *, real *, logical *
+ , integer *);
+ char norm[1];
+ logical ignore_cwise__;
+ extern doublereal cla_gercond_c__(char *, integer *, complex *, integer *,
+ complex *, integer *, integer *, real *, logical *, integer *,
+ complex *, real *, ftnlen);
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern doublereal cla_gercond_x__(char *, integer *, complex *, integer *,
+ complex *, integer *, integer *, complex *, integer *, complex *,
+ real *, ftnlen), clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int cgecon_(char *, integer *, complex *, integer
+ *, real *, real *, complex *, real *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical colequ, notran, rowequ;
+ extern integer ilaprec_(char *);
+ integer ithresh, n_norms__;
+ real rthresh;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGERFSX improves the computed solution to a system of linear */
+/* equations and provides error bounds and backward error estimates */
+/* for the solution. In addition to normwise error bound, the code */
+/* provides maximum componentwise error bound if possible. See */
+/* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the */
+/* error bounds. */
+
+/* The original system of linear equations may have been equilibrated */
+/* before calling this routine, as described by arguments EQUED, R */
+/* and C below. In this case, the solution and error bounds returned */
+/* are for the original unequilibrated system. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* EQUED (input) CHARACTER*1 */
+/* Specifies the form of equilibration that was done to A */
+/* before calling this routine. This is needed to compute */
+/* the solution and error bounds correctly. */
+/* = 'N': No equilibration */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* The right hand side B has been changed accordingly. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The original N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The factors L and U from the factorization A = P*L*U */
+/* as computed by CGETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from CGETRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* R (input or output) REAL array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+/* If R is output, each element of R is a power of the radix. */
+/* If R is input, each element of R should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* C (input or output) REAL array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+/* If C is output, each element of C is a power of the radix. */
+/* If C is input, each element of C should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by CGETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) REAL array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check the input parameters. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ trans_type__ = ilatrans_(trans);
+ ref_type__ = 1;
+ if (*nparams >= 1) {
+ if (params[1] < 0.f) {
+ params[1] = 1.f;
+ } else {
+ ref_type__ = params[1];
+ }
+ }
+
+/* Set default parameters. */
+
+ illrcond_thresh__ = (real) (*n) * slamch_("Epsilon");
+ ithresh = 10;
+ rthresh = .5f;
+ unstable_thresh__ = .25f;
+ ignore_cwise__ = FALSE_;
+
+ if (*nparams >= 2) {
+ if (params[2] < 0.f) {
+ params[2] = (real) ithresh;
+ } else {
+ ithresh = (integer) params[2];
+ }
+ }
+ if (*nparams >= 3) {
+ if (params[3] < 0.f) {
+ if (ignore_cwise__) {
+ params[3] = 0.f;
+ } else {
+ params[3] = 1.f;
+ }
+ } else {
+ ignore_cwise__ = params[3] == 0.f;
+ }
+ }
+ if (ref_type__ == 0 || *n_err_bnds__ == 0) {
+ n_norms__ = 0;
+ } else if (ignore_cwise__) {
+ n_norms__ = 1;
+ } else {
+ n_norms__ = 2;
+ }
+
+ notran = lsame_(trans, "N");
+ rowequ = lsame_(equed, "R") || lsame_(equed, "B");
+ colequ = lsame_(equed, "C") || lsame_(equed, "B");
+
+/* Test input parameters. */
+
+ if (trans_type__ == -1) {
+ *info = -1;
+ } else if (! rowequ && ! colequ && ! lsame_(equed, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -13;
+ } else if (*ldx < max(1,*n)) {
+ *info = -15;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGERFSX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *nrhs == 0) {
+ *rcond = 1.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 0.f;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.f;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.f;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.f;
+ }
+ }
+ return 0;
+ }
+
+/* Default to failure. */
+
+ *rcond = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 1.f;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.f;
+ }
+ }
+
+/* Compute the norm of A and the reciprocal of the condition */
+/* number of A. */
+
+ if (notran) {
+ *(unsigned char *)norm = 'I';
+ } else {
+ *(unsigned char *)norm = '1';
+ }
+ anorm = clange_(norm, n, n, &a[a_offset], lda, &rwork[1]);
+ cgecon_(norm, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &rwork[1],
+ info);
+
+/* Perform refinement on each right-hand side */
+
+ if (ref_type__ != 0) {
+ prec_type__ = ilaprec_("D");
+ if (notran) {
+ cla_gerfsx_extended__(&prec_type__, &trans_type__, n, nrhs, &a[
+ a_offset], lda, &af[af_offset], ldaf, &ipiv[1], &colequ, &
+ c__[1], &b[b_offset], ldb, &x[x_offset], ldx, &berr[1], &
+ n_norms__, &err_bnds_norm__[err_bnds_norm_offset], &
+ err_bnds_comp__[err_bnds_comp_offset], &work[1], &rwork[1]
+ , &work[*n + 1], (complex *)(&rwork[1]), rcond, &ithresh, &rthresh, &
+ unstable_thresh__, &ignore_cwise__, info);
+ } else {
+ cla_gerfsx_extended__(&prec_type__, &trans_type__, n, nrhs, &a[
+ a_offset], lda, &af[af_offset], ldaf, &ipiv[1], &rowequ, &
+ r__[1], &b[b_offset], ldb, &x[x_offset], ldx, &berr[1], &
+ n_norms__, &err_bnds_norm__[err_bnds_norm_offset], &
+ err_bnds_comp__[err_bnds_comp_offset], &work[1], &rwork[1]
+ , &work[*n + 1], (complex *)(&rwork[1]), rcond, &ithresh, &rthresh, &
+ unstable_thresh__, &ignore_cwise__, info);
+ }
+ }
+/* Computing MAX */
+ r__1 = 10.f, r__2 = sqrt((real) (*n));
+ err_lbnd__ = dmax(r__1,r__2) * slamch_("Epsilon");
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {
+
+/* Compute scaled normwise condition number cond(A*C). */
+
+ if (colequ && notran) {
+ rcond_tmp__ = cla_gercond_c__(trans, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &c__[1], &c_true, info, &work[
+ 1], &rwork[1], (ftnlen)1);
+ } else if (rowequ && ! notran) {
+ rcond_tmp__ = cla_gercond_c__(trans, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &r__[1], &c_true, info, &work[
+ 1], &rwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = cla_gercond_c__(trans, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &c__[1], &c_false, info, &
+ work[1], &rwork[1], (ftnlen)1);
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1
+ << 1)] > 1.f) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 0.f;
+ if (*info <= *n) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {
+
+/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
+/* each right-hand side using the current solution as an estimate of */
+/* the true solution. If the componentwise error estimate is too */
+/* large, then the solution is a lousy estimate of truth and the */
+/* estimated RCOND may be too optimistic. To avoid misleading users, */
+/* the inverse condition number is set to 0.0 when the estimated */
+/* cwise error is at least CWISE_WRONG. */
+
+ cwise_wrong__ = sqrt(slamch_("Epsilon"));
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ cwise_wrong__) {
+ rcond_tmp__ = cla_gercond_x__(trans, n, &a[a_offset], lda, &
+ af[af_offset], ldaf, &ipiv[1], &x[j * x_dim1 + 1],
+ info, &work[1], &rwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = 0.f;
+ }
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1
+ << 1)] > 1.f) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 0.f;
+ if (params[3] == 1.f && *info < *n + j) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CGERFSX */
+
+} /* cgerfsx_ */
diff --git a/SRC/cgerq2.c b/SRC/cgerq2.c
new file mode 100644
index 0000000..885c716
--- /dev/null
+++ b/SRC/cgerq2.c
@@ -0,0 +1,162 @@
+/* cgerq2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cgerq2_(integer *m, integer *n, complex *a, integer *lda,
+ complex *tau, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, k;
+ complex alpha;
+ extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
+, integer *, complex *, complex *, integer *, complex *),
+ clacgv_(integer *, complex *, integer *), clarfp_(integer *,
+ complex *, complex *, integer *, complex *), xerbla_(char *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGERQ2 computes an RQ factorization of a complex m by n matrix A: */
+/* A = R * Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the m by n matrix A. */
+/* On exit, if m <= n, the upper triangle of the subarray */
+/* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R; */
+/* if m >= n, the elements on and above the (m-n)-th subdiagonal */
+/* contain the m by n upper trapezoidal matrix R; the remaining */
+/* elements, with the array TAU, represent the unitary matrix */
+/* Q as a product of elementary reflectors (see Further */
+/* Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace) COMPLEX array, dimension (M) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1)' H(2)' . . . H(k)', where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on */
+/* exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGERQ2", &i__1);
+ return 0;
+ }
+
+ k = min(*m,*n);
+
+ for (i__ = k; i__ >= 1; --i__) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* A(m-k+i,1:n-k+i-1) */
+
+ i__1 = *n - k + i__;
+ clacgv_(&i__1, &a[*m - k + i__ + a_dim1], lda);
+ i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
+ alpha.r = a[i__1].r, alpha.i = a[i__1].i;
+ i__1 = *n - k + i__;
+ clarfp_(&i__1, &alpha, &a[*m - k + i__ + a_dim1], lda, &tau[i__]);
+
+/* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right */
+
+ i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
+ a[i__1].r = 1.f, a[i__1].i = 0.f;
+ i__1 = *m - k + i__ - 1;
+ i__2 = *n - k + i__;
+ clarf_("Right", &i__1, &i__2, &a[*m - k + i__ + a_dim1], lda, &tau[
+ i__], &a[a_offset], lda, &work[1]);
+ i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
+ a[i__1].r = alpha.r, a[i__1].i = alpha.i;
+ i__1 = *n - k + i__ - 1;
+ clacgv_(&i__1, &a[*m - k + i__ + a_dim1], lda);
+/* L10: */
+ }
+ return 0;
+
+/* End of CGERQ2 */
+
+} /* cgerq2_ */
diff --git a/SRC/cgerqf.c b/SRC/cgerqf.c
new file mode 100644
index 0000000..204b487
--- /dev/null
+++ b/SRC/cgerqf.c
@@ -0,0 +1,270 @@
+/* cgerqf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int cgerqf_(integer *m, integer *n, complex *a, integer *lda,
+ complex *tau, complex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, k, ib, nb, ki, kk, mu, nu, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int cgerq2_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *), clarfb_(char *, char
+ *, char *, char *, integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *), clarft_(char *, char *
+, integer *, integer *, complex *, integer *, complex *, complex *
+, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGERQF computes an RQ factorization of a complex M-by-N matrix A: */
+/* A = R * Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, */
+/* if m <= n, the upper triangle of the subarray */
+/* A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R; */
+/* if m >= n, the elements on and above the (m-n)-th subdiagonal */
+/* contain the M-by-N upper trapezoidal matrix R; */
+/* the remaining elements, with the array TAU, represent the */
+/* unitary matrix Q as a product of min(m,n) elementary */
+/* reflectors (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M). */
+/* For optimum performance LWORK >= M*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1)' H(2)' . . . H(k)', where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on */
+/* exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+
+ if (*info == 0) {
+ k = min(*m,*n);
+ if (k == 0) {
+ lwkopt = 1;
+ } else {
+ nb = ilaenv_(&c__1, "CGERQF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = *m * nb;
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ if (*lwork < max(1,*m) && ! lquery) {
+ *info = -7;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGERQF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (k == 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 1;
+ iws = *m;
+ if (nb > 1 && nb < k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "CGERQF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *m;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "CGERQF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < k && nx < k) {
+
+/* Use blocked code initially. */
+/* The last kk rows are handled by the block method. */
+
+ ki = (k - nx - 1) / nb * nb;
+/* Computing MIN */
+ i__1 = k, i__2 = ki + nb;
+ kk = min(i__1,i__2);
+
+ i__1 = k - kk + 1;
+ i__2 = -nb;
+ for (i__ = k - kk + ki + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__
+ += i__2) {
+/* Computing MIN */
+ i__3 = k - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Compute the RQ factorization of the current block */
+/* A(m-k+i:m-k+i+ib-1,1:n-k+i+ib-1) */
+
+ i__3 = *n - k + i__ + ib - 1;
+ cgerq2_(&ib, &i__3, &a[*m - k + i__ + a_dim1], lda, &tau[i__], &
+ work[1], &iinfo);
+ if (*m - k + i__ > 1) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__3 = *n - k + i__ + ib - 1;
+ clarft_("Backward", "Rowwise", &i__3, &ib, &a[*m - k + i__ +
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H to A(1:m-k+i-1,1:n-k+i+ib-1) from the right */
+
+ i__3 = *m - k + i__ - 1;
+ i__4 = *n - k + i__ + ib - 1;
+ clarfb_("Right", "No transpose", "Backward", "Rowwise", &i__3,
+ &i__4, &ib, &a[*m - k + i__ + a_dim1], lda, &work[1],
+ &ldwork, &a[a_offset], lda, &work[ib + 1], &ldwork);
+ }
+/* L10: */
+ }
+ mu = *m - k + i__ + nb - 1;
+ nu = *n - k + i__ + nb - 1;
+ } else {
+ mu = *m;
+ nu = *n;
+ }
+
+/* Use unblocked code to factor the last or only block */
+
+ if (mu > 0 && nu > 0) {
+ cgerq2_(&mu, &nu, &a[a_offset], lda, &tau[1], &work[1], &iinfo);
+ }
+
+ work[1].r = (real) iws, work[1].i = 0.f;
+ return 0;
+
+/* End of CGERQF */
+
+} /* cgerqf_ */
diff --git a/SRC/cgesc2.c b/SRC/cgesc2.c
new file mode 100644
index 0000000..111103e
--- /dev/null
+++ b/SRC/cgesc2.c
@@ -0,0 +1,206 @@
+/* cgesc2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static complex c_b13 = {1.f,0.f};
+static integer c_n1 = -1;
+
+/* Subroutine */ int cgesc2_(integer *n, complex *a, integer *lda, complex *
+ rhs, integer *ipiv, integer *jpiv, real *scale)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer i__, j;
+ real eps;
+ complex temp;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *), slabad_(real *, real *);
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ real bignum;
+ extern /* Subroutine */ int claswp_(integer *, complex *, integer *,
+ integer *, integer *, integer *, integer *);
+ real smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGESC2 solves a system of linear equations */
+
+/* A * X = scale* RHS */
+
+/* with a general N-by-N matrix A using the LU factorization with */
+/* complete pivoting computed by CGETC2. */
+
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+
+/* A (input) COMPLEX array, dimension (LDA, N) */
+/* On entry, the LU part of the factorization of the n-by-n */
+/* matrix A computed by CGETC2: A = P * L * U * Q */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1, N). */
+
+/* RHS (input/output) COMPLEX array, dimension N. */
+/* On entry, the right hand side vector b. */
+/* On exit, the solution vector X. */
+
+/* IPIV (input) INTEGER array, dimension (N). */
+/* The pivot indices; for 1 <= i <= N, row i of the */
+/* matrix has been interchanged with row IPIV(i). */
+
+/* JPIV (input) INTEGER array, dimension (N). */
+/* The pivot indices; for 1 <= j <= N, column j of the */
+/* matrix has been interchanged with column JPIV(j). */
+
+/* SCALE (output) REAL */
+/* On exit, SCALE contains the scale factor. SCALE is chosen */
+/* 0 <= SCALE <= 1 to prevent owerflow in the solution. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Set constant to control overflow */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --rhs;
+ --ipiv;
+ --jpiv;
+
+ /* Function Body */
+ eps = slamch_("P");
+ smlnum = slamch_("S") / eps;
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Apply permutations IPIV to RHS */
+
+ i__1 = *n - 1;
+ claswp_(&c__1, &rhs[1], lda, &c__1, &i__1, &ipiv[1], &c__1);
+
+/* Solve for L part */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j;
+ i__4 = j;
+ i__5 = j + i__ * a_dim1;
+ i__6 = i__;
+ q__2.r = a[i__5].r * rhs[i__6].r - a[i__5].i * rhs[i__6].i,
+ q__2.i = a[i__5].r * rhs[i__6].i + a[i__5].i * rhs[i__6]
+ .r;
+ q__1.r = rhs[i__4].r - q__2.r, q__1.i = rhs[i__4].i - q__2.i;
+ rhs[i__3].r = q__1.r, rhs[i__3].i = q__1.i;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Solve for U part */
+
+ *scale = 1.f;
+
+/* Check for scaling */
+
+ i__ = icamax_(n, &rhs[1], &c__1);
+ if (smlnum * 2.f * c_abs(&rhs[i__]) > c_abs(&a[*n + *n * a_dim1])) {
+ r__1 = c_abs(&rhs[i__]);
+ q__1.r = .5f / r__1, q__1.i = 0.f / r__1;
+ temp.r = q__1.r, temp.i = q__1.i;
+ cscal_(n, &temp, &rhs[1], &c__1);
+ *scale *= temp.r;
+ }
+ for (i__ = *n; i__ >= 1; --i__) {
+ c_div(&q__1, &c_b13, &a[i__ + i__ * a_dim1]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__1 = i__;
+ i__2 = i__;
+ q__1.r = rhs[i__2].r * temp.r - rhs[i__2].i * temp.i, q__1.i = rhs[
+ i__2].r * temp.i + rhs[i__2].i * temp.r;
+ rhs[i__1].r = q__1.r, rhs[i__1].i = q__1.i;
+ i__1 = *n;
+ for (j = i__ + 1; j <= i__1; ++j) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = j;
+ i__5 = i__ + j * a_dim1;
+ q__3.r = a[i__5].r * temp.r - a[i__5].i * temp.i, q__3.i = a[i__5]
+ .r * temp.i + a[i__5].i * temp.r;
+ q__2.r = rhs[i__4].r * q__3.r - rhs[i__4].i * q__3.i, q__2.i =
+ rhs[i__4].r * q__3.i + rhs[i__4].i * q__3.r;
+ q__1.r = rhs[i__3].r - q__2.r, q__1.i = rhs[i__3].i - q__2.i;
+ rhs[i__2].r = q__1.r, rhs[i__2].i = q__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Apply permutations JPIV to the solution (RHS) */
+
+ i__1 = *n - 1;
+ claswp_(&c__1, &rhs[1], lda, &c__1, &i__1, &jpiv[1], &c_n1);
+ return 0;
+
+/* End of CGESC2 */
+
+} /* cgesc2_ */
diff --git a/SRC/cgesdd.c b/SRC/cgesdd.c
new file mode 100644
index 0000000..6149ae7
--- /dev/null
+++ b/SRC/cgesdd.c
@@ -0,0 +1,2240 @@
+/* cgesdd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+
+/* Subroutine */ int cgesdd_(char *jobz, integer *m, integer *n, complex *a,
+ integer *lda, real *s, complex *u, integer *ldu, complex *vt, integer
+ *ldvt, complex *work, integer *lwork, real *rwork, integer *iwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
+ i__2, i__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, ie, il, ir, iu, blk;
+ real dum[1], eps;
+ integer iru, ivt, iscl;
+ real anrm;
+ integer idum[1], ierr, itau, irvt;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ integer chunk, minmn, wrkbl, itaup, itauq;
+ logical wntqa;
+ integer nwork;
+ extern /* Subroutine */ int clacp2_(char *, integer *, integer *, real *,
+ integer *, complex *, integer *);
+ logical wntqn, wntqo, wntqs;
+ integer mnthr1, mnthr2;
+ extern /* Subroutine */ int cgebrd_(integer *, integer *, complex *,
+ integer *, real *, real *, complex *, complex *, complex *,
+ integer *, integer *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int cgelqf_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *), clacrm_(
+ integer *, integer *, complex *, integer *, real *, integer *,
+ complex *, integer *, real *), clarcm_(integer *, integer *, real
+ *, integer *, complex *, integer *, complex *, integer *, real *),
+ clascl_(char *, integer *, integer *, real *, real *, integer *,
+ integer *, complex *, integer *, integer *), sbdsdc_(char
+ *, char *, integer *, real *, real *, real *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, integer *), cgeqrf_(integer *, integer *, complex *, integer
+ *, complex *, complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int cungbr_(char *, integer *, integer *, integer
+ *, complex *, integer *, complex *, complex *, integer *, integer
+ *);
+ real bignum;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *), cunmbr_(char *, char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *), cunglq_(
+ integer *, integer *, integer *, complex *, integer *, complex *,
+ complex *, integer *, integer *);
+ integer ldwrkl;
+ extern /* Subroutine */ int cungqr_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *);
+ integer ldwrkr, minwrk, ldwrku, maxwrk, ldwkvt;
+ real smlnum;
+ logical wntqas;
+ integer nrwork;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+/* 8-15-00: Improve consistency of WS calculations (eca) */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGESDD computes the singular value decomposition (SVD) of a complex */
+/* M-by-N matrix A, optionally computing the left and/or right singular */
+/* vectors, by using divide-and-conquer method. The SVD is written */
+
+/* A = U * SIGMA * conjugate-transpose(V) */
+
+/* where SIGMA is an M-by-N matrix which is zero except for its */
+/* min(m,n) diagonal elements, U is an M-by-M unitary matrix, and */
+/* V is an N-by-N unitary matrix. The diagonal elements of SIGMA */
+/* are the singular values of A; they are real and non-negative, and */
+/* are returned in descending order. The first min(m,n) columns of */
+/* U and V are the left and right singular vectors of A. */
+
+/* Note that the routine returns VT = V**H, not V. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* Specifies options for computing all or part of the matrix U: */
+/* = 'A': all M columns of U and all N rows of V**H are */
+/* returned in the arrays U and VT; */
+/* = 'S': the first min(M,N) columns of U and the first */
+/* min(M,N) rows of V**H are returned in the arrays U */
+/* and VT; */
+/* = 'O': If M >= N, the first N columns of U are overwritten */
+/* in the array A and all rows of V**H are returned in */
+/* the array VT; */
+/* otherwise, all columns of U are returned in the */
+/* array U and the first M rows of V**H are overwritten */
+/* in the array A; */
+/* = 'N': no columns of U or rows of V**H are computed. */
+
+/* M (input) INTEGER */
+/* The number of rows of the input matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the input matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, */
+/* if JOBZ = 'O', A is overwritten with the first N columns */
+/* of U (the left singular vectors, stored */
+/* columnwise) if M >= N; */
+/* A is overwritten with the first M rows */
+/* of V**H (the right singular vectors, stored */
+/* rowwise) otherwise. */
+/* if JOBZ .ne. 'O', the contents of A are destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* S (output) REAL array, dimension (min(M,N)) */
+/* The singular values of A, sorted so that S(i) >= S(i+1). */
+
+/* U (output) COMPLEX array, dimension (LDU,UCOL) */
+/* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N; */
+/* UCOL = min(M,N) if JOBZ = 'S'. */
+/* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M */
+/* unitary matrix U; */
+/* if JOBZ = 'S', U contains the first min(M,N) columns of U */
+/* (the left singular vectors, stored columnwise); */
+/* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= 1; if */
+/* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M. */
+
+/* VT (output) COMPLEX array, dimension (LDVT,N) */
+/* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the */
+/* N-by-N unitary matrix V**H; */
+/* if JOBZ = 'S', VT contains the first min(M,N) rows of */
+/* V**H (the right singular vectors, stored rowwise); */
+/* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. LDVT >= 1; if */
+/* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N; */
+/* if JOBZ = 'S', LDVT >= min(M,N). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= 1. */
+/* if JOBZ = 'N', LWORK >= 2*min(M,N)+max(M,N). */
+/* if JOBZ = 'O', */
+/* LWORK >= 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N). */
+/* if JOBZ = 'S' or 'A', */
+/* LWORK >= min(M,N)*min(M,N)+2*min(M,N)+max(M,N). */
+/* For good performance, LWORK should generally be larger. */
+
+/* If LWORK = -1, a workspace query is assumed. The optimal */
+/* size for the WORK array is calculated and stored in WORK(1), */
+/* and no other work except argument checking is performed. */
+
+/* RWORK (workspace) REAL array, dimension (MAX(1,LRWORK)) */
+/* If JOBZ = 'N', LRWORK >= 5*min(M,N). */
+/* Otherwise, LRWORK >= 5*min(M,N)*min(M,N) + 7*min(M,N) */
+
+/* IWORK (workspace) INTEGER array, dimension (8*min(M,N)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: The updating process of SBDSDC did not converge. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ minmn = min(*m,*n);
+ mnthr1 = (integer) (minmn * 17.f / 9.f);
+ mnthr2 = (integer) (minmn * 5.f / 3.f);
+ wntqa = lsame_(jobz, "A");
+ wntqs = lsame_(jobz, "S");
+ wntqas = wntqa || wntqs;
+ wntqo = lsame_(jobz, "O");
+ wntqn = lsame_(jobz, "N");
+ minwrk = 1;
+ maxwrk = 1;
+
+ if (! (wntqa || wntqs || wntqo || wntqn)) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldu < 1 || wntqas && *ldu < *m || wntqo && *m < *n && *ldu < *
+ m) {
+ *info = -8;
+ } else if (*ldvt < 1 || wntqa && *ldvt < *n || wntqs && *ldvt < minmn ||
+ wntqo && *m >= *n && *ldvt < *n) {
+ *info = -10;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* CWorkspace refers to complex workspace, and RWorkspace to */
+/* real workspace. NB refers to the optimal block size for the */
+/* immediately following subroutine, as returned by ILAENV.) */
+
+ if (*info == 0 && *m > 0 && *n > 0) {
+ if (*m >= *n) {
+
+/* There is no complex work space needed for bidiagonal SVD */
+/* The real work space needed for bidiagonal SVD is BDSPAC */
+/* for computing singular values and singular vectors; BDSPAN */
+/* for computing singular values only. */
+/* BDSPAC = 5*N*N + 7*N */
+/* BDSPAN = MAX(7*N+4, 3*N+2+SMLSIZ*(SMLSIZ+8)) */
+
+ if (*m >= mnthr1) {
+ if (wntqn) {
+
+/* Path 1 (M much larger than N, JOBZ='N') */
+
+ maxwrk = *n + *n * ilaenv_(&c__1, "CGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", n, n, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+ minwrk = *n * 3;
+ } else if (wntqo) {
+
+/* Path 2 (M much larger than N, JOBZ='O') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "CGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n + *n * ilaenv_(&c__1, "CUNGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNMBR", "QLN", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNMBR", "PRC", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+ maxwrk = *m * *n + *n * *n + wrkbl;
+ minwrk = (*n << 1) * *n + *n * 3;
+ } else if (wntqs) {
+
+/* Path 3 (M much larger than N, JOBZ='S') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "CGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n + *n * ilaenv_(&c__1, "CUNGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNMBR", "QLN", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNMBR", "PRC", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+ maxwrk = *n * *n + wrkbl;
+ minwrk = *n * *n + *n * 3;
+ } else if (wntqa) {
+
+/* Path 4 (M much larger than N, JOBZ='A') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "CGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n + *m * ilaenv_(&c__1, "CUNGQR",
+ " ", m, m, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNMBR", "QLN", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNMBR", "PRC", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+ maxwrk = *n * *n + wrkbl;
+ minwrk = *n * *n + (*n << 1) + *m;
+ }
+ } else if (*m >= mnthr2) {
+
+/* Path 5 (M much larger than N, but not as much as MNTHR1) */
+
+ maxwrk = (*n << 1) + (*m + *n) * ilaenv_(&c__1, "CGEBRD",
+ " ", m, n, &c_n1, &c_n1);
+ minwrk = (*n << 1) + *m;
+ if (wntqo) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNGBR", "P", n, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNGBR", "Q", m, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ maxwrk += *m * *n;
+ minwrk += *n * *n;
+ } else if (wntqs) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNGBR", "P", n, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNGBR", "Q", m, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ } else if (wntqa) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNGBR", "P", n, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *m * ilaenv_(&c__1,
+ "CUNGBR", "Q", m, m, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ }
+ } else {
+
+/* Path 6 (M at least N, but not much larger) */
+
+ maxwrk = (*n << 1) + (*m + *n) * ilaenv_(&c__1, "CGEBRD",
+ " ", m, n, &c_n1, &c_n1);
+ minwrk = (*n << 1) + *m;
+ if (wntqo) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNMBR", "PRC", n, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNMBR", "QLN", m, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ maxwrk += *m * *n;
+ minwrk += *n * *n;
+ } else if (wntqs) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNMBR", "PRC", n, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNMBR", "QLN", m, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ } else if (wntqa) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNGBR", "PRC", n, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *m * ilaenv_(&c__1,
+ "CUNGBR", "QLN", m, m, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ }
+ }
+ } else {
+
+/* There is no complex work space needed for bidiagonal SVD */
+/* The real work space needed for bidiagonal SVD is BDSPAC */
+/* for computing singular values and singular vectors; BDSPAN */
+/* for computing singular values only. */
+/* BDSPAC = 5*M*M + 7*M */
+/* BDSPAN = MAX(7*M+4, 3*M+2+SMLSIZ*(SMLSIZ+8)) */
+
+ if (*n >= mnthr1) {
+ if (wntqn) {
+
+/* Path 1t (N much larger than M, JOBZ='N') */
+
+ maxwrk = *m + *m * ilaenv_(&c__1, "CGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", m, m, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+ minwrk = *m * 3;
+ } else if (wntqo) {
+
+/* Path 2t (N much larger than M, JOBZ='O') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "CGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m + *m * ilaenv_(&c__1, "CUNGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNMBR", "PRC", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNMBR", "QLN", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+ maxwrk = *m * *n + *m * *m + wrkbl;
+ minwrk = (*m << 1) * *m + *m * 3;
+ } else if (wntqs) {
+
+/* Path 3t (N much larger than M, JOBZ='S') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "CGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m + *m * ilaenv_(&c__1, "CUNGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNMBR", "PRC", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNMBR", "QLN", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+ maxwrk = *m * *m + wrkbl;
+ minwrk = *m * *m + *m * 3;
+ } else if (wntqa) {
+
+/* Path 4t (N much larger than M, JOBZ='A') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "CGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m + *n * ilaenv_(&c__1, "CUNGLQ",
+ " ", n, n, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNMBR", "PRC", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNMBR", "QLN", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+ maxwrk = *m * *m + wrkbl;
+ minwrk = *m * *m + (*m << 1) + *n;
+ }
+ } else if (*n >= mnthr2) {
+
+/* Path 5t (N much larger than M, but not as much as MNTHR1) */
+
+ maxwrk = (*m << 1) + (*m + *n) * ilaenv_(&c__1, "CGEBRD",
+ " ", m, n, &c_n1, &c_n1);
+ minwrk = (*m << 1) + *n;
+ if (wntqo) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNGBR", "P", m, n, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNGBR", "Q", m, m, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ maxwrk += *m * *n;
+ minwrk += *m * *m;
+ } else if (wntqs) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNGBR", "P", m, n, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNGBR", "Q", m, m, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ } else if (wntqa) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *n * ilaenv_(&c__1,
+ "CUNGBR", "P", n, n, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNGBR", "Q", m, m, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ }
+ } else {
+
+/* Path 6t (N greater than M, but not much larger) */
+
+ maxwrk = (*m << 1) + (*m + *n) * ilaenv_(&c__1, "CGEBRD",
+ " ", m, n, &c_n1, &c_n1);
+ minwrk = (*m << 1) + *n;
+ if (wntqo) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNMBR", "PRC", m, n, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNMBR", "QLN", m, m, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ maxwrk += *m * *n;
+ minwrk += *m * *m;
+ } else if (wntqs) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNGBR", "PRC", m, n, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNGBR", "QLN", m, m, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ } else if (wntqa) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *n * ilaenv_(&c__1,
+ "CUNGBR", "PRC", n, n, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNGBR", "QLN", m, m, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ }
+ }
+ }
+ maxwrk = max(maxwrk,minwrk);
+ }
+ if (*info == 0) {
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+ if (*lwork < minwrk && *lwork != -1) {
+ *info = -13;
+ }
+ }
+
+/* Quick returns */
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGESDD", &i__1);
+ return 0;
+ }
+ if (*lwork == -1) {
+ return 0;
+ }
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ smlnum = sqrt(slamch_("S")) / eps;
+ bignum = 1.f / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = clange_("M", m, n, &a[a_offset], lda, dum);
+ iscl = 0;
+ if (anrm > 0.f && anrm < smlnum) {
+ iscl = 1;
+ clascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, &
+ ierr);
+ } else if (anrm > bignum) {
+ iscl = 1;
+ clascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+ if (*m >= *n) {
+
+/* A has at least as many rows as columns. If A has sufficiently */
+/* more rows than columns, first reduce using the QR */
+/* decomposition (if sufficient workspace available) */
+
+ if (*m >= mnthr1) {
+
+ if (wntqn) {
+
+/* Path 1 (M much larger than N, JOBZ='N') */
+/* No singular vectors to be computed */
+
+ itau = 1;
+ nwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: need 0) */
+
+ i__1 = *lwork - nwork + 1;
+ cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__1, &ierr);
+
+/* Zero out below R */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ claset_("L", &i__1, &i__2, &c_b1, &c_b1, &a[a_dim1 + 2], lda);
+ ie = 1;
+ itauq = 1;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize R in A */
+/* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__1 = *lwork - nwork + 1;
+ cgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__1, &ierr);
+ nrwork = ie + *n;
+
+/* Perform bidiagonal SVD, compute singular values only */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAN) */
+
+ sbdsdc_("U", "N", n, &s[1], &rwork[ie], dum, &c__1, dum, &
+ c__1, dum, idum, &rwork[nrwork], &iwork[1], info);
+
+ } else if (wntqo) {
+
+/* Path 2 (M much larger than N, JOBZ='O') */
+/* N left singular vectors to be overwritten on A and */
+/* N right singular vectors to be computed in VT */
+
+ iu = 1;
+
+/* WORK(IU) is N by N */
+
+ ldwrku = *n;
+ ir = iu + ldwrku * *n;
+ if (*lwork >= *m * *n + *n * *n + *n * 3) {
+
+/* WORK(IR) is M by N */
+
+ ldwrkr = *m;
+ } else {
+ ldwrkr = (*lwork - *n * *n - *n * 3) / *n;
+ }
+ itau = ir + ldwrkr * *n;
+ nwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (CWorkspace: need N*N+2*N, prefer M*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__1 = *lwork - nwork + 1;
+ cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__1, &ierr);
+
+/* Copy R to WORK( IR ), zeroing out below it */
+
+ clacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr);
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ claset_("L", &i__1, &i__2, &c_b1, &c_b1, &work[ir + 1], &
+ ldwrkr);
+
+/* Generate Q in A */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__1 = *lwork - nwork + 1;
+ cungqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[nwork],
+ &i__1, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IR) */
+/* (CWorkspace: need N*N+3*N, prefer M*N+2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__1 = *lwork - nwork + 1;
+ cgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__1, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of R in WORK(IRU) and computing right singular vectors */
+/* of R in WORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ iru = ie + *n;
+ irvt = iru + *n * *n;
+ nrwork = irvt + *n * *n;
+ sbdsdc_("U", "I", n, &s[1], &rwork[ie], &rwork[iru], n, &
+ rwork[irvt], n, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Copy real matrix RWORK(IRU) to complex matrix WORK(IU) */
+/* Overwrite WORK(IU) by the left singular vectors of R */
+/* (CWorkspace: need 2*N*N+3*N, prefer M*N+N*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ clacp2_("F", n, n, &rwork[iru], n, &work[iu], &ldwrku);
+ i__1 = *lwork - nwork + 1;
+ cunmbr_("Q", "L", "N", n, n, n, &work[ir], &ldwrkr, &work[
+ itauq], &work[iu], &ldwrku, &work[nwork], &i__1, &
+ ierr);
+
+/* Copy real matrix RWORK(IRVT) to complex matrix VT */
+/* Overwrite VT by the right singular vectors of R */
+/* (CWorkspace: need N*N+3*N, prefer M*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ clacp2_("F", n, n, &rwork[irvt], n, &vt[vt_offset], ldvt);
+ i__1 = *lwork - nwork + 1;
+ cunmbr_("P", "R", "C", n, n, n, &work[ir], &ldwrkr, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, &
+ ierr);
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IU), storing result in WORK(IR) and copying to A */
+/* (CWorkspace: need 2*N*N, prefer N*N+M*N) */
+/* (RWorkspace: 0) */
+
+ i__1 = *m;
+ i__2 = ldwrkr;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *m - i__ + 1;
+ chunk = min(i__3,ldwrkr);
+ cgemm_("N", "N", &chunk, n, n, &c_b2, &a[i__ + a_dim1],
+ lda, &work[iu], &ldwrku, &c_b1, &work[ir], &
+ ldwrkr);
+ clacpy_("F", &chunk, n, &work[ir], &ldwrkr, &a[i__ +
+ a_dim1], lda);
+/* L10: */
+ }
+
+ } else if (wntqs) {
+
+/* Path 3 (M much larger than N, JOBZ='S') */
+/* N left singular vectors to be computed in U and */
+/* N right singular vectors to be computed in VT */
+
+ ir = 1;
+
+/* WORK(IR) is N by N */
+
+ ldwrkr = *n;
+ itau = ir + ldwrkr * *n;
+ nwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - nwork + 1;
+ cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__2, &ierr);
+
+/* Copy R to WORK(IR), zeroing out below it */
+
+ clacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr);
+ i__2 = *n - 1;
+ i__1 = *n - 1;
+ claset_("L", &i__2, &i__1, &c_b1, &c_b1, &work[ir + 1], &
+ ldwrkr);
+
+/* Generate Q in A */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - nwork + 1;
+ cungqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[nwork],
+ &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IR) */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - nwork + 1;
+ cgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__2, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ iru = ie + *n;
+ irvt = iru + *n * *n;
+ nrwork = irvt + *n * *n;
+ sbdsdc_("U", "I", n, &s[1], &rwork[ie], &rwork[iru], n, &
+ rwork[irvt], n, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Copy real matrix RWORK(IRU) to complex matrix U */
+/* Overwrite U by left singular vectors of R */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ clacp2_("F", n, n, &rwork[iru], n, &u[u_offset], ldu);
+ i__2 = *lwork - nwork + 1;
+ cunmbr_("Q", "L", "N", n, n, n, &work[ir], &ldwrkr, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr);
+
+/* Copy real matrix RWORK(IRVT) to complex matrix VT */
+/* Overwrite VT by right singular vectors of R */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ clacp2_("F", n, n, &rwork[irvt], n, &vt[vt_offset], ldvt);
+ i__2 = *lwork - nwork + 1;
+ cunmbr_("P", "R", "C", n, n, n, &work[ir], &ldwrkr, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, &
+ ierr);
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IR), storing result in U */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: 0) */
+
+ clacpy_("F", n, n, &u[u_offset], ldu, &work[ir], &ldwrkr);
+ cgemm_("N", "N", m, n, n, &c_b2, &a[a_offset], lda, &work[ir],
+ &ldwrkr, &c_b1, &u[u_offset], ldu);
+
+ } else if (wntqa) {
+
+/* Path 4 (M much larger than N, JOBZ='A') */
+/* M left singular vectors to be computed in U and */
+/* N right singular vectors to be computed in VT */
+
+ iu = 1;
+
+/* WORK(IU) is N by N */
+
+ ldwrku = *n;
+ itau = iu + ldwrku * *n;
+ nwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - nwork + 1;
+ cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__2, &ierr);
+ clacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu);
+
+/* Generate Q in U */
+/* (CWorkspace: need N+M, prefer N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - nwork + 1;
+ cungqr_(m, m, n, &u[u_offset], ldu, &work[itau], &work[nwork],
+ &i__2, &ierr);
+
+/* Produce R in A, zeroing out below it */
+
+ i__2 = *n - 1;
+ i__1 = *n - 1;
+ claset_("L", &i__2, &i__1, &c_b1, &c_b1, &a[a_dim1 + 2], lda);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize R in A */
+/* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - nwork + 1;
+ cgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__2, &ierr);
+ iru = ie + *n;
+ irvt = iru + *n * *n;
+ nrwork = irvt + *n * *n;
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ sbdsdc_("U", "I", n, &s[1], &rwork[ie], &rwork[iru], n, &
+ rwork[irvt], n, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Copy real matrix RWORK(IRU) to complex matrix WORK(IU) */
+/* Overwrite WORK(IU) by left singular vectors of R */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ clacp2_("F", n, n, &rwork[iru], n, &work[iu], &ldwrku);
+ i__2 = *lwork - nwork + 1;
+ cunmbr_("Q", "L", "N", n, n, n, &a[a_offset], lda, &work[
+ itauq], &work[iu], &ldwrku, &work[nwork], &i__2, &
+ ierr);
+
+/* Copy real matrix RWORK(IRVT) to complex matrix VT */
+/* Overwrite VT by right singular vectors of R */
+/* (CWorkspace: need 3*N, prefer 2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ clacp2_("F", n, n, &rwork[irvt], n, &vt[vt_offset], ldvt);
+ i__2 = *lwork - nwork + 1;
+ cunmbr_("P", "R", "C", n, n, n, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, &
+ ierr);
+
+/* Multiply Q in U by left singular vectors of R in */
+/* WORK(IU), storing result in A */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: 0) */
+
+ cgemm_("N", "N", m, n, n, &c_b2, &u[u_offset], ldu, &work[iu],
+ &ldwrku, &c_b1, &a[a_offset], lda);
+
+/* Copy left singular vectors of A from A to U */
+
+ clacpy_("F", m, n, &a[a_offset], lda, &u[u_offset], ldu);
+
+ }
+
+ } else if (*m >= mnthr2) {
+
+/* MNTHR2 <= M < MNTHR1 */
+
+/* Path 5 (M much larger than N, but not as much as MNTHR1) */
+/* Reduce to bidiagonal form without QR decomposition, use */
+/* CUNGBR and matrix multiplication to compute singular vectors */
+
+ ie = 1;
+ nrwork = ie + *n;
+ itauq = 1;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize A */
+/* (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - nwork + 1;
+ cgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq],
+ &work[itaup], &work[nwork], &i__2, &ierr);
+ if (wntqn) {
+
+/* Compute singular values only */
+/* (Cworkspace: 0) */
+/* (Rworkspace: need BDSPAN) */
+
+ sbdsdc_("U", "N", n, &s[1], &rwork[ie], dum, &c__1, dum, &
+ c__1, dum, idum, &rwork[nrwork], &iwork[1], info);
+ } else if (wntqo) {
+ iu = nwork;
+ iru = nrwork;
+ irvt = iru + *n * *n;
+ nrwork = irvt + *n * *n;
+
+/* Copy A to VT, generate P**H */
+/* (Cworkspace: need 2*N, prefer N+N*NB) */
+/* (Rworkspace: 0) */
+
+ clacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+ i__2 = *lwork - nwork + 1;
+ cungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], &
+ work[nwork], &i__2, &ierr);
+
+/* Generate Q in A */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - nwork + 1;
+ cungbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], &work[
+ nwork], &i__2, &ierr);
+
+ if (*lwork >= *m * *n + *n * 3) {
+
+/* WORK( IU ) is M by N */
+
+ ldwrku = *m;
+ } else {
+
+/* WORK(IU) is LDWRKU by N */
+
+ ldwrku = (*lwork - *n * 3) / *n;
+ }
+ nwork = iu + ldwrku * *n;
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ sbdsdc_("U", "I", n, &s[1], &rwork[ie], &rwork[iru], n, &
+ rwork[irvt], n, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Multiply real matrix RWORK(IRVT) by P**H in VT, */
+/* storing the result in WORK(IU), copying to VT */
+/* (Cworkspace: need 0) */
+/* (Rworkspace: need 3*N*N) */
+
+ clarcm_(n, n, &rwork[irvt], n, &vt[vt_offset], ldvt, &work[iu]
+, &ldwrku, &rwork[nrwork]);
+ clacpy_("F", n, n, &work[iu], &ldwrku, &vt[vt_offset], ldvt);
+
+/* Multiply Q in A by real matrix RWORK(IRU), storing the */
+/* result in WORK(IU), copying to A */
+/* (CWorkspace: need N*N, prefer M*N) */
+/* (Rworkspace: need 3*N*N, prefer N*N+2*M*N) */
+
+ nrwork = irvt;
+ i__2 = *m;
+ i__1 = ldwrku;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
+ i__1) {
+/* Computing MIN */
+ i__3 = *m - i__ + 1;
+ chunk = min(i__3,ldwrku);
+ clacrm_(&chunk, n, &a[i__ + a_dim1], lda, &rwork[iru], n,
+ &work[iu], &ldwrku, &rwork[nrwork]);
+ clacpy_("F", &chunk, n, &work[iu], &ldwrku, &a[i__ +
+ a_dim1], lda);
+/* L20: */
+ }
+
+ } else if (wntqs) {
+
+/* Copy A to VT, generate P**H */
+/* (Cworkspace: need 2*N, prefer N+N*NB) */
+/* (Rworkspace: 0) */
+
+ clacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+ i__1 = *lwork - nwork + 1;
+ cungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], &
+ work[nwork], &i__1, &ierr);
+
+/* Copy A to U, generate Q */
+/* (Cworkspace: need 2*N, prefer N+N*NB) */
+/* (Rworkspace: 0) */
+
+ clacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu);
+ i__1 = *lwork - nwork + 1;
+ cungbr_("Q", m, n, n, &u[u_offset], ldu, &work[itauq], &work[
+ nwork], &i__1, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ iru = nrwork;
+ irvt = iru + *n * *n;
+ nrwork = irvt + *n * *n;
+ sbdsdc_("U", "I", n, &s[1], &rwork[ie], &rwork[iru], n, &
+ rwork[irvt], n, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Multiply real matrix RWORK(IRVT) by P**H in VT, */
+/* storing the result in A, copying to VT */
+/* (Cworkspace: need 0) */
+/* (Rworkspace: need 3*N*N) */
+
+ clarcm_(n, n, &rwork[irvt], n, &vt[vt_offset], ldvt, &a[
+ a_offset], lda, &rwork[nrwork]);
+ clacpy_("F", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+
+/* Multiply Q in U by real matrix RWORK(IRU), storing the */
+/* result in A, copying to U */
+/* (CWorkspace: need 0) */
+/* (Rworkspace: need N*N+2*M*N) */
+
+ nrwork = irvt;
+ clacrm_(m, n, &u[u_offset], ldu, &rwork[iru], n, &a[a_offset],
+ lda, &rwork[nrwork]);
+ clacpy_("F", m, n, &a[a_offset], lda, &u[u_offset], ldu);
+ } else {
+
+/* Copy A to VT, generate P**H */
+/* (Cworkspace: need 2*N, prefer N+N*NB) */
+/* (Rworkspace: 0) */
+
+ clacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+ i__1 = *lwork - nwork + 1;
+ cungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], &
+ work[nwork], &i__1, &ierr);
+
+/* Copy A to U, generate Q */
+/* (Cworkspace: need 2*N, prefer N+N*NB) */
+/* (Rworkspace: 0) */
+
+ clacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu);
+ i__1 = *lwork - nwork + 1;
+ cungbr_("Q", m, m, n, &u[u_offset], ldu, &work[itauq], &work[
+ nwork], &i__1, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ iru = nrwork;
+ irvt = iru + *n * *n;
+ nrwork = irvt + *n * *n;
+ sbdsdc_("U", "I", n, &s[1], &rwork[ie], &rwork[iru], n, &
+ rwork[irvt], n, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Multiply real matrix RWORK(IRVT) by P**H in VT, */
+/* storing the result in A, copying to VT */
+/* (Cworkspace: need 0) */
+/* (Rworkspace: need 3*N*N) */
+
+ clarcm_(n, n, &rwork[irvt], n, &vt[vt_offset], ldvt, &a[
+ a_offset], lda, &rwork[nrwork]);
+ clacpy_("F", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+
+/* Multiply Q in U by real matrix RWORK(IRU), storing the */
+/* result in A, copying to U */
+/* (CWorkspace: 0) */
+/* (Rworkspace: need 3*N*N) */
+
+ nrwork = irvt;
+ clacrm_(m, n, &u[u_offset], ldu, &rwork[iru], n, &a[a_offset],
+ lda, &rwork[nrwork]);
+ clacpy_("F", m, n, &a[a_offset], lda, &u[u_offset], ldu);
+ }
+
+ } else {
+
+/* M .LT. MNTHR2 */
+
+/* Path 6 (M at least N, but not much larger) */
+/* Reduce to bidiagonal form without QR decomposition */
+/* Use CUNMBR to compute singular vectors */
+
+ ie = 1;
+ nrwork = ie + *n;
+ itauq = 1;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize A */
+/* (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB) */
+/* (RWorkspace: need N) */
+
+ i__1 = *lwork - nwork + 1;
+ cgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq],
+ &work[itaup], &work[nwork], &i__1, &ierr);
+ if (wntqn) {
+
+/* Compute singular values only */
+/* (Cworkspace: 0) */
+/* (Rworkspace: need BDSPAN) */
+
+ sbdsdc_("U", "N", n, &s[1], &rwork[ie], dum, &c__1, dum, &
+ c__1, dum, idum, &rwork[nrwork], &iwork[1], info);
+ } else if (wntqo) {
+ iu = nwork;
+ iru = nrwork;
+ irvt = iru + *n * *n;
+ nrwork = irvt + *n * *n;
+ if (*lwork >= *m * *n + *n * 3) {
+
+/* WORK( IU ) is M by N */
+
+ ldwrku = *m;
+ } else {
+
+/* WORK( IU ) is LDWRKU by N */
+
+ ldwrku = (*lwork - *n * 3) / *n;
+ }
+ nwork = iu + ldwrku * *n;
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ sbdsdc_("U", "I", n, &s[1], &rwork[ie], &rwork[iru], n, &
+ rwork[irvt], n, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Copy real matrix RWORK(IRVT) to complex matrix VT */
+/* Overwrite VT by right singular vectors of A */
+/* (Cworkspace: need 2*N, prefer N+N*NB) */
+/* (Rworkspace: need 0) */
+
+ clacp2_("F", n, n, &rwork[irvt], n, &vt[vt_offset], ldvt);
+ i__1 = *lwork - nwork + 1;
+ cunmbr_("P", "R", "C", n, n, n, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, &
+ ierr);
+
+ if (*lwork >= *m * *n + *n * 3) {
+
+/* Copy real matrix RWORK(IRU) to complex matrix WORK(IU) */
+/* Overwrite WORK(IU) by left singular vectors of A, copying */
+/* to A */
+/* (Cworkspace: need M*N+2*N, prefer M*N+N+N*NB) */
+/* (Rworkspace: need 0) */
+
+ claset_("F", m, n, &c_b1, &c_b1, &work[iu], &ldwrku);
+ clacp2_("F", n, n, &rwork[iru], n, &work[iu], &ldwrku);
+ i__1 = *lwork - nwork + 1;
+ cunmbr_("Q", "L", "N", m, n, n, &a[a_offset], lda, &work[
+ itauq], &work[iu], &ldwrku, &work[nwork], &i__1, &
+ ierr);
+ clacpy_("F", m, n, &work[iu], &ldwrku, &a[a_offset], lda);
+ } else {
+
+/* Generate Q in A */
+/* (Cworkspace: need 2*N, prefer N+N*NB) */
+/* (Rworkspace: need 0) */
+
+ i__1 = *lwork - nwork + 1;
+ cungbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], &
+ work[nwork], &i__1, &ierr);
+
+/* Multiply Q in A by real matrix RWORK(IRU), storing the */
+/* result in WORK(IU), copying to A */
+/* (CWorkspace: need N*N, prefer M*N) */
+/* (Rworkspace: need 3*N*N, prefer N*N+2*M*N) */
+
+ nrwork = irvt;
+ i__1 = *m;
+ i__2 = ldwrku;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *m - i__ + 1;
+ chunk = min(i__3,ldwrku);
+ clacrm_(&chunk, n, &a[i__ + a_dim1], lda, &rwork[iru],
+ n, &work[iu], &ldwrku, &rwork[nrwork]);
+ clacpy_("F", &chunk, n, &work[iu], &ldwrku, &a[i__ +
+ a_dim1], lda);
+/* L30: */
+ }
+ }
+
+ } else if (wntqs) {
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ iru = nrwork;
+ irvt = iru + *n * *n;
+ nrwork = irvt + *n * *n;
+ sbdsdc_("U", "I", n, &s[1], &rwork[ie], &rwork[iru], n, &
+ rwork[irvt], n, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Copy real matrix RWORK(IRU) to complex matrix U */
+/* Overwrite U by left singular vectors of A */
+/* (CWorkspace: need 3*N, prefer 2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ claset_("F", m, n, &c_b1, &c_b1, &u[u_offset], ldu)
+ ;
+ clacp2_("F", n, n, &rwork[iru], n, &u[u_offset], ldu);
+ i__2 = *lwork - nwork + 1;
+ cunmbr_("Q", "L", "N", m, n, n, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr);
+
+/* Copy real matrix RWORK(IRVT) to complex matrix VT */
+/* Overwrite VT by right singular vectors of A */
+/* (CWorkspace: need 3*N, prefer 2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ clacp2_("F", n, n, &rwork[irvt], n, &vt[vt_offset], ldvt);
+ i__2 = *lwork - nwork + 1;
+ cunmbr_("P", "R", "C", n, n, n, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, &
+ ierr);
+ } else {
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ iru = nrwork;
+ irvt = iru + *n * *n;
+ nrwork = irvt + *n * *n;
+ sbdsdc_("U", "I", n, &s[1], &rwork[ie], &rwork[iru], n, &
+ rwork[irvt], n, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Set the right corner of U to identity matrix */
+
+ claset_("F", m, m, &c_b1, &c_b1, &u[u_offset], ldu)
+ ;
+ if (*m > *n) {
+ i__2 = *m - *n;
+ i__1 = *m - *n;
+ claset_("F", &i__2, &i__1, &c_b1, &c_b2, &u[*n + 1 + (*n
+ + 1) * u_dim1], ldu);
+ }
+
+/* Copy real matrix RWORK(IRU) to complex matrix U */
+/* Overwrite U by left singular vectors of A */
+/* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) */
+/* (RWorkspace: 0) */
+
+ clacp2_("F", n, n, &rwork[iru], n, &u[u_offset], ldu);
+ i__2 = *lwork - nwork + 1;
+ cunmbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr);
+
+/* Copy real matrix RWORK(IRVT) to complex matrix VT */
+/* Overwrite VT by right singular vectors of A */
+/* (CWorkspace: need 3*N, prefer 2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ clacp2_("F", n, n, &rwork[irvt], n, &vt[vt_offset], ldvt);
+ i__2 = *lwork - nwork + 1;
+ cunmbr_("P", "R", "C", n, n, n, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, &
+ ierr);
+ }
+
+ }
+
+ } else {
+
+/* A has more columns than rows. If A has sufficiently more */
+/* columns than rows, first reduce using the LQ decomposition (if */
+/* sufficient workspace available) */
+
+ if (*n >= mnthr1) {
+
+ if (wntqn) {
+
+/* Path 1t (N much larger than M, JOBZ='N') */
+/* No singular vectors to be computed */
+
+ itau = 1;
+ nwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - nwork + 1;
+ cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__2, &ierr);
+
+/* Zero out above L */
+
+ i__2 = *m - 1;
+ i__1 = *m - 1;
+ claset_("U", &i__2, &i__1, &c_b1, &c_b1, &a[(a_dim1 << 1) + 1]
+, lda);
+ ie = 1;
+ itauq = 1;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize L in A */
+/* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - nwork + 1;
+ cgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__2, &ierr);
+ nrwork = ie + *m;
+
+/* Perform bidiagonal SVD, compute singular values only */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAN) */
+
+ sbdsdc_("U", "N", m, &s[1], &rwork[ie], dum, &c__1, dum, &
+ c__1, dum, idum, &rwork[nrwork], &iwork[1], info);
+
+ } else if (wntqo) {
+
+/* Path 2t (N much larger than M, JOBZ='O') */
+/* M right singular vectors to be overwritten on A and */
+/* M left singular vectors to be computed in U */
+
+ ivt = 1;
+ ldwkvt = *m;
+
+/* WORK(IVT) is M by M */
+
+ il = ivt + ldwkvt * *m;
+ if (*lwork >= *m * *n + *m * *m + *m * 3) {
+
+/* WORK(IL) M by N */
+
+ ldwrkl = *m;
+ chunk = *n;
+ } else {
+
+/* WORK(IL) is M by CHUNK */
+
+ ldwrkl = *m;
+ chunk = (*lwork - *m * *m - *m * 3) / *m;
+ }
+ itau = il + ldwrkl * chunk;
+ nwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - nwork + 1;
+ cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__2, &ierr);
+
+/* Copy L to WORK(IL), zeroing about above it */
+
+ clacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwrkl);
+ i__2 = *m - 1;
+ i__1 = *m - 1;
+ claset_("U", &i__2, &i__1, &c_b1, &c_b1, &work[il + ldwrkl], &
+ ldwrkl);
+
+/* Generate Q in A */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - nwork + 1;
+ cunglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[nwork],
+ &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IL) */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - nwork + 1;
+ cgebrd_(m, m, &work[il], &ldwrkl, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__2, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ iru = ie + *m;
+ irvt = iru + *m * *m;
+ nrwork = irvt + *m * *m;
+ sbdsdc_("U", "I", m, &s[1], &rwork[ie], &rwork[iru], m, &
+ rwork[irvt], m, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Copy real matrix RWORK(IRU) to complex matrix WORK(IU) */
+/* Overwrite WORK(IU) by the left singular vectors of L */
+/* (CWorkspace: need N*N+3*N, prefer M*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ clacp2_("F", m, m, &rwork[iru], m, &u[u_offset], ldu);
+ i__2 = *lwork - nwork + 1;
+ cunmbr_("Q", "L", "N", m, m, m, &work[il], &ldwrkl, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr);
+
+/* Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT) */
+/* Overwrite WORK(IVT) by the right singular vectors of L */
+/* (CWorkspace: need N*N+3*N, prefer M*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ clacp2_("F", m, m, &rwork[irvt], m, &work[ivt], &ldwkvt);
+ i__2 = *lwork - nwork + 1;
+ cunmbr_("P", "R", "C", m, m, m, &work[il], &ldwrkl, &work[
+ itaup], &work[ivt], &ldwkvt, &work[nwork], &i__2, &
+ ierr);
+
+/* Multiply right singular vectors of L in WORK(IL) by Q */
+/* in A, storing result in WORK(IL) and copying to A */
+/* (CWorkspace: need 2*M*M, prefer M*M+M*N)) */
+/* (RWorkspace: 0) */
+
+ i__2 = *n;
+ i__1 = chunk;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
+ i__1) {
+/* Computing MIN */
+ i__3 = *n - i__ + 1;
+ blk = min(i__3,chunk);
+ cgemm_("N", "N", m, &blk, m, &c_b2, &work[ivt], m, &a[i__
+ * a_dim1 + 1], lda, &c_b1, &work[il], &ldwrkl);
+ clacpy_("F", m, &blk, &work[il], &ldwrkl, &a[i__ * a_dim1
+ + 1], lda);
+/* L40: */
+ }
+
+ } else if (wntqs) {
+
+/* Path 3t (N much larger than M, JOBZ='S') */
+/* M right singular vectors to be computed in VT and */
+/* M left singular vectors to be computed in U */
+
+ il = 1;
+
+/* WORK(IL) is M by M */
+
+ ldwrkl = *m;
+ itau = il + ldwrkl * *m;
+ nwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__1 = *lwork - nwork + 1;
+ cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__1, &ierr);
+
+/* Copy L to WORK(IL), zeroing out above it */
+
+ clacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwrkl);
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ claset_("U", &i__1, &i__2, &c_b1, &c_b1, &work[il + ldwrkl], &
+ ldwrkl);
+
+/* Generate Q in A */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__1 = *lwork - nwork + 1;
+ cunglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[nwork],
+ &i__1, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IL) */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__1 = *lwork - nwork + 1;
+ cgebrd_(m, m, &work[il], &ldwrkl, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__1, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ iru = ie + *m;
+ irvt = iru + *m * *m;
+ nrwork = irvt + *m * *m;
+ sbdsdc_("U", "I", m, &s[1], &rwork[ie], &rwork[iru], m, &
+ rwork[irvt], m, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Copy real matrix RWORK(IRU) to complex matrix U */
+/* Overwrite U by left singular vectors of L */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ clacp2_("F", m, m, &rwork[iru], m, &u[u_offset], ldu);
+ i__1 = *lwork - nwork + 1;
+ cunmbr_("Q", "L", "N", m, m, m, &work[il], &ldwrkl, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr);
+
+/* Copy real matrix RWORK(IRVT) to complex matrix VT */
+/* Overwrite VT by left singular vectors of L */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ clacp2_("F", m, m, &rwork[irvt], m, &vt[vt_offset], ldvt);
+ i__1 = *lwork - nwork + 1;
+ cunmbr_("P", "R", "C", m, m, m, &work[il], &ldwrkl, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, &
+ ierr);
+
+/* Copy VT to WORK(IL), multiply right singular vectors of L */
+/* in WORK(IL) by Q in A, storing result in VT */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: 0) */
+
+ clacpy_("F", m, m, &vt[vt_offset], ldvt, &work[il], &ldwrkl);
+ cgemm_("N", "N", m, n, m, &c_b2, &work[il], &ldwrkl, &a[
+ a_offset], lda, &c_b1, &vt[vt_offset], ldvt);
+
+ } else if (wntqa) {
+
+/* Path 9t (N much larger than M, JOBZ='A') */
+/* N right singular vectors to be computed in VT and */
+/* M left singular vectors to be computed in U */
+
+ ivt = 1;
+
+/* WORK(IVT) is M by M */
+
+ ldwkvt = *m;
+ itau = ivt + ldwkvt * *m;
+ nwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__1 = *lwork - nwork + 1;
+ cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__1, &ierr);
+ clacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+
+/* Generate Q in VT */
+/* (CWorkspace: need M+N, prefer M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__1 = *lwork - nwork + 1;
+ cunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &work[
+ nwork], &i__1, &ierr);
+
+/* Produce L in A, zeroing out above it */
+
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ claset_("U", &i__1, &i__2, &c_b1, &c_b1, &a[(a_dim1 << 1) + 1]
+, lda);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize L in A */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__1 = *lwork - nwork + 1;
+ cgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__1, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ iru = ie + *m;
+ irvt = iru + *m * *m;
+ nrwork = irvt + *m * *m;
+ sbdsdc_("U", "I", m, &s[1], &rwork[ie], &rwork[iru], m, &
+ rwork[irvt], m, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Copy real matrix RWORK(IRU) to complex matrix U */
+/* Overwrite U by left singular vectors of L */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ clacp2_("F", m, m, &rwork[iru], m, &u[u_offset], ldu);
+ i__1 = *lwork - nwork + 1;
+ cunmbr_("Q", "L", "N", m, m, m, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr);
+
+/* Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT) */
+/* Overwrite WORK(IVT) by right singular vectors of L */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ clacp2_("F", m, m, &rwork[irvt], m, &work[ivt], &ldwkvt);
+ i__1 = *lwork - nwork + 1;
+ cunmbr_("P", "R", "C", m, m, m, &a[a_offset], lda, &work[
+ itaup], &work[ivt], &ldwkvt, &work[nwork], &i__1, &
+ ierr);
+
+/* Multiply right singular vectors of L in WORK(IVT) by */
+/* Q in VT, storing result in A */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: 0) */
+
+ cgemm_("N", "N", m, n, m, &c_b2, &work[ivt], &ldwkvt, &vt[
+ vt_offset], ldvt, &c_b1, &a[a_offset], lda);
+
+/* Copy right singular vectors of A from A to VT */
+
+ clacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+
+ }
+
+ } else if (*n >= mnthr2) {
+
+/* MNTHR2 <= N < MNTHR1 */
+
+/* Path 5t (N much larger than M, but not as much as MNTHR1) */
+/* Reduce to bidiagonal form without QR decomposition, use */
+/* CUNGBR and matrix multiplication to compute singular vectors */
+
+
+ ie = 1;
+ nrwork = ie + *m;
+ itauq = 1;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize A */
+/* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) */
+/* (RWorkspace: M) */
+
+ i__1 = *lwork - nwork + 1;
+ cgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq],
+ &work[itaup], &work[nwork], &i__1, &ierr);
+
+ if (wntqn) {
+
+/* Compute singular values only */
+/* (Cworkspace: 0) */
+/* (Rworkspace: need BDSPAN) */
+
+ sbdsdc_("L", "N", m, &s[1], &rwork[ie], dum, &c__1, dum, &
+ c__1, dum, idum, &rwork[nrwork], &iwork[1], info);
+ } else if (wntqo) {
+ irvt = nrwork;
+ iru = irvt + *m * *m;
+ nrwork = iru + *m * *m;
+ ivt = nwork;
+
+/* Copy A to U, generate Q */
+/* (Cworkspace: need 2*M, prefer M+M*NB) */
+/* (Rworkspace: 0) */
+
+ clacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+ i__1 = *lwork - nwork + 1;
+ cungbr_("Q", m, m, n, &u[u_offset], ldu, &work[itauq], &work[
+ nwork], &i__1, &ierr);
+
+/* Generate P**H in A */
+/* (Cworkspace: need 2*M, prefer M+M*NB) */
+/* (Rworkspace: 0) */
+
+ i__1 = *lwork - nwork + 1;
+ cungbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[
+ nwork], &i__1, &ierr);
+
+ ldwkvt = *m;
+ if (*lwork >= *m * *n + *m * 3) {
+
+/* WORK( IVT ) is M by N */
+
+ nwork = ivt + ldwkvt * *n;
+ chunk = *n;
+ } else {
+
+/* WORK( IVT ) is M by CHUNK */
+
+ chunk = (*lwork - *m * 3) / *m;
+ nwork = ivt + ldwkvt * chunk;
+ }
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ sbdsdc_("L", "I", m, &s[1], &rwork[ie], &rwork[iru], m, &
+ rwork[irvt], m, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Multiply Q in U by real matrix RWORK(IRVT) */
+/* storing the result in WORK(IVT), copying to U */
+/* (Cworkspace: need 0) */
+/* (Rworkspace: need 2*M*M) */
+
+ clacrm_(m, m, &u[u_offset], ldu, &rwork[iru], m, &work[ivt], &
+ ldwkvt, &rwork[nrwork]);
+ clacpy_("F", m, m, &work[ivt], &ldwkvt, &u[u_offset], ldu);
+
+/* Multiply RWORK(IRVT) by P**H in A, storing the */
+/* result in WORK(IVT), copying to A */
+/* (CWorkspace: need M*M, prefer M*N) */
+/* (Rworkspace: need 2*M*M, prefer 2*M*N) */
+
+ nrwork = iru;
+ i__1 = *n;
+ i__2 = chunk;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *n - i__ + 1;
+ blk = min(i__3,chunk);
+ clarcm_(m, &blk, &rwork[irvt], m, &a[i__ * a_dim1 + 1],
+ lda, &work[ivt], &ldwkvt, &rwork[nrwork]);
+ clacpy_("F", m, &blk, &work[ivt], &ldwkvt, &a[i__ *
+ a_dim1 + 1], lda);
+/* L50: */
+ }
+ } else if (wntqs) {
+
+/* Copy A to U, generate Q */
+/* (Cworkspace: need 2*M, prefer M+M*NB) */
+/* (Rworkspace: 0) */
+
+ clacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+ i__2 = *lwork - nwork + 1;
+ cungbr_("Q", m, m, n, &u[u_offset], ldu, &work[itauq], &work[
+ nwork], &i__2, &ierr);
+
+/* Copy A to VT, generate P**H */
+/* (Cworkspace: need 2*M, prefer M+M*NB) */
+/* (Rworkspace: 0) */
+
+ clacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+ i__2 = *lwork - nwork + 1;
+ cungbr_("P", m, n, m, &vt[vt_offset], ldvt, &work[itaup], &
+ work[nwork], &i__2, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ irvt = nrwork;
+ iru = irvt + *m * *m;
+ nrwork = iru + *m * *m;
+ sbdsdc_("L", "I", m, &s[1], &rwork[ie], &rwork[iru], m, &
+ rwork[irvt], m, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Multiply Q in U by real matrix RWORK(IRU), storing the */
+/* result in A, copying to U */
+/* (CWorkspace: need 0) */
+/* (Rworkspace: need 3*M*M) */
+
+ clacrm_(m, m, &u[u_offset], ldu, &rwork[iru], m, &a[a_offset],
+ lda, &rwork[nrwork]);
+ clacpy_("F", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+
+/* Multiply real matrix RWORK(IRVT) by P**H in VT, */
+/* storing the result in A, copying to VT */
+/* (Cworkspace: need 0) */
+/* (Rworkspace: need M*M+2*M*N) */
+
+ nrwork = iru;
+ clarcm_(m, n, &rwork[irvt], m, &vt[vt_offset], ldvt, &a[
+ a_offset], lda, &rwork[nrwork]);
+ clacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+ } else {
+
+/* Copy A to U, generate Q */
+/* (Cworkspace: need 2*M, prefer M+M*NB) */
+/* (Rworkspace: 0) */
+
+ clacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+ i__2 = *lwork - nwork + 1;
+ cungbr_("Q", m, m, n, &u[u_offset], ldu, &work[itauq], &work[
+ nwork], &i__2, &ierr);
+
+/* Copy A to VT, generate P**H */
+/* (Cworkspace: need 2*M, prefer M+M*NB) */
+/* (Rworkspace: 0) */
+
+ clacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+ i__2 = *lwork - nwork + 1;
+ cungbr_("P", n, n, m, &vt[vt_offset], ldvt, &work[itaup], &
+ work[nwork], &i__2, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ irvt = nrwork;
+ iru = irvt + *m * *m;
+ nrwork = iru + *m * *m;
+ sbdsdc_("L", "I", m, &s[1], &rwork[ie], &rwork[iru], m, &
+ rwork[irvt], m, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Multiply Q in U by real matrix RWORK(IRU), storing the */
+/* result in A, copying to U */
+/* (CWorkspace: need 0) */
+/* (Rworkspace: need 3*M*M) */
+
+ clacrm_(m, m, &u[u_offset], ldu, &rwork[iru], m, &a[a_offset],
+ lda, &rwork[nrwork]);
+ clacpy_("F", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+
+/* Multiply real matrix RWORK(IRVT) by P**H in VT, */
+/* storing the result in A, copying to VT */
+/* (Cworkspace: need 0) */
+/* (Rworkspace: need M*M+2*M*N) */
+
+ clarcm_(m, n, &rwork[irvt], m, &vt[vt_offset], ldvt, &a[
+ a_offset], lda, &rwork[nrwork]);
+ clacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+ }
+
+ } else {
+
+/* N .LT. MNTHR2 */
+
+/* Path 6t (N greater than M, but not much larger) */
+/* Reduce to bidiagonal form without LQ decomposition */
+/* Use CUNMBR to compute singular vectors */
+
+ ie = 1;
+ nrwork = ie + *m;
+ itauq = 1;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize A */
+/* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) */
+/* (RWorkspace: M) */
+
+ i__2 = *lwork - nwork + 1;
+ cgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq],
+ &work[itaup], &work[nwork], &i__2, &ierr);
+ if (wntqn) {
+
+/* Compute singular values only */
+/* (Cworkspace: 0) */
+/* (Rworkspace: need BDSPAN) */
+
+ sbdsdc_("L", "N", m, &s[1], &rwork[ie], dum, &c__1, dum, &
+ c__1, dum, idum, &rwork[nrwork], &iwork[1], info);
+ } else if (wntqo) {
+ ldwkvt = *m;
+ ivt = nwork;
+ if (*lwork >= *m * *n + *m * 3) {
+
+/* WORK( IVT ) is M by N */
+
+ claset_("F", m, n, &c_b1, &c_b1, &work[ivt], &ldwkvt);
+ nwork = ivt + ldwkvt * *n;
+ } else {
+
+/* WORK( IVT ) is M by CHUNK */
+
+ chunk = (*lwork - *m * 3) / *m;
+ nwork = ivt + ldwkvt * chunk;
+ }
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ irvt = nrwork;
+ iru = irvt + *m * *m;
+ nrwork = iru + *m * *m;
+ sbdsdc_("L", "I", m, &s[1], &rwork[ie], &rwork[iru], m, &
+ rwork[irvt], m, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Copy real matrix RWORK(IRU) to complex matrix U */
+/* Overwrite U by left singular vectors of A */
+/* (Cworkspace: need 2*M, prefer M+M*NB) */
+/* (Rworkspace: need 0) */
+
+ clacp2_("F", m, m, &rwork[iru], m, &u[u_offset], ldu);
+ i__2 = *lwork - nwork + 1;
+ cunmbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr);
+
+ if (*lwork >= *m * *n + *m * 3) {
+
+/* Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT) */
+/* Overwrite WORK(IVT) by right singular vectors of A, */
+/* copying to A */
+/* (Cworkspace: need M*N+2*M, prefer M*N+M+M*NB) */
+/* (Rworkspace: need 0) */
+
+ clacp2_("F", m, m, &rwork[irvt], m, &work[ivt], &ldwkvt);
+ i__2 = *lwork - nwork + 1;
+ cunmbr_("P", "R", "C", m, n, m, &a[a_offset], lda, &work[
+ itaup], &work[ivt], &ldwkvt, &work[nwork], &i__2,
+ &ierr);
+ clacpy_("F", m, n, &work[ivt], &ldwkvt, &a[a_offset], lda);
+ } else {
+
+/* Generate P**H in A */
+/* (Cworkspace: need 2*M, prefer M+M*NB) */
+/* (Rworkspace: need 0) */
+
+ i__2 = *lwork - nwork + 1;
+ cungbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &
+ work[nwork], &i__2, &ierr);
+
+/* Multiply Q in A by real matrix RWORK(IRU), storing the */
+/* result in WORK(IU), copying to A */
+/* (CWorkspace: need M*M, prefer M*N) */
+/* (Rworkspace: need 3*M*M, prefer M*M+2*M*N) */
+
+ nrwork = iru;
+ i__2 = *n;
+ i__1 = chunk;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
+ i__1) {
+/* Computing MIN */
+ i__3 = *n - i__ + 1;
+ blk = min(i__3,chunk);
+ clarcm_(m, &blk, &rwork[irvt], m, &a[i__ * a_dim1 + 1]
+, lda, &work[ivt], &ldwkvt, &rwork[nrwork]);
+ clacpy_("F", m, &blk, &work[ivt], &ldwkvt, &a[i__ *
+ a_dim1 + 1], lda);
+/* L60: */
+ }
+ }
+ } else if (wntqs) {
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ irvt = nrwork;
+ iru = irvt + *m * *m;
+ nrwork = iru + *m * *m;
+ sbdsdc_("L", "I", m, &s[1], &rwork[ie], &rwork[iru], m, &
+ rwork[irvt], m, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Copy real matrix RWORK(IRU) to complex matrix U */
+/* Overwrite U by left singular vectors of A */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: M*M) */
+
+ clacp2_("F", m, m, &rwork[iru], m, &u[u_offset], ldu);
+ i__1 = *lwork - nwork + 1;
+ cunmbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr);
+
+/* Copy real matrix RWORK(IRVT) to complex matrix VT */
+/* Overwrite VT by right singular vectors of A */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: M*M) */
+
+ claset_("F", m, n, &c_b1, &c_b1, &vt[vt_offset], ldvt);
+ clacp2_("F", m, m, &rwork[irvt], m, &vt[vt_offset], ldvt);
+ i__1 = *lwork - nwork + 1;
+ cunmbr_("P", "R", "C", m, n, m, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, &
+ ierr);
+ } else {
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ irvt = nrwork;
+ iru = irvt + *m * *m;
+ nrwork = iru + *m * *m;
+
+ sbdsdc_("L", "I", m, &s[1], &rwork[ie], &rwork[iru], m, &
+ rwork[irvt], m, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Copy real matrix RWORK(IRU) to complex matrix U */
+/* Overwrite U by left singular vectors of A */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: M*M) */
+
+ clacp2_("F", m, m, &rwork[iru], m, &u[u_offset], ldu);
+ i__1 = *lwork - nwork + 1;
+ cunmbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr);
+
+/* Set all of VT to identity matrix */
+
+ claset_("F", n, n, &c_b1, &c_b2, &vt[vt_offset], ldvt);
+
+/* Copy real matrix RWORK(IRVT) to complex matrix VT */
+/* Overwrite VT by right singular vectors of A */
+/* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) */
+/* (RWorkspace: M*M) */
+
+ clacp2_("F", m, m, &rwork[irvt], m, &vt[vt_offset], ldvt);
+ i__1 = *lwork - nwork + 1;
+ cunmbr_("P", "R", "C", n, n, m, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, &
+ ierr);
+ }
+
+ }
+
+ }
+
+/* Undo scaling if necessary */
+
+ if (iscl == 1) {
+ if (anrm > bignum) {
+ slascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, &ierr);
+ }
+ if (*info != 0 && anrm > bignum) {
+ i__1 = minmn - 1;
+ slascl_("G", &c__0, &c__0, &bignum, &anrm, &i__1, &c__1, &rwork[
+ ie], &minmn, &ierr);
+ }
+ if (anrm < smlnum) {
+ slascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, &ierr);
+ }
+ if (*info != 0 && anrm < smlnum) {
+ i__1 = minmn - 1;
+ slascl_("G", &c__0, &c__0, &smlnum, &anrm, &i__1, &c__1, &rwork[
+ ie], &minmn, &ierr);
+ }
+ }
+
+/* Return optimal workspace in WORK(1) */
+
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CGESDD */
+
+} /* cgesdd_ */
diff --git a/SRC/cgesv.c b/SRC/cgesv.c
new file mode 100644
index 0000000..1d3ea37
--- /dev/null
+++ b/SRC/cgesv.c
@@ -0,0 +1,138 @@
+/* cgesv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cgesv_(integer *n, integer *nrhs, complex *a, integer *
+ lda, integer *ipiv, complex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int cgetrf_(integer *, integer *, complex *,
+ integer *, integer *, integer *), xerbla_(char *, integer *), cgetrs_(char *, integer *, integer *, complex *, integer
+ *, integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGESV computes the solution to a complex system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */
+
+/* The LU decomposition with partial pivoting and row interchanges is */
+/* used to factor A as */
+/* A = P * L * U, */
+/* where P is a permutation matrix, L is unit lower triangular, and U is */
+/* upper triangular. The factored form of A is then used to solve the */
+/* system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N coefficient matrix A. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* The pivot indices that define the permutation matrix P; */
+/* row i of the matrix was interchanged with row IPIV(i). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS matrix of right hand side matrix B. */
+/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, so the solution could not be computed. */
+
+/* ===================================================================== */
+
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGESV ", &i__1);
+ return 0;
+ }
+
+/* Compute the LU factorization of A. */
+
+ cgetrf_(n, n, &a[a_offset], lda, &ipiv[1], info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ cgetrs_("No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &b[
+ b_offset], ldb, info);
+ }
+ return 0;
+
+/* End of CGESV */
+
+} /* cgesv_ */
diff --git a/SRC/cgesvd.c b/SRC/cgesvd.c
new file mode 100644
index 0000000..f6b5b7c
--- /dev/null
+++ b/SRC/cgesvd.c
@@ -0,0 +1,4164 @@
+/* cgesvd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__6 = 6;
+static integer c__0 = 0;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cgesvd_(char *jobu, char *jobvt, integer *m, integer *n,
+ complex *a, integer *lda, real *s, complex *u, integer *ldu, complex *
+ vt, integer *ldvt, complex *work, integer *lwork, real *rwork,
+ integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1[2],
+ i__2, i__3, i__4;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, ie, ir, iu, blk, ncu;
+ real dum[1], eps;
+ integer nru;
+ complex cdum[1];
+ integer iscl;
+ real anrm;
+ integer ierr, itau, ncvt, nrvt;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ integer chunk, minmn, wrkbl, itaup, itauq, mnthr, iwork;
+ logical wntua, wntva, wntun, wntuo, wntvn, wntvo, wntus, wntvs;
+ extern /* Subroutine */ int cgebrd_(integer *, integer *, complex *,
+ integer *, real *, real *, complex *, complex *, complex *,
+ integer *, integer *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int cgelqf_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *), clascl_(
+ char *, integer *, integer *, real *, real *, integer *, integer *
+, complex *, integer *, integer *), cgeqrf_(integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), cbdsqr_(char *, integer *, integer *, integer *, integer
+ *, real *, real *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, integer *), xerbla_(char *,
+ integer *), cungbr_(char *, integer *, integer *, integer
+ *, complex *, integer *, complex *, complex *, integer *, integer
+ *);
+ real bignum;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int cunmbr_(char *, char *, char *, integer *,
+ integer *, integer *, complex *, integer *, complex *, complex *,
+ integer *, complex *, integer *, integer *), cunglq_(integer *, integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *), cungqr_(
+ integer *, integer *, integer *, complex *, integer *, complex *,
+ complex *, integer *, integer *);
+ integer ldwrkr, minwrk, ldwrku, maxwrk;
+ real smlnum;
+ integer irwork;
+ logical lquery, wntuas, wntvas;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGESVD computes the singular value decomposition (SVD) of a complex */
+/* M-by-N matrix A, optionally computing the left and/or right singular */
+/* vectors. The SVD is written */
+
+/* A = U * SIGMA * conjugate-transpose(V) */
+
+/* where SIGMA is an M-by-N matrix which is zero except for its */
+/* min(m,n) diagonal elements, U is an M-by-M unitary matrix, and */
+/* V is an N-by-N unitary matrix. The diagonal elements of SIGMA */
+/* are the singular values of A; they are real and non-negative, and */
+/* are returned in descending order. The first min(m,n) columns of */
+/* U and V are the left and right singular vectors of A. */
+
+/* Note that the routine returns V**H, not V. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBU (input) CHARACTER*1 */
+/* Specifies options for computing all or part of the matrix U: */
+/* = 'A': all M columns of U are returned in array U: */
+/* = 'S': the first min(m,n) columns of U (the left singular */
+/* vectors) are returned in the array U; */
+/* = 'O': the first min(m,n) columns of U (the left singular */
+/* vectors) are overwritten on the array A; */
+/* = 'N': no columns of U (no left singular vectors) are */
+/* computed. */
+
+/* JOBVT (input) CHARACTER*1 */
+/* Specifies options for computing all or part of the matrix */
+/* V**H: */
+/* = 'A': all N rows of V**H are returned in the array VT; */
+/* = 'S': the first min(m,n) rows of V**H (the right singular */
+/* vectors) are returned in the array VT; */
+/* = 'O': the first min(m,n) rows of V**H (the right singular */
+/* vectors) are overwritten on the array A; */
+/* = 'N': no rows of V**H (no right singular vectors) are */
+/* computed. */
+
+/* JOBVT and JOBU cannot both be 'O'. */
+
+/* M (input) INTEGER */
+/* The number of rows of the input matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the input matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, */
+/* if JOBU = 'O', A is overwritten with the first min(m,n) */
+/* columns of U (the left singular vectors, */
+/* stored columnwise); */
+/* if JOBVT = 'O', A is overwritten with the first min(m,n) */
+/* rows of V**H (the right singular vectors, */
+/* stored rowwise); */
+/* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A */
+/* are destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* S (output) REAL array, dimension (min(M,N)) */
+/* The singular values of A, sorted so that S(i) >= S(i+1). */
+
+/* U (output) COMPLEX array, dimension (LDU,UCOL) */
+/* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'. */
+/* If JOBU = 'A', U contains the M-by-M unitary matrix U; */
+/* if JOBU = 'S', U contains the first min(m,n) columns of U */
+/* (the left singular vectors, stored columnwise); */
+/* if JOBU = 'N' or 'O', U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= 1; if */
+/* JOBU = 'S' or 'A', LDU >= M. */
+
+/* VT (output) COMPLEX array, dimension (LDVT,N) */
+/* If JOBVT = 'A', VT contains the N-by-N unitary matrix */
+/* V**H; */
+/* if JOBVT = 'S', VT contains the first min(m,n) rows of */
+/* V**H (the right singular vectors, stored rowwise); */
+/* if JOBVT = 'N' or 'O', VT is not referenced. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. LDVT >= 1; if */
+/* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* LWORK >= MAX(1,2*MIN(M,N)+MAX(M,N)). */
+/* For good performance, LWORK should generally be larger. */
+
+/* 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. */
+
+/* RWORK (workspace) REAL array, dimension (5*min(M,N)) */
+/* On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the */
+/* unconverged superdiagonal elements of an upper bidiagonal */
+/* matrix B whose diagonal is in S (not necessarily sorted). */
+/* B satisfies A = U * B * VT, so it has the same singular */
+/* values as A, and singular vectors related by U and VT. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if CBDSQR did not converge, INFO specifies how many */
+/* superdiagonals of an intermediate bidiagonal form B */
+/* did not converge to zero. See the description of RWORK */
+/* above for details. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ minmn = min(*m,*n);
+ wntua = lsame_(jobu, "A");
+ wntus = lsame_(jobu, "S");
+ wntuas = wntua || wntus;
+ wntuo = lsame_(jobu, "O");
+ wntun = lsame_(jobu, "N");
+ wntva = lsame_(jobvt, "A");
+ wntvs = lsame_(jobvt, "S");
+ wntvas = wntva || wntvs;
+ wntvo = lsame_(jobvt, "O");
+ wntvn = lsame_(jobvt, "N");
+ lquery = *lwork == -1;
+
+ if (! (wntua || wntus || wntuo || wntun)) {
+ *info = -1;
+ } else if (! (wntva || wntvs || wntvo || wntvn) || wntvo && wntuo) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -6;
+ } else if (*ldu < 1 || wntuas && *ldu < *m) {
+ *info = -9;
+ } else if (*ldvt < 1 || wntva && *ldvt < *n || wntvs && *ldvt < minmn) {
+ *info = -11;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* CWorkspace refers to complex workspace, and RWorkspace to */
+/* real workspace. NB refers to the optimal block size for the */
+/* immediately following subroutine, as returned by ILAENV.) */
+
+ if (*info == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ if (*m >= *n && minmn > 0) {
+
+/* Space needed for CBDSQR is BDSPAC = 5*N */
+
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = jobu;
+ i__1[1] = 1, a__1[1] = jobvt;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ mnthr = ilaenv_(&c__6, "CGESVD", ch__1, m, n, &c__0, &c__0);
+ if (*m >= mnthr) {
+ if (wntun) {
+
+/* Path 1 (M much larger than N, JOBU='N') */
+
+ maxwrk = *n + *n * ilaenv_(&c__1, "CGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", n, n, &c_n1, &c_n1);
+ maxwrk = max(i__2,i__3);
+ if (wntvo || wntvas) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&
+ c__1, "CUNGBR", "P", n, n, n, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ minwrk = *n * 3;
+ } else if (wntuo && wntvn) {
+
+/* Path 2 (M much larger than N, JOBU='O', JOBVT='N') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "CGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "CUNGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNGBR", "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n;
+ maxwrk = max(i__2,i__3);
+ minwrk = (*n << 1) + *m;
+ } else if (wntuo && wntvas) {
+
+/* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or */
+/* 'A') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "CGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "CUNGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNGBR", "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
+ "CUNGBR", "P", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n;
+ maxwrk = max(i__2,i__3);
+ minwrk = (*n << 1) + *m;
+ } else if (wntus && wntvn) {
+
+/* Path 4 (M much larger than N, JOBU='S', JOBVT='N') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "CGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "CUNGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNGBR", "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = *n * *n + wrkbl;
+ minwrk = (*n << 1) + *m;
+ } else if (wntus && wntvo) {
+
+/* Path 5 (M much larger than N, JOBU='S', JOBVT='O') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "CGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "CUNGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNGBR", "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
+ "CUNGBR", "P", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = (*n << 1) * *n + wrkbl;
+ minwrk = (*n << 1) + *m;
+ } else if (wntus && wntvas) {
+
+/* Path 6 (M much larger than N, JOBU='S', JOBVT='S' or */
+/* 'A') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "CGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "CUNGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNGBR", "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
+ "CUNGBR", "P", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = *n * *n + wrkbl;
+ minwrk = (*n << 1) + *m;
+ } else if (wntua && wntvn) {
+
+/* Path 7 (M much larger than N, JOBU='A', JOBVT='N') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "CGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "CUNGQR",
+ " ", m, m, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNGBR", "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = *n * *n + wrkbl;
+ minwrk = (*n << 1) + *m;
+ } else if (wntua && wntvo) {
+
+/* Path 8 (M much larger than N, JOBU='A', JOBVT='O') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "CGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "CUNGQR",
+ " ", m, m, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNGBR", "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
+ "CUNGBR", "P", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = (*n << 1) * *n + wrkbl;
+ minwrk = (*n << 1) + *m;
+ } else if (wntua && wntvas) {
+
+/* Path 9 (M much larger than N, JOBU='A', JOBVT='S' or */
+/* 'A') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "CGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "CUNGQR",
+ " ", m, m, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNGBR", "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
+ "CUNGBR", "P", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = *n * *n + wrkbl;
+ minwrk = (*n << 1) + *m;
+ }
+ } else {
+
+/* Path 10 (M at least N, but not much larger) */
+
+ maxwrk = (*n << 1) + (*m + *n) * ilaenv_(&c__1, "CGEBRD",
+ " ", m, n, &c_n1, &c_n1);
+ if (wntus || wntuo) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
+ "CUNGBR", "Q", m, n, n, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ if (wntua) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = (*n << 1) + *m * ilaenv_(&c__1,
+ "CUNGBR", "Q", m, m, n, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ if (! wntvn) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&
+ c__1, "CUNGBR", "P", n, n, n, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ minwrk = (*n << 1) + *m;
+ }
+ } else if (minmn > 0) {
+
+/* Space needed for CBDSQR is BDSPAC = 5*M */
+
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = jobu;
+ i__1[1] = 1, a__1[1] = jobvt;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ mnthr = ilaenv_(&c__6, "CGESVD", ch__1, m, n, &c__0, &c__0);
+ if (*n >= mnthr) {
+ if (wntvn) {
+
+/* Path 1t(N much larger than M, JOBVT='N') */
+
+ maxwrk = *m + *m * ilaenv_(&c__1, "CGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", m, m, &c_n1, &c_n1);
+ maxwrk = max(i__2,i__3);
+ if (wntuo || wntuas) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNGBR", "Q", m, m, m, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ minwrk = *m * 3;
+ } else if (wntvo && wntun) {
+
+/* Path 2t(N much larger than M, JOBU='N', JOBVT='O') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "CGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "CUNGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
+ "CUNGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n;
+ maxwrk = max(i__2,i__3);
+ minwrk = (*m << 1) + *n;
+ } else if (wntvo && wntuas) {
+
+/* Path 3t(N much larger than M, JOBU='S' or 'A', */
+/* JOBVT='O') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "CGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "CUNGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
+ "CUNGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNGBR", "Q", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n;
+ maxwrk = max(i__2,i__3);
+ minwrk = (*m << 1) + *n;
+ } else if (wntvs && wntun) {
+
+/* Path 4t(N much larger than M, JOBU='N', JOBVT='S') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "CGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "CUNGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
+ "CUNGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = *m * *m + wrkbl;
+ minwrk = (*m << 1) + *n;
+ } else if (wntvs && wntuo) {
+
+/* Path 5t(N much larger than M, JOBU='O', JOBVT='S') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "CGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "CUNGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
+ "CUNGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNGBR", "Q", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = (*m << 1) * *m + wrkbl;
+ minwrk = (*m << 1) + *n;
+ } else if (wntvs && wntuas) {
+
+/* Path 6t(N much larger than M, JOBU='S' or 'A', */
+/* JOBVT='S') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "CGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "CUNGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
+ "CUNGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNGBR", "Q", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = *m * *m + wrkbl;
+ minwrk = (*m << 1) + *n;
+ } else if (wntva && wntun) {
+
+/* Path 7t(N much larger than M, JOBU='N', JOBVT='A') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "CGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "CUNGLQ",
+ " ", n, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
+ "CUNGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = *m * *m + wrkbl;
+ minwrk = (*m << 1) + *n;
+ } else if (wntva && wntuo) {
+
+/* Path 8t(N much larger than M, JOBU='O', JOBVT='A') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "CGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "CUNGLQ",
+ " ", n, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
+ "CUNGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNGBR", "Q", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = (*m << 1) * *m + wrkbl;
+ minwrk = (*m << 1) + *n;
+ } else if (wntva && wntuas) {
+
+/* Path 9t(N much larger than M, JOBU='S' or 'A', */
+/* JOBVT='A') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "CGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "CUNGLQ",
+ " ", n, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "CGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
+ "CUNGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNGBR", "Q", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = *m * *m + wrkbl;
+ minwrk = (*m << 1) + *n;
+ }
+ } else {
+
+/* Path 10t(N greater than M, but not much larger) */
+
+ maxwrk = (*m << 1) + (*m + *n) * ilaenv_(&c__1, "CGEBRD",
+ " ", m, n, &c_n1, &c_n1);
+ if (wntvs || wntvo) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = (*m << 1) + *m * ilaenv_(&c__1,
+ "CUNGBR", "P", m, n, m, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ if (wntva) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = (*m << 1) + *n * ilaenv_(&c__1,
+ "CUNGBR", "P", n, n, m, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ if (! wntun) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&
+ c__1, "CUNGBR", "Q", m, m, m, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ minwrk = (*m << 1) + *n;
+ }
+ }
+ maxwrk = max(minwrk,maxwrk);
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info != 0) {
+ i__2 = -(*info);
+ xerbla_("CGESVD", &i__2);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ smlnum = sqrt(slamch_("S")) / eps;
+ bignum = 1.f / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = clange_("M", m, n, &a[a_offset], lda, dum);
+ iscl = 0;
+ if (anrm > 0.f && anrm < smlnum) {
+ iscl = 1;
+ clascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, &
+ ierr);
+ } else if (anrm > bignum) {
+ iscl = 1;
+ clascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+ if (*m >= *n) {
+
+/* A has at least as many rows as columns. If A has sufficiently */
+/* more rows than columns, first reduce using the QR */
+/* decomposition (if sufficient workspace available) */
+
+ if (*m >= mnthr) {
+
+ if (wntun) {
+
+/* Path 1 (M much larger than N, JOBU='N') */
+/* No left singular vectors to be computed */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: need 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &
+ i__2, &ierr);
+
+/* Zero out below R */
+
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ claset_("L", &i__2, &i__3, &c_b1, &c_b1, &a[a_dim1 + 2], lda);
+ ie = 1;
+ itauq = 1;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in A */
+/* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__2, &ierr);
+ ncvt = 0;
+ if (wntvo || wntvas) {
+
+/* If right singular vectors desired, generate P'. */
+/* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &
+ work[iwork], &i__2, &ierr);
+ ncvt = *n;
+ }
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of A in A if desired */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", n, &ncvt, &c__0, &c__0, &s[1], &rwork[ie], &a[
+ a_offset], lda, cdum, &c__1, cdum, &c__1, &rwork[
+ irwork], info);
+
+/* If right singular vectors desired in VT, copy them there */
+
+ if (wntvas) {
+ clacpy_("F", n, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+ }
+
+ } else if (wntuo && wntvn) {
+
+/* Path 2 (M much larger than N, JOBU='O', JOBVT='N') */
+/* N left singular vectors to be overwritten on A and */
+/* no right singular vectors to be computed */
+
+ if (*lwork >= *n * *n + *n * 3) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *lda * *n;
+ if (*lwork >= max(i__2,i__3) + *lda * *n) {
+
+/* WORK(IU) is LDA by N, WORK(IR) is LDA by N */
+
+ ldwrku = *lda;
+ ldwrkr = *lda;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *lda * *n;
+ if (*lwork >= max(i__2,i__3) + *n * *n) {
+
+/* WORK(IU) is LDA by N, WORK(IR) is N by N */
+
+ ldwrku = *lda;
+ ldwrkr = *n;
+ } else {
+
+/* WORK(IU) is LDWRKU by N, WORK(IR) is N by N */
+
+ ldwrku = (*lwork - *n * *n) / *n;
+ ldwrkr = *n;
+ }
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__2, &ierr);
+
+/* Copy R to WORK(IR) and zero out below it */
+
+ clacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ claset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[ir + 1], &
+ ldwrkr);
+
+/* Generate Q in A */
+/* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IR) */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &i__2, &
+ ierr);
+
+/* Generate left vectors bidiagonalizing R */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) */
+/* (RWorkspace: need 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], &
+ work[iwork], &i__2, &ierr);
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IR) */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", n, &c__0, n, &c__0, &s[1], &rwork[ie], cdum,
+ &c__1, &work[ir], &ldwrkr, cdum, &c__1, &rwork[
+ irwork], info);
+ iu = itauq;
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IR), storing result in WORK(IU) and copying to A */
+/* (CWorkspace: need N*N+N, prefer N*N+M*N) */
+/* (RWorkspace: 0) */
+
+ i__2 = *m;
+ i__3 = ldwrku;
+ for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
+ i__3) {
+/* Computing MIN */
+ i__4 = *m - i__ + 1;
+ chunk = min(i__4,ldwrku);
+ cgemm_("N", "N", &chunk, n, n, &c_b2, &a[i__ + a_dim1]
+, lda, &work[ir], &ldwrkr, &c_b1, &work[iu], &
+ ldwrku);
+ clacpy_("F", &chunk, n, &work[iu], &ldwrku, &a[i__ +
+ a_dim1], lda);
+/* L10: */
+ }
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ ie = 1;
+ itauq = 1;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize A */
+/* (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB) */
+/* (RWorkspace: N) */
+
+ i__3 = *lwork - iwork + 1;
+ cgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__3, &ierr);
+
+/* Generate left vectors bidiagonalizing A */
+/* (CWorkspace: need 3*N, prefer 2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__3 = *lwork - iwork + 1;
+ cungbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], &
+ work[iwork], &i__3, &ierr);
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in A */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", n, &c__0, m, &c__0, &s[1], &rwork[ie], cdum,
+ &c__1, &a[a_offset], lda, cdum, &c__1, &rwork[
+ irwork], info);
+
+ }
+
+ } else if (wntuo && wntvas) {
+
+/* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A') */
+/* N left singular vectors to be overwritten on A and */
+/* N right singular vectors to be computed in VT */
+
+ if (*lwork >= *n * *n + *n * 3) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+/* Computing MAX */
+ i__3 = wrkbl, i__2 = *lda * *n;
+ if (*lwork >= max(i__3,i__2) + *lda * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is LDA by N */
+
+ ldwrku = *lda;
+ ldwrkr = *lda;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__3 = wrkbl, i__2 = *lda * *n;
+ if (*lwork >= max(i__3,i__2) + *n * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is N by N */
+
+ ldwrku = *lda;
+ ldwrkr = *n;
+ } else {
+
+/* WORK(IU) is LDWRKU by N and WORK(IR) is N by N */
+
+ ldwrku = (*lwork - *n * *n) / *n;
+ ldwrkr = *n;
+ }
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__3 = *lwork - iwork + 1;
+ cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__3, &ierr);
+
+/* Copy R to VT, zeroing out below it */
+
+ clacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+ if (*n > 1) {
+ i__3 = *n - 1;
+ i__2 = *n - 1;
+ claset_("L", &i__3, &i__2, &c_b1, &c_b1, &vt[vt_dim1
+ + 2], ldvt);
+ }
+
+/* Generate Q in A */
+/* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__3 = *lwork - iwork + 1;
+ cungqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__3, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in VT, copying result to WORK(IR) */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__3 = *lwork - iwork + 1;
+ cgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &i__3, &
+ ierr);
+ clacpy_("L", n, n, &vt[vt_offset], ldvt, &work[ir], &
+ ldwrkr);
+
+/* Generate left vectors bidiagonalizing R in WORK(IR) */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__3 = *lwork - iwork + 1;
+ cungbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], &
+ work[iwork], &i__3, &ierr);
+
+/* Generate right vectors bidiagonalizing R in VT */
+/* (CWorkspace: need N*N+3*N-1, prefer N*N+2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__3 = *lwork - iwork + 1;
+ cungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup],
+ &work[iwork], &i__3, &ierr);
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IR) and computing right */
+/* singular vectors of R in VT */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", n, n, n, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &work[ir], &ldwrkr, cdum, &c__1,
+ &rwork[irwork], info);
+ iu = itauq;
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IR), storing result in WORK(IU) and copying to A */
+/* (CWorkspace: need N*N+N, prefer N*N+M*N) */
+/* (RWorkspace: 0) */
+
+ i__3 = *m;
+ i__2 = ldwrku;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__4 = *m - i__ + 1;
+ chunk = min(i__4,ldwrku);
+ cgemm_("N", "N", &chunk, n, n, &c_b2, &a[i__ + a_dim1]
+, lda, &work[ir], &ldwrkr, &c_b1, &work[iu], &
+ ldwrku);
+ clacpy_("F", &chunk, n, &work[iu], &ldwrku, &a[i__ +
+ a_dim1], lda);
+/* L20: */
+ }
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__2, &ierr);
+
+/* Copy R to VT, zeroing out below it */
+
+ clacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+ if (*n > 1) {
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ claset_("L", &i__2, &i__3, &c_b1, &c_b1, &vt[vt_dim1
+ + 2], ldvt);
+ }
+
+/* Generate Q in A */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in VT */
+/* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) */
+/* (RWorkspace: N) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &i__2, &
+ ierr);
+
+/* Multiply Q in A by left vectors bidiagonalizing R */
+/* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunmbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt, &
+ work[itauq], &a[a_offset], lda, &work[iwork], &
+ i__2, &ierr);
+
+/* Generate right vectors bidiagonalizing R in VT */
+/* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup],
+ &work[iwork], &i__2, &ierr);
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in A and computing right */
+/* singular vectors of A in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", n, n, m, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &a[a_offset], lda, cdum, &c__1,
+ &rwork[irwork], info);
+
+ }
+
+ } else if (wntus) {
+
+ if (wntvn) {
+
+/* Path 4 (M much larger than N, JOBU='S', JOBVT='N') */
+/* N left singular vectors to be computed in U and */
+/* no right singular vectors to be computed */
+
+ if (*lwork >= *n * *n + *n * 3) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+ if (*lwork >= wrkbl + *lda * *n) {
+
+/* WORK(IR) is LDA by N */
+
+ ldwrkr = *lda;
+ } else {
+
+/* WORK(IR) is N by N */
+
+ ldwrkr = *n;
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy R to WORK(IR), zeroing out below it */
+
+ clacpy_("U", n, n, &a[a_offset], lda, &work[ir], &
+ ldwrkr);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ claset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[ir + 1]
+, &ldwrkr);
+
+/* Generate Q in A */
+/* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungqr_(m, n, n, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IR) */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Generate left vectors bidiagonalizing R in WORK(IR) */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IR) */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", n, &c__0, n, &c__0, &s[1], &rwork[ie],
+ cdum, &c__1, &work[ir], &ldwrkr, cdum, &c__1,
+ &rwork[irwork], info);
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IR), storing result in U */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: 0) */
+
+ cgemm_("N", "N", m, n, n, &c_b2, &a[a_offset], lda, &
+ work[ir], &ldwrkr, &c_b1, &u[u_offset], ldu);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ clacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungqr_(m, n, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Zero out below R in A */
+
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ claset_("L", &i__2, &i__3, &c_b1, &c_b1, &a[a_dim1 +
+ 2], lda);
+
+/* Bidiagonalize R in A */
+/* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left vectors bidiagonalizing R */
+/* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunmbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
+ work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr)
+ ;
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", n, &c__0, m, &c__0, &s[1], &rwork[ie],
+ cdum, &c__1, &u[u_offset], ldu, cdum, &c__1, &
+ rwork[irwork], info);
+
+ }
+
+ } else if (wntvo) {
+
+/* Path 5 (M much larger than N, JOBU='S', JOBVT='O') */
+/* N left singular vectors to be computed in U and */
+/* N right singular vectors to be overwritten on A */
+
+ if (*lwork >= (*n << 1) * *n + *n * 3) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + (*lda << 1) * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is LDA by N */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *lda;
+ } else if (*lwork >= wrkbl + (*lda + *n) * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is N by N */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *n;
+ } else {
+
+/* WORK(IU) is N by N and WORK(IR) is N by N */
+
+ ldwrku = *n;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *n;
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy R to WORK(IU), zeroing out below it */
+
+ clacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ claset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[iu + 1]
+, &ldwrku);
+
+/* Generate Q in A */
+/* (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungqr_(m, n, n, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IU), copying result to */
+/* WORK(IR) */
+/* (CWorkspace: need 2*N*N+3*N, */
+/* prefer 2*N*N+2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(n, n, &work[iu], &ldwrku, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ clacpy_("U", n, n, &work[iu], &ldwrku, &work[ir], &
+ ldwrkr);
+
+/* Generate left bidiagonalizing vectors in WORK(IU) */
+/* (CWorkspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in WORK(IR) */
+/* (CWorkspace: need 2*N*N+3*N-1, */
+/* prefer 2*N*N+2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("P", n, n, n, &work[ir], &ldwrkr, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IU) and computing */
+/* right singular vectors of R in WORK(IR) */
+/* (CWorkspace: need 2*N*N) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", n, n, n, &c__0, &s[1], &rwork[ie], &work[
+ ir], &ldwrkr, &work[iu], &ldwrku, cdum, &c__1,
+ &rwork[irwork], info);
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IU), storing result in U */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: 0) */
+
+ cgemm_("N", "N", m, n, n, &c_b2, &a[a_offset], lda, &
+ work[iu], &ldwrku, &c_b1, &u[u_offset], ldu);
+
+/* Copy right singular vectors of R to A */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: 0) */
+
+ clacpy_("F", n, n, &work[ir], &ldwrkr, &a[a_offset],
+ lda);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ clacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungqr_(m, n, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Zero out below R in A */
+
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ claset_("L", &i__2, &i__3, &c_b1, &c_b1, &a[a_dim1 +
+ 2], lda);
+
+/* Bidiagonalize R in A */
+/* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left vectors bidiagonalizing R */
+/* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunmbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
+ work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr)
+ ;
+
+/* Generate right vectors bidiagonalizing R in A */
+/* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("P", n, n, n, &a[a_offset], lda, &work[itaup],
+ &work[iwork], &i__2, &ierr);
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in A */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", n, n, m, &c__0, &s[1], &rwork[ie], &a[
+ a_offset], lda, &u[u_offset], ldu, cdum, &
+ c__1, &rwork[irwork], info);
+
+ }
+
+ } else if (wntvas) {
+
+/* Path 6 (M much larger than N, JOBU='S', JOBVT='S' */
+/* or 'A') */
+/* N left singular vectors to be computed in U and */
+/* N right singular vectors to be computed in VT */
+
+ if (*lwork >= *n * *n + *n * 3) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + *lda * *n) {
+
+/* WORK(IU) is LDA by N */
+
+ ldwrku = *lda;
+ } else {
+
+/* WORK(IU) is N by N */
+
+ ldwrku = *n;
+ }
+ itau = iu + ldwrku * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy R to WORK(IU), zeroing out below it */
+
+ clacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ claset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[iu + 1]
+, &ldwrku);
+
+/* Generate Q in A */
+/* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungqr_(m, n, n, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IU), copying result to VT */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(n, n, &work[iu], &ldwrku, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ clacpy_("U", n, n, &work[iu], &ldwrku, &vt[vt_offset],
+ ldvt);
+
+/* Generate left bidiagonalizing vectors in WORK(IU) */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in VT */
+/* (CWorkspace: need N*N+3*N-1, */
+/* prefer N*N+2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
+ itaup], &work[iwork], &i__2, &ierr)
+ ;
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IU) and computing */
+/* right singular vectors of R in VT */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", n, n, n, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &work[iu], &ldwrku, cdum, &
+ c__1, &rwork[irwork], info);
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IU), storing result in U */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: 0) */
+
+ cgemm_("N", "N", m, n, n, &c_b2, &a[a_offset], lda, &
+ work[iu], &ldwrku, &c_b1, &u[u_offset], ldu);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ clacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungqr_(m, n, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy R to VT, zeroing out below it */
+
+ clacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+ if (*n > 1) {
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ claset_("L", &i__2, &i__3, &c_b1, &c_b1, &vt[
+ vt_dim1 + 2], ldvt);
+ }
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in VT */
+/* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &rwork[ie],
+ &work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left bidiagonalizing vectors */
+/* in VT */
+/* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunmbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt,
+ &work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in VT */
+/* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
+ itaup], &work[iwork], &i__2, &ierr)
+ ;
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", n, n, m, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, cdum, &
+ c__1, &rwork[irwork], info);
+
+ }
+
+ }
+
+ } else if (wntua) {
+
+ if (wntvn) {
+
+/* Path 7 (M much larger than N, JOBU='A', JOBVT='N') */
+/* M left singular vectors to be computed in U and */
+/* no right singular vectors to be computed */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *n * 3;
+ if (*lwork >= *n * *n + max(i__2,i__3)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+ if (*lwork >= wrkbl + *lda * *n) {
+
+/* WORK(IR) is LDA by N */
+
+ ldwrkr = *lda;
+ } else {
+
+/* WORK(IR) is N by N */
+
+ ldwrkr = *n;
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ clacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Copy R to WORK(IR), zeroing out below it */
+
+ clacpy_("U", n, n, &a[a_offset], lda, &work[ir], &
+ ldwrkr);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ claset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[ir + 1]
+, &ldwrkr);
+
+/* Generate Q in U */
+/* (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IR) */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in WORK(IR) */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IR) */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", n, &c__0, n, &c__0, &s[1], &rwork[ie],
+ cdum, &c__1, &work[ir], &ldwrkr, cdum, &c__1,
+ &rwork[irwork], info);
+
+/* Multiply Q in U by left singular vectors of R in */
+/* WORK(IR), storing result in A */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: 0) */
+
+ cgemm_("N", "N", m, n, n, &c_b2, &u[u_offset], ldu, &
+ work[ir], &ldwrkr, &c_b1, &a[a_offset], lda);
+
+/* Copy left singular vectors of A from A to U */
+
+ clacpy_("F", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ clacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (CWorkspace: need N+M, prefer N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Zero out below R in A */
+
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ claset_("L", &i__2, &i__3, &c_b1, &c_b1, &a[a_dim1 +
+ 2], lda);
+
+/* Bidiagonalize R in A */
+/* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left bidiagonalizing vectors */
+/* in A */
+/* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunmbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
+ work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr)
+ ;
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", n, &c__0, m, &c__0, &s[1], &rwork[ie],
+ cdum, &c__1, &u[u_offset], ldu, cdum, &c__1, &
+ rwork[irwork], info);
+
+ }
+
+ } else if (wntvo) {
+
+/* Path 8 (M much larger than N, JOBU='A', JOBVT='O') */
+/* M left singular vectors to be computed in U and */
+/* N right singular vectors to be overwritten on A */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *n * 3;
+ if (*lwork >= (*n << 1) * *n + max(i__2,i__3)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + (*lda << 1) * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is LDA by N */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *lda;
+ } else if (*lwork >= wrkbl + (*lda + *n) * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is N by N */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *n;
+ } else {
+
+/* WORK(IU) is N by N and WORK(IR) is N by N */
+
+ ldwrku = *n;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *n;
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ clacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (CWorkspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy R to WORK(IU), zeroing out below it */
+
+ clacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ claset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[iu + 1]
+, &ldwrku);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IU), copying result to */
+/* WORK(IR) */
+/* (CWorkspace: need 2*N*N+3*N, */
+/* prefer 2*N*N+2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(n, n, &work[iu], &ldwrku, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ clacpy_("U", n, n, &work[iu], &ldwrku, &work[ir], &
+ ldwrkr);
+
+/* Generate left bidiagonalizing vectors in WORK(IU) */
+/* (CWorkspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in WORK(IR) */
+/* (CWorkspace: need 2*N*N+3*N-1, */
+/* prefer 2*N*N+2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("P", n, n, n, &work[ir], &ldwrkr, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IU) and computing */
+/* right singular vectors of R in WORK(IR) */
+/* (CWorkspace: need 2*N*N) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", n, n, n, &c__0, &s[1], &rwork[ie], &work[
+ ir], &ldwrkr, &work[iu], &ldwrku, cdum, &c__1,
+ &rwork[irwork], info);
+
+/* Multiply Q in U by left singular vectors of R in */
+/* WORK(IU), storing result in A */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: 0) */
+
+ cgemm_("N", "N", m, n, n, &c_b2, &u[u_offset], ldu, &
+ work[iu], &ldwrku, &c_b1, &a[a_offset], lda);
+
+/* Copy left singular vectors of A from A to U */
+
+ clacpy_("F", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Copy right singular vectors of R from WORK(IR) to A */
+
+ clacpy_("F", n, n, &work[ir], &ldwrkr, &a[a_offset],
+ lda);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ clacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (CWorkspace: need N+M, prefer N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Zero out below R in A */
+
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ claset_("L", &i__2, &i__3, &c_b1, &c_b1, &a[a_dim1 +
+ 2], lda);
+
+/* Bidiagonalize R in A */
+/* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left bidiagonalizing vectors */
+/* in A */
+/* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunmbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
+ work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr)
+ ;
+
+/* Generate right bidiagonalizing vectors in A */
+/* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("P", n, n, n, &a[a_offset], lda, &work[itaup],
+ &work[iwork], &i__2, &ierr);
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in A */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", n, n, m, &c__0, &s[1], &rwork[ie], &a[
+ a_offset], lda, &u[u_offset], ldu, cdum, &
+ c__1, &rwork[irwork], info);
+
+ }
+
+ } else if (wntvas) {
+
+/* Path 9 (M much larger than N, JOBU='A', JOBVT='S' */
+/* or 'A') */
+/* M left singular vectors to be computed in U and */
+/* N right singular vectors to be computed in VT */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *n * 3;
+ if (*lwork >= *n * *n + max(i__2,i__3)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + *lda * *n) {
+
+/* WORK(IU) is LDA by N */
+
+ ldwrku = *lda;
+ } else {
+
+/* WORK(IU) is N by N */
+
+ ldwrku = *n;
+ }
+ itau = iu + ldwrku * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ clacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy R to WORK(IU), zeroing out below it */
+
+ clacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ claset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[iu + 1]
+, &ldwrku);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IU), copying result to VT */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(n, n, &work[iu], &ldwrku, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ clacpy_("U", n, n, &work[iu], &ldwrku, &vt[vt_offset],
+ ldvt);
+
+/* Generate left bidiagonalizing vectors in WORK(IU) */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in VT */
+/* (CWorkspace: need N*N+3*N-1, */
+/* prefer N*N+2*N+(N-1)*NB) */
+/* (RWorkspace: need 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
+ itaup], &work[iwork], &i__2, &ierr)
+ ;
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IU) and computing */
+/* right singular vectors of R in VT */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", n, n, n, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &work[iu], &ldwrku, cdum, &
+ c__1, &rwork[irwork], info);
+
+/* Multiply Q in U by left singular vectors of R in */
+/* WORK(IU), storing result in A */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: 0) */
+
+ cgemm_("N", "N", m, n, n, &c_b2, &u[u_offset], ldu, &
+ work[iu], &ldwrku, &c_b1, &a[a_offset], lda);
+
+/* Copy left singular vectors of A from A to U */
+
+ clacpy_("F", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ clacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (CWorkspace: need N+M, prefer N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy R from A to VT, zeroing out below it */
+
+ clacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+ if (*n > 1) {
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ claset_("L", &i__2, &i__3, &c_b1, &c_b1, &vt[
+ vt_dim1 + 2], ldvt);
+ }
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in VT */
+/* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &rwork[ie],
+ &work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left bidiagonalizing vectors */
+/* in VT */
+/* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunmbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt,
+ &work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in VT */
+/* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
+ itaup], &work[iwork], &i__2, &ierr)
+ ;
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", n, n, m, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, cdum, &
+ c__1, &rwork[irwork], info);
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* M .LT. MNTHR */
+
+/* Path 10 (M at least N, but not much larger) */
+/* Reduce to bidiagonal form without QR decomposition */
+
+ ie = 1;
+ itauq = 1;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize A */
+/* (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq],
+ &work[itaup], &work[iwork], &i__2, &ierr);
+ if (wntuas) {
+
+/* If left singular vectors desired in U, copy result to U */
+/* and generate left bidiagonalizing vectors in U */
+/* (CWorkspace: need 2*N+NCU, prefer 2*N+NCU*NB) */
+/* (RWorkspace: 0) */
+
+ clacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu);
+ if (wntus) {
+ ncu = *n;
+ }
+ if (wntua) {
+ ncu = *m;
+ }
+ i__2 = *lwork - iwork + 1;
+ cungbr_("Q", m, &ncu, n, &u[u_offset], ldu, &work[itauq], &
+ work[iwork], &i__2, &ierr);
+ }
+ if (wntvas) {
+
+/* If right singular vectors desired in VT, copy result to */
+/* VT and generate right bidiagonalizing vectors in VT */
+/* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ clacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+ i__2 = *lwork - iwork + 1;
+ cungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], &
+ work[iwork], &i__2, &ierr);
+ }
+ if (wntuo) {
+
+/* If left singular vectors desired in A, generate left */
+/* bidiagonalizing vectors in A */
+/* (CWorkspace: need 3*N, prefer 2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], &work[
+ iwork], &i__2, &ierr);
+ }
+ if (wntvo) {
+
+/* If right singular vectors desired in A, generate right */
+/* bidiagonalizing vectors in A */
+/* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[
+ iwork], &i__2, &ierr);
+ }
+ irwork = ie + *n;
+ if (wntuas || wntuo) {
+ nru = *m;
+ }
+ if (wntun) {
+ nru = 0;
+ }
+ if (wntvas || wntvo) {
+ ncvt = *n;
+ }
+ if (wntvn) {
+ ncvt = 0;
+ }
+ if (! wntuo && ! wntvo) {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in U and computing right singular */
+/* vectors in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, cdum, &c__1, &
+ rwork[irwork], info);
+ } else if (! wntuo && wntvo) {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in U and computing right singular */
+/* vectors in A */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &a[
+ a_offset], lda, &u[u_offset], ldu, cdum, &c__1, &
+ rwork[irwork], info);
+ } else {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in A and computing right singular */
+/* vectors in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &a[a_offset], lda, cdum, &c__1, &
+ rwork[irwork], info);
+ }
+
+ }
+
+ } else {
+
+/* A has more columns than rows. If A has sufficiently more */
+/* columns than rows, first reduce using the LQ decomposition (if */
+/* sufficient workspace available) */
+
+ if (*n >= mnthr) {
+
+ if (wntvn) {
+
+/* Path 1t(N much larger than M, JOBVT='N') */
+/* No right singular vectors to be computed */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &
+ i__2, &ierr);
+
+/* Zero out above L */
+
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ claset_("U", &i__2, &i__3, &c_b1, &c_b1, &a[(a_dim1 << 1) + 1]
+, lda);
+ ie = 1;
+ itauq = 1;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in A */
+/* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__2, &ierr);
+ if (wntuo || wntuas) {
+
+/* If left singular vectors desired, generate Q */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq], &
+ work[iwork], &i__2, &ierr);
+ }
+ irwork = ie + *m;
+ nru = 0;
+ if (wntuo || wntuas) {
+ nru = *m;
+ }
+
+/* Perform bidiagonal QR iteration, computing left singular */
+/* vectors of A in A if desired */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", m, &c__0, &nru, &c__0, &s[1], &rwork[ie], cdum, &
+ c__1, &a[a_offset], lda, cdum, &c__1, &rwork[irwork],
+ info);
+
+/* If left singular vectors desired in U, copy them there */
+
+ if (wntuas) {
+ clacpy_("F", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+ }
+
+ } else if (wntvo && wntun) {
+
+/* Path 2t(N much larger than M, JOBU='N', JOBVT='O') */
+/* M right singular vectors to be overwritten on A and */
+/* no left singular vectors to be computed */
+
+ if (*lwork >= *m * *m + *m * 3) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *lda * *n;
+ if (*lwork >= max(i__2,i__3) + *lda * *m) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is LDA by M */
+
+ ldwrku = *lda;
+ chunk = *n;
+ ldwrkr = *lda;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *lda * *n;
+ if (*lwork >= max(i__2,i__3) + *m * *m) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is M by M */
+
+ ldwrku = *lda;
+ chunk = *n;
+ ldwrkr = *m;
+ } else {
+
+/* WORK(IU) is M by CHUNK and WORK(IR) is M by M */
+
+ ldwrku = *m;
+ chunk = (*lwork - *m * *m) / *m;
+ ldwrkr = *m;
+ }
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__2, &ierr);
+
+/* Copy L to WORK(IR) and zero out above it */
+
+ clacpy_("L", m, m, &a[a_offset], lda, &work[ir], &ldwrkr);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ claset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[ir +
+ ldwrkr], &ldwrkr);
+
+/* Generate Q in A */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IR) */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &i__2, &
+ ierr);
+
+/* Generate right vectors bidiagonalizing L */
+/* (CWorkspace: need M*M+3*M-1, prefer M*M+2*M+(M-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup], &
+ work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of L in WORK(IR) */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", m, m, &c__0, &c__0, &s[1], &rwork[ie], &work[
+ ir], &ldwrkr, cdum, &c__1, cdum, &c__1, &rwork[
+ irwork], info);
+ iu = itauq;
+
+/* Multiply right singular vectors of L in WORK(IR) by Q */
+/* in A, storing result in WORK(IU) and copying to A */
+/* (CWorkspace: need M*M+M, prefer M*M+M*N) */
+/* (RWorkspace: 0) */
+
+ i__2 = *n;
+ i__3 = chunk;
+ for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
+ i__3) {
+/* Computing MIN */
+ i__4 = *n - i__ + 1;
+ blk = min(i__4,chunk);
+ cgemm_("N", "N", m, &blk, m, &c_b2, &work[ir], &
+ ldwrkr, &a[i__ * a_dim1 + 1], lda, &c_b1, &
+ work[iu], &ldwrku);
+ clacpy_("F", m, &blk, &work[iu], &ldwrku, &a[i__ *
+ a_dim1 + 1], lda);
+/* L30: */
+ }
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ ie = 1;
+ itauq = 1;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize A */
+/* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) */
+/* (RWorkspace: need M) */
+
+ i__3 = *lwork - iwork + 1;
+ cgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__3, &ierr);
+
+/* Generate right vectors bidiagonalizing A */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__3 = *lwork - iwork + 1;
+ cungbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &
+ work[iwork], &i__3, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of A in A */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("L", m, n, &c__0, &c__0, &s[1], &rwork[ie], &a[
+ a_offset], lda, cdum, &c__1, cdum, &c__1, &rwork[
+ irwork], info);
+
+ }
+
+ } else if (wntvo && wntuas) {
+
+/* Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O') */
+/* M right singular vectors to be overwritten on A and */
+/* M left singular vectors to be computed in U */
+
+ if (*lwork >= *m * *m + *m * 3) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+/* Computing MAX */
+ i__3 = wrkbl, i__2 = *lda * *n;
+ if (*lwork >= max(i__3,i__2) + *lda * *m) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is LDA by M */
+
+ ldwrku = *lda;
+ chunk = *n;
+ ldwrkr = *lda;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__3 = wrkbl, i__2 = *lda * *n;
+ if (*lwork >= max(i__3,i__2) + *m * *m) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is M by M */
+
+ ldwrku = *lda;
+ chunk = *n;
+ ldwrkr = *m;
+ } else {
+
+/* WORK(IU) is M by CHUNK and WORK(IR) is M by M */
+
+ ldwrku = *m;
+ chunk = (*lwork - *m * *m) / *m;
+ ldwrkr = *m;
+ }
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__3 = *lwork - iwork + 1;
+ cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__3, &ierr);
+
+/* Copy L to U, zeroing about above it */
+
+ clacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+ i__3 = *m - 1;
+ i__2 = *m - 1;
+ claset_("U", &i__3, &i__2, &c_b1, &c_b1, &u[(u_dim1 << 1)
+ + 1], ldu);
+
+/* Generate Q in A */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__3 = *lwork - iwork + 1;
+ cunglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__3, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in U, copying result to WORK(IR) */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__3 = *lwork - iwork + 1;
+ cgebrd_(m, m, &u[u_offset], ldu, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__3, &ierr);
+ clacpy_("U", m, m, &u[u_offset], ldu, &work[ir], &ldwrkr);
+
+/* Generate right vectors bidiagonalizing L in WORK(IR) */
+/* (CWorkspace: need M*M+3*M-1, prefer M*M+2*M+(M-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__3 = *lwork - iwork + 1;
+ cungbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup], &
+ work[iwork], &i__3, &ierr);
+
+/* Generate left vectors bidiagonalizing L in U */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__3 = *lwork - iwork + 1;
+ cungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], &
+ work[iwork], &i__3, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of L in U, and computing right */
+/* singular vectors of L in WORK(IR) */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", m, m, m, &c__0, &s[1], &rwork[ie], &work[ir],
+ &ldwrkr, &u[u_offset], ldu, cdum, &c__1, &rwork[
+ irwork], info);
+ iu = itauq;
+
+/* Multiply right singular vectors of L in WORK(IR) by Q */
+/* in A, storing result in WORK(IU) and copying to A */
+/* (CWorkspace: need M*M+M, prefer M*M+M*N)) */
+/* (RWorkspace: 0) */
+
+ i__3 = *n;
+ i__2 = chunk;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__4 = *n - i__ + 1;
+ blk = min(i__4,chunk);
+ cgemm_("N", "N", m, &blk, m, &c_b2, &work[ir], &
+ ldwrkr, &a[i__ * a_dim1 + 1], lda, &c_b1, &
+ work[iu], &ldwrku);
+ clacpy_("F", m, &blk, &work[iu], &ldwrku, &a[i__ *
+ a_dim1 + 1], lda);
+/* L40: */
+ }
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__2, &ierr);
+
+/* Copy L to U, zeroing out above it */
+
+ clacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ claset_("U", &i__2, &i__3, &c_b1, &c_b1, &u[(u_dim1 << 1)
+ + 1], ldu);
+
+/* Generate Q in A */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in U */
+/* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(m, m, &u[u_offset], ldu, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__2, &ierr);
+
+/* Multiply right vectors bidiagonalizing L by Q in A */
+/* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunmbr_("P", "L", "C", m, n, m, &u[u_offset], ldu, &work[
+ itaup], &a[a_offset], lda, &work[iwork], &i__2, &
+ ierr);
+
+/* Generate left vectors bidiagonalizing L in U */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], &
+ work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in A */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", m, n, m, &c__0, &s[1], &rwork[ie], &a[
+ a_offset], lda, &u[u_offset], ldu, cdum, &c__1, &
+ rwork[irwork], info);
+
+ }
+
+ } else if (wntvs) {
+
+ if (wntun) {
+
+/* Path 4t(N much larger than M, JOBU='N', JOBVT='S') */
+/* M right singular vectors to be computed in VT and */
+/* no left singular vectors to be computed */
+
+ if (*lwork >= *m * *m + *m * 3) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+ if (*lwork >= wrkbl + *lda * *m) {
+
+/* WORK(IR) is LDA by M */
+
+ ldwrkr = *lda;
+ } else {
+
+/* WORK(IR) is M by M */
+
+ ldwrkr = *m;
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy L to WORK(IR), zeroing out above it */
+
+ clacpy_("L", m, m, &a[a_offset], lda, &work[ir], &
+ ldwrkr);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ claset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[ir +
+ ldwrkr], &ldwrkr);
+
+/* Generate Q in A */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunglq_(m, n, m, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IR) */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Generate right vectors bidiagonalizing L in */
+/* WORK(IR) */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+(M-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of L in WORK(IR) */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", m, m, &c__0, &c__0, &s[1], &rwork[ie], &
+ work[ir], &ldwrkr, cdum, &c__1, cdum, &c__1, &
+ rwork[irwork], info);
+
+/* Multiply right singular vectors of L in WORK(IR) by */
+/* Q in A, storing result in VT */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: 0) */
+
+ cgemm_("N", "N", m, n, m, &c_b2, &work[ir], &ldwrkr, &
+ a[a_offset], lda, &c_b1, &vt[vt_offset], ldvt);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy result to VT */
+
+ clacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Zero out above L in A */
+
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ claset_("U", &i__2, &i__3, &c_b1, &c_b1, &a[(a_dim1 <<
+ 1) + 1], lda);
+
+/* Bidiagonalize L in A */
+/* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right vectors bidiagonalizing L by Q in VT */
+/* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunmbr_("P", "L", "C", m, n, m, &a[a_offset], lda, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of A in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", m, n, &c__0, &c__0, &s[1], &rwork[ie], &
+ vt[vt_offset], ldvt, cdum, &c__1, cdum, &c__1,
+ &rwork[irwork], info);
+
+ }
+
+ } else if (wntuo) {
+
+/* Path 5t(N much larger than M, JOBU='O', JOBVT='S') */
+/* M right singular vectors to be computed in VT and */
+/* M left singular vectors to be overwritten on A */
+
+ if (*lwork >= (*m << 1) * *m + *m * 3) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + (*lda << 1) * *m) {
+
+/* WORK(IU) is LDA by M and WORK(IR) is LDA by M */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *lda;
+ } else if (*lwork >= wrkbl + (*lda + *m) * *m) {
+
+/* WORK(IU) is LDA by M and WORK(IR) is M by M */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *m;
+ } else {
+
+/* WORK(IU) is M by M and WORK(IR) is M by M */
+
+ ldwrku = *m;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *m;
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy L to WORK(IU), zeroing out below it */
+
+ clacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ claset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[iu +
+ ldwrku], &ldwrku);
+
+/* Generate Q in A */
+/* (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunglq_(m, n, m, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IU), copying result to */
+/* WORK(IR) */
+/* (CWorkspace: need 2*M*M+3*M, */
+/* prefer 2*M*M+2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(m, m, &work[iu], &ldwrku, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ clacpy_("L", m, m, &work[iu], &ldwrku, &work[ir], &
+ ldwrkr);
+
+/* Generate right bidiagonalizing vectors in WORK(IU) */
+/* (CWorkspace: need 2*M*M+3*M-1, */
+/* prefer 2*M*M+2*M+(M-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in WORK(IR) */
+/* (CWorkspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("Q", m, m, m, &work[ir], &ldwrkr, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of L in WORK(IR) and computing */
+/* right singular vectors of L in WORK(IU) */
+/* (CWorkspace: need 2*M*M) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", m, m, m, &c__0, &s[1], &rwork[ie], &work[
+ iu], &ldwrku, &work[ir], &ldwrkr, cdum, &c__1,
+ &rwork[irwork], info);
+
+/* Multiply right singular vectors of L in WORK(IU) by */
+/* Q in A, storing result in VT */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: 0) */
+
+ cgemm_("N", "N", m, n, m, &c_b2, &work[iu], &ldwrku, &
+ a[a_offset], lda, &c_b1, &vt[vt_offset], ldvt);
+
+/* Copy left singular vectors of L to A */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: 0) */
+
+ clacpy_("F", m, m, &work[ir], &ldwrkr, &a[a_offset],
+ lda);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ clacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Zero out above L in A */
+
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ claset_("U", &i__2, &i__3, &c_b1, &c_b1, &a[(a_dim1 <<
+ 1) + 1], lda);
+
+/* Bidiagonalize L in A */
+/* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right vectors bidiagonalizing L by Q in VT */
+/* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunmbr_("P", "L", "C", m, n, m, &a[a_offset], lda, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors of L in A */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in A and computing right */
+/* singular vectors of A in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", m, n, m, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &a[a_offset], lda, cdum, &
+ c__1, &rwork[irwork], info);
+
+ }
+
+ } else if (wntuas) {
+
+/* Path 6t(N much larger than M, JOBU='S' or 'A', */
+/* JOBVT='S') */
+/* M right singular vectors to be computed in VT and */
+/* M left singular vectors to be computed in U */
+
+ if (*lwork >= *m * *m + *m * 3) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + *lda * *m) {
+
+/* WORK(IU) is LDA by N */
+
+ ldwrku = *lda;
+ } else {
+
+/* WORK(IU) is LDA by M */
+
+ ldwrku = *m;
+ }
+ itau = iu + ldwrku * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy L to WORK(IU), zeroing out above it */
+
+ clacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ claset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[iu +
+ ldwrku], &ldwrku);
+
+/* Generate Q in A */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunglq_(m, n, m, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IU), copying result to U */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(m, m, &work[iu], &ldwrku, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ clacpy_("L", m, m, &work[iu], &ldwrku, &u[u_offset],
+ ldu);
+
+/* Generate right bidiagonalizing vectors in WORK(IU) */
+/* (CWorkspace: need M*M+3*M-1, */
+/* prefer M*M+2*M+(M-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in U */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of L in U and computing right */
+/* singular vectors of L in WORK(IU) */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", m, m, m, &c__0, &s[1], &rwork[ie], &work[
+ iu], &ldwrku, &u[u_offset], ldu, cdum, &c__1,
+ &rwork[irwork], info);
+
+/* Multiply right singular vectors of L in WORK(IU) by */
+/* Q in A, storing result in VT */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: 0) */
+
+ cgemm_("N", "N", m, n, m, &c_b2, &work[iu], &ldwrku, &
+ a[a_offset], lda, &c_b1, &vt[vt_offset], ldvt);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ clacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy L to U, zeroing out above it */
+
+ clacpy_("L", m, m, &a[a_offset], lda, &u[u_offset],
+ ldu);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ claset_("U", &i__2, &i__3, &c_b1, &c_b1, &u[(u_dim1 <<
+ 1) + 1], ldu);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in U */
+/* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(m, m, &u[u_offset], ldu, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right bidiagonalizing vectors in U by Q */
+/* in VT */
+/* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunmbr_("P", "L", "C", m, n, m, &u[u_offset], ldu, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in U */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", m, n, m, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, cdum, &
+ c__1, &rwork[irwork], info);
+
+ }
+
+ }
+
+ } else if (wntva) {
+
+ if (wntun) {
+
+/* Path 7t(N much larger than M, JOBU='N', JOBVT='A') */
+/* N right singular vectors to be computed in VT and */
+/* no left singular vectors to be computed */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *m * 3;
+ if (*lwork >= *m * *m + max(i__2,i__3)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+ if (*lwork >= wrkbl + *lda * *m) {
+
+/* WORK(IR) is LDA by M */
+
+ ldwrkr = *lda;
+ } else {
+
+/* WORK(IR) is M by M */
+
+ ldwrkr = *m;
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ clacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Copy L to WORK(IR), zeroing out above it */
+
+ clacpy_("L", m, m, &a[a_offset], lda, &work[ir], &
+ ldwrkr);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ claset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[ir +
+ ldwrkr], &ldwrkr);
+
+/* Generate Q in VT */
+/* (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IR) */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in WORK(IR) */
+/* (CWorkspace: need M*M+3*M-1, */
+/* prefer M*M+2*M+(M-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of L in WORK(IR) */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", m, m, &c__0, &c__0, &s[1], &rwork[ie], &
+ work[ir], &ldwrkr, cdum, &c__1, cdum, &c__1, &
+ rwork[irwork], info);
+
+/* Multiply right singular vectors of L in WORK(IR) by */
+/* Q in VT, storing result in A */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: 0) */
+
+ cgemm_("N", "N", m, n, m, &c_b2, &work[ir], &ldwrkr, &
+ vt[vt_offset], ldvt, &c_b1, &a[a_offset], lda);
+
+/* Copy right singular vectors of A from A to VT */
+
+ clacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ clacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (CWorkspace: need M+N, prefer M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Zero out above L in A */
+
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ claset_("U", &i__2, &i__3, &c_b1, &c_b1, &a[(a_dim1 <<
+ 1) + 1], lda);
+
+/* Bidiagonalize L in A */
+/* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right bidiagonalizing vectors in A by Q */
+/* in VT */
+/* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunmbr_("P", "L", "C", m, n, m, &a[a_offset], lda, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of A in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", m, n, &c__0, &c__0, &s[1], &rwork[ie], &
+ vt[vt_offset], ldvt, cdum, &c__1, cdum, &c__1,
+ &rwork[irwork], info);
+
+ }
+
+ } else if (wntuo) {
+
+/* Path 8t(N much larger than M, JOBU='O', JOBVT='A') */
+/* N right singular vectors to be computed in VT and */
+/* M left singular vectors to be overwritten on A */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *m * 3;
+ if (*lwork >= (*m << 1) * *m + max(i__2,i__3)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + (*lda << 1) * *m) {
+
+/* WORK(IU) is LDA by M and WORK(IR) is LDA by M */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *lda;
+ } else if (*lwork >= wrkbl + (*lda + *m) * *m) {
+
+/* WORK(IU) is LDA by M and WORK(IR) is M by M */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *m;
+ } else {
+
+/* WORK(IU) is M by M and WORK(IR) is M by M */
+
+ ldwrku = *m;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *m;
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ clacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (CWorkspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy L to WORK(IU), zeroing out above it */
+
+ clacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ claset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[iu +
+ ldwrku], &ldwrku);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IU), copying result to */
+/* WORK(IR) */
+/* (CWorkspace: need 2*M*M+3*M, */
+/* prefer 2*M*M+2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(m, m, &work[iu], &ldwrku, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ clacpy_("L", m, m, &work[iu], &ldwrku, &work[ir], &
+ ldwrkr);
+
+/* Generate right bidiagonalizing vectors in WORK(IU) */
+/* (CWorkspace: need 2*M*M+3*M-1, */
+/* prefer 2*M*M+2*M+(M-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in WORK(IR) */
+/* (CWorkspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("Q", m, m, m, &work[ir], &ldwrkr, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of L in WORK(IR) and computing */
+/* right singular vectors of L in WORK(IU) */
+/* (CWorkspace: need 2*M*M) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", m, m, m, &c__0, &s[1], &rwork[ie], &work[
+ iu], &ldwrku, &work[ir], &ldwrkr, cdum, &c__1,
+ &rwork[irwork], info);
+
+/* Multiply right singular vectors of L in WORK(IU) by */
+/* Q in VT, storing result in A */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: 0) */
+
+ cgemm_("N", "N", m, n, m, &c_b2, &work[iu], &ldwrku, &
+ vt[vt_offset], ldvt, &c_b1, &a[a_offset], lda);
+
+/* Copy right singular vectors of A from A to VT */
+
+ clacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Copy left singular vectors of A from WORK(IR) to A */
+
+ clacpy_("F", m, m, &work[ir], &ldwrkr, &a[a_offset],
+ lda);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ clacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (CWorkspace: need M+N, prefer M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Zero out above L in A */
+
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ claset_("U", &i__2, &i__3, &c_b1, &c_b1, &a[(a_dim1 <<
+ 1) + 1], lda);
+
+/* Bidiagonalize L in A */
+/* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right bidiagonalizing vectors in A by Q */
+/* in VT */
+/* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunmbr_("P", "L", "C", m, n, m, &a[a_offset], lda, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in A */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in A and computing right */
+/* singular vectors of A in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", m, n, m, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &a[a_offset], lda, cdum, &
+ c__1, &rwork[irwork], info);
+
+ }
+
+ } else if (wntuas) {
+
+/* Path 9t(N much larger than M, JOBU='S' or 'A', */
+/* JOBVT='A') */
+/* N right singular vectors to be computed in VT and */
+/* M left singular vectors to be computed in U */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *m * 3;
+ if (*lwork >= *m * *m + max(i__2,i__3)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + *lda * *m) {
+
+/* WORK(IU) is LDA by M */
+
+ ldwrku = *lda;
+ } else {
+
+/* WORK(IU) is M by M */
+
+ ldwrku = *m;
+ }
+ itau = iu + ldwrku * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ clacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy L to WORK(IU), zeroing out above it */
+
+ clacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ claset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[iu +
+ ldwrku], &ldwrku);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IU), copying result to U */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(m, m, &work[iu], &ldwrku, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ clacpy_("L", m, m, &work[iu], &ldwrku, &u[u_offset],
+ ldu);
+
+/* Generate right bidiagonalizing vectors in WORK(IU) */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+(M-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in U */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of L in U and computing right */
+/* singular vectors of L in WORK(IU) */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", m, m, m, &c__0, &s[1], &rwork[ie], &work[
+ iu], &ldwrku, &u[u_offset], ldu, cdum, &c__1,
+ &rwork[irwork], info);
+
+/* Multiply right singular vectors of L in WORK(IU) by */
+/* Q in VT, storing result in A */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: 0) */
+
+ cgemm_("N", "N", m, n, m, &c_b2, &work[iu], &ldwrku, &
+ vt[vt_offset], ldvt, &c_b1, &a[a_offset], lda);
+
+/* Copy right singular vectors of A from A to VT */
+
+ clacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ clacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (CWorkspace: need M+N, prefer M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy L to U, zeroing out above it */
+
+ clacpy_("L", m, m, &a[a_offset], lda, &u[u_offset],
+ ldu);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ claset_("U", &i__2, &i__3, &c_b1, &c_b1, &u[(u_dim1 <<
+ 1) + 1], ldu);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in U */
+/* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(m, m, &u[u_offset], ldu, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right bidiagonalizing vectors in U by Q */
+/* in VT */
+/* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cunmbr_("P", "L", "C", m, n, m, &u[u_offset], ldu, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in U */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("U", m, n, m, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, cdum, &
+ c__1, &rwork[irwork], info);
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N .LT. MNTHR */
+
+/* Path 10t(N greater than M, but not much larger) */
+/* Reduce to bidiagonal form without LQ decomposition */
+
+ ie = 1;
+ itauq = 1;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize A */
+/* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) */
+/* (RWorkspace: M) */
+
+ i__2 = *lwork - iwork + 1;
+ cgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq],
+ &work[itaup], &work[iwork], &i__2, &ierr);
+ if (wntuas) {
+
+/* If left singular vectors desired in U, copy result to U */
+/* and generate left bidiagonalizing vectors in U */
+/* (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB) */
+/* (RWorkspace: 0) */
+
+ clacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+ i__2 = *lwork - iwork + 1;
+ cungbr_("Q", m, m, n, &u[u_offset], ldu, &work[itauq], &work[
+ iwork], &i__2, &ierr);
+ }
+ if (wntvas) {
+
+/* If right singular vectors desired in VT, copy result to */
+/* VT and generate right bidiagonalizing vectors in VT */
+/* (CWorkspace: need 2*M+NRVT, prefer 2*M+NRVT*NB) */
+/* (RWorkspace: 0) */
+
+ clacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+ if (wntva) {
+ nrvt = *n;
+ }
+ if (wntvs) {
+ nrvt = *m;
+ }
+ i__2 = *lwork - iwork + 1;
+ cungbr_("P", &nrvt, n, m, &vt[vt_offset], ldvt, &work[itaup],
+ &work[iwork], &i__2, &ierr);
+ }
+ if (wntuo) {
+
+/* If left singular vectors desired in A, generate left */
+/* bidiagonalizing vectors in A */
+/* (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("Q", m, m, n, &a[a_offset], lda, &work[itauq], &work[
+ iwork], &i__2, &ierr);
+ }
+ if (wntvo) {
+
+/* If right singular vectors desired in A, generate right */
+/* bidiagonalizing vectors in A */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ cungbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[
+ iwork], &i__2, &ierr);
+ }
+ irwork = ie + *m;
+ if (wntuas || wntuo) {
+ nru = *m;
+ }
+ if (wntun) {
+ nru = 0;
+ }
+ if (wntvas || wntvo) {
+ ncvt = *n;
+ }
+ if (wntvn) {
+ ncvt = 0;
+ }
+ if (! wntuo && ! wntvo) {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in U and computing right singular */
+/* vectors in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, cdum, &c__1, &
+ rwork[irwork], info);
+ } else if (! wntuo && wntvo) {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in U and computing right singular */
+/* vectors in A */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &a[
+ a_offset], lda, &u[u_offset], ldu, cdum, &c__1, &
+ rwork[irwork], info);
+ } else {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in A and computing right singular */
+/* vectors in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ cbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &a[a_offset], lda, cdum, &c__1, &
+ rwork[irwork], info);
+ }
+
+ }
+
+ }
+
+/* Undo scaling if necessary */
+
+ if (iscl == 1) {
+ if (anrm > bignum) {
+ slascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, &ierr);
+ }
+ if (*info != 0 && anrm > bignum) {
+ i__2 = minmn - 1;
+ slascl_("G", &c__0, &c__0, &bignum, &anrm, &i__2, &c__1, &rwork[
+ ie], &minmn, &ierr);
+ }
+ if (anrm < smlnum) {
+ slascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, &ierr);
+ }
+ if (*info != 0 && anrm < smlnum) {
+ i__2 = minmn - 1;
+ slascl_("G", &c__0, &c__0, &smlnum, &anrm, &i__2, &c__1, &rwork[
+ ie], &minmn, &ierr);
+ }
+ }
+
+/* Return optimal workspace in WORK(1) */
+
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CGESVD */
+
+} /* cgesvd_ */
diff --git a/SRC/cgesvx.c b/SRC/cgesvx.c
new file mode 100644
index 0000000..3dffd52
--- /dev/null
+++ b/SRC/cgesvx.c
@@ -0,0 +1,605 @@
+/* cgesvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cgesvx_(char *fact, char *trans, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *
+ ipiv, char *equed, real *r__, real *c__, complex *b, integer *ldb,
+ complex *x, integer *ldx, real *rcond, real *ferr, real *berr,
+ complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j;
+ real amax;
+ char norm[1];
+ extern logical lsame_(char *, char *);
+ real rcmin, rcmax, anorm;
+ logical equil;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int claqge_(integer *, integer *, complex *,
+ integer *, real *, real *, real *, real *, real *, char *)
+ , cgecon_(char *, integer *, complex *, integer *, real *, real *,
+ complex *, real *, integer *);
+ real colcnd;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int cgeequ_(integer *, integer *, complex *,
+ integer *, real *, real *, real *, real *, real *, integer *);
+ logical nofact;
+ extern /* Subroutine */ int cgerfs_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, integer *, complex *, integer
+ *, complex *, integer *, real *, real *, complex *, real *,
+ integer *), cgetrf_(integer *, integer *, complex *,
+ integer *, integer *, integer *), clacpy_(char *, integer *,
+ integer *, complex *, integer *, complex *, integer *),
+ xerbla_(char *, integer *);
+ real bignum;
+ extern doublereal clantr_(char *, char *, char *, integer *, integer *,
+ complex *, integer *, real *);
+ integer infequ;
+ logical colequ;
+ extern /* Subroutine */ int cgetrs_(char *, integer *, integer *, complex
+ *, integer *, integer *, complex *, integer *, integer *);
+ real rowcnd;
+ logical notran;
+ real smlnum;
+ logical rowequ;
+ real rpvgrw;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGESVX uses the LU factorization to compute the solution to a complex */
+/* system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */
+/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */
+/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */
+/* or diag(C)*B (if TRANS = 'T' or 'C'). */
+
+/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the */
+/* matrix A (after equilibration if FACT = 'E') as */
+/* A = P * L * U, */
+/* where P is a permutation matrix, L is a unit lower triangular */
+/* matrix, and U is upper triangular. */
+
+/* 3. If some U(i,i)=0, so that U is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */
+/* that it solves the original system before equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF and IPIV contain the factored form of A. */
+/* If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by R and C. */
+/* A, AF, and IPIV are not modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is */
+/* not 'N', then A must have been equilibrated by the scaling */
+/* factors in R and/or C. A is not modified if FACT = 'F' or */
+/* 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
+
+/* On exit, if EQUED .ne. 'N', A is scaled as follows: */
+/* EQUED = 'R': A := diag(R) * A */
+/* EQUED = 'C': A := A * diag(C) */
+/* EQUED = 'B': A := diag(R) * A * diag(C). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) COMPLEX array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the factors L and U from the factorization */
+/* A = P*L*U as computed by CGETRF. If EQUED .ne. 'N', then */
+/* AF is the factored form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the equilibrated matrix A (see the description of A for */
+/* the form of the equilibrated matrix). */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* as computed by CGETRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the equilibrated matrix A. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* R (input or output) REAL array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+
+/* C (input or output) REAL array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */
+/* diag(R)*B; */
+/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */
+/* overwritten by diag(C)*B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X */
+/* to the original system of equations. Note that A and B are */
+/* modified on exit if EQUED .ne. 'N', and the solution to the */
+/* equilibrated system is inv(diag(C))*X if TRANS = 'N' and */
+/* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' */
+/* and EQUED = 'R' or 'B'. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A after equilibration (if done). If RCOND is less than the */
+/* machine precision (in particular, if RCOND = 0), the matrix */
+/* is singular to working precision. This condition is */
+/* indicated by a return code of INFO > 0. */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace/output) REAL array, dimension (2*N) */
+/* On exit, RWORK(1) contains the reciprocal pivot growth */
+/* factor norm(A)/norm(U). The "max absolute element" norm is */
+/* used. If RWORK(1) is much less than 1, then the stability */
+/* of the LU factorization of the (equilibrated) matrix A */
+/* could be poor. This also means that the solution X, condition */
+/* estimator RCOND, and forward error bound FERR could be */
+/* unreliable. If factorization fails with 0<INFO<=N, then */
+/* RWORK(1) contains the reciprocal pivot growth factor for the */
+/* leading INFO columns of A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: U(i,i) is exactly zero. The factorization has */
+/* been completed, but the factor U is exactly */
+/* singular, so the solution and error bounds */
+/* could not be computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ notran = lsame_(trans, "N");
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rowequ = FALSE_;
+ colequ = FALSE_;
+ } else {
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ }
+
+/* Test the input parameters. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (lsame_(fact, "F") && ! (rowequ || colequ
+ || lsame_(equed, "N"))) {
+ *info = -10;
+ } else {
+ if (rowequ) {
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = r__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = r__[j];
+ rcmax = dmax(r__1,r__2);
+/* L10: */
+ }
+ if (rcmin <= 0.f) {
+ *info = -11;
+ } else if (*n > 0) {
+ rowcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ } else {
+ rowcnd = 1.f;
+ }
+ }
+ if (colequ && *info == 0) {
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = c__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = c__[j];
+ rcmax = dmax(r__1,r__2);
+/* L20: */
+ }
+ if (rcmin <= 0.f) {
+ *info = -12;
+ } else if (*n > 0) {
+ colcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ } else {
+ colcnd = 1.f;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -14;
+ } else if (*ldx < max(1,*n)) {
+ *info = -16;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGESVX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ cgeequ_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &colcnd, &
+ amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ claqge_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &
+ colcnd, &amax, equed);
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+ }
+
+/* Scale the right hand side. */
+
+ if (notran) {
+ if (rowequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * b_dim1;
+ q__1.r = r__[i__4] * b[i__5].r, q__1.i = r__[i__4] * b[
+ i__5].i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else if (colequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * b_dim1;
+ q__1.r = c__[i__4] * b[i__5].r, q__1.i = c__[i__4] * b[i__5]
+ .i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of A. */
+
+ clacpy_("Full", n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ cgetrf_(n, n, &af[af_offset], ldaf, &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ rpvgrw = clantr_("M", "U", "N", info, info, &af[af_offset], ldaf,
+ &rwork[1]);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = clange_("M", n, info, &a[a_offset], lda, &rwork[1]) / rpvgrw;
+ }
+ rwork[1] = rpvgrw;
+ *rcond = 0.f;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A and the */
+/* reciprocal pivot growth factor RPVGRW. */
+
+ if (notran) {
+ *(unsigned char *)norm = '1';
+ } else {
+ *(unsigned char *)norm = 'I';
+ }
+ anorm = clange_(norm, n, n, &a[a_offset], lda, &rwork[1]);
+ rpvgrw = clantr_("M", "U", "N", n, n, &af[af_offset], ldaf, &rwork[1]);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = clange_("M", n, n, &a[a_offset], lda, &rwork[1]) /
+ rpvgrw;
+ }
+
+/* Compute the reciprocal of the condition number of A. */
+
+ cgecon_(norm, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &rwork[1],
+ info);
+
+/* Compute the solution matrix X. */
+
+ clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ cgetrs_(trans, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ cgerfs_(trans, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1],
+ &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[
+ 1], &rwork[1], info);
+
+/* Transform the solution matrix X to a solution of the original */
+/* system. */
+
+ if (notran) {
+ if (colequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * x_dim1;
+ q__1.r = c__[i__4] * x[i__5].r, q__1.i = c__[i__4] * x[
+ i__5].i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= colcnd;
+/* L90: */
+ }
+ }
+ } else if (rowequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * x_dim1;
+ q__1.r = r__[i__4] * x[i__5].r, q__1.i = r__[i__4] * x[i__5]
+ .i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+/* L100: */
+ }
+/* L110: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= rowcnd;
+/* L120: */
+ }
+ }
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < slamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ rwork[1] = rpvgrw;
+ return 0;
+
+/* End of CGESVX */
+
+} /* cgesvx_ */
diff --git a/SRC/cgesvxx.c b/SRC/cgesvxx.c
new file mode 100644
index 0000000..3fc32de
--- /dev/null
+++ b/SRC/cgesvxx.c
@@ -0,0 +1,714 @@
+/* cgesvxx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cgesvxx_(char *fact, char *trans, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *
+ ipiv, char *equed, real *r__, real *c__, complex *b, integer *ldb,
+ complex *x, integer *ldx, real *rcond, real *rpvgrw, real *berr,
+ integer *n_err_bnds__, real *err_bnds_norm__, real *err_bnds_comp__,
+ integer *nparams, real *params, complex *work, real *rwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j;
+ extern doublereal cla_rpvgrw__(integer *, integer *, complex *, integer *,
+ complex *, integer *);
+ real amax;
+ extern logical lsame_(char *, char *);
+ real rcmin, rcmax;
+ logical equil;
+ extern /* Subroutine */ int claqge_(integer *, integer *, complex *,
+ integer *, real *, real *, real *, real *, real *, char *)
+ ;
+ real colcnd;
+ extern doublereal slamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int cgetrf_(integer *, integer *, complex *,
+ integer *, integer *, integer *), clacpy_(char *, integer *,
+ integer *, complex *, integer *, complex *, integer *),
+ xerbla_(char *, integer *);
+ real bignum;
+ integer infequ;
+ logical colequ;
+ extern /* Subroutine */ int cgetrs_(char *, integer *, integer *, complex
+ *, integer *, integer *, complex *, integer *, integer *);
+ real rowcnd;
+ logical notran;
+ real smlnum;
+ logical rowequ;
+ extern /* Subroutine */ int clascl2_(integer *, integer *, real *,
+ complex *, integer *), cgeequb_(integer *, integer *, complex *,
+ integer *, real *, real *, real *, real *, real *, integer *),
+ cgerfsx_(char *, char *, integer *, integer *, complex *, integer
+ *, complex *, integer *, integer *, real *, real *, complex *,
+ integer *, complex *, integer *, real *, real *, integer *, real *
+, real *, integer *, real *, complex *, real *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGESVXX uses the LU factorization to compute the solution to a */
+/* complex system of linear equations A * X = B, where A is an */
+/* N-by-N matrix and X and B are N-by-NRHS matrices. */
+
+/* If requested, both normwise and maximum componentwise error bounds */
+/* are returned. CGESVXX will return a solution with a tiny */
+/* guaranteed error (O(eps) where eps is the working machine */
+/* precision) unless the matrix is very ill-conditioned, in which */
+/* case a warning is returned. Relevant condition numbers also are */
+/* calculated and returned. */
+
+/* CGESVXX accepts user-provided factorizations and equilibration */
+/* factors; see the definitions of the FACT and EQUED options. */
+/* Solving with refinement and using a factorization from a previous */
+/* CGESVXX call will also produce a solution with either O(eps) */
+/* errors or warnings, but we cannot make that claim for general */
+/* user-provided factorizations and equilibration factors if they */
+/* differ from what CGESVXX would itself produce. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+
+/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */
+/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */
+/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */
+
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */
+/* or diag(C)*B (if TRANS = 'T' or 'C'). */
+
+/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */
+/* the matrix A (after equilibration if FACT = 'E') as */
+
+/* A = P * L * U, */
+
+/* where P is a permutation matrix, L is a unit lower triangular */
+/* matrix, and U is upper triangular. */
+
+/* 3. If some U(i,i)=0, so that U is exactly singular, then the */
+/* routine returns with INFO = i. Otherwise, the factored form of A */
+/* is used to estimate the condition number of the matrix A (see */
+/* argument RCOND). If the reciprocal of the condition number is less */
+/* than machine precision, the routine still goes on to solve for X */
+/* and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */
+/* the routine will use iterative refinement to try to get a small */
+/* error and error bounds. Refinement calculates the residual to at */
+/* least twice the working precision. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */
+/* that it solves the original system before equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF and IPIV contain the factored form of A. */
+/* If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by R and C. */
+/* A, AF, and IPIV are not modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is */
+/* not 'N', then A must have been equilibrated by the scaling */
+/* factors in R and/or C. A is not modified if FACT = 'F' or */
+/* 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
+
+/* On exit, if EQUED .ne. 'N', A is scaled as follows: */
+/* EQUED = 'R': A := diag(R) * A */
+/* EQUED = 'C': A := A * diag(C) */
+/* EQUED = 'B': A := diag(R) * A * diag(C). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) COMPLEX array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the factors L and U from the factorization */
+/* A = P*L*U as computed by CGETRF. If EQUED .ne. 'N', then */
+/* AF is the factored form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the equilibrated matrix A (see the description of A for */
+/* the form of the equilibrated matrix). */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* as computed by CGETRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the equilibrated matrix A. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* R (input or output) REAL array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+/* If R is output, each element of R is a power of the radix. */
+/* If R is input, each element of R should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* C (input or output) REAL array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+/* If C is output, each element of C is a power of the radix. */
+/* If C is input, each element of C should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */
+/* diag(R)*B; */
+/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */
+/* overwritten by diag(C)*B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX array, dimension (LDX,NRHS) */
+/* If INFO = 0, the N-by-NRHS solution matrix X to the original */
+/* system of equations. Note that A and B are modified on exit */
+/* if EQUED .ne. 'N', and the solution to the equilibrated system is */
+/* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or */
+/* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* RPVGRW (output) REAL */
+/* Reciprocal pivot growth. On exit, this contains the reciprocal */
+/* pivot growth factor norm(A)/norm(U). The "max absolute element" */
+/* norm is used. If this is much less than 1, then the stability of */
+/* the LU factorization of the (equilibrated) matrix A could be poor. */
+/* This also means that the solution X, estimated condition numbers, */
+/* and error bounds could be unreliable. If factorization fails with */
+/* 0<INFO<=N, then this contains the reciprocal pivot growth factor */
+/* for the leading INFO columns of A. In CGESVX, this quantity is */
+/* returned in WORK(1). */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) REAL array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ notran = lsame_(trans, "N");
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rowequ = FALSE_;
+ colequ = FALSE_;
+ } else {
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+
+/* Default is failure. If an input parameter is wrong or */
+/* factorization fails, make everything look horrible. Only the */
+/* pivot growth is set here, the rest is initialized in CGERFSX. */
+
+ *rpvgrw = 0.f;
+
+/* Test the input parameters. PARAMS is not tested until CGERFSX. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (lsame_(fact, "F") && ! (rowequ || colequ
+ || lsame_(equed, "N"))) {
+ *info = -10;
+ } else {
+ if (rowequ) {
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = r__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = r__[j];
+ rcmax = dmax(r__1,r__2);
+/* L10: */
+ }
+ if (rcmin <= 0.f) {
+ *info = -11;
+ } else if (*n > 0) {
+ rowcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ } else {
+ rowcnd = 1.f;
+ }
+ }
+ if (colequ && *info == 0) {
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = c__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = c__[j];
+ rcmax = dmax(r__1,r__2);
+/* L20: */
+ }
+ if (rcmin <= 0.f) {
+ *info = -12;
+ } else if (*n > 0) {
+ colcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ } else {
+ colcnd = 1.f;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -14;
+ } else if (*ldx < max(1,*n)) {
+ *info = -16;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGESVXX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ cgeequb_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &colcnd,
+ &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ claqge_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &
+ colcnd, &amax, equed);
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+
+/* If the scaling factors are not applied, set them to 1.0. */
+
+ if (! rowequ) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ r__[j] = 1.f;
+ }
+ }
+ if (! colequ) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 1.f;
+ }
+ }
+ }
+
+/* Scale the right-hand side. */
+
+ if (notran) {
+ if (rowequ) {
+ clascl2_(n, nrhs, &r__[1], &b[b_offset], ldb);
+ }
+ } else {
+ if (colequ) {
+ clascl2_(n, nrhs, &c__[1], &b[b_offset], ldb);
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of A. */
+
+ clacpy_("Full", n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ cgetrf_(n, n, &af[af_offset], ldaf, &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Pivot in column INFO is exactly 0 */
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ *rpvgrw = cla_rpvgrw__(n, info, &a[a_offset], lda, &af[af_offset],
+ ldaf);
+ return 0;
+ }
+ }
+
+/* Compute the reciprocal pivot growth factor RPVGRW. */
+
+ *rpvgrw = cla_rpvgrw__(n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+
+/* Compute the solution matrix X. */
+
+ clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ cgetrs_(trans, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ cgerfsx_(trans, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &
+ ipiv[1], &r__[1], &c__[1], &b[b_offset], ldb, &x[x_offset], ldx,
+ rcond, &berr[1], n_err_bnds__, &err_bnds_norm__[
+ err_bnds_norm_offset], &err_bnds_comp__[err_bnds_comp_offset],
+ nparams, ¶ms[1], &work[1], &rwork[1], info);
+
+/* Scale solutions. */
+
+ if (colequ && notran) {
+ clascl2_(n, nrhs, &c__[1], &x[x_offset], ldx);
+ } else if (rowequ && ! notran) {
+ clascl2_(n, nrhs, &r__[1], &x[x_offset], ldx);
+ }
+
+ return 0;
+
+/* End of CGESVXX */
+
+} /* cgesvxx_ */
diff --git a/SRC/cgetc2.c b/SRC/cgetc2.c
new file mode 100644
index 0000000..bf2921e
--- /dev/null
+++ b/SRC/cgetc2.c
@@ -0,0 +1,208 @@
+/* cgetc2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static complex c_b10 = {-1.f,-0.f};
+
+/* Subroutine */ int cgetc2_(integer *n, complex *a, integer *lda, integer *
+ ipiv, integer *jpiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1;
+ complex q__1;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, ip, jp;
+ real eps;
+ integer ipv, jpv;
+ real smin, xmax;
+ extern /* Subroutine */ int cgeru_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *),
+ cswap_(integer *, complex *, integer *, complex *, integer *),
+ slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ real bignum, smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGETC2 computes an LU factorization, using complete pivoting, of the */
+/* n-by-n matrix A. The factorization has the form A = P * L * U * Q, */
+/* where P and Q are permutation matrices, L is lower triangular with */
+/* unit diagonal elements and U is upper triangular. */
+
+/* This is a level 1 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA, N) */
+/* On entry, the n-by-n matrix to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U*Q; the unit diagonal elements of L are not stored. */
+/* If U(k, k) appears to be less than SMIN, U(k, k) is given the */
+/* value of SMIN, giving a nonsingular perturbed system. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1, N). */
+
+/* IPIV (output) INTEGER array, dimension (N). */
+/* The pivot indices; for 1 <= i <= N, row i of the */
+/* matrix has been interchanged with row IPIV(i). */
+
+/* JPIV (output) INTEGER array, dimension (N). */
+/* The pivot indices; for 1 <= j <= N, column j of the */
+/* matrix has been interchanged with column JPIV(j). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* > 0: if INFO = k, U(k, k) is likely to produce overflow if */
+/* one tries to solve for x in Ax = b. So U is perturbed */
+/* to avoid the overflow. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Set constants to control overflow */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --jpiv;
+
+ /* Function Body */
+ *info = 0;
+ eps = slamch_("P");
+ smlnum = slamch_("S") / eps;
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Factorize A using complete pivoting. */
+/* Set pivots less than SMIN to SMIN */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Find max element in matrix A */
+
+ xmax = 0.f;
+ i__2 = *n;
+ for (ip = i__; ip <= i__2; ++ip) {
+ i__3 = *n;
+ for (jp = i__; jp <= i__3; ++jp) {
+ if (c_abs(&a[ip + jp * a_dim1]) >= xmax) {
+ xmax = c_abs(&a[ip + jp * a_dim1]);
+ ipv = ip;
+ jpv = jp;
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+ if (i__ == 1) {
+/* Computing MAX */
+ r__1 = eps * xmax;
+ smin = dmax(r__1,smlnum);
+ }
+
+/* Swap rows */
+
+ if (ipv != i__) {
+ cswap_(n, &a[ipv + a_dim1], lda, &a[i__ + a_dim1], lda);
+ }
+ ipiv[i__] = ipv;
+
+/* Swap columns */
+
+ if (jpv != i__) {
+ cswap_(n, &a[jpv * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
+ c__1);
+ }
+ jpiv[i__] = jpv;
+
+/* Check for singularity */
+
+ if (c_abs(&a[i__ + i__ * a_dim1]) < smin) {
+ *info = i__;
+ i__2 = i__ + i__ * a_dim1;
+ q__1.r = smin, q__1.i = 0.f;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ c_div(&q__1, &a[j + i__ * a_dim1], &a[i__ + i__ * a_dim1]);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L30: */
+ }
+ i__2 = *n - i__;
+ i__3 = *n - i__;
+ cgeru_(&i__2, &i__3, &c_b10, &a[i__ + 1 + i__ * a_dim1], &c__1, &a[
+ i__ + (i__ + 1) * a_dim1], lda, &a[i__ + 1 + (i__ + 1) *
+ a_dim1], lda);
+/* L40: */
+ }
+
+ if (c_abs(&a[*n + *n * a_dim1]) < smin) {
+ *info = *n;
+ i__1 = *n + *n * a_dim1;
+ q__1.r = smin, q__1.i = 0.f;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ }
+ return 0;
+
+/* End of CGETC2 */
+
+} /* cgetc2_ */
diff --git a/SRC/cgetf2.c b/SRC/cgetf2.c
new file mode 100644
index 0000000..e41b695
--- /dev/null
+++ b/SRC/cgetf2.c
@@ -0,0 +1,202 @@
+/* cgetf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cgetf2_(integer *m, integer *n, complex *a, integer *lda,
+ integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ complex q__1;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, jp;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *), cgeru_(integer *, integer *, complex *, complex *,
+ integer *, complex *, integer *, complex *, integer *);
+ real sfmin;
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGETF2 computes an LU factorization of a general m-by-n matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* The factorization has the form */
+/* A = P * L * U */
+/* where P is a permutation matrix, L is lower triangular with unit */
+/* diagonal elements (lower trapezoidal if m > n), and U is upper */
+/* triangular (upper trapezoidal if m < n). */
+
+/* This is the right-looking Level 2 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the m by n matrix to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, U(k,k) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGETF2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Compute machine safe minimum */
+
+ sfmin = slamch_("S");
+
+ i__1 = min(*m,*n);
+ for (j = 1; j <= i__1; ++j) {
+
+/* Find pivot and test for singularity. */
+
+ i__2 = *m - j + 1;
+ jp = j - 1 + icamax_(&i__2, &a[j + j * a_dim1], &c__1);
+ ipiv[j] = jp;
+ i__2 = jp + j * a_dim1;
+ if (a[i__2].r != 0.f || a[i__2].i != 0.f) {
+
+/* Apply the interchange to columns 1:N. */
+
+ if (jp != j) {
+ cswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda);
+ }
+
+/* Compute elements J+1:M of J-th column. */
+
+ if (j < *m) {
+ if (c_abs(&a[j + j * a_dim1]) >= sfmin) {
+ i__2 = *m - j;
+ c_div(&q__1, &c_b1, &a[j + j * a_dim1]);
+ cscal_(&i__2, &q__1, &a[j + 1 + j * a_dim1], &c__1);
+ } else {
+ i__2 = *m - j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ + j * a_dim1;
+ c_div(&q__1, &a[j + i__ + j * a_dim1], &a[j + j *
+ a_dim1]);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L20: */
+ }
+ }
+ }
+
+ } else if (*info == 0) {
+
+ *info = j;
+ }
+
+ if (j < min(*m,*n)) {
+
+/* Update trailing submatrix. */
+
+ i__2 = *m - j;
+ i__3 = *n - j;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__2, &i__3, &q__1, &a[j + 1 + j * a_dim1], &c__1, &a[j +
+ (j + 1) * a_dim1], lda, &a[j + 1 + (j + 1) * a_dim1], lda)
+ ;
+ }
+/* L10: */
+ }
+ return 0;
+
+/* End of CGETF2 */
+
+} /* cgetf2_ */
diff --git a/SRC/cgetrf.c b/SRC/cgetrf.c
new file mode 100644
index 0000000..0798e8f
--- /dev/null
+++ b/SRC/cgetrf.c
@@ -0,0 +1,220 @@
+/* cgetrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cgetrf_(integer *m, integer *n, complex *a, integer *lda,
+ integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j, jb, nb;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ integer iinfo;
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *), cgetf2_(integer *,
+ integer *, complex *, integer *, integer *, integer *), xerbla_(
+ char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int claswp_(integer *, complex *, integer *,
+ integer *, integer *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGETRF computes an LU factorization of a general M-by-N matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* The factorization has the form */
+/* A = P * L * U */
+/* where P is a permutation matrix, L is lower triangular with unit */
+/* diagonal elements (lower trapezoidal if m > n), and U is upper */
+/* triangular (upper trapezoidal if m < n). */
+
+/* This is the right-looking Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGETRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "CGETRF", " ", m, n, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= min(*m,*n)) {
+
+/* Use unblocked code. */
+
+ cgetf2_(m, n, &a[a_offset], lda, &ipiv[1], info);
+ } else {
+
+/* Use blocked code. */
+
+ i__1 = min(*m,*n);
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = min(*m,*n) - j + 1;
+ jb = min(i__3,nb);
+
+/* Factor diagonal and subdiagonal blocks and test for exact */
+/* singularity. */
+
+ i__3 = *m - j + 1;
+ cgetf2_(&i__3, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo);
+
+/* Adjust INFO and the pivot indices. */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo + j - 1;
+ }
+/* Computing MIN */
+ i__4 = *m, i__5 = j + jb - 1;
+ i__3 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__3; ++i__) {
+ ipiv[i__] = j - 1 + ipiv[i__];
+/* L10: */
+ }
+
+/* Apply interchanges to columns 1:J-1. */
+
+ i__3 = j - 1;
+ i__4 = j + jb - 1;
+ claswp_(&i__3, &a[a_offset], lda, &j, &i__4, &ipiv[1], &c__1);
+
+ if (j + jb <= *n) {
+
+/* Apply interchanges to columns J+JB:N. */
+
+ i__3 = *n - j - jb + 1;
+ i__4 = j + jb - 1;
+ claswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, &
+ ipiv[1], &c__1);
+
+/* Compute block row of U. */
+
+ i__3 = *n - j - jb + 1;
+ ctrsm_("Left", "Lower", "No transpose", "Unit", &jb, &i__3, &
+ c_b1, &a[j + j * a_dim1], lda, &a[j + (j + jb) *
+ a_dim1], lda);
+ if (j + jb <= *m) {
+
+/* Update trailing submatrix. */
+
+ i__3 = *m - j - jb + 1;
+ i__4 = *n - j - jb + 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "No transpose", &i__3, &i__4, &jb,
+ &q__1, &a[j + jb + j * a_dim1], lda, &a[j + (j +
+ jb) * a_dim1], lda, &c_b1, &a[j + jb + (j + jb) *
+ a_dim1], lda);
+ }
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+/* End of CGETRF */
+
+} /* cgetrf_ */
diff --git a/SRC/cgetri.c b/SRC/cgetri.c
new file mode 100644
index 0000000..e849bfd
--- /dev/null
+++ b/SRC/cgetri.c
@@ -0,0 +1,271 @@
+/* cgetri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int cgetri_(integer *n, complex *a, integer *lda, integer *
+ ipiv, complex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j, jb, nb, jj, jp, nn, iws;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), cgemv_(char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *, complex *, complex *, integer *);
+ integer nbmin;
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *), ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer ldwork;
+ extern /* Subroutine */ int ctrtri_(char *, char *, integer *, complex *,
+ integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGETRI computes the inverse of a matrix using the LU factorization */
+/* computed by CGETRF. */
+
+/* This method inverts U and then computes inv(A) by solving the system */
+/* inv(A)*L = inv(U) for inv(A). */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the factors L and U from the factorization */
+/* A = P*L*U as computed by CGETRF. */
+/* On exit, if INFO = 0, the inverse of the original matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from CGETRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO=0, then WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* For optimal performance LWORK >= N*NB, where NB is */
+/* the optimal blocksize 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is */
+/* singular and its inverse could not be computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb = ilaenv_(&c__1, "CGETRI", " ", n, &c_n1, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ lquery = *lwork == -1;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*lda < max(1,*n)) {
+ *info = -3;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGETRI", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form inv(U). If INFO > 0 from CTRTRI, then U is singular, */
+/* and the inverse is not computed. */
+
+ ctrtri_("Upper", "Non-unit", n, &a[a_offset], lda, info);
+ if (*info > 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = *n;
+ if (nb > 1 && nb < *n) {
+/* Computing MAX */
+ i__1 = ldwork * nb;
+ iws = max(i__1,1);
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "CGETRI", " ", n, &c_n1, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = *n;
+ }
+
+/* Solve the equation inv(A)*L = inv(U) for inv(A). */
+
+ if (nb < nbmin || nb >= *n) {
+
+/* Use unblocked code. */
+
+ for (j = *n; j >= 1; --j) {
+
+/* Copy current column of L to WORK and replace with zeros. */
+
+ i__1 = *n;
+ for (i__ = j + 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__ + j * a_dim1;
+ work[i__2].r = a[i__3].r, work[i__2].i = a[i__3].i;
+ i__2 = i__ + j * a_dim1;
+ a[i__2].r = 0.f, a[i__2].i = 0.f;
+/* L10: */
+ }
+
+/* Compute current column of inv(A). */
+
+ if (j < *n) {
+ i__1 = *n - j;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", n, &i__1, &q__1, &a[(j + 1) * a_dim1 +
+ 1], lda, &work[j + 1], &c__1, &c_b2, &a[j * a_dim1 +
+ 1], &c__1);
+ }
+/* L20: */
+ }
+ } else {
+
+/* Use blocked code. */
+
+ nn = (*n - 1) / nb * nb + 1;
+ i__1 = -nb;
+ for (j = nn; i__1 < 0 ? j >= 1 : j <= 1; j += i__1) {
+/* Computing MIN */
+ i__2 = nb, i__3 = *n - j + 1;
+ jb = min(i__2,i__3);
+
+/* Copy current block column of L to WORK and replace with */
+/* zeros. */
+
+ i__2 = j + jb - 1;
+ for (jj = j; jj <= i__2; ++jj) {
+ i__3 = *n;
+ for (i__ = jj + 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + (jj - j) * ldwork;
+ i__5 = i__ + jj * a_dim1;
+ work[i__4].r = a[i__5].r, work[i__4].i = a[i__5].i;
+ i__4 = i__ + jj * a_dim1;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Compute current block column of inv(A). */
+
+ if (j + jb <= *n) {
+ i__2 = *n - j - jb + 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "No transpose", n, &jb, &i__2, &q__1, &
+ a[(j + jb) * a_dim1 + 1], lda, &work[j + jb], &ldwork,
+ &c_b2, &a[j * a_dim1 + 1], lda);
+ }
+ ctrsm_("Right", "Lower", "No transpose", "Unit", n, &jb, &c_b2, &
+ work[j], &ldwork, &a[j * a_dim1 + 1], lda);
+/* L50: */
+ }
+ }
+
+/* Apply column interchanges. */
+
+ for (j = *n - 1; j >= 1; --j) {
+ jp = ipiv[j];
+ if (jp != j) {
+ cswap_(n, &a[j * a_dim1 + 1], &c__1, &a[jp * a_dim1 + 1], &c__1);
+ }
+/* L60: */
+ }
+
+ work[1].r = (real) iws, work[1].i = 0.f;
+ return 0;
+
+/* End of CGETRI */
+
+} /* cgetri_ */
diff --git a/SRC/cgetrs.c b/SRC/cgetrs.c
new file mode 100644
index 0000000..e0bcf1f
--- /dev/null
+++ b/SRC/cgetrs.c
@@ -0,0 +1,186 @@
+/* cgetrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cgetrs_(char *trans, integer *n, integer *nrhs, complex *
+ a, integer *lda, integer *ipiv, complex *b, integer *ldb, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *), xerbla_(char *,
+ integer *), claswp_(integer *, complex *, integer *,
+ integer *, integer *, integer *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGETRS solves a system of linear equations */
+/* A * X = B, A**T * X = B, or A**H * X = B */
+/* with a general N-by-N matrix A using the LU factorization computed */
+/* by CGETRF. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The factors L and U from the factorization A = P*L*U */
+/* as computed by CGETRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from CGETRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGETRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (notran) {
+
+/* Solve A * X = B. */
+
+/* Apply row interchanges to the right hand sides. */
+
+ claswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c__1);
+
+/* Solve L*X = B, overwriting B with X. */
+
+ ctrsm_("Left", "Lower", "No transpose", "Unit", n, nrhs, &c_b1, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+/* Solve U*X = B, overwriting B with X. */
+
+ ctrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b1, &
+ a[a_offset], lda, &b[b_offset], ldb);
+ } else {
+
+/* Solve A**T * X = B or A**H * X = B. */
+
+/* Solve U'*X = B, overwriting B with X. */
+
+ ctrsm_("Left", "Upper", trans, "Non-unit", n, nrhs, &c_b1, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+/* Solve L'*X = B, overwriting B with X. */
+
+ ctrsm_("Left", "Lower", trans, "Unit", n, nrhs, &c_b1, &a[a_offset],
+ lda, &b[b_offset], ldb);
+
+/* Apply row interchanges to the solution vectors. */
+
+ claswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c_n1);
+ }
+
+ return 0;
+
+/* End of CGETRS */
+
+} /* cgetrs_ */
diff --git a/SRC/cggbak.c b/SRC/cggbak.c
new file mode 100644
index 0000000..643170b
--- /dev/null
+++ b/SRC/cggbak.c
@@ -0,0 +1,274 @@
+/* cggbak.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cggbak_(char *job, char *side, integer *n, integer *ilo,
+ integer *ihi, real *lscale, real *rscale, integer *m, complex *v,
+ integer *ldv, integer *info)
+{
+ /* System generated locals */
+ integer v_dim1, v_offset, i__1;
+
+ /* Local variables */
+ integer i__, k;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ logical leftv;
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), xerbla_(char *, integer *);
+ logical rightv;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGGBAK forms the right or left eigenvectors of a complex generalized */
+/* eigenvalue problem A*x = lambda*B*x, by backward transformation on */
+/* the computed eigenvectors of the balanced pair of matrices output by */
+/* CGGBAL. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies the type of backward transformation required: */
+/* = 'N': do nothing, return immediately; */
+/* = 'P': do backward transformation for permutation only; */
+/* = 'S': do backward transformation for scaling only; */
+/* = 'B': do backward transformations for both permutation and */
+/* scaling. */
+/* JOB must be the same as the argument JOB supplied to CGGBAL. */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'R': V contains right eigenvectors; */
+/* = 'L': V contains left eigenvectors. */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrix V. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* The integers ILO and IHI determined by CGGBAL. */
+/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
+
+/* LSCALE (input) REAL array, dimension (N) */
+/* Details of the permutations and/or scaling factors applied */
+/* to the left side of A and B, as returned by CGGBAL. */
+
+/* RSCALE (input) REAL array, dimension (N) */
+/* Details of the permutations and/or scaling factors applied */
+/* to the right side of A and B, as returned by CGGBAL. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix V. M >= 0. */
+
+/* V (input/output) COMPLEX array, dimension (LDV,M) */
+/* On entry, the matrix of right or left eigenvectors to be */
+/* transformed, as returned by CTGEVC. */
+/* On exit, V is overwritten by the transformed eigenvectors. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the matrix V. LDV >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* See R.C. Ward, Balancing the generalized eigenvalue problem, */
+/* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ --lscale;
+ --rscale;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+
+ /* Function Body */
+ rightv = lsame_(side, "R");
+ leftv = lsame_(side, "L");
+
+ *info = 0;
+ if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
+ && ! lsame_(job, "B")) {
+ *info = -1;
+ } else if (! rightv && ! leftv) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ilo < 1) {
+ *info = -4;
+ } else if (*n == 0 && *ihi == 0 && *ilo != 1) {
+ *info = -4;
+ } else if (*n > 0 && (*ihi < *ilo || *ihi > max(1,*n))) {
+ *info = -5;
+ } else if (*n == 0 && *ilo == 1 && *ihi != 0) {
+ *info = -5;
+ } else if (*m < 0) {
+ *info = -8;
+ } else if (*ldv < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGGBAK", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+ if (*m == 0) {
+ return 0;
+ }
+ if (lsame_(job, "N")) {
+ return 0;
+ }
+
+ if (*ilo == *ihi) {
+ goto L30;
+ }
+
+/* Backward balance */
+
+ if (lsame_(job, "S") || lsame_(job, "B")) {
+
+/* Backward transformation on right eigenvectors */
+
+ if (rightv) {
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ csscal_(m, &rscale[i__], &v[i__ + v_dim1], ldv);
+/* L10: */
+ }
+ }
+
+/* Backward transformation on left eigenvectors */
+
+ if (leftv) {
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ csscal_(m, &lscale[i__], &v[i__ + v_dim1], ldv);
+/* L20: */
+ }
+ }
+ }
+
+/* Backward permutation */
+
+L30:
+ if (lsame_(job, "P") || lsame_(job, "B")) {
+
+/* Backward permutation on right eigenvectors */
+
+ if (rightv) {
+ if (*ilo == 1) {
+ goto L50;
+ }
+ for (i__ = *ilo - 1; i__ >= 1; --i__) {
+ k = rscale[i__];
+ if (k == i__) {
+ goto L40;
+ }
+ cswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L40:
+ ;
+ }
+
+L50:
+ if (*ihi == *n) {
+ goto L70;
+ }
+ i__1 = *n;
+ for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
+ k = rscale[i__];
+ if (k == i__) {
+ goto L60;
+ }
+ cswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L60:
+ ;
+ }
+ }
+
+/* Backward permutation on left eigenvectors */
+
+L70:
+ if (leftv) {
+ if (*ilo == 1) {
+ goto L90;
+ }
+ for (i__ = *ilo - 1; i__ >= 1; --i__) {
+ k = lscale[i__];
+ if (k == i__) {
+ goto L80;
+ }
+ cswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L80:
+ ;
+ }
+
+L90:
+ if (*ihi == *n) {
+ goto L110;
+ }
+ i__1 = *n;
+ for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
+ k = lscale[i__];
+ if (k == i__) {
+ goto L100;
+ }
+ cswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L100:
+ ;
+ }
+ }
+ }
+
+L110:
+
+ return 0;
+
+/* End of CGGBAK */
+
+} /* cggbak_ */
diff --git a/SRC/cggbal.c b/SRC/cggbal.c
new file mode 100644
index 0000000..c12f5ea
--- /dev/null
+++ b/SRC/cggbal.c
@@ -0,0 +1,652 @@
+/* cggbal.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b36 = 10.f;
+static real c_b72 = .5f;
+
+/* Subroutine */ int cggbal_(char *job, integer *n, complex *a, integer *lda,
+ complex *b, integer *ldb, integer *ilo, integer *ihi, real *lscale,
+ real *rscale, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double r_lg10(real *), r_imag(complex *), c_abs(complex *), r_sign(real *,
+ real *), pow_ri(real *, integer *);
+
+ /* Local variables */
+ integer i__, j, k, l, m;
+ real t;
+ integer jc;
+ real ta, tb, tc;
+ integer ir;
+ real ew;
+ integer it, nr, ip1, jp1, lm1;
+ real cab, rab, ewc, cor, sum;
+ integer nrp2, icab, lcab;
+ real beta, coef;
+ integer irab, lrab;
+ real basl, cmax;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ real coef2, coef5, gamma, alpha;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real sfmin;
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ real sfmax;
+ integer iflow, kount;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *);
+ real pgamma;
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), xerbla_(char *, integer *);
+ integer lsfmin, lsfmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGGBAL balances a pair of general complex matrices (A,B). This */
+/* involves, first, permuting A and B by similarity transformations to */
+/* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N */
+/* elements on the diagonal; and second, applying a diagonal similarity */
+/* transformation to rows and columns ILO to IHI to make the rows */
+/* and columns as close in norm as possible. Both steps are optional. */
+
+/* Balancing may reduce the 1-norm of the matrices, and improve the */
+/* accuracy of the computed eigenvalues and/or eigenvectors in the */
+/* generalized eigenvalue problem A*x = lambda*B*x. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies the operations to be performed on A and B: */
+/* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0 */
+/* and RSCALE(I) = 1.0 for i=1,...,N; */
+/* = 'P': permute only; */
+/* = 'S': scale only; */
+/* = 'B': both permute and scale. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the input matrix A. */
+/* On exit, A is overwritten by the balanced matrix. */
+/* If JOB = 'N', A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,N) */
+/* On entry, the input matrix B. */
+/* On exit, B is overwritten by the balanced matrix. */
+/* If JOB = 'N', B is not referenced. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* ILO (output) INTEGER */
+/* IHI (output) INTEGER */
+/* ILO and IHI are set to integers such that on exit */
+/* A(i,j) = 0 and B(i,j) = 0 if i > j and */
+/* j = 1,...,ILO-1 or i = IHI+1,...,N. */
+/* If JOB = 'N' or 'S', ILO = 1 and IHI = N. */
+
+/* LSCALE (output) REAL array, dimension (N) */
+/* Details of the permutations and scaling factors applied */
+/* to the left side of A and B. If P(j) is the index of the */
+/* row interchanged with row j, and D(j) is the scaling factor */
+/* applied to row j, then */
+/* LSCALE(j) = P(j) for J = 1,...,ILO-1 */
+/* = D(j) for J = ILO,...,IHI */
+/* = P(j) for J = IHI+1,...,N. */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* RSCALE (output) REAL array, dimension (N) */
+/* Details of the permutations and scaling factors applied */
+/* to the right side of A and B. If P(j) is the index of the */
+/* column interchanged with column j, and D(j) is the scaling */
+/* factor applied to column j, then */
+/* RSCALE(j) = P(j) for J = 1,...,ILO-1 */
+/* = D(j) for J = ILO,...,IHI */
+/* = P(j) for J = IHI+1,...,N. */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* WORK (workspace) REAL array, dimension (lwork) */
+/* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and */
+/* at least 1 when JOB = 'N' or 'P'. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* See R.C. WARD, Balancing the generalized eigenvalue problem, */
+/* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --lscale;
+ --rscale;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
+ && ! lsame_(job, "B")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGGBAL", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *ilo = 1;
+ *ihi = *n;
+ return 0;
+ }
+
+ if (*n == 1) {
+ *ilo = 1;
+ *ihi = *n;
+ lscale[1] = 1.f;
+ rscale[1] = 1.f;
+ return 0;
+ }
+
+ if (lsame_(job, "N")) {
+ *ilo = 1;
+ *ihi = *n;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ lscale[i__] = 1.f;
+ rscale[i__] = 1.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+ k = 1;
+ l = *n;
+ if (lsame_(job, "S")) {
+ goto L190;
+ }
+
+ goto L30;
+
+/* Permute the matrices A and B to isolate the eigenvalues. */
+
+/* Find row with one nonzero in columns 1 through L */
+
+L20:
+ l = lm1;
+ if (l != 1) {
+ goto L30;
+ }
+
+ rscale[1] = 1.f;
+ lscale[1] = 1.f;
+ goto L190;
+
+L30:
+ lm1 = l - 1;
+ for (i__ = l; i__ >= 1; --i__) {
+ i__1 = lm1;
+ for (j = 1; j <= i__1; ++j) {
+ jp1 = j + 1;
+ i__2 = i__ + j * a_dim1;
+ i__3 = i__ + j * b_dim1;
+ if (a[i__2].r != 0.f || a[i__2].i != 0.f || (b[i__3].r != 0.f ||
+ b[i__3].i != 0.f)) {
+ goto L50;
+ }
+/* L40: */
+ }
+ j = l;
+ goto L70;
+
+L50:
+ i__1 = l;
+ for (j = jp1; j <= i__1; ++j) {
+ i__2 = i__ + j * a_dim1;
+ i__3 = i__ + j * b_dim1;
+ if (a[i__2].r != 0.f || a[i__2].i != 0.f || (b[i__3].r != 0.f ||
+ b[i__3].i != 0.f)) {
+ goto L80;
+ }
+/* L60: */
+ }
+ j = jp1 - 1;
+
+L70:
+ m = l;
+ iflow = 1;
+ goto L160;
+L80:
+ ;
+ }
+ goto L100;
+
+/* Find column with one nonzero in rows K through N */
+
+L90:
+ ++k;
+
+L100:
+ i__1 = l;
+ for (j = k; j <= i__1; ++j) {
+ i__2 = lm1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ ip1 = i__ + 1;
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * b_dim1;
+ if (a[i__3].r != 0.f || a[i__3].i != 0.f || (b[i__4].r != 0.f ||
+ b[i__4].i != 0.f)) {
+ goto L120;
+ }
+/* L110: */
+ }
+ i__ = l;
+ goto L140;
+L120:
+ i__2 = l;
+ for (i__ = ip1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * b_dim1;
+ if (a[i__3].r != 0.f || a[i__3].i != 0.f || (b[i__4].r != 0.f ||
+ b[i__4].i != 0.f)) {
+ goto L150;
+ }
+/* L130: */
+ }
+ i__ = ip1 - 1;
+L140:
+ m = k;
+ iflow = 2;
+ goto L160;
+L150:
+ ;
+ }
+ goto L190;
+
+/* Permute rows M and I */
+
+L160:
+ lscale[m] = (real) i__;
+ if (i__ == m) {
+ goto L170;
+ }
+ i__1 = *n - k + 1;
+ cswap_(&i__1, &a[i__ + k * a_dim1], lda, &a[m + k * a_dim1], lda);
+ i__1 = *n - k + 1;
+ cswap_(&i__1, &b[i__ + k * b_dim1], ldb, &b[m + k * b_dim1], ldb);
+
+/* Permute columns M and J */
+
+L170:
+ rscale[m] = (real) j;
+ if (j == m) {
+ goto L180;
+ }
+ cswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
+ cswap_(&l, &b[j * b_dim1 + 1], &c__1, &b[m * b_dim1 + 1], &c__1);
+
+L180:
+ switch (iflow) {
+ case 1: goto L20;
+ case 2: goto L90;
+ }
+
+L190:
+ *ilo = k;
+ *ihi = l;
+
+ if (lsame_(job, "P")) {
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ lscale[i__] = 1.f;
+ rscale[i__] = 1.f;
+/* L195: */
+ }
+ return 0;
+ }
+
+ if (*ilo == *ihi) {
+ return 0;
+ }
+
+/* Balance the submatrix in rows ILO to IHI. */
+
+ nr = *ihi - *ilo + 1;
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ rscale[i__] = 0.f;
+ lscale[i__] = 0.f;
+
+ work[i__] = 0.f;
+ work[i__ + *n] = 0.f;
+ work[i__ + (*n << 1)] = 0.f;
+ work[i__ + *n * 3] = 0.f;
+ work[i__ + (*n << 2)] = 0.f;
+ work[i__ + *n * 5] = 0.f;
+/* L200: */
+ }
+
+/* Compute right side vector in resulting linear equations */
+
+ basl = r_lg10(&c_b36);
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ i__2 = *ihi;
+ for (j = *ilo; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ if (a[i__3].r == 0.f && a[i__3].i == 0.f) {
+ ta = 0.f;
+ goto L210;
+ }
+ i__3 = i__ + j * a_dim1;
+ r__3 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[i__ + j
+ * a_dim1]), dabs(r__2));
+ ta = r_lg10(&r__3) / basl;
+
+L210:
+ i__3 = i__ + j * b_dim1;
+ if (b[i__3].r == 0.f && b[i__3].i == 0.f) {
+ tb = 0.f;
+ goto L220;
+ }
+ i__3 = i__ + j * b_dim1;
+ r__3 = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[i__ + j
+ * b_dim1]), dabs(r__2));
+ tb = r_lg10(&r__3) / basl;
+
+L220:
+ work[i__ + (*n << 2)] = work[i__ + (*n << 2)] - ta - tb;
+ work[j + *n * 5] = work[j + *n * 5] - ta - tb;
+/* L230: */
+ }
+/* L240: */
+ }
+
+ coef = 1.f / (real) (nr << 1);
+ coef2 = coef * coef;
+ coef5 = coef2 * .5f;
+ nrp2 = nr + 2;
+ beta = 0.f;
+ it = 1;
+
+/* Start generalized conjugate gradient iteration */
+
+L250:
+
+ gamma = sdot_(&nr, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + (*n << 2)]
+, &c__1) + sdot_(&nr, &work[*ilo + *n * 5], &c__1, &work[*ilo + *
+ n * 5], &c__1);
+
+ ew = 0.f;
+ ewc = 0.f;
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ ew += work[i__ + (*n << 2)];
+ ewc += work[i__ + *n * 5];
+/* L260: */
+ }
+
+/* Computing 2nd power */
+ r__1 = ew;
+/* Computing 2nd power */
+ r__2 = ewc;
+/* Computing 2nd power */
+ r__3 = ew - ewc;
+ gamma = coef * gamma - coef2 * (r__1 * r__1 + r__2 * r__2) - coef5 * (
+ r__3 * r__3);
+ if (gamma == 0.f) {
+ goto L350;
+ }
+ if (it != 1) {
+ beta = gamma / pgamma;
+ }
+ t = coef5 * (ewc - ew * 3.f);
+ tc = coef5 * (ew - ewc * 3.f);
+
+ sscal_(&nr, &beta, &work[*ilo], &c__1);
+ sscal_(&nr, &beta, &work[*ilo + *n], &c__1);
+
+ saxpy_(&nr, &coef, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + *n], &
+ c__1);
+ saxpy_(&nr, &coef, &work[*ilo + *n * 5], &c__1, &work[*ilo], &c__1);
+
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ work[i__] += tc;
+ work[i__ + *n] += t;
+/* L270: */
+ }
+
+/* Apply matrix to vector */
+
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ kount = 0;
+ sum = 0.f;
+ i__2 = *ihi;
+ for (j = *ilo; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ if (a[i__3].r == 0.f && a[i__3].i == 0.f) {
+ goto L280;
+ }
+ ++kount;
+ sum += work[j];
+L280:
+ i__3 = i__ + j * b_dim1;
+ if (b[i__3].r == 0.f && b[i__3].i == 0.f) {
+ goto L290;
+ }
+ ++kount;
+ sum += work[j];
+L290:
+ ;
+ }
+ work[i__ + (*n << 1)] = (real) kount * work[i__ + *n] + sum;
+/* L300: */
+ }
+
+ i__1 = *ihi;
+ for (j = *ilo; j <= i__1; ++j) {
+ kount = 0;
+ sum = 0.f;
+ i__2 = *ihi;
+ for (i__ = *ilo; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ if (a[i__3].r == 0.f && a[i__3].i == 0.f) {
+ goto L310;
+ }
+ ++kount;
+ sum += work[i__ + *n];
+L310:
+ i__3 = i__ + j * b_dim1;
+ if (b[i__3].r == 0.f && b[i__3].i == 0.f) {
+ goto L320;
+ }
+ ++kount;
+ sum += work[i__ + *n];
+L320:
+ ;
+ }
+ work[j + *n * 3] = (real) kount * work[j] + sum;
+/* L330: */
+ }
+
+ sum = sdot_(&nr, &work[*ilo + *n], &c__1, &work[*ilo + (*n << 1)], &c__1)
+ + sdot_(&nr, &work[*ilo], &c__1, &work[*ilo + *n * 3], &c__1);
+ alpha = gamma / sum;
+
+/* Determine correction to current iteration */
+
+ cmax = 0.f;
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ cor = alpha * work[i__ + *n];
+ if (dabs(cor) > cmax) {
+ cmax = dabs(cor);
+ }
+ lscale[i__] += cor;
+ cor = alpha * work[i__];
+ if (dabs(cor) > cmax) {
+ cmax = dabs(cor);
+ }
+ rscale[i__] += cor;
+/* L340: */
+ }
+ if (cmax < .5f) {
+ goto L350;
+ }
+
+ r__1 = -alpha;
+ saxpy_(&nr, &r__1, &work[*ilo + (*n << 1)], &c__1, &work[*ilo + (*n << 2)]
+, &c__1);
+ r__1 = -alpha;
+ saxpy_(&nr, &r__1, &work[*ilo + *n * 3], &c__1, &work[*ilo + *n * 5], &
+ c__1);
+
+ pgamma = gamma;
+ ++it;
+ if (it <= nrp2) {
+ goto L250;
+ }
+
+/* End generalized conjugate gradient iteration */
+
+L350:
+ sfmin = slamch_("S");
+ sfmax = 1.f / sfmin;
+ lsfmin = (integer) (r_lg10(&sfmin) / basl + 1.f);
+ lsfmax = (integer) (r_lg10(&sfmax) / basl);
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ i__2 = *n - *ilo + 1;
+ irab = icamax_(&i__2, &a[i__ + *ilo * a_dim1], lda);
+ rab = c_abs(&a[i__ + (irab + *ilo - 1) * a_dim1]);
+ i__2 = *n - *ilo + 1;
+ irab = icamax_(&i__2, &b[i__ + *ilo * b_dim1], ldb);
+/* Computing MAX */
+ r__1 = rab, r__2 = c_abs(&b[i__ + (irab + *ilo - 1) * b_dim1]);
+ rab = dmax(r__1,r__2);
+ r__1 = rab + sfmin;
+ lrab = (integer) (r_lg10(&r__1) / basl + 1.f);
+ ir = lscale[i__] + r_sign(&c_b72, &lscale[i__]);
+/* Computing MIN */
+ i__2 = max(ir,lsfmin), i__2 = min(i__2,lsfmax), i__3 = lsfmax - lrab;
+ ir = min(i__2,i__3);
+ lscale[i__] = pow_ri(&c_b36, &ir);
+ icab = icamax_(ihi, &a[i__ * a_dim1 + 1], &c__1);
+ cab = c_abs(&a[icab + i__ * a_dim1]);
+ icab = icamax_(ihi, &b[i__ * b_dim1 + 1], &c__1);
+/* Computing MAX */
+ r__1 = cab, r__2 = c_abs(&b[icab + i__ * b_dim1]);
+ cab = dmax(r__1,r__2);
+ r__1 = cab + sfmin;
+ lcab = (integer) (r_lg10(&r__1) / basl + 1.f);
+ jc = rscale[i__] + r_sign(&c_b72, &rscale[i__]);
+/* Computing MIN */
+ i__2 = max(jc,lsfmin), i__2 = min(i__2,lsfmax), i__3 = lsfmax - lcab;
+ jc = min(i__2,i__3);
+ rscale[i__] = pow_ri(&c_b36, &jc);
+/* L360: */
+ }
+
+/* Row scaling of matrices A and B */
+
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ i__2 = *n - *ilo + 1;
+ csscal_(&i__2, &lscale[i__], &a[i__ + *ilo * a_dim1], lda);
+ i__2 = *n - *ilo + 1;
+ csscal_(&i__2, &lscale[i__], &b[i__ + *ilo * b_dim1], ldb);
+/* L370: */
+ }
+
+/* Column scaling of matrices A and B */
+
+ i__1 = *ihi;
+ for (j = *ilo; j <= i__1; ++j) {
+ csscal_(ihi, &rscale[j], &a[j * a_dim1 + 1], &c__1);
+ csscal_(ihi, &rscale[j], &b[j * b_dim1 + 1], &c__1);
+/* L380: */
+ }
+
+ return 0;
+
+/* End of CGGBAL */
+
+} /* cggbal_ */
diff --git a/SRC/cgges.c b/SRC/cgges.c
new file mode 100644
index 0000000..b19048d
--- /dev/null
+++ b/SRC/cgges.c
@@ -0,0 +1,596 @@
+/* cgges.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cgges_(char *jobvsl, char *jobvsr, char *sort, L_fp
+ selctg, integer *n, complex *a, integer *lda, complex *b, integer *
+ ldb, integer *sdim, complex *alpha, complex *beta, complex *vsl,
+ integer *ldvsl, complex *vsr, integer *ldvsr, complex *work, integer *
+ lwork, real *rwork, logical *bwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
+ vsr_dim1, vsr_offset, i__1, i__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real dif[2];
+ integer ihi, ilo;
+ real eps, anrm, bnrm;
+ integer idum[1], ierr, itau, iwrk;
+ real pvsl, pvsr;
+ extern logical lsame_(char *, char *);
+ integer ileft, icols;
+ logical cursl, ilvsl, ilvsr;
+ integer irwrk, irows;
+ extern /* Subroutine */ int cggbak_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, complex *, integer *,
+ integer *), cggbal_(char *, integer *, complex *,
+ integer *, complex *, integer *, integer *, integer *, real *,
+ real *, real *, integer *), slabad_(real *, real *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int cgghrd_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, complex *, integer *, integer *),
+ clascl_(char *, integer *, integer *, real *, real *, integer *,
+ integer *, complex *, integer *, integer *);
+ logical ilascl, ilbscl;
+ extern /* Subroutine */ int cgeqrf_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ real bignum;
+ extern /* Subroutine */ int chgeqz_(char *, char *, char *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ complex *, complex *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, integer *),
+ ctgsen_(integer *, logical *, logical *, logical *, integer *,
+ complex *, integer *, complex *, integer *, complex *, complex *,
+ complex *, integer *, complex *, integer *, integer *, real *,
+ real *, real *, complex *, integer *, integer *, integer *,
+ integer *);
+ integer ijobvl, iright, ijobvr;
+ real anrmto;
+ integer lwkmin;
+ logical lastsl;
+ real bnrmto;
+ extern /* Subroutine */ int cungqr_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *),
+ cunmqr_(char *, char *, integer *, integer *, integer *, complex
+ *, integer *, complex *, complex *, integer *, complex *, integer
+ *, integer *);
+ real smlnum;
+ logical wantst, lquery;
+ integer lwkopt;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+/* .. Function Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGGES computes for a pair of N-by-N complex nonsymmetric matrices */
+/* (A,B), the generalized eigenvalues, the generalized complex Schur */
+/* form (S, T), and optionally left and/or right Schur vectors (VSL */
+/* and VSR). This gives the generalized Schur factorization */
+
+/* (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H ) */
+
+/* where (VSR)**H is the conjugate-transpose of VSR. */
+
+/* Optionally, it also orders the eigenvalues so that a selected cluster */
+/* of eigenvalues appears in the leading diagonal blocks of the upper */
+/* triangular matrix S and the upper triangular matrix T. The leading */
+/* columns of VSL and VSR then form an unitary basis for the */
+/* corresponding left and right eigenspaces (deflating subspaces). */
+
+/* (If only the generalized eigenvalues are needed, use the driver */
+/* CGGEV instead, which is faster.) */
+
+/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w */
+/* or a ratio alpha/beta = w, such that A - w*B is singular. It is */
+/* usually represented as the pair (alpha,beta), as there is a */
+/* reasonable interpretation for beta=0, and even for both being zero. */
+
+/* A pair of matrices (S,T) is in generalized complex Schur form if S */
+/* and T are upper triangular and, in addition, the diagonal elements */
+/* of T are non-negative real numbers. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVSL (input) CHARACTER*1 */
+/* = 'N': do not compute the left Schur vectors; */
+/* = 'V': compute the left Schur vectors. */
+
+/* JOBVSR (input) CHARACTER*1 */
+/* = 'N': do not compute the right Schur vectors; */
+/* = 'V': compute the right Schur vectors. */
+
+/* SORT (input) CHARACTER*1 */
+/* Specifies whether or not to order the eigenvalues on the */
+/* diagonal of the generalized Schur form. */
+/* = 'N': Eigenvalues are not ordered; */
+/* = 'S': Eigenvalues are ordered (see SELCTG). */
+
+/* SELCTG (external procedure) LOGICAL FUNCTION of two COMPLEX arguments */
+/* SELCTG must be declared EXTERNAL in the calling subroutine. */
+/* If SORT = 'N', SELCTG is not referenced. */
+/* If SORT = 'S', SELCTG is used to select eigenvalues to sort */
+/* to the top left of the Schur form. */
+/* An eigenvalue ALPHA(j)/BETA(j) is selected if */
+/* SELCTG(ALPHA(j),BETA(j)) is true. */
+
+/* Note that a selected complex eigenvalue may no longer satisfy */
+/* SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since */
+/* ordering may change the value of complex eigenvalues */
+/* (especially if the eigenvalue is ill-conditioned), in this */
+/* case INFO is set to N+2 (See INFO below). */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VSL, and VSR. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA, N) */
+/* On entry, the first of the pair of matrices. */
+/* On exit, A has been overwritten by its generalized Schur */
+/* form S. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX array, dimension (LDB, N) */
+/* On entry, the second of the pair of matrices. */
+/* On exit, B has been overwritten by its generalized Schur */
+/* form T. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* SDIM (output) INTEGER */
+/* If SORT = 'N', SDIM = 0. */
+/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */
+/* for which SELCTG is true. */
+
+/* ALPHA (output) COMPLEX array, dimension (N) */
+/* BETA (output) COMPLEX array, dimension (N) */
+/* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the */
+/* generalized eigenvalues. ALPHA(j), j=1,...,N and BETA(j), */
+/* j=1,...,N are the diagonals of the complex Schur form (A,B) */
+/* output by CGGES. The BETA(j) will be non-negative real. */
+
+/* Note: the quotients ALPHA(j)/BETA(j) may easily over- or */
+/* underflow, and BETA(j) may even be zero. Thus, the user */
+/* should avoid naively computing the ratio alpha/beta. */
+/* However, ALPHA will be always less than and usually */
+/* comparable with norm(A) in magnitude, and BETA always less */
+/* than and usually comparable with norm(B). */
+
+/* VSL (output) COMPLEX array, dimension (LDVSL,N) */
+/* If JOBVSL = 'V', VSL will contain the left Schur vectors. */
+/* Not referenced if JOBVSL = 'N'. */
+
+/* LDVSL (input) INTEGER */
+/* The leading dimension of the matrix VSL. LDVSL >= 1, and */
+/* if JOBVSL = 'V', LDVSL >= N. */
+
+/* VSR (output) COMPLEX array, dimension (LDVSR,N) */
+/* If JOBVSR = 'V', VSR will contain the right Schur vectors. */
+/* Not referenced if JOBVSR = 'N'. */
+
+/* LDVSR (input) INTEGER */
+/* The leading dimension of the matrix VSR. LDVSR >= 1, and */
+/* if JOBVSR = 'V', LDVSR >= N. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,2*N). */
+/* For good performance, LWORK must generally be larger. */
+
+/* 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. */
+
+/* RWORK (workspace) REAL array, dimension (8*N) */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+/* Not referenced if SORT = 'N'. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* =1,...,N: */
+/* The QZ iteration failed. (A,B) are not in Schur */
+/* form, but ALPHA(j) and BETA(j) should be correct for */
+/* j=INFO+1,...,N. */
+/* > N: =N+1: other than QZ iteration failed in CHGEQZ */
+/* =N+2: after reordering, roundoff changed values of */
+/* some complex eigenvalues so that leading */
+/* eigenvalues in the Generalized Schur form no */
+/* longer satisfy SELCTG=.TRUE. This could also */
+/* be caused due to scaling. */
+/* =N+3: reordering falied in CTGSEN. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alpha;
+ --beta;
+ vsl_dim1 = *ldvsl;
+ vsl_offset = 1 + vsl_dim1;
+ vsl -= vsl_offset;
+ vsr_dim1 = *ldvsr;
+ vsr_offset = 1 + vsr_dim1;
+ vsr -= vsr_offset;
+ --work;
+ --rwork;
+ --bwork;
+
+ /* Function Body */
+ if (lsame_(jobvsl, "N")) {
+ ijobvl = 1;
+ ilvsl = FALSE_;
+ } else if (lsame_(jobvsl, "V")) {
+ ijobvl = 2;
+ ilvsl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvsl = FALSE_;
+ }
+
+ if (lsame_(jobvsr, "N")) {
+ ijobvr = 1;
+ ilvsr = FALSE_;
+ } else if (lsame_(jobvsr, "V")) {
+ ijobvr = 2;
+ ilvsr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvsr = FALSE_;
+ }
+
+ wantst = lsame_(sort, "S");
+
+/* Test the input arguments */
+
+ *info = 0;
+ lquery = *lwork == -1;
+ if (ijobvl <= 0) {
+ *info = -1;
+ } else if (ijobvr <= 0) {
+ *info = -2;
+ } else if (! wantst && ! lsame_(sort, "N")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
+ *info = -14;
+ } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
+ *info = -16;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ if (*info == 0) {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n << 1;
+ lwkmin = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = *n + *n * ilaenv_(&c__1, "CGEQRF", " ", n, &c__1, n,
+ &c__0);
+ lwkopt = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = *n + *n * ilaenv_(&c__1, "CUNMQR", " ", n, &
+ c__1, n, &c_n1);
+ lwkopt = max(i__1,i__2);
+ if (ilvsl) {
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = *n + *n * ilaenv_(&c__1, "CUNGQR", " ", n, &
+ c__1, n, &c_n1);
+ lwkopt = max(i__1,i__2);
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ if (*lwork < lwkmin && ! lquery) {
+ *info = -18;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGGES ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *sdim = 0;
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1.f / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = clange_("M", n, n, &a[a_offset], lda, &rwork[1]);
+ ilascl = FALSE_;
+ if (anrm > 0.f && anrm < smlnum) {
+ anrmto = smlnum;
+ ilascl = TRUE_;
+ } else if (anrm > bignum) {
+ anrmto = bignum;
+ ilascl = TRUE_;
+ }
+
+ if (ilascl) {
+ clascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = clange_("M", n, n, &b[b_offset], ldb, &rwork[1]);
+ ilbscl = FALSE_;
+ if (bnrm > 0.f && bnrm < smlnum) {
+ bnrmto = smlnum;
+ ilbscl = TRUE_;
+ } else if (bnrm > bignum) {
+ bnrmto = bignum;
+ ilbscl = TRUE_;
+ }
+
+ if (ilbscl) {
+ clascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
+ ierr);
+ }
+
+/* Permute the matrix to make it more nearly triangular */
+/* (Real Workspace: need 6*N) */
+
+ ileft = 1;
+ iright = *n + 1;
+ irwrk = iright + *n;
+ cggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &rwork[
+ ileft], &rwork[iright], &rwork[irwrk], &ierr);
+
+/* Reduce B to triangular form (QR decomposition of B) */
+/* (Complex Workspace: need N, prefer N*NB) */
+
+ irows = ihi + 1 - ilo;
+ icols = *n + 1 - ilo;
+ itau = 1;
+ iwrk = itau + irows;
+ i__1 = *lwork + 1 - iwrk;
+ cgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
+ iwrk], &i__1, &ierr);
+
+/* Apply the orthogonal transformation to matrix A */
+/* (Complex Workspace: need N, prefer N*NB) */
+
+ i__1 = *lwork + 1 - iwrk;
+ cunmqr_("L", "C", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
+ work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, &
+ ierr);
+
+/* Initialize VSL */
+/* (Complex Workspace: need N, prefer N*NB) */
+
+ if (ilvsl) {
+ claset_("Full", n, n, &c_b1, &c_b2, &vsl[vsl_offset], ldvsl);
+ if (irows > 1) {
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ clacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[
+ ilo + 1 + ilo * vsl_dim1], ldvsl);
+ }
+ i__1 = *lwork + 1 - iwrk;
+ cungqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, &
+ work[itau], &work[iwrk], &i__1, &ierr);
+ }
+
+/* Initialize VSR */
+
+ if (ilvsr) {
+ claset_("Full", n, n, &c_b1, &c_b2, &vsr[vsr_offset], ldvsr);
+ }
+
+/* Reduce to generalized Hessenberg form */
+/* (Workspace: none needed) */
+
+ cgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &ierr);
+
+ *sdim = 0;
+
+/* Perform QZ algorithm, computing Schur vectors if desired */
+/* (Complex Workspace: need N) */
+/* (Real Workspace: need N) */
+
+ iwrk = itau;
+ i__1 = *lwork + 1 - iwrk;
+ chgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[
+ b_offset], ldb, &alpha[1], &beta[1], &vsl[vsl_offset], ldvsl, &
+ vsr[vsr_offset], ldvsr, &work[iwrk], &i__1, &rwork[irwrk], &ierr);
+ if (ierr != 0) {
+ if (ierr > 0 && ierr <= *n) {
+ *info = ierr;
+ } else if (ierr > *n && ierr <= *n << 1) {
+ *info = ierr - *n;
+ } else {
+ *info = *n + 1;
+ }
+ goto L30;
+ }
+
+/* Sort eigenvalues ALPHA/BETA if desired */
+/* (Workspace: none needed) */
+
+ if (wantst) {
+
+/* Undo scaling on eigenvalues before selecting */
+
+ if (ilascl) {
+ clascl_("G", &c__0, &c__0, &anrm, &anrmto, n, &c__1, &alpha[1], n,
+ &ierr);
+ }
+ if (ilbscl) {
+ clascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, &c__1, &beta[1], n,
+ &ierr);
+ }
+
+/* Select eigenvalues */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ bwork[i__] = (*selctg)(&alpha[i__], &beta[i__]);
+/* L10: */
+ }
+
+ i__1 = *lwork - iwrk + 1;
+ ctgsen_(&c__0, &ilvsl, &ilvsr, &bwork[1], n, &a[a_offset], lda, &b[
+ b_offset], ldb, &alpha[1], &beta[1], &vsl[vsl_offset], ldvsl,
+ &vsr[vsr_offset], ldvsr, sdim, &pvsl, &pvsr, dif, &work[iwrk],
+ &i__1, idum, &c__1, &ierr);
+ if (ierr == 1) {
+ *info = *n + 3;
+ }
+
+ }
+
+/* Apply back-permutation to VSL and VSR */
+/* (Workspace: none needed) */
+
+ if (ilvsl) {
+ cggbak_("P", "L", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &
+ vsl[vsl_offset], ldvsl, &ierr);
+ }
+ if (ilvsr) {
+ cggbak_("P", "R", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &
+ vsr[vsr_offset], ldvsr, &ierr);
+ }
+
+/* Undo scaling */
+
+ if (ilascl) {
+ clascl_("U", &c__0, &c__0, &anrmto, &anrm, n, n, &a[a_offset], lda, &
+ ierr);
+ clascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alpha[1], n, &
+ ierr);
+ }
+
+ if (ilbscl) {
+ clascl_("U", &c__0, &c__0, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, &
+ ierr);
+ clascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
+ ierr);
+ }
+
+ if (wantst) {
+
+/* Check if reordering is correct */
+
+ lastsl = TRUE_;
+ *sdim = 0;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ cursl = (*selctg)(&alpha[i__], &beta[i__]);
+ if (cursl) {
+ ++(*sdim);
+ }
+ if (cursl && ! lastsl) {
+ *info = *n + 2;
+ }
+ lastsl = cursl;
+/* L20: */
+ }
+
+ }
+
+L30:
+
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CGGES */
+
+} /* cgges_ */
diff --git a/SRC/cggesx.c b/SRC/cggesx.c
new file mode 100644
index 0000000..57667e1
--- /dev/null
+++ b/SRC/cggesx.c
@@ -0,0 +1,701 @@
+/* cggesx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp
+ selctg, char *sense, integer *n, complex *a, integer *lda, complex *b,
+ integer *ldb, integer *sdim, complex *alpha, complex *beta, complex *
+ vsl, integer *ldvsl, complex *vsr, integer *ldvsr, real *rconde, real
+ *rcondv, complex *work, integer *lwork, real *rwork, integer *iwork,
+ integer *liwork, logical *bwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
+ vsr_dim1, vsr_offset, i__1, i__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real pl, pr, dif[2];
+ integer ihi, ilo;
+ real eps;
+ integer ijob;
+ real anrm, bnrm;
+ integer ierr, itau, iwrk, lwrk;
+ extern logical lsame_(char *, char *);
+ integer ileft, icols;
+ logical cursl, ilvsl, ilvsr;
+ integer irwrk, irows;
+ extern /* Subroutine */ int cggbak_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, complex *, integer *,
+ integer *), cggbal_(char *, integer *, complex *,
+ integer *, complex *, integer *, integer *, integer *, real *,
+ real *, real *, integer *), slabad_(real *, real *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int cgghrd_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, complex *, integer *, integer *),
+ clascl_(char *, integer *, integer *, real *, real *, integer *,
+ integer *, complex *, integer *, integer *);
+ logical ilascl, ilbscl;
+ extern /* Subroutine */ int cgeqrf_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *), clacpy_(
+ char *, integer *, integer *, complex *, integer *, complex *,
+ integer *), claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), xerbla_(char *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern doublereal slamch_(char *);
+ real bignum;
+ extern /* Subroutine */ int chgeqz_(char *, char *, char *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ complex *, complex *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, integer *),
+ ctgsen_(integer *, logical *, logical *, logical *, integer *,
+ complex *, integer *, complex *, integer *, complex *, complex *,
+ complex *, integer *, complex *, integer *, integer *, real *,
+ real *, real *, complex *, integer *, integer *, integer *,
+ integer *);
+ integer ijobvl, iright, ijobvr;
+ logical wantsb;
+ integer liwmin;
+ logical wantse, lastsl;
+ real anrmto, bnrmto;
+ extern /* Subroutine */ int cungqr_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *);
+ integer minwrk, maxwrk;
+ logical wantsn;
+ real smlnum;
+ extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *);
+ logical wantst, lquery, wantsv;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+/* .. Function Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGGESX computes for a pair of N-by-N complex nonsymmetric matrices */
+/* (A,B), the generalized eigenvalues, the complex Schur form (S,T), */
+/* and, optionally, the left and/or right matrices of Schur vectors (VSL */
+/* and VSR). This gives the generalized Schur factorization */
+
+/* (A,B) = ( (VSL) S (VSR)**H, (VSL) T (VSR)**H ) */
+
+/* where (VSR)**H is the conjugate-transpose of VSR. */
+
+/* Optionally, it also orders the eigenvalues so that a selected cluster */
+/* of eigenvalues appears in the leading diagonal blocks of the upper */
+/* triangular matrix S and the upper triangular matrix T; computes */
+/* a reciprocal condition number for the average of the selected */
+/* eigenvalues (RCONDE); and computes a reciprocal condition number for */
+/* the right and left deflating subspaces corresponding to the selected */
+/* eigenvalues (RCONDV). The leading columns of VSL and VSR then form */
+/* an orthonormal basis for the corresponding left and right eigenspaces */
+/* (deflating subspaces). */
+
+/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w */
+/* or a ratio alpha/beta = w, such that A - w*B is singular. It is */
+/* usually represented as the pair (alpha,beta), as there is a */
+/* reasonable interpretation for beta=0 or for both being zero. */
+
+/* A pair of matrices (S,T) is in generalized complex Schur form if T is */
+/* upper triangular with non-negative diagonal and S is upper */
+/* triangular. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVSL (input) CHARACTER*1 */
+/* = 'N': do not compute the left Schur vectors; */
+/* = 'V': compute the left Schur vectors. */
+
+/* JOBVSR (input) CHARACTER*1 */
+/* = 'N': do not compute the right Schur vectors; */
+/* = 'V': compute the right Schur vectors. */
+
+/* SORT (input) CHARACTER*1 */
+/* Specifies whether or not to order the eigenvalues on the */
+/* diagonal of the generalized Schur form. */
+/* = 'N': Eigenvalues are not ordered; */
+/* = 'S': Eigenvalues are ordered (see SELCTG). */
+
+/* SELCTG (external procedure) LOGICAL FUNCTION of two COMPLEX arguments */
+/* SELCTG must be declared EXTERNAL in the calling subroutine. */
+/* If SORT = 'N', SELCTG is not referenced. */
+/* If SORT = 'S', SELCTG is used to select eigenvalues to sort */
+/* to the top left of the Schur form. */
+/* Note that a selected complex eigenvalue may no longer satisfy */
+/* SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since */
+/* ordering may change the value of complex eigenvalues */
+/* (especially if the eigenvalue is ill-conditioned), in this */
+/* case INFO is set to N+3 see INFO below). */
+
+/* SENSE (input) CHARACTER*1 */
+/* Determines which reciprocal condition numbers are computed. */
+/* = 'N' : None are computed; */
+/* = 'E' : Computed for average of selected eigenvalues only; */
+/* = 'V' : Computed for selected deflating subspaces only; */
+/* = 'B' : Computed for both. */
+/* If SENSE = 'E', 'V', or 'B', SORT must equal 'S'. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VSL, and VSR. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA, N) */
+/* On entry, the first of the pair of matrices. */
+/* On exit, A has been overwritten by its generalized Schur */
+/* form S. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX array, dimension (LDB, N) */
+/* On entry, the second of the pair of matrices. */
+/* On exit, B has been overwritten by its generalized Schur */
+/* form T. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* SDIM (output) INTEGER */
+/* If SORT = 'N', SDIM = 0. */
+/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */
+/* for which SELCTG is true. */
+
+/* ALPHA (output) COMPLEX array, dimension (N) */
+/* BETA (output) COMPLEX array, dimension (N) */
+/* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the */
+/* generalized eigenvalues. ALPHA(j) and BETA(j),j=1,...,N are */
+/* the diagonals of the complex Schur form (S,T). BETA(j) will */
+/* be non-negative real. */
+
+/* Note: the quotients ALPHA(j)/BETA(j) may easily over- or */
+/* underflow, and BETA(j) may even be zero. Thus, the user */
+/* should avoid naively computing the ratio alpha/beta. */
+/* However, ALPHA will be always less than and usually */
+/* comparable with norm(A) in magnitude, and BETA always less */
+/* than and usually comparable with norm(B). */
+
+/* VSL (output) COMPLEX array, dimension (LDVSL,N) */
+/* If JOBVSL = 'V', VSL will contain the left Schur vectors. */
+/* Not referenced if JOBVSL = 'N'. */
+
+/* LDVSL (input) INTEGER */
+/* The leading dimension of the matrix VSL. LDVSL >=1, and */
+/* if JOBVSL = 'V', LDVSL >= N. */
+
+/* VSR (output) COMPLEX array, dimension (LDVSR,N) */
+/* If JOBVSR = 'V', VSR will contain the right Schur vectors. */
+/* Not referenced if JOBVSR = 'N'. */
+
+/* LDVSR (input) INTEGER */
+/* The leading dimension of the matrix VSR. LDVSR >= 1, and */
+/* if JOBVSR = 'V', LDVSR >= N. */
+
+/* RCONDE (output) REAL array, dimension ( 2 ) */
+/* If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the */
+/* reciprocal condition numbers for the average of the selected */
+/* eigenvalues. */
+/* Not referenced if SENSE = 'N' or 'V'. */
+
+/* RCONDV (output) REAL array, dimension ( 2 ) */
+/* If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the */
+/* reciprocal condition number for the selected deflating */
+/* subspaces. */
+/* Not referenced if SENSE = 'N' or 'E'. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B', */
+/* LWORK >= MAX(1,2*N,2*SDIM*(N-SDIM)), else */
+/* LWORK >= MAX(1,2*N). Note that 2*SDIM*(N-SDIM) <= N*N/2. */
+/* Note also that an error is only returned if */
+/* LWORK < MAX(1,2*N), but if SENSE = 'E' or 'V' or 'B' this may */
+/* not be large enough. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the bound on the optimal size of the WORK */
+/* array and the minimum size of the IWORK array, returns these */
+/* values as the first entries of the WORK and IWORK arrays, and */
+/* no error message related to LWORK or LIWORK is issued by */
+/* XERBLA. */
+
+/* RWORK (workspace) REAL array, dimension ( 8*N ) */
+/* Real workspace. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise */
+/* LIWORK >= N+2. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the bound on the optimal size of the */
+/* WORK array and the minimum size of the IWORK array, returns */
+/* these values as the first entries of the WORK and IWORK */
+/* arrays, and no error message related to LWORK or LIWORK is */
+/* issued by XERBLA. */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+/* Not referenced if SORT = 'N'. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1,...,N: */
+/* The QZ iteration failed. (A,B) are not in Schur */
+/* form, but ALPHA(j) and BETA(j) should be correct for */
+/* j=INFO+1,...,N. */
+/* > N: =N+1: other than QZ iteration failed in CHGEQZ */
+/* =N+2: after reordering, roundoff changed values of */
+/* some complex eigenvalues so that leading */
+/* eigenvalues in the Generalized Schur form no */
+/* longer satisfy SELCTG=.TRUE. This could also */
+/* be caused due to scaling. */
+/* =N+3: reordering failed in CTGSEN. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alpha;
+ --beta;
+ vsl_dim1 = *ldvsl;
+ vsl_offset = 1 + vsl_dim1;
+ vsl -= vsl_offset;
+ vsr_dim1 = *ldvsr;
+ vsr_offset = 1 + vsr_dim1;
+ vsr -= vsr_offset;
+ --rconde;
+ --rcondv;
+ --work;
+ --rwork;
+ --iwork;
+ --bwork;
+
+ /* Function Body */
+ if (lsame_(jobvsl, "N")) {
+ ijobvl = 1;
+ ilvsl = FALSE_;
+ } else if (lsame_(jobvsl, "V")) {
+ ijobvl = 2;
+ ilvsl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvsl = FALSE_;
+ }
+
+ if (lsame_(jobvsr, "N")) {
+ ijobvr = 1;
+ ilvsr = FALSE_;
+ } else if (lsame_(jobvsr, "V")) {
+ ijobvr = 2;
+ ilvsr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvsr = FALSE_;
+ }
+
+ wantst = lsame_(sort, "S");
+ wantsn = lsame_(sense, "N");
+ wantse = lsame_(sense, "E");
+ wantsv = lsame_(sense, "V");
+ wantsb = lsame_(sense, "B");
+ lquery = *lwork == -1 || *liwork == -1;
+ if (wantsn) {
+ ijob = 0;
+ } else if (wantse) {
+ ijob = 1;
+ } else if (wantsv) {
+ ijob = 2;
+ } else if (wantsb) {
+ ijob = 4;
+ }
+
+/* Test the input arguments */
+
+ *info = 0;
+ if (ijobvl <= 0) {
+ *info = -1;
+ } else if (ijobvr <= 0) {
+ *info = -2;
+ } else if (! wantst && ! lsame_(sort, "N")) {
+ *info = -3;
+ } else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && !
+ wantsn) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (*lda < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
+ *info = -15;
+ } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
+ *info = -17;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ if (*info == 0) {
+ if (*n > 0) {
+ minwrk = *n << 1;
+ maxwrk = *n * (ilaenv_(&c__1, "CGEQRF", " ", n, &c__1, n, &c__0) + 1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * (ilaenv_(&c__1, "CUNMQR", " ", n, &
+ c__1, n, &c_n1) + 1);
+ maxwrk = max(i__1,i__2);
+ if (ilvsl) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * (ilaenv_(&c__1, "CUNGQR", " ", n, &
+ c__1, n, &c_n1) + 1);
+ maxwrk = max(i__1,i__2);
+ }
+ lwrk = maxwrk;
+ if (ijob >= 1) {
+/* Computing MAX */
+ i__1 = lwrk, i__2 = *n * *n / 2;
+ lwrk = max(i__1,i__2);
+ }
+ } else {
+ minwrk = 1;
+ maxwrk = 1;
+ lwrk = 1;
+ }
+ work[1].r = (real) lwrk, work[1].i = 0.f;
+ if (wantsn || *n == 0) {
+ liwmin = 1;
+ } else {
+ liwmin = *n + 2;
+ }
+ iwork[1] = liwmin;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -21;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -24;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGGESX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *sdim = 0;
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1.f / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = clange_("M", n, n, &a[a_offset], lda, &rwork[1]);
+ ilascl = FALSE_;
+ if (anrm > 0.f && anrm < smlnum) {
+ anrmto = smlnum;
+ ilascl = TRUE_;
+ } else if (anrm > bignum) {
+ anrmto = bignum;
+ ilascl = TRUE_;
+ }
+ if (ilascl) {
+ clascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = clange_("M", n, n, &b[b_offset], ldb, &rwork[1]);
+ ilbscl = FALSE_;
+ if (bnrm > 0.f && bnrm < smlnum) {
+ bnrmto = smlnum;
+ ilbscl = TRUE_;
+ } else if (bnrm > bignum) {
+ bnrmto = bignum;
+ ilbscl = TRUE_;
+ }
+ if (ilbscl) {
+ clascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
+ ierr);
+ }
+
+/* Permute the matrix to make it more nearly triangular */
+/* (Real Workspace: need 6*N) */
+
+ ileft = 1;
+ iright = *n + 1;
+ irwrk = iright + *n;
+ cggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &rwork[
+ ileft], &rwork[iright], &rwork[irwrk], &ierr);
+
+/* Reduce B to triangular form (QR decomposition of B) */
+/* (Complex Workspace: need N, prefer N*NB) */
+
+ irows = ihi + 1 - ilo;
+ icols = *n + 1 - ilo;
+ itau = 1;
+ iwrk = itau + irows;
+ i__1 = *lwork + 1 - iwrk;
+ cgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
+ iwrk], &i__1, &ierr);
+
+/* Apply the unitary transformation to matrix A */
+/* (Complex Workspace: need N, prefer N*NB) */
+
+ i__1 = *lwork + 1 - iwrk;
+ cunmqr_("L", "C", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
+ work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, &
+ ierr);
+
+/* Initialize VSL */
+/* (Complex Workspace: need N, prefer N*NB) */
+
+ if (ilvsl) {
+ claset_("Full", n, n, &c_b1, &c_b2, &vsl[vsl_offset], ldvsl);
+ if (irows > 1) {
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ clacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[
+ ilo + 1 + ilo * vsl_dim1], ldvsl);
+ }
+ i__1 = *lwork + 1 - iwrk;
+ cungqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, &
+ work[itau], &work[iwrk], &i__1, &ierr);
+ }
+
+/* Initialize VSR */
+
+ if (ilvsr) {
+ claset_("Full", n, n, &c_b1, &c_b2, &vsr[vsr_offset], ldvsr);
+ }
+
+/* Reduce to generalized Hessenberg form */
+/* (Workspace: none needed) */
+
+ cgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &ierr);
+
+ *sdim = 0;
+
+/* Perform QZ algorithm, computing Schur vectors if desired */
+/* (Complex Workspace: need N) */
+/* (Real Workspace: need N) */
+
+ iwrk = itau;
+ i__1 = *lwork + 1 - iwrk;
+ chgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[
+ b_offset], ldb, &alpha[1], &beta[1], &vsl[vsl_offset], ldvsl, &
+ vsr[vsr_offset], ldvsr, &work[iwrk], &i__1, &rwork[irwrk], &ierr);
+ if (ierr != 0) {
+ if (ierr > 0 && ierr <= *n) {
+ *info = ierr;
+ } else if (ierr > *n && ierr <= *n << 1) {
+ *info = ierr - *n;
+ } else {
+ *info = *n + 1;
+ }
+ goto L40;
+ }
+
+/* Sort eigenvalues ALPHA/BETA and compute the reciprocal of */
+/* condition number(s) */
+
+ if (wantst) {
+
+/* Undo scaling on eigenvalues before SELCTGing */
+
+ if (ilascl) {
+ clascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alpha[1], n,
+ &ierr);
+ }
+ if (ilbscl) {
+ clascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n,
+ &ierr);
+ }
+
+/* Select eigenvalues */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ bwork[i__] = (*selctg)(&alpha[i__], &beta[i__]);
+/* L10: */
+ }
+
+/* Reorder eigenvalues, transform Generalized Schur vectors, and */
+/* compute reciprocal condition numbers */
+/* (Complex Workspace: If IJOB >= 1, need MAX(1, 2*SDIM*(N-SDIM)) */
+/* otherwise, need 1 ) */
+
+ i__1 = *lwork - iwrk + 1;
+ ctgsen_(&ijob, &ilvsl, &ilvsr, &bwork[1], n, &a[a_offset], lda, &b[
+ b_offset], ldb, &alpha[1], &beta[1], &vsl[vsl_offset], ldvsl,
+ &vsr[vsr_offset], ldvsr, sdim, &pl, &pr, dif, &work[iwrk], &
+ i__1, &iwork[1], liwork, &ierr);
+
+ if (ijob >= 1) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*sdim << 1) * (*n - *sdim);
+ maxwrk = max(i__1,i__2);
+ }
+ if (ierr == -21) {
+
+/* not enough complex workspace */
+
+ *info = -21;
+ } else {
+ if (ijob == 1 || ijob == 4) {
+ rconde[1] = pl;
+ rconde[2] = pr;
+ }
+ if (ijob == 2 || ijob == 4) {
+ rcondv[1] = dif[0];
+ rcondv[2] = dif[1];
+ }
+ if (ierr == 1) {
+ *info = *n + 3;
+ }
+ }
+
+ }
+
+/* Apply permutation to VSL and VSR */
+/* (Workspace: none needed) */
+
+ if (ilvsl) {
+ cggbak_("P", "L", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &
+ vsl[vsl_offset], ldvsl, &ierr);
+ }
+
+ if (ilvsr) {
+ cggbak_("P", "R", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &
+ vsr[vsr_offset], ldvsr, &ierr);
+ }
+
+/* Undo scaling */
+
+ if (ilascl) {
+ clascl_("U", &c__0, &c__0, &anrmto, &anrm, n, n, &a[a_offset], lda, &
+ ierr);
+ clascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alpha[1], n, &
+ ierr);
+ }
+
+ if (ilbscl) {
+ clascl_("U", &c__0, &c__0, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, &
+ ierr);
+ clascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
+ ierr);
+ }
+
+ if (wantst) {
+
+/* Check if reordering is correct */
+
+ lastsl = TRUE_;
+ *sdim = 0;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ cursl = (*selctg)(&alpha[i__], &beta[i__]);
+ if (cursl) {
+ ++(*sdim);
+ }
+ if (cursl && ! lastsl) {
+ *info = *n + 2;
+ }
+ lastsl = cursl;
+/* L30: */
+ }
+
+ }
+
+L40:
+
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of CGGESX */
+
+} /* cggesx_ */
diff --git a/SRC/cggev.c b/SRC/cggev.c
new file mode 100644
index 0000000..615ac57
--- /dev/null
+++ b/SRC/cggev.c
@@ -0,0 +1,592 @@
+/* cggev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cggev_(char *jobvl, char *jobvr, integer *n, complex *a,
+ integer *lda, complex *b, integer *ldb, complex *alpha, complex *beta,
+ complex *vl, integer *ldvl, complex *vr, integer *ldvr, complex *
+ work, integer *lwork, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
+ vr_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4;
+ complex q__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_imag(complex *);
+
+ /* Local variables */
+ integer jc, in, jr, ihi, ilo;
+ real eps;
+ logical ilv;
+ real anrm, bnrm;
+ integer ierr, itau;
+ real temp;
+ logical ilvl, ilvr;
+ integer iwrk;
+ extern logical lsame_(char *, char *);
+ integer ileft, icols, irwrk, irows;
+ extern /* Subroutine */ int cggbak_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, complex *, integer *,
+ integer *), cggbal_(char *, integer *, complex *,
+ integer *, complex *, integer *, integer *, integer *, real *,
+ real *, real *, integer *), slabad_(real *, real *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int cgghrd_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, complex *, integer *, integer *),
+ clascl_(char *, integer *, integer *, real *, real *, integer *,
+ integer *, complex *, integer *, integer *);
+ logical ilascl, ilbscl;
+ extern /* Subroutine */ int cgeqrf_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), ctgevc_(char *, char *, logical *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, integer *, integer *, complex *, real *, integer *), xerbla_(char *, integer *);
+ logical ldumma[1];
+ char chtemp[1];
+ real bignum;
+ extern /* Subroutine */ int chgeqz_(char *, char *, char *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ complex *, complex *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ijobvl, iright, ijobvr;
+ extern /* Subroutine */ int cungqr_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *);
+ real anrmto;
+ integer lwkmin;
+ real bnrmto;
+ extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *);
+ real smlnum;
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGGEV computes for a pair of N-by-N complex nonsymmetric matrices */
+/* (A,B), the generalized eigenvalues, and optionally, the left and/or */
+/* right generalized eigenvectors. */
+
+/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar */
+/* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is */
+/* singular. It is usually represented as the pair (alpha,beta), as */
+/* there is a reasonable interpretation for beta=0, and even for both */
+/* being zero. */
+
+/* The right generalized eigenvector v(j) corresponding to the */
+/* generalized eigenvalue lambda(j) of (A,B) satisfies */
+
+/* A * v(j) = lambda(j) * B * v(j). */
+
+/* The left generalized eigenvector u(j) corresponding to the */
+/* generalized eigenvalues lambda(j) of (A,B) satisfies */
+
+/* u(j)**H * A = lambda(j) * u(j)**H * B */
+
+/* where u(j)**H is the conjugate-transpose of u(j). */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVL (input) CHARACTER*1 */
+/* = 'N': do not compute the left generalized eigenvectors; */
+/* = 'V': compute the left generalized eigenvectors. */
+
+/* JOBVR (input) CHARACTER*1 */
+/* = 'N': do not compute the right generalized eigenvectors; */
+/* = 'V': compute the right generalized eigenvectors. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VL, and VR. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA, N) */
+/* On entry, the matrix A in the pair (A,B). */
+/* On exit, A has been overwritten. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX array, dimension (LDB, N) */
+/* On entry, the matrix B in the pair (A,B). */
+/* On exit, B has been overwritten. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* ALPHA (output) COMPLEX array, dimension (N) */
+/* BETA (output) COMPLEX array, dimension (N) */
+/* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the */
+/* generalized eigenvalues. */
+
+/* Note: the quotients ALPHA(j)/BETA(j) may easily over- or */
+/* underflow, and BETA(j) may even be zero. Thus, the user */
+/* should avoid naively computing the ratio alpha/beta. */
+/* However, ALPHA will be always less than and usually */
+/* comparable with norm(A) in magnitude, and BETA always less */
+/* than and usually comparable with norm(B). */
+
+/* VL (output) COMPLEX array, dimension (LDVL,N) */
+/* If JOBVL = 'V', the left generalized eigenvectors u(j) are */
+/* stored one after another in the columns of VL, in the same */
+/* order as their eigenvalues. */
+/* Each eigenvector is scaled so the largest component has */
+/* abs(real part) + abs(imag. part) = 1. */
+/* Not referenced if JOBVL = 'N'. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the matrix VL. LDVL >= 1, and */
+/* if JOBVL = 'V', LDVL >= N. */
+
+/* VR (output) COMPLEX array, dimension (LDVR,N) */
+/* If JOBVR = 'V', the right generalized eigenvectors v(j) are */
+/* stored one after another in the columns of VR, in the same */
+/* order as their eigenvalues. */
+/* Each eigenvector is scaled so the largest component has */
+/* abs(real part) + abs(imag. part) = 1. */
+/* Not referenced if JOBVR = 'N'. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the matrix VR. LDVR >= 1, and */
+/* if JOBVR = 'V', LDVR >= N. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,2*N). */
+/* For good performance, LWORK must generally be larger. */
+
+/* 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. */
+
+/* RWORK (workspace/output) REAL array, dimension (8*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* =1,...,N: */
+/* The QZ iteration failed. No eigenvectors have been */
+/* calculated, but ALPHA(j) and BETA(j) should be */
+/* correct for j=INFO+1,...,N. */
+/* > N: =N+1: other then QZ iteration failed in SHGEQZ, */
+/* =N+2: error return from STGEVC. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alpha;
+ --beta;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ if (lsame_(jobvl, "N")) {
+ ijobvl = 1;
+ ilvl = FALSE_;
+ } else if (lsame_(jobvl, "V")) {
+ ijobvl = 2;
+ ilvl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvl = FALSE_;
+ }
+
+ if (lsame_(jobvr, "N")) {
+ ijobvr = 1;
+ ilvr = FALSE_;
+ } else if (lsame_(jobvr, "V")) {
+ ijobvr = 2;
+ ilvr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvr = FALSE_;
+ }
+ ilv = ilvl || ilvr;
+
+/* Test the input arguments */
+
+ *info = 0;
+ lquery = *lwork == -1;
+ if (ijobvl <= 0) {
+ *info = -1;
+ } else if (ijobvr <= 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvl < 1 || ilvl && *ldvl < *n) {
+ *info = -11;
+ } else if (*ldvr < 1 || ilvr && *ldvr < *n) {
+ *info = -13;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. The workspace is */
+/* computed assuming ILO = 1 and IHI = N, the worst case.) */
+
+ if (*info == 0) {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n << 1;
+ lwkmin = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = *n + *n * ilaenv_(&c__1, "CGEQRF", " ", n, &c__1, n,
+ &c__0);
+ lwkopt = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = *n + *n * ilaenv_(&c__1, "CUNMQR", " ", n, &
+ c__1, n, &c__0);
+ lwkopt = max(i__1,i__2);
+ if (ilvl) {
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = *n + *n * ilaenv_(&c__1, "CUNGQR", " ", n, &
+ c__1, n, &c_n1);
+ lwkopt = max(i__1,i__2);
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ if (*lwork < lwkmin && ! lquery) {
+ *info = -15;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGGEV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("E") * slamch_("B");
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1.f / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = clange_("M", n, n, &a[a_offset], lda, &rwork[1]);
+ ilascl = FALSE_;
+ if (anrm > 0.f && anrm < smlnum) {
+ anrmto = smlnum;
+ ilascl = TRUE_;
+ } else if (anrm > bignum) {
+ anrmto = bignum;
+ ilascl = TRUE_;
+ }
+ if (ilascl) {
+ clascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = clange_("M", n, n, &b[b_offset], ldb, &rwork[1]);
+ ilbscl = FALSE_;
+ if (bnrm > 0.f && bnrm < smlnum) {
+ bnrmto = smlnum;
+ ilbscl = TRUE_;
+ } else if (bnrm > bignum) {
+ bnrmto = bignum;
+ ilbscl = TRUE_;
+ }
+ if (ilbscl) {
+ clascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
+ ierr);
+ }
+
+/* Permute the matrices A, B to isolate eigenvalues if possible */
+/* (Real Workspace: need 6*N) */
+
+ ileft = 1;
+ iright = *n + 1;
+ irwrk = iright + *n;
+ cggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &rwork[
+ ileft], &rwork[iright], &rwork[irwrk], &ierr);
+
+/* Reduce B to triangular form (QR decomposition of B) */
+/* (Complex Workspace: need N, prefer N*NB) */
+
+ irows = ihi + 1 - ilo;
+ if (ilv) {
+ icols = *n + 1 - ilo;
+ } else {
+ icols = irows;
+ }
+ itau = 1;
+ iwrk = itau + irows;
+ i__1 = *lwork + 1 - iwrk;
+ cgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
+ iwrk], &i__1, &ierr);
+
+/* Apply the orthogonal transformation to matrix A */
+/* (Complex Workspace: need N, prefer N*NB) */
+
+ i__1 = *lwork + 1 - iwrk;
+ cunmqr_("L", "C", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
+ work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, &
+ ierr);
+
+/* Initialize VL */
+/* (Complex Workspace: need N, prefer N*NB) */
+
+ if (ilvl) {
+ claset_("Full", n, n, &c_b1, &c_b2, &vl[vl_offset], ldvl);
+ if (irows > 1) {
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ clacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vl[
+ ilo + 1 + ilo * vl_dim1], ldvl);
+ }
+ i__1 = *lwork + 1 - iwrk;
+ cungqr_(&irows, &irows, &irows, &vl[ilo + ilo * vl_dim1], ldvl, &work[
+ itau], &work[iwrk], &i__1, &ierr);
+ }
+
+/* Initialize VR */
+
+ if (ilvr) {
+ claset_("Full", n, n, &c_b1, &c_b2, &vr[vr_offset], ldvr);
+ }
+
+/* Reduce to generalized Hessenberg form */
+
+ if (ilv) {
+
+/* Eigenvectors requested -- work on whole matrix. */
+
+ cgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr);
+ } else {
+ cgghrd_("N", "N", &irows, &c__1, &irows, &a[ilo + ilo * a_dim1], lda,
+ &b[ilo + ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[
+ vr_offset], ldvr, &ierr);
+ }
+
+/* Perform QZ algorithm (Compute eigenvalues, and optionally, the */
+/* Schur form and Schur vectors) */
+/* (Complex Workspace: need N) */
+/* (Real Workspace: need N) */
+
+ iwrk = itau;
+ if (ilv) {
+ *(unsigned char *)chtemp = 'S';
+ } else {
+ *(unsigned char *)chtemp = 'E';
+ }
+ i__1 = *lwork + 1 - iwrk;
+ chgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[
+ b_offset], ldb, &alpha[1], &beta[1], &vl[vl_offset], ldvl, &vr[
+ vr_offset], ldvr, &work[iwrk], &i__1, &rwork[irwrk], &ierr);
+ if (ierr != 0) {
+ if (ierr > 0 && ierr <= *n) {
+ *info = ierr;
+ } else if (ierr > *n && ierr <= *n << 1) {
+ *info = ierr - *n;
+ } else {
+ *info = *n + 1;
+ }
+ goto L70;
+ }
+
+/* Compute Eigenvectors */
+/* (Real Workspace: need 2*N) */
+/* (Complex Workspace: need 2*N) */
+
+ if (ilv) {
+ if (ilvl) {
+ if (ilvr) {
+ *(unsigned char *)chtemp = 'B';
+ } else {
+ *(unsigned char *)chtemp = 'L';
+ }
+ } else {
+ *(unsigned char *)chtemp = 'R';
+ }
+
+ ctgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb,
+ &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[
+ iwrk], &rwork[irwrk], &ierr);
+ if (ierr != 0) {
+ *info = *n + 2;
+ goto L70;
+ }
+
+/* Undo balancing on VL and VR and normalization */
+/* (Workspace: none needed) */
+
+ if (ilvl) {
+ cggbak_("P", "L", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n,
+ &vl[vl_offset], ldvl, &ierr);
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ temp = 0.f;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ i__3 = jr + jc * vl_dim1;
+ r__3 = temp, r__4 = (r__1 = vl[i__3].r, dabs(r__1)) + (
+ r__2 = r_imag(&vl[jr + jc * vl_dim1]), dabs(r__2))
+ ;
+ temp = dmax(r__3,r__4);
+/* L10: */
+ }
+ if (temp < smlnum) {
+ goto L30;
+ }
+ temp = 1.f / temp;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = jr + jc * vl_dim1;
+ i__4 = jr + jc * vl_dim1;
+ q__1.r = temp * vl[i__4].r, q__1.i = temp * vl[i__4].i;
+ vl[i__3].r = q__1.r, vl[i__3].i = q__1.i;
+/* L20: */
+ }
+L30:
+ ;
+ }
+ }
+ if (ilvr) {
+ cggbak_("P", "R", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n,
+ &vr[vr_offset], ldvr, &ierr);
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ temp = 0.f;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ i__3 = jr + jc * vr_dim1;
+ r__3 = temp, r__4 = (r__1 = vr[i__3].r, dabs(r__1)) + (
+ r__2 = r_imag(&vr[jr + jc * vr_dim1]), dabs(r__2))
+ ;
+ temp = dmax(r__3,r__4);
+/* L40: */
+ }
+ if (temp < smlnum) {
+ goto L60;
+ }
+ temp = 1.f / temp;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = jr + jc * vr_dim1;
+ i__4 = jr + jc * vr_dim1;
+ q__1.r = temp * vr[i__4].r, q__1.i = temp * vr[i__4].i;
+ vr[i__3].r = q__1.r, vr[i__3].i = q__1.i;
+/* L50: */
+ }
+L60:
+ ;
+ }
+ }
+ }
+
+/* Undo scaling if necessary */
+
+ if (ilascl) {
+ clascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alpha[1], n, &
+ ierr);
+ }
+
+ if (ilbscl) {
+ clascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
+ ierr);
+ }
+
+L70:
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CGGEV */
+
+} /* cggev_ */
diff --git a/SRC/cggevx.c b/SRC/cggevx.c
new file mode 100644
index 0000000..5c1a1b3
--- /dev/null
+++ b/SRC/cggevx.c
@@ -0,0 +1,802 @@
+/* cggevx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c__0 = 0;
+
+/* Subroutine */ int cggevx_(char *balanc, char *jobvl, char *jobvr, char *
+ sense, integer *n, complex *a, integer *lda, complex *b, integer *ldb,
+ complex *alpha, complex *beta, complex *vl, integer *ldvl, complex *
+ vr, integer *ldvr, integer *ilo, integer *ihi, real *lscale, real *
+ rscale, real *abnrm, real *bbnrm, real *rconde, real *rcondv, complex
+ *work, integer *lwork, real *rwork, integer *iwork, logical *bwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
+ vr_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4;
+ complex q__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, m, jc, in, jr;
+ real eps;
+ logical ilv;
+ real anrm, bnrm;
+ integer ierr, itau;
+ real temp;
+ logical ilvl, ilvr;
+ integer iwrk, iwrk1;
+ extern logical lsame_(char *, char *);
+ integer icols;
+ logical noscl;
+ integer irows;
+ extern /* Subroutine */ int cggbak_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, complex *, integer *,
+ integer *), cggbal_(char *, integer *, complex *,
+ integer *, complex *, integer *, integer *, integer *, real *,
+ real *, real *, integer *), slabad_(real *, real *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int cgghrd_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, complex *, integer *, integer *),
+ clascl_(char *, integer *, integer *, real *, real *, integer *,
+ integer *, complex *, integer *, integer *);
+ logical ilascl, ilbscl;
+ extern /* Subroutine */ int cgeqrf_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *), clacpy_(
+ char *, integer *, integer *, complex *, integer *, complex *,
+ integer *), claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), ctgevc_(char *, char
+ *, logical *, integer *, complex *, integer *, complex *, integer
+ *, complex *, integer *, complex *, integer *, integer *, integer
+ *, complex *, real *, integer *);
+ logical ldumma[1];
+ char chtemp[1];
+ real bignum;
+ extern /* Subroutine */ int chgeqz_(char *, char *, char *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ complex *, complex *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, integer *),
+ ctgsna_(char *, char *, logical *, integer *, complex *, integer *
+, complex *, integer *, complex *, integer *, complex *, integer *
+, real *, real *, integer *, integer *, complex *, integer *,
+ integer *, integer *);
+ integer ijobvl;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern doublereal slamch_(char *);
+ integer ijobvr;
+ logical wantsb;
+ extern /* Subroutine */ int cungqr_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *);
+ real anrmto;
+ logical wantse;
+ real bnrmto;
+ extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *);
+ integer minwrk, maxwrk;
+ logical wantsn;
+ real smlnum;
+ logical lquery, wantsv;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGGEVX computes for a pair of N-by-N complex nonsymmetric matrices */
+/* (A,B) the generalized eigenvalues, and optionally, the left and/or */
+/* right generalized eigenvectors. */
+
+/* Optionally, it also computes a balancing transformation to improve */
+/* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */
+/* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for */
+/* the eigenvalues (RCONDE), and reciprocal condition numbers for the */
+/* right eigenvectors (RCONDV). */
+
+/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar */
+/* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is */
+/* singular. It is usually represented as the pair (alpha,beta), as */
+/* there is a reasonable interpretation for beta=0, and even for both */
+/* being zero. */
+
+/* The right eigenvector v(j) corresponding to the eigenvalue lambda(j) */
+/* of (A,B) satisfies */
+/* A * v(j) = lambda(j) * B * v(j) . */
+/* The left eigenvector u(j) corresponding to the eigenvalue lambda(j) */
+/* of (A,B) satisfies */
+/* u(j)**H * A = lambda(j) * u(j)**H * B. */
+/* where u(j)**H is the conjugate-transpose of u(j). */
+
+
+/* Arguments */
+/* ========= */
+
+/* BALANC (input) CHARACTER*1 */
+/* Specifies the balance option to be performed: */
+/* = 'N': do not diagonally scale or permute; */
+/* = 'P': permute only; */
+/* = 'S': scale only; */
+/* = 'B': both permute and scale. */
+/* Computed reciprocal condition numbers will be for the */
+/* matrices after permuting and/or balancing. Permuting does */
+/* not change condition numbers (in exact arithmetic), but */
+/* balancing does. */
+
+/* JOBVL (input) CHARACTER*1 */
+/* = 'N': do not compute the left generalized eigenvectors; */
+/* = 'V': compute the left generalized eigenvectors. */
+
+/* JOBVR (input) CHARACTER*1 */
+/* = 'N': do not compute the right generalized eigenvectors; */
+/* = 'V': compute the right generalized eigenvectors. */
+
+/* SENSE (input) CHARACTER*1 */
+/* Determines which reciprocal condition numbers are computed. */
+/* = 'N': none are computed; */
+/* = 'E': computed for eigenvalues only; */
+/* = 'V': computed for eigenvectors only; */
+/* = 'B': computed for eigenvalues and eigenvectors. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VL, and VR. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA, N) */
+/* On entry, the matrix A in the pair (A,B). */
+/* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V' */
+/* or both, then A contains the first part of the complex Schur */
+/* form of the "balanced" versions of the input A and B. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX array, dimension (LDB, N) */
+/* On entry, the matrix B in the pair (A,B). */
+/* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V' */
+/* or both, then B contains the second part of the complex */
+/* Schur form of the "balanced" versions of the input A and B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* ALPHA (output) COMPLEX array, dimension (N) */
+/* BETA (output) COMPLEX array, dimension (N) */
+/* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the generalized */
+/* eigenvalues. */
+
+/* Note: the quotient ALPHA(j)/BETA(j) ) may easily over- or */
+/* underflow, and BETA(j) may even be zero. Thus, the user */
+/* should avoid naively computing the ratio ALPHA/BETA. */
+/* However, ALPHA will be always less than and usually */
+/* comparable with norm(A) in magnitude, and BETA always less */
+/* than and usually comparable with norm(B). */
+
+/* VL (output) COMPLEX array, dimension (LDVL,N) */
+/* If JOBVL = 'V', the left generalized eigenvectors u(j) are */
+/* stored one after another in the columns of VL, in the same */
+/* order as their eigenvalues. */
+/* Each eigenvector will be scaled so the largest component */
+/* will have abs(real part) + abs(imag. part) = 1. */
+/* Not referenced if JOBVL = 'N'. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the matrix VL. LDVL >= 1, and */
+/* if JOBVL = 'V', LDVL >= N. */
+
+/* VR (output) COMPLEX array, dimension (LDVR,N) */
+/* If JOBVR = 'V', the right generalized eigenvectors v(j) are */
+/* stored one after another in the columns of VR, in the same */
+/* order as their eigenvalues. */
+/* Each eigenvector will be scaled so the largest component */
+/* will have abs(real part) + abs(imag. part) = 1. */
+/* Not referenced if JOBVR = 'N'. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the matrix VR. LDVR >= 1, and */
+/* if JOBVR = 'V', LDVR >= N. */
+
+/* ILO (output) INTEGER */
+/* IHI (output) INTEGER */
+/* ILO and IHI are integer values such that on exit */
+/* A(i,j) = 0 and B(i,j) = 0 if i > j and */
+/* j = 1,...,ILO-1 or i = IHI+1,...,N. */
+/* If BALANC = 'N' or 'S', ILO = 1 and IHI = N. */
+
+/* LSCALE (output) REAL array, dimension (N) */
+/* Details of the permutations and scaling factors applied */
+/* to the left side of A and B. If PL(j) is the index of the */
+/* row interchanged with row j, and DL(j) is the scaling */
+/* factor applied to row j, then */
+/* LSCALE(j) = PL(j) for j = 1,...,ILO-1 */
+/* = DL(j) for j = ILO,...,IHI */
+/* = PL(j) for j = IHI+1,...,N. */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* RSCALE (output) REAL array, dimension (N) */
+/* Details of the permutations and scaling factors applied */
+/* to the right side of A and B. If PR(j) is the index of the */
+/* column interchanged with column j, and DR(j) is the scaling */
+/* factor applied to column j, then */
+/* RSCALE(j) = PR(j) for j = 1,...,ILO-1 */
+/* = DR(j) for j = ILO,...,IHI */
+/* = PR(j) for j = IHI+1,...,N */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* ABNRM (output) REAL */
+/* The one-norm of the balanced matrix A. */
+
+/* BBNRM (output) REAL */
+/* The one-norm of the balanced matrix B. */
+
+/* RCONDE (output) REAL array, dimension (N) */
+/* If SENSE = 'E' or 'B', the reciprocal condition numbers of */
+/* the eigenvalues, stored in consecutive elements of the array. */
+/* If SENSE = 'N' or 'V', RCONDE is not referenced. */
+
+/* RCONDV (output) REAL array, dimension (N) */
+/* If SENSE = 'V' or 'B', the estimated reciprocal condition */
+/* numbers of the eigenvectors, stored in consecutive elements */
+/* of the array. If the eigenvalues cannot be reordered to */
+/* compute RCONDV(j), RCONDV(j) is set to 0; this can only occur */
+/* when the true value would be very small anyway. */
+/* If SENSE = 'N' or 'E', RCONDV is not referenced. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,2*N). */
+/* If SENSE = 'E', LWORK >= max(1,4*N). */
+/* If SENSE = 'V' or 'B', LWORK >= max(1,2*N*N+2*N). */
+
+/* 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. */
+
+/* RWORK (workspace) REAL array, dimension (lrwork) */
+/* lrwork must be at least max(1,6*N) if BALANC = 'S' or 'B', */
+/* and at least max(1,2*N) otherwise. */
+/* Real workspace. */
+
+/* IWORK (workspace) INTEGER array, dimension (N+2) */
+/* If SENSE = 'E', IWORK is not referenced. */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+/* If SENSE = 'N', BWORK is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1,...,N: */
+/* The QZ iteration failed. No eigenvectors have been */
+/* calculated, but ALPHA(j) and BETA(j) should be correct */
+/* for j=INFO+1,...,N. */
+/* > N: =N+1: other than QZ iteration failed in CHGEQZ. */
+/* =N+2: error return from CTGEVC. */
+
+/* Further Details */
+/* =============== */
+
+/* Balancing a matrix pair (A,B) includes, first, permuting rows and */
+/* columns to isolate eigenvalues, second, applying diagonal similarity */
+/* transformation to the rows and columns to make the rows and columns */
+/* as close in norm as possible. The computed reciprocal condition */
+/* numbers correspond to the balanced matrix. Permuting rows and columns */
+/* will not change the condition numbers (in exact arithmetic) but */
+/* diagonal scaling will. For further explanation of balancing, see */
+/* section 4.11.1.2 of LAPACK Users' Guide. */
+
+/* An approximate error bound on the chordal distance between the i-th */
+/* computed generalized eigenvalue w and the corresponding exact */
+/* eigenvalue lambda is */
+
+/* chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I) */
+
+/* An approximate error bound for the angle between the i-th computed */
+/* eigenvector VL(i) or VR(i) is given by */
+
+/* EPS * norm(ABNRM, BBNRM) / DIF(i). */
+
+/* For further explanation of the reciprocal condition numbers RCONDE */
+/* and RCONDV, see section 4.11 of LAPACK User's Guide. */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alpha;
+ --beta;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --lscale;
+ --rscale;
+ --rconde;
+ --rcondv;
+ --work;
+ --rwork;
+ --iwork;
+ --bwork;
+
+ /* Function Body */
+ if (lsame_(jobvl, "N")) {
+ ijobvl = 1;
+ ilvl = FALSE_;
+ } else if (lsame_(jobvl, "V")) {
+ ijobvl = 2;
+ ilvl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvl = FALSE_;
+ }
+
+ if (lsame_(jobvr, "N")) {
+ ijobvr = 1;
+ ilvr = FALSE_;
+ } else if (lsame_(jobvr, "V")) {
+ ijobvr = 2;
+ ilvr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvr = FALSE_;
+ }
+ ilv = ilvl || ilvr;
+
+ noscl = lsame_(balanc, "N") || lsame_(balanc, "P");
+ wantsn = lsame_(sense, "N");
+ wantse = lsame_(sense, "E");
+ wantsv = lsame_(sense, "V");
+ wantsb = lsame_(sense, "B");
+
+/* Test the input arguments */
+
+ *info = 0;
+ lquery = *lwork == -1;
+ if (! (noscl || lsame_(balanc, "S") || lsame_(
+ balanc, "B"))) {
+ *info = -1;
+ } else if (ijobvl <= 0) {
+ *info = -2;
+ } else if (ijobvr <= 0) {
+ *info = -3;
+ } else if (! (wantsn || wantse || wantsb || wantsv)) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldvl < 1 || ilvl && *ldvl < *n) {
+ *info = -13;
+ } else if (*ldvr < 1 || ilvr && *ldvr < *n) {
+ *info = -15;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. The workspace is */
+/* computed assuming ILO = 1 and IHI = N, the worst case.) */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ } else {
+ minwrk = *n << 1;
+ if (wantse) {
+ minwrk = *n << 2;
+ } else if (wantsv || wantsb) {
+ minwrk = (*n << 1) * (*n + 1);
+ }
+ maxwrk = minwrk;
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "CGEQRF", " ", n, &
+ c__1, n, &c__0);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "CUNMQR", " ", n, &
+ c__1, n, &c__0);
+ maxwrk = max(i__1,i__2);
+ if (ilvl) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "CUNGQR",
+ " ", n, &c__1, n, &c__0);
+ maxwrk = max(i__1,i__2);
+ }
+ }
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -25;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGGEVX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1.f / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = clange_("M", n, n, &a[a_offset], lda, &rwork[1]);
+ ilascl = FALSE_;
+ if (anrm > 0.f && anrm < smlnum) {
+ anrmto = smlnum;
+ ilascl = TRUE_;
+ } else if (anrm > bignum) {
+ anrmto = bignum;
+ ilascl = TRUE_;
+ }
+ if (ilascl) {
+ clascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = clange_("M", n, n, &b[b_offset], ldb, &rwork[1]);
+ ilbscl = FALSE_;
+ if (bnrm > 0.f && bnrm < smlnum) {
+ bnrmto = smlnum;
+ ilbscl = TRUE_;
+ } else if (bnrm > bignum) {
+ bnrmto = bignum;
+ ilbscl = TRUE_;
+ }
+ if (ilbscl) {
+ clascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
+ ierr);
+ }
+
+/* Permute and/or balance the matrix pair (A,B) */
+/* (Real Workspace: need 6*N if BALANC = 'S' or 'B', 1 otherwise) */
+
+ cggbal_(balanc, n, &a[a_offset], lda, &b[b_offset], ldb, ilo, ihi, &
+ lscale[1], &rscale[1], &rwork[1], &ierr);
+
+/* Compute ABNRM and BBNRM */
+
+ *abnrm = clange_("1", n, n, &a[a_offset], lda, &rwork[1]);
+ if (ilascl) {
+ rwork[1] = *abnrm;
+ slascl_("G", &c__0, &c__0, &anrmto, &anrm, &c__1, &c__1, &rwork[1], &
+ c__1, &ierr);
+ *abnrm = rwork[1];
+ }
+
+ *bbnrm = clange_("1", n, n, &b[b_offset], ldb, &rwork[1]);
+ if (ilbscl) {
+ rwork[1] = *bbnrm;
+ slascl_("G", &c__0, &c__0, &bnrmto, &bnrm, &c__1, &c__1, &rwork[1], &
+ c__1, &ierr);
+ *bbnrm = rwork[1];
+ }
+
+/* Reduce B to triangular form (QR decomposition of B) */
+/* (Complex Workspace: need N, prefer N*NB ) */
+
+ irows = *ihi + 1 - *ilo;
+ if (ilv || ! wantsn) {
+ icols = *n + 1 - *ilo;
+ } else {
+ icols = irows;
+ }
+ itau = 1;
+ iwrk = itau + irows;
+ i__1 = *lwork + 1 - iwrk;
+ cgeqrf_(&irows, &icols, &b[*ilo + *ilo * b_dim1], ldb, &work[itau], &work[
+ iwrk], &i__1, &ierr);
+
+/* Apply the unitary transformation to A */
+/* (Complex Workspace: need N, prefer N*NB) */
+
+ i__1 = *lwork + 1 - iwrk;
+ cunmqr_("L", "C", &irows, &icols, &irows, &b[*ilo + *ilo * b_dim1], ldb, &
+ work[itau], &a[*ilo + *ilo * a_dim1], lda, &work[iwrk], &i__1, &
+ ierr);
+
+/* Initialize VL and/or VR */
+/* (Workspace: need N, prefer N*NB) */
+
+ if (ilvl) {
+ claset_("Full", n, n, &c_b1, &c_b2, &vl[vl_offset], ldvl);
+ if (irows > 1) {
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ clacpy_("L", &i__1, &i__2, &b[*ilo + 1 + *ilo * b_dim1], ldb, &vl[
+ *ilo + 1 + *ilo * vl_dim1], ldvl);
+ }
+ i__1 = *lwork + 1 - iwrk;
+ cungqr_(&irows, &irows, &irows, &vl[*ilo + *ilo * vl_dim1], ldvl, &
+ work[itau], &work[iwrk], &i__1, &ierr);
+ }
+
+ if (ilvr) {
+ claset_("Full", n, n, &c_b1, &c_b2, &vr[vr_offset], ldvr);
+ }
+
+/* Reduce to generalized Hessenberg form */
+/* (Workspace: none needed) */
+
+ if (ilv || ! wantsn) {
+
+/* Eigenvectors requested -- work on whole matrix. */
+
+ cgghrd_(jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr);
+ } else {
+ cgghrd_("N", "N", &irows, &c__1, &irows, &a[*ilo + *ilo * a_dim1],
+ lda, &b[*ilo + *ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[
+ vr_offset], ldvr, &ierr);
+ }
+
+/* Perform QZ algorithm (Compute eigenvalues, and optionally, the */
+/* Schur forms and Schur vectors) */
+/* (Complex Workspace: need N) */
+/* (Real Workspace: need N) */
+
+ iwrk = itau;
+ if (ilv || ! wantsn) {
+ *(unsigned char *)chtemp = 'S';
+ } else {
+ *(unsigned char *)chtemp = 'E';
+ }
+
+ i__1 = *lwork + 1 - iwrk;
+ chgeqz_(chtemp, jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset]
+, ldb, &alpha[1], &beta[1], &vl[vl_offset], ldvl, &vr[vr_offset],
+ ldvr, &work[iwrk], &i__1, &rwork[1], &ierr);
+ if (ierr != 0) {
+ if (ierr > 0 && ierr <= *n) {
+ *info = ierr;
+ } else if (ierr > *n && ierr <= *n << 1) {
+ *info = ierr - *n;
+ } else {
+ *info = *n + 1;
+ }
+ goto L90;
+ }
+
+/* Compute Eigenvectors and estimate condition numbers if desired */
+/* CTGEVC: (Complex Workspace: need 2*N ) */
+/* (Real Workspace: need 2*N ) */
+/* CTGSNA: (Complex Workspace: need 2*N*N if SENSE='V' or 'B') */
+/* (Integer Workspace: need N+2 ) */
+
+ if (ilv || ! wantsn) {
+ if (ilv) {
+ if (ilvl) {
+ if (ilvr) {
+ *(unsigned char *)chtemp = 'B';
+ } else {
+ *(unsigned char *)chtemp = 'L';
+ }
+ } else {
+ *(unsigned char *)chtemp = 'R';
+ }
+
+ ctgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset],
+ ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &
+ work[iwrk], &rwork[1], &ierr);
+ if (ierr != 0) {
+ *info = *n + 2;
+ goto L90;
+ }
+ }
+
+ if (! wantsn) {
+
+/* compute eigenvectors (STGEVC) and estimate condition */
+/* numbers (STGSNA). Note that the definition of the condition */
+/* number is not invariant under transformation (u,v) to */
+/* (Q*u, Z*v), where (u,v) are eigenvectors of the generalized */
+/* Schur form (S,T), Q and Z are orthogonal matrices. In order */
+/* to avoid using extra 2*N*N workspace, we have to */
+/* re-calculate eigenvectors and estimate the condition numbers */
+/* one at a time. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ bwork[j] = FALSE_;
+/* L10: */
+ }
+ bwork[i__] = TRUE_;
+
+ iwrk = *n + 1;
+ iwrk1 = iwrk + *n;
+
+ if (wantse || wantsb) {
+ ctgevc_("B", "S", &bwork[1], n, &a[a_offset], lda, &b[
+ b_offset], ldb, &work[1], n, &work[iwrk], n, &
+ c__1, &m, &work[iwrk1], &rwork[1], &ierr);
+ if (ierr != 0) {
+ *info = *n + 2;
+ goto L90;
+ }
+ }
+
+ i__2 = *lwork - iwrk1 + 1;
+ ctgsna_(sense, "S", &bwork[1], n, &a[a_offset], lda, &b[
+ b_offset], ldb, &work[1], n, &work[iwrk], n, &rconde[
+ i__], &rcondv[i__], &c__1, &m, &work[iwrk1], &i__2, &
+ iwork[1], &ierr);
+
+/* L20: */
+ }
+ }
+ }
+
+/* Undo balancing on VL and VR and normalization */
+/* (Workspace: none needed) */
+
+ if (ilvl) {
+ cggbak_(balanc, "L", n, ilo, ihi, &lscale[1], &rscale[1], n, &vl[
+ vl_offset], ldvl, &ierr);
+
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ temp = 0.f;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ i__3 = jr + jc * vl_dim1;
+ r__3 = temp, r__4 = (r__1 = vl[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&vl[jr + jc * vl_dim1]), dabs(r__2));
+ temp = dmax(r__3,r__4);
+/* L30: */
+ }
+ if (temp < smlnum) {
+ goto L50;
+ }
+ temp = 1.f / temp;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = jr + jc * vl_dim1;
+ i__4 = jr + jc * vl_dim1;
+ q__1.r = temp * vl[i__4].r, q__1.i = temp * vl[i__4].i;
+ vl[i__3].r = q__1.r, vl[i__3].i = q__1.i;
+/* L40: */
+ }
+L50:
+ ;
+ }
+ }
+
+ if (ilvr) {
+ cggbak_(balanc, "R", n, ilo, ihi, &lscale[1], &rscale[1], n, &vr[
+ vr_offset], ldvr, &ierr);
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ temp = 0.f;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ i__3 = jr + jc * vr_dim1;
+ r__3 = temp, r__4 = (r__1 = vr[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&vr[jr + jc * vr_dim1]), dabs(r__2));
+ temp = dmax(r__3,r__4);
+/* L60: */
+ }
+ if (temp < smlnum) {
+ goto L80;
+ }
+ temp = 1.f / temp;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = jr + jc * vr_dim1;
+ i__4 = jr + jc * vr_dim1;
+ q__1.r = temp * vr[i__4].r, q__1.i = temp * vr[i__4].i;
+ vr[i__3].r = q__1.r, vr[i__3].i = q__1.i;
+/* L70: */
+ }
+L80:
+ ;
+ }
+ }
+
+/* Undo scaling if necessary */
+
+ if (ilascl) {
+ clascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alpha[1], n, &
+ ierr);
+ }
+
+ if (ilbscl) {
+ clascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
+ ierr);
+ }
+
+L90:
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CGGEVX */
+
+} /* cggevx_ */
diff --git a/SRC/cggglm.c b/SRC/cggglm.c
new file mode 100644
index 0000000..a8ec88d
--- /dev/null
+++ b/SRC/cggglm.c
@@ -0,0 +1,334 @@
+/* cggglm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cggglm_(integer *n, integer *m, integer *p, complex *a,
+ integer *lda, complex *b, integer *ldb, complex *d__, complex *x,
+ complex *y, complex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, nb, np, nb1, nb2, nb3, nb4, lopt;
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *), ccopy_(integer *, complex *, integer *,
+ complex *, integer *), cggqrf_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, complex *,
+ complex *, integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer lwkmin;
+ extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *), cunmrq_(char *,
+ char *, integer *, integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *, complex *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int ctrtrs_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGGGLM solves a general Gauss-Markov linear model (GLM) problem: */
+
+/* minimize || y ||_2 subject to d = A*x + B*y */
+/* x */
+
+/* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a */
+/* given N-vector. It is assumed that M <= N <= M+P, and */
+
+/* rank(A) = M and rank( A B ) = N. */
+
+/* Under these assumptions, the constrained equation is always */
+/* consistent, and there is a unique solution x and a minimal 2-norm */
+/* solution y, which is obtained using a generalized QR factorization */
+/* of the matrices (A, B) given by */
+
+/* A = Q*(R), B = Q*T*Z. */
+/* (0) */
+
+/* In particular, if matrix B is square nonsingular, then the problem */
+/* GLM is equivalent to the following weighted linear least squares */
+/* problem */
+
+/* minimize || inv(B)*(d-A*x) ||_2 */
+/* x */
+
+/* where inv(B) denotes the inverse of B. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices A and B. N >= 0. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix A. 0 <= M <= N. */
+
+/* P (input) INTEGER */
+/* The number of columns of the matrix B. P >= N-M. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,M) */
+/* On entry, the N-by-M matrix A. */
+/* On exit, the upper triangular part of the array A contains */
+/* the M-by-M upper triangular matrix R. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,P) */
+/* On entry, the N-by-P matrix B. */
+/* On exit, if N <= P, the upper triangle of the subarray */
+/* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T; */
+/* if N > P, the elements on and above the (N-P)th subdiagonal */
+/* contain the N-by-P upper trapezoidal matrix T. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* D (input/output) COMPLEX array, dimension (N) */
+/* On entry, D is the left hand side of the GLM equation. */
+/* On exit, D is destroyed. */
+
+/* X (output) COMPLEX array, dimension (M) */
+/* Y (output) COMPLEX array, dimension (P) */
+/* On exit, X and Y are the solutions of the GLM problem. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N+M+P). */
+/* For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB, */
+/* where NB is an upper bound for the optimal blocksizes for */
+/* CGEQRF, CGERQF, CUNMQR and CUNMRQ. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1: the upper triangular factor R associated with A in the */
+/* generalized QR factorization of the pair (A, B) is */
+/* singular, so that rank(A) < M; the least squares */
+/* solution could not be computed. */
+/* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal */
+/* factor T associated with B in the generalized QR */
+/* factorization of the pair (A, B) is singular, so that */
+/* rank( A B ) < N; the least squares solution could not */
+/* be computed. */
+
+/* =================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --d__;
+ --x;
+ --y;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ np = min(*n,*p);
+ lquery = *lwork == -1;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*m < 0 || *m > *n) {
+ *info = -2;
+ } else if (*p < 0 || *p < *n - *m) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+
+/* Calculate workspace */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ lwkmin = 1;
+ lwkopt = 1;
+ } else {
+ nb1 = ilaenv_(&c__1, "CGEQRF", " ", n, m, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "CGERQF", " ", n, m, &c_n1, &c_n1);
+ nb3 = ilaenv_(&c__1, "CUNMQR", " ", n, m, p, &c_n1);
+ nb4 = ilaenv_(&c__1, "CUNMRQ", " ", n, m, p, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2), i__1 = max(i__1,nb3);
+ nb = max(i__1,nb4);
+ lwkmin = *m + *n + *p;
+ lwkopt = *m + np + max(*n,*p) * nb;
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ if (*lwork < lwkmin && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGGGLM", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Compute the GQR factorization of matrices A and B: */
+
+/* Q'*A = ( R11 ) M, Q'*B*Z' = ( T11 T12 ) M */
+/* ( 0 ) N-M ( 0 T22 ) N-M */
+/* M M+P-N N-M */
+
+/* where R11 and T22 are upper triangular, and Q and Z are */
+/* unitary. */
+
+ i__1 = *lwork - *m - np;
+ cggqrf_(n, m, p, &a[a_offset], lda, &work[1], &b[b_offset], ldb, &work[*m
+ + 1], &work[*m + np + 1], &i__1, info);
+ i__1 = *m + np + 1;
+ lopt = work[i__1].r;
+
+/* Update left-hand-side vector d = Q'*d = ( d1 ) M */
+/* ( d2 ) N-M */
+
+ i__1 = max(1,*n);
+ i__2 = *lwork - *m - np;
+ cunmqr_("Left", "Conjugate transpose", n, &c__1, m, &a[a_offset], lda, &
+ work[1], &d__[1], &i__1, &work[*m + np + 1], &i__2, info);
+/* Computing MAX */
+ i__3 = *m + np + 1;
+ i__1 = lopt, i__2 = (integer) work[i__3].r;
+ lopt = max(i__1,i__2);
+
+/* Solve T22*y2 = d2 for y2 */
+
+ if (*n > *m) {
+ i__1 = *n - *m;
+ i__2 = *n - *m;
+ ctrtrs_("Upper", "No transpose", "Non unit", &i__1, &c__1, &b[*m + 1
+ + (*m + *p - *n + 1) * b_dim1], ldb, &d__[*m + 1], &i__2,
+ info);
+
+ if (*info > 0) {
+ *info = 1;
+ return 0;
+ }
+
+ i__1 = *n - *m;
+ ccopy_(&i__1, &d__[*m + 1], &c__1, &y[*m + *p - *n + 1], &c__1);
+ }
+
+/* Set y1 = 0 */
+
+ i__1 = *m + *p - *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ y[i__2].r = 0.f, y[i__2].i = 0.f;
+/* L10: */
+ }
+
+/* Update d1 = d1 - T12*y2 */
+
+ i__1 = *n - *m;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", m, &i__1, &q__1, &b[(*m + *p - *n + 1) * b_dim1 +
+ 1], ldb, &y[*m + *p - *n + 1], &c__1, &c_b2, &d__[1], &c__1);
+
+/* Solve triangular system: R11*x = d1 */
+
+ if (*m > 0) {
+ ctrtrs_("Upper", "No Transpose", "Non unit", m, &c__1, &a[a_offset],
+ lda, &d__[1], m, info);
+
+ if (*info > 0) {
+ *info = 2;
+ return 0;
+ }
+
+/* Copy D to X */
+
+ ccopy_(m, &d__[1], &c__1, &x[1], &c__1);
+ }
+
+/* Backward transformation y = Z'*y */
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *n - *p + 1;
+ i__3 = max(1,*p);
+ i__4 = *lwork - *m - np;
+ cunmrq_("Left", "Conjugate transpose", p, &c__1, &np, &b[max(i__1, i__2)+
+ b_dim1], ldb, &work[*m + 1], &y[1], &i__3, &work[*m + np + 1], &
+ i__4, info);
+/* Computing MAX */
+ i__4 = *m + np + 1;
+ i__2 = lopt, i__3 = (integer) work[i__4].r;
+ i__1 = *m + np + max(i__2,i__3);
+ work[1].r = (real) i__1, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CGGGLM */
+
+} /* cggglm_ */
diff --git a/SRC/cgghrd.c b/SRC/cgghrd.c
new file mode 100644
index 0000000..18bc120
--- /dev/null
+++ b/SRC/cgghrd.c
@@ -0,0 +1,336 @@
+/* cgghrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static complex c_b2 = {0.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cgghrd_(char *compq, char *compz, integer *n, integer *
+ ilo, integer *ihi, complex *a, integer *lda, complex *b, integer *ldb,
+ complex *q, integer *ldq, complex *z__, integer *ldz, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
+ z_offset, i__1, i__2, i__3;
+ complex q__1;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ real c__;
+ complex s;
+ logical ilq, ilz;
+ integer jcol;
+ extern /* Subroutine */ int crot_(integer *, complex *, integer *,
+ complex *, integer *, real *, complex *);
+ integer jrow;
+ extern logical lsame_(char *, char *);
+ complex ctemp;
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), clartg_(complex *,
+ complex *, real *, complex *, complex *), xerbla_(char *, integer
+ *);
+ integer icompq, icompz;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGGHRD reduces a pair of complex matrices (A,B) to generalized upper */
+/* Hessenberg form using unitary transformations, where A is a */
+/* general matrix and B is upper triangular. The form of the generalized */
+/* eigenvalue problem is */
+/* A*x = lambda*B*x, */
+/* and B is typically made upper triangular by computing its QR */
+/* factorization and moving the unitary matrix Q to the left side */
+/* of the equation. */
+
+/* This subroutine simultaneously reduces A to a Hessenberg matrix H: */
+/* Q**H*A*Z = H */
+/* and transforms B to another upper triangular matrix T: */
+/* Q**H*B*Z = T */
+/* in order to reduce the problem to its standard form */
+/* H*y = lambda*T*y */
+/* where y = Z**H*x. */
+
+/* The unitary matrices Q and Z are determined as products of Givens */
+/* rotations. They may either be formed explicitly, or they may be */
+/* postmultiplied into input matrices Q1 and Z1, so that */
+/* Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H */
+/* Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H */
+/* If Q1 is the unitary matrix from the QR factorization of B in the */
+/* original equation A*x = lambda*B*x, then CGGHRD reduces the original */
+/* problem to generalized Hessenberg form. */
+
+/* Arguments */
+/* ========= */
+
+/* COMPQ (input) CHARACTER*1 */
+/* = 'N': do not compute Q; */
+/* = 'I': Q is initialized to the unit matrix, and the */
+/* unitary matrix Q is returned; */
+/* = 'V': Q must contain a unitary matrix Q1 on entry, */
+/* and the product Q1*Q is returned. */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': do not compute Q; */
+/* = 'I': Q is initialized to the unit matrix, and the */
+/* unitary matrix Q is returned; */
+/* = 'V': Q must contain a unitary matrix Q1 on entry, */
+/* and the product Q1*Q is returned. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* ILO and IHI mark the rows and columns of A which are to be */
+/* reduced. It is assumed that A is already upper triangular */
+/* in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are */
+/* normally set by a previous call to CGGBAL; otherwise they */
+/* should be set to 1 and N respectively. */
+/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA, N) */
+/* On entry, the N-by-N general matrix to be reduced. */
+/* On exit, the upper triangle and the first subdiagonal of A */
+/* are overwritten with the upper Hessenberg matrix H, and the */
+/* rest is set to zero. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX array, dimension (LDB, N) */
+/* On entry, the N-by-N upper triangular matrix B. */
+/* On exit, the upper triangular matrix T = Q**H B Z. The */
+/* elements below the diagonal are set to zero. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Q (input/output) COMPLEX array, dimension (LDQ, N) */
+/* On entry, if COMPQ = 'V', the unitary matrix Q1, typically */
+/* from the QR factorization of B. */
+/* On exit, if COMPQ='I', the unitary matrix Q, and if */
+/* COMPQ = 'V', the product Q1*Q. */
+/* Not referenced if COMPQ='N'. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. */
+/* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. */
+
+/* Z (input/output) COMPLEX array, dimension (LDZ, N) */
+/* On entry, if COMPZ = 'V', the unitary matrix Z1. */
+/* On exit, if COMPZ='I', the unitary matrix Z, and if */
+/* COMPZ = 'V', the product Z1*Z. */
+/* Not referenced if COMPZ='N'. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. */
+/* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* This routine reduces A to Hessenberg and B to triangular form by */
+/* an unblocked reduction, as described in _Matrix_Computations_, */
+/* by Golub and van Loan (Johns Hopkins Press). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode COMPQ */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+
+ /* Function Body */
+ if (lsame_(compq, "N")) {
+ ilq = FALSE_;
+ icompq = 1;
+ } else if (lsame_(compq, "V")) {
+ ilq = TRUE_;
+ icompq = 2;
+ } else if (lsame_(compq, "I")) {
+ ilq = TRUE_;
+ icompq = 3;
+ } else {
+ icompq = 0;
+ }
+
+/* Decode COMPZ */
+
+ if (lsame_(compz, "N")) {
+ ilz = FALSE_;
+ icompz = 1;
+ } else if (lsame_(compz, "V")) {
+ ilz = TRUE_;
+ icompz = 2;
+ } else if (lsame_(compz, "I")) {
+ ilz = TRUE_;
+ icompz = 3;
+ } else {
+ icompz = 0;
+ }
+
+/* Test the input parameters. */
+
+ *info = 0;
+ if (icompq <= 0) {
+ *info = -1;
+ } else if (icompz <= 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ilo < 1) {
+ *info = -4;
+ } else if (*ihi > *n || *ihi < *ilo - 1) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (ilq && *ldq < *n || *ldq < 1) {
+ *info = -11;
+ } else if (ilz && *ldz < *n || *ldz < 1) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGGHRD", &i__1);
+ return 0;
+ }
+
+/* Initialize Q and Z if desired. */
+
+ if (icompq == 3) {
+ claset_("Full", n, n, &c_b2, &c_b1, &q[q_offset], ldq);
+ }
+ if (icompz == 3) {
+ claset_("Full", n, n, &c_b2, &c_b1, &z__[z_offset], ldz);
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 1) {
+ return 0;
+ }
+
+/* Zero out lower triangle of B */
+
+ i__1 = *n - 1;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ i__2 = *n;
+ for (jrow = jcol + 1; jrow <= i__2; ++jrow) {
+ i__3 = jrow + jcol * b_dim1;
+ b[i__3].r = 0.f, b[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Reduce A and B */
+
+ i__1 = *ihi - 2;
+ for (jcol = *ilo; jcol <= i__1; ++jcol) {
+
+ i__2 = jcol + 2;
+ for (jrow = *ihi; jrow >= i__2; --jrow) {
+
+/* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL) */
+
+ i__3 = jrow - 1 + jcol * a_dim1;
+ ctemp.r = a[i__3].r, ctemp.i = a[i__3].i;
+ clartg_(&ctemp, &a[jrow + jcol * a_dim1], &c__, &s, &a[jrow - 1 +
+ jcol * a_dim1]);
+ i__3 = jrow + jcol * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ i__3 = *n - jcol;
+ crot_(&i__3, &a[jrow - 1 + (jcol + 1) * a_dim1], lda, &a[jrow + (
+ jcol + 1) * a_dim1], lda, &c__, &s);
+ i__3 = *n + 2 - jrow;
+ crot_(&i__3, &b[jrow - 1 + (jrow - 1) * b_dim1], ldb, &b[jrow + (
+ jrow - 1) * b_dim1], ldb, &c__, &s);
+ if (ilq) {
+ r_cnjg(&q__1, &s);
+ crot_(n, &q[(jrow - 1) * q_dim1 + 1], &c__1, &q[jrow * q_dim1
+ + 1], &c__1, &c__, &q__1);
+ }
+
+/* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1) */
+
+ i__3 = jrow + jrow * b_dim1;
+ ctemp.r = b[i__3].r, ctemp.i = b[i__3].i;
+ clartg_(&ctemp, &b[jrow + (jrow - 1) * b_dim1], &c__, &s, &b[jrow
+ + jrow * b_dim1]);
+ i__3 = jrow + (jrow - 1) * b_dim1;
+ b[i__3].r = 0.f, b[i__3].i = 0.f;
+ crot_(ihi, &a[jrow * a_dim1 + 1], &c__1, &a[(jrow - 1) * a_dim1 +
+ 1], &c__1, &c__, &s);
+ i__3 = jrow - 1;
+ crot_(&i__3, &b[jrow * b_dim1 + 1], &c__1, &b[(jrow - 1) * b_dim1
+ + 1], &c__1, &c__, &s);
+ if (ilz) {
+ crot_(n, &z__[jrow * z_dim1 + 1], &c__1, &z__[(jrow - 1) *
+ z_dim1 + 1], &c__1, &c__, &s);
+ }
+/* L30: */
+ }
+/* L40: */
+ }
+
+ return 0;
+
+/* End of CGGHRD */
+
+} /* cgghrd_ */
diff --git a/SRC/cgglse.c b/SRC/cgglse.c
new file mode 100644
index 0000000..a57f3d4
--- /dev/null
+++ b/SRC/cgglse.c
@@ -0,0 +1,342 @@
+/* cgglse.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cgglse_(integer *m, integer *n, integer *p, complex *a,
+ integer *lda, complex *b, integer *ldb, complex *c__, complex *d__,
+ complex *x, complex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
+ complex q__1;
+
+ /* Local variables */
+ integer nb, mn, nr, nb1, nb2, nb3, nb4, lopt;
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *), ccopy_(integer *, complex *, integer *,
+ complex *, integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *), ctrmv_(char *, char *, char *,
+ integer *, complex *, integer *, complex *, integer *), cggrqf_(integer *, integer *, integer *, complex
+ *, integer *, complex *, complex *, integer *, complex *, complex
+ *, integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer lwkmin;
+ extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *), cunmrq_(char *,
+ char *, integer *, integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *, complex *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int ctrtrs_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGGLSE solves the linear equality-constrained least squares (LSE) */
+/* problem: */
+
+/* minimize || c - A*x ||_2 subject to B*x = d */
+
+/* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given */
+/* M-vector, and d is a given P-vector. It is assumed that */
+/* P <= N <= M+P, and */
+
+/* rank(B) = P and rank( (A) ) = N. */
+/* ( (B) ) */
+
+/* These conditions ensure that the LSE problem has a unique solution, */
+/* which is obtained using a generalized RQ factorization of the */
+/* matrices (B, A) given by */
+
+/* B = (0 R)*Q, A = Z*T*Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. 0 <= P <= N <= M+P. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(M,N)-by-N upper trapezoidal matrix T. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix B. */
+/* On exit, the upper triangle of the subarray B(1:P,N-P+1:N) */
+/* contains the P-by-P upper triangular matrix R. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,P). */
+
+/* C (input/output) COMPLEX array, dimension (M) */
+/* On entry, C contains the right hand side vector for the */
+/* least squares part of the LSE problem. */
+/* On exit, the residual sum of squares for the solution */
+/* is given by the sum of squares of elements N-P+1 to M of */
+/* vector C. */
+
+/* D (input/output) COMPLEX array, dimension (P) */
+/* On entry, D contains the right hand side vector for the */
+/* constrained equation. */
+/* On exit, D is destroyed. */
+
+/* X (output) COMPLEX array, dimension (N) */
+/* On exit, X is the solution of the LSE problem. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M+N+P). */
+/* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB, */
+/* where NB is an upper bound for the optimal blocksizes for */
+/* CGEQRF, CGERQF, CUNMQR and CUNMRQ. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1: the upper triangular factor R associated with B in the */
+/* generalized RQ factorization of the pair (B, A) is */
+/* singular, so that rank(B) < P; the least squares */
+/* solution could not be computed. */
+/* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor */
+/* T associated with A in the generalized RQ factorization */
+/* of the pair (B, A) is singular, so that */
+/* rank( (A) ) < N; the least squares solution could not */
+/* ( (B) ) */
+/* be computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --c__;
+ --d__;
+ --x;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ mn = min(*m,*n);
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*p < 0 || *p > *n || *p < *n - *m) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*p)) {
+ *info = -7;
+ }
+
+/* Calculate workspace */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ lwkmin = 1;
+ lwkopt = 1;
+ } else {
+ nb1 = ilaenv_(&c__1, "CGEQRF", " ", m, n, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "CGERQF", " ", m, n, &c_n1, &c_n1);
+ nb3 = ilaenv_(&c__1, "CUNMQR", " ", m, n, p, &c_n1);
+ nb4 = ilaenv_(&c__1, "CUNMRQ", " ", m, n, p, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2), i__1 = max(i__1,nb3);
+ nb = max(i__1,nb4);
+ lwkmin = *m + *n + *p;
+ lwkopt = *p + mn + max(*m,*n) * nb;
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ if (*lwork < lwkmin && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGGLSE", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Compute the GRQ factorization of matrices B and A: */
+
+/* B*Q' = ( 0 T12 ) P Z'*A*Q' = ( R11 R12 ) N-P */
+/* N-P P ( 0 R22 ) M+P-N */
+/* N-P P */
+
+/* where T12 and R11 are upper triangular, and Q and Z are */
+/* unitary. */
+
+ i__1 = *lwork - *p - mn;
+ cggrqf_(p, m, n, &b[b_offset], ldb, &work[1], &a[a_offset], lda, &work[*p
+ + 1], &work[*p + mn + 1], &i__1, info);
+ i__1 = *p + mn + 1;
+ lopt = work[i__1].r;
+
+/* Update c = Z'*c = ( c1 ) N-P */
+/* ( c2 ) M+P-N */
+
+ i__1 = max(1,*m);
+ i__2 = *lwork - *p - mn;
+ cunmqr_("Left", "Conjugate Transpose", m, &c__1, &mn, &a[a_offset], lda, &
+ work[*p + 1], &c__[1], &i__1, &work[*p + mn + 1], &i__2, info);
+/* Computing MAX */
+ i__3 = *p + mn + 1;
+ i__1 = lopt, i__2 = (integer) work[i__3].r;
+ lopt = max(i__1,i__2);
+
+/* Solve T12*x2 = d for x2 */
+
+ if (*p > 0) {
+ ctrtrs_("Upper", "No transpose", "Non-unit", p, &c__1, &b[(*n - *p +
+ 1) * b_dim1 + 1], ldb, &d__[1], p, info);
+
+ if (*info > 0) {
+ *info = 1;
+ return 0;
+ }
+
+/* Put the solution in X */
+
+ ccopy_(p, &d__[1], &c__1, &x[*n - *p + 1], &c__1);
+
+/* Update c1 */
+
+ i__1 = *n - *p;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__1, p, &q__1, &a[(*n - *p + 1) * a_dim1 + 1]
+, lda, &d__[1], &c__1, &c_b1, &c__[1], &c__1);
+ }
+
+/* Solve R11*x1 = c1 for x1 */
+
+ if (*n > *p) {
+ i__1 = *n - *p;
+ i__2 = *n - *p;
+ ctrtrs_("Upper", "No transpose", "Non-unit", &i__1, &c__1, &a[
+ a_offset], lda, &c__[1], &i__2, info);
+
+ if (*info > 0) {
+ *info = 2;
+ return 0;
+ }
+
+/* Put the solutions in X */
+
+ i__1 = *n - *p;
+ ccopy_(&i__1, &c__[1], &c__1, &x[1], &c__1);
+ }
+
+/* Compute the residual vector: */
+
+ if (*m < *n) {
+ nr = *m + *p - *n;
+ if (nr > 0) {
+ i__1 = *n - *m;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &nr, &i__1, &q__1, &a[*n - *p + 1 + (*m +
+ 1) * a_dim1], lda, &d__[nr + 1], &c__1, &c_b1, &c__[*n - *
+ p + 1], &c__1);
+ }
+ } else {
+ nr = *p;
+ }
+ if (nr > 0) {
+ ctrmv_("Upper", "No transpose", "Non unit", &nr, &a[*n - *p + 1 + (*n
+ - *p + 1) * a_dim1], lda, &d__[1], &c__1);
+ q__1.r = -1.f, q__1.i = -0.f;
+ caxpy_(&nr, &q__1, &d__[1], &c__1, &c__[*n - *p + 1], &c__1);
+ }
+
+/* Backward transformation x = Q'*x */
+
+ i__1 = *lwork - *p - mn;
+ cunmrq_("Left", "Conjugate Transpose", n, &c__1, p, &b[b_offset], ldb, &
+ work[1], &x[1], n, &work[*p + mn + 1], &i__1, info);
+/* Computing MAX */
+ i__4 = *p + mn + 1;
+ i__2 = lopt, i__3 = (integer) work[i__4].r;
+ i__1 = *p + mn + max(i__2,i__3);
+ work[1].r = (real) i__1, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CGGLSE */
+
+} /* cgglse_ */
diff --git a/SRC/cggqrf.c b/SRC/cggqrf.c
new file mode 100644
index 0000000..41c861a
--- /dev/null
+++ b/SRC/cggqrf.c
@@ -0,0 +1,268 @@
+/* cggqrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cggqrf_(integer *n, integer *m, integer *p, complex *a,
+ integer *lda, complex *taua, complex *b, integer *ldb, complex *taub,
+ complex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer nb, nb1, nb2, nb3, lopt;
+ extern /* Subroutine */ int cgeqrf_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *), cgerqf_(
+ integer *, integer *, complex *, integer *, complex *, complex *,
+ integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGGQRF computes a generalized QR factorization of an N-by-M matrix A */
+/* and an N-by-P matrix B: */
+
+/* A = Q*R, B = Q*T*Z, */
+
+/* where Q is an N-by-N unitary matrix, Z is a P-by-P unitary matrix, */
+/* and R and T assume one of the forms: */
+
+/* if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N, */
+/* ( 0 ) N-M N M-N */
+/* M */
+
+/* where R11 is upper triangular, and */
+
+/* if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P, */
+/* P-N N ( T21 ) P */
+/* P */
+
+/* where T12 or T21 is upper triangular. */
+
+/* In particular, if B is square and nonsingular, the GQR factorization */
+/* of A and B implicitly gives the QR factorization of inv(B)*A: */
+
+/* inv(B)*A = Z'*(inv(T)*R) */
+
+/* where inv(B) denotes the inverse of the matrix B, and Z' denotes the */
+/* conjugate transpose of matrix Z. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices A and B. N >= 0. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of columns of the matrix B. P >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,M) */
+/* On entry, the N-by-M matrix A. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(N,M)-by-M upper trapezoidal matrix R (R is */
+/* upper triangular if N >= M); the elements below the diagonal, */
+/* with the array TAUA, represent the unitary matrix Q as a */
+/* product of min(N,M) elementary reflectors (see Further */
+/* Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAUA (output) COMPLEX array, dimension (min(N,M)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the unitary matrix Q (see Further Details). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,P) */
+/* On entry, the N-by-P matrix B. */
+/* On exit, if N <= P, the upper triangle of the subarray */
+/* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T; */
+/* if N > P, the elements on and above the (N-P)-th subdiagonal */
+/* contain the N-by-P upper trapezoidal matrix T; the remaining */
+/* elements, with the array TAUB, represent the unitary */
+/* matrix Z as a product of elementary reflectors (see Further */
+/* Details). */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* TAUB (output) COMPLEX array, dimension (min(N,P)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the unitary matrix Z (see Further Details). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N,M,P). */
+/* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3), */
+/* where NB1 is the optimal blocksize for the QR factorization */
+/* of an N-by-M matrix, NB2 is the optimal blocksize for the */
+/* RQ factorization of an N-by-P matrix, and NB3 is the optimal */
+/* blocksize for a call of CUNMQR. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(n,m). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - taua * v * v' */
+
+/* where taua is a complex scalar, and v is a complex vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */
+/* and taua in TAUA(i). */
+/* To form Q explicitly, use LAPACK subroutine CUNGQR. */
+/* To use Q to update another matrix, use LAPACK subroutine CUNMQR. */
+
+/* The matrix Z is represented as a product of elementary reflectors */
+
+/* Z = H(1) H(2) . . . H(k), where k = min(n,p). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - taub * v * v' */
+
+/* where taub is a complex scalar, and v is a complex vector with */
+/* v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in */
+/* B(n-k+i,1:p-k+i-1), and taub in TAUB(i). */
+/* To form Z explicitly, use LAPACK subroutine CUNGRQ. */
+/* To use Z to update another matrix, use LAPACK subroutine CUNMRQ. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --taua;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --taub;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb1 = ilaenv_(&c__1, "CGEQRF", " ", n, m, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "CGERQF", " ", n, p, &c_n1, &c_n1);
+ nb3 = ilaenv_(&c__1, "CUNMQR", " ", n, m, p, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2);
+ nb = max(i__1,nb3);
+/* Computing MAX */
+ i__1 = max(*n,*m);
+ lwkopt = max(i__1,*p) * nb;
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ lquery = *lwork == -1;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*p < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*n), i__1 = max(i__1,*m);
+ if (*lwork < max(i__1,*p) && ! lquery) {
+ *info = -11;
+ }
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGGQRF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* QR factorization of N-by-M matrix A: A = Q*R */
+
+ cgeqrf_(n, m, &a[a_offset], lda, &taua[1], &work[1], lwork, info);
+ lopt = work[1].r;
+
+/* Update B := Q'*B. */
+
+ i__1 = min(*n,*m);
+ cunmqr_("Left", "Conjugate Transpose", n, p, &i__1, &a[a_offset], lda, &
+ taua[1], &b[b_offset], ldb, &work[1], lwork, info);
+/* Computing MAX */
+ i__1 = lopt, i__2 = (integer) work[1].r;
+ lopt = max(i__1,i__2);
+
+/* RQ factorization of N-by-P matrix B: B = T*Z. */
+
+ cgerqf_(n, p, &b[b_offset], ldb, &taub[1], &work[1], lwork, info);
+/* Computing MAX */
+ i__2 = lopt, i__3 = (integer) work[1].r;
+ i__1 = max(i__2,i__3);
+ work[1].r = (real) i__1, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CGGQRF */
+
+} /* cggqrf_ */
diff --git a/SRC/cggrqf.c b/SRC/cggrqf.c
new file mode 100644
index 0000000..2653aea
--- /dev/null
+++ b/SRC/cggrqf.c
@@ -0,0 +1,269 @@
+/* cggrqf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cggrqf_(integer *m, integer *p, integer *n, complex *a,
+ integer *lda, complex *taua, complex *b, integer *ldb, complex *taub,
+ complex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer nb, nb1, nb2, nb3, lopt;
+ extern /* Subroutine */ int cgeqrf_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *), cgerqf_(
+ integer *, integer *, complex *, integer *, complex *, complex *,
+ integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int cunmrq_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGGRQF computes a generalized RQ factorization of an M-by-N matrix A */
+/* and a P-by-N matrix B: */
+
+/* A = R*Q, B = Z*T*Q, */
+
+/* where Q is an N-by-N unitary matrix, Z is a P-by-P unitary */
+/* matrix, and R and T assume one of the forms: */
+
+/* if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N, */
+/* N-M M ( R21 ) N */
+/* N */
+
+/* where R12 or R21 is upper triangular, and */
+
+/* if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P, */
+/* ( 0 ) P-N P N-P */
+/* N */
+
+/* where T11 is upper triangular. */
+
+/* In particular, if B is square and nonsingular, the GRQ factorization */
+/* of A and B implicitly gives the RQ factorization of A*inv(B): */
+
+/* A*inv(B) = (R*inv(T))*Z' */
+
+/* where inv(B) denotes the inverse of the matrix B, and Z' denotes the */
+/* conjugate transpose of the matrix Z. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, if M <= N, the upper triangle of the subarray */
+/* A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R; */
+/* if M > N, the elements on and above the (M-N)-th subdiagonal */
+/* contain the M-by-N upper trapezoidal matrix R; the remaining */
+/* elements, with the array TAUA, represent the unitary */
+/* matrix Q as a product of elementary reflectors (see Further */
+/* Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAUA (output) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the unitary matrix Q (see Further Details). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix B. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(P,N)-by-N upper trapezoidal matrix T (T is */
+/* upper triangular if P >= N); the elements below the diagonal, */
+/* with the array TAUB, represent the unitary matrix Z as a */
+/* product of elementary reflectors (see Further Details). */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,P). */
+
+/* TAUB (output) COMPLEX array, dimension (min(P,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the unitary matrix Z (see Further Details). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N,M,P). */
+/* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3), */
+/* where NB1 is the optimal blocksize for the RQ factorization */
+/* of an M-by-N matrix, NB2 is the optimal blocksize for the */
+/* QR factorization of a P-by-N matrix, and NB3 is the optimal */
+/* blocksize for a call of CUNMRQ. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO=-i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - taua * v * v' */
+
+/* where taua is a complex scalar, and v is a complex vector with */
+/* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in */
+/* A(m-k+i,1:n-k+i-1), and taua in TAUA(i). */
+/* To form Q explicitly, use LAPACK subroutine CUNGRQ. */
+/* To use Q to update another matrix, use LAPACK subroutine CUNMRQ. */
+
+/* The matrix Z is represented as a product of elementary reflectors */
+
+/* Z = H(1) H(2) . . . H(k), where k = min(p,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - taub * v * v' */
+
+/* where taub is a complex scalar, and v is a complex vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i), */
+/* and taub in TAUB(i). */
+/* To form Z explicitly, use LAPACK subroutine CUNGQR. */
+/* To use Z to update another matrix, use LAPACK subroutine CUNMQR. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --taua;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --taub;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb1 = ilaenv_(&c__1, "CGERQF", " ", m, n, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "CGEQRF", " ", p, n, &c_n1, &c_n1);
+ nb3 = ilaenv_(&c__1, "CUNMRQ", " ", m, n, p, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2);
+ nb = max(i__1,nb3);
+/* Computing MAX */
+ i__1 = max(*n,*m);
+ lwkopt = max(i__1,*p) * nb;
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*p < 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*p)) {
+ *info = -8;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*m), i__1 = max(i__1,*p);
+ if (*lwork < max(i__1,*n) && ! lquery) {
+ *info = -11;
+ }
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGGRQF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* RQ factorization of M-by-N matrix A: A = R*Q */
+
+ cgerqf_(m, n, &a[a_offset], lda, &taua[1], &work[1], lwork, info);
+ lopt = work[1].r;
+
+/* Update B := B*Q' */
+
+ i__1 = min(*m,*n);
+/* Computing MAX */
+ i__2 = 1, i__3 = *m - *n + 1;
+ cunmrq_("Right", "Conjugate Transpose", p, n, &i__1, &a[max(i__2, i__3)+
+ a_dim1], lda, &taua[1], &b[b_offset], ldb, &work[1], lwork, info);
+/* Computing MAX */
+ i__1 = lopt, i__2 = (integer) work[1].r;
+ lopt = max(i__1,i__2);
+
+/* QR factorization of P-by-N matrix B: B = Z*T */
+
+ cgeqrf_(p, n, &b[b_offset], ldb, &taub[1], &work[1], lwork, info);
+/* Computing MAX */
+ i__2 = lopt, i__3 = (integer) work[1].r;
+ i__1 = max(i__2,i__3);
+ work[1].r = (real) i__1, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CGGRQF */
+
+} /* cggrqf_ */
diff --git a/SRC/cggsvd.c b/SRC/cggsvd.c
new file mode 100644
index 0000000..9415098
--- /dev/null
+++ b/SRC/cggsvd.c
@@ -0,0 +1,403 @@
+/* cggsvd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cggsvd_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *n, integer *p, integer *k, integer *l, complex *a, integer *
+ lda, complex *b, integer *ldb, real *alpha, real *beta, complex *u,
+ integer *ldu, complex *v, integer *ldv, complex *q, integer *ldq,
+ complex *work, real *rwork, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1,
+ u_offset, v_dim1, v_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ real ulp;
+ integer ibnd;
+ real tola;
+ integer isub;
+ real tolb, unfl, temp, smax;
+ extern logical lsame_(char *, char *);
+ real anorm, bnorm;
+ logical wantq;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ logical wantu, wantv;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int ctgsja_(char *, char *, char *, integer *,
+ integer *, integer *, integer *, integer *, complex *, integer *,
+ complex *, integer *, real *, real *, real *, real *, complex *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, integer *);
+ integer ncycle;
+ extern /* Subroutine */ int xerbla_(char *, integer *), cggsvp_(
+ char *, char *, char *, integer *, integer *, integer *, complex *
+, integer *, complex *, integer *, real *, real *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, integer *, real *, complex *, complex *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGGSVD computes the generalized singular value decomposition (GSVD) */
+/* of an M-by-N complex matrix A and P-by-N complex matrix B: */
+
+/* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ) */
+
+/* where U, V and Q are unitary matrices, and Z' means the conjugate */
+/* transpose of Z. Let K+L = the effective numerical rank of the */
+/* matrix (A',B')', then R is a (K+L)-by-(K+L) nonsingular upper */
+/* triangular matrix, D1 and D2 are M-by-(K+L) and P-by-(K+L) "diagonal" */
+/* matrices and of the following structures, respectively: */
+
+/* If M-K-L >= 0, */
+
+/* K L */
+/* D1 = K ( I 0 ) */
+/* L ( 0 C ) */
+/* M-K-L ( 0 0 ) */
+
+/* K L */
+/* D2 = L ( 0 S ) */
+/* P-L ( 0 0 ) */
+
+/* N-K-L K L */
+/* ( 0 R ) = K ( 0 R11 R12 ) */
+/* L ( 0 0 R22 ) */
+/* where */
+
+/* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */
+/* S = diag( BETA(K+1), ... , BETA(K+L) ), */
+/* C**2 + S**2 = I. */
+
+/* R is stored in A(1:K+L,N-K-L+1:N) on exit. */
+
+/* If M-K-L < 0, */
+
+/* K M-K K+L-M */
+/* D1 = K ( I 0 0 ) */
+/* M-K ( 0 C 0 ) */
+
+/* K M-K K+L-M */
+/* D2 = M-K ( 0 S 0 ) */
+/* K+L-M ( 0 0 I ) */
+/* P-L ( 0 0 0 ) */
+
+/* N-K-L K M-K K+L-M */
+/* ( 0 R ) = K ( 0 R11 R12 R13 ) */
+/* M-K ( 0 0 R22 R23 ) */
+/* K+L-M ( 0 0 0 R33 ) */
+
+/* where */
+
+/* C = diag( ALPHA(K+1), ... , ALPHA(M) ), */
+/* S = diag( BETA(K+1), ... , BETA(M) ), */
+/* C**2 + S**2 = I. */
+
+/* (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored */
+/* ( 0 R22 R23 ) */
+/* in B(M-K+1:L,N+M-K-L+1:N) on exit. */
+
+/* The routine computes C, S, R, and optionally the unitary */
+/* transformation matrices U, V and Q. */
+
+/* In particular, if B is an N-by-N nonsingular matrix, then the GSVD of */
+/* A and B implicitly gives the SVD of A*inv(B): */
+/* A*inv(B) = U*(D1*inv(D2))*V'. */
+/* If ( A',B')' has orthnormal columns, then the GSVD of A and B is also */
+/* equal to the CS decomposition of A and B. Furthermore, the GSVD can */
+/* be used to derive the solution of the eigenvalue problem: */
+/* A'*A x = lambda* B'*B x. */
+/* In some literature, the GSVD of A and B is presented in the form */
+/* U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 ) */
+/* where U and V are orthogonal and X is nonsingular, and D1 and D2 are */
+/* ``diagonal''. The former GSVD form can be converted to the latter */
+/* form by taking the nonsingular matrix X as */
+
+/* X = Q*( I 0 ) */
+/* ( 0 inv(R) ) */
+
+/* Arguments */
+/* ========= */
+
+/* JOBU (input) CHARACTER*1 */
+/* = 'U': Unitary matrix U is computed; */
+/* = 'N': U is not computed. */
+
+/* JOBV (input) CHARACTER*1 */
+/* = 'V': Unitary matrix V is computed; */
+/* = 'N': V is not computed. */
+
+/* JOBQ (input) CHARACTER*1 */
+/* = 'Q': Unitary matrix Q is computed; */
+/* = 'N': Q is not computed. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* K (output) INTEGER */
+/* L (output) INTEGER */
+/* On exit, K and L specify the dimension of the subblocks */
+/* described in Purpose. */
+/* K + L = effective numerical rank of (A',B')'. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A contains the triangular matrix R, or part of R. */
+/* See Purpose for details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix B. */
+/* On exit, B contains part of the triangular matrix R if */
+/* M-K-L < 0. See Purpose for details. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,P). */
+
+/* ALPHA (output) REAL array, dimension (N) */
+/* BETA (output) REAL array, dimension (N) */
+/* On exit, ALPHA and BETA contain the generalized singular */
+/* value pairs of A and B; */
+/* ALPHA(1:K) = 1, */
+/* BETA(1:K) = 0, */
+/* and if M-K-L >= 0, */
+/* ALPHA(K+1:K+L) = C, */
+/* BETA(K+1:K+L) = S, */
+/* or if M-K-L < 0, */
+/* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0 */
+/* BETA(K+1:M) = S, BETA(M+1:K+L) = 1 */
+/* and */
+/* ALPHA(K+L+1:N) = 0 */
+/* BETA(K+L+1:N) = 0 */
+
+/* U (output) COMPLEX array, dimension (LDU,M) */
+/* If JOBU = 'U', U contains the M-by-M unitary matrix U. */
+/* If JOBU = 'N', U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M) if */
+/* JOBU = 'U'; LDU >= 1 otherwise. */
+
+/* V (output) COMPLEX array, dimension (LDV,P) */
+/* If JOBV = 'V', V contains the P-by-P unitary matrix V. */
+/* If JOBV = 'N', V is not referenced. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. LDV >= max(1,P) if */
+/* JOBV = 'V'; LDV >= 1 otherwise. */
+
+/* Q (output) COMPLEX array, dimension (LDQ,N) */
+/* If JOBQ = 'Q', Q contains the N-by-N unitary matrix Q. */
+/* If JOBQ = 'N', Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N) if */
+/* JOBQ = 'Q'; LDQ >= 1 otherwise. */
+
+/* WORK (workspace) COMPLEX array, dimension (max(3*N,M,P)+N) */
+
+/* RWORK (workspace) REAL array, dimension (2*N) */
+
+/* IWORK (workspace/output) INTEGER array, dimension (N) */
+/* On exit, IWORK stores the sorting information. More */
+/* precisely, the following loop will sort ALPHA */
+/* for I = K+1, min(M,K+L) */
+/* swap ALPHA(I) and ALPHA(IWORK(I)) */
+/* endfor */
+/* such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, the Jacobi-type procedure failed to */
+/* converge. For further details, see subroutine CTGSJA. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* TOLA REAL */
+/* TOLB REAL */
+/* TOLA and TOLB are the thresholds to determine the effective */
+/* rank of (A',B')'. Generally, they are set to */
+/* TOLA = MAX(M,N)*norm(A)*MACHEPS, */
+/* TOLB = MAX(P,N)*norm(B)*MACHEPS. */
+/* The size of TOLA and TOLB may affect the size of backward */
+/* errors of the decomposition. */
+
+/* Further Details */
+/* =============== */
+
+/* 2-96 Based on modifications by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alpha;
+ --beta;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ wantu = lsame_(jobu, "U");
+ wantv = lsame_(jobv, "V");
+ wantq = lsame_(jobq, "Q");
+
+ *info = 0;
+ if (! (wantu || lsame_(jobu, "N"))) {
+ *info = -1;
+ } else if (! (wantv || lsame_(jobv, "N"))) {
+ *info = -2;
+ } else if (! (wantq || lsame_(jobq, "N"))) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*p < 0) {
+ *info = -6;
+ } else if (*lda < max(1,*m)) {
+ *info = -10;
+ } else if (*ldb < max(1,*p)) {
+ *info = -12;
+ } else if (*ldu < 1 || wantu && *ldu < *m) {
+ *info = -16;
+ } else if (*ldv < 1 || wantv && *ldv < *p) {
+ *info = -18;
+ } else if (*ldq < 1 || wantq && *ldq < *n) {
+ *info = -20;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGGSVD", &i__1);
+ return 0;
+ }
+
+/* Compute the Frobenius norm of matrices A and B */
+
+ anorm = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ bnorm = clange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
+
+/* Get machine precision and set up threshold for determining */
+/* the effective numerical rank of the matrices A and B. */
+
+ ulp = slamch_("Precision");
+ unfl = slamch_("Safe Minimum");
+ tola = max(*m,*n) * dmax(anorm,unfl) * ulp;
+ tolb = max(*p,*n) * dmax(bnorm,unfl) * ulp;
+
+ cggsvp_(jobu, jobv, jobq, m, p, n, &a[a_offset], lda, &b[b_offset], ldb, &
+ tola, &tolb, k, l, &u[u_offset], ldu, &v[v_offset], ldv, &q[
+ q_offset], ldq, &iwork[1], &rwork[1], &work[1], &work[*n + 1],
+ info);
+
+/* Compute the GSVD of two upper "triangular" matrices */
+
+ ctgsja_(jobu, jobv, jobq, m, p, n, k, l, &a[a_offset], lda, &b[b_offset],
+ ldb, &tola, &tolb, &alpha[1], &beta[1], &u[u_offset], ldu, &v[
+ v_offset], ldv, &q[q_offset], ldq, &work[1], &ncycle, info);
+
+/* Sort the singular values and store the pivot indices in IWORK */
+/* Copy ALPHA to RWORK, then sort ALPHA in RWORK */
+
+ scopy_(n, &alpha[1], &c__1, &rwork[1], &c__1);
+/* Computing MIN */
+ i__1 = *l, i__2 = *m - *k;
+ ibnd = min(i__1,i__2);
+ i__1 = ibnd;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Scan for largest ALPHA(K+I) */
+
+ isub = i__;
+ smax = rwork[*k + i__];
+ i__2 = ibnd;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ temp = rwork[*k + j];
+ if (temp > smax) {
+ isub = j;
+ smax = temp;
+ }
+/* L10: */
+ }
+ if (isub != i__) {
+ rwork[*k + isub] = rwork[*k + i__];
+ rwork[*k + i__] = smax;
+ iwork[*k + i__] = *k + isub;
+ } else {
+ iwork[*k + i__] = *k + i__;
+ }
+/* L20: */
+ }
+
+ return 0;
+
+/* End of CGGSVD */
+
+} /* cggsvd_ */
diff --git a/SRC/cggsvp.c b/SRC/cggsvp.c
new file mode 100644
index 0000000..6f21946
--- /dev/null
+++ b/SRC/cggsvp.c
@@ -0,0 +1,530 @@
+/* cggsvp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+
+/* Subroutine */ int cggsvp_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *p, integer *n, complex *a, integer *lda, complex *b, integer
+ *ldb, real *tola, real *tolb, integer *k, integer *l, complex *u,
+ integer *ldu, complex *v, integer *ldv, complex *q, integer *ldq,
+ integer *iwork, real *rwork, complex *tau, complex *work, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1,
+ u_offset, v_dim1, v_offset, i__1, i__2, i__3;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j;
+ extern logical lsame_(char *, char *);
+ logical wantq, wantu, wantv;
+ extern /* Subroutine */ int cgeqr2_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *), cgerq2_(integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *),
+ cung2r_(integer *, integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *), cunm2r_(char *, char *, integer
+ *, integer *, integer *, complex *, integer *, complex *, complex
+ *, integer *, complex *, integer *), cunmr2_(char
+ *, char *, integer *, integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *, complex *, integer *), cgeqpf_(integer *, integer *, complex *, integer *,
+ integer *, complex *, complex *, real *, integer *), clacpy_(char
+ *, integer *, integer *, complex *, integer *, complex *, integer
+ *), claset_(char *, integer *, integer *, complex *,
+ complex *, complex *, integer *), xerbla_(char *, integer
+ *), clapmt_(logical *, integer *, integer *, complex *,
+ integer *, integer *);
+ logical forwrd;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGGSVP computes unitary matrices U, V and Q such that */
+
+/* N-K-L K L */
+/* U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0; */
+/* L ( 0 0 A23 ) */
+/* M-K-L ( 0 0 0 ) */
+
+/* N-K-L K L */
+/* = K ( 0 A12 A13 ) if M-K-L < 0; */
+/* M-K ( 0 0 A23 ) */
+
+/* N-K-L K L */
+/* V'*B*Q = L ( 0 0 B13 ) */
+/* P-L ( 0 0 0 ) */
+
+/* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */
+/* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */
+/* otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective */
+/* numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the */
+/* conjugate transpose of Z. */
+
+/* This decomposition is the preprocessing step for computing the */
+/* Generalized Singular Value Decomposition (GSVD), see subroutine */
+/* CGGSVD. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBU (input) CHARACTER*1 */
+/* = 'U': Unitary matrix U is computed; */
+/* = 'N': U is not computed. */
+
+/* JOBV (input) CHARACTER*1 */
+/* = 'V': Unitary matrix V is computed; */
+/* = 'N': V is not computed. */
+
+/* JOBQ (input) CHARACTER*1 */
+/* = 'Q': Unitary matrix Q is computed; */
+/* = 'N': Q is not computed. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A contains the triangular (or trapezoidal) matrix */
+/* described in the Purpose section. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix B. */
+/* On exit, B contains the triangular matrix described in */
+/* the Purpose section. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,P). */
+
+/* TOLA (input) REAL */
+/* TOLB (input) REAL */
+/* TOLA and TOLB are the thresholds to determine the effective */
+/* numerical rank of matrix B and a subblock of A. Generally, */
+/* they are set to */
+/* TOLA = MAX(M,N)*norm(A)*MACHEPS, */
+/* TOLB = MAX(P,N)*norm(B)*MACHEPS. */
+/* The size of TOLA and TOLB may affect the size of backward */
+/* errors of the decomposition. */
+
+/* K (output) INTEGER */
+/* L (output) INTEGER */
+/* On exit, K and L specify the dimension of the subblocks */
+/* described in Purpose section. */
+/* K + L = effective numerical rank of (A',B')'. */
+
+/* U (output) COMPLEX array, dimension (LDU,M) */
+/* If JOBU = 'U', U contains the unitary matrix U. */
+/* If JOBU = 'N', U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M) if */
+/* JOBU = 'U'; LDU >= 1 otherwise. */
+
+/* V (output) COMPLEX array, dimension (LDV,P) */
+/* If JOBV = 'V', V contains the unitary matrix V. */
+/* If JOBV = 'N', V is not referenced. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. LDV >= max(1,P) if */
+/* JOBV = 'V'; LDV >= 1 otherwise. */
+
+/* Q (output) COMPLEX array, dimension (LDQ,N) */
+/* If JOBQ = 'Q', Q contains the unitary matrix Q. */
+/* If JOBQ = 'N', Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N) if */
+/* JOBQ = 'Q'; LDQ >= 1 otherwise. */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* RWORK (workspace) REAL array, dimension (2*N) */
+
+/* TAU (workspace) COMPLEX array, dimension (N) */
+
+/* WORK (workspace) COMPLEX array, dimension (max(3*N,M,P)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The subroutine uses LAPACK subroutine CGEQPF for the QR factorization */
+/* with column pivoting to detect the effective numerical rank of the */
+/* a matrix. It may be replaced by a better rank determination strategy. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --iwork;
+ --rwork;
+ --tau;
+ --work;
+
+ /* Function Body */
+ wantu = lsame_(jobu, "U");
+ wantv = lsame_(jobv, "V");
+ wantq = lsame_(jobq, "Q");
+ forwrd = TRUE_;
+
+ *info = 0;
+ if (! (wantu || lsame_(jobu, "N"))) {
+ *info = -1;
+ } else if (! (wantv || lsame_(jobv, "N"))) {
+ *info = -2;
+ } else if (! (wantq || lsame_(jobq, "N"))) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*p < 0) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (*lda < max(1,*m)) {
+ *info = -8;
+ } else if (*ldb < max(1,*p)) {
+ *info = -10;
+ } else if (*ldu < 1 || wantu && *ldu < *m) {
+ *info = -16;
+ } else if (*ldv < 1 || wantv && *ldv < *p) {
+ *info = -18;
+ } else if (*ldq < 1 || wantq && *ldq < *n) {
+ *info = -20;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGGSVP", &i__1);
+ return 0;
+ }
+
+/* QR with column pivoting of B: B*P = V*( S11 S12 ) */
+/* ( 0 0 ) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ iwork[i__] = 0;
+/* L10: */
+ }
+ cgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], &rwork[1],
+ info);
+
+/* Update A := A*P */
+
+ clapmt_(&forwrd, m, n, &a[a_offset], lda, &iwork[1]);
+
+/* Determine the effective rank of matrix B. */
+
+ *l = 0;
+ i__1 = min(*p,*n);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * b_dim1;
+ if ((r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b[i__ + i__ *
+ b_dim1]), dabs(r__2)) > *tolb) {
+ ++(*l);
+ }
+/* L20: */
+ }
+
+ if (wantv) {
+
+/* Copy the details of V, and form V. */
+
+ claset_("Full", p, p, &c_b1, &c_b1, &v[v_offset], ldv);
+ if (*p > 1) {
+ i__1 = *p - 1;
+ clacpy_("Lower", &i__1, n, &b[b_dim1 + 2], ldb, &v[v_dim1 + 2],
+ ldv);
+ }
+ i__1 = min(*p,*n);
+ cung2r_(p, p, &i__1, &v[v_offset], ldv, &tau[1], &work[1], info);
+ }
+
+/* Clean up B */
+
+ i__1 = *l - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *l;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0.f, b[i__3].i = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+ if (*p > *l) {
+ i__1 = *p - *l;
+ claset_("Full", &i__1, n, &c_b1, &c_b1, &b[*l + 1 + b_dim1], ldb);
+ }
+
+ if (wantq) {
+
+/* Set Q = I and Update Q := Q*P */
+
+ claset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
+ clapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]);
+ }
+
+ if (*p >= *l && *n != *l) {
+
+/* RQ factorization of ( S11 S12 ) = ( 0 S12 )*Z */
+
+ cgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info);
+
+/* Update A := A*Z' */
+
+ cunmr2_("Right", "Conjugate transpose", m, n, l, &b[b_offset], ldb, &
+ tau[1], &a[a_offset], lda, &work[1], info);
+ if (wantq) {
+
+/* Update Q := Q*Z' */
+
+ cunmr2_("Right", "Conjugate transpose", n, n, l, &b[b_offset],
+ ldb, &tau[1], &q[q_offset], ldq, &work[1], info);
+ }
+
+/* Clean up B */
+
+ i__1 = *n - *l;
+ claset_("Full", l, &i__1, &c_b1, &c_b1, &b[b_offset], ldb);
+ i__1 = *n;
+ for (j = *n - *l + 1; j <= i__1; ++j) {
+ i__2 = *l;
+ for (i__ = j - *n + *l + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0.f, b[i__3].i = 0.f;
+/* L50: */
+ }
+/* L60: */
+ }
+
+ }
+
+/* Let N-L L */
+/* A = ( A11 A12 ) M, */
+
+/* then the following does the complete QR decomposition of A11: */
+
+/* A11 = U*( 0 T12 )*P1' */
+/* ( 0 0 ) */
+
+ i__1 = *n - *l;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ iwork[i__] = 0;
+/* L70: */
+ }
+ i__1 = *n - *l;
+ cgeqpf_(m, &i__1, &a[a_offset], lda, &iwork[1], &tau[1], &work[1], &rwork[
+ 1], info);
+
+/* Determine the effective rank of A11 */
+
+ *k = 0;
+/* Computing MIN */
+ i__2 = *m, i__3 = *n - *l;
+ i__1 = min(i__2,i__3);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ if ((r__1 = a[i__2].r, dabs(r__1)) + (r__2 = r_imag(&a[i__ + i__ *
+ a_dim1]), dabs(r__2)) > *tola) {
+ ++(*k);
+ }
+/* L80: */
+ }
+
+/* Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N ) */
+
+/* Computing MIN */
+ i__2 = *m, i__3 = *n - *l;
+ i__1 = min(i__2,i__3);
+ cunm2r_("Left", "Conjugate transpose", m, l, &i__1, &a[a_offset], lda, &
+ tau[1], &a[(*n - *l + 1) * a_dim1 + 1], lda, &work[1], info);
+
+ if (wantu) {
+
+/* Copy the details of U, and form U */
+
+ claset_("Full", m, m, &c_b1, &c_b1, &u[u_offset], ldu);
+ if (*m > 1) {
+ i__1 = *m - 1;
+ i__2 = *n - *l;
+ clacpy_("Lower", &i__1, &i__2, &a[a_dim1 + 2], lda, &u[u_dim1 + 2]
+, ldu);
+ }
+/* Computing MIN */
+ i__2 = *m, i__3 = *n - *l;
+ i__1 = min(i__2,i__3);
+ cung2r_(m, m, &i__1, &u[u_offset], ldu, &tau[1], &work[1], info);
+ }
+
+ if (wantq) {
+
+/* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 */
+
+ i__1 = *n - *l;
+ clapmt_(&forwrd, n, &i__1, &q[q_offset], ldq, &iwork[1]);
+ }
+
+/* Clean up A: set the strictly lower triangular part of */
+/* A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. */
+
+ i__1 = *k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *k;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L90: */
+ }
+/* L100: */
+ }
+ if (*m > *k) {
+ i__1 = *m - *k;
+ i__2 = *n - *l;
+ claset_("Full", &i__1, &i__2, &c_b1, &c_b1, &a[*k + 1 + a_dim1], lda);
+ }
+
+ if (*n - *l > *k) {
+
+/* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */
+
+ i__1 = *n - *l;
+ cgerq2_(k, &i__1, &a[a_offset], lda, &tau[1], &work[1], info);
+
+ if (wantq) {
+
+/* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1' */
+
+ i__1 = *n - *l;
+ cunmr2_("Right", "Conjugate transpose", n, &i__1, k, &a[a_offset],
+ lda, &tau[1], &q[q_offset], ldq, &work[1], info);
+ }
+
+/* Clean up A */
+
+ i__1 = *n - *l - *k;
+ claset_("Full", k, &i__1, &c_b1, &c_b1, &a[a_offset], lda);
+ i__1 = *n - *l;
+ for (j = *n - *l - *k + 1; j <= i__1; ++j) {
+ i__2 = *k;
+ for (i__ = j - *n + *l + *k + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L110: */
+ }
+/* L120: */
+ }
+
+ }
+
+ if (*m > *k) {
+
+/* QR factorization of A( K+1:M,N-L+1:N ) */
+
+ i__1 = *m - *k;
+ cgeqr2_(&i__1, l, &a[*k + 1 + (*n - *l + 1) * a_dim1], lda, &tau[1], &
+ work[1], info);
+
+ if (wantu) {
+
+/* Update U(:,K+1:M) := U(:,K+1:M)*U1 */
+
+ i__1 = *m - *k;
+/* Computing MIN */
+ i__3 = *m - *k;
+ i__2 = min(i__3,*l);
+ cunm2r_("Right", "No transpose", m, &i__1, &i__2, &a[*k + 1 + (*n
+ - *l + 1) * a_dim1], lda, &tau[1], &u[(*k + 1) * u_dim1 +
+ 1], ldu, &work[1], info);
+ }
+
+/* Clean up */
+
+ i__1 = *n;
+ for (j = *n - *l + 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j - *n + *k + *l + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L130: */
+ }
+/* L140: */
+ }
+
+ }
+
+ return 0;
+
+/* End of CGGSVP */
+
+} /* cggsvp_ */
diff --git a/SRC/cgtcon.c b/SRC/cgtcon.c
new file mode 100644
index 0000000..462a36a
--- /dev/null
+++ b/SRC/cgtcon.c
@@ -0,0 +1,207 @@
+/* cgtcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cgtcon_(char *norm, integer *n, complex *dl, complex *
+ d__, complex *du, complex *du2, integer *ipiv, real *anorm, real *
+ rcond, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, kase, kase1;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *), xerbla_(char *, integer *);
+ real ainvnm;
+ logical onenrm;
+ extern /* Subroutine */ int cgttrs_(char *, integer *, integer *, complex
+ *, complex *, complex *, complex *, integer *, complex *, integer
+ *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGTCON estimates the reciprocal of the condition number of a complex */
+/* tridiagonal matrix A using the LU factorization as computed by */
+/* CGTTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* DL (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) multipliers that define the matrix L from the */
+/* LU factorization of A as computed by CGTTRF. */
+
+/* D (input) COMPLEX array, dimension (N) */
+/* The n diagonal elements of the upper triangular matrix U from */
+/* the LU factorization of A. */
+
+/* DU (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) elements of the first superdiagonal of U. */
+
+/* DU2 (input) COMPLEX array, dimension (N-2) */
+/* The (n-2) elements of the second superdiagonal of U. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* ANORM (input) REAL */
+/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */
+/* If NORM = 'I', the infinity-norm of the original matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ --work;
+ --ipiv;
+ --du2;
+ --du;
+ --d__;
+ --dl;
+
+ /* Function Body */
+ *info = 0;
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*anorm < 0.f) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGTCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.f;
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ } else if (*anorm == 0.f) {
+ return 0;
+ }
+
+/* Check that D(1:N) is non-zero. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ if (d__[i__2].r == 0.f && d__[i__2].i == 0.f) {
+ return 0;
+ }
+/* L10: */
+ }
+
+ ainvnm = 0.f;
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kase = 0;
+L20:
+ clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(U)*inv(L). */
+
+ cgttrs_("No transpose", n, &c__1, &dl[1], &d__[1], &du[1], &du2[1]
+, &ipiv[1], &work[1], n, info);
+ } else {
+
+/* Multiply by inv(L')*inv(U'). */
+
+ cgttrs_("Conjugate transpose", n, &c__1, &dl[1], &d__[1], &du[1],
+ &du2[1], &ipiv[1], &work[1], n, info);
+ }
+ goto L20;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / ainvnm / *anorm;
+ }
+
+ return 0;
+
+/* End of CGTCON */
+
+} /* cgtcon_ */
diff --git a/SRC/cgtrfs.c b/SRC/cgtrfs.c
new file mode 100644
index 0000000..8589822
--- /dev/null
+++ b/SRC/cgtrfs.c
@@ -0,0 +1,553 @@
+/* cgtrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b18 = -1.f;
+static real c_b19 = 1.f;
+static complex c_b26 = {1.f,0.f};
+
+/* Subroutine */ int cgtrfs_(char *trans, integer *n, integer *nrhs, complex *
+ dl, complex *d__, complex *du, complex *dlf, complex *df, complex *
+ duf, complex *du2, integer *ipiv, complex *b, integer *ldb, complex *
+ x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6, i__7, i__8, i__9;
+ real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10, r__11,
+ r__12, r__13, r__14;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j;
+ real s;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ integer count;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *), clagtm_(char *, integer *, integer *,
+ real *, complex *, complex *, complex *, complex *, integer *,
+ real *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+ char transn[1];
+ extern /* Subroutine */ int cgttrs_(char *, integer *, integer *, complex
+ *, complex *, complex *, complex *, integer *, complex *, integer
+ *, integer *);
+ char transt[1];
+ real lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGTRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is tridiagonal, and provides */
+/* error bounds and backward error estimates for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* DL (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of A. */
+
+/* D (input) COMPLEX array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* DU (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) superdiagonal elements of A. */
+
+/* DLF (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) multipliers that define the matrix L from the */
+/* LU factorization of A as computed by CGTTRF. */
+
+/* DF (input) COMPLEX array, dimension (N) */
+/* The n diagonal elements of the upper triangular matrix U from */
+/* the LU factorization of A. */
+
+/* DUF (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) elements of the first superdiagonal of U. */
+
+/* DU2 (input) COMPLEX array, dimension (N-2) */
+/* The (n-2) elements of the second superdiagonal of U. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by CGTTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ --dlf;
+ --df;
+ --duf;
+ --du2;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -13;
+ } else if (*ldx < max(1,*n)) {
+ *info = -15;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGTRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transn = 'N';
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transn = 'C';
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = 4;
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.f;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A, A**T, or A**H, depending on TRANS. */
+
+ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ clagtm_(trans, n, &c__1, &c_b18, &dl[1], &d__[1], &du[1], &x[j *
+ x_dim1 + 1], ldx, &c_b19, &work[1], n);
+
+/* Compute abs(op(A))*abs(x) + abs(b) for use in the backward */
+/* error bound. */
+
+ if (notran) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * x_dim1 + 1;
+ rwork[1] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b[
+ j * b_dim1 + 1]), dabs(r__2)) + ((r__3 = d__[1].r,
+ dabs(r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) *
+ ((r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x[j
+ * x_dim1 + 1]), dabs(r__6)));
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * x_dim1 + 1;
+ i__4 = j * x_dim1 + 2;
+ rwork[1] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b[
+ j * b_dim1 + 1]), dabs(r__2)) + ((r__3 = d__[1].r,
+ dabs(r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) *
+ ((r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x[j
+ * x_dim1 + 1]), dabs(r__6))) + ((r__7 = du[1].r, dabs(
+ r__7)) + (r__8 = r_imag(&du[1]), dabs(r__8))) * ((
+ r__9 = x[i__4].r, dabs(r__9)) + (r__10 = r_imag(&x[j *
+ x_dim1 + 2]), dabs(r__10)));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ - 1;
+ i__5 = i__ - 1 + j * x_dim1;
+ i__6 = i__;
+ i__7 = i__ + j * x_dim1;
+ i__8 = i__;
+ i__9 = i__ + 1 + j * x_dim1;
+ rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&b[i__ + j * b_dim1]), dabs(r__2)) + ((
+ r__3 = dl[i__4].r, dabs(r__3)) + (r__4 = r_imag(&
+ dl[i__ - 1]), dabs(r__4))) * ((r__5 = x[i__5].r,
+ dabs(r__5)) + (r__6 = r_imag(&x[i__ - 1 + j *
+ x_dim1]), dabs(r__6))) + ((r__7 = d__[i__6].r,
+ dabs(r__7)) + (r__8 = r_imag(&d__[i__]), dabs(
+ r__8))) * ((r__9 = x[i__7].r, dabs(r__9)) + (
+ r__10 = r_imag(&x[i__ + j * x_dim1]), dabs(r__10))
+ ) + ((r__11 = du[i__8].r, dabs(r__11)) + (r__12 =
+ r_imag(&du[i__]), dabs(r__12))) * ((r__13 = x[
+ i__9].r, dabs(r__13)) + (r__14 = r_imag(&x[i__ +
+ 1 + j * x_dim1]), dabs(r__14)));
+/* L30: */
+ }
+ i__2 = *n + j * b_dim1;
+ i__3 = *n - 1;
+ i__4 = *n - 1 + j * x_dim1;
+ i__5 = *n;
+ i__6 = *n + j * x_dim1;
+ rwork[*n] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
+ b[*n + j * b_dim1]), dabs(r__2)) + ((r__3 = dl[i__3]
+ .r, dabs(r__3)) + (r__4 = r_imag(&dl[*n - 1]), dabs(
+ r__4))) * ((r__5 = x[i__4].r, dabs(r__5)) + (r__6 =
+ r_imag(&x[*n - 1 + j * x_dim1]), dabs(r__6))) + ((
+ r__7 = d__[i__5].r, dabs(r__7)) + (r__8 = r_imag(&d__[
+ *n]), dabs(r__8))) * ((r__9 = x[i__6].r, dabs(r__9))
+ + (r__10 = r_imag(&x[*n + j * x_dim1]), dabs(r__10)));
+ }
+ } else {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * x_dim1 + 1;
+ rwork[1] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b[
+ j * b_dim1 + 1]), dabs(r__2)) + ((r__3 = d__[1].r,
+ dabs(r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) *
+ ((r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x[j
+ * x_dim1 + 1]), dabs(r__6)));
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * x_dim1 + 1;
+ i__4 = j * x_dim1 + 2;
+ rwork[1] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b[
+ j * b_dim1 + 1]), dabs(r__2)) + ((r__3 = d__[1].r,
+ dabs(r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) *
+ ((r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x[j
+ * x_dim1 + 1]), dabs(r__6))) + ((r__7 = dl[1].r, dabs(
+ r__7)) + (r__8 = r_imag(&dl[1]), dabs(r__8))) * ((
+ r__9 = x[i__4].r, dabs(r__9)) + (r__10 = r_imag(&x[j *
+ x_dim1 + 2]), dabs(r__10)));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ - 1;
+ i__5 = i__ - 1 + j * x_dim1;
+ i__6 = i__;
+ i__7 = i__ + j * x_dim1;
+ i__8 = i__;
+ i__9 = i__ + 1 + j * x_dim1;
+ rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&b[i__ + j * b_dim1]), dabs(r__2)) + ((
+ r__3 = du[i__4].r, dabs(r__3)) + (r__4 = r_imag(&
+ du[i__ - 1]), dabs(r__4))) * ((r__5 = x[i__5].r,
+ dabs(r__5)) + (r__6 = r_imag(&x[i__ - 1 + j *
+ x_dim1]), dabs(r__6))) + ((r__7 = d__[i__6].r,
+ dabs(r__7)) + (r__8 = r_imag(&d__[i__]), dabs(
+ r__8))) * ((r__9 = x[i__7].r, dabs(r__9)) + (
+ r__10 = r_imag(&x[i__ + j * x_dim1]), dabs(r__10))
+ ) + ((r__11 = dl[i__8].r, dabs(r__11)) + (r__12 =
+ r_imag(&dl[i__]), dabs(r__12))) * ((r__13 = x[
+ i__9].r, dabs(r__13)) + (r__14 = r_imag(&x[i__ +
+ 1 + j * x_dim1]), dabs(r__14)));
+/* L40: */
+ }
+ i__2 = *n + j * b_dim1;
+ i__3 = *n - 1;
+ i__4 = *n - 1 + j * x_dim1;
+ i__5 = *n;
+ i__6 = *n + j * x_dim1;
+ rwork[*n] = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
+ b[*n + j * b_dim1]), dabs(r__2)) + ((r__3 = du[i__3]
+ .r, dabs(r__3)) + (r__4 = r_imag(&du[*n - 1]), dabs(
+ r__4))) * ((r__5 = x[i__4].r, dabs(r__5)) + (r__6 =
+ r_imag(&x[*n - 1 + j * x_dim1]), dabs(r__6))) + ((
+ r__7 = d__[i__5].r, dabs(r__7)) + (r__8 = r_imag(&d__[
+ *n]), dabs(r__8))) * ((r__9 = x[i__6].r, dabs(r__9))
+ + (r__10 = r_imag(&x[*n + j * x_dim1]), dabs(r__10)));
+ }
+ }
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__3 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
+ s = dmax(r__3,r__4);
+ } else {
+/* Computing MAX */
+ i__3 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = dmax(r__3,r__4);
+ }
+/* L50: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ cgttrs_(trans, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[
+ 1], &work[1], n, info);
+ caxpy_(n, &c_b26, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use CLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__3 = i__;
+ rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__];
+ } else {
+ i__3 = i__;
+ rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__] + safe1;
+ }
+/* L60: */
+ }
+
+ kase = 0;
+L70:
+ clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)**H). */
+
+ cgttrs_(transt, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &
+ ipiv[1], &work[1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L80: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L90: */
+ }
+ cgttrs_(transn, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &
+ ipiv[1], &work[1], n, info);
+ }
+ goto L70;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * x_dim1;
+ r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + j * x_dim1]), dabs(r__2));
+ lstres = dmax(r__3,r__4);
+/* L100: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L110: */
+ }
+
+ return 0;
+
+/* End of CGTRFS */
+
+} /* cgtrfs_ */
diff --git a/SRC/cgtsv.c b/SRC/cgtsv.c
new file mode 100644
index 0000000..57a1e32
--- /dev/null
+++ b/SRC/cgtsv.c
@@ -0,0 +1,287 @@
+/* cgtsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cgtsv_(integer *n, integer *nrhs, complex *dl, complex *
+ d__, complex *du, complex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2, q__3, q__4, q__5;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer j, k;
+ complex temp, mult;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGTSV solves the equation */
+
+/* A*X = B, */
+
+/* where A is an N-by-N tridiagonal matrix, by Gaussian elimination with */
+/* partial pivoting. */
+
+/* Note that the equation A'*X = B may be solved by interchanging the */
+/* order of the arguments DU and DL. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* DL (input/output) COMPLEX array, dimension (N-1) */
+/* On entry, DL must contain the (n-1) subdiagonal elements of */
+/* A. */
+/* On exit, DL is overwritten by the (n-2) elements of the */
+/* second superdiagonal of the upper triangular matrix U from */
+/* the LU factorization of A, in DL(1), ..., DL(n-2). */
+
+/* D (input/output) COMPLEX array, dimension (N) */
+/* On entry, D must contain the diagonal elements of A. */
+/* On exit, D is overwritten by the n diagonal elements of U. */
+
+/* DU (input/output) COMPLEX array, dimension (N-1) */
+/* On entry, DU must contain the (n-1) superdiagonal elements */
+/* of A. */
+/* On exit, DU is overwritten by the (n-1) elements of the first */
+/* superdiagonal of U. */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero, and the solution */
+/* has not been computed. The factorization has not been */
+/* completed unless i = N. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGTSV ", &i__1);
+ return 0;
+ }
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ i__1 = *n - 1;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = k;
+ if (dl[i__2].r == 0.f && dl[i__2].i == 0.f) {
+
+/* Subdiagonal is zero, no elimination is required. */
+
+ i__2 = k;
+ if (d__[i__2].r == 0.f && d__[i__2].i == 0.f) {
+
+/* Diagonal is zero: set INFO = K and return; a unique */
+/* solution can not be found. */
+
+ *info = k;
+ return 0;
+ }
+ } else /* if(complicated condition) */ {
+ i__2 = k;
+ i__3 = k;
+ if ((r__1 = d__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&d__[k]),
+ dabs(r__2)) >= (r__3 = dl[i__3].r, dabs(r__3)) + (r__4 =
+ r_imag(&dl[k]), dabs(r__4))) {
+
+/* No row interchange required */
+
+ c_div(&q__1, &dl[k], &d__[k]);
+ mult.r = q__1.r, mult.i = q__1.i;
+ i__2 = k + 1;
+ i__3 = k + 1;
+ i__4 = k;
+ q__2.r = mult.r * du[i__4].r - mult.i * du[i__4].i, q__2.i =
+ mult.r * du[i__4].i + mult.i * du[i__4].r;
+ q__1.r = d__[i__3].r - q__2.r, q__1.i = d__[i__3].i - q__2.i;
+ d__[i__2].r = q__1.r, d__[i__2].i = q__1.i;
+ i__2 = *nrhs;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = k + 1 + j * b_dim1;
+ i__4 = k + 1 + j * b_dim1;
+ i__5 = k + j * b_dim1;
+ q__2.r = mult.r * b[i__5].r - mult.i * b[i__5].i, q__2.i =
+ mult.r * b[i__5].i + mult.i * b[i__5].r;
+ q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L10: */
+ }
+ if (k < *n - 1) {
+ i__2 = k;
+ dl[i__2].r = 0.f, dl[i__2].i = 0.f;
+ }
+ } else {
+
+/* Interchange rows K and K+1 */
+
+ c_div(&q__1, &d__[k], &dl[k]);
+ mult.r = q__1.r, mult.i = q__1.i;
+ i__2 = k;
+ i__3 = k;
+ d__[i__2].r = dl[i__3].r, d__[i__2].i = dl[i__3].i;
+ i__2 = k + 1;
+ temp.r = d__[i__2].r, temp.i = d__[i__2].i;
+ i__2 = k + 1;
+ i__3 = k;
+ q__2.r = mult.r * temp.r - mult.i * temp.i, q__2.i = mult.r *
+ temp.i + mult.i * temp.r;
+ q__1.r = du[i__3].r - q__2.r, q__1.i = du[i__3].i - q__2.i;
+ d__[i__2].r = q__1.r, d__[i__2].i = q__1.i;
+ if (k < *n - 1) {
+ i__2 = k;
+ i__3 = k + 1;
+ dl[i__2].r = du[i__3].r, dl[i__2].i = du[i__3].i;
+ i__2 = k + 1;
+ q__2.r = -mult.r, q__2.i = -mult.i;
+ i__3 = k;
+ q__1.r = q__2.r * dl[i__3].r - q__2.i * dl[i__3].i,
+ q__1.i = q__2.r * dl[i__3].i + q__2.i * dl[i__3]
+ .r;
+ du[i__2].r = q__1.r, du[i__2].i = q__1.i;
+ }
+ i__2 = k;
+ du[i__2].r = temp.r, du[i__2].i = temp.i;
+ i__2 = *nrhs;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = k + j * b_dim1;
+ temp.r = b[i__3].r, temp.i = b[i__3].i;
+ i__3 = k + j * b_dim1;
+ i__4 = k + 1 + j * b_dim1;
+ b[i__3].r = b[i__4].r, b[i__3].i = b[i__4].i;
+ i__3 = k + 1 + j * b_dim1;
+ i__4 = k + 1 + j * b_dim1;
+ q__2.r = mult.r * b[i__4].r - mult.i * b[i__4].i, q__2.i =
+ mult.r * b[i__4].i + mult.i * b[i__4].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i - q__2.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L20: */
+ }
+ }
+ }
+/* L30: */
+ }
+ i__1 = *n;
+ if (d__[i__1].r == 0.f && d__[i__1].i == 0.f) {
+ *info = *n;
+ return 0;
+ }
+
+/* Back solve with the matrix U from the factorization. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n + j * b_dim1;
+ c_div(&q__1, &b[*n + j * b_dim1], &d__[*n]);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ if (*n > 1) {
+ i__2 = *n - 1 + j * b_dim1;
+ i__3 = *n - 1 + j * b_dim1;
+ i__4 = *n - 1;
+ i__5 = *n + j * b_dim1;
+ q__3.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i, q__3.i =
+ du[i__4].r * b[i__5].i + du[i__4].i * b[i__5].r;
+ q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
+ c_div(&q__1, &q__2, &d__[*n - 1]);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ }
+ for (k = *n - 2; k >= 1; --k) {
+ i__2 = k + j * b_dim1;
+ i__3 = k + j * b_dim1;
+ i__4 = k;
+ i__5 = k + 1 + j * b_dim1;
+ q__4.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i, q__4.i =
+ du[i__4].r * b[i__5].i + du[i__4].i * b[i__5].r;
+ q__3.r = b[i__3].r - q__4.r, q__3.i = b[i__3].i - q__4.i;
+ i__6 = k;
+ i__7 = k + 2 + j * b_dim1;
+ q__5.r = dl[i__6].r * b[i__7].r - dl[i__6].i * b[i__7].i, q__5.i =
+ dl[i__6].r * b[i__7].i + dl[i__6].i * b[i__7].r;
+ q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i;
+ c_div(&q__1, &q__2, &d__[k]);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L40: */
+ }
+/* L50: */
+ }
+
+ return 0;
+
+/* End of CGTSV */
+
+} /* cgtsv_ */
diff --git a/SRC/cgtsvx.c b/SRC/cgtsvx.c
new file mode 100644
index 0000000..9e99fb0
--- /dev/null
+++ b/SRC/cgtsvx.c
@@ -0,0 +1,347 @@
+/* cgtsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cgtsvx_(char *fact, char *trans, integer *n, integer *
+ nrhs, complex *dl, complex *d__, complex *du, complex *dlf, complex *
+ df, complex *duf, complex *du2, integer *ipiv, complex *b, integer *
+ ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr,
+ complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+
+ /* Local variables */
+ char norm[1];
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ extern doublereal slamch_(char *), clangt_(char *, integer *,
+ complex *, complex *, complex *);
+ logical nofact;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), cgtcon_(char *,
+ integer *, complex *, complex *, complex *, complex *, integer *,
+ real *, real *, complex *, integer *), xerbla_(char *,
+ integer *), cgtrfs_(char *, integer *, integer *, complex
+ *, complex *, complex *, complex *, complex *, complex *, complex
+ *, integer *, complex *, integer *, complex *, integer *, real *,
+ real *, complex *, real *, integer *), cgttrf_(integer *,
+ complex *, complex *, complex *, complex *, integer *, integer *);
+ logical notran;
+ extern /* Subroutine */ int cgttrs_(char *, integer *, integer *, complex
+ *, complex *, complex *, complex *, integer *, complex *, integer
+ *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGTSVX uses the LU factorization to compute the solution to a complex */
+/* system of linear equations A * X = B, A**T * X = B, or A**H * X = B, */
+/* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS */
+/* matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A */
+/* as A = L * U, where L is a product of permutation and unit lower */
+/* bidiagonal matrices and U is upper triangular with nonzeros in */
+/* only the main diagonal and first two superdiagonals. */
+
+/* 2. If some U(i,i)=0, so that U is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 3. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 4. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of A has been */
+/* supplied on entry. */
+/* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored form */
+/* of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV will not */
+/* be modified. */
+/* = 'N': The matrix will be copied to DLF, DF, and DUF */
+/* and factored. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* DL (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of A. */
+
+/* D (input) COMPLEX array, dimension (N) */
+/* The n diagonal elements of A. */
+
+/* DU (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) superdiagonal elements of A. */
+
+/* DLF (input or output) COMPLEX array, dimension (N-1) */
+/* If FACT = 'F', then DLF is an input argument and on entry */
+/* contains the (n-1) multipliers that define the matrix L from */
+/* the LU factorization of A as computed by CGTTRF. */
+
+/* If FACT = 'N', then DLF is an output argument and on exit */
+/* contains the (n-1) multipliers that define the matrix L from */
+/* the LU factorization of A. */
+
+/* DF (input or output) COMPLEX array, dimension (N) */
+/* If FACT = 'F', then DF is an input argument and on entry */
+/* contains the n diagonal elements of the upper triangular */
+/* matrix U from the LU factorization of A. */
+
+/* If FACT = 'N', then DF is an output argument and on exit */
+/* contains the n diagonal elements of the upper triangular */
+/* matrix U from the LU factorization of A. */
+
+/* DUF (input or output) COMPLEX array, dimension (N-1) */
+/* If FACT = 'F', then DUF is an input argument and on entry */
+/* contains the (n-1) elements of the first superdiagonal of U. */
+
+/* If FACT = 'N', then DUF is an output argument and on exit */
+/* contains the (n-1) elements of the first superdiagonal of U. */
+
+/* DU2 (input or output) COMPLEX array, dimension (N-2) */
+/* If FACT = 'F', then DU2 is an input argument and on entry */
+/* contains the (n-2) elements of the second superdiagonal of */
+/* U. */
+
+/* If FACT = 'N', then DU2 is an output argument and on exit */
+/* contains the (n-2) elements of the second superdiagonal of */
+/* U. */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains the pivot indices from the LU factorization of A as */
+/* computed by CGTTRF. */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the LU factorization of A; */
+/* row i of the matrix was interchanged with row IPIV(i). */
+/* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates */
+/* a row interchange was not required. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A. If RCOND is less than the machine precision (in */
+/* particular, if RCOND = 0), the matrix is singular to working */
+/* precision. This condition is indicated by a return code of */
+/* INFO > 0. */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: U(i,i) is exactly zero. The factorization */
+/* has not been completed unless i = N, but the */
+/* factor U is exactly singular, so the solution */
+/* and error bounds could not be computed. */
+/* RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ --dlf;
+ --df;
+ --duf;
+ --du2;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ notran = lsame_(trans, "N");
+ if (! nofact && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -14;
+ } else if (*ldx < max(1,*n)) {
+ *info = -16;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGTSVX", &i__1);
+ return 0;
+ }
+
+ if (nofact) {
+
+/* Compute the LU factorization of A. */
+
+ ccopy_(n, &d__[1], &c__1, &df[1], &c__1);
+ if (*n > 1) {
+ i__1 = *n - 1;
+ ccopy_(&i__1, &dl[1], &c__1, &dlf[1], &c__1);
+ i__1 = *n - 1;
+ ccopy_(&i__1, &du[1], &c__1, &duf[1], &c__1);
+ }
+ cgttrf_(n, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.f;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ if (notran) {
+ *(unsigned char *)norm = '1';
+ } else {
+ *(unsigned char *)norm = 'I';
+ }
+ anorm = clangt_(norm, n, &dl[1], &d__[1], &du[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ cgtcon_(norm, n, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], &anorm,
+ rcond, &work[1], info);
+
+/* Compute the solution vectors X. */
+
+ clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ cgttrs_(trans, n, nrhs, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], &x[
+ x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solutions and */
+/* compute error bounds and backward error estimates for them. */
+
+ cgtrfs_(trans, n, nrhs, &dl[1], &d__[1], &du[1], &dlf[1], &df[1], &duf[1],
+ &du2[1], &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1]
+, &berr[1], &work[1], &rwork[1], info);
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < slamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of CGTSVX */
+
+} /* cgtsvx_ */
diff --git a/SRC/cgttrf.c b/SRC/cgttrf.c
new file mode 100644
index 0000000..b6a012b
--- /dev/null
+++ b/SRC/cgttrf.c
@@ -0,0 +1,274 @@
+/* cgttrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cgttrf_(integer *n, complex *dl, complex *d__, complex *
+ du, complex *du2, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer i__;
+ complex fact, temp;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGTTRF computes an LU factorization of a complex tridiagonal matrix A */
+/* using elimination with partial pivoting and row interchanges. */
+
+/* The factorization has the form */
+/* A = L * U */
+/* where L is a product of permutation and unit lower bidiagonal */
+/* matrices and U is upper triangular with nonzeros in only the main */
+/* diagonal and first two superdiagonals. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* DL (input/output) COMPLEX array, dimension (N-1) */
+/* On entry, DL must contain the (n-1) sub-diagonal elements of */
+/* A. */
+
+/* On exit, DL is overwritten by the (n-1) multipliers that */
+/* define the matrix L from the LU factorization of A. */
+
+/* D (input/output) COMPLEX array, dimension (N) */
+/* On entry, D must contain the diagonal elements of A. */
+
+/* On exit, D is overwritten by the n diagonal elements of the */
+/* upper triangular matrix U from the LU factorization of A. */
+
+/* DU (input/output) COMPLEX array, dimension (N-1) */
+/* On entry, DU must contain the (n-1) super-diagonal elements */
+/* of A. */
+
+/* On exit, DU is overwritten by the (n-1) elements of the first */
+/* super-diagonal of U. */
+
+/* DU2 (output) COMPLEX array, dimension (N-2) */
+/* On exit, DU2 is overwritten by the (n-2) elements of the */
+/* second super-diagonal of U. */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, U(k,k) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ipiv;
+ --du2;
+ --du;
+ --d__;
+ --dl;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ i__1 = -(*info);
+ xerbla_("CGTTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Initialize IPIV(i) = i and DU2(i) = 0 */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ipiv[i__] = i__;
+/* L10: */
+ }
+ i__1 = *n - 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ du2[i__2].r = 0.f, du2[i__2].i = 0.f;
+/* L20: */
+ }
+
+ i__1 = *n - 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ if ((r__1 = d__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&d__[i__]),
+ dabs(r__2)) >= (r__3 = dl[i__3].r, dabs(r__3)) + (r__4 =
+ r_imag(&dl[i__]), dabs(r__4))) {
+
+/* No row interchange required, eliminate DL(I) */
+
+ i__2 = i__;
+ if ((r__1 = d__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&d__[i__]),
+ dabs(r__2)) != 0.f) {
+ c_div(&q__1, &dl[i__], &d__[i__]);
+ fact.r = q__1.r, fact.i = q__1.i;
+ i__2 = i__;
+ dl[i__2].r = fact.r, dl[i__2].i = fact.i;
+ i__2 = i__ + 1;
+ i__3 = i__ + 1;
+ i__4 = i__;
+ q__2.r = fact.r * du[i__4].r - fact.i * du[i__4].i, q__2.i =
+ fact.r * du[i__4].i + fact.i * du[i__4].r;
+ q__1.r = d__[i__3].r - q__2.r, q__1.i = d__[i__3].i - q__2.i;
+ d__[i__2].r = q__1.r, d__[i__2].i = q__1.i;
+ }
+ } else {
+
+/* Interchange rows I and I+1, eliminate DL(I) */
+
+ c_div(&q__1, &d__[i__], &dl[i__]);
+ fact.r = q__1.r, fact.i = q__1.i;
+ i__2 = i__;
+ i__3 = i__;
+ d__[i__2].r = dl[i__3].r, d__[i__2].i = dl[i__3].i;
+ i__2 = i__;
+ dl[i__2].r = fact.r, dl[i__2].i = fact.i;
+ i__2 = i__;
+ temp.r = du[i__2].r, temp.i = du[i__2].i;
+ i__2 = i__;
+ i__3 = i__ + 1;
+ du[i__2].r = d__[i__3].r, du[i__2].i = d__[i__3].i;
+ i__2 = i__ + 1;
+ i__3 = i__ + 1;
+ q__2.r = fact.r * d__[i__3].r - fact.i * d__[i__3].i, q__2.i =
+ fact.r * d__[i__3].i + fact.i * d__[i__3].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i - q__2.i;
+ d__[i__2].r = q__1.r, d__[i__2].i = q__1.i;
+ i__2 = i__;
+ i__3 = i__ + 1;
+ du2[i__2].r = du[i__3].r, du2[i__2].i = du[i__3].i;
+ i__2 = i__ + 1;
+ q__2.r = -fact.r, q__2.i = -fact.i;
+ i__3 = i__ + 1;
+ q__1.r = q__2.r * du[i__3].r - q__2.i * du[i__3].i, q__1.i =
+ q__2.r * du[i__3].i + q__2.i * du[i__3].r;
+ du[i__2].r = q__1.r, du[i__2].i = q__1.i;
+ ipiv[i__] = i__ + 1;
+ }
+/* L30: */
+ }
+ if (*n > 1) {
+ i__ = *n - 1;
+ i__1 = i__;
+ i__2 = i__;
+ if ((r__1 = d__[i__1].r, dabs(r__1)) + (r__2 = r_imag(&d__[i__]),
+ dabs(r__2)) >= (r__3 = dl[i__2].r, dabs(r__3)) + (r__4 =
+ r_imag(&dl[i__]), dabs(r__4))) {
+ i__1 = i__;
+ if ((r__1 = d__[i__1].r, dabs(r__1)) + (r__2 = r_imag(&d__[i__]),
+ dabs(r__2)) != 0.f) {
+ c_div(&q__1, &dl[i__], &d__[i__]);
+ fact.r = q__1.r, fact.i = q__1.i;
+ i__1 = i__;
+ dl[i__1].r = fact.r, dl[i__1].i = fact.i;
+ i__1 = i__ + 1;
+ i__2 = i__ + 1;
+ i__3 = i__;
+ q__2.r = fact.r * du[i__3].r - fact.i * du[i__3].i, q__2.i =
+ fact.r * du[i__3].i + fact.i * du[i__3].r;
+ q__1.r = d__[i__2].r - q__2.r, q__1.i = d__[i__2].i - q__2.i;
+ d__[i__1].r = q__1.r, d__[i__1].i = q__1.i;
+ }
+ } else {
+ c_div(&q__1, &d__[i__], &dl[i__]);
+ fact.r = q__1.r, fact.i = q__1.i;
+ i__1 = i__;
+ i__2 = i__;
+ d__[i__1].r = dl[i__2].r, d__[i__1].i = dl[i__2].i;
+ i__1 = i__;
+ dl[i__1].r = fact.r, dl[i__1].i = fact.i;
+ i__1 = i__;
+ temp.r = du[i__1].r, temp.i = du[i__1].i;
+ i__1 = i__;
+ i__2 = i__ + 1;
+ du[i__1].r = d__[i__2].r, du[i__1].i = d__[i__2].i;
+ i__1 = i__ + 1;
+ i__2 = i__ + 1;
+ q__2.r = fact.r * d__[i__2].r - fact.i * d__[i__2].i, q__2.i =
+ fact.r * d__[i__2].i + fact.i * d__[i__2].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i - q__2.i;
+ d__[i__1].r = q__1.r, d__[i__1].i = q__1.i;
+ ipiv[i__] = i__ + 1;
+ }
+ }
+
+/* Check for a zero on the diagonal of U. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ if ((r__1 = d__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&d__[i__]),
+ dabs(r__2)) == 0.f) {
+ *info = i__;
+ goto L50;
+ }
+/* L40: */
+ }
+L50:
+
+ return 0;
+
+/* End of CGTTRF */
+
+} /* cgttrf_ */
diff --git a/SRC/cgttrs.c b/SRC/cgttrs.c
new file mode 100644
index 0000000..8bd8c7a
--- /dev/null
+++ b/SRC/cgttrs.c
@@ -0,0 +1,192 @@
+/* cgttrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cgttrs_(char *trans, integer *n, integer *nrhs, complex *
+ dl, complex *d__, complex *du, complex *du2, integer *ipiv, complex *
+ b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer j, jb, nb;
+ extern /* Subroutine */ int cgtts2_(integer *, integer *, integer *,
+ complex *, complex *, complex *, complex *, integer *, complex *,
+ integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer itrans;
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGTTRS solves one of the systems of equations */
+/* A * X = B, A**T * X = B, or A**H * X = B, */
+/* with a tridiagonal matrix A using the LU factorization computed */
+/* by CGTTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* DL (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) multipliers that define the matrix L from the */
+/* LU factorization of A. */
+
+/* D (input) COMPLEX array, dimension (N) */
+/* The n diagonal elements of the upper triangular matrix U from */
+/* the LU factorization of A. */
+
+/* DU (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) elements of the first super-diagonal of U. */
+
+/* DU2 (input) COMPLEX array, dimension (N-2) */
+/* The (n-2) elements of the second super-diagonal of U. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the matrix of right hand side vectors B. */
+/* On exit, B is overwritten by the solution vectors X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ --du2;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ notran = *(unsigned char *)trans == 'N' || *(unsigned char *)trans == 'n';
+ if (! notran && ! (*(unsigned char *)trans == 'T' || *(unsigned char *)
+ trans == 't') && ! (*(unsigned char *)trans == 'C' || *(unsigned
+ char *)trans == 'c')) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(*n,1)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGTTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+/* Decode TRANS */
+
+ if (notran) {
+ itrans = 0;
+ } else if (*(unsigned char *)trans == 'T' || *(unsigned char *)trans ==
+ 't') {
+ itrans = 1;
+ } else {
+ itrans = 2;
+ }
+
+/* Determine the number of right-hand sides to solve at a time. */
+
+ if (*nrhs == 1) {
+ nb = 1;
+ } else {
+/* Computing MAX */
+ i__1 = 1, i__2 = ilaenv_(&c__1, "CGTTRS", trans, n, nrhs, &c_n1, &
+ c_n1);
+ nb = max(i__1,i__2);
+ }
+
+ if (nb >= *nrhs) {
+ cgtts2_(&itrans, n, nrhs, &dl[1], &d__[1], &du[1], &du2[1], &ipiv[1],
+ &b[b_offset], ldb);
+ } else {
+ i__1 = *nrhs;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = *nrhs - j + 1;
+ jb = min(i__3,nb);
+ cgtts2_(&itrans, n, &jb, &dl[1], &d__[1], &du[1], &du2[1], &ipiv[
+ 1], &b[j * b_dim1 + 1], ldb);
+/* L10: */
+ }
+ }
+
+/* End of CGTTRS */
+
+ return 0;
+} /* cgttrs_ */
diff --git a/SRC/cgtts2.c b/SRC/cgtts2.c
new file mode 100644
index 0000000..dae49c8
--- /dev/null
+++ b/SRC/cgtts2.c
@@ -0,0 +1,583 @@
+/* cgtts2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cgtts2_(integer *itrans, integer *n, integer *nrhs,
+ complex *dl, complex *d__, complex *du, complex *du2, integer *ipiv,
+ complex *b, integer *ldb)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
+ complex q__1, q__2, q__3, q__4, q__5, q__6, q__7, q__8;
+
+ /* Builtin functions */
+ void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j;
+ complex temp;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGTTS2 solves one of the systems of equations */
+/* A * X = B, A**T * X = B, or A**H * X = B, */
+/* with a tridiagonal matrix A using the LU factorization computed */
+/* by CGTTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* ITRANS (input) INTEGER */
+/* Specifies the form of the system of equations. */
+/* = 0: A * X = B (No transpose) */
+/* = 1: A**T * X = B (Transpose) */
+/* = 2: A**H * X = B (Conjugate transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* DL (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) multipliers that define the matrix L from the */
+/* LU factorization of A. */
+
+/* D (input) COMPLEX array, dimension (N) */
+/* The n diagonal elements of the upper triangular matrix U from */
+/* the LU factorization of A. */
+
+/* DU (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) elements of the first super-diagonal of U. */
+
+/* DU2 (input) COMPLEX array, dimension (N-2) */
+/* The (n-2) elements of the second super-diagonal of U. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the matrix of right hand side vectors B. */
+/* On exit, B is overwritten by the solution vectors X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ --du2;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (*itrans == 0) {
+
+/* Solve A*X = B using the LU factorization of A, */
+/* overwriting each right hand side vector with its solution. */
+
+ if (*nrhs <= 1) {
+ j = 1;
+L10:
+
+/* Solve L*x = b. */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (ipiv[i__] == i__) {
+ i__2 = i__ + 1 + j * b_dim1;
+ i__3 = i__ + 1 + j * b_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * b_dim1;
+ q__2.r = dl[i__4].r * b[i__5].r - dl[i__4].i * b[i__5].i,
+ q__2.i = dl[i__4].r * b[i__5].i + dl[i__4].i * b[
+ i__5].r;
+ q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ } else {
+ i__2 = i__ + j * b_dim1;
+ temp.r = b[i__2].r, temp.i = b[i__2].i;
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + 1 + j * b_dim1;
+ b[i__2].r = b[i__3].r, b[i__2].i = b[i__3].i;
+ i__2 = i__ + 1 + j * b_dim1;
+ i__3 = i__;
+ i__4 = i__ + j * b_dim1;
+ q__2.r = dl[i__3].r * b[i__4].r - dl[i__3].i * b[i__4].i,
+ q__2.i = dl[i__3].r * b[i__4].i + dl[i__3].i * b[
+ i__4].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i - q__2.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ }
+/* L20: */
+ }
+
+/* Solve U*x = b. */
+
+ i__1 = *n + j * b_dim1;
+ c_div(&q__1, &b[*n + j * b_dim1], &d__[*n]);
+ b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+ if (*n > 1) {
+ i__1 = *n - 1 + j * b_dim1;
+ i__2 = *n - 1 + j * b_dim1;
+ i__3 = *n - 1;
+ i__4 = *n + j * b_dim1;
+ q__3.r = du[i__3].r * b[i__4].r - du[i__3].i * b[i__4].i,
+ q__3.i = du[i__3].r * b[i__4].i + du[i__3].i * b[i__4]
+ .r;
+ q__2.r = b[i__2].r - q__3.r, q__2.i = b[i__2].i - q__3.i;
+ c_div(&q__1, &q__2, &d__[*n - 1]);
+ b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+ }
+ for (i__ = *n - 2; i__ >= 1; --i__) {
+ i__1 = i__ + j * b_dim1;
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__;
+ i__4 = i__ + 1 + j * b_dim1;
+ q__4.r = du[i__3].r * b[i__4].r - du[i__3].i * b[i__4].i,
+ q__4.i = du[i__3].r * b[i__4].i + du[i__3].i * b[i__4]
+ .r;
+ q__3.r = b[i__2].r - q__4.r, q__3.i = b[i__2].i - q__4.i;
+ i__5 = i__;
+ i__6 = i__ + 2 + j * b_dim1;
+ q__5.r = du2[i__5].r * b[i__6].r - du2[i__5].i * b[i__6].i,
+ q__5.i = du2[i__5].r * b[i__6].i + du2[i__5].i * b[
+ i__6].r;
+ q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i;
+ c_div(&q__1, &q__2, &d__[i__]);
+ b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+/* L30: */
+ }
+ if (j < *nrhs) {
+ ++j;
+ goto L10;
+ }
+ } else {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve L*x = b. */
+
+ i__2 = *n - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (ipiv[i__] == i__) {
+ i__3 = i__ + 1 + j * b_dim1;
+ i__4 = i__ + 1 + j * b_dim1;
+ i__5 = i__;
+ i__6 = i__ + j * b_dim1;
+ q__2.r = dl[i__5].r * b[i__6].r - dl[i__5].i * b[i__6]
+ .i, q__2.i = dl[i__5].r * b[i__6].i + dl[i__5]
+ .i * b[i__6].r;
+ q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i -
+ q__2.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+ } else {
+ i__3 = i__ + j * b_dim1;
+ temp.r = b[i__3].r, temp.i = b[i__3].i;
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + 1 + j * b_dim1;
+ b[i__3].r = b[i__4].r, b[i__3].i = b[i__4].i;
+ i__3 = i__ + 1 + j * b_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * b_dim1;
+ q__2.r = dl[i__4].r * b[i__5].r - dl[i__4].i * b[i__5]
+ .i, q__2.i = dl[i__4].r * b[i__5].i + dl[i__4]
+ .i * b[i__5].r;
+ q__1.r = temp.r - q__2.r, q__1.i = temp.i - q__2.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+ }
+/* L40: */
+ }
+
+/* Solve U*x = b. */
+
+ i__2 = *n + j * b_dim1;
+ c_div(&q__1, &b[*n + j * b_dim1], &d__[*n]);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ if (*n > 1) {
+ i__2 = *n - 1 + j * b_dim1;
+ i__3 = *n - 1 + j * b_dim1;
+ i__4 = *n - 1;
+ i__5 = *n + j * b_dim1;
+ q__3.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i,
+ q__3.i = du[i__4].r * b[i__5].i + du[i__4].i * b[
+ i__5].r;
+ q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
+ c_div(&q__1, &q__2, &d__[*n - 1]);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ }
+ for (i__ = *n - 2; i__ >= 1; --i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ i__5 = i__ + 1 + j * b_dim1;
+ q__4.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i,
+ q__4.i = du[i__4].r * b[i__5].i + du[i__4].i * b[
+ i__5].r;
+ q__3.r = b[i__3].r - q__4.r, q__3.i = b[i__3].i - q__4.i;
+ i__6 = i__;
+ i__7 = i__ + 2 + j * b_dim1;
+ q__5.r = du2[i__6].r * b[i__7].r - du2[i__6].i * b[i__7]
+ .i, q__5.i = du2[i__6].r * b[i__7].i + du2[i__6]
+ .i * b[i__7].r;
+ q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i;
+ c_div(&q__1, &q__2, &d__[i__]);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+ } else if (*itrans == 1) {
+
+/* Solve A**T * X = B. */
+
+ if (*nrhs <= 1) {
+ j = 1;
+L70:
+
+/* Solve U**T * x = b. */
+
+ i__1 = j * b_dim1 + 1;
+ c_div(&q__1, &b[j * b_dim1 + 1], &d__[1]);
+ b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+ if (*n > 1) {
+ i__1 = j * b_dim1 + 2;
+ i__2 = j * b_dim1 + 2;
+ i__3 = j * b_dim1 + 1;
+ q__3.r = du[1].r * b[i__3].r - du[1].i * b[i__3].i, q__3.i =
+ du[1].r * b[i__3].i + du[1].i * b[i__3].r;
+ q__2.r = b[i__2].r - q__3.r, q__2.i = b[i__2].i - q__3.i;
+ c_div(&q__1, &q__2, &d__[2]);
+ b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+ }
+ i__1 = *n;
+ for (i__ = 3; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ - 1;
+ i__5 = i__ - 1 + j * b_dim1;
+ q__4.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i,
+ q__4.i = du[i__4].r * b[i__5].i + du[i__4].i * b[i__5]
+ .r;
+ q__3.r = b[i__3].r - q__4.r, q__3.i = b[i__3].i - q__4.i;
+ i__6 = i__ - 2;
+ i__7 = i__ - 2 + j * b_dim1;
+ q__5.r = du2[i__6].r * b[i__7].r - du2[i__6].i * b[i__7].i,
+ q__5.i = du2[i__6].r * b[i__7].i + du2[i__6].i * b[
+ i__7].r;
+ q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i;
+ c_div(&q__1, &q__2, &d__[i__]);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L80: */
+ }
+
+/* Solve L**T * x = b. */
+
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ if (ipiv[i__] == i__) {
+ i__1 = i__ + j * b_dim1;
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__;
+ i__4 = i__ + 1 + j * b_dim1;
+ q__2.r = dl[i__3].r * b[i__4].r - dl[i__3].i * b[i__4].i,
+ q__2.i = dl[i__3].r * b[i__4].i + dl[i__3].i * b[
+ i__4].r;
+ q__1.r = b[i__2].r - q__2.r, q__1.i = b[i__2].i - q__2.i;
+ b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+ } else {
+ i__1 = i__ + 1 + j * b_dim1;
+ temp.r = b[i__1].r, temp.i = b[i__1].i;
+ i__1 = i__ + 1 + j * b_dim1;
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__;
+ q__2.r = dl[i__3].r * temp.r - dl[i__3].i * temp.i,
+ q__2.i = dl[i__3].r * temp.i + dl[i__3].i *
+ temp.r;
+ q__1.r = b[i__2].r - q__2.r, q__1.i = b[i__2].i - q__2.i;
+ b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+ i__1 = i__ + j * b_dim1;
+ b[i__1].r = temp.r, b[i__1].i = temp.i;
+ }
+/* L90: */
+ }
+ if (j < *nrhs) {
+ ++j;
+ goto L70;
+ }
+ } else {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve U**T * x = b. */
+
+ i__2 = j * b_dim1 + 1;
+ c_div(&q__1, &b[j * b_dim1 + 1], &d__[1]);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ if (*n > 1) {
+ i__2 = j * b_dim1 + 2;
+ i__3 = j * b_dim1 + 2;
+ i__4 = j * b_dim1 + 1;
+ q__3.r = du[1].r * b[i__4].r - du[1].i * b[i__4].i,
+ q__3.i = du[1].r * b[i__4].i + du[1].i * b[i__4]
+ .r;
+ q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
+ c_div(&q__1, &q__2, &d__[2]);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ }
+ i__2 = *n;
+ for (i__ = 3; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ - 1;
+ i__6 = i__ - 1 + j * b_dim1;
+ q__4.r = du[i__5].r * b[i__6].r - du[i__5].i * b[i__6].i,
+ q__4.i = du[i__5].r * b[i__6].i + du[i__5].i * b[
+ i__6].r;
+ q__3.r = b[i__4].r - q__4.r, q__3.i = b[i__4].i - q__4.i;
+ i__7 = i__ - 2;
+ i__8 = i__ - 2 + j * b_dim1;
+ q__5.r = du2[i__7].r * b[i__8].r - du2[i__7].i * b[i__8]
+ .i, q__5.i = du2[i__7].r * b[i__8].i + du2[i__7]
+ .i * b[i__8].r;
+ q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i;
+ c_div(&q__1, &q__2, &d__[i__]);
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L100: */
+ }
+
+/* Solve L**T * x = b. */
+
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ if (ipiv[i__] == i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ i__5 = i__ + 1 + j * b_dim1;
+ q__2.r = dl[i__4].r * b[i__5].r - dl[i__4].i * b[i__5]
+ .i, q__2.i = dl[i__4].r * b[i__5].i + dl[i__4]
+ .i * b[i__5].r;
+ q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i -
+ q__2.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ } else {
+ i__2 = i__ + 1 + j * b_dim1;
+ temp.r = b[i__2].r, temp.i = b[i__2].i;
+ i__2 = i__ + 1 + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ q__2.r = dl[i__4].r * temp.r - dl[i__4].i * temp.i,
+ q__2.i = dl[i__4].r * temp.i + dl[i__4].i *
+ temp.r;
+ q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i -
+ q__2.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = i__ + j * b_dim1;
+ b[i__2].r = temp.r, b[i__2].i = temp.i;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+ }
+ } else {
+
+/* Solve A**H * X = B. */
+
+ if (*nrhs <= 1) {
+ j = 1;
+L130:
+
+/* Solve U**H * x = b. */
+
+ i__1 = j * b_dim1 + 1;
+ r_cnjg(&q__2, &d__[1]);
+ c_div(&q__1, &b[j * b_dim1 + 1], &q__2);
+ b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+ if (*n > 1) {
+ i__1 = j * b_dim1 + 2;
+ i__2 = j * b_dim1 + 2;
+ r_cnjg(&q__4, &du[1]);
+ i__3 = j * b_dim1 + 1;
+ q__3.r = q__4.r * b[i__3].r - q__4.i * b[i__3].i, q__3.i =
+ q__4.r * b[i__3].i + q__4.i * b[i__3].r;
+ q__2.r = b[i__2].r - q__3.r, q__2.i = b[i__2].i - q__3.i;
+ r_cnjg(&q__5, &d__[2]);
+ c_div(&q__1, &q__2, &q__5);
+ b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+ }
+ i__1 = *n;
+ for (i__ = 3; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ r_cnjg(&q__5, &du[i__ - 1]);
+ i__4 = i__ - 1 + j * b_dim1;
+ q__4.r = q__5.r * b[i__4].r - q__5.i * b[i__4].i, q__4.i =
+ q__5.r * b[i__4].i + q__5.i * b[i__4].r;
+ q__3.r = b[i__3].r - q__4.r, q__3.i = b[i__3].i - q__4.i;
+ r_cnjg(&q__7, &du2[i__ - 2]);
+ i__5 = i__ - 2 + j * b_dim1;
+ q__6.r = q__7.r * b[i__5].r - q__7.i * b[i__5].i, q__6.i =
+ q__7.r * b[i__5].i + q__7.i * b[i__5].r;
+ q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i;
+ r_cnjg(&q__8, &d__[i__]);
+ c_div(&q__1, &q__2, &q__8);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L140: */
+ }
+
+/* Solve L**H * x = b. */
+
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ if (ipiv[i__] == i__) {
+ i__1 = i__ + j * b_dim1;
+ i__2 = i__ + j * b_dim1;
+ r_cnjg(&q__3, &dl[i__]);
+ i__3 = i__ + 1 + j * b_dim1;
+ q__2.r = q__3.r * b[i__3].r - q__3.i * b[i__3].i, q__2.i =
+ q__3.r * b[i__3].i + q__3.i * b[i__3].r;
+ q__1.r = b[i__2].r - q__2.r, q__1.i = b[i__2].i - q__2.i;
+ b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+ } else {
+ i__1 = i__ + 1 + j * b_dim1;
+ temp.r = b[i__1].r, temp.i = b[i__1].i;
+ i__1 = i__ + 1 + j * b_dim1;
+ i__2 = i__ + j * b_dim1;
+ r_cnjg(&q__3, &dl[i__]);
+ q__2.r = q__3.r * temp.r - q__3.i * temp.i, q__2.i =
+ q__3.r * temp.i + q__3.i * temp.r;
+ q__1.r = b[i__2].r - q__2.r, q__1.i = b[i__2].i - q__2.i;
+ b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+ i__1 = i__ + j * b_dim1;
+ b[i__1].r = temp.r, b[i__1].i = temp.i;
+ }
+/* L150: */
+ }
+ if (j < *nrhs) {
+ ++j;
+ goto L130;
+ }
+ } else {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve U**H * x = b. */
+
+ i__2 = j * b_dim1 + 1;
+ r_cnjg(&q__2, &d__[1]);
+ c_div(&q__1, &b[j * b_dim1 + 1], &q__2);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ if (*n > 1) {
+ i__2 = j * b_dim1 + 2;
+ i__3 = j * b_dim1 + 2;
+ r_cnjg(&q__4, &du[1]);
+ i__4 = j * b_dim1 + 1;
+ q__3.r = q__4.r * b[i__4].r - q__4.i * b[i__4].i, q__3.i =
+ q__4.r * b[i__4].i + q__4.i * b[i__4].r;
+ q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
+ r_cnjg(&q__5, &d__[2]);
+ c_div(&q__1, &q__2, &q__5);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ }
+ i__2 = *n;
+ for (i__ = 3; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ r_cnjg(&q__5, &du[i__ - 1]);
+ i__5 = i__ - 1 + j * b_dim1;
+ q__4.r = q__5.r * b[i__5].r - q__5.i * b[i__5].i, q__4.i =
+ q__5.r * b[i__5].i + q__5.i * b[i__5].r;
+ q__3.r = b[i__4].r - q__4.r, q__3.i = b[i__4].i - q__4.i;
+ r_cnjg(&q__7, &du2[i__ - 2]);
+ i__6 = i__ - 2 + j * b_dim1;
+ q__6.r = q__7.r * b[i__6].r - q__7.i * b[i__6].i, q__6.i =
+ q__7.r * b[i__6].i + q__7.i * b[i__6].r;
+ q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i;
+ r_cnjg(&q__8, &d__[i__]);
+ c_div(&q__1, &q__2, &q__8);
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L160: */
+ }
+
+/* Solve L**H * x = b. */
+
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ if (ipiv[i__] == i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ r_cnjg(&q__3, &dl[i__]);
+ i__4 = i__ + 1 + j * b_dim1;
+ q__2.r = q__3.r * b[i__4].r - q__3.i * b[i__4].i,
+ q__2.i = q__3.r * b[i__4].i + q__3.i * b[i__4]
+ .r;
+ q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i -
+ q__2.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ } else {
+ i__2 = i__ + 1 + j * b_dim1;
+ temp.r = b[i__2].r, temp.i = b[i__2].i;
+ i__2 = i__ + 1 + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ r_cnjg(&q__3, &dl[i__]);
+ q__2.r = q__3.r * temp.r - q__3.i * temp.i, q__2.i =
+ q__3.r * temp.i + q__3.i * temp.r;
+ q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i -
+ q__2.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = i__ + j * b_dim1;
+ b[i__2].r = temp.r, b[i__2].i = temp.i;
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+ }
+
+/* End of CGTTS2 */
+
+ return 0;
+} /* cgtts2_ */
diff --git a/SRC/chbev.c b/SRC/chbev.c
new file mode 100644
index 0000000..45c3ef8
--- /dev/null
+++ b/SRC/chbev.c
@@ -0,0 +1,270 @@
+/* chbev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b11 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int chbev_(char *jobz, char *uplo, integer *n, integer *kd,
+ complex *ab, integer *ldab, real *w, complex *z__, integer *ldz,
+ complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, z_dim1, z_offset, i__1;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real eps;
+ integer inde;
+ real anrm;
+ integer imax;
+ real rmin, rmax, sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ logical lower, wantz;
+ extern doublereal clanhb_(char *, char *, integer *, integer *, complex *,
+ integer *, real *);
+ integer iscale;
+ extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, complex *, integer *, integer *), chbtrd_(char *, char *, integer *, integer *, complex *,
+ integer *, real *, real *, complex *, integer *, complex *,
+ integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ integer indrwk;
+ extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *,
+ complex *, integer *, real *, integer *), ssterf_(integer
+ *, real *, real *, integer *);
+ real smlnum;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHBEV computes all the eigenvalues and, optionally, eigenvectors of */
+/* a complex Hermitian band matrix A. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) COMPLEX array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, AB is overwritten by values generated during the */
+/* reduction to tridiagonal form. If UPLO = 'U', the first */
+/* superdiagonal and the diagonal of the tridiagonal matrix T */
+/* are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */
+/* the diagonal and first subdiagonal of T are returned in the */
+/* first two rows of AB. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD + 1. */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
+/* eigenvectors of the matrix A, with the i-th column of Z */
+/* holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* RWORK (workspace) REAL array, dimension (max(1,3*N-2)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of an intermediate tridiagonal */
+/* form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ lower = lsame_(uplo, "L");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kd < 0) {
+ *info = -4;
+ } else if (*ldab < *kd + 1) {
+ *info = -6;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -9;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHBEV ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (lower) {
+ i__1 = ab_dim1 + 1;
+ w[1] = ab[i__1].r;
+ } else {
+ i__1 = *kd + 1 + ab_dim1;
+ w[1] = ab[i__1].r;
+ }
+ if (wantz) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1.f, z__[i__1].i = 0.f;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = clanhb_("M", uplo, n, kd, &ab[ab_offset], ldab, &rwork[1]);
+ iscale = 0;
+ if (anrm > 0.f && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ if (lower) {
+ clascl_("B", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ } else {
+ clascl_("Q", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ }
+ }
+
+/* Call CHBTRD to reduce Hermitian band matrix to tridiagonal form. */
+
+ inde = 1;
+ chbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &rwork[inde], &
+ z__[z_offset], ldz, &work[1], &iinfo);
+
+/* For eigenvalues only, call SSTERF. For eigenvectors, call CSTEQR. */
+
+ if (! wantz) {
+ ssterf_(n, &w[1], &rwork[inde], info);
+ } else {
+ indrwk = inde + *n;
+ csteqr_(jobz, n, &w[1], &rwork[inde], &z__[z_offset], ldz, &rwork[
+ indrwk], info);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *n;
+ } else {
+ imax = *info - 1;
+ }
+ r__1 = 1.f / sigma;
+ sscal_(&imax, &r__1, &w[1], &c__1);
+ }
+
+ return 0;
+
+/* End of CHBEV */
+
+} /* chbev_ */
diff --git a/SRC/chbevd.c b/SRC/chbevd.c
new file mode 100644
index 0000000..148aafd
--- /dev/null
+++ b/SRC/chbevd.c
@@ -0,0 +1,377 @@
+/* chbevd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static real c_b13 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int chbevd_(char *jobz, char *uplo, integer *n, integer *kd,
+ complex *ab, integer *ldab, real *w, complex *z__, integer *ldz,
+ complex *work, integer *lwork, real *rwork, integer *lrwork, integer *
+ iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, z_dim1, z_offset, i__1;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real eps;
+ integer inde;
+ real anrm;
+ integer imax;
+ real rmin, rmax;
+ integer llwk2;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ real sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ integer lwmin;
+ logical lower;
+ integer llrwk;
+ logical wantz;
+ integer indwk2;
+ extern doublereal clanhb_(char *, char *, integer *, integer *, complex *,
+ integer *, real *);
+ integer iscale;
+ extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, complex *, integer *, integer *), cstedc_(char *, integer *, real *, real *, complex *,
+ integer *, complex *, integer *, real *, integer *, integer *,
+ integer *, integer *), chbtrd_(char *, char *, integer *,
+ integer *, complex *, integer *, real *, real *, complex *,
+ integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ integer indwrk, liwmin;
+ extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
+ integer lrwmin;
+ real smlnum;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHBEVD computes all the eigenvalues and, optionally, eigenvectors of */
+/* a complex Hermitian band matrix A. If eigenvectors are desired, it */
+/* uses a divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) COMPLEX array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, AB is overwritten by values generated during the */
+/* reduction to tridiagonal form. If UPLO = 'U', the first */
+/* superdiagonal and the diagonal of the tridiagonal matrix T */
+/* are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */
+/* the diagonal and first subdiagonal of T are returned in the */
+/* first two rows of AB. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD + 1. */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
+/* eigenvectors of the matrix A, with the i-th column of Z */
+/* holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If N <= 1, LWORK must be at least 1. */
+/* If JOBZ = 'N' and N > 1, LWORK must be at least N. */
+/* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N**2. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK, RWORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* RWORK (workspace/output) REAL array, */
+/* dimension (LRWORK) */
+/* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. */
+
+/* LRWORK (input) INTEGER */
+/* The dimension of array RWORK. */
+/* If N <= 1, LRWORK must be at least 1. */
+/* If JOBZ = 'N' and N > 1, LRWORK must be at least N. */
+/* If JOBZ = 'V' and N > 1, LRWORK must be at least */
+/* 1 + 5*N + 2*N**2. */
+
+/* If LRWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of array IWORK. */
+/* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. */
+/* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N . */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of an intermediate tridiagonal */
+/* form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ lower = lsame_(uplo, "L");
+ lquery = *lwork == -1 || *liwork == -1 || *lrwork == -1;
+
+ *info = 0;
+ if (*n <= 1) {
+ lwmin = 1;
+ lrwmin = 1;
+ liwmin = 1;
+ } else {
+ if (wantz) {
+/* Computing 2nd power */
+ i__1 = *n;
+ lwmin = i__1 * i__1 << 1;
+/* Computing 2nd power */
+ i__1 = *n;
+ lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
+ liwmin = *n * 5 + 3;
+ } else {
+ lwmin = *n;
+ lrwmin = *n;
+ liwmin = 1;
+ }
+ }
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kd < 0) {
+ *info = -4;
+ } else if (*ldab < *kd + 1) {
+ *info = -6;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -9;
+ }
+
+ if (*info == 0) {
+ work[1].r = (real) lwmin, work[1].i = 0.f;
+ rwork[1] = (real) lrwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -11;
+ } else if (*lrwork < lrwmin && ! lquery) {
+ *info = -13;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -15;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHBEVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ i__1 = ab_dim1 + 1;
+ w[1] = ab[i__1].r;
+ if (wantz) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1.f, z__[i__1].i = 0.f;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = clanhb_("M", uplo, n, kd, &ab[ab_offset], ldab, &rwork[1]);
+ iscale = 0;
+ if (anrm > 0.f && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ if (lower) {
+ clascl_("B", kd, kd, &c_b13, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ } else {
+ clascl_("Q", kd, kd, &c_b13, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ }
+ }
+
+/* Call CHBTRD to reduce Hermitian band matrix to tridiagonal form. */
+
+ inde = 1;
+ indwrk = inde + *n;
+ indwk2 = *n * *n + 1;
+ llwk2 = *lwork - indwk2 + 1;
+ llrwk = *lrwork - indwrk + 1;
+ chbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &rwork[inde], &
+ z__[z_offset], ldz, &work[1], &iinfo);
+
+/* For eigenvalues only, call SSTERF. For eigenvectors, call CSTEDC. */
+
+ if (! wantz) {
+ ssterf_(n, &w[1], &rwork[inde], info);
+ } else {
+ cstedc_("I", n, &w[1], &rwork[inde], &work[1], n, &work[indwk2], &
+ llwk2, &rwork[indwrk], &llrwk, &iwork[1], liwork, info);
+ cgemm_("N", "N", n, n, n, &c_b2, &z__[z_offset], ldz, &work[1], n, &
+ c_b1, &work[indwk2], n);
+ clacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *n;
+ } else {
+ imax = *info - 1;
+ }
+ r__1 = 1.f / sigma;
+ sscal_(&imax, &r__1, &w[1], &c__1);
+ }
+
+ work[1].r = (real) lwmin, work[1].i = 0.f;
+ rwork[1] = (real) lrwmin;
+ iwork[1] = liwmin;
+ return 0;
+
+/* End of CHBEVD */
+
+} /* chbevd_ */
diff --git a/SRC/chbevx.c b/SRC/chbevx.c
new file mode 100644
index 0000000..0a395a2
--- /dev/null
+++ b/SRC/chbevx.c
@@ -0,0 +1,524 @@
+/* chbevx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static real c_b16 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int chbevx_(char *jobz, char *range, char *uplo, integer *n,
+ integer *kd, complex *ab, integer *ldab, complex *q, integer *ldq,
+ real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *
+ m, real *w, complex *z__, integer *ldz, complex *work, real *rwork,
+ integer *iwork, integer *ifail, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, q_dim1, q_offset, z_dim1, z_offset, i__1,
+ i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, jj;
+ real eps, vll, vuu, tmp1;
+ integer indd, inde;
+ real anrm;
+ integer imax;
+ real rmin, rmax;
+ logical test;
+ complex ctmp1;
+ integer itmp1, indee;
+ real sigma;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ char order[1];
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ logical lower;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ logical wantz;
+ extern doublereal clanhb_(char *, char *, integer *, integer *, complex *,
+ integer *, real *);
+ logical alleig, indeig;
+ integer iscale, indibl;
+ extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, complex *, integer *, integer *), chbtrd_(char *, char *, integer *, integer *, complex *,
+ integer *, real *, real *, complex *, integer *, complex *,
+ integer *);
+ logical valeig;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real abstll, bignum;
+ integer indiwk, indisp;
+ extern /* Subroutine */ int cstein_(integer *, real *, real *, integer *,
+ real *, integer *, integer *, complex *, integer *, real *,
+ integer *, integer *, integer *);
+ integer indrwk, indwrk;
+ extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *,
+ complex *, integer *, real *, integer *), ssterf_(integer
+ *, real *, real *, integer *);
+ integer nsplit;
+ extern /* Subroutine */ int sstebz_(char *, char *, integer *, real *,
+ real *, integer *, integer *, real *, real *, real *, integer *,
+ integer *, real *, integer *, integer *, real *, integer *,
+ integer *);
+ real smlnum;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHBEVX computes selected eigenvalues and, optionally, eigenvectors */
+/* of a complex Hermitian band matrix A. Eigenvalues and eigenvectors */
+/* can be selected by specifying either a range of values or a range of */
+/* indices for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found; */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found; */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) COMPLEX array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, AB is overwritten by values generated during the */
+/* reduction to tridiagonal form. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD + 1. */
+
+/* Q (output) COMPLEX array, dimension (LDQ, N) */
+/* If JOBZ = 'V', the N-by-N unitary matrix used in the */
+/* reduction to tridiagonal form. */
+/* If JOBZ = 'N', the array Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. If JOBZ = 'V', then */
+/* LDQ >= max(1,N). */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) REAL */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing AB to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*SLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*SLAMCH('S'). */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices */
+/* with Guaranteed High Relative Accuracy," by Demmel and */
+/* Kahan, LAPACK Working Note #3. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* The first M elements contain the selected eigenvalues in */
+/* ascending order. */
+
+/* Z (output) COMPLEX array, dimension (LDZ, max(1,M)) */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If an eigenvector fails to converge, then that column of Z */
+/* contains the latest approximation to the eigenvector, and the */
+/* index of the eigenvector is returned in IFAIL. */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* RWORK (workspace) REAL array, dimension (7*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, then i eigenvectors failed to converge. */
+/* Their indices are stored in array IFAIL. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+ lower = lsame_(uplo, "L");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*kd < 0) {
+ *info = -5;
+ } else if (*ldab < *kd + 1) {
+ *info = -7;
+ } else if (wantz && *ldq < max(1,*n)) {
+ *info = -9;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -11;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -12;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -13;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -18;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHBEVX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ *m = 1;
+ if (lower) {
+ i__1 = ab_dim1 + 1;
+ ctmp1.r = ab[i__1].r, ctmp1.i = ab[i__1].i;
+ } else {
+ i__1 = *kd + 1 + ab_dim1;
+ ctmp1.r = ab[i__1].r, ctmp1.i = ab[i__1].i;
+ }
+ tmp1 = ctmp1.r;
+ if (valeig) {
+ if (! (*vl < tmp1 && *vu >= tmp1)) {
+ *m = 0;
+ }
+ }
+ if (*m == 1) {
+ w[1] = ctmp1.r;
+ if (wantz) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1.f, z__[i__1].i = 0.f;
+ }
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
+ rmax = dmin(r__1,r__2);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ abstll = *abstol;
+ if (valeig) {
+ vll = *vl;
+ vuu = *vu;
+ } else {
+ vll = 0.f;
+ vuu = 0.f;
+ }
+ anrm = clanhb_("M", uplo, n, kd, &ab[ab_offset], ldab, &rwork[1]);
+ if (anrm > 0.f && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ if (lower) {
+ clascl_("B", kd, kd, &c_b16, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ } else {
+ clascl_("Q", kd, kd, &c_b16, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ }
+ if (*abstol > 0.f) {
+ abstll = *abstol * sigma;
+ }
+ if (valeig) {
+ vll = *vl * sigma;
+ vuu = *vu * sigma;
+ }
+ }
+
+/* Call CHBTRD to reduce Hermitian band matrix to tridiagonal form. */
+
+ indd = 1;
+ inde = indd + *n;
+ indrwk = inde + *n;
+ indwrk = 1;
+ chbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &rwork[indd], &rwork[
+ inde], &q[q_offset], ldq, &work[indwrk], &iinfo);
+
+/* If all eigenvalues are desired and ABSTOL is less than or equal */
+/* to zero, then call SSTERF or CSTEQR. If this fails for some */
+/* eigenvalue, then try SSTEBZ. */
+
+ test = FALSE_;
+ if (indeig) {
+ if (*il == 1 && *iu == *n) {
+ test = TRUE_;
+ }
+ }
+ if ((alleig || test) && *abstol <= 0.f) {
+ scopy_(n, &rwork[indd], &c__1, &w[1], &c__1);
+ indee = indrwk + (*n << 1);
+ if (! wantz) {
+ i__1 = *n - 1;
+ scopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
+ ssterf_(n, &w[1], &rwork[indee], info);
+ } else {
+ clacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz);
+ i__1 = *n - 1;
+ scopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
+ csteqr_(jobz, n, &w[1], &rwork[indee], &z__[z_offset], ldz, &
+ rwork[indrwk], info);
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ifail[i__] = 0;
+/* L10: */
+ }
+ }
+ }
+ if (*info == 0) {
+ *m = *n;
+ goto L30;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call SSTEBZ and, if eigenvectors are desired, CSTEIN. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ indibl = 1;
+ indisp = indibl + *n;
+ indiwk = indisp + *n;
+ sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], &
+ rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &
+ rwork[indrwk], &iwork[indiwk], info);
+
+ if (wantz) {
+ cstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], &
+ iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[
+ indiwk], &ifail[1], info);
+
+/* Apply unitary matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by CSTEIN. */
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1);
+ cgemv_("N", n, n, &c_b2, &q[q_offset], ldq, &work[1], &c__1, &
+ c_b1, &z__[j * z_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+L30:
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *m;
+ } else {
+ imax = *info - 1;
+ }
+ r__1 = 1.f / sigma;
+ sscal_(&imax, &r__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L40: */
+ }
+
+ if (i__ != 0) {
+ itmp1 = iwork[indibl + i__ - 1];
+ w[i__] = w[j];
+ iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
+ w[j] = tmp1;
+ iwork[indibl + j - 1] = itmp1;
+ cswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ if (*info != 0) {
+ itmp1 = ifail[i__];
+ ifail[i__] = ifail[j];
+ ifail[j] = itmp1;
+ }
+ }
+/* L50: */
+ }
+ }
+
+ return 0;
+
+/* End of CHBEVX */
+
+} /* chbevx_ */
diff --git a/SRC/chbgst.c b/SRC/chbgst.c
new file mode 100644
index 0000000..a4d1581
--- /dev/null
+++ b/SRC/chbgst.c
@@ -0,0 +1,2146 @@
+/* chbgst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int chbgst_(char *vect, char *uplo, integer *n, integer *ka,
+ integer *kb, complex *ab, integer *ldab, complex *bb, integer *ldbb,
+ complex *x, integer *ldx, complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, bb_dim1, bb_offset, x_dim1, x_offset, i__1,
+ i__2, i__3, i__4, i__5, i__6, i__7, i__8;
+ real r__1;
+ complex q__1, q__2, q__3, q__4, q__5, q__6, q__7, q__8, q__9, q__10;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k, l, m;
+ complex t;
+ integer i0, i1, i2, j1, j2;
+ complex ra;
+ integer nr, nx, ka1, kb1;
+ complex ra1;
+ integer j1t, j2t;
+ real bii;
+ integer kbt, nrt, inca;
+ extern /* Subroutine */ int crot_(integer *, complex *, integer *,
+ complex *, integer *, real *, complex *), cgerc_(integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cgeru_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *);
+ logical upper, wantx;
+ extern /* Subroutine */ int clar2v_(integer *, complex *, complex *,
+ complex *, integer *, real *, complex *, integer *), clacgv_(
+ integer *, complex *, integer *), csscal_(integer *, real *,
+ complex *, integer *), claset_(char *, integer *, integer *,
+ complex *, complex *, complex *, integer *), clartg_(
+ complex *, complex *, real *, complex *, complex *), xerbla_(char
+ *, integer *), clargv_(integer *, complex *, integer *,
+ complex *, integer *, real *, integer *);
+ logical update;
+ extern /* Subroutine */ int clartv_(integer *, complex *, integer *,
+ complex *, integer *, real *, complex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHBGST reduces a complex Hermitian-definite banded generalized */
+/* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y, */
+/* such that C has the same bandwidth as A. */
+
+/* B must have been previously factorized as S**H*S by CPBSTF, using a */
+/* split Cholesky factorization. A is overwritten by C = X**H*A*X, where */
+/* X = S**(-1)*Q and Q is a unitary matrix chosen to preserve the */
+/* bandwidth of A. */
+
+/* Arguments */
+/* ========= */
+
+/* VECT (input) CHARACTER*1 */
+/* = 'N': do not form the transformation matrix X; */
+/* = 'V': form X. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* KA (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */
+
+/* KB (input) INTEGER */
+/* The number of superdiagonals of the matrix B if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0. */
+
+/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first ka+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */
+
+/* On exit, the transformed matrix X**H*A*X, stored in the same */
+/* format as A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KA+1. */
+
+/* BB (input) COMPLEX array, dimension (LDBB,N) */
+/* The banded factor S from the split Cholesky factorization of */
+/* B, as returned by CPBSTF, stored in the first kb+1 rows of */
+/* the array. */
+
+/* LDBB (input) INTEGER */
+/* The leading dimension of the array BB. LDBB >= KB+1. */
+
+/* X (output) COMPLEX array, dimension (LDX,N) */
+/* If VECT = 'V', the n-by-n matrix X. */
+/* If VECT = 'N', the array X is not referenced. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. */
+/* LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise. */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ bb_dim1 = *ldbb;
+ bb_offset = 1 + bb_dim1;
+ bb -= bb_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ wantx = lsame_(vect, "V");
+ upper = lsame_(uplo, "U");
+ ka1 = *ka + 1;
+ kb1 = *kb + 1;
+ *info = 0;
+ if (! wantx && ! lsame_(vect, "N")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ka < 0) {
+ *info = -4;
+ } else if (*kb < 0 || *kb > *ka) {
+ *info = -5;
+ } else if (*ldab < *ka + 1) {
+ *info = -7;
+ } else if (*ldbb < *kb + 1) {
+ *info = -9;
+ } else if (*ldx < 1 || wantx && *ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHBGST", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ inca = *ldab * ka1;
+
+/* Initialize X to the unit matrix, if needed */
+
+ if (wantx) {
+ claset_("Full", n, n, &c_b1, &c_b2, &x[x_offset], ldx);
+ }
+
+/* Set M to the splitting point m. It must be the same value as is */
+/* used in CPBSTF. The chosen value allows the arrays WORK and RWORK */
+/* to be of dimension (N). */
+
+ m = (*n + *kb) / 2;
+
+/* The routine works in two phases, corresponding to the two halves */
+/* of the split Cholesky factorization of B as S**H*S where */
+
+/* S = ( U ) */
+/* ( M L ) */
+
+/* with U upper triangular of order m, and L lower triangular of */
+/* order n-m. S has the same bandwidth as B. */
+
+/* S is treated as a product of elementary matrices: */
+
+/* S = S(m)*S(m-1)*...*S(2)*S(1)*S(m+1)*S(m+2)*...*S(n-1)*S(n) */
+
+/* where S(i) is determined by the i-th row of S. */
+
+/* In phase 1, the index i takes the values n, n-1, ... , m+1; */
+/* in phase 2, it takes the values 1, 2, ... , m. */
+
+/* For each value of i, the current matrix A is updated by forming */
+/* inv(S(i))**H*A*inv(S(i)). This creates a triangular bulge outside */
+/* the band of A. The bulge is then pushed down toward the bottom of */
+/* A in phase 1, and up toward the top of A in phase 2, by applying */
+/* plane rotations. */
+
+/* There are kb*(kb+1)/2 elements in the bulge, but at most 2*kb-1 */
+/* of them are linearly independent, so annihilating a bulge requires */
+/* only 2*kb-1 plane rotations. The rotations are divided into a 1st */
+/* set of kb-1 rotations, and a 2nd set of kb rotations. */
+
+/* Wherever possible, rotations are generated and applied in vector */
+/* operations of length NR between the indices J1 and J2 (sometimes */
+/* replaced by modified values NRT, J1T or J2T). */
+
+/* The real cosines and complex sines of the rotations are stored in */
+/* the arrays RWORK and WORK, those of the 1st set in elements */
+/* 2:m-kb-1, and those of the 2nd set in elements m-kb+1:n. */
+
+/* The bulges are not formed explicitly; nonzero elements outside the */
+/* band are created only when they are required for generating new */
+/* rotations; they are stored in the array WORK, in positions where */
+/* they are later overwritten by the sines of the rotations which */
+/* annihilate them. */
+
+/* **************************** Phase 1 ***************************** */
+
+/* The logical structure of this phase is: */
+
+/* UPDATE = .TRUE. */
+/* DO I = N, M + 1, -1 */
+/* use S(i) to update A and create a new bulge */
+/* apply rotations to push all bulges KA positions downward */
+/* END DO */
+/* UPDATE = .FALSE. */
+/* DO I = M + KA + 1, N - 1 */
+/* apply rotations to push all bulges KA positions downward */
+/* END DO */
+
+/* To avoid duplicating code, the two loops are merged. */
+
+ update = TRUE_;
+ i__ = *n + 1;
+L10:
+ if (update) {
+ --i__;
+/* Computing MIN */
+ i__1 = *kb, i__2 = i__ - 1;
+ kbt = min(i__1,i__2);
+ i0 = i__ - 1;
+/* Computing MIN */
+ i__1 = *n, i__2 = i__ + *ka;
+ i1 = min(i__1,i__2);
+ i2 = i__ - kbt + ka1;
+ if (i__ < m + 1) {
+ update = FALSE_;
+ ++i__;
+ i0 = m;
+ if (*ka == 0) {
+ goto L480;
+ }
+ goto L10;
+ }
+ } else {
+ i__ += *ka;
+ if (i__ > *n - 1) {
+ goto L480;
+ }
+ }
+
+ if (upper) {
+
+/* Transform A, working with the upper triangle */
+
+ if (update) {
+
+/* Form inv(S(i))**H * A * inv(S(i)) */
+
+ i__1 = kb1 + i__ * bb_dim1;
+ bii = bb[i__1].r;
+ i__1 = ka1 + i__ * ab_dim1;
+ i__2 = ka1 + i__ * ab_dim1;
+ r__1 = ab[i__2].r / bii / bii;
+ ab[i__1].r = r__1, ab[i__1].i = 0.f;
+ i__1 = i1;
+ for (j = i__ + 1; j <= i__1; ++j) {
+ i__2 = i__ - j + ka1 + j * ab_dim1;
+ i__3 = i__ - j + ka1 + j * ab_dim1;
+ q__1.r = ab[i__3].r / bii, q__1.i = ab[i__3].i / bii;
+ ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
+/* L20: */
+ }
+/* Computing MAX */
+ i__1 = 1, i__2 = i__ - *ka;
+ i__3 = i__ - 1;
+ for (j = max(i__1,i__2); j <= i__3; ++j) {
+ i__1 = j - i__ + ka1 + i__ * ab_dim1;
+ i__2 = j - i__ + ka1 + i__ * ab_dim1;
+ q__1.r = ab[i__2].r / bii, q__1.i = ab[i__2].i / bii;
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+/* L30: */
+ }
+ i__3 = i__ - 1;
+ for (k = i__ - kbt; k <= i__3; ++k) {
+ i__1 = k;
+ for (j = i__ - kbt; j <= i__1; ++j) {
+ i__2 = j - k + ka1 + k * ab_dim1;
+ i__4 = j - k + ka1 + k * ab_dim1;
+ i__5 = j - i__ + kb1 + i__ * bb_dim1;
+ r_cnjg(&q__5, &ab[k - i__ + ka1 + i__ * ab_dim1]);
+ q__4.r = bb[i__5].r * q__5.r - bb[i__5].i * q__5.i,
+ q__4.i = bb[i__5].r * q__5.i + bb[i__5].i *
+ q__5.r;
+ q__3.r = ab[i__4].r - q__4.r, q__3.i = ab[i__4].i -
+ q__4.i;
+ r_cnjg(&q__7, &bb[k - i__ + kb1 + i__ * bb_dim1]);
+ i__6 = j - i__ + ka1 + i__ * ab_dim1;
+ q__6.r = q__7.r * ab[i__6].r - q__7.i * ab[i__6].i,
+ q__6.i = q__7.r * ab[i__6].i + q__7.i * ab[i__6]
+ .r;
+ q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i;
+ i__7 = ka1 + i__ * ab_dim1;
+ r__1 = ab[i__7].r;
+ i__8 = j - i__ + kb1 + i__ * bb_dim1;
+ q__9.r = r__1 * bb[i__8].r, q__9.i = r__1 * bb[i__8].i;
+ r_cnjg(&q__10, &bb[k - i__ + kb1 + i__ * bb_dim1]);
+ q__8.r = q__9.r * q__10.r - q__9.i * q__10.i, q__8.i =
+ q__9.r * q__10.i + q__9.i * q__10.r;
+ q__1.r = q__2.r + q__8.r, q__1.i = q__2.i + q__8.i;
+ ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
+/* L40: */
+ }
+/* Computing MAX */
+ i__1 = 1, i__2 = i__ - *ka;
+ i__4 = i__ - kbt - 1;
+ for (j = max(i__1,i__2); j <= i__4; ++j) {
+ i__1 = j - k + ka1 + k * ab_dim1;
+ i__2 = j - k + ka1 + k * ab_dim1;
+ r_cnjg(&q__3, &bb[k - i__ + kb1 + i__ * bb_dim1]);
+ i__5 = j - i__ + ka1 + i__ * ab_dim1;
+ q__2.r = q__3.r * ab[i__5].r - q__3.i * ab[i__5].i,
+ q__2.i = q__3.r * ab[i__5].i + q__3.i * ab[i__5]
+ .r;
+ q__1.r = ab[i__2].r - q__2.r, q__1.i = ab[i__2].i -
+ q__2.i;
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+/* L50: */
+ }
+/* L60: */
+ }
+ i__3 = i1;
+ for (j = i__; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = j - *ka, i__1 = i__ - kbt;
+ i__2 = i__ - 1;
+ for (k = max(i__4,i__1); k <= i__2; ++k) {
+ i__4 = k - j + ka1 + j * ab_dim1;
+ i__1 = k - j + ka1 + j * ab_dim1;
+ i__5 = k - i__ + kb1 + i__ * bb_dim1;
+ i__6 = i__ - j + ka1 + j * ab_dim1;
+ q__2.r = bb[i__5].r * ab[i__6].r - bb[i__5].i * ab[i__6]
+ .i, q__2.i = bb[i__5].r * ab[i__6].i + bb[i__5].i
+ * ab[i__6].r;
+ q__1.r = ab[i__1].r - q__2.r, q__1.i = ab[i__1].i -
+ q__2.i;
+ ab[i__4].r = q__1.r, ab[i__4].i = q__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by inv(S(i)) */
+
+ i__3 = *n - m;
+ r__1 = 1.f / bii;
+ csscal_(&i__3, &r__1, &x[m + 1 + i__ * x_dim1], &c__1);
+ if (kbt > 0) {
+ i__3 = *n - m;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgerc_(&i__3, &kbt, &q__1, &x[m + 1 + i__ * x_dim1], &
+ c__1, &bb[kb1 - kbt + i__ * bb_dim1], &c__1, &x[m
+ + 1 + (i__ - kbt) * x_dim1], ldx);
+ }
+ }
+
+/* store a(i,i1) in RA1 for use in next loop over K */
+
+ i__3 = i__ - i1 + ka1 + i1 * ab_dim1;
+ ra1.r = ab[i__3].r, ra1.i = ab[i__3].i;
+ }
+
+/* Generate and apply vectors of rotations to chase all the */
+/* existing bulges KA positions down toward the bottom of the */
+/* band */
+
+ i__3 = *kb - 1;
+ for (k = 1; k <= i__3; ++k) {
+ if (update) {
+
+/* Determine the rotations which would annihilate the bulge */
+/* which has in theory just been created */
+
+ if (i__ - k + *ka < *n && i__ - k > 1) {
+
+/* generate rotation to annihilate a(i,i-k+ka+1) */
+
+ clartg_(&ab[k + 1 + (i__ - k + *ka) * ab_dim1], &ra1, &
+ rwork[i__ - k + *ka - m], &work[i__ - k + *ka - m]
+, &ra);
+
+/* create nonzero element a(i-k,i-k+ka+1) outside the */
+/* band and store it in WORK(i-k) */
+
+ i__2 = kb1 - k + i__ * bb_dim1;
+ q__2.r = -bb[i__2].r, q__2.i = -bb[i__2].i;
+ q__1.r = q__2.r * ra1.r - q__2.i * ra1.i, q__1.i = q__2.r
+ * ra1.i + q__2.i * ra1.r;
+ t.r = q__1.r, t.i = q__1.i;
+ i__2 = i__ - k;
+ i__4 = i__ - k + *ka - m;
+ q__2.r = rwork[i__4] * t.r, q__2.i = rwork[i__4] * t.i;
+ r_cnjg(&q__4, &work[i__ - k + *ka - m]);
+ i__1 = (i__ - k + *ka) * ab_dim1 + 1;
+ q__3.r = q__4.r * ab[i__1].r - q__4.i * ab[i__1].i,
+ q__3.i = q__4.r * ab[i__1].i + q__4.i * ab[i__1]
+ .r;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ i__2 = (i__ - k + *ka) * ab_dim1 + 1;
+ i__4 = i__ - k + *ka - m;
+ q__2.r = work[i__4].r * t.r - work[i__4].i * t.i, q__2.i =
+ work[i__4].r * t.i + work[i__4].i * t.r;
+ i__1 = i__ - k + *ka - m;
+ i__5 = (i__ - k + *ka) * ab_dim1 + 1;
+ q__3.r = rwork[i__1] * ab[i__5].r, q__3.i = rwork[i__1] *
+ ab[i__5].i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
+ ra1.r = ra.r, ra1.i = ra.i;
+ }
+ }
+/* Computing MAX */
+ i__2 = 1, i__4 = k - i0 + 2;
+ j2 = i__ - k - 1 + max(i__2,i__4) * ka1;
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ if (update) {
+/* Computing MAX */
+ i__2 = j2, i__4 = i__ + (*ka << 1) - k + 1;
+ j2t = max(i__2,i__4);
+ } else {
+ j2t = j2;
+ }
+ nrt = (*n - j2t + *ka) / ka1;
+ i__2 = j1;
+ i__4 = ka1;
+ for (j = j2t; i__4 < 0 ? j >= i__2 : j <= i__2; j += i__4) {
+
+/* create nonzero element a(j-ka,j+1) outside the band */
+/* and store it in WORK(j-m) */
+
+ i__1 = j - m;
+ i__5 = j - m;
+ i__6 = (j + 1) * ab_dim1 + 1;
+ q__1.r = work[i__5].r * ab[i__6].r - work[i__5].i * ab[i__6]
+ .i, q__1.i = work[i__5].r * ab[i__6].i + work[i__5].i
+ * ab[i__6].r;
+ work[i__1].r = q__1.r, work[i__1].i = q__1.i;
+ i__1 = (j + 1) * ab_dim1 + 1;
+ i__5 = j - m;
+ i__6 = (j + 1) * ab_dim1 + 1;
+ q__1.r = rwork[i__5] * ab[i__6].r, q__1.i = rwork[i__5] * ab[
+ i__6].i;
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+/* L90: */
+ }
+
+/* generate rotations in 1st set to annihilate elements which */
+/* have been created outside the band */
+
+ if (nrt > 0) {
+ clargv_(&nrt, &ab[j2t * ab_dim1 + 1], &inca, &work[j2t - m], &
+ ka1, &rwork[j2t - m], &ka1);
+ }
+ if (nr > 0) {
+
+/* apply rotations in 1st set from the right */
+
+ i__4 = *ka - 1;
+ for (l = 1; l <= i__4; ++l) {
+ clartv_(&nr, &ab[ka1 - l + j2 * ab_dim1], &inca, &ab[*ka
+ - l + (j2 + 1) * ab_dim1], &inca, &rwork[j2 - m],
+ &work[j2 - m], &ka1);
+/* L100: */
+ }
+
+/* apply rotations in 1st set from both sides to diagonal */
+/* blocks */
+
+ clar2v_(&nr, &ab[ka1 + j2 * ab_dim1], &ab[ka1 + (j2 + 1) *
+ ab_dim1], &ab[*ka + (j2 + 1) * ab_dim1], &inca, &
+ rwork[j2 - m], &work[j2 - m], &ka1);
+
+ clacgv_(&nr, &work[j2 - m], &ka1);
+ }
+
+/* start applying rotations in 1st set from the left */
+
+ i__4 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__4; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ clartv_(&nrt, &ab[l + (j2 + ka1 - l) * ab_dim1], &inca, &
+ ab[l + 1 + (j2 + ka1 - l) * ab_dim1], &inca, &
+ rwork[j2 - m], &work[j2 - m], &ka1);
+ }
+/* L110: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 1st set */
+
+ i__4 = j1;
+ i__2 = ka1;
+ for (j = j2; i__2 < 0 ? j >= i__4 : j <= i__4; j += i__2) {
+ i__1 = *n - m;
+ r_cnjg(&q__1, &work[j - m]);
+ crot_(&i__1, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j
+ + 1) * x_dim1], &c__1, &rwork[j - m], &q__1);
+/* L120: */
+ }
+ }
+/* L130: */
+ }
+
+ if (update) {
+ if (i2 <= *n && kbt > 0) {
+
+/* create nonzero element a(i-kbt,i-kbt+ka+1) outside the */
+/* band and store it in WORK(i-kbt) */
+
+ i__3 = i__ - kbt;
+ i__2 = kb1 - kbt + i__ * bb_dim1;
+ q__2.r = -bb[i__2].r, q__2.i = -bb[i__2].i;
+ q__1.r = q__2.r * ra1.r - q__2.i * ra1.i, q__1.i = q__2.r *
+ ra1.i + q__2.i * ra1.r;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ }
+ }
+
+ for (k = *kb; k >= 1; --k) {
+ if (update) {
+/* Computing MAX */
+ i__3 = 2, i__2 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__3,i__2) * ka1;
+ } else {
+/* Computing MAX */
+ i__3 = 1, i__2 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__3,i__2) * ka1;
+ }
+
+/* finish applying rotations in 2nd set from the left */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (*n - j2 + *ka + l) / ka1;
+ if (nrt > 0) {
+ clartv_(&nrt, &ab[l + (j2 - l + 1) * ab_dim1], &inca, &ab[
+ l + 1 + (j2 - l + 1) * ab_dim1], &inca, &rwork[j2
+ - *ka], &work[j2 - *ka], &ka1);
+ }
+/* L140: */
+ }
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ i__3 = j2;
+ i__2 = -ka1;
+ for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2) {
+ i__4 = j;
+ i__1 = j - *ka;
+ work[i__4].r = work[i__1].r, work[i__4].i = work[i__1].i;
+ rwork[j] = rwork[j - *ka];
+/* L150: */
+ }
+ i__2 = j1;
+ i__3 = ka1;
+ for (j = j2; i__3 < 0 ? j >= i__2 : j <= i__2; j += i__3) {
+
+/* create nonzero element a(j-ka,j+1) outside the band */
+/* and store it in WORK(j) */
+
+ i__4 = j;
+ i__1 = j;
+ i__5 = (j + 1) * ab_dim1 + 1;
+ q__1.r = work[i__1].r * ab[i__5].r - work[i__1].i * ab[i__5]
+ .i, q__1.i = work[i__1].r * ab[i__5].i + work[i__1].i
+ * ab[i__5].r;
+ work[i__4].r = q__1.r, work[i__4].i = q__1.i;
+ i__4 = (j + 1) * ab_dim1 + 1;
+ i__1 = j;
+ i__5 = (j + 1) * ab_dim1 + 1;
+ q__1.r = rwork[i__1] * ab[i__5].r, q__1.i = rwork[i__1] * ab[
+ i__5].i;
+ ab[i__4].r = q__1.r, ab[i__4].i = q__1.i;
+/* L160: */
+ }
+ if (update) {
+ if (i__ - k < *n - *ka && k <= kbt) {
+ i__3 = i__ - k + *ka;
+ i__2 = i__ - k;
+ work[i__3].r = work[i__2].r, work[i__3].i = work[i__2].i;
+ }
+ }
+/* L170: */
+ }
+
+ for (k = *kb; k >= 1; --k) {
+/* Computing MAX */
+ i__3 = 1, i__2 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__3,i__2) * ka1;
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ if (nr > 0) {
+
+/* generate rotations in 2nd set to annihilate elements */
+/* which have been created outside the band */
+
+ clargv_(&nr, &ab[j2 * ab_dim1 + 1], &inca, &work[j2], &ka1, &
+ rwork[j2], &ka1);
+
+/* apply rotations in 2nd set from the right */
+
+ i__3 = *ka - 1;
+ for (l = 1; l <= i__3; ++l) {
+ clartv_(&nr, &ab[ka1 - l + j2 * ab_dim1], &inca, &ab[*ka
+ - l + (j2 + 1) * ab_dim1], &inca, &rwork[j2], &
+ work[j2], &ka1);
+/* L180: */
+ }
+
+/* apply rotations in 2nd set from both sides to diagonal */
+/* blocks */
+
+ clar2v_(&nr, &ab[ka1 + j2 * ab_dim1], &ab[ka1 + (j2 + 1) *
+ ab_dim1], &ab[*ka + (j2 + 1) * ab_dim1], &inca, &
+ rwork[j2], &work[j2], &ka1);
+
+ clacgv_(&nr, &work[j2], &ka1);
+ }
+
+/* start applying rotations in 2nd set from the left */
+
+ i__3 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__3; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ clartv_(&nrt, &ab[l + (j2 + ka1 - l) * ab_dim1], &inca, &
+ ab[l + 1 + (j2 + ka1 - l) * ab_dim1], &inca, &
+ rwork[j2], &work[j2], &ka1);
+ }
+/* L190: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 2nd set */
+
+ i__3 = j1;
+ i__2 = ka1;
+ for (j = j2; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2) {
+ i__4 = *n - m;
+ r_cnjg(&q__1, &work[j]);
+ crot_(&i__4, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j
+ + 1) * x_dim1], &c__1, &rwork[j], &q__1);
+/* L200: */
+ }
+ }
+/* L210: */
+ }
+
+ i__2 = *kb - 1;
+ for (k = 1; k <= i__2; ++k) {
+/* Computing MAX */
+ i__3 = 1, i__4 = k - i0 + 2;
+ j2 = i__ - k - 1 + max(i__3,i__4) * ka1;
+
+/* finish applying rotations in 1st set from the left */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ clartv_(&nrt, &ab[l + (j2 + ka1 - l) * ab_dim1], &inca, &
+ ab[l + 1 + (j2 + ka1 - l) * ab_dim1], &inca, &
+ rwork[j2 - m], &work[j2 - m], &ka1);
+ }
+/* L220: */
+ }
+/* L230: */
+ }
+
+ if (*kb > 1) {
+ i__2 = i2 + *ka;
+ for (j = *n - 1; j >= i__2; --j) {
+ rwork[j - m] = rwork[j - *ka - m];
+ i__3 = j - m;
+ i__4 = j - *ka - m;
+ work[i__3].r = work[i__4].r, work[i__3].i = work[i__4].i;
+/* L240: */
+ }
+ }
+
+ } else {
+
+/* Transform A, working with the lower triangle */
+
+ if (update) {
+
+/* Form inv(S(i))**H * A * inv(S(i)) */
+
+ i__2 = i__ * bb_dim1 + 1;
+ bii = bb[i__2].r;
+ i__2 = i__ * ab_dim1 + 1;
+ i__3 = i__ * ab_dim1 + 1;
+ r__1 = ab[i__3].r / bii / bii;
+ ab[i__2].r = r__1, ab[i__2].i = 0.f;
+ i__2 = i1;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j - i__ + 1 + i__ * ab_dim1;
+ i__4 = j - i__ + 1 + i__ * ab_dim1;
+ q__1.r = ab[i__4].r / bii, q__1.i = ab[i__4].i / bii;
+ ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
+/* L250: */
+ }
+/* Computing MAX */
+ i__2 = 1, i__3 = i__ - *ka;
+ i__4 = i__ - 1;
+ for (j = max(i__2,i__3); j <= i__4; ++j) {
+ i__2 = i__ - j + 1 + j * ab_dim1;
+ i__3 = i__ - j + 1 + j * ab_dim1;
+ q__1.r = ab[i__3].r / bii, q__1.i = ab[i__3].i / bii;
+ ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
+/* L260: */
+ }
+ i__4 = i__ - 1;
+ for (k = i__ - kbt; k <= i__4; ++k) {
+ i__2 = k;
+ for (j = i__ - kbt; j <= i__2; ++j) {
+ i__3 = k - j + 1 + j * ab_dim1;
+ i__1 = k - j + 1 + j * ab_dim1;
+ i__5 = i__ - j + 1 + j * bb_dim1;
+ r_cnjg(&q__5, &ab[i__ - k + 1 + k * ab_dim1]);
+ q__4.r = bb[i__5].r * q__5.r - bb[i__5].i * q__5.i,
+ q__4.i = bb[i__5].r * q__5.i + bb[i__5].i *
+ q__5.r;
+ q__3.r = ab[i__1].r - q__4.r, q__3.i = ab[i__1].i -
+ q__4.i;
+ r_cnjg(&q__7, &bb[i__ - k + 1 + k * bb_dim1]);
+ i__6 = i__ - j + 1 + j * ab_dim1;
+ q__6.r = q__7.r * ab[i__6].r - q__7.i * ab[i__6].i,
+ q__6.i = q__7.r * ab[i__6].i + q__7.i * ab[i__6]
+ .r;
+ q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i;
+ i__7 = i__ * ab_dim1 + 1;
+ r__1 = ab[i__7].r;
+ i__8 = i__ - j + 1 + j * bb_dim1;
+ q__9.r = r__1 * bb[i__8].r, q__9.i = r__1 * bb[i__8].i;
+ r_cnjg(&q__10, &bb[i__ - k + 1 + k * bb_dim1]);
+ q__8.r = q__9.r * q__10.r - q__9.i * q__10.i, q__8.i =
+ q__9.r * q__10.i + q__9.i * q__10.r;
+ q__1.r = q__2.r + q__8.r, q__1.i = q__2.i + q__8.i;
+ ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
+/* L270: */
+ }
+/* Computing MAX */
+ i__2 = 1, i__3 = i__ - *ka;
+ i__1 = i__ - kbt - 1;
+ for (j = max(i__2,i__3); j <= i__1; ++j) {
+ i__2 = k - j + 1 + j * ab_dim1;
+ i__3 = k - j + 1 + j * ab_dim1;
+ r_cnjg(&q__3, &bb[i__ - k + 1 + k * bb_dim1]);
+ i__5 = i__ - j + 1 + j * ab_dim1;
+ q__2.r = q__3.r * ab[i__5].r - q__3.i * ab[i__5].i,
+ q__2.i = q__3.r * ab[i__5].i + q__3.i * ab[i__5]
+ .r;
+ q__1.r = ab[i__3].r - q__2.r, q__1.i = ab[i__3].i -
+ q__2.i;
+ ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
+/* L280: */
+ }
+/* L290: */
+ }
+ i__4 = i1;
+ for (j = i__; j <= i__4; ++j) {
+/* Computing MAX */
+ i__1 = j - *ka, i__2 = i__ - kbt;
+ i__3 = i__ - 1;
+ for (k = max(i__1,i__2); k <= i__3; ++k) {
+ i__1 = j - k + 1 + k * ab_dim1;
+ i__2 = j - k + 1 + k * ab_dim1;
+ i__5 = i__ - k + 1 + k * bb_dim1;
+ i__6 = j - i__ + 1 + i__ * ab_dim1;
+ q__2.r = bb[i__5].r * ab[i__6].r - bb[i__5].i * ab[i__6]
+ .i, q__2.i = bb[i__5].r * ab[i__6].i + bb[i__5].i
+ * ab[i__6].r;
+ q__1.r = ab[i__2].r - q__2.r, q__1.i = ab[i__2].i -
+ q__2.i;
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+/* L300: */
+ }
+/* L310: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by inv(S(i)) */
+
+ i__4 = *n - m;
+ r__1 = 1.f / bii;
+ csscal_(&i__4, &r__1, &x[m + 1 + i__ * x_dim1], &c__1);
+ if (kbt > 0) {
+ i__4 = *n - m;
+ q__1.r = -1.f, q__1.i = -0.f;
+ i__3 = *ldbb - 1;
+ cgeru_(&i__4, &kbt, &q__1, &x[m + 1 + i__ * x_dim1], &
+ c__1, &bb[kbt + 1 + (i__ - kbt) * bb_dim1], &i__3,
+ &x[m + 1 + (i__ - kbt) * x_dim1], ldx);
+ }
+ }
+
+/* store a(i1,i) in RA1 for use in next loop over K */
+
+ i__4 = i1 - i__ + 1 + i__ * ab_dim1;
+ ra1.r = ab[i__4].r, ra1.i = ab[i__4].i;
+ }
+
+/* Generate and apply vectors of rotations to chase all the */
+/* existing bulges KA positions down toward the bottom of the */
+/* band */
+
+ i__4 = *kb - 1;
+ for (k = 1; k <= i__4; ++k) {
+ if (update) {
+
+/* Determine the rotations which would annihilate the bulge */
+/* which has in theory just been created */
+
+ if (i__ - k + *ka < *n && i__ - k > 1) {
+
+/* generate rotation to annihilate a(i-k+ka+1,i) */
+
+ clartg_(&ab[ka1 - k + i__ * ab_dim1], &ra1, &rwork[i__ -
+ k + *ka - m], &work[i__ - k + *ka - m], &ra);
+
+/* create nonzero element a(i-k+ka+1,i-k) outside the */
+/* band and store it in WORK(i-k) */
+
+ i__3 = k + 1 + (i__ - k) * bb_dim1;
+ q__2.r = -bb[i__3].r, q__2.i = -bb[i__3].i;
+ q__1.r = q__2.r * ra1.r - q__2.i * ra1.i, q__1.i = q__2.r
+ * ra1.i + q__2.i * ra1.r;
+ t.r = q__1.r, t.i = q__1.i;
+ i__3 = i__ - k;
+ i__1 = i__ - k + *ka - m;
+ q__2.r = rwork[i__1] * t.r, q__2.i = rwork[i__1] * t.i;
+ r_cnjg(&q__4, &work[i__ - k + *ka - m]);
+ i__2 = ka1 + (i__ - k) * ab_dim1;
+ q__3.r = q__4.r * ab[i__2].r - q__4.i * ab[i__2].i,
+ q__3.i = q__4.r * ab[i__2].i + q__4.i * ab[i__2]
+ .r;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ i__3 = ka1 + (i__ - k) * ab_dim1;
+ i__1 = i__ - k + *ka - m;
+ q__2.r = work[i__1].r * t.r - work[i__1].i * t.i, q__2.i =
+ work[i__1].r * t.i + work[i__1].i * t.r;
+ i__2 = i__ - k + *ka - m;
+ i__5 = ka1 + (i__ - k) * ab_dim1;
+ q__3.r = rwork[i__2] * ab[i__5].r, q__3.i = rwork[i__2] *
+ ab[i__5].i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
+ ra1.r = ra.r, ra1.i = ra.i;
+ }
+ }
+/* Computing MAX */
+ i__3 = 1, i__1 = k - i0 + 2;
+ j2 = i__ - k - 1 + max(i__3,i__1) * ka1;
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ if (update) {
+/* Computing MAX */
+ i__3 = j2, i__1 = i__ + (*ka << 1) - k + 1;
+ j2t = max(i__3,i__1);
+ } else {
+ j2t = j2;
+ }
+ nrt = (*n - j2t + *ka) / ka1;
+ i__3 = j1;
+ i__1 = ka1;
+ for (j = j2t; i__1 < 0 ? j >= i__3 : j <= i__3; j += i__1) {
+
+/* create nonzero element a(j+1,j-ka) outside the band */
+/* and store it in WORK(j-m) */
+
+ i__2 = j - m;
+ i__5 = j - m;
+ i__6 = ka1 + (j - *ka + 1) * ab_dim1;
+ q__1.r = work[i__5].r * ab[i__6].r - work[i__5].i * ab[i__6]
+ .i, q__1.i = work[i__5].r * ab[i__6].i + work[i__5].i
+ * ab[i__6].r;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ i__2 = ka1 + (j - *ka + 1) * ab_dim1;
+ i__5 = j - m;
+ i__6 = ka1 + (j - *ka + 1) * ab_dim1;
+ q__1.r = rwork[i__5] * ab[i__6].r, q__1.i = rwork[i__5] * ab[
+ i__6].i;
+ ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
+/* L320: */
+ }
+
+/* generate rotations in 1st set to annihilate elements which */
+/* have been created outside the band */
+
+ if (nrt > 0) {
+ clargv_(&nrt, &ab[ka1 + (j2t - *ka) * ab_dim1], &inca, &work[
+ j2t - m], &ka1, &rwork[j2t - m], &ka1);
+ }
+ if (nr > 0) {
+
+/* apply rotations in 1st set from the left */
+
+ i__1 = *ka - 1;
+ for (l = 1; l <= i__1; ++l) {
+ clartv_(&nr, &ab[l + 1 + (j2 - l) * ab_dim1], &inca, &ab[
+ l + 2 + (j2 - l) * ab_dim1], &inca, &rwork[j2 - m]
+, &work[j2 - m], &ka1);
+/* L330: */
+ }
+
+/* apply rotations in 1st set from both sides to diagonal */
+/* blocks */
+
+ clar2v_(&nr, &ab[j2 * ab_dim1 + 1], &ab[(j2 + 1) * ab_dim1 +
+ 1], &ab[j2 * ab_dim1 + 2], &inca, &rwork[j2 - m], &
+ work[j2 - m], &ka1);
+
+ clacgv_(&nr, &work[j2 - m], &ka1);
+ }
+
+/* start applying rotations in 1st set from the right */
+
+ i__1 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__1; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ clartv_(&nrt, &ab[ka1 - l + 1 + j2 * ab_dim1], &inca, &ab[
+ ka1 - l + (j2 + 1) * ab_dim1], &inca, &rwork[j2 -
+ m], &work[j2 - m], &ka1);
+ }
+/* L340: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 1st set */
+
+ i__1 = j1;
+ i__3 = ka1;
+ for (j = j2; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) {
+ i__2 = *n - m;
+ crot_(&i__2, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j
+ + 1) * x_dim1], &c__1, &rwork[j - m], &work[j - m]
+);
+/* L350: */
+ }
+ }
+/* L360: */
+ }
+
+ if (update) {
+ if (i2 <= *n && kbt > 0) {
+
+/* create nonzero element a(i-kbt+ka+1,i-kbt) outside the */
+/* band and store it in WORK(i-kbt) */
+
+ i__4 = i__ - kbt;
+ i__3 = kbt + 1 + (i__ - kbt) * bb_dim1;
+ q__2.r = -bb[i__3].r, q__2.i = -bb[i__3].i;
+ q__1.r = q__2.r * ra1.r - q__2.i * ra1.i, q__1.i = q__2.r *
+ ra1.i + q__2.i * ra1.r;
+ work[i__4].r = q__1.r, work[i__4].i = q__1.i;
+ }
+ }
+
+ for (k = *kb; k >= 1; --k) {
+ if (update) {
+/* Computing MAX */
+ i__4 = 2, i__3 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__4,i__3) * ka1;
+ } else {
+/* Computing MAX */
+ i__4 = 1, i__3 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__4,i__3) * ka1;
+ }
+
+/* finish applying rotations in 2nd set from the right */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (*n - j2 + *ka + l) / ka1;
+ if (nrt > 0) {
+ clartv_(&nrt, &ab[ka1 - l + 1 + (j2 - *ka) * ab_dim1], &
+ inca, &ab[ka1 - l + (j2 - *ka + 1) * ab_dim1], &
+ inca, &rwork[j2 - *ka], &work[j2 - *ka], &ka1);
+ }
+/* L370: */
+ }
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ i__4 = j2;
+ i__3 = -ka1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) {
+ i__1 = j;
+ i__2 = j - *ka;
+ work[i__1].r = work[i__2].r, work[i__1].i = work[i__2].i;
+ rwork[j] = rwork[j - *ka];
+/* L380: */
+ }
+ i__3 = j1;
+ i__4 = ka1;
+ for (j = j2; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+
+/* create nonzero element a(j+1,j-ka) outside the band */
+/* and store it in WORK(j) */
+
+ i__1 = j;
+ i__2 = j;
+ i__5 = ka1 + (j - *ka + 1) * ab_dim1;
+ q__1.r = work[i__2].r * ab[i__5].r - work[i__2].i * ab[i__5]
+ .i, q__1.i = work[i__2].r * ab[i__5].i + work[i__2].i
+ * ab[i__5].r;
+ work[i__1].r = q__1.r, work[i__1].i = q__1.i;
+ i__1 = ka1 + (j - *ka + 1) * ab_dim1;
+ i__2 = j;
+ i__5 = ka1 + (j - *ka + 1) * ab_dim1;
+ q__1.r = rwork[i__2] * ab[i__5].r, q__1.i = rwork[i__2] * ab[
+ i__5].i;
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+/* L390: */
+ }
+ if (update) {
+ if (i__ - k < *n - *ka && k <= kbt) {
+ i__4 = i__ - k + *ka;
+ i__3 = i__ - k;
+ work[i__4].r = work[i__3].r, work[i__4].i = work[i__3].i;
+ }
+ }
+/* L400: */
+ }
+
+ for (k = *kb; k >= 1; --k) {
+/* Computing MAX */
+ i__4 = 1, i__3 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__4,i__3) * ka1;
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ if (nr > 0) {
+
+/* generate rotations in 2nd set to annihilate elements */
+/* which have been created outside the band */
+
+ clargv_(&nr, &ab[ka1 + (j2 - *ka) * ab_dim1], &inca, &work[j2]
+, &ka1, &rwork[j2], &ka1);
+
+/* apply rotations in 2nd set from the left */
+
+ i__4 = *ka - 1;
+ for (l = 1; l <= i__4; ++l) {
+ clartv_(&nr, &ab[l + 1 + (j2 - l) * ab_dim1], &inca, &ab[
+ l + 2 + (j2 - l) * ab_dim1], &inca, &rwork[j2], &
+ work[j2], &ka1);
+/* L410: */
+ }
+
+/* apply rotations in 2nd set from both sides to diagonal */
+/* blocks */
+
+ clar2v_(&nr, &ab[j2 * ab_dim1 + 1], &ab[(j2 + 1) * ab_dim1 +
+ 1], &ab[j2 * ab_dim1 + 2], &inca, &rwork[j2], &work[
+ j2], &ka1);
+
+ clacgv_(&nr, &work[j2], &ka1);
+ }
+
+/* start applying rotations in 2nd set from the right */
+
+ i__4 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__4; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ clartv_(&nrt, &ab[ka1 - l + 1 + j2 * ab_dim1], &inca, &ab[
+ ka1 - l + (j2 + 1) * ab_dim1], &inca, &rwork[j2],
+ &work[j2], &ka1);
+ }
+/* L420: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 2nd set */
+
+ i__4 = j1;
+ i__3 = ka1;
+ for (j = j2; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) {
+ i__1 = *n - m;
+ crot_(&i__1, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j
+ + 1) * x_dim1], &c__1, &rwork[j], &work[j]);
+/* L430: */
+ }
+ }
+/* L440: */
+ }
+
+ i__3 = *kb - 1;
+ for (k = 1; k <= i__3; ++k) {
+/* Computing MAX */
+ i__4 = 1, i__1 = k - i0 + 2;
+ j2 = i__ - k - 1 + max(i__4,i__1) * ka1;
+
+/* finish applying rotations in 1st set from the right */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ clartv_(&nrt, &ab[ka1 - l + 1 + j2 * ab_dim1], &inca, &ab[
+ ka1 - l + (j2 + 1) * ab_dim1], &inca, &rwork[j2 -
+ m], &work[j2 - m], &ka1);
+ }
+/* L450: */
+ }
+/* L460: */
+ }
+
+ if (*kb > 1) {
+ i__3 = i2 + *ka;
+ for (j = *n - 1; j >= i__3; --j) {
+ rwork[j - m] = rwork[j - *ka - m];
+ i__4 = j - m;
+ i__1 = j - *ka - m;
+ work[i__4].r = work[i__1].r, work[i__4].i = work[i__1].i;
+/* L470: */
+ }
+ }
+
+ }
+
+ goto L10;
+
+L480:
+
+/* **************************** Phase 2 ***************************** */
+
+/* The logical structure of this phase is: */
+
+/* UPDATE = .TRUE. */
+/* DO I = 1, M */
+/* use S(i) to update A and create a new bulge */
+/* apply rotations to push all bulges KA positions upward */
+/* END DO */
+/* UPDATE = .FALSE. */
+/* DO I = M - KA - 1, 2, -1 */
+/* apply rotations to push all bulges KA positions upward */
+/* END DO */
+
+/* To avoid duplicating code, the two loops are merged. */
+
+ update = TRUE_;
+ i__ = 0;
+L490:
+ if (update) {
+ ++i__;
+/* Computing MIN */
+ i__3 = *kb, i__4 = m - i__;
+ kbt = min(i__3,i__4);
+ i0 = i__ + 1;
+/* Computing MAX */
+ i__3 = 1, i__4 = i__ - *ka;
+ i1 = max(i__3,i__4);
+ i2 = i__ + kbt - ka1;
+ if (i__ > m) {
+ update = FALSE_;
+ --i__;
+ i0 = m + 1;
+ if (*ka == 0) {
+ return 0;
+ }
+ goto L490;
+ }
+ } else {
+ i__ -= *ka;
+ if (i__ < 2) {
+ return 0;
+ }
+ }
+
+ if (i__ < m - kbt) {
+ nx = m;
+ } else {
+ nx = *n;
+ }
+
+ if (upper) {
+
+/* Transform A, working with the upper triangle */
+
+ if (update) {
+
+/* Form inv(S(i))**H * A * inv(S(i)) */
+
+ i__3 = kb1 + i__ * bb_dim1;
+ bii = bb[i__3].r;
+ i__3 = ka1 + i__ * ab_dim1;
+ i__4 = ka1 + i__ * ab_dim1;
+ r__1 = ab[i__4].r / bii / bii;
+ ab[i__3].r = r__1, ab[i__3].i = 0.f;
+ i__3 = i__ - 1;
+ for (j = i1; j <= i__3; ++j) {
+ i__4 = j - i__ + ka1 + i__ * ab_dim1;
+ i__1 = j - i__ + ka1 + i__ * ab_dim1;
+ q__1.r = ab[i__1].r / bii, q__1.i = ab[i__1].i / bii;
+ ab[i__4].r = q__1.r, ab[i__4].i = q__1.i;
+/* L500: */
+ }
+/* Computing MIN */
+ i__4 = *n, i__1 = i__ + *ka;
+ i__3 = min(i__4,i__1);
+ for (j = i__ + 1; j <= i__3; ++j) {
+ i__4 = i__ - j + ka1 + j * ab_dim1;
+ i__1 = i__ - j + ka1 + j * ab_dim1;
+ q__1.r = ab[i__1].r / bii, q__1.i = ab[i__1].i / bii;
+ ab[i__4].r = q__1.r, ab[i__4].i = q__1.i;
+/* L510: */
+ }
+ i__3 = i__ + kbt;
+ for (k = i__ + 1; k <= i__3; ++k) {
+ i__4 = i__ + kbt;
+ for (j = k; j <= i__4; ++j) {
+ i__1 = k - j + ka1 + j * ab_dim1;
+ i__2 = k - j + ka1 + j * ab_dim1;
+ i__5 = i__ - j + kb1 + j * bb_dim1;
+ r_cnjg(&q__5, &ab[i__ - k + ka1 + k * ab_dim1]);
+ q__4.r = bb[i__5].r * q__5.r - bb[i__5].i * q__5.i,
+ q__4.i = bb[i__5].r * q__5.i + bb[i__5].i *
+ q__5.r;
+ q__3.r = ab[i__2].r - q__4.r, q__3.i = ab[i__2].i -
+ q__4.i;
+ r_cnjg(&q__7, &bb[i__ - k + kb1 + k * bb_dim1]);
+ i__6 = i__ - j + ka1 + j * ab_dim1;
+ q__6.r = q__7.r * ab[i__6].r - q__7.i * ab[i__6].i,
+ q__6.i = q__7.r * ab[i__6].i + q__7.i * ab[i__6]
+ .r;
+ q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i;
+ i__7 = ka1 + i__ * ab_dim1;
+ r__1 = ab[i__7].r;
+ i__8 = i__ - j + kb1 + j * bb_dim1;
+ q__9.r = r__1 * bb[i__8].r, q__9.i = r__1 * bb[i__8].i;
+ r_cnjg(&q__10, &bb[i__ - k + kb1 + k * bb_dim1]);
+ q__8.r = q__9.r * q__10.r - q__9.i * q__10.i, q__8.i =
+ q__9.r * q__10.i + q__9.i * q__10.r;
+ q__1.r = q__2.r + q__8.r, q__1.i = q__2.i + q__8.i;
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+/* L520: */
+ }
+/* Computing MIN */
+ i__1 = *n, i__2 = i__ + *ka;
+ i__4 = min(i__1,i__2);
+ for (j = i__ + kbt + 1; j <= i__4; ++j) {
+ i__1 = k - j + ka1 + j * ab_dim1;
+ i__2 = k - j + ka1 + j * ab_dim1;
+ r_cnjg(&q__3, &bb[i__ - k + kb1 + k * bb_dim1]);
+ i__5 = i__ - j + ka1 + j * ab_dim1;
+ q__2.r = q__3.r * ab[i__5].r - q__3.i * ab[i__5].i,
+ q__2.i = q__3.r * ab[i__5].i + q__3.i * ab[i__5]
+ .r;
+ q__1.r = ab[i__2].r - q__2.r, q__1.i = ab[i__2].i -
+ q__2.i;
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+/* L530: */
+ }
+/* L540: */
+ }
+ i__3 = i__;
+ for (j = i1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__1 = j + *ka, i__2 = i__ + kbt;
+ i__4 = min(i__1,i__2);
+ for (k = i__ + 1; k <= i__4; ++k) {
+ i__1 = j - k + ka1 + k * ab_dim1;
+ i__2 = j - k + ka1 + k * ab_dim1;
+ i__5 = i__ - k + kb1 + k * bb_dim1;
+ i__6 = j - i__ + ka1 + i__ * ab_dim1;
+ q__2.r = bb[i__5].r * ab[i__6].r - bb[i__5].i * ab[i__6]
+ .i, q__2.i = bb[i__5].r * ab[i__6].i + bb[i__5].i
+ * ab[i__6].r;
+ q__1.r = ab[i__2].r - q__2.r, q__1.i = ab[i__2].i -
+ q__2.i;
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+/* L550: */
+ }
+/* L560: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by inv(S(i)) */
+
+ r__1 = 1.f / bii;
+ csscal_(&nx, &r__1, &x[i__ * x_dim1 + 1], &c__1);
+ if (kbt > 0) {
+ q__1.r = -1.f, q__1.i = -0.f;
+ i__3 = *ldbb - 1;
+ cgeru_(&nx, &kbt, &q__1, &x[i__ * x_dim1 + 1], &c__1, &bb[
+ *kb + (i__ + 1) * bb_dim1], &i__3, &x[(i__ + 1) *
+ x_dim1 + 1], ldx);
+ }
+ }
+
+/* store a(i1,i) in RA1 for use in next loop over K */
+
+ i__3 = i1 - i__ + ka1 + i__ * ab_dim1;
+ ra1.r = ab[i__3].r, ra1.i = ab[i__3].i;
+ }
+
+/* Generate and apply vectors of rotations to chase all the */
+/* existing bulges KA positions up toward the top of the band */
+
+ i__3 = *kb - 1;
+ for (k = 1; k <= i__3; ++k) {
+ if (update) {
+
+/* Determine the rotations which would annihilate the bulge */
+/* which has in theory just been created */
+
+ if (i__ + k - ka1 > 0 && i__ + k < m) {
+
+/* generate rotation to annihilate a(i+k-ka-1,i) */
+
+ clartg_(&ab[k + 1 + i__ * ab_dim1], &ra1, &rwork[i__ + k
+ - *ka], &work[i__ + k - *ka], &ra);
+
+/* create nonzero element a(i+k-ka-1,i+k) outside the */
+/* band and store it in WORK(m-kb+i+k) */
+
+ i__4 = kb1 - k + (i__ + k) * bb_dim1;
+ q__2.r = -bb[i__4].r, q__2.i = -bb[i__4].i;
+ q__1.r = q__2.r * ra1.r - q__2.i * ra1.i, q__1.i = q__2.r
+ * ra1.i + q__2.i * ra1.r;
+ t.r = q__1.r, t.i = q__1.i;
+ i__4 = m - *kb + i__ + k;
+ i__1 = i__ + k - *ka;
+ q__2.r = rwork[i__1] * t.r, q__2.i = rwork[i__1] * t.i;
+ r_cnjg(&q__4, &work[i__ + k - *ka]);
+ i__2 = (i__ + k) * ab_dim1 + 1;
+ q__3.r = q__4.r * ab[i__2].r - q__4.i * ab[i__2].i,
+ q__3.i = q__4.r * ab[i__2].i + q__4.i * ab[i__2]
+ .r;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ work[i__4].r = q__1.r, work[i__4].i = q__1.i;
+ i__4 = (i__ + k) * ab_dim1 + 1;
+ i__1 = i__ + k - *ka;
+ q__2.r = work[i__1].r * t.r - work[i__1].i * t.i, q__2.i =
+ work[i__1].r * t.i + work[i__1].i * t.r;
+ i__2 = i__ + k - *ka;
+ i__5 = (i__ + k) * ab_dim1 + 1;
+ q__3.r = rwork[i__2] * ab[i__5].r, q__3.i = rwork[i__2] *
+ ab[i__5].i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ ab[i__4].r = q__1.r, ab[i__4].i = q__1.i;
+ ra1.r = ra.r, ra1.i = ra.i;
+ }
+ }
+/* Computing MAX */
+ i__4 = 1, i__1 = k + i0 - m + 1;
+ j2 = i__ + k + 1 - max(i__4,i__1) * ka1;
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ if (update) {
+/* Computing MIN */
+ i__4 = j2, i__1 = i__ - (*ka << 1) + k - 1;
+ j2t = min(i__4,i__1);
+ } else {
+ j2t = j2;
+ }
+ nrt = (j2t + *ka - 1) / ka1;
+ i__4 = j2t;
+ i__1 = ka1;
+ for (j = j1; i__1 < 0 ? j >= i__4 : j <= i__4; j += i__1) {
+
+/* create nonzero element a(j-1,j+ka) outside the band */
+/* and store it in WORK(j) */
+
+ i__2 = j;
+ i__5 = j;
+ i__6 = (j + *ka - 1) * ab_dim1 + 1;
+ q__1.r = work[i__5].r * ab[i__6].r - work[i__5].i * ab[i__6]
+ .i, q__1.i = work[i__5].r * ab[i__6].i + work[i__5].i
+ * ab[i__6].r;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ i__2 = (j + *ka - 1) * ab_dim1 + 1;
+ i__5 = j;
+ i__6 = (j + *ka - 1) * ab_dim1 + 1;
+ q__1.r = rwork[i__5] * ab[i__6].r, q__1.i = rwork[i__5] * ab[
+ i__6].i;
+ ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
+/* L570: */
+ }
+
+/* generate rotations in 1st set to annihilate elements which */
+/* have been created outside the band */
+
+ if (nrt > 0) {
+ clargv_(&nrt, &ab[(j1 + *ka) * ab_dim1 + 1], &inca, &work[j1],
+ &ka1, &rwork[j1], &ka1);
+ }
+ if (nr > 0) {
+
+/* apply rotations in 1st set from the left */
+
+ i__1 = *ka - 1;
+ for (l = 1; l <= i__1; ++l) {
+ clartv_(&nr, &ab[ka1 - l + (j1 + l) * ab_dim1], &inca, &
+ ab[*ka - l + (j1 + l) * ab_dim1], &inca, &rwork[
+ j1], &work[j1], &ka1);
+/* L580: */
+ }
+
+/* apply rotations in 1st set from both sides to diagonal */
+/* blocks */
+
+ clar2v_(&nr, &ab[ka1 + j1 * ab_dim1], &ab[ka1 + (j1 - 1) *
+ ab_dim1], &ab[*ka + j1 * ab_dim1], &inca, &rwork[j1],
+ &work[j1], &ka1);
+
+ clacgv_(&nr, &work[j1], &ka1);
+ }
+
+/* start applying rotations in 1st set from the right */
+
+ i__1 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__1; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ clartv_(&nrt, &ab[l + j1t * ab_dim1], &inca, &ab[l + 1 + (
+ j1t - 1) * ab_dim1], &inca, &rwork[j1t], &work[
+ j1t], &ka1);
+ }
+/* L590: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 1st set */
+
+ i__1 = j2;
+ i__4 = ka1;
+ for (j = j1; i__4 < 0 ? j >= i__1 : j <= i__1; j += i__4) {
+ crot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1
+ + 1], &c__1, &rwork[j], &work[j]);
+/* L600: */
+ }
+ }
+/* L610: */
+ }
+
+ if (update) {
+ if (i2 > 0 && kbt > 0) {
+
+/* create nonzero element a(i+kbt-ka-1,i+kbt) outside the */
+/* band and store it in WORK(m-kb+i+kbt) */
+
+ i__3 = m - *kb + i__ + kbt;
+ i__4 = kb1 - kbt + (i__ + kbt) * bb_dim1;
+ q__2.r = -bb[i__4].r, q__2.i = -bb[i__4].i;
+ q__1.r = q__2.r * ra1.r - q__2.i * ra1.i, q__1.i = q__2.r *
+ ra1.i + q__2.i * ra1.r;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ }
+ }
+
+ for (k = *kb; k >= 1; --k) {
+ if (update) {
+/* Computing MAX */
+ i__3 = 2, i__4 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__3,i__4) * ka1;
+ } else {
+/* Computing MAX */
+ i__3 = 1, i__4 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__3,i__4) * ka1;
+ }
+
+/* finish applying rotations in 2nd set from the right */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (j2 + *ka + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ clartv_(&nrt, &ab[l + (j1t + *ka) * ab_dim1], &inca, &ab[
+ l + 1 + (j1t + *ka - 1) * ab_dim1], &inca, &rwork[
+ m - *kb + j1t + *ka], &work[m - *kb + j1t + *ka],
+ &ka1);
+ }
+/* L620: */
+ }
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ i__3 = j2;
+ i__4 = ka1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+ i__1 = m - *kb + j;
+ i__2 = m - *kb + j + *ka;
+ work[i__1].r = work[i__2].r, work[i__1].i = work[i__2].i;
+ rwork[m - *kb + j] = rwork[m - *kb + j + *ka];
+/* L630: */
+ }
+ i__4 = j2;
+ i__3 = ka1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) {
+
+/* create nonzero element a(j-1,j+ka) outside the band */
+/* and store it in WORK(m-kb+j) */
+
+ i__1 = m - *kb + j;
+ i__2 = m - *kb + j;
+ i__5 = (j + *ka - 1) * ab_dim1 + 1;
+ q__1.r = work[i__2].r * ab[i__5].r - work[i__2].i * ab[i__5]
+ .i, q__1.i = work[i__2].r * ab[i__5].i + work[i__2].i
+ * ab[i__5].r;
+ work[i__1].r = q__1.r, work[i__1].i = q__1.i;
+ i__1 = (j + *ka - 1) * ab_dim1 + 1;
+ i__2 = m - *kb + j;
+ i__5 = (j + *ka - 1) * ab_dim1 + 1;
+ q__1.r = rwork[i__2] * ab[i__5].r, q__1.i = rwork[i__2] * ab[
+ i__5].i;
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+/* L640: */
+ }
+ if (update) {
+ if (i__ + k > ka1 && k <= kbt) {
+ i__3 = m - *kb + i__ + k - *ka;
+ i__4 = m - *kb + i__ + k;
+ work[i__3].r = work[i__4].r, work[i__3].i = work[i__4].i;
+ }
+ }
+/* L650: */
+ }
+
+ for (k = *kb; k >= 1; --k) {
+/* Computing MAX */
+ i__3 = 1, i__4 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__3,i__4) * ka1;
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ if (nr > 0) {
+
+/* generate rotations in 2nd set to annihilate elements */
+/* which have been created outside the band */
+
+ clargv_(&nr, &ab[(j1 + *ka) * ab_dim1 + 1], &inca, &work[m - *
+ kb + j1], &ka1, &rwork[m - *kb + j1], &ka1);
+
+/* apply rotations in 2nd set from the left */
+
+ i__3 = *ka - 1;
+ for (l = 1; l <= i__3; ++l) {
+ clartv_(&nr, &ab[ka1 - l + (j1 + l) * ab_dim1], &inca, &
+ ab[*ka - l + (j1 + l) * ab_dim1], &inca, &rwork[m
+ - *kb + j1], &work[m - *kb + j1], &ka1);
+/* L660: */
+ }
+
+/* apply rotations in 2nd set from both sides to diagonal */
+/* blocks */
+
+ clar2v_(&nr, &ab[ka1 + j1 * ab_dim1], &ab[ka1 + (j1 - 1) *
+ ab_dim1], &ab[*ka + j1 * ab_dim1], &inca, &rwork[m - *
+ kb + j1], &work[m - *kb + j1], &ka1);
+
+ clacgv_(&nr, &work[m - *kb + j1], &ka1);
+ }
+
+/* start applying rotations in 2nd set from the right */
+
+ i__3 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__3; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ clartv_(&nrt, &ab[l + j1t * ab_dim1], &inca, &ab[l + 1 + (
+ j1t - 1) * ab_dim1], &inca, &rwork[m - *kb + j1t],
+ &work[m - *kb + j1t], &ka1);
+ }
+/* L670: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 2nd set */
+
+ i__3 = j2;
+ i__4 = ka1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+ crot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1
+ + 1], &c__1, &rwork[m - *kb + j], &work[m - *kb +
+ j]);
+/* L680: */
+ }
+ }
+/* L690: */
+ }
+
+ i__4 = *kb - 1;
+ for (k = 1; k <= i__4; ++k) {
+/* Computing MAX */
+ i__3 = 1, i__1 = k + i0 - m + 1;
+ j2 = i__ + k + 1 - max(i__3,i__1) * ka1;
+
+/* finish applying rotations in 1st set from the right */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ clartv_(&nrt, &ab[l + j1t * ab_dim1], &inca, &ab[l + 1 + (
+ j1t - 1) * ab_dim1], &inca, &rwork[j1t], &work[
+ j1t], &ka1);
+ }
+/* L700: */
+ }
+/* L710: */
+ }
+
+ if (*kb > 1) {
+ i__4 = i2 - *ka;
+ for (j = 2; j <= i__4; ++j) {
+ rwork[j] = rwork[j + *ka];
+ i__3 = j;
+ i__1 = j + *ka;
+ work[i__3].r = work[i__1].r, work[i__3].i = work[i__1].i;
+/* L720: */
+ }
+ }
+
+ } else {
+
+/* Transform A, working with the lower triangle */
+
+ if (update) {
+
+/* Form inv(S(i))**H * A * inv(S(i)) */
+
+ i__4 = i__ * bb_dim1 + 1;
+ bii = bb[i__4].r;
+ i__4 = i__ * ab_dim1 + 1;
+ i__3 = i__ * ab_dim1 + 1;
+ r__1 = ab[i__3].r / bii / bii;
+ ab[i__4].r = r__1, ab[i__4].i = 0.f;
+ i__4 = i__ - 1;
+ for (j = i1; j <= i__4; ++j) {
+ i__3 = i__ - j + 1 + j * ab_dim1;
+ i__1 = i__ - j + 1 + j * ab_dim1;
+ q__1.r = ab[i__1].r / bii, q__1.i = ab[i__1].i / bii;
+ ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
+/* L730: */
+ }
+/* Computing MIN */
+ i__3 = *n, i__1 = i__ + *ka;
+ i__4 = min(i__3,i__1);
+ for (j = i__ + 1; j <= i__4; ++j) {
+ i__3 = j - i__ + 1 + i__ * ab_dim1;
+ i__1 = j - i__ + 1 + i__ * ab_dim1;
+ q__1.r = ab[i__1].r / bii, q__1.i = ab[i__1].i / bii;
+ ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
+/* L740: */
+ }
+ i__4 = i__ + kbt;
+ for (k = i__ + 1; k <= i__4; ++k) {
+ i__3 = i__ + kbt;
+ for (j = k; j <= i__3; ++j) {
+ i__1 = j - k + 1 + k * ab_dim1;
+ i__2 = j - k + 1 + k * ab_dim1;
+ i__5 = j - i__ + 1 + i__ * bb_dim1;
+ r_cnjg(&q__5, &ab[k - i__ + 1 + i__ * ab_dim1]);
+ q__4.r = bb[i__5].r * q__5.r - bb[i__5].i * q__5.i,
+ q__4.i = bb[i__5].r * q__5.i + bb[i__5].i *
+ q__5.r;
+ q__3.r = ab[i__2].r - q__4.r, q__3.i = ab[i__2].i -
+ q__4.i;
+ r_cnjg(&q__7, &bb[k - i__ + 1 + i__ * bb_dim1]);
+ i__6 = j - i__ + 1 + i__ * ab_dim1;
+ q__6.r = q__7.r * ab[i__6].r - q__7.i * ab[i__6].i,
+ q__6.i = q__7.r * ab[i__6].i + q__7.i * ab[i__6]
+ .r;
+ q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i;
+ i__7 = i__ * ab_dim1 + 1;
+ r__1 = ab[i__7].r;
+ i__8 = j - i__ + 1 + i__ * bb_dim1;
+ q__9.r = r__1 * bb[i__8].r, q__9.i = r__1 * bb[i__8].i;
+ r_cnjg(&q__10, &bb[k - i__ + 1 + i__ * bb_dim1]);
+ q__8.r = q__9.r * q__10.r - q__9.i * q__10.i, q__8.i =
+ q__9.r * q__10.i + q__9.i * q__10.r;
+ q__1.r = q__2.r + q__8.r, q__1.i = q__2.i + q__8.i;
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+/* L750: */
+ }
+/* Computing MIN */
+ i__1 = *n, i__2 = i__ + *ka;
+ i__3 = min(i__1,i__2);
+ for (j = i__ + kbt + 1; j <= i__3; ++j) {
+ i__1 = j - k + 1 + k * ab_dim1;
+ i__2 = j - k + 1 + k * ab_dim1;
+ r_cnjg(&q__3, &bb[k - i__ + 1 + i__ * bb_dim1]);
+ i__5 = j - i__ + 1 + i__ * ab_dim1;
+ q__2.r = q__3.r * ab[i__5].r - q__3.i * ab[i__5].i,
+ q__2.i = q__3.r * ab[i__5].i + q__3.i * ab[i__5]
+ .r;
+ q__1.r = ab[i__2].r - q__2.r, q__1.i = ab[i__2].i -
+ q__2.i;
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+/* L760: */
+ }
+/* L770: */
+ }
+ i__4 = i__;
+ for (j = i1; j <= i__4; ++j) {
+/* Computing MIN */
+ i__1 = j + *ka, i__2 = i__ + kbt;
+ i__3 = min(i__1,i__2);
+ for (k = i__ + 1; k <= i__3; ++k) {
+ i__1 = k - j + 1 + j * ab_dim1;
+ i__2 = k - j + 1 + j * ab_dim1;
+ i__5 = k - i__ + 1 + i__ * bb_dim1;
+ i__6 = i__ - j + 1 + j * ab_dim1;
+ q__2.r = bb[i__5].r * ab[i__6].r - bb[i__5].i * ab[i__6]
+ .i, q__2.i = bb[i__5].r * ab[i__6].i + bb[i__5].i
+ * ab[i__6].r;
+ q__1.r = ab[i__2].r - q__2.r, q__1.i = ab[i__2].i -
+ q__2.i;
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+/* L780: */
+ }
+/* L790: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by inv(S(i)) */
+
+ r__1 = 1.f / bii;
+ csscal_(&nx, &r__1, &x[i__ * x_dim1 + 1], &c__1);
+ if (kbt > 0) {
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgerc_(&nx, &kbt, &q__1, &x[i__ * x_dim1 + 1], &c__1, &bb[
+ i__ * bb_dim1 + 2], &c__1, &x[(i__ + 1) * x_dim1
+ + 1], ldx);
+ }
+ }
+
+/* store a(i,i1) in RA1 for use in next loop over K */
+
+ i__4 = i__ - i1 + 1 + i1 * ab_dim1;
+ ra1.r = ab[i__4].r, ra1.i = ab[i__4].i;
+ }
+
+/* Generate and apply vectors of rotations to chase all the */
+/* existing bulges KA positions up toward the top of the band */
+
+ i__4 = *kb - 1;
+ for (k = 1; k <= i__4; ++k) {
+ if (update) {
+
+/* Determine the rotations which would annihilate the bulge */
+/* which has in theory just been created */
+
+ if (i__ + k - ka1 > 0 && i__ + k < m) {
+
+/* generate rotation to annihilate a(i,i+k-ka-1) */
+
+ clartg_(&ab[ka1 - k + (i__ + k - *ka) * ab_dim1], &ra1, &
+ rwork[i__ + k - *ka], &work[i__ + k - *ka], &ra);
+
+/* create nonzero element a(i+k,i+k-ka-1) outside the */
+/* band and store it in WORK(m-kb+i+k) */
+
+ i__3 = k + 1 + i__ * bb_dim1;
+ q__2.r = -bb[i__3].r, q__2.i = -bb[i__3].i;
+ q__1.r = q__2.r * ra1.r - q__2.i * ra1.i, q__1.i = q__2.r
+ * ra1.i + q__2.i * ra1.r;
+ t.r = q__1.r, t.i = q__1.i;
+ i__3 = m - *kb + i__ + k;
+ i__1 = i__ + k - *ka;
+ q__2.r = rwork[i__1] * t.r, q__2.i = rwork[i__1] * t.i;
+ r_cnjg(&q__4, &work[i__ + k - *ka]);
+ i__2 = ka1 + (i__ + k - *ka) * ab_dim1;
+ q__3.r = q__4.r * ab[i__2].r - q__4.i * ab[i__2].i,
+ q__3.i = q__4.r * ab[i__2].i + q__4.i * ab[i__2]
+ .r;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ i__3 = ka1 + (i__ + k - *ka) * ab_dim1;
+ i__1 = i__ + k - *ka;
+ q__2.r = work[i__1].r * t.r - work[i__1].i * t.i, q__2.i =
+ work[i__1].r * t.i + work[i__1].i * t.r;
+ i__2 = i__ + k - *ka;
+ i__5 = ka1 + (i__ + k - *ka) * ab_dim1;
+ q__3.r = rwork[i__2] * ab[i__5].r, q__3.i = rwork[i__2] *
+ ab[i__5].i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
+ ra1.r = ra.r, ra1.i = ra.i;
+ }
+ }
+/* Computing MAX */
+ i__3 = 1, i__1 = k + i0 - m + 1;
+ j2 = i__ + k + 1 - max(i__3,i__1) * ka1;
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ if (update) {
+/* Computing MIN */
+ i__3 = j2, i__1 = i__ - (*ka << 1) + k - 1;
+ j2t = min(i__3,i__1);
+ } else {
+ j2t = j2;
+ }
+ nrt = (j2t + *ka - 1) / ka1;
+ i__3 = j2t;
+ i__1 = ka1;
+ for (j = j1; i__1 < 0 ? j >= i__3 : j <= i__3; j += i__1) {
+
+/* create nonzero element a(j+ka,j-1) outside the band */
+/* and store it in WORK(j) */
+
+ i__2 = j;
+ i__5 = j;
+ i__6 = ka1 + (j - 1) * ab_dim1;
+ q__1.r = work[i__5].r * ab[i__6].r - work[i__5].i * ab[i__6]
+ .i, q__1.i = work[i__5].r * ab[i__6].i + work[i__5].i
+ * ab[i__6].r;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ i__2 = ka1 + (j - 1) * ab_dim1;
+ i__5 = j;
+ i__6 = ka1 + (j - 1) * ab_dim1;
+ q__1.r = rwork[i__5] * ab[i__6].r, q__1.i = rwork[i__5] * ab[
+ i__6].i;
+ ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
+/* L800: */
+ }
+
+/* generate rotations in 1st set to annihilate elements which */
+/* have been created outside the band */
+
+ if (nrt > 0) {
+ clargv_(&nrt, &ab[ka1 + j1 * ab_dim1], &inca, &work[j1], &ka1,
+ &rwork[j1], &ka1);
+ }
+ if (nr > 0) {
+
+/* apply rotations in 1st set from the right */
+
+ i__1 = *ka - 1;
+ for (l = 1; l <= i__1; ++l) {
+ clartv_(&nr, &ab[l + 1 + j1 * ab_dim1], &inca, &ab[l + 2
+ + (j1 - 1) * ab_dim1], &inca, &rwork[j1], &work[
+ j1], &ka1);
+/* L810: */
+ }
+
+/* apply rotations in 1st set from both sides to diagonal */
+/* blocks */
+
+ clar2v_(&nr, &ab[j1 * ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 +
+ 1], &ab[(j1 - 1) * ab_dim1 + 2], &inca, &rwork[j1], &
+ work[j1], &ka1);
+
+ clacgv_(&nr, &work[j1], &ka1);
+ }
+
+/* start applying rotations in 1st set from the left */
+
+ i__1 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__1; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ clartv_(&nrt, &ab[ka1 - l + 1 + (j1t - ka1 + l) * ab_dim1]
+, &inca, &ab[ka1 - l + (j1t - ka1 + l) * ab_dim1],
+ &inca, &rwork[j1t], &work[j1t], &ka1);
+ }
+/* L820: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 1st set */
+
+ i__1 = j2;
+ i__3 = ka1;
+ for (j = j1; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) {
+ r_cnjg(&q__1, &work[j]);
+ crot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1
+ + 1], &c__1, &rwork[j], &q__1);
+/* L830: */
+ }
+ }
+/* L840: */
+ }
+
+ if (update) {
+ if (i2 > 0 && kbt > 0) {
+
+/* create nonzero element a(i+kbt,i+kbt-ka-1) outside the */
+/* band and store it in WORK(m-kb+i+kbt) */
+
+ i__4 = m - *kb + i__ + kbt;
+ i__3 = kbt + 1 + i__ * bb_dim1;
+ q__2.r = -bb[i__3].r, q__2.i = -bb[i__3].i;
+ q__1.r = q__2.r * ra1.r - q__2.i * ra1.i, q__1.i = q__2.r *
+ ra1.i + q__2.i * ra1.r;
+ work[i__4].r = q__1.r, work[i__4].i = q__1.i;
+ }
+ }
+
+ for (k = *kb; k >= 1; --k) {
+ if (update) {
+/* Computing MAX */
+ i__4 = 2, i__3 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__4,i__3) * ka1;
+ } else {
+/* Computing MAX */
+ i__4 = 1, i__3 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__4,i__3) * ka1;
+ }
+
+/* finish applying rotations in 2nd set from the left */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (j2 + *ka + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ clartv_(&nrt, &ab[ka1 - l + 1 + (j1t + l - 1) * ab_dim1],
+ &inca, &ab[ka1 - l + (j1t + l - 1) * ab_dim1], &
+ inca, &rwork[m - *kb + j1t + *ka], &work[m - *kb
+ + j1t + *ka], &ka1);
+ }
+/* L850: */
+ }
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ i__4 = j2;
+ i__3 = ka1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) {
+ i__1 = m - *kb + j;
+ i__2 = m - *kb + j + *ka;
+ work[i__1].r = work[i__2].r, work[i__1].i = work[i__2].i;
+ rwork[m - *kb + j] = rwork[m - *kb + j + *ka];
+/* L860: */
+ }
+ i__3 = j2;
+ i__4 = ka1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+
+/* create nonzero element a(j+ka,j-1) outside the band */
+/* and store it in WORK(m-kb+j) */
+
+ i__1 = m - *kb + j;
+ i__2 = m - *kb + j;
+ i__5 = ka1 + (j - 1) * ab_dim1;
+ q__1.r = work[i__2].r * ab[i__5].r - work[i__2].i * ab[i__5]
+ .i, q__1.i = work[i__2].r * ab[i__5].i + work[i__2].i
+ * ab[i__5].r;
+ work[i__1].r = q__1.r, work[i__1].i = q__1.i;
+ i__1 = ka1 + (j - 1) * ab_dim1;
+ i__2 = m - *kb + j;
+ i__5 = ka1 + (j - 1) * ab_dim1;
+ q__1.r = rwork[i__2] * ab[i__5].r, q__1.i = rwork[i__2] * ab[
+ i__5].i;
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+/* L870: */
+ }
+ if (update) {
+ if (i__ + k > ka1 && k <= kbt) {
+ i__4 = m - *kb + i__ + k - *ka;
+ i__3 = m - *kb + i__ + k;
+ work[i__4].r = work[i__3].r, work[i__4].i = work[i__3].i;
+ }
+ }
+/* L880: */
+ }
+
+ for (k = *kb; k >= 1; --k) {
+/* Computing MAX */
+ i__4 = 1, i__3 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__4,i__3) * ka1;
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ if (nr > 0) {
+
+/* generate rotations in 2nd set to annihilate elements */
+/* which have been created outside the band */
+
+ clargv_(&nr, &ab[ka1 + j1 * ab_dim1], &inca, &work[m - *kb +
+ j1], &ka1, &rwork[m - *kb + j1], &ka1);
+
+/* apply rotations in 2nd set from the right */
+
+ i__4 = *ka - 1;
+ for (l = 1; l <= i__4; ++l) {
+ clartv_(&nr, &ab[l + 1 + j1 * ab_dim1], &inca, &ab[l + 2
+ + (j1 - 1) * ab_dim1], &inca, &rwork[m - *kb + j1]
+, &work[m - *kb + j1], &ka1);
+/* L890: */
+ }
+
+/* apply rotations in 2nd set from both sides to diagonal */
+/* blocks */
+
+ clar2v_(&nr, &ab[j1 * ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 +
+ 1], &ab[(j1 - 1) * ab_dim1 + 2], &inca, &rwork[m - *
+ kb + j1], &work[m - *kb + j1], &ka1);
+
+ clacgv_(&nr, &work[m - *kb + j1], &ka1);
+ }
+
+/* start applying rotations in 2nd set from the left */
+
+ i__4 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__4; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ clartv_(&nrt, &ab[ka1 - l + 1 + (j1t - ka1 + l) * ab_dim1]
+, &inca, &ab[ka1 - l + (j1t - ka1 + l) * ab_dim1],
+ &inca, &rwork[m - *kb + j1t], &work[m - *kb +
+ j1t], &ka1);
+ }
+/* L900: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 2nd set */
+
+ i__4 = j2;
+ i__3 = ka1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) {
+ r_cnjg(&q__1, &work[m - *kb + j]);
+ crot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1
+ + 1], &c__1, &rwork[m - *kb + j], &q__1);
+/* L910: */
+ }
+ }
+/* L920: */
+ }
+
+ i__3 = *kb - 1;
+ for (k = 1; k <= i__3; ++k) {
+/* Computing MAX */
+ i__4 = 1, i__1 = k + i0 - m + 1;
+ j2 = i__ + k + 1 - max(i__4,i__1) * ka1;
+
+/* finish applying rotations in 1st set from the left */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ clartv_(&nrt, &ab[ka1 - l + 1 + (j1t - ka1 + l) * ab_dim1]
+, &inca, &ab[ka1 - l + (j1t - ka1 + l) * ab_dim1],
+ &inca, &rwork[j1t], &work[j1t], &ka1);
+ }
+/* L930: */
+ }
+/* L940: */
+ }
+
+ if (*kb > 1) {
+ i__3 = i2 - *ka;
+ for (j = 2; j <= i__3; ++j) {
+ rwork[j] = rwork[j + *ka];
+ i__4 = j;
+ i__1 = j + *ka;
+ work[i__4].r = work[i__1].r, work[i__4].i = work[i__1].i;
+/* L950: */
+ }
+ }
+
+ }
+
+ goto L490;
+
+/* End of CHBGST */
+
+} /* chbgst_ */
diff --git a/SRC/chbgv.c b/SRC/chbgv.c
new file mode 100644
index 0000000..b4e70a4
--- /dev/null
+++ b/SRC/chbgv.c
@@ -0,0 +1,235 @@
+/* chbgv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int chbgv_(char *jobz, char *uplo, integer *n, integer *ka,
+ integer *kb, complex *ab, integer *ldab, complex *bb, integer *ldbb,
+ real *w, complex *z__, integer *ldz, complex *work, real *rwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, bb_dim1, bb_offset, z_dim1, z_offset, i__1;
+
+ /* Local variables */
+ integer inde;
+ char vect[1];
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical upper, wantz;
+ extern /* Subroutine */ int chbtrd_(char *, char *, integer *, integer *,
+ complex *, integer *, real *, real *, complex *, integer *,
+ complex *, integer *), chbgst_(char *, char *,
+ integer *, integer *, integer *, complex *, integer *, complex *,
+ integer *, complex *, integer *, complex *, real *, integer *), xerbla_(char *, integer *), cpbstf_(char
+ *, integer *, integer *, complex *, integer *, integer *);
+ integer indwrk;
+ extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *,
+ complex *, integer *, real *, integer *), ssterf_(integer
+ *, real *, real *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHBGV computes all the eigenvalues, and optionally, the eigenvectors */
+/* of a complex generalized Hermitian-definite banded eigenproblem, of */
+/* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian */
+/* and banded, and B is also positive definite. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* KA (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */
+
+/* KB (input) INTEGER */
+/* The number of superdiagonals of the matrix B if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KB >= 0. */
+
+/* AB (input/output) COMPLEX array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first ka+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */
+
+/* On exit, the contents of AB are destroyed. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KA+1. */
+
+/* BB (input/output) COMPLEX array, dimension (LDBB, N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix B, stored in the first kb+1 rows of the array. The */
+/* j-th column of B is stored in the j-th column of the array BB */
+/* as follows: */
+/* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; */
+/* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). */
+
+/* On exit, the factor S from the split Cholesky factorization */
+/* B = S**H*S, as returned by CPBSTF. */
+
+/* LDBB (input) INTEGER */
+/* The leading dimension of the array BB. LDBB >= KB+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
+/* eigenvectors, with the i-th column of Z holding the */
+/* eigenvector associated with W(i). The eigenvectors are */
+/* normalized so that Z**H*B*Z = I. */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= N. */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* RWORK (workspace) REAL array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is: */
+/* <= N: the algorithm failed to converge: */
+/* i off-diagonal elements of an intermediate */
+/* tridiagonal form did not converge to zero; */
+/* > N: if INFO = N + i, for 1 <= i <= N, then CPBSTF */
+/* returned INFO = i: B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ bb_dim1 = *ldbb;
+ bb_offset = 1 + bb_dim1;
+ bb -= bb_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ka < 0) {
+ *info = -4;
+ } else if (*kb < 0 || *kb > *ka) {
+ *info = -5;
+ } else if (*ldab < *ka + 1) {
+ *info = -7;
+ } else if (*ldbb < *kb + 1) {
+ *info = -9;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHBGV ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a split Cholesky factorization of B. */
+
+ cpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem. */
+
+ inde = 1;
+ indwrk = inde + *n;
+ chbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb,
+ &z__[z_offset], ldz, &work[1], &rwork[indwrk], &iinfo);
+
+/* Reduce to tridiagonal form. */
+
+ if (wantz) {
+ *(unsigned char *)vect = 'U';
+ } else {
+ *(unsigned char *)vect = 'N';
+ }
+ chbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &w[1], &rwork[inde], &
+ z__[z_offset], ldz, &work[1], &iinfo);
+
+/* For eigenvalues only, call SSTERF. For eigenvectors, call CSTEQR. */
+
+ if (! wantz) {
+ ssterf_(n, &w[1], &rwork[inde], info);
+ } else {
+ csteqr_(jobz, n, &w[1], &rwork[inde], &z__[z_offset], ldz, &rwork[
+ indwrk], info);
+ }
+ return 0;
+
+/* End of CHBGV */
+
+} /* chbgv_ */
diff --git a/SRC/chbgvd.c b/SRC/chbgvd.c
new file mode 100644
index 0000000..780f128
--- /dev/null
+++ b/SRC/chbgvd.c
@@ -0,0 +1,355 @@
+/* chbgvd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static complex c_b2 = {0.f,0.f};
+
+/* Subroutine */ int chbgvd_(char *jobz, char *uplo, integer *n, integer *ka,
+ integer *kb, complex *ab, integer *ldab, complex *bb, integer *ldbb,
+ real *w, complex *z__, integer *ldz, complex *work, integer *lwork,
+ real *rwork, integer *lrwork, integer *iwork, integer *liwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, bb_dim1, bb_offset, z_dim1, z_offset, i__1;
+
+ /* Local variables */
+ integer inde;
+ char vect[1];
+ integer llwk2;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ integer iinfo, lwmin;
+ logical upper;
+ integer llrwk;
+ logical wantz;
+ integer indwk2;
+ extern /* Subroutine */ int cstedc_(char *, integer *, real *, real *,
+ complex *, integer *, complex *, integer *, real *, integer *,
+ integer *, integer *, integer *), chbtrd_(char *, char *,
+ integer *, integer *, complex *, integer *, real *, real *,
+ complex *, integer *, complex *, integer *),
+ chbgst_(char *, char *, integer *, integer *, integer *, complex *
+, integer *, complex *, integer *, complex *, integer *, complex *
+, real *, integer *), clacpy_(char *, integer *,
+ integer *, complex *, integer *, complex *, integer *),
+ xerbla_(char *, integer *), cpbstf_(char *, integer *,
+ integer *, complex *, integer *, integer *);
+ integer indwrk, liwmin;
+ extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
+ integer lrwmin;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHBGVD computes all the eigenvalues, and optionally, the eigenvectors */
+/* of a complex generalized Hermitian-definite banded eigenproblem, of */
+/* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian */
+/* and banded, and B is also positive definite. If eigenvectors are */
+/* desired, it uses a divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* KA (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */
+
+/* KB (input) INTEGER */
+/* The number of superdiagonals of the matrix B if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KB >= 0. */
+
+/* AB (input/output) COMPLEX array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first ka+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */
+
+/* On exit, the contents of AB are destroyed. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KA+1. */
+
+/* BB (input/output) COMPLEX array, dimension (LDBB, N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix B, stored in the first kb+1 rows of the array. The */
+/* j-th column of B is stored in the j-th column of the array BB */
+/* as follows: */
+/* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; */
+/* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). */
+
+/* On exit, the factor S from the split Cholesky factorization */
+/* B = S**H*S, as returned by CPBSTF. */
+
+/* LDBB (input) INTEGER */
+/* The leading dimension of the array BB. LDBB >= KB+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
+/* eigenvectors, with the i-th column of Z holding the */
+/* eigenvector associated with W(i). The eigenvectors are */
+/* normalized so that Z**H*B*Z = I. */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= N. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO=0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If N <= 1, LWORK >= 1. */
+/* If JOBZ = 'N' and N > 1, LWORK >= N. */
+/* If JOBZ = 'V' and N > 1, LWORK >= 2*N**2. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK, RWORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK)) */
+/* On exit, if INFO=0, RWORK(1) returns the optimal LRWORK. */
+
+/* LRWORK (input) INTEGER */
+/* The dimension of array RWORK. */
+/* If N <= 1, LRWORK >= 1. */
+/* If JOBZ = 'N' and N > 1, LRWORK >= N. */
+/* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2. */
+
+/* If LRWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO=0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of array IWORK. */
+/* If JOBZ = 'N' or N <= 1, LIWORK >= 1. */
+/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is: */
+/* <= N: the algorithm failed to converge: */
+/* i off-diagonal elements of an intermediate */
+/* tridiagonal form did not converge to zero; */
+/* > N: if INFO = N + i, for 1 <= i <= N, then CPBSTF */
+/* returned INFO = i: B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ bb_dim1 = *ldbb;
+ bb_offset = 1 + bb_dim1;
+ bb -= bb_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
+
+ *info = 0;
+ if (*n <= 1) {
+ lwmin = 1;
+ lrwmin = 1;
+ liwmin = 1;
+ } else if (wantz) {
+/* Computing 2nd power */
+ i__1 = *n;
+ lwmin = i__1 * i__1 << 1;
+/* Computing 2nd power */
+ i__1 = *n;
+ lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
+ liwmin = *n * 5 + 3;
+ } else {
+ lwmin = *n;
+ lrwmin = *n;
+ liwmin = 1;
+ }
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ka < 0) {
+ *info = -4;
+ } else if (*kb < 0 || *kb > *ka) {
+ *info = -5;
+ } else if (*ldab < *ka + 1) {
+ *info = -7;
+ } else if (*ldbb < *kb + 1) {
+ *info = -9;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -12;
+ }
+
+ if (*info == 0) {
+ work[1].r = (real) lwmin, work[1].i = 0.f;
+ rwork[1] = (real) lrwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -14;
+ } else if (*lrwork < lrwmin && ! lquery) {
+ *info = -16;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -18;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHBGVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a split Cholesky factorization of B. */
+
+ cpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem. */
+
+ inde = 1;
+ indwrk = inde + *n;
+ indwk2 = *n * *n + 1;
+ llwk2 = *lwork - indwk2 + 2;
+ llrwk = *lrwork - indwrk + 2;
+ chbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb,
+ &z__[z_offset], ldz, &work[1], &rwork[indwrk], &iinfo);
+
+/* Reduce Hermitian band matrix to tridiagonal form. */
+
+ if (wantz) {
+ *(unsigned char *)vect = 'U';
+ } else {
+ *(unsigned char *)vect = 'N';
+ }
+ chbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &w[1], &rwork[inde], &
+ z__[z_offset], ldz, &work[1], &iinfo);
+
+/* For eigenvalues only, call SSTERF. For eigenvectors, call CSTEDC. */
+
+ if (! wantz) {
+ ssterf_(n, &w[1], &rwork[inde], info);
+ } else {
+ cstedc_("I", n, &w[1], &rwork[inde], &work[1], n, &work[indwk2], &
+ llwk2, &rwork[indwrk], &llrwk, &iwork[1], liwork, info);
+ cgemm_("N", "N", n, n, n, &c_b1, &z__[z_offset], ldz, &work[1], n, &
+ c_b2, &work[indwk2], n);
+ clacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz);
+ }
+
+ work[1].r = (real) lwmin, work[1].i = 0.f;
+ rwork[1] = (real) lrwmin;
+ iwork[1] = liwmin;
+ return 0;
+
+/* End of CHBGVD */
+
+} /* chbgvd_ */
diff --git a/SRC/chbgvx.c b/SRC/chbgvx.c
new file mode 100644
index 0000000..295bc86
--- /dev/null
+++ b/SRC/chbgvx.c
@@ -0,0 +1,472 @@
+/* chbgvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int chbgvx_(char *jobz, char *range, char *uplo, integer *n,
+ integer *ka, integer *kb, complex *ab, integer *ldab, complex *bb,
+ integer *ldbb, complex *q, integer *ldq, real *vl, real *vu, integer *
+ il, integer *iu, real *abstol, integer *m, real *w, complex *z__,
+ integer *ldz, complex *work, real *rwork, integer *iwork, integer *
+ ifail, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, bb_dim1, bb_offset, q_dim1, q_offset, z_dim1,
+ z_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, jj;
+ real tmp1;
+ integer indd, inde;
+ char vect[1];
+ logical test;
+ integer itmp1, indee;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *);
+ integer iinfo;
+ char order[1];
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ logical wantz, alleig, indeig;
+ integer indibl;
+ extern /* Subroutine */ int chbtrd_(char *, char *, integer *, integer *,
+ complex *, integer *, real *, real *, complex *, integer *,
+ complex *, integer *);
+ logical valeig;
+ extern /* Subroutine */ int chbgst_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, complex *, real *, integer *), clacpy_(
+ char *, integer *, integer *, complex *, integer *, complex *,
+ integer *), xerbla_(char *, integer *), cpbstf_(
+ char *, integer *, integer *, complex *, integer *, integer *);
+ integer indiwk, indisp;
+ extern /* Subroutine */ int cstein_(integer *, real *, real *, integer *,
+ real *, integer *, integer *, complex *, integer *, real *,
+ integer *, integer *, integer *);
+ integer indrwk, indwrk;
+ extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *,
+ complex *, integer *, real *, integer *), ssterf_(integer
+ *, real *, real *, integer *);
+ integer nsplit;
+ extern /* Subroutine */ int sstebz_(char *, char *, integer *, real *,
+ real *, integer *, integer *, real *, real *, real *, integer *,
+ integer *, real *, integer *, integer *, real *, integer *,
+ integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHBGVX computes all the eigenvalues, and optionally, the eigenvectors */
+/* of a complex generalized Hermitian-definite banded eigenproblem, of */
+/* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian */
+/* and banded, and B is also positive definite. Eigenvalues and */
+/* eigenvectors can be selected by specifying either all eigenvalues, */
+/* a range of values or a range of indices for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found; */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found; */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* KA (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */
+
+/* KB (input) INTEGER */
+/* The number of superdiagonals of the matrix B if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KB >= 0. */
+
+/* AB (input/output) COMPLEX array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first ka+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */
+
+/* On exit, the contents of AB are destroyed. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KA+1. */
+
+/* BB (input/output) COMPLEX array, dimension (LDBB, N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix B, stored in the first kb+1 rows of the array. The */
+/* j-th column of B is stored in the j-th column of the array BB */
+/* as follows: */
+/* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; */
+/* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). */
+
+/* On exit, the factor S from the split Cholesky factorization */
+/* B = S**H*S, as returned by CPBSTF. */
+
+/* LDBB (input) INTEGER */
+/* The leading dimension of the array BB. LDBB >= KB+1. */
+
+/* Q (output) COMPLEX array, dimension (LDQ, N) */
+/* If JOBZ = 'V', the n-by-n matrix used in the reduction of */
+/* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x, */
+/* and consequently C to tridiagonal form. */
+/* If JOBZ = 'N', the array Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. If JOBZ = 'N', */
+/* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N). */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) REAL */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing AP to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*SLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*SLAMCH('S'). */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
+/* eigenvectors, with the i-th column of Z holding the */
+/* eigenvector associated with W(i). The eigenvectors are */
+/* normalized so that Z**H*B*Z = I. */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= N. */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* RWORK (workspace) REAL array, dimension (7*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is: */
+/* <= N: then i eigenvectors failed to converge. Their */
+/* indices are stored in array IFAIL. */
+/* > N: if INFO = N + i, for 1 <= i <= N, then CPBSTF */
+/* returned INFO = i: B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ bb_dim1 = *ldbb;
+ bb_offset = 1 + bb_dim1;
+ bb -= bb_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ka < 0) {
+ *info = -5;
+ } else if (*kb < 0 || *kb > *ka) {
+ *info = -6;
+ } else if (*ldab < *ka + 1) {
+ *info = -8;
+ } else if (*ldbb < *kb + 1) {
+ *info = -10;
+ } else if (*ldq < 1 || wantz && *ldq < *n) {
+ *info = -12;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -14;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -15;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -16;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -21;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHBGVX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a split Cholesky factorization of B. */
+
+ cpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem. */
+
+ chbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb,
+ &q[q_offset], ldq, &work[1], &rwork[1], &iinfo);
+
+/* Solve the standard eigenvalue problem. */
+/* Reduce Hermitian band matrix to tridiagonal form. */
+
+ indd = 1;
+ inde = indd + *n;
+ indrwk = inde + *n;
+ indwrk = 1;
+ if (wantz) {
+ *(unsigned char *)vect = 'U';
+ } else {
+ *(unsigned char *)vect = 'N';
+ }
+ chbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &rwork[indd], &rwork[
+ inde], &q[q_offset], ldq, &work[indwrk], &iinfo);
+
+/* If all eigenvalues are desired and ABSTOL is less than or equal */
+/* to zero, then call SSTERF or CSTEQR. If this fails for some */
+/* eigenvalue, then try SSTEBZ. */
+
+ test = FALSE_;
+ if (indeig) {
+ if (*il == 1 && *iu == *n) {
+ test = TRUE_;
+ }
+ }
+ if ((alleig || test) && *abstol <= 0.f) {
+ scopy_(n, &rwork[indd], &c__1, &w[1], &c__1);
+ indee = indrwk + (*n << 1);
+ i__1 = *n - 1;
+ scopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
+ if (! wantz) {
+ ssterf_(n, &w[1], &rwork[indee], info);
+ } else {
+ clacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz);
+ csteqr_(jobz, n, &w[1], &rwork[indee], &z__[z_offset], ldz, &
+ rwork[indrwk], info);
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ifail[i__] = 0;
+/* L10: */
+ }
+ }
+ }
+ if (*info == 0) {
+ *m = *n;
+ goto L30;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call SSTEBZ and, if eigenvectors are desired, */
+/* call CSTEIN. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ indibl = 1;
+ indisp = indibl + *n;
+ indiwk = indisp + *n;
+ sstebz_(range, order, n, vl, vu, il, iu, abstol, &rwork[indd], &rwork[
+ inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &rwork[
+ indrwk], &iwork[indiwk], info);
+
+ if (wantz) {
+ cstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], &
+ iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[
+ indiwk], &ifail[1], info);
+
+/* Apply unitary matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by CSTEIN. */
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1);
+ cgemv_("N", n, n, &c_b2, &q[q_offset], ldq, &work[1], &c__1, &
+ c_b1, &z__[j * z_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+
+L30:
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L40: */
+ }
+
+ if (i__ != 0) {
+ itmp1 = iwork[indibl + i__ - 1];
+ w[i__] = w[j];
+ iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
+ w[j] = tmp1;
+ iwork[indibl + j - 1] = itmp1;
+ cswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ if (*info != 0) {
+ itmp1 = ifail[i__];
+ ifail[i__] = ifail[j];
+ ifail[j] = itmp1;
+ }
+ }
+/* L50: */
+ }
+ }
+
+ return 0;
+
+/* End of CHBGVX */
+
+} /* chbgvx_ */
diff --git a/SRC/chbtrd.c b/SRC/chbtrd.c
new file mode 100644
index 0000000..a62bd64
--- /dev/null
+++ b/SRC/chbtrd.c
@@ -0,0 +1,808 @@
+/* chbtrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int chbtrd_(char *vect, char *uplo, integer *n, integer *kd,
+ complex *ab, integer *ldab, real *d__, real *e, complex *q, integer *
+ ldq, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, q_dim1, q_offset, i__1, i__2, i__3, i__4,
+ i__5, i__6;
+ real r__1;
+ complex q__1;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+ double c_abs(complex *);
+
+ /* Local variables */
+ integer i__, j, k, l;
+ complex t;
+ integer i2, j1, j2, nq, nr, kd1, ibl, iqb, kdn, jin, nrt, kdm1, inca,
+ jend, lend, jinc;
+ real abst;
+ integer incx, last;
+ complex temp;
+ extern /* Subroutine */ int crot_(integer *, complex *, integer *,
+ complex *, integer *, real *, complex *);
+ integer j1end, j1inc;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *);
+ integer iqend;
+ extern logical lsame_(char *, char *);
+ logical initq, wantq, upper;
+ extern /* Subroutine */ int clar2v_(integer *, complex *, complex *,
+ complex *, integer *, real *, complex *, integer *), clacgv_(
+ integer *, complex *, integer *);
+ integer iqaend;
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), clartg_(complex *,
+ complex *, real *, complex *, complex *), xerbla_(char *, integer
+ *), clargv_(integer *, complex *, integer *, complex *,
+ integer *, real *, integer *), clartv_(integer *, complex *,
+ integer *, complex *, integer *, real *, complex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHBTRD reduces a complex Hermitian band matrix A to real symmetric */
+/* tridiagonal form T by a unitary similarity transformation: */
+/* Q**H * A * Q = T. */
+
+/* Arguments */
+/* ========= */
+
+/* VECT (input) CHARACTER*1 */
+/* = 'N': do not form Q; */
+/* = 'V': form Q; */
+/* = 'U': update a matrix X, by forming X*Q. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+/* On exit, the diagonal elements of AB are overwritten by the */
+/* diagonal elements of the tridiagonal matrix T; if KD > 0, the */
+/* elements on the first superdiagonal (if UPLO = 'U') or the */
+/* first subdiagonal (if UPLO = 'L') are overwritten by the */
+/* off-diagonal elements of T; the rest of AB is overwritten by */
+/* values generated during the reduction. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* D (output) REAL array, dimension (N) */
+/* The diagonal elements of the tridiagonal matrix T. */
+
+/* E (output) REAL array, dimension (N-1) */
+/* The off-diagonal elements of the tridiagonal matrix T: */
+/* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'. */
+
+/* Q (input/output) COMPLEX array, dimension (LDQ,N) */
+/* On entry, if VECT = 'U', then Q must contain an N-by-N */
+/* matrix X; if VECT = 'N' or 'V', then Q need not be set. */
+
+/* On exit: */
+/* if VECT = 'V', Q contains the N-by-N unitary matrix Q; */
+/* if VECT = 'U', Q contains the product X*Q; */
+/* if VECT = 'N', the array Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. */
+/* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'. */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* Modified by Linda Kaufman, Bell Labs. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --d__;
+ --e;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+
+ /* Function Body */
+ initq = lsame_(vect, "V");
+ wantq = initq || lsame_(vect, "U");
+ upper = lsame_(uplo, "U");
+ kd1 = *kd + 1;
+ kdm1 = *kd - 1;
+ incx = *ldab - 1;
+ iqend = 1;
+
+ *info = 0;
+ if (! wantq && ! lsame_(vect, "N")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kd < 0) {
+ *info = -4;
+ } else if (*ldab < kd1) {
+ *info = -6;
+ } else if (*ldq < max(1,*n) && wantq) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHBTRD", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Initialize Q to the unit matrix, if needed */
+
+ if (initq) {
+ claset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
+ }
+
+/* Wherever possible, plane rotations are generated and applied in */
+/* vector operations of length NR over the index set J1:J2:KD1. */
+
+/* The real cosines and complex sines of the plane rotations are */
+/* stored in the arrays D and WORK. */
+
+ inca = kd1 * *ldab;
+/* Computing MIN */
+ i__1 = *n - 1;
+ kdn = min(i__1,*kd);
+ if (upper) {
+
+ if (*kd > 1) {
+
+/* Reduce to complex Hermitian tridiagonal form, working with */
+/* the upper triangle */
+
+ nr = 0;
+ j1 = kdn + 2;
+ j2 = 1;
+
+ i__1 = kd1 + ab_dim1;
+ i__2 = kd1 + ab_dim1;
+ r__1 = ab[i__2].r;
+ ab[i__1].r = r__1, ab[i__1].i = 0.f;
+ i__1 = *n - 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Reduce i-th row of matrix to tridiagonal form */
+
+ for (k = kdn + 1; k >= 2; --k) {
+ j1 += kdn;
+ j2 += kdn;
+
+ if (nr > 0) {
+
+/* generate plane rotations to annihilate nonzero */
+/* elements which have been created outside the band */
+
+ clargv_(&nr, &ab[(j1 - 1) * ab_dim1 + 1], &inca, &
+ work[j1], &kd1, &d__[j1], &kd1);
+
+/* apply rotations from the right */
+
+
+/* Dependent on the the number of diagonals either */
+/* CLARTV or CROT is used */
+
+ if (nr >= (*kd << 1) - 1) {
+ i__2 = *kd - 1;
+ for (l = 1; l <= i__2; ++l) {
+ clartv_(&nr, &ab[l + 1 + (j1 - 1) * ab_dim1],
+ &inca, &ab[l + j1 * ab_dim1], &inca, &
+ d__[j1], &work[j1], &kd1);
+/* L10: */
+ }
+
+ } else {
+ jend = j1 + (nr - 1) * kd1;
+ i__2 = jend;
+ i__3 = kd1;
+ for (jinc = j1; i__3 < 0 ? jinc >= i__2 : jinc <=
+ i__2; jinc += i__3) {
+ crot_(&kdm1, &ab[(jinc - 1) * ab_dim1 + 2], &
+ c__1, &ab[jinc * ab_dim1 + 1], &c__1,
+ &d__[jinc], &work[jinc]);
+/* L20: */
+ }
+ }
+ }
+
+
+ if (k > 2) {
+ if (k <= *n - i__ + 1) {
+
+/* generate plane rotation to annihilate a(i,i+k-1) */
+/* within the band */
+
+ clartg_(&ab[*kd - k + 3 + (i__ + k - 2) * ab_dim1]
+, &ab[*kd - k + 2 + (i__ + k - 1) *
+ ab_dim1], &d__[i__ + k - 1], &work[i__ +
+ k - 1], &temp);
+ i__3 = *kd - k + 3 + (i__ + k - 2) * ab_dim1;
+ ab[i__3].r = temp.r, ab[i__3].i = temp.i;
+
+/* apply rotation from the right */
+
+ i__3 = k - 3;
+ crot_(&i__3, &ab[*kd - k + 4 + (i__ + k - 2) *
+ ab_dim1], &c__1, &ab[*kd - k + 3 + (i__ +
+ k - 1) * ab_dim1], &c__1, &d__[i__ + k -
+ 1], &work[i__ + k - 1]);
+ }
+ ++nr;
+ j1 = j1 - kdn - 1;
+ }
+
+/* apply plane rotations from both sides to diagonal */
+/* blocks */
+
+ if (nr > 0) {
+ clar2v_(&nr, &ab[kd1 + (j1 - 1) * ab_dim1], &ab[kd1 +
+ j1 * ab_dim1], &ab[*kd + j1 * ab_dim1], &inca,
+ &d__[j1], &work[j1], &kd1);
+ }
+
+/* apply plane rotations from the left */
+
+ if (nr > 0) {
+ clacgv_(&nr, &work[j1], &kd1);
+ if ((*kd << 1) - 1 < nr) {
+
+/* Dependent on the the number of diagonals either */
+/* CLARTV or CROT is used */
+
+ i__3 = *kd - 1;
+ for (l = 1; l <= i__3; ++l) {
+ if (j2 + l > *n) {
+ nrt = nr - 1;
+ } else {
+ nrt = nr;
+ }
+ if (nrt > 0) {
+ clartv_(&nrt, &ab[*kd - l + (j1 + l) *
+ ab_dim1], &inca, &ab[*kd - l + 1
+ + (j1 + l) * ab_dim1], &inca, &
+ d__[j1], &work[j1], &kd1);
+ }
+/* L30: */
+ }
+ } else {
+ j1end = j1 + kd1 * (nr - 2);
+ if (j1end >= j1) {
+ i__3 = j1end;
+ i__2 = kd1;
+ for (jin = j1; i__2 < 0 ? jin >= i__3 : jin <=
+ i__3; jin += i__2) {
+ i__4 = *kd - 1;
+ crot_(&i__4, &ab[*kd - 1 + (jin + 1) *
+ ab_dim1], &incx, &ab[*kd + (jin +
+ 1) * ab_dim1], &incx, &d__[jin], &
+ work[jin]);
+/* L40: */
+ }
+ }
+/* Computing MIN */
+ i__2 = kdm1, i__3 = *n - j2;
+ lend = min(i__2,i__3);
+ last = j1end + kd1;
+ if (lend > 0) {
+ crot_(&lend, &ab[*kd - 1 + (last + 1) *
+ ab_dim1], &incx, &ab[*kd + (last + 1)
+ * ab_dim1], &incx, &d__[last], &work[
+ last]);
+ }
+ }
+ }
+
+ if (wantq) {
+
+/* accumulate product of plane rotations in Q */
+
+ if (initq) {
+
+/* take advantage of the fact that Q was */
+/* initially the Identity matrix */
+
+ iqend = max(iqend,j2);
+/* Computing MAX */
+ i__2 = 0, i__3 = k - 3;
+ i2 = max(i__2,i__3);
+ iqaend = i__ * *kd + 1;
+ if (k == 2) {
+ iqaend += *kd;
+ }
+ iqaend = min(iqaend,iqend);
+ i__2 = j2;
+ i__3 = kd1;
+ for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j
+ += i__3) {
+ ibl = i__ - i2 / kdm1;
+ ++i2;
+/* Computing MAX */
+ i__4 = 1, i__5 = j - ibl;
+ iqb = max(i__4,i__5);
+ nq = iqaend + 1 - iqb;
+/* Computing MIN */
+ i__4 = iqaend + *kd;
+ iqaend = min(i__4,iqend);
+ r_cnjg(&q__1, &work[j]);
+ crot_(&nq, &q[iqb + (j - 1) * q_dim1], &c__1,
+ &q[iqb + j * q_dim1], &c__1, &d__[j],
+ &q__1);
+/* L50: */
+ }
+ } else {
+
+ i__3 = j2;
+ i__2 = kd1;
+ for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j
+ += i__2) {
+ r_cnjg(&q__1, &work[j]);
+ crot_(n, &q[(j - 1) * q_dim1 + 1], &c__1, &q[
+ j * q_dim1 + 1], &c__1, &d__[j], &
+ q__1);
+/* L60: */
+ }
+ }
+
+ }
+
+ if (j2 + kdn > *n) {
+
+/* adjust J2 to keep within the bounds of the matrix */
+
+ --nr;
+ j2 = j2 - kdn - 1;
+ }
+
+ i__2 = j2;
+ i__3 = kd1;
+ for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j += i__3)
+ {
+
+/* create nonzero element a(j-1,j+kd) outside the band */
+/* and store it in WORK */
+
+ i__4 = j + *kd;
+ i__5 = j;
+ i__6 = (j + *kd) * ab_dim1 + 1;
+ q__1.r = work[i__5].r * ab[i__6].r - work[i__5].i *
+ ab[i__6].i, q__1.i = work[i__5].r * ab[i__6]
+ .i + work[i__5].i * ab[i__6].r;
+ work[i__4].r = q__1.r, work[i__4].i = q__1.i;
+ i__4 = (j + *kd) * ab_dim1 + 1;
+ i__5 = j;
+ i__6 = (j + *kd) * ab_dim1 + 1;
+ q__1.r = d__[i__5] * ab[i__6].r, q__1.i = d__[i__5] *
+ ab[i__6].i;
+ ab[i__4].r = q__1.r, ab[i__4].i = q__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+
+ if (*kd > 0) {
+
+/* make off-diagonal elements real and copy them to E */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__3 = *kd + (i__ + 1) * ab_dim1;
+ t.r = ab[i__3].r, t.i = ab[i__3].i;
+ abst = c_abs(&t);
+ i__3 = *kd + (i__ + 1) * ab_dim1;
+ ab[i__3].r = abst, ab[i__3].i = 0.f;
+ e[i__] = abst;
+ if (abst != 0.f) {
+ q__1.r = t.r / abst, q__1.i = t.i / abst;
+ t.r = q__1.r, t.i = q__1.i;
+ } else {
+ t.r = 1.f, t.i = 0.f;
+ }
+ if (i__ < *n - 1) {
+ i__3 = *kd + (i__ + 2) * ab_dim1;
+ i__2 = *kd + (i__ + 2) * ab_dim1;
+ q__1.r = ab[i__2].r * t.r - ab[i__2].i * t.i, q__1.i = ab[
+ i__2].r * t.i + ab[i__2].i * t.r;
+ ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
+ }
+ if (wantq) {
+ r_cnjg(&q__1, &t);
+ cscal_(n, &q__1, &q[(i__ + 1) * q_dim1 + 1], &c__1);
+ }
+/* L100: */
+ }
+ } else {
+
+/* set E to zero if original matrix was diagonal */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ e[i__] = 0.f;
+/* L110: */
+ }
+ }
+
+/* copy diagonal elements to D */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__3 = i__;
+ i__2 = kd1 + i__ * ab_dim1;
+ d__[i__3] = ab[i__2].r;
+/* L120: */
+ }
+
+ } else {
+
+ if (*kd > 1) {
+
+/* Reduce to complex Hermitian tridiagonal form, working with */
+/* the lower triangle */
+
+ nr = 0;
+ j1 = kdn + 2;
+ j2 = 1;
+
+ i__1 = ab_dim1 + 1;
+ i__3 = ab_dim1 + 1;
+ r__1 = ab[i__3].r;
+ ab[i__1].r = r__1, ab[i__1].i = 0.f;
+ i__1 = *n - 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Reduce i-th column of matrix to tridiagonal form */
+
+ for (k = kdn + 1; k >= 2; --k) {
+ j1 += kdn;
+ j2 += kdn;
+
+ if (nr > 0) {
+
+/* generate plane rotations to annihilate nonzero */
+/* elements which have been created outside the band */
+
+ clargv_(&nr, &ab[kd1 + (j1 - kd1) * ab_dim1], &inca, &
+ work[j1], &kd1, &d__[j1], &kd1);
+
+/* apply plane rotations from one side */
+
+
+/* Dependent on the the number of diagonals either */
+/* CLARTV or CROT is used */
+
+ if (nr > (*kd << 1) - 1) {
+ i__3 = *kd - 1;
+ for (l = 1; l <= i__3; ++l) {
+ clartv_(&nr, &ab[kd1 - l + (j1 - kd1 + l) *
+ ab_dim1], &inca, &ab[kd1 - l + 1 + (
+ j1 - kd1 + l) * ab_dim1], &inca, &d__[
+ j1], &work[j1], &kd1);
+/* L130: */
+ }
+ } else {
+ jend = j1 + kd1 * (nr - 1);
+ i__3 = jend;
+ i__2 = kd1;
+ for (jinc = j1; i__2 < 0 ? jinc >= i__3 : jinc <=
+ i__3; jinc += i__2) {
+ crot_(&kdm1, &ab[*kd + (jinc - *kd) * ab_dim1]
+, &incx, &ab[kd1 + (jinc - *kd) *
+ ab_dim1], &incx, &d__[jinc], &work[
+ jinc]);
+/* L140: */
+ }
+ }
+
+ }
+
+ if (k > 2) {
+ if (k <= *n - i__ + 1) {
+
+/* generate plane rotation to annihilate a(i+k-1,i) */
+/* within the band */
+
+ clartg_(&ab[k - 1 + i__ * ab_dim1], &ab[k + i__ *
+ ab_dim1], &d__[i__ + k - 1], &work[i__ +
+ k - 1], &temp);
+ i__2 = k - 1 + i__ * ab_dim1;
+ ab[i__2].r = temp.r, ab[i__2].i = temp.i;
+
+/* apply rotation from the left */
+
+ i__2 = k - 3;
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ crot_(&i__2, &ab[k - 2 + (i__ + 1) * ab_dim1], &
+ i__3, &ab[k - 1 + (i__ + 1) * ab_dim1], &
+ i__4, &d__[i__ + k - 1], &work[i__ + k -
+ 1]);
+ }
+ ++nr;
+ j1 = j1 - kdn - 1;
+ }
+
+/* apply plane rotations from both sides to diagonal */
+/* blocks */
+
+ if (nr > 0) {
+ clar2v_(&nr, &ab[(j1 - 1) * ab_dim1 + 1], &ab[j1 *
+ ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 + 2], &
+ inca, &d__[j1], &work[j1], &kd1);
+ }
+
+/* apply plane rotations from the right */
+
+
+/* Dependent on the the number of diagonals either */
+/* CLARTV or CROT is used */
+
+ if (nr > 0) {
+ clacgv_(&nr, &work[j1], &kd1);
+ if (nr > (*kd << 1) - 1) {
+ i__2 = *kd - 1;
+ for (l = 1; l <= i__2; ++l) {
+ if (j2 + l > *n) {
+ nrt = nr - 1;
+ } else {
+ nrt = nr;
+ }
+ if (nrt > 0) {
+ clartv_(&nrt, &ab[l + 2 + (j1 - 1) *
+ ab_dim1], &inca, &ab[l + 1 + j1 *
+ ab_dim1], &inca, &d__[j1], &work[
+ j1], &kd1);
+ }
+/* L150: */
+ }
+ } else {
+ j1end = j1 + kd1 * (nr - 2);
+ if (j1end >= j1) {
+ i__2 = j1end;
+ i__3 = kd1;
+ for (j1inc = j1; i__3 < 0 ? j1inc >= i__2 :
+ j1inc <= i__2; j1inc += i__3) {
+ crot_(&kdm1, &ab[(j1inc - 1) * ab_dim1 +
+ 3], &c__1, &ab[j1inc * ab_dim1 +
+ 2], &c__1, &d__[j1inc], &work[
+ j1inc]);
+/* L160: */
+ }
+ }
+/* Computing MIN */
+ i__3 = kdm1, i__2 = *n - j2;
+ lend = min(i__3,i__2);
+ last = j1end + kd1;
+ if (lend > 0) {
+ crot_(&lend, &ab[(last - 1) * ab_dim1 + 3], &
+ c__1, &ab[last * ab_dim1 + 2], &c__1,
+ &d__[last], &work[last]);
+ }
+ }
+ }
+
+
+
+ if (wantq) {
+
+/* accumulate product of plane rotations in Q */
+
+ if (initq) {
+
+/* take advantage of the fact that Q was */
+/* initially the Identity matrix */
+
+ iqend = max(iqend,j2);
+/* Computing MAX */
+ i__3 = 0, i__2 = k - 3;
+ i2 = max(i__3,i__2);
+ iqaend = i__ * *kd + 1;
+ if (k == 2) {
+ iqaend += *kd;
+ }
+ iqaend = min(iqaend,iqend);
+ i__3 = j2;
+ i__2 = kd1;
+ for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j
+ += i__2) {
+ ibl = i__ - i2 / kdm1;
+ ++i2;
+/* Computing MAX */
+ i__4 = 1, i__5 = j - ibl;
+ iqb = max(i__4,i__5);
+ nq = iqaend + 1 - iqb;
+/* Computing MIN */
+ i__4 = iqaend + *kd;
+ iqaend = min(i__4,iqend);
+ crot_(&nq, &q[iqb + (j - 1) * q_dim1], &c__1,
+ &q[iqb + j * q_dim1], &c__1, &d__[j],
+ &work[j]);
+/* L170: */
+ }
+ } else {
+
+ i__2 = j2;
+ i__3 = kd1;
+ for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j
+ += i__3) {
+ crot_(n, &q[(j - 1) * q_dim1 + 1], &c__1, &q[
+ j * q_dim1 + 1], &c__1, &d__[j], &
+ work[j]);
+/* L180: */
+ }
+ }
+ }
+
+ if (j2 + kdn > *n) {
+
+/* adjust J2 to keep within the bounds of the matrix */
+
+ --nr;
+ j2 = j2 - kdn - 1;
+ }
+
+ i__3 = j2;
+ i__2 = kd1;
+ for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2)
+ {
+
+/* create nonzero element a(j+kd,j-1) outside the */
+/* band and store it in WORK */
+
+ i__4 = j + *kd;
+ i__5 = j;
+ i__6 = kd1 + j * ab_dim1;
+ q__1.r = work[i__5].r * ab[i__6].r - work[i__5].i *
+ ab[i__6].i, q__1.i = work[i__5].r * ab[i__6]
+ .i + work[i__5].i * ab[i__6].r;
+ work[i__4].r = q__1.r, work[i__4].i = q__1.i;
+ i__4 = kd1 + j * ab_dim1;
+ i__5 = j;
+ i__6 = kd1 + j * ab_dim1;
+ q__1.r = d__[i__5] * ab[i__6].r, q__1.i = d__[i__5] *
+ ab[i__6].i;
+ ab[i__4].r = q__1.r, ab[i__4].i = q__1.i;
+/* L190: */
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+ }
+
+ if (*kd > 0) {
+
+/* make off-diagonal elements real and copy them to E */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ * ab_dim1 + 2;
+ t.r = ab[i__2].r, t.i = ab[i__2].i;
+ abst = c_abs(&t);
+ i__2 = i__ * ab_dim1 + 2;
+ ab[i__2].r = abst, ab[i__2].i = 0.f;
+ e[i__] = abst;
+ if (abst != 0.f) {
+ q__1.r = t.r / abst, q__1.i = t.i / abst;
+ t.r = q__1.r, t.i = q__1.i;
+ } else {
+ t.r = 1.f, t.i = 0.f;
+ }
+ if (i__ < *n - 1) {
+ i__2 = (i__ + 1) * ab_dim1 + 2;
+ i__3 = (i__ + 1) * ab_dim1 + 2;
+ q__1.r = ab[i__3].r * t.r - ab[i__3].i * t.i, q__1.i = ab[
+ i__3].r * t.i + ab[i__3].i * t.r;
+ ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
+ }
+ if (wantq) {
+ cscal_(n, &t, &q[(i__ + 1) * q_dim1 + 1], &c__1);
+ }
+/* L220: */
+ }
+ } else {
+
+/* set E to zero if original matrix was diagonal */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ e[i__] = 0.f;
+/* L230: */
+ }
+ }
+
+/* copy diagonal elements to D */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__ * ab_dim1 + 1;
+ d__[i__2] = ab[i__3].r;
+/* L240: */
+ }
+ }
+
+ return 0;
+
+/* End of CHBTRD */
+
+} /* chbtrd_ */
diff --git a/SRC/checon.c b/SRC/checon.c
new file mode 100644
index 0000000..af7eeed
--- /dev/null
+++ b/SRC/checon.c
@@ -0,0 +1,201 @@
+/* checon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int checon_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *ipiv, real *anorm, real *rcond, complex *work, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *), xerbla_(char *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int chetrs_(char *, integer *, integer *, complex
+ *, integer *, integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHECON estimates the reciprocal of the condition number of a complex */
+/* Hermitian matrix A using the factorization A = U*D*U**H or */
+/* A = L*D*L**H computed by CHETRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**H; */
+/* = 'L': Lower triangular, form is A = L*D*L**H. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by CHETRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CHETRF. */
+
+/* ANORM (input) REAL */
+/* The 1-norm of the original matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*anorm < 0.f) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHECON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.f;
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ } else if (*anorm <= 0.f) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ for (i__ = *n; i__ >= 1; --i__) {
+ i__1 = i__ + i__ * a_dim1;
+ if (ipiv[i__] > 0 && (a[i__1].r == 0.f && a[i__1].i == 0.f)) {
+ return 0;
+ }
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ if (ipiv[i__] > 0 && (a[i__2].r == 0.f && a[i__2].i == 0.f)) {
+ return 0;
+ }
+/* L20: */
+ }
+ }
+
+/* Estimate the 1-norm of the inverse. */
+
+ kase = 0;
+L30:
+ clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+
+/* Multiply by inv(L*D*L') or inv(U*D*U'). */
+
+ chetrs_(uplo, n, &c__1, &a[a_offset], lda, &ipiv[1], &work[1], n,
+ info);
+ goto L30;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / ainvnm / *anorm;
+ }
+
+ return 0;
+
+/* End of CHECON */
+
+} /* checon_ */
diff --git a/SRC/cheequb.c b/SRC/cheequb.c
new file mode 100644
index 0000000..dd51a2b
--- /dev/null
+++ b/SRC/cheequb.c
@@ -0,0 +1,440 @@
+/* cheequb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cheequb_(char *uplo, integer *n, complex *a, integer *
+ lda, real *s, real *scond, real *amax, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ doublereal d__1;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ double r_imag(complex *), sqrt(doublereal), log(doublereal), pow_ri(real *
+ , integer *);
+
+ /* Local variables */
+ real d__;
+ integer i__, j;
+ real t, u, c0, c1, c2, si;
+ logical up;
+ real avg, std, tol, base;
+ integer iter;
+ real smin, smax, scale;
+ extern logical lsame_(char *, char *);
+ real sumsq;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ extern /* Subroutine */ int classq_(integer *, complex *, integer *, real
+ *, real *);
+ real smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSYEQUB computes row and column scalings intended to equilibrate a */
+/* symmetric matrix A and reduce its condition number */
+/* (with respect to the two-norm). S contains the scale factors, */
+/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
+/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
+/* choice of S puts the condition number of B within a factor N of the */
+/* smallest possible condition number over all possible diagonal */
+/* scalings. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The N-by-N symmetric matrix whose scaling */
+/* factors are to be computed. Only the diagonal elements of A */
+/* are referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* S (output) REAL array, dimension (N) */
+/* If INFO = 0, S contains the scale factors for A. */
+
+/* SCOND (output) REAL */
+/* If INFO = 0, S contains the ratio of the smallest S(i) to */
+/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
+/* large nor too small, it is not worth scaling by S. */
+
+/* AMAX (output) REAL */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+
+/* Test input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (! (lsame_(uplo, "U") || lsame_(uplo, "L"))) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHEEQUB", &i__1);
+ return 0;
+ }
+ up = lsame_(uplo, "U");
+ *amax = 0.f;
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ *scond = 1.f;
+ return 0;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s[i__] = 0.f;
+ }
+ *amax = 0.f;
+ if (up) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = s[i__], r__4 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ s[i__] = dmax(r__3,r__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = s[j], r__4 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ s[j] = dmax(r__3,r__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = *amax, r__4 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ *amax = dmax(r__3,r__4);
+ }
+/* Computing MAX */
+ i__2 = j + j * a_dim1;
+ r__3 = s[j], r__4 = (r__1 = a[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[j + j * a_dim1]), dabs(r__2));
+ s[j] = dmax(r__3,r__4);
+/* Computing MAX */
+ i__2 = j + j * a_dim1;
+ r__3 = *amax, r__4 = (r__1 = a[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[j + j * a_dim1]), dabs(r__2));
+ *amax = dmax(r__3,r__4);
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j + j * a_dim1;
+ r__3 = s[j], r__4 = (r__1 = a[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[j + j * a_dim1]), dabs(r__2));
+ s[j] = dmax(r__3,r__4);
+/* Computing MAX */
+ i__2 = j + j * a_dim1;
+ r__3 = *amax, r__4 = (r__1 = a[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[j + j * a_dim1]), dabs(r__2));
+ *amax = dmax(r__3,r__4);
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = s[i__], r__4 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ s[i__] = dmax(r__3,r__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = s[j], r__4 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ s[j] = dmax(r__3,r__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = *amax, r__4 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ *amax = dmax(r__3,r__4);
+ }
+ }
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ s[j] = 1.f / s[j];
+ }
+ tol = 1.f / sqrt(*n * 2.f);
+ for (iter = 1; iter <= 100; ++iter) {
+ scale = 0.f;
+ sumsq = 0.f;
+/* beta = |A|s */
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ work[i__2].r = 0.f, work[i__2].i = 0.f;
+ }
+ if (up) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ t = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ i__ + j * a_dim1]), dabs(r__2));
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ r__3 = ((r__1 = a[i__5].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[i__ + j * a_dim1]), dabs(r__2))) * s[j];
+ q__1.r = work[i__4].r + r__3, q__1.i = work[i__4].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ i__3 = j;
+ i__4 = j;
+ i__5 = i__ + j * a_dim1;
+ r__3 = ((r__1 = a[i__5].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[i__ + j * a_dim1]), dabs(r__2))) * s[i__];
+ q__1.r = work[i__4].r + r__3, q__1.i = work[i__4].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ }
+ i__2 = j;
+ i__3 = j;
+ i__4 = j + j * a_dim1;
+ r__3 = ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&a[j
+ + j * a_dim1]), dabs(r__2))) * s[j];
+ q__1.r = work[i__3].r + r__3, q__1.i = work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ i__3 = j;
+ i__4 = j + j * a_dim1;
+ r__3 = ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&a[j
+ + j * a_dim1]), dabs(r__2))) * s[j];
+ q__1.r = work[i__3].r + r__3, q__1.i = work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ t = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ i__ + j * a_dim1]), dabs(r__2));
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ r__3 = ((r__1 = a[i__5].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[i__ + j * a_dim1]), dabs(r__2))) * s[j];
+ q__1.r = work[i__4].r + r__3, q__1.i = work[i__4].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ i__3 = j;
+ i__4 = j;
+ i__5 = i__ + j * a_dim1;
+ r__3 = ((r__1 = a[i__5].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[i__ + j * a_dim1]), dabs(r__2))) * s[i__];
+ q__1.r = work[i__4].r + r__3, q__1.i = work[i__4].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ }
+ }
+ }
+/* avg = s^T beta / n */
+ avg = 0.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ q__2.r = s[i__2] * work[i__3].r, q__2.i = s[i__2] * work[i__3].i;
+ q__1.r = avg + q__2.r, q__1.i = q__2.i;
+ avg = q__1.r;
+ }
+ avg /= *n;
+ std = 0.f;
+ i__1 = *n * 3;
+ for (i__ = (*n << 1) + 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__ - (*n << 1);
+ i__4 = i__ - (*n << 1);
+ q__2.r = s[i__3] * work[i__4].r, q__2.i = s[i__3] * work[i__4].i;
+ q__1.r = q__2.r - avg, q__1.i = q__2.i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ classq_(n, &work[(*n << 1) + 1], &c__1, &scale, &sumsq);
+ std = scale * sqrt(sumsq / *n);
+ if (std < tol * avg) {
+ goto L999;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ t = (r__1 = a[i__2].r, dabs(r__1)) + (r__2 = r_imag(&a[i__ + i__ *
+ a_dim1]), dabs(r__2));
+ si = s[i__];
+ c2 = (*n - 1) * t;
+ i__2 = *n - 2;
+ i__3 = i__;
+ r__1 = t * si;
+ q__2.r = work[i__3].r - r__1, q__2.i = work[i__3].i;
+ d__1 = (doublereal) i__2;
+ q__1.r = d__1 * q__2.r, q__1.i = d__1 * q__2.i;
+ c1 = q__1.r;
+ r__1 = -(t * si) * si;
+ i__2 = i__;
+ d__1 = 2.;
+ q__4.r = d__1 * work[i__2].r, q__4.i = d__1 * work[i__2].i;
+ q__3.r = si * q__4.r, q__3.i = si * q__4.i;
+ q__2.r = r__1 + q__3.r, q__2.i = q__3.i;
+ r__2 = *n * avg;
+ q__1.r = q__2.r - r__2, q__1.i = q__2.i;
+ c0 = q__1.r;
+ d__ = c1 * c1 - c0 * 4 * c2;
+ if (d__ <= 0.f) {
+ *info = -1;
+ return 0;
+ }
+ si = c0 * -2 / (c1 + sqrt(d__));
+ d__ = si - s[i__];
+ u = 0.f;
+ if (up) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ t = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[j
+ + i__ * a_dim1]), dabs(r__2));
+ u += s[j] * t;
+ i__3 = j;
+ i__4 = j;
+ r__1 = d__ * t;
+ q__1.r = work[i__4].r + r__1, q__1.i = work[i__4].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ t = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ i__ + j * a_dim1]), dabs(r__2));
+ u += s[j] * t;
+ i__3 = j;
+ i__4 = j;
+ r__1 = d__ * t;
+ q__1.r = work[i__4].r + r__1, q__1.i = work[i__4].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ t = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ i__ + j * a_dim1]), dabs(r__2));
+ u += s[j] * t;
+ i__3 = j;
+ i__4 = j;
+ r__1 = d__ * t;
+ q__1.r = work[i__4].r + r__1, q__1.i = work[i__4].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ t = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[j
+ + i__ * a_dim1]), dabs(r__2));
+ u += s[j] * t;
+ i__3 = j;
+ i__4 = j;
+ r__1 = d__ * t;
+ q__1.r = work[i__4].r + r__1, q__1.i = work[i__4].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ }
+ }
+ i__2 = i__;
+ q__4.r = u + work[i__2].r, q__4.i = work[i__2].i;
+ q__3.r = d__ * q__4.r, q__3.i = d__ * q__4.i;
+ d__1 = (doublereal) (*n);
+ q__2.r = q__3.r / d__1, q__2.i = q__3.i / d__1;
+ q__1.r = avg + q__2.r, q__1.i = q__2.i;
+ avg = q__1.r;
+ s[i__] = si;
+ }
+ }
+L999:
+ smlnum = slamch_("SAFEMIN");
+ bignum = 1.f / smlnum;
+ smin = bignum;
+ smax = 0.f;
+ t = 1.f / sqrt(avg);
+ base = slamch_("B");
+ u = 1.f / log(base);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = (integer) (u * log(s[i__] * t));
+ s[i__] = pow_ri(&base, &i__2);
+/* Computing MIN */
+ r__1 = smin, r__2 = s[i__];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = smax, r__2 = s[i__];
+ smax = dmax(r__1,r__2);
+ }
+ *scond = dmax(smin,smlnum) / dmin(smax,bignum);
+ return 0;
+} /* cheequb_ */
diff --git a/SRC/cheev.c b/SRC/cheev.c
new file mode 100644
index 0000000..58e2c93
--- /dev/null
+++ b/SRC/cheev.c
@@ -0,0 +1,284 @@
+/* cheev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static real c_b18 = 1.f;
+
+/* Subroutine */ int cheev_(char *jobz, char *uplo, integer *n, complex *a,
+ integer *lda, real *w, complex *work, integer *lwork, real *rwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer nb;
+ real eps;
+ integer inde;
+ real anrm;
+ integer imax;
+ real rmin, rmax, sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ logical lower, wantz;
+ extern doublereal clanhe_(char *, char *, integer *, complex *, integer *,
+ real *);
+ integer iscale;
+ extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int chetrd_(char *, integer *, complex *, integer
+ *, real *, real *, complex *, complex *, integer *, integer *);
+ real safmin;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ integer indtau, indwrk;
+ extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *,
+ complex *, integer *, real *, integer *), cungtr_(char *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ integer *), ssterf_(integer *, real *, real *, integer *);
+ integer llwork;
+ real smlnum;
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHEEV computes all eigenvalues and, optionally, eigenvectors of a */
+/* complex Hermitian matrix A. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (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. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
+/* orthonormal eigenvectors of the matrix A. */
+/* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') */
+/* or the upper triangle (if UPLO='U') of A, including the */
+/* diagonal, is destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(1,2*N-1). */
+/* For optimal efficiency, LWORK >= (NB+1)*N, */
+/* where NB is the blocksize for CHETRD 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. */
+
+/* RWORK (workspace) REAL array, dimension (max(1, 3*N-2)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of an intermediate tridiagonal */
+/* form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ lower = lsame_(uplo, "L");
+ lquery = *lwork == -1;
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+
+ if (*info == 0) {
+ nb = ilaenv_(&c__1, "CHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = 1, i__2 = (nb + 1) * *n;
+ lwkopt = max(i__1,i__2);
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+/* Computing MAX */
+ i__1 = 1, i__2 = (*n << 1) - 1;
+ if (*lwork < max(i__1,i__2) && ! lquery) {
+ *info = -8;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHEEV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ i__1 = a_dim1 + 1;
+ w[1] = a[i__1].r;
+ work[1].r = 1.f, work[1].i = 0.f;
+ if (wantz) {
+ i__1 = a_dim1 + 1;
+ a[i__1].r = 1.f, a[i__1].i = 0.f;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = clanhe_("M", uplo, n, &a[a_offset], lda, &rwork[1]);
+ iscale = 0;
+ if (anrm > 0.f && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ clascl_(uplo, &c__0, &c__0, &c_b18, &sigma, n, n, &a[a_offset], lda,
+ info);
+ }
+
+/* Call CHETRD to reduce Hermitian matrix to tridiagonal form. */
+
+ inde = 1;
+ indtau = 1;
+ indwrk = indtau + *n;
+ llwork = *lwork - indwrk + 1;
+ chetrd_(uplo, n, &a[a_offset], lda, &w[1], &rwork[inde], &work[indtau], &
+ work[indwrk], &llwork, &iinfo);
+
+/* For eigenvalues only, call SSTERF. For eigenvectors, first call */
+/* CUNGTR to generate the unitary matrix, then call CSTEQR. */
+
+ if (! wantz) {
+ ssterf_(n, &w[1], &rwork[inde], info);
+ } else {
+ cungtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], &
+ llwork, &iinfo);
+ indwrk = inde + *n;
+ csteqr_(jobz, n, &w[1], &rwork[inde], &a[a_offset], lda, &rwork[
+ indwrk], info);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *n;
+ } else {
+ imax = *info - 1;
+ }
+ r__1 = 1.f / sigma;
+ sscal_(&imax, &r__1, &w[1], &c__1);
+ }
+
+/* Set WORK(1) to optimal complex workspace size. */
+
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CHEEV */
+
+} /* cheev_ */
diff --git a/SRC/cheevd.c b/SRC/cheevd.c
new file mode 100644
index 0000000..0cade89
--- /dev/null
+++ b/SRC/cheevd.c
@@ -0,0 +1,377 @@
+/* cheevd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static real c_b18 = 1.f;
+
+/* Subroutine */ int cheevd_(char *jobz, char *uplo, integer *n, complex *a,
+ integer *lda, real *w, complex *work, integer *lwork, real *rwork,
+ integer *lrwork, integer *iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real eps;
+ integer inde;
+ real anrm;
+ integer imax;
+ real rmin, rmax;
+ integer lopt;
+ real sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ integer lwmin, liopt;
+ logical lower;
+ integer llrwk, lropt;
+ logical wantz;
+ integer indwk2, llwrk2;
+ extern doublereal clanhe_(char *, char *, integer *, complex *, integer *,
+ real *);
+ integer iscale;
+ extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, complex *, integer *, integer *), cstedc_(char *, integer *, real *, real *, complex *,
+ integer *, complex *, integer *, real *, integer *, integer *,
+ integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int chetrd_(char *, integer *, complex *, integer
+ *, real *, real *, complex *, complex *, integer *, integer *), clacpy_(char *, integer *, integer *, complex *, integer
+ *, complex *, integer *);
+ real safmin;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ integer indtau, indrwk, indwrk, liwmin;
+ extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
+ integer lrwmin;
+ extern /* Subroutine */ int cunmtr_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *);
+ integer llwork;
+ real smlnum;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHEEVD computes all eigenvalues and, optionally, eigenvectors of a */
+/* complex Hermitian matrix A. If eigenvectors are desired, it uses a */
+/* divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (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. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
+/* orthonormal eigenvectors of the matrix A. */
+/* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') */
+/* or the upper triangle (if UPLO='U') of A, including the */
+/* diagonal, is destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. */
+/* If N <= 1, LWORK must be at least 1. */
+/* If JOBZ = 'N' and N > 1, LWORK must be at least N + 1. */
+/* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N + N**2. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK, RWORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* RWORK (workspace/output) REAL array, */
+/* dimension (LRWORK) */
+/* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. */
+
+/* LRWORK (input) INTEGER */
+/* The dimension of the array RWORK. */
+/* If N <= 1, LRWORK must be at least 1. */
+/* If JOBZ = 'N' and N > 1, LRWORK must be at least N. */
+/* If JOBZ = 'V' and N > 1, LRWORK must be at least */
+/* 1 + 5*N + 2*N**2. */
+
+/* If LRWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If N <= 1, LIWORK must be at least 1. */
+/* If JOBZ = 'N' and N > 1, LIWORK must be at least 1. */
+/* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed */
+/* to converge; i off-diagonal elements of an intermediate */
+/* tridiagonal form did not converge to zero; */
+/* if INFO = i and JOBZ = 'V', then the algorithm failed */
+/* to compute an eigenvalue while working on the submatrix */
+/* lying in rows and columns INFO/(N+1) through */
+/* mod(INFO,N+1). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* Modified description of INFO. Sven, 16 Feb 05. */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ lower = lsame_(uplo, "L");
+ lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+
+ if (*info == 0) {
+ if (*n <= 1) {
+ lwmin = 1;
+ lrwmin = 1;
+ liwmin = 1;
+ lopt = lwmin;
+ lropt = lrwmin;
+ liopt = liwmin;
+ } else {
+ if (wantz) {
+ lwmin = (*n << 1) + *n * *n;
+/* Computing 2nd power */
+ i__1 = *n;
+ lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
+ liwmin = *n * 5 + 3;
+ } else {
+ lwmin = *n + 1;
+ lrwmin = *n;
+ liwmin = 1;
+ }
+/* Computing MAX */
+ i__1 = lwmin, i__2 = *n + ilaenv_(&c__1, "CHETRD", uplo, n, &c_n1,
+ &c_n1, &c_n1);
+ lopt = max(i__1,i__2);
+ lropt = lrwmin;
+ liopt = liwmin;
+ }
+ work[1].r = (real) lopt, work[1].i = 0.f;
+ rwork[1] = (real) lropt;
+ iwork[1] = liopt;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -8;
+ } else if (*lrwork < lrwmin && ! lquery) {
+ *info = -10;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHEEVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ i__1 = a_dim1 + 1;
+ w[1] = a[i__1].r;
+ if (wantz) {
+ i__1 = a_dim1 + 1;
+ a[i__1].r = 1.f, a[i__1].i = 0.f;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = clanhe_("M", uplo, n, &a[a_offset], lda, &rwork[1]);
+ iscale = 0;
+ if (anrm > 0.f && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ clascl_(uplo, &c__0, &c__0, &c_b18, &sigma, n, n, &a[a_offset], lda,
+ info);
+ }
+
+/* Call CHETRD to reduce Hermitian matrix to tridiagonal form. */
+
+ inde = 1;
+ indtau = 1;
+ indwrk = indtau + *n;
+ indrwk = inde + *n;
+ indwk2 = indwrk + *n * *n;
+ llwork = *lwork - indwrk + 1;
+ llwrk2 = *lwork - indwk2 + 1;
+ llrwk = *lrwork - indrwk + 1;
+ chetrd_(uplo, n, &a[a_offset], lda, &w[1], &rwork[inde], &work[indtau], &
+ work[indwrk], &llwork, &iinfo);
+
+/* For eigenvalues only, call SSTERF. For eigenvectors, first call */
+/* CSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the */
+/* tridiagonal matrix, then call CUNMTR to multiply it to the */
+/* Householder transformations represented as Householder vectors in */
+/* A. */
+
+ if (! wantz) {
+ ssterf_(n, &w[1], &rwork[inde], info);
+ } else {
+ cstedc_("I", n, &w[1], &rwork[inde], &work[indwrk], n, &work[indwk2],
+ &llwrk2, &rwork[indrwk], &llrwk, &iwork[1], liwork, info);
+ cunmtr_("L", uplo, "N", n, n, &a[a_offset], lda, &work[indtau], &work[
+ indwrk], n, &work[indwk2], &llwrk2, &iinfo);
+ clacpy_("A", n, n, &work[indwrk], n, &a[a_offset], lda);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *n;
+ } else {
+ imax = *info - 1;
+ }
+ r__1 = 1.f / sigma;
+ sscal_(&imax, &r__1, &w[1], &c__1);
+ }
+
+ work[1].r = (real) lopt, work[1].i = 0.f;
+ rwork[1] = (real) lropt;
+ iwork[1] = liopt;
+
+ return 0;
+
+/* End of CHEEVD */
+
+} /* cheevd_ */
diff --git a/SRC/cheevr.c b/SRC/cheevr.c
new file mode 100644
index 0000000..20e21ba
--- /dev/null
+++ b/SRC/cheevr.c
@@ -0,0 +1,687 @@
+/* cheevr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__10 = 10;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cheevr_(char *jobz, char *range, char *uplo, integer *n,
+ complex *a, integer *lda, real *vl, real *vu, integer *il, integer *
+ iu, real *abstol, integer *m, real *w, complex *z__, integer *ldz,
+ integer *isuppz, complex *work, integer *lwork, real *rwork, integer *
+ lrwork, integer *iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, nb, jj;
+ real eps, vll, vuu, tmp1, anrm;
+ integer imax;
+ real rmin, rmax;
+ logical test;
+ integer itmp1, indrd, indre;
+ real sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ char order[1];
+ integer indwk;
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer lwmin;
+ logical lower;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ logical wantz, alleig, indeig;
+ integer iscale, ieeeok, indibl, indrdd, indifl, indree;
+ logical valeig;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int chetrd_(char *, integer *, complex *, integer
+ *, real *, real *, complex *, complex *, integer *, integer *), csscal_(integer *, real *, complex *, integer *);
+ real safmin;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real abstll, bignum;
+ integer indtau, indisp;
+ extern /* Subroutine */ int cstein_(integer *, real *, real *, integer *,
+ real *, integer *, integer *, complex *, integer *, real *,
+ integer *, integer *, integer *);
+ integer indiwo, indwkn;
+ extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
+ real *);
+ extern /* Subroutine */ int cstemr_(char *, char *, integer *, real *,
+ real *, real *, real *, integer *, integer *, integer *, real *,
+ complex *, integer *, integer *, integer *, logical *, real *,
+ integer *, integer *, integer *, integer *);
+ integer indrwk, liwmin;
+ logical tryrac;
+ extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
+ integer lrwmin, llwrkn, llwork, nsplit;
+ real smlnum;
+ extern /* Subroutine */ int cunmtr_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *), sstebz_(
+ char *, char *, integer *, real *, real *, integer *, integer *,
+ real *, real *, real *, integer *, integer *, real *, integer *,
+ integer *, real *, integer *, integer *);
+ logical lquery;
+ integer lwkopt, llrwork;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHEEVR computes selected eigenvalues and, optionally, eigenvectors */
+/* of a complex Hermitian matrix A. Eigenvalues and eigenvectors can */
+/* be selected by specifying either a range of values or a range of */
+/* indices for the desired eigenvalues. */
+
+/* CHEEVR first reduces the matrix A to tridiagonal form T with a call */
+/* to CHETRD. Then, whenever possible, CHEEVR calls CSTEMR to compute */
+/* the eigenspectrum using Relatively Robust Representations. CSTEMR */
+/* computes eigenvalues by the dqds algorithm, while orthogonal */
+/* eigenvectors are computed from various "good" L D L^T representations */
+/* (also known as Relatively Robust Representations). Gram-Schmidt */
+/* orthogonalization is avoided as far as possible. More specifically, */
+/* the various steps of the algorithm are as follows. */
+
+/* For each unreduced block (submatrix) of T, */
+/* (a) Compute T - sigma I = L D L^T, so that L and D */
+/* define all the wanted eigenvalues to high relative accuracy. */
+/* This means that small relative changes in the entries of D and L */
+/* cause only small relative changes in the eigenvalues and */
+/* eigenvectors. The standard (unfactored) representation of the */
+/* tridiagonal matrix T does not have this property in general. */
+/* (b) Compute the eigenvalues to suitable accuracy. */
+/* If the eigenvectors are desired, the algorithm attains full */
+/* accuracy of the computed eigenvalues only right before */
+/* the corresponding vectors have to be computed, see steps c) and d). */
+/* (c) For each cluster of close eigenvalues, select a new */
+/* shift close to the cluster, find a new factorization, and refine */
+/* the shifted eigenvalues to suitable accuracy. */
+/* (d) For each eigenvalue with a large enough relative separation compute */
+/* the corresponding eigenvector by forming a rank revealing twisted */
+/* factorization. Go back to (c) for any clusters that remain. */
+
+/* The desired accuracy of the output can be specified by the input */
+/* parameter ABSTOL. */
+
+/* For more details, see DSTEMR's documentation and: */
+/* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */
+/* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */
+/* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */
+/* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */
+/* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */
+/* 2004. Also LAPACK Working Note 154. */
+/* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */
+/* tridiagonal eigenvalue/eigenvector problem", */
+/* Computer Science Division Technical Report No. UCB/CSD-97-971, */
+/* UC Berkeley, May 1997. */
+
+
+/* Note 1 : CHEEVR calls CSTEMR when the full spectrum is requested */
+/* on machines which conform to the ieee-754 floating point standard. */
+/* CHEEVR calls SSTEBZ and CSTEIN on non-ieee machines and */
+/* when partial spectrum requests are made. */
+
+/* Normal execution of CSTEMR may create NaNs and infinities and */
+/* hence may abort due to a floating point exception in environments */
+/* which do not handle NaNs and infinities in the ieee standard default */
+/* manner. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+/* ********* For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and */
+/* ********* CSTEIN are called */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (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. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+/* On exit, the lower triangle (if UPLO='L') or the upper */
+/* triangle (if UPLO='U') of A, including the diagonal, is */
+/* destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) REAL */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing A to tridiagonal form. */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices */
+/* with Guaranteed High Relative Accuracy," by Demmel and */
+/* Kahan, LAPACK Working Note #3. */
+
+/* If high relative accuracy is important, set ABSTOL to */
+/* SLAMCH( 'Safe minimum' ). Doing so will guarantee that */
+/* eigenvalues are computed to high relative accuracy when */
+/* possible in future releases. The current code does not */
+/* make any guarantees about high relative accuracy, but */
+/* furutre releases will. See J. Barlow and J. Demmel, */
+/* "Computing Accurate Eigensystems of Scaled Diagonally */
+/* Dominant Matrices", LAPACK Working Note #7, for a discussion */
+/* of which matrices define their eigenvalues to high relative */
+/* accuracy. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* The first M elements contain the selected eigenvalues in */
+/* ascending order. */
+
+/* Z (output) COMPLEX array, dimension (LDZ, max(1,M)) */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */
+/* The support of the eigenvectors in Z, i.e., the indices */
+/* indicating the nonzero elements in Z. The i-th eigenvector */
+/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */
+/* ISUPPZ( 2*i ). */
+/* ********* Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(1,2*N). */
+/* For optimal efficiency, LWORK >= (NB+1)*N, */
+/* where NB is the max of the blocksize for CHETRD and for */
+/* CUNMTR as returned by ILAENV. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK, RWORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK)) */
+/* On exit, if INFO = 0, RWORK(1) returns the optimal */
+/* (and minimal) LRWORK. */
+
+/* LRWORK (input) INTEGER */
+/* The length of the array RWORK. LRWORK >= max(1,24*N). */
+
+/* If LRWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal */
+/* (and minimal) LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. LIWORK >= max(1,10*N). */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: Internal error */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Inderjit Dhillon, IBM Almaden, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Ken Stanley, Computer Science Division, University of */
+/* California at Berkeley, USA */
+/* Jason Riedy, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --isuppz;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ ieeeok = ilaenv_(&c__10, "CHEEVR", "N", &c__1, &c__2, &c__3, &c__4);
+
+ lower = lsame_(uplo, "L");
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * 24;
+ lrwmin = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * 10;
+ liwmin = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = *n << 1;
+ lwmin = max(i__1,i__2);
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -8;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -9;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -10;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -15;
+ }
+ }
+
+ if (*info == 0) {
+ nb = ilaenv_(&c__1, "CHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "CUNMTR", uplo, n, &c_n1, &c_n1, &
+ c_n1);
+ nb = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = (nb + 1) * *n;
+ lwkopt = max(i__1,lwmin);
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ rwork[1] = (real) lrwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -18;
+ } else if (*lrwork < lrwmin && ! lquery) {
+ *info = -20;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -22;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHEEVR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ work[1].r = 1.f, work[1].i = 0.f;
+ return 0;
+ }
+
+ if (*n == 1) {
+ work[1].r = 2.f, work[1].i = 0.f;
+ if (alleig || indeig) {
+ *m = 1;
+ i__1 = a_dim1 + 1;
+ w[1] = a[i__1].r;
+ } else {
+ i__1 = a_dim1 + 1;
+ i__2 = a_dim1 + 1;
+ if (*vl < a[i__1].r && *vu >= a[i__2].r) {
+ *m = 1;
+ i__1 = a_dim1 + 1;
+ w[1] = a[i__1].r;
+ }
+ }
+ if (wantz) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1.f, z__[i__1].i = 0.f;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
+ rmax = dmin(r__1,r__2);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ abstll = *abstol;
+ if (valeig) {
+ vll = *vl;
+ vuu = *vu;
+ }
+ anrm = clansy_("M", uplo, n, &a[a_offset], lda, &rwork[1]);
+ if (anrm > 0.f && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ if (lower) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ csscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ csscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+ if (*abstol > 0.f) {
+ abstll = *abstol * sigma;
+ }
+ if (valeig) {
+ vll = *vl * sigma;
+ vuu = *vu * sigma;
+ }
+ }
+/* Initialize indices into workspaces. Note: The IWORK indices are */
+/* used only if SSTERF or CSTEMR fail. */
+/* WORK(INDTAU:INDTAU+N-1) stores the complex scalar factors of the */
+/* elementary reflectors used in CHETRD. */
+ indtau = 1;
+/* INDWK is the starting offset of the remaining complex workspace, */
+/* and LLWORK is the remaining complex workspace size. */
+ indwk = indtau + *n;
+ llwork = *lwork - indwk + 1;
+/* RWORK(INDRD:INDRD+N-1) stores the real tridiagonal's diagonal */
+/* entries. */
+ indrd = 1;
+/* RWORK(INDRE:INDRE+N-1) stores the off-diagonal entries of the */
+/* tridiagonal matrix from CHETRD. */
+ indre = indrd + *n;
+/* RWORK(INDRDD:INDRDD+N-1) is a copy of the diagonal entries over */
+/* -written by CSTEMR (the SSTERF path copies the diagonal to W). */
+ indrdd = indre + *n;
+/* RWORK(INDREE:INDREE+N-1) is a copy of the off-diagonal entries over */
+/* -written while computing the eigenvalues in SSTERF and CSTEMR. */
+ indree = indrdd + *n;
+/* INDRWK is the starting offset of the left-over real workspace, and */
+/* LLRWORK is the remaining workspace size. */
+ indrwk = indree + *n;
+ llrwork = *lrwork - indrwk + 1;
+/* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in SSTEBZ and */
+/* stores the block indices of each of the M<=N eigenvalues. */
+ indibl = 1;
+/* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in SSTEBZ and */
+/* stores the starting and finishing indices of each block. */
+ indisp = indibl + *n;
+/* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors */
+/* that corresponding to eigenvectors that fail to converge in */
+/* SSTEIN. This information is discarded; if any fail, the driver */
+/* returns INFO > 0. */
+ indifl = indisp + *n;
+/* INDIWO is the offset of the remaining integer workspace. */
+ indiwo = indisp + *n;
+
+/* Call CHETRD to reduce Hermitian matrix to tridiagonal form. */
+
+ chetrd_(uplo, n, &a[a_offset], lda, &rwork[indrd], &rwork[indre], &work[
+ indtau], &work[indwk], &llwork, &iinfo);
+
+/* If all eigenvalues are desired */
+/* then call SSTERF or CSTEMR and CUNMTR. */
+
+ test = FALSE_;
+ if (indeig) {
+ if (*il == 1 && *iu == *n) {
+ test = TRUE_;
+ }
+ }
+ if ((alleig || test) && ieeeok == 1) {
+ if (! wantz) {
+ scopy_(n, &rwork[indrd], &c__1, &w[1], &c__1);
+ i__1 = *n - 1;
+ scopy_(&i__1, &rwork[indre], &c__1, &rwork[indree], &c__1);
+ ssterf_(n, &w[1], &rwork[indree], info);
+ } else {
+ i__1 = *n - 1;
+ scopy_(&i__1, &rwork[indre], &c__1, &rwork[indree], &c__1);
+ scopy_(n, &rwork[indrd], &c__1, &rwork[indrdd], &c__1);
+
+ if (*abstol <= *n * 2.f * eps) {
+ tryrac = TRUE_;
+ } else {
+ tryrac = FALSE_;
+ }
+ cstemr_(jobz, "A", n, &rwork[indrdd], &rwork[indree], vl, vu, il,
+ iu, m, &w[1], &z__[z_offset], ldz, n, &isuppz[1], &tryrac,
+ &rwork[indrwk], &llrwork, &iwork[1], liwork, info);
+
+/* Apply unitary matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by CSTEIN. */
+
+ if (wantz && *info == 0) {
+ indwkn = indwk;
+ llwrkn = *lwork - indwkn + 1;
+ cunmtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau]
+, &z__[z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
+ }
+ }
+
+
+ if (*info == 0) {
+ *m = *n;
+ goto L30;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call SSTEBZ and, if eigenvectors are desired, CSTEIN. */
+/* Also call SSTEBZ and CSTEIN if CSTEMR fails. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indrd], &
+ rwork[indre], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &
+ rwork[indrwk], &iwork[indiwo], info);
+
+ if (wantz) {
+ cstein_(n, &rwork[indrd], &rwork[indre], m, &w[1], &iwork[indibl], &
+ iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[
+ indiwo], &iwork[indifl], info);
+
+/* Apply unitary matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by CSTEIN. */
+
+ indwkn = indwk;
+ llwrkn = *lwork - indwkn + 1;
+ cunmtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[
+ z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+L30:
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *m;
+ } else {
+ imax = *info - 1;
+ }
+ r__1 = 1.f / sigma;
+ sscal_(&imax, &r__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L40: */
+ }
+
+ if (i__ != 0) {
+ itmp1 = iwork[indibl + i__ - 1];
+ w[i__] = w[j];
+ iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
+ w[j] = tmp1;
+ iwork[indibl + j - 1] = itmp1;
+ cswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ }
+/* L50: */
+ }
+ }
+
+/* Set WORK(1) to optimal workspace size. */
+
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ rwork[1] = (real) lrwmin;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of CHEEVR */
+
+} /* cheevr_ */
diff --git a/SRC/cheevx.c b/SRC/cheevx.c
new file mode 100644
index 0000000..3381e87
--- /dev/null
+++ b/SRC/cheevx.c
@@ -0,0 +1,542 @@
+/* cheevx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cheevx_(char *jobz, char *range, char *uplo, integer *n,
+ complex *a, integer *lda, real *vl, real *vu, integer *il, integer *
+ iu, real *abstol, integer *m, real *w, complex *z__, integer *ldz,
+ complex *work, integer *lwork, real *rwork, integer *iwork, integer *
+ ifail, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, nb, jj;
+ real eps, vll, vuu, tmp1;
+ integer indd, inde;
+ real anrm;
+ integer imax;
+ real rmin, rmax;
+ logical test;
+ integer itmp1, indee;
+ real sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ char order[1];
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ logical lower;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ logical wantz;
+ extern doublereal clanhe_(char *, char *, integer *, complex *, integer *,
+ real *);
+ logical alleig, indeig;
+ integer iscale, indibl;
+ logical valeig;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int chetrd_(char *, integer *, complex *, integer
+ *, real *, real *, complex *, complex *, integer *, integer *), csscal_(integer *, real *, complex *, integer *),
+ clacpy_(char *, integer *, integer *, complex *, integer *,
+ complex *, integer *);
+ real safmin;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real abstll, bignum;
+ integer indiwk, indisp, indtau;
+ extern /* Subroutine */ int cstein_(integer *, real *, real *, integer *,
+ real *, integer *, integer *, complex *, integer *, real *,
+ integer *, integer *, integer *);
+ integer indrwk, indwrk, lwkmin;
+ extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *,
+ complex *, integer *, real *, integer *), cungtr_(char *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ integer *), ssterf_(integer *, real *, real *, integer *),
+ cunmtr_(char *, char *, char *, integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ integer *);
+ integer nsplit, llwork;
+ real smlnum;
+ extern /* Subroutine */ int sstebz_(char *, char *, integer *, real *,
+ real *, integer *, integer *, real *, real *, real *, integer *,
+ integer *, real *, integer *, integer *, real *, integer *,
+ integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHEEVX computes selected eigenvalues and, optionally, eigenvectors */
+/* of a complex Hermitian matrix A. Eigenvalues and eigenvectors can */
+/* be selected by specifying either a range of values or a range of */
+/* indices for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (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. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+/* On exit, the lower triangle (if UPLO='L') or the upper */
+/* triangle (if UPLO='U') of A, including the diagonal, is */
+/* destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) REAL */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing A to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*SLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*SLAMCH('S'). */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices */
+/* with Guaranteed High Relative Accuracy," by Demmel and */
+/* Kahan, LAPACK Working Note #3. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* On normal exit, the first M elements contain the selected */
+/* eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX array, dimension (LDZ, max(1,M)) */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If an eigenvector fails to converge, then that column of Z */
+/* contains the latest approximation to the eigenvector, and the */
+/* index of the eigenvector is returned in IFAIL. */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= 1, when N <= 1; */
+/* otherwise 2*N. */
+/* For optimal efficiency, LWORK >= (NB+1)*N, */
+/* where NB is the max of the blocksize for CHETRD and for */
+/* CUNMTR as 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. */
+
+/* RWORK (workspace) REAL array, dimension (7*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, then i eigenvectors failed to converge. */
+/* Their indices are stored in array IFAIL. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ lower = lsame_(uplo, "L");
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+ lquery = *lwork == -1;
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -8;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -9;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -10;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -15;
+ }
+ }
+
+ if (*info == 0) {
+ if (*n <= 1) {
+ lwkmin = 1;
+ work[1].r = (real) lwkmin, work[1].i = 0.f;
+ } else {
+ lwkmin = *n << 1;
+ nb = ilaenv_(&c__1, "CHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "CUNMTR", uplo, n, &c_n1, &c_n1,
+ &c_n1);
+ nb = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = (nb + 1) * *n;
+ lwkopt = max(i__1,i__2);
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ }
+
+ if (*lwork < lwkmin && ! lquery) {
+ *info = -17;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHEEVX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (alleig || indeig) {
+ *m = 1;
+ i__1 = a_dim1 + 1;
+ w[1] = a[i__1].r;
+ } else if (valeig) {
+ i__1 = a_dim1 + 1;
+ i__2 = a_dim1 + 1;
+ if (*vl < a[i__1].r && *vu >= a[i__2].r) {
+ *m = 1;
+ i__1 = a_dim1 + 1;
+ w[1] = a[i__1].r;
+ }
+ }
+ if (wantz) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1.f, z__[i__1].i = 0.f;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
+ rmax = dmin(r__1,r__2);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ abstll = *abstol;
+ if (valeig) {
+ vll = *vl;
+ vuu = *vu;
+ }
+ anrm = clanhe_("M", uplo, n, &a[a_offset], lda, &rwork[1]);
+ if (anrm > 0.f && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ if (lower) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ csscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ csscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+ if (*abstol > 0.f) {
+ abstll = *abstol * sigma;
+ }
+ if (valeig) {
+ vll = *vl * sigma;
+ vuu = *vu * sigma;
+ }
+ }
+
+/* Call CHETRD to reduce Hermitian matrix to tridiagonal form. */
+
+ indd = 1;
+ inde = indd + *n;
+ indrwk = inde + *n;
+ indtau = 1;
+ indwrk = indtau + *n;
+ llwork = *lwork - indwrk + 1;
+ chetrd_(uplo, n, &a[a_offset], lda, &rwork[indd], &rwork[inde], &work[
+ indtau], &work[indwrk], &llwork, &iinfo);
+
+/* If all eigenvalues are desired and ABSTOL is less than or equal to */
+/* zero, then call SSTERF or CUNGTR and CSTEQR. If this fails for */
+/* some eigenvalue, then try SSTEBZ. */
+
+ test = FALSE_;
+ if (indeig) {
+ if (*il == 1 && *iu == *n) {
+ test = TRUE_;
+ }
+ }
+ if ((alleig || test) && *abstol <= 0.f) {
+ scopy_(n, &rwork[indd], &c__1, &w[1], &c__1);
+ indee = indrwk + (*n << 1);
+ if (! wantz) {
+ i__1 = *n - 1;
+ scopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
+ ssterf_(n, &w[1], &rwork[indee], info);
+ } else {
+ clacpy_("A", n, n, &a[a_offset], lda, &z__[z_offset], ldz);
+ cungtr_(uplo, n, &z__[z_offset], ldz, &work[indtau], &work[indwrk]
+, &llwork, &iinfo);
+ i__1 = *n - 1;
+ scopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
+ csteqr_(jobz, n, &w[1], &rwork[indee], &z__[z_offset], ldz, &
+ rwork[indrwk], info);
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ifail[i__] = 0;
+/* L30: */
+ }
+ }
+ }
+ if (*info == 0) {
+ *m = *n;
+ goto L40;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call SSTEBZ and, if eigenvectors are desired, CSTEIN. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ indibl = 1;
+ indisp = indibl + *n;
+ indiwk = indisp + *n;
+ sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], &
+ rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &
+ rwork[indrwk], &iwork[indiwk], info);
+
+ if (wantz) {
+ cstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], &
+ iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[
+ indiwk], &ifail[1], info);
+
+/* Apply unitary matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by CSTEIN. */
+
+ cunmtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[
+ z_offset], ldz, &work[indwrk], &llwork, &iinfo);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+L40:
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *m;
+ } else {
+ imax = *info - 1;
+ }
+ r__1 = 1.f / sigma;
+ sscal_(&imax, &r__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L50: */
+ }
+
+ if (i__ != 0) {
+ itmp1 = iwork[indibl + i__ - 1];
+ w[i__] = w[j];
+ iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
+ w[j] = tmp1;
+ iwork[indibl + j - 1] = itmp1;
+ cswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ if (*info != 0) {
+ itmp1 = ifail[i__];
+ ifail[i__] = ifail[j];
+ ifail[j] = itmp1;
+ }
+ }
+/* L60: */
+ }
+ }
+
+/* Set WORK(1) to optimal complex workspace size. */
+
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CHEEVX */
+
+} /* cheevx_ */
diff --git a/SRC/chegs2.c b/SRC/chegs2.c
new file mode 100644
index 0000000..1988418
--- /dev/null
+++ b/SRC/chegs2.c
@@ -0,0 +1,334 @@
+/* chegs2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int chegs2_(integer *itype, char *uplo, integer *n, complex *
+ a, integer *lda, complex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Local variables */
+ integer k;
+ complex ct;
+ real akk, bkk;
+ extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex *
+, integer *, complex *, integer *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
+ complex *, integer *, complex *, integer *), ctrsv_(char *, char *, char *, integer *, complex *,
+ integer *, complex *, integer *), clacgv_(
+ integer *, complex *, integer *), csscal_(integer *, real *,
+ complex *, integer *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHEGS2 reduces a complex Hermitian-definite generalized */
+/* eigenproblem to standard form. */
+
+/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
+/* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L') */
+
+/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
+/* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L. */
+
+/* B must have been previously factorized as U'*U or L*L' by CPOTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L'); */
+/* = 2 or 3: compute U*A*U' or L'*A*L. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored, and how B has been factorized. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) 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, the transformed matrix, stored in the */
+/* same format as A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) COMPLEX array, dimension (LDB,N) */
+/* The triangular factor from the Cholesky factorization of B, */
+/* as returned by CPOTRF. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHEGS2", &i__1);
+ return 0;
+ }
+
+ if (*itype == 1) {
+ if (upper) {
+
+/* Compute inv(U')*A*inv(U) */
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+/* Update the upper triangle of A(k:n,k:n) */
+
+ i__2 = k + k * a_dim1;
+ akk = a[i__2].r;
+ i__2 = k + k * b_dim1;
+ bkk = b[i__2].r;
+/* Computing 2nd power */
+ r__1 = bkk;
+ akk /= r__1 * r__1;
+ i__2 = k + k * a_dim1;
+ a[i__2].r = akk, a[i__2].i = 0.f;
+ if (k < *n) {
+ i__2 = *n - k;
+ r__1 = 1.f / bkk;
+ csscal_(&i__2, &r__1, &a[k + (k + 1) * a_dim1], lda);
+ r__1 = akk * -.5f;
+ ct.r = r__1, ct.i = 0.f;
+ i__2 = *n - k;
+ clacgv_(&i__2, &a[k + (k + 1) * a_dim1], lda);
+ i__2 = *n - k;
+ clacgv_(&i__2, &b[k + (k + 1) * b_dim1], ldb);
+ i__2 = *n - k;
+ caxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
+ k + 1) * a_dim1], lda);
+ i__2 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cher2_(uplo, &i__2, &q__1, &a[k + (k + 1) * a_dim1], lda,
+ &b[k + (k + 1) * b_dim1], ldb, &a[k + 1 + (k + 1)
+ * a_dim1], lda);
+ i__2 = *n - k;
+ caxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
+ k + 1) * a_dim1], lda);
+ i__2 = *n - k;
+ clacgv_(&i__2, &b[k + (k + 1) * b_dim1], ldb);
+ i__2 = *n - k;
+ ctrsv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &b[
+ k + 1 + (k + 1) * b_dim1], ldb, &a[k + (k + 1) *
+ a_dim1], lda);
+ i__2 = *n - k;
+ clacgv_(&i__2, &a[k + (k + 1) * a_dim1], lda);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Compute inv(L)*A*inv(L') */
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+/* Update the lower triangle of A(k:n,k:n) */
+
+ i__2 = k + k * a_dim1;
+ akk = a[i__2].r;
+ i__2 = k + k * b_dim1;
+ bkk = b[i__2].r;
+/* Computing 2nd power */
+ r__1 = bkk;
+ akk /= r__1 * r__1;
+ i__2 = k + k * a_dim1;
+ a[i__2].r = akk, a[i__2].i = 0.f;
+ if (k < *n) {
+ i__2 = *n - k;
+ r__1 = 1.f / bkk;
+ csscal_(&i__2, &r__1, &a[k + 1 + k * a_dim1], &c__1);
+ r__1 = akk * -.5f;
+ ct.r = r__1, ct.i = 0.f;
+ i__2 = *n - k;
+ caxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
+ 1 + k * a_dim1], &c__1);
+ i__2 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cher2_(uplo, &i__2, &q__1, &a[k + 1 + k * a_dim1], &c__1,
+ &b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + (k + 1)
+ * a_dim1], lda);
+ i__2 = *n - k;
+ caxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
+ 1 + k * a_dim1], &c__1);
+ i__2 = *n - k;
+ ctrsv_(uplo, "No transpose", "Non-unit", &i__2, &b[k + 1
+ + (k + 1) * b_dim1], ldb, &a[k + 1 + k * a_dim1],
+ &c__1);
+ }
+/* L20: */
+ }
+ }
+ } else {
+ if (upper) {
+
+/* Compute U*A*U' */
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+/* Update the upper triangle of A(1:k,1:k) */
+
+ i__2 = k + k * a_dim1;
+ akk = a[i__2].r;
+ i__2 = k + k * b_dim1;
+ bkk = b[i__2].r;
+ i__2 = k - 1;
+ ctrmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset],
+ ldb, &a[k * a_dim1 + 1], &c__1);
+ r__1 = akk * .5f;
+ ct.r = r__1, ct.i = 0.f;
+ i__2 = k - 1;
+ caxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
+ 1], &c__1);
+ i__2 = k - 1;
+ cher2_(uplo, &i__2, &c_b1, &a[k * a_dim1 + 1], &c__1, &b[k *
+ b_dim1 + 1], &c__1, &a[a_offset], lda);
+ i__2 = k - 1;
+ caxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
+ 1], &c__1);
+ i__2 = k - 1;
+ csscal_(&i__2, &bkk, &a[k * a_dim1 + 1], &c__1);
+ i__2 = k + k * a_dim1;
+/* Computing 2nd power */
+ r__2 = bkk;
+ r__1 = akk * (r__2 * r__2);
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+/* L30: */
+ }
+ } else {
+
+/* Compute L'*A*L */
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+/* Update the lower triangle of A(1:k,1:k) */
+
+ i__2 = k + k * a_dim1;
+ akk = a[i__2].r;
+ i__2 = k + k * b_dim1;
+ bkk = b[i__2].r;
+ i__2 = k - 1;
+ clacgv_(&i__2, &a[k + a_dim1], lda);
+ i__2 = k - 1;
+ ctrmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &b[
+ b_offset], ldb, &a[k + a_dim1], lda);
+ r__1 = akk * .5f;
+ ct.r = r__1, ct.i = 0.f;
+ i__2 = k - 1;
+ clacgv_(&i__2, &b[k + b_dim1], ldb);
+ i__2 = k - 1;
+ caxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
+ i__2 = k - 1;
+ cher2_(uplo, &i__2, &c_b1, &a[k + a_dim1], lda, &b[k + b_dim1]
+, ldb, &a[a_offset], lda);
+ i__2 = k - 1;
+ caxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
+ i__2 = k - 1;
+ clacgv_(&i__2, &b[k + b_dim1], ldb);
+ i__2 = k - 1;
+ csscal_(&i__2, &bkk, &a[k + a_dim1], lda);
+ i__2 = k - 1;
+ clacgv_(&i__2, &a[k + a_dim1], lda);
+ i__2 = k + k * a_dim1;
+/* Computing 2nd power */
+ r__2 = bkk;
+ r__1 = akk * (r__2 * r__2);
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+/* L40: */
+ }
+ }
+ }
+ return 0;
+
+/* End of CHEGS2 */
+
+} /* chegs2_ */
diff --git a/SRC/chegst.c b/SRC/chegst.c
new file mode 100644
index 0000000..783d0ac
--- /dev/null
+++ b/SRC/chegst.c
@@ -0,0 +1,350 @@
+/* chegst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static complex c_b2 = {.5f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b18 = 1.f;
+
+/* Subroutine */ int chegst_(integer *itype, char *uplo, integer *n, complex *
+ a, integer *lda, complex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+ complex q__1;
+
+ /* Local variables */
+ integer k, kb, nb;
+ extern /* Subroutine */ int chemm_(char *, char *, integer *, integer *,
+ complex *, complex *, integer *, complex *, integer *, complex *,
+ complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *), ctrsm_(char *, char *,
+ char *, char *, integer *, integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int chegs2_(integer *, char *, integer *, complex
+ *, integer *, complex *, integer *, integer *), cher2k_(
+ char *, char *, integer *, integer *, complex *, complex *,
+ integer *, complex *, integer *, real *, complex *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHEGST reduces a complex Hermitian-definite generalized */
+/* eigenproblem to standard form. */
+
+/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
+/* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H) */
+
+/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
+/* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L. */
+
+/* B must have been previously factorized as U**H*U or L*L**H by CPOTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H); */
+/* = 2 or 3: compute U*A*U**H or L**H*A*L. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored and B is factored as */
+/* U**H*U; */
+/* = 'L': Lower triangle of A is stored and B is factored as */
+/* L*L**H. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) 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, the transformed matrix, stored in the */
+/* same format as A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) COMPLEX array, dimension (LDB,N) */
+/* The triangular factor from the Cholesky factorization of B, */
+/* as returned by CPOTRF. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHEGST", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "CHEGST", uplo, n, &c_n1, &c_n1, &c_n1);
+
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code */
+
+ chegs2_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
+ } else {
+
+/* Use blocked code */
+
+ if (*itype == 1) {
+ if (upper) {
+
+/* Compute inv(U')*A*inv(U) */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+/* Computing MIN */
+ i__3 = *n - k + 1;
+ kb = min(i__3,nb);
+
+/* Update the upper triangle of A(k:n,k:n) */
+
+ chegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
+ k * b_dim1], ldb, info);
+ if (k + kb <= *n) {
+ i__3 = *n - k - kb + 1;
+ ctrsm_("Left", uplo, "Conjugate transpose", "Non-unit"
+, &kb, &i__3, &c_b1, &b[k + k * b_dim1], ldb,
+ &a[k + (k + kb) * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ q__1.r = -.5f, q__1.i = -0.f;
+ chemm_("Left", uplo, &kb, &i__3, &q__1, &a[k + k *
+ a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb,
+ &c_b1, &a[k + (k + kb) * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cher2k_(uplo, "Conjugate transpose", &i__3, &kb, &
+ q__1, &a[k + (k + kb) * a_dim1], lda, &b[k + (
+ k + kb) * b_dim1], ldb, &c_b18, &a[k + kb + (
+ k + kb) * a_dim1], lda)
+ ;
+ i__3 = *n - k - kb + 1;
+ q__1.r = -.5f, q__1.i = -0.f;
+ chemm_("Left", uplo, &kb, &i__3, &q__1, &a[k + k *
+ a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb,
+ &c_b1, &a[k + (k + kb) * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ ctrsm_("Right", uplo, "No transpose", "Non-unit", &kb,
+ &i__3, &c_b1, &b[k + kb + (k + kb) * b_dim1],
+ ldb, &a[k + (k + kb) * a_dim1], lda);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Compute inv(L)*A*inv(L') */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+/* Computing MIN */
+ i__3 = *n - k + 1;
+ kb = min(i__3,nb);
+
+/* Update the lower triangle of A(k:n,k:n) */
+
+ chegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
+ k * b_dim1], ldb, info);
+ if (k + kb <= *n) {
+ i__3 = *n - k - kb + 1;
+ ctrsm_("Right", uplo, "Conjugate transpose", "Non-un"
+ "it", &i__3, &kb, &c_b1, &b[k + k * b_dim1],
+ ldb, &a[k + kb + k * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ q__1.r = -.5f, q__1.i = -0.f;
+ chemm_("Right", uplo, &i__3, &kb, &q__1, &a[k + k *
+ a_dim1], lda, &b[k + kb + k * b_dim1], ldb, &
+ c_b1, &a[k + kb + k * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cher2k_(uplo, "No transpose", &i__3, &kb, &q__1, &a[k
+ + kb + k * a_dim1], lda, &b[k + kb + k *
+ b_dim1], ldb, &c_b18, &a[k + kb + (k + kb) *
+ a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ q__1.r = -.5f, q__1.i = -0.f;
+ chemm_("Right", uplo, &i__3, &kb, &q__1, &a[k + k *
+ a_dim1], lda, &b[k + kb + k * b_dim1], ldb, &
+ c_b1, &a[k + kb + k * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ ctrsm_("Left", uplo, "No transpose", "Non-unit", &
+ i__3, &kb, &c_b1, &b[k + kb + (k + kb) *
+ b_dim1], ldb, &a[k + kb + k * a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+ } else {
+ if (upper) {
+
+/* Compute U*A*U' */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+/* Computing MIN */
+ i__3 = *n - k + 1;
+ kb = min(i__3,nb);
+
+/* Update the upper triangle of A(1:k+kb-1,1:k+kb-1) */
+
+ i__3 = k - 1;
+ ctrmm_("Left", uplo, "No transpose", "Non-unit", &i__3, &
+ kb, &c_b1, &b[b_offset], ldb, &a[k * a_dim1 + 1],
+ lda);
+ i__3 = k - 1;
+ chemm_("Right", uplo, &i__3, &kb, &c_b2, &a[k + k *
+ a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b1, &a[
+ k * a_dim1 + 1], lda);
+ i__3 = k - 1;
+ cher2k_(uplo, "No transpose", &i__3, &kb, &c_b1, &a[k *
+ a_dim1 + 1], lda, &b[k * b_dim1 + 1], ldb, &c_b18,
+ &a[a_offset], lda);
+ i__3 = k - 1;
+ chemm_("Right", uplo, &i__3, &kb, &c_b2, &a[k + k *
+ a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b1, &a[
+ k * a_dim1 + 1], lda);
+ i__3 = k - 1;
+ ctrmm_("Right", uplo, "Conjugate transpose", "Non-unit", &
+ i__3, &kb, &c_b1, &b[k + k * b_dim1], ldb, &a[k *
+ a_dim1 + 1], lda);
+ chegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
+ k * b_dim1], ldb, info);
+/* L30: */
+ }
+ } else {
+
+/* Compute L'*A*L */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+/* Computing MIN */
+ i__3 = *n - k + 1;
+ kb = min(i__3,nb);
+
+/* Update the lower triangle of A(1:k+kb-1,1:k+kb-1) */
+
+ i__3 = k - 1;
+ ctrmm_("Right", uplo, "No transpose", "Non-unit", &kb, &
+ i__3, &c_b1, &b[b_offset], ldb, &a[k + a_dim1],
+ lda);
+ i__3 = k - 1;
+ chemm_("Left", uplo, &kb, &i__3, &c_b2, &a[k + k * a_dim1]
+, lda, &b[k + b_dim1], ldb, &c_b1, &a[k + a_dim1],
+ lda);
+ i__3 = k - 1;
+ cher2k_(uplo, "Conjugate transpose", &i__3, &kb, &c_b1, &
+ a[k + a_dim1], lda, &b[k + b_dim1], ldb, &c_b18, &
+ a[a_offset], lda);
+ i__3 = k - 1;
+ chemm_("Left", uplo, &kb, &i__3, &c_b2, &a[k + k * a_dim1]
+, lda, &b[k + b_dim1], ldb, &c_b1, &a[k + a_dim1],
+ lda);
+ i__3 = k - 1;
+ ctrmm_("Left", uplo, "Conjugate transpose", "Non-unit", &
+ kb, &i__3, &c_b1, &b[k + k * b_dim1], ldb, &a[k +
+ a_dim1], lda);
+ chegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
+ k * b_dim1], ldb, info);
+/* L40: */
+ }
+ }
+ }
+ }
+ return 0;
+
+/* End of CHEGST */
+
+} /* chegst_ */
diff --git a/SRC/chegv.c b/SRC/chegv.c
new file mode 100644
index 0000000..0888e89
--- /dev/null
+++ b/SRC/chegv.c
@@ -0,0 +1,286 @@
+/* chegv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int chegv_(integer *itype, char *jobz, char *uplo, integer *
+ n, complex *a, integer *lda, complex *b, integer *ldb, real *w,
+ complex *work, integer *lwork, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+
+ /* Local variables */
+ integer nb, neig;
+ extern /* Subroutine */ int cheev_(char *, char *, integer *, complex *,
+ integer *, real *, complex *, integer *, real *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *);
+ char trans[1];
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *);
+ logical upper, wantz;
+ extern /* Subroutine */ int chegst_(integer *, char *, integer *, complex
+ *, integer *, complex *, integer *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), cpotrf_(
+ char *, integer *, complex *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHEGV computes all the eigenvalues, and optionally, the eigenvectors */
+/* of a complex generalized Hermitian-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. */
+/* Here A and B are assumed to be Hermitian and B is also */
+/* positive definite. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) 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. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+
+/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
+/* matrix Z of eigenvectors. The eigenvectors are normalized */
+/* as follows: */
+/* if ITYPE = 1 or 2, Z**H*B*Z = I; */
+/* if ITYPE = 3, Z**H*inv(B)*Z = I. */
+/* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') */
+/* or the lower triangle (if UPLO='L') of A, including the */
+/* diagonal, is destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX array, dimension (LDB, N) */
+/* On entry, the Hermitian positive definite matrix B. */
+/* If UPLO = 'U', the leading N-by-N upper triangular part of B */
+/* contains the upper triangular part of the matrix B. */
+/* If UPLO = 'L', the leading N-by-N lower triangular part of B */
+/* contains the lower triangular part of the matrix B. */
+
+/* On exit, if INFO <= N, the part of B containing the matrix is */
+/* overwritten by the triangular factor U or L from the Cholesky */
+/* factorization B = U**H*U or B = L*L**H. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(1,2*N-1). */
+/* For optimal efficiency, LWORK >= (NB+1)*N, */
+/* where NB is the blocksize for CHETRD 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. */
+
+/* RWORK (workspace) REAL array, dimension (max(1, 3*N-2)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: CPOTRF or CHEEV returned an error code: */
+/* <= N: if INFO = i, CHEEV failed to converge; */
+/* i off-diagonal elements of an intermediate */
+/* tridiagonal form did not converge to zero; */
+/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --w;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1;
+
+ *info = 0;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+
+ if (*info == 0) {
+ nb = ilaenv_(&c__1, "CHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = 1, i__2 = (nb + 1) * *n;
+ lwkopt = max(i__1,i__2);
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+/* Computing MAX */
+ i__1 = 1, i__2 = (*n << 1) - 1;
+ if (*lwork < max(i__1,i__2) && ! lquery) {
+ *info = -11;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHEGV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of B. */
+
+ cpotrf_(uplo, n, &b[b_offset], ldb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ chegst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
+ cheev_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &rwork[1]
+, info);
+
+ if (wantz) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ neig = *n;
+ if (*info > 0) {
+ neig = *info - 1;
+ }
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'C';
+ }
+
+ ctrsm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &b[
+ b_offset], ldb, &a[a_offset], lda);
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'C';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ ctrmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &b[
+ b_offset], ldb, &a[a_offset], lda);
+ }
+ }
+
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CHEGV */
+
+} /* chegv_ */
diff --git a/SRC/chegvd.c b/SRC/chegvd.c
new file mode 100644
index 0000000..5f19c37
--- /dev/null
+++ b/SRC/chegvd.c
@@ -0,0 +1,364 @@
+/* chegvd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+
+/* Subroutine */ int chegvd_(integer *itype, char *jobz, char *uplo, integer *
+ n, complex *a, integer *lda, complex *b, integer *ldb, real *w,
+ complex *work, integer *lwork, real *rwork, integer *lrwork, integer *
+ iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer lopt;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *);
+ integer lwmin;
+ char trans[1];
+ integer liopt;
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *);
+ logical upper;
+ integer lropt;
+ logical wantz;
+ extern /* Subroutine */ int cheevd_(char *, char *, integer *, complex *,
+ integer *, real *, complex *, integer *, real *, integer *,
+ integer *, integer *, integer *), chegst_(integer
+ *, char *, integer *, complex *, integer *, complex *, integer *,
+ integer *), xerbla_(char *, integer *), cpotrf_(
+ char *, integer *, complex *, integer *, integer *);
+ integer liwmin, lrwmin;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHEGVD computes all the eigenvalues, and optionally, the eigenvectors */
+/* of a complex generalized Hermitian-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */
+/* B are assumed to be Hermitian and B is also positive definite. */
+/* If eigenvectors are desired, it uses a divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) 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. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+
+/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
+/* matrix Z of eigenvectors. The eigenvectors are normalized */
+/* as follows: */
+/* if ITYPE = 1 or 2, Z**H*B*Z = I; */
+/* if ITYPE = 3, Z**H*inv(B)*Z = I. */
+/* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') */
+/* or the lower triangle (if UPLO='L') of A, including the */
+/* diagonal, is destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX array, dimension (LDB, N) */
+/* On entry, the Hermitian matrix B. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of B contains the */
+/* upper triangular part of the matrix B. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of B contains */
+/* the lower triangular part of the matrix B. */
+
+/* On exit, if INFO <= N, the part of B containing the matrix is */
+/* overwritten by the triangular factor U or L from the Cholesky */
+/* factorization B = U**H*U or B = L*L**H. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. */
+/* If N <= 1, LWORK >= 1. */
+/* If JOBZ = 'N' and N > 1, LWORK >= N + 1. */
+/* If JOBZ = 'V' and N > 1, LWORK >= 2*N + N**2. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK, RWORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK)) */
+/* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. */
+
+/* LRWORK (input) INTEGER */
+/* The dimension of the array RWORK. */
+/* If N <= 1, LRWORK >= 1. */
+/* If JOBZ = 'N' and N > 1, LRWORK >= N. */
+/* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2. */
+
+/* If LRWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If N <= 1, LIWORK >= 1. */
+/* If JOBZ = 'N' and N > 1, LIWORK >= 1. */
+/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: CPOTRF or CHEEVD returned an error code: */
+/* <= N: if INFO = i and JOBZ = 'N', then the algorithm */
+/* failed to converge; i off-diagonal elements of an */
+/* intermediate tridiagonal form did not converge to */
+/* zero; */
+/* if INFO = i and JOBZ = 'V', then the algorithm */
+/* failed to compute an eigenvalue while working on */
+/* the submatrix lying in rows and columns INFO/(N+1) */
+/* through mod(INFO,N+1); */
+/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* Modified so that no backsubstitution is performed if CHEEVD fails to */
+/* converge (NEIG in old code could be greater than N causing out of */
+/* bounds reference to A - reported by Ralf Meyer). Also corrected the */
+/* description of INFO and the test on ITYPE. Sven, 16 Feb 05. */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --w;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
+
+ *info = 0;
+ if (*n <= 1) {
+ lwmin = 1;
+ lrwmin = 1;
+ liwmin = 1;
+ } else if (wantz) {
+ lwmin = (*n << 1) + *n * *n;
+ lrwmin = *n * 5 + 1 + (*n << 1) * *n;
+ liwmin = *n * 5 + 3;
+ } else {
+ lwmin = *n + 1;
+ lrwmin = *n;
+ liwmin = 1;
+ }
+ lopt = lwmin;
+ lropt = lrwmin;
+ liopt = liwmin;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+
+ if (*info == 0) {
+ work[1].r = (real) lopt, work[1].i = 0.f;
+ rwork[1] = (real) lropt;
+ iwork[1] = liopt;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -11;
+ } else if (*lrwork < lrwmin && ! lquery) {
+ *info = -13;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -15;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHEGVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of B. */
+
+ cpotrf_(uplo, n, &b[b_offset], ldb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ chegst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
+ cheevd_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &rwork[
+ 1], lrwork, &iwork[1], liwork, info);
+/* Computing MAX */
+ r__1 = (real) lopt, r__2 = work[1].r;
+ lopt = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = (real) lropt;
+ lropt = dmax(r__1,rwork[1]);
+/* Computing MAX */
+ r__1 = (real) liopt, r__2 = (real) iwork[1];
+ liopt = dmax(r__1,r__2);
+
+ if (wantz && *info == 0) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'C';
+ }
+
+ ctrsm_("Left", uplo, trans, "Non-unit", n, n, &c_b1, &b[b_offset],
+ ldb, &a[a_offset], lda);
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'C';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ ctrmm_("Left", uplo, trans, "Non-unit", n, n, &c_b1, &b[b_offset],
+ ldb, &a[a_offset], lda);
+ }
+ }
+
+ work[1].r = (real) lopt, work[1].i = 0.f;
+ rwork[1] = (real) lropt;
+ iwork[1] = liopt;
+
+ return 0;
+
+/* End of CHEGVD */
+
+} /* chegvd_ */
diff --git a/SRC/chegvx.c b/SRC/chegvx.c
new file mode 100644
index 0000000..89d91de
--- /dev/null
+++ b/SRC/chegvx.c
@@ -0,0 +1,394 @@
+/* chegvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int chegvx_(integer *itype, char *jobz, char *range, char *
+ uplo, integer *n, complex *a, integer *lda, complex *b, integer *ldb,
+ real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *
+ m, real *w, complex *z__, integer *ldz, complex *work, integer *lwork,
+ real *rwork, integer *iwork, integer *ifail, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1, i__2;
+
+ /* Local variables */
+ integer nb;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *);
+ char trans[1];
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *);
+ logical upper, wantz, alleig, indeig, valeig;
+ extern /* Subroutine */ int chegst_(integer *, char *, integer *, complex
+ *, integer *, complex *, integer *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), cheevx_(
+ char *, char *, char *, integer *, complex *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, real *, complex *
+, integer *, complex *, integer *, real *, integer *, integer *,
+ integer *), cpotrf_(char *, integer *,
+ complex *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHEGVX computes selected eigenvalues, and optionally, eigenvectors */
+/* of a complex generalized Hermitian-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */
+/* B are assumed to be Hermitian and B is also positive definite. */
+/* Eigenvalues and eigenvectors can be selected by specifying either a */
+/* range of values or a range of indices for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+/* * */
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) 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. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+
+/* On exit, the lower triangle (if UPLO='L') or the upper */
+/* triangle (if UPLO='U') of A, including the diagonal, is */
+/* destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX array, dimension (LDB, N) */
+/* On entry, the Hermitian matrix B. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of B contains the */
+/* upper triangular part of the matrix B. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of B contains */
+/* the lower triangular part of the matrix B. */
+
+/* On exit, if INFO <= N, the part of B containing the matrix is */
+/* overwritten by the triangular factor U or L from the Cholesky */
+/* factorization B = U**H*U or B = L*L**H. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) REAL */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing A to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*SLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*SLAMCH('S'). */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* The first M elements contain the selected */
+/* eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX array, dimension (LDZ, max(1,M)) */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* The eigenvectors are normalized as follows: */
+/* if ITYPE = 1 or 2, Z**T*B*Z = I; */
+/* if ITYPE = 3, Z**T*inv(B)*Z = I. */
+
+/* If an eigenvector fails to converge, then that column of Z */
+/* contains the latest approximation to the eigenvector, and the */
+/* index of the eigenvector is returned in IFAIL. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(1,2*N). */
+/* For optimal efficiency, LWORK >= (NB+1)*N, */
+/* where NB is the blocksize for CHETRD 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. */
+
+/* RWORK (workspace) REAL array, dimension (7*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: CPOTRF or CHEEVX returned an error code: */
+/* <= N: if INFO = i, CHEEVX failed to converge; */
+/* i eigenvectors failed to converge. Their indices */
+/* are stored in array IFAIL. */
+/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+ lquery = *lwork == -1;
+
+ *info = 0;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -3;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -11;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -12;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -13;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -18;
+ }
+ }
+
+ if (*info == 0) {
+ nb = ilaenv_(&c__1, "CHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = 1, i__2 = (nb + 1) * *n;
+ lwkopt = max(i__1,i__2);
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *n << 1;
+ if (*lwork < max(i__1,i__2) && ! lquery) {
+ *info = -20;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHEGVX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of B. */
+
+ cpotrf_(uplo, n, &b[b_offset], ldb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ chegst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
+ cheevx_(jobz, range, uplo, n, &a[a_offset], lda, vl, vu, il, iu, abstol,
+ m, &w[1], &z__[z_offset], ldz, &work[1], lwork, &rwork[1], &iwork[
+ 1], &ifail[1], info);
+
+ if (wantz) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ if (*info > 0) {
+ *m = *info - 1;
+ }
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'C';
+ }
+
+ ctrsm_("Left", uplo, trans, "Non-unit", n, m, &c_b1, &b[b_offset],
+ ldb, &z__[z_offset], ldz);
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'C';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ ctrmm_("Left", uplo, trans, "Non-unit", n, m, &c_b1, &b[b_offset],
+ ldb, &z__[z_offset], ldz);
+ }
+ }
+
+/* Set WORK(1) to optimal complex workspace size. */
+
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CHEGVX */
+
+} /* chegvx_ */
diff --git a/SRC/cherfs.c b/SRC/cherfs.c
new file mode 100644
index 0000000..4811c60
--- /dev/null
+++ b/SRC/cherfs.c
@@ -0,0 +1,472 @@
+/* cherfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cherfs_(char *uplo, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex *
+ b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr,
+ complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ real s, xk;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int chemv_(char *, integer *, complex *, complex *
+, integer *, complex *, integer *, complex *, complex *, integer *
+);
+ integer isave[3];
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ integer count;
+ logical upper;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *), chetrs_(
+ char *, integer *, integer *, complex *, integer *, integer *,
+ complex *, integer *, integer *);
+ real lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHERFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is Hermitian indefinite, and */
+/* provides error bounds and backward error estimates for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The 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. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The factored form of the matrix A. AF contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor U or L from the factorization A = U*D*U**H or */
+/* A = L*D*L**H as computed by CHETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CHETRF. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by CHETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldx < max(1,*n)) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHERFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.f;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ q__1.r = -1.f, q__1.i = -0.f;
+ chemv_(uplo, n, &q__1, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, &
+ c_b1, &work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[
+ i__ + j * b_dim1]), dabs(r__2));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j
+ * x_dim1]), dabs(r__2));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + k * a_dim1]), dabs(r__2))) * xk;
+ i__4 = i__ + k * a_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ i__ + k * a_dim1]), dabs(r__2))) * ((r__3 = x[
+ i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[i__ + j *
+ x_dim1]), dabs(r__4)));
+/* L40: */
+ }
+ i__3 = k + k * a_dim1;
+ rwork[k] = rwork[k] + (r__1 = a[i__3].r, dabs(r__1)) * xk + s;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j
+ * x_dim1]), dabs(r__2));
+ i__3 = k + k * a_dim1;
+ rwork[k] += (r__1 = a[i__3].r, dabs(r__1)) * xk;
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + k * a_dim1]), dabs(r__2))) * xk;
+ i__4 = i__ + k * a_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ i__ + k * a_dim1]), dabs(r__2))) * ((r__3 = x[
+ i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[i__ + j *
+ x_dim1]), dabs(r__4)));
+/* L60: */
+ }
+ rwork[k] += s;
+/* L70: */
+ }
+ }
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__3 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
+ s = dmax(r__3,r__4);
+ } else {
+/* Computing MAX */
+ i__3 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = dmax(r__3,r__4);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ chetrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[1],
+ n, info);
+ caxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use CLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__3 = i__;
+ rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__];
+ } else {
+ i__3 = i__;
+ rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__] + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ chetrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L120: */
+ }
+ chetrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * x_dim1;
+ r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + j * x_dim1]), dabs(r__2));
+ lstres = dmax(r__3,r__4);
+/* L130: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of CHERFS */
+
+} /* cherfs_ */
diff --git a/SRC/cherfsx.c b/SRC/cherfsx.c
new file mode 100644
index 0000000..a1776eb
--- /dev/null
+++ b/SRC/cherfsx.c
@@ -0,0 +1,627 @@
+/* cherfsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int cherfsx_(char *uplo, char *equed, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *
+ ipiv, real *s, complex *b, integer *ldb, complex *x, integer *ldx,
+ real *rcond, real *berr, integer *n_err_bnds__, real *err_bnds_norm__,
+ real *err_bnds_comp__, integer *nparams, real *params, complex *work,
+ real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real illrcond_thresh__, unstable_thresh__, err_lbnd__;
+ integer ref_type__;
+ integer j;
+ real rcond_tmp__;
+ integer prec_type__;
+ real cwise_wrong__;
+ extern /* Subroutine */ int cla_herfsx_extended__(integer *, char *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ integer *, logical *, real *, complex *, integer *, complex *,
+ integer *, real *, integer *, real *, real *, complex *, real *,
+ complex *, complex *, real *, integer *, real *, real *, logical *
+ , integer *, ftnlen);
+ char norm[1];
+ logical ignore_cwise__;
+ extern logical lsame_(char *, char *);
+ extern doublereal cla_hercond_c__(char *, integer *, complex *, integer *,
+ complex *, integer *, integer *, real *, logical *, integer *,
+ complex *, real *, ftnlen);
+ real anorm;
+ logical rcequ;
+ extern doublereal cla_hercond_x__(char *, integer *, complex *, integer *,
+ complex *, integer *, integer *, complex *, integer *, complex *,
+ real *, ftnlen), clanhe_(char *, char *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int checon_(char *, integer *, complex *, integer
+ *, integer *, real *, real *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaprec_(char *);
+ integer ithresh, n_norms__;
+ real rthresh;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHERFSX improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is Hermitian indefinite, and */
+/* provides error bounds and backward error estimates for the */
+/* solution. In addition to normwise error bound, the code provides */
+/* maximum componentwise error bound if possible. See comments for */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds. */
+
+/* The original system of linear equations may have been equilibrated */
+/* before calling this routine, as described by arguments EQUED and S */
+/* below. In this case, the solution and error bounds returned are */
+/* for the original unequilibrated system. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* EQUED (input) CHARACTER*1 */
+/* Specifies the form of equilibration that was done to A */
+/* before calling this routine. This is needed to compute */
+/* the solution and error bounds correctly. */
+/* = 'N': No equilibration */
+/* = 'Y': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(S) * A * diag(S). */
+/* The right hand side B has been changed accordingly. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular */
+/* part of the matrix A, and the strictly lower triangular */
+/* part of A is not referenced. If UPLO = 'L', the leading */
+/* N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The factored form of the matrix A. AF contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor U or L from the factorization A = U*D*U**T or A = */
+/* L*D*L**T as computed by SSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by SSYTRF. */
+
+/* S (input or output) REAL array, dimension (N) */
+/* The scale factors for A. If EQUED = 'Y', A is multiplied on */
+/* the left and right by diag(S). S is an input argument if FACT = */
+/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
+/* = 'Y', each element of S must be positive. If S is output, each */
+/* element of S is a power of the radix. If S is input, each element */
+/* of S should be a power of the radix to ensure a reliable solution */
+/* and error estimates. Scaling by powers of the radix does not cause */
+/* rounding errors unless the result underflows or overflows. */
+/* Rounding errors during scaling lead to refining with a matrix that */
+/* is not equivalent to the input matrix, producing error estimates */
+/* that may not be reliable. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by SGETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) REAL array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check the input parameters. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ ref_type__ = 1;
+ if (*nparams >= 1) {
+ if (params[1] < 0.f) {
+ params[1] = 1.f;
+ } else {
+ ref_type__ = params[1];
+ }
+ }
+
+/* Set default parameters. */
+
+ illrcond_thresh__ = (real) (*n) * slamch_("Epsilon");
+ ithresh = 10;
+ rthresh = .5f;
+ unstable_thresh__ = .25f;
+ ignore_cwise__ = FALSE_;
+
+ if (*nparams >= 2) {
+ if (params[2] < 0.f) {
+ params[2] = (real) ithresh;
+ } else {
+ ithresh = (integer) params[2];
+ }
+ }
+ if (*nparams >= 3) {
+ if (params[3] < 0.f) {
+ if (ignore_cwise__) {
+ params[3] = 0.f;
+ } else {
+ params[3] = 1.f;
+ }
+ } else {
+ ignore_cwise__ = params[3] == 0.f;
+ }
+ }
+ if (ref_type__ == 0 || *n_err_bnds__ == 0) {
+ n_norms__ = 0;
+ } else if (ignore_cwise__) {
+ n_norms__ = 1;
+ } else {
+ n_norms__ = 2;
+ }
+
+ rcequ = lsame_(equed, "Y");
+
+/* Test input parameters. */
+
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! rcequ && ! lsame_(equed, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -11;
+ } else if (*ldx < max(1,*n)) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHERFSX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *nrhs == 0) {
+ *rcond = 1.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 0.f;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.f;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.f;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.f;
+ }
+ }
+ return 0;
+ }
+
+/* Default to failure. */
+
+ *rcond = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 1.f;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.f;
+ }
+ }
+
+/* Compute the norm of A and the reciprocal of the condition */
+/* number of A. */
+
+ *(unsigned char *)norm = 'I';
+ anorm = clanhe_(norm, uplo, n, &a[a_offset], lda, &rwork[1]);
+ checon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1],
+ info);
+
+/* Perform refinement on each right-hand side */
+
+ if (ref_type__ != 0) {
+ prec_type__ = ilaprec_("D");
+ cla_herfsx_extended__(&prec_type__, uplo, n, nrhs, &a[a_offset], lda,
+ &af[af_offset], ldaf, &ipiv[1], &rcequ, &s[1], &b[b_offset],
+ ldb, &x[x_offset], ldx, &berr[1], &n_norms__, &
+ err_bnds_norm__[err_bnds_norm_offset], &err_bnds_comp__[
+ err_bnds_comp_offset], &work[1], &rwork[1], &work[*n + 1],
+ (complex *)(&rwork[1]), rcond, &ithresh, &rthresh, &unstable_thresh__, &
+ ignore_cwise__, info, (ftnlen)1);
+ }
+/* Computing MAX */
+ r__1 = 10.f, r__2 = sqrt((real) (*n));
+ err_lbnd__ = dmax(r__1,r__2) * slamch_("Epsilon");
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {
+
+/* Compute scaled normwise condition number cond(A*C). */
+
+ if (rcequ) {
+ rcond_tmp__ = cla_hercond_c__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &s[1], &c_true, info, &work[1]
+ , &rwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = cla_hercond_c__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &s[1], &c_false, info, &work[
+ 1], &rwork[1], (ftnlen)1);
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1
+ << 1)] > 1.f) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 0.f;
+ if (*info <= *n) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {
+
+/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
+/* each right-hand side using the current solution as an estimate of */
+/* the true solution. If the componentwise error estimate is too */
+/* large, then the solution is a lousy estimate of truth and the */
+/* estimated RCOND may be too optimistic. To avoid misleading users, */
+/* the inverse condition number is set to 0.0 when the estimated */
+/* cwise error is at least CWISE_WRONG. */
+
+ cwise_wrong__ = sqrt(slamch_("Epsilon"));
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ cwise_wrong__) {
+ rcond_tmp__ = cla_hercond_x__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &x[j * x_dim1 + 1], info,
+ &work[1], &rwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = 0.f;
+ }
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1
+ << 1)] > 1.f) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 0.f;
+ if (params[3] == 1.f && *info < *n + j) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CHERFSX */
+
+} /* cherfsx_ */
diff --git a/SRC/chesv.c b/SRC/chesv.c
new file mode 100644
index 0000000..a0e4d1f
--- /dev/null
+++ b/SRC/chesv.c
@@ -0,0 +1,214 @@
+/* chesv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int chesv_(char *uplo, integer *n, integer *nrhs, complex *a,
+ integer *lda, integer *ipiv, complex *b, integer *ldb, complex *work,
+ integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ integer nb;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int chetrf_(char *, integer *, complex *, integer
+ *, integer *, complex *, integer *, integer *), xerbla_(
+ char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int chetrs_(char *, integer *, integer *, complex
+ *, integer *, integer *, complex *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHESV 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 diagonal pivoting method is used to factor A as */
+/* A = U * D * U**H, if UPLO = 'U', or */
+/* A = L * D * L**H, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is Hermitian and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then */
+/* used to solve the system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input/output) 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, the block diagonal matrix D and the */
+/* multipliers used to obtain the factor U or L from the */
+/* factorization A = U*D*U**H or A = L*D*L**H as computed by */
+/* CHETRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D, as */
+/* determined by CHETRF. If IPIV(k) > 0, then rows and columns */
+/* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 */
+/* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, */
+/* then rows and columns k-1 and -IPIV(k) were interchanged and */
+/* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and */
+/* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and */
+/* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 */
+/* diagonal block. */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK >= 1, and for best performance */
+/* LWORK >= max(1,N*NB), where NB is the optimal blocksize for */
+/* CHETRF. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */
+/* has been completed, but the block diagonal matrix D is */
+/* exactly singular, so the solution could not be computed. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*lwork < 1 && ! lquery) {
+ *info = -10;
+ }
+
+ if (*info == 0) {
+ if (*n == 0) {
+ lwkopt = 1;
+ } else {
+ nb = ilaenv_(&c__1, "CHETRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHESV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ chetrf_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], lwork, info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ chetrs_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], ldb,
+ info);
+
+ }
+
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CHESV */
+
+} /* chesv_ */
diff --git a/SRC/chesvx.c b/SRC/chesvx.c
new file mode 100644
index 0000000..f025237
--- /dev/null
+++ b/SRC/chesvx.c
@@ -0,0 +1,368 @@
+/* chesvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int chesvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *
+ ipiv, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond,
+ real *ferr, real *berr, complex *work, integer *lwork, real *rwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2;
+
+ /* Local variables */
+ integer nb;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern doublereal clanhe_(char *, char *, integer *, complex *, integer *,
+ real *);
+ extern /* Subroutine */ int checon_(char *, integer *, complex *, integer
+ *, integer *, real *, real *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int cherfs_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, integer *, complex *, integer
+ *, complex *, integer *, real *, real *, complex *, real *,
+ integer *), chetrf_(char *, integer *, complex *, integer
+ *, integer *, complex *, integer *, integer *), clacpy_(
+ char *, integer *, integer *, complex *, integer *, complex *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), chetrs_(
+ char *, integer *, integer *, complex *, integer *, integer *,
+ complex *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHESVX uses the diagonal pivoting factorization to compute the */
+/* solution to a complex system of linear equations A * X = B, */
+/* where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS */
+/* matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'N', the diagonal pivoting method is used to factor A. */
+/* The form of the factorization is */
+/* A = U * D * U**H, if UPLO = 'U', or */
+/* A = L * D * L**H, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is Hermitian and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* 2. If some D(i,i)=0, so that D is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 3. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 4. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of A has been */
+/* supplied on entry. */
+/* = 'F': On entry, AF and IPIV contain the factored form */
+/* of A. A, AF and IPIV will not be modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* 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. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) COMPLEX array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**H or A = L*D*L**H as computed by CHETRF. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**H or A = L*D*L**H. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by CHETRF. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by CHETRF. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A. If RCOND is less than the machine precision (in */
+/* particular, if RCOND = 0), the matrix is singular to working */
+/* precision. This condition is indicated by a return code of */
+/* INFO > 0. */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK >= max(1,2*N), and for best */
+/* performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where */
+/* NB is the optimal blocksize for CHETRF. */
+
+/* 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. */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: D(i,i) is exactly zero. The factorization */
+/* has been completed but the factor D is exactly */
+/* singular, so the solution and error bounds could */
+/* not be computed. RCOND = 0 is returned. */
+/* = N+1: D is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ lquery = *lwork == -1;
+ if (! nofact && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -11;
+ } else if (*ldx < max(1,*n)) {
+ *info = -13;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n << 1;
+ if (*lwork < max(i__1,i__2) && ! lquery) {
+ *info = -18;
+ }
+ }
+
+ if (*info == 0) {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n << 1;
+ lwkopt = max(i__1,i__2);
+ if (nofact) {
+ nb = ilaenv_(&c__1, "CHETRF", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = *n * nb;
+ lwkopt = max(i__1,i__2);
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHESVX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+ if (nofact) {
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ clacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ chetrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], lwork,
+ info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.f;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = clanhe_("I", uplo, n, &a[a_offset], lda, &rwork[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ checon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1],
+ info);
+
+/* Compute the solution vectors X. */
+
+ clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ chetrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solutions and */
+/* compute error bounds and backward error estimates for them. */
+
+ cherfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1],
+ &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1]
+, &rwork[1], info);
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < slamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CHESVX */
+
+} /* chesvx_ */
diff --git a/SRC/chesvxx.c b/SRC/chesvxx.c
new file mode 100644
index 0000000..7d9c5d1
--- /dev/null
+++ b/SRC/chesvxx.c
@@ -0,0 +1,627 @@
+/* chesvxx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int chesvxx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *
+ ipiv, char *equed, real *s, complex *b, integer *ldb, complex *x,
+ integer *ldx, real *rcond, real *rpvgrw, real *berr, integer *
+ n_err_bnds__, real *err_bnds_norm__, real *err_bnds_comp__, integer *
+ nparams, real *params, complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j;
+ real amax, smin, smax;
+ extern doublereal cla_herpvgrw__(char *, integer *, integer *, complex *,
+ integer *, complex *, integer *, integer *, real *, ftnlen);
+ extern logical lsame_(char *, char *);
+ real scond;
+ logical equil, rcequ;
+ extern /* Subroutine */ int claqhe_(char *, integer *, complex *, integer
+ *, real *, real *, real *, char *);
+ extern doublereal slamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int chetrf_(char *, integer *, complex *, integer
+ *, integer *, complex *, integer *, integer *), clacpy_(
+ char *, integer *, integer *, complex *, integer *, complex *,
+ integer *), xerbla_(char *, integer *);
+ real bignum;
+ integer infequ;
+ extern /* Subroutine */ int chetrs_(char *, integer *, integer *, complex
+ *, integer *, integer *, complex *, integer *, integer *);
+ real smlnum;
+ extern /* Subroutine */ int clascl2_(integer *, integer *, real *,
+ complex *, integer *), cheequb_(char *, integer *, complex *,
+ integer *, real *, real *, real *, complex *, integer *),
+ cherfsx_(char *, char *, integer *, integer *, complex *, integer
+ *, complex *, integer *, integer *, real *, complex *, integer *,
+ complex *, integer *, real *, real *, integer *, real *, real *,
+ integer *, real *, complex *, real *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHESVXX uses the diagonal pivoting factorization to compute the */
+/* solution to a complex system of linear equations A * X = B, where */
+/* A is an N-by-N symmetric matrix and X and B are N-by-NRHS */
+/* matrices. */
+
+/* If requested, both normwise and maximum componentwise error bounds */
+/* are returned. CHESVXX will return a solution with a tiny */
+/* guaranteed error (O(eps) where eps is the working machine */
+/* precision) unless the matrix is very ill-conditioned, in which */
+/* case a warning is returned. Relevant condition numbers also are */
+/* calculated and returned. */
+
+/* CHESVXX accepts user-provided factorizations and equilibration */
+/* factors; see the definitions of the FACT and EQUED options. */
+/* Solving with refinement and using a factorization from a previous */
+/* CHESVXX call will also produce a solution with either O(eps) */
+/* errors or warnings, but we cannot make that claim for general */
+/* user-provided factorizations and equilibration factors if they */
+/* differ from what CHESVXX would itself produce. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+
+/* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B */
+
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
+
+/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */
+/* the matrix A (after equilibration if FACT = 'E') as */
+
+/* A = U * D * U**T, if UPLO = 'U', or */
+/* A = L * D * L**T, if UPLO = 'L', */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* 3. If some D(i,i)=0, so that D is exactly singular, then the */
+/* routine returns with INFO = i. Otherwise, the factored form of A */
+/* is used to estimate the condition number of the matrix A (see */
+/* argument RCOND). If the reciprocal of the condition number is */
+/* less than machine precision, the routine still goes on to solve */
+/* for X and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */
+/* the routine will use iterative refinement to try to get a small */
+/* error and error bounds. Refinement calculates the residual to at */
+/* least twice the working precision. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(R) so that it solves the original system before */
+/* equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF and IPIV contain the factored form of A. */
+/* If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by S. */
+/* A, AF, and IPIV are not modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular */
+/* part of the matrix A, and the strictly lower triangular */
+/* part of A is not referenced. If UPLO = 'L', the leading */
+/* N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
+/* diag(S)*A*diag(S). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) COMPLEX array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L from the factorization A = */
+/* U*D*U**T or A = L*D*L**T as computed by SSYTRF. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L from the factorization A = */
+/* U*D*U**T or A = L*D*L**T. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains details of the interchanges and the block */
+/* structure of D, as determined by CHETRF. If IPIV(k) > 0, */
+/* then rows and columns k and IPIV(k) were interchanged and */
+/* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and */
+/* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and */
+/* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 */
+/* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0, */
+/* then rows and columns k+1 and -IPIV(k) were interchanged */
+/* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains details of the interchanges and the block */
+/* structure of D, as determined by CHETRF. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'Y': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(S) * A * diag(S). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* S (input or output) REAL array, dimension (N) */
+/* The scale factors for A. If EQUED = 'Y', A is multiplied on */
+/* the left and right by diag(S). S is an input argument if FACT = */
+/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
+/* = 'Y', each element of S must be positive. If S is output, each */
+/* element of S is a power of the radix. If S is input, each element */
+/* of S should be a power of the radix to ensure a reliable solution */
+/* and error estimates. Scaling by powers of the radix does not cause */
+/* rounding errors unless the result underflows or overflows. */
+/* Rounding errors during scaling lead to refining with a matrix that */
+/* is not equivalent to the input matrix, producing error estimates */
+/* that may not be reliable. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if EQUED = 'Y', B is overwritten by diag(S)*B; */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX array, dimension (LDX,NRHS) */
+/* If INFO = 0, the N-by-NRHS solution matrix X to the original */
+/* system of equations. Note that A and B are modified on exit if */
+/* EQUED .ne. 'N', and the solution to the equilibrated system is */
+/* inv(diag(S))*X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* RPVGRW (output) REAL */
+/* Reciprocal pivot growth. On exit, this contains the reciprocal */
+/* pivot growth factor norm(A)/norm(U). The "max absolute element" */
+/* norm is used. If this is much less than 1, then the stability of */
+/* the LU factorization of the (equilibrated) matrix A could be poor. */
+/* This also means that the solution X, estimated condition numbers, */
+/* and error bounds could be unreliable. If factorization fails with */
+/* 0<INFO<=N, then this contains the reciprocal pivot growth factor */
+/* for the leading INFO columns of A. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) REAL array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rcequ = FALSE_;
+ } else {
+ rcequ = lsame_(equed, "Y");
+ }
+
+/* Default is failure. If an input parameter is wrong or */
+/* factorization fails, make everything look horrible. Only the */
+/* pivot growth is set here, the rest is initialized in CHERFSX. */
+
+ *rpvgrw = 0.f;
+
+/* Test the input parameters. PARAMS is not tested until CHERFSX. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (lsame_(fact, "F") && ! (rcequ || lsame_(
+ equed, "N"))) {
+ *info = -9;
+ } else {
+ if (rcequ) {
+ smin = bignum;
+ smax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = smin, r__2 = s[j];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = smax, r__2 = s[j];
+ smax = dmax(r__1,r__2);
+/* L10: */
+ }
+ if (smin <= 0.f) {
+ *info = -10;
+ } else if (*n > 0) {
+ scond = dmax(smin,smlnum) / dmin(smax,bignum);
+ } else {
+ scond = 1.f;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -12;
+ } else if (*ldx < max(1,*n)) {
+ *info = -14;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHESVXX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ cheequb_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, &work[1], &
+ infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ claqhe_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed);
+ rcequ = lsame_(equed, "Y");
+ }
+ }
+
+/* Scale the right-hand side. */
+
+ if (rcequ) {
+ clascl2_(n, nrhs, &s[1], &b[b_offset], ldb);
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of A. */
+
+ clacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ i__1 = max(1,*n) * 5;
+ chetrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], &i__1,
+ info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Pivot in column INFO is exactly 0 */
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ if (*n > 0) {
+ *rpvgrw = cla_herpvgrw__(uplo, n, info, &a[a_offset], lda, &
+ af[af_offset], ldaf, &ipiv[1], &rwork[1], (ftnlen)1);
+ }
+ return 0;
+ }
+ }
+
+/* Compute the reciprocal pivot growth factor RPVGRW. */
+
+ if (*n > 0) {
+ *rpvgrw = cla_herpvgrw__(uplo, n, info, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &rwork[1], (ftnlen)1);
+ }
+
+/* Compute the solution matrix X. */
+
+ clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ chetrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ cherfsx_(uplo, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &
+ ipiv[1], &s[1], &b[b_offset], ldb, &x[x_offset], ldx, rcond, &
+ berr[1], n_err_bnds__, &err_bnds_norm__[err_bnds_norm_offset], &
+ err_bnds_comp__[err_bnds_comp_offset], nparams, ¶ms[1], &work[
+ 1], &rwork[1], info);
+
+/* Scale solutions. */
+
+ if (rcequ) {
+ clascl2_(n, nrhs, &s[1], &x[x_offset], ldx);
+ }
+
+ return 0;
+
+/* End of CHESVXX */
+
+} /* chesvxx_ */
diff --git a/SRC/chetd2.c b/SRC/chetd2.c
new file mode 100644
index 0000000..a18ee71
--- /dev/null
+++ b/SRC/chetd2.c
@@ -0,0 +1,358 @@
+/* chetd2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b2 = {0.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int chetd2_(char *uplo, integer *n, complex *a, integer *lda,
+ real *d__, real *e, complex *tau, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Local variables */
+ integer i__;
+ complex taui;
+ extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex *
+, integer *, complex *, integer *, complex *, integer *);
+ complex alpha;
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int chemv_(char *, integer *, complex *, complex *
+, integer *, complex *, integer *, complex *, complex *, integer *
+), caxpy_(integer *, complex *, complex *, integer *,
+ complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int clarfg_(integer *, complex *, complex *,
+ integer *, complex *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHETD2 reduces a complex Hermitian matrix A to real symmetric */
+/* tridiagonal form T by a unitary similarity transformation: */
+/* Q' * A * Q = T. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the 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 UPLO = 'U', the diagonal and first superdiagonal */
+/* of A are overwritten by the corresponding elements of the */
+/* tridiagonal matrix T, and the elements above the first */
+/* superdiagonal, with the array TAU, represent the unitary */
+/* matrix Q as a product of elementary reflectors; if UPLO */
+/* = 'L', the diagonal and first subdiagonal of A are over- */
+/* written by the corresponding elements of the tridiagonal */
+/* matrix T, and the elements below the first subdiagonal, with */
+/* the array TAU, represent the unitary matrix Q as a product */
+/* of elementary reflectors. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* D (output) REAL array, dimension (N) */
+/* The diagonal elements of the tridiagonal matrix T: */
+/* D(i) = A(i,i). */
+
+/* E (output) REAL array, dimension (N-1) */
+/* The off-diagonal elements of the tridiagonal matrix T: */
+/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */
+
+/* TAU (output) COMPLEX array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(n-1) . . . H(2) H(1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */
+/* A(1:i-1,i+1), and tau in TAU(i). */
+
+/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(1) H(2) . . . H(n-1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */
+/* and tau in TAU(i). */
+
+/* The contents of A on exit are illustrated by the following examples */
+/* with n = 5: */
+
+/* if UPLO = 'U': if UPLO = 'L': */
+
+/* ( d e v2 v3 v4 ) ( d ) */
+/* ( d e v3 v4 ) ( e d ) */
+/* ( d e v4 ) ( v1 e d ) */
+/* ( d e ) ( v1 v2 e d ) */
+/* ( d ) ( v1 v2 v3 e d ) */
+
+/* where d and e denote diagonal and off-diagonal elements of T, and vi */
+/* denotes an element of the vector defining H(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ --tau;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHETD2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Reduce the upper triangle of A */
+
+ i__1 = *n + *n * a_dim1;
+ i__2 = *n + *n * a_dim1;
+ r__1 = a[i__2].r;
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+
+/* Generate elementary reflector H(i) = I - tau * v * v' */
+/* to annihilate A(1:i-1,i+1) */
+
+ i__1 = i__ + (i__ + 1) * a_dim1;
+ alpha.r = a[i__1].r, alpha.i = a[i__1].i;
+ clarfg_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &taui);
+ i__1 = i__;
+ e[i__1] = alpha.r;
+
+ if (taui.r != 0.f || taui.i != 0.f) {
+
+/* Apply H(i) from both sides to A(1:i,1:i) */
+
+ i__1 = i__ + (i__ + 1) * a_dim1;
+ a[i__1].r = 1.f, a[i__1].i = 0.f;
+
+/* Compute x := tau * A * v storing x in TAU(1:i) */
+
+ chemv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) *
+ a_dim1 + 1], &c__1, &c_b2, &tau[1], &c__1);
+
+/* Compute w := x - 1/2 * tau * (x'*v) * v */
+
+ q__3.r = -.5f, q__3.i = -0.f;
+ q__2.r = q__3.r * taui.r - q__3.i * taui.i, q__2.i = q__3.r *
+ taui.i + q__3.i * taui.r;
+ cdotc_(&q__4, &i__, &tau[1], &c__1, &a[(i__ + 1) * a_dim1 + 1]
+, &c__1);
+ q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r *
+ q__4.i + q__2.i * q__4.r;
+ alpha.r = q__1.r, alpha.i = q__1.i;
+ caxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[
+ 1], &c__1);
+
+/* Apply the transformation as a rank-2 update: */
+/* A := A - v * w' - w * v' */
+
+ q__1.r = -1.f, q__1.i = -0.f;
+ cher2_(uplo, &i__, &q__1, &a[(i__ + 1) * a_dim1 + 1], &c__1, &
+ tau[1], &c__1, &a[a_offset], lda);
+
+ } else {
+ i__1 = i__ + i__ * a_dim1;
+ i__2 = i__ + i__ * a_dim1;
+ r__1 = a[i__2].r;
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ }
+ i__1 = i__ + (i__ + 1) * a_dim1;
+ i__2 = i__;
+ a[i__1].r = e[i__2], a[i__1].i = 0.f;
+ i__1 = i__ + 1;
+ i__2 = i__ + 1 + (i__ + 1) * a_dim1;
+ d__[i__1] = a[i__2].r;
+ i__1 = i__;
+ tau[i__1].r = taui.r, tau[i__1].i = taui.i;
+/* L10: */
+ }
+ i__1 = a_dim1 + 1;
+ d__[1] = a[i__1].r;
+ } else {
+
+/* Reduce the lower triangle of A */
+
+ i__1 = a_dim1 + 1;
+ i__2 = a_dim1 + 1;
+ r__1 = a[i__2].r;
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Generate elementary reflector H(i) = I - tau * v * v' */
+/* to annihilate A(i+2:n,i) */
+
+ i__2 = i__ + 1 + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *n - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ clarfg_(&i__2, &alpha, &a[min(i__3, *n)+ i__ * a_dim1], &c__1, &
+ taui);
+ i__2 = i__;
+ e[i__2] = alpha.r;
+
+ if (taui.r != 0.f || taui.i != 0.f) {
+
+/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
+
+ i__2 = i__ + 1 + i__ * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+
+/* Compute x := tau * A * v storing y in TAU(i:n-1) */
+
+ i__2 = *n - i__;
+ chemv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1],
+ lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b2, &tau[
+ i__], &c__1);
+
+/* Compute w := x - 1/2 * tau * (x'*v) * v */
+
+ q__3.r = -.5f, q__3.i = -0.f;
+ q__2.r = q__3.r * taui.r - q__3.i * taui.i, q__2.i = q__3.r *
+ taui.i + q__3.i * taui.r;
+ i__2 = *n - i__;
+ cdotc_(&q__4, &i__2, &tau[i__], &c__1, &a[i__ + 1 + i__ *
+ a_dim1], &c__1);
+ q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r *
+ q__4.i + q__2.i * q__4.r;
+ alpha.r = q__1.r, alpha.i = q__1.i;
+ i__2 = *n - i__;
+ caxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
+ i__], &c__1);
+
+/* Apply the transformation as a rank-2 update: */
+/* A := A - v * w' - w * v' */
+
+ i__2 = *n - i__;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cher2_(uplo, &i__2, &q__1, &a[i__ + 1 + i__ * a_dim1], &c__1,
+ &tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1],
+ lda);
+
+ } else {
+ i__2 = i__ + 1 + (i__ + 1) * a_dim1;
+ i__3 = i__ + 1 + (i__ + 1) * a_dim1;
+ r__1 = a[i__3].r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ }
+ i__2 = i__ + 1 + i__ * a_dim1;
+ i__3 = i__;
+ a[i__2].r = e[i__3], a[i__2].i = 0.f;
+ i__2 = i__;
+ i__3 = i__ + i__ * a_dim1;
+ d__[i__2] = a[i__3].r;
+ i__2 = i__;
+ tau[i__2].r = taui.r, tau[i__2].i = taui.i;
+/* L20: */
+ }
+ i__1 = *n;
+ i__2 = *n + *n * a_dim1;
+ d__[i__1] = a[i__2].r;
+ }
+
+ return 0;
+
+/* End of CHETD2 */
+
+} /* chetd2_ */
diff --git a/SRC/chetf2.c b/SRC/chetf2.c
new file mode 100644
index 0000000..8e98051
--- /dev/null
+++ b/SRC/chetf2.c
@@ -0,0 +1,802 @@
+/* chetf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int chetf2_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2, q__3, q__4, q__5, q__6;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_imag(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ real d__;
+ integer i__, j, k;
+ complex t;
+ real r1, d11;
+ complex d12;
+ real d22;
+ complex d21;
+ integer kk, kp;
+ complex wk;
+ real tt;
+ complex wkm1, wkp1;
+ extern /* Subroutine */ int cher_(char *, integer *, real *, complex *,
+ integer *, complex *, integer *);
+ integer imax, jmax;
+ real alpha;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer kstep;
+ logical upper;
+ extern doublereal slapy2_(real *, real *);
+ real absakk;
+ extern integer icamax_(integer *, complex *, integer *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), xerbla_(char *, integer *);
+ real colmax;
+ extern logical sisnan_(real *);
+ real rowmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHETF2 computes the factorization of a complex Hermitian matrix A */
+/* using the Bunch-Kaufman diagonal pivoting method: */
+
+/* A = U*D*U' or A = L*D*L' */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, U' is the conjugate transpose of U, 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. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the 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, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L (see below for further details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, D(k,k) is exactly zero. 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. */
+
+/* Further Details */
+/* =============== */
+
+/* 09-29-06 - patch from */
+/* Bobby Cheng, MathWorks */
+
+/* Replace l.210 and l.392 */
+/* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN */
+/* by */
+/* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN */
+
+/* 01-01-96 - Based on modifications by */
+/* J. Lewis, Boeing Computer Services Company */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* If UPLO = 'U', then A = U*D*U', where */
+/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
+/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
+/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I v 0 ) k-s */
+/* U(k) = ( 0 I 0 ) s */
+/* ( 0 0 I ) n-k */
+/* k-s s n-k */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
+/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
+/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
+
+/* If UPLO = 'L', then A = L*D*L', where */
+/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
+/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
+/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I 0 0 ) k-1 */
+/* L(k) = ( 0 I 0 ) s */
+/* ( 0 v I ) n-k-s+1 */
+/* k-1 s n-k-s+1 */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
+/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
+/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHETF2", &i__1);
+ return 0;
+ }
+
+/* Initialize ALPHA for use in choosing pivot block size. */
+
+ alpha = (sqrt(17.f) + 1.f) / 8.f;
+
+ if (upper) {
+
+/* Factorize A as U*D*U' using the upper triangle of A */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2 */
+
+ k = *n;
+L10:
+
+/* If K < 1, exit from loop */
+
+ if (k < 1) {
+ goto L90;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = k + k * a_dim1;
+ absakk = (r__1 = a[i__1].r, dabs(r__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ imax = icamax_(&i__1, &a[k * a_dim1 + 1], &c__1);
+ i__1 = imax + k * a_dim1;
+ colmax = (r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a[imax
+ + k * a_dim1]), dabs(r__2));
+ } else {
+ colmax = 0.f;
+ }
+
+ if (dmax(absakk,colmax) == 0.f || sisnan_(&absakk)) {
+
+/* Column K is zero or contains a NaN: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ r__1 = a[i__2].r;
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = k - imax;
+ jmax = imax + icamax_(&i__1, &a[imax + (imax + 1) * a_dim1],
+ lda);
+ i__1 = imax + jmax * a_dim1;
+ rowmax = (r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ imax + jmax * a_dim1]), dabs(r__2));
+ if (imax > 1) {
+ i__1 = imax - 1;
+ jmax = icamax_(&i__1, &a[imax * a_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__1 = jmax + imax * a_dim1;
+ r__3 = rowmax, r__4 = (r__1 = a[i__1].r, dabs(r__1)) + (
+ r__2 = r_imag(&a[jmax + imax * a_dim1]), dabs(
+ r__2));
+ rowmax = dmax(r__3,r__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = imax + imax * a_dim1;
+ if ((r__1 = a[i__1].r, dabs(r__1)) >= alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k - kstep + 1;
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the leading */
+/* submatrix A(1:k,1:k) */
+
+ i__1 = kp - 1;
+ cswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1],
+ &c__1);
+ i__1 = kk - 1;
+ for (j = kp + 1; j <= i__1; ++j) {
+ r_cnjg(&q__1, &a[j + kk * a_dim1]);
+ t.r = q__1.r, t.i = q__1.i;
+ i__2 = j + kk * a_dim1;
+ r_cnjg(&q__1, &a[kp + j * a_dim1]);
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ i__2 = kp + j * a_dim1;
+ a[i__2].r = t.r, a[i__2].i = t.i;
+/* L20: */
+ }
+ i__1 = kp + kk * a_dim1;
+ r_cnjg(&q__1, &a[kp + kk * a_dim1]);
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = kk + kk * a_dim1;
+ r1 = a[i__1].r;
+ i__1 = kk + kk * a_dim1;
+ i__2 = kp + kp * a_dim1;
+ r__1 = a[i__2].r;
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ i__1 = kp + kp * a_dim1;
+ a[i__1].r = r1, a[i__1].i = 0.f;
+ if (kstep == 2) {
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ r__1 = a[i__2].r;
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ i__1 = k - 1 + k * a_dim1;
+ t.r = a[i__1].r, t.i = a[i__1].i;
+ i__1 = k - 1 + k * a_dim1;
+ i__2 = kp + k * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + k * a_dim1;
+ a[i__1].r = t.r, a[i__1].i = t.i;
+ }
+ } else {
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ r__1 = a[i__2].r;
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ if (kstep == 2) {
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ i__2 = k - 1 + (k - 1) * a_dim1;
+ r__1 = a[i__2].r;
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ }
+ }
+
+/* Update the leading submatrix */
+
+ if (kstep == 1) {
+
+/* 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 */
+
+/* Perform a rank-1 update of A(1:k-1,1:k-1) as */
+
+/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */
+
+ i__1 = k + k * a_dim1;
+ r1 = 1.f / a[i__1].r;
+ i__1 = k - 1;
+ r__1 = -r1;
+ cher_(uplo, &i__1, &r__1, &a[k * a_dim1 + 1], &c__1, &a[
+ a_offset], lda);
+
+/* Store U(k) in column k */
+
+ i__1 = k - 1;
+ csscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
+ } 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) )' */
+/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */
+
+ if (k > 2) {
+
+ i__1 = k - 1 + k * a_dim1;
+ r__1 = a[i__1].r;
+ r__2 = r_imag(&a[k - 1 + k * a_dim1]);
+ d__ = slapy2_(&r__1, &r__2);
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ d22 = a[i__1].r / d__;
+ i__1 = k + k * a_dim1;
+ d11 = a[i__1].r / d__;
+ tt = 1.f / (d11 * d22 - 1.f);
+ i__1 = k - 1 + k * a_dim1;
+ q__1.r = a[i__1].r / d__, q__1.i = a[i__1].i / d__;
+ d12.r = q__1.r, d12.i = q__1.i;
+ d__ = tt / d__;
+
+ for (j = k - 2; j >= 1; --j) {
+ i__1 = j + (k - 1) * a_dim1;
+ q__3.r = d11 * a[i__1].r, q__3.i = d11 * a[i__1].i;
+ r_cnjg(&q__5, &d12);
+ i__2 = j + k * a_dim1;
+ q__4.r = q__5.r * a[i__2].r - q__5.i * a[i__2].i,
+ q__4.i = q__5.r * a[i__2].i + q__5.i * a[i__2]
+ .r;
+ q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
+ q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
+ wkm1.r = q__1.r, wkm1.i = q__1.i;
+ i__1 = j + k * a_dim1;
+ q__3.r = d22 * a[i__1].r, q__3.i = d22 * a[i__1].i;
+ i__2 = j + (k - 1) * a_dim1;
+ q__4.r = d12.r * a[i__2].r - d12.i * a[i__2].i,
+ q__4.i = d12.r * a[i__2].i + d12.i * a[i__2]
+ .r;
+ q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
+ q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
+ wk.r = q__1.r, wk.i = q__1.i;
+ for (i__ = j; i__ >= 1; --i__) {
+ i__1 = i__ + j * a_dim1;
+ i__2 = i__ + j * a_dim1;
+ i__3 = i__ + k * a_dim1;
+ r_cnjg(&q__4, &wk);
+ q__3.r = a[i__3].r * q__4.r - a[i__3].i * q__4.i,
+ q__3.i = a[i__3].r * q__4.i + a[i__3].i *
+ q__4.r;
+ q__2.r = a[i__2].r - q__3.r, q__2.i = a[i__2].i -
+ q__3.i;
+ i__4 = i__ + (k - 1) * a_dim1;
+ r_cnjg(&q__6, &wkm1);
+ q__5.r = a[i__4].r * q__6.r - a[i__4].i * q__6.i,
+ q__5.i = a[i__4].r * q__6.i + a[i__4].i *
+ q__6.r;
+ q__1.r = q__2.r - q__5.r, q__1.i = q__2.i -
+ q__5.i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+/* L30: */
+ }
+ i__1 = j + k * a_dim1;
+ a[i__1].r = wk.r, a[i__1].i = wk.i;
+ i__1 = j + (k - 1) * a_dim1;
+ a[i__1].r = wkm1.r, a[i__1].i = wkm1.i;
+ i__1 = j + j * a_dim1;
+ i__2 = j + j * a_dim1;
+ r__1 = a[i__2].r;
+ q__1.r = r__1, q__1.i = 0.f;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+/* L40: */
+ }
+
+ }
+
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k - 1] = -kp;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kstep;
+ goto L10;
+
+ } else {
+
+/* Factorize A as L*D*L' using the lower triangle of A */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2 */
+
+ k = 1;
+L50:
+
+/* If K > N, exit from loop */
+
+ if (k > *n) {
+ goto L90;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = k + k * a_dim1;
+ absakk = (r__1 = a[i__1].r, dabs(r__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ imax = k + icamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1);
+ i__1 = imax + k * a_dim1;
+ colmax = (r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a[imax
+ + k * a_dim1]), dabs(r__2));
+ } else {
+ colmax = 0.f;
+ }
+
+ if (dmax(absakk,colmax) == 0.f || sisnan_(&absakk)) {
+
+/* Column K is zero or contains a NaN: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ r__1 = a[i__2].r;
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = imax - k;
+ jmax = k - 1 + icamax_(&i__1, &a[imax + k * a_dim1], lda);
+ i__1 = imax + jmax * a_dim1;
+ rowmax = (r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ imax + jmax * a_dim1]), dabs(r__2));
+ if (imax < *n) {
+ i__1 = *n - imax;
+ jmax = imax + icamax_(&i__1, &a[imax + 1 + imax * a_dim1],
+ &c__1);
+/* Computing MAX */
+ i__1 = jmax + imax * a_dim1;
+ r__3 = rowmax, r__4 = (r__1 = a[i__1].r, dabs(r__1)) + (
+ r__2 = r_imag(&a[jmax + imax * a_dim1]), dabs(
+ r__2));
+ rowmax = dmax(r__3,r__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = imax + imax * a_dim1;
+ if ((r__1 = a[i__1].r, dabs(r__1)) >= alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k + kstep - 1;
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the trailing */
+/* submatrix A(k:n,k:n) */
+
+ if (kp < *n) {
+ i__1 = *n - kp;
+ cswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1
+ + kp * a_dim1], &c__1);
+ }
+ i__1 = kp - 1;
+ for (j = kk + 1; j <= i__1; ++j) {
+ r_cnjg(&q__1, &a[j + kk * a_dim1]);
+ t.r = q__1.r, t.i = q__1.i;
+ i__2 = j + kk * a_dim1;
+ r_cnjg(&q__1, &a[kp + j * a_dim1]);
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ i__2 = kp + j * a_dim1;
+ a[i__2].r = t.r, a[i__2].i = t.i;
+/* L60: */
+ }
+ i__1 = kp + kk * a_dim1;
+ r_cnjg(&q__1, &a[kp + kk * a_dim1]);
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = kk + kk * a_dim1;
+ r1 = a[i__1].r;
+ i__1 = kk + kk * a_dim1;
+ i__2 = kp + kp * a_dim1;
+ r__1 = a[i__2].r;
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ i__1 = kp + kp * a_dim1;
+ a[i__1].r = r1, a[i__1].i = 0.f;
+ if (kstep == 2) {
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ r__1 = a[i__2].r;
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ i__1 = k + 1 + k * a_dim1;
+ t.r = a[i__1].r, t.i = a[i__1].i;
+ i__1 = k + 1 + k * a_dim1;
+ i__2 = kp + k * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + k * a_dim1;
+ a[i__1].r = t.r, a[i__1].i = t.i;
+ }
+ } else {
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ r__1 = a[i__2].r;
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ if (kstep == 2) {
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ i__2 = k + 1 + (k + 1) * a_dim1;
+ r__1 = a[i__2].r;
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ }
+ }
+
+/* Update the trailing submatrix */
+
+ if (kstep == 1) {
+
+/* 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 < *n) {
+
+/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
+
+/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */
+
+ i__1 = k + k * a_dim1;
+ r1 = 1.f / a[i__1].r;
+ i__1 = *n - k;
+ r__1 = -r1;
+ cher_(uplo, &i__1, &r__1, &a[k + 1 + k * a_dim1], &c__1, &
+ a[k + 1 + (k + 1) * a_dim1], lda);
+
+/* Store L(k) in column K */
+
+ i__1 = *n - k;
+ csscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1);
+ }
+ } else {
+
+/* 2-by-2 pivot block D(k) */
+
+ if (k < *n - 1) {
+
+/* 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) )' */
+/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' */
+
+/* where L(k) and L(k+1) are the k-th and (k+1)-th */
+/* columns of L */
+
+ i__1 = k + 1 + k * a_dim1;
+ r__1 = a[i__1].r;
+ r__2 = r_imag(&a[k + 1 + k * a_dim1]);
+ d__ = slapy2_(&r__1, &r__2);
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ d11 = a[i__1].r / d__;
+ i__1 = k + k * a_dim1;
+ d22 = a[i__1].r / d__;
+ tt = 1.f / (d11 * d22 - 1.f);
+ i__1 = k + 1 + k * a_dim1;
+ q__1.r = a[i__1].r / d__, q__1.i = a[i__1].i / d__;
+ d21.r = q__1.r, d21.i = q__1.i;
+ d__ = tt / d__;
+
+ i__1 = *n;
+ for (j = k + 2; j <= i__1; ++j) {
+ i__2 = j + k * a_dim1;
+ q__3.r = d11 * a[i__2].r, q__3.i = d11 * a[i__2].i;
+ i__3 = j + (k + 1) * a_dim1;
+ q__4.r = d21.r * a[i__3].r - d21.i * a[i__3].i,
+ q__4.i = d21.r * a[i__3].i + d21.i * a[i__3]
+ .r;
+ q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
+ q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
+ wk.r = q__1.r, wk.i = q__1.i;
+ i__2 = j + (k + 1) * a_dim1;
+ q__3.r = d22 * a[i__2].r, q__3.i = d22 * a[i__2].i;
+ r_cnjg(&q__5, &d21);
+ i__3 = j + k * a_dim1;
+ q__4.r = q__5.r * a[i__3].r - q__5.i * a[i__3].i,
+ q__4.i = q__5.r * a[i__3].i + q__5.i * a[i__3]
+ .r;
+ q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
+ q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
+ wkp1.r = q__1.r, wkp1.i = q__1.i;
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__ + k * a_dim1;
+ r_cnjg(&q__4, &wk);
+ q__3.r = a[i__5].r * q__4.r - a[i__5].i * q__4.i,
+ q__3.i = a[i__5].r * q__4.i + a[i__5].i *
+ q__4.r;
+ q__2.r = a[i__4].r - q__3.r, q__2.i = a[i__4].i -
+ q__3.i;
+ i__6 = i__ + (k + 1) * a_dim1;
+ r_cnjg(&q__6, &wkp1);
+ q__5.r = a[i__6].r * q__6.r - a[i__6].i * q__6.i,
+ q__5.i = a[i__6].r * q__6.i + a[i__6].i *
+ q__6.r;
+ q__1.r = q__2.r - q__5.r, q__1.i = q__2.i -
+ q__5.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L70: */
+ }
+ i__2 = j + k * a_dim1;
+ a[i__2].r = wk.r, a[i__2].i = wk.i;
+ i__2 = j + (k + 1) * a_dim1;
+ a[i__2].r = wkp1.r, a[i__2].i = wkp1.i;
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ r__1 = a[i__3].r;
+ q__1.r = r__1, q__1.i = 0.f;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L80: */
+ }
+ }
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k + 1] = -kp;
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kstep;
+ goto L50;
+
+ }
+
+L90:
+ return 0;
+
+/* End of CHETF2 */
+
+} /* chetf2_ */
diff --git a/SRC/chetrd.c b/SRC/chetrd.c
new file mode 100644
index 0000000..38df87a
--- /dev/null
+++ b/SRC/chetrd.c
@@ -0,0 +1,369 @@
+/* chetrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+static real c_b23 = 1.f;
+
+/* Subroutine */ int chetrd_(char *uplo, integer *n, complex *a, integer *lda,
+ real *d__, real *e, complex *tau, complex *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j, nb, kk, nx, iws;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ logical upper;
+ extern /* Subroutine */ int chetd2_(char *, integer *, complex *, integer
+ *, real *, real *, complex *, integer *), cher2k_(char *,
+ char *, integer *, integer *, complex *, complex *, integer *,
+ complex *, integer *, real *, complex *, integer *), clatrd_(char *, integer *, integer *, complex *, integer
+ *, real *, complex *, complex *, integer *), xerbla_(char
+ *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHETRD reduces a complex Hermitian matrix A to real symmetric */
+/* tridiagonal form T by a unitary similarity transformation: */
+/* Q**H * A * Q = T. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (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 UPLO = 'U', the diagonal and first superdiagonal */
+/* of A are overwritten by the corresponding elements of the */
+/* tridiagonal matrix T, and the elements above the first */
+/* superdiagonal, with the array TAU, represent the unitary */
+/* matrix Q as a product of elementary reflectors; if UPLO */
+/* = 'L', the diagonal and first subdiagonal of A are over- */
+/* written by the corresponding elements of the tridiagonal */
+/* matrix T, and the elements below the first subdiagonal, with */
+/* the array TAU, represent the unitary matrix Q as a product */
+/* of elementary reflectors. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* D (output) REAL array, dimension (N) */
+/* The diagonal elements of the tridiagonal matrix T: */
+/* D(i) = A(i,i). */
+
+/* E (output) REAL array, dimension (N-1) */
+/* The off-diagonal elements of the tridiagonal matrix T: */
+/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */
+
+/* TAU (output) COMPLEX array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= 1. */
+/* For optimum performance LWORK >= N*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(n-1) . . . H(2) H(1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */
+/* A(1:i-1,i+1), and tau in TAU(i). */
+
+/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(1) H(2) . . . H(n-1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */
+/* and tau in TAU(i). */
+
+/* The contents of A on exit are illustrated by the following examples */
+/* with n = 5: */
+
+/* if UPLO = 'U': if UPLO = 'L': */
+
+/* ( d e v2 v3 v4 ) ( d ) */
+/* ( d e v3 v4 ) ( e d ) */
+/* ( d e v4 ) ( v1 e d ) */
+/* ( d e ) ( v1 v2 e d ) */
+/* ( d ) ( v1 v2 v3 e d ) */
+
+/* where d and e denote diagonal and off-diagonal elements of T, and vi */
+/* denotes an element of the vector defining H(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1;
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*lwork < 1 && ! lquery) {
+ *info = -9;
+ }
+
+ if (*info == 0) {
+
+/* Determine the block size. */
+
+ nb = ilaenv_(&c__1, "CHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHETRD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ work[1].r = 1.f, work[1].i = 0.f;
+ return 0;
+ }
+
+ nx = *n;
+ iws = 1;
+ if (nb > 1 && nb < *n) {
+
+/* Determine when to cross over from blocked to unblocked code */
+/* (last block is always handled by unblocked code). */
+
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__3, "CHETRD", uplo, n, &c_n1, &c_n1, &
+ c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *n) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *n;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: determine the */
+/* minimum value of NB, and reduce NB or force use of */
+/* unblocked code by setting NX = N. */
+
+/* Computing MAX */
+ i__1 = *lwork / ldwork;
+ nb = max(i__1,1);
+ nbmin = ilaenv_(&c__2, "CHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
+ if (nb < nbmin) {
+ nx = *n;
+ }
+ }
+ } else {
+ nx = *n;
+ }
+ } else {
+ nb = 1;
+ }
+
+ if (upper) {
+
+/* Reduce the upper triangle of A. */
+/* Columns 1:kk are handled by the unblocked method. */
+
+ kk = *n - (*n - nx + nb - 1) / nb * nb;
+ i__1 = kk + 1;
+ i__2 = -nb;
+ for (i__ = *n - nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+
+/* Reduce columns i:i+nb-1 to tridiagonal form and form the */
+/* matrix W which is needed to update the unreduced part of */
+/* the matrix */
+
+ i__3 = i__ + nb - 1;
+ clatrd_(uplo, &i__3, &nb, &a[a_offset], lda, &e[1], &tau[1], &
+ work[1], &ldwork);
+
+/* Update the unreduced submatrix A(1:i-1,1:i-1), using an */
+/* update of the form: A := A - V*W' - W*V' */
+
+ i__3 = i__ - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cher2k_(uplo, "No transpose", &i__3, &nb, &q__1, &a[i__ * a_dim1
+ + 1], lda, &work[1], &ldwork, &c_b23, &a[a_offset], lda);
+
+/* Copy superdiagonal elements back into A, and diagonal */
+/* elements into D */
+
+ i__3 = i__ + nb - 1;
+ for (j = i__; j <= i__3; ++j) {
+ i__4 = j - 1 + j * a_dim1;
+ i__5 = j - 1;
+ a[i__4].r = e[i__5], a[i__4].i = 0.f;
+ i__4 = j;
+ i__5 = j + j * a_dim1;
+ d__[i__4] = a[i__5].r;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Use unblocked code to reduce the last or only block */
+
+ chetd2_(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo);
+ } else {
+
+/* Reduce the lower triangle of A */
+
+ i__2 = *n - nx;
+ i__1 = nb;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
+
+/* Reduce columns i:i+nb-1 to tridiagonal form and form the */
+/* matrix W which is needed to update the unreduced part of */
+/* the matrix */
+
+ i__3 = *n - i__ + 1;
+ clatrd_(uplo, &i__3, &nb, &a[i__ + i__ * a_dim1], lda, &e[i__], &
+ tau[i__], &work[1], &ldwork);
+
+/* Update the unreduced submatrix A(i+nb:n,i+nb:n), using */
+/* an update of the form: A := A - V*W' - W*V' */
+
+ i__3 = *n - i__ - nb + 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cher2k_(uplo, "No transpose", &i__3, &nb, &q__1, &a[i__ + nb +
+ i__ * a_dim1], lda, &work[nb + 1], &ldwork, &c_b23, &a[
+ i__ + nb + (i__ + nb) * a_dim1], lda);
+
+/* Copy subdiagonal elements back into A, and diagonal */
+/* elements into D */
+
+ i__3 = i__ + nb - 1;
+ for (j = i__; j <= i__3; ++j) {
+ i__4 = j + 1 + j * a_dim1;
+ i__5 = j;
+ a[i__4].r = e[i__5], a[i__4].i = 0.f;
+ i__4 = j;
+ i__5 = j + j * a_dim1;
+ d__[i__4] = a[i__5].r;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Use unblocked code to reduce the last or only block */
+
+ i__1 = *n - i__ + 1;
+ chetd2_(uplo, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__],
+ &tau[i__], &iinfo);
+ }
+
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ return 0;
+
+/* End of CHETRD */
+
+} /* chetrd_ */
diff --git a/SRC/chetrf.c b/SRC/chetrf.c
new file mode 100644
index 0000000..75c17bb
--- /dev/null
+++ b/SRC/chetrf.c
@@ -0,0 +1,334 @@
+/* chetrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int chetrf_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *ipiv, complex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer j, k, kb, nb, iws;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ logical upper;
+ extern /* Subroutine */ int chetf2_(char *, integer *, complex *, integer
+ *, integer *, integer *), clahef_(char *, integer *,
+ integer *, integer *, complex *, integer *, integer *, complex *,
+ integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHETRF computes the factorization of a complex Hermitian matrix A */
+/* using the Bunch-Kaufman diagonal pivoting method. The form of the */
+/* factorization is */
+
+/* A = U*D*U**H or A = L*D*L**H */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, 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. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (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, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L (see below for further details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK >=1. For best performance */
+/* LWORK >= N*NB, where NB is the block size returned by ILAENV. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. 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. */
+
+/* Further Details */
+/* =============== */
+
+/* If UPLO = 'U', then A = U*D*U', where */
+/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
+/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
+/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I v 0 ) k-s */
+/* U(k) = ( 0 I 0 ) s */
+/* ( 0 0 I ) n-k */
+/* k-s s n-k */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
+/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
+/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
+
+/* If UPLO = 'L', then A = L*D*L', where */
+/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
+/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
+/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I 0 0 ) k-1 */
+/* L(k) = ( 0 I 0 ) s */
+/* ( 0 v I ) n-k-s+1 */
+/* k-1 s n-k-s+1 */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
+/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
+/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1;
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*lwork < 1 && ! lquery) {
+ *info = -7;
+ }
+
+ if (*info == 0) {
+
+/* Determine the block size */
+
+ nb = ilaenv_(&c__1, "CHETRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHETRF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = *n;
+ if (nb > 1 && nb < *n) {
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+/* Computing MAX */
+ i__1 = *lwork / ldwork;
+ nb = max(i__1,1);
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "CHETRF", uplo, n, &c_n1, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = 1;
+ }
+ if (nb < nbmin) {
+ nb = *n;
+ }
+
+ if (upper) {
+
+/* Factorize A as U*D*U' 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; */
+/* KB is either NB or NB-1, or K for the last block */
+
+ k = *n;
+L10:
+
+/* If K < 1, exit from loop */
+
+ if (k < 1) {
+ goto L40;
+ }
+
+ if (k > nb) {
+
+/* Factorize columns k-kb+1:k of A and use blocked code to */
+/* update columns 1:k-kb */
+
+ clahef_(uplo, &k, &nb, &kb, &a[a_offset], lda, &ipiv[1], &work[1],
+ n, &iinfo);
+ } else {
+
+/* Use unblocked code to factorize columns 1:k of A */
+
+ chetf2_(uplo, &k, &a[a_offset], lda, &ipiv[1], &iinfo);
+ kb = k;
+ }
+
+/* Set INFO on the first occurrence of a zero pivot */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kb;
+ goto L10;
+
+ } else {
+
+/* Factorize A as L*D*L' 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; */
+/* KB is either NB or NB-1, or N-K+1 for the last block */
+
+ k = 1;
+L20:
+
+/* If K > N, exit from loop */
+
+ if (k > *n) {
+ goto L40;
+ }
+
+ if (k <= *n - nb) {
+
+/* Factorize columns k:k+kb-1 of A and use blocked code to */
+/* update columns k+kb:n */
+
+ i__1 = *n - k + 1;
+ clahef_(uplo, &i__1, &nb, &kb, &a[k + k * a_dim1], lda, &ipiv[k],
+ &work[1], n, &iinfo);
+ } else {
+
+/* Use unblocked code to factorize columns k:n of A */
+
+ i__1 = *n - k + 1;
+ chetf2_(uplo, &i__1, &a[k + k * a_dim1], lda, &ipiv[k], &iinfo);
+ kb = *n - k + 1;
+ }
+
+/* Set INFO on the first occurrence of a zero pivot */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo + k - 1;
+ }
+
+/* Adjust IPIV */
+
+ i__1 = k + kb - 1;
+ for (j = k; j <= i__1; ++j) {
+ if (ipiv[j] > 0) {
+ ipiv[j] = ipiv[j] + k - 1;
+ } else {
+ ipiv[j] = ipiv[j] - k + 1;
+ }
+/* L30: */
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kb;
+ goto L20;
+
+ }
+
+L40:
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ return 0;
+
+/* End of CHETRF */
+
+} /* chetrf_ */
diff --git a/SRC/chetri.c b/SRC/chetri.c
new file mode 100644
index 0000000..ac9c6bf
--- /dev/null
+++ b/SRC/chetri.c
@@ -0,0 +1,510 @@
+/* chetri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b2 = {0.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int chetri_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *ipiv, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ real d__;
+ integer j, k;
+ real t, ak;
+ integer kp;
+ real akp1;
+ complex temp, akkp1;
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int chemv_(char *, integer *, complex *, complex *
+, integer *, complex *, integer *, complex *, complex *, integer *
+), ccopy_(integer *, complex *, integer *, complex *,
+ integer *), cswap_(integer *, complex *, integer *, complex *,
+ integer *);
+ integer kstep;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHETRI computes the inverse of a complex Hermitian indefinite matrix */
+/* A using the factorization A = U*D*U**H or A = L*D*L**H computed by */
+/* CHETRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**H; */
+/* = 'L': Lower triangular, form is A = L*D*L**H. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L as computed by CHETRF. */
+
+/* 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. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CHETRF. */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* INFO (output) 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. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHETRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ for (*info = *n; *info >= 1; --(*info)) {
+ i__1 = *info + *info * a_dim1;
+ if (ipiv[*info] > 0 && (a[i__1].r == 0.f && a[i__1].i == 0.f)) {
+ return 0;
+ }
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ i__2 = *info + *info * a_dim1;
+ if (ipiv[*info] > 0 && (a[i__2].r == 0.f && a[i__2].i == 0.f)) {
+ return 0;
+ }
+/* L20: */
+ }
+ }
+ *info = 0;
+
+ if (upper) {
+
+/* Compute inv(A) from the factorization A = U*D*U'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+L30:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L50;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ r__1 = 1.f / a[i__2].r;
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+
+/* Compute column K of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ ccopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ chemv_(uplo, &i__1, &q__1, &a[a_offset], lda, &work[1], &c__1,
+ &c_b2, &a[k * a_dim1 + 1], &c__1);
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ i__3 = k - 1;
+ cdotc_(&q__2, &i__3, &work[1], &c__1, &a[k * a_dim1 + 1], &
+ c__1);
+ r__1 = q__2.r;
+ q__1.r = a[i__2].r - r__1, q__1.i = a[i__2].i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ t = c_abs(&a[k + (k + 1) * a_dim1]);
+ i__1 = k + k * a_dim1;
+ ak = a[i__1].r / t;
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ akp1 = a[i__1].r / t;
+ i__1 = k + (k + 1) * a_dim1;
+ q__1.r = a[i__1].r / t, q__1.i = a[i__1].i / t;
+ akkp1.r = q__1.r, akkp1.i = q__1.i;
+ d__ = t * (ak * akp1 - 1.f);
+ i__1 = k + k * a_dim1;
+ r__1 = akp1 / d__;
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ r__1 = ak / d__;
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ i__1 = k + (k + 1) * a_dim1;
+ q__2.r = -akkp1.r, q__2.i = -akkp1.i;
+ q__1.r = q__2.r / d__, q__1.i = q__2.i / d__;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+
+/* Compute columns K and K+1 of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ ccopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ chemv_(uplo, &i__1, &q__1, &a[a_offset], lda, &work[1], &c__1,
+ &c_b2, &a[k * a_dim1 + 1], &c__1);
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ i__3 = k - 1;
+ cdotc_(&q__2, &i__3, &work[1], &c__1, &a[k * a_dim1 + 1], &
+ c__1);
+ r__1 = q__2.r;
+ q__1.r = a[i__2].r - r__1, q__1.i = a[i__2].i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = k + (k + 1) * a_dim1;
+ i__2 = k + (k + 1) * a_dim1;
+ i__3 = k - 1;
+ cdotc_(&q__2, &i__3, &a[k * a_dim1 + 1], &c__1, &a[(k + 1) *
+ a_dim1 + 1], &c__1);
+ q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = k - 1;
+ ccopy_(&i__1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], &
+ c__1);
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ chemv_(uplo, &i__1, &q__1, &a[a_offset], lda, &work[1], &c__1,
+ &c_b2, &a[(k + 1) * a_dim1 + 1], &c__1);
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ i__2 = k + 1 + (k + 1) * a_dim1;
+ i__3 = k - 1;
+ cdotc_(&q__2, &i__3, &work[1], &c__1, &a[(k + 1) * a_dim1 + 1]
+, &c__1);
+ r__1 = q__2.r;
+ q__1.r = a[i__2].r - r__1, q__1.i = a[i__2].i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ }
+ kstep = 2;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the leading */
+/* submatrix A(1:k+1,1:k+1) */
+
+ i__1 = kp - 1;
+ cswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &
+ c__1);
+ i__1 = k - 1;
+ for (j = kp + 1; j <= i__1; ++j) {
+ r_cnjg(&q__1, &a[j + k * a_dim1]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__2 = j + k * a_dim1;
+ r_cnjg(&q__1, &a[kp + j * a_dim1]);
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ i__2 = kp + j * a_dim1;
+ a[i__2].r = temp.r, a[i__2].i = temp.i;
+/* L40: */
+ }
+ i__1 = kp + k * a_dim1;
+ r_cnjg(&q__1, &a[kp + k * a_dim1]);
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = k + k * a_dim1;
+ temp.r = a[i__1].r, temp.i = a[i__1].i;
+ i__1 = k + k * a_dim1;
+ i__2 = kp + kp * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + kp * a_dim1;
+ a[i__1].r = temp.r, a[i__1].i = temp.i;
+ if (kstep == 2) {
+ i__1 = k + (k + 1) * a_dim1;
+ temp.r = a[i__1].r, temp.i = a[i__1].i;
+ i__1 = k + (k + 1) * a_dim1;
+ i__2 = kp + (k + 1) * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + (k + 1) * a_dim1;
+ a[i__1].r = temp.r, a[i__1].i = temp.i;
+ }
+ }
+
+ k += kstep;
+ goto L30;
+L50:
+
+ ;
+ } else {
+
+/* Compute inv(A) from the factorization A = L*D*L'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+L60:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L80;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ r__1 = 1.f / a[i__2].r;
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+
+/* Compute column K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ ccopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ chemv_(uplo, &i__1, &q__1, &a[k + 1 + (k + 1) * a_dim1], lda,
+ &work[1], &c__1, &c_b2, &a[k + 1 + k * a_dim1], &c__1);
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ i__3 = *n - k;
+ cdotc_(&q__2, &i__3, &work[1], &c__1, &a[k + 1 + k * a_dim1],
+ &c__1);
+ r__1 = q__2.r;
+ q__1.r = a[i__2].r - r__1, q__1.i = a[i__2].i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ t = c_abs(&a[k + (k - 1) * a_dim1]);
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ ak = a[i__1].r / t;
+ i__1 = k + k * a_dim1;
+ akp1 = a[i__1].r / t;
+ i__1 = k + (k - 1) * a_dim1;
+ q__1.r = a[i__1].r / t, q__1.i = a[i__1].i / t;
+ akkp1.r = q__1.r, akkp1.i = q__1.i;
+ d__ = t * (ak * akp1 - 1.f);
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ r__1 = akp1 / d__;
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ i__1 = k + k * a_dim1;
+ r__1 = ak / d__;
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ i__1 = k + (k - 1) * a_dim1;
+ q__2.r = -akkp1.r, q__2.i = -akkp1.i;
+ q__1.r = q__2.r / d__, q__1.i = q__2.i / d__;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+
+/* Compute columns K-1 and K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ ccopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ chemv_(uplo, &i__1, &q__1, &a[k + 1 + (k + 1) * a_dim1], lda,
+ &work[1], &c__1, &c_b2, &a[k + 1 + k * a_dim1], &c__1);
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ i__3 = *n - k;
+ cdotc_(&q__2, &i__3, &work[1], &c__1, &a[k + 1 + k * a_dim1],
+ &c__1);
+ r__1 = q__2.r;
+ q__1.r = a[i__2].r - r__1, q__1.i = a[i__2].i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = k + (k - 1) * a_dim1;
+ i__2 = k + (k - 1) * a_dim1;
+ i__3 = *n - k;
+ cdotc_(&q__2, &i__3, &a[k + 1 + k * a_dim1], &c__1, &a[k + 1
+ + (k - 1) * a_dim1], &c__1);
+ q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = *n - k;
+ ccopy_(&i__1, &a[k + 1 + (k - 1) * a_dim1], &c__1, &work[1], &
+ c__1);
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ chemv_(uplo, &i__1, &q__1, &a[k + 1 + (k + 1) * a_dim1], lda,
+ &work[1], &c__1, &c_b2, &a[k + 1 + (k - 1) * a_dim1],
+ &c__1);
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ i__2 = k - 1 + (k - 1) * a_dim1;
+ i__3 = *n - k;
+ cdotc_(&q__2, &i__3, &work[1], &c__1, &a[k + 1 + (k - 1) *
+ a_dim1], &c__1);
+ r__1 = q__2.r;
+ q__1.r = a[i__2].r - r__1, q__1.i = a[i__2].i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ }
+ kstep = 2;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the trailing */
+/* submatrix A(k-1:n,k-1:n) */
+
+ if (kp < *n) {
+ i__1 = *n - kp;
+ cswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + kp *
+ a_dim1], &c__1);
+ }
+ i__1 = kp - 1;
+ for (j = k + 1; j <= i__1; ++j) {
+ r_cnjg(&q__1, &a[j + k * a_dim1]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__2 = j + k * a_dim1;
+ r_cnjg(&q__1, &a[kp + j * a_dim1]);
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ i__2 = kp + j * a_dim1;
+ a[i__2].r = temp.r, a[i__2].i = temp.i;
+/* L70: */
+ }
+ i__1 = kp + k * a_dim1;
+ r_cnjg(&q__1, &a[kp + k * a_dim1]);
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = k + k * a_dim1;
+ temp.r = a[i__1].r, temp.i = a[i__1].i;
+ i__1 = k + k * a_dim1;
+ i__2 = kp + kp * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + kp * a_dim1;
+ a[i__1].r = temp.r, a[i__1].i = temp.i;
+ if (kstep == 2) {
+ i__1 = k + (k - 1) * a_dim1;
+ temp.r = a[i__1].r, temp.i = a[i__1].i;
+ i__1 = k + (k - 1) * a_dim1;
+ i__2 = kp + (k - 1) * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + (k - 1) * a_dim1;
+ a[i__1].r = temp.r, a[i__1].i = temp.i;
+ }
+ }
+
+ k -= kstep;
+ goto L60;
+L80:
+ ;
+ }
+
+ return 0;
+
+/* End of CHETRI */
+
+} /* chetri_ */
diff --git a/SRC/chetrs.c b/SRC/chetrs.c
new file mode 100644
index 0000000..fcb0eef
--- /dev/null
+++ b/SRC/chetrs.c
@@ -0,0 +1,528 @@
+/* chetrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int chetrs_(char *uplo, integer *n, integer *nrhs, complex *
+ a, integer *lda, integer *ipiv, complex *b, integer *ldb, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer j, k;
+ real s;
+ complex ak, bk;
+ integer kp;
+ complex akm1, bkm1, akm1k;
+ extern logical lsame_(char *, char *);
+ complex denom;
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *), cgeru_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *),
+ cswap_(integer *, complex *, integer *, complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
+ csscal_(integer *, real *, complex *, integer *), xerbla_(char *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHETRS solves a system of linear equations A*X = B with a complex */
+/* Hermitian matrix A using the factorization A = U*D*U**H or */
+/* A = L*D*L**H computed by CHETRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**H; */
+/* = 'L': Lower triangular, form is A = L*D*L**H. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by CHETRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CHETRF. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHETRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B, where A = U*D*U'. */
+
+/* First solve U*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+L10:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L30;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &a[k * a_dim1 + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = k + k * a_dim1;
+ s = 1.f / a[i__1].r;
+ csscal_(nrhs, &s, &b[k + b_dim1], ldb);
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K-1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k - 1) {
+ cswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ i__1 = k - 2;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &a[k * a_dim1 + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+ i__1 = k - 2;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &a[(k - 1) * a_dim1 + 1], &c__1, &b[k
+ - 1 + b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = k - 1 + k * a_dim1;
+ akm1k.r = a[i__1].r, akm1k.i = a[i__1].i;
+ c_div(&q__1, &a[k - 1 + (k - 1) * a_dim1], &akm1k);
+ akm1.r = q__1.r, akm1.i = q__1.i;
+ r_cnjg(&q__2, &akm1k);
+ c_div(&q__1, &a[k + k * a_dim1], &q__2);
+ ak.r = q__1.r, ak.i = q__1.i;
+ q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i +
+ akm1.i * ak.r;
+ q__1.r = q__2.r - 1.f, q__1.i = q__2.i - 0.f;
+ denom.r = q__1.r, denom.i = q__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ c_div(&q__1, &b[k - 1 + j * b_dim1], &akm1k);
+ bkm1.r = q__1.r, bkm1.i = q__1.i;
+ r_cnjg(&q__2, &akm1k);
+ c_div(&q__1, &b[k + j * b_dim1], &q__2);
+ bk.r = q__1.r, bk.i = q__1.i;
+ i__2 = k - 1 + j * b_dim1;
+ q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r *
+ bkm1.i + ak.i * bkm1.r;
+ q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
+ c_div(&q__1, &q__2, &denom);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + j * b_dim1;
+ q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r *
+ bk.i + akm1.i * bk.r;
+ q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
+ c_div(&q__1, &q__2, &denom);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L20: */
+ }
+ k += -2;
+ }
+
+ goto L10;
+L30:
+
+/* Next solve U'*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+L40:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L50;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(U'(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k > 1) {
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b[b_offset]
+, ldb, &a[k * a_dim1 + 1], &c__1, &c_b1, &b[k +
+ b_dim1], ldb);
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ }
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ if (k > 1) {
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b[b_offset]
+, ldb, &a[k * a_dim1 + 1], &c__1, &c_b1, &b[k +
+ b_dim1], ldb);
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+
+ clacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b[b_offset]
+, ldb, &a[(k + 1) * a_dim1 + 1], &c__1, &c_b1, &b[k +
+ 1 + b_dim1], ldb);
+ clacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
+ }
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ k += 2;
+ }
+
+ goto L40;
+L50:
+
+ ;
+ } else {
+
+/* Solve A*X = B, where A = L*D*L'. */
+
+/* First solve L*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+L60:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L80;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &a[k + 1 + k * a_dim1], &c__1, &b[
+ k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = k + k * a_dim1;
+ s = 1.f / a[i__1].r;
+ csscal_(nrhs, &s, &b[k + b_dim1], ldb);
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K+1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k + 1) {
+ cswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ if (k < *n - 1) {
+ i__1 = *n - k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &a[k + 2 + k * a_dim1], &c__1, &b[
+ k + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &a[k + 2 + (k + 1) * a_dim1], &
+ c__1, &b[k + 1 + b_dim1], ldb, &b[k + 2 + b_dim1],
+ ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = k + 1 + k * a_dim1;
+ akm1k.r = a[i__1].r, akm1k.i = a[i__1].i;
+ r_cnjg(&q__2, &akm1k);
+ c_div(&q__1, &a[k + k * a_dim1], &q__2);
+ akm1.r = q__1.r, akm1.i = q__1.i;
+ c_div(&q__1, &a[k + 1 + (k + 1) * a_dim1], &akm1k);
+ ak.r = q__1.r, ak.i = q__1.i;
+ q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i +
+ akm1.i * ak.r;
+ q__1.r = q__2.r - 1.f, q__1.i = q__2.i - 0.f;
+ denom.r = q__1.r, denom.i = q__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ r_cnjg(&q__2, &akm1k);
+ c_div(&q__1, &b[k + j * b_dim1], &q__2);
+ bkm1.r = q__1.r, bkm1.i = q__1.i;
+ c_div(&q__1, &b[k + 1 + j * b_dim1], &akm1k);
+ bk.r = q__1.r, bk.i = q__1.i;
+ i__2 = k + j * b_dim1;
+ q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r *
+ bkm1.i + ak.i * bkm1.r;
+ q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
+ c_div(&q__1, &q__2, &denom);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r *
+ bk.i + akm1.i * bk.r;
+ q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
+ c_div(&q__1, &q__2, &denom);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L70: */
+ }
+ k += 2;
+ }
+
+ goto L60;
+L80:
+
+/* Next solve L'*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+L90:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L100;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(L'(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b[k + 1 +
+ b_dim1], ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, &
+ b[k + b_dim1], ldb);
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ }
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ if (k < *n) {
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b[k + 1 +
+ b_dim1], ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, &
+ b[k + b_dim1], ldb);
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+
+ clacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b[k + 1 +
+ b_dim1], ldb, &a[k + 1 + (k - 1) * a_dim1], &c__1, &
+ c_b1, &b[k - 1 + b_dim1], ldb);
+ clacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
+ }
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ k += -2;
+ }
+
+ goto L90;
+L100:
+ ;
+ }
+
+ return 0;
+
+/* End of CHETRS */
+
+} /* chetrs_ */
diff --git a/SRC/chfrk.c b/SRC/chfrk.c
new file mode 100644
index 0000000..d980a7e
--- /dev/null
+++ b/SRC/chfrk.c
@@ -0,0 +1,530 @@
+/* chfrk.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int chfrk_(char *transr, char *uplo, char *trans, integer *n,
+ integer *k, real *alpha, complex *a, integer *lda, real *beta,
+ complex *c__)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ complex q__1;
+
+ /* Local variables */
+ integer j, n1, n2, nk, info;
+ complex cbeta;
+ logical normaltransr;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), cherk_(char *,
+ char *, integer *, integer *, real *, complex *, integer *, real *
+, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical lower;
+ complex calpha;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nisodd, notrans;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Level 3 BLAS like routine for C in RFP Format. */
+
+/* CHFRK performs one of the Hermitian rank--k operations */
+
+/* C := alpha*A*conjg( A' ) + beta*C, */
+
+/* or */
+
+/* C := alpha*conjg( A' )*A + beta*C, */
+
+/* where alpha and beta are real scalars, C is an n--by--n Hermitian */
+/* matrix and A is an n--by--k matrix in the first case and a k--by--n */
+/* matrix in the second case. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANSR - (input) CHARACTER. */
+/* = 'N': The Normal Form of RFP A is stored; */
+/* = 'C': The Conjugate-transpose Form of RFP A is stored. */
+
+/* UPLO - (input) CHARACTER. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array C is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of C */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of C */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* TRANS - (input) CHARACTER. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C. */
+
+/* TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C. */
+
+/* Unchanged on exit. */
+
+/* N - (input) INTEGER. */
+/* On entry, N specifies the order of the matrix C. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* K - (input) INTEGER. */
+/* On entry with TRANS = 'N' or 'n', K specifies the number */
+/* of columns of the matrix A, and on entry with */
+/* TRANS = 'C' or 'c', K specifies the number of rows of the */
+/* matrix A. K must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - (input) REAL. */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - (input) COMPLEX array of DIMENSION ( LDA, ka ), where KA */
+/* is K when TRANS = 'N' or 'n', and is N otherwise. Before */
+/* entry with TRANS = 'N' or 'n', the leading N--by--K part of */
+/* the array A must contain the matrix A, otherwise the leading */
+/* K--by--N part of the array A must contain the matrix A. */
+/* Unchanged on exit. */
+
+/* LDA - (input) INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When TRANS = 'N' or 'n' */
+/* then LDA must be at least max( 1, n ), otherwise LDA must */
+/* be at least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* BETA - (input) REAL. */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+/* C - (input/output) COMPLEX array, dimension ( N*(N+1)/2 ). */
+/* On entry, the matrix A in RFP Format. RFP Format is */
+/* described by TRANSR, UPLO and N. Note that the imaginary */
+/* parts of the diagonal elements need not be set, they are */
+/* assumed to be zero, and on exit they are set to zero. */
+
+/* Arguments */
+/* ========== */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --c__;
+
+ /* Function Body */
+ info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ notrans = lsame_(trans, "N");
+
+ if (notrans) {
+ nrowa = *n;
+ } else {
+ nrowa = *k;
+ }
+
+ if (! normaltransr && ! lsame_(transr, "C")) {
+ info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ info = -2;
+ } else if (! notrans && ! lsame_(trans, "C")) {
+ info = -3;
+ } else if (*n < 0) {
+ info = -4;
+ } else if (*k < 0) {
+ info = -5;
+ } else if (*lda < max(1,nrowa)) {
+ info = -8;
+ }
+ if (info != 0) {
+ i__1 = -info;
+ xerbla_("CHFRK ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+/* The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not */
+/* done (it is in CHERK for example) and left in the general case. */
+
+ if (*n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) {
+ return 0;
+ }
+
+ if (*alpha == 0.f && *beta == 0.f) {
+ i__1 = *n * (*n + 1) / 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ c__[i__2].r = 0.f, c__[i__2].i = 0.f;
+ }
+ return 0;
+ }
+
+ q__1.r = *alpha, q__1.i = 0.f;
+ calpha.r = q__1.r, calpha.i = q__1.i;
+ q__1.r = *beta, q__1.i = 0.f;
+ cbeta.r = q__1.r, cbeta.i = q__1.i;
+
+/* C is N-by-N. */
+/* If N is odd, set NISODD = .TRUE., and N1 and N2. */
+/* If N is even, NISODD = .FALSE., and NK. */
+
+ if (*n % 2 == 0) {
+ nisodd = FALSE_;
+ nk = *n / 2;
+ } else {
+ nisodd = TRUE_;
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+ }
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* N is odd, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' */
+
+ cherk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[1], n);
+ cherk_("U", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda,
+ beta, &c__[*n + 1], n);
+ cgemm_("N", "C", &n2, &n1, k, &calpha, &a[n1 + 1 + a_dim1]
+, lda, &a[a_dim1 + 1], lda, &cbeta, &c__[n1 + 1],
+ n);
+
+ } else {
+
+/* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'C' */
+
+ cherk_("L", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[1], n);
+ cherk_("U", "C", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1],
+ lda, beta, &c__[*n + 1], n)
+ ;
+ cgemm_("C", "N", &n2, &n1, k, &calpha, &a[(n1 + 1) *
+ a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, &
+ c__[n1 + 1], n);
+
+ }
+
+ } else {
+
+/* N is odd, TRANSR = 'N', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' */
+
+ cherk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[n2 + 1], n);
+ cherk_("U", "N", &n2, k, alpha, &a[n2 + a_dim1], lda,
+ beta, &c__[n1 + 1], n);
+ cgemm_("N", "C", &n1, &n2, k, &calpha, &a[a_dim1 + 1],
+ lda, &a[n2 + a_dim1], lda, &cbeta, &c__[1], n);
+
+ } else {
+
+/* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'C' */
+
+ cherk_("L", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[n2 + 1], n);
+ cherk_("U", "C", &n2, k, alpha, &a[n2 * a_dim1 + 1], lda,
+ beta, &c__[n1 + 1], n);
+ cgemm_("C", "N", &n1, &n2, k, &calpha, &a[a_dim1 + 1],
+ lda, &a[n2 * a_dim1 + 1], lda, &cbeta, &c__[1], n);
+
+ }
+
+ }
+
+ } else {
+
+/* N is odd, and TRANSR = 'C' */
+
+ if (lower) {
+
+/* N is odd, TRANSR = 'C', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'N' */
+
+ cherk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[1], &n1);
+ cherk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda,
+ beta, &c__[2], &n1);
+ cgemm_("N", "C", &n1, &n2, k, &calpha, &a[a_dim1 + 1],
+ lda, &a[n1 + 1 + a_dim1], lda, &cbeta, &c__[n1 *
+ n1 + 1], &n1);
+
+ } else {
+
+/* N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'C' */
+
+ cherk_("U", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[1], &n1);
+ cherk_("L", "C", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1],
+ lda, beta, &c__[2], &n1);
+ cgemm_("C", "N", &n1, &n2, k, &calpha, &a[a_dim1 + 1],
+ lda, &a[(n1 + 1) * a_dim1 + 1], lda, &cbeta, &c__[
+ n1 * n1 + 1], &n1);
+
+ }
+
+ } else {
+
+/* N is odd, TRANSR = 'C', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'N' */
+
+ cherk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[n2 * n2 + 1], &n2);
+ cherk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda,
+ beta, &c__[n1 * n2 + 1], &n2);
+ cgemm_("N", "C", &n2, &n1, k, &calpha, &a[n1 + 1 + a_dim1]
+, lda, &a[a_dim1 + 1], lda, &cbeta, &c__[1], &n2);
+
+ } else {
+
+/* N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'C' */
+
+ cherk_("U", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[n2 * n2 + 1], &n2);
+ cherk_("L", "C", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1],
+ lda, beta, &c__[n1 * n2 + 1], &n2);
+ cgemm_("C", "N", &n2, &n1, k, &calpha, &a[(n1 + 1) *
+ a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, &
+ c__[1], &n2);
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* N is even, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' */
+
+ i__1 = *n + 1;
+ cherk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[2], &i__1);
+ i__1 = *n + 1;
+ cherk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
+ beta, &c__[1], &i__1);
+ i__1 = *n + 1;
+ cgemm_("N", "C", &nk, &nk, k, &calpha, &a[nk + 1 + a_dim1]
+, lda, &a[a_dim1 + 1], lda, &cbeta, &c__[nk + 2],
+ &i__1);
+
+ } else {
+
+/* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'C' */
+
+ i__1 = *n + 1;
+ cherk_("L", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[2], &i__1);
+ i__1 = *n + 1;
+ cherk_("U", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
+ lda, beta, &c__[1], &i__1);
+ i__1 = *n + 1;
+ cgemm_("C", "N", &nk, &nk, k, &calpha, &a[(nk + 1) *
+ a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, &
+ c__[nk + 2], &i__1);
+
+ }
+
+ } else {
+
+/* N is even, TRANSR = 'N', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' */
+
+ i__1 = *n + 1;
+ cherk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk + 2], &i__1);
+ i__1 = *n + 1;
+ cherk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
+ beta, &c__[nk + 1], &i__1);
+ i__1 = *n + 1;
+ cgemm_("N", "C", &nk, &nk, k, &calpha, &a[a_dim1 + 1],
+ lda, &a[nk + 1 + a_dim1], lda, &cbeta, &c__[1], &
+ i__1);
+
+ } else {
+
+/* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'C' */
+
+ i__1 = *n + 1;
+ cherk_("L", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk + 2], &i__1);
+ i__1 = *n + 1;
+ cherk_("U", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
+ lda, beta, &c__[nk + 1], &i__1);
+ i__1 = *n + 1;
+ cgemm_("C", "N", &nk, &nk, k, &calpha, &a[a_dim1 + 1],
+ lda, &a[(nk + 1) * a_dim1 + 1], lda, &cbeta, &c__[
+ 1], &i__1);
+
+ }
+
+ }
+
+ } else {
+
+/* N is even, and TRANSR = 'C' */
+
+ if (lower) {
+
+/* N is even, TRANSR = 'C', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'N' */
+
+ cherk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk + 1], &nk);
+ cherk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
+ beta, &c__[1], &nk);
+ cgemm_("N", "C", &nk, &nk, k, &calpha, &a[a_dim1 + 1],
+ lda, &a[nk + 1 + a_dim1], lda, &cbeta, &c__[(nk +
+ 1) * nk + 1], &nk);
+
+ } else {
+
+/* N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'C' */
+
+ cherk_("U", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk + 1], &nk);
+ cherk_("L", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
+ lda, beta, &c__[1], &nk);
+ cgemm_("C", "N", &nk, &nk, k, &calpha, &a[a_dim1 + 1],
+ lda, &a[(nk + 1) * a_dim1 + 1], lda, &cbeta, &c__[
+ (nk + 1) * nk + 1], &nk);
+
+ }
+
+ } else {
+
+/* N is even, TRANSR = 'C', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'N' */
+
+ cherk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk * (nk + 1) + 1], &nk);
+ cherk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
+ beta, &c__[nk * nk + 1], &nk);
+ cgemm_("N", "C", &nk, &nk, k, &calpha, &a[nk + 1 + a_dim1]
+, lda, &a[a_dim1 + 1], lda, &cbeta, &c__[1], &nk);
+
+ } else {
+
+/* N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'C' */
+
+ cherk_("U", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk * (nk + 1) + 1], &nk);
+ cherk_("L", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
+ lda, beta, &c__[nk * nk + 1], &nk);
+ cgemm_("C", "N", &nk, &nk, k, &calpha, &a[(nk + 1) *
+ a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, &
+ c__[1], &nk);
+
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of CHFRK */
+
+} /* chfrk_ */
diff --git a/SRC/chgeqz.c b/SRC/chgeqz.c
new file mode 100644
index 0000000..a728058
--- /dev/null
+++ b/SRC/chgeqz.c
@@ -0,0 +1,1143 @@
+/* chgeqz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int chgeqz_(char *job, char *compq, char *compz, integer *n,
+ integer *ilo, integer *ihi, complex *h__, integer *ldh, complex *t,
+ integer *ldt, complex *alpha, complex *beta, complex *q, integer *ldq,
+ complex *z__, integer *ldz, complex *work, integer *lwork, real *
+ rwork, integer *info)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, q_dim1, q_offset, t_dim1, t_offset, z_dim1,
+ z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1, r__2, r__3, r__4, r__5, r__6;
+ complex q__1, q__2, q__3, q__4, q__5, q__6;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+ void r_cnjg(complex *, complex *);
+ double r_imag(complex *);
+ void c_div(complex *, complex *, complex *), pow_ci(complex *, complex *,
+ integer *), c_sqrt(complex *, complex *);
+
+ /* Local variables */
+ real c__;
+ integer j;
+ complex s, t1;
+ integer jc, in;
+ complex u12;
+ integer jr;
+ complex ad11, ad12, ad21, ad22;
+ integer jch;
+ logical ilq, ilz;
+ real ulp;
+ complex abi22;
+ real absb, atol, btol, temp;
+ extern /* Subroutine */ int crot_(integer *, complex *, integer *,
+ complex *, integer *, real *, complex *);
+ real temp2;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ complex ctemp;
+ integer iiter, ilast, jiter;
+ real anorm, bnorm;
+ integer maxit;
+ complex shift;
+ real tempr;
+ complex ctemp2, ctemp3;
+ logical ilazr2;
+ real ascale, bscale;
+ complex signbc;
+ extern doublereal slamch_(char *), clanhs_(char *, integer *,
+ complex *, integer *, real *);
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), clartg_(complex *,
+ complex *, real *, complex *, complex *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ complex eshift;
+ logical ilschr;
+ integer icompq, ilastm;
+ complex rtdisc;
+ integer ischur;
+ logical ilazro;
+ integer icompz, ifirst, ifrstm, istart;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHGEQZ computes the eigenvalues of a complex matrix pair (H,T), */
+/* where H is an upper Hessenberg matrix and T is upper triangular, */
+/* using the single-shift QZ method. */
+/* Matrix pairs of this type are produced by the reduction to */
+/* generalized upper Hessenberg form of a complex matrix pair (A,B): */
+
+/* A = Q1*H*Z1**H, B = Q1*T*Z1**H, */
+
+/* as computed by CGGHRD. */
+
+/* If JOB='S', then the Hessenberg-triangular pair (H,T) is */
+/* also reduced to generalized Schur form, */
+
+/* H = Q*S*Z**H, T = Q*P*Z**H, */
+
+/* where Q and Z are unitary matrices and S and P are upper triangular. */
+
+/* Optionally, the unitary matrix Q from the generalized Schur */
+/* factorization may be postmultiplied into an input matrix Q1, and the */
+/* unitary matrix Z may be postmultiplied into an input matrix Z1. */
+/* If Q1 and Z1 are the unitary matrices from CGGHRD that reduced */
+/* the matrix pair (A,B) to generalized Hessenberg form, then the output */
+/* matrices Q1*Q and Z1*Z are the unitary factors from the generalized */
+/* Schur factorization of (A,B): */
+
+/* A = (Q1*Q)*S*(Z1*Z)**H, B = (Q1*Q)*P*(Z1*Z)**H. */
+
+/* To avoid overflow, eigenvalues of the matrix pair (H,T) */
+/* (equivalently, of (A,B)) are computed as a pair of complex values */
+/* (alpha,beta). If beta is nonzero, lambda = alpha / beta is an */
+/* eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP) */
+/* A*x = lambda*B*x */
+/* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the */
+/* alternate form of the GNEP */
+/* mu*A*y = B*y. */
+/* The values of alpha and beta for the i-th eigenvalue can be read */
+/* directly from the generalized Schur form: alpha = S(i,i), */
+/* beta = P(i,i). */
+
+/* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix */
+/* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), */
+/* pp. 241--256. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* = 'E': Compute eigenvalues only; */
+/* = 'S': Computer eigenvalues and the Schur form. */
+
+/* COMPQ (input) CHARACTER*1 */
+/* = 'N': Left Schur vectors (Q) are not computed; */
+/* = 'I': Q is initialized to the unit matrix and the matrix Q */
+/* of left Schur vectors of (H,T) is returned; */
+/* = 'V': Q must contain a unitary matrix Q1 on entry and */
+/* the product Q1*Q is returned. */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': Right Schur vectors (Z) are not computed; */
+/* = 'I': Q is initialized to the unit matrix and the matrix Z */
+/* of right Schur vectors of (H,T) is returned; */
+/* = 'V': Z must contain a unitary matrix Z1 on entry and */
+/* the product Z1*Z is returned. */
+
+/* N (input) INTEGER */
+/* The order of the matrices H, T, Q, and Z. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* ILO and IHI mark the rows and columns of H which are in */
+/* Hessenberg form. It is assumed that A is already upper */
+/* triangular in rows and columns 1:ILO-1 and IHI+1:N. */
+/* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. */
+
+/* H (input/output) COMPLEX array, dimension (LDH, N) */
+/* On entry, the N-by-N upper Hessenberg matrix H. */
+/* On exit, if JOB = 'S', H contains the upper triangular */
+/* matrix S from the generalized Schur factorization. */
+/* If JOB = 'E', the diagonal of H matches that of S, but */
+/* the rest of H is unspecified. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH >= max( 1, N ). */
+
+/* T (input/output) COMPLEX array, dimension (LDT, N) */
+/* On entry, the N-by-N upper triangular matrix T. */
+/* On exit, if JOB = 'S', T contains the upper triangular */
+/* matrix P from the generalized Schur factorization. */
+/* If JOB = 'E', the diagonal of T matches that of P, but */
+/* the rest of T is unspecified. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= max( 1, N ). */
+
+/* ALPHA (output) COMPLEX array, dimension (N) */
+/* The complex scalars alpha that define the eigenvalues of */
+/* GNEP. ALPHA(i) = S(i,i) in the generalized Schur */
+/* factorization. */
+
+/* BETA (output) COMPLEX array, dimension (N) */
+/* The real non-negative scalars beta that define the */
+/* eigenvalues of GNEP. BETA(i) = P(i,i) in the generalized */
+/* Schur factorization. */
+
+/* Together, the quantities alpha = ALPHA(j) and beta = BETA(j) */
+/* represent the j-th eigenvalue of the matrix pair (A,B), in */
+/* one of the forms lambda = alpha/beta or mu = beta/alpha. */
+/* Since either lambda or mu may overflow, they should not, */
+/* in general, be computed. */
+
+/* Q (input/output) COMPLEX array, dimension (LDQ, N) */
+/* On entry, if COMPZ = 'V', the unitary matrix Q1 used in the */
+/* reduction of (A,B) to generalized Hessenberg form. */
+/* On exit, if COMPZ = 'I', the unitary matrix of left Schur */
+/* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of */
+/* left Schur vectors of (A,B). */
+/* Not referenced if COMPZ = 'N'. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= 1. */
+/* If COMPQ='V' or 'I', then LDQ >= N. */
+
+/* Z (input/output) COMPLEX array, dimension (LDZ, N) */
+/* On entry, if COMPZ = 'V', the unitary matrix Z1 used in the */
+/* reduction of (A,B) to generalized Hessenberg form. */
+/* On exit, if COMPZ = 'I', the unitary matrix of right Schur */
+/* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of */
+/* right Schur vectors of (A,B). */
+/* Not referenced if COMPZ = 'N'. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1. */
+/* If COMPZ='V' or 'I', then LDZ >= N. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+
+/* 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. */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* = 1,...,N: the QZ iteration did not converge. (H,T) is not */
+/* in Schur form, but ALPHA(i) and BETA(i), */
+/* i=INFO+1,...,N should be correct. */
+/* = N+1,...,2*N: the shift calculation failed. (H,T) is not */
+/* in Schur form, but ALPHA(i) and BETA(i), */
+/* i=INFO-N+1,...,N should be correct. */
+
+/* Further Details */
+/* =============== */
+
+/* We assume that complex ABS works as long as its value is less than */
+/* overflow. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode JOB, COMPQ, COMPZ */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ --alpha;
+ --beta;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ if (lsame_(job, "E")) {
+ ilschr = FALSE_;
+ ischur = 1;
+ } else if (lsame_(job, "S")) {
+ ilschr = TRUE_;
+ ischur = 2;
+ } else {
+ ischur = 0;
+ }
+
+ if (lsame_(compq, "N")) {
+ ilq = FALSE_;
+ icompq = 1;
+ } else if (lsame_(compq, "V")) {
+ ilq = TRUE_;
+ icompq = 2;
+ } else if (lsame_(compq, "I")) {
+ ilq = TRUE_;
+ icompq = 3;
+ } else {
+ icompq = 0;
+ }
+
+ if (lsame_(compz, "N")) {
+ ilz = FALSE_;
+ icompz = 1;
+ } else if (lsame_(compz, "V")) {
+ ilz = TRUE_;
+ icompz = 2;
+ } else if (lsame_(compz, "I")) {
+ ilz = TRUE_;
+ icompz = 3;
+ } else {
+ icompz = 0;
+ }
+
+/* Check Argument Values */
+
+ *info = 0;
+ i__1 = max(1,*n);
+ work[1].r = (real) i__1, work[1].i = 0.f;
+ lquery = *lwork == -1;
+ if (ischur == 0) {
+ *info = -1;
+ } else if (icompq == 0) {
+ *info = -2;
+ } else if (icompz == 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ilo < 1) {
+ *info = -5;
+ } else if (*ihi > *n || *ihi < *ilo - 1) {
+ *info = -6;
+ } else if (*ldh < *n) {
+ *info = -8;
+ } else if (*ldt < *n) {
+ *info = -10;
+ } else if (*ldq < 1 || ilq && *ldq < *n) {
+ *info = -14;
+ } else if (*ldz < 1 || ilz && *ldz < *n) {
+ *info = -16;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -18;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHGEQZ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+/* WORK( 1 ) = CMPLX( 1 ) */
+ if (*n <= 0) {
+ work[1].r = 1.f, work[1].i = 0.f;
+ return 0;
+ }
+
+/* Initialize Q and Z */
+
+ if (icompq == 3) {
+ claset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
+ }
+ if (icompz == 3) {
+ claset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
+ }
+
+/* Machine Constants */
+
+ in = *ihi + 1 - *ilo;
+ safmin = slamch_("S");
+ ulp = slamch_("E") * slamch_("B");
+ anorm = clanhs_("F", &in, &h__[*ilo + *ilo * h_dim1], ldh, &rwork[1]);
+ bnorm = clanhs_("F", &in, &t[*ilo + *ilo * t_dim1], ldt, &rwork[1]);
+/* Computing MAX */
+ r__1 = safmin, r__2 = ulp * anorm;
+ atol = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = safmin, r__2 = ulp * bnorm;
+ btol = dmax(r__1,r__2);
+ ascale = 1.f / dmax(safmin,anorm);
+ bscale = 1.f / dmax(safmin,bnorm);
+
+
+/* Set Eigenvalues IHI+1:N */
+
+ i__1 = *n;
+ for (j = *ihi + 1; j <= i__1; ++j) {
+ absb = c_abs(&t[j + j * t_dim1]);
+ if (absb > safmin) {
+ i__2 = j + j * t_dim1;
+ q__2.r = t[i__2].r / absb, q__2.i = t[i__2].i / absb;
+ r_cnjg(&q__1, &q__2);
+ signbc.r = q__1.r, signbc.i = q__1.i;
+ i__2 = j + j * t_dim1;
+ t[i__2].r = absb, t[i__2].i = 0.f;
+ if (ilschr) {
+ i__2 = j - 1;
+ cscal_(&i__2, &signbc, &t[j * t_dim1 + 1], &c__1);
+ cscal_(&j, &signbc, &h__[j * h_dim1 + 1], &c__1);
+ } else {
+ i__2 = j + j * h_dim1;
+ i__3 = j + j * h_dim1;
+ q__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i,
+ q__1.i = h__[i__3].r * signbc.i + h__[i__3].i *
+ signbc.r;
+ h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
+ }
+ if (ilz) {
+ cscal_(n, &signbc, &z__[j * z_dim1 + 1], &c__1);
+ }
+ } else {
+ i__2 = j + j * t_dim1;
+ t[i__2].r = 0.f, t[i__2].i = 0.f;
+ }
+ i__2 = j;
+ i__3 = j + j * h_dim1;
+ alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
+ i__2 = j;
+ i__3 = j + j * t_dim1;
+ beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
+/* L10: */
+ }
+
+/* If IHI < ILO, skip QZ steps */
+
+ if (*ihi < *ilo) {
+ goto L190;
+ }
+
+/* MAIN QZ ITERATION LOOP */
+
+/* Initialize dynamic indices */
+
+/* Eigenvalues ILAST+1:N have been found. */
+/* Column operations modify rows IFRSTM:whatever */
+/* Row operations modify columns whatever:ILASTM */
+
+/* If only eigenvalues are being computed, then */
+/* IFRSTM is the row of the last splitting row above row ILAST; */
+/* this is always at least ILO. */
+/* IITER counts iterations since the last eigenvalue was found, */
+/* to tell when to use an extraordinary shift. */
+/* MAXIT is the maximum number of QZ sweeps allowed. */
+
+ ilast = *ihi;
+ if (ilschr) {
+ ifrstm = 1;
+ ilastm = *n;
+ } else {
+ ifrstm = *ilo;
+ ilastm = *ihi;
+ }
+ iiter = 0;
+ eshift.r = 0.f, eshift.i = 0.f;
+ maxit = (*ihi - *ilo + 1) * 30;
+
+ i__1 = maxit;
+ for (jiter = 1; jiter <= i__1; ++jiter) {
+
+/* Check for too many iterations. */
+
+ if (jiter > maxit) {
+ goto L180;
+ }
+
+/* Split the matrix if possible. */
+
+/* Two tests: */
+/* 1: H(j,j-1)=0 or j=ILO */
+/* 2: T(j,j)=0 */
+
+/* Special case: j=ILAST */
+
+ if (ilast == *ilo) {
+ goto L60;
+ } else {
+ i__2 = ilast + (ilast - 1) * h_dim1;
+ if ((r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&h__[ilast
+ + (ilast - 1) * h_dim1]), dabs(r__2)) <= atol) {
+ i__2 = ilast + (ilast - 1) * h_dim1;
+ h__[i__2].r = 0.f, h__[i__2].i = 0.f;
+ goto L60;
+ }
+ }
+
+ if (c_abs(&t[ilast + ilast * t_dim1]) <= btol) {
+ i__2 = ilast + ilast * t_dim1;
+ t[i__2].r = 0.f, t[i__2].i = 0.f;
+ goto L50;
+ }
+
+/* General case: j<ILAST */
+
+ i__2 = *ilo;
+ for (j = ilast - 1; j >= i__2; --j) {
+
+/* Test 1: for H(j,j-1)=0 or j=ILO */
+
+ if (j == *ilo) {
+ ilazro = TRUE_;
+ } else {
+ i__3 = j + (j - 1) * h_dim1;
+ if ((r__1 = h__[i__3].r, dabs(r__1)) + (r__2 = r_imag(&h__[j
+ + (j - 1) * h_dim1]), dabs(r__2)) <= atol) {
+ i__3 = j + (j - 1) * h_dim1;
+ h__[i__3].r = 0.f, h__[i__3].i = 0.f;
+ ilazro = TRUE_;
+ } else {
+ ilazro = FALSE_;
+ }
+ }
+
+/* Test 2: for T(j,j)=0 */
+
+ if (c_abs(&t[j + j * t_dim1]) < btol) {
+ i__3 = j + j * t_dim1;
+ t[i__3].r = 0.f, t[i__3].i = 0.f;
+
+/* Test 1a: Check for 2 consecutive small subdiagonals in A */
+
+ ilazr2 = FALSE_;
+ if (! ilazro) {
+ i__3 = j + (j - 1) * h_dim1;
+ i__4 = j + 1 + j * h_dim1;
+ i__5 = j + j * h_dim1;
+ if (((r__1 = h__[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ h__[j + (j - 1) * h_dim1]), dabs(r__2))) * (
+ ascale * ((r__3 = h__[i__4].r, dabs(r__3)) + (
+ r__4 = r_imag(&h__[j + 1 + j * h_dim1]), dabs(
+ r__4)))) <= ((r__5 = h__[i__5].r, dabs(r__5)) + (
+ r__6 = r_imag(&h__[j + j * h_dim1]), dabs(r__6)))
+ * (ascale * atol)) {
+ ilazr2 = TRUE_;
+ }
+ }
+
+/* If both tests pass (1 & 2), i.e., the leading diagonal */
+/* element of B in the block is zero, split a 1x1 block off */
+/* at the top. (I.e., at the J-th row/column) The leading */
+/* diagonal element of the remainder can also be zero, so */
+/* this may have to be done repeatedly. */
+
+ if (ilazro || ilazr2) {
+ i__3 = ilast - 1;
+ for (jch = j; jch <= i__3; ++jch) {
+ i__4 = jch + jch * h_dim1;
+ ctemp.r = h__[i__4].r, ctemp.i = h__[i__4].i;
+ clartg_(&ctemp, &h__[jch + 1 + jch * h_dim1], &c__, &
+ s, &h__[jch + jch * h_dim1]);
+ i__4 = jch + 1 + jch * h_dim1;
+ h__[i__4].r = 0.f, h__[i__4].i = 0.f;
+ i__4 = ilastm - jch;
+ crot_(&i__4, &h__[jch + (jch + 1) * h_dim1], ldh, &
+ h__[jch + 1 + (jch + 1) * h_dim1], ldh, &c__,
+ &s);
+ i__4 = ilastm - jch;
+ crot_(&i__4, &t[jch + (jch + 1) * t_dim1], ldt, &t[
+ jch + 1 + (jch + 1) * t_dim1], ldt, &c__, &s);
+ if (ilq) {
+ r_cnjg(&q__1, &s);
+ crot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1)
+ * q_dim1 + 1], &c__1, &c__, &q__1);
+ }
+ if (ilazr2) {
+ i__4 = jch + (jch - 1) * h_dim1;
+ i__5 = jch + (jch - 1) * h_dim1;
+ q__1.r = c__ * h__[i__5].r, q__1.i = c__ * h__[
+ i__5].i;
+ h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
+ }
+ ilazr2 = FALSE_;
+ i__4 = jch + 1 + (jch + 1) * t_dim1;
+ if ((r__1 = t[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
+ t[jch + 1 + (jch + 1) * t_dim1]), dabs(r__2))
+ >= btol) {
+ if (jch + 1 >= ilast) {
+ goto L60;
+ } else {
+ ifirst = jch + 1;
+ goto L70;
+ }
+ }
+ i__4 = jch + 1 + (jch + 1) * t_dim1;
+ t[i__4].r = 0.f, t[i__4].i = 0.f;
+/* L20: */
+ }
+ goto L50;
+ } else {
+
+/* Only test 2 passed -- chase the zero to T(ILAST,ILAST) */
+/* Then process as in the case T(ILAST,ILAST)=0 */
+
+ i__3 = ilast - 1;
+ for (jch = j; jch <= i__3; ++jch) {
+ i__4 = jch + (jch + 1) * t_dim1;
+ ctemp.r = t[i__4].r, ctemp.i = t[i__4].i;
+ clartg_(&ctemp, &t[jch + 1 + (jch + 1) * t_dim1], &
+ c__, &s, &t[jch + (jch + 1) * t_dim1]);
+ i__4 = jch + 1 + (jch + 1) * t_dim1;
+ t[i__4].r = 0.f, t[i__4].i = 0.f;
+ if (jch < ilastm - 1) {
+ i__4 = ilastm - jch - 1;
+ crot_(&i__4, &t[jch + (jch + 2) * t_dim1], ldt, &
+ t[jch + 1 + (jch + 2) * t_dim1], ldt, &
+ c__, &s);
+ }
+ i__4 = ilastm - jch + 2;
+ crot_(&i__4, &h__[jch + (jch - 1) * h_dim1], ldh, &
+ h__[jch + 1 + (jch - 1) * h_dim1], ldh, &c__,
+ &s);
+ if (ilq) {
+ r_cnjg(&q__1, &s);
+ crot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1)
+ * q_dim1 + 1], &c__1, &c__, &q__1);
+ }
+ i__4 = jch + 1 + jch * h_dim1;
+ ctemp.r = h__[i__4].r, ctemp.i = h__[i__4].i;
+ clartg_(&ctemp, &h__[jch + 1 + (jch - 1) * h_dim1], &
+ c__, &s, &h__[jch + 1 + jch * h_dim1]);
+ i__4 = jch + 1 + (jch - 1) * h_dim1;
+ h__[i__4].r = 0.f, h__[i__4].i = 0.f;
+ i__4 = jch + 1 - ifrstm;
+ crot_(&i__4, &h__[ifrstm + jch * h_dim1], &c__1, &h__[
+ ifrstm + (jch - 1) * h_dim1], &c__1, &c__, &s)
+ ;
+ i__4 = jch - ifrstm;
+ crot_(&i__4, &t[ifrstm + jch * t_dim1], &c__1, &t[
+ ifrstm + (jch - 1) * t_dim1], &c__1, &c__, &s)
+ ;
+ if (ilz) {
+ crot_(n, &z__[jch * z_dim1 + 1], &c__1, &z__[(jch
+ - 1) * z_dim1 + 1], &c__1, &c__, &s);
+ }
+/* L30: */
+ }
+ goto L50;
+ }
+ } else if (ilazro) {
+
+/* Only test 1 passed -- work on J:ILAST */
+
+ ifirst = j;
+ goto L70;
+ }
+
+/* Neither test passed -- try next J */
+
+/* L40: */
+ }
+
+/* (Drop-through is "impossible") */
+
+ *info = (*n << 1) + 1;
+ goto L210;
+
+/* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a */
+/* 1x1 block. */
+
+L50:
+ i__2 = ilast + ilast * h_dim1;
+ ctemp.r = h__[i__2].r, ctemp.i = h__[i__2].i;
+ clartg_(&ctemp, &h__[ilast + (ilast - 1) * h_dim1], &c__, &s, &h__[
+ ilast + ilast * h_dim1]);
+ i__2 = ilast + (ilast - 1) * h_dim1;
+ h__[i__2].r = 0.f, h__[i__2].i = 0.f;
+ i__2 = ilast - ifrstm;
+ crot_(&i__2, &h__[ifrstm + ilast * h_dim1], &c__1, &h__[ifrstm + (
+ ilast - 1) * h_dim1], &c__1, &c__, &s);
+ i__2 = ilast - ifrstm;
+ crot_(&i__2, &t[ifrstm + ilast * t_dim1], &c__1, &t[ifrstm + (ilast -
+ 1) * t_dim1], &c__1, &c__, &s);
+ if (ilz) {
+ crot_(n, &z__[ilast * z_dim1 + 1], &c__1, &z__[(ilast - 1) *
+ z_dim1 + 1], &c__1, &c__, &s);
+ }
+
+/* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA */
+
+L60:
+ absb = c_abs(&t[ilast + ilast * t_dim1]);
+ if (absb > safmin) {
+ i__2 = ilast + ilast * t_dim1;
+ q__2.r = t[i__2].r / absb, q__2.i = t[i__2].i / absb;
+ r_cnjg(&q__1, &q__2);
+ signbc.r = q__1.r, signbc.i = q__1.i;
+ i__2 = ilast + ilast * t_dim1;
+ t[i__2].r = absb, t[i__2].i = 0.f;
+ if (ilschr) {
+ i__2 = ilast - ifrstm;
+ cscal_(&i__2, &signbc, &t[ifrstm + ilast * t_dim1], &c__1);
+ i__2 = ilast + 1 - ifrstm;
+ cscal_(&i__2, &signbc, &h__[ifrstm + ilast * h_dim1], &c__1);
+ } else {
+ i__2 = ilast + ilast * h_dim1;
+ i__3 = ilast + ilast * h_dim1;
+ q__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i,
+ q__1.i = h__[i__3].r * signbc.i + h__[i__3].i *
+ signbc.r;
+ h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
+ }
+ if (ilz) {
+ cscal_(n, &signbc, &z__[ilast * z_dim1 + 1], &c__1);
+ }
+ } else {
+ i__2 = ilast + ilast * t_dim1;
+ t[i__2].r = 0.f, t[i__2].i = 0.f;
+ }
+ i__2 = ilast;
+ i__3 = ilast + ilast * h_dim1;
+ alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
+ i__2 = ilast;
+ i__3 = ilast + ilast * t_dim1;
+ beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
+
+/* Go to next block -- exit if finished. */
+
+ --ilast;
+ if (ilast < *ilo) {
+ goto L190;
+ }
+
+/* Reset counters */
+
+ iiter = 0;
+ eshift.r = 0.f, eshift.i = 0.f;
+ if (! ilschr) {
+ ilastm = ilast;
+ if (ifrstm > ilast) {
+ ifrstm = *ilo;
+ }
+ }
+ goto L160;
+
+/* QZ step */
+
+/* This iteration only involves rows/columns IFIRST:ILAST. We */
+/* assume IFIRST < ILAST, and that the diagonal of B is non-zero. */
+
+L70:
+ ++iiter;
+ if (! ilschr) {
+ ifrstm = ifirst;
+ }
+
+/* Compute the Shift. */
+
+/* At this point, IFIRST < ILAST, and the diagonal elements of */
+/* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in */
+/* magnitude) */
+
+ if (iiter / 10 * 10 != iiter) {
+
+/* The Wilkinson shift (AEP p.512), i.e., the eigenvalue of */
+/* the bottom-right 2x2 block of A inv(B) which is nearest to */
+/* the bottom-right element. */
+
+/* We factor B as U*D, where U has unit diagonals, and */
+/* compute (A*inv(D))*inv(U). */
+
+ i__2 = ilast - 1 + ilast * t_dim1;
+ q__2.r = bscale * t[i__2].r, q__2.i = bscale * t[i__2].i;
+ i__3 = ilast + ilast * t_dim1;
+ q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
+ c_div(&q__1, &q__2, &q__3);
+ u12.r = q__1.r, u12.i = q__1.i;
+ i__2 = ilast - 1 + (ilast - 1) * h_dim1;
+ q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
+ i__3 = ilast - 1 + (ilast - 1) * t_dim1;
+ q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
+ c_div(&q__1, &q__2, &q__3);
+ ad11.r = q__1.r, ad11.i = q__1.i;
+ i__2 = ilast + (ilast - 1) * h_dim1;
+ q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
+ i__3 = ilast - 1 + (ilast - 1) * t_dim1;
+ q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
+ c_div(&q__1, &q__2, &q__3);
+ ad21.r = q__1.r, ad21.i = q__1.i;
+ i__2 = ilast - 1 + ilast * h_dim1;
+ q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
+ i__3 = ilast + ilast * t_dim1;
+ q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
+ c_div(&q__1, &q__2, &q__3);
+ ad12.r = q__1.r, ad12.i = q__1.i;
+ i__2 = ilast + ilast * h_dim1;
+ q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
+ i__3 = ilast + ilast * t_dim1;
+ q__3.r = bscale * t[i__3].r, q__3.i = bscale * t[i__3].i;
+ c_div(&q__1, &q__2, &q__3);
+ ad22.r = q__1.r, ad22.i = q__1.i;
+ q__2.r = u12.r * ad21.r - u12.i * ad21.i, q__2.i = u12.r * ad21.i
+ + u12.i * ad21.r;
+ q__1.r = ad22.r - q__2.r, q__1.i = ad22.i - q__2.i;
+ abi22.r = q__1.r, abi22.i = q__1.i;
+
+ q__2.r = ad11.r + abi22.r, q__2.i = ad11.i + abi22.i;
+ q__1.r = q__2.r * .5f, q__1.i = q__2.i * .5f;
+ t1.r = q__1.r, t1.i = q__1.i;
+ pow_ci(&q__4, &t1, &c__2);
+ q__5.r = ad12.r * ad21.r - ad12.i * ad21.i, q__5.i = ad12.r *
+ ad21.i + ad12.i * ad21.r;
+ q__3.r = q__4.r + q__5.r, q__3.i = q__4.i + q__5.i;
+ q__6.r = ad11.r * ad22.r - ad11.i * ad22.i, q__6.i = ad11.r *
+ ad22.i + ad11.i * ad22.r;
+ q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i;
+ c_sqrt(&q__1, &q__2);
+ rtdisc.r = q__1.r, rtdisc.i = q__1.i;
+ q__1.r = t1.r - abi22.r, q__1.i = t1.i - abi22.i;
+ q__2.r = t1.r - abi22.r, q__2.i = t1.i - abi22.i;
+ temp = q__1.r * rtdisc.r + r_imag(&q__2) * r_imag(&rtdisc);
+ if (temp <= 0.f) {
+ q__1.r = t1.r + rtdisc.r, q__1.i = t1.i + rtdisc.i;
+ shift.r = q__1.r, shift.i = q__1.i;
+ } else {
+ q__1.r = t1.r - rtdisc.r, q__1.i = t1.i - rtdisc.i;
+ shift.r = q__1.r, shift.i = q__1.i;
+ }
+ } else {
+
+/* Exceptional shift. Chosen for no particularly good reason. */
+
+ i__2 = ilast - 1 + ilast * h_dim1;
+ q__4.r = ascale * h__[i__2].r, q__4.i = ascale * h__[i__2].i;
+ i__3 = ilast - 1 + (ilast - 1) * t_dim1;
+ q__5.r = bscale * t[i__3].r, q__5.i = bscale * t[i__3].i;
+ c_div(&q__3, &q__4, &q__5);
+ r_cnjg(&q__2, &q__3);
+ q__1.r = eshift.r + q__2.r, q__1.i = eshift.i + q__2.i;
+ eshift.r = q__1.r, eshift.i = q__1.i;
+ shift.r = eshift.r, shift.i = eshift.i;
+ }
+
+/* Now check for two consecutive small subdiagonals. */
+
+ i__2 = ifirst + 1;
+ for (j = ilast - 1; j >= i__2; --j) {
+ istart = j;
+ i__3 = j + j * h_dim1;
+ q__2.r = ascale * h__[i__3].r, q__2.i = ascale * h__[i__3].i;
+ i__4 = j + j * t_dim1;
+ q__4.r = bscale * t[i__4].r, q__4.i = bscale * t[i__4].i;
+ q__3.r = shift.r * q__4.r - shift.i * q__4.i, q__3.i = shift.r *
+ q__4.i + shift.i * q__4.r;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ temp = (r__1 = ctemp.r, dabs(r__1)) + (r__2 = r_imag(&ctemp),
+ dabs(r__2));
+ i__3 = j + 1 + j * h_dim1;
+ temp2 = ascale * ((r__1 = h__[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&h__[j + 1 + j * h_dim1]), dabs(r__2)));
+ tempr = dmax(temp,temp2);
+ if (tempr < 1.f && tempr != 0.f) {
+ temp /= tempr;
+ temp2 /= tempr;
+ }
+ i__3 = j + (j - 1) * h_dim1;
+ if (((r__1 = h__[i__3].r, dabs(r__1)) + (r__2 = r_imag(&h__[j + (
+ j - 1) * h_dim1]), dabs(r__2))) * temp2 <= temp * atol) {
+ goto L90;
+ }
+/* L80: */
+ }
+
+ istart = ifirst;
+ i__2 = ifirst + ifirst * h_dim1;
+ q__2.r = ascale * h__[i__2].r, q__2.i = ascale * h__[i__2].i;
+ i__3 = ifirst + ifirst * t_dim1;
+ q__4.r = bscale * t[i__3].r, q__4.i = bscale * t[i__3].i;
+ q__3.r = shift.r * q__4.r - shift.i * q__4.i, q__3.i = shift.r *
+ q__4.i + shift.i * q__4.r;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+L90:
+
+/* Do an implicit-shift QZ sweep. */
+
+/* Initial Q */
+
+ i__2 = istart + 1 + istart * h_dim1;
+ q__1.r = ascale * h__[i__2].r, q__1.i = ascale * h__[i__2].i;
+ ctemp2.r = q__1.r, ctemp2.i = q__1.i;
+ clartg_(&ctemp, &ctemp2, &c__, &s, &ctemp3);
+
+/* Sweep */
+
+ i__2 = ilast - 1;
+ for (j = istart; j <= i__2; ++j) {
+ if (j > istart) {
+ i__3 = j + (j - 1) * h_dim1;
+ ctemp.r = h__[i__3].r, ctemp.i = h__[i__3].i;
+ clartg_(&ctemp, &h__[j + 1 + (j - 1) * h_dim1], &c__, &s, &
+ h__[j + (j - 1) * h_dim1]);
+ i__3 = j + 1 + (j - 1) * h_dim1;
+ h__[i__3].r = 0.f, h__[i__3].i = 0.f;
+ }
+
+ i__3 = ilastm;
+ for (jc = j; jc <= i__3; ++jc) {
+ i__4 = j + jc * h_dim1;
+ q__2.r = c__ * h__[i__4].r, q__2.i = c__ * h__[i__4].i;
+ i__5 = j + 1 + jc * h_dim1;
+ q__3.r = s.r * h__[i__5].r - s.i * h__[i__5].i, q__3.i = s.r *
+ h__[i__5].i + s.i * h__[i__5].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__4 = j + 1 + jc * h_dim1;
+ r_cnjg(&q__4, &s);
+ q__3.r = -q__4.r, q__3.i = -q__4.i;
+ i__5 = j + jc * h_dim1;
+ q__2.r = q__3.r * h__[i__5].r - q__3.i * h__[i__5].i, q__2.i =
+ q__3.r * h__[i__5].i + q__3.i * h__[i__5].r;
+ i__6 = j + 1 + jc * h_dim1;
+ q__5.r = c__ * h__[i__6].r, q__5.i = c__ * h__[i__6].i;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+ h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
+ i__4 = j + jc * h_dim1;
+ h__[i__4].r = ctemp.r, h__[i__4].i = ctemp.i;
+ i__4 = j + jc * t_dim1;
+ q__2.r = c__ * t[i__4].r, q__2.i = c__ * t[i__4].i;
+ i__5 = j + 1 + jc * t_dim1;
+ q__3.r = s.r * t[i__5].r - s.i * t[i__5].i, q__3.i = s.r * t[
+ i__5].i + s.i * t[i__5].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ ctemp2.r = q__1.r, ctemp2.i = q__1.i;
+ i__4 = j + 1 + jc * t_dim1;
+ r_cnjg(&q__4, &s);
+ q__3.r = -q__4.r, q__3.i = -q__4.i;
+ i__5 = j + jc * t_dim1;
+ q__2.r = q__3.r * t[i__5].r - q__3.i * t[i__5].i, q__2.i =
+ q__3.r * t[i__5].i + q__3.i * t[i__5].r;
+ i__6 = j + 1 + jc * t_dim1;
+ q__5.r = c__ * t[i__6].r, q__5.i = c__ * t[i__6].i;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+ t[i__4].r = q__1.r, t[i__4].i = q__1.i;
+ i__4 = j + jc * t_dim1;
+ t[i__4].r = ctemp2.r, t[i__4].i = ctemp2.i;
+/* L100: */
+ }
+ if (ilq) {
+ i__3 = *n;
+ for (jr = 1; jr <= i__3; ++jr) {
+ i__4 = jr + j * q_dim1;
+ q__2.r = c__ * q[i__4].r, q__2.i = c__ * q[i__4].i;
+ r_cnjg(&q__4, &s);
+ i__5 = jr + (j + 1) * q_dim1;
+ q__3.r = q__4.r * q[i__5].r - q__4.i * q[i__5].i, q__3.i =
+ q__4.r * q[i__5].i + q__4.i * q[i__5].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__4 = jr + (j + 1) * q_dim1;
+ q__3.r = -s.r, q__3.i = -s.i;
+ i__5 = jr + j * q_dim1;
+ q__2.r = q__3.r * q[i__5].r - q__3.i * q[i__5].i, q__2.i =
+ q__3.r * q[i__5].i + q__3.i * q[i__5].r;
+ i__6 = jr + (j + 1) * q_dim1;
+ q__4.r = c__ * q[i__6].r, q__4.i = c__ * q[i__6].i;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ q[i__4].r = q__1.r, q[i__4].i = q__1.i;
+ i__4 = jr + j * q_dim1;
+ q[i__4].r = ctemp.r, q[i__4].i = ctemp.i;
+/* L110: */
+ }
+ }
+
+ i__3 = j + 1 + (j + 1) * t_dim1;
+ ctemp.r = t[i__3].r, ctemp.i = t[i__3].i;
+ clartg_(&ctemp, &t[j + 1 + j * t_dim1], &c__, &s, &t[j + 1 + (j +
+ 1) * t_dim1]);
+ i__3 = j + 1 + j * t_dim1;
+ t[i__3].r = 0.f, t[i__3].i = 0.f;
+
+/* Computing MIN */
+ i__4 = j + 2;
+ i__3 = min(i__4,ilast);
+ for (jr = ifrstm; jr <= i__3; ++jr) {
+ i__4 = jr + (j + 1) * h_dim1;
+ q__2.r = c__ * h__[i__4].r, q__2.i = c__ * h__[i__4].i;
+ i__5 = jr + j * h_dim1;
+ q__3.r = s.r * h__[i__5].r - s.i * h__[i__5].i, q__3.i = s.r *
+ h__[i__5].i + s.i * h__[i__5].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__4 = jr + j * h_dim1;
+ r_cnjg(&q__4, &s);
+ q__3.r = -q__4.r, q__3.i = -q__4.i;
+ i__5 = jr + (j + 1) * h_dim1;
+ q__2.r = q__3.r * h__[i__5].r - q__3.i * h__[i__5].i, q__2.i =
+ q__3.r * h__[i__5].i + q__3.i * h__[i__5].r;
+ i__6 = jr + j * h_dim1;
+ q__5.r = c__ * h__[i__6].r, q__5.i = c__ * h__[i__6].i;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+ h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
+ i__4 = jr + (j + 1) * h_dim1;
+ h__[i__4].r = ctemp.r, h__[i__4].i = ctemp.i;
+/* L120: */
+ }
+ i__3 = j;
+ for (jr = ifrstm; jr <= i__3; ++jr) {
+ i__4 = jr + (j + 1) * t_dim1;
+ q__2.r = c__ * t[i__4].r, q__2.i = c__ * t[i__4].i;
+ i__5 = jr + j * t_dim1;
+ q__3.r = s.r * t[i__5].r - s.i * t[i__5].i, q__3.i = s.r * t[
+ i__5].i + s.i * t[i__5].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__4 = jr + j * t_dim1;
+ r_cnjg(&q__4, &s);
+ q__3.r = -q__4.r, q__3.i = -q__4.i;
+ i__5 = jr + (j + 1) * t_dim1;
+ q__2.r = q__3.r * t[i__5].r - q__3.i * t[i__5].i, q__2.i =
+ q__3.r * t[i__5].i + q__3.i * t[i__5].r;
+ i__6 = jr + j * t_dim1;
+ q__5.r = c__ * t[i__6].r, q__5.i = c__ * t[i__6].i;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+ t[i__4].r = q__1.r, t[i__4].i = q__1.i;
+ i__4 = jr + (j + 1) * t_dim1;
+ t[i__4].r = ctemp.r, t[i__4].i = ctemp.i;
+/* L130: */
+ }
+ if (ilz) {
+ i__3 = *n;
+ for (jr = 1; jr <= i__3; ++jr) {
+ i__4 = jr + (j + 1) * z_dim1;
+ q__2.r = c__ * z__[i__4].r, q__2.i = c__ * z__[i__4].i;
+ i__5 = jr + j * z_dim1;
+ q__3.r = s.r * z__[i__5].r - s.i * z__[i__5].i, q__3.i =
+ s.r * z__[i__5].i + s.i * z__[i__5].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__4 = jr + j * z_dim1;
+ r_cnjg(&q__4, &s);
+ q__3.r = -q__4.r, q__3.i = -q__4.i;
+ i__5 = jr + (j + 1) * z_dim1;
+ q__2.r = q__3.r * z__[i__5].r - q__3.i * z__[i__5].i,
+ q__2.i = q__3.r * z__[i__5].i + q__3.i * z__[i__5]
+ .r;
+ i__6 = jr + j * z_dim1;
+ q__5.r = c__ * z__[i__6].r, q__5.i = c__ * z__[i__6].i;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+ z__[i__4].r = q__1.r, z__[i__4].i = q__1.i;
+ i__4 = jr + (j + 1) * z_dim1;
+ z__[i__4].r = ctemp.r, z__[i__4].i = ctemp.i;
+/* L140: */
+ }
+ }
+/* L150: */
+ }
+
+L160:
+
+/* L170: */
+ ;
+ }
+
+/* Drop-through = non-convergence */
+
+L180:
+ *info = ilast;
+ goto L210;
+
+/* Successful completion of all QZ steps */
+
+L190:
+
+/* Set Eigenvalues 1:ILO-1 */
+
+ i__1 = *ilo - 1;
+ for (j = 1; j <= i__1; ++j) {
+ absb = c_abs(&t[j + j * t_dim1]);
+ if (absb > safmin) {
+ i__2 = j + j * t_dim1;
+ q__2.r = t[i__2].r / absb, q__2.i = t[i__2].i / absb;
+ r_cnjg(&q__1, &q__2);
+ signbc.r = q__1.r, signbc.i = q__1.i;
+ i__2 = j + j * t_dim1;
+ t[i__2].r = absb, t[i__2].i = 0.f;
+ if (ilschr) {
+ i__2 = j - 1;
+ cscal_(&i__2, &signbc, &t[j * t_dim1 + 1], &c__1);
+ cscal_(&j, &signbc, &h__[j * h_dim1 + 1], &c__1);
+ } else {
+ i__2 = j + j * h_dim1;
+ i__3 = j + j * h_dim1;
+ q__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i,
+ q__1.i = h__[i__3].r * signbc.i + h__[i__3].i *
+ signbc.r;
+ h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
+ }
+ if (ilz) {
+ cscal_(n, &signbc, &z__[j * z_dim1 + 1], &c__1);
+ }
+ } else {
+ i__2 = j + j * t_dim1;
+ t[i__2].r = 0.f, t[i__2].i = 0.f;
+ }
+ i__2 = j;
+ i__3 = j + j * h_dim1;
+ alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
+ i__2 = j;
+ i__3 = j + j * t_dim1;
+ beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
+/* L200: */
+ }
+
+/* Normal Termination */
+
+ *info = 0;
+
+/* Exit (other than argument error) -- return optimal workspace size */
+
+L210:
+ q__1.r = (real) (*n), q__1.i = 0.f;
+ work[1].r = q__1.r, work[1].i = q__1.i;
+ return 0;
+
+/* End of CHGEQZ */
+
+} /* chgeqz_ */
diff --git a/SRC/chla_transtype.c b/SRC/chla_transtype.c
new file mode 100644
index 0000000..f616fbf
--- /dev/null
+++ b/SRC/chla_transtype.c
@@ -0,0 +1,62 @@
+/* chla_transtype.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Character */ VOID chla_transtype__(char *ret_val, ftnlen ret_val_len,
+ integer *trans)
+{
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* October 2008 */
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This subroutine translates from a BLAST-specified integer constant to */
+/* the character string specifying a transposition operation. */
+
+/* CHLA_TRANSTYPE returns an CHARACTER*1. If CHLA_TRANSTYPE is 'X', */
+/* then input is not an integer indicating a transposition operator. */
+/* Otherwise CHLA_TRANSTYPE returns the constant value corresponding to */
+/* TRANS. */
+
+/* Arguments */
+/* ========= */
+/* TRANS (input) INTEGER */
+/* Specifies the form of the system of equations: */
+/* = BLAS_NO_TRANS = 111 : No Transpose */
+/* = BLAS_TRANS = 112 : Transpose */
+/* = BLAS_CONJ_TRANS = 113 : Conjugate Transpose */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Executable Statements .. */
+ if (*trans == 111) {
+ *(unsigned char *)ret_val = 'N';
+ } else if (*trans == 112) {
+ *(unsigned char *)ret_val = 'T';
+ } else if (*trans == 113) {
+ *(unsigned char *)ret_val = 'C';
+ } else {
+ *(unsigned char *)ret_val = 'X';
+ }
+ return ;
+
+/* End of CHLA_TRANSTYPE */
+
+} /* chla_transtype__ */
diff --git a/SRC/chpcon.c b/SRC/chpcon.c
new file mode 100644
index 0000000..8fdf9f3
--- /dev/null
+++ b/SRC/chpcon.c
@@ -0,0 +1,195 @@
+/* chpcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int chpcon_(char *uplo, integer *n, complex *ap, integer *
+ ipiv, real *anorm, real *rcond, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, ip, kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *), xerbla_(char *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int chptrs_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHPCON estimates the reciprocal of the condition number of a complex */
+/* Hermitian packed matrix A using the factorization A = U*D*U**H or */
+/* A = L*D*L**H computed by CHPTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**H; */
+/* = 'L': Lower triangular, form is A = L*D*L**H. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by CHPTRF, stored as a */
+/* packed triangular matrix. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CHPTRF. */
+
+/* ANORM (input) REAL */
+/* The 1-norm of the original matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --work;
+ --ipiv;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*anorm < 0.f) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHPCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.f;
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ } else if (*anorm <= 0.f) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ ip = *n * (*n + 1) / 2;
+ for (i__ = *n; i__ >= 1; --i__) {
+ i__1 = ip;
+ if (ipiv[i__] > 0 && (ap[i__1].r == 0.f && ap[i__1].i == 0.f)) {
+ return 0;
+ }
+ ip -= i__;
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ ip = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ip;
+ if (ipiv[i__] > 0 && (ap[i__2].r == 0.f && ap[i__2].i == 0.f)) {
+ return 0;
+ }
+ ip = ip + *n - i__ + 1;
+/* L20: */
+ }
+ }
+
+/* Estimate the 1-norm of the inverse. */
+
+ kase = 0;
+L30:
+ clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+
+/* Multiply by inv(L*D*L') or inv(U*D*U'). */
+
+ chptrs_(uplo, n, &c__1, &ap[1], &ipiv[1], &work[1], n, info);
+ goto L30;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / ainvnm / *anorm;
+ }
+
+ return 0;
+
+/* End of CHPCON */
+
+} /* chpcon_ */
diff --git a/SRC/chpev.c b/SRC/chpev.c
new file mode 100644
index 0000000..12442c0
--- /dev/null
+++ b/SRC/chpev.c
@@ -0,0 +1,249 @@
+/* chpev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int chpev_(char *jobz, char *uplo, integer *n, complex *ap,
+ real *w, complex *z__, integer *ldz, complex *work, real *rwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real eps;
+ integer inde;
+ real anrm;
+ integer imax;
+ real rmin, rmax, sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ logical wantz;
+ integer iscale;
+ extern doublereal clanhp_(char *, char *, integer *, complex *, real *), slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ integer indtau;
+ extern /* Subroutine */ int chptrd_(char *, integer *, complex *, real *,
+ real *, complex *, integer *);
+ integer indrwk, indwrk;
+ extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *,
+ complex *, integer *, real *, integer *), cupgtr_(char *,
+ integer *, complex *, complex *, complex *, integer *, complex *,
+ integer *), ssterf_(integer *, real *, real *, integer *);
+ real smlnum;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHPEV computes all the eigenvalues and, optionally, eigenvectors of a */
+/* complex Hermitian matrix in packed storage. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, AP is overwritten by values generated during the */
+/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */
+/* and first superdiagonal of the tridiagonal matrix T overwrite */
+/* the corresponding elements of A, and if UPLO = 'L', the */
+/* diagonal and first subdiagonal of T overwrite the */
+/* corresponding elements of A. */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
+/* eigenvectors of the matrix A, with the i-th column of Z */
+/* holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) COMPLEX array, dimension (max(1, 2*N-1)) */
+
+/* RWORK (workspace) REAL array, dimension (max(1, 3*N-2)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of an intermediate tridiagonal */
+/* form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lsame_(uplo, "L") || lsame_(uplo,
+ "U"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -7;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHPEV ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ w[1] = ap[1].r;
+ rwork[1] = 1.f;
+ if (wantz) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1.f, z__[i__1].i = 0.f;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = clanhp_("M", uplo, n, &ap[1], &rwork[1]);
+ iscale = 0;
+ if (anrm > 0.f && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ i__1 = *n * (*n + 1) / 2;
+ csscal_(&i__1, &sigma, &ap[1], &c__1);
+ }
+
+/* Call CHPTRD to reduce Hermitian packed matrix to tridiagonal form. */
+
+ inde = 1;
+ indtau = 1;
+ chptrd_(uplo, n, &ap[1], &w[1], &rwork[inde], &work[indtau], &iinfo);
+
+/* For eigenvalues only, call SSTERF. For eigenvectors, first call */
+/* CUPGTR to generate the orthogonal matrix, then call CSTEQR. */
+
+ if (! wantz) {
+ ssterf_(n, &w[1], &rwork[inde], info);
+ } else {
+ indwrk = indtau + *n;
+ cupgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &work[
+ indwrk], &iinfo);
+ indrwk = inde + *n;
+ csteqr_(jobz, n, &w[1], &rwork[inde], &z__[z_offset], ldz, &rwork[
+ indrwk], info);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *n;
+ } else {
+ imax = *info - 1;
+ }
+ r__1 = 1.f / sigma;
+ sscal_(&imax, &r__1, &w[1], &c__1);
+ }
+
+ return 0;
+
+/* End of CHPEV */
+
+} /* chpev_ */
diff --git a/SRC/chpevd.c b/SRC/chpevd.c
new file mode 100644
index 0000000..e69b3f0
--- /dev/null
+++ b/SRC/chpevd.c
@@ -0,0 +1,346 @@
+/* chpevd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int chpevd_(char *jobz, char *uplo, integer *n, complex *ap,
+ real *w, complex *z__, integer *ldz, complex *work, integer *lwork,
+ real *rwork, integer *lrwork, integer *iwork, integer *liwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real eps;
+ integer inde;
+ real anrm;
+ integer imax;
+ real rmin, rmax, sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ integer lwmin, llrwk, llwrk;
+ logical wantz;
+ integer iscale;
+ extern doublereal clanhp_(char *, char *, integer *, complex *, real *);
+ extern /* Subroutine */ int cstedc_(char *, integer *, real *, real *,
+ complex *, integer *, complex *, integer *, real *, integer *,
+ integer *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ integer indtau;
+ extern /* Subroutine */ int chptrd_(char *, integer *, complex *, real *,
+ real *, complex *, integer *);
+ integer indrwk, indwrk, liwmin;
+ extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
+ integer lrwmin;
+ extern /* Subroutine */ int cupmtr_(char *, char *, char *, integer *,
+ integer *, complex *, complex *, complex *, integer *, complex *,
+ integer *);
+ real smlnum;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHPEVD computes all the eigenvalues and, optionally, eigenvectors of */
+/* a complex Hermitian matrix A in packed storage. If eigenvectors are */
+/* desired, it uses a divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, AP is overwritten by values generated during the */
+/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */
+/* and first superdiagonal of the tridiagonal matrix T overwrite */
+/* the corresponding elements of A, and if UPLO = 'L', the */
+/* diagonal and first subdiagonal of T overwrite the */
+/* corresponding elements of A. */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
+/* eigenvectors of the matrix A, with the i-th column of Z */
+/* holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the required LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of array WORK. */
+/* If N <= 1, LWORK must be at least 1. */
+/* If JOBZ = 'N' and N > 1, LWORK must be at least N. */
+/* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the required sizes of the WORK, RWORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK)) */
+/* On exit, if INFO = 0, RWORK(1) returns the required LRWORK. */
+
+/* LRWORK (input) INTEGER */
+/* The dimension of array RWORK. */
+/* If N <= 1, LRWORK must be at least 1. */
+/* If JOBZ = 'N' and N > 1, LRWORK must be at least N. */
+/* If JOBZ = 'V' and N > 1, LRWORK must be at least */
+/* 1 + 5*N + 2*N**2. */
+
+/* If LRWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the required sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the required LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of array IWORK. */
+/* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. */
+/* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the required sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of an intermediate tridiagonal */
+/* form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lsame_(uplo, "L") || lsame_(uplo,
+ "U"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -7;
+ }
+
+ if (*info == 0) {
+ if (*n <= 1) {
+ lwmin = 1;
+ liwmin = 1;
+ lrwmin = 1;
+ } else {
+ if (wantz) {
+ lwmin = *n << 1;
+/* Computing 2nd power */
+ i__1 = *n;
+ lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
+ liwmin = *n * 5 + 3;
+ } else {
+ lwmin = *n;
+ lrwmin = *n;
+ liwmin = 1;
+ }
+ }
+ work[1].r = (real) lwmin, work[1].i = 0.f;
+ rwork[1] = (real) lrwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -9;
+ } else if (*lrwork < lrwmin && ! lquery) {
+ *info = -11;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHPEVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ w[1] = ap[1].r;
+ if (wantz) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1.f, z__[i__1].i = 0.f;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = clanhp_("M", uplo, n, &ap[1], &rwork[1]);
+ iscale = 0;
+ if (anrm > 0.f && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ i__1 = *n * (*n + 1) / 2;
+ csscal_(&i__1, &sigma, &ap[1], &c__1);
+ }
+
+/* Call CHPTRD to reduce Hermitian packed matrix to tridiagonal form. */
+
+ inde = 1;
+ indtau = 1;
+ indrwk = inde + *n;
+ indwrk = indtau + *n;
+ llwrk = *lwork - indwrk + 1;
+ llrwk = *lrwork - indrwk + 1;
+ chptrd_(uplo, n, &ap[1], &w[1], &rwork[inde], &work[indtau], &iinfo);
+
+/* For eigenvalues only, call SSTERF. For eigenvectors, first call */
+/* CUPGTR to generate the orthogonal matrix, then call CSTEDC. */
+
+ if (! wantz) {
+ ssterf_(n, &w[1], &rwork[inde], info);
+ } else {
+ cstedc_("I", n, &w[1], &rwork[inde], &z__[z_offset], ldz, &work[
+ indwrk], &llwrk, &rwork[indrwk], &llrwk, &iwork[1], liwork,
+ info);
+ cupmtr_("L", uplo, "N", n, n, &ap[1], &work[indtau], &z__[z_offset],
+ ldz, &work[indwrk], &iinfo);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *n;
+ } else {
+ imax = *info - 1;
+ }
+ r__1 = 1.f / sigma;
+ sscal_(&imax, &r__1, &w[1], &c__1);
+ }
+
+ work[1].r = (real) lwmin, work[1].i = 0.f;
+ rwork[1] = (real) lrwmin;
+ iwork[1] = liwmin;
+ return 0;
+
+/* End of CHPEVD */
+
+} /* chpevd_ */
diff --git a/SRC/chpevx.c b/SRC/chpevx.c
new file mode 100644
index 0000000..77334b2
--- /dev/null
+++ b/SRC/chpevx.c
@@ -0,0 +1,471 @@
+/* chpevx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int chpevx_(char *jobz, char *range, char *uplo, integer *n,
+ complex *ap, real *vl, real *vu, integer *il, integer *iu, real *
+ abstol, integer *m, real *w, complex *z__, integer *ldz, complex *
+ work, real *rwork, integer *iwork, integer *ifail, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, jj;
+ real eps, vll, vuu, tmp1;
+ integer indd, inde;
+ real anrm;
+ integer imax;
+ real rmin, rmax;
+ logical test;
+ integer itmp1, indee;
+ real sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ char order[1];
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *), scopy_(integer *, real *, integer *, real *
+, integer *);
+ logical wantz, alleig, indeig;
+ integer iscale, indibl;
+ extern doublereal clanhp_(char *, char *, integer *, complex *, real *);
+ logical valeig;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real abstll, bignum;
+ integer indiwk, indisp, indtau;
+ extern /* Subroutine */ int chptrd_(char *, integer *, complex *, real *,
+ real *, complex *, integer *), cstein_(integer *, real *,
+ real *, integer *, real *, integer *, integer *, complex *,
+ integer *, real *, integer *, integer *, integer *);
+ integer indrwk, indwrk;
+ extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *,
+ complex *, integer *, real *, integer *), cupgtr_(char *,
+ integer *, complex *, complex *, complex *, integer *, complex *,
+ integer *), ssterf_(integer *, real *, real *, integer *);
+ integer nsplit;
+ extern /* Subroutine */ int cupmtr_(char *, char *, char *, integer *,
+ integer *, complex *, complex *, complex *, integer *, complex *,
+ integer *);
+ real smlnum;
+ extern /* Subroutine */ int sstebz_(char *, char *, integer *, real *,
+ real *, integer *, integer *, real *, real *, real *, integer *,
+ integer *, real *, integer *, integer *, real *, integer *,
+ integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHPEVX computes selected eigenvalues and, optionally, eigenvectors */
+/* of a complex Hermitian matrix A in packed storage. */
+/* Eigenvalues/vectors can be selected by specifying either a range of */
+/* values or a range of indices for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found; */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found; */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, AP is overwritten by values generated during the */
+/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */
+/* and first superdiagonal of the tridiagonal matrix T overwrite */
+/* the corresponding elements of A, and if UPLO = 'L', the */
+/* diagonal and first subdiagonal of T overwrite the */
+/* corresponding elements of A. */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) REAL */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing AP to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*SLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*SLAMCH('S'). */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices */
+/* with Guaranteed High Relative Accuracy," by Demmel and */
+/* Kahan, LAPACK Working Note #3. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the selected eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX array, dimension (LDZ, max(1,M)) */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If an eigenvector fails to converge, then that column of Z */
+/* contains the latest approximation to the eigenvector, and */
+/* the index of the eigenvector is returned in IFAIL. */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (7*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, then i eigenvectors failed to converge. */
+/* Their indices are stored in array IFAIL. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (! (lsame_(uplo, "L") || lsame_(uplo,
+ "U"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -7;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -8;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -9;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -14;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHPEVX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (alleig || indeig) {
+ *m = 1;
+ w[1] = ap[1].r;
+ } else {
+ if (*vl < ap[1].r && *vu >= ap[1].r) {
+ *m = 1;
+ w[1] = ap[1].r;
+ }
+ }
+ if (wantz) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1.f, z__[i__1].i = 0.f;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
+ rmax = dmin(r__1,r__2);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ abstll = *abstol;
+ if (valeig) {
+ vll = *vl;
+ vuu = *vu;
+ } else {
+ vll = 0.f;
+ vuu = 0.f;
+ }
+ anrm = clanhp_("M", uplo, n, &ap[1], &rwork[1]);
+ if (anrm > 0.f && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ i__1 = *n * (*n + 1) / 2;
+ csscal_(&i__1, &sigma, &ap[1], &c__1);
+ if (*abstol > 0.f) {
+ abstll = *abstol * sigma;
+ }
+ if (valeig) {
+ vll = *vl * sigma;
+ vuu = *vu * sigma;
+ }
+ }
+
+/* Call CHPTRD to reduce Hermitian packed matrix to tridiagonal form. */
+
+ indd = 1;
+ inde = indd + *n;
+ indrwk = inde + *n;
+ indtau = 1;
+ indwrk = indtau + *n;
+ chptrd_(uplo, n, &ap[1], &rwork[indd], &rwork[inde], &work[indtau], &
+ iinfo);
+
+/* If all eigenvalues are desired and ABSTOL is less than or equal */
+/* to zero, then call SSTERF or CUPGTR and CSTEQR. If this fails */
+/* for some eigenvalue, then try SSTEBZ. */
+
+ test = FALSE_;
+ if (indeig) {
+ if (*il == 1 && *iu == *n) {
+ test = TRUE_;
+ }
+ }
+ if ((alleig || test) && *abstol <= 0.f) {
+ scopy_(n, &rwork[indd], &c__1, &w[1], &c__1);
+ indee = indrwk + (*n << 1);
+ if (! wantz) {
+ i__1 = *n - 1;
+ scopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
+ ssterf_(n, &w[1], &rwork[indee], info);
+ } else {
+ cupgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &
+ work[indwrk], &iinfo);
+ i__1 = *n - 1;
+ scopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
+ csteqr_(jobz, n, &w[1], &rwork[indee], &z__[z_offset], ldz, &
+ rwork[indrwk], info);
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ifail[i__] = 0;
+/* L10: */
+ }
+ }
+ }
+ if (*info == 0) {
+ *m = *n;
+ goto L20;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call SSTEBZ and, if eigenvectors are desired, CSTEIN. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ indibl = 1;
+ indisp = indibl + *n;
+ indiwk = indisp + *n;
+ sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], &
+ rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &
+ rwork[indrwk], &iwork[indiwk], info);
+
+ if (wantz) {
+ cstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], &
+ iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[
+ indiwk], &ifail[1], info);
+
+/* Apply unitary matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by CSTEIN. */
+
+ indwrk = indtau + *n;
+ cupmtr_("L", uplo, "N", n, m, &ap[1], &work[indtau], &z__[z_offset],
+ ldz, &work[indwrk], &iinfo);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+L20:
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *m;
+ } else {
+ imax = *info - 1;
+ }
+ r__1 = 1.f / sigma;
+ sscal_(&imax, &r__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L30: */
+ }
+
+ if (i__ != 0) {
+ itmp1 = iwork[indibl + i__ - 1];
+ w[i__] = w[j];
+ iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
+ w[j] = tmp1;
+ iwork[indibl + j - 1] = itmp1;
+ cswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ if (*info != 0) {
+ itmp1 = ifail[i__];
+ ifail[i__] = ifail[j];
+ ifail[j] = itmp1;
+ }
+ }
+/* L40: */
+ }
+ }
+
+ return 0;
+
+/* End of CHPEVX */
+
+} /* chpevx_ */
diff --git a/SRC/chpgst.c b/SRC/chpgst.c
new file mode 100644
index 0000000..b830930
--- /dev/null
+++ b/SRC/chpgst.c
@@ -0,0 +1,312 @@
+/* chpgst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int chpgst_(integer *itype, char *uplo, integer *n, complex *
+ ap, complex *bp, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1, r__2;
+ complex q__1, q__2, q__3;
+
+ /* Local variables */
+ integer j, k, j1, k1, jj, kk;
+ complex ct;
+ real ajj;
+ integer j1j1;
+ real akk;
+ integer k1k1;
+ real bjj, bkk;
+ extern /* Subroutine */ int chpr2_(char *, integer *, complex *, complex *
+, integer *, complex *, integer *, complex *);
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int chpmv_(char *, integer *, complex *, complex *
+, complex *, integer *, complex *, complex *, integer *),
+ caxpy_(integer *, complex *, complex *, integer *, complex *,
+ integer *), ctpmv_(char *, char *, char *, integer *, complex *,
+ complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
+ complex *, complex *, integer *), csscal_(
+ integer *, real *, complex *, integer *), xerbla_(char *, integer
+ *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHPGST reduces a complex Hermitian-definite generalized */
+/* eigenproblem to standard form, using packed storage. */
+
+/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
+/* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H) */
+
+/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
+/* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L. */
+
+/* B must have been previously factorized as U**H*U or L*L**H by CPPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H); */
+/* = 2 or 3: compute U*A*U**H or L**H*A*L. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored and B is factored as */
+/* U**H*U; */
+/* = 'L': Lower triangle of A is stored and B is factored as */
+/* L*L**H. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, if INFO = 0, the transformed matrix, stored in the */
+/* same format as A. */
+
+/* BP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The triangular factor from the Cholesky factorization of B, */
+/* stored in the same format as A, as returned by CPPTRF. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --bp;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHPGST", &i__1);
+ return 0;
+ }
+
+ if (*itype == 1) {
+ if (upper) {
+
+/* Compute inv(U')*A*inv(U) */
+
+/* J1 and JJ are the indices of A(1,j) and A(j,j) */
+
+ jj = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ j1 = jj + 1;
+ jj += j;
+
+/* Compute the j-th column of the upper triangle of A */
+
+ i__2 = jj;
+ i__3 = jj;
+ r__1 = ap[i__3].r;
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+ i__2 = jj;
+ bjj = bp[i__2].r;
+ ctpsv_(uplo, "Conjugate transpose", "Non-unit", &j, &bp[1], &
+ ap[j1], &c__1);
+ i__2 = j - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ chpmv_(uplo, &i__2, &q__1, &ap[1], &bp[j1], &c__1, &c_b1, &ap[
+ j1], &c__1);
+ i__2 = j - 1;
+ r__1 = 1.f / bjj;
+ csscal_(&i__2, &r__1, &ap[j1], &c__1);
+ i__2 = jj;
+ i__3 = jj;
+ i__4 = j - 1;
+ cdotc_(&q__3, &i__4, &ap[j1], &c__1, &bp[j1], &c__1);
+ q__2.r = ap[i__3].r - q__3.r, q__2.i = ap[i__3].i - q__3.i;
+ q__1.r = q__2.r / bjj, q__1.i = q__2.i / bjj;
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+/* L10: */
+ }
+ } else {
+
+/* Compute inv(L)*A*inv(L') */
+
+/* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */
+
+ kk = 1;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ k1k1 = kk + *n - k + 1;
+
+/* Update the lower triangle of A(k:n,k:n) */
+
+ i__2 = kk;
+ akk = ap[i__2].r;
+ i__2 = kk;
+ bkk = bp[i__2].r;
+/* Computing 2nd power */
+ r__1 = bkk;
+ akk /= r__1 * r__1;
+ i__2 = kk;
+ ap[i__2].r = akk, ap[i__2].i = 0.f;
+ if (k < *n) {
+ i__2 = *n - k;
+ r__1 = 1.f / bkk;
+ csscal_(&i__2, &r__1, &ap[kk + 1], &c__1);
+ r__1 = akk * -.5f;
+ ct.r = r__1, ct.i = 0.f;
+ i__2 = *n - k;
+ caxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
+ ;
+ i__2 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ chpr2_(uplo, &i__2, &q__1, &ap[kk + 1], &c__1, &bp[kk + 1]
+, &c__1, &ap[k1k1]);
+ i__2 = *n - k;
+ caxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
+ ;
+ i__2 = *n - k;
+ ctpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1],
+ &ap[kk + 1], &c__1);
+ }
+ kk = k1k1;
+/* L20: */
+ }
+ }
+ } else {
+ if (upper) {
+
+/* Compute U*A*U' */
+
+/* K1 and KK are the indices of A(1,k) and A(k,k) */
+
+ kk = 0;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ k1 = kk + 1;
+ kk += k;
+
+/* Update the upper triangle of A(1:k,1:k) */
+
+ i__2 = kk;
+ akk = ap[i__2].r;
+ i__2 = kk;
+ bkk = bp[i__2].r;
+ i__2 = k - 1;
+ ctpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[
+ k1], &c__1);
+ r__1 = akk * .5f;
+ ct.r = r__1, ct.i = 0.f;
+ i__2 = k - 1;
+ caxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
+ i__2 = k - 1;
+ chpr2_(uplo, &i__2, &c_b1, &ap[k1], &c__1, &bp[k1], &c__1, &
+ ap[1]);
+ i__2 = k - 1;
+ caxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
+ i__2 = k - 1;
+ csscal_(&i__2, &bkk, &ap[k1], &c__1);
+ i__2 = kk;
+/* Computing 2nd power */
+ r__2 = bkk;
+ r__1 = akk * (r__2 * r__2);
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+/* L30: */
+ }
+ } else {
+
+/* Compute L'*A*L */
+
+/* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */
+
+ jj = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ j1j1 = jj + *n - j + 1;
+
+/* Compute the j-th column of the lower triangle of A */
+
+ i__2 = jj;
+ ajj = ap[i__2].r;
+ i__2 = jj;
+ bjj = bp[i__2].r;
+ i__2 = jj;
+ r__1 = ajj * bjj;
+ i__3 = *n - j;
+ cdotc_(&q__2, &i__3, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1);
+ q__1.r = r__1 + q__2.r, q__1.i = q__2.i;
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ i__2 = *n - j;
+ csscal_(&i__2, &bjj, &ap[jj + 1], &c__1);
+ i__2 = *n - j;
+ chpmv_(uplo, &i__2, &c_b1, &ap[j1j1], &bp[jj + 1], &c__1, &
+ c_b1, &ap[jj + 1], &c__1);
+ i__2 = *n - j + 1;
+ ctpmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &bp[jj]
+, &ap[jj], &c__1);
+ jj = j1j1;
+/* L40: */
+ }
+ }
+ }
+ return 0;
+
+/* End of CHPGST */
+
+} /* chpgst_ */
diff --git a/SRC/chpgv.c b/SRC/chpgv.c
new file mode 100644
index 0000000..bf69356
--- /dev/null
+++ b/SRC/chpgv.c
@@ -0,0 +1,244 @@
+/* chpgv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int chpgv_(integer *itype, char *jobz, char *uplo, integer *
+ n, complex *ap, complex *bp, real *w, complex *z__, integer *ldz,
+ complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+
+ /* Local variables */
+ integer j, neig;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int chpev_(char *, char *, integer *, complex *,
+ real *, complex *, integer *, complex *, real *, integer *);
+ char trans[1];
+ extern /* Subroutine */ int ctpmv_(char *, char *, char *, integer *,
+ complex *, complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
+ complex *, complex *, integer *);
+ logical wantz;
+ extern /* Subroutine */ int xerbla_(char *, integer *), chpgst_(
+ integer *, char *, integer *, complex *, complex *, integer *), cpptrf_(char *, integer *, complex *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHPGV computes all the eigenvalues and, optionally, the eigenvectors */
+/* of a complex generalized Hermitian-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. */
+/* Here A and B are assumed to be Hermitian, stored in packed format, */
+/* and B is also positive definite. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the contents of AP are destroyed. */
+
+/* BP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* B, packed columnwise in a linear array. The j-th column of B */
+/* is stored in the array BP as follows: */
+/* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */
+
+/* On exit, the triangular factor U or L from the Cholesky */
+/* factorization B = U**H*U or B = L*L**H, in the same storage */
+/* format as B. */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
+/* eigenvectors. The eigenvectors are normalized as follows: */
+/* if ITYPE = 1 or 2, Z**H*B*Z = I; */
+/* if ITYPE = 3, Z**H*inv(B)*Z = I. */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) COMPLEX array, dimension (max(1, 2*N-1)) */
+
+/* RWORK (workspace) REAL array, dimension (max(1, 3*N-2)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: CPPTRF or CHPEV returned an error code: */
+/* <= N: if INFO = i, CHPEV failed to converge; */
+/* i off-diagonal elements of an intermediate */
+/* tridiagonal form did not convergeto zero; */
+/* > N: if INFO = N + i, for 1 <= i <= n, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --bp;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+
+ *info = 0;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHPGV ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of B. */
+
+ cpptrf_(uplo, n, &bp[1], info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ chpgst_(itype, uplo, n, &ap[1], &bp[1], info);
+ chpev_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], &
+ rwork[1], info);
+
+ if (wantz) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ neig = *n;
+ if (*info > 0) {
+ neig = *info - 1;
+ }
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'C';
+ }
+
+ i__1 = neig;
+ for (j = 1; j <= i__1; ++j) {
+ ctpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L10: */
+ }
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'C';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ i__1 = neig;
+ for (j = 1; j <= i__1; ++j) {
+ ctpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L20: */
+ }
+ }
+ }
+ return 0;
+
+/* End of CHPGV */
+
+} /* chpgv_ */
diff --git a/SRC/chpgvd.c b/SRC/chpgvd.c
new file mode 100644
index 0000000..58fe02a
--- /dev/null
+++ b/SRC/chpgvd.c
@@ -0,0 +1,356 @@
+/* chpgvd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int chpgvd_(integer *itype, char *jobz, char *uplo, integer *
+ n, complex *ap, complex *bp, real *w, complex *z__, integer *ldz,
+ complex *work, integer *lwork, real *rwork, integer *lrwork, integer *
+ iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j, neig;
+ extern logical lsame_(char *, char *);
+ integer lwmin;
+ char trans[1];
+ extern /* Subroutine */ int ctpmv_(char *, char *, char *, integer *,
+ complex *, complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
+ complex *, complex *, integer *);
+ logical wantz;
+ extern /* Subroutine */ int chpevd_(char *, char *, integer *, complex *,
+ real *, complex *, integer *, complex *, integer *, real *,
+ integer *, integer *, integer *, integer *),
+ xerbla_(char *, integer *), chpgst_(integer *, char *,
+ integer *, complex *, complex *, integer *), cpptrf_(char
+ *, integer *, complex *, integer *);
+ integer liwmin, lrwmin;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHPGVD computes all the eigenvalues and, optionally, the eigenvectors */
+/* of a complex generalized Hermitian-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */
+/* B are assumed to be Hermitian, stored in packed format, and B is also */
+/* positive definite. */
+/* If eigenvectors are desired, it uses a divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the contents of AP are destroyed. */
+
+/* BP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* B, packed columnwise in a linear array. The j-th column of B */
+/* is stored in the array BP as follows: */
+/* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */
+
+/* On exit, the triangular factor U or L from the Cholesky */
+/* factorization B = U**H*U or B = L*L**H, in the same storage */
+/* format as B. */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
+/* eigenvectors. The eigenvectors are normalized as follows: */
+/* if ITYPE = 1 or 2, Z**H*B*Z = I; */
+/* if ITYPE = 3, Z**H*inv(B)*Z = I. */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the required LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of array WORK. */
+/* If N <= 1, LWORK >= 1. */
+/* If JOBZ = 'N' and N > 1, LWORK >= N. */
+/* If JOBZ = 'V' and N > 1, LWORK >= 2*N. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the required sizes of the WORK, RWORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* RWORK (workspace) REAL array, dimension (MAX(1,LRWORK)) */
+/* On exit, if INFO = 0, RWORK(1) returns the required LRWORK. */
+
+/* LRWORK (input) INTEGER */
+/* The dimension of array RWORK. */
+/* If N <= 1, LRWORK >= 1. */
+/* If JOBZ = 'N' and N > 1, LRWORK >= N. */
+/* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2. */
+
+/* If LRWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the required sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the required LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of array IWORK. */
+/* If JOBZ = 'N' or N <= 1, LIWORK >= 1. */
+/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the required sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: CPPTRF or CHPEVD returned an error code: */
+/* <= N: if INFO = i, CHPEVD failed to converge; */
+/* i off-diagonal elements of an intermediate */
+/* tridiagonal form did not convergeto zero; */
+/* > N: if INFO = N + i, for 1 <= i <= n, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --bp;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
+
+ *info = 0;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -9;
+ }
+
+ if (*info == 0) {
+ if (*n <= 1) {
+ lwmin = 1;
+ liwmin = 1;
+ lrwmin = 1;
+ } else {
+ if (wantz) {
+ lwmin = *n << 1;
+/* Computing 2nd power */
+ i__1 = *n;
+ lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
+ liwmin = *n * 5 + 3;
+ } else {
+ lwmin = *n;
+ lrwmin = *n;
+ liwmin = 1;
+ }
+ }
+ work[1].r = (real) lwmin, work[1].i = 0.f;
+ rwork[1] = (real) lrwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -11;
+ } else if (*lrwork < lrwmin && ! lquery) {
+ *info = -13;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -15;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHPGVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of B. */
+
+ cpptrf_(uplo, n, &bp[1], info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ chpgst_(itype, uplo, n, &ap[1], &bp[1], info);
+ chpevd_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1],
+ lwork, &rwork[1], lrwork, &iwork[1], liwork, info);
+/* Computing MAX */
+ r__1 = (real) lwmin, r__2 = work[1].r;
+ lwmin = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = (real) lrwmin;
+ lrwmin = dmax(r__1,rwork[1]);
+/* Computing MAX */
+ r__1 = (real) liwmin, r__2 = (real) iwork[1];
+ liwmin = dmax(r__1,r__2);
+
+ if (wantz) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ neig = *n;
+ if (*info > 0) {
+ neig = *info - 1;
+ }
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'C';
+ }
+
+ i__1 = neig;
+ for (j = 1; j <= i__1; ++j) {
+ ctpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L10: */
+ }
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'C';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ i__1 = neig;
+ for (j = 1; j <= i__1; ++j) {
+ ctpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L20: */
+ }
+ }
+ }
+
+ work[1].r = (real) lwmin, work[1].i = 0.f;
+ rwork[1] = (real) lrwmin;
+ iwork[1] = liwmin;
+ return 0;
+
+/* End of CHPGVD */
+
+} /* chpgvd_ */
diff --git a/SRC/chpgvx.c b/SRC/chpgvx.c
new file mode 100644
index 0000000..838b558
--- /dev/null
+++ b/SRC/chpgvx.c
@@ -0,0 +1,343 @@
+/* chpgvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int chpgvx_(integer *itype, char *jobz, char *range, char *
+ uplo, integer *n, complex *ap, complex *bp, real *vl, real *vu,
+ integer *il, integer *iu, real *abstol, integer *m, real *w, complex *
+ z__, integer *ldz, complex *work, real *rwork, integer *iwork,
+ integer *ifail, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+
+ /* Local variables */
+ integer j;
+ extern logical lsame_(char *, char *);
+ char trans[1];
+ extern /* Subroutine */ int ctpmv_(char *, char *, char *, integer *,
+ complex *, complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
+ complex *, complex *, integer *);
+ logical wantz, alleig, indeig, valeig;
+ extern /* Subroutine */ int xerbla_(char *, integer *), chpgst_(
+ integer *, char *, integer *, complex *, complex *, integer *), chpevx_(char *, char *, char *, integer *, complex *,
+ real *, real *, integer *, integer *, real *, integer *, real *,
+ complex *, integer *, complex *, real *, integer *, integer *,
+ integer *), cpptrf_(char *, integer *,
+ complex *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHPGVX computes selected eigenvalues and, optionally, eigenvectors */
+/* of a complex generalized Hermitian-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */
+/* B are assumed to be Hermitian, stored in packed format, and B is also */
+/* positive definite. Eigenvalues and eigenvectors can be selected by */
+/* specifying either a range of values or a range of indices for the */
+/* desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found; */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found; */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the contents of AP are destroyed. */
+
+/* BP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* B, packed columnwise in a linear array. The j-th column of B */
+/* is stored in the array BP as follows: */
+/* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */
+
+/* On exit, the triangular factor U or L from the Cholesky */
+/* factorization B = U**H*U or B = L*L**H, in the same storage */
+/* format as B. */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) REAL */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing AP to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*SLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*SLAMCH('S'). */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* On normal exit, the first M elements contain the selected */
+/* eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX array, dimension (LDZ, N) */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* The eigenvectors are normalized as follows: */
+/* if ITYPE = 1 or 2, Z**H*B*Z = I; */
+/* if ITYPE = 3, Z**H*inv(B)*Z = I. */
+
+/* If an eigenvector fails to converge, then that column of Z */
+/* contains the latest approximation to the eigenvector, and the */
+/* index of the eigenvector is returned in IFAIL. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (7*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: CPPTRF or CHPEVX returned an error code: */
+/* <= N: if INFO = i, CHPEVX failed to converge; */
+/* i eigenvectors failed to converge. Their indices */
+/* are stored in array IFAIL. */
+/* > N: if INFO = N + i, for 1 <= i <= n, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --bp;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ *info = 0;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -3;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -9;
+ }
+ } else if (indeig) {
+ if (*il < 1) {
+ *info = -10;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -11;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -16;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHPGVX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of B. */
+
+ cpptrf_(uplo, n, &bp[1], info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ chpgst_(itype, uplo, n, &ap[1], &bp[1], info);
+ chpevx_(jobz, range, uplo, n, &ap[1], vl, vu, il, iu, abstol, m, &w[1], &
+ z__[z_offset], ldz, &work[1], &rwork[1], &iwork[1], &ifail[1],
+ info);
+
+ if (wantz) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ if (*info > 0) {
+ *m = *info - 1;
+ }
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'C';
+ }
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ ctpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L10: */
+ }
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'C';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ ctpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L20: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CHPGVX */
+
+} /* chpgvx_ */
diff --git a/SRC/chprfs.c b/SRC/chprfs.c
new file mode 100644
index 0000000..6f73ec3
--- /dev/null
+++ b/SRC/chprfs.c
@@ -0,0 +1,462 @@
+/* chprfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int chprfs_(char *uplo, integer *n, integer *nrhs, complex *
+ ap, complex *afp, integer *ipiv, complex *b, integer *ldb, complex *x,
+ integer *ldx, real *ferr, real *berr, complex *work, real *rwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ real s;
+ integer ik, kk;
+ real xk;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), chpmv_(char *, integer *, complex *,
+ complex *, complex *, integer *, complex *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *,
+ complex *, integer *);
+ integer count;
+ logical upper;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *), chptrs_(
+ char *, integer *, integer *, complex *, integer *, complex *,
+ integer *, integer *);
+ real lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHPRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is Hermitian indefinite */
+/* and packed, and provides error bounds and backward error estimates */
+/* for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the Hermitian matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* AFP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The factored form of the matrix A. AFP contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor U or L from the factorization A = U*D*U**H or */
+/* A = L*D*L**H as computed by CHPTRF, stored as a packed */
+/* triangular matrix. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CHPTRF. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by CHPTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --afp;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*ldx < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHPRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.f;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ q__1.r = -1.f, q__1.i = -0.f;
+ chpmv_(uplo, n, &q__1, &ap[1], &x[j * x_dim1 + 1], &c__1, &c_b1, &
+ work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[
+ i__ + j * b_dim1]), dabs(r__2));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ kk = 1;
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j
+ * x_dim1]), dabs(r__2));
+ ik = kk;
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ik;
+ rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&ap[ik]), dabs(r__2))) * xk;
+ i__4 = ik;
+ i__5 = i__ + j * x_dim1;
+ s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
+ ap[ik]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs(
+ r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]),
+ dabs(r__4)));
+ ++ik;
+/* L40: */
+ }
+ i__3 = kk + k - 1;
+ rwork[k] = rwork[k] + (r__1 = ap[i__3].r, dabs(r__1)) * xk +
+ s;
+ kk += k;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j
+ * x_dim1]), dabs(r__2));
+ i__3 = kk;
+ rwork[k] += (r__1 = ap[i__3].r, dabs(r__1)) * xk;
+ ik = kk + 1;
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ i__4 = ik;
+ rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&ap[ik]), dabs(r__2))) * xk;
+ i__4 = ik;
+ i__5 = i__ + j * x_dim1;
+ s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
+ ap[ik]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs(
+ r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]),
+ dabs(r__4)));
+ ++ik;
+/* L60: */
+ }
+ rwork[k] += s;
+ kk += *n - k + 1;
+/* L70: */
+ }
+ }
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__3 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
+ s = dmax(r__3,r__4);
+ } else {
+/* Computing MAX */
+ i__3 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = dmax(r__3,r__4);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ chptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info);
+ caxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use CLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__3 = i__;
+ rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__];
+ } else {
+ i__3 = i__;
+ rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__] + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ chptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L120: */
+ }
+ chptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * x_dim1;
+ r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + j * x_dim1]), dabs(r__2));
+ lstres = dmax(r__3,r__4);
+/* L130: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of CHPRFS */
+
+} /* chprfs_ */
diff --git a/SRC/chpsv.c b/SRC/chpsv.c
new file mode 100644
index 0000000..977b0cf
--- /dev/null
+++ b/SRC/chpsv.c
@@ -0,0 +1,176 @@
+/* chpsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int chpsv_(char *uplo, integer *n, integer *nrhs, complex *
+ ap, integer *ipiv, complex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), chptrf_(
+ char *, integer *, complex *, integer *, integer *),
+ chptrs_(char *, integer *, integer *, complex *, integer *,
+ complex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHPSV computes the solution to a complex system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N Hermitian matrix stored in packed format and X */
+/* and B are N-by-NRHS matrices. */
+
+/* The diagonal pivoting method is used to factor A as */
+/* A = U * D * U**H, if UPLO = 'U', or */
+/* A = L * D * L**H, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, D is Hermitian and block diagonal with 1-by-1 */
+/* and 2-by-2 diagonal blocks. The factored form of A is then used to */
+/* solve the system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+
+/* On exit, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as */
+/* a packed triangular matrix in the same storage format as A. */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D, as */
+/* determined by CHPTRF. If IPIV(k) > 0, then rows and columns */
+/* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 */
+/* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, */
+/* then rows and columns k-1 and -IPIV(k) were interchanged and */
+/* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and */
+/* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and */
+/* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 */
+/* diagonal block. */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */
+/* has been completed, but the block diagonal matrix D is */
+/* exactly singular, so the solution could not be */
+/* computed. */
+
+/* Further Details */
+/* =============== */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the Hermitian matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = conjg(aji)) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHPSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ chptrf_(uplo, n, &ap[1], &ipiv[1], info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ chptrs_(uplo, n, nrhs, &ap[1], &ipiv[1], &b[b_offset], ldb, info);
+
+ }
+ return 0;
+
+/* End of CHPSV */
+
+} /* chpsv_ */
diff --git a/SRC/chpsvx.c b/SRC/chpsvx.c
new file mode 100644
index 0000000..d75ccae
--- /dev/null
+++ b/SRC/chpsvx.c
@@ -0,0 +1,320 @@
+/* chpsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int chpsvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, complex *ap, complex *afp, integer *ipiv, complex *b, integer *
+ ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr,
+ complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ extern doublereal clanhp_(char *, char *, integer *, complex *, real *), slamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int chpcon_(char *, integer *, complex *, integer
+ *, real *, real *, complex *, integer *), clacpy_(char *,
+ integer *, integer *, complex *, integer *, complex *, integer *), xerbla_(char *, integer *), chprfs_(char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *, complex *, real *
+, integer *), chptrf_(char *, integer *, complex *,
+ integer *, integer *), chptrs_(char *, integer *, integer
+ *, complex *, integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHPSVX uses the diagonal pivoting factorization A = U*D*U**H or */
+/* A = L*D*L**H to compute the solution to a complex system of linear */
+/* equations A * X = B, where A is an N-by-N Hermitian matrix stored */
+/* in packed format and X and B are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as */
+/* A = U * D * U**H, if UPLO = 'U', or */
+/* A = L * D * L**H, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices and D is Hermitian and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* 2. If some D(i,i)=0, so that D is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 3. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 4. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of A has been */
+/* supplied on entry. */
+/* = 'F': On entry, AFP and IPIV contain the factored form of */
+/* A. AFP and IPIV will not be modified. */
+/* = 'N': The matrix A will be copied to AFP and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the Hermitian matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+
+/* AFP (input or output) COMPLEX array, dimension (N*(N+1)/2) */
+/* If FACT = 'F', then AFP is an input argument and on entry */
+/* contains the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as */
+/* a packed triangular matrix in the same storage format as A. */
+
+/* If FACT = 'N', then AFP is an output argument and on exit */
+/* contains the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as */
+/* a packed triangular matrix in the same storage format as A. */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by CHPTRF. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by CHPTRF. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A. If RCOND is less than the machine precision (in */
+/* particular, if RCOND = 0), the matrix is singular to working */
+/* precision. This condition is indicated by a return code of */
+/* INFO > 0. */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: D(i,i) is exactly zero. The factorization */
+/* has been completed but the factor D is exactly */
+/* singular, so the solution and error bounds could */
+/* not be computed. RCOND = 0 is returned. */
+/* = N+1: D is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* Further Details */
+/* =============== */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the Hermitian matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = conjg(aji)) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --afp;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ if (! nofact && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHPSVX", &i__1);
+ return 0;
+ }
+
+ if (nofact) {
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ i__1 = *n * (*n + 1) / 2;
+ ccopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1);
+ chptrf_(uplo, n, &afp[1], &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.f;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = clanhp_("I", uplo, n, &ap[1], &rwork[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ chpcon_(uplo, n, &afp[1], &ipiv[1], &anorm, rcond, &work[1], info);
+
+/* Compute the solution vectors X. */
+
+ clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ chptrs_(uplo, n, nrhs, &afp[1], &ipiv[1], &x[x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solutions and */
+/* compute error bounds and backward error estimates for them. */
+
+ chprfs_(uplo, n, nrhs, &ap[1], &afp[1], &ipiv[1], &b[b_offset], ldb, &x[
+ x_offset], ldx, &ferr[1], &berr[1], &work[1], &rwork[1], info);
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < slamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of CHPSVX */
+
+} /* chpsvx_ */
diff --git a/SRC/chptrd.c b/SRC/chptrd.c
new file mode 100644
index 0000000..b08a545
--- /dev/null
+++ b/SRC/chptrd.c
@@ -0,0 +1,318 @@
+/* chptrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b2 = {0.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int chptrd_(char *uplo, integer *n, complex *ap, real *d__,
+ real *e, complex *tau, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real r__1;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Local variables */
+ integer i__, i1, ii, i1i1;
+ complex taui;
+ extern /* Subroutine */ int chpr2_(char *, integer *, complex *, complex *
+, integer *, complex *, integer *, complex *);
+ complex alpha;
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int chpmv_(char *, integer *, complex *, complex *
+, complex *, integer *, complex *, complex *, integer *),
+ caxpy_(integer *, complex *, complex *, integer *, complex *,
+ integer *);
+ logical upper;
+ extern /* Subroutine */ int clarfg_(integer *, complex *, complex *,
+ integer *, complex *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHPTRD reduces a complex Hermitian matrix A stored in packed form to */
+/* real symmetric tridiagonal form T by a unitary similarity */
+/* transformation: Q**H * A * Q = T. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+/* On exit, if UPLO = 'U', the diagonal and first superdiagonal */
+/* of A are overwritten by the corresponding elements of the */
+/* tridiagonal matrix T, and the elements above the first */
+/* superdiagonal, with the array TAU, represent the unitary */
+/* matrix Q as a product of elementary reflectors; if UPLO */
+/* = 'L', the diagonal and first subdiagonal of A are over- */
+/* written by the corresponding elements of the tridiagonal */
+/* matrix T, and the elements below the first subdiagonal, with */
+/* the array TAU, represent the unitary matrix Q as a product */
+/* of elementary reflectors. See Further Details. */
+
+/* D (output) REAL array, dimension (N) */
+/* The diagonal elements of the tridiagonal matrix T: */
+/* D(i) = A(i,i). */
+
+/* E (output) REAL array, dimension (N-1) */
+/* The off-diagonal elements of the tridiagonal matrix T: */
+/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */
+
+/* TAU (output) COMPLEX array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(n-1) . . . H(2) H(1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP, */
+/* overwriting A(1:i-1,i+1), and tau is stored in TAU(i). */
+
+/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(1) H(2) . . . H(n-1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP, */
+/* overwriting A(i+2:n,i), and tau is stored in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ --tau;
+ --e;
+ --d__;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHPTRD", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Reduce the upper triangle of A. */
+/* I1 is the index in AP of A(1,I+1). */
+
+ i1 = *n * (*n - 1) / 2 + 1;
+ i__1 = i1 + *n - 1;
+ i__2 = i1 + *n - 1;
+ r__1 = ap[i__2].r;
+ ap[i__1].r = r__1, ap[i__1].i = 0.f;
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+
+/* Generate elementary reflector H(i) = I - tau * v * v' */
+/* to annihilate A(1:i-1,i+1) */
+
+ i__1 = i1 + i__ - 1;
+ alpha.r = ap[i__1].r, alpha.i = ap[i__1].i;
+ clarfg_(&i__, &alpha, &ap[i1], &c__1, &taui);
+ i__1 = i__;
+ e[i__1] = alpha.r;
+
+ if (taui.r != 0.f || taui.i != 0.f) {
+
+/* Apply H(i) from both sides to A(1:i,1:i) */
+
+ i__1 = i1 + i__ - 1;
+ ap[i__1].r = 1.f, ap[i__1].i = 0.f;
+
+/* Compute y := tau * A * v storing y in TAU(1:i) */
+
+ chpmv_(uplo, &i__, &taui, &ap[1], &ap[i1], &c__1, &c_b2, &tau[
+ 1], &c__1);
+
+/* Compute w := y - 1/2 * tau * (y'*v) * v */
+
+ q__3.r = -.5f, q__3.i = -0.f;
+ q__2.r = q__3.r * taui.r - q__3.i * taui.i, q__2.i = q__3.r *
+ taui.i + q__3.i * taui.r;
+ cdotc_(&q__4, &i__, &tau[1], &c__1, &ap[i1], &c__1);
+ q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r *
+ q__4.i + q__2.i * q__4.r;
+ alpha.r = q__1.r, alpha.i = q__1.i;
+ caxpy_(&i__, &alpha, &ap[i1], &c__1, &tau[1], &c__1);
+
+/* Apply the transformation as a rank-2 update: */
+/* A := A - v * w' - w * v' */
+
+ q__1.r = -1.f, q__1.i = -0.f;
+ chpr2_(uplo, &i__, &q__1, &ap[i1], &c__1, &tau[1], &c__1, &ap[
+ 1]);
+
+ }
+ i__1 = i1 + i__ - 1;
+ i__2 = i__;
+ ap[i__1].r = e[i__2], ap[i__1].i = 0.f;
+ i__1 = i__ + 1;
+ i__2 = i1 + i__;
+ d__[i__1] = ap[i__2].r;
+ i__1 = i__;
+ tau[i__1].r = taui.r, tau[i__1].i = taui.i;
+ i1 -= i__;
+/* L10: */
+ }
+ d__[1] = ap[1].r;
+ } else {
+
+/* Reduce the lower triangle of A. II is the index in AP of */
+/* A(i,i) and I1I1 is the index of A(i+1,i+1). */
+
+ ii = 1;
+ r__1 = ap[1].r;
+ ap[1].r = r__1, ap[1].i = 0.f;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i1i1 = ii + *n - i__ + 1;
+
+/* Generate elementary reflector H(i) = I - tau * v * v' */
+/* to annihilate A(i+2:n,i) */
+
+ i__2 = ii + 1;
+ alpha.r = ap[i__2].r, alpha.i = ap[i__2].i;
+ i__2 = *n - i__;
+ clarfg_(&i__2, &alpha, &ap[ii + 2], &c__1, &taui);
+ i__2 = i__;
+ e[i__2] = alpha.r;
+
+ if (taui.r != 0.f || taui.i != 0.f) {
+
+/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
+
+ i__2 = ii + 1;
+ ap[i__2].r = 1.f, ap[i__2].i = 0.f;
+
+/* Compute y := tau * A * v storing y in TAU(i:n-1) */
+
+ i__2 = *n - i__;
+ chpmv_(uplo, &i__2, &taui, &ap[i1i1], &ap[ii + 1], &c__1, &
+ c_b2, &tau[i__], &c__1);
+
+/* Compute w := y - 1/2 * tau * (y'*v) * v */
+
+ q__3.r = -.5f, q__3.i = -0.f;
+ q__2.r = q__3.r * taui.r - q__3.i * taui.i, q__2.i = q__3.r *
+ taui.i + q__3.i * taui.r;
+ i__2 = *n - i__;
+ cdotc_(&q__4, &i__2, &tau[i__], &c__1, &ap[ii + 1], &c__1);
+ q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r *
+ q__4.i + q__2.i * q__4.r;
+ alpha.r = q__1.r, alpha.i = q__1.i;
+ i__2 = *n - i__;
+ caxpy_(&i__2, &alpha, &ap[ii + 1], &c__1, &tau[i__], &c__1);
+
+/* Apply the transformation as a rank-2 update: */
+/* A := A - v * w' - w * v' */
+
+ i__2 = *n - i__;
+ q__1.r = -1.f, q__1.i = -0.f;
+ chpr2_(uplo, &i__2, &q__1, &ap[ii + 1], &c__1, &tau[i__], &
+ c__1, &ap[i1i1]);
+
+ }
+ i__2 = ii + 1;
+ i__3 = i__;
+ ap[i__2].r = e[i__3], ap[i__2].i = 0.f;
+ i__2 = i__;
+ i__3 = ii;
+ d__[i__2] = ap[i__3].r;
+ i__2 = i__;
+ tau[i__2].r = taui.r, tau[i__2].i = taui.i;
+ ii = i1i1;
+/* L20: */
+ }
+ i__1 = *n;
+ i__2 = ii;
+ d__[i__1] = ap[i__2].r;
+ }
+
+ return 0;
+
+/* End of CHPTRD */
+
+} /* chptrd_ */
diff --git a/SRC/chptrf.c b/SRC/chptrf.c
new file mode 100644
index 0000000..47d9337
--- /dev/null
+++ b/SRC/chptrf.c
@@ -0,0 +1,821 @@
+/* chptrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int chptrf_(char *uplo, integer *n, complex *ap, integer *
+ ipiv, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2, q__3, q__4, q__5, q__6;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_imag(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ real d__;
+ integer i__, j, k;
+ complex t;
+ real r1, d11;
+ complex d12;
+ real d22;
+ complex d21;
+ integer kc, kk, kp;
+ complex wk;
+ integer kx;
+ real tt;
+ integer knc, kpc, npp;
+ complex wkm1, wkp1;
+ extern /* Subroutine */ int chpr_(char *, integer *, real *, complex *,
+ integer *, complex *);
+ integer imax, jmax;
+ real alpha;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer kstep;
+ logical upper;
+ extern doublereal slapy2_(real *, real *);
+ real absakk;
+ extern integer icamax_(integer *, complex *, integer *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), xerbla_(char *, integer *);
+ real colmax, rowmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHPTRF computes the factorization of a complex Hermitian packed */
+/* matrix A using the Bunch-Kaufman diagonal pivoting method: */
+
+/* A = U*D*U**H or A = L*D*L**H */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is Hermitian and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L, stored as a packed triangular */
+/* matrix overwriting A (see below for further details). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. 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. */
+
+/* Further Details */
+/* =============== */
+
+/* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services */
+/* Company */
+
+/* If UPLO = 'U', then A = U*D*U', where */
+/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
+/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
+/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I v 0 ) k-s */
+/* U(k) = ( 0 I 0 ) s */
+/* ( 0 0 I ) n-k */
+/* k-s s n-k */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
+/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
+/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
+
+/* If UPLO = 'L', then A = L*D*L', where */
+/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
+/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
+/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I 0 0 ) k-1 */
+/* L(k) = ( 0 I 0 ) s */
+/* ( 0 v I ) n-k-s+1 */
+/* k-1 s n-k-s+1 */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
+/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
+/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ipiv;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHPTRF", &i__1);
+ return 0;
+ }
+
+/* Initialize ALPHA for use in choosing pivot block size. */
+
+ alpha = (sqrt(17.f) + 1.f) / 8.f;
+
+ if (upper) {
+
+/* Factorize A as U*D*U' using the upper triangle of A */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2 */
+
+ k = *n;
+ kc = (*n - 1) * *n / 2 + 1;
+L10:
+ knc = kc;
+
+/* If K < 1, exit from loop */
+
+ if (k < 1) {
+ goto L110;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = kc + k - 1;
+ absakk = (r__1 = ap[i__1].r, dabs(r__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ imax = icamax_(&i__1, &ap[kc], &c__1);
+ i__1 = kc + imax - 1;
+ colmax = (r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kc
+ + imax - 1]), dabs(r__2));
+ } else {
+ colmax = 0.f;
+ }
+
+ if (dmax(absakk,colmax) == 0.f) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ i__1 = kc + k - 1;
+ i__2 = kc + k - 1;
+ r__1 = ap[i__2].r;
+ ap[i__1].r = r__1, ap[i__1].i = 0.f;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ rowmax = 0.f;
+ jmax = imax;
+ kx = imax * (imax + 1) / 2 + imax;
+ i__1 = k;
+ for (j = imax + 1; j <= i__1; ++j) {
+ i__2 = kx;
+ if ((r__1 = ap[i__2].r, dabs(r__1)) + (r__2 = r_imag(&ap[
+ kx]), dabs(r__2)) > rowmax) {
+ i__2 = kx;
+ rowmax = (r__1 = ap[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&ap[kx]), dabs(r__2));
+ jmax = j;
+ }
+ kx += j;
+/* L20: */
+ }
+ kpc = (imax - 1) * imax / 2 + 1;
+ if (imax > 1) {
+ i__1 = imax - 1;
+ jmax = icamax_(&i__1, &ap[kpc], &c__1);
+/* Computing MAX */
+ i__1 = kpc + jmax - 1;
+ r__3 = rowmax, r__4 = (r__1 = ap[i__1].r, dabs(r__1)) + (
+ r__2 = r_imag(&ap[kpc + jmax - 1]), dabs(r__2));
+ rowmax = dmax(r__3,r__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = kpc + imax - 1;
+ if ((r__1 = ap[i__1].r, dabs(r__1)) >= alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k - kstep + 1;
+ if (kstep == 2) {
+ knc = knc - k + 1;
+ }
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the leading */
+/* submatrix A(1:k,1:k) */
+
+ i__1 = kp - 1;
+ cswap_(&i__1, &ap[knc], &c__1, &ap[kpc], &c__1);
+ kx = kpc + kp - 1;
+ i__1 = kk - 1;
+ for (j = kp + 1; j <= i__1; ++j) {
+ kx = kx + j - 1;
+ r_cnjg(&q__1, &ap[knc + j - 1]);
+ t.r = q__1.r, t.i = q__1.i;
+ i__2 = knc + j - 1;
+ r_cnjg(&q__1, &ap[kx]);
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ i__2 = kx;
+ ap[i__2].r = t.r, ap[i__2].i = t.i;
+/* L30: */
+ }
+ i__1 = kx + kk - 1;
+ r_cnjg(&q__1, &ap[kx + kk - 1]);
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ i__1 = knc + kk - 1;
+ r1 = ap[i__1].r;
+ i__1 = knc + kk - 1;
+ i__2 = kpc + kp - 1;
+ r__1 = ap[i__2].r;
+ ap[i__1].r = r__1, ap[i__1].i = 0.f;
+ i__1 = kpc + kp - 1;
+ ap[i__1].r = r1, ap[i__1].i = 0.f;
+ if (kstep == 2) {
+ i__1 = kc + k - 1;
+ i__2 = kc + k - 1;
+ r__1 = ap[i__2].r;
+ ap[i__1].r = r__1, ap[i__1].i = 0.f;
+ i__1 = kc + k - 2;
+ t.r = ap[i__1].r, t.i = ap[i__1].i;
+ i__1 = kc + k - 2;
+ i__2 = kc + kp - 1;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kc + kp - 1;
+ ap[i__1].r = t.r, ap[i__1].i = t.i;
+ }
+ } else {
+ i__1 = kc + k - 1;
+ i__2 = kc + k - 1;
+ r__1 = ap[i__2].r;
+ ap[i__1].r = r__1, ap[i__1].i = 0.f;
+ if (kstep == 2) {
+ i__1 = kc - 1;
+ i__2 = kc - 1;
+ r__1 = ap[i__2].r;
+ ap[i__1].r = r__1, ap[i__1].i = 0.f;
+ }
+ }
+
+/* Update the leading submatrix */
+
+ if (kstep == 1) {
+
+/* 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 */
+
+/* Perform a rank-1 update of A(1:k-1,1:k-1) as */
+
+/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */
+
+ i__1 = kc + k - 1;
+ r1 = 1.f / ap[i__1].r;
+ i__1 = k - 1;
+ r__1 = -r1;
+ chpr_(uplo, &i__1, &r__1, &ap[kc], &c__1, &ap[1]);
+
+/* Store U(k) in column k */
+
+ i__1 = k - 1;
+ csscal_(&i__1, &r1, &ap[kc], &c__1);
+ } 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) )' */
+/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */
+
+ if (k > 2) {
+
+ i__1 = k - 1 + (k - 1) * k / 2;
+ r__1 = ap[i__1].r;
+ r__2 = r_imag(&ap[k - 1 + (k - 1) * k / 2]);
+ d__ = slapy2_(&r__1, &r__2);
+ i__1 = k - 1 + (k - 2) * (k - 1) / 2;
+ d22 = ap[i__1].r / d__;
+ i__1 = k + (k - 1) * k / 2;
+ d11 = ap[i__1].r / d__;
+ tt = 1.f / (d11 * d22 - 1.f);
+ i__1 = k - 1 + (k - 1) * k / 2;
+ q__1.r = ap[i__1].r / d__, q__1.i = ap[i__1].i / d__;
+ d12.r = q__1.r, d12.i = q__1.i;
+ d__ = tt / d__;
+
+ for (j = k - 2; j >= 1; --j) {
+ i__1 = j + (k - 2) * (k - 1) / 2;
+ q__3.r = d11 * ap[i__1].r, q__3.i = d11 * ap[i__1].i;
+ r_cnjg(&q__5, &d12);
+ i__2 = j + (k - 1) * k / 2;
+ q__4.r = q__5.r * ap[i__2].r - q__5.i * ap[i__2].i,
+ q__4.i = q__5.r * ap[i__2].i + q__5.i * ap[
+ i__2].r;
+ q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
+ q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
+ wkm1.r = q__1.r, wkm1.i = q__1.i;
+ i__1 = j + (k - 1) * k / 2;
+ q__3.r = d22 * ap[i__1].r, q__3.i = d22 * ap[i__1].i;
+ i__2 = j + (k - 2) * (k - 1) / 2;
+ q__4.r = d12.r * ap[i__2].r - d12.i * ap[i__2].i,
+ q__4.i = d12.r * ap[i__2].i + d12.i * ap[i__2]
+ .r;
+ q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
+ q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
+ wk.r = q__1.r, wk.i = q__1.i;
+ for (i__ = j; i__ >= 1; --i__) {
+ i__1 = i__ + (j - 1) * j / 2;
+ i__2 = i__ + (j - 1) * j / 2;
+ i__3 = i__ + (k - 1) * k / 2;
+ r_cnjg(&q__4, &wk);
+ q__3.r = ap[i__3].r * q__4.r - ap[i__3].i *
+ q__4.i, q__3.i = ap[i__3].r * q__4.i + ap[
+ i__3].i * q__4.r;
+ q__2.r = ap[i__2].r - q__3.r, q__2.i = ap[i__2].i
+ - q__3.i;
+ i__4 = i__ + (k - 2) * (k - 1) / 2;
+ r_cnjg(&q__6, &wkm1);
+ q__5.r = ap[i__4].r * q__6.r - ap[i__4].i *
+ q__6.i, q__5.i = ap[i__4].r * q__6.i + ap[
+ i__4].i * q__6.r;
+ q__1.r = q__2.r - q__5.r, q__1.i = q__2.i -
+ q__5.i;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+/* L40: */
+ }
+ i__1 = j + (k - 1) * k / 2;
+ ap[i__1].r = wk.r, ap[i__1].i = wk.i;
+ i__1 = j + (k - 2) * (k - 1) / 2;
+ ap[i__1].r = wkm1.r, ap[i__1].i = wkm1.i;
+ i__1 = j + (j - 1) * j / 2;
+ i__2 = j + (j - 1) * j / 2;
+ r__1 = ap[i__2].r;
+ q__1.r = r__1, q__1.i = 0.f;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+/* L50: */
+ }
+
+ }
+
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k - 1] = -kp;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kstep;
+ kc = knc - k;
+ goto L10;
+
+ } else {
+
+/* Factorize A as L*D*L' using the lower triangle of A */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2 */
+
+ k = 1;
+ kc = 1;
+ npp = *n * (*n + 1) / 2;
+L60:
+ knc = kc;
+
+/* If K > N, exit from loop */
+
+ if (k > *n) {
+ goto L110;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = kc;
+ absakk = (r__1 = ap[i__1].r, dabs(r__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ imax = k + icamax_(&i__1, &ap[kc + 1], &c__1);
+ i__1 = kc + imax - k;
+ colmax = (r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kc
+ + imax - k]), dabs(r__2));
+ } else {
+ colmax = 0.f;
+ }
+
+ if (dmax(absakk,colmax) == 0.f) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ i__1 = kc;
+ i__2 = kc;
+ r__1 = ap[i__2].r;
+ ap[i__1].r = r__1, ap[i__1].i = 0.f;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ rowmax = 0.f;
+ kx = kc + imax - k;
+ i__1 = imax - 1;
+ for (j = k; j <= i__1; ++j) {
+ i__2 = kx;
+ if ((r__1 = ap[i__2].r, dabs(r__1)) + (r__2 = r_imag(&ap[
+ kx]), dabs(r__2)) > rowmax) {
+ i__2 = kx;
+ rowmax = (r__1 = ap[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&ap[kx]), dabs(r__2));
+ jmax = j;
+ }
+ kx = kx + *n - j;
+/* L70: */
+ }
+ kpc = npp - (*n - imax + 1) * (*n - imax + 2) / 2 + 1;
+ if (imax < *n) {
+ i__1 = *n - imax;
+ jmax = imax + icamax_(&i__1, &ap[kpc + 1], &c__1);
+/* Computing MAX */
+ i__1 = kpc + jmax - imax;
+ r__3 = rowmax, r__4 = (r__1 = ap[i__1].r, dabs(r__1)) + (
+ r__2 = r_imag(&ap[kpc + jmax - imax]), dabs(r__2))
+ ;
+ rowmax = dmax(r__3,r__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = kpc;
+ if ((r__1 = ap[i__1].r, dabs(r__1)) >= alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k + kstep - 1;
+ if (kstep == 2) {
+ knc = knc + *n - k + 1;
+ }
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the trailing */
+/* submatrix A(k:n,k:n) */
+
+ if (kp < *n) {
+ i__1 = *n - kp;
+ cswap_(&i__1, &ap[knc + kp - kk + 1], &c__1, &ap[kpc + 1],
+ &c__1);
+ }
+ kx = knc + kp - kk;
+ i__1 = kp - 1;
+ for (j = kk + 1; j <= i__1; ++j) {
+ kx = kx + *n - j + 1;
+ r_cnjg(&q__1, &ap[knc + j - kk]);
+ t.r = q__1.r, t.i = q__1.i;
+ i__2 = knc + j - kk;
+ r_cnjg(&q__1, &ap[kx]);
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ i__2 = kx;
+ ap[i__2].r = t.r, ap[i__2].i = t.i;
+/* L80: */
+ }
+ i__1 = knc + kp - kk;
+ r_cnjg(&q__1, &ap[knc + kp - kk]);
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ i__1 = knc;
+ r1 = ap[i__1].r;
+ i__1 = knc;
+ i__2 = kpc;
+ r__1 = ap[i__2].r;
+ ap[i__1].r = r__1, ap[i__1].i = 0.f;
+ i__1 = kpc;
+ ap[i__1].r = r1, ap[i__1].i = 0.f;
+ if (kstep == 2) {
+ i__1 = kc;
+ i__2 = kc;
+ r__1 = ap[i__2].r;
+ ap[i__1].r = r__1, ap[i__1].i = 0.f;
+ i__1 = kc + 1;
+ t.r = ap[i__1].r, t.i = ap[i__1].i;
+ i__1 = kc + 1;
+ i__2 = kc + kp - k;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kc + kp - k;
+ ap[i__1].r = t.r, ap[i__1].i = t.i;
+ }
+ } else {
+ i__1 = kc;
+ i__2 = kc;
+ r__1 = ap[i__2].r;
+ ap[i__1].r = r__1, ap[i__1].i = 0.f;
+ if (kstep == 2) {
+ i__1 = knc;
+ i__2 = knc;
+ r__1 = ap[i__2].r;
+ ap[i__1].r = r__1, ap[i__1].i = 0.f;
+ }
+ }
+
+/* Update the trailing submatrix */
+
+ if (kstep == 1) {
+
+/* 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 < *n) {
+
+/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
+
+/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */
+
+ i__1 = kc;
+ r1 = 1.f / ap[i__1].r;
+ i__1 = *n - k;
+ r__1 = -r1;
+ chpr_(uplo, &i__1, &r__1, &ap[kc + 1], &c__1, &ap[kc + *n
+ - k + 1]);
+
+/* Store L(k) in column K */
+
+ i__1 = *n - k;
+ csscal_(&i__1, &r1, &ap[kc + 1], &c__1);
+ }
+ } 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 */
+
+ if (k < *n - 1) {
+
+/* 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) )' */
+/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' */
+
+/* where L(k) and L(k+1) are the k-th and (k+1)-th */
+/* columns of L */
+
+ i__1 = k + 1 + (k - 1) * ((*n << 1) - k) / 2;
+ r__1 = ap[i__1].r;
+ r__2 = r_imag(&ap[k + 1 + (k - 1) * ((*n << 1) - k) / 2]);
+ d__ = slapy2_(&r__1, &r__2);
+ i__1 = k + 1 + k * ((*n << 1) - k - 1) / 2;
+ d11 = ap[i__1].r / d__;
+ i__1 = k + (k - 1) * ((*n << 1) - k) / 2;
+ d22 = ap[i__1].r / d__;
+ tt = 1.f / (d11 * d22 - 1.f);
+ i__1 = k + 1 + (k - 1) * ((*n << 1) - k) / 2;
+ q__1.r = ap[i__1].r / d__, q__1.i = ap[i__1].i / d__;
+ d21.r = q__1.r, d21.i = q__1.i;
+ d__ = tt / d__;
+
+ i__1 = *n;
+ for (j = k + 2; j <= i__1; ++j) {
+ i__2 = j + (k - 1) * ((*n << 1) - k) / 2;
+ q__3.r = d11 * ap[i__2].r, q__3.i = d11 * ap[i__2].i;
+ i__3 = j + k * ((*n << 1) - k - 1) / 2;
+ q__4.r = d21.r * ap[i__3].r - d21.i * ap[i__3].i,
+ q__4.i = d21.r * ap[i__3].i + d21.i * ap[i__3]
+ .r;
+ q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
+ q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
+ wk.r = q__1.r, wk.i = q__1.i;
+ i__2 = j + k * ((*n << 1) - k - 1) / 2;
+ q__3.r = d22 * ap[i__2].r, q__3.i = d22 * ap[i__2].i;
+ r_cnjg(&q__5, &d21);
+ i__3 = j + (k - 1) * ((*n << 1) - k) / 2;
+ q__4.r = q__5.r * ap[i__3].r - q__5.i * ap[i__3].i,
+ q__4.i = q__5.r * ap[i__3].i + q__5.i * ap[
+ i__3].r;
+ q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
+ q__1.r = d__ * q__2.r, q__1.i = d__ * q__2.i;
+ wkp1.r = q__1.r, wkp1.i = q__1.i;
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * ((*n << 1) - j) / 2;
+ i__4 = i__ + (j - 1) * ((*n << 1) - j) / 2;
+ i__5 = i__ + (k - 1) * ((*n << 1) - k) / 2;
+ r_cnjg(&q__4, &wk);
+ q__3.r = ap[i__5].r * q__4.r - ap[i__5].i *
+ q__4.i, q__3.i = ap[i__5].r * q__4.i + ap[
+ i__5].i * q__4.r;
+ q__2.r = ap[i__4].r - q__3.r, q__2.i = ap[i__4].i
+ - q__3.i;
+ i__6 = i__ + k * ((*n << 1) - k - 1) / 2;
+ r_cnjg(&q__6, &wkp1);
+ q__5.r = ap[i__6].r * q__6.r - ap[i__6].i *
+ q__6.i, q__5.i = ap[i__6].r * q__6.i + ap[
+ i__6].i * q__6.r;
+ q__1.r = q__2.r - q__5.r, q__1.i = q__2.i -
+ q__5.i;
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+/* L90: */
+ }
+ i__2 = j + (k - 1) * ((*n << 1) - k) / 2;
+ ap[i__2].r = wk.r, ap[i__2].i = wk.i;
+ i__2 = j + k * ((*n << 1) - k - 1) / 2;
+ ap[i__2].r = wkp1.r, ap[i__2].i = wkp1.i;
+ i__2 = j + (j - 1) * ((*n << 1) - j) / 2;
+ i__3 = j + (j - 1) * ((*n << 1) - j) / 2;
+ r__1 = ap[i__3].r;
+ q__1.r = r__1, q__1.i = 0.f;
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+/* L100: */
+ }
+ }
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k + 1] = -kp;
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kstep;
+ kc = knc + *n - k + 2;
+ goto L60;
+
+ }
+
+L110:
+ return 0;
+
+/* End of CHPTRF */
+
+} /* chptrf_ */
diff --git a/SRC/chptri.c b/SRC/chptri.c
new file mode 100644
index 0000000..069bb2a
--- /dev/null
+++ b/SRC/chptri.c
@@ -0,0 +1,512 @@
+/* chptri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b2 = {0.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int chptri_(char *uplo, integer *n, complex *ap, integer *
+ ipiv, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real r__1;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ real d__;
+ integer j, k;
+ real t, ak;
+ integer kc, kp, kx, kpc, npp;
+ real akp1;
+ complex temp, akkp1;
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), chpmv_(char *, integer *, complex *,
+ complex *, complex *, integer *, complex *, complex *, integer *), cswap_(integer *, complex *, integer *, complex *,
+ integer *);
+ integer kstep;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer kcnext;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHPTRI computes the inverse of a complex Hermitian indefinite matrix */
+/* A in packed storage using the factorization A = U*D*U**H or */
+/* A = L*D*L**H computed by CHPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**H; */
+/* = 'L': Lower triangular, form is A = L*D*L**H. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L as computed by CHPTRF, */
+/* stored as a packed triangular matrix. */
+
+/* On exit, if INFO = 0, the (Hermitian) inverse of the original */
+/* matrix, stored as a packed triangular matrix. The j-th column */
+/* of inv(A) is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CHPTRF. */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* INFO (output) 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. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --work;
+ --ipiv;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHPTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ kp = *n * (*n + 1) / 2;
+ for (*info = *n; *info >= 1; --(*info)) {
+ i__1 = kp;
+ if (ipiv[*info] > 0 && (ap[i__1].r == 0.f && ap[i__1].i == 0.f)) {
+ return 0;
+ }
+ kp -= *info;
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ kp = 1;
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ i__2 = kp;
+ if (ipiv[*info] > 0 && (ap[i__2].r == 0.f && ap[i__2].i == 0.f)) {
+ return 0;
+ }
+ kp = kp + *n - *info + 1;
+/* L20: */
+ }
+ }
+ *info = 0;
+
+ if (upper) {
+
+/* Compute inv(A) from the factorization A = U*D*U'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+ kc = 1;
+L30:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L50;
+ }
+
+ kcnext = kc + k;
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = kc + k - 1;
+ i__2 = kc + k - 1;
+ r__1 = 1.f / ap[i__2].r;
+ ap[i__1].r = r__1, ap[i__1].i = 0.f;
+
+/* Compute column K of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ ccopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ chpmv_(uplo, &i__1, &q__1, &ap[1], &work[1], &c__1, &c_b2, &
+ ap[kc], &c__1);
+ i__1 = kc + k - 1;
+ i__2 = kc + k - 1;
+ i__3 = k - 1;
+ cdotc_(&q__2, &i__3, &work[1], &c__1, &ap[kc], &c__1);
+ r__1 = q__2.r;
+ q__1.r = ap[i__2].r - r__1, q__1.i = ap[i__2].i;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ t = c_abs(&ap[kcnext + k - 1]);
+ i__1 = kc + k - 1;
+ ak = ap[i__1].r / t;
+ i__1 = kcnext + k;
+ akp1 = ap[i__1].r / t;
+ i__1 = kcnext + k - 1;
+ q__1.r = ap[i__1].r / t, q__1.i = ap[i__1].i / t;
+ akkp1.r = q__1.r, akkp1.i = q__1.i;
+ d__ = t * (ak * akp1 - 1.f);
+ i__1 = kc + k - 1;
+ r__1 = akp1 / d__;
+ ap[i__1].r = r__1, ap[i__1].i = 0.f;
+ i__1 = kcnext + k;
+ r__1 = ak / d__;
+ ap[i__1].r = r__1, ap[i__1].i = 0.f;
+ i__1 = kcnext + k - 1;
+ q__2.r = -akkp1.r, q__2.i = -akkp1.i;
+ q__1.r = q__2.r / d__, q__1.i = q__2.i / d__;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+
+/* Compute columns K and K+1 of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ ccopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ chpmv_(uplo, &i__1, &q__1, &ap[1], &work[1], &c__1, &c_b2, &
+ ap[kc], &c__1);
+ i__1 = kc + k - 1;
+ i__2 = kc + k - 1;
+ i__3 = k - 1;
+ cdotc_(&q__2, &i__3, &work[1], &c__1, &ap[kc], &c__1);
+ r__1 = q__2.r;
+ q__1.r = ap[i__2].r - r__1, q__1.i = ap[i__2].i;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ i__1 = kcnext + k - 1;
+ i__2 = kcnext + k - 1;
+ i__3 = k - 1;
+ cdotc_(&q__2, &i__3, &ap[kc], &c__1, &ap[kcnext], &c__1);
+ q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ i__1 = k - 1;
+ ccopy_(&i__1, &ap[kcnext], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ chpmv_(uplo, &i__1, &q__1, &ap[1], &work[1], &c__1, &c_b2, &
+ ap[kcnext], &c__1);
+ i__1 = kcnext + k;
+ i__2 = kcnext + k;
+ i__3 = k - 1;
+ cdotc_(&q__2, &i__3, &work[1], &c__1, &ap[kcnext], &c__1);
+ r__1 = q__2.r;
+ q__1.r = ap[i__2].r - r__1, q__1.i = ap[i__2].i;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ }
+ kstep = 2;
+ kcnext = kcnext + k + 1;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the leading */
+/* submatrix A(1:k+1,1:k+1) */
+
+ kpc = (kp - 1) * kp / 2 + 1;
+ i__1 = kp - 1;
+ cswap_(&i__1, &ap[kc], &c__1, &ap[kpc], &c__1);
+ kx = kpc + kp - 1;
+ i__1 = k - 1;
+ for (j = kp + 1; j <= i__1; ++j) {
+ kx = kx + j - 1;
+ r_cnjg(&q__1, &ap[kc + j - 1]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__2 = kc + j - 1;
+ r_cnjg(&q__1, &ap[kx]);
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ i__2 = kx;
+ ap[i__2].r = temp.r, ap[i__2].i = temp.i;
+/* L40: */
+ }
+ i__1 = kc + kp - 1;
+ r_cnjg(&q__1, &ap[kc + kp - 1]);
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ i__1 = kc + k - 1;
+ temp.r = ap[i__1].r, temp.i = ap[i__1].i;
+ i__1 = kc + k - 1;
+ i__2 = kpc + kp - 1;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kpc + kp - 1;
+ ap[i__1].r = temp.r, ap[i__1].i = temp.i;
+ if (kstep == 2) {
+ i__1 = kc + k + k - 1;
+ temp.r = ap[i__1].r, temp.i = ap[i__1].i;
+ i__1 = kc + k + k - 1;
+ i__2 = kc + k + kp - 1;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kc + k + kp - 1;
+ ap[i__1].r = temp.r, ap[i__1].i = temp.i;
+ }
+ }
+
+ k += kstep;
+ kc = kcnext;
+ goto L30;
+L50:
+
+ ;
+ } else {
+
+/* Compute inv(A) from the factorization A = L*D*L'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ npp = *n * (*n + 1) / 2;
+ k = *n;
+ kc = npp;
+L60:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L80;
+ }
+
+ kcnext = kc - (*n - k + 2);
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = kc;
+ i__2 = kc;
+ r__1 = 1.f / ap[i__2].r;
+ ap[i__1].r = r__1, ap[i__1].i = 0.f;
+
+/* Compute column K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ ccopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ chpmv_(uplo, &i__1, &q__1, &ap[kc + *n - k + 1], &work[1], &
+ c__1, &c_b2, &ap[kc + 1], &c__1);
+ i__1 = kc;
+ i__2 = kc;
+ i__3 = *n - k;
+ cdotc_(&q__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1);
+ r__1 = q__2.r;
+ q__1.r = ap[i__2].r - r__1, q__1.i = ap[i__2].i;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ t = c_abs(&ap[kcnext + 1]);
+ i__1 = kcnext;
+ ak = ap[i__1].r / t;
+ i__1 = kc;
+ akp1 = ap[i__1].r / t;
+ i__1 = kcnext + 1;
+ q__1.r = ap[i__1].r / t, q__1.i = ap[i__1].i / t;
+ akkp1.r = q__1.r, akkp1.i = q__1.i;
+ d__ = t * (ak * akp1 - 1.f);
+ i__1 = kcnext;
+ r__1 = akp1 / d__;
+ ap[i__1].r = r__1, ap[i__1].i = 0.f;
+ i__1 = kc;
+ r__1 = ak / d__;
+ ap[i__1].r = r__1, ap[i__1].i = 0.f;
+ i__1 = kcnext + 1;
+ q__2.r = -akkp1.r, q__2.i = -akkp1.i;
+ q__1.r = q__2.r / d__, q__1.i = q__2.i / d__;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+
+/* Compute columns K-1 and K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ ccopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ chpmv_(uplo, &i__1, &q__1, &ap[kc + (*n - k + 1)], &work[1], &
+ c__1, &c_b2, &ap[kc + 1], &c__1);
+ i__1 = kc;
+ i__2 = kc;
+ i__3 = *n - k;
+ cdotc_(&q__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1);
+ r__1 = q__2.r;
+ q__1.r = ap[i__2].r - r__1, q__1.i = ap[i__2].i;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ i__1 = kcnext + 1;
+ i__2 = kcnext + 1;
+ i__3 = *n - k;
+ cdotc_(&q__2, &i__3, &ap[kc + 1], &c__1, &ap[kcnext + 2], &
+ c__1);
+ q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ i__1 = *n - k;
+ ccopy_(&i__1, &ap[kcnext + 2], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ chpmv_(uplo, &i__1, &q__1, &ap[kc + (*n - k + 1)], &work[1], &
+ c__1, &c_b2, &ap[kcnext + 2], &c__1);
+ i__1 = kcnext;
+ i__2 = kcnext;
+ i__3 = *n - k;
+ cdotc_(&q__2, &i__3, &work[1], &c__1, &ap[kcnext + 2], &c__1);
+ r__1 = q__2.r;
+ q__1.r = ap[i__2].r - r__1, q__1.i = ap[i__2].i;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ }
+ kstep = 2;
+ kcnext -= *n - k + 3;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the trailing */
+/* submatrix A(k-1:n,k-1:n) */
+
+ kpc = npp - (*n - kp + 1) * (*n - kp + 2) / 2 + 1;
+ if (kp < *n) {
+ i__1 = *n - kp;
+ cswap_(&i__1, &ap[kc + kp - k + 1], &c__1, &ap[kpc + 1], &
+ c__1);
+ }
+ kx = kc + kp - k;
+ i__1 = kp - 1;
+ for (j = k + 1; j <= i__1; ++j) {
+ kx = kx + *n - j + 1;
+ r_cnjg(&q__1, &ap[kc + j - k]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__2 = kc + j - k;
+ r_cnjg(&q__1, &ap[kx]);
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ i__2 = kx;
+ ap[i__2].r = temp.r, ap[i__2].i = temp.i;
+/* L70: */
+ }
+ i__1 = kc + kp - k;
+ r_cnjg(&q__1, &ap[kc + kp - k]);
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ i__1 = kc;
+ temp.r = ap[i__1].r, temp.i = ap[i__1].i;
+ i__1 = kc;
+ i__2 = kpc;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kpc;
+ ap[i__1].r = temp.r, ap[i__1].i = temp.i;
+ if (kstep == 2) {
+ i__1 = kc - *n + k - 1;
+ temp.r = ap[i__1].r, temp.i = ap[i__1].i;
+ i__1 = kc - *n + k - 1;
+ i__2 = kc - *n + kp - 1;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kc - *n + kp - 1;
+ ap[i__1].r = temp.r, ap[i__1].i = temp.i;
+ }
+ }
+
+ k -= kstep;
+ kc = kcnext;
+ goto L60;
+L80:
+ ;
+ }
+
+ return 0;
+
+/* End of CHPTRI */
+
+} /* chptri_ */
diff --git a/SRC/chptrs.c b/SRC/chptrs.c
new file mode 100644
index 0000000..e5c7536
--- /dev/null
+++ b/SRC/chptrs.c
@@ -0,0 +1,530 @@
+/* chptrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int chptrs_(char *uplo, integer *n, integer *nrhs, complex *
+ ap, integer *ipiv, complex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer j, k;
+ real s;
+ complex ak, bk;
+ integer kc, kp;
+ complex akm1, bkm1, akm1k;
+ extern logical lsame_(char *, char *);
+ complex denom;
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *), cgeru_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *),
+ cswap_(integer *, complex *, integer *, complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
+ csscal_(integer *, real *, complex *, integer *), xerbla_(char *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHPTRS solves a system of linear equations A*X = B with a complex */
+/* Hermitian matrix A stored in packed format using the factorization */
+/* A = U*D*U**H or A = L*D*L**H computed by CHPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**H; */
+/* = 'L': Lower triangular, form is A = L*D*L**H. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by CHPTRF, stored as a */
+/* packed triangular matrix. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CHPTRF. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ap;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHPTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B, where A = U*D*U'. */
+
+/* First solve U*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L10:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L30;
+ }
+
+ kc -= k;
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &ap[kc], &c__1, &b[k + b_dim1], ldb, &
+ b[b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = kc + k - 1;
+ s = 1.f / ap[i__1].r;
+ csscal_(nrhs, &s, &b[k + b_dim1], ldb);
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K-1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k - 1) {
+ cswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ i__1 = k - 2;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &ap[kc], &c__1, &b[k + b_dim1], ldb, &
+ b[b_dim1 + 1], ldb);
+ i__1 = k - 2;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &ap[kc - (k - 1)], &c__1, &b[k - 1 +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = kc + k - 2;
+ akm1k.r = ap[i__1].r, akm1k.i = ap[i__1].i;
+ c_div(&q__1, &ap[kc - 1], &akm1k);
+ akm1.r = q__1.r, akm1.i = q__1.i;
+ r_cnjg(&q__2, &akm1k);
+ c_div(&q__1, &ap[kc + k - 1], &q__2);
+ ak.r = q__1.r, ak.i = q__1.i;
+ q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i +
+ akm1.i * ak.r;
+ q__1.r = q__2.r - 1.f, q__1.i = q__2.i - 0.f;
+ denom.r = q__1.r, denom.i = q__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ c_div(&q__1, &b[k - 1 + j * b_dim1], &akm1k);
+ bkm1.r = q__1.r, bkm1.i = q__1.i;
+ r_cnjg(&q__2, &akm1k);
+ c_div(&q__1, &b[k + j * b_dim1], &q__2);
+ bk.r = q__1.r, bk.i = q__1.i;
+ i__2 = k - 1 + j * b_dim1;
+ q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r *
+ bkm1.i + ak.i * bkm1.r;
+ q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
+ c_div(&q__1, &q__2, &denom);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + j * b_dim1;
+ q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r *
+ bk.i + akm1.i * bk.r;
+ q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
+ c_div(&q__1, &q__2, &denom);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L20: */
+ }
+ kc = kc - k + 1;
+ k += -2;
+ }
+
+ goto L10;
+L30:
+
+/* Next solve U'*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+ kc = 1;
+L40:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L50;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(U'(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k > 1) {
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b[b_offset]
+, ldb, &ap[kc], &c__1, &c_b1, &b[k + b_dim1], ldb);
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ }
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ kc += k;
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ if (k > 1) {
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b[b_offset]
+, ldb, &ap[kc], &c__1, &c_b1, &b[k + b_dim1], ldb);
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+
+ clacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b[b_offset]
+, ldb, &ap[kc + k], &c__1, &c_b1, &b[k + 1 + b_dim1],
+ ldb);
+ clacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
+ }
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ kc = kc + (k << 1) + 1;
+ k += 2;
+ }
+
+ goto L40;
+L50:
+
+ ;
+ } else {
+
+/* Solve A*X = B, where A = L*D*L'. */
+
+/* First solve L*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+ kc = 1;
+L60:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L80;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &ap[kc + 1], &c__1, &b[k + b_dim1],
+ ldb, &b[k + 1 + b_dim1], ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = kc;
+ s = 1.f / ap[i__1].r;
+ csscal_(nrhs, &s, &b[k + b_dim1], ldb);
+ kc = kc + *n - k + 1;
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K+1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k + 1) {
+ cswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ if (k < *n - 1) {
+ i__1 = *n - k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &ap[kc + 2], &c__1, &b[k + b_dim1],
+ ldb, &b[k + 2 + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &ap[kc + *n - k + 2], &c__1, &b[k
+ + 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = kc + 1;
+ akm1k.r = ap[i__1].r, akm1k.i = ap[i__1].i;
+ r_cnjg(&q__2, &akm1k);
+ c_div(&q__1, &ap[kc], &q__2);
+ akm1.r = q__1.r, akm1.i = q__1.i;
+ c_div(&q__1, &ap[kc + *n - k + 1], &akm1k);
+ ak.r = q__1.r, ak.i = q__1.i;
+ q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i +
+ akm1.i * ak.r;
+ q__1.r = q__2.r - 1.f, q__1.i = q__2.i - 0.f;
+ denom.r = q__1.r, denom.i = q__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ r_cnjg(&q__2, &akm1k);
+ c_div(&q__1, &b[k + j * b_dim1], &q__2);
+ bkm1.r = q__1.r, bkm1.i = q__1.i;
+ c_div(&q__1, &b[k + 1 + j * b_dim1], &akm1k);
+ bk.r = q__1.r, bk.i = q__1.i;
+ i__2 = k + j * b_dim1;
+ q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r *
+ bkm1.i + ak.i * bkm1.r;
+ q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
+ c_div(&q__1, &q__2, &denom);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r *
+ bk.i + akm1.i * bk.r;
+ q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
+ c_div(&q__1, &q__2, &denom);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L70: */
+ }
+ kc = kc + (*n - k << 1) + 1;
+ k += 2;
+ }
+
+ goto L60;
+L80:
+
+/* Next solve L'*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L90:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L100;
+ }
+
+ kc -= *n - k + 1;
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(L'(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b[k + 1 +
+ b_dim1], ldb, &ap[kc + 1], &c__1, &c_b1, &b[k +
+ b_dim1], ldb);
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ }
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ if (k < *n) {
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b[k + 1 +
+ b_dim1], ldb, &ap[kc + 1], &c__1, &c_b1, &b[k +
+ b_dim1], ldb);
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+
+ clacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b[k + 1 +
+ b_dim1], ldb, &ap[kc - (*n - k)], &c__1, &c_b1, &b[k
+ - 1 + b_dim1], ldb);
+ clacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
+ }
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ kc -= *n - k + 2;
+ k += -2;
+ }
+
+ goto L90;
+L100:
+ ;
+ }
+
+ return 0;
+
+/* End of CHPTRS */
+
+} /* chptrs_ */
diff --git a/SRC/chsein.c b/SRC/chsein.c
new file mode 100644
index 0000000..bc49ab1
--- /dev/null
+++ b/SRC/chsein.c
@@ -0,0 +1,432 @@
+/* chsein.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static logical c_false = FALSE_;
+static logical c_true = TRUE_;
+
+/* Subroutine */ int chsein_(char *side, char *eigsrc, char *initv, logical *
+ select, integer *n, complex *h__, integer *ldh, complex *w, complex *
+ vl, integer *ldvl, complex *vr, integer *ldvr, integer *mm, integer *
+ m, complex *work, real *rwork, integer *ifaill, integer *ifailr,
+ integer *info)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
+ i__2, i__3;
+ real r__1, r__2;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, k, kl, kr, ks;
+ complex wk;
+ integer kln;
+ real ulp, eps3, unfl;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical leftv, bothv;
+ real hnorm;
+ extern /* Subroutine */ int claein_(logical *, logical *, integer *,
+ complex *, integer *, complex *, complex *, complex *, integer *,
+ real *, real *, real *, integer *);
+ extern doublereal slamch_(char *), clanhs_(char *, integer *,
+ complex *, integer *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical noinit;
+ integer ldwork;
+ logical rightv, fromqr;
+ real smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHSEIN uses inverse iteration to find specified right and/or left */
+/* eigenvectors of a complex upper Hessenberg matrix H. */
+
+/* The right eigenvector x and the left eigenvector y of the matrix H */
+/* corresponding to an eigenvalue w are defined by: */
+
+/* H * x = w * x, y**h * H = w * y**h */
+
+/* where y**h denotes the conjugate transpose of the vector y. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'R': compute right eigenvectors only; */
+/* = 'L': compute left eigenvectors only; */
+/* = 'B': compute both right and left eigenvectors. */
+
+/* EIGSRC (input) CHARACTER*1 */
+/* Specifies the source of eigenvalues supplied in W: */
+/* = 'Q': the eigenvalues were found using CHSEQR; thus, if */
+/* H has zero subdiagonal elements, and so is */
+/* block-triangular, then the j-th eigenvalue can be */
+/* assumed to be an eigenvalue of the block containing */
+/* the j-th row/column. This property allows CHSEIN to */
+/* perform inverse iteration on just one diagonal block. */
+/* = 'N': no assumptions are made on the correspondence */
+/* between eigenvalues and diagonal blocks. In this */
+/* case, CHSEIN must always perform inverse iteration */
+/* using the whole matrix H. */
+
+/* INITV (input) CHARACTER*1 */
+/* = 'N': no initial vectors are supplied; */
+/* = 'U': user-supplied initial vectors are stored in the arrays */
+/* VL and/or VR. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* Specifies the eigenvectors to be computed. To select the */
+/* eigenvector corresponding to the eigenvalue W(j), */
+/* SELECT(j) must be set to .TRUE.. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N >= 0. */
+
+/* H (input) COMPLEX array, dimension (LDH,N) */
+/* The upper Hessenberg matrix H. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH >= max(1,N). */
+
+/* W (input/output) COMPLEX array, dimension (N) */
+/* On entry, the eigenvalues of H. */
+/* On exit, the real parts of W may have been altered since */
+/* close eigenvalues are perturbed slightly in searching for */
+/* independent eigenvectors. */
+
+/* VL (input/output) COMPLEX array, dimension (LDVL,MM) */
+/* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must */
+/* contain starting vectors for the inverse iteration for the */
+/* left eigenvectors; the starting vector for each eigenvector */
+/* must be in the same column in which the eigenvector will be */
+/* stored. */
+/* On exit, if SIDE = 'L' or 'B', the left eigenvectors */
+/* specified by SELECT will be stored consecutively in the */
+/* columns of VL, in the same order as their eigenvalues. */
+/* If SIDE = 'R', VL is not referenced. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. */
+/* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. */
+
+/* VR (input/output) COMPLEX array, dimension (LDVR,MM) */
+/* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must */
+/* contain starting vectors for the inverse iteration for the */
+/* right eigenvectors; the starting vector for each eigenvector */
+/* must be in the same column in which the eigenvector will be */
+/* stored. */
+/* On exit, if SIDE = 'R' or 'B', the right eigenvectors */
+/* specified by SELECT will be stored consecutively in the */
+/* columns of VR, in the same order as their eigenvalues. */
+/* If SIDE = 'L', VR is not referenced. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. */
+/* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. */
+
+/* MM (input) INTEGER */
+/* The number of columns in the arrays VL and/or VR. MM >= M. */
+
+/* M (output) INTEGER */
+/* The number of columns in the arrays VL and/or VR required to */
+/* store the eigenvectors (= the number of .TRUE. elements in */
+/* SELECT). */
+
+/* WORK (workspace) COMPLEX array, dimension (N*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* IFAILL (output) INTEGER array, dimension (MM) */
+/* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left */
+/* eigenvector in the i-th column of VL (corresponding to the */
+/* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the */
+/* eigenvector converged satisfactorily. */
+/* If SIDE = 'R', IFAILL is not referenced. */
+
+/* IFAILR (output) INTEGER array, dimension (MM) */
+/* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right */
+/* eigenvector in the i-th column of VR (corresponding to the */
+/* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the */
+/* eigenvector converged satisfactorily. */
+/* If SIDE = 'L', IFAILR is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, i is the number of eigenvectors which */
+/* failed to converge; see IFAILL and IFAILR for further */
+/* details. */
+
+/* Further Details */
+/* =============== */
+
+/* Each eigenvector is normalized so that the element of largest */
+/* magnitude has magnitude 1; here the magnitude of a complex number */
+/* (x,y) is taken to be |x|+|y|. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters. */
+
+ /* Parameter adjustments */
+ --select;
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --w;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+ --rwork;
+ --ifaill;
+ --ifailr;
+
+ /* Function Body */
+ bothv = lsame_(side, "B");
+ rightv = lsame_(side, "R") || bothv;
+ leftv = lsame_(side, "L") || bothv;
+
+ fromqr = lsame_(eigsrc, "Q");
+
+ noinit = lsame_(initv, "N");
+
+/* Set M to the number of columns required to store the selected */
+/* eigenvectors. */
+
+ *m = 0;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (select[k]) {
+ ++(*m);
+ }
+/* L10: */
+ }
+
+ *info = 0;
+ if (! rightv && ! leftv) {
+ *info = -1;
+ } else if (! fromqr && ! lsame_(eigsrc, "N")) {
+ *info = -2;
+ } else if (! noinit && ! lsame_(initv, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*ldh < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvl < 1 || leftv && *ldvl < *n) {
+ *info = -10;
+ } else if (*ldvr < 1 || rightv && *ldvr < *n) {
+ *info = -12;
+ } else if (*mm < *m) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CHSEIN", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Set machine-dependent constants. */
+
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Precision");
+ smlnum = unfl * (*n / ulp);
+
+ ldwork = *n;
+
+ kl = 1;
+ kln = 0;
+ if (fromqr) {
+ kr = 0;
+ } else {
+ kr = *n;
+ }
+ ks = 1;
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (select[k]) {
+
+/* Compute eigenvector(s) corresponding to W(K). */
+
+ if (fromqr) {
+
+/* If affiliation of eigenvalues is known, check whether */
+/* the matrix splits. */
+
+/* Determine KL and KR such that 1 <= KL <= K <= KR <= N */
+/* and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or */
+/* KR = N). */
+
+/* Then inverse iteration can be performed with the */
+/* submatrix H(KL:N,KL:N) for a left eigenvector, and with */
+/* the submatrix H(1:KR,1:KR) for a right eigenvector. */
+
+ i__2 = kl + 1;
+ for (i__ = k; i__ >= i__2; --i__) {
+ i__3 = i__ + (i__ - 1) * h_dim1;
+ if (h__[i__3].r == 0.f && h__[i__3].i == 0.f) {
+ goto L30;
+ }
+/* L20: */
+ }
+L30:
+ kl = i__;
+ if (k > kr) {
+ i__2 = *n - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ i__3 = i__ + 1 + i__ * h_dim1;
+ if (h__[i__3].r == 0.f && h__[i__3].i == 0.f) {
+ goto L50;
+ }
+/* L40: */
+ }
+L50:
+ kr = i__;
+ }
+ }
+
+ if (kl != kln) {
+ kln = kl;
+
+/* Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it */
+/* has not ben computed before. */
+
+ i__2 = kr - kl + 1;
+ hnorm = clanhs_("I", &i__2, &h__[kl + kl * h_dim1], ldh, &
+ rwork[1]);
+ if (hnorm > 0.f) {
+ eps3 = hnorm * ulp;
+ } else {
+ eps3 = smlnum;
+ }
+ }
+
+/* Perturb eigenvalue if it is close to any previous */
+/* selected eigenvalues affiliated to the submatrix */
+/* H(KL:KR,KL:KR). Close roots are modified by EPS3. */
+
+ i__2 = k;
+ wk.r = w[i__2].r, wk.i = w[i__2].i;
+L60:
+ i__2 = kl;
+ for (i__ = k - 1; i__ >= i__2; --i__) {
+ i__3 = i__;
+ q__2.r = w[i__3].r - wk.r, q__2.i = w[i__3].i - wk.i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ if (select[i__] && (r__1 = q__1.r, dabs(r__1)) + (r__2 =
+ r_imag(&q__1), dabs(r__2)) < eps3) {
+ q__1.r = wk.r + eps3, q__1.i = wk.i;
+ wk.r = q__1.r, wk.i = q__1.i;
+ goto L60;
+ }
+/* L70: */
+ }
+ i__2 = k;
+ w[i__2].r = wk.r, w[i__2].i = wk.i;
+
+ if (leftv) {
+
+/* Compute left eigenvector. */
+
+ i__2 = *n - kl + 1;
+ claein_(&c_false, &noinit, &i__2, &h__[kl + kl * h_dim1], ldh,
+ &wk, &vl[kl + ks * vl_dim1], &work[1], &ldwork, &
+ rwork[1], &eps3, &smlnum, &iinfo);
+ if (iinfo > 0) {
+ ++(*info);
+ ifaill[ks] = k;
+ } else {
+ ifaill[ks] = 0;
+ }
+ i__2 = kl - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + ks * vl_dim1;
+ vl[i__3].r = 0.f, vl[i__3].i = 0.f;
+/* L80: */
+ }
+ }
+ if (rightv) {
+
+/* Compute right eigenvector. */
+
+ claein_(&c_true, &noinit, &kr, &h__[h_offset], ldh, &wk, &vr[
+ ks * vr_dim1 + 1], &work[1], &ldwork, &rwork[1], &
+ eps3, &smlnum, &iinfo);
+ if (iinfo > 0) {
+ ++(*info);
+ ifailr[ks] = k;
+ } else {
+ ifailr[ks] = 0;
+ }
+ i__2 = *n;
+ for (i__ = kr + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + ks * vr_dim1;
+ vr[i__3].r = 0.f, vr[i__3].i = 0.f;
+/* L90: */
+ }
+ }
+ ++ks;
+ }
+/* L100: */
+ }
+
+ return 0;
+
+/* End of CHSEIN */
+
+} /* chsein_ */
diff --git a/SRC/chseqr.c b/SRC/chseqr.c
new file mode 100644
index 0000000..0a02ec5
--- /dev/null
+++ b/SRC/chseqr.c
@@ -0,0 +1,480 @@
+/* chseqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c__12 = 12;
+static integer c__2 = 2;
+static integer c__49 = 49;
+
+/* Subroutine */ int chseqr_(char *job, char *compz, integer *n, integer *ilo,
+ integer *ihi, complex *h__, integer *ldh, complex *w, complex *z__,
+ integer *ldz, complex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3[2];
+ real r__1, r__2, r__3;
+ complex q__1;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ complex hl[2401] /* was [49][49] */;
+ integer kbot, nmin;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ logical initz;
+ complex workl[49];
+ logical wantt, wantz;
+ extern /* Subroutine */ int claqr0_(logical *, logical *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ integer *, complex *, integer *, complex *, integer *, integer *),
+ clahqr_(logical *, logical *, integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, integer *, complex *,
+ integer *, integer *), clacpy_(char *, integer *, integer *,
+ complex *, integer *, complex *, integer *), claset_(char
+ *, integer *, integer *, complex *, complex *, complex *, integer
+ *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+/* Purpose */
+/* ======= */
+
+/* CHSEQR computes the eigenvalues of a Hessenberg matrix H */
+/* and, optionally, the matrices T and Z from the Schur decomposition */
+/* H = Z T Z**H, where T is an upper triangular matrix (the */
+/* Schur form), and Z is the unitary matrix of Schur vectors. */
+
+/* Optionally Z may be postmultiplied into an input unitary */
+/* matrix Q so that this routine can give the Schur factorization */
+/* of a matrix A which has been reduced to the Hessenberg form H */
+/* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* = 'E': compute eigenvalues only; */
+/* = 'S': compute eigenvalues and the Schur form T. */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': no Schur vectors are computed; */
+/* = 'I': Z is initialized to the unit matrix and the matrix Z */
+/* of Schur vectors of H is returned; */
+/* = 'V': Z must contain an unitary matrix Q on entry, and */
+/* the product Q*Z is returned. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N .GE. 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that H is already upper triangular in rows */
+/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
+/* set by a previous call to CGEBAL, and then passed to CGEHRD */
+/* when the matrix output by CGEBAL is reduced to Hessenberg */
+/* form. Otherwise ILO and IHI should be set to 1 and N */
+/* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */
+/* If N = 0, then ILO = 1 and IHI = 0. */
+
+/* H (input/output) COMPLEX array, dimension (LDH,N) */
+/* On entry, the upper Hessenberg matrix H. */
+/* On exit, if INFO = 0 and JOB = 'S', H contains the upper */
+/* triangular matrix T from the Schur decomposition (the */
+/* Schur form). If INFO = 0 and JOB = 'E', the contents of */
+/* H are unspecified on exit. (The output value of H when */
+/* INFO.GT.0 is given under the description of INFO below.) */
+
+/* Unlike earlier versions of CHSEQR, this subroutine may */
+/* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 */
+/* or j = IHI+1, IHI+2, ... N. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH .GE. max(1,N). */
+
+/* W (output) COMPLEX array, dimension (N) */
+/* The computed eigenvalues. If JOB = 'S', the eigenvalues are */
+/* stored in the same order as on the diagonal of the Schur */
+/* form returned in H, with W(i) = H(i,i). */
+
+/* Z (input/output) COMPLEX array, dimension (LDZ,N) */
+/* If COMPZ = 'N', Z is not referenced. */
+/* If COMPZ = 'I', on entry Z need not be set and on exit, */
+/* if INFO = 0, Z contains the unitary matrix Z of the Schur */
+/* vectors of H. If COMPZ = 'V', on entry Z must contain an */
+/* N-by-N matrix Q, which is assumed to be equal to the unit */
+/* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, */
+/* if INFO = 0, Z contains Q*Z. */
+/* Normally Q is the unitary matrix generated by CUNGHR */
+/* after the call to CGEHRD which formed the Hessenberg matrix */
+/* H. (The output value of Z when INFO.GT.0 is given under */
+/* the description of INFO below.) */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. if COMPZ = 'I' or */
+/* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns an estimate of */
+/* the optimal value for LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK .GE. max(1,N) */
+/* is sufficient and delivers very good and sometimes */
+/* optimal performance. However, LWORK as large as 11*N */
+/* may be required for optimal performance. A workspace */
+/* query is recommended to determine the optimal workspace */
+/* size. */
+
+/* If LWORK = -1, then CHSEQR does a workspace query. */
+/* In this case, CHSEQR checks the input parameters and */
+/* estimates the optimal workspace size for the given */
+/* values of N, ILO and IHI. The estimate is returned */
+/* in WORK(1). No error message related to LWORK is */
+/* issued by XERBLA. Neither H nor Z are accessed. */
+
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* .LT. 0: if INFO = -i, the i-th argument had an illegal */
+/* value */
+/* .GT. 0: if INFO = i, CHSEQR failed to compute all of */
+/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */
+/* and WI contain those eigenvalues which have been */
+/* successfully computed. (Failures are rare.) */
+
+/* If INFO .GT. 0 and JOB = 'E', then on exit, the */
+/* remaining unconverged eigenvalues are the eigen- */
+/* values of the upper Hessenberg matrix rows and */
+/* columns ILO through INFO of the final, output */
+/* value of H. */
+
+/* If INFO .GT. 0 and JOB = 'S', then on exit */
+
+/* (*) (initial value of H)*U = U*(final value of H) */
+
+/* where U is a unitary matrix. The final */
+/* value of H is upper Hessenberg and triangular in */
+/* rows and columns INFO+1 through IHI. */
+
+/* If INFO .GT. 0 and COMPZ = 'V', then on exit */
+
+/* (final value of Z) = (initial value of Z)*U */
+
+/* where U is the unitary matrix in (*) (regard- */
+/* less of the value of JOB.) */
+
+/* If INFO .GT. 0 and COMPZ = 'I', then on exit */
+/* (final value of Z) = U */
+/* where U is the unitary matrix in (*) (regard- */
+/* less of the value of JOB.) */
+
+/* If INFO .GT. 0 and COMPZ = 'N', then Z is not */
+/* accessed. */
+
+/* ================================================================ */
+/* Default values supplied by */
+/* ILAENV(ISPEC,'CHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). */
+/* It is suggested that these defaults be adjusted in order */
+/* to attain best performance in each particular */
+/* computational environment. */
+
+/* ISPEC=12: The CLAHQR vs CLAQR0 crossover point. */
+/* Default: 75. (Must be at least 11.) */
+
+/* ISPEC=13: Recommended deflation window size. */
+/* This depends on ILO, IHI and NS. NS is the */
+/* number of simultaneous shifts returned */
+/* by ILAENV(ISPEC=15). (See ISPEC=15 below.) */
+/* The default for (IHI-ILO+1).LE.500 is NS. */
+/* The default for (IHI-ILO+1).GT.500 is 3*NS/2. */
+
+/* ISPEC=14: Nibble crossover point. (See IPARMQ for */
+/* details.) Default: 14% of deflation window */
+/* size. */
+
+/* ISPEC=15: Number of simultaneous shifts in a multishift */
+/* QR iteration. */
+
+/* If IHI-ILO+1 is ... */
+
+/* greater than ...but less ... the */
+/* or equal to ... than default is */
+
+/* 1 30 NS = 2(+) */
+/* 30 60 NS = 4(+) */
+/* 60 150 NS = 10(+) */
+/* 150 590 NS = ** */
+/* 590 3000 NS = 64 */
+/* 3000 6000 NS = 128 */
+/* 6000 infinity NS = 256 */
+
+/* (+) By default some or all matrices of this order */
+/* are passed to the implicit double shift routine */
+/* CLAHQR and this parameter is ignored. See */
+/* ISPEC=12 above and comments in IPARMQ for */
+/* details. */
+
+/* (**) The asterisks (**) indicate an ad-hoc */
+/* function of N increasing from 10 to 64. */
+
+/* ISPEC=16: Select structured matrix multiply. */
+/* If the number of simultaneous shifts (specified */
+/* by ISPEC=15) is less than 14, then the default */
+/* for ISPEC=16 is 0. Otherwise the default for */
+/* ISPEC=16 is 2. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* References: */
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */
+/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */
+/* 929--947, 2002. */
+
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */
+/* of Matrix Analysis, volume 23, pages 948--973, 2002. */
+
+/* ================================================================ */
+/* .. Parameters .. */
+
+/* ==== Matrices of order NTINY or smaller must be processed by */
+/* . CLAHQR because of insufficient subdiagonal scratch space. */
+/* . (This is a hard limit.) ==== */
+
+/* ==== NL allocates some local workspace to help small matrices */
+/* . through a rare CLAHQR failure. NL .GT. NTINY = 11 is */
+/* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- */
+/* . mended. (The default value of NMIN is 75.) Using NL = 49 */
+/* . allows up to six simultaneous shifts and a 16-by-16 */
+/* . deflation window. ==== */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* ==== Decode and check the input parameters. ==== */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ wantt = lsame_(job, "S");
+ initz = lsame_(compz, "I");
+ wantz = initz || lsame_(compz, "V");
+ r__1 = (real) max(1,*n);
+ q__1.r = r__1, q__1.i = 0.f;
+ work[1].r = q__1.r, work[1].i = q__1.i;
+ lquery = *lwork == -1;
+
+ *info = 0;
+ if (! lsame_(job, "E") && ! wantt) {
+ *info = -1;
+ } else if (! lsame_(compz, "N") && ! wantz) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ilo < 1 || *ilo > max(1,*n)) {
+ *info = -4;
+ } else if (*ihi < min(*ilo,*n) || *ihi > *n) {
+ *info = -5;
+ } else if (*ldh < max(1,*n)) {
+ *info = -7;
+ } else if (*ldz < 1 || wantz && *ldz < max(1,*n)) {
+ *info = -10;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -12;
+ }
+
+ if (*info != 0) {
+
+/* ==== Quick return in case of invalid argument. ==== */
+
+ i__1 = -(*info);
+ xerbla_("CHSEQR", &i__1);
+ return 0;
+
+ } else if (*n == 0) {
+
+/* ==== Quick return in case N = 0; nothing to do. ==== */
+
+ return 0;
+
+ } else if (lquery) {
+
+/* ==== Quick return in case of a workspace query ==== */
+
+ claqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1], ilo,
+ ihi, &z__[z_offset], ldz, &work[1], lwork, info);
+/* ==== Ensure reported workspace size is backward-compatible with */
+/* . previous LAPACK versions. ==== */
+/* Computing MAX */
+ r__2 = work[1].r, r__3 = (real) max(1,*n);
+ r__1 = dmax(r__2,r__3);
+ q__1.r = r__1, q__1.i = 0.f;
+ work[1].r = q__1.r, work[1].i = q__1.i;
+ return 0;
+
+ } else {
+
+/* ==== copy eigenvalues isolated by CGEBAL ==== */
+
+ if (*ilo > 1) {
+ i__1 = *ilo - 1;
+ i__2 = *ldh + 1;
+ ccopy_(&i__1, &h__[h_offset], &i__2, &w[1], &c__1);
+ }
+ if (*ihi < *n) {
+ i__1 = *n - *ihi;
+ i__2 = *ldh + 1;
+ ccopy_(&i__1, &h__[*ihi + 1 + (*ihi + 1) * h_dim1], &i__2, &w[*
+ ihi + 1], &c__1);
+ }
+
+/* ==== Initialize Z, if requested ==== */
+
+ if (initz) {
+ claset_("A", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
+ }
+
+/* ==== Quick return if possible ==== */
+
+ if (*ilo == *ihi) {
+ i__1 = *ilo;
+ i__2 = *ilo + *ilo * h_dim1;
+ w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
+ return 0;
+ }
+
+/* ==== CLAHQR/CLAQR0 crossover point ==== */
+
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = job;
+ i__3[1] = 1, a__1[1] = compz;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ nmin = ilaenv_(&c__12, "CHSEQR", ch__1, n, ilo, ihi, lwork);
+ nmin = max(11,nmin);
+
+/* ==== CLAQR0 for big matrices; CLAHQR for small ones ==== */
+
+ if (*n > nmin) {
+ claqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1],
+ ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, info);
+ } else {
+
+/* ==== Small matrix ==== */
+
+ clahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1],
+ ilo, ihi, &z__[z_offset], ldz, info);
+
+ if (*info > 0) {
+
+/* ==== A rare CLAHQR failure! CLAQR0 sometimes succeeds */
+/* . when CLAHQR fails. ==== */
+
+ kbot = *info;
+
+ if (*n >= 49) {
+
+/* ==== Larger matrices have enough subdiagonal scratch */
+/* . space to call CLAQR0 directly. ==== */
+
+ claqr0_(&wantt, &wantz, n, ilo, &kbot, &h__[h_offset],
+ ldh, &w[1], ilo, ihi, &z__[z_offset], ldz, &work[
+ 1], lwork, info);
+
+ } else {
+
+/* ==== Tiny matrices don't have enough subdiagonal */
+/* . scratch space to benefit from CLAQR0. Hence, */
+/* . tiny matrices must be copied into a larger */
+/* . array before calling CLAQR0. ==== */
+
+ clacpy_("A", n, n, &h__[h_offset], ldh, hl, &c__49);
+ i__1 = *n + 1 + *n * 49 - 50;
+ hl[i__1].r = 0.f, hl[i__1].i = 0.f;
+ i__1 = 49 - *n;
+ claset_("A", &c__49, &i__1, &c_b1, &c_b1, &hl[(*n + 1) *
+ 49 - 49], &c__49);
+ claqr0_(&wantt, &wantz, &c__49, ilo, &kbot, hl, &c__49, &
+ w[1], ilo, ihi, &z__[z_offset], ldz, workl, &
+ c__49, info);
+ if (wantt || *info != 0) {
+ clacpy_("A", n, n, hl, &c__49, &h__[h_offset], ldh);
+ }
+ }
+ }
+ }
+
+/* ==== Clear out the trash, if necessary. ==== */
+
+ if ((wantt || *info != 0) && *n > 2) {
+ i__1 = *n - 2;
+ i__2 = *n - 2;
+ claset_("L", &i__1, &i__2, &c_b1, &c_b1, &h__[h_dim1 + 3], ldh);
+ }
+
+/* ==== Ensure reported workspace size is backward-compatible with */
+/* . previous LAPACK versions. ==== */
+
+/* Computing MAX */
+ r__2 = (real) max(1,*n), r__3 = work[1].r;
+ r__1 = dmax(r__2,r__3);
+ q__1.r = r__1, q__1.i = 0.f;
+ work[1].r = q__1.r, work[1].i = q__1.i;
+ }
+
+/* ==== End of CHSEQR ==== */
+
+ return 0;
+} /* chseqr_ */
diff --git a/SRC/cla_gbamv.c b/SRC/cla_gbamv.c
new file mode 100644
index 0000000..8e271d8
--- /dev/null
+++ b/SRC/cla_gbamv.c
@@ -0,0 +1,336 @@
+/* cla_gbamv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cla_gbamv__(integer *trans, integer *m, integer *n,
+ integer *kl, integer *ku, real *alpha, complex *ab, integer *ldab,
+ complex *x, integer *incx, real *beta, real *y, integer *incy)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double r_imag(complex *), r_sign(real *, real *);
+
+ /* Local variables */
+ extern integer ilatrans_(char *);
+ integer i__, j;
+ logical symb_zero__;
+ integer kd, iy, jx, kx, ky, info;
+ real temp;
+ integer lenx, leny;
+ real safe1;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLA_GEAMV performs one of the matrix-vector operations */
+
+/* y := alpha*abs(A)*abs(x) + beta*abs(y), */
+/* or y := alpha*abs(A)'*abs(x) + beta*abs(y), */
+
+/* where alpha and beta are scalars, x and y are vectors and A is an */
+/* m by n matrix. */
+
+/* This function is primarily used in calculating error bounds. */
+/* To protect against underflow during evaluation, components in */
+/* the resulting vector are perturbed away from zero by (N+1) */
+/* times the underflow threshold. To prevent unnecessarily large */
+/* errors for block-structure embedded in general matrices, */
+/* "symbolically" zero components are not perturbed. A zero */
+/* entry is considered "symbolic" if all multiplications involved */
+/* in computing that entry have at least one zero multiplicand. */
+
+/* Parameters */
+/* ========== */
+
+/* TRANS - INTEGER */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) */
+/* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) */
+/* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER */
+/* On entry, M specifies the number of rows of the matrix A. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* KL - INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU - INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* ALPHA - REAL */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - REAL array of DIMENSION ( LDA, n ) */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+/* X - REAL array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - REAL */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - REAL array of DIMENSION at least */
+/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
+/* Before entry with BETA non-zero, the incremented array Y */
+/* must contain the vector y. On exit, Y is overwritten by the */
+/* updated vector y. */
+
+/* INCY - INTEGER */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! (*trans == ilatrans_("N") || *trans == ilatrans_("T") || *trans == ilatrans_("C"))) {
+ info = 1;
+ } else if (*m < 0) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*kl < 0) {
+ info = 4;
+ } else if (*ku < 0) {
+ info = 5;
+ } else if (*ldab < *kl + *ku + 1) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ } else if (*incy == 0) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("CLA_GBAMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || *alpha == 0.f && *beta == 1.f) {
+ return 0;
+ }
+
+/* Set LENX and LENY, the lengths of the vectors x and y, and set */
+/* up the start points in X and Y. */
+
+ if (*trans == ilatrans_("N")) {
+ lenx = *n;
+ leny = *m;
+ } else {
+ lenx = *m;
+ leny = *n;
+ }
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (lenx - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (leny - 1) * *incy;
+ }
+
+/* Set SAFE1 essentially to be the underflow threshold times the */
+/* number of additions in each row. */
+
+ safe1 = slamch_("Safe minimum");
+ safe1 = (*n + 1) * safe1;
+
+/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */
+
+/* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to */
+/* the inexact flag. Still doesn't help change the iteration order */
+/* to per-column. */
+
+ kd = *ku + 1;
+ iy = ky;
+ if (*incx == 1) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.f) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.f;
+ } else if (y[iy] == 0.f) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (r__1 = y[iy], dabs(r__1));
+ }
+ if (*alpha != 0.f) {
+/* Computing MAX */
+ i__2 = i__ - *ku;
+/* Computing MIN */
+ i__4 = i__ + *kl;
+ i__3 = min(i__4,lenx);
+ for (j = max(i__2,1); j <= i__3; ++j) {
+ if (*trans == ilatrans_("N")) {
+ i__2 = kd + i__ - j + j * ab_dim1;
+ temp = (r__1 = ab[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&ab[kd + i__ - j + j * ab_dim1]), dabs(
+ r__2));
+ } else {
+ i__2 = j + (kd + i__ - j) * ab_dim1;
+ temp = (r__1 = ab[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&ab[j + (kd + i__ - j) * ab_dim1]),
+ dabs(r__2));
+ }
+ i__2 = j;
+ symb_zero__ = symb_zero__ && (x[i__2].r == 0.f && x[i__2]
+ .i == 0.f || temp == 0.f);
+ i__2 = j;
+ y[iy] += *alpha * ((r__1 = x[i__2].r, dabs(r__1)) + (r__2
+ = r_imag(&x[j]), dabs(r__2))) * temp;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += r_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.f) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.f;
+ } else if (y[iy] == 0.f) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (r__1 = y[iy], dabs(r__1));
+ }
+ if (*alpha != 0.f) {
+ jx = kx;
+/* Computing MAX */
+ i__3 = i__ - *ku;
+/* Computing MIN */
+ i__4 = i__ + *kl;
+ i__2 = min(i__4,lenx);
+ for (j = max(i__3,1); j <= i__2; ++j) {
+ if (*trans == ilatrans_("N")) {
+ i__3 = kd + i__ - j + j * ab_dim1;
+ temp = (r__1 = ab[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&ab[kd + i__ - j + j * ab_dim1]), dabs(
+ r__2));
+ } else {
+ i__3 = j + (kd + i__ - j) * ab_dim1;
+ temp = (r__1 = ab[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&ab[j + (kd + i__ - j) * ab_dim1]),
+ dabs(r__2));
+ }
+ i__3 = jx;
+ symb_zero__ = symb_zero__ && (x[i__3].r == 0.f && x[i__3]
+ .i == 0.f || temp == 0.f);
+ i__3 = jx;
+ y[iy] += *alpha * ((r__1 = x[i__3].r, dabs(r__1)) + (r__2
+ = r_imag(&x[jx]), dabs(r__2))) * temp;
+ jx += *incx;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += r_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ }
+
+ return 0;
+
+/* End of CLA_GBAMV */
+
+} /* cla_gbamv__ */
diff --git a/SRC/cla_gbrcond_c.c b/SRC/cla_gbrcond_c.c
new file mode 100644
index 0000000..172784a
--- /dev/null
+++ b/SRC/cla_gbrcond_c.c
@@ -0,0 +1,349 @@
+/* cla_gbrcond_c.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal cla_gbrcond_c__(char *trans, integer *n, integer *kl, integer *ku,
+ complex *ab, integer *ldab, complex *afb, integer *ldafb, integer *
+ ipiv, real *c__, logical *capply, integer *info, complex *work, real *
+ rwork, ftnlen trans_len)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, i__1, i__2, i__3, i__4;
+ real ret_val, r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, kd, ke;
+ real tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ real anorm;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *), xerbla_(char *, integer *),
+ cgbtrs_(char *, integer *, integer *, integer *, integer *,
+ complex *, integer *, integer *, complex *, integer *, integer *);
+ real ainvnm;
+ logical notrans;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_GBRCOND_C Computes the infinity norm condition number of */
+/* op(A) * inv(diag(C)) where C is a REAL vector. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input) COMPLEX array, dimension (LDAFB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by CGBTRF. U is stored as an upper triangular */
+/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */
+/* and the multipliers used during the factorization are stored */
+/* in rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from the factorization A = P*L*U */
+/* as computed by CGBTRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* C (input) REAL array, dimension (N) */
+/* The vector C in the formula op(A) * inv(diag(C)). */
+
+/* CAPPLY (input) LOGICAL */
+/* If .TRUE. then access the vector C in the formula above. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) COMPLEX array, dimension (2*N). */
+/* Workspace. */
+
+/* RWORK (input) REAL array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ --c__;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ *info = 0;
+ notrans = lsame_(trans, "N");
+ if (! notrans && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0 || *kl > *n - 1) {
+ *info = -3;
+ } else if (*ku < 0 || *ku > *n - 1) {
+ *info = -4;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -6;
+ } else if (*ldafb < (*kl << 1) + *ku + 1) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLA_GBRCOND_C", &i__1);
+ return ret_val;
+ }
+
+/* Compute norm of op(A)*op2(C). */
+
+ anorm = 0.f;
+ kd = *ku + 1;
+ ke = *kl + 1;
+ if (notrans) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ if (*capply) {
+/* Computing MAX */
+ i__2 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__3 = min(i__4,*n);
+ for (j = max(i__2,1); j <= i__3; ++j) {
+ i__2 = kd + i__ - j + j * ab_dim1;
+ tmp += ((r__1 = ab[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
+ ab[kd + i__ - j + j * ab_dim1]), dabs(r__2))) /
+ c__[j];
+ }
+ } else {
+/* Computing MAX */
+ i__3 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__2 = min(i__4,*n);
+ for (j = max(i__3,1); j <= i__2; ++j) {
+ i__3 = kd + i__ - j + j * ab_dim1;
+ tmp += (r__1 = ab[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ ab[kd + i__ - j + j * ab_dim1]), dabs(r__2));
+ }
+ }
+ rwork[i__] = tmp;
+ anorm = dmax(anorm,tmp);
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ if (*capply) {
+/* Computing MAX */
+ i__2 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__3 = min(i__4,*n);
+ for (j = max(i__2,1); j <= i__3; ++j) {
+ i__2 = ke - i__ + j + i__ * ab_dim1;
+ tmp += ((r__1 = ab[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
+ ab[ke - i__ + j + i__ * ab_dim1]), dabs(r__2))) /
+ c__[j];
+ }
+ } else {
+/* Computing MAX */
+ i__3 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__2 = min(i__4,*n);
+ for (j = max(i__3,1); j <= i__2; ++j) {
+ i__3 = ke - i__ + j + i__ * ab_dim1;
+ tmp += (r__1 = ab[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ ab[ke - i__ + j + i__ * ab_dim1]), dabs(r__2));
+ }
+ }
+ rwork[i__] = tmp;
+ anorm = dmax(anorm,tmp);
+ }
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ ret_val = 1.f;
+ return ret_val;
+ } else if (anorm == 0.f) {
+ return ret_val;
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.f;
+
+ kase = 0;
+L10:
+ clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__4] * work[i__3].r, q__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+
+ if (notrans) {
+ cgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset],
+ ldafb, &ipiv[1], &work[1], n, info);
+ } else {
+ cgbtrs_("Conjugate transpose", n, kl, ku, &c__1, &afb[
+ afb_offset], ldafb, &ipiv[1], &work[1], n, info);
+ }
+
+/* Multiply by inv(C). */
+
+ if (*capply) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = c__[i__4] * work[i__3].r, q__1.i = c__[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ }
+ } else {
+
+/* Multiply by inv(C'). */
+
+ if (*capply) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = c__[i__4] * work[i__3].r, q__1.i = c__[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ }
+
+ if (notrans) {
+ cgbtrs_("Conjugate transpose", n, kl, ku, &c__1, &afb[
+ afb_offset], ldafb, &ipiv[1], &work[1], n, info);
+ } else {
+ cgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset],
+ ldafb, &ipiv[1], &work[1], n, info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__4] * work[i__3].r, q__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ ret_val = 1.f / ainvnm;
+ }
+
+ return ret_val;
+
+} /* cla_gbrcond_c__ */
diff --git a/SRC/cla_gbrcond_x.c b/SRC/cla_gbrcond_x.c
new file mode 100644
index 0000000..5f82d1c
--- /dev/null
+++ b/SRC/cla_gbrcond_x.c
@@ -0,0 +1,320 @@
+/* cla_gbrcond_x.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal cla_gbrcond_x__(char *trans, integer *n, integer *kl, integer *ku,
+ complex *ab, integer *ldab, complex *afb, integer *ldafb, integer *
+ ipiv, complex *x, integer *info, complex *work, real *rwork, ftnlen
+ trans_len)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, i__1, i__2, i__3, i__4;
+ real ret_val, r__1, r__2;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, kd, ke;
+ real tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ real anorm;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *), xerbla_(char *, integer *),
+ cgbtrs_(char *, integer *, integer *, integer *, integer *,
+ complex *, integer *, integer *, complex *, integer *, integer *);
+ real ainvnm;
+ logical notrans;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_GBRCOND_X Computes the infinity norm condition number of */
+/* op(A) * diag(X) where X is a COMPLEX vector. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input) COMPLEX array, dimension (LDAFB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by CGBTRF. U is stored as an upper triangular */
+/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */
+/* and the multipliers used during the factorization are stored */
+/* in rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from the factorization A = P*L*U */
+/* as computed by CGBTRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* X (input) COMPLEX array, dimension (N) */
+/* The vector X in the formula op(A) * diag(X). */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) COMPLEX array, dimension (2*N). */
+/* Workspace. */
+
+/* RWORK (input) REAL array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ --x;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ *info = 0;
+ notrans = lsame_(trans, "N");
+ if (! notrans && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0 || *kl > *n - 1) {
+ *info = -3;
+ } else if (*ku < 0 || *ku > *n - 1) {
+ *info = -4;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -6;
+ } else if (*ldafb < (*kl << 1) + *ku + 1) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLA_GBRCOND_X", &i__1);
+ return ret_val;
+ }
+
+/* Compute norm of op(A)*op2(C). */
+
+ kd = *ku + 1;
+ ke = *kl + 1;
+ anorm = 0.f;
+ if (notrans) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+/* Computing MAX */
+ i__2 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__3 = min(i__4,*n);
+ for (j = max(i__2,1); j <= i__3; ++j) {
+ i__2 = kd + i__ - j + j * ab_dim1;
+ i__4 = j;
+ q__2.r = ab[i__2].r * x[i__4].r - ab[i__2].i * x[i__4].i,
+ q__2.i = ab[i__2].r * x[i__4].i + ab[i__2].i * x[i__4]
+ .r;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ tmp += (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
+ dabs(r__2));
+ }
+ rwork[i__] = tmp;
+ anorm = dmax(anorm,tmp);
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+/* Computing MAX */
+ i__3 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__2 = min(i__4,*n);
+ for (j = max(i__3,1); j <= i__2; ++j) {
+ i__3 = ke - i__ + j + i__ * ab_dim1;
+ i__4 = j;
+ q__2.r = ab[i__3].r * x[i__4].r - ab[i__3].i * x[i__4].i,
+ q__2.i = ab[i__3].r * x[i__4].i + ab[i__3].i * x[i__4]
+ .r;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ tmp += (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
+ dabs(r__2));
+ }
+ rwork[i__] = tmp;
+ anorm = dmax(anorm,tmp);
+ }
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ ret_val = 1.f;
+ return ret_val;
+ } else if (anorm == 0.f) {
+ return ret_val;
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.f;
+
+ kase = 0;
+L10:
+ clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__4] * work[i__3].r, q__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+
+ if (notrans) {
+ cgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset],
+ ldafb, &ipiv[1], &work[1], n, info);
+ } else {
+ cgbtrs_("Conjugate transpose", n, kl, ku, &c__1, &afb[
+ afb_offset], ldafb, &ipiv[1], &work[1], n, info);
+ }
+
+/* Multiply by inv(X). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ c_div(&q__1, &work[i__], &x[i__]);
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ } else {
+
+/* Multiply by inv(X'). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ c_div(&q__1, &work[i__], &x[i__]);
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+
+ if (notrans) {
+ cgbtrs_("Conjugate transpose", n, kl, ku, &c__1, &afb[
+ afb_offset], ldafb, &ipiv[1], &work[1], n, info);
+ } else {
+ cgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset],
+ ldafb, &ipiv[1], &work[1], n, info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__4] * work[i__3].r, q__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ ret_val = 1.f / ainvnm;
+ }
+
+ return ret_val;
+
+} /* cla_gbrcond_x__ */
diff --git a/SRC/cla_gbrfsx_extended.c b/SRC/cla_gbrfsx_extended.c
new file mode 100644
index 0000000..f56b249
--- /dev/null
+++ b/SRC/cla_gbrfsx_extended.c
@@ -0,0 +1,643 @@
+/* cla_gbrfsx_extended.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static complex c_b6 = {-1.f,0.f};
+static complex c_b8 = {1.f,0.f};
+static real c_b31 = 1.f;
+
+/* Subroutine */ int cla_gbrfsx_extended__(integer *prec_type__, integer *
+ trans_type__, integer *n, integer *kl, integer *ku, integer *nrhs,
+ complex *ab, integer *ldab, complex *afb, integer *ldafb, integer *
+ ipiv, logical *colequ, real *c__, complex *b, integer *ldb, complex *
+ y, integer *ldy, real *berr_out__, integer *n_norms__, real *
+ err_bnds_norm__, real *err_bnds_comp__, complex *res, real *ayb,
+ complex *dy, complex *y_tail__, real *rcond, integer *ithresh, real *
+ rthresh, real *dz_ub__, logical *ignore_cwise__, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ y_dim1, y_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2;
+ char ch__1[1];
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ real dxratmax, dzratmax;
+ integer i__, j, m;
+ extern /* Subroutine */ int cla_gbamv__(integer *, integer *, integer *,
+ integer *, integer *, real *, complex *, integer *, complex *,
+ integer *, real *, real *, integer *);
+ logical incr_prec__;
+ real prev_dz_z__, yk, final_dx_x__;
+ extern /* Subroutine */ int cla_wwaddw__(integer *, complex *, complex *,
+ complex *);
+ real final_dz_z__, prevnormdx;
+ integer cnt;
+ real dyk, eps, incr_thresh__, dx_x__, dz_z__;
+ extern /* Subroutine */ int cla_lin_berr__(integer *, integer *, integer *
+ , complex *, real *, real *);
+ real ymin;
+ extern /* Subroutine */ int blas_cgbmv_x__(integer *, integer *, integer *
+ , integer *, integer *, complex *, complex *, integer *, complex *
+ , integer *, complex *, complex *, integer *, integer *);
+ integer y_prec_state__;
+ extern /* Subroutine */ int blas_cgbmv2_x__(integer *, integer *, integer
+ *, integer *, integer *, complex *, complex *, integer *, complex
+ *, complex *, integer *, complex *, complex *, integer *, integer
+ *), cgbmv_(char *, integer *, integer *, integer *, integer *,
+ complex *, complex *, integer *, complex *, integer *, complex *,
+ complex *, integer *), ccopy_(integer *, complex *,
+ integer *, complex *, integer *);
+ real dxrat, dzrat;
+ extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ char trans[1];
+ real normx, normy;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int cgbtrs_(char *, integer *, integer *, integer
+ *, integer *, complex *, integer *, integer *, complex *, integer
+ *, integer *);
+ real normdx;
+ extern /* Character */ VOID chla_transtype__(char *, ftnlen, integer *);
+ real hugeval;
+ integer x_state__, z_state__;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_GBRFSX_EXTENDED improves the computed solution to a system of */
+/* linear equations by performing extra-precise iterative refinement */
+/* and provides error bounds and backward error estimates for the solution. */
+/* This subroutine is called by CGBRFSX to perform iterative refinement. */
+/* In addition to normwise error bound, the code provides maximum */
+/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP for details of the error bounds. Note that this */
+/* subroutine is only resonsible for setting the second fields of */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP. */
+
+/* Arguments */
+/* ========= */
+
+/* PREC_TYPE (input) INTEGER */
+/* Specifies the intermediate precision to be used in refinement. */
+/* The value is defined by ILAPREC(P) where P is a CHARACTER and */
+/* P = 'S': Single */
+/* = 'D': Double */
+/* = 'I': Indigenous */
+/* = 'X', 'E': Extra */
+
+/* TRANS_TYPE (input) INTEGER */
+/* Specifies the transposition operation on A. */
+/* The value is defined by ILATRANS(T) where T is a CHARACTER and */
+/* T = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0 */
+
+/* NRHS (input) INTEGER */
+/* The number of right-hand-sides, i.e., the number of columns of the */
+/* matrix B. */
+
+/* AB (input) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AFB (input) COMPLEX array, dimension (LDAF,N) */
+/* The factors L and U from the factorization */
+/* A = P*L*U as computed by CGBTRF. */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from the factorization A = P*L*U */
+/* as computed by CGBTRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* COLEQU (input) LOGICAL */
+/* If .TRUE. then column equilibration was done to A before calling */
+/* this routine. This is needed to compute the solution and error */
+/* bounds correctly. */
+
+/* C (input) REAL array, dimension (N) */
+/* The column scale factors for A. If COLEQU = .FALSE., C */
+/* is not accessed. If C is input, each element of C should be a power */
+/* of the radix to ensure a reliable solution and error estimates. */
+/* Scaling by powers of the radix does not cause rounding errors unless */
+/* the result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right-hand-side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Y (input/output) COMPLEX array, dimension (LDY,NRHS) */
+/* On entry, the solution matrix X, as computed by CGBTRS. */
+/* On exit, the improved solution matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= max(1,N). */
+
+/* BERR_OUT (output) REAL array, dimension (NRHS) */
+/* On exit, BERR_OUT(j) contains the componentwise relative backward */
+/* error for right-hand-side j from the formula */
+/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. This is computed by CLA_LIN_BERR. */
+
+/* N_NORMS (input) INTEGER */
+/* Determines which error bounds to return (see ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP). */
+/* If N_NORMS >= 1 return normwise error bounds. */
+/* If N_NORMS >= 2 return componentwise error bounds. */
+
+/* ERR_BNDS_NORM (input/output) REAL array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (input/output) REAL array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* RES (input) COMPLEX array, dimension (N) */
+/* Workspace to hold the intermediate residual. */
+
+/* AYB (input) REAL array, dimension (N) */
+/* Workspace. */
+
+/* DY (input) COMPLEX array, dimension (N) */
+/* Workspace to hold the intermediate solution. */
+
+/* Y_TAIL (input) COMPLEX array, dimension (N) */
+/* Workspace to hold the trailing bits of the intermediate solution. */
+
+/* RCOND (input) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* ITHRESH (input) INTEGER */
+/* The maximum number of residual computations allowed for */
+/* refinement. The default is 10. For 'aggressive' set to 100 to */
+/* permit convergence using approximate factorizations or */
+/* factorizations other than LU. If the factorization uses a */
+/* technique other than Gaussian elimination, the guarantees in */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */
+
+/* RTHRESH (input) REAL */
+/* Determines when to stop refinement if the error estimate stops */
+/* decreasing. Refinement will stop when the next solution no longer */
+/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */
+/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */
+/* default value is 0.5. For 'aggressive' set to 0.9 to permit */
+/* convergence on extremely ill-conditioned matrices. See LAWN 165 */
+/* for more details. */
+
+/* DZ_UB (input) REAL */
+/* Determines when to start considering componentwise convergence. */
+/* Componentwise convergence is only considered after each component */
+/* of the solution Y is stable, which we definte as the relative */
+/* change in each component being less than DZ_UB. The default value */
+/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */
+/* more details. */
+
+/* IGNORE_CWISE (input) LOGICAL */
+/* If .TRUE. then ignore componentwise convergence. Default value */
+/* is .FALSE.. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* < 0: if INFO = -i, the ith argument to CGBTRS had an illegal */
+/* value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions.. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ --berr_out__;
+ --res;
+ --ayb;
+ --dy;
+ --y_tail__;
+
+ /* Function Body */
+ if (*info != 0) {
+ return 0;
+ }
+ chla_transtype__(ch__1, (ftnlen)1, trans_type__);
+ *(unsigned char *)trans = *(unsigned char *)&ch__1[0];
+ eps = slamch_("Epsilon");
+ hugeval = slamch_("Overflow");
+/* Force HUGEVAL to Inf */
+ hugeval *= hugeval;
+/* Using HUGEVAL may lead to spurious underflows. */
+ incr_thresh__ = (real) (*n) * eps;
+ m = *kl + *ku + 1;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ y_prec_state__ = 1;
+ if (y_prec_state__ == 2) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ y_tail__[i__3].r = 0.f, y_tail__[i__3].i = 0.f;
+ }
+ }
+ dxrat = 0.f;
+ dxratmax = 0.f;
+ dzrat = 0.f;
+ dzratmax = 0.f;
+ final_dx_x__ = hugeval;
+ final_dz_z__ = hugeval;
+ prevnormdx = hugeval;
+ prev_dz_z__ = hugeval;
+ dz_z__ = hugeval;
+ dx_x__ = hugeval;
+ x_state__ = 1;
+ z_state__ = 0;
+ incr_prec__ = FALSE_;
+ i__2 = *ithresh;
+ for (cnt = 1; cnt <= i__2; ++cnt) {
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ if (y_prec_state__ == 0) {
+ cgbmv_(trans, &m, n, kl, ku, &c_b6, &ab[ab_offset], ldab, &y[
+ j * y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1);
+ } else if (y_prec_state__ == 1) {
+ blas_cgbmv_x__(trans_type__, n, n, kl, ku, &c_b6, &ab[
+ ab_offset], ldab, &y[j * y_dim1 + 1], &c__1, &c_b8, &
+ res[1], &c__1, prec_type__);
+ } else {
+ blas_cgbmv2_x__(trans_type__, n, n, kl, ku, &c_b6, &ab[
+ ab_offset], ldab, &y[j * y_dim1 + 1], &y_tail__[1], &
+ c__1, &c_b8, &res[1], &c__1, prec_type__);
+ }
+/* XXX: RES is no longer needed. */
+ ccopy_(n, &res[1], &c__1, &dy[1], &c__1);
+ cgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1]
+, &dy[1], n, info);
+
+/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
+
+ normx = 0.f;
+ normy = 0.f;
+ normdx = 0.f;
+ dz_z__ = 0.f;
+ ymin = hugeval;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * y_dim1;
+ yk = (r__1 = y[i__4].r, dabs(r__1)) + (r__2 = r_imag(&y[i__ +
+ j * y_dim1]), dabs(r__2));
+ i__4 = i__;
+ dyk = (r__1 = dy[i__4].r, dabs(r__1)) + (r__2 = r_imag(&dy[
+ i__]), dabs(r__2));
+ if (yk != 0.f) {
+/* Computing MAX */
+ r__1 = dz_z__, r__2 = dyk / yk;
+ dz_z__ = dmax(r__1,r__2);
+ } else if (dyk != 0.f) {
+ dz_z__ = hugeval;
+ }
+ ymin = dmin(ymin,yk);
+ normy = dmax(normy,yk);
+ if (*colequ) {
+/* Computing MAX */
+ r__1 = normx, r__2 = yk * c__[i__];
+ normx = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = normdx, r__2 = dyk * c__[i__];
+ normdx = dmax(r__1,r__2);
+ } else {
+ normx = normy;
+ normdx = dmax(normdx,dyk);
+ }
+ }
+ if (normx != 0.f) {
+ dx_x__ = normdx / normx;
+ } else if (normdx == 0.f) {
+ dx_x__ = 0.f;
+ } else {
+ dx_x__ = hugeval;
+ }
+ dxrat = normdx / prevnormdx;
+ dzrat = dz_z__ / prev_dz_z__;
+
+/* Check termination criteria. */
+
+ if (! (*ignore_cwise__) && ymin * *rcond < incr_thresh__ * normy
+ && y_prec_state__ < 2) {
+ incr_prec__ = TRUE_;
+ }
+ if (x_state__ == 3 && dxrat <= *rthresh) {
+ x_state__ = 1;
+ }
+ if (x_state__ == 1) {
+ if (dx_x__ <= eps) {
+ x_state__ = 2;
+ } else if (dxrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ x_state__ = 3;
+ }
+ } else {
+ if (dxrat > dxratmax) {
+ dxratmax = dxrat;
+ }
+ }
+ if (x_state__ > 1) {
+ final_dx_x__ = dx_x__;
+ }
+ }
+ if (z_state__ == 0 && dz_z__ <= *dz_ub__) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 3 && dzrat <= *rthresh) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 1) {
+ if (dz_z__ <= eps) {
+ z_state__ = 2;
+ } else if (dz_z__ > *dz_ub__) {
+ z_state__ = 0;
+ dzratmax = 0.f;
+ final_dz_z__ = hugeval;
+ } else if (dzrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ z_state__ = 3;
+ }
+ } else {
+ if (dzrat > dzratmax) {
+ dzratmax = dzrat;
+ }
+ }
+ if (z_state__ > 1) {
+ final_dz_z__ = dz_z__;
+ }
+ }
+
+/* Exit if both normwise and componentwise stopped working, */
+/* but if componentwise is unstable, let it go at least two */
+/* iterations. */
+
+ if (x_state__ != 1) {
+ if (*ignore_cwise__) {
+ goto L666;
+ }
+ if (z_state__ == 3 || z_state__ == 2) {
+ goto L666;
+ }
+ if (z_state__ == 0 && cnt > 1) {
+ goto L666;
+ }
+ }
+ if (incr_prec__) {
+ incr_prec__ = FALSE_;
+ ++y_prec_state__;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ y_tail__[i__4].r = 0.f, y_tail__[i__4].i = 0.f;
+ }
+ }
+ prevnormdx = normdx;
+ prev_dz_z__ = dz_z__;
+
+/* Update soluton. */
+
+ if (y_prec_state__ < 2) {
+ caxpy_(n, &c_b8, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
+ } else {
+ cla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
+ }
+ }
+/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */
+L666:
+
+/* Set final_* when cnt hits ithresh. */
+
+ if (x_state__ == 1) {
+ final_dx_x__ = dx_x__;
+ }
+ if (z_state__ == 1) {
+ final_dz_z__ = dz_z__;
+ }
+
+/* Compute error bounds. */
+
+ if (*n_norms__ >= 1) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / (
+ 1 - dxratmax);
+ }
+ if (*n_norms__ >= 2) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / (
+ 1 - dzratmax);
+ }
+
+/* Compute componentwise relative backward error from formula */
+/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. */
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ cgbmv_(trans, n, n, kl, ku, &c_b6, &ab[ab_offset], ldab, &y[j *
+ y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ ayb[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[i__
+ + j * b_dim1]), dabs(r__2));
+ }
+
+/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */
+
+ cla_gbamv__(trans_type__, n, n, kl, ku, &c_b31, &ab[ab_offset], ldab,
+ &y[j * y_dim1 + 1], &c__1, &c_b31, &ayb[1], &c__1);
+ cla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
+
+/* End of loop for each RHS. */
+
+ }
+
+ return 0;
+} /* cla_gbrfsx_extended__ */
diff --git a/SRC/cla_gbrpvgrw.c b/SRC/cla_gbrpvgrw.c
new file mode 100644
index 0000000..2774b92
--- /dev/null
+++ b/SRC/cla_gbrpvgrw.c
@@ -0,0 +1,147 @@
+/* cla_gbrpvgrw.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal cla_gbrpvgrw__(integer *n, integer *kl, integer *ku, integer *
+ ncols, complex *ab, integer *ldab, complex *afb, integer *ldafb)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, i__1, i__2, i__3, i__4;
+ real ret_val, r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, kd;
+ real amax, umax, rpvgrw;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_GBRPVGRW computes the reciprocal pivot growth factor */
+/* norm(A)/norm(U). The "max absolute element" norm is used. If this is */
+/* much less than 1, the stability of the LU factorization of the */
+/* (equilibrated) matrix A could be poor. This also means that the */
+/* solution X, estimated condition numbers, and error bounds could be */
+/* unreliable. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NCOLS (input) INTEGER */
+/* The number of columns of the matrix A. NCOLS >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input) COMPLEX array, dimension (LDAFB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by CGBTRF. U is stored as an upper triangular */
+/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */
+/* and the multipliers used during the factorization are stored */
+/* in rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+
+ /* Function Body */
+ rpvgrw = 1.f;
+ kd = *ku + 1;
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ amax = 0.f;
+ umax = 0.f;
+/* Computing MAX */
+ i__2 = j - *ku;
+/* Computing MIN */
+ i__4 = j + *kl;
+ i__3 = min(i__4,*n);
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ i__2 = kd + i__ - j + j * ab_dim1;
+ r__3 = (r__1 = ab[i__2].r, dabs(r__1)) + (r__2 = r_imag(&ab[kd +
+ i__ - j + j * ab_dim1]), dabs(r__2));
+ amax = dmax(r__3,amax);
+ }
+/* Computing MAX */
+ i__3 = j - *ku;
+ i__2 = j;
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = kd + i__ - j + j * afb_dim1;
+ r__3 = (r__1 = afb[i__3].r, dabs(r__1)) + (r__2 = r_imag(&afb[kd
+ + i__ - j + j * afb_dim1]), dabs(r__2));
+ umax = dmax(r__3,umax);
+ }
+ if (umax != 0.f) {
+/* Computing MIN */
+ r__1 = amax / umax;
+ rpvgrw = dmin(r__1,rpvgrw);
+ }
+ }
+ ret_val = rpvgrw;
+ return ret_val;
+} /* cla_gbrpvgrw__ */
diff --git a/SRC/cla_geamv.c b/SRC/cla_geamv.c
new file mode 100644
index 0000000..11b1fff
--- /dev/null
+++ b/SRC/cla_geamv.c
@@ -0,0 +1,313 @@
+/* cla_geamv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cla_geamv__(integer *trans, integer *m, integer *n, real
+ *alpha, complex *a, integer *lda, complex *x, integer *incx, real *
+ beta, real *y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double r_imag(complex *), r_sign(real *, real *);
+
+ /* Local variables */
+ extern integer ilatrans_(char *);
+ integer i__, j;
+ logical symb_zero__;
+ integer iy, jx, kx, ky, info;
+ real temp;
+ integer lenx, leny;
+ real safe1;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_GEAMV performs one of the matrix-vector operations */
+
+/* y := alpha*abs(A)*abs(x) + beta*abs(y), */
+/* or y := alpha*abs(A)'*abs(x) + beta*abs(y), */
+
+/* where alpha and beta are scalars, x and y are vectors and A is an */
+/* m by n matrix. */
+
+/* This function is primarily used in calculating error bounds. */
+/* To protect against underflow during evaluation, components in */
+/* the resulting vector are perturbed away from zero by (N+1) */
+/* times the underflow threshold. To prevent unnecessarily large */
+/* errors for block-structure embedded in general matrices, */
+/* "symbolically" zero components are not perturbed. A zero */
+/* entry is considered "symbolic" if all multiplications involved */
+/* in computing that entry have at least one zero multiplicand. */
+
+/* Parameters */
+/* ========== */
+
+/* TRANS - INTEGER */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) */
+/* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) */
+/* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER */
+/* On entry, M specifies the number of rows of the matrix A. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, n ) */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - REAL */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - REAL array of DIMENSION at least */
+/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
+/* Before entry with BETA non-zero, the incremented array Y */
+/* must contain the vector y. On exit, Y is overwritten by the */
+/* updated vector y. */
+
+/* INCY - INTEGER */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! (*trans == ilatrans_("N") || *trans == ilatrans_("T") || *trans == ilatrans_("C"))) {
+ info = 1;
+ } else if (*m < 0) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*lda < max(1,*m)) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ } else if (*incy == 0) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("CLA_GEAMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || *alpha == 0.f && *beta == 1.f) {
+ return 0;
+ }
+
+/* Set LENX and LENY, the lengths of the vectors x and y, and set */
+/* up the start points in X and Y. */
+
+ if (*trans == ilatrans_("N")) {
+ lenx = *n;
+ leny = *m;
+ } else {
+ lenx = *m;
+ leny = *n;
+ }
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (lenx - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (leny - 1) * *incy;
+ }
+
+/* Set SAFE1 essentially to be the underflow threshold times the */
+/* number of additions in each row. */
+
+ safe1 = slamch_("Safe minimum");
+ safe1 = (*n + 1) * safe1;
+
+/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */
+
+/* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to */
+/* the inexact flag. Still doesn't help change the iteration order */
+/* to per-column. */
+
+ iy = ky;
+ if (*incx == 1) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.f) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.f;
+ } else if (y[iy] == 0.f) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (r__1 = y[iy], dabs(r__1));
+ }
+ if (*alpha != 0.f) {
+ i__2 = lenx;
+ for (j = 1; j <= i__2; ++j) {
+ if (*trans == ilatrans_("N")) {
+ i__3 = i__ + j * a_dim1;
+ temp = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ } else {
+ i__3 = j + i__ * a_dim1;
+ temp = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[j + i__ * a_dim1]), dabs(r__2));
+ }
+ i__3 = j;
+ symb_zero__ = symb_zero__ && (x[i__3].r == 0.f && x[i__3]
+ .i == 0.f || temp == 0.f);
+ i__3 = j;
+ y[iy] += *alpha * ((r__1 = x[i__3].r, dabs(r__1)) + (r__2
+ = r_imag(&x[j]), dabs(r__2))) * temp;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += r_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.f) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.f;
+ } else if (y[iy] == 0.f) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (r__1 = y[iy], dabs(r__1));
+ }
+ if (*alpha != 0.f) {
+ jx = kx;
+ i__2 = lenx;
+ for (j = 1; j <= i__2; ++j) {
+ if (*trans == ilatrans_("N")) {
+ i__3 = i__ + j * a_dim1;
+ temp = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ } else {
+ i__3 = j + i__ * a_dim1;
+ temp = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[j + i__ * a_dim1]), dabs(r__2));
+ }
+ i__3 = jx;
+ symb_zero__ = symb_zero__ && (x[i__3].r == 0.f && x[i__3]
+ .i == 0.f || temp == 0.f);
+ i__3 = jx;
+ y[iy] += *alpha * ((r__1 = x[i__3].r, dabs(r__1)) + (r__2
+ = r_imag(&x[jx]), dabs(r__2))) * temp;
+ jx += *incx;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += r_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ }
+
+ return 0;
+
+/* End of CLA_GEAMV */
+
+} /* cla_geamv__ */
diff --git a/SRC/cla_gercond_c.c b/SRC/cla_gercond_c.c
new file mode 100644
index 0000000..0d6476c
--- /dev/null
+++ b/SRC/cla_gercond_c.c
@@ -0,0 +1,307 @@
+/* cla_gercond_c.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal cla_gercond_c__(char *trans, integer *n, complex *a, integer *lda,
+ complex *af, integer *ldaf, integer *ipiv, real *c__, logical *capply,
+ integer *info, complex *work, real *rwork, ftnlen trans_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
+ real ret_val, r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j;
+ real tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ real anorm;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *), xerbla_(char *, integer *),
+ cgetrs_(char *, integer *, integer *, complex *, integer *,
+ integer *, complex *, integer *, integer *);
+ real ainvnm;
+ logical notrans;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Aguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_GERCOND_C computes the infinity norm condition number of */
+/* op(A) * inv(diag(C)) where C is a REAL vector. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The factors L and U from the factorization */
+/* A = P*L*U as computed by CGETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from the factorization A = P*L*U */
+/* as computed by CGETRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* C (input) REAL array, dimension (N) */
+/* The vector C in the formula op(A) * inv(diag(C)). */
+
+/* CAPPLY (input) LOGICAL */
+/* If .TRUE. then access the vector C in the formula above. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) COMPLEX array, dimension (2*N). */
+/* Workspace. */
+
+/* RWORK (input) REAL array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --c__;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ *info = 0;
+ notrans = lsame_(trans, "N");
+ if (! notrans && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLA_GERCOND_C", &i__1);
+ return ret_val;
+ }
+
+/* Compute norm of op(A)*op2(C). */
+
+ anorm = 0.f;
+ if (notrans) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ if (*capply) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[i__ + j * a_dim1]), dabs(r__2))) / c__[j];
+ }
+ } else {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ i__ + j * a_dim1]), dabs(r__2));
+ }
+ }
+ rwork[i__] = tmp;
+ anorm = dmax(anorm,tmp);
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ if (*capply) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[j + i__ * a_dim1]), dabs(r__2))) / c__[j];
+ }
+ } else {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ j + i__ * a_dim1]), dabs(r__2));
+ }
+ }
+ rwork[i__] = tmp;
+ anorm = dmax(anorm,tmp);
+ }
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ ret_val = 1.f;
+ return ret_val;
+ } else if (anorm == 0.f) {
+ return ret_val;
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.f;
+
+ kase = 0;
+L10:
+ clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__4] * work[i__3].r, q__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+
+ if (notrans) {
+ cgetrs_("No transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[
+ 1], &work[1], n, info);
+ } else {
+ cgetrs_("Conjugate transpose", n, &c__1, &af[af_offset], ldaf,
+ &ipiv[1], &work[1], n, info);
+ }
+
+/* Multiply by inv(C). */
+
+ if (*capply) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = c__[i__4] * work[i__3].r, q__1.i = c__[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ }
+ } else {
+
+/* Multiply by inv(C'). */
+
+ if (*capply) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = c__[i__4] * work[i__3].r, q__1.i = c__[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ }
+
+ if (notrans) {
+ cgetrs_("Conjugate transpose", n, &c__1, &af[af_offset], ldaf,
+ &ipiv[1], &work[1], n, info);
+ } else {
+ cgetrs_("No transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[
+ 1], &work[1], n, info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__4] * work[i__3].r, q__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ ret_val = 1.f / ainvnm;
+ }
+
+ return ret_val;
+
+} /* cla_gercond_c__ */
diff --git a/SRC/cla_gercond_x.c b/SRC/cla_gercond_x.c
new file mode 100644
index 0000000..11f440b
--- /dev/null
+++ b/SRC/cla_gercond_x.c
@@ -0,0 +1,287 @@
+/* cla_gercond_x.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal cla_gercond_x__(char *trans, integer *n, complex *a, integer *lda,
+ complex *af, integer *ldaf, integer *ipiv, complex *x, integer *info,
+ complex *work, real *rwork, ftnlen trans_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
+ real ret_val, r__1, r__2;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer i__, j;
+ real tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ real anorm;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *), xerbla_(char *, integer *),
+ cgetrs_(char *, integer *, integer *, complex *, integer *,
+ integer *, complex *, integer *, integer *);
+ real ainvnm;
+ logical notrans;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_GERCOND_X computes the infinity norm condition number of */
+/* op(A) * diag(X) where X is a COMPLEX vector. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The factors L and U from the factorization */
+/* A = P*L*U as computed by CGETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from the factorization A = P*L*U */
+/* as computed by CGETRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* X (input) COMPLEX array, dimension (N) */
+/* The vector X in the formula op(A) * diag(X). */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) COMPLEX array, dimension (2*N). */
+/* Workspace. */
+
+/* RWORK (input) REAL array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --x;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ *info = 0;
+ notrans = lsame_(trans, "N");
+ if (! notrans && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLA_GERCOND_X", &i__1);
+ return ret_val;
+ }
+
+/* Compute norm of op(A)*op2(C). */
+
+ anorm = 0.f;
+ if (notrans) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = j;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ q__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ tmp += (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
+ dabs(r__2));
+ }
+ rwork[i__] = tmp;
+ anorm = dmax(anorm,tmp);
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ i__4 = j;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ q__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ tmp += (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
+ dabs(r__2));
+ }
+ rwork[i__] = tmp;
+ anorm = dmax(anorm,tmp);
+ }
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ ret_val = 1.f;
+ return ret_val;
+ } else if (anorm == 0.f) {
+ return ret_val;
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.f;
+
+ kase = 0;
+L10:
+ clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+/* Multiply by R. */
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__4] * work[i__3].r, q__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+
+ if (notrans) {
+ cgetrs_("No transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[
+ 1], &work[1], n, info);
+ } else {
+ cgetrs_("Conjugate transpose", n, &c__1, &af[af_offset], ldaf,
+ &ipiv[1], &work[1], n, info);
+ }
+
+/* Multiply by inv(X). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ c_div(&q__1, &work[i__], &x[i__]);
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ } else {
+
+/* Multiply by inv(X'). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ c_div(&q__1, &work[i__], &x[i__]);
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+
+ if (notrans) {
+ cgetrs_("Conjugate transpose", n, &c__1, &af[af_offset], ldaf,
+ &ipiv[1], &work[1], n, info);
+ } else {
+ cgetrs_("No transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[
+ 1], &work[1], n, info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__4] * work[i__3].r, q__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ ret_val = 1.f / ainvnm;
+ }
+
+ return ret_val;
+
+} /* cla_gercond_x__ */
diff --git a/SRC/cla_gerfsx_extended.c b/SRC/cla_gerfsx_extended.c
new file mode 100644
index 0000000..b3174ae
--- /dev/null
+++ b/SRC/cla_gerfsx_extended.c
@@ -0,0 +1,632 @@
+/* cla_gerfsx_extended.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static complex c_b6 = {-1.f,0.f};
+static complex c_b8 = {1.f,0.f};
+static real c_b31 = 1.f;
+
+/* Subroutine */ int cla_gerfsx_extended__(integer *prec_type__, integer *
+ trans_type__, integer *n, integer *nrhs, complex *a, integer *lda,
+ complex *af, integer *ldaf, integer *ipiv, logical *colequ, real *c__,
+ complex *b, integer *ldb, complex *y, integer *ldy, real *berr_out__,
+ integer *n_norms__, real *errs_n__, real *errs_c__, complex *res,
+ real *ayb, complex *dy, complex *y_tail__, real *rcond, integer *
+ ithresh, real *rthresh, real *dz_ub__, logical *ignore_cwise__,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1,
+ y_offset, errs_n_dim1, errs_n_offset, errs_c_dim1, errs_c_offset,
+ i__1, i__2, i__3, i__4;
+ real r__1, r__2;
+ char ch__1[1];
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ real dxratmax, dzratmax;
+ integer i__, j;
+ extern /* Subroutine */ int cla_geamv__(integer *, integer *, integer *,
+ real *, complex *, integer *, complex *, integer *, real *, real *
+ , integer *);
+ logical incr_prec__;
+ real prev_dz_z__, yk, final_dx_x__;
+ extern /* Subroutine */ int cla_wwaddw__(integer *, complex *, complex *,
+ complex *);
+ real final_dz_z__, prevnormdx;
+ integer cnt;
+ real dyk, eps, incr_thresh__, dx_x__, dz_z__;
+ extern /* Subroutine */ int cla_lin_berr__(integer *, integer *, integer *
+ , complex *, real *, real *);
+ real ymin;
+ extern /* Subroutine */ int blas_cgemv_x__(integer *, integer *, integer *
+ , complex *, complex *, integer *, complex *, integer *, complex *
+ , complex *, integer *, integer *);
+ integer y_prec_state__;
+ extern /* Subroutine */ int blas_cgemv2_x__(integer *, integer *, integer
+ *, complex *, complex *, integer *, complex *, complex *, integer
+ *, complex *, complex *, integer *, integer *), cgemv_(char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *, complex *, complex *, integer *), ccopy_(
+ integer *, complex *, integer *, complex *, integer *);
+ real dxrat, dzrat;
+ extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ char trans[1];
+ real normx, normy;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int cgetrs_(char *, integer *, integer *, complex
+ *, integer *, integer *, complex *, integer *, integer *);
+ real normdx;
+ extern /* Character */ VOID chla_transtype__(char *, ftnlen, integer *);
+ real hugeval;
+ integer x_state__, z_state__;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_GERFSX_EXTENDED improves the computed solution to a system of */
+/* linear equations by performing extra-precise iterative refinement */
+/* and provides error bounds and backward error estimates for the solution. */
+/* This subroutine is called by CGERFSX to perform iterative refinement. */
+/* In addition to normwise error bound, the code provides maximum */
+/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP for details of the error bounds. Note that this */
+/* subroutine is only resonsible for setting the second fields of */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP. */
+
+/* Arguments */
+/* ========= */
+
+/* PREC_TYPE (input) INTEGER */
+/* Specifies the intermediate precision to be used in refinement. */
+/* The value is defined by ILAPREC(P) where P is a CHARACTER and */
+/* P = 'S': Single */
+/* = 'D': Double */
+/* = 'I': Indigenous */
+/* = 'X', 'E': Extra */
+
+/* TRANS_TYPE (input) INTEGER */
+/* Specifies the transposition operation on A. */
+/* The value is defined by ILATRANS(T) where T is a CHARACTER and */
+/* T = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right-hand-sides, i.e., the number of columns of the */
+/* matrix B. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The factors L and U from the factorization */
+/* A = P*L*U as computed by CGETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from the factorization A = P*L*U */
+/* as computed by CGETRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* COLEQU (input) LOGICAL */
+/* If .TRUE. then column equilibration was done to A before calling */
+/* this routine. This is needed to compute the solution and error */
+/* bounds correctly. */
+
+/* C (input) REAL array, dimension (N) */
+/* The column scale factors for A. If COLEQU = .FALSE., C */
+/* is not accessed. If C is input, each element of C should be a power */
+/* of the radix to ensure a reliable solution and error estimates. */
+/* Scaling by powers of the radix does not cause rounding errors unless */
+/* the result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right-hand-side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Y (input/output) COMPLEX array, dimension (LDY,NRHS) */
+/* On entry, the solution matrix X, as computed by CGETRS. */
+/* On exit, the improved solution matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= max(1,N). */
+
+/* BERR_OUT (output) REAL array, dimension (NRHS) */
+/* On exit, BERR_OUT(j) contains the componentwise relative backward */
+/* error for right-hand-side j from the formula */
+/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. This is computed by CLA_LIN_BERR. */
+
+/* N_NORMS (input) INTEGER */
+/* Determines which error bounds to return (see ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP). */
+/* If N_NORMS >= 1 return normwise error bounds. */
+/* If N_NORMS >= 2 return componentwise error bounds. */
+
+/* ERR_BNDS_NORM (input/output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (input/output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* RES (input) COMPLEX array, dimension (N) */
+/* Workspace to hold the intermediate residual. */
+
+/* AYB (input) REAL array, dimension (N) */
+/* Workspace. */
+
+/* DY (input) COMPLEX array, dimension (N) */
+/* Workspace to hold the intermediate solution. */
+
+/* Y_TAIL (input) COMPLEX array, dimension (N) */
+/* Workspace to hold the trailing bits of the intermediate solution. */
+
+/* RCOND (input) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* ITHRESH (input) INTEGER */
+/* The maximum number of residual computations allowed for */
+/* refinement. The default is 10. For 'aggressive' set to 100 to */
+/* permit convergence using approximate factorizations or */
+/* factorizations other than LU. If the factorization uses a */
+/* technique other than Gaussian elimination, the guarantees in */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */
+
+/* RTHRESH (input) REAL */
+/* Determines when to stop refinement if the error estimate stops */
+/* decreasing. Refinement will stop when the next solution no longer */
+/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */
+/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */
+/* default value is 0.5. For 'aggressive' set to 0.9 to permit */
+/* convergence on extremely ill-conditioned matrices. See LAWN 165 */
+/* for more details. */
+
+/* DZ_UB (input) REAL */
+/* Determines when to start considering componentwise convergence. */
+/* Componentwise convergence is only considered after each component */
+/* of the solution Y is stable, which we definte as the relative */
+/* change in each component being less than DZ_UB. The default value */
+/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */
+/* more details. */
+
+/* IGNORE_CWISE (input) LOGICAL */
+/* If .TRUE. then ignore componentwise convergence. Default value */
+/* is .FALSE.. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* < 0: if INFO = -i, the ith argument to CGETRS had an illegal */
+/* value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ errs_c_dim1 = *nrhs;
+ errs_c_offset = 1 + errs_c_dim1;
+ errs_c__ -= errs_c_offset;
+ errs_n_dim1 = *nrhs;
+ errs_n_offset = 1 + errs_n_dim1;
+ errs_n__ -= errs_n_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ --berr_out__;
+ --res;
+ --ayb;
+ --dy;
+ --y_tail__;
+
+ /* Function Body */
+ if (*info != 0) {
+ return 0;
+ }
+ chla_transtype__(ch__1, (ftnlen)1, trans_type__);
+ *(unsigned char *)trans = *(unsigned char *)&ch__1[0];
+ eps = slamch_("Epsilon");
+ hugeval = slamch_("Overflow");
+/* Force HUGEVAL to Inf */
+ hugeval *= hugeval;
+/* Using HUGEVAL may lead to spurious underflows. */
+ incr_thresh__ = (real) (*n) * eps;
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ y_prec_state__ = 1;
+ if (y_prec_state__ == 2) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ y_tail__[i__3].r = 0.f, y_tail__[i__3].i = 0.f;
+ }
+ }
+ dxrat = 0.f;
+ dxratmax = 0.f;
+ dzrat = 0.f;
+ dzratmax = 0.f;
+ final_dx_x__ = hugeval;
+ final_dz_z__ = hugeval;
+ prevnormdx = hugeval;
+ prev_dz_z__ = hugeval;
+ dz_z__ = hugeval;
+ dx_x__ = hugeval;
+ x_state__ = 1;
+ z_state__ = 0;
+ incr_prec__ = FALSE_;
+ i__2 = *ithresh;
+ for (cnt = 1; cnt <= i__2; ++cnt) {
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ if (y_prec_state__ == 0) {
+ cgemv_(trans, n, n, &c_b6, &a[a_offset], lda, &y[j * y_dim1 +
+ 1], &c__1, &c_b8, &res[1], &c__1);
+ } else if (y_prec_state__ == 1) {
+ blas_cgemv_x__(trans_type__, n, n, &c_b6, &a[a_offset], lda, &
+ y[j * y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1,
+ prec_type__);
+ } else {
+ blas_cgemv2_x__(trans_type__, n, n, &c_b6, &a[a_offset], lda,
+ &y[j * y_dim1 + 1], &y_tail__[1], &c__1, &c_b8, &res[
+ 1], &c__1, prec_type__);
+ }
+/* XXX: RES is no longer needed. */
+ ccopy_(n, &res[1], &c__1, &dy[1], &c__1);
+ cgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &dy[1],
+ n, info);
+
+/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
+
+ normx = 0.f;
+ normy = 0.f;
+ normdx = 0.f;
+ dz_z__ = 0.f;
+ ymin = hugeval;
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * y_dim1;
+ yk = (r__1 = y[i__4].r, dabs(r__1)) + (r__2 = r_imag(&y[i__ +
+ j * y_dim1]), dabs(r__2));
+ i__4 = i__;
+ dyk = (r__1 = dy[i__4].r, dabs(r__1)) + (r__2 = r_imag(&dy[
+ i__]), dabs(r__2));
+ if (yk != 0.f) {
+/* Computing MAX */
+ r__1 = dz_z__, r__2 = dyk / yk;
+ dz_z__ = dmax(r__1,r__2);
+ } else if (dyk != 0.f) {
+ dz_z__ = hugeval;
+ }
+ ymin = dmin(ymin,yk);
+ normy = dmax(normy,yk);
+ if (*colequ) {
+/* Computing MAX */
+ r__1 = normx, r__2 = yk * c__[i__];
+ normx = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = normdx, r__2 = dyk * c__[i__];
+ normdx = dmax(r__1,r__2);
+ } else {
+ normx = normy;
+ normdx = dmax(normdx,dyk);
+ }
+ }
+ if (normx != 0.f) {
+ dx_x__ = normdx / normx;
+ } else if (normdx == 0.f) {
+ dx_x__ = 0.f;
+ } else {
+ dx_x__ = hugeval;
+ }
+ dxrat = normdx / prevnormdx;
+ dzrat = dz_z__ / prev_dz_z__;
+
+/* Check termination criteria */
+
+ if (! (*ignore_cwise__) && ymin * *rcond < incr_thresh__ * normy
+ && y_prec_state__ < 2) {
+ incr_prec__ = TRUE_;
+ }
+ if (x_state__ == 3 && dxrat <= *rthresh) {
+ x_state__ = 1;
+ }
+ if (x_state__ == 1) {
+ if (dx_x__ <= eps) {
+ x_state__ = 2;
+ } else if (dxrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ x_state__ = 3;
+ }
+ } else {
+ if (dxrat > dxratmax) {
+ dxratmax = dxrat;
+ }
+ }
+ if (x_state__ > 1) {
+ final_dx_x__ = dx_x__;
+ }
+ }
+ if (z_state__ == 0 && dz_z__ <= *dz_ub__) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 3 && dzrat <= *rthresh) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 1) {
+ if (dz_z__ <= eps) {
+ z_state__ = 2;
+ } else if (dz_z__ > *dz_ub__) {
+ z_state__ = 0;
+ dzratmax = 0.f;
+ final_dz_z__ = hugeval;
+ } else if (dzrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ z_state__ = 3;
+ }
+ } else {
+ if (dzrat > dzratmax) {
+ dzratmax = dzrat;
+ }
+ }
+ if (z_state__ > 1) {
+ final_dz_z__ = dz_z__;
+ }
+ }
+
+/* Exit if both normwise and componentwise stopped working, */
+/* but if componentwise is unstable, let it go at least two */
+/* iterations. */
+
+ if (x_state__ != 1) {
+ if (*ignore_cwise__) {
+ goto L666;
+ }
+ if (z_state__ == 3 || z_state__ == 2) {
+ goto L666;
+ }
+ if (z_state__ == 0 && cnt > 1) {
+ goto L666;
+ }
+ }
+ if (incr_prec__) {
+ incr_prec__ = FALSE_;
+ ++y_prec_state__;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ y_tail__[i__4].r = 0.f, y_tail__[i__4].i = 0.f;
+ }
+ }
+ prevnormdx = normdx;
+ prev_dz_z__ = dz_z__;
+
+/* Update soluton. */
+
+ if (y_prec_state__ < 2) {
+ caxpy_(n, &c_b8, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
+ } else {
+ cla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
+ }
+ }
+/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */
+L666:
+
+/* Set final_* when cnt hits ithresh */
+
+ if (x_state__ == 1) {
+ final_dx_x__ = dx_x__;
+ }
+ if (z_state__ == 1) {
+ final_dz_z__ = dz_z__;
+ }
+
+/* Compute error bounds */
+
+ if (*n_norms__ >= 1) {
+ errs_n__[j + (errs_n_dim1 << 1)] = final_dx_x__ / (1 - dxratmax);
+ }
+ if (*n_norms__ >= 2) {
+ errs_c__[j + (errs_c_dim1 << 1)] = final_dz_z__ / (1 - dzratmax);
+ }
+
+/* Compute componentwise relative backward error from formula */
+/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. */
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ cgemv_(trans, n, n, &c_b6, &a[a_offset], lda, &y[j * y_dim1 + 1], &
+ c__1, &c_b8, &res[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ ayb[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[i__
+ + j * b_dim1]), dabs(r__2));
+ }
+
+/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */
+
+ cla_geamv__(trans_type__, n, n, &c_b31, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &c__1, &c_b31, &ayb[1], &c__1);
+ cla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
+
+/* End of loop for each RHS. */
+
+ }
+
+ return 0;
+} /* cla_gerfsx_extended__ */
diff --git a/SRC/cla_heamv.c b/SRC/cla_heamv.c
new file mode 100644
index 0000000..8a7be1c
--- /dev/null
+++ b/SRC/cla_heamv.c
@@ -0,0 +1,327 @@
+/* cla_heamv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cla_heamv__(integer *uplo, integer *n, real *alpha,
+ complex *a, integer *lda, complex *x, integer *incx, real *beta, real
+ *y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double r_imag(complex *), r_sign(real *, real *);
+
+ /* Local variables */
+ integer i__, j;
+ logical symb_zero__;
+ integer iy, jx, kx, ky, info;
+ real temp, safe1;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilauplo_(char *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_SYAMV performs the matrix-vector operation */
+
+/* y := alpha*abs(A)*abs(x) + beta*abs(y), */
+
+/* where alpha and beta are scalars, x and y are vectors and A is an */
+/* n by n symmetric matrix. */
+
+/* This function is primarily used in calculating error bounds. */
+/* To protect against underflow during evaluation, components in */
+/* the resulting vector are perturbed away from zero by (N+1) */
+/* times the underflow threshold. To prevent unnecessarily large */
+/* errors for block-structure embedded in general matrices, */
+/* "symbolically" zero components are not perturbed. A zero */
+/* entry is considered "symbolic" if all multiplications involved */
+/* in computing that entry have at least one zero multiplicand. */
+
+/* Parameters */
+/* ========== */
+
+/* UPLO - INTEGER */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array A is to be referenced as */
+/* follows: */
+
+/* UPLO = BLAS_UPPER Only the upper triangular part of A */
+/* is to be referenced. */
+
+/* UPLO = BLAS_LOWER Only the lower triangular part of A */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, n ). */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ) */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - REAL . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - REAL array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ) */
+/* Before entry with BETA non-zero, the incremented array Y */
+/* must contain the vector y. On exit, Y is overwritten by the */
+/* updated vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+/* -- Modified for the absolute-value product, April 2006 */
+/* Jason Riedy, UC Berkeley */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (*uplo != ilauplo_("U") && *uplo != ilauplo_("L")
+ ) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*lda < max(1,*n)) {
+ info = 5;
+ } else if (*incx == 0) {
+ info = 7;
+ } else if (*incy == 0) {
+ info = 10;
+ }
+ if (info != 0) {
+ xerbla_("CHEMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0.f && *beta == 1.f) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Set SAFE1 essentially to be the underflow threshold times the */
+/* number of additions in each row. */
+
+ safe1 = slamch_("Safe minimum");
+ safe1 = (*n + 1) * safe1;
+
+/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */
+
+/* The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to */
+/* the inexact flag. Still doesn't help change the iteration order */
+/* to per-column. */
+
+ iy = ky;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.f) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.f;
+ } else if (y[iy] == 0.f) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (r__1 = y[iy], dabs(r__1));
+ }
+ if (*alpha != 0.f) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (*uplo == ilauplo_("U")) {
+ if (i__ <= j) {
+ i__3 = i__ + j * a_dim1;
+ temp = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ } else {
+ i__3 = j + i__ * a_dim1;
+ temp = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[j + i__ * a_dim1]), dabs(r__2));
+ }
+ } else {
+ if (i__ >= j) {
+ i__3 = i__ + j * a_dim1;
+ temp = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ } else {
+ i__3 = j + i__ * a_dim1;
+ temp = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[j + i__ * a_dim1]), dabs(r__2));
+ }
+ }
+ i__3 = j;
+ symb_zero__ = symb_zero__ && (x[i__3].r == 0.f && x[i__3]
+ .i == 0.f || temp == 0.f);
+ i__3 = j;
+ y[iy] += *alpha * ((r__1 = x[i__3].r, dabs(r__1)) + (r__2
+ = r_imag(&x[j]), dabs(r__2))) * temp;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += r_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.f) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.f;
+ } else if (y[iy] == 0.f) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (r__1 = y[iy], dabs(r__1));
+ }
+ jx = kx;
+ if (*alpha != 0.f) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (*uplo == ilauplo_("U")) {
+ if (i__ <= j) {
+ i__3 = i__ + j * a_dim1;
+ temp = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ } else {
+ i__3 = j + i__ * a_dim1;
+ temp = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[j + i__ * a_dim1]), dabs(r__2));
+ }
+ } else {
+ if (i__ >= j) {
+ i__3 = i__ + j * a_dim1;
+ temp = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ } else {
+ i__3 = j + i__ * a_dim1;
+ temp = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[j + i__ * a_dim1]), dabs(r__2));
+ }
+ }
+ i__3 = j;
+ symb_zero__ = symb_zero__ && (x[i__3].r == 0.f && x[i__3]
+ .i == 0.f || temp == 0.f);
+ i__3 = jx;
+ y[iy] += *alpha * ((r__1 = x[i__3].r, dabs(r__1)) + (r__2
+ = r_imag(&x[jx]), dabs(r__2))) * temp;
+ jx += *incx;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += r_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ }
+
+ return 0;
+
+/* End of CLA_HEAMV */
+
+} /* cla_heamv__ */
diff --git a/SRC/cla_hercond_c.c b/SRC/cla_hercond_c.c
new file mode 100644
index 0000000..71c7262
--- /dev/null
+++ b/SRC/cla_hercond_c.c
@@ -0,0 +1,330 @@
+/* cla_hercond_c.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal cla_hercond_c__(char *uplo, integer *n, complex *a, integer *lda,
+ complex *af, integer *ldaf, integer *ipiv, real *c__, logical *capply,
+ integer *info, complex *work, real *rwork, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
+ real ret_val, r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j;
+ logical up;
+ real tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ real anorm;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *), xerbla_(char *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int chetrs_(char *, integer *, integer *, complex
+ *, integer *, integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_HERCOND_C computes the infinity norm condition number of */
+/* op(A) * inv(diag(C)) where C is a REAL vector. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by CHETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CHETRF. */
+
+/* C (input) REAL array, dimension (N) */
+/* The vector C in the formula op(A) * inv(diag(C)). */
+
+/* CAPPLY (input) LOGICAL */
+/* If .TRUE. then access the vector C in the formula above. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) COMPLEX array, dimension (2*N). */
+/* Workspace. */
+
+/* RWORK (input) REAL array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --c__;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ *info = 0;
+ if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLA_HERCOND_C", &i__1);
+ return ret_val;
+ }
+ up = FALSE_;
+ if (lsame_(uplo, "U")) {
+ up = TRUE_;
+ }
+
+/* Compute norm of op(A)*op2(C). */
+
+ anorm = 0.f;
+ if (up) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ if (*capply) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[j + i__ * a_dim1]), dabs(r__2))) / c__[j];
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[i__ + j * a_dim1]), dabs(r__2))) / c__[j];
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ j + i__ * a_dim1]), dabs(r__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ i__ + j * a_dim1]), dabs(r__2));
+ }
+ }
+ rwork[i__] = tmp;
+ anorm = dmax(anorm,tmp);
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ if (*capply) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[i__ + j * a_dim1]), dabs(r__2))) / c__[j];
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[j + i__ * a_dim1]), dabs(r__2))) / c__[j];
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ i__ + j * a_dim1]), dabs(r__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ j + i__ * a_dim1]), dabs(r__2));
+ }
+ }
+ rwork[i__] = tmp;
+ anorm = dmax(anorm,tmp);
+ }
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ ret_val = 1.f;
+ return ret_val;
+ } else if (anorm == 0.f) {
+ return ret_val;
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.f;
+
+ kase = 0;
+L10:
+ clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__4] * work[i__3].r, q__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+
+ if (up) {
+ chetrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ } else {
+ chetrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+
+/* Multiply by inv(C). */
+
+ if (*capply) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = c__[i__4] * work[i__3].r, q__1.i = c__[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ }
+ } else {
+
+/* Multiply by inv(C'). */
+
+ if (*capply) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = c__[i__4] * work[i__3].r, q__1.i = c__[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ }
+
+ if (up) {
+ chetrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ } else {
+ chetrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__4] * work[i__3].r, q__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ ret_val = 1.f / ainvnm;
+ }
+
+ return ret_val;
+
+} /* cla_hercond_c__ */
diff --git a/SRC/cla_hercond_x.c b/SRC/cla_hercond_x.c
new file mode 100644
index 0000000..4a2b643
--- /dev/null
+++ b/SRC/cla_hercond_x.c
@@ -0,0 +1,308 @@
+/* cla_hercond_x.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal cla_hercond_x__(char *uplo, integer *n, complex *a, integer *lda,
+ complex *af, integer *ldaf, integer *ipiv, complex *x, integer *info,
+ complex *work, real *rwork, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
+ real ret_val, r__1, r__2;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer i__, j;
+ logical up;
+ real tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ real anorm;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *), xerbla_(char *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int chetrs_(char *, integer *, integer *, complex
+ *, integer *, integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_HERCOND_X computes the infinity norm condition number of */
+/* op(A) * diag(X) where X is a COMPLEX vector. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by CHETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CHETRF. */
+
+/* X (input) COMPLEX array, dimension (N) */
+/* The vector X in the formula op(A) * diag(X). */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) COMPLEX array, dimension (2*N). */
+/* Workspace. */
+
+/* RWORK (input) REAL array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --x;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ *info = 0;
+ if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLA_HERCOND_X", &i__1);
+ return ret_val;
+ }
+ up = FALSE_;
+ if (lsame_(uplo, "U")) {
+ up = TRUE_;
+ }
+
+/* Compute norm of op(A)*op2(C). */
+
+ anorm = 0.f;
+ if (up) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ i__4 = j;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ q__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ tmp += (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
+ dabs(r__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = j;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ q__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ tmp += (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
+ dabs(r__2));
+ }
+ rwork[i__] = tmp;
+ anorm = dmax(anorm,tmp);
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = j;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ q__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ tmp += (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
+ dabs(r__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ i__4 = j;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ q__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ tmp += (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
+ dabs(r__2));
+ }
+ rwork[i__] = tmp;
+ anorm = dmax(anorm,tmp);
+ }
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ ret_val = 1.f;
+ return ret_val;
+ } else if (anorm == 0.f) {
+ return ret_val;
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.f;
+
+ kase = 0;
+L10:
+ clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__4] * work[i__3].r, q__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+
+ if (up) {
+ chetrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ } else {
+ chetrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+
+/* Multiply by inv(X). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ c_div(&q__1, &work[i__], &x[i__]);
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ } else {
+
+/* Multiply by inv(X'). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ c_div(&q__1, &work[i__], &x[i__]);
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+
+ if (up) {
+ chetrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ } else {
+ chetrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__4] * work[i__3].r, q__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ ret_val = 1.f / ainvnm;
+ }
+
+ return ret_val;
+
+} /* cla_hercond_x__ */
diff --git a/SRC/cla_herfsx_extended.c b/SRC/cla_herfsx_extended.c
new file mode 100644
index 0000000..58a99c7
--- /dev/null
+++ b/SRC/cla_herfsx_extended.c
@@ -0,0 +1,621 @@
+/* cla_herfsx_extended.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static complex c_b11 = {-1.f,0.f};
+static complex c_b12 = {1.f,0.f};
+static real c_b33 = 1.f;
+
+/* Subroutine */ int cla_herfsx_extended__(integer *prec_type__, char *uplo,
+ integer *n, integer *nrhs, complex *a, integer *lda, complex *af,
+ integer *ldaf, integer *ipiv, logical *colequ, real *c__, complex *b,
+ integer *ldb, complex *y, integer *ldy, real *berr_out__, integer *
+ n_norms__, real *err_bnds_norm__, real *err_bnds_comp__, complex *res,
+ real *ayb, complex *dy, complex *y_tail__, real *rcond, integer *
+ ithresh, real *rthresh, real *dz_ub__, logical *ignore_cwise__,
+ integer *info, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1,
+ y_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ real dxratmax, dzratmax;
+ integer i__, j;
+ extern /* Subroutine */ int cla_heamv__(integer *, integer *, real *,
+ complex *, integer *, complex *, integer *, real *, real *,
+ integer *);
+ logical incr_prec__;
+ real prev_dz_z__, yk, final_dx_x__;
+ extern /* Subroutine */ int cla_wwaddw__(integer *, complex *, complex *,
+ complex *);
+ real final_dz_z__, prevnormdx;
+ integer cnt;
+ real dyk, eps, incr_thresh__, dx_x__, dz_z__;
+ extern /* Subroutine */ int cla_lin_berr__(integer *, integer *, integer *
+ , complex *, real *, real *);
+ real ymin;
+ extern /* Subroutine */ int blas_chemv_x__(integer *, integer *, complex *
+ , complex *, integer *, complex *, integer *, complex *, complex *
+ , integer *, integer *);
+ integer y_prec_state__, uplo2;
+ extern /* Subroutine */ int blas_chemv2_x__(integer *, integer *, complex
+ *, complex *, integer *, complex *, complex *, integer *, complex
+ *, complex *, integer *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int chemv_(char *, integer *, complex *, complex *
+, integer *, complex *, integer *, complex *, complex *, integer *
+), ccopy_(integer *, complex *, integer *, complex *,
+ integer *);
+ real dxrat, dzrat;
+ extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ real normx, normy;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int chetrs_(char *, integer *, integer *, complex
+ *, integer *, integer *, complex *, integer *, integer *);
+ real normdx, hugeval;
+ extern integer ilauplo_(char *);
+ integer x_state__, z_state__;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_HERFSX_EXTENDED improves the computed solution to a system of */
+/* linear equations by performing extra-precise iterative refinement */
+/* and provides error bounds and backward error estimates for the solution. */
+/* This subroutine is called by CHERFSX to perform iterative refinement. */
+/* In addition to normwise error bound, the code provides maximum */
+/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP for details of the error bounds. Note that this */
+/* subroutine is only resonsible for setting the second fields of */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP. */
+
+/* Arguments */
+/* ========= */
+
+/* PREC_TYPE (input) INTEGER */
+/* Specifies the intermediate precision to be used in refinement. */
+/* The value is defined by ILAPREC(P) where P is a CHARACTER and */
+/* P = 'S': Single */
+/* = 'D': Double */
+/* = 'I': Indigenous */
+/* = 'X', 'E': Extra */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right-hand-sides, i.e., the number of columns of the */
+/* matrix B. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by CHETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CHETRF. */
+
+/* COLEQU (input) LOGICAL */
+/* If .TRUE. then column equilibration was done to A before calling */
+/* this routine. This is needed to compute the solution and error */
+/* bounds correctly. */
+
+/* C (input) REAL array, dimension (N) */
+/* The column scale factors for A. If COLEQU = .FALSE., C */
+/* is not accessed. If C is input, each element of C should be a power */
+/* of the radix to ensure a reliable solution and error estimates. */
+/* Scaling by powers of the radix does not cause rounding errors unless */
+/* the result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right-hand-side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Y (input/output) COMPLEX array, dimension */
+/* (LDY,NRHS) */
+/* On entry, the solution matrix X, as computed by CHETRS. */
+/* On exit, the improved solution matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= max(1,N). */
+
+/* BERR_OUT (output) REAL array, dimension (NRHS) */
+/* On exit, BERR_OUT(j) contains the componentwise relative backward */
+/* error for right-hand-side j from the formula */
+/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. This is computed by CLA_LIN_BERR. */
+
+/* N_NORMS (input) INTEGER */
+/* Determines which error bounds to return (see ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP). */
+/* If N_NORMS >= 1 return normwise error bounds. */
+/* If N_NORMS >= 2 return componentwise error bounds. */
+
+/* ERR_BNDS_NORM (input/output) REAL array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (input/output) REAL array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* RES (input) COMPLEX array, dimension (N) */
+/* Workspace to hold the intermediate residual. */
+
+/* AYB (input) REAL array, dimension (N) */
+/* Workspace. */
+
+/* DY (input) COMPLEX array, dimension (N) */
+/* Workspace to hold the intermediate solution. */
+
+/* Y_TAIL (input) COMPLEX array, dimension (N) */
+/* Workspace to hold the trailing bits of the intermediate solution. */
+
+/* RCOND (input) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* ITHRESH (input) INTEGER */
+/* The maximum number of residual computations allowed for */
+/* refinement. The default is 10. For 'aggressive' set to 100 to */
+/* permit convergence using approximate factorizations or */
+/* factorizations other than LU. If the factorization uses a */
+/* technique other than Gaussian elimination, the guarantees in */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */
+
+/* RTHRESH (input) REAL */
+/* Determines when to stop refinement if the error estimate stops */
+/* decreasing. Refinement will stop when the next solution no longer */
+/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */
+/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */
+/* default value is 0.5. For 'aggressive' set to 0.9 to permit */
+/* convergence on extremely ill-conditioned matrices. See LAWN 165 */
+/* for more details. */
+
+/* DZ_UB (input) REAL */
+/* Determines when to start considering componentwise convergence. */
+/* Componentwise convergence is only considered after each component */
+/* of the solution Y is stable, which we definte as the relative */
+/* change in each component being less than DZ_UB. The default value */
+/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */
+/* more details. */
+
+/* IGNORE_CWISE (input) LOGICAL */
+/* If .TRUE. then ignore componentwise convergence. Default value */
+/* is .FALSE.. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* < 0: if INFO = -i, the ith argument to CHETRS had an illegal */
+/* value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ --berr_out__;
+ --res;
+ --ayb;
+ --dy;
+ --y_tail__;
+
+ /* Function Body */
+ if (*info != 0) {
+ return 0;
+ }
+ eps = slamch_("Epsilon");
+ hugeval = slamch_("Overflow");
+/* Force HUGEVAL to Inf */
+ hugeval *= hugeval;
+/* Using HUGEVAL may lead to spurious underflows. */
+ incr_thresh__ = (real) (*n) * eps;
+ if (lsame_(uplo, "L")) {
+ uplo2 = ilauplo_("L");
+ } else {
+ uplo2 = ilauplo_("U");
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ y_prec_state__ = 1;
+ if (y_prec_state__ == 2) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ y_tail__[i__3].r = 0.f, y_tail__[i__3].i = 0.f;
+ }
+ }
+ dxrat = 0.f;
+ dxratmax = 0.f;
+ dzrat = 0.f;
+ dzratmax = 0.f;
+ final_dx_x__ = hugeval;
+ final_dz_z__ = hugeval;
+ prevnormdx = hugeval;
+ prev_dz_z__ = hugeval;
+ dz_z__ = hugeval;
+ dx_x__ = hugeval;
+ x_state__ = 1;
+ z_state__ = 0;
+ incr_prec__ = FALSE_;
+ i__2 = *ithresh;
+ for (cnt = 1; cnt <= i__2; ++cnt) {
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ if (y_prec_state__ == 0) {
+ chemv_(uplo, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1],
+ &c__1, &c_b12, &res[1], &c__1);
+ } else if (y_prec_state__ == 1) {
+ blas_chemv_x__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &c__1, &c_b12, &res[1], &c__1,
+ prec_type__);
+ } else {
+ blas_chemv2_x__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &y_tail__[1], &c__1, &c_b12, &res[1], &
+ c__1, prec_type__);
+ }
+/* XXX: RES is no longer needed. */
+ ccopy_(n, &res[1], &c__1, &dy[1], &c__1);
+ chetrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &dy[1], n,
+ info);
+
+/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
+
+ normx = 0.f;
+ normy = 0.f;
+ normdx = 0.f;
+ dz_z__ = 0.f;
+ ymin = hugeval;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * y_dim1;
+ yk = (r__1 = y[i__4].r, dabs(r__1)) + (r__2 = r_imag(&y[i__ +
+ j * y_dim1]), dabs(r__2));
+ i__4 = i__;
+ dyk = (r__1 = dy[i__4].r, dabs(r__1)) + (r__2 = r_imag(&dy[
+ i__]), dabs(r__2));
+ if (yk != 0.f) {
+/* Computing MAX */
+ r__1 = dz_z__, r__2 = dyk / yk;
+ dz_z__ = dmax(r__1,r__2);
+ } else if (dyk != 0.f) {
+ dz_z__ = hugeval;
+ }
+ ymin = dmin(ymin,yk);
+ normy = dmax(normy,yk);
+ if (*colequ) {
+/* Computing MAX */
+ r__1 = normx, r__2 = yk * c__[i__];
+ normx = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = normdx, r__2 = dyk * c__[i__];
+ normdx = dmax(r__1,r__2);
+ } else {
+ normx = normy;
+ normdx = dmax(normdx,dyk);
+ }
+ }
+ if (normx != 0.f) {
+ dx_x__ = normdx / normx;
+ } else if (normdx == 0.f) {
+ dx_x__ = 0.f;
+ } else {
+ dx_x__ = hugeval;
+ }
+ dxrat = normdx / prevnormdx;
+ dzrat = dz_z__ / prev_dz_z__;
+
+/* Check termination criteria. */
+
+ if (ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2) {
+ incr_prec__ = TRUE_;
+ }
+ if (x_state__ == 3 && dxrat <= *rthresh) {
+ x_state__ = 1;
+ }
+ if (x_state__ == 1) {
+ if (dx_x__ <= eps) {
+ x_state__ = 2;
+ } else if (dxrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ x_state__ = 3;
+ }
+ } else {
+ if (dxrat > dxratmax) {
+ dxratmax = dxrat;
+ }
+ }
+ if (x_state__ > 1) {
+ final_dx_x__ = dx_x__;
+ }
+ }
+ if (z_state__ == 0 && dz_z__ <= *dz_ub__) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 3 && dzrat <= *rthresh) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 1) {
+ if (dz_z__ <= eps) {
+ z_state__ = 2;
+ } else if (dz_z__ > *dz_ub__) {
+ z_state__ = 0;
+ dzratmax = 0.f;
+ final_dz_z__ = hugeval;
+ } else if (dzrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ z_state__ = 3;
+ }
+ } else {
+ if (dzrat > dzratmax) {
+ dzratmax = dzrat;
+ }
+ }
+ if (z_state__ > 1) {
+ final_dz_z__ = dz_z__;
+ }
+ }
+ if (x_state__ != 1 && (*ignore_cwise__ || z_state__ != 1)) {
+ goto L666;
+ }
+ if (incr_prec__) {
+ incr_prec__ = FALSE_;
+ ++y_prec_state__;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ y_tail__[i__4].r = 0.f, y_tail__[i__4].i = 0.f;
+ }
+ }
+ prevnormdx = normdx;
+ prev_dz_z__ = dz_z__;
+
+/* Update soluton. */
+
+ if (y_prec_state__ < 2) {
+ caxpy_(n, &c_b12, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
+ } else {
+ cla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
+ }
+ }
+/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */
+L666:
+
+/* Set final_* when cnt hits ithresh. */
+
+ if (x_state__ == 1) {
+ final_dx_x__ = dx_x__;
+ }
+ if (z_state__ == 1) {
+ final_dz_z__ = dz_z__;
+ }
+
+/* Compute error bounds. */
+
+ if (*n_norms__ >= 1) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / (
+ 1 - dxratmax);
+ }
+ if (*n_norms__ >= 2) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / (
+ 1 - dzratmax);
+ }
+
+/* Compute componentwise relative backward error from formula */
+/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. */
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ chemv_(uplo, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1,
+ &c_b12, &res[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ ayb[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[i__
+ + j * b_dim1]), dabs(r__2));
+ }
+
+/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */
+
+ cla_heamv__(&uplo2, n, &c_b33, &a[a_offset], lda, &y[j * y_dim1 + 1],
+ &c__1, &c_b33, &ayb[1], &c__1);
+ cla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
+
+/* End of loop for each RHS. */
+
+ }
+
+ return 0;
+} /* cla_herfsx_extended__ */
diff --git a/SRC/cla_herpvgrw.c b/SRC/cla_herpvgrw.c
new file mode 100644
index 0000000..48be9d9
--- /dev/null
+++ b/SRC/cla_herpvgrw.c
@@ -0,0 +1,355 @@
+/* cla_herpvgrw.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal cla_herpvgrw__(char *uplo, integer *n, integer *info, complex *a,
+ integer *lda, complex *af, integer *ldaf, integer *ipiv, real *work,
+ ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3;
+ real ret_val, r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k, kp;
+ real tmp, amax, umax;
+ extern logical lsame_(char *, char *);
+ integer ncols;
+ logical upper;
+ real rpvgrw;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_HERPVGRW computes the reciprocal pivot growth factor */
+/* norm(A)/norm(U). The "max absolute element" norm is used. If this is */
+/* much less than 1, the stability of the LU factorization of the */
+/* (equilibrated) matrix A could be poor. This also means that the */
+/* solution X, estimated condition numbers, and error bounds could be */
+/* unreliable. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* INFO (input) INTEGER */
+/* The value of INFO returned from SSYTRF, .i.e., the pivot in */
+/* column INFO is exactly 0. */
+
+/* NCOLS (input) INTEGER */
+/* The number of columns of the matrix A. NCOLS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by CHETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CHETRF. */
+
+/* WORK (input) COMPLEX array, dimension (2*N) */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ upper = lsame_("Upper", uplo);
+ if (*info == 0) {
+ if (upper) {
+ ncols = 1;
+ } else {
+ ncols = *n;
+ }
+ } else {
+ ncols = *info;
+ }
+ rpvgrw = 1.f;
+ i__1 = *n << 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+ }
+
+/* Find the max magnitude entry of each column of A. Compute the max */
+/* for all N columns so we can apply the pivot permutation while */
+/* looping below. Assume a full factorization is the common case. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[i__
+ + j * a_dim1]), dabs(r__2)), r__4 = work[*n + i__];
+ work[*n + i__] = dmax(r__3,r__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[i__
+ + j * a_dim1]), dabs(r__2)), r__4 = work[*n + j];
+ work[*n + j] = dmax(r__3,r__4);
+ }
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[i__
+ + j * a_dim1]), dabs(r__2)), r__4 = work[*n + i__];
+ work[*n + i__] = dmax(r__3,r__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[i__
+ + j * a_dim1]), dabs(r__2)), r__4 = work[*n + j];
+ work[*n + j] = dmax(r__3,r__4);
+ }
+ }
+ }
+
+/* Now find the max magnitude entry of each column of U or L. Also */
+/* permute the magnitudes of A above so they're in the same order as */
+/* the factor. */
+
+/* The iteration orders and permutations were copied from csytrs. */
+/* Calls to SSWAP would be severe overkill. */
+
+ if (upper) {
+ k = *n;
+ while(k < ncols && k > 0) {
+ if (ipiv[k] > 0) {
+/* 1x1 pivot */
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ i__2 = i__ + k * af_dim1;
+ r__3 = (r__1 = af[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
+ af[i__ + k * af_dim1]), dabs(r__2)), r__4 = work[
+ k];
+ work[k] = dmax(r__3,r__4);
+ }
+ --k;
+ } else {
+/* 2x2 pivot */
+ kp = -ipiv[k];
+ tmp = work[*n + k - 1];
+ work[*n + k - 1] = work[*n + kp];
+ work[*n + kp] = tmp;
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ i__2 = i__ + k * af_dim1;
+ r__3 = (r__1 = af[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
+ af[i__ + k * af_dim1]), dabs(r__2)), r__4 = work[
+ k];
+ work[k] = dmax(r__3,r__4);
+/* Computing MAX */
+ i__2 = i__ + (k - 1) * af_dim1;
+ r__3 = (r__1 = af[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
+ af[i__ + (k - 1) * af_dim1]), dabs(r__2)), r__4 =
+ work[k - 1];
+ work[k - 1] = dmax(r__3,r__4);
+ }
+/* Computing MAX */
+ i__1 = k + k * af_dim1;
+ r__3 = (r__1 = af[i__1].r, dabs(r__1)) + (r__2 = r_imag(&af[k
+ + k * af_dim1]), dabs(r__2)), r__4 = work[k];
+ work[k] = dmax(r__3,r__4);
+ k += -2;
+ }
+ }
+ k = ncols;
+ while(k <= *n) {
+ if (ipiv[k] > 0) {
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ ++k;
+ } else {
+ kp = -ipiv[k];
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ k += 2;
+ }
+ }
+ } else {
+ k = 1;
+ while(k <= ncols) {
+ if (ipiv[k] > 0) {
+/* 1x1 pivot */
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ i__1 = *n;
+ for (i__ = k; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ i__2 = i__ + k * af_dim1;
+ r__3 = (r__1 = af[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
+ af[i__ + k * af_dim1]), dabs(r__2)), r__4 = work[
+ k];
+ work[k] = dmax(r__3,r__4);
+ }
+ ++k;
+ } else {
+/* 2x2 pivot */
+ kp = -ipiv[k];
+ tmp = work[*n + k + 1];
+ work[*n + k + 1] = work[*n + kp];
+ work[*n + kp] = tmp;
+ i__1 = *n;
+ for (i__ = k + 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ i__2 = i__ + k * af_dim1;
+ r__3 = (r__1 = af[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
+ af[i__ + k * af_dim1]), dabs(r__2)), r__4 = work[
+ k];
+ work[k] = dmax(r__3,r__4);
+/* Computing MAX */
+ i__2 = i__ + (k + 1) * af_dim1;
+ r__3 = (r__1 = af[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
+ af[i__ + (k + 1) * af_dim1]), dabs(r__2)), r__4 =
+ work[k + 1];
+ work[k + 1] = dmax(r__3,r__4);
+ }
+/* Computing MAX */
+ i__1 = k + k * af_dim1;
+ r__3 = (r__1 = af[i__1].r, dabs(r__1)) + (r__2 = r_imag(&af[k
+ + k * af_dim1]), dabs(r__2)), r__4 = work[k];
+ work[k] = dmax(r__3,r__4);
+ k += 2;
+ }
+ }
+ k = ncols;
+ while(k >= 1) {
+ if (ipiv[k] > 0) {
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ --k;
+ } else {
+ kp = -ipiv[k];
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ k += -2;
+ }
+ }
+ }
+
+/* Compute the *inverse* of the max element growth factor. Dividing */
+/* by zero would imply the largest entry of the factor's column is */
+/* zero. Than can happen when either the column of A is zero or */
+/* massive pivots made the factor underflow to zero. Neither counts */
+/* as growth in itself, so simply ignore terms with zero */
+/* denominators. */
+
+ if (upper) {
+ i__1 = *n;
+ for (i__ = ncols; i__ <= i__1; ++i__) {
+ umax = work[i__];
+ amax = work[*n + i__];
+ if (umax != 0.f) {
+/* Computing MIN */
+ r__1 = amax / umax;
+ rpvgrw = dmin(r__1,rpvgrw);
+ }
+ }
+ } else {
+ i__1 = ncols;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ umax = work[i__];
+ amax = work[*n + i__];
+ if (umax != 0.f) {
+/* Computing MIN */
+ r__1 = amax / umax;
+ rpvgrw = dmin(r__1,rpvgrw);
+ }
+ }
+ }
+ ret_val = rpvgrw;
+ return ret_val;
+} /* cla_herpvgrw__ */
diff --git a/SRC/cla_lin_berr.c b/SRC/cla_lin_berr.c
new file mode 100644
index 0000000..8a78bc8
--- /dev/null
+++ b/SRC/cla_lin_berr.c
@@ -0,0 +1,136 @@
+/* cla_lin_berr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cla_lin_berr__(integer *n, integer *nz, integer *nrhs,
+ complex *res, real *ayb, real *berr)
+{
+ /* System generated locals */
+ integer ayb_dim1, ayb_offset, res_dim1, res_offset, i__1, i__2, i__3,
+ i__4;
+ real r__1, r__2, r__3;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j;
+ real tmp, safe1;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_LIN_BERR computes componentwise relative backward error from */
+/* the formula */
+/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NZ (input) INTEGER */
+/* We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to */
+/* guard against spuriously zero residuals. Default value is N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices AYB, RES, and BERR. NRHS >= 0. */
+
+/* RES (input) DOUBLE PRECISION array, dimension (N,NRHS) */
+/* The residual matrix, i.e., the matrix R in the relative backward */
+/* error formula above. */
+
+/* AYB (input) DOUBLE PRECISION array, dimension (N, NRHS) */
+/* The denominator in the relative backward error formula above, i.e., */
+/* the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B */
+/* are from iterative refinement (see cla_gerfsx_extended.f). */
+
+/* RES (output) COMPLEX array, dimension (NRHS) */
+/* The componentwise relative backward error from the formula above. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Adding SAFE1 to the numerator guards against spuriously zero */
+/* residuals. A similar safeguard is in the CLA_yyAMV routine used */
+/* to compute AYB. */
+
+ /* Parameter adjustments */
+ --berr;
+ ayb_dim1 = *n;
+ ayb_offset = 1 + ayb_dim1;
+ ayb -= ayb_offset;
+ res_dim1 = *n;
+ res_offset = 1 + res_dim1;
+ res -= res_offset;
+
+ /* Function Body */
+ safe1 = slamch_("Safe minimum");
+ safe1 = (*nz + 1) * safe1;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (ayb[i__ + j * ayb_dim1] != 0.f) {
+ i__3 = i__ + j * res_dim1;
+ r__3 = (r__1 = res[i__3].r, dabs(r__1)) + (r__2 = r_imag(&res[
+ i__ + j * res_dim1]), dabs(r__2));
+ q__3.r = r__3, q__3.i = 0.f;
+ q__2.r = safe1 + q__3.r, q__2.i = q__3.i;
+ i__4 = i__ + j * ayb_dim1;
+ q__1.r = q__2.r / ayb[i__4], q__1.i = q__2.i / ayb[i__4];
+ tmp = q__1.r;
+/* Computing MAX */
+ r__1 = berr[j];
+ berr[j] = dmax(r__1,tmp);
+ }
+
+/* If AYB is exactly 0.0 (and if computed by CLA_yyAMV), then we know */
+/* the true residual also must be exactly 0.0. */
+
+ }
+ }
+ return 0;
+} /* cla_lin_berr__ */
diff --git a/SRC/cla_porcond_c.c b/SRC/cla_porcond_c.c
new file mode 100644
index 0000000..b5b853e
--- /dev/null
+++ b/SRC/cla_porcond_c.c
@@ -0,0 +1,325 @@
+/* cla_porcond_c.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal cla_porcond_c__(char *uplo, integer *n, complex *a, integer *lda,
+ complex *af, integer *ldaf, real *c__, logical *capply, integer *info,
+ complex *work, real *rwork, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
+ real ret_val, r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j;
+ logical up;
+ real tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ real anorm;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *), xerbla_(char *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int cpotrs_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_PORCOND_C Computes the infinity norm condition number of */
+/* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by CPOTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* C (input) REAL array, dimension (N) */
+/* The vector C in the formula op(A) * inv(diag(C)). */
+
+/* CAPPLY (input) LOGICAL */
+/* If .TRUE. then access the vector C in the formula above. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) COMPLEX array, dimension (2*N). */
+/* Workspace. */
+
+/* RWORK (input) REAL array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --c__;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ *info = 0;
+ if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLA_PORCOND_C", &i__1);
+ return ret_val;
+ }
+ up = FALSE_;
+ if (lsame_(uplo, "U")) {
+ up = TRUE_;
+ }
+
+/* Compute norm of op(A)*op2(C). */
+
+ anorm = 0.f;
+ if (up) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ if (*capply) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[j + i__ * a_dim1]), dabs(r__2))) / c__[j];
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[i__ + j * a_dim1]), dabs(r__2))) / c__[j];
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ j + i__ * a_dim1]), dabs(r__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ i__ + j * a_dim1]), dabs(r__2));
+ }
+ }
+ rwork[i__] = tmp;
+ anorm = dmax(anorm,tmp);
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ if (*capply) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[i__ + j * a_dim1]), dabs(r__2))) / c__[j];
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[j + i__ * a_dim1]), dabs(r__2))) / c__[j];
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ i__ + j * a_dim1]), dabs(r__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ j + i__ * a_dim1]), dabs(r__2));
+ }
+ }
+ rwork[i__] = tmp;
+ anorm = dmax(anorm,tmp);
+ }
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ ret_val = 1.f;
+ return ret_val;
+ } else if (anorm == 0.f) {
+ return ret_val;
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.f;
+
+ kase = 0;
+L10:
+ clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__4] * work[i__3].r, q__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+
+ if (up) {
+ cpotrs_("U", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ } else {
+ cpotrs_("L", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ }
+
+/* Multiply by inv(C). */
+
+ if (*capply) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = c__[i__4] * work[i__3].r, q__1.i = c__[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ }
+ } else {
+
+/* Multiply by inv(C'). */
+
+ if (*capply) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = c__[i__4] * work[i__3].r, q__1.i = c__[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ }
+
+ if (up) {
+ cpotrs_("U", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ } else {
+ cpotrs_("L", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__4] * work[i__3].r, q__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ ret_val = 1.f / ainvnm;
+ }
+
+ return ret_val;
+
+} /* cla_porcond_c__ */
diff --git a/SRC/cla_porcond_x.c b/SRC/cla_porcond_x.c
new file mode 100644
index 0000000..ca274eb
--- /dev/null
+++ b/SRC/cla_porcond_x.c
@@ -0,0 +1,303 @@
+/* cla_porcond_x.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal cla_porcond_x__(char *uplo, integer *n, complex *a, integer *lda,
+ complex *af, integer *ldaf, complex *x, integer *info, complex *work,
+ real *rwork, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
+ real ret_val, r__1, r__2;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer i__, j;
+ logical up;
+ real tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ real anorm;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *), xerbla_(char *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int cpotrs_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_PORCOND_X Computes the infinity norm condition number of */
+/* op(A) * diag(X) where X is a COMPLEX vector. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by CPOTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* X (input) COMPLEX array, dimension (N) */
+/* The vector X in the formula op(A) * diag(X). */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) COMPLEX array, dimension (2*N). */
+/* Workspace. */
+
+/* RWORK (input) REAL array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --x;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ *info = 0;
+ if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLA_PORCOND_X", &i__1);
+ return ret_val;
+ }
+ up = FALSE_;
+ if (lsame_(uplo, "U")) {
+ up = TRUE_;
+ }
+
+/* Compute norm of op(A)*op2(C). */
+
+ anorm = 0.f;
+ if (up) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ i__4 = j;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ q__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ tmp += (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
+ dabs(r__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = j;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ q__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ tmp += (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
+ dabs(r__2));
+ }
+ rwork[i__] = tmp;
+ anorm = dmax(anorm,tmp);
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = j;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ q__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ tmp += (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
+ dabs(r__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ i__4 = j;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ q__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ tmp += (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
+ dabs(r__2));
+ }
+ rwork[i__] = tmp;
+ anorm = dmax(anorm,tmp);
+ }
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ ret_val = 1.f;
+ return ret_val;
+ } else if (anorm == 0.f) {
+ return ret_val;
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.f;
+
+ kase = 0;
+L10:
+ clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__4] * work[i__3].r, q__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+
+ if (up) {
+ cpotrs_("U", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ } else {
+ cpotrs_("L", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ }
+
+/* Multiply by inv(X). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ c_div(&q__1, &work[i__], &x[i__]);
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ } else {
+
+/* Multiply by inv(X'). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ c_div(&q__1, &work[i__], &x[i__]);
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+
+ if (up) {
+ cpotrs_("U", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ } else {
+ cpotrs_("L", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__4] * work[i__3].r, q__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ ret_val = 1.f / ainvnm;
+ }
+
+ return ret_val;
+
+} /* cla_porcond_x__ */
diff --git a/SRC/cla_porfsx_extended.c b/SRC/cla_porfsx_extended.c
new file mode 100644
index 0000000..d91e65a
--- /dev/null
+++ b/SRC/cla_porfsx_extended.c
@@ -0,0 +1,616 @@
+/* cla_porfsx_extended.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static complex c_b11 = {-1.f,0.f};
+static complex c_b12 = {1.f,0.f};
+static real c_b33 = 1.f;
+
+/* Subroutine */ int cla_porfsx_extended__(integer *prec_type__, char *uplo,
+ integer *n, integer *nrhs, complex *a, integer *lda, complex *af,
+ integer *ldaf, logical *colequ, real *c__, complex *b, integer *ldb,
+ complex *y, integer *ldy, real *berr_out__, integer *n_norms__, real *
+ err_bnds_norm__, real *err_bnds_comp__, complex *res, real *ayb,
+ complex *dy, complex *y_tail__, real *rcond, integer *ithresh, real *
+ rthresh, real *dz_ub__, logical *ignore_cwise__, integer *info,
+ ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1,
+ y_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ real dxratmax, dzratmax;
+ integer i__, j;
+ extern /* Subroutine */ int cla_heamv__(integer *, integer *, real *,
+ complex *, integer *, complex *, integer *, real *, real *,
+ integer *);
+ logical incr_prec__;
+ real prev_dz_z__, yk, final_dx_x__;
+ extern /* Subroutine */ int cla_wwaddw__(integer *, complex *, complex *,
+ complex *);
+ real final_dz_z__, prevnormdx;
+ integer cnt;
+ real dyk, eps, incr_thresh__, dx_x__, dz_z__;
+ extern /* Subroutine */ int cla_lin_berr__(integer *, integer *, integer *
+ , complex *, real *, real *);
+ real ymin;
+ extern /* Subroutine */ int blas_chemv_x__(integer *, integer *, complex *
+ , complex *, integer *, complex *, integer *, complex *, complex *
+ , integer *, integer *);
+ integer y_prec_state__, uplo2;
+ extern /* Subroutine */ int blas_chemv2_x__(integer *, integer *, complex
+ *, complex *, integer *, complex *, complex *, integer *, complex
+ *, complex *, integer *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int chemv_(char *, integer *, complex *, complex *
+, integer *, complex *, integer *, complex *, complex *, integer *
+), ccopy_(integer *, complex *, integer *, complex *,
+ integer *);
+ real dxrat, dzrat;
+ extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ real normx, normy;
+ extern doublereal slamch_(char *);
+ real normdx;
+ extern /* Subroutine */ int cpotrs_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, integer *);
+ real hugeval;
+ extern integer ilauplo_(char *);
+ integer x_state__, z_state__;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_PORFSX_EXTENDED improves the computed solution to a system of */
+/* linear equations by performing extra-precise iterative refinement */
+/* and provides error bounds and backward error estimates for the solution. */
+/* This subroutine is called by CPORFSX to perform iterative refinement. */
+/* In addition to normwise error bound, the code provides maximum */
+/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP for details of the error bounds. Note that this */
+/* subroutine is only resonsible for setting the second fields of */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP. */
+
+/* Arguments */
+/* ========= */
+
+/* PREC_TYPE (input) INTEGER */
+/* Specifies the intermediate precision to be used in refinement. */
+/* The value is defined by ILAPREC(P) where P is a CHARACTER and */
+/* P = 'S': Single */
+/* = 'D': Double */
+/* = 'I': Indigenous */
+/* = 'X', 'E': Extra */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right-hand-sides, i.e., the number of columns of the */
+/* matrix B. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by CPOTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* COLEQU (input) LOGICAL */
+/* If .TRUE. then column equilibration was done to A before calling */
+/* this routine. This is needed to compute the solution and error */
+/* bounds correctly. */
+
+/* C (input) REAL array, dimension (N) */
+/* The column scale factors for A. If COLEQU = .FALSE., C */
+/* is not accessed. If C is input, each element of C should be a power */
+/* of the radix to ensure a reliable solution and error estimates. */
+/* Scaling by powers of the radix does not cause rounding errors unless */
+/* the result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right-hand-side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Y (input/output) COMPLEX array, dimension */
+/* (LDY,NRHS) */
+/* On entry, the solution matrix X, as computed by CPOTRS. */
+/* On exit, the improved solution matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= max(1,N). */
+
+/* BERR_OUT (output) REAL array, dimension (NRHS) */
+/* On exit, BERR_OUT(j) contains the componentwise relative backward */
+/* error for right-hand-side j from the formula */
+/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. This is computed by CLA_LIN_BERR. */
+
+/* N_NORMS (input) INTEGER */
+/* Determines which error bounds to return (see ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP). */
+/* If N_NORMS >= 1 return normwise error bounds. */
+/* If N_NORMS >= 2 return componentwise error bounds. */
+
+/* ERR_BNDS_NORM (input/output) REAL array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (input/output) REAL array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* RES (input) COMPLEX array, dimension (N) */
+/* Workspace to hold the intermediate residual. */
+
+/* AYB (input) REAL array, dimension (N) */
+/* Workspace. */
+
+/* DY (input) COMPLEX array, dimension (N) */
+/* Workspace to hold the intermediate solution. */
+
+/* Y_TAIL (input) COMPLEX array, dimension (N) */
+/* Workspace to hold the trailing bits of the intermediate solution. */
+
+/* RCOND (input) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* ITHRESH (input) INTEGER */
+/* The maximum number of residual computations allowed for */
+/* refinement. The default is 10. For 'aggressive' set to 100 to */
+/* permit convergence using approximate factorizations or */
+/* factorizations other than LU. If the factorization uses a */
+/* technique other than Gaussian elimination, the guarantees in */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */
+
+/* RTHRESH (input) REAL */
+/* Determines when to stop refinement if the error estimate stops */
+/* decreasing. Refinement will stop when the next solution no longer */
+/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */
+/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */
+/* default value is 0.5. For 'aggressive' set to 0.9 to permit */
+/* convergence on extremely ill-conditioned matrices. See LAWN 165 */
+/* for more details. */
+
+/* DZ_UB (input) REAL */
+/* Determines when to start considering componentwise convergence. */
+/* Componentwise convergence is only considered after each component */
+/* of the solution Y is stable, which we definte as the relative */
+/* change in each component being less than DZ_UB. The default value */
+/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */
+/* more details. */
+
+/* IGNORE_CWISE (input) LOGICAL */
+/* If .TRUE. then ignore componentwise convergence. Default value */
+/* is .FALSE.. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* < 0: if INFO = -i, the ith argument to CPOTRS had an illegal */
+/* value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ --berr_out__;
+ --res;
+ --ayb;
+ --dy;
+ --y_tail__;
+
+ /* Function Body */
+ if (*info != 0) {
+ return 0;
+ }
+ eps = slamch_("Epsilon");
+ hugeval = slamch_("Overflow");
+/* Force HUGEVAL to Inf */
+ hugeval *= hugeval;
+/* Using HUGEVAL may lead to spurious underflows. */
+ incr_thresh__ = (real) (*n) * eps;
+ if (lsame_(uplo, "L")) {
+ uplo2 = ilauplo_("L");
+ } else {
+ uplo2 = ilauplo_("U");
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ y_prec_state__ = 1;
+ if (y_prec_state__ == 2) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ y_tail__[i__3].r = 0.f, y_tail__[i__3].i = 0.f;
+ }
+ }
+ dxrat = 0.f;
+ dxratmax = 0.f;
+ dzrat = 0.f;
+ dzratmax = 0.f;
+ final_dx_x__ = hugeval;
+ final_dz_z__ = hugeval;
+ prevnormdx = hugeval;
+ prev_dz_z__ = hugeval;
+ dz_z__ = hugeval;
+ dx_x__ = hugeval;
+ x_state__ = 1;
+ z_state__ = 0;
+ incr_prec__ = FALSE_;
+ i__2 = *ithresh;
+ for (cnt = 1; cnt <= i__2; ++cnt) {
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ if (y_prec_state__ == 0) {
+ chemv_(uplo, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1],
+ &c__1, &c_b12, &res[1], &c__1);
+ } else if (y_prec_state__ == 1) {
+ blas_chemv_x__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &c__1, &c_b12, &res[1], &c__1,
+ prec_type__);
+ } else {
+ blas_chemv2_x__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &y_tail__[1], &c__1, &c_b12, &res[1], &
+ c__1, prec_type__);
+ }
+/* XXX: RES is no longer needed. */
+ ccopy_(n, &res[1], &c__1, &dy[1], &c__1);
+ cpotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &dy[1], n, info);
+
+/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
+
+ normx = 0.f;
+ normy = 0.f;
+ normdx = 0.f;
+ dz_z__ = 0.f;
+ ymin = hugeval;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * y_dim1;
+ yk = (r__1 = y[i__4].r, dabs(r__1)) + (r__2 = r_imag(&y[i__ +
+ j * y_dim1]), dabs(r__2));
+ i__4 = i__;
+ dyk = (r__1 = dy[i__4].r, dabs(r__1)) + (r__2 = r_imag(&dy[
+ i__]), dabs(r__2));
+ if (yk != 0.f) {
+/* Computing MAX */
+ r__1 = dz_z__, r__2 = dyk / yk;
+ dz_z__ = dmax(r__1,r__2);
+ } else if (dyk != 0.f) {
+ dz_z__ = hugeval;
+ }
+ ymin = dmin(ymin,yk);
+ normy = dmax(normy,yk);
+ if (*colequ) {
+/* Computing MAX */
+ r__1 = normx, r__2 = yk * c__[i__];
+ normx = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = normdx, r__2 = dyk * c__[i__];
+ normdx = dmax(r__1,r__2);
+ } else {
+ normx = normy;
+ normdx = dmax(normdx,dyk);
+ }
+ }
+ if (normx != 0.f) {
+ dx_x__ = normdx / normx;
+ } else if (normdx == 0.f) {
+ dx_x__ = 0.f;
+ } else {
+ dx_x__ = hugeval;
+ }
+ dxrat = normdx / prevnormdx;
+ dzrat = dz_z__ / prev_dz_z__;
+
+/* Check termination criteria. */
+
+ if (ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2) {
+ incr_prec__ = TRUE_;
+ }
+ if (x_state__ == 3 && dxrat <= *rthresh) {
+ x_state__ = 1;
+ }
+ if (x_state__ == 1) {
+ if (dx_x__ <= eps) {
+ x_state__ = 2;
+ } else if (dxrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ x_state__ = 3;
+ }
+ } else {
+ if (dxrat > dxratmax) {
+ dxratmax = dxrat;
+ }
+ }
+ if (x_state__ > 1) {
+ final_dx_x__ = dx_x__;
+ }
+ }
+ if (z_state__ == 0 && dz_z__ <= *dz_ub__) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 3 && dzrat <= *rthresh) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 1) {
+ if (dz_z__ <= eps) {
+ z_state__ = 2;
+ } else if (dz_z__ > *dz_ub__) {
+ z_state__ = 0;
+ dzratmax = 0.f;
+ final_dz_z__ = hugeval;
+ } else if (dzrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ z_state__ = 3;
+ }
+ } else {
+ if (dzrat > dzratmax) {
+ dzratmax = dzrat;
+ }
+ }
+ if (z_state__ > 1) {
+ final_dz_z__ = dz_z__;
+ }
+ }
+ if (x_state__ != 1 && (*ignore_cwise__ || z_state__ != 1)) {
+ goto L666;
+ }
+ if (incr_prec__) {
+ incr_prec__ = FALSE_;
+ ++y_prec_state__;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ y_tail__[i__4].r = 0.f, y_tail__[i__4].i = 0.f;
+ }
+ }
+ prevnormdx = normdx;
+ prev_dz_z__ = dz_z__;
+
+/* Update soluton. */
+
+ if (y_prec_state__ < 2) {
+ caxpy_(n, &c_b12, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
+ } else {
+ cla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
+ }
+ }
+/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */
+L666:
+
+/* Set final_* when cnt hits ithresh. */
+
+ if (x_state__ == 1) {
+ final_dx_x__ = dx_x__;
+ }
+ if (z_state__ == 1) {
+ final_dz_z__ = dz_z__;
+ }
+
+/* Compute error bounds. */
+
+ if (*n_norms__ >= 1) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / (
+ 1 - dxratmax);
+ }
+ if (*n_norms__ >= 2) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / (
+ 1 - dzratmax);
+ }
+
+/* Compute componentwise relative backward error from formula */
+/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. */
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ chemv_(uplo, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1,
+ &c_b12, &res[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ ayb[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[i__
+ + j * b_dim1]), dabs(r__2));
+ }
+
+/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */
+
+ cla_heamv__(&uplo2, n, &c_b33, &a[a_offset], lda, &y[j * y_dim1 + 1],
+ &c__1, &c_b33, &ayb[1], &c__1);
+ cla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
+
+/* End of loop for each RHS. */
+
+ }
+
+ return 0;
+} /* cla_porfsx_extended__ */
diff --git a/SRC/cla_porpvgrw.c b/SRC/cla_porpvgrw.c
new file mode 100644
index 0000000..e27baa8
--- /dev/null
+++ b/SRC/cla_porpvgrw.c
@@ -0,0 +1,207 @@
+/* cla_porpvgrw.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal cla_porpvgrw__(char *uplo, integer *ncols, complex *a, integer *
+ lda, complex *af, integer *ldaf, real *work, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3;
+ real ret_val, r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j;
+ real amax, umax;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ real rpvgrw;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_PORPVGRW computes the reciprocal pivot growth factor */
+/* norm(A)/norm(U). The "max absolute element" norm is used. If this is */
+/* much less than 1, the stability of the LU factorization of the */
+/* (equilibrated) matrix A could be poor. This also means that the */
+/* solution X, estimated condition numbers, and error bounds could be */
+/* unreliable. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* NCOLS (input) INTEGER */
+/* The number of columns of the matrix A. NCOLS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by CPOTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* WORK (input) COMPLEX array, dimension (2*N) */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --work;
+
+ /* Function Body */
+ upper = lsame_("Upper", uplo);
+
+/* SPOTRF will have factored only the NCOLSxNCOLS leading minor, so */
+/* we restrict the growth search to that minor and use only the first */
+/* 2*NCOLS workspace entries. */
+
+ rpvgrw = 1.f;
+ i__1 = *ncols << 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+ }
+
+/* Find the max magnitude entry of each column. */
+
+ if (upper) {
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[i__
+ + j * a_dim1]), dabs(r__2)), r__4 = work[*ncols + j];
+ work[*ncols + j] = dmax(r__3,r__4);
+ }
+ }
+ } else {
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *ncols;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[i__
+ + j * a_dim1]), dabs(r__2)), r__4 = work[*ncols + j];
+ work[*ncols + j] = dmax(r__3,r__4);
+ }
+ }
+ }
+
+/* Now find the max magnitude entry of each column of the factor in */
+/* AF. No pivoting, so no permutations. */
+
+ if (lsame_("Upper", uplo)) {
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * af_dim1;
+ r__3 = (r__1 = af[i__3].r, dabs(r__1)) + (r__2 = r_imag(&af[
+ i__ + j * af_dim1]), dabs(r__2)), r__4 = work[j];
+ work[j] = dmax(r__3,r__4);
+ }
+ }
+ } else {
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *ncols;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * af_dim1;
+ r__3 = (r__1 = af[i__3].r, dabs(r__1)) + (r__2 = r_imag(&af[
+ i__ + j * af_dim1]), dabs(r__2)), r__4 = work[j];
+ work[j] = dmax(r__3,r__4);
+ }
+ }
+ }
+
+/* Compute the *inverse* of the max element growth factor. Dividing */
+/* by zero would imply the largest entry of the factor's column is */
+/* zero. Than can happen when either the column of A is zero or */
+/* massive pivots made the factor underflow to zero. Neither counts */
+/* as growth in itself, so simply ignore terms with zero */
+/* denominators. */
+
+ if (lsame_("Upper", uplo)) {
+ i__1 = *ncols;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ umax = work[i__];
+ amax = work[*ncols + i__];
+ if (umax != 0.f) {
+/* Computing MIN */
+ r__1 = amax / umax;
+ rpvgrw = dmin(r__1,rpvgrw);
+ }
+ }
+ } else {
+ i__1 = *ncols;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ umax = work[i__];
+ amax = work[*ncols + i__];
+ if (umax != 0.f) {
+/* Computing MIN */
+ r__1 = amax / umax;
+ rpvgrw = dmin(r__1,rpvgrw);
+ }
+ }
+ }
+ ret_val = rpvgrw;
+ return ret_val;
+} /* cla_porpvgrw__ */
diff --git a/SRC/cla_rpvgrw.c b/SRC/cla_rpvgrw.c
new file mode 100644
index 0000000..7c0c699
--- /dev/null
+++ b/SRC/cla_rpvgrw.c
@@ -0,0 +1,128 @@
+/* cla_rpvgrw.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal cla_rpvgrw__(integer *n, integer *ncols, complex *a, integer *lda,
+ complex *af, integer *ldaf)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3;
+ real ret_val, r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j;
+ real amax, umax, rpvgrw;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_RPVGRW computes the reciprocal pivot growth factor */
+/* norm(A)/norm(U). The "max absolute element" norm is used. If this is */
+/* much less than 1, the stability of the LU factorization of the */
+/* (equilibrated) matrix A could be poor. This also means that the */
+/* solution X, estimated condition numbers, and error bounds could be */
+/* unreliable. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NCOLS (input) INTEGER */
+/* The number of columns of the matrix A. NCOLS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The factors L and U from the factorization */
+/* A = P*L*U as computed by CGETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+
+ /* Function Body */
+ rpvgrw = 1.f;
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ amax = 0.f;
+ umax = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[i__ + j
+ * a_dim1]), dabs(r__2));
+ amax = dmax(r__3,amax);
+ }
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * af_dim1;
+ r__3 = (r__1 = af[i__3].r, dabs(r__1)) + (r__2 = r_imag(&af[i__ +
+ j * af_dim1]), dabs(r__2));
+ umax = dmax(r__3,umax);
+ }
+ if (umax != 0.f) {
+/* Computing MIN */
+ r__1 = amax / umax;
+ rpvgrw = dmin(r__1,rpvgrw);
+ }
+ }
+ ret_val = rpvgrw;
+ return ret_val;
+} /* cla_rpvgrw__ */
diff --git a/SRC/cla_syamv.c b/SRC/cla_syamv.c
new file mode 100644
index 0000000..2038542
--- /dev/null
+++ b/SRC/cla_syamv.c
@@ -0,0 +1,327 @@
+/* cla_syamv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cla_syamv__(integer *uplo, integer *n, real *alpha,
+ complex *a, integer *lda, complex *x, integer *incx, real *beta, real
+ *y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double r_imag(complex *), r_sign(real *, real *);
+
+ /* Local variables */
+ integer i__, j;
+ logical symb_zero__;
+ integer iy, jx, kx, ky, info;
+ real temp, safe1;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilauplo_(char *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_SYAMV performs the matrix-vector operation */
+
+/* y := alpha*abs(A)*abs(x) + beta*abs(y), */
+
+/* where alpha and beta are scalars, x and y are vectors and A is an */
+/* n by n symmetric matrix. */
+
+/* This function is primarily used in calculating error bounds. */
+/* To protect against underflow during evaluation, components in */
+/* the resulting vector are perturbed away from zero by (N+1) */
+/* times the underflow threshold. To prevent unnecessarily large */
+/* errors for block-structure embedded in general matrices, */
+/* "symbolically" zero components are not perturbed. A zero */
+/* entry is considered "symbolic" if all multiplications involved */
+/* in computing that entry have at least one zero multiplicand. */
+
+/* Parameters */
+/* ========== */
+
+/* UPLO - INTEGER */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array A is to be referenced as */
+/* follows: */
+
+/* UPLO = BLAS_UPPER Only the upper triangular part of A */
+/* is to be referenced. */
+
+/* UPLO = BLAS_LOWER Only the lower triangular part of A */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array of DIMENSION ( LDA, n ). */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ) */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - REAL . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - REAL array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ) */
+/* Before entry with BETA non-zero, the incremented array Y */
+/* must contain the vector y. On exit, Y is overwritten by the */
+/* updated vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+/* -- Modified for the absolute-value product, April 2006 */
+/* Jason Riedy, UC Berkeley */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (*uplo != ilauplo_("U") && *uplo != ilauplo_("L")
+ ) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*lda < max(1,*n)) {
+ info = 5;
+ } else if (*incx == 0) {
+ info = 7;
+ } else if (*incy == 0) {
+ info = 10;
+ }
+ if (info != 0) {
+ xerbla_("SSYMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0.f && *beta == 1.f) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Set SAFE1 essentially to be the underflow threshold times the */
+/* number of additions in each row. */
+
+ safe1 = slamch_("Safe minimum");
+ safe1 = (*n + 1) * safe1;
+
+/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */
+
+/* The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to */
+/* the inexact flag. Still doesn't help change the iteration order */
+/* to per-column. */
+
+ iy = ky;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.f) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.f;
+ } else if (y[iy] == 0.f) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (r__1 = y[iy], dabs(r__1));
+ }
+ if (*alpha != 0.f) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (*uplo == ilauplo_("U")) {
+ if (i__ <= j) {
+ i__3 = i__ + j * a_dim1;
+ temp = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ } else {
+ i__3 = j + i__ * a_dim1;
+ temp = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[j + i__ * a_dim1]), dabs(r__2));
+ }
+ } else {
+ if (i__ >= j) {
+ i__3 = i__ + j * a_dim1;
+ temp = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ } else {
+ i__3 = j + i__ * a_dim1;
+ temp = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[j + i__ * a_dim1]), dabs(r__2));
+ }
+ }
+ i__3 = j;
+ symb_zero__ = symb_zero__ && (x[i__3].r == 0.f && x[i__3]
+ .i == 0.f || temp == 0.f);
+ i__3 = j;
+ y[iy] += *alpha * ((r__1 = x[i__3].r, dabs(r__1)) + (r__2
+ = r_imag(&x[j]), dabs(r__2))) * temp;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += r_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.f) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.f;
+ } else if (y[iy] == 0.f) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (r__1 = y[iy], dabs(r__1));
+ }
+ jx = kx;
+ if (*alpha != 0.f) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (*uplo == ilauplo_("U")) {
+ if (i__ <= j) {
+ i__3 = i__ + j * a_dim1;
+ temp = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ } else {
+ i__3 = j + i__ * a_dim1;
+ temp = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[j + i__ * a_dim1]), dabs(r__2));
+ }
+ } else {
+ if (i__ >= j) {
+ i__3 = i__ + j * a_dim1;
+ temp = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ } else {
+ i__3 = j + i__ * a_dim1;
+ temp = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[j + i__ * a_dim1]), dabs(r__2));
+ }
+ }
+ i__3 = j;
+ symb_zero__ = symb_zero__ && (x[i__3].r == 0.f && x[i__3]
+ .i == 0.f || temp == 0.f);
+ i__3 = jx;
+ y[iy] += *alpha * ((r__1 = x[i__3].r, dabs(r__1)) + (r__2
+ = r_imag(&x[jx]), dabs(r__2))) * temp;
+ jx += *incx;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += r_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ }
+
+ return 0;
+
+/* End of CLA_SYAMV */
+
+} /* cla_syamv__ */
diff --git a/SRC/cla_syrcond_c.c b/SRC/cla_syrcond_c.c
new file mode 100644
index 0000000..4c52b17
--- /dev/null
+++ b/SRC/cla_syrcond_c.c
@@ -0,0 +1,330 @@
+/* cla_syrcond_c.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal cla_syrcond_c__(char *uplo, integer *n, complex *a, integer *lda,
+ complex *af, integer *ldaf, integer *ipiv, real *c__, logical *capply,
+ integer *info, complex *work, real *rwork, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
+ real ret_val, r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j;
+ logical up;
+ real tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ real anorm;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *), xerbla_(char *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int csytrs_(char *, integer *, integer *, complex
+ *, integer *, integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_SYRCOND_C Computes the infinity norm condition number of */
+/* op(A) * inv(diag(C)) where C is a REAL vector. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by CSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CSYTRF. */
+
+/* C (input) REAL array, dimension (N) */
+/* The vector C in the formula op(A) * inv(diag(C)). */
+
+/* CAPPLY (input) LOGICAL */
+/* If .TRUE. then access the vector C in the formula above. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) COMPLEX array, dimension (2*N). */
+/* Workspace. */
+
+/* RWORK (input) REAL array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --c__;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ *info = 0;
+ if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLA_SYRCOND_C", &i__1);
+ return ret_val;
+ }
+ up = FALSE_;
+ if (lsame_(uplo, "U")) {
+ up = TRUE_;
+ }
+
+/* Compute norm of op(A)*op2(C). */
+
+ anorm = 0.f;
+ if (up) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ if (*capply) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[j + i__ * a_dim1]), dabs(r__2))) / c__[j];
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[i__ + j * a_dim1]), dabs(r__2))) / c__[j];
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ j + i__ * a_dim1]), dabs(r__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ i__ + j * a_dim1]), dabs(r__2));
+ }
+ }
+ rwork[i__] = tmp;
+ anorm = dmax(anorm,tmp);
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ if (*capply) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[i__ + j * a_dim1]), dabs(r__2))) / c__[j];
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[j + i__ * a_dim1]), dabs(r__2))) / c__[j];
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ i__ + j * a_dim1]), dabs(r__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ j + i__ * a_dim1]), dabs(r__2));
+ }
+ }
+ rwork[i__] = tmp;
+ anorm = dmax(anorm,tmp);
+ }
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ ret_val = 1.f;
+ return ret_val;
+ } else if (anorm == 0.f) {
+ return ret_val;
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.f;
+
+ kase = 0;
+L10:
+ clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__4] * work[i__3].r, q__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+
+ if (up) {
+ csytrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ } else {
+ csytrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+
+/* Multiply by inv(C). */
+
+ if (*capply) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = c__[i__4] * work[i__3].r, q__1.i = c__[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ }
+ } else {
+
+/* Multiply by inv(C'). */
+
+ if (*capply) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = c__[i__4] * work[i__3].r, q__1.i = c__[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ }
+
+ if (up) {
+ csytrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ } else {
+ csytrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__4] * work[i__3].r, q__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ ret_val = 1.f / ainvnm;
+ }
+
+ return ret_val;
+
+} /* cla_syrcond_c__ */
diff --git a/SRC/cla_syrcond_x.c b/SRC/cla_syrcond_x.c
new file mode 100644
index 0000000..f4c8cc1
--- /dev/null
+++ b/SRC/cla_syrcond_x.c
@@ -0,0 +1,308 @@
+/* cla_syrcond_x.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal cla_syrcond_x__(char *uplo, integer *n, complex *a, integer *lda,
+ complex *af, integer *ldaf, integer *ipiv, complex *x, integer *info,
+ complex *work, real *rwork, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
+ real ret_val, r__1, r__2;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer i__, j;
+ logical up;
+ real tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ real anorm;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *), xerbla_(char *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int csytrs_(char *, integer *, integer *, complex
+ *, integer *, integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_SYRCOND_X Computes the infinity norm condition number of */
+/* op(A) * diag(X) where X is a COMPLEX vector. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by CSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CSYTRF. */
+
+/* X (input) COMPLEX array, dimension (N) */
+/* The vector X in the formula op(A) * diag(X). */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) COMPLEX array, dimension (2*N). */
+/* Workspace. */
+
+/* RWORK (input) REAL array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --x;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ *info = 0;
+ if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLA_SYRCOND_X", &i__1);
+ return ret_val;
+ }
+ up = FALSE_;
+ if (lsame_(uplo, "U")) {
+ up = TRUE_;
+ }
+
+/* Compute norm of op(A)*op2(C). */
+
+ anorm = 0.f;
+ if (up) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ i__4 = j;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ q__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ tmp += (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
+ dabs(r__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = j;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ q__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ tmp += (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
+ dabs(r__2));
+ }
+ rwork[i__] = tmp;
+ anorm = dmax(anorm,tmp);
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = j;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ q__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ tmp += (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
+ dabs(r__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ i__4 = j;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ q__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ tmp += (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
+ dabs(r__2));
+ }
+ rwork[i__] = tmp;
+ anorm = dmax(anorm,tmp);
+ }
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ ret_val = 1.f;
+ return ret_val;
+ } else if (anorm == 0.f) {
+ return ret_val;
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.f;
+
+ kase = 0;
+L10:
+ clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__4] * work[i__3].r, q__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+
+ if (up) {
+ csytrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ } else {
+ csytrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+
+/* Multiply by inv(X). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ c_div(&q__1, &work[i__], &x[i__]);
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ } else {
+
+/* Multiply by inv(X'). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ c_div(&q__1, &work[i__], &x[i__]);
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+
+ if (up) {
+ csytrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ } else {
+ csytrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__4] * work[i__3].r, q__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ ret_val = 1.f / ainvnm;
+ }
+
+ return ret_val;
+
+} /* cla_syrcond_x__ */
diff --git a/SRC/cla_syrfsx_extended.c b/SRC/cla_syrfsx_extended.c
new file mode 100644
index 0000000..4e321d6
--- /dev/null
+++ b/SRC/cla_syrfsx_extended.c
@@ -0,0 +1,622 @@
+/* cla_syrfsx_extended.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static complex c_b11 = {-1.f,0.f};
+static complex c_b12 = {1.f,0.f};
+static real c_b33 = 1.f;
+
+/* Subroutine */ int cla_syrfsx_extended__(integer *prec_type__, char *uplo,
+ integer *n, integer *nrhs, complex *a, integer *lda, complex *af,
+ integer *ldaf, integer *ipiv, logical *colequ, real *c__, complex *b,
+ integer *ldb, complex *y, integer *ldy, real *berr_out__, integer *
+ n_norms__, real *err_bnds_norm__, real *err_bnds_comp__, complex *res,
+ real *ayb, complex *dy, complex *y_tail__, real *rcond, integer *
+ ithresh, real *rthresh, real *dz_ub__, logical *ignore_cwise__,
+ integer *info, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1,
+ y_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ real dxratmax, dzratmax;
+ integer i__, j;
+ logical incr_prec__;
+ extern /* Subroutine */ int cla_syamv__(integer *, integer *, real *,
+ complex *, integer *, complex *, integer *, real *, real *,
+ integer *);
+ real prev_dz_z__, yk, final_dx_x__;
+ extern /* Subroutine */ int cla_wwaddw__(integer *, complex *, complex *,
+ complex *);
+ real final_dz_z__, prevnormdx;
+ integer cnt;
+ real dyk, eps, incr_thresh__, dx_x__, dz_z__;
+ extern /* Subroutine */ int cla_lin_berr__(integer *, integer *, integer *
+ , complex *, real *, real *);
+ real ymin;
+ integer y_prec_state__;
+ extern /* Subroutine */ int blas_csymv_x__(integer *, integer *, complex *
+ , complex *, integer *, complex *, integer *, complex *, complex *
+ , integer *, integer *);
+ integer uplo2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int blas_csymv2_x__(integer *, integer *, complex
+ *, complex *, integer *, complex *, complex *, integer *, complex
+ *, complex *, integer *, integer *), ccopy_(integer *, complex *,
+ integer *, complex *, integer *);
+ real dxrat, dzrat;
+ extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *), csymv_(char *, integer *,
+ complex *, complex *, integer *, complex *, integer *, complex *,
+ complex *, integer *);
+ real normx, normy;
+ extern doublereal slamch_(char *);
+ real normdx;
+ extern /* Subroutine */ int csytrs_(char *, integer *, integer *, complex
+ *, integer *, integer *, complex *, integer *, integer *);
+ real hugeval;
+ extern integer ilauplo_(char *);
+ integer x_state__, z_state__;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_SYRFSX_EXTENDED improves the computed solution to a system of */
+/* linear equations by performing extra-precise iterative refinement */
+/* and provides error bounds and backward error estimates for the solution. */
+/* This subroutine is called by CSYRFSX to perform iterative refinement. */
+/* In addition to normwise error bound, the code provides maximum */
+/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP for details of the error bounds. Note that this */
+/* subroutine is only resonsible for setting the second fields of */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP. */
+
+/* Arguments */
+/* ========= */
+
+/* PREC_TYPE (input) INTEGER */
+/* Specifies the intermediate precision to be used in refinement. */
+/* The value is defined by ILAPREC(P) where P is a CHARACTER and */
+/* P = 'S': Single */
+/* = 'D': Double */
+/* = 'I': Indigenous */
+/* = 'X', 'E': Extra */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right-hand-sides, i.e., the number of columns of the */
+/* matrix B. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by CSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CSYTRF. */
+
+/* COLEQU (input) LOGICAL */
+/* If .TRUE. then column equilibration was done to A before calling */
+/* this routine. This is needed to compute the solution and error */
+/* bounds correctly. */
+
+/* C (input) REAL array, dimension (N) */
+/* The column scale factors for A. If COLEQU = .FALSE., C */
+/* is not accessed. If C is input, each element of C should be a power */
+/* of the radix to ensure a reliable solution and error estimates. */
+/* Scaling by powers of the radix does not cause rounding errors unless */
+/* the result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right-hand-side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Y (input/output) COMPLEX array, dimension */
+/* (LDY,NRHS) */
+/* On entry, the solution matrix X, as computed by CSYTRS. */
+/* On exit, the improved solution matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= max(1,N). */
+
+/* BERR_OUT (output) REAL array, dimension (NRHS) */
+/* On exit, BERR_OUT(j) contains the componentwise relative backward */
+/* error for right-hand-side j from the formula */
+/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. This is computed by CLA_LIN_BERR. */
+
+/* N_NORMS (input) INTEGER */
+/* Determines which error bounds to return (see ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP). */
+/* If N_NORMS >= 1 return normwise error bounds. */
+/* If N_NORMS >= 2 return componentwise error bounds. */
+
+/* ERR_BNDS_NORM (input/output) REAL array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (input/output) REAL array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* RES (input) COMPLEX array, dimension (N) */
+/* Workspace to hold the intermediate residual. */
+
+/* AYB (input) REAL array, dimension (N) */
+/* Workspace. */
+
+/* DY (input) COMPLEX array, dimension (N) */
+/* Workspace to hold the intermediate solution. */
+
+/* Y_TAIL (input) COMPLEX array, dimension (N) */
+/* Workspace to hold the trailing bits of the intermediate solution. */
+
+/* RCOND (input) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* ITHRESH (input) INTEGER */
+/* The maximum number of residual computations allowed for */
+/* refinement. The default is 10. For 'aggressive' set to 100 to */
+/* permit convergence using approximate factorizations or */
+/* factorizations other than LU. If the factorization uses a */
+/* technique other than Gaussian elimination, the guarantees in */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */
+
+/* RTHRESH (input) REAL */
+/* Determines when to stop refinement if the error estimate stops */
+/* decreasing. Refinement will stop when the next solution no longer */
+/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */
+/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */
+/* default value is 0.5. For 'aggressive' set to 0.9 to permit */
+/* convergence on extremely ill-conditioned matrices. See LAWN 165 */
+/* for more details. */
+
+/* DZ_UB (input) REAL */
+/* Determines when to start considering componentwise convergence. */
+/* Componentwise convergence is only considered after each component */
+/* of the solution Y is stable, which we definte as the relative */
+/* change in each component being less than DZ_UB. The default value */
+/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */
+/* more details. */
+
+/* IGNORE_CWISE (input) LOGICAL */
+/* If .TRUE. then ignore componentwise convergence. Default value */
+/* is .FALSE.. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* < 0: if INFO = -i, the ith argument to CSYTRS had an illegal */
+/* value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ --berr_out__;
+ --res;
+ --ayb;
+ --dy;
+ --y_tail__;
+
+ /* Function Body */
+ if (*info != 0) {
+ return 0;
+ }
+ eps = slamch_("Epsilon");
+ hugeval = slamch_("Overflow");
+/* Force HUGEVAL to Inf */
+ hugeval *= hugeval;
+/* Using HUGEVAL may lead to spurious underflows. */
+ incr_thresh__ = (real) (*n) * eps;
+ if (lsame_(uplo, "L")) {
+ uplo2 = ilauplo_("L");
+ } else {
+ uplo2 = ilauplo_("U");
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ y_prec_state__ = 1;
+ if (y_prec_state__ == 2) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ y_tail__[i__3].r = 0.f, y_tail__[i__3].i = 0.f;
+ }
+ }
+ dxrat = 0.f;
+ dxratmax = 0.f;
+ dzrat = 0.f;
+ dzratmax = 0.f;
+ final_dx_x__ = hugeval;
+ final_dz_z__ = hugeval;
+ prevnormdx = hugeval;
+ prev_dz_z__ = hugeval;
+ dz_z__ = hugeval;
+ dx_x__ = hugeval;
+ x_state__ = 1;
+ z_state__ = 0;
+ incr_prec__ = FALSE_;
+ i__2 = *ithresh;
+ for (cnt = 1; cnt <= i__2; ++cnt) {
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ if (y_prec_state__ == 0) {
+ csymv_(uplo, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1],
+ &c__1, &c_b12, &res[1], &c__1);
+ } else if (y_prec_state__ == 1) {
+ blas_csymv_x__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &c__1, &c_b12, &res[1], &c__1,
+ prec_type__);
+ } else {
+ blas_csymv2_x__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &y_tail__[1], &c__1, &c_b12, &res[1], &
+ c__1, prec_type__);
+ }
+/* XXX: RES is no longer needed. */
+ ccopy_(n, &res[1], &c__1, &dy[1], &c__1);
+ csytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &dy[1], n,
+ info);
+
+/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
+
+ normx = 0.f;
+ normy = 0.f;
+ normdx = 0.f;
+ dz_z__ = 0.f;
+ ymin = hugeval;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * y_dim1;
+ yk = (r__1 = y[i__4].r, dabs(r__1)) + (r__2 = r_imag(&y[i__ +
+ j * y_dim1]), dabs(r__2));
+ i__4 = i__;
+ dyk = (r__1 = dy[i__4].r, dabs(r__1)) + (r__2 = r_imag(&dy[
+ i__]), dabs(r__2));
+ if (yk != 0.f) {
+/* Computing MAX */
+ r__1 = dz_z__, r__2 = dyk / yk;
+ dz_z__ = dmax(r__1,r__2);
+ } else if (dyk != 0.f) {
+ dz_z__ = hugeval;
+ }
+ ymin = dmin(ymin,yk);
+ normy = dmax(normy,yk);
+ if (*colequ) {
+/* Computing MAX */
+ r__1 = normx, r__2 = yk * c__[i__];
+ normx = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = normdx, r__2 = dyk * c__[i__];
+ normdx = dmax(r__1,r__2);
+ } else {
+ normx = normy;
+ normdx = dmax(normdx,dyk);
+ }
+ }
+ if (normx != 0.f) {
+ dx_x__ = normdx / normx;
+ } else if (normdx == 0.f) {
+ dx_x__ = 0.f;
+ } else {
+ dx_x__ = hugeval;
+ }
+ dxrat = normdx / prevnormdx;
+ dzrat = dz_z__ / prev_dz_z__;
+
+/* Check termination criteria. */
+
+ if (ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2) {
+ incr_prec__ = TRUE_;
+ }
+ if (x_state__ == 3 && dxrat <= *rthresh) {
+ x_state__ = 1;
+ }
+ if (x_state__ == 1) {
+ if (dx_x__ <= eps) {
+ x_state__ = 2;
+ } else if (dxrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ x_state__ = 3;
+ }
+ } else {
+ if (dxrat > dxratmax) {
+ dxratmax = dxrat;
+ }
+ }
+ if (x_state__ > 1) {
+ final_dx_x__ = dx_x__;
+ }
+ }
+ if (z_state__ == 0 && dz_z__ <= *dz_ub__) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 3 && dzrat <= *rthresh) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 1) {
+ if (dz_z__ <= eps) {
+ z_state__ = 2;
+ } else if (dz_z__ > *dz_ub__) {
+ z_state__ = 0;
+ dzratmax = 0.f;
+ final_dz_z__ = hugeval;
+ } else if (dzrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ z_state__ = 3;
+ }
+ } else {
+ if (dzrat > dzratmax) {
+ dzratmax = dzrat;
+ }
+ }
+ if (z_state__ > 1) {
+ final_dz_z__ = dz_z__;
+ }
+ }
+ if (x_state__ != 1 && (*ignore_cwise__ || z_state__ != 1)) {
+ goto L666;
+ }
+ if (incr_prec__) {
+ incr_prec__ = FALSE_;
+ ++y_prec_state__;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ y_tail__[i__4].r = 0.f, y_tail__[i__4].i = 0.f;
+ }
+ }
+ prevnormdx = normdx;
+ prev_dz_z__ = dz_z__;
+
+/* Update soluton. */
+
+ if (y_prec_state__ < 2) {
+ caxpy_(n, &c_b12, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
+ } else {
+ cla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
+ }
+ }
+/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */
+L666:
+
+/* Set final_* when cnt hits ithresh. */
+
+ if (x_state__ == 1) {
+ final_dx_x__ = dx_x__;
+ }
+ if (z_state__ == 1) {
+ final_dz_z__ = dz_z__;
+ }
+
+/* Compute error bounds. */
+
+ if (*n_norms__ >= 1) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / (
+ 1 - dxratmax);
+ }
+ if (*n_norms__ >= 2) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / (
+ 1 - dzratmax);
+ }
+
+/* Compute componentwise relative backward error from formula */
+/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. */
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ csymv_(uplo, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1,
+ &c_b12, &res[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ ayb[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[i__
+ + j * b_dim1]), dabs(r__2));
+ }
+
+/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */
+
+ cla_syamv__(&uplo2, n, &c_b33, &a[a_offset], lda, &y[j * y_dim1 + 1],
+ &c__1, &c_b33, &ayb[1], &c__1);
+ cla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
+
+/* End of loop for each RHS. */
+
+ }
+
+ return 0;
+} /* cla_syrfsx_extended__ */
diff --git a/SRC/cla_syrpvgrw.c b/SRC/cla_syrpvgrw.c
new file mode 100644
index 0000000..9d0c91d
--- /dev/null
+++ b/SRC/cla_syrpvgrw.c
@@ -0,0 +1,355 @@
+/* cla_syrpvgrw.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal cla_syrpvgrw__(char *uplo, integer *n, integer *info, complex *a,
+ integer *lda, complex *af, integer *ldaf, integer *ipiv, real *work,
+ ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3;
+ real ret_val, r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k, kp;
+ real tmp, amax, umax;
+ extern logical lsame_(char *, char *);
+ integer ncols;
+ logical upper;
+ real rpvgrw;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_SYRPVGRW computes the reciprocal pivot growth factor */
+/* norm(A)/norm(U). The "max absolute element" norm is used. If this is */
+/* much less than 1, the stability of the LU factorization of the */
+/* (equilibrated) matrix A could be poor. This also means that the */
+/* solution X, estimated condition numbers, and error bounds could be */
+/* unreliable. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* INFO (input) INTEGER */
+/* The value of INFO returned from CSYTRF, .i.e., the pivot in */
+/* column INFO is exactly 0. */
+
+/* NCOLS (input) INTEGER */
+/* The number of columns of the matrix A. NCOLS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by CSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CSYTRF. */
+
+/* WORK (input) COMPLEX array, dimension (2*N) */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ upper = lsame_("Upper", uplo);
+ if (*info == 0) {
+ if (upper) {
+ ncols = 1;
+ } else {
+ ncols = *n;
+ }
+ } else {
+ ncols = *info;
+ }
+ rpvgrw = 1.f;
+ i__1 = *n << 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+ }
+
+/* Find the max magnitude entry of each column of A. Compute the max */
+/* for all N columns so we can apply the pivot permutation while */
+/* looping below. Assume a full factorization is the common case. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[i__
+ + j * a_dim1]), dabs(r__2)), r__4 = work[*n + i__];
+ work[*n + i__] = dmax(r__3,r__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[i__
+ + j * a_dim1]), dabs(r__2)), r__4 = work[*n + j];
+ work[*n + j] = dmax(r__3,r__4);
+ }
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[i__
+ + j * a_dim1]), dabs(r__2)), r__4 = work[*n + i__];
+ work[*n + i__] = dmax(r__3,r__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[i__
+ + j * a_dim1]), dabs(r__2)), r__4 = work[*n + j];
+ work[*n + j] = dmax(r__3,r__4);
+ }
+ }
+ }
+
+/* Now find the max magnitude entry of each column of U or L. Also */
+/* permute the magnitudes of A above so they're in the same order as */
+/* the factor. */
+
+/* The iteration orders and permutations were copied from csytrs. */
+/* Calls to SSWAP would be severe overkill. */
+
+ if (upper) {
+ k = *n;
+ while(k < ncols && k > 0) {
+ if (ipiv[k] > 0) {
+/* 1x1 pivot */
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ i__2 = i__ + k * af_dim1;
+ r__3 = (r__1 = af[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
+ af[i__ + k * af_dim1]), dabs(r__2)), r__4 = work[
+ k];
+ work[k] = dmax(r__3,r__4);
+ }
+ --k;
+ } else {
+/* 2x2 pivot */
+ kp = -ipiv[k];
+ tmp = work[*n + k - 1];
+ work[*n + k - 1] = work[*n + kp];
+ work[*n + kp] = tmp;
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ i__2 = i__ + k * af_dim1;
+ r__3 = (r__1 = af[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
+ af[i__ + k * af_dim1]), dabs(r__2)), r__4 = work[
+ k];
+ work[k] = dmax(r__3,r__4);
+/* Computing MAX */
+ i__2 = i__ + (k - 1) * af_dim1;
+ r__3 = (r__1 = af[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
+ af[i__ + (k - 1) * af_dim1]), dabs(r__2)), r__4 =
+ work[k - 1];
+ work[k - 1] = dmax(r__3,r__4);
+ }
+/* Computing MAX */
+ i__1 = k + k * af_dim1;
+ r__3 = (r__1 = af[i__1].r, dabs(r__1)) + (r__2 = r_imag(&af[k
+ + k * af_dim1]), dabs(r__2)), r__4 = work[k];
+ work[k] = dmax(r__3,r__4);
+ k += -2;
+ }
+ }
+ k = ncols;
+ while(k <= *n) {
+ if (ipiv[k] > 0) {
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ ++k;
+ } else {
+ kp = -ipiv[k];
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ k += 2;
+ }
+ }
+ } else {
+ k = 1;
+ while(k <= ncols) {
+ if (ipiv[k] > 0) {
+/* 1x1 pivot */
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ i__1 = *n;
+ for (i__ = k; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ i__2 = i__ + k * af_dim1;
+ r__3 = (r__1 = af[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
+ af[i__ + k * af_dim1]), dabs(r__2)), r__4 = work[
+ k];
+ work[k] = dmax(r__3,r__4);
+ }
+ ++k;
+ } else {
+/* 2x2 pivot */
+ kp = -ipiv[k];
+ tmp = work[*n + k + 1];
+ work[*n + k + 1] = work[*n + kp];
+ work[*n + kp] = tmp;
+ i__1 = *n;
+ for (i__ = k + 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ i__2 = i__ + k * af_dim1;
+ r__3 = (r__1 = af[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
+ af[i__ + k * af_dim1]), dabs(r__2)), r__4 = work[
+ k];
+ work[k] = dmax(r__3,r__4);
+/* Computing MAX */
+ i__2 = i__ + (k + 1) * af_dim1;
+ r__3 = (r__1 = af[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
+ af[i__ + (k + 1) * af_dim1]), dabs(r__2)), r__4 =
+ work[k + 1];
+ work[k + 1] = dmax(r__3,r__4);
+ }
+/* Computing MAX */
+ i__1 = k + k * af_dim1;
+ r__3 = (r__1 = af[i__1].r, dabs(r__1)) + (r__2 = r_imag(&af[k
+ + k * af_dim1]), dabs(r__2)), r__4 = work[k];
+ work[k] = dmax(r__3,r__4);
+ k += 2;
+ }
+ }
+ k = ncols;
+ while(k >= 1) {
+ if (ipiv[k] > 0) {
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ --k;
+ } else {
+ kp = -ipiv[k];
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ k += -2;
+ }
+ }
+ }
+
+/* Compute the *inverse* of the max element growth factor. Dividing */
+/* by zero would imply the largest entry of the factor's column is */
+/* zero. Than can happen when either the column of A is zero or */
+/* massive pivots made the factor underflow to zero. Neither counts */
+/* as growth in itself, so simply ignore terms with zero */
+/* denominators. */
+
+ if (upper) {
+ i__1 = *n;
+ for (i__ = ncols; i__ <= i__1; ++i__) {
+ umax = work[i__];
+ amax = work[*n + i__];
+ if (umax != 0.f) {
+/* Computing MIN */
+ r__1 = amax / umax;
+ rpvgrw = dmin(r__1,rpvgrw);
+ }
+ }
+ } else {
+ i__1 = ncols;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ umax = work[i__];
+ amax = work[*n + i__];
+ if (umax != 0.f) {
+/* Computing MIN */
+ r__1 = amax / umax;
+ rpvgrw = dmin(r__1,rpvgrw);
+ }
+ }
+ }
+ ret_val = rpvgrw;
+ return ret_val;
+} /* cla_syrpvgrw__ */
diff --git a/SRC/cla_wwaddw.c b/SRC/cla_wwaddw.c
new file mode 100644
index 0000000..b1a3831
--- /dev/null
+++ b/SRC/cla_wwaddw.c
@@ -0,0 +1,94 @@
+/* cla_wwaddw.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cla_wwaddw__(integer *n, complex *x, complex *y, complex
+ *w)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ complex q__1, q__2, q__3;
+
+ /* Local variables */
+ integer i__;
+ complex s;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLA_WWADDW adds a vector W into a doubled-single vector (X, Y). */
+
+/* This works for all extant IBM's hex and binary floating point */
+/* arithmetics, but not for decimal. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The length of vectors X, Y, and W. */
+
+/* X, Y (input/output) COMPLEX array, length N */
+/* The doubled-single accumulation vector. */
+
+/* W (input) COMPLEX array, length N */
+/* The vector to be added. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --w;
+ --y;
+ --x;
+
+ /* Function Body */
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ q__1.r = x[i__2].r + w[i__3].r, q__1.i = x[i__2].i + w[i__3].i;
+ s.r = q__1.r, s.i = q__1.i;
+ q__2.r = s.r + s.r, q__2.i = s.i + s.i;
+ q__1.r = q__2.r - s.r, q__1.i = q__2.i - s.i;
+ s.r = q__1.r, s.i = q__1.i;
+ i__2 = i__;
+ i__3 = i__;
+ q__3.r = x[i__3].r - s.r, q__3.i = x[i__3].i - s.i;
+ i__4 = i__;
+ q__2.r = q__3.r + w[i__4].r, q__2.i = q__3.i + w[i__4].i;
+ i__5 = i__;
+ q__1.r = q__2.r + y[i__5].r, q__1.i = q__2.i + y[i__5].i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ i__2 = i__;
+ x[i__2].r = s.r, x[i__2].i = s.i;
+/* L10: */
+ }
+ return 0;
+} /* cla_wwaddw__ */
diff --git a/SRC/clabrd.c b/SRC/clabrd.c
new file mode 100644
index 0000000..e32d91d
--- /dev/null
+++ b/SRC/clabrd.c
@@ -0,0 +1,500 @@
+/* clabrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int clabrd_(integer *m, integer *n, integer *nb, complex *a,
+ integer *lda, real *d__, real *e, complex *tauq, complex *taup,
+ complex *x, integer *ldx, complex *y, integer *ldy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2,
+ i__3;
+ complex q__1;
+
+ /* Local variables */
+ integer i__;
+ complex alpha;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *), cgemv_(char *, integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, complex *,
+ integer *), clarfg_(integer *, complex *, complex *,
+ integer *, complex *), clacgv_(integer *, complex *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLABRD reduces the first NB rows and columns of a complex general */
+/* m by n matrix A to upper or lower real bidiagonal form by a unitary */
+/* transformation Q' * A * P, and returns the matrices X and Y which */
+/* are needed to apply the transformation to the unreduced part of A. */
+
+/* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower */
+/* bidiagonal form. */
+
+/* This is an auxiliary routine called by CGEBRD */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows in the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns in the matrix A. */
+
+/* NB (input) INTEGER */
+/* The number of leading rows and columns of A to be reduced. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the m by n general matrix to be reduced. */
+/* On exit, the first NB rows and columns of the matrix are */
+/* overwritten; the rest of the array is unchanged. */
+/* If m >= n, elements on and below the diagonal in the first NB */
+/* columns, with the array TAUQ, represent the unitary */
+/* matrix Q as a product of elementary reflectors; and */
+/* elements above the diagonal in the first NB rows, with the */
+/* array TAUP, represent the unitary matrix P as a product */
+/* of elementary reflectors. */
+/* If m < n, elements below the diagonal in the first NB */
+/* columns, with the array TAUQ, represent the unitary */
+/* matrix Q as a product of elementary reflectors, and */
+/* elements on and above the diagonal in the first NB rows, */
+/* with the array TAUP, represent the unitary matrix P as */
+/* a product of elementary reflectors. */
+/* See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* D (output) REAL array, dimension (NB) */
+/* The diagonal elements of the first NB rows and columns of */
+/* the reduced matrix. D(i) = A(i,i). */
+
+/* E (output) REAL array, dimension (NB) */
+/* The off-diagonal elements of the first NB rows and columns of */
+/* the reduced matrix. */
+
+/* TAUQ (output) COMPLEX array dimension (NB) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the unitary matrix Q. See Further Details. */
+
+/* TAUP (output) COMPLEX array, dimension (NB) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the unitary matrix P. See Further Details. */
+
+/* X (output) COMPLEX array, dimension (LDX,NB) */
+/* The m-by-nb matrix X required to update the unreduced part */
+/* of A. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,M). */
+
+/* Y (output) COMPLEX array, dimension (LDY,NB) */
+/* The n-by-nb matrix Y required to update the unreduced part */
+/* of A. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= max(1,N). */
+
+/* Further Details */
+/* =============== */
+
+/* The matrices Q and P are represented as products of elementary */
+/* reflectors: */
+
+/* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) */
+
+/* Each H(i) and G(i) has the form: */
+
+/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
+
+/* where tauq and taup are complex scalars, and v and u are complex */
+/* vectors. */
+
+/* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in */
+/* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in */
+/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in */
+/* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in */
+/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* The elements of the vectors v and u together form the m-by-nb matrix */
+/* V and the nb-by-n matrix U' which are needed, with X and Y, to apply */
+/* the transformation to the unreduced part of the matrix, using a block */
+/* update of the form: A := A - V*Y' - X*U'. */
+
+/* The contents of A on exit are illustrated by the following examples */
+/* with nb = 2: */
+
+/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
+
+/* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) */
+/* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) */
+/* ( v1 v2 a a a ) ( v1 1 a a a a ) */
+/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */
+/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */
+/* ( v1 v2 a a a ) */
+
+/* where a denotes an element of the original matrix which is unchanged, */
+/* vi denotes an element of the vector defining H(i), and ui an element */
+/* of the vector defining G(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ --tauq;
+ --taup;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+ if (*m >= *n) {
+
+/* Reduce to upper bidiagonal form */
+
+ i__1 = *nb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Update A(i:m,i) */
+
+ i__2 = i__ - 1;
+ clacgv_(&i__2, &y[i__ + y_dim1], ldy);
+ i__2 = *m - i__ + 1;
+ i__3 = i__ - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__2, &i__3, &q__1, &a[i__ + a_dim1], lda,
+ &y[i__ + y_dim1], ldy, &c_b2, &a[i__ + i__ * a_dim1], &
+ c__1);
+ i__2 = i__ - 1;
+ clacgv_(&i__2, &y[i__ + y_dim1], ldy);
+ i__2 = *m - i__ + 1;
+ i__3 = i__ - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__2, &i__3, &q__1, &x[i__ + x_dim1], ldx,
+ &a[i__ * a_dim1 + 1], &c__1, &c_b2, &a[i__ + i__ *
+ a_dim1], &c__1);
+
+/* Generate reflection Q(i) to annihilate A(i+1:m,i) */
+
+ i__2 = i__ + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *m - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ clarfg_(&i__2, &alpha, &a[min(i__3, *m)+ i__ * a_dim1], &c__1, &
+ tauq[i__]);
+ i__2 = i__;
+ d__[i__2] = alpha.r;
+ if (i__ < *n) {
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+
+/* Compute Y(i+1:n,i) */
+
+ i__2 = *m - i__ + 1;
+ i__3 = *n - i__;
+ cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + (
+ i__ + 1) * a_dim1], lda, &a[i__ + i__ * a_dim1], &
+ c__1, &c_b1, &y[i__ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *m - i__ + 1;
+ i__3 = i__ - 1;
+ cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ +
+ a_dim1], lda, &a[i__ + i__ * a_dim1], &c__1, &c_b1, &
+ y[i__ * y_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__2, &i__3, &q__1, &y[i__ + 1 +
+ y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b2, &y[
+ i__ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *m - i__ + 1;
+ i__3 = i__ - 1;
+ cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &x[i__ +
+ x_dim1], ldx, &a[i__ + i__ * a_dim1], &c__1, &c_b1, &
+ y[i__ * y_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Conjugate transpose", &i__2, &i__3, &q__1, &a[(i__ +
+ 1) * a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &
+ c_b2, &y[i__ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *n - i__;
+ cscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
+
+/* Update A(i,i+1:n) */
+
+ i__2 = *n - i__;
+ clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
+ clacgv_(&i__, &a[i__ + a_dim1], lda);
+ i__2 = *n - i__;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__2, &i__, &q__1, &y[i__ + 1 +
+ y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b2, &a[i__ + (
+ i__ + 1) * a_dim1], lda);
+ clacgv_(&i__, &a[i__ + a_dim1], lda);
+ i__2 = i__ - 1;
+ clacgv_(&i__2, &x[i__ + x_dim1], ldx);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Conjugate transpose", &i__2, &i__3, &q__1, &a[(i__ +
+ 1) * a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b2, &
+ a[i__ + (i__ + 1) * a_dim1], lda);
+ i__2 = i__ - 1;
+ clacgv_(&i__2, &x[i__ + x_dim1], ldx);
+
+/* Generate reflection P(i) to annihilate A(i,i+2:n) */
+
+ i__2 = i__ + (i__ + 1) * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *n - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ clarfg_(&i__2, &alpha, &a[i__ + min(i__3, *n)* a_dim1], lda, &
+ taup[i__]);
+ i__2 = i__;
+ e[i__2] = alpha.r;
+ i__2 = i__ + (i__ + 1) * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+
+/* Compute X(i+1:m,i) */
+
+ i__2 = *m - i__;
+ i__3 = *n - i__;
+ cgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (i__
+ + 1) * a_dim1], lda, &a[i__ + (i__ + 1) * a_dim1],
+ lda, &c_b1, &x[i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = *n - i__;
+ cgemv_("Conjugate transpose", &i__2, &i__, &c_b2, &y[i__ + 1
+ + y_dim1], ldy, &a[i__ + (i__ + 1) * a_dim1], lda, &
+ c_b1, &x[i__ * x_dim1 + 1], &c__1);
+ i__2 = *m - i__;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__2, &i__, &q__1, &a[i__ + 1 +
+ a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
+ i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ cgemv_("No transpose", &i__2, &i__3, &c_b2, &a[(i__ + 1) *
+ a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, &
+ c_b1, &x[i__ * x_dim1 + 1], &c__1);
+ i__2 = *m - i__;
+ i__3 = i__ - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__2, &i__3, &q__1, &x[i__ + 1 +
+ x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
+ i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = *m - i__;
+ cscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = *n - i__;
+ clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Reduce to lower bidiagonal form */
+
+ i__1 = *nb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Update A(i,i:n) */
+
+ i__2 = *n - i__ + 1;
+ clacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
+ i__2 = i__ - 1;
+ clacgv_(&i__2, &a[i__ + a_dim1], lda);
+ i__2 = *n - i__ + 1;
+ i__3 = i__ - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__2, &i__3, &q__1, &y[i__ + y_dim1], ldy,
+ &a[i__ + a_dim1], lda, &c_b2, &a[i__ + i__ * a_dim1],
+ lda);
+ i__2 = i__ - 1;
+ clacgv_(&i__2, &a[i__ + a_dim1], lda);
+ i__2 = i__ - 1;
+ clacgv_(&i__2, &x[i__ + x_dim1], ldx);
+ i__2 = i__ - 1;
+ i__3 = *n - i__ + 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Conjugate transpose", &i__2, &i__3, &q__1, &a[i__ *
+ a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b2, &a[i__ +
+ i__ * a_dim1], lda);
+ i__2 = i__ - 1;
+ clacgv_(&i__2, &x[i__ + x_dim1], ldx);
+
+/* Generate reflection P(i) to annihilate A(i,i+1:n) */
+
+ i__2 = i__ + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *n - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ clarfg_(&i__2, &alpha, &a[i__ + min(i__3, *n)* a_dim1], lda, &
+ taup[i__]);
+ i__2 = i__;
+ d__[i__2] = alpha.r;
+ if (i__ < *m) {
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+
+/* Compute X(i+1:m,i) */
+
+ i__2 = *m - i__;
+ i__3 = *n - i__ + 1;
+ cgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + i__ *
+ a_dim1], lda, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[
+ i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = *n - i__ + 1;
+ i__3 = i__ - 1;
+ cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &y[i__ +
+ y_dim1], ldy, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[
+ i__ * x_dim1 + 1], &c__1);
+ i__2 = *m - i__;
+ i__3 = i__ - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__2, &i__3, &q__1, &a[i__ + 1 +
+ a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
+ i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__ + 1;
+ cgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ * a_dim1 +
+ 1], lda, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[i__ *
+ x_dim1 + 1], &c__1);
+ i__2 = *m - i__;
+ i__3 = i__ - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__2, &i__3, &q__1, &x[i__ + 1 +
+ x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
+ i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = *m - i__;
+ cscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = *n - i__ + 1;
+ clacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
+
+/* Update A(i+1:m,i) */
+
+ i__2 = i__ - 1;
+ clacgv_(&i__2, &y[i__ + y_dim1], ldy);
+ i__2 = *m - i__;
+ i__3 = i__ - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__2, &i__3, &q__1, &a[i__ + 1 +
+ a_dim1], lda, &y[i__ + y_dim1], ldy, &c_b2, &a[i__ +
+ 1 + i__ * a_dim1], &c__1);
+ i__2 = i__ - 1;
+ clacgv_(&i__2, &y[i__ + y_dim1], ldy);
+ i__2 = *m - i__;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__2, &i__, &q__1, &x[i__ + 1 +
+ x_dim1], ldx, &a[i__ * a_dim1 + 1], &c__1, &c_b2, &a[
+ i__ + 1 + i__ * a_dim1], &c__1);
+
+/* Generate reflection Q(i) to annihilate A(i+2:m,i) */
+
+ i__2 = i__ + 1 + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *m - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ clarfg_(&i__2, &alpha, &a[min(i__3, *m)+ i__ * a_dim1], &c__1,
+ &tauq[i__]);
+ i__2 = i__;
+ e[i__2] = alpha.r;
+ i__2 = i__ + 1 + i__ * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+
+/* Compute Y(i+1:n,i) */
+
+ i__2 = *m - i__;
+ i__3 = *n - i__;
+ cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1
+ + (i__ + 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1]
+, &c__1, &c_b1, &y[i__ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *m - i__;
+ i__3 = i__ - 1;
+ cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1
+ + a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &
+ c_b1, &y[i__ * y_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__2, &i__3, &q__1, &y[i__ + 1 +
+ y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b2, &y[
+ i__ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *m - i__;
+ cgemv_("Conjugate transpose", &i__2, &i__, &c_b2, &x[i__ + 1
+ + x_dim1], ldx, &a[i__ + 1 + i__ * a_dim1], &c__1, &
+ c_b1, &y[i__ * y_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Conjugate transpose", &i__, &i__2, &q__1, &a[(i__ + 1)
+ * a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &
+ c_b2, &y[i__ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *n - i__;
+ cscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
+ } else {
+ i__2 = *n - i__ + 1;
+ clacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+/* End of CLABRD */
+
+} /* clabrd_ */
diff --git a/SRC/clacgv.c b/SRC/clacgv.c
new file mode 100644
index 0000000..31fa8ff
--- /dev/null
+++ b/SRC/clacgv.c
@@ -0,0 +1,95 @@
+/* clacgv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int clacgv_(integer *n, complex *x, integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ complex q__1;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, ioff;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLACGV conjugates a complex vector of length N. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The length of the vector X. N >= 0. */
+
+/* X (input/output) COMPLEX array, dimension */
+/* (1+(N-1)*abs(INCX)) */
+/* On entry, the vector of length N to be conjugated. */
+/* On exit, X is overwritten with conjg(X). */
+
+/* INCX (input) INTEGER */
+/* The spacing between successive elements of X. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --x;
+
+ /* Function Body */
+ if (*incx == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ r_cnjg(&q__1, &x[i__]);
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+/* L10: */
+ }
+ } else {
+ ioff = 1;
+ if (*incx < 0) {
+ ioff = 1 - (*n - 1) * *incx;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ioff;
+ r_cnjg(&q__1, &x[ioff]);
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ ioff += *incx;
+/* L20: */
+ }
+ }
+ return 0;
+
+/* End of CLACGV */
+
+} /* clacgv_ */
diff --git a/SRC/clacn2.c b/SRC/clacn2.c
new file mode 100644
index 0000000..221f4e3
--- /dev/null
+++ b/SRC/clacn2.c
@@ -0,0 +1,283 @@
+/* clacn2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int clacn2_(integer *n, complex *v, complex *x, real *est,
+ integer *kase, integer *isave)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ double c_abs(complex *), r_imag(complex *);
+
+ /* Local variables */
+ integer i__;
+ real temp, absxi;
+ integer jlast;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ extern integer icmax1_(integer *, complex *, integer *);
+ extern doublereal scsum1_(integer *, complex *, integer *), slamch_(char *
+);
+ real safmin, altsgn, estold;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLACN2 estimates the 1-norm of a square, complex matrix A. */
+/* Reverse communication is used for evaluating matrix-vector products. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 1. */
+
+/* V (workspace) COMPLEX array, dimension (N) */
+/* On the final return, V = A*W, where EST = norm(V)/norm(W) */
+/* (W is not returned). */
+
+/* X (input/output) COMPLEX array, dimension (N) */
+/* On an intermediate return, X should be overwritten by */
+/* A * X, if KASE=1, */
+/* A' * X, if KASE=2, */
+/* where A' is the conjugate transpose of A, and CLACN2 must be */
+/* re-called with all the other parameters unchanged. */
+
+/* EST (input/output) REAL */
+/* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be */
+/* unchanged from the previous call to CLACN2. */
+/* On exit, EST is an estimate (a lower bound) for norm(A). */
+
+/* KASE (input/output) INTEGER */
+/* On the initial call to CLACN2, KASE should be 0. */
+/* On an intermediate return, KASE will be 1 or 2, indicating */
+/* whether X should be overwritten by A * X or A' * X. */
+/* On the final return from CLACN2, KASE will again be 0. */
+
+/* ISAVE (input/output) INTEGER array, dimension (3) */
+/* ISAVE is used to save variables between calls to SLACN2 */
+
+/* Further Details */
+/* ======= ======= */
+
+/* Contributed by Nick Higham, University of Manchester. */
+/* Originally named CONEST, dated March 16, 1988. */
+
+/* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */
+/* a real or complex matrix, with applications to condition estimation", */
+/* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */
+
+/* Last modified: April, 1999 */
+
+/* This is a thread safe version of CLACON, which uses the array ISAVE */
+/* in place of a SAVE statement, as follows: */
+
+/* CLACON CLACN2 */
+/* JUMP ISAVE(1) */
+/* J ISAVE(2) */
+/* ITER ISAVE(3) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --isave;
+ --x;
+ --v;
+
+ /* Function Body */
+ safmin = slamch_("Safe minimum");
+ if (*kase == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ r__1 = 1.f / (real) (*n);
+ q__1.r = r__1, q__1.i = 0.f;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+/* L10: */
+ }
+ *kase = 1;
+ isave[1] = 1;
+ return 0;
+ }
+
+ switch (isave[1]) {
+ case 1: goto L20;
+ case 2: goto L40;
+ case 3: goto L70;
+ case 4: goto L90;
+ case 5: goto L120;
+ }
+
+/* ................ ENTRY (ISAVE( 1 ) = 1) */
+/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */
+
+L20:
+ if (*n == 1) {
+ v[1].r = x[1].r, v[1].i = x[1].i;
+ *est = c_abs(&v[1]);
+/* ... QUIT */
+ goto L130;
+ }
+ *est = scsum1_(n, &x[1], &c__1);
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ absxi = c_abs(&x[i__]);
+ if (absxi > safmin) {
+ i__2 = i__;
+ i__3 = i__;
+ r__1 = x[i__3].r / absxi;
+ r__2 = r_imag(&x[i__]) / absxi;
+ q__1.r = r__1, q__1.i = r__2;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ } else {
+ i__2 = i__;
+ x[i__2].r = 1.f, x[i__2].i = 0.f;
+ }
+/* L30: */
+ }
+ *kase = 2;
+ isave[1] = 2;
+ return 0;
+
+/* ................ ENTRY (ISAVE( 1 ) = 2) */
+/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. */
+
+L40:
+ isave[2] = icmax1_(n, &x[1], &c__1);
+ isave[3] = 2;
+
+/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */
+
+L50:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ x[i__2].r = 0.f, x[i__2].i = 0.f;
+/* L60: */
+ }
+ i__1 = isave[2];
+ x[i__1].r = 1.f, x[i__1].i = 0.f;
+ *kase = 1;
+ isave[1] = 3;
+ return 0;
+
+/* ................ ENTRY (ISAVE( 1 ) = 3) */
+/* X HAS BEEN OVERWRITTEN BY A*X. */
+
+L70:
+ ccopy_(n, &x[1], &c__1, &v[1], &c__1);
+ estold = *est;
+ *est = scsum1_(n, &v[1], &c__1);
+
+/* TEST FOR CYCLING. */
+ if (*est <= estold) {
+ goto L100;
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ absxi = c_abs(&x[i__]);
+ if (absxi > safmin) {
+ i__2 = i__;
+ i__3 = i__;
+ r__1 = x[i__3].r / absxi;
+ r__2 = r_imag(&x[i__]) / absxi;
+ q__1.r = r__1, q__1.i = r__2;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ } else {
+ i__2 = i__;
+ x[i__2].r = 1.f, x[i__2].i = 0.f;
+ }
+/* L80: */
+ }
+ *kase = 2;
+ isave[1] = 4;
+ return 0;
+
+/* ................ ENTRY (ISAVE( 1 ) = 4) */
+/* X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. */
+
+L90:
+ jlast = isave[2];
+ isave[2] = icmax1_(n, &x[1], &c__1);
+ if (c_abs(&x[jlast]) != c_abs(&x[isave[2]]) && isave[3] < 5) {
+ ++isave[3];
+ goto L50;
+ }
+
+/* ITERATION COMPLETE. FINAL STAGE. */
+
+L100:
+ altsgn = 1.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ r__1 = altsgn * ((real) (i__ - 1) / (real) (*n - 1) + 1.f);
+ q__1.r = r__1, q__1.i = 0.f;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ altsgn = -altsgn;
+/* L110: */
+ }
+ *kase = 1;
+ isave[1] = 5;
+ return 0;
+
+/* ................ ENTRY (ISAVE( 1 ) = 5) */
+/* X HAS BEEN OVERWRITTEN BY A*X. */
+
+L120:
+ temp = scsum1_(n, &x[1], &c__1) / (real) (*n * 3) * 2.f;
+ if (temp > *est) {
+ ccopy_(n, &x[1], &c__1, &v[1], &c__1);
+ *est = temp;
+ }
+
+L130:
+ *kase = 0;
+ return 0;
+
+/* End of CLACN2 */
+
+} /* clacn2_ */
diff --git a/SRC/clacon.c b/SRC/clacon.c
new file mode 100644
index 0000000..f77e3dc
--- /dev/null
+++ b/SRC/clacon.c
@@ -0,0 +1,275 @@
+/* clacon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int clacon_(integer *n, complex *v, complex *x, real *est,
+ integer *kase)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ double c_abs(complex *), r_imag(complex *);
+
+ /* Local variables */
+ static integer i__, j, iter;
+ static real temp;
+ static integer jump;
+ static real absxi;
+ static integer jlast;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ extern integer icmax1_(integer *, complex *, integer *);
+ extern doublereal scsum1_(integer *, complex *, integer *), slamch_(char *
+);
+ static real safmin, altsgn, estold;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLACON estimates the 1-norm of a square, complex matrix A. */
+/* Reverse communication is used for evaluating matrix-vector products. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 1. */
+
+/* V (workspace) COMPLEX array, dimension (N) */
+/* On the final return, V = A*W, where EST = norm(V)/norm(W) */
+/* (W is not returned). */
+
+/* X (input/output) COMPLEX array, dimension (N) */
+/* On an intermediate return, X should be overwritten by */
+/* A * X, if KASE=1, */
+/* A' * X, if KASE=2, */
+/* where A' is the conjugate transpose of A, and CLACON must be */
+/* re-called with all the other parameters unchanged. */
+
+/* EST (input/output) REAL */
+/* On entry with KASE = 1 or 2 and JUMP = 3, EST should be */
+/* unchanged from the previous call to CLACON. */
+/* On exit, EST is an estimate (a lower bound) for norm(A). */
+
+/* KASE (input/output) INTEGER */
+/* On the initial call to CLACON, KASE should be 0. */
+/* On an intermediate return, KASE will be 1 or 2, indicating */
+/* whether X should be overwritten by A * X or A' * X. */
+/* On the final return from CLACON, KASE will again be 0. */
+
+/* Further Details */
+/* ======= ======= */
+
+/* Contributed by Nick Higham, University of Manchester. */
+/* Originally named CONEST, dated March 16, 1988. */
+
+/* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */
+/* a real or complex matrix, with applications to condition estimation", */
+/* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */
+
+/* Last modified: April, 1999 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --x;
+ --v;
+
+ /* Function Body */
+ safmin = slamch_("Safe minimum");
+ if (*kase == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ r__1 = 1.f / (real) (*n);
+ q__1.r = r__1, q__1.i = 0.f;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+/* L10: */
+ }
+ *kase = 1;
+ jump = 1;
+ return 0;
+ }
+
+ switch (jump) {
+ case 1: goto L20;
+ case 2: goto L40;
+ case 3: goto L70;
+ case 4: goto L90;
+ case 5: goto L120;
+ }
+
+/* ................ ENTRY (JUMP = 1) */
+/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */
+
+L20:
+ if (*n == 1) {
+ v[1].r = x[1].r, v[1].i = x[1].i;
+ *est = c_abs(&v[1]);
+/* ... QUIT */
+ goto L130;
+ }
+ *est = scsum1_(n, &x[1], &c__1);
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ absxi = c_abs(&x[i__]);
+ if (absxi > safmin) {
+ i__2 = i__;
+ i__3 = i__;
+ r__1 = x[i__3].r / absxi;
+ r__2 = r_imag(&x[i__]) / absxi;
+ q__1.r = r__1, q__1.i = r__2;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ } else {
+ i__2 = i__;
+ x[i__2].r = 1.f, x[i__2].i = 0.f;
+ }
+/* L30: */
+ }
+ *kase = 2;
+ jump = 2;
+ return 0;
+
+/* ................ ENTRY (JUMP = 2) */
+/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. */
+
+L40:
+ j = icmax1_(n, &x[1], &c__1);
+ iter = 2;
+
+/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */
+
+L50:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ x[i__2].r = 0.f, x[i__2].i = 0.f;
+/* L60: */
+ }
+ i__1 = j;
+ x[i__1].r = 1.f, x[i__1].i = 0.f;
+ *kase = 1;
+ jump = 3;
+ return 0;
+
+/* ................ ENTRY (JUMP = 3) */
+/* X HAS BEEN OVERWRITTEN BY A*X. */
+
+L70:
+ ccopy_(n, &x[1], &c__1, &v[1], &c__1);
+ estold = *est;
+ *est = scsum1_(n, &v[1], &c__1);
+
+/* TEST FOR CYCLING. */
+ if (*est <= estold) {
+ goto L100;
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ absxi = c_abs(&x[i__]);
+ if (absxi > safmin) {
+ i__2 = i__;
+ i__3 = i__;
+ r__1 = x[i__3].r / absxi;
+ r__2 = r_imag(&x[i__]) / absxi;
+ q__1.r = r__1, q__1.i = r__2;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ } else {
+ i__2 = i__;
+ x[i__2].r = 1.f, x[i__2].i = 0.f;
+ }
+/* L80: */
+ }
+ *kase = 2;
+ jump = 4;
+ return 0;
+
+/* ................ ENTRY (JUMP = 4) */
+/* X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. */
+
+L90:
+ jlast = j;
+ j = icmax1_(n, &x[1], &c__1);
+ if (c_abs(&x[jlast]) != c_abs(&x[j]) && iter < 5) {
+ ++iter;
+ goto L50;
+ }
+
+/* ITERATION COMPLETE. FINAL STAGE. */
+
+L100:
+ altsgn = 1.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ r__1 = altsgn * ((real) (i__ - 1) / (real) (*n - 1) + 1.f);
+ q__1.r = r__1, q__1.i = 0.f;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ altsgn = -altsgn;
+/* L110: */
+ }
+ *kase = 1;
+ jump = 5;
+ return 0;
+
+/* ................ ENTRY (JUMP = 5) */
+/* X HAS BEEN OVERWRITTEN BY A*X. */
+
+L120:
+ temp = scsum1_(n, &x[1], &c__1) / (real) (*n * 3) * 2.f;
+ if (temp > *est) {
+ ccopy_(n, &x[1], &c__1, &v[1], &c__1);
+ *est = temp;
+ }
+
+L130:
+ *kase = 0;
+ return 0;
+
+/* End of CLACON */
+
+} /* clacon_ */
diff --git a/SRC/clacp2.c b/SRC/clacp2.c
new file mode 100644
index 0000000..379eb8f
--- /dev/null
+++ b/SRC/clacp2.c
@@ -0,0 +1,134 @@
+/* clacp2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int clacp2_(char *uplo, integer *m, integer *n, real *a,
+ integer *lda, complex *b, integer *ldb)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j;
+ extern logical lsame_(char *, char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLACP2 copies all or part of a real two-dimensional matrix A to a */
+/* complex matrix B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies the part of the matrix A to be copied to B. */
+/* = 'U': Upper triangular part */
+/* = 'L': Lower triangular part */
+/* Otherwise: All of the matrix A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The m by n matrix A. If UPLO = 'U', only the upper trapezium */
+/* is accessed; if UPLO = 'L', only the lower trapezium is */
+/* accessed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (output) COMPLEX array, dimension (LDB,N) */
+/* On exit, B = A in the locations specified by UPLO. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(j,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * a_dim1;
+ b[i__3].r = a[i__4], b[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+
+ } else if (lsame_(uplo, "L")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * a_dim1;
+ b[i__3].r = a[i__4], b[i__3].i = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * a_dim1;
+ b[i__3].r = a[i__4], b[i__3].i = 0.f;
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+
+ return 0;
+
+/* End of CLACP2 */
+
+} /* clacp2_ */
diff --git a/SRC/clacpy.c b/SRC/clacpy.c
new file mode 100644
index 0000000..6d3f585
--- /dev/null
+++ b/SRC/clacpy.c
@@ -0,0 +1,134 @@
+/* clacpy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int clacpy_(char *uplo, integer *m, integer *n, complex *a,
+ integer *lda, complex *b, integer *ldb)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j;
+ extern logical lsame_(char *, char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLACPY copies all or part of a two-dimensional matrix A to another */
+/* matrix B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies the part of the matrix A to be copied to B. */
+/* = 'U': Upper triangular part */
+/* = 'L': Lower triangular part */
+/* Otherwise: All of the matrix A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The m by n matrix A. If UPLO = 'U', only the upper trapezium */
+/* is accessed; if UPLO = 'L', only the lower trapezium is */
+/* accessed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (output) COMPLEX array, dimension (LDB,N) */
+/* On exit, B = A in the locations specified by UPLO. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(j,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * a_dim1;
+ b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i;
+/* L10: */
+ }
+/* L20: */
+ }
+
+ } else if (lsame_(uplo, "L")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * a_dim1;
+ b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i;
+/* L30: */
+ }
+/* L40: */
+ }
+
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * a_dim1;
+ b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i;
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+
+ return 0;
+
+/* End of CLACPY */
+
+} /* clacpy_ */
diff --git a/SRC/clacrm.c b/SRC/clacrm.c
new file mode 100644
index 0000000..ea759a1
--- /dev/null
+++ b/SRC/clacrm.c
@@ -0,0 +1,176 @@
+/* clacrm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b6 = 1.f;
+static real c_b7 = 0.f;
+
+/* Subroutine */ int clacrm_(integer *m, integer *n, complex *a, integer *lda,
+ real *b, integer *ldb, complex *c__, integer *ldc, real *rwork)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, a_dim1, a_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5;
+ real r__1;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, l;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLACRM performs a very simple matrix-matrix multiplication: */
+/* C := A * B, */
+/* where A is M by N and complex; B is N by N and real; */
+/* C is M by N and complex. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A and of the matrix C. */
+/* M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns and rows of the matrix B and */
+/* the number of columns of the matrix C. */
+/* N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA, N) */
+/* A contains the M by N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >=max(1,M). */
+
+/* B (input) REAL array, dimension (LDB, N) */
+/* B contains the N by N matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >=max(1,N). */
+
+/* C (input) COMPLEX array, dimension (LDC, N) */
+/* C contains the M by N matrix C. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >=max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (2*M*N) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ rwork[(j - 1) * *m + i__] = a[i__3].r;
+/* L10: */
+ }
+/* L20: */
+ }
+
+ l = *m * *n + 1;
+ sgemm_("N", "N", m, n, n, &c_b6, &rwork[1], m, &b[b_offset], ldb, &c_b7, &
+ rwork[l], m);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = l + (j - 1) * *m + i__ - 1;
+ c__[i__3].r = rwork[i__4], c__[i__3].i = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ rwork[(j - 1) * *m + i__] = r_imag(&a[i__ + j * a_dim1]);
+/* L50: */
+ }
+/* L60: */
+ }
+ sgemm_("N", "N", m, n, n, &c_b6, &rwork[1], m, &b[b_offset], ldb, &c_b7, &
+ rwork[l], m);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ r__1 = c__[i__4].r;
+ i__5 = l + (j - 1) * *m + i__ - 1;
+ q__1.r = r__1, q__1.i = rwork[i__5];
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+
+ return 0;
+
+/* End of CLACRM */
+
+} /* clacrm_ */
diff --git a/SRC/clacrt.c b/SRC/clacrt.c
new file mode 100644
index 0000000..45bd677
--- /dev/null
+++ b/SRC/clacrt.c
@@ -0,0 +1,155 @@
+/* clacrt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int clacrt_(integer *n, complex *cx, integer *incx, complex *
+ cy, integer *incy, complex *c__, complex *s)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ complex q__1, q__2, q__3;
+
+ /* Local variables */
+ integer i__, ix, iy;
+ complex ctemp;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLACRT performs the operation */
+
+/* ( c s )( x ) ==> ( x ) */
+/* ( -s c )( y ) ( y ) */
+
+/* where c and s are complex and the vectors x and y are complex. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of elements in the vectors CX and CY. */
+
+/* CX (input/output) COMPLEX array, dimension (N) */
+/* On input, the vector x. */
+/* On output, CX is overwritten with c*x + s*y. */
+
+/* INCX (input) INTEGER */
+/* The increment between successive values of CX. INCX <> 0. */
+
+/* CY (input/output) COMPLEX array, dimension (N) */
+/* On input, the vector y. */
+/* On output, CY is overwritten with -s*x + c*y. */
+
+/* INCY (input) INTEGER */
+/* The increment between successive values of CY. INCY <> 0. */
+
+/* C (input) COMPLEX */
+/* S (input) COMPLEX */
+/* C and S define the matrix */
+/* [ C S ]. */
+/* [ -S C ] */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --cy;
+ --cx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* Code for unequal increments or equal increments not equal to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ix;
+ q__2.r = c__->r * cx[i__2].r - c__->i * cx[i__2].i, q__2.i = c__->r *
+ cx[i__2].i + c__->i * cx[i__2].r;
+ i__3 = iy;
+ q__3.r = s->r * cy[i__3].r - s->i * cy[i__3].i, q__3.i = s->r * cy[
+ i__3].i + s->i * cy[i__3].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__2 = iy;
+ i__3 = iy;
+ q__2.r = c__->r * cy[i__3].r - c__->i * cy[i__3].i, q__2.i = c__->r *
+ cy[i__3].i + c__->i * cy[i__3].r;
+ i__4 = ix;
+ q__3.r = s->r * cx[i__4].r - s->i * cx[i__4].i, q__3.i = s->r * cx[
+ i__4].i + s->i * cx[i__4].r;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ cy[i__2].r = q__1.r, cy[i__2].i = q__1.i;
+ i__2 = ix;
+ cx[i__2].r = ctemp.r, cx[i__2].i = ctemp.i;
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ return 0;
+
+/* Code for both increments equal to 1 */
+
+L20:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ q__2.r = c__->r * cx[i__2].r - c__->i * cx[i__2].i, q__2.i = c__->r *
+ cx[i__2].i + c__->i * cx[i__2].r;
+ i__3 = i__;
+ q__3.r = s->r * cy[i__3].r - s->i * cy[i__3].i, q__3.i = s->r * cy[
+ i__3].i + s->i * cy[i__3].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__2 = i__;
+ i__3 = i__;
+ q__2.r = c__->r * cy[i__3].r - c__->i * cy[i__3].i, q__2.i = c__->r *
+ cy[i__3].i + c__->i * cy[i__3].r;
+ i__4 = i__;
+ q__3.r = s->r * cx[i__4].r - s->i * cx[i__4].i, q__3.i = s->r * cx[
+ i__4].i + s->i * cx[i__4].r;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ cy[i__2].r = q__1.r, cy[i__2].i = q__1.i;
+ i__2 = i__;
+ cx[i__2].r = ctemp.r, cx[i__2].i = ctemp.i;
+/* L30: */
+ }
+ return 0;
+} /* clacrt_ */
diff --git a/SRC/cladiv.c b/SRC/cladiv.c
new file mode 100644
index 0000000..d10c959
--- /dev/null
+++ b/SRC/cladiv.c
@@ -0,0 +1,74 @@
+/* cladiv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Complex */ VOID cladiv_(complex * ret_val, complex *x, complex *y)
+{
+ /* System generated locals */
+ real r__1, r__2, r__3, r__4;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ real zi, zr;
+ extern /* Subroutine */ int sladiv_(real *, real *, real *, real *, real *
+, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLADIV := X / Y, where X and Y are complex. The computation of X / Y */
+/* will not overflow on an intermediary step unless the results */
+/* overflows. */
+
+/* Arguments */
+/* ========= */
+
+/* X (input) COMPLEX */
+/* Y (input) COMPLEX */
+/* The complex scalars X and Y. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ r__1 = x->r;
+ r__2 = r_imag(x);
+ r__3 = y->r;
+ r__4 = r_imag(y);
+ sladiv_(&r__1, &r__2, &r__3, &r__4, &zr, &zi);
+ q__1.r = zr, q__1.i = zi;
+ ret_val->r = q__1.r, ret_val->i = q__1.i;
+
+ return ;
+
+/* End of CLADIV */
+
+} /* cladiv_ */
diff --git a/SRC/claed0.c b/SRC/claed0.c
new file mode 100644
index 0000000..a1f2a9b
--- /dev/null
+++ b/SRC/claed0.c
@@ -0,0 +1,367 @@
+/* claed0.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__9 = 9;
+static integer c__0 = 0;
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* Subroutine */ int claed0_(integer *qsiz, integer *n, real *d__, real *e,
+ complex *q, integer *ldq, complex *qstore, integer *ldqs, real *rwork,
+ integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2;
+ real r__1;
+
+ /* Builtin functions */
+ double log(doublereal);
+ integer pow_ii(integer *, integer *);
+
+ /* Local variables */
+ integer i__, j, k, ll, iq, lgn, msd2, smm1, spm1, spm2;
+ real temp;
+ integer curr, iperm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer indxq, iwrem;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ integer iqptr;
+ extern /* Subroutine */ int claed7_(integer *, integer *, integer *,
+ integer *, integer *, integer *, real *, complex *, integer *,
+ real *, integer *, real *, integer *, integer *, integer *,
+ integer *, integer *, real *, complex *, real *, integer *,
+ integer *);
+ integer tlvls;
+ extern /* Subroutine */ int clacrm_(integer *, integer *, complex *,
+ integer *, real *, integer *, complex *, integer *, real *);
+ integer igivcl;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer igivnm, submat, curprb, subpbs, igivpt, curlvl, matsiz, iprmpt,
+ smlsiz;
+ extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *,
+ real *, integer *, real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Using the divide and conquer method, CLAED0 computes all eigenvalues */
+/* of a symmetric tridiagonal matrix which is one diagonal block of */
+/* those from reducing a dense or band Hermitian matrix and */
+/* corresponding eigenvectors of the dense or band matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* QSIZ (input) INTEGER */
+/* The dimension of the unitary matrix used to reduce */
+/* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. */
+
+/* N (input) INTEGER */
+/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the diagonal elements of the tridiagonal matrix. */
+/* On exit, the eigenvalues in ascending order. */
+
+/* E (input/output) REAL array, dimension (N-1) */
+/* On entry, the off-diagonal elements of the tridiagonal matrix. */
+/* On exit, E has been destroyed. */
+
+/* Q (input/output) COMPLEX array, dimension (LDQ,N) */
+/* On entry, Q must contain an QSIZ x N matrix whose columns */
+/* unitarily orthonormal. It is a part of the unitary matrix */
+/* that reduces the full dense Hermitian matrix to a */
+/* (reducible) symmetric tridiagonal matrix. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* IWORK (workspace) INTEGER array, */
+/* the dimension of IWORK must be at least */
+/* 6 + 6*N + 5*N*lg N */
+/* ( lg( N ) = smallest integer k */
+/* such that 2^k >= N ) */
+
+/* RWORK (workspace) REAL array, */
+/* dimension (1 + 3*N + 2*N*lg N + 3*N**2) */
+/* ( lg( N ) = smallest integer k */
+/* such that 2^k >= N ) */
+
+/* QSTORE (workspace) COMPLEX array, dimension (LDQS, N) */
+/* Used to store parts of */
+/* the eigenvector matrix when the updating matrix multiplies */
+/* take place. */
+
+/* LDQS (input) INTEGER */
+/* The leading dimension of the array QSTORE. */
+/* LDQS >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: The algorithm failed to compute an eigenvalue while */
+/* working on the submatrix lying in rows and columns */
+/* INFO/(N+1) through mod(INFO,N+1). */
+
+/* ===================================================================== */
+
+/* Warning: N could be as big as QSIZ! */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ qstore_dim1 = *ldqs;
+ qstore_offset = 1 + qstore_dim1;
+ qstore -= qstore_offset;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+/* IF( ICOMPQ .LT. 0 .OR. ICOMPQ .GT. 2 ) THEN */
+/* INFO = -1 */
+/* ELSE IF( ( ICOMPQ .EQ. 1 ) .AND. ( QSIZ .LT. MAX( 0, N ) ) ) */
+/* $ THEN */
+ if (*qsiz < max(0,*n)) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldq < max(1,*n)) {
+ *info = -6;
+ } else if (*ldqs < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLAED0", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ smlsiz = ilaenv_(&c__9, "CLAED0", " ", &c__0, &c__0, &c__0, &c__0);
+
+/* Determine the size and placement of the submatrices, and save in */
+/* the leading elements of IWORK. */
+
+ iwork[1] = *n;
+ subpbs = 1;
+ tlvls = 0;
+L10:
+ if (iwork[subpbs] > smlsiz) {
+ for (j = subpbs; j >= 1; --j) {
+ iwork[j * 2] = (iwork[j] + 1) / 2;
+ iwork[(j << 1) - 1] = iwork[j] / 2;
+/* L20: */
+ }
+ ++tlvls;
+ subpbs <<= 1;
+ goto L10;
+ }
+ i__1 = subpbs;
+ for (j = 2; j <= i__1; ++j) {
+ iwork[j] += iwork[j - 1];
+/* L30: */
+ }
+
+/* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 */
+/* using rank-1 modifications (cuts). */
+
+ spm1 = subpbs - 1;
+ i__1 = spm1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ submat = iwork[i__] + 1;
+ smm1 = submat - 1;
+ d__[smm1] -= (r__1 = e[smm1], dabs(r__1));
+ d__[submat] -= (r__1 = e[smm1], dabs(r__1));
+/* L40: */
+ }
+
+ indxq = (*n << 2) + 3;
+
+/* Set up workspaces for eigenvalues only/accumulate new vectors */
+/* routine */
+
+ temp = log((real) (*n)) / log(2.f);
+ lgn = (integer) temp;
+ if (pow_ii(&c__2, &lgn) < *n) {
+ ++lgn;
+ }
+ if (pow_ii(&c__2, &lgn) < *n) {
+ ++lgn;
+ }
+ iprmpt = indxq + *n + 1;
+ iperm = iprmpt + *n * lgn;
+ iqptr = iperm + *n * lgn;
+ igivpt = iqptr + *n + 2;
+ igivcl = igivpt + *n * lgn;
+
+ igivnm = 1;
+ iq = igivnm + (*n << 1) * lgn;
+/* Computing 2nd power */
+ i__1 = *n;
+ iwrem = iq + i__1 * i__1 + 1;
+/* Initialize pointers */
+ i__1 = subpbs;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ iwork[iprmpt + i__] = 1;
+ iwork[igivpt + i__] = 1;
+/* L50: */
+ }
+ iwork[iqptr] = 1;
+
+/* Solve each submatrix eigenproblem at the bottom of the divide and */
+/* conquer tree. */
+
+ curr = 0;
+ i__1 = spm1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ if (i__ == 0) {
+ submat = 1;
+ matsiz = iwork[1];
+ } else {
+ submat = iwork[i__] + 1;
+ matsiz = iwork[i__ + 1] - iwork[i__];
+ }
+ ll = iq - 1 + iwork[iqptr + curr];
+ ssteqr_("I", &matsiz, &d__[submat], &e[submat], &rwork[ll], &matsiz, &
+ rwork[1], info);
+ clacrm_(qsiz, &matsiz, &q[submat * q_dim1 + 1], ldq, &rwork[ll], &
+ matsiz, &qstore[submat * qstore_dim1 + 1], ldqs, &rwork[iwrem]
+);
+/* Computing 2nd power */
+ i__2 = matsiz;
+ iwork[iqptr + curr + 1] = iwork[iqptr + curr] + i__2 * i__2;
+ ++curr;
+ if (*info > 0) {
+ *info = submat * (*n + 1) + submat + matsiz - 1;
+ return 0;
+ }
+ k = 1;
+ i__2 = iwork[i__ + 1];
+ for (j = submat; j <= i__2; ++j) {
+ iwork[indxq + j] = k;
+ ++k;
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Successively merge eigensystems of adjacent submatrices */
+/* into eigensystem for the corresponding larger matrix. */
+
+/* while ( SUBPBS > 1 ) */
+
+ curlvl = 1;
+L80:
+ if (subpbs > 1) {
+ spm2 = subpbs - 2;
+ i__1 = spm2;
+ for (i__ = 0; i__ <= i__1; i__ += 2) {
+ if (i__ == 0) {
+ submat = 1;
+ matsiz = iwork[2];
+ msd2 = iwork[1];
+ curprb = 0;
+ } else {
+ submat = iwork[i__] + 1;
+ matsiz = iwork[i__ + 2] - iwork[i__];
+ msd2 = matsiz / 2;
+ ++curprb;
+ }
+
+/* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) */
+/* into an eigensystem of size MATSIZ. CLAED7 handles the case */
+/* when the eigenvectors of a full or band Hermitian matrix (which */
+/* was reduced to tridiagonal form) are desired. */
+
+/* I am free to use Q as a valuable working space until Loop 150. */
+
+ claed7_(&matsiz, &msd2, qsiz, &tlvls, &curlvl, &curprb, &d__[
+ submat], &qstore[submat * qstore_dim1 + 1], ldqs, &e[
+ submat + msd2 - 1], &iwork[indxq + submat], &rwork[iq], &
+ iwork[iqptr], &iwork[iprmpt], &iwork[iperm], &iwork[
+ igivpt], &iwork[igivcl], &rwork[igivnm], &q[submat *
+ q_dim1 + 1], &rwork[iwrem], &iwork[subpbs + 1], info);
+ if (*info > 0) {
+ *info = submat * (*n + 1) + submat + matsiz - 1;
+ return 0;
+ }
+ iwork[i__ / 2 + 1] = iwork[i__ + 2];
+/* L90: */
+ }
+ subpbs /= 2;
+ ++curlvl;
+ goto L80;
+ }
+
+/* end while */
+
+/* Re-merge the eigenvalues/vectors which were deflated at the final */
+/* merge step. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ j = iwork[indxq + i__];
+ rwork[i__] = d__[j];
+ ccopy_(qsiz, &qstore[j * qstore_dim1 + 1], &c__1, &q[i__ * q_dim1 + 1]
+, &c__1);
+/* L100: */
+ }
+ scopy_(n, &rwork[1], &c__1, &d__[1], &c__1);
+
+ return 0;
+
+/* End of CLAED0 */
+
+} /* claed0_ */
diff --git a/SRC/claed7.c b/SRC/claed7.c
new file mode 100644
index 0000000..14728f8
--- /dev/null
+++ b/SRC/claed7.c
@@ -0,0 +1,325 @@
+/* claed7.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int claed7_(integer *n, integer *cutpnt, integer *qsiz,
+ integer *tlvls, integer *curlvl, integer *curpbm, real *d__, complex *
+ q, integer *ldq, real *rho, integer *indxq, real *qstore, integer *
+ qptr, integer *prmptr, integer *perm, integer *givptr, integer *
+ givcol, real *givnum, complex *work, real *rwork, integer *iwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, i__1, i__2;
+
+ /* Builtin functions */
+ integer pow_ii(integer *, integer *);
+
+ /* Local variables */
+ integer i__, k, n1, n2, iq, iw, iz, ptr, indx, curr, indxc, indxp;
+ extern /* Subroutine */ int claed8_(integer *, integer *, integer *,
+ complex *, integer *, real *, real *, integer *, real *, real *,
+ complex *, integer *, real *, integer *, integer *, integer *,
+ integer *, integer *, integer *, real *, integer *), slaed9_(
+ integer *, integer *, integer *, integer *, real *, real *,
+ integer *, real *, real *, real *, real *, integer *, integer *),
+ slaeda_(integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, real *, real *, integer *, real *
+, real *, integer *);
+ integer idlmda;
+ extern /* Subroutine */ int clacrm_(integer *, integer *, complex *,
+ integer *, real *, integer *, complex *, integer *, real *),
+ xerbla_(char *, integer *), slamrg_(integer *, integer *,
+ real *, integer *, integer *, integer *);
+ integer coltyp;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAED7 computes the updated eigensystem of a diagonal */
+/* matrix after modification by a rank-one symmetric matrix. This */
+/* routine is used only for the eigenproblem which requires all */
+/* eigenvalues and optionally eigenvectors of a dense or banded */
+/* Hermitian matrix that has been reduced to tridiagonal form. */
+
+/* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out) */
+
+/* where Z = Q'u, u is a vector of length N with ones in the */
+/* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. */
+
+/* The eigenvectors of the original matrix are stored in Q, and the */
+/* eigenvalues are in D. The algorithm consists of three stages: */
+
+/* The first stage consists of deflating the size of the problem */
+/* when there are multiple eigenvalues or if there is a zero in */
+/* the Z vector. For each such occurence the dimension of the */
+/* secular equation problem is reduced by one. This stage is */
+/* performed by the routine SLAED2. */
+
+/* The second stage consists of calculating the updated */
+/* eigenvalues. This is done by finding the roots of the secular */
+/* equation via the routine SLAED4 (as called by SLAED3). */
+/* This routine also calculates the eigenvectors of the current */
+/* problem. */
+
+/* The final stage consists of computing the updated eigenvectors */
+/* directly using the updated eigenvalues. The eigenvectors for */
+/* the current problem are multiplied with the eigenvectors from */
+/* the overall problem. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
+
+/* CUTPNT (input) INTEGER */
+/* Contains the location of the last eigenvalue in the leading */
+/* sub-matrix. min(1,N) <= CUTPNT <= N. */
+
+/* QSIZ (input) INTEGER */
+/* The dimension of the unitary matrix used to reduce */
+/* the full matrix to tridiagonal form. QSIZ >= N. */
+
+/* TLVLS (input) INTEGER */
+/* The total number of merging levels in the overall divide and */
+/* conquer tree. */
+
+/* CURLVL (input) INTEGER */
+/* The current level in the overall merge routine, */
+/* 0 <= curlvl <= tlvls. */
+
+/* CURPBM (input) INTEGER */
+/* The current problem in the current level in the overall */
+/* merge routine (counting from upper left to lower right). */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the eigenvalues of the rank-1-perturbed matrix. */
+/* On exit, the eigenvalues of the repaired matrix. */
+
+/* Q (input/output) COMPLEX array, dimension (LDQ,N) */
+/* On entry, the eigenvectors of the rank-1-perturbed matrix. */
+/* On exit, the eigenvectors of the repaired tridiagonal matrix. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* RHO (input) REAL */
+/* Contains the subdiagonal element used to create the rank-1 */
+/* modification. */
+
+/* INDXQ (output) INTEGER array, dimension (N) */
+/* This contains the permutation which will reintegrate the */
+/* subproblem just solved back into sorted order, */
+/* ie. D( INDXQ( I = 1, N ) ) will be in ascending order. */
+
+/* IWORK (workspace) INTEGER array, dimension (4*N) */
+
+/* RWORK (workspace) REAL array, */
+/* dimension (3*N+2*QSIZ*N) */
+
+/* WORK (workspace) COMPLEX array, dimension (QSIZ*N) */
+
+/* QSTORE (input/output) REAL array, dimension (N**2+1) */
+/* Stores eigenvectors of submatrices encountered during */
+/* divide and conquer, packed together. QPTR points to */
+/* beginning of the submatrices. */
+
+/* QPTR (input/output) INTEGER array, dimension (N+2) */
+/* List of indices pointing to beginning of submatrices stored */
+/* in QSTORE. The submatrices are numbered starting at the */
+/* bottom left of the divide and conquer tree, from left to */
+/* right and bottom to top. */
+
+/* PRMPTR (input) INTEGER array, dimension (N lg N) */
+/* Contains a list of pointers which indicate where in PERM a */
+/* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) */
+/* indicates the size of the permutation and also the size of */
+/* the full, non-deflated problem. */
+
+/* PERM (input) INTEGER array, dimension (N lg N) */
+/* Contains the permutations (from deflation and sorting) to be */
+/* applied to each eigenblock. */
+
+/* GIVPTR (input) INTEGER array, dimension (N lg N) */
+/* Contains a list of pointers which indicate where in GIVCOL a */
+/* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) */
+/* indicates the number of Givens rotations. */
+
+/* GIVCOL (input) INTEGER array, dimension (2, N lg N) */
+/* Each pair of numbers indicates a pair of columns to take place */
+/* in a Givens rotation. */
+
+/* GIVNUM (input) REAL array, dimension (2, N lg N) */
+/* Each number indicates the S value to be used in the */
+/* corresponding Givens rotation. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, an eigenvalue did not converge */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --indxq;
+ --qstore;
+ --qptr;
+ --prmptr;
+ --perm;
+ --givptr;
+ givcol -= 3;
+ givnum -= 3;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+/* IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN */
+/* INFO = -1 */
+/* ELSE IF( N.LT.0 ) THEN */
+ if (*n < 0) {
+ *info = -1;
+ } else if (min(1,*n) > *cutpnt || *n < *cutpnt) {
+ *info = -2;
+ } else if (*qsiz < *n) {
+ *info = -3;
+ } else if (*ldq < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLAED7", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* The following values are for bookkeeping purposes only. They are */
+/* integer pointers which indicate the portion of the workspace */
+/* used by a particular array in SLAED2 and SLAED3. */
+
+ iz = 1;
+ idlmda = iz + *n;
+ iw = idlmda + *n;
+ iq = iw + *n;
+
+ indx = 1;
+ indxc = indx + *n;
+ coltyp = indxc + *n;
+ indxp = coltyp + *n;
+
+/* Form the z-vector which consists of the last row of Q_1 and the */
+/* first row of Q_2. */
+
+ ptr = pow_ii(&c__2, tlvls) + 1;
+ i__1 = *curlvl - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *tlvls - i__;
+ ptr += pow_ii(&c__2, &i__2);
+/* L10: */
+ }
+ curr = ptr + *curpbm;
+ slaeda_(n, tlvls, curlvl, curpbm, &prmptr[1], &perm[1], &givptr[1], &
+ givcol[3], &givnum[3], &qstore[1], &qptr[1], &rwork[iz], &rwork[
+ iz + *n], info);
+
+/* When solving the final problem, we no longer need the stored data, */
+/* so we will overwrite the data from this level onto the previously */
+/* used storage space. */
+
+ if (*curlvl == *tlvls) {
+ qptr[curr] = 1;
+ prmptr[curr] = 1;
+ givptr[curr] = 1;
+ }
+
+/* Sort and Deflate eigenvalues. */
+
+ claed8_(&k, n, qsiz, &q[q_offset], ldq, &d__[1], rho, cutpnt, &rwork[iz],
+ &rwork[idlmda], &work[1], qsiz, &rwork[iw], &iwork[indxp], &iwork[
+ indx], &indxq[1], &perm[prmptr[curr]], &givptr[curr + 1], &givcol[
+ (givptr[curr] << 1) + 1], &givnum[(givptr[curr] << 1) + 1], info);
+ prmptr[curr + 1] = prmptr[curr] + *n;
+ givptr[curr + 1] += givptr[curr];
+
+/* Solve Secular Equation. */
+
+ if (k != 0) {
+ slaed9_(&k, &c__1, &k, n, &d__[1], &rwork[iq], &k, rho, &rwork[idlmda]
+, &rwork[iw], &qstore[qptr[curr]], &k, info);
+ clacrm_(qsiz, &k, &work[1], qsiz, &qstore[qptr[curr]], &k, &q[
+ q_offset], ldq, &rwork[iq]);
+/* Computing 2nd power */
+ i__1 = k;
+ qptr[curr + 1] = qptr[curr] + i__1 * i__1;
+ if (*info != 0) {
+ return 0;
+ }
+
+/* Prepare the INDXQ sorting premutation. */
+
+ n1 = k;
+ n2 = *n - k;
+ slamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]);
+ } else {
+ qptr[curr + 1] = qptr[curr];
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ indxq[i__] = i__;
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of CLAED7 */
+
+} /* claed7_ */
diff --git a/SRC/claed8.c b/SRC/claed8.c
new file mode 100644
index 0000000..74e9416
--- /dev/null
+++ b/SRC/claed8.c
@@ -0,0 +1,436 @@
+/* claed8.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b3 = -1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int claed8_(integer *k, integer *n, integer *qsiz, complex *
+ q, integer *ldq, real *d__, real *rho, integer *cutpnt, real *z__,
+ real *dlamda, complex *q2, integer *ldq2, real *w, integer *indxp,
+ integer *indx, integer *indxq, integer *perm, integer *givptr,
+ integer *givcol, real *givnum, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, q2_dim1, q2_offset, i__1;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real c__;
+ integer i__, j;
+ real s, t;
+ integer k2, n1, n2, jp, n1p1;
+ real eps, tau, tol;
+ integer jlam, imax, jmax;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ ccopy_(integer *, complex *, integer *, complex *, integer *),
+ csrot_(integer *, complex *, integer *, complex *, integer *,
+ real *, real *), scopy_(integer *, real *, integer *, real *,
+ integer *);
+ extern doublereal slapy2_(real *, real *), slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), xerbla_(char *,
+ integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ extern /* Subroutine */ int slamrg_(integer *, integer *, real *, integer
+ *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAED8 merges the two sets of eigenvalues together into a single */
+/* sorted set. Then it tries to deflate the size of the problem. */
+/* There are two ways in which deflation can occur: when two or more */
+/* eigenvalues are close together or if there is a tiny element in the */
+/* Z vector. For each such occurrence the order of the related secular */
+/* equation problem is reduced by one. */
+
+/* Arguments */
+/* ========= */
+
+/* K (output) INTEGER */
+/* Contains the number of non-deflated eigenvalues. */
+/* This is the order of the related secular equation. */
+
+/* N (input) INTEGER */
+/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
+
+/* QSIZ (input) INTEGER */
+/* The dimension of the unitary matrix used to reduce */
+/* the dense or band matrix to tridiagonal form. */
+/* QSIZ >= N if ICOMPQ = 1. */
+
+/* Q (input/output) COMPLEX array, dimension (LDQ,N) */
+/* On entry, Q contains the eigenvectors of the partially solved */
+/* system which has been previously updated in matrix */
+/* multiplies with other partially solved eigensystems. */
+/* On exit, Q contains the trailing (N-K) updated eigenvectors */
+/* (those which were deflated) in its last N-K columns. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max( 1, N ). */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, D contains the eigenvalues of the two submatrices to */
+/* be combined. On exit, D contains the trailing (N-K) updated */
+/* eigenvalues (those which were deflated) sorted into increasing */
+/* order. */
+
+/* RHO (input/output) REAL */
+/* Contains the off diagonal element associated with the rank-1 */
+/* cut which originally split the two submatrices which are now */
+/* being recombined. RHO is modified during the computation to */
+/* the value required by SLAED3. */
+
+/* CUTPNT (input) INTEGER */
+/* Contains the location of the last eigenvalue in the leading */
+/* sub-matrix. MIN(1,N) <= CUTPNT <= N. */
+
+/* Z (input) REAL array, dimension (N) */
+/* On input this vector contains the updating vector (the last */
+/* row of the first sub-eigenvector matrix and the first row of */
+/* the second sub-eigenvector matrix). The contents of Z are */
+/* destroyed during the updating process. */
+
+/* DLAMDA (output) REAL array, dimension (N) */
+/* Contains a copy of the first K eigenvalues which will be used */
+/* by SLAED3 to form the secular equation. */
+
+/* Q2 (output) COMPLEX array, dimension (LDQ2,N) */
+/* If ICOMPQ = 0, Q2 is not referenced. Otherwise, */
+/* Contains a copy of the first K eigenvectors which will be used */
+/* by SLAED7 in a matrix multiply (SGEMM) to update the new */
+/* eigenvectors. */
+
+/* LDQ2 (input) INTEGER */
+/* The leading dimension of the array Q2. LDQ2 >= max( 1, N ). */
+
+/* W (output) REAL array, dimension (N) */
+/* This will hold the first k values of the final */
+/* deflation-altered z-vector and will be passed to SLAED3. */
+
+/* INDXP (workspace) INTEGER array, dimension (N) */
+/* This will contain the permutation used to place deflated */
+/* values of D at the end of the array. On output INDXP(1:K) */
+/* points to the nondeflated D-values and INDXP(K+1:N) */
+/* points to the deflated eigenvalues. */
+
+/* INDX (workspace) INTEGER array, dimension (N) */
+/* This will contain the permutation used to sort the contents of */
+/* D into ascending order. */
+
+/* INDXQ (input) INTEGER array, dimension (N) */
+/* This contains the permutation which separately sorts the two */
+/* sub-problems in D into ascending order. Note that elements in */
+/* the second half of this permutation must first have CUTPNT */
+/* added to their values in order to be accurate. */
+
+/* PERM (output) INTEGER array, dimension (N) */
+/* Contains the permutations (from deflation and sorting) to be */
+/* applied to each eigenblock. */
+
+/* GIVPTR (output) INTEGER */
+/* Contains the number of Givens rotations which took place in */
+/* this subproblem. */
+
+/* GIVCOL (output) INTEGER array, dimension (2, N) */
+/* Each pair of numbers indicates a pair of columns to take place */
+/* in a Givens rotation. */
+
+/* GIVNUM (output) REAL array, dimension (2, N) */
+/* Each number indicates the S value to be used in the */
+/* corresponding Givens rotation. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --d__;
+ --z__;
+ --dlamda;
+ q2_dim1 = *ldq2;
+ q2_offset = 1 + q2_dim1;
+ q2 -= q2_offset;
+ --w;
+ --indxp;
+ --indx;
+ --indxq;
+ --perm;
+ givcol -= 3;
+ givnum -= 3;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*n < 0) {
+ *info = -2;
+ } else if (*qsiz < *n) {
+ *info = -3;
+ } else if (*ldq < max(1,*n)) {
+ *info = -5;
+ } else if (*cutpnt < min(1,*n) || *cutpnt > *n) {
+ *info = -8;
+ } else if (*ldq2 < max(1,*n)) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLAED8", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ n1 = *cutpnt;
+ n2 = *n - n1;
+ n1p1 = n1 + 1;
+
+ if (*rho < 0.f) {
+ sscal_(&n2, &c_b3, &z__[n1p1], &c__1);
+ }
+
+/* Normalize z so that norm(z) = 1 */
+
+ t = 1.f / sqrt(2.f);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ indx[j] = j;
+/* L10: */
+ }
+ sscal_(n, &t, &z__[1], &c__1);
+ *rho = (r__1 = *rho * 2.f, dabs(r__1));
+
+/* Sort the eigenvalues into increasing order */
+
+ i__1 = *n;
+ for (i__ = *cutpnt + 1; i__ <= i__1; ++i__) {
+ indxq[i__] += *cutpnt;
+/* L20: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dlamda[i__] = d__[indxq[i__]];
+ w[i__] = z__[indxq[i__]];
+/* L30: */
+ }
+ i__ = 1;
+ j = *cutpnt + 1;
+ slamrg_(&n1, &n2, &dlamda[1], &c__1, &c__1, &indx[1]);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = dlamda[indx[i__]];
+ z__[i__] = w[indx[i__]];
+/* L40: */
+ }
+
+/* Calculate the allowable deflation tolerance */
+
+ imax = isamax_(n, &z__[1], &c__1);
+ jmax = isamax_(n, &d__[1], &c__1);
+ eps = slamch_("Epsilon");
+ tol = eps * 8.f * (r__1 = d__[jmax], dabs(r__1));
+
+/* If the rank-1 modifier is small enough, no more needs to be done */
+/* -- except to reorganize Q so that its columns correspond with the */
+/* elements in D. */
+
+ if (*rho * (r__1 = z__[imax], dabs(r__1)) <= tol) {
+ *k = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ perm[j] = indxq[indx[j]];
+ ccopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1]
+, &c__1);
+/* L50: */
+ }
+ clacpy_("A", qsiz, n, &q2[q2_dim1 + 1], ldq2, &q[q_dim1 + 1], ldq);
+ return 0;
+ }
+
+/* If there are multiple eigenvalues then the problem deflates. Here */
+/* the number of equal eigenvalues are found. As each equal */
+/* eigenvalue is found, an elementary reflector is computed to rotate */
+/* the corresponding eigensubspace so that the corresponding */
+/* components of Z are zero in this new basis. */
+
+ *k = 0;
+ *givptr = 0;
+ k2 = *n + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*rho * (r__1 = z__[j], dabs(r__1)) <= tol) {
+
+/* Deflate due to small z component. */
+
+ --k2;
+ indxp[k2] = j;
+ if (j == *n) {
+ goto L100;
+ }
+ } else {
+ jlam = j;
+ goto L70;
+ }
+/* L60: */
+ }
+L70:
+ ++j;
+ if (j > *n) {
+ goto L90;
+ }
+ if (*rho * (r__1 = z__[j], dabs(r__1)) <= tol) {
+
+/* Deflate due to small z component. */
+
+ --k2;
+ indxp[k2] = j;
+ } else {
+
+/* Check if eigenvalues are close enough to allow deflation. */
+
+ s = z__[jlam];
+ c__ = z__[j];
+
+/* Find sqrt(a**2+b**2) without overflow or */
+/* destructive underflow. */
+
+ tau = slapy2_(&c__, &s);
+ t = d__[j] - d__[jlam];
+ c__ /= tau;
+ s = -s / tau;
+ if ((r__1 = t * c__ * s, dabs(r__1)) <= tol) {
+
+/* Deflation is possible. */
+
+ z__[j] = tau;
+ z__[jlam] = 0.f;
+
+/* Record the appropriate Givens rotation */
+
+ ++(*givptr);
+ givcol[(*givptr << 1) + 1] = indxq[indx[jlam]];
+ givcol[(*givptr << 1) + 2] = indxq[indx[j]];
+ givnum[(*givptr << 1) + 1] = c__;
+ givnum[(*givptr << 1) + 2] = s;
+ csrot_(qsiz, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, &q[indxq[
+ indx[j]] * q_dim1 + 1], &c__1, &c__, &s);
+ t = d__[jlam] * c__ * c__ + d__[j] * s * s;
+ d__[j] = d__[jlam] * s * s + d__[j] * c__ * c__;
+ d__[jlam] = t;
+ --k2;
+ i__ = 1;
+L80:
+ if (k2 + i__ <= *n) {
+ if (d__[jlam] < d__[indxp[k2 + i__]]) {
+ indxp[k2 + i__ - 1] = indxp[k2 + i__];
+ indxp[k2 + i__] = jlam;
+ ++i__;
+ goto L80;
+ } else {
+ indxp[k2 + i__ - 1] = jlam;
+ }
+ } else {
+ indxp[k2 + i__ - 1] = jlam;
+ }
+ jlam = j;
+ } else {
+ ++(*k);
+ w[*k] = z__[jlam];
+ dlamda[*k] = d__[jlam];
+ indxp[*k] = jlam;
+ jlam = j;
+ }
+ }
+ goto L70;
+L90:
+
+/* Record the last eigenvalue. */
+
+ ++(*k);
+ w[*k] = z__[jlam];
+ dlamda[*k] = d__[jlam];
+ indxp[*k] = jlam;
+
+L100:
+
+/* Sort the eigenvalues and corresponding eigenvectors into DLAMDA */
+/* and Q2 respectively. The eigenvalues/vectors which were not */
+/* deflated go into the first K slots of DLAMDA and Q2 respectively, */
+/* while those which were deflated go into the last N - K slots. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ jp = indxp[j];
+ dlamda[j] = d__[jp];
+ perm[j] = indxq[indx[jp]];
+ ccopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1], &
+ c__1);
+/* L110: */
+ }
+
+/* The deflated eigenvalues and their corresponding vectors go back */
+/* into the last N - K slots of D and Q respectively. */
+
+ if (*k < *n) {
+ i__1 = *n - *k;
+ scopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1);
+ i__1 = *n - *k;
+ clacpy_("A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(*k +
+ 1) * q_dim1 + 1], ldq);
+ }
+
+ return 0;
+
+/* End of CLAED8 */
+
+} /* claed8_ */
diff --git a/SRC/claein.c b/SRC/claein.c
new file mode 100644
index 0000000..48c0b20
--- /dev/null
+++ b/SRC/claein.c
@@ -0,0 +1,392 @@
+/* claein.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int claein_(logical *rightv, logical *noinit, integer *n,
+ complex *h__, integer *ldh, complex *w, complex *v, complex *b,
+ integer *ldb, real *rwork, real *eps3, real *smlnum, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j;
+ complex x, ei, ej;
+ integer its, ierr;
+ complex temp;
+ real scale;
+ char trans[1];
+ real rtemp, rootn, vnorm;
+ extern doublereal scnrm2_(integer *, complex *, integer *);
+ extern integer icamax_(integer *, complex *, integer *);
+ extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), clatrs_(char *, char *, char *, char *, integer *, complex *,
+ integer *, complex *, real *, real *, integer *);
+ extern doublereal scasum_(integer *, complex *, integer *);
+ char normin[1];
+ real nrmsml, growto;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAEIN uses inverse iteration to find a right or left eigenvector */
+/* corresponding to the eigenvalue W of a complex upper Hessenberg */
+/* matrix H. */
+
+/* Arguments */
+/* ========= */
+
+/* RIGHTV (input) LOGICAL */
+/* = .TRUE. : compute right eigenvector; */
+/* = .FALSE.: compute left eigenvector. */
+
+/* NOINIT (input) LOGICAL */
+/* = .TRUE. : no initial vector supplied in V */
+/* = .FALSE.: initial vector supplied in V. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N >= 0. */
+
+/* H (input) COMPLEX array, dimension (LDH,N) */
+/* The upper Hessenberg matrix H. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH >= max(1,N). */
+
+/* W (input) COMPLEX */
+/* The eigenvalue of H whose corresponding right or left */
+/* eigenvector is to be computed. */
+
+/* V (input/output) COMPLEX array, dimension (N) */
+/* On entry, if NOINIT = .FALSE., V must contain a starting */
+/* vector for inverse iteration; otherwise V need not be set. */
+/* On exit, V contains the computed eigenvector, normalized so */
+/* that the component of largest magnitude has magnitude 1; here */
+/* the magnitude of a complex number (x,y) is taken to be */
+/* |x| + |y|. */
+
+/* B (workspace) COMPLEX array, dimension (LDB,N) */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* EPS3 (input) REAL */
+/* A small machine-dependent value which is used to perturb */
+/* close eigenvalues, and to replace zero pivots. */
+
+/* SMLNUM (input) REAL */
+/* A machine-dependent value close to the underflow threshold. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* = 1: inverse iteration did not converge; V is set to the */
+/* last iterate. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --v;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+
+/* GROWTO is the threshold used in the acceptance test for an */
+/* eigenvector. */
+
+ rootn = sqrt((real) (*n));
+ growto = .1f / rootn;
+/* Computing MAX */
+ r__1 = 1.f, r__2 = *eps3 * rootn;
+ nrmsml = dmax(r__1,r__2) * *smlnum;
+
+/* Form B = H - W*I (except that the subdiagonal elements are not */
+/* stored). */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * h_dim1;
+ b[i__3].r = h__[i__4].r, b[i__3].i = h__[i__4].i;
+/* L10: */
+ }
+ i__2 = j + j * b_dim1;
+ i__3 = j + j * h_dim1;
+ q__1.r = h__[i__3].r - w->r, q__1.i = h__[i__3].i - w->i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L20: */
+ }
+
+ if (*noinit) {
+
+/* Initialize V. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ v[i__2].r = *eps3, v[i__2].i = 0.f;
+/* L30: */
+ }
+ } else {
+
+/* Scale supplied initial vector. */
+
+ vnorm = scnrm2_(n, &v[1], &c__1);
+ r__1 = *eps3 * rootn / dmax(vnorm,nrmsml);
+ csscal_(n, &r__1, &v[1], &c__1);
+ }
+
+ if (*rightv) {
+
+/* LU decomposition with partial pivoting of B, replacing zero */
+/* pivots by EPS3. */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + 1 + i__ * h_dim1;
+ ei.r = h__[i__2].r, ei.i = h__[i__2].i;
+ i__2 = i__ + i__ * b_dim1;
+ if ((r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b[i__ + i__ *
+ b_dim1]), dabs(r__2)) < (r__3 = ei.r, dabs(r__3)) + (
+ r__4 = r_imag(&ei), dabs(r__4))) {
+
+/* Interchange rows and eliminate. */
+
+ cladiv_(&q__1, &b[i__ + i__ * b_dim1], &ei);
+ x.r = q__1.r, x.i = q__1.i;
+ i__2 = i__ + i__ * b_dim1;
+ b[i__2].r = ei.r, b[i__2].i = ei.i;
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + 1 + j * b_dim1;
+ temp.r = b[i__3].r, temp.i = b[i__3].i;
+ i__3 = i__ + 1 + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r *
+ temp.i + x.i * temp.r;
+ q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = temp.r, b[i__3].i = temp.i;
+/* L40: */
+ }
+ } else {
+
+/* Eliminate without interchange. */
+
+ i__2 = i__ + i__ * b_dim1;
+ if (b[i__2].r == 0.f && b[i__2].i == 0.f) {
+ i__3 = i__ + i__ * b_dim1;
+ b[i__3].r = *eps3, b[i__3].i = 0.f;
+ }
+ cladiv_(&q__1, &ei, &b[i__ + i__ * b_dim1]);
+ x.r = q__1.r, x.i = q__1.i;
+ if (x.r != 0.f || x.i != 0.f) {
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + 1 + j * b_dim1;
+ i__4 = i__ + 1 + j * b_dim1;
+ i__5 = i__ + j * b_dim1;
+ q__2.r = x.r * b[i__5].r - x.i * b[i__5].i, q__2.i =
+ x.r * b[i__5].i + x.i * b[i__5].r;
+ q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i -
+ q__2.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L50: */
+ }
+ }
+ }
+/* L60: */
+ }
+ i__1 = *n + *n * b_dim1;
+ if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
+ i__2 = *n + *n * b_dim1;
+ b[i__2].r = *eps3, b[i__2].i = 0.f;
+ }
+
+ *(unsigned char *)trans = 'N';
+
+ } else {
+
+/* UL decomposition with partial pivoting of B, replacing zero */
+/* pivots by EPS3. */
+
+ for (j = *n; j >= 2; --j) {
+ i__1 = j + (j - 1) * h_dim1;
+ ej.r = h__[i__1].r, ej.i = h__[i__1].i;
+ i__1 = j + j * b_dim1;
+ if ((r__1 = b[i__1].r, dabs(r__1)) + (r__2 = r_imag(&b[j + j *
+ b_dim1]), dabs(r__2)) < (r__3 = ej.r, dabs(r__3)) + (r__4
+ = r_imag(&ej), dabs(r__4))) {
+
+/* Interchange columns and eliminate. */
+
+ cladiv_(&q__1, &b[j + j * b_dim1], &ej);
+ x.r = q__1.r, x.i = q__1.i;
+ i__1 = j + j * b_dim1;
+ b[i__1].r = ej.r, b[i__1].i = ej.i;
+ i__1 = j - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + (j - 1) * b_dim1;
+ temp.r = b[i__2].r, temp.i = b[i__2].i;
+ i__2 = i__ + (j - 1) * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ q__2.r = x.r * temp.r - x.i * temp.i, q__2.i = x.r *
+ temp.i + x.i * temp.r;
+ q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = i__ + j * b_dim1;
+ b[i__2].r = temp.r, b[i__2].i = temp.i;
+/* L70: */
+ }
+ } else {
+
+/* Eliminate without interchange. */
+
+ i__1 = j + j * b_dim1;
+ if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
+ i__2 = j + j * b_dim1;
+ b[i__2].r = *eps3, b[i__2].i = 0.f;
+ }
+ cladiv_(&q__1, &ej, &b[j + j * b_dim1]);
+ x.r = q__1.r, x.i = q__1.i;
+ if (x.r != 0.f || x.i != 0.f) {
+ i__1 = j - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + (j - 1) * b_dim1;
+ i__3 = i__ + (j - 1) * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ q__2.r = x.r * b[i__4].r - x.i * b[i__4].i, q__2.i =
+ x.r * b[i__4].i + x.i * b[i__4].r;
+ q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i -
+ q__2.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L80: */
+ }
+ }
+ }
+/* L90: */
+ }
+ i__1 = b_dim1 + 1;
+ if (b[i__1].r == 0.f && b[i__1].i == 0.f) {
+ i__2 = b_dim1 + 1;
+ b[i__2].r = *eps3, b[i__2].i = 0.f;
+ }
+
+ *(unsigned char *)trans = 'C';
+
+ }
+
+ *(unsigned char *)normin = 'N';
+ i__1 = *n;
+ for (its = 1; its <= i__1; ++its) {
+
+/* Solve U*x = scale*v for a right eigenvector */
+/* or U'*x = scale*v for a left eigenvector, */
+/* overwriting x on v. */
+
+ clatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, &v[1]
+, &scale, &rwork[1], &ierr);
+ *(unsigned char *)normin = 'Y';
+
+/* Test for sufficient growth in the norm of v. */
+
+ vnorm = scasum_(n, &v[1], &c__1);
+ if (vnorm >= growto * scale) {
+ goto L120;
+ }
+
+/* Choose new orthogonal starting vector and try again. */
+
+ rtemp = *eps3 / (rootn + 1.f);
+ v[1].r = *eps3, v[1].i = 0.f;
+ i__2 = *n;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ v[i__3].r = rtemp, v[i__3].i = 0.f;
+/* L100: */
+ }
+ i__2 = *n - its + 1;
+ i__3 = *n - its + 1;
+ r__1 = *eps3 * rootn;
+ q__1.r = v[i__3].r - r__1, q__1.i = v[i__3].i;
+ v[i__2].r = q__1.r, v[i__2].i = q__1.i;
+/* L110: */
+ }
+
+/* Failure to find eigenvector in N iterations. */
+
+ *info = 1;
+
+L120:
+
+/* Normalize eigenvector. */
+
+ i__ = icamax_(n, &v[1], &c__1);
+ i__1 = i__;
+ r__3 = 1.f / ((r__1 = v[i__1].r, dabs(r__1)) + (r__2 = r_imag(&v[i__]),
+ dabs(r__2)));
+ csscal_(n, &r__3, &v[1], &c__1);
+
+ return 0;
+
+/* End of CLAEIN */
+
+} /* claein_ */
diff --git a/SRC/claesy.c b/SRC/claesy.c
new file mode 100644
index 0000000..9a60e4d
--- /dev/null
+++ b/SRC/claesy.c
@@ -0,0 +1,206 @@
+/* claesy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__2 = 2;
+
+/* Subroutine */ int claesy_(complex *a, complex *b, complex *c__, complex *
+ rt1, complex *rt2, complex *evscal, complex *cs1, complex *sn1)
+{
+ /* System generated locals */
+ real r__1, r__2;
+ complex q__1, q__2, q__3, q__4, q__5, q__6, q__7;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+ void pow_ci(complex *, complex *, integer *), c_sqrt(complex *, complex *)
+ , c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ complex s, t;
+ real z__;
+ complex tmp;
+ real babs, tabs, evnorm;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAESY computes the eigendecomposition of a 2-by-2 symmetric matrix */
+/* ( ( A, B );( B, C ) ) */
+/* provided the norm of the matrix of eigenvectors is larger than */
+/* some threshold value. */
+
+/* RT1 is the eigenvalue of larger absolute value, and RT2 of */
+/* smaller absolute value. If the eigenvectors are computed, then */
+/* on return ( CS1, SN1 ) is the unit eigenvector for RT1, hence */
+
+/* [ CS1 SN1 ] . [ A B ] . [ CS1 -SN1 ] = [ RT1 0 ] */
+/* [ -SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ] */
+
+/* Arguments */
+/* ========= */
+
+/* A (input) COMPLEX */
+/* The ( 1, 1 ) element of input matrix. */
+
+/* B (input) COMPLEX */
+/* The ( 1, 2 ) element of input matrix. The ( 2, 1 ) element */
+/* is also given by B, since the 2-by-2 matrix is symmetric. */
+
+/* C (input) COMPLEX */
+/* The ( 2, 2 ) element of input matrix. */
+
+/* RT1 (output) COMPLEX */
+/* The eigenvalue of larger modulus. */
+
+/* RT2 (output) COMPLEX */
+/* The eigenvalue of smaller modulus. */
+
+/* EVSCAL (output) COMPLEX */
+/* The complex value by which the eigenvector matrix was scaled */
+/* to make it orthonormal. If EVSCAL is zero, the eigenvectors */
+/* were not computed. This means one of two things: the 2-by-2 */
+/* matrix could not be diagonalized, or the norm of the matrix */
+/* of eigenvectors before scaling was larger than the threshold */
+/* value THRESH (set below). */
+
+/* CS1 (output) COMPLEX */
+/* SN1 (output) COMPLEX */
+/* If EVSCAL .NE. 0, ( CS1, SN1 ) is the unit right eigenvector */
+/* for RT1. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+
+/* Special case: The matrix is actually diagonal. */
+/* To avoid divide by zero later, we treat this case separately. */
+
+ if (c_abs(b) == 0.f) {
+ rt1->r = a->r, rt1->i = a->i;
+ rt2->r = c__->r, rt2->i = c__->i;
+ if (c_abs(rt1) < c_abs(rt2)) {
+ tmp.r = rt1->r, tmp.i = rt1->i;
+ rt1->r = rt2->r, rt1->i = rt2->i;
+ rt2->r = tmp.r, rt2->i = tmp.i;
+ cs1->r = 0.f, cs1->i = 0.f;
+ sn1->r = 1.f, sn1->i = 0.f;
+ } else {
+ cs1->r = 1.f, cs1->i = 0.f;
+ sn1->r = 0.f, sn1->i = 0.f;
+ }
+ } else {
+
+/* Compute the eigenvalues and eigenvectors. */
+/* The characteristic equation is */
+/* lambda **2 - (A+C) lambda + (A*C - B*B) */
+/* and we solve it using the quadratic formula. */
+
+ q__2.r = a->r + c__->r, q__2.i = a->i + c__->i;
+ q__1.r = q__2.r * .5f, q__1.i = q__2.i * .5f;
+ s.r = q__1.r, s.i = q__1.i;
+ q__2.r = a->r - c__->r, q__2.i = a->i - c__->i;
+ q__1.r = q__2.r * .5f, q__1.i = q__2.i * .5f;
+ t.r = q__1.r, t.i = q__1.i;
+
+/* Take the square root carefully to avoid over/under flow. */
+
+ babs = c_abs(b);
+ tabs = c_abs(&t);
+ z__ = dmax(babs,tabs);
+ if (z__ > 0.f) {
+ q__5.r = t.r / z__, q__5.i = t.i / z__;
+ pow_ci(&q__4, &q__5, &c__2);
+ q__7.r = b->r / z__, q__7.i = b->i / z__;
+ pow_ci(&q__6, &q__7, &c__2);
+ q__3.r = q__4.r + q__6.r, q__3.i = q__4.i + q__6.i;
+ c_sqrt(&q__2, &q__3);
+ q__1.r = z__ * q__2.r, q__1.i = z__ * q__2.i;
+ t.r = q__1.r, t.i = q__1.i;
+ }
+
+/* Compute the two eigenvalues. RT1 and RT2 are exchanged */
+/* if necessary so that RT1 will have the greater magnitude. */
+
+ q__1.r = s.r + t.r, q__1.i = s.i + t.i;
+ rt1->r = q__1.r, rt1->i = q__1.i;
+ q__1.r = s.r - t.r, q__1.i = s.i - t.i;
+ rt2->r = q__1.r, rt2->i = q__1.i;
+ if (c_abs(rt1) < c_abs(rt2)) {
+ tmp.r = rt1->r, tmp.i = rt1->i;
+ rt1->r = rt2->r, rt1->i = rt2->i;
+ rt2->r = tmp.r, rt2->i = tmp.i;
+ }
+
+/* Choose CS1 = 1 and SN1 to satisfy the first equation, then */
+/* scale the components of this eigenvector so that the matrix */
+/* of eigenvectors X satisfies X * X' = I . (No scaling is */
+/* done if the norm of the eigenvalue matrix is less than THRESH.) */
+
+ q__2.r = rt1->r - a->r, q__2.i = rt1->i - a->i;
+ c_div(&q__1, &q__2, b);
+ sn1->r = q__1.r, sn1->i = q__1.i;
+ tabs = c_abs(sn1);
+ if (tabs > 1.f) {
+/* Computing 2nd power */
+ r__2 = 1.f / tabs;
+ r__1 = r__2 * r__2;
+ q__5.r = sn1->r / tabs, q__5.i = sn1->i / tabs;
+ pow_ci(&q__4, &q__5, &c__2);
+ q__3.r = r__1 + q__4.r, q__3.i = q__4.i;
+ c_sqrt(&q__2, &q__3);
+ q__1.r = tabs * q__2.r, q__1.i = tabs * q__2.i;
+ t.r = q__1.r, t.i = q__1.i;
+ } else {
+ q__3.r = sn1->r * sn1->r - sn1->i * sn1->i, q__3.i = sn1->r *
+ sn1->i + sn1->i * sn1->r;
+ q__2.r = q__3.r + 1.f, q__2.i = q__3.i + 0.f;
+ c_sqrt(&q__1, &q__2);
+ t.r = q__1.r, t.i = q__1.i;
+ }
+ evnorm = c_abs(&t);
+ if (evnorm >= .1f) {
+ c_div(&q__1, &c_b1, &t);
+ evscal->r = q__1.r, evscal->i = q__1.i;
+ cs1->r = evscal->r, cs1->i = evscal->i;
+ q__1.r = sn1->r * evscal->r - sn1->i * evscal->i, q__1.i = sn1->r
+ * evscal->i + sn1->i * evscal->r;
+ sn1->r = q__1.r, sn1->i = q__1.i;
+ } else {
+ evscal->r = 0.f, evscal->i = 0.f;
+ }
+ }
+ return 0;
+
+/* End of CLAESY */
+
+} /* claesy_ */
diff --git a/SRC/claev2.c b/SRC/claev2.c
new file mode 100644
index 0000000..f2d1cc0
--- /dev/null
+++ b/SRC/claev2.c
@@ -0,0 +1,123 @@
+/* claev2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int claev2_(complex *a, complex *b, complex *c__, real *rt1,
+ real *rt2, real *cs1, complex *sn1)
+{
+ /* System generated locals */
+ real r__1, r__2, r__3;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ real t;
+ complex w;
+ extern /* Subroutine */ int slaev2_(real *, real *, real *, real *, real *
+, real *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAEV2 computes the eigendecomposition of a 2-by-2 Hermitian matrix */
+/* [ A B ] */
+/* [ CONJG(B) C ]. */
+/* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the */
+/* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right */
+/* eigenvector for RT1, giving the decomposition */
+
+/* [ CS1 CONJG(SN1) ] [ A B ] [ CS1 -CONJG(SN1) ] = [ RT1 0 ] */
+/* [-SN1 CS1 ] [ CONJG(B) C ] [ SN1 CS1 ] [ 0 RT2 ]. */
+
+/* Arguments */
+/* ========= */
+
+/* A (input) COMPLEX */
+/* The (1,1) element of the 2-by-2 matrix. */
+
+/* B (input) COMPLEX */
+/* The (1,2) element and the conjugate of the (2,1) element of */
+/* the 2-by-2 matrix. */
+
+/* C (input) COMPLEX */
+/* The (2,2) element of the 2-by-2 matrix. */
+
+/* RT1 (output) REAL */
+/* The eigenvalue of larger absolute value. */
+
+/* RT2 (output) REAL */
+/* The eigenvalue of smaller absolute value. */
+
+/* CS1 (output) REAL */
+/* SN1 (output) COMPLEX */
+/* The vector (CS1, SN1) is a unit right eigenvector for RT1. */
+
+/* Further Details */
+/* =============== */
+
+/* RT1 is accurate to a few ulps barring over/underflow. */
+
+/* RT2 may be inaccurate if there is massive cancellation in the */
+/* determinant A*C-B*B; higher precision or correctly rounded or */
+/* correctly truncated arithmetic would be needed to compute RT2 */
+/* accurately in all cases. */
+
+/* CS1 and SN1 are accurate to a few ulps barring over/underflow. */
+
+/* Overflow is possible only if RT1 is within a factor of 5 of overflow. */
+/* Underflow is harmless if the input data is 0 or exceeds */
+/* underflow_threshold / macheps. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (c_abs(b) == 0.f) {
+ w.r = 1.f, w.i = 0.f;
+ } else {
+ r_cnjg(&q__2, b);
+ r__1 = c_abs(b);
+ q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
+ w.r = q__1.r, w.i = q__1.i;
+ }
+ r__1 = a->r;
+ r__2 = c_abs(b);
+ r__3 = c__->r;
+ slaev2_(&r__1, &r__2, &r__3, rt1, rt2, cs1, &t);
+ q__1.r = t * w.r, q__1.i = t * w.i;
+ sn1->r = q__1.r, sn1->i = q__1.i;
+ return 0;
+
+/* End of CLAEV2 */
+
+} /* claev2_ */
diff --git a/SRC/clag2z.c b/SRC/clag2z.c
new file mode 100644
index 0000000..664b6ae
--- /dev/null
+++ b/SRC/clag2z.c
@@ -0,0 +1,101 @@
+/* clag2z.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int clag2z_(integer *m, integer *n, complex *sa, integer *
+ ldsa, doublecomplex *a, integer *lda, integer *info)
+{
+ /* System generated locals */
+ integer sa_dim1, sa_offset, a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j;
+
+
+/* -- LAPACK PROTOTYPE auxiliary routine (version 3.1.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* August 2007 */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAG2Z converts a COMPLEX matrix, SA, to a COMPLEX*16 matrix, A. */
+
+/* Note that while it is possible to overflow while converting */
+/* from double to single, it is not possible to overflow when */
+/* converting from single to double. */
+
+/* This is an auxiliary routine so there is no argument checking. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of lines of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* SA (input) COMPLEX array, dimension (LDSA,N) */
+/* On entry, the M-by-N coefficient matrix SA. */
+
+/* LDSA (input) INTEGER */
+/* The leading dimension of the array SA. LDSA >= max(1,M). */
+
+/* A (output) COMPLEX*16 array, dimension (LDA,N) */
+/* On exit, the M-by-N coefficient matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* ========= */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ sa_dim1 = *ldsa;
+ sa_offset = 1 + sa_dim1;
+ sa -= sa_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * sa_dim1;
+ a[i__3].r = sa[i__4].r, a[i__3].i = sa[i__4].i;
+/* L10: */
+ }
+/* L20: */
+ }
+ return 0;
+
+/* End of CLAG2Z */
+
+} /* clag2z_ */
diff --git a/SRC/clags2.c b/SRC/clags2.c
new file mode 100644
index 0000000..61f6c9f
--- /dev/null
+++ b/SRC/clags2.c
@@ -0,0 +1,465 @@
+/* clags2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int clags2_(logical *upper, real *a1, complex *a2, real *a3,
+ real *b1, complex *b2, real *b3, real *csu, complex *snu, real *csv,
+ complex *snv, real *csq, complex *snq)
+{
+ /* System generated locals */
+ real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8;
+ complex q__1, q__2, q__3, q__4, q__5;
+
+ /* Builtin functions */
+ double c_abs(complex *), r_imag(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ real a;
+ complex b, c__;
+ real d__;
+ complex r__, d1;
+ real s1, s2, fb, fc;
+ complex ua11, ua12, ua21, ua22, vb11, vb12, vb21, vb22;
+ real csl, csr, snl, snr, aua11, aua12, aua21, aua22, avb11, avb12, avb21,
+ avb22, ua11r, ua22r, vb11r, vb22r;
+ extern /* Subroutine */ int slasv2_(real *, real *, real *, real *, real *
+, real *, real *, real *, real *), clartg_(complex *, complex *,
+ real *, complex *, complex *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAGS2 computes 2-by-2 unitary matrices U, V and Q, such */
+/* that if ( UPPER ) then */
+
+/* U'*A*Q = U'*( A1 A2 )*Q = ( x 0 ) */
+/* ( 0 A3 ) ( x x ) */
+/* and */
+/* V'*B*Q = V'*( B1 B2 )*Q = ( x 0 ) */
+/* ( 0 B3 ) ( x x ) */
+
+/* or if ( .NOT.UPPER ) then */
+
+/* U'*A*Q = U'*( A1 0 )*Q = ( x x ) */
+/* ( A2 A3 ) ( 0 x ) */
+/* and */
+/* V'*B*Q = V'*( B1 0 )*Q = ( x x ) */
+/* ( B2 B3 ) ( 0 x ) */
+/* where */
+
+/* U = ( CSU SNU ), V = ( CSV SNV ), */
+/* ( -CONJG(SNU) CSU ) ( -CONJG(SNV) CSV ) */
+
+/* Q = ( CSQ SNQ ) */
+/* ( -CONJG(SNQ) CSQ ) */
+
+/* Z' denotes the conjugate transpose of Z. */
+
+/* The rows of the transformed A and B are parallel. Moreover, if the */
+/* input 2-by-2 matrix A is not zero, then the transformed (1,1) entry */
+/* of A is not zero. If the input matrices A and B are both not zero, */
+/* then the transformed (2,2) element of B is not zero, except when the */
+/* first rows of input A and B are parallel and the second rows are */
+/* zero. */
+
+/* Arguments */
+/* ========= */
+
+/* UPPER (input) LOGICAL */
+/* = .TRUE.: the input matrices A and B are upper triangular. */
+/* = .FALSE.: the input matrices A and B are lower triangular. */
+
+/* A1 (input) REAL */
+/* A2 (input) COMPLEX */
+/* A3 (input) REAL */
+/* On entry, A1, A2 and A3 are elements of the input 2-by-2 */
+/* upper (lower) triangular matrix A. */
+
+/* B1 (input) REAL */
+/* B2 (input) COMPLEX */
+/* B3 (input) REAL */
+/* On entry, B1, B2 and B3 are elements of the input 2-by-2 */
+/* upper (lower) triangular matrix B. */
+
+/* CSU (output) REAL */
+/* SNU (output) COMPLEX */
+/* The desired unitary matrix U. */
+
+/* CSV (output) REAL */
+/* SNV (output) COMPLEX */
+/* The desired unitary matrix V. */
+
+/* CSQ (output) REAL */
+/* SNQ (output) COMPLEX */
+/* The desired unitary matrix Q. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (*upper) {
+
+/* Input matrices A and B are upper triangular matrices */
+
+/* Form matrix C = A*adj(B) = ( a b ) */
+/* ( 0 d ) */
+
+ a = *a1 * *b3;
+ d__ = *a3 * *b1;
+ q__2.r = *b1 * a2->r, q__2.i = *b1 * a2->i;
+ q__3.r = *a1 * b2->r, q__3.i = *a1 * b2->i;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ b.r = q__1.r, b.i = q__1.i;
+ fb = c_abs(&b);
+
+/* Transform complex 2-by-2 matrix C to real matrix by unitary */
+/* diagonal matrix diag(1,D1). */
+
+ d1.r = 1.f, d1.i = 0.f;
+ if (fb != 0.f) {
+ q__1.r = b.r / fb, q__1.i = b.i / fb;
+ d1.r = q__1.r, d1.i = q__1.i;
+ }
+
+/* The SVD of real 2 by 2 triangular C */
+
+/* ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 ) */
+/* ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T ) */
+
+ slasv2_(&a, &fb, &d__, &s1, &s2, &snr, &csr, &snl, &csl);
+
+ if (dabs(csl) >= dabs(snl) || dabs(csr) >= dabs(snr)) {
+
+/* Compute the (1,1) and (1,2) elements of U'*A and V'*B, */
+/* and (1,2) element of |U|'*|A| and |V|'*|B|. */
+
+ ua11r = csl * *a1;
+ q__2.r = csl * a2->r, q__2.i = csl * a2->i;
+ q__4.r = snl * d1.r, q__4.i = snl * d1.i;
+ q__3.r = *a3 * q__4.r, q__3.i = *a3 * q__4.i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ ua12.r = q__1.r, ua12.i = q__1.i;
+
+ vb11r = csr * *b1;
+ q__2.r = csr * b2->r, q__2.i = csr * b2->i;
+ q__4.r = snr * d1.r, q__4.i = snr * d1.i;
+ q__3.r = *b3 * q__4.r, q__3.i = *b3 * q__4.i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ vb12.r = q__1.r, vb12.i = q__1.i;
+
+ aua12 = dabs(csl) * ((r__1 = a2->r, dabs(r__1)) + (r__2 = r_imag(
+ a2), dabs(r__2))) + dabs(snl) * dabs(*a3);
+ avb12 = dabs(csr) * ((r__1 = b2->r, dabs(r__1)) + (r__2 = r_imag(
+ b2), dabs(r__2))) + dabs(snr) * dabs(*b3);
+
+/* zero (1,2) elements of U'*A and V'*B */
+
+ if (dabs(ua11r) + ((r__1 = ua12.r, dabs(r__1)) + (r__2 = r_imag(&
+ ua12), dabs(r__2))) == 0.f) {
+ q__2.r = vb11r, q__2.i = 0.f;
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ r_cnjg(&q__3, &vb12);
+ clartg_(&q__1, &q__3, csq, snq, &r__);
+ } else if (dabs(vb11r) + ((r__1 = vb12.r, dabs(r__1)) + (r__2 =
+ r_imag(&vb12), dabs(r__2))) == 0.f) {
+ q__2.r = ua11r, q__2.i = 0.f;
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ r_cnjg(&q__3, &ua12);
+ clartg_(&q__1, &q__3, csq, snq, &r__);
+ } else if (aua12 / (dabs(ua11r) + ((r__1 = ua12.r, dabs(r__1)) + (
+ r__2 = r_imag(&ua12), dabs(r__2)))) <= avb12 / (dabs(
+ vb11r) + ((r__3 = vb12.r, dabs(r__3)) + (r__4 = r_imag(&
+ vb12), dabs(r__4))))) {
+ q__2.r = ua11r, q__2.i = 0.f;
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ r_cnjg(&q__3, &ua12);
+ clartg_(&q__1, &q__3, csq, snq, &r__);
+ } else {
+ q__2.r = vb11r, q__2.i = 0.f;
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ r_cnjg(&q__3, &vb12);
+ clartg_(&q__1, &q__3, csq, snq, &r__);
+ }
+
+ *csu = csl;
+ q__2.r = -d1.r, q__2.i = -d1.i;
+ q__1.r = snl * q__2.r, q__1.i = snl * q__2.i;
+ snu->r = q__1.r, snu->i = q__1.i;
+ *csv = csr;
+ q__2.r = -d1.r, q__2.i = -d1.i;
+ q__1.r = snr * q__2.r, q__1.i = snr * q__2.i;
+ snv->r = q__1.r, snv->i = q__1.i;
+
+ } else {
+
+/* Compute the (2,1) and (2,2) elements of U'*A and V'*B, */
+/* and (2,2) element of |U|'*|A| and |V|'*|B|. */
+
+ r_cnjg(&q__4, &d1);
+ q__3.r = -q__4.r, q__3.i = -q__4.i;
+ q__2.r = snl * q__3.r, q__2.i = snl * q__3.i;
+ q__1.r = *a1 * q__2.r, q__1.i = *a1 * q__2.i;
+ ua21.r = q__1.r, ua21.i = q__1.i;
+ r_cnjg(&q__5, &d1);
+ q__4.r = -q__5.r, q__4.i = -q__5.i;
+ q__3.r = snl * q__4.r, q__3.i = snl * q__4.i;
+ q__2.r = q__3.r * a2->r - q__3.i * a2->i, q__2.i = q__3.r * a2->i
+ + q__3.i * a2->r;
+ r__1 = csl * *a3;
+ q__1.r = q__2.r + r__1, q__1.i = q__2.i;
+ ua22.r = q__1.r, ua22.i = q__1.i;
+
+ r_cnjg(&q__4, &d1);
+ q__3.r = -q__4.r, q__3.i = -q__4.i;
+ q__2.r = snr * q__3.r, q__2.i = snr * q__3.i;
+ q__1.r = *b1 * q__2.r, q__1.i = *b1 * q__2.i;
+ vb21.r = q__1.r, vb21.i = q__1.i;
+ r_cnjg(&q__5, &d1);
+ q__4.r = -q__5.r, q__4.i = -q__5.i;
+ q__3.r = snr * q__4.r, q__3.i = snr * q__4.i;
+ q__2.r = q__3.r * b2->r - q__3.i * b2->i, q__2.i = q__3.r * b2->i
+ + q__3.i * b2->r;
+ r__1 = csr * *b3;
+ q__1.r = q__2.r + r__1, q__1.i = q__2.i;
+ vb22.r = q__1.r, vb22.i = q__1.i;
+
+ aua22 = dabs(snl) * ((r__1 = a2->r, dabs(r__1)) + (r__2 = r_imag(
+ a2), dabs(r__2))) + dabs(csl) * dabs(*a3);
+ avb22 = dabs(snr) * ((r__1 = b2->r, dabs(r__1)) + (r__2 = r_imag(
+ b2), dabs(r__2))) + dabs(csr) * dabs(*b3);
+
+/* zero (2,2) elements of U'*A and V'*B, and then swap. */
+
+ if ((r__1 = ua21.r, dabs(r__1)) + (r__2 = r_imag(&ua21), dabs(
+ r__2)) + ((r__3 = ua22.r, dabs(r__3)) + (r__4 = r_imag(&
+ ua22), dabs(r__4))) == 0.f) {
+ r_cnjg(&q__2, &vb21);
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ r_cnjg(&q__3, &vb22);
+ clartg_(&q__1, &q__3, csq, snq, &r__);
+ } else if ((r__1 = vb21.r, dabs(r__1)) + (r__2 = r_imag(&vb21),
+ dabs(r__2)) + c_abs(&vb22) == 0.f) {
+ r_cnjg(&q__2, &ua21);
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ r_cnjg(&q__3, &ua22);
+ clartg_(&q__1, &q__3, csq, snq, &r__);
+ } else if (aua22 / ((r__1 = ua21.r, dabs(r__1)) + (r__2 = r_imag(&
+ ua21), dabs(r__2)) + ((r__3 = ua22.r, dabs(r__3)) + (r__4
+ = r_imag(&ua22), dabs(r__4)))) <= avb22 / ((r__5 = vb21.r,
+ dabs(r__5)) + (r__6 = r_imag(&vb21), dabs(r__6)) + ((
+ r__7 = vb22.r, dabs(r__7)) + (r__8 = r_imag(&vb22), dabs(
+ r__8))))) {
+ r_cnjg(&q__2, &ua21);
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ r_cnjg(&q__3, &ua22);
+ clartg_(&q__1, &q__3, csq, snq, &r__);
+ } else {
+ r_cnjg(&q__2, &vb21);
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ r_cnjg(&q__3, &vb22);
+ clartg_(&q__1, &q__3, csq, snq, &r__);
+ }
+
+ *csu = snl;
+ q__1.r = csl * d1.r, q__1.i = csl * d1.i;
+ snu->r = q__1.r, snu->i = q__1.i;
+ *csv = snr;
+ q__1.r = csr * d1.r, q__1.i = csr * d1.i;
+ snv->r = q__1.r, snv->i = q__1.i;
+
+ }
+
+ } else {
+
+/* Input matrices A and B are lower triangular matrices */
+
+/* Form matrix C = A*adj(B) = ( a 0 ) */
+/* ( c d ) */
+
+ a = *a1 * *b3;
+ d__ = *a3 * *b1;
+ q__2.r = *b3 * a2->r, q__2.i = *b3 * a2->i;
+ q__3.r = *a3 * b2->r, q__3.i = *a3 * b2->i;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ fc = c_abs(&c__);
+
+/* Transform complex 2-by-2 matrix C to real matrix by unitary */
+/* diagonal matrix diag(d1,1). */
+
+ d1.r = 1.f, d1.i = 0.f;
+ if (fc != 0.f) {
+ q__1.r = c__.r / fc, q__1.i = c__.i / fc;
+ d1.r = q__1.r, d1.i = q__1.i;
+ }
+
+/* The SVD of real 2 by 2 triangular C */
+
+/* ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 ) */
+/* ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T ) */
+
+ slasv2_(&a, &fc, &d__, &s1, &s2, &snr, &csr, &snl, &csl);
+
+ if (dabs(csr) >= dabs(snr) || dabs(csl) >= dabs(snl)) {
+
+/* Compute the (2,1) and (2,2) elements of U'*A and V'*B, */
+/* and (2,1) element of |U|'*|A| and |V|'*|B|. */
+
+ q__4.r = -d1.r, q__4.i = -d1.i;
+ q__3.r = snr * q__4.r, q__3.i = snr * q__4.i;
+ q__2.r = *a1 * q__3.r, q__2.i = *a1 * q__3.i;
+ q__5.r = csr * a2->r, q__5.i = csr * a2->i;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+ ua21.r = q__1.r, ua21.i = q__1.i;
+ ua22r = csr * *a3;
+
+ q__4.r = -d1.r, q__4.i = -d1.i;
+ q__3.r = snl * q__4.r, q__3.i = snl * q__4.i;
+ q__2.r = *b1 * q__3.r, q__2.i = *b1 * q__3.i;
+ q__5.r = csl * b2->r, q__5.i = csl * b2->i;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+ vb21.r = q__1.r, vb21.i = q__1.i;
+ vb22r = csl * *b3;
+
+ aua21 = dabs(snr) * dabs(*a1) + dabs(csr) * ((r__1 = a2->r, dabs(
+ r__1)) + (r__2 = r_imag(a2), dabs(r__2)));
+ avb21 = dabs(snl) * dabs(*b1) + dabs(csl) * ((r__1 = b2->r, dabs(
+ r__1)) + (r__2 = r_imag(b2), dabs(r__2)));
+
+/* zero (2,1) elements of U'*A and V'*B. */
+
+ if ((r__1 = ua21.r, dabs(r__1)) + (r__2 = r_imag(&ua21), dabs(
+ r__2)) + dabs(ua22r) == 0.f) {
+ q__1.r = vb22r, q__1.i = 0.f;
+ clartg_(&q__1, &vb21, csq, snq, &r__);
+ } else if ((r__1 = vb21.r, dabs(r__1)) + (r__2 = r_imag(&vb21),
+ dabs(r__2)) + dabs(vb22r) == 0.f) {
+ q__1.r = ua22r, q__1.i = 0.f;
+ clartg_(&q__1, &ua21, csq, snq, &r__);
+ } else if (aua21 / ((r__1 = ua21.r, dabs(r__1)) + (r__2 = r_imag(&
+ ua21), dabs(r__2)) + dabs(ua22r)) <= avb21 / ((r__3 =
+ vb21.r, dabs(r__3)) + (r__4 = r_imag(&vb21), dabs(r__4))
+ + dabs(vb22r))) {
+ q__1.r = ua22r, q__1.i = 0.f;
+ clartg_(&q__1, &ua21, csq, snq, &r__);
+ } else {
+ q__1.r = vb22r, q__1.i = 0.f;
+ clartg_(&q__1, &vb21, csq, snq, &r__);
+ }
+
+ *csu = csr;
+ r_cnjg(&q__3, &d1);
+ q__2.r = -q__3.r, q__2.i = -q__3.i;
+ q__1.r = snr * q__2.r, q__1.i = snr * q__2.i;
+ snu->r = q__1.r, snu->i = q__1.i;
+ *csv = csl;
+ r_cnjg(&q__3, &d1);
+ q__2.r = -q__3.r, q__2.i = -q__3.i;
+ q__1.r = snl * q__2.r, q__1.i = snl * q__2.i;
+ snv->r = q__1.r, snv->i = q__1.i;
+
+ } else {
+
+/* Compute the (1,1) and (1,2) elements of U'*A and V'*B, */
+/* and (1,1) element of |U|'*|A| and |V|'*|B|. */
+
+ r__1 = csr * *a1;
+ r_cnjg(&q__4, &d1);
+ q__3.r = snr * q__4.r, q__3.i = snr * q__4.i;
+ q__2.r = q__3.r * a2->r - q__3.i * a2->i, q__2.i = q__3.r * a2->i
+ + q__3.i * a2->r;
+ q__1.r = r__1 + q__2.r, q__1.i = q__2.i;
+ ua11.r = q__1.r, ua11.i = q__1.i;
+ r_cnjg(&q__3, &d1);
+ q__2.r = snr * q__3.r, q__2.i = snr * q__3.i;
+ q__1.r = *a3 * q__2.r, q__1.i = *a3 * q__2.i;
+ ua12.r = q__1.r, ua12.i = q__1.i;
+
+ r__1 = csl * *b1;
+ r_cnjg(&q__4, &d1);
+ q__3.r = snl * q__4.r, q__3.i = snl * q__4.i;
+ q__2.r = q__3.r * b2->r - q__3.i * b2->i, q__2.i = q__3.r * b2->i
+ + q__3.i * b2->r;
+ q__1.r = r__1 + q__2.r, q__1.i = q__2.i;
+ vb11.r = q__1.r, vb11.i = q__1.i;
+ r_cnjg(&q__3, &d1);
+ q__2.r = snl * q__3.r, q__2.i = snl * q__3.i;
+ q__1.r = *b3 * q__2.r, q__1.i = *b3 * q__2.i;
+ vb12.r = q__1.r, vb12.i = q__1.i;
+
+ aua11 = dabs(csr) * dabs(*a1) + dabs(snr) * ((r__1 = a2->r, dabs(
+ r__1)) + (r__2 = r_imag(a2), dabs(r__2)));
+ avb11 = dabs(csl) * dabs(*b1) + dabs(snl) * ((r__1 = b2->r, dabs(
+ r__1)) + (r__2 = r_imag(b2), dabs(r__2)));
+
+/* zero (1,1) elements of U'*A and V'*B, and then swap. */
+
+ if ((r__1 = ua11.r, dabs(r__1)) + (r__2 = r_imag(&ua11), dabs(
+ r__2)) + ((r__3 = ua12.r, dabs(r__3)) + (r__4 = r_imag(&
+ ua12), dabs(r__4))) == 0.f) {
+ clartg_(&vb12, &vb11, csq, snq, &r__);
+ } else if ((r__1 = vb11.r, dabs(r__1)) + (r__2 = r_imag(&vb11),
+ dabs(r__2)) + ((r__3 = vb12.r, dabs(r__3)) + (r__4 =
+ r_imag(&vb12), dabs(r__4))) == 0.f) {
+ clartg_(&ua12, &ua11, csq, snq, &r__);
+ } else if (aua11 / ((r__1 = ua11.r, dabs(r__1)) + (r__2 = r_imag(&
+ ua11), dabs(r__2)) + ((r__3 = ua12.r, dabs(r__3)) + (r__4
+ = r_imag(&ua12), dabs(r__4)))) <= avb11 / ((r__5 = vb11.r,
+ dabs(r__5)) + (r__6 = r_imag(&vb11), dabs(r__6)) + ((
+ r__7 = vb12.r, dabs(r__7)) + (r__8 = r_imag(&vb12), dabs(
+ r__8))))) {
+ clartg_(&ua12, &ua11, csq, snq, &r__);
+ } else {
+ clartg_(&vb12, &vb11, csq, snq, &r__);
+ }
+
+ *csu = snr;
+ r_cnjg(&q__2, &d1);
+ q__1.r = csr * q__2.r, q__1.i = csr * q__2.i;
+ snu->r = q__1.r, snu->i = q__1.i;
+ *csv = snl;
+ r_cnjg(&q__2, &d1);
+ q__1.r = csl * q__2.r, q__1.i = csl * q__2.i;
+ snv->r = q__1.r, snv->i = q__1.i;
+
+ }
+
+ }
+
+ return 0;
+
+/* End of CLAGS2 */
+
+} /* clags2_ */
diff --git a/SRC/clagtm.c b/SRC/clagtm.c
new file mode 100644
index 0000000..f50ddf0
--- /dev/null
+++ b/SRC/clagtm.c
@@ -0,0 +1,598 @@
+/* clagtm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int clagtm_(char *trans, integer *n, integer *nrhs, real *
+ alpha, complex *dl, complex *d__, complex *du, complex *x, integer *
+ ldx, real *beta, complex *b, integer *ldb)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6, i__7, i__8, i__9, i__10;
+ complex q__1, q__2, q__3, q__4, q__5, q__6, q__7, q__8, q__9;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j;
+ extern logical lsame_(char *, char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAGTM performs a matrix-vector product of the form */
+
+/* B := alpha * A * X + beta * B */
+
+/* where A is a tridiagonal matrix of order N, B and X are N by NRHS */
+/* matrices, and alpha and beta are real scalars, each of which may be */
+/* 0., 1., or -1. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': No transpose, B := alpha * A * X + beta * B */
+/* = 'T': Transpose, B := alpha * A**T * X + beta * B */
+/* = 'C': Conjugate transpose, B := alpha * A**H * X + beta * B */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. */
+
+/* ALPHA (input) REAL */
+/* The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise, */
+/* it is assumed to be 0. */
+
+/* DL (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) sub-diagonal elements of T. */
+
+/* D (input) COMPLEX array, dimension (N) */
+/* The diagonal elements of T. */
+
+/* DU (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) super-diagonal elements of T. */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The N by NRHS matrix X. */
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(N,1). */
+
+/* BETA (input) REAL */
+/* The scalar beta. BETA must be 0., 1., or -1.; otherwise, */
+/* it is assumed to be 1. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the N by NRHS matrix B. */
+/* On exit, B is overwritten by the matrix expression */
+/* B := alpha * A * X + beta * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(N,1). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Multiply B by BETA if BETA.NE.1. */
+
+ if (*beta == 0.f) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0.f, b[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (*beta == -1.f) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ q__1.r = -b[i__4].r, q__1.i = -b[i__4].i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+ if (*alpha == 1.f) {
+ if (lsame_(trans, "N")) {
+
+/* Compute B := B + A*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ q__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
+ q__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
+ .r;
+ q__1.r = b[i__3].r + q__2.r, q__1.i = b[i__3].i + q__2.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ q__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
+ q__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
+ .r;
+ q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i;
+ i__5 = j * x_dim1 + 2;
+ q__4.r = du[1].r * x[i__5].r - du[1].i * x[i__5].i,
+ q__4.i = du[1].r * x[i__5].i + du[1].i * x[i__5]
+ .r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ i__4 = *n - 1;
+ i__5 = *n - 1 + j * x_dim1;
+ q__3.r = dl[i__4].r * x[i__5].r - dl[i__4].i * x[i__5].i,
+ q__3.i = dl[i__4].r * x[i__5].i + dl[i__4].i * x[
+ i__5].r;
+ q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i;
+ i__6 = *n;
+ i__7 = *n + j * x_dim1;
+ q__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7]
+ .i, q__4.i = d__[i__6].r * x[i__7].i + d__[i__6]
+ .i * x[i__7].r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ - 1;
+ i__6 = i__ - 1 + j * x_dim1;
+ q__4.r = dl[i__5].r * x[i__6].r - dl[i__5].i * x[i__6]
+ .i, q__4.i = dl[i__5].r * x[i__6].i + dl[i__5]
+ .i * x[i__6].r;
+ q__3.r = b[i__4].r + q__4.r, q__3.i = b[i__4].i +
+ q__4.i;
+ i__7 = i__;
+ i__8 = i__ + j * x_dim1;
+ q__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[
+ i__8].i, q__5.i = d__[i__7].r * x[i__8].i +
+ d__[i__7].i * x[i__8].r;
+ q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
+ i__9 = i__;
+ i__10 = i__ + 1 + j * x_dim1;
+ q__6.r = du[i__9].r * x[i__10].r - du[i__9].i * x[
+ i__10].i, q__6.i = du[i__9].r * x[i__10].i +
+ du[i__9].i * x[i__10].r;
+ q__1.r = q__2.r + q__6.r, q__1.i = q__2.i + q__6.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else if (lsame_(trans, "T")) {
+
+/* Compute B := B + A**T * X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ q__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
+ q__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
+ .r;
+ q__1.r = b[i__3].r + q__2.r, q__1.i = b[i__3].i + q__2.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ q__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
+ q__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
+ .r;
+ q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i;
+ i__5 = j * x_dim1 + 2;
+ q__4.r = dl[1].r * x[i__5].r - dl[1].i * x[i__5].i,
+ q__4.i = dl[1].r * x[i__5].i + dl[1].i * x[i__5]
+ .r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ i__4 = *n - 1;
+ i__5 = *n - 1 + j * x_dim1;
+ q__3.r = du[i__4].r * x[i__5].r - du[i__4].i * x[i__5].i,
+ q__3.i = du[i__4].r * x[i__5].i + du[i__4].i * x[
+ i__5].r;
+ q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i;
+ i__6 = *n;
+ i__7 = *n + j * x_dim1;
+ q__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7]
+ .i, q__4.i = d__[i__6].r * x[i__7].i + d__[i__6]
+ .i * x[i__7].r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ - 1;
+ i__6 = i__ - 1 + j * x_dim1;
+ q__4.r = du[i__5].r * x[i__6].r - du[i__5].i * x[i__6]
+ .i, q__4.i = du[i__5].r * x[i__6].i + du[i__5]
+ .i * x[i__6].r;
+ q__3.r = b[i__4].r + q__4.r, q__3.i = b[i__4].i +
+ q__4.i;
+ i__7 = i__;
+ i__8 = i__ + j * x_dim1;
+ q__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[
+ i__8].i, q__5.i = d__[i__7].r * x[i__8].i +
+ d__[i__7].i * x[i__8].r;
+ q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
+ i__9 = i__;
+ i__10 = i__ + 1 + j * x_dim1;
+ q__6.r = dl[i__9].r * x[i__10].r - dl[i__9].i * x[
+ i__10].i, q__6.i = dl[i__9].r * x[i__10].i +
+ dl[i__9].i * x[i__10].r;
+ q__1.r = q__2.r + q__6.r, q__1.i = q__2.i + q__6.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L70: */
+ }
+ }
+/* L80: */
+ }
+ } else if (lsame_(trans, "C")) {
+
+/* Compute B := B + A**H * X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ r_cnjg(&q__3, &d__[1]);
+ i__4 = j * x_dim1 + 1;
+ q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i =
+ q__3.r * x[i__4].i + q__3.i * x[i__4].r;
+ q__1.r = b[i__3].r + q__2.r, q__1.i = b[i__3].i + q__2.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ r_cnjg(&q__4, &d__[1]);
+ i__4 = j * x_dim1 + 1;
+ q__3.r = q__4.r * x[i__4].r - q__4.i * x[i__4].i, q__3.i =
+ q__4.r * x[i__4].i + q__4.i * x[i__4].r;
+ q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i;
+ r_cnjg(&q__6, &dl[1]);
+ i__5 = j * x_dim1 + 2;
+ q__5.r = q__6.r * x[i__5].r - q__6.i * x[i__5].i, q__5.i =
+ q__6.r * x[i__5].i + q__6.i * x[i__5].r;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ r_cnjg(&q__4, &du[*n - 1]);
+ i__4 = *n - 1 + j * x_dim1;
+ q__3.r = q__4.r * x[i__4].r - q__4.i * x[i__4].i, q__3.i =
+ q__4.r * x[i__4].i + q__4.i * x[i__4].r;
+ q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i;
+ r_cnjg(&q__6, &d__[*n]);
+ i__5 = *n + j * x_dim1;
+ q__5.r = q__6.r * x[i__5].r - q__6.i * x[i__5].i, q__5.i =
+ q__6.r * x[i__5].i + q__6.i * x[i__5].r;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ r_cnjg(&q__5, &du[i__ - 1]);
+ i__5 = i__ - 1 + j * x_dim1;
+ q__4.r = q__5.r * x[i__5].r - q__5.i * x[i__5].i,
+ q__4.i = q__5.r * x[i__5].i + q__5.i * x[i__5]
+ .r;
+ q__3.r = b[i__4].r + q__4.r, q__3.i = b[i__4].i +
+ q__4.i;
+ r_cnjg(&q__7, &d__[i__]);
+ i__6 = i__ + j * x_dim1;
+ q__6.r = q__7.r * x[i__6].r - q__7.i * x[i__6].i,
+ q__6.i = q__7.r * x[i__6].i + q__7.i * x[i__6]
+ .r;
+ q__2.r = q__3.r + q__6.r, q__2.i = q__3.i + q__6.i;
+ r_cnjg(&q__9, &dl[i__]);
+ i__7 = i__ + 1 + j * x_dim1;
+ q__8.r = q__9.r * x[i__7].r - q__9.i * x[i__7].i,
+ q__8.i = q__9.r * x[i__7].i + q__9.i * x[i__7]
+ .r;
+ q__1.r = q__2.r + q__8.r, q__1.i = q__2.i + q__8.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L90: */
+ }
+ }
+/* L100: */
+ }
+ }
+ } else if (*alpha == -1.f) {
+ if (lsame_(trans, "N")) {
+
+/* Compute B := B - A*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ q__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
+ q__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
+ .r;
+ q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ q__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
+ q__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
+ .r;
+ q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
+ i__5 = j * x_dim1 + 2;
+ q__4.r = du[1].r * x[i__5].r - du[1].i * x[i__5].i,
+ q__4.i = du[1].r * x[i__5].i + du[1].i * x[i__5]
+ .r;
+ q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ i__4 = *n - 1;
+ i__5 = *n - 1 + j * x_dim1;
+ q__3.r = dl[i__4].r * x[i__5].r - dl[i__4].i * x[i__5].i,
+ q__3.i = dl[i__4].r * x[i__5].i + dl[i__4].i * x[
+ i__5].r;
+ q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
+ i__6 = *n;
+ i__7 = *n + j * x_dim1;
+ q__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7]
+ .i, q__4.i = d__[i__6].r * x[i__7].i + d__[i__6]
+ .i * x[i__7].r;
+ q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ - 1;
+ i__6 = i__ - 1 + j * x_dim1;
+ q__4.r = dl[i__5].r * x[i__6].r - dl[i__5].i * x[i__6]
+ .i, q__4.i = dl[i__5].r * x[i__6].i + dl[i__5]
+ .i * x[i__6].r;
+ q__3.r = b[i__4].r - q__4.r, q__3.i = b[i__4].i -
+ q__4.i;
+ i__7 = i__;
+ i__8 = i__ + j * x_dim1;
+ q__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[
+ i__8].i, q__5.i = d__[i__7].r * x[i__8].i +
+ d__[i__7].i * x[i__8].r;
+ q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i;
+ i__9 = i__;
+ i__10 = i__ + 1 + j * x_dim1;
+ q__6.r = du[i__9].r * x[i__10].r - du[i__9].i * x[
+ i__10].i, q__6.i = du[i__9].r * x[i__10].i +
+ du[i__9].i * x[i__10].r;
+ q__1.r = q__2.r - q__6.r, q__1.i = q__2.i - q__6.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L110: */
+ }
+ }
+/* L120: */
+ }
+ } else if (lsame_(trans, "T")) {
+
+/* Compute B := B - A'*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ q__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
+ q__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
+ .r;
+ q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ q__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
+ q__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
+ .r;
+ q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
+ i__5 = j * x_dim1 + 2;
+ q__4.r = dl[1].r * x[i__5].r - dl[1].i * x[i__5].i,
+ q__4.i = dl[1].r * x[i__5].i + dl[1].i * x[i__5]
+ .r;
+ q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ i__4 = *n - 1;
+ i__5 = *n - 1 + j * x_dim1;
+ q__3.r = du[i__4].r * x[i__5].r - du[i__4].i * x[i__5].i,
+ q__3.i = du[i__4].r * x[i__5].i + du[i__4].i * x[
+ i__5].r;
+ q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
+ i__6 = *n;
+ i__7 = *n + j * x_dim1;
+ q__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7]
+ .i, q__4.i = d__[i__6].r * x[i__7].i + d__[i__6]
+ .i * x[i__7].r;
+ q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ - 1;
+ i__6 = i__ - 1 + j * x_dim1;
+ q__4.r = du[i__5].r * x[i__6].r - du[i__5].i * x[i__6]
+ .i, q__4.i = du[i__5].r * x[i__6].i + du[i__5]
+ .i * x[i__6].r;
+ q__3.r = b[i__4].r - q__4.r, q__3.i = b[i__4].i -
+ q__4.i;
+ i__7 = i__;
+ i__8 = i__ + j * x_dim1;
+ q__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[
+ i__8].i, q__5.i = d__[i__7].r * x[i__8].i +
+ d__[i__7].i * x[i__8].r;
+ q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i;
+ i__9 = i__;
+ i__10 = i__ + 1 + j * x_dim1;
+ q__6.r = dl[i__9].r * x[i__10].r - dl[i__9].i * x[
+ i__10].i, q__6.i = dl[i__9].r * x[i__10].i +
+ dl[i__9].i * x[i__10].r;
+ q__1.r = q__2.r - q__6.r, q__1.i = q__2.i - q__6.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L130: */
+ }
+ }
+/* L140: */
+ }
+ } else if (lsame_(trans, "C")) {
+
+/* Compute B := B - A'*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ r_cnjg(&q__3, &d__[1]);
+ i__4 = j * x_dim1 + 1;
+ q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i, q__2.i =
+ q__3.r * x[i__4].i + q__3.i * x[i__4].r;
+ q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ r_cnjg(&q__4, &d__[1]);
+ i__4 = j * x_dim1 + 1;
+ q__3.r = q__4.r * x[i__4].r - q__4.i * x[i__4].i, q__3.i =
+ q__4.r * x[i__4].i + q__4.i * x[i__4].r;
+ q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
+ r_cnjg(&q__6, &dl[1]);
+ i__5 = j * x_dim1 + 2;
+ q__5.r = q__6.r * x[i__5].r - q__6.i * x[i__5].i, q__5.i =
+ q__6.r * x[i__5].i + q__6.i * x[i__5].r;
+ q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - q__5.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ r_cnjg(&q__4, &du[*n - 1]);
+ i__4 = *n - 1 + j * x_dim1;
+ q__3.r = q__4.r * x[i__4].r - q__4.i * x[i__4].i, q__3.i =
+ q__4.r * x[i__4].i + q__4.i * x[i__4].r;
+ q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
+ r_cnjg(&q__6, &d__[*n]);
+ i__5 = *n + j * x_dim1;
+ q__5.r = q__6.r * x[i__5].r - q__6.i * x[i__5].i, q__5.i =
+ q__6.r * x[i__5].i + q__6.i * x[i__5].r;
+ q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - q__5.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ r_cnjg(&q__5, &du[i__ - 1]);
+ i__5 = i__ - 1 + j * x_dim1;
+ q__4.r = q__5.r * x[i__5].r - q__5.i * x[i__5].i,
+ q__4.i = q__5.r * x[i__5].i + q__5.i * x[i__5]
+ .r;
+ q__3.r = b[i__4].r - q__4.r, q__3.i = b[i__4].i -
+ q__4.i;
+ r_cnjg(&q__7, &d__[i__]);
+ i__6 = i__ + j * x_dim1;
+ q__6.r = q__7.r * x[i__6].r - q__7.i * x[i__6].i,
+ q__6.i = q__7.r * x[i__6].i + q__7.i * x[i__6]
+ .r;
+ q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i;
+ r_cnjg(&q__9, &dl[i__]);
+ i__7 = i__ + 1 + j * x_dim1;
+ q__8.r = q__9.r * x[i__7].r - q__9.i * x[i__7].i,
+ q__8.i = q__9.r * x[i__7].i + q__9.i * x[i__7]
+ .r;
+ q__1.r = q__2.r - q__8.r, q__1.i = q__2.i - q__8.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L150: */
+ }
+ }
+/* L160: */
+ }
+ }
+ }
+ return 0;
+
+/* End of CLAGTM */
+
+} /* clagtm_ */
diff --git a/SRC/clahef.c b/SRC/clahef.c
new file mode 100644
index 0000000..2a9a921
--- /dev/null
+++ b/SRC/clahef.c
@@ -0,0 +1,933 @@
+/* clahef.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int clahef_(char *uplo, integer *n, integer *nb, integer *kb,
+ complex *a, integer *lda, integer *ipiv, complex *w, integer *ldw,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_imag(complex *);
+ void r_cnjg(complex *, complex *), c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer j, k;
+ real t, r1;
+ complex d11, d21, d22;
+ integer jb, jj, kk, jp, kp, kw, kkw, imax, jmax;
+ real alpha;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *), ccopy_(integer *, complex *, integer *,
+ complex *, integer *), cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer kstep;
+ real absakk;
+ extern /* Subroutine */ int clacgv_(integer *, complex *, integer *);
+ extern integer icamax_(integer *, complex *, integer *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *);
+ real colmax, rowmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAHEF computes a partial factorization of a complex Hermitian */
+/* matrix A using the Bunch-Kaufman 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' U22' ) */
+
+/* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) 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. */
+/* Note that U' denotes the conjugate transpose of U. */
+
+/* CLAHEF is an auxiliary routine called by CHETRF. It uses blocked code */
+/* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or */
+/* A22 (if UPLO = 'L'). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NB (input) 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. */
+
+/* KB (output) INTEGER */
+/* The number of columns of A that were actually factored. */
+/* KB is either NB-1 or NB, or N if N <= NB. */
+
+/* A (input/output) 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, A contains details of the partial factorization. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If UPLO = 'U', only the last KB elements of IPIV are set; */
+/* if UPLO = 'L', only the first KB elements are set. */
+
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* W (workspace) COMPLEX array, dimension (LDW,NB) */
+
+/* LDW (input) INTEGER */
+/* The leading dimension of the array W. LDW >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* > 0: if INFO = k, D(k,k) is exactly zero. The factorization */
+/* has been completed, but the block diagonal matrix D is */
+/* exactly singular. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ w_dim1 = *ldw;
+ w_offset = 1 + w_dim1;
+ w -= w_offset;
+
+ /* Function Body */
+ *info = 0;
+
+/* Initialize ALPHA for use in choosing pivot block size. */
+
+ alpha = (sqrt(17.f) + 1.f) / 8.f;
+
+ if (lsame_(uplo, "U")) {
+
+/* 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) */
+
+/* K is the main loop index, decreasing from N in steps of 1 or 2 */
+
+/* KW is the column of W which corresponds to column K of A */
+
+ k = *n;
+L10:
+ kw = *nb + k - *n;
+
+/* Exit from loop */
+
+ if (k <= *n - *nb + 1 && *nb < *n || k < 1) {
+ goto L30;
+ }
+
+/* Copy column K of A to column KW of W and update it */
+
+ i__1 = k - 1;
+ ccopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1);
+ i__1 = k + kw * w_dim1;
+ i__2 = k + k * a_dim1;
+ r__1 = a[i__2].r;
+ w[i__1].r = r__1, w[i__1].i = 0.f;
+ if (k < *n) {
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * a_dim1 + 1],
+ lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw *
+ w_dim1 + 1], &c__1);
+ i__1 = k + kw * w_dim1;
+ i__2 = k + kw * w_dim1;
+ r__1 = w[i__2].r;
+ w[i__1].r = r__1, w[i__1].i = 0.f;
+ }
+
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = k + kw * w_dim1;
+ absakk = (r__1 = w[i__1].r, dabs(r__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ imax = icamax_(&i__1, &w[kw * w_dim1 + 1], &c__1);
+ i__1 = imax + kw * w_dim1;
+ colmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[imax
+ + kw * w_dim1]), dabs(r__2));
+ } else {
+ colmax = 0.f;
+ }
+
+ if (dmax(absakk,colmax) == 0.f) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ r__1 = a[i__2].r;
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* Copy column IMAX to column KW-1 of W and update it */
+
+ i__1 = imax - 1;
+ ccopy_(&i__1, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) *
+ w_dim1 + 1], &c__1);
+ i__1 = imax + (kw - 1) * w_dim1;
+ i__2 = imax + imax * a_dim1;
+ r__1 = a[i__2].r;
+ w[i__1].r = r__1, w[i__1].i = 0.f;
+ i__1 = k - imax;
+ ccopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax +
+ 1 + (kw - 1) * w_dim1], &c__1);
+ i__1 = k - imax;
+ clacgv_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], &c__1);
+ if (k < *n) {
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) *
+ a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1],
+ ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1);
+ i__1 = imax + (kw - 1) * w_dim1;
+ i__2 = imax + (kw - 1) * w_dim1;
+ r__1 = w[i__2].r;
+ w[i__1].r = r__1, w[i__1].i = 0.f;
+ }
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = k - imax;
+ jmax = imax + icamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1],
+ &c__1);
+ i__1 = jmax + (kw - 1) * w_dim1;
+ rowmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[
+ jmax + (kw - 1) * w_dim1]), dabs(r__2));
+ if (imax > 1) {
+ i__1 = imax - 1;
+ jmax = icamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__1 = jmax + (kw - 1) * w_dim1;
+ r__3 = rowmax, r__4 = (r__1 = w[i__1].r, dabs(r__1)) + (
+ r__2 = r_imag(&w[jmax + (kw - 1) * w_dim1]), dabs(
+ r__2));
+ rowmax = dmax(r__3,r__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = imax + (kw - 1) * w_dim1;
+ if ((r__1 = w[i__1].r, dabs(r__1)) >= alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+
+/* copy column KW-1 of W to column KW */
+
+ ccopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw *
+ w_dim1 + 1], &c__1);
+ } else {
+
+/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k - kstep + 1;
+ kkw = *nb + kk - *n;
+
+/* Updated column KP is already stored in column KKW of W */
+
+ if (kp != kk) {
+
+/* Copy non-updated column KK to column KP */
+
+ i__1 = kp + kp * a_dim1;
+ i__2 = kk + kk * a_dim1;
+ r__1 = a[i__2].r;
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ i__1 = kk - 1 - kp;
+ ccopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp +
+ 1) * a_dim1], lda);
+ i__1 = kk - 1 - kp;
+ clacgv_(&i__1, &a[kp + (kp + 1) * a_dim1], lda);
+ i__1 = kp - 1;
+ ccopy_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1],
+ &c__1);
+
+/* Interchange rows KK and KP in last KK columns of A and W */
+
+ if (kk < *n) {
+ i__1 = *n - kk;
+ cswap_(&i__1, &a[kk + (kk + 1) * a_dim1], lda, &a[kp + (
+ kk + 1) * a_dim1], lda);
+ }
+ i__1 = *n - kk + 1;
+ cswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw *
+ w_dim1], ldw);
+ }
+
+ if (kstep == 1) {
+
+/* 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 */
+
+ ccopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &
+ c__1);
+ i__1 = k + k * a_dim1;
+ r1 = 1.f / a[i__1].r;
+ i__1 = k - 1;
+ csscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
+
+/* Conjugate W(k) */
+
+ i__1 = k - 1;
+ clacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1);
+ } 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 > 2) {
+
+/* Store U(k) and U(k-1) in columns k and k-1 of A */
+
+ i__1 = k - 1 + kw * w_dim1;
+ d21.r = w[i__1].r, d21.i = w[i__1].i;
+ r_cnjg(&q__2, &d21);
+ c_div(&q__1, &w[k + kw * w_dim1], &q__2);
+ d11.r = q__1.r, d11.i = q__1.i;
+ c_div(&q__1, &w[k - 1 + (kw - 1) * w_dim1], &d21);
+ d22.r = q__1.r, d22.i = q__1.i;
+ q__1.r = d11.r * d22.r - d11.i * d22.i, q__1.i = d11.r *
+ d22.i + d11.i * d22.r;
+ t = 1.f / (q__1.r - 1.f);
+ q__2.r = t, q__2.i = 0.f;
+ c_div(&q__1, &q__2, &d21);
+ d21.r = q__1.r, d21.i = q__1.i;
+ i__1 = k - 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + (k - 1) * a_dim1;
+ i__3 = j + (kw - 1) * w_dim1;
+ q__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
+ q__3.i = d11.r * w[i__3].i + d11.i * w[i__3]
+ .r;
+ i__4 = j + kw * w_dim1;
+ q__2.r = q__3.r - w[i__4].r, q__2.i = q__3.i - w[i__4]
+ .i;
+ q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i =
+ d21.r * q__2.i + d21.i * q__2.r;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ i__2 = j + k * a_dim1;
+ r_cnjg(&q__2, &d21);
+ i__3 = j + kw * w_dim1;
+ q__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
+ q__4.i = d22.r * w[i__3].i + d22.i * w[i__3]
+ .r;
+ i__4 = j + (kw - 1) * w_dim1;
+ q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4]
+ .i;
+ q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i =
+ q__2.r * q__3.i + q__2.i * q__3.r;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L20: */
+ }
+ }
+
+/* Copy D(k) to A */
+
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ i__2 = k - 1 + (kw - 1) * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+ i__1 = k - 1 + k * a_dim1;
+ i__2 = k - 1 + kw * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+ i__1 = k + k * a_dim1;
+ i__2 = k + kw * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+
+/* Conjugate W(k) and W(k-1) */
+
+ i__1 = k - 1;
+ clacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1);
+ i__1 = k - 2;
+ clacgv_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k - 1] = -kp;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kstep;
+ goto L10;
+
+L30:
+
+/* Update the upper triangle of A11 (= A(1:k,1:k)) as */
+
+/* A11 := A11 - U12*D*U12' = A11 - U12*W' */
+
+/* computing blocks of NB columns at a time (note that conjg(W) is */
+/* actually stored) */
+
+ i__1 = -(*nb);
+ for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j +=
+ i__1) {
+/* Computing MIN */
+ i__2 = *nb, i__3 = k - j + 1;
+ jb = min(i__2,i__3);
+
+/* Update the upper triangle of the diagonal block */
+
+ i__2 = j + jb - 1;
+ for (jj = j; jj <= i__2; ++jj) {
+ i__3 = jj + jj * a_dim1;
+ i__4 = jj + jj * a_dim1;
+ r__1 = a[i__4].r;
+ a[i__3].r = r__1, a[i__3].i = 0.f;
+ i__3 = jj - j + 1;
+ i__4 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__3, &i__4, &q__1, &a[j + (k + 1) *
+ a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b1,
+ &a[j + jj * a_dim1], &c__1);
+ i__3 = jj + jj * a_dim1;
+ i__4 = jj + jj * a_dim1;
+ r__1 = a[i__4].r;
+ a[i__3].r = r__1, a[i__3].i = 0.f;
+/* L40: */
+ }
+
+/* Update the rectangular superdiagonal block */
+
+ i__2 = j - 1;
+ i__3 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &q__1, &a[(
+ k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * w_dim1], ldw,
+ &c_b1, &a[j * a_dim1 + 1], lda);
+/* L50: */
+ }
+
+/* Put U12 in standard form by partially undoing the interchanges */
+/* in columns k+1:n */
+
+ j = k + 1;
+L60:
+ jj = j;
+ jp = ipiv[j];
+ if (jp < 0) {
+ jp = -jp;
+ ++j;
+ }
+ ++j;
+ if (jp != jj && j <= *n) {
+ i__1 = *n - j + 1;
+ cswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda);
+ }
+ if (j <= *n) {
+ goto L60;
+ }
+
+/* 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) */
+
+/* K is the main loop index, increasing from 1 in steps of 1 or 2 */
+
+ k = 1;
+L70:
+
+/* Exit from loop */
+
+ if (k >= *nb && *nb < *n || k > *n) {
+ goto L90;
+ }
+
+/* Copy column K of A to column K of W and update it */
+
+ i__1 = k + k * w_dim1;
+ i__2 = k + k * a_dim1;
+ r__1 = a[i__2].r;
+ w[i__1].r = r__1, w[i__1].i = 0.f;
+ if (k < *n) {
+ i__1 = *n - k;
+ ccopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &w[k + 1 + k *
+ w_dim1], &c__1);
+ }
+ i__1 = *n - k + 1;
+ i__2 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1], lda, &w[k
+ + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1);
+ i__1 = k + k * w_dim1;
+ i__2 = k + k * w_dim1;
+ r__1 = w[i__2].r;
+ w[i__1].r = r__1, w[i__1].i = 0.f;
+
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = k + k * w_dim1;
+ absakk = (r__1 = w[i__1].r, dabs(r__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ imax = k + icamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1);
+ i__1 = imax + k * w_dim1;
+ colmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[imax
+ + k * w_dim1]), dabs(r__2));
+ } else {
+ colmax = 0.f;
+ }
+
+ if (dmax(absakk,colmax) == 0.f) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ r__1 = a[i__2].r;
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* Copy column IMAX to column K+1 of W and update it */
+
+ i__1 = imax - k;
+ ccopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) *
+ w_dim1], &c__1);
+ i__1 = imax - k;
+ clacgv_(&i__1, &w[k + (k + 1) * w_dim1], &c__1);
+ i__1 = imax + (k + 1) * w_dim1;
+ i__2 = imax + imax * a_dim1;
+ r__1 = a[i__2].r;
+ w[i__1].r = r__1, w[i__1].i = 0.f;
+ if (imax < *n) {
+ i__1 = *n - imax;
+ ccopy_(&i__1, &a[imax + 1 + imax * a_dim1], &c__1, &w[
+ imax + 1 + (k + 1) * w_dim1], &c__1);
+ }
+ i__1 = *n - k + 1;
+ i__2 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1],
+ lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + 1) *
+ w_dim1], &c__1);
+ i__1 = imax + (k + 1) * w_dim1;
+ i__2 = imax + (k + 1) * w_dim1;
+ r__1 = w[i__2].r;
+ w[i__1].r = r__1, w[i__1].i = 0.f;
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = imax - k;
+ jmax = k - 1 + icamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1)
+ ;
+ i__1 = jmax + (k + 1) * w_dim1;
+ rowmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[
+ jmax + (k + 1) * w_dim1]), dabs(r__2));
+ if (imax < *n) {
+ i__1 = *n - imax;
+ jmax = imax + icamax_(&i__1, &w[imax + 1 + (k + 1) *
+ w_dim1], &c__1);
+/* Computing MAX */
+ i__1 = jmax + (k + 1) * w_dim1;
+ r__3 = rowmax, r__4 = (r__1 = w[i__1].r, dabs(r__1)) + (
+ r__2 = r_imag(&w[jmax + (k + 1) * w_dim1]), dabs(
+ r__2));
+ rowmax = dmax(r__3,r__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = imax + (k + 1) * w_dim1;
+ if ((r__1 = w[i__1].r, dabs(r__1)) >= alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+
+/* copy column K+1 of W to column K */
+
+ i__1 = *n - k + 1;
+ ccopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k +
+ k * w_dim1], &c__1);
+ } else {
+
+/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k + kstep - 1;
+
+/* Updated column KP is already stored in column KK of W */
+
+ if (kp != kk) {
+
+/* Copy non-updated column KK to column KP */
+
+ i__1 = kp + kp * a_dim1;
+ i__2 = kk + kk * a_dim1;
+ r__1 = a[i__2].r;
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ i__1 = kp - kk - 1;
+ ccopy_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk +
+ 1) * a_dim1], lda);
+ i__1 = kp - kk - 1;
+ clacgv_(&i__1, &a[kp + (kk + 1) * a_dim1], lda);
+ if (kp < *n) {
+ i__1 = *n - kp;
+ ccopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1
+ + kp * a_dim1], &c__1);
+ }
+
+/* Interchange rows KK and KP in first KK columns of A and W */
+
+ i__1 = kk - 1;
+ cswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda);
+ cswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw);
+ }
+
+ if (kstep == 1) {
+
+/* 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 */
+
+ i__1 = *n - k + 1;
+ ccopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], &
+ c__1);
+ if (k < *n) {
+ i__1 = k + k * a_dim1;
+ r1 = 1.f / a[i__1].r;
+ i__1 = *n - k;
+ csscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1);
+
+/* Conjugate W(k) */
+
+ i__1 = *n - k;
+ clacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1);
+ }
+ } 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 < *n - 1) {
+
+/* Store L(k) and L(k+1) in columns k and k+1 of A */
+
+ i__1 = k + 1 + k * w_dim1;
+ d21.r = w[i__1].r, d21.i = w[i__1].i;
+ c_div(&q__1, &w[k + 1 + (k + 1) * w_dim1], &d21);
+ d11.r = q__1.r, d11.i = q__1.i;
+ r_cnjg(&q__2, &d21);
+ c_div(&q__1, &w[k + k * w_dim1], &q__2);
+ d22.r = q__1.r, d22.i = q__1.i;
+ q__1.r = d11.r * d22.r - d11.i * d22.i, q__1.i = d11.r *
+ d22.i + d11.i * d22.r;
+ t = 1.f / (q__1.r - 1.f);
+ q__2.r = t, q__2.i = 0.f;
+ c_div(&q__1, &q__2, &d21);
+ d21.r = q__1.r, d21.i = q__1.i;
+ i__1 = *n;
+ for (j = k + 2; j <= i__1; ++j) {
+ i__2 = j + k * a_dim1;
+ r_cnjg(&q__2, &d21);
+ i__3 = j + k * w_dim1;
+ q__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
+ q__4.i = d11.r * w[i__3].i + d11.i * w[i__3]
+ .r;
+ i__4 = j + (k + 1) * w_dim1;
+ q__3.r = q__4.r - w[i__4].r, q__3.i = q__4.i - w[i__4]
+ .i;
+ q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i =
+ q__2.r * q__3.i + q__2.i * q__3.r;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ i__2 = j + (k + 1) * a_dim1;
+ i__3 = j + (k + 1) * w_dim1;
+ q__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
+ q__3.i = d22.r * w[i__3].i + d22.i * w[i__3]
+ .r;
+ i__4 = j + k * w_dim1;
+ q__2.r = q__3.r - w[i__4].r, q__2.i = q__3.i - w[i__4]
+ .i;
+ q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i =
+ d21.r * q__2.i + d21.i * q__2.r;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L80: */
+ }
+ }
+
+/* Copy D(k) to A */
+
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+ i__1 = k + 1 + k * a_dim1;
+ i__2 = k + 1 + k * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ i__2 = k + 1 + (k + 1) * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+
+/* Conjugate W(k) and W(k+1) */
+
+ i__1 = *n - k;
+ clacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1);
+ i__1 = *n - k - 1;
+ clacgv_(&i__1, &w[k + 2 + (k + 1) * w_dim1], &c__1);
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k + 1] = -kp;
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kstep;
+ goto L70;
+
+L90:
+
+/* Update the lower triangle of A22 (= A(k:n,k:n)) as */
+
+/* A22 := A22 - L21*D*L21' = A22 - L21*W' */
+
+/* computing blocks of NB columns at a time (note that conjg(W) is */
+/* actually stored) */
+
+ i__1 = *n;
+ i__2 = *nb;
+ for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = *nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+
+/* Update the lower triangle of the diagonal block */
+
+ i__3 = j + jb - 1;
+ for (jj = j; jj <= i__3; ++jj) {
+ i__4 = jj + jj * a_dim1;
+ i__5 = jj + jj * a_dim1;
+ r__1 = a[i__5].r;
+ a[i__4].r = r__1, a[i__4].i = 0.f;
+ i__4 = j + jb - jj;
+ i__5 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__4, &i__5, &q__1, &a[jj + a_dim1],
+ lda, &w[jj + w_dim1], ldw, &c_b1, &a[jj + jj * a_dim1]
+, &c__1);
+ i__4 = jj + jj * a_dim1;
+ i__5 = jj + jj * a_dim1;
+ r__1 = a[i__5].r;
+ a[i__4].r = r__1, a[i__4].i = 0.f;
+/* L100: */
+ }
+
+/* Update the rectangular subdiagonal block */
+
+ if (j + jb <= *n) {
+ i__3 = *n - j - jb + 1;
+ i__4 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &q__1,
+ &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b1,
+ &a[j + jb + j * a_dim1], lda);
+ }
+/* L110: */
+ }
+
+/* Put L21 in standard form by partially undoing the interchanges */
+/* in columns 1:k-1 */
+
+ j = k - 1;
+L120:
+ jj = j;
+ jp = ipiv[j];
+ if (jp < 0) {
+ jp = -jp;
+ --j;
+ }
+ --j;
+ if (jp != jj && j >= 1) {
+ cswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda);
+ }
+ if (j >= 1) {
+ goto L120;
+ }
+
+/* Set KB to the number of columns factorized */
+
+ *kb = k - 1;
+
+ }
+ return 0;
+
+/* End of CLAHEF */
+
+} /* clahef_ */
diff --git a/SRC/clahqr.c b/SRC/clahqr.c
new file mode 100644
index 0000000..98674fc
--- /dev/null
+++ b/SRC/clahqr.c
@@ -0,0 +1,754 @@
+/* clahqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int clahqr_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, complex *h__, integer *ldh, complex *w,
+ integer *iloz, integer *ihiz, complex *z__, integer *ldz, integer *
+ info)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4, r__5, r__6;
+ complex q__1, q__2, q__3, q__4, q__5, q__6, q__7;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void r_cnjg(complex *, complex *);
+ double c_abs(complex *);
+ void c_sqrt(complex *, complex *), pow_ci(complex *, complex *, integer *)
+ ;
+
+ /* Local variables */
+ integer i__, j, k, l, m;
+ real s;
+ complex t, u, v[2], x, y;
+ integer i1, i2;
+ complex t1;
+ real t2;
+ complex v2;
+ real aa, ab, ba, bb, h10;
+ complex h11;
+ real h21;
+ complex h22, sc;
+ integer nh, nz;
+ real sx;
+ integer jhi;
+ complex h11s;
+ integer jlo, its;
+ real ulp;
+ complex sum;
+ real tst;
+ complex temp;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *), ccopy_(integer *, complex *, integer *, complex *,
+ integer *);
+ real rtemp;
+ extern /* Subroutine */ int slabad_(real *, real *), clarfg_(integer *,
+ complex *, complex *, integer *, complex *);
+ extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
+ extern doublereal slamch_(char *);
+ real safmin, safmax, smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAHQR is an auxiliary routine called by CHSEQR to update the */
+/* eigenvalues and Schur decomposition already computed by CHSEQR, by */
+/* dealing with the Hessenberg submatrix in rows and columns ILO to */
+/* IHI. */
+
+/* Arguments */
+/* ========= */
+
+/* WANTT (input) LOGICAL */
+/* = .TRUE. : the full Schur form T is required; */
+/* = .FALSE.: only eigenvalues are required. */
+
+/* WANTZ (input) LOGICAL */
+/* = .TRUE. : the matrix of Schur vectors Z is required; */
+/* = .FALSE.: Schur vectors are not required. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that H is already upper triangular in rows and */
+/* columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1). */
+/* CLAHQR works primarily with the Hessenberg submatrix in rows */
+/* and columns ILO to IHI, but applies transformations to all of */
+/* H if WANTT is .TRUE.. */
+/* 1 <= ILO <= max(1,IHI); IHI <= N. */
+
+/* H (input/output) COMPLEX array, dimension (LDH,N) */
+/* On entry, the upper Hessenberg matrix H. */
+/* On exit, if INFO is zero and if WANTT is .TRUE., then H */
+/* is upper triangular in rows and columns ILO:IHI. If INFO */
+/* is zero and if WANTT is .FALSE., then the contents of H */
+/* are unspecified on exit. The output state of H in case */
+/* INF is positive is below under the description of INFO. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH >= max(1,N). */
+
+/* W (output) COMPLEX array, dimension (N) */
+/* The computed eigenvalues ILO to IHI are stored in the */
+/* corresponding elements of W. If WANTT is .TRUE., the */
+/* eigenvalues are stored in the same order as on the diagonal */
+/* of the Schur form returned in H, with W(i) = H(i,i). */
+
+/* ILOZ (input) INTEGER */
+/* IHIZ (input) INTEGER */
+/* Specify the rows of Z to which transformations must be */
+/* applied if WANTZ is .TRUE.. */
+/* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */
+
+/* Z (input/output) COMPLEX array, dimension (LDZ,N) */
+/* If WANTZ is .TRUE., on entry Z must contain the current */
+/* matrix Z of transformations accumulated by CHSEQR, and on */
+/* exit Z has been updated; transformations are applied only to */
+/* the submatrix Z(ILOZ:IHIZ,ILO:IHI). */
+/* If WANTZ is .FALSE., Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* .GT. 0: if INFO = i, CLAHQR failed to compute all the */
+/* eigenvalues ILO to IHI in a total of 30 iterations */
+/* per eigenvalue; elements i+1:ihi of W contain */
+/* those eigenvalues which have been successfully */
+/* computed. */
+
+/* If INFO .GT. 0 and WANTT is .FALSE., then on exit, */
+/* the remaining unconverged eigenvalues are the */
+/* eigenvalues of the upper Hessenberg matrix */
+/* rows and columns ILO thorugh INFO of the final, */
+/* output value of H. */
+
+/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */
+/* (*) (initial value of H)*U = U*(final value of H) */
+/* where U is an orthognal matrix. The final */
+/* value of H is upper Hessenberg and triangular in */
+/* rows and columns INFO+1 through IHI. */
+
+/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
+/* (final value of Z) = (initial value of Z)*U */
+/* where U is the orthogonal matrix in (*) */
+/* (regardless of the value of WANTT.) */
+
+/* Further Details */
+/* =============== */
+
+/* 02-96 Based on modifications by */
+/* David Day, Sandia National Laboratory, USA */
+
+/* 12-04 Further modifications by */
+/* Ralph Byers, University of Kansas, USA */
+/* This is a modified version of CLAHQR from LAPACK version 3.0. */
+/* It is (1) more robust against overflow and underflow and */
+/* (2) adopts the more conservative Ahues & Tisseur stopping */
+/* criterion (LAWN 122, 1997). */
+
+/* ========================================================= */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+ if (*ilo == *ihi) {
+ i__1 = *ilo;
+ i__2 = *ilo + *ilo * h_dim1;
+ w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
+ return 0;
+ }
+
+/* ==== clear out the trash ==== */
+ i__1 = *ihi - 3;
+ for (j = *ilo; j <= i__1; ++j) {
+ i__2 = j + 2 + j * h_dim1;
+ h__[i__2].r = 0.f, h__[i__2].i = 0.f;
+ i__2 = j + 3 + j * h_dim1;
+ h__[i__2].r = 0.f, h__[i__2].i = 0.f;
+/* L10: */
+ }
+ if (*ilo <= *ihi - 2) {
+ i__1 = *ihi + (*ihi - 2) * h_dim1;
+ h__[i__1].r = 0.f, h__[i__1].i = 0.f;
+ }
+/* ==== ensure that subdiagonal entries are real ==== */
+ if (*wantt) {
+ jlo = 1;
+ jhi = *n;
+ } else {
+ jlo = *ilo;
+ jhi = *ihi;
+ }
+ i__1 = *ihi;
+ for (i__ = *ilo + 1; i__ <= i__1; ++i__) {
+ if (r_imag(&h__[i__ + (i__ - 1) * h_dim1]) != 0.f) {
+/* ==== The following redundant normalization */
+/* . avoids problems with both gradual and */
+/* . sudden underflow in ABS(H(I,I-1)) ==== */
+ i__2 = i__ + (i__ - 1) * h_dim1;
+ i__3 = i__ + (i__ - 1) * h_dim1;
+ r__3 = (r__1 = h__[i__3].r, dabs(r__1)) + (r__2 = r_imag(&h__[i__
+ + (i__ - 1) * h_dim1]), dabs(r__2));
+ q__1.r = h__[i__2].r / r__3, q__1.i = h__[i__2].i / r__3;
+ sc.r = q__1.r, sc.i = q__1.i;
+ r_cnjg(&q__2, &sc);
+ r__1 = c_abs(&sc);
+ q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
+ sc.r = q__1.r, sc.i = q__1.i;
+ i__2 = i__ + (i__ - 1) * h_dim1;
+ r__1 = c_abs(&h__[i__ + (i__ - 1) * h_dim1]);
+ h__[i__2].r = r__1, h__[i__2].i = 0.f;
+ i__2 = jhi - i__ + 1;
+ cscal_(&i__2, &sc, &h__[i__ + i__ * h_dim1], ldh);
+/* Computing MIN */
+ i__3 = jhi, i__4 = i__ + 1;
+ i__2 = min(i__3,i__4) - jlo + 1;
+ r_cnjg(&q__1, &sc);
+ cscal_(&i__2, &q__1, &h__[jlo + i__ * h_dim1], &c__1);
+ if (*wantz) {
+ i__2 = *ihiz - *iloz + 1;
+ r_cnjg(&q__1, &sc);
+ cscal_(&i__2, &q__1, &z__[*iloz + i__ * z_dim1], &c__1);
+ }
+ }
+/* L20: */
+ }
+
+ nh = *ihi - *ilo + 1;
+ nz = *ihiz - *iloz + 1;
+
+/* Set machine-dependent constants for the stopping criterion. */
+
+ safmin = slamch_("SAFE MINIMUM");
+ safmax = 1.f / safmin;
+ slabad_(&safmin, &safmax);
+ ulp = slamch_("PRECISION");
+ smlnum = safmin * ((real) nh / ulp);
+
+/* I1 and I2 are the indices of the first row and last column of H */
+/* to which transformations must be applied. If eigenvalues only are */
+/* being computed, I1 and I2 are set inside the main loop. */
+
+ if (*wantt) {
+ i1 = 1;
+ i2 = *n;
+ }
+
+/* The main loop begins here. I is the loop index and decreases from */
+/* IHI to ILO in steps of 1. Each iteration of the loop works */
+/* with the active submatrix in rows and columns L to I. */
+/* Eigenvalues I+1 to IHI have already converged. Either L = ILO, or */
+/* H(L,L-1) is negligible so that the matrix splits. */
+
+ i__ = *ihi;
+L30:
+ if (i__ < *ilo) {
+ goto L150;
+ }
+
+/* Perform QR iterations on rows and columns ILO to I until a */
+/* submatrix of order 1 splits off at the bottom because a */
+/* subdiagonal element has become negligible. */
+
+ l = *ilo;
+ for (its = 0; its <= 30; ++its) {
+
+/* Look for a single small subdiagonal element. */
+
+ i__1 = l + 1;
+ for (k = i__; k >= i__1; --k) {
+ i__2 = k + (k - 1) * h_dim1;
+ if ((r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&h__[k + (k
+ - 1) * h_dim1]), dabs(r__2)) <= smlnum) {
+ goto L50;
+ }
+ i__2 = k - 1 + (k - 1) * h_dim1;
+ i__3 = k + k * h_dim1;
+ tst = (r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&h__[k -
+ 1 + (k - 1) * h_dim1]), dabs(r__2)) + ((r__3 = h__[i__3]
+ .r, dabs(r__3)) + (r__4 = r_imag(&h__[k + k * h_dim1]),
+ dabs(r__4)));
+ if (tst == 0.f) {
+ if (k - 2 >= *ilo) {
+ i__2 = k - 1 + (k - 2) * h_dim1;
+ tst += (r__1 = h__[i__2].r, dabs(r__1));
+ }
+ if (k + 1 <= *ihi) {
+ i__2 = k + 1 + k * h_dim1;
+ tst += (r__1 = h__[i__2].r, dabs(r__1));
+ }
+ }
+/* ==== The following is a conservative small subdiagonal */
+/* . deflation criterion due to Ahues & Tisseur (LAWN 122, */
+/* . 1997). It has better mathematical foundation and */
+/* . improves accuracy in some examples. ==== */
+ i__2 = k + (k - 1) * h_dim1;
+ if ((r__1 = h__[i__2].r, dabs(r__1)) <= ulp * tst) {
+/* Computing MAX */
+ i__2 = k + (k - 1) * h_dim1;
+ i__3 = k - 1 + k * h_dim1;
+ r__5 = (r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&h__[
+ k + (k - 1) * h_dim1]), dabs(r__2)), r__6 = (r__3 =
+ h__[i__3].r, dabs(r__3)) + (r__4 = r_imag(&h__[k - 1
+ + k * h_dim1]), dabs(r__4));
+ ab = dmax(r__5,r__6);
+/* Computing MIN */
+ i__2 = k + (k - 1) * h_dim1;
+ i__3 = k - 1 + k * h_dim1;
+ r__5 = (r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&h__[
+ k + (k - 1) * h_dim1]), dabs(r__2)), r__6 = (r__3 =
+ h__[i__3].r, dabs(r__3)) + (r__4 = r_imag(&h__[k - 1
+ + k * h_dim1]), dabs(r__4));
+ ba = dmin(r__5,r__6);
+ i__2 = k - 1 + (k - 1) * h_dim1;
+ i__3 = k + k * h_dim1;
+ q__2.r = h__[i__2].r - h__[i__3].r, q__2.i = h__[i__2].i -
+ h__[i__3].i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+/* Computing MAX */
+ i__4 = k + k * h_dim1;
+ r__5 = (r__1 = h__[i__4].r, dabs(r__1)) + (r__2 = r_imag(&h__[
+ k + k * h_dim1]), dabs(r__2)), r__6 = (r__3 = q__1.r,
+ dabs(r__3)) + (r__4 = r_imag(&q__1), dabs(r__4));
+ aa = dmax(r__5,r__6);
+ i__2 = k - 1 + (k - 1) * h_dim1;
+ i__3 = k + k * h_dim1;
+ q__2.r = h__[i__2].r - h__[i__3].r, q__2.i = h__[i__2].i -
+ h__[i__3].i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+/* Computing MIN */
+ i__4 = k + k * h_dim1;
+ r__5 = (r__1 = h__[i__4].r, dabs(r__1)) + (r__2 = r_imag(&h__[
+ k + k * h_dim1]), dabs(r__2)), r__6 = (r__3 = q__1.r,
+ dabs(r__3)) + (r__4 = r_imag(&q__1), dabs(r__4));
+ bb = dmin(r__5,r__6);
+ s = aa + ab;
+/* Computing MAX */
+ r__1 = smlnum, r__2 = ulp * (bb * (aa / s));
+ if (ba * (ab / s) <= dmax(r__1,r__2)) {
+ goto L50;
+ }
+ }
+/* L40: */
+ }
+L50:
+ l = k;
+ if (l > *ilo) {
+
+/* H(L,L-1) is negligible */
+
+ i__1 = l + (l - 1) * h_dim1;
+ h__[i__1].r = 0.f, h__[i__1].i = 0.f;
+ }
+
+/* Exit from loop if a submatrix of order 1 has split off. */
+
+ if (l >= i__) {
+ goto L140;
+ }
+
+/* Now the active submatrix is in rows and columns L to I. If */
+/* eigenvalues only are being computed, only the active submatrix */
+/* need be transformed. */
+
+ if (! (*wantt)) {
+ i1 = l;
+ i2 = i__;
+ }
+
+ if (its == 10) {
+
+/* Exceptional shift. */
+
+ i__1 = l + 1 + l * h_dim1;
+ s = (r__1 = h__[i__1].r, dabs(r__1)) * .75f;
+ i__1 = l + l * h_dim1;
+ q__1.r = s + h__[i__1].r, q__1.i = h__[i__1].i;
+ t.r = q__1.r, t.i = q__1.i;
+ } else if (its == 20) {
+
+/* Exceptional shift. */
+
+ i__1 = i__ + (i__ - 1) * h_dim1;
+ s = (r__1 = h__[i__1].r, dabs(r__1)) * .75f;
+ i__1 = i__ + i__ * h_dim1;
+ q__1.r = s + h__[i__1].r, q__1.i = h__[i__1].i;
+ t.r = q__1.r, t.i = q__1.i;
+ } else {
+
+/* Wilkinson's shift. */
+
+ i__1 = i__ + i__ * h_dim1;
+ t.r = h__[i__1].r, t.i = h__[i__1].i;
+ c_sqrt(&q__2, &h__[i__ - 1 + i__ * h_dim1]);
+ c_sqrt(&q__3, &h__[i__ + (i__ - 1) * h_dim1]);
+ q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r *
+ q__3.i + q__2.i * q__3.r;
+ u.r = q__1.r, u.i = q__1.i;
+ s = (r__1 = u.r, dabs(r__1)) + (r__2 = r_imag(&u), dabs(r__2));
+ if (s != 0.f) {
+ i__1 = i__ - 1 + (i__ - 1) * h_dim1;
+ q__2.r = h__[i__1].r - t.r, q__2.i = h__[i__1].i - t.i;
+ q__1.r = q__2.r * .5f, q__1.i = q__2.i * .5f;
+ x.r = q__1.r, x.i = q__1.i;
+ sx = (r__1 = x.r, dabs(r__1)) + (r__2 = r_imag(&x), dabs(r__2)
+ );
+/* Computing MAX */
+ r__3 = s, r__4 = (r__1 = x.r, dabs(r__1)) + (r__2 = r_imag(&x)
+ , dabs(r__2));
+ s = dmax(r__3,r__4);
+ q__5.r = x.r / s, q__5.i = x.i / s;
+ pow_ci(&q__4, &q__5, &c__2);
+ q__7.r = u.r / s, q__7.i = u.i / s;
+ pow_ci(&q__6, &q__7, &c__2);
+ q__3.r = q__4.r + q__6.r, q__3.i = q__4.i + q__6.i;
+ c_sqrt(&q__2, &q__3);
+ q__1.r = s * q__2.r, q__1.i = s * q__2.i;
+ y.r = q__1.r, y.i = q__1.i;
+ if (sx > 0.f) {
+ q__1.r = x.r / sx, q__1.i = x.i / sx;
+ q__2.r = x.r / sx, q__2.i = x.i / sx;
+ if (q__1.r * y.r + r_imag(&q__2) * r_imag(&y) < 0.f) {
+ q__3.r = -y.r, q__3.i = -y.i;
+ y.r = q__3.r, y.i = q__3.i;
+ }
+ }
+ q__4.r = x.r + y.r, q__4.i = x.i + y.i;
+ cladiv_(&q__3, &u, &q__4);
+ q__2.r = u.r * q__3.r - u.i * q__3.i, q__2.i = u.r * q__3.i +
+ u.i * q__3.r;
+ q__1.r = t.r - q__2.r, q__1.i = t.i - q__2.i;
+ t.r = q__1.r, t.i = q__1.i;
+ }
+ }
+
+/* Look for two consecutive small subdiagonal elements. */
+
+ i__1 = l + 1;
+ for (m = i__ - 1; m >= i__1; --m) {
+
+/* Determine the effect of starting the single-shift QR */
+/* iteration at row M, and see if this would make H(M,M-1) */
+/* negligible. */
+
+ i__2 = m + m * h_dim1;
+ h11.r = h__[i__2].r, h11.i = h__[i__2].i;
+ i__2 = m + 1 + (m + 1) * h_dim1;
+ h22.r = h__[i__2].r, h22.i = h__[i__2].i;
+ q__1.r = h11.r - t.r, q__1.i = h11.i - t.i;
+ h11s.r = q__1.r, h11s.i = q__1.i;
+ i__2 = m + 1 + m * h_dim1;
+ h21 = h__[i__2].r;
+ s = (r__1 = h11s.r, dabs(r__1)) + (r__2 = r_imag(&h11s), dabs(
+ r__2)) + dabs(h21);
+ q__1.r = h11s.r / s, q__1.i = h11s.i / s;
+ h11s.r = q__1.r, h11s.i = q__1.i;
+ h21 /= s;
+ v[0].r = h11s.r, v[0].i = h11s.i;
+ v[1].r = h21, v[1].i = 0.f;
+ i__2 = m + (m - 1) * h_dim1;
+ h10 = h__[i__2].r;
+ if (dabs(h10) * dabs(h21) <= ulp * (((r__1 = h11s.r, dabs(r__1))
+ + (r__2 = r_imag(&h11s), dabs(r__2))) * ((r__3 = h11.r,
+ dabs(r__3)) + (r__4 = r_imag(&h11), dabs(r__4)) + ((r__5 =
+ h22.r, dabs(r__5)) + (r__6 = r_imag(&h22), dabs(r__6)))))
+ ) {
+ goto L70;
+ }
+/* L60: */
+ }
+ i__1 = l + l * h_dim1;
+ h11.r = h__[i__1].r, h11.i = h__[i__1].i;
+ i__1 = l + 1 + (l + 1) * h_dim1;
+ h22.r = h__[i__1].r, h22.i = h__[i__1].i;
+ q__1.r = h11.r - t.r, q__1.i = h11.i - t.i;
+ h11s.r = q__1.r, h11s.i = q__1.i;
+ i__1 = l + 1 + l * h_dim1;
+ h21 = h__[i__1].r;
+ s = (r__1 = h11s.r, dabs(r__1)) + (r__2 = r_imag(&h11s), dabs(r__2))
+ + dabs(h21);
+ q__1.r = h11s.r / s, q__1.i = h11s.i / s;
+ h11s.r = q__1.r, h11s.i = q__1.i;
+ h21 /= s;
+ v[0].r = h11s.r, v[0].i = h11s.i;
+ v[1].r = h21, v[1].i = 0.f;
+L70:
+
+/* Single-shift QR step */
+
+ i__1 = i__ - 1;
+ for (k = m; k <= i__1; ++k) {
+
+/* The first iteration of this loop determines a reflection G */
+/* from the vector V and applies it from left and right to H, */
+/* thus creating a nonzero bulge below the subdiagonal. */
+
+/* Each subsequent iteration determines a reflection G to */
+/* restore the Hessenberg form in the (K-1)th column, and thus */
+/* chases the bulge one step toward the bottom of the active */
+/* submatrix. */
+
+/* V(2) is always real before the call to CLARFG, and hence */
+/* after the call T2 ( = T1*V(2) ) is also real. */
+
+ if (k > m) {
+ ccopy_(&c__2, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
+ }
+ clarfg_(&c__2, v, &v[1], &c__1, &t1);
+ if (k > m) {
+ i__2 = k + (k - 1) * h_dim1;
+ h__[i__2].r = v[0].r, h__[i__2].i = v[0].i;
+ i__2 = k + 1 + (k - 1) * h_dim1;
+ h__[i__2].r = 0.f, h__[i__2].i = 0.f;
+ }
+ v2.r = v[1].r, v2.i = v[1].i;
+ q__1.r = t1.r * v2.r - t1.i * v2.i, q__1.i = t1.r * v2.i + t1.i *
+ v2.r;
+ t2 = q__1.r;
+
+/* Apply G from the left to transform the rows of the matrix */
+/* in columns K to I2. */
+
+ i__2 = i2;
+ for (j = k; j <= i__2; ++j) {
+ r_cnjg(&q__3, &t1);
+ i__3 = k + j * h_dim1;
+ q__2.r = q__3.r * h__[i__3].r - q__3.i * h__[i__3].i, q__2.i =
+ q__3.r * h__[i__3].i + q__3.i * h__[i__3].r;
+ i__4 = k + 1 + j * h_dim1;
+ q__4.r = t2 * h__[i__4].r, q__4.i = t2 * h__[i__4].i;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ sum.r = q__1.r, sum.i = q__1.i;
+ i__3 = k + j * h_dim1;
+ i__4 = k + j * h_dim1;
+ q__1.r = h__[i__4].r - sum.r, q__1.i = h__[i__4].i - sum.i;
+ h__[i__3].r = q__1.r, h__[i__3].i = q__1.i;
+ i__3 = k + 1 + j * h_dim1;
+ i__4 = k + 1 + j * h_dim1;
+ q__2.r = sum.r * v2.r - sum.i * v2.i, q__2.i = sum.r * v2.i +
+ sum.i * v2.r;
+ q__1.r = h__[i__4].r - q__2.r, q__1.i = h__[i__4].i - q__2.i;
+ h__[i__3].r = q__1.r, h__[i__3].i = q__1.i;
+/* L80: */
+ }
+
+/* Apply G from the right to transform the columns of the */
+/* matrix in rows I1 to min(K+2,I). */
+
+/* Computing MIN */
+ i__3 = k + 2;
+ i__2 = min(i__3,i__);
+ for (j = i1; j <= i__2; ++j) {
+ i__3 = j + k * h_dim1;
+ q__2.r = t1.r * h__[i__3].r - t1.i * h__[i__3].i, q__2.i =
+ t1.r * h__[i__3].i + t1.i * h__[i__3].r;
+ i__4 = j + (k + 1) * h_dim1;
+ q__3.r = t2 * h__[i__4].r, q__3.i = t2 * h__[i__4].i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ sum.r = q__1.r, sum.i = q__1.i;
+ i__3 = j + k * h_dim1;
+ i__4 = j + k * h_dim1;
+ q__1.r = h__[i__4].r - sum.r, q__1.i = h__[i__4].i - sum.i;
+ h__[i__3].r = q__1.r, h__[i__3].i = q__1.i;
+ i__3 = j + (k + 1) * h_dim1;
+ i__4 = j + (k + 1) * h_dim1;
+ r_cnjg(&q__3, &v2);
+ q__2.r = sum.r * q__3.r - sum.i * q__3.i, q__2.i = sum.r *
+ q__3.i + sum.i * q__3.r;
+ q__1.r = h__[i__4].r - q__2.r, q__1.i = h__[i__4].i - q__2.i;
+ h__[i__3].r = q__1.r, h__[i__3].i = q__1.i;
+/* L90: */
+ }
+
+ if (*wantz) {
+
+/* Accumulate transformations in the matrix Z */
+
+ i__2 = *ihiz;
+ for (j = *iloz; j <= i__2; ++j) {
+ i__3 = j + k * z_dim1;
+ q__2.r = t1.r * z__[i__3].r - t1.i * z__[i__3].i, q__2.i =
+ t1.r * z__[i__3].i + t1.i * z__[i__3].r;
+ i__4 = j + (k + 1) * z_dim1;
+ q__3.r = t2 * z__[i__4].r, q__3.i = t2 * z__[i__4].i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ sum.r = q__1.r, sum.i = q__1.i;
+ i__3 = j + k * z_dim1;
+ i__4 = j + k * z_dim1;
+ q__1.r = z__[i__4].r - sum.r, q__1.i = z__[i__4].i -
+ sum.i;
+ z__[i__3].r = q__1.r, z__[i__3].i = q__1.i;
+ i__3 = j + (k + 1) * z_dim1;
+ i__4 = j + (k + 1) * z_dim1;
+ r_cnjg(&q__3, &v2);
+ q__2.r = sum.r * q__3.r - sum.i * q__3.i, q__2.i = sum.r *
+ q__3.i + sum.i * q__3.r;
+ q__1.r = z__[i__4].r - q__2.r, q__1.i = z__[i__4].i -
+ q__2.i;
+ z__[i__3].r = q__1.r, z__[i__3].i = q__1.i;
+/* L100: */
+ }
+ }
+
+ if (k == m && m > l) {
+
+/* If the QR step was started at row M > L because two */
+/* consecutive small subdiagonals were found, then extra */
+/* scaling must be performed to ensure that H(M,M-1) remains */
+/* real. */
+
+ q__1.r = 1.f - t1.r, q__1.i = 0.f - t1.i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ r__1 = c_abs(&temp);
+ q__1.r = temp.r / r__1, q__1.i = temp.i / r__1;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__2 = m + 1 + m * h_dim1;
+ i__3 = m + 1 + m * h_dim1;
+ r_cnjg(&q__2, &temp);
+ q__1.r = h__[i__3].r * q__2.r - h__[i__3].i * q__2.i, q__1.i =
+ h__[i__3].r * q__2.i + h__[i__3].i * q__2.r;
+ h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
+ if (m + 2 <= i__) {
+ i__2 = m + 2 + (m + 1) * h_dim1;
+ i__3 = m + 2 + (m + 1) * h_dim1;
+ q__1.r = h__[i__3].r * temp.r - h__[i__3].i * temp.i,
+ q__1.i = h__[i__3].r * temp.i + h__[i__3].i *
+ temp.r;
+ h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
+ }
+ i__2 = i__;
+ for (j = m; j <= i__2; ++j) {
+ if (j != m + 1) {
+ if (i2 > j) {
+ i__3 = i2 - j;
+ cscal_(&i__3, &temp, &h__[j + (j + 1) * h_dim1],
+ ldh);
+ }
+ i__3 = j - i1;
+ r_cnjg(&q__1, &temp);
+ cscal_(&i__3, &q__1, &h__[i1 + j * h_dim1], &c__1);
+ if (*wantz) {
+ r_cnjg(&q__1, &temp);
+ cscal_(&nz, &q__1, &z__[*iloz + j * z_dim1], &
+ c__1);
+ }
+ }
+/* L110: */
+ }
+ }
+/* L120: */
+ }
+
+/* Ensure that H(I,I-1) is real. */
+
+ i__1 = i__ + (i__ - 1) * h_dim1;
+ temp.r = h__[i__1].r, temp.i = h__[i__1].i;
+ if (r_imag(&temp) != 0.f) {
+ rtemp = c_abs(&temp);
+ i__1 = i__ + (i__ - 1) * h_dim1;
+ h__[i__1].r = rtemp, h__[i__1].i = 0.f;
+ q__1.r = temp.r / rtemp, q__1.i = temp.i / rtemp;
+ temp.r = q__1.r, temp.i = q__1.i;
+ if (i2 > i__) {
+ i__1 = i2 - i__;
+ r_cnjg(&q__1, &temp);
+ cscal_(&i__1, &q__1, &h__[i__ + (i__ + 1) * h_dim1], ldh);
+ }
+ i__1 = i__ - i1;
+ cscal_(&i__1, &temp, &h__[i1 + i__ * h_dim1], &c__1);
+ if (*wantz) {
+ cscal_(&nz, &temp, &z__[*iloz + i__ * z_dim1], &c__1);
+ }
+ }
+
+/* L130: */
+ }
+
+/* Failure to converge in remaining number of iterations */
+
+ *info = i__;
+ return 0;
+
+L140:
+
+/* H(I,I-1) is negligible: one eigenvalue has converged. */
+
+ i__1 = i__;
+ i__2 = i__ + i__ * h_dim1;
+ w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
+
+/* return to start of the main loop with new value of I. */
+
+ i__ = l - 1;
+ goto L30;
+
+L150:
+ return 0;
+
+/* End of CLAHQR */
+
+} /* clahqr_ */
diff --git a/SRC/clahr2.c b/SRC/clahr2.c
new file mode 100644
index 0000000..22d3bbf
--- /dev/null
+++ b/SRC/clahr2.c
@@ -0,0 +1,329 @@
+/* clahr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int clahr2_(integer *n, integer *k, integer *nb, complex *a,
+ integer *lda, complex *tau, complex *t, integer *ldt, complex *y,
+ integer *ldy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
+ i__3;
+ complex q__1;
+
+ /* Local variables */
+ integer i__;
+ complex ei;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *), cgemm_(char *, char *, integer *, integer *, integer *
+, complex *, complex *, integer *, complex *, integer *, complex *
+, complex *, integer *), cgemv_(char *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), ccopy_(integer *,
+ complex *, integer *, complex *, integer *), ctrmm_(char *, char *
+, char *, char *, integer *, integer *, complex *, complex *,
+ integer *, complex *, integer *),
+ caxpy_(integer *, complex *, complex *, integer *, complex *,
+ integer *), ctrmv_(char *, char *, char *, integer *, complex *,
+ integer *, complex *, integer *), clarfg_(
+ integer *, complex *, complex *, integer *, complex *), clacgv_(
+ integer *, complex *, integer *), clacpy_(char *, integer *,
+ integer *, complex *, integer *, complex *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1) */
+/* matrix A so that elements below the k-th subdiagonal are zero. The */
+/* reduction is performed by an unitary similarity transformation */
+/* Q' * A * Q. The routine returns the matrices V and T which determine */
+/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */
+
+/* This is an auxiliary routine called by CGEHRD. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* K (input) INTEGER */
+/* The offset for the reduction. Elements below the k-th */
+/* subdiagonal in the first NB columns are reduced to zero. */
+/* K < N. */
+
+/* NB (input) INTEGER */
+/* The number of columns to be reduced. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N-K+1) */
+/* On entry, the n-by-(n-k+1) general matrix A. */
+/* On exit, the elements on and above the k-th subdiagonal in */
+/* the first NB columns are overwritten with the corresponding */
+/* elements of the reduced matrix; the elements below the k-th */
+/* subdiagonal, with the array TAU, represent the matrix Q as a */
+/* product of elementary reflectors. The other columns of A are */
+/* unchanged. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAU (output) COMPLEX array, dimension (NB) */
+/* The scalar factors of the elementary reflectors. See Further */
+/* Details. */
+
+/* T (output) COMPLEX array, dimension (LDT,NB) */
+/* The upper triangular matrix T. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= NB. */
+
+/* Y (output) COMPLEX array, dimension (LDY,NB) */
+/* The n-by-nb matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= N. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of nb elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(nb). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
+/* A(i+k+1:n,i), and tau in TAU(i). */
+
+/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */
+/* V which is needed, with T and Y, to apply the transformation to the */
+/* unreduced part of the matrix, using an update of the form: */
+/* A := (I - V*T*V') * (A - Y*V'). */
+
+/* The contents of A on exit are illustrated by the following example */
+/* with n = 7, k = 3 and nb = 2: */
+
+/* ( a a a a a ) */
+/* ( a a a a a ) */
+/* ( a a a a a ) */
+/* ( h h a a a ) */
+/* ( v1 h a a a ) */
+/* ( v1 v2 a a a ) */
+/* ( v1 v2 a a a ) */
+
+/* where a denotes an element of the original matrix A, h denotes a */
+/* modified element of the upper Hessenberg matrix H, and vi denotes an */
+/* element of the vector defining H(i). */
+
+/* This file is a slight modification of LAPACK-3.0's CLAHRD */
+/* incorporating improvements proposed by Quintana-Orti and Van de */
+/* Gejin. Note that the entries of A(1:K,2:NB) differ from those */
+/* returned by the original LAPACK routine. This function is */
+/* not backward compatible with LAPACK3.0. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --tau;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+
+ /* Function Body */
+ if (*n <= 1) {
+ return 0;
+ }
+
+ i__1 = *nb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (i__ > 1) {
+
+/* Update A(K+1:N,I) */
+
+/* Update I-th column of A - Y * V' */
+
+ i__2 = i__ - 1;
+ clacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
+ i__2 = *n - *k;
+ i__3 = i__ - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("NO TRANSPOSE", &i__2, &i__3, &q__1, &y[*k + 1 + y_dim1],
+ ldy, &a[*k + i__ - 1 + a_dim1], lda, &c_b2, &a[*k + 1 +
+ i__ * a_dim1], &c__1);
+ i__2 = i__ - 1;
+ clacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
+
+/* Apply I - V * T' * V' to this column (call it b) from the */
+/* left, using the last column of T as workspace */
+
+/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */
+/* ( V2 ) ( b2 ) */
+
+/* where V1 is unit lower triangular */
+
+/* w := V1' * b1 */
+
+ i__2 = i__ - 1;
+ ccopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 +
+ 1], &c__1);
+ i__2 = i__ - 1;
+ ctrmv_("Lower", "Conjugate transpose", "UNIT", &i__2, &a[*k + 1 +
+ a_dim1], lda, &t[*nb * t_dim1 + 1], &c__1);
+
+/* w := w + V2'*b2 */
+
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ +
+ a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b2, &
+ t[*nb * t_dim1 + 1], &c__1);
+
+/* w := T'*w */
+
+ i__2 = i__ - 1;
+ ctrmv_("Upper", "Conjugate transpose", "NON-UNIT", &i__2, &t[
+ t_offset], ldt, &t[*nb * t_dim1 + 1], &c__1);
+
+/* b2 := b2 - V2*w */
+
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("NO TRANSPOSE", &i__2, &i__3, &q__1, &a[*k + i__ + a_dim1],
+ lda, &t[*nb * t_dim1 + 1], &c__1, &c_b2, &a[*k + i__ +
+ i__ * a_dim1], &c__1);
+
+/* b1 := b1 - V1*w */
+
+ i__2 = i__ - 1;
+ ctrmv_("Lower", "NO TRANSPOSE", "UNIT", &i__2, &a[*k + 1 + a_dim1]
+, lda, &t[*nb * t_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ caxpy_(&i__2, &q__1, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__
+ * a_dim1], &c__1);
+
+ i__2 = *k + i__ - 1 + (i__ - 1) * a_dim1;
+ a[i__2].r = ei.r, a[i__2].i = ei.i;
+ }
+
+/* Generate the elementary reflector H(I) to annihilate */
+/* A(K+I+1:N,I) */
+
+ i__2 = *n - *k - i__ + 1;
+/* Computing MIN */
+ i__3 = *k + i__ + 1;
+ clarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[min(i__3, *n)+ i__ *
+ a_dim1], &c__1, &tau[i__]);
+ i__2 = *k + i__ + i__ * a_dim1;
+ ei.r = a[i__2].r, ei.i = a[i__2].i;
+ i__2 = *k + i__ + i__ * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+
+/* Compute Y(K+1:N,I) */
+
+ i__2 = *n - *k;
+ i__3 = *n - *k - i__ + 1;
+ cgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b2, &a[*k + 1 + (i__ + 1) *
+ a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &y[*
+ k + 1 + i__ * y_dim1], &c__1);
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ +
+ a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &t[
+ i__ * t_dim1 + 1], &c__1);
+ i__2 = *n - *k;
+ i__3 = i__ - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("NO TRANSPOSE", &i__2, &i__3, &q__1, &y[*k + 1 + y_dim1], ldy,
+ &t[i__ * t_dim1 + 1], &c__1, &c_b2, &y[*k + 1 + i__ * y_dim1],
+ &c__1);
+ i__2 = *n - *k;
+ cscal_(&i__2, &tau[i__], &y[*k + 1 + i__ * y_dim1], &c__1);
+
+/* Compute T(1:I,I) */
+
+ i__2 = i__ - 1;
+ i__3 = i__;
+ q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i;
+ cscal_(&i__2, &q__1, &t[i__ * t_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ ctrmv_("Upper", "No Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt,
+ &t[i__ * t_dim1 + 1], &c__1)
+ ;
+ i__2 = i__ + i__ * t_dim1;
+ i__3 = i__;
+ t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i;
+
+/* L10: */
+ }
+ i__1 = *k + *nb + *nb * a_dim1;
+ a[i__1].r = ei.r, a[i__1].i = ei.i;
+
+/* Compute Y(1:K,1:NB) */
+
+ clacpy_("ALL", k, nb, &a[(a_dim1 << 1) + 1], lda, &y[y_offset], ldy);
+ ctrmm_("RIGHT", "Lower", "NO TRANSPOSE", "UNIT", k, nb, &c_b2, &a[*k + 1
+ + a_dim1], lda, &y[y_offset], ldy);
+ if (*n > *k + *nb) {
+ i__1 = *n - *k - *nb;
+ cgemm_("NO TRANSPOSE", "NO TRANSPOSE", k, nb, &i__1, &c_b2, &a[(*nb +
+ 2) * a_dim1 + 1], lda, &a[*k + 1 + *nb + a_dim1], lda, &c_b2,
+ &y[y_offset], ldy);
+ }
+ ctrmm_("RIGHT", "Upper", "NO TRANSPOSE", "NON-UNIT", k, nb, &c_b2, &t[
+ t_offset], ldt, &y[y_offset], ldy);
+
+ return 0;
+
+/* End of CLAHR2 */
+
+} /* clahr2_ */
diff --git a/SRC/clahrd.c b/SRC/clahrd.c
new file mode 100644
index 0000000..00ac3ab
--- /dev/null
+++ b/SRC/clahrd.c
@@ -0,0 +1,298 @@
+/* clahrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int clahrd_(integer *n, integer *k, integer *nb, complex *a,
+ integer *lda, complex *tau, complex *t, integer *ldt, complex *y,
+ integer *ldy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
+ i__3;
+ complex q__1;
+
+ /* Local variables */
+ integer i__;
+ complex ei;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *), cgemv_(char *, integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, complex *,
+ integer *), ccopy_(integer *, complex *, integer *,
+ complex *, integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *), ctrmv_(char *, char *, char *,
+ integer *, complex *, integer *, complex *, integer *), clarfg_(integer *, complex *, complex *, integer
+ *, complex *), clacgv_(integer *, complex *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAHRD reduces the first NB columns of a complex general n-by-(n-k+1) */
+/* matrix A so that elements below the k-th subdiagonal are zero. The */
+/* reduction is performed by a unitary similarity transformation */
+/* Q' * A * Q. The routine returns the matrices V and T which determine */
+/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */
+
+/* This is an OBSOLETE auxiliary routine. */
+/* This routine will be 'deprecated' in a future release. */
+/* Please use the new routine CLAHR2 instead. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* K (input) INTEGER */
+/* The offset for the reduction. Elements below the k-th */
+/* subdiagonal in the first NB columns are reduced to zero. */
+
+/* NB (input) INTEGER */
+/* The number of columns to be reduced. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N-K+1) */
+/* On entry, the n-by-(n-k+1) general matrix A. */
+/* On exit, the elements on and above the k-th subdiagonal in */
+/* the first NB columns are overwritten with the corresponding */
+/* elements of the reduced matrix; the elements below the k-th */
+/* subdiagonal, with the array TAU, represent the matrix Q as a */
+/* product of elementary reflectors. The other columns of A are */
+/* unchanged. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAU (output) COMPLEX array, dimension (NB) */
+/* The scalar factors of the elementary reflectors. See Further */
+/* Details. */
+
+/* T (output) COMPLEX array, dimension (LDT,NB) */
+/* The upper triangular matrix T. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= NB. */
+
+/* Y (output) COMPLEX array, dimension (LDY,NB) */
+/* The n-by-nb matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= max(1,N). */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of nb elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(nb). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
+/* A(i+k+1:n,i), and tau in TAU(i). */
+
+/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */
+/* V which is needed, with T and Y, to apply the transformation to the */
+/* unreduced part of the matrix, using an update of the form: */
+/* A := (I - V*T*V') * (A - Y*V'). */
+
+/* The contents of A on exit are illustrated by the following example */
+/* with n = 7, k = 3 and nb = 2: */
+
+/* ( a h a a a ) */
+/* ( a h a a a ) */
+/* ( a h a a a ) */
+/* ( h h a a a ) */
+/* ( v1 h a a a ) */
+/* ( v1 v2 a a a ) */
+/* ( v1 v2 a a a ) */
+
+/* where a denotes an element of the original matrix A, h denotes a */
+/* modified element of the upper Hessenberg matrix H, and vi denotes an */
+/* element of the vector defining H(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --tau;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+
+ /* Function Body */
+ if (*n <= 1) {
+ return 0;
+ }
+
+ i__1 = *nb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (i__ > 1) {
+
+/* Update A(1:n,i) */
+
+/* Compute i-th column of A - Y * V' */
+
+ i__2 = i__ - 1;
+ clacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
+ i__2 = i__ - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", n, &i__2, &q__1, &y[y_offset], ldy, &a[*k
+ + i__ - 1 + a_dim1], lda, &c_b2, &a[i__ * a_dim1 + 1], &
+ c__1);
+ i__2 = i__ - 1;
+ clacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
+
+/* Apply I - V * T' * V' to this column (call it b) from the */
+/* left, using the last column of T as workspace */
+
+/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */
+/* ( V2 ) ( b2 ) */
+
+/* where V1 is unit lower triangular */
+
+/* w := V1' * b1 */
+
+ i__2 = i__ - 1;
+ ccopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 +
+ 1], &c__1);
+ i__2 = i__ - 1;
+ ctrmv_("Lower", "Conjugate transpose", "Unit", &i__2, &a[*k + 1 +
+ a_dim1], lda, &t[*nb * t_dim1 + 1], &c__1);
+
+/* w := w + V2'*b2 */
+
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ +
+ a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b2, &
+ t[*nb * t_dim1 + 1], &c__1);
+
+/* w := T'*w */
+
+ i__2 = i__ - 1;
+ ctrmv_("Upper", "Conjugate transpose", "Non-unit", &i__2, &t[
+ t_offset], ldt, &t[*nb * t_dim1 + 1], &c__1);
+
+/* b2 := b2 - V2*w */
+
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__2, &i__3, &q__1, &a[*k + i__ + a_dim1],
+ lda, &t[*nb * t_dim1 + 1], &c__1, &c_b2, &a[*k + i__ +
+ i__ * a_dim1], &c__1);
+
+/* b1 := b1 - V1*w */
+
+ i__2 = i__ - 1;
+ ctrmv_("Lower", "No transpose", "Unit", &i__2, &a[*k + 1 + a_dim1]
+, lda, &t[*nb * t_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ caxpy_(&i__2, &q__1, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__
+ * a_dim1], &c__1);
+
+ i__2 = *k + i__ - 1 + (i__ - 1) * a_dim1;
+ a[i__2].r = ei.r, a[i__2].i = ei.i;
+ }
+
+/* Generate the elementary reflector H(i) to annihilate */
+/* A(k+i+1:n,i) */
+
+ i__2 = *k + i__ + i__ * a_dim1;
+ ei.r = a[i__2].r, ei.i = a[i__2].i;
+ i__2 = *n - *k - i__ + 1;
+/* Computing MIN */
+ i__3 = *k + i__ + 1;
+ clarfg_(&i__2, &ei, &a[min(i__3, *n)+ i__ * a_dim1], &c__1, &tau[i__])
+ ;
+ i__2 = *k + i__ + i__ * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+
+/* Compute Y(1:n,i) */
+
+ i__2 = *n - *k - i__ + 1;
+ cgemv_("No transpose", n, &i__2, &c_b2, &a[(i__ + 1) * a_dim1 + 1],
+ lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &y[i__ *
+ y_dim1 + 1], &c__1);
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ +
+ a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &t[
+ i__ * t_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", n, &i__2, &q__1, &y[y_offset], ldy, &t[i__ *
+ t_dim1 + 1], &c__1, &c_b2, &y[i__ * y_dim1 + 1], &c__1);
+ cscal_(n, &tau[i__], &y[i__ * y_dim1 + 1], &c__1);
+
+/* Compute T(1:i,i) */
+
+ i__2 = i__ - 1;
+ i__3 = i__;
+ q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i;
+ cscal_(&i__2, &q__1, &t[i__ * t_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ ctrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt,
+ &t[i__ * t_dim1 + 1], &c__1)
+ ;
+ i__2 = i__ + i__ * t_dim1;
+ i__3 = i__;
+ t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i;
+
+/* L10: */
+ }
+ i__1 = *k + *nb + *nb * a_dim1;
+ a[i__1].r = ei.r, a[i__1].i = ei.i;
+
+ return 0;
+
+/* End of CLAHRD */
+
+} /* clahrd_ */
diff --git a/SRC/claic1.c b/SRC/claic1.c
new file mode 100644
index 0000000..06e41da
--- /dev/null
+++ b/SRC/claic1.c
@@ -0,0 +1,448 @@
+/* claic1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int claic1_(integer *job, integer *j, complex *x, real *sest,
+ complex *w, complex *gamma, real *sestpr, complex *s, complex *c__)
+{
+ /* System generated locals */
+ real r__1, r__2;
+ complex q__1, q__2, q__3, q__4, q__5, q__6;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+ void r_cnjg(complex *, complex *), c_sqrt(complex *, complex *);
+ double sqrt(doublereal);
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ real b, t, s1, s2, scl, eps, tmp;
+ complex sine;
+ real test, zeta1, zeta2;
+ complex alpha;
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ real norma, absgam, absalp;
+ extern doublereal slamch_(char *);
+ complex cosine;
+ real absest;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAIC1 applies one step of incremental condition estimation in */
+/* its simplest version: */
+
+/* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j */
+/* lower triangular matrix L, such that */
+/* twonorm(L*x) = sest */
+/* Then CLAIC1 computes sestpr, s, c such that */
+/* the vector */
+/* [ s*x ] */
+/* xhat = [ c ] */
+/* is an approximate singular vector of */
+/* [ L 0 ] */
+/* Lhat = [ w' gamma ] */
+/* in the sense that */
+/* twonorm(Lhat*xhat) = sestpr. */
+
+/* Depending on JOB, an estimate for the largest or smallest singular */
+/* value is computed. */
+
+/* Note that [s c]' and sestpr**2 is an eigenpair of the system */
+
+/* diag(sest*sest, 0) + [alpha gamma] * [ conjg(alpha) ] */
+/* [ conjg(gamma) ] */
+
+/* where alpha = conjg(x)'*w. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) INTEGER */
+/* = 1: an estimate for the largest singular value is computed. */
+/* = 2: an estimate for the smallest singular value is computed. */
+
+/* J (input) INTEGER */
+/* Length of X and W */
+
+/* X (input) COMPLEX array, dimension (J) */
+/* The j-vector x. */
+
+/* SEST (input) REAL */
+/* Estimated singular value of j by j matrix L */
+
+/* W (input) COMPLEX array, dimension (J) */
+/* The j-vector w. */
+
+/* GAMMA (input) COMPLEX */
+/* The diagonal element gamma. */
+
+/* SESTPR (output) REAL */
+/* Estimated singular value of (j+1) by (j+1) matrix Lhat. */
+
+/* S (output) COMPLEX */
+/* Sine needed in forming xhat. */
+
+/* C (output) COMPLEX */
+/* Cosine needed in forming xhat. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --w;
+ --x;
+
+ /* Function Body */
+ eps = slamch_("Epsilon");
+ cdotc_(&q__1, j, &x[1], &c__1, &w[1], &c__1);
+ alpha.r = q__1.r, alpha.i = q__1.i;
+
+ absalp = c_abs(&alpha);
+ absgam = c_abs(gamma);
+ absest = dabs(*sest);
+
+ if (*job == 1) {
+
+/* Estimating largest singular value */
+
+/* special cases */
+
+ if (*sest == 0.f) {
+ s1 = dmax(absgam,absalp);
+ if (s1 == 0.f) {
+ s->r = 0.f, s->i = 0.f;
+ c__->r = 1.f, c__->i = 0.f;
+ *sestpr = 0.f;
+ } else {
+ q__1.r = alpha.r / s1, q__1.i = alpha.i / s1;
+ s->r = q__1.r, s->i = q__1.i;
+ q__1.r = gamma->r / s1, q__1.i = gamma->i / s1;
+ c__->r = q__1.r, c__->i = q__1.i;
+ r_cnjg(&q__4, s);
+ q__3.r = s->r * q__4.r - s->i * q__4.i, q__3.i = s->r *
+ q__4.i + s->i * q__4.r;
+ r_cnjg(&q__6, c__);
+ q__5.r = c__->r * q__6.r - c__->i * q__6.i, q__5.i = c__->r *
+ q__6.i + c__->i * q__6.r;
+ q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
+ c_sqrt(&q__1, &q__2);
+ tmp = q__1.r;
+ q__1.r = s->r / tmp, q__1.i = s->i / tmp;
+ s->r = q__1.r, s->i = q__1.i;
+ q__1.r = c__->r / tmp, q__1.i = c__->i / tmp;
+ c__->r = q__1.r, c__->i = q__1.i;
+ *sestpr = s1 * tmp;
+ }
+ return 0;
+ } else if (absgam <= eps * absest) {
+ s->r = 1.f, s->i = 0.f;
+ c__->r = 0.f, c__->i = 0.f;
+ tmp = dmax(absest,absalp);
+ s1 = absest / tmp;
+ s2 = absalp / tmp;
+ *sestpr = tmp * sqrt(s1 * s1 + s2 * s2);
+ return 0;
+ } else if (absalp <= eps * absest) {
+ s1 = absgam;
+ s2 = absest;
+ if (s1 <= s2) {
+ s->r = 1.f, s->i = 0.f;
+ c__->r = 0.f, c__->i = 0.f;
+ *sestpr = s2;
+ } else {
+ s->r = 0.f, s->i = 0.f;
+ c__->r = 1.f, c__->i = 0.f;
+ *sestpr = s1;
+ }
+ return 0;
+ } else if (absest <= eps * absalp || absest <= eps * absgam) {
+ s1 = absgam;
+ s2 = absalp;
+ if (s1 <= s2) {
+ tmp = s1 / s2;
+ scl = sqrt(tmp * tmp + 1.f);
+ *sestpr = s2 * scl;
+ q__2.r = alpha.r / s2, q__2.i = alpha.i / s2;
+ q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
+ s->r = q__1.r, s->i = q__1.i;
+ q__2.r = gamma->r / s2, q__2.i = gamma->i / s2;
+ q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
+ c__->r = q__1.r, c__->i = q__1.i;
+ } else {
+ tmp = s2 / s1;
+ scl = sqrt(tmp * tmp + 1.f);
+ *sestpr = s1 * scl;
+ q__2.r = alpha.r / s1, q__2.i = alpha.i / s1;
+ q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
+ s->r = q__1.r, s->i = q__1.i;
+ q__2.r = gamma->r / s1, q__2.i = gamma->i / s1;
+ q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
+ c__->r = q__1.r, c__->i = q__1.i;
+ }
+ return 0;
+ } else {
+
+/* normal case */
+
+ zeta1 = absalp / absest;
+ zeta2 = absgam / absest;
+
+ b = (1.f - zeta1 * zeta1 - zeta2 * zeta2) * .5f;
+ r__1 = zeta1 * zeta1;
+ c__->r = r__1, c__->i = 0.f;
+ if (b > 0.f) {
+ r__1 = b * b;
+ q__4.r = r__1 + c__->r, q__4.i = c__->i;
+ c_sqrt(&q__3, &q__4);
+ q__2.r = b + q__3.r, q__2.i = q__3.i;
+ c_div(&q__1, c__, &q__2);
+ t = q__1.r;
+ } else {
+ r__1 = b * b;
+ q__3.r = r__1 + c__->r, q__3.i = c__->i;
+ c_sqrt(&q__2, &q__3);
+ q__1.r = q__2.r - b, q__1.i = q__2.i;
+ t = q__1.r;
+ }
+
+ q__3.r = alpha.r / absest, q__3.i = alpha.i / absest;
+ q__2.r = -q__3.r, q__2.i = -q__3.i;
+ q__1.r = q__2.r / t, q__1.i = q__2.i / t;
+ sine.r = q__1.r, sine.i = q__1.i;
+ q__3.r = gamma->r / absest, q__3.i = gamma->i / absest;
+ q__2.r = -q__3.r, q__2.i = -q__3.i;
+ r__1 = t + 1.f;
+ q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
+ cosine.r = q__1.r, cosine.i = q__1.i;
+ r_cnjg(&q__4, &sine);
+ q__3.r = sine.r * q__4.r - sine.i * q__4.i, q__3.i = sine.r *
+ q__4.i + sine.i * q__4.r;
+ r_cnjg(&q__6, &cosine);
+ q__5.r = cosine.r * q__6.r - cosine.i * q__6.i, q__5.i = cosine.r
+ * q__6.i + cosine.i * q__6.r;
+ q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
+ c_sqrt(&q__1, &q__2);
+ tmp = q__1.r;
+ q__1.r = sine.r / tmp, q__1.i = sine.i / tmp;
+ s->r = q__1.r, s->i = q__1.i;
+ q__1.r = cosine.r / tmp, q__1.i = cosine.i / tmp;
+ c__->r = q__1.r, c__->i = q__1.i;
+ *sestpr = sqrt(t + 1.f) * absest;
+ return 0;
+ }
+
+ } else if (*job == 2) {
+
+/* Estimating smallest singular value */
+
+/* special cases */
+
+ if (*sest == 0.f) {
+ *sestpr = 0.f;
+ if (dmax(absgam,absalp) == 0.f) {
+ sine.r = 1.f, sine.i = 0.f;
+ cosine.r = 0.f, cosine.i = 0.f;
+ } else {
+ r_cnjg(&q__2, gamma);
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ sine.r = q__1.r, sine.i = q__1.i;
+ r_cnjg(&q__1, &alpha);
+ cosine.r = q__1.r, cosine.i = q__1.i;
+ }
+/* Computing MAX */
+ r__1 = c_abs(&sine), r__2 = c_abs(&cosine);
+ s1 = dmax(r__1,r__2);
+ q__1.r = sine.r / s1, q__1.i = sine.i / s1;
+ s->r = q__1.r, s->i = q__1.i;
+ q__1.r = cosine.r / s1, q__1.i = cosine.i / s1;
+ c__->r = q__1.r, c__->i = q__1.i;
+ r_cnjg(&q__4, s);
+ q__3.r = s->r * q__4.r - s->i * q__4.i, q__3.i = s->r * q__4.i +
+ s->i * q__4.r;
+ r_cnjg(&q__6, c__);
+ q__5.r = c__->r * q__6.r - c__->i * q__6.i, q__5.i = c__->r *
+ q__6.i + c__->i * q__6.r;
+ q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
+ c_sqrt(&q__1, &q__2);
+ tmp = q__1.r;
+ q__1.r = s->r / tmp, q__1.i = s->i / tmp;
+ s->r = q__1.r, s->i = q__1.i;
+ q__1.r = c__->r / tmp, q__1.i = c__->i / tmp;
+ c__->r = q__1.r, c__->i = q__1.i;
+ return 0;
+ } else if (absgam <= eps * absest) {
+ s->r = 0.f, s->i = 0.f;
+ c__->r = 1.f, c__->i = 0.f;
+ *sestpr = absgam;
+ return 0;
+ } else if (absalp <= eps * absest) {
+ s1 = absgam;
+ s2 = absest;
+ if (s1 <= s2) {
+ s->r = 0.f, s->i = 0.f;
+ c__->r = 1.f, c__->i = 0.f;
+ *sestpr = s1;
+ } else {
+ s->r = 1.f, s->i = 0.f;
+ c__->r = 0.f, c__->i = 0.f;
+ *sestpr = s2;
+ }
+ return 0;
+ } else if (absest <= eps * absalp || absest <= eps * absgam) {
+ s1 = absgam;
+ s2 = absalp;
+ if (s1 <= s2) {
+ tmp = s1 / s2;
+ scl = sqrt(tmp * tmp + 1.f);
+ *sestpr = absest * (tmp / scl);
+ r_cnjg(&q__4, gamma);
+ q__3.r = q__4.r / s2, q__3.i = q__4.i / s2;
+ q__2.r = -q__3.r, q__2.i = -q__3.i;
+ q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
+ s->r = q__1.r, s->i = q__1.i;
+ r_cnjg(&q__3, &alpha);
+ q__2.r = q__3.r / s2, q__2.i = q__3.i / s2;
+ q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
+ c__->r = q__1.r, c__->i = q__1.i;
+ } else {
+ tmp = s2 / s1;
+ scl = sqrt(tmp * tmp + 1.f);
+ *sestpr = absest / scl;
+ r_cnjg(&q__4, gamma);
+ q__3.r = q__4.r / s1, q__3.i = q__4.i / s1;
+ q__2.r = -q__3.r, q__2.i = -q__3.i;
+ q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
+ s->r = q__1.r, s->i = q__1.i;
+ r_cnjg(&q__3, &alpha);
+ q__2.r = q__3.r / s1, q__2.i = q__3.i / s1;
+ q__1.r = q__2.r / scl, q__1.i = q__2.i / scl;
+ c__->r = q__1.r, c__->i = q__1.i;
+ }
+ return 0;
+ } else {
+
+/* normal case */
+
+ zeta1 = absalp / absest;
+ zeta2 = absgam / absest;
+
+/* Computing MAX */
+ r__1 = zeta1 * zeta1 + 1.f + zeta1 * zeta2, r__2 = zeta1 * zeta2
+ + zeta2 * zeta2;
+ norma = dmax(r__1,r__2);
+
+/* See if root is closer to zero or to ONE */
+
+ test = (zeta1 - zeta2) * 2.f * (zeta1 + zeta2) + 1.f;
+ if (test >= 0.f) {
+
+/* root is close to zero, compute directly */
+
+ b = (zeta1 * zeta1 + zeta2 * zeta2 + 1.f) * .5f;
+ r__1 = zeta2 * zeta2;
+ c__->r = r__1, c__->i = 0.f;
+ r__2 = b * b;
+ q__2.r = r__2 - c__->r, q__2.i = -c__->i;
+ r__1 = b + sqrt(c_abs(&q__2));
+ q__1.r = c__->r / r__1, q__1.i = c__->i / r__1;
+ t = q__1.r;
+ q__2.r = alpha.r / absest, q__2.i = alpha.i / absest;
+ r__1 = 1.f - t;
+ q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
+ sine.r = q__1.r, sine.i = q__1.i;
+ q__3.r = gamma->r / absest, q__3.i = gamma->i / absest;
+ q__2.r = -q__3.r, q__2.i = -q__3.i;
+ q__1.r = q__2.r / t, q__1.i = q__2.i / t;
+ cosine.r = q__1.r, cosine.i = q__1.i;
+ *sestpr = sqrt(t + eps * 4.f * eps * norma) * absest;
+ } else {
+
+/* root is closer to ONE, shift by that amount */
+
+ b = (zeta2 * zeta2 + zeta1 * zeta1 - 1.f) * .5f;
+ r__1 = zeta1 * zeta1;
+ c__->r = r__1, c__->i = 0.f;
+ if (b >= 0.f) {
+ q__2.r = -c__->r, q__2.i = -c__->i;
+ r__1 = b * b;
+ q__5.r = r__1 + c__->r, q__5.i = c__->i;
+ c_sqrt(&q__4, &q__5);
+ q__3.r = b + q__4.r, q__3.i = q__4.i;
+ c_div(&q__1, &q__2, &q__3);
+ t = q__1.r;
+ } else {
+ r__1 = b * b;
+ q__3.r = r__1 + c__->r, q__3.i = c__->i;
+ c_sqrt(&q__2, &q__3);
+ q__1.r = b - q__2.r, q__1.i = -q__2.i;
+ t = q__1.r;
+ }
+ q__3.r = alpha.r / absest, q__3.i = alpha.i / absest;
+ q__2.r = -q__3.r, q__2.i = -q__3.i;
+ q__1.r = q__2.r / t, q__1.i = q__2.i / t;
+ sine.r = q__1.r, sine.i = q__1.i;
+ q__3.r = gamma->r / absest, q__3.i = gamma->i / absest;
+ q__2.r = -q__3.r, q__2.i = -q__3.i;
+ r__1 = t + 1.f;
+ q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
+ cosine.r = q__1.r, cosine.i = q__1.i;
+ *sestpr = sqrt(t + 1.f + eps * 4.f * eps * norma) * absest;
+ }
+ r_cnjg(&q__4, &sine);
+ q__3.r = sine.r * q__4.r - sine.i * q__4.i, q__3.i = sine.r *
+ q__4.i + sine.i * q__4.r;
+ r_cnjg(&q__6, &cosine);
+ q__5.r = cosine.r * q__6.r - cosine.i * q__6.i, q__5.i = cosine.r
+ * q__6.i + cosine.i * q__6.r;
+ q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
+ c_sqrt(&q__1, &q__2);
+ tmp = q__1.r;
+ q__1.r = sine.r / tmp, q__1.i = sine.i / tmp;
+ s->r = q__1.r, s->i = q__1.i;
+ q__1.r = cosine.r / tmp, q__1.i = cosine.i / tmp;
+ c__->r = q__1.r, c__->i = q__1.i;
+ return 0;
+
+ }
+ }
+ return 0;
+
+/* End of CLAIC1 */
+
+} /* claic1_ */
diff --git a/SRC/clals0.c b/SRC/clals0.c
new file mode 100644
index 0000000..0e83601
--- /dev/null
+++ b/SRC/clals0.c
@@ -0,0 +1,558 @@
+/* clals0.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b5 = -1.f;
+static integer c__1 = 1;
+static real c_b13 = 1.f;
+static real c_b15 = 0.f;
+static integer c__0 = 0;
+
+/* Subroutine */ int clals0_(integer *icompq, integer *nl, integer *nr,
+ integer *sqre, integer *nrhs, complex *b, integer *ldb, complex *bx,
+ integer *ldbx, integer *perm, integer *givptr, integer *givcol,
+ integer *ldgcol, real *givnum, integer *ldgnum, real *poles, real *
+ difl, real *difr, real *z__, integer *k, real *c__, real *s, real *
+ rwork, integer *info)
+{
+ /* System generated locals */
+ integer givcol_dim1, givcol_offset, difr_dim1, difr_offset, givnum_dim1,
+ givnum_offset, poles_dim1, poles_offset, b_dim1, b_offset,
+ bx_dim1, bx_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, m, n;
+ real dj;
+ integer nlp1, jcol;
+ real temp;
+ integer jrow;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ real diflj, difrj, dsigj;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), sgemv_(char *, integer *, integer *, real *
+, real *, integer *, real *, integer *, real *, real *, integer *), csrot_(integer *, complex *, integer *, complex *,
+ integer *, real *, real *);
+ extern doublereal slamc3_(real *, real *);
+ extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, complex *, integer *, integer *), csscal_(integer *, real *, complex *, integer *),
+ clacpy_(char *, integer *, integer *, complex *, integer *,
+ complex *, integer *), xerbla_(char *, integer *);
+ real dsigjp;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLALS0 applies back the multiplying factors of either the left or the */
+/* right singular vector matrix of a diagonal matrix appended by a row */
+/* to the right hand side matrix B in solving the least squares problem */
+/* using the divide-and-conquer SVD approach. */
+
+/* For the left singular vector matrix, three types of orthogonal */
+/* matrices are involved: */
+
+/* (1L) Givens rotations: the number of such rotations is GIVPTR; the */
+/* pairs of columns/rows they were applied to are stored in GIVCOL; */
+/* and the C- and S-values of these rotations are stored in GIVNUM. */
+
+/* (2L) Permutation. The (NL+1)-st row of B is to be moved to the first */
+/* row, and for J=2:N, PERM(J)-th row of B is to be moved to the */
+/* J-th row. */
+
+/* (3L) The left singular vector matrix of the remaining matrix. */
+
+/* For the right singular vector matrix, four types of orthogonal */
+/* matrices are involved: */
+
+/* (1R) The right singular vector matrix of the remaining matrix. */
+
+/* (2R) If SQRE = 1, one extra Givens rotation to generate the right */
+/* null space. */
+
+/* (3R) The inverse transformation of (2L). */
+
+/* (4R) The inverse transformation of (1L). */
+
+/* Arguments */
+/* ========= */
+
+/* ICOMPQ (input) INTEGER */
+/* Specifies whether singular vectors are to be computed in */
+/* factored form: */
+/* = 0: Left singular vector matrix. */
+/* = 1: Right singular vector matrix. */
+
+/* NL (input) INTEGER */
+/* The row dimension of the upper block. NL >= 1. */
+
+/* NR (input) INTEGER */
+/* The row dimension of the lower block. NR >= 1. */
+
+/* SQRE (input) INTEGER */
+/* = 0: the lower block is an NR-by-NR square matrix. */
+/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */
+
+/* The bidiagonal matrix has row dimension N = NL + NR + 1, */
+/* and column dimension M = N + SQRE. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B and BX. NRHS must be at least 1. */
+
+/* B (input/output) COMPLEX array, dimension ( LDB, NRHS ) */
+/* On input, B contains the right hand sides of the least */
+/* squares problem in rows 1 through M. On output, B contains */
+/* the solution X in rows 1 through N. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB must be at least */
+/* max(1,MAX( M, N ) ). */
+
+/* BX (workspace) COMPLEX array, dimension ( LDBX, NRHS ) */
+
+/* LDBX (input) INTEGER */
+/* The leading dimension of BX. */
+
+/* PERM (input) INTEGER array, dimension ( N ) */
+/* The permutations (from deflation and sorting) applied */
+/* to the two blocks. */
+
+/* GIVPTR (input) INTEGER */
+/* The number of Givens rotations which took place in this */
+/* subproblem. */
+
+/* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 ) */
+/* Each pair of numbers indicates a pair of rows/columns */
+/* involved in a Givens rotation. */
+
+/* LDGCOL (input) INTEGER */
+/* The leading dimension of GIVCOL, must be at least N. */
+
+/* GIVNUM (input) REAL array, dimension ( LDGNUM, 2 ) */
+/* Each number indicates the C or S value used in the */
+/* corresponding Givens rotation. */
+
+/* LDGNUM (input) INTEGER */
+/* The leading dimension of arrays DIFR, POLES and */
+/* GIVNUM, must be at least K. */
+
+/* POLES (input) REAL array, dimension ( LDGNUM, 2 ) */
+/* On entry, POLES(1:K, 1) contains the new singular */
+/* values obtained from solving the secular equation, and */
+/* POLES(1:K, 2) is an array containing the poles in the secular */
+/* equation. */
+
+/* DIFL (input) REAL array, dimension ( K ). */
+/* On entry, DIFL(I) is the distance between I-th updated */
+/* (undeflated) singular value and the I-th (undeflated) old */
+/* singular value. */
+
+/* DIFR (input) REAL array, dimension ( LDGNUM, 2 ). */
+/* On entry, DIFR(I, 1) contains the distances between I-th */
+/* updated (undeflated) singular value and the I+1-th */
+/* (undeflated) old singular value. And DIFR(I, 2) is the */
+/* normalizing factor for the I-th right singular vector. */
+
+/* Z (input) REAL array, dimension ( K ) */
+/* Contain the components of the deflation-adjusted updating row */
+/* vector. */
+
+/* K (input) INTEGER */
+/* Contains the dimension of the non-deflated matrix, */
+/* This is the order of the related secular equation. 1 <= K <=N. */
+
+/* C (input) REAL */
+/* C contains garbage if SQRE =0 and the C-value of a Givens */
+/* rotation related to the right null space if SQRE = 1. */
+
+/* S (input) REAL */
+/* S contains garbage if SQRE =0 and the S-value of a Givens */
+/* rotation related to the right null space if SQRE = 1. */
+
+/* RWORK (workspace) REAL array, dimension */
+/* ( K*(1+NRHS) + 2*NRHS ) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */
+/* California at Berkeley, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ bx_dim1 = *ldbx;
+ bx_offset = 1 + bx_dim1;
+ bx -= bx_offset;
+ --perm;
+ givcol_dim1 = *ldgcol;
+ givcol_offset = 1 + givcol_dim1;
+ givcol -= givcol_offset;
+ difr_dim1 = *ldgnum;
+ difr_offset = 1 + difr_dim1;
+ difr -= difr_offset;
+ poles_dim1 = *ldgnum;
+ poles_offset = 1 + poles_dim1;
+ poles -= poles_offset;
+ givnum_dim1 = *ldgnum;
+ givnum_offset = 1 + givnum_dim1;
+ givnum -= givnum_offset;
+ --difl;
+ --z__;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*icompq < 0 || *icompq > 1) {
+ *info = -1;
+ } else if (*nl < 1) {
+ *info = -2;
+ } else if (*nr < 1) {
+ *info = -3;
+ } else if (*sqre < 0 || *sqre > 1) {
+ *info = -4;
+ }
+
+ n = *nl + *nr + 1;
+
+ if (*nrhs < 1) {
+ *info = -5;
+ } else if (*ldb < n) {
+ *info = -7;
+ } else if (*ldbx < n) {
+ *info = -9;
+ } else if (*givptr < 0) {
+ *info = -11;
+ } else if (*ldgcol < n) {
+ *info = -13;
+ } else if (*ldgnum < n) {
+ *info = -15;
+ } else if (*k < 1) {
+ *info = -20;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLALS0", &i__1);
+ return 0;
+ }
+
+ m = n + *sqre;
+ nlp1 = *nl + 1;
+
+ if (*icompq == 0) {
+
+/* Apply back orthogonal transformations from the left. */
+
+/* Step (1L): apply back the Givens rotations performed. */
+
+ i__1 = *givptr;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ csrot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, &
+ b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ +
+ (givnum_dim1 << 1)], &givnum[i__ + givnum_dim1]);
+/* L10: */
+ }
+
+/* Step (2L): permute rows of B. */
+
+ ccopy_(nrhs, &b[nlp1 + b_dim1], ldb, &bx[bx_dim1 + 1], ldbx);
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ ccopy_(nrhs, &b[perm[i__] + b_dim1], ldb, &bx[i__ + bx_dim1],
+ ldbx);
+/* L20: */
+ }
+
+/* Step (3L): apply the inverse of the left singular vector */
+/* matrix to BX. */
+
+ if (*k == 1) {
+ ccopy_(nrhs, &bx[bx_offset], ldbx, &b[b_offset], ldb);
+ if (z__[1] < 0.f) {
+ csscal_(nrhs, &c_b5, &b[b_offset], ldb);
+ }
+ } else {
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ diflj = difl[j];
+ dj = poles[j + poles_dim1];
+ dsigj = -poles[j + (poles_dim1 << 1)];
+ if (j < *k) {
+ difrj = -difr[j + difr_dim1];
+ dsigjp = -poles[j + 1 + (poles_dim1 << 1)];
+ }
+ if (z__[j] == 0.f || poles[j + (poles_dim1 << 1)] == 0.f) {
+ rwork[j] = 0.f;
+ } else {
+ rwork[j] = -poles[j + (poles_dim1 << 1)] * z__[j] / diflj
+ / (poles[j + (poles_dim1 << 1)] + dj);
+ }
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (z__[i__] == 0.f || poles[i__ + (poles_dim1 << 1)] ==
+ 0.f) {
+ rwork[i__] = 0.f;
+ } else {
+ rwork[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__]
+ / (slamc3_(&poles[i__ + (poles_dim1 << 1)], &
+ dsigj) - diflj) / (poles[i__ + (poles_dim1 <<
+ 1)] + dj);
+ }
+/* L30: */
+ }
+ i__2 = *k;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ if (z__[i__] == 0.f || poles[i__ + (poles_dim1 << 1)] ==
+ 0.f) {
+ rwork[i__] = 0.f;
+ } else {
+ rwork[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__]
+ / (slamc3_(&poles[i__ + (poles_dim1 << 1)], &
+ dsigjp) + difrj) / (poles[i__ + (poles_dim1 <<
+ 1)] + dj);
+ }
+/* L40: */
+ }
+ rwork[1] = -1.f;
+ temp = snrm2_(k, &rwork[1], &c__1);
+
+/* Since B and BX are complex, the following call to SGEMV */
+/* is performed in two steps (real and imaginary parts). */
+
+/* CALL SGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO, */
+/* $ B( J, 1 ), LDB ) */
+
+ i__ = *k + (*nrhs << 1);
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = *k;
+ for (jrow = 1; jrow <= i__3; ++jrow) {
+ ++i__;
+ i__4 = jrow + jcol * bx_dim1;
+ rwork[i__] = bx[i__4].r;
+/* L50: */
+ }
+/* L60: */
+ }
+ sgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k,
+ &rwork[1], &c__1, &c_b15, &rwork[*k + 1], &c__1);
+ i__ = *k + (*nrhs << 1);
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = *k;
+ for (jrow = 1; jrow <= i__3; ++jrow) {
+ ++i__;
+ rwork[i__] = r_imag(&bx[jrow + jcol * bx_dim1]);
+/* L70: */
+ }
+/* L80: */
+ }
+ sgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k,
+ &rwork[1], &c__1, &c_b15, &rwork[*k + 1 + *nrhs], &
+ c__1);
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = j + jcol * b_dim1;
+ i__4 = jcol + *k;
+ i__5 = jcol + *k + *nrhs;
+ q__1.r = rwork[i__4], q__1.i = rwork[i__5];
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L90: */
+ }
+ clascl_("G", &c__0, &c__0, &temp, &c_b13, &c__1, nrhs, &b[j +
+ b_dim1], ldb, info);
+/* L100: */
+ }
+ }
+
+/* Move the deflated rows of BX to B also. */
+
+ if (*k < max(m,n)) {
+ i__1 = n - *k;
+ clacpy_("A", &i__1, nrhs, &bx[*k + 1 + bx_dim1], ldbx, &b[*k + 1
+ + b_dim1], ldb);
+ }
+ } else {
+
+/* Apply back the right orthogonal transformations. */
+
+/* Step (1R): apply back the new right singular vector matrix */
+/* to B. */
+
+ if (*k == 1) {
+ ccopy_(nrhs, &b[b_offset], ldb, &bx[bx_offset], ldbx);
+ } else {
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ dsigj = poles[j + (poles_dim1 << 1)];
+ if (z__[j] == 0.f) {
+ rwork[j] = 0.f;
+ } else {
+ rwork[j] = -z__[j] / difl[j] / (dsigj + poles[j +
+ poles_dim1]) / difr[j + (difr_dim1 << 1)];
+ }
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (z__[j] == 0.f) {
+ rwork[i__] = 0.f;
+ } else {
+ r__1 = -poles[i__ + 1 + (poles_dim1 << 1)];
+ rwork[i__] = z__[j] / (slamc3_(&dsigj, &r__1) - difr[
+ i__ + difr_dim1]) / (dsigj + poles[i__ +
+ poles_dim1]) / difr[i__ + (difr_dim1 << 1)];
+ }
+/* L110: */
+ }
+ i__2 = *k;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ if (z__[j] == 0.f) {
+ rwork[i__] = 0.f;
+ } else {
+ r__1 = -poles[i__ + (poles_dim1 << 1)];
+ rwork[i__] = z__[j] / (slamc3_(&dsigj, &r__1) - difl[
+ i__]) / (dsigj + poles[i__ + poles_dim1]) /
+ difr[i__ + (difr_dim1 << 1)];
+ }
+/* L120: */
+ }
+
+/* Since B and BX are complex, the following call to SGEMV */
+/* is performed in two steps (real and imaginary parts). */
+
+/* CALL SGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO, */
+/* $ BX( J, 1 ), LDBX ) */
+
+ i__ = *k + (*nrhs << 1);
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = *k;
+ for (jrow = 1; jrow <= i__3; ++jrow) {
+ ++i__;
+ i__4 = jrow + jcol * b_dim1;
+ rwork[i__] = b[i__4].r;
+/* L130: */
+ }
+/* L140: */
+ }
+ sgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k,
+ &rwork[1], &c__1, &c_b15, &rwork[*k + 1], &c__1);
+ i__ = *k + (*nrhs << 1);
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = *k;
+ for (jrow = 1; jrow <= i__3; ++jrow) {
+ ++i__;
+ rwork[i__] = r_imag(&b[jrow + jcol * b_dim1]);
+/* L150: */
+ }
+/* L160: */
+ }
+ sgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k,
+ &rwork[1], &c__1, &c_b15, &rwork[*k + 1 + *nrhs], &
+ c__1);
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = j + jcol * bx_dim1;
+ i__4 = jcol + *k;
+ i__5 = jcol + *k + *nrhs;
+ q__1.r = rwork[i__4], q__1.i = rwork[i__5];
+ bx[i__3].r = q__1.r, bx[i__3].i = q__1.i;
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+
+/* Step (2R): if SQRE = 1, apply back the rotation that is */
+/* related to the right null space of the subproblem. */
+
+ if (*sqre == 1) {
+ ccopy_(nrhs, &b[m + b_dim1], ldb, &bx[m + bx_dim1], ldbx);
+ csrot_(nrhs, &bx[bx_dim1 + 1], ldbx, &bx[m + bx_dim1], ldbx, c__,
+ s);
+ }
+ if (*k < max(m,n)) {
+ i__1 = n - *k;
+ clacpy_("A", &i__1, nrhs, &b[*k + 1 + b_dim1], ldb, &bx[*k + 1 +
+ bx_dim1], ldbx);
+ }
+
+/* Step (3R): permute rows of B. */
+
+ ccopy_(nrhs, &bx[bx_dim1 + 1], ldbx, &b[nlp1 + b_dim1], ldb);
+ if (*sqre == 1) {
+ ccopy_(nrhs, &bx[m + bx_dim1], ldbx, &b[m + b_dim1], ldb);
+ }
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ ccopy_(nrhs, &bx[i__ + bx_dim1], ldbx, &b[perm[i__] + b_dim1],
+ ldb);
+/* L190: */
+ }
+
+/* Step (4R): apply back the Givens rotations performed. */
+
+ for (i__ = *givptr; i__ >= 1; --i__) {
+ r__1 = -givnum[i__ + givnum_dim1];
+ csrot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, &
+ b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ +
+ (givnum_dim1 << 1)], &r__1);
+/* L200: */
+ }
+ }
+
+ return 0;
+
+/* End of CLALS0 */
+
+} /* clals0_ */
diff --git a/SRC/clalsa.c b/SRC/clalsa.c
new file mode 100644
index 0000000..ca12b37
--- /dev/null
+++ b/SRC/clalsa.c
@@ -0,0 +1,663 @@
+/* clalsa.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b9 = 1.f;
+static real c_b10 = 0.f;
+static integer c__2 = 2;
+
+/* Subroutine */ int clalsa_(integer *icompq, integer *smlsiz, integer *n,
+ integer *nrhs, complex *b, integer *ldb, complex *bx, integer *ldbx,
+ real *u, integer *ldu, real *vt, integer *k, real *difl, real *difr,
+ real *z__, real *poles, integer *givptr, integer *givcol, integer *
+ ldgcol, integer *perm, real *givnum, real *c__, real *s, real *rwork,
+ integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, difl_dim1,
+ difl_offset, difr_dim1, difr_offset, givnum_dim1, givnum_offset,
+ poles_dim1, poles_offset, u_dim1, u_offset, vt_dim1, vt_offset,
+ z_dim1, z_offset, b_dim1, b_offset, bx_dim1, bx_offset, i__1,
+ i__2, i__3, i__4, i__5, i__6;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ integer pow_ii(integer *, integer *);
+
+ /* Local variables */
+ integer i__, j, i1, ic, lf, nd, ll, nl, nr, im1, nlf, nrf, lvl, ndb1,
+ nlp1, lvl2, nrp1, jcol, nlvl, sqre, jrow, jimag, jreal, inode,
+ ndiml;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ integer ndimr;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), clals0_(integer *, integer *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ integer *, integer *, integer *, integer *, real *, integer *,
+ real *, real *, real *, real *, integer *, real *, real *, real *,
+ integer *), xerbla_(char *, integer *), slasdt_(integer *
+, integer *, integer *, integer *, integer *, integer *, integer *
+);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLALSA is an itermediate step in solving the least squares problem */
+/* by computing the SVD of the coefficient matrix in compact form (The */
+/* singular vectors are computed as products of simple orthorgonal */
+/* matrices.). */
+
+/* If ICOMPQ = 0, CLALSA applies the inverse of the left singular vector */
+/* matrix of an upper bidiagonal matrix to the right hand side; and if */
+/* ICOMPQ = 1, CLALSA applies the right singular vector matrix to the */
+/* right hand side. The singular vector matrices were generated in */
+/* compact form by CLALSA. */
+
+/* Arguments */
+/* ========= */
+
+/* ICOMPQ (input) INTEGER */
+/* Specifies whether the left or the right singular vector */
+/* matrix is involved. */
+/* = 0: Left singular vector matrix */
+/* = 1: Right singular vector matrix */
+
+/* SMLSIZ (input) INTEGER */
+/* The maximum size of the subproblems at the bottom of the */
+/* computation tree. */
+
+/* N (input) INTEGER */
+/* The row and column dimensions of the upper bidiagonal matrix. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B and BX. NRHS must be at least 1. */
+
+/* B (input/output) COMPLEX array, dimension ( LDB, NRHS ) */
+/* On input, B contains the right hand sides of the least */
+/* squares problem in rows 1 through M. */
+/* On output, B contains the solution X in rows 1 through N. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B in the calling subprogram. */
+/* LDB must be at least max(1,MAX( M, N ) ). */
+
+/* BX (output) COMPLEX array, dimension ( LDBX, NRHS ) */
+/* On exit, the result of applying the left or right singular */
+/* vector matrix to B. */
+
+/* LDBX (input) INTEGER */
+/* The leading dimension of BX. */
+
+/* U (input) REAL array, dimension ( LDU, SMLSIZ ). */
+/* On entry, U contains the left singular vector matrices of all */
+/* subproblems at the bottom level. */
+
+/* LDU (input) INTEGER, LDU = > N. */
+/* The leading dimension of arrays U, VT, DIFL, DIFR, */
+/* POLES, GIVNUM, and Z. */
+
+/* VT (input) REAL array, dimension ( LDU, SMLSIZ+1 ). */
+/* On entry, VT' contains the right singular vector matrices of */
+/* all subproblems at the bottom level. */
+
+/* K (input) INTEGER array, dimension ( N ). */
+
+/* DIFL (input) REAL array, dimension ( LDU, NLVL ). */
+/* where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1. */
+
+/* DIFR (input) REAL array, dimension ( LDU, 2 * NLVL ). */
+/* On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record */
+/* distances between singular values on the I-th level and */
+/* singular values on the (I -1)-th level, and DIFR(*, 2 * I) */
+/* record the normalizing factors of the right singular vectors */
+/* matrices of subproblems on I-th level. */
+
+/* Z (input) REAL array, dimension ( LDU, NLVL ). */
+/* On entry, Z(1, I) contains the components of the deflation- */
+/* adjusted updating row vector for subproblems on the I-th */
+/* level. */
+
+/* POLES (input) REAL array, dimension ( LDU, 2 * NLVL ). */
+/* On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old */
+/* singular values involved in the secular equations on the I-th */
+/* level. */
+
+/* GIVPTR (input) INTEGER array, dimension ( N ). */
+/* On entry, GIVPTR( I ) records the number of Givens */
+/* rotations performed on the I-th problem on the computation */
+/* tree. */
+
+/* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ). */
+/* On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the */
+/* locations of Givens rotations performed on the I-th level on */
+/* the computation tree. */
+
+/* LDGCOL (input) INTEGER, LDGCOL = > N. */
+/* The leading dimension of arrays GIVCOL and PERM. */
+
+/* PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ). */
+/* On entry, PERM(*, I) records permutations done on the I-th */
+/* level of the computation tree. */
+
+/* GIVNUM (input) REAL array, dimension ( LDU, 2 * NLVL ). */
+/* On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S- */
+/* values of Givens rotations performed on the I-th level on the */
+/* computation tree. */
+
+/* C (input) REAL array, dimension ( N ). */
+/* On entry, if the I-th subproblem is not square, */
+/* C( I ) contains the C-value of a Givens rotation related to */
+/* the right null space of the I-th subproblem. */
+
+/* S (input) REAL array, dimension ( N ). */
+/* On entry, if the I-th subproblem is not square, */
+/* S( I ) contains the S-value of a Givens rotation related to */
+/* the right null space of the I-th subproblem. */
+
+/* RWORK (workspace) REAL array, dimension at least */
+/* max ( N, (SMLSZ+1)*NRHS*3 ). */
+
+/* IWORK (workspace) INTEGER array. */
+/* The dimension must be at least 3 * N */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */
+/* California at Berkeley, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ bx_dim1 = *ldbx;
+ bx_offset = 1 + bx_dim1;
+ bx -= bx_offset;
+ givnum_dim1 = *ldu;
+ givnum_offset = 1 + givnum_dim1;
+ givnum -= givnum_offset;
+ poles_dim1 = *ldu;
+ poles_offset = 1 + poles_dim1;
+ poles -= poles_offset;
+ z_dim1 = *ldu;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ difr_dim1 = *ldu;
+ difr_offset = 1 + difr_dim1;
+ difr -= difr_offset;
+ difl_dim1 = *ldu;
+ difl_offset = 1 + difl_dim1;
+ difl -= difl_offset;
+ vt_dim1 = *ldu;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --k;
+ --givptr;
+ perm_dim1 = *ldgcol;
+ perm_offset = 1 + perm_dim1;
+ perm -= perm_offset;
+ givcol_dim1 = *ldgcol;
+ givcol_offset = 1 + givcol_dim1;
+ givcol -= givcol_offset;
+ --c__;
+ --s;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*icompq < 0 || *icompq > 1) {
+ *info = -1;
+ } else if (*smlsiz < 3) {
+ *info = -2;
+ } else if (*n < *smlsiz) {
+ *info = -3;
+ } else if (*nrhs < 1) {
+ *info = -4;
+ } else if (*ldb < *n) {
+ *info = -6;
+ } else if (*ldbx < *n) {
+ *info = -8;
+ } else if (*ldu < *n) {
+ *info = -10;
+ } else if (*ldgcol < *n) {
+ *info = -19;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLALSA", &i__1);
+ return 0;
+ }
+
+/* Book-keeping and setting up the computation tree. */
+
+ inode = 1;
+ ndiml = inode + *n;
+ ndimr = ndiml + *n;
+
+ slasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr],
+ smlsiz);
+
+/* The following code applies back the left singular vector factors. */
+/* For applying back the right singular vector factors, go to 170. */
+
+ if (*icompq == 1) {
+ goto L170;
+ }
+
+/* The nodes on the bottom level of the tree were solved */
+/* by SLASDQ. The corresponding left and right singular vector */
+/* matrices are in explicit form. First apply back the left */
+/* singular vector matrices. */
+
+ ndb1 = (nd + 1) / 2;
+ i__1 = nd;
+ for (i__ = ndb1; i__ <= i__1; ++i__) {
+
+/* IC : center row of each node */
+/* NL : number of rows of left subproblem */
+/* NR : number of rows of right subproblem */
+/* NLF: starting row of the left subproblem */
+/* NRF: starting row of the right subproblem */
+
+ i1 = i__ - 1;
+ ic = iwork[inode + i1];
+ nl = iwork[ndiml + i1];
+ nr = iwork[ndimr + i1];
+ nlf = ic - nl;
+ nrf = ic + 1;
+
+/* Since B and BX are complex, the following call to SGEMM */
+/* is performed in two steps (real and imaginary parts). */
+
+/* CALL SGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU, */
+/* $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX ) */
+
+ j = nl * *nrhs << 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nlf + nl - 1;
+ for (jrow = nlf; jrow <= i__3; ++jrow) {
+ ++j;
+ i__4 = jrow + jcol * b_dim1;
+ rwork[j] = b[i__4].r;
+/* L10: */
+ }
+/* L20: */
+ }
+ sgemm_("T", "N", &nl, nrhs, &nl, &c_b9, &u[nlf + u_dim1], ldu, &rwork[
+ (nl * *nrhs << 1) + 1], &nl, &c_b10, &rwork[1], &nl);
+ j = nl * *nrhs << 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nlf + nl - 1;
+ for (jrow = nlf; jrow <= i__3; ++jrow) {
+ ++j;
+ rwork[j] = r_imag(&b[jrow + jcol * b_dim1]);
+/* L30: */
+ }
+/* L40: */
+ }
+ sgemm_("T", "N", &nl, nrhs, &nl, &c_b9, &u[nlf + u_dim1], ldu, &rwork[
+ (nl * *nrhs << 1) + 1], &nl, &c_b10, &rwork[nl * *nrhs + 1], &
+ nl);
+ jreal = 0;
+ jimag = nl * *nrhs;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nlf + nl - 1;
+ for (jrow = nlf; jrow <= i__3; ++jrow) {
+ ++jreal;
+ ++jimag;
+ i__4 = jrow + jcol * bx_dim1;
+ i__5 = jreal;
+ i__6 = jimag;
+ q__1.r = rwork[i__5], q__1.i = rwork[i__6];
+ bx[i__4].r = q__1.r, bx[i__4].i = q__1.i;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* Since B and BX are complex, the following call to SGEMM */
+/* is performed in two steps (real and imaginary parts). */
+
+/* CALL SGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU, */
+/* $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX ) */
+
+ j = nr * *nrhs << 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nrf + nr - 1;
+ for (jrow = nrf; jrow <= i__3; ++jrow) {
+ ++j;
+ i__4 = jrow + jcol * b_dim1;
+ rwork[j] = b[i__4].r;
+/* L70: */
+ }
+/* L80: */
+ }
+ sgemm_("T", "N", &nr, nrhs, &nr, &c_b9, &u[nrf + u_dim1], ldu, &rwork[
+ (nr * *nrhs << 1) + 1], &nr, &c_b10, &rwork[1], &nr);
+ j = nr * *nrhs << 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nrf + nr - 1;
+ for (jrow = nrf; jrow <= i__3; ++jrow) {
+ ++j;
+ rwork[j] = r_imag(&b[jrow + jcol * b_dim1]);
+/* L90: */
+ }
+/* L100: */
+ }
+ sgemm_("T", "N", &nr, nrhs, &nr, &c_b9, &u[nrf + u_dim1], ldu, &rwork[
+ (nr * *nrhs << 1) + 1], &nr, &c_b10, &rwork[nr * *nrhs + 1], &
+ nr);
+ jreal = 0;
+ jimag = nr * *nrhs;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nrf + nr - 1;
+ for (jrow = nrf; jrow <= i__3; ++jrow) {
+ ++jreal;
+ ++jimag;
+ i__4 = jrow + jcol * bx_dim1;
+ i__5 = jreal;
+ i__6 = jimag;
+ q__1.r = rwork[i__5], q__1.i = rwork[i__6];
+ bx[i__4].r = q__1.r, bx[i__4].i = q__1.i;
+/* L110: */
+ }
+/* L120: */
+ }
+
+/* L130: */
+ }
+
+/* Next copy the rows of B that correspond to unchanged rows */
+/* in the bidiagonal matrix to BX. */
+
+ i__1 = nd;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ic = iwork[inode + i__ - 1];
+ ccopy_(nrhs, &b[ic + b_dim1], ldb, &bx[ic + bx_dim1], ldbx);
+/* L140: */
+ }
+
+/* Finally go through the left singular vector matrices of all */
+/* the other subproblems bottom-up on the tree. */
+
+ j = pow_ii(&c__2, &nlvl);
+ sqre = 0;
+
+ for (lvl = nlvl; lvl >= 1; --lvl) {
+ lvl2 = (lvl << 1) - 1;
+
+/* find the first node LF and last node LL on */
+/* the current level LVL */
+
+ if (lvl == 1) {
+ lf = 1;
+ ll = 1;
+ } else {
+ i__1 = lvl - 1;
+ lf = pow_ii(&c__2, &i__1);
+ ll = (lf << 1) - 1;
+ }
+ i__1 = ll;
+ for (i__ = lf; i__ <= i__1; ++i__) {
+ im1 = i__ - 1;
+ ic = iwork[inode + im1];
+ nl = iwork[ndiml + im1];
+ nr = iwork[ndimr + im1];
+ nlf = ic - nl;
+ nrf = ic + 1;
+ --j;
+ clals0_(icompq, &nl, &nr, &sqre, nrhs, &bx[nlf + bx_dim1], ldbx, &
+ b[nlf + b_dim1], ldb, &perm[nlf + lvl * perm_dim1], &
+ givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, &
+ givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 *
+ poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf +
+ lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[
+ j], &s[j], &rwork[1], info);
+/* L150: */
+ }
+/* L160: */
+ }
+ goto L330;
+
+/* ICOMPQ = 1: applying back the right singular vector factors. */
+
+L170:
+
+/* First now go through the right singular vector matrices of all */
+/* the tree nodes top-down. */
+
+ j = 0;
+ i__1 = nlvl;
+ for (lvl = 1; lvl <= i__1; ++lvl) {
+ lvl2 = (lvl << 1) - 1;
+
+/* Find the first node LF and last node LL on */
+/* the current level LVL. */
+
+ if (lvl == 1) {
+ lf = 1;
+ ll = 1;
+ } else {
+ i__2 = lvl - 1;
+ lf = pow_ii(&c__2, &i__2);
+ ll = (lf << 1) - 1;
+ }
+ i__2 = lf;
+ for (i__ = ll; i__ >= i__2; --i__) {
+ im1 = i__ - 1;
+ ic = iwork[inode + im1];
+ nl = iwork[ndiml + im1];
+ nr = iwork[ndimr + im1];
+ nlf = ic - nl;
+ nrf = ic + 1;
+ if (i__ == ll) {
+ sqre = 0;
+ } else {
+ sqre = 1;
+ }
+ ++j;
+ clals0_(icompq, &nl, &nr, &sqre, nrhs, &b[nlf + b_dim1], ldb, &bx[
+ nlf + bx_dim1], ldbx, &perm[nlf + lvl * perm_dim1], &
+ givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, &
+ givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 *
+ poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf +
+ lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[
+ j], &s[j], &rwork[1], info);
+/* L180: */
+ }
+/* L190: */
+ }
+
+/* The nodes on the bottom level of the tree were solved */
+/* by SLASDQ. The corresponding right singular vector */
+/* matrices are in explicit form. Apply them back. */
+
+ ndb1 = (nd + 1) / 2;
+ i__1 = nd;
+ for (i__ = ndb1; i__ <= i__1; ++i__) {
+ i1 = i__ - 1;
+ ic = iwork[inode + i1];
+ nl = iwork[ndiml + i1];
+ nr = iwork[ndimr + i1];
+ nlp1 = nl + 1;
+ if (i__ == nd) {
+ nrp1 = nr;
+ } else {
+ nrp1 = nr + 1;
+ }
+ nlf = ic - nl;
+ nrf = ic + 1;
+
+/* Since B and BX are complex, the following call to SGEMM is */
+/* performed in two steps (real and imaginary parts). */
+
+/* CALL SGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU, */
+/* $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX ) */
+
+ j = nlp1 * *nrhs << 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nlf + nlp1 - 1;
+ for (jrow = nlf; jrow <= i__3; ++jrow) {
+ ++j;
+ i__4 = jrow + jcol * b_dim1;
+ rwork[j] = b[i__4].r;
+/* L200: */
+ }
+/* L210: */
+ }
+ sgemm_("T", "N", &nlp1, nrhs, &nlp1, &c_b9, &vt[nlf + vt_dim1], ldu, &
+ rwork[(nlp1 * *nrhs << 1) + 1], &nlp1, &c_b10, &rwork[1], &
+ nlp1);
+ j = nlp1 * *nrhs << 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nlf + nlp1 - 1;
+ for (jrow = nlf; jrow <= i__3; ++jrow) {
+ ++j;
+ rwork[j] = r_imag(&b[jrow + jcol * b_dim1]);
+/* L220: */
+ }
+/* L230: */
+ }
+ sgemm_("T", "N", &nlp1, nrhs, &nlp1, &c_b9, &vt[nlf + vt_dim1], ldu, &
+ rwork[(nlp1 * *nrhs << 1) + 1], &nlp1, &c_b10, &rwork[nlp1 * *
+ nrhs + 1], &nlp1);
+ jreal = 0;
+ jimag = nlp1 * *nrhs;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nlf + nlp1 - 1;
+ for (jrow = nlf; jrow <= i__3; ++jrow) {
+ ++jreal;
+ ++jimag;
+ i__4 = jrow + jcol * bx_dim1;
+ i__5 = jreal;
+ i__6 = jimag;
+ q__1.r = rwork[i__5], q__1.i = rwork[i__6];
+ bx[i__4].r = q__1.r, bx[i__4].i = q__1.i;
+/* L240: */
+ }
+/* L250: */
+ }
+
+/* Since B and BX are complex, the following call to SGEMM is */
+/* performed in two steps (real and imaginary parts). */
+
+/* CALL SGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU, */
+/* $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX ) */
+
+ j = nrp1 * *nrhs << 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nrf + nrp1 - 1;
+ for (jrow = nrf; jrow <= i__3; ++jrow) {
+ ++j;
+ i__4 = jrow + jcol * b_dim1;
+ rwork[j] = b[i__4].r;
+/* L260: */
+ }
+/* L270: */
+ }
+ sgemm_("T", "N", &nrp1, nrhs, &nrp1, &c_b9, &vt[nrf + vt_dim1], ldu, &
+ rwork[(nrp1 * *nrhs << 1) + 1], &nrp1, &c_b10, &rwork[1], &
+ nrp1);
+ j = nrp1 * *nrhs << 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nrf + nrp1 - 1;
+ for (jrow = nrf; jrow <= i__3; ++jrow) {
+ ++j;
+ rwork[j] = r_imag(&b[jrow + jcol * b_dim1]);
+/* L280: */
+ }
+/* L290: */
+ }
+ sgemm_("T", "N", &nrp1, nrhs, &nrp1, &c_b9, &vt[nrf + vt_dim1], ldu, &
+ rwork[(nrp1 * *nrhs << 1) + 1], &nrp1, &c_b10, &rwork[nrp1 * *
+ nrhs + 1], &nrp1);
+ jreal = 0;
+ jimag = nrp1 * *nrhs;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nrf + nrp1 - 1;
+ for (jrow = nrf; jrow <= i__3; ++jrow) {
+ ++jreal;
+ ++jimag;
+ i__4 = jrow + jcol * bx_dim1;
+ i__5 = jreal;
+ i__6 = jimag;
+ q__1.r = rwork[i__5], q__1.i = rwork[i__6];
+ bx[i__4].r = q__1.r, bx[i__4].i = q__1.i;
+/* L300: */
+ }
+/* L310: */
+ }
+
+/* L320: */
+ }
+
+L330:
+
+ return 0;
+
+/* End of CLALSA */
+
+} /* clalsa_ */
diff --git a/SRC/clalsd.c b/SRC/clalsd.c
new file mode 100644
index 0000000..0ae828f
--- /dev/null
+++ b/SRC/clalsd.c
@@ -0,0 +1,755 @@
+/* clalsd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static integer c__1 = 1;
+static integer c__0 = 0;
+static real c_b10 = 1.f;
+static real c_b35 = 0.f;
+
+/* Subroutine */ int clalsd_(char *uplo, integer *smlsiz, integer *n, integer
+ *nrhs, real *d__, real *e, complex *b, integer *ldb, real *rcond,
+ integer *rank, complex *work, real *rwork, integer *iwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *), log(doublereal), r_sign(real *, real *);
+
+ /* Local variables */
+ integer c__, i__, j, k;
+ real r__;
+ integer s, u, z__;
+ real cs;
+ integer bx;
+ real sn;
+ integer st, vt, nm1, st1;
+ real eps;
+ integer iwk;
+ real tol;
+ integer difl, difr;
+ real rcnd;
+ integer jcol, irwb, perm, nsub, nlvl, sqre, bxst, jrow, irwu, jimag,
+ jreal;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ integer irwib;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer poles, sizei, irwrb, nsize;
+ extern /* Subroutine */ int csrot_(integer *, complex *, integer *,
+ complex *, integer *, real *, real *);
+ integer irwvt, icmpq1, icmpq2;
+ extern /* Subroutine */ int clalsa_(integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, real *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ integer *, integer *, integer *, integer *, real *, real *, real *
+, real *, integer *, integer *), clascl_(char *, integer *,
+ integer *, real *, real *, integer *, integer *, complex *,
+ integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int slasda_(integer *, integer *, integer *,
+ integer *, real *, real *, real *, integer *, real *, integer *,
+ real *, real *, real *, real *, integer *, integer *, integer *,
+ integer *, real *, real *, real *, real *, integer *, integer *),
+ clacpy_(char *, integer *, integer *, complex *, integer *,
+ complex *, integer *), claset_(char *, integer *, integer
+ *, complex *, complex *, complex *, integer *), xerbla_(
+ char *, integer *), slascl_(char *, integer *, integer *,
+ real *, real *, integer *, integer *, real *, integer *, integer *
+);
+ extern integer isamax_(integer *, real *, integer *);
+ integer givcol;
+ extern /* Subroutine */ int slasdq_(char *, integer *, integer *, integer
+ *, integer *, integer *, real *, real *, real *, integer *, real *
+, integer *, real *, integer *, real *, integer *),
+ slaset_(char *, integer *, integer *, real *, real *, real *,
+ integer *), slartg_(real *, real *, real *, real *, real *
+);
+ real orgnrm;
+ integer givnum;
+ extern doublereal slanst_(char *, integer *, real *, real *);
+ extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *);
+ integer givptr, nrwork, irwwrk, smlszp;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLALSD uses the singular value decomposition of A to solve the least */
+/* squares problem of finding X to minimize the Euclidean norm of each */
+/* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B */
+/* are N-by-NRHS. The solution X overwrites B. */
+
+/* The singular values of A smaller than RCOND times the largest */
+/* singular value are treated as zero in solving the least squares */
+/* problem; in this case a minimum norm solution is returned. */
+/* The actual singular values are returned in D in ascending order. */
+
+/* This code makes very mild assumptions about floating point */
+/* arithmetic. It will work on machines with a guard digit in */
+/* add/subtract, or on those binary machines without guard digits */
+/* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. */
+/* It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': D and E define an upper bidiagonal matrix. */
+/* = 'L': D and E define a lower bidiagonal matrix. */
+
+/* SMLSIZ (input) INTEGER */
+/* The maximum size of the subproblems at the bottom of the */
+/* computation tree. */
+
+/* N (input) INTEGER */
+/* The dimension of the bidiagonal matrix. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS must be at least 1. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry D contains the main diagonal of the bidiagonal */
+/* matrix. On exit, if INFO = 0, D contains its singular values. */
+
+/* E (input/output) REAL array, dimension (N-1) */
+/* Contains the super-diagonal entries of the bidiagonal matrix. */
+/* On exit, E has been destroyed. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On input, B contains the right hand sides of the least */
+/* squares problem. On output, B contains the solution X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B in the calling subprogram. */
+/* LDB must be at least max(1,N). */
+
+/* RCOND (input) REAL */
+/* The singular values of A less than or equal to RCOND times */
+/* the largest singular value are treated as zero in solving */
+/* the least squares problem. If RCOND is negative, */
+/* machine precision is used instead. */
+/* For example, if diag(S)*X=B were the least squares problem, */
+/* where diag(S) is a diagonal matrix of singular values, the */
+/* solution would be X(i) = B(i) / S(i) if S(i) is greater than */
+/* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to */
+/* RCOND*max(S). */
+
+/* RANK (output) INTEGER */
+/* The number of singular values of A greater than RCOND times */
+/* the largest singular value. */
+
+/* WORK (workspace) COMPLEX array, dimension (N * NRHS). */
+
+/* RWORK (workspace) REAL array, dimension at least */
+/* (9*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS + (SMLSIZ+1)**2), */
+/* where */
+/* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) */
+
+/* IWORK (workspace) INTEGER array, dimension (3*N*NLVL + 11*N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: The algorithm failed to compute an singular value while */
+/* working on the submatrix lying in rows and columns */
+/* INFO/(N+1) through MOD(INFO,N+1). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */
+/* California at Berkeley, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 1) {
+ *info = -4;
+ } else if (*ldb < 1 || *ldb < *n) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLALSD", &i__1);
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+
+/* Set up the tolerance. */
+
+ if (*rcond <= 0.f || *rcond >= 1.f) {
+ rcnd = eps;
+ } else {
+ rcnd = *rcond;
+ }
+
+ *rank = 0;
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ } else if (*n == 1) {
+ if (d__[1] == 0.f) {
+ claset_("A", &c__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+ } else {
+ *rank = 1;
+ clascl_("G", &c__0, &c__0, &d__[1], &c_b10, &c__1, nrhs, &b[
+ b_offset], ldb, info);
+ d__[1] = dabs(d__[1]);
+ }
+ return 0;
+ }
+
+/* Rotate the matrix if it is lower bidiagonal. */
+
+ if (*(unsigned char *)uplo == 'L') {
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ slartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
+ d__[i__] = r__;
+ e[i__] = sn * d__[i__ + 1];
+ d__[i__ + 1] = cs * d__[i__ + 1];
+ if (*nrhs == 1) {
+ csrot_(&c__1, &b[i__ + b_dim1], &c__1, &b[i__ + 1 + b_dim1], &
+ c__1, &cs, &sn);
+ } else {
+ rwork[(i__ << 1) - 1] = cs;
+ rwork[i__ * 2] = sn;
+ }
+/* L10: */
+ }
+ if (*nrhs > 1) {
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n - 1;
+ for (j = 1; j <= i__2; ++j) {
+ cs = rwork[(j << 1) - 1];
+ sn = rwork[j * 2];
+ csrot_(&c__1, &b[j + i__ * b_dim1], &c__1, &b[j + 1 + i__
+ * b_dim1], &c__1, &cs, &sn);
+/* L20: */
+ }
+/* L30: */
+ }
+ }
+ }
+
+/* Scale. */
+
+ nm1 = *n - 1;
+ orgnrm = slanst_("M", n, &d__[1], &e[1]);
+ if (orgnrm == 0.f) {
+ claset_("A", n, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+ return 0;
+ }
+
+ slascl_("G", &c__0, &c__0, &orgnrm, &c_b10, n, &c__1, &d__[1], n, info);
+ slascl_("G", &c__0, &c__0, &orgnrm, &c_b10, &nm1, &c__1, &e[1], &nm1,
+ info);
+
+/* If N is smaller than the minimum divide size SMLSIZ, then solve */
+/* the problem with another solver. */
+
+ if (*n <= *smlsiz) {
+ irwu = 1;
+ irwvt = irwu + *n * *n;
+ irwwrk = irwvt + *n * *n;
+ irwrb = irwwrk;
+ irwib = irwrb + *n * *nrhs;
+ irwb = irwib + *n * *nrhs;
+ slaset_("A", n, n, &c_b35, &c_b10, &rwork[irwu], n);
+ slaset_("A", n, n, &c_b35, &c_b10, &rwork[irwvt], n);
+ slasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &rwork[irwvt], n,
+ &rwork[irwu], n, &rwork[irwwrk], &c__1, &rwork[irwwrk], info);
+ if (*info != 0) {
+ return 0;
+ }
+
+/* In the real version, B is passed to SLASDQ and multiplied */
+/* internally by Q'. Here B is complex and that product is */
+/* computed below in two steps (real and imaginary parts). */
+
+ j = irwb - 1;
+ i__1 = *nrhs;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ i__2 = *n;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ ++j;
+ i__3 = jrow + jcol * b_dim1;
+ rwork[j] = b[i__3].r;
+/* L40: */
+ }
+/* L50: */
+ }
+ sgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwu], n, &rwork[irwb], n,
+ &c_b35, &rwork[irwrb], n);
+ j = irwb - 1;
+ i__1 = *nrhs;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ i__2 = *n;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ ++j;
+ rwork[j] = r_imag(&b[jrow + jcol * b_dim1]);
+/* L60: */
+ }
+/* L70: */
+ }
+ sgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwu], n, &rwork[irwb], n,
+ &c_b35, &rwork[irwib], n);
+ jreal = irwrb - 1;
+ jimag = irwib - 1;
+ i__1 = *nrhs;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ i__2 = *n;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ ++jreal;
+ ++jimag;
+ i__3 = jrow + jcol * b_dim1;
+ i__4 = jreal;
+ i__5 = jimag;
+ q__1.r = rwork[i__4], q__1.i = rwork[i__5];
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L80: */
+ }
+/* L90: */
+ }
+
+ tol = rcnd * (r__1 = d__[isamax_(n, &d__[1], &c__1)], dabs(r__1));
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (d__[i__] <= tol) {
+ claset_("A", &c__1, nrhs, &c_b1, &c_b1, &b[i__ + b_dim1], ldb);
+ } else {
+ clascl_("G", &c__0, &c__0, &d__[i__], &c_b10, &c__1, nrhs, &b[
+ i__ + b_dim1], ldb, info);
+ ++(*rank);
+ }
+/* L100: */
+ }
+
+/* Since B is complex, the following call to SGEMM is performed */
+/* in two steps (real and imaginary parts). That is for V * B */
+/* (in the real version of the code V' is stored in WORK). */
+
+/* CALL SGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO, */
+/* $ WORK( NWORK ), N ) */
+
+ j = irwb - 1;
+ i__1 = *nrhs;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ i__2 = *n;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ ++j;
+ i__3 = jrow + jcol * b_dim1;
+ rwork[j] = b[i__3].r;
+/* L110: */
+ }
+/* L120: */
+ }
+ sgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwvt], n, &rwork[irwb],
+ n, &c_b35, &rwork[irwrb], n);
+ j = irwb - 1;
+ i__1 = *nrhs;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ i__2 = *n;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ ++j;
+ rwork[j] = r_imag(&b[jrow + jcol * b_dim1]);
+/* L130: */
+ }
+/* L140: */
+ }
+ sgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwvt], n, &rwork[irwb],
+ n, &c_b35, &rwork[irwib], n);
+ jreal = irwrb - 1;
+ jimag = irwib - 1;
+ i__1 = *nrhs;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ i__2 = *n;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ ++jreal;
+ ++jimag;
+ i__3 = jrow + jcol * b_dim1;
+ i__4 = jreal;
+ i__5 = jimag;
+ q__1.r = rwork[i__4], q__1.i = rwork[i__5];
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L150: */
+ }
+/* L160: */
+ }
+
+/* Unscale. */
+
+ slascl_("G", &c__0, &c__0, &c_b10, &orgnrm, n, &c__1, &d__[1], n,
+ info);
+ slasrt_("D", n, &d__[1], info);
+ clascl_("G", &c__0, &c__0, &orgnrm, &c_b10, n, nrhs, &b[b_offset],
+ ldb, info);
+
+ return 0;
+ }
+
+/* Book-keeping and setting up some constants. */
+
+ nlvl = (integer) (log((real) (*n) / (real) (*smlsiz + 1)) / log(2.f)) + 1;
+
+ smlszp = *smlsiz + 1;
+
+ u = 1;
+ vt = *smlsiz * *n + 1;
+ difl = vt + smlszp * *n;
+ difr = difl + nlvl * *n;
+ z__ = difr + (nlvl * *n << 1);
+ c__ = z__ + nlvl * *n;
+ s = c__ + *n;
+ poles = s + *n;
+ givnum = poles + (nlvl << 1) * *n;
+ nrwork = givnum + (nlvl << 1) * *n;
+ bx = 1;
+
+ irwrb = nrwork;
+ irwib = irwrb + *smlsiz * *nrhs;
+ irwb = irwib + *smlsiz * *nrhs;
+
+ sizei = *n + 1;
+ k = sizei + *n;
+ givptr = k + *n;
+ perm = givptr + *n;
+ givcol = perm + nlvl * *n;
+ iwk = givcol + (nlvl * *n << 1);
+
+ st = 1;
+ sqre = 0;
+ icmpq1 = 1;
+ icmpq2 = 0;
+ nsub = 0;
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((r__1 = d__[i__], dabs(r__1)) < eps) {
+ d__[i__] = r_sign(&eps, &d__[i__]);
+ }
+/* L170: */
+ }
+
+ i__1 = nm1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((r__1 = e[i__], dabs(r__1)) < eps || i__ == nm1) {
+ ++nsub;
+ iwork[nsub] = st;
+
+/* Subproblem found. First determine its size and then */
+/* apply divide and conquer on it. */
+
+ if (i__ < nm1) {
+
+/* A subproblem with E(I) small for I < NM1. */
+
+ nsize = i__ - st + 1;
+ iwork[sizei + nsub - 1] = nsize;
+ } else if ((r__1 = e[i__], dabs(r__1)) >= eps) {
+
+/* A subproblem with E(NM1) not too small but I = NM1. */
+
+ nsize = *n - st + 1;
+ iwork[sizei + nsub - 1] = nsize;
+ } else {
+
+/* A subproblem with E(NM1) small. This implies an */
+/* 1-by-1 subproblem at D(N), which is not solved */
+/* explicitly. */
+
+ nsize = i__ - st + 1;
+ iwork[sizei + nsub - 1] = nsize;
+ ++nsub;
+ iwork[nsub] = *n;
+ iwork[sizei + nsub - 1] = 1;
+ ccopy_(nrhs, &b[*n + b_dim1], ldb, &work[bx + nm1], n);
+ }
+ st1 = st - 1;
+ if (nsize == 1) {
+
+/* This is a 1-by-1 subproblem and is not solved */
+/* explicitly. */
+
+ ccopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n);
+ } else if (nsize <= *smlsiz) {
+
+/* This is a small subproblem and is solved by SLASDQ. */
+
+ slaset_("A", &nsize, &nsize, &c_b35, &c_b10, &rwork[vt + st1],
+ n);
+ slaset_("A", &nsize, &nsize, &c_b35, &c_b10, &rwork[u + st1],
+ n);
+ slasdq_("U", &c__0, &nsize, &nsize, &nsize, &c__0, &d__[st], &
+ e[st], &rwork[vt + st1], n, &rwork[u + st1], n, &
+ rwork[nrwork], &c__1, &rwork[nrwork], info)
+ ;
+ if (*info != 0) {
+ return 0;
+ }
+
+/* In the real version, B is passed to SLASDQ and multiplied */
+/* internally by Q'. Here B is complex and that product is */
+/* computed below in two steps (real and imaginary parts). */
+
+ j = irwb - 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = st + nsize - 1;
+ for (jrow = st; jrow <= i__3; ++jrow) {
+ ++j;
+ i__4 = jrow + jcol * b_dim1;
+ rwork[j] = b[i__4].r;
+/* L180: */
+ }
+/* L190: */
+ }
+ sgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[u + st1]
+, n, &rwork[irwb], &nsize, &c_b35, &rwork[irwrb], &
+ nsize);
+ j = irwb - 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = st + nsize - 1;
+ for (jrow = st; jrow <= i__3; ++jrow) {
+ ++j;
+ rwork[j] = r_imag(&b[jrow + jcol * b_dim1]);
+/* L200: */
+ }
+/* L210: */
+ }
+ sgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[u + st1]
+, n, &rwork[irwb], &nsize, &c_b35, &rwork[irwib], &
+ nsize);
+ jreal = irwrb - 1;
+ jimag = irwib - 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = st + nsize - 1;
+ for (jrow = st; jrow <= i__3; ++jrow) {
+ ++jreal;
+ ++jimag;
+ i__4 = jrow + jcol * b_dim1;
+ i__5 = jreal;
+ i__6 = jimag;
+ q__1.r = rwork[i__5], q__1.i = rwork[i__6];
+ b[i__4].r = q__1.r, b[i__4].i = q__1.i;
+/* L220: */
+ }
+/* L230: */
+ }
+
+ clacpy_("A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx +
+ st1], n);
+ } else {
+
+/* A large problem. Solve it using divide and conquer. */
+
+ slasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], &
+ rwork[u + st1], n, &rwork[vt + st1], &iwork[k + st1],
+ &rwork[difl + st1], &rwork[difr + st1], &rwork[z__ +
+ st1], &rwork[poles + st1], &iwork[givptr + st1], &
+ iwork[givcol + st1], n, &iwork[perm + st1], &rwork[
+ givnum + st1], &rwork[c__ + st1], &rwork[s + st1], &
+ rwork[nrwork], &iwork[iwk], info);
+ if (*info != 0) {
+ return 0;
+ }
+ bxst = bx + st1;
+ clalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b[st + b_dim1], ldb, &
+ work[bxst], n, &rwork[u + st1], n, &rwork[vt + st1], &
+ iwork[k + st1], &rwork[difl + st1], &rwork[difr + st1]
+, &rwork[z__ + st1], &rwork[poles + st1], &iwork[
+ givptr + st1], &iwork[givcol + st1], n, &iwork[perm +
+ st1], &rwork[givnum + st1], &rwork[c__ + st1], &rwork[
+ s + st1], &rwork[nrwork], &iwork[iwk], info);
+ if (*info != 0) {
+ return 0;
+ }
+ }
+ st = i__ + 1;
+ }
+/* L240: */
+ }
+
+/* Apply the singular values and treat the tiny ones as zero. */
+
+ tol = rcnd * (r__1 = d__[isamax_(n, &d__[1], &c__1)], dabs(r__1));
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Some of the elements in D can be negative because 1-by-1 */
+/* subproblems were not solved explicitly. */
+
+ if ((r__1 = d__[i__], dabs(r__1)) <= tol) {
+ claset_("A", &c__1, nrhs, &c_b1, &c_b1, &work[bx + i__ - 1], n);
+ } else {
+ ++(*rank);
+ clascl_("G", &c__0, &c__0, &d__[i__], &c_b10, &c__1, nrhs, &work[
+ bx + i__ - 1], n, info);
+ }
+ d__[i__] = (r__1 = d__[i__], dabs(r__1));
+/* L250: */
+ }
+
+/* Now apply back the right singular vectors. */
+
+ icmpq2 = 1;
+ i__1 = nsub;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ st = iwork[i__];
+ st1 = st - 1;
+ nsize = iwork[sizei + i__ - 1];
+ bxst = bx + st1;
+ if (nsize == 1) {
+ ccopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb);
+ } else if (nsize <= *smlsiz) {
+
+/* Since B and BX are complex, the following call to SGEMM */
+/* is performed in two steps (real and imaginary parts). */
+
+/* CALL SGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE, */
+/* $ RWORK( VT+ST1 ), N, RWORK( BXST ), N, ZERO, */
+/* $ B( ST, 1 ), LDB ) */
+
+ j = bxst - *n - 1;
+ jreal = irwb - 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ j += *n;
+ i__3 = nsize;
+ for (jrow = 1; jrow <= i__3; ++jrow) {
+ ++jreal;
+ i__4 = j + jrow;
+ rwork[jreal] = work[i__4].r;
+/* L260: */
+ }
+/* L270: */
+ }
+ sgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[vt + st1],
+ n, &rwork[irwb], &nsize, &c_b35, &rwork[irwrb], &nsize);
+ j = bxst - *n - 1;
+ jimag = irwb - 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ j += *n;
+ i__3 = nsize;
+ for (jrow = 1; jrow <= i__3; ++jrow) {
+ ++jimag;
+ rwork[jimag] = r_imag(&work[j + jrow]);
+/* L280: */
+ }
+/* L290: */
+ }
+ sgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[vt + st1],
+ n, &rwork[irwb], &nsize, &c_b35, &rwork[irwib], &nsize);
+ jreal = irwrb - 1;
+ jimag = irwib - 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = st + nsize - 1;
+ for (jrow = st; jrow <= i__3; ++jrow) {
+ ++jreal;
+ ++jimag;
+ i__4 = jrow + jcol * b_dim1;
+ i__5 = jreal;
+ i__6 = jimag;
+ q__1.r = rwork[i__5], q__1.i = rwork[i__6];
+ b[i__4].r = q__1.r, b[i__4].i = q__1.i;
+/* L300: */
+ }
+/* L310: */
+ }
+ } else {
+ clalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b[st +
+ b_dim1], ldb, &rwork[u + st1], n, &rwork[vt + st1], &
+ iwork[k + st1], &rwork[difl + st1], &rwork[difr + st1], &
+ rwork[z__ + st1], &rwork[poles + st1], &iwork[givptr +
+ st1], &iwork[givcol + st1], n, &iwork[perm + st1], &rwork[
+ givnum + st1], &rwork[c__ + st1], &rwork[s + st1], &rwork[
+ nrwork], &iwork[iwk], info);
+ if (*info != 0) {
+ return 0;
+ }
+ }
+/* L320: */
+ }
+
+/* Unscale and sort the singular values. */
+
+ slascl_("G", &c__0, &c__0, &c_b10, &orgnrm, n, &c__1, &d__[1], n, info);
+ slasrt_("D", n, &d__[1], info);
+ clascl_("G", &c__0, &c__0, &orgnrm, &c_b10, n, nrhs, &b[b_offset], ldb,
+ info);
+
+ return 0;
+
+/* End of CLALSD */
+
+} /* clalsd_ */
diff --git a/SRC/clangb.c b/SRC/clangb.c
new file mode 100644
index 0000000..f192af5
--- /dev/null
+++ b/SRC/clangb.c
@@ -0,0 +1,224 @@
+/* clangb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal clangb_(char *norm, integer *n, integer *kl, integer *ku, complex *
+ ab, integer *ldab, real *work)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real ret_val, r__1, r__2;
+
+ /* Builtin functions */
+ double c_abs(complex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, l;
+ real sum, scale;
+ extern logical lsame_(char *, char *);
+ real value;
+ extern /* Subroutine */ int classq_(integer *, complex *, integer *, real
+ *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLANGB returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of an */
+/* n by n band matrix A, with kl sub-diagonals and ku super-diagonals. */
+
+/* Description */
+/* =========== */
+
+/* CLANGB returns the value */
+
+/* CLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in CLANGB as described */
+/* above. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, CLANGB is */
+/* set to zero. */
+
+/* KL (input) INTEGER */
+/* The number of sub-diagonals of the matrix A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of super-diagonals of the matrix A. KU >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* The band matrix A, stored in rows 1 to KL+KU+1. The j-th */
+/* column of A is stored in the j-th column of the array AB as */
+/* follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = *ku + 2 - j;
+/* Computing MIN */
+ i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1;
+ i__3 = min(i__4,i__5);
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&ab[i__ + j * ab_dim1]);
+ value = dmax(r__1,r__2);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.f;
+/* Computing MAX */
+ i__3 = *ku + 2 - j;
+/* Computing MIN */
+ i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1;
+ i__2 = min(i__4,i__5);
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+ sum += c_abs(&ab[i__ + j * ab_dim1]);
+/* L30: */
+ }
+ value = dmax(value,sum);
+/* L40: */
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L50: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ k = *ku + 1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *ku;
+/* Computing MIN */
+ i__5 = *n, i__6 = j + *kl;
+ i__4 = min(i__5,i__6);
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ work[i__] += c_abs(&ab[k + i__ + j * ab_dim1]);
+/* L60: */
+ }
+/* L70: */
+ }
+ value = 0.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = work[i__];
+ value = dmax(r__1,r__2);
+/* L80: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.f;
+ sum = 1.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *ku;
+ l = max(i__4,i__2);
+ k = *ku + 1 - j + l;
+/* Computing MIN */
+ i__2 = *n, i__3 = j + *kl;
+ i__4 = min(i__2,i__3) - l + 1;
+ classq_(&i__4, &ab[k + j * ab_dim1], &c__1, &scale, &sum);
+/* L90: */
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of CLANGB */
+
+} /* clangb_ */
diff --git a/SRC/clange.c b/SRC/clange.c
new file mode 100644
index 0000000..0530406
--- /dev/null
+++ b/SRC/clange.c
@@ -0,0 +1,199 @@
+/* clange.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal clange_(char *norm, integer *m, integer *n, complex *a, integer *
+ lda, real *work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real ret_val, r__1, r__2;
+
+ /* Builtin functions */
+ double c_abs(complex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ real sum, scale;
+ extern logical lsame_(char *, char *);
+ real value;
+ extern /* Subroutine */ int classq_(integer *, complex *, integer *, real
+ *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLANGE returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* complex matrix A. */
+
+/* Description */
+/* =========== */
+
+/* CLANGE returns the value */
+
+/* CLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in CLANGE as described */
+/* above. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. When M = 0, */
+/* CLANGE is set to zero. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. When N = 0, */
+/* CLANGE is set to zero. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(M,1). */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ if (min(*m,*n) == 0) {
+ value = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * a_dim1]);
+ value = dmax(r__1,r__2);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.f;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ sum += c_abs(&a[i__ + j * a_dim1]);
+/* L30: */
+ }
+ value = dmax(value,sum);
+/* L40: */
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L50: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += c_abs(&a[i__ + j * a_dim1]);
+/* L60: */
+ }
+/* L70: */
+ }
+ value = 0.f;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = work[i__];
+ value = dmax(r__1,r__2);
+/* L80: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.f;
+ sum = 1.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ classq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
+/* L90: */
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of CLANGE */
+
+} /* clange_ */
diff --git a/SRC/clangt.c b/SRC/clangt.c
new file mode 100644
index 0000000..ac8e57c
--- /dev/null
+++ b/SRC/clangt.c
@@ -0,0 +1,195 @@
+/* clangt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal clangt_(char *norm, integer *n, complex *dl, complex *d__, complex
+ *du)
+{
+ /* System generated locals */
+ integer i__1;
+ real ret_val, r__1, r__2;
+
+ /* Builtin functions */
+ double c_abs(complex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real sum, scale;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern /* Subroutine */ int classq_(integer *, complex *, integer *, real
+ *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLANGT returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* complex tridiagonal matrix A. */
+
+/* Description */
+/* =========== */
+
+/* CLANGT returns the value */
+
+/* CLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in CLANGT as described */
+/* above. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, CLANGT is */
+/* set to zero. */
+
+/* DL (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) sub-diagonal elements of A. */
+
+/* D (input) COMPLEX array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* DU (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) super-diagonal elements of A. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --du;
+ --d__;
+ --dl;
+
+ /* Function Body */
+ if (*n <= 0) {
+ anorm = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ anorm = c_abs(&d__[*n]);
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = anorm, r__2 = c_abs(&dl[i__]);
+ anorm = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = anorm, r__2 = c_abs(&d__[i__]);
+ anorm = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = anorm, r__2 = c_abs(&du[i__]);
+ anorm = dmax(r__1,r__2);
+/* L10: */
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ if (*n == 1) {
+ anorm = c_abs(&d__[1]);
+ } else {
+/* Computing MAX */
+ r__1 = c_abs(&d__[1]) + c_abs(&dl[1]), r__2 = c_abs(&d__[*n]) +
+ c_abs(&du[*n - 1]);
+ anorm = dmax(r__1,r__2);
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = anorm, r__2 = c_abs(&d__[i__]) + c_abs(&dl[i__]) +
+ c_abs(&du[i__ - 1]);
+ anorm = dmax(r__1,r__2);
+/* L20: */
+ }
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ if (*n == 1) {
+ anorm = c_abs(&d__[1]);
+ } else {
+/* Computing MAX */
+ r__1 = c_abs(&d__[1]) + c_abs(&du[1]), r__2 = c_abs(&d__[*n]) +
+ c_abs(&dl[*n - 1]);
+ anorm = dmax(r__1,r__2);
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = anorm, r__2 = c_abs(&d__[i__]) + c_abs(&du[i__]) +
+ c_abs(&dl[i__ - 1]);
+ anorm = dmax(r__1,r__2);
+/* L30: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.f;
+ sum = 1.f;
+ classq_(n, &d__[1], &c__1, &scale, &sum);
+ if (*n > 1) {
+ i__1 = *n - 1;
+ classq_(&i__1, &dl[1], &c__1, &scale, &sum);
+ i__1 = *n - 1;
+ classq_(&i__1, &du[1], &c__1, &scale, &sum);
+ }
+ anorm = scale * sqrt(sum);
+ }
+
+ ret_val = anorm;
+ return ret_val;
+
+/* End of CLANGT */
+
+} /* clangt_ */
diff --git a/SRC/clanhb.c b/SRC/clanhb.c
new file mode 100644
index 0000000..7305aed
--- /dev/null
+++ b/SRC/clanhb.c
@@ -0,0 +1,291 @@
+/* clanhb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal clanhb_(char *norm, char *uplo, integer *n, integer *k, complex *
+ ab, integer *ldab, real *work)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ real ret_val, r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double c_abs(complex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, l;
+ real sum, absa, scale;
+ extern logical lsame_(char *, char *);
+ real value;
+ extern /* Subroutine */ int classq_(integer *, complex *, integer *, real
+ *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLANHB returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of an */
+/* n by n hermitian band matrix A, with k super-diagonals. */
+
+/* Description */
+/* =========== */
+
+/* CLANHB returns the value */
+
+/* CLANHB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in CLANHB as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* band matrix A is supplied. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, CLANHB is */
+/* set to zero. */
+
+/* K (input) INTEGER */
+/* The number of super-diagonals or sub-diagonals of the */
+/* band matrix A. K >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* The upper or lower triangle of the hermitian band matrix A, */
+/* stored in the first K+1 rows of AB. The j-th column of A is */
+/* stored in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set and are assumed to be zero. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= K+1. */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
+/* WORK is not referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ i__3 = *k;
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&ab[i__ + j * ab_dim1]);
+ value = dmax(r__1,r__2);
+/* L10: */
+ }
+/* Computing MAX */
+ i__3 = *k + 1 + j * ab_dim1;
+ r__2 = value, r__3 = (r__1 = ab[i__3].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__3 = j * ab_dim1 + 1;
+ r__2 = value, r__3 = (r__1 = ab[i__3].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+/* Computing MIN */
+ i__2 = *n + 1 - j, i__4 = *k + 1;
+ i__3 = min(i__2,i__4);
+ for (i__ = 2; i__ <= i__3; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&ab[i__ + j * ab_dim1]);
+ value = dmax(r__1,r__2);
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
+
+/* Find normI(A) ( = norm1(A), since A is hermitian). */
+
+ value = 0.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.f;
+ l = *k + 1 - j;
+/* Computing MAX */
+ i__3 = 1, i__2 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__3,i__2); i__ <= i__4; ++i__) {
+ absa = c_abs(&ab[l + i__ + j * ab_dim1]);
+ sum += absa;
+ work[i__] += absa;
+/* L50: */
+ }
+ i__4 = *k + 1 + j * ab_dim1;
+ work[j] = sum + (r__1 = ab[i__4].r, dabs(r__1));
+/* L60: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = work[i__];
+ value = dmax(r__1,r__2);
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L80: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = j * ab_dim1 + 1;
+ sum = work[j] + (r__1 = ab[i__4].r, dabs(r__1));
+ l = 1 - j;
+/* Computing MIN */
+ i__3 = *n, i__2 = j + *k;
+ i__4 = min(i__3,i__2);
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ absa = c_abs(&ab[l + i__ + j * ab_dim1]);
+ sum += absa;
+ work[i__] += absa;
+/* L90: */
+ }
+ value = dmax(value,sum);
+/* L100: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.f;
+ sum = 1.f;
+ if (*k > 0) {
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j - 1;
+ i__4 = min(i__3,*k);
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ classq_(&i__4, &ab[max(i__2, 1)+ j * ab_dim1], &c__1, &
+ scale, &sum);
+/* L110: */
+ }
+ l = *k + 1;
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n - j;
+ i__4 = min(i__3,*k);
+ classq_(&i__4, &ab[j * ab_dim1 + 2], &c__1, &scale, &sum);
+/* L120: */
+ }
+ l = 1;
+ }
+ sum *= 2;
+ } else {
+ l = 1;
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = l + j * ab_dim1;
+ if (ab[i__4].r != 0.f) {
+ i__4 = l + j * ab_dim1;
+ absa = (r__1 = ab[i__4].r, dabs(r__1));
+ if (scale < absa) {
+/* Computing 2nd power */
+ r__1 = scale / absa;
+ sum = sum * (r__1 * r__1) + 1.f;
+ scale = absa;
+ } else {
+/* Computing 2nd power */
+ r__1 = absa / scale;
+ sum += r__1 * r__1;
+ }
+ }
+/* L130: */
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of CLANHB */
+
+} /* clanhb_ */
diff --git a/SRC/clanhe.c b/SRC/clanhe.c
new file mode 100644
index 0000000..9eae42c
--- /dev/null
+++ b/SRC/clanhe.c
@@ -0,0 +1,265 @@
+/* clanhe.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal clanhe_(char *norm, char *uplo, integer *n, complex *a, integer *
+ lda, real *work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real ret_val, r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double c_abs(complex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ real sum, absa, scale;
+ extern logical lsame_(char *, char *);
+ real value;
+ extern /* Subroutine */ int classq_(integer *, complex *, integer *, real
+ *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLANHE returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* complex hermitian matrix A. */
+
+/* Description */
+/* =========== */
+
+/* CLANHE returns the value */
+
+/* CLANHE = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in CLANHE as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* hermitian matrix A is to be referenced. */
+/* = 'U': Upper triangular part of A is referenced */
+/* = 'L': Lower triangular part of A is referenced */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, CLANHE is */
+/* set to zero. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The hermitian matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of A contains the upper triangular part */
+/* of the matrix A, and the strictly lower triangular part of A */
+/* is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of A contains the lower triangular part of */
+/* the matrix A, and the strictly upper triangular part of A is */
+/* not referenced. Note that the imaginary parts of the diagonal */
+/* elements need not be set and are assumed to be zero. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(N,1). */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
+/* WORK is not referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * a_dim1]);
+ value = dmax(r__1,r__2);
+/* L10: */
+ }
+/* Computing MAX */
+ i__2 = j + j * a_dim1;
+ r__2 = value, r__3 = (r__1 = a[i__2].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j + j * a_dim1;
+ r__2 = value, r__3 = (r__1 = a[i__2].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * a_dim1]);
+ value = dmax(r__1,r__2);
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
+
+/* Find normI(A) ( = norm1(A), since A is hermitian). */
+
+ value = 0.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.f;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ absa = c_abs(&a[i__ + j * a_dim1]);
+ sum += absa;
+ work[i__] += absa;
+/* L50: */
+ }
+ i__2 = j + j * a_dim1;
+ work[j] = sum + (r__1 = a[i__2].r, dabs(r__1));
+/* L60: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = work[i__];
+ value = dmax(r__1,r__2);
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L80: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * a_dim1;
+ sum = work[j] + (r__1 = a[i__2].r, dabs(r__1));
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ absa = c_abs(&a[i__ + j * a_dim1]);
+ sum += absa;
+ work[i__] += absa;
+/* L90: */
+ }
+ value = dmax(value,sum);
+/* L100: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.f;
+ sum = 1.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ classq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
+/* L110: */
+ }
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ classq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum);
+/* L120: */
+ }
+ }
+ sum *= 2;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ if (a[i__2].r != 0.f) {
+ i__2 = i__ + i__ * a_dim1;
+ absa = (r__1 = a[i__2].r, dabs(r__1));
+ if (scale < absa) {
+/* Computing 2nd power */
+ r__1 = scale / absa;
+ sum = sum * (r__1 * r__1) + 1.f;
+ scale = absa;
+ } else {
+/* Computing 2nd power */
+ r__1 = absa / scale;
+ sum += r__1 * r__1;
+ }
+ }
+/* L130: */
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of CLANHE */
+
+} /* clanhe_ */
diff --git a/SRC/clanhf.c b/SRC/clanhf.c
new file mode 100644
index 0000000..e598dae
--- /dev/null
+++ b/SRC/clanhf.c
@@ -0,0 +1,1803 @@
+/* clanhf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal clanhf_(char *norm, char *transr, char *uplo, integer *n, complex *
+ a, real *work)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real ret_val, r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double c_abs(complex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, l;
+ real s;
+ integer n1;
+ real aa;
+ integer lda, ifm, noe, ilu;
+ real scale;
+ extern logical lsame_(char *, char *);
+ real value;
+ extern integer isamax_(integer *, real *, integer *);
+ extern /* Subroutine */ int classq_(integer *, complex *, integer *, real
+ *, real *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLANHF returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* complex Hermitian matrix A in RFP format. */
+
+/* Description */
+/* =========== */
+
+/* CLANHF returns the value */
+
+/* CLANHF = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER */
+/* Specifies the value to be returned in CLANHF as described */
+/* above. */
+
+/* TRANSR (input) CHARACTER */
+/* Specifies whether the RFP format of A is normal or */
+/* conjugate-transposed format. */
+/* = 'N': RFP format is Normal */
+/* = 'C': RFP format is Conjugate-transposed */
+
+/* UPLO (input) CHARACTER */
+/* On entry, UPLO specifies whether the RFP matrix A came from */
+/* an upper or lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' RFP A came from an upper triangular */
+/* matrix */
+
+/* UPLO = 'L' or 'l' RFP A came from a lower triangular */
+/* matrix */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, CLANHF is */
+/* set to zero. */
+
+/* A (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ); */
+/* On entry, the matrix A in RFP Format. */
+/* RFP Format is described by TRANSR, UPLO and N as follows: */
+/* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even; */
+/* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If */
+/* TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A */
+/* as defined when TRANSR = 'N'. The contents of RFP A are */
+/* defined by UPLO as follows: If UPLO = 'U' the RFP A */
+/* contains the ( N*(N+1)/2 ) elements of upper packed A */
+/* either in normal or conjugate-transpose Format. If */
+/* UPLO = 'L' the RFP A contains the ( N*(N+1) /2 ) elements */
+/* of lower packed A either in normal or conjugate-transpose */
+/* Format. The LDA of RFP A is (N+1)/2 when TRANSR = 'C'. When */
+/* TRANSR is 'N' the LDA is N+1 when N is even and is N when */
+/* is odd. See the Note below for more details. */
+/* Unchanged on exit. */
+
+/* WORK (workspace) REAL array, dimension (LWORK), */
+/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
+/* WORK is not referenced. */
+
+/* Note: */
+/* ===== */
+
+/* We first consider Standard Packed Format when N is even. */
+/* We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* conjugate-transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* conjugate-transpose of the last three columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- -- */
+/* 03 04 05 33 43 53 */
+/* -- -- */
+/* 13 14 15 00 44 54 */
+/* -- */
+/* 23 24 25 10 11 55 */
+
+/* 33 34 35 20 21 22 */
+/* -- */
+/* 00 44 45 30 31 32 */
+/* -- -- */
+/* 01 11 55 40 41 42 */
+/* -- -- -- */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We next consider Standard Packed Format when N is odd. */
+/* We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* conjugate-transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* conjugate-transpose of the last two columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- */
+/* 02 03 04 00 33 43 */
+/* -- */
+/* 12 13 14 10 11 44 */
+
+/* 22 23 24 20 21 22 */
+/* -- */
+/* 00 33 34 30 31 32 */
+/* -- -- */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- */
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (*n == 0) {
+ ret_val = 0.f;
+ return ret_val;
+ }
+
+/* set noe = 1 if n is odd. if n is even set noe=0 */
+
+ noe = 1;
+ if (*n % 2 == 0) {
+ noe = 0;
+ }
+
+/* set ifm = 0 when form='C' or 'c' and 1 otherwise */
+
+ ifm = 1;
+ if (lsame_(transr, "C")) {
+ ifm = 0;
+ }
+
+/* set ilu = 0 when uplo='U or 'u' and 1 otherwise */
+
+ ilu = 1;
+ if (lsame_(uplo, "U")) {
+ ilu = 0;
+ }
+
+/* set lda = (n+1)/2 when ifm = 0 */
+/* set lda = n when ifm = 1 and noe = 1 */
+/* set lda = n+1 when ifm = 1 and noe = 0 */
+
+ if (ifm == 1) {
+ if (noe == 1) {
+ lda = *n;
+ } else {
+/* noe=0 */
+ lda = *n + 1;
+ }
+ } else {
+/* ifm=0 */
+ lda = (*n + 1) / 2;
+ }
+
+ if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ k = (*n + 1) / 2;
+ value = 0.f;
+ if (noe == 1) {
+/* n is odd & n = k + k - 1 */
+ if (ifm == 1) {
+/* A is n by k */
+ if (ilu == 1) {
+/* uplo ='L' */
+ j = 0;
+/* -> L(0,0) */
+/* Computing MAX */
+ i__1 = j + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__1].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 2;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ i__ = j - 1;
+/* L(k+j,k+j) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__2].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__ = j;
+/* -> L(j,j) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__2].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__2 = *n - 1;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ }
+ } else {
+/* uplo = 'U' */
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k + j - 2;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ i__ = k + j - 1;
+/* -> U(i,i) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__2].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ ++i__;
+/* =k+j; i -> U(j,j) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__2].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__2 = *n - 1;
+ for (i__ = k + j + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ }
+ i__1 = *n - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+/* j=k-1 */
+ }
+/* i=n-1 -> U(n-1,n-1) */
+/* Computing MAX */
+ i__1 = i__ + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__1].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ }
+ } else {
+/* xpose case; A is k by n */
+ if (ilu == 1) {
+/* uplo ='L' */
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ i__ = j;
+/* L(i,i) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__2].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__ = j + 1;
+/* L(j+k,j+k) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__2].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__2 = k - 1;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ }
+ j = k - 1;
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ i__ = k - 1;
+/* -> L(i,i) is at A(i,j) */
+/* Computing MAX */
+ i__1 = i__ + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__1].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ }
+ } else {
+/* uplo = 'U' */
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ }
+ j = k - 1;
+/* -> U(j,j) is at A(0,j) */
+/* Computing MAX */
+ i__1 = j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__1].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+ i__2 = j - k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ i__ = j - k;
+/* -> U(i,i) at A(i,j) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__2].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__ = j - k + 1;
+/* U(j,j) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__2].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__2 = k - 1;
+ for (i__ = j - k + 2; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ }
+ }
+ }
+ } else {
+/* n is even & k = n/2 */
+ if (ifm == 1) {
+/* A is n+1 by k */
+ if (ilu == 1) {
+/* uplo ='L' */
+ j = 0;
+/* -> L(k,k) & j=1 -> L(0,0) */
+/* Computing MAX */
+ i__1 = j + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__1].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+/* Computing MAX */
+ i__1 = j + 1 + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__1].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ i__ = j;
+/* L(k+j,k+j) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__2].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__ = j + 1;
+/* -> L(j,j) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__2].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__2 = *n;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ }
+ } else {
+/* uplo = 'U' */
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k + j - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ i__ = k + j;
+/* -> U(i,i) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__2].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ ++i__;
+/* =k+j+1; i -> U(j,j) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__2].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__2 = *n;
+ for (i__ = k + j + 2; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ }
+ i__1 = *n - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+/* j=k-1 */
+ }
+/* i=n-1 -> U(n-1,n-1) */
+/* Computing MAX */
+ i__1 = i__ + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__1].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__ = *n;
+/* -> U(k-1,k-1) */
+/* Computing MAX */
+ i__1 = i__ + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__1].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ }
+ } else {
+/* xpose case; A is k by n+1 */
+ if (ilu == 1) {
+/* uplo ='L' */
+ j = 0;
+/* -> L(k,k) at A(0,0) */
+/* Computing MAX */
+ i__1 = j + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__1].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 2;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ i__ = j - 1;
+/* L(i,i) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__2].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__ = j;
+/* L(j+k,j+k) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__2].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__2 = k - 1;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ }
+ j = k;
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ i__ = k - 1;
+/* -> L(i,i) is at A(i,j) */
+/* Computing MAX */
+ i__1 = i__ + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__1].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__1 = *n;
+ for (j = k + 1; j <= i__1; ++j) {
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ }
+ } else {
+/* uplo = 'U' */
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ }
+ j = k;
+/* -> U(j,j) is at A(0,j) */
+/* Computing MAX */
+ i__1 = j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__1].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ i__1 = *n - 1;
+ for (j = k + 1; j <= i__1; ++j) {
+ i__2 = j - k - 2;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ i__ = j - k - 1;
+/* -> U(i,i) at A(i,j) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__2].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__ = j - k;
+/* U(j,j) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__2].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__2 = k - 1;
+ for (i__ = j - k + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ }
+ j = *n;
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * lda]);
+ value = dmax(r__1,r__2);
+ }
+ i__ = k - 1;
+/* U(k,k) at A(i,j) */
+/* Computing MAX */
+ i__1 = i__ + j * lda;
+ r__2 = value, r__3 = (r__1 = a[i__1].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ }
+ }
+ }
+ } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
+
+/* Find normI(A) ( = norm1(A), since A is Hermitian). */
+
+ if (ifm == 1) {
+/* A is 'N' */
+ k = *n / 2;
+ if (noe == 1) {
+/* n is odd & A is n by (n+1)/2 */
+ if (ilu == 0) {
+/* uplo = 'U' */
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+ }
+ i__1 = k;
+ for (j = 0; j <= i__1; ++j) {
+ s = 0.f;
+ i__2 = k + j - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = c_abs(&a[i__ + j * lda]);
+/* -> A(i,j+k) */
+ s += aa;
+ work[i__] += aa;
+ }
+ i__2 = i__ + j * lda;
+ aa = (r__1 = a[i__2].r, dabs(r__1));
+/* -> A(j+k,j+k) */
+ work[j + k] = s + aa;
+ if (i__ == k + k) {
+ goto L10;
+ }
+ ++i__;
+ i__2 = i__ + j * lda;
+ aa = (r__1 = a[i__2].r, dabs(r__1));
+/* -> A(j,j) */
+ work[j] += aa;
+ s = 0.f;
+ i__2 = k - 1;
+ for (l = j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = c_abs(&a[i__ + j * lda]);
+/* -> A(l,j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[j] += s;
+ }
+L10:
+ i__ = isamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ } else {
+/* ilu = 1 & uplo = 'L' */
+ ++k;
+/* k=(n+1)/2 for n odd and ilu=1 */
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+ }
+ for (j = k - 1; j >= 0; --j) {
+ s = 0.f;
+ i__1 = j - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ aa = c_abs(&a[i__ + j * lda]);
+/* -> A(j+k,i+k) */
+ s += aa;
+ work[i__ + k] += aa;
+ }
+ if (j > 0) {
+ i__1 = i__ + j * lda;
+ aa = (r__1 = a[i__1].r, dabs(r__1));
+/* -> A(j+k,j+k) */
+ s += aa;
+ work[i__ + k] += s;
+/* i=j */
+ ++i__;
+ }
+ i__1 = i__ + j * lda;
+ aa = (r__1 = a[i__1].r, dabs(r__1));
+/* -> A(j,j) */
+ work[j] = aa;
+ s = 0.f;
+ i__1 = *n - 1;
+ for (l = j + 1; l <= i__1; ++l) {
+ ++i__;
+ aa = c_abs(&a[i__ + j * lda]);
+/* -> A(l,j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[j] += s;
+ }
+ i__ = isamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ }
+ } else {
+/* n is even & A is n+1 by k = n/2 */
+ if (ilu == 0) {
+/* uplo = 'U' */
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+ }
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ s = 0.f;
+ i__2 = k + j - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = c_abs(&a[i__ + j * lda]);
+/* -> A(i,j+k) */
+ s += aa;
+ work[i__] += aa;
+ }
+ i__2 = i__ + j * lda;
+ aa = (r__1 = a[i__2].r, dabs(r__1));
+/* -> A(j+k,j+k) */
+ work[j + k] = s + aa;
+ ++i__;
+ i__2 = i__ + j * lda;
+ aa = (r__1 = a[i__2].r, dabs(r__1));
+/* -> A(j,j) */
+ work[j] += aa;
+ s = 0.f;
+ i__2 = k - 1;
+ for (l = j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = c_abs(&a[i__ + j * lda]);
+/* -> A(l,j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[j] += s;
+ }
+ i__ = isamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ } else {
+/* ilu = 1 & uplo = 'L' */
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+ }
+ for (j = k - 1; j >= 0; --j) {
+ s = 0.f;
+ i__1 = j - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ aa = c_abs(&a[i__ + j * lda]);
+/* -> A(j+k,i+k) */
+ s += aa;
+ work[i__ + k] += aa;
+ }
+ i__1 = i__ + j * lda;
+ aa = (r__1 = a[i__1].r, dabs(r__1));
+/* -> A(j+k,j+k) */
+ s += aa;
+ work[i__ + k] += s;
+/* i=j */
+ ++i__;
+ i__1 = i__ + j * lda;
+ aa = (r__1 = a[i__1].r, dabs(r__1));
+/* -> A(j,j) */
+ work[j] = aa;
+ s = 0.f;
+ i__1 = *n - 1;
+ for (l = j + 1; l <= i__1; ++l) {
+ ++i__;
+ aa = c_abs(&a[i__ + j * lda]);
+/* -> A(l,j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[j] += s;
+ }
+ i__ = isamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ }
+ }
+ } else {
+/* ifm=0 */
+ k = *n / 2;
+ if (noe == 1) {
+/* n is odd & A is (n+1)/2 by n */
+ if (ilu == 0) {
+/* uplo = 'U' */
+ n1 = k;
+/* n/2 */
+ ++k;
+/* k is the row size and lda */
+ i__1 = *n - 1;
+ for (i__ = n1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+ }
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ s = 0.f;
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = c_abs(&a[i__ + j * lda]);
+/* A(j,n1+i) */
+ work[i__ + n1] += aa;
+ s += aa;
+ }
+ work[j] = s;
+ }
+/* j=n1=k-1 is special */
+ i__1 = j * lda;
+ s = (r__1 = a[i__1].r, dabs(r__1));
+/* A(k-1,k-1) */
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ aa = c_abs(&a[i__ + j * lda]);
+/* A(k-1,i+n1) */
+ work[i__ + n1] += aa;
+ s += aa;
+ }
+ work[j] += s;
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+ s = 0.f;
+ i__2 = j - k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = c_abs(&a[i__ + j * lda]);
+/* A(i,j-k) */
+ work[i__] += aa;
+ s += aa;
+ }
+/* i=j-k */
+ i__2 = i__ + j * lda;
+ aa = (r__1 = a[i__2].r, dabs(r__1));
+/* A(j-k,j-k) */
+ s += aa;
+ work[j - k] += s;
+ ++i__;
+ i__2 = i__ + j * lda;
+ s = (r__1 = a[i__2].r, dabs(r__1));
+/* A(j,j) */
+ i__2 = *n - 1;
+ for (l = j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = c_abs(&a[i__ + j * lda]);
+/* A(j,l) */
+ work[l] += aa;
+ s += aa;
+ }
+ work[j] += s;
+ }
+ i__ = isamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ } else {
+/* ilu=1 & uplo = 'L' */
+ ++k;
+/* k=(n+1)/2 for n odd and ilu=1 */
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+/* process */
+ s = 0.f;
+ i__2 = j - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = c_abs(&a[i__ + j * lda]);
+/* A(j,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+ i__2 = i__ + j * lda;
+ aa = (r__1 = a[i__2].r, dabs(r__1));
+/* i=j so process of A(j,j) */
+ s += aa;
+ work[j] = s;
+/* is initialised here */
+ ++i__;
+/* i=j process A(j+k,j+k) */
+ i__2 = i__ + j * lda;
+ aa = (r__1 = a[i__2].r, dabs(r__1));
+ s = aa;
+ i__2 = *n - 1;
+ for (l = k + j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = c_abs(&a[i__ + j * lda]);
+/* A(l,k+j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[k + j] += s;
+ }
+/* j=k-1 is special :process col A(k-1,0:k-1) */
+ s = 0.f;
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ aa = c_abs(&a[i__ + j * lda]);
+/* A(k,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+/* i=k-1 */
+ i__1 = i__ + j * lda;
+ aa = (r__1 = a[i__1].r, dabs(r__1));
+/* A(k-1,k-1) */
+ s += aa;
+ work[i__] = s;
+/* done with col j=k+1 */
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+/* process col j of A = A(j,0:k-1) */
+ s = 0.f;
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = c_abs(&a[i__ + j * lda]);
+/* A(j,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+ work[j] += s;
+ }
+ i__ = isamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ }
+ } else {
+/* n is even & A is k=n/2 by n+1 */
+ if (ilu == 0) {
+/* uplo = 'U' */
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+ }
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ s = 0.f;
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = c_abs(&a[i__ + j * lda]);
+/* A(j,i+k) */
+ work[i__ + k] += aa;
+ s += aa;
+ }
+ work[j] = s;
+ }
+/* j=k */
+ i__1 = j * lda;
+ aa = (r__1 = a[i__1].r, dabs(r__1));
+/* A(k,k) */
+ s = aa;
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ aa = c_abs(&a[i__ + j * lda]);
+/* A(k,k+i) */
+ work[i__ + k] += aa;
+ s += aa;
+ }
+ work[j] += s;
+ i__1 = *n - 1;
+ for (j = k + 1; j <= i__1; ++j) {
+ s = 0.f;
+ i__2 = j - 2 - k;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = c_abs(&a[i__ + j * lda]);
+/* A(i,j-k-1) */
+ work[i__] += aa;
+ s += aa;
+ }
+/* i=j-1-k */
+ i__2 = i__ + j * lda;
+ aa = (r__1 = a[i__2].r, dabs(r__1));
+/* A(j-k-1,j-k-1) */
+ s += aa;
+ work[j - k - 1] += s;
+ ++i__;
+ i__2 = i__ + j * lda;
+ aa = (r__1 = a[i__2].r, dabs(r__1));
+/* A(j,j) */
+ s = aa;
+ i__2 = *n - 1;
+ for (l = j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = c_abs(&a[i__ + j * lda]);
+/* A(j,l) */
+ work[l] += aa;
+ s += aa;
+ }
+ work[j] += s;
+ }
+/* j=n */
+ s = 0.f;
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ aa = c_abs(&a[i__ + j * lda]);
+/* A(i,k-1) */
+ work[i__] += aa;
+ s += aa;
+ }
+/* i=k-1 */
+ i__1 = i__ + j * lda;
+ aa = (r__1 = a[i__1].r, dabs(r__1));
+/* A(k-1,k-1) */
+ s += aa;
+ work[i__] += s;
+ i__ = isamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ } else {
+/* ilu=1 & uplo = 'L' */
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+ }
+/* j=0 is special :process col A(k:n-1,k) */
+ s = (r__1 = a[0].r, dabs(r__1));
+/* A(k,k) */
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ aa = c_abs(&a[i__]);
+/* A(k+i,k) */
+ work[i__ + k] += aa;
+ s += aa;
+ }
+ work[k] += s;
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* process */
+ s = 0.f;
+ i__2 = j - 2;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = c_abs(&a[i__ + j * lda]);
+/* A(j-1,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+ i__2 = i__ + j * lda;
+ aa = (r__1 = a[i__2].r, dabs(r__1));
+/* i=j-1 so process of A(j-1,j-1) */
+ s += aa;
+ work[j - 1] = s;
+/* is initialised here */
+ ++i__;
+/* i=j process A(j+k,j+k) */
+ i__2 = i__ + j * lda;
+ aa = (r__1 = a[i__2].r, dabs(r__1));
+ s = aa;
+ i__2 = *n - 1;
+ for (l = k + j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = c_abs(&a[i__ + j * lda]);
+/* A(l,k+j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[k + j] += s;
+ }
+/* j=k is special :process col A(k,0:k-1) */
+ s = 0.f;
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ aa = c_abs(&a[i__ + j * lda]);
+/* A(k,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+
+/* i=k-1 */
+ i__1 = i__ + j * lda;
+ aa = (r__1 = a[i__1].r, dabs(r__1));
+/* A(k-1,k-1) */
+ s += aa;
+ work[i__] = s;
+/* done with col j=k+1 */
+ i__1 = *n;
+ for (j = k + 1; j <= i__1; ++j) {
+
+/* process col j-1 of A = A(j-1,0:k-1) */
+ s = 0.f;
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = c_abs(&a[i__ + j * lda]);
+/* A(j-1,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+ work[j - 1] += s;
+ }
+ i__ = isamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ }
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ k = (*n + 1) / 2;
+ scale = 0.f;
+ s = 1.f;
+ if (noe == 1) {
+/* n is odd */
+ if (ifm == 1) {
+/* A is normal & A is n by k */
+ if (ilu == 0) {
+/* A is upper */
+ i__1 = k - 3;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 2;
+ classq_(&i__2, &a[k + j + 1 + j * lda], &c__1, &scale,
+ &s);
+/* L at A(k,0) */
+ }
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k + j - 1;
+ classq_(&i__2, &a[j * lda], &c__1, &scale, &s);
+/* trap U at A(0,0) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ l = k - 1;
+/* -> U(k,k) at A(k-1,0) */
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = l;
+ aa = a[i__2].r;
+/* U(k+i,k+i) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ i__2 = l + 1;
+ aa = a[i__2].r;
+/* U(i,i) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ l = l + lda + 1;
+ }
+ i__1 = l;
+ aa = a[i__1].r;
+/* U(n-1,n-1) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ } else {
+/* ilu=1 & A is lower */
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - j - 1;
+ classq_(&i__2, &a[j + 1 + j * lda], &c__1, &scale, &s)
+ ;
+/* trap L at A(0,0) */
+ }
+ i__1 = k - 2;
+ for (j = 1; j <= i__1; ++j) {
+ classq_(&j, &a[(j + 1) * lda], &c__1, &scale, &s);
+/* U at A(0,1) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ aa = a[0].r;
+/* L(0,0) at A(0,0) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ l = lda;
+/* -> L(k,k) at A(0,1) */
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = l;
+ aa = a[i__2].r;
+/* L(k-1+i,k-1+i) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ i__2 = l + 1;
+ aa = a[i__2].r;
+/* L(i,i) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ l = l + lda + 1;
+ }
+ }
+ } else {
+/* A is xpose & A is k by n */
+ if (ilu == 0) {
+/* A' is upper */
+ i__1 = k - 2;
+ for (j = 1; j <= i__1; ++j) {
+ classq_(&j, &a[(k + j) * lda], &c__1, &scale, &s);
+/* U at A(0,k) */
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ classq_(&k, &a[j * lda], &c__1, &scale, &s);
+/* k by k-1 rect. at A(0,0) */
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 1;
+ classq_(&i__2, &a[j + 1 + (j + k - 1) * lda], &c__1, &
+ scale, &s);
+/* L at A(0,k-1) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ l = k * lda - lda;
+/* -> U(k-1,k-1) at A(0,k-1) */
+ i__1 = l;
+ aa = a[i__1].r;
+/* U(k-1,k-1) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ l += lda;
+/* -> U(0,0) at A(0,k) */
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+ i__2 = l;
+ aa = a[i__2].r;
+/* -> U(j-k,j-k) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ i__2 = l + 1;
+ aa = a[i__2].r;
+/* -> U(j,j) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ l = l + lda + 1;
+ }
+ } else {
+/* A' is lower */
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ classq_(&j, &a[j * lda], &c__1, &scale, &s);
+/* U at A(0,0) */
+ }
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+ classq_(&k, &a[j * lda], &c__1, &scale, &s);
+/* k by k-1 rect. at A(0,k) */
+ }
+ i__1 = k - 3;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 2;
+ classq_(&i__2, &a[j + 2 + j * lda], &c__1, &scale, &s)
+ ;
+/* L at A(1,0) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ l = 0;
+/* -> L(0,0) at A(0,0) */
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = l;
+ aa = a[i__2].r;
+/* L(i,i) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ i__2 = l + 1;
+ aa = a[i__2].r;
+/* L(k+i,k+i) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ l = l + lda + 1;
+ }
+/* L-> k-1 + (k-1)*lda or L(k-1,k-1) at A(k-1,k-1) */
+ i__1 = l;
+ aa = a[i__1].r;
+/* L(k-1,k-1) at A(k-1,k-1) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ }
+ }
+ } else {
+/* n is even */
+ if (ifm == 1) {
+/* A is normal */
+ if (ilu == 0) {
+/* A is upper */
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 1;
+ classq_(&i__2, &a[k + j + 2 + j * lda], &c__1, &scale,
+ &s);
+/* L at A(k+1,0) */
+ }
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k + j;
+ classq_(&i__2, &a[j * lda], &c__1, &scale, &s);
+/* trap U at A(0,0) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ l = k;
+/* -> U(k,k) at A(k,0) */
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = l;
+ aa = a[i__2].r;
+/* U(k+i,k+i) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ i__2 = l + 1;
+ aa = a[i__2].r;
+/* U(i,i) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ l = l + lda + 1;
+ }
+ } else {
+/* ilu=1 & A is lower */
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - j - 1;
+ classq_(&i__2, &a[j + 2 + j * lda], &c__1, &scale, &s)
+ ;
+/* trap L at A(1,0) */
+ }
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ classq_(&j, &a[j * lda], &c__1, &scale, &s);
+/* U at A(0,0) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ l = 0;
+/* -> L(k,k) at A(0,0) */
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = l;
+ aa = a[i__2].r;
+/* L(k-1+i,k-1+i) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ i__2 = l + 1;
+ aa = a[i__2].r;
+/* L(i,i) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ l = l + lda + 1;
+ }
+ }
+ } else {
+/* A is xpose */
+ if (ilu == 0) {
+/* A' is upper */
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ classq_(&j, &a[(k + 1 + j) * lda], &c__1, &scale, &s);
+/* U at A(0,k+1) */
+ }
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ classq_(&k, &a[j * lda], &c__1, &scale, &s);
+/* k by k rect. at A(0,0) */
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 1;
+ classq_(&i__2, &a[j + 1 + (j + k) * lda], &c__1, &
+ scale, &s);
+/* L at A(0,k) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ l = k * lda;
+/* -> U(k,k) at A(0,k) */
+ i__1 = l;
+ aa = a[i__1].r;
+/* U(k,k) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ l += lda;
+/* -> U(0,0) at A(0,k+1) */
+ i__1 = *n - 1;
+ for (j = k + 1; j <= i__1; ++j) {
+ i__2 = l;
+ aa = a[i__2].r;
+/* -> U(j-k-1,j-k-1) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ i__2 = l + 1;
+ aa = a[i__2].r;
+/* -> U(j,j) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ l = l + lda + 1;
+ }
+/* L=k-1+n*lda */
+/* -> U(k-1,k-1) at A(k-1,n) */
+ i__1 = l;
+ aa = a[i__1].r;
+/* U(k,k) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ } else {
+/* A' is lower */
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ classq_(&j, &a[(j + 1) * lda], &c__1, &scale, &s);
+/* U at A(0,1) */
+ }
+ i__1 = *n;
+ for (j = k + 1; j <= i__1; ++j) {
+ classq_(&k, &a[j * lda], &c__1, &scale, &s);
+/* k by k rect. at A(0,k+1) */
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 1;
+ classq_(&i__2, &a[j + 1 + j * lda], &c__1, &scale, &s)
+ ;
+/* L at A(0,0) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ l = 0;
+/* -> L(k,k) at A(0,0) */
+ i__1 = l;
+ aa = a[i__1].r;
+/* L(k,k) at A(0,0) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ l = lda;
+/* -> L(0,0) at A(0,1) */
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = l;
+ aa = a[i__2].r;
+/* L(i,i) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ i__2 = l + 1;
+ aa = a[i__2].r;
+/* L(k+i+1,k+i+1) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ l = l + lda + 1;
+ }
+/* L-> k - 1 + k*lda or L(k-1,k-1) at A(k-1,k) */
+ i__1 = l;
+ aa = a[i__1].r;
+/* L(k-1,k-1) at A(k-1,k) */
+ if (aa != 0.f) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ r__1 = scale / aa;
+ s = s * (r__1 * r__1) + 1.f;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ r__1 = aa / scale;
+ s += r__1 * r__1;
+ }
+ }
+ }
+ }
+ }
+ value = scale * sqrt(s);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of CLANHF */
+
+} /* clanhf_ */
diff --git a/SRC/clanhp.c b/SRC/clanhp.c
new file mode 100644
index 0000000..824b178
--- /dev/null
+++ b/SRC/clanhp.c
@@ -0,0 +1,277 @@
+/* clanhp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal clanhp_(char *norm, char *uplo, integer *n, complex *ap, real *
+ work)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real ret_val, r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double c_abs(complex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ real sum, absa, scale;
+ extern logical lsame_(char *, char *);
+ real value;
+ extern /* Subroutine */ int classq_(integer *, complex *, integer *, real
+ *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLANHP returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* complex hermitian matrix A, supplied in packed form. */
+
+/* Description */
+/* =========== */
+
+/* CLANHP returns the value */
+
+/* CLANHP = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in CLANHP as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* hermitian matrix A is supplied. */
+/* = 'U': Upper triangular part of A is supplied */
+/* = 'L': Lower triangular part of A is supplied */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, CLANHP is */
+/* set to zero. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the hermitian matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set and are assumed to be zero. */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
+/* WORK is not referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --ap;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.f;
+ if (lsame_(uplo, "U")) {
+ k = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j - 1;
+ for (i__ = k + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&ap[i__]);
+ value = dmax(r__1,r__2);
+/* L10: */
+ }
+ k += j;
+/* Computing MAX */
+ i__2 = k;
+ r__2 = value, r__3 = (r__1 = ap[i__2].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+/* L20: */
+ }
+ } else {
+ k = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = k;
+ r__2 = value, r__3 = (r__1 = ap[i__2].r, dabs(r__1));
+ value = dmax(r__2,r__3);
+ i__2 = k + *n - j;
+ for (i__ = k + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&ap[i__]);
+ value = dmax(r__1,r__2);
+/* L30: */
+ }
+ k = k + *n - j + 1;
+/* L40: */
+ }
+ }
+ } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
+
+/* Find normI(A) ( = norm1(A), since A is hermitian). */
+
+ value = 0.f;
+ k = 1;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.f;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ absa = c_abs(&ap[k]);
+ sum += absa;
+ work[i__] += absa;
+ ++k;
+/* L50: */
+ }
+ i__2 = k;
+ work[j] = sum + (r__1 = ap[i__2].r, dabs(r__1));
+ ++k;
+/* L60: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = work[i__];
+ value = dmax(r__1,r__2);
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L80: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k;
+ sum = work[j] + (r__1 = ap[i__2].r, dabs(r__1));
+ ++k;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ absa = c_abs(&ap[k]);
+ sum += absa;
+ work[i__] += absa;
+ ++k;
+/* L90: */
+ }
+ value = dmax(value,sum);
+/* L100: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.f;
+ sum = 1.f;
+ k = 2;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ classq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k += j;
+/* L110: */
+ }
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ classq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k = k + *n - j + 1;
+/* L120: */
+ }
+ }
+ sum *= 2;
+ k = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = k;
+ if (ap[i__2].r != 0.f) {
+ i__2 = k;
+ absa = (r__1 = ap[i__2].r, dabs(r__1));
+ if (scale < absa) {
+/* Computing 2nd power */
+ r__1 = scale / absa;
+ sum = sum * (r__1 * r__1) + 1.f;
+ scale = absa;
+ } else {
+/* Computing 2nd power */
+ r__1 = absa / scale;
+ sum += r__1 * r__1;
+ }
+ }
+ if (lsame_(uplo, "U")) {
+ k = k + i__ + 1;
+ } else {
+ k = k + *n - i__ + 1;
+ }
+/* L130: */
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of CLANHP */
+
+} /* clanhp_ */
diff --git a/SRC/clanhs.c b/SRC/clanhs.c
new file mode 100644
index 0000000..850ca81
--- /dev/null
+++ b/SRC/clanhs.c
@@ -0,0 +1,205 @@
+/* clanhs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal clanhs_(char *norm, integer *n, complex *a, integer *lda, real *
+ work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ real ret_val, r__1, r__2;
+
+ /* Builtin functions */
+ double c_abs(complex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ real sum, scale;
+ extern logical lsame_(char *, char *);
+ real value;
+ extern /* Subroutine */ int classq_(integer *, complex *, integer *, real
+ *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLANHS returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* Hessenberg matrix A. */
+
+/* Description */
+/* =========== */
+
+/* CLANHS returns the value */
+
+/* CLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in CLANHS as described */
+/* above. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, CLANHS is */
+/* set to zero. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The n by n upper Hessenberg matrix A; the part of A below the */
+/* first sub-diagonal is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(N,1). */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n, i__4 = j + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * a_dim1]);
+ value = dmax(r__1,r__2);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.f;
+/* Computing MIN */
+ i__3 = *n, i__4 = j + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ sum += c_abs(&a[i__ + j * a_dim1]);
+/* L30: */
+ }
+ value = dmax(value,sum);
+/* L40: */
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L50: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n, i__4 = j + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += c_abs(&a[i__ + j * a_dim1]);
+/* L60: */
+ }
+/* L70: */
+ }
+ value = 0.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = work[i__];
+ value = dmax(r__1,r__2);
+/* L80: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.f;
+ sum = 1.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n, i__4 = j + 1;
+ i__2 = min(i__3,i__4);
+ classq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
+/* L90: */
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of CLANHS */
+
+} /* clanhs_ */
diff --git a/SRC/clanht.c b/SRC/clanht.c
new file mode 100644
index 0000000..834e68f
--- /dev/null
+++ b/SRC/clanht.c
@@ -0,0 +1,166 @@
+/* clanht.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal clanht_(char *norm, integer *n, real *d__, complex *e)
+{
+ /* System generated locals */
+ integer i__1;
+ real ret_val, r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double c_abs(complex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real sum, scale;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern /* Subroutine */ int classq_(integer *, complex *, integer *, real
+ *, real *), slassq_(integer *, real *, integer *, real *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLANHT returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* complex Hermitian tridiagonal matrix A. */
+
+/* Description */
+/* =========== */
+
+/* CLANHT returns the value */
+
+/* CLANHT = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in CLANHT as described */
+/* above. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, CLANHT is */
+/* set to zero. */
+
+/* D (input) REAL array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* E (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) sub-diagonal or super-diagonal elements of A. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --e;
+ --d__;
+
+ /* Function Body */
+ if (*n <= 0) {
+ anorm = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ anorm = (r__1 = d__[*n], dabs(r__1));
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = anorm, r__3 = (r__1 = d__[i__], dabs(r__1));
+ anorm = dmax(r__2,r__3);
+/* Computing MAX */
+ r__1 = anorm, r__2 = c_abs(&e[i__]);
+ anorm = dmax(r__1,r__2);
+/* L10: */
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1' || lsame_(norm, "I")) {
+
+/* Find norm1(A). */
+
+ if (*n == 1) {
+ anorm = dabs(d__[1]);
+ } else {
+/* Computing MAX */
+ r__2 = dabs(d__[1]) + c_abs(&e[1]), r__3 = c_abs(&e[*n - 1]) + (
+ r__1 = d__[*n], dabs(r__1));
+ anorm = dmax(r__2,r__3);
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = anorm, r__3 = (r__1 = d__[i__], dabs(r__1)) + c_abs(&e[
+ i__]) + c_abs(&e[i__ - 1]);
+ anorm = dmax(r__2,r__3);
+/* L20: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.f;
+ sum = 1.f;
+ if (*n > 1) {
+ i__1 = *n - 1;
+ classq_(&i__1, &e[1], &c__1, &scale, &sum);
+ sum *= 2;
+ }
+ slassq_(n, &d__[1], &c__1, &scale, &sum);
+ anorm = scale * sqrt(sum);
+ }
+
+ ret_val = anorm;
+ return ret_val;
+
+/* End of CLANHT */
+
+} /* clanht_ */
diff --git a/SRC/clansb.c b/SRC/clansb.c
new file mode 100644
index 0000000..fa0c885
--- /dev/null
+++ b/SRC/clansb.c
@@ -0,0 +1,261 @@
+/* clansb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal clansb_(char *norm, char *uplo, integer *n, integer *k, complex *
+ ab, integer *ldab, real *work)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ real ret_val, r__1, r__2;
+
+ /* Builtin functions */
+ double c_abs(complex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, l;
+ real sum, absa, scale;
+ extern logical lsame_(char *, char *);
+ real value;
+ extern /* Subroutine */ int classq_(integer *, complex *, integer *, real
+ *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLANSB returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of an */
+/* n by n symmetric band matrix A, with k super-diagonals. */
+
+/* Description */
+/* =========== */
+
+/* CLANSB returns the value */
+
+/* CLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in CLANSB as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* band matrix A is supplied. */
+/* = 'U': Upper triangular part is supplied */
+/* = 'L': Lower triangular part is supplied */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, CLANSB is */
+/* set to zero. */
+
+/* K (input) INTEGER */
+/* The number of super-diagonals or sub-diagonals of the */
+/* band matrix A. K >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* The upper or lower triangle of the symmetric band matrix A, */
+/* stored in the first K+1 rows of AB. The j-th column of A is */
+/* stored in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= K+1. */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
+/* WORK is not referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ i__3 = *k + 1;
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&ab[i__ + j * ab_dim1]);
+ value = dmax(r__1,r__2);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *n + 1 - j, i__4 = *k + 1;
+ i__3 = min(i__2,i__4);
+ for (i__ = 1; i__ <= i__3; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&ab[i__ + j * ab_dim1]);
+ value = dmax(r__1,r__2);
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
+
+/* Find normI(A) ( = norm1(A), since A is symmetric). */
+
+ value = 0.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.f;
+ l = *k + 1 - j;
+/* Computing MAX */
+ i__3 = 1, i__2 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__3,i__2); i__ <= i__4; ++i__) {
+ absa = c_abs(&ab[l + i__ + j * ab_dim1]);
+ sum += absa;
+ work[i__] += absa;
+/* L50: */
+ }
+ work[j] = sum + c_abs(&ab[*k + 1 + j * ab_dim1]);
+/* L60: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = work[i__];
+ value = dmax(r__1,r__2);
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L80: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = work[j] + c_abs(&ab[j * ab_dim1 + 1]);
+ l = 1 - j;
+/* Computing MIN */
+ i__3 = *n, i__2 = j + *k;
+ i__4 = min(i__3,i__2);
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ absa = c_abs(&ab[l + i__ + j * ab_dim1]);
+ sum += absa;
+ work[i__] += absa;
+/* L90: */
+ }
+ value = dmax(value,sum);
+/* L100: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.f;
+ sum = 1.f;
+ if (*k > 0) {
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j - 1;
+ i__4 = min(i__3,*k);
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ classq_(&i__4, &ab[max(i__2, 1)+ j * ab_dim1], &c__1, &
+ scale, &sum);
+/* L110: */
+ }
+ l = *k + 1;
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n - j;
+ i__4 = min(i__3,*k);
+ classq_(&i__4, &ab[j * ab_dim1 + 2], &c__1, &scale, &sum);
+/* L120: */
+ }
+ l = 1;
+ }
+ sum *= 2;
+ } else {
+ l = 1;
+ }
+ classq_(n, &ab[l + ab_dim1], ldab, &scale, &sum);
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of CLANSB */
+
+} /* clansb_ */
diff --git a/SRC/clansp.c b/SRC/clansp.c
new file mode 100644
index 0000000..906ea81
--- /dev/null
+++ b/SRC/clansp.c
@@ -0,0 +1,278 @@
+/* clansp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal clansp_(char *norm, char *uplo, integer *n, complex *ap, real *
+ work)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real ret_val, r__1, r__2;
+
+ /* Builtin functions */
+ double c_abs(complex *), r_imag(complex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ real sum, absa, scale;
+ extern logical lsame_(char *, char *);
+ real value;
+ extern /* Subroutine */ int classq_(integer *, complex *, integer *, real
+ *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLANSP returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* complex symmetric matrix A, supplied in packed form. */
+
+/* Description */
+/* =========== */
+
+/* CLANSP returns the value */
+
+/* CLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in CLANSP as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is supplied. */
+/* = 'U': Upper triangular part of A is supplied */
+/* = 'L': Lower triangular part of A is supplied */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, CLANSP is */
+/* set to zero. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the symmetric matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
+/* WORK is not referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --ap;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.f;
+ if (lsame_(uplo, "U")) {
+ k = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&ap[i__]);
+ value = dmax(r__1,r__2);
+/* L10: */
+ }
+ k += j;
+/* L20: */
+ }
+ } else {
+ k = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + *n - j;
+ for (i__ = k; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&ap[i__]);
+ value = dmax(r__1,r__2);
+/* L30: */
+ }
+ k = k + *n - j + 1;
+/* L40: */
+ }
+ }
+ } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
+
+/* Find normI(A) ( = norm1(A), since A is symmetric). */
+
+ value = 0.f;
+ k = 1;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.f;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ absa = c_abs(&ap[k]);
+ sum += absa;
+ work[i__] += absa;
+ ++k;
+/* L50: */
+ }
+ work[j] = sum + c_abs(&ap[k]);
+ ++k;
+/* L60: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = work[i__];
+ value = dmax(r__1,r__2);
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L80: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = work[j] + c_abs(&ap[k]);
+ ++k;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ absa = c_abs(&ap[k]);
+ sum += absa;
+ work[i__] += absa;
+ ++k;
+/* L90: */
+ }
+ value = dmax(value,sum);
+/* L100: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.f;
+ sum = 1.f;
+ k = 2;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ classq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k += j;
+/* L110: */
+ }
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ classq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k = k + *n - j + 1;
+/* L120: */
+ }
+ }
+ sum *= 2;
+ k = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = k;
+ if (ap[i__2].r != 0.f) {
+ i__2 = k;
+ absa = (r__1 = ap[i__2].r, dabs(r__1));
+ if (scale < absa) {
+/* Computing 2nd power */
+ r__1 = scale / absa;
+ sum = sum * (r__1 * r__1) + 1.f;
+ scale = absa;
+ } else {
+/* Computing 2nd power */
+ r__1 = absa / scale;
+ sum += r__1 * r__1;
+ }
+ }
+ if (r_imag(&ap[k]) != 0.f) {
+ absa = (r__1 = r_imag(&ap[k]), dabs(r__1));
+ if (scale < absa) {
+/* Computing 2nd power */
+ r__1 = scale / absa;
+ sum = sum * (r__1 * r__1) + 1.f;
+ scale = absa;
+ } else {
+/* Computing 2nd power */
+ r__1 = absa / scale;
+ sum += r__1 * r__1;
+ }
+ }
+ if (lsame_(uplo, "U")) {
+ k = k + i__ + 1;
+ } else {
+ k = k + *n - i__ + 1;
+ }
+/* L130: */
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of CLANSP */
+
+} /* clansp_ */
diff --git a/SRC/clansy.c b/SRC/clansy.c
new file mode 100644
index 0000000..874e77e
--- /dev/null
+++ b/SRC/clansy.c
@@ -0,0 +1,237 @@
+/* clansy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal clansy_(char *norm, char *uplo, integer *n, complex *a, integer *
+ lda, real *work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real ret_val, r__1, r__2;
+
+ /* Builtin functions */
+ double c_abs(complex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ real sum, absa, scale;
+ extern logical lsame_(char *, char *);
+ real value;
+ extern /* Subroutine */ int classq_(integer *, complex *, integer *, real
+ *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLANSY returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* complex symmetric matrix A. */
+
+/* Description */
+/* =========== */
+
+/* CLANSY returns the value */
+
+/* CLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in CLANSY as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is to be referenced. */
+/* = 'U': Upper triangular part of A is referenced */
+/* = 'L': Lower triangular part of A is referenced */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, CLANSY is */
+/* set to zero. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of A contains the upper triangular part */
+/* of the matrix A, and the strictly lower triangular part of A */
+/* is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of A contains the lower triangular part of */
+/* the matrix A, and the strictly upper triangular part of A is */
+/* not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(N,1). */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
+/* WORK is not referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * a_dim1]);
+ value = dmax(r__1,r__2);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * a_dim1]);
+ value = dmax(r__1,r__2);
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
+
+/* Find normI(A) ( = norm1(A), since A is symmetric). */
+
+ value = 0.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.f;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ absa = c_abs(&a[i__ + j * a_dim1]);
+ sum += absa;
+ work[i__] += absa;
+/* L50: */
+ }
+ work[j] = sum + c_abs(&a[j + j * a_dim1]);
+/* L60: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = work[i__];
+ value = dmax(r__1,r__2);
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L80: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = work[j] + c_abs(&a[j + j * a_dim1]);
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ absa = c_abs(&a[i__ + j * a_dim1]);
+ sum += absa;
+ work[i__] += absa;
+/* L90: */
+ }
+ value = dmax(value,sum);
+/* L100: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.f;
+ sum = 1.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ classq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
+/* L110: */
+ }
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ classq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum);
+/* L120: */
+ }
+ }
+ sum *= 2;
+ i__1 = *lda + 1;
+ classq_(n, &a[a_offset], &i__1, &scale, &sum);
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of CLANSY */
+
+} /* clansy_ */
diff --git a/SRC/clantb.c b/SRC/clantb.c
new file mode 100644
index 0000000..98d8657
--- /dev/null
+++ b/SRC/clantb.c
@@ -0,0 +1,426 @@
+/* clantb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal clantb_(char *norm, char *uplo, char *diag, integer *n, integer *k,
+ complex *ab, integer *ldab, real *work)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5;
+ real ret_val, r__1, r__2;
+
+ /* Builtin functions */
+ double c_abs(complex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, l;
+ real sum, scale;
+ logical udiag;
+ extern logical lsame_(char *, char *);
+ real value;
+ extern /* Subroutine */ int classq_(integer *, complex *, integer *, real
+ *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLANTB returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of an */
+/* n by n triangular band matrix A, with ( k + 1 ) diagonals. */
+
+/* Description */
+/* =========== */
+
+/* CLANTB returns the value */
+
+/* CLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in CLANTB as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, CLANTB is */
+/* set to zero. */
+
+/* K (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals of the matrix A if UPLO = 'L'. */
+/* K >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first k+1 rows of AB. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). */
+/* Note that when DIAG = 'U', the elements of the array AB */
+/* corresponding to the diagonal elements of the matrix A are */
+/* not referenced, but are assumed to be one. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= K+1. */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ if (lsame_(diag, "U")) {
+ value = 1.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ i__3 = *k;
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&ab[i__ + j * ab_dim1]);
+ value = dmax(r__1,r__2);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *n + 1 - j, i__4 = *k + 1;
+ i__3 = min(i__2,i__4);
+ for (i__ = 2; i__ <= i__3; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&ab[i__ + j * ab_dim1]);
+ value = dmax(r__1,r__2);
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else {
+ value = 0.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__3 = *k + 2 - j;
+ i__2 = *k + 1;
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&ab[i__ + j * ab_dim1]);
+ value = dmax(r__1,r__2);
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n + 1 - j, i__4 = *k + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&ab[i__ + j * ab_dim1]);
+ value = dmax(r__1,r__2);
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.f;
+ udiag = lsame_(diag, "U");
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag) {
+ sum = 1.f;
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ i__3 = *k;
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+ sum += c_abs(&ab[i__ + j * ab_dim1]);
+/* L90: */
+ }
+ } else {
+ sum = 0.f;
+/* Computing MAX */
+ i__3 = *k + 2 - j;
+ i__2 = *k + 1;
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+ sum += c_abs(&ab[i__ + j * ab_dim1]);
+/* L100: */
+ }
+ }
+ value = dmax(value,sum);
+/* L110: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag) {
+ sum = 1.f;
+/* Computing MIN */
+ i__3 = *n + 1 - j, i__4 = *k + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ sum += c_abs(&ab[i__ + j * ab_dim1]);
+/* L120: */
+ }
+ } else {
+ sum = 0.f;
+/* Computing MIN */
+ i__3 = *n + 1 - j, i__4 = *k + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ sum += c_abs(&ab[i__ + j * ab_dim1]);
+/* L130: */
+ }
+ }
+ value = dmax(value,sum);
+/* L140: */
+ }
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ value = 0.f;
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.f;
+/* L150: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ l = *k + 1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ work[i__] += c_abs(&ab[l + i__ + j * ab_dim1]);
+/* L160: */
+ }
+/* L170: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L180: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ l = *k + 1 - j;
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *k;
+ i__3 = j;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ work[i__] += c_abs(&ab[l + i__ + j * ab_dim1]);
+/* L190: */
+ }
+/* L200: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.f;
+/* L210: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ l = 1 - j;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ work[i__] += c_abs(&ab[l + i__ + j * ab_dim1]);
+/* L220: */
+ }
+/* L230: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L240: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ l = 1 - j;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j; i__ <= i__3; ++i__) {
+ work[i__] += c_abs(&ab[l + i__ + j * ab_dim1]);
+/* L250: */
+ }
+/* L260: */
+ }
+ }
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = work[i__];
+ value = dmax(r__1,r__2);
+/* L270: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ scale = 1.f;
+ sum = (real) (*n);
+ if (*k > 0) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = j - 1;
+ i__3 = min(i__4,*k);
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ classq_(&i__3, &ab[max(i__2, 1)+ j * ab_dim1], &c__1,
+ &scale, &sum);
+/* L280: */
+ }
+ }
+ } else {
+ scale = 0.f;
+ sum = 1.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = j, i__2 = *k + 1;
+ i__3 = min(i__4,i__2);
+/* Computing MAX */
+ i__5 = *k + 2 - j;
+ classq_(&i__3, &ab[max(i__5, 1)+ j * ab_dim1], &c__1, &
+ scale, &sum);
+/* L290: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ scale = 1.f;
+ sum = (real) (*n);
+ if (*k > 0) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = *n - j;
+ i__3 = min(i__4,*k);
+ classq_(&i__3, &ab[j * ab_dim1 + 2], &c__1, &scale, &
+ sum);
+/* L300: */
+ }
+ }
+ } else {
+ scale = 0.f;
+ sum = 1.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = *n - j + 1, i__2 = *k + 1;
+ i__3 = min(i__4,i__2);
+ classq_(&i__3, &ab[j * ab_dim1 + 1], &c__1, &scale, &sum);
+/* L310: */
+ }
+ }
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of CLANTB */
+
+} /* clantb_ */
diff --git a/SRC/clantp.c b/SRC/clantp.c
new file mode 100644
index 0000000..720f2cc
--- /dev/null
+++ b/SRC/clantp.c
@@ -0,0 +1,391 @@
+/* clantp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal clantp_(char *norm, char *uplo, char *diag, integer *n, complex *
+ ap, real *work)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real ret_val, r__1, r__2;
+
+ /* Builtin functions */
+ double c_abs(complex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ real sum, scale;
+ logical udiag;
+ extern logical lsame_(char *, char *);
+ real value;
+ extern /* Subroutine */ int classq_(integer *, complex *, integer *, real
+ *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLANTP returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* triangular matrix A, supplied in packed form. */
+
+/* Description */
+/* =========== */
+
+/* CLANTP returns the value */
+
+/* CLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in CLANTP as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, CLANTP is */
+/* set to zero. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* Note that when DIAG = 'U', the elements of the array AP */
+/* corresponding to the diagonal elements of the matrix A are */
+/* not referenced, but are assumed to be one. */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --ap;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ k = 1;
+ if (lsame_(diag, "U")) {
+ value = 1.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j - 2;
+ for (i__ = k; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&ap[i__]);
+ value = dmax(r__1,r__2);
+/* L10: */
+ }
+ k += j;
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + *n - j;
+ for (i__ = k + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&ap[i__]);
+ value = dmax(r__1,r__2);
+/* L30: */
+ }
+ k = k + *n - j + 1;
+/* L40: */
+ }
+ }
+ } else {
+ value = 0.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&ap[i__]);
+ value = dmax(r__1,r__2);
+/* L50: */
+ }
+ k += j;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + *n - j;
+ for (i__ = k; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&ap[i__]);
+ value = dmax(r__1,r__2);
+/* L70: */
+ }
+ k = k + *n - j + 1;
+/* L80: */
+ }
+ }
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.f;
+ k = 1;
+ udiag = lsame_(diag, "U");
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag) {
+ sum = 1.f;
+ i__2 = k + j - 2;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ sum += c_abs(&ap[i__]);
+/* L90: */
+ }
+ } else {
+ sum = 0.f;
+ i__2 = k + j - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ sum += c_abs(&ap[i__]);
+/* L100: */
+ }
+ }
+ k += j;
+ value = dmax(value,sum);
+/* L110: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag) {
+ sum = 1.f;
+ i__2 = k + *n - j;
+ for (i__ = k + 1; i__ <= i__2; ++i__) {
+ sum += c_abs(&ap[i__]);
+/* L120: */
+ }
+ } else {
+ sum = 0.f;
+ i__2 = k + *n - j;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ sum += c_abs(&ap[i__]);
+/* L130: */
+ }
+ }
+ k = k + *n - j + 1;
+ value = dmax(value,sum);
+/* L140: */
+ }
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ k = 1;
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.f;
+/* L150: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += c_abs(&ap[k]);
+ ++k;
+/* L160: */
+ }
+ ++k;
+/* L170: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L180: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += c_abs(&ap[k]);
+ ++k;
+/* L190: */
+ }
+/* L200: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.f;
+/* L210: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ++k;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ work[i__] += c_abs(&ap[k]);
+ ++k;
+/* L220: */
+ }
+/* L230: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L240: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ work[i__] += c_abs(&ap[k]);
+ ++k;
+/* L250: */
+ }
+/* L260: */
+ }
+ }
+ }
+ value = 0.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = work[i__];
+ value = dmax(r__1,r__2);
+/* L270: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ scale = 1.f;
+ sum = (real) (*n);
+ k = 2;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ classq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k += j;
+/* L280: */
+ }
+ } else {
+ scale = 0.f;
+ sum = 1.f;
+ k = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ classq_(&j, &ap[k], &c__1, &scale, &sum);
+ k += j;
+/* L290: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ scale = 1.f;
+ sum = (real) (*n);
+ k = 2;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ classq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k = k + *n - j + 1;
+/* L300: */
+ }
+ } else {
+ scale = 0.f;
+ sum = 1.f;
+ k = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ classq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k = k + *n - j + 1;
+/* L310: */
+ }
+ }
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of CLANTP */
+
+} /* clantp_ */
diff --git a/SRC/clantr.c b/SRC/clantr.c
new file mode 100644
index 0000000..adf6e51
--- /dev/null
+++ b/SRC/clantr.c
@@ -0,0 +1,394 @@
+/* clantr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal clantr_(char *norm, char *uplo, char *diag, integer *m, integer *n,
+ complex *a, integer *lda, real *work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ real ret_val, r__1, r__2;
+
+ /* Builtin functions */
+ double c_abs(complex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ real sum, scale;
+ logical udiag;
+ extern logical lsame_(char *, char *);
+ real value;
+ extern /* Subroutine */ int classq_(integer *, complex *, integer *, real
+ *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLANTR returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* trapezoidal or triangular matrix A. */
+
+/* Description */
+/* =========== */
+
+/* CLANTR returns the value */
+
+/* CLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in CLANTR as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower trapezoidal. */
+/* = 'U': Upper trapezoidal */
+/* = 'L': Lower trapezoidal */
+/* Note that A is triangular instead of trapezoidal if M = N. */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A has unit diagonal. */
+/* = 'N': Non-unit diagonal */
+/* = 'U': Unit diagonal */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0, and if */
+/* UPLO = 'U', M <= N. When M = 0, CLANTR is set to zero. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0, and if */
+/* UPLO = 'L', N <= M. When N = 0, CLANTR is set to zero. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The trapezoidal matrix A (A is triangular if M = N). */
+/* If UPLO = 'U', the leading m by n upper trapezoidal part of */
+/* the array A contains the upper trapezoidal matrix, and the */
+/* strictly lower triangular part of A is not referenced. */
+/* If UPLO = 'L', the leading m by n lower trapezoidal part of */
+/* the array A contains the lower trapezoidal matrix, and the */
+/* strictly upper triangular part of A is not referenced. Note */
+/* that when DIAG = 'U', the diagonal elements of A are not */
+/* referenced and are assumed to be one. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(M,1). */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ if (min(*m,*n) == 0) {
+ value = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ if (lsame_(diag, "U")) {
+ value = 1.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *m, i__4 = j - 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * a_dim1]);
+ value = dmax(r__1,r__2);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * a_dim1]);
+ value = dmax(r__1,r__2);
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else {
+ value = 0.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(*m,j);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * a_dim1]);
+ value = dmax(r__1,r__2);
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = c_abs(&a[i__ + j * a_dim1]);
+ value = dmax(r__1,r__2);
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.f;
+ udiag = lsame_(diag, "U");
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag && j <= *m) {
+ sum = 1.f;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ sum += c_abs(&a[i__ + j * a_dim1]);
+/* L90: */
+ }
+ } else {
+ sum = 0.f;
+ i__2 = min(*m,j);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ sum += c_abs(&a[i__ + j * a_dim1]);
+/* L100: */
+ }
+ }
+ value = dmax(value,sum);
+/* L110: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag) {
+ sum = 1.f;
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ sum += c_abs(&a[i__ + j * a_dim1]);
+/* L120: */
+ }
+ } else {
+ sum = 0.f;
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ sum += c_abs(&a[i__ + j * a_dim1]);
+/* L130: */
+ }
+ }
+ value = dmax(value,sum);
+/* L140: */
+ }
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.f;
+/* L150: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *m, i__4 = j - 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += c_abs(&a[i__ + j * a_dim1]);
+/* L160: */
+ }
+/* L170: */
+ }
+ } else {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L180: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(*m,j);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += c_abs(&a[i__ + j * a_dim1]);
+/* L190: */
+ }
+/* L200: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.f;
+/* L210: */
+ }
+ i__1 = *m;
+ for (i__ = *n + 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L220: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ work[i__] += c_abs(&a[i__ + j * a_dim1]);
+/* L230: */
+ }
+/* L240: */
+ }
+ } else {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L250: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ work[i__] += c_abs(&a[i__ + j * a_dim1]);
+/* L260: */
+ }
+/* L270: */
+ }
+ }
+ }
+ value = 0.f;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = work[i__];
+ value = dmax(r__1,r__2);
+/* L280: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ scale = 1.f;
+ sum = (real) min(*m,*n);
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *m, i__4 = j - 1;
+ i__2 = min(i__3,i__4);
+ classq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
+/* L290: */
+ }
+ } else {
+ scale = 0.f;
+ sum = 1.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(*m,j);
+ classq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
+/* L300: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ scale = 1.f;
+ sum = (real) min(*m,*n);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m - j;
+/* Computing MIN */
+ i__3 = *m, i__4 = j + 1;
+ classq_(&i__2, &a[min(i__3, i__4)+ j * a_dim1], &c__1, &
+ scale, &sum);
+/* L310: */
+ }
+ } else {
+ scale = 0.f;
+ sum = 1.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m - j + 1;
+ classq_(&i__2, &a[j + j * a_dim1], &c__1, &scale, &sum);
+/* L320: */
+ }
+ }
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of CLANTR */
+
+} /* clantr_ */
diff --git a/SRC/clapll.c b/SRC/clapll.c
new file mode 100644
index 0000000..e398c67
--- /dev/null
+++ b/SRC/clapll.c
@@ -0,0 +1,143 @@
+/* clapll.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int clapll_(integer *n, complex *x, integer *incx, complex *
+ y, integer *incy, real *ssmin)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2, r__3;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+ double c_abs(complex *);
+
+ /* Local variables */
+ complex c__, a11, a12, a22, tau;
+ extern /* Subroutine */ int slas2_(real *, real *, real *, real *, real *)
+ ;
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ real ssmax;
+ extern /* Subroutine */ int clarfg_(integer *, complex *, complex *,
+ integer *, complex *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Given two column vectors X and Y, let */
+
+/* A = ( X Y ). */
+
+/* The subroutine first computes the QR factorization of A = Q*R, */
+/* and then computes the SVD of the 2-by-2 upper triangular matrix R. */
+/* The smaller singular value of R is returned in SSMIN, which is used */
+/* as the measurement of the linear dependency of the vectors X and Y. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The length of the vectors X and Y. */
+
+/* X (input/output) COMPLEX array, dimension (1+(N-1)*INCX) */
+/* On entry, X contains the N-vector X. */
+/* On exit, X is overwritten. */
+
+/* INCX (input) INTEGER */
+/* The increment between successive elements of X. INCX > 0. */
+
+/* Y (input/output) COMPLEX array, dimension (1+(N-1)*INCY) */
+/* On entry, Y contains the N-vector Y. */
+/* On exit, Y is overwritten. */
+
+/* INCY (input) INTEGER */
+/* The increment between successive elements of Y. INCY > 0. */
+
+/* SSMIN (output) REAL */
+/* The smallest singular value of the N-by-2 matrix A = ( X Y ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --y;
+ --x;
+
+ /* Function Body */
+ if (*n <= 1) {
+ *ssmin = 0.f;
+ return 0;
+ }
+
+/* Compute the QR factorization of the N-by-2 matrix ( X Y ) */
+
+ clarfg_(n, &x[1], &x[*incx + 1], incx, &tau);
+ a11.r = x[1].r, a11.i = x[1].i;
+ x[1].r = 1.f, x[1].i = 0.f;
+
+ r_cnjg(&q__3, &tau);
+ q__2.r = -q__3.r, q__2.i = -q__3.i;
+ cdotc_(&q__4, n, &x[1], incx, &y[1], incy);
+ q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i +
+ q__2.i * q__4.r;
+ c__.r = q__1.r, c__.i = q__1.i;
+ caxpy_(n, &c__, &x[1], incx, &y[1], incy);
+
+ i__1 = *n - 1;
+ clarfg_(&i__1, &y[*incy + 1], &y[(*incy << 1) + 1], incy, &tau);
+
+ a12.r = y[1].r, a12.i = y[1].i;
+ i__1 = *incy + 1;
+ a22.r = y[i__1].r, a22.i = y[i__1].i;
+
+/* Compute the SVD of 2-by-2 Upper triangular matrix. */
+
+ r__1 = c_abs(&a11);
+ r__2 = c_abs(&a12);
+ r__3 = c_abs(&a22);
+ slas2_(&r__1, &r__2, &r__3, ssmin, &ssmax);
+
+ return 0;
+
+/* End of CLAPLL */
+
+} /* clapll_ */
diff --git a/SRC/clapmt.c b/SRC/clapmt.c
new file mode 100644
index 0000000..7e63e4d
--- /dev/null
+++ b/SRC/clapmt.c
@@ -0,0 +1,185 @@
+/* clapmt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int clapmt_(logical *forwrd, integer *m, integer *n, complex
+ *x, integer *ldx, integer *k)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, ii, in;
+ complex temp;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAPMT rearranges the columns of the M by N matrix X as specified */
+/* by the permutation K(1),K(2),...,K(N) of the integers 1,...,N. */
+/* If FORWRD = .TRUE., forward permutation: */
+
+/* X(*,K(J)) is moved X(*,J) for J = 1,2,...,N. */
+
+/* If FORWRD = .FALSE., backward permutation: */
+
+/* X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N. */
+
+/* Arguments */
+/* ========= */
+
+/* FORWRD (input) LOGICAL */
+/* = .TRUE., forward permutation */
+/* = .FALSE., backward permutation */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix X. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix X. N >= 0. */
+
+/* X (input/output) COMPLEX array, dimension (LDX,N) */
+/* On entry, the M by N matrix X. */
+/* On exit, X contains the permuted matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X, LDX >= MAX(1,M). */
+
+/* K (input/output) INTEGER array, dimension (N) */
+/* On entry, K contains the permutation vector. K is used as */
+/* internal workspace, but reset to its original value on */
+/* output. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --k;
+
+ /* Function Body */
+ if (*n <= 1) {
+ return 0;
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ k[i__] = -k[i__];
+/* L10: */
+ }
+
+ if (*forwrd) {
+
+/* Forward permutation */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+ if (k[i__] > 0) {
+ goto L40;
+ }
+
+ j = i__;
+ k[j] = -k[j];
+ in = k[j];
+
+L20:
+ if (k[in] > 0) {
+ goto L40;
+ }
+
+ i__2 = *m;
+ for (ii = 1; ii <= i__2; ++ii) {
+ i__3 = ii + j * x_dim1;
+ temp.r = x[i__3].r, temp.i = x[i__3].i;
+ i__3 = ii + j * x_dim1;
+ i__4 = ii + in * x_dim1;
+ x[i__3].r = x[i__4].r, x[i__3].i = x[i__4].i;
+ i__3 = ii + in * x_dim1;
+ x[i__3].r = temp.r, x[i__3].i = temp.i;
+/* L30: */
+ }
+
+ k[in] = -k[in];
+ j = in;
+ in = k[in];
+ goto L20;
+
+L40:
+
+/* L60: */
+ ;
+ }
+
+ } else {
+
+/* Backward permutation */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+ if (k[i__] > 0) {
+ goto L100;
+ }
+
+ k[i__] = -k[i__];
+ j = k[i__];
+L80:
+ if (j == i__) {
+ goto L100;
+ }
+
+ i__2 = *m;
+ for (ii = 1; ii <= i__2; ++ii) {
+ i__3 = ii + i__ * x_dim1;
+ temp.r = x[i__3].r, temp.i = x[i__3].i;
+ i__3 = ii + i__ * x_dim1;
+ i__4 = ii + j * x_dim1;
+ x[i__3].r = x[i__4].r, x[i__3].i = x[i__4].i;
+ i__3 = ii + j * x_dim1;
+ x[i__3].r = temp.r, x[i__3].i = temp.i;
+/* L90: */
+ }
+
+ k[j] = -k[j];
+ j = k[j];
+ goto L80;
+
+L100:
+/* L110: */
+ ;
+ }
+
+ }
+
+ return 0;
+
+/* End of CLAPMT */
+
+} /* clapmt_ */
diff --git a/SRC/claqgb.c b/SRC/claqgb.c
new file mode 100644
index 0000000..a323247
--- /dev/null
+++ b/SRC/claqgb.c
@@ -0,0 +1,227 @@
+/* claqgb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int claqgb_(integer *m, integer *n, integer *kl, integer *ku,
+ complex *ab, integer *ldab, real *r__, real *c__, real *rowcnd, real
+ *colcnd, real *amax, char *equed)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j;
+ real cj, large, small;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAQGB equilibrates a general M by N band matrix A with KL */
+/* subdiagonals and KU superdiagonals using the row and scaling factors */
+/* in the vectors R and C. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */
+
+/* On exit, the equilibrated matrix, in the same storage format */
+/* as A. See EQUED for the form of the equilibrated matrix. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDA >= KL+KU+1. */
+
+/* R (input) REAL array, dimension (M) */
+/* The row scale factors for A. */
+
+/* C (input) REAL array, dimension (N) */
+/* The column scale factors for A. */
+
+/* ROWCND (input) REAL */
+/* Ratio of the smallest R(i) to the largest R(i). */
+
+/* COLCND (input) REAL */
+/* Ratio of the smallest C(i) to the largest C(i). */
+
+/* AMAX (input) REAL */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if row or column scaling */
+/* should be done based on the ratio of the row or column scaling */
+/* factors. If ROWCND < THRESH, row scaling is done, and if */
+/* COLCND < THRESH, column scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if row scaling */
+/* should be done based on the absolute size of the largest matrix */
+/* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = slamch_("Safe minimum") / slamch_("Precision");
+ large = 1.f / small;
+
+ if (*rowcnd >= .1f && *amax >= small && *amax <= large) {
+
+/* No row scaling */
+
+ if (*colcnd >= .1f) {
+
+/* No column scaling */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = c__[j];
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__4 = min(i__5,i__6);
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ i__2 = *ku + 1 + i__ - j + j * ab_dim1;
+ i__3 = *ku + 1 + i__ - j + j * ab_dim1;
+ q__1.r = cj * ab[i__3].r, q__1.i = cj * ab[i__3].i;
+ ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
+/* L10: */
+ }
+/* L20: */
+ }
+ *(unsigned char *)equed = 'C';
+ }
+ } else if (*colcnd >= .1f) {
+
+/* Row scaling, no column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__3 = min(i__5,i__6);
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ i__4 = *ku + 1 + i__ - j + j * ab_dim1;
+ i__2 = i__;
+ i__5 = *ku + 1 + i__ - j + j * ab_dim1;
+ q__1.r = r__[i__2] * ab[i__5].r, q__1.i = r__[i__2] * ab[i__5]
+ .i;
+ ab[i__4].r = q__1.r, ab[i__4].i = q__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ *(unsigned char *)equed = 'R';
+ } else {
+
+/* Row and column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = c__[j];
+/* Computing MAX */
+ i__3 = 1, i__4 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__2 = min(i__5,i__6);
+ for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) {
+ i__3 = *ku + 1 + i__ - j + j * ab_dim1;
+ r__1 = cj * r__[i__];
+ i__4 = *ku + 1 + i__ - j + j * ab_dim1;
+ q__1.r = r__1 * ab[i__4].r, q__1.i = r__1 * ab[i__4].i;
+ ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
+/* L50: */
+ }
+/* L60: */
+ }
+ *(unsigned char *)equed = 'B';
+ }
+
+ return 0;
+
+/* End of CLAQGB */
+
+} /* claqgb_ */
diff --git a/SRC/claqge.c b/SRC/claqge.c
new file mode 100644
index 0000000..ed87bac
--- /dev/null
+++ b/SRC/claqge.c
@@ -0,0 +1,202 @@
+/* claqge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int claqge_(integer *m, integer *n, complex *a, integer *lda,
+ real *r__, real *c__, real *rowcnd, real *colcnd, real *amax, char *
+ equed)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j;
+ real cj, large, small;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAQGE equilibrates a general M by N matrix A using the row and */
+/* column scaling factors in the vectors R and C. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M by N matrix A. */
+/* On exit, the equilibrated matrix. See EQUED for the form of */
+/* the equilibrated matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(M,1). */
+
+/* R (input) REAL array, dimension (M) */
+/* The row scale factors for A. */
+
+/* C (input) REAL array, dimension (N) */
+/* The column scale factors for A. */
+
+/* ROWCND (input) REAL */
+/* Ratio of the smallest R(i) to the largest R(i). */
+
+/* COLCND (input) REAL */
+/* Ratio of the smallest C(i) to the largest C(i). */
+
+/* AMAX (input) REAL */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if row or column scaling */
+/* should be done based on the ratio of the row or column scaling */
+/* factors. If ROWCND < THRESH, row scaling is done, and if */
+/* COLCND < THRESH, column scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if row scaling */
+/* should be done based on the absolute size of the largest matrix */
+/* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = slamch_("Safe minimum") / slamch_("Precision");
+ large = 1.f / small;
+
+ if (*rowcnd >= .1f && *amax >= small && *amax <= large) {
+
+/* No row scaling */
+
+ if (*colcnd >= .1f) {
+
+/* No column scaling */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = c__[j];
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ q__1.r = cj * a[i__4].r, q__1.i = cj * a[i__4].i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L10: */
+ }
+/* L20: */
+ }
+ *(unsigned char *)equed = 'C';
+ }
+ } else if (*colcnd >= .1f) {
+
+/* Row scaling, no column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ q__1.r = r__[i__4] * a[i__5].r, q__1.i = r__[i__4] * a[i__5]
+ .i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ *(unsigned char *)equed = 'R';
+ } else {
+
+/* Row and column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = c__[j];
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ r__1 = cj * r__[i__];
+ i__4 = i__ + j * a_dim1;
+ q__1.r = r__1 * a[i__4].r, q__1.i = r__1 * a[i__4].i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L50: */
+ }
+/* L60: */
+ }
+ *(unsigned char *)equed = 'B';
+ }
+
+ return 0;
+
+/* End of CLAQGE */
+
+} /* claqge_ */
diff --git a/SRC/claqhb.c b/SRC/claqhb.c
new file mode 100644
index 0000000..e4dc7f8
--- /dev/null
+++ b/SRC/claqhb.c
@@ -0,0 +1,200 @@
+/* claqhb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int claqhb_(char *uplo, integer *n, integer *kd, complex *ab,
+ integer *ldab, real *s, real *scond, real *amax, char *equed)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ real r__1;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j;
+ real cj, large;
+ extern logical lsame_(char *, char *);
+ real small;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAQHB equilibrates an Hermitian band matrix A using the scaling */
+/* factors in the vector S. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, if INFO = 0, the triangular factor U or L from the */
+/* Cholesky factorization A = U'*U or A = L*L' of the band */
+/* matrix A, in the same storage format as A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* S (output) REAL array, dimension (N) */
+/* The scale factors for A. */
+
+/* SCOND (input) REAL */
+/* Ratio of the smallest S(i) to the largest S(i). */
+
+/* AMAX (input) REAL */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies whether or not equilibration was done. */
+/* = 'N': No equilibration. */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if scaling should be done */
+/* based on the ratio of the scaling factors. If SCOND < THRESH, */
+/* scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if scaling should */
+/* be done based on the absolute size of the largest matrix element. */
+/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --s;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = slamch_("Safe minimum") / slamch_("Precision");
+ large = 1.f / small;
+
+ if (*scond >= .1f && *amax >= small && *amax <= large) {
+
+/* No equilibration */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Replace A by diag(S) * A * diag(S). */
+
+ if (lsame_(uplo, "U")) {
+
+/* Upper triangle of A is stored in band format. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *kd;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ i__2 = *kd + 1 + i__ - j + j * ab_dim1;
+ r__1 = cj * s[i__];
+ i__3 = *kd + 1 + i__ - j + j * ab_dim1;
+ q__1.r = r__1 * ab[i__3].r, q__1.i = r__1 * ab[i__3].i;
+ ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
+/* L10: */
+ }
+ i__4 = *kd + 1 + j * ab_dim1;
+ i__2 = *kd + 1 + j * ab_dim1;
+ r__1 = cj * cj * ab[i__2].r;
+ ab[i__4].r = r__1, ab[i__4].i = 0.f;
+/* L20: */
+ }
+ } else {
+
+/* Lower triangle of A is stored. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__4 = j * ab_dim1 + 1;
+ i__2 = j * ab_dim1 + 1;
+ r__1 = cj * cj * ab[i__2].r;
+ ab[i__4].r = r__1, ab[i__4].i = 0.f;
+/* Computing MIN */
+ i__2 = *n, i__3 = j + *kd;
+ i__4 = min(i__2,i__3);
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ i__2 = i__ + 1 - j + j * ab_dim1;
+ r__1 = cj * s[i__];
+ i__3 = i__ + 1 - j + j * ab_dim1;
+ q__1.r = r__1 * ab[i__3].r, q__1.i = r__1 * ab[i__3].i;
+ ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ *(unsigned char *)equed = 'Y';
+ }
+
+ return 0;
+
+/* End of CLAQHB */
+
+} /* claqhb_ */
diff --git a/SRC/claqhe.c b/SRC/claqhe.c
new file mode 100644
index 0000000..507a7ac
--- /dev/null
+++ b/SRC/claqhe.c
@@ -0,0 +1,192 @@
+/* claqhe.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int claqhe_(char *uplo, integer *n, complex *a, integer *lda,
+ real *s, real *scond, real *amax, char *equed)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ real r__1;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j;
+ real cj, large;
+ extern logical lsame_(char *, char *);
+ real small;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAQHE equilibrates a Hermitian matrix A using the scaling factors */
+/* in the vector S. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the 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 EQUED = 'Y', the equilibrated matrix: */
+/* diag(S) * A * diag(S). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(N,1). */
+
+/* S (input) REAL array, dimension (N) */
+/* The scale factors for A. */
+
+/* SCOND (input) REAL */
+/* Ratio of the smallest S(i) to the largest S(i). */
+
+/* AMAX (input) REAL */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies whether or not equilibration was done. */
+/* = 'N': No equilibration. */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if scaling should be done */
+/* based on the ratio of the scaling factors. If SCOND < THRESH, */
+/* scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if scaling should */
+/* be done based on the absolute size of the largest matrix element. */
+/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = slamch_("Safe minimum") / slamch_("Precision");
+ large = 1.f / small;
+
+ if (*scond >= .1f && *amax >= small && *amax <= large) {
+
+/* No equilibration */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Replace A by diag(S) * A * diag(S). */
+
+ if (lsame_(uplo, "U")) {
+
+/* Upper triangle of A is stored. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ r__1 = cj * s[i__];
+ i__4 = i__ + j * a_dim1;
+ q__1.r = r__1 * a[i__4].r, q__1.i = r__1 * a[i__4].i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L10: */
+ }
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ r__1 = cj * cj * a[i__3].r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+/* L20: */
+ }
+ } else {
+
+/* Lower triangle of A is stored. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ r__1 = cj * cj * a[i__3].r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ r__1 = cj * s[i__];
+ i__4 = i__ + j * a_dim1;
+ q__1.r = r__1 * a[i__4].r, q__1.i = r__1 * a[i__4].i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ *(unsigned char *)equed = 'Y';
+ }
+
+ return 0;
+
+/* End of CLAQHE */
+
+} /* claqhe_ */
diff --git a/SRC/claqhp.c b/SRC/claqhp.c
new file mode 100644
index 0000000..2676a25
--- /dev/null
+++ b/SRC/claqhp.c
@@ -0,0 +1,189 @@
+/* claqhp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int claqhp_(char *uplo, integer *n, complex *ap, real *s,
+ real *scond, real *amax, char *equed)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j, jc;
+ real cj, large;
+ extern logical lsame_(char *, char *);
+ real small;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAQHP equilibrates a Hermitian matrix A using the scaling factors */
+/* in the vector S. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the equilibrated matrix: diag(S) * A * diag(S), in */
+/* the same storage format as A. */
+
+/* S (input) REAL array, dimension (N) */
+/* The scale factors for A. */
+
+/* SCOND (input) REAL */
+/* Ratio of the smallest S(i) to the largest S(i). */
+
+/* AMAX (input) REAL */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies whether or not equilibration was done. */
+/* = 'N': No equilibration. */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if scaling should be done */
+/* based on the ratio of the scaling factors. If SCOND < THRESH, */
+/* scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if scaling should */
+/* be done based on the absolute size of the largest matrix element. */
+/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --s;
+ --ap;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = slamch_("Safe minimum") / slamch_("Precision");
+ large = 1.f / small;
+
+ if (*scond >= .1f && *amax >= small && *amax <= large) {
+
+/* No equilibration */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Replace A by diag(S) * A * diag(S). */
+
+ if (lsame_(uplo, "U")) {
+
+/* Upper triangle of A is stored. */
+
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - 1;
+ r__1 = cj * s[i__];
+ i__4 = jc + i__ - 1;
+ q__1.r = r__1 * ap[i__4].r, q__1.i = r__1 * ap[i__4].i;
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+/* L10: */
+ }
+ i__2 = jc + j - 1;
+ i__3 = jc + j - 1;
+ r__1 = cj * cj * ap[i__3].r;
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+ jc += j;
+/* L20: */
+ }
+ } else {
+
+/* Lower triangle of A is stored. */
+
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = jc;
+ i__3 = jc;
+ r__1 = cj * cj * ap[i__3].r;
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - j;
+ r__1 = cj * s[i__];
+ i__4 = jc + i__ - j;
+ q__1.r = r__1 * ap[i__4].r, q__1.i = r__1 * ap[i__4].i;
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+/* L30: */
+ }
+ jc = jc + *n - j + 1;
+/* L40: */
+ }
+ }
+ *(unsigned char *)equed = 'Y';
+ }
+
+ return 0;
+
+/* End of CLAQHP */
+
+} /* claqhp_ */
diff --git a/SRC/claqp2.c b/SRC/claqp2.c
new file mode 100644
index 0000000..6dc8ed8
--- /dev/null
+++ b/SRC/claqp2.c
@@ -0,0 +1,244 @@
+/* claqp2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int claqp2_(integer *m, integer *n, integer *offset, complex
+ *a, integer *lda, integer *jpvt, complex *tau, real *vn1, real *vn2,
+ complex *work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1;
+ complex q__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ void r_cnjg(complex *, complex *);
+ double c_abs(complex *);
+
+ /* Local variables */
+ integer i__, j, mn;
+ complex aii;
+ integer pvt;
+ real temp, temp2, tol3z;
+ extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
+, integer *, complex *, complex *, integer *, complex *);
+ integer offpi;
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer itemp;
+ extern doublereal scnrm2_(integer *, complex *, integer *);
+ extern /* Subroutine */ int clarfp_(integer *, complex *, complex *,
+ integer *, complex *);
+ extern doublereal slamch_(char *);
+ extern integer isamax_(integer *, real *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAQP2 computes a QR factorization with column pivoting of */
+/* the block A(OFFSET+1:M,1:N). */
+/* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* OFFSET (input) INTEGER */
+/* The number of rows of the matrix A that must be pivoted */
+/* but no factorized. OFFSET >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is */
+/* the triangular factor obtained; the elements in block */
+/* A(OFFSET+1:M,1:N) below the diagonal, together with the */
+/* array TAU, represent the orthogonal matrix Q as a product of */
+/* elementary reflectors. Block A(1:OFFSET,1:N) has been */
+/* accordingly pivoted, but no factorized. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
+/* to the front of A*P (a leading column); if JPVT(i) = 0, */
+/* the i-th column of A is a free column. */
+/* On exit, if JPVT(i) = k, then the i-th column of A*P */
+/* was the k-th column of A. */
+
+/* TAU (output) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors. */
+
+/* VN1 (input/output) REAL array, dimension (N) */
+/* The vector with the partial column norms. */
+
+/* VN2 (input/output) REAL array, dimension (N) */
+/* The vector with the exact column norms. */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
+/* X. Sun, Computer Science Dept., Duke University, USA */
+
+/* Partial column norm updating strategy modified by */
+/* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */
+/* University of Zagreb, Croatia. */
+/* June 2006. */
+/* For more details see LAPACK Working Note 176. */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --jpvt;
+ --tau;
+ --vn1;
+ --vn2;
+ --work;
+
+ /* Function Body */
+/* Computing MIN */
+ i__1 = *m - *offset;
+ mn = min(i__1,*n);
+ tol3z = sqrt(slamch_("Epsilon"));
+
+/* Compute factorization. */
+
+ i__1 = mn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+ offpi = *offset + i__;
+
+/* Determine ith pivot column and swap if necessary. */
+
+ i__2 = *n - i__ + 1;
+ pvt = i__ - 1 + isamax_(&i__2, &vn1[i__], &c__1);
+
+ if (pvt != i__) {
+ cswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
+ c__1);
+ itemp = jpvt[pvt];
+ jpvt[pvt] = jpvt[i__];
+ jpvt[i__] = itemp;
+ vn1[pvt] = vn1[i__];
+ vn2[pvt] = vn2[i__];
+ }
+
+/* Generate elementary reflector H(i). */
+
+ if (offpi < *m) {
+ i__2 = *m - offpi + 1;
+ clarfp_(&i__2, &a[offpi + i__ * a_dim1], &a[offpi + 1 + i__ *
+ a_dim1], &c__1, &tau[i__]);
+ } else {
+ clarfp_(&c__1, &a[*m + i__ * a_dim1], &a[*m + i__ * a_dim1], &
+ c__1, &tau[i__]);
+ }
+
+ if (i__ < *n) {
+
+/* Apply H(i)' to A(offset+i:m,i+1:n) from the left. */
+
+ i__2 = offpi + i__ * a_dim1;
+ aii.r = a[i__2].r, aii.i = a[i__2].i;
+ i__2 = offpi + i__ * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+ i__2 = *m - offpi + 1;
+ i__3 = *n - i__;
+ r_cnjg(&q__1, &tau[i__]);
+ clarf_("Left", &i__2, &i__3, &a[offpi + i__ * a_dim1], &c__1, &
+ q__1, &a[offpi + (i__ + 1) * a_dim1], lda, &work[1]);
+ i__2 = offpi + i__ * a_dim1;
+ a[i__2].r = aii.r, a[i__2].i = aii.i;
+ }
+
+/* Update partial column norms. */
+
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (vn1[j] != 0.f) {
+
+/* NOTE: The following 4 lines follow from the analysis in */
+/* Lapack Working Note 176. */
+
+/* Computing 2nd power */
+ r__1 = c_abs(&a[offpi + j * a_dim1]) / vn1[j];
+ temp = 1.f - r__1 * r__1;
+ temp = dmax(temp,0.f);
+/* Computing 2nd power */
+ r__1 = vn1[j] / vn2[j];
+ temp2 = temp * (r__1 * r__1);
+ if (temp2 <= tol3z) {
+ if (offpi < *m) {
+ i__3 = *m - offpi;
+ vn1[j] = scnrm2_(&i__3, &a[offpi + 1 + j * a_dim1], &
+ c__1);
+ vn2[j] = vn1[j];
+ } else {
+ vn1[j] = 0.f;
+ vn2[j] = 0.f;
+ }
+ } else {
+ vn1[j] *= sqrt(temp);
+ }
+ }
+/* L10: */
+ }
+
+/* L20: */
+ }
+
+ return 0;
+
+/* End of CLAQP2 */
+
+} /* claqp2_ */
diff --git a/SRC/claqps.c b/SRC/claqps.c
new file mode 100644
index 0000000..ae14316
--- /dev/null
+++ b/SRC/claqps.c
@@ -0,0 +1,367 @@
+/* claqps.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int claqps_(integer *m, integer *n, integer *offset, integer
+ *nb, integer *kb, complex *a, integer *lda, integer *jpvt, complex *
+ tau, real *vn1, real *vn2, complex *auxv, complex *f, integer *ldf)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, f_dim1, f_offset, i__1, i__2, i__3;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ void r_cnjg(complex *, complex *);
+ double c_abs(complex *);
+ integer i_nint(real *);
+
+ /* Local variables */
+ integer j, k, rk;
+ complex akk;
+ integer pvt;
+ real temp, temp2, tol3z;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), cgemv_(char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *, complex *, complex *, integer *), cswap_(
+ integer *, complex *, integer *, complex *, integer *);
+ integer itemp;
+ extern doublereal scnrm2_(integer *, complex *, integer *);
+ extern /* Subroutine */ int clarfp_(integer *, complex *, complex *,
+ integer *, complex *);
+ extern doublereal slamch_(char *);
+ integer lsticc;
+ extern integer isamax_(integer *, real *, integer *);
+ integer lastrk;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAQPS computes a step of QR factorization with column pivoting */
+/* of a complex M-by-N matrix A by using Blas-3. It tries to factorize */
+/* NB columns from A starting from the row OFFSET+1, and updates all */
+/* of the matrix with Blas-3 xGEMM. */
+
+/* In some cases, due to catastrophic cancellations, it cannot */
+/* factorize NB columns. Hence, the actual number of factorized */
+/* columns is returned in KB. */
+
+/* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0 */
+
+/* OFFSET (input) INTEGER */
+/* The number of rows of A that have been factorized in */
+/* previous steps. */
+
+/* NB (input) INTEGER */
+/* The number of columns to factorize. */
+
+/* KB (output) INTEGER */
+/* The number of columns actually factorized. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, block A(OFFSET+1:M,1:KB) is the triangular */
+/* factor obtained and block A(1:OFFSET,1:N) has been */
+/* accordingly pivoted, but no factorized. */
+/* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has */
+/* been updated. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* JPVT(I) = K <==> Column K of the full matrix A has been */
+/* permuted into position I in AP. */
+
+/* TAU (output) COMPLEX array, dimension (KB) */
+/* The scalar factors of the elementary reflectors. */
+
+/* VN1 (input/output) REAL array, dimension (N) */
+/* The vector with the partial column norms. */
+
+/* VN2 (input/output) REAL array, dimension (N) */
+/* The vector with the exact column norms. */
+
+/* AUXV (input/output) COMPLEX array, dimension (NB) */
+/* Auxiliar vector. */
+
+/* F (input/output) COMPLEX array, dimension (LDF,NB) */
+/* Matrix F' = L*Y'*A. */
+
+/* LDF (input) INTEGER */
+/* The leading dimension of the array F. LDF >= max(1,N). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
+/* X. Sun, Computer Science Dept., Duke University, USA */
+
+/* Partial column norm updating strategy modified by */
+/* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */
+/* University of Zagreb, Croatia. */
+/* June 2006. */
+/* For more details see LAPACK Working Note 176. */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --jpvt;
+ --tau;
+ --vn1;
+ --vn2;
+ --auxv;
+ f_dim1 = *ldf;
+ f_offset = 1 + f_dim1;
+ f -= f_offset;
+
+ /* Function Body */
+/* Computing MIN */
+ i__1 = *m, i__2 = *n + *offset;
+ lastrk = min(i__1,i__2);
+ lsticc = 0;
+ k = 0;
+ tol3z = sqrt(slamch_("Epsilon"));
+
+/* Beginning of while loop. */
+
+L10:
+ if (k < *nb && lsticc == 0) {
+ ++k;
+ rk = *offset + k;
+
+/* Determine ith pivot column and swap if necessary */
+
+ i__1 = *n - k + 1;
+ pvt = k - 1 + isamax_(&i__1, &vn1[k], &c__1);
+ if (pvt != k) {
+ cswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1);
+ i__1 = k - 1;
+ cswap_(&i__1, &f[pvt + f_dim1], ldf, &f[k + f_dim1], ldf);
+ itemp = jpvt[pvt];
+ jpvt[pvt] = jpvt[k];
+ jpvt[k] = itemp;
+ vn1[pvt] = vn1[k];
+ vn2[pvt] = vn2[k];
+ }
+
+/* Apply previous Householder reflectors to column K: */
+/* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)'. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j * f_dim1;
+ r_cnjg(&q__1, &f[k + j * f_dim1]);
+ f[i__2].r = q__1.r, f[i__2].i = q__1.i;
+/* L20: */
+ }
+ i__1 = *m - rk + 1;
+ i__2 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__1, &i__2, &q__1, &a[rk + a_dim1], lda,
+ &f[k + f_dim1], ldf, &c_b2, &a[rk + k * a_dim1], &c__1);
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j * f_dim1;
+ r_cnjg(&q__1, &f[k + j * f_dim1]);
+ f[i__2].r = q__1.r, f[i__2].i = q__1.i;
+/* L30: */
+ }
+ }
+
+/* Generate elementary reflector H(k). */
+
+ if (rk < *m) {
+ i__1 = *m - rk + 1;
+ clarfp_(&i__1, &a[rk + k * a_dim1], &a[rk + 1 + k * a_dim1], &
+ c__1, &tau[k]);
+ } else {
+ clarfp_(&c__1, &a[rk + k * a_dim1], &a[rk + k * a_dim1], &c__1, &
+ tau[k]);
+ }
+
+ i__1 = rk + k * a_dim1;
+ akk.r = a[i__1].r, akk.i = a[i__1].i;
+ i__1 = rk + k * a_dim1;
+ a[i__1].r = 1.f, a[i__1].i = 0.f;
+
+/* Compute Kth column of F: */
+
+/* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)'*A(RK:M,K). */
+
+ if (k < *n) {
+ i__1 = *m - rk + 1;
+ i__2 = *n - k;
+ cgemv_("Conjugate transpose", &i__1, &i__2, &tau[k], &a[rk + (k +
+ 1) * a_dim1], lda, &a[rk + k * a_dim1], &c__1, &c_b1, &f[
+ k + 1 + k * f_dim1], &c__1);
+ }
+
+/* Padding F(1:K,K) with zeros. */
+
+ i__1 = k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + k * f_dim1;
+ f[i__2].r = 0.f, f[i__2].i = 0.f;
+/* L40: */
+ }
+
+/* Incremental updating of F: */
+/* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)' */
+/* *A(RK:M,K). */
+
+ if (k > 1) {
+ i__1 = *m - rk + 1;
+ i__2 = k - 1;
+ i__3 = k;
+ q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i;
+ cgemv_("Conjugate transpose", &i__1, &i__2, &q__1, &a[rk + a_dim1]
+, lda, &a[rk + k * a_dim1], &c__1, &c_b1, &auxv[1], &c__1);
+
+ i__1 = k - 1;
+ cgemv_("No transpose", n, &i__1, &c_b2, &f[f_dim1 + 1], ldf, &
+ auxv[1], &c__1, &c_b2, &f[k * f_dim1 + 1], &c__1);
+ }
+
+/* Update the current row of A: */
+/* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)'. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "Conjugate transpose", &c__1, &i__1, &k, &
+ q__1, &a[rk + a_dim1], lda, &f[k + 1 + f_dim1], ldf, &
+ c_b2, &a[rk + (k + 1) * a_dim1], lda);
+ }
+
+/* Update partial column norms. */
+
+ if (rk < lastrk) {
+ i__1 = *n;
+ for (j = k + 1; j <= i__1; ++j) {
+ if (vn1[j] != 0.f) {
+
+/* NOTE: The following 4 lines follow from the analysis in */
+/* Lapack Working Note 176. */
+
+ temp = c_abs(&a[rk + j * a_dim1]) / vn1[j];
+/* Computing MAX */
+ r__1 = 0.f, r__2 = (temp + 1.f) * (1.f - temp);
+ temp = dmax(r__1,r__2);
+/* Computing 2nd power */
+ r__1 = vn1[j] / vn2[j];
+ temp2 = temp * (r__1 * r__1);
+ if (temp2 <= tol3z) {
+ vn2[j] = (real) lsticc;
+ lsticc = j;
+ } else {
+ vn1[j] *= sqrt(temp);
+ }
+ }
+/* L50: */
+ }
+ }
+
+ i__1 = rk + k * a_dim1;
+ a[i__1].r = akk.r, a[i__1].i = akk.i;
+
+/* End of while loop. */
+
+ goto L10;
+ }
+ *kb = k;
+ rk = *offset + *kb;
+
+/* Apply the block reflector to the rest of the matrix: */
+/* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - */
+/* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)'. */
+
+/* Computing MIN */
+ i__1 = *n, i__2 = *m - *offset;
+ if (*kb < min(i__1,i__2)) {
+ i__1 = *m - rk;
+ i__2 = *n - *kb;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "Conjugate transpose", &i__1, &i__2, kb, &q__1,
+ &a[rk + 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b2, &
+ a[rk + 1 + (*kb + 1) * a_dim1], lda);
+ }
+
+/* Recomputation of difficult columns. */
+
+L60:
+ if (lsticc > 0) {
+ itemp = i_nint(&vn2[lsticc]);
+ i__1 = *m - rk;
+ vn1[lsticc] = scnrm2_(&i__1, &a[rk + 1 + lsticc * a_dim1], &c__1);
+
+/* NOTE: The computation of VN1( LSTICC ) relies on the fact that */
+/* SNRM2 does not fail on vectors with norm below the value of */
+/* SQRT(DLAMCH('S')) */
+
+ vn2[lsticc] = vn1[lsticc];
+ lsticc = itemp;
+ goto L60;
+ }
+
+ return 0;
+
+/* End of CLAQPS */
+
+} /* claqps_ */
diff --git a/SRC/claqr0.c b/SRC/claqr0.c
new file mode 100644
index 0000000..89c73fe
--- /dev/null
+++ b/SRC/claqr0.c
@@ -0,0 +1,784 @@
+/* claqr0.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__13 = 13;
+static integer c__15 = 15;
+static integer c_n1 = -1;
+static integer c__12 = 12;
+static integer c__14 = 14;
+static integer c__16 = 16;
+static logical c_false = FALSE_;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int claqr0_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, complex *h__, integer *ldh, complex *w,
+ integer *iloz, integer *ihiz, complex *z__, integer *ldz, complex *
+ work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8;
+ complex q__1, q__2, q__3, q__4, q__5;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void c_sqrt(complex *, complex *);
+
+ /* Local variables */
+ integer i__, k;
+ real s;
+ complex aa, bb, cc, dd;
+ integer ld, nh, it, ks, kt, ku, kv, ls, ns, nw;
+ complex tr2, det;
+ integer inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot, nmin;
+ complex swap;
+ integer ktop;
+ complex zdum[1] /* was [1][1] */;
+ integer kacc22, itmax, nsmax, nwmax, kwtop;
+ extern /* Subroutine */ int claqr3_(logical *, logical *, integer *,
+ integer *, integer *, integer *, complex *, integer *, integer *,
+ integer *, complex *, integer *, integer *, integer *, complex *,
+ complex *, integer *, integer *, complex *, integer *, integer *,
+ complex *, integer *, complex *, integer *), claqr4_(logical *,
+ logical *, integer *, integer *, integer *, complex *, integer *,
+ complex *, integer *, integer *, complex *, integer *, complex *,
+ integer *, integer *), claqr5_(logical *, logical *, integer *,
+ integer *, integer *, integer *, integer *, complex *, complex *,
+ integer *, integer *, integer *, complex *, integer *, complex *,
+ integer *, complex *, integer *, integer *, complex *, integer *,
+ integer *, complex *, integer *);
+ integer nibble;
+ extern /* Subroutine */ int clahqr_(logical *, logical *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ integer *, complex *, integer *, integer *), clacpy_(char *,
+ integer *, integer *, complex *, integer *, complex *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ char jbcmpz[2];
+ complex rtdisc;
+ integer nwupbd;
+ logical sorted;
+ integer lwkopt;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAQR0 computes the eigenvalues of a Hessenberg matrix H */
+/* and, optionally, the matrices T and Z from the Schur decomposition */
+/* H = Z T Z**H, where T is an upper triangular matrix (the */
+/* Schur form), and Z is the unitary matrix of Schur vectors. */
+
+/* Optionally Z may be postmultiplied into an input unitary */
+/* matrix Q so that this routine can give the Schur factorization */
+/* of a matrix A which has been reduced to the Hessenberg form H */
+/* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. */
+
+/* Arguments */
+/* ========= */
+
+/* WANTT (input) LOGICAL */
+/* = .TRUE. : the full Schur form T is required; */
+/* = .FALSE.: only eigenvalues are required. */
+
+/* WANTZ (input) LOGICAL */
+/* = .TRUE. : the matrix of Schur vectors Z is required; */
+/* = .FALSE.: Schur vectors are not required. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N .GE. 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that H is already upper triangular in rows */
+/* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, */
+/* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a */
+/* previous call to CGEBAL, and then passed to CGEHRD when the */
+/* matrix output by CGEBAL is reduced to Hessenberg form. */
+/* Otherwise, ILO and IHI should be set to 1 and N, */
+/* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */
+/* If N = 0, then ILO = 1 and IHI = 0. */
+
+/* H (input/output) COMPLEX array, dimension (LDH,N) */
+/* On entry, the upper Hessenberg matrix H. */
+/* On exit, if INFO = 0 and WANTT is .TRUE., then H */
+/* contains the upper triangular matrix T from the Schur */
+/* decomposition (the Schur form). If INFO = 0 and WANT is */
+/* .FALSE., then the contents of H are unspecified on exit. */
+/* (The output value of H when INFO.GT.0 is given under the */
+/* description of INFO below.) */
+
+/* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and */
+/* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH .GE. max(1,N). */
+
+/* W (output) COMPLEX array, dimension (N) */
+/* The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored */
+/* in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are */
+/* stored in the same order as on the diagonal of the Schur */
+/* form returned in H, with W(i) = H(i,i). */
+
+/* Z (input/output) COMPLEX array, dimension (LDZ,IHI) */
+/* If WANTZ is .FALSE., then Z is not referenced. */
+/* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is */
+/* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the */
+/* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). */
+/* (The output value of Z when INFO.GT.0 is given under */
+/* the description of INFO below.) */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. if WANTZ is .TRUE. */
+/* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. */
+
+/* WORK (workspace/output) COMPLEX array, dimension LWORK */
+/* On exit, if LWORK = -1, WORK(1) returns an estimate of */
+/* the optimal value for LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK .GE. max(1,N) */
+/* is sufficient, but LWORK typically as large as 6*N may */
+/* be required for optimal performance. A workspace query */
+/* to determine the optimal workspace size is recommended. */
+
+/* If LWORK = -1, then CLAQR0 does a workspace query. */
+/* In this case, CLAQR0 checks the input parameters and */
+/* estimates the optimal workspace size for the given */
+/* values of N, ILO and IHI. The estimate is returned */
+/* in WORK(1). No error message related to LWORK is */
+/* issued by XERBLA. Neither H nor Z are accessed. */
+
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* .GT. 0: if INFO = i, CLAQR0 failed to compute all of */
+/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */
+/* and WI contain those eigenvalues which have been */
+/* successfully computed. (Failures are rare.) */
+
+/* If INFO .GT. 0 and WANT is .FALSE., then on exit, */
+/* the remaining unconverged eigenvalues are the eigen- */
+/* values of the upper Hessenberg matrix rows and */
+/* columns ILO through INFO of the final, output */
+/* value of H. */
+
+/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */
+
+/* (*) (initial value of H)*U = U*(final value of H) */
+
+/* where U is a unitary matrix. The final */
+/* value of H is upper Hessenberg and triangular in */
+/* rows and columns INFO+1 through IHI. */
+
+/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
+
+/* (final value of Z(ILO:IHI,ILOZ:IHIZ) */
+/* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U */
+
+/* where U is the unitary matrix in (*) (regard- */
+/* less of the value of WANTT.) */
+
+/* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not */
+/* accessed. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* References: */
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */
+/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */
+/* 929--947, 2002. */
+
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */
+/* of Matrix Analysis, volume 23, pages 948--973, 2002. */
+
+/* ================================================================ */
+/* .. Parameters .. */
+
+/* ==== Matrices of order NTINY or smaller must be processed by */
+/* . CLAHQR because of insufficient subdiagonal scratch space. */
+/* . (This is a hard limit.) ==== */
+
+/* ==== Exceptional deflation windows: try to cure rare */
+/* . slow convergence by varying the size of the */
+/* . deflation window after KEXNW iterations. ==== */
+
+/* ==== Exceptional shifts: try to cure rare slow convergence */
+/* . with ad-hoc exceptional shifts every KEXSH iterations. */
+/* . ==== */
+
+/* ==== The constant WILK1 is used to form the exceptional */
+/* . shifts. ==== */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* ==== Quick return for N = 0: nothing to do. ==== */
+
+ if (*n == 0) {
+ work[1].r = 1.f, work[1].i = 0.f;
+ return 0;
+ }
+
+ if (*n <= 11) {
+
+/* ==== Tiny matrices must use CLAHQR. ==== */
+
+ lwkopt = 1;
+ if (*lwork != -1) {
+ clahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1],
+ iloz, ihiz, &z__[z_offset], ldz, info);
+ }
+ } else {
+
+/* ==== Use small bulge multi-shift QR with aggressive early */
+/* . deflation on larger-than-tiny matrices. ==== */
+
+/* ==== Hope for the best. ==== */
+
+ *info = 0;
+
+/* ==== Set up job flags for ILAENV. ==== */
+
+ if (*wantt) {
+ *(unsigned char *)jbcmpz = 'S';
+ } else {
+ *(unsigned char *)jbcmpz = 'E';
+ }
+ if (*wantz) {
+ *(unsigned char *)&jbcmpz[1] = 'V';
+ } else {
+ *(unsigned char *)&jbcmpz[1] = 'N';
+ }
+
+/* ==== NWR = recommended deflation window size. At this */
+/* . point, N .GT. NTINY = 11, so there is enough */
+/* . subdiagonal workspace for NWR.GE.2 as required. */
+/* . (In fact, there is enough subdiagonal space for */
+/* . NWR.GE.3.) ==== */
+
+ nwr = ilaenv_(&c__13, "CLAQR0", jbcmpz, n, ilo, ihi, lwork);
+ nwr = max(2,nwr);
+/* Computing MIN */
+ i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = min(i__1,i__2);
+ nwr = min(i__1,nwr);
+
+/* ==== NSR = recommended number of simultaneous shifts. */
+/* . At this point N .GT. NTINY = 11, so there is at */
+/* . enough subdiagonal workspace for NSR to be even */
+/* . and greater than or equal to two as required. ==== */
+
+ nsr = ilaenv_(&c__15, "CLAQR0", jbcmpz, n, ilo, ihi, lwork);
+/* Computing MIN */
+ i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = min(i__1,i__2), i__2 = *ihi -
+ *ilo;
+ nsr = min(i__1,i__2);
+/* Computing MAX */
+ i__1 = 2, i__2 = nsr - nsr % 2;
+ nsr = max(i__1,i__2);
+
+/* ==== Estimate optimal workspace ==== */
+
+/* ==== Workspace query call to CLAQR3 ==== */
+
+ i__1 = nwr + 1;
+ claqr3_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz,
+ ihiz, &z__[z_offset], ldz, &ls, &ld, &w[1], &h__[h_offset],
+ ldh, n, &h__[h_offset], ldh, n, &h__[h_offset], ldh, &work[1],
+ &c_n1);
+
+/* ==== Optimal workspace = MAX(CLAQR5, CLAQR3) ==== */
+
+/* Computing MAX */
+ i__1 = nsr * 3 / 2, i__2 = (integer) work[1].r;
+ lwkopt = max(i__1,i__2);
+
+/* ==== Quick return in case of workspace query. ==== */
+
+ if (*lwork == -1) {
+ r__1 = (real) lwkopt;
+ q__1.r = r__1, q__1.i = 0.f;
+ work[1].r = q__1.r, work[1].i = q__1.i;
+ return 0;
+ }
+
+/* ==== CLAHQR/CLAQR0 crossover point ==== */
+
+ nmin = ilaenv_(&c__12, "CLAQR0", jbcmpz, n, ilo, ihi, lwork);
+ nmin = max(11,nmin);
+
+/* ==== Nibble crossover point ==== */
+
+ nibble = ilaenv_(&c__14, "CLAQR0", jbcmpz, n, ilo, ihi, lwork);
+ nibble = max(0,nibble);
+
+/* ==== Accumulate reflections during ttswp? Use block */
+/* . 2-by-2 structure during matrix-matrix multiply? ==== */
+
+ kacc22 = ilaenv_(&c__16, "CLAQR0", jbcmpz, n, ilo, ihi, lwork);
+ kacc22 = max(0,kacc22);
+ kacc22 = min(2,kacc22);
+
+/* ==== NWMAX = the largest possible deflation window for */
+/* . which there is sufficient workspace. ==== */
+
+/* Computing MIN */
+ i__1 = (*n - 1) / 3, i__2 = *lwork / 2;
+ nwmax = min(i__1,i__2);
+ nw = nwmax;
+
+/* ==== NSMAX = the Largest number of simultaneous shifts */
+/* . for which there is sufficient workspace. ==== */
+
+/* Computing MIN */
+ i__1 = (*n + 6) / 9, i__2 = (*lwork << 1) / 3;
+ nsmax = min(i__1,i__2);
+ nsmax -= nsmax % 2;
+
+/* ==== NDFL: an iteration count restarted at deflation. ==== */
+
+ ndfl = 1;
+
+/* ==== ITMAX = iteration limit ==== */
+
+/* Computing MAX */
+ i__1 = 10, i__2 = *ihi - *ilo + 1;
+ itmax = max(i__1,i__2) * 30;
+
+/* ==== Last row and column in the active block ==== */
+
+ kbot = *ihi;
+
+/* ==== Main Loop ==== */
+
+ i__1 = itmax;
+ for (it = 1; it <= i__1; ++it) {
+
+/* ==== Done when KBOT falls below ILO ==== */
+
+ if (kbot < *ilo) {
+ goto L80;
+ }
+
+/* ==== Locate active block ==== */
+
+ i__2 = *ilo + 1;
+ for (k = kbot; k >= i__2; --k) {
+ i__3 = k + (k - 1) * h_dim1;
+ if (h__[i__3].r == 0.f && h__[i__3].i == 0.f) {
+ goto L20;
+ }
+/* L10: */
+ }
+ k = *ilo;
+L20:
+ ktop = k;
+
+/* ==== Select deflation window size: */
+/* . Typical Case: */
+/* . If possible and advisable, nibble the entire */
+/* . active block. If not, use size MIN(NWR,NWMAX) */
+/* . or MIN(NWR+1,NWMAX) depending upon which has */
+/* . the smaller corresponding subdiagonal entry */
+/* . (a heuristic). */
+/* . */
+/* . Exceptional Case: */
+/* . If there have been no deflations in KEXNW or */
+/* . more iterations, then vary the deflation window */
+/* . size. At first, because, larger windows are, */
+/* . in general, more powerful than smaller ones, */
+/* . rapidly increase the window to the maximum possible. */
+/* . Then, gradually reduce the window size. ==== */
+
+ nh = kbot - ktop + 1;
+ nwupbd = min(nh,nwmax);
+ if (ndfl < 5) {
+ nw = min(nwupbd,nwr);
+ } else {
+/* Computing MIN */
+ i__2 = nwupbd, i__3 = nw << 1;
+ nw = min(i__2,i__3);
+ }
+ if (nw < nwmax) {
+ if (nw >= nh - 1) {
+ nw = nh;
+ } else {
+ kwtop = kbot - nw + 1;
+ i__2 = kwtop + (kwtop - 1) * h_dim1;
+ i__3 = kwtop - 1 + (kwtop - 2) * h_dim1;
+ if ((r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
+ h__[kwtop + (kwtop - 1) * h_dim1]), dabs(r__2)) >
+ (r__3 = h__[i__3].r, dabs(r__3)) + (r__4 = r_imag(
+ &h__[kwtop - 1 + (kwtop - 2) * h_dim1]), dabs(
+ r__4))) {
+ ++nw;
+ }
+ }
+ }
+ if (ndfl < 5) {
+ ndec = -1;
+ } else if (ndec >= 0 || nw >= nwupbd) {
+ ++ndec;
+ if (nw - ndec < 2) {
+ ndec = 0;
+ }
+ nw -= ndec;
+ }
+
+/* ==== Aggressive early deflation: */
+/* . split workspace under the subdiagonal into */
+/* . - an nw-by-nw work array V in the lower */
+/* . left-hand-corner, */
+/* . - an NW-by-at-least-NW-but-more-is-better */
+/* . (NW-by-NHO) horizontal work array along */
+/* . the bottom edge, */
+/* . - an at-least-NW-but-more-is-better (NHV-by-NW) */
+/* . vertical work array along the left-hand-edge. */
+/* . ==== */
+
+ kv = *n - nw + 1;
+ kt = nw + 1;
+ nho = *n - nw - 1 - kt + 1;
+ kwv = nw + 2;
+ nve = *n - nw - kwv + 1;
+
+/* ==== Aggressive early deflation ==== */
+
+ claqr3_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh,
+ iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &w[1], &h__[kv
+ + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1], ldh, &nve, &
+ h__[kwv + h_dim1], ldh, &work[1], lwork);
+
+/* ==== Adjust KBOT accounting for new deflations. ==== */
+
+ kbot -= ld;
+
+/* ==== KS points to the shifts. ==== */
+
+ ks = kbot - ls + 1;
+
+/* ==== Skip an expensive QR sweep if there is a (partly */
+/* . heuristic) reason to expect that many eigenvalues */
+/* . will deflate without it. Here, the QR sweep is */
+/* . skipped if many eigenvalues have just been deflated */
+/* . or if the remaining active block is small. */
+
+ if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > min(
+ nmin,nwmax)) {
+
+/* ==== NS = nominal number of simultaneous shifts. */
+/* . This may be lowered (slightly) if CLAQR3 */
+/* . did not provide that many shifts. ==== */
+
+/* Computing MIN */
+/* Computing MAX */
+ i__4 = 2, i__5 = kbot - ktop;
+ i__2 = min(nsmax,nsr), i__3 = max(i__4,i__5);
+ ns = min(i__2,i__3);
+ ns -= ns % 2;
+
+/* ==== If there have been no deflations */
+/* . in a multiple of KEXSH iterations, */
+/* . then try exceptional shifts. */
+/* . Otherwise use shifts provided by */
+/* . CLAQR3 above or from the eigenvalues */
+/* . of a trailing principal submatrix. ==== */
+
+ if (ndfl % 6 == 0) {
+ ks = kbot - ns + 1;
+ i__2 = ks + 1;
+ for (i__ = kbot; i__ >= i__2; i__ += -2) {
+ i__3 = i__;
+ i__4 = i__ + i__ * h_dim1;
+ i__5 = i__ + (i__ - 1) * h_dim1;
+ r__3 = ((r__1 = h__[i__5].r, dabs(r__1)) + (r__2 =
+ r_imag(&h__[i__ + (i__ - 1) * h_dim1]), dabs(
+ r__2))) * .75f;
+ q__1.r = h__[i__4].r + r__3, q__1.i = h__[i__4].i;
+ w[i__3].r = q__1.r, w[i__3].i = q__1.i;
+ i__3 = i__ - 1;
+ i__4 = i__;
+ w[i__3].r = w[i__4].r, w[i__3].i = w[i__4].i;
+/* L30: */
+ }
+ } else {
+
+/* ==== Got NS/2 or fewer shifts? Use CLAQR4 or */
+/* . CLAHQR on a trailing principal submatrix to */
+/* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, */
+/* . there is enough space below the subdiagonal */
+/* . to fit an NS-by-NS scratch array.) ==== */
+
+ if (kbot - ks + 1 <= ns / 2) {
+ ks = kbot - ns + 1;
+ kt = *n - ns + 1;
+ clacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, &
+ h__[kt + h_dim1], ldh);
+ if (ns > nmin) {
+ claqr4_(&c_false, &c_false, &ns, &c__1, &ns, &h__[
+ kt + h_dim1], ldh, &w[ks], &c__1, &c__1,
+ zdum, &c__1, &work[1], lwork, &inf);
+ } else {
+ clahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[
+ kt + h_dim1], ldh, &w[ks], &c__1, &c__1,
+ zdum, &c__1, &inf);
+ }
+ ks += inf;
+
+/* ==== In case of a rare QR failure use */
+/* . eigenvalues of the trailing 2-by-2 */
+/* . principal submatrix. Scale to avoid */
+/* . overflows, underflows and subnormals. */
+/* . (The scale factor S can not be zero, */
+/* . because H(KBOT,KBOT-1) is nonzero.) ==== */
+
+ if (ks >= kbot) {
+ i__2 = kbot - 1 + (kbot - 1) * h_dim1;
+ i__3 = kbot + (kbot - 1) * h_dim1;
+ i__4 = kbot - 1 + kbot * h_dim1;
+ i__5 = kbot + kbot * h_dim1;
+ s = (r__1 = h__[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&h__[kbot - 1 + (kbot - 1) *
+ h_dim1]), dabs(r__2)) + ((r__3 = h__[i__3]
+ .r, dabs(r__3)) + (r__4 = r_imag(&h__[
+ kbot + (kbot - 1) * h_dim1]), dabs(r__4)))
+ + ((r__5 = h__[i__4].r, dabs(r__5)) + (
+ r__6 = r_imag(&h__[kbot - 1 + kbot *
+ h_dim1]), dabs(r__6))) + ((r__7 = h__[
+ i__5].r, dabs(r__7)) + (r__8 = r_imag(&
+ h__[kbot + kbot * h_dim1]), dabs(r__8)));
+ i__2 = kbot - 1 + (kbot - 1) * h_dim1;
+ q__1.r = h__[i__2].r / s, q__1.i = h__[i__2].i /
+ s;
+ aa.r = q__1.r, aa.i = q__1.i;
+ i__2 = kbot + (kbot - 1) * h_dim1;
+ q__1.r = h__[i__2].r / s, q__1.i = h__[i__2].i /
+ s;
+ cc.r = q__1.r, cc.i = q__1.i;
+ i__2 = kbot - 1 + kbot * h_dim1;
+ q__1.r = h__[i__2].r / s, q__1.i = h__[i__2].i /
+ s;
+ bb.r = q__1.r, bb.i = q__1.i;
+ i__2 = kbot + kbot * h_dim1;
+ q__1.r = h__[i__2].r / s, q__1.i = h__[i__2].i /
+ s;
+ dd.r = q__1.r, dd.i = q__1.i;
+ q__2.r = aa.r + dd.r, q__2.i = aa.i + dd.i;
+ q__1.r = q__2.r / 2.f, q__1.i = q__2.i / 2.f;
+ tr2.r = q__1.r, tr2.i = q__1.i;
+ q__3.r = aa.r - tr2.r, q__3.i = aa.i - tr2.i;
+ q__4.r = dd.r - tr2.r, q__4.i = dd.i - tr2.i;
+ q__2.r = q__3.r * q__4.r - q__3.i * q__4.i,
+ q__2.i = q__3.r * q__4.i + q__3.i *
+ q__4.r;
+ q__5.r = bb.r * cc.r - bb.i * cc.i, q__5.i = bb.r
+ * cc.i + bb.i * cc.r;
+ q__1.r = q__2.r - q__5.r, q__1.i = q__2.i -
+ q__5.i;
+ det.r = q__1.r, det.i = q__1.i;
+ q__2.r = -det.r, q__2.i = -det.i;
+ c_sqrt(&q__1, &q__2);
+ rtdisc.r = q__1.r, rtdisc.i = q__1.i;
+ i__2 = kbot - 1;
+ q__2.r = tr2.r + rtdisc.r, q__2.i = tr2.i +
+ rtdisc.i;
+ q__1.r = s * q__2.r, q__1.i = s * q__2.i;
+ w[i__2].r = q__1.r, w[i__2].i = q__1.i;
+ i__2 = kbot;
+ q__2.r = tr2.r - rtdisc.r, q__2.i = tr2.i -
+ rtdisc.i;
+ q__1.r = s * q__2.r, q__1.i = s * q__2.i;
+ w[i__2].r = q__1.r, w[i__2].i = q__1.i;
+
+ ks = kbot - 1;
+ }
+ }
+
+ if (kbot - ks + 1 > ns) {
+
+/* ==== Sort the shifts (Helps a little) ==== */
+
+ sorted = FALSE_;
+ i__2 = ks + 1;
+ for (k = kbot; k >= i__2; --k) {
+ if (sorted) {
+ goto L60;
+ }
+ sorted = TRUE_;
+ i__3 = k - 1;
+ for (i__ = ks; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__ + 1;
+ if ((r__1 = w[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&w[i__]), dabs(r__2)) < (r__3 =
+ w[i__5].r, dabs(r__3)) + (r__4 =
+ r_imag(&w[i__ + 1]), dabs(r__4))) {
+ sorted = FALSE_;
+ i__4 = i__;
+ swap.r = w[i__4].r, swap.i = w[i__4].i;
+ i__4 = i__;
+ i__5 = i__ + 1;
+ w[i__4].r = w[i__5].r, w[i__4].i = w[i__5]
+ .i;
+ i__4 = i__ + 1;
+ w[i__4].r = swap.r, w[i__4].i = swap.i;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+L60:
+ ;
+ }
+ }
+
+/* ==== If there are only two shifts, then use */
+/* . only one. ==== */
+
+ if (kbot - ks + 1 == 2) {
+ i__2 = kbot;
+ i__3 = kbot + kbot * h_dim1;
+ q__2.r = w[i__2].r - h__[i__3].r, q__2.i = w[i__2].i -
+ h__[i__3].i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ i__4 = kbot - 1;
+ i__5 = kbot + kbot * h_dim1;
+ q__4.r = w[i__4].r - h__[i__5].r, q__4.i = w[i__4].i -
+ h__[i__5].i;
+ q__3.r = q__4.r, q__3.i = q__4.i;
+ if ((r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
+ dabs(r__2)) < (r__3 = q__3.r, dabs(r__3)) + (r__4
+ = r_imag(&q__3), dabs(r__4))) {
+ i__2 = kbot - 1;
+ i__3 = kbot;
+ w[i__2].r = w[i__3].r, w[i__2].i = w[i__3].i;
+ } else {
+ i__2 = kbot;
+ i__3 = kbot - 1;
+ w[i__2].r = w[i__3].r, w[i__2].i = w[i__3].i;
+ }
+ }
+
+/* ==== Use up to NS of the the smallest magnatiude */
+/* . shifts. If there aren't NS shifts available, */
+/* . then use them all, possibly dropping one to */
+/* . make the number of shifts even. ==== */
+
+/* Computing MIN */
+ i__2 = ns, i__3 = kbot - ks + 1;
+ ns = min(i__2,i__3);
+ ns -= ns % 2;
+ ks = kbot - ns + 1;
+
+/* ==== Small-bulge multi-shift QR sweep: */
+/* . split workspace under the subdiagonal into */
+/* . - a KDU-by-KDU work array U in the lower */
+/* . left-hand-corner, */
+/* . - a KDU-by-at-least-KDU-but-more-is-better */
+/* . (KDU-by-NHo) horizontal work array WH along */
+/* . the bottom edge, */
+/* . - and an at-least-KDU-but-more-is-better-by-KDU */
+/* . (NVE-by-KDU) vertical work WV arrow along */
+/* . the left-hand-edge. ==== */
+
+ kdu = ns * 3 - 3;
+ ku = *n - kdu + 1;
+ kwh = kdu + 1;
+ nho = *n - kdu - 3 - (kdu + 1) + 1;
+ kwv = kdu + 4;
+ nve = *n - kdu - kwv + 1;
+
+/* ==== Small-bulge multi-shift QR sweep ==== */
+
+ claqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &w[ks], &
+ h__[h_offset], ldh, iloz, ihiz, &z__[z_offset], ldz, &
+ work[1], &c__3, &h__[ku + h_dim1], ldh, &nve, &h__[
+ kwv + h_dim1], ldh, &nho, &h__[ku + kwh * h_dim1],
+ ldh);
+ }
+
+/* ==== Note progress (or the lack of it). ==== */
+
+ if (ld > 0) {
+ ndfl = 1;
+ } else {
+ ++ndfl;
+ }
+
+/* ==== End of main loop ==== */
+/* L70: */
+ }
+
+/* ==== Iteration limit exceeded. Set INFO to show where */
+/* . the problem occurred and exit. ==== */
+
+ *info = kbot;
+L80:
+ ;
+ }
+
+/* ==== Return the optimal value of LWORK. ==== */
+
+ r__1 = (real) lwkopt;
+ q__1.r = r__1, q__1.i = 0.f;
+ work[1].r = q__1.r, work[1].i = q__1.i;
+
+/* ==== End of CLAQR0 ==== */
+
+ return 0;
+} /* claqr0_ */
diff --git a/SRC/claqr1.c b/SRC/claqr1.c
new file mode 100644
index 0000000..3f370be
--- /dev/null
+++ b/SRC/claqr1.c
@@ -0,0 +1,197 @@
+/* claqr1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int claqr1_(integer *n, complex *h__, integer *ldh, complex *
+ s1, complex *s2, complex *v)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4, r__5, r__6;
+ complex q__1, q__2, q__3, q__4, q__5, q__6, q__7, q__8;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ real s;
+ complex h21s, h31s;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Given a 2-by-2 or 3-by-3 matrix H, CLAQR1 sets v to a */
+/* scalar multiple of the first column of the product */
+
+/* (*) K = (H - s1*I)*(H - s2*I) */
+
+/* scaling to avoid overflows and most underflows. */
+
+/* This is useful for starting double implicit shift bulges */
+/* in the QR algorithm. */
+
+
+/* N (input) integer */
+/* Order of the matrix H. N must be either 2 or 3. */
+
+/* H (input) COMPLEX array of dimension (LDH,N) */
+/* The 2-by-2 or 3-by-3 matrix H in (*). */
+
+/* LDH (input) integer */
+/* The leading dimension of H as declared in */
+/* the calling procedure. LDH.GE.N */
+
+/* S1 (input) COMPLEX */
+/* S2 S1 and S2 are the shifts defining K in (*) above. */
+
+/* V (output) COMPLEX array of dimension N */
+/* A scalar multiple of the first column of the */
+/* matrix K in (*). */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --v;
+
+ /* Function Body */
+ if (*n == 2) {
+ i__1 = h_dim1 + 1;
+ q__2.r = h__[i__1].r - s2->r, q__2.i = h__[i__1].i - s2->i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ i__2 = h_dim1 + 2;
+ s = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1), dabs(r__2))
+ + ((r__3 = h__[i__2].r, dabs(r__3)) + (r__4 = r_imag(&h__[
+ h_dim1 + 2]), dabs(r__4)));
+ if (s == 0.f) {
+ v[1].r = 0.f, v[1].i = 0.f;
+ v[2].r = 0.f, v[2].i = 0.f;
+ } else {
+ i__1 = h_dim1 + 2;
+ q__1.r = h__[i__1].r / s, q__1.i = h__[i__1].i / s;
+ h21s.r = q__1.r, h21s.i = q__1.i;
+ i__1 = (h_dim1 << 1) + 1;
+ q__2.r = h21s.r * h__[i__1].r - h21s.i * h__[i__1].i, q__2.i =
+ h21s.r * h__[i__1].i + h21s.i * h__[i__1].r;
+ i__2 = h_dim1 + 1;
+ q__4.r = h__[i__2].r - s1->r, q__4.i = h__[i__2].i - s1->i;
+ i__3 = h_dim1 + 1;
+ q__6.r = h__[i__3].r - s2->r, q__6.i = h__[i__3].i - s2->i;
+ q__5.r = q__6.r / s, q__5.i = q__6.i / s;
+ q__3.r = q__4.r * q__5.r - q__4.i * q__5.i, q__3.i = q__4.r *
+ q__5.i + q__4.i * q__5.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ v[1].r = q__1.r, v[1].i = q__1.i;
+ i__1 = h_dim1 + 1;
+ i__2 = (h_dim1 << 1) + 2;
+ q__4.r = h__[i__1].r + h__[i__2].r, q__4.i = h__[i__1].i + h__[
+ i__2].i;
+ q__3.r = q__4.r - s1->r, q__3.i = q__4.i - s1->i;
+ q__2.r = q__3.r - s2->r, q__2.i = q__3.i - s2->i;
+ q__1.r = h21s.r * q__2.r - h21s.i * q__2.i, q__1.i = h21s.r *
+ q__2.i + h21s.i * q__2.r;
+ v[2].r = q__1.r, v[2].i = q__1.i;
+ }
+ } else {
+ i__1 = h_dim1 + 1;
+ q__2.r = h__[i__1].r - s2->r, q__2.i = h__[i__1].i - s2->i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ i__2 = h_dim1 + 2;
+ i__3 = h_dim1 + 3;
+ s = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1), dabs(r__2))
+ + ((r__3 = h__[i__2].r, dabs(r__3)) + (r__4 = r_imag(&h__[
+ h_dim1 + 2]), dabs(r__4))) + ((r__5 = h__[i__3].r, dabs(r__5))
+ + (r__6 = r_imag(&h__[h_dim1 + 3]), dabs(r__6)));
+ if (s == 0.f) {
+ v[1].r = 0.f, v[1].i = 0.f;
+ v[2].r = 0.f, v[2].i = 0.f;
+ v[3].r = 0.f, v[3].i = 0.f;
+ } else {
+ i__1 = h_dim1 + 2;
+ q__1.r = h__[i__1].r / s, q__1.i = h__[i__1].i / s;
+ h21s.r = q__1.r, h21s.i = q__1.i;
+ i__1 = h_dim1 + 3;
+ q__1.r = h__[i__1].r / s, q__1.i = h__[i__1].i / s;
+ h31s.r = q__1.r, h31s.i = q__1.i;
+ i__1 = h_dim1 + 1;
+ q__4.r = h__[i__1].r - s1->r, q__4.i = h__[i__1].i - s1->i;
+ i__2 = h_dim1 + 1;
+ q__6.r = h__[i__2].r - s2->r, q__6.i = h__[i__2].i - s2->i;
+ q__5.r = q__6.r / s, q__5.i = q__6.i / s;
+ q__3.r = q__4.r * q__5.r - q__4.i * q__5.i, q__3.i = q__4.r *
+ q__5.i + q__4.i * q__5.r;
+ i__3 = (h_dim1 << 1) + 1;
+ q__7.r = h__[i__3].r * h21s.r - h__[i__3].i * h21s.i, q__7.i =
+ h__[i__3].r * h21s.i + h__[i__3].i * h21s.r;
+ q__2.r = q__3.r + q__7.r, q__2.i = q__3.i + q__7.i;
+ i__4 = h_dim1 * 3 + 1;
+ q__8.r = h__[i__4].r * h31s.r - h__[i__4].i * h31s.i, q__8.i =
+ h__[i__4].r * h31s.i + h__[i__4].i * h31s.r;
+ q__1.r = q__2.r + q__8.r, q__1.i = q__2.i + q__8.i;
+ v[1].r = q__1.r, v[1].i = q__1.i;
+ i__1 = h_dim1 + 1;
+ i__2 = (h_dim1 << 1) + 2;
+ q__5.r = h__[i__1].r + h__[i__2].r, q__5.i = h__[i__1].i + h__[
+ i__2].i;
+ q__4.r = q__5.r - s1->r, q__4.i = q__5.i - s1->i;
+ q__3.r = q__4.r - s2->r, q__3.i = q__4.i - s2->i;
+ q__2.r = h21s.r * q__3.r - h21s.i * q__3.i, q__2.i = h21s.r *
+ q__3.i + h21s.i * q__3.r;
+ i__3 = h_dim1 * 3 + 2;
+ q__6.r = h__[i__3].r * h31s.r - h__[i__3].i * h31s.i, q__6.i =
+ h__[i__3].r * h31s.i + h__[i__3].i * h31s.r;
+ q__1.r = q__2.r + q__6.r, q__1.i = q__2.i + q__6.i;
+ v[2].r = q__1.r, v[2].i = q__1.i;
+ i__1 = h_dim1 + 1;
+ i__2 = h_dim1 * 3 + 3;
+ q__5.r = h__[i__1].r + h__[i__2].r, q__5.i = h__[i__1].i + h__[
+ i__2].i;
+ q__4.r = q__5.r - s1->r, q__4.i = q__5.i - s1->i;
+ q__3.r = q__4.r - s2->r, q__3.i = q__4.i - s2->i;
+ q__2.r = h31s.r * q__3.r - h31s.i * q__3.i, q__2.i = h31s.r *
+ q__3.i + h31s.i * q__3.r;
+ i__3 = (h_dim1 << 1) + 3;
+ q__6.r = h21s.r * h__[i__3].r - h21s.i * h__[i__3].i, q__6.i =
+ h21s.r * h__[i__3].i + h21s.i * h__[i__3].r;
+ q__1.r = q__2.r + q__6.r, q__1.i = q__2.i + q__6.i;
+ v[3].r = q__1.r, v[3].i = q__1.i;
+ }
+ }
+ return 0;
+} /* claqr1_ */
diff --git a/SRC/claqr2.c b/SRC/claqr2.c
new file mode 100644
index 0000000..ec288cf
--- /dev/null
+++ b/SRC/claqr2.c
@@ -0,0 +1,603 @@
+/* claqr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static logical c_true = TRUE_;
+
+/* Subroutine */ int claqr2_(logical *wantt, logical *wantz, integer *n,
+ integer *ktop, integer *kbot, integer *nw, complex *h__, integer *ldh,
+ integer *iloz, integer *ihiz, complex *z__, integer *ldz, integer *
+ ns, integer *nd, complex *sh, complex *v, integer *ldv, integer *nh,
+ complex *t, integer *ldt, integer *nv, complex *wv, integer *ldwv,
+ complex *work, integer *lwork)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1,
+ wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4, r__5, r__6;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j;
+ complex s;
+ integer jw;
+ real foo;
+ integer kln;
+ complex tau;
+ integer knt;
+ real ulp;
+ integer lwk1, lwk2;
+ complex beta;
+ integer kcol, info, ifst, ilst, ltop, krow;
+ extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
+, integer *, complex *, complex *, integer *, complex *),
+ cgemm_(char *, char *, integer *, integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, complex *,
+ integer *), ccopy_(integer *, complex *, integer
+ *, complex *, integer *);
+ integer infqr, kwtop;
+ extern /* Subroutine */ int slabad_(real *, real *), cgehrd_(integer *,
+ integer *, integer *, complex *, integer *, complex *, complex *,
+ integer *, integer *), clarfg_(integer *, complex *, complex *,
+ integer *, complex *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clahqr_(logical *, logical *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ integer *, complex *, integer *, integer *), clacpy_(char *,
+ integer *, integer *, complex *, integer *, complex *, integer *), claset_(char *, integer *, integer *, complex *, complex
+ *, complex *, integer *);
+ real safmin, safmax;
+ extern /* Subroutine */ int ctrexc_(char *, integer *, complex *, integer
+ *, complex *, integer *, integer *, integer *, integer *),
+ cunmhr_(char *, char *, integer *, integer *, integer *, integer
+ *, complex *, integer *, complex *, complex *, integer *, complex
+ *, integer *, integer *);
+ real smlnum;
+ integer lwkopt;
+
+
+/* -- LAPACK auxiliary routine (version 3.2.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* -- April 2009 -- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* This subroutine is identical to CLAQR3 except that it avoids */
+/* recursion by calling CLAHQR instead of CLAQR4. */
+
+
+/* ****************************************************************** */
+/* Aggressive early deflation: */
+
+/* This subroutine accepts as input an upper Hessenberg matrix */
+/* H and performs an unitary similarity transformation */
+/* designed to detect and deflate fully converged eigenvalues from */
+/* a trailing principal submatrix. On output H has been over- */
+/* written by a new Hessenberg matrix that is a perturbation of */
+/* an unitary similarity transformation of H. It is to be */
+/* hoped that the final version of H has many zero subdiagonal */
+/* entries. */
+
+/* ****************************************************************** */
+/* WANTT (input) LOGICAL */
+/* If .TRUE., then the Hessenberg matrix H is fully updated */
+/* so that the triangular Schur factor may be */
+/* computed (in cooperation with the calling subroutine). */
+/* If .FALSE., then only enough of H is updated to preserve */
+/* the eigenvalues. */
+
+/* WANTZ (input) LOGICAL */
+/* If .TRUE., then the unitary matrix Z is updated so */
+/* so that the unitary Schur factor may be computed */
+/* (in cooperation with the calling subroutine). */
+/* If .FALSE., then Z is not referenced. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H and (if WANTZ is .TRUE.) the */
+/* order of the unitary matrix Z. */
+
+/* KTOP (input) INTEGER */
+/* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */
+/* KBOT and KTOP together determine an isolated block */
+/* along the diagonal of the Hessenberg matrix. */
+
+/* KBOT (input) INTEGER */
+/* It is assumed without a check that either */
+/* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */
+/* determine an isolated block along the diagonal of the */
+/* Hessenberg matrix. */
+
+/* NW (input) INTEGER */
+/* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). */
+
+/* H (input/output) COMPLEX array, dimension (LDH,N) */
+/* On input the initial N-by-N section of H stores the */
+/* Hessenberg matrix undergoing aggressive early deflation. */
+/* On output H has been transformed by a unitary */
+/* similarity transformation, perturbed, and the returned */
+/* to Hessenberg form that (it is to be hoped) has some */
+/* zero subdiagonal entries. */
+
+/* LDH (input) integer */
+/* Leading dimension of H just as declared in the calling */
+/* subroutine. N .LE. LDH */
+
+/* ILOZ (input) INTEGER */
+/* IHIZ (input) INTEGER */
+/* Specify the rows of Z to which transformations must be */
+/* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. */
+
+/* Z (input/output) COMPLEX array, dimension (LDZ,N) */
+/* IF WANTZ is .TRUE., then on output, the unitary */
+/* similarity transformation mentioned above has been */
+/* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. */
+/* If WANTZ is .FALSE., then Z is unreferenced. */
+
+/* LDZ (input) integer */
+/* The leading dimension of Z just as declared in the */
+/* calling subroutine. 1 .LE. LDZ. */
+
+/* NS (output) integer */
+/* The number of unconverged (ie approximate) eigenvalues */
+/* returned in SR and SI that may be used as shifts by the */
+/* calling subroutine. */
+
+/* ND (output) integer */
+/* The number of converged eigenvalues uncovered by this */
+/* subroutine. */
+
+/* SH (output) COMPLEX array, dimension KBOT */
+/* On output, approximate eigenvalues that may */
+/* be used for shifts are stored in SH(KBOT-ND-NS+1) */
+/* through SR(KBOT-ND). Converged eigenvalues are */
+/* stored in SH(KBOT-ND+1) through SH(KBOT). */
+
+/* V (workspace) COMPLEX array, dimension (LDV,NW) */
+/* An NW-by-NW work array. */
+
+/* LDV (input) integer scalar */
+/* The leading dimension of V just as declared in the */
+/* calling subroutine. NW .LE. LDV */
+
+/* NH (input) integer scalar */
+/* The number of columns of T. NH.GE.NW. */
+
+/* T (workspace) COMPLEX array, dimension (LDT,NW) */
+
+/* LDT (input) integer */
+/* The leading dimension of T just as declared in the */
+/* calling subroutine. NW .LE. LDT */
+
+/* NV (input) integer */
+/* The number of rows of work array WV available for */
+/* workspace. NV.GE.NW. */
+
+/* WV (workspace) COMPLEX array, dimension (LDWV,NW) */
+
+/* LDWV (input) integer */
+/* The leading dimension of W just as declared in the */
+/* calling subroutine. NW .LE. LDV */
+
+/* WORK (workspace) COMPLEX array, dimension LWORK. */
+/* On exit, WORK(1) is set to an estimate of the optimal value */
+/* of LWORK for the given values of N, NW, KTOP and KBOT. */
+
+/* LWORK (input) integer */
+/* The dimension of the work array WORK. LWORK = 2*NW */
+/* suffices, but greater efficiency may result from larger */
+/* values of LWORK. */
+
+/* If LWORK = -1, then a workspace query is assumed; CLAQR2 */
+/* only estimates the optimal workspace size for the given */
+/* values of N, NW, KTOP and KBOT. The estimate is returned */
+/* in WORK(1). No error message related to LWORK is issued */
+/* by XERBLA. Neither H nor Z are accessed. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* ==== Estimate optimal workspace. ==== */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --sh;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ wv_dim1 = *ldwv;
+ wv_offset = 1 + wv_dim1;
+ wv -= wv_offset;
+ --work;
+
+ /* Function Body */
+/* Computing MIN */
+ i__1 = *nw, i__2 = *kbot - *ktop + 1;
+ jw = min(i__1,i__2);
+ if (jw <= 2) {
+ lwkopt = 1;
+ } else {
+
+/* ==== Workspace query call to CGEHRD ==== */
+
+ i__1 = jw - 1;
+ cgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], &
+ c_n1, &info);
+ lwk1 = (integer) work[1].r;
+
+/* ==== Workspace query call to CUNMHR ==== */
+
+ i__1 = jw - 1;
+ cunmhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1],
+ &v[v_offset], ldv, &work[1], &c_n1, &info);
+ lwk2 = (integer) work[1].r;
+
+/* ==== Optimal workspace ==== */
+
+ lwkopt = jw + max(lwk1,lwk2);
+ }
+
+/* ==== Quick return in case of workspace query. ==== */
+
+ if (*lwork == -1) {
+ r__1 = (real) lwkopt;
+ q__1.r = r__1, q__1.i = 0.f;
+ work[1].r = q__1.r, work[1].i = q__1.i;
+ return 0;
+ }
+
+/* ==== Nothing to do ... */
+/* ... for an empty active block ... ==== */
+ *ns = 0;
+ *nd = 0;
+ work[1].r = 1.f, work[1].i = 0.f;
+ if (*ktop > *kbot) {
+ return 0;
+ }
+/* ... nor for an empty deflation window. ==== */
+ if (*nw < 1) {
+ return 0;
+ }
+
+/* ==== Machine constants ==== */
+
+ safmin = slamch_("SAFE MINIMUM");
+ safmax = 1.f / safmin;
+ slabad_(&safmin, &safmax);
+ ulp = slamch_("PRECISION");
+ smlnum = safmin * ((real) (*n) / ulp);
+
+/* ==== Setup deflation window ==== */
+
+/* Computing MIN */
+ i__1 = *nw, i__2 = *kbot - *ktop + 1;
+ jw = min(i__1,i__2);
+ kwtop = *kbot - jw + 1;
+ if (kwtop == *ktop) {
+ s.r = 0.f, s.i = 0.f;
+ } else {
+ i__1 = kwtop + (kwtop - 1) * h_dim1;
+ s.r = h__[i__1].r, s.i = h__[i__1].i;
+ }
+
+ if (*kbot == kwtop) {
+
+/* ==== 1-by-1 deflation window: not much to do ==== */
+
+ i__1 = kwtop;
+ i__2 = kwtop + kwtop * h_dim1;
+ sh[i__1].r = h__[i__2].r, sh[i__1].i = h__[i__2].i;
+ *ns = 1;
+ *nd = 0;
+/* Computing MAX */
+ i__1 = kwtop + kwtop * h_dim1;
+ r__5 = smlnum, r__6 = ulp * ((r__1 = h__[i__1].r, dabs(r__1)) + (r__2
+ = r_imag(&h__[kwtop + kwtop * h_dim1]), dabs(r__2)));
+ if ((r__3 = s.r, dabs(r__3)) + (r__4 = r_imag(&s), dabs(r__4)) <=
+ dmax(r__5,r__6)) {
+ *ns = 0;
+ *nd = 1;
+ if (kwtop > *ktop) {
+ i__1 = kwtop + (kwtop - 1) * h_dim1;
+ h__[i__1].r = 0.f, h__[i__1].i = 0.f;
+ }
+ }
+ work[1].r = 1.f, work[1].i = 0.f;
+ return 0;
+ }
+
+/* ==== Convert to spike-triangular form. (In case of a */
+/* . rare QR failure, this routine continues to do */
+/* . aggressive early deflation using that part of */
+/* . the deflation window that converged using INFQR */
+/* . here and there to keep track.) ==== */
+
+ clacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset],
+ ldt);
+ i__1 = jw - 1;
+ i__2 = *ldh + 1;
+ i__3 = *ldt + 1;
+ ccopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], &
+ i__3);
+
+ claset_("A", &jw, &jw, &c_b1, &c_b2, &v[v_offset], ldv);
+ clahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[kwtop],
+ &c__1, &jw, &v[v_offset], ldv, &infqr);
+
+/* ==== Deflation detection loop ==== */
+
+ *ns = jw;
+ ilst = infqr + 1;
+ i__1 = jw;
+ for (knt = infqr + 1; knt <= i__1; ++knt) {
+
+/* ==== Small spike tip deflation test ==== */
+
+ i__2 = *ns + *ns * t_dim1;
+ foo = (r__1 = t[i__2].r, dabs(r__1)) + (r__2 = r_imag(&t[*ns + *ns *
+ t_dim1]), dabs(r__2));
+ if (foo == 0.f) {
+ foo = (r__1 = s.r, dabs(r__1)) + (r__2 = r_imag(&s), dabs(r__2));
+ }
+ i__2 = *ns * v_dim1 + 1;
+/* Computing MAX */
+ r__5 = smlnum, r__6 = ulp * foo;
+ if (((r__1 = s.r, dabs(r__1)) + (r__2 = r_imag(&s), dabs(r__2))) * ((
+ r__3 = v[i__2].r, dabs(r__3)) + (r__4 = r_imag(&v[*ns *
+ v_dim1 + 1]), dabs(r__4))) <= dmax(r__5,r__6)) {
+
+/* ==== One more converged eigenvalue ==== */
+
+ --(*ns);
+ } else {
+
+/* ==== One undeflatable eigenvalue. Move it up out of the */
+/* . way. (CTREXC can not fail in this case.) ==== */
+
+ ifst = *ns;
+ ctrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &
+ ilst, &info);
+ ++ilst;
+ }
+/* L10: */
+ }
+
+/* ==== Return to Hessenberg form ==== */
+
+ if (*ns == 0) {
+ s.r = 0.f, s.i = 0.f;
+ }
+
+ if (*ns < jw) {
+
+/* ==== sorting the diagonal of T improves accuracy for */
+/* . graded matrices. ==== */
+
+ i__1 = *ns;
+ for (i__ = infqr + 1; i__ <= i__1; ++i__) {
+ ifst = i__;
+ i__2 = *ns;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + j * t_dim1;
+ i__4 = ifst + ifst * t_dim1;
+ if ((r__1 = t[i__3].r, dabs(r__1)) + (r__2 = r_imag(&t[j + j *
+ t_dim1]), dabs(r__2)) > (r__3 = t[i__4].r, dabs(r__3)
+ ) + (r__4 = r_imag(&t[ifst + ifst * t_dim1]), dabs(
+ r__4))) {
+ ifst = j;
+ }
+/* L20: */
+ }
+ ilst = i__;
+ if (ifst != ilst) {
+ ctrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
+ &ilst, &info);
+ }
+/* L30: */
+ }
+ }
+
+/* ==== Restore shift/eigenvalue array from T ==== */
+
+ i__1 = jw;
+ for (i__ = infqr + 1; i__ <= i__1; ++i__) {
+ i__2 = kwtop + i__ - 1;
+ i__3 = i__ + i__ * t_dim1;
+ sh[i__2].r = t[i__3].r, sh[i__2].i = t[i__3].i;
+/* L40: */
+ }
+
+
+ if (*ns < jw || s.r == 0.f && s.i == 0.f) {
+ if (*ns > 1 && (s.r != 0.f || s.i != 0.f)) {
+
+/* ==== Reflect spike back into lower triangle ==== */
+
+ ccopy_(ns, &v[v_offset], ldv, &work[1], &c__1);
+ i__1 = *ns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ r_cnjg(&q__1, &work[i__]);
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L50: */
+ }
+ beta.r = work[1].r, beta.i = work[1].i;
+ clarfg_(ns, &beta, &work[2], &c__1, &tau);
+ work[1].r = 1.f, work[1].i = 0.f;
+
+ i__1 = jw - 2;
+ i__2 = jw - 2;
+ claset_("L", &i__1, &i__2, &c_b1, &c_b1, &t[t_dim1 + 3], ldt);
+
+ r_cnjg(&q__1, &tau);
+ clarf_("L", ns, &jw, &work[1], &c__1, &q__1, &t[t_offset], ldt, &
+ work[jw + 1]);
+ clarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, &
+ work[jw + 1]);
+ clarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, &
+ work[jw + 1]);
+
+ i__1 = *lwork - jw;
+ cgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1]
+, &i__1, &info);
+ }
+
+/* ==== Copy updated reduced window into place ==== */
+
+ if (kwtop > 1) {
+ i__1 = kwtop + (kwtop - 1) * h_dim1;
+ r_cnjg(&q__2, &v[v_dim1 + 1]);
+ q__1.r = s.r * q__2.r - s.i * q__2.i, q__1.i = s.r * q__2.i + s.i
+ * q__2.r;
+ h__[i__1].r = q__1.r, h__[i__1].i = q__1.i;
+ }
+ clacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1]
+, ldh);
+ i__1 = jw - 1;
+ i__2 = *ldt + 1;
+ i__3 = *ldh + 1;
+ ccopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1],
+ &i__3);
+
+/* ==== Accumulate orthogonal matrix in order update */
+/* . H and Z, if requested. ==== */
+
+ if (*ns > 1 && (s.r != 0.f || s.i != 0.f)) {
+ i__1 = *lwork - jw;
+ cunmhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1],
+ &v[v_offset], ldv, &work[jw + 1], &i__1, &info);
+ }
+
+/* ==== Update vertical slab in H ==== */
+
+ if (*wantt) {
+ ltop = 1;
+ } else {
+ ltop = *ktop;
+ }
+ i__1 = kwtop - 1;
+ i__2 = *nv;
+ for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *nv, i__4 = kwtop - krow;
+ kln = min(i__3,i__4);
+ cgemm_("N", "N", &kln, &jw, &jw, &c_b2, &h__[krow + kwtop *
+ h_dim1], ldh, &v[v_offset], ldv, &c_b1, &wv[wv_offset],
+ ldwv);
+ clacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop *
+ h_dim1], ldh);
+/* L60: */
+ }
+
+/* ==== Update horizontal slab in H ==== */
+
+ if (*wantt) {
+ i__2 = *n;
+ i__1 = *nh;
+ for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2;
+ kcol += i__1) {
+/* Computing MIN */
+ i__3 = *nh, i__4 = *n - kcol + 1;
+ kln = min(i__3,i__4);
+ cgemm_("C", "N", &jw, &kln, &jw, &c_b2, &v[v_offset], ldv, &
+ h__[kwtop + kcol * h_dim1], ldh, &c_b1, &t[t_offset],
+ ldt);
+ clacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol *
+ h_dim1], ldh);
+/* L70: */
+ }
+ }
+
+/* ==== Update vertical slab in Z ==== */
+
+ if (*wantz) {
+ i__1 = *ihiz;
+ i__2 = *nv;
+ for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *nv, i__4 = *ihiz - krow + 1;
+ kln = min(i__3,i__4);
+ cgemm_("N", "N", &kln, &jw, &jw, &c_b2, &z__[krow + kwtop *
+ z_dim1], ldz, &v[v_offset], ldv, &c_b1, &wv[wv_offset]
+, ldwv);
+ clacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow +
+ kwtop * z_dim1], ldz);
+/* L80: */
+ }
+ }
+ }
+
+/* ==== Return the number of deflations ... ==== */
+
+ *nd = jw - *ns;
+
+/* ==== ... and the number of shifts. (Subtracting */
+/* . INFQR from the spike length takes care */
+/* . of the case of a rare QR failure while */
+/* . calculating eigenvalues of the deflation */
+/* . window.) ==== */
+
+ *ns -= infqr;
+
+/* ==== Return optimal workspace. ==== */
+
+ r__1 = (real) lwkopt;
+ q__1.r = r__1, q__1.i = 0.f;
+ work[1].r = q__1.r, work[1].i = q__1.i;
+
+/* ==== End of CLAQR2 ==== */
+
+ return 0;
+} /* claqr2_ */
diff --git a/SRC/claqr3.c b/SRC/claqr3.c
new file mode 100644
index 0000000..0a3044a
--- /dev/null
+++ b/SRC/claqr3.c
@@ -0,0 +1,620 @@
+/* claqr3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static logical c_true = TRUE_;
+static integer c__12 = 12;
+
+/* Subroutine */ int claqr3_(logical *wantt, logical *wantz, integer *n,
+ integer *ktop, integer *kbot, integer *nw, complex *h__, integer *ldh,
+ integer *iloz, integer *ihiz, complex *z__, integer *ldz, integer *
+ ns, integer *nd, complex *sh, complex *v, integer *ldv, integer *nh,
+ complex *t, integer *ldt, integer *nv, complex *wv, integer *ldwv,
+ complex *work, integer *lwork)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1,
+ wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4, r__5, r__6;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j;
+ complex s;
+ integer jw;
+ real foo;
+ integer kln;
+ complex tau;
+ integer knt;
+ real ulp;
+ integer lwk1, lwk2, lwk3;
+ complex beta;
+ integer kcol, info, nmin, ifst, ilst, ltop, krow;
+ extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
+, integer *, complex *, complex *, integer *, complex *),
+ cgemm_(char *, char *, integer *, integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, complex *,
+ integer *), ccopy_(integer *, complex *, integer
+ *, complex *, integer *);
+ integer infqr, kwtop;
+ extern /* Subroutine */ int claqr4_(logical *, logical *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ integer *, complex *, integer *, complex *, integer *, integer *),
+ slabad_(real *, real *), cgehrd_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *)
+ , clarfg_(integer *, complex *, complex *, integer *, complex *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clahqr_(logical *, logical *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ integer *, complex *, integer *, integer *), clacpy_(char *,
+ integer *, integer *, complex *, integer *, complex *, integer *), claset_(char *, integer *, integer *, complex *, complex
+ *, complex *, integer *);
+ real safmin;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ real safmax;
+ extern /* Subroutine */ int ctrexc_(char *, integer *, complex *, integer
+ *, complex *, integer *, integer *, integer *, integer *),
+ cunmhr_(char *, char *, integer *, integer *, integer *, integer
+ *, complex *, integer *, complex *, complex *, integer *, complex
+ *, integer *, integer *);
+ real smlnum;
+ integer lwkopt;
+
+
+/* -- LAPACK auxiliary routine (version 3.2.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* -- April 2009 -- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* ****************************************************************** */
+/* Aggressive early deflation: */
+
+/* This subroutine accepts as input an upper Hessenberg matrix */
+/* H and performs an unitary similarity transformation */
+/* designed to detect and deflate fully converged eigenvalues from */
+/* a trailing principal submatrix. On output H has been over- */
+/* written by a new Hessenberg matrix that is a perturbation of */
+/* an unitary similarity transformation of H. It is to be */
+/* hoped that the final version of H has many zero subdiagonal */
+/* entries. */
+
+/* ****************************************************************** */
+/* WANTT (input) LOGICAL */
+/* If .TRUE., then the Hessenberg matrix H is fully updated */
+/* so that the triangular Schur factor may be */
+/* computed (in cooperation with the calling subroutine). */
+/* If .FALSE., then only enough of H is updated to preserve */
+/* the eigenvalues. */
+
+/* WANTZ (input) LOGICAL */
+/* If .TRUE., then the unitary matrix Z is updated so */
+/* so that the unitary Schur factor may be computed */
+/* (in cooperation with the calling subroutine). */
+/* If .FALSE., then Z is not referenced. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H and (if WANTZ is .TRUE.) the */
+/* order of the unitary matrix Z. */
+
+/* KTOP (input) INTEGER */
+/* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */
+/* KBOT and KTOP together determine an isolated block */
+/* along the diagonal of the Hessenberg matrix. */
+
+/* KBOT (input) INTEGER */
+/* It is assumed without a check that either */
+/* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */
+/* determine an isolated block along the diagonal of the */
+/* Hessenberg matrix. */
+
+/* NW (input) INTEGER */
+/* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). */
+
+/* H (input/output) COMPLEX array, dimension (LDH,N) */
+/* On input the initial N-by-N section of H stores the */
+/* Hessenberg matrix undergoing aggressive early deflation. */
+/* On output H has been transformed by a unitary */
+/* similarity transformation, perturbed, and the returned */
+/* to Hessenberg form that (it is to be hoped) has some */
+/* zero subdiagonal entries. */
+
+/* LDH (input) integer */
+/* Leading dimension of H just as declared in the calling */
+/* subroutine. N .LE. LDH */
+
+/* ILOZ (input) INTEGER */
+/* IHIZ (input) INTEGER */
+/* Specify the rows of Z to which transformations must be */
+/* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. */
+
+/* Z (input/output) COMPLEX array, dimension (LDZ,N) */
+/* IF WANTZ is .TRUE., then on output, the unitary */
+/* similarity transformation mentioned above has been */
+/* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. */
+/* If WANTZ is .FALSE., then Z is unreferenced. */
+
+/* LDZ (input) integer */
+/* The leading dimension of Z just as declared in the */
+/* calling subroutine. 1 .LE. LDZ. */
+
+/* NS (output) integer */
+/* The number of unconverged (ie approximate) eigenvalues */
+/* returned in SR and SI that may be used as shifts by the */
+/* calling subroutine. */
+
+/* ND (output) integer */
+/* The number of converged eigenvalues uncovered by this */
+/* subroutine. */
+
+/* SH (output) COMPLEX array, dimension KBOT */
+/* On output, approximate eigenvalues that may */
+/* be used for shifts are stored in SH(KBOT-ND-NS+1) */
+/* through SR(KBOT-ND). Converged eigenvalues are */
+/* stored in SH(KBOT-ND+1) through SH(KBOT). */
+
+/* V (workspace) COMPLEX array, dimension (LDV,NW) */
+/* An NW-by-NW work array. */
+
+/* LDV (input) integer scalar */
+/* The leading dimension of V just as declared in the */
+/* calling subroutine. NW .LE. LDV */
+
+/* NH (input) integer scalar */
+/* The number of columns of T. NH.GE.NW. */
+
+/* T (workspace) COMPLEX array, dimension (LDT,NW) */
+
+/* LDT (input) integer */
+/* The leading dimension of T just as declared in the */
+/* calling subroutine. NW .LE. LDT */
+
+/* NV (input) integer */
+/* The number of rows of work array WV available for */
+/* workspace. NV.GE.NW. */
+
+/* WV (workspace) COMPLEX array, dimension (LDWV,NW) */
+
+/* LDWV (input) integer */
+/* The leading dimension of W just as declared in the */
+/* calling subroutine. NW .LE. LDV */
+
+/* WORK (workspace) COMPLEX array, dimension LWORK. */
+/* On exit, WORK(1) is set to an estimate of the optimal value */
+/* of LWORK for the given values of N, NW, KTOP and KBOT. */
+
+/* LWORK (input) integer */
+/* The dimension of the work array WORK. LWORK = 2*NW */
+/* suffices, but greater efficiency may result from larger */
+/* values of LWORK. */
+
+/* If LWORK = -1, then a workspace query is assumed; CLAQR3 */
+/* only estimates the optimal workspace size for the given */
+/* values of N, NW, KTOP and KBOT. The estimate is returned */
+/* in WORK(1). No error message related to LWORK is issued */
+/* by XERBLA. Neither H nor Z are accessed. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* ==== Estimate optimal workspace. ==== */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --sh;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ wv_dim1 = *ldwv;
+ wv_offset = 1 + wv_dim1;
+ wv -= wv_offset;
+ --work;
+
+ /* Function Body */
+/* Computing MIN */
+ i__1 = *nw, i__2 = *kbot - *ktop + 1;
+ jw = min(i__1,i__2);
+ if (jw <= 2) {
+ lwkopt = 1;
+ } else {
+
+/* ==== Workspace query call to CGEHRD ==== */
+
+ i__1 = jw - 1;
+ cgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], &
+ c_n1, &info);
+ lwk1 = (integer) work[1].r;
+
+/* ==== Workspace query call to CUNMHR ==== */
+
+ i__1 = jw - 1;
+ cunmhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1],
+ &v[v_offset], ldv, &work[1], &c_n1, &info);
+ lwk2 = (integer) work[1].r;
+
+/* ==== Workspace query call to CLAQR4 ==== */
+
+ claqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[1],
+ &c__1, &jw, &v[v_offset], ldv, &work[1], &c_n1, &infqr);
+ lwk3 = (integer) work[1].r;
+
+/* ==== Optimal workspace ==== */
+
+/* Computing MAX */
+ i__1 = jw + max(lwk1,lwk2);
+ lwkopt = max(i__1,lwk3);
+ }
+
+/* ==== Quick return in case of workspace query. ==== */
+
+ if (*lwork == -1) {
+ r__1 = (real) lwkopt;
+ q__1.r = r__1, q__1.i = 0.f;
+ work[1].r = q__1.r, work[1].i = q__1.i;
+ return 0;
+ }
+
+/* ==== Nothing to do ... */
+/* ... for an empty active block ... ==== */
+ *ns = 0;
+ *nd = 0;
+ work[1].r = 1.f, work[1].i = 0.f;
+ if (*ktop > *kbot) {
+ return 0;
+ }
+/* ... nor for an empty deflation window. ==== */
+ if (*nw < 1) {
+ return 0;
+ }
+
+/* ==== Machine constants ==== */
+
+ safmin = slamch_("SAFE MINIMUM");
+ safmax = 1.f / safmin;
+ slabad_(&safmin, &safmax);
+ ulp = slamch_("PRECISION");
+ smlnum = safmin * ((real) (*n) / ulp);
+
+/* ==== Setup deflation window ==== */
+
+/* Computing MIN */
+ i__1 = *nw, i__2 = *kbot - *ktop + 1;
+ jw = min(i__1,i__2);
+ kwtop = *kbot - jw + 1;
+ if (kwtop == *ktop) {
+ s.r = 0.f, s.i = 0.f;
+ } else {
+ i__1 = kwtop + (kwtop - 1) * h_dim1;
+ s.r = h__[i__1].r, s.i = h__[i__1].i;
+ }
+
+ if (*kbot == kwtop) {
+
+/* ==== 1-by-1 deflation window: not much to do ==== */
+
+ i__1 = kwtop;
+ i__2 = kwtop + kwtop * h_dim1;
+ sh[i__1].r = h__[i__2].r, sh[i__1].i = h__[i__2].i;
+ *ns = 1;
+ *nd = 0;
+/* Computing MAX */
+ i__1 = kwtop + kwtop * h_dim1;
+ r__5 = smlnum, r__6 = ulp * ((r__1 = h__[i__1].r, dabs(r__1)) + (r__2
+ = r_imag(&h__[kwtop + kwtop * h_dim1]), dabs(r__2)));
+ if ((r__3 = s.r, dabs(r__3)) + (r__4 = r_imag(&s), dabs(r__4)) <=
+ dmax(r__5,r__6)) {
+ *ns = 0;
+ *nd = 1;
+ if (kwtop > *ktop) {
+ i__1 = kwtop + (kwtop - 1) * h_dim1;
+ h__[i__1].r = 0.f, h__[i__1].i = 0.f;
+ }
+ }
+ work[1].r = 1.f, work[1].i = 0.f;
+ return 0;
+ }
+
+/* ==== Convert to spike-triangular form. (In case of a */
+/* . rare QR failure, this routine continues to do */
+/* . aggressive early deflation using that part of */
+/* . the deflation window that converged using INFQR */
+/* . here and there to keep track.) ==== */
+
+ clacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset],
+ ldt);
+ i__1 = jw - 1;
+ i__2 = *ldh + 1;
+ i__3 = *ldt + 1;
+ ccopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], &
+ i__3);
+
+ claset_("A", &jw, &jw, &c_b1, &c_b2, &v[v_offset], ldv);
+ nmin = ilaenv_(&c__12, "CLAQR3", "SV", &jw, &c__1, &jw, lwork);
+ if (jw > nmin) {
+ claqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[
+ kwtop], &c__1, &jw, &v[v_offset], ldv, &work[1], lwork, &
+ infqr);
+ } else {
+ clahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[
+ kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr);
+ }
+
+/* ==== Deflation detection loop ==== */
+
+ *ns = jw;
+ ilst = infqr + 1;
+ i__1 = jw;
+ for (knt = infqr + 1; knt <= i__1; ++knt) {
+
+/* ==== Small spike tip deflation test ==== */
+
+ i__2 = *ns + *ns * t_dim1;
+ foo = (r__1 = t[i__2].r, dabs(r__1)) + (r__2 = r_imag(&t[*ns + *ns *
+ t_dim1]), dabs(r__2));
+ if (foo == 0.f) {
+ foo = (r__1 = s.r, dabs(r__1)) + (r__2 = r_imag(&s), dabs(r__2));
+ }
+ i__2 = *ns * v_dim1 + 1;
+/* Computing MAX */
+ r__5 = smlnum, r__6 = ulp * foo;
+ if (((r__1 = s.r, dabs(r__1)) + (r__2 = r_imag(&s), dabs(r__2))) * ((
+ r__3 = v[i__2].r, dabs(r__3)) + (r__4 = r_imag(&v[*ns *
+ v_dim1 + 1]), dabs(r__4))) <= dmax(r__5,r__6)) {
+
+/* ==== One more converged eigenvalue ==== */
+
+ --(*ns);
+ } else {
+
+/* ==== One undeflatable eigenvalue. Move it up out of the */
+/* . way. (CTREXC can not fail in this case.) ==== */
+
+ ifst = *ns;
+ ctrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &
+ ilst, &info);
+ ++ilst;
+ }
+/* L10: */
+ }
+
+/* ==== Return to Hessenberg form ==== */
+
+ if (*ns == 0) {
+ s.r = 0.f, s.i = 0.f;
+ }
+
+ if (*ns < jw) {
+
+/* ==== sorting the diagonal of T improves accuracy for */
+/* . graded matrices. ==== */
+
+ i__1 = *ns;
+ for (i__ = infqr + 1; i__ <= i__1; ++i__) {
+ ifst = i__;
+ i__2 = *ns;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + j * t_dim1;
+ i__4 = ifst + ifst * t_dim1;
+ if ((r__1 = t[i__3].r, dabs(r__1)) + (r__2 = r_imag(&t[j + j *
+ t_dim1]), dabs(r__2)) > (r__3 = t[i__4].r, dabs(r__3)
+ ) + (r__4 = r_imag(&t[ifst + ifst * t_dim1]), dabs(
+ r__4))) {
+ ifst = j;
+ }
+/* L20: */
+ }
+ ilst = i__;
+ if (ifst != ilst) {
+ ctrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
+ &ilst, &info);
+ }
+/* L30: */
+ }
+ }
+
+/* ==== Restore shift/eigenvalue array from T ==== */
+
+ i__1 = jw;
+ for (i__ = infqr + 1; i__ <= i__1; ++i__) {
+ i__2 = kwtop + i__ - 1;
+ i__3 = i__ + i__ * t_dim1;
+ sh[i__2].r = t[i__3].r, sh[i__2].i = t[i__3].i;
+/* L40: */
+ }
+
+
+ if (*ns < jw || s.r == 0.f && s.i == 0.f) {
+ if (*ns > 1 && (s.r != 0.f || s.i != 0.f)) {
+
+/* ==== Reflect spike back into lower triangle ==== */
+
+ ccopy_(ns, &v[v_offset], ldv, &work[1], &c__1);
+ i__1 = *ns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ r_cnjg(&q__1, &work[i__]);
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L50: */
+ }
+ beta.r = work[1].r, beta.i = work[1].i;
+ clarfg_(ns, &beta, &work[2], &c__1, &tau);
+ work[1].r = 1.f, work[1].i = 0.f;
+
+ i__1 = jw - 2;
+ i__2 = jw - 2;
+ claset_("L", &i__1, &i__2, &c_b1, &c_b1, &t[t_dim1 + 3], ldt);
+
+ r_cnjg(&q__1, &tau);
+ clarf_("L", ns, &jw, &work[1], &c__1, &q__1, &t[t_offset], ldt, &
+ work[jw + 1]);
+ clarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, &
+ work[jw + 1]);
+ clarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, &
+ work[jw + 1]);
+
+ i__1 = *lwork - jw;
+ cgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1]
+, &i__1, &info);
+ }
+
+/* ==== Copy updated reduced window into place ==== */
+
+ if (kwtop > 1) {
+ i__1 = kwtop + (kwtop - 1) * h_dim1;
+ r_cnjg(&q__2, &v[v_dim1 + 1]);
+ q__1.r = s.r * q__2.r - s.i * q__2.i, q__1.i = s.r * q__2.i + s.i
+ * q__2.r;
+ h__[i__1].r = q__1.r, h__[i__1].i = q__1.i;
+ }
+ clacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1]
+, ldh);
+ i__1 = jw - 1;
+ i__2 = *ldt + 1;
+ i__3 = *ldh + 1;
+ ccopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1],
+ &i__3);
+
+/* ==== Accumulate orthogonal matrix in order update */
+/* . H and Z, if requested. ==== */
+
+ if (*ns > 1 && (s.r != 0.f || s.i != 0.f)) {
+ i__1 = *lwork - jw;
+ cunmhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1],
+ &v[v_offset], ldv, &work[jw + 1], &i__1, &info);
+ }
+
+/* ==== Update vertical slab in H ==== */
+
+ if (*wantt) {
+ ltop = 1;
+ } else {
+ ltop = *ktop;
+ }
+ i__1 = kwtop - 1;
+ i__2 = *nv;
+ for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *nv, i__4 = kwtop - krow;
+ kln = min(i__3,i__4);
+ cgemm_("N", "N", &kln, &jw, &jw, &c_b2, &h__[krow + kwtop *
+ h_dim1], ldh, &v[v_offset], ldv, &c_b1, &wv[wv_offset],
+ ldwv);
+ clacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop *
+ h_dim1], ldh);
+/* L60: */
+ }
+
+/* ==== Update horizontal slab in H ==== */
+
+ if (*wantt) {
+ i__2 = *n;
+ i__1 = *nh;
+ for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2;
+ kcol += i__1) {
+/* Computing MIN */
+ i__3 = *nh, i__4 = *n - kcol + 1;
+ kln = min(i__3,i__4);
+ cgemm_("C", "N", &jw, &kln, &jw, &c_b2, &v[v_offset], ldv, &
+ h__[kwtop + kcol * h_dim1], ldh, &c_b1, &t[t_offset],
+ ldt);
+ clacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol *
+ h_dim1], ldh);
+/* L70: */
+ }
+ }
+
+/* ==== Update vertical slab in Z ==== */
+
+ if (*wantz) {
+ i__1 = *ihiz;
+ i__2 = *nv;
+ for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *nv, i__4 = *ihiz - krow + 1;
+ kln = min(i__3,i__4);
+ cgemm_("N", "N", &kln, &jw, &jw, &c_b2, &z__[krow + kwtop *
+ z_dim1], ldz, &v[v_offset], ldv, &c_b1, &wv[wv_offset]
+, ldwv);
+ clacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow +
+ kwtop * z_dim1], ldz);
+/* L80: */
+ }
+ }
+ }
+
+/* ==== Return the number of deflations ... ==== */
+
+ *nd = jw - *ns;
+
+/* ==== ... and the number of shifts. (Subtracting */
+/* . INFQR from the spike length takes care */
+/* . of the case of a rare QR failure while */
+/* . calculating eigenvalues of the deflation */
+/* . window.) ==== */
+
+ *ns -= infqr;
+
+/* ==== Return optimal workspace. ==== */
+
+ r__1 = (real) lwkopt;
+ q__1.r = r__1, q__1.i = 0.f;
+ work[1].r = q__1.r, work[1].i = q__1.i;
+
+/* ==== End of CLAQR3 ==== */
+
+ return 0;
+} /* claqr3_ */
diff --git a/SRC/claqr4.c b/SRC/claqr4.c
new file mode 100644
index 0000000..e3792ed
--- /dev/null
+++ b/SRC/claqr4.c
@@ -0,0 +1,782 @@
+/* claqr4.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__13 = 13;
+static integer c__15 = 15;
+static integer c_n1 = -1;
+static integer c__12 = 12;
+static integer c__14 = 14;
+static integer c__16 = 16;
+static logical c_false = FALSE_;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int claqr4_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, complex *h__, integer *ldh, complex *w,
+ integer *iloz, integer *ihiz, complex *z__, integer *ldz, complex *
+ work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8;
+ complex q__1, q__2, q__3, q__4, q__5;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void c_sqrt(complex *, complex *);
+
+ /* Local variables */
+ integer i__, k;
+ real s;
+ complex aa, bb, cc, dd;
+ integer ld, nh, it, ks, kt, ku, kv, ls, ns, nw;
+ complex tr2, det;
+ integer inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot, nmin;
+ complex swap;
+ integer ktop;
+ complex zdum[1] /* was [1][1] */;
+ integer kacc22, itmax, nsmax, nwmax, kwtop;
+ extern /* Subroutine */ int claqr2_(logical *, logical *, integer *,
+ integer *, integer *, integer *, complex *, integer *, integer *,
+ integer *, complex *, integer *, integer *, integer *, complex *,
+ complex *, integer *, integer *, complex *, integer *, integer *,
+ complex *, integer *, complex *, integer *), claqr5_(logical *,
+ logical *, integer *, integer *, integer *, integer *, integer *,
+ complex *, complex *, integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, integer *,
+ complex *, integer *, integer *, complex *, integer *);
+ integer nibble;
+ extern /* Subroutine */ int clahqr_(logical *, logical *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ integer *, complex *, integer *, integer *), clacpy_(char *,
+ integer *, integer *, complex *, integer *, complex *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ char jbcmpz[2];
+ complex rtdisc;
+ integer nwupbd;
+ logical sorted;
+ integer lwkopt;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* This subroutine implements one level of recursion for CLAQR0. */
+/* It is a complete implementation of the small bulge multi-shift */
+/* QR algorithm. It may be called by CLAQR0 and, for large enough */
+/* deflation window size, it may be called by CLAQR3. This */
+/* subroutine is identical to CLAQR0 except that it calls CLAQR2 */
+/* instead of CLAQR3. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAQR4 computes the eigenvalues of a Hessenberg matrix H */
+/* and, optionally, the matrices T and Z from the Schur decomposition */
+/* H = Z T Z**H, where T is an upper triangular matrix (the */
+/* Schur form), and Z is the unitary matrix of Schur vectors. */
+
+/* Optionally Z may be postmultiplied into an input unitary */
+/* matrix Q so that this routine can give the Schur factorization */
+/* of a matrix A which has been reduced to the Hessenberg form H */
+/* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. */
+
+/* Arguments */
+/* ========= */
+
+/* WANTT (input) LOGICAL */
+/* = .TRUE. : the full Schur form T is required; */
+/* = .FALSE.: only eigenvalues are required. */
+
+/* WANTZ (input) LOGICAL */
+/* = .TRUE. : the matrix of Schur vectors Z is required; */
+/* = .FALSE.: Schur vectors are not required. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N .GE. 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that H is already upper triangular in rows */
+/* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, */
+/* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a */
+/* previous call to CGEBAL, and then passed to CGEHRD when the */
+/* matrix output by CGEBAL is reduced to Hessenberg form. */
+/* Otherwise, ILO and IHI should be set to 1 and N, */
+/* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */
+/* If N = 0, then ILO = 1 and IHI = 0. */
+
+/* H (input/output) COMPLEX array, dimension (LDH,N) */
+/* On entry, the upper Hessenberg matrix H. */
+/* On exit, if INFO = 0 and WANTT is .TRUE., then H */
+/* contains the upper triangular matrix T from the Schur */
+/* decomposition (the Schur form). If INFO = 0 and WANT is */
+/* .FALSE., then the contents of H are unspecified on exit. */
+/* (The output value of H when INFO.GT.0 is given under the */
+/* description of INFO below.) */
+
+/* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and */
+/* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH .GE. max(1,N). */
+
+/* W (output) COMPLEX array, dimension (N) */
+/* The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored */
+/* in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are */
+/* stored in the same order as on the diagonal of the Schur */
+/* form returned in H, with W(i) = H(i,i). */
+
+/* Z (input/output) COMPLEX array, dimension (LDZ,IHI) */
+/* If WANTZ is .FALSE., then Z is not referenced. */
+/* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is */
+/* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the */
+/* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). */
+/* (The output value of Z when INFO.GT.0 is given under */
+/* the description of INFO below.) */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. if WANTZ is .TRUE. */
+/* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. */
+
+/* WORK (workspace/output) COMPLEX array, dimension LWORK */
+/* On exit, if LWORK = -1, WORK(1) returns an estimate of */
+/* the optimal value for LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK .GE. max(1,N) */
+/* is sufficient, but LWORK typically as large as 6*N may */
+/* be required for optimal performance. A workspace query */
+/* to determine the optimal workspace size is recommended. */
+
+/* If LWORK = -1, then CLAQR4 does a workspace query. */
+/* In this case, CLAQR4 checks the input parameters and */
+/* estimates the optimal workspace size for the given */
+/* values of N, ILO and IHI. The estimate is returned */
+/* in WORK(1). No error message related to LWORK is */
+/* issued by XERBLA. Neither H nor Z are accessed. */
+
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* .GT. 0: if INFO = i, CLAQR4 failed to compute all of */
+/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */
+/* and WI contain those eigenvalues which have been */
+/* successfully computed. (Failures are rare.) */
+
+/* If INFO .GT. 0 and WANT is .FALSE., then on exit, */
+/* the remaining unconverged eigenvalues are the eigen- */
+/* values of the upper Hessenberg matrix rows and */
+/* columns ILO through INFO of the final, output */
+/* value of H. */
+
+/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */
+
+/* (*) (initial value of H)*U = U*(final value of H) */
+
+/* where U is a unitary matrix. The final */
+/* value of H is upper Hessenberg and triangular in */
+/* rows and columns INFO+1 through IHI. */
+
+/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
+
+/* (final value of Z(ILO:IHI,ILOZ:IHIZ) */
+/* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U */
+
+/* where U is the unitary matrix in (*) (regard- */
+/* less of the value of WANTT.) */
+
+/* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not */
+/* accessed. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* References: */
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */
+/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */
+/* 929--947, 2002. */
+
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */
+/* of Matrix Analysis, volume 23, pages 948--973, 2002. */
+
+/* ================================================================ */
+/* .. Parameters .. */
+
+/* ==== Matrices of order NTINY or smaller must be processed by */
+/* . CLAHQR because of insufficient subdiagonal scratch space. */
+/* . (This is a hard limit.) ==== */
+
+/* ==== Exceptional deflation windows: try to cure rare */
+/* . slow convergence by varying the size of the */
+/* . deflation window after KEXNW iterations. ==== */
+
+/* ==== Exceptional shifts: try to cure rare slow convergence */
+/* . with ad-hoc exceptional shifts every KEXSH iterations. */
+/* . ==== */
+
+/* ==== The constant WILK1 is used to form the exceptional */
+/* . shifts. ==== */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* ==== Quick return for N = 0: nothing to do. ==== */
+
+ if (*n == 0) {
+ work[1].r = 1.f, work[1].i = 0.f;
+ return 0;
+ }
+
+ if (*n <= 11) {
+
+/* ==== Tiny matrices must use CLAHQR. ==== */
+
+ lwkopt = 1;
+ if (*lwork != -1) {
+ clahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1],
+ iloz, ihiz, &z__[z_offset], ldz, info);
+ }
+ } else {
+
+/* ==== Use small bulge multi-shift QR with aggressive early */
+/* . deflation on larger-than-tiny matrices. ==== */
+
+/* ==== Hope for the best. ==== */
+
+ *info = 0;
+
+/* ==== Set up job flags for ILAENV. ==== */
+
+ if (*wantt) {
+ *(unsigned char *)jbcmpz = 'S';
+ } else {
+ *(unsigned char *)jbcmpz = 'E';
+ }
+ if (*wantz) {
+ *(unsigned char *)&jbcmpz[1] = 'V';
+ } else {
+ *(unsigned char *)&jbcmpz[1] = 'N';
+ }
+
+/* ==== NWR = recommended deflation window size. At this */
+/* . point, N .GT. NTINY = 11, so there is enough */
+/* . subdiagonal workspace for NWR.GE.2 as required. */
+/* . (In fact, there is enough subdiagonal space for */
+/* . NWR.GE.3.) ==== */
+
+ nwr = ilaenv_(&c__13, "CLAQR4", jbcmpz, n, ilo, ihi, lwork);
+ nwr = max(2,nwr);
+/* Computing MIN */
+ i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = min(i__1,i__2);
+ nwr = min(i__1,nwr);
+
+/* ==== NSR = recommended number of simultaneous shifts. */
+/* . At this point N .GT. NTINY = 11, so there is at */
+/* . enough subdiagonal workspace for NSR to be even */
+/* . and greater than or equal to two as required. ==== */
+
+ nsr = ilaenv_(&c__15, "CLAQR4", jbcmpz, n, ilo, ihi, lwork);
+/* Computing MIN */
+ i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = min(i__1,i__2), i__2 = *ihi -
+ *ilo;
+ nsr = min(i__1,i__2);
+/* Computing MAX */
+ i__1 = 2, i__2 = nsr - nsr % 2;
+ nsr = max(i__1,i__2);
+
+/* ==== Estimate optimal workspace ==== */
+
+/* ==== Workspace query call to CLAQR2 ==== */
+
+ i__1 = nwr + 1;
+ claqr2_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz,
+ ihiz, &z__[z_offset], ldz, &ls, &ld, &w[1], &h__[h_offset],
+ ldh, n, &h__[h_offset], ldh, n, &h__[h_offset], ldh, &work[1],
+ &c_n1);
+
+/* ==== Optimal workspace = MAX(CLAQR5, CLAQR2) ==== */
+
+/* Computing MAX */
+ i__1 = nsr * 3 / 2, i__2 = (integer) work[1].r;
+ lwkopt = max(i__1,i__2);
+
+/* ==== Quick return in case of workspace query. ==== */
+
+ if (*lwork == -1) {
+ r__1 = (real) lwkopt;
+ q__1.r = r__1, q__1.i = 0.f;
+ work[1].r = q__1.r, work[1].i = q__1.i;
+ return 0;
+ }
+
+/* ==== CLAHQR/CLAQR0 crossover point ==== */
+
+ nmin = ilaenv_(&c__12, "CLAQR4", jbcmpz, n, ilo, ihi, lwork);
+ nmin = max(11,nmin);
+
+/* ==== Nibble crossover point ==== */
+
+ nibble = ilaenv_(&c__14, "CLAQR4", jbcmpz, n, ilo, ihi, lwork);
+ nibble = max(0,nibble);
+
+/* ==== Accumulate reflections during ttswp? Use block */
+/* . 2-by-2 structure during matrix-matrix multiply? ==== */
+
+ kacc22 = ilaenv_(&c__16, "CLAQR4", jbcmpz, n, ilo, ihi, lwork);
+ kacc22 = max(0,kacc22);
+ kacc22 = min(2,kacc22);
+
+/* ==== NWMAX = the largest possible deflation window for */
+/* . which there is sufficient workspace. ==== */
+
+/* Computing MIN */
+ i__1 = (*n - 1) / 3, i__2 = *lwork / 2;
+ nwmax = min(i__1,i__2);
+ nw = nwmax;
+
+/* ==== NSMAX = the Largest number of simultaneous shifts */
+/* . for which there is sufficient workspace. ==== */
+
+/* Computing MIN */
+ i__1 = (*n + 6) / 9, i__2 = (*lwork << 1) / 3;
+ nsmax = min(i__1,i__2);
+ nsmax -= nsmax % 2;
+
+/* ==== NDFL: an iteration count restarted at deflation. ==== */
+
+ ndfl = 1;
+
+/* ==== ITMAX = iteration limit ==== */
+
+/* Computing MAX */
+ i__1 = 10, i__2 = *ihi - *ilo + 1;
+ itmax = max(i__1,i__2) * 30;
+
+/* ==== Last row and column in the active block ==== */
+
+ kbot = *ihi;
+
+/* ==== Main Loop ==== */
+
+ i__1 = itmax;
+ for (it = 1; it <= i__1; ++it) {
+
+/* ==== Done when KBOT falls below ILO ==== */
+
+ if (kbot < *ilo) {
+ goto L80;
+ }
+
+/* ==== Locate active block ==== */
+
+ i__2 = *ilo + 1;
+ for (k = kbot; k >= i__2; --k) {
+ i__3 = k + (k - 1) * h_dim1;
+ if (h__[i__3].r == 0.f && h__[i__3].i == 0.f) {
+ goto L20;
+ }
+/* L10: */
+ }
+ k = *ilo;
+L20:
+ ktop = k;
+
+/* ==== Select deflation window size: */
+/* . Typical Case: */
+/* . If possible and advisable, nibble the entire */
+/* . active block. If not, use size MIN(NWR,NWMAX) */
+/* . or MIN(NWR+1,NWMAX) depending upon which has */
+/* . the smaller corresponding subdiagonal entry */
+/* . (a heuristic). */
+/* . */
+/* . Exceptional Case: */
+/* . If there have been no deflations in KEXNW or */
+/* . more iterations, then vary the deflation window */
+/* . size. At first, because, larger windows are, */
+/* . in general, more powerful than smaller ones, */
+/* . rapidly increase the window to the maximum possible. */
+/* . Then, gradually reduce the window size. ==== */
+
+ nh = kbot - ktop + 1;
+ nwupbd = min(nh,nwmax);
+ if (ndfl < 5) {
+ nw = min(nwupbd,nwr);
+ } else {
+/* Computing MIN */
+ i__2 = nwupbd, i__3 = nw << 1;
+ nw = min(i__2,i__3);
+ }
+ if (nw < nwmax) {
+ if (nw >= nh - 1) {
+ nw = nh;
+ } else {
+ kwtop = kbot - nw + 1;
+ i__2 = kwtop + (kwtop - 1) * h_dim1;
+ i__3 = kwtop - 1 + (kwtop - 2) * h_dim1;
+ if ((r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
+ h__[kwtop + (kwtop - 1) * h_dim1]), dabs(r__2)) >
+ (r__3 = h__[i__3].r, dabs(r__3)) + (r__4 = r_imag(
+ &h__[kwtop - 1 + (kwtop - 2) * h_dim1]), dabs(
+ r__4))) {
+ ++nw;
+ }
+ }
+ }
+ if (ndfl < 5) {
+ ndec = -1;
+ } else if (ndec >= 0 || nw >= nwupbd) {
+ ++ndec;
+ if (nw - ndec < 2) {
+ ndec = 0;
+ }
+ nw -= ndec;
+ }
+
+/* ==== Aggressive early deflation: */
+/* . split workspace under the subdiagonal into */
+/* . - an nw-by-nw work array V in the lower */
+/* . left-hand-corner, */
+/* . - an NW-by-at-least-NW-but-more-is-better */
+/* . (NW-by-NHO) horizontal work array along */
+/* . the bottom edge, */
+/* . - an at-least-NW-but-more-is-better (NHV-by-NW) */
+/* . vertical work array along the left-hand-edge. */
+/* . ==== */
+
+ kv = *n - nw + 1;
+ kt = nw + 1;
+ nho = *n - nw - 1 - kt + 1;
+ kwv = nw + 2;
+ nve = *n - nw - kwv + 1;
+
+/* ==== Aggressive early deflation ==== */
+
+ claqr2_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh,
+ iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &w[1], &h__[kv
+ + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1], ldh, &nve, &
+ h__[kwv + h_dim1], ldh, &work[1], lwork);
+
+/* ==== Adjust KBOT accounting for new deflations. ==== */
+
+ kbot -= ld;
+
+/* ==== KS points to the shifts. ==== */
+
+ ks = kbot - ls + 1;
+
+/* ==== Skip an expensive QR sweep if there is a (partly */
+/* . heuristic) reason to expect that many eigenvalues */
+/* . will deflate without it. Here, the QR sweep is */
+/* . skipped if many eigenvalues have just been deflated */
+/* . or if the remaining active block is small. */
+
+ if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > min(
+ nmin,nwmax)) {
+
+/* ==== NS = nominal number of simultaneous shifts. */
+/* . This may be lowered (slightly) if CLAQR2 */
+/* . did not provide that many shifts. ==== */
+
+/* Computing MIN */
+/* Computing MAX */
+ i__4 = 2, i__5 = kbot - ktop;
+ i__2 = min(nsmax,nsr), i__3 = max(i__4,i__5);
+ ns = min(i__2,i__3);
+ ns -= ns % 2;
+
+/* ==== If there have been no deflations */
+/* . in a multiple of KEXSH iterations, */
+/* . then try exceptional shifts. */
+/* . Otherwise use shifts provided by */
+/* . CLAQR2 above or from the eigenvalues */
+/* . of a trailing principal submatrix. ==== */
+
+ if (ndfl % 6 == 0) {
+ ks = kbot - ns + 1;
+ i__2 = ks + 1;
+ for (i__ = kbot; i__ >= i__2; i__ += -2) {
+ i__3 = i__;
+ i__4 = i__ + i__ * h_dim1;
+ i__5 = i__ + (i__ - 1) * h_dim1;
+ r__3 = ((r__1 = h__[i__5].r, dabs(r__1)) + (r__2 =
+ r_imag(&h__[i__ + (i__ - 1) * h_dim1]), dabs(
+ r__2))) * .75f;
+ q__1.r = h__[i__4].r + r__3, q__1.i = h__[i__4].i;
+ w[i__3].r = q__1.r, w[i__3].i = q__1.i;
+ i__3 = i__ - 1;
+ i__4 = i__;
+ w[i__3].r = w[i__4].r, w[i__3].i = w[i__4].i;
+/* L30: */
+ }
+ } else {
+
+/* ==== Got NS/2 or fewer shifts? Use CLAHQR */
+/* . on a trailing principal submatrix to */
+/* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, */
+/* . there is enough space below the subdiagonal */
+/* . to fit an NS-by-NS scratch array.) ==== */
+
+ if (kbot - ks + 1 <= ns / 2) {
+ ks = kbot - ns + 1;
+ kt = *n - ns + 1;
+ clacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, &
+ h__[kt + h_dim1], ldh);
+ clahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[kt
+ + h_dim1], ldh, &w[ks], &c__1, &c__1, zdum, &
+ c__1, &inf);
+ ks += inf;
+
+/* ==== In case of a rare QR failure use */
+/* . eigenvalues of the trailing 2-by-2 */
+/* . principal submatrix. Scale to avoid */
+/* . overflows, underflows and subnormals. */
+/* . (The scale factor S can not be zero, */
+/* . because H(KBOT,KBOT-1) is nonzero.) ==== */
+
+ if (ks >= kbot) {
+ i__2 = kbot - 1 + (kbot - 1) * h_dim1;
+ i__3 = kbot + (kbot - 1) * h_dim1;
+ i__4 = kbot - 1 + kbot * h_dim1;
+ i__5 = kbot + kbot * h_dim1;
+ s = (r__1 = h__[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&h__[kbot - 1 + (kbot - 1) *
+ h_dim1]), dabs(r__2)) + ((r__3 = h__[i__3]
+ .r, dabs(r__3)) + (r__4 = r_imag(&h__[
+ kbot + (kbot - 1) * h_dim1]), dabs(r__4)))
+ + ((r__5 = h__[i__4].r, dabs(r__5)) + (
+ r__6 = r_imag(&h__[kbot - 1 + kbot *
+ h_dim1]), dabs(r__6))) + ((r__7 = h__[
+ i__5].r, dabs(r__7)) + (r__8 = r_imag(&
+ h__[kbot + kbot * h_dim1]), dabs(r__8)));
+ i__2 = kbot - 1 + (kbot - 1) * h_dim1;
+ q__1.r = h__[i__2].r / s, q__1.i = h__[i__2].i /
+ s;
+ aa.r = q__1.r, aa.i = q__1.i;
+ i__2 = kbot + (kbot - 1) * h_dim1;
+ q__1.r = h__[i__2].r / s, q__1.i = h__[i__2].i /
+ s;
+ cc.r = q__1.r, cc.i = q__1.i;
+ i__2 = kbot - 1 + kbot * h_dim1;
+ q__1.r = h__[i__2].r / s, q__1.i = h__[i__2].i /
+ s;
+ bb.r = q__1.r, bb.i = q__1.i;
+ i__2 = kbot + kbot * h_dim1;
+ q__1.r = h__[i__2].r / s, q__1.i = h__[i__2].i /
+ s;
+ dd.r = q__1.r, dd.i = q__1.i;
+ q__2.r = aa.r + dd.r, q__2.i = aa.i + dd.i;
+ q__1.r = q__2.r / 2.f, q__1.i = q__2.i / 2.f;
+ tr2.r = q__1.r, tr2.i = q__1.i;
+ q__3.r = aa.r - tr2.r, q__3.i = aa.i - tr2.i;
+ q__4.r = dd.r - tr2.r, q__4.i = dd.i - tr2.i;
+ q__2.r = q__3.r * q__4.r - q__3.i * q__4.i,
+ q__2.i = q__3.r * q__4.i + q__3.i *
+ q__4.r;
+ q__5.r = bb.r * cc.r - bb.i * cc.i, q__5.i = bb.r
+ * cc.i + bb.i * cc.r;
+ q__1.r = q__2.r - q__5.r, q__1.i = q__2.i -
+ q__5.i;
+ det.r = q__1.r, det.i = q__1.i;
+ q__2.r = -det.r, q__2.i = -det.i;
+ c_sqrt(&q__1, &q__2);
+ rtdisc.r = q__1.r, rtdisc.i = q__1.i;
+ i__2 = kbot - 1;
+ q__2.r = tr2.r + rtdisc.r, q__2.i = tr2.i +
+ rtdisc.i;
+ q__1.r = s * q__2.r, q__1.i = s * q__2.i;
+ w[i__2].r = q__1.r, w[i__2].i = q__1.i;
+ i__2 = kbot;
+ q__2.r = tr2.r - rtdisc.r, q__2.i = tr2.i -
+ rtdisc.i;
+ q__1.r = s * q__2.r, q__1.i = s * q__2.i;
+ w[i__2].r = q__1.r, w[i__2].i = q__1.i;
+
+ ks = kbot - 1;
+ }
+ }
+
+ if (kbot - ks + 1 > ns) {
+
+/* ==== Sort the shifts (Helps a little) ==== */
+
+ sorted = FALSE_;
+ i__2 = ks + 1;
+ for (k = kbot; k >= i__2; --k) {
+ if (sorted) {
+ goto L60;
+ }
+ sorted = TRUE_;
+ i__3 = k - 1;
+ for (i__ = ks; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__ + 1;
+ if ((r__1 = w[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&w[i__]), dabs(r__2)) < (r__3 =
+ w[i__5].r, dabs(r__3)) + (r__4 =
+ r_imag(&w[i__ + 1]), dabs(r__4))) {
+ sorted = FALSE_;
+ i__4 = i__;
+ swap.r = w[i__4].r, swap.i = w[i__4].i;
+ i__4 = i__;
+ i__5 = i__ + 1;
+ w[i__4].r = w[i__5].r, w[i__4].i = w[i__5]
+ .i;
+ i__4 = i__ + 1;
+ w[i__4].r = swap.r, w[i__4].i = swap.i;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+L60:
+ ;
+ }
+ }
+
+/* ==== If there are only two shifts, then use */
+/* . only one. ==== */
+
+ if (kbot - ks + 1 == 2) {
+ i__2 = kbot;
+ i__3 = kbot + kbot * h_dim1;
+ q__2.r = w[i__2].r - h__[i__3].r, q__2.i = w[i__2].i -
+ h__[i__3].i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ i__4 = kbot - 1;
+ i__5 = kbot + kbot * h_dim1;
+ q__4.r = w[i__4].r - h__[i__5].r, q__4.i = w[i__4].i -
+ h__[i__5].i;
+ q__3.r = q__4.r, q__3.i = q__4.i;
+ if ((r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
+ dabs(r__2)) < (r__3 = q__3.r, dabs(r__3)) + (r__4
+ = r_imag(&q__3), dabs(r__4))) {
+ i__2 = kbot - 1;
+ i__3 = kbot;
+ w[i__2].r = w[i__3].r, w[i__2].i = w[i__3].i;
+ } else {
+ i__2 = kbot;
+ i__3 = kbot - 1;
+ w[i__2].r = w[i__3].r, w[i__2].i = w[i__3].i;
+ }
+ }
+
+/* ==== Use up to NS of the the smallest magnatiude */
+/* . shifts. If there aren't NS shifts available, */
+/* . then use them all, possibly dropping one to */
+/* . make the number of shifts even. ==== */
+
+/* Computing MIN */
+ i__2 = ns, i__3 = kbot - ks + 1;
+ ns = min(i__2,i__3);
+ ns -= ns % 2;
+ ks = kbot - ns + 1;
+
+/* ==== Small-bulge multi-shift QR sweep: */
+/* . split workspace under the subdiagonal into */
+/* . - a KDU-by-KDU work array U in the lower */
+/* . left-hand-corner, */
+/* . - a KDU-by-at-least-KDU-but-more-is-better */
+/* . (KDU-by-NHo) horizontal work array WH along */
+/* . the bottom edge, */
+/* . - and an at-least-KDU-but-more-is-better-by-KDU */
+/* . (NVE-by-KDU) vertical work WV arrow along */
+/* . the left-hand-edge. ==== */
+
+ kdu = ns * 3 - 3;
+ ku = *n - kdu + 1;
+ kwh = kdu + 1;
+ nho = *n - kdu - 3 - (kdu + 1) + 1;
+ kwv = kdu + 4;
+ nve = *n - kdu - kwv + 1;
+
+/* ==== Small-bulge multi-shift QR sweep ==== */
+
+ claqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &w[ks], &
+ h__[h_offset], ldh, iloz, ihiz, &z__[z_offset], ldz, &
+ work[1], &c__3, &h__[ku + h_dim1], ldh, &nve, &h__[
+ kwv + h_dim1], ldh, &nho, &h__[ku + kwh * h_dim1],
+ ldh);
+ }
+
+/* ==== Note progress (or the lack of it). ==== */
+
+ if (ld > 0) {
+ ndfl = 1;
+ } else {
+ ++ndfl;
+ }
+
+/* ==== End of main loop ==== */
+/* L70: */
+ }
+
+/* ==== Iteration limit exceeded. Set INFO to show where */
+/* . the problem occurred and exit. ==== */
+
+ *info = kbot;
+L80:
+ ;
+ }
+
+/* ==== Return the optimal value of LWORK. ==== */
+
+ r__1 = (real) lwkopt;
+ q__1.r = r__1, q__1.i = 0.f;
+ work[1].r = q__1.r, work[1].i = q__1.i;
+
+/* ==== End of CLAQR4 ==== */
+
+ return 0;
+} /* claqr4_ */
diff --git a/SRC/claqr5.c b/SRC/claqr5.c
new file mode 100644
index 0000000..56552c3
--- /dev/null
+++ b/SRC/claqr5.c
@@ -0,0 +1,1345 @@
+/* claqr5.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int claqr5_(logical *wantt, logical *wantz, integer *kacc22,
+ integer *n, integer *ktop, integer *kbot, integer *nshfts, complex *s,
+ complex *h__, integer *ldh, integer *iloz, integer *ihiz, complex *
+ z__, integer *ldz, complex *v, integer *ldv, complex *u, integer *ldu,
+ integer *nv, complex *wv, integer *ldwv, integer *nh, complex *wh,
+ integer *ldwh)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, u_dim1, u_offset, v_dim1, v_offset, wh_dim1,
+ wh_offset, wv_dim1, wv_offset, z_dim1, z_offset, i__1, i__2, i__3,
+ i__4, i__5, i__6, i__7, i__8, i__9, i__10, i__11;
+ real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10;
+ complex q__1, q__2, q__3, q__4, q__5, q__6, q__7, q__8;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer j, k, m, i2, j2, i4, j4, k1;
+ real h11, h12, h21, h22;
+ integer m22, ns, nu;
+ complex vt[3];
+ real scl;
+ integer kdu, kms;
+ real ulp;
+ integer knz, kzs;
+ real tst1, tst2;
+ complex beta;
+ logical blk22, bmp22;
+ integer mend, jcol, jlen, jbot, mbot, jtop, jrow, mtop;
+ complex alpha;
+ logical accum;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ integer ndcol, incol, krcol, nbmps;
+ extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *), claqr1_(integer *,
+ complex *, integer *, complex *, complex *, complex *), slabad_(
+ real *, real *), clarfg_(integer *, complex *, complex *, integer
+ *, complex *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *);
+ real safmin, safmax;
+ complex refsum;
+ integer mstart;
+ real smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* This auxiliary subroutine called by CLAQR0 performs a */
+/* single small-bulge multi-shift QR sweep. */
+
+/* WANTT (input) logical scalar */
+/* WANTT = .true. if the triangular Schur factor */
+/* is being computed. WANTT is set to .false. otherwise. */
+
+/* WANTZ (input) logical scalar */
+/* WANTZ = .true. if the unitary Schur factor is being */
+/* computed. WANTZ is set to .false. otherwise. */
+
+/* KACC22 (input) integer with value 0, 1, or 2. */
+/* Specifies the computation mode of far-from-diagonal */
+/* orthogonal updates. */
+/* = 0: CLAQR5 does not accumulate reflections and does not */
+/* use matrix-matrix multiply to update far-from-diagonal */
+/* matrix entries. */
+/* = 1: CLAQR5 accumulates reflections and uses matrix-matrix */
+/* multiply to update the far-from-diagonal matrix entries. */
+/* = 2: CLAQR5 accumulates reflections, uses matrix-matrix */
+/* multiply to update the far-from-diagonal matrix entries, */
+/* and takes advantage of 2-by-2 block structure during */
+/* matrix multiplies. */
+
+/* N (input) integer scalar */
+/* N is the order of the Hessenberg matrix H upon which this */
+/* subroutine operates. */
+
+/* KTOP (input) integer scalar */
+/* KBOT (input) integer scalar */
+/* These are the first and last rows and columns of an */
+/* isolated diagonal block upon which the QR sweep is to be */
+/* applied. It is assumed without a check that */
+/* either KTOP = 1 or H(KTOP,KTOP-1) = 0 */
+/* and */
+/* either KBOT = N or H(KBOT+1,KBOT) = 0. */
+
+/* NSHFTS (input) integer scalar */
+/* NSHFTS gives the number of simultaneous shifts. NSHFTS */
+/* must be positive and even. */
+
+/* S (input/output) COMPLEX array of size (NSHFTS) */
+/* S contains the shifts of origin that define the multi- */
+/* shift QR sweep. On output S may be reordered. */
+
+/* H (input/output) COMPLEX array of size (LDH,N) */
+/* On input H contains a Hessenberg matrix. On output a */
+/* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied */
+/* to the isolated diagonal block in rows and columns KTOP */
+/* through KBOT. */
+
+/* LDH (input) integer scalar */
+/* LDH is the leading dimension of H just as declared in the */
+/* calling procedure. LDH.GE.MAX(1,N). */
+
+/* ILOZ (input) INTEGER */
+/* IHIZ (input) INTEGER */
+/* Specify the rows of Z to which transformations must be */
+/* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N */
+
+/* Z (input/output) COMPLEX array of size (LDZ,IHI) */
+/* If WANTZ = .TRUE., then the QR Sweep unitary */
+/* similarity transformation is accumulated into */
+/* Z(ILOZ:IHIZ,ILO:IHI) from the right. */
+/* If WANTZ = .FALSE., then Z is unreferenced. */
+
+/* LDZ (input) integer scalar */
+/* LDA is the leading dimension of Z just as declared in */
+/* the calling procedure. LDZ.GE.N. */
+
+/* V (workspace) COMPLEX array of size (LDV,NSHFTS/2) */
+
+/* LDV (input) integer scalar */
+/* LDV is the leading dimension of V as declared in the */
+/* calling procedure. LDV.GE.3. */
+
+/* U (workspace) COMPLEX array of size */
+/* (LDU,3*NSHFTS-3) */
+
+/* LDU (input) integer scalar */
+/* LDU is the leading dimension of U just as declared in the */
+/* in the calling subroutine. LDU.GE.3*NSHFTS-3. */
+
+/* NH (input) integer scalar */
+/* NH is the number of columns in array WH available for */
+/* workspace. NH.GE.1. */
+
+/* WH (workspace) COMPLEX array of size (LDWH,NH) */
+
+/* LDWH (input) integer scalar */
+/* Leading dimension of WH just as declared in the */
+/* calling procedure. LDWH.GE.3*NSHFTS-3. */
+
+/* NV (input) integer scalar */
+/* NV is the number of rows in WV agailable for workspace. */
+/* NV.GE.1. */
+
+/* WV (workspace) COMPLEX array of size */
+/* (LDWV,3*NSHFTS-3) */
+
+/* LDWV (input) integer scalar */
+/* LDWV is the leading dimension of WV as declared in the */
+/* in the calling subroutine. LDWV.GE.NV. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* Reference: */
+
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part I: Maintaining Well Focused Shifts, and */
+/* Level 3 Performance, SIAM Journal of Matrix Analysis, */
+/* volume 23, pages 929--947, 2002. */
+
+/* ================================================================ */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* ==== If there are no shifts, then there is nothing to do. ==== */
+
+ /* Parameter adjustments */
+ --s;
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ wv_dim1 = *ldwv;
+ wv_offset = 1 + wv_dim1;
+ wv -= wv_offset;
+ wh_dim1 = *ldwh;
+ wh_offset = 1 + wh_dim1;
+ wh -= wh_offset;
+
+ /* Function Body */
+ if (*nshfts < 2) {
+ return 0;
+ }
+
+/* ==== If the active block is empty or 1-by-1, then there */
+/* . is nothing to do. ==== */
+
+ if (*ktop >= *kbot) {
+ return 0;
+ }
+
+/* ==== NSHFTS is supposed to be even, but if it is odd, */
+/* . then simply reduce it by one. ==== */
+
+ ns = *nshfts - *nshfts % 2;
+
+/* ==== Machine constants for deflation ==== */
+
+ safmin = slamch_("SAFE MINIMUM");
+ safmax = 1.f / safmin;
+ slabad_(&safmin, &safmax);
+ ulp = slamch_("PRECISION");
+ smlnum = safmin * ((real) (*n) / ulp);
+
+/* ==== Use accumulated reflections to update far-from-diagonal */
+/* . entries ? ==== */
+
+ accum = *kacc22 == 1 || *kacc22 == 2;
+
+/* ==== If so, exploit the 2-by-2 block structure? ==== */
+
+ blk22 = ns > 2 && *kacc22 == 2;
+
+/* ==== clear trash ==== */
+
+ if (*ktop + 2 <= *kbot) {
+ i__1 = *ktop + 2 + *ktop * h_dim1;
+ h__[i__1].r = 0.f, h__[i__1].i = 0.f;
+ }
+
+/* ==== NBMPS = number of 2-shift bulges in the chain ==== */
+
+ nbmps = ns / 2;
+
+/* ==== KDU = width of slab ==== */
+
+ kdu = nbmps * 6 - 3;
+
+/* ==== Create and chase chains of NBMPS bulges ==== */
+
+ i__1 = *kbot - 2;
+ i__2 = nbmps * 3 - 2;
+ for (incol = (1 - nbmps) * 3 + *ktop - 1; i__2 < 0 ? incol >= i__1 :
+ incol <= i__1; incol += i__2) {
+ ndcol = incol + kdu;
+ if (accum) {
+ claset_("ALL", &kdu, &kdu, &c_b1, &c_b2, &u[u_offset], ldu);
+ }
+
+/* ==== Near-the-diagonal bulge chase. The following loop */
+/* . performs the near-the-diagonal part of a small bulge */
+/* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal */
+/* . chunk extends from column INCOL to column NDCOL */
+/* . (including both column INCOL and column NDCOL). The */
+/* . following loop chases a 3*NBMPS column long chain of */
+/* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL */
+/* . may be less than KTOP and and NDCOL may be greater than */
+/* . KBOT indicating phantom columns from which to chase */
+/* . bulges before they are actually introduced or to which */
+/* . to chase bulges beyond column KBOT.) ==== */
+
+/* Computing MIN */
+ i__4 = incol + nbmps * 3 - 3, i__5 = *kbot - 2;
+ i__3 = min(i__4,i__5);
+ for (krcol = incol; krcol <= i__3; ++krcol) {
+
+/* ==== Bulges number MTOP to MBOT are active double implicit */
+/* . shift bulges. There may or may not also be small */
+/* . 2-by-2 bulge, if there is room. The inactive bulges */
+/* . (if any) must wait until the active bulges have moved */
+/* . down the diagonal to make room. The phantom matrix */
+/* . paradigm described above helps keep track. ==== */
+
+/* Computing MAX */
+ i__4 = 1, i__5 = (*ktop - 1 - krcol + 2) / 3 + 1;
+ mtop = max(i__4,i__5);
+/* Computing MIN */
+ i__4 = nbmps, i__5 = (*kbot - krcol) / 3;
+ mbot = min(i__4,i__5);
+ m22 = mbot + 1;
+ bmp22 = mbot < nbmps && krcol + (m22 - 1) * 3 == *kbot - 2;
+
+/* ==== Generate reflections to chase the chain right */
+/* . one column. (The minimum value of K is KTOP-1.) ==== */
+
+ i__4 = mbot;
+ for (m = mtop; m <= i__4; ++m) {
+ k = krcol + (m - 1) * 3;
+ if (k == *ktop - 1) {
+ claqr1_(&c__3, &h__[*ktop + *ktop * h_dim1], ldh, &s[(m <<
+ 1) - 1], &s[m * 2], &v[m * v_dim1 + 1]);
+ i__5 = m * v_dim1 + 1;
+ alpha.r = v[i__5].r, alpha.i = v[i__5].i;
+ clarfg_(&c__3, &alpha, &v[m * v_dim1 + 2], &c__1, &v[m *
+ v_dim1 + 1]);
+ } else {
+ i__5 = k + 1 + k * h_dim1;
+ beta.r = h__[i__5].r, beta.i = h__[i__5].i;
+ i__5 = m * v_dim1 + 2;
+ i__6 = k + 2 + k * h_dim1;
+ v[i__5].r = h__[i__6].r, v[i__5].i = h__[i__6].i;
+ i__5 = m * v_dim1 + 3;
+ i__6 = k + 3 + k * h_dim1;
+ v[i__5].r = h__[i__6].r, v[i__5].i = h__[i__6].i;
+ clarfg_(&c__3, &beta, &v[m * v_dim1 + 2], &c__1, &v[m *
+ v_dim1 + 1]);
+
+/* ==== A Bulge may collapse because of vigilant */
+/* . deflation or destructive underflow. In the */
+/* . underflow case, try the two-small-subdiagonals */
+/* . trick to try to reinflate the bulge. ==== */
+
+ i__5 = k + 3 + k * h_dim1;
+ i__6 = k + 3 + (k + 1) * h_dim1;
+ i__7 = k + 3 + (k + 2) * h_dim1;
+ if (h__[i__5].r != 0.f || h__[i__5].i != 0.f || (h__[i__6]
+ .r != 0.f || h__[i__6].i != 0.f) || h__[i__7].r ==
+ 0.f && h__[i__7].i == 0.f) {
+
+/* ==== Typical case: not collapsed (yet). ==== */
+
+ i__5 = k + 1 + k * h_dim1;
+ h__[i__5].r = beta.r, h__[i__5].i = beta.i;
+ i__5 = k + 2 + k * h_dim1;
+ h__[i__5].r = 0.f, h__[i__5].i = 0.f;
+ i__5 = k + 3 + k * h_dim1;
+ h__[i__5].r = 0.f, h__[i__5].i = 0.f;
+ } else {
+
+/* ==== Atypical case: collapsed. Attempt to */
+/* . reintroduce ignoring H(K+1,K) and H(K+2,K). */
+/* . If the fill resulting from the new */
+/* . reflector is too large, then abandon it. */
+/* . Otherwise, use the new one. ==== */
+
+ claqr1_(&c__3, &h__[k + 1 + (k + 1) * h_dim1], ldh, &
+ s[(m << 1) - 1], &s[m * 2], vt);
+ alpha.r = vt[0].r, alpha.i = vt[0].i;
+ clarfg_(&c__3, &alpha, &vt[1], &c__1, vt);
+ r_cnjg(&q__2, vt);
+ i__5 = k + 1 + k * h_dim1;
+ r_cnjg(&q__5, &vt[1]);
+ i__6 = k + 2 + k * h_dim1;
+ q__4.r = q__5.r * h__[i__6].r - q__5.i * h__[i__6].i,
+ q__4.i = q__5.r * h__[i__6].i + q__5.i * h__[
+ i__6].r;
+ q__3.r = h__[i__5].r + q__4.r, q__3.i = h__[i__5].i +
+ q__4.i;
+ q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i =
+ q__2.r * q__3.i + q__2.i * q__3.r;
+ refsum.r = q__1.r, refsum.i = q__1.i;
+
+ i__5 = k + 2 + k * h_dim1;
+ q__3.r = refsum.r * vt[1].r - refsum.i * vt[1].i,
+ q__3.i = refsum.r * vt[1].i + refsum.i * vt[1]
+ .r;
+ q__2.r = h__[i__5].r - q__3.r, q__2.i = h__[i__5].i -
+ q__3.i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ q__5.r = refsum.r * vt[2].r - refsum.i * vt[2].i,
+ q__5.i = refsum.r * vt[2].i + refsum.i * vt[2]
+ .r;
+ q__4.r = q__5.r, q__4.i = q__5.i;
+ i__6 = k + k * h_dim1;
+ i__7 = k + 1 + (k + 1) * h_dim1;
+ i__8 = k + 2 + (k + 2) * h_dim1;
+ if ((r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
+ q__1), dabs(r__2)) + ((r__3 = q__4.r, dabs(
+ r__3)) + (r__4 = r_imag(&q__4), dabs(r__4)))
+ > ulp * ((r__5 = h__[i__6].r, dabs(r__5)) + (
+ r__6 = r_imag(&h__[k + k * h_dim1]), dabs(
+ r__6)) + ((r__7 = h__[i__7].r, dabs(r__7)) + (
+ r__8 = r_imag(&h__[k + 1 + (k + 1) * h_dim1]),
+ dabs(r__8))) + ((r__9 = h__[i__8].r, dabs(
+ r__9)) + (r__10 = r_imag(&h__[k + 2 + (k + 2)
+ * h_dim1]), dabs(r__10))))) {
+
+/* ==== Starting a new bulge here would */
+/* . create non-negligible fill. Use */
+/* . the old one with trepidation. ==== */
+
+ i__5 = k + 1 + k * h_dim1;
+ h__[i__5].r = beta.r, h__[i__5].i = beta.i;
+ i__5 = k + 2 + k * h_dim1;
+ h__[i__5].r = 0.f, h__[i__5].i = 0.f;
+ i__5 = k + 3 + k * h_dim1;
+ h__[i__5].r = 0.f, h__[i__5].i = 0.f;
+ } else {
+
+/* ==== Stating a new bulge here would */
+/* . create only negligible fill. */
+/* . Replace the old reflector with */
+/* . the new one. ==== */
+
+ i__5 = k + 1 + k * h_dim1;
+ i__6 = k + 1 + k * h_dim1;
+ q__1.r = h__[i__6].r - refsum.r, q__1.i = h__[
+ i__6].i - refsum.i;
+ h__[i__5].r = q__1.r, h__[i__5].i = q__1.i;
+ i__5 = k + 2 + k * h_dim1;
+ h__[i__5].r = 0.f, h__[i__5].i = 0.f;
+ i__5 = k + 3 + k * h_dim1;
+ h__[i__5].r = 0.f, h__[i__5].i = 0.f;
+ i__5 = m * v_dim1 + 1;
+ v[i__5].r = vt[0].r, v[i__5].i = vt[0].i;
+ i__5 = m * v_dim1 + 2;
+ v[i__5].r = vt[1].r, v[i__5].i = vt[1].i;
+ i__5 = m * v_dim1 + 3;
+ v[i__5].r = vt[2].r, v[i__5].i = vt[2].i;
+ }
+ }
+ }
+/* L10: */
+ }
+
+/* ==== Generate a 2-by-2 reflection, if needed. ==== */
+
+ k = krcol + (m22 - 1) * 3;
+ if (bmp22) {
+ if (k == *ktop - 1) {
+ claqr1_(&c__2, &h__[k + 1 + (k + 1) * h_dim1], ldh, &s[(
+ m22 << 1) - 1], &s[m22 * 2], &v[m22 * v_dim1 + 1])
+ ;
+ i__4 = m22 * v_dim1 + 1;
+ beta.r = v[i__4].r, beta.i = v[i__4].i;
+ clarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22
+ * v_dim1 + 1]);
+ } else {
+ i__4 = k + 1 + k * h_dim1;
+ beta.r = h__[i__4].r, beta.i = h__[i__4].i;
+ i__4 = m22 * v_dim1 + 2;
+ i__5 = k + 2 + k * h_dim1;
+ v[i__4].r = h__[i__5].r, v[i__4].i = h__[i__5].i;
+ clarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22
+ * v_dim1 + 1]);
+ i__4 = k + 1 + k * h_dim1;
+ h__[i__4].r = beta.r, h__[i__4].i = beta.i;
+ i__4 = k + 2 + k * h_dim1;
+ h__[i__4].r = 0.f, h__[i__4].i = 0.f;
+ }
+ }
+
+/* ==== Multiply H by reflections from the left ==== */
+
+ if (accum) {
+ jbot = min(ndcol,*kbot);
+ } else if (*wantt) {
+ jbot = *n;
+ } else {
+ jbot = *kbot;
+ }
+ i__4 = jbot;
+ for (j = max(*ktop,krcol); j <= i__4; ++j) {
+/* Computing MIN */
+ i__5 = mbot, i__6 = (j - krcol + 2) / 3;
+ mend = min(i__5,i__6);
+ i__5 = mend;
+ for (m = mtop; m <= i__5; ++m) {
+ k = krcol + (m - 1) * 3;
+ r_cnjg(&q__2, &v[m * v_dim1 + 1]);
+ i__6 = k + 1 + j * h_dim1;
+ r_cnjg(&q__6, &v[m * v_dim1 + 2]);
+ i__7 = k + 2 + j * h_dim1;
+ q__5.r = q__6.r * h__[i__7].r - q__6.i * h__[i__7].i,
+ q__5.i = q__6.r * h__[i__7].i + q__6.i * h__[i__7]
+ .r;
+ q__4.r = h__[i__6].r + q__5.r, q__4.i = h__[i__6].i +
+ q__5.i;
+ r_cnjg(&q__8, &v[m * v_dim1 + 3]);
+ i__8 = k + 3 + j * h_dim1;
+ q__7.r = q__8.r * h__[i__8].r - q__8.i * h__[i__8].i,
+ q__7.i = q__8.r * h__[i__8].i + q__8.i * h__[i__8]
+ .r;
+ q__3.r = q__4.r + q__7.r, q__3.i = q__4.i + q__7.i;
+ q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i =
+ q__2.r * q__3.i + q__2.i * q__3.r;
+ refsum.r = q__1.r, refsum.i = q__1.i;
+ i__6 = k + 1 + j * h_dim1;
+ i__7 = k + 1 + j * h_dim1;
+ q__1.r = h__[i__7].r - refsum.r, q__1.i = h__[i__7].i -
+ refsum.i;
+ h__[i__6].r = q__1.r, h__[i__6].i = q__1.i;
+ i__6 = k + 2 + j * h_dim1;
+ i__7 = k + 2 + j * h_dim1;
+ i__8 = m * v_dim1 + 2;
+ q__2.r = refsum.r * v[i__8].r - refsum.i * v[i__8].i,
+ q__2.i = refsum.r * v[i__8].i + refsum.i * v[i__8]
+ .r;
+ q__1.r = h__[i__7].r - q__2.r, q__1.i = h__[i__7].i -
+ q__2.i;
+ h__[i__6].r = q__1.r, h__[i__6].i = q__1.i;
+ i__6 = k + 3 + j * h_dim1;
+ i__7 = k + 3 + j * h_dim1;
+ i__8 = m * v_dim1 + 3;
+ q__2.r = refsum.r * v[i__8].r - refsum.i * v[i__8].i,
+ q__2.i = refsum.r * v[i__8].i + refsum.i * v[i__8]
+ .r;
+ q__1.r = h__[i__7].r - q__2.r, q__1.i = h__[i__7].i -
+ q__2.i;
+ h__[i__6].r = q__1.r, h__[i__6].i = q__1.i;
+/* L20: */
+ }
+/* L30: */
+ }
+ if (bmp22) {
+ k = krcol + (m22 - 1) * 3;
+/* Computing MAX */
+ i__4 = k + 1;
+ i__5 = jbot;
+ for (j = max(i__4,*ktop); j <= i__5; ++j) {
+ r_cnjg(&q__2, &v[m22 * v_dim1 + 1]);
+ i__4 = k + 1 + j * h_dim1;
+ r_cnjg(&q__5, &v[m22 * v_dim1 + 2]);
+ i__6 = k + 2 + j * h_dim1;
+ q__4.r = q__5.r * h__[i__6].r - q__5.i * h__[i__6].i,
+ q__4.i = q__5.r * h__[i__6].i + q__5.i * h__[i__6]
+ .r;
+ q__3.r = h__[i__4].r + q__4.r, q__3.i = h__[i__4].i +
+ q__4.i;
+ q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i =
+ q__2.r * q__3.i + q__2.i * q__3.r;
+ refsum.r = q__1.r, refsum.i = q__1.i;
+ i__4 = k + 1 + j * h_dim1;
+ i__6 = k + 1 + j * h_dim1;
+ q__1.r = h__[i__6].r - refsum.r, q__1.i = h__[i__6].i -
+ refsum.i;
+ h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
+ i__4 = k + 2 + j * h_dim1;
+ i__6 = k + 2 + j * h_dim1;
+ i__7 = m22 * v_dim1 + 2;
+ q__2.r = refsum.r * v[i__7].r - refsum.i * v[i__7].i,
+ q__2.i = refsum.r * v[i__7].i + refsum.i * v[i__7]
+ .r;
+ q__1.r = h__[i__6].r - q__2.r, q__1.i = h__[i__6].i -
+ q__2.i;
+ h__[i__4].r = q__1.r, h__[i__4].i = q__1.i;
+/* L40: */
+ }
+ }
+
+/* ==== Multiply H by reflections from the right. */
+/* . Delay filling in the last row until the */
+/* . vigilant deflation check is complete. ==== */
+
+ if (accum) {
+ jtop = max(*ktop,incol);
+ } else if (*wantt) {
+ jtop = 1;
+ } else {
+ jtop = *ktop;
+ }
+ i__5 = mbot;
+ for (m = mtop; m <= i__5; ++m) {
+ i__4 = m * v_dim1 + 1;
+ if (v[i__4].r != 0.f || v[i__4].i != 0.f) {
+ k = krcol + (m - 1) * 3;
+/* Computing MIN */
+ i__6 = *kbot, i__7 = k + 3;
+ i__4 = min(i__6,i__7);
+ for (j = jtop; j <= i__4; ++j) {
+ i__6 = m * v_dim1 + 1;
+ i__7 = j + (k + 1) * h_dim1;
+ i__8 = m * v_dim1 + 2;
+ i__9 = j + (k + 2) * h_dim1;
+ q__4.r = v[i__8].r * h__[i__9].r - v[i__8].i * h__[
+ i__9].i, q__4.i = v[i__8].r * h__[i__9].i + v[
+ i__8].i * h__[i__9].r;
+ q__3.r = h__[i__7].r + q__4.r, q__3.i = h__[i__7].i +
+ q__4.i;
+ i__10 = m * v_dim1 + 3;
+ i__11 = j + (k + 3) * h_dim1;
+ q__5.r = v[i__10].r * h__[i__11].r - v[i__10].i * h__[
+ i__11].i, q__5.i = v[i__10].r * h__[i__11].i
+ + v[i__10].i * h__[i__11].r;
+ q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
+ q__1.r = v[i__6].r * q__2.r - v[i__6].i * q__2.i,
+ q__1.i = v[i__6].r * q__2.i + v[i__6].i *
+ q__2.r;
+ refsum.r = q__1.r, refsum.i = q__1.i;
+ i__6 = j + (k + 1) * h_dim1;
+ i__7 = j + (k + 1) * h_dim1;
+ q__1.r = h__[i__7].r - refsum.r, q__1.i = h__[i__7].i
+ - refsum.i;
+ h__[i__6].r = q__1.r, h__[i__6].i = q__1.i;
+ i__6 = j + (k + 2) * h_dim1;
+ i__7 = j + (k + 2) * h_dim1;
+ r_cnjg(&q__3, &v[m * v_dim1 + 2]);
+ q__2.r = refsum.r * q__3.r - refsum.i * q__3.i,
+ q__2.i = refsum.r * q__3.i + refsum.i *
+ q__3.r;
+ q__1.r = h__[i__7].r - q__2.r, q__1.i = h__[i__7].i -
+ q__2.i;
+ h__[i__6].r = q__1.r, h__[i__6].i = q__1.i;
+ i__6 = j + (k + 3) * h_dim1;
+ i__7 = j + (k + 3) * h_dim1;
+ r_cnjg(&q__3, &v[m * v_dim1 + 3]);
+ q__2.r = refsum.r * q__3.r - refsum.i * q__3.i,
+ q__2.i = refsum.r * q__3.i + refsum.i *
+ q__3.r;
+ q__1.r = h__[i__7].r - q__2.r, q__1.i = h__[i__7].i -
+ q__2.i;
+ h__[i__6].r = q__1.r, h__[i__6].i = q__1.i;
+/* L50: */
+ }
+
+ if (accum) {
+
+/* ==== Accumulate U. (If necessary, update Z later */
+/* . with with an efficient matrix-matrix */
+/* . multiply.) ==== */
+
+ kms = k - incol;
+/* Computing MAX */
+ i__4 = 1, i__6 = *ktop - incol;
+ i__7 = kdu;
+ for (j = max(i__4,i__6); j <= i__7; ++j) {
+ i__4 = m * v_dim1 + 1;
+ i__6 = j + (kms + 1) * u_dim1;
+ i__8 = m * v_dim1 + 2;
+ i__9 = j + (kms + 2) * u_dim1;
+ q__4.r = v[i__8].r * u[i__9].r - v[i__8].i * u[
+ i__9].i, q__4.i = v[i__8].r * u[i__9].i +
+ v[i__8].i * u[i__9].r;
+ q__3.r = u[i__6].r + q__4.r, q__3.i = u[i__6].i +
+ q__4.i;
+ i__10 = m * v_dim1 + 3;
+ i__11 = j + (kms + 3) * u_dim1;
+ q__5.r = v[i__10].r * u[i__11].r - v[i__10].i * u[
+ i__11].i, q__5.i = v[i__10].r * u[i__11]
+ .i + v[i__10].i * u[i__11].r;
+ q__2.r = q__3.r + q__5.r, q__2.i = q__3.i +
+ q__5.i;
+ q__1.r = v[i__4].r * q__2.r - v[i__4].i * q__2.i,
+ q__1.i = v[i__4].r * q__2.i + v[i__4].i *
+ q__2.r;
+ refsum.r = q__1.r, refsum.i = q__1.i;
+ i__4 = j + (kms + 1) * u_dim1;
+ i__6 = j + (kms + 1) * u_dim1;
+ q__1.r = u[i__6].r - refsum.r, q__1.i = u[i__6].i
+ - refsum.i;
+ u[i__4].r = q__1.r, u[i__4].i = q__1.i;
+ i__4 = j + (kms + 2) * u_dim1;
+ i__6 = j + (kms + 2) * u_dim1;
+ r_cnjg(&q__3, &v[m * v_dim1 + 2]);
+ q__2.r = refsum.r * q__3.r - refsum.i * q__3.i,
+ q__2.i = refsum.r * q__3.i + refsum.i *
+ q__3.r;
+ q__1.r = u[i__6].r - q__2.r, q__1.i = u[i__6].i -
+ q__2.i;
+ u[i__4].r = q__1.r, u[i__4].i = q__1.i;
+ i__4 = j + (kms + 3) * u_dim1;
+ i__6 = j + (kms + 3) * u_dim1;
+ r_cnjg(&q__3, &v[m * v_dim1 + 3]);
+ q__2.r = refsum.r * q__3.r - refsum.i * q__3.i,
+ q__2.i = refsum.r * q__3.i + refsum.i *
+ q__3.r;
+ q__1.r = u[i__6].r - q__2.r, q__1.i = u[i__6].i -
+ q__2.i;
+ u[i__4].r = q__1.r, u[i__4].i = q__1.i;
+/* L60: */
+ }
+ } else if (*wantz) {
+
+/* ==== U is not accumulated, so update Z */
+/* . now by multiplying by reflections */
+/* . from the right. ==== */
+
+ i__7 = *ihiz;
+ for (j = *iloz; j <= i__7; ++j) {
+ i__4 = m * v_dim1 + 1;
+ i__6 = j + (k + 1) * z_dim1;
+ i__8 = m * v_dim1 + 2;
+ i__9 = j + (k + 2) * z_dim1;
+ q__4.r = v[i__8].r * z__[i__9].r - v[i__8].i *
+ z__[i__9].i, q__4.i = v[i__8].r * z__[
+ i__9].i + v[i__8].i * z__[i__9].r;
+ q__3.r = z__[i__6].r + q__4.r, q__3.i = z__[i__6]
+ .i + q__4.i;
+ i__10 = m * v_dim1 + 3;
+ i__11 = j + (k + 3) * z_dim1;
+ q__5.r = v[i__10].r * z__[i__11].r - v[i__10].i *
+ z__[i__11].i, q__5.i = v[i__10].r * z__[
+ i__11].i + v[i__10].i * z__[i__11].r;
+ q__2.r = q__3.r + q__5.r, q__2.i = q__3.i +
+ q__5.i;
+ q__1.r = v[i__4].r * q__2.r - v[i__4].i * q__2.i,
+ q__1.i = v[i__4].r * q__2.i + v[i__4].i *
+ q__2.r;
+ refsum.r = q__1.r, refsum.i = q__1.i;
+ i__4 = j + (k + 1) * z_dim1;
+ i__6 = j + (k + 1) * z_dim1;
+ q__1.r = z__[i__6].r - refsum.r, q__1.i = z__[
+ i__6].i - refsum.i;
+ z__[i__4].r = q__1.r, z__[i__4].i = q__1.i;
+ i__4 = j + (k + 2) * z_dim1;
+ i__6 = j + (k + 2) * z_dim1;
+ r_cnjg(&q__3, &v[m * v_dim1 + 2]);
+ q__2.r = refsum.r * q__3.r - refsum.i * q__3.i,
+ q__2.i = refsum.r * q__3.i + refsum.i *
+ q__3.r;
+ q__1.r = z__[i__6].r - q__2.r, q__1.i = z__[i__6]
+ .i - q__2.i;
+ z__[i__4].r = q__1.r, z__[i__4].i = q__1.i;
+ i__4 = j + (k + 3) * z_dim1;
+ i__6 = j + (k + 3) * z_dim1;
+ r_cnjg(&q__3, &v[m * v_dim1 + 3]);
+ q__2.r = refsum.r * q__3.r - refsum.i * q__3.i,
+ q__2.i = refsum.r * q__3.i + refsum.i *
+ q__3.r;
+ q__1.r = z__[i__6].r - q__2.r, q__1.i = z__[i__6]
+ .i - q__2.i;
+ z__[i__4].r = q__1.r, z__[i__4].i = q__1.i;
+/* L70: */
+ }
+ }
+ }
+/* L80: */
+ }
+
+/* ==== Special case: 2-by-2 reflection (if needed) ==== */
+
+ k = krcol + (m22 - 1) * 3;
+ i__5 = m22 * v_dim1 + 1;
+ if (bmp22 && (v[i__5].r != 0.f || v[i__5].i != 0.f)) {
+/* Computing MIN */
+ i__7 = *kbot, i__4 = k + 3;
+ i__5 = min(i__7,i__4);
+ for (j = jtop; j <= i__5; ++j) {
+ i__7 = m22 * v_dim1 + 1;
+ i__4 = j + (k + 1) * h_dim1;
+ i__6 = m22 * v_dim1 + 2;
+ i__8 = j + (k + 2) * h_dim1;
+ q__3.r = v[i__6].r * h__[i__8].r - v[i__6].i * h__[i__8]
+ .i, q__3.i = v[i__6].r * h__[i__8].i + v[i__6].i *
+ h__[i__8].r;
+ q__2.r = h__[i__4].r + q__3.r, q__2.i = h__[i__4].i +
+ q__3.i;
+ q__1.r = v[i__7].r * q__2.r - v[i__7].i * q__2.i, q__1.i =
+ v[i__7].r * q__2.i + v[i__7].i * q__2.r;
+ refsum.r = q__1.r, refsum.i = q__1.i;
+ i__7 = j + (k + 1) * h_dim1;
+ i__4 = j + (k + 1) * h_dim1;
+ q__1.r = h__[i__4].r - refsum.r, q__1.i = h__[i__4].i -
+ refsum.i;
+ h__[i__7].r = q__1.r, h__[i__7].i = q__1.i;
+ i__7 = j + (k + 2) * h_dim1;
+ i__4 = j + (k + 2) * h_dim1;
+ r_cnjg(&q__3, &v[m22 * v_dim1 + 2]);
+ q__2.r = refsum.r * q__3.r - refsum.i * q__3.i, q__2.i =
+ refsum.r * q__3.i + refsum.i * q__3.r;
+ q__1.r = h__[i__4].r - q__2.r, q__1.i = h__[i__4].i -
+ q__2.i;
+ h__[i__7].r = q__1.r, h__[i__7].i = q__1.i;
+/* L90: */
+ }
+
+ if (accum) {
+ kms = k - incol;
+/* Computing MAX */
+ i__5 = 1, i__7 = *ktop - incol;
+ i__4 = kdu;
+ for (j = max(i__5,i__7); j <= i__4; ++j) {
+ i__5 = m22 * v_dim1 + 1;
+ i__7 = j + (kms + 1) * u_dim1;
+ i__6 = m22 * v_dim1 + 2;
+ i__8 = j + (kms + 2) * u_dim1;
+ q__3.r = v[i__6].r * u[i__8].r - v[i__6].i * u[i__8]
+ .i, q__3.i = v[i__6].r * u[i__8].i + v[i__6]
+ .i * u[i__8].r;
+ q__2.r = u[i__7].r + q__3.r, q__2.i = u[i__7].i +
+ q__3.i;
+ q__1.r = v[i__5].r * q__2.r - v[i__5].i * q__2.i,
+ q__1.i = v[i__5].r * q__2.i + v[i__5].i *
+ q__2.r;
+ refsum.r = q__1.r, refsum.i = q__1.i;
+ i__5 = j + (kms + 1) * u_dim1;
+ i__7 = j + (kms + 1) * u_dim1;
+ q__1.r = u[i__7].r - refsum.r, q__1.i = u[i__7].i -
+ refsum.i;
+ u[i__5].r = q__1.r, u[i__5].i = q__1.i;
+ i__5 = j + (kms + 2) * u_dim1;
+ i__7 = j + (kms + 2) * u_dim1;
+ r_cnjg(&q__3, &v[m22 * v_dim1 + 2]);
+ q__2.r = refsum.r * q__3.r - refsum.i * q__3.i,
+ q__2.i = refsum.r * q__3.i + refsum.i *
+ q__3.r;
+ q__1.r = u[i__7].r - q__2.r, q__1.i = u[i__7].i -
+ q__2.i;
+ u[i__5].r = q__1.r, u[i__5].i = q__1.i;
+/* L100: */
+ }
+ } else if (*wantz) {
+ i__4 = *ihiz;
+ for (j = *iloz; j <= i__4; ++j) {
+ i__5 = m22 * v_dim1 + 1;
+ i__7 = j + (k + 1) * z_dim1;
+ i__6 = m22 * v_dim1 + 2;
+ i__8 = j + (k + 2) * z_dim1;
+ q__3.r = v[i__6].r * z__[i__8].r - v[i__6].i * z__[
+ i__8].i, q__3.i = v[i__6].r * z__[i__8].i + v[
+ i__6].i * z__[i__8].r;
+ q__2.r = z__[i__7].r + q__3.r, q__2.i = z__[i__7].i +
+ q__3.i;
+ q__1.r = v[i__5].r * q__2.r - v[i__5].i * q__2.i,
+ q__1.i = v[i__5].r * q__2.i + v[i__5].i *
+ q__2.r;
+ refsum.r = q__1.r, refsum.i = q__1.i;
+ i__5 = j + (k + 1) * z_dim1;
+ i__7 = j + (k + 1) * z_dim1;
+ q__1.r = z__[i__7].r - refsum.r, q__1.i = z__[i__7].i
+ - refsum.i;
+ z__[i__5].r = q__1.r, z__[i__5].i = q__1.i;
+ i__5 = j + (k + 2) * z_dim1;
+ i__7 = j + (k + 2) * z_dim1;
+ r_cnjg(&q__3, &v[m22 * v_dim1 + 2]);
+ q__2.r = refsum.r * q__3.r - refsum.i * q__3.i,
+ q__2.i = refsum.r * q__3.i + refsum.i *
+ q__3.r;
+ q__1.r = z__[i__7].r - q__2.r, q__1.i = z__[i__7].i -
+ q__2.i;
+ z__[i__5].r = q__1.r, z__[i__5].i = q__1.i;
+/* L110: */
+ }
+ }
+ }
+
+/* ==== Vigilant deflation check ==== */
+
+ mstart = mtop;
+ if (krcol + (mstart - 1) * 3 < *ktop) {
+ ++mstart;
+ }
+ mend = mbot;
+ if (bmp22) {
+ ++mend;
+ }
+ if (krcol == *kbot - 2) {
+ ++mend;
+ }
+ i__4 = mend;
+ for (m = mstart; m <= i__4; ++m) {
+/* Computing MIN */
+ i__5 = *kbot - 1, i__7 = krcol + (m - 1) * 3;
+ k = min(i__5,i__7);
+
+/* ==== The following convergence test requires that */
+/* . the tradition small-compared-to-nearby-diagonals */
+/* . criterion and the Ahues & Tisseur (LAWN 122, 1997) */
+/* . criteria both be satisfied. The latter improves */
+/* . accuracy in some examples. Falling back on an */
+/* . alternate convergence criterion when TST1 or TST2 */
+/* . is zero (as done here) is traditional but probably */
+/* . unnecessary. ==== */
+
+ i__5 = k + 1 + k * h_dim1;
+ if (h__[i__5].r != 0.f || h__[i__5].i != 0.f) {
+ i__5 = k + k * h_dim1;
+ i__7 = k + 1 + (k + 1) * h_dim1;
+ tst1 = (r__1 = h__[i__5].r, dabs(r__1)) + (r__2 = r_imag(&
+ h__[k + k * h_dim1]), dabs(r__2)) + ((r__3 = h__[
+ i__7].r, dabs(r__3)) + (r__4 = r_imag(&h__[k + 1
+ + (k + 1) * h_dim1]), dabs(r__4)));
+ if (tst1 == 0.f) {
+ if (k >= *ktop + 1) {
+ i__5 = k + (k - 1) * h_dim1;
+ tst1 += (r__1 = h__[i__5].r, dabs(r__1)) + (r__2 =
+ r_imag(&h__[k + (k - 1) * h_dim1]), dabs(
+ r__2));
+ }
+ if (k >= *ktop + 2) {
+ i__5 = k + (k - 2) * h_dim1;
+ tst1 += (r__1 = h__[i__5].r, dabs(r__1)) + (r__2 =
+ r_imag(&h__[k + (k - 2) * h_dim1]), dabs(
+ r__2));
+ }
+ if (k >= *ktop + 3) {
+ i__5 = k + (k - 3) * h_dim1;
+ tst1 += (r__1 = h__[i__5].r, dabs(r__1)) + (r__2 =
+ r_imag(&h__[k + (k - 3) * h_dim1]), dabs(
+ r__2));
+ }
+ if (k <= *kbot - 2) {
+ i__5 = k + 2 + (k + 1) * h_dim1;
+ tst1 += (r__1 = h__[i__5].r, dabs(r__1)) + (r__2 =
+ r_imag(&h__[k + 2 + (k + 1) * h_dim1]),
+ dabs(r__2));
+ }
+ if (k <= *kbot - 3) {
+ i__5 = k + 3 + (k + 1) * h_dim1;
+ tst1 += (r__1 = h__[i__5].r, dabs(r__1)) + (r__2 =
+ r_imag(&h__[k + 3 + (k + 1) * h_dim1]),
+ dabs(r__2));
+ }
+ if (k <= *kbot - 4) {
+ i__5 = k + 4 + (k + 1) * h_dim1;
+ tst1 += (r__1 = h__[i__5].r, dabs(r__1)) + (r__2 =
+ r_imag(&h__[k + 4 + (k + 1) * h_dim1]),
+ dabs(r__2));
+ }
+ }
+ i__5 = k + 1 + k * h_dim1;
+/* Computing MAX */
+ r__3 = smlnum, r__4 = ulp * tst1;
+ if ((r__1 = h__[i__5].r, dabs(r__1)) + (r__2 = r_imag(&
+ h__[k + 1 + k * h_dim1]), dabs(r__2)) <= dmax(
+ r__3,r__4)) {
+/* Computing MAX */
+ i__5 = k + 1 + k * h_dim1;
+ i__7 = k + (k + 1) * h_dim1;
+ r__5 = (r__1 = h__[i__5].r, dabs(r__1)) + (r__2 =
+ r_imag(&h__[k + 1 + k * h_dim1]), dabs(r__2)),
+ r__6 = (r__3 = h__[i__7].r, dabs(r__3)) + (
+ r__4 = r_imag(&h__[k + (k + 1) * h_dim1]),
+ dabs(r__4));
+ h12 = dmax(r__5,r__6);
+/* Computing MIN */
+ i__5 = k + 1 + k * h_dim1;
+ i__7 = k + (k + 1) * h_dim1;
+ r__5 = (r__1 = h__[i__5].r, dabs(r__1)) + (r__2 =
+ r_imag(&h__[k + 1 + k * h_dim1]), dabs(r__2)),
+ r__6 = (r__3 = h__[i__7].r, dabs(r__3)) + (
+ r__4 = r_imag(&h__[k + (k + 1) * h_dim1]),
+ dabs(r__4));
+ h21 = dmin(r__5,r__6);
+ i__5 = k + k * h_dim1;
+ i__7 = k + 1 + (k + 1) * h_dim1;
+ q__2.r = h__[i__5].r - h__[i__7].r, q__2.i = h__[i__5]
+ .i - h__[i__7].i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+/* Computing MAX */
+ i__6 = k + 1 + (k + 1) * h_dim1;
+ r__5 = (r__1 = h__[i__6].r, dabs(r__1)) + (r__2 =
+ r_imag(&h__[k + 1 + (k + 1) * h_dim1]), dabs(
+ r__2)), r__6 = (r__3 = q__1.r, dabs(r__3)) + (
+ r__4 = r_imag(&q__1), dabs(r__4));
+ h11 = dmax(r__5,r__6);
+ i__5 = k + k * h_dim1;
+ i__7 = k + 1 + (k + 1) * h_dim1;
+ q__2.r = h__[i__5].r - h__[i__7].r, q__2.i = h__[i__5]
+ .i - h__[i__7].i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+/* Computing MIN */
+ i__6 = k + 1 + (k + 1) * h_dim1;
+ r__5 = (r__1 = h__[i__6].r, dabs(r__1)) + (r__2 =
+ r_imag(&h__[k + 1 + (k + 1) * h_dim1]), dabs(
+ r__2)), r__6 = (r__3 = q__1.r, dabs(r__3)) + (
+ r__4 = r_imag(&q__1), dabs(r__4));
+ h22 = dmin(r__5,r__6);
+ scl = h11 + h12;
+ tst2 = h22 * (h11 / scl);
+
+/* Computing MAX */
+ r__1 = smlnum, r__2 = ulp * tst2;
+ if (tst2 == 0.f || h21 * (h12 / scl) <= dmax(r__1,
+ r__2)) {
+ i__5 = k + 1 + k * h_dim1;
+ h__[i__5].r = 0.f, h__[i__5].i = 0.f;
+ }
+ }
+ }
+/* L120: */
+ }
+
+/* ==== Fill in the last row of each bulge. ==== */
+
+/* Computing MIN */
+ i__4 = nbmps, i__5 = (*kbot - krcol - 1) / 3;
+ mend = min(i__4,i__5);
+ i__4 = mend;
+ for (m = mtop; m <= i__4; ++m) {
+ k = krcol + (m - 1) * 3;
+ i__5 = m * v_dim1 + 1;
+ i__7 = m * v_dim1 + 3;
+ q__2.r = v[i__5].r * v[i__7].r - v[i__5].i * v[i__7].i,
+ q__2.i = v[i__5].r * v[i__7].i + v[i__5].i * v[i__7]
+ .r;
+ i__6 = k + 4 + (k + 3) * h_dim1;
+ q__1.r = q__2.r * h__[i__6].r - q__2.i * h__[i__6].i, q__1.i =
+ q__2.r * h__[i__6].i + q__2.i * h__[i__6].r;
+ refsum.r = q__1.r, refsum.i = q__1.i;
+ i__5 = k + 4 + (k + 1) * h_dim1;
+ q__1.r = -refsum.r, q__1.i = -refsum.i;
+ h__[i__5].r = q__1.r, h__[i__5].i = q__1.i;
+ i__5 = k + 4 + (k + 2) * h_dim1;
+ q__2.r = -refsum.r, q__2.i = -refsum.i;
+ r_cnjg(&q__3, &v[m * v_dim1 + 2]);
+ q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r *
+ q__3.i + q__2.i * q__3.r;
+ h__[i__5].r = q__1.r, h__[i__5].i = q__1.i;
+ i__5 = k + 4 + (k + 3) * h_dim1;
+ i__7 = k + 4 + (k + 3) * h_dim1;
+ r_cnjg(&q__3, &v[m * v_dim1 + 3]);
+ q__2.r = refsum.r * q__3.r - refsum.i * q__3.i, q__2.i =
+ refsum.r * q__3.i + refsum.i * q__3.r;
+ q__1.r = h__[i__7].r - q__2.r, q__1.i = h__[i__7].i - q__2.i;
+ h__[i__5].r = q__1.r, h__[i__5].i = q__1.i;
+/* L130: */
+ }
+
+/* ==== End of near-the-diagonal bulge chase. ==== */
+
+/* L140: */
+ }
+
+/* ==== Use U (if accumulated) to update far-from-diagonal */
+/* . entries in H. If required, use U to update Z as */
+/* . well. ==== */
+
+ if (accum) {
+ if (*wantt) {
+ jtop = 1;
+ jbot = *n;
+ } else {
+ jtop = *ktop;
+ jbot = *kbot;
+ }
+ if (! blk22 || incol < *ktop || ndcol > *kbot || ns <= 2) {
+
+/* ==== Updates not exploiting the 2-by-2 block */
+/* . structure of U. K1 and NU keep track of */
+/* . the location and size of U in the special */
+/* . cases of introducing bulges and chasing */
+/* . bulges off the bottom. In these special */
+/* . cases and in case the number of shifts */
+/* . is NS = 2, there is no 2-by-2 block */
+/* . structure to exploit. ==== */
+
+/* Computing MAX */
+ i__3 = 1, i__4 = *ktop - incol;
+ k1 = max(i__3,i__4);
+/* Computing MAX */
+ i__3 = 0, i__4 = ndcol - *kbot;
+ nu = kdu - max(i__3,i__4) - k1 + 1;
+
+/* ==== Horizontal Multiply ==== */
+
+ i__3 = jbot;
+ i__4 = *nh;
+ for (jcol = min(ndcol,*kbot) + 1; i__4 < 0 ? jcol >= i__3 :
+ jcol <= i__3; jcol += i__4) {
+/* Computing MIN */
+ i__5 = *nh, i__7 = jbot - jcol + 1;
+ jlen = min(i__5,i__7);
+ cgemm_("C", "N", &nu, &jlen, &nu, &c_b2, &u[k1 + k1 *
+ u_dim1], ldu, &h__[incol + k1 + jcol * h_dim1],
+ ldh, &c_b1, &wh[wh_offset], ldwh);
+ clacpy_("ALL", &nu, &jlen, &wh[wh_offset], ldwh, &h__[
+ incol + k1 + jcol * h_dim1], ldh);
+/* L150: */
+ }
+
+/* ==== Vertical multiply ==== */
+
+ i__4 = max(*ktop,incol) - 1;
+ i__3 = *nv;
+ for (jrow = jtop; i__3 < 0 ? jrow >= i__4 : jrow <= i__4;
+ jrow += i__3) {
+/* Computing MIN */
+ i__5 = *nv, i__7 = max(*ktop,incol) - jrow;
+ jlen = min(i__5,i__7);
+ cgemm_("N", "N", &jlen, &nu, &nu, &c_b2, &h__[jrow + (
+ incol + k1) * h_dim1], ldh, &u[k1 + k1 * u_dim1],
+ ldu, &c_b1, &wv[wv_offset], ldwv);
+ clacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &h__[
+ jrow + (incol + k1) * h_dim1], ldh);
+/* L160: */
+ }
+
+/* ==== Z multiply (also vertical) ==== */
+
+ if (*wantz) {
+ i__3 = *ihiz;
+ i__4 = *nv;
+ for (jrow = *iloz; i__4 < 0 ? jrow >= i__3 : jrow <= i__3;
+ jrow += i__4) {
+/* Computing MIN */
+ i__5 = *nv, i__7 = *ihiz - jrow + 1;
+ jlen = min(i__5,i__7);
+ cgemm_("N", "N", &jlen, &nu, &nu, &c_b2, &z__[jrow + (
+ incol + k1) * z_dim1], ldz, &u[k1 + k1 *
+ u_dim1], ldu, &c_b1, &wv[wv_offset], ldwv);
+ clacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &z__[
+ jrow + (incol + k1) * z_dim1], ldz)
+ ;
+/* L170: */
+ }
+ }
+ } else {
+
+/* ==== Updates exploiting U's 2-by-2 block structure. */
+/* . (I2, I4, J2, J4 are the last rows and columns */
+/* . of the blocks.) ==== */
+
+ i2 = (kdu + 1) / 2;
+ i4 = kdu;
+ j2 = i4 - i2;
+ j4 = kdu;
+
+/* ==== KZS and KNZ deal with the band of zeros */
+/* . along the diagonal of one of the triangular */
+/* . blocks. ==== */
+
+ kzs = j4 - j2 - (ns + 1);
+ knz = ns + 1;
+
+/* ==== Horizontal multiply ==== */
+
+ i__4 = jbot;
+ i__3 = *nh;
+ for (jcol = min(ndcol,*kbot) + 1; i__3 < 0 ? jcol >= i__4 :
+ jcol <= i__4; jcol += i__3) {
+/* Computing MIN */
+ i__5 = *nh, i__7 = jbot - jcol + 1;
+ jlen = min(i__5,i__7);
+
+/* ==== Copy bottom of H to top+KZS of scratch ==== */
+/* (The first KZS rows get multiplied by zero.) ==== */
+
+ clacpy_("ALL", &knz, &jlen, &h__[incol + 1 + j2 + jcol *
+ h_dim1], ldh, &wh[kzs + 1 + wh_dim1], ldwh);
+
+/* ==== Multiply by U21' ==== */
+
+ claset_("ALL", &kzs, &jlen, &c_b1, &c_b1, &wh[wh_offset],
+ ldwh);
+ ctrmm_("L", "U", "C", "N", &knz, &jlen, &c_b2, &u[j2 + 1
+ + (kzs + 1) * u_dim1], ldu, &wh[kzs + 1 + wh_dim1]
+, ldwh);
+
+/* ==== Multiply top of H by U11' ==== */
+
+ cgemm_("C", "N", &i2, &jlen, &j2, &c_b2, &u[u_offset],
+ ldu, &h__[incol + 1 + jcol * h_dim1], ldh, &c_b2,
+ &wh[wh_offset], ldwh);
+
+/* ==== Copy top of H to bottom of WH ==== */
+
+ clacpy_("ALL", &j2, &jlen, &h__[incol + 1 + jcol * h_dim1]
+, ldh, &wh[i2 + 1 + wh_dim1], ldwh);
+
+/* ==== Multiply by U21' ==== */
+
+ ctrmm_("L", "L", "C", "N", &j2, &jlen, &c_b2, &u[(i2 + 1)
+ * u_dim1 + 1], ldu, &wh[i2 + 1 + wh_dim1], ldwh);
+
+/* ==== Multiply by U22 ==== */
+
+ i__5 = i4 - i2;
+ i__7 = j4 - j2;
+ cgemm_("C", "N", &i__5, &jlen, &i__7, &c_b2, &u[j2 + 1 + (
+ i2 + 1) * u_dim1], ldu, &h__[incol + 1 + j2 +
+ jcol * h_dim1], ldh, &c_b2, &wh[i2 + 1 + wh_dim1],
+ ldwh);
+
+/* ==== Copy it back ==== */
+
+ clacpy_("ALL", &kdu, &jlen, &wh[wh_offset], ldwh, &h__[
+ incol + 1 + jcol * h_dim1], ldh);
+/* L180: */
+ }
+
+/* ==== Vertical multiply ==== */
+
+ i__3 = max(incol,*ktop) - 1;
+ i__4 = *nv;
+ for (jrow = jtop; i__4 < 0 ? jrow >= i__3 : jrow <= i__3;
+ jrow += i__4) {
+/* Computing MIN */
+ i__5 = *nv, i__7 = max(incol,*ktop) - jrow;
+ jlen = min(i__5,i__7);
+
+/* ==== Copy right of H to scratch (the first KZS */
+/* . columns get multiplied by zero) ==== */
+
+ clacpy_("ALL", &jlen, &knz, &h__[jrow + (incol + 1 + j2) *
+ h_dim1], ldh, &wv[(kzs + 1) * wv_dim1 + 1], ldwv);
+
+/* ==== Multiply by U21 ==== */
+
+ claset_("ALL", &jlen, &kzs, &c_b1, &c_b1, &wv[wv_offset],
+ ldwv);
+ ctrmm_("R", "U", "N", "N", &jlen, &knz, &c_b2, &u[j2 + 1
+ + (kzs + 1) * u_dim1], ldu, &wv[(kzs + 1) *
+ wv_dim1 + 1], ldwv);
+
+/* ==== Multiply by U11 ==== */
+
+ cgemm_("N", "N", &jlen, &i2, &j2, &c_b2, &h__[jrow + (
+ incol + 1) * h_dim1], ldh, &u[u_offset], ldu, &
+ c_b2, &wv[wv_offset], ldwv);
+
+/* ==== Copy left of H to right of scratch ==== */
+
+ clacpy_("ALL", &jlen, &j2, &h__[jrow + (incol + 1) *
+ h_dim1], ldh, &wv[(i2 + 1) * wv_dim1 + 1], ldwv);
+
+/* ==== Multiply by U21 ==== */
+
+ i__5 = i4 - i2;
+ ctrmm_("R", "L", "N", "N", &jlen, &i__5, &c_b2, &u[(i2 +
+ 1) * u_dim1 + 1], ldu, &wv[(i2 + 1) * wv_dim1 + 1]
+, ldwv);
+
+/* ==== Multiply by U22 ==== */
+
+ i__5 = i4 - i2;
+ i__7 = j4 - j2;
+ cgemm_("N", "N", &jlen, &i__5, &i__7, &c_b2, &h__[jrow + (
+ incol + 1 + j2) * h_dim1], ldh, &u[j2 + 1 + (i2 +
+ 1) * u_dim1], ldu, &c_b2, &wv[(i2 + 1) * wv_dim1
+ + 1], ldwv);
+
+/* ==== Copy it back ==== */
+
+ clacpy_("ALL", &jlen, &kdu, &wv[wv_offset], ldwv, &h__[
+ jrow + (incol + 1) * h_dim1], ldh);
+/* L190: */
+ }
+
+/* ==== Multiply Z (also vertical) ==== */
+
+ if (*wantz) {
+ i__4 = *ihiz;
+ i__3 = *nv;
+ for (jrow = *iloz; i__3 < 0 ? jrow >= i__4 : jrow <= i__4;
+ jrow += i__3) {
+/* Computing MIN */
+ i__5 = *nv, i__7 = *ihiz - jrow + 1;
+ jlen = min(i__5,i__7);
+
+/* ==== Copy right of Z to left of scratch (first */
+/* . KZS columns get multiplied by zero) ==== */
+
+ clacpy_("ALL", &jlen, &knz, &z__[jrow + (incol + 1 +
+ j2) * z_dim1], ldz, &wv[(kzs + 1) * wv_dim1 +
+ 1], ldwv);
+
+/* ==== Multiply by U12 ==== */
+
+ claset_("ALL", &jlen, &kzs, &c_b1, &c_b1, &wv[
+ wv_offset], ldwv);
+ ctrmm_("R", "U", "N", "N", &jlen, &knz, &c_b2, &u[j2
+ + 1 + (kzs + 1) * u_dim1], ldu, &wv[(kzs + 1)
+ * wv_dim1 + 1], ldwv);
+
+/* ==== Multiply by U11 ==== */
+
+ cgemm_("N", "N", &jlen, &i2, &j2, &c_b2, &z__[jrow + (
+ incol + 1) * z_dim1], ldz, &u[u_offset], ldu,
+ &c_b2, &wv[wv_offset], ldwv);
+
+/* ==== Copy left of Z to right of scratch ==== */
+
+ clacpy_("ALL", &jlen, &j2, &z__[jrow + (incol + 1) *
+ z_dim1], ldz, &wv[(i2 + 1) * wv_dim1 + 1],
+ ldwv);
+
+/* ==== Multiply by U21 ==== */
+
+ i__5 = i4 - i2;
+ ctrmm_("R", "L", "N", "N", &jlen, &i__5, &c_b2, &u[(
+ i2 + 1) * u_dim1 + 1], ldu, &wv[(i2 + 1) *
+ wv_dim1 + 1], ldwv);
+
+/* ==== Multiply by U22 ==== */
+
+ i__5 = i4 - i2;
+ i__7 = j4 - j2;
+ cgemm_("N", "N", &jlen, &i__5, &i__7, &c_b2, &z__[
+ jrow + (incol + 1 + j2) * z_dim1], ldz, &u[j2
+ + 1 + (i2 + 1) * u_dim1], ldu, &c_b2, &wv[(i2
+ + 1) * wv_dim1 + 1], ldwv);
+
+/* ==== Copy the result back to Z ==== */
+
+ clacpy_("ALL", &jlen, &kdu, &wv[wv_offset], ldwv, &
+ z__[jrow + (incol + 1) * z_dim1], ldz);
+/* L200: */
+ }
+ }
+ }
+ }
+/* L210: */
+ }
+
+/* ==== End of CLAQR5 ==== */
+
+ return 0;
+} /* claqr5_ */
diff --git a/SRC/claqsb.c b/SRC/claqsb.c
new file mode 100644
index 0000000..040ba50
--- /dev/null
+++ b/SRC/claqsb.c
@@ -0,0 +1,192 @@
+/* claqsb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int claqsb_(char *uplo, integer *n, integer *kd, complex *ab,
+ integer *ldab, real *s, real *scond, real *amax, char *equed)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ real r__1;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j;
+ real cj, large;
+ extern logical lsame_(char *, char *);
+ real small;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAQSB equilibrates a symmetric band matrix A using the scaling */
+/* factors in the vector S. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, if INFO = 0, the triangular factor U or L from the */
+/* Cholesky factorization A = U'*U or A = L*L' of the band */
+/* matrix A, in the same storage format as A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* S (input) REAL array, dimension (N) */
+/* The scale factors for A. */
+
+/* SCOND (input) REAL */
+/* Ratio of the smallest S(i) to the largest S(i). */
+
+/* AMAX (input) REAL */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies whether or not equilibration was done. */
+/* = 'N': No equilibration. */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if scaling should be done */
+/* based on the ratio of the scaling factors. If SCOND < THRESH, */
+/* scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if scaling should */
+/* be done based on the absolute size of the largest matrix element. */
+/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --s;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = slamch_("Safe minimum") / slamch_("Precision");
+ large = 1.f / small;
+
+ if (*scond >= .1f && *amax >= small && *amax <= large) {
+
+/* No equilibration */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Replace A by diag(S) * A * diag(S). */
+
+ if (lsame_(uplo, "U")) {
+
+/* Upper triangle of A is stored in band format. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *kd;
+ i__4 = j;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ i__2 = *kd + 1 + i__ - j + j * ab_dim1;
+ r__1 = cj * s[i__];
+ i__3 = *kd + 1 + i__ - j + j * ab_dim1;
+ q__1.r = r__1 * ab[i__3].r, q__1.i = r__1 * ab[i__3].i;
+ ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+
+/* Lower triangle of A is stored. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+/* Computing MIN */
+ i__2 = *n, i__3 = j + *kd;
+ i__4 = min(i__2,i__3);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__2 = i__ + 1 - j + j * ab_dim1;
+ r__1 = cj * s[i__];
+ i__3 = i__ + 1 - j + j * ab_dim1;
+ q__1.r = r__1 * ab[i__3].r, q__1.i = r__1 * ab[i__3].i;
+ ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ *(unsigned char *)equed = 'Y';
+ }
+
+ return 0;
+
+/* End of CLAQSB */
+
+} /* claqsb_ */
diff --git a/SRC/claqsp.c b/SRC/claqsp.c
new file mode 100644
index 0000000..f89a5f3
--- /dev/null
+++ b/SRC/claqsp.c
@@ -0,0 +1,179 @@
+/* claqsp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int claqsp_(char *uplo, integer *n, complex *ap, real *s,
+ real *scond, real *amax, char *equed)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j, jc;
+ real cj, large;
+ extern logical lsame_(char *, char *);
+ real small;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAQSP equilibrates a symmetric matrix A using the scaling factors */
+/* in the vector S. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the equilibrated matrix: diag(S) * A * diag(S), in */
+/* the same storage format as A. */
+
+/* S (input) REAL array, dimension (N) */
+/* The scale factors for A. */
+
+/* SCOND (input) REAL */
+/* Ratio of the smallest S(i) to the largest S(i). */
+
+/* AMAX (input) REAL */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies whether or not equilibration was done. */
+/* = 'N': No equilibration. */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if scaling should be done */
+/* based on the ratio of the scaling factors. If SCOND < THRESH, */
+/* scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if scaling should */
+/* be done based on the absolute size of the largest matrix element. */
+/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --s;
+ --ap;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = slamch_("Safe minimum") / slamch_("Precision");
+ large = 1.f / small;
+
+ if (*scond >= .1f && *amax >= small && *amax <= large) {
+
+/* No equilibration */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Replace A by diag(S) * A * diag(S). */
+
+ if (lsame_(uplo, "U")) {
+
+/* Upper triangle of A is stored. */
+
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - 1;
+ r__1 = cj * s[i__];
+ i__4 = jc + i__ - 1;
+ q__1.r = r__1 * ap[i__4].r, q__1.i = r__1 * ap[i__4].i;
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+/* L10: */
+ }
+ jc += j;
+/* L20: */
+ }
+ } else {
+
+/* Lower triangle of A is stored. */
+
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - j;
+ r__1 = cj * s[i__];
+ i__4 = jc + i__ - j;
+ q__1.r = r__1 * ap[i__4].r, q__1.i = r__1 * ap[i__4].i;
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+/* L30: */
+ }
+ jc = jc + *n - j + 1;
+/* L40: */
+ }
+ }
+ *(unsigned char *)equed = 'Y';
+ }
+
+ return 0;
+
+/* End of CLAQSP */
+
+} /* claqsp_ */
diff --git a/SRC/claqsy.c b/SRC/claqsy.c
new file mode 100644
index 0000000..eefd906
--- /dev/null
+++ b/SRC/claqsy.c
@@ -0,0 +1,182 @@
+/* claqsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int claqsy_(char *uplo, integer *n, complex *a, integer *lda,
+ real *s, real *scond, real *amax, char *equed)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ real r__1;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j;
+ real cj, large;
+ extern logical lsame_(char *, char *);
+ real small;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAQSY equilibrates a symmetric matrix A using the scaling factors */
+/* in the vector S. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n by n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n by n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if EQUED = 'Y', the equilibrated matrix: */
+/* diag(S) * A * diag(S). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(N,1). */
+
+/* S (input) REAL array, dimension (N) */
+/* The scale factors for A. */
+
+/* SCOND (input) REAL */
+/* Ratio of the smallest S(i) to the largest S(i). */
+
+/* AMAX (input) REAL */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies whether or not equilibration was done. */
+/* = 'N': No equilibration. */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if scaling should be done */
+/* based on the ratio of the scaling factors. If SCOND < THRESH, */
+/* scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if scaling should */
+/* be done based on the absolute size of the largest matrix element. */
+/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = slamch_("Safe minimum") / slamch_("Precision");
+ large = 1.f / small;
+
+ if (*scond >= .1f && *amax >= small && *amax <= large) {
+
+/* No equilibration */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Replace A by diag(S) * A * diag(S). */
+
+ if (lsame_(uplo, "U")) {
+
+/* Upper triangle of A is stored. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ r__1 = cj * s[i__];
+ i__4 = i__ + j * a_dim1;
+ q__1.r = r__1 * a[i__4].r, q__1.i = r__1 * a[i__4].i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+
+/* Lower triangle of A is stored. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ r__1 = cj * s[i__];
+ i__4 = i__ + j * a_dim1;
+ q__1.r = r__1 * a[i__4].r, q__1.i = r__1 * a[i__4].i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ *(unsigned char *)equed = 'Y';
+ }
+
+ return 0;
+
+/* End of CLAQSY */
+
+} /* claqsy_ */
diff --git a/SRC/clar1v.c b/SRC/clar1v.c
new file mode 100644
index 0000000..b952776
--- /dev/null
+++ b/SRC/clar1v.c
@@ -0,0 +1,500 @@
+/* clar1v.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int clar1v_(integer *n, integer *b1, integer *bn, real *
+ lambda, real *d__, real *l, real *ld, real *lld, real *pivmin, real *
+ gaptol, complex *z__, logical *wantnc, integer *negcnt, real *ztz,
+ real *mingma, integer *r__, integer *isuppz, real *nrminv, real *
+ resid, real *rqcorr, real *work)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double c_abs(complex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real s;
+ integer r1, r2;
+ real eps, tmp;
+ integer neg1, neg2, indp, inds;
+ real dplus;
+ extern doublereal slamch_(char *);
+ integer indlpl, indumn;
+ extern logical sisnan_(real *);
+ real dminus;
+ logical sawnan1, sawnan2;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAR1V computes the (scaled) r-th column of the inverse of */
+/* the sumbmatrix in rows B1 through BN of the tridiagonal matrix */
+/* L D L^T - sigma I. When sigma is close to an eigenvalue, the */
+/* computed vector is an accurate eigenvector. Usually, r corresponds */
+/* to the index where the eigenvector is largest in magnitude. */
+/* The following steps accomplish this computation : */
+/* (a) Stationary qd transform, L D L^T - sigma I = L(+) D(+) L(+)^T, */
+/* (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T, */
+/* (c) Computation of the diagonal elements of the inverse of */
+/* L D L^T - sigma I by combining the above transforms, and choosing */
+/* r as the index where the diagonal of the inverse is (one of the) */
+/* largest in magnitude. */
+/* (d) Computation of the (scaled) r-th column of the inverse using the */
+/* twisted factorization obtained by combining the top part of the */
+/* the stationary and the bottom part of the progressive transform. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix L D L^T. */
+
+/* B1 (input) INTEGER */
+/* First index of the submatrix of L D L^T. */
+
+/* BN (input) INTEGER */
+/* Last index of the submatrix of L D L^T. */
+
+/* LAMBDA (input) REAL */
+/* The shift. In order to compute an accurate eigenvector, */
+/* LAMBDA should be a good approximation to an eigenvalue */
+/* of L D L^T. */
+
+/* L (input) REAL array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the unit bidiagonal matrix */
+/* L, in elements 1 to N-1. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the diagonal matrix D. */
+
+/* LD (input) REAL array, dimension (N-1) */
+/* The n-1 elements L(i)*D(i). */
+
+/* LLD (input) REAL array, dimension (N-1) */
+/* The n-1 elements L(i)*L(i)*D(i). */
+
+/* PIVMIN (input) REAL */
+/* The minimum pivot in the Sturm sequence. */
+
+/* GAPTOL (input) REAL */
+/* Tolerance that indicates when eigenvector entries are negligible */
+/* w.r.t. their contribution to the residual. */
+
+/* Z (input/output) COMPLEX array, dimension (N) */
+/* On input, all entries of Z must be set to 0. */
+/* On output, Z contains the (scaled) r-th column of the */
+/* inverse. The scaling is such that Z(R) equals 1. */
+
+/* WANTNC (input) LOGICAL */
+/* Specifies whether NEGCNT has to be computed. */
+
+/* NEGCNT (output) INTEGER */
+/* If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin */
+/* in the matrix factorization L D L^T, and NEGCNT = -1 otherwise. */
+
+/* ZTZ (output) REAL */
+/* The square of the 2-norm of Z. */
+
+/* MINGMA (output) REAL */
+/* The reciprocal of the largest (in magnitude) diagonal */
+/* element of the inverse of L D L^T - sigma I. */
+
+/* R (input/output) INTEGER */
+/* The twist index for the twisted factorization used to */
+/* compute Z. */
+/* On input, 0 <= R <= N. If R is input as 0, R is set to */
+/* the index where (L D L^T - sigma I)^{-1} is largest */
+/* in magnitude. If 1 <= R <= N, R is unchanged. */
+/* On output, R contains the twist index used to compute Z. */
+/* Ideally, R designates the position of the maximum entry in the */
+/* eigenvector. */
+
+/* ISUPPZ (output) INTEGER array, dimension (2) */
+/* The support of the vector in Z, i.e., the vector Z is */
+/* nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ). */
+
+/* NRMINV (output) REAL */
+/* NRMINV = 1/SQRT( ZTZ ) */
+
+/* RESID (output) REAL */
+/* The residual of the FP vector. */
+/* RESID = ABS( MINGMA )/SQRT( ZTZ ) */
+
+/* RQCORR (output) REAL */
+/* The Rayleigh Quotient correction to LAMBDA. */
+/* RQCORR = MINGMA*TMP */
+
+/* WORK (workspace) REAL array, dimension (4*N) */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --isuppz;
+ --z__;
+ --lld;
+ --ld;
+ --l;
+ --d__;
+
+ /* Function Body */
+ eps = slamch_("Precision");
+ if (*r__ == 0) {
+ r1 = *b1;
+ r2 = *bn;
+ } else {
+ r1 = *r__;
+ r2 = *r__;
+ }
+/* Storage for LPLUS */
+ indlpl = 0;
+/* Storage for UMINUS */
+ indumn = *n;
+ inds = (*n << 1) + 1;
+ indp = *n * 3 + 1;
+ if (*b1 == 1) {
+ work[inds] = 0.f;
+ } else {
+ work[inds + *b1 - 1] = lld[*b1 - 1];
+ }
+
+/* Compute the stationary transform (using the differential form) */
+/* until the index R2. */
+
+ sawnan1 = FALSE_;
+ neg1 = 0;
+ s = work[inds + *b1 - 1] - *lambda;
+ i__1 = r1 - 1;
+ for (i__ = *b1; i__ <= i__1; ++i__) {
+ dplus = d__[i__] + s;
+ work[indlpl + i__] = ld[i__] / dplus;
+ if (dplus < 0.f) {
+ ++neg1;
+ }
+ work[inds + i__] = s * work[indlpl + i__] * l[i__];
+ s = work[inds + i__] - *lambda;
+/* L50: */
+ }
+ sawnan1 = sisnan_(&s);
+ if (sawnan1) {
+ goto L60;
+ }
+ i__1 = r2 - 1;
+ for (i__ = r1; i__ <= i__1; ++i__) {
+ dplus = d__[i__] + s;
+ work[indlpl + i__] = ld[i__] / dplus;
+ work[inds + i__] = s * work[indlpl + i__] * l[i__];
+ s = work[inds + i__] - *lambda;
+/* L51: */
+ }
+ sawnan1 = sisnan_(&s);
+
+L60:
+ if (sawnan1) {
+/* Runs a slower version of the above loop if a NaN is detected */
+ neg1 = 0;
+ s = work[inds + *b1 - 1] - *lambda;
+ i__1 = r1 - 1;
+ for (i__ = *b1; i__ <= i__1; ++i__) {
+ dplus = d__[i__] + s;
+ if (dabs(dplus) < *pivmin) {
+ dplus = -(*pivmin);
+ }
+ work[indlpl + i__] = ld[i__] / dplus;
+ if (dplus < 0.f) {
+ ++neg1;
+ }
+ work[inds + i__] = s * work[indlpl + i__] * l[i__];
+ if (work[indlpl + i__] == 0.f) {
+ work[inds + i__] = lld[i__];
+ }
+ s = work[inds + i__] - *lambda;
+/* L70: */
+ }
+ i__1 = r2 - 1;
+ for (i__ = r1; i__ <= i__1; ++i__) {
+ dplus = d__[i__] + s;
+ if (dabs(dplus) < *pivmin) {
+ dplus = -(*pivmin);
+ }
+ work[indlpl + i__] = ld[i__] / dplus;
+ work[inds + i__] = s * work[indlpl + i__] * l[i__];
+ if (work[indlpl + i__] == 0.f) {
+ work[inds + i__] = lld[i__];
+ }
+ s = work[inds + i__] - *lambda;
+/* L71: */
+ }
+ }
+
+/* Compute the progressive transform (using the differential form) */
+/* until the index R1 */
+
+ sawnan2 = FALSE_;
+ neg2 = 0;
+ work[indp + *bn - 1] = d__[*bn] - *lambda;
+ i__1 = r1;
+ for (i__ = *bn - 1; i__ >= i__1; --i__) {
+ dminus = lld[i__] + work[indp + i__];
+ tmp = d__[i__] / dminus;
+ if (dminus < 0.f) {
+ ++neg2;
+ }
+ work[indumn + i__] = l[i__] * tmp;
+ work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda;
+/* L80: */
+ }
+ tmp = work[indp + r1 - 1];
+ sawnan2 = sisnan_(&tmp);
+ if (sawnan2) {
+/* Runs a slower version of the above loop if a NaN is detected */
+ neg2 = 0;
+ i__1 = r1;
+ for (i__ = *bn - 1; i__ >= i__1; --i__) {
+ dminus = lld[i__] + work[indp + i__];
+ if (dabs(dminus) < *pivmin) {
+ dminus = -(*pivmin);
+ }
+ tmp = d__[i__] / dminus;
+ if (dminus < 0.f) {
+ ++neg2;
+ }
+ work[indumn + i__] = l[i__] * tmp;
+ work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda;
+ if (tmp == 0.f) {
+ work[indp + i__ - 1] = d__[i__] - *lambda;
+ }
+/* L100: */
+ }
+ }
+
+/* Find the index (from R1 to R2) of the largest (in magnitude) */
+/* diagonal element of the inverse */
+
+ *mingma = work[inds + r1 - 1] + work[indp + r1 - 1];
+ if (*mingma < 0.f) {
+ ++neg1;
+ }
+ if (*wantnc) {
+ *negcnt = neg1 + neg2;
+ } else {
+ *negcnt = -1;
+ }
+ if (dabs(*mingma) == 0.f) {
+ *mingma = eps * work[inds + r1 - 1];
+ }
+ *r__ = r1;
+ i__1 = r2 - 1;
+ for (i__ = r1; i__ <= i__1; ++i__) {
+ tmp = work[inds + i__] + work[indp + i__];
+ if (tmp == 0.f) {
+ tmp = eps * work[inds + i__];
+ }
+ if (dabs(tmp) <= dabs(*mingma)) {
+ *mingma = tmp;
+ *r__ = i__ + 1;
+ }
+/* L110: */
+ }
+
+/* Compute the FP vector: solve N^T v = e_r */
+
+ isuppz[1] = *b1;
+ isuppz[2] = *bn;
+ i__1 = *r__;
+ z__[i__1].r = 1.f, z__[i__1].i = 0.f;
+ *ztz = 1.f;
+
+/* Compute the FP vector upwards from R */
+
+ if (! sawnan1 && ! sawnan2) {
+ i__1 = *b1;
+ for (i__ = *r__ - 1; i__ >= i__1; --i__) {
+ i__2 = i__;
+ i__3 = indlpl + i__;
+ i__4 = i__ + 1;
+ q__2.r = work[i__3] * z__[i__4].r, q__2.i = work[i__3] * z__[i__4]
+ .i;
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ z__[i__2].r = q__1.r, z__[i__2].i = q__1.i;
+ if ((c_abs(&z__[i__]) + c_abs(&z__[i__ + 1])) * (r__1 = ld[i__],
+ dabs(r__1)) < *gaptol) {
+ i__2 = i__;
+ z__[i__2].r = 0.f, z__[i__2].i = 0.f;
+ isuppz[1] = i__ + 1;
+ goto L220;
+ }
+ i__2 = i__;
+ i__3 = i__;
+ q__1.r = z__[i__2].r * z__[i__3].r - z__[i__2].i * z__[i__3].i,
+ q__1.i = z__[i__2].r * z__[i__3].i + z__[i__2].i * z__[
+ i__3].r;
+ *ztz += q__1.r;
+/* L210: */
+ }
+L220:
+ ;
+ } else {
+/* Run slower loop if NaN occurred. */
+ i__1 = *b1;
+ for (i__ = *r__ - 1; i__ >= i__1; --i__) {
+ i__2 = i__ + 1;
+ if (z__[i__2].r == 0.f && z__[i__2].i == 0.f) {
+ i__2 = i__;
+ r__1 = -(ld[i__ + 1] / ld[i__]);
+ i__3 = i__ + 2;
+ q__1.r = r__1 * z__[i__3].r, q__1.i = r__1 * z__[i__3].i;
+ z__[i__2].r = q__1.r, z__[i__2].i = q__1.i;
+ } else {
+ i__2 = i__;
+ i__3 = indlpl + i__;
+ i__4 = i__ + 1;
+ q__2.r = work[i__3] * z__[i__4].r, q__2.i = work[i__3] * z__[
+ i__4].i;
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ z__[i__2].r = q__1.r, z__[i__2].i = q__1.i;
+ }
+ if ((c_abs(&z__[i__]) + c_abs(&z__[i__ + 1])) * (r__1 = ld[i__],
+ dabs(r__1)) < *gaptol) {
+ i__2 = i__;
+ z__[i__2].r = 0.f, z__[i__2].i = 0.f;
+ isuppz[1] = i__ + 1;
+ goto L240;
+ }
+ i__2 = i__;
+ i__3 = i__;
+ q__1.r = z__[i__2].r * z__[i__3].r - z__[i__2].i * z__[i__3].i,
+ q__1.i = z__[i__2].r * z__[i__3].i + z__[i__2].i * z__[
+ i__3].r;
+ *ztz += q__1.r;
+/* L230: */
+ }
+L240:
+ ;
+ }
+/* Compute the FP vector downwards from R in blocks of size BLKSIZ */
+ if (! sawnan1 && ! sawnan2) {
+ i__1 = *bn - 1;
+ for (i__ = *r__; i__ <= i__1; ++i__) {
+ i__2 = i__ + 1;
+ i__3 = indumn + i__;
+ i__4 = i__;
+ q__2.r = work[i__3] * z__[i__4].r, q__2.i = work[i__3] * z__[i__4]
+ .i;
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ z__[i__2].r = q__1.r, z__[i__2].i = q__1.i;
+ if ((c_abs(&z__[i__]) + c_abs(&z__[i__ + 1])) * (r__1 = ld[i__],
+ dabs(r__1)) < *gaptol) {
+ i__2 = i__ + 1;
+ z__[i__2].r = 0.f, z__[i__2].i = 0.f;
+ isuppz[2] = i__;
+ goto L260;
+ }
+ i__2 = i__ + 1;
+ i__3 = i__ + 1;
+ q__1.r = z__[i__2].r * z__[i__3].r - z__[i__2].i * z__[i__3].i,
+ q__1.i = z__[i__2].r * z__[i__3].i + z__[i__2].i * z__[
+ i__3].r;
+ *ztz += q__1.r;
+/* L250: */
+ }
+L260:
+ ;
+ } else {
+/* Run slower loop if NaN occurred. */
+ i__1 = *bn - 1;
+ for (i__ = *r__; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ if (z__[i__2].r == 0.f && z__[i__2].i == 0.f) {
+ i__2 = i__ + 1;
+ r__1 = -(ld[i__ - 1] / ld[i__]);
+ i__3 = i__ - 1;
+ q__1.r = r__1 * z__[i__3].r, q__1.i = r__1 * z__[i__3].i;
+ z__[i__2].r = q__1.r, z__[i__2].i = q__1.i;
+ } else {
+ i__2 = i__ + 1;
+ i__3 = indumn + i__;
+ i__4 = i__;
+ q__2.r = work[i__3] * z__[i__4].r, q__2.i = work[i__3] * z__[
+ i__4].i;
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ z__[i__2].r = q__1.r, z__[i__2].i = q__1.i;
+ }
+ if ((c_abs(&z__[i__]) + c_abs(&z__[i__ + 1])) * (r__1 = ld[i__],
+ dabs(r__1)) < *gaptol) {
+ i__2 = i__ + 1;
+ z__[i__2].r = 0.f, z__[i__2].i = 0.f;
+ isuppz[2] = i__;
+ goto L280;
+ }
+ i__2 = i__ + 1;
+ i__3 = i__ + 1;
+ q__1.r = z__[i__2].r * z__[i__3].r - z__[i__2].i * z__[i__3].i,
+ q__1.i = z__[i__2].r * z__[i__3].i + z__[i__2].i * z__[
+ i__3].r;
+ *ztz += q__1.r;
+/* L270: */
+ }
+L280:
+ ;
+ }
+
+/* Compute quantities for convergence test */
+
+ tmp = 1.f / *ztz;
+ *nrminv = sqrt(tmp);
+ *resid = dabs(*mingma) * *nrminv;
+ *rqcorr = *mingma * tmp;
+
+
+ return 0;
+
+/* End of CLAR1V */
+
+} /* clar1v_ */
diff --git a/SRC/clar2v.c b/SRC/clar2v.c
new file mode 100644
index 0000000..636d5be
--- /dev/null
+++ b/SRC/clar2v.c
@@ -0,0 +1,159 @@
+/* clar2v.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int clar2v_(integer *n, complex *x, complex *y, complex *z__,
+ integer *incx, real *c__, complex *s, integer *incc)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real r__1;
+ complex q__1, q__2, q__3, q__4, q__5;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__;
+ complex t2, t3, t4;
+ real t5, t6;
+ integer ic;
+ real ci;
+ complex si;
+ integer ix;
+ real xi, yi;
+ complex zi;
+ real t1i, t1r, sii, zii, sir, zir;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAR2V applies a vector of complex plane rotations with real cosines */
+/* from both sides to a sequence of 2-by-2 complex Hermitian matrices, */
+/* defined by the elements of the vectors x, y and z. For i = 1,2,...,n */
+
+/* ( x(i) z(i) ) := */
+/* ( conjg(z(i)) y(i) ) */
+
+/* ( c(i) conjg(s(i)) ) ( x(i) z(i) ) ( c(i) -conjg(s(i)) ) */
+/* ( -s(i) c(i) ) ( conjg(z(i)) y(i) ) ( s(i) c(i) ) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of plane rotations to be applied. */
+
+/* X (input/output) COMPLEX array, dimension (1+(N-1)*INCX) */
+/* The vector x; the elements of x are assumed to be real. */
+
+/* Y (input/output) COMPLEX array, dimension (1+(N-1)*INCX) */
+/* The vector y; the elements of y are assumed to be real. */
+
+/* Z (input/output) COMPLEX array, dimension (1+(N-1)*INCX) */
+/* The vector z. */
+
+/* INCX (input) INTEGER */
+/* The increment between elements of X, Y and Z. INCX > 0. */
+
+/* C (input) REAL array, dimension (1+(N-1)*INCC) */
+/* The cosines of the plane rotations. */
+
+/* S (input) COMPLEX array, dimension (1+(N-1)*INCC) */
+/* The sines of the plane rotations. */
+
+/* INCC (input) INTEGER */
+/* The increment between elements of C and S. INCC > 0. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --s;
+ --c__;
+ --z__;
+ --y;
+ --x;
+
+ /* Function Body */
+ ix = 1;
+ ic = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ix;
+ xi = x[i__2].r;
+ i__2 = ix;
+ yi = y[i__2].r;
+ i__2 = ix;
+ zi.r = z__[i__2].r, zi.i = z__[i__2].i;
+ zir = zi.r;
+ zii = r_imag(&zi);
+ ci = c__[ic];
+ i__2 = ic;
+ si.r = s[i__2].r, si.i = s[i__2].i;
+ sir = si.r;
+ sii = r_imag(&si);
+ t1r = sir * zir - sii * zii;
+ t1i = sir * zii + sii * zir;
+ q__1.r = ci * zi.r, q__1.i = ci * zi.i;
+ t2.r = q__1.r, t2.i = q__1.i;
+ r_cnjg(&q__3, &si);
+ q__2.r = xi * q__3.r, q__2.i = xi * q__3.i;
+ q__1.r = t2.r - q__2.r, q__1.i = t2.i - q__2.i;
+ t3.r = q__1.r, t3.i = q__1.i;
+ r_cnjg(&q__2, &t2);
+ q__3.r = yi * si.r, q__3.i = yi * si.i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ t4.r = q__1.r, t4.i = q__1.i;
+ t5 = ci * xi + t1r;
+ t6 = ci * yi - t1r;
+ i__2 = ix;
+ r__1 = ci * t5 + (sir * t4.r + sii * r_imag(&t4));
+ x[i__2].r = r__1, x[i__2].i = 0.f;
+ i__2 = ix;
+ r__1 = ci * t6 - (sir * t3.r - sii * r_imag(&t3));
+ y[i__2].r = r__1, y[i__2].i = 0.f;
+ i__2 = ix;
+ q__2.r = ci * t3.r, q__2.i = ci * t3.i;
+ r_cnjg(&q__4, &si);
+ q__5.r = t6, q__5.i = t1i;
+ q__3.r = q__4.r * q__5.r - q__4.i * q__5.i, q__3.i = q__4.r * q__5.i
+ + q__4.i * q__5.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ z__[i__2].r = q__1.r, z__[i__2].i = q__1.i;
+ ix += *incx;
+ ic += *incc;
+/* L10: */
+ }
+ return 0;
+
+/* End of CLAR2V */
+
+} /* clar2v_ */
diff --git a/SRC/clarcm.c b/SRC/clarcm.c
new file mode 100644
index 0000000..657e165
--- /dev/null
+++ b/SRC/clarcm.c
@@ -0,0 +1,176 @@
+/* clarcm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b6 = 1.f;
+static real c_b7 = 0.f;
+
+/* Subroutine */ int clarcm_(integer *m, integer *n, real *a, integer *lda,
+ complex *b, integer *ldb, complex *c__, integer *ldc, real *rwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5;
+ real r__1;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, l;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLARCM performs a very simple matrix-matrix multiplication: */
+/* C := A * B, */
+/* where A is M by M and real; B is M by N and complex; */
+/* C is M by N and complex. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A and of the matrix C. */
+/* M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns and rows of the matrix B and */
+/* the number of columns of the matrix C. */
+/* N >= 0. */
+
+/* A (input) REAL array, dimension (LDA, M) */
+/* A contains the M by M matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >=max(1,M). */
+
+/* B (input) REAL array, dimension (LDB, N) */
+/* B contains the M by N matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >=max(1,M). */
+
+/* C (input) COMPLEX array, dimension (LDC, N) */
+/* C contains the M by N matrix C. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >=max(1,M). */
+
+/* RWORK (workspace) REAL array, dimension (2*M*N) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[(j - 1) * *m + i__] = b[i__3].r;
+/* L10: */
+ }
+/* L20: */
+ }
+
+ l = *m * *n + 1;
+ sgemm_("N", "N", m, n, m, &c_b6, &a[a_offset], lda, &rwork[1], m, &c_b7, &
+ rwork[l], m);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = l + (j - 1) * *m + i__ - 1;
+ c__[i__3].r = rwork[i__4], c__[i__3].i = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ rwork[(j - 1) * *m + i__] = r_imag(&b[i__ + j * b_dim1]);
+/* L50: */
+ }
+/* L60: */
+ }
+ sgemm_("N", "N", m, n, m, &c_b6, &a[a_offset], lda, &rwork[1], m, &c_b7, &
+ rwork[l], m);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ r__1 = c__[i__4].r;
+ i__5 = l + (j - 1) * *m + i__ - 1;
+ q__1.r = r__1, q__1.i = rwork[i__5];
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+
+ return 0;
+
+/* End of CLARCM */
+
+} /* clarcm_ */
diff --git a/SRC/clarf.c b/SRC/clarf.c
new file mode 100644
index 0000000..53da4d3
--- /dev/null
+++ b/SRC/clarf.c
@@ -0,0 +1,198 @@
+/* clarf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static complex c_b2 = {0.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int clarf_(char *side, integer *m, integer *n, complex *v,
+ integer *incv, complex *tau, complex *c__, integer *ldc, complex *
+ work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1;
+ complex q__1;
+
+ /* Local variables */
+ integer i__;
+ logical applyleft;
+ extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *),
+ cgemv_(char *, integer *, integer *, complex *, complex *,
+ integer *, complex *, integer *, complex *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ integer lastc, lastv;
+ extern integer ilaclc_(integer *, integer *, complex *, integer *),
+ ilaclr_(integer *, integer *, complex *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLARF applies a complex elementary reflector H to a complex M-by-N */
+/* matrix C, from either the left or the right. H is represented in the */
+/* form */
+
+/* H = I - tau * v * v' */
+
+/* where tau is a complex scalar and v is a complex vector. */
+
+/* If tau = 0, then H is taken to be the unit matrix. */
+
+/* To apply H' (the conjugate transpose of H), supply conjg(tau) instead */
+/* tau. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': form H * C */
+/* = 'R': form C * H */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* V (input) COMPLEX array, dimension */
+/* (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
+/* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
+/* The vector v in the representation of H. V is not used if */
+/* TAU = 0. */
+
+/* INCV (input) INTEGER */
+/* The increment between elements of v. INCV <> 0. */
+
+/* TAU (input) COMPLEX */
+/* The value tau in the representation of H. */
+
+/* C (input/output) COMPLEX array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
+/* or C * H if SIDE = 'R'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (N) if SIDE = 'L' */
+/* or (M) if SIDE = 'R' */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ applyleft = lsame_(side, "L");
+ lastv = 0;
+ lastc = 0;
+ if (tau->r != 0.f || tau->i != 0.f) {
+/* Set up variables for scanning V. LASTV begins pointing to the end */
+/* of V. */
+ if (applyleft) {
+ lastv = *m;
+ } else {
+ lastv = *n;
+ }
+ if (*incv > 0) {
+ i__ = (lastv - 1) * *incv + 1;
+ } else {
+ i__ = 1;
+ }
+/* Look for the last non-zero row in V. */
+ for(;;) { /* while(complicated condition) */
+ i__1 = i__;
+ if (!(lastv > 0 && (v[i__1].r == 0.f && v[i__1].i == 0.f)))
+ break;
+ --lastv;
+ i__ -= *incv;
+ }
+ if (applyleft) {
+/* Scan for the last non-zero column in C(1:lastv,:). */
+ lastc = ilaclc_(&lastv, n, &c__[c_offset], ldc);
+ } else {
+/* Scan for the last non-zero row in C(:,1:lastv). */
+ lastc = ilaclr_(m, &lastv, &c__[c_offset], ldc);
+ }
+ }
+/* Note that lastc.eq.0 renders the BLAS operations null; no special */
+/* case is needed at this level. */
+ if (applyleft) {
+
+/* Form H * C */
+
+ if (lastv > 0) {
+
+/* w(1:lastc,1) := C(1:lastv,1:lastc)' * v(1:lastv,1) */
+
+ cgemv_("Conjugate transpose", &lastv, &lastc, &c_b1, &c__[
+ c_offset], ldc, &v[1], incv, &c_b2, &work[1], &c__1);
+
+/* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)' */
+
+ q__1.r = -tau->r, q__1.i = -tau->i;
+ cgerc_(&lastv, &lastc, &q__1, &v[1], incv, &work[1], &c__1, &c__[
+ c_offset], ldc);
+ }
+ } else {
+
+/* Form C * H */
+
+ if (lastv > 0) {
+
+/* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) */
+
+ cgemv_("No transpose", &lastc, &lastv, &c_b1, &c__[c_offset], ldc,
+ &v[1], incv, &c_b2, &work[1], &c__1);
+
+/* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)' */
+
+ q__1.r = -tau->r, q__1.i = -tau->i;
+ cgerc_(&lastc, &lastv, &q__1, &work[1], &c__1, &v[1], incv, &c__[
+ c_offset], ldc);
+ }
+ }
+ return 0;
+
+/* End of CLARF */
+
+} /* clarf_ */
diff --git a/SRC/clarfb.c b/SRC/clarfb.c
new file mode 100644
index 0000000..6b31aa1
--- /dev/null
+++ b/SRC/clarfb.c
@@ -0,0 +1,837 @@
+/* clarfb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int clarfb_(char *side, char *trans, char *direct, char *
+ storev, integer *m, integer *n, integer *k, complex *v, integer *ldv,
+ complex *t, integer *ldt, complex *c__, integer *ldc, complex *work,
+ integer *ldwork)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1,
+ work_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ integer lastc;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), ctrmm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *);
+ integer lastv;
+ extern integer ilaclc_(integer *, integer *, complex *, integer *);
+ extern /* Subroutine */ int clacgv_(integer *, complex *, integer *);
+ extern integer ilaclr_(integer *, integer *, complex *, integer *);
+ char transt[1];
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLARFB applies a complex block reflector H or its transpose H' to a */
+/* complex M-by-N matrix C, from either the left or the right. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply H or H' from the Left */
+/* = 'R': apply H or H' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply H (No transpose) */
+/* = 'C': apply H' (Conjugate transpose) */
+
+/* DIRECT (input) CHARACTER*1 */
+/* Indicates how H is formed from a product of elementary */
+/* reflectors */
+/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */
+/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
+
+/* STOREV (input) CHARACTER*1 */
+/* Indicates how the vectors which define the elementary */
+/* reflectors are stored: */
+/* = 'C': Columnwise */
+/* = 'R': Rowwise */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* K (input) INTEGER */
+/* The order of the matrix T (= the number of elementary */
+/* reflectors whose product defines the block reflector). */
+
+/* V (input) COMPLEX array, dimension */
+/* (LDV,K) if STOREV = 'C' */
+/* (LDV,M) if STOREV = 'R' and SIDE = 'L' */
+/* (LDV,N) if STOREV = 'R' and SIDE = 'R' */
+/* The matrix V. See further details. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. */
+/* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); */
+/* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); */
+/* if STOREV = 'R', LDV >= K. */
+
+/* T (input) COMPLEX array, dimension (LDT,K) */
+/* The triangular K-by-K matrix T in the representation of the */
+/* block reflector. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= K. */
+
+/* C (input/output) COMPLEX array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) COMPLEX array, dimension (LDWORK,K) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. */
+/* If SIDE = 'L', LDWORK >= max(1,N); */
+/* if SIDE = 'R', LDWORK >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+ if (lsame_(trans, "N")) {
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+ if (lsame_(storev, "C")) {
+
+ if (lsame_(direct, "F")) {
+
+/* Let V = ( V1 ) (first K rows) */
+/* ( V2 ) */
+/* where V1 is unit lower triangular. */
+
+ if (lsame_(side, "L")) {
+
+/* Form H * C or H' * C where C = ( C1 ) */
+/* ( C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilaclr_(m, k, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilaclc_(&lastv, n, &c__[c_offset], ldc);
+
+/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */
+
+/* W := C1' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1
+ + 1], &c__1);
+ clacgv_(&lastc, &work[j * work_dim1 + 1], &c__1);
+/* L10: */
+ }
+
+/* W := W * V1 */
+
+ ctrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
+ c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C2'*V2 */
+
+ i__1 = lastv - *k;
+ cgemm_("Conjugate transpose", "No transpose", &lastc, k, &
+ i__1, &c_b1, &c__[*k + 1 + c_dim1], ldc, &v[*k +
+ 1 + v_dim1], ldv, &c_b1, &work[work_offset],
+ ldwork);
+ }
+
+/* W := W * T' or W * T */
+
+ ctrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &c_b1,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - V * W' */
+
+ if (*m > *k) {
+
+/* C2 := C2 - V2 * W' */
+
+ i__1 = lastv - *k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "Conjugate transpose", &i__1, &
+ lastc, k, &q__1, &v[*k + 1 + v_dim1], ldv, &work[
+ work_offset], ldwork, &c_b1, &c__[*k + 1 + c_dim1]
+, ldc);
+ }
+
+/* W := W * V1' */
+
+ ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", &
+ lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset]
+, ldwork)
+ ;
+
+/* C1 := C1 - W' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * c_dim1;
+ i__4 = j + i__ * c_dim1;
+ r_cnjg(&q__2, &work[i__ + j * work_dim1]);
+ q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i -
+ q__2.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L20: */
+ }
+/* L30: */
+ }
+
+ } else if (lsame_(side, "R")) {
+
+/* Form C * H or C * H' where C = ( C1 C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilaclr_(n, k, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilaclr_(m, &lastv, &c__[c_offset], ldc);
+
+/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */
+
+/* W := C1 */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j *
+ work_dim1 + 1], &c__1);
+/* L40: */
+ }
+
+/* W := W * V1 */
+
+ ctrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
+ c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C2 * V2 */
+
+ i__1 = lastv - *k;
+ cgemm_("No transpose", "No transpose", &lastc, k, &i__1, &
+ c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + 1
+ + v_dim1], ldv, &c_b1, &work[work_offset], ldwork);
+ }
+
+/* W := W * T or W * T' */
+
+ ctrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b1,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - W * V' */
+
+ if (lastv > *k) {
+
+/* C2 := C2 - W * V2' */
+
+ i__1 = lastv - *k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "Conjugate transpose", &lastc, &
+ i__1, k, &q__1, &work[work_offset], ldwork, &v[*k
+ + 1 + v_dim1], ldv, &c_b1, &c__[(*k + 1) * c_dim1
+ + 1], ldc);
+ }
+
+/* W := W * V1' */
+
+ ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", &
+ lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset]
+, ldwork)
+ ;
+
+/* C1 := C1 - W */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * work_dim1;
+ q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[
+ i__4].i - work[i__5].i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+
+ } else {
+
+/* Let V = ( V1 ) */
+/* ( V2 ) (last K rows) */
+/* where V2 is unit upper triangular. */
+
+ if (lsame_(side, "L")) {
+
+/* Form H * C or H' * C where C = ( C1 ) */
+/* ( C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilaclr_(m, k, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilaclc_(&lastv, n, &c__[c_offset], ldc);
+
+/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */
+
+/* W := C2' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[
+ j * work_dim1 + 1], &c__1);
+ clacgv_(&lastc, &work[j * work_dim1 + 1], &c__1);
+/* L70: */
+ }
+
+/* W := W * V2 */
+
+ ctrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
+ c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &work[
+ work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C1'*V1 */
+
+ i__1 = lastv - *k;
+ cgemm_("Conjugate transpose", "No transpose", &lastc, k, &
+ i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset],
+ ldv, &c_b1, &work[work_offset], ldwork);
+ }
+
+/* W := W * T' or W * T */
+
+ ctrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &c_b1,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - V * W' */
+
+ if (lastv > *k) {
+
+/* C1 := C1 - V1 * W' */
+
+ i__1 = lastv - *k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "Conjugate transpose", &i__1, &
+ lastc, k, &q__1, &v[v_offset], ldv, &work[
+ work_offset], ldwork, &c_b1, &c__[c_offset], ldc);
+ }
+
+/* W := W * V2' */
+
+ ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", &
+ lastc, k, &c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &
+ work[work_offset], ldwork);
+
+/* C2 := C2 - W' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = lastv - *k + j + i__ * c_dim1;
+ i__4 = lastv - *k + j + i__ * c_dim1;
+ r_cnjg(&q__2, &work[i__ + j * work_dim1]);
+ q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i -
+ q__2.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L80: */
+ }
+/* L90: */
+ }
+
+ } else if (lsame_(side, "R")) {
+
+/* Form C * H or C * H' where C = ( C1 C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilaclr_(n, k, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilaclr_(m, &lastv, &c__[c_offset], ldc);
+
+/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */
+
+/* W := C2 */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1,
+ &work[j * work_dim1 + 1], &c__1);
+/* L100: */
+ }
+
+/* W := W * V2 */
+
+ ctrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
+ c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &work[
+ work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C1 * V1 */
+
+ i__1 = lastv - *k;
+ cgemm_("No transpose", "No transpose", &lastc, k, &i__1, &
+ c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, &
+ c_b1, &work[work_offset], ldwork);
+ }
+
+/* W := W * T or W * T' */
+
+ ctrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b1,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - W * V' */
+
+ if (lastv > *k) {
+
+/* C1 := C1 - W * V1' */
+
+ i__1 = lastv - *k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "Conjugate transpose", &lastc, &
+ i__1, k, &q__1, &work[work_offset], ldwork, &v[
+ v_offset], ldv, &c_b1, &c__[c_offset], ldc);
+ }
+
+/* W := W * V2' */
+
+ ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", &
+ lastc, k, &c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &
+ work[work_offset], ldwork);
+
+/* C2 := C2 - W */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (lastv - *k + j) * c_dim1;
+ i__4 = i__ + (lastv - *k + j) * c_dim1;
+ i__5 = i__ + j * work_dim1;
+ q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[
+ i__4].i - work[i__5].i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L110: */
+ }
+/* L120: */
+ }
+ }
+ }
+
+ } else if (lsame_(storev, "R")) {
+
+ if (lsame_(direct, "F")) {
+
+/* Let V = ( V1 V2 ) (V1: first K columns) */
+/* where V1 is unit upper triangular. */
+
+ if (lsame_(side, "L")) {
+
+/* Form H * C or H' * C where C = ( C1 ) */
+/* ( C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilaclc_(k, m, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilaclc_(&lastv, n, &c__[c_offset], ldc);
+
+/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */
+
+/* W := C1' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1
+ + 1], &c__1);
+ clacgv_(&lastc, &work[j * work_dim1 + 1], &c__1);
+/* L130: */
+ }
+
+/* W := W * V1' */
+
+ ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", &
+ lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset]
+, ldwork)
+ ;
+ if (lastv > *k) {
+
+/* W := W + C2'*V2' */
+
+ i__1 = lastv - *k;
+ cgemm_("Conjugate transpose", "Conjugate transpose", &
+ lastc, k, &i__1, &c_b1, &c__[*k + 1 + c_dim1],
+ ldc, &v[(*k + 1) * v_dim1 + 1], ldv, &c_b1, &work[
+ work_offset], ldwork);
+ }
+
+/* W := W * T' or W * T */
+
+ ctrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &c_b1,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - V' * W' */
+
+ if (lastv > *k) {
+
+/* C2 := C2 - V2' * W' */
+
+ i__1 = lastv - *k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("Conjugate transpose", "Conjugate transpose", &
+ i__1, &lastc, k, &q__1, &v[(*k + 1) * v_dim1 + 1],
+ ldv, &work[work_offset], ldwork, &c_b1, &c__[*k
+ + 1 + c_dim1], ldc);
+ }
+
+/* W := W * V1 */
+
+ ctrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
+ c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
+
+/* C1 := C1 - W' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * c_dim1;
+ i__4 = j + i__ * c_dim1;
+ r_cnjg(&q__2, &work[i__ + j * work_dim1]);
+ q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i -
+ q__2.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L140: */
+ }
+/* L150: */
+ }
+
+ } else if (lsame_(side, "R")) {
+
+/* Form C * H or C * H' where C = ( C1 C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilaclc_(k, n, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilaclr_(m, &lastv, &c__[c_offset], ldc);
+
+/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */
+
+/* W := C1 */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j *
+ work_dim1 + 1], &c__1);
+/* L160: */
+ }
+
+/* W := W * V1' */
+
+ ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", &
+ lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset]
+, ldwork)
+ ;
+ if (lastv > *k) {
+
+/* W := W + C2 * V2' */
+
+ i__1 = lastv - *k;
+ cgemm_("No transpose", "Conjugate transpose", &lastc, k, &
+ i__1, &c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[
+ (*k + 1) * v_dim1 + 1], ldv, &c_b1, &work[
+ work_offset], ldwork);
+ }
+
+/* W := W * T or W * T' */
+
+ ctrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b1,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - W * V */
+
+ if (lastv > *k) {
+
+/* C2 := C2 - W * V2 */
+
+ i__1 = lastv - *k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "No transpose", &lastc, &i__1, k, &
+ q__1, &work[work_offset], ldwork, &v[(*k + 1) *
+ v_dim1 + 1], ldv, &c_b1, &c__[(*k + 1) * c_dim1 +
+ 1], ldc);
+ }
+
+/* W := W * V1 */
+
+ ctrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
+ c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
+
+/* C1 := C1 - W */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * work_dim1;
+ q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[
+ i__4].i - work[i__5].i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L170: */
+ }
+/* L180: */
+ }
+
+ }
+
+ } else {
+
+/* Let V = ( V1 V2 ) (V2: last K columns) */
+/* where V2 is unit lower triangular. */
+
+ if (lsame_(side, "L")) {
+
+/* Form H * C or H' * C where C = ( C1 ) */
+/* ( C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilaclc_(k, m, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilaclc_(&lastv, n, &c__[c_offset], ldc);
+
+/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */
+
+/* W := C2' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[
+ j * work_dim1 + 1], &c__1);
+ clacgv_(&lastc, &work[j * work_dim1 + 1], &c__1);
+/* L190: */
+ }
+
+/* W := W * V2' */
+
+ ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", &
+ lastc, k, &c_b1, &v[(lastv - *k + 1) * v_dim1 + 1],
+ ldv, &work[work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C1'*V1' */
+
+ i__1 = lastv - *k;
+ cgemm_("Conjugate transpose", "Conjugate transpose", &
+ lastc, k, &i__1, &c_b1, &c__[c_offset], ldc, &v[
+ v_offset], ldv, &c_b1, &work[work_offset], ldwork);
+ }
+
+/* W := W * T' or W * T */
+
+ ctrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &c_b1,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - V' * W' */
+
+ if (lastv > *k) {
+
+/* C1 := C1 - V1' * W' */
+
+ i__1 = lastv - *k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("Conjugate transpose", "Conjugate transpose", &
+ i__1, &lastc, k, &q__1, &v[v_offset], ldv, &work[
+ work_offset], ldwork, &c_b1, &c__[c_offset], ldc);
+ }
+
+/* W := W * V2 */
+
+ ctrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
+ c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
+ work_offset], ldwork);
+
+/* C2 := C2 - W' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = lastv - *k + j + i__ * c_dim1;
+ i__4 = lastv - *k + j + i__ * c_dim1;
+ r_cnjg(&q__2, &work[i__ + j * work_dim1]);
+ q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i -
+ q__2.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L200: */
+ }
+/* L210: */
+ }
+
+ } else if (lsame_(side, "R")) {
+
+/* Form C * H or C * H' where C = ( C1 C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilaclc_(k, n, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilaclr_(m, &lastv, &c__[c_offset], ldc);
+
+/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */
+
+/* W := C2 */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1,
+ &work[j * work_dim1 + 1], &c__1);
+/* L220: */
+ }
+
+/* W := W * V2' */
+
+ ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", &
+ lastc, k, &c_b1, &v[(lastv - *k + 1) * v_dim1 + 1],
+ ldv, &work[work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C1 * V1' */
+
+ i__1 = lastv - *k;
+ cgemm_("No transpose", "Conjugate transpose", &lastc, k, &
+ i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset],
+ ldv, &c_b1, &work[work_offset], ldwork);
+ }
+
+/* W := W * T or W * T' */
+
+ ctrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b1,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - W * V */
+
+ if (lastv > *k) {
+
+/* C1 := C1 - W * V1 */
+
+ i__1 = lastv - *k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "No transpose", &lastc, &i__1, k, &
+ q__1, &work[work_offset], ldwork, &v[v_offset],
+ ldv, &c_b1, &c__[c_offset], ldc);
+ }
+
+/* W := W * V2 */
+
+ ctrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
+ c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
+ work_offset], ldwork);
+
+/* C1 := C1 - W */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (lastv - *k + j) * c_dim1;
+ i__4 = i__ + (lastv - *k + j) * c_dim1;
+ i__5 = i__ + j * work_dim1;
+ q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[
+ i__4].i - work[i__5].i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L230: */
+ }
+/* L240: */
+ }
+
+ }
+
+ }
+ }
+
+ return 0;
+
+/* End of CLARFB */
+
+} /* clarfb_ */
diff --git a/SRC/clarfg.c b/SRC/clarfg.c
new file mode 100644
index 0000000..2a2c3eb
--- /dev/null
+++ b/SRC/clarfg.c
@@ -0,0 +1,190 @@
+/* clarfg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b5 = {1.f,0.f};
+
+/* Subroutine */ int clarfg_(integer *n, complex *alpha, complex *x, integer *
+ incx, complex *tau)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *), r_sign(real *, real *);
+
+ /* Local variables */
+ integer j, knt;
+ real beta;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *);
+ real alphi, alphr, xnorm;
+ extern doublereal scnrm2_(integer *, complex *, integer *), slapy3_(real *
+, real *, real *);
+ extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *);
+ real safmin, rsafmn;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLARFG generates a complex elementary reflector H of order n, such */
+/* that */
+
+/* H' * ( alpha ) = ( beta ), H' * H = I. */
+/* ( x ) ( 0 ) */
+
+/* where alpha and beta are scalars, with beta real, and x is an */
+/* (n-1)-element complex vector. H is represented in the form */
+
+/* H = I - tau * ( 1 ) * ( 1 v' ) , */
+/* ( v ) */
+
+/* where tau is a complex scalar and v is a complex (n-1)-element */
+/* vector. Note that H is not hermitian. */
+
+/* If the elements of x are all zero and alpha is real, then tau = 0 */
+/* and H is taken to be the unit matrix. */
+
+/* Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the elementary reflector. */
+
+/* ALPHA (input/output) COMPLEX */
+/* On entry, the value alpha. */
+/* On exit, it is overwritten with the value beta. */
+
+/* X (input/output) COMPLEX array, dimension */
+/* (1+(N-2)*abs(INCX)) */
+/* On entry, the vector x. */
+/* On exit, it is overwritten with the vector v. */
+
+/* INCX (input) INTEGER */
+/* The increment between elements of X. INCX > 0. */
+
+/* TAU (output) COMPLEX */
+/* The value tau. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --x;
+
+ /* Function Body */
+ if (*n <= 0) {
+ tau->r = 0.f, tau->i = 0.f;
+ return 0;
+ }
+
+ i__1 = *n - 1;
+ xnorm = scnrm2_(&i__1, &x[1], incx);
+ alphr = alpha->r;
+ alphi = r_imag(alpha);
+
+ if (xnorm == 0.f && alphi == 0.f) {
+
+/* H = I */
+
+ tau->r = 0.f, tau->i = 0.f;
+ } else {
+
+/* general case */
+
+ r__1 = slapy3_(&alphr, &alphi, &xnorm);
+ beta = -r_sign(&r__1, &alphr);
+ safmin = slamch_("S") / slamch_("E");
+ rsafmn = 1.f / safmin;
+
+ knt = 0;
+ if (dabs(beta) < safmin) {
+
+/* XNORM, BETA may be inaccurate; scale X and recompute them */
+
+L10:
+ ++knt;
+ i__1 = *n - 1;
+ csscal_(&i__1, &rsafmn, &x[1], incx);
+ beta *= rsafmn;
+ alphi *= rsafmn;
+ alphr *= rsafmn;
+ if (dabs(beta) < safmin) {
+ goto L10;
+ }
+
+/* New BETA is at most 1, at least SAFMIN */
+
+ i__1 = *n - 1;
+ xnorm = scnrm2_(&i__1, &x[1], incx);
+ q__1.r = alphr, q__1.i = alphi;
+ alpha->r = q__1.r, alpha->i = q__1.i;
+ r__1 = slapy3_(&alphr, &alphi, &xnorm);
+ beta = -r_sign(&r__1, &alphr);
+ }
+ r__1 = (beta - alphr) / beta;
+ r__2 = -alphi / beta;
+ q__1.r = r__1, q__1.i = r__2;
+ tau->r = q__1.r, tau->i = q__1.i;
+ q__2.r = alpha->r - beta, q__2.i = alpha->i;
+ cladiv_(&q__1, &c_b5, &q__2);
+ alpha->r = q__1.r, alpha->i = q__1.i;
+ i__1 = *n - 1;
+ cscal_(&i__1, alpha, &x[1], incx);
+
+/* If ALPHA is subnormal, it may lose relative accuracy */
+
+ i__1 = knt;
+ for (j = 1; j <= i__1; ++j) {
+ beta *= safmin;
+/* L20: */
+ }
+ alpha->r = beta, alpha->i = 0.f;
+ }
+
+ return 0;
+
+/* End of CLARFG */
+
+} /* clarfg_ */
diff --git a/SRC/clarfp.c b/SRC/clarfp.c
new file mode 100644
index 0000000..5e08c2a
--- /dev/null
+++ b/SRC/clarfp.c
@@ -0,0 +1,234 @@
+/* clarfp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b5 = {1.f,0.f};
+
+/* Subroutine */ int clarfp_(integer *n, complex *alpha, complex *x, integer *
+ incx, complex *tau)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real r__1, r__2;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *), r_sign(real *, real *);
+
+ /* Local variables */
+ integer j, knt;
+ real beta;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *);
+ real alphi, alphr, xnorm;
+ extern doublereal scnrm2_(integer *, complex *, integer *), slapy2_(real *
+, real *), slapy3_(real *, real *, real *);
+ extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *);
+ real safmin, rsafmn;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLARFP generates a complex elementary reflector H of order n, such */
+/* that */
+
+/* H' * ( alpha ) = ( beta ), H' * H = I. */
+/* ( x ) ( 0 ) */
+
+/* where alpha and beta are scalars, beta is real and non-negative, and */
+/* x is an (n-1)-element complex vector. H is represented in the form */
+
+/* H = I - tau * ( 1 ) * ( 1 v' ) , */
+/* ( v ) */
+
+/* where tau is a complex scalar and v is a complex (n-1)-element */
+/* vector. Note that H is not hermitian. */
+
+/* If the elements of x are all zero and alpha is real, then tau = 0 */
+/* and H is taken to be the unit matrix. */
+
+/* Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the elementary reflector. */
+
+/* ALPHA (input/output) COMPLEX */
+/* On entry, the value alpha. */
+/* On exit, it is overwritten with the value beta. */
+
+/* X (input/output) COMPLEX array, dimension */
+/* (1+(N-2)*abs(INCX)) */
+/* On entry, the vector x. */
+/* On exit, it is overwritten with the vector v. */
+
+/* INCX (input) INTEGER */
+/* The increment between elements of X. INCX > 0. */
+
+/* TAU (output) COMPLEX */
+/* The value tau. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --x;
+
+ /* Function Body */
+ if (*n <= 0) {
+ tau->r = 0.f, tau->i = 0.f;
+ return 0;
+ }
+
+ i__1 = *n - 1;
+ xnorm = scnrm2_(&i__1, &x[1], incx);
+ alphr = alpha->r;
+ alphi = r_imag(alpha);
+
+ if (xnorm == 0.f && alphi == 0.f) {
+
+/* H = [1-alpha/abs(alpha) 0; 0 I], sign chosen so ALPHA >= 0. */
+
+ if (alphi == 0.f) {
+ if (alphr >= 0.f) {
+/* When TAU.eq.ZERO, the vector is special-cased to be */
+/* all zeros in the application routines. We do not need */
+/* to clear it. */
+ tau->r = 0.f, tau->i = 0.f;
+ } else {
+/* However, the application routines rely on explicit */
+/* zero checks when TAU.ne.ZERO, and we must clear X. */
+ tau->r = 2.f, tau->i = 0.f;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (j - 1) * *incx + 1;
+ x[i__2].r = 0.f, x[i__2].i = 0.f;
+ }
+ q__1.r = -alpha->r, q__1.i = -alpha->i;
+ alpha->r = q__1.r, alpha->i = q__1.i;
+ }
+ } else {
+/* Only "reflecting" the diagonal entry to be real and non-negative. */
+ xnorm = slapy2_(&alphr, &alphi);
+ r__1 = 1.f - alphr / xnorm;
+ r__2 = -alphi / xnorm;
+ q__1.r = r__1, q__1.i = r__2;
+ tau->r = q__1.r, tau->i = q__1.i;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (j - 1) * *incx + 1;
+ x[i__2].r = 0.f, x[i__2].i = 0.f;
+ }
+ alpha->r = xnorm, alpha->i = 0.f;
+ }
+ } else {
+
+/* general case */
+
+ r__1 = slapy3_(&alphr, &alphi, &xnorm);
+ beta = r_sign(&r__1, &alphr);
+ safmin = slamch_("S") / slamch_("E");
+ rsafmn = 1.f / safmin;
+
+ knt = 0;
+ if (dabs(beta) < safmin) {
+
+/* XNORM, BETA may be inaccurate; scale X and recompute them */
+
+L10:
+ ++knt;
+ i__1 = *n - 1;
+ csscal_(&i__1, &rsafmn, &x[1], incx);
+ beta *= rsafmn;
+ alphi *= rsafmn;
+ alphr *= rsafmn;
+ if (dabs(beta) < safmin) {
+ goto L10;
+ }
+
+/* New BETA is at most 1, at least SAFMIN */
+
+ i__1 = *n - 1;
+ xnorm = scnrm2_(&i__1, &x[1], incx);
+ q__1.r = alphr, q__1.i = alphi;
+ alpha->r = q__1.r, alpha->i = q__1.i;
+ r__1 = slapy3_(&alphr, &alphi, &xnorm);
+ beta = r_sign(&r__1, &alphr);
+ }
+ q__1.r = alpha->r + beta, q__1.i = alpha->i;
+ alpha->r = q__1.r, alpha->i = q__1.i;
+ if (beta < 0.f) {
+ beta = -beta;
+ q__2.r = -alpha->r, q__2.i = -alpha->i;
+ q__1.r = q__2.r / beta, q__1.i = q__2.i / beta;
+ tau->r = q__1.r, tau->i = q__1.i;
+ } else {
+ alphr = alphi * (alphi / alpha->r);
+ alphr += xnorm * (xnorm / alpha->r);
+ r__1 = alphr / beta;
+ r__2 = -alphi / beta;
+ q__1.r = r__1, q__1.i = r__2;
+ tau->r = q__1.r, tau->i = q__1.i;
+ r__1 = -alphr;
+ q__1.r = r__1, q__1.i = alphi;
+ alpha->r = q__1.r, alpha->i = q__1.i;
+ }
+ cladiv_(&q__1, &c_b5, alpha);
+ alpha->r = q__1.r, alpha->i = q__1.i;
+ i__1 = *n - 1;
+ cscal_(&i__1, alpha, &x[1], incx);
+
+/* If BETA is subnormal, it may lose relative accuracy */
+
+ i__1 = knt;
+ for (j = 1; j <= i__1; ++j) {
+ beta *= safmin;
+/* L20: */
+ }
+ alpha->r = beta, alpha->i = 0.f;
+ }
+
+ return 0;
+
+/* End of CLARFP */
+
+} /* clarfp_ */
diff --git a/SRC/clarft.c b/SRC/clarft.c
new file mode 100644
index 0000000..ca573e4
--- /dev/null
+++ b/SRC/clarft.c
@@ -0,0 +1,361 @@
+/* clarft.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b2 = {0.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int clarft_(char *direct, char *storev, integer *n, integer *
+ k, complex *v, integer *ldv, complex *tau, complex *t, integer *ldt)
+{
+ /* System generated locals */
+ integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j, prevlastv;
+ complex vii;
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *);
+ extern logical lsame_(char *, char *);
+ integer lastv;
+ extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
+ complex *, integer *, complex *, integer *), clacgv_(integer *, complex *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLARFT forms the triangular factor T of a complex block reflector H */
+/* of order n, which is defined as a product of k elementary reflectors. */
+
+/* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */
+
+/* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */
+
+/* If STOREV = 'C', the vector which defines the elementary reflector */
+/* H(i) is stored in the i-th column of the array V, and */
+
+/* H = I - V * T * V' */
+
+/* If STOREV = 'R', the vector which defines the elementary reflector */
+/* H(i) is stored in the i-th row of the array V, and */
+
+/* H = I - V' * T * V */
+
+/* Arguments */
+/* ========= */
+
+/* DIRECT (input) CHARACTER*1 */
+/* Specifies the order in which the elementary reflectors are */
+/* multiplied to form the block reflector: */
+/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */
+/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
+
+/* STOREV (input) CHARACTER*1 */
+/* Specifies how the vectors which define the elementary */
+/* reflectors are stored (see also Further Details): */
+/* = 'C': columnwise */
+/* = 'R': rowwise */
+
+/* N (input) INTEGER */
+/* The order of the block reflector H. N >= 0. */
+
+/* K (input) INTEGER */
+/* The order of the triangular factor T (= the number of */
+/* elementary reflectors). K >= 1. */
+
+/* V (input/output) COMPLEX array, dimension */
+/* (LDV,K) if STOREV = 'C' */
+/* (LDV,N) if STOREV = 'R' */
+/* The matrix V. See further details. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. */
+/* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */
+
+/* TAU (input) COMPLEX array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i). */
+
+/* T (output) COMPLEX array, dimension (LDT,K) */
+/* The k by k triangular factor T of the block reflector. */
+/* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */
+/* lower triangular. The rest of the array is not used. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= K. */
+
+/* Further Details */
+/* =============== */
+
+/* The shape of the matrix V and the storage of the vectors which define */
+/* the H(i) is best illustrated by the following example with n = 5 and */
+/* k = 3. The elements equal to 1 are not stored; the corresponding */
+/* array elements are modified but restored on exit. The rest of the */
+/* array is not used. */
+
+/* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */
+
+/* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */
+/* ( v1 1 ) ( 1 v2 v2 v2 ) */
+/* ( v1 v2 1 ) ( 1 v3 v3 ) */
+/* ( v1 v2 v3 ) */
+/* ( v1 v2 v3 ) */
+
+/* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */
+
+/* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */
+/* ( v1 v2 v3 ) ( v2 v2 v2 1 ) */
+/* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */
+/* ( 1 v3 ) */
+/* ( 1 ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --tau;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+
+ /* Function Body */
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (lsame_(direct, "F")) {
+ prevlastv = *n;
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ prevlastv = max(prevlastv,i__);
+ i__2 = i__;
+ if (tau[i__2].r == 0.f && tau[i__2].i == 0.f) {
+
+/* H(i) = I */
+
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * t_dim1;
+ t[i__3].r = 0.f, t[i__3].i = 0.f;
+/* L10: */
+ }
+ } else {
+
+/* general case */
+
+ i__2 = i__ + i__ * v_dim1;
+ vii.r = v[i__2].r, vii.i = v[i__2].i;
+ i__2 = i__ + i__ * v_dim1;
+ v[i__2].r = 1.f, v[i__2].i = 0.f;
+ if (lsame_(storev, "C")) {
+/* Skip any trailing zeros. */
+ i__2 = i__ + 1;
+ for (lastv = *n; lastv >= i__2; --lastv) {
+ i__3 = lastv + i__ * v_dim1;
+ if (v[i__3].r != 0.f || v[i__3].i != 0.f) {
+ break;
+ }
+ }
+ j = min(lastv,prevlastv);
+
+/* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i) */
+
+ i__2 = j - i__ + 1;
+ i__3 = i__ - 1;
+ i__4 = i__;
+ q__1.r = -tau[i__4].r, q__1.i = -tau[i__4].i;
+ cgemv_("Conjugate transpose", &i__2, &i__3, &q__1, &v[i__
+ + v_dim1], ldv, &v[i__ + i__ * v_dim1], &c__1, &
+ c_b2, &t[i__ * t_dim1 + 1], &c__1);
+ } else {
+/* Skip any trailing zeros. */
+ i__2 = i__ + 1;
+ for (lastv = *n; lastv >= i__2; --lastv) {
+ i__3 = i__ + lastv * v_dim1;
+ if (v[i__3].r != 0.f || v[i__3].i != 0.f) {
+ break;
+ }
+ }
+ j = min(lastv,prevlastv);
+
+/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)' */
+
+ if (i__ < j) {
+ i__2 = j - i__;
+ clacgv_(&i__2, &v[i__ + (i__ + 1) * v_dim1], ldv);
+ }
+ i__2 = i__ - 1;
+ i__3 = j - i__ + 1;
+ i__4 = i__;
+ q__1.r = -tau[i__4].r, q__1.i = -tau[i__4].i;
+ cgemv_("No transpose", &i__2, &i__3, &q__1, &v[i__ *
+ v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, &
+ c_b2, &t[i__ * t_dim1 + 1], &c__1);
+ if (i__ < j) {
+ i__2 = j - i__;
+ clacgv_(&i__2, &v[i__ + (i__ + 1) * v_dim1], ldv);
+ }
+ }
+ i__2 = i__ + i__ * v_dim1;
+ v[i__2].r = vii.r, v[i__2].i = vii.i;
+
+/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */
+
+ i__2 = i__ - 1;
+ ctrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[
+ t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1);
+ i__2 = i__ + i__ * t_dim1;
+ i__3 = i__;
+ t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i;
+ if (i__ > 1) {
+ prevlastv = max(prevlastv,lastv);
+ } else {
+ prevlastv = lastv;
+ }
+ }
+/* L20: */
+ }
+ } else {
+ prevlastv = 1;
+ for (i__ = *k; i__ >= 1; --i__) {
+ i__1 = i__;
+ if (tau[i__1].r == 0.f && tau[i__1].i == 0.f) {
+
+/* H(i) = I */
+
+ i__1 = *k;
+ for (j = i__; j <= i__1; ++j) {
+ i__2 = j + i__ * t_dim1;
+ t[i__2].r = 0.f, t[i__2].i = 0.f;
+/* L30: */
+ }
+ } else {
+
+/* general case */
+
+ if (i__ < *k) {
+ if (lsame_(storev, "C")) {
+ i__1 = *n - *k + i__ + i__ * v_dim1;
+ vii.r = v[i__1].r, vii.i = v[i__1].i;
+ i__1 = *n - *k + i__ + i__ * v_dim1;
+ v[i__1].r = 1.f, v[i__1].i = 0.f;
+/* Skip any leading zeros. */
+ i__1 = i__ - 1;
+ for (lastv = 1; lastv <= i__1; ++lastv) {
+ i__2 = lastv + i__ * v_dim1;
+ if (v[i__2].r != 0.f || v[i__2].i != 0.f) {
+ break;
+ }
+ }
+ j = max(lastv,prevlastv);
+
+/* T(i+1:k,i) := */
+/* - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i) */
+
+ i__1 = *n - *k + i__ - j + 1;
+ i__2 = *k - i__;
+ i__3 = i__;
+ q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i;
+ cgemv_("Conjugate transpose", &i__1, &i__2, &q__1, &v[
+ j + (i__ + 1) * v_dim1], ldv, &v[j + i__ *
+ v_dim1], &c__1, &c_b2, &t[i__ + 1 + i__ *
+ t_dim1], &c__1);
+ i__1 = *n - *k + i__ + i__ * v_dim1;
+ v[i__1].r = vii.r, v[i__1].i = vii.i;
+ } else {
+ i__1 = i__ + (*n - *k + i__) * v_dim1;
+ vii.r = v[i__1].r, vii.i = v[i__1].i;
+ i__1 = i__ + (*n - *k + i__) * v_dim1;
+ v[i__1].r = 1.f, v[i__1].i = 0.f;
+/* Skip any leading zeros. */
+ i__1 = i__ - 1;
+ for (lastv = 1; lastv <= i__1; ++lastv) {
+ i__2 = i__ + lastv * v_dim1;
+ if (v[i__2].r != 0.f || v[i__2].i != 0.f) {
+ break;
+ }
+ }
+ j = max(lastv,prevlastv);
+
+/* T(i+1:k,i) := */
+/* - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)' */
+
+ i__1 = *n - *k + i__ - 1 - j + 1;
+ clacgv_(&i__1, &v[i__ + j * v_dim1], ldv);
+ i__1 = *k - i__;
+ i__2 = *n - *k + i__ - j + 1;
+ i__3 = i__;
+ q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i;
+ cgemv_("No transpose", &i__1, &i__2, &q__1, &v[i__ +
+ 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1],
+ ldv, &c_b2, &t[i__ + 1 + i__ * t_dim1], &c__1);
+ i__1 = *n - *k + i__ - 1 - j + 1;
+ clacgv_(&i__1, &v[i__ + j * v_dim1], ldv);
+ i__1 = i__ + (*n - *k + i__) * v_dim1;
+ v[i__1].r = vii.r, v[i__1].i = vii.i;
+ }
+
+/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */
+
+ i__1 = *k - i__;
+ ctrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__
+ + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ *
+ t_dim1], &c__1)
+ ;
+ if (i__ > 1) {
+ prevlastv = min(prevlastv,lastv);
+ } else {
+ prevlastv = lastv;
+ }
+ }
+ i__1 = i__ + i__ * t_dim1;
+ i__2 = i__;
+ t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i;
+ }
+/* L40: */
+ }
+ }
+ return 0;
+
+/* End of CLARFT */
+
+} /* clarft_ */
diff --git a/SRC/clarfx.c b/SRC/clarfx.c
new file mode 100644
index 0000000..538bd47
--- /dev/null
+++ b/SRC/clarfx.c
@@ -0,0 +1,2048 @@
+/* clarfx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int clarfx_(char *side, integer *m, integer *n, complex *v,
+ complex *tau, complex *c__, integer *ldc, complex *work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
+ i__9, i__10, i__11;
+ complex q__1, q__2, q__3, q__4, q__5, q__6, q__7, q__8, q__9, q__10,
+ q__11, q__12, q__13, q__14, q__15, q__16, q__17, q__18, q__19;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer j;
+ complex t1, t2, t3, t4, t5, t6, t7, t8, t9, v1, v2, v3, v4, v5, v6, v7,
+ v8, v9, t10, v10, sum;
+ extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
+, integer *, complex *, complex *, integer *, complex *);
+ extern logical lsame_(char *, char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLARFX applies a complex elementary reflector H to a complex m by n */
+/* matrix C, from either the left or the right. H is represented in the */
+/* form */
+
+/* H = I - tau * v * v' */
+
+/* where tau is a complex scalar and v is a complex vector. */
+
+/* If tau = 0, then H is taken to be the unit matrix */
+
+/* This version uses inline code if H has order < 11. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': form H * C */
+/* = 'R': form C * H */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* V (input) COMPLEX array, dimension (M) if SIDE = 'L' */
+/* or (N) if SIDE = 'R' */
+/* The vector v in the representation of H. */
+
+/* TAU (input) COMPLEX */
+/* The value tau in the representation of H. */
+
+/* C (input/output) COMPLEX array, dimension (LDC,N) */
+/* On entry, the m by n matrix C. */
+/* On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
+/* or C * H if SIDE = 'R'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDA >= max(1,M). */
+
+/* WORK (workspace) COMPLEX array, dimension (N) if SIDE = 'L' */
+/* or (M) if SIDE = 'R' */
+/* WORK is not referenced if H has order < 11. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ if (tau->r == 0.f && tau->i == 0.f) {
+ return 0;
+ }
+ if (lsame_(side, "L")) {
+
+/* Form H * C, where H has order m. */
+
+ switch (*m) {
+ case 1: goto L10;
+ case 2: goto L30;
+ case 3: goto L50;
+ case 4: goto L70;
+ case 5: goto L90;
+ case 6: goto L110;
+ case 7: goto L130;
+ case 8: goto L150;
+ case 9: goto L170;
+ case 10: goto L190;
+ }
+
+/* Code for general M */
+
+ clarf_(side, m, n, &v[1], &c__1, tau, &c__[c_offset], ldc, &work[1]);
+ goto L410;
+L10:
+
+/* Special code for 1 x 1 Householder */
+
+ q__3.r = tau->r * v[1].r - tau->i * v[1].i, q__3.i = tau->r * v[1].i
+ + tau->i * v[1].r;
+ r_cnjg(&q__4, &v[1]);
+ q__2.r = q__3.r * q__4.r - q__3.i * q__4.i, q__2.i = q__3.r * q__4.i
+ + q__3.i * q__4.r;
+ q__1.r = 1.f - q__2.r, q__1.i = 0.f - q__2.i;
+ t1.r = q__1.r, t1.i = q__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j * c_dim1 + 1;
+ i__3 = j * c_dim1 + 1;
+ q__1.r = t1.r * c__[i__3].r - t1.i * c__[i__3].i, q__1.i = t1.r *
+ c__[i__3].i + t1.i * c__[i__3].r;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+/* L20: */
+ }
+ goto L410;
+L30:
+
+/* Special code for 2 x 2 Householder */
+
+ r_cnjg(&q__1, &v[1]);
+ v1.r = q__1.r, v1.i = q__1.i;
+ r_cnjg(&q__2, &v1);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t1.r = q__1.r, t1.i = q__1.i;
+ r_cnjg(&q__1, &v[2]);
+ v2.r = q__1.r, v2.i = q__1.i;
+ r_cnjg(&q__2, &v2);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t2.r = q__1.r, t2.i = q__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j * c_dim1 + 1;
+ q__2.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, q__2.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j * c_dim1 + 2;
+ q__3.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, q__3.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ sum.r = q__1.r, sum.i = q__1.i;
+ i__2 = j * c_dim1 + 1;
+ i__3 = j * c_dim1 + 1;
+ q__2.r = sum.r * t1.r - sum.i * t1.i, q__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 2;
+ i__3 = j * c_dim1 + 2;
+ q__2.r = sum.r * t2.r - sum.i * t2.i, q__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+/* L40: */
+ }
+ goto L410;
+L50:
+
+/* Special code for 3 x 3 Householder */
+
+ r_cnjg(&q__1, &v[1]);
+ v1.r = q__1.r, v1.i = q__1.i;
+ r_cnjg(&q__2, &v1);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t1.r = q__1.r, t1.i = q__1.i;
+ r_cnjg(&q__1, &v[2]);
+ v2.r = q__1.r, v2.i = q__1.i;
+ r_cnjg(&q__2, &v2);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t2.r = q__1.r, t2.i = q__1.i;
+ r_cnjg(&q__1, &v[3]);
+ v3.r = q__1.r, v3.i = q__1.i;
+ r_cnjg(&q__2, &v3);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t3.r = q__1.r, t3.i = q__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j * c_dim1 + 1;
+ q__3.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, q__3.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j * c_dim1 + 2;
+ q__4.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, q__4.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i;
+ i__4 = j * c_dim1 + 3;
+ q__5.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, q__5.i = v3.r *
+ c__[i__4].i + v3.i * c__[i__4].r;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+ sum.r = q__1.r, sum.i = q__1.i;
+ i__2 = j * c_dim1 + 1;
+ i__3 = j * c_dim1 + 1;
+ q__2.r = sum.r * t1.r - sum.i * t1.i, q__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 2;
+ i__3 = j * c_dim1 + 2;
+ q__2.r = sum.r * t2.r - sum.i * t2.i, q__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 3;
+ i__3 = j * c_dim1 + 3;
+ q__2.r = sum.r * t3.r - sum.i * t3.i, q__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+/* L60: */
+ }
+ goto L410;
+L70:
+
+/* Special code for 4 x 4 Householder */
+
+ r_cnjg(&q__1, &v[1]);
+ v1.r = q__1.r, v1.i = q__1.i;
+ r_cnjg(&q__2, &v1);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t1.r = q__1.r, t1.i = q__1.i;
+ r_cnjg(&q__1, &v[2]);
+ v2.r = q__1.r, v2.i = q__1.i;
+ r_cnjg(&q__2, &v2);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t2.r = q__1.r, t2.i = q__1.i;
+ r_cnjg(&q__1, &v[3]);
+ v3.r = q__1.r, v3.i = q__1.i;
+ r_cnjg(&q__2, &v3);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t3.r = q__1.r, t3.i = q__1.i;
+ r_cnjg(&q__1, &v[4]);
+ v4.r = q__1.r, v4.i = q__1.i;
+ r_cnjg(&q__2, &v4);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t4.r = q__1.r, t4.i = q__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j * c_dim1 + 1;
+ q__4.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, q__4.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j * c_dim1 + 2;
+ q__5.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, q__5.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ q__3.r = q__4.r + q__5.r, q__3.i = q__4.i + q__5.i;
+ i__4 = j * c_dim1 + 3;
+ q__6.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, q__6.i = v3.r *
+ c__[i__4].i + v3.i * c__[i__4].r;
+ q__2.r = q__3.r + q__6.r, q__2.i = q__3.i + q__6.i;
+ i__5 = j * c_dim1 + 4;
+ q__7.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, q__7.i = v4.r *
+ c__[i__5].i + v4.i * c__[i__5].r;
+ q__1.r = q__2.r + q__7.r, q__1.i = q__2.i + q__7.i;
+ sum.r = q__1.r, sum.i = q__1.i;
+ i__2 = j * c_dim1 + 1;
+ i__3 = j * c_dim1 + 1;
+ q__2.r = sum.r * t1.r - sum.i * t1.i, q__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 2;
+ i__3 = j * c_dim1 + 2;
+ q__2.r = sum.r * t2.r - sum.i * t2.i, q__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 3;
+ i__3 = j * c_dim1 + 3;
+ q__2.r = sum.r * t3.r - sum.i * t3.i, q__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 4;
+ i__3 = j * c_dim1 + 4;
+ q__2.r = sum.r * t4.r - sum.i * t4.i, q__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+/* L80: */
+ }
+ goto L410;
+L90:
+
+/* Special code for 5 x 5 Householder */
+
+ r_cnjg(&q__1, &v[1]);
+ v1.r = q__1.r, v1.i = q__1.i;
+ r_cnjg(&q__2, &v1);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t1.r = q__1.r, t1.i = q__1.i;
+ r_cnjg(&q__1, &v[2]);
+ v2.r = q__1.r, v2.i = q__1.i;
+ r_cnjg(&q__2, &v2);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t2.r = q__1.r, t2.i = q__1.i;
+ r_cnjg(&q__1, &v[3]);
+ v3.r = q__1.r, v3.i = q__1.i;
+ r_cnjg(&q__2, &v3);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t3.r = q__1.r, t3.i = q__1.i;
+ r_cnjg(&q__1, &v[4]);
+ v4.r = q__1.r, v4.i = q__1.i;
+ r_cnjg(&q__2, &v4);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t4.r = q__1.r, t4.i = q__1.i;
+ r_cnjg(&q__1, &v[5]);
+ v5.r = q__1.r, v5.i = q__1.i;
+ r_cnjg(&q__2, &v5);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t5.r = q__1.r, t5.i = q__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j * c_dim1 + 1;
+ q__5.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, q__5.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j * c_dim1 + 2;
+ q__6.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, q__6.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ q__4.r = q__5.r + q__6.r, q__4.i = q__5.i + q__6.i;
+ i__4 = j * c_dim1 + 3;
+ q__7.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, q__7.i = v3.r *
+ c__[i__4].i + v3.i * c__[i__4].r;
+ q__3.r = q__4.r + q__7.r, q__3.i = q__4.i + q__7.i;
+ i__5 = j * c_dim1 + 4;
+ q__8.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, q__8.i = v4.r *
+ c__[i__5].i + v4.i * c__[i__5].r;
+ q__2.r = q__3.r + q__8.r, q__2.i = q__3.i + q__8.i;
+ i__6 = j * c_dim1 + 5;
+ q__9.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, q__9.i = v5.r *
+ c__[i__6].i + v5.i * c__[i__6].r;
+ q__1.r = q__2.r + q__9.r, q__1.i = q__2.i + q__9.i;
+ sum.r = q__1.r, sum.i = q__1.i;
+ i__2 = j * c_dim1 + 1;
+ i__3 = j * c_dim1 + 1;
+ q__2.r = sum.r * t1.r - sum.i * t1.i, q__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 2;
+ i__3 = j * c_dim1 + 2;
+ q__2.r = sum.r * t2.r - sum.i * t2.i, q__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 3;
+ i__3 = j * c_dim1 + 3;
+ q__2.r = sum.r * t3.r - sum.i * t3.i, q__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 4;
+ i__3 = j * c_dim1 + 4;
+ q__2.r = sum.r * t4.r - sum.i * t4.i, q__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 5;
+ i__3 = j * c_dim1 + 5;
+ q__2.r = sum.r * t5.r - sum.i * t5.i, q__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+/* L100: */
+ }
+ goto L410;
+L110:
+
+/* Special code for 6 x 6 Householder */
+
+ r_cnjg(&q__1, &v[1]);
+ v1.r = q__1.r, v1.i = q__1.i;
+ r_cnjg(&q__2, &v1);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t1.r = q__1.r, t1.i = q__1.i;
+ r_cnjg(&q__1, &v[2]);
+ v2.r = q__1.r, v2.i = q__1.i;
+ r_cnjg(&q__2, &v2);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t2.r = q__1.r, t2.i = q__1.i;
+ r_cnjg(&q__1, &v[3]);
+ v3.r = q__1.r, v3.i = q__1.i;
+ r_cnjg(&q__2, &v3);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t3.r = q__1.r, t3.i = q__1.i;
+ r_cnjg(&q__1, &v[4]);
+ v4.r = q__1.r, v4.i = q__1.i;
+ r_cnjg(&q__2, &v4);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t4.r = q__1.r, t4.i = q__1.i;
+ r_cnjg(&q__1, &v[5]);
+ v5.r = q__1.r, v5.i = q__1.i;
+ r_cnjg(&q__2, &v5);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t5.r = q__1.r, t5.i = q__1.i;
+ r_cnjg(&q__1, &v[6]);
+ v6.r = q__1.r, v6.i = q__1.i;
+ r_cnjg(&q__2, &v6);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t6.r = q__1.r, t6.i = q__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j * c_dim1 + 1;
+ q__6.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, q__6.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j * c_dim1 + 2;
+ q__7.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, q__7.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ q__5.r = q__6.r + q__7.r, q__5.i = q__6.i + q__7.i;
+ i__4 = j * c_dim1 + 3;
+ q__8.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, q__8.i = v3.r *
+ c__[i__4].i + v3.i * c__[i__4].r;
+ q__4.r = q__5.r + q__8.r, q__4.i = q__5.i + q__8.i;
+ i__5 = j * c_dim1 + 4;
+ q__9.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, q__9.i = v4.r *
+ c__[i__5].i + v4.i * c__[i__5].r;
+ q__3.r = q__4.r + q__9.r, q__3.i = q__4.i + q__9.i;
+ i__6 = j * c_dim1 + 5;
+ q__10.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, q__10.i = v5.r
+ * c__[i__6].i + v5.i * c__[i__6].r;
+ q__2.r = q__3.r + q__10.r, q__2.i = q__3.i + q__10.i;
+ i__7 = j * c_dim1 + 6;
+ q__11.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, q__11.i = v6.r
+ * c__[i__7].i + v6.i * c__[i__7].r;
+ q__1.r = q__2.r + q__11.r, q__1.i = q__2.i + q__11.i;
+ sum.r = q__1.r, sum.i = q__1.i;
+ i__2 = j * c_dim1 + 1;
+ i__3 = j * c_dim1 + 1;
+ q__2.r = sum.r * t1.r - sum.i * t1.i, q__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 2;
+ i__3 = j * c_dim1 + 2;
+ q__2.r = sum.r * t2.r - sum.i * t2.i, q__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 3;
+ i__3 = j * c_dim1 + 3;
+ q__2.r = sum.r * t3.r - sum.i * t3.i, q__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 4;
+ i__3 = j * c_dim1 + 4;
+ q__2.r = sum.r * t4.r - sum.i * t4.i, q__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 5;
+ i__3 = j * c_dim1 + 5;
+ q__2.r = sum.r * t5.r - sum.i * t5.i, q__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 6;
+ i__3 = j * c_dim1 + 6;
+ q__2.r = sum.r * t6.r - sum.i * t6.i, q__2.i = sum.r * t6.i +
+ sum.i * t6.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+/* L120: */
+ }
+ goto L410;
+L130:
+
+/* Special code for 7 x 7 Householder */
+
+ r_cnjg(&q__1, &v[1]);
+ v1.r = q__1.r, v1.i = q__1.i;
+ r_cnjg(&q__2, &v1);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t1.r = q__1.r, t1.i = q__1.i;
+ r_cnjg(&q__1, &v[2]);
+ v2.r = q__1.r, v2.i = q__1.i;
+ r_cnjg(&q__2, &v2);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t2.r = q__1.r, t2.i = q__1.i;
+ r_cnjg(&q__1, &v[3]);
+ v3.r = q__1.r, v3.i = q__1.i;
+ r_cnjg(&q__2, &v3);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t3.r = q__1.r, t3.i = q__1.i;
+ r_cnjg(&q__1, &v[4]);
+ v4.r = q__1.r, v4.i = q__1.i;
+ r_cnjg(&q__2, &v4);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t4.r = q__1.r, t4.i = q__1.i;
+ r_cnjg(&q__1, &v[5]);
+ v5.r = q__1.r, v5.i = q__1.i;
+ r_cnjg(&q__2, &v5);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t5.r = q__1.r, t5.i = q__1.i;
+ r_cnjg(&q__1, &v[6]);
+ v6.r = q__1.r, v6.i = q__1.i;
+ r_cnjg(&q__2, &v6);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t6.r = q__1.r, t6.i = q__1.i;
+ r_cnjg(&q__1, &v[7]);
+ v7.r = q__1.r, v7.i = q__1.i;
+ r_cnjg(&q__2, &v7);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t7.r = q__1.r, t7.i = q__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j * c_dim1 + 1;
+ q__7.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, q__7.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j * c_dim1 + 2;
+ q__8.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, q__8.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ q__6.r = q__7.r + q__8.r, q__6.i = q__7.i + q__8.i;
+ i__4 = j * c_dim1 + 3;
+ q__9.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, q__9.i = v3.r *
+ c__[i__4].i + v3.i * c__[i__4].r;
+ q__5.r = q__6.r + q__9.r, q__5.i = q__6.i + q__9.i;
+ i__5 = j * c_dim1 + 4;
+ q__10.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, q__10.i = v4.r
+ * c__[i__5].i + v4.i * c__[i__5].r;
+ q__4.r = q__5.r + q__10.r, q__4.i = q__5.i + q__10.i;
+ i__6 = j * c_dim1 + 5;
+ q__11.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, q__11.i = v5.r
+ * c__[i__6].i + v5.i * c__[i__6].r;
+ q__3.r = q__4.r + q__11.r, q__3.i = q__4.i + q__11.i;
+ i__7 = j * c_dim1 + 6;
+ q__12.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, q__12.i = v6.r
+ * c__[i__7].i + v6.i * c__[i__7].r;
+ q__2.r = q__3.r + q__12.r, q__2.i = q__3.i + q__12.i;
+ i__8 = j * c_dim1 + 7;
+ q__13.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, q__13.i = v7.r
+ * c__[i__8].i + v7.i * c__[i__8].r;
+ q__1.r = q__2.r + q__13.r, q__1.i = q__2.i + q__13.i;
+ sum.r = q__1.r, sum.i = q__1.i;
+ i__2 = j * c_dim1 + 1;
+ i__3 = j * c_dim1 + 1;
+ q__2.r = sum.r * t1.r - sum.i * t1.i, q__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 2;
+ i__3 = j * c_dim1 + 2;
+ q__2.r = sum.r * t2.r - sum.i * t2.i, q__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 3;
+ i__3 = j * c_dim1 + 3;
+ q__2.r = sum.r * t3.r - sum.i * t3.i, q__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 4;
+ i__3 = j * c_dim1 + 4;
+ q__2.r = sum.r * t4.r - sum.i * t4.i, q__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 5;
+ i__3 = j * c_dim1 + 5;
+ q__2.r = sum.r * t5.r - sum.i * t5.i, q__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 6;
+ i__3 = j * c_dim1 + 6;
+ q__2.r = sum.r * t6.r - sum.i * t6.i, q__2.i = sum.r * t6.i +
+ sum.i * t6.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 7;
+ i__3 = j * c_dim1 + 7;
+ q__2.r = sum.r * t7.r - sum.i * t7.i, q__2.i = sum.r * t7.i +
+ sum.i * t7.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+/* L140: */
+ }
+ goto L410;
+L150:
+
+/* Special code for 8 x 8 Householder */
+
+ r_cnjg(&q__1, &v[1]);
+ v1.r = q__1.r, v1.i = q__1.i;
+ r_cnjg(&q__2, &v1);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t1.r = q__1.r, t1.i = q__1.i;
+ r_cnjg(&q__1, &v[2]);
+ v2.r = q__1.r, v2.i = q__1.i;
+ r_cnjg(&q__2, &v2);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t2.r = q__1.r, t2.i = q__1.i;
+ r_cnjg(&q__1, &v[3]);
+ v3.r = q__1.r, v3.i = q__1.i;
+ r_cnjg(&q__2, &v3);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t3.r = q__1.r, t3.i = q__1.i;
+ r_cnjg(&q__1, &v[4]);
+ v4.r = q__1.r, v4.i = q__1.i;
+ r_cnjg(&q__2, &v4);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t4.r = q__1.r, t4.i = q__1.i;
+ r_cnjg(&q__1, &v[5]);
+ v5.r = q__1.r, v5.i = q__1.i;
+ r_cnjg(&q__2, &v5);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t5.r = q__1.r, t5.i = q__1.i;
+ r_cnjg(&q__1, &v[6]);
+ v6.r = q__1.r, v6.i = q__1.i;
+ r_cnjg(&q__2, &v6);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t6.r = q__1.r, t6.i = q__1.i;
+ r_cnjg(&q__1, &v[7]);
+ v7.r = q__1.r, v7.i = q__1.i;
+ r_cnjg(&q__2, &v7);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t7.r = q__1.r, t7.i = q__1.i;
+ r_cnjg(&q__1, &v[8]);
+ v8.r = q__1.r, v8.i = q__1.i;
+ r_cnjg(&q__2, &v8);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t8.r = q__1.r, t8.i = q__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j * c_dim1 + 1;
+ q__8.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, q__8.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j * c_dim1 + 2;
+ q__9.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, q__9.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ q__7.r = q__8.r + q__9.r, q__7.i = q__8.i + q__9.i;
+ i__4 = j * c_dim1 + 3;
+ q__10.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, q__10.i = v3.r
+ * c__[i__4].i + v3.i * c__[i__4].r;
+ q__6.r = q__7.r + q__10.r, q__6.i = q__7.i + q__10.i;
+ i__5 = j * c_dim1 + 4;
+ q__11.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, q__11.i = v4.r
+ * c__[i__5].i + v4.i * c__[i__5].r;
+ q__5.r = q__6.r + q__11.r, q__5.i = q__6.i + q__11.i;
+ i__6 = j * c_dim1 + 5;
+ q__12.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, q__12.i = v5.r
+ * c__[i__6].i + v5.i * c__[i__6].r;
+ q__4.r = q__5.r + q__12.r, q__4.i = q__5.i + q__12.i;
+ i__7 = j * c_dim1 + 6;
+ q__13.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, q__13.i = v6.r
+ * c__[i__7].i + v6.i * c__[i__7].r;
+ q__3.r = q__4.r + q__13.r, q__3.i = q__4.i + q__13.i;
+ i__8 = j * c_dim1 + 7;
+ q__14.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, q__14.i = v7.r
+ * c__[i__8].i + v7.i * c__[i__8].r;
+ q__2.r = q__3.r + q__14.r, q__2.i = q__3.i + q__14.i;
+ i__9 = j * c_dim1 + 8;
+ q__15.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, q__15.i = v8.r
+ * c__[i__9].i + v8.i * c__[i__9].r;
+ q__1.r = q__2.r + q__15.r, q__1.i = q__2.i + q__15.i;
+ sum.r = q__1.r, sum.i = q__1.i;
+ i__2 = j * c_dim1 + 1;
+ i__3 = j * c_dim1 + 1;
+ q__2.r = sum.r * t1.r - sum.i * t1.i, q__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 2;
+ i__3 = j * c_dim1 + 2;
+ q__2.r = sum.r * t2.r - sum.i * t2.i, q__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 3;
+ i__3 = j * c_dim1 + 3;
+ q__2.r = sum.r * t3.r - sum.i * t3.i, q__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 4;
+ i__3 = j * c_dim1 + 4;
+ q__2.r = sum.r * t4.r - sum.i * t4.i, q__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 5;
+ i__3 = j * c_dim1 + 5;
+ q__2.r = sum.r * t5.r - sum.i * t5.i, q__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 6;
+ i__3 = j * c_dim1 + 6;
+ q__2.r = sum.r * t6.r - sum.i * t6.i, q__2.i = sum.r * t6.i +
+ sum.i * t6.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 7;
+ i__3 = j * c_dim1 + 7;
+ q__2.r = sum.r * t7.r - sum.i * t7.i, q__2.i = sum.r * t7.i +
+ sum.i * t7.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 8;
+ i__3 = j * c_dim1 + 8;
+ q__2.r = sum.r * t8.r - sum.i * t8.i, q__2.i = sum.r * t8.i +
+ sum.i * t8.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+/* L160: */
+ }
+ goto L410;
+L170:
+
+/* Special code for 9 x 9 Householder */
+
+ r_cnjg(&q__1, &v[1]);
+ v1.r = q__1.r, v1.i = q__1.i;
+ r_cnjg(&q__2, &v1);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t1.r = q__1.r, t1.i = q__1.i;
+ r_cnjg(&q__1, &v[2]);
+ v2.r = q__1.r, v2.i = q__1.i;
+ r_cnjg(&q__2, &v2);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t2.r = q__1.r, t2.i = q__1.i;
+ r_cnjg(&q__1, &v[3]);
+ v3.r = q__1.r, v3.i = q__1.i;
+ r_cnjg(&q__2, &v3);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t3.r = q__1.r, t3.i = q__1.i;
+ r_cnjg(&q__1, &v[4]);
+ v4.r = q__1.r, v4.i = q__1.i;
+ r_cnjg(&q__2, &v4);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t4.r = q__1.r, t4.i = q__1.i;
+ r_cnjg(&q__1, &v[5]);
+ v5.r = q__1.r, v5.i = q__1.i;
+ r_cnjg(&q__2, &v5);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t5.r = q__1.r, t5.i = q__1.i;
+ r_cnjg(&q__1, &v[6]);
+ v6.r = q__1.r, v6.i = q__1.i;
+ r_cnjg(&q__2, &v6);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t6.r = q__1.r, t6.i = q__1.i;
+ r_cnjg(&q__1, &v[7]);
+ v7.r = q__1.r, v7.i = q__1.i;
+ r_cnjg(&q__2, &v7);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t7.r = q__1.r, t7.i = q__1.i;
+ r_cnjg(&q__1, &v[8]);
+ v8.r = q__1.r, v8.i = q__1.i;
+ r_cnjg(&q__2, &v8);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t8.r = q__1.r, t8.i = q__1.i;
+ r_cnjg(&q__1, &v[9]);
+ v9.r = q__1.r, v9.i = q__1.i;
+ r_cnjg(&q__2, &v9);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t9.r = q__1.r, t9.i = q__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j * c_dim1 + 1;
+ q__9.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, q__9.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j * c_dim1 + 2;
+ q__10.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, q__10.i = v2.r
+ * c__[i__3].i + v2.i * c__[i__3].r;
+ q__8.r = q__9.r + q__10.r, q__8.i = q__9.i + q__10.i;
+ i__4 = j * c_dim1 + 3;
+ q__11.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, q__11.i = v3.r
+ * c__[i__4].i + v3.i * c__[i__4].r;
+ q__7.r = q__8.r + q__11.r, q__7.i = q__8.i + q__11.i;
+ i__5 = j * c_dim1 + 4;
+ q__12.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, q__12.i = v4.r
+ * c__[i__5].i + v4.i * c__[i__5].r;
+ q__6.r = q__7.r + q__12.r, q__6.i = q__7.i + q__12.i;
+ i__6 = j * c_dim1 + 5;
+ q__13.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, q__13.i = v5.r
+ * c__[i__6].i + v5.i * c__[i__6].r;
+ q__5.r = q__6.r + q__13.r, q__5.i = q__6.i + q__13.i;
+ i__7 = j * c_dim1 + 6;
+ q__14.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, q__14.i = v6.r
+ * c__[i__7].i + v6.i * c__[i__7].r;
+ q__4.r = q__5.r + q__14.r, q__4.i = q__5.i + q__14.i;
+ i__8 = j * c_dim1 + 7;
+ q__15.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, q__15.i = v7.r
+ * c__[i__8].i + v7.i * c__[i__8].r;
+ q__3.r = q__4.r + q__15.r, q__3.i = q__4.i + q__15.i;
+ i__9 = j * c_dim1 + 8;
+ q__16.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, q__16.i = v8.r
+ * c__[i__9].i + v8.i * c__[i__9].r;
+ q__2.r = q__3.r + q__16.r, q__2.i = q__3.i + q__16.i;
+ i__10 = j * c_dim1 + 9;
+ q__17.r = v9.r * c__[i__10].r - v9.i * c__[i__10].i, q__17.i =
+ v9.r * c__[i__10].i + v9.i * c__[i__10].r;
+ q__1.r = q__2.r + q__17.r, q__1.i = q__2.i + q__17.i;
+ sum.r = q__1.r, sum.i = q__1.i;
+ i__2 = j * c_dim1 + 1;
+ i__3 = j * c_dim1 + 1;
+ q__2.r = sum.r * t1.r - sum.i * t1.i, q__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 2;
+ i__3 = j * c_dim1 + 2;
+ q__2.r = sum.r * t2.r - sum.i * t2.i, q__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 3;
+ i__3 = j * c_dim1 + 3;
+ q__2.r = sum.r * t3.r - sum.i * t3.i, q__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 4;
+ i__3 = j * c_dim1 + 4;
+ q__2.r = sum.r * t4.r - sum.i * t4.i, q__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 5;
+ i__3 = j * c_dim1 + 5;
+ q__2.r = sum.r * t5.r - sum.i * t5.i, q__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 6;
+ i__3 = j * c_dim1 + 6;
+ q__2.r = sum.r * t6.r - sum.i * t6.i, q__2.i = sum.r * t6.i +
+ sum.i * t6.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 7;
+ i__3 = j * c_dim1 + 7;
+ q__2.r = sum.r * t7.r - sum.i * t7.i, q__2.i = sum.r * t7.i +
+ sum.i * t7.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 8;
+ i__3 = j * c_dim1 + 8;
+ q__2.r = sum.r * t8.r - sum.i * t8.i, q__2.i = sum.r * t8.i +
+ sum.i * t8.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 9;
+ i__3 = j * c_dim1 + 9;
+ q__2.r = sum.r * t9.r - sum.i * t9.i, q__2.i = sum.r * t9.i +
+ sum.i * t9.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+/* L180: */
+ }
+ goto L410;
+L190:
+
+/* Special code for 10 x 10 Householder */
+
+ r_cnjg(&q__1, &v[1]);
+ v1.r = q__1.r, v1.i = q__1.i;
+ r_cnjg(&q__2, &v1);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t1.r = q__1.r, t1.i = q__1.i;
+ r_cnjg(&q__1, &v[2]);
+ v2.r = q__1.r, v2.i = q__1.i;
+ r_cnjg(&q__2, &v2);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t2.r = q__1.r, t2.i = q__1.i;
+ r_cnjg(&q__1, &v[3]);
+ v3.r = q__1.r, v3.i = q__1.i;
+ r_cnjg(&q__2, &v3);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t3.r = q__1.r, t3.i = q__1.i;
+ r_cnjg(&q__1, &v[4]);
+ v4.r = q__1.r, v4.i = q__1.i;
+ r_cnjg(&q__2, &v4);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t4.r = q__1.r, t4.i = q__1.i;
+ r_cnjg(&q__1, &v[5]);
+ v5.r = q__1.r, v5.i = q__1.i;
+ r_cnjg(&q__2, &v5);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t5.r = q__1.r, t5.i = q__1.i;
+ r_cnjg(&q__1, &v[6]);
+ v6.r = q__1.r, v6.i = q__1.i;
+ r_cnjg(&q__2, &v6);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t6.r = q__1.r, t6.i = q__1.i;
+ r_cnjg(&q__1, &v[7]);
+ v7.r = q__1.r, v7.i = q__1.i;
+ r_cnjg(&q__2, &v7);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t7.r = q__1.r, t7.i = q__1.i;
+ r_cnjg(&q__1, &v[8]);
+ v8.r = q__1.r, v8.i = q__1.i;
+ r_cnjg(&q__2, &v8);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t8.r = q__1.r, t8.i = q__1.i;
+ r_cnjg(&q__1, &v[9]);
+ v9.r = q__1.r, v9.i = q__1.i;
+ r_cnjg(&q__2, &v9);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t9.r = q__1.r, t9.i = q__1.i;
+ r_cnjg(&q__1, &v[10]);
+ v10.r = q__1.r, v10.i = q__1.i;
+ r_cnjg(&q__2, &v10);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t10.r = q__1.r, t10.i = q__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j * c_dim1 + 1;
+ q__10.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, q__10.i = v1.r
+ * c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j * c_dim1 + 2;
+ q__11.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, q__11.i = v2.r
+ * c__[i__3].i + v2.i * c__[i__3].r;
+ q__9.r = q__10.r + q__11.r, q__9.i = q__10.i + q__11.i;
+ i__4 = j * c_dim1 + 3;
+ q__12.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, q__12.i = v3.r
+ * c__[i__4].i + v3.i * c__[i__4].r;
+ q__8.r = q__9.r + q__12.r, q__8.i = q__9.i + q__12.i;
+ i__5 = j * c_dim1 + 4;
+ q__13.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, q__13.i = v4.r
+ * c__[i__5].i + v4.i * c__[i__5].r;
+ q__7.r = q__8.r + q__13.r, q__7.i = q__8.i + q__13.i;
+ i__6 = j * c_dim1 + 5;
+ q__14.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, q__14.i = v5.r
+ * c__[i__6].i + v5.i * c__[i__6].r;
+ q__6.r = q__7.r + q__14.r, q__6.i = q__7.i + q__14.i;
+ i__7 = j * c_dim1 + 6;
+ q__15.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, q__15.i = v6.r
+ * c__[i__7].i + v6.i * c__[i__7].r;
+ q__5.r = q__6.r + q__15.r, q__5.i = q__6.i + q__15.i;
+ i__8 = j * c_dim1 + 7;
+ q__16.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, q__16.i = v7.r
+ * c__[i__8].i + v7.i * c__[i__8].r;
+ q__4.r = q__5.r + q__16.r, q__4.i = q__5.i + q__16.i;
+ i__9 = j * c_dim1 + 8;
+ q__17.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, q__17.i = v8.r
+ * c__[i__9].i + v8.i * c__[i__9].r;
+ q__3.r = q__4.r + q__17.r, q__3.i = q__4.i + q__17.i;
+ i__10 = j * c_dim1 + 9;
+ q__18.r = v9.r * c__[i__10].r - v9.i * c__[i__10].i, q__18.i =
+ v9.r * c__[i__10].i + v9.i * c__[i__10].r;
+ q__2.r = q__3.r + q__18.r, q__2.i = q__3.i + q__18.i;
+ i__11 = j * c_dim1 + 10;
+ q__19.r = v10.r * c__[i__11].r - v10.i * c__[i__11].i, q__19.i =
+ v10.r * c__[i__11].i + v10.i * c__[i__11].r;
+ q__1.r = q__2.r + q__19.r, q__1.i = q__2.i + q__19.i;
+ sum.r = q__1.r, sum.i = q__1.i;
+ i__2 = j * c_dim1 + 1;
+ i__3 = j * c_dim1 + 1;
+ q__2.r = sum.r * t1.r - sum.i * t1.i, q__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 2;
+ i__3 = j * c_dim1 + 2;
+ q__2.r = sum.r * t2.r - sum.i * t2.i, q__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 3;
+ i__3 = j * c_dim1 + 3;
+ q__2.r = sum.r * t3.r - sum.i * t3.i, q__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 4;
+ i__3 = j * c_dim1 + 4;
+ q__2.r = sum.r * t4.r - sum.i * t4.i, q__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 5;
+ i__3 = j * c_dim1 + 5;
+ q__2.r = sum.r * t5.r - sum.i * t5.i, q__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 6;
+ i__3 = j * c_dim1 + 6;
+ q__2.r = sum.r * t6.r - sum.i * t6.i, q__2.i = sum.r * t6.i +
+ sum.i * t6.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 7;
+ i__3 = j * c_dim1 + 7;
+ q__2.r = sum.r * t7.r - sum.i * t7.i, q__2.i = sum.r * t7.i +
+ sum.i * t7.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 8;
+ i__3 = j * c_dim1 + 8;
+ q__2.r = sum.r * t8.r - sum.i * t8.i, q__2.i = sum.r * t8.i +
+ sum.i * t8.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 9;
+ i__3 = j * c_dim1 + 9;
+ q__2.r = sum.r * t9.r - sum.i * t9.i, q__2.i = sum.r * t9.i +
+ sum.i * t9.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j * c_dim1 + 10;
+ i__3 = j * c_dim1 + 10;
+ q__2.r = sum.r * t10.r - sum.i * t10.i, q__2.i = sum.r * t10.i +
+ sum.i * t10.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+/* L200: */
+ }
+ goto L410;
+ } else {
+
+/* Form C * H, where H has order n. */
+
+ switch (*n) {
+ case 1: goto L210;
+ case 2: goto L230;
+ case 3: goto L250;
+ case 4: goto L270;
+ case 5: goto L290;
+ case 6: goto L310;
+ case 7: goto L330;
+ case 8: goto L350;
+ case 9: goto L370;
+ case 10: goto L390;
+ }
+
+/* Code for general N */
+
+ clarf_(side, m, n, &v[1], &c__1, tau, &c__[c_offset], ldc, &work[1]);
+ goto L410;
+L210:
+
+/* Special code for 1 x 1 Householder */
+
+ q__3.r = tau->r * v[1].r - tau->i * v[1].i, q__3.i = tau->r * v[1].i
+ + tau->i * v[1].r;
+ r_cnjg(&q__4, &v[1]);
+ q__2.r = q__3.r * q__4.r - q__3.i * q__4.i, q__2.i = q__3.r * q__4.i
+ + q__3.i * q__4.r;
+ q__1.r = 1.f - q__2.r, q__1.i = 0.f - q__2.i;
+ t1.r = q__1.r, t1.i = q__1.i;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + c_dim1;
+ i__3 = j + c_dim1;
+ q__1.r = t1.r * c__[i__3].r - t1.i * c__[i__3].i, q__1.i = t1.r *
+ c__[i__3].i + t1.i * c__[i__3].r;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+/* L220: */
+ }
+ goto L410;
+L230:
+
+/* Special code for 2 x 2 Householder */
+
+ v1.r = v[1].r, v1.i = v[1].i;
+ r_cnjg(&q__2, &v1);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t1.r = q__1.r, t1.i = q__1.i;
+ v2.r = v[2].r, v2.i = v[2].i;
+ r_cnjg(&q__2, &v2);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t2.r = q__1.r, t2.i = q__1.i;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + c_dim1;
+ q__2.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, q__2.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j + (c_dim1 << 1);
+ q__3.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, q__3.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ sum.r = q__1.r, sum.i = q__1.i;
+ i__2 = j + c_dim1;
+ i__3 = j + c_dim1;
+ q__2.r = sum.r * t1.r - sum.i * t1.i, q__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + (c_dim1 << 1);
+ i__3 = j + (c_dim1 << 1);
+ q__2.r = sum.r * t2.r - sum.i * t2.i, q__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+/* L240: */
+ }
+ goto L410;
+L250:
+
+/* Special code for 3 x 3 Householder */
+
+ v1.r = v[1].r, v1.i = v[1].i;
+ r_cnjg(&q__2, &v1);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t1.r = q__1.r, t1.i = q__1.i;
+ v2.r = v[2].r, v2.i = v[2].i;
+ r_cnjg(&q__2, &v2);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t2.r = q__1.r, t2.i = q__1.i;
+ v3.r = v[3].r, v3.i = v[3].i;
+ r_cnjg(&q__2, &v3);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t3.r = q__1.r, t3.i = q__1.i;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + c_dim1;
+ q__3.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, q__3.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j + (c_dim1 << 1);
+ q__4.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, q__4.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i;
+ i__4 = j + c_dim1 * 3;
+ q__5.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, q__5.i = v3.r *
+ c__[i__4].i + v3.i * c__[i__4].r;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+ sum.r = q__1.r, sum.i = q__1.i;
+ i__2 = j + c_dim1;
+ i__3 = j + c_dim1;
+ q__2.r = sum.r * t1.r - sum.i * t1.i, q__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + (c_dim1 << 1);
+ i__3 = j + (c_dim1 << 1);
+ q__2.r = sum.r * t2.r - sum.i * t2.i, q__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 3;
+ i__3 = j + c_dim1 * 3;
+ q__2.r = sum.r * t3.r - sum.i * t3.i, q__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+/* L260: */
+ }
+ goto L410;
+L270:
+
+/* Special code for 4 x 4 Householder */
+
+ v1.r = v[1].r, v1.i = v[1].i;
+ r_cnjg(&q__2, &v1);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t1.r = q__1.r, t1.i = q__1.i;
+ v2.r = v[2].r, v2.i = v[2].i;
+ r_cnjg(&q__2, &v2);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t2.r = q__1.r, t2.i = q__1.i;
+ v3.r = v[3].r, v3.i = v[3].i;
+ r_cnjg(&q__2, &v3);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t3.r = q__1.r, t3.i = q__1.i;
+ v4.r = v[4].r, v4.i = v[4].i;
+ r_cnjg(&q__2, &v4);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t4.r = q__1.r, t4.i = q__1.i;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + c_dim1;
+ q__4.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, q__4.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j + (c_dim1 << 1);
+ q__5.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, q__5.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ q__3.r = q__4.r + q__5.r, q__3.i = q__4.i + q__5.i;
+ i__4 = j + c_dim1 * 3;
+ q__6.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, q__6.i = v3.r *
+ c__[i__4].i + v3.i * c__[i__4].r;
+ q__2.r = q__3.r + q__6.r, q__2.i = q__3.i + q__6.i;
+ i__5 = j + (c_dim1 << 2);
+ q__7.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, q__7.i = v4.r *
+ c__[i__5].i + v4.i * c__[i__5].r;
+ q__1.r = q__2.r + q__7.r, q__1.i = q__2.i + q__7.i;
+ sum.r = q__1.r, sum.i = q__1.i;
+ i__2 = j + c_dim1;
+ i__3 = j + c_dim1;
+ q__2.r = sum.r * t1.r - sum.i * t1.i, q__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + (c_dim1 << 1);
+ i__3 = j + (c_dim1 << 1);
+ q__2.r = sum.r * t2.r - sum.i * t2.i, q__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 3;
+ i__3 = j + c_dim1 * 3;
+ q__2.r = sum.r * t3.r - sum.i * t3.i, q__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + (c_dim1 << 2);
+ i__3 = j + (c_dim1 << 2);
+ q__2.r = sum.r * t4.r - sum.i * t4.i, q__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+/* L280: */
+ }
+ goto L410;
+L290:
+
+/* Special code for 5 x 5 Householder */
+
+ v1.r = v[1].r, v1.i = v[1].i;
+ r_cnjg(&q__2, &v1);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t1.r = q__1.r, t1.i = q__1.i;
+ v2.r = v[2].r, v2.i = v[2].i;
+ r_cnjg(&q__2, &v2);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t2.r = q__1.r, t2.i = q__1.i;
+ v3.r = v[3].r, v3.i = v[3].i;
+ r_cnjg(&q__2, &v3);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t3.r = q__1.r, t3.i = q__1.i;
+ v4.r = v[4].r, v4.i = v[4].i;
+ r_cnjg(&q__2, &v4);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t4.r = q__1.r, t4.i = q__1.i;
+ v5.r = v[5].r, v5.i = v[5].i;
+ r_cnjg(&q__2, &v5);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t5.r = q__1.r, t5.i = q__1.i;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + c_dim1;
+ q__5.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, q__5.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j + (c_dim1 << 1);
+ q__6.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, q__6.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ q__4.r = q__5.r + q__6.r, q__4.i = q__5.i + q__6.i;
+ i__4 = j + c_dim1 * 3;
+ q__7.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, q__7.i = v3.r *
+ c__[i__4].i + v3.i * c__[i__4].r;
+ q__3.r = q__4.r + q__7.r, q__3.i = q__4.i + q__7.i;
+ i__5 = j + (c_dim1 << 2);
+ q__8.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, q__8.i = v4.r *
+ c__[i__5].i + v4.i * c__[i__5].r;
+ q__2.r = q__3.r + q__8.r, q__2.i = q__3.i + q__8.i;
+ i__6 = j + c_dim1 * 5;
+ q__9.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, q__9.i = v5.r *
+ c__[i__6].i + v5.i * c__[i__6].r;
+ q__1.r = q__2.r + q__9.r, q__1.i = q__2.i + q__9.i;
+ sum.r = q__1.r, sum.i = q__1.i;
+ i__2 = j + c_dim1;
+ i__3 = j + c_dim1;
+ q__2.r = sum.r * t1.r - sum.i * t1.i, q__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + (c_dim1 << 1);
+ i__3 = j + (c_dim1 << 1);
+ q__2.r = sum.r * t2.r - sum.i * t2.i, q__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 3;
+ i__3 = j + c_dim1 * 3;
+ q__2.r = sum.r * t3.r - sum.i * t3.i, q__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + (c_dim1 << 2);
+ i__3 = j + (c_dim1 << 2);
+ q__2.r = sum.r * t4.r - sum.i * t4.i, q__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 5;
+ i__3 = j + c_dim1 * 5;
+ q__2.r = sum.r * t5.r - sum.i * t5.i, q__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+/* L300: */
+ }
+ goto L410;
+L310:
+
+/* Special code for 6 x 6 Householder */
+
+ v1.r = v[1].r, v1.i = v[1].i;
+ r_cnjg(&q__2, &v1);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t1.r = q__1.r, t1.i = q__1.i;
+ v2.r = v[2].r, v2.i = v[2].i;
+ r_cnjg(&q__2, &v2);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t2.r = q__1.r, t2.i = q__1.i;
+ v3.r = v[3].r, v3.i = v[3].i;
+ r_cnjg(&q__2, &v3);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t3.r = q__1.r, t3.i = q__1.i;
+ v4.r = v[4].r, v4.i = v[4].i;
+ r_cnjg(&q__2, &v4);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t4.r = q__1.r, t4.i = q__1.i;
+ v5.r = v[5].r, v5.i = v[5].i;
+ r_cnjg(&q__2, &v5);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t5.r = q__1.r, t5.i = q__1.i;
+ v6.r = v[6].r, v6.i = v[6].i;
+ r_cnjg(&q__2, &v6);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t6.r = q__1.r, t6.i = q__1.i;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + c_dim1;
+ q__6.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, q__6.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j + (c_dim1 << 1);
+ q__7.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, q__7.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ q__5.r = q__6.r + q__7.r, q__5.i = q__6.i + q__7.i;
+ i__4 = j + c_dim1 * 3;
+ q__8.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, q__8.i = v3.r *
+ c__[i__4].i + v3.i * c__[i__4].r;
+ q__4.r = q__5.r + q__8.r, q__4.i = q__5.i + q__8.i;
+ i__5 = j + (c_dim1 << 2);
+ q__9.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, q__9.i = v4.r *
+ c__[i__5].i + v4.i * c__[i__5].r;
+ q__3.r = q__4.r + q__9.r, q__3.i = q__4.i + q__9.i;
+ i__6 = j + c_dim1 * 5;
+ q__10.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, q__10.i = v5.r
+ * c__[i__6].i + v5.i * c__[i__6].r;
+ q__2.r = q__3.r + q__10.r, q__2.i = q__3.i + q__10.i;
+ i__7 = j + c_dim1 * 6;
+ q__11.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, q__11.i = v6.r
+ * c__[i__7].i + v6.i * c__[i__7].r;
+ q__1.r = q__2.r + q__11.r, q__1.i = q__2.i + q__11.i;
+ sum.r = q__1.r, sum.i = q__1.i;
+ i__2 = j + c_dim1;
+ i__3 = j + c_dim1;
+ q__2.r = sum.r * t1.r - sum.i * t1.i, q__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + (c_dim1 << 1);
+ i__3 = j + (c_dim1 << 1);
+ q__2.r = sum.r * t2.r - sum.i * t2.i, q__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 3;
+ i__3 = j + c_dim1 * 3;
+ q__2.r = sum.r * t3.r - sum.i * t3.i, q__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + (c_dim1 << 2);
+ i__3 = j + (c_dim1 << 2);
+ q__2.r = sum.r * t4.r - sum.i * t4.i, q__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 5;
+ i__3 = j + c_dim1 * 5;
+ q__2.r = sum.r * t5.r - sum.i * t5.i, q__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 6;
+ i__3 = j + c_dim1 * 6;
+ q__2.r = sum.r * t6.r - sum.i * t6.i, q__2.i = sum.r * t6.i +
+ sum.i * t6.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+/* L320: */
+ }
+ goto L410;
+L330:
+
+/* Special code for 7 x 7 Householder */
+
+ v1.r = v[1].r, v1.i = v[1].i;
+ r_cnjg(&q__2, &v1);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t1.r = q__1.r, t1.i = q__1.i;
+ v2.r = v[2].r, v2.i = v[2].i;
+ r_cnjg(&q__2, &v2);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t2.r = q__1.r, t2.i = q__1.i;
+ v3.r = v[3].r, v3.i = v[3].i;
+ r_cnjg(&q__2, &v3);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t3.r = q__1.r, t3.i = q__1.i;
+ v4.r = v[4].r, v4.i = v[4].i;
+ r_cnjg(&q__2, &v4);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t4.r = q__1.r, t4.i = q__1.i;
+ v5.r = v[5].r, v5.i = v[5].i;
+ r_cnjg(&q__2, &v5);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t5.r = q__1.r, t5.i = q__1.i;
+ v6.r = v[6].r, v6.i = v[6].i;
+ r_cnjg(&q__2, &v6);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t6.r = q__1.r, t6.i = q__1.i;
+ v7.r = v[7].r, v7.i = v[7].i;
+ r_cnjg(&q__2, &v7);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t7.r = q__1.r, t7.i = q__1.i;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + c_dim1;
+ q__7.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, q__7.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j + (c_dim1 << 1);
+ q__8.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, q__8.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ q__6.r = q__7.r + q__8.r, q__6.i = q__7.i + q__8.i;
+ i__4 = j + c_dim1 * 3;
+ q__9.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, q__9.i = v3.r *
+ c__[i__4].i + v3.i * c__[i__4].r;
+ q__5.r = q__6.r + q__9.r, q__5.i = q__6.i + q__9.i;
+ i__5 = j + (c_dim1 << 2);
+ q__10.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, q__10.i = v4.r
+ * c__[i__5].i + v4.i * c__[i__5].r;
+ q__4.r = q__5.r + q__10.r, q__4.i = q__5.i + q__10.i;
+ i__6 = j + c_dim1 * 5;
+ q__11.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, q__11.i = v5.r
+ * c__[i__6].i + v5.i * c__[i__6].r;
+ q__3.r = q__4.r + q__11.r, q__3.i = q__4.i + q__11.i;
+ i__7 = j + c_dim1 * 6;
+ q__12.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, q__12.i = v6.r
+ * c__[i__7].i + v6.i * c__[i__7].r;
+ q__2.r = q__3.r + q__12.r, q__2.i = q__3.i + q__12.i;
+ i__8 = j + c_dim1 * 7;
+ q__13.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, q__13.i = v7.r
+ * c__[i__8].i + v7.i * c__[i__8].r;
+ q__1.r = q__2.r + q__13.r, q__1.i = q__2.i + q__13.i;
+ sum.r = q__1.r, sum.i = q__1.i;
+ i__2 = j + c_dim1;
+ i__3 = j + c_dim1;
+ q__2.r = sum.r * t1.r - sum.i * t1.i, q__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + (c_dim1 << 1);
+ i__3 = j + (c_dim1 << 1);
+ q__2.r = sum.r * t2.r - sum.i * t2.i, q__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 3;
+ i__3 = j + c_dim1 * 3;
+ q__2.r = sum.r * t3.r - sum.i * t3.i, q__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + (c_dim1 << 2);
+ i__3 = j + (c_dim1 << 2);
+ q__2.r = sum.r * t4.r - sum.i * t4.i, q__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 5;
+ i__3 = j + c_dim1 * 5;
+ q__2.r = sum.r * t5.r - sum.i * t5.i, q__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 6;
+ i__3 = j + c_dim1 * 6;
+ q__2.r = sum.r * t6.r - sum.i * t6.i, q__2.i = sum.r * t6.i +
+ sum.i * t6.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 7;
+ i__3 = j + c_dim1 * 7;
+ q__2.r = sum.r * t7.r - sum.i * t7.i, q__2.i = sum.r * t7.i +
+ sum.i * t7.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+/* L340: */
+ }
+ goto L410;
+L350:
+
+/* Special code for 8 x 8 Householder */
+
+ v1.r = v[1].r, v1.i = v[1].i;
+ r_cnjg(&q__2, &v1);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t1.r = q__1.r, t1.i = q__1.i;
+ v2.r = v[2].r, v2.i = v[2].i;
+ r_cnjg(&q__2, &v2);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t2.r = q__1.r, t2.i = q__1.i;
+ v3.r = v[3].r, v3.i = v[3].i;
+ r_cnjg(&q__2, &v3);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t3.r = q__1.r, t3.i = q__1.i;
+ v4.r = v[4].r, v4.i = v[4].i;
+ r_cnjg(&q__2, &v4);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t4.r = q__1.r, t4.i = q__1.i;
+ v5.r = v[5].r, v5.i = v[5].i;
+ r_cnjg(&q__2, &v5);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t5.r = q__1.r, t5.i = q__1.i;
+ v6.r = v[6].r, v6.i = v[6].i;
+ r_cnjg(&q__2, &v6);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t6.r = q__1.r, t6.i = q__1.i;
+ v7.r = v[7].r, v7.i = v[7].i;
+ r_cnjg(&q__2, &v7);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t7.r = q__1.r, t7.i = q__1.i;
+ v8.r = v[8].r, v8.i = v[8].i;
+ r_cnjg(&q__2, &v8);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t8.r = q__1.r, t8.i = q__1.i;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + c_dim1;
+ q__8.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, q__8.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j + (c_dim1 << 1);
+ q__9.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, q__9.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ q__7.r = q__8.r + q__9.r, q__7.i = q__8.i + q__9.i;
+ i__4 = j + c_dim1 * 3;
+ q__10.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, q__10.i = v3.r
+ * c__[i__4].i + v3.i * c__[i__4].r;
+ q__6.r = q__7.r + q__10.r, q__6.i = q__7.i + q__10.i;
+ i__5 = j + (c_dim1 << 2);
+ q__11.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, q__11.i = v4.r
+ * c__[i__5].i + v4.i * c__[i__5].r;
+ q__5.r = q__6.r + q__11.r, q__5.i = q__6.i + q__11.i;
+ i__6 = j + c_dim1 * 5;
+ q__12.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, q__12.i = v5.r
+ * c__[i__6].i + v5.i * c__[i__6].r;
+ q__4.r = q__5.r + q__12.r, q__4.i = q__5.i + q__12.i;
+ i__7 = j + c_dim1 * 6;
+ q__13.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, q__13.i = v6.r
+ * c__[i__7].i + v6.i * c__[i__7].r;
+ q__3.r = q__4.r + q__13.r, q__3.i = q__4.i + q__13.i;
+ i__8 = j + c_dim1 * 7;
+ q__14.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, q__14.i = v7.r
+ * c__[i__8].i + v7.i * c__[i__8].r;
+ q__2.r = q__3.r + q__14.r, q__2.i = q__3.i + q__14.i;
+ i__9 = j + (c_dim1 << 3);
+ q__15.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, q__15.i = v8.r
+ * c__[i__9].i + v8.i * c__[i__9].r;
+ q__1.r = q__2.r + q__15.r, q__1.i = q__2.i + q__15.i;
+ sum.r = q__1.r, sum.i = q__1.i;
+ i__2 = j + c_dim1;
+ i__3 = j + c_dim1;
+ q__2.r = sum.r * t1.r - sum.i * t1.i, q__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + (c_dim1 << 1);
+ i__3 = j + (c_dim1 << 1);
+ q__2.r = sum.r * t2.r - sum.i * t2.i, q__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 3;
+ i__3 = j + c_dim1 * 3;
+ q__2.r = sum.r * t3.r - sum.i * t3.i, q__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + (c_dim1 << 2);
+ i__3 = j + (c_dim1 << 2);
+ q__2.r = sum.r * t4.r - sum.i * t4.i, q__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 5;
+ i__3 = j + c_dim1 * 5;
+ q__2.r = sum.r * t5.r - sum.i * t5.i, q__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 6;
+ i__3 = j + c_dim1 * 6;
+ q__2.r = sum.r * t6.r - sum.i * t6.i, q__2.i = sum.r * t6.i +
+ sum.i * t6.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 7;
+ i__3 = j + c_dim1 * 7;
+ q__2.r = sum.r * t7.r - sum.i * t7.i, q__2.i = sum.r * t7.i +
+ sum.i * t7.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + (c_dim1 << 3);
+ i__3 = j + (c_dim1 << 3);
+ q__2.r = sum.r * t8.r - sum.i * t8.i, q__2.i = sum.r * t8.i +
+ sum.i * t8.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+/* L360: */
+ }
+ goto L410;
+L370:
+
+/* Special code for 9 x 9 Householder */
+
+ v1.r = v[1].r, v1.i = v[1].i;
+ r_cnjg(&q__2, &v1);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t1.r = q__1.r, t1.i = q__1.i;
+ v2.r = v[2].r, v2.i = v[2].i;
+ r_cnjg(&q__2, &v2);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t2.r = q__1.r, t2.i = q__1.i;
+ v3.r = v[3].r, v3.i = v[3].i;
+ r_cnjg(&q__2, &v3);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t3.r = q__1.r, t3.i = q__1.i;
+ v4.r = v[4].r, v4.i = v[4].i;
+ r_cnjg(&q__2, &v4);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t4.r = q__1.r, t4.i = q__1.i;
+ v5.r = v[5].r, v5.i = v[5].i;
+ r_cnjg(&q__2, &v5);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t5.r = q__1.r, t5.i = q__1.i;
+ v6.r = v[6].r, v6.i = v[6].i;
+ r_cnjg(&q__2, &v6);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t6.r = q__1.r, t6.i = q__1.i;
+ v7.r = v[7].r, v7.i = v[7].i;
+ r_cnjg(&q__2, &v7);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t7.r = q__1.r, t7.i = q__1.i;
+ v8.r = v[8].r, v8.i = v[8].i;
+ r_cnjg(&q__2, &v8);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t8.r = q__1.r, t8.i = q__1.i;
+ v9.r = v[9].r, v9.i = v[9].i;
+ r_cnjg(&q__2, &v9);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t9.r = q__1.r, t9.i = q__1.i;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + c_dim1;
+ q__9.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, q__9.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j + (c_dim1 << 1);
+ q__10.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, q__10.i = v2.r
+ * c__[i__3].i + v2.i * c__[i__3].r;
+ q__8.r = q__9.r + q__10.r, q__8.i = q__9.i + q__10.i;
+ i__4 = j + c_dim1 * 3;
+ q__11.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, q__11.i = v3.r
+ * c__[i__4].i + v3.i * c__[i__4].r;
+ q__7.r = q__8.r + q__11.r, q__7.i = q__8.i + q__11.i;
+ i__5 = j + (c_dim1 << 2);
+ q__12.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, q__12.i = v4.r
+ * c__[i__5].i + v4.i * c__[i__5].r;
+ q__6.r = q__7.r + q__12.r, q__6.i = q__7.i + q__12.i;
+ i__6 = j + c_dim1 * 5;
+ q__13.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, q__13.i = v5.r
+ * c__[i__6].i + v5.i * c__[i__6].r;
+ q__5.r = q__6.r + q__13.r, q__5.i = q__6.i + q__13.i;
+ i__7 = j + c_dim1 * 6;
+ q__14.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, q__14.i = v6.r
+ * c__[i__7].i + v6.i * c__[i__7].r;
+ q__4.r = q__5.r + q__14.r, q__4.i = q__5.i + q__14.i;
+ i__8 = j + c_dim1 * 7;
+ q__15.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, q__15.i = v7.r
+ * c__[i__8].i + v7.i * c__[i__8].r;
+ q__3.r = q__4.r + q__15.r, q__3.i = q__4.i + q__15.i;
+ i__9 = j + (c_dim1 << 3);
+ q__16.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, q__16.i = v8.r
+ * c__[i__9].i + v8.i * c__[i__9].r;
+ q__2.r = q__3.r + q__16.r, q__2.i = q__3.i + q__16.i;
+ i__10 = j + c_dim1 * 9;
+ q__17.r = v9.r * c__[i__10].r - v9.i * c__[i__10].i, q__17.i =
+ v9.r * c__[i__10].i + v9.i * c__[i__10].r;
+ q__1.r = q__2.r + q__17.r, q__1.i = q__2.i + q__17.i;
+ sum.r = q__1.r, sum.i = q__1.i;
+ i__2 = j + c_dim1;
+ i__3 = j + c_dim1;
+ q__2.r = sum.r * t1.r - sum.i * t1.i, q__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + (c_dim1 << 1);
+ i__3 = j + (c_dim1 << 1);
+ q__2.r = sum.r * t2.r - sum.i * t2.i, q__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 3;
+ i__3 = j + c_dim1 * 3;
+ q__2.r = sum.r * t3.r - sum.i * t3.i, q__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + (c_dim1 << 2);
+ i__3 = j + (c_dim1 << 2);
+ q__2.r = sum.r * t4.r - sum.i * t4.i, q__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 5;
+ i__3 = j + c_dim1 * 5;
+ q__2.r = sum.r * t5.r - sum.i * t5.i, q__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 6;
+ i__3 = j + c_dim1 * 6;
+ q__2.r = sum.r * t6.r - sum.i * t6.i, q__2.i = sum.r * t6.i +
+ sum.i * t6.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 7;
+ i__3 = j + c_dim1 * 7;
+ q__2.r = sum.r * t7.r - sum.i * t7.i, q__2.i = sum.r * t7.i +
+ sum.i * t7.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + (c_dim1 << 3);
+ i__3 = j + (c_dim1 << 3);
+ q__2.r = sum.r * t8.r - sum.i * t8.i, q__2.i = sum.r * t8.i +
+ sum.i * t8.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 9;
+ i__3 = j + c_dim1 * 9;
+ q__2.r = sum.r * t9.r - sum.i * t9.i, q__2.i = sum.r * t9.i +
+ sum.i * t9.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+/* L380: */
+ }
+ goto L410;
+L390:
+
+/* Special code for 10 x 10 Householder */
+
+ v1.r = v[1].r, v1.i = v[1].i;
+ r_cnjg(&q__2, &v1);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t1.r = q__1.r, t1.i = q__1.i;
+ v2.r = v[2].r, v2.i = v[2].i;
+ r_cnjg(&q__2, &v2);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t2.r = q__1.r, t2.i = q__1.i;
+ v3.r = v[3].r, v3.i = v[3].i;
+ r_cnjg(&q__2, &v3);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t3.r = q__1.r, t3.i = q__1.i;
+ v4.r = v[4].r, v4.i = v[4].i;
+ r_cnjg(&q__2, &v4);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t4.r = q__1.r, t4.i = q__1.i;
+ v5.r = v[5].r, v5.i = v[5].i;
+ r_cnjg(&q__2, &v5);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t5.r = q__1.r, t5.i = q__1.i;
+ v6.r = v[6].r, v6.i = v[6].i;
+ r_cnjg(&q__2, &v6);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t6.r = q__1.r, t6.i = q__1.i;
+ v7.r = v[7].r, v7.i = v[7].i;
+ r_cnjg(&q__2, &v7);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t7.r = q__1.r, t7.i = q__1.i;
+ v8.r = v[8].r, v8.i = v[8].i;
+ r_cnjg(&q__2, &v8);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t8.r = q__1.r, t8.i = q__1.i;
+ v9.r = v[9].r, v9.i = v[9].i;
+ r_cnjg(&q__2, &v9);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t9.r = q__1.r, t9.i = q__1.i;
+ v10.r = v[10].r, v10.i = v[10].i;
+ r_cnjg(&q__2, &v10);
+ q__1.r = tau->r * q__2.r - tau->i * q__2.i, q__1.i = tau->r * q__2.i
+ + tau->i * q__2.r;
+ t10.r = q__1.r, t10.i = q__1.i;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + c_dim1;
+ q__10.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, q__10.i = v1.r
+ * c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j + (c_dim1 << 1);
+ q__11.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, q__11.i = v2.r
+ * c__[i__3].i + v2.i * c__[i__3].r;
+ q__9.r = q__10.r + q__11.r, q__9.i = q__10.i + q__11.i;
+ i__4 = j + c_dim1 * 3;
+ q__12.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, q__12.i = v3.r
+ * c__[i__4].i + v3.i * c__[i__4].r;
+ q__8.r = q__9.r + q__12.r, q__8.i = q__9.i + q__12.i;
+ i__5 = j + (c_dim1 << 2);
+ q__13.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, q__13.i = v4.r
+ * c__[i__5].i + v4.i * c__[i__5].r;
+ q__7.r = q__8.r + q__13.r, q__7.i = q__8.i + q__13.i;
+ i__6 = j + c_dim1 * 5;
+ q__14.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, q__14.i = v5.r
+ * c__[i__6].i + v5.i * c__[i__6].r;
+ q__6.r = q__7.r + q__14.r, q__6.i = q__7.i + q__14.i;
+ i__7 = j + c_dim1 * 6;
+ q__15.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, q__15.i = v6.r
+ * c__[i__7].i + v6.i * c__[i__7].r;
+ q__5.r = q__6.r + q__15.r, q__5.i = q__6.i + q__15.i;
+ i__8 = j + c_dim1 * 7;
+ q__16.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, q__16.i = v7.r
+ * c__[i__8].i + v7.i * c__[i__8].r;
+ q__4.r = q__5.r + q__16.r, q__4.i = q__5.i + q__16.i;
+ i__9 = j + (c_dim1 << 3);
+ q__17.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, q__17.i = v8.r
+ * c__[i__9].i + v8.i * c__[i__9].r;
+ q__3.r = q__4.r + q__17.r, q__3.i = q__4.i + q__17.i;
+ i__10 = j + c_dim1 * 9;
+ q__18.r = v9.r * c__[i__10].r - v9.i * c__[i__10].i, q__18.i =
+ v9.r * c__[i__10].i + v9.i * c__[i__10].r;
+ q__2.r = q__3.r + q__18.r, q__2.i = q__3.i + q__18.i;
+ i__11 = j + c_dim1 * 10;
+ q__19.r = v10.r * c__[i__11].r - v10.i * c__[i__11].i, q__19.i =
+ v10.r * c__[i__11].i + v10.i * c__[i__11].r;
+ q__1.r = q__2.r + q__19.r, q__1.i = q__2.i + q__19.i;
+ sum.r = q__1.r, sum.i = q__1.i;
+ i__2 = j + c_dim1;
+ i__3 = j + c_dim1;
+ q__2.r = sum.r * t1.r - sum.i * t1.i, q__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + (c_dim1 << 1);
+ i__3 = j + (c_dim1 << 1);
+ q__2.r = sum.r * t2.r - sum.i * t2.i, q__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 3;
+ i__3 = j + c_dim1 * 3;
+ q__2.r = sum.r * t3.r - sum.i * t3.i, q__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + (c_dim1 << 2);
+ i__3 = j + (c_dim1 << 2);
+ q__2.r = sum.r * t4.r - sum.i * t4.i, q__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 5;
+ i__3 = j + c_dim1 * 5;
+ q__2.r = sum.r * t5.r - sum.i * t5.i, q__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 6;
+ i__3 = j + c_dim1 * 6;
+ q__2.r = sum.r * t6.r - sum.i * t6.i, q__2.i = sum.r * t6.i +
+ sum.i * t6.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 7;
+ i__3 = j + c_dim1 * 7;
+ q__2.r = sum.r * t7.r - sum.i * t7.i, q__2.i = sum.r * t7.i +
+ sum.i * t7.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + (c_dim1 << 3);
+ i__3 = j + (c_dim1 << 3);
+ q__2.r = sum.r * t8.r - sum.i * t8.i, q__2.i = sum.r * t8.i +
+ sum.i * t8.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 9;
+ i__3 = j + c_dim1 * 9;
+ q__2.r = sum.r * t9.r - sum.i * t9.i, q__2.i = sum.r * t9.i +
+ sum.i * t9.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = j + c_dim1 * 10;
+ i__3 = j + c_dim1 * 10;
+ q__2.r = sum.r * t10.r - sum.i * t10.i, q__2.i = sum.r * t10.i +
+ sum.i * t10.r;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+/* L400: */
+ }
+ goto L410;
+ }
+L410:
+ return 0;
+
+/* End of CLARFX */
+
+} /* clarfx_ */
diff --git a/SRC/clargv.c b/SRC/clargv.c
new file mode 100644
index 0000000..166806e
--- /dev/null
+++ b/SRC/clargv.c
@@ -0,0 +1,335 @@
+/* clargv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int clargv_(integer *n, complex *x, integer *incx, complex *
+ y, integer *incy, real *c__, integer *incc)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ double log(doublereal), pow_ri(real *, integer *), r_imag(complex *),
+ sqrt(doublereal);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ real d__;
+ complex f, g;
+ integer i__, j;
+ complex r__;
+ real f2, g2;
+ integer ic;
+ real di;
+ complex ff;
+ real cs, dr;
+ complex fs, gs;
+ integer ix, iy;
+ complex sn;
+ real f2s, g2s, eps, scale;
+ integer count;
+ real safmn2, safmx2;
+ extern doublereal slapy2_(real *, real *), slamch_(char *);
+ real safmin;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLARGV generates a vector of complex plane rotations with real */
+/* cosines, determined by elements of the complex vectors x and y. */
+/* For i = 1,2,...,n */
+
+/* ( c(i) s(i) ) ( x(i) ) = ( r(i) ) */
+/* ( -conjg(s(i)) c(i) ) ( y(i) ) = ( 0 ) */
+
+/* where c(i)**2 + ABS(s(i))**2 = 1 */
+
+/* The following conventions are used (these are the same as in CLARTG, */
+/* but differ from the BLAS1 routine CROTG): */
+/* If y(i)=0, then c(i)=1 and s(i)=0. */
+/* If x(i)=0, then c(i)=0 and s(i) is chosen so that r(i) is real. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of plane rotations to be generated. */
+
+/* X (input/output) COMPLEX array, dimension (1+(N-1)*INCX) */
+/* On entry, the vector x. */
+/* On exit, x(i) is overwritten by r(i), for i = 1,...,n. */
+
+/* INCX (input) INTEGER */
+/* The increment between elements of X. INCX > 0. */
+
+/* Y (input/output) COMPLEX array, dimension (1+(N-1)*INCY) */
+/* On entry, the vector y. */
+/* On exit, the sines of the plane rotations. */
+
+/* INCY (input) INTEGER */
+/* The increment between elements of Y. INCY > 0. */
+
+/* C (output) REAL array, dimension (1+(N-1)*INCC) */
+/* The cosines of the plane rotations. */
+
+/* INCC (input) INTEGER */
+/* The increment between elements of C. INCC > 0. */
+
+/* Further Details */
+/* ======= ======= */
+
+/* 6-6-96 - Modified with a new algorithm by W. Kahan and J. Demmel */
+
+/* This version has a few statements commented out for thread safety */
+/* (machine parameters are computed on each entry). 10 feb 03, SJH. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* LOGICAL FIRST */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Save statement .. */
+/* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 */
+/* .. */
+/* .. Data statements .. */
+/* DATA FIRST / .TRUE. / */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* IF( FIRST ) THEN */
+/* FIRST = .FALSE. */
+ /* Parameter adjustments */
+ --c__;
+ --y;
+ --x;
+
+ /* Function Body */
+ safmin = slamch_("S");
+ eps = slamch_("E");
+ r__1 = slamch_("B");
+ i__1 = (integer) (log(safmin / eps) / log(slamch_("B")) / 2.f);
+ safmn2 = pow_ri(&r__1, &i__1);
+ safmx2 = 1.f / safmn2;
+/* END IF */
+ ix = 1;
+ iy = 1;
+ ic = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ix;
+ f.r = x[i__2].r, f.i = x[i__2].i;
+ i__2 = iy;
+ g.r = y[i__2].r, g.i = y[i__2].i;
+
+/* Use identical algorithm as in CLARTG */
+
+/* Computing MAX */
+/* Computing MAX */
+ r__7 = (r__1 = f.r, dabs(r__1)), r__8 = (r__2 = r_imag(&f), dabs(r__2)
+ );
+/* Computing MAX */
+ r__9 = (r__3 = g.r, dabs(r__3)), r__10 = (r__4 = r_imag(&g), dabs(
+ r__4));
+ r__5 = dmax(r__7,r__8), r__6 = dmax(r__9,r__10);
+ scale = dmax(r__5,r__6);
+ fs.r = f.r, fs.i = f.i;
+ gs.r = g.r, gs.i = g.i;
+ count = 0;
+ if (scale >= safmx2) {
+L10:
+ ++count;
+ q__1.r = safmn2 * fs.r, q__1.i = safmn2 * fs.i;
+ fs.r = q__1.r, fs.i = q__1.i;
+ q__1.r = safmn2 * gs.r, q__1.i = safmn2 * gs.i;
+ gs.r = q__1.r, gs.i = q__1.i;
+ scale *= safmn2;
+ if (scale >= safmx2) {
+ goto L10;
+ }
+ } else if (scale <= safmn2) {
+ if (g.r == 0.f && g.i == 0.f) {
+ cs = 1.f;
+ sn.r = 0.f, sn.i = 0.f;
+ r__.r = f.r, r__.i = f.i;
+ goto L50;
+ }
+L20:
+ --count;
+ q__1.r = safmx2 * fs.r, q__1.i = safmx2 * fs.i;
+ fs.r = q__1.r, fs.i = q__1.i;
+ q__1.r = safmx2 * gs.r, q__1.i = safmx2 * gs.i;
+ gs.r = q__1.r, gs.i = q__1.i;
+ scale *= safmx2;
+ if (scale <= safmn2) {
+ goto L20;
+ }
+ }
+/* Computing 2nd power */
+ r__1 = fs.r;
+/* Computing 2nd power */
+ r__2 = r_imag(&fs);
+ f2 = r__1 * r__1 + r__2 * r__2;
+/* Computing 2nd power */
+ r__1 = gs.r;
+/* Computing 2nd power */
+ r__2 = r_imag(&gs);
+ g2 = r__1 * r__1 + r__2 * r__2;
+ if (f2 <= dmax(g2,1.f) * safmin) {
+
+/* This is a rare case: F is very small. */
+
+ if (f.r == 0.f && f.i == 0.f) {
+ cs = 0.f;
+ r__2 = g.r;
+ r__3 = r_imag(&g);
+ r__1 = slapy2_(&r__2, &r__3);
+ r__.r = r__1, r__.i = 0.f;
+/* Do complex/real division explicitly with two real */
+/* divisions */
+ r__1 = gs.r;
+ r__2 = r_imag(&gs);
+ d__ = slapy2_(&r__1, &r__2);
+ r__1 = gs.r / d__;
+ r__2 = -r_imag(&gs) / d__;
+ q__1.r = r__1, q__1.i = r__2;
+ sn.r = q__1.r, sn.i = q__1.i;
+ goto L50;
+ }
+ r__1 = fs.r;
+ r__2 = r_imag(&fs);
+ f2s = slapy2_(&r__1, &r__2);
+/* G2 and G2S are accurate */
+/* G2 is at least SAFMIN, and G2S is at least SAFMN2 */
+ g2s = sqrt(g2);
+/* Error in CS from underflow in F2S is at most */
+/* UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS */
+/* If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN, */
+/* and so CS .lt. sqrt(SAFMIN) */
+/* If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN */
+/* and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS) */
+/* Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S */
+ cs = f2s / g2s;
+/* Make sure abs(FF) = 1 */
+/* Do complex/real division explicitly with 2 real divisions */
+/* Computing MAX */
+ r__3 = (r__1 = f.r, dabs(r__1)), r__4 = (r__2 = r_imag(&f), dabs(
+ r__2));
+ if (dmax(r__3,r__4) > 1.f) {
+ r__1 = f.r;
+ r__2 = r_imag(&f);
+ d__ = slapy2_(&r__1, &r__2);
+ r__1 = f.r / d__;
+ r__2 = r_imag(&f) / d__;
+ q__1.r = r__1, q__1.i = r__2;
+ ff.r = q__1.r, ff.i = q__1.i;
+ } else {
+ dr = safmx2 * f.r;
+ di = safmx2 * r_imag(&f);
+ d__ = slapy2_(&dr, &di);
+ r__1 = dr / d__;
+ r__2 = di / d__;
+ q__1.r = r__1, q__1.i = r__2;
+ ff.r = q__1.r, ff.i = q__1.i;
+ }
+ r__1 = gs.r / g2s;
+ r__2 = -r_imag(&gs) / g2s;
+ q__2.r = r__1, q__2.i = r__2;
+ q__1.r = ff.r * q__2.r - ff.i * q__2.i, q__1.i = ff.r * q__2.i +
+ ff.i * q__2.r;
+ sn.r = q__1.r, sn.i = q__1.i;
+ q__2.r = cs * f.r, q__2.i = cs * f.i;
+ q__3.r = sn.r * g.r - sn.i * g.i, q__3.i = sn.r * g.i + sn.i *
+ g.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ r__.r = q__1.r, r__.i = q__1.i;
+ } else {
+
+/* This is the most common case. */
+/* Neither F2 nor F2/G2 are less than SAFMIN */
+/* F2S cannot overflow, and it is accurate */
+
+ f2s = sqrt(g2 / f2 + 1.f);
+/* Do the F2S(real)*FS(complex) multiply with two real */
+/* multiplies */
+ r__1 = f2s * fs.r;
+ r__2 = f2s * r_imag(&fs);
+ q__1.r = r__1, q__1.i = r__2;
+ r__.r = q__1.r, r__.i = q__1.i;
+ cs = 1.f / f2s;
+ d__ = f2 + g2;
+/* Do complex/real division explicitly with two real divisions */
+ r__1 = r__.r / d__;
+ r__2 = r_imag(&r__) / d__;
+ q__1.r = r__1, q__1.i = r__2;
+ sn.r = q__1.r, sn.i = q__1.i;
+ r_cnjg(&q__2, &gs);
+ q__1.r = sn.r * q__2.r - sn.i * q__2.i, q__1.i = sn.r * q__2.i +
+ sn.i * q__2.r;
+ sn.r = q__1.r, sn.i = q__1.i;
+ if (count != 0) {
+ if (count > 0) {
+ i__2 = count;
+ for (j = 1; j <= i__2; ++j) {
+ q__1.r = safmx2 * r__.r, q__1.i = safmx2 * r__.i;
+ r__.r = q__1.r, r__.i = q__1.i;
+/* L30: */
+ }
+ } else {
+ i__2 = -count;
+ for (j = 1; j <= i__2; ++j) {
+ q__1.r = safmn2 * r__.r, q__1.i = safmn2 * r__.i;
+ r__.r = q__1.r, r__.i = q__1.i;
+/* L40: */
+ }
+ }
+ }
+ }
+L50:
+ c__[ic] = cs;
+ i__2 = iy;
+ y[i__2].r = sn.r, y[i__2].i = sn.i;
+ i__2 = ix;
+ x[i__2].r = r__.r, x[i__2].i = r__.i;
+ ic += *incc;
+ iy += *incy;
+ ix += *incx;
+/* L60: */
+ }
+ return 0;
+
+/* End of CLARGV */
+
+} /* clargv_ */
diff --git a/SRC/clarnv.c b/SRC/clarnv.c
new file mode 100644
index 0000000..b4f2076
--- /dev/null
+++ b/SRC/clarnv.c
@@ -0,0 +1,190 @@
+/* clarnv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int clarnv_(integer *idist, integer *iseed, integer *n,
+ complex *x)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ double log(doublereal), sqrt(doublereal);
+ void c_exp(complex *, complex *);
+
+ /* Local variables */
+ integer i__;
+ real u[128];
+ integer il, iv;
+ extern /* Subroutine */ int slaruv_(integer *, integer *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLARNV returns a vector of n random complex numbers from a uniform or */
+/* normal distribution. */
+
+/* Arguments */
+/* ========= */
+
+/* IDIST (input) INTEGER */
+/* Specifies the distribution of the random numbers: */
+/* = 1: real and imaginary parts each uniform (0,1) */
+/* = 2: real and imaginary parts each uniform (-1,1) */
+/* = 3: real and imaginary parts each normal (0,1) */
+/* = 4: uniformly distributed on the disc abs(z) < 1 */
+/* = 5: uniformly distributed on the circle abs(z) = 1 */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* N (input) INTEGER */
+/* The number of random numbers to be generated. */
+
+/* X (output) COMPLEX array, dimension (N) */
+/* The generated random numbers. */
+
+/* Further Details */
+/* =============== */
+
+/* This routine calls the auxiliary routine SLARUV to generate random */
+/* real numbers from a uniform (0,1) distribution, in batches of up to */
+/* 128 using vectorisable code. The Box-Muller method is used to */
+/* transform numbers from a uniform to a normal distribution. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --x;
+ --iseed;
+
+ /* Function Body */
+ i__1 = *n;
+ for (iv = 1; iv <= i__1; iv += 64) {
+/* Computing MIN */
+ i__2 = 64, i__3 = *n - iv + 1;
+ il = min(i__2,i__3);
+
+/* Call SLARUV to generate 2*IL real numbers from a uniform (0,1) */
+/* distribution (2*IL <= LV) */
+
+ i__2 = il << 1;
+ slaruv_(&iseed[1], &i__2, u);
+
+ if (*idist == 1) {
+
+/* Copy generated numbers */
+
+ i__2 = il;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = iv + i__ - 1;
+ i__4 = (i__ << 1) - 2;
+ i__5 = (i__ << 1) - 1;
+ q__1.r = u[i__4], q__1.i = u[i__5];
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+/* L10: */
+ }
+ } else if (*idist == 2) {
+
+/* Convert generated numbers to uniform (-1,1) distribution */
+
+ i__2 = il;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = iv + i__ - 1;
+ r__1 = u[(i__ << 1) - 2] * 2.f - 1.f;
+ r__2 = u[(i__ << 1) - 1] * 2.f - 1.f;
+ q__1.r = r__1, q__1.i = r__2;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+/* L20: */
+ }
+ } else if (*idist == 3) {
+
+/* Convert generated numbers to normal (0,1) distribution */
+
+ i__2 = il;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = iv + i__ - 1;
+ r__1 = sqrt(log(u[(i__ << 1) - 2]) * -2.f);
+ r__2 = u[(i__ << 1) - 1] * 6.2831853071795864769252867663f;
+ q__3.r = 0.f, q__3.i = r__2;
+ c_exp(&q__2, &q__3);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+/* L30: */
+ }
+ } else if (*idist == 4) {
+
+/* Convert generated numbers to complex numbers uniformly */
+/* distributed on the unit disk */
+
+ i__2 = il;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = iv + i__ - 1;
+ r__1 = sqrt(u[(i__ << 1) - 2]);
+ r__2 = u[(i__ << 1) - 1] * 6.2831853071795864769252867663f;
+ q__3.r = 0.f, q__3.i = r__2;
+ c_exp(&q__2, &q__3);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+/* L40: */
+ }
+ } else if (*idist == 5) {
+
+/* Convert generated numbers to complex numbers uniformly */
+/* distributed on the unit circle */
+
+ i__2 = il;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = iv + i__ - 1;
+ r__1 = u[(i__ << 1) - 1] * 6.2831853071795864769252867663f;
+ q__2.r = 0.f, q__2.i = r__1;
+ c_exp(&q__1, &q__2);
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ return 0;
+
+/* End of CLARNV */
+
+} /* clarnv_ */
diff --git a/SRC/clarrv.c b/SRC/clarrv.c
new file mode 100644
index 0000000..a5bf8a7
--- /dev/null
+++ b/SRC/clarrv.c
@@ -0,0 +1,1015 @@
+/* clarrv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static integer c__1 = 1;
+static integer c__2 = 2;
+static real c_b28 = 0.f;
+
+/* Subroutine */ int clarrv_(integer *n, real *vl, real *vu, real *d__, real *
+ l, real *pivmin, integer *isplit, integer *m, integer *dol, integer *
+ dou, real *minrgp, real *rtol1, real *rtol2, real *w, real *werr,
+ real *wgap, integer *iblock, integer *indexw, real *gers, complex *
+ z__, integer *ldz, integer *isuppz, real *work, integer *iwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1, r__2;
+ complex q__1;
+ logical L__1;
+
+ /* Builtin functions */
+ double log(doublereal);
+
+ /* Local variables */
+ integer minwsize, i__, j, k, p, q, miniwsize, ii;
+ real gl;
+ integer im, in;
+ real gu, gap, eps, tau, tol, tmp;
+ integer zto;
+ real ztz;
+ integer iend, jblk;
+ real lgap;
+ integer done;
+ real rgap, left;
+ integer wend, iter;
+ real bstw;
+ integer itmp1, indld;
+ real fudge;
+ integer idone;
+ real sigma;
+ integer iinfo, iindr;
+ real resid;
+ logical eskip;
+ real right;
+ integer nclus, zfrom;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ real rqtol;
+ integer iindc1, iindc2, indin1, indin2;
+ extern /* Subroutine */ int clar1v_(integer *, integer *, integer *, real
+ *, real *, real *, real *, real *, real *, real *, complex *,
+ logical *, integer *, real *, real *, integer *, integer *, real *
+, real *, real *, real *);
+ logical stp2ii;
+ real lambda;
+ integer ibegin, indeig;
+ logical needbs;
+ integer indlld;
+ real sgndef, mingma;
+ extern doublereal slamch_(char *);
+ integer oldien, oldncl, wbegin;
+ real spdiam;
+ integer negcnt;
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *);
+ integer oldcls;
+ real savgap;
+ integer ndepth;
+ real ssigma;
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *);
+ logical usedbs;
+ integer iindwk, offset;
+ real gaptol;
+ extern /* Subroutine */ int slarrb_(integer *, real *, real *, integer *,
+ integer *, real *, real *, integer *, real *, real *, real *,
+ real *, integer *, real *, real *, integer *, integer *);
+ integer newcls, oldfst, indwrk, windex, oldlst;
+ logical usedrq;
+ integer newfst, newftt, parity, windmn, windpl, isupmn, newlst, zusedl;
+ real bstres;
+ integer newsiz, zusedu, zusedw;
+ real nrminv, rqcorr;
+ logical tryrqc;
+ integer isupmx;
+ extern /* Subroutine */ int slarrf_(integer *, real *, real *, real *,
+ integer *, integer *, real *, real *, real *, real *, real *,
+ real *, real *, real *, real *, real *, real *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLARRV computes the eigenvectors of the tridiagonal matrix */
+/* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T. */
+/* The input eigenvalues should have been computed by SLARRE. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* Lower and upper bounds of the interval that contains the desired */
+/* eigenvalues. VL < VU. Needed to compute gaps on the left or right */
+/* end of the extremal eigenvalues in the desired RANGE. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the N diagonal elements of the diagonal matrix D. */
+/* On exit, D may be overwritten. */
+
+/* L (input/output) REAL array, dimension (N) */
+/* On entry, the (N-1) subdiagonal elements of the unit */
+/* bidiagonal matrix L are in elements 1 to N-1 of L */
+/* (if the matrix is not splitted.) At the end of each block */
+/* is stored the corresponding shift as given by SLARRE. */
+/* On exit, L is overwritten. */
+
+/* PIVMIN (in) DOUBLE PRECISION */
+/* The minimum pivot allowed in the Sturm sequence. */
+
+/* ISPLIT (input) INTEGER array, dimension (N) */
+/* The splitting points, at which T breaks up into blocks. */
+/* The first block consists of rows/columns 1 to */
+/* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 */
+/* through ISPLIT( 2 ), etc. */
+
+/* M (input) INTEGER */
+/* The total number of input eigenvalues. 0 <= M <= N. */
+
+/* DOL (input) INTEGER */
+/* DOU (input) INTEGER */
+/* If the user wants to compute only selected eigenvectors from all */
+/* the eigenvalues supplied, he can specify an index range DOL:DOU. */
+/* Or else the setting DOL=1, DOU=M should be applied. */
+/* Note that DOL and DOU refer to the order in which the eigenvalues */
+/* are stored in W. */
+/* If the user wants to compute only selected eigenpairs, then */
+/* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the */
+/* computed eigenvectors. All other columns of Z are set to zero. */
+
+/* MINRGP (input) REAL */
+
+/* RTOL1 (input) REAL */
+/* RTOL2 (input) REAL */
+/* Parameters for bisection. */
+/* An interval [LEFT,RIGHT] has converged if */
+/* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */
+
+/* W (input/output) REAL array, dimension (N) */
+/* The first M elements of W contain the APPROXIMATE eigenvalues for */
+/* which eigenvectors are to be computed. The eigenvalues */
+/* should be grouped by split-off block and ordered from */
+/* smallest to largest within the block ( The output array */
+/* W from SLARRE is expected here ). Furthermore, they are with */
+/* respect to the shift of the corresponding root representation */
+/* for their block. On exit, W holds the eigenvalues of the */
+/* UNshifted matrix. */
+
+/* WERR (input/output) REAL array, dimension (N) */
+/* The first M elements contain the semiwidth of the uncertainty */
+/* interval of the corresponding eigenvalue in W */
+
+/* WGAP (input/output) REAL array, dimension (N) */
+/* The separation from the right neighbor eigenvalue in W. */
+
+/* IBLOCK (input) INTEGER array, dimension (N) */
+/* The indices of the blocks (submatrices) associated with the */
+/* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue */
+/* W(i) belongs to the first block from the top, =2 if W(i) */
+/* belongs to the second block, etc. */
+
+/* INDEXW (input) INTEGER array, dimension (N) */
+/* The indices of the eigenvalues within each block (submatrix); */
+/* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the */
+/* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block. */
+
+/* GERS (input) REAL array, dimension (2*N) */
+/* The N Gerschgorin intervals (the i-th Gerschgorin interval */
+/* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should */
+/* be computed from the original UNshifted matrix. */
+
+/* Z (output) COMPLEX array, dimension (LDZ, max(1,M) ) */
+/* If INFO = 0, the first M columns of Z contain the */
+/* orthonormal eigenvectors of the matrix T */
+/* corresponding to the input eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */
+/* The support of the eigenvectors in Z, i.e., the indices */
+/* indicating the nonzero elements in Z. The I-th eigenvector */
+/* is nonzero only in elements ISUPPZ( 2*I-1 ) through */
+/* ISUPPZ( 2*I ). */
+
+/* WORK (workspace) REAL array, dimension (12*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (7*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+
+/* > 0: A problem occured in CLARRV. */
+/* < 0: One of the called subroutines signaled an internal problem. */
+/* Needs inspection of the corresponding parameter IINFO */
+/* for further information. */
+
+/* =-1: Problem in SLARRB when refining a child's eigenvalues. */
+/* =-2: Problem in SLARRF when computing the RRR of a child. */
+/* When a child is inside a tight cluster, it can be difficult */
+/* to find an RRR. A partial remedy from the user's point of */
+/* view is to make the parameter MINRGP smaller and recompile. */
+/* However, as the orthogonality of the computed vectors is */
+/* proportional to 1/MINRGP, the user should be aware that */
+/* he might be trading in precision when he decreases MINRGP. */
+/* =-3: Problem in SLARRB when refining a single eigenvalue */
+/* after the Rayleigh correction was rejected. */
+/* = 5: The Rayleigh Quotient Iteration failed to converge to */
+/* full accuracy in MAXITR steps. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+/* .. */
+/* The first N entries of WORK are reserved for the eigenvalues */
+ /* Parameter adjustments */
+ --d__;
+ --l;
+ --isplit;
+ --w;
+ --werr;
+ --wgap;
+ --iblock;
+ --indexw;
+ --gers;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --isuppz;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ indld = *n + 1;
+ indlld = (*n << 1) + 1;
+ indin1 = *n * 3 + 1;
+ indin2 = (*n << 2) + 1;
+ indwrk = *n * 5 + 1;
+ minwsize = *n * 12;
+ i__1 = minwsize;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L5: */
+ }
+/* IWORK(IINDR+1:IINDR+N) hold the twist indices R for the */
+/* factorization used to compute the FP vector */
+ iindr = 0;
+/* IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current */
+/* layer and the one above. */
+ iindc1 = *n;
+ iindc2 = *n << 1;
+ iindwk = *n * 3 + 1;
+ miniwsize = *n * 7;
+ i__1 = miniwsize;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ iwork[i__] = 0;
+/* L10: */
+ }
+ zusedl = 1;
+ if (*dol > 1) {
+/* Set lower bound for use of Z */
+ zusedl = *dol - 1;
+ }
+ zusedu = *m;
+ if (*dou < *m) {
+/* Set lower bound for use of Z */
+ zusedu = *dou + 1;
+ }
+/* The width of the part of Z that is used */
+ zusedw = zusedu - zusedl + 1;
+ claset_("Full", n, &zusedw, &c_b1, &c_b1, &z__[zusedl * z_dim1 + 1], ldz);
+ eps = slamch_("Precision");
+ rqtol = eps * 2.f;
+
+/* Set expert flags for standard code. */
+ tryrqc = TRUE_;
+ if (*dol == 1 && *dou == *m) {
+ } else {
+/* Only selected eigenpairs are computed. Since the other evalues */
+/* are not refined by RQ iteration, bisection has to compute to full */
+/* accuracy. */
+ *rtol1 = eps * 4.f;
+ *rtol2 = eps * 4.f;
+ }
+/* The entries WBEGIN:WEND in W, WERR, WGAP correspond to the */
+/* desired eigenvalues. The support of the nonzero eigenvector */
+/* entries is contained in the interval IBEGIN:IEND. */
+/* Remark that if k eigenpairs are desired, then the eigenvectors */
+/* are stored in k contiguous columns of Z. */
+/* DONE is the number of eigenvectors already computed */
+ done = 0;
+ ibegin = 1;
+ wbegin = 1;
+ i__1 = iblock[*m];
+ for (jblk = 1; jblk <= i__1; ++jblk) {
+ iend = isplit[jblk];
+ sigma = l[iend];
+/* Find the eigenvectors of the submatrix indexed IBEGIN */
+/* through IEND. */
+ wend = wbegin - 1;
+L15:
+ if (wend < *m) {
+ if (iblock[wend + 1] == jblk) {
+ ++wend;
+ goto L15;
+ }
+ }
+ if (wend < wbegin) {
+ ibegin = iend + 1;
+ goto L170;
+ } else if (wend < *dol || wbegin > *dou) {
+ ibegin = iend + 1;
+ wbegin = wend + 1;
+ goto L170;
+ }
+/* Find local spectral diameter of the block */
+ gl = gers[(ibegin << 1) - 1];
+ gu = gers[ibegin * 2];
+ i__2 = iend;
+ for (i__ = ibegin + 1; i__ <= i__2; ++i__) {
+/* Computing MIN */
+ r__1 = gers[(i__ << 1) - 1];
+ gl = dmin(r__1,gl);
+/* Computing MAX */
+ r__1 = gers[i__ * 2];
+ gu = dmax(r__1,gu);
+/* L20: */
+ }
+ spdiam = gu - gl;
+/* OLDIEN is the last index of the previous block */
+ oldien = ibegin - 1;
+/* Calculate the size of the current block */
+ in = iend - ibegin + 1;
+/* The number of eigenvalues in the current block */
+ im = wend - wbegin + 1;
+/* This is for a 1x1 block */
+ if (ibegin == iend) {
+ ++done;
+ i__2 = ibegin + wbegin * z_dim1;
+ z__[i__2].r = 1.f, z__[i__2].i = 0.f;
+ isuppz[(wbegin << 1) - 1] = ibegin;
+ isuppz[wbegin * 2] = ibegin;
+ w[wbegin] += sigma;
+ work[wbegin] = w[wbegin];
+ ibegin = iend + 1;
+ ++wbegin;
+ goto L170;
+ }
+/* The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND) */
+/* Note that these can be approximations, in this case, the corresp. */
+/* entries of WERR give the size of the uncertainty interval. */
+/* The eigenvalue approximations will be refined when necessary as */
+/* high relative accuracy is required for the computation of the */
+/* corresponding eigenvectors. */
+ scopy_(&im, &w[wbegin], &c__1, &work[wbegin], &c__1);
+/* We store in W the eigenvalue approximations w.r.t. the original */
+/* matrix T. */
+ i__2 = im;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ w[wbegin + i__ - 1] += sigma;
+/* L30: */
+ }
+/* NDEPTH is the current depth of the representation tree */
+ ndepth = 0;
+/* PARITY is either 1 or 0 */
+ parity = 1;
+/* NCLUS is the number of clusters for the next level of the */
+/* representation tree, we start with NCLUS = 1 for the root */
+ nclus = 1;
+ iwork[iindc1 + 1] = 1;
+ iwork[iindc1 + 2] = im;
+/* IDONE is the number of eigenvectors already computed in the current */
+/* block */
+ idone = 0;
+/* loop while( IDONE.LT.IM ) */
+/* generate the representation tree for the current block and */
+/* compute the eigenvectors */
+L40:
+ if (idone < im) {
+/* This is a crude protection against infinitely deep trees */
+ if (ndepth > *m) {
+ *info = -2;
+ return 0;
+ }
+/* breadth first processing of the current level of the representation */
+/* tree: OLDNCL = number of clusters on current level */
+ oldncl = nclus;
+/* reset NCLUS to count the number of child clusters */
+ nclus = 0;
+
+ parity = 1 - parity;
+ if (parity == 0) {
+ oldcls = iindc1;
+ newcls = iindc2;
+ } else {
+ oldcls = iindc2;
+ newcls = iindc1;
+ }
+/* Process the clusters on the current level */
+ i__2 = oldncl;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ j = oldcls + (i__ << 1);
+/* OLDFST, OLDLST = first, last index of current cluster. */
+/* cluster indices start with 1 and are relative */
+/* to WBEGIN when accessing W, WGAP, WERR, Z */
+ oldfst = iwork[j - 1];
+ oldlst = iwork[j];
+ if (ndepth > 0) {
+/* Retrieve relatively robust representation (RRR) of cluster */
+/* that has been computed at the previous level */
+/* The RRR is stored in Z and overwritten once the eigenvectors */
+/* have been computed or when the cluster is refined */
+ if (*dol == 1 && *dou == *m) {
+/* Get representation from location of the leftmost evalue */
+/* of the cluster */
+ j = wbegin + oldfst - 1;
+ } else {
+ if (wbegin + oldfst - 1 < *dol) {
+/* Get representation from the left end of Z array */
+ j = *dol - 1;
+ } else if (wbegin + oldfst - 1 > *dou) {
+/* Get representation from the right end of Z array */
+ j = *dou;
+ } else {
+ j = wbegin + oldfst - 1;
+ }
+ }
+ i__3 = in - 1;
+ for (k = 1; k <= i__3; ++k) {
+ i__4 = ibegin + k - 1 + j * z_dim1;
+ d__[ibegin + k - 1] = z__[i__4].r;
+ i__4 = ibegin + k - 1 + (j + 1) * z_dim1;
+ l[ibegin + k - 1] = z__[i__4].r;
+/* L45: */
+ }
+ i__3 = iend + j * z_dim1;
+ d__[iend] = z__[i__3].r;
+ i__3 = iend + (j + 1) * z_dim1;
+ sigma = z__[i__3].r;
+/* Set the corresponding entries in Z to zero */
+ claset_("Full", &in, &c__2, &c_b1, &c_b1, &z__[ibegin + j
+ * z_dim1], ldz);
+ }
+/* Compute DL and DLL of current RRR */
+ i__3 = iend - 1;
+ for (j = ibegin; j <= i__3; ++j) {
+ tmp = d__[j] * l[j];
+ work[indld - 1 + j] = tmp;
+ work[indlld - 1 + j] = tmp * l[j];
+/* L50: */
+ }
+ if (ndepth > 0) {
+/* P and Q are index of the first and last eigenvalue to compute */
+/* within the current block */
+ p = indexw[wbegin - 1 + oldfst];
+ q = indexw[wbegin - 1 + oldlst];
+/* Offset for the arrays WORK, WGAP and WERR, i.e., th P-OFFSET */
+/* thru' Q-OFFSET elements of these arrays are to be used. */
+/* OFFSET = P-OLDFST */
+ offset = indexw[wbegin] - 1;
+/* perform limited bisection (if necessary) to get approximate */
+/* eigenvalues to the precision needed. */
+ slarrb_(&in, &d__[ibegin], &work[indlld + ibegin - 1], &p,
+ &q, rtol1, rtol2, &offset, &work[wbegin], &wgap[
+ wbegin], &werr[wbegin], &work[indwrk], &iwork[
+ iindwk], pivmin, &spdiam, &in, &iinfo);
+ if (iinfo != 0) {
+ *info = -1;
+ return 0;
+ }
+/* We also recompute the extremal gaps. W holds all eigenvalues */
+/* of the unshifted matrix and must be used for computation */
+/* of WGAP, the entries of WORK might stem from RRRs with */
+/* different shifts. The gaps from WBEGIN-1+OLDFST to */
+/* WBEGIN-1+OLDLST are correctly computed in SLARRB. */
+/* However, we only allow the gaps to become greater since */
+/* this is what should happen when we decrease WERR */
+ if (oldfst > 1) {
+/* Computing MAX */
+ r__1 = wgap[wbegin + oldfst - 2], r__2 = w[wbegin +
+ oldfst - 1] - werr[wbegin + oldfst - 1] - w[
+ wbegin + oldfst - 2] - werr[wbegin + oldfst -
+ 2];
+ wgap[wbegin + oldfst - 2] = dmax(r__1,r__2);
+ }
+ if (wbegin + oldlst - 1 < wend) {
+/* Computing MAX */
+ r__1 = wgap[wbegin + oldlst - 1], r__2 = w[wbegin +
+ oldlst] - werr[wbegin + oldlst] - w[wbegin +
+ oldlst - 1] - werr[wbegin + oldlst - 1];
+ wgap[wbegin + oldlst - 1] = dmax(r__1,r__2);
+ }
+/* Each time the eigenvalues in WORK get refined, we store */
+/* the newly found approximation with all shifts applied in W */
+ i__3 = oldlst;
+ for (j = oldfst; j <= i__3; ++j) {
+ w[wbegin + j - 1] = work[wbegin + j - 1] + sigma;
+/* L53: */
+ }
+ }
+/* Process the current node. */
+ newfst = oldfst;
+ i__3 = oldlst;
+ for (j = oldfst; j <= i__3; ++j) {
+ if (j == oldlst) {
+/* we are at the right end of the cluster, this is also the */
+/* boundary of the child cluster */
+ newlst = j;
+ } else if (wgap[wbegin + j - 1] >= *minrgp * (r__1 = work[
+ wbegin + j - 1], dabs(r__1))) {
+/* the right relative gap is big enough, the child cluster */
+/* (NEWFST,..,NEWLST) is well separated from the following */
+ newlst = j;
+ } else {
+/* inside a child cluster, the relative gap is not */
+/* big enough. */
+ goto L140;
+ }
+/* Compute size of child cluster found */
+ newsiz = newlst - newfst + 1;
+/* NEWFTT is the place in Z where the new RRR or the computed */
+/* eigenvector is to be stored */
+ if (*dol == 1 && *dou == *m) {
+/* Store representation at location of the leftmost evalue */
+/* of the cluster */
+ newftt = wbegin + newfst - 1;
+ } else {
+ if (wbegin + newfst - 1 < *dol) {
+/* Store representation at the left end of Z array */
+ newftt = *dol - 1;
+ } else if (wbegin + newfst - 1 > *dou) {
+/* Store representation at the right end of Z array */
+ newftt = *dou;
+ } else {
+ newftt = wbegin + newfst - 1;
+ }
+ }
+ if (newsiz > 1) {
+
+/* Current child is not a singleton but a cluster. */
+/* Compute and store new representation of child. */
+
+
+/* Compute left and right cluster gap. */
+
+/* LGAP and RGAP are not computed from WORK because */
+/* the eigenvalue approximations may stem from RRRs */
+/* different shifts. However, W hold all eigenvalues */
+/* of the unshifted matrix. Still, the entries in WGAP */
+/* have to be computed from WORK since the entries */
+/* in W might be of the same order so that gaps are not */
+/* exhibited correctly for very close eigenvalues. */
+ if (newfst == 1) {
+/* Computing MAX */
+ r__1 = 0.f, r__2 = w[wbegin] - werr[wbegin] - *vl;
+ lgap = dmax(r__1,r__2);
+ } else {
+ lgap = wgap[wbegin + newfst - 2];
+ }
+ rgap = wgap[wbegin + newlst - 1];
+
+/* Compute left- and rightmost eigenvalue of child */
+/* to high precision in order to shift as close */
+/* as possible and obtain as large relative gaps */
+/* as possible */
+
+ for (k = 1; k <= 2; ++k) {
+ if (k == 1) {
+ p = indexw[wbegin - 1 + newfst];
+ } else {
+ p = indexw[wbegin - 1 + newlst];
+ }
+ offset = indexw[wbegin] - 1;
+ slarrb_(&in, &d__[ibegin], &work[indlld + ibegin
+ - 1], &p, &p, &rqtol, &rqtol, &offset, &
+ work[wbegin], &wgap[wbegin], &werr[wbegin]
+, &work[indwrk], &iwork[iindwk], pivmin, &
+ spdiam, &in, &iinfo);
+/* L55: */
+ }
+
+ if (wbegin + newlst - 1 < *dol || wbegin + newfst - 1
+ > *dou) {
+/* if the cluster contains no desired eigenvalues */
+/* skip the computation of that branch of the rep. tree */
+
+/* We could skip before the refinement of the extremal */
+/* eigenvalues of the child, but then the representation */
+/* tree could be different from the one when nothing is */
+/* skipped. For this reason we skip at this place. */
+ idone = idone + newlst - newfst + 1;
+ goto L139;
+ }
+
+/* Compute RRR of child cluster. */
+/* Note that the new RRR is stored in Z */
+
+/* SLARRF needs LWORK = 2*N */
+ slarrf_(&in, &d__[ibegin], &l[ibegin], &work[indld +
+ ibegin - 1], &newfst, &newlst, &work[wbegin],
+ &wgap[wbegin], &werr[wbegin], &spdiam, &lgap,
+ &rgap, pivmin, &tau, &work[indin1], &work[
+ indin2], &work[indwrk], &iinfo);
+/* In the complex case, SLARRF cannot write */
+/* the new RRR directly into Z and needs an intermediate */
+/* workspace */
+ i__4 = in - 1;
+ for (k = 1; k <= i__4; ++k) {
+ i__5 = ibegin + k - 1 + newftt * z_dim1;
+ i__6 = indin1 + k - 1;
+ q__1.r = work[i__6], q__1.i = 0.f;
+ z__[i__5].r = q__1.r, z__[i__5].i = q__1.i;
+ i__5 = ibegin + k - 1 + (newftt + 1) * z_dim1;
+ i__6 = indin2 + k - 1;
+ q__1.r = work[i__6], q__1.i = 0.f;
+ z__[i__5].r = q__1.r, z__[i__5].i = q__1.i;
+/* L56: */
+ }
+ i__4 = iend + newftt * z_dim1;
+ i__5 = indin1 + in - 1;
+ q__1.r = work[i__5], q__1.i = 0.f;
+ z__[i__4].r = q__1.r, z__[i__4].i = q__1.i;
+ if (iinfo == 0) {
+/* a new RRR for the cluster was found by SLARRF */
+/* update shift and store it */
+ ssigma = sigma + tau;
+ i__4 = iend + (newftt + 1) * z_dim1;
+ q__1.r = ssigma, q__1.i = 0.f;
+ z__[i__4].r = q__1.r, z__[i__4].i = q__1.i;
+/* WORK() are the midpoints and WERR() the semi-width */
+/* Note that the entries in W are unchanged. */
+ i__4 = newlst;
+ for (k = newfst; k <= i__4; ++k) {
+ fudge = eps * 3.f * (r__1 = work[wbegin + k -
+ 1], dabs(r__1));
+ work[wbegin + k - 1] -= tau;
+ fudge += eps * 4.f * (r__1 = work[wbegin + k
+ - 1], dabs(r__1));
+/* Fudge errors */
+ werr[wbegin + k - 1] += fudge;
+/* Gaps are not fudged. Provided that WERR is small */
+/* when eigenvalues are close, a zero gap indicates */
+/* that a new representation is needed for resolving */
+/* the cluster. A fudge could lead to a wrong decision */
+/* of judging eigenvalues 'separated' which in */
+/* reality are not. This could have a negative impact */
+/* on the orthogonality of the computed eigenvectors. */
+/* L116: */
+ }
+ ++nclus;
+ k = newcls + (nclus << 1);
+ iwork[k - 1] = newfst;
+ iwork[k] = newlst;
+ } else {
+ *info = -2;
+ return 0;
+ }
+ } else {
+
+/* Compute eigenvector of singleton */
+
+ iter = 0;
+
+ tol = log((real) in) * 4.f * eps;
+
+ k = newfst;
+ windex = wbegin + k - 1;
+/* Computing MAX */
+ i__4 = windex - 1;
+ windmn = max(i__4,1);
+/* Computing MIN */
+ i__4 = windex + 1;
+ windpl = min(i__4,*m);
+ lambda = work[windex];
+ ++done;
+/* Check if eigenvector computation is to be skipped */
+ if (windex < *dol || windex > *dou) {
+ eskip = TRUE_;
+ goto L125;
+ } else {
+ eskip = FALSE_;
+ }
+ left = work[windex] - werr[windex];
+ right = work[windex] + werr[windex];
+ indeig = indexw[windex];
+/* Note that since we compute the eigenpairs for a child, */
+/* all eigenvalue approximations are w.r.t the same shift. */
+/* In this case, the entries in WORK should be used for */
+/* computing the gaps since they exhibit even very small */
+/* differences in the eigenvalues, as opposed to the */
+/* entries in W which might "look" the same. */
+ if (k == 1) {
+/* In the case RANGE='I' and with not much initial */
+/* accuracy in LAMBDA and VL, the formula */
+/* LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA ) */
+/* can lead to an overestimation of the left gap and */
+/* thus to inadequately early RQI 'convergence'. */
+/* Prevent this by forcing a small left gap. */
+/* Computing MAX */
+ r__1 = dabs(left), r__2 = dabs(right);
+ lgap = eps * dmax(r__1,r__2);
+ } else {
+ lgap = wgap[windmn];
+ }
+ if (k == im) {
+/* In the case RANGE='I' and with not much initial */
+/* accuracy in LAMBDA and VU, the formula */
+/* can lead to an overestimation of the right gap and */
+/* thus to inadequately early RQI 'convergence'. */
+/* Prevent this by forcing a small right gap. */
+/* Computing MAX */
+ r__1 = dabs(left), r__2 = dabs(right);
+ rgap = eps * dmax(r__1,r__2);
+ } else {
+ rgap = wgap[windex];
+ }
+ gap = dmin(lgap,rgap);
+ if (k == 1 || k == im) {
+/* The eigenvector support can become wrong */
+/* because significant entries could be cut off due to a */
+/* large GAPTOL parameter in LAR1V. Prevent this. */
+ gaptol = 0.f;
+ } else {
+ gaptol = gap * eps;
+ }
+ isupmn = in;
+ isupmx = 1;
+/* Update WGAP so that it holds the minimum gap */
+/* to the left or the right. This is crucial in the */
+/* case where bisection is used to ensure that the */
+/* eigenvalue is refined up to the required precision. */
+/* The correct value is restored afterwards. */
+ savgap = wgap[windex];
+ wgap[windex] = gap;
+/* We want to use the Rayleigh Quotient Correction */
+/* as often as possible since it converges quadratically */
+/* when we are close enough to the desired eigenvalue. */
+/* However, the Rayleigh Quotient can have the wrong sign */
+/* and lead us away from the desired eigenvalue. In this */
+/* case, the best we can do is to use bisection. */
+ usedbs = FALSE_;
+ usedrq = FALSE_;
+/* Bisection is initially turned off unless it is forced */
+ needbs = ! tryrqc;
+L120:
+/* Check if bisection should be used to refine eigenvalue */
+ if (needbs) {
+/* Take the bisection as new iterate */
+ usedbs = TRUE_;
+ itmp1 = iwork[iindr + windex];
+ offset = indexw[wbegin] - 1;
+ r__1 = eps * 2.f;
+ slarrb_(&in, &d__[ibegin], &work[indlld + ibegin
+ - 1], &indeig, &indeig, &c_b28, &r__1, &
+ offset, &work[wbegin], &wgap[wbegin], &
+ werr[wbegin], &work[indwrk], &iwork[
+ iindwk], pivmin, &spdiam, &itmp1, &iinfo);
+ if (iinfo != 0) {
+ *info = -3;
+ return 0;
+ }
+ lambda = work[windex];
+/* Reset twist index from inaccurate LAMBDA to */
+/* force computation of true MINGMA */
+ iwork[iindr + windex] = 0;
+ }
+/* Given LAMBDA, compute the eigenvector. */
+ L__1 = ! usedbs;
+ clar1v_(&in, &c__1, &in, &lambda, &d__[ibegin], &l[
+ ibegin], &work[indld + ibegin - 1], &work[
+ indlld + ibegin - 1], pivmin, &gaptol, &z__[
+ ibegin + windex * z_dim1], &L__1, &negcnt, &
+ ztz, &mingma, &iwork[iindr + windex], &isuppz[
+ (windex << 1) - 1], &nrminv, &resid, &rqcorr,
+ &work[indwrk]);
+ if (iter == 0) {
+ bstres = resid;
+ bstw = lambda;
+ } else if (resid < bstres) {
+ bstres = resid;
+ bstw = lambda;
+ }
+/* Computing MIN */
+ i__4 = isupmn, i__5 = isuppz[(windex << 1) - 1];
+ isupmn = min(i__4,i__5);
+/* Computing MAX */
+ i__4 = isupmx, i__5 = isuppz[windex * 2];
+ isupmx = max(i__4,i__5);
+ ++iter;
+/* sin alpha <= |resid|/gap */
+/* Note that both the residual and the gap are */
+/* proportional to the matrix, so ||T|| doesn't play */
+/* a role in the quotient */
+
+/* Convergence test for Rayleigh-Quotient iteration */
+/* (omitted when Bisection has been used) */
+
+ if (resid > tol * gap && dabs(rqcorr) > rqtol * dabs(
+ lambda) && ! usedbs) {
+/* We need to check that the RQCORR update doesn't */
+/* move the eigenvalue away from the desired one and */
+/* towards a neighbor. -> protection with bisection */
+ if (indeig <= negcnt) {
+/* The wanted eigenvalue lies to the left */
+ sgndef = -1.f;
+ } else {
+/* The wanted eigenvalue lies to the right */
+ sgndef = 1.f;
+ }
+/* We only use the RQCORR if it improves the */
+/* the iterate reasonably. */
+ if (rqcorr * sgndef >= 0.f && lambda + rqcorr <=
+ right && lambda + rqcorr >= left) {
+ usedrq = TRUE_;
+/* Store new midpoint of bisection interval in WORK */
+ if (sgndef == 1.f) {
+/* The current LAMBDA is on the left of the true */
+/* eigenvalue */
+ left = lambda;
+/* We prefer to assume that the error estimate */
+/* is correct. We could make the interval not */
+/* as a bracket but to be modified if the RQCORR */
+/* chooses to. In this case, the RIGHT side should */
+/* be modified as follows: */
+/* RIGHT = MAX(RIGHT, LAMBDA + RQCORR) */
+ } else {
+/* The current LAMBDA is on the right of the true */
+/* eigenvalue */
+ right = lambda;
+/* See comment about assuming the error estimate is */
+/* correct above. */
+/* LEFT = MIN(LEFT, LAMBDA + RQCORR) */
+ }
+ work[windex] = (right + left) * .5f;
+/* Take RQCORR since it has the correct sign and */
+/* improves the iterate reasonably */
+ lambda += rqcorr;
+/* Update width of error interval */
+ werr[windex] = (right - left) * .5f;
+ } else {
+ needbs = TRUE_;
+ }
+ if (right - left < rqtol * dabs(lambda)) {
+/* The eigenvalue is computed to bisection accuracy */
+/* compute eigenvector and stop */
+ usedbs = TRUE_;
+ goto L120;
+ } else if (iter < 10) {
+ goto L120;
+ } else if (iter == 10) {
+ needbs = TRUE_;
+ goto L120;
+ } else {
+ *info = 5;
+ return 0;
+ }
+ } else {
+ stp2ii = FALSE_;
+ if (usedrq && usedbs && bstres <= resid) {
+ lambda = bstw;
+ stp2ii = TRUE_;
+ }
+ if (stp2ii) {
+/* improve error angle by second step */
+ L__1 = ! usedbs;
+ clar1v_(&in, &c__1, &in, &lambda, &d__[ibegin]
+, &l[ibegin], &work[indld + ibegin -
+ 1], &work[indlld + ibegin - 1],
+ pivmin, &gaptol, &z__[ibegin + windex
+ * z_dim1], &L__1, &negcnt, &ztz, &
+ mingma, &iwork[iindr + windex], &
+ isuppz[(windex << 1) - 1], &nrminv, &
+ resid, &rqcorr, &work[indwrk]);
+ }
+ work[windex] = lambda;
+ }
+
+/* Compute FP-vector support w.r.t. whole matrix */
+
+ isuppz[(windex << 1) - 1] += oldien;
+ isuppz[windex * 2] += oldien;
+ zfrom = isuppz[(windex << 1) - 1];
+ zto = isuppz[windex * 2];
+ isupmn += oldien;
+ isupmx += oldien;
+/* Ensure vector is ok if support in the RQI has changed */
+ if (isupmn < zfrom) {
+ i__4 = zfrom - 1;
+ for (ii = isupmn; ii <= i__4; ++ii) {
+ i__5 = ii + windex * z_dim1;
+ z__[i__5].r = 0.f, z__[i__5].i = 0.f;
+/* L122: */
+ }
+ }
+ if (isupmx > zto) {
+ i__4 = isupmx;
+ for (ii = zto + 1; ii <= i__4; ++ii) {
+ i__5 = ii + windex * z_dim1;
+ z__[i__5].r = 0.f, z__[i__5].i = 0.f;
+/* L123: */
+ }
+ }
+ i__4 = zto - zfrom + 1;
+ csscal_(&i__4, &nrminv, &z__[zfrom + windex * z_dim1],
+ &c__1);
+L125:
+/* Update W */
+ w[windex] = lambda + sigma;
+/* Recompute the gaps on the left and right */
+/* But only allow them to become larger and not */
+/* smaller (which can only happen through "bad" */
+/* cancellation and doesn't reflect the theory */
+/* where the initial gaps are underestimated due */
+/* to WERR being too crude.) */
+ if (! eskip) {
+ if (k > 1) {
+/* Computing MAX */
+ r__1 = wgap[windmn], r__2 = w[windex] - werr[
+ windex] - w[windmn] - werr[windmn];
+ wgap[windmn] = dmax(r__1,r__2);
+ }
+ if (windex < wend) {
+/* Computing MAX */
+ r__1 = savgap, r__2 = w[windpl] - werr[windpl]
+ - w[windex] - werr[windex];
+ wgap[windex] = dmax(r__1,r__2);
+ }
+ }
+ ++idone;
+ }
+/* here ends the code for the current child */
+
+L139:
+/* Proceed to any remaining child nodes */
+ newfst = j + 1;
+L140:
+ ;
+ }
+/* L150: */
+ }
+ ++ndepth;
+ goto L40;
+ }
+ ibegin = iend + 1;
+ wbegin = wend + 1;
+L170:
+ ;
+ }
+
+ return 0;
+
+/* End of CLARRV */
+
+} /* clarrv_ */
diff --git a/SRC/clarscl2.c b/SRC/clarscl2.c
new file mode 100644
index 0000000..2896853
--- /dev/null
+++ b/SRC/clarscl2.c
@@ -0,0 +1,95 @@
+/* clarscl2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int clarscl2_(integer *m, integer *n, real *d__, complex *x,
+ integer *ldx)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLARSCL2 performs a reciprocal diagonal scaling on an vector: */
+/* x <-- inv(D) * x */
+/* where the REAL diagonal matrix D is stored as a vector. */
+
+/* Eventually to be replaced by BLAS_cge_diag_scale in the new BLAS */
+/* standard. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of D and X. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of D and X. N >= 0. */
+
+/* D (input) REAL array, length M */
+/* Diagonal matrix D, stored as a vector of length M. */
+
+/* X (input/output) COMPLEX array, dimension (LDX,N) */
+/* On entry, the vector X to be scaled by D. */
+/* On exit, the scaled vector. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the vector X. LDX >= 0. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --d__;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+
+ /* Function Body */
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * x_dim1;
+ i__5 = i__;
+ q__1.r = x[i__4].r / d__[i__5], q__1.i = x[i__4].i / d__[i__5];
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ }
+ }
+ return 0;
+} /* clarscl2_ */
diff --git a/SRC/clartg.c b/SRC/clartg.c
new file mode 100644
index 0000000..75456ab
--- /dev/null
+++ b/SRC/clartg.c
@@ -0,0 +1,284 @@
+/* clartg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int clartg_(complex *f, complex *g, real *cs, complex *sn,
+ complex *r__)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ double log(doublereal), pow_ri(real *, integer *), r_imag(complex *),
+ sqrt(doublereal);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ real d__;
+ integer i__;
+ real f2, g2;
+ complex ff;
+ real di, dr;
+ complex fs, gs;
+ real f2s, g2s, eps, scale;
+ integer count;
+ real safmn2, safmx2;
+ extern doublereal slapy2_(real *, real *), slamch_(char *);
+ real safmin;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLARTG generates a plane rotation so that */
+
+/* [ CS SN ] [ F ] [ R ] */
+/* [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1. */
+/* [ -SN CS ] [ G ] [ 0 ] */
+
+/* This is a faster version of the BLAS1 routine CROTG, except for */
+/* the following differences: */
+/* F and G are unchanged on return. */
+/* If G=0, then CS=1 and SN=0. */
+/* If F=0, then CS=0 and SN is chosen so that R is real. */
+
+/* Arguments */
+/* ========= */
+
+/* F (input) COMPLEX */
+/* The first component of vector to be rotated. */
+
+/* G (input) COMPLEX */
+/* The second component of vector to be rotated. */
+
+/* CS (output) REAL */
+/* The cosine of the rotation. */
+
+/* SN (output) COMPLEX */
+/* The sine of the rotation. */
+
+/* R (output) COMPLEX */
+/* The nonzero component of the rotated vector. */
+
+/* Further Details */
+/* ======= ======= */
+
+/* 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel */
+
+/* This version has a few statements commented out for thread safety */
+/* (machine parameters are computed on each entry). 10 feb 03, SJH. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* LOGICAL FIRST */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Save statement .. */
+/* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 */
+/* .. */
+/* .. Data statements .. */
+/* DATA FIRST / .TRUE. / */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* IF( FIRST ) THEN */
+ safmin = slamch_("S");
+ eps = slamch_("E");
+ r__1 = slamch_("B");
+ i__1 = (integer) (log(safmin / eps) / log(slamch_("B")) / 2.f);
+ safmn2 = pow_ri(&r__1, &i__1);
+ safmx2 = 1.f / safmn2;
+/* FIRST = .FALSE. */
+/* END IF */
+/* Computing MAX */
+/* Computing MAX */
+ r__7 = (r__1 = f->r, dabs(r__1)), r__8 = (r__2 = r_imag(f), dabs(r__2));
+/* Computing MAX */
+ r__9 = (r__3 = g->r, dabs(r__3)), r__10 = (r__4 = r_imag(g), dabs(r__4));
+ r__5 = dmax(r__7,r__8), r__6 = dmax(r__9,r__10);
+ scale = dmax(r__5,r__6);
+ fs.r = f->r, fs.i = f->i;
+ gs.r = g->r, gs.i = g->i;
+ count = 0;
+ if (scale >= safmx2) {
+L10:
+ ++count;
+ q__1.r = safmn2 * fs.r, q__1.i = safmn2 * fs.i;
+ fs.r = q__1.r, fs.i = q__1.i;
+ q__1.r = safmn2 * gs.r, q__1.i = safmn2 * gs.i;
+ gs.r = q__1.r, gs.i = q__1.i;
+ scale *= safmn2;
+ if (scale >= safmx2) {
+ goto L10;
+ }
+ } else if (scale <= safmn2) {
+ if (g->r == 0.f && g->i == 0.f) {
+ *cs = 1.f;
+ sn->r = 0.f, sn->i = 0.f;
+ r__->r = f->r, r__->i = f->i;
+ return 0;
+ }
+L20:
+ --count;
+ q__1.r = safmx2 * fs.r, q__1.i = safmx2 * fs.i;
+ fs.r = q__1.r, fs.i = q__1.i;
+ q__1.r = safmx2 * gs.r, q__1.i = safmx2 * gs.i;
+ gs.r = q__1.r, gs.i = q__1.i;
+ scale *= safmx2;
+ if (scale <= safmn2) {
+ goto L20;
+ }
+ }
+/* Computing 2nd power */
+ r__1 = fs.r;
+/* Computing 2nd power */
+ r__2 = r_imag(&fs);
+ f2 = r__1 * r__1 + r__2 * r__2;
+/* Computing 2nd power */
+ r__1 = gs.r;
+/* Computing 2nd power */
+ r__2 = r_imag(&gs);
+ g2 = r__1 * r__1 + r__2 * r__2;
+ if (f2 <= dmax(g2,1.f) * safmin) {
+
+/* This is a rare case: F is very small. */
+
+ if (f->r == 0.f && f->i == 0.f) {
+ *cs = 0.f;
+ r__2 = g->r;
+ r__3 = r_imag(g);
+ r__1 = slapy2_(&r__2, &r__3);
+ r__->r = r__1, r__->i = 0.f;
+/* Do complex/real division explicitly with two real divisions */
+ r__1 = gs.r;
+ r__2 = r_imag(&gs);
+ d__ = slapy2_(&r__1, &r__2);
+ r__1 = gs.r / d__;
+ r__2 = -r_imag(&gs) / d__;
+ q__1.r = r__1, q__1.i = r__2;
+ sn->r = q__1.r, sn->i = q__1.i;
+ return 0;
+ }
+ r__1 = fs.r;
+ r__2 = r_imag(&fs);
+ f2s = slapy2_(&r__1, &r__2);
+/* G2 and G2S are accurate */
+/* G2 is at least SAFMIN, and G2S is at least SAFMN2 */
+ g2s = sqrt(g2);
+/* Error in CS from underflow in F2S is at most */
+/* UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS */
+/* If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN, */
+/* and so CS .lt. sqrt(SAFMIN) */
+/* If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN */
+/* and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS) */
+/* Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S */
+ *cs = f2s / g2s;
+/* Make sure abs(FF) = 1 */
+/* Do complex/real division explicitly with 2 real divisions */
+/* Computing MAX */
+ r__3 = (r__1 = f->r, dabs(r__1)), r__4 = (r__2 = r_imag(f), dabs(r__2)
+ );
+ if (dmax(r__3,r__4) > 1.f) {
+ r__1 = f->r;
+ r__2 = r_imag(f);
+ d__ = slapy2_(&r__1, &r__2);
+ r__1 = f->r / d__;
+ r__2 = r_imag(f) / d__;
+ q__1.r = r__1, q__1.i = r__2;
+ ff.r = q__1.r, ff.i = q__1.i;
+ } else {
+ dr = safmx2 * f->r;
+ di = safmx2 * r_imag(f);
+ d__ = slapy2_(&dr, &di);
+ r__1 = dr / d__;
+ r__2 = di / d__;
+ q__1.r = r__1, q__1.i = r__2;
+ ff.r = q__1.r, ff.i = q__1.i;
+ }
+ r__1 = gs.r / g2s;
+ r__2 = -r_imag(&gs) / g2s;
+ q__2.r = r__1, q__2.i = r__2;
+ q__1.r = ff.r * q__2.r - ff.i * q__2.i, q__1.i = ff.r * q__2.i + ff.i
+ * q__2.r;
+ sn->r = q__1.r, sn->i = q__1.i;
+ q__2.r = *cs * f->r, q__2.i = *cs * f->i;
+ q__3.r = sn->r * g->r - sn->i * g->i, q__3.i = sn->r * g->i + sn->i *
+ g->r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ r__->r = q__1.r, r__->i = q__1.i;
+ } else {
+
+/* This is the most common case. */
+/* Neither F2 nor F2/G2 are less than SAFMIN */
+/* F2S cannot overflow, and it is accurate */
+
+ f2s = sqrt(g2 / f2 + 1.f);
+/* Do the F2S(real)*FS(complex) multiply with two real multiplies */
+ r__1 = f2s * fs.r;
+ r__2 = f2s * r_imag(&fs);
+ q__1.r = r__1, q__1.i = r__2;
+ r__->r = q__1.r, r__->i = q__1.i;
+ *cs = 1.f / f2s;
+ d__ = f2 + g2;
+/* Do complex/real division explicitly with two real divisions */
+ r__1 = r__->r / d__;
+ r__2 = r_imag(r__) / d__;
+ q__1.r = r__1, q__1.i = r__2;
+ sn->r = q__1.r, sn->i = q__1.i;
+ r_cnjg(&q__2, &gs);
+ q__1.r = sn->r * q__2.r - sn->i * q__2.i, q__1.i = sn->r * q__2.i +
+ sn->i * q__2.r;
+ sn->r = q__1.r, sn->i = q__1.i;
+ if (count != 0) {
+ if (count > 0) {
+ i__1 = count;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ q__1.r = safmx2 * r__->r, q__1.i = safmx2 * r__->i;
+ r__->r = q__1.r, r__->i = q__1.i;
+/* L30: */
+ }
+ } else {
+ i__1 = -count;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ q__1.r = safmn2 * r__->r, q__1.i = safmn2 * r__->i;
+ r__->r = q__1.r, r__->i = q__1.i;
+/* L40: */
+ }
+ }
+ }
+ }
+ return 0;
+
+/* End of CLARTG */
+
+} /* clartg_ */
diff --git a/SRC/clartv.c b/SRC/clartv.c
new file mode 100644
index 0000000..d77d54d
--- /dev/null
+++ b/SRC/clartv.c
@@ -0,0 +1,125 @@
+/* clartv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int clartv_(integer *n, complex *x, integer *incx, complex *
+ y, integer *incy, real *c__, complex *s, integer *incc)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, ic, ix, iy;
+ complex xi, yi;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLARTV applies a vector of complex plane rotations with real cosines */
+/* to elements of the complex vectors x and y. For i = 1,2,...,n */
+
+/* ( x(i) ) := ( c(i) s(i) ) ( x(i) ) */
+/* ( y(i) ) ( -conjg(s(i)) c(i) ) ( y(i) ) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of plane rotations to be applied. */
+
+/* X (input/output) COMPLEX array, dimension (1+(N-1)*INCX) */
+/* The vector x. */
+
+/* INCX (input) INTEGER */
+/* The increment between elements of X. INCX > 0. */
+
+/* Y (input/output) COMPLEX array, dimension (1+(N-1)*INCY) */
+/* The vector y. */
+
+/* INCY (input) INTEGER */
+/* The increment between elements of Y. INCY > 0. */
+
+/* C (input) REAL array, dimension (1+(N-1)*INCC) */
+/* The cosines of the plane rotations. */
+
+/* S (input) COMPLEX array, dimension (1+(N-1)*INCC) */
+/* The sines of the plane rotations. */
+
+/* INCC (input) INTEGER */
+/* The increment between elements of C and S. INCC > 0. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --s;
+ --c__;
+ --y;
+ --x;
+
+ /* Function Body */
+ ix = 1;
+ iy = 1;
+ ic = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ix;
+ xi.r = x[i__2].r, xi.i = x[i__2].i;
+ i__2 = iy;
+ yi.r = y[i__2].r, yi.i = y[i__2].i;
+ i__2 = ix;
+ i__3 = ic;
+ q__2.r = c__[i__3] * xi.r, q__2.i = c__[i__3] * xi.i;
+ i__4 = ic;
+ q__3.r = s[i__4].r * yi.r - s[i__4].i * yi.i, q__3.i = s[i__4].r *
+ yi.i + s[i__4].i * yi.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ i__2 = iy;
+ i__3 = ic;
+ q__2.r = c__[i__3] * yi.r, q__2.i = c__[i__3] * yi.i;
+ r_cnjg(&q__4, &s[ic]);
+ q__3.r = q__4.r * xi.r - q__4.i * xi.i, q__3.i = q__4.r * xi.i +
+ q__4.i * xi.r;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ ix += *incx;
+ iy += *incy;
+ ic += *incc;
+/* L10: */
+ }
+ return 0;
+
+/* End of CLARTV */
+
+} /* clartv_ */
diff --git a/SRC/clarz.c b/SRC/clarz.c
new file mode 100644
index 0000000..5050cf5
--- /dev/null
+++ b/SRC/clarz.c
@@ -0,0 +1,198 @@
+/* clarz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int clarz_(char *side, integer *m, integer *n, integer *l,
+ complex *v, integer *incv, complex *tau, complex *c__, integer *ldc,
+ complex *work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset;
+ complex q__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *),
+ cgemv_(char *, integer *, integer *, complex *, complex *,
+ integer *, complex *, integer *, complex *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cgeru_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *),
+ ccopy_(integer *, complex *, integer *, complex *, integer *),
+ caxpy_(integer *, complex *, complex *, integer *, complex *,
+ integer *), clacgv_(integer *, complex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLARZ applies a complex elementary reflector H to a complex */
+/* M-by-N matrix C, from either the left or the right. H is represented */
+/* in the form */
+
+/* H = I - tau * v * v' */
+
+/* where tau is a complex scalar and v is a complex vector. */
+
+/* If tau = 0, then H is taken to be the unit matrix. */
+
+/* To apply H' (the conjugate transpose of H), supply conjg(tau) instead */
+/* tau. */
+
+/* H is a product of k elementary reflectors as returned by CTZRZF. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': form H * C */
+/* = 'R': form C * H */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* L (input) INTEGER */
+/* The number of entries of the vector V containing */
+/* the meaningful part of the Householder vectors. */
+/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */
+
+/* V (input) COMPLEX array, dimension (1+(L-1)*abs(INCV)) */
+/* The vector v in the representation of H as returned by */
+/* CTZRZF. V is not used if TAU = 0. */
+
+/* INCV (input) INTEGER */
+/* The increment between elements of v. INCV <> 0. */
+
+/* TAU (input) COMPLEX */
+/* The value tau in the representation of H. */
+
+/* C (input/output) COMPLEX array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
+/* or C * H if SIDE = 'R'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (N) if SIDE = 'L' */
+/* or (M) if SIDE = 'R' */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ if (lsame_(side, "L")) {
+
+/* Form H * C */
+
+ if (tau->r != 0.f || tau->i != 0.f) {
+
+/* w( 1:n ) = conjg( C( 1, 1:n ) ) */
+
+ ccopy_(n, &c__[c_offset], ldc, &work[1], &c__1);
+ clacgv_(n, &work[1], &c__1);
+
+/* w( 1:n ) = conjg( w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l ) ) */
+
+ cgemv_("Conjugate transpose", l, n, &c_b1, &c__[*m - *l + 1 +
+ c_dim1], ldc, &v[1], incv, &c_b1, &work[1], &c__1);
+ clacgv_(n, &work[1], &c__1);
+
+/* C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n ) */
+
+ q__1.r = -tau->r, q__1.i = -tau->i;
+ caxpy_(n, &q__1, &work[1], &c__1, &c__[c_offset], ldc);
+
+/* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... */
+/* tau * v( 1:l ) * conjg( w( 1:n )' ) */
+
+ q__1.r = -tau->r, q__1.i = -tau->i;
+ cgeru_(l, n, &q__1, &v[1], incv, &work[1], &c__1, &c__[*m - *l +
+ 1 + c_dim1], ldc);
+ }
+
+ } else {
+
+/* Form C * H */
+
+ if (tau->r != 0.f || tau->i != 0.f) {
+
+/* w( 1:m ) = C( 1:m, 1 ) */
+
+ ccopy_(m, &c__[c_offset], &c__1, &work[1], &c__1);
+
+/* w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l ) */
+
+ cgemv_("No transpose", m, l, &c_b1, &c__[(*n - *l + 1) * c_dim1 +
+ 1], ldc, &v[1], incv, &c_b1, &work[1], &c__1);
+
+/* C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m ) */
+
+ q__1.r = -tau->r, q__1.i = -tau->i;
+ caxpy_(m, &q__1, &work[1], &c__1, &c__[c_offset], &c__1);
+
+/* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... */
+/* tau * w( 1:m ) * v( 1:l )' */
+
+ q__1.r = -tau->r, q__1.i = -tau->i;
+ cgerc_(m, l, &q__1, &work[1], &c__1, &v[1], incv, &c__[(*n - *l +
+ 1) * c_dim1 + 1], ldc);
+
+ }
+
+ }
+
+ return 0;
+
+/* End of CLARZ */
+
+} /* clarz_ */
diff --git a/SRC/clarzb.c b/SRC/clarzb.c
new file mode 100644
index 0000000..8861dc6
--- /dev/null
+++ b/SRC/clarzb.c
@@ -0,0 +1,323 @@
+/* clarzb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int clarzb_(char *side, char *trans, char *direct, char *
+ storev, integer *m, integer *n, integer *k, integer *l, complex *v,
+ integer *ldv, complex *t, integer *ldt, complex *c__, integer *ldc,
+ complex *work, integer *ldwork)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1,
+ work_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j, info;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), ctrmm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *), clacgv_(integer *,
+ complex *, integer *), xerbla_(char *, integer *);
+ char transt[1];
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLARZB applies a complex block reflector H or its transpose H**H */
+/* to a complex distributed M-by-N C from the left or the right. */
+
+/* Currently, only STOREV = 'R' and DIRECT = 'B' are supported. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply H or H' from the Left */
+/* = 'R': apply H or H' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply H (No transpose) */
+/* = 'C': apply H' (Conjugate transpose) */
+
+/* DIRECT (input) CHARACTER*1 */
+/* Indicates how H is formed from a product of elementary */
+/* reflectors */
+/* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet) */
+/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
+
+/* STOREV (input) CHARACTER*1 */
+/* Indicates how the vectors which define the elementary */
+/* reflectors are stored: */
+/* = 'C': Columnwise (not supported yet) */
+/* = 'R': Rowwise */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* K (input) INTEGER */
+/* The order of the matrix T (= the number of elementary */
+/* reflectors whose product defines the block reflector). */
+
+/* L (input) INTEGER */
+/* The number of columns of the matrix V containing the */
+/* meaningful part of the Householder reflectors. */
+/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */
+
+/* V (input) COMPLEX array, dimension (LDV,NV). */
+/* If STOREV = 'C', NV = K; if STOREV = 'R', NV = L. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. */
+/* If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K. */
+
+/* T (input) COMPLEX array, dimension (LDT,K) */
+/* The triangular K-by-K matrix T in the representation of the */
+/* block reflector. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= K. */
+
+/* C (input/output) COMPLEX array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) COMPLEX array, dimension (LDWORK,K) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. */
+/* If SIDE = 'L', LDWORK >= max(1,N); */
+/* if SIDE = 'R', LDWORK >= max(1,M). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+/* Check for currently supported options */
+
+ info = 0;
+ if (! lsame_(direct, "B")) {
+ info = -3;
+ } else if (! lsame_(storev, "R")) {
+ info = -4;
+ }
+ if (info != 0) {
+ i__1 = -info;
+ xerbla_("CLARZB", &i__1);
+ return 0;
+ }
+
+ if (lsame_(trans, "N")) {
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+ if (lsame_(side, "L")) {
+
+/* Form H * C or H' * C */
+
+/* W( 1:n, 1:k ) = conjg( C( 1:k, 1:n )' ) */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1);
+/* L10: */
+ }
+
+/* W( 1:n, 1:k ) = W( 1:n, 1:k ) + ... */
+/* conjg( C( m-l+1:m, 1:n )' ) * V( 1:k, 1:l )' */
+
+ if (*l > 0) {
+ cgemm_("Transpose", "Conjugate transpose", n, k, l, &c_b1, &c__[*
+ m - *l + 1 + c_dim1], ldc, &v[v_offset], ldv, &c_b1, &
+ work[work_offset], ldwork);
+ }
+
+/* W( 1:n, 1:k ) = W( 1:n, 1:k ) * T' or W( 1:m, 1:k ) * T */
+
+ ctrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b1, &t[t_offset]
+, ldt, &work[work_offset], ldwork);
+
+/* C( 1:k, 1:n ) = C( 1:k, 1:n ) - conjg( W( 1:n, 1:k )' ) */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *k;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = j + i__ * work_dim1;
+ q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[i__4].i -
+ work[i__5].i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... */
+/* conjg( V( 1:k, 1:l )' ) * conjg( W( 1:n, 1:k )' ) */
+
+ if (*l > 0) {
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("Transpose", "Transpose", l, n, k, &q__1, &v[v_offset],
+ ldv, &work[work_offset], ldwork, &c_b1, &c__[*m - *l + 1
+ + c_dim1], ldc);
+ }
+
+ } else if (lsame_(side, "R")) {
+
+/* Form C * H or C * H' */
+
+/* W( 1:m, 1:k ) = C( 1:m, 1:k ) */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &
+ c__1);
+/* L40: */
+ }
+
+/* W( 1:m, 1:k ) = W( 1:m, 1:k ) + ... */
+/* C( 1:m, n-l+1:n ) * conjg( V( 1:k, 1:l )' ) */
+
+ if (*l > 0) {
+ cgemm_("No transpose", "Transpose", m, k, l, &c_b1, &c__[(*n - *l
+ + 1) * c_dim1 + 1], ldc, &v[v_offset], ldv, &c_b1, &work[
+ work_offset], ldwork);
+ }
+
+/* W( 1:m, 1:k ) = W( 1:m, 1:k ) * conjg( T ) or */
+/* W( 1:m, 1:k ) * conjg( T' ) */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *k - j + 1;
+ clacgv_(&i__2, &t[j + j * t_dim1], &c__1);
+/* L50: */
+ }
+ ctrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b1, &t[t_offset],
+ ldt, &work[work_offset], ldwork);
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *k - j + 1;
+ clacgv_(&i__2, &t[j + j * t_dim1], &c__1);
+/* L60: */
+ }
+
+/* C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k ) */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * work_dim1;
+ q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[i__4].i -
+ work[i__5].i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+
+/* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... */
+/* W( 1:m, 1:k ) * conjg( V( 1:k, 1:l ) ) */
+
+ i__1 = *l;
+ for (j = 1; j <= i__1; ++j) {
+ clacgv_(k, &v[j * v_dim1 + 1], &c__1);
+/* L90: */
+ }
+ if (*l > 0) {
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "No transpose", m, l, k, &q__1, &work[
+ work_offset], ldwork, &v[v_offset], ldv, &c_b1, &c__[(*n
+ - *l + 1) * c_dim1 + 1], ldc);
+ }
+ i__1 = *l;
+ for (j = 1; j <= i__1; ++j) {
+ clacgv_(k, &v[j * v_dim1 + 1], &c__1);
+/* L100: */
+ }
+
+ }
+
+ return 0;
+
+/* End of CLARZB */
+
+} /* clarzb_ */
diff --git a/SRC/clarzt.c b/SRC/clarzt.c
new file mode 100644
index 0000000..8287e70
--- /dev/null
+++ b/SRC/clarzt.c
@@ -0,0 +1,236 @@
+/* clarzt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int clarzt_(char *direct, char *storev, integer *n, integer *
+ k, complex *v, integer *ldv, complex *tau, complex *t, integer *ldt)
+{
+ /* System generated locals */
+ integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j, info;
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
+ complex *, integer *, complex *, integer *), clacgv_(integer *, complex *, integer *), xerbla_(char *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLARZT forms the triangular factor T of a complex block reflector */
+/* H of order > n, which is defined as a product of k elementary */
+/* reflectors. */
+
+/* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */
+
+/* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */
+
+/* If STOREV = 'C', the vector which defines the elementary reflector */
+/* H(i) is stored in the i-th column of the array V, and */
+
+/* H = I - V * T * V' */
+
+/* If STOREV = 'R', the vector which defines the elementary reflector */
+/* H(i) is stored in the i-th row of the array V, and */
+
+/* H = I - V' * T * V */
+
+/* Currently, only STOREV = 'R' and DIRECT = 'B' are supported. */
+
+/* Arguments */
+/* ========= */
+
+/* DIRECT (input) CHARACTER*1 */
+/* Specifies the order in which the elementary reflectors are */
+/* multiplied to form the block reflector: */
+/* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet) */
+/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
+
+/* STOREV (input) CHARACTER*1 */
+/* Specifies how the vectors which define the elementary */
+/* reflectors are stored (see also Further Details): */
+/* = 'C': columnwise (not supported yet) */
+/* = 'R': rowwise */
+
+/* N (input) INTEGER */
+/* The order of the block reflector H. N >= 0. */
+
+/* K (input) INTEGER */
+/* The order of the triangular factor T (= the number of */
+/* elementary reflectors). K >= 1. */
+
+/* V (input/output) COMPLEX array, dimension */
+/* (LDV,K) if STOREV = 'C' */
+/* (LDV,N) if STOREV = 'R' */
+/* The matrix V. See further details. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. */
+/* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */
+
+/* TAU (input) COMPLEX array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i). */
+
+/* T (output) COMPLEX array, dimension (LDT,K) */
+/* The k by k triangular factor T of the block reflector. */
+/* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */
+/* lower triangular. The rest of the array is not used. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= K. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* The shape of the matrix V and the storage of the vectors which define */
+/* the H(i) is best illustrated by the following example with n = 5 and */
+/* k = 3. The elements equal to 1 are not stored; the corresponding */
+/* array elements are modified but restored on exit. The rest of the */
+/* array is not used. */
+
+/* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */
+
+/* ______V_____ */
+/* ( v1 v2 v3 ) / \ */
+/* ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 ) */
+/* V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 ) */
+/* ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 ) */
+/* ( v1 v2 v3 ) */
+/* . . . */
+/* . . . */
+/* 1 . . */
+/* 1 . */
+/* 1 */
+
+/* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */
+
+/* ______V_____ */
+/* 1 / \ */
+/* . 1 ( 1 . . . . v1 v1 v1 v1 v1 ) */
+/* . . 1 ( . 1 . . . v2 v2 v2 v2 v2 ) */
+/* . . . ( . . 1 . . v3 v3 v3 v3 v3 ) */
+/* . . . */
+/* ( v1 v2 v3 ) */
+/* ( v1 v2 v3 ) */
+/* V = ( v1 v2 v3 ) */
+/* ( v1 v2 v3 ) */
+/* ( v1 v2 v3 ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for currently supported options */
+
+ /* Parameter adjustments */
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --tau;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(direct, "B")) {
+ info = -1;
+ } else if (! lsame_(storev, "R")) {
+ info = -2;
+ }
+ if (info != 0) {
+ i__1 = -info;
+ xerbla_("CLARZT", &i__1);
+ return 0;
+ }
+
+ for (i__ = *k; i__ >= 1; --i__) {
+ i__1 = i__;
+ if (tau[i__1].r == 0.f && tau[i__1].i == 0.f) {
+
+/* H(i) = I */
+
+ i__1 = *k;
+ for (j = i__; j <= i__1; ++j) {
+ i__2 = j + i__ * t_dim1;
+ t[i__2].r = 0.f, t[i__2].i = 0.f;
+/* L10: */
+ }
+ } else {
+
+/* general case */
+
+ if (i__ < *k) {
+
+/* T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)' */
+
+ clacgv_(n, &v[i__ + v_dim1], ldv);
+ i__1 = *k - i__;
+ i__2 = i__;
+ q__1.r = -tau[i__2].r, q__1.i = -tau[i__2].i;
+ cgemv_("No transpose", &i__1, n, &q__1, &v[i__ + 1 + v_dim1],
+ ldv, &v[i__ + v_dim1], ldv, &c_b1, &t[i__ + 1 + i__ *
+ t_dim1], &c__1);
+ clacgv_(n, &v[i__ + v_dim1], ldv);
+
+/* T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i) */
+
+ i__1 = *k - i__;
+ ctrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ + 1
+ + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * t_dim1]
+, &c__1);
+ }
+ i__1 = i__ + i__ * t_dim1;
+ i__2 = i__;
+ t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i;
+ }
+/* L20: */
+ }
+ return 0;
+
+/* End of CLARZT */
+
+} /* clarzt_ */
diff --git a/SRC/clascl.c b/SRC/clascl.c
new file mode 100644
index 0000000..ca01694
--- /dev/null
+++ b/SRC/clascl.c
@@ -0,0 +1,377 @@
+/* clascl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int clascl_(char *type__, integer *kl, integer *ku, real *
+ cfrom, real *cto, integer *m, integer *n, complex *a, integer *lda,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j, k1, k2, k3, k4;
+ real mul, cto1;
+ logical done;
+ real ctoc;
+ extern logical lsame_(char *, char *);
+ integer itype;
+ real cfrom1;
+ extern doublereal slamch_(char *);
+ real cfromc;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ extern logical sisnan_(real *);
+ real smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLASCL multiplies the M by N complex matrix A by the real scalar */
+/* CTO/CFROM. This is done without over/underflow as long as the final */
+/* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that */
+/* A may be full, upper triangular, lower triangular, upper Hessenberg, */
+/* or banded. */
+
+/* Arguments */
+/* ========= */
+
+/* TYPE (input) CHARACTER*1 */
+/* TYPE indices the storage type of the input matrix. */
+/* = 'G': A is a full matrix. */
+/* = 'L': A is a lower triangular matrix. */
+/* = 'U': A is an upper triangular matrix. */
+/* = 'H': A is an upper Hessenberg matrix. */
+/* = 'B': A is a symmetric band matrix with lower bandwidth KL */
+/* and upper bandwidth KU and with the only the lower */
+/* half stored. */
+/* = 'Q': A is a symmetric band matrix with lower bandwidth KL */
+/* and upper bandwidth KU and with the only the upper */
+/* half stored. */
+/* = 'Z': A is a band matrix with lower bandwidth KL and upper */
+/* bandwidth KU. */
+
+/* KL (input) INTEGER */
+/* The lower bandwidth of A. Referenced only if TYPE = 'B', */
+/* 'Q' or 'Z'. */
+
+/* KU (input) INTEGER */
+/* The upper bandwidth of A. Referenced only if TYPE = 'B', */
+/* 'Q' or 'Z'. */
+
+/* CFROM (input) REAL */
+/* CTO (input) REAL */
+/* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed */
+/* without over/underflow if the final result CTO*A(I,J)/CFROM */
+/* can be represented without over/underflow. CFROM must be */
+/* nonzero. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* The matrix to be multiplied by CTO/CFROM. See TYPE for the */
+/* storage type. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* INFO (output) INTEGER */
+/* 0 - successful exit */
+/* <0 - if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+
+ if (lsame_(type__, "G")) {
+ itype = 0;
+ } else if (lsame_(type__, "L")) {
+ itype = 1;
+ } else if (lsame_(type__, "U")) {
+ itype = 2;
+ } else if (lsame_(type__, "H")) {
+ itype = 3;
+ } else if (lsame_(type__, "B")) {
+ itype = 4;
+ } else if (lsame_(type__, "Q")) {
+ itype = 5;
+ } else if (lsame_(type__, "Z")) {
+ itype = 6;
+ } else {
+ itype = -1;
+ }
+
+ if (itype == -1) {
+ *info = -1;
+ } else if (*cfrom == 0.f || sisnan_(cfrom)) {
+ *info = -4;
+ } else if (sisnan_(cto)) {
+ *info = -5;
+ } else if (*m < 0) {
+ *info = -6;
+ } else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) {
+ *info = -7;
+ } else if (itype <= 3 && *lda < max(1,*m)) {
+ *info = -9;
+ } else if (itype >= 4) {
+/* Computing MAX */
+ i__1 = *m - 1;
+ if (*kl < 0 || *kl > max(i__1,0)) {
+ *info = -2;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = *n - 1;
+ if (*ku < 0 || *ku > max(i__1,0) || (itype == 4 || itype == 5) &&
+ *kl != *ku) {
+ *info = -3;
+ } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < *
+ ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) {
+ *info = -9;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLASCL", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *m == 0) {
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+
+ cfromc = *cfrom;
+ ctoc = *cto;
+
+L10:
+ cfrom1 = cfromc * smlnum;
+ if (cfrom1 == cfromc) {
+/* CFROMC is an inf. Multiply by a correctly signed zero for */
+/* finite CTOC, or a NaN if CTOC is infinite. */
+ mul = ctoc / cfromc;
+ done = TRUE_;
+ cto1 = ctoc;
+ } else {
+ cto1 = ctoc / bignum;
+ if (cto1 == ctoc) {
+/* CTOC is either 0 or an inf. In both cases, CTOC itself */
+/* serves as the correct multiplication factor. */
+ mul = ctoc;
+ done = TRUE_;
+ cfromc = 1.f;
+ } else if (dabs(cfrom1) > dabs(ctoc) && ctoc != 0.f) {
+ mul = smlnum;
+ done = FALSE_;
+ cfromc = cfrom1;
+ } else if (dabs(cto1) > dabs(cfromc)) {
+ mul = bignum;
+ done = FALSE_;
+ ctoc = cto1;
+ } else {
+ mul = ctoc / cfromc;
+ done = TRUE_;
+ }
+ }
+
+ if (itype == 0) {
+
+/* Full matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ q__1.r = mul * a[i__4].r, q__1.i = mul * a[i__4].i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L20: */
+ }
+/* L30: */
+ }
+
+ } else if (itype == 1) {
+
+/* Lower triangular matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ q__1.r = mul * a[i__4].r, q__1.i = mul * a[i__4].i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L40: */
+ }
+/* L50: */
+ }
+
+ } else if (itype == 2) {
+
+/* Upper triangular matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(j,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ q__1.r = mul * a[i__4].r, q__1.i = mul * a[i__4].i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L60: */
+ }
+/* L70: */
+ }
+
+ } else if (itype == 3) {
+
+/* Upper Hessenberg matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j + 1;
+ i__2 = min(i__3,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ q__1.r = mul * a[i__4].r, q__1.i = mul * a[i__4].i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L80: */
+ }
+/* L90: */
+ }
+
+ } else if (itype == 4) {
+
+/* Lower half of a symmetric band matrix */
+
+ k3 = *kl + 1;
+ k4 = *n + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = k3, i__4 = k4 - j;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ q__1.r = mul * a[i__4].r, q__1.i = mul * a[i__4].i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L100: */
+ }
+/* L110: */
+ }
+
+ } else if (itype == 5) {
+
+/* Upper half of a symmetric band matrix */
+
+ k1 = *ku + 2;
+ k3 = *ku + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = k1 - j;
+ i__3 = k3;
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+ i__2 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ q__1.r = mul * a[i__4].r, q__1.i = mul * a[i__4].i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L120: */
+ }
+/* L130: */
+ }
+
+ } else if (itype == 6) {
+
+/* Band matrix */
+
+ k1 = *kl + *ku + 2;
+ k2 = *kl + 1;
+ k3 = (*kl << 1) + *ku + 1;
+ k4 = *kl + *ku + 1 + *m;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__3 = k1 - j;
+/* Computing MIN */
+ i__4 = k3, i__5 = k4 - j;
+ i__2 = min(i__4,i__5);
+ for (i__ = max(i__3,k2); i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ q__1.r = mul * a[i__4].r, q__1.i = mul * a[i__4].i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L140: */
+ }
+/* L150: */
+ }
+
+ }
+
+ if (! done) {
+ goto L10;
+ }
+
+ return 0;
+
+/* End of CLASCL */
+
+} /* clascl_ */
diff --git a/SRC/clascl2.c b/SRC/clascl2.c
new file mode 100644
index 0000000..f1980c3
--- /dev/null
+++ b/SRC/clascl2.c
@@ -0,0 +1,95 @@
+/* clascl2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int clascl2_(integer *m, integer *n, real *d__, complex *x,
+ integer *ldx)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLASCL2 performs a diagonal scaling on a vector: */
+/* x <-- D * x */
+/* where the diagonal REAL matrix D is stored as a vector. */
+
+/* Eventually to be replaced by BLAS_cge_diag_scale in the new BLAS */
+/* standard. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of D and X. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of D and X. N >= 0. */
+
+/* D (input) REAL array, length M */
+/* Diagonal matrix D, stored as a vector of length M. */
+
+/* X (input/output) COMPLEX array, dimension (LDX,N) */
+/* On entry, the vector X to be scaled by D. */
+/* On exit, the scaled vector. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the vector X. LDX >= 0. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --d__;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+
+ /* Function Body */
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * x_dim1;
+ i__5 = i__;
+ q__1.r = d__[i__5] * x[i__4].r, q__1.i = d__[i__5] * x[i__4].i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ }
+ }
+ return 0;
+} /* clascl2_ */
diff --git a/SRC/claset.c b/SRC/claset.c
new file mode 100644
index 0000000..ea011e4
--- /dev/null
+++ b/SRC/claset.c
@@ -0,0 +1,162 @@
+/* claset.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int claset_(char *uplo, integer *m, integer *n, complex *
+ alpha, complex *beta, complex *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j;
+ extern logical lsame_(char *, char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLASET initializes a 2-D array A to BETA on the diagonal and */
+/* ALPHA on the offdiagonals. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies the part of the matrix A to be set. */
+/* = 'U': Upper triangular part is set. The lower triangle */
+/* is unchanged. */
+/* = 'L': Lower triangular part is set. The upper triangle */
+/* is unchanged. */
+/* Otherwise: All of the matrix A is set. */
+
+/* M (input) INTEGER */
+/* On entry, M specifies the number of rows of A. */
+
+/* N (input) INTEGER */
+/* On entry, N specifies the number of columns of A. */
+
+/* ALPHA (input) COMPLEX */
+/* All the offdiagonal array elements are set to ALPHA. */
+
+/* BETA (input) COMPLEX */
+/* All the diagonal array elements are set to BETA. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the m by n matrix A. */
+/* On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j; */
+/* A(i,i) = BETA , 1 <= i <= min(m,n) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ if (lsame_(uplo, "U")) {
+
+/* Set the diagonal to BETA and the strictly upper triangular */
+/* part of the array to ALPHA. */
+
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j - 1;
+ i__2 = min(i__3,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = alpha->r, a[i__3].i = alpha->i;
+/* L10: */
+ }
+/* L20: */
+ }
+ i__1 = min(*n,*m);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = beta->r, a[i__2].i = beta->i;
+/* L30: */
+ }
+
+ } else if (lsame_(uplo, "L")) {
+
+/* Set the diagonal to BETA and the strictly lower triangular */
+/* part of the array to ALPHA. */
+
+ i__1 = min(*m,*n);
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = alpha->r, a[i__3].i = alpha->i;
+/* L40: */
+ }
+/* L50: */
+ }
+ i__1 = min(*n,*m);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = beta->r, a[i__2].i = beta->i;
+/* L60: */
+ }
+
+ } else {
+
+/* Set the array to BETA on the diagonal and ALPHA on the */
+/* offdiagonal. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = alpha->r, a[i__3].i = alpha->i;
+/* L70: */
+ }
+/* L80: */
+ }
+ i__1 = min(*m,*n);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = beta->r, a[i__2].i = beta->i;
+/* L90: */
+ }
+ }
+
+ return 0;
+
+/* End of CLASET */
+
+} /* claset_ */
diff --git a/SRC/clasr.c b/SRC/clasr.c
new file mode 100644
index 0000000..4f12a7f
--- /dev/null
+++ b/SRC/clasr.c
@@ -0,0 +1,609 @@
+/* clasr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int clasr_(char *side, char *pivot, char *direct, integer *m,
+ integer *n, real *c__, real *s, complex *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ complex q__1, q__2, q__3;
+
+ /* Local variables */
+ integer i__, j, info;
+ complex temp;
+ extern logical lsame_(char *, char *);
+ real ctemp, stemp;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLASR applies a sequence of real plane rotations to a complex matrix */
+/* A, from either the left or the right. */
+
+/* When SIDE = 'L', the transformation takes the form */
+
+/* A := P*A */
+
+/* and when SIDE = 'R', the transformation takes the form */
+
+/* A := A*P**T */
+
+/* where P is an orthogonal matrix consisting of a sequence of z plane */
+/* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', */
+/* and P**T is the transpose of P. */
+
+/* When DIRECT = 'F' (Forward sequence), then */
+
+/* P = P(z-1) * ... * P(2) * P(1) */
+
+/* and when DIRECT = 'B' (Backward sequence), then */
+
+/* P = P(1) * P(2) * ... * P(z-1) */
+
+/* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation */
+
+/* R(k) = ( c(k) s(k) ) */
+/* = ( -s(k) c(k) ). */
+
+/* When PIVOT = 'V' (Variable pivot), the rotation is performed */
+/* for the plane (k,k+1), i.e., P(k) has the form */
+
+/* P(k) = ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+/* ( c(k) s(k) ) */
+/* ( -s(k) c(k) ) */
+/* ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+
+/* where R(k) appears as a rank-2 modification to the identity matrix in */
+/* rows and columns k and k+1. */
+
+/* When PIVOT = 'T' (Top pivot), the rotation is performed for the */
+/* plane (1,k+1), so P(k) has the form */
+
+/* P(k) = ( c(k) s(k) ) */
+/* ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+/* ( -s(k) c(k) ) */
+/* ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+
+/* where R(k) appears in rows and columns 1 and k+1. */
+
+/* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is */
+/* performed for the plane (k,z), giving P(k) the form */
+
+/* P(k) = ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+/* ( c(k) s(k) ) */
+/* ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+/* ( -s(k) c(k) ) */
+
+/* where R(k) appears in rows and columns k and z. The rotations are */
+/* performed without ever forming P(k) explicitly. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* Specifies whether the plane rotation matrix P is applied to */
+/* A on the left or the right. */
+/* = 'L': Left, compute A := P*A */
+/* = 'R': Right, compute A:= A*P**T */
+
+/* PIVOT (input) CHARACTER*1 */
+/* Specifies the plane for which P(k) is a plane rotation */
+/* matrix. */
+/* = 'V': Variable pivot, the plane (k,k+1) */
+/* = 'T': Top pivot, the plane (1,k+1) */
+/* = 'B': Bottom pivot, the plane (k,z) */
+
+/* DIRECT (input) CHARACTER*1 */
+/* Specifies whether P is a forward or backward sequence of */
+/* plane rotations. */
+/* = 'F': Forward, P = P(z-1)*...*P(2)*P(1) */
+/* = 'B': Backward, P = P(1)*P(2)*...*P(z-1) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. If m <= 1, an immediate */
+/* return is effected. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. If n <= 1, an */
+/* immediate return is effected. */
+
+/* C (input) REAL array, dimension */
+/* (M-1) if SIDE = 'L' */
+/* (N-1) if SIDE = 'R' */
+/* The cosines c(k) of the plane rotations. */
+
+/* S (input) REAL array, dimension */
+/* (M-1) if SIDE = 'L' */
+/* (N-1) if SIDE = 'R' */
+/* The sines s(k) of the plane rotations. The 2-by-2 plane */
+/* rotation part of the matrix P(k), R(k), has the form */
+/* R(k) = ( c(k) s(k) ) */
+/* ( -s(k) c(k) ). */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* The M-by-N matrix A. On exit, A is overwritten by P*A if */
+/* SIDE = 'R' or by A*P**T if SIDE = 'L'. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ --c__;
+ --s;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ info = 0;
+ if (! (lsame_(side, "L") || lsame_(side, "R"))) {
+ info = 1;
+ } else if (! (lsame_(pivot, "V") || lsame_(pivot,
+ "T") || lsame_(pivot, "B"))) {
+ info = 2;
+ } else if (! (lsame_(direct, "F") || lsame_(direct,
+ "B"))) {
+ info = 3;
+ } else if (*m < 0) {
+ info = 4;
+ } else if (*n < 0) {
+ info = 5;
+ } else if (*lda < max(1,*m)) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("CLASR ", &info);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+ if (lsame_(side, "L")) {
+
+/* Form P * A */
+
+ if (lsame_(pivot, "V")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = j + 1 + i__ * a_dim1;
+ temp.r = a[i__3].r, temp.i = a[i__3].i;
+ i__3 = j + 1 + i__ * a_dim1;
+ q__2.r = ctemp * temp.r, q__2.i = ctemp * temp.i;
+ i__4 = j + i__ * a_dim1;
+ q__3.r = stemp * a[i__4].r, q__3.i = stemp * a[
+ i__4].i;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i -
+ q__3.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ i__3 = j + i__ * a_dim1;
+ q__2.r = stemp * temp.r, q__2.i = stemp * temp.i;
+ i__4 = j + i__ * a_dim1;
+ q__3.r = ctemp * a[i__4].r, q__3.i = ctemp * a[
+ i__4].i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
+ q__3.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L10: */
+ }
+ }
+/* L20: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *m - 1; j >= 1; --j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = j + 1 + i__ * a_dim1;
+ temp.r = a[i__2].r, temp.i = a[i__2].i;
+ i__2 = j + 1 + i__ * a_dim1;
+ q__2.r = ctemp * temp.r, q__2.i = ctemp * temp.i;
+ i__3 = j + i__ * a_dim1;
+ q__3.r = stemp * a[i__3].r, q__3.i = stemp * a[
+ i__3].i;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i -
+ q__3.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ i__2 = j + i__ * a_dim1;
+ q__2.r = stemp * temp.r, q__2.i = stemp * temp.i;
+ i__3 = j + i__ * a_dim1;
+ q__3.r = ctemp * a[i__3].r, q__3.i = ctemp * a[
+ i__3].i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
+ q__3.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L30: */
+ }
+ }
+/* L40: */
+ }
+ }
+ } else if (lsame_(pivot, "T")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *m;
+ for (j = 2; j <= i__1; ++j) {
+ ctemp = c__[j - 1];
+ stemp = s[j - 1];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * a_dim1;
+ temp.r = a[i__3].r, temp.i = a[i__3].i;
+ i__3 = j + i__ * a_dim1;
+ q__2.r = ctemp * temp.r, q__2.i = ctemp * temp.i;
+ i__4 = i__ * a_dim1 + 1;
+ q__3.r = stemp * a[i__4].r, q__3.i = stemp * a[
+ i__4].i;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i -
+ q__3.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ i__3 = i__ * a_dim1 + 1;
+ q__2.r = stemp * temp.r, q__2.i = stemp * temp.i;
+ i__4 = i__ * a_dim1 + 1;
+ q__3.r = ctemp * a[i__4].r, q__3.i = ctemp * a[
+ i__4].i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
+ q__3.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *m; j >= 2; --j) {
+ ctemp = c__[j - 1];
+ stemp = s[j - 1];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = j + i__ * a_dim1;
+ temp.r = a[i__2].r, temp.i = a[i__2].i;
+ i__2 = j + i__ * a_dim1;
+ q__2.r = ctemp * temp.r, q__2.i = ctemp * temp.i;
+ i__3 = i__ * a_dim1 + 1;
+ q__3.r = stemp * a[i__3].r, q__3.i = stemp * a[
+ i__3].i;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i -
+ q__3.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ i__2 = i__ * a_dim1 + 1;
+ q__2.r = stemp * temp.r, q__2.i = stemp * temp.i;
+ i__3 = i__ * a_dim1 + 1;
+ q__3.r = ctemp * a[i__3].r, q__3.i = ctemp * a[
+ i__3].i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
+ q__3.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L70: */
+ }
+ }
+/* L80: */
+ }
+ }
+ } else if (lsame_(pivot, "B")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * a_dim1;
+ temp.r = a[i__3].r, temp.i = a[i__3].i;
+ i__3 = j + i__ * a_dim1;
+ i__4 = *m + i__ * a_dim1;
+ q__2.r = stemp * a[i__4].r, q__2.i = stemp * a[
+ i__4].i;
+ q__3.r = ctemp * temp.r, q__3.i = ctemp * temp.i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
+ q__3.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ i__3 = *m + i__ * a_dim1;
+ i__4 = *m + i__ * a_dim1;
+ q__2.r = ctemp * a[i__4].r, q__2.i = ctemp * a[
+ i__4].i;
+ q__3.r = stemp * temp.r, q__3.i = stemp * temp.i;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i -
+ q__3.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L90: */
+ }
+ }
+/* L100: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *m - 1; j >= 1; --j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = j + i__ * a_dim1;
+ temp.r = a[i__2].r, temp.i = a[i__2].i;
+ i__2 = j + i__ * a_dim1;
+ i__3 = *m + i__ * a_dim1;
+ q__2.r = stemp * a[i__3].r, q__2.i = stemp * a[
+ i__3].i;
+ q__3.r = ctemp * temp.r, q__3.i = ctemp * temp.i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
+ q__3.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ i__2 = *m + i__ * a_dim1;
+ i__3 = *m + i__ * a_dim1;
+ q__2.r = ctemp * a[i__3].r, q__2.i = ctemp * a[
+ i__3].i;
+ q__3.r = stemp * temp.r, q__3.i = stemp * temp.i;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i -
+ q__3.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L110: */
+ }
+ }
+/* L120: */
+ }
+ }
+ }
+ } else if (lsame_(side, "R")) {
+
+/* Form A * P' */
+
+ if (lsame_(pivot, "V")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j + 1) * a_dim1;
+ temp.r = a[i__3].r, temp.i = a[i__3].i;
+ i__3 = i__ + (j + 1) * a_dim1;
+ q__2.r = ctemp * temp.r, q__2.i = ctemp * temp.i;
+ i__4 = i__ + j * a_dim1;
+ q__3.r = stemp * a[i__4].r, q__3.i = stemp * a[
+ i__4].i;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i -
+ q__3.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ i__3 = i__ + j * a_dim1;
+ q__2.r = stemp * temp.r, q__2.i = stemp * temp.i;
+ i__4 = i__ + j * a_dim1;
+ q__3.r = ctemp * a[i__4].r, q__3.i = ctemp * a[
+ i__4].i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
+ q__3.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L130: */
+ }
+ }
+/* L140: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *n - 1; j >= 1; --j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + (j + 1) * a_dim1;
+ temp.r = a[i__2].r, temp.i = a[i__2].i;
+ i__2 = i__ + (j + 1) * a_dim1;
+ q__2.r = ctemp * temp.r, q__2.i = ctemp * temp.i;
+ i__3 = i__ + j * a_dim1;
+ q__3.r = stemp * a[i__3].r, q__3.i = stemp * a[
+ i__3].i;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i -
+ q__3.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ i__2 = i__ + j * a_dim1;
+ q__2.r = stemp * temp.r, q__2.i = stemp * temp.i;
+ i__3 = i__ + j * a_dim1;
+ q__3.r = ctemp * a[i__3].r, q__3.i = ctemp * a[
+ i__3].i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
+ q__3.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L150: */
+ }
+ }
+/* L160: */
+ }
+ }
+ } else if (lsame_(pivot, "T")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ ctemp = c__[j - 1];
+ stemp = s[j - 1];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ temp.r = a[i__3].r, temp.i = a[i__3].i;
+ i__3 = i__ + j * a_dim1;
+ q__2.r = ctemp * temp.r, q__2.i = ctemp * temp.i;
+ i__4 = i__ + a_dim1;
+ q__3.r = stemp * a[i__4].r, q__3.i = stemp * a[
+ i__4].i;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i -
+ q__3.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ i__3 = i__ + a_dim1;
+ q__2.r = stemp * temp.r, q__2.i = stemp * temp.i;
+ i__4 = i__ + a_dim1;
+ q__3.r = ctemp * a[i__4].r, q__3.i = ctemp * a[
+ i__4].i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
+ q__3.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L170: */
+ }
+ }
+/* L180: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *n; j >= 2; --j) {
+ ctemp = c__[j - 1];
+ stemp = s[j - 1];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * a_dim1;
+ temp.r = a[i__2].r, temp.i = a[i__2].i;
+ i__2 = i__ + j * a_dim1;
+ q__2.r = ctemp * temp.r, q__2.i = ctemp * temp.i;
+ i__3 = i__ + a_dim1;
+ q__3.r = stemp * a[i__3].r, q__3.i = stemp * a[
+ i__3].i;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i -
+ q__3.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ i__2 = i__ + a_dim1;
+ q__2.r = stemp * temp.r, q__2.i = stemp * temp.i;
+ i__3 = i__ + a_dim1;
+ q__3.r = ctemp * a[i__3].r, q__3.i = ctemp * a[
+ i__3].i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
+ q__3.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L190: */
+ }
+ }
+/* L200: */
+ }
+ }
+ } else if (lsame_(pivot, "B")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ temp.r = a[i__3].r, temp.i = a[i__3].i;
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + *n * a_dim1;
+ q__2.r = stemp * a[i__4].r, q__2.i = stemp * a[
+ i__4].i;
+ q__3.r = ctemp * temp.r, q__3.i = ctemp * temp.i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
+ q__3.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ i__3 = i__ + *n * a_dim1;
+ i__4 = i__ + *n * a_dim1;
+ q__2.r = ctemp * a[i__4].r, q__2.i = ctemp * a[
+ i__4].i;
+ q__3.r = stemp * temp.r, q__3.i = stemp * temp.i;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i -
+ q__3.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L210: */
+ }
+ }
+/* L220: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *n - 1; j >= 1; --j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * a_dim1;
+ temp.r = a[i__2].r, temp.i = a[i__2].i;
+ i__2 = i__ + j * a_dim1;
+ i__3 = i__ + *n * a_dim1;
+ q__2.r = stemp * a[i__3].r, q__2.i = stemp * a[
+ i__3].i;
+ q__3.r = ctemp * temp.r, q__3.i = ctemp * temp.i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i +
+ q__3.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ i__2 = i__ + *n * a_dim1;
+ i__3 = i__ + *n * a_dim1;
+ q__2.r = ctemp * a[i__3].r, q__2.i = ctemp * a[
+ i__3].i;
+ q__3.r = stemp * temp.r, q__3.i = stemp * temp.i;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i -
+ q__3.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L230: */
+ }
+ }
+/* L240: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CLASR */
+
+} /* clasr_ */
diff --git a/SRC/classq.c b/SRC/classq.c
new file mode 100644
index 0000000..22e9b8c
--- /dev/null
+++ b/SRC/classq.c
@@ -0,0 +1,138 @@
+/* classq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int classq_(integer *n, complex *x, integer *incx, real *
+ scale, real *sumsq)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real r__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer ix;
+ real temp1;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLASSQ returns the values scl and ssq such that */
+
+/* ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, */
+
+/* where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is */
+/* assumed to be at least unity and the value of ssq will then satisfy */
+
+/* 1.0 .le. ssq .le. ( sumsq + 2*n ). */
+
+/* scale is assumed to be non-negative and scl returns the value */
+
+/* scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ), */
+/* i */
+
+/* scale and sumsq must be supplied in SCALE and SUMSQ respectively. */
+/* SCALE and SUMSQ are overwritten by scl and ssq respectively. */
+
+/* The routine makes only one pass through the vector X. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of elements to be used from the vector X. */
+
+/* X (input) COMPLEX array, dimension (N) */
+/* The vector x as described above. */
+/* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. */
+
+/* INCX (input) INTEGER */
+/* The increment between successive values of the vector X. */
+/* INCX > 0. */
+
+/* SCALE (input/output) REAL */
+/* On entry, the value scale in the equation above. */
+/* On exit, SCALE is overwritten with the value scl . */
+
+/* SUMSQ (input/output) REAL */
+/* On entry, the value sumsq in the equation above. */
+/* On exit, SUMSQ is overwritten with the value ssq . */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --x;
+
+ /* Function Body */
+ if (*n > 0) {
+ i__1 = (*n - 1) * *incx + 1;
+ i__2 = *incx;
+ for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
+ i__3 = ix;
+ if (x[i__3].r != 0.f) {
+ i__3 = ix;
+ temp1 = (r__1 = x[i__3].r, dabs(r__1));
+ if (*scale < temp1) {
+/* Computing 2nd power */
+ r__1 = *scale / temp1;
+ *sumsq = *sumsq * (r__1 * r__1) + 1;
+ *scale = temp1;
+ } else {
+/* Computing 2nd power */
+ r__1 = temp1 / *scale;
+ *sumsq += r__1 * r__1;
+ }
+ }
+ if (r_imag(&x[ix]) != 0.f) {
+ temp1 = (r__1 = r_imag(&x[ix]), dabs(r__1));
+ if (*scale < temp1) {
+/* Computing 2nd power */
+ r__1 = *scale / temp1;
+ *sumsq = *sumsq * (r__1 * r__1) + 1;
+ *scale = temp1;
+ } else {
+/* Computing 2nd power */
+ r__1 = temp1 / *scale;
+ *sumsq += r__1 * r__1;
+ }
+ }
+/* L10: */
+ }
+ }
+
+ return 0;
+
+/* End of CLASSQ */
+
+} /* classq_ */
diff --git a/SRC/claswp.c b/SRC/claswp.c
new file mode 100644
index 0000000..01566c7
--- /dev/null
+++ b/SRC/claswp.c
@@ -0,0 +1,166 @@
+/* claswp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int claswp_(integer *n, complex *a, integer *lda, integer *
+ k1, integer *k2, integer *ipiv, integer *incx)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+
+ /* Local variables */
+ integer i__, j, k, i1, i2, n32, ip, ix, ix0, inc;
+ complex temp;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLASWP performs a series of row interchanges on the matrix A. */
+/* One row interchange is initiated for each of rows K1 through K2 of A. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the matrix of column dimension N to which the row */
+/* interchanges will be applied. */
+/* On exit, the permuted matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* K1 (input) INTEGER */
+/* The first element of IPIV for which a row interchange will */
+/* be done. */
+
+/* K2 (input) INTEGER */
+/* The last element of IPIV for which a row interchange will */
+/* be done. */
+
+/* IPIV (input) INTEGER array, dimension (K2*abs(INCX)) */
+/* The vector of pivot indices. Only the elements in positions */
+/* K1 through K2 of IPIV are accessed. */
+/* IPIV(K) = L implies rows K and L are to be interchanged. */
+
+/* INCX (input) INTEGER */
+/* The increment between successive values of IPIV. If IPIV */
+/* is negative, the pivots are applied in reverse order. */
+
+/* Further Details */
+/* =============== */
+
+/* Modified by */
+/* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Interchange row I with row IPIV(I) for each of rows K1 through K2. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ if (*incx > 0) {
+ ix0 = *k1;
+ i1 = *k1;
+ i2 = *k2;
+ inc = 1;
+ } else if (*incx < 0) {
+ ix0 = (1 - *k2) * *incx + 1;
+ i1 = *k2;
+ i2 = *k1;
+ inc = -1;
+ } else {
+ return 0;
+ }
+
+ n32 = *n / 32 << 5;
+ if (n32 != 0) {
+ i__1 = n32;
+ for (j = 1; j <= i__1; j += 32) {
+ ix = ix0;
+ i__2 = i2;
+ i__3 = inc;
+ for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3)
+ {
+ ip = ipiv[ix];
+ if (ip != i__) {
+ i__4 = j + 31;
+ for (k = j; k <= i__4; ++k) {
+ i__5 = i__ + k * a_dim1;
+ temp.r = a[i__5].r, temp.i = a[i__5].i;
+ i__5 = i__ + k * a_dim1;
+ i__6 = ip + k * a_dim1;
+ a[i__5].r = a[i__6].r, a[i__5].i = a[i__6].i;
+ i__5 = ip + k * a_dim1;
+ a[i__5].r = temp.r, a[i__5].i = temp.i;
+/* L10: */
+ }
+ }
+ ix += *incx;
+/* L20: */
+ }
+/* L30: */
+ }
+ }
+ if (n32 != *n) {
+ ++n32;
+ ix = ix0;
+ i__1 = i2;
+ i__3 = inc;
+ for (i__ = i1; i__3 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__3) {
+ ip = ipiv[ix];
+ if (ip != i__) {
+ i__2 = *n;
+ for (k = n32; k <= i__2; ++k) {
+ i__4 = i__ + k * a_dim1;
+ temp.r = a[i__4].r, temp.i = a[i__4].i;
+ i__4 = i__ + k * a_dim1;
+ i__5 = ip + k * a_dim1;
+ a[i__4].r = a[i__5].r, a[i__4].i = a[i__5].i;
+ i__4 = ip + k * a_dim1;
+ a[i__4].r = temp.r, a[i__4].i = temp.i;
+/* L40: */
+ }
+ }
+ ix += *incx;
+/* L50: */
+ }
+ }
+
+ return 0;
+
+/* End of CLASWP */
+
+} /* claswp_ */
diff --git a/SRC/clasyf.c b/SRC/clasyf.c
new file mode 100644
index 0000000..3010bba
--- /dev/null
+++ b/SRC/clasyf.c
@@ -0,0 +1,829 @@
+/* clasyf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int clasyf_(char *uplo, integer *n, integer *nb, integer *kb,
+ complex *a, integer *lda, integer *ipiv, complex *w, integer *ldw,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_imag(complex *);
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer j, k;
+ complex t, r1, d11, d21, d22;
+ integer jb, jj, kk, jp, kp, kw, kkw, imax, jmax;
+ real alpha;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *), cgemm_(char *, char *, integer *, integer *, integer *
+, complex *, complex *, integer *, complex *, integer *, complex *
+, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *), ccopy_(integer *, complex *, integer *,
+ complex *, integer *), cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer kstep;
+ real absakk;
+ extern integer icamax_(integer *, complex *, integer *);
+ real colmax, rowmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLASYF computes a partial factorization of a complex symmetric matrix */
+/* A using the Bunch-Kaufman 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' U22' ) */
+
+/* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) 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. */
+/* Note that U' denotes the transpose of U. */
+
+/* CLASYF is an auxiliary routine called by CSYTRF. It uses blocked code */
+/* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or */
+/* A22 (if UPLO = 'L'). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NB (input) 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. */
+
+/* KB (output) INTEGER */
+/* The number of columns of A that were actually factored. */
+/* KB is either NB-1 or NB, or N if N <= NB. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n-by-n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n-by-n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+/* On exit, A contains details of the partial factorization. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If UPLO = 'U', only the last KB elements of IPIV are set; */
+/* if UPLO = 'L', only the first KB elements are set. */
+
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* W (workspace) COMPLEX array, dimension (LDW,NB) */
+
+/* LDW (input) INTEGER */
+/* The leading dimension of the array W. LDW >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* > 0: if INFO = k, D(k,k) is exactly zero. The factorization */
+/* has been completed, but the block diagonal matrix D is */
+/* exactly singular. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ w_dim1 = *ldw;
+ w_offset = 1 + w_dim1;
+ w -= w_offset;
+
+ /* Function Body */
+ *info = 0;
+
+/* Initialize ALPHA for use in choosing pivot block size. */
+
+ alpha = (sqrt(17.f) + 1.f) / 8.f;
+
+ if (lsame_(uplo, "U")) {
+
+/* 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 */
+
+/* K is the main loop index, decreasing from N in steps of 1 or 2 */
+
+/* KW is the column of W which corresponds to column K of A */
+
+ k = *n;
+L10:
+ kw = *nb + k - *n;
+
+/* Exit from loop */
+
+ if (k <= *n - *nb + 1 && *nb < *n || k < 1) {
+ goto L30;
+ }
+
+/* Copy column K of A to column KW of W and update it */
+
+ ccopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1);
+ if (k < *n) {
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) * a_dim1 + 1],
+ lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw *
+ w_dim1 + 1], &c__1);
+ }
+
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = k + kw * w_dim1;
+ absakk = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[k + kw *
+ w_dim1]), dabs(r__2));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ imax = icamax_(&i__1, &w[kw * w_dim1 + 1], &c__1);
+ i__1 = imax + kw * w_dim1;
+ colmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[imax
+ + kw * w_dim1]), dabs(r__2));
+ } else {
+ colmax = 0.f;
+ }
+
+ if (dmax(absakk,colmax) == 0.f) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* Copy column IMAX to column KW-1 of W and update it */
+
+ ccopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) *
+ w_dim1 + 1], &c__1);
+ i__1 = k - imax;
+ ccopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax +
+ 1 + (kw - 1) * w_dim1], &c__1);
+ if (k < *n) {
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &k, &i__1, &q__1, &a[(k + 1) *
+ a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1],
+ ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1);
+ }
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = k - imax;
+ jmax = imax + icamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1],
+ &c__1);
+ i__1 = jmax + (kw - 1) * w_dim1;
+ rowmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[
+ jmax + (kw - 1) * w_dim1]), dabs(r__2));
+ if (imax > 1) {
+ i__1 = imax - 1;
+ jmax = icamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__1 = jmax + (kw - 1) * w_dim1;
+ r__3 = rowmax, r__4 = (r__1 = w[i__1].r, dabs(r__1)) + (
+ r__2 = r_imag(&w[jmax + (kw - 1) * w_dim1]), dabs(
+ r__2));
+ rowmax = dmax(r__3,r__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = imax + (kw - 1) * w_dim1;
+ if ((r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[
+ imax + (kw - 1) * w_dim1]), dabs(r__2)) >= alpha *
+ rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+
+/* copy column KW-1 of W to column KW */
+
+ ccopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw *
+ w_dim1 + 1], &c__1);
+ } else {
+
+/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k - kstep + 1;
+ kkw = *nb + kk - *n;
+
+/* Updated column KP is already stored in column KKW of W */
+
+ if (kp != kk) {
+
+/* Copy non-updated column KK to column KP */
+
+ i__1 = kp + k * a_dim1;
+ i__2 = kk + k * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = k - 1 - kp;
+ ccopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp +
+ 1) * a_dim1], lda);
+ ccopy_(&kp, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &
+ c__1);
+
+/* Interchange rows KK and KP in last KK columns of A and W */
+
+ i__1 = *n - kk + 1;
+ cswap_(&i__1, &a[kk + kk * a_dim1], lda, &a[kp + kk * a_dim1],
+ lda);
+ i__1 = *n - kk + 1;
+ cswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw *
+ w_dim1], ldw);
+ }
+
+ if (kstep == 1) {
+
+/* 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 */
+
+ ccopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &
+ c__1);
+ c_div(&q__1, &c_b1, &a[k + k * a_dim1]);
+ r1.r = q__1.r, r1.i = q__1.i;
+ i__1 = k - 1;
+ cscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
+ } 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 > 2) {
+
+/* Store U(k) and U(k-1) in columns k and k-1 of A */
+
+ i__1 = k - 1 + kw * w_dim1;
+ d21.r = w[i__1].r, d21.i = w[i__1].i;
+ c_div(&q__1, &w[k + kw * w_dim1], &d21);
+ d11.r = q__1.r, d11.i = q__1.i;
+ c_div(&q__1, &w[k - 1 + (kw - 1) * w_dim1], &d21);
+ d22.r = q__1.r, d22.i = q__1.i;
+ q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r *
+ d22.i + d11.i * d22.r;
+ q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f;
+ c_div(&q__1, &c_b1, &q__2);
+ t.r = q__1.r, t.i = q__1.i;
+ c_div(&q__1, &t, &d21);
+ d21.r = q__1.r, d21.i = q__1.i;
+ i__1 = k - 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + (k - 1) * a_dim1;
+ i__3 = j + (kw - 1) * w_dim1;
+ q__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
+ q__3.i = d11.r * w[i__3].i + d11.i * w[i__3]
+ .r;
+ i__4 = j + kw * w_dim1;
+ q__2.r = q__3.r - w[i__4].r, q__2.i = q__3.i - w[i__4]
+ .i;
+ q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i =
+ d21.r * q__2.i + d21.i * q__2.r;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ i__2 = j + k * a_dim1;
+ i__3 = j + kw * w_dim1;
+ q__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
+ q__3.i = d22.r * w[i__3].i + d22.i * w[i__3]
+ .r;
+ i__4 = j + (kw - 1) * w_dim1;
+ q__2.r = q__3.r - w[i__4].r, q__2.i = q__3.i - w[i__4]
+ .i;
+ q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i =
+ d21.r * q__2.i + d21.i * q__2.r;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L20: */
+ }
+ }
+
+/* Copy D(k) to A */
+
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ i__2 = k - 1 + (kw - 1) * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+ i__1 = k - 1 + k * a_dim1;
+ i__2 = k - 1 + kw * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+ i__1 = k + k * a_dim1;
+ i__2 = k + kw * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k - 1] = -kp;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kstep;
+ goto L10;
+
+L30:
+
+/* Update the upper triangle of A11 (= A(1:k,1:k)) as */
+
+/* A11 := A11 - U12*D*U12' = A11 - U12*W' */
+
+/* computing blocks of NB columns at a time */
+
+ i__1 = -(*nb);
+ for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j +=
+ i__1) {
+/* Computing MIN */
+ i__2 = *nb, i__3 = k - j + 1;
+ jb = min(i__2,i__3);
+
+/* Update the upper triangle of the diagonal block */
+
+ i__2 = j + jb - 1;
+ for (jj = j; jj <= i__2; ++jj) {
+ i__3 = jj - j + 1;
+ i__4 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__3, &i__4, &q__1, &a[j + (k + 1) *
+ a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b1,
+ &a[j + jj * a_dim1], &c__1);
+/* L40: */
+ }
+
+/* Update the rectangular superdiagonal block */
+
+ i__2 = j - 1;
+ i__3 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &q__1, &a[(
+ k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * w_dim1], ldw,
+ &c_b1, &a[j * a_dim1 + 1], lda);
+/* L50: */
+ }
+
+/* Put U12 in standard form by partially undoing the interchanges */
+/* in columns k+1:n */
+
+ j = k + 1;
+L60:
+ jj = j;
+ jp = ipiv[j];
+ if (jp < 0) {
+ jp = -jp;
+ ++j;
+ }
+ ++j;
+ if (jp != jj && j <= *n) {
+ i__1 = *n - j + 1;
+ cswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda);
+ }
+ if (j <= *n) {
+ goto L60;
+ }
+
+/* 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 */
+
+/* K is the main loop index, increasing from 1 in steps of 1 or 2 */
+
+ k = 1;
+L70:
+
+/* Exit from loop */
+
+ if (k >= *nb && *nb < *n || k > *n) {
+ goto L90;
+ }
+
+/* Copy column K of A to column K of W and update it */
+
+ i__1 = *n - k + 1;
+ ccopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1);
+ i__1 = *n - k + 1;
+ i__2 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1], lda, &w[k
+ + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1);
+
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = k + k * w_dim1;
+ absakk = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[k + k *
+ w_dim1]), dabs(r__2));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ imax = k + icamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1);
+ i__1 = imax + k * w_dim1;
+ colmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[imax
+ + k * w_dim1]), dabs(r__2));
+ } else {
+ colmax = 0.f;
+ }
+
+ if (dmax(absakk,colmax) == 0.f) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* Copy column IMAX to column K+1 of W and update it */
+
+ i__1 = imax - k;
+ ccopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) *
+ w_dim1], &c__1);
+ i__1 = *n - imax + 1;
+ ccopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k +
+ 1) * w_dim1], &c__1);
+ i__1 = *n - k + 1;
+ i__2 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__1, &i__2, &q__1, &a[k + a_dim1],
+ lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + 1) *
+ w_dim1], &c__1);
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = imax - k;
+ jmax = k - 1 + icamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1)
+ ;
+ i__1 = jmax + (k + 1) * w_dim1;
+ rowmax = (r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[
+ jmax + (k + 1) * w_dim1]), dabs(r__2));
+ if (imax < *n) {
+ i__1 = *n - imax;
+ jmax = imax + icamax_(&i__1, &w[imax + 1 + (k + 1) *
+ w_dim1], &c__1);
+/* Computing MAX */
+ i__1 = jmax + (k + 1) * w_dim1;
+ r__3 = rowmax, r__4 = (r__1 = w[i__1].r, dabs(r__1)) + (
+ r__2 = r_imag(&w[jmax + (k + 1) * w_dim1]), dabs(
+ r__2));
+ rowmax = dmax(r__3,r__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = imax + (k + 1) * w_dim1;
+ if ((r__1 = w[i__1].r, dabs(r__1)) + (r__2 = r_imag(&w[
+ imax + (k + 1) * w_dim1]), dabs(r__2)) >= alpha *
+ rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+
+/* copy column K+1 of W to column K */
+
+ i__1 = *n - k + 1;
+ ccopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k +
+ k * w_dim1], &c__1);
+ } else {
+
+/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k + kstep - 1;
+
+/* Updated column KP is already stored in column KK of W */
+
+ if (kp != kk) {
+
+/* Copy non-updated column KK to column KP */
+
+ i__1 = kp + k * a_dim1;
+ i__2 = kk + k * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp - k - 1;
+ ccopy_(&i__1, &a[k + 1 + kk * a_dim1], &c__1, &a[kp + (k + 1)
+ * a_dim1], lda);
+ i__1 = *n - kp + 1;
+ ccopy_(&i__1, &a[kp + kk * a_dim1], &c__1, &a[kp + kp *
+ a_dim1], &c__1);
+
+/* Interchange rows KK and KP in first KK columns of A and W */
+
+ cswap_(&kk, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda);
+ cswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw);
+ }
+
+ if (kstep == 1) {
+
+/* 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 */
+
+ i__1 = *n - k + 1;
+ ccopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], &
+ c__1);
+ if (k < *n) {
+ c_div(&q__1, &c_b1, &a[k + k * a_dim1]);
+ r1.r = q__1.r, r1.i = q__1.i;
+ i__1 = *n - k;
+ cscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1);
+ }
+ } 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 < *n - 1) {
+
+/* Store L(k) and L(k+1) in columns k and k+1 of A */
+
+ i__1 = k + 1 + k * w_dim1;
+ d21.r = w[i__1].r, d21.i = w[i__1].i;
+ c_div(&q__1, &w[k + 1 + (k + 1) * w_dim1], &d21);
+ d11.r = q__1.r, d11.i = q__1.i;
+ c_div(&q__1, &w[k + k * w_dim1], &d21);
+ d22.r = q__1.r, d22.i = q__1.i;
+ q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r *
+ d22.i + d11.i * d22.r;
+ q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f;
+ c_div(&q__1, &c_b1, &q__2);
+ t.r = q__1.r, t.i = q__1.i;
+ c_div(&q__1, &t, &d21);
+ d21.r = q__1.r, d21.i = q__1.i;
+ i__1 = *n;
+ for (j = k + 2; j <= i__1; ++j) {
+ i__2 = j + k * a_dim1;
+ i__3 = j + k * w_dim1;
+ q__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
+ q__3.i = d11.r * w[i__3].i + d11.i * w[i__3]
+ .r;
+ i__4 = j + (k + 1) * w_dim1;
+ q__2.r = q__3.r - w[i__4].r, q__2.i = q__3.i - w[i__4]
+ .i;
+ q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i =
+ d21.r * q__2.i + d21.i * q__2.r;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ i__2 = j + (k + 1) * a_dim1;
+ i__3 = j + (k + 1) * w_dim1;
+ q__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
+ q__3.i = d22.r * w[i__3].i + d22.i * w[i__3]
+ .r;
+ i__4 = j + k * w_dim1;
+ q__2.r = q__3.r - w[i__4].r, q__2.i = q__3.i - w[i__4]
+ .i;
+ q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i =
+ d21.r * q__2.i + d21.i * q__2.r;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L80: */
+ }
+ }
+
+/* Copy D(k) to A */
+
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+ i__1 = k + 1 + k * a_dim1;
+ i__2 = k + 1 + k * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ i__2 = k + 1 + (k + 1) * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k + 1] = -kp;
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kstep;
+ goto L70;
+
+L90:
+
+/* Update the lower triangle of A22 (= A(k:n,k:n)) as */
+
+/* A22 := A22 - L21*D*L21' = A22 - L21*W' */
+
+/* computing blocks of NB columns at a time */
+
+ i__1 = *n;
+ i__2 = *nb;
+ for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = *nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+
+/* Update the lower triangle of the diagonal block */
+
+ i__3 = j + jb - 1;
+ for (jj = j; jj <= i__3; ++jj) {
+ i__4 = j + jb - jj;
+ i__5 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__4, &i__5, &q__1, &a[jj + a_dim1],
+ lda, &w[jj + w_dim1], ldw, &c_b1, &a[jj + jj * a_dim1]
+, &c__1);
+/* L100: */
+ }
+
+/* Update the rectangular subdiagonal block */
+
+ if (j + jb <= *n) {
+ i__3 = *n - j - jb + 1;
+ i__4 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &q__1,
+ &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b1,
+ &a[j + jb + j * a_dim1], lda);
+ }
+/* L110: */
+ }
+
+/* Put L21 in standard form by partially undoing the interchanges */
+/* in columns 1:k-1 */
+
+ j = k - 1;
+L120:
+ jj = j;
+ jp = ipiv[j];
+ if (jp < 0) {
+ jp = -jp;
+ --j;
+ }
+ --j;
+ if (jp != jj && j >= 1) {
+ cswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda);
+ }
+ if (j >= 1) {
+ goto L120;
+ }
+
+/* Set KB to the number of columns factorized */
+
+ *kb = k - 1;
+
+ }
+ return 0;
+
+/* End of CLASYF */
+
+} /* clasyf_ */
diff --git a/SRC/clatbs.c b/SRC/clatbs.c
new file mode 100644
index 0000000..646e4f4
--- /dev/null
+++ b/SRC/clatbs.c
@@ -0,0 +1,1193 @@
+/* clatbs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b36 = .5f;
+
+/* Subroutine */ int clatbs_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, integer *kd, complex *ab, integer *ldab, complex *
+ x, real *scale, real *cnorm, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j;
+ real xj, rec, tjj;
+ integer jinc, jlen;
+ real xbnd;
+ integer imax;
+ real tmax;
+ complex tjjs;
+ real xmax, grow;
+ integer maind;
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real tscal;
+ complex uscal;
+ integer jlast;
+ extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ complex csumj;
+ extern /* Subroutine */ int ctbsv_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *
+, complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern integer icamax_(integer *, complex *, integer *);
+ extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), xerbla_(char *, integer *);
+ real bignum;
+ extern integer isamax_(integer *, real *, integer *);
+ extern doublereal scasum_(integer *, complex *, integer *);
+ logical notran;
+ integer jfirst;
+ real smlnum;
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLATBS solves one of the triangular systems */
+
+/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */
+
+/* with scaling to prevent overflow, where A is an upper or lower */
+/* triangular band matrix. Here A' denotes the transpose of A, x and b */
+/* are n-element vectors, and s is a scaling factor, usually less than */
+/* or equal to 1, chosen so that the components of x will be less than */
+/* the overflow threshold. If the unscaled problem will not cause */
+/* overflow, the Level 2 BLAS routine CTBSV is called. If the matrix A */
+/* is singular (A(j,j) = 0 for some j), then s is set to 0 and a */
+/* non-trivial solution to A*x = 0 is returned. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': Solve A * x = s*b (No transpose) */
+/* = 'T': Solve A**T * x = s*b (Transpose) */
+/* = 'C': Solve A**H * x = s*b (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* NORMIN (input) CHARACTER*1 */
+/* Specifies whether CNORM has been set or not. */
+/* = 'Y': CNORM contains the column norms on entry */
+/* = 'N': CNORM is not set on entry. On exit, the norms will */
+/* be computed and stored in CNORM. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of subdiagonals or superdiagonals in the */
+/* triangular matrix A. KD >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first KD+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* X (input/output) COMPLEX array, dimension (N) */
+/* On entry, the right hand side b of the triangular system. */
+/* On exit, X is overwritten by the solution vector x. */
+
+/* SCALE (output) REAL */
+/* The scaling factor s for the triangular system */
+/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b. */
+/* If SCALE = 0, the matrix A is singular or badly scaled, and */
+/* the vector x is an exact or approximate solution to A*x = 0. */
+
+/* CNORM (input or output) REAL array, dimension (N) */
+
+/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
+/* contains the norm of the off-diagonal part of the j-th column */
+/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */
+/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
+/* must be greater than or equal to the 1-norm. */
+
+/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
+/* returns the 1-norm of the offdiagonal part of the j-th column */
+/* of A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* Further Details */
+/* ======= ======= */
+
+/* A rough bound on x is computed; if that is less than overflow, CTBSV */
+/* is called, otherwise, specific code is used which checks for possible */
+/* overflow or divide-by-zero at every operation. */
+
+/* A columnwise scheme is used for solving A*x = b. The basic algorithm */
+/* if A is lower triangular is */
+
+/* x[1:n] := b[1:n] */
+/* for j = 1, ..., n */
+/* x(j) := x(j) / A(j,j) */
+/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
+/* end */
+
+/* Define bounds on the components of x after j iterations of the loop: */
+/* M(j) = bound on x[1:j] */
+/* G(j) = bound on x[j+1:n] */
+/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */
+
+/* Then for iteration j+1 we have */
+/* M(j+1) <= G(j) / | A(j+1,j+1) | */
+/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
+/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
+
+/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
+/* column j+1 of A, not counting the diagonal. Hence */
+
+/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
+/* 1<=i<=j */
+/* and */
+
+/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
+/* 1<=i< j */
+
+/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTBSV if the */
+/* reciprocal of the largest M(j), j=1,..,n, is larger than */
+/* max(underflow, 1/overflow). */
+
+/* The bound on x(j) is also used to determine when a step in the */
+/* columnwise method can be performed without fear of overflow. If */
+/* the computed bound is greater than a large constant, x is scaled to */
+/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
+/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
+
+/* Similarly, a row-wise scheme is used to solve A**T *x = b or */
+/* A**H *x = b. The basic algorithm for A upper triangular is */
+
+/* for j = 1, ..., n */
+/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
+/* end */
+
+/* We simultaneously compute two bounds */
+/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
+/* M(j) = bound on x(i), 1<=i<=j */
+
+/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */
+/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
+/* Then the bound on x(j) is */
+
+/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
+
+/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
+/* 1<=i<=j */
+
+/* and we can safely call CTBSV if 1/M(n) and 1/G(n) are both greater */
+/* than max(underflow, 1/overflow). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --x;
+ --cnorm;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+/* Test the input parameters. */
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (! lsame_(normin, "Y") && ! lsame_(normin,
+ "N")) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*kd < 0) {
+ *info = -6;
+ } else if (*ldab < *kd + 1) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLATBS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine machine dependent parameters to control overflow. */
+
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ smlnum /= slamch_("Precision");
+ bignum = 1.f / smlnum;
+ *scale = 1.f;
+
+ if (lsame_(normin, "N")) {
+
+/* Compute the 1-norm of each column, not including the diagonal. */
+
+ if (upper) {
+
+/* A is upper triangular. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *kd, i__3 = j - 1;
+ jlen = min(i__2,i__3);
+ cnorm[j] = scasum_(&jlen, &ab[*kd + 1 - jlen + j * ab_dim1], &
+ c__1);
+/* L10: */
+ }
+ } else {
+
+/* A is lower triangular. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *kd, i__3 = *n - j;
+ jlen = min(i__2,i__3);
+ if (jlen > 0) {
+ cnorm[j] = scasum_(&jlen, &ab[j * ab_dim1 + 2], &c__1);
+ } else {
+ cnorm[j] = 0.f;
+ }
+/* L20: */
+ }
+ }
+ }
+
+/* Scale the column norms by TSCAL if the maximum element in CNORM is */
+/* greater than BIGNUM/2. */
+
+ imax = isamax_(n, &cnorm[1], &c__1);
+ tmax = cnorm[imax];
+ if (tmax <= bignum * .5f) {
+ tscal = 1.f;
+ } else {
+ tscal = .5f / (smlnum * tmax);
+ sscal_(n, &tscal, &cnorm[1], &c__1);
+ }
+
+/* Compute a bound on the computed solution vector to see if the */
+/* Level 2 BLAS routine CTBSV can be used. */
+
+ xmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j;
+ r__3 = xmax, r__4 = (r__1 = x[i__2].r / 2.f, dabs(r__1)) + (r__2 =
+ r_imag(&x[j]) / 2.f, dabs(r__2));
+ xmax = dmax(r__3,r__4);
+/* L30: */
+ }
+ xbnd = xmax;
+ if (notran) {
+
+/* Compute the growth in A * x = b. */
+
+ if (upper) {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ maind = *kd + 1;
+ } else {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ maind = 1;
+ }
+
+ if (tscal != 1.f) {
+ grow = 0.f;
+ goto L60;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, G(0) = max{x(i), i=1,...,n}. */
+
+ grow = .5f / dmax(xbnd,smlnum);
+ xbnd = grow;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L60;
+ }
+
+ i__3 = maind + j * ab_dim1;
+ tjjs.r = ab[i__3].r, tjjs.i = ab[i__3].i;
+ tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
+ dabs(r__2));
+
+ if (tjj >= smlnum) {
+
+/* M(j) = G(j-1) / abs(A(j,j)) */
+
+/* Computing MIN */
+ r__1 = xbnd, r__2 = dmin(1.f,tjj) * grow;
+ xbnd = dmin(r__1,r__2);
+ } else {
+
+/* M(j) could overflow, set XBND to 0. */
+
+ xbnd = 0.f;
+ }
+
+ if (tjj + cnorm[j] >= smlnum) {
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
+
+ grow *= tjj / (tjj + cnorm[j]);
+ } else {
+
+/* G(j) could overflow, set GROW to 0. */
+
+ grow = 0.f;
+ }
+/* L40: */
+ }
+ grow = xbnd;
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
+ grow = dmin(r__1,r__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L60;
+ }
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
+
+ grow *= 1.f / (cnorm[j] + 1.f);
+/* L50: */
+ }
+ }
+L60:
+
+ ;
+ } else {
+
+/* Compute the growth in A**T * x = b or A**H * x = b. */
+
+ if (upper) {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ maind = *kd + 1;
+ } else {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ maind = 1;
+ }
+
+ if (tscal != 1.f) {
+ grow = 0.f;
+ goto L90;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, M(0) = max{x(i), i=1,...,n}. */
+
+ grow = .5f / dmax(xbnd,smlnum);
+ xbnd = grow;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L90;
+ }
+
+/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
+
+ xj = cnorm[j] + 1.f;
+/* Computing MIN */
+ r__1 = grow, r__2 = xbnd / xj;
+ grow = dmin(r__1,r__2);
+
+ i__3 = maind + j * ab_dim1;
+ tjjs.r = ab[i__3].r, tjjs.i = ab[i__3].i;
+ tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
+ dabs(r__2));
+
+ if (tjj >= smlnum) {
+
+/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
+
+ if (xj > tjj) {
+ xbnd *= tjj / xj;
+ }
+ } else {
+
+/* M(j) could overflow, set XBND to 0. */
+
+ xbnd = 0.f;
+ }
+/* L70: */
+ }
+ grow = dmin(grow,xbnd);
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
+ grow = dmin(r__1,r__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L90;
+ }
+
+/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
+
+ xj = cnorm[j] + 1.f;
+ grow /= xj;
+/* L80: */
+ }
+ }
+L90:
+ ;
+ }
+
+ if (grow * tscal > smlnum) {
+
+/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
+/* elements of X is not too small. */
+
+ ctbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &x[1], &c__1);
+ } else {
+
+/* Use a Level 1 BLAS solve, scaling intermediate results. */
+
+ if (xmax > bignum * .5f) {
+
+/* Scale X so that its components are less than or equal to */
+/* BIGNUM in absolute value. */
+
+ *scale = bignum * .5f / xmax;
+ csscal_(n, scale, &x[1], &c__1);
+ xmax = bignum;
+ } else {
+ xmax *= 2.f;
+ }
+
+ if (notran) {
+
+/* Solve A * x = b */
+
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
+
+ i__3 = j;
+ xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
+ dabs(r__2));
+ if (nounit) {
+ i__3 = maind + j * ab_dim1;
+ q__1.r = tscal * ab[i__3].r, q__1.i = tscal * ab[i__3].i;
+ tjjs.r = q__1.r, tjjs.i = q__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.f;
+ if (tscal == 1.f) {
+ goto L105;
+ }
+ }
+ tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
+ dabs(r__2));
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.f) {
+ if (xj > tjj * bignum) {
+
+/* Scale x by 1/b(j). */
+
+ rec = 1.f / xj;
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ i__3 = j;
+ cladiv_(&q__1, &x[j], &tjjs);
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ i__3 = j;
+ xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
+ ), dabs(r__2));
+ } else if (tjj > 0.f) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
+/* to avoid overflow when dividing by A(j,j). */
+
+ rec = tjj * bignum / xj;
+ if (cnorm[j] > 1.f) {
+
+/* Scale by 1/CNORM(j) to avoid overflow when */
+/* multiplying x(j) times column j. */
+
+ rec /= cnorm[j];
+ }
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ i__3 = j;
+ cladiv_(&q__1, &x[j], &tjjs);
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ i__3 = j;
+ xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
+ ), dabs(r__2));
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0, and compute a solution to A*x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ x[i__4].r = 0.f, x[i__4].i = 0.f;
+/* L100: */
+ }
+ i__3 = j;
+ x[i__3].r = 1.f, x[i__3].i = 0.f;
+ xj = 1.f;
+ *scale = 0.f;
+ xmax = 0.f;
+ }
+L105:
+
+/* Scale x if necessary to avoid overflow when adding a */
+/* multiple of column j of A. */
+
+ if (xj > 1.f) {
+ rec = 1.f / xj;
+ if (cnorm[j] > (bignum - xmax) * rec) {
+
+/* Scale x by 1/(2*abs(x(j))). */
+
+ rec *= .5f;
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ }
+ } else if (xj * cnorm[j] > bignum - xmax) {
+
+/* Scale x by 1/2. */
+
+ csscal_(n, &c_b36, &x[1], &c__1);
+ *scale *= .5f;
+ }
+
+ if (upper) {
+ if (j > 1) {
+
+/* Compute the update */
+/* x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) - */
+/* x(j)* A(max(1,j-kd):j-1,j) */
+
+/* Computing MIN */
+ i__3 = *kd, i__4 = j - 1;
+ jlen = min(i__3,i__4);
+ i__3 = j;
+ q__2.r = -x[i__3].r, q__2.i = -x[i__3].i;
+ q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
+ caxpy_(&jlen, &q__1, &ab[*kd + 1 - jlen + j * ab_dim1]
+, &c__1, &x[j - jlen], &c__1);
+ i__3 = j - 1;
+ i__ = icamax_(&i__3, &x[1], &c__1);
+ i__3 = i__;
+ xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__]), dabs(r__2));
+ }
+ } else if (j < *n) {
+
+/* Compute the update */
+/* x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) - */
+/* x(j) * A(j+1:min(j+kd,n),j) */
+
+/* Computing MIN */
+ i__3 = *kd, i__4 = *n - j;
+ jlen = min(i__3,i__4);
+ if (jlen > 0) {
+ i__3 = j;
+ q__2.r = -x[i__3].r, q__2.i = -x[i__3].i;
+ q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
+ caxpy_(&jlen, &q__1, &ab[j * ab_dim1 + 2], &c__1, &x[
+ j + 1], &c__1);
+ }
+ i__3 = *n - j;
+ i__ = j + icamax_(&i__3, &x[j + 1], &c__1);
+ i__3 = i__;
+ xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[
+ i__]), dabs(r__2));
+ }
+/* L110: */
+ }
+
+ } else if (lsame_(trans, "T")) {
+
+/* Solve A**T * x = b */
+
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
+/* k<>j */
+
+ i__3 = j;
+ xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
+ dabs(r__2));
+ uscal.r = tscal, uscal.i = 0.f;
+ rec = 1.f / dmax(xmax,1.f);
+ if (cnorm[j] > (bignum - xj) * rec) {
+
+/* If x(j) could overflow, scale x by 1/(2*XMAX). */
+
+ rec *= .5f;
+ if (nounit) {
+ i__3 = maind + j * ab_dim1;
+ q__1.r = tscal * ab[i__3].r, q__1.i = tscal * ab[i__3]
+ .i;
+ tjjs.r = q__1.r, tjjs.i = q__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.f;
+ }
+ tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
+ dabs(r__2));
+ if (tjj > 1.f) {
+
+/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
+
+/* Computing MIN */
+ r__1 = 1.f, r__2 = rec * tjj;
+ rec = dmin(r__1,r__2);
+ cladiv_(&q__1, &uscal, &tjjs);
+ uscal.r = q__1.r, uscal.i = q__1.i;
+ }
+ if (rec < 1.f) {
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ csumj.r = 0.f, csumj.i = 0.f;
+ if (uscal.r == 1.f && uscal.i == 0.f) {
+
+/* If the scaling needed for A in the dot product is 1, */
+/* call CDOTU to perform the dot product. */
+
+ if (upper) {
+/* Computing MIN */
+ i__3 = *kd, i__4 = j - 1;
+ jlen = min(i__3,i__4);
+ cdotu_(&q__1, &jlen, &ab[*kd + 1 - jlen + j * ab_dim1]
+, &c__1, &x[j - jlen], &c__1);
+ csumj.r = q__1.r, csumj.i = q__1.i;
+ } else {
+/* Computing MIN */
+ i__3 = *kd, i__4 = *n - j;
+ jlen = min(i__3,i__4);
+ if (jlen > 1) {
+ cdotu_(&q__1, &jlen, &ab[j * ab_dim1 + 2], &c__1,
+ &x[j + 1], &c__1);
+ csumj.r = q__1.r, csumj.i = q__1.i;
+ }
+ }
+ } else {
+
+/* Otherwise, use in-line code for the dot product. */
+
+ if (upper) {
+/* Computing MIN */
+ i__3 = *kd, i__4 = j - 1;
+ jlen = min(i__3,i__4);
+ i__3 = jlen;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = *kd + i__ - jlen + j * ab_dim1;
+ q__3.r = ab[i__4].r * uscal.r - ab[i__4].i *
+ uscal.i, q__3.i = ab[i__4].r * uscal.i +
+ ab[i__4].i * uscal.r;
+ i__5 = j - jlen - 1 + i__;
+ q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i,
+ q__2.i = q__3.r * x[i__5].i + q__3.i * x[
+ i__5].r;
+ q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
+ q__2.i;
+ csumj.r = q__1.r, csumj.i = q__1.i;
+/* L120: */
+ }
+ } else {
+/* Computing MIN */
+ i__3 = *kd, i__4 = *n - j;
+ jlen = min(i__3,i__4);
+ i__3 = jlen;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + 1 + j * ab_dim1;
+ q__3.r = ab[i__4].r * uscal.r - ab[i__4].i *
+ uscal.i, q__3.i = ab[i__4].r * uscal.i +
+ ab[i__4].i * uscal.r;
+ i__5 = j + i__;
+ q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i,
+ q__2.i = q__3.r * x[i__5].i + q__3.i * x[
+ i__5].r;
+ q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
+ q__2.i;
+ csumj.r = q__1.r, csumj.i = q__1.i;
+/* L130: */
+ }
+ }
+ }
+
+ q__1.r = tscal, q__1.i = 0.f;
+ if (uscal.r == q__1.r && uscal.i == q__1.i) {
+
+/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
+/* was not used to scale the dotproduct. */
+
+ i__3 = j;
+ i__4 = j;
+ q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i -
+ csumj.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ i__3 = j;
+ xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
+ ), dabs(r__2));
+ if (nounit) {
+
+/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
+
+ i__3 = maind + j * ab_dim1;
+ q__1.r = tscal * ab[i__3].r, q__1.i = tscal * ab[i__3]
+ .i;
+ tjjs.r = q__1.r, tjjs.i = q__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.f;
+ if (tscal == 1.f) {
+ goto L145;
+ }
+ }
+ tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
+ dabs(r__2));
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.f) {
+ if (xj > tjj * bignum) {
+
+/* Scale X by 1/abs(x(j)). */
+
+ rec = 1.f / xj;
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ i__3 = j;
+ cladiv_(&q__1, &x[j], &tjjs);
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ } else if (tjj > 0.f) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
+
+ rec = tjj * bignum / xj;
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ i__3 = j;
+ cladiv_(&q__1, &x[j], &tjjs);
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0 and compute a solution to A**T *x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ x[i__4].r = 0.f, x[i__4].i = 0.f;
+/* L140: */
+ }
+ i__3 = j;
+ x[i__3].r = 1.f, x[i__3].i = 0.f;
+ *scale = 0.f;
+ xmax = 0.f;
+ }
+L145:
+ ;
+ } else {
+
+/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
+/* product has already been divided by 1/A(j,j). */
+
+ i__3 = j;
+ cladiv_(&q__2, &x[j], &tjjs);
+ q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ }
+/* Computing MAX */
+ i__3 = j;
+ r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[j]), dabs(r__2));
+ xmax = dmax(r__3,r__4);
+/* L150: */
+ }
+
+ } else {
+
+/* Solve A**H * x = b */
+
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
+/* k<>j */
+
+ i__3 = j;
+ xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
+ dabs(r__2));
+ uscal.r = tscal, uscal.i = 0.f;
+ rec = 1.f / dmax(xmax,1.f);
+ if (cnorm[j] > (bignum - xj) * rec) {
+
+/* If x(j) could overflow, scale x by 1/(2*XMAX). */
+
+ rec *= .5f;
+ if (nounit) {
+ r_cnjg(&q__2, &ab[maind + j * ab_dim1]);
+ q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
+ tjjs.r = q__1.r, tjjs.i = q__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.f;
+ }
+ tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
+ dabs(r__2));
+ if (tjj > 1.f) {
+
+/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
+
+/* Computing MIN */
+ r__1 = 1.f, r__2 = rec * tjj;
+ rec = dmin(r__1,r__2);
+ cladiv_(&q__1, &uscal, &tjjs);
+ uscal.r = q__1.r, uscal.i = q__1.i;
+ }
+ if (rec < 1.f) {
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ csumj.r = 0.f, csumj.i = 0.f;
+ if (uscal.r == 1.f && uscal.i == 0.f) {
+
+/* If the scaling needed for A in the dot product is 1, */
+/* call CDOTC to perform the dot product. */
+
+ if (upper) {
+/* Computing MIN */
+ i__3 = *kd, i__4 = j - 1;
+ jlen = min(i__3,i__4);
+ cdotc_(&q__1, &jlen, &ab[*kd + 1 - jlen + j * ab_dim1]
+, &c__1, &x[j - jlen], &c__1);
+ csumj.r = q__1.r, csumj.i = q__1.i;
+ } else {
+/* Computing MIN */
+ i__3 = *kd, i__4 = *n - j;
+ jlen = min(i__3,i__4);
+ if (jlen > 1) {
+ cdotc_(&q__1, &jlen, &ab[j * ab_dim1 + 2], &c__1,
+ &x[j + 1], &c__1);
+ csumj.r = q__1.r, csumj.i = q__1.i;
+ }
+ }
+ } else {
+
+/* Otherwise, use in-line code for the dot product. */
+
+ if (upper) {
+/* Computing MIN */
+ i__3 = *kd, i__4 = j - 1;
+ jlen = min(i__3,i__4);
+ i__3 = jlen;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ r_cnjg(&q__4, &ab[*kd + i__ - jlen + j * ab_dim1])
+ ;
+ q__3.r = q__4.r * uscal.r - q__4.i * uscal.i,
+ q__3.i = q__4.r * uscal.i + q__4.i *
+ uscal.r;
+ i__4 = j - jlen - 1 + i__;
+ q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
+ q__2.i = q__3.r * x[i__4].i + q__3.i * x[
+ i__4].r;
+ q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
+ q__2.i;
+ csumj.r = q__1.r, csumj.i = q__1.i;
+/* L160: */
+ }
+ } else {
+/* Computing MIN */
+ i__3 = *kd, i__4 = *n - j;
+ jlen = min(i__3,i__4);
+ i__3 = jlen;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ r_cnjg(&q__4, &ab[i__ + 1 + j * ab_dim1]);
+ q__3.r = q__4.r * uscal.r - q__4.i * uscal.i,
+ q__3.i = q__4.r * uscal.i + q__4.i *
+ uscal.r;
+ i__4 = j + i__;
+ q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
+ q__2.i = q__3.r * x[i__4].i + q__3.i * x[
+ i__4].r;
+ q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
+ q__2.i;
+ csumj.r = q__1.r, csumj.i = q__1.i;
+/* L170: */
+ }
+ }
+ }
+
+ q__1.r = tscal, q__1.i = 0.f;
+ if (uscal.r == q__1.r && uscal.i == q__1.i) {
+
+/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
+/* was not used to scale the dotproduct. */
+
+ i__3 = j;
+ i__4 = j;
+ q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i -
+ csumj.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ i__3 = j;
+ xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
+ ), dabs(r__2));
+ if (nounit) {
+
+/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
+
+ r_cnjg(&q__2, &ab[maind + j * ab_dim1]);
+ q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
+ tjjs.r = q__1.r, tjjs.i = q__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.f;
+ if (tscal == 1.f) {
+ goto L185;
+ }
+ }
+ tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
+ dabs(r__2));
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.f) {
+ if (xj > tjj * bignum) {
+
+/* Scale X by 1/abs(x(j)). */
+
+ rec = 1.f / xj;
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ i__3 = j;
+ cladiv_(&q__1, &x[j], &tjjs);
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ } else if (tjj > 0.f) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
+
+ rec = tjj * bignum / xj;
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ i__3 = j;
+ cladiv_(&q__1, &x[j], &tjjs);
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0 and compute a solution to A**H *x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ x[i__4].r = 0.f, x[i__4].i = 0.f;
+/* L180: */
+ }
+ i__3 = j;
+ x[i__3].r = 1.f, x[i__3].i = 0.f;
+ *scale = 0.f;
+ xmax = 0.f;
+ }
+L185:
+ ;
+ } else {
+
+/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
+/* product has already been divided by 1/A(j,j). */
+
+ i__3 = j;
+ cladiv_(&q__2, &x[j], &tjjs);
+ q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ }
+/* Computing MAX */
+ i__3 = j;
+ r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[j]), dabs(r__2));
+ xmax = dmax(r__3,r__4);
+/* L190: */
+ }
+ }
+ *scale /= tscal;
+ }
+
+/* Scale the column norms by 1/TSCAL for return. */
+
+ if (tscal != 1.f) {
+ r__1 = 1.f / tscal;
+ sscal_(n, &r__1, &cnorm[1], &c__1);
+ }
+
+ return 0;
+
+/* End of CLATBS */
+
+} /* clatbs_ */
diff --git a/SRC/clatdf.c b/SRC/clatdf.c
new file mode 100644
index 0000000..89c38a2
--- /dev/null
+++ b/SRC/clatdf.c
@@ -0,0 +1,357 @@
+/* clatdf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b24 = 1.f;
+
+/* Subroutine */ int clatdf_(integer *ijob, integer *n, complex *z__, integer
+ *ldz, complex *rhs, real *rdsum, real *rdscal, integer *ipiv, integer
+ *jpiv)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void c_div(complex *, complex *, complex *);
+ double c_abs(complex *);
+ void c_sqrt(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ complex bm, bp, xm[2], xp[2];
+ integer info;
+ complex temp, work[8];
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *);
+ real scale;
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ complex pmone;
+ extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ real rtemp, sminu, rwork[2], splus;
+ extern /* Subroutine */ int cgesc2_(integer *, complex *, integer *,
+ complex *, integer *, integer *, real *), cgecon_(char *, integer
+ *, complex *, integer *, real *, real *, complex *, real *,
+ integer *), classq_(integer *, complex *, integer *, real
+ *, real *), claswp_(integer *, complex *, integer *, integer *,
+ integer *, integer *, integer *);
+ extern doublereal scasum_(integer *, complex *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLATDF computes the contribution to the reciprocal Dif-estimate */
+/* by solving for x in Z * x = b, where b is chosen such that the norm */
+/* of x is as large as possible. It is assumed that LU decomposition */
+/* of Z has been computed by CGETC2. On entry RHS = f holds the */
+/* contribution from earlier solved sub-systems, and on return RHS = x. */
+
+/* The factorization of Z returned by CGETC2 has the form */
+/* Z = P * L * U * Q, where P and Q are permutation matrices. L is lower */
+/* triangular with unit diagonal elements and U is upper triangular. */
+
+/* Arguments */
+/* ========= */
+
+/* IJOB (input) INTEGER */
+/* IJOB = 2: First compute an approximative null-vector e */
+/* of Z using CGECON, e is normalized and solve for */
+/* Zx = +-e - f with the sign giving the greater value of */
+/* 2-norm(x). About 5 times as expensive as Default. */
+/* IJOB .ne. 2: Local look ahead strategy where */
+/* all entries of the r.h.s. b is choosen as either +1 or */
+/* -1. Default. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Z. */
+
+/* Z (input) REAL array, dimension (LDZ, N) */
+/* On entry, the LU part of the factorization of the n-by-n */
+/* matrix Z computed by CGETC2: Z = P * L * U * Q */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDA >= max(1, N). */
+
+/* RHS (input/output) REAL array, dimension (N). */
+/* On entry, RHS contains contributions from other subsystems. */
+/* On exit, RHS contains the solution of the subsystem with */
+/* entries according to the value of IJOB (see above). */
+
+/* RDSUM (input/output) REAL */
+/* On entry, the sum of squares of computed contributions to */
+/* the Dif-estimate under computation by CTGSYL, where the */
+/* scaling factor RDSCAL (see below) has been factored out. */
+/* On exit, the corresponding sum of squares updated with the */
+/* contributions from the current sub-system. */
+/* If TRANS = 'T' RDSUM is not touched. */
+/* NOTE: RDSUM only makes sense when CTGSY2 is called by CTGSYL. */
+
+/* RDSCAL (input/output) REAL */
+/* On entry, scaling factor used to prevent overflow in RDSUM. */
+/* On exit, RDSCAL is updated w.r.t. the current contributions */
+/* in RDSUM. */
+/* If TRANS = 'T', RDSCAL is not touched. */
+/* NOTE: RDSCAL only makes sense when CTGSY2 is called by */
+/* CTGSYL. */
+
+/* IPIV (input) INTEGER array, dimension (N). */
+/* The pivot indices; for 1 <= i <= N, row i of the */
+/* matrix has been interchanged with row IPIV(i). */
+
+/* JPIV (input) INTEGER array, dimension (N). */
+/* The pivot indices; for 1 <= j <= N, column j of the */
+/* matrix has been interchanged with column JPIV(j). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* This routine is a further developed implementation of algorithm */
+/* BSOLVE in [1] using complete pivoting in the LU factorization. */
+
+/* [1] Bo Kagstrom and Lars Westin, */
+/* Generalized Schur Methods with Condition Estimators for */
+/* Solving the Generalized Sylvester Equation, IEEE Transactions */
+/* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. */
+
+/* [2] Peter Poromaa, */
+/* On Efficient and Robust Estimators for the Separation */
+/* between two Regular Matrix Pairs with Applications in */
+/* Condition Estimation. Report UMINF-95.05, Department of */
+/* Computing Science, Umea University, S-901 87 Umea, Sweden, */
+/* 1995. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --rhs;
+ --ipiv;
+ --jpiv;
+
+ /* Function Body */
+ if (*ijob != 2) {
+
+/* Apply permutations IPIV to RHS */
+
+ i__1 = *n - 1;
+ claswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &ipiv[1], &c__1);
+
+/* Solve for L-part choosing RHS either to +1 or -1. */
+
+ q__1.r = -1.f, q__1.i = -0.f;
+ pmone.r = q__1.r, pmone.i = q__1.i;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ q__1.r = rhs[i__2].r + 1.f, q__1.i = rhs[i__2].i + 0.f;
+ bp.r = q__1.r, bp.i = q__1.i;
+ i__2 = j;
+ q__1.r = rhs[i__2].r - 1.f, q__1.i = rhs[i__2].i - 0.f;
+ bm.r = q__1.r, bm.i = q__1.i;
+ splus = 1.f;
+
+/* Lockahead for L- part RHS(1:N-1) = +-1 */
+/* SPLUS and SMIN computed more efficiently than in BSOLVE[1]. */
+
+ i__2 = *n - j;
+ cdotc_(&q__1, &i__2, &z__[j + 1 + j * z_dim1], &c__1, &z__[j + 1
+ + j * z_dim1], &c__1);
+ splus += q__1.r;
+ i__2 = *n - j;
+ cdotc_(&q__1, &i__2, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1],
+ &c__1);
+ sminu = q__1.r;
+ i__2 = j;
+ splus *= rhs[i__2].r;
+ if (splus > sminu) {
+ i__2 = j;
+ rhs[i__2].r = bp.r, rhs[i__2].i = bp.i;
+ } else if (sminu > splus) {
+ i__2 = j;
+ rhs[i__2].r = bm.r, rhs[i__2].i = bm.i;
+ } else {
+
+/* In this case the updating sums are equal and we can */
+/* choose RHS(J) +1 or -1. The first time this happens we */
+/* choose -1, thereafter +1. This is a simple way to get */
+/* good estimates of matrices like Byers well-known example */
+/* (see [1]). (Not done in BSOLVE.) */
+
+ i__2 = j;
+ i__3 = j;
+ q__1.r = rhs[i__3].r + pmone.r, q__1.i = rhs[i__3].i +
+ pmone.i;
+ rhs[i__2].r = q__1.r, rhs[i__2].i = q__1.i;
+ pmone.r = 1.f, pmone.i = 0.f;
+ }
+
+/* Compute the remaining r.h.s. */
+
+ i__2 = j;
+ q__1.r = -rhs[i__2].r, q__1.i = -rhs[i__2].i;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__2 = *n - j;
+ caxpy_(&i__2, &temp, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1],
+ &c__1);
+/* L10: */
+ }
+
+/* Solve for U- part, lockahead for RHS(N) = +-1. This is not done */
+/* In BSOLVE and will hopefully give us a better estimate because */
+/* any ill-conditioning of the original matrix is transfered to U */
+/* and not to L. U(N, N) is an approximation to sigma_min(LU). */
+
+ i__1 = *n - 1;
+ ccopy_(&i__1, &rhs[1], &c__1, work, &c__1);
+ i__1 = *n - 1;
+ i__2 = *n;
+ q__1.r = rhs[i__2].r + 1.f, q__1.i = rhs[i__2].i + 0.f;
+ work[i__1].r = q__1.r, work[i__1].i = q__1.i;
+ i__1 = *n;
+ i__2 = *n;
+ q__1.r = rhs[i__2].r - 1.f, q__1.i = rhs[i__2].i - 0.f;
+ rhs[i__1].r = q__1.r, rhs[i__1].i = q__1.i;
+ splus = 0.f;
+ sminu = 0.f;
+ for (i__ = *n; i__ >= 1; --i__) {
+ c_div(&q__1, &c_b1, &z__[i__ + i__ * z_dim1]);
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__1 = i__ - 1;
+ i__2 = i__ - 1;
+ q__1.r = work[i__2].r * temp.r - work[i__2].i * temp.i, q__1.i =
+ work[i__2].r * temp.i + work[i__2].i * temp.r;
+ work[i__1].r = q__1.r, work[i__1].i = q__1.i;
+ i__1 = i__;
+ i__2 = i__;
+ q__1.r = rhs[i__2].r * temp.r - rhs[i__2].i * temp.i, q__1.i =
+ rhs[i__2].r * temp.i + rhs[i__2].i * temp.r;
+ rhs[i__1].r = q__1.r, rhs[i__1].i = q__1.i;
+ i__1 = *n;
+ for (k = i__ + 1; k <= i__1; ++k) {
+ i__2 = i__ - 1;
+ i__3 = i__ - 1;
+ i__4 = k - 1;
+ i__5 = i__ + k * z_dim1;
+ q__3.r = z__[i__5].r * temp.r - z__[i__5].i * temp.i, q__3.i =
+ z__[i__5].r * temp.i + z__[i__5].i * temp.r;
+ q__2.r = work[i__4].r * q__3.r - work[i__4].i * q__3.i,
+ q__2.i = work[i__4].r * q__3.i + work[i__4].i *
+ q__3.r;
+ q__1.r = work[i__3].r - q__2.r, q__1.i = work[i__3].i -
+ q__2.i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = k;
+ i__5 = i__ + k * z_dim1;
+ q__3.r = z__[i__5].r * temp.r - z__[i__5].i * temp.i, q__3.i =
+ z__[i__5].r * temp.i + z__[i__5].i * temp.r;
+ q__2.r = rhs[i__4].r * q__3.r - rhs[i__4].i * q__3.i, q__2.i =
+ rhs[i__4].r * q__3.i + rhs[i__4].i * q__3.r;
+ q__1.r = rhs[i__3].r - q__2.r, q__1.i = rhs[i__3].i - q__2.i;
+ rhs[i__2].r = q__1.r, rhs[i__2].i = q__1.i;
+/* L20: */
+ }
+ splus += c_abs(&work[i__ - 1]);
+ sminu += c_abs(&rhs[i__]);
+/* L30: */
+ }
+ if (splus > sminu) {
+ ccopy_(n, work, &c__1, &rhs[1], &c__1);
+ }
+
+/* Apply the permutations JPIV to the computed solution (RHS) */
+
+ i__1 = *n - 1;
+ claswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &jpiv[1], &c_n1);
+
+/* Compute the sum of squares */
+
+ classq_(n, &rhs[1], &c__1, rdscal, rdsum);
+ return 0;
+ }
+
+/* ENTRY IJOB = 2 */
+
+/* Compute approximate nullvector XM of Z */
+
+ cgecon_("I", n, &z__[z_offset], ldz, &c_b24, &rtemp, work, rwork, &info);
+ ccopy_(n, &work[*n], &c__1, xm, &c__1);
+
+/* Compute RHS */
+
+ i__1 = *n - 1;
+ claswp_(&c__1, xm, ldz, &c__1, &i__1, &ipiv[1], &c_n1);
+ cdotc_(&q__3, n, xm, &c__1, xm, &c__1);
+ c_sqrt(&q__2, &q__3);
+ c_div(&q__1, &c_b1, &q__2);
+ temp.r = q__1.r, temp.i = q__1.i;
+ cscal_(n, &temp, xm, &c__1);
+ ccopy_(n, xm, &c__1, xp, &c__1);
+ caxpy_(n, &c_b1, &rhs[1], &c__1, xp, &c__1);
+ q__1.r = -1.f, q__1.i = -0.f;
+ caxpy_(n, &q__1, xm, &c__1, &rhs[1], &c__1);
+ cgesc2_(n, &z__[z_offset], ldz, &rhs[1], &ipiv[1], &jpiv[1], &scale);
+ cgesc2_(n, &z__[z_offset], ldz, xp, &ipiv[1], &jpiv[1], &scale);
+ if (scasum_(n, xp, &c__1) > scasum_(n, &rhs[1], &c__1)) {
+ ccopy_(n, xp, &c__1, &rhs[1], &c__1);
+ }
+
+/* Compute the sum of squares */
+
+ classq_(n, &rhs[1], &c__1, rdscal, rdsum);
+ return 0;
+
+/* End of CLATDF */
+
+} /* clatdf_ */
diff --git a/SRC/clatps.c b/SRC/clatps.c
new file mode 100644
index 0000000..c30b6d4
--- /dev/null
+++ b/SRC/clatps.c
@@ -0,0 +1,1161 @@
+/* clatps.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b36 = .5f;
+
+/* Subroutine */ int clatps_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, complex *ap, complex *x, real *scale, real *cnorm,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, ip;
+ real xj, rec, tjj;
+ integer jinc, jlen;
+ real xbnd;
+ integer imax;
+ real tmax;
+ complex tjjs;
+ real xmax, grow;
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real tscal;
+ complex uscal;
+ integer jlast;
+ extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ complex csumj;
+ extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
+ complex *, complex *, integer *), slabad_(
+ real *, real *);
+ extern integer icamax_(integer *, complex *, integer *);
+ extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), xerbla_(char *, integer *);
+ real bignum;
+ extern integer isamax_(integer *, real *, integer *);
+ extern doublereal scasum_(integer *, complex *, integer *);
+ logical notran;
+ integer jfirst;
+ real smlnum;
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLATPS solves one of the triangular systems */
+
+/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */
+
+/* with scaling to prevent overflow, where A is an upper or lower */
+/* triangular matrix stored in packed form. Here A**T denotes the */
+/* transpose of A, A**H denotes the conjugate transpose of A, x and b */
+/* are n-element vectors, and s is a scaling factor, usually less than */
+/* or equal to 1, chosen so that the components of x will be less than */
+/* the overflow threshold. If the unscaled problem will not cause */
+/* overflow, the Level 2 BLAS routine CTPSV is called. If the matrix A */
+/* is singular (A(j,j) = 0 for some j), then s is set to 0 and a */
+/* non-trivial solution to A*x = 0 is returned. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': Solve A * x = s*b (No transpose) */
+/* = 'T': Solve A**T * x = s*b (Transpose) */
+/* = 'C': Solve A**H * x = s*b (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* NORMIN (input) CHARACTER*1 */
+/* Specifies whether CNORM has been set or not. */
+/* = 'Y': CNORM contains the column norms on entry */
+/* = 'N': CNORM is not set on entry. On exit, the norms will */
+/* be computed and stored in CNORM. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* X (input/output) COMPLEX array, dimension (N) */
+/* On entry, the right hand side b of the triangular system. */
+/* On exit, X is overwritten by the solution vector x. */
+
+/* SCALE (output) REAL */
+/* The scaling factor s for the triangular system */
+/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b. */
+/* If SCALE = 0, the matrix A is singular or badly scaled, and */
+/* the vector x is an exact or approximate solution to A*x = 0. */
+
+/* CNORM (input or output) REAL array, dimension (N) */
+
+/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
+/* contains the norm of the off-diagonal part of the j-th column */
+/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */
+/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
+/* must be greater than or equal to the 1-norm. */
+
+/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
+/* returns the 1-norm of the offdiagonal part of the j-th column */
+/* of A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* Further Details */
+/* ======= ======= */
+
+/* A rough bound on x is computed; if that is less than overflow, CTPSV */
+/* is called, otherwise, specific code is used which checks for possible */
+/* overflow or divide-by-zero at every operation. */
+
+/* A columnwise scheme is used for solving A*x = b. The basic algorithm */
+/* if A is lower triangular is */
+
+/* x[1:n] := b[1:n] */
+/* for j = 1, ..., n */
+/* x(j) := x(j) / A(j,j) */
+/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
+/* end */
+
+/* Define bounds on the components of x after j iterations of the loop: */
+/* M(j) = bound on x[1:j] */
+/* G(j) = bound on x[j+1:n] */
+/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */
+
+/* Then for iteration j+1 we have */
+/* M(j+1) <= G(j) / | A(j+1,j+1) | */
+/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
+/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
+
+/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
+/* column j+1 of A, not counting the diagonal. Hence */
+
+/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
+/* 1<=i<=j */
+/* and */
+
+/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
+/* 1<=i< j */
+
+/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTPSV if the */
+/* reciprocal of the largest M(j), j=1,..,n, is larger than */
+/* max(underflow, 1/overflow). */
+
+/* The bound on x(j) is also used to determine when a step in the */
+/* columnwise method can be performed without fear of overflow. If */
+/* the computed bound is greater than a large constant, x is scaled to */
+/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
+/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
+
+/* Similarly, a row-wise scheme is used to solve A**T *x = b or */
+/* A**H *x = b. The basic algorithm for A upper triangular is */
+
+/* for j = 1, ..., n */
+/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
+/* end */
+
+/* We simultaneously compute two bounds */
+/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
+/* M(j) = bound on x(i), 1<=i<=j */
+
+/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */
+/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
+/* Then the bound on x(j) is */
+
+/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
+
+/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
+/* 1<=i<=j */
+
+/* and we can safely call CTPSV if 1/M(n) and 1/G(n) are both greater */
+/* than max(underflow, 1/overflow). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --cnorm;
+ --x;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+/* Test the input parameters. */
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (! lsame_(normin, "Y") && ! lsame_(normin,
+ "N")) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLATPS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine machine dependent parameters to control overflow. */
+
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ smlnum /= slamch_("Precision");
+ bignum = 1.f / smlnum;
+ *scale = 1.f;
+
+ if (lsame_(normin, "N")) {
+
+/* Compute the 1-norm of each column, not including the diagonal. */
+
+ if (upper) {
+
+/* A is upper triangular. */
+
+ ip = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ cnorm[j] = scasum_(&i__2, &ap[ip], &c__1);
+ ip += j;
+/* L10: */
+ }
+ } else {
+
+/* A is lower triangular. */
+
+ ip = 1;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ cnorm[j] = scasum_(&i__2, &ap[ip + 1], &c__1);
+ ip = ip + *n - j + 1;
+/* L20: */
+ }
+ cnorm[*n] = 0.f;
+ }
+ }
+
+/* Scale the column norms by TSCAL if the maximum element in CNORM is */
+/* greater than BIGNUM/2. */
+
+ imax = isamax_(n, &cnorm[1], &c__1);
+ tmax = cnorm[imax];
+ if (tmax <= bignum * .5f) {
+ tscal = 1.f;
+ } else {
+ tscal = .5f / (smlnum * tmax);
+ sscal_(n, &tscal, &cnorm[1], &c__1);
+ }
+
+/* Compute a bound on the computed solution vector to see if the */
+/* Level 2 BLAS routine CTPSV can be used. */
+
+ xmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j;
+ r__3 = xmax, r__4 = (r__1 = x[i__2].r / 2.f, dabs(r__1)) + (r__2 =
+ r_imag(&x[j]) / 2.f, dabs(r__2));
+ xmax = dmax(r__3,r__4);
+/* L30: */
+ }
+ xbnd = xmax;
+ if (notran) {
+
+/* Compute the growth in A * x = b. */
+
+ if (upper) {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ } else {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ }
+
+ if (tscal != 1.f) {
+ grow = 0.f;
+ goto L60;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, G(0) = max{x(i), i=1,...,n}. */
+
+ grow = .5f / dmax(xbnd,smlnum);
+ xbnd = grow;
+ ip = jfirst * (jfirst + 1) / 2;
+ jlen = *n;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L60;
+ }
+
+ i__3 = ip;
+ tjjs.r = ap[i__3].r, tjjs.i = ap[i__3].i;
+ tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
+ dabs(r__2));
+
+ if (tjj >= smlnum) {
+
+/* M(j) = G(j-1) / abs(A(j,j)) */
+
+/* Computing MIN */
+ r__1 = xbnd, r__2 = dmin(1.f,tjj) * grow;
+ xbnd = dmin(r__1,r__2);
+ } else {
+
+/* M(j) could overflow, set XBND to 0. */
+
+ xbnd = 0.f;
+ }
+
+ if (tjj + cnorm[j] >= smlnum) {
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
+
+ grow *= tjj / (tjj + cnorm[j]);
+ } else {
+
+/* G(j) could overflow, set GROW to 0. */
+
+ grow = 0.f;
+ }
+ ip += jinc * jlen;
+ --jlen;
+/* L40: */
+ }
+ grow = xbnd;
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
+ grow = dmin(r__1,r__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L60;
+ }
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
+
+ grow *= 1.f / (cnorm[j] + 1.f);
+/* L50: */
+ }
+ }
+L60:
+
+ ;
+ } else {
+
+/* Compute the growth in A**T * x = b or A**H * x = b. */
+
+ if (upper) {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ } else {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ }
+
+ if (tscal != 1.f) {
+ grow = 0.f;
+ goto L90;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, M(0) = max{x(i), i=1,...,n}. */
+
+ grow = .5f / dmax(xbnd,smlnum);
+ xbnd = grow;
+ ip = jfirst * (jfirst + 1) / 2;
+ jlen = 1;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L90;
+ }
+
+/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
+
+ xj = cnorm[j] + 1.f;
+/* Computing MIN */
+ r__1 = grow, r__2 = xbnd / xj;
+ grow = dmin(r__1,r__2);
+
+ i__3 = ip;
+ tjjs.r = ap[i__3].r, tjjs.i = ap[i__3].i;
+ tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
+ dabs(r__2));
+
+ if (tjj >= smlnum) {
+
+/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
+
+ if (xj > tjj) {
+ xbnd *= tjj / xj;
+ }
+ } else {
+
+/* M(j) could overflow, set XBND to 0. */
+
+ xbnd = 0.f;
+ }
+ ++jlen;
+ ip += jinc * jlen;
+/* L70: */
+ }
+ grow = dmin(grow,xbnd);
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
+ grow = dmin(r__1,r__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L90;
+ }
+
+/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
+
+ xj = cnorm[j] + 1.f;
+ grow /= xj;
+/* L80: */
+ }
+ }
+L90:
+ ;
+ }
+
+ if (grow * tscal > smlnum) {
+
+/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
+/* elements of X is not too small. */
+
+ ctpsv_(uplo, trans, diag, n, &ap[1], &x[1], &c__1);
+ } else {
+
+/* Use a Level 1 BLAS solve, scaling intermediate results. */
+
+ if (xmax > bignum * .5f) {
+
+/* Scale X so that its components are less than or equal to */
+/* BIGNUM in absolute value. */
+
+ *scale = bignum * .5f / xmax;
+ csscal_(n, scale, &x[1], &c__1);
+ xmax = bignum;
+ } else {
+ xmax *= 2.f;
+ }
+
+ if (notran) {
+
+/* Solve A * x = b */
+
+ ip = jfirst * (jfirst + 1) / 2;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
+
+ i__3 = j;
+ xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
+ dabs(r__2));
+ if (nounit) {
+ i__3 = ip;
+ q__1.r = tscal * ap[i__3].r, q__1.i = tscal * ap[i__3].i;
+ tjjs.r = q__1.r, tjjs.i = q__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.f;
+ if (tscal == 1.f) {
+ goto L105;
+ }
+ }
+ tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
+ dabs(r__2));
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.f) {
+ if (xj > tjj * bignum) {
+
+/* Scale x by 1/b(j). */
+
+ rec = 1.f / xj;
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ i__3 = j;
+ cladiv_(&q__1, &x[j], &tjjs);
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ i__3 = j;
+ xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
+ ), dabs(r__2));
+ } else if (tjj > 0.f) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
+/* to avoid overflow when dividing by A(j,j). */
+
+ rec = tjj * bignum / xj;
+ if (cnorm[j] > 1.f) {
+
+/* Scale by 1/CNORM(j) to avoid overflow when */
+/* multiplying x(j) times column j. */
+
+ rec /= cnorm[j];
+ }
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ i__3 = j;
+ cladiv_(&q__1, &x[j], &tjjs);
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ i__3 = j;
+ xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
+ ), dabs(r__2));
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0, and compute a solution to A*x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ x[i__4].r = 0.f, x[i__4].i = 0.f;
+/* L100: */
+ }
+ i__3 = j;
+ x[i__3].r = 1.f, x[i__3].i = 0.f;
+ xj = 1.f;
+ *scale = 0.f;
+ xmax = 0.f;
+ }
+L105:
+
+/* Scale x if necessary to avoid overflow when adding a */
+/* multiple of column j of A. */
+
+ if (xj > 1.f) {
+ rec = 1.f / xj;
+ if (cnorm[j] > (bignum - xmax) * rec) {
+
+/* Scale x by 1/(2*abs(x(j))). */
+
+ rec *= .5f;
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ }
+ } else if (xj * cnorm[j] > bignum - xmax) {
+
+/* Scale x by 1/2. */
+
+ csscal_(n, &c_b36, &x[1], &c__1);
+ *scale *= .5f;
+ }
+
+ if (upper) {
+ if (j > 1) {
+
+/* Compute the update */
+/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */
+
+ i__3 = j - 1;
+ i__4 = j;
+ q__2.r = -x[i__4].r, q__2.i = -x[i__4].i;
+ q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
+ caxpy_(&i__3, &q__1, &ap[ip - j + 1], &c__1, &x[1], &
+ c__1);
+ i__3 = j - 1;
+ i__ = icamax_(&i__3, &x[1], &c__1);
+ i__3 = i__;
+ xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__]), dabs(r__2));
+ }
+ ip -= j;
+ } else {
+ if (j < *n) {
+
+/* Compute the update */
+/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */
+
+ i__3 = *n - j;
+ i__4 = j;
+ q__2.r = -x[i__4].r, q__2.i = -x[i__4].i;
+ q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
+ caxpy_(&i__3, &q__1, &ap[ip + 1], &c__1, &x[j + 1], &
+ c__1);
+ i__3 = *n - j;
+ i__ = j + icamax_(&i__3, &x[j + 1], &c__1);
+ i__3 = i__;
+ xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__]), dabs(r__2));
+ }
+ ip = ip + *n - j + 1;
+ }
+/* L110: */
+ }
+
+ } else if (lsame_(trans, "T")) {
+
+/* Solve A**T * x = b */
+
+ ip = jfirst * (jfirst + 1) / 2;
+ jlen = 1;
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
+/* k<>j */
+
+ i__3 = j;
+ xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
+ dabs(r__2));
+ uscal.r = tscal, uscal.i = 0.f;
+ rec = 1.f / dmax(xmax,1.f);
+ if (cnorm[j] > (bignum - xj) * rec) {
+
+/* If x(j) could overflow, scale x by 1/(2*XMAX). */
+
+ rec *= .5f;
+ if (nounit) {
+ i__3 = ip;
+ q__1.r = tscal * ap[i__3].r, q__1.i = tscal * ap[i__3]
+ .i;
+ tjjs.r = q__1.r, tjjs.i = q__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.f;
+ }
+ tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
+ dabs(r__2));
+ if (tjj > 1.f) {
+
+/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
+
+/* Computing MIN */
+ r__1 = 1.f, r__2 = rec * tjj;
+ rec = dmin(r__1,r__2);
+ cladiv_(&q__1, &uscal, &tjjs);
+ uscal.r = q__1.r, uscal.i = q__1.i;
+ }
+ if (rec < 1.f) {
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ csumj.r = 0.f, csumj.i = 0.f;
+ if (uscal.r == 1.f && uscal.i == 0.f) {
+
+/* If the scaling needed for A in the dot product is 1, */
+/* call CDOTU to perform the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ cdotu_(&q__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], &
+ c__1);
+ csumj.r = q__1.r, csumj.i = q__1.i;
+ } else if (j < *n) {
+ i__3 = *n - j;
+ cdotu_(&q__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], &
+ c__1);
+ csumj.r = q__1.r, csumj.i = q__1.i;
+ }
+ } else {
+
+/* Otherwise, use in-line code for the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ip - j + i__;
+ q__3.r = ap[i__4].r * uscal.r - ap[i__4].i *
+ uscal.i, q__3.i = ap[i__4].r * uscal.i +
+ ap[i__4].i * uscal.r;
+ i__5 = i__;
+ q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i,
+ q__2.i = q__3.r * x[i__5].i + q__3.i * x[
+ i__5].r;
+ q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
+ q__2.i;
+ csumj.r = q__1.r, csumj.i = q__1.i;
+/* L120: */
+ }
+ } else if (j < *n) {
+ i__3 = *n - j;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ip + i__;
+ q__3.r = ap[i__4].r * uscal.r - ap[i__4].i *
+ uscal.i, q__3.i = ap[i__4].r * uscal.i +
+ ap[i__4].i * uscal.r;
+ i__5 = j + i__;
+ q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i,
+ q__2.i = q__3.r * x[i__5].i + q__3.i * x[
+ i__5].r;
+ q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
+ q__2.i;
+ csumj.r = q__1.r, csumj.i = q__1.i;
+/* L130: */
+ }
+ }
+ }
+
+ q__1.r = tscal, q__1.i = 0.f;
+ if (uscal.r == q__1.r && uscal.i == q__1.i) {
+
+/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
+/* was not used to scale the dotproduct. */
+
+ i__3 = j;
+ i__4 = j;
+ q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i -
+ csumj.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ i__3 = j;
+ xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
+ ), dabs(r__2));
+ if (nounit) {
+
+/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
+
+ i__3 = ip;
+ q__1.r = tscal * ap[i__3].r, q__1.i = tscal * ap[i__3]
+ .i;
+ tjjs.r = q__1.r, tjjs.i = q__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.f;
+ if (tscal == 1.f) {
+ goto L145;
+ }
+ }
+ tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
+ dabs(r__2));
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.f) {
+ if (xj > tjj * bignum) {
+
+/* Scale X by 1/abs(x(j)). */
+
+ rec = 1.f / xj;
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ i__3 = j;
+ cladiv_(&q__1, &x[j], &tjjs);
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ } else if (tjj > 0.f) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
+
+ rec = tjj * bignum / xj;
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ i__3 = j;
+ cladiv_(&q__1, &x[j], &tjjs);
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0 and compute a solution to A**T *x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ x[i__4].r = 0.f, x[i__4].i = 0.f;
+/* L140: */
+ }
+ i__3 = j;
+ x[i__3].r = 1.f, x[i__3].i = 0.f;
+ *scale = 0.f;
+ xmax = 0.f;
+ }
+L145:
+ ;
+ } else {
+
+/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
+/* product has already been divided by 1/A(j,j). */
+
+ i__3 = j;
+ cladiv_(&q__2, &x[j], &tjjs);
+ q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ }
+/* Computing MAX */
+ i__3 = j;
+ r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[j]), dabs(r__2));
+ xmax = dmax(r__3,r__4);
+ ++jlen;
+ ip += jinc * jlen;
+/* L150: */
+ }
+
+ } else {
+
+/* Solve A**H * x = b */
+
+ ip = jfirst * (jfirst + 1) / 2;
+ jlen = 1;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
+/* k<>j */
+
+ i__3 = j;
+ xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
+ dabs(r__2));
+ uscal.r = tscal, uscal.i = 0.f;
+ rec = 1.f / dmax(xmax,1.f);
+ if (cnorm[j] > (bignum - xj) * rec) {
+
+/* If x(j) could overflow, scale x by 1/(2*XMAX). */
+
+ rec *= .5f;
+ if (nounit) {
+ r_cnjg(&q__2, &ap[ip]);
+ q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
+ tjjs.r = q__1.r, tjjs.i = q__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.f;
+ }
+ tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
+ dabs(r__2));
+ if (tjj > 1.f) {
+
+/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
+
+/* Computing MIN */
+ r__1 = 1.f, r__2 = rec * tjj;
+ rec = dmin(r__1,r__2);
+ cladiv_(&q__1, &uscal, &tjjs);
+ uscal.r = q__1.r, uscal.i = q__1.i;
+ }
+ if (rec < 1.f) {
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ csumj.r = 0.f, csumj.i = 0.f;
+ if (uscal.r == 1.f && uscal.i == 0.f) {
+
+/* If the scaling needed for A in the dot product is 1, */
+/* call CDOTC to perform the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ cdotc_(&q__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], &
+ c__1);
+ csumj.r = q__1.r, csumj.i = q__1.i;
+ } else if (j < *n) {
+ i__3 = *n - j;
+ cdotc_(&q__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], &
+ c__1);
+ csumj.r = q__1.r, csumj.i = q__1.i;
+ }
+ } else {
+
+/* Otherwise, use in-line code for the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ r_cnjg(&q__4, &ap[ip - j + i__]);
+ q__3.r = q__4.r * uscal.r - q__4.i * uscal.i,
+ q__3.i = q__4.r * uscal.i + q__4.i *
+ uscal.r;
+ i__4 = i__;
+ q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
+ q__2.i = q__3.r * x[i__4].i + q__3.i * x[
+ i__4].r;
+ q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
+ q__2.i;
+ csumj.r = q__1.r, csumj.i = q__1.i;
+/* L160: */
+ }
+ } else if (j < *n) {
+ i__3 = *n - j;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ r_cnjg(&q__4, &ap[ip + i__]);
+ q__3.r = q__4.r * uscal.r - q__4.i * uscal.i,
+ q__3.i = q__4.r * uscal.i + q__4.i *
+ uscal.r;
+ i__4 = j + i__;
+ q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
+ q__2.i = q__3.r * x[i__4].i + q__3.i * x[
+ i__4].r;
+ q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
+ q__2.i;
+ csumj.r = q__1.r, csumj.i = q__1.i;
+/* L170: */
+ }
+ }
+ }
+
+ q__1.r = tscal, q__1.i = 0.f;
+ if (uscal.r == q__1.r && uscal.i == q__1.i) {
+
+/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
+/* was not used to scale the dotproduct. */
+
+ i__3 = j;
+ i__4 = j;
+ q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i -
+ csumj.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ i__3 = j;
+ xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
+ ), dabs(r__2));
+ if (nounit) {
+
+/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
+
+ r_cnjg(&q__2, &ap[ip]);
+ q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
+ tjjs.r = q__1.r, tjjs.i = q__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.f;
+ if (tscal == 1.f) {
+ goto L185;
+ }
+ }
+ tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
+ dabs(r__2));
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.f) {
+ if (xj > tjj * bignum) {
+
+/* Scale X by 1/abs(x(j)). */
+
+ rec = 1.f / xj;
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ i__3 = j;
+ cladiv_(&q__1, &x[j], &tjjs);
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ } else if (tjj > 0.f) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
+
+ rec = tjj * bignum / xj;
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ i__3 = j;
+ cladiv_(&q__1, &x[j], &tjjs);
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0 and compute a solution to A**H *x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ x[i__4].r = 0.f, x[i__4].i = 0.f;
+/* L180: */
+ }
+ i__3 = j;
+ x[i__3].r = 1.f, x[i__3].i = 0.f;
+ *scale = 0.f;
+ xmax = 0.f;
+ }
+L185:
+ ;
+ } else {
+
+/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
+/* product has already been divided by 1/A(j,j). */
+
+ i__3 = j;
+ cladiv_(&q__2, &x[j], &tjjs);
+ q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ }
+/* Computing MAX */
+ i__3 = j;
+ r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[j]), dabs(r__2));
+ xmax = dmax(r__3,r__4);
+ ++jlen;
+ ip += jinc * jlen;
+/* L190: */
+ }
+ }
+ *scale /= tscal;
+ }
+
+/* Scale the column norms by 1/TSCAL for return. */
+
+ if (tscal != 1.f) {
+ r__1 = 1.f / tscal;
+ sscal_(n, &r__1, &cnorm[1], &c__1);
+ }
+
+ return 0;
+
+/* End of CLATPS */
+
+} /* clatps_ */
diff --git a/SRC/clatrd.c b/SRC/clatrd.c
new file mode 100644
index 0000000..4a696f1
--- /dev/null
+++ b/SRC/clatrd.c
@@ -0,0 +1,418 @@
+/* clatrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int clatrd_(char *uplo, integer *n, integer *nb, complex *a,
+ integer *lda, real *e, complex *tau, complex *w, integer *ldw)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
+ real r__1;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Local variables */
+ integer i__, iw;
+ complex alpha;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *);
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *), chemv_(char *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, complex *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *), clarfg_(integer *, complex *,
+ complex *, integer *, complex *), clacgv_(integer *, complex *,
+ integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLATRD reduces NB rows and columns of a complex Hermitian matrix A to */
+/* Hermitian tridiagonal form by a unitary similarity */
+/* transformation Q' * A * Q, and returns the matrices V and W which are */
+/* needed to apply the transformation to the unreduced part of A. */
+
+/* If UPLO = 'U', CLATRD reduces the last NB rows and columns of a */
+/* matrix, of which the upper triangle is supplied; */
+/* if UPLO = 'L', CLATRD reduces the first NB rows and columns of a */
+/* matrix, of which the lower triangle is supplied. */
+
+/* This is an auxiliary routine called by CHETRD. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* NB (input) INTEGER */
+/* The number of rows and columns to be reduced. */
+
+/* A (input/output) 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 UPLO = 'U', the last NB columns have been reduced to */
+/* tridiagonal form, with the diagonal elements overwriting */
+/* the diagonal elements of A; the elements above the diagonal */
+/* with the array TAU, represent the unitary matrix Q as a */
+/* product of elementary reflectors; */
+/* if UPLO = 'L', the first NB columns have been reduced to */
+/* tridiagonal form, with the diagonal elements overwriting */
+/* the diagonal elements of A; the elements below the diagonal */
+/* with the array TAU, represent the unitary matrix Q as a */
+/* product of elementary reflectors. */
+/* See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* E (output) REAL array, dimension (N-1) */
+/* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal */
+/* elements of the last NB columns of the reduced matrix; */
+/* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of */
+/* the first NB columns of the reduced matrix. */
+
+/* TAU (output) COMPLEX array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors, stored in */
+/* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. */
+/* See Further Details. */
+
+/* W (output) COMPLEX array, dimension (LDW,NB) */
+/* The n-by-nb matrix W required to update the unreduced part */
+/* of A. */
+
+/* LDW (input) INTEGER */
+/* The leading dimension of the array W. LDW >= max(1,N). */
+
+/* Further Details */
+/* =============== */
+
+/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(n) H(n-1) . . . H(n-nb+1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), */
+/* and tau in TAU(i-1). */
+
+/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(1) H(2) . . . H(nb). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */
+/* and tau in TAU(i). */
+
+/* The elements of the vectors v together form the n-by-nb matrix V */
+/* which is needed, with W, to apply the transformation to the unreduced */
+/* part of the matrix, using a Hermitian rank-2k update of the form: */
+/* A := A - V*W' - W*V'. */
+
+/* The contents of A on exit are illustrated by the following examples */
+/* with n = 5 and nb = 2: */
+
+/* if UPLO = 'U': if UPLO = 'L': */
+
+/* ( a a a v4 v5 ) ( d ) */
+/* ( a a v4 v5 ) ( 1 d ) */
+/* ( a 1 v5 ) ( v1 1 a ) */
+/* ( d 1 ) ( v1 v2 a a ) */
+/* ( d ) ( v1 v2 a a a ) */
+
+/* where d denotes a diagonal element of the reduced matrix, a denotes */
+/* an element of the original matrix that is unchanged, and vi denotes */
+/* an element of the vector defining H(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --e;
+ --tau;
+ w_dim1 = *ldw;
+ w_offset = 1 + w_dim1;
+ w -= w_offset;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+
+ if (lsame_(uplo, "U")) {
+
+/* Reduce last NB columns of upper triangle */
+
+ i__1 = *n - *nb + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ iw = i__ - *n + *nb;
+ if (i__ < *n) {
+
+/* Update A(1:i,i) */
+
+ i__2 = i__ + i__ * a_dim1;
+ i__3 = i__ + i__ * a_dim1;
+ r__1 = a[i__3].r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ i__2 = *n - i__;
+ clacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw);
+ i__2 = *n - i__;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__, &i__2, &q__1, &a[(i__ + 1) *
+ a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, &
+ c_b2, &a[i__ * a_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ clacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw);
+ i__2 = *n - i__;
+ clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
+ i__2 = *n - i__;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__, &i__2, &q__1, &w[(iw + 1) *
+ w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, &
+ c_b2, &a[i__ * a_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
+ i__2 = i__ + i__ * a_dim1;
+ i__3 = i__ + i__ * a_dim1;
+ r__1 = a[i__3].r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ }
+ if (i__ > 1) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* A(1:i-2,i) */
+
+ i__2 = i__ - 1 + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = i__ - 1;
+ clarfg_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &tau[i__
+ - 1]);
+ i__2 = i__ - 1;
+ e[i__2] = alpha.r;
+ i__2 = i__ - 1 + i__ * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+
+/* Compute W(1:i-1,i) */
+
+ i__2 = i__ - 1;
+ chemv_("Upper", &i__2, &c_b2, &a[a_offset], lda, &a[i__ *
+ a_dim1 + 1], &c__1, &c_b1, &w[iw * w_dim1 + 1], &c__1);
+ if (i__ < *n) {
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w[(iw
+ + 1) * w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], &
+ c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__2, &i__3, &q__1, &a[(i__ + 1) *
+ a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], &
+ c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[(
+ i__ + 1) * a_dim1 + 1], lda, &a[i__ * a_dim1 + 1],
+ &c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__2, &i__3, &q__1, &w[(iw + 1) *
+ w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], &
+ c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1);
+ }
+ i__2 = i__ - 1;
+ cscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1);
+ q__3.r = -.5f, q__3.i = -0.f;
+ i__2 = i__ - 1;
+ q__2.r = q__3.r * tau[i__2].r - q__3.i * tau[i__2].i, q__2.i =
+ q__3.r * tau[i__2].i + q__3.i * tau[i__2].r;
+ i__3 = i__ - 1;
+ cdotc_(&q__4, &i__3, &w[iw * w_dim1 + 1], &c__1, &a[i__ *
+ a_dim1 + 1], &c__1);
+ q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r *
+ q__4.i + q__2.i * q__4.r;
+ alpha.r = q__1.r, alpha.i = q__1.i;
+ i__2 = i__ - 1;
+ caxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw *
+ w_dim1 + 1], &c__1);
+ }
+
+/* L10: */
+ }
+ } else {
+
+/* Reduce first NB columns of lower triangle */
+
+ i__1 = *nb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Update A(i:n,i) */
+
+ i__2 = i__ + i__ * a_dim1;
+ i__3 = i__ + i__ * a_dim1;
+ r__1 = a[i__3].r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ i__2 = i__ - 1;
+ clacgv_(&i__2, &w[i__ + w_dim1], ldw);
+ i__2 = *n - i__ + 1;
+ i__3 = i__ - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__2, &i__3, &q__1, &a[i__ + a_dim1], lda,
+ &w[i__ + w_dim1], ldw, &c_b2, &a[i__ + i__ * a_dim1], &
+ c__1);
+ i__2 = i__ - 1;
+ clacgv_(&i__2, &w[i__ + w_dim1], ldw);
+ i__2 = i__ - 1;
+ clacgv_(&i__2, &a[i__ + a_dim1], lda);
+ i__2 = *n - i__ + 1;
+ i__3 = i__ - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__2, &i__3, &q__1, &w[i__ + w_dim1], ldw,
+ &a[i__ + a_dim1], lda, &c_b2, &a[i__ + i__ * a_dim1], &
+ c__1);
+ i__2 = i__ - 1;
+ clacgv_(&i__2, &a[i__ + a_dim1], lda);
+ i__2 = i__ + i__ * a_dim1;
+ i__3 = i__ + i__ * a_dim1;
+ r__1 = a[i__3].r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ if (i__ < *n) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* A(i+2:n,i) */
+
+ i__2 = i__ + 1 + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *n - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ clarfg_(&i__2, &alpha, &a[min(i__3, *n)+ i__ * a_dim1], &c__1,
+ &tau[i__]);
+ i__2 = i__;
+ e[i__2] = alpha.r;
+ i__2 = i__ + 1 + i__ * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+
+/* Compute W(i+1:n,i) */
+
+ i__2 = *n - i__;
+ chemv_("Lower", &i__2, &c_b2, &a[i__ + 1 + (i__ + 1) * a_dim1]
+, lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b1, &w[
+ i__ + 1 + i__ * w_dim1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w[i__ + 1
+ + w_dim1], ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, &
+ c_b1, &w[i__ * w_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__2, &i__3, &q__1, &a[i__ + 1 +
+ a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[
+ i__ + 1 + i__ * w_dim1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1
+ + a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &
+ c_b1, &w[i__ * w_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__2, &i__3, &q__1, &w[i__ + 1 +
+ w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[
+ i__ + 1 + i__ * w_dim1], &c__1);
+ i__2 = *n - i__;
+ cscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1);
+ q__3.r = -.5f, q__3.i = -0.f;
+ i__2 = i__;
+ q__2.r = q__3.r * tau[i__2].r - q__3.i * tau[i__2].i, q__2.i =
+ q__3.r * tau[i__2].i + q__3.i * tau[i__2].r;
+ i__3 = *n - i__;
+ cdotc_(&q__4, &i__3, &w[i__ + 1 + i__ * w_dim1], &c__1, &a[
+ i__ + 1 + i__ * a_dim1], &c__1);
+ q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r *
+ q__4.i + q__2.i * q__4.r;
+ alpha.r = q__1.r, alpha.i = q__1.i;
+ i__2 = *n - i__;
+ caxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[
+ i__ + 1 + i__ * w_dim1], &c__1);
+ }
+
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of CLATRD */
+
+} /* clatrd_ */
diff --git a/SRC/clatrs.c b/SRC/clatrs.c
new file mode 100644
index 0000000..3bf8994
--- /dev/null
+++ b/SRC/clatrs.c
@@ -0,0 +1,1147 @@
+/* clatrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b36 = .5f;
+
+/* Subroutine */ int clatrs_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, complex *a, integer *lda, complex *x, real *scale,
+ real *cnorm, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j;
+ real xj, rec, tjj;
+ integer jinc;
+ real xbnd;
+ integer imax;
+ real tmax;
+ complex tjjs;
+ real xmax, grow;
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real tscal;
+ complex uscal;
+ integer jlast;
+ extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ complex csumj;
+ extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int ctrsv_(char *, char *, char *, integer *,
+ complex *, integer *, complex *, integer *), slabad_(real *, real *);
+ extern integer icamax_(integer *, complex *, integer *);
+ extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), xerbla_(char *, integer *);
+ real bignum;
+ extern integer isamax_(integer *, real *, integer *);
+ extern doublereal scasum_(integer *, complex *, integer *);
+ logical notran;
+ integer jfirst;
+ real smlnum;
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLATRS solves one of the triangular systems */
+
+/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */
+
+/* with scaling to prevent overflow. Here A is an upper or lower */
+/* triangular matrix, A**T denotes the transpose of A, A**H denotes the */
+/* conjugate transpose of A, x and b are n-element vectors, and s is a */
+/* scaling factor, usually less than or equal to 1, chosen so that the */
+/* components of x will be less than the overflow threshold. If the */
+/* unscaled problem will not cause overflow, the Level 2 BLAS routine */
+/* CTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j), */
+/* then s is set to 0 and a non-trivial solution to A*x = 0 is returned. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': Solve A * x = s*b (No transpose) */
+/* = 'T': Solve A**T * x = s*b (Transpose) */
+/* = 'C': Solve A**H * x = s*b (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* NORMIN (input) CHARACTER*1 */
+/* Specifies whether CNORM has been set or not. */
+/* = 'Y': CNORM contains the column norms on entry */
+/* = 'N': CNORM is not set on entry. On exit, the norms will */
+/* be computed and stored in CNORM. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max (1,N). */
+
+/* X (input/output) COMPLEX array, dimension (N) */
+/* On entry, the right hand side b of the triangular system. */
+/* On exit, X is overwritten by the solution vector x. */
+
+/* SCALE (output) REAL */
+/* The scaling factor s for the triangular system */
+/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b. */
+/* If SCALE = 0, the matrix A is singular or badly scaled, and */
+/* the vector x is an exact or approximate solution to A*x = 0. */
+
+/* CNORM (input or output) REAL array, dimension (N) */
+
+/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
+/* contains the norm of the off-diagonal part of the j-th column */
+/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */
+/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
+/* must be greater than or equal to the 1-norm. */
+
+/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
+/* returns the 1-norm of the offdiagonal part of the j-th column */
+/* of A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* Further Details */
+/* ======= ======= */
+
+/* A rough bound on x is computed; if that is less than overflow, CTRSV */
+/* is called, otherwise, specific code is used which checks for possible */
+/* overflow or divide-by-zero at every operation. */
+
+/* A columnwise scheme is used for solving A*x = b. The basic algorithm */
+/* if A is lower triangular is */
+
+/* x[1:n] := b[1:n] */
+/* for j = 1, ..., n */
+/* x(j) := x(j) / A(j,j) */
+/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
+/* end */
+
+/* Define bounds on the components of x after j iterations of the loop: */
+/* M(j) = bound on x[1:j] */
+/* G(j) = bound on x[j+1:n] */
+/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */
+
+/* Then for iteration j+1 we have */
+/* M(j+1) <= G(j) / | A(j+1,j+1) | */
+/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
+/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
+
+/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
+/* column j+1 of A, not counting the diagonal. Hence */
+
+/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
+/* 1<=i<=j */
+/* and */
+
+/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
+/* 1<=i< j */
+
+/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTRSV if the */
+/* reciprocal of the largest M(j), j=1,..,n, is larger than */
+/* max(underflow, 1/overflow). */
+
+/* The bound on x(j) is also used to determine when a step in the */
+/* columnwise method can be performed without fear of overflow. If */
+/* the computed bound is greater than a large constant, x is scaled to */
+/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
+/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
+
+/* Similarly, a row-wise scheme is used to solve A**T *x = b or */
+/* A**H *x = b. The basic algorithm for A upper triangular is */
+
+/* for j = 1, ..., n */
+/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
+/* end */
+
+/* We simultaneously compute two bounds */
+/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
+/* M(j) = bound on x(i), 1<=i<=j */
+
+/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */
+/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
+/* Then the bound on x(j) is */
+
+/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
+
+/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
+/* 1<=i<=j */
+
+/* and we can safely call CTRSV if 1/M(n) and 1/G(n) are both greater */
+/* than max(underflow, 1/overflow). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --cnorm;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+/* Test the input parameters. */
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (! lsame_(normin, "Y") && ! lsame_(normin,
+ "N")) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLATRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine machine dependent parameters to control overflow. */
+
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ smlnum /= slamch_("Precision");
+ bignum = 1.f / smlnum;
+ *scale = 1.f;
+
+ if (lsame_(normin, "N")) {
+
+/* Compute the 1-norm of each column, not including the diagonal. */
+
+ if (upper) {
+
+/* A is upper triangular. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ cnorm[j] = scasum_(&i__2, &a[j * a_dim1 + 1], &c__1);
+/* L10: */
+ }
+ } else {
+
+/* A is lower triangular. */
+
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ cnorm[j] = scasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1);
+/* L20: */
+ }
+ cnorm[*n] = 0.f;
+ }
+ }
+
+/* Scale the column norms by TSCAL if the maximum element in CNORM is */
+/* greater than BIGNUM/2. */
+
+ imax = isamax_(n, &cnorm[1], &c__1);
+ tmax = cnorm[imax];
+ if (tmax <= bignum * .5f) {
+ tscal = 1.f;
+ } else {
+ tscal = .5f / (smlnum * tmax);
+ sscal_(n, &tscal, &cnorm[1], &c__1);
+ }
+
+/* Compute a bound on the computed solution vector to see if the */
+/* Level 2 BLAS routine CTRSV can be used. */
+
+ xmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j;
+ r__3 = xmax, r__4 = (r__1 = x[i__2].r / 2.f, dabs(r__1)) + (r__2 =
+ r_imag(&x[j]) / 2.f, dabs(r__2));
+ xmax = dmax(r__3,r__4);
+/* L30: */
+ }
+ xbnd = xmax;
+
+ if (notran) {
+
+/* Compute the growth in A * x = b. */
+
+ if (upper) {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ } else {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ }
+
+ if (tscal != 1.f) {
+ grow = 0.f;
+ goto L60;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, G(0) = max{x(i), i=1,...,n}. */
+
+ grow = .5f / dmax(xbnd,smlnum);
+ xbnd = grow;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L60;
+ }
+
+ i__3 = j + j * a_dim1;
+ tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
+ tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
+ dabs(r__2));
+
+ if (tjj >= smlnum) {
+
+/* M(j) = G(j-1) / abs(A(j,j)) */
+
+/* Computing MIN */
+ r__1 = xbnd, r__2 = dmin(1.f,tjj) * grow;
+ xbnd = dmin(r__1,r__2);
+ } else {
+
+/* M(j) could overflow, set XBND to 0. */
+
+ xbnd = 0.f;
+ }
+
+ if (tjj + cnorm[j] >= smlnum) {
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
+
+ grow *= tjj / (tjj + cnorm[j]);
+ } else {
+
+/* G(j) could overflow, set GROW to 0. */
+
+ grow = 0.f;
+ }
+/* L40: */
+ }
+ grow = xbnd;
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
+ grow = dmin(r__1,r__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L60;
+ }
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
+
+ grow *= 1.f / (cnorm[j] + 1.f);
+/* L50: */
+ }
+ }
+L60:
+
+ ;
+ } else {
+
+/* Compute the growth in A**T * x = b or A**H * x = b. */
+
+ if (upper) {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ } else {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ }
+
+ if (tscal != 1.f) {
+ grow = 0.f;
+ goto L90;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, M(0) = max{x(i), i=1,...,n}. */
+
+ grow = .5f / dmax(xbnd,smlnum);
+ xbnd = grow;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L90;
+ }
+
+/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
+
+ xj = cnorm[j] + 1.f;
+/* Computing MIN */
+ r__1 = grow, r__2 = xbnd / xj;
+ grow = dmin(r__1,r__2);
+
+ i__3 = j + j * a_dim1;
+ tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
+ tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
+ dabs(r__2));
+
+ if (tjj >= smlnum) {
+
+/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
+
+ if (xj > tjj) {
+ xbnd *= tjj / xj;
+ }
+ } else {
+
+/* M(j) could overflow, set XBND to 0. */
+
+ xbnd = 0.f;
+ }
+/* L70: */
+ }
+ grow = dmin(grow,xbnd);
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
+ grow = dmin(r__1,r__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L90;
+ }
+
+/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
+
+ xj = cnorm[j] + 1.f;
+ grow /= xj;
+/* L80: */
+ }
+ }
+L90:
+ ;
+ }
+
+ if (grow * tscal > smlnum) {
+
+/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
+/* elements of X is not too small. */
+
+ ctrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1);
+ } else {
+
+/* Use a Level 1 BLAS solve, scaling intermediate results. */
+
+ if (xmax > bignum * .5f) {
+
+/* Scale X so that its components are less than or equal to */
+/* BIGNUM in absolute value. */
+
+ *scale = bignum * .5f / xmax;
+ csscal_(n, scale, &x[1], &c__1);
+ xmax = bignum;
+ } else {
+ xmax *= 2.f;
+ }
+
+ if (notran) {
+
+/* Solve A * x = b */
+
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
+
+ i__3 = j;
+ xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
+ dabs(r__2));
+ if (nounit) {
+ i__3 = j + j * a_dim1;
+ q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3].i;
+ tjjs.r = q__1.r, tjjs.i = q__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.f;
+ if (tscal == 1.f) {
+ goto L105;
+ }
+ }
+ tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
+ dabs(r__2));
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.f) {
+ if (xj > tjj * bignum) {
+
+/* Scale x by 1/b(j). */
+
+ rec = 1.f / xj;
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ i__3 = j;
+ cladiv_(&q__1, &x[j], &tjjs);
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ i__3 = j;
+ xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
+ ), dabs(r__2));
+ } else if (tjj > 0.f) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
+/* to avoid overflow when dividing by A(j,j). */
+
+ rec = tjj * bignum / xj;
+ if (cnorm[j] > 1.f) {
+
+/* Scale by 1/CNORM(j) to avoid overflow when */
+/* multiplying x(j) times column j. */
+
+ rec /= cnorm[j];
+ }
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ i__3 = j;
+ cladiv_(&q__1, &x[j], &tjjs);
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ i__3 = j;
+ xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
+ ), dabs(r__2));
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0, and compute a solution to A*x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ x[i__4].r = 0.f, x[i__4].i = 0.f;
+/* L100: */
+ }
+ i__3 = j;
+ x[i__3].r = 1.f, x[i__3].i = 0.f;
+ xj = 1.f;
+ *scale = 0.f;
+ xmax = 0.f;
+ }
+L105:
+
+/* Scale x if necessary to avoid overflow when adding a */
+/* multiple of column j of A. */
+
+ if (xj > 1.f) {
+ rec = 1.f / xj;
+ if (cnorm[j] > (bignum - xmax) * rec) {
+
+/* Scale x by 1/(2*abs(x(j))). */
+
+ rec *= .5f;
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ }
+ } else if (xj * cnorm[j] > bignum - xmax) {
+
+/* Scale x by 1/2. */
+
+ csscal_(n, &c_b36, &x[1], &c__1);
+ *scale *= .5f;
+ }
+
+ if (upper) {
+ if (j > 1) {
+
+/* Compute the update */
+/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */
+
+ i__3 = j - 1;
+ i__4 = j;
+ q__2.r = -x[i__4].r, q__2.i = -x[i__4].i;
+ q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
+ caxpy_(&i__3, &q__1, &a[j * a_dim1 + 1], &c__1, &x[1],
+ &c__1);
+ i__3 = j - 1;
+ i__ = icamax_(&i__3, &x[1], &c__1);
+ i__3 = i__;
+ xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__]), dabs(r__2));
+ }
+ } else {
+ if (j < *n) {
+
+/* Compute the update */
+/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */
+
+ i__3 = *n - j;
+ i__4 = j;
+ q__2.r = -x[i__4].r, q__2.i = -x[i__4].i;
+ q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
+ caxpy_(&i__3, &q__1, &a[j + 1 + j * a_dim1], &c__1, &
+ x[j + 1], &c__1);
+ i__3 = *n - j;
+ i__ = j + icamax_(&i__3, &x[j + 1], &c__1);
+ i__3 = i__;
+ xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__]), dabs(r__2));
+ }
+ }
+/* L110: */
+ }
+
+ } else if (lsame_(trans, "T")) {
+
+/* Solve A**T * x = b */
+
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
+/* k<>j */
+
+ i__3 = j;
+ xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
+ dabs(r__2));
+ uscal.r = tscal, uscal.i = 0.f;
+ rec = 1.f / dmax(xmax,1.f);
+ if (cnorm[j] > (bignum - xj) * rec) {
+
+/* If x(j) could overflow, scale x by 1/(2*XMAX). */
+
+ rec *= .5f;
+ if (nounit) {
+ i__3 = j + j * a_dim1;
+ q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3]
+ .i;
+ tjjs.r = q__1.r, tjjs.i = q__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.f;
+ }
+ tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
+ dabs(r__2));
+ if (tjj > 1.f) {
+
+/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
+
+/* Computing MIN */
+ r__1 = 1.f, r__2 = rec * tjj;
+ rec = dmin(r__1,r__2);
+ cladiv_(&q__1, &uscal, &tjjs);
+ uscal.r = q__1.r, uscal.i = q__1.i;
+ }
+ if (rec < 1.f) {
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ csumj.r = 0.f, csumj.i = 0.f;
+ if (uscal.r == 1.f && uscal.i == 0.f) {
+
+/* If the scaling needed for A in the dot product is 1, */
+/* call CDOTU to perform the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ cdotu_(&q__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
+ &c__1);
+ csumj.r = q__1.r, csumj.i = q__1.i;
+ } else if (j < *n) {
+ i__3 = *n - j;
+ cdotu_(&q__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
+ x[j + 1], &c__1);
+ csumj.r = q__1.r, csumj.i = q__1.i;
+ }
+ } else {
+
+/* Otherwise, use in-line code for the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ q__3.r = a[i__4].r * uscal.r - a[i__4].i *
+ uscal.i, q__3.i = a[i__4].r * uscal.i + a[
+ i__4].i * uscal.r;
+ i__5 = i__;
+ q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i,
+ q__2.i = q__3.r * x[i__5].i + q__3.i * x[
+ i__5].r;
+ q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
+ q__2.i;
+ csumj.r = q__1.r, csumj.i = q__1.i;
+/* L120: */
+ }
+ } else if (j < *n) {
+ i__3 = *n;
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ q__3.r = a[i__4].r * uscal.r - a[i__4].i *
+ uscal.i, q__3.i = a[i__4].r * uscal.i + a[
+ i__4].i * uscal.r;
+ i__5 = i__;
+ q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i,
+ q__2.i = q__3.r * x[i__5].i + q__3.i * x[
+ i__5].r;
+ q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
+ q__2.i;
+ csumj.r = q__1.r, csumj.i = q__1.i;
+/* L130: */
+ }
+ }
+ }
+
+ q__1.r = tscal, q__1.i = 0.f;
+ if (uscal.r == q__1.r && uscal.i == q__1.i) {
+
+/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
+/* was not used to scale the dotproduct. */
+
+ i__3 = j;
+ i__4 = j;
+ q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i -
+ csumj.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ i__3 = j;
+ xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
+ ), dabs(r__2));
+ if (nounit) {
+ i__3 = j + j * a_dim1;
+ q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3]
+ .i;
+ tjjs.r = q__1.r, tjjs.i = q__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.f;
+ if (tscal == 1.f) {
+ goto L145;
+ }
+ }
+
+/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
+
+ tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
+ dabs(r__2));
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.f) {
+ if (xj > tjj * bignum) {
+
+/* Scale X by 1/abs(x(j)). */
+
+ rec = 1.f / xj;
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ i__3 = j;
+ cladiv_(&q__1, &x[j], &tjjs);
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ } else if (tjj > 0.f) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
+
+ rec = tjj * bignum / xj;
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ i__3 = j;
+ cladiv_(&q__1, &x[j], &tjjs);
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0 and compute a solution to A**T *x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ x[i__4].r = 0.f, x[i__4].i = 0.f;
+/* L140: */
+ }
+ i__3 = j;
+ x[i__3].r = 1.f, x[i__3].i = 0.f;
+ *scale = 0.f;
+ xmax = 0.f;
+ }
+L145:
+ ;
+ } else {
+
+/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
+/* product has already been divided by 1/A(j,j). */
+
+ i__3 = j;
+ cladiv_(&q__2, &x[j], &tjjs);
+ q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ }
+/* Computing MAX */
+ i__3 = j;
+ r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[j]), dabs(r__2));
+ xmax = dmax(r__3,r__4);
+/* L150: */
+ }
+
+ } else {
+
+/* Solve A**H * x = b */
+
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
+/* k<>j */
+
+ i__3 = j;
+ xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
+ dabs(r__2));
+ uscal.r = tscal, uscal.i = 0.f;
+ rec = 1.f / dmax(xmax,1.f);
+ if (cnorm[j] > (bignum - xj) * rec) {
+
+/* If x(j) could overflow, scale x by 1/(2*XMAX). */
+
+ rec *= .5f;
+ if (nounit) {
+ r_cnjg(&q__2, &a[j + j * a_dim1]);
+ q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
+ tjjs.r = q__1.r, tjjs.i = q__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.f;
+ }
+ tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
+ dabs(r__2));
+ if (tjj > 1.f) {
+
+/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
+
+/* Computing MIN */
+ r__1 = 1.f, r__2 = rec * tjj;
+ rec = dmin(r__1,r__2);
+ cladiv_(&q__1, &uscal, &tjjs);
+ uscal.r = q__1.r, uscal.i = q__1.i;
+ }
+ if (rec < 1.f) {
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ csumj.r = 0.f, csumj.i = 0.f;
+ if (uscal.r == 1.f && uscal.i == 0.f) {
+
+/* If the scaling needed for A in the dot product is 1, */
+/* call CDOTC to perform the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ cdotc_(&q__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
+ &c__1);
+ csumj.r = q__1.r, csumj.i = q__1.i;
+ } else if (j < *n) {
+ i__3 = *n - j;
+ cdotc_(&q__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
+ x[j + 1], &c__1);
+ csumj.r = q__1.r, csumj.i = q__1.i;
+ }
+ } else {
+
+/* Otherwise, use in-line code for the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ r_cnjg(&q__4, &a[i__ + j * a_dim1]);
+ q__3.r = q__4.r * uscal.r - q__4.i * uscal.i,
+ q__3.i = q__4.r * uscal.i + q__4.i *
+ uscal.r;
+ i__4 = i__;
+ q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
+ q__2.i = q__3.r * x[i__4].i + q__3.i * x[
+ i__4].r;
+ q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
+ q__2.i;
+ csumj.r = q__1.r, csumj.i = q__1.i;
+/* L160: */
+ }
+ } else if (j < *n) {
+ i__3 = *n;
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ r_cnjg(&q__4, &a[i__ + j * a_dim1]);
+ q__3.r = q__4.r * uscal.r - q__4.i * uscal.i,
+ q__3.i = q__4.r * uscal.i + q__4.i *
+ uscal.r;
+ i__4 = i__;
+ q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
+ q__2.i = q__3.r * x[i__4].i + q__3.i * x[
+ i__4].r;
+ q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
+ q__2.i;
+ csumj.r = q__1.r, csumj.i = q__1.i;
+/* L170: */
+ }
+ }
+ }
+
+ q__1.r = tscal, q__1.i = 0.f;
+ if (uscal.r == q__1.r && uscal.i == q__1.i) {
+
+/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
+/* was not used to scale the dotproduct. */
+
+ i__3 = j;
+ i__4 = j;
+ q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i -
+ csumj.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ i__3 = j;
+ xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
+ ), dabs(r__2));
+ if (nounit) {
+ r_cnjg(&q__2, &a[j + j * a_dim1]);
+ q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
+ tjjs.r = q__1.r, tjjs.i = q__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.f;
+ if (tscal == 1.f) {
+ goto L185;
+ }
+ }
+
+/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
+
+ tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
+ dabs(r__2));
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.f) {
+ if (xj > tjj * bignum) {
+
+/* Scale X by 1/abs(x(j)). */
+
+ rec = 1.f / xj;
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ i__3 = j;
+ cladiv_(&q__1, &x[j], &tjjs);
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ } else if (tjj > 0.f) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
+
+ rec = tjj * bignum / xj;
+ csscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ i__3 = j;
+ cladiv_(&q__1, &x[j], &tjjs);
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0 and compute a solution to A**H *x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ x[i__4].r = 0.f, x[i__4].i = 0.f;
+/* L180: */
+ }
+ i__3 = j;
+ x[i__3].r = 1.f, x[i__3].i = 0.f;
+ *scale = 0.f;
+ xmax = 0.f;
+ }
+L185:
+ ;
+ } else {
+
+/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
+/* product has already been divided by 1/A(j,j). */
+
+ i__3 = j;
+ cladiv_(&q__2, &x[j], &tjjs);
+ q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ }
+/* Computing MAX */
+ i__3 = j;
+ r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[j]), dabs(r__2));
+ xmax = dmax(r__3,r__4);
+/* L190: */
+ }
+ }
+ *scale /= tscal;
+ }
+
+/* Scale the column norms by 1/TSCAL for return. */
+
+ if (tscal != 1.f) {
+ r__1 = 1.f / tscal;
+ sscal_(n, &r__1, &cnorm[1], &c__1);
+ }
+
+ return 0;
+
+/* End of CLATRS */
+
+} /* clatrs_ */
diff --git a/SRC/clatrz.c b/SRC/clatrz.c
new file mode 100644
index 0000000..59faa33
--- /dev/null
+++ b/SRC/clatrz.c
@@ -0,0 +1,180 @@
+/* clatrz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int clatrz_(integer *m, integer *n, integer *l, complex *a,
+ integer *lda, complex *tau, complex *work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ complex q__1;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__;
+ complex alpha;
+ extern /* Subroutine */ int clarz_(char *, integer *, integer *, integer *
+, complex *, integer *, complex *, complex *, integer *, complex *
+), clacgv_(integer *, complex *, integer *), clarfp_(
+ integer *, complex *, complex *, integer *, complex *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLATRZ factors the M-by-(M+L) complex upper trapezoidal matrix */
+/* [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z by means */
+/* of unitary transformations, where Z is an (M+L)-by-(M+L) unitary */
+/* matrix and, R and A1 are M-by-M upper triangular matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* L (input) INTEGER */
+/* The number of columns of the matrix A containing the */
+/* meaningful part of the Householder vectors. N-M >= L >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the leading M-by-N upper trapezoidal part of the */
+/* array A must contain the matrix to be factorized. */
+/* On exit, the leading M-by-M upper triangular part of A */
+/* contains the upper triangular matrix R, and elements N-L+1 to */
+/* N of the first M rows of A, with the array TAU, represent the */
+/* unitary matrix Z as a product of M elementary reflectors. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX array, dimension (M) */
+/* The scalar factors of the elementary reflectors. */
+
+/* WORK (workspace) COMPLEX array, dimension (M) */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* The factorization is obtained by Householder's method. The kth */
+/* transformation matrix, Z( k ), which is used to introduce zeros into */
+/* the ( m - k + 1 )th row of A, is given in the form */
+
+/* Z( k ) = ( I 0 ), */
+/* ( 0 T( k ) ) */
+
+/* where */
+
+/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */
+/* ( 0 ) */
+/* ( z( k ) ) */
+
+/* tau is a scalar and z( k ) is an l element vector. tau and z( k ) */
+/* are chosen to annihilate the elements of the kth row of A2. */
+
+/* The scalar tau is returned in the kth element of TAU and the vector */
+/* u( k ) in the kth row of A2, such that the elements of z( k ) are */
+/* in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in */
+/* the upper triangular part of A1. */
+
+/* Z is given by */
+
+/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ if (*m == 0) {
+ return 0;
+ } else if (*m == *n) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ tau[i__2].r = 0.f, tau[i__2].i = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+ for (i__ = *m; i__ >= 1; --i__) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* [ A(i,i) A(i,n-l+1:n) ] */
+
+ clacgv_(l, &a[i__ + (*n - *l + 1) * a_dim1], lda);
+ r_cnjg(&q__1, &a[i__ + i__ * a_dim1]);
+ alpha.r = q__1.r, alpha.i = q__1.i;
+ i__1 = *l + 1;
+ clarfp_(&i__1, &alpha, &a[i__ + (*n - *l + 1) * a_dim1], lda, &tau[
+ i__]);
+ i__1 = i__;
+ r_cnjg(&q__1, &tau[i__]);
+ tau[i__1].r = q__1.r, tau[i__1].i = q__1.i;
+
+/* Apply H(i) to A(1:i-1,i:n) from the right */
+
+ i__1 = i__ - 1;
+ i__2 = *n - i__ + 1;
+ r_cnjg(&q__1, &tau[i__]);
+ clarz_("Right", &i__1, &i__2, l, &a[i__ + (*n - *l + 1) * a_dim1],
+ lda, &q__1, &a[i__ * a_dim1 + 1], lda, &work[1]);
+ i__1 = i__ + i__ * a_dim1;
+ r_cnjg(&q__1, &alpha);
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+
+/* L20: */
+ }
+
+ return 0;
+
+/* End of CLATRZ */
+
+} /* clatrz_ */
diff --git a/SRC/clatzm.c b/SRC/clatzm.c
new file mode 100644
index 0000000..4daa3d4
--- /dev/null
+++ b/SRC/clatzm.c
@@ -0,0 +1,196 @@
+/* clatzm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int clatzm_(char *side, integer *m, integer *n, complex *v,
+ integer *incv, complex *tau, complex *c1, complex *c2, integer *ldc,
+ complex *work)
+{
+ /* System generated locals */
+ integer c1_dim1, c1_offset, c2_dim1, c2_offset, i__1;
+ complex q__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *),
+ cgemv_(char *, integer *, integer *, complex *, complex *,
+ integer *, complex *, integer *, complex *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cgeru_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *),
+ ccopy_(integer *, complex *, integer *, complex *, integer *),
+ caxpy_(integer *, complex *, complex *, integer *, complex *,
+ integer *), clacgv_(integer *, complex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine CUNMRZ. */
+
+/* CLATZM applies a Householder matrix generated by CTZRQF to a matrix. */
+
+/* Let P = I - tau*u*u', u = ( 1 ), */
+/* ( v ) */
+/* where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if */
+/* SIDE = 'R'. */
+
+/* If SIDE equals 'L', let */
+/* C = [ C1 ] 1 */
+/* [ C2 ] m-1 */
+/* n */
+/* Then C is overwritten by P*C. */
+
+/* If SIDE equals 'R', let */
+/* C = [ C1, C2 ] m */
+/* 1 n-1 */
+/* Then C is overwritten by C*P. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': form P * C */
+/* = 'R': form C * P */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* V (input) COMPLEX array, dimension */
+/* (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
+/* (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
+/* The vector v in the representation of P. V is not used */
+/* if TAU = 0. */
+
+/* INCV (input) INTEGER */
+/* The increment between elements of v. INCV <> 0 */
+
+/* TAU (input) COMPLEX */
+/* The value tau in the representation of P. */
+
+/* C1 (input/output) COMPLEX array, dimension */
+/* (LDC,N) if SIDE = 'L' */
+/* (M,1) if SIDE = 'R' */
+/* On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1 */
+/* if SIDE = 'R'. */
+
+/* On exit, the first row of P*C if SIDE = 'L', or the first */
+/* column of C*P if SIDE = 'R'. */
+
+/* C2 (input/output) COMPLEX array, dimension */
+/* (LDC, N) if SIDE = 'L' */
+/* (LDC, N-1) if SIDE = 'R' */
+/* On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the */
+/* m x (n - 1) matrix C2 if SIDE = 'R'. */
+
+/* On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P */
+/* if SIDE = 'R'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the arrays C1 and C2. */
+/* LDC >= max(1,M). */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (N) if SIDE = 'L' */
+/* (M) if SIDE = 'R' */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --v;
+ c2_dim1 = *ldc;
+ c2_offset = 1 + c2_dim1;
+ c2 -= c2_offset;
+ c1_dim1 = *ldc;
+ c1_offset = 1 + c1_dim1;
+ c1 -= c1_offset;
+ --work;
+
+ /* Function Body */
+ if (min(*m,*n) == 0 || tau->r == 0.f && tau->i == 0.f) {
+ return 0;
+ }
+
+ if (lsame_(side, "L")) {
+
+/* w := conjg( C1 + v' * C2 ) */
+
+ ccopy_(n, &c1[c1_offset], ldc, &work[1], &c__1);
+ clacgv_(n, &work[1], &c__1);
+ i__1 = *m - 1;
+ cgemv_("Conjugate transpose", &i__1, n, &c_b1, &c2[c2_offset], ldc, &
+ v[1], incv, &c_b1, &work[1], &c__1);
+
+/* [ C1 ] := [ C1 ] - tau* [ 1 ] * w' */
+/* [ C2 ] [ C2 ] [ v ] */
+
+ clacgv_(n, &work[1], &c__1);
+ q__1.r = -tau->r, q__1.i = -tau->i;
+ caxpy_(n, &q__1, &work[1], &c__1, &c1[c1_offset], ldc);
+ i__1 = *m - 1;
+ q__1.r = -tau->r, q__1.i = -tau->i;
+ cgeru_(&i__1, n, &q__1, &v[1], incv, &work[1], &c__1, &c2[c2_offset],
+ ldc);
+
+ } else if (lsame_(side, "R")) {
+
+/* w := C1 + C2 * v */
+
+ ccopy_(m, &c1[c1_offset], &c__1, &work[1], &c__1);
+ i__1 = *n - 1;
+ cgemv_("No transpose", m, &i__1, &c_b1, &c2[c2_offset], ldc, &v[1],
+ incv, &c_b1, &work[1], &c__1);
+
+/* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v'] */
+
+ q__1.r = -tau->r, q__1.i = -tau->i;
+ caxpy_(m, &q__1, &work[1], &c__1, &c1[c1_offset], &c__1);
+ i__1 = *n - 1;
+ q__1.r = -tau->r, q__1.i = -tau->i;
+ cgerc_(m, &i__1, &q__1, &work[1], &c__1, &v[1], incv, &c2[c2_offset],
+ ldc);
+ }
+
+ return 0;
+
+/* End of CLATZM */
+
+} /* clatzm_ */
diff --git a/SRC/clauu2.c b/SRC/clauu2.c
new file mode 100644
index 0000000..34f67f6
--- /dev/null
+++ b/SRC/clauu2.c
@@ -0,0 +1,203 @@
+/* clauu2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int clauu2_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1;
+ complex q__1;
+
+ /* Local variables */
+ integer i__;
+ real aii;
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *);
+ logical upper;
+ extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
+ csscal_(integer *, real *, complex *, integer *), xerbla_(char *,
+ integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAUU2 computes the product U * U' or L' * L, where the triangular */
+/* factor U or L is stored in the upper or lower triangular part of */
+/* the array A. */
+
+/* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */
+/* overwriting the factor U in A. */
+/* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */
+/* overwriting the factor L in A. */
+
+/* This is the unblocked form of the algorithm, calling Level 2 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the triangular factor stored in the array A */
+/* is upper or lower triangular: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the triangular factor U or L. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the triangular factor U or L. */
+/* On exit, if UPLO = 'U', the upper triangle of A is */
+/* overwritten with the upper triangle of the product U * U'; */
+/* if UPLO = 'L', the lower triangle of A is overwritten with */
+/* the lower triangle of the product L' * L. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLAUU2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Compute the product U * U'. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ aii = a[i__2].r;
+ if (i__ < *n) {
+ i__2 = i__ + i__ * a_dim1;
+ i__3 = *n - i__;
+ cdotc_(&q__1, &i__3, &a[i__ + (i__ + 1) * a_dim1], lda, &a[
+ i__ + (i__ + 1) * a_dim1], lda);
+ r__1 = aii * aii + q__1.r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ i__2 = *n - i__;
+ clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ q__1.r = aii, q__1.i = 0.f;
+ cgemv_("No transpose", &i__2, &i__3, &c_b1, &a[(i__ + 1) *
+ a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, &
+ q__1, &a[i__ * a_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
+ } else {
+ csscal_(&i__, &aii, &a[i__ * a_dim1 + 1], &c__1);
+ }
+/* L10: */
+ }
+
+ } else {
+
+/* Compute the product L' * L. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ aii = a[i__2].r;
+ if (i__ < *n) {
+ i__2 = i__ + i__ * a_dim1;
+ i__3 = *n - i__;
+ cdotc_(&q__1, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &a[
+ i__ + 1 + i__ * a_dim1], &c__1);
+ r__1 = aii * aii + q__1.r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ i__2 = i__ - 1;
+ clacgv_(&i__2, &a[i__ + a_dim1], lda);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ q__1.r = aii, q__1.i = 0.f;
+ cgemv_("Conjugate transpose", &i__2, &i__3, &c_b1, &a[i__ + 1
+ + a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &
+ q__1, &a[i__ + a_dim1], lda);
+ i__2 = i__ - 1;
+ clacgv_(&i__2, &a[i__ + a_dim1], lda);
+ } else {
+ csscal_(&i__, &aii, &a[i__ + a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of CLAUU2 */
+
+} /* clauu2_ */
diff --git a/SRC/clauum.c b/SRC/clauum.c
new file mode 100644
index 0000000..c6816a7
--- /dev/null
+++ b/SRC/clauum.c
@@ -0,0 +1,217 @@
+/* clauum.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b21 = 1.f;
+
+/* Subroutine */ int clauum_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, ib, nb;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), cherk_(char *,
+ char *, integer *, integer *, real *, complex *, integer *, real *
+, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *);
+ logical upper;
+ extern /* Subroutine */ int clauu2_(char *, integer *, complex *, integer
+ *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAUUM computes the product U * U' or L' * L, where the triangular */
+/* factor U or L is stored in the upper or lower triangular part of */
+/* the array A. */
+
+/* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */
+/* overwriting the factor U in A. */
+/* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */
+/* overwriting the factor L in A. */
+
+/* This is the blocked form of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the triangular factor stored in the array A */
+/* is upper or lower triangular: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the triangular factor U or L. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the triangular factor U or L. */
+/* On exit, if UPLO = 'U', the upper triangle of A is */
+/* overwritten with the upper triangle of the product U * U'; */
+/* if UPLO = 'L', the lower triangle of A is overwritten with */
+/* the lower triangle of the product L' * L. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLAUUM", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "CLAUUM", uplo, n, &c_n1, &c_n1, &c_n1);
+
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code */
+
+ clauu2_(uplo, n, &a[a_offset], lda, info);
+ } else {
+
+/* Use blocked code */
+
+ if (upper) {
+
+/* Compute the product U * U'. */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - i__ + 1;
+ ib = min(i__3,i__4);
+ i__3 = i__ - 1;
+ ctrmm_("Right", "Upper", "Conjugate transpose", "Non-unit", &
+ i__3, &ib, &c_b1, &a[i__ + i__ * a_dim1], lda, &a[i__
+ * a_dim1 + 1], lda);
+ clauu2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info);
+ if (i__ + ib <= *n) {
+ i__3 = i__ - 1;
+ i__4 = *n - i__ - ib + 1;
+ cgemm_("No transpose", "Conjugate transpose", &i__3, &ib,
+ &i__4, &c_b1, &a[(i__ + ib) * a_dim1 + 1], lda, &
+ a[i__ + (i__ + ib) * a_dim1], lda, &c_b1, &a[i__ *
+ a_dim1 + 1], lda);
+ i__3 = *n - i__ - ib + 1;
+ cherk_("Upper", "No transpose", &ib, &i__3, &c_b21, &a[
+ i__ + (i__ + ib) * a_dim1], lda, &c_b21, &a[i__ +
+ i__ * a_dim1], lda);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Compute the product L' * L. */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - i__ + 1;
+ ib = min(i__3,i__4);
+ i__3 = i__ - 1;
+ ctrmm_("Left", "Lower", "Conjugate transpose", "Non-unit", &
+ ib, &i__3, &c_b1, &a[i__ + i__ * a_dim1], lda, &a[i__
+ + a_dim1], lda);
+ clauu2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info);
+ if (i__ + ib <= *n) {
+ i__3 = i__ - 1;
+ i__4 = *n - i__ - ib + 1;
+ cgemm_("Conjugate transpose", "No transpose", &ib, &i__3,
+ &i__4, &c_b1, &a[i__ + ib + i__ * a_dim1], lda, &
+ a[i__ + ib + a_dim1], lda, &c_b1, &a[i__ + a_dim1]
+, lda);
+ i__3 = *n - i__ - ib + 1;
+ cherk_("Lower", "Conjugate transpose", &ib, &i__3, &c_b21,
+ &a[i__ + ib + i__ * a_dim1], lda, &c_b21, &a[i__
+ + i__ * a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CLAUUM */
+
+} /* clauum_ */
diff --git a/SRC/cpbcon.c b/SRC/cpbcon.c
new file mode 100644
index 0000000..6c32104
--- /dev/null
+++ b/SRC/cpbcon.c
@@ -0,0 +1,238 @@
+/* cpbcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cpbcon_(char *uplo, integer *n, integer *kd, complex *ab,
+ integer *ldab, real *anorm, real *rcond, complex *work, real *rwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer ix, kase;
+ real scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *);
+ extern integer icamax_(integer *, complex *, integer *);
+ real scalel;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clatbs_(char *, char *, char *, char *,
+ integer *, integer *, complex *, integer *, complex *, real *,
+ real *, integer *);
+ real scaleu;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int csrscl_(integer *, real *, complex *, integer
+ *);
+ char normin[1];
+ real smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPBCON estimates the reciprocal of the condition number (in the */
+/* 1-norm) of a complex Hermitian positive definite band matrix using */
+/* the Cholesky factorization A = U**H*U or A = L*L**H computed by */
+/* CPBTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular factor stored in AB; */
+/* = 'L': Lower triangular factor stored in AB. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**H*U or A = L*L**H of the band matrix A, stored in the */
+/* first KD+1 rows of the array. The j-th column of U or L is */
+/* stored in the j-th column of the array AB as follows: */
+/* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* ANORM (input) REAL */
+/* The 1-norm (or infinity-norm) of the Hermitian band matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*ldab < *kd + 1) {
+ *info = -5;
+ } else if (*anorm < 0.f) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPBCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.f;
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ } else if (*anorm == 0.f) {
+ return 0;
+ }
+
+ smlnum = slamch_("Safe minimum");
+
+/* Estimate the 1-norm of the inverse. */
+
+ kase = 0;
+ *(unsigned char *)normin = 'N';
+L10:
+ clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (upper) {
+
+/* Multiply by inv(U'). */
+
+ clatbs_("Upper", "Conjugate transpose", "Non-unit", normin, n, kd,
+ &ab[ab_offset], ldab, &work[1], &scalel, &rwork[1], info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(U). */
+
+ clatbs_("Upper", "No transpose", "Non-unit", normin, n, kd, &ab[
+ ab_offset], ldab, &work[1], &scaleu, &rwork[1], info);
+ } else {
+
+/* Multiply by inv(L). */
+
+ clatbs_("Lower", "No transpose", "Non-unit", normin, n, kd, &ab[
+ ab_offset], ldab, &work[1], &scalel, &rwork[1], info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(L'). */
+
+ clatbs_("Lower", "Conjugate transpose", "Non-unit", normin, n, kd,
+ &ab[ab_offset], ldab, &work[1], &scaleu, &rwork[1], info);
+ }
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ scale = scalel * scaleu;
+ if (scale != 1.f) {
+ ix = icamax_(n, &work[1], &c__1);
+ i__1 = ix;
+ if (scale < ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
+ work[ix]), dabs(r__2))) * smlnum || scale == 0.f) {
+ goto L20;
+ }
+ csrscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / ainvnm / *anorm;
+ }
+
+L20:
+
+ return 0;
+
+/* End of CPBCON */
+
+} /* cpbcon_ */
diff --git a/SRC/cpbequ.c b/SRC/cpbequ.c
new file mode 100644
index 0000000..d83df71
--- /dev/null
+++ b/SRC/cpbequ.c
@@ -0,0 +1,204 @@
+/* cpbequ.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cpbequ_(char *uplo, integer *n, integer *kd, complex *ab,
+ integer *ldab, real *s, real *scond, real *amax, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ real smin;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPBEQU computes row and column scalings intended to equilibrate a */
+/* Hermitian positive definite band matrix A and reduce its condition */
+/* number (with respect to the two-norm). S contains the scale factors, */
+/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
+/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
+/* choice of S puts the condition number of B within a factor N of the */
+/* smallest possible condition number over all possible diagonal */
+/* scalings. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular of A is stored; */
+/* = 'L': Lower triangular of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* The upper or lower triangle of the Hermitian band matrix A, */
+/* stored in the first KD+1 rows of the array. The j-th column */
+/* of A is stored in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array A. LDAB >= KD+1. */
+
+/* S (output) REAL array, dimension (N) */
+/* If INFO = 0, S contains the scale factors for A. */
+
+/* SCOND (output) REAL */
+/* If INFO = 0, S contains the ratio of the smallest S(i) to */
+/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
+/* large nor too small, it is not worth scaling by S. */
+
+/* AMAX (output) REAL */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --s;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*ldab < *kd + 1) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPBEQU", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *scond = 1.f;
+ *amax = 0.f;
+ return 0;
+ }
+
+ if (upper) {
+ j = *kd + 1;
+ } else {
+ j = 1;
+ }
+
+/* Initialize SMIN and AMAX. */
+
+ i__1 = j + ab_dim1;
+ s[1] = ab[i__1].r;
+ smin = s[1];
+ *amax = s[1];
+
+/* Find the minimum and maximum diagonal elements. */
+
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = j + i__ * ab_dim1;
+ s[i__] = ab[i__2].r;
+/* Computing MIN */
+ r__1 = smin, r__2 = s[i__];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = *amax, r__2 = s[i__];
+ *amax = dmax(r__1,r__2);
+/* L10: */
+ }
+
+ if (smin <= 0.f) {
+
+/* Find the first non-positive diagonal element and return. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] <= 0.f) {
+ *info = i__;
+ return 0;
+ }
+/* L20: */
+ }
+ } else {
+
+/* Set the scale factors to the reciprocals */
+/* of the diagonal elements. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s[i__] = 1.f / sqrt(s[i__]);
+/* L30: */
+ }
+
+/* Compute SCOND = min(S(I)) / max(S(I)) */
+
+ *scond = sqrt(smin) / sqrt(*amax);
+ }
+ return 0;
+
+/* End of CPBEQU */
+
+} /* cpbequ_ */
diff --git a/SRC/cpbrfs.c b/SRC/cpbrfs.c
new file mode 100644
index 0000000..43625c6
--- /dev/null
+++ b/SRC/cpbrfs.c
@@ -0,0 +1,482 @@
+/* cpbrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cpbrfs_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, complex *ab, integer *ldab, complex *afb, integer *ldafb,
+ complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *
+ berr, complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k, l;
+ real s, xk;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern /* Subroutine */ int chbmv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *);
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ integer count;
+ logical upper;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *), cpbtrs_(
+ char *, integer *, integer *, integer *, complex *, integer *,
+ complex *, integer *, integer *);
+ real lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPBRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is Hermitian positive definite */
+/* and banded, and provides error bounds and backward error estimates */
+/* for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* The upper or lower triangle of the Hermitian band matrix A, */
+/* stored in the first KD+1 rows of the array. The j-th column */
+/* of A is stored in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* AFB (input) COMPLEX array, dimension (LDAFB,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**H*U or A = L*L**H of the band matrix A as computed by */
+/* CPBTRF, in the same storage format as A (see AB). */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= KD+1. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by CPBTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldab < *kd + 1) {
+ *info = -6;
+ } else if (*ldafb < *kd + 1) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldx < max(1,*n)) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPBRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+/* Computing MIN */
+ i__1 = *n + 1, i__2 = (*kd << 1) + 2;
+ nz = min(i__1,i__2);
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.f;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ q__1.r = -1.f, q__1.i = -0.f;
+ chbmv_(uplo, n, kd, &q__1, &ab[ab_offset], ldab, &x[j * x_dim1 + 1], &
+ c__1, &c_b1, &work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[
+ i__ + j * b_dim1]), dabs(r__2));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j
+ * x_dim1]), dabs(r__2));
+ l = *kd + 1 - k;
+/* Computing MAX */
+ i__3 = 1, i__4 = k - *kd;
+ i__5 = k - 1;
+ for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
+ i__3 = l + i__ + k * ab_dim1;
+ rwork[i__] += ((r__1 = ab[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&ab[l + i__ + k * ab_dim1]), dabs(r__2))) *
+ xk;
+ i__3 = l + i__ + k * ab_dim1;
+ i__4 = i__ + j * x_dim1;
+ s += ((r__1 = ab[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ ab[l + i__ + k * ab_dim1]), dabs(r__2))) * ((r__3
+ = x[i__4].r, dabs(r__3)) + (r__4 = r_imag(&x[i__
+ + j * x_dim1]), dabs(r__4)));
+/* L40: */
+ }
+ i__5 = *kd + 1 + k * ab_dim1;
+ rwork[k] = rwork[k] + (r__1 = ab[i__5].r, dabs(r__1)) * xk +
+ s;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__5 = k + j * x_dim1;
+ xk = (r__1 = x[i__5].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j
+ * x_dim1]), dabs(r__2));
+ i__5 = k * ab_dim1 + 1;
+ rwork[k] += (r__1 = ab[i__5].r, dabs(r__1)) * xk;
+ l = 1 - k;
+/* Computing MIN */
+ i__3 = *n, i__4 = k + *kd;
+ i__5 = min(i__3,i__4);
+ for (i__ = k + 1; i__ <= i__5; ++i__) {
+ i__3 = l + i__ + k * ab_dim1;
+ rwork[i__] += ((r__1 = ab[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&ab[l + i__ + k * ab_dim1]), dabs(r__2))) *
+ xk;
+ i__3 = l + i__ + k * ab_dim1;
+ i__4 = i__ + j * x_dim1;
+ s += ((r__1 = ab[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ ab[l + i__ + k * ab_dim1]), dabs(r__2))) * ((r__3
+ = x[i__4].r, dabs(r__3)) + (r__4 = r_imag(&x[i__
+ + j * x_dim1]), dabs(r__4)));
+/* L60: */
+ }
+ rwork[k] += s;
+/* L70: */
+ }
+ }
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__5 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__5].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
+ s = dmax(r__3,r__4);
+ } else {
+/* Computing MAX */
+ i__5 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__5].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = dmax(r__3,r__4);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ cpbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[1], n,
+ info);
+ caxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use CLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__5 = i__;
+ rwork[i__] = (r__1 = work[i__5].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__];
+ } else {
+ i__5 = i__;
+ rwork[i__] = (r__1 = work[i__5].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__] + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ cpbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[1],
+ n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__5 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__3] * work[i__4].r, q__1.i = rwork[i__3]
+ * work[i__4].i;
+ work[i__5].r = q__1.r, work[i__5].i = q__1.i;
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__5 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__3] * work[i__4].r, q__1.i = rwork[i__3]
+ * work[i__4].i;
+ work[i__5].r = q__1.r, work[i__5].i = q__1.i;
+/* L120: */
+ }
+ cpbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[1],
+ n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__5 = i__ + j * x_dim1;
+ r__3 = lstres, r__4 = (r__1 = x[i__5].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + j * x_dim1]), dabs(r__2));
+ lstres = dmax(r__3,r__4);
+/* L130: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of CPBRFS */
+
+} /* cpbrfs_ */
diff --git a/SRC/cpbstf.c b/SRC/cpbstf.c
new file mode 100644
index 0000000..3770330
--- /dev/null
+++ b/SRC/cpbstf.c
@@ -0,0 +1,334 @@
+/* cpbstf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b9 = -1.f;
+
+/* Subroutine */ int cpbstf_(char *uplo, integer *n, integer *kd, complex *ab,
+ integer *ldab, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer j, m, km;
+ real ajj;
+ integer kld;
+ extern /* Subroutine */ int cher_(char *, integer *, real *, complex *,
+ integer *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
+ csscal_(integer *, real *, complex *, integer *), xerbla_(char *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPBSTF computes a split Cholesky factorization of a complex */
+/* Hermitian positive definite band matrix A. */
+
+/* This routine is designed to be used in conjunction with CHBGST. */
+
+/* The factorization has the form A = S**H*S where S is a band matrix */
+/* of the same bandwidth as A and the following structure: */
+
+/* S = ( U ) */
+/* ( M L ) */
+
+/* where U is upper triangular of order m = (n+kd)/2, and L is lower */
+/* triangular of order n-m. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first kd+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, if INFO = 0, the factor S from the split Cholesky */
+/* factorization A = S**H*S. See Further Details. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the factorization could not be completed, */
+/* because the updated element a(i,i) was negative; the */
+/* matrix A is not positive definite. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* N = 7, KD = 2: */
+
+/* S = ( s11 s12 s13 ) */
+/* ( s22 s23 s24 ) */
+/* ( s33 s34 ) */
+/* ( s44 ) */
+/* ( s53 s54 s55 ) */
+/* ( s64 s65 s66 ) */
+/* ( s75 s76 s77 ) */
+
+/* If UPLO = 'U', the array AB holds: */
+
+/* on entry: on exit: */
+
+/* * * a13 a24 a35 a46 a57 * * s13 s24 s53' s64' s75' */
+/* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54' s65' s76' */
+/* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 */
+
+/* If UPLO = 'L', the array AB holds: */
+
+/* on entry: on exit: */
+
+/* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 */
+/* a21 a32 a43 a54 a65 a76 * s12' s23' s34' s54 s65 s76 * */
+/* a31 a42 a53 a64 a64 * * s13' s24' s53 s64 s75 * * */
+
+/* Array elements marked * are not used by the routine; s12' denotes */
+/* conjg(s12); the diagonal elements of S are real. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*ldab < *kd + 1) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPBSTF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *ldab - 1;
+ kld = max(i__1,i__2);
+
+/* Set the splitting point m. */
+
+ m = (*n + *kd) / 2;
+
+ if (upper) {
+
+/* Factorize A(m+1:n,m+1:n) as L**H*L, and update A(1:m,1:m). */
+
+ i__1 = m + 1;
+ for (j = *n; j >= i__1; --j) {
+
+/* Compute s(j,j) and test for non-positive-definiteness. */
+
+ i__2 = *kd + 1 + j * ab_dim1;
+ ajj = ab[i__2].r;
+ if (ajj <= 0.f) {
+ i__2 = *kd + 1 + j * ab_dim1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.f;
+ goto L50;
+ }
+ ajj = sqrt(ajj);
+ i__2 = *kd + 1 + j * ab_dim1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.f;
+/* Computing MIN */
+ i__2 = j - 1;
+ km = min(i__2,*kd);
+
+/* Compute elements j-km:j-1 of the j-th column and update the */
+/* the leading submatrix within the band. */
+
+ r__1 = 1.f / ajj;
+ csscal_(&km, &r__1, &ab[*kd + 1 - km + j * ab_dim1], &c__1);
+ cher_("Upper", &km, &c_b9, &ab[*kd + 1 - km + j * ab_dim1], &c__1,
+ &ab[*kd + 1 + (j - km) * ab_dim1], &kld);
+/* L10: */
+ }
+
+/* Factorize the updated submatrix A(1:m,1:m) as U**H*U. */
+
+ i__1 = m;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute s(j,j) and test for non-positive-definiteness. */
+
+ i__2 = *kd + 1 + j * ab_dim1;
+ ajj = ab[i__2].r;
+ if (ajj <= 0.f) {
+ i__2 = *kd + 1 + j * ab_dim1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.f;
+ goto L50;
+ }
+ ajj = sqrt(ajj);
+ i__2 = *kd + 1 + j * ab_dim1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.f;
+/* Computing MIN */
+ i__2 = *kd, i__3 = m - j;
+ km = min(i__2,i__3);
+
+/* Compute elements j+1:j+km of the j-th row and update the */
+/* trailing submatrix within the band. */
+
+ if (km > 0) {
+ r__1 = 1.f / ajj;
+ csscal_(&km, &r__1, &ab[*kd + (j + 1) * ab_dim1], &kld);
+ clacgv_(&km, &ab[*kd + (j + 1) * ab_dim1], &kld);
+ cher_("Upper", &km, &c_b9, &ab[*kd + (j + 1) * ab_dim1], &kld,
+ &ab[*kd + 1 + (j + 1) * ab_dim1], &kld);
+ clacgv_(&km, &ab[*kd + (j + 1) * ab_dim1], &kld);
+ }
+/* L20: */
+ }
+ } else {
+
+/* Factorize A(m+1:n,m+1:n) as L**H*L, and update A(1:m,1:m). */
+
+ i__1 = m + 1;
+ for (j = *n; j >= i__1; --j) {
+
+/* Compute s(j,j) and test for non-positive-definiteness. */
+
+ i__2 = j * ab_dim1 + 1;
+ ajj = ab[i__2].r;
+ if (ajj <= 0.f) {
+ i__2 = j * ab_dim1 + 1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.f;
+ goto L50;
+ }
+ ajj = sqrt(ajj);
+ i__2 = j * ab_dim1 + 1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.f;
+/* Computing MIN */
+ i__2 = j - 1;
+ km = min(i__2,*kd);
+
+/* Compute elements j-km:j-1 of the j-th row and update the */
+/* trailing submatrix within the band. */
+
+ r__1 = 1.f / ajj;
+ csscal_(&km, &r__1, &ab[km + 1 + (j - km) * ab_dim1], &kld);
+ clacgv_(&km, &ab[km + 1 + (j - km) * ab_dim1], &kld);
+ cher_("Lower", &km, &c_b9, &ab[km + 1 + (j - km) * ab_dim1], &kld,
+ &ab[(j - km) * ab_dim1 + 1], &kld);
+ clacgv_(&km, &ab[km + 1 + (j - km) * ab_dim1], &kld);
+/* L30: */
+ }
+
+/* Factorize the updated submatrix A(1:m,1:m) as U**H*U. */
+
+ i__1 = m;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute s(j,j) and test for non-positive-definiteness. */
+
+ i__2 = j * ab_dim1 + 1;
+ ajj = ab[i__2].r;
+ if (ajj <= 0.f) {
+ i__2 = j * ab_dim1 + 1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.f;
+ goto L50;
+ }
+ ajj = sqrt(ajj);
+ i__2 = j * ab_dim1 + 1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.f;
+/* Computing MIN */
+ i__2 = *kd, i__3 = m - j;
+ km = min(i__2,i__3);
+
+/* Compute elements j+1:j+km of the j-th column and update the */
+/* trailing submatrix within the band. */
+
+ if (km > 0) {
+ r__1 = 1.f / ajj;
+ csscal_(&km, &r__1, &ab[j * ab_dim1 + 2], &c__1);
+ cher_("Lower", &km, &c_b9, &ab[j * ab_dim1 + 2], &c__1, &ab[(
+ j + 1) * ab_dim1 + 1], &kld);
+ }
+/* L40: */
+ }
+ }
+ return 0;
+
+L50:
+ *info = j;
+ return 0;
+
+/* End of CPBSTF */
+
+} /* cpbstf_ */
diff --git a/SRC/cpbsv.c b/SRC/cpbsv.c
new file mode 100644
index 0000000..4b59d79
--- /dev/null
+++ b/SRC/cpbsv.c
@@ -0,0 +1,182 @@
+/* cpbsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cpbsv_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, complex *ab, integer *ldab, complex *b, integer *ldb, integer *
+ info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), cpbtrf_(
+ char *, integer *, integer *, complex *, integer *, integer *), cpbtrs_(char *, integer *, integer *, integer *, complex
+ *, integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPBSV computes the solution to a complex system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N Hermitian positive definite band matrix and X */
+/* and B are N-by-NRHS matrices. */
+
+/* The Cholesky decomposition is used to factor A as */
+/* A = U**H * U, if UPLO = 'U', or */
+/* A = L * L**H, if UPLO = 'L', */
+/* where U is an upper triangular band matrix, and L is a lower */
+/* triangular band matrix, with the same number of superdiagonals or */
+/* subdiagonals as A. The factored form of A is then used to solve the */
+/* system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD). */
+/* See below for further details. */
+
+/* On exit, if INFO = 0, the triangular factor U or L from the */
+/* Cholesky factorization A = U**H*U or A = L*L**H of the band */
+/* matrix A, in the same storage format as A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i of A is not */
+/* positive definite, so the factorization could not be */
+/* completed, and the solution has not been computed. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* N = 6, KD = 2, and UPLO = 'U': */
+
+/* On entry: On exit: */
+
+/* * * a13 a24 a35 a46 * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+
+/* Similarly, if UPLO = 'L' the format of A is as follows: */
+
+/* On entry: On exit: */
+
+/* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */
+/* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */
+/* a31 a42 a53 a64 * * l31 l42 l53 l64 * * */
+
+/* Array elements marked * are not used by the routine. */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldab < *kd + 1) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPBSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ cpbtrf_(uplo, n, kd, &ab[ab_offset], ldab, info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ cpbtrs_(uplo, n, kd, nrhs, &ab[ab_offset], ldab, &b[b_offset], ldb,
+ info);
+
+ }
+ return 0;
+
+/* End of CPBSV */
+
+} /* cpbsv_ */
diff --git a/SRC/cpbsvx.c b/SRC/cpbsvx.c
new file mode 100644
index 0000000..f3ad88c
--- /dev/null
+++ b/SRC/cpbsvx.c
@@ -0,0 +1,523 @@
+/* cpbsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cpbsvx_(char *fact, char *uplo, integer *n, integer *kd,
+ integer *nrhs, complex *ab, integer *ldab, complex *afb, integer *
+ ldafb, char *equed, real *s, complex *b, integer *ldb, complex *x,
+ integer *ldx, real *rcond, real *ferr, real *berr, complex *work,
+ real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j, j1, j2;
+ real amax, smin, smax;
+ extern logical lsame_(char *, char *);
+ real scond, anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ logical equil, rcequ, upper;
+ extern doublereal clanhb_(char *, char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int claqhb_(char *, integer *, integer *, complex
+ *, integer *, real *, real *, real *, char *),
+ cpbcon_(char *, integer *, integer *, complex *, integer *, real *
+, real *, complex *, real *, integer *);
+ extern doublereal slamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), xerbla_(char *,
+ integer *), cpbequ_(char *, integer *, integer *, complex
+ *, integer *, real *, real *, real *, integer *), cpbrfs_(
+ char *, integer *, integer *, integer *, complex *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ real *, real *, complex *, real *, integer *);
+ real bignum;
+ extern /* Subroutine */ int cpbtrf_(char *, integer *, integer *, complex
+ *, integer *, integer *);
+ integer infequ;
+ extern /* Subroutine */ int cpbtrs_(char *, integer *, integer *, integer
+ *, complex *, integer *, complex *, integer *, integer *);
+ real smlnum;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPBSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to */
+/* compute the solution to a complex system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N Hermitian positive definite band matrix and X */
+/* and B are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+/* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
+
+/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */
+/* factor the matrix A (after equilibration if FACT = 'E') as */
+/* A = U**H * U, if UPLO = 'U', or */
+/* A = L * L**H, if UPLO = 'L', */
+/* where U is an upper triangular band matrix, and L is a lower */
+/* triangular band matrix. */
+
+/* 3. If the leading i-by-i principal minor is not positive definite, */
+/* then the routine returns with INFO = i. Otherwise, the factored */
+/* form of A is used to estimate the condition number of the matrix */
+/* A. If the reciprocal of the condition number is less than machine */
+/* precision, INFO = N+1 is returned as a warning, but the routine */
+/* still goes on to solve for X and compute error bounds as */
+/* described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(S) so that it solves the original system before */
+/* equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AFB contains the factored form of A. */
+/* If EQUED = 'Y', the matrix A has been equilibrated */
+/* with scaling factors given by S. AB and AFB will not */
+/* be modified. */
+/* = 'N': The matrix A will be copied to AFB and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AFB and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right-hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first KD+1 rows of the array, except */
+/* if FACT = 'F' and EQUED = 'Y', then A must contain the */
+/* equilibrated matrix diag(S)*A*diag(S). The j-th column of A */
+/* is stored in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD). */
+/* See below for further details. */
+
+/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
+/* diag(S)*A*diag(S). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array A. LDAB >= KD+1. */
+
+/* AFB (input or output) COMPLEX array, dimension (LDAFB,N) */
+/* If FACT = 'F', then AFB is an input argument and on entry */
+/* contains the triangular factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H of the band matrix */
+/* A, in the same storage format as A (see AB). If EQUED = 'Y', */
+/* then AFB is the factored form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AFB is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H. */
+
+/* If FACT = 'E', then AFB is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H of the equilibrated */
+/* matrix A (see the description of A for the form of the */
+/* equilibrated matrix). */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= KD+1. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* S (input or output) REAL array, dimension (N) */
+/* The scale factors for A; not accessed if EQUED = 'N'. S is */
+/* an input argument if FACT = 'F'; otherwise, S is an output */
+/* argument. If FACT = 'F' and EQUED = 'Y', each element of S */
+/* must be positive. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */
+/* B is overwritten by diag(S) * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */
+/* the original system of equations. Note that if EQUED = 'Y', */
+/* A and B are modified on exit, and the solution to the */
+/* equilibrated system is inv(diag(S))*X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A after equilibration (if done). If RCOND is less than the */
+/* machine precision (in particular, if RCOND = 0), the matrix */
+/* is singular to working precision. This condition is */
+/* indicated by a return code of INFO > 0. */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: the leading minor of order i of A is */
+/* not positive definite, so the factorization */
+/* could not be completed, and the solution has not */
+/* been computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* N = 6, KD = 2, and UPLO = 'U': */
+
+/* Two-dimensional storage of the Hermitian matrix A: */
+
+/* a11 a12 a13 */
+/* a22 a23 a24 */
+/* a33 a34 a35 */
+/* a44 a45 a46 */
+/* a55 a56 */
+/* (aij=conjg(aji)) a66 */
+
+/* Band storage of the upper triangle of A: */
+
+/* * * a13 a24 a35 a46 */
+/* * a12 a23 a34 a45 a56 */
+/* a11 a22 a33 a44 a55 a66 */
+
+/* Similarly, if UPLO = 'L' the format of A is as follows: */
+
+/* a11 a22 a33 a44 a55 a66 */
+/* a21 a32 a43 a54 a65 * */
+/* a31 a42 a53 a64 * * */
+
+/* Array elements marked * are not used by the routine. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ upper = lsame_(uplo, "U");
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rcequ = FALSE_;
+ } else {
+ rcequ = lsame_(equed, "Y");
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ }
+
+/* Test the input parameters. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kd < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*ldab < *kd + 1) {
+ *info = -7;
+ } else if (*ldafb < *kd + 1) {
+ *info = -9;
+ } else if (lsame_(fact, "F") && ! (rcequ || lsame_(
+ equed, "N"))) {
+ *info = -10;
+ } else {
+ if (rcequ) {
+ smin = bignum;
+ smax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = smin, r__2 = s[j];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = smax, r__2 = s[j];
+ smax = dmax(r__1,r__2);
+/* L10: */
+ }
+ if (smin <= 0.f) {
+ *info = -11;
+ } else if (*n > 0) {
+ scond = dmax(smin,smlnum) / dmin(smax,bignum);
+ } else {
+ scond = 1.f;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -13;
+ } else if (*ldx < max(1,*n)) {
+ *info = -15;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPBSVX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ cpbequ_(uplo, n, kd, &ab[ab_offset], ldab, &s[1], &scond, &amax, &
+ infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ claqhb_(uplo, n, kd, &ab[ab_offset], ldab, &s[1], &scond, &amax,
+ equed);
+ rcequ = lsame_(equed, "Y");
+ }
+ }
+
+/* Scale the right-hand side. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * b_dim1;
+ q__1.r = s[i__4] * b[i__5].r, q__1.i = s[i__4] * b[i__5].i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L20: */
+ }
+/* L30: */
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j - *kd;
+ j1 = max(i__2,1);
+ i__2 = j - j1 + 1;
+ ccopy_(&i__2, &ab[*kd + 1 - j + j1 + j * ab_dim1], &c__1, &
+ afb[*kd + 1 - j + j1 + j * afb_dim1], &c__1);
+/* L40: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = j + *kd;
+ j2 = min(i__2,*n);
+ i__2 = j2 - j + 1;
+ ccopy_(&i__2, &ab[j * ab_dim1 + 1], &c__1, &afb[j * afb_dim1
+ + 1], &c__1);
+/* L50: */
+ }
+ }
+
+ cpbtrf_(uplo, n, kd, &afb[afb_offset], ldafb, info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.f;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = clanhb_("1", uplo, n, kd, &ab[ab_offset], ldab, &rwork[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ cpbcon_(uplo, n, kd, &afb[afb_offset], ldafb, &anorm, rcond, &work[1], &
+ rwork[1], info);
+
+/* Compute the solution matrix X. */
+
+ clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ cpbtrs_(uplo, n, kd, nrhs, &afb[afb_offset], ldafb, &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ cpbrfs_(uplo, n, kd, nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb,
+ &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1]
+, &rwork[1], info);
+
+/* Transform the solution matrix X to a solution of the original */
+/* system. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * x_dim1;
+ q__1.r = s[i__4] * x[i__5].r, q__1.i = s[i__4] * x[i__5].i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+/* L60: */
+ }
+/* L70: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= scond;
+/* L80: */
+ }
+ }
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < slamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of CPBSVX */
+
+} /* cpbsvx_ */
diff --git a/SRC/cpbtf2.c b/SRC/cpbtf2.c
new file mode 100644
index 0000000..eab52ff
--- /dev/null
+++ b/SRC/cpbtf2.c
@@ -0,0 +1,255 @@
+/* cpbtf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b8 = -1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int cpbtf2_(char *uplo, integer *n, integer *kd, complex *ab,
+ integer *ldab, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer j, kn;
+ real ajj;
+ integer kld;
+ extern /* Subroutine */ int cher_(char *, integer *, real *, complex *,
+ integer *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
+ csscal_(integer *, real *, complex *, integer *), xerbla_(char *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPBTF2 computes the Cholesky factorization of a complex Hermitian */
+/* positive definite band matrix A. */
+
+/* The factorization has the form */
+/* A = U' * U , if UPLO = 'U', or */
+/* A = L * L', if UPLO = 'L', */
+/* where U is an upper triangular matrix, U' is the conjugate transpose */
+/* of U, and L is lower triangular. */
+
+/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, if INFO = 0, the triangular factor U or L from the */
+/* Cholesky factorization A = U'*U or A = L*L' of the band */
+/* matrix A, in the same storage format as A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, the leading minor of order k is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* N = 6, KD = 2, and UPLO = 'U': */
+
+/* On entry: On exit: */
+
+/* * * a13 a24 a35 a46 * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+
+/* Similarly, if UPLO = 'L' the format of A is as follows: */
+
+/* On entry: On exit: */
+
+/* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */
+/* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */
+/* a31 a42 a53 a64 * * l31 l42 l53 l64 * * */
+
+/* Array elements marked * are not used by the routine. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*ldab < *kd + 1) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPBTF2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *ldab - 1;
+ kld = max(i__1,i__2);
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute U(J,J) and test for non-positive-definiteness. */
+
+ i__2 = *kd + 1 + j * ab_dim1;
+ ajj = ab[i__2].r;
+ if (ajj <= 0.f) {
+ i__2 = *kd + 1 + j * ab_dim1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.f;
+ goto L30;
+ }
+ ajj = sqrt(ajj);
+ i__2 = *kd + 1 + j * ab_dim1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.f;
+
+/* Compute elements J+1:J+KN of row J and update the */
+/* trailing submatrix within the band. */
+
+/* Computing MIN */
+ i__2 = *kd, i__3 = *n - j;
+ kn = min(i__2,i__3);
+ if (kn > 0) {
+ r__1 = 1.f / ajj;
+ csscal_(&kn, &r__1, &ab[*kd + (j + 1) * ab_dim1], &kld);
+ clacgv_(&kn, &ab[*kd + (j + 1) * ab_dim1], &kld);
+ cher_("Upper", &kn, &c_b8, &ab[*kd + (j + 1) * ab_dim1], &kld,
+ &ab[*kd + 1 + (j + 1) * ab_dim1], &kld);
+ clacgv_(&kn, &ab[*kd + (j + 1) * ab_dim1], &kld);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute L(J,J) and test for non-positive-definiteness. */
+
+ i__2 = j * ab_dim1 + 1;
+ ajj = ab[i__2].r;
+ if (ajj <= 0.f) {
+ i__2 = j * ab_dim1 + 1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.f;
+ goto L30;
+ }
+ ajj = sqrt(ajj);
+ i__2 = j * ab_dim1 + 1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.f;
+
+/* Compute elements J+1:J+KN of column J and update the */
+/* trailing submatrix within the band. */
+
+/* Computing MIN */
+ i__2 = *kd, i__3 = *n - j;
+ kn = min(i__2,i__3);
+ if (kn > 0) {
+ r__1 = 1.f / ajj;
+ csscal_(&kn, &r__1, &ab[j * ab_dim1 + 2], &c__1);
+ cher_("Lower", &kn, &c_b8, &ab[j * ab_dim1 + 2], &c__1, &ab[(
+ j + 1) * ab_dim1 + 1], &kld);
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+L30:
+ *info = j;
+ return 0;
+
+/* End of CPBTF2 */
+
+} /* cpbtf2_ */
diff --git a/SRC/cpbtrf.c b/SRC/cpbtrf.c
new file mode 100644
index 0000000..7d08412
--- /dev/null
+++ b/SRC/cpbtrf.c
@@ -0,0 +1,489 @@
+/* cpbtrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b21 = -1.f;
+static real c_b22 = 1.f;
+static integer c__33 = 33;
+
+/* Subroutine */ int cpbtrf_(char *uplo, integer *n, integer *kd, complex *ab,
+ integer *ldab, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j, i2, i3, ib, nb, ii, jj;
+ complex work[1056] /* was [33][32] */;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), cherk_(char *,
+ char *, integer *, integer *, real *, complex *, integer *, real *
+, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *), cpbtf2_(char *,
+ integer *, integer *, complex *, integer *, integer *),
+ cpotf2_(char *, integer *, complex *, integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPBTRF computes the Cholesky factorization of a complex Hermitian */
+/* positive definite band matrix A. */
+
+/* The factorization has the form */
+/* A = U**H * U, if UPLO = 'U', or */
+/* A = L * L**H, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, if INFO = 0, the triangular factor U or L from the */
+/* Cholesky factorization A = U**H*U or A = L*L**H of the band */
+/* matrix A, in the same storage format as A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* N = 6, KD = 2, and UPLO = 'U': */
+
+/* On entry: On exit: */
+
+/* * * a13 a24 a35 a46 * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+
+/* Similarly, if UPLO = 'L' the format of A is as follows: */
+
+/* On entry: On exit: */
+
+/* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */
+/* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */
+/* a31 a42 a53 a64 * * l31 l42 l53 l64 * * */
+
+/* Array elements marked * are not used by the routine. */
+
+/* Contributed by */
+/* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*ldab < *kd + 1) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPBTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment */
+
+ nb = ilaenv_(&c__1, "CPBTRF", uplo, n, kd, &c_n1, &c_n1);
+
+/* The block size must not exceed the semi-bandwidth KD, and must not */
+/* exceed the limit set by the size of the local array WORK. */
+
+ nb = min(nb,32);
+
+ if (nb <= 1 || nb > *kd) {
+
+/* Use unblocked code */
+
+ cpbtf2_(uplo, n, kd, &ab[ab_offset], ldab, info);
+ } else {
+
+/* Use blocked code */
+
+ if (lsame_(uplo, "U")) {
+
+/* Compute the Cholesky factorization of a Hermitian band */
+/* matrix, given the upper triangle of the matrix in band */
+/* storage. */
+
+/* Zero the upper triangle of the work array. */
+
+ i__1 = nb;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 33 - 34;
+ work[i__3].r = 0.f, work[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Process the band matrix one diagonal block at a time. */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - i__ + 1;
+ ib = min(i__3,i__4);
+
+/* Factorize the diagonal block */
+
+ i__3 = *ldab - 1;
+ cpotf2_(uplo, &ib, &ab[*kd + 1 + i__ * ab_dim1], &i__3, &ii);
+ if (ii != 0) {
+ *info = i__ + ii - 1;
+ goto L150;
+ }
+ if (i__ + ib <= *n) {
+
+/* Update the relevant part of the trailing submatrix. */
+/* If A11 denotes the diagonal block which has just been */
+/* factorized, then we need to update the remaining */
+/* blocks in the diagram: */
+
+/* A11 A12 A13 */
+/* A22 A23 */
+/* A33 */
+
+/* The numbers of rows and columns in the partitioning */
+/* are IB, I2, I3 respectively. The blocks A12, A22 and */
+/* A23 are empty if IB = KD. The upper triangle of A13 */
+/* lies outside the band. */
+
+/* Computing MIN */
+ i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
+ i2 = min(i__3,i__4);
+/* Computing MIN */
+ i__3 = ib, i__4 = *n - i__ - *kd + 1;
+ i3 = min(i__3,i__4);
+
+ if (i2 > 0) {
+
+/* Update A12 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ ctrsm_("Left", "Upper", "Conjugate transpose", "Non-"
+ "unit", &ib, &i2, &c_b1, &ab[*kd + 1 + i__ *
+ ab_dim1], &i__3, &ab[*kd + 1 - ib + (i__ + ib)
+ * ab_dim1], &i__4);
+
+/* Update A22 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ cherk_("Upper", "Conjugate transpose", &i2, &ib, &
+ c_b21, &ab[*kd + 1 - ib + (i__ + ib) *
+ ab_dim1], &i__3, &c_b22, &ab[*kd + 1 + (i__ +
+ ib) * ab_dim1], &i__4);
+ }
+
+ if (i3 > 0) {
+
+/* Copy the lower triangle of A13 into the work array. */
+
+ i__3 = i3;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = ib;
+ for (ii = jj; ii <= i__4; ++ii) {
+ i__5 = ii + jj * 33 - 34;
+ i__6 = ii - jj + 1 + (jj + i__ + *kd - 1) *
+ ab_dim1;
+ work[i__5].r = ab[i__6].r, work[i__5].i = ab[
+ i__6].i;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Update A13 (in the work array). */
+
+ i__3 = *ldab - 1;
+ ctrsm_("Left", "Upper", "Conjugate transpose", "Non-"
+ "unit", &ib, &i3, &c_b1, &ab[*kd + 1 + i__ *
+ ab_dim1], &i__3, work, &c__33);
+
+/* Update A23 */
+
+ if (i2 > 0) {
+ q__1.r = -1.f, q__1.i = -0.f;
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ cgemm_("Conjugate transpose", "No transpose", &i2,
+ &i3, &ib, &q__1, &ab[*kd + 1 - ib + (i__
+ + ib) * ab_dim1], &i__3, work, &c__33, &
+ c_b1, &ab[ib + 1 + (i__ + *kd) * ab_dim1],
+ &i__4);
+ }
+
+/* Update A33 */
+
+ i__3 = *ldab - 1;
+ cherk_("Upper", "Conjugate transpose", &i3, &ib, &
+ c_b21, work, &c__33, &c_b22, &ab[*kd + 1 + (
+ i__ + *kd) * ab_dim1], &i__3);
+
+/* Copy the lower triangle of A13 back into place. */
+
+ i__3 = i3;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = ib;
+ for (ii = jj; ii <= i__4; ++ii) {
+ i__5 = ii - jj + 1 + (jj + i__ + *kd - 1) *
+ ab_dim1;
+ i__6 = ii + jj * 33 - 34;
+ ab[i__5].r = work[i__6].r, ab[i__5].i = work[
+ i__6].i;
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+ }
+/* L70: */
+ }
+ } else {
+
+/* Compute the Cholesky factorization of a Hermitian band */
+/* matrix, given the lower triangle of the matrix in band */
+/* storage. */
+
+/* Zero the lower triangle of the work array. */
+
+ i__2 = nb;
+ for (j = 1; j <= i__2; ++j) {
+ i__1 = nb;
+ for (i__ = j + 1; i__ <= i__1; ++i__) {
+ i__3 = i__ + j * 33 - 34;
+ work[i__3].r = 0.f, work[i__3].i = 0.f;
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Process the band matrix one diagonal block at a time. */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - i__ + 1;
+ ib = min(i__3,i__4);
+
+/* Factorize the diagonal block */
+
+ i__3 = *ldab - 1;
+ cpotf2_(uplo, &ib, &ab[i__ * ab_dim1 + 1], &i__3, &ii);
+ if (ii != 0) {
+ *info = i__ + ii - 1;
+ goto L150;
+ }
+ if (i__ + ib <= *n) {
+
+/* Update the relevant part of the trailing submatrix. */
+/* If A11 denotes the diagonal block which has just been */
+/* factorized, then we need to update the remaining */
+/* blocks in the diagram: */
+
+/* A11 */
+/* A21 A22 */
+/* A31 A32 A33 */
+
+/* The numbers of rows and columns in the partitioning */
+/* are IB, I2, I3 respectively. The blocks A21, A22 and */
+/* A32 are empty if IB = KD. The lower triangle of A31 */
+/* lies outside the band. */
+
+/* Computing MIN */
+ i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
+ i2 = min(i__3,i__4);
+/* Computing MIN */
+ i__3 = ib, i__4 = *n - i__ - *kd + 1;
+ i3 = min(i__3,i__4);
+
+ if (i2 > 0) {
+
+/* Update A21 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ ctrsm_("Right", "Lower", "Conjugate transpose", "Non"
+ "-unit", &i2, &ib, &c_b1, &ab[i__ * ab_dim1 +
+ 1], &i__3, &ab[ib + 1 + i__ * ab_dim1], &i__4);
+
+/* Update A22 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ cherk_("Lower", "No transpose", &i2, &ib, &c_b21, &ab[
+ ib + 1 + i__ * ab_dim1], &i__3, &c_b22, &ab[(
+ i__ + ib) * ab_dim1 + 1], &i__4);
+ }
+
+ if (i3 > 0) {
+
+/* Copy the upper triangle of A31 into the work array. */
+
+ i__3 = ib;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = min(jj,i3);
+ for (ii = 1; ii <= i__4; ++ii) {
+ i__5 = ii + jj * 33 - 34;
+ i__6 = *kd + 1 - jj + ii + (jj + i__ - 1) *
+ ab_dim1;
+ work[i__5].r = ab[i__6].r, work[i__5].i = ab[
+ i__6].i;
+/* L100: */
+ }
+/* L110: */
+ }
+
+/* Update A31 (in the work array). */
+
+ i__3 = *ldab - 1;
+ ctrsm_("Right", "Lower", "Conjugate transpose", "Non"
+ "-unit", &i3, &ib, &c_b1, &ab[i__ * ab_dim1 +
+ 1], &i__3, work, &c__33);
+
+/* Update A32 */
+
+ if (i2 > 0) {
+ q__1.r = -1.f, q__1.i = -0.f;
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ cgemm_("No transpose", "Conjugate transpose", &i3,
+ &i2, &ib, &q__1, work, &c__33, &ab[ib +
+ 1 + i__ * ab_dim1], &i__3, &c_b1, &ab[*kd
+ + 1 - ib + (i__ + ib) * ab_dim1], &i__4);
+ }
+
+/* Update A33 */
+
+ i__3 = *ldab - 1;
+ cherk_("Lower", "No transpose", &i3, &ib, &c_b21,
+ work, &c__33, &c_b22, &ab[(i__ + *kd) *
+ ab_dim1 + 1], &i__3);
+
+/* Copy the upper triangle of A31 back into place. */
+
+ i__3 = ib;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = min(jj,i3);
+ for (ii = 1; ii <= i__4; ++ii) {
+ i__5 = *kd + 1 - jj + ii + (jj + i__ - 1) *
+ ab_dim1;
+ i__6 = ii + jj * 33 - 34;
+ ab[i__5].r = work[i__6].r, ab[i__5].i = work[
+ i__6].i;
+/* L120: */
+ }
+/* L130: */
+ }
+ }
+ }
+/* L140: */
+ }
+ }
+ }
+ return 0;
+
+L150:
+ return 0;
+
+/* End of CPBTRF */
+
+} /* cpbtrf_ */
diff --git a/SRC/cpbtrs.c b/SRC/cpbtrs.c
new file mode 100644
index 0000000..d325213
--- /dev/null
+++ b/SRC/cpbtrs.c
@@ -0,0 +1,184 @@
+/* cpbtrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cpbtrs_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, complex *ab, integer *ldab, complex *b, integer *ldb, integer *
+ info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ integer j;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ctbsv_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPBTRS solves a system of linear equations A*X = B with a Hermitian */
+/* positive definite band matrix A using the Cholesky factorization */
+/* A = U**H*U or A = L*L**H computed by CPBTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular factor stored in AB; */
+/* = 'L': Lower triangular factor stored in AB. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**H*U or A = L*L**H of the band matrix A, stored in the */
+/* first KD+1 rows of the array. The j-th column of U or L is */
+/* stored in the j-th column of the array AB as follows: */
+/* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldab < *kd + 1) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPBTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B where A = U'*U. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve U'*X = B, overwriting B with X. */
+
+ ctbsv_("Upper", "Conjugate transpose", "Non-unit", n, kd, &ab[
+ ab_offset], ldab, &b[j * b_dim1 + 1], &c__1);
+
+/* Solve U*X = B, overwriting B with X. */
+
+ ctbsv_("Upper", "No transpose", "Non-unit", n, kd, &ab[ab_offset],
+ ldab, &b[j * b_dim1 + 1], &c__1);
+/* L10: */
+ }
+ } else {
+
+/* Solve A*X = B where A = L*L'. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve L*X = B, overwriting B with X. */
+
+ ctbsv_("Lower", "No transpose", "Non-unit", n, kd, &ab[ab_offset],
+ ldab, &b[j * b_dim1 + 1], &c__1);
+
+/* Solve L'*X = B, overwriting B with X. */
+
+ ctbsv_("Lower", "Conjugate transpose", "Non-unit", n, kd, &ab[
+ ab_offset], ldab, &b[j * b_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of CPBTRS */
+
+} /* cpbtrs_ */
diff --git a/SRC/cpftrf.c b/SRC/cpftrf.c
new file mode 100644
index 0000000..85bdab7
--- /dev/null
+++ b/SRC/cpftrf.c
@@ -0,0 +1,475 @@
+/* cpftrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static real c_b15 = -1.f;
+static real c_b16 = 1.f;
+
+/* Subroutine */ int cpftrf_(char *transr, char *uplo, integer *n, complex *a,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer k, n1, n2;
+ logical normaltransr;
+ extern /* Subroutine */ int cherk_(char *, char *, integer *, integer *,
+ real *, complex *, integer *, real *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *), xerbla_(char *,
+ integer *);
+ logical nisodd;
+ extern /* Subroutine */ int cpotrf_(char *, integer *, complex *, integer
+ *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPFTRF computes the Cholesky factorization of a complex Hermitian */
+/* positive definite matrix A. */
+
+/* The factorization has the form */
+/* A = U**H * U, if UPLO = 'U', or */
+/* A = L * L**H, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* This is the block version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': The Normal TRANSR of RFP A is stored; */
+/* = 'C': The Conjugate-transpose TRANSR of RFP A is stored. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': Upper triangle of RFP A is stored; */
+/* = 'L': Lower triangle of RFP A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension ( N*(N+1)/2 ); */
+/* On entry, the Hermitian matrix A in RFP format. RFP format is */
+/* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' */
+/* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */
+/* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is */
+/* the Conjugate-transpose of RFP A as defined when */
+/* TRANSR = 'N'. The contents of RFP A are defined by UPLO as */
+/* follows: If UPLO = 'U' the RFP A contains the nt elements of */
+/* upper packed A. If UPLO = 'L' the RFP A contains the elements */
+/* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = */
+/* 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N */
+/* is odd. See the Note below for more details. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization RFP A = U**H*U or RFP A = L*L**H. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* Further Notes on RFP Format: */
+/* ============================ */
+
+
+/* We first consider Standard Packed Format when N is even. */
+/* We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* conjugate-transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* conjugate-transpose of the last three columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- -- */
+/* 03 04 05 33 43 53 */
+/* -- -- */
+/* 13 14 15 00 44 54 */
+/* -- */
+/* 23 24 25 10 11 55 */
+
+/* 33 34 35 20 21 22 */
+/* -- */
+/* 00 44 45 30 31 32 */
+/* -- -- */
+/* 01 11 55 40 41 42 */
+/* -- -- -- */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We next consider Standard Packed Format when N is odd. */
+/* We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* conjugate-transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* conjugate-transpose of the last two columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- */
+/* 02 03 04 00 33 43 */
+/* -- */
+/* 12 13 14 10 11 44 */
+
+/* 22 23 24 20 21 22 */
+/* -- */
+/* 00 33 34 30 31 32 */
+/* -- -- */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- */
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "C")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPFTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* If N is odd, set NISODD = .TRUE. */
+/* If N is even, set K = N/2 and NISODD = .FALSE. */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ } else {
+ nisodd = TRUE_;
+ }
+
+/* Set N1 and N2 depending on LOWER */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* start execution: there are eight cases */
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */
+/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */
+/* T1 -> a(0), T2 -> a(n), S -> a(n1) */
+
+ cpotrf_("L", &n1, a, n, info);
+ if (*info > 0) {
+ return 0;
+ }
+ ctrsm_("R", "L", "C", "N", &n2, &n1, &c_b1, a, n, &a[n1], n);
+ cherk_("U", "N", &n2, &n1, &c_b15, &a[n1], n, &c_b16, &a[*n],
+ n);
+ cpotrf_("U", &n2, &a[*n], n, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */
+/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */
+/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */
+
+ cpotrf_("L", &n1, &a[n2], n, info);
+ if (*info > 0) {
+ return 0;
+ }
+ ctrsm_("L", "L", "N", "N", &n1, &n2, &c_b1, &a[n2], n, a, n);
+ cherk_("U", "C", &n2, &n1, &c_b15, a, n, &c_b16, &a[n1], n);
+ cpotrf_("U", &n2, &a[n1], n, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is odd */
+/* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */
+/* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 */
+
+ cpotrf_("U", &n1, a, &n1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ ctrsm_("L", "U", "C", "N", &n1, &n2, &c_b1, a, &n1, &a[n1 *
+ n1], &n1);
+ cherk_("L", "C", &n2, &n1, &c_b15, &a[n1 * n1], &n1, &c_b16, &
+ a[1], &n1);
+ cpotrf_("L", &n2, &a[1], &n1, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is odd */
+/* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */
+/* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 */
+
+ cpotrf_("U", &n1, &a[n2 * n2], &n2, info);
+ if (*info > 0) {
+ return 0;
+ }
+ ctrsm_("R", "U", "N", "N", &n2, &n1, &c_b1, &a[n2 * n2], &n2,
+ a, &n2);
+ cherk_("L", "N", &n2, &n1, &c_b15, a, &n2, &c_b16, &a[n1 * n2]
+, &n2);
+ cpotrf_("L", &n2, &a[n1 * n2], &n2, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
+/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */
+
+ i__1 = *n + 1;
+ cpotrf_("L", &k, &a[1], &i__1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ ctrsm_("R", "L", "C", "N", &k, &k, &c_b1, &a[1], &i__1, &a[k
+ + 1], &i__2);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ cherk_("U", "N", &k, &k, &c_b15, &a[k + 1], &i__1, &c_b16, a,
+ &i__2);
+ i__1 = *n + 1;
+ cpotrf_("U", &k, a, &i__1, info);
+ if (*info > 0) {
+ *info += k;
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
+/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */
+
+ i__1 = *n + 1;
+ cpotrf_("L", &k, &a[k + 1], &i__1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ ctrsm_("L", "L", "N", "N", &k, &k, &c_b1, &a[k + 1], &i__1, a,
+ &i__2);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ cherk_("U", "C", &k, &k, &c_b15, a, &i__1, &c_b16, &a[k], &
+ i__2);
+ i__1 = *n + 1;
+ cpotrf_("U", &k, &a[k], &i__1, info);
+ if (*info > 0) {
+ *info += k;
+ }
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */
+/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */
+
+ cpotrf_("U", &k, &a[k], &k, info);
+ if (*info > 0) {
+ return 0;
+ }
+ ctrsm_("L", "U", "C", "N", &k, &k, &c_b1, &a[k], &n1, &a[k * (
+ k + 1)], &k);
+ cherk_("L", "C", &k, &k, &c_b15, &a[k * (k + 1)], &k, &c_b16,
+ a, &k);
+ cpotrf_("L", &k, a, &k, info);
+ if (*info > 0) {
+ *info += k;
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */
+/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */
+
+ cpotrf_("U", &k, &a[k * (k + 1)], &k, info);
+ if (*info > 0) {
+ return 0;
+ }
+ ctrsm_("R", "U", "N", "N", &k, &k, &c_b1, &a[k * (k + 1)], &k,
+ a, &k);
+ cherk_("L", "N", &k, &k, &c_b15, a, &k, &c_b16, &a[k * k], &k);
+ cpotrf_("L", &k, &a[k * k], &k, info);
+ if (*info > 0) {
+ *info += k;
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of CPFTRF */
+
+} /* cpftrf_ */
diff --git a/SRC/cpftri.c b/SRC/cpftri.c
new file mode 100644
index 0000000..da7e26d
--- /dev/null
+++ b/SRC/cpftri.c
@@ -0,0 +1,425 @@
+/* cpftri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static real c_b12 = 1.f;
+
+/* Subroutine */ int cpftri_(char *transr, char *uplo, integer *n, complex *a,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer k, n1, n2;
+ logical normaltransr;
+ extern /* Subroutine */ int cherk_(char *, char *, integer *, integer *,
+ real *, complex *, integer *, real *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nisodd;
+ extern /* Subroutine */ int clauum_(char *, integer *, complex *, integer
+ *, integer *), ctftri_(char *, char *, char *, integer *,
+ complex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPFTRI computes the inverse of a complex Hermitian positive definite */
+/* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H */
+/* computed by CPFTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': The Normal TRANSR of RFP A is stored; */
+/* = 'C': The Conjugate-transpose TRANSR of RFP A is stored. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension ( N*(N+1)/2 ); */
+/* On entry, the Hermitian matrix A in RFP format. RFP format is */
+/* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' */
+/* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */
+/* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is */
+/* the Conjugate-transpose of RFP A as defined when */
+/* TRANSR = 'N'. The contents of RFP A are defined by UPLO as */
+/* follows: If UPLO = 'U' the RFP A contains the nt elements of */
+/* upper packed A. If UPLO = 'L' the RFP A contains the elements */
+/* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = */
+/* 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N */
+/* is odd. See the Note below for more details. */
+
+/* On exit, the Hermitian inverse of the original matrix, in the */
+/* same storage format. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the (i,i) element of the factor U or L is */
+/* zero, and the inverse could not be computed. */
+
+/* Note: */
+/* ===== */
+
+/* We first consider Standard Packed Format when N is even. */
+/* We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* conjugate-transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* conjugate-transpose of the last three columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- -- */
+/* 03 04 05 33 43 53 */
+/* -- -- */
+/* 13 14 15 00 44 54 */
+/* -- */
+/* 23 24 25 10 11 55 */
+
+/* 33 34 35 20 21 22 */
+/* -- */
+/* 00 44 45 30 31 32 */
+/* -- -- */
+/* 01 11 55 40 41 42 */
+/* -- -- -- */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We next consider Standard Packed Format when N is odd. */
+/* We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* conjugate-transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* conjugate-transpose of the last two columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- */
+/* 02 03 04 00 33 43 */
+/* -- */
+/* 12 13 14 10 11 44 */
+
+/* 22 23 24 20 21 22 */
+/* -- */
+/* 00 33 34 30 31 32 */
+/* -- -- */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- */
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "C")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPFTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Invert the triangular Cholesky factor U or L. */
+
+ ctftri_(transr, uplo, "N", n, a, info);
+ if (*info > 0) {
+ return 0;
+ }
+
+/* If N is odd, set NISODD = .TRUE. */
+/* If N is even, set K = N/2 and NISODD = .FALSE. */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ } else {
+ nisodd = TRUE_;
+ }
+
+/* Set N1 and N2 depending on LOWER */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* Start execution of triangular matrix multiply: inv(U)*inv(U)^C or */
+/* inv(L)^C*inv(L). There are eight cases. */
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:N1-1) ) */
+/* T1 -> a(0,0), T2 -> a(0,1), S -> a(N1,0) */
+/* T1 -> a(0), T2 -> a(n), S -> a(N1) */
+
+ clauum_("L", &n1, a, n, info);
+ cherk_("L", "C", &n1, &n2, &c_b12, &a[n1], n, &c_b12, a, n);
+ ctrmm_("L", "U", "N", "N", &n2, &n1, &c_b1, &a[*n], n, &a[n1],
+ n);
+ clauum_("U", &n2, &a[*n], n, info);
+
+ } else {
+
+/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:N2-1) */
+/* T1 -> a(N1+1,0), T2 -> a(N1,0), S -> a(0,0) */
+/* T1 -> a(N2), T2 -> a(N1), S -> a(0) */
+
+ clauum_("L", &n1, &a[n2], n, info);
+ cherk_("L", "N", &n1, &n2, &c_b12, a, n, &c_b12, &a[n2], n);
+ ctrmm_("R", "U", "C", "N", &n1, &n2, &c_b1, &a[n1], n, a, n);
+ clauum_("U", &n2, &a[n1], n, info);
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE, and N is odd */
+/* T1 -> a(0), T2 -> a(1), S -> a(0+N1*N1) */
+
+ clauum_("U", &n1, a, &n1, info);
+ cherk_("U", "N", &n1, &n2, &c_b12, &a[n1 * n1], &n1, &c_b12,
+ a, &n1);
+ ctrmm_("R", "L", "N", "N", &n1, &n2, &c_b1, &a[1], &n1, &a[n1
+ * n1], &n1);
+ clauum_("L", &n2, &a[1], &n1, info);
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE, and N is odd */
+/* T1 -> a(0+N2*N2), T2 -> a(0+N1*N2), S -> a(0) */
+
+ clauum_("U", &n1, &a[n2 * n2], &n2, info);
+ cherk_("U", "C", &n1, &n2, &c_b12, a, &n2, &c_b12, &a[n2 * n2]
+, &n2);
+ ctrmm_("L", "L", "C", "N", &n2, &n1, &c_b1, &a[n1 * n2], &n2,
+ a, &n2);
+ clauum_("L", &n2, &a[n1 * n2], &n2, info);
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
+/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */
+
+ i__1 = *n + 1;
+ clauum_("L", &k, &a[1], &i__1, info);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ cherk_("L", "C", &k, &k, &c_b12, &a[k + 1], &i__1, &c_b12, &a[
+ 1], &i__2);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ ctrmm_("L", "U", "N", "N", &k, &k, &c_b1, a, &i__1, &a[k + 1],
+ &i__2);
+ i__1 = *n + 1;
+ clauum_("U", &k, a, &i__1, info);
+
+ } else {
+
+/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
+/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */
+
+ i__1 = *n + 1;
+ clauum_("L", &k, &a[k + 1], &i__1, info);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ cherk_("L", "N", &k, &k, &c_b12, a, &i__1, &c_b12, &a[k + 1],
+ &i__2);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ ctrmm_("R", "U", "C", "N", &k, &k, &c_b1, &a[k], &i__1, a, &
+ i__2);
+ i__1 = *n + 1;
+ clauum_("U", &k, &a[k], &i__1, info);
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE, and N is even (see paper) */
+/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1), */
+/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */
+
+ clauum_("U", &k, &a[k], &k, info);
+ cherk_("U", "N", &k, &k, &c_b12, &a[k * (k + 1)], &k, &c_b12,
+ &a[k], &k);
+ ctrmm_("R", "L", "N", "N", &k, &k, &c_b1, a, &k, &a[k * (k +
+ 1)], &k);
+ clauum_("L", &k, a, &k, info);
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE, and N is even (see paper) */
+/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0), */
+/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */
+
+ clauum_("U", &k, &a[k * (k + 1)], &k, info);
+ cherk_("U", "C", &k, &k, &c_b12, a, &k, &c_b12, &a[k * (k + 1)
+ ], &k);
+ ctrmm_("L", "L", "C", "N", &k, &k, &c_b1, &a[k * k], &k, a, &
+ k);
+ clauum_("L", &k, &a[k * k], &k, info);
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of CPFTRI */
+
+} /* cpftri_ */
diff --git a/SRC/cpftrs.c b/SRC/cpftrs.c
new file mode 100644
index 0000000..7c42d26
--- /dev/null
+++ b/SRC/cpftrs.c
@@ -0,0 +1,260 @@
+/* cpftrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+
+/* Subroutine */ int cpftrs_(char *transr, char *uplo, integer *n, integer *
+ nrhs, complex *a, complex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ctfsm_(char *, char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, complex *, integer *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPFTRS solves a system of linear equations A*X = B with a Hermitian */
+/* positive definite matrix A using the Cholesky factorization */
+/* A = U**H*U or A = L*L**H computed by CPFTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': The Normal TRANSR of RFP A is stored; */
+/* = 'C': The Conjugate-transpose TRANSR of RFP A is stored. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': Upper triangle of RFP A is stored; */
+/* = 'L': Lower triangle of RFP A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension ( N*(N+1)/2 ); */
+/* The triangular factor U or L from the Cholesky factorization */
+/* of RFP A = U**H*U or RFP A = L*L**H, as computed by CPFTRF. */
+/* See note below for more details about RFP A. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Note: */
+/* ===== */
+
+/* We first consider Standard Packed Format when N is even. */
+/* We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* conjugate-transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* conjugate-transpose of the last three columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- -- */
+/* 03 04 05 33 43 53 */
+/* -- -- */
+/* 13 14 15 00 44 54 */
+/* -- */
+/* 23 24 25 10 11 55 */
+
+/* 33 34 35 20 21 22 */
+/* -- */
+/* 00 44 45 30 31 32 */
+/* -- -- */
+/* 01 11 55 40 41 42 */
+/* -- -- -- */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We next consider Standard Packed Format when N is odd. */
+/* We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* conjugate-transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* conjugate-transpose of the last two columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- */
+/* 02 03 04 00 33 43 */
+/* -- */
+/* 12 13 14 10 11 44 */
+
+/* 22 23 24 20 21 22 */
+/* -- */
+/* 00 33 34 30 31 32 */
+/* -- -- */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- */
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "C")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPFTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+/* start execution: there are two triangular solves */
+
+ if (lower) {
+ ctfsm_(transr, "L", uplo, "N", "N", n, nrhs, &c_b1, a, &b[b_offset],
+ ldb);
+ ctfsm_(transr, "L", uplo, "C", "N", n, nrhs, &c_b1, a, &b[b_offset],
+ ldb);
+ } else {
+ ctfsm_(transr, "L", uplo, "C", "N", n, nrhs, &c_b1, a, &b[b_offset],
+ ldb);
+ ctfsm_(transr, "L", uplo, "N", "N", n, nrhs, &c_b1, a, &b[b_offset],
+ ldb);
+ }
+
+ return 0;
+
+/* End of CPFTRS */
+
+} /* cpftrs_ */
diff --git a/SRC/cpocon.c b/SRC/cpocon.c
new file mode 100644
index 0000000..b31555e
--- /dev/null
+++ b/SRC/cpocon.c
@@ -0,0 +1,224 @@
+/* cpocon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cpocon_(char *uplo, integer *n, complex *a, integer *lda,
+ real *anorm, real *rcond, complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer ix, kase;
+ real scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *);
+ extern integer icamax_(integer *, complex *, integer *);
+ real scalel;
+ extern doublereal slamch_(char *);
+ real scaleu;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int clatrs_(char *, char *, char *, char *,
+ integer *, complex *, integer *, complex *, real *, real *,
+ integer *), csrscl_(integer *,
+ real *, complex *, integer *);
+ char normin[1];
+ real smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPOCON estimates the reciprocal of the condition number (in the */
+/* 1-norm) of a complex Hermitian positive definite matrix using the */
+/* Cholesky factorization A = U**H*U or A = L*L**H computed by CPOTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**H*U or A = L*L**H, as computed by CPOTRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* ANORM (input) REAL */
+/* The 1-norm (or infinity-norm) of the Hermitian matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*anorm < 0.f) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPOCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.f;
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ } else if (*anorm == 0.f) {
+ return 0;
+ }
+
+ smlnum = slamch_("Safe minimum");
+
+/* Estimate the 1-norm of inv(A). */
+
+ kase = 0;
+ *(unsigned char *)normin = 'N';
+L10:
+ clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (upper) {
+
+/* Multiply by inv(U'). */
+
+ clatrs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &a[
+ a_offset], lda, &work[1], &scalel, &rwork[1], info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(U). */
+
+ clatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[
+ a_offset], lda, &work[1], &scaleu, &rwork[1], info);
+ } else {
+
+/* Multiply by inv(L). */
+
+ clatrs_("Lower", "No transpose", "Non-unit", normin, n, &a[
+ a_offset], lda, &work[1], &scalel, &rwork[1], info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(L'). */
+
+ clatrs_("Lower", "Conjugate transpose", "Non-unit", normin, n, &a[
+ a_offset], lda, &work[1], &scaleu, &rwork[1], info);
+ }
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ scale = scalel * scaleu;
+ if (scale != 1.f) {
+ ix = icamax_(n, &work[1], &c__1);
+ i__1 = ix;
+ if (scale < ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
+ work[ix]), dabs(r__2))) * smlnum || scale == 0.f) {
+ goto L20;
+ }
+ csrscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / ainvnm / *anorm;
+ }
+
+L20:
+ return 0;
+
+/* End of CPOCON */
+
+} /* cpocon_ */
diff --git a/SRC/cpoequ.c b/SRC/cpoequ.c
new file mode 100644
index 0000000..a6c8498
--- /dev/null
+++ b/SRC/cpoequ.c
@@ -0,0 +1,176 @@
+/* cpoequ.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cpoequ_(integer *n, complex *a, integer *lda, real *s,
+ real *scond, real *amax, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real smin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPOEQU computes row and column scalings intended to equilibrate a */
+/* Hermitian positive definite matrix A and reduce its condition number */
+/* (with respect to the two-norm). S contains the scale factors, */
+/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
+/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
+/* choice of S puts the condition number of B within a factor N of the */
+/* smallest possible condition number over all possible diagonal */
+/* scalings. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The N-by-N Hermitian positive definite matrix whose scaling */
+/* factors are to be computed. Only the diagonal elements of A */
+/* are referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* S (output) REAL array, dimension (N) */
+/* If INFO = 0, S contains the scale factors for A. */
+
+/* SCOND (output) REAL */
+/* If INFO = 0, S contains the ratio of the smallest S(i) to */
+/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
+/* large nor too small, it is not worth scaling by S. */
+
+/* AMAX (output) REAL */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*lda < max(1,*n)) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPOEQU", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *scond = 1.f;
+ *amax = 0.f;
+ return 0;
+ }
+
+/* Find the minimum and maximum diagonal elements. */
+
+ i__1 = a_dim1 + 1;
+ s[1] = a[i__1].r;
+ smin = s[1];
+ *amax = s[1];
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ s[i__] = a[i__2].r;
+/* Computing MIN */
+ r__1 = smin, r__2 = s[i__];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = *amax, r__2 = s[i__];
+ *amax = dmax(r__1,r__2);
+/* L10: */
+ }
+
+ if (smin <= 0.f) {
+
+/* Find the first non-positive diagonal element and return. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] <= 0.f) {
+ *info = i__;
+ return 0;
+ }
+/* L20: */
+ }
+ } else {
+
+/* Set the scale factors to the reciprocals */
+/* of the diagonal elements. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s[i__] = 1.f / sqrt(s[i__]);
+/* L30: */
+ }
+
+/* Compute SCOND = min(S(I)) / max(S(I)) */
+
+ *scond = sqrt(smin) / sqrt(*amax);
+ }
+ return 0;
+
+/* End of CPOEQU */
+
+} /* cpoequ_ */
diff --git a/SRC/cpoequb.c b/SRC/cpoequb.c
new file mode 100644
index 0000000..1c29632
--- /dev/null
+++ b/SRC/cpoequb.c
@@ -0,0 +1,195 @@
+/* cpoequb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cpoequb_(integer *n, complex *a, integer *lda, real *s,
+ real *scond, real *amax, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double log(doublereal), pow_ri(real *, integer *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real tmp, base, smin;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPOEQUB computes row and column scalings intended to equilibrate a */
+/* symmetric positive definite matrix A and reduce its condition number */
+/* (with respect to the two-norm). S contains the scale factors, */
+/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
+/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
+/* choice of S puts the condition number of B within a factor N of the */
+/* smallest possible condition number over all possible diagonal */
+/* scalings. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The N-by-N symmetric positive definite matrix whose scaling */
+/* factors are to be computed. Only the diagonal elements of A */
+/* are referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* S (output) REAL array, dimension (N) */
+/* If INFO = 0, S contains the scale factors for A. */
+
+/* SCOND (output) REAL */
+/* If INFO = 0, S contains the ratio of the smallest S(i) to */
+/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
+/* large nor too small, it is not worth scaling by S. */
+
+/* AMAX (output) REAL */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+/* Positive definite only performs 1 pass of equilibration. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*lda < max(1,*n)) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPOEQUB", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ *scond = 1.f;
+ *amax = 0.f;
+ return 0;
+ }
+ base = slamch_("B");
+ tmp = -.5f / log(base);
+
+/* Find the minimum and maximum diagonal elements. */
+
+ i__1 = a_dim1 + 1;
+ s[1] = a[i__1].r;
+ smin = s[1];
+ *amax = s[1];
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__ + i__ * a_dim1;
+ s[i__2] = a[i__3].r;
+/* Computing MIN */
+ r__1 = smin, r__2 = s[i__];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = *amax, r__2 = s[i__];
+ *amax = dmax(r__1,r__2);
+/* L10: */
+ }
+
+ if (smin <= 0.f) {
+
+/* Find the first non-positive diagonal element and return. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] <= 0.f) {
+ *info = i__;
+ return 0;
+ }
+/* L20: */
+ }
+ } else {
+
+/* Set the scale factors to the reciprocals */
+/* of the diagonal elements. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = (integer) (tmp * log(s[i__]));
+ s[i__] = pow_ri(&base, &i__2);
+/* L30: */
+ }
+
+/* Compute SCOND = min(S(I)) / max(S(I)). */
+
+ *scond = sqrt(smin) / sqrt(*amax);
+ }
+
+ return 0;
+
+/* End of CPOEQUB */
+
+} /* cpoequb_ */
diff --git a/SRC/cporfs.c b/SRC/cporfs.c
new file mode 100644
index 0000000..401a877
--- /dev/null
+++ b/SRC/cporfs.c
@@ -0,0 +1,465 @@
+/* cporfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cporfs_(char *uplo, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *af, integer *ldaf, complex *b, integer *ldb,
+ complex *x, integer *ldx, real *ferr, real *berr, complex *work,
+ real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ real s, xk;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int chemv_(char *, integer *, complex *, complex *
+, integer *, complex *, integer *, complex *, complex *, integer *
+);
+ integer isave[3];
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ integer count;
+ logical upper;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *), cpotrs_(
+ char *, integer *, integer *, complex *, integer *, complex *,
+ integer *, integer *);
+ real lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPORFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is Hermitian positive definite, */
+/* and provides error bounds and backward error estimates for the */
+/* solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The 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. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**H*U or A = L*L**H, as computed by CPOTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by CPOTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ==================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPORFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.f;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ q__1.r = -1.f, q__1.i = -0.f;
+ chemv_(uplo, n, &q__1, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, &
+ c_b1, &work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[
+ i__ + j * b_dim1]), dabs(r__2));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j
+ * x_dim1]), dabs(r__2));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + k * a_dim1]), dabs(r__2))) * xk;
+ i__4 = i__ + k * a_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ i__ + k * a_dim1]), dabs(r__2))) * ((r__3 = x[
+ i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[i__ + j *
+ x_dim1]), dabs(r__4)));
+/* L40: */
+ }
+ i__3 = k + k * a_dim1;
+ rwork[k] = rwork[k] + (r__1 = a[i__3].r, dabs(r__1)) * xk + s;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j
+ * x_dim1]), dabs(r__2));
+ i__3 = k + k * a_dim1;
+ rwork[k] += (r__1 = a[i__3].r, dabs(r__1)) * xk;
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + k * a_dim1]), dabs(r__2))) * xk;
+ i__4 = i__ + k * a_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ i__ + k * a_dim1]), dabs(r__2))) * ((r__3 = x[
+ i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[i__ + j *
+ x_dim1]), dabs(r__4)));
+/* L60: */
+ }
+ rwork[k] += s;
+/* L70: */
+ }
+ }
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__3 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
+ s = dmax(r__3,r__4);
+ } else {
+/* Computing MAX */
+ i__3 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = dmax(r__3,r__4);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ cpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[1], n, info);
+ caxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use CLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__3 = i__;
+ rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__];
+ } else {
+ i__3 = i__;
+ rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__] + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ cpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L120: */
+ }
+ cpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * x_dim1;
+ r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + j * x_dim1]), dabs(r__2));
+ lstres = dmax(r__3,r__4);
+/* L130: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of CPORFS */
+
+} /* cporfs_ */
diff --git a/SRC/cporfsx.c b/SRC/cporfsx.c
new file mode 100644
index 0000000..5ce6195
--- /dev/null
+++ b/SRC/cporfsx.c
@@ -0,0 +1,620 @@
+/* cporfsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int cporfsx_(char *uplo, char *equed, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, real *s,
+ complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real
+ *berr, integer *n_err_bnds__, real *err_bnds_norm__, real *
+ err_bnds_comp__, integer *nparams, real *params, complex *work, real *
+ rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real illrcond_thresh__, unstable_thresh__, err_lbnd__;
+ integer ref_type__;
+ integer j;
+ real rcond_tmp__;
+ integer prec_type__;
+ real cwise_wrong__;
+ extern /* Subroutine */ int cla_porfsx_extended__(integer *, char *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ logical *, real *, complex *, integer *, complex *, integer *,
+ real *, integer *, real *, real *, complex *, real *, complex *,
+ complex *, real *, integer *, real *, real *, logical *, integer *
+ , ftnlen);
+ char norm[1];
+ logical ignore_cwise__;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ logical rcequ;
+ extern doublereal cla_porcond_c__(char *, integer *, complex *, integer *,
+ complex *, integer *, real *, logical *, integer *, complex *,
+ real *, ftnlen), cla_porcond_x__(char *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ real *, ftnlen), clanhe_(char *, char *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), cpocon_(
+ char *, integer *, complex *, integer *, real *, real *, complex *
+, real *, integer *);
+ extern integer ilaprec_(char *);
+ integer ithresh, n_norms__;
+ real rthresh;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPORFSX improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric positive */
+/* definite, and provides error bounds and backward error estimates */
+/* for the solution. In addition to normwise error bound, the code */
+/* provides maximum componentwise error bound if possible. See */
+/* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the */
+/* error bounds. */
+
+/* The original system of linear equations may have been equilibrated */
+/* before calling this routine, as described by arguments EQUED and S */
+/* below. In this case, the solution and error bounds returned are */
+/* for the original unequilibrated system. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* EQUED (input) CHARACTER*1 */
+/* Specifies the form of equilibration that was done to A */
+/* before calling this routine. This is needed to compute */
+/* the solution and error bounds correctly. */
+/* = 'N': No equilibration */
+/* = 'Y': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(S) * A * diag(S). */
+/* The right hand side B has been changed accordingly. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular part */
+/* of the matrix A, and the strictly lower triangular part of A */
+/* is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of A contains the lower triangular part of */
+/* the matrix A, and the strictly upper triangular part of A is */
+/* not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by SPOTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* S (input or output) REAL array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'Y', A is multiplied on */
+/* the left and right by diag(S). S is an input argument if FACT = */
+/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
+/* = 'Y', each element of S must be positive. If S is output, each */
+/* element of S is a power of the radix. If S is input, each element */
+/* of S should be a power of the radix to ensure a reliable solution */
+/* and error estimates. Scaling by powers of the radix does not cause */
+/* rounding errors unless the result underflows or overflows. */
+/* Rounding errors during scaling lead to refining with a matrix that */
+/* is not equivalent to the input matrix, producing error estimates */
+/* that may not be reliable. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by SGETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) REAL array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check the input parameters. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ ref_type__ = 1;
+ if (*nparams >= 1) {
+ if (params[1] < 0.f) {
+ params[1] = 1.f;
+ } else {
+ ref_type__ = params[1];
+ }
+ }
+
+/* Set default parameters. */
+
+ illrcond_thresh__ = (real) (*n) * slamch_("Epsilon");
+ ithresh = 10;
+ rthresh = .5f;
+ unstable_thresh__ = .25f;
+ ignore_cwise__ = FALSE_;
+
+ if (*nparams >= 2) {
+ if (params[2] < 0.f) {
+ params[2] = (real) ithresh;
+ } else {
+ ithresh = (integer) params[2];
+ }
+ }
+ if (*nparams >= 3) {
+ if (params[3] < 0.f) {
+ if (ignore_cwise__) {
+ params[3] = 0.f;
+ } else {
+ params[3] = 1.f;
+ }
+ } else {
+ ignore_cwise__ = params[3] == 0.f;
+ }
+ }
+ if (ref_type__ == 0 || *n_err_bnds__ == 0) {
+ n_norms__ = 0;
+ } else if (ignore_cwise__) {
+ n_norms__ = 1;
+ } else {
+ n_norms__ = 2;
+ }
+
+ rcequ = lsame_(equed, "Y");
+
+/* Test input parameters. */
+
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! rcequ && ! lsame_(equed, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -11;
+ } else if (*ldx < max(1,*n)) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPORFSX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *nrhs == 0) {
+ *rcond = 1.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 0.f;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.f;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.f;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.f;
+ }
+ }
+ return 0;
+ }
+
+/* Default to failure. */
+
+ *rcond = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 1.f;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.f;
+ }
+ }
+
+/* Compute the norm of A and the reciprocal of the condition */
+/* number of A. */
+
+ *(unsigned char *)norm = 'I';
+ anorm = clanhe_(norm, uplo, n, &a[a_offset], lda, &rwork[1]);
+ cpocon_(uplo, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &rwork[1],
+ info);
+
+/* Perform refinement on each right-hand side */
+
+ if (ref_type__ != 0) {
+ prec_type__ = ilaprec_("D");
+ cla_porfsx_extended__(&prec_type__, uplo, n, nrhs, &a[a_offset], lda,
+ &af[af_offset], ldaf, &rcequ, &s[1], &b[b_offset], ldb, &x[
+ x_offset], ldx, &berr[1], &n_norms__, &err_bnds_norm__[
+ err_bnds_norm_offset], &err_bnds_comp__[err_bnds_comp_offset],
+ &work[1], &rwork[1], &work[*n + 1], (complex *)(&rwork[1]), rcond, &ithresh, &
+ rthresh, &unstable_thresh__, &ignore_cwise__, info, (ftnlen)1)
+ ;
+ }
+/* Computing MAX */
+ r__1 = 10.f, r__2 = sqrt((real) (*n));
+ err_lbnd__ = dmax(r__1,r__2) * slamch_("Epsilon");
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {
+
+/* Compute scaled normwise condition number cond(A*C). */
+
+ if (rcequ) {
+ rcond_tmp__ = cla_porcond_c__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &s[1], &c_true, info, &work[1], &rwork[
+ 1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = cla_porcond_c__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &s[1], &c_false, info, &work[1], &rwork[
+ 1], (ftnlen)1);
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1
+ << 1)] > 1.f) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 0.f;
+ if (*info <= *n) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {
+
+/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
+/* each right-hand side using the current solution as an estimate of */
+/* the true solution. If the componentwise error estimate is too */
+/* large, then the solution is a lousy estimate of truth and the */
+/* estimated RCOND may be too optimistic. To avoid misleading users, */
+/* the inverse condition number is set to 0.0 when the estimated */
+/* cwise error is at least CWISE_WRONG. */
+
+ cwise_wrong__ = sqrt(slamch_("Epsilon"));
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ cwise_wrong__) {
+ rcond_tmp__ = cla_porcond_x__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &x[j * x_dim1 + 1], info, &work[1],
+ &rwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = 0.f;
+ }
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1
+ << 1)] > 1.f) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 0.f;
+ if (params[3] == 1.f && *info < *n + j) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CPORFSX */
+
+} /* cporfsx_ */
diff --git a/SRC/cposv.c b/SRC/cposv.c
new file mode 100644
index 0000000..8dbc051
--- /dev/null
+++ b/SRC/cposv.c
@@ -0,0 +1,151 @@
+/* cposv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cposv_(char *uplo, integer *n, integer *nrhs, complex *a,
+ integer *lda, complex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), cpotrf_(
+ char *, integer *, complex *, integer *, integer *),
+ cpotrs_(char *, integer *, integer *, complex *, integer *,
+ complex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPOSV computes the solution to a complex system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N Hermitian positive definite matrix and X and B */
+/* are N-by-NRHS matrices. */
+
+/* The Cholesky decomposition is used to factor A as */
+/* A = U**H* U, if UPLO = 'U', or */
+/* A = L * L**H, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is a lower triangular */
+/* matrix. The factored form of A is then used to solve the system of */
+/* equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input/output) 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, the factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i of A is not */
+/* positive definite, so the factorization could not be */
+/* completed, and the solution has not been computed. */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPOSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ cpotrf_(uplo, n, &a[a_offset], lda, info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ cpotrs_(uplo, n, nrhs, &a[a_offset], lda, &b[b_offset], ldb, info);
+
+ }
+ return 0;
+
+/* End of CPOSV */
+
+} /* cposv_ */
diff --git a/SRC/cposvx.c b/SRC/cposvx.c
new file mode 100644
index 0000000..bf2fc35
--- /dev/null
+++ b/SRC/cposvx.c
@@ -0,0 +1,458 @@
+/* cposvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cposvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, char *
+ equed, real *s, complex *b, integer *ldb, complex *x, integer *ldx,
+ real *rcond, real *ferr, real *berr, complex *work, real *rwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j;
+ real amax, smin, smax;
+ extern logical lsame_(char *, char *);
+ real scond, anorm;
+ logical equil, rcequ;
+ extern doublereal clanhe_(char *, char *, integer *, complex *, integer *,
+ real *);
+ extern /* Subroutine */ int claqhe_(char *, integer *, complex *, integer
+ *, real *, real *, real *, char *);
+ extern doublereal slamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), xerbla_(char *,
+ integer *);
+ real bignum;
+ extern /* Subroutine */ int cpocon_(char *, integer *, complex *, integer
+ *, real *, real *, complex *, real *, integer *);
+ integer infequ;
+ extern /* Subroutine */ int cpoequ_(integer *, complex *, integer *, real
+ *, real *, real *, integer *), cporfs_(char *, integer *, integer
+ *, complex *, integer *, complex *, integer *, complex *, integer
+ *, complex *, integer *, real *, real *, complex *, real *,
+ integer *), cpotrf_(char *, integer *, complex *, integer
+ *, integer *), cpotrs_(char *, integer *, integer *,
+ complex *, integer *, complex *, integer *, integer *);
+ real smlnum;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPOSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to */
+/* compute the solution to a complex system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N Hermitian positive definite matrix and X and B */
+/* are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+/* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
+
+/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */
+/* factor the matrix A (after equilibration if FACT = 'E') as */
+/* A = U**H* U, if UPLO = 'U', or */
+/* A = L * L**H, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is a lower triangular */
+/* matrix. */
+
+/* 3. If the leading i-by-i principal minor is not positive definite, */
+/* then the routine returns with INFO = i. Otherwise, the factored */
+/* form of A is used to estimate the condition number of the matrix */
+/* A. If the reciprocal of the condition number is less than machine */
+/* precision, INFO = N+1 is returned as a warning, but the routine */
+/* still goes on to solve for X and compute error bounds as */
+/* described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(S) so that it solves the original system before */
+/* equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF contains the factored form of A. */
+/* If EQUED = 'Y', the matrix A has been equilibrated */
+/* with scaling factors given by S. A and AF will not */
+/* be modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the Hermitian matrix A, except if FACT = 'F' and */
+/* EQUED = 'Y', then A must contain the equilibrated matrix */
+/* diag(S)*A*diag(S). If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. A is not modified if */
+/* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
+
+/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
+/* diag(S)*A*diag(S). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) COMPLEX array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the triangular factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H, in the same storage */
+/* format as A. If EQUED .ne. 'N', then AF is the factored form */
+/* of the equilibrated matrix diag(S)*A*diag(S). */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H of the original */
+/* matrix A. */
+
+/* If FACT = 'E', then AF is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H of the equilibrated */
+/* matrix A (see the description of A for the form of the */
+/* equilibrated matrix). */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* S (input or output) REAL array, dimension (N) */
+/* The scale factors for A; not accessed if EQUED = 'N'. S is */
+/* an input argument if FACT = 'F'; otherwise, S is an output */
+/* argument. If FACT = 'F' and EQUED = 'Y', each element of S */
+/* must be positive. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS righthand side matrix B. */
+/* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */
+/* B is overwritten by diag(S) * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */
+/* the original system of equations. Note that if EQUED = 'Y', */
+/* A and B are modified on exit, and the solution to the */
+/* equilibrated system is inv(diag(S))*X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A after equilibration (if done). If RCOND is less than the */
+/* machine precision (in particular, if RCOND = 0), the matrix */
+/* is singular to working precision. This condition is */
+/* indicated by a return code of INFO > 0. */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: the leading minor of order i of A is */
+/* not positive definite, so the factorization */
+/* could not be completed, and the solution has not */
+/* been computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rcequ = FALSE_;
+ } else {
+ rcequ = lsame_(equed, "Y");
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ }
+
+/* Test the input parameters. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (lsame_(fact, "F") && ! (rcequ || lsame_(
+ equed, "N"))) {
+ *info = -9;
+ } else {
+ if (rcequ) {
+ smin = bignum;
+ smax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = smin, r__2 = s[j];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = smax, r__2 = s[j];
+ smax = dmax(r__1,r__2);
+/* L10: */
+ }
+ if (smin <= 0.f) {
+ *info = -10;
+ } else if (*n > 0) {
+ scond = dmax(smin,smlnum) / dmin(smax,bignum);
+ } else {
+ scond = 1.f;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -12;
+ } else if (*ldx < max(1,*n)) {
+ *info = -14;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPOSVX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ cpoequ_(n, &a[a_offset], lda, &s[1], &scond, &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ claqhe_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed);
+ rcequ = lsame_(equed, "Y");
+ }
+ }
+
+/* Scale the right hand side. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * b_dim1;
+ q__1.r = s[i__4] * b[i__5].r, q__1.i = s[i__4] * b[i__5].i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L20: */
+ }
+/* L30: */
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ clacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ cpotrf_(uplo, n, &af[af_offset], ldaf, info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.f;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = clanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ cpocon_(uplo, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &rwork[1],
+ info);
+
+/* Compute the solution matrix X. */
+
+ clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ cpotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &x[x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ cporfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &b[
+ b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1], &
+ rwork[1], info);
+
+/* Transform the solution matrix X to a solution of the original */
+/* system. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * x_dim1;
+ q__1.r = s[i__4] * x[i__5].r, q__1.i = s[i__4] * x[i__5].i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+/* L40: */
+ }
+/* L50: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= scond;
+/* L60: */
+ }
+ }
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < slamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of CPOSVX */
+
+} /* cposvx_ */
diff --git a/SRC/cposvxx.c b/SRC/cposvxx.c
new file mode 100644
index 0000000..067ff77
--- /dev/null
+++ b/SRC/cposvxx.c
@@ -0,0 +1,613 @@
+/* cposvxx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cposvxx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, char *
+ equed, real *s, complex *b, integer *ldb, complex *x, integer *ldx,
+ real *rcond, real *rpvgrw, real *berr, integer *n_err_bnds__, real *
+ err_bnds_norm__, real *err_bnds_comp__, integer *nparams, real *
+ params, complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j;
+ real amax, smin, smax;
+ extern doublereal cla_porpvgrw__(char *, integer *, complex *, integer *,
+ complex *, integer *, real *, ftnlen);
+ extern logical lsame_(char *, char *);
+ real scond;
+ logical equil, rcequ;
+ extern /* Subroutine */ int claqhe_(char *, integer *, complex *, integer
+ *, real *, real *, real *, char *);
+ extern doublereal slamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), xerbla_(char *,
+ integer *);
+ real bignum;
+ integer infequ;
+ extern /* Subroutine */ int cpotrf_(char *, integer *, complex *, integer
+ *, integer *), cpotrs_(char *, integer *, integer *,
+ complex *, integer *, complex *, integer *, integer *);
+ real smlnum;
+ extern /* Subroutine */ int clascl2_(integer *, integer *, real *,
+ complex *, integer *), cpoequb_(integer *, complex *, integer *,
+ real *, real *, real *, integer *), cporfsx_(char *, char *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ real *, complex *, integer *, complex *, integer *, real *, real *
+, integer *, real *, real *, integer *, real *, complex *, real *,
+ integer *);
+
+
+/* -- LAPACK driver routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T */
+/* to compute the solution to a complex system of linear equations */
+/* A * X = B, where A is an N-by-N symmetric positive definite matrix */
+/* and X and B are N-by-NRHS matrices. */
+
+/* If requested, both normwise and maximum componentwise error bounds */
+/* are returned. CPOSVXX will return a solution with a tiny */
+/* guaranteed error (O(eps) where eps is the working machine */
+/* precision) unless the matrix is very ill-conditioned, in which */
+/* case a warning is returned. Relevant condition numbers also are */
+/* calculated and returned. */
+
+/* CPOSVXX accepts user-provided factorizations and equilibration */
+/* factors; see the definitions of the FACT and EQUED options. */
+/* Solving with refinement and using a factorization from a previous */
+/* CPOSVXX call will also produce a solution with either O(eps) */
+/* errors or warnings, but we cannot make that claim for general */
+/* user-provided factorizations and equilibration factors if they */
+/* differ from what CPOSVXX would itself produce. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+
+/* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B */
+
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
+
+/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */
+/* factor the matrix A (after equilibration if FACT = 'E') as */
+/* A = U**T* U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is a lower triangular */
+/* matrix. */
+
+/* 3. If the leading i-by-i principal minor is not positive definite, */
+/* then the routine returns with INFO = i. Otherwise, the factored */
+/* form of A is used to estimate the condition number of the matrix */
+/* A (see argument RCOND). If the reciprocal of the condition number */
+/* is less than machine precision, the routine still goes on to solve */
+/* for X and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */
+/* the routine will use iterative refinement to try to get a small */
+/* error and error bounds. Refinement calculates the residual to at */
+/* least twice the working precision. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(S) so that it solves the original system before */
+/* equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF contains the factored form of A. */
+/* If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by S. */
+/* A and AF are not modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED = */
+/* 'Y', then A must contain the equilibrated matrix */
+/* diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper */
+/* triangular part of A contains the upper triangular part of the */
+/* matrix A, and the strictly lower triangular part of A is not */
+/* referenced. If UPLO = 'L', the leading N-by-N lower triangular */
+/* part of A contains the lower triangular part of the matrix A, and */
+/* the strictly upper triangular part of A is not referenced. A is */
+/* not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED = */
+/* 'N' on exit. */
+
+/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
+/* diag(S)*A*diag(S). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) COMPLEX array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T, in the same storage */
+/* format as A. If EQUED .ne. 'N', then AF is the factored */
+/* form of the equilibrated matrix diag(S)*A*diag(S). */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T of the original */
+/* matrix A. */
+
+/* If FACT = 'E', then AF is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T of the equilibrated */
+/* matrix A (see the description of A for the form of the */
+/* equilibrated matrix). */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'Y': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(S) * A * diag(S). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* S (input or output) REAL array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'Y', A is multiplied on */
+/* the left and right by diag(S). S is an input argument if FACT = */
+/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
+/* = 'Y', each element of S must be positive. If S is output, each */
+/* element of S is a power of the radix. If S is input, each element */
+/* of S should be a power of the radix to ensure a reliable solution */
+/* and error estimates. Scaling by powers of the radix does not cause */
+/* rounding errors unless the result underflows or overflows. */
+/* Rounding errors during scaling lead to refining with a matrix that */
+/* is not equivalent to the input matrix, producing error estimates */
+/* that may not be reliable. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if EQUED = 'Y', B is overwritten by diag(S)*B; */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX array, dimension (LDX,NRHS) */
+/* If INFO = 0, the N-by-NRHS solution matrix X to the original */
+/* system of equations. Note that A and B are modified on exit if */
+/* EQUED .ne. 'N', and the solution to the equilibrated system is */
+/* inv(diag(S))*X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* RPVGRW (output) REAL */
+/* Reciprocal pivot growth. On exit, this contains the reciprocal */
+/* pivot growth factor norm(A)/norm(U). The "max absolute element" */
+/* norm is used. If this is much less than 1, then the stability of */
+/* the LU factorization of the (equilibrated) matrix A could be poor. */
+/* This also means that the solution X, estimated condition numbers, */
+/* and error bounds could be unreliable. If factorization fails with */
+/* 0<INFO<=N, then this contains the reciprocal pivot growth factor */
+/* for the leading INFO columns of A. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) REAL array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rcequ = FALSE_;
+ } else {
+ rcequ = lsame_(equed, "Y");
+ }
+
+/* Default is failure. If an input parameter is wrong or */
+/* factorization fails, make everything look horrible. Only the */
+/* pivot growth is set here, the rest is initialized in CPORFSX. */
+
+ *rpvgrw = 0.f;
+
+/* Test the input parameters. PARAMS is not tested until CPORFSX. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (lsame_(fact, "F") && ! (rcequ || lsame_(
+ equed, "N"))) {
+ *info = -9;
+ } else {
+ if (rcequ) {
+ smin = bignum;
+ smax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = smin, r__2 = s[j];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = smax, r__2 = s[j];
+ smax = dmax(r__1,r__2);
+/* L10: */
+ }
+ if (smin <= 0.f) {
+ *info = -10;
+ } else if (*n > 0) {
+ scond = dmax(smin,smlnum) / dmin(smax,bignum);
+ } else {
+ scond = 1.f;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -12;
+ } else if (*ldx < max(1,*n)) {
+ *info = -14;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPOSVXX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ cpoequb_(n, &a[a_offset], lda, &s[1], &scond, &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ claqhe_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed);
+ rcequ = lsame_(equed, "Y");
+ }
+ }
+
+/* Scale the right-hand side. */
+
+ if (rcequ) {
+ clascl2_(n, nrhs, &s[1], &b[b_offset], ldb);
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of A. */
+
+ clacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ cpotrf_(uplo, n, &af[af_offset], ldaf, info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Pivot in column INFO is exactly 0 */
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ *rpvgrw = cla_porpvgrw__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &rwork[1], (ftnlen)1);
+ return 0;
+ }
+ }
+
+/* Compute the reciprocal pivot growth factor RPVGRW. */
+
+ *rpvgrw = cla_porpvgrw__(uplo, n, &a[a_offset], lda, &af[af_offset], ldaf,
+ &rwork[1], (ftnlen)1);
+
+/* Compute the solution matrix X. */
+
+ clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ cpotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &x[x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ cporfsx_(uplo, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &
+ s[1], &b[b_offset], ldb, &x[x_offset], ldx, rcond, &berr[1],
+ n_err_bnds__, &err_bnds_norm__[err_bnds_norm_offset], &
+ err_bnds_comp__[err_bnds_comp_offset], nparams, ¶ms[1], &work[
+ 1], &rwork[1], info);
+
+/* Scale solutions. */
+
+ if (rcequ) {
+ clascl2_(n, nrhs, &s[1], &x[x_offset], ldx);
+ }
+
+ return 0;
+
+/* End of CPOSVXX */
+
+} /* cposvxx_ */
diff --git a/SRC/cpotf2.c b/SRC/cpotf2.c
new file mode 100644
index 0000000..53ff862
--- /dev/null
+++ b/SRC/cpotf2.c
@@ -0,0 +1,245 @@
+/* cpotf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cpotf2_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer j;
+ real ajj;
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *);
+ logical upper;
+ extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
+ csscal_(integer *, real *, complex *, integer *), xerbla_(char *,
+ integer *);
+ extern logical sisnan_(real *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPOTF2 computes the Cholesky factorization of a complex Hermitian */
+/* positive definite matrix A. */
+
+/* The factorization has the form */
+/* A = U' * U , if UPLO = 'U', or */
+/* A = L * L', if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the 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, the factor U or L from the Cholesky */
+/* factorization A = U'*U or A = L*L'. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, the leading minor of order k is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPOTF2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute U(J,J) and test for non-positive-definiteness. */
+
+ i__2 = j + j * a_dim1;
+ r__1 = a[i__2].r;
+ i__3 = j - 1;
+ cdotc_(&q__2, &i__3, &a[j * a_dim1 + 1], &c__1, &a[j * a_dim1 + 1]
+, &c__1);
+ q__1.r = r__1 - q__2.r, q__1.i = -q__2.i;
+ ajj = q__1.r;
+ if (ajj <= 0.f || sisnan_(&ajj)) {
+ i__2 = j + j * a_dim1;
+ a[i__2].r = ajj, a[i__2].i = 0.f;
+ goto L30;
+ }
+ ajj = sqrt(ajj);
+ i__2 = j + j * a_dim1;
+ a[i__2].r = ajj, a[i__2].i = 0.f;
+
+/* Compute elements J+1:N of row J. */
+
+ if (j < *n) {
+ i__2 = j - 1;
+ clacgv_(&i__2, &a[j * a_dim1 + 1], &c__1);
+ i__2 = j - 1;
+ i__3 = *n - j;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Transpose", &i__2, &i__3, &q__1, &a[(j + 1) * a_dim1
+ + 1], lda, &a[j * a_dim1 + 1], &c__1, &c_b1, &a[j + (
+ j + 1) * a_dim1], lda);
+ i__2 = j - 1;
+ clacgv_(&i__2, &a[j * a_dim1 + 1], &c__1);
+ i__2 = *n - j;
+ r__1 = 1.f / ajj;
+ csscal_(&i__2, &r__1, &a[j + (j + 1) * a_dim1], lda);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute L(J,J) and test for non-positive-definiteness. */
+
+ i__2 = j + j * a_dim1;
+ r__1 = a[i__2].r;
+ i__3 = j - 1;
+ cdotc_(&q__2, &i__3, &a[j + a_dim1], lda, &a[j + a_dim1], lda);
+ q__1.r = r__1 - q__2.r, q__1.i = -q__2.i;
+ ajj = q__1.r;
+ if (ajj <= 0.f || sisnan_(&ajj)) {
+ i__2 = j + j * a_dim1;
+ a[i__2].r = ajj, a[i__2].i = 0.f;
+ goto L30;
+ }
+ ajj = sqrt(ajj);
+ i__2 = j + j * a_dim1;
+ a[i__2].r = ajj, a[i__2].i = 0.f;
+
+/* Compute elements J+1:N of column J. */
+
+ if (j < *n) {
+ i__2 = j - 1;
+ clacgv_(&i__2, &a[j + a_dim1], lda);
+ i__2 = *n - j;
+ i__3 = j - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No transpose", &i__2, &i__3, &q__1, &a[j + 1 + a_dim1]
+, lda, &a[j + a_dim1], lda, &c_b1, &a[j + 1 + j *
+ a_dim1], &c__1);
+ i__2 = j - 1;
+ clacgv_(&i__2, &a[j + a_dim1], lda);
+ i__2 = *n - j;
+ r__1 = 1.f / ajj;
+ csscal_(&i__2, &r__1, &a[j + 1 + j * a_dim1], &c__1);
+ }
+/* L20: */
+ }
+ }
+ goto L40;
+
+L30:
+ *info = j;
+
+L40:
+ return 0;
+
+/* End of CPOTF2 */
+
+} /* cpotf2_ */
diff --git a/SRC/cpotrf.c b/SRC/cpotrf.c
new file mode 100644
index 0000000..f71adee
--- /dev/null
+++ b/SRC/cpotrf.c
@@ -0,0 +1,248 @@
+/* cpotrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b14 = -1.f;
+static real c_b15 = 1.f;
+
+/* Subroutine */ int cpotrf_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ complex q__1;
+
+ /* Local variables */
+ integer j, jb, nb;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), cherk_(char *,
+ char *, integer *, integer *, real *, complex *, integer *, real *
+, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *);
+ logical upper;
+ extern /* Subroutine */ int cpotf2_(char *, integer *, complex *, integer
+ *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPOTRF computes the Cholesky factorization of a complex Hermitian */
+/* positive definite matrix A. */
+
+/* The factorization has the form */
+/* A = U**H * U, if UPLO = 'U', or */
+/* A = L * L**H, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* This is the block version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (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, the factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPOTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "CPOTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code. */
+
+ cpotf2_(uplo, n, &a[a_offset], lda, info);
+ } else {
+
+/* Use blocked code. */
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+ i__3 = j - 1;
+ cherk_("Upper", "Conjugate transpose", &jb, &i__3, &c_b14, &a[
+ j * a_dim1 + 1], lda, &c_b15, &a[j + j * a_dim1], lda);
+ cpotf2_("Upper", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+ if (j + jb <= *n) {
+
+/* Compute the current block row. */
+
+ i__3 = *n - j - jb + 1;
+ i__4 = j - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("Conjugate transpose", "No transpose", &jb, &i__3,
+ &i__4, &q__1, &a[j * a_dim1 + 1], lda, &a[(j + jb)
+ * a_dim1 + 1], lda, &c_b1, &a[j + (j + jb) *
+ a_dim1], lda);
+ i__3 = *n - j - jb + 1;
+ ctrsm_("Left", "Upper", "Conjugate transpose", "Non-unit",
+ &jb, &i__3, &c_b1, &a[j + j * a_dim1], lda, &a[j
+ + (j + jb) * a_dim1], lda);
+ }
+/* L10: */
+ }
+
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+ i__3 = j - 1;
+ cherk_("Lower", "No transpose", &jb, &i__3, &c_b14, &a[j +
+ a_dim1], lda, &c_b15, &a[j + j * a_dim1], lda);
+ cpotf2_("Lower", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+ if (j + jb <= *n) {
+
+/* Compute the current block column. */
+
+ i__3 = *n - j - jb + 1;
+ i__4 = j - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "Conjugate transpose", &i__3, &jb,
+ &i__4, &q__1, &a[j + jb + a_dim1], lda, &a[j +
+ a_dim1], lda, &c_b1, &a[j + jb + j * a_dim1], lda);
+ i__3 = *n - j - jb + 1;
+ ctrsm_("Right", "Lower", "Conjugate transpose", "Non-unit"
+, &i__3, &jb, &c_b1, &a[j + j * a_dim1], lda, &a[
+ j + jb + j * a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+ }
+ goto L40;
+
+L30:
+ *info = *info + j - 1;
+
+L40:
+ return 0;
+
+/* End of CPOTRF */
+
+} /* cpotrf_ */
diff --git a/SRC/cpotri.c b/SRC/cpotri.c
new file mode 100644
index 0000000..27e88ce
--- /dev/null
+++ b/SRC/cpotri.c
@@ -0,0 +1,125 @@
+/* cpotri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cpotri_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), clauum_(
+ char *, integer *, complex *, integer *, integer *),
+ ctrtri_(char *, char *, integer *, complex *, integer *, integer *
+);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPOTRI computes the inverse of a complex Hermitian positive definite */
+/* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H */
+/* computed by CPOTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the triangular factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H, as computed by */
+/* CPOTRF. */
+/* On exit, the upper or lower triangle of the (Hermitian) */
+/* inverse of A, overwriting the input factor U or L. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the (i,i) element of the factor U or L is */
+/* zero, and the inverse could not be computed. */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPOTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Invert the triangular Cholesky factor U or L. */
+
+ ctrtri_(uplo, "Non-unit", n, &a[a_offset], lda, info);
+ if (*info > 0) {
+ return 0;
+ }
+
+/* Form inv(U)*inv(U)' or inv(L)'*inv(L). */
+
+ clauum_(uplo, n, &a[a_offset], lda, info);
+
+ return 0;
+
+/* End of CPOTRI */
+
+} /* cpotri_ */
diff --git a/SRC/cpotrs.c b/SRC/cpotrs.c
new file mode 100644
index 0000000..d65ce4e
--- /dev/null
+++ b/SRC/cpotrs.c
@@ -0,0 +1,165 @@
+/* cpotrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+
+/* Subroutine */ int cpotrs_(char *uplo, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPOTRS solves a system of linear equations A*X = B with a Hermitian */
+/* positive definite matrix A using the Cholesky factorization */
+/* A = U**H*U or A = L*L**H computed by CPOTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**H*U or A = L*L**H, as computed by CPOTRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPOTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B where A = U'*U. */
+
+/* Solve U'*X = B, overwriting B with X. */
+
+ ctrsm_("Left", "Upper", "Conjugate transpose", "Non-unit", n, nrhs, &
+ c_b1, &a[a_offset], lda, &b[b_offset], ldb);
+
+/* Solve U*X = B, overwriting B with X. */
+
+ ctrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b1, &
+ a[a_offset], lda, &b[b_offset], ldb);
+ } else {
+
+/* Solve A*X = B where A = L*L'. */
+
+/* Solve L*X = B, overwriting B with X. */
+
+ ctrsm_("Left", "Lower", "No transpose", "Non-unit", n, nrhs, &c_b1, &
+ a[a_offset], lda, &b[b_offset], ldb);
+
+/* Solve L'*X = B, overwriting B with X. */
+
+ ctrsm_("Left", "Lower", "Conjugate transpose", "Non-unit", n, nrhs, &
+ c_b1, &a[a_offset], lda, &b[b_offset], ldb);
+ }
+
+ return 0;
+
+/* End of CPOTRS */
+
+} /* cpotrs_ */
diff --git a/SRC/cppcon.c b/SRC/cppcon.c
new file mode 100644
index 0000000..656f100
--- /dev/null
+++ b/SRC/cppcon.c
@@ -0,0 +1,222 @@
+/* cppcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cppcon_(char *uplo, integer *n, complex *ap, real *anorm,
+ real *rcond, complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer ix, kase;
+ real scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *);
+ extern integer icamax_(integer *, complex *, integer *);
+ real scalel;
+ extern doublereal slamch_(char *);
+ real scaleu;
+ extern /* Subroutine */ int xerbla_(char *, integer *), clatps_(
+ char *, char *, char *, char *, integer *, complex *, complex *,
+ real *, real *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int csrscl_(integer *, real *, complex *, integer
+ *);
+ char normin[1];
+ real smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPPCON estimates the reciprocal of the condition number (in the */
+/* 1-norm) of a complex Hermitian positive definite packed matrix using */
+/* the Cholesky factorization A = U**H*U or A = L*L**H computed by */
+/* CPPTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**H*U or A = L*L**H, packed columnwise in a linear */
+/* array. The j-th column of U or L is stored in the array AP */
+/* as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */
+
+/* ANORM (input) REAL */
+/* The 1-norm (or infinity-norm) of the Hermitian matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*anorm < 0.f) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPPCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.f;
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ } else if (*anorm == 0.f) {
+ return 0;
+ }
+
+ smlnum = slamch_("Safe minimum");
+
+/* Estimate the 1-norm of the inverse. */
+
+ kase = 0;
+ *(unsigned char *)normin = 'N';
+L10:
+ clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (upper) {
+
+/* Multiply by inv(U'). */
+
+ clatps_("Upper", "Conjugate transpose", "Non-unit", normin, n, &
+ ap[1], &work[1], &scalel, &rwork[1], info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(U). */
+
+ clatps_("Upper", "No transpose", "Non-unit", normin, n, &ap[1], &
+ work[1], &scaleu, &rwork[1], info);
+ } else {
+
+/* Multiply by inv(L). */
+
+ clatps_("Lower", "No transpose", "Non-unit", normin, n, &ap[1], &
+ work[1], &scalel, &rwork[1], info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(L'). */
+
+ clatps_("Lower", "Conjugate transpose", "Non-unit", normin, n, &
+ ap[1], &work[1], &scaleu, &rwork[1], info);
+ }
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ scale = scalel * scaleu;
+ if (scale != 1.f) {
+ ix = icamax_(n, &work[1], &c__1);
+ i__1 = ix;
+ if (scale < ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
+ work[ix]), dabs(r__2))) * smlnum || scale == 0.f) {
+ goto L20;
+ }
+ csrscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / ainvnm / *anorm;
+ }
+
+L20:
+ return 0;
+
+/* End of CPPCON */
+
+} /* cppcon_ */
diff --git a/SRC/cppequ.c b/SRC/cppequ.c
new file mode 100644
index 0000000..31877c8
--- /dev/null
+++ b/SRC/cppequ.c
@@ -0,0 +1,210 @@
+/* cppequ.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cppequ_(char *uplo, integer *n, complex *ap, real *s,
+ real *scond, real *amax, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, jj;
+ real smin;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPPEQU computes row and column scalings intended to equilibrate a */
+/* Hermitian positive definite matrix A in packed storage and reduce */
+/* its condition number (with respect to the two-norm). S contains the */
+/* scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix */
+/* B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal. */
+/* This choice of S puts the condition number of B within a factor N of */
+/* the smallest possible condition number over all possible diagonal */
+/* scalings. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the Hermitian matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* S (output) REAL array, dimension (N) */
+/* If INFO = 0, S contains the scale factors for A. */
+
+/* SCOND (output) REAL */
+/* If INFO = 0, S contains the ratio of the smallest S(i) to */
+/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
+/* large nor too small, it is not worth scaling by S. */
+
+/* AMAX (output) REAL */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --s;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPPEQU", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *scond = 1.f;
+ *amax = 0.f;
+ return 0;
+ }
+
+/* Initialize SMIN and AMAX. */
+
+ s[1] = ap[1].r;
+ smin = s[1];
+ *amax = s[1];
+
+ if (upper) {
+
+/* UPLO = 'U': Upper triangle of A is stored. */
+/* Find the minimum and maximum diagonal elements. */
+
+ jj = 1;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ jj += i__;
+ i__2 = jj;
+ s[i__] = ap[i__2].r;
+/* Computing MIN */
+ r__1 = smin, r__2 = s[i__];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = *amax, r__2 = s[i__];
+ *amax = dmax(r__1,r__2);
+/* L10: */
+ }
+
+ } else {
+
+/* UPLO = 'L': Lower triangle of A is stored. */
+/* Find the minimum and maximum diagonal elements. */
+
+ jj = 1;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ jj = jj + *n - i__ + 2;
+ i__2 = jj;
+ s[i__] = ap[i__2].r;
+/* Computing MIN */
+ r__1 = smin, r__2 = s[i__];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = *amax, r__2 = s[i__];
+ *amax = dmax(r__1,r__2);
+/* L20: */
+ }
+ }
+
+ if (smin <= 0.f) {
+
+/* Find the first non-positive diagonal element and return. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] <= 0.f) {
+ *info = i__;
+ return 0;
+ }
+/* L30: */
+ }
+ } else {
+
+/* Set the scale factors to the reciprocals */
+/* of the diagonal elements. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s[i__] = 1.f / sqrt(s[i__]);
+/* L40: */
+ }
+
+/* Compute SCOND = min(S(I)) / max(S(I)) */
+
+ *scond = sqrt(smin) / sqrt(*amax);
+ }
+ return 0;
+
+/* End of CPPEQU */
+
+} /* cppequ_ */
diff --git a/SRC/cpprfs.c b/SRC/cpprfs.c
new file mode 100644
index 0000000..2159485
--- /dev/null
+++ b/SRC/cpprfs.c
@@ -0,0 +1,457 @@
+/* cpprfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cpprfs_(char *uplo, integer *n, integer *nrhs, complex *
+ ap, complex *afp, complex *b, integer *ldb, complex *x, integer *ldx,
+ real *ferr, real *berr, complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ real s;
+ integer ik, kk;
+ real xk;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), chpmv_(char *, integer *, complex *,
+ complex *, complex *, integer *, complex *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *,
+ complex *, integer *);
+ integer count;
+ logical upper;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *), cpptrs_(
+ char *, integer *, integer *, complex *, complex *, integer *,
+ integer *);
+ real lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPPRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is Hermitian positive definite */
+/* and packed, and provides error bounds and backward error estimates */
+/* for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the Hermitian matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* AFP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**H*U or A = L*L**H, as computed by SPPTRF/CPPTRF, */
+/* packed columnwise in a linear array in the same format as A */
+/* (see AP). */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by CPPTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ==================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --afp;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldx < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPPRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.f;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ q__1.r = -1.f, q__1.i = -0.f;
+ chpmv_(uplo, n, &q__1, &ap[1], &x[j * x_dim1 + 1], &c__1, &c_b1, &
+ work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[
+ i__ + j * b_dim1]), dabs(r__2));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ kk = 1;
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j
+ * x_dim1]), dabs(r__2));
+ ik = kk;
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ik;
+ rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&ap[ik]), dabs(r__2))) * xk;
+ i__4 = ik;
+ i__5 = i__ + j * x_dim1;
+ s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
+ ap[ik]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs(
+ r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]),
+ dabs(r__4)));
+ ++ik;
+/* L40: */
+ }
+ i__3 = kk + k - 1;
+ rwork[k] = rwork[k] + (r__1 = ap[i__3].r, dabs(r__1)) * xk +
+ s;
+ kk += k;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j
+ * x_dim1]), dabs(r__2));
+ i__3 = kk;
+ rwork[k] += (r__1 = ap[i__3].r, dabs(r__1)) * xk;
+ ik = kk + 1;
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ i__4 = ik;
+ rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&ap[ik]), dabs(r__2))) * xk;
+ i__4 = ik;
+ i__5 = i__ + j * x_dim1;
+ s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
+ ap[ik]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs(
+ r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]),
+ dabs(r__4)));
+ ++ik;
+/* L60: */
+ }
+ rwork[k] += s;
+ kk += *n - k + 1;
+/* L70: */
+ }
+ }
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__3 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
+ s = dmax(r__3,r__4);
+ } else {
+/* Computing MAX */
+ i__3 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = dmax(r__3,r__4);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ cpptrs_(uplo, n, &c__1, &afp[1], &work[1], n, info);
+ caxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use CLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__3 = i__;
+ rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__];
+ } else {
+ i__3 = i__;
+ rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__] + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ cpptrs_(uplo, n, &c__1, &afp[1], &work[1], n, info)
+ ;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L120: */
+ }
+ cpptrs_(uplo, n, &c__1, &afp[1], &work[1], n, info)
+ ;
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * x_dim1;
+ r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + j * x_dim1]), dabs(r__2));
+ lstres = dmax(r__3,r__4);
+/* L130: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of CPPRFS */
+
+} /* cpprfs_ */
diff --git a/SRC/cppsv.c b/SRC/cppsv.c
new file mode 100644
index 0000000..c13d7d3
--- /dev/null
+++ b/SRC/cppsv.c
@@ -0,0 +1,160 @@
+/* cppsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cppsv_(char *uplo, integer *n, integer *nrhs, complex *
+ ap, complex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), cpptrf_(
+ char *, integer *, complex *, integer *), cpptrs_(char *,
+ integer *, integer *, complex *, complex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPPSV computes the solution to a complex system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N Hermitian positive definite matrix stored in */
+/* packed format and X and B are N-by-NRHS matrices. */
+
+/* The Cholesky decomposition is used to factor A as */
+/* A = U**H* U, if UPLO = 'U', or */
+/* A = L * L**H, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is a lower triangular */
+/* matrix. The factored form of A is then used to solve the system of */
+/* equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H, in the same storage */
+/* format as A. */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i of A is not */
+/* positive definite, so the factorization could not be */
+/* completed, and the solution has not been computed. */
+
+/* Further Details */
+/* =============== */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the Hermitian matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = conjg(aji)) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPPSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ cpptrf_(uplo, n, &ap[1], info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ cpptrs_(uplo, n, nrhs, &ap[1], &b[b_offset], ldb, info);
+
+ }
+ return 0;
+
+/* End of CPPSV */
+
+} /* cppsv_ */
diff --git a/SRC/cppsvx.c b/SRC/cppsvx.c
new file mode 100644
index 0000000..3898b38
--- /dev/null
+++ b/SRC/cppsvx.c
@@ -0,0 +1,461 @@
+/* cppsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cppsvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, complex *ap, complex *afp, char *equed, real *s, complex *b,
+ integer *ldb, complex *x, integer *ldx, real *rcond, real *ferr, real
+ *berr, complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j;
+ real amax, smin, smax;
+ extern logical lsame_(char *, char *);
+ real scond, anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ logical equil, rcequ;
+ extern doublereal clanhp_(char *, char *, integer *, complex *, real *), slamch_(char *);
+ extern /* Subroutine */ int claqhp_(char *, integer *, complex *, real *,
+ real *, real *, char *);
+ logical nofact;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), xerbla_(char *,
+ integer *);
+ real bignum;
+ extern /* Subroutine */ int cppcon_(char *, integer *, complex *, real *,
+ real *, complex *, real *, integer *);
+ integer infequ;
+ extern /* Subroutine */ int cppequ_(char *, integer *, complex *, real *,
+ real *, real *, integer *), cpprfs_(char *, integer *,
+ integer *, complex *, complex *, complex *, integer *, complex *,
+ integer *, real *, real *, complex *, real *, integer *),
+ cpptrf_(char *, integer *, complex *, integer *);
+ real smlnum;
+ extern /* Subroutine */ int cpptrs_(char *, integer *, integer *, complex
+ *, complex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPPSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to */
+/* compute the solution to a complex system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N Hermitian positive definite matrix stored in */
+/* packed format and X and B are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+/* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
+
+/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */
+/* factor the matrix A (after equilibration if FACT = 'E') as */
+/* A = U'* U , if UPLO = 'U', or */
+/* A = L * L', if UPLO = 'L', */
+/* where U is an upper triangular matrix, L is a lower triangular */
+/* matrix, and ' indicates conjugate transpose. */
+
+/* 3. If the leading i-by-i principal minor is not positive definite, */
+/* then the routine returns with INFO = i. Otherwise, the factored */
+/* form of A is used to estimate the condition number of the matrix */
+/* A. If the reciprocal of the condition number is less than machine */
+/* precision, INFO = N+1 is returned as a warning, but the routine */
+/* still goes on to solve for X and compute error bounds as */
+/* described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(S) so that it solves the original system before */
+/* equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AFP contains the factored form of A. */
+/* If EQUED = 'Y', the matrix A has been equilibrated */
+/* with scaling factors given by S. AP and AFP will not */
+/* be modified. */
+/* = 'N': The matrix A will be copied to AFP and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AFP and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array, except if FACT = 'F' */
+/* and EQUED = 'Y', then A must contain the equilibrated matrix */
+/* diag(S)*A*diag(S). The j-th column of A is stored in the */
+/* array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. A is not modified if */
+/* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
+
+/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
+/* diag(S)*A*diag(S). */
+
+/* AFP (input or output) COMPLEX array, dimension (N*(N+1)/2) */
+/* If FACT = 'F', then AFP is an input argument and on entry */
+/* contains the triangular factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H, in the same storage */
+/* format as A. If EQUED .ne. 'N', then AFP is the factored */
+/* form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AFP is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H of the original */
+/* matrix A. */
+
+/* If FACT = 'E', then AFP is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H of the equilibrated */
+/* matrix A (see the description of AP for the form of the */
+/* equilibrated matrix). */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* S (input or output) REAL array, dimension (N) */
+/* The scale factors for A; not accessed if EQUED = 'N'. S is */
+/* an input argument if FACT = 'F'; otherwise, S is an output */
+/* argument. If FACT = 'F' and EQUED = 'Y', each element of S */
+/* must be positive. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */
+/* B is overwritten by diag(S) * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */
+/* the original system of equations. Note that if EQUED = 'Y', */
+/* A and B are modified on exit, and the solution to the */
+/* equilibrated system is inv(diag(S))*X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A after equilibration (if done). If RCOND is less than the */
+/* machine precision (in particular, if RCOND = 0), the matrix */
+/* is singular to working precision. This condition is */
+/* indicated by a return code of INFO > 0. */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: the leading minor of order i of A is */
+/* not positive definite, so the factorization */
+/* could not be completed, and the solution has not */
+/* been computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* Further Details */
+/* =============== */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the Hermitian matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = conjg(aji)) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ap;
+ --afp;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rcequ = FALSE_;
+ } else {
+ rcequ = lsame_(equed, "Y");
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ }
+
+/* Test the input parameters. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (lsame_(fact, "F") && ! (rcequ || lsame_(
+ equed, "N"))) {
+ *info = -7;
+ } else {
+ if (rcequ) {
+ smin = bignum;
+ smax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = smin, r__2 = s[j];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = smax, r__2 = s[j];
+ smax = dmax(r__1,r__2);
+/* L10: */
+ }
+ if (smin <= 0.f) {
+ *info = -8;
+ } else if (*n > 0) {
+ scond = dmax(smin,smlnum) / dmin(smax,bignum);
+ } else {
+ scond = 1.f;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldx < max(1,*n)) {
+ *info = -12;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPPSVX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ cppequ_(uplo, n, &ap[1], &s[1], &scond, &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ claqhp_(uplo, n, &ap[1], &s[1], &scond, &amax, equed);
+ rcequ = lsame_(equed, "Y");
+ }
+ }
+
+/* Scale the right-hand side. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * b_dim1;
+ q__1.r = s[i__4] * b[i__5].r, q__1.i = s[i__4] * b[i__5].i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L20: */
+ }
+/* L30: */
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ i__1 = *n * (*n + 1) / 2;
+ ccopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1);
+ cpptrf_(uplo, n, &afp[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.f;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = clanhp_("I", uplo, n, &ap[1], &rwork[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ cppcon_(uplo, n, &afp[1], &anorm, rcond, &work[1], &rwork[1], info);
+
+/* Compute the solution matrix X. */
+
+ clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ cpptrs_(uplo, n, nrhs, &afp[1], &x[x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ cpprfs_(uplo, n, nrhs, &ap[1], &afp[1], &b[b_offset], ldb, &x[x_offset],
+ ldx, &ferr[1], &berr[1], &work[1], &rwork[1], info);
+
+/* Transform the solution matrix X to a solution of the original */
+/* system. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * x_dim1;
+ q__1.r = s[i__4] * x[i__5].r, q__1.i = s[i__4] * x[i__5].i;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+/* L40: */
+ }
+/* L50: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= scond;
+/* L60: */
+ }
+ }
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < slamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of CPPSVX */
+
+} /* cppsvx_ */
diff --git a/SRC/cpptrf.c b/SRC/cpptrf.c
new file mode 100644
index 0000000..39bf238
--- /dev/null
+++ b/SRC/cpptrf.c
@@ -0,0 +1,234 @@
+/* cpptrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b16 = -1.f;
+
+/* Subroutine */ int cpptrf_(char *uplo, integer *n, complex *ap, integer *
+ info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real r__1;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer j, jc, jj;
+ real ajj;
+ extern /* Subroutine */ int chpr_(char *, integer *, real *, complex *,
+ integer *, complex *);
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
+ complex *, complex *, integer *), csscal_(
+ integer *, real *, complex *, integer *), xerbla_(char *, integer
+ *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPPTRF computes the Cholesky factorization of a complex Hermitian */
+/* positive definite matrix A stored in packed format. */
+
+/* The factorization has the form */
+/* A = U**H * U, if UPLO = 'U', or */
+/* A = L * L**H, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+
+/* On exit, if INFO = 0, the triangular factor U or L from the */
+/* Cholesky factorization A = U**H*U or A = L*L**H, in the same */
+/* storage format as A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* Further Details */
+/* =============== */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the Hermitian matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = conjg(aji)) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPPTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ jj = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ jc = jj + 1;
+ jj += j;
+
+/* Compute elements 1:J-1 of column J. */
+
+ if (j > 1) {
+ i__2 = j - 1;
+ ctpsv_("Upper", "Conjugate transpose", "Non-unit", &i__2, &ap[
+ 1], &ap[jc], &c__1);
+ }
+
+/* Compute U(J,J) and test for non-positive-definiteness. */
+
+ i__2 = jj;
+ r__1 = ap[i__2].r;
+ i__3 = j - 1;
+ cdotc_(&q__2, &i__3, &ap[jc], &c__1, &ap[jc], &c__1);
+ q__1.r = r__1 - q__2.r, q__1.i = -q__2.i;
+ ajj = q__1.r;
+ if (ajj <= 0.f) {
+ i__2 = jj;
+ ap[i__2].r = ajj, ap[i__2].i = 0.f;
+ goto L30;
+ }
+ i__2 = jj;
+ r__1 = sqrt(ajj);
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+/* L10: */
+ }
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ jj = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute L(J,J) and test for non-positive-definiteness. */
+
+ i__2 = jj;
+ ajj = ap[i__2].r;
+ if (ajj <= 0.f) {
+ i__2 = jj;
+ ap[i__2].r = ajj, ap[i__2].i = 0.f;
+ goto L30;
+ }
+ ajj = sqrt(ajj);
+ i__2 = jj;
+ ap[i__2].r = ajj, ap[i__2].i = 0.f;
+
+/* Compute elements J+1:N of column J and update the trailing */
+/* submatrix. */
+
+ if (j < *n) {
+ i__2 = *n - j;
+ r__1 = 1.f / ajj;
+ csscal_(&i__2, &r__1, &ap[jj + 1], &c__1);
+ i__2 = *n - j;
+ chpr_("Lower", &i__2, &c_b16, &ap[jj + 1], &c__1, &ap[jj + *n
+ - j + 1]);
+ jj = jj + *n - j + 1;
+ }
+/* L20: */
+ }
+ }
+ goto L40;
+
+L30:
+ *info = j;
+
+L40:
+ return 0;
+
+/* End of CPPTRF */
+
+} /* cpptrf_ */
diff --git a/SRC/cpptri.c b/SRC/cpptri.c
new file mode 100644
index 0000000..b3dcfd4
--- /dev/null
+++ b/SRC/cpptri.c
@@ -0,0 +1,180 @@
+/* cpptri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b8 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int cpptri_(char *uplo, integer *n, complex *ap, integer *
+ info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real r__1;
+ complex q__1;
+
+ /* Local variables */
+ integer j, jc, jj;
+ real ajj;
+ integer jjn;
+ extern /* Subroutine */ int chpr_(char *, integer *, real *, complex *,
+ integer *, complex *);
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ctpmv_(char *, char *, char *, integer *,
+ complex *, complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), xerbla_(char *, integer *), ctptri_(char *, char *,
+ integer *, complex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPPTRI computes the inverse of a complex Hermitian positive definite */
+/* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H */
+/* computed by CPPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular factor is stored in AP; */
+/* = 'L': Lower triangular factor is stored in AP. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the triangular factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H, packed columnwise as */
+/* a linear array. The j-th column of U or L is stored in the */
+/* array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */
+
+/* On exit, the upper or lower triangle of the (Hermitian) */
+/* inverse of A, overwriting the input factor U or L. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the (i,i) element of the factor U or L is */
+/* zero, and the inverse could not be computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPPTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Invert the triangular Cholesky factor U or L. */
+
+ ctptri_(uplo, "Non-unit", n, &ap[1], info);
+ if (*info > 0) {
+ return 0;
+ }
+ if (upper) {
+
+/* Compute the product inv(U) * inv(U)'. */
+
+ jj = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ jc = jj + 1;
+ jj += j;
+ if (j > 1) {
+ i__2 = j - 1;
+ chpr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1]);
+ }
+ i__2 = jj;
+ ajj = ap[i__2].r;
+ csscal_(&j, &ajj, &ap[jc], &c__1);
+/* L10: */
+ }
+
+ } else {
+
+/* Compute the product inv(L)' * inv(L). */
+
+ jj = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ jjn = jj + *n - j + 1;
+ i__2 = jj;
+ i__3 = *n - j + 1;
+ cdotc_(&q__1, &i__3, &ap[jj], &c__1, &ap[jj], &c__1);
+ r__1 = q__1.r;
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+ if (j < *n) {
+ i__2 = *n - j;
+ ctpmv_("Lower", "Conjugate transpose", "Non-unit", &i__2, &ap[
+ jjn], &ap[jj + 1], &c__1);
+ }
+ jj = jjn;
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of CPPTRI */
+
+} /* cpptri_ */
diff --git a/SRC/cpptrs.c b/SRC/cpptrs.c
new file mode 100644
index 0000000..631f870
--- /dev/null
+++ b/SRC/cpptrs.c
@@ -0,0 +1,170 @@
+/* cpptrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cpptrs_(char *uplo, integer *n, integer *nrhs, complex *
+ ap, complex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ integer i__;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
+ complex *, complex *, integer *), xerbla_(
+ char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPPTRS solves a system of linear equations A*X = B with a Hermitian */
+/* positive definite matrix A in packed storage using the Cholesky */
+/* factorization A = U**H*U or A = L*L**H computed by CPPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**H*U or A = L*L**H, packed columnwise in a linear */
+/* array. The j-th column of U or L is stored in the array AP */
+/* as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPPTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B where A = U'*U. */
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Solve U'*X = B, overwriting B with X. */
+
+ ctpsv_("Upper", "Conjugate transpose", "Non-unit", n, &ap[1], &b[
+ i__ * b_dim1 + 1], &c__1);
+
+/* Solve U*X = B, overwriting B with X. */
+
+ ctpsv_("Upper", "No transpose", "Non-unit", n, &ap[1], &b[i__ *
+ b_dim1 + 1], &c__1);
+/* L10: */
+ }
+ } else {
+
+/* Solve A*X = B where A = L*L'. */
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Solve L*Y = B, overwriting B with X. */
+
+ ctpsv_("Lower", "No transpose", "Non-unit", n, &ap[1], &b[i__ *
+ b_dim1 + 1], &c__1);
+
+/* Solve L'*X = Y, overwriting B with X. */
+
+ ctpsv_("Lower", "Conjugate transpose", "Non-unit", n, &ap[1], &b[
+ i__ * b_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of CPPTRS */
+
+} /* cpptrs_ */
diff --git a/SRC/cpstf2.c b/SRC/cpstf2.c
new file mode 100644
index 0000000..1811995
--- /dev/null
+++ b/SRC/cpstf2.c
@@ -0,0 +1,442 @@
+/* cpstf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cpstf2_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *piv, integer *rank, real *tol, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, maxlocval;
+ real ajj;
+ integer pvt;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *);
+ complex ctemp;
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer itemp;
+ real stemp;
+ logical upper;
+ real sstop;
+ extern /* Subroutine */ int clacgv_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), xerbla_(char *, integer *);
+ extern logical sisnan_(real *);
+ extern integer smaxloc_(real *, integer *);
+
+
+/* -- LAPACK PROTOTYPE routine (version 3.2) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPSTF2 computes the Cholesky factorization with complete */
+/* pivoting of a complex Hermitian positive semidefinite matrix A. */
+
+/* The factorization has the form */
+/* P' * A * P = U' * U , if UPLO = 'U', */
+/* P' * A * P = L * L', if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular, and */
+/* P is stored as vector PIV. */
+
+/* This algorithm does not attempt to check that A is positive */
+/* semidefinite. This version of the algorithm calls level 2 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n by n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n by n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization as above. */
+
+/* PIV (output) INTEGER array, dimension (N) */
+/* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. */
+
+/* RANK (output) INTEGER */
+/* The rank of A given by the number of steps the algorithm */
+/* completed. */
+
+/* TOL (input) REAL */
+/* User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) ) */
+/* will be used. The algorithm terminates at the (K-1)st step */
+/* if the pivot <= TOL. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* WORK REAL array, dimension (2*N) */
+/* Work space. */
+
+/* INFO (output) INTEGER */
+/* < 0: If INFO = -K, the K-th argument had an illegal value, */
+/* = 0: algorithm completed successfully, and */
+/* > 0: the matrix A is either rank deficient with computed rank */
+/* as returned in RANK, or is indefinite. See Section 7 of */
+/* LAPACK Working Note #161 for further information. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ --work;
+ --piv;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPSTF2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Initialize PIV */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ piv[i__] = i__;
+/* L100: */
+ }
+
+/* Compute stopping value */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ work[i__] = a[i__2].r;
+/* L110: */
+ }
+ pvt = smaxloc_(&work[1], n);
+ i__1 = pvt + pvt * a_dim1;
+ ajj = a[i__1].r;
+ if (ajj == 0.f || sisnan_(&ajj)) {
+ *rank = 0;
+ *info = 1;
+ goto L200;
+ }
+
+/* Compute stopping value if not supplied */
+
+ if (*tol < 0.f) {
+ sstop = *n * slamch_("Epsilon") * ajj;
+ } else {
+ sstop = *tol;
+ }
+
+/* Set first half of WORK to zero, holds dot products */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L120: */
+ }
+
+ if (upper) {
+
+/* Compute the Cholesky factorization P' * A * P = U' * U */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Find pivot, test for exit, else swap rows and columns */
+/* Update dot products, compute possible pivots which are */
+/* stored in the second half of WORK */
+
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+
+ if (j > 1) {
+ r_cnjg(&q__2, &a[j - 1 + i__ * a_dim1]);
+ i__3 = j - 1 + i__ * a_dim1;
+ q__1.r = q__2.r * a[i__3].r - q__2.i * a[i__3].i, q__1.i =
+ q__2.r * a[i__3].i + q__2.i * a[i__3].r;
+ work[i__] += q__1.r;
+ }
+ i__3 = i__ + i__ * a_dim1;
+ work[*n + i__] = a[i__3].r - work[i__];
+
+/* L130: */
+ }
+
+ if (j > 1) {
+ maxlocval = (*n << 1) - (*n + j) + 1;
+ itemp = smaxloc_(&work[*n + j], &maxlocval);
+ pvt = itemp + j - 1;
+ ajj = work[*n + pvt];
+ if (ajj <= sstop || sisnan_(&ajj)) {
+ i__2 = j + j * a_dim1;
+ a[i__2].r = ajj, a[i__2].i = 0.f;
+ goto L190;
+ }
+ }
+
+ if (j != pvt) {
+
+/* Pivot OK, so can now swap pivot rows and columns */
+
+ i__2 = pvt + pvt * a_dim1;
+ i__3 = j + j * a_dim1;
+ a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
+ i__2 = j - 1;
+ cswap_(&i__2, &a[j * a_dim1 + 1], &c__1, &a[pvt * a_dim1 + 1],
+ &c__1);
+ if (pvt < *n) {
+ i__2 = *n - pvt;
+ cswap_(&i__2, &a[j + (pvt + 1) * a_dim1], lda, &a[pvt + (
+ pvt + 1) * a_dim1], lda);
+ }
+ i__2 = pvt - 1;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ r_cnjg(&q__1, &a[j + i__ * a_dim1]);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__3 = j + i__ * a_dim1;
+ r_cnjg(&q__1, &a[i__ + pvt * a_dim1]);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ i__3 = i__ + pvt * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+/* L140: */
+ }
+ i__2 = j + pvt * a_dim1;
+ r_cnjg(&q__1, &a[j + pvt * a_dim1]);
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+
+/* Swap dot products and PIV */
+
+ stemp = work[j];
+ work[j] = work[pvt];
+ work[pvt] = stemp;
+ itemp = piv[pvt];
+ piv[pvt] = piv[j];
+ piv[j] = itemp;
+ }
+
+ ajj = sqrt(ajj);
+ i__2 = j + j * a_dim1;
+ a[i__2].r = ajj, a[i__2].i = 0.f;
+
+/* Compute elements J+1:N of row J */
+
+ if (j < *n) {
+ i__2 = j - 1;
+ clacgv_(&i__2, &a[j * a_dim1 + 1], &c__1);
+ i__2 = j - 1;
+ i__3 = *n - j;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Trans", &i__2, &i__3, &q__1, &a[(j + 1) * a_dim1 + 1],
+ lda, &a[j * a_dim1 + 1], &c__1, &c_b1, &a[j + (j + 1)
+ * a_dim1], lda);
+ i__2 = j - 1;
+ clacgv_(&i__2, &a[j * a_dim1 + 1], &c__1);
+ i__2 = *n - j;
+ r__1 = 1.f / ajj;
+ csscal_(&i__2, &r__1, &a[j + (j + 1) * a_dim1], lda);
+ }
+
+/* L150: */
+ }
+
+ } else {
+
+/* Compute the Cholesky factorization P' * A * P = L * L' */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Find pivot, test for exit, else swap rows and columns */
+/* Update dot products, compute possible pivots which are */
+/* stored in the second half of WORK */
+
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+
+ if (j > 1) {
+ r_cnjg(&q__2, &a[i__ + (j - 1) * a_dim1]);
+ i__3 = i__ + (j - 1) * a_dim1;
+ q__1.r = q__2.r * a[i__3].r - q__2.i * a[i__3].i, q__1.i =
+ q__2.r * a[i__3].i + q__2.i * a[i__3].r;
+ work[i__] += q__1.r;
+ }
+ i__3 = i__ + i__ * a_dim1;
+ work[*n + i__] = a[i__3].r - work[i__];
+
+/* L160: */
+ }
+
+ if (j > 1) {
+ maxlocval = (*n << 1) - (*n + j) + 1;
+ itemp = smaxloc_(&work[*n + j], &maxlocval);
+ pvt = itemp + j - 1;
+ ajj = work[*n + pvt];
+ if (ajj <= sstop || sisnan_(&ajj)) {
+ i__2 = j + j * a_dim1;
+ a[i__2].r = ajj, a[i__2].i = 0.f;
+ goto L190;
+ }
+ }
+
+ if (j != pvt) {
+
+/* Pivot OK, so can now swap pivot rows and columns */
+
+ i__2 = pvt + pvt * a_dim1;
+ i__3 = j + j * a_dim1;
+ a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
+ i__2 = j - 1;
+ cswap_(&i__2, &a[j + a_dim1], lda, &a[pvt + a_dim1], lda);
+ if (pvt < *n) {
+ i__2 = *n - pvt;
+ cswap_(&i__2, &a[pvt + 1 + j * a_dim1], &c__1, &a[pvt + 1
+ + pvt * a_dim1], &c__1);
+ }
+ i__2 = pvt - 1;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ r_cnjg(&q__1, &a[i__ + j * a_dim1]);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__3 = i__ + j * a_dim1;
+ r_cnjg(&q__1, &a[pvt + i__ * a_dim1]);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ i__3 = pvt + i__ * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+/* L170: */
+ }
+ i__2 = pvt + j * a_dim1;
+ r_cnjg(&q__1, &a[pvt + j * a_dim1]);
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+
+/* Swap dot products and PIV */
+
+ stemp = work[j];
+ work[j] = work[pvt];
+ work[pvt] = stemp;
+ itemp = piv[pvt];
+ piv[pvt] = piv[j];
+ piv[j] = itemp;
+ }
+
+ ajj = sqrt(ajj);
+ i__2 = j + j * a_dim1;
+ a[i__2].r = ajj, a[i__2].i = 0.f;
+
+/* Compute elements J+1:N of column J */
+
+ if (j < *n) {
+ i__2 = j - 1;
+ clacgv_(&i__2, &a[j + a_dim1], lda);
+ i__2 = *n - j;
+ i__3 = j - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No Trans", &i__2, &i__3, &q__1, &a[j + 1 + a_dim1],
+ lda, &a[j + a_dim1], lda, &c_b1, &a[j + 1 + j *
+ a_dim1], &c__1);
+ i__2 = j - 1;
+ clacgv_(&i__2, &a[j + a_dim1], lda);
+ i__2 = *n - j;
+ r__1 = 1.f / ajj;
+ csscal_(&i__2, &r__1, &a[j + 1 + j * a_dim1], &c__1);
+ }
+
+/* L180: */
+ }
+
+ }
+
+/* Ran to completion, A has full rank */
+
+ *rank = *n;
+
+ goto L200;
+L190:
+
+/* Rank is number of steps completed. Set INFO = 1 to signal */
+/* that the factorization cannot be used to solve a system. */
+
+ *rank = j - 1;
+ *info = 1;
+
+L200:
+ return 0;
+
+/* End of CPSTF2 */
+
+} /* cpstf2_ */
diff --git a/SRC/cpstrf.c b/SRC/cpstrf.c
new file mode 100644
index 0000000..aab54b9
--- /dev/null
+++ b/SRC/cpstrf.c
@@ -0,0 +1,521 @@
+/* cpstrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b29 = -1.f;
+static real c_b30 = 1.f;
+
+/* Subroutine */ int cpstrf_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *piv, integer *rank, real *tol, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, maxlocval, jb, nb;
+ real ajj;
+ integer pvt;
+ extern /* Subroutine */ int cherk_(char *, char *, integer *, integer *,
+ real *, complex *, integer *, real *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *);
+ complex ctemp;
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer itemp;
+ real stemp;
+ logical upper;
+ real sstop;
+ extern /* Subroutine */ int cpstf2_(char *, integer *, complex *, integer
+ *, integer *, integer *, real *, real *, integer *),
+ clacgv_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern logical sisnan_(real *);
+ extern integer smaxloc_(real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPSTRF computes the Cholesky factorization with complete */
+/* pivoting of a complex Hermitian positive semidefinite matrix A. */
+
+/* The factorization has the form */
+/* P' * A * P = U' * U , if UPLO = 'U', */
+/* P' * A * P = L * L', if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular, and */
+/* P is stored as vector PIV. */
+
+/* This algorithm does not attempt to check that A is positive */
+/* semidefinite. This version of the algorithm calls level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n by n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n by n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization as above. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* PIV (output) INTEGER array, dimension (N) */
+/* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. */
+
+/* RANK (output) INTEGER */
+/* The rank of A given by the number of steps the algorithm */
+/* completed. */
+
+/* TOL (input) REAL */
+/* User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) ) */
+/* will be used. The algorithm terminates at the (K-1)st step */
+/* if the pivot <= TOL. */
+
+/* WORK REAL array, dimension (2*N) */
+/* Work space. */
+
+/* INFO (output) INTEGER */
+/* < 0: If INFO = -K, the K-th argument had an illegal value, */
+/* = 0: algorithm completed successfully, and */
+/* > 0: the matrix A is either rank deficient with computed rank */
+/* as returned in RANK, or is indefinite. See Section 7 of */
+/* LAPACK Working Note #161 for further information. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --work;
+ --piv;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPSTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get block size */
+
+ nb = ilaenv_(&c__1, "CPOTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code */
+
+ cpstf2_(uplo, n, &a[a_dim1 + 1], lda, &piv[1], rank, tol, &work[1],
+ info);
+ goto L230;
+
+ } else {
+
+/* Initialize PIV */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ piv[i__] = i__;
+/* L100: */
+ }
+
+/* Compute stopping value */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ work[i__] = a[i__2].r;
+/* L110: */
+ }
+ pvt = smaxloc_(&work[1], n);
+ i__1 = pvt + pvt * a_dim1;
+ ajj = a[i__1].r;
+ if (ajj == 0.f || sisnan_(&ajj)) {
+ *rank = 0;
+ *info = 1;
+ goto L230;
+ }
+
+/* Compute stopping value if not supplied */
+
+ if (*tol < 0.f) {
+ sstop = *n * slamch_("Epsilon") * ajj;
+ } else {
+ sstop = *tol;
+ }
+
+
+ if (upper) {
+
+/* Compute the Cholesky factorization P' * A * P = U' * U */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+
+/* Account for last block not being NB wide */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - k + 1;
+ jb = min(i__3,i__4);
+
+/* Set relevant part of first half of WORK to zero, */
+/* holds dot products */
+
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ work[i__] = 0.f;
+/* L120: */
+ }
+
+ i__3 = k + jb - 1;
+ for (j = k; j <= i__3; ++j) {
+
+/* Find pivot, test for exit, else swap rows and columns */
+/* Update dot products, compute possible pivots which are */
+/* stored in the second half of WORK */
+
+ i__4 = *n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+
+ if (j > k) {
+ r_cnjg(&q__2, &a[j - 1 + i__ * a_dim1]);
+ i__5 = j - 1 + i__ * a_dim1;
+ q__1.r = q__2.r * a[i__5].r - q__2.i * a[i__5].i,
+ q__1.i = q__2.r * a[i__5].i + q__2.i * a[
+ i__5].r;
+ work[i__] += q__1.r;
+ }
+ i__5 = i__ + i__ * a_dim1;
+ work[*n + i__] = a[i__5].r - work[i__];
+
+/* L130: */
+ }
+
+ if (j > 1) {
+ maxlocval = (*n << 1) - (*n + j) + 1;
+ itemp = smaxloc_(&work[*n + j], &maxlocval);
+ pvt = itemp + j - 1;
+ ajj = work[*n + pvt];
+ if (ajj <= sstop || sisnan_(&ajj)) {
+ i__4 = j + j * a_dim1;
+ a[i__4].r = ajj, a[i__4].i = 0.f;
+ goto L220;
+ }
+ }
+
+ if (j != pvt) {
+
+/* Pivot OK, so can now swap pivot rows and columns */
+
+ i__4 = pvt + pvt * a_dim1;
+ i__5 = j + j * a_dim1;
+ a[i__4].r = a[i__5].r, a[i__4].i = a[i__5].i;
+ i__4 = j - 1;
+ cswap_(&i__4, &a[j * a_dim1 + 1], &c__1, &a[pvt *
+ a_dim1 + 1], &c__1);
+ if (pvt < *n) {
+ i__4 = *n - pvt;
+ cswap_(&i__4, &a[j + (pvt + 1) * a_dim1], lda, &a[
+ pvt + (pvt + 1) * a_dim1], lda);
+ }
+ i__4 = pvt - 1;
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ r_cnjg(&q__1, &a[j + i__ * a_dim1]);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__5 = j + i__ * a_dim1;
+ r_cnjg(&q__1, &a[i__ + pvt * a_dim1]);
+ a[i__5].r = q__1.r, a[i__5].i = q__1.i;
+ i__5 = i__ + pvt * a_dim1;
+ a[i__5].r = ctemp.r, a[i__5].i = ctemp.i;
+/* L140: */
+ }
+ i__4 = j + pvt * a_dim1;
+ r_cnjg(&q__1, &a[j + pvt * a_dim1]);
+ a[i__4].r = q__1.r, a[i__4].i = q__1.i;
+
+/* Swap dot products and PIV */
+
+ stemp = work[j];
+ work[j] = work[pvt];
+ work[pvt] = stemp;
+ itemp = piv[pvt];
+ piv[pvt] = piv[j];
+ piv[j] = itemp;
+ }
+
+ ajj = sqrt(ajj);
+ i__4 = j + j * a_dim1;
+ a[i__4].r = ajj, a[i__4].i = 0.f;
+
+/* Compute elements J+1:N of row J. */
+
+ if (j < *n) {
+ i__4 = j - 1;
+ clacgv_(&i__4, &a[j * a_dim1 + 1], &c__1);
+ i__4 = j - k;
+ i__5 = *n - j;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Trans", &i__4, &i__5, &q__1, &a[k + (j + 1) *
+ a_dim1], lda, &a[k + j * a_dim1], &c__1, &
+ c_b1, &a[j + (j + 1) * a_dim1], lda);
+ i__4 = j - 1;
+ clacgv_(&i__4, &a[j * a_dim1 + 1], &c__1);
+ i__4 = *n - j;
+ r__1 = 1.f / ajj;
+ csscal_(&i__4, &r__1, &a[j + (j + 1) * a_dim1], lda);
+ }
+
+/* L150: */
+ }
+
+/* Update trailing matrix, J already incremented */
+
+ if (k + jb <= *n) {
+ i__3 = *n - j + 1;
+ cherk_("Upper", "Conj Trans", &i__3, &jb, &c_b29, &a[k +
+ j * a_dim1], lda, &c_b30, &a[j + j * a_dim1], lda);
+ }
+
+/* L160: */
+ }
+
+ } else {
+
+/* Compute the Cholesky factorization P' * A * P = L * L' */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+
+/* Account for last block not being NB wide */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - k + 1;
+ jb = min(i__3,i__4);
+
+/* Set relevant part of first half of WORK to zero, */
+/* holds dot products */
+
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ work[i__] = 0.f;
+/* L170: */
+ }
+
+ i__3 = k + jb - 1;
+ for (j = k; j <= i__3; ++j) {
+
+/* Find pivot, test for exit, else swap rows and columns */
+/* Update dot products, compute possible pivots which are */
+/* stored in the second half of WORK */
+
+ i__4 = *n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+
+ if (j > k) {
+ r_cnjg(&q__2, &a[i__ + (j - 1) * a_dim1]);
+ i__5 = i__ + (j - 1) * a_dim1;
+ q__1.r = q__2.r * a[i__5].r - q__2.i * a[i__5].i,
+ q__1.i = q__2.r * a[i__5].i + q__2.i * a[
+ i__5].r;
+ work[i__] += q__1.r;
+ }
+ i__5 = i__ + i__ * a_dim1;
+ work[*n + i__] = a[i__5].r - work[i__];
+
+/* L180: */
+ }
+
+ if (j > 1) {
+ maxlocval = (*n << 1) - (*n + j) + 1;
+ itemp = smaxloc_(&work[*n + j], &maxlocval);
+ pvt = itemp + j - 1;
+ ajj = work[*n + pvt];
+ if (ajj <= sstop || sisnan_(&ajj)) {
+ i__4 = j + j * a_dim1;
+ a[i__4].r = ajj, a[i__4].i = 0.f;
+ goto L220;
+ }
+ }
+
+ if (j != pvt) {
+
+/* Pivot OK, so can now swap pivot rows and columns */
+
+ i__4 = pvt + pvt * a_dim1;
+ i__5 = j + j * a_dim1;
+ a[i__4].r = a[i__5].r, a[i__4].i = a[i__5].i;
+ i__4 = j - 1;
+ cswap_(&i__4, &a[j + a_dim1], lda, &a[pvt + a_dim1],
+ lda);
+ if (pvt < *n) {
+ i__4 = *n - pvt;
+ cswap_(&i__4, &a[pvt + 1 + j * a_dim1], &c__1, &a[
+ pvt + 1 + pvt * a_dim1], &c__1);
+ }
+ i__4 = pvt - 1;
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ r_cnjg(&q__1, &a[i__ + j * a_dim1]);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__5 = i__ + j * a_dim1;
+ r_cnjg(&q__1, &a[pvt + i__ * a_dim1]);
+ a[i__5].r = q__1.r, a[i__5].i = q__1.i;
+ i__5 = pvt + i__ * a_dim1;
+ a[i__5].r = ctemp.r, a[i__5].i = ctemp.i;
+/* L190: */
+ }
+ i__4 = pvt + j * a_dim1;
+ r_cnjg(&q__1, &a[pvt + j * a_dim1]);
+ a[i__4].r = q__1.r, a[i__4].i = q__1.i;
+
+/* Swap dot products and PIV */
+
+ stemp = work[j];
+ work[j] = work[pvt];
+ work[pvt] = stemp;
+ itemp = piv[pvt];
+ piv[pvt] = piv[j];
+ piv[j] = itemp;
+ }
+
+ ajj = sqrt(ajj);
+ i__4 = j + j * a_dim1;
+ a[i__4].r = ajj, a[i__4].i = 0.f;
+
+/* Compute elements J+1:N of column J. */
+
+ if (j < *n) {
+ i__4 = j - 1;
+ clacgv_(&i__4, &a[j + a_dim1], lda);
+ i__4 = *n - j;
+ i__5 = j - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("No Trans", &i__4, &i__5, &q__1, &a[j + 1 + k *
+ a_dim1], lda, &a[j + k * a_dim1], lda, &c_b1,
+ &a[j + 1 + j * a_dim1], &c__1);
+ i__4 = j - 1;
+ clacgv_(&i__4, &a[j + a_dim1], lda);
+ i__4 = *n - j;
+ r__1 = 1.f / ajj;
+ csscal_(&i__4, &r__1, &a[j + 1 + j * a_dim1], &c__1);
+ }
+
+/* L200: */
+ }
+
+/* Update trailing matrix, J already incremented */
+
+ if (k + jb <= *n) {
+ i__3 = *n - j + 1;
+ cherk_("Lower", "No Trans", &i__3, &jb, &c_b29, &a[j + k *
+ a_dim1], lda, &c_b30, &a[j + j * a_dim1], lda);
+ }
+
+/* L210: */
+ }
+
+ }
+ }
+
+/* Ran to completion, A has full rank */
+
+ *rank = *n;
+
+ goto L230;
+L220:
+
+/* Rank is the number of steps completed. Set INFO = 1 to signal */
+/* that the factorization cannot be used to solve a system. */
+
+ *rank = j - 1;
+ *info = 1;
+
+L230:
+ return 0;
+
+/* End of CPSTRF */
+
+} /* cpstrf_ */
diff --git a/SRC/cptcon.c b/SRC/cptcon.c
new file mode 100644
index 0000000..a09b17d
--- /dev/null
+++ b/SRC/cptcon.c
@@ -0,0 +1,186 @@
+/* cptcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cptcon_(integer *n, real *d__, complex *e, real *anorm,
+ real *rcond, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+
+ /* Local variables */
+ integer i__, ix;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ real ainvnm;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPTCON computes the reciprocal of the condition number (in the */
+/* 1-norm) of a complex Hermitian positive definite tridiagonal matrix */
+/* using the factorization A = L*D*L**H or A = U**H*D*U computed by */
+/* CPTTRF. */
+
+/* Norm(inv(A)) is computed by a direct method, and the reciprocal of */
+/* the condition number is computed as */
+/* RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the diagonal matrix D from the */
+/* factorization of A, as computed by CPTTRF. */
+
+/* E (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) off-diagonal elements of the unit bidiagonal factor */
+/* U or L from the factorization of A, as computed by CPTTRF. */
+
+/* ANORM (input) REAL */
+/* The 1-norm of the original matrix A. */
+
+/* RCOND (output) REAL */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the */
+/* 1-norm of inv(A) computed in this routine. */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The method used is described in Nicholas J. Higham, "Efficient */
+/* Algorithms for Computing the Condition Number of a Tridiagonal */
+/* Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --e;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*anorm < 0.f) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPTCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.f;
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ } else if (*anorm == 0.f) {
+ return 0;
+ }
+
+/* Check that D(1:N) is positive. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (d__[i__] <= 0.f) {
+ return 0;
+ }
+/* L10: */
+ }
+
+/* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by */
+
+/* m(i,j) = abs(A(i,j)), i = j, */
+/* m(i,j) = -abs(A(i,j)), i .ne. j, */
+
+/* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'. */
+
+/* Solve M(L) * x = e. */
+
+ rwork[1] = 1.f;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ rwork[i__] = rwork[i__ - 1] * c_abs(&e[i__ - 1]) + 1.f;
+/* L20: */
+ }
+
+/* Solve D * M(L)' * x = b. */
+
+ rwork[*n] /= d__[*n];
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ rwork[i__] = rwork[i__] / d__[i__] + rwork[i__ + 1] * c_abs(&e[i__]);
+/* L30: */
+ }
+
+/* Compute AINVNM = max(x(i)), 1<=i<=n. */
+
+ ix = isamax_(n, &rwork[1], &c__1);
+ ainvnm = (r__1 = rwork[ix], dabs(r__1));
+
+/* Compute the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / ainvnm / *anorm;
+ }
+
+ return 0;
+
+/* End of CPTCON */
+
+} /* cptcon_ */
diff --git a/SRC/cpteqr.c b/SRC/cpteqr.c
new file mode 100644
index 0000000..82c53c6
--- /dev/null
+++ b/SRC/cpteqr.c
@@ -0,0 +1,241 @@
+/* cpteqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int cpteqr_(char *compz, integer *n, real *d__, real *e,
+ complex *z__, integer *ldz, real *work, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ complex c__[1] /* was [1][1] */;
+ integer i__;
+ complex vt[1] /* was [1][1] */;
+ integer nru;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), xerbla_(char *,
+ integer *), cbdsqr_(char *, integer *, integer *, integer
+ *, integer *, real *, real *, complex *, integer *, complex *,
+ integer *, complex *, integer *, real *, integer *);
+ integer icompz;
+ extern /* Subroutine */ int spttrf_(integer *, real *, real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPTEQR computes all eigenvalues and, optionally, eigenvectors of a */
+/* symmetric positive definite tridiagonal matrix by first factoring the */
+/* matrix using SPTTRF and then calling CBDSQR to compute the singular */
+/* values of the bidiagonal factor. */
+
+/* This routine computes the eigenvalues of the positive definite */
+/* tridiagonal matrix to high relative accuracy. This means that if the */
+/* eigenvalues range over many orders of magnitude in size, then the */
+/* small eigenvalues and corresponding eigenvectors will be computed */
+/* more accurately than, for example, with the standard QR method. */
+
+/* The eigenvectors of a full or band positive definite Hermitian matrix */
+/* can also be found if CHETRD, CHPTRD, or CHBTRD has been used to */
+/* reduce this matrix to tridiagonal form. (The reduction to */
+/* tridiagonal form, however, may preclude the possibility of obtaining */
+/* high relative accuracy in the small eigenvalues of the original */
+/* matrix, if these eigenvalues range over many orders of magnitude.) */
+
+/* Arguments */
+/* ========= */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only. */
+/* = 'V': Compute eigenvectors of original Hermitian */
+/* matrix also. Array Z contains the unitary matrix */
+/* used to reduce the original matrix to tridiagonal */
+/* form. */
+/* = 'I': Compute eigenvectors of tridiagonal matrix also. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the n diagonal elements of the tridiagonal matrix. */
+/* On normal exit, D contains the eigenvalues, in descending */
+/* order. */
+
+/* E (input/output) REAL array, dimension (N-1) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix. */
+/* On exit, E has been destroyed. */
+
+/* Z (input/output) COMPLEX array, dimension (LDZ, N) */
+/* On entry, if COMPZ = 'V', the unitary matrix used in the */
+/* reduction to tridiagonal form. */
+/* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the */
+/* original Hermitian matrix; */
+/* if COMPZ = 'I', the orthonormal eigenvectors of the */
+/* tridiagonal matrix. */
+/* If INFO > 0 on exit, Z contains the eigenvectors associated */
+/* with only the stored eigenvalues. */
+/* If COMPZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* COMPZ = 'V' or 'I', LDZ >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (4*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, and i is: */
+/* <= N the Cholesky factorization of the matrix could */
+/* not be performed because the i-th principal minor */
+/* was not positive definite. */
+/* > N the SVD algorithm failed to converge; */
+/* if INFO = N+i, i off-diagonal elements of the */
+/* bidiagonal factor did not converge to zero. */
+
+/* ==================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+ if (lsame_(compz, "N")) {
+ icompz = 0;
+ } else if (lsame_(compz, "V")) {
+ icompz = 1;
+ } else if (lsame_(compz, "I")) {
+ icompz = 2;
+ } else {
+ icompz = -1;
+ }
+ if (icompz < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPTEQR", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (icompz > 0) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1.f, z__[i__1].i = 0.f;
+ }
+ return 0;
+ }
+ if (icompz == 2) {
+ claset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
+ }
+
+/* Call SPTTRF to factor the matrix. */
+
+ spttrf_(n, &d__[1], &e[1], info);
+ if (*info != 0) {
+ return 0;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = sqrt(d__[i__]);
+/* L10: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ e[i__] *= d__[i__];
+/* L20: */
+ }
+
+/* Call CBDSQR to compute the singular values/vectors of the */
+/* bidiagonal factor. */
+
+ if (icompz > 0) {
+ nru = *n;
+ } else {
+ nru = 0;
+ }
+ cbdsqr_("Lower", n, &c__0, &nru, &c__0, &d__[1], &e[1], vt, &c__1, &z__[
+ z_offset], ldz, c__, &c__1, &work[1], info);
+
+/* Square the singular values. */
+
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] *= d__[i__];
+/* L30: */
+ }
+ } else {
+ *info = *n + *info;
+ }
+
+ return 0;
+
+/* End of CPTEQR */
+
+} /* cpteqr_ */
diff --git a/SRC/cptrfs.c b/SRC/cptrfs.c
new file mode 100644
index 0000000..66e9b3c
--- /dev/null
+++ b/SRC/cptrfs.c
@@ -0,0 +1,574 @@
+/* cptrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static complex c_b16 = {1.f,0.f};
+
+/* Subroutine */ int cptrfs_(char *uplo, integer *n, integer *nrhs, real *d__,
+ complex *e, real *df, complex *ef, complex *b, integer *ldb, complex
+ *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6;
+ real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10, r__11,
+ r__12;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void r_cnjg(complex *, complex *);
+ double c_abs(complex *);
+
+ /* Local variables */
+ integer i__, j;
+ real s;
+ complex bi, cx, dx, ex;
+ integer ix, nz;
+ real eps, safe1, safe2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ integer count;
+ logical upper;
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ real lstres;
+ extern /* Subroutine */ int cpttrs_(char *, integer *, integer *, real *,
+ complex *, complex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPTRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is Hermitian positive definite */
+/* and tridiagonal, and provides error bounds and backward error */
+/* estimates for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the superdiagonal or the subdiagonal of the */
+/* tridiagonal matrix A is stored and the form of the */
+/* factorization: */
+/* = 'U': E is the superdiagonal of A, and A = U**H*D*U; */
+/* = 'L': E is the subdiagonal of A, and A = L*D*L**H. */
+/* (The two forms are equivalent if A is real.) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n real diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) off-diagonal elements of the tridiagonal matrix A */
+/* (see UPLO). */
+
+/* DF (input) REAL array, dimension (N) */
+/* The n diagonal elements of the diagonal matrix D from */
+/* the factorization computed by CPTTRF. */
+
+/* EF (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) off-diagonal elements of the unit bidiagonal */
+/* factor U or L from the factorization computed by CPTTRF */
+/* (see UPLO). */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by CPTTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --df;
+ --ef;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPTRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = 4;
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.f;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X. Also compute */
+/* abs(A)*abs(x) + abs(b) for use in the backward error bound. */
+
+ if (upper) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ bi.r = b[i__2].r, bi.i = b[i__2].i;
+ i__2 = j * x_dim1 + 1;
+ q__1.r = d__[1] * x[i__2].r, q__1.i = d__[1] * x[i__2].i;
+ dx.r = q__1.r, dx.i = q__1.i;
+ q__1.r = bi.r - dx.r, q__1.i = bi.i - dx.i;
+ work[1].r = q__1.r, work[1].i = q__1.i;
+ rwork[1] = (r__1 = bi.r, dabs(r__1)) + (r__2 = r_imag(&bi),
+ dabs(r__2)) + ((r__3 = dx.r, dabs(r__3)) + (r__4 =
+ r_imag(&dx), dabs(r__4)));
+ } else {
+ i__2 = j * b_dim1 + 1;
+ bi.r = b[i__2].r, bi.i = b[i__2].i;
+ i__2 = j * x_dim1 + 1;
+ q__1.r = d__[1] * x[i__2].r, q__1.i = d__[1] * x[i__2].i;
+ dx.r = q__1.r, dx.i = q__1.i;
+ i__2 = j * x_dim1 + 2;
+ q__1.r = e[1].r * x[i__2].r - e[1].i * x[i__2].i, q__1.i = e[
+ 1].r * x[i__2].i + e[1].i * x[i__2].r;
+ ex.r = q__1.r, ex.i = q__1.i;
+ q__2.r = bi.r - dx.r, q__2.i = bi.i - dx.i;
+ q__1.r = q__2.r - ex.r, q__1.i = q__2.i - ex.i;
+ work[1].r = q__1.r, work[1].i = q__1.i;
+ i__2 = j * x_dim1 + 2;
+ rwork[1] = (r__1 = bi.r, dabs(r__1)) + (r__2 = r_imag(&bi),
+ dabs(r__2)) + ((r__3 = dx.r, dabs(r__3)) + (r__4 =
+ r_imag(&dx), dabs(r__4))) + ((r__5 = e[1].r, dabs(
+ r__5)) + (r__6 = r_imag(&e[1]), dabs(r__6))) * ((r__7
+ = x[i__2].r, dabs(r__7)) + (r__8 = r_imag(&x[j *
+ x_dim1 + 2]), dabs(r__8)));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ bi.r = b[i__3].r, bi.i = b[i__3].i;
+ r_cnjg(&q__2, &e[i__ - 1]);
+ i__3 = i__ - 1 + j * x_dim1;
+ q__1.r = q__2.r * x[i__3].r - q__2.i * x[i__3].i, q__1.i =
+ q__2.r * x[i__3].i + q__2.i * x[i__3].r;
+ cx.r = q__1.r, cx.i = q__1.i;
+ i__3 = i__;
+ i__4 = i__ + j * x_dim1;
+ q__1.r = d__[i__3] * x[i__4].r, q__1.i = d__[i__3] * x[
+ i__4].i;
+ dx.r = q__1.r, dx.i = q__1.i;
+ i__3 = i__;
+ i__4 = i__ + 1 + j * x_dim1;
+ q__1.r = e[i__3].r * x[i__4].r - e[i__3].i * x[i__4].i,
+ q__1.i = e[i__3].r * x[i__4].i + e[i__3].i * x[
+ i__4].r;
+ ex.r = q__1.r, ex.i = q__1.i;
+ i__3 = i__;
+ q__3.r = bi.r - cx.r, q__3.i = bi.i - cx.i;
+ q__2.r = q__3.r - dx.r, q__2.i = q__3.i - dx.i;
+ q__1.r = q__2.r - ex.r, q__1.i = q__2.i - ex.i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ i__3 = i__ - 1;
+ i__4 = i__ - 1 + j * x_dim1;
+ i__5 = i__;
+ i__6 = i__ + 1 + j * x_dim1;
+ rwork[i__] = (r__1 = bi.r, dabs(r__1)) + (r__2 = r_imag(&
+ bi), dabs(r__2)) + ((r__3 = e[i__3].r, dabs(r__3))
+ + (r__4 = r_imag(&e[i__ - 1]), dabs(r__4))) * ((
+ r__5 = x[i__4].r, dabs(r__5)) + (r__6 = r_imag(&x[
+ i__ - 1 + j * x_dim1]), dabs(r__6))) + ((r__7 =
+ dx.r, dabs(r__7)) + (r__8 = r_imag(&dx), dabs(
+ r__8))) + ((r__9 = e[i__5].r, dabs(r__9)) + (
+ r__10 = r_imag(&e[i__]), dabs(r__10))) * ((r__11 =
+ x[i__6].r, dabs(r__11)) + (r__12 = r_imag(&x[i__
+ + 1 + j * x_dim1]), dabs(r__12)));
+/* L30: */
+ }
+ i__2 = *n + j * b_dim1;
+ bi.r = b[i__2].r, bi.i = b[i__2].i;
+ r_cnjg(&q__2, &e[*n - 1]);
+ i__2 = *n - 1 + j * x_dim1;
+ q__1.r = q__2.r * x[i__2].r - q__2.i * x[i__2].i, q__1.i =
+ q__2.r * x[i__2].i + q__2.i * x[i__2].r;
+ cx.r = q__1.r, cx.i = q__1.i;
+ i__2 = *n;
+ i__3 = *n + j * x_dim1;
+ q__1.r = d__[i__2] * x[i__3].r, q__1.i = d__[i__2] * x[i__3]
+ .i;
+ dx.r = q__1.r, dx.i = q__1.i;
+ i__2 = *n;
+ q__2.r = bi.r - cx.r, q__2.i = bi.i - cx.i;
+ q__1.r = q__2.r - dx.r, q__1.i = q__2.i - dx.i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ i__2 = *n - 1;
+ i__3 = *n - 1 + j * x_dim1;
+ rwork[*n] = (r__1 = bi.r, dabs(r__1)) + (r__2 = r_imag(&bi),
+ dabs(r__2)) + ((r__3 = e[i__2].r, dabs(r__3)) + (r__4
+ = r_imag(&e[*n - 1]), dabs(r__4))) * ((r__5 = x[i__3]
+ .r, dabs(r__5)) + (r__6 = r_imag(&x[*n - 1 + j *
+ x_dim1]), dabs(r__6))) + ((r__7 = dx.r, dabs(r__7)) +
+ (r__8 = r_imag(&dx), dabs(r__8)));
+ }
+ } else {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ bi.r = b[i__2].r, bi.i = b[i__2].i;
+ i__2 = j * x_dim1 + 1;
+ q__1.r = d__[1] * x[i__2].r, q__1.i = d__[1] * x[i__2].i;
+ dx.r = q__1.r, dx.i = q__1.i;
+ q__1.r = bi.r - dx.r, q__1.i = bi.i - dx.i;
+ work[1].r = q__1.r, work[1].i = q__1.i;
+ rwork[1] = (r__1 = bi.r, dabs(r__1)) + (r__2 = r_imag(&bi),
+ dabs(r__2)) + ((r__3 = dx.r, dabs(r__3)) + (r__4 =
+ r_imag(&dx), dabs(r__4)));
+ } else {
+ i__2 = j * b_dim1 + 1;
+ bi.r = b[i__2].r, bi.i = b[i__2].i;
+ i__2 = j * x_dim1 + 1;
+ q__1.r = d__[1] * x[i__2].r, q__1.i = d__[1] * x[i__2].i;
+ dx.r = q__1.r, dx.i = q__1.i;
+ r_cnjg(&q__2, &e[1]);
+ i__2 = j * x_dim1 + 2;
+ q__1.r = q__2.r * x[i__2].r - q__2.i * x[i__2].i, q__1.i =
+ q__2.r * x[i__2].i + q__2.i * x[i__2].r;
+ ex.r = q__1.r, ex.i = q__1.i;
+ q__2.r = bi.r - dx.r, q__2.i = bi.i - dx.i;
+ q__1.r = q__2.r - ex.r, q__1.i = q__2.i - ex.i;
+ work[1].r = q__1.r, work[1].i = q__1.i;
+ i__2 = j * x_dim1 + 2;
+ rwork[1] = (r__1 = bi.r, dabs(r__1)) + (r__2 = r_imag(&bi),
+ dabs(r__2)) + ((r__3 = dx.r, dabs(r__3)) + (r__4 =
+ r_imag(&dx), dabs(r__4))) + ((r__5 = e[1].r, dabs(
+ r__5)) + (r__6 = r_imag(&e[1]), dabs(r__6))) * ((r__7
+ = x[i__2].r, dabs(r__7)) + (r__8 = r_imag(&x[j *
+ x_dim1 + 2]), dabs(r__8)));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ bi.r = b[i__3].r, bi.i = b[i__3].i;
+ i__3 = i__ - 1;
+ i__4 = i__ - 1 + j * x_dim1;
+ q__1.r = e[i__3].r * x[i__4].r - e[i__3].i * x[i__4].i,
+ q__1.i = e[i__3].r * x[i__4].i + e[i__3].i * x[
+ i__4].r;
+ cx.r = q__1.r, cx.i = q__1.i;
+ i__3 = i__;
+ i__4 = i__ + j * x_dim1;
+ q__1.r = d__[i__3] * x[i__4].r, q__1.i = d__[i__3] * x[
+ i__4].i;
+ dx.r = q__1.r, dx.i = q__1.i;
+ r_cnjg(&q__2, &e[i__]);
+ i__3 = i__ + 1 + j * x_dim1;
+ q__1.r = q__2.r * x[i__3].r - q__2.i * x[i__3].i, q__1.i =
+ q__2.r * x[i__3].i + q__2.i * x[i__3].r;
+ ex.r = q__1.r, ex.i = q__1.i;
+ i__3 = i__;
+ q__3.r = bi.r - cx.r, q__3.i = bi.i - cx.i;
+ q__2.r = q__3.r - dx.r, q__2.i = q__3.i - dx.i;
+ q__1.r = q__2.r - ex.r, q__1.i = q__2.i - ex.i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ i__3 = i__ - 1;
+ i__4 = i__ - 1 + j * x_dim1;
+ i__5 = i__;
+ i__6 = i__ + 1 + j * x_dim1;
+ rwork[i__] = (r__1 = bi.r, dabs(r__1)) + (r__2 = r_imag(&
+ bi), dabs(r__2)) + ((r__3 = e[i__3].r, dabs(r__3))
+ + (r__4 = r_imag(&e[i__ - 1]), dabs(r__4))) * ((
+ r__5 = x[i__4].r, dabs(r__5)) + (r__6 = r_imag(&x[
+ i__ - 1 + j * x_dim1]), dabs(r__6))) + ((r__7 =
+ dx.r, dabs(r__7)) + (r__8 = r_imag(&dx), dabs(
+ r__8))) + ((r__9 = e[i__5].r, dabs(r__9)) + (
+ r__10 = r_imag(&e[i__]), dabs(r__10))) * ((r__11 =
+ x[i__6].r, dabs(r__11)) + (r__12 = r_imag(&x[i__
+ + 1 + j * x_dim1]), dabs(r__12)));
+/* L40: */
+ }
+ i__2 = *n + j * b_dim1;
+ bi.r = b[i__2].r, bi.i = b[i__2].i;
+ i__2 = *n - 1;
+ i__3 = *n - 1 + j * x_dim1;
+ q__1.r = e[i__2].r * x[i__3].r - e[i__2].i * x[i__3].i,
+ q__1.i = e[i__2].r * x[i__3].i + e[i__2].i * x[i__3]
+ .r;
+ cx.r = q__1.r, cx.i = q__1.i;
+ i__2 = *n;
+ i__3 = *n + j * x_dim1;
+ q__1.r = d__[i__2] * x[i__3].r, q__1.i = d__[i__2] * x[i__3]
+ .i;
+ dx.r = q__1.r, dx.i = q__1.i;
+ i__2 = *n;
+ q__2.r = bi.r - cx.r, q__2.i = bi.i - cx.i;
+ q__1.r = q__2.r - dx.r, q__1.i = q__2.i - dx.i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ i__2 = *n - 1;
+ i__3 = *n - 1 + j * x_dim1;
+ rwork[*n] = (r__1 = bi.r, dabs(r__1)) + (r__2 = r_imag(&bi),
+ dabs(r__2)) + ((r__3 = e[i__2].r, dabs(r__3)) + (r__4
+ = r_imag(&e[*n - 1]), dabs(r__4))) * ((r__5 = x[i__3]
+ .r, dabs(r__5)) + (r__6 = r_imag(&x[*n - 1 + j *
+ x_dim1]), dabs(r__6))) + ((r__7 = dx.r, dabs(r__7)) +
+ (r__8 = r_imag(&dx), dabs(r__8)));
+ }
+ }
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__3 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
+ s = dmax(r__3,r__4);
+ } else {
+/* Computing MAX */
+ i__3 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = dmax(r__3,r__4);
+ }
+/* L50: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ cpttrs_(uplo, n, &c__1, &df[1], &ef[1], &work[1], n, info);
+ caxpy_(n, &c_b16, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__3 = i__;
+ rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__];
+ } else {
+ i__3 = i__;
+ rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__] + safe1;
+ }
+/* L60: */
+ }
+ ix = isamax_(n, &rwork[1], &c__1);
+ ferr[j] = rwork[ix];
+
+/* Estimate the norm of inv(A). */
+
+/* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by */
+
+/* m(i,j) = abs(A(i,j)), i = j, */
+/* m(i,j) = -abs(A(i,j)), i .ne. j, */
+
+/* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'. */
+
+/* Solve M(L) * x = e. */
+
+ rwork[1] = 1.f;
+ i__2 = *n;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ rwork[i__] = rwork[i__ - 1] * c_abs(&ef[i__ - 1]) + 1.f;
+/* L70: */
+ }
+
+/* Solve D * M(L)' * x = b. */
+
+ rwork[*n] /= df[*n];
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ rwork[i__] = rwork[i__] / df[i__] + rwork[i__ + 1] * c_abs(&ef[
+ i__]);
+/* L80: */
+ }
+
+/* Compute norm(inv(A)) = max(x(i)), 1<=i<=n. */
+
+ ix = isamax_(n, &rwork[1], &c__1);
+ ferr[j] *= (r__1 = rwork[ix], dabs(r__1));
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = lstres, r__2 = c_abs(&x[i__ + j * x_dim1]);
+ lstres = dmax(r__1,r__2);
+/* L90: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L100: */
+ }
+
+ return 0;
+
+/* End of CPTRFS */
+
+} /* cptrfs_ */
diff --git a/SRC/cptsv.c b/SRC/cptsv.c
new file mode 100644
index 0000000..5f9b31f
--- /dev/null
+++ b/SRC/cptsv.c
@@ -0,0 +1,129 @@
+/* cptsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cptsv_(integer *n, integer *nrhs, real *d__, complex *e,
+ complex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int xerbla_(char *, integer *), cpttrf_(
+ integer *, real *, complex *, integer *), cpttrs_(char *, integer
+ *, integer *, real *, complex *, complex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPTSV computes the solution to a complex system of linear equations */
+/* A*X = B, where A is an N-by-N Hermitian positive definite tridiagonal */
+/* matrix, and X and B are N-by-NRHS matrices. */
+
+/* A is factored as A = L*D*L**H, and the factored form of A is then */
+/* used to solve the system of equations. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the n diagonal elements of the tridiagonal matrix */
+/* A. On exit, the n diagonal elements of the diagonal matrix */
+/* D from the factorization A = L*D*L**H. */
+
+/* E (input/output) COMPLEX array, dimension (N-1) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix A. On exit, the (n-1) subdiagonal elements of the */
+/* unit bidiagonal factor L from the L*D*L**H factorization of */
+/* A. E can also be regarded as the superdiagonal of the unit */
+/* bidiagonal factor U from the U**H*D*U factorization of A. */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the solution has not been */
+/* computed. The factorization has not been completed */
+/* unless i = N. */
+
+/* ===================================================================== */
+
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*ldb < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPTSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the L*D*L' (or U'*D*U) factorization of A. */
+
+ cpttrf_(n, &d__[1], &e[1], info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ cpttrs_("Lower", n, nrhs, &d__[1], &e[1], &b[b_offset], ldb, info);
+ }
+ return 0;
+
+/* End of CPTSV */
+
+} /* cptsv_ */
diff --git a/SRC/cptsvx.c b/SRC/cptsvx.c
new file mode 100644
index 0000000..2e31446
--- /dev/null
+++ b/SRC/cptsvx.c
@@ -0,0 +1,285 @@
+/* cptsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cptsvx_(char *fact, integer *n, integer *nrhs, real *d__,
+ complex *e, real *df, complex *ef, complex *b, integer *ldb, complex
+ *x, integer *ldx, real *rcond, real *ferr, real *berr, complex *work,
+ real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), scopy_(integer *, real *, integer *, real *
+, integer *);
+ extern doublereal slamch_(char *), clanht_(char *, integer *,
+ real *, complex *);
+ logical nofact;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), xerbla_(char *,
+ integer *), cptcon_(integer *, real *, complex *, real *,
+ real *, real *, integer *), cptrfs_(char *, integer *, integer *,
+ real *, complex *, real *, complex *, complex *, integer *,
+ complex *, integer *, real *, real *, complex *, real *, integer *
+), cpttrf_(integer *, real *, complex *, integer *),
+ cpttrs_(char *, integer *, integer *, real *, complex *, complex *
+, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPTSVX uses the factorization A = L*D*L**H to compute the solution */
+/* to a complex system of linear equations A*X = B, where A is an */
+/* N-by-N Hermitian positive definite tridiagonal matrix and X and B */
+/* are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**H, where L */
+/* is a unit lower bidiagonal matrix and D is diagonal. The */
+/* factorization can also be regarded as having the form */
+/* A = U**H*D*U. */
+
+/* 2. If the leading i-by-i principal minor is not positive definite, */
+/* then the routine returns with INFO = i. Otherwise, the factored */
+/* form of A is used to estimate the condition number of the matrix */
+/* A. If the reciprocal of the condition number is less than machine */
+/* precision, INFO = N+1 is returned as a warning, but the routine */
+/* still goes on to solve for X and compute error bounds as */
+/* described below. */
+
+/* 3. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 4. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix */
+/* A is supplied on entry. */
+/* = 'F': On entry, DF and EF contain the factored form of A. */
+/* D, E, DF, and EF will not be modified. */
+/* = 'N': The matrix A will be copied to DF and EF and */
+/* factored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
+
+/* DF (input or output) REAL array, dimension (N) */
+/* If FACT = 'F', then DF is an input argument and on entry */
+/* contains the n diagonal elements of the diagonal matrix D */
+/* from the L*D*L**H factorization of A. */
+/* If FACT = 'N', then DF is an output argument and on exit */
+/* contains the n diagonal elements of the diagonal matrix D */
+/* from the L*D*L**H factorization of A. */
+
+/* EF (input or output) COMPLEX array, dimension (N-1) */
+/* If FACT = 'F', then EF is an input argument and on entry */
+/* contains the (n-1) subdiagonal elements of the unit */
+/* bidiagonal factor L from the L*D*L**H factorization of A. */
+/* If FACT = 'N', then EF is an output argument and on exit */
+/* contains the (n-1) subdiagonal elements of the unit */
+/* bidiagonal factor L from the L*D*L**H factorization of A. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The reciprocal condition number of the matrix A. If RCOND */
+/* is less than the machine precision (in particular, if */
+/* RCOND = 0), the matrix is singular to working precision. */
+/* This condition is indicated by a return code of INFO > 0. */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in any */
+/* element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: the leading minor of order i of A is */
+/* not positive definite, so the factorization */
+/* could not be completed, and the solution has not */
+/* been computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --df;
+ --ef;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ if (! nofact && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPTSVX", &i__1);
+ return 0;
+ }
+
+ if (nofact) {
+
+/* Compute the L*D*L' (or U'*D*U) factorization of A. */
+
+ scopy_(n, &d__[1], &c__1, &df[1], &c__1);
+ if (*n > 1) {
+ i__1 = *n - 1;
+ ccopy_(&i__1, &e[1], &c__1, &ef[1], &c__1);
+ }
+ cpttrf_(n, &df[1], &ef[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.f;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = clanht_("1", n, &d__[1], &e[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ cptcon_(n, &df[1], &ef[1], &anorm, rcond, &rwork[1], info);
+
+/* Compute the solution vectors X. */
+
+ clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ cpttrs_("Lower", n, nrhs, &df[1], &ef[1], &x[x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solutions and */
+/* compute error bounds and backward error estimates for them. */
+
+ cptrfs_("Lower", n, nrhs, &d__[1], &e[1], &df[1], &ef[1], &b[b_offset],
+ ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1], &rwork[1],
+ info);
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < slamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of CPTSVX */
+
+} /* cptsvx_ */
diff --git a/SRC/cpttrf.c b/SRC/cpttrf.c
new file mode 100644
index 0000000..29a877c
--- /dev/null
+++ b/SRC/cpttrf.c
@@ -0,0 +1,215 @@
+/* cpttrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cpttrf_(integer *n, real *d__, complex *e, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ real f, g;
+ integer i__, i4;
+ real eii, eir;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPTTRF computes the L*D*L' factorization of a complex Hermitian */
+/* positive definite tridiagonal matrix A. The factorization may also */
+/* be regarded as having the form A = U'*D*U. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the n diagonal elements of the tridiagonal matrix */
+/* A. On exit, the n diagonal elements of the diagonal matrix */
+/* D from the L*D*L' factorization of A. */
+
+/* E (input/output) COMPLEX array, dimension (N-1) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix A. On exit, the (n-1) subdiagonal elements of the */
+/* unit bidiagonal factor L from the L*D*L' factorization of A. */
+/* E can also be regarded as the superdiagonal of the unit */
+/* bidiagonal factor U from the U'*D*U factorization of A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, the leading minor of order k is not */
+/* positive definite; if k < N, the factorization could not */
+/* be completed, while if k = N, the factorization was */
+/* completed, but D(N) <= 0. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --e;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ i__1 = -(*info);
+ xerbla_("CPTTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Compute the L*D*L' (or U'*D*U) factorization of A. */
+
+ i4 = (*n - 1) % 4;
+ i__1 = i4;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (d__[i__] <= 0.f) {
+ *info = i__;
+ goto L20;
+ }
+ i__2 = i__;
+ eir = e[i__2].r;
+ eii = r_imag(&e[i__]);
+ f = eir / d__[i__];
+ g = eii / d__[i__];
+ i__2 = i__;
+ q__1.r = f, q__1.i = g;
+ e[i__2].r = q__1.r, e[i__2].i = q__1.i;
+ d__[i__ + 1] = d__[i__ + 1] - f * eir - g * eii;
+/* L10: */
+ }
+
+ i__1 = *n - 4;
+ for (i__ = i4 + 1; i__ <= i__1; i__ += 4) {
+
+/* Drop out of the loop if d(i) <= 0: the matrix is not positive */
+/* definite. */
+
+ if (d__[i__] <= 0.f) {
+ *info = i__;
+ goto L20;
+ }
+
+/* Solve for e(i) and d(i+1). */
+
+ i__2 = i__;
+ eir = e[i__2].r;
+ eii = r_imag(&e[i__]);
+ f = eir / d__[i__];
+ g = eii / d__[i__];
+ i__2 = i__;
+ q__1.r = f, q__1.i = g;
+ e[i__2].r = q__1.r, e[i__2].i = q__1.i;
+ d__[i__ + 1] = d__[i__ + 1] - f * eir - g * eii;
+
+ if (d__[i__ + 1] <= 0.f) {
+ *info = i__ + 1;
+ goto L20;
+ }
+
+/* Solve for e(i+1) and d(i+2). */
+
+ i__2 = i__ + 1;
+ eir = e[i__2].r;
+ eii = r_imag(&e[i__ + 1]);
+ f = eir / d__[i__ + 1];
+ g = eii / d__[i__ + 1];
+ i__2 = i__ + 1;
+ q__1.r = f, q__1.i = g;
+ e[i__2].r = q__1.r, e[i__2].i = q__1.i;
+ d__[i__ + 2] = d__[i__ + 2] - f * eir - g * eii;
+
+ if (d__[i__ + 2] <= 0.f) {
+ *info = i__ + 2;
+ goto L20;
+ }
+
+/* Solve for e(i+2) and d(i+3). */
+
+ i__2 = i__ + 2;
+ eir = e[i__2].r;
+ eii = r_imag(&e[i__ + 2]);
+ f = eir / d__[i__ + 2];
+ g = eii / d__[i__ + 2];
+ i__2 = i__ + 2;
+ q__1.r = f, q__1.i = g;
+ e[i__2].r = q__1.r, e[i__2].i = q__1.i;
+ d__[i__ + 3] = d__[i__ + 3] - f * eir - g * eii;
+
+ if (d__[i__ + 3] <= 0.f) {
+ *info = i__ + 3;
+ goto L20;
+ }
+
+/* Solve for e(i+3) and d(i+4). */
+
+ i__2 = i__ + 3;
+ eir = e[i__2].r;
+ eii = r_imag(&e[i__ + 3]);
+ f = eir / d__[i__ + 3];
+ g = eii / d__[i__ + 3];
+ i__2 = i__ + 3;
+ q__1.r = f, q__1.i = g;
+ e[i__2].r = q__1.r, e[i__2].i = q__1.i;
+ d__[i__ + 4] = d__[i__ + 4] - f * eir - g * eii;
+/* L110: */
+ }
+
+/* Check d(n) for positive definiteness. */
+
+ if (d__[*n] <= 0.f) {
+ *info = *n;
+ }
+
+L20:
+ return 0;
+
+/* End of CPTTRF */
+
+} /* cpttrf_ */
diff --git a/SRC/cpttrs.c b/SRC/cpttrs.c
new file mode 100644
index 0000000..fe730b7
--- /dev/null
+++ b/SRC/cpttrs.c
@@ -0,0 +1,176 @@
+/* cpttrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cpttrs_(char *uplo, integer *n, integer *nrhs, real *d__,
+ complex *e, complex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer j, jb, nb, iuplo;
+ logical upper;
+ extern /* Subroutine */ int cptts2_(integer *, integer *, integer *, real
+ *, complex *, complex *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPTTRS solves a tridiagonal system of the form */
+/* A * X = B */
+/* using the factorization A = U'*D*U or A = L*D*L' computed by CPTTRF. */
+/* D is a diagonal matrix specified in the vector D, U (or L) is a unit */
+/* bidiagonal matrix whose superdiagonal (subdiagonal) is specified in */
+/* the vector E, and X and B are N by NRHS matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies the form of the factorization and whether the */
+/* vector E is the superdiagonal of the upper bidiagonal factor */
+/* U or the subdiagonal of the lower bidiagonal factor L. */
+/* = 'U': A = U'*D*U, E is the superdiagonal of U */
+/* = 'L': A = L*D*L', E is the subdiagonal of L */
+
+/* N (input) INTEGER */
+/* The order of the tridiagonal matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the diagonal matrix D from the */
+/* factorization A = U'*D*U or A = L*D*L'. */
+
+/* E (input) COMPLEX array, dimension (N-1) */
+/* If UPLO = 'U', the (n-1) superdiagonal elements of the unit */
+/* bidiagonal factor U from the factorization A = U'*D*U. */
+/* If UPLO = 'L', the (n-1) subdiagonal elements of the unit */
+/* bidiagonal factor L from the factorization A = L*D*L'. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors B for the system of */
+/* linear equations. */
+/* On exit, the solution vectors, X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = *(unsigned char *)uplo == 'U' || *(unsigned char *)uplo == 'u';
+ if (! upper && ! (*(unsigned char *)uplo == 'L' || *(unsigned char *)uplo
+ == 'l')) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CPTTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+/* Determine the number of right-hand sides to solve at a time. */
+
+ if (*nrhs == 1) {
+ nb = 1;
+ } else {
+/* Computing MAX */
+ i__1 = 1, i__2 = ilaenv_(&c__1, "CPTTRS", uplo, n, nrhs, &c_n1, &c_n1);
+ nb = max(i__1,i__2);
+ }
+
+/* Decode UPLO */
+
+ if (upper) {
+ iuplo = 1;
+ } else {
+ iuplo = 0;
+ }
+
+ if (nb >= *nrhs) {
+ cptts2_(&iuplo, n, nrhs, &d__[1], &e[1], &b[b_offset], ldb);
+ } else {
+ i__1 = *nrhs;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = *nrhs - j + 1;
+ jb = min(i__3,nb);
+ cptts2_(&iuplo, n, &jb, &d__[1], &e[1], &b[j * b_dim1 + 1], ldb);
+/* L10: */
+ }
+ }
+
+ return 0;
+
+/* End of CPTTRS */
+
+} /* cpttrs_ */
diff --git a/SRC/cptts2.c b/SRC/cptts2.c
new file mode 100644
index 0000000..a871d79
--- /dev/null
+++ b/SRC/cptts2.c
@@ -0,0 +1,315 @@
+/* cptts2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cptts2_(integer *iuplo, integer *n, integer *nrhs, real *
+ d__, complex *e, complex *b, integer *ldb)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j;
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPTTS2 solves a tridiagonal system of the form */
+/* A * X = B */
+/* using the factorization A = U'*D*U or A = L*D*L' computed by CPTTRF. */
+/* D is a diagonal matrix specified in the vector D, U (or L) is a unit */
+/* bidiagonal matrix whose superdiagonal (subdiagonal) is specified in */
+/* the vector E, and X and B are N by NRHS matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* IUPLO (input) INTEGER */
+/* Specifies the form of the factorization and whether the */
+/* vector E is the superdiagonal of the upper bidiagonal factor */
+/* U or the subdiagonal of the lower bidiagonal factor L. */
+/* = 1: A = U'*D*U, E is the superdiagonal of U */
+/* = 0: A = L*D*L', E is the subdiagonal of L */
+
+/* N (input) INTEGER */
+/* The order of the tridiagonal matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the diagonal matrix D from the */
+/* factorization A = U'*D*U or A = L*D*L'. */
+
+/* E (input) COMPLEX array, dimension (N-1) */
+/* If IUPLO = 1, the (n-1) superdiagonal elements of the unit */
+/* bidiagonal factor U from the factorization A = U'*D*U. */
+/* If IUPLO = 0, the (n-1) subdiagonal elements of the unit */
+/* bidiagonal factor L from the factorization A = L*D*L'. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors B for the system of */
+/* linear equations. */
+/* On exit, the solution vectors, X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*n <= 1) {
+ if (*n == 1) {
+ r__1 = 1.f / d__[1];
+ csscal_(nrhs, &r__1, &b[b_offset], ldb);
+ }
+ return 0;
+ }
+
+ if (*iuplo == 1) {
+
+/* Solve A * X = B using the factorization A = U'*D*U, */
+/* overwriting each right hand side vector with its solution. */
+
+ if (*nrhs <= 2) {
+ j = 1;
+L5:
+
+/* Solve U' * x = b. */
+
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ - 1 + j * b_dim1;
+ r_cnjg(&q__3, &e[i__ - 1]);
+ q__2.r = b[i__4].r * q__3.r - b[i__4].i * q__3.i, q__2.i = b[
+ i__4].r * q__3.i + b[i__4].i * q__3.r;
+ q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L10: */
+ }
+
+/* Solve D * U * x = b. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ q__1.r = b[i__3].r / d__[i__4], q__1.i = b[i__3].i / d__[i__4]
+ ;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L20: */
+ }
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ i__1 = i__ + j * b_dim1;
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + 1 + j * b_dim1;
+ i__4 = i__;
+ q__2.r = b[i__3].r * e[i__4].r - b[i__3].i * e[i__4].i,
+ q__2.i = b[i__3].r * e[i__4].i + b[i__3].i * e[i__4]
+ .r;
+ q__1.r = b[i__2].r - q__2.r, q__1.i = b[i__2].i - q__2.i;
+ b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+/* L30: */
+ }
+ if (j < *nrhs) {
+ ++j;
+ goto L5;
+ }
+ } else {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve U' * x = b. */
+
+ i__2 = *n;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ - 1 + j * b_dim1;
+ r_cnjg(&q__3, &e[i__ - 1]);
+ q__2.r = b[i__5].r * q__3.r - b[i__5].i * q__3.i, q__2.i =
+ b[i__5].r * q__3.i + b[i__5].i * q__3.r;
+ q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L40: */
+ }
+
+/* Solve D * U * x = b. */
+
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ i__4 = *n;
+ q__1.r = b[i__3].r / d__[i__4], q__1.i = b[i__3].i / d__[i__4]
+ ;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ q__2.r = b[i__3].r / d__[i__4], q__2.i = b[i__3].i / d__[
+ i__4];
+ i__5 = i__ + 1 + j * b_dim1;
+ i__6 = i__;
+ q__3.r = b[i__5].r * e[i__6].r - b[i__5].i * e[i__6].i,
+ q__3.i = b[i__5].r * e[i__6].i + b[i__5].i * e[
+ i__6].r;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+ } else {
+
+/* Solve A * X = B using the factorization A = L*D*L', */
+/* overwriting each right hand side vector with its solution. */
+
+ if (*nrhs <= 2) {
+ j = 1;
+L65:
+
+/* Solve L * x = b. */
+
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ - 1 + j * b_dim1;
+ i__5 = i__ - 1;
+ q__2.r = b[i__4].r * e[i__5].r - b[i__4].i * e[i__5].i,
+ q__2.i = b[i__4].r * e[i__5].i + b[i__4].i * e[i__5]
+ .r;
+ q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L70: */
+ }
+
+/* Solve D * L' * x = b. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ q__1.r = b[i__3].r / d__[i__4], q__1.i = b[i__3].i / d__[i__4]
+ ;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L80: */
+ }
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ i__1 = i__ + j * b_dim1;
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + 1 + j * b_dim1;
+ r_cnjg(&q__3, &e[i__]);
+ q__2.r = b[i__3].r * q__3.r - b[i__3].i * q__3.i, q__2.i = b[
+ i__3].r * q__3.i + b[i__3].i * q__3.r;
+ q__1.r = b[i__2].r - q__2.r, q__1.i = b[i__2].i - q__2.i;
+ b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+/* L90: */
+ }
+ if (j < *nrhs) {
+ ++j;
+ goto L65;
+ }
+ } else {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve L * x = b. */
+
+ i__2 = *n;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ - 1 + j * b_dim1;
+ i__6 = i__ - 1;
+ q__2.r = b[i__5].r * e[i__6].r - b[i__5].i * e[i__6].i,
+ q__2.i = b[i__5].r * e[i__6].i + b[i__5].i * e[
+ i__6].r;
+ q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L100: */
+ }
+
+/* Solve D * L' * x = b. */
+
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ i__4 = *n;
+ q__1.r = b[i__3].r / d__[i__4], q__1.i = b[i__3].i / d__[i__4]
+ ;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ q__2.r = b[i__3].r / d__[i__4], q__2.i = b[i__3].i / d__[
+ i__4];
+ i__5 = i__ + 1 + j * b_dim1;
+ r_cnjg(&q__4, &e[i__]);
+ q__3.r = b[i__5].r * q__4.r - b[i__5].i * q__4.i, q__3.i =
+ b[i__5].r * q__4.i + b[i__5].i * q__4.r;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L110: */
+ }
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CPTTS2 */
+
+} /* cptts2_ */
diff --git a/SRC/crot.c b/SRC/crot.c
new file mode 100644
index 0000000..4ebd3f2
--- /dev/null
+++ b/SRC/crot.c
@@ -0,0 +1,155 @@
+/* crot.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int crot_(integer *n, complex *cx, integer *incx, complex *
+ cy, integer *incy, real *c__, complex *s)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, ix, iy;
+ complex stemp;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CROT applies a plane rotation, where the cos (C) is real and the */
+/* sin (S) is complex, and the vectors CX and CY are complex. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of elements in the vectors CX and CY. */
+
+/* CX (input/output) COMPLEX array, dimension (N) */
+/* On input, the vector X. */
+/* On output, CX is overwritten with C*X + S*Y. */
+
+/* INCX (input) INTEGER */
+/* The increment between successive values of CY. INCX <> 0. */
+
+/* CY (input/output) COMPLEX array, dimension (N) */
+/* On input, the vector Y. */
+/* On output, CY is overwritten with -CONJG(S)*X + C*Y. */
+
+/* INCY (input) INTEGER */
+/* The increment between successive values of CY. INCX <> 0. */
+
+/* C (input) REAL */
+/* S (input) COMPLEX */
+/* C and S define a rotation */
+/* [ C S ] */
+/* [ -conjg(S) C ] */
+/* where C*C + S*CONJG(S) = 1.0. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --cy;
+ --cx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* Code for unequal increments or equal increments not equal to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ix;
+ q__2.r = *c__ * cx[i__2].r, q__2.i = *c__ * cx[i__2].i;
+ i__3 = iy;
+ q__3.r = s->r * cy[i__3].r - s->i * cy[i__3].i, q__3.i = s->r * cy[
+ i__3].i + s->i * cy[i__3].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ stemp.r = q__1.r, stemp.i = q__1.i;
+ i__2 = iy;
+ i__3 = iy;
+ q__2.r = *c__ * cy[i__3].r, q__2.i = *c__ * cy[i__3].i;
+ r_cnjg(&q__4, s);
+ i__4 = ix;
+ q__3.r = q__4.r * cx[i__4].r - q__4.i * cx[i__4].i, q__3.i = q__4.r *
+ cx[i__4].i + q__4.i * cx[i__4].r;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ cy[i__2].r = q__1.r, cy[i__2].i = q__1.i;
+ i__2 = ix;
+ cx[i__2].r = stemp.r, cx[i__2].i = stemp.i;
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ return 0;
+
+/* Code for both increments equal to 1 */
+
+L20:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ q__2.r = *c__ * cx[i__2].r, q__2.i = *c__ * cx[i__2].i;
+ i__3 = i__;
+ q__3.r = s->r * cy[i__3].r - s->i * cy[i__3].i, q__3.i = s->r * cy[
+ i__3].i + s->i * cy[i__3].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ stemp.r = q__1.r, stemp.i = q__1.i;
+ i__2 = i__;
+ i__3 = i__;
+ q__2.r = *c__ * cy[i__3].r, q__2.i = *c__ * cy[i__3].i;
+ r_cnjg(&q__4, s);
+ i__4 = i__;
+ q__3.r = q__4.r * cx[i__4].r - q__4.i * cx[i__4].i, q__3.i = q__4.r *
+ cx[i__4].i + q__4.i * cx[i__4].r;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ cy[i__2].r = q__1.r, cy[i__2].i = q__1.i;
+ i__2 = i__;
+ cx[i__2].r = stemp.r, cx[i__2].i = stemp.i;
+/* L30: */
+ }
+ return 0;
+} /* crot_ */
diff --git a/SRC/cspcon.c b/SRC/cspcon.c
new file mode 100644
index 0000000..fe65b69
--- /dev/null
+++ b/SRC/cspcon.c
@@ -0,0 +1,195 @@
+/* cspcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cspcon_(char *uplo, integer *n, complex *ap, integer *
+ ipiv, real *anorm, real *rcond, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, ip, kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *), xerbla_(char *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int csptrs_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSPCON estimates the reciprocal of the condition number (in the */
+/* 1-norm) of a complex symmetric packed matrix A using the */
+/* factorization A = U*D*U**T or A = L*D*L**T computed by CSPTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by CSPTRF, stored as a */
+/* packed triangular matrix. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CSPTRF. */
+
+/* ANORM (input) REAL */
+/* The 1-norm of the original matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --work;
+ --ipiv;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*anorm < 0.f) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CSPCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.f;
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ } else if (*anorm <= 0.f) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ ip = *n * (*n + 1) / 2;
+ for (i__ = *n; i__ >= 1; --i__) {
+ i__1 = ip;
+ if (ipiv[i__] > 0 && (ap[i__1].r == 0.f && ap[i__1].i == 0.f)) {
+ return 0;
+ }
+ ip -= i__;
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ ip = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ip;
+ if (ipiv[i__] > 0 && (ap[i__2].r == 0.f && ap[i__2].i == 0.f)) {
+ return 0;
+ }
+ ip = ip + *n - i__ + 1;
+/* L20: */
+ }
+ }
+
+/* Estimate the 1-norm of the inverse. */
+
+ kase = 0;
+L30:
+ clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+
+/* Multiply by inv(L*D*L') or inv(U*D*U'). */
+
+ csptrs_(uplo, n, &c__1, &ap[1], &ipiv[1], &work[1], n, info);
+ goto L30;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / ainvnm / *anorm;
+ }
+
+ return 0;
+
+/* End of CSPCON */
+
+} /* cspcon_ */
diff --git a/SRC/cspmv.c b/SRC/cspmv.c
new file mode 100644
index 0000000..fc9a3d1
--- /dev/null
+++ b/SRC/cspmv.c
@@ -0,0 +1,428 @@
+/* cspmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cspmv_(char *uplo, integer *n, complex *alpha, complex *
+ ap, complex *x, integer *incx, complex *beta, complex *y, integer *
+ incy)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
+ complex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSPMV performs the matrix-vector operation */
+
+/* y := alpha*A*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are n element vectors and */
+/* A is an n by n symmetric matrix, supplied in packed form. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the matrix A is supplied in the packed */
+/* array AP as follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* supplied in AP. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* supplied in AP. */
+
+/* Unchanged on exit. */
+
+/* N (input) INTEGER */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA (input) COMPLEX */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* AP (input) COMPLEX array, dimension at least */
+/* ( ( N*( N + 1 ) )/2 ). */
+/* Before entry, with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular part of the symmetric matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
+/* and a( 2, 2 ) respectively, and so on. */
+/* Before entry, with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular part of the symmetric matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
+/* and a( 3, 1 ) respectively, and so on. */
+/* Unchanged on exit. */
+
+/* X (input) COMPLEX array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the N- */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX (input) INTEGER */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA (input) COMPLEX */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y (input/output) COMPLEX array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. On exit, Y is overwritten by the updated */
+/* vector y. */
+
+/* INCY (input) INTEGER */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --y;
+ --x;
+ --ap;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 6;
+ } else if (*incy == 0) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("CSPMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f &&
+ beta->i == 0.f)) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of the array AP */
+/* are accessed sequentially with one pass through AP. */
+
+/* First form y := beta*y. */
+
+ if (beta->r != 1.f || beta->i != 0.f) {
+ if (*incy == 1) {
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ y[i__2].r = 0.f, y[i__2].i = 0.f;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ y[i__2].r = 0.f, y[i__2].i = 0.f;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ i__3 = iy;
+ q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (alpha->r == 0.f && alpha->i == 0.f) {
+ return 0;
+ }
+ kk = 1;
+ if (lsame_(uplo, "U")) {
+
+/* Form y when AP contains the upper triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ k = kk;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = k;
+ q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
+ q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
+ .r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ i__3 = k;
+ i__4 = i__;
+ q__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[i__4].i,
+ q__2.i = ap[i__3].r * x[i__4].i + ap[i__3].i * x[
+ i__4].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ ++k;
+/* L50: */
+ }
+ i__2 = j;
+ i__3 = j;
+ i__4 = kk + j - 1;
+ q__3.r = temp1.r * ap[i__4].r - temp1.i * ap[i__4].i, q__3.i =
+ temp1.r * ap[i__4].i + temp1.i * ap[i__4].r;
+ q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i;
+ q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ kk += j;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ ix = kx;
+ iy = ky;
+ i__2 = kk + j - 2;
+ for (k = kk; k <= i__2; ++k) {
+ i__3 = iy;
+ i__4 = iy;
+ i__5 = k;
+ q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
+ q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
+ .r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ i__3 = k;
+ i__4 = ix;
+ q__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[i__4].i,
+ q__2.i = ap[i__3].r * x[i__4].i + ap[i__3].i * x[
+ i__4].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ i__2 = jy;
+ i__3 = jy;
+ i__4 = kk + j - 1;
+ q__3.r = temp1.r * ap[i__4].r - temp1.i * ap[i__4].i, q__3.i =
+ temp1.r * ap[i__4].i + temp1.i * ap[i__4].r;
+ q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i;
+ q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ jx += *incx;
+ jy += *incy;
+ kk += j;
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y when AP contains the lower triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__2 = j;
+ i__3 = j;
+ i__4 = kk;
+ q__2.r = temp1.r * ap[i__4].r - temp1.i * ap[i__4].i, q__2.i =
+ temp1.r * ap[i__4].i + temp1.i * ap[i__4].r;
+ q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ k = kk + 1;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = k;
+ q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
+ q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
+ .r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ i__3 = k;
+ i__4 = i__;
+ q__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[i__4].i,
+ q__2.i = ap[i__3].r * x[i__4].i + ap[i__3].i * x[
+ i__4].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ ++k;
+/* L90: */
+ }
+ i__2 = j;
+ i__3 = j;
+ q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ kk += *n - j + 1;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__2 = jy;
+ i__3 = jy;
+ i__4 = kk;
+ q__2.r = temp1.r * ap[i__4].r - temp1.i * ap[i__4].i, q__2.i =
+ temp1.r * ap[i__4].i + temp1.i * ap[i__4].r;
+ q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ ix = jx;
+ iy = jy;
+ i__2 = kk + *n - j;
+ for (k = kk + 1; k <= i__2; ++k) {
+ ix += *incx;
+ iy += *incy;
+ i__3 = iy;
+ i__4 = iy;
+ i__5 = k;
+ q__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
+ q__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
+ .r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ i__3 = k;
+ i__4 = ix;
+ q__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[i__4].i,
+ q__2.i = ap[i__3].r * x[i__4].i + ap[i__3].i * x[
+ i__4].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L110: */
+ }
+ i__2 = jy;
+ i__3 = jy;
+ q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ jx += *incx;
+ jy += *incy;
+ kk += *n - j + 1;
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CSPMV */
+
+} /* cspmv_ */
diff --git a/SRC/cspr.c b/SRC/cspr.c
new file mode 100644
index 0000000..9b49f94
--- /dev/null
+++ b/SRC/cspr.c
@@ -0,0 +1,339 @@
+/* cspr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cspr_(char *uplo, integer *n, complex *alpha, complex *x,
+ integer *incx, complex *ap)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ complex q__1, q__2;
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, jx, kx, info;
+ complex temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSPR performs the symmetric rank 1 operation */
+
+/* A := alpha*x*conjg( x' ) + A, */
+
+/* where alpha is a complex scalar, x is an n element vector and A is an */
+/* n by n symmetric matrix, supplied in packed form. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the matrix A is supplied in the packed */
+/* array AP as follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* supplied in AP. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* supplied in AP. */
+
+/* Unchanged on exit. */
+
+/* N (input) INTEGER */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA (input) COMPLEX */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X (input) COMPLEX array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the N- */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX (input) INTEGER */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* AP (input/output) COMPLEX array, dimension at least */
+/* ( ( N*( N + 1 ) )/2 ). */
+/* Before entry, with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular part of the symmetric matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
+/* and a( 2, 2 ) respectively, and so on. On exit, the array */
+/* AP is overwritten by the upper triangular part of the */
+/* updated matrix. */
+/* Before entry, with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular part of the symmetric matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
+/* and a( 3, 1 ) respectively, and so on. On exit, the array */
+/* AP is overwritten by the lower triangular part of the */
+/* updated matrix. */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set, they are assumed to be zero, and on exit they */
+/* are set to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ }
+ if (info != 0) {
+ xerbla_("CSPR ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f) {
+ return 0;
+ }
+
+/* Set the start point in X if the increment is not unity. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of the array AP */
+/* are accessed sequentially with one pass through AP. */
+
+ kk = 1;
+ if (lsame_(uplo, "U")) {
+
+/* Form A when upper triangle is stored in AP. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ i__2 = j;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ k = kk;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = k;
+ i__4 = k;
+ i__5 = i__;
+ q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ q__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ q__1.r = ap[i__4].r + q__2.r, q__1.i = ap[i__4].i +
+ q__2.i;
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+ ++k;
+/* L10: */
+ }
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ i__4 = j;
+ q__2.r = x[i__4].r * temp.r - x[i__4].i * temp.i, q__2.i =
+ x[i__4].r * temp.i + x[i__4].i * temp.r;
+ q__1.r = ap[i__3].r + q__2.r, q__1.i = ap[i__3].i +
+ q__2.i;
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ } else {
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
+ }
+ kk += j;
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ i__2 = jx;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix = kx;
+ i__2 = kk + j - 2;
+ for (k = kk; k <= i__2; ++k) {
+ i__3 = k;
+ i__4 = k;
+ i__5 = ix;
+ q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ q__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ q__1.r = ap[i__4].r + q__2.r, q__1.i = ap[i__4].i +
+ q__2.i;
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+ ix += *incx;
+/* L30: */
+ }
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ i__4 = jx;
+ q__2.r = x[i__4].r * temp.r - x[i__4].i * temp.i, q__2.i =
+ x[i__4].r * temp.i + x[i__4].i * temp.r;
+ q__1.r = ap[i__3].r + q__2.r, q__1.i = ap[i__3].i +
+ q__2.i;
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ } else {
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
+ }
+ jx += *incx;
+ kk += j;
+/* L40: */
+ }
+ }
+ } else {
+
+/* Form A when lower triangle is stored in AP. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ i__2 = j;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__2 = kk;
+ i__3 = kk;
+ i__4 = j;
+ q__2.r = temp.r * x[i__4].r - temp.i * x[i__4].i, q__2.i =
+ temp.r * x[i__4].i + temp.i * x[i__4].r;
+ q__1.r = ap[i__3].r + q__2.r, q__1.i = ap[i__3].i +
+ q__2.i;
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ k = kk + 1;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = k;
+ i__4 = k;
+ i__5 = i__;
+ q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ q__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ q__1.r = ap[i__4].r + q__2.r, q__1.i = ap[i__4].i +
+ q__2.i;
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+ ++k;
+/* L50: */
+ }
+ } else {
+ i__2 = kk;
+ i__3 = kk;
+ ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
+ }
+ kk = kk + *n - j + 1;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ i__2 = jx;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__2 = kk;
+ i__3 = kk;
+ i__4 = jx;
+ q__2.r = temp.r * x[i__4].r - temp.i * x[i__4].i, q__2.i =
+ temp.r * x[i__4].i + temp.i * x[i__4].r;
+ q__1.r = ap[i__3].r + q__2.r, q__1.i = ap[i__3].i +
+ q__2.i;
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ ix = jx;
+ i__2 = kk + *n - j;
+ for (k = kk + 1; k <= i__2; ++k) {
+ ix += *incx;
+ i__3 = k;
+ i__4 = k;
+ i__5 = ix;
+ q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ q__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ q__1.r = ap[i__4].r + q__2.r, q__1.i = ap[i__4].i +
+ q__2.i;
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+/* L70: */
+ }
+ } else {
+ i__2 = kk;
+ i__3 = kk;
+ ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
+ }
+ jx += *incx;
+ kk = kk + *n - j + 1;
+/* L80: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CSPR */
+
+} /* cspr_ */
diff --git a/SRC/csprfs.c b/SRC/csprfs.c
new file mode 100644
index 0000000..2f385f6
--- /dev/null
+++ b/SRC/csprfs.c
@@ -0,0 +1,464 @@
+/* csprfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int csprfs_(char *uplo, integer *n, integer *nrhs, complex *
+ ap, complex *afp, integer *ipiv, complex *b, integer *ldb, complex *x,
+ integer *ldx, real *ferr, real *berr, complex *work, real *rwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ real s;
+ integer ik, kk;
+ real xk;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ integer count;
+ extern /* Subroutine */ int cspmv_(char *, integer *, complex *, complex *
+, complex *, integer *, complex *, complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real lstres;
+ extern /* Subroutine */ int csptrs_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSPRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric indefinite */
+/* and packed, and provides error bounds and backward error estimates */
+/* for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the symmetric matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* AFP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The factored form of the matrix A. AFP contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor U or L from the factorization A = U*D*U**T or */
+/* A = L*D*L**T as computed by CSPTRF, stored as a packed */
+/* triangular matrix. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CSPTRF. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by CSPTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --afp;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*ldx < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CSPRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.f;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cspmv_(uplo, n, &q__1, &ap[1], &x[j * x_dim1 + 1], &c__1, &c_b1, &
+ work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[
+ i__ + j * b_dim1]), dabs(r__2));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ kk = 1;
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j
+ * x_dim1]), dabs(r__2));
+ ik = kk;
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ik;
+ rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&ap[ik]), dabs(r__2))) * xk;
+ i__4 = ik;
+ i__5 = i__ + j * x_dim1;
+ s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
+ ap[ik]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs(
+ r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]),
+ dabs(r__4)));
+ ++ik;
+/* L40: */
+ }
+ i__3 = kk + k - 1;
+ rwork[k] = rwork[k] + ((r__1 = ap[i__3].r, dabs(r__1)) + (
+ r__2 = r_imag(&ap[kk + k - 1]), dabs(r__2))) * xk + s;
+ kk += k;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j
+ * x_dim1]), dabs(r__2));
+ i__3 = kk;
+ rwork[k] += ((r__1 = ap[i__3].r, dabs(r__1)) + (r__2 = r_imag(
+ &ap[kk]), dabs(r__2))) * xk;
+ ik = kk + 1;
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ i__4 = ik;
+ rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&ap[ik]), dabs(r__2))) * xk;
+ i__4 = ik;
+ i__5 = i__ + j * x_dim1;
+ s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
+ ap[ik]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs(
+ r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]),
+ dabs(r__4)));
+ ++ik;
+/* L60: */
+ }
+ rwork[k] += s;
+ kk += *n - k + 1;
+/* L70: */
+ }
+ }
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__3 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
+ s = dmax(r__3,r__4);
+ } else {
+/* Computing MAX */
+ i__3 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = dmax(r__3,r__4);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ csptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info);
+ caxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use CLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__3 = i__;
+ rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__];
+ } else {
+ i__3 = i__;
+ rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__] + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ csptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L120: */
+ }
+ csptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * x_dim1;
+ r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + j * x_dim1]), dabs(r__2));
+ lstres = dmax(r__3,r__4);
+/* L130: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of CSPRFS */
+
+} /* csprfs_ */
diff --git a/SRC/cspsv.c b/SRC/cspsv.c
new file mode 100644
index 0000000..fd24509
--- /dev/null
+++ b/SRC/cspsv.c
@@ -0,0 +1,176 @@
+/* cspsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cspsv_(char *uplo, integer *n, integer *nrhs, complex *
+ ap, integer *ipiv, complex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), csptrf_(
+ char *, integer *, complex *, integer *, integer *),
+ csptrs_(char *, integer *, integer *, complex *, integer *,
+ complex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSPSV computes the solution to a complex system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N symmetric matrix stored in packed format and X */
+/* and B are N-by-NRHS matrices. */
+
+/* The diagonal pivoting method is used to factor A as */
+/* A = U * D * U**T, if UPLO = 'U', or */
+/* A = L * D * L**T, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, D is symmetric and block diagonal with 1-by-1 */
+/* and 2-by-2 diagonal blocks. The factored form of A is then used to */
+/* solve the system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+
+/* On exit, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as */
+/* a packed triangular matrix in the same storage format as A. */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D, as */
+/* determined by CSPTRF. If IPIV(k) > 0, then rows and columns */
+/* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 */
+/* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, */
+/* then rows and columns k-1 and -IPIV(k) were interchanged and */
+/* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and */
+/* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and */
+/* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 */
+/* diagonal block. */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */
+/* has been completed, but the block diagonal matrix D is */
+/* exactly singular, so the solution could not be */
+/* computed. */
+
+/* Further Details */
+/* =============== */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the symmetric matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = aji) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CSPSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ csptrf_(uplo, n, &ap[1], &ipiv[1], info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ csptrs_(uplo, n, nrhs, &ap[1], &ipiv[1], &b[b_offset], ldb, info);
+
+ }
+ return 0;
+
+/* End of CSPSV */
+
+} /* cspsv_ */
diff --git a/SRC/cspsvx.c b/SRC/cspsvx.c
new file mode 100644
index 0000000..5a2d13a
--- /dev/null
+++ b/SRC/cspsvx.c
@@ -0,0 +1,323 @@
+/* cspsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cspsvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, complex *ap, complex *afp, integer *ipiv, complex *b, integer *
+ ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr,
+ complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ extern doublereal slamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), xerbla_(char *,
+ integer *);
+ extern doublereal clansp_(char *, char *, integer *, complex *, real *);
+ extern /* Subroutine */ int cspcon_(char *, integer *, complex *, integer
+ *, real *, real *, complex *, integer *), csprfs_(char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *, complex *, real *
+, integer *), csptrf_(char *, integer *, complex *,
+ integer *, integer *), csptrs_(char *, integer *, integer
+ *, complex *, integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSPSVX uses the diagonal pivoting factorization A = U*D*U**T or */
+/* A = L*D*L**T to compute the solution to a complex system of linear */
+/* equations A * X = B, where A is an N-by-N symmetric matrix stored */
+/* in packed format and X and B are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as */
+/* A = U * D * U**T, if UPLO = 'U', or */
+/* A = L * D * L**T, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* 2. If some D(i,i)=0, so that D is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 3. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 4. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of A has been */
+/* supplied on entry. */
+/* = 'F': On entry, AFP and IPIV contain the factored form */
+/* of A. AP, AFP and IPIV will not be modified. */
+/* = 'N': The matrix A will be copied to AFP and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the symmetric matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+
+/* AFP (input or output) COMPLEX array, dimension (N*(N+1)/2) */
+/* If FACT = 'F', then AFP is an input argument and on entry */
+/* contains the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as */
+/* a packed triangular matrix in the same storage format as A. */
+
+/* If FACT = 'N', then AFP is an output argument and on exit */
+/* contains the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as */
+/* a packed triangular matrix in the same storage format as A. */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by CSPTRF. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by CSPTRF. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A. If RCOND is less than the machine precision (in */
+/* particular, if RCOND = 0), the matrix is singular to working */
+/* precision. This condition is indicated by a return code of */
+/* INFO > 0. */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: D(i,i) is exactly zero. The factorization */
+/* has been completed but the factor D is exactly */
+/* singular, so the solution and error bounds could */
+/* not be computed. RCOND = 0 is returned. */
+/* = N+1: D is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* Further Details */
+/* =============== */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the symmetric matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = aji) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --afp;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ if (! nofact && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CSPSVX", &i__1);
+ return 0;
+ }
+
+ if (nofact) {
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ i__1 = *n * (*n + 1) / 2;
+ ccopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1);
+ csptrf_(uplo, n, &afp[1], &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.f;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = clansp_("I", uplo, n, &ap[1], &rwork[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ cspcon_(uplo, n, &afp[1], &ipiv[1], &anorm, rcond, &work[1], info);
+
+/* Compute the solution vectors X. */
+
+ clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ csptrs_(uplo, n, nrhs, &afp[1], &ipiv[1], &x[x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solutions and */
+/* compute error bounds and backward error estimates for them. */
+
+ csprfs_(uplo, n, nrhs, &ap[1], &afp[1], &ipiv[1], &b[b_offset], ldb, &x[
+ x_offset], ldx, &ferr[1], &berr[1], &work[1], &rwork[1], info);
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < slamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of CSPSVX */
+
+} /* cspsvx_ */
diff --git a/SRC/csptrf.c b/SRC/csptrf.c
new file mode 100644
index 0000000..753039b
--- /dev/null
+++ b/SRC/csptrf.c
@@ -0,0 +1,763 @@
+/* csptrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int csptrf_(char *uplo, integer *n, complex *ap, integer *
+ ipiv, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_imag(complex *);
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ complex t, r1, d11, d12, d21, d22;
+ integer kc, kk, kp;
+ complex wk;
+ integer kx, knc, kpc, npp;
+ complex wkm1, wkp1;
+ integer imax, jmax;
+ extern /* Subroutine */ int cspr_(char *, integer *, complex *, complex *,
+ integer *, complex *);
+ real alpha;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer kstep;
+ logical upper;
+ real absakk;
+ extern integer icamax_(integer *, complex *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real colmax, rowmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSPTRF computes the factorization of a complex symmetric matrix A */
+/* stored in packed format using the Bunch-Kaufman diagonal pivoting */
+/* method: */
+
+/* A = U*D*U**T or A = L*D*L**T */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L, stored as a packed triangular */
+/* matrix overwriting A (see below for further details). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. 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. */
+
+/* Further Details */
+/* =============== */
+
+/* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services */
+/* Company */
+
+/* If UPLO = 'U', then A = U*D*U', where */
+/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
+/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
+/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I v 0 ) k-s */
+/* U(k) = ( 0 I 0 ) s */
+/* ( 0 0 I ) n-k */
+/* k-s s n-k */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
+/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
+/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
+
+/* If UPLO = 'L', then A = L*D*L', where */
+/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
+/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
+/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I 0 0 ) k-1 */
+/* L(k) = ( 0 I 0 ) s */
+/* ( 0 v I ) n-k-s+1 */
+/* k-1 s n-k-s+1 */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
+/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
+/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ipiv;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CSPTRF", &i__1);
+ return 0;
+ }
+
+/* Initialize ALPHA for use in choosing pivot block size. */
+
+ alpha = (sqrt(17.f) + 1.f) / 8.f;
+
+ if (upper) {
+
+/* Factorize A as U*D*U' using the upper triangle of A */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2 */
+
+ k = *n;
+ kc = (*n - 1) * *n / 2 + 1;
+L10:
+ knc = kc;
+
+/* If K < 1, exit from loop */
+
+ if (k < 1) {
+ goto L110;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = kc + k - 1;
+ absakk = (r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kc + k
+ - 1]), dabs(r__2));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ imax = icamax_(&i__1, &ap[kc], &c__1);
+ i__1 = kc + imax - 1;
+ colmax = (r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kc
+ + imax - 1]), dabs(r__2));
+ } else {
+ colmax = 0.f;
+ }
+
+ if (dmax(absakk,colmax) == 0.f) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ rowmax = 0.f;
+ jmax = imax;
+ kx = imax * (imax + 1) / 2 + imax;
+ i__1 = k;
+ for (j = imax + 1; j <= i__1; ++j) {
+ i__2 = kx;
+ if ((r__1 = ap[i__2].r, dabs(r__1)) + (r__2 = r_imag(&ap[
+ kx]), dabs(r__2)) > rowmax) {
+ i__2 = kx;
+ rowmax = (r__1 = ap[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&ap[kx]), dabs(r__2));
+ jmax = j;
+ }
+ kx += j;
+/* L20: */
+ }
+ kpc = (imax - 1) * imax / 2 + 1;
+ if (imax > 1) {
+ i__1 = imax - 1;
+ jmax = icamax_(&i__1, &ap[kpc], &c__1);
+/* Computing MAX */
+ i__1 = kpc + jmax - 1;
+ r__3 = rowmax, r__4 = (r__1 = ap[i__1].r, dabs(r__1)) + (
+ r__2 = r_imag(&ap[kpc + jmax - 1]), dabs(r__2));
+ rowmax = dmax(r__3,r__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = kpc + imax - 1;
+ if ((r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[
+ kpc + imax - 1]), dabs(r__2)) >= alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k - kstep + 1;
+ if (kstep == 2) {
+ knc = knc - k + 1;
+ }
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the leading */
+/* submatrix A(1:k,1:k) */
+
+ i__1 = kp - 1;
+ cswap_(&i__1, &ap[knc], &c__1, &ap[kpc], &c__1);
+ kx = kpc + kp - 1;
+ i__1 = kk - 1;
+ for (j = kp + 1; j <= i__1; ++j) {
+ kx = kx + j - 1;
+ i__2 = knc + j - 1;
+ t.r = ap[i__2].r, t.i = ap[i__2].i;
+ i__2 = knc + j - 1;
+ i__3 = kx;
+ ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
+ i__2 = kx;
+ ap[i__2].r = t.r, ap[i__2].i = t.i;
+/* L30: */
+ }
+ i__1 = knc + kk - 1;
+ t.r = ap[i__1].r, t.i = ap[i__1].i;
+ i__1 = knc + kk - 1;
+ i__2 = kpc + kp - 1;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kpc + kp - 1;
+ ap[i__1].r = t.r, ap[i__1].i = t.i;
+ if (kstep == 2) {
+ i__1 = kc + k - 2;
+ t.r = ap[i__1].r, t.i = ap[i__1].i;
+ i__1 = kc + k - 2;
+ i__2 = kc + kp - 1;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kc + kp - 1;
+ ap[i__1].r = t.r, ap[i__1].i = t.i;
+ }
+ }
+
+/* Update the leading submatrix */
+
+ if (kstep == 1) {
+
+/* 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 */
+
+/* Perform a rank-1 update of A(1:k-1,1:k-1) as */
+
+/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */
+
+ c_div(&q__1, &c_b1, &ap[kc + k - 1]);
+ r1.r = q__1.r, r1.i = q__1.i;
+ i__1 = k - 1;
+ q__1.r = -r1.r, q__1.i = -r1.i;
+ cspr_(uplo, &i__1, &q__1, &ap[kc], &c__1, &ap[1]);
+
+/* Store U(k) in column k */
+
+ i__1 = k - 1;
+ cscal_(&i__1, &r1, &ap[kc], &c__1);
+ } 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) )' */
+/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */
+
+ if (k > 2) {
+
+ i__1 = k - 1 + (k - 1) * k / 2;
+ d12.r = ap[i__1].r, d12.i = ap[i__1].i;
+ c_div(&q__1, &ap[k - 1 + (k - 2) * (k - 1) / 2], &d12);
+ d22.r = q__1.r, d22.i = q__1.i;
+ c_div(&q__1, &ap[k + (k - 1) * k / 2], &d12);
+ d11.r = q__1.r, d11.i = q__1.i;
+ q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r *
+ d22.i + d11.i * d22.r;
+ q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f;
+ c_div(&q__1, &c_b1, &q__2);
+ t.r = q__1.r, t.i = q__1.i;
+ c_div(&q__1, &t, &d12);
+ d12.r = q__1.r, d12.i = q__1.i;
+
+ for (j = k - 2; j >= 1; --j) {
+ i__1 = j + (k - 2) * (k - 1) / 2;
+ q__3.r = d11.r * ap[i__1].r - d11.i * ap[i__1].i,
+ q__3.i = d11.r * ap[i__1].i + d11.i * ap[i__1]
+ .r;
+ i__2 = j + (k - 1) * k / 2;
+ q__2.r = q__3.r - ap[i__2].r, q__2.i = q__3.i - ap[
+ i__2].i;
+ q__1.r = d12.r * q__2.r - d12.i * q__2.i, q__1.i =
+ d12.r * q__2.i + d12.i * q__2.r;
+ wkm1.r = q__1.r, wkm1.i = q__1.i;
+ i__1 = j + (k - 1) * k / 2;
+ q__3.r = d22.r * ap[i__1].r - d22.i * ap[i__1].i,
+ q__3.i = d22.r * ap[i__1].i + d22.i * ap[i__1]
+ .r;
+ i__2 = j + (k - 2) * (k - 1) / 2;
+ q__2.r = q__3.r - ap[i__2].r, q__2.i = q__3.i - ap[
+ i__2].i;
+ q__1.r = d12.r * q__2.r - d12.i * q__2.i, q__1.i =
+ d12.r * q__2.i + d12.i * q__2.r;
+ wk.r = q__1.r, wk.i = q__1.i;
+ for (i__ = j; i__ >= 1; --i__) {
+ i__1 = i__ + (j - 1) * j / 2;
+ i__2 = i__ + (j - 1) * j / 2;
+ i__3 = i__ + (k - 1) * k / 2;
+ q__3.r = ap[i__3].r * wk.r - ap[i__3].i * wk.i,
+ q__3.i = ap[i__3].r * wk.i + ap[i__3].i *
+ wk.r;
+ q__2.r = ap[i__2].r - q__3.r, q__2.i = ap[i__2].i
+ - q__3.i;
+ i__4 = i__ + (k - 2) * (k - 1) / 2;
+ q__4.r = ap[i__4].r * wkm1.r - ap[i__4].i *
+ wkm1.i, q__4.i = ap[i__4].r * wkm1.i + ap[
+ i__4].i * wkm1.r;
+ q__1.r = q__2.r - q__4.r, q__1.i = q__2.i -
+ q__4.i;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+/* L40: */
+ }
+ i__1 = j + (k - 1) * k / 2;
+ ap[i__1].r = wk.r, ap[i__1].i = wk.i;
+ i__1 = j + (k - 2) * (k - 1) / 2;
+ ap[i__1].r = wkm1.r, ap[i__1].i = wkm1.i;
+/* L50: */
+ }
+
+ }
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k - 1] = -kp;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kstep;
+ kc = knc - k;
+ goto L10;
+
+ } else {
+
+/* Factorize A as L*D*L' using the lower triangle of A */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2 */
+
+ k = 1;
+ kc = 1;
+ npp = *n * (*n + 1) / 2;
+L60:
+ knc = kc;
+
+/* If K > N, exit from loop */
+
+ if (k > *n) {
+ goto L110;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = kc;
+ absakk = (r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kc]),
+ dabs(r__2));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ imax = k + icamax_(&i__1, &ap[kc + 1], &c__1);
+ i__1 = kc + imax - k;
+ colmax = (r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kc
+ + imax - k]), dabs(r__2));
+ } else {
+ colmax = 0.f;
+ }
+
+ if (dmax(absakk,colmax) == 0.f) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ rowmax = 0.f;
+ kx = kc + imax - k;
+ i__1 = imax - 1;
+ for (j = k; j <= i__1; ++j) {
+ i__2 = kx;
+ if ((r__1 = ap[i__2].r, dabs(r__1)) + (r__2 = r_imag(&ap[
+ kx]), dabs(r__2)) > rowmax) {
+ i__2 = kx;
+ rowmax = (r__1 = ap[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&ap[kx]), dabs(r__2));
+ jmax = j;
+ }
+ kx = kx + *n - j;
+/* L70: */
+ }
+ kpc = npp - (*n - imax + 1) * (*n - imax + 2) / 2 + 1;
+ if (imax < *n) {
+ i__1 = *n - imax;
+ jmax = imax + icamax_(&i__1, &ap[kpc + 1], &c__1);
+/* Computing MAX */
+ i__1 = kpc + jmax - imax;
+ r__3 = rowmax, r__4 = (r__1 = ap[i__1].r, dabs(r__1)) + (
+ r__2 = r_imag(&ap[kpc + jmax - imax]), dabs(r__2))
+ ;
+ rowmax = dmax(r__3,r__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = kpc;
+ if ((r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[
+ kpc]), dabs(r__2)) >= alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k + kstep - 1;
+ if (kstep == 2) {
+ knc = knc + *n - k + 1;
+ }
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the trailing */
+/* submatrix A(k:n,k:n) */
+
+ if (kp < *n) {
+ i__1 = *n - kp;
+ cswap_(&i__1, &ap[knc + kp - kk + 1], &c__1, &ap[kpc + 1],
+ &c__1);
+ }
+ kx = knc + kp - kk;
+ i__1 = kp - 1;
+ for (j = kk + 1; j <= i__1; ++j) {
+ kx = kx + *n - j + 1;
+ i__2 = knc + j - kk;
+ t.r = ap[i__2].r, t.i = ap[i__2].i;
+ i__2 = knc + j - kk;
+ i__3 = kx;
+ ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
+ i__2 = kx;
+ ap[i__2].r = t.r, ap[i__2].i = t.i;
+/* L80: */
+ }
+ i__1 = knc;
+ t.r = ap[i__1].r, t.i = ap[i__1].i;
+ i__1 = knc;
+ i__2 = kpc;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kpc;
+ ap[i__1].r = t.r, ap[i__1].i = t.i;
+ if (kstep == 2) {
+ i__1 = kc + 1;
+ t.r = ap[i__1].r, t.i = ap[i__1].i;
+ i__1 = kc + 1;
+ i__2 = kc + kp - k;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kc + kp - k;
+ ap[i__1].r = t.r, ap[i__1].i = t.i;
+ }
+ }
+
+/* Update the trailing submatrix */
+
+ if (kstep == 1) {
+
+/* 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 < *n) {
+
+/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
+
+/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */
+
+ c_div(&q__1, &c_b1, &ap[kc]);
+ r1.r = q__1.r, r1.i = q__1.i;
+ i__1 = *n - k;
+ q__1.r = -r1.r, q__1.i = -r1.i;
+ cspr_(uplo, &i__1, &q__1, &ap[kc + 1], &c__1, &ap[kc + *n
+ - k + 1]);
+
+/* Store L(k) in column K */
+
+ i__1 = *n - k;
+ cscal_(&i__1, &r1, &ap[kc + 1], &c__1);
+ }
+ } 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 */
+
+ if (k < *n - 1) {
+
+/* 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) )' */
+/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' */
+
+/* where L(k) and L(k+1) are the k-th and (k+1)-th */
+/* columns of L */
+
+ i__1 = k + 1 + (k - 1) * ((*n << 1) - k) / 2;
+ d21.r = ap[i__1].r, d21.i = ap[i__1].i;
+ c_div(&q__1, &ap[k + 1 + k * ((*n << 1) - k - 1) / 2], &
+ d21);
+ d11.r = q__1.r, d11.i = q__1.i;
+ c_div(&q__1, &ap[k + (k - 1) * ((*n << 1) - k) / 2], &d21)
+ ;
+ d22.r = q__1.r, d22.i = q__1.i;
+ q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r *
+ d22.i + d11.i * d22.r;
+ q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f;
+ c_div(&q__1, &c_b1, &q__2);
+ t.r = q__1.r, t.i = q__1.i;
+ c_div(&q__1, &t, &d21);
+ d21.r = q__1.r, d21.i = q__1.i;
+
+ i__1 = *n;
+ for (j = k + 2; j <= i__1; ++j) {
+ i__2 = j + (k - 1) * ((*n << 1) - k) / 2;
+ q__3.r = d11.r * ap[i__2].r - d11.i * ap[i__2].i,
+ q__3.i = d11.r * ap[i__2].i + d11.i * ap[i__2]
+ .r;
+ i__3 = j + k * ((*n << 1) - k - 1) / 2;
+ q__2.r = q__3.r - ap[i__3].r, q__2.i = q__3.i - ap[
+ i__3].i;
+ q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i =
+ d21.r * q__2.i + d21.i * q__2.r;
+ wk.r = q__1.r, wk.i = q__1.i;
+ i__2 = j + k * ((*n << 1) - k - 1) / 2;
+ q__3.r = d22.r * ap[i__2].r - d22.i * ap[i__2].i,
+ q__3.i = d22.r * ap[i__2].i + d22.i * ap[i__2]
+ .r;
+ i__3 = j + (k - 1) * ((*n << 1) - k) / 2;
+ q__2.r = q__3.r - ap[i__3].r, q__2.i = q__3.i - ap[
+ i__3].i;
+ q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i =
+ d21.r * q__2.i + d21.i * q__2.r;
+ wkp1.r = q__1.r, wkp1.i = q__1.i;
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * ((*n << 1) - j) / 2;
+ i__4 = i__ + (j - 1) * ((*n << 1) - j) / 2;
+ i__5 = i__ + (k - 1) * ((*n << 1) - k) / 2;
+ q__3.r = ap[i__5].r * wk.r - ap[i__5].i * wk.i,
+ q__3.i = ap[i__5].r * wk.i + ap[i__5].i *
+ wk.r;
+ q__2.r = ap[i__4].r - q__3.r, q__2.i = ap[i__4].i
+ - q__3.i;
+ i__6 = i__ + k * ((*n << 1) - k - 1) / 2;
+ q__4.r = ap[i__6].r * wkp1.r - ap[i__6].i *
+ wkp1.i, q__4.i = ap[i__6].r * wkp1.i + ap[
+ i__6].i * wkp1.r;
+ q__1.r = q__2.r - q__4.r, q__1.i = q__2.i -
+ q__4.i;
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+/* L90: */
+ }
+ i__2 = j + (k - 1) * ((*n << 1) - k) / 2;
+ ap[i__2].r = wk.r, ap[i__2].i = wk.i;
+ i__2 = j + k * ((*n << 1) - k - 1) / 2;
+ ap[i__2].r = wkp1.r, ap[i__2].i = wkp1.i;
+/* L100: */
+ }
+ }
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k + 1] = -kp;
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kstep;
+ kc = knc + *n - k + 2;
+ goto L60;
+
+ }
+
+L110:
+ return 0;
+
+/* End of CSPTRF */
+
+} /* csptrf_ */
diff --git a/SRC/csptri.c b/SRC/csptri.c
new file mode 100644
index 0000000..67dc455
--- /dev/null
+++ b/SRC/csptri.c
@@ -0,0 +1,508 @@
+/* csptri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static complex c_b2 = {0.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int csptri_(char *uplo, integer *n, complex *ap, integer *
+ ipiv, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ complex d__;
+ integer j, k;
+ complex t, ak;
+ integer kc, kp, kx, kpc, npp;
+ complex akp1, temp, akkp1;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer kstep;
+ extern /* Subroutine */ int cspmv_(char *, integer *, complex *, complex *
+, complex *, integer *, complex *, complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer kcnext;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSPTRI computes the inverse of a complex symmetric indefinite matrix */
+/* A in packed storage using the factorization A = U*D*U**T or */
+/* A = L*D*L**T computed by CSPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L as computed by CSPTRF, */
+/* stored as a packed triangular matrix. */
+
+/* On exit, if INFO = 0, the (symmetric) inverse of the original */
+/* matrix, stored as a packed triangular matrix. The j-th column */
+/* of inv(A) is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CSPTRF. */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* INFO (output) 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. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --work;
+ --ipiv;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CSPTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ kp = *n * (*n + 1) / 2;
+ for (*info = *n; *info >= 1; --(*info)) {
+ i__1 = kp;
+ if (ipiv[*info] > 0 && (ap[i__1].r == 0.f && ap[i__1].i == 0.f)) {
+ return 0;
+ }
+ kp -= *info;
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ kp = 1;
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ i__2 = kp;
+ if (ipiv[*info] > 0 && (ap[i__2].r == 0.f && ap[i__2].i == 0.f)) {
+ return 0;
+ }
+ kp = kp + *n - *info + 1;
+/* L20: */
+ }
+ }
+ *info = 0;
+
+ if (upper) {
+
+/* Compute inv(A) from the factorization A = U*D*U'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+ kc = 1;
+L30:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L50;
+ }
+
+ kcnext = kc + k;
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = kc + k - 1;
+ c_div(&q__1, &c_b1, &ap[kc + k - 1]);
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+
+/* Compute column K of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ ccopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cspmv_(uplo, &i__1, &q__1, &ap[1], &work[1], &c__1, &c_b2, &
+ ap[kc], &c__1);
+ i__1 = kc + k - 1;
+ i__2 = kc + k - 1;
+ i__3 = k - 1;
+ cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kc], &c__1);
+ q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = kcnext + k - 1;
+ t.r = ap[i__1].r, t.i = ap[i__1].i;
+ c_div(&q__1, &ap[kc + k - 1], &t);
+ ak.r = q__1.r, ak.i = q__1.i;
+ c_div(&q__1, &ap[kcnext + k], &t);
+ akp1.r = q__1.r, akp1.i = q__1.i;
+ c_div(&q__1, &ap[kcnext + k - 1], &t);
+ akkp1.r = q__1.r, akkp1.i = q__1.i;
+ q__3.r = ak.r * akp1.r - ak.i * akp1.i, q__3.i = ak.r * akp1.i +
+ ak.i * akp1.r;
+ q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f;
+ q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i
+ * q__2.r;
+ d__.r = q__1.r, d__.i = q__1.i;
+ i__1 = kc + k - 1;
+ c_div(&q__1, &akp1, &d__);
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ i__1 = kcnext + k;
+ c_div(&q__1, &ak, &d__);
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ i__1 = kcnext + k - 1;
+ q__2.r = -akkp1.r, q__2.i = -akkp1.i;
+ c_div(&q__1, &q__2, &d__);
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+
+/* Compute columns K and K+1 of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ ccopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cspmv_(uplo, &i__1, &q__1, &ap[1], &work[1], &c__1, &c_b2, &
+ ap[kc], &c__1);
+ i__1 = kc + k - 1;
+ i__2 = kc + k - 1;
+ i__3 = k - 1;
+ cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kc], &c__1);
+ q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ i__1 = kcnext + k - 1;
+ i__2 = kcnext + k - 1;
+ i__3 = k - 1;
+ cdotu_(&q__2, &i__3, &ap[kc], &c__1, &ap[kcnext], &c__1);
+ q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ i__1 = k - 1;
+ ccopy_(&i__1, &ap[kcnext], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cspmv_(uplo, &i__1, &q__1, &ap[1], &work[1], &c__1, &c_b2, &
+ ap[kcnext], &c__1);
+ i__1 = kcnext + k;
+ i__2 = kcnext + k;
+ i__3 = k - 1;
+ cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kcnext], &c__1);
+ q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ }
+ kstep = 2;
+ kcnext = kcnext + k + 1;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the leading */
+/* submatrix A(1:k+1,1:k+1) */
+
+ kpc = (kp - 1) * kp / 2 + 1;
+ i__1 = kp - 1;
+ cswap_(&i__1, &ap[kc], &c__1, &ap[kpc], &c__1);
+ kx = kpc + kp - 1;
+ i__1 = k - 1;
+ for (j = kp + 1; j <= i__1; ++j) {
+ kx = kx + j - 1;
+ i__2 = kc + j - 1;
+ temp.r = ap[i__2].r, temp.i = ap[i__2].i;
+ i__2 = kc + j - 1;
+ i__3 = kx;
+ ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
+ i__2 = kx;
+ ap[i__2].r = temp.r, ap[i__2].i = temp.i;
+/* L40: */
+ }
+ i__1 = kc + k - 1;
+ temp.r = ap[i__1].r, temp.i = ap[i__1].i;
+ i__1 = kc + k - 1;
+ i__2 = kpc + kp - 1;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kpc + kp - 1;
+ ap[i__1].r = temp.r, ap[i__1].i = temp.i;
+ if (kstep == 2) {
+ i__1 = kc + k + k - 1;
+ temp.r = ap[i__1].r, temp.i = ap[i__1].i;
+ i__1 = kc + k + k - 1;
+ i__2 = kc + k + kp - 1;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kc + k + kp - 1;
+ ap[i__1].r = temp.r, ap[i__1].i = temp.i;
+ }
+ }
+
+ k += kstep;
+ kc = kcnext;
+ goto L30;
+L50:
+
+ ;
+ } else {
+
+/* Compute inv(A) from the factorization A = L*D*L'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ npp = *n * (*n + 1) / 2;
+ k = *n;
+ kc = npp;
+L60:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L80;
+ }
+
+ kcnext = kc - (*n - k + 2);
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = kc;
+ c_div(&q__1, &c_b1, &ap[kc]);
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+
+/* Compute column K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ ccopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cspmv_(uplo, &i__1, &q__1, &ap[kc + *n - k + 1], &work[1], &
+ c__1, &c_b2, &ap[kc + 1], &c__1);
+ i__1 = kc;
+ i__2 = kc;
+ i__3 = *n - k;
+ cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1);
+ q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = kcnext + 1;
+ t.r = ap[i__1].r, t.i = ap[i__1].i;
+ c_div(&q__1, &ap[kcnext], &t);
+ ak.r = q__1.r, ak.i = q__1.i;
+ c_div(&q__1, &ap[kc], &t);
+ akp1.r = q__1.r, akp1.i = q__1.i;
+ c_div(&q__1, &ap[kcnext + 1], &t);
+ akkp1.r = q__1.r, akkp1.i = q__1.i;
+ q__3.r = ak.r * akp1.r - ak.i * akp1.i, q__3.i = ak.r * akp1.i +
+ ak.i * akp1.r;
+ q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f;
+ q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i
+ * q__2.r;
+ d__.r = q__1.r, d__.i = q__1.i;
+ i__1 = kcnext;
+ c_div(&q__1, &akp1, &d__);
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ i__1 = kc;
+ c_div(&q__1, &ak, &d__);
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ i__1 = kcnext + 1;
+ q__2.r = -akkp1.r, q__2.i = -akkp1.i;
+ c_div(&q__1, &q__2, &d__);
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+
+/* Compute columns K-1 and K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ ccopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cspmv_(uplo, &i__1, &q__1, &ap[kc + (*n - k + 1)], &work[1], &
+ c__1, &c_b2, &ap[kc + 1], &c__1);
+ i__1 = kc;
+ i__2 = kc;
+ i__3 = *n - k;
+ cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1);
+ q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ i__1 = kcnext + 1;
+ i__2 = kcnext + 1;
+ i__3 = *n - k;
+ cdotu_(&q__2, &i__3, &ap[kc + 1], &c__1, &ap[kcnext + 2], &
+ c__1);
+ q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ i__1 = *n - k;
+ ccopy_(&i__1, &ap[kcnext + 2], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cspmv_(uplo, &i__1, &q__1, &ap[kc + (*n - k + 1)], &work[1], &
+ c__1, &c_b2, &ap[kcnext + 2], &c__1);
+ i__1 = kcnext;
+ i__2 = kcnext;
+ i__3 = *n - k;
+ cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kcnext + 2], &c__1);
+ q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ }
+ kstep = 2;
+ kcnext -= *n - k + 3;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the trailing */
+/* submatrix A(k-1:n,k-1:n) */
+
+ kpc = npp - (*n - kp + 1) * (*n - kp + 2) / 2 + 1;
+ if (kp < *n) {
+ i__1 = *n - kp;
+ cswap_(&i__1, &ap[kc + kp - k + 1], &c__1, &ap[kpc + 1], &
+ c__1);
+ }
+ kx = kc + kp - k;
+ i__1 = kp - 1;
+ for (j = k + 1; j <= i__1; ++j) {
+ kx = kx + *n - j + 1;
+ i__2 = kc + j - k;
+ temp.r = ap[i__2].r, temp.i = ap[i__2].i;
+ i__2 = kc + j - k;
+ i__3 = kx;
+ ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
+ i__2 = kx;
+ ap[i__2].r = temp.r, ap[i__2].i = temp.i;
+/* L70: */
+ }
+ i__1 = kc;
+ temp.r = ap[i__1].r, temp.i = ap[i__1].i;
+ i__1 = kc;
+ i__2 = kpc;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kpc;
+ ap[i__1].r = temp.r, ap[i__1].i = temp.i;
+ if (kstep == 2) {
+ i__1 = kc - *n + k - 1;
+ temp.r = ap[i__1].r, temp.i = ap[i__1].i;
+ i__1 = kc - *n + k - 1;
+ i__2 = kc - *n + kp - 1;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kc - *n + kp - 1;
+ ap[i__1].r = temp.r, ap[i__1].i = temp.i;
+ }
+ }
+
+ k -= kstep;
+ kc = kcnext;
+ goto L60;
+L80:
+ ;
+ }
+
+ return 0;
+
+/* End of CSPTRI */
+
+} /* csptri_ */
diff --git a/SRC/csptrs.c b/SRC/csptrs.c
new file mode 100644
index 0000000..d976b8c
--- /dev/null
+++ b/SRC/csptrs.c
@@ -0,0 +1,502 @@
+/* csptrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int csptrs_(char *uplo, integer *n, integer *nrhs, complex *
+ ap, integer *ipiv, complex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer j, k;
+ complex ak, bk;
+ integer kc, kp;
+ complex akm1, bkm1, akm1k;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ complex denom;
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *), cgeru_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *),
+ cswap_(integer *, complex *, integer *, complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSPTRS solves a system of linear equations A*X = B with a complex */
+/* symmetric matrix A stored in packed format using the factorization */
+/* A = U*D*U**T or A = L*D*L**T computed by CSPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by CSPTRF, stored as a */
+/* packed triangular matrix. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CSPTRF. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ap;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CSPTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B, where A = U*D*U'. */
+
+/* First solve U*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L10:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L30;
+ }
+
+ kc -= k;
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &ap[kc], &c__1, &b[k + b_dim1], ldb, &
+ b[b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ c_div(&q__1, &c_b1, &ap[kc + k - 1]);
+ cscal_(nrhs, &q__1, &b[k + b_dim1], ldb);
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K-1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k - 1) {
+ cswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ i__1 = k - 2;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &ap[kc], &c__1, &b[k + b_dim1], ldb, &
+ b[b_dim1 + 1], ldb);
+ i__1 = k - 2;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &ap[kc - (k - 1)], &c__1, &b[k - 1 +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = kc + k - 2;
+ akm1k.r = ap[i__1].r, akm1k.i = ap[i__1].i;
+ c_div(&q__1, &ap[kc - 1], &akm1k);
+ akm1.r = q__1.r, akm1.i = q__1.i;
+ c_div(&q__1, &ap[kc + k - 1], &akm1k);
+ ak.r = q__1.r, ak.i = q__1.i;
+ q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i +
+ akm1.i * ak.r;
+ q__1.r = q__2.r - 1.f, q__1.i = q__2.i - 0.f;
+ denom.r = q__1.r, denom.i = q__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ c_div(&q__1, &b[k - 1 + j * b_dim1], &akm1k);
+ bkm1.r = q__1.r, bkm1.i = q__1.i;
+ c_div(&q__1, &b[k + j * b_dim1], &akm1k);
+ bk.r = q__1.r, bk.i = q__1.i;
+ i__2 = k - 1 + j * b_dim1;
+ q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r *
+ bkm1.i + ak.i * bkm1.r;
+ q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
+ c_div(&q__1, &q__2, &denom);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + j * b_dim1;
+ q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r *
+ bk.i + akm1.i * bk.r;
+ q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
+ c_div(&q__1, &q__2, &denom);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L20: */
+ }
+ kc = kc - k + 1;
+ k += -2;
+ }
+
+ goto L10;
+L30:
+
+/* Next solve U'*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+ kc = 1;
+L40:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L50;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(U'(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &ap[kc]
+, &c__1, &c_b1, &b[k + b_dim1], ldb);
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ kc += k;
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &ap[kc]
+, &c__1, &c_b1, &b[k + b_dim1], ldb);
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &ap[kc
+ + k], &c__1, &c_b1, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ kc = kc + (k << 1) + 1;
+ k += 2;
+ }
+
+ goto L40;
+L50:
+
+ ;
+ } else {
+
+/* Solve A*X = B, where A = L*D*L'. */
+
+/* First solve L*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+ kc = 1;
+L60:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L80;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &ap[kc + 1], &c__1, &b[k + b_dim1],
+ ldb, &b[k + 1 + b_dim1], ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ c_div(&q__1, &c_b1, &ap[kc]);
+ cscal_(nrhs, &q__1, &b[k + b_dim1], ldb);
+ kc = kc + *n - k + 1;
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K+1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k + 1) {
+ cswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ if (k < *n - 1) {
+ i__1 = *n - k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &ap[kc + 2], &c__1, &b[k + b_dim1],
+ ldb, &b[k + 2 + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &ap[kc + *n - k + 2], &c__1, &b[k
+ + 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = kc + 1;
+ akm1k.r = ap[i__1].r, akm1k.i = ap[i__1].i;
+ c_div(&q__1, &ap[kc], &akm1k);
+ akm1.r = q__1.r, akm1.i = q__1.i;
+ c_div(&q__1, &ap[kc + *n - k + 1], &akm1k);
+ ak.r = q__1.r, ak.i = q__1.i;
+ q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i +
+ akm1.i * ak.r;
+ q__1.r = q__2.r - 1.f, q__1.i = q__2.i - 0.f;
+ denom.r = q__1.r, denom.i = q__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ c_div(&q__1, &b[k + j * b_dim1], &akm1k);
+ bkm1.r = q__1.r, bkm1.i = q__1.i;
+ c_div(&q__1, &b[k + 1 + j * b_dim1], &akm1k);
+ bk.r = q__1.r, bk.i = q__1.i;
+ i__2 = k + j * b_dim1;
+ q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r *
+ bkm1.i + ak.i * bkm1.r;
+ q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
+ c_div(&q__1, &q__2, &denom);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r *
+ bk.i + akm1.i * bk.r;
+ q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
+ c_div(&q__1, &q__2, &denom);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L70: */
+ }
+ kc = kc + (*n - k << 1) + 1;
+ k += 2;
+ }
+
+ goto L60;
+L80:
+
+/* Next solve L'*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L90:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L100;
+ }
+
+ kc -= *n - k + 1;
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(L'(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Transpose", &i__1, nrhs, &q__1, &b[k + 1 + b_dim1],
+ ldb, &ap[kc + 1], &c__1, &c_b1, &b[k + b_dim1], ldb);
+ }
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Transpose", &i__1, nrhs, &q__1, &b[k + 1 + b_dim1],
+ ldb, &ap[kc + 1], &c__1, &c_b1, &b[k + b_dim1], ldb);
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Transpose", &i__1, nrhs, &q__1, &b[k + 1 + b_dim1],
+ ldb, &ap[kc - (*n - k)], &c__1, &c_b1, &b[k - 1 +
+ b_dim1], ldb);
+ }
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ kc -= *n - k + 2;
+ k += -2;
+ }
+
+ goto L90;
+L100:
+ ;
+ }
+
+ return 0;
+
+/* End of CSPTRS */
+
+} /* csptrs_ */
diff --git a/SRC/csrscl.c b/SRC/csrscl.c
new file mode 100644
index 0000000..c940703
--- /dev/null
+++ b/SRC/csrscl.c
@@ -0,0 +1,134 @@
+/* csrscl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int csrscl_(integer *n, real *sa, complex *sx, integer *incx)
+{
+ real mul, cden;
+ logical done;
+ real cnum, cden1, cnum1;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *);
+ real bignum, smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSRSCL multiplies an n-element complex vector x by the real scalar */
+/* 1/a. This is done without overflow or underflow as long as */
+/* the final result x/a does not overflow or underflow. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of components of the vector x. */
+
+/* SA (input) REAL */
+/* The scalar a which is used to divide each component of x. */
+/* SA must be >= 0, or the subroutine will divide by zero. */
+
+/* SX (input/output) COMPLEX array, dimension */
+/* (1+(N-1)*abs(INCX)) */
+/* The n-element vector x. */
+
+/* INCX (input) INTEGER */
+/* The increment between successive values of the vector SX. */
+/* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --sx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Initialize the denominator to SA and the numerator to 1. */
+
+ cden = *sa;
+ cnum = 1.f;
+
+L10:
+ cden1 = cden * smlnum;
+ cnum1 = cnum / bignum;
+ if (dabs(cden1) > dabs(cnum) && cnum != 0.f) {
+
+/* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. */
+
+ mul = smlnum;
+ done = FALSE_;
+ cden = cden1;
+ } else if (dabs(cnum1) > dabs(cden)) {
+
+/* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. */
+
+ mul = bignum;
+ done = FALSE_;
+ cnum = cnum1;
+ } else {
+
+/* Multiply X by CNUM / CDEN and return. */
+
+ mul = cnum / cden;
+ done = TRUE_;
+ }
+
+/* Scale the vector X by MUL */
+
+ csscal_(n, &mul, &sx[1], incx);
+
+ if (! done) {
+ goto L10;
+ }
+
+ return 0;
+
+/* End of CSRSCL */
+
+} /* csrscl_ */
diff --git a/SRC/cstedc.c b/SRC/cstedc.c
new file mode 100644
index 0000000..6c499a4
--- /dev/null
+++ b/SRC/cstedc.c
@@ -0,0 +1,496 @@
+/* cstedc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__9 = 9;
+static integer c__0 = 0;
+static integer c__2 = 2;
+static real c_b17 = 0.f;
+static real c_b18 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int cstedc_(char *compz, integer *n, real *d__, real *e,
+ complex *z__, integer *ldz, complex *work, integer *lwork, real *
+ rwork, integer *lrwork, integer *iwork, integer *liwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double log(doublereal);
+ integer pow_ii(integer *, integer *);
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, m;
+ real p;
+ integer ii, ll, lgn;
+ real eps, tiny;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer lwmin;
+ extern /* Subroutine */ int claed0_(integer *, integer *, real *, real *,
+ complex *, integer *, complex *, integer *, real *, integer *,
+ integer *);
+ integer start;
+ extern /* Subroutine */ int clacrm_(integer *, integer *, complex *,
+ integer *, real *, integer *, complex *, integer *, real *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), xerbla_(char *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer finish;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *), sstedc_(char *, integer *, real *, real *, real *,
+ integer *, real *, integer *, integer *, integer *, integer *), slaset_(char *, integer *, integer *, real *, real *,
+ real *, integer *);
+ integer liwmin, icompz;
+ extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *,
+ complex *, integer *, real *, integer *);
+ real orgnrm;
+ extern doublereal slanst_(char *, integer *, real *, real *);
+ extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
+ integer lrwmin;
+ logical lquery;
+ integer smlsiz;
+ extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *,
+ real *, integer *, real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSTEDC computes all eigenvalues and, optionally, eigenvectors of a */
+/* symmetric tridiagonal matrix using the divide and conquer method. */
+/* The eigenvectors of a full or band complex Hermitian matrix can also */
+/* be found if CHETRD or CHPTRD or CHBTRD has been used to reduce this */
+/* matrix to tridiagonal form. */
+
+/* This code makes very mild assumptions about floating point */
+/* arithmetic. It will work on machines with a guard digit in */
+/* add/subtract, or on those binary machines without guard digits */
+/* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */
+/* It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. See SLAED3 for details. */
+
+/* Arguments */
+/* ========= */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only. */
+/* = 'I': Compute eigenvectors of tridiagonal matrix also. */
+/* = 'V': Compute eigenvectors of original Hermitian matrix */
+/* also. On entry, Z contains the unitary matrix used */
+/* to reduce the original matrix to tridiagonal form. */
+
+/* N (input) INTEGER */
+/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the diagonal elements of the tridiagonal matrix. */
+/* On exit, if INFO = 0, the eigenvalues in ascending order. */
+
+/* E (input/output) REAL array, dimension (N-1) */
+/* On entry, the subdiagonal elements of the tridiagonal matrix. */
+/* On exit, E has been destroyed. */
+
+/* Z (input/output) COMPLEX array, dimension (LDZ,N) */
+/* On entry, if COMPZ = 'V', then Z contains the unitary */
+/* matrix used in the reduction to tridiagonal form. */
+/* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */
+/* orthonormal eigenvectors of the original Hermitian matrix, */
+/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */
+/* of the symmetric tridiagonal matrix. */
+/* If COMPZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1. */
+/* If eigenvectors are desired, then LDZ >= max(1,N). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If COMPZ = 'N' or 'I', or N <= 1, LWORK must be at least 1. */
+/* If COMPZ = 'V' and N > 1, LWORK must be at least N*N. */
+/* Note that for COMPZ = 'V', then if N is less than or */
+/* equal to the minimum divide size, usually 25, then LWORK need */
+/* only be 1. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK, RWORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK)) */
+/* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. */
+
+/* LRWORK (input) INTEGER */
+/* The dimension of the array RWORK. */
+/* If COMPZ = 'N' or N <= 1, LRWORK must be at least 1. */
+/* If COMPZ = 'V' and N > 1, LRWORK must be at least */
+/* 1 + 3*N + 2*N*lg N + 3*N**2 , */
+/* where lg( N ) = smallest integer k such */
+/* that 2**k >= N. */
+/* If COMPZ = 'I' and N > 1, LRWORK must be at least */
+/* 1 + 4*N + 2*N**2 . */
+/* Note that for COMPZ = 'I' or 'V', then if N is less than or */
+/* equal to the minimum divide size, usually 25, then LRWORK */
+/* need only be max(1,2*(N-1)). */
+
+/* If LRWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If COMPZ = 'N' or N <= 1, LIWORK must be at least 1. */
+/* If COMPZ = 'V' or N > 1, LIWORK must be at least */
+/* 6 + 6*N + 5*N*lg N. */
+/* If COMPZ = 'I' or N > 1, LIWORK must be at least */
+/* 3 + 5*N . */
+/* Note that for COMPZ = 'I' or 'V', then if N is less than or */
+/* equal to the minimum divide size, usually 25, then LIWORK */
+/* need only be 1. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: The algorithm failed to compute an eigenvalue while */
+/* working on the submatrix lying in rows and columns */
+/* INFO/(N+1) through mod(INFO,N+1). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
+
+ if (lsame_(compz, "N")) {
+ icompz = 0;
+ } else if (lsame_(compz, "V")) {
+ icompz = 1;
+ } else if (lsame_(compz, "I")) {
+ icompz = 2;
+ } else {
+ icompz = -1;
+ }
+ if (icompz < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
+ *info = -6;
+ }
+
+ if (*info == 0) {
+
+/* Compute the workspace requirements */
+
+ smlsiz = ilaenv_(&c__9, "CSTEDC", " ", &c__0, &c__0, &c__0, &c__0);
+ if (*n <= 1 || icompz == 0) {
+ lwmin = 1;
+ liwmin = 1;
+ lrwmin = 1;
+ } else if (*n <= smlsiz) {
+ lwmin = 1;
+ liwmin = 1;
+ lrwmin = *n - 1 << 1;
+ } else if (icompz == 1) {
+ lgn = (integer) (log((real) (*n)) / log(2.f));
+ if (pow_ii(&c__2, &lgn) < *n) {
+ ++lgn;
+ }
+ if (pow_ii(&c__2, &lgn) < *n) {
+ ++lgn;
+ }
+ lwmin = *n * *n;
+/* Computing 2nd power */
+ i__1 = *n;
+ lrwmin = *n * 3 + 1 + (*n << 1) * lgn + i__1 * i__1 * 3;
+ liwmin = *n * 6 + 6 + *n * 5 * lgn;
+ } else if (icompz == 2) {
+ lwmin = 1;
+/* Computing 2nd power */
+ i__1 = *n;
+ lrwmin = (*n << 2) + 1 + (i__1 * i__1 << 1);
+ liwmin = *n * 5 + 3;
+ }
+ work[1].r = (real) lwmin, work[1].i = 0.f;
+ rwork[1] = (real) lrwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -8;
+ } else if (*lrwork < lrwmin && ! lquery) {
+ *info = -10;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CSTEDC", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+ if (*n == 1) {
+ if (icompz != 0) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1.f, z__[i__1].i = 0.f;
+ }
+ return 0;
+ }
+
+/* If the following conditional clause is removed, then the routine */
+/* will use the Divide and Conquer routine to compute only the */
+/* eigenvalues, which requires (3N + 3N**2) real workspace and */
+/* (2 + 5N + 2N lg(N)) integer workspace. */
+/* Since on many architectures SSTERF is much faster than any other */
+/* algorithm for finding eigenvalues only, it is used here */
+/* as the default. If the conditional clause is removed, then */
+/* information on the size of workspace needs to be changed. */
+
+/* If COMPZ = 'N', use SSTERF to compute the eigenvalues. */
+
+ if (icompz == 0) {
+ ssterf_(n, &d__[1], &e[1], info);
+ goto L70;
+ }
+
+/* If N is smaller than the minimum divide size (SMLSIZ+1), then */
+/* solve the problem with another solver. */
+
+ if (*n <= smlsiz) {
+
+ csteqr_(compz, n, &d__[1], &e[1], &z__[z_offset], ldz, &rwork[1],
+ info);
+
+ } else {
+
+/* If COMPZ = 'I', we simply call SSTEDC instead. */
+
+ if (icompz == 2) {
+ slaset_("Full", n, n, &c_b17, &c_b18, &rwork[1], n);
+ ll = *n * *n + 1;
+ i__1 = *lrwork - ll + 1;
+ sstedc_("I", n, &d__[1], &e[1], &rwork[1], n, &rwork[ll], &i__1, &
+ iwork[1], liwork, info);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * z_dim1;
+ i__4 = (j - 1) * *n + i__;
+ z__[i__3].r = rwork[i__4], z__[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ goto L70;
+ }
+
+/* From now on, only option left to be handled is COMPZ = 'V', */
+/* i.e. ICOMPZ = 1. */
+
+/* Scale. */
+
+ orgnrm = slanst_("M", n, &d__[1], &e[1]);
+ if (orgnrm == 0.f) {
+ goto L70;
+ }
+
+ eps = slamch_("Epsilon");
+
+ start = 1;
+
+/* while ( START <= N ) */
+
+L30:
+ if (start <= *n) {
+
+/* Let FINISH be the position of the next subdiagonal entry */
+/* such that E( FINISH ) <= TINY or FINISH = N if no such */
+/* subdiagonal exists. The matrix identified by the elements */
+/* between START and FINISH constitutes an independent */
+/* sub-problem. */
+
+ finish = start;
+L40:
+ if (finish < *n) {
+ tiny = eps * sqrt((r__1 = d__[finish], dabs(r__1))) * sqrt((
+ r__2 = d__[finish + 1], dabs(r__2)));
+ if ((r__1 = e[finish], dabs(r__1)) > tiny) {
+ ++finish;
+ goto L40;
+ }
+ }
+
+/* (Sub) Problem determined. Compute its size and solve it. */
+
+ m = finish - start + 1;
+ if (m > smlsiz) {
+
+/* Scale. */
+
+ orgnrm = slanst_("M", &m, &d__[start], &e[start]);
+ slascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &m, &c__1, &d__[
+ start], &m, info);
+ i__1 = m - 1;
+ i__2 = m - 1;
+ slascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &i__1, &c__1, &e[
+ start], &i__2, info);
+
+ claed0_(n, &m, &d__[start], &e[start], &z__[start * z_dim1 +
+ 1], ldz, &work[1], n, &rwork[1], &iwork[1], info);
+ if (*info > 0) {
+ *info = (*info / (m + 1) + start - 1) * (*n + 1) + *info %
+ (m + 1) + start - 1;
+ goto L70;
+ }
+
+/* Scale back. */
+
+ slascl_("G", &c__0, &c__0, &c_b18, &orgnrm, &m, &c__1, &d__[
+ start], &m, info);
+
+ } else {
+ ssteqr_("I", &m, &d__[start], &e[start], &rwork[1], &m, &
+ rwork[m * m + 1], info);
+ clacrm_(n, &m, &z__[start * z_dim1 + 1], ldz, &rwork[1], &m, &
+ work[1], n, &rwork[m * m + 1]);
+ clacpy_("A", n, &m, &work[1], n, &z__[start * z_dim1 + 1],
+ ldz);
+ if (*info > 0) {
+ *info = start * (*n + 1) + finish;
+ goto L70;
+ }
+ }
+
+ start = finish + 1;
+ goto L30;
+ }
+
+/* endwhile */
+
+/* If the problem split any number of times, then the eigenvalues */
+/* will not be properly ordered. Here we permute the eigenvalues */
+/* (and the associated eigenvectors) into ascending order. */
+
+ if (m != *n) {
+
+/* Use Selection Sort to minimize swaps of eigenvectors */
+
+ i__1 = *n;
+ for (ii = 2; ii <= i__1; ++ii) {
+ i__ = ii - 1;
+ k = i__;
+ p = d__[i__];
+ i__2 = *n;
+ for (j = ii; j <= i__2; ++j) {
+ if (d__[j] < p) {
+ k = j;
+ p = d__[j];
+ }
+/* L50: */
+ }
+ if (k != i__) {
+ d__[k] = d__[i__];
+ d__[i__] = p;
+ cswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1
+ + 1], &c__1);
+ }
+/* L60: */
+ }
+ }
+ }
+
+L70:
+ work[1].r = (real) lwmin, work[1].i = 0.f;
+ rwork[1] = (real) lrwmin;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of CSTEDC */
+
+} /* cstedc_ */
diff --git a/SRC/cstegr.c b/SRC/cstegr.c
new file mode 100644
index 0000000..7ca1374
--- /dev/null
+++ b/SRC/cstegr.c
@@ -0,0 +1,210 @@
+/* cstegr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cstegr_(char *jobz, char *range, integer *n, real *d__,
+ real *e, real *vl, real *vu, integer *il, integer *iu, real *abstol,
+ integer *m, real *w, complex *z__, integer *ldz, integer *isuppz,
+ real *work, integer *lwork, integer *iwork, integer *liwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset;
+
+ /* Local variables */
+ extern /* Subroutine */ int cstemr_(char *, char *, integer *, real *,
+ real *, real *, real *, integer *, integer *, integer *, real *,
+ complex *, integer *, integer *, integer *, logical *, real *,
+ integer *, integer *, integer *, integer *);
+ logical tryrac;
+
+
+
+/* -- LAPACK computational routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSTEGR computes selected eigenvalues and, optionally, eigenvectors */
+/* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */
+/* a well defined set of pairwise different real eigenvalues, the corresponding */
+/* real eigenvectors are pairwise orthogonal. */
+
+/* The spectrum may be computed either completely or partially by specifying */
+/* either an interval (VL,VU] or a range of indices IL:IU for the desired */
+/* eigenvalues. */
+
+/* CSTEGR is a compatability wrapper around the improved CSTEMR routine. */
+/* See SSTEMR for further details. */
+
+/* One important change is that the ABSTOL parameter no longer provides any */
+/* benefit and hence is no longer used. */
+
+/* Note : CSTEGR and CSTEMR work only on machines which follow */
+/* IEEE-754 floating-point standard in their handling of infinities and */
+/* NaNs. Normal execution may create these exceptiona values and hence */
+/* may abort due to a floating point exception in environments which */
+/* do not conform to the IEEE-754 standard. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the N diagonal elements of the tridiagonal matrix */
+/* T. On exit, D is overwritten. */
+
+/* E (input/output) REAL array, dimension (N) */
+/* On entry, the (N-1) subdiagonal elements of the tridiagonal */
+/* matrix T in elements 1 to N-1 of E. E(N) need not be set on */
+/* input, but is used internally as workspace. */
+/* On exit, E is overwritten. */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) REAL */
+/* Unused. Was the absolute error tolerance for the */
+/* eigenvalues/eigenvectors in previous versions. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* The first M elements contain the selected eigenvalues in */
+/* ascending order. */
+
+/* Z (output) COMPLEX array, dimension (LDZ, max(1,M) ) */
+/* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix T */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+/* Supplying N columns is always safe. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', then LDZ >= max(1,N). */
+
+/* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) ) */
+/* The support of the eigenvectors in Z, i.e., the indices */
+/* indicating the nonzero elements in Z. The i-th computed eigenvector */
+/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */
+/* ISUPPZ( 2*i ). This is relevant in the case when the matrix */
+/* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */
+
+/* WORK (workspace/output) REAL array, dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal */
+/* (and minimal) LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,18*N) */
+/* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'. */
+/* 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. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (LIWORK) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. LIWORK >= max(1,10*N) */
+/* if the eigenvectors are desired, and LIWORK >= max(1,8*N) */
+/* if only the eigenvalues are to be computed. */
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal size of the IWORK array, */
+/* returns this value as the first entry of the IWORK array, and */
+/* no error message related to LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* On exit, INFO */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = 1X, internal error in SLARRE, */
+/* if INFO = 2X, internal error in CLARRV. */
+/* Here, the digit X = ABS( IINFO ) < 10, where IINFO is */
+/* the nonzero error code returned by SLARRE or */
+/* CLARRV, respectively. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Inderjit Dhillon, IBM Almaden, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, LBNL/NERSC, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --isuppz;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ tryrac = FALSE_;
+ cstemr_(jobz, range, n, &d__[1], &e[1], vl, vu, il, iu, m, &w[1], &z__[
+ z_offset], ldz, n, &isuppz[1], &tryrac, &work[1], lwork, &iwork[1]
+, liwork, info);
+
+/* End of CSTEGR */
+
+ return 0;
+} /* cstegr_ */
diff --git a/SRC/cstein.c b/SRC/cstein.c
new file mode 100644
index 0000000..ad5a3fc
--- /dev/null
+++ b/SRC/cstein.c
@@ -0,0 +1,468 @@
+/* cstein.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cstein_(integer *n, real *d__, real *e, integer *m, real
+ *w, integer *iblock, integer *isplit, complex *z__, integer *ldz,
+ real *work, integer *iwork, integer *ifail, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4, r__5;
+ complex q__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, b1, j1, bn, jr;
+ real xj, scl, eps, ctr, sep, nrm, tol;
+ integer its;
+ real xjm, eps1;
+ integer jblk, nblk, jmax;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ integer iseed[4], gpind, iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ extern doublereal sasum_(integer *, real *, integer *);
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ real ortol;
+ integer indrv1, indrv2, indrv3, indrv4, indrv5;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), slagtf_(
+ integer *, real *, real *, real *, real *, real *, real *,
+ integer *, integer *);
+ integer nrmchk;
+ extern integer isamax_(integer *, real *, integer *);
+ extern /* Subroutine */ int slagts_(integer *, integer *, real *, real *,
+ real *, real *, integer *, real *, real *, integer *);
+ integer blksiz;
+ real onenrm, pertol;
+ extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
+ *);
+ real stpcrt;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSTEIN computes the eigenvectors of a real symmetric tridiagonal */
+/* matrix T corresponding to specified eigenvalues, using inverse */
+/* iteration. */
+
+/* The maximum number of iterations allowed for each eigenvector is */
+/* specified by an internal parameter MAXITS (currently set to 5). */
+
+/* Although the eigenvectors are real, they are stored in a complex */
+/* array, which may be passed to CUNMTR or CUPMTR for back */
+/* transformation to the eigenvectors of a complex Hermitian matrix */
+/* which was reduced to tridiagonal form. */
+
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix T. */
+
+/* E (input) REAL array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the tridiagonal matrix */
+/* T, stored in elements 1 to N-1. */
+
+/* M (input) INTEGER */
+/* The number of eigenvectors to be found. 0 <= M <= N. */
+
+/* W (input) REAL array, dimension (N) */
+/* The first M elements of W contain the eigenvalues for */
+/* which eigenvectors are to be computed. The eigenvalues */
+/* should be grouped by split-off block and ordered from */
+/* smallest to largest within the block. ( The output array */
+/* W from SSTEBZ with ORDER = 'B' is expected here. ) */
+
+/* IBLOCK (input) INTEGER array, dimension (N) */
+/* The submatrix indices associated with the corresponding */
+/* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to */
+/* the first submatrix from the top, =2 if W(i) belongs to */
+/* the second submatrix, etc. ( The output array IBLOCK */
+/* from SSTEBZ is expected here. ) */
+
+/* ISPLIT (input) INTEGER array, dimension (N) */
+/* The splitting points, at which T breaks up into submatrices. */
+/* The first submatrix consists of rows/columns 1 to */
+/* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 */
+/* through ISPLIT( 2 ), etc. */
+/* ( The output array ISPLIT from SSTEBZ is expected here. ) */
+
+/* Z (output) COMPLEX array, dimension (LDZ, M) */
+/* The computed eigenvectors. The eigenvector associated */
+/* with the eigenvalue W(i) is stored in the i-th column of */
+/* Z. Any vector which fails to converge is set to its current */
+/* iterate after MAXITS iterations. */
+/* The imaginary parts of the eigenvectors are set to zero. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (5*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* IFAIL (output) INTEGER array, dimension (M) */
+/* On normal exit, all elements of IFAIL are zero. */
+/* If one or more eigenvectors fail to converge after */
+/* MAXITS iterations, then their indices are stored in */
+/* array IFAIL. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, then i eigenvectors failed to converge */
+/* in MAXITS iterations. Their indices are stored in */
+/* array IFAIL. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* MAXITS INTEGER, default = 5 */
+/* The maximum number of iterations performed. */
+
+/* EXTRA INTEGER, default = 2 */
+/* The number of iterations performed after norm growth */
+/* criterion is satisfied, should be at least 1. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --w;
+ --iblock;
+ --isplit;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ *info = 0;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ifail[i__] = 0;
+/* L10: */
+ }
+
+ if (*n < 0) {
+ *info = -1;
+ } else if (*m < 0 || *m > *n) {
+ *info = -4;
+ } else if (*ldz < max(1,*n)) {
+ *info = -9;
+ } else {
+ i__1 = *m;
+ for (j = 2; j <= i__1; ++j) {
+ if (iblock[j] < iblock[j - 1]) {
+ *info = -6;
+ goto L30;
+ }
+ if (iblock[j] == iblock[j - 1] && w[j] < w[j - 1]) {
+ *info = -5;
+ goto L30;
+ }
+/* L20: */
+ }
+L30:
+ ;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CSTEIN", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *m == 0) {
+ return 0;
+ } else if (*n == 1) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1.f, z__[i__1].i = 0.f;
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ eps = slamch_("Precision");
+
+/* Initialize seed for random number generator SLARNV. */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = 1;
+/* L40: */
+ }
+
+/* Initialize pointers. */
+
+ indrv1 = 0;
+ indrv2 = indrv1 + *n;
+ indrv3 = indrv2 + *n;
+ indrv4 = indrv3 + *n;
+ indrv5 = indrv4 + *n;
+
+/* Compute eigenvectors of matrix blocks. */
+
+ j1 = 1;
+ i__1 = iblock[*m];
+ for (nblk = 1; nblk <= i__1; ++nblk) {
+
+/* Find starting and ending indices of block nblk. */
+
+ if (nblk == 1) {
+ b1 = 1;
+ } else {
+ b1 = isplit[nblk - 1] + 1;
+ }
+ bn = isplit[nblk];
+ blksiz = bn - b1 + 1;
+ if (blksiz == 1) {
+ goto L60;
+ }
+ gpind = b1;
+
+/* Compute reorthogonalization criterion and stopping criterion. */
+
+ onenrm = (r__1 = d__[b1], dabs(r__1)) + (r__2 = e[b1], dabs(r__2));
+/* Computing MAX */
+ r__3 = onenrm, r__4 = (r__1 = d__[bn], dabs(r__1)) + (r__2 = e[bn - 1]
+ , dabs(r__2));
+ onenrm = dmax(r__3,r__4);
+ i__2 = bn - 1;
+ for (i__ = b1 + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__4 = onenrm, r__5 = (r__1 = d__[i__], dabs(r__1)) + (r__2 = e[
+ i__ - 1], dabs(r__2)) + (r__3 = e[i__], dabs(r__3));
+ onenrm = dmax(r__4,r__5);
+/* L50: */
+ }
+ ortol = onenrm * .001f;
+
+ stpcrt = sqrt(.1f / blksiz);
+
+/* Loop through eigenvalues of block nblk. */
+
+L60:
+ jblk = 0;
+ i__2 = *m;
+ for (j = j1; j <= i__2; ++j) {
+ if (iblock[j] != nblk) {
+ j1 = j;
+ goto L180;
+ }
+ ++jblk;
+ xj = w[j];
+
+/* Skip all the work if the block size is one. */
+
+ if (blksiz == 1) {
+ work[indrv1 + 1] = 1.f;
+ goto L140;
+ }
+
+/* If eigenvalues j and j-1 are too close, add a relatively */
+/* small perturbation. */
+
+ if (jblk > 1) {
+ eps1 = (r__1 = eps * xj, dabs(r__1));
+ pertol = eps1 * 10.f;
+ sep = xj - xjm;
+ if (sep < pertol) {
+ xj = xjm + pertol;
+ }
+ }
+
+ its = 0;
+ nrmchk = 0;
+
+/* Get random starting vector. */
+
+ slarnv_(&c__2, iseed, &blksiz, &work[indrv1 + 1]);
+
+/* Copy the matrix T so it won't be destroyed in factorization. */
+
+ scopy_(&blksiz, &d__[b1], &c__1, &work[indrv4 + 1], &c__1);
+ i__3 = blksiz - 1;
+ scopy_(&i__3, &e[b1], &c__1, &work[indrv2 + 2], &c__1);
+ i__3 = blksiz - 1;
+ scopy_(&i__3, &e[b1], &c__1, &work[indrv3 + 1], &c__1);
+
+/* Compute LU factors with partial pivoting ( PT = LU ) */
+
+ tol = 0.f;
+ slagtf_(&blksiz, &work[indrv4 + 1], &xj, &work[indrv2 + 2], &work[
+ indrv3 + 1], &tol, &work[indrv5 + 1], &iwork[1], &iinfo);
+
+/* Update iteration count. */
+
+L70:
+ ++its;
+ if (its > 5) {
+ goto L120;
+ }
+
+/* Normalize and scale the righthand side vector Pb. */
+
+/* Computing MAX */
+ r__2 = eps, r__3 = (r__1 = work[indrv4 + blksiz], dabs(r__1));
+ scl = blksiz * onenrm * dmax(r__2,r__3) / sasum_(&blksiz, &work[
+ indrv1 + 1], &c__1);
+ sscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1);
+
+/* Solve the system LU = Pb. */
+
+ slagts_(&c_n1, &blksiz, &work[indrv4 + 1], &work[indrv2 + 2], &
+ work[indrv3 + 1], &work[indrv5 + 1], &iwork[1], &work[
+ indrv1 + 1], &tol, &iinfo);
+
+/* Reorthogonalize by modified Gram-Schmidt if eigenvalues are */
+/* close enough. */
+
+ if (jblk == 1) {
+ goto L110;
+ }
+ if ((r__1 = xj - xjm, dabs(r__1)) > ortol) {
+ gpind = j;
+ }
+ if (gpind != j) {
+ i__3 = j - 1;
+ for (i__ = gpind; i__ <= i__3; ++i__) {
+ ctr = 0.f;
+ i__4 = blksiz;
+ for (jr = 1; jr <= i__4; ++jr) {
+ i__5 = b1 - 1 + jr + i__ * z_dim1;
+ ctr += work[indrv1 + jr] * z__[i__5].r;
+/* L80: */
+ }
+ i__4 = blksiz;
+ for (jr = 1; jr <= i__4; ++jr) {
+ i__5 = b1 - 1 + jr + i__ * z_dim1;
+ work[indrv1 + jr] -= ctr * z__[i__5].r;
+/* L90: */
+ }
+/* L100: */
+ }
+ }
+
+/* Check the infinity norm of the iterate. */
+
+L110:
+ jmax = isamax_(&blksiz, &work[indrv1 + 1], &c__1);
+ nrm = (r__1 = work[indrv1 + jmax], dabs(r__1));
+
+/* Continue for additional iterations after norm reaches */
+/* stopping criterion. */
+
+ if (nrm < stpcrt) {
+ goto L70;
+ }
+ ++nrmchk;
+ if (nrmchk < 3) {
+ goto L70;
+ }
+
+ goto L130;
+
+/* If stopping criterion was not satisfied, update info and */
+/* store eigenvector number in array ifail. */
+
+L120:
+ ++(*info);
+ ifail[*info] = j;
+
+/* Accept iterate as jth eigenvector. */
+
+L130:
+ scl = 1.f / snrm2_(&blksiz, &work[indrv1 + 1], &c__1);
+ jmax = isamax_(&blksiz, &work[indrv1 + 1], &c__1);
+ if (work[indrv1 + jmax] < 0.f) {
+ scl = -scl;
+ }
+ sscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1);
+L140:
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * z_dim1;
+ z__[i__4].r = 0.f, z__[i__4].i = 0.f;
+/* L150: */
+ }
+ i__3 = blksiz;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = b1 + i__ - 1 + j * z_dim1;
+ i__5 = indrv1 + i__;
+ q__1.r = work[i__5], q__1.i = 0.f;
+ z__[i__4].r = q__1.r, z__[i__4].i = q__1.i;
+/* L160: */
+ }
+
+/* Save the shift to check eigenvalue spacing at next */
+/* iteration. */
+
+ xjm = xj;
+
+/* L170: */
+ }
+L180:
+ ;
+ }
+
+ return 0;
+
+/* End of CSTEIN */
+
+} /* cstein_ */
diff --git a/SRC/cstemr.c b/SRC/cstemr.c
new file mode 100644
index 0000000..2726853
--- /dev/null
+++ b/SRC/cstemr.c
@@ -0,0 +1,749 @@
+/* cstemr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b18 = .003f;
+
+/* Subroutine */ int cstemr_(char *jobz, char *range, integer *n, real *d__,
+ real *e, real *vl, real *vu, integer *il, integer *iu, integer *m,
+ real *w, complex *z__, integer *ldz, integer *nzc, integer *isuppz,
+ logical *tryrac, real *work, integer *lwork, integer *iwork, integer *
+ liwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ real r1, r2;
+ integer jj;
+ real cs;
+ integer in;
+ real sn, wl, wu;
+ integer iil, iiu;
+ real eps, tmp;
+ integer indd, iend, jblk, wend;
+ real rmin, rmax;
+ integer itmp;
+ real tnrm;
+ integer inde2;
+ extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *)
+ ;
+ integer itmp2;
+ real rtol1, rtol2, scale;
+ integer indgp;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ integer iindw, ilast;
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer lwmin;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ logical wantz;
+ extern /* Subroutine */ int slaev2_(real *, real *, real *, real *, real *
+, real *, real *);
+ logical alleig;
+ integer ibegin;
+ logical indeig;
+ integer iindbl;
+ logical valeig;
+ extern doublereal slamch_(char *);
+ integer wbegin;
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ integer inderr, iindwk, indgrs, offset;
+ extern /* Subroutine */ int slarrc_(char *, integer *, real *, real *,
+ real *, real *, real *, integer *, integer *, integer *, integer *
+), clarrv_(integer *, real *, real *, real *, real *,
+ real *, integer *, integer *, integer *, integer *, real *, real *
+, real *, real *, real *, real *, integer *, integer *, real *,
+ complex *, integer *, integer *, real *, integer *, integer *),
+ slarre_(char *, integer *, real *, real *, integer *, integer *,
+ real *, real *, real *, real *, real *, real *, integer *,
+ integer *, integer *, real *, real *, real *, integer *, integer *
+, real *, real *, real *, integer *, integer *);
+ integer iinspl, indwrk, ifirst, liwmin, nzcmin;
+ real pivmin, thresh;
+ extern doublereal slanst_(char *, integer *, real *, real *);
+ extern /* Subroutine */ int slarrj_(integer *, real *, real *, integer *,
+ integer *, real *, integer *, real *, real *, real *, integer *,
+ real *, real *, integer *);
+ integer nsplit;
+ extern /* Subroutine */ int slarrr_(integer *, real *, real *, integer *);
+ real smlnum;
+ extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *);
+ logical lquery, zquery;
+
+
+/* -- LAPACK computational routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSTEMR computes selected eigenvalues and, optionally, eigenvectors */
+/* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */
+/* a well defined set of pairwise different real eigenvalues, the corresponding */
+/* real eigenvectors are pairwise orthogonal. */
+
+/* The spectrum may be computed either completely or partially by specifying */
+/* either an interval (VL,VU] or a range of indices IL:IU for the desired */
+/* eigenvalues. */
+
+/* Depending on the number of desired eigenvalues, these are computed either */
+/* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are */
+/* computed by the use of various suitable L D L^T factorizations near clusters */
+/* of close eigenvalues (referred to as RRRs, Relatively Robust */
+/* Representations). An informal sketch of the algorithm follows. */
+
+/* For each unreduced block (submatrix) of T, */
+/* (a) Compute T - sigma I = L D L^T, so that L and D */
+/* define all the wanted eigenvalues to high relative accuracy. */
+/* This means that small relative changes in the entries of D and L */
+/* cause only small relative changes in the eigenvalues and */
+/* eigenvectors. The standard (unfactored) representation of the */
+/* tridiagonal matrix T does not have this property in general. */
+/* (b) Compute the eigenvalues to suitable accuracy. */
+/* If the eigenvectors are desired, the algorithm attains full */
+/* accuracy of the computed eigenvalues only right before */
+/* the corresponding vectors have to be computed, see steps c) and d). */
+/* (c) For each cluster of close eigenvalues, select a new */
+/* shift close to the cluster, find a new factorization, and refine */
+/* the shifted eigenvalues to suitable accuracy. */
+/* (d) For each eigenvalue with a large enough relative separation compute */
+/* the corresponding eigenvector by forming a rank revealing twisted */
+/* factorization. Go back to (c) for any clusters that remain. */
+
+/* For more details, see: */
+/* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */
+/* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */
+/* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */
+/* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */
+/* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */
+/* 2004. Also LAPACK Working Note 154. */
+/* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */
+/* tridiagonal eigenvalue/eigenvector problem", */
+/* Computer Science Division Technical Report No. UCB/CSD-97-971, */
+/* UC Berkeley, May 1997. */
+
+/* Notes: */
+/* 1.CSTEMR works only on machines which follow IEEE-754 */
+/* floating-point standard in their handling of infinities and NaNs. */
+/* This permits the use of efficient inner loops avoiding a check for */
+/* zero divisors. */
+
+/* 2. LAPACK routines can be used to reduce a complex Hermitean matrix to */
+/* real symmetric tridiagonal form. */
+
+/* (Any complex Hermitean tridiagonal matrix has real values on its diagonal */
+/* and potentially complex numbers on its off-diagonals. By applying a */
+/* similarity transform with an appropriate diagonal matrix */
+/* diag(1,e^{i \phy_1}, ... , e^{i \phy_{n-1}}), the complex Hermitean */
+/* matrix can be transformed into a real symmetric matrix and complex */
+/* arithmetic can be entirely avoided.) */
+
+/* While the eigenvectors of the real symmetric tridiagonal matrix are real, */
+/* the eigenvectors of original complex Hermitean matrix have complex entries */
+/* in general. */
+/* Since LAPACK drivers overwrite the matrix data with the eigenvectors, */
+/* CSTEMR accepts complex workspace to facilitate interoperability */
+/* with CUNMTR or CUPMTR. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the N diagonal elements of the tridiagonal matrix */
+/* T. On exit, D is overwritten. */
+
+/* E (input/output) REAL array, dimension (N) */
+/* On entry, the (N-1) subdiagonal elements of the tridiagonal */
+/* matrix T in elements 1 to N-1 of E. E(N) need not be set on */
+/* input, but is used internally as workspace. */
+/* On exit, E is overwritten. */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* The first M elements contain the selected eigenvalues in */
+/* ascending order. */
+
+/* Z (output) COMPLEX array, dimension (LDZ, max(1,M) ) */
+/* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix T */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and can be computed with a workspace */
+/* query by setting NZC = -1, see below. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', then LDZ >= max(1,N). */
+
+/* NZC (input) INTEGER */
+/* The number of eigenvectors to be held in the array Z. */
+/* If RANGE = 'A', then NZC >= max(1,N). */
+/* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU]. */
+/* If RANGE = 'I', then NZC >= IU-IL+1. */
+/* If NZC = -1, then a workspace query is assumed; the */
+/* routine calculates the number of columns of the array Z that */
+/* are needed to hold the eigenvectors. */
+/* This value is returned as the first entry of the Z array, and */
+/* no error message related to NZC is issued by XERBLA. */
+
+/* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) ) */
+/* The support of the eigenvectors in Z, i.e., the indices */
+/* indicating the nonzero elements in Z. The i-th computed eigenvector */
+/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */
+/* ISUPPZ( 2*i ). This is relevant in the case when the matrix */
+/* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */
+
+/* TRYRAC (input/output) LOGICAL */
+/* If TRYRAC.EQ..TRUE., indicates that the code should check whether */
+/* the tridiagonal matrix defines its eigenvalues to high relative */
+/* accuracy. If so, the code uses relative-accuracy preserving */
+/* algorithms that might be (a bit) slower depending on the matrix. */
+/* If the matrix does not define its eigenvalues to high relative */
+/* accuracy, the code can uses possibly faster algorithms. */
+/* If TRYRAC.EQ..FALSE., the code is not required to guarantee */
+/* relatively accurate eigenvalues and can use the fastest possible */
+/* techniques. */
+/* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix */
+/* does not define its eigenvalues to high relative accuracy. */
+
+/* WORK (workspace/output) REAL array, dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal */
+/* (and minimal) LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,18*N) */
+/* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'. */
+/* 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. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (LIWORK) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. LIWORK >= max(1,10*N) */
+/* if the eigenvectors are desired, and LIWORK >= max(1,8*N) */
+/* if only the eigenvalues are to be computed. */
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal size of the IWORK array, */
+/* returns this value as the first entry of the IWORK array, and */
+/* no error message related to LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* On exit, INFO */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = 1X, internal error in SLARRE, */
+/* if INFO = 2X, internal error in CLARRV. */
+/* Here, the digit X = ABS( IINFO ) < 10, where IINFO is */
+/* the nonzero error code returned by SLARRE or */
+/* CLARRV, respectively. */
+
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --isuppz;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ lquery = *lwork == -1 || *liwork == -1;
+ zquery = *nzc == -1;
+/* SSTEMR needs WORK of size 6*N, IWORK of size 3*N. */
+/* In addition, SLARRE needs WORK of size 6*N, IWORK of size 5*N. */
+/* Furthermore, CLARRV needs WORK of size 12*N, IWORK of size 7*N. */
+ if (wantz) {
+ lwmin = *n * 18;
+ liwmin = *n * 10;
+ } else {
+/* need less workspace if only the eigenvalues are wanted */
+ lwmin = *n * 12;
+ liwmin = *n << 3;
+ }
+ wl = 0.f;
+ wu = 0.f;
+ iil = 0;
+ iiu = 0;
+ if (valeig) {
+/* We do not reference VL, VU in the cases RANGE = 'I','A' */
+/* The interval (WL, WU] contains all the wanted eigenvalues. */
+/* It is either given by the user or computed in SLARRE. */
+ wl = *vl;
+ wu = *vu;
+ } else if (indeig) {
+/* We do not reference IL, IU in the cases RANGE = 'V','A' */
+ iil = *il;
+ iiu = *iu;
+ }
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (valeig && *n > 0 && wu <= wl) {
+ *info = -7;
+ } else if (indeig && (iil < 1 || iil > *n)) {
+ *info = -8;
+ } else if (indeig && (iiu < iil || iiu > *n)) {
+ *info = -9;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -13;
+ } else if (*lwork < lwmin && ! lquery) {
+ *info = -17;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -19;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
+ rmax = dmin(r__1,r__2);
+
+ if (*info == 0) {
+ work[1] = (real) lwmin;
+ iwork[1] = liwmin;
+
+ if (wantz && alleig) {
+ nzcmin = *n;
+ } else if (wantz && valeig) {
+ slarrc_("T", n, vl, vu, &d__[1], &e[1], &safmin, &nzcmin, &itmp, &
+ itmp2, info);
+ } else if (wantz && indeig) {
+ nzcmin = iiu - iil + 1;
+ } else {
+/* WANTZ .EQ. FALSE. */
+ nzcmin = 0;
+ }
+ if (zquery && *info == 0) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = (real) nzcmin, z__[i__1].i = 0.f;
+ } else if (*nzc < nzcmin && ! zquery) {
+ *info = -14;
+ }
+ }
+ if (*info != 0) {
+
+ i__1 = -(*info);
+ xerbla_("CSTEMR", &i__1);
+
+ return 0;
+ } else if (lquery || zquery) {
+ return 0;
+ }
+
+/* Handle N = 0, 1, and 2 cases immediately */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (alleig || indeig) {
+ *m = 1;
+ w[1] = d__[1];
+ } else {
+ if (wl < d__[1] && wu >= d__[1]) {
+ *m = 1;
+ w[1] = d__[1];
+ }
+ }
+ if (wantz && ! zquery) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1.f, z__[i__1].i = 0.f;
+ isuppz[1] = 1;
+ isuppz[2] = 1;
+ }
+ return 0;
+ }
+
+ if (*n == 2) {
+ if (! wantz) {
+ slae2_(&d__[1], &e[1], &d__[2], &r1, &r2);
+ } else if (wantz && ! zquery) {
+ slaev2_(&d__[1], &e[1], &d__[2], &r1, &r2, &cs, &sn);
+ }
+ if (alleig || valeig && r2 > wl && r2 <= wu || indeig && iil == 1) {
+ ++(*m);
+ w[*m] = r2;
+ if (wantz && ! zquery) {
+ i__1 = *m * z_dim1 + 1;
+ r__1 = -sn;
+ z__[i__1].r = r__1, z__[i__1].i = 0.f;
+ i__1 = *m * z_dim1 + 2;
+ z__[i__1].r = cs, z__[i__1].i = 0.f;
+/* Note: At most one of SN and CS can be zero. */
+ if (sn != 0.f) {
+ if (cs != 0.f) {
+ isuppz[(*m << 1) - 1] = 1;
+ isuppz[(*m << 1) - 1] = 2;
+ } else {
+ isuppz[(*m << 1) - 1] = 1;
+ isuppz[(*m << 1) - 1] = 1;
+ }
+ } else {
+ isuppz[(*m << 1) - 1] = 2;
+ isuppz[*m * 2] = 2;
+ }
+ }
+ }
+ if (alleig || valeig && r1 > wl && r1 <= wu || indeig && iiu == 2) {
+ ++(*m);
+ w[*m] = r1;
+ if (wantz && ! zquery) {
+ i__1 = *m * z_dim1 + 1;
+ z__[i__1].r = cs, z__[i__1].i = 0.f;
+ i__1 = *m * z_dim1 + 2;
+ z__[i__1].r = sn, z__[i__1].i = 0.f;
+/* Note: At most one of SN and CS can be zero. */
+ if (sn != 0.f) {
+ if (cs != 0.f) {
+ isuppz[(*m << 1) - 1] = 1;
+ isuppz[(*m << 1) - 1] = 2;
+ } else {
+ isuppz[(*m << 1) - 1] = 1;
+ isuppz[(*m << 1) - 1] = 1;
+ }
+ } else {
+ isuppz[(*m << 1) - 1] = 2;
+ isuppz[*m * 2] = 2;
+ }
+ }
+ }
+ return 0;
+ }
+/* Continue with general N */
+ indgrs = 1;
+ inderr = (*n << 1) + 1;
+ indgp = *n * 3 + 1;
+ indd = (*n << 2) + 1;
+ inde2 = *n * 5 + 1;
+ indwrk = *n * 6 + 1;
+
+ iinspl = 1;
+ iindbl = *n + 1;
+ iindw = (*n << 1) + 1;
+ iindwk = *n * 3 + 1;
+
+/* Scale matrix to allowable range, if necessary. */
+/* The allowable range is related to the PIVMIN parameter; see the */
+/* comments in SLARRD. The preference for scaling small values */
+/* up is heuristic; we expect users' matrices not to be close to the */
+/* RMAX threshold. */
+
+ scale = 1.f;
+ tnrm = slanst_("M", n, &d__[1], &e[1]);
+ if (tnrm > 0.f && tnrm < rmin) {
+ scale = rmin / tnrm;
+ } else if (tnrm > rmax) {
+ scale = rmax / tnrm;
+ }
+ if (scale != 1.f) {
+ sscal_(n, &scale, &d__[1], &c__1);
+ i__1 = *n - 1;
+ sscal_(&i__1, &scale, &e[1], &c__1);
+ tnrm *= scale;
+ if (valeig) {
+/* If eigenvalues in interval have to be found, */
+/* scale (WL, WU] accordingly */
+ wl *= scale;
+ wu *= scale;
+ }
+ }
+
+/* Compute the desired eigenvalues of the tridiagonal after splitting */
+/* into smaller subblocks if the corresponding off-diagonal elements */
+/* are small */
+/* THRESH is the splitting parameter for SLARRE */
+/* A negative THRESH forces the old splitting criterion based on the */
+/* size of the off-diagonal. A positive THRESH switches to splitting */
+/* which preserves relative accuracy. */
+
+ if (*tryrac) {
+/* Test whether the matrix warrants the more expensive relative approach. */
+ slarrr_(n, &d__[1], &e[1], &iinfo);
+ } else {
+/* The user does not care about relative accurately eigenvalues */
+ iinfo = -1;
+ }
+/* Set the splitting criterion */
+ if (iinfo == 0) {
+ thresh = eps;
+ } else {
+ thresh = -eps;
+/* relative accuracy is desired but T does not guarantee it */
+ *tryrac = FALSE_;
+ }
+
+ if (*tryrac) {
+/* Copy original diagonal, needed to guarantee relative accuracy */
+ scopy_(n, &d__[1], &c__1, &work[indd], &c__1);
+ }
+/* Store the squares of the offdiagonal values of T */
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing 2nd power */
+ r__1 = e[j];
+ work[inde2 + j - 1] = r__1 * r__1;
+/* L5: */
+ }
+/* Set the tolerance parameters for bisection */
+ if (! wantz) {
+/* SLARRE computes the eigenvalues to full precision. */
+ rtol1 = eps * 4.f;
+ rtol2 = eps * 4.f;
+ } else {
+/* SLARRE computes the eigenvalues to less than full precision. */
+/* CLARRV will refine the eigenvalue approximations, and we only */
+/* need less accurate initial bisection in SLARRE. */
+/* Note: these settings do only affect the subset case and SLARRE */
+/* Computing MAX */
+ r__1 = sqrt(eps) * .05f, r__2 = eps * 4.f;
+ rtol1 = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = sqrt(eps) * .005f, r__2 = eps * 4.f;
+ rtol2 = dmax(r__1,r__2);
+ }
+ slarre_(range, n, &wl, &wu, &iil, &iiu, &d__[1], &e[1], &work[inde2], &
+ rtol1, &rtol2, &thresh, &nsplit, &iwork[iinspl], m, &w[1], &work[
+ inderr], &work[indgp], &iwork[iindbl], &iwork[iindw], &work[
+ indgrs], &pivmin, &work[indwrk], &iwork[iindwk], &iinfo);
+ if (iinfo != 0) {
+ *info = abs(iinfo) + 10;
+ return 0;
+ }
+/* Note that if RANGE .NE. 'V', SLARRE computes bounds on the desired */
+/* part of the spectrum. All desired eigenvalues are contained in */
+/* (WL,WU] */
+ if (wantz) {
+
+/* Compute the desired eigenvectors corresponding to the computed */
+/* eigenvalues */
+
+ clarrv_(n, &wl, &wu, &d__[1], &e[1], &pivmin, &iwork[iinspl], m, &
+ c__1, m, &c_b18, &rtol1, &rtol2, &w[1], &work[inderr], &work[
+ indgp], &iwork[iindbl], &iwork[iindw], &work[indgrs], &z__[
+ z_offset], ldz, &isuppz[1], &work[indwrk], &iwork[iindwk], &
+ iinfo);
+ if (iinfo != 0) {
+ *info = abs(iinfo) + 20;
+ return 0;
+ }
+ } else {
+/* SLARRE computes eigenvalues of the (shifted) root representation */
+/* CLARRV returns the eigenvalues of the unshifted matrix. */
+/* However, if the eigenvectors are not desired by the user, we need */
+/* to apply the corresponding shifts from SLARRE to obtain the */
+/* eigenvalues of the original matrix. */
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ itmp = iwork[iindbl + j - 1];
+ w[j] += e[iwork[iinspl + itmp - 1]];
+/* L20: */
+ }
+ }
+
+ if (*tryrac) {
+/* Refine computed eigenvalues so that they are relatively accurate */
+/* with respect to the original matrix T. */
+ ibegin = 1;
+ wbegin = 1;
+ i__1 = iwork[iindbl + *m - 1];
+ for (jblk = 1; jblk <= i__1; ++jblk) {
+ iend = iwork[iinspl + jblk - 1];
+ in = iend - ibegin + 1;
+ wend = wbegin - 1;
+/* check if any eigenvalues have to be refined in this block */
+L36:
+ if (wend < *m) {
+ if (iwork[iindbl + wend] == jblk) {
+ ++wend;
+ goto L36;
+ }
+ }
+ if (wend < wbegin) {
+ ibegin = iend + 1;
+ goto L39;
+ }
+ offset = iwork[iindw + wbegin - 1] - 1;
+ ifirst = iwork[iindw + wbegin - 1];
+ ilast = iwork[iindw + wend - 1];
+ rtol2 = eps * 4.f;
+ slarrj_(&in, &work[indd + ibegin - 1], &work[inde2 + ibegin - 1],
+ &ifirst, &ilast, &rtol2, &offset, &w[wbegin], &work[
+ inderr + wbegin - 1], &work[indwrk], &iwork[iindwk], &
+ pivmin, &tnrm, &iinfo);
+ ibegin = iend + 1;
+ wbegin = wend + 1;
+L39:
+ ;
+ }
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (scale != 1.f) {
+ r__1 = 1.f / scale;
+ sscal_(m, &r__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in increasing order, then sort them, */
+/* possibly along with eigenvectors. */
+
+ if (nsplit > 1) {
+ if (! wantz) {
+ slasrt_("I", m, &w[1], &iinfo);
+ if (iinfo != 0) {
+ *info = 3;
+ return 0;
+ }
+ } else {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp) {
+ i__ = jj;
+ tmp = w[jj];
+ }
+/* L50: */
+ }
+ if (i__ != 0) {
+ w[i__] = w[j];
+ w[j] = tmp;
+ if (wantz) {
+ cswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j *
+ z_dim1 + 1], &c__1);
+ itmp = isuppz[(i__ << 1) - 1];
+ isuppz[(i__ << 1) - 1] = isuppz[(j << 1) - 1];
+ isuppz[(j << 1) - 1] = itmp;
+ itmp = isuppz[i__ * 2];
+ isuppz[i__ * 2] = isuppz[j * 2];
+ isuppz[j * 2] = itmp;
+ }
+ }
+/* L60: */
+ }
+ }
+ }
+
+
+ work[1] = (real) lwmin;
+ iwork[1] = liwmin;
+ return 0;
+
+/* End of CSTEMR */
+
+} /* cstemr_ */
diff --git a/SRC/csteqr.c b/SRC/csteqr.c
new file mode 100644
index 0000000..724bf45
--- /dev/null
+++ b/SRC/csteqr.c
@@ -0,0 +1,620 @@
+/* csteqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static real c_b41 = 1.f;
+
+/* Subroutine */ int csteqr_(char *compz, integer *n, real *d__, real *e,
+ complex *z__, integer *ldz, real *work, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_sign(real *, real *);
+
+ /* Local variables */
+ real b, c__, f, g;
+ integer i__, j, k, l, m;
+ real p, r__, s;
+ integer l1, ii, mm, lm1, mm1, nm1;
+ real rt1, rt2, eps;
+ integer lsv;
+ real tst, eps2;
+ integer lend, jtot;
+ extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *)
+ ;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int clasr_(char *, char *, char *, integer *,
+ integer *, real *, real *, complex *, integer *);
+ real anorm;
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer lendm1, lendp1;
+ extern /* Subroutine */ int slaev2_(real *, real *, real *, real *, real *
+, real *, real *);
+ extern doublereal slapy2_(real *, real *);
+ integer iscale;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real safmax;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *);
+ integer lendsv;
+ extern /* Subroutine */ int slartg_(real *, real *, real *, real *, real *
+);
+ real ssfmin;
+ integer nmaxit, icompz;
+ real ssfmax;
+ extern doublereal slanst_(char *, integer *, real *, real *);
+ extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSTEQR computes all eigenvalues and, optionally, eigenvectors of a */
+/* symmetric tridiagonal matrix using the implicit QL or QR method. */
+/* The eigenvectors of a full or band complex Hermitian matrix can also */
+/* be found if CHETRD or CHPTRD or CHBTRD has been used to reduce this */
+/* matrix to tridiagonal form. */
+
+/* Arguments */
+/* ========= */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only. */
+/* = 'V': Compute eigenvalues and eigenvectors of the original */
+/* Hermitian matrix. On entry, Z must contain the */
+/* unitary matrix used to reduce the original matrix */
+/* to tridiagonal form. */
+/* = 'I': Compute eigenvalues and eigenvectors of the */
+/* tridiagonal matrix. Z is initialized to the identity */
+/* matrix. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the diagonal elements of the tridiagonal matrix. */
+/* On exit, if INFO = 0, the eigenvalues in ascending order. */
+
+/* E (input/output) REAL array, dimension (N-1) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix. */
+/* On exit, E has been destroyed. */
+
+/* Z (input/output) COMPLEX array, dimension (LDZ, N) */
+/* On entry, if COMPZ = 'V', then Z contains the unitary */
+/* matrix used in the reduction to tridiagonal form. */
+/* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */
+/* orthonormal eigenvectors of the original Hermitian matrix, */
+/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */
+/* of the symmetric tridiagonal matrix. */
+/* If COMPZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* eigenvectors are desired, then LDZ >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (max(1,2*N-2)) */
+/* If COMPZ = 'N', then WORK is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: the algorithm has failed to find all the eigenvalues in */
+/* a total of 30*N iterations; if INFO = i, then i */
+/* elements of E have not converged to zero; on exit, D */
+/* and E contain the elements of a symmetric tridiagonal */
+/* matrix which is unitarily similar to the original */
+/* matrix. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+ if (lsame_(compz, "N")) {
+ icompz = 0;
+ } else if (lsame_(compz, "V")) {
+ icompz = 1;
+ } else if (lsame_(compz, "I")) {
+ icompz = 2;
+ } else {
+ icompz = -1;
+ }
+ if (icompz < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CSTEQR", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (icompz == 2) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1.f, z__[i__1].i = 0.f;
+ }
+ return 0;
+ }
+
+/* Determine the unit roundoff and over/underflow thresholds. */
+
+ eps = slamch_("E");
+/* Computing 2nd power */
+ r__1 = eps;
+ eps2 = r__1 * r__1;
+ safmin = slamch_("S");
+ safmax = 1.f / safmin;
+ ssfmax = sqrt(safmax) / 3.f;
+ ssfmin = sqrt(safmin) / eps2;
+
+/* Compute the eigenvalues and eigenvectors of the tridiagonal */
+/* matrix. */
+
+ if (icompz == 2) {
+ claset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
+ }
+
+ nmaxit = *n * 30;
+ jtot = 0;
+
+/* Determine where the matrix splits and choose QL or QR iteration */
+/* for each block, according to whether top or bottom diagonal */
+/* element is smaller. */
+
+ l1 = 1;
+ nm1 = *n - 1;
+
+L10:
+ if (l1 > *n) {
+ goto L160;
+ }
+ if (l1 > 1) {
+ e[l1 - 1] = 0.f;
+ }
+ if (l1 <= nm1) {
+ i__1 = nm1;
+ for (m = l1; m <= i__1; ++m) {
+ tst = (r__1 = e[m], dabs(r__1));
+ if (tst == 0.f) {
+ goto L30;
+ }
+ if (tst <= sqrt((r__1 = d__[m], dabs(r__1))) * sqrt((r__2 = d__[m
+ + 1], dabs(r__2))) * eps) {
+ e[m] = 0.f;
+ goto L30;
+ }
+/* L20: */
+ }
+ }
+ m = *n;
+
+L30:
+ l = l1;
+ lsv = l;
+ lend = m;
+ lendsv = lend;
+ l1 = m + 1;
+ if (lend == l) {
+ goto L10;
+ }
+
+/* Scale submatrix in rows and columns L to LEND */
+
+ i__1 = lend - l + 1;
+ anorm = slanst_("I", &i__1, &d__[l], &e[l]);
+ iscale = 0;
+ if (anorm == 0.f) {
+ goto L10;
+ }
+ if (anorm > ssfmax) {
+ iscale = 1;
+ i__1 = lend - l + 1;
+ slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
+ info);
+ i__1 = lend - l;
+ slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
+ info);
+ } else if (anorm < ssfmin) {
+ iscale = 2;
+ i__1 = lend - l + 1;
+ slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
+ info);
+ i__1 = lend - l;
+ slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
+ info);
+ }
+
+/* Choose between QL and QR iteration */
+
+ if ((r__1 = d__[lend], dabs(r__1)) < (r__2 = d__[l], dabs(r__2))) {
+ lend = lsv;
+ l = lendsv;
+ }
+
+ if (lend > l) {
+
+/* QL Iteration */
+
+/* Look for small subdiagonal element. */
+
+L40:
+ if (l != lend) {
+ lendm1 = lend - 1;
+ i__1 = lendm1;
+ for (m = l; m <= i__1; ++m) {
+/* Computing 2nd power */
+ r__2 = (r__1 = e[m], dabs(r__1));
+ tst = r__2 * r__2;
+ if (tst <= eps2 * (r__1 = d__[m], dabs(r__1)) * (r__2 = d__[m
+ + 1], dabs(r__2)) + safmin) {
+ goto L60;
+ }
+/* L50: */
+ }
+ }
+
+ m = lend;
+
+L60:
+ if (m < lend) {
+ e[m] = 0.f;
+ }
+ p = d__[l];
+ if (m == l) {
+ goto L80;
+ }
+
+/* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2 */
+/* to compute its eigensystem. */
+
+ if (m == l + 1) {
+ if (icompz > 0) {
+ slaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
+ work[l] = c__;
+ work[*n - 1 + l] = s;
+ clasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], &
+ z__[l * z_dim1 + 1], ldz);
+ } else {
+ slae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
+ }
+ d__[l] = rt1;
+ d__[l + 1] = rt2;
+ e[l] = 0.f;
+ l += 2;
+ if (l <= lend) {
+ goto L40;
+ }
+ goto L140;
+ }
+
+ if (jtot == nmaxit) {
+ goto L140;
+ }
+ ++jtot;
+
+/* Form shift. */
+
+ g = (d__[l + 1] - p) / (e[l] * 2.f);
+ r__ = slapy2_(&g, &c_b41);
+ g = d__[m] - p + e[l] / (g + r_sign(&r__, &g));
+
+ s = 1.f;
+ c__ = 1.f;
+ p = 0.f;
+
+/* Inner loop */
+
+ mm1 = m - 1;
+ i__1 = l;
+ for (i__ = mm1; i__ >= i__1; --i__) {
+ f = s * e[i__];
+ b = c__ * e[i__];
+ slartg_(&g, &f, &c__, &s, &r__);
+ if (i__ != m - 1) {
+ e[i__ + 1] = r__;
+ }
+ g = d__[i__ + 1] - p;
+ r__ = (d__[i__] - g) * s + c__ * 2.f * b;
+ p = s * r__;
+ d__[i__ + 1] = g + p;
+ g = c__ * r__ - b;
+
+/* If eigenvectors are desired, then save rotations. */
+
+ if (icompz > 0) {
+ work[i__] = c__;
+ work[*n - 1 + i__] = -s;
+ }
+
+/* L70: */
+ }
+
+/* If eigenvectors are desired, then apply saved rotations. */
+
+ if (icompz > 0) {
+ mm = m - l + 1;
+ clasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l
+ * z_dim1 + 1], ldz);
+ }
+
+ d__[l] -= p;
+ e[l] = g;
+ goto L40;
+
+/* Eigenvalue found. */
+
+L80:
+ d__[l] = p;
+
+ ++l;
+ if (l <= lend) {
+ goto L40;
+ }
+ goto L140;
+
+ } else {
+
+/* QR Iteration */
+
+/* Look for small superdiagonal element. */
+
+L90:
+ if (l != lend) {
+ lendp1 = lend + 1;
+ i__1 = lendp1;
+ for (m = l; m >= i__1; --m) {
+/* Computing 2nd power */
+ r__2 = (r__1 = e[m - 1], dabs(r__1));
+ tst = r__2 * r__2;
+ if (tst <= eps2 * (r__1 = d__[m], dabs(r__1)) * (r__2 = d__[m
+ - 1], dabs(r__2)) + safmin) {
+ goto L110;
+ }
+/* L100: */
+ }
+ }
+
+ m = lend;
+
+L110:
+ if (m > lend) {
+ e[m - 1] = 0.f;
+ }
+ p = d__[l];
+ if (m == l) {
+ goto L130;
+ }
+
+/* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2 */
+/* to compute its eigensystem. */
+
+ if (m == l - 1) {
+ if (icompz > 0) {
+ slaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s)
+ ;
+ work[m] = c__;
+ work[*n - 1 + m] = s;
+ clasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], &
+ z__[(l - 1) * z_dim1 + 1], ldz);
+ } else {
+ slae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
+ }
+ d__[l - 1] = rt1;
+ d__[l] = rt2;
+ e[l - 1] = 0.f;
+ l += -2;
+ if (l >= lend) {
+ goto L90;
+ }
+ goto L140;
+ }
+
+ if (jtot == nmaxit) {
+ goto L140;
+ }
+ ++jtot;
+
+/* Form shift. */
+
+ g = (d__[l - 1] - p) / (e[l - 1] * 2.f);
+ r__ = slapy2_(&g, &c_b41);
+ g = d__[m] - p + e[l - 1] / (g + r_sign(&r__, &g));
+
+ s = 1.f;
+ c__ = 1.f;
+ p = 0.f;
+
+/* Inner loop */
+
+ lm1 = l - 1;
+ i__1 = lm1;
+ for (i__ = m; i__ <= i__1; ++i__) {
+ f = s * e[i__];
+ b = c__ * e[i__];
+ slartg_(&g, &f, &c__, &s, &r__);
+ if (i__ != m) {
+ e[i__ - 1] = r__;
+ }
+ g = d__[i__] - p;
+ r__ = (d__[i__ + 1] - g) * s + c__ * 2.f * b;
+ p = s * r__;
+ d__[i__] = g + p;
+ g = c__ * r__ - b;
+
+/* If eigenvectors are desired, then save rotations. */
+
+ if (icompz > 0) {
+ work[i__] = c__;
+ work[*n - 1 + i__] = s;
+ }
+
+/* L120: */
+ }
+
+/* If eigenvectors are desired, then apply saved rotations. */
+
+ if (icompz > 0) {
+ mm = l - m + 1;
+ clasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m
+ * z_dim1 + 1], ldz);
+ }
+
+ d__[l] -= p;
+ e[lm1] = g;
+ goto L90;
+
+/* Eigenvalue found. */
+
+L130:
+ d__[l] = p;
+
+ --l;
+ if (l >= lend) {
+ goto L90;
+ }
+ goto L140;
+
+ }
+
+/* Undo scaling if necessary */
+
+L140:
+ if (iscale == 1) {
+ i__1 = lendsv - lsv + 1;
+ slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
+ n, info);
+ i__1 = lendsv - lsv;
+ slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n,
+ info);
+ } else if (iscale == 2) {
+ i__1 = lendsv - lsv + 1;
+ slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
+ n, info);
+ i__1 = lendsv - lsv;
+ slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n,
+ info);
+ }
+
+/* Check for no convergence to an eigenvalue after a total */
+/* of N*MAXIT iterations. */
+
+ if (jtot == nmaxit) {
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (e[i__] != 0.f) {
+ ++(*info);
+ }
+/* L150: */
+ }
+ return 0;
+ }
+ goto L10;
+
+/* Order eigenvalues and eigenvectors. */
+
+L160:
+ if (icompz == 0) {
+
+/* Use Quick Sort */
+
+ slasrt_("I", n, &d__[1], info);
+
+ } else {
+
+/* Use Selection Sort to minimize swaps of eigenvectors */
+
+ i__1 = *n;
+ for (ii = 2; ii <= i__1; ++ii) {
+ i__ = ii - 1;
+ k = i__;
+ p = d__[i__];
+ i__2 = *n;
+ for (j = ii; j <= i__2; ++j) {
+ if (d__[j] < p) {
+ k = j;
+ p = d__[j];
+ }
+/* L170: */
+ }
+ if (k != i__) {
+ d__[k] = d__[i__];
+ d__[i__] = p;
+ cswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1],
+ &c__1);
+ }
+/* L180: */
+ }
+ }
+ return 0;
+
+/* End of CSTEQR */
+
+} /* csteqr_ */
diff --git a/SRC/csycon.c b/SRC/csycon.c
new file mode 100644
index 0000000..fe23ded
--- /dev/null
+++ b/SRC/csycon.c
@@ -0,0 +1,201 @@
+/* csycon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int csycon_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *ipiv, real *anorm, real *rcond, complex *work, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *), xerbla_(char *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int csytrs_(char *, integer *, integer *, complex
+ *, integer *, integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSYCON estimates the reciprocal of the condition number (in the */
+/* 1-norm) of a complex symmetric matrix A using the factorization */
+/* A = U*D*U**T or A = L*D*L**T computed by CSYTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by CSYTRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CSYTRF. */
+
+/* ANORM (input) REAL */
+/* The 1-norm of the original matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*anorm < 0.f) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CSYCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.f;
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ } else if (*anorm <= 0.f) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ for (i__ = *n; i__ >= 1; --i__) {
+ i__1 = i__ + i__ * a_dim1;
+ if (ipiv[i__] > 0 && (a[i__1].r == 0.f && a[i__1].i == 0.f)) {
+ return 0;
+ }
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ if (ipiv[i__] > 0 && (a[i__2].r == 0.f && a[i__2].i == 0.f)) {
+ return 0;
+ }
+/* L20: */
+ }
+ }
+
+/* Estimate the 1-norm of the inverse. */
+
+ kase = 0;
+L30:
+ clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+
+/* Multiply by inv(L*D*L') or inv(U*D*U'). */
+
+ csytrs_(uplo, n, &c__1, &a[a_offset], lda, &ipiv[1], &work[1], n,
+ info);
+ goto L30;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / ainvnm / *anorm;
+ }
+
+ return 0;
+
+/* End of CSYCON */
+
+} /* csycon_ */
diff --git a/SRC/csyequb.c b/SRC/csyequb.c
new file mode 100644
index 0000000..d2e20e3
--- /dev/null
+++ b/SRC/csyequb.c
@@ -0,0 +1,451 @@
+/* csyequb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int csyequb_(char *uplo, integer *n, complex *a, integer *
+ lda, real *s, real *scond, real *amax, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ doublereal d__1;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ double r_imag(complex *), sqrt(doublereal), log(doublereal), pow_ri(real *
+ , integer *);
+
+ /* Local variables */
+ real d__;
+ integer i__, j;
+ real t, u, c0, c1, c2, si;
+ logical up;
+ real avg, std, tol, base;
+ integer iter;
+ real smin, smax, scale;
+ extern logical lsame_(char *, char *);
+ real sumsq;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ extern /* Subroutine */ int classq_(integer *, complex *, integer *, real
+ *, real *);
+ real smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSYEQUB computes row and column scalings intended to equilibrate a */
+/* symmetric matrix A and reduce its condition number */
+/* (with respect to the two-norm). S contains the scale factors, */
+/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
+/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
+/* choice of S puts the condition number of B within a factor N of the */
+/* smallest possible condition number over all possible diagonal */
+/* scalings. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The N-by-N symmetric matrix whose scaling */
+/* factors are to be computed. Only the diagonal elements of A */
+/* are referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* S (output) REAL array, dimension (N) */
+/* If INFO = 0, S contains the scale factors for A. */
+
+/* SCOND (output) REAL */
+/* If INFO = 0, S contains the ratio of the smallest S(i) to */
+/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
+/* large nor too small, it is not worth scaling by S. */
+
+/* AMAX (output) REAL */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
+
+/* Further Details */
+/* ======= ======= */
+
+/* Reference: Livne, O.E. and Golub, G.H., "Scaling by Binormalization", */
+/* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. */
+/* DOI 10.1023/B:NUMA.0000016606.32820.69 */
+/* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* Statement Function Definitions */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (! (lsame_(uplo, "U") || lsame_(uplo, "L"))) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CSYEQUB", &i__1);
+ return 0;
+ }
+ up = lsame_(uplo, "U");
+ *amax = 0.f;
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ *scond = 1.f;
+ return 0;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s[i__] = 0.f;
+ }
+ *amax = 0.f;
+ if (up) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = s[i__], r__4 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ s[i__] = dmax(r__3,r__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = s[j], r__4 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ s[j] = dmax(r__3,r__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = *amax, r__4 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ *amax = dmax(r__3,r__4);
+ }
+/* Computing MAX */
+ i__2 = j + j * a_dim1;
+ r__3 = s[j], r__4 = (r__1 = a[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[j + j * a_dim1]), dabs(r__2));
+ s[j] = dmax(r__3,r__4);
+/* Computing MAX */
+ i__2 = j + j * a_dim1;
+ r__3 = *amax, r__4 = (r__1 = a[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[j + j * a_dim1]), dabs(r__2));
+ *amax = dmax(r__3,r__4);
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j + j * a_dim1;
+ r__3 = s[j], r__4 = (r__1 = a[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[j + j * a_dim1]), dabs(r__2));
+ s[j] = dmax(r__3,r__4);
+/* Computing MAX */
+ i__2 = j + j * a_dim1;
+ r__3 = *amax, r__4 = (r__1 = a[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[j + j * a_dim1]), dabs(r__2));
+ *amax = dmax(r__3,r__4);
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = s[i__], r__4 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ s[i__] = dmax(r__3,r__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = s[j], r__4 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ s[j] = dmax(r__3,r__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ r__3 = *amax, r__4 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2));
+ *amax = dmax(r__3,r__4);
+ }
+ }
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ s[j] = 1.f / s[j];
+ }
+ tol = 1.f / sqrt(*n * 2.f);
+ for (iter = 1; iter <= 100; ++iter) {
+ scale = 0.f;
+ sumsq = 0.f;
+/* beta = |A|s */
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ work[i__2].r = 0.f, work[i__2].i = 0.f;
+ }
+ if (up) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ t = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ i__ + j * a_dim1]), dabs(r__2));
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ r__3 = ((r__1 = a[i__5].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[i__ + j * a_dim1]), dabs(r__2))) * s[j];
+ q__1.r = work[i__4].r + r__3, q__1.i = work[i__4].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ i__3 = j;
+ i__4 = j;
+ i__5 = i__ + j * a_dim1;
+ r__3 = ((r__1 = a[i__5].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[i__ + j * a_dim1]), dabs(r__2))) * s[i__];
+ q__1.r = work[i__4].r + r__3, q__1.i = work[i__4].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ }
+ i__2 = j;
+ i__3 = j;
+ i__4 = j + j * a_dim1;
+ r__3 = ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&a[j
+ + j * a_dim1]), dabs(r__2))) * s[j];
+ q__1.r = work[i__3].r + r__3, q__1.i = work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ i__3 = j;
+ i__4 = j + j * a_dim1;
+ r__3 = ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&a[j
+ + j * a_dim1]), dabs(r__2))) * s[j];
+ q__1.r = work[i__3].r + r__3, q__1.i = work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ t = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ i__ + j * a_dim1]), dabs(r__2));
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ r__3 = ((r__1 = a[i__5].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[i__ + j * a_dim1]), dabs(r__2))) * s[j];
+ q__1.r = work[i__4].r + r__3, q__1.i = work[i__4].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ i__3 = j;
+ i__4 = j;
+ i__5 = i__ + j * a_dim1;
+ r__3 = ((r__1 = a[i__5].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[i__ + j * a_dim1]), dabs(r__2))) * s[i__];
+ q__1.r = work[i__4].r + r__3, q__1.i = work[i__4].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ }
+ }
+ }
+/* avg = s^T beta / n */
+ avg = 0.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ q__2.r = s[i__2] * work[i__3].r, q__2.i = s[i__2] * work[i__3].i;
+ q__1.r = avg + q__2.r, q__1.i = q__2.i;
+ avg = q__1.r;
+ }
+ avg /= *n;
+ std = 0.f;
+ i__1 = *n << 1;
+ for (i__ = *n + 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__ - *n;
+ i__4 = i__ - *n;
+ q__2.r = s[i__3] * work[i__4].r, q__2.i = s[i__3] * work[i__4].i;
+ q__1.r = q__2.r - avg, q__1.i = q__2.i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ classq_(n, &work[*n + 1], &c__1, &scale, &sumsq);
+ std = scale * sqrt(sumsq / *n);
+ if (std < tol * avg) {
+ goto L999;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ t = (r__1 = a[i__2].r, dabs(r__1)) + (r__2 = r_imag(&a[i__ + i__ *
+ a_dim1]), dabs(r__2));
+ si = s[i__];
+ c2 = (*n - 1) * t;
+ i__2 = *n - 2;
+ i__3 = i__;
+ r__1 = t * si;
+ q__2.r = work[i__3].r - r__1, q__2.i = work[i__3].i;
+ d__1 = (doublereal) i__2;
+ q__1.r = d__1 * q__2.r, q__1.i = d__1 * q__2.i;
+ c1 = q__1.r;
+ r__1 = -(t * si) * si;
+ i__2 = i__;
+ d__1 = 2.;
+ q__4.r = d__1 * work[i__2].r, q__4.i = d__1 * work[i__2].i;
+ q__3.r = si * q__4.r, q__3.i = si * q__4.i;
+ q__2.r = r__1 + q__3.r, q__2.i = q__3.i;
+ r__2 = *n * avg;
+ q__1.r = q__2.r - r__2, q__1.i = q__2.i;
+ c0 = q__1.r;
+ d__ = c1 * c1 - c0 * 4 * c2;
+ if (d__ <= 0.f) {
+ *info = -1;
+ return 0;
+ }
+ si = c0 * -2 / (c1 + sqrt(d__));
+ d__ = si - s[i__];
+ u = 0.f;
+ if (up) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ t = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[j
+ + i__ * a_dim1]), dabs(r__2));
+ u += s[j] * t;
+ i__3 = j;
+ i__4 = j;
+ r__1 = d__ * t;
+ q__1.r = work[i__4].r + r__1, q__1.i = work[i__4].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ t = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ i__ + j * a_dim1]), dabs(r__2));
+ u += s[j] * t;
+ i__3 = j;
+ i__4 = j;
+ r__1 = d__ * t;
+ q__1.r = work[i__4].r + r__1, q__1.i = work[i__4].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ t = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ i__ + j * a_dim1]), dabs(r__2));
+ u += s[j] * t;
+ i__3 = j;
+ i__4 = j;
+ r__1 = d__ * t;
+ q__1.r = work[i__4].r + r__1, q__1.i = work[i__4].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ t = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[j
+ + i__ * a_dim1]), dabs(r__2));
+ u += s[j] * t;
+ i__3 = j;
+ i__4 = j;
+ r__1 = d__ * t;
+ q__1.r = work[i__4].r + r__1, q__1.i = work[i__4].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ }
+ }
+ i__2 = i__;
+ q__4.r = u + work[i__2].r, q__4.i = work[i__2].i;
+ q__3.r = d__ * q__4.r, q__3.i = d__ * q__4.i;
+ d__1 = (doublereal) (*n);
+ q__2.r = q__3.r / d__1, q__2.i = q__3.i / d__1;
+ q__1.r = avg + q__2.r, q__1.i = q__2.i;
+ avg = q__1.r;
+ s[i__] = si;
+ }
+ }
+L999:
+ smlnum = slamch_("SAFEMIN");
+ bignum = 1.f / smlnum;
+ smin = bignum;
+ smax = 0.f;
+ t = 1.f / sqrt(avg);
+ base = slamch_("B");
+ u = 1.f / log(base);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = (integer) (u * log(s[i__] * t));
+ s[i__] = pow_ri(&base, &i__2);
+/* Computing MIN */
+ r__1 = smin, r__2 = s[i__];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = smax, r__2 = s[i__];
+ smax = dmax(r__1,r__2);
+ }
+ *scond = dmax(smin,smlnum) / dmin(smax,bignum);
+
+ return 0;
+} /* csyequb_ */
diff --git a/SRC/csymv.c b/SRC/csymv.c
new file mode 100644
index 0000000..d6851ee
--- /dev/null
+++ b/SRC/csymv.c
@@ -0,0 +1,429 @@
+/* csymv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int csymv_(char *uplo, integer *n, complex *alpha, complex *
+ a, integer *lda, complex *x, integer *incx, complex *beta, complex *y,
+ integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Local variables */
+ integer i__, j, ix, iy, jx, jy, kx, ky, info;
+ complex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSYMV performs the matrix-vector operation */
+
+/* y := alpha*A*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are n element vectors and */
+/* A is an n by n symmetric matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array A is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of A */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of A */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* N (input) INTEGER */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA (input) COMPLEX */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A (input) COMPLEX array, dimension ( LDA, N ) */
+/* Before entry, with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular part of the symmetric matrix and the strictly */
+/* lower triangular part of A is not referenced. */
+/* Before entry, with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular part of the symmetric matrix and the strictly */
+/* upper triangular part of A is not referenced. */
+/* Unchanged on exit. */
+
+/* LDA (input) INTEGER */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, N ). */
+/* Unchanged on exit. */
+
+/* X (input) COMPLEX array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the N- */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX (input) INTEGER */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA (input) COMPLEX */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y (input/output) COMPLEX array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. On exit, Y is overwritten by the updated */
+/* vector y. */
+
+/* INCY (input) INTEGER */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*lda < max(1,*n)) {
+ info = 5;
+ } else if (*incx == 0) {
+ info = 7;
+ } else if (*incy == 0) {
+ info = 10;
+ }
+ if (info != 0) {
+ xerbla_("CSYMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f &&
+ beta->i == 0.f)) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through the triangular part */
+/* of A. */
+
+/* First form y := beta*y. */
+
+ if (beta->r != 1.f || beta->i != 0.f) {
+ if (*incy == 1) {
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ y[i__2].r = 0.f, y[i__2].i = 0.f;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ y[i__2].r = 0.f, y[i__2].i = 0.f;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ i__3 = iy;
+ q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (alpha->r == 0.f && alpha->i == 0.f) {
+ return 0;
+ }
+ if (lsame_(uplo, "U")) {
+
+/* Form y when A is stored in upper triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ q__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[
+ i__4].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L50: */
+ }
+ i__2 = j;
+ i__3 = j;
+ i__4 = j + j * a_dim1;
+ q__3.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i, q__3.i =
+ temp1.r * a[i__4].i + temp1.i * a[i__4].r;
+ q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i;
+ q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ ix = kx;
+ iy = ky;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = iy;
+ i__4 = iy;
+ i__5 = i__ + j * a_dim1;
+ q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ i__3 = i__ + j * a_dim1;
+ i__4 = ix;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ q__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[
+ i__4].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ i__2 = jy;
+ i__3 = jy;
+ i__4 = j + j * a_dim1;
+ q__3.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i, q__3.i =
+ temp1.r * a[i__4].i + temp1.i * a[i__4].r;
+ q__2.r = y[i__3].r + q__3.r, q__2.i = y[i__3].i + q__3.i;
+ q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ jx += *incx;
+ jy += *incy;
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y when A is stored in lower triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__2 = j;
+ i__3 = j;
+ i__4 = j + j * a_dim1;
+ q__2.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i, q__2.i =
+ temp1.r * a[i__4].i + temp1.i * a[i__4].r;
+ q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ q__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[
+ i__4].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L90: */
+ }
+ i__2 = j;
+ i__3 = j;
+ q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__2 = jy;
+ i__3 = jy;
+ i__4 = j + j * a_dim1;
+ q__2.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i, q__2.i =
+ temp1.r * a[i__4].i + temp1.i * a[i__4].r;
+ q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ ix = jx;
+ iy = jy;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ ix += *incx;
+ iy += *incy;
+ i__3 = iy;
+ i__4 = iy;
+ i__5 = i__ + j * a_dim1;
+ q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ i__3 = i__ + j * a_dim1;
+ i__4 = ix;
+ q__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ q__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[
+ i__4].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L110: */
+ }
+ i__2 = jy;
+ i__3 = jy;
+ q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ jx += *incx;
+ jy += *incy;
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CSYMV */
+
+} /* csymv_ */
diff --git a/SRC/csyr.c b/SRC/csyr.c
new file mode 100644
index 0000000..d09dcea
--- /dev/null
+++ b/SRC/csyr.c
@@ -0,0 +1,289 @@
+/* csyr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int csyr_(char *uplo, integer *n, complex *alpha, complex *x,
+ integer *incx, complex *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1, q__2;
+
+ /* Local variables */
+ integer i__, j, ix, jx, kx, info;
+ complex temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSYR performs the symmetric rank 1 operation */
+
+/* A := alpha*x*( x' ) + A, */
+
+/* where alpha is a complex scalar, x is an n element vector and A is an */
+/* n by n symmetric matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array A is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of A */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of A */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* N (input) INTEGER */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA (input) COMPLEX */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X (input) COMPLEX array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the N- */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX (input) INTEGER */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* A (input/output) COMPLEX array, dimension ( LDA, N ) */
+/* Before entry, with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular part of the symmetric matrix and the strictly */
+/* lower triangular part of A is not referenced. On exit, the */
+/* upper triangular part of the array A is overwritten by the */
+/* upper triangular part of the updated matrix. */
+/* Before entry, with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular part of the symmetric matrix and the strictly */
+/* upper triangular part of A is not referenced. On exit, the */
+/* lower triangular part of the array A is overwritten by the */
+/* lower triangular part of the updated matrix. */
+
+/* LDA (input) INTEGER */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, N ). */
+/* Unchanged on exit. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ } else if (*lda < max(1,*n)) {
+ info = 7;
+ }
+ if (info != 0) {
+ xerbla_("CSYR ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f) {
+ return 0;
+ }
+
+/* Set the start point in X if the increment is not unity. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through the triangular part */
+/* of A. */
+
+ if (lsame_(uplo, "U")) {
+
+/* Form A when A is stored in upper triangle. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ i__2 = j;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__;
+ q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ q__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i +
+ q__2.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L10: */
+ }
+ }
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ i__2 = jx;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix = kx;
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = ix;
+ q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ q__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i +
+ q__2.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ ix += *incx;
+/* L30: */
+ }
+ }
+ jx += *incx;
+/* L40: */
+ }
+ }
+ } else {
+
+/* Form A when A is stored in lower triangle. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ i__2 = j;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__;
+ q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ q__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i +
+ q__2.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ i__2 = jx;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ q__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ ix = jx;
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = ix;
+ q__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ q__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ q__1.r = a[i__4].r + q__2.r, q__1.i = a[i__4].i +
+ q__2.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ ix += *incx;
+/* L70: */
+ }
+ }
+ jx += *incx;
+/* L80: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CSYR */
+
+} /* csyr_ */
diff --git a/SRC/csyrfs.c b/SRC/csyrfs.c
new file mode 100644
index 0000000..730bd46
--- /dev/null
+++ b/SRC/csyrfs.c
@@ -0,0 +1,473 @@
+/* csyrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int csyrfs_(char *uplo, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex *
+ b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr,
+ complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ real s, xk;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ integer count;
+ logical upper;
+ extern /* Subroutine */ int csymv_(char *, integer *, complex *, complex *
+, integer *, complex *, integer *, complex *, complex *, integer *
+), clacn2_(integer *, complex *, complex *, real *,
+ integer *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real lstres;
+ extern /* Subroutine */ int csytrs_(char *, integer *, integer *, complex
+ *, integer *, integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSYRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric indefinite, and */
+/* provides error bounds and backward error estimates for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular part */
+/* of the matrix A, and the strictly lower triangular part of A */
+/* is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of A contains the lower triangular part of */
+/* the matrix A, and the strictly upper triangular part of A is */
+/* not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The factored form of the matrix A. AF contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor U or L from the factorization A = U*D*U**T or */
+/* A = L*D*L**T as computed by CSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CSYTRF. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by CSYTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldx < max(1,*n)) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CSYRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.f;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ ccopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ q__1.r = -1.f, q__1.i = -0.f;
+ csymv_(uplo, n, &q__1, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, &
+ c_b1, &work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[
+ i__ + j * b_dim1]), dabs(r__2));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j
+ * x_dim1]), dabs(r__2));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + k * a_dim1]), dabs(r__2))) * xk;
+ i__4 = i__ + k * a_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ i__ + k * a_dim1]), dabs(r__2))) * ((r__3 = x[
+ i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[i__ + j *
+ x_dim1]), dabs(r__4)));
+/* L40: */
+ }
+ i__3 = k + k * a_dim1;
+ rwork[k] = rwork[k] + ((r__1 = a[i__3].r, dabs(r__1)) + (r__2
+ = r_imag(&a[k + k * a_dim1]), dabs(r__2))) * xk + s;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j
+ * x_dim1]), dabs(r__2));
+ i__3 = k + k * a_dim1;
+ rwork[k] += ((r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[k + k * a_dim1]), dabs(r__2))) * xk;
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + k * a_dim1]), dabs(r__2))) * xk;
+ i__4 = i__ + k * a_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ i__ + k * a_dim1]), dabs(r__2))) * ((r__3 = x[
+ i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[i__ + j *
+ x_dim1]), dabs(r__4)));
+/* L60: */
+ }
+ rwork[k] += s;
+/* L70: */
+ }
+ }
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__3 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
+ s = dmax(r__3,r__4);
+ } else {
+/* Computing MAX */
+ i__3 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = dmax(r__3,r__4);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ csytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[1],
+ n, info);
+ caxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use CLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__3 = i__;
+ rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__];
+ } else {
+ i__3 = i__;
+ rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__] + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ csytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L120: */
+ }
+ csytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * x_dim1;
+ r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + j * x_dim1]), dabs(r__2));
+ lstres = dmax(r__3,r__4);
+/* L130: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of CSYRFS */
+
+} /* csyrfs_ */
diff --git a/SRC/csyrfsx.c b/SRC/csyrfsx.c
new file mode 100644
index 0000000..7331e39
--- /dev/null
+++ b/SRC/csyrfsx.c
@@ -0,0 +1,627 @@
+/* csyrfsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int csyrfsx_(char *uplo, char *equed, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *
+ ipiv, real *s, complex *b, integer *ldb, complex *x, integer *ldx,
+ real *rcond, real *berr, integer *n_err_bnds__, real *err_bnds_norm__,
+ real *err_bnds_comp__, integer *nparams, real *params, complex *work,
+ real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real illrcond_thresh__, unstable_thresh__, err_lbnd__;
+ integer ref_type__;
+ integer j;
+ real rcond_tmp__;
+ integer prec_type__;
+ real cwise_wrong__;
+ extern /* Subroutine */ int cla_syrfsx_extended__(integer *, char *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ integer *, logical *, real *, complex *, integer *, complex *,
+ integer *, real *, integer *, real *, real *, complex *, real *,
+ complex *, complex *, real *, integer *, real *, real *, logical *
+ , integer *, ftnlen);
+ char norm[1];
+ logical ignore_cwise__;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ logical rcequ;
+ extern doublereal cla_syrcond_c__(char *, integer *, complex *, integer *,
+ complex *, integer *, integer *, real *, logical *, integer *,
+ complex *, real *, ftnlen), cla_syrcond_x__(char *, integer *,
+ complex *, integer *, complex *, integer *, integer *, complex *,
+ integer *, complex *, real *, ftnlen), slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
+ real *);
+ extern /* Subroutine */ int csycon_(char *, integer *, complex *, integer
+ *, integer *, real *, real *, complex *, integer *);
+ extern integer ilaprec_(char *);
+ integer ithresh, n_norms__;
+ real rthresh;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSYRFSX improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric indefinite, and */
+/* provides error bounds and backward error estimates for the */
+/* solution. In addition to normwise error bound, the code provides */
+/* maximum componentwise error bound if possible. See comments for */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds. */
+
+/* The original system of linear equations may have been equilibrated */
+/* before calling this routine, as described by arguments EQUED and S */
+/* below. In this case, the solution and error bounds returned are */
+/* for the original unequilibrated system. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* EQUED (input) CHARACTER*1 */
+/* Specifies the form of equilibration that was done to A */
+/* before calling this routine. This is needed to compute */
+/* the solution and error bounds correctly. */
+/* = 'N': No equilibration */
+/* = 'Y': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(S) * A * diag(S). */
+/* The right hand side B has been changed accordingly. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular */
+/* part of the matrix A, and the strictly lower triangular */
+/* part of A is not referenced. If UPLO = 'L', the leading */
+/* N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX array, dimension (LDAF,N) */
+/* The factored form of the matrix A. AF contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor U or L from the factorization A = U*D*U**T or A = */
+/* L*D*L**T as computed by SSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by SSYTRF. */
+
+/* S (input or output) REAL array, dimension (N) */
+/* The scale factors for A. If EQUED = 'Y', A is multiplied on */
+/* the left and right by diag(S). S is an input argument if FACT = */
+/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
+/* = 'Y', each element of S must be positive. If S is output, each */
+/* element of S is a power of the radix. If S is input, each element */
+/* of S should be a power of the radix to ensure a reliable solution */
+/* and error estimates. Scaling by powers of the radix does not cause */
+/* rounding errors unless the result underflows or overflows. */
+/* Rounding errors during scaling lead to refining with a matrix that */
+/* is not equivalent to the input matrix, producing error estimates */
+/* that may not be reliable. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by SGETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) REAL array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check the input parameters. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ ref_type__ = 1;
+ if (*nparams >= 1) {
+ if (params[1] < 0.f) {
+ params[1] = 1.f;
+ } else {
+ ref_type__ = params[1];
+ }
+ }
+
+/* Set default parameters. */
+
+ illrcond_thresh__ = (real) (*n) * slamch_("Epsilon");
+ ithresh = 10;
+ rthresh = .5f;
+ unstable_thresh__ = .25f;
+ ignore_cwise__ = FALSE_;
+
+ if (*nparams >= 2) {
+ if (params[2] < 0.f) {
+ params[2] = (real) ithresh;
+ } else {
+ ithresh = (integer) params[2];
+ }
+ }
+ if (*nparams >= 3) {
+ if (params[3] < 0.f) {
+ if (ignore_cwise__) {
+ params[3] = 0.f;
+ } else {
+ params[3] = 1.f;
+ }
+ } else {
+ ignore_cwise__ = params[3] == 0.f;
+ }
+ }
+ if (ref_type__ == 0 || *n_err_bnds__ == 0) {
+ n_norms__ = 0;
+ } else if (ignore_cwise__) {
+ n_norms__ = 1;
+ } else {
+ n_norms__ = 2;
+ }
+
+ rcequ = lsame_(equed, "Y");
+
+/* Test input parameters. */
+
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! rcequ && ! lsame_(equed, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -11;
+ } else if (*ldx < max(1,*n)) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CSYRFSX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *nrhs == 0) {
+ *rcond = 1.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 0.f;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.f;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.f;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.f;
+ }
+ }
+ return 0;
+ }
+
+/* Default to failure. */
+
+ *rcond = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 1.f;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.f;
+ }
+ }
+
+/* Compute the norm of A and the reciprocal of the condition */
+/* number of A. */
+
+ *(unsigned char *)norm = 'I';
+ anorm = clansy_(norm, uplo, n, &a[a_offset], lda, &rwork[1]);
+ csycon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1],
+ info);
+
+/* Perform refinement on each right-hand side */
+
+ if (ref_type__ != 0) {
+ prec_type__ = ilaprec_("D");
+ cla_syrfsx_extended__(&prec_type__, uplo, n, nrhs, &a[a_offset], lda,
+ &af[af_offset], ldaf, &ipiv[1], &rcequ, &s[1], &b[b_offset],
+ ldb, &x[x_offset], ldx, &berr[1], &n_norms__, &
+ err_bnds_norm__[err_bnds_norm_offset], &err_bnds_comp__[
+ err_bnds_comp_offset], &work[1], &rwork[1], &work[*n + 1],
+ (complex *)(&rwork[1]), rcond, &ithresh, &rthresh, &unstable_thresh__, &
+ ignore_cwise__, info, (ftnlen)1);
+ }
+/* Computing MAX */
+ r__1 = 10.f, r__2 = sqrt((real) (*n));
+ err_lbnd__ = dmax(r__1,r__2) * slamch_("Epsilon");
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {
+
+/* Compute scaled normwise condition number cond(A*C). */
+
+ if (rcequ) {
+ rcond_tmp__ = cla_syrcond_c__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &s[1], &c_true, info, &work[1]
+ , &rwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = cla_syrcond_c__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &s[1], &c_false, info, &work[
+ 1], &rwork[1], (ftnlen)1);
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1
+ << 1)] > 1.f) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 0.f;
+ if (*info <= *n) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {
+
+/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
+/* each right-hand side using the current solution as an estimate of */
+/* the true solution. If the componentwise error estimate is too */
+/* large, then the solution is a lousy estimate of truth and the */
+/* estimated RCOND may be too optimistic. To avoid misleading users, */
+/* the inverse condition number is set to 0.0 when the estimated */
+/* cwise error is at least CWISE_WRONG. */
+
+ cwise_wrong__ = sqrt(slamch_("Epsilon"));
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ cwise_wrong__) {
+ rcond_tmp__ = cla_syrcond_x__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &x[j * x_dim1 + 1], info,
+ &work[1], &rwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = 0.f;
+ }
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1
+ << 1)] > 1.f) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 0.f;
+ if (params[3] == 1.f && *info < *n + j) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CSYRFSX */
+
+} /* csyrfsx_ */
diff --git a/SRC/csysv.c b/SRC/csysv.c
new file mode 100644
index 0000000..c5e682d
--- /dev/null
+++ b/SRC/csysv.c
@@ -0,0 +1,214 @@
+/* csysv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int csysv_(char *uplo, integer *n, integer *nrhs, complex *a,
+ integer *lda, integer *ipiv, complex *b, integer *ldb, complex *work,
+ integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ integer nb;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int csytrf_(char *, integer *, complex *, integer
+ *, integer *, complex *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int csytrs_(char *, integer *, integer *, complex
+ *, integer *, integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSYSV 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 diagonal pivoting method is used to factor A as */
+/* A = U * D * U**T, if UPLO = 'U', or */
+/* A = L * D * L**T, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then */
+/* used to solve the system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the block diagonal matrix D and the */
+/* multipliers used to obtain the factor U or L from the */
+/* factorization A = U*D*U**T or A = L*D*L**T as computed by */
+/* CSYTRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D, as */
+/* determined by CSYTRF. If IPIV(k) > 0, then rows and columns */
+/* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 */
+/* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, */
+/* then rows and columns k-1 and -IPIV(k) were interchanged and */
+/* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and */
+/* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and */
+/* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 */
+/* diagonal block. */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK >= 1, and for best performance */
+/* LWORK >= max(1,N*NB), where NB is the optimal blocksize for */
+/* CSYTRF. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */
+/* has been completed, but the block diagonal matrix D is */
+/* exactly singular, so the solution could not be computed. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*lwork < 1 && ! lquery) {
+ *info = -10;
+ }
+
+ if (*info == 0) {
+ if (*n == 0) {
+ lwkopt = 1;
+ } else {
+ nb = ilaenv_(&c__1, "CSYTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CSYSV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ csytrf_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], lwork, info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ csytrs_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], ldb,
+ info);
+
+ }
+
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CSYSV */
+
+} /* csysv_ */
diff --git a/SRC/csysvx.c b/SRC/csysvx.c
new file mode 100644
index 0000000..233fa11
--- /dev/null
+++ b/SRC/csysvx.c
@@ -0,0 +1,368 @@
+/* csysvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int csysvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *
+ ipiv, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond,
+ real *ferr, real *berr, complex *work, integer *lwork, real *rwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2;
+
+ /* Local variables */
+ integer nb;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern doublereal slamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), xerbla_(char *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
+ real *);
+ extern /* Subroutine */ int csycon_(char *, integer *, complex *, integer
+ *, integer *, real *, real *, complex *, integer *),
+ csyrfs_(char *, integer *, integer *, complex *, integer *,
+ complex *, integer *, integer *, complex *, integer *, complex *,
+ integer *, real *, real *, complex *, real *, integer *),
+ csytrf_(char *, integer *, complex *, integer *, integer *,
+ complex *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int csytrs_(char *, integer *, integer *, complex
+ *, integer *, integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSYSVX uses the diagonal pivoting factorization to compute the */
+/* solution to a complex system of linear equations A * X = B, */
+/* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */
+/* matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'N', the diagonal pivoting method is used to factor A. */
+/* The form of the factorization is */
+/* A = U * D * U**T, if UPLO = 'U', or */
+/* A = L * D * L**T, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* 2. If some D(i,i)=0, so that D is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 3. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 4. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of A has been */
+/* supplied on entry. */
+/* = 'F': On entry, AF and IPIV contain the factored form */
+/* of A. A, AF and IPIV will not be modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular part */
+/* of the matrix A, and the strictly lower triangular part of A */
+/* is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of A contains the lower triangular part of */
+/* the matrix A, and the strictly upper triangular part of A is */
+/* not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) COMPLEX array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**T or A = L*D*L**T as computed by CSYTRF. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**T or A = L*D*L**T. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by CSYTRF. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by CSYTRF. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A. If RCOND is less than the machine precision (in */
+/* particular, if RCOND = 0), the matrix is singular to working */
+/* precision. This condition is indicated by a return code of */
+/* INFO > 0. */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK >= max(1,2*N), and for best */
+/* performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where */
+/* NB is the optimal blocksize for CSYTRF. */
+
+/* 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. */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: D(i,i) is exactly zero. The factorization */
+/* has been completed but the factor D is exactly */
+/* singular, so the solution and error bounds could */
+/* not be computed. RCOND = 0 is returned. */
+/* = N+1: D is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ lquery = *lwork == -1;
+ if (! nofact && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -11;
+ } else if (*ldx < max(1,*n)) {
+ *info = -13;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n << 1;
+ if (*lwork < max(i__1,i__2) && ! lquery) {
+ *info = -18;
+ }
+ }
+
+ if (*info == 0) {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n << 1;
+ lwkopt = max(i__1,i__2);
+ if (nofact) {
+ nb = ilaenv_(&c__1, "CSYTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = *n * nb;
+ lwkopt = max(i__1,i__2);
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CSYSVX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+ if (nofact) {
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ clacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ csytrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], lwork,
+ info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.f;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = clansy_("I", uplo, n, &a[a_offset], lda, &rwork[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ csycon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1],
+ info);
+
+/* Compute the solution vectors X. */
+
+ clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ csytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solutions and */
+/* compute error bounds and backward error estimates for them. */
+
+ csyrfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1],
+ &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1]
+, &rwork[1], info);
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < slamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CSYSVX */
+
+} /* csysvx_ */
diff --git a/SRC/csysvxx.c b/SRC/csysvxx.c
new file mode 100644
index 0000000..2863ad5
--- /dev/null
+++ b/SRC/csysvxx.c
@@ -0,0 +1,631 @@
+/* csysvxx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int csysvxx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *
+ ipiv, char *equed, real *s, complex *b, integer *ldb, complex *x,
+ integer *ldx, real *rcond, real *rpvgrw, real *berr, integer *
+ n_err_bnds__, real *err_bnds_norm__, real *err_bnds_comp__, integer *
+ nparams, real *params, complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j;
+ real amax, smin, smax;
+ extern doublereal cla_syrpvgrw__(char *, integer *, integer *, complex *,
+ integer *, complex *, integer *, integer *, real *, ftnlen);
+ extern logical lsame_(char *, char *);
+ real scond;
+ logical equil, rcequ;
+ extern doublereal slamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), xerbla_(char *,
+ integer *);
+ real bignum;
+ integer infequ;
+ extern /* Subroutine */ int claqsy_(char *, integer *, complex *, integer
+ *, real *, real *, real *, char *), csytrf_(char *
+, integer *, complex *, integer *, integer *, complex *, integer *
+, integer *);
+ real smlnum;
+ extern /* Subroutine */ int clascl2_(integer *, integer *, real *,
+ complex *, integer *), csytrs_(char *, integer *, integer *,
+ complex *, integer *, integer *, complex *, integer *, integer *), csyequb_(char *, integer *, complex *, integer *, real *,
+ real *, real *, complex *, integer *), csyrfsx_(char *,
+ char *, integer *, integer *, complex *, integer *, complex *,
+ integer *, integer *, real *, complex *, integer *, complex *,
+ integer *, real *, real *, integer *, real *, real *, integer *,
+ real *, complex *, real *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSYSVXX uses the diagonal pivoting factorization to compute the */
+/* solution to a complex system of linear equations A * X = B, where */
+/* A is an N-by-N symmetric matrix and X and B are N-by-NRHS */
+/* matrices. */
+
+/* If requested, both normwise and maximum componentwise error bounds */
+/* are returned. CSYSVXX will return a solution with a tiny */
+/* guaranteed error (O(eps) where eps is the working machine */
+/* precision) unless the matrix is very ill-conditioned, in which */
+/* case a warning is returned. Relevant condition numbers also are */
+/* calculated and returned. */
+
+/* CSYSVXX accepts user-provided factorizations and equilibration */
+/* factors; see the definitions of the FACT and EQUED options. */
+/* Solving with refinement and using a factorization from a previous */
+/* CSYSVXX call will also produce a solution with either O(eps) */
+/* errors or warnings, but we cannot make that claim for general */
+/* user-provided factorizations and equilibration factors if they */
+/* differ from what CSYSVXX would itself produce. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+
+/* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B */
+
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
+
+/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */
+/* the matrix A (after equilibration if FACT = 'E') as */
+
+/* A = U * D * U**T, if UPLO = 'U', or */
+/* A = L * D * L**T, if UPLO = 'L', */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* 3. If some D(i,i)=0, so that D is exactly singular, then the */
+/* routine returns with INFO = i. Otherwise, the factored form of A */
+/* is used to estimate the condition number of the matrix A (see */
+/* argument RCOND). If the reciprocal of the condition number is */
+/* less than machine precision, the routine still goes on to solve */
+/* for X and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */
+/* the routine will use iterative refinement to try to get a small */
+/* error and error bounds. Refinement calculates the residual to at */
+/* least twice the working precision. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(R) so that it solves the original system before */
+/* equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF and IPIV contain the factored form of A. */
+/* If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by S. */
+/* A, AF, and IPIV are not modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular */
+/* part of the matrix A, and the strictly lower triangular */
+/* part of A is not referenced. If UPLO = 'L', the leading */
+/* N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
+/* diag(S)*A*diag(S). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) COMPLEX array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L from the factorization A = */
+/* U*D*U**T or A = L*D*L**T as computed by SSYTRF. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L from the factorization A = */
+/* U*D*U**T or A = L*D*L**T. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains details of the interchanges and the block */
+/* structure of D, as determined by SSYTRF. If IPIV(k) > 0, */
+/* then rows and columns k and IPIV(k) were interchanged and */
+/* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and */
+/* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and */
+/* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 */
+/* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0, */
+/* then rows and columns k+1 and -IPIV(k) were interchanged */
+/* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains details of the interchanges and the block */
+/* structure of D, as determined by SSYTRF. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'Y': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(S) * A * diag(S). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* S (input or output) REAL array, dimension (N) */
+/* The scale factors for A. If EQUED = 'Y', A is multiplied on */
+/* the left and right by diag(S). S is an input argument if FACT = */
+/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
+/* = 'Y', each element of S must be positive. If S is output, each */
+/* element of S is a power of the radix. If S is input, each element */
+/* of S should be a power of the radix to ensure a reliable solution */
+/* and error estimates. Scaling by powers of the radix does not cause */
+/* rounding errors unless the result underflows or overflows. */
+/* Rounding errors during scaling lead to refining with a matrix that */
+/* is not equivalent to the input matrix, producing error estimates */
+/* that may not be reliable. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if EQUED = 'Y', B is overwritten by diag(S)*B; */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX array, dimension (LDX,NRHS) */
+/* If INFO = 0, the N-by-NRHS solution matrix X to the original */
+/* system of equations. Note that A and B are modified on exit if */
+/* EQUED .ne. 'N', and the solution to the equilibrated system is */
+/* inv(diag(S))*X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* RPVGRW (output) REAL */
+/* Reciprocal pivot growth. On exit, this contains the reciprocal */
+/* pivot growth factor norm(A)/norm(U). The "max absolute element" */
+/* norm is used. If this is much less than 1, then the stability of */
+/* the LU factorization of the (equilibrated) matrix A could be poor. */
+/* This also means that the solution X, estimated condition numbers, */
+/* and error bounds could be unreliable. If factorization fails with */
+/* 0<INFO<=N, then this contains the reciprocal pivot growth factor */
+/* for the leading INFO columns of A. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) REAL array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rcequ = FALSE_;
+ } else {
+ rcequ = lsame_(equed, "Y");
+ }
+
+/* Default is failure. If an input parameter is wrong or */
+/* factorization fails, make everything look horrible. Only the */
+/* pivot growth is set here, the rest is initialized in CSYRFSX. */
+
+ *rpvgrw = 0.f;
+
+/* Test the input parameters. PARAMS is not tested until CSYRFSX. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (lsame_(fact, "F") && ! (rcequ || lsame_(
+ equed, "N"))) {
+ *info = -9;
+ } else {
+ if (rcequ) {
+ smin = bignum;
+ smax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = smin, r__2 = s[j];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = smax, r__2 = s[j];
+ smax = dmax(r__1,r__2);
+/* L10: */
+ }
+ if (smin <= 0.f) {
+ *info = -10;
+ } else if (*n > 0) {
+ scond = dmax(smin,smlnum) / dmin(smax,bignum);
+ } else {
+ scond = 1.f;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -12;
+ } else if (*ldx < max(1,*n)) {
+ *info = -14;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CSYSVXX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ csyequb_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, &work[1], &
+ infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ claqsy_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed);
+ rcequ = lsame_(equed, "Y");
+ }
+ }
+
+/* Scale the right hand-side. */
+
+ if (rcequ) {
+ clascl2_(n, nrhs, &s[1], &b[b_offset], ldb);
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of A. */
+
+ clacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ i__1 = max(1,*n) * 5;
+ csytrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], &i__1,
+ info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Pivot in column INFO is exactly 0 */
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ if (*n > 0) {
+ *rpvgrw = cla_syrpvgrw__(uplo, n, info, &a[a_offset], lda, &
+ af[af_offset], ldaf, &ipiv[1], &rwork[1], (ftnlen)1);
+ }
+ return 0;
+ }
+ }
+
+/* Compute the reciprocal pivot growth factor RPVGRW. */
+
+ if (*n > 0) {
+ *rpvgrw = cla_syrpvgrw__(uplo, n, info, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &rwork[1], (ftnlen)1);
+ }
+
+/* Compute the solution matrix X. */
+
+ clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ csytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ csyrfsx_(uplo, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &
+ ipiv[1], &s[1], &b[b_offset], ldb, &x[x_offset], ldx, rcond, &
+ berr[1], n_err_bnds__, &err_bnds_norm__[err_bnds_norm_offset], &
+ err_bnds_comp__[err_bnds_comp_offset], nparams, ¶ms[1], &work[
+ 1], &rwork[1], info);
+
+/* Scale solutions. */
+
+ if (rcequ) {
+ clascl2_(n, nrhs, &s[1], &x[x_offset], ldx);
+ }
+
+ return 0;
+
+/* End of CSYSVXX */
+
+} /* csysvxx_ */
diff --git a/SRC/csytf2.c b/SRC/csytf2.c
new file mode 100644
index 0000000..5d00495
--- /dev/null
+++ b/SRC/csytf2.c
@@ -0,0 +1,727 @@
+/* csytf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int csytf2_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_imag(complex *);
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ complex t, r1, d11, d12, d21, d22;
+ integer kk, kp;
+ complex wk, wkm1, wkp1;
+ integer imax, jmax;
+ extern /* Subroutine */ int csyr_(char *, integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ real alpha;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer kstep;
+ logical upper;
+ real absakk;
+ extern integer icamax_(integer *, complex *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real colmax;
+ extern logical sisnan_(real *);
+ real rowmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSYTF2 computes the factorization of a complex symmetric matrix A */
+/* using the Bunch-Kaufman diagonal pivoting method: */
+
+/* A = U*D*U' or A = L*D*L' */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, U' is the transpose of U, 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. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n-by-n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n-by-n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L (see below for further details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, D(k,k) is exactly zero. 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. */
+
+/* Further Details */
+/* =============== */
+
+/* 09-29-06 - patch from */
+/* Bobby Cheng, MathWorks */
+
+/* Replace l.209 and l.377 */
+/* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN */
+/* by */
+/* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN */
+
+/* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services */
+/* Company */
+
+/* If UPLO = 'U', then A = U*D*U', where */
+/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
+/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
+/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I v 0 ) k-s */
+/* U(k) = ( 0 I 0 ) s */
+/* ( 0 0 I ) n-k */
+/* k-s s n-k */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
+/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
+/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
+
+/* If UPLO = 'L', then A = L*D*L', where */
+/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
+/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
+/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I 0 0 ) k-1 */
+/* L(k) = ( 0 I 0 ) s */
+/* ( 0 v I ) n-k-s+1 */
+/* k-1 s n-k-s+1 */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
+/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
+/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CSYTF2", &i__1);
+ return 0;
+ }
+
+/* Initialize ALPHA for use in choosing pivot block size. */
+
+ alpha = (sqrt(17.f) + 1.f) / 8.f;
+
+ if (upper) {
+
+/* Factorize A as U*D*U' using the upper triangle of A */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2 */
+
+ k = *n;
+L10:
+
+/* If K < 1, exit from loop */
+
+ if (k < 1) {
+ goto L70;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = k + k * a_dim1;
+ absakk = (r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a[k + k *
+ a_dim1]), dabs(r__2));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ imax = icamax_(&i__1, &a[k * a_dim1 + 1], &c__1);
+ i__1 = imax + k * a_dim1;
+ colmax = (r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a[imax
+ + k * a_dim1]), dabs(r__2));
+ } else {
+ colmax = 0.f;
+ }
+
+ if (dmax(absakk,colmax) == 0.f || sisnan_(&absakk)) {
+
+/* Column K is zero or NaN: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = k - imax;
+ jmax = imax + icamax_(&i__1, &a[imax + (imax + 1) * a_dim1],
+ lda);
+ i__1 = imax + jmax * a_dim1;
+ rowmax = (r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ imax + jmax * a_dim1]), dabs(r__2));
+ if (imax > 1) {
+ i__1 = imax - 1;
+ jmax = icamax_(&i__1, &a[imax * a_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__1 = jmax + imax * a_dim1;
+ r__3 = rowmax, r__4 = (r__1 = a[i__1].r, dabs(r__1)) + (
+ r__2 = r_imag(&a[jmax + imax * a_dim1]), dabs(
+ r__2));
+ rowmax = dmax(r__3,r__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = imax + imax * a_dim1;
+ if ((r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ imax + imax * a_dim1]), dabs(r__2)) >= alpha *
+ rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k - kstep + 1;
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the leading */
+/* submatrix A(1:k,1:k) */
+
+ i__1 = kp - 1;
+ cswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1],
+ &c__1);
+ i__1 = kk - kp - 1;
+ cswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp +
+ 1) * a_dim1], lda);
+ i__1 = kk + kk * a_dim1;
+ t.r = a[i__1].r, t.i = a[i__1].i;
+ i__1 = kk + kk * a_dim1;
+ i__2 = kp + kp * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + kp * a_dim1;
+ a[i__1].r = t.r, a[i__1].i = t.i;
+ if (kstep == 2) {
+ i__1 = k - 1 + k * a_dim1;
+ t.r = a[i__1].r, t.i = a[i__1].i;
+ i__1 = k - 1 + k * a_dim1;
+ i__2 = kp + k * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + k * a_dim1;
+ a[i__1].r = t.r, a[i__1].i = t.i;
+ }
+ }
+
+/* Update the leading submatrix */
+
+ if (kstep == 1) {
+
+/* 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 */
+
+/* Perform a rank-1 update of A(1:k-1,1:k-1) as */
+
+/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */
+
+ c_div(&q__1, &c_b1, &a[k + k * a_dim1]);
+ r1.r = q__1.r, r1.i = q__1.i;
+ i__1 = k - 1;
+ q__1.r = -r1.r, q__1.i = -r1.i;
+ csyr_(uplo, &i__1, &q__1, &a[k * a_dim1 + 1], &c__1, &a[
+ a_offset], lda);
+
+/* Store U(k) in column k */
+
+ i__1 = k - 1;
+ cscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
+ } 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) )' */
+/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */
+
+ if (k > 2) {
+
+ i__1 = k - 1 + k * a_dim1;
+ d12.r = a[i__1].r, d12.i = a[i__1].i;
+ c_div(&q__1, &a[k - 1 + (k - 1) * a_dim1], &d12);
+ d22.r = q__1.r, d22.i = q__1.i;
+ c_div(&q__1, &a[k + k * a_dim1], &d12);
+ d11.r = q__1.r, d11.i = q__1.i;
+ q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r *
+ d22.i + d11.i * d22.r;
+ q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f;
+ c_div(&q__1, &c_b1, &q__2);
+ t.r = q__1.r, t.i = q__1.i;
+ c_div(&q__1, &t, &d12);
+ d12.r = q__1.r, d12.i = q__1.i;
+
+ for (j = k - 2; j >= 1; --j) {
+ i__1 = j + (k - 1) * a_dim1;
+ q__3.r = d11.r * a[i__1].r - d11.i * a[i__1].i,
+ q__3.i = d11.r * a[i__1].i + d11.i * a[i__1]
+ .r;
+ i__2 = j + k * a_dim1;
+ q__2.r = q__3.r - a[i__2].r, q__2.i = q__3.i - a[i__2]
+ .i;
+ q__1.r = d12.r * q__2.r - d12.i * q__2.i, q__1.i =
+ d12.r * q__2.i + d12.i * q__2.r;
+ wkm1.r = q__1.r, wkm1.i = q__1.i;
+ i__1 = j + k * a_dim1;
+ q__3.r = d22.r * a[i__1].r - d22.i * a[i__1].i,
+ q__3.i = d22.r * a[i__1].i + d22.i * a[i__1]
+ .r;
+ i__2 = j + (k - 1) * a_dim1;
+ q__2.r = q__3.r - a[i__2].r, q__2.i = q__3.i - a[i__2]
+ .i;
+ q__1.r = d12.r * q__2.r - d12.i * q__2.i, q__1.i =
+ d12.r * q__2.i + d12.i * q__2.r;
+ wk.r = q__1.r, wk.i = q__1.i;
+ for (i__ = j; i__ >= 1; --i__) {
+ i__1 = i__ + j * a_dim1;
+ i__2 = i__ + j * a_dim1;
+ i__3 = i__ + k * a_dim1;
+ q__3.r = a[i__3].r * wk.r - a[i__3].i * wk.i,
+ q__3.i = a[i__3].r * wk.i + a[i__3].i *
+ wk.r;
+ q__2.r = a[i__2].r - q__3.r, q__2.i = a[i__2].i -
+ q__3.i;
+ i__4 = i__ + (k - 1) * a_dim1;
+ q__4.r = a[i__4].r * wkm1.r - a[i__4].i * wkm1.i,
+ q__4.i = a[i__4].r * wkm1.i + a[i__4].i *
+ wkm1.r;
+ q__1.r = q__2.r - q__4.r, q__1.i = q__2.i -
+ q__4.i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+/* L20: */
+ }
+ i__1 = j + k * a_dim1;
+ a[i__1].r = wk.r, a[i__1].i = wk.i;
+ i__1 = j + (k - 1) * a_dim1;
+ a[i__1].r = wkm1.r, a[i__1].i = wkm1.i;
+/* L30: */
+ }
+
+ }
+
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k - 1] = -kp;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kstep;
+ goto L10;
+
+ } else {
+
+/* Factorize A as L*D*L' using the lower triangle of A */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2 */
+
+ k = 1;
+L40:
+
+/* If K > N, exit from loop */
+
+ if (k > *n) {
+ goto L70;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = k + k * a_dim1;
+ absakk = (r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a[k + k *
+ a_dim1]), dabs(r__2));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ imax = k + icamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1);
+ i__1 = imax + k * a_dim1;
+ colmax = (r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a[imax
+ + k * a_dim1]), dabs(r__2));
+ } else {
+ colmax = 0.f;
+ }
+
+ if (dmax(absakk,colmax) == 0.f || sisnan_(&absakk)) {
+
+/* Column K is zero or NaN: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = imax - k;
+ jmax = k - 1 + icamax_(&i__1, &a[imax + k * a_dim1], lda);
+ i__1 = imax + jmax * a_dim1;
+ rowmax = (r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ imax + jmax * a_dim1]), dabs(r__2));
+ if (imax < *n) {
+ i__1 = *n - imax;
+ jmax = imax + icamax_(&i__1, &a[imax + 1 + imax * a_dim1],
+ &c__1);
+/* Computing MAX */
+ i__1 = jmax + imax * a_dim1;
+ r__3 = rowmax, r__4 = (r__1 = a[i__1].r, dabs(r__1)) + (
+ r__2 = r_imag(&a[jmax + imax * a_dim1]), dabs(
+ r__2));
+ rowmax = dmax(r__3,r__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = imax + imax * a_dim1;
+ if ((r__1 = a[i__1].r, dabs(r__1)) + (r__2 = r_imag(&a[
+ imax + imax * a_dim1]), dabs(r__2)) >= alpha *
+ rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k + kstep - 1;
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the trailing */
+/* submatrix A(k:n,k:n) */
+
+ if (kp < *n) {
+ i__1 = *n - kp;
+ cswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1
+ + kp * a_dim1], &c__1);
+ }
+ i__1 = kp - kk - 1;
+ cswap_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk +
+ 1) * a_dim1], lda);
+ i__1 = kk + kk * a_dim1;
+ t.r = a[i__1].r, t.i = a[i__1].i;
+ i__1 = kk + kk * a_dim1;
+ i__2 = kp + kp * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + kp * a_dim1;
+ a[i__1].r = t.r, a[i__1].i = t.i;
+ if (kstep == 2) {
+ i__1 = k + 1 + k * a_dim1;
+ t.r = a[i__1].r, t.i = a[i__1].i;
+ i__1 = k + 1 + k * a_dim1;
+ i__2 = kp + k * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + k * a_dim1;
+ a[i__1].r = t.r, a[i__1].i = t.i;
+ }
+ }
+
+/* Update the trailing submatrix */
+
+ if (kstep == 1) {
+
+/* 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 < *n) {
+
+/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
+
+/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */
+
+ c_div(&q__1, &c_b1, &a[k + k * a_dim1]);
+ r1.r = q__1.r, r1.i = q__1.i;
+ i__1 = *n - k;
+ q__1.r = -r1.r, q__1.i = -r1.i;
+ csyr_(uplo, &i__1, &q__1, &a[k + 1 + k * a_dim1], &c__1, &
+ a[k + 1 + (k + 1) * a_dim1], lda);
+
+/* Store L(k) in column K */
+
+ i__1 = *n - k;
+ cscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1);
+ }
+ } else {
+
+/* 2-by-2 pivot block D(k) */
+
+ if (k < *n - 1) {
+
+/* 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) )' */
+/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' */
+
+/* where L(k) and L(k+1) are the k-th and (k+1)-th */
+/* columns of L */
+
+ i__1 = k + 1 + k * a_dim1;
+ d21.r = a[i__1].r, d21.i = a[i__1].i;
+ c_div(&q__1, &a[k + 1 + (k + 1) * a_dim1], &d21);
+ d11.r = q__1.r, d11.i = q__1.i;
+ c_div(&q__1, &a[k + k * a_dim1], &d21);
+ d22.r = q__1.r, d22.i = q__1.i;
+ q__3.r = d11.r * d22.r - d11.i * d22.i, q__3.i = d11.r *
+ d22.i + d11.i * d22.r;
+ q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f;
+ c_div(&q__1, &c_b1, &q__2);
+ t.r = q__1.r, t.i = q__1.i;
+ c_div(&q__1, &t, &d21);
+ d21.r = q__1.r, d21.i = q__1.i;
+
+ i__1 = *n;
+ for (j = k + 2; j <= i__1; ++j) {
+ i__2 = j + k * a_dim1;
+ q__3.r = d11.r * a[i__2].r - d11.i * a[i__2].i,
+ q__3.i = d11.r * a[i__2].i + d11.i * a[i__2]
+ .r;
+ i__3 = j + (k + 1) * a_dim1;
+ q__2.r = q__3.r - a[i__3].r, q__2.i = q__3.i - a[i__3]
+ .i;
+ q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i =
+ d21.r * q__2.i + d21.i * q__2.r;
+ wk.r = q__1.r, wk.i = q__1.i;
+ i__2 = j + (k + 1) * a_dim1;
+ q__3.r = d22.r * a[i__2].r - d22.i * a[i__2].i,
+ q__3.i = d22.r * a[i__2].i + d22.i * a[i__2]
+ .r;
+ i__3 = j + k * a_dim1;
+ q__2.r = q__3.r - a[i__3].r, q__2.i = q__3.i - a[i__3]
+ .i;
+ q__1.r = d21.r * q__2.r - d21.i * q__2.i, q__1.i =
+ d21.r * q__2.i + d21.i * q__2.r;
+ wkp1.r = q__1.r, wkp1.i = q__1.i;
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__ + k * a_dim1;
+ q__3.r = a[i__5].r * wk.r - a[i__5].i * wk.i,
+ q__3.i = a[i__5].r * wk.i + a[i__5].i *
+ wk.r;
+ q__2.r = a[i__4].r - q__3.r, q__2.i = a[i__4].i -
+ q__3.i;
+ i__6 = i__ + (k + 1) * a_dim1;
+ q__4.r = a[i__6].r * wkp1.r - a[i__6].i * wkp1.i,
+ q__4.i = a[i__6].r * wkp1.i + a[i__6].i *
+ wkp1.r;
+ q__1.r = q__2.r - q__4.r, q__1.i = q__2.i -
+ q__4.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L50: */
+ }
+ i__2 = j + k * a_dim1;
+ a[i__2].r = wk.r, a[i__2].i = wk.i;
+ i__2 = j + (k + 1) * a_dim1;
+ a[i__2].r = wkp1.r, a[i__2].i = wkp1.i;
+/* L60: */
+ }
+ }
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k + 1] = -kp;
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kstep;
+ goto L40;
+
+ }
+
+L70:
+ return 0;
+
+/* End of CSYTF2 */
+
+} /* csytf2_ */
diff --git a/SRC/csytrf.c b/SRC/csytrf.c
new file mode 100644
index 0000000..c8d2b53
--- /dev/null
+++ b/SRC/csytrf.c
@@ -0,0 +1,340 @@
+/* csytrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int csytrf_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *ipiv, complex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer j, k, kb, nb, iws;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ logical upper;
+ extern /* Subroutine */ int csytf2_(char *, integer *, complex *, integer
+ *, integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int clasyf_(char *, integer *, integer *, integer
+ *, complex *, integer *, integer *, complex *, integer *, integer
+ *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSYTRF computes the factorization of a complex symmetric matrix A */
+/* using the Bunch-Kaufman diagonal pivoting method. The form of the */
+/* factorization is */
+
+/* A = U*D*U**T or A = L*D*L**T */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is symmetric and block diagonal with */
+/* with 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* This is the blocked version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (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, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L (see below for further details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. 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. */
+
+/* Further Details */
+/* =============== */
+
+/* If UPLO = 'U', then A = U*D*U', where */
+/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
+/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
+/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I v 0 ) k-s */
+/* U(k) = ( 0 I 0 ) s */
+/* ( 0 0 I ) n-k */
+/* k-s s n-k */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
+/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
+/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
+
+/* If UPLO = 'L', then A = L*D*L', where */
+/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
+/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
+/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I 0 0 ) k-1 */
+/* L(k) = ( 0 I 0 ) s */
+/* ( 0 v I ) n-k-s+1 */
+/* k-1 s n-k-s+1 */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
+/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
+/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1;
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*lwork < 1 && ! lquery) {
+ *info = -7;
+ }
+
+ if (*info == 0) {
+
+/* Determine the block size */
+
+ nb = ilaenv_(&c__1, "CSYTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CSYTRF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = *n;
+ if (nb > 1 && nb < *n) {
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+/* Computing MAX */
+ i__1 = *lwork / ldwork;
+ nb = max(i__1,1);
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "CSYTRF", uplo, n, &c_n1, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = 1;
+ }
+ if (nb < nbmin) {
+ nb = *n;
+ }
+
+ if (upper) {
+
+/* Factorize A as U*D*U' 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; */
+/* KB is either NB or NB-1, or K for the last block */
+
+ k = *n;
+L10:
+
+/* If K < 1, exit from loop */
+
+ if (k < 1) {
+ goto L40;
+ }
+
+ if (k > nb) {
+
+/* Factorize columns k-kb+1:k of A and use blocked code to */
+/* update columns 1:k-kb */
+
+ clasyf_(uplo, &k, &nb, &kb, &a[a_offset], lda, &ipiv[1], &work[1],
+ n, &iinfo);
+ } else {
+
+/* Use unblocked code to factorize columns 1:k of A */
+
+ csytf2_(uplo, &k, &a[a_offset], lda, &ipiv[1], &iinfo);
+ kb = k;
+ }
+
+/* Set INFO on the first occurrence of a zero pivot */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kb;
+ goto L10;
+
+ } else {
+
+/* Factorize A as L*D*L' 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; */
+/* KB is either NB or NB-1, or N-K+1 for the last block */
+
+ k = 1;
+L20:
+
+/* If K > N, exit from loop */
+
+ if (k > *n) {
+ goto L40;
+ }
+
+ if (k <= *n - nb) {
+
+/* Factorize columns k:k+kb-1 of A and use blocked code to */
+/* update columns k+kb:n */
+
+ i__1 = *n - k + 1;
+ clasyf_(uplo, &i__1, &nb, &kb, &a[k + k * a_dim1], lda, &ipiv[k],
+ &work[1], n, &iinfo);
+ } else {
+
+/* Use unblocked code to factorize columns k:n of A */
+
+ i__1 = *n - k + 1;
+ csytf2_(uplo, &i__1, &a[k + k * a_dim1], lda, &ipiv[k], &iinfo);
+ kb = *n - k + 1;
+ }
+
+/* Set INFO on the first occurrence of a zero pivot */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo + k - 1;
+ }
+
+/* Adjust IPIV */
+
+ i__1 = k + kb - 1;
+ for (j = k; j <= i__1; ++j) {
+ if (ipiv[j] > 0) {
+ ipiv[j] = ipiv[j] + k - 1;
+ } else {
+ ipiv[j] = ipiv[j] - k + 1;
+ }
+/* L30: */
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kb;
+ goto L20;
+
+ }
+
+L40:
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ return 0;
+
+/* End of CSYTRF */
+
+} /* csytrf_ */
diff --git a/SRC/csytri.c b/SRC/csytri.c
new file mode 100644
index 0000000..a35945d
--- /dev/null
+++ b/SRC/csytri.c
@@ -0,0 +1,489 @@
+/* csytri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static complex c_b2 = {0.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int csytri_(char *uplo, integer *n, complex *a, integer *lda,
+ integer *ipiv, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ complex d__;
+ integer k;
+ complex t, ak;
+ integer kp;
+ complex akp1, temp, akkp1;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer kstep;
+ logical upper;
+ extern /* Subroutine */ int csymv_(char *, integer *, complex *, complex *
+, integer *, complex *, integer *, complex *, complex *, integer *
+), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSYTRI computes the inverse of a complex symmetric indefinite matrix */
+/* A using the factorization A = U*D*U**T or A = L*D*L**T computed by */
+/* CSYTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L as computed by CSYTRF. */
+
+/* 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. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CSYTRF. */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* INFO (output) 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. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CSYTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ for (*info = *n; *info >= 1; --(*info)) {
+ i__1 = *info + *info * a_dim1;
+ if (ipiv[*info] > 0 && (a[i__1].r == 0.f && a[i__1].i == 0.f)) {
+ return 0;
+ }
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ i__2 = *info + *info * a_dim1;
+ if (ipiv[*info] > 0 && (a[i__2].r == 0.f && a[i__2].i == 0.f)) {
+ return 0;
+ }
+/* L20: */
+ }
+ }
+ *info = 0;
+
+ if (upper) {
+
+/* Compute inv(A) from the factorization A = U*D*U'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+L30:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L40;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = k + k * a_dim1;
+ c_div(&q__1, &c_b1, &a[k + k * a_dim1]);
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+
+/* Compute column K of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ ccopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ csymv_(uplo, &i__1, &q__1, &a[a_offset], lda, &work[1], &c__1,
+ &c_b2, &a[k * a_dim1 + 1], &c__1);
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ i__3 = k - 1;
+ cdotu_(&q__2, &i__3, &work[1], &c__1, &a[k * a_dim1 + 1], &
+ c__1);
+ q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = k + (k + 1) * a_dim1;
+ t.r = a[i__1].r, t.i = a[i__1].i;
+ c_div(&q__1, &a[k + k * a_dim1], &t);
+ ak.r = q__1.r, ak.i = q__1.i;
+ c_div(&q__1, &a[k + 1 + (k + 1) * a_dim1], &t);
+ akp1.r = q__1.r, akp1.i = q__1.i;
+ c_div(&q__1, &a[k + (k + 1) * a_dim1], &t);
+ akkp1.r = q__1.r, akkp1.i = q__1.i;
+ q__3.r = ak.r * akp1.r - ak.i * akp1.i, q__3.i = ak.r * akp1.i +
+ ak.i * akp1.r;
+ q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f;
+ q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i
+ * q__2.r;
+ d__.r = q__1.r, d__.i = q__1.i;
+ i__1 = k + k * a_dim1;
+ c_div(&q__1, &akp1, &d__);
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ c_div(&q__1, &ak, &d__);
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = k + (k + 1) * a_dim1;
+ q__2.r = -akkp1.r, q__2.i = -akkp1.i;
+ c_div(&q__1, &q__2, &d__);
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+
+/* Compute columns K and K+1 of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ ccopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ csymv_(uplo, &i__1, &q__1, &a[a_offset], lda, &work[1], &c__1,
+ &c_b2, &a[k * a_dim1 + 1], &c__1);
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ i__3 = k - 1;
+ cdotu_(&q__2, &i__3, &work[1], &c__1, &a[k * a_dim1 + 1], &
+ c__1);
+ q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = k + (k + 1) * a_dim1;
+ i__2 = k + (k + 1) * a_dim1;
+ i__3 = k - 1;
+ cdotu_(&q__2, &i__3, &a[k * a_dim1 + 1], &c__1, &a[(k + 1) *
+ a_dim1 + 1], &c__1);
+ q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = k - 1;
+ ccopy_(&i__1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], &
+ c__1);
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ csymv_(uplo, &i__1, &q__1, &a[a_offset], lda, &work[1], &c__1,
+ &c_b2, &a[(k + 1) * a_dim1 + 1], &c__1);
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ i__2 = k + 1 + (k + 1) * a_dim1;
+ i__3 = k - 1;
+ cdotu_(&q__2, &i__3, &work[1], &c__1, &a[(k + 1) * a_dim1 + 1]
+, &c__1);
+ q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ }
+ kstep = 2;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the leading */
+/* submatrix A(1:k+1,1:k+1) */
+
+ i__1 = kp - 1;
+ cswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &
+ c__1);
+ i__1 = k - kp - 1;
+ cswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1) *
+ a_dim1], lda);
+ i__1 = k + k * a_dim1;
+ temp.r = a[i__1].r, temp.i = a[i__1].i;
+ i__1 = k + k * a_dim1;
+ i__2 = kp + kp * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + kp * a_dim1;
+ a[i__1].r = temp.r, a[i__1].i = temp.i;
+ if (kstep == 2) {
+ i__1 = k + (k + 1) * a_dim1;
+ temp.r = a[i__1].r, temp.i = a[i__1].i;
+ i__1 = k + (k + 1) * a_dim1;
+ i__2 = kp + (k + 1) * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + (k + 1) * a_dim1;
+ a[i__1].r = temp.r, a[i__1].i = temp.i;
+ }
+ }
+
+ k += kstep;
+ goto L30;
+L40:
+
+ ;
+ } else {
+
+/* Compute inv(A) from the factorization A = L*D*L'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+L50:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L60;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = k + k * a_dim1;
+ c_div(&q__1, &c_b1, &a[k + k * a_dim1]);
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+
+/* Compute column K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ ccopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ csymv_(uplo, &i__1, &q__1, &a[k + 1 + (k + 1) * a_dim1], lda,
+ &work[1], &c__1, &c_b2, &a[k + 1 + k * a_dim1], &c__1);
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ i__3 = *n - k;
+ cdotu_(&q__2, &i__3, &work[1], &c__1, &a[k + 1 + k * a_dim1],
+ &c__1);
+ q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = k + (k - 1) * a_dim1;
+ t.r = a[i__1].r, t.i = a[i__1].i;
+ c_div(&q__1, &a[k - 1 + (k - 1) * a_dim1], &t);
+ ak.r = q__1.r, ak.i = q__1.i;
+ c_div(&q__1, &a[k + k * a_dim1], &t);
+ akp1.r = q__1.r, akp1.i = q__1.i;
+ c_div(&q__1, &a[k + (k - 1) * a_dim1], &t);
+ akkp1.r = q__1.r, akkp1.i = q__1.i;
+ q__3.r = ak.r * akp1.r - ak.i * akp1.i, q__3.i = ak.r * akp1.i +
+ ak.i * akp1.r;
+ q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f;
+ q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i
+ * q__2.r;
+ d__.r = q__1.r, d__.i = q__1.i;
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ c_div(&q__1, &akp1, &d__);
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = k + k * a_dim1;
+ c_div(&q__1, &ak, &d__);
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = k + (k - 1) * a_dim1;
+ q__2.r = -akkp1.r, q__2.i = -akkp1.i;
+ c_div(&q__1, &q__2, &d__);
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+
+/* Compute columns K-1 and K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ ccopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ csymv_(uplo, &i__1, &q__1, &a[k + 1 + (k + 1) * a_dim1], lda,
+ &work[1], &c__1, &c_b2, &a[k + 1 + k * a_dim1], &c__1);
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ i__3 = *n - k;
+ cdotu_(&q__2, &i__3, &work[1], &c__1, &a[k + 1 + k * a_dim1],
+ &c__1);
+ q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = k + (k - 1) * a_dim1;
+ i__2 = k + (k - 1) * a_dim1;
+ i__3 = *n - k;
+ cdotu_(&q__2, &i__3, &a[k + 1 + k * a_dim1], &c__1, &a[k + 1
+ + (k - 1) * a_dim1], &c__1);
+ q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = *n - k;
+ ccopy_(&i__1, &a[k + 1 + (k - 1) * a_dim1], &c__1, &work[1], &
+ c__1);
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ csymv_(uplo, &i__1, &q__1, &a[k + 1 + (k + 1) * a_dim1], lda,
+ &work[1], &c__1, &c_b2, &a[k + 1 + (k - 1) * a_dim1],
+ &c__1);
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ i__2 = k - 1 + (k - 1) * a_dim1;
+ i__3 = *n - k;
+ cdotu_(&q__2, &i__3, &work[1], &c__1, &a[k + 1 + (k - 1) *
+ a_dim1], &c__1);
+ q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ }
+ kstep = 2;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the trailing */
+/* submatrix A(k-1:n,k-1:n) */
+
+ if (kp < *n) {
+ i__1 = *n - kp;
+ cswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + kp *
+ a_dim1], &c__1);
+ }
+ i__1 = kp - k - 1;
+ cswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) *
+ a_dim1], lda);
+ i__1 = k + k * a_dim1;
+ temp.r = a[i__1].r, temp.i = a[i__1].i;
+ i__1 = k + k * a_dim1;
+ i__2 = kp + kp * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + kp * a_dim1;
+ a[i__1].r = temp.r, a[i__1].i = temp.i;
+ if (kstep == 2) {
+ i__1 = k + (k - 1) * a_dim1;
+ temp.r = a[i__1].r, temp.i = a[i__1].i;
+ i__1 = k + (k - 1) * a_dim1;
+ i__2 = kp + (k - 1) * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + (k - 1) * a_dim1;
+ a[i__1].r = temp.r, a[i__1].i = temp.i;
+ }
+ }
+
+ k -= kstep;
+ goto L50;
+L60:
+ ;
+ }
+
+ return 0;
+
+/* End of CSYTRI */
+
+} /* csytri_ */
diff --git a/SRC/csytrs.c b/SRC/csytrs.c
new file mode 100644
index 0000000..50a2488
--- /dev/null
+++ b/SRC/csytrs.c
@@ -0,0 +1,502 @@
+/* csytrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int csytrs_(char *uplo, integer *n, integer *nrhs, complex *
+ a, integer *lda, integer *ipiv, complex *b, integer *ldb, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer j, k;
+ complex ak, bk;
+ integer kp;
+ complex akm1, bkm1, akm1k;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ complex denom;
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *), cgeru_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *),
+ cswap_(integer *, complex *, integer *, complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSYTRS solves a system of linear equations A*X = B with a complex */
+/* symmetric matrix A using the factorization A = U*D*U**T or */
+/* A = L*D*L**T computed by CSYTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by CSYTRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CSYTRF. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CSYTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B, where A = U*D*U'. */
+
+/* First solve U*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+L10:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L30;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &a[k * a_dim1 + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ c_div(&q__1, &c_b1, &a[k + k * a_dim1]);
+ cscal_(nrhs, &q__1, &b[k + b_dim1], ldb);
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K-1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k - 1) {
+ cswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ i__1 = k - 2;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &a[k * a_dim1 + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+ i__1 = k - 2;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &a[(k - 1) * a_dim1 + 1], &c__1, &b[k
+ - 1 + b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = k - 1 + k * a_dim1;
+ akm1k.r = a[i__1].r, akm1k.i = a[i__1].i;
+ c_div(&q__1, &a[k - 1 + (k - 1) * a_dim1], &akm1k);
+ akm1.r = q__1.r, akm1.i = q__1.i;
+ c_div(&q__1, &a[k + k * a_dim1], &akm1k);
+ ak.r = q__1.r, ak.i = q__1.i;
+ q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i +
+ akm1.i * ak.r;
+ q__1.r = q__2.r - 1.f, q__1.i = q__2.i - 0.f;
+ denom.r = q__1.r, denom.i = q__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ c_div(&q__1, &b[k - 1 + j * b_dim1], &akm1k);
+ bkm1.r = q__1.r, bkm1.i = q__1.i;
+ c_div(&q__1, &b[k + j * b_dim1], &akm1k);
+ bk.r = q__1.r, bk.i = q__1.i;
+ i__2 = k - 1 + j * b_dim1;
+ q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r *
+ bkm1.i + ak.i * bkm1.r;
+ q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
+ c_div(&q__1, &q__2, &denom);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + j * b_dim1;
+ q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r *
+ bk.i + akm1.i * bk.r;
+ q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
+ c_div(&q__1, &q__2, &denom);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L20: */
+ }
+ k += -2;
+ }
+
+ goto L10;
+L30:
+
+/* Next solve U'*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+L40:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L50;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(U'(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &a[k *
+ a_dim1 + 1], &c__1, &c_b1, &b[k + b_dim1], ldb)
+ ;
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &a[k *
+ a_dim1 + 1], &c__1, &c_b1, &b[k + b_dim1], ldb)
+ ;
+ i__1 = k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &a[(k
+ + 1) * a_dim1 + 1], &c__1, &c_b1, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ k += 2;
+ }
+
+ goto L40;
+L50:
+
+ ;
+ } else {
+
+/* Solve A*X = B, where A = L*D*L'. */
+
+/* First solve L*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+L60:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L80;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &a[k + 1 + k * a_dim1], &c__1, &b[
+ k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ c_div(&q__1, &c_b1, &a[k + k * a_dim1]);
+ cscal_(nrhs, &q__1, &b[k + b_dim1], ldb);
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K+1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k + 1) {
+ cswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ if (k < *n - 1) {
+ i__1 = *n - k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &a[k + 2 + k * a_dim1], &c__1, &b[
+ k + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgeru_(&i__1, nrhs, &q__1, &a[k + 2 + (k + 1) * a_dim1], &
+ c__1, &b[k + 1 + b_dim1], ldb, &b[k + 2 + b_dim1],
+ ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = k + 1 + k * a_dim1;
+ akm1k.r = a[i__1].r, akm1k.i = a[i__1].i;
+ c_div(&q__1, &a[k + k * a_dim1], &akm1k);
+ akm1.r = q__1.r, akm1.i = q__1.i;
+ c_div(&q__1, &a[k + 1 + (k + 1) * a_dim1], &akm1k);
+ ak.r = q__1.r, ak.i = q__1.i;
+ q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i +
+ akm1.i * ak.r;
+ q__1.r = q__2.r - 1.f, q__1.i = q__2.i - 0.f;
+ denom.r = q__1.r, denom.i = q__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ c_div(&q__1, &b[k + j * b_dim1], &akm1k);
+ bkm1.r = q__1.r, bkm1.i = q__1.i;
+ c_div(&q__1, &b[k + 1 + j * b_dim1], &akm1k);
+ bk.r = q__1.r, bk.i = q__1.i;
+ i__2 = k + j * b_dim1;
+ q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r *
+ bkm1.i + ak.i * bkm1.r;
+ q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
+ c_div(&q__1, &q__2, &denom);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r *
+ bk.i + akm1.i * bk.r;
+ q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
+ c_div(&q__1, &q__2, &denom);
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L70: */
+ }
+ k += 2;
+ }
+
+ goto L60;
+L80:
+
+/* Next solve L'*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+L90:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L100;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(L'(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Transpose", &i__1, nrhs, &q__1, &b[k + 1 + b_dim1],
+ ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, &b[k +
+ b_dim1], ldb);
+ }
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Transpose", &i__1, nrhs, &q__1, &b[k + 1 + b_dim1],
+ ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, &b[k +
+ b_dim1], ldb);
+ i__1 = *n - k;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemv_("Transpose", &i__1, nrhs, &q__1, &b[k + 1 + b_dim1],
+ ldb, &a[k + 1 + (k - 1) * a_dim1], &c__1, &c_b1, &b[k
+ - 1 + b_dim1], ldb);
+ }
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ k += -2;
+ }
+
+ goto L90;
+L100:
+ ;
+ }
+
+ return 0;
+
+/* End of CSYTRS */
+
+} /* csytrs_ */
diff --git a/SRC/ctbcon.c b/SRC/ctbcon.c
new file mode 100644
index 0000000..014bac5
--- /dev/null
+++ b/SRC/ctbcon.c
@@ -0,0 +1,255 @@
+/* ctbcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ctbcon_(char *norm, char *uplo, char *diag, integer *n,
+ integer *kd, complex *ab, integer *ldab, real *rcond, complex *work,
+ real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer ix, kase, kase1;
+ real scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ real anorm;
+ logical upper;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *);
+ real xnorm;
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal clantb_(char *, char *, char *, integer *, integer *,
+ complex *, integer *, real *), slamch_(
+ char *);
+ extern /* Subroutine */ int clatbs_(char *, char *, char *, char *,
+ integer *, integer *, complex *, integer *, complex *, real *,
+ real *, integer *), xerbla_(char *
+, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int csrscl_(integer *, real *, complex *, integer
+ *);
+ logical onenrm;
+ char normin[1];
+ real smlnum;
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTBCON estimates the reciprocal of the condition number of a */
+/* triangular band matrix A, in either the 1-norm or the infinity-norm. */
+
+/* The norm of A is computed and an estimate is obtained for */
+/* norm(inv(A)), then the reciprocal of the condition number is */
+/* computed as */
+/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* RCOND (output) REAL */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ nounit = lsame_(diag, "N");
+
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*kd < 0) {
+ *info = -5;
+ } else if (*ldab < *kd + 1) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTBCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ }
+
+ *rcond = 0.f;
+ smlnum = slamch_("Safe minimum") * (real) max(*n,1);
+
+/* Compute the 1-norm of the triangular matrix A or A'. */
+
+ anorm = clantb_(norm, uplo, diag, n, kd, &ab[ab_offset], ldab, &rwork[1]);
+
+/* Continue only if ANORM > 0. */
+
+ if (anorm > 0.f) {
+
+/* Estimate the 1-norm of the inverse of A. */
+
+ ainvnm = 0.f;
+ *(unsigned char *)normin = 'N';
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kase = 0;
+L10:
+ clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(A). */
+
+ clatbs_(uplo, "No transpose", diag, normin, n, kd, &ab[
+ ab_offset], ldab, &work[1], &scale, &rwork[1], info);
+ } else {
+
+/* Multiply by inv(A'). */
+
+ clatbs_(uplo, "Conjugate transpose", diag, normin, n, kd, &ab[
+ ab_offset], ldab, &work[1], &scale, &rwork[1], info);
+ }
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ if (scale != 1.f) {
+ ix = icamax_(n, &work[1], &c__1);
+ i__1 = ix;
+ xnorm = (r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
+ work[ix]), dabs(r__2));
+ if (scale < xnorm * smlnum || scale == 0.f) {
+ goto L20;
+ }
+ csrscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / anorm / ainvnm;
+ }
+ }
+
+L20:
+ return 0;
+
+/* End of CTBCON */
+
+} /* ctbcon_ */
diff --git a/SRC/ctbrfs.c b/SRC/ctbrfs.c
new file mode 100644
index 0000000..883e532
--- /dev/null
+++ b/SRC/ctbrfs.c
@@ -0,0 +1,584 @@
+/* ctbrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ctbrfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, complex *ab, integer *ldab, complex *b,
+ integer *ldb, complex *x, integer *ldx, real *ferr, real *berr,
+ complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1,
+ i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ real s, xk;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int ctbmv_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *), ccopy_(integer *, complex *, integer *, complex *
+, integer *), ctbsv_(char *, char *, char *, integer *, integer *,
+ complex *, integer *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *,
+ complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+ char transn[1], transt[1];
+ logical nounit;
+ real lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTBRFS provides error bounds and backward error estimates for the */
+/* solution to a system of linear equations with a triangular band */
+/* coefficient matrix. */
+
+/* The solution matrix X must be computed by CTBTRS or some other */
+/* means before entering this routine. CTBRFS does not do iterative */
+/* refinement because doing so cannot improve the backward error. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*kd < 0) {
+ *info = -5;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*ldab < *kd + 1) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldx < max(1,*n)) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTBRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transn = 'N';
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transn = 'C';
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *kd + 2;
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A, A**T, or A**H, depending on TRANS. */
+
+ ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ctbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[1], &
+ c__1);
+ q__1.r = -1.f, q__1.i = -0.f;
+ caxpy_(n, &q__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[
+ i__ + j * b_dim1]), dabs(r__2));
+/* L20: */
+ }
+
+ if (notran) {
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ x[k + j * x_dim1]), dabs(r__2));
+/* Computing MAX */
+ i__3 = 1, i__4 = k - *kd;
+ i__5 = k;
+ for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
+ i__3 = *kd + 1 + i__ - k + k * ab_dim1;
+ rwork[i__] += ((r__1 = ab[i__3].r, dabs(r__1)) + (
+ r__2 = r_imag(&ab[*kd + 1 + i__ - k + k *
+ ab_dim1]), dabs(r__2))) * xk;
+/* L30: */
+ }
+/* L40: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__5 = k + j * x_dim1;
+ xk = (r__1 = x[i__5].r, dabs(r__1)) + (r__2 = r_imag(&
+ x[k + j * x_dim1]), dabs(r__2));
+/* Computing MAX */
+ i__5 = 1, i__3 = k - *kd;
+ i__4 = k - 1;
+ for (i__ = max(i__5,i__3); i__ <= i__4; ++i__) {
+ i__5 = *kd + 1 + i__ - k + k * ab_dim1;
+ rwork[i__] += ((r__1 = ab[i__5].r, dabs(r__1)) + (
+ r__2 = r_imag(&ab[*kd + 1 + i__ - k + k *
+ ab_dim1]), dabs(r__2))) * xk;
+/* L50: */
+ }
+ rwork[k] += xk;
+/* L60: */
+ }
+ }
+ } else {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__4 = k + j * x_dim1;
+ xk = (r__1 = x[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
+ x[k + j * x_dim1]), dabs(r__2));
+/* Computing MIN */
+ i__5 = *n, i__3 = k + *kd;
+ i__4 = min(i__5,i__3);
+ for (i__ = k; i__ <= i__4; ++i__) {
+ i__5 = i__ + 1 - k + k * ab_dim1;
+ rwork[i__] += ((r__1 = ab[i__5].r, dabs(r__1)) + (
+ r__2 = r_imag(&ab[i__ + 1 - k + k *
+ ab_dim1]), dabs(r__2))) * xk;
+/* L70: */
+ }
+/* L80: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__4 = k + j * x_dim1;
+ xk = (r__1 = x[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
+ x[k + j * x_dim1]), dabs(r__2));
+/* Computing MIN */
+ i__5 = *n, i__3 = k + *kd;
+ i__4 = min(i__5,i__3);
+ for (i__ = k + 1; i__ <= i__4; ++i__) {
+ i__5 = i__ + 1 - k + k * ab_dim1;
+ rwork[i__] += ((r__1 = ab[i__5].r, dabs(r__1)) + (
+ r__2 = r_imag(&ab[i__ + 1 - k + k *
+ ab_dim1]), dabs(r__2))) * xk;
+/* L90: */
+ }
+ rwork[k] += xk;
+/* L100: */
+ }
+ }
+ }
+ } else {
+
+/* Compute abs(A**H)*abs(X) + abs(B). */
+
+ if (upper) {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+/* Computing MAX */
+ i__4 = 1, i__5 = k - *kd;
+ i__3 = k;
+ for (i__ = max(i__4,i__5); i__ <= i__3; ++i__) {
+ i__4 = *kd + 1 + i__ - k + k * ab_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((r__1 = ab[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&ab[*kd + 1 + i__ - k + k *
+ ab_dim1]), dabs(r__2))) * ((r__3 = x[i__5]
+ .r, dabs(r__3)) + (r__4 = r_imag(&x[i__ +
+ j * x_dim1]), dabs(r__4)));
+/* L110: */
+ }
+ rwork[k] += s;
+/* L120: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ s = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ x[k + j * x_dim1]), dabs(r__2));
+/* Computing MAX */
+ i__3 = 1, i__4 = k - *kd;
+ i__5 = k - 1;
+ for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
+ i__3 = *kd + 1 + i__ - k + k * ab_dim1;
+ i__4 = i__ + j * x_dim1;
+ s += ((r__1 = ab[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&ab[*kd + 1 + i__ - k + k *
+ ab_dim1]), dabs(r__2))) * ((r__3 = x[i__4]
+ .r, dabs(r__3)) + (r__4 = r_imag(&x[i__ +
+ j * x_dim1]), dabs(r__4)));
+/* L130: */
+ }
+ rwork[k] += s;
+/* L140: */
+ }
+ }
+ } else {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+/* Computing MIN */
+ i__3 = *n, i__4 = k + *kd;
+ i__5 = min(i__3,i__4);
+ for (i__ = k; i__ <= i__5; ++i__) {
+ i__3 = i__ + 1 - k + k * ab_dim1;
+ i__4 = i__ + j * x_dim1;
+ s += ((r__1 = ab[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&ab[i__ + 1 - k + k * ab_dim1]),
+ dabs(r__2))) * ((r__3 = x[i__4].r, dabs(
+ r__3)) + (r__4 = r_imag(&x[i__ + j *
+ x_dim1]), dabs(r__4)));
+/* L150: */
+ }
+ rwork[k] += s;
+/* L160: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__5 = k + j * x_dim1;
+ s = (r__1 = x[i__5].r, dabs(r__1)) + (r__2 = r_imag(&
+ x[k + j * x_dim1]), dabs(r__2));
+/* Computing MIN */
+ i__3 = *n, i__4 = k + *kd;
+ i__5 = min(i__3,i__4);
+ for (i__ = k + 1; i__ <= i__5; ++i__) {
+ i__3 = i__ + 1 - k + k * ab_dim1;
+ i__4 = i__ + j * x_dim1;
+ s += ((r__1 = ab[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&ab[i__ + 1 - k + k * ab_dim1]),
+ dabs(r__2))) * ((r__3 = x[i__4].r, dabs(
+ r__3)) + (r__4 = r_imag(&x[i__ + j *
+ x_dim1]), dabs(r__4)));
+/* L170: */
+ }
+ rwork[k] += s;
+/* L180: */
+ }
+ }
+ }
+ }
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__5 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__5].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
+ s = dmax(r__3,r__4);
+ } else {
+/* Computing MAX */
+ i__5 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__5].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = dmax(r__3,r__4);
+ }
+/* L190: */
+ }
+ berr[j] = s;
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use CLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__5 = i__;
+ rwork[i__] = (r__1 = work[i__5].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__];
+ } else {
+ i__5 = i__;
+ rwork[i__] = (r__1 = work[i__5].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__] + safe1;
+ }
+/* L200: */
+ }
+
+ kase = 0;
+L210:
+ clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)**H). */
+
+ ctbsv_(uplo, transt, diag, n, kd, &ab[ab_offset], ldab, &work[
+ 1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__5 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__3] * work[i__4].r, q__1.i = rwork[i__3]
+ * work[i__4].i;
+ work[i__5].r = q__1.r, work[i__5].i = q__1.i;
+/* L220: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__5 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ q__1.r = rwork[i__3] * work[i__4].r, q__1.i = rwork[i__3]
+ * work[i__4].i;
+ work[i__5].r = q__1.r, work[i__5].i = q__1.i;
+/* L230: */
+ }
+ ctbsv_(uplo, transn, diag, n, kd, &ab[ab_offset], ldab, &work[
+ 1], &c__1);
+ }
+ goto L210;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__5 = i__ + j * x_dim1;
+ r__3 = lstres, r__4 = (r__1 = x[i__5].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + j * x_dim1]), dabs(r__2));
+ lstres = dmax(r__3,r__4);
+/* L240: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L250: */
+ }
+
+ return 0;
+
+/* End of CTBRFS */
+
+} /* ctbrfs_ */
diff --git a/SRC/ctbtrs.c b/SRC/ctbtrs.c
new file mode 100644
index 0000000..d19e3ea
--- /dev/null
+++ b/SRC/ctbtrs.c
@@ -0,0 +1,206 @@
+/* ctbtrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ctbtrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, complex *ab, integer *ldab, complex *b,
+ integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1, i__2;
+
+ /* Local variables */
+ integer j;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ctbsv_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTBTRS solves a triangular system of the form */
+
+/* A * X = B, A**T * X = B, or A**H * X = B, */
+
+/* where A is a triangular band matrix of order N, and B is an */
+/* N-by-NRHS matrix. A check is made to verify that A is nonsingular. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of AB. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, if INFO = 0, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element of A is zero, */
+/* indicating that the matrix is singular and the */
+/* solutions X have not been computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ nounit = lsame_(diag, "N");
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*kd < 0) {
+ *info = -5;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*ldab < *kd + 1) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTBTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check for singularity. */
+
+ if (nounit) {
+ if (upper) {
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ i__2 = *kd + 1 + *info * ab_dim1;
+ if (ab[i__2].r == 0.f && ab[i__2].i == 0.f) {
+ return 0;
+ }
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ i__2 = *info * ab_dim1 + 1;
+ if (ab[i__2].r == 0.f && ab[i__2].i == 0.f) {
+ return 0;
+ }
+/* L20: */
+ }
+ }
+ }
+ *info = 0;
+
+/* Solve A * X = B, A**T * X = B, or A**H * X = B. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ctbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &b[j * b_dim1
+ + 1], &c__1);
+/* L30: */
+ }
+
+ return 0;
+
+/* End of CTBTRS */
+
+} /* ctbtrs_ */
diff --git a/SRC/ctfsm.c b/SRC/ctfsm.c
new file mode 100644
index 0000000..2b07055
--- /dev/null
+++ b/SRC/ctfsm.c
@@ -0,0 +1,1024 @@
+/* ctfsm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+
+/* Subroutine */ int ctfsm_(char *transr, char *side, char *uplo, char *trans,
+ char *diag, integer *m, integer *n, complex *alpha, complex *a,
+ complex *b, integer *ldb)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2, i__3;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j, k, m1, m2, n1, n2, info;
+ logical normaltransr;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ logical lside;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *), xerbla_(char *,
+ integer *);
+ logical misodd, nisodd, notrans;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Level 3 BLAS like routine for A in RFP Format. */
+
+/* CTFSM solves the matrix equation */
+
+/* op( A )*X = alpha*B or X*op( A ) = alpha*B */
+
+/* where alpha is a scalar, X and B are m by n matrices, A is a unit, or */
+/* non-unit, upper or lower triangular matrix and op( A ) is one of */
+
+/* op( A ) = A or op( A ) = conjg( A' ). */
+
+/* A is in Rectangular Full Packed (RFP) Format. */
+
+/* The matrix X is overwritten on B. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANSR - (input) CHARACTER */
+/* = 'N': The Normal Form of RFP A is stored; */
+/* = 'C': The Conjugate-transpose Form of RFP A is stored. */
+
+/* SIDE - (input) CHARACTER */
+/* On entry, SIDE specifies whether op( A ) appears on the left */
+/* or right of X as follows: */
+
+/* SIDE = 'L' or 'l' op( A )*X = alpha*B. */
+
+/* SIDE = 'R' or 'r' X*op( A ) = alpha*B. */
+
+/* Unchanged on exit. */
+
+/* UPLO - (input) CHARACTER */
+/* On entry, UPLO specifies whether the RFP matrix A came from */
+/* an upper or lower triangular matrix as follows: */
+/* UPLO = 'U' or 'u' RFP A came from an upper triangular matrix */
+/* UPLO = 'L' or 'l' RFP A came from a lower triangular matrix */
+
+/* Unchanged on exit. */
+
+/* TRANS - (input) CHARACTER */
+/* On entry, TRANS specifies the form of op( A ) to be used */
+/* in the matrix multiplication as follows: */
+
+/* TRANS = 'N' or 'n' op( A ) = A. */
+
+/* TRANS = 'C' or 'c' op( A ) = conjg( A' ). */
+
+/* Unchanged on exit. */
+
+/* DIAG - (input) CHARACTER */
+/* On entry, DIAG specifies whether or not RFP A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* M - (input) INTEGER. */
+/* On entry, M specifies the number of rows of B. M must be at */
+/* least zero. */
+/* Unchanged on exit. */
+
+/* N - (input) INTEGER. */
+/* On entry, N specifies the number of columns of B. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - (input) COMPLEX. */
+/* On entry, ALPHA specifies the scalar alpha. When alpha is */
+/* zero then A is not referenced and B need not be set before */
+/* entry. */
+/* Unchanged on exit. */
+
+/* A - (input) COMPLEX array, dimension ( N*(N+1)/2 ); */
+/* NT = N*(N+1)/2. On entry, the matrix A in RFP Format. */
+/* RFP Format is described by TRANSR, UPLO and N as follows: */
+/* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even; */
+/* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If */
+/* TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A as */
+/* defined when TRANSR = 'N'. The contents of RFP A are defined */
+/* by UPLO as follows: If UPLO = 'U' the RFP A contains the NT */
+/* elements of upper packed A either in normal or */
+/* conjugate-transpose Format. If UPLO = 'L' the RFP A contains */
+/* the NT elements of lower packed A either in normal or */
+/* conjugate-transpose Format. The LDA of RFP A is (N+1)/2 when */
+/* TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is */
+/* even and is N when is odd. */
+/* See the Note below for more details. Unchanged on exit. */
+
+/* B - (input/ouptut) COMPLEX array, DIMENSION ( LDB, N ) */
+/* Before entry, the leading m by n part of the array B must */
+/* contain the right-hand side matrix B, and on exit is */
+/* overwritten by the solution matrix X. */
+
+/* LDB - (input) INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. LDB must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+/* Further Details */
+/* =============== */
+
+/* We first consider Standard Packed Format when N is even. */
+/* We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* conjugate-transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* conjugate-transpose of the last three columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- -- */
+/* 03 04 05 33 43 53 */
+/* -- -- */
+/* 13 14 15 00 44 54 */
+/* -- */
+/* 23 24 25 10 11 55 */
+
+/* 33 34 35 20 21 22 */
+/* -- */
+/* 00 44 45 30 31 32 */
+/* -- -- */
+/* 01 11 55 40 41 42 */
+/* -- -- -- */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We next consider Standard Packed Format when N is odd. */
+/* We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* conjugate-transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* conjugate-transpose of the last two columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- */
+/* 02 03 04 00 33 43 */
+/* -- */
+/* 12 13 14 10 11 44 */
+
+/* 22 23 24 20 21 22 */
+/* -- */
+/* 00 33 34 30 31 32 */
+/* -- -- */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- */
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ b_dim1 = *ldb - 1 - 0 + 1;
+ b_offset = 0 + b_dim1 * 0;
+ b -= b_offset;
+
+ /* Function Body */
+ info = 0;
+ normaltransr = lsame_(transr, "N");
+ lside = lsame_(side, "L");
+ lower = lsame_(uplo, "L");
+ notrans = lsame_(trans, "N");
+ if (! normaltransr && ! lsame_(transr, "C")) {
+ info = -1;
+ } else if (! lside && ! lsame_(side, "R")) {
+ info = -2;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ info = -3;
+ } else if (! notrans && ! lsame_(trans, "C")) {
+ info = -4;
+ } else if (! lsame_(diag, "N") && ! lsame_(diag,
+ "U")) {
+ info = -5;
+ } else if (*m < 0) {
+ info = -6;
+ } else if (*n < 0) {
+ info = -7;
+ } else if (*ldb < max(1,*m)) {
+ info = -11;
+ }
+ if (info != 0) {
+ i__1 = -info;
+ xerbla_("CTFSM ", &i__1);
+ return 0;
+ }
+
+/* Quick return when ( (N.EQ.0).OR.(M.EQ.0) ) */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Quick return when ALPHA.EQ.(0E+0,0E+0) */
+
+ if (alpha->r == 0.f && alpha->i == 0.f) {
+ i__1 = *n - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *m - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0.f, b[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ return 0;
+ }
+
+ if (lside) {
+
+/* SIDE = 'L' */
+
+/* A is M-by-M. */
+/* If M is odd, set NISODD = .TRUE., and M1 and M2. */
+/* If M is even, NISODD = .FALSE., and M. */
+
+ if (*m % 2 == 0) {
+ misodd = FALSE_;
+ k = *m / 2;
+ } else {
+ misodd = TRUE_;
+ if (lower) {
+ m2 = *m / 2;
+ m1 = *m - m2;
+ } else {
+ m1 = *m / 2;
+ m2 = *m - m1;
+ }
+ }
+
+ if (misodd) {
+
+/* SIDE = 'L' and N is odd */
+
+ if (normaltransr) {
+
+/* SIDE = 'L', N is odd, and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and */
+/* TRANS = 'N' */
+
+ if (*m == 1) {
+ ctrsm_("L", "L", "N", diag, &m1, n, alpha, a, m, &
+ b[b_offset], ldb);
+ } else {
+ ctrsm_("L", "L", "N", diag, &m1, n, alpha, a, m, &
+ b[b_offset], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("N", "N", &m2, n, &m1, &q__1, &a[m1], m, &
+ b[b_offset], ldb, alpha, &b[m1], ldb);
+ ctrsm_("L", "U", "C", diag, &m2, n, &c_b1, &a[*m],
+ m, &b[m1], ldb);
+ }
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and */
+/* TRANS = 'C' */
+
+ if (*m == 1) {
+ ctrsm_("L", "L", "C", diag, &m1, n, alpha, a, m, &
+ b[b_offset], ldb);
+ } else {
+ ctrsm_("L", "U", "N", diag, &m2, n, alpha, &a[*m],
+ m, &b[m1], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("C", "N", &m1, n, &m2, &q__1, &a[m1], m, &
+ b[m1], ldb, alpha, &b[b_offset], ldb);
+ ctrsm_("L", "L", "C", diag, &m1, n, &c_b1, a, m, &
+ b[b_offset], ldb);
+ }
+
+ }
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'U' */
+
+ if (! notrans) {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and */
+/* TRANS = 'N' */
+
+ ctrsm_("L", "L", "N", diag, &m1, n, alpha, &a[m2], m,
+ &b[b_offset], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("C", "N", &m2, n, &m1, &q__1, a, m, &b[
+ b_offset], ldb, alpha, &b[m1], ldb);
+ ctrsm_("L", "U", "C", diag, &m2, n, &c_b1, &a[m1], m,
+ &b[m1], ldb);
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and */
+/* TRANS = 'C' */
+
+ ctrsm_("L", "U", "N", diag, &m2, n, alpha, &a[m1], m,
+ &b[m1], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("N", "N", &m1, n, &m2, &q__1, a, m, &b[m1],
+ ldb, alpha, &b[b_offset], ldb);
+ ctrsm_("L", "L", "C", diag, &m1, n, &c_b1, &a[m2], m,
+ &b[b_offset], ldb);
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'L', N is odd, and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SIDE ='L', N is odd, TRANSR = 'C', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'L', and */
+/* TRANS = 'N' */
+
+ if (*m == 1) {
+ ctrsm_("L", "U", "C", diag, &m1, n, alpha, a, &m1,
+ &b[b_offset], ldb);
+ } else {
+ ctrsm_("L", "U", "C", diag, &m1, n, alpha, a, &m1,
+ &b[b_offset], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("C", "N", &m2, n, &m1, &q__1, &a[m1 * m1],
+ &m1, &b[b_offset], ldb, alpha, &b[m1],
+ ldb);
+ ctrsm_("L", "L", "N", diag, &m2, n, &c_b1, &a[1],
+ &m1, &b[m1], ldb);
+ }
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'L', and */
+/* TRANS = 'C' */
+
+ if (*m == 1) {
+ ctrsm_("L", "U", "N", diag, &m1, n, alpha, a, &m1,
+ &b[b_offset], ldb);
+ } else {
+ ctrsm_("L", "L", "C", diag, &m2, n, alpha, &a[1],
+ &m1, &b[m1], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("N", "N", &m1, n, &m2, &q__1, &a[m1 * m1],
+ &m1, &b[m1], ldb, alpha, &b[b_offset],
+ ldb);
+ ctrsm_("L", "U", "N", diag, &m1, n, &c_b1, a, &m1,
+ &b[b_offset], ldb);
+ }
+
+ }
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'C', and UPLO = 'U' */
+
+ if (! notrans) {
+
+/* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'U', and */
+/* TRANS = 'N' */
+
+ ctrsm_("L", "U", "C", diag, &m1, n, alpha, &a[m2 * m2]
+, &m2, &b[b_offset], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("N", "N", &m2, n, &m1, &q__1, a, &m2, &b[
+ b_offset], ldb, alpha, &b[m1], ldb);
+ ctrsm_("L", "L", "N", diag, &m2, n, &c_b1, &a[m1 * m2]
+, &m2, &b[m1], ldb);
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'U', and */
+/* TRANS = 'C' */
+
+ ctrsm_("L", "L", "C", diag, &m2, n, alpha, &a[m1 * m2]
+, &m2, &b[m1], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("C", "N", &m1, n, &m2, &q__1, a, &m2, &b[m1],
+ ldb, alpha, &b[b_offset], ldb);
+ ctrsm_("L", "U", "N", diag, &m1, n, &c_b1, &a[m2 * m2]
+, &m2, &b[b_offset], ldb);
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'L' and N is even */
+
+ if (normaltransr) {
+
+/* SIDE = 'L', N is even, and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', */
+/* and TRANS = 'N' */
+
+ i__1 = *m + 1;
+ ctrsm_("L", "L", "N", diag, &k, n, alpha, &a[1], &
+ i__1, &b[b_offset], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ i__1 = *m + 1;
+ cgemm_("N", "N", &k, n, &k, &q__1, &a[k + 1], &i__1, &
+ b[b_offset], ldb, alpha, &b[k], ldb);
+ i__1 = *m + 1;
+ ctrsm_("L", "U", "C", diag, &k, n, &c_b1, a, &i__1, &
+ b[k], ldb);
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', */
+/* and TRANS = 'C' */
+
+ i__1 = *m + 1;
+ ctrsm_("L", "U", "N", diag, &k, n, alpha, a, &i__1, &
+ b[k], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ i__1 = *m + 1;
+ cgemm_("C", "N", &k, n, &k, &q__1, &a[k + 1], &i__1, &
+ b[k], ldb, alpha, &b[b_offset], ldb);
+ i__1 = *m + 1;
+ ctrsm_("L", "L", "C", diag, &k, n, &c_b1, &a[1], &
+ i__1, &b[b_offset], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'U' */
+
+ if (! notrans) {
+
+/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', */
+/* and TRANS = 'N' */
+
+ i__1 = *m + 1;
+ ctrsm_("L", "L", "N", diag, &k, n, alpha, &a[k + 1], &
+ i__1, &b[b_offset], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ i__1 = *m + 1;
+ cgemm_("C", "N", &k, n, &k, &q__1, a, &i__1, &b[
+ b_offset], ldb, alpha, &b[k], ldb);
+ i__1 = *m + 1;
+ ctrsm_("L", "U", "C", diag, &k, n, &c_b1, &a[k], &
+ i__1, &b[k], ldb);
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', */
+/* and TRANS = 'C' */
+ i__1 = *m + 1;
+ ctrsm_("L", "U", "N", diag, &k, n, alpha, &a[k], &
+ i__1, &b[k], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ i__1 = *m + 1;
+ cgemm_("N", "N", &k, n, &k, &q__1, a, &i__1, &b[k],
+ ldb, alpha, &b[b_offset], ldb);
+ i__1 = *m + 1;
+ ctrsm_("L", "L", "C", diag, &k, n, &c_b1, &a[k + 1], &
+ i__1, &b[b_offset], ldb);
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'L', N is even, and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SIDE ='L', N is even, TRANSR = 'C', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'L', */
+/* and TRANS = 'N' */
+
+ ctrsm_("L", "U", "C", diag, &k, n, alpha, &a[k], &k, &
+ b[b_offset], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("C", "N", &k, n, &k, &q__1, &a[k * (k + 1)], &
+ k, &b[b_offset], ldb, alpha, &b[k], ldb);
+ ctrsm_("L", "L", "N", diag, &k, n, &c_b1, a, &k, &b[k]
+, ldb);
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'L', */
+/* and TRANS = 'C' */
+
+ ctrsm_("L", "L", "C", diag, &k, n, alpha, a, &k, &b[k]
+, ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("N", "N", &k, n, &k, &q__1, &a[k * (k + 1)], &
+ k, &b[k], ldb, alpha, &b[b_offset], ldb);
+ ctrsm_("L", "U", "N", diag, &k, n, &c_b1, &a[k], &k, &
+ b[b_offset], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'C', and UPLO = 'U' */
+
+ if (! notrans) {
+
+/* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'U', */
+/* and TRANS = 'N' */
+
+ ctrsm_("L", "U", "C", diag, &k, n, alpha, &a[k * (k +
+ 1)], &k, &b[b_offset], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("N", "N", &k, n, &k, &q__1, a, &k, &b[b_offset]
+, ldb, alpha, &b[k], ldb);
+ ctrsm_("L", "L", "N", diag, &k, n, &c_b1, &a[k * k], &
+ k, &b[k], ldb);
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'U', */
+/* and TRANS = 'C' */
+
+ ctrsm_("L", "L", "C", diag, &k, n, alpha, &a[k * k], &
+ k, &b[k], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("C", "N", &k, n, &k, &q__1, a, &k, &b[k], ldb,
+ alpha, &b[b_offset], ldb);
+ ctrsm_("L", "U", "N", diag, &k, n, &c_b1, &a[k * (k +
+ 1)], &k, &b[b_offset], ldb);
+
+ }
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'R' */
+
+/* A is N-by-N. */
+/* If N is odd, set NISODD = .TRUE., and N1 and N2. */
+/* If N is even, NISODD = .FALSE., and K. */
+
+ if (*n % 2 == 0) {
+ nisodd = FALSE_;
+ k = *n / 2;
+ } else {
+ nisodd = TRUE_;
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+ }
+
+ if (nisodd) {
+
+/* SIDE = 'R' and N is odd */
+
+ if (normaltransr) {
+
+/* SIDE = 'R', N is odd, and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and */
+/* TRANS = 'N' */
+
+ ctrsm_("R", "U", "C", diag, m, &n2, alpha, &a[*n], n,
+ &b[n1 * b_dim1], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("N", "N", m, &n1, &n2, &q__1, &b[n1 * b_dim1],
+ ldb, &a[n1], n, alpha, b, ldb);
+ ctrsm_("R", "L", "N", diag, m, &n1, &c_b1, a, n, b,
+ ldb);
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and */
+/* TRANS = 'C' */
+
+ ctrsm_("R", "L", "C", diag, m, &n1, alpha, a, n, b,
+ ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("N", "C", m, &n2, &n1, &q__1, b, ldb, &a[n1],
+ n, alpha, &b[n1 * b_dim1], ldb);
+ ctrsm_("R", "U", "N", diag, m, &n2, &c_b1, &a[*n], n,
+ &b[n1 * b_dim1], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and */
+/* TRANS = 'N' */
+
+ ctrsm_("R", "L", "C", diag, m, &n1, alpha, &a[n2], n,
+ b, ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("N", "N", m, &n2, &n1, &q__1, b, ldb, a, n,
+ alpha, &b[n1 * b_dim1], ldb);
+ ctrsm_("R", "U", "N", diag, m, &n2, &c_b1, &a[n1], n,
+ &b[n1 * b_dim1], ldb);
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and */
+/* TRANS = 'C' */
+
+ ctrsm_("R", "U", "C", diag, m, &n2, alpha, &a[n1], n,
+ &b[n1 * b_dim1], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("N", "C", m, &n1, &n2, &q__1, &b[n1 * b_dim1],
+ ldb, a, n, alpha, b, ldb);
+ ctrsm_("R", "L", "N", diag, m, &n1, &c_b1, &a[n2], n,
+ b, ldb);
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'R', N is odd, and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SIDE ='R', N is odd, TRANSR = 'C', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'L', and */
+/* TRANS = 'N' */
+
+ ctrsm_("R", "L", "N", diag, m, &n2, alpha, &a[1], &n1,
+ &b[n1 * b_dim1], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("N", "C", m, &n1, &n2, &q__1, &b[n1 * b_dim1],
+ ldb, &a[n1 * n1], &n1, alpha, b, ldb);
+ ctrsm_("R", "U", "C", diag, m, &n1, &c_b1, a, &n1, b,
+ ldb);
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'L', and */
+/* TRANS = 'C' */
+
+ ctrsm_("R", "U", "N", diag, m, &n1, alpha, a, &n1, b,
+ ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("N", "N", m, &n2, &n1, &q__1, b, ldb, &a[n1 *
+ n1], &n1, alpha, &b[n1 * b_dim1], ldb);
+ ctrsm_("R", "L", "C", diag, m, &n2, &c_b1, &a[1], &n1,
+ &b[n1 * b_dim1], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'C', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'U', and */
+/* TRANS = 'N' */
+
+ ctrsm_("R", "U", "N", diag, m, &n1, alpha, &a[n2 * n2]
+, &n2, b, ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("N", "C", m, &n2, &n1, &q__1, b, ldb, a, &n2,
+ alpha, &b[n1 * b_dim1], ldb);
+ ctrsm_("R", "L", "C", diag, m, &n2, &c_b1, &a[n1 * n2]
+, &n2, &b[n1 * b_dim1], ldb);
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'U', and */
+/* TRANS = 'C' */
+
+ ctrsm_("R", "L", "N", diag, m, &n2, alpha, &a[n1 * n2]
+, &n2, &b[n1 * b_dim1], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("N", "N", m, &n1, &n2, &q__1, &b[n1 * b_dim1],
+ ldb, a, &n2, alpha, b, ldb);
+ ctrsm_("R", "U", "C", diag, m, &n1, &c_b1, &a[n2 * n2]
+, &n2, b, ldb);
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'R' and N is even */
+
+ if (normaltransr) {
+
+/* SIDE = 'R', N is even, and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', */
+/* and TRANS = 'N' */
+
+ i__1 = *n + 1;
+ ctrsm_("R", "U", "C", diag, m, &k, alpha, a, &i__1, &
+ b[k * b_dim1], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ i__1 = *n + 1;
+ cgemm_("N", "N", m, &k, &k, &q__1, &b[k * b_dim1],
+ ldb, &a[k + 1], &i__1, alpha, b, ldb);
+ i__1 = *n + 1;
+ ctrsm_("R", "L", "N", diag, m, &k, &c_b1, &a[1], &
+ i__1, b, ldb);
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', */
+/* and TRANS = 'C' */
+
+ i__1 = *n + 1;
+ ctrsm_("R", "L", "C", diag, m, &k, alpha, &a[1], &
+ i__1, b, ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ i__1 = *n + 1;
+ cgemm_("N", "C", m, &k, &k, &q__1, b, ldb, &a[k + 1],
+ &i__1, alpha, &b[k * b_dim1], ldb);
+ i__1 = *n + 1;
+ ctrsm_("R", "U", "N", diag, m, &k, &c_b1, a, &i__1, &
+ b[k * b_dim1], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', */
+/* and TRANS = 'N' */
+
+ i__1 = *n + 1;
+ ctrsm_("R", "L", "C", diag, m, &k, alpha, &a[k + 1], &
+ i__1, b, ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ i__1 = *n + 1;
+ cgemm_("N", "N", m, &k, &k, &q__1, b, ldb, a, &i__1,
+ alpha, &b[k * b_dim1], ldb);
+ i__1 = *n + 1;
+ ctrsm_("R", "U", "N", diag, m, &k, &c_b1, &a[k], &
+ i__1, &b[k * b_dim1], ldb);
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', */
+/* and TRANS = 'C' */
+
+ i__1 = *n + 1;
+ ctrsm_("R", "U", "C", diag, m, &k, alpha, &a[k], &
+ i__1, &b[k * b_dim1], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ i__1 = *n + 1;
+ cgemm_("N", "C", m, &k, &k, &q__1, &b[k * b_dim1],
+ ldb, a, &i__1, alpha, b, ldb);
+ i__1 = *n + 1;
+ ctrsm_("R", "L", "N", diag, m, &k, &c_b1, &a[k + 1], &
+ i__1, b, ldb);
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'R', N is even, and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SIDE ='R', N is even, TRANSR = 'C', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'L', */
+/* and TRANS = 'N' */
+
+ ctrsm_("R", "L", "N", diag, m, &k, alpha, a, &k, &b[k
+ * b_dim1], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("N", "C", m, &k, &k, &q__1, &b[k * b_dim1],
+ ldb, &a[(k + 1) * k], &k, alpha, b, ldb);
+ ctrsm_("R", "U", "C", diag, m, &k, &c_b1, &a[k], &k,
+ b, ldb);
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'L', */
+/* and TRANS = 'C' */
+
+ ctrsm_("R", "U", "N", diag, m, &k, alpha, &a[k], &k,
+ b, ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("N", "N", m, &k, &k, &q__1, b, ldb, &a[(k + 1)
+ * k], &k, alpha, &b[k * b_dim1], ldb);
+ ctrsm_("R", "L", "C", diag, m, &k, &c_b1, a, &k, &b[k
+ * b_dim1], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'C', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'U', */
+/* and TRANS = 'N' */
+
+ ctrsm_("R", "U", "N", diag, m, &k, alpha, &a[(k + 1) *
+ k], &k, b, ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("N", "C", m, &k, &k, &q__1, b, ldb, a, &k,
+ alpha, &b[k * b_dim1], ldb);
+ ctrsm_("R", "L", "C", diag, m, &k, &c_b1, &a[k * k], &
+ k, &b[k * b_dim1], ldb);
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'U', */
+/* and TRANS = 'C' */
+
+ ctrsm_("R", "L", "N", diag, m, &k, alpha, &a[k * k], &
+ k, &b[k * b_dim1], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("N", "N", m, &k, &k, &q__1, &b[k * b_dim1],
+ ldb, a, &k, alpha, b, ldb);
+ ctrsm_("R", "U", "C", diag, m, &k, &c_b1, &a[(k + 1) *
+ k], &k, b, ldb);
+
+ }
+
+ }
+
+ }
+
+ }
+ }
+
+ return 0;
+
+/* End of CTFSM */
+
+} /* ctfsm_ */
diff --git a/SRC/ctftri.c b/SRC/ctftri.c
new file mode 100644
index 0000000..1453e33
--- /dev/null
+++ b/SRC/ctftri.c
@@ -0,0 +1,500 @@
+/* ctftri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+
+/* Subroutine */ int ctftri_(char *transr, char *uplo, char *diag, integer *n,
+ complex *a, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ complex q__1;
+
+ /* Local variables */
+ integer k, n1, n2;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nisodd;
+ extern /* Subroutine */ int ctrtri_(char *, char *, integer *, complex *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTFTRI computes the inverse of a triangular matrix A stored in RFP */
+/* format. */
+
+/* This is a Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': The Normal TRANSR of RFP A is stored; */
+/* = 'C': The Conjugate-transpose TRANSR of RFP A is stored. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension ( N*(N+1)/2 ); */
+/* On entry, the triangular matrix A in RFP format. RFP format */
+/* is described by TRANSR, UPLO, and N as follows: If TRANSR = */
+/* 'N' then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */
+/* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is */
+/* the Conjugate-transpose of RFP A as defined when */
+/* TRANSR = 'N'. The contents of RFP A are defined by UPLO as */
+/* follows: If UPLO = 'U' the RFP A contains the nt elements of */
+/* upper packed A; If UPLO = 'L' the RFP A contains the nt */
+/* elements of lower packed A. The LDA of RFP A is (N+1)/2 when */
+/* TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is */
+/* even and N is odd. See the Note below for more details. */
+
+/* On exit, the (triangular) inverse of the original matrix, in */
+/* the same storage format. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */
+/* matrix is singular and its inverse can not be computed. */
+
+/* Notes: */
+/* ====== */
+
+/* We first consider Standard Packed Format when N is even. */
+/* We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* conjugate-transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* conjugate-transpose of the last three columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- -- */
+/* 03 04 05 33 43 53 */
+/* -- -- */
+/* 13 14 15 00 44 54 */
+/* -- */
+/* 23 24 25 10 11 55 */
+
+/* 33 34 35 20 21 22 */
+/* -- */
+/* 00 44 45 30 31 32 */
+/* -- -- */
+/* 01 11 55 40 41 42 */
+/* -- -- -- */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We next consider Standard Packed Format when N is odd. */
+/* We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* conjugate-transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* conjugate-transpose of the last two columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- */
+/* 02 03 04 00 33 43 */
+/* -- */
+/* 12 13 14 10 11 44 */
+
+/* 22 23 24 20 21 22 */
+/* -- */
+/* 00 33 34 30 31 32 */
+/* -- -- */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- */
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "C")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (! lsame_(diag, "N") && ! lsame_(diag,
+ "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTFTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* If N is odd, set NISODD = .TRUE. */
+/* If N is even, set K = N/2 and NISODD = .FALSE. */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ } else {
+ nisodd = TRUE_;
+ }
+
+/* Set N1 and N2 depending on LOWER */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+
+/* start execution: there are eight cases */
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */
+/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */
+/* T1 -> a(0), T2 -> a(n), S -> a(n1) */
+
+ ctrtri_("L", diag, &n1, a, n, info);
+ if (*info > 0) {
+ return 0;
+ }
+ q__1.r = -1.f, q__1.i = -0.f;
+ ctrmm_("R", "L", "N", diag, &n2, &n1, &q__1, a, n, &a[n1], n);
+ ctrtri_("U", diag, &n2, &a[*n], n, info)
+ ;
+ if (*info > 0) {
+ *info += n1;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ ctrmm_("L", "U", "C", diag, &n2, &n1, &c_b1, &a[*n], n, &a[n1]
+, n);
+
+ } else {
+
+/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */
+/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */
+/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */
+
+ ctrtri_("L", diag, &n1, &a[n2], n, info)
+ ;
+ if (*info > 0) {
+ return 0;
+ }
+ q__1.r = -1.f, q__1.i = -0.f;
+ ctrmm_("L", "L", "C", diag, &n1, &n2, &q__1, &a[n2], n, a, n);
+ ctrtri_("U", diag, &n2, &a[n1], n, info)
+ ;
+ if (*info > 0) {
+ *info += n1;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ ctrmm_("R", "U", "N", diag, &n1, &n2, &c_b1, &a[n1], n, a, n);
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is odd */
+/* T1 -> a(0), T2 -> a(1), S -> a(0+n1*n1) */
+
+ ctrtri_("U", diag, &n1, a, &n1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ q__1.r = -1.f, q__1.i = -0.f;
+ ctrmm_("L", "U", "N", diag, &n1, &n2, &q__1, a, &n1, &a[n1 *
+ n1], &n1);
+ ctrtri_("L", diag, &n2, &a[1], &n1, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ ctrmm_("R", "L", "C", diag, &n1, &n2, &c_b1, &a[1], &n1, &a[
+ n1 * n1], &n1);
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is odd */
+/* T1 -> a(0+n2*n2), T2 -> a(0+n1*n2), S -> a(0) */
+
+ ctrtri_("U", diag, &n1, &a[n2 * n2], &n2, info);
+ if (*info > 0) {
+ return 0;
+ }
+ q__1.r = -1.f, q__1.i = -0.f;
+ ctrmm_("R", "U", "C", diag, &n2, &n1, &q__1, &a[n2 * n2], &n2,
+ a, &n2);
+ ctrtri_("L", diag, &n2, &a[n1 * n2], &n2, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ ctrmm_("L", "L", "N", diag, &n2, &n1, &c_b1, &a[n1 * n2], &n2,
+ a, &n2);
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
+/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */
+
+ i__1 = *n + 1;
+ ctrtri_("L", diag, &k, &a[1], &i__1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ q__1.r = -1.f, q__1.i = -0.f;
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ ctrmm_("R", "L", "N", diag, &k, &k, &q__1, &a[1], &i__1, &a[k
+ + 1], &i__2);
+ i__1 = *n + 1;
+ ctrtri_("U", diag, &k, a, &i__1, info);
+ if (*info > 0) {
+ *info += k;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ ctrmm_("L", "U", "C", diag, &k, &k, &c_b1, a, &i__1, &a[k + 1]
+, &i__2);
+
+ } else {
+
+/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
+/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */
+
+ i__1 = *n + 1;
+ ctrtri_("L", diag, &k, &a[k + 1], &i__1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ q__1.r = -1.f, q__1.i = -0.f;
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ ctrmm_("L", "L", "C", diag, &k, &k, &q__1, &a[k + 1], &i__1,
+ a, &i__2);
+ i__1 = *n + 1;
+ ctrtri_("U", diag, &k, &a[k], &i__1, info);
+ if (*info > 0) {
+ *info += k;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ ctrmm_("R", "U", "N", diag, &k, &k, &c_b1, &a[k], &i__1, a, &
+ i__2);
+ }
+ } else {
+
+/* N is even and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */
+/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */
+
+ ctrtri_("U", diag, &k, &a[k], &k, info);
+ if (*info > 0) {
+ return 0;
+ }
+ q__1.r = -1.f, q__1.i = -0.f;
+ ctrmm_("L", "U", "N", diag, &k, &k, &q__1, &a[k], &k, &a[k * (
+ k + 1)], &k);
+ ctrtri_("L", diag, &k, a, &k, info);
+ if (*info > 0) {
+ *info += k;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ ctrmm_("R", "L", "C", diag, &k, &k, &c_b1, a, &k, &a[k * (k +
+ 1)], &k);
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */
+/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */
+
+ ctrtri_("U", diag, &k, &a[k * (k + 1)], &k, info);
+ if (*info > 0) {
+ return 0;
+ }
+ q__1.r = -1.f, q__1.i = -0.f;
+ ctrmm_("R", "U", "C", diag, &k, &k, &q__1, &a[k * (k + 1)], &
+ k, a, &k);
+ ctrtri_("L", diag, &k, &a[k * k], &k, info);
+ if (*info > 0) {
+ *info += k;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ ctrmm_("L", "L", "N", diag, &k, &k, &c_b1, &a[k * k], &k, a, &
+ k);
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CTFTRI */
+
+} /* ctftri_ */
diff --git a/SRC/ctfttp.c b/SRC/ctfttp.c
new file mode 100644
index 0000000..c581937
--- /dev/null
+++ b/SRC/ctfttp.c
@@ -0,0 +1,576 @@
+/* ctfttp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ctfttp_(char *transr, char *uplo, integer *n, complex *
+ arf, complex *ap, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ complex q__1;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k, n1, n2, ij, jp, js, nt, lda, ijp;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nisodd;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTFTTP copies a triangular matrix A from rectangular full packed */
+/* format (TF) to standard packed format (TP). */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': ARF is in Normal format; */
+/* = 'C': ARF is in Conjugate-transpose format; */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* ARF (input) COMPLEX array, dimension ( N*(N+1)/2 ), */
+/* On entry, the upper or lower triangular matrix A stored in */
+/* RFP format. For a further discussion see Notes below. */
+
+/* AP (output) COMPLEX array, dimension ( N*(N+1)/2 ), */
+/* On exit, the upper or lower triangular matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Notes: */
+/* ====== */
+
+/* We first consider Standard Packed Format when N is even. */
+/* We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* conjugate-transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* conjugate-transpose of the last three columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- -- */
+/* 03 04 05 33 43 53 */
+/* -- -- */
+/* 13 14 15 00 44 54 */
+/* -- */
+/* 23 24 25 10 11 55 */
+
+/* 33 34 35 20 21 22 */
+/* -- */
+/* 00 44 45 30 31 32 */
+/* -- -- */
+/* 01 11 55 40 41 42 */
+/* -- -- -- */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We next consider Standard Packed Format when N is odd. */
+/* We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* conjugate-transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* conjugate-transpose of the last two columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- */
+/* 02 03 04 00 33 43 */
+/* -- */
+/* 12 13 14 10 11 44 */
+
+/* 22 23 24 20 21 22 */
+/* -- */
+/* 00 33 34 30 31 32 */
+/* -- -- */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- */
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "C")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTFTTP", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (normaltransr) {
+ ap[0].r = arf[0].r, ap[0].i = arf[0].i;
+ } else {
+ r_cnjg(&q__1, arf);
+ ap[0].r = q__1.r, ap[0].i = q__1.i;
+ }
+ return 0;
+ }
+
+/* Size of array ARF(0:NT-1) */
+
+ nt = *n * (*n + 1) / 2;
+
+/* Set N1 and N2 depending on LOWER */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* If N is odd, set NISODD = .TRUE. */
+/* If N is even, set K = N/2 and NISODD = .FALSE. */
+
+/* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) */
+/* where noe = 0 if n is even, noe = 1 if n is odd */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ lda = *n + 1;
+ } else {
+ nisodd = TRUE_;
+ lda = *n;
+ }
+
+/* ARF^C has lda rows and n+1-noe cols */
+
+ if (! normaltransr) {
+ lda = (*n + 1) / 2;
+ }
+
+/* start execution: there are eight cases */
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */
+/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */
+/* T1 -> a(0), T2 -> a(n), S -> a(n1); lda = n */
+
+ ijp = 0;
+ jp = 0;
+ i__1 = n2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ij = i__ + jp;
+ i__3 = ijp;
+ i__4 = ij;
+ ap[i__3].r = arf[i__4].r, ap[i__3].i = arf[i__4].i;
+ ++ijp;
+ }
+ jp += lda;
+ }
+ i__1 = n2 - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = n2;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ ij = i__ + j * lda;
+ i__3 = ijp;
+ r_cnjg(&q__1, &arf[ij]);
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+ ++ijp;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */
+/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */
+/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */
+
+ ijp = 0;
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ ij = n2 + j;
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ijp;
+ r_cnjg(&q__1, &arf[ij]);
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+ ++ijp;
+ ij += lda;
+ }
+ }
+ js = 0;
+ i__1 = *n - 1;
+ for (j = n1; j <= i__1; ++j) {
+ ij = js;
+ i__2 = js + j;
+ for (ij = js; ij <= i__2; ++ij) {
+ i__3 = ijp;
+ i__4 = ij;
+ ap[i__3].r = arf[i__4].r, ap[i__3].i = arf[i__4].i;
+ ++ijp;
+ }
+ js += lda;
+ }
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is odd */
+/* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */
+/* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 */
+
+ ijp = 0;
+ i__1 = n2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = *n * lda - 1;
+ i__3 = lda;
+ for (ij = i__ * (lda + 1); i__3 < 0 ? ij >= i__2 : ij <=
+ i__2; ij += i__3) {
+ i__4 = ijp;
+ r_cnjg(&q__1, &arf[ij]);
+ ap[i__4].r = q__1.r, ap[i__4].i = q__1.i;
+ ++ijp;
+ }
+ }
+ js = 1;
+ i__1 = n2 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + n2 - j - 1;
+ for (ij = js; ij <= i__3; ++ij) {
+ i__2 = ijp;
+ i__4 = ij;
+ ap[i__2].r = arf[i__4].r, ap[i__2].i = arf[i__4].i;
+ ++ijp;
+ }
+ js = js + lda + 1;
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is odd */
+/* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */
+/* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 */
+
+ ijp = 0;
+ js = n2 * lda;
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + j;
+ for (ij = js; ij <= i__3; ++ij) {
+ i__2 = ijp;
+ i__4 = ij;
+ ap[i__2].r = arf[i__4].r, ap[i__2].i = arf[i__4].i;
+ ++ijp;
+ }
+ js += lda;
+ }
+ i__1 = n1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__3 = i__ + (n1 + i__) * lda;
+ i__2 = lda;
+ for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij +=
+ i__2) {
+ i__4 = ijp;
+ r_cnjg(&q__1, &arf[ij]);
+ ap[i__4].r = q__1.r, ap[i__4].i = q__1.i;
+ ++ijp;
+ }
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
+/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */
+
+ ijp = 0;
+ jp = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ij = i__ + 1 + jp;
+ i__3 = ijp;
+ i__4 = ij;
+ ap[i__3].r = arf[i__4].r, ap[i__3].i = arf[i__4].i;
+ ++ijp;
+ }
+ jp += lda;
+ }
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = k - 1;
+ for (j = i__; j <= i__2; ++j) {
+ ij = i__ + j * lda;
+ i__3 = ijp;
+ r_cnjg(&q__1, &arf[ij]);
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+ ++ijp;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
+/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */
+
+ ijp = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ ij = k + 1 + j;
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ijp;
+ r_cnjg(&q__1, &arf[ij]);
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+ ++ijp;
+ ij += lda;
+ }
+ }
+ js = 0;
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+ ij = js;
+ i__2 = js + j;
+ for (ij = js; ij <= i__2; ++ij) {
+ i__3 = ijp;
+ i__4 = ij;
+ ap[i__3].r = arf[i__4].r, ap[i__3].i = arf[i__4].i;
+ ++ijp;
+ }
+ js += lda;
+ }
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */
+/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */
+
+ ijp = 0;
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = (*n + 1) * lda - 1;
+ i__3 = lda;
+ for (ij = i__ + (i__ + 1) * lda; i__3 < 0 ? ij >= i__2 :
+ ij <= i__2; ij += i__3) {
+ i__4 = ijp;
+ r_cnjg(&q__1, &arf[ij]);
+ ap[i__4].r = q__1.r, ap[i__4].i = q__1.i;
+ ++ijp;
+ }
+ }
+ js = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + k - j - 1;
+ for (ij = js; ij <= i__3; ++ij) {
+ i__2 = ijp;
+ i__4 = ij;
+ ap[i__2].r = arf[i__4].r, ap[i__2].i = arf[i__4].i;
+ ++ijp;
+ }
+ js = js + lda + 1;
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */
+/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */
+
+ ijp = 0;
+ js = (k + 1) * lda;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + j;
+ for (ij = js; ij <= i__3; ++ij) {
+ i__2 = ijp;
+ i__4 = ij;
+ ap[i__2].r = arf[i__4].r, ap[i__2].i = arf[i__4].i;
+ ++ijp;
+ }
+ js += lda;
+ }
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__3 = i__ + (k + i__) * lda;
+ i__2 = lda;
+ for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij +=
+ i__2) {
+ i__4 = ijp;
+ r_cnjg(&q__1, &arf[ij]);
+ ap[i__4].r = q__1.r, ap[i__4].i = q__1.i;
+ ++ijp;
+ }
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of CTFTTP */
+
+} /* ctfttp_ */
diff --git a/SRC/ctfttr.c b/SRC/ctfttr.c
new file mode 100644
index 0000000..a927b2d
--- /dev/null
+++ b/SRC/ctfttr.c
@@ -0,0 +1,580 @@
+/* ctfttr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ctfttr_(char *transr, char *uplo, integer *n, complex *
+ arf, complex *a, integer *lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ complex q__1;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k, l, n1, n2, ij, nt, nx2, np1x2;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nisodd;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTFTTR copies a triangular matrix A from rectangular full packed */
+/* format (TF) to standard full format (TR). */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': ARF is in Normal format; */
+/* = 'C': ARF is in Conjugate-transpose format; */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* ARF (input) COMPLEX array, dimension ( N*(N+1)/2 ), */
+/* On entry, the upper or lower triangular matrix A stored in */
+/* RFP format. For a further discussion see Notes below. */
+
+/* A (output) COMPLEX array, dimension ( LDA, N ) */
+/* On exit, the triangular matrix A. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of the array A contains */
+/* the upper triangular matrix, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of the array A contains */
+/* the lower triangular matrix, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Notes: */
+/* ====== */
+
+/* We first consider Standard Packed Format when N is even. */
+/* We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* conjugate-transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* conjugate-transpose of the last three columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- -- */
+/* 03 04 05 33 43 53 */
+/* -- -- */
+/* 13 14 15 00 44 54 */
+/* -- */
+/* 23 24 25 10 11 55 */
+
+/* 33 34 35 20 21 22 */
+/* -- */
+/* 00 44 45 30 31 32 */
+/* -- -- */
+/* 01 11 55 40 41 42 */
+/* -- -- -- */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We next consider Standard Packed Format when N is odd. */
+/* We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* conjugate-transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* conjugate-transpose of the last two columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- */
+/* 02 03 04 00 33 43 */
+/* -- */
+/* 12 13 14 10 11 44 */
+
+/* 22 23 24 20 21 22 */
+/* -- */
+/* 00 33 34 30 31 32 */
+/* -- -- */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- */
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda - 1 - 0 + 1;
+ a_offset = 0 + a_dim1 * 0;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "C")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTFTTR", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 1) {
+ if (*n == 1) {
+ if (normaltransr) {
+ a[0].r = arf[0].r, a[0].i = arf[0].i;
+ } else {
+ r_cnjg(&q__1, arf);
+ a[0].r = q__1.r, a[0].i = q__1.i;
+ }
+ }
+ return 0;
+ }
+
+/* Size of array ARF(1:2,0:nt-1) */
+
+ nt = *n * (*n + 1) / 2;
+
+/* set N1 and N2 depending on LOWER: for N even N1=N2=K */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. */
+/* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is */
+/* N--by--(N+1)/2. */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ if (! lower) {
+ np1x2 = *n + *n + 2;
+ }
+ } else {
+ nisodd = TRUE_;
+ if (! lower) {
+ nx2 = *n + *n;
+ }
+ }
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */
+/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */
+/* T1 -> a(0), T2 -> a(n), S -> a(n1); lda=n */
+
+ ij = 0;
+ i__1 = n2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = n2 + j;
+ for (i__ = n1; i__ <= i__2; ++i__) {
+ i__3 = n2 + j + i__ * a_dim1;
+ r_cnjg(&q__1, &arf[ij]);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = ij;
+ a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i;
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */
+/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */
+/* T1 -> a(n2), T2 -> a(n1), S -> a(0); lda=n */
+
+ ij = nt - *n;
+ i__1 = n1;
+ for (j = *n - 1; j >= i__1; --j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = ij;
+ a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i;
+ ++ij;
+ }
+ i__2 = n1 - 1;
+ for (l = j - n1; l <= i__2; ++l) {
+ i__3 = j - n1 + l * a_dim1;
+ r_cnjg(&q__1, &arf[ij]);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ ++ij;
+ }
+ ij -= nx2;
+ }
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is odd */
+/* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */
+/* T1 -> A(0+0) , T2 -> A(1+0) , S -> A(0+n1*n1); lda=n1 */
+
+ ij = 0;
+ i__1 = n2 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * a_dim1;
+ r_cnjg(&q__1, &arf[ij]);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = n1 + j; i__ <= i__2; ++i__) {
+ i__3 = i__ + (n1 + j) * a_dim1;
+ i__4 = ij;
+ a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i;
+ ++ij;
+ }
+ }
+ i__1 = *n - 1;
+ for (j = n2; j <= i__1; ++j) {
+ i__2 = n1 - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * a_dim1;
+ r_cnjg(&q__1, &arf[ij]);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is odd */
+/* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */
+/* T1 -> A(n2*n2), T2 -> A(n1*n2), S -> A(0); lda = n2 */
+
+ ij = 0;
+ i__1 = n1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = n1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * a_dim1;
+ r_cnjg(&q__1, &arf[ij]);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ ++ij;
+ }
+ }
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = ij;
+ a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (l = n2 + j; l <= i__2; ++l) {
+ i__3 = n2 + j + l * a_dim1;
+ r_cnjg(&q__1, &arf[ij]);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ ++ij;
+ }
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
+/* T1 -> a(1), T2 -> a(0), S -> a(k+1); lda=n+1 */
+
+ ij = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k + j;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ i__3 = k + j + i__ * a_dim1;
+ r_cnjg(&q__1, &arf[ij]);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = ij;
+ a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i;
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
+/* T1 -> a(k+1), T2 -> a(k), S -> a(0); lda=n+1 */
+
+ ij = nt - *n - 1;
+ i__1 = k;
+ for (j = *n - 1; j >= i__1; --j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = ij;
+ a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i;
+ ++ij;
+ }
+ i__2 = k - 1;
+ for (l = j - k; l <= i__2; ++l) {
+ i__3 = j - k + l * a_dim1;
+ r_cnjg(&q__1, &arf[ij]);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ ++ij;
+ }
+ ij -= np1x2;
+ }
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is even (see paper, A=B) */
+/* T1 -> A(0,1) , T2 -> A(0,0) , S -> A(0,k+1) : */
+/* T1 -> A(0+k) , T2 -> A(0+0) , S -> A(0+k*(k+1)); lda=k */
+
+ ij = 0;
+ j = k;
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * a_dim1;
+ i__3 = ij;
+ a[i__2].r = arf[i__3].r, a[i__2].i = arf[i__3].i;
+ ++ij;
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * a_dim1;
+ r_cnjg(&q__1, &arf[ij]);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = k + 1 + j; i__ <= i__2; ++i__) {
+ i__3 = i__ + (k + 1 + j) * a_dim1;
+ i__4 = ij;
+ a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i;
+ ++ij;
+ }
+ }
+ i__1 = *n - 1;
+ for (j = k - 1; j <= i__1; ++j) {
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * a_dim1;
+ r_cnjg(&q__1, &arf[ij]);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is even (see paper, A=B) */
+/* T1 -> A(0,k+1) , T2 -> A(0,k) , S -> A(0,0) */
+/* T1 -> A(0+k*(k+1)) , T2 -> A(0+k*k) , S -> A(0+0)); lda=k */
+
+ ij = 0;
+ i__1 = k;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * a_dim1;
+ r_cnjg(&q__1, &arf[ij]);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ ++ij;
+ }
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = ij;
+ a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (l = k + 1 + j; l <= i__2; ++l) {
+ i__3 = k + 1 + j + l * a_dim1;
+ r_cnjg(&q__1, &arf[ij]);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ ++ij;
+ }
+ }
+
+/* Note that here J = K-1 */
+
+ i__1 = j;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * a_dim1;
+ i__3 = ij;
+ a[i__2].r = arf[i__3].r, a[i__2].i = arf[i__3].i;
+ ++ij;
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of CTFTTR */
+
+} /* ctfttr_ */
diff --git a/SRC/ctgevc.c b/SRC/ctgevc.c
new file mode 100644
index 0000000..7aeae85
--- /dev/null
+++ b/SRC/ctgevc.c
@@ -0,0 +1,971 @@
+/* ctgevc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int ctgevc_(char *side, char *howmny, logical *select,
+ integer *n, complex *s, integer *lds, complex *p, integer *ldp,
+ complex *vl, integer *ldvl, complex *vr, integer *ldvr, integer *mm,
+ integer *m, complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer p_dim1, p_offset, s_dim1, s_offset, vl_dim1, vl_offset, vr_dim1,
+ vr_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4, r__5, r__6;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ complex d__;
+ integer i__, j;
+ complex ca, cb;
+ integer je, im, jr;
+ real big;
+ logical lsa, lsb;
+ real ulp;
+ complex sum;
+ integer ibeg, ieig, iend;
+ real dmin__;
+ integer isrc;
+ real temp;
+ complex suma, sumb;
+ real xmax, scale;
+ logical ilall;
+ integer iside;
+ real sbeta;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *);
+ real small;
+ logical compl;
+ real anorm, bnorm;
+ logical compr, ilbbad;
+ real acoefa, bcoefa, acoeff;
+ complex bcoeff;
+ logical ilback;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ real ascale, bscale;
+ extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
+ extern doublereal slamch_(char *);
+ complex salpha;
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ logical ilcomp;
+ integer ihwmny;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+
+/* Purpose */
+/* ======= */
+
+/* CTGEVC computes some or all of the right and/or left eigenvectors of */
+/* a pair of complex matrices (S,P), where S and P are upper triangular. */
+/* Matrix pairs of this type are produced by the generalized Schur */
+/* factorization of a complex matrix pair (A,B): */
+
+/* A = Q*S*Z**H, B = Q*P*Z**H */
+
+/* as computed by CGGHRD + CHGEQZ. */
+
+/* The right eigenvector x and the left eigenvector y of (S,P) */
+/* corresponding to an eigenvalue w are defined by: */
+
+/* S*x = w*P*x, (y**H)*S = w*(y**H)*P, */
+
+/* where y**H denotes the conjugate tranpose of y. */
+/* The eigenvalues are not input to this routine, but are computed */
+/* directly from the diagonal elements of S and P. */
+
+/* This routine returns the matrices X and/or Y of right and left */
+/* eigenvectors of (S,P), or the products Z*X and/or Q*Y, */
+/* where Z and Q are input matrices. */
+/* If Q and Z are the unitary factors from the generalized Schur */
+/* factorization of a matrix pair (A,B), then Z*X and Q*Y */
+/* are the matrices of right and left eigenvectors of (A,B). */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'R': compute right eigenvectors only; */
+/* = 'L': compute left eigenvectors only; */
+/* = 'B': compute both right and left eigenvectors. */
+
+/* HOWMNY (input) CHARACTER*1 */
+/* = 'A': compute all right and/or left eigenvectors; */
+/* = 'B': compute all right and/or left eigenvectors, */
+/* backtransformed by the matrices in VR and/or VL; */
+/* = 'S': compute selected right and/or left eigenvectors, */
+/* specified by the logical array SELECT. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* If HOWMNY='S', SELECT specifies the eigenvectors to be */
+/* computed. The eigenvector corresponding to the j-th */
+/* eigenvalue is computed if SELECT(j) = .TRUE.. */
+/* Not referenced if HOWMNY = 'A' or 'B'. */
+
+/* N (input) INTEGER */
+/* The order of the matrices S and P. N >= 0. */
+
+/* S (input) COMPLEX array, dimension (LDS,N) */
+/* The upper triangular matrix S from a generalized Schur */
+/* factorization, as computed by CHGEQZ. */
+
+/* LDS (input) INTEGER */
+/* The leading dimension of array S. LDS >= max(1,N). */
+
+/* P (input) COMPLEX array, dimension (LDP,N) */
+/* The upper triangular matrix P from a generalized Schur */
+/* factorization, as computed by CHGEQZ. P must have real */
+/* diagonal elements. */
+
+/* LDP (input) INTEGER */
+/* The leading dimension of array P. LDP >= max(1,N). */
+
+/* VL (input/output) COMPLEX array, dimension (LDVL,MM) */
+/* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */
+/* contain an N-by-N matrix Q (usually the unitary matrix Q */
+/* of left Schur vectors returned by CHGEQZ). */
+/* On exit, if SIDE = 'L' or 'B', VL contains: */
+/* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); */
+/* if HOWMNY = 'B', the matrix Q*Y; */
+/* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by */
+/* SELECT, stored consecutively in the columns of */
+/* VL, in the same order as their eigenvalues. */
+/* Not referenced if SIDE = 'R'. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of array VL. LDVL >= 1, and if */
+/* SIDE = 'L' or 'l' or 'B' or 'b', LDVL >= N. */
+
+/* VR (input/output) COMPLEX array, dimension (LDVR,MM) */
+/* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */
+/* contain an N-by-N matrix Q (usually the unitary matrix Z */
+/* of right Schur vectors returned by CHGEQZ). */
+/* On exit, if SIDE = 'R' or 'B', VR contains: */
+/* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); */
+/* if HOWMNY = 'B', the matrix Z*X; */
+/* if HOWMNY = 'S', the right eigenvectors of (S,P) specified by */
+/* SELECT, stored consecutively in the columns of */
+/* VR, in the same order as their eigenvalues. */
+/* Not referenced if SIDE = 'L'. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. LDVR >= 1, and if */
+/* SIDE = 'R' or 'B', LDVR >= N. */
+
+/* MM (input) INTEGER */
+/* The number of columns in the arrays VL and/or VR. MM >= M. */
+
+/* M (output) INTEGER */
+/* The number of columns in the arrays VL and/or VR actually */
+/* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M */
+/* is set to N. Each selected eigenvector occupies one column. */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and Test the input parameters */
+
+ /* Parameter adjustments */
+ --select;
+ s_dim1 = *lds;
+ s_offset = 1 + s_dim1;
+ s -= s_offset;
+ p_dim1 = *ldp;
+ p_offset = 1 + p_dim1;
+ p -= p_offset;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ if (lsame_(howmny, "A")) {
+ ihwmny = 1;
+ ilall = TRUE_;
+ ilback = FALSE_;
+ } else if (lsame_(howmny, "S")) {
+ ihwmny = 2;
+ ilall = FALSE_;
+ ilback = FALSE_;
+ } else if (lsame_(howmny, "B")) {
+ ihwmny = 3;
+ ilall = TRUE_;
+ ilback = TRUE_;
+ } else {
+ ihwmny = -1;
+ }
+
+ if (lsame_(side, "R")) {
+ iside = 1;
+ compl = FALSE_;
+ compr = TRUE_;
+ } else if (lsame_(side, "L")) {
+ iside = 2;
+ compl = TRUE_;
+ compr = FALSE_;
+ } else if (lsame_(side, "B")) {
+ iside = 3;
+ compl = TRUE_;
+ compr = TRUE_;
+ } else {
+ iside = -1;
+ }
+
+ *info = 0;
+ if (iside < 0) {
+ *info = -1;
+ } else if (ihwmny < 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lds < max(1,*n)) {
+ *info = -6;
+ } else if (*ldp < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTGEVC", &i__1);
+ return 0;
+ }
+
+/* Count the number of eigenvectors */
+
+ if (! ilall) {
+ im = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (select[j]) {
+ ++im;
+ }
+/* L10: */
+ }
+ } else {
+ im = *n;
+ }
+
+/* Check diagonal of B */
+
+ ilbbad = FALSE_;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (r_imag(&p[j + j * p_dim1]) != 0.f) {
+ ilbbad = TRUE_;
+ }
+/* L20: */
+ }
+
+ if (ilbbad) {
+ *info = -7;
+ } else if (compl && *ldvl < *n || *ldvl < 1) {
+ *info = -10;
+ } else if (compr && *ldvr < *n || *ldvr < 1) {
+ *info = -12;
+ } else if (*mm < im) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTGEVC", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = im;
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Machine Constants */
+
+ safmin = slamch_("Safe minimum");
+ big = 1.f / safmin;
+ slabad_(&safmin, &big);
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ small = safmin * *n / ulp;
+ big = 1.f / small;
+ bignum = 1.f / (safmin * *n);
+
+/* Compute the 1-norm of each column of the strictly upper triangular */
+/* part of A and B to check for possible overflow in the triangular */
+/* solver. */
+
+ i__1 = s_dim1 + 1;
+ anorm = (r__1 = s[i__1].r, dabs(r__1)) + (r__2 = r_imag(&s[s_dim1 + 1]),
+ dabs(r__2));
+ i__1 = p_dim1 + 1;
+ bnorm = (r__1 = p[i__1].r, dabs(r__1)) + (r__2 = r_imag(&p[p_dim1 + 1]),
+ dabs(r__2));
+ rwork[1] = 0.f;
+ rwork[*n + 1] = 0.f;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ rwork[j] = 0.f;
+ rwork[*n + j] = 0.f;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * s_dim1;
+ rwork[j] += (r__1 = s[i__3].r, dabs(r__1)) + (r__2 = r_imag(&s[
+ i__ + j * s_dim1]), dabs(r__2));
+ i__3 = i__ + j * p_dim1;
+ rwork[*n + j] += (r__1 = p[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ p[i__ + j * p_dim1]), dabs(r__2));
+/* L30: */
+ }
+/* Computing MAX */
+ i__2 = j + j * s_dim1;
+ r__3 = anorm, r__4 = rwork[j] + ((r__1 = s[i__2].r, dabs(r__1)) + (
+ r__2 = r_imag(&s[j + j * s_dim1]), dabs(r__2)));
+ anorm = dmax(r__3,r__4);
+/* Computing MAX */
+ i__2 = j + j * p_dim1;
+ r__3 = bnorm, r__4 = rwork[*n + j] + ((r__1 = p[i__2].r, dabs(r__1))
+ + (r__2 = r_imag(&p[j + j * p_dim1]), dabs(r__2)));
+ bnorm = dmax(r__3,r__4);
+/* L40: */
+ }
+
+ ascale = 1.f / dmax(anorm,safmin);
+ bscale = 1.f / dmax(bnorm,safmin);
+
+/* Left eigenvectors */
+
+ if (compl) {
+ ieig = 0;
+
+/* Main loop over eigenvalues */
+
+ i__1 = *n;
+ for (je = 1; je <= i__1; ++je) {
+ if (ilall) {
+ ilcomp = TRUE_;
+ } else {
+ ilcomp = select[je];
+ }
+ if (ilcomp) {
+ ++ieig;
+
+ i__2 = je + je * s_dim1;
+ i__3 = je + je * p_dim1;
+ if ((r__2 = s[i__2].r, dabs(r__2)) + (r__3 = r_imag(&s[je +
+ je * s_dim1]), dabs(r__3)) <= safmin && (r__1 = p[
+ i__3].r, dabs(r__1)) <= safmin) {
+
+/* Singular matrix pencil -- return unit eigenvector */
+
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = jr + ieig * vl_dim1;
+ vl[i__3].r = 0.f, vl[i__3].i = 0.f;
+/* L50: */
+ }
+ i__2 = ieig + ieig * vl_dim1;
+ vl[i__2].r = 1.f, vl[i__2].i = 0.f;
+ goto L140;
+ }
+
+/* Non-singular eigenvalue: */
+/* Compute coefficients a and b in */
+/* H */
+/* y ( a A - b B ) = 0 */
+
+/* Computing MAX */
+ i__2 = je + je * s_dim1;
+ i__3 = je + je * p_dim1;
+ r__4 = ((r__2 = s[i__2].r, dabs(r__2)) + (r__3 = r_imag(&s[je
+ + je * s_dim1]), dabs(r__3))) * ascale, r__5 = (r__1 =
+ p[i__3].r, dabs(r__1)) * bscale, r__4 = max(r__4,
+ r__5);
+ temp = 1.f / dmax(r__4,safmin);
+ i__2 = je + je * s_dim1;
+ q__2.r = temp * s[i__2].r, q__2.i = temp * s[i__2].i;
+ q__1.r = ascale * q__2.r, q__1.i = ascale * q__2.i;
+ salpha.r = q__1.r, salpha.i = q__1.i;
+ i__2 = je + je * p_dim1;
+ sbeta = temp * p[i__2].r * bscale;
+ acoeff = sbeta * ascale;
+ q__1.r = bscale * salpha.r, q__1.i = bscale * salpha.i;
+ bcoeff.r = q__1.r, bcoeff.i = q__1.i;
+
+/* Scale to avoid underflow */
+
+ lsa = dabs(sbeta) >= safmin && dabs(acoeff) < small;
+ lsb = (r__1 = salpha.r, dabs(r__1)) + (r__2 = r_imag(&salpha),
+ dabs(r__2)) >= safmin && (r__3 = bcoeff.r, dabs(r__3)
+ ) + (r__4 = r_imag(&bcoeff), dabs(r__4)) < small;
+
+ scale = 1.f;
+ if (lsa) {
+ scale = small / dabs(sbeta) * dmin(anorm,big);
+ }
+ if (lsb) {
+/* Computing MAX */
+ r__3 = scale, r__4 = small / ((r__1 = salpha.r, dabs(r__1)
+ ) + (r__2 = r_imag(&salpha), dabs(r__2))) * dmin(
+ bnorm,big);
+ scale = dmax(r__3,r__4);
+ }
+ if (lsa || lsb) {
+/* Computing MIN */
+/* Computing MAX */
+ r__5 = 1.f, r__6 = dabs(acoeff), r__5 = max(r__5,r__6),
+ r__6 = (r__1 = bcoeff.r, dabs(r__1)) + (r__2 =
+ r_imag(&bcoeff), dabs(r__2));
+ r__3 = scale, r__4 = 1.f / (safmin * dmax(r__5,r__6));
+ scale = dmin(r__3,r__4);
+ if (lsa) {
+ acoeff = ascale * (scale * sbeta);
+ } else {
+ acoeff = scale * acoeff;
+ }
+ if (lsb) {
+ q__2.r = scale * salpha.r, q__2.i = scale * salpha.i;
+ q__1.r = bscale * q__2.r, q__1.i = bscale * q__2.i;
+ bcoeff.r = q__1.r, bcoeff.i = q__1.i;
+ } else {
+ q__1.r = scale * bcoeff.r, q__1.i = scale * bcoeff.i;
+ bcoeff.r = q__1.r, bcoeff.i = q__1.i;
+ }
+ }
+
+ acoefa = dabs(acoeff);
+ bcoefa = (r__1 = bcoeff.r, dabs(r__1)) + (r__2 = r_imag(&
+ bcoeff), dabs(r__2));
+ xmax = 1.f;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = jr;
+ work[i__3].r = 0.f, work[i__3].i = 0.f;
+/* L60: */
+ }
+ i__2 = je;
+ work[i__2].r = 1.f, work[i__2].i = 0.f;
+/* Computing MAX */
+ r__1 = ulp * acoefa * anorm, r__2 = ulp * bcoefa * bnorm,
+ r__1 = max(r__1,r__2);
+ dmin__ = dmax(r__1,safmin);
+
+/* H */
+/* Triangular solve of (a A - b B) y = 0 */
+
+/* H */
+/* (rowwise in (a A - b B) , or columnwise in a A - b B) */
+
+ i__2 = *n;
+ for (j = je + 1; j <= i__2; ++j) {
+
+/* Compute */
+/* j-1 */
+/* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) */
+/* k=je */
+/* (Scale if necessary) */
+
+ temp = 1.f / xmax;
+ if (acoefa * rwork[j] + bcoefa * rwork[*n + j] > bignum *
+ temp) {
+ i__3 = j - 1;
+ for (jr = je; jr <= i__3; ++jr) {
+ i__4 = jr;
+ i__5 = jr;
+ q__1.r = temp * work[i__5].r, q__1.i = temp *
+ work[i__5].i;
+ work[i__4].r = q__1.r, work[i__4].i = q__1.i;
+/* L70: */
+ }
+ xmax = 1.f;
+ }
+ suma.r = 0.f, suma.i = 0.f;
+ sumb.r = 0.f, sumb.i = 0.f;
+
+ i__3 = j - 1;
+ for (jr = je; jr <= i__3; ++jr) {
+ r_cnjg(&q__3, &s[jr + j * s_dim1]);
+ i__4 = jr;
+ q__2.r = q__3.r * work[i__4].r - q__3.i * work[i__4]
+ .i, q__2.i = q__3.r * work[i__4].i + q__3.i *
+ work[i__4].r;
+ q__1.r = suma.r + q__2.r, q__1.i = suma.i + q__2.i;
+ suma.r = q__1.r, suma.i = q__1.i;
+ r_cnjg(&q__3, &p[jr + j * p_dim1]);
+ i__4 = jr;
+ q__2.r = q__3.r * work[i__4].r - q__3.i * work[i__4]
+ .i, q__2.i = q__3.r * work[i__4].i + q__3.i *
+ work[i__4].r;
+ q__1.r = sumb.r + q__2.r, q__1.i = sumb.i + q__2.i;
+ sumb.r = q__1.r, sumb.i = q__1.i;
+/* L80: */
+ }
+ q__2.r = acoeff * suma.r, q__2.i = acoeff * suma.i;
+ r_cnjg(&q__4, &bcoeff);
+ q__3.r = q__4.r * sumb.r - q__4.i * sumb.i, q__3.i =
+ q__4.r * sumb.i + q__4.i * sumb.r;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ sum.r = q__1.r, sum.i = q__1.i;
+
+/* Form x(j) = - SUM / conjg( a*S(j,j) - b*P(j,j) ) */
+
+/* with scaling and perturbation of the denominator */
+
+ i__3 = j + j * s_dim1;
+ q__3.r = acoeff * s[i__3].r, q__3.i = acoeff * s[i__3].i;
+ i__4 = j + j * p_dim1;
+ q__4.r = bcoeff.r * p[i__4].r - bcoeff.i * p[i__4].i,
+ q__4.i = bcoeff.r * p[i__4].i + bcoeff.i * p[i__4]
+ .r;
+ q__2.r = q__3.r - q__4.r, q__2.i = q__3.i - q__4.i;
+ r_cnjg(&q__1, &q__2);
+ d__.r = q__1.r, d__.i = q__1.i;
+ if ((r__1 = d__.r, dabs(r__1)) + (r__2 = r_imag(&d__),
+ dabs(r__2)) <= dmin__) {
+ q__1.r = dmin__, q__1.i = 0.f;
+ d__.r = q__1.r, d__.i = q__1.i;
+ }
+
+ if ((r__1 = d__.r, dabs(r__1)) + (r__2 = r_imag(&d__),
+ dabs(r__2)) < 1.f) {
+ if ((r__1 = sum.r, dabs(r__1)) + (r__2 = r_imag(&sum),
+ dabs(r__2)) >= bignum * ((r__3 = d__.r, dabs(
+ r__3)) + (r__4 = r_imag(&d__), dabs(r__4)))) {
+ temp = 1.f / ((r__1 = sum.r, dabs(r__1)) + (r__2 =
+ r_imag(&sum), dabs(r__2)));
+ i__3 = j - 1;
+ for (jr = je; jr <= i__3; ++jr) {
+ i__4 = jr;
+ i__5 = jr;
+ q__1.r = temp * work[i__5].r, q__1.i = temp *
+ work[i__5].i;
+ work[i__4].r = q__1.r, work[i__4].i = q__1.i;
+/* L90: */
+ }
+ xmax = temp * xmax;
+ q__1.r = temp * sum.r, q__1.i = temp * sum.i;
+ sum.r = q__1.r, sum.i = q__1.i;
+ }
+ }
+ i__3 = j;
+ q__2.r = -sum.r, q__2.i = -sum.i;
+ cladiv_(&q__1, &q__2, &d__);
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* Computing MAX */
+ i__3 = j;
+ r__3 = xmax, r__4 = (r__1 = work[i__3].r, dabs(r__1)) + (
+ r__2 = r_imag(&work[j]), dabs(r__2));
+ xmax = dmax(r__3,r__4);
+/* L100: */
+ }
+
+/* Back transform eigenvector if HOWMNY='B'. */
+
+ if (ilback) {
+ i__2 = *n + 1 - je;
+ cgemv_("N", n, &i__2, &c_b2, &vl[je * vl_dim1 + 1], ldvl,
+ &work[je], &c__1, &c_b1, &work[*n + 1], &c__1);
+ isrc = 2;
+ ibeg = 1;
+ } else {
+ isrc = 1;
+ ibeg = je;
+ }
+
+/* Copy and scale eigenvector into column of VL */
+
+ xmax = 0.f;
+ i__2 = *n;
+ for (jr = ibeg; jr <= i__2; ++jr) {
+/* Computing MAX */
+ i__3 = (isrc - 1) * *n + jr;
+ r__3 = xmax, r__4 = (r__1 = work[i__3].r, dabs(r__1)) + (
+ r__2 = r_imag(&work[(isrc - 1) * *n + jr]), dabs(
+ r__2));
+ xmax = dmax(r__3,r__4);
+/* L110: */
+ }
+
+ if (xmax > safmin) {
+ temp = 1.f / xmax;
+ i__2 = *n;
+ for (jr = ibeg; jr <= i__2; ++jr) {
+ i__3 = jr + ieig * vl_dim1;
+ i__4 = (isrc - 1) * *n + jr;
+ q__1.r = temp * work[i__4].r, q__1.i = temp * work[
+ i__4].i;
+ vl[i__3].r = q__1.r, vl[i__3].i = q__1.i;
+/* L120: */
+ }
+ } else {
+ ibeg = *n + 1;
+ }
+
+ i__2 = ibeg - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = jr + ieig * vl_dim1;
+ vl[i__3].r = 0.f, vl[i__3].i = 0.f;
+/* L130: */
+ }
+
+ }
+L140:
+ ;
+ }
+ }
+
+/* Right eigenvectors */
+
+ if (compr) {
+ ieig = im + 1;
+
+/* Main loop over eigenvalues */
+
+ for (je = *n; je >= 1; --je) {
+ if (ilall) {
+ ilcomp = TRUE_;
+ } else {
+ ilcomp = select[je];
+ }
+ if (ilcomp) {
+ --ieig;
+
+ i__1 = je + je * s_dim1;
+ i__2 = je + je * p_dim1;
+ if ((r__2 = s[i__1].r, dabs(r__2)) + (r__3 = r_imag(&s[je +
+ je * s_dim1]), dabs(r__3)) <= safmin && (r__1 = p[
+ i__2].r, dabs(r__1)) <= safmin) {
+
+/* Singular matrix pencil -- return unit eigenvector */
+
+ i__1 = *n;
+ for (jr = 1; jr <= i__1; ++jr) {
+ i__2 = jr + ieig * vr_dim1;
+ vr[i__2].r = 0.f, vr[i__2].i = 0.f;
+/* L150: */
+ }
+ i__1 = ieig + ieig * vr_dim1;
+ vr[i__1].r = 1.f, vr[i__1].i = 0.f;
+ goto L250;
+ }
+
+/* Non-singular eigenvalue: */
+/* Compute coefficients a and b in */
+
+/* ( a A - b B ) x = 0 */
+
+/* Computing MAX */
+ i__1 = je + je * s_dim1;
+ i__2 = je + je * p_dim1;
+ r__4 = ((r__2 = s[i__1].r, dabs(r__2)) + (r__3 = r_imag(&s[je
+ + je * s_dim1]), dabs(r__3))) * ascale, r__5 = (r__1 =
+ p[i__2].r, dabs(r__1)) * bscale, r__4 = max(r__4,
+ r__5);
+ temp = 1.f / dmax(r__4,safmin);
+ i__1 = je + je * s_dim1;
+ q__2.r = temp * s[i__1].r, q__2.i = temp * s[i__1].i;
+ q__1.r = ascale * q__2.r, q__1.i = ascale * q__2.i;
+ salpha.r = q__1.r, salpha.i = q__1.i;
+ i__1 = je + je * p_dim1;
+ sbeta = temp * p[i__1].r * bscale;
+ acoeff = sbeta * ascale;
+ q__1.r = bscale * salpha.r, q__1.i = bscale * salpha.i;
+ bcoeff.r = q__1.r, bcoeff.i = q__1.i;
+
+/* Scale to avoid underflow */
+
+ lsa = dabs(sbeta) >= safmin && dabs(acoeff) < small;
+ lsb = (r__1 = salpha.r, dabs(r__1)) + (r__2 = r_imag(&salpha),
+ dabs(r__2)) >= safmin && (r__3 = bcoeff.r, dabs(r__3)
+ ) + (r__4 = r_imag(&bcoeff), dabs(r__4)) < small;
+
+ scale = 1.f;
+ if (lsa) {
+ scale = small / dabs(sbeta) * dmin(anorm,big);
+ }
+ if (lsb) {
+/* Computing MAX */
+ r__3 = scale, r__4 = small / ((r__1 = salpha.r, dabs(r__1)
+ ) + (r__2 = r_imag(&salpha), dabs(r__2))) * dmin(
+ bnorm,big);
+ scale = dmax(r__3,r__4);
+ }
+ if (lsa || lsb) {
+/* Computing MIN */
+/* Computing MAX */
+ r__5 = 1.f, r__6 = dabs(acoeff), r__5 = max(r__5,r__6),
+ r__6 = (r__1 = bcoeff.r, dabs(r__1)) + (r__2 =
+ r_imag(&bcoeff), dabs(r__2));
+ r__3 = scale, r__4 = 1.f / (safmin * dmax(r__5,r__6));
+ scale = dmin(r__3,r__4);
+ if (lsa) {
+ acoeff = ascale * (scale * sbeta);
+ } else {
+ acoeff = scale * acoeff;
+ }
+ if (lsb) {
+ q__2.r = scale * salpha.r, q__2.i = scale * salpha.i;
+ q__1.r = bscale * q__2.r, q__1.i = bscale * q__2.i;
+ bcoeff.r = q__1.r, bcoeff.i = q__1.i;
+ } else {
+ q__1.r = scale * bcoeff.r, q__1.i = scale * bcoeff.i;
+ bcoeff.r = q__1.r, bcoeff.i = q__1.i;
+ }
+ }
+
+ acoefa = dabs(acoeff);
+ bcoefa = (r__1 = bcoeff.r, dabs(r__1)) + (r__2 = r_imag(&
+ bcoeff), dabs(r__2));
+ xmax = 1.f;
+ i__1 = *n;
+ for (jr = 1; jr <= i__1; ++jr) {
+ i__2 = jr;
+ work[i__2].r = 0.f, work[i__2].i = 0.f;
+/* L160: */
+ }
+ i__1 = je;
+ work[i__1].r = 1.f, work[i__1].i = 0.f;
+/* Computing MAX */
+ r__1 = ulp * acoefa * anorm, r__2 = ulp * bcoefa * bnorm,
+ r__1 = max(r__1,r__2);
+ dmin__ = dmax(r__1,safmin);
+
+/* Triangular solve of (a A - b B) x = 0 (columnwise) */
+
+/* WORK(1:j-1) contains sums w, */
+/* WORK(j+1:JE) contains x */
+
+ i__1 = je - 1;
+ for (jr = 1; jr <= i__1; ++jr) {
+ i__2 = jr;
+ i__3 = jr + je * s_dim1;
+ q__2.r = acoeff * s[i__3].r, q__2.i = acoeff * s[i__3].i;
+ i__4 = jr + je * p_dim1;
+ q__3.r = bcoeff.r * p[i__4].r - bcoeff.i * p[i__4].i,
+ q__3.i = bcoeff.r * p[i__4].i + bcoeff.i * p[i__4]
+ .r;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L170: */
+ }
+ i__1 = je;
+ work[i__1].r = 1.f, work[i__1].i = 0.f;
+
+ for (j = je - 1; j >= 1; --j) {
+
+/* Form x(j) := - w(j) / d */
+/* with scaling and perturbation of the denominator */
+
+ i__1 = j + j * s_dim1;
+ q__2.r = acoeff * s[i__1].r, q__2.i = acoeff * s[i__1].i;
+ i__2 = j + j * p_dim1;
+ q__3.r = bcoeff.r * p[i__2].r - bcoeff.i * p[i__2].i,
+ q__3.i = bcoeff.r * p[i__2].i + bcoeff.i * p[i__2]
+ .r;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ d__.r = q__1.r, d__.i = q__1.i;
+ if ((r__1 = d__.r, dabs(r__1)) + (r__2 = r_imag(&d__),
+ dabs(r__2)) <= dmin__) {
+ q__1.r = dmin__, q__1.i = 0.f;
+ d__.r = q__1.r, d__.i = q__1.i;
+ }
+
+ if ((r__1 = d__.r, dabs(r__1)) + (r__2 = r_imag(&d__),
+ dabs(r__2)) < 1.f) {
+ i__1 = j;
+ if ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[j]), dabs(r__2)) >= bignum * ((
+ r__3 = d__.r, dabs(r__3)) + (r__4 = r_imag(&
+ d__), dabs(r__4)))) {
+ i__1 = j;
+ temp = 1.f / ((r__1 = work[i__1].r, dabs(r__1)) +
+ (r__2 = r_imag(&work[j]), dabs(r__2)));
+ i__1 = je;
+ for (jr = 1; jr <= i__1; ++jr) {
+ i__2 = jr;
+ i__3 = jr;
+ q__1.r = temp * work[i__3].r, q__1.i = temp *
+ work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L180: */
+ }
+ }
+ }
+
+ i__1 = j;
+ i__2 = j;
+ q__2.r = -work[i__2].r, q__2.i = -work[i__2].i;
+ cladiv_(&q__1, &q__2, &d__);
+ work[i__1].r = q__1.r, work[i__1].i = q__1.i;
+
+ if (j > 1) {
+
+/* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling */
+
+ i__1 = j;
+ if ((r__1 = work[i__1].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[j]), dabs(r__2)) > 1.f) {
+ i__1 = j;
+ temp = 1.f / ((r__1 = work[i__1].r, dabs(r__1)) +
+ (r__2 = r_imag(&work[j]), dabs(r__2)));
+ if (acoefa * rwork[j] + bcoefa * rwork[*n + j] >=
+ bignum * temp) {
+ i__1 = je;
+ for (jr = 1; jr <= i__1; ++jr) {
+ i__2 = jr;
+ i__3 = jr;
+ q__1.r = temp * work[i__3].r, q__1.i =
+ temp * work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i =
+ q__1.i;
+/* L190: */
+ }
+ }
+ }
+
+ i__1 = j;
+ q__1.r = acoeff * work[i__1].r, q__1.i = acoeff *
+ work[i__1].i;
+ ca.r = q__1.r, ca.i = q__1.i;
+ i__1 = j;
+ q__1.r = bcoeff.r * work[i__1].r - bcoeff.i * work[
+ i__1].i, q__1.i = bcoeff.r * work[i__1].i +
+ bcoeff.i * work[i__1].r;
+ cb.r = q__1.r, cb.i = q__1.i;
+ i__1 = j - 1;
+ for (jr = 1; jr <= i__1; ++jr) {
+ i__2 = jr;
+ i__3 = jr;
+ i__4 = jr + j * s_dim1;
+ q__3.r = ca.r * s[i__4].r - ca.i * s[i__4].i,
+ q__3.i = ca.r * s[i__4].i + ca.i * s[i__4]
+ .r;
+ q__2.r = work[i__3].r + q__3.r, q__2.i = work[
+ i__3].i + q__3.i;
+ i__5 = jr + j * p_dim1;
+ q__4.r = cb.r * p[i__5].r - cb.i * p[i__5].i,
+ q__4.i = cb.r * p[i__5].i + cb.i * p[i__5]
+ .r;
+ q__1.r = q__2.r - q__4.r, q__1.i = q__2.i -
+ q__4.i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L200: */
+ }
+ }
+/* L210: */
+ }
+
+/* Back transform eigenvector if HOWMNY='B'. */
+
+ if (ilback) {
+ cgemv_("N", n, &je, &c_b2, &vr[vr_offset], ldvr, &work[1],
+ &c__1, &c_b1, &work[*n + 1], &c__1);
+ isrc = 2;
+ iend = *n;
+ } else {
+ isrc = 1;
+ iend = je;
+ }
+
+/* Copy and scale eigenvector into column of VR */
+
+ xmax = 0.f;
+ i__1 = iend;
+ for (jr = 1; jr <= i__1; ++jr) {
+/* Computing MAX */
+ i__2 = (isrc - 1) * *n + jr;
+ r__3 = xmax, r__4 = (r__1 = work[i__2].r, dabs(r__1)) + (
+ r__2 = r_imag(&work[(isrc - 1) * *n + jr]), dabs(
+ r__2));
+ xmax = dmax(r__3,r__4);
+/* L220: */
+ }
+
+ if (xmax > safmin) {
+ temp = 1.f / xmax;
+ i__1 = iend;
+ for (jr = 1; jr <= i__1; ++jr) {
+ i__2 = jr + ieig * vr_dim1;
+ i__3 = (isrc - 1) * *n + jr;
+ q__1.r = temp * work[i__3].r, q__1.i = temp * work[
+ i__3].i;
+ vr[i__2].r = q__1.r, vr[i__2].i = q__1.i;
+/* L230: */
+ }
+ } else {
+ iend = 0;
+ }
+
+ i__1 = *n;
+ for (jr = iend + 1; jr <= i__1; ++jr) {
+ i__2 = jr + ieig * vr_dim1;
+ vr[i__2].r = 0.f, vr[i__2].i = 0.f;
+/* L240: */
+ }
+
+ }
+L250:
+ ;
+ }
+ }
+
+ return 0;
+
+/* End of CTGEVC */
+
+} /* ctgevc_ */
diff --git a/SRC/ctgex2.c b/SRC/ctgex2.c
new file mode 100644
index 0000000..59846f2
--- /dev/null
+++ b/SRC/ctgex2.c
@@ -0,0 +1,373 @@
+/* ctgex2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* Subroutine */ int ctgex2_(logical *wantq, logical *wantz, integer *n,
+ complex *a, integer *lda, complex *b, integer *ldb, complex *q,
+ integer *ldq, complex *z__, integer *ldz, integer *j1, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
+ z_offset, i__1, i__2, i__3;
+ real r__1;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal), c_abs(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ complex f, g;
+ integer i__, m;
+ complex s[4] /* was [2][2] */, t[4] /* was [2][2] */;
+ real cq, sa, sb, cz;
+ complex sq;
+ real ss, ws;
+ complex sz;
+ real eps, sum;
+ logical weak;
+ complex cdum;
+ extern /* Subroutine */ int crot_(integer *, complex *, integer *,
+ complex *, integer *, real *, complex *);
+ complex work[8];
+ real scale;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), clartg_(complex *,
+ complex *, real *, complex *, complex *), classq_(integer *,
+ complex *, integer *, real *, real *);
+ real thresh, smlnum;
+ logical strong;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTGEX2 swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22) */
+/* in an upper triangular matrix pair (A, B) by an unitary equivalence */
+/* transformation. */
+
+/* (A, B) must be in generalized Schur canonical form, that is, A and */
+/* B are both upper triangular. */
+
+/* Optionally, the matrices Q and Z of generalized Schur vectors are */
+/* updated. */
+
+/* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' */
+/* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' */
+
+
+/* Arguments */
+/* ========= */
+
+/* WANTQ (input) LOGICAL */
+/* .TRUE. : update the left transformation matrix Q; */
+/* .FALSE.: do not update Q. */
+
+/* WANTZ (input) LOGICAL */
+/* .TRUE. : update the right transformation matrix Z; */
+/* .FALSE.: do not update Z. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) COMPLEX arrays, dimensions (LDA,N) */
+/* On entry, the matrix A in the pair (A, B). */
+/* On exit, the updated matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX arrays, dimensions (LDB,N) */
+/* On entry, the matrix B in the pair (A, B). */
+/* On exit, the updated matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Q (input/output) COMPLEX array, dimension (LDZ,N) */
+/* If WANTQ = .TRUE, on entry, the unitary matrix Q. On exit, */
+/* the updated matrix Q. */
+/* Not referenced if WANTQ = .FALSE.. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= 1; */
+/* If WANTQ = .TRUE., LDQ >= N. */
+
+/* Z (input/output) COMPLEX array, dimension (LDZ,N) */
+/* If WANTZ = .TRUE, on entry, the unitary matrix Z. On exit, */
+/* the updated matrix Z. */
+/* Not referenced if WANTZ = .FALSE.. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1; */
+/* If WANTZ = .TRUE., LDZ >= N. */
+
+/* J1 (input) INTEGER */
+/* The index to the first block (A11, B11). */
+
+/* INFO (output) INTEGER */
+/* =0: Successful exit. */
+/* =1: The transformed matrix pair (A, B) would be too far */
+/* from generalized Schur form; the problem is ill- */
+/* conditioned. */
+
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* In the current code both weak and strong stability tests are */
+/* performed. The user can omit the strong stability test by changing */
+/* the internal logical parameter WANDS to .FALSE.. See ref. [2] for */
+/* details. */
+
+/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
+/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
+/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
+/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
+
+/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
+/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
+/* Estimation: Theory, Algorithms and Software, Report UMINF-94.04, */
+/* Department of Computing Science, Umea University, S-901 87 Umea, */
+/* Sweden, 1994. Also as LAPACK Working Note 87. To appear in */
+/* Numerical Algorithms, 1996. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n <= 1) {
+ return 0;
+ }
+
+ m = 2;
+ weak = FALSE_;
+ strong = FALSE_;
+
+/* Make a local copy of selected block in (A, B) */
+
+ clacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, s, &c__2);
+ clacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, t, &c__2);
+
+/* Compute the threshold for testing the acceptance of swapping. */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S") / eps;
+ scale = 0.f;
+ sum = 1.f;
+ clacpy_("Full", &m, &m, s, &c__2, work, &m);
+ clacpy_("Full", &m, &m, t, &c__2, &work[m * m], &m);
+ i__1 = (m << 1) * m;
+ classq_(&i__1, work, &c__1, &scale, &sum);
+ sa = scale * sqrt(sum);
+/* Computing MAX */
+ r__1 = eps * 10.f * sa;
+ thresh = dmax(r__1,smlnum);
+
+/* Compute unitary QL and RQ that swap 1-by-1 and 1-by-1 blocks */
+/* using Givens rotations and perform the swap tentatively. */
+
+ q__2.r = s[3].r * t[0].r - s[3].i * t[0].i, q__2.i = s[3].r * t[0].i + s[
+ 3].i * t[0].r;
+ q__3.r = t[3].r * s[0].r - t[3].i * s[0].i, q__3.i = t[3].r * s[0].i + t[
+ 3].i * s[0].r;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ f.r = q__1.r, f.i = q__1.i;
+ q__2.r = s[3].r * t[2].r - s[3].i * t[2].i, q__2.i = s[3].r * t[2].i + s[
+ 3].i * t[2].r;
+ q__3.r = t[3].r * s[2].r - t[3].i * s[2].i, q__3.i = t[3].r * s[2].i + t[
+ 3].i * s[2].r;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ g.r = q__1.r, g.i = q__1.i;
+ sa = c_abs(&s[3]);
+ sb = c_abs(&t[3]);
+ clartg_(&g, &f, &cz, &sz, &cdum);
+ q__1.r = -sz.r, q__1.i = -sz.i;
+ sz.r = q__1.r, sz.i = q__1.i;
+ r_cnjg(&q__1, &sz);
+ crot_(&c__2, s, &c__1, &s[2], &c__1, &cz, &q__1);
+ r_cnjg(&q__1, &sz);
+ crot_(&c__2, t, &c__1, &t[2], &c__1, &cz, &q__1);
+ if (sa >= sb) {
+ clartg_(s, &s[1], &cq, &sq, &cdum);
+ } else {
+ clartg_(t, &t[1], &cq, &sq, &cdum);
+ }
+ crot_(&c__2, s, &c__2, &s[1], &c__2, &cq, &sq);
+ crot_(&c__2, t, &c__2, &t[1], &c__2, &cq, &sq);
+
+/* Weak stability test: |S21| + |T21| <= O(EPS F-norm((S, T))) */
+
+ ws = c_abs(&s[1]) + c_abs(&t[1]);
+ weak = ws <= thresh;
+ if (! weak) {
+ goto L20;
+ }
+
+ if (TRUE_) {
+
+/* Strong stability test: */
+/* F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A, B))) */
+
+ clacpy_("Full", &m, &m, s, &c__2, work, &m);
+ clacpy_("Full", &m, &m, t, &c__2, &work[m * m], &m);
+ r_cnjg(&q__2, &sz);
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ crot_(&c__2, work, &c__1, &work[2], &c__1, &cz, &q__1);
+ r_cnjg(&q__2, &sz);
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ crot_(&c__2, &work[4], &c__1, &work[6], &c__1, &cz, &q__1);
+ q__1.r = -sq.r, q__1.i = -sq.i;
+ crot_(&c__2, work, &c__2, &work[1], &c__2, &cq, &q__1);
+ q__1.r = -sq.r, q__1.i = -sq.i;
+ crot_(&c__2, &work[4], &c__2, &work[5], &c__2, &cq, &q__1);
+ for (i__ = 1; i__ <= 2; ++i__) {
+ i__1 = i__ - 1;
+ i__2 = i__ - 1;
+ i__3 = *j1 + i__ - 1 + *j1 * a_dim1;
+ q__1.r = work[i__2].r - a[i__3].r, q__1.i = work[i__2].i - a[i__3]
+ .i;
+ work[i__1].r = q__1.r, work[i__1].i = q__1.i;
+ i__1 = i__ + 1;
+ i__2 = i__ + 1;
+ i__3 = *j1 + i__ - 1 + (*j1 + 1) * a_dim1;
+ q__1.r = work[i__2].r - a[i__3].r, q__1.i = work[i__2].i - a[i__3]
+ .i;
+ work[i__1].r = q__1.r, work[i__1].i = q__1.i;
+ i__1 = i__ + 3;
+ i__2 = i__ + 3;
+ i__3 = *j1 + i__ - 1 + *j1 * b_dim1;
+ q__1.r = work[i__2].r - b[i__3].r, q__1.i = work[i__2].i - b[i__3]
+ .i;
+ work[i__1].r = q__1.r, work[i__1].i = q__1.i;
+ i__1 = i__ + 5;
+ i__2 = i__ + 5;
+ i__3 = *j1 + i__ - 1 + (*j1 + 1) * b_dim1;
+ q__1.r = work[i__2].r - b[i__3].r, q__1.i = work[i__2].i - b[i__3]
+ .i;
+ work[i__1].r = q__1.r, work[i__1].i = q__1.i;
+/* L10: */
+ }
+ scale = 0.f;
+ sum = 1.f;
+ i__1 = (m << 1) * m;
+ classq_(&i__1, work, &c__1, &scale, &sum);
+ ss = scale * sqrt(sum);
+ strong = ss <= thresh;
+ if (! strong) {
+ goto L20;
+ }
+ }
+
+/* If the swap is accepted ("weakly" and "strongly"), apply the */
+/* equivalence transformations to the original matrix pair (A,B) */
+
+ i__1 = *j1 + 1;
+ r_cnjg(&q__1, &sz);
+ crot_(&i__1, &a[*j1 * a_dim1 + 1], &c__1, &a[(*j1 + 1) * a_dim1 + 1], &
+ c__1, &cz, &q__1);
+ i__1 = *j1 + 1;
+ r_cnjg(&q__1, &sz);
+ crot_(&i__1, &b[*j1 * b_dim1 + 1], &c__1, &b[(*j1 + 1) * b_dim1 + 1], &
+ c__1, &cz, &q__1);
+ i__1 = *n - *j1 + 1;
+ crot_(&i__1, &a[*j1 + *j1 * a_dim1], lda, &a[*j1 + 1 + *j1 * a_dim1], lda,
+ &cq, &sq);
+ i__1 = *n - *j1 + 1;
+ crot_(&i__1, &b[*j1 + *j1 * b_dim1], ldb, &b[*j1 + 1 + *j1 * b_dim1], ldb,
+ &cq, &sq);
+
+/* Set N1 by N2 (2,1) blocks to 0 */
+
+ i__1 = *j1 + 1 + *j1 * a_dim1;
+ a[i__1].r = 0.f, a[i__1].i = 0.f;
+ i__1 = *j1 + 1 + *j1 * b_dim1;
+ b[i__1].r = 0.f, b[i__1].i = 0.f;
+
+/* Accumulate transformations into Q and Z if requested. */
+
+ if (*wantz) {
+ r_cnjg(&q__1, &sz);
+ crot_(n, &z__[*j1 * z_dim1 + 1], &c__1, &z__[(*j1 + 1) * z_dim1 + 1],
+ &c__1, &cz, &q__1);
+ }
+ if (*wantq) {
+ r_cnjg(&q__1, &sq);
+ crot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[(*j1 + 1) * q_dim1 + 1], &
+ c__1, &cq, &q__1);
+ }
+
+/* Exit with INFO = 0 if swap was successfully performed. */
+
+ return 0;
+
+/* Exit with INFO = 1 if swap was rejected. */
+
+L20:
+ *info = 1;
+ return 0;
+
+/* End of CTGEX2 */
+
+} /* ctgex2_ */
diff --git a/SRC/ctgexc.c b/SRC/ctgexc.c
new file mode 100644
index 0000000..2ef6ebc
--- /dev/null
+++ b/SRC/ctgexc.c
@@ -0,0 +1,248 @@
+/* ctgexc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ctgexc_(logical *wantq, logical *wantz, integer *n,
+ complex *a, integer *lda, complex *b, integer *ldb, complex *q,
+ integer *ldq, complex *z__, integer *ldz, integer *ifst, integer *
+ ilst, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
+ z_offset, i__1;
+
+ /* Local variables */
+ integer here;
+ extern /* Subroutine */ int ctgex2_(logical *, logical *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, integer *, integer *), xerbla_(char *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTGEXC reorders the generalized Schur decomposition of a complex */
+/* matrix pair (A,B), using an unitary equivalence transformation */
+/* (A, B) := Q * (A, B) * Z', so that the diagonal block of (A, B) with */
+/* row index IFST is moved to row ILST. */
+
+/* (A, B) must be in generalized Schur canonical form, that is, A and */
+/* B are both upper triangular. */
+
+/* Optionally, the matrices Q and Z of generalized Schur vectors are */
+/* updated. */
+
+/* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' */
+/* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' */
+
+/* Arguments */
+/* ========= */
+
+/* WANTQ (input) LOGICAL */
+/* .TRUE. : update the left transformation matrix Q; */
+/* .FALSE.: do not update Q. */
+
+/* WANTZ (input) LOGICAL */
+/* .TRUE. : update the right transformation matrix Z; */
+/* .FALSE.: do not update Z. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the upper triangular matrix A in the pair (A, B). */
+/* On exit, the updated matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,N) */
+/* On entry, the upper triangular matrix B in the pair (A, B). */
+/* On exit, the updated matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Q (input/output) COMPLEX array, dimension (LDZ,N) */
+/* On entry, if WANTQ = .TRUE., the unitary matrix Q. */
+/* On exit, the updated matrix Q. */
+/* If WANTQ = .FALSE., Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= 1; */
+/* If WANTQ = .TRUE., LDQ >= N. */
+
+/* Z (input/output) COMPLEX array, dimension (LDZ,N) */
+/* On entry, if WANTZ = .TRUE., the unitary matrix Z. */
+/* On exit, the updated matrix Z. */
+/* If WANTZ = .FALSE., Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1; */
+/* If WANTZ = .TRUE., LDZ >= N. */
+
+/* IFST (input) INTEGER */
+/* ILST (input/output) INTEGER */
+/* Specify the reordering of the diagonal blocks of (A, B). */
+/* The block with row index IFST is moved to row ILST, by a */
+/* sequence of swapping between adjacent blocks. */
+
+/* INFO (output) INTEGER */
+/* =0: Successful exit. */
+/* <0: if INFO = -i, the i-th argument had an illegal value. */
+/* =1: The transformed matrix pair (A, B) would be too far */
+/* from generalized Schur form; the problem is ill- */
+/* conditioned. (A, B) may have been partially reordered, */
+/* and ILST points to the first row of the current */
+/* position of the block being moved. */
+
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
+/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
+/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
+/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
+
+/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
+/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
+/* Estimation: Theory, Algorithms and Software, Report */
+/* UMINF - 94.04, Department of Computing Science, Umea University, */
+/* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. */
+/* To appear in Numerical Algorithms, 1996. */
+
+/* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
+/* for Solving the Generalized Sylvester Equation and Estimating the */
+/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
+/* Department of Computing Science, Umea University, S-901 87 Umea, */
+/* Sweden, December 1993, Revised April 1994, Also as LAPACK working */
+/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, */
+/* 1996. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test input arguments. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldq < 1 || *wantq && *ldq < max(1,*n)) {
+ *info = -9;
+ } else if (*ldz < 1 || *wantz && *ldz < max(1,*n)) {
+ *info = -11;
+ } else if (*ifst < 1 || *ifst > *n) {
+ *info = -12;
+ } else if (*ilst < 1 || *ilst > *n) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTGEXC", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 1) {
+ return 0;
+ }
+ if (*ifst == *ilst) {
+ return 0;
+ }
+
+ if (*ifst < *ilst) {
+
+ here = *ifst;
+
+L10:
+
+/* Swap with next one below */
+
+ ctgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[
+ q_offset], ldq, &z__[z_offset], ldz, &here, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ ++here;
+ if (here < *ilst) {
+ goto L10;
+ }
+ --here;
+ } else {
+ here = *ifst - 1;
+
+L20:
+
+/* Swap with next one above */
+
+ ctgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[
+ q_offset], ldq, &z__[z_offset], ldz, &here, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ --here;
+ if (here >= *ilst) {
+ goto L20;
+ }
+ ++here;
+ }
+ *ilst = here;
+ return 0;
+
+/* End of CTGEXC */
+
+} /* ctgexc_ */
diff --git a/SRC/ctgsen.c b/SRC/ctgsen.c
new file mode 100644
index 0000000..c307f99
--- /dev/null
+++ b/SRC/ctgsen.c
@@ -0,0 +1,762 @@
+/* ctgsen.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ctgsen_(integer *ijob, logical *wantq, logical *wantz,
+ logical *select, integer *n, complex *a, integer *lda, complex *b,
+ integer *ldb, complex *alpha, complex *beta, complex *q, integer *ldq,
+ complex *z__, integer *ldz, integer *m, real *pl, real *pr, real *
+ dif, complex *work, integer *lwork, integer *iwork, integer *liwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
+ z_offset, i__1, i__2, i__3;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), c_abs(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, k, n1, n2, ks, mn2, ijb, kase, ierr;
+ real dsum;
+ logical swap;
+ complex temp1, temp2;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *);
+ integer isave[3];
+ logical wantd;
+ integer lwmin;
+ logical wantp;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *);
+ logical wantd1, wantd2;
+ real dscale;
+ extern doublereal slamch_(char *);
+ real rdscal;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *);
+ real safmin;
+ extern /* Subroutine */ int ctgexc_(logical *, logical *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, integer *, integer *, integer *), xerbla_(
+ char *, integer *), classq_(integer *, complex *, integer
+ *, real *, real *);
+ integer liwmin;
+ extern /* Subroutine */ int ctgsyl_(char *, integer *, integer *, integer
+ *, complex *, integer *, complex *, integer *, complex *, integer
+ *, complex *, integer *, complex *, integer *, complex *, integer
+ *, real *, real *, complex *, integer *, integer *, integer *);
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTGSEN reorders the generalized Schur decomposition of a complex */
+/* matrix pair (A, B) (in terms of an unitary equivalence trans- */
+/* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues */
+/* appears in the leading diagonal blocks of the pair (A,B). The leading */
+/* columns of Q and Z form unitary bases of the corresponding left and */
+/* right eigenspaces (deflating subspaces). (A, B) must be in */
+/* generalized Schur canonical form, that is, A and B are both upper */
+/* triangular. */
+
+/* CTGSEN also computes the generalized eigenvalues */
+
+/* w(j)= ALPHA(j) / BETA(j) */
+
+/* of the reordered matrix pair (A, B). */
+
+/* Optionally, the routine computes estimates of reciprocal condition */
+/* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), */
+/* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) */
+/* between the matrix pairs (A11, B11) and (A22,B22) that correspond to */
+/* the selected cluster and the eigenvalues outside the cluster, resp., */
+/* and norms of "projections" onto left and right eigenspaces w.r.t. */
+/* the selected cluster in the (1,1)-block. */
+
+
+/* Arguments */
+/* ========= */
+
+/* IJOB (input) integer */
+/* Specifies whether condition numbers are required for the */
+/* cluster of eigenvalues (PL and PR) or the deflating subspaces */
+/* (Difu and Difl): */
+/* =0: Only reorder w.r.t. SELECT. No extras. */
+/* =1: Reciprocal of norms of "projections" onto left and right */
+/* eigenspaces w.r.t. the selected cluster (PL and PR). */
+/* =2: Upper bounds on Difu and Difl. F-norm-based estimate */
+/* (DIF(1:2)). */
+/* =3: Estimate of Difu and Difl. 1-norm-based estimate */
+/* (DIF(1:2)). */
+/* About 5 times as expensive as IJOB = 2. */
+/* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic */
+/* version to get it all. */
+/* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) */
+
+/* WANTQ (input) LOGICAL */
+/* .TRUE. : update the left transformation matrix Q; */
+/* .FALSE.: do not update Q. */
+
+/* WANTZ (input) LOGICAL */
+/* .TRUE. : update the right transformation matrix Z; */
+/* .FALSE.: do not update Z. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* SELECT specifies the eigenvalues in the selected cluster. To */
+/* select an eigenvalue w(j), SELECT(j) must be set to */
+/* .TRUE.. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension(LDA,N) */
+/* On entry, the upper triangular matrix A, in generalized */
+/* Schur canonical form. */
+/* On exit, A is overwritten by the reordered matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX array, dimension(LDB,N) */
+/* On entry, the upper triangular matrix B, in generalized */
+/* Schur canonical form. */
+/* On exit, B is overwritten by the reordered matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* ALPHA (output) COMPLEX array, dimension (N) */
+/* BETA (output) COMPLEX array, dimension (N) */
+/* The diagonal elements of A and B, respectively, */
+/* when the pair (A,B) has been reduced to generalized Schur */
+/* form. ALPHA(i)/BETA(i) i=1,...,N are the generalized */
+/* eigenvalues. */
+
+/* Q (input/output) COMPLEX array, dimension (LDQ,N) */
+/* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. */
+/* On exit, Q has been postmultiplied by the left unitary */
+/* transformation matrix which reorder (A, B); The leading M */
+/* columns of Q form orthonormal bases for the specified pair of */
+/* left eigenspaces (deflating subspaces). */
+/* If WANTQ = .FALSE., Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= 1. */
+/* If WANTQ = .TRUE., LDQ >= N. */
+
+/* Z (input/output) COMPLEX array, dimension (LDZ,N) */
+/* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. */
+/* On exit, Z has been postmultiplied by the left unitary */
+/* transformation matrix which reorder (A, B); The leading M */
+/* columns of Z form orthonormal bases for the specified pair of */
+/* left eigenspaces (deflating subspaces). */
+/* If WANTZ = .FALSE., Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1. */
+/* If WANTZ = .TRUE., LDZ >= N. */
+
+/* M (output) INTEGER */
+/* The dimension of the specified pair of left and right */
+/* eigenspaces, (deflating subspaces) 0 <= M <= N. */
+
+/* PL (output) REAL */
+/* PR (output) REAL */
+/* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the */
+/* reciprocal of the norm of "projections" onto left and right */
+/* eigenspace with respect to the selected cluster. */
+/* 0 < PL, PR <= 1. */
+/* If M = 0 or M = N, PL = PR = 1. */
+/* If IJOB = 0, 2 or 3 PL, PR are not referenced. */
+
+/* DIF (output) REAL array, dimension (2). */
+/* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. */
+/* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on */
+/* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based */
+/* estimates of Difu and Difl, computed using reversed */
+/* communication with CLACN2. */
+/* If M = 0 or N, DIF(1:2) = F-norm([A, B]). */
+/* If IJOB = 0 or 1, DIF is not referenced. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* IF IJOB = 0, WORK is not referenced. Otherwise, */
+/* on exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= 1 */
+/* If IJOB = 1, 2 or 4, LWORK >= 2*M*(N-M) */
+/* If IJOB = 3 or 5, LWORK >= 4*M*(N-M) */
+
+/* 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. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* IF IJOB = 0, IWORK is not referenced. Otherwise, */
+/* on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. LIWORK >= 1. */
+/* If IJOB = 1, 2 or 4, LIWORK >= N+2; */
+/* If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M)); */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal size of the IWORK array, */
+/* returns this value as the first entry of the IWORK array, and */
+/* no error message related to LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* =0: Successful exit. */
+/* <0: If INFO = -i, the i-th argument had an illegal value. */
+/* =1: Reordering of (A, B) failed because the transformed */
+/* matrix pair (A, B) would be too far from generalized */
+/* Schur form; the problem is very ill-conditioned. */
+/* (A, B) may have been partially reordered. */
+/* If requested, 0 is returned in DIF(*), PL and PR. */
+
+
+/* Further Details */
+/* =============== */
+
+/* CTGSEN first collects the selected eigenvalues by computing unitary */
+/* U and W that move them to the top left corner of (A, B). In other */
+/* words, the selected eigenvalues are the eigenvalues of (A11, B11) in */
+
+/* U'*(A, B)*W = (A11 A12) (B11 B12) n1 */
+/* ( 0 A22),( 0 B22) n2 */
+/* n1 n2 n1 n2 */
+
+/* where N = n1+n2 and U' means the conjugate transpose of U. The first */
+/* n1 columns of U and W span the specified pair of left and right */
+/* eigenspaces (deflating subspaces) of (A, B). */
+
+/* If (A, B) has been obtained from the generalized real Schur */
+/* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the */
+/* reordered generalized Schur form of (C, D) is given by */
+
+/* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)', */
+
+/* and the first n1 columns of Q*U and Z*W span the corresponding */
+/* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). */
+
+/* Note that if the selected eigenvalue is sufficiently ill-conditioned, */
+/* then its value may differ significantly from its value before */
+/* reordering. */
+
+/* The reciprocal condition numbers of the left and right eigenspaces */
+/* spanned by the first n1 columns of U and W (or Q*U and Z*W) may */
+/* be returned in DIF(1:2), corresponding to Difu and Difl, resp. */
+
+/* The Difu and Difl are defined as: */
+
+/* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu ) */
+/* and */
+/* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], */
+
+/* where sigma-min(Zu) is the smallest singular value of the */
+/* (2*n1*n2)-by-(2*n1*n2) matrix */
+
+/* Zu = [ kron(In2, A11) -kron(A22', In1) ] */
+/* [ kron(In2, B11) -kron(B22', In1) ]. */
+
+/* Here, Inx is the identity matrix of size nx and A22' is the */
+/* transpose of A22. kron(X, Y) is the Kronecker product between */
+/* the matrices X and Y. */
+
+/* When DIF(2) is small, small changes in (A, B) can cause large changes */
+/* in the deflating subspace. An approximate (asymptotic) bound on the */
+/* maximum angular error in the computed deflating subspaces is */
+
+/* EPS * norm((A, B)) / DIF(2), */
+
+/* where EPS is the machine precision. */
+
+/* The reciprocal norm of the projectors on the left and right */
+/* eigenspaces associated with (A11, B11) may be returned in PL and PR. */
+/* They are computed as follows. First we compute L and R so that */
+/* P*(A, B)*Q is block diagonal, where */
+
+/* P = ( I -L ) n1 Q = ( I R ) n1 */
+/* ( 0 I ) n2 and ( 0 I ) n2 */
+/* n1 n2 n1 n2 */
+
+/* and (L, R) is the solution to the generalized Sylvester equation */
+
+/* A11*R - L*A22 = -A12 */
+/* B11*R - L*B22 = -B12 */
+
+/* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). */
+/* An approximate (asymptotic) bound on the average absolute error of */
+/* the selected eigenvalues is */
+
+/* EPS * norm((A, B)) / PL. */
+
+/* There are also global error bounds which valid for perturbations up */
+/* to a certain restriction: A lower bound (x) on the smallest */
+/* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and */
+/* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), */
+/* (i.e. (A + E, B + F), is */
+
+/* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)). */
+
+/* An approximate bound on x can be computed from DIF(1:2), PL and PR. */
+
+/* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed */
+/* (L', R') and unperturbed (L, R) left and right deflating subspaces */
+/* associated with the selected cluster in the (1,1)-blocks can be */
+/* bounded as */
+
+/* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) */
+/* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) */
+
+/* See LAPACK User's Guide section 4.11 or the following references */
+/* for more information. */
+
+/* Note that if the default method for computing the Frobenius-norm- */
+/* based estimate DIF is not wanted (see CLATDF), then the parameter */
+/* IDIFJB (see below) should be changed from 3 to 4 (routine CLATDF */
+/* (IJOB = 2 will be used)). See CTGSYL for more details. */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* References */
+/* ========== */
+
+/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
+/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
+/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
+/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
+
+/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
+/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
+/* Estimation: Theory, Algorithms and Software, Report */
+/* UMINF - 94.04, Department of Computing Science, Umea University, */
+/* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. */
+/* To appear in Numerical Algorithms, 1996. */
+
+/* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
+/* for Solving the Generalized Sylvester Equation and Estimating the */
+/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
+/* Department of Computing Science, Umea University, S-901 87 Umea, */
+/* Sweden, December 1993, Revised April 1994, Also as LAPACK working */
+/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, */
+/* 1996. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ --select;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alpha;
+ --beta;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --dif;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1 || *liwork == -1;
+
+ if (*ijob < 0 || *ijob > 5) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldq < 1 || *wantq && *ldq < *n) {
+ *info = -13;
+ } else if (*ldz < 1 || *wantz && *ldz < *n) {
+ *info = -15;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTGSEN", &i__1);
+ return 0;
+ }
+
+ ierr = 0;
+
+ wantp = *ijob == 1 || *ijob >= 4;
+ wantd1 = *ijob == 2 || *ijob == 4;
+ wantd2 = *ijob == 3 || *ijob == 5;
+ wantd = wantd1 || wantd2;
+
+/* Set M to the dimension of the specified pair of deflating */
+/* subspaces. */
+
+ *m = 0;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = k;
+ i__3 = k + k * a_dim1;
+ alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
+ i__2 = k;
+ i__3 = k + k * b_dim1;
+ beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
+ if (k < *n) {
+ if (select[k]) {
+ ++(*m);
+ }
+ } else {
+ if (select[*n]) {
+ ++(*m);
+ }
+ }
+/* L10: */
+ }
+
+ if (*ijob == 1 || *ijob == 2 || *ijob == 4) {
+/* Computing MAX */
+ i__1 = 1, i__2 = (*m << 1) * (*n - *m);
+ lwmin = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = *n + 2;
+ liwmin = max(i__1,i__2);
+ } else if (*ijob == 3 || *ijob == 5) {
+/* Computing MAX */
+ i__1 = 1, i__2 = (*m << 2) * (*n - *m);
+ lwmin = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = (*m << 1) * (*n - *m), i__1 = max(i__1,i__2), i__2 =
+ *n + 2;
+ liwmin = max(i__1,i__2);
+ } else {
+ lwmin = 1;
+ liwmin = 1;
+ }
+
+ work[1].r = (real) lwmin, work[1].i = 0.f;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -21;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -23;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTGSEN", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == *n || *m == 0) {
+ if (wantp) {
+ *pl = 1.f;
+ *pr = 1.f;
+ }
+ if (wantd) {
+ dscale = 0.f;
+ dsum = 1.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ classq_(n, &a[i__ * a_dim1 + 1], &c__1, &dscale, &dsum);
+ classq_(n, &b[i__ * b_dim1 + 1], &c__1, &dscale, &dsum);
+/* L20: */
+ }
+ dif[1] = dscale * sqrt(dsum);
+ dif[2] = dif[1];
+ }
+ goto L70;
+ }
+
+/* Get machine constant */
+
+ safmin = slamch_("S");
+
+/* Collect the selected blocks at the top-left corner of (A, B). */
+
+ ks = 0;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ swap = select[k];
+ if (swap) {
+ ++ks;
+
+/* Swap the K-th block to position KS. Compute unitary Q */
+/* and Z that will swap adjacent diagonal blocks in (A, B). */
+
+ if (k != ks) {
+ ctgexc_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb,
+ &q[q_offset], ldq, &z__[z_offset], ldz, &k, &ks, &
+ ierr);
+ }
+
+ if (ierr > 0) {
+
+/* Swap is rejected: exit. */
+
+ *info = 1;
+ if (wantp) {
+ *pl = 0.f;
+ *pr = 0.f;
+ }
+ if (wantd) {
+ dif[1] = 0.f;
+ dif[2] = 0.f;
+ }
+ goto L70;
+ }
+ }
+/* L30: */
+ }
+ if (wantp) {
+
+/* Solve generalized Sylvester equation for R and L: */
+/* A11 * R - L * A22 = A12 */
+/* B11 * R - L * B22 = B12 */
+
+ n1 = *m;
+ n2 = *n - *m;
+ i__ = n1 + 1;
+ clacpy_("Full", &n1, &n2, &a[i__ * a_dim1 + 1], lda, &work[1], &n1);
+ clacpy_("Full", &n1, &n2, &b[i__ * b_dim1 + 1], ldb, &work[n1 * n2 +
+ 1], &n1);
+ ijb = 0;
+ i__1 = *lwork - (n1 << 1) * n2;
+ ctgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ * a_dim1]
+, lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ + i__ *
+ b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &dif[1], &
+ work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &ierr);
+
+/* Estimate the reciprocal of norms of "projections" onto */
+/* left and right eigenspaces */
+
+ rdscal = 0.f;
+ dsum = 1.f;
+ i__1 = n1 * n2;
+ classq_(&i__1, &work[1], &c__1, &rdscal, &dsum);
+ *pl = rdscal * sqrt(dsum);
+ if (*pl == 0.f) {
+ *pl = 1.f;
+ } else {
+ *pl = dscale / (sqrt(dscale * dscale / *pl + *pl) * sqrt(*pl));
+ }
+ rdscal = 0.f;
+ dsum = 1.f;
+ i__1 = n1 * n2;
+ classq_(&i__1, &work[n1 * n2 + 1], &c__1, &rdscal, &dsum);
+ *pr = rdscal * sqrt(dsum);
+ if (*pr == 0.f) {
+ *pr = 1.f;
+ } else {
+ *pr = dscale / (sqrt(dscale * dscale / *pr + *pr) * sqrt(*pr));
+ }
+ }
+ if (wantd) {
+
+/* Compute estimates Difu and Difl. */
+
+ if (wantd1) {
+ n1 = *m;
+ n2 = *n - *m;
+ i__ = n1 + 1;
+ ijb = 3;
+
+/* Frobenius norm-based Difu estimate. */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ ctgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ *
+ a_dim1], lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ +
+ i__ * b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &
+ dif[1], &work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &
+ ierr);
+
+/* Frobenius norm-based Difl estimate. */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ ctgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, &a[
+ a_offset], lda, &work[1], &n2, &b[i__ + i__ * b_dim1],
+ ldb, &b[b_offset], ldb, &work[n1 * n2 + 1], &n2, &dscale,
+ &dif[2], &work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &
+ ierr);
+ } else {
+
+/* Compute 1-norm-based estimates of Difu and Difl using */
+/* reversed communication with CLACN2. In each step a */
+/* generalized Sylvester equation or a transposed variant */
+/* is solved. */
+
+ kase = 0;
+ n1 = *m;
+ n2 = *n - *m;
+ i__ = n1 + 1;
+ ijb = 0;
+ mn2 = (n1 << 1) * n2;
+
+/* 1-norm-based estimate of Difu. */
+
+L40:
+ clacn2_(&mn2, &work[mn2 + 1], &work[1], &dif[1], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Solve generalized Sylvester equation */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ ctgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ +
+ i__ * a_dim1], lda, &work[1], &n1, &b[b_offset],
+ ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
+ 1], &n1, &dscale, &dif[1], &work[(n1 * n2 << 1) +
+ 1], &i__1, &iwork[1], &ierr);
+ } else {
+
+/* Solve the transposed variant. */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ ctgsyl_("C", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ +
+ i__ * a_dim1], lda, &work[1], &n1, &b[b_offset],
+ ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
+ 1], &n1, &dscale, &dif[1], &work[(n1 * n2 << 1) +
+ 1], &i__1, &iwork[1], &ierr);
+ }
+ goto L40;
+ }
+ dif[1] = dscale / dif[1];
+
+/* 1-norm-based estimate of Difl. */
+
+L50:
+ clacn2_(&mn2, &work[mn2 + 1], &work[1], &dif[2], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Solve generalized Sylvester equation */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ ctgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda,
+ &a[a_offset], lda, &work[1], &n2, &b[i__ + i__ *
+ b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 +
+ 1], &n2, &dscale, &dif[2], &work[(n1 * n2 << 1) +
+ 1], &i__1, &iwork[1], &ierr);
+ } else {
+
+/* Solve the transposed variant. */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ ctgsyl_("C", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda,
+ &a[a_offset], lda, &work[1], &n2, &b[b_offset],
+ ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
+ 1], &n2, &dscale, &dif[2], &work[(n1 * n2 << 1) +
+ 1], &i__1, &iwork[1], &ierr);
+ }
+ goto L50;
+ }
+ dif[2] = dscale / dif[2];
+ }
+ }
+
+/* If B(K,K) is complex, make it real and positive (normalization */
+/* of the generalized Schur form) and Store the generalized */
+/* eigenvalues of reordered pair (A, B) */
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ dscale = c_abs(&b[k + k * b_dim1]);
+ if (dscale > safmin) {
+ i__2 = k + k * b_dim1;
+ q__2.r = b[i__2].r / dscale, q__2.i = b[i__2].i / dscale;
+ r_cnjg(&q__1, &q__2);
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ i__2 = k + k * b_dim1;
+ q__1.r = b[i__2].r / dscale, q__1.i = b[i__2].i / dscale;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ i__2 = k + k * b_dim1;
+ b[i__2].r = dscale, b[i__2].i = 0.f;
+ i__2 = *n - k;
+ cscal_(&i__2, &temp1, &b[k + (k + 1) * b_dim1], ldb);
+ i__2 = *n - k + 1;
+ cscal_(&i__2, &temp1, &a[k + k * a_dim1], lda);
+ if (*wantq) {
+ cscal_(n, &temp2, &q[k * q_dim1 + 1], &c__1);
+ }
+ } else {
+ i__2 = k + k * b_dim1;
+ b[i__2].r = 0.f, b[i__2].i = 0.f;
+ }
+
+ i__2 = k;
+ i__3 = k + k * a_dim1;
+ alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
+ i__2 = k;
+ i__3 = k + k * b_dim1;
+ beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
+
+/* L60: */
+ }
+
+L70:
+
+ work[1].r = (real) lwmin, work[1].i = 0.f;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of CTGSEN */
+
+} /* ctgsen_ */
diff --git a/SRC/ctgsja.c b/SRC/ctgsja.c
new file mode 100644
index 0000000..04174e8
--- /dev/null
+++ b/SRC/ctgsja.c
@@ -0,0 +1,671 @@
+/* ctgsja.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+static real c_b39 = -1.f;
+static real c_b42 = 1.f;
+
+/* Subroutine */ int ctgsja_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *p, integer *n, integer *k, integer *l, complex *a, integer *
+ lda, complex *b, integer *ldb, real *tola, real *tolb, real *alpha,
+ real *beta, complex *u, integer *ldu, complex *v, integer *ldv,
+ complex *q, integer *ldq, complex *work, integer *ncycle, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1,
+ u_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4;
+ real r__1;
+ complex q__1;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j;
+ real a1, b1, a3, b3;
+ complex a2, b2;
+ real csq, csu, csv;
+ complex snq;
+ real rwk;
+ complex snu, snv;
+ extern /* Subroutine */ int crot_(integer *, complex *, integer *,
+ complex *, integer *, real *, complex *);
+ real gamma;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ logical initq, initu, initv, wantq, upper;
+ real error, ssmin;
+ logical wantu, wantv;
+ extern /* Subroutine */ int clags2_(logical *, real *, complex *, real *,
+ real *, complex *, real *, real *, complex *, real *, complex *,
+ real *, complex *), clapll_(integer *, complex *, integer *,
+ complex *, integer *, real *), csscal_(integer *, real *, complex
+ *, integer *);
+ integer kcycle;
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), xerbla_(char *,
+ integer *), slartg_(real *, real *, real *, real *, real *
+);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTGSJA computes the generalized singular value decomposition (GSVD) */
+/* of two complex upper triangular (or trapezoidal) matrices A and B. */
+
+/* On entry, it is assumed that matrices A and B have the following */
+/* forms, which may be obtained by the preprocessing subroutine CGGSVP */
+/* from a general M-by-N matrix A and P-by-N matrix B: */
+
+/* N-K-L K L */
+/* A = K ( 0 A12 A13 ) if M-K-L >= 0; */
+/* L ( 0 0 A23 ) */
+/* M-K-L ( 0 0 0 ) */
+
+/* N-K-L K L */
+/* A = K ( 0 A12 A13 ) if M-K-L < 0; */
+/* M-K ( 0 0 A23 ) */
+
+/* N-K-L K L */
+/* B = L ( 0 0 B13 ) */
+/* P-L ( 0 0 0 ) */
+
+/* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */
+/* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */
+/* otherwise A23 is (M-K)-by-L upper trapezoidal. */
+
+/* On exit, */
+
+/* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ), */
+
+/* where U, V and Q are unitary matrices, Z' denotes the conjugate */
+/* transpose of Z, R is a nonsingular upper triangular matrix, and D1 */
+/* and D2 are ``diagonal'' matrices, which are of the following */
+/* structures: */
+
+/* If M-K-L >= 0, */
+
+/* K L */
+/* D1 = K ( I 0 ) */
+/* L ( 0 C ) */
+/* M-K-L ( 0 0 ) */
+
+/* K L */
+/* D2 = L ( 0 S ) */
+/* P-L ( 0 0 ) */
+
+/* N-K-L K L */
+/* ( 0 R ) = K ( 0 R11 R12 ) K */
+/* L ( 0 0 R22 ) L */
+
+/* where */
+
+/* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */
+/* S = diag( BETA(K+1), ... , BETA(K+L) ), */
+/* C**2 + S**2 = I. */
+
+/* R is stored in A(1:K+L,N-K-L+1:N) on exit. */
+
+/* If M-K-L < 0, */
+
+/* K M-K K+L-M */
+/* D1 = K ( I 0 0 ) */
+/* M-K ( 0 C 0 ) */
+
+/* K M-K K+L-M */
+/* D2 = M-K ( 0 S 0 ) */
+/* K+L-M ( 0 0 I ) */
+/* P-L ( 0 0 0 ) */
+
+/* N-K-L K M-K K+L-M */
+/* ( 0 R ) = K ( 0 R11 R12 R13 ) */
+/* M-K ( 0 0 R22 R23 ) */
+/* K+L-M ( 0 0 0 R33 ) */
+
+/* where */
+/* C = diag( ALPHA(K+1), ... , ALPHA(M) ), */
+/* S = diag( BETA(K+1), ... , BETA(M) ), */
+/* C**2 + S**2 = I. */
+
+/* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored */
+/* ( 0 R22 R23 ) */
+/* in B(M-K+1:L,N+M-K-L+1:N) on exit. */
+
+/* The computation of the unitary transformation matrices U, V or Q */
+/* is optional. These matrices may either be formed explicitly, or they */
+/* may be postmultiplied into input matrices U1, V1, or Q1. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBU (input) CHARACTER*1 */
+/* = 'U': U must contain a unitary matrix U1 on entry, and */
+/* the product U1*U is returned; */
+/* = 'I': U is initialized to the unit matrix, and the */
+/* unitary matrix U is returned; */
+/* = 'N': U is not computed. */
+
+/* JOBV (input) CHARACTER*1 */
+/* = 'V': V must contain a unitary matrix V1 on entry, and */
+/* the product V1*V is returned; */
+/* = 'I': V is initialized to the unit matrix, and the */
+/* unitary matrix V is returned; */
+/* = 'N': V is not computed. */
+
+/* JOBQ (input) CHARACTER*1 */
+/* = 'Q': Q must contain a unitary matrix Q1 on entry, and */
+/* the product Q1*Q is returned; */
+/* = 'I': Q is initialized to the unit matrix, and the */
+/* unitary matrix Q is returned; */
+/* = 'N': Q is not computed. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* K (input) INTEGER */
+/* L (input) INTEGER */
+/* K and L specify the subblocks in the input matrices A and B: */
+/* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,,N-L+1:N) */
+/* of A and B, whose GSVD is going to be computed by CTGSJA. */
+/* See Further details. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular */
+/* matrix R or part of R. See Purpose for details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix B. */
+/* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains */
+/* a part of R. See Purpose for details. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,P). */
+
+/* TOLA (input) REAL */
+/* TOLB (input) REAL */
+/* TOLA and TOLB are the convergence criteria for the Jacobi- */
+/* Kogbetliantz iteration procedure. Generally, they are the */
+/* same as used in the preprocessing step, say */
+/* TOLA = MAX(M,N)*norm(A)*MACHEPS, */
+/* TOLB = MAX(P,N)*norm(B)*MACHEPS. */
+
+/* ALPHA (output) REAL array, dimension (N) */
+/* BETA (output) REAL array, dimension (N) */
+/* On exit, ALPHA and BETA contain the generalized singular */
+/* value pairs of A and B; */
+/* ALPHA(1:K) = 1, */
+/* BETA(1:K) = 0, */
+/* and if M-K-L >= 0, */
+/* ALPHA(K+1:K+L) = diag(C), */
+/* BETA(K+1:K+L) = diag(S), */
+/* or if M-K-L < 0, */
+/* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0 */
+/* BETA(K+1:M) = S, BETA(M+1:K+L) = 1. */
+/* Furthermore, if K+L < N, */
+/* ALPHA(K+L+1:N) = 0 */
+/* BETA(K+L+1:N) = 0. */
+
+/* U (input/output) COMPLEX array, dimension (LDU,M) */
+/* On entry, if JOBU = 'U', U must contain a matrix U1 (usually */
+/* the unitary matrix returned by CGGSVP). */
+/* On exit, */
+/* if JOBU = 'I', U contains the unitary matrix U; */
+/* if JOBU = 'U', U contains the product U1*U. */
+/* If JOBU = 'N', U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M) if */
+/* JOBU = 'U'; LDU >= 1 otherwise. */
+
+/* V (input/output) COMPLEX array, dimension (LDV,P) */
+/* On entry, if JOBV = 'V', V must contain a matrix V1 (usually */
+/* the unitary matrix returned by CGGSVP). */
+/* On exit, */
+/* if JOBV = 'I', V contains the unitary matrix V; */
+/* if JOBV = 'V', V contains the product V1*V. */
+/* If JOBV = 'N', V is not referenced. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. LDV >= max(1,P) if */
+/* JOBV = 'V'; LDV >= 1 otherwise. */
+
+/* Q (input/output) COMPLEX array, dimension (LDQ,N) */
+/* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually */
+/* the unitary matrix returned by CGGSVP). */
+/* On exit, */
+/* if JOBQ = 'I', Q contains the unitary matrix Q; */
+/* if JOBQ = 'Q', Q contains the product Q1*Q. */
+/* If JOBQ = 'N', Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N) if */
+/* JOBQ = 'Q'; LDQ >= 1 otherwise. */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* NCYCLE (output) INTEGER */
+/* The number of cycles required for convergence. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1: the procedure does not converge after MAXIT cycles. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* MAXIT INTEGER */
+/* MAXIT specifies the total loops that the iterative procedure */
+/* may take. If after MAXIT cycles, the routine fails to */
+/* converge, we return INFO = 1. */
+
+/* Further Details */
+/* =============== */
+
+/* CTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce */
+/* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L */
+/* matrix B13 to the form: */
+
+/* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1, */
+
+/* where U1, V1 and Q1 are unitary matrix, and Z' is the conjugate */
+/* transpose of Z. C1 and S1 are diagonal matrices satisfying */
+
+/* C1**2 + S1**2 = I, */
+
+/* and R1 is an L-by-L nonsingular upper triangular matrix. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alpha;
+ --beta;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+
+ /* Function Body */
+ initu = lsame_(jobu, "I");
+ wantu = initu || lsame_(jobu, "U");
+
+ initv = lsame_(jobv, "I");
+ wantv = initv || lsame_(jobv, "V");
+
+ initq = lsame_(jobq, "I");
+ wantq = initq || lsame_(jobq, "Q");
+
+ *info = 0;
+ if (! (initu || wantu || lsame_(jobu, "N"))) {
+ *info = -1;
+ } else if (! (initv || wantv || lsame_(jobv, "N")))
+ {
+ *info = -2;
+ } else if (! (initq || wantq || lsame_(jobq, "N")))
+ {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*p < 0) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (*lda < max(1,*m)) {
+ *info = -10;
+ } else if (*ldb < max(1,*p)) {
+ *info = -12;
+ } else if (*ldu < 1 || wantu && *ldu < *m) {
+ *info = -18;
+ } else if (*ldv < 1 || wantv && *ldv < *p) {
+ *info = -20;
+ } else if (*ldq < 1 || wantq && *ldq < *n) {
+ *info = -22;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTGSJA", &i__1);
+ return 0;
+ }
+
+/* Initialize U, V and Q, if necessary */
+
+ if (initu) {
+ claset_("Full", m, m, &c_b1, &c_b2, &u[u_offset], ldu);
+ }
+ if (initv) {
+ claset_("Full", p, p, &c_b1, &c_b2, &v[v_offset], ldv);
+ }
+ if (initq) {
+ claset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
+ }
+
+/* Loop until convergence */
+
+ upper = FALSE_;
+ for (kcycle = 1; kcycle <= 40; ++kcycle) {
+
+ upper = ! upper;
+
+ i__1 = *l - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *l;
+ for (j = i__ + 1; j <= i__2; ++j) {
+
+ a1 = 0.f;
+ a2.r = 0.f, a2.i = 0.f;
+ a3 = 0.f;
+ if (*k + i__ <= *m) {
+ i__3 = *k + i__ + (*n - *l + i__) * a_dim1;
+ a1 = a[i__3].r;
+ }
+ if (*k + j <= *m) {
+ i__3 = *k + j + (*n - *l + j) * a_dim1;
+ a3 = a[i__3].r;
+ }
+
+ i__3 = i__ + (*n - *l + i__) * b_dim1;
+ b1 = b[i__3].r;
+ i__3 = j + (*n - *l + j) * b_dim1;
+ b3 = b[i__3].r;
+
+ if (upper) {
+ if (*k + i__ <= *m) {
+ i__3 = *k + i__ + (*n - *l + j) * a_dim1;
+ a2.r = a[i__3].r, a2.i = a[i__3].i;
+ }
+ i__3 = i__ + (*n - *l + j) * b_dim1;
+ b2.r = b[i__3].r, b2.i = b[i__3].i;
+ } else {
+ if (*k + j <= *m) {
+ i__3 = *k + j + (*n - *l + i__) * a_dim1;
+ a2.r = a[i__3].r, a2.i = a[i__3].i;
+ }
+ i__3 = j + (*n - *l + i__) * b_dim1;
+ b2.r = b[i__3].r, b2.i = b[i__3].i;
+ }
+
+ clags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &
+ csv, &snv, &csq, &snq);
+
+/* Update (K+I)-th and (K+J)-th rows of matrix A: U'*A */
+
+ if (*k + j <= *m) {
+ r_cnjg(&q__1, &snu);
+ crot_(l, &a[*k + j + (*n - *l + 1) * a_dim1], lda, &a[*k
+ + i__ + (*n - *l + 1) * a_dim1], lda, &csu, &q__1)
+ ;
+ }
+
+/* Update I-th and J-th rows of matrix B: V'*B */
+
+ r_cnjg(&q__1, &snv);
+ crot_(l, &b[j + (*n - *l + 1) * b_dim1], ldb, &b[i__ + (*n - *
+ l + 1) * b_dim1], ldb, &csv, &q__1);
+
+/* Update (N-L+I)-th and (N-L+J)-th columns of matrices */
+/* A and B: A*Q and B*Q */
+
+/* Computing MIN */
+ i__4 = *k + *l;
+ i__3 = min(i__4,*m);
+ crot_(&i__3, &a[(*n - *l + j) * a_dim1 + 1], &c__1, &a[(*n - *
+ l + i__) * a_dim1 + 1], &c__1, &csq, &snq);
+
+ crot_(l, &b[(*n - *l + j) * b_dim1 + 1], &c__1, &b[(*n - *l +
+ i__) * b_dim1 + 1], &c__1, &csq, &snq);
+
+ if (upper) {
+ if (*k + i__ <= *m) {
+ i__3 = *k + i__ + (*n - *l + j) * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ }
+ i__3 = i__ + (*n - *l + j) * b_dim1;
+ b[i__3].r = 0.f, b[i__3].i = 0.f;
+ } else {
+ if (*k + j <= *m) {
+ i__3 = *k + j + (*n - *l + i__) * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ }
+ i__3 = j + (*n - *l + i__) * b_dim1;
+ b[i__3].r = 0.f, b[i__3].i = 0.f;
+ }
+
+/* Ensure that the diagonal elements of A and B are real. */
+
+ if (*k + i__ <= *m) {
+ i__3 = *k + i__ + (*n - *l + i__) * a_dim1;
+ i__4 = *k + i__ + (*n - *l + i__) * a_dim1;
+ r__1 = a[i__4].r;
+ a[i__3].r = r__1, a[i__3].i = 0.f;
+ }
+ if (*k + j <= *m) {
+ i__3 = *k + j + (*n - *l + j) * a_dim1;
+ i__4 = *k + j + (*n - *l + j) * a_dim1;
+ r__1 = a[i__4].r;
+ a[i__3].r = r__1, a[i__3].i = 0.f;
+ }
+ i__3 = i__ + (*n - *l + i__) * b_dim1;
+ i__4 = i__ + (*n - *l + i__) * b_dim1;
+ r__1 = b[i__4].r;
+ b[i__3].r = r__1, b[i__3].i = 0.f;
+ i__3 = j + (*n - *l + j) * b_dim1;
+ i__4 = j + (*n - *l + j) * b_dim1;
+ r__1 = b[i__4].r;
+ b[i__3].r = r__1, b[i__3].i = 0.f;
+
+/* Update unitary matrices U, V, Q, if desired. */
+
+ if (wantu && *k + j <= *m) {
+ crot_(m, &u[(*k + j) * u_dim1 + 1], &c__1, &u[(*k + i__) *
+ u_dim1 + 1], &c__1, &csu, &snu);
+ }
+
+ if (wantv) {
+ crot_(p, &v[j * v_dim1 + 1], &c__1, &v[i__ * v_dim1 + 1],
+ &c__1, &csv, &snv);
+ }
+
+ if (wantq) {
+ crot_(n, &q[(*n - *l + j) * q_dim1 + 1], &c__1, &q[(*n - *
+ l + i__) * q_dim1 + 1], &c__1, &csq, &snq);
+ }
+
+/* L10: */
+ }
+/* L20: */
+ }
+
+ if (! upper) {
+
+/* The matrices A13 and B13 were lower triangular at the start */
+/* of the cycle, and are now upper triangular. */
+
+/* Convergence test: test the parallelism of the corresponding */
+/* rows of A and B. */
+
+ error = 0.f;
+/* Computing MIN */
+ i__2 = *l, i__3 = *m - *k;
+ i__1 = min(i__2,i__3);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *l - i__ + 1;
+ ccopy_(&i__2, &a[*k + i__ + (*n - *l + i__) * a_dim1], lda, &
+ work[1], &c__1);
+ i__2 = *l - i__ + 1;
+ ccopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &work[*
+ l + 1], &c__1);
+ i__2 = *l - i__ + 1;
+ clapll_(&i__2, &work[1], &c__1, &work[*l + 1], &c__1, &ssmin);
+ error = dmax(error,ssmin);
+/* L30: */
+ }
+
+ if (dabs(error) <= dmin(*tola,*tolb)) {
+ goto L50;
+ }
+ }
+
+/* End of cycle loop */
+
+/* L40: */
+ }
+
+/* The algorithm has not converged after MAXIT cycles. */
+
+ *info = 1;
+ goto L100;
+
+L50:
+
+/* If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged. */
+/* Compute the generalized singular value pairs (ALPHA, BETA), and */
+/* set the triangular matrix R to array A. */
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ alpha[i__] = 1.f;
+ beta[i__] = 0.f;
+/* L60: */
+ }
+
+/* Computing MIN */
+ i__2 = *l, i__3 = *m - *k;
+ i__1 = min(i__2,i__3);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+ i__2 = *k + i__ + (*n - *l + i__) * a_dim1;
+ a1 = a[i__2].r;
+ i__2 = i__ + (*n - *l + i__) * b_dim1;
+ b1 = b[i__2].r;
+
+ if (a1 != 0.f) {
+ gamma = b1 / a1;
+
+ if (gamma < 0.f) {
+ i__2 = *l - i__ + 1;
+ csscal_(&i__2, &c_b39, &b[i__ + (*n - *l + i__) * b_dim1],
+ ldb);
+ if (wantv) {
+ csscal_(p, &c_b39, &v[i__ * v_dim1 + 1], &c__1);
+ }
+ }
+
+ r__1 = dabs(gamma);
+ slartg_(&r__1, &c_b42, &beta[*k + i__], &alpha[*k + i__], &rwk);
+
+ if (alpha[*k + i__] >= beta[*k + i__]) {
+ i__2 = *l - i__ + 1;
+ r__1 = 1.f / alpha[*k + i__];
+ csscal_(&i__2, &r__1, &a[*k + i__ + (*n - *l + i__) * a_dim1],
+ lda);
+ } else {
+ i__2 = *l - i__ + 1;
+ r__1 = 1.f / beta[*k + i__];
+ csscal_(&i__2, &r__1, &b[i__ + (*n - *l + i__) * b_dim1], ldb)
+ ;
+ i__2 = *l - i__ + 1;
+ ccopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k
+ + i__ + (*n - *l + i__) * a_dim1], lda);
+ }
+
+ } else {
+ alpha[*k + i__] = 0.f;
+ beta[*k + i__] = 1.f;
+ i__2 = *l - i__ + 1;
+ ccopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k +
+ i__ + (*n - *l + i__) * a_dim1], lda);
+ }
+/* L70: */
+ }
+
+/* Post-assignment */
+
+ i__1 = *k + *l;
+ for (i__ = *m + 1; i__ <= i__1; ++i__) {
+ alpha[i__] = 0.f;
+ beta[i__] = 1.f;
+/* L80: */
+ }
+
+ if (*k + *l < *n) {
+ i__1 = *n;
+ for (i__ = *k + *l + 1; i__ <= i__1; ++i__) {
+ alpha[i__] = 0.f;
+ beta[i__] = 0.f;
+/* L90: */
+ }
+ }
+
+L100:
+ *ncycle = kcycle;
+
+ return 0;
+
+/* End of CTGSJA */
+
+} /* ctgsja_ */
diff --git a/SRC/ctgsna.c b/SRC/ctgsna.c
new file mode 100644
index 0000000..d235cdb
--- /dev/null
+++ b/SRC/ctgsna.c
@@ -0,0 +1,484 @@
+/* ctgsna.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static complex c_b19 = {1.f,0.f};
+static complex c_b20 = {0.f,0.f};
+static logical c_false = FALSE_;
+static integer c__3 = 3;
+
+/* Subroutine */ int ctgsna_(char *job, char *howmny, logical *select,
+ integer *n, complex *a, integer *lda, complex *b, integer *ldb,
+ complex *vl, integer *ldvl, complex *vr, integer *ldvr, real *s, real
+ *dif, integer *mm, integer *m, complex *work, integer *lwork, integer
+ *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
+ vr_offset, i__1;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+
+ /* Local variables */
+ integer i__, k, n1, n2, ks;
+ real eps, cond;
+ integer ierr, ifst;
+ real lnrm;
+ complex yhax, yhbx;
+ integer ilst;
+ real rnrm, scale;
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *);
+ integer lwmin;
+ logical wants;
+ complex dummy[1];
+ extern doublereal scnrm2_(integer *, complex *, integer *), slapy2_(real *
+, real *);
+ complex dummy1[1];
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), ctgexc_(logical *,
+ logical *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, complex *, integer *, integer *, integer *,
+ integer *), xerbla_(char *, integer *);
+ real bignum;
+ logical wantbh, wantdf, somcon;
+ extern /* Subroutine */ int ctgsyl_(char *, integer *, integer *, integer
+ *, complex *, integer *, complex *, integer *, complex *, integer
+ *, complex *, integer *, complex *, integer *, complex *, integer
+ *, real *, real *, complex *, integer *, integer *, integer *);
+ real smlnum;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTGSNA estimates reciprocal condition numbers for specified */
+/* eigenvalues and/or eigenvectors of a matrix pair (A, B). */
+
+/* (A, B) must be in generalized Schur canonical form, that is, A and */
+/* B are both upper triangular. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies whether condition numbers are required for */
+/* eigenvalues (S) or eigenvectors (DIF): */
+/* = 'E': for eigenvalues only (S); */
+/* = 'V': for eigenvectors only (DIF); */
+/* = 'B': for both eigenvalues and eigenvectors (S and DIF). */
+
+/* HOWMNY (input) CHARACTER*1 */
+/* = 'A': compute condition numbers for all eigenpairs; */
+/* = 'S': compute condition numbers for selected eigenpairs */
+/* specified by the array SELECT. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* If HOWMNY = 'S', SELECT specifies the eigenpairs for which */
+/* condition numbers are required. To select condition numbers */
+/* for the corresponding j-th eigenvalue and/or eigenvector, */
+/* SELECT(j) must be set to .TRUE.. */
+/* If HOWMNY = 'A', SELECT is not referenced. */
+
+/* N (input) INTEGER */
+/* The order of the square matrix pair (A, B). N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The upper triangular matrix A in the pair (A,B). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) COMPLEX array, dimension (LDB,N) */
+/* The upper triangular matrix B in the pair (A, B). */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* VL (input) COMPLEX array, dimension (LDVL,M) */
+/* IF JOB = 'E' or 'B', VL must contain left eigenvectors of */
+/* (A, B), corresponding to the eigenpairs specified by HOWMNY */
+/* and SELECT. The eigenvectors must be stored in consecutive */
+/* columns of VL, as returned by CTGEVC. */
+/* If JOB = 'V', VL is not referenced. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. LDVL >= 1; and */
+/* If JOB = 'E' or 'B', LDVL >= N. */
+
+/* VR (input) COMPLEX array, dimension (LDVR,M) */
+/* IF JOB = 'E' or 'B', VR must contain right eigenvectors of */
+/* (A, B), corresponding to the eigenpairs specified by HOWMNY */
+/* and SELECT. The eigenvectors must be stored in consecutive */
+/* columns of VR, as returned by CTGEVC. */
+/* If JOB = 'V', VR is not referenced. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. LDVR >= 1; */
+/* If JOB = 'E' or 'B', LDVR >= N. */
+
+/* S (output) REAL array, dimension (MM) */
+/* If JOB = 'E' or 'B', the reciprocal condition numbers of the */
+/* selected eigenvalues, stored in consecutive elements of the */
+/* array. */
+/* If JOB = 'V', S is not referenced. */
+
+/* DIF (output) REAL array, dimension (MM) */
+/* If JOB = 'V' or 'B', the estimated reciprocal condition */
+/* numbers of the selected eigenvectors, stored in consecutive */
+/* elements of the array. */
+/* If the eigenvalues cannot be reordered to compute DIF(j), */
+/* DIF(j) is set to 0; this can only occur when the true value */
+/* would be very small anyway. */
+/* For each eigenvalue/vector specified by SELECT, DIF stores */
+/* a Frobenius norm-based estimate of Difl. */
+/* If JOB = 'E', DIF is not referenced. */
+
+/* MM (input) INTEGER */
+/* The number of elements in the arrays S and DIF. MM >= M. */
+
+/* M (output) INTEGER */
+/* The number of elements of the arrays S and DIF used to store */
+/* the specified condition numbers; for each selected eigenvalue */
+/* one element is used. If HOWMNY = 'A', M is set to N. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* If JOB = 'V' or 'B', LWORK >= max(1,2*N*N). */
+
+/* IWORK (workspace) INTEGER array, dimension (N+2) */
+/* If JOB = 'E', IWORK is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The reciprocal of the condition number of the i-th generalized */
+/* eigenvalue w = (a, b) is defined as */
+
+/* S(I) = (|v'Au|**2 + |v'Bu|**2)**(1/2) / (norm(u)*norm(v)) */
+
+/* where u and v are the right and left eigenvectors of (A, B) */
+/* corresponding to w; |z| denotes the absolute value of the complex */
+/* number, and norm(u) denotes the 2-norm of the vector u. The pair */
+/* (a, b) corresponds to an eigenvalue w = a/b (= v'Au/v'Bu) of the */
+/* matrix pair (A, B). If both a and b equal zero, then (A,B) is */
+/* singular and S(I) = -1 is returned. */
+
+/* An approximate error bound on the chordal distance between the i-th */
+/* computed generalized eigenvalue w and the corresponding exact */
+/* eigenvalue lambda is */
+
+/* chord(w, lambda) <= EPS * norm(A, B) / S(I), */
+
+/* where EPS is the machine precision. */
+
+/* The reciprocal of the condition number of the right eigenvector u */
+/* and left eigenvector v corresponding to the generalized eigenvalue w */
+/* is defined as follows. Suppose */
+
+/* (A, B) = ( a * ) ( b * ) 1 */
+/* ( 0 A22 ),( 0 B22 ) n-1 */
+/* 1 n-1 1 n-1 */
+
+/* Then the reciprocal condition number DIF(I) is */
+
+/* Difl[(a, b), (A22, B22)] = sigma-min( Zl ) */
+
+/* where sigma-min(Zl) denotes the smallest singular value of */
+
+/* Zl = [ kron(a, In-1) -kron(1, A22) ] */
+/* [ kron(b, In-1) -kron(1, B22) ]. */
+
+/* Here In-1 is the identity matrix of size n-1 and X' is the conjugate */
+/* transpose of X. kron(X, Y) is the Kronecker product between the */
+/* matrices X and Y. */
+
+/* We approximate the smallest singular value of Zl with an upper */
+/* bound. This is done by CLATDF. */
+
+/* An approximate error bound for a computed eigenvector VL(i) or */
+/* VR(i) is given by */
+
+/* EPS * norm(A, B) / DIF(i). */
+
+/* See ref. [2-3] for more details and further references. */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* References */
+/* ========== */
+
+/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
+/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
+/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
+/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
+
+/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
+/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
+/* Estimation: Theory, Algorithms and Software, Report */
+/* UMINF - 94.04, Department of Computing Science, Umea University, */
+/* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. */
+/* To appear in Numerical Algorithms, 1996. */
+
+/* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
+/* for Solving the Generalized Sylvester Equation and Estimating the */
+/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
+/* Department of Computing Science, Umea University, S-901 87 Umea, */
+/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */
+/* Note 75. */
+/* To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ --select;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --s;
+ --dif;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantbh = lsame_(job, "B");
+ wants = lsame_(job, "E") || wantbh;
+ wantdf = lsame_(job, "V") || wantbh;
+
+ somcon = lsame_(howmny, "S");
+
+ *info = 0;
+ lquery = *lwork == -1;
+
+ if (! wants && ! wantdf) {
+ *info = -1;
+ } else if (! lsame_(howmny, "A") && ! somcon) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (wants && *ldvl < *n) {
+ *info = -10;
+ } else if (wants && *ldvr < *n) {
+ *info = -12;
+ } else {
+
+/* Set M to the number of eigenpairs for which condition numbers */
+/* are required, and test MM. */
+
+ if (somcon) {
+ *m = 0;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (select[k]) {
+ ++(*m);
+ }
+/* L10: */
+ }
+ } else {
+ *m = *n;
+ }
+
+ if (*n == 0) {
+ lwmin = 1;
+ } else if (lsame_(job, "V") || lsame_(job,
+ "B")) {
+ lwmin = (*n << 1) * *n;
+ } else {
+ lwmin = *n;
+ }
+ work[1].r = (real) lwmin, work[1].i = 0.f;
+
+ if (*mm < *m) {
+ *info = -15;
+ } else if (*lwork < lwmin && ! lquery) {
+ *info = -18;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTGSNA", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S") / eps;
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ ks = 0;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+/* Determine whether condition numbers are required for the k-th */
+/* eigenpair. */
+
+ if (somcon) {
+ if (! select[k]) {
+ goto L20;
+ }
+ }
+
+ ++ks;
+
+ if (wants) {
+
+/* Compute the reciprocal condition number of the k-th */
+/* eigenvalue. */
+
+ rnrm = scnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
+ lnrm = scnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
+ cgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[ks * vr_dim1 + 1]
+, &c__1, &c_b20, &work[1], &c__1);
+ cdotc_(&q__1, n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1);
+ yhax.r = q__1.r, yhax.i = q__1.i;
+ cgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[ks * vr_dim1 + 1]
+, &c__1, &c_b20, &work[1], &c__1);
+ cdotc_(&q__1, n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1);
+ yhbx.r = q__1.r, yhbx.i = q__1.i;
+ r__1 = c_abs(&yhax);
+ r__2 = c_abs(&yhbx);
+ cond = slapy2_(&r__1, &r__2);
+ if (cond == 0.f) {
+ s[ks] = -1.f;
+ } else {
+ s[ks] = cond / (rnrm * lnrm);
+ }
+ }
+
+ if (wantdf) {
+ if (*n == 1) {
+ r__1 = c_abs(&a[a_dim1 + 1]);
+ r__2 = c_abs(&b[b_dim1 + 1]);
+ dif[ks] = slapy2_(&r__1, &r__2);
+ } else {
+
+/* Estimate the reciprocal condition number of the k-th */
+/* eigenvectors. */
+
+/* Copy the matrix (A, B) to the array WORK and move the */
+/* (k,k)th pair to the (1,1) position. */
+
+ clacpy_("Full", n, n, &a[a_offset], lda, &work[1], n);
+ clacpy_("Full", n, n, &b[b_offset], ldb, &work[*n * *n + 1],
+ n);
+ ifst = k;
+ ilst = 1;
+
+ ctgexc_(&c_false, &c_false, n, &work[1], n, &work[*n * *n + 1]
+, n, dummy, &c__1, dummy1, &c__1, &ifst, &ilst, &ierr)
+ ;
+
+ if (ierr > 0) {
+
+/* Ill-conditioned problem - swap rejected. */
+
+ dif[ks] = 0.f;
+ } else {
+
+/* Reordering successful, solve generalized Sylvester */
+/* equation for R and L, */
+/* A22 * R - L * A11 = A12 */
+/* B22 * R - L * B11 = B12, */
+/* and compute estimate of Difl[(A11,B11), (A22, B22)]. */
+
+ n1 = 1;
+ n2 = *n - n1;
+ i__ = *n * *n + 1;
+ ctgsyl_("N", &c__3, &n2, &n1, &work[*n * n1 + n1 + 1], n,
+ &work[1], n, &work[n1 + 1], n, &work[*n * n1 + n1
+ + i__], n, &work[i__], n, &work[n1 + i__], n, &
+ scale, &dif[ks], dummy, &c__1, &iwork[1], &ierr);
+ }
+ }
+ }
+
+L20:
+ ;
+ }
+ work[1].r = (real) lwmin, work[1].i = 0.f;
+ return 0;
+
+/* End of CTGSNA */
+
+} /* ctgsna_ */
diff --git a/SRC/ctgsy2.c b/SRC/ctgsy2.c
new file mode 100644
index 0000000..055e2ed
--- /dev/null
+++ b/SRC/ctgsy2.c
@@ -0,0 +1,477 @@
+/* ctgsy2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* Subroutine */ int ctgsy2_(char *trans, integer *ijob, integer *m, integer *
+ n, complex *a, integer *lda, complex *b, integer *ldb, complex *c__,
+ integer *ldc, complex *d__, integer *ldd, complex *e, integer *lde,
+ complex *f, integer *ldf, real *scale, real *rdsum, real *rdscal,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
+ d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3,
+ i__4;
+ complex q__1, q__2, q__3, q__4, q__5, q__6;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ complex z__[4] /* was [2][2] */, rhs[2];
+ integer ierr, ipiv[2], jpiv[2];
+ complex alpha;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *), cgesc2_(integer *, complex *,
+ integer *, complex *, integer *, integer *, real *), cgetc2_(
+ integer *, complex *, integer *, integer *, integer *, integer *),
+ clatdf_(integer *, integer *, complex *, integer *, complex *,
+ real *, real *, integer *, integer *);
+ real scaloc;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTGSY2 solves the generalized Sylvester equation */
+
+/* A * R - L * B = scale * C (1) */
+/* D * R - L * E = scale * F */
+
+/* using Level 1 and 2 BLAS, where R and L are unknown M-by-N matrices, */
+/* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M, */
+/* N-by-N and M-by-N, respectively. A, B, D and E are upper triangular */
+/* (i.e., (A,D) and (B,E) in generalized Schur form). */
+
+/* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output */
+/* scaling factor chosen to avoid overflow. */
+
+/* In matrix notation solving equation (1) corresponds to solve */
+/* Zx = scale * b, where Z is defined as */
+
+/* Z = [ kron(In, A) -kron(B', Im) ] (2) */
+/* [ kron(In, D) -kron(E', Im) ], */
+
+/* Ik is the identity matrix of size k and X' is the transpose of X. */
+/* kron(X, Y) is the Kronecker product between the matrices X and Y. */
+
+/* If TRANS = 'C', y in the conjugate transposed system Z'y = scale*b */
+/* is solved for, which is equivalent to solve for R and L in */
+
+/* A' * R + D' * L = scale * C (3) */
+/* R * B' + L * E' = scale * -F */
+
+/* This case is used to compute an estimate of Dif[(A, D), (B, E)] = */
+/* = sigma_min(Z) using reverse communicaton with CLACON. */
+
+/* CTGSY2 also (IJOB >= 1) contributes to the computation in CTGSYL */
+/* of an upper bound on the separation between to matrix pairs. Then */
+/* the input (A, D), (B, E) are sub-pencils of two matrix pairs in */
+/* CTGSYL. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N', solve the generalized Sylvester equation (1). */
+/* = 'T': solve the 'transposed' system (3). */
+
+/* IJOB (input) INTEGER */
+/* Specifies what kind of functionality to be performed. */
+/* =0: solve (1) only. */
+/* =1: A contribution from this subsystem to a Frobenius */
+/* norm-based estimate of the separation between two matrix */
+/* pairs is computed. (look ahead strategy is used). */
+/* =2: A contribution from this subsystem to a Frobenius */
+/* norm-based estimate of the separation between two matrix */
+/* pairs is computed. (SGECON on sub-systems is used.) */
+/* Not referenced if TRANS = 'T'. */
+
+/* M (input) INTEGER */
+/* On entry, M specifies the order of A and D, and the row */
+/* dimension of C, F, R and L. */
+
+/* N (input) INTEGER */
+/* On entry, N specifies the order of B and E, and the column */
+/* dimension of C, F, R and L. */
+
+/* A (input) COMPLEX array, dimension (LDA, M) */
+/* On entry, A contains an upper triangular matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the matrix A. LDA >= max(1, M). */
+
+/* B (input) COMPLEX array, dimension (LDB, N) */
+/* On entry, B contains an upper triangular matrix. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the matrix B. LDB >= max(1, N). */
+
+/* C (input/output) COMPLEX array, dimension (LDC, N) */
+/* On entry, C contains the right-hand-side of the first matrix */
+/* equation in (1). */
+/* On exit, if IJOB = 0, C has been overwritten by the solution */
+/* R. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the matrix C. LDC >= max(1, M). */
+
+/* D (input) COMPLEX array, dimension (LDD, M) */
+/* On entry, D contains an upper triangular matrix. */
+
+/* LDD (input) INTEGER */
+/* The leading dimension of the matrix D. LDD >= max(1, M). */
+
+/* E (input) COMPLEX array, dimension (LDE, N) */
+/* On entry, E contains an upper triangular matrix. */
+
+/* LDE (input) INTEGER */
+/* The leading dimension of the matrix E. LDE >= max(1, N). */
+
+/* F (input/output) COMPLEX array, dimension (LDF, N) */
+/* On entry, F contains the right-hand-side of the second matrix */
+/* equation in (1). */
+/* On exit, if IJOB = 0, F has been overwritten by the solution */
+/* L. */
+
+/* LDF (input) INTEGER */
+/* The leading dimension of the matrix F. LDF >= max(1, M). */
+
+/* SCALE (output) REAL */
+/* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions */
+/* R and L (C and F on entry) will hold the solutions to a */
+/* slightly perturbed system but the input matrices A, B, D and */
+/* E have not been changed. If SCALE = 0, R and L will hold the */
+/* solutions to the homogeneous system with C = F = 0. */
+/* Normally, SCALE = 1. */
+
+/* RDSUM (input/output) REAL */
+/* On entry, the sum of squares of computed contributions to */
+/* the Dif-estimate under computation by CTGSYL, where the */
+/* scaling factor RDSCAL (see below) has been factored out. */
+/* On exit, the corresponding sum of squares updated with the */
+/* contributions from the current sub-system. */
+/* If TRANS = 'T' RDSUM is not touched. */
+/* NOTE: RDSUM only makes sense when CTGSY2 is called by */
+/* CTGSYL. */
+
+/* RDSCAL (input/output) REAL */
+/* On entry, scaling factor used to prevent overflow in RDSUM. */
+/* On exit, RDSCAL is updated w.r.t. the current contributions */
+/* in RDSUM. */
+/* If TRANS = 'T', RDSCAL is not touched. */
+/* NOTE: RDSCAL only makes sense when CTGSY2 is called by */
+/* CTGSYL. */
+
+/* INFO (output) INTEGER */
+/* On exit, if INFO is set to */
+/* =0: Successful exit */
+/* <0: If INFO = -i, input argument number i is illegal. */
+/* >0: The matrix pairs (A, D) and (B, E) have common or very */
+/* close eigenvalues. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ d_dim1 = *ldd;
+ d_offset = 1 + d_dim1;
+ d__ -= d_offset;
+ e_dim1 = *lde;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ f_dim1 = *ldf;
+ f_offset = 1 + f_dim1;
+ f -= f_offset;
+
+ /* Function Body */
+ *info = 0;
+ ierr = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "C")) {
+ *info = -1;
+ } else if (notran) {
+ if (*ijob < 0 || *ijob > 2) {
+ *info = -2;
+ }
+ }
+ if (*info == 0) {
+ if (*m <= 0) {
+ *info = -3;
+ } else if (*n <= 0) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ } else if (*ldd < max(1,*m)) {
+ *info = -12;
+ } else if (*lde < max(1,*n)) {
+ *info = -14;
+ } else if (*ldf < max(1,*m)) {
+ *info = -16;
+ }
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTGSY2", &i__1);
+ return 0;
+ }
+
+ if (notran) {
+
+/* Solve (I, J) - system */
+/* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) */
+/* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) */
+/* for I = M, M - 1, ..., 1; J = 1, 2, ..., N */
+
+ *scale = 1.f;
+ scaloc = 1.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (i__ = *m; i__ >= 1; --i__) {
+
+/* Build 2 by 2 system */
+
+ i__2 = i__ + i__ * a_dim1;
+ z__[0].r = a[i__2].r, z__[0].i = a[i__2].i;
+ i__2 = i__ + i__ * d_dim1;
+ z__[1].r = d__[i__2].r, z__[1].i = d__[i__2].i;
+ i__2 = j + j * b_dim1;
+ q__1.r = -b[i__2].r, q__1.i = -b[i__2].i;
+ z__[2].r = q__1.r, z__[2].i = q__1.i;
+ i__2 = j + j * e_dim1;
+ q__1.r = -e[i__2].r, q__1.i = -e[i__2].i;
+ z__[3].r = q__1.r, z__[3].i = q__1.i;
+
+/* Set up right hand side(s) */
+
+ i__2 = i__ + j * c_dim1;
+ rhs[0].r = c__[i__2].r, rhs[0].i = c__[i__2].i;
+ i__2 = i__ + j * f_dim1;
+ rhs[1].r = f[i__2].r, rhs[1].i = f[i__2].i;
+
+/* Solve Z * x = RHS */
+
+ cgetc2_(&c__2, z__, &c__2, ipiv, jpiv, &ierr);
+ if (ierr > 0) {
+ *info = ierr;
+ }
+ if (*ijob == 0) {
+ cgesc2_(&c__2, z__, &c__2, rhs, ipiv, jpiv, &scaloc);
+ if (scaloc != 1.f) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ q__1.r = scaloc, q__1.i = 0.f;
+ cscal_(m, &q__1, &c__[k * c_dim1 + 1], &c__1);
+ q__1.r = scaloc, q__1.i = 0.f;
+ cscal_(m, &q__1, &f[k * f_dim1 + 1], &c__1);
+/* L10: */
+ }
+ *scale *= scaloc;
+ }
+ } else {
+ clatdf_(ijob, &c__2, z__, &c__2, rhs, rdsum, rdscal, ipiv,
+ jpiv);
+ }
+
+/* Unpack solution vector(s) */
+
+ i__2 = i__ + j * c_dim1;
+ c__[i__2].r = rhs[0].r, c__[i__2].i = rhs[0].i;
+ i__2 = i__ + j * f_dim1;
+ f[i__2].r = rhs[1].r, f[i__2].i = rhs[1].i;
+
+/* Substitute R(I, J) and L(I, J) into remaining equation. */
+
+ if (i__ > 1) {
+ q__1.r = -rhs[0].r, q__1.i = -rhs[0].i;
+ alpha.r = q__1.r, alpha.i = q__1.i;
+ i__2 = i__ - 1;
+ caxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &c__[j
+ * c_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ caxpy_(&i__2, &alpha, &d__[i__ * d_dim1 + 1], &c__1, &f[j
+ * f_dim1 + 1], &c__1);
+ }
+ if (j < *n) {
+ i__2 = *n - j;
+ caxpy_(&i__2, &rhs[1], &b[j + (j + 1) * b_dim1], ldb, &
+ c__[i__ + (j + 1) * c_dim1], ldc);
+ i__2 = *n - j;
+ caxpy_(&i__2, &rhs[1], &e[j + (j + 1) * e_dim1], lde, &f[
+ i__ + (j + 1) * f_dim1], ldf);
+ }
+
+/* L20: */
+ }
+/* L30: */
+ }
+ } else {
+
+/* Solve transposed (I, J) - system: */
+/* A(I, I)' * R(I, J) + D(I, I)' * L(J, J) = C(I, J) */
+/* R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) */
+/* for I = 1, 2, ..., M, J = N, N - 1, ..., 1 */
+
+ *scale = 1.f;
+ scaloc = 1.f;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ for (j = *n; j >= 1; --j) {
+
+/* Build 2 by 2 system Z' */
+
+ r_cnjg(&q__1, &a[i__ + i__ * a_dim1]);
+ z__[0].r = q__1.r, z__[0].i = q__1.i;
+ r_cnjg(&q__2, &b[j + j * b_dim1]);
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ z__[1].r = q__1.r, z__[1].i = q__1.i;
+ r_cnjg(&q__1, &d__[i__ + i__ * d_dim1]);
+ z__[2].r = q__1.r, z__[2].i = q__1.i;
+ r_cnjg(&q__2, &e[j + j * e_dim1]);
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ z__[3].r = q__1.r, z__[3].i = q__1.i;
+
+
+/* Set up right hand side(s) */
+
+ i__2 = i__ + j * c_dim1;
+ rhs[0].r = c__[i__2].r, rhs[0].i = c__[i__2].i;
+ i__2 = i__ + j * f_dim1;
+ rhs[1].r = f[i__2].r, rhs[1].i = f[i__2].i;
+
+/* Solve Z' * x = RHS */
+
+ cgetc2_(&c__2, z__, &c__2, ipiv, jpiv, &ierr);
+ if (ierr > 0) {
+ *info = ierr;
+ }
+ cgesc2_(&c__2, z__, &c__2, rhs, ipiv, jpiv, &scaloc);
+ if (scaloc != 1.f) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ q__1.r = scaloc, q__1.i = 0.f;
+ cscal_(m, &q__1, &c__[k * c_dim1 + 1], &c__1);
+ q__1.r = scaloc, q__1.i = 0.f;
+ cscal_(m, &q__1, &f[k * f_dim1 + 1], &c__1);
+/* L40: */
+ }
+ *scale *= scaloc;
+ }
+
+/* Unpack solution vector(s) */
+
+ i__2 = i__ + j * c_dim1;
+ c__[i__2].r = rhs[0].r, c__[i__2].i = rhs[0].i;
+ i__2 = i__ + j * f_dim1;
+ f[i__2].r = rhs[1].r, f[i__2].i = rhs[1].i;
+
+/* Substitute R(I, J) and L(I, J) into remaining equation. */
+
+ i__2 = j - 1;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = i__ + k * f_dim1;
+ i__4 = i__ + k * f_dim1;
+ r_cnjg(&q__4, &b[k + j * b_dim1]);
+ q__3.r = rhs[0].r * q__4.r - rhs[0].i * q__4.i, q__3.i =
+ rhs[0].r * q__4.i + rhs[0].i * q__4.r;
+ q__2.r = f[i__4].r + q__3.r, q__2.i = f[i__4].i + q__3.i;
+ r_cnjg(&q__6, &e[k + j * e_dim1]);
+ q__5.r = rhs[1].r * q__6.r - rhs[1].i * q__6.i, q__5.i =
+ rhs[1].r * q__6.i + rhs[1].i * q__6.r;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+ f[i__3].r = q__1.r, f[i__3].i = q__1.i;
+/* L50: */
+ }
+ i__2 = *m;
+ for (k = i__ + 1; k <= i__2; ++k) {
+ i__3 = k + j * c_dim1;
+ i__4 = k + j * c_dim1;
+ r_cnjg(&q__4, &a[i__ + k * a_dim1]);
+ q__3.r = q__4.r * rhs[0].r - q__4.i * rhs[0].i, q__3.i =
+ q__4.r * rhs[0].i + q__4.i * rhs[0].r;
+ q__2.r = c__[i__4].r - q__3.r, q__2.i = c__[i__4].i -
+ q__3.i;
+ r_cnjg(&q__6, &d__[i__ + k * d_dim1]);
+ q__5.r = q__6.r * rhs[1].r - q__6.i * rhs[1].i, q__5.i =
+ q__6.r * rhs[1].i + q__6.i * rhs[1].r;
+ q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - q__5.i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L60: */
+ }
+
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ return 0;
+
+/* End of CTGSY2 */
+
+} /* ctgsy2_ */
diff --git a/SRC/ctgsyl.c b/SRC/ctgsyl.c
new file mode 100644
index 0000000..2e13f9b
--- /dev/null
+++ b/SRC/ctgsyl.c
@@ -0,0 +1,689 @@
+/* ctgsyl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__5 = 5;
+static integer c__1 = 1;
+static complex c_b44 = {-1.f,0.f};
+static complex c_b45 = {1.f,0.f};
+
+/* Subroutine */ int ctgsyl_(char *trans, integer *ijob, integer *m, integer *
+ n, complex *a, integer *lda, complex *b, integer *ldb, complex *c__,
+ integer *ldc, complex *d__, integer *ldd, complex *e, integer *lde,
+ complex *f, integer *ldf, real *scale, real *dif, complex *work,
+ integer *lwork, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
+ d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3,
+ i__4;
+ complex q__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, p, q, ie, je, mb, nb, is, js, pq;
+ real dsum;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *), cgemm_(char *, char *, integer *, integer *, integer *
+, complex *, complex *, integer *, complex *, integer *, complex *
+, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ integer ifunc, linfo, lwmin;
+ real scale2;
+ extern /* Subroutine */ int ctgsy2_(char *, integer *, integer *, integer
+ *, complex *, integer *, complex *, integer *, complex *, integer
+ *, complex *, integer *, complex *, integer *, complex *, integer
+ *, real *, real *, real *, integer *);
+ real dscale, scaloc;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer iround;
+ logical notran;
+ integer isolve;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTGSYL solves the generalized Sylvester equation: */
+
+/* A * R - L * B = scale * C (1) */
+/* D * R - L * E = scale * F */
+
+/* where R and L are unknown m-by-n matrices, (A, D), (B, E) and */
+/* (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n, */
+/* respectively, with complex entries. A, B, D and E are upper */
+/* triangular (i.e., (A,D) and (B,E) in generalized Schur form). */
+
+/* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 */
+/* is an output scaling factor chosen to avoid overflow. */
+
+/* In matrix notation (1) is equivalent to solve Zx = scale*b, where Z */
+/* is defined as */
+
+/* Z = [ kron(In, A) -kron(B', Im) ] (2) */
+/* [ kron(In, D) -kron(E', Im) ], */
+
+/* Here Ix is the identity matrix of size x and X' is the conjugate */
+/* transpose of X. Kron(X, Y) is the Kronecker product between the */
+/* matrices X and Y. */
+
+/* If TRANS = 'C', y in the conjugate transposed system Z'*y = scale*b */
+/* is solved for, which is equivalent to solve for R and L in */
+
+/* A' * R + D' * L = scale * C (3) */
+/* R * B' + L * E' = scale * -F */
+
+/* This case (TRANS = 'C') is used to compute an one-norm-based estimate */
+/* of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D) */
+/* and (B,E), using CLACON. */
+
+/* If IJOB >= 1, CTGSYL computes a Frobenius norm-based estimate of */
+/* Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the */
+/* reciprocal of the smallest singular value of Z. */
+
+/* This is a level-3 BLAS algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': solve the generalized sylvester equation (1). */
+/* = 'C': solve the "conjugate transposed" system (3). */
+
+/* IJOB (input) INTEGER */
+/* Specifies what kind of functionality to be performed. */
+/* =0: solve (1) only. */
+/* =1: The functionality of 0 and 3. */
+/* =2: The functionality of 0 and 4. */
+/* =3: Only an estimate of Dif[(A,D), (B,E)] is computed. */
+/* (look ahead strategy is used). */
+/* =4: Only an estimate of Dif[(A,D), (B,E)] is computed. */
+/* (CGECON on sub-systems is used). */
+/* Not referenced if TRANS = 'C'. */
+
+/* M (input) INTEGER */
+/* The order of the matrices A and D, and the row dimension of */
+/* the matrices C, F, R and L. */
+
+/* N (input) INTEGER */
+/* The order of the matrices B and E, and the column dimension */
+/* of the matrices C, F, R and L. */
+
+/* A (input) COMPLEX array, dimension (LDA, M) */
+/* The upper triangular matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1, M). */
+
+/* B (input) COMPLEX array, dimension (LDB, N) */
+/* The upper triangular matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1, N). */
+
+/* C (input/output) COMPLEX array, dimension (LDC, N) */
+/* On entry, C contains the right-hand-side of the first matrix */
+/* equation in (1) or (3). */
+/* On exit, if IJOB = 0, 1 or 2, C has been overwritten by */
+/* the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R, */
+/* the solution achieved during the computation of the */
+/* Dif-estimate. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1, M). */
+
+/* D (input) COMPLEX array, dimension (LDD, M) */
+/* The upper triangular matrix D. */
+
+/* LDD (input) INTEGER */
+/* The leading dimension of the array D. LDD >= max(1, M). */
+
+/* E (input) COMPLEX array, dimension (LDE, N) */
+/* The upper triangular matrix E. */
+
+/* LDE (input) INTEGER */
+/* The leading dimension of the array E. LDE >= max(1, N). */
+
+/* F (input/output) COMPLEX array, dimension (LDF, N) */
+/* On entry, F contains the right-hand-side of the second matrix */
+/* equation in (1) or (3). */
+/* On exit, if IJOB = 0, 1 or 2, F has been overwritten by */
+/* the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L, */
+/* the solution achieved during the computation of the */
+/* Dif-estimate. */
+
+/* LDF (input) INTEGER */
+/* The leading dimension of the array F. LDF >= max(1, M). */
+
+/* DIF (output) REAL */
+/* On exit DIF is the reciprocal of a lower bound of the */
+/* reciprocal of the Dif-function, i.e. DIF is an upper bound of */
+/* Dif[(A,D), (B,E)] = sigma-min(Z), where Z as in (2). */
+/* IF IJOB = 0 or TRANS = 'C', DIF is not referenced. */
+
+/* SCALE (output) REAL */
+/* On exit SCALE is the scaling factor in (1) or (3). */
+/* If 0 < SCALE < 1, C and F hold the solutions R and L, resp., */
+/* to a slightly perturbed system but the input matrices A, B, */
+/* D and E have not been changed. If SCALE = 0, R and L will */
+/* hold the solutions to the homogenious system with C = F = 0. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK > = 1. */
+/* If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N). */
+
+/* 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. */
+
+/* IWORK (workspace) INTEGER array, dimension (M+N+2) */
+
+/* INFO (output) INTEGER */
+/* =0: successful exit */
+/* <0: If INFO = -i, the i-th argument had an illegal value. */
+/* >0: (A, D) and (B, E) have common or very close */
+/* eigenvalues. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
+/* for Solving the Generalized Sylvester Equation and Estimating the */
+/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
+/* Department of Computing Science, Umea University, S-901 87 Umea, */
+/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */
+/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, */
+/* No 1, 1996. */
+
+/* [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester */
+/* Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal. */
+/* Appl., 15(4):1045-1060, 1994. */
+
+/* [3] B. Kagstrom and L. Westin, Generalized Schur Methods with */
+/* Condition Estimators for Solving the Generalized Sylvester */
+/* Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7, */
+/* July 1989, pp 745-751. */
+
+/* ===================================================================== */
+/* Replaced various illegal calls to CCOPY by calls to CLASET. */
+/* Sven Hammarling, 1/5/02. */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ d_dim1 = *ldd;
+ d_offset = 1 + d_dim1;
+ d__ -= d_offset;
+ e_dim1 = *lde;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ f_dim1 = *ldf;
+ f_offset = 1 + f_dim1;
+ f -= f_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+ if (! notran && ! lsame_(trans, "C")) {
+ *info = -1;
+ } else if (notran) {
+ if (*ijob < 0 || *ijob > 4) {
+ *info = -2;
+ }
+ }
+ if (*info == 0) {
+ if (*m <= 0) {
+ *info = -3;
+ } else if (*n <= 0) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ } else if (*ldd < max(1,*m)) {
+ *info = -12;
+ } else if (*lde < max(1,*n)) {
+ *info = -14;
+ } else if (*ldf < max(1,*m)) {
+ *info = -16;
+ }
+ }
+
+ if (*info == 0) {
+ if (notran) {
+ if (*ijob == 1 || *ijob == 2) {
+/* Computing MAX */
+ i__1 = 1, i__2 = (*m << 1) * *n;
+ lwmin = max(i__1,i__2);
+ } else {
+ lwmin = 1;
+ }
+ } else {
+ lwmin = 1;
+ }
+ work[1].r = (real) lwmin, work[1].i = 0.f;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -20;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTGSYL", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ *scale = 1.f;
+ if (notran) {
+ if (*ijob != 0) {
+ *dif = 0.f;
+ }
+ }
+ return 0;
+ }
+
+/* Determine optimal block sizes MB and NB */
+
+ mb = ilaenv_(&c__2, "CTGSYL", trans, m, n, &c_n1, &c_n1);
+ nb = ilaenv_(&c__5, "CTGSYL", trans, m, n, &c_n1, &c_n1);
+
+ isolve = 1;
+ ifunc = 0;
+ if (notran) {
+ if (*ijob >= 3) {
+ ifunc = *ijob - 2;
+ claset_("F", m, n, &c_b1, &c_b1, &c__[c_offset], ldc);
+ claset_("F", m, n, &c_b1, &c_b1, &f[f_offset], ldf);
+ } else if (*ijob >= 1 && notran) {
+ isolve = 2;
+ }
+ }
+
+ if (mb <= 1 && nb <= 1 || mb >= *m && nb >= *n) {
+
+/* Use unblocked Level 2 solver */
+
+ i__1 = isolve;
+ for (iround = 1; iround <= i__1; ++iround) {
+
+ *scale = 1.f;
+ dscale = 0.f;
+ dsum = 1.f;
+ pq = *m * *n;
+ ctgsy2_(trans, &ifunc, m, n, &a[a_offset], lda, &b[b_offset], ldb,
+ &c__[c_offset], ldc, &d__[d_offset], ldd, &e[e_offset],
+ lde, &f[f_offset], ldf, scale, &dsum, &dscale, info);
+ if (dscale != 0.f) {
+ if (*ijob == 1 || *ijob == 3) {
+ *dif = sqrt((real) ((*m << 1) * *n)) / (dscale * sqrt(
+ dsum));
+ } else {
+ *dif = sqrt((real) pq) / (dscale * sqrt(dsum));
+ }
+ }
+ if (isolve == 2 && iround == 1) {
+ if (notran) {
+ ifunc = *ijob;
+ }
+ scale2 = *scale;
+ clacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m);
+ clacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m);
+ claset_("F", m, n, &c_b1, &c_b1, &c__[c_offset], ldc);
+ claset_("F", m, n, &c_b1, &c_b1, &f[f_offset], ldf)
+ ;
+ } else if (isolve == 2 && iround == 2) {
+ clacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc);
+ clacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf);
+ *scale = scale2;
+ }
+/* L30: */
+ }
+
+ return 0;
+
+ }
+
+/* Determine block structure of A */
+
+ p = 0;
+ i__ = 1;
+L40:
+ if (i__ > *m) {
+ goto L50;
+ }
+ ++p;
+ iwork[p] = i__;
+ i__ += mb;
+ if (i__ >= *m) {
+ goto L50;
+ }
+ goto L40;
+L50:
+ iwork[p + 1] = *m + 1;
+ if (iwork[p] == iwork[p + 1]) {
+ --p;
+ }
+
+/* Determine block structure of B */
+
+ q = p + 1;
+ j = 1;
+L60:
+ if (j > *n) {
+ goto L70;
+ }
+
+ ++q;
+ iwork[q] = j;
+ j += nb;
+ if (j >= *n) {
+ goto L70;
+ }
+ goto L60;
+
+L70:
+ iwork[q + 1] = *n + 1;
+ if (iwork[q] == iwork[q + 1]) {
+ --q;
+ }
+
+ if (notran) {
+ i__1 = isolve;
+ for (iround = 1; iround <= i__1; ++iround) {
+
+/* Solve (I, J) - subsystem */
+/* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) */
+/* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) */
+/* for I = P, P - 1, ..., 1; J = 1, 2, ..., Q */
+
+ pq = 0;
+ *scale = 1.f;
+ dscale = 0.f;
+ dsum = 1.f;
+ i__2 = q;
+ for (j = p + 2; j <= i__2; ++j) {
+ js = iwork[j];
+ je = iwork[j + 1] - 1;
+ nb = je - js + 1;
+ for (i__ = p; i__ >= 1; --i__) {
+ is = iwork[i__];
+ ie = iwork[i__ + 1] - 1;
+ mb = ie - is + 1;
+ ctgsy2_(trans, &ifunc, &mb, &nb, &a[is + is * a_dim1],
+ lda, &b[js + js * b_dim1], ldb, &c__[is + js *
+ c_dim1], ldc, &d__[is + is * d_dim1], ldd, &e[js
+ + js * e_dim1], lde, &f[is + js * f_dim1], ldf, &
+ scaloc, &dsum, &dscale, &linfo);
+ if (linfo > 0) {
+ *info = linfo;
+ }
+ pq += mb * nb;
+ if (scaloc != 1.f) {
+ i__3 = js - 1;
+ for (k = 1; k <= i__3; ++k) {
+ q__1.r = scaloc, q__1.i = 0.f;
+ cscal_(m, &q__1, &c__[k * c_dim1 + 1], &c__1);
+ q__1.r = scaloc, q__1.i = 0.f;
+ cscal_(m, &q__1, &f[k * f_dim1 + 1], &c__1);
+/* L80: */
+ }
+ i__3 = je;
+ for (k = js; k <= i__3; ++k) {
+ i__4 = is - 1;
+ q__1.r = scaloc, q__1.i = 0.f;
+ cscal_(&i__4, &q__1, &c__[k * c_dim1 + 1], &c__1);
+ i__4 = is - 1;
+ q__1.r = scaloc, q__1.i = 0.f;
+ cscal_(&i__4, &q__1, &f[k * f_dim1 + 1], &c__1);
+/* L90: */
+ }
+ i__3 = je;
+ for (k = js; k <= i__3; ++k) {
+ i__4 = *m - ie;
+ q__1.r = scaloc, q__1.i = 0.f;
+ cscal_(&i__4, &q__1, &c__[ie + 1 + k * c_dim1], &
+ c__1);
+ i__4 = *m - ie;
+ q__1.r = scaloc, q__1.i = 0.f;
+ cscal_(&i__4, &q__1, &f[ie + 1 + k * f_dim1], &
+ c__1);
+/* L100: */
+ }
+ i__3 = *n;
+ for (k = je + 1; k <= i__3; ++k) {
+ q__1.r = scaloc, q__1.i = 0.f;
+ cscal_(m, &q__1, &c__[k * c_dim1 + 1], &c__1);
+ q__1.r = scaloc, q__1.i = 0.f;
+ cscal_(m, &q__1, &f[k * f_dim1 + 1], &c__1);
+/* L110: */
+ }
+ *scale *= scaloc;
+ }
+
+/* Substitute R(I,J) and L(I,J) into remaining equation. */
+
+ if (i__ > 1) {
+ i__3 = is - 1;
+ cgemm_("N", "N", &i__3, &nb, &mb, &c_b44, &a[is *
+ a_dim1 + 1], lda, &c__[is + js * c_dim1], ldc,
+ &c_b45, &c__[js * c_dim1 + 1], ldc);
+ i__3 = is - 1;
+ cgemm_("N", "N", &i__3, &nb, &mb, &c_b44, &d__[is *
+ d_dim1 + 1], ldd, &c__[is + js * c_dim1], ldc,
+ &c_b45, &f[js * f_dim1 + 1], ldf);
+ }
+ if (j < q) {
+ i__3 = *n - je;
+ cgemm_("N", "N", &mb, &i__3, &nb, &c_b45, &f[is + js *
+ f_dim1], ldf, &b[js + (je + 1) * b_dim1],
+ ldb, &c_b45, &c__[is + (je + 1) * c_dim1],
+ ldc);
+ i__3 = *n - je;
+ cgemm_("N", "N", &mb, &i__3, &nb, &c_b45, &f[is + js *
+ f_dim1], ldf, &e[js + (je + 1) * e_dim1],
+ lde, &c_b45, &f[is + (je + 1) * f_dim1], ldf);
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+ if (dscale != 0.f) {
+ if (*ijob == 1 || *ijob == 3) {
+ *dif = sqrt((real) ((*m << 1) * *n)) / (dscale * sqrt(
+ dsum));
+ } else {
+ *dif = sqrt((real) pq) / (dscale * sqrt(dsum));
+ }
+ }
+ if (isolve == 2 && iround == 1) {
+ if (notran) {
+ ifunc = *ijob;
+ }
+ scale2 = *scale;
+ clacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m);
+ clacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m);
+ claset_("F", m, n, &c_b1, &c_b1, &c__[c_offset], ldc);
+ claset_("F", m, n, &c_b1, &c_b1, &f[f_offset], ldf)
+ ;
+ } else if (isolve == 2 && iround == 2) {
+ clacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc);
+ clacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf);
+ *scale = scale2;
+ }
+/* L150: */
+ }
+ } else {
+
+/* Solve transposed (I, J)-subsystem */
+/* A(I, I)' * R(I, J) + D(I, I)' * L(I, J) = C(I, J) */
+/* R(I, J) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) */
+/* for I = 1,2,..., P; J = Q, Q-1,..., 1 */
+
+ *scale = 1.f;
+ i__1 = p;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ is = iwork[i__];
+ ie = iwork[i__ + 1] - 1;
+ mb = ie - is + 1;
+ i__2 = p + 2;
+ for (j = q; j >= i__2; --j) {
+ js = iwork[j];
+ je = iwork[j + 1] - 1;
+ nb = je - js + 1;
+ ctgsy2_(trans, &ifunc, &mb, &nb, &a[is + is * a_dim1], lda, &
+ b[js + js * b_dim1], ldb, &c__[is + js * c_dim1], ldc,
+ &d__[is + is * d_dim1], ldd, &e[js + js * e_dim1],
+ lde, &f[is + js * f_dim1], ldf, &scaloc, &dsum, &
+ dscale, &linfo);
+ if (linfo > 0) {
+ *info = linfo;
+ }
+ if (scaloc != 1.f) {
+ i__3 = js - 1;
+ for (k = 1; k <= i__3; ++k) {
+ q__1.r = scaloc, q__1.i = 0.f;
+ cscal_(m, &q__1, &c__[k * c_dim1 + 1], &c__1);
+ q__1.r = scaloc, q__1.i = 0.f;
+ cscal_(m, &q__1, &f[k * f_dim1 + 1], &c__1);
+/* L160: */
+ }
+ i__3 = je;
+ for (k = js; k <= i__3; ++k) {
+ i__4 = is - 1;
+ q__1.r = scaloc, q__1.i = 0.f;
+ cscal_(&i__4, &q__1, &c__[k * c_dim1 + 1], &c__1);
+ i__4 = is - 1;
+ q__1.r = scaloc, q__1.i = 0.f;
+ cscal_(&i__4, &q__1, &f[k * f_dim1 + 1], &c__1);
+/* L170: */
+ }
+ i__3 = je;
+ for (k = js; k <= i__3; ++k) {
+ i__4 = *m - ie;
+ q__1.r = scaloc, q__1.i = 0.f;
+ cscal_(&i__4, &q__1, &c__[ie + 1 + k * c_dim1], &c__1)
+ ;
+ i__4 = *m - ie;
+ q__1.r = scaloc, q__1.i = 0.f;
+ cscal_(&i__4, &q__1, &f[ie + 1 + k * f_dim1], &c__1);
+/* L180: */
+ }
+ i__3 = *n;
+ for (k = je + 1; k <= i__3; ++k) {
+ q__1.r = scaloc, q__1.i = 0.f;
+ cscal_(m, &q__1, &c__[k * c_dim1 + 1], &c__1);
+ q__1.r = scaloc, q__1.i = 0.f;
+ cscal_(m, &q__1, &f[k * f_dim1 + 1], &c__1);
+/* L190: */
+ }
+ *scale *= scaloc;
+ }
+
+/* Substitute R(I,J) and L(I,J) into remaining equation. */
+
+ if (j > p + 2) {
+ i__3 = js - 1;
+ cgemm_("N", "C", &mb, &i__3, &nb, &c_b45, &c__[is + js *
+ c_dim1], ldc, &b[js * b_dim1 + 1], ldb, &c_b45, &
+ f[is + f_dim1], ldf);
+ i__3 = js - 1;
+ cgemm_("N", "C", &mb, &i__3, &nb, &c_b45, &f[is + js *
+ f_dim1], ldf, &e[js * e_dim1 + 1], lde, &c_b45, &
+ f[is + f_dim1], ldf);
+ }
+ if (i__ < p) {
+ i__3 = *m - ie;
+ cgemm_("C", "N", &i__3, &nb, &mb, &c_b44, &a[is + (ie + 1)
+ * a_dim1], lda, &c__[is + js * c_dim1], ldc, &
+ c_b45, &c__[ie + 1 + js * c_dim1], ldc);
+ i__3 = *m - ie;
+ cgemm_("C", "N", &i__3, &nb, &mb, &c_b44, &d__[is + (ie +
+ 1) * d_dim1], ldd, &f[is + js * f_dim1], ldf, &
+ c_b45, &c__[ie + 1 + js * c_dim1], ldc);
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+ }
+
+ work[1].r = (real) lwmin, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CTGSYL */
+
+} /* ctgsyl_ */
diff --git a/SRC/ctpcon.c b/SRC/ctpcon.c
new file mode 100644
index 0000000..fafeb8e
--- /dev/null
+++ b/SRC/ctpcon.c
@@ -0,0 +1,240 @@
+/* ctpcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ctpcon_(char *norm, char *uplo, char *diag, integer *n,
+ complex *ap, real *rcond, complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer ix, kase, kase1;
+ real scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ real anorm;
+ logical upper;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *);
+ real xnorm;
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal clantp_(char *, char *, char *, integer *, complex *,
+ real *);
+ extern /* Subroutine */ int clatps_(char *, char *, char *, char *,
+ integer *, complex *, complex *, real *, real *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int csrscl_(integer *, real *, complex *, integer
+ *);
+ logical onenrm;
+ char normin[1];
+ real smlnum;
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTPCON estimates the reciprocal of the condition number of a packed */
+/* triangular matrix A, in either the 1-norm or the infinity-norm. */
+
+/* The norm of A is computed and an estimate is obtained for */
+/* norm(inv(A)), then the reciprocal of the condition number is */
+/* computed as */
+/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* RCOND (output) REAL */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ nounit = lsame_(diag, "N");
+
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTPCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ }
+
+ *rcond = 0.f;
+ smlnum = slamch_("Safe minimum") * (real) max(1,*n);
+
+/* Compute the norm of the triangular matrix A. */
+
+ anorm = clantp_(norm, uplo, diag, n, &ap[1], &rwork[1]);
+
+/* Continue only if ANORM > 0. */
+
+ if (anorm > 0.f) {
+
+/* Estimate the norm of the inverse of A. */
+
+ ainvnm = 0.f;
+ *(unsigned char *)normin = 'N';
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kase = 0;
+L10:
+ clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(A). */
+
+ clatps_(uplo, "No transpose", diag, normin, n, &ap[1], &work[
+ 1], &scale, &rwork[1], info);
+ } else {
+
+/* Multiply by inv(A'). */
+
+ clatps_(uplo, "Conjugate transpose", diag, normin, n, &ap[1],
+ &work[1], &scale, &rwork[1], info);
+ }
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ if (scale != 1.f) {
+ ix = icamax_(n, &work[1], &c__1);
+ i__1 = ix;
+ xnorm = (r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
+ work[ix]), dabs(r__2));
+ if (scale < xnorm * smlnum || scale == 0.f) {
+ goto L20;
+ }
+ csrscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / anorm / ainvnm;
+ }
+ }
+
+L20:
+ return 0;
+
+/* End of CTPCON */
+
+} /* ctpcon_ */
diff --git a/SRC/ctprfs.c b/SRC/ctprfs.c
new file mode 100644
index 0000000..cf3bd0e
--- /dev/null
+++ b/SRC/ctprfs.c
@@ -0,0 +1,565 @@
+/* ctprfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ctprfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, complex *ap, complex *b, integer *ldb, complex *x,
+ integer *ldx, real *ferr, real *berr, complex *work, real *rwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ real s;
+ integer kc;
+ real xk;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *), ctpmv_(char *, char *, char *,
+ integer *, complex *, complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
+ complex *, complex *, integer *), clacn2_(
+ integer *, complex *, complex *, real *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+ char transn[1], transt[1];
+ logical nounit;
+ real lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTPRFS provides error bounds and backward error estimates for the */
+/* solution to a system of linear equations with a triangular packed */
+/* coefficient matrix. */
+
+/* The solution matrix X must be computed by CTPTRS or some other */
+/* means before entering this routine. CTPRFS does not do iterative */
+/* refinement because doing so cannot improve the backward error. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*ldx < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTPRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transn = 'N';
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transn = 'C';
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A, A**T, or A**H, depending on TRANS. */
+
+ ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ctpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1);
+ q__1.r = -1.f, q__1.i = -0.f;
+ caxpy_(n, &q__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[
+ i__ + j * b_dim1]), dabs(r__2));
+/* L20: */
+ }
+
+ if (notran) {
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ kc = 1;
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ x[k + j * x_dim1]), dabs(r__2));
+ i__3 = k;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = kc + i__ - 1;
+ rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (
+ r__2 = r_imag(&ap[kc + i__ - 1]), dabs(
+ r__2))) * xk;
+/* L30: */
+ }
+ kc += k;
+/* L40: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ x[k + j * x_dim1]), dabs(r__2));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = kc + i__ - 1;
+ rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (
+ r__2 = r_imag(&ap[kc + i__ - 1]), dabs(
+ r__2))) * xk;
+/* L50: */
+ }
+ rwork[k] += xk;
+ kc += k;
+/* L60: */
+ }
+ }
+ } else {
+ kc = 1;
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ x[k + j * x_dim1]), dabs(r__2));
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ i__4 = kc + i__ - k;
+ rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (
+ r__2 = r_imag(&ap[kc + i__ - k]), dabs(
+ r__2))) * xk;
+/* L70: */
+ }
+ kc = kc + *n - k + 1;
+/* L80: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ x[k + j * x_dim1]), dabs(r__2));
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ i__4 = kc + i__ - k;
+ rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (
+ r__2 = r_imag(&ap[kc + i__ - k]), dabs(
+ r__2))) * xk;
+/* L90: */
+ }
+ rwork[k] += xk;
+ kc = kc + *n - k + 1;
+/* L100: */
+ }
+ }
+ }
+ } else {
+
+/* Compute abs(A**H)*abs(X) + abs(B). */
+
+ if (upper) {
+ kc = 1;
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__3 = k;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = kc + i__ - 1;
+ i__5 = i__ + j * x_dim1;
+ s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&ap[kc + i__ - 1]), dabs(r__2))) *
+ ((r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
+ r_imag(&x[i__ + j * x_dim1]), dabs(r__4)))
+ ;
+/* L110: */
+ }
+ rwork[k] += s;
+ kc += k;
+/* L120: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ s = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ x[k + j * x_dim1]), dabs(r__2));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = kc + i__ - 1;
+ i__5 = i__ + j * x_dim1;
+ s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&ap[kc + i__ - 1]), dabs(r__2))) *
+ ((r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
+ r_imag(&x[i__ + j * x_dim1]), dabs(r__4)))
+ ;
+/* L130: */
+ }
+ rwork[k] += s;
+ kc += k;
+/* L140: */
+ }
+ }
+ } else {
+ kc = 1;
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ i__4 = kc + i__ - k;
+ i__5 = i__ + j * x_dim1;
+ s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&ap[kc + i__ - k]), dabs(r__2))) *
+ ((r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
+ r_imag(&x[i__ + j * x_dim1]), dabs(r__4)))
+ ;
+/* L150: */
+ }
+ rwork[k] += s;
+ kc = kc + *n - k + 1;
+/* L160: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ s = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ x[k + j * x_dim1]), dabs(r__2));
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ i__4 = kc + i__ - k;
+ i__5 = i__ + j * x_dim1;
+ s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&ap[kc + i__ - k]), dabs(r__2))) *
+ ((r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
+ r_imag(&x[i__ + j * x_dim1]), dabs(r__4)))
+ ;
+/* L170: */
+ }
+ rwork[k] += s;
+ kc = kc + *n - k + 1;
+/* L180: */
+ }
+ }
+ }
+ }
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__3 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
+ s = dmax(r__3,r__4);
+ } else {
+/* Computing MAX */
+ i__3 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = dmax(r__3,r__4);
+ }
+/* L190: */
+ }
+ berr[j] = s;
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use CLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__3 = i__;
+ rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__];
+ } else {
+ i__3 = i__;
+ rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__] + safe1;
+ }
+/* L200: */
+ }
+
+ kase = 0;
+L210:
+ clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)**H). */
+
+ ctpsv_(uplo, transt, diag, n, &ap[1], &work[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L220: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L230: */
+ }
+ ctpsv_(uplo, transn, diag, n, &ap[1], &work[1], &c__1);
+ }
+ goto L210;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * x_dim1;
+ r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + j * x_dim1]), dabs(r__2));
+ lstres = dmax(r__3,r__4);
+/* L240: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L250: */
+ }
+
+ return 0;
+
+/* End of CTPRFS */
+
+} /* ctprfs_ */
diff --git a/SRC/ctptri.c b/SRC/ctptri.c
new file mode 100644
index 0000000..f8161f2
--- /dev/null
+++ b/SRC/ctptri.c
@@ -0,0 +1,236 @@
+/* ctptri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int ctptri_(char *uplo, char *diag, integer *n, complex *ap,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ complex q__1;
+
+ /* Builtin functions */
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer j, jc, jj;
+ complex ajj;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ctpmv_(char *, char *, char *, integer *,
+ complex *, complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer jclast;
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTPTRI computes the inverse of a complex upper or lower triangular */
+/* matrix A stored in packed format. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangular matrix A, stored */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+/* On exit, the (triangular) inverse of the original matrix, in */
+/* the same packed storage format. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */
+/* matrix is singular and its inverse can not be computed. */
+
+/* Further Details */
+/* =============== */
+
+/* A triangular matrix A can be transferred to packed storage using one */
+/* of the following program segments: */
+
+/* UPLO = 'U': UPLO = 'L': */
+
+/* JC = 1 JC = 1 */
+/* DO 2 J = 1, N DO 2 J = 1, N */
+/* DO 1 I = 1, J DO 1 I = J, N */
+/* AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J) */
+/* 1 CONTINUE 1 CONTINUE */
+/* JC = JC + J JC = JC + N - J + 1 */
+/* 2 CONTINUE 2 CONTINUE */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ nounit = lsame_(diag, "N");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTPTRI", &i__1);
+ return 0;
+ }
+
+/* Check for singularity if non-unit. */
+
+ if (nounit) {
+ if (upper) {
+ jj = 0;
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ jj += *info;
+ i__2 = jj;
+ if (ap[i__2].r == 0.f && ap[i__2].i == 0.f) {
+ return 0;
+ }
+/* L10: */
+ }
+ } else {
+ jj = 1;
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ i__2 = jj;
+ if (ap[i__2].r == 0.f && ap[i__2].i == 0.f) {
+ return 0;
+ }
+ jj = jj + *n - *info + 1;
+/* L20: */
+ }
+ }
+ *info = 0;
+ }
+
+ if (upper) {
+
+/* Compute inverse of upper triangular matrix. */
+
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (nounit) {
+ i__2 = jc + j - 1;
+ c_div(&q__1, &c_b1, &ap[jc + j - 1]);
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ i__2 = jc + j - 1;
+ q__1.r = -ap[i__2].r, q__1.i = -ap[i__2].i;
+ ajj.r = q__1.r, ajj.i = q__1.i;
+ } else {
+ q__1.r = -1.f, q__1.i = -0.f;
+ ajj.r = q__1.r, ajj.i = q__1.i;
+ }
+
+/* Compute elements 1:j-1 of j-th column. */
+
+ i__2 = j - 1;
+ ctpmv_("Upper", "No transpose", diag, &i__2, &ap[1], &ap[jc], &
+ c__1);
+ i__2 = j - 1;
+ cscal_(&i__2, &ajj, &ap[jc], &c__1);
+ jc += j;
+/* L30: */
+ }
+
+ } else {
+
+/* Compute inverse of lower triangular matrix. */
+
+ jc = *n * (*n + 1) / 2;
+ for (j = *n; j >= 1; --j) {
+ if (nounit) {
+ i__1 = jc;
+ c_div(&q__1, &c_b1, &ap[jc]);
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ i__1 = jc;
+ q__1.r = -ap[i__1].r, q__1.i = -ap[i__1].i;
+ ajj.r = q__1.r, ajj.i = q__1.i;
+ } else {
+ q__1.r = -1.f, q__1.i = -0.f;
+ ajj.r = q__1.r, ajj.i = q__1.i;
+ }
+ if (j < *n) {
+
+/* Compute elements j+1:n of j-th column. */
+
+ i__1 = *n - j;
+ ctpmv_("Lower", "No transpose", diag, &i__1, &ap[jclast], &ap[
+ jc + 1], &c__1);
+ i__1 = *n - j;
+ cscal_(&i__1, &ajj, &ap[jc + 1], &c__1);
+ }
+ jclast = jc;
+ jc = jc - *n + j - 2;
+/* L40: */
+ }
+ }
+
+ return 0;
+
+/* End of CTPTRI */
+
+} /* ctptri_ */
diff --git a/SRC/ctptrs.c b/SRC/ctptrs.c
new file mode 100644
index 0000000..ae5dbc7
--- /dev/null
+++ b/SRC/ctptrs.c
@@ -0,0 +1,194 @@
+/* ctptrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ctptrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, complex *ap, complex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2;
+
+ /* Local variables */
+ integer j, jc;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
+ complex *, complex *, integer *), xerbla_(
+ char *, integer *);
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTPTRS solves a triangular system of the form */
+
+/* A * X = B, A**T * X = B, or A**H * X = B, */
+
+/* where A is a triangular matrix of order N stored in packed format, */
+/* and B is an N-by-NRHS matrix. A check is made to verify that A is */
+/* nonsingular. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, if INFO = 0, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element of A is zero, */
+/* indicating that the matrix is singular and the */
+/* solutions X have not been computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ nounit = lsame_(diag, "N");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTPTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check for singularity. */
+
+ if (nounit) {
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ i__2 = jc + *info - 1;
+ if (ap[i__2].r == 0.f && ap[i__2].i == 0.f) {
+ return 0;
+ }
+ jc += *info;
+/* L10: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ i__2 = jc;
+ if (ap[i__2].r == 0.f && ap[i__2].i == 0.f) {
+ return 0;
+ }
+ jc = jc + *n - *info + 1;
+/* L20: */
+ }
+ }
+ }
+ *info = 0;
+
+/* Solve A * x = b, A**T * x = b, or A**H * x = b. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ctpsv_(uplo, trans, diag, n, &ap[1], &b[j * b_dim1 + 1], &c__1);
+/* L30: */
+ }
+
+ return 0;
+
+/* End of CTPTRS */
+
+} /* ctptrs_ */
diff --git a/SRC/ctpttf.c b/SRC/ctpttf.c
new file mode 100644
index 0000000..ffd424c
--- /dev/null
+++ b/SRC/ctpttf.c
@@ -0,0 +1,573 @@
+/* ctpttf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ctpttf_(char *transr, char *uplo, integer *n, complex *
+ ap, complex *arf, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ complex q__1;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k, n1, n2, ij, jp, js, nt, lda, ijp;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nisodd;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTPTTF copies a triangular matrix A from standard packed format (TP) */
+/* to rectangular full packed format (TF). */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': ARF in Normal format is wanted; */
+/* = 'C': ARF in Conjugate-transpose format is wanted. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) COMPLEX array, dimension ( N*(N+1)/2 ), */
+/* On entry, the upper or lower triangular matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* ARF (output) COMPLEX array, dimension ( N*(N+1)/2 ), */
+/* On exit, the upper or lower triangular matrix A stored in */
+/* RFP format. For a further discussion see Notes below. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Notes: */
+/* ====== */
+
+/* We first consider Standard Packed Format when N is even. */
+/* We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* conjugate-transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* conjugate-transpose of the last three columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- -- */
+/* 03 04 05 33 43 53 */
+/* -- -- */
+/* 13 14 15 00 44 54 */
+/* -- */
+/* 23 24 25 10 11 55 */
+
+/* 33 34 35 20 21 22 */
+/* -- */
+/* 00 44 45 30 31 32 */
+/* -- -- */
+/* 01 11 55 40 41 42 */
+/* -- -- -- */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We next consider Standard Packed Format when N is odd. */
+/* We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* conjugate-transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* conjugate-transpose of the last two columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- */
+/* 02 03 04 00 33 43 */
+/* -- */
+/* 12 13 14 10 11 44 */
+
+/* 22 23 24 20 21 22 */
+/* -- */
+/* 00 33 34 30 31 32 */
+/* -- -- */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- */
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "C")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTPTTF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (normaltransr) {
+ arf[0].r = ap[0].r, arf[0].i = ap[0].i;
+ } else {
+ r_cnjg(&q__1, ap);
+ arf[0].r = q__1.r, arf[0].i = q__1.i;
+ }
+ return 0;
+ }
+
+/* Size of array ARF(0:NT-1) */
+
+ nt = *n * (*n + 1) / 2;
+
+/* Set N1 and N2 depending on LOWER */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* If N is odd, set NISODD = .TRUE. */
+/* If N is even, set K = N/2 and NISODD = .FALSE. */
+
+/* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) */
+/* where noe = 0 if n is even, noe = 1 if n is odd */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ lda = *n + 1;
+ } else {
+ nisodd = TRUE_;
+ lda = *n;
+ }
+
+/* ARF^C has lda rows and n+1-noe cols */
+
+ if (! normaltransr) {
+ lda = (*n + 1) / 2;
+ }
+
+/* start execution: there are eight cases */
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */
+/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */
+/* T1 -> a(0), T2 -> a(n), S -> a(n1); lda = n */
+
+ ijp = 0;
+ jp = 0;
+ i__1 = n2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ij = i__ + jp;
+ i__3 = ij;
+ i__4 = ijp;
+ arf[i__3].r = ap[i__4].r, arf[i__3].i = ap[i__4].i;
+ ++ijp;
+ }
+ jp += lda;
+ }
+ i__1 = n2 - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = n2;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ ij = i__ + j * lda;
+ i__3 = ij;
+ r_cnjg(&q__1, &ap[ijp]);
+ arf[i__3].r = q__1.r, arf[i__3].i = q__1.i;
+ ++ijp;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */
+/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */
+/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */
+
+ ijp = 0;
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ ij = n2 + j;
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ r_cnjg(&q__1, &ap[ijp]);
+ arf[i__3].r = q__1.r, arf[i__3].i = q__1.i;
+ ++ijp;
+ ij += lda;
+ }
+ }
+ js = 0;
+ i__1 = *n - 1;
+ for (j = n1; j <= i__1; ++j) {
+ ij = js;
+ i__2 = js + j;
+ for (ij = js; ij <= i__2; ++ij) {
+ i__3 = ij;
+ i__4 = ijp;
+ arf[i__3].r = ap[i__4].r, arf[i__3].i = ap[i__4].i;
+ ++ijp;
+ }
+ js += lda;
+ }
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is odd */
+/* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */
+/* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 */
+
+ ijp = 0;
+ i__1 = n2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = *n * lda - 1;
+ i__3 = lda;
+ for (ij = i__ * (lda + 1); i__3 < 0 ? ij >= i__2 : ij <=
+ i__2; ij += i__3) {
+ i__4 = ij;
+ r_cnjg(&q__1, &ap[ijp]);
+ arf[i__4].r = q__1.r, arf[i__4].i = q__1.i;
+ ++ijp;
+ }
+ }
+ js = 1;
+ i__1 = n2 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + n2 - j - 1;
+ for (ij = js; ij <= i__3; ++ij) {
+ i__2 = ij;
+ i__4 = ijp;
+ arf[i__2].r = ap[i__4].r, arf[i__2].i = ap[i__4].i;
+ ++ijp;
+ }
+ js = js + lda + 1;
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is odd */
+/* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */
+/* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 */
+
+ ijp = 0;
+ js = n2 * lda;
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + j;
+ for (ij = js; ij <= i__3; ++ij) {
+ i__2 = ij;
+ i__4 = ijp;
+ arf[i__2].r = ap[i__4].r, arf[i__2].i = ap[i__4].i;
+ ++ijp;
+ }
+ js += lda;
+ }
+ i__1 = n1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__3 = i__ + (n1 + i__) * lda;
+ i__2 = lda;
+ for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij +=
+ i__2) {
+ i__4 = ij;
+ r_cnjg(&q__1, &ap[ijp]);
+ arf[i__4].r = q__1.r, arf[i__4].i = q__1.i;
+ ++ijp;
+ }
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
+/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */
+
+ ijp = 0;
+ jp = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ij = i__ + 1 + jp;
+ i__3 = ij;
+ i__4 = ijp;
+ arf[i__3].r = ap[i__4].r, arf[i__3].i = ap[i__4].i;
+ ++ijp;
+ }
+ jp += lda;
+ }
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = k - 1;
+ for (j = i__; j <= i__2; ++j) {
+ ij = i__ + j * lda;
+ i__3 = ij;
+ r_cnjg(&q__1, &ap[ijp]);
+ arf[i__3].r = q__1.r, arf[i__3].i = q__1.i;
+ ++ijp;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
+/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */
+
+ ijp = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ ij = k + 1 + j;
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ r_cnjg(&q__1, &ap[ijp]);
+ arf[i__3].r = q__1.r, arf[i__3].i = q__1.i;
+ ++ijp;
+ ij += lda;
+ }
+ }
+ js = 0;
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+ ij = js;
+ i__2 = js + j;
+ for (ij = js; ij <= i__2; ++ij) {
+ i__3 = ij;
+ i__4 = ijp;
+ arf[i__3].r = ap[i__4].r, arf[i__3].i = ap[i__4].i;
+ ++ijp;
+ }
+ js += lda;
+ }
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */
+/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */
+
+ ijp = 0;
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = (*n + 1) * lda - 1;
+ i__3 = lda;
+ for (ij = i__ + (i__ + 1) * lda; i__3 < 0 ? ij >= i__2 :
+ ij <= i__2; ij += i__3) {
+ i__4 = ij;
+ r_cnjg(&q__1, &ap[ijp]);
+ arf[i__4].r = q__1.r, arf[i__4].i = q__1.i;
+ ++ijp;
+ }
+ }
+ js = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + k - j - 1;
+ for (ij = js; ij <= i__3; ++ij) {
+ i__2 = ij;
+ i__4 = ijp;
+ arf[i__2].r = ap[i__4].r, arf[i__2].i = ap[i__4].i;
+ ++ijp;
+ }
+ js = js + lda + 1;
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */
+/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */
+
+ ijp = 0;
+ js = (k + 1) * lda;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + j;
+ for (ij = js; ij <= i__3; ++ij) {
+ i__2 = ij;
+ i__4 = ijp;
+ arf[i__2].r = ap[i__4].r, arf[i__2].i = ap[i__4].i;
+ ++ijp;
+ }
+ js += lda;
+ }
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__3 = i__ + (k + i__) * lda;
+ i__2 = lda;
+ for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij +=
+ i__2) {
+ i__4 = ij;
+ r_cnjg(&q__1, &ap[ijp]);
+ arf[i__4].r = q__1.r, arf[i__4].i = q__1.i;
+ ++ijp;
+ }
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of CTPTTF */
+
+} /* ctpttf_ */
diff --git a/SRC/ctpttr.c b/SRC/ctpttr.c
new file mode 100644
index 0000000..552c88e
--- /dev/null
+++ b/SRC/ctpttr.c
@@ -0,0 +1,148 @@
+/* ctpttr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ctpttr_(char *uplo, integer *n, complex *ap, complex *a,
+ integer *lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, k;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTPTTR copies a triangular matrix A from standard packed format (TP) */
+/* to standard full format (TR). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular. */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) COMPLEX array, dimension ( N*(N+1)/2 ), */
+/* On entry, the upper or lower triangular matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* A (output) COMPLEX array, dimension ( LDA, N ) */
+/* On exit, the triangular matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ lower = lsame_(uplo, "L");
+ if (! lower && ! lsame_(uplo, "U")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTPTTR", &i__1);
+ return 0;
+ }
+
+ if (lower) {
+ k = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ++k;
+ i__3 = i__ + j * a_dim1;
+ i__4 = k;
+ a[i__3].r = ap[i__4].r, a[i__3].i = ap[i__4].i;
+ }
+ }
+ } else {
+ k = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ++k;
+ i__3 = i__ + j * a_dim1;
+ i__4 = k;
+ a[i__3].r = ap[i__4].r, a[i__3].i = ap[i__4].i;
+ }
+ }
+ }
+
+
+ return 0;
+
+/* End of CTPTTR */
+
+} /* ctpttr_ */
diff --git a/SRC/ctrcon.c b/SRC/ctrcon.c
new file mode 100644
index 0000000..05831a7
--- /dev/null
+++ b/SRC/ctrcon.c
@@ -0,0 +1,249 @@
+/* ctrcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ctrcon_(char *norm, char *uplo, char *diag, integer *n,
+ complex *a, integer *lda, real *rcond, complex *work, real *rwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer ix, kase, kase1;
+ real scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ real anorm;
+ logical upper;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *);
+ real xnorm;
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal clantr_(char *, char *, char *, integer *, integer *,
+ complex *, integer *, real *);
+ real ainvnm;
+ extern /* Subroutine */ int clatrs_(char *, char *, char *, char *,
+ integer *, complex *, integer *, complex *, real *, real *,
+ integer *), csrscl_(integer *,
+ real *, complex *, integer *);
+ logical onenrm;
+ char normin[1];
+ real smlnum;
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTRCON estimates the reciprocal of the condition number of a */
+/* triangular matrix A, in either the 1-norm or the infinity-norm. */
+
+/* The norm of A is computed and an estimate is obtained for */
+/* norm(inv(A)), then the reciprocal of the condition number is */
+/* computed as */
+/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ nounit = lsame_(diag, "N");
+
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTRCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ }
+
+ *rcond = 0.f;
+ smlnum = slamch_("Safe minimum") * (real) max(1,*n);
+
+/* Compute the norm of the triangular matrix A. */
+
+ anorm = clantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &rwork[1]);
+
+/* Continue only if ANORM > 0. */
+
+ if (anorm > 0.f) {
+
+/* Estimate the norm of the inverse of A. */
+
+ ainvnm = 0.f;
+ *(unsigned char *)normin = 'N';
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kase = 0;
+L10:
+ clacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(A). */
+
+ clatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset],
+ lda, &work[1], &scale, &rwork[1], info);
+ } else {
+
+/* Multiply by inv(A'). */
+
+ clatrs_(uplo, "Conjugate transpose", diag, normin, n, &a[
+ a_offset], lda, &work[1], &scale, &rwork[1], info);
+ }
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ if (scale != 1.f) {
+ ix = icamax_(n, &work[1], &c__1);
+ i__1 = ix;
+ xnorm = (r__1 = work[i__1].r, dabs(r__1)) + (r__2 = r_imag(&
+ work[ix]), dabs(r__2));
+ if (scale < xnorm * smlnum || scale == 0.f) {
+ goto L20;
+ }
+ csrscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / anorm / ainvnm;
+ }
+ }
+
+L20:
+ return 0;
+
+/* End of CTRCON */
+
+} /* ctrcon_ */
diff --git a/SRC/ctrevc.c b/SRC/ctrevc.c
new file mode 100644
index 0000000..05c60f4
--- /dev/null
+++ b/SRC/ctrevc.c
@@ -0,0 +1,532 @@
+/* ctrevc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int ctrevc_(char *side, char *howmny, logical *select,
+ integer *n, complex *t, integer *ldt, complex *vl, integer *ldvl,
+ complex *vr, integer *ldvr, integer *mm, integer *m, complex *work,
+ real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
+ i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k, ii, ki, is;
+ real ulp;
+ logical allv;
+ real unfl, ovfl, smin;
+ logical over;
+ real scale;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *);
+ real remax;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ logical leftv, bothv, somev;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), xerbla_(char *, integer *), clatrs_(char *, char *,
+ char *, char *, integer *, complex *, integer *, complex *, real *
+, real *, integer *);
+ extern doublereal scasum_(integer *, complex *, integer *);
+ logical rightv;
+ real smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTREVC computes some or all of the right and/or left eigenvectors of */
+/* a complex upper triangular matrix T. */
+/* Matrices of this type are produced by the Schur factorization of */
+/* a complex general matrix: A = Q*T*Q**H, as computed by CHSEQR. */
+
+/* The right eigenvector x and the left eigenvector y of T corresponding */
+/* to an eigenvalue w are defined by: */
+
+/* T*x = w*x, (y**H)*T = w*(y**H) */
+
+/* where y**H denotes the conjugate transpose of the vector y. */
+/* The eigenvalues are not input to this routine, but are read directly */
+/* from the diagonal of T. */
+
+/* This routine returns the matrices X and/or Y of right and left */
+/* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an */
+/* input matrix. If Q is the unitary factor that reduces a matrix A to */
+/* Schur form T, then Q*X and Q*Y are the matrices of right and left */
+/* eigenvectors of A. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'R': compute right eigenvectors only; */
+/* = 'L': compute left eigenvectors only; */
+/* = 'B': compute both right and left eigenvectors. */
+
+/* HOWMNY (input) CHARACTER*1 */
+/* = 'A': compute all right and/or left eigenvectors; */
+/* = 'B': compute all right and/or left eigenvectors, */
+/* backtransformed using the matrices supplied in */
+/* VR and/or VL; */
+/* = 'S': compute selected right and/or left eigenvectors, */
+/* as indicated by the logical array SELECT. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* If HOWMNY = 'S', SELECT specifies the eigenvectors to be */
+/* computed. */
+/* The eigenvector corresponding to the j-th eigenvalue is */
+/* computed if SELECT(j) = .TRUE.. */
+/* Not referenced if HOWMNY = 'A' or 'B'. */
+
+/* N (input) INTEGER */
+/* The order of the matrix T. N >= 0. */
+
+/* T (input/output) COMPLEX array, dimension (LDT,N) */
+/* The upper triangular matrix T. T is modified, but restored */
+/* on exit. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= max(1,N). */
+
+/* VL (input/output) COMPLEX array, dimension (LDVL,MM) */
+/* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */
+/* contain an N-by-N matrix Q (usually the unitary matrix Q of */
+/* Schur vectors returned by CHSEQR). */
+/* On exit, if SIDE = 'L' or 'B', VL contains: */
+/* if HOWMNY = 'A', the matrix Y of left eigenvectors of T; */
+/* if HOWMNY = 'B', the matrix Q*Y; */
+/* if HOWMNY = 'S', the left eigenvectors of T specified by */
+/* SELECT, stored consecutively in the columns */
+/* of VL, in the same order as their */
+/* eigenvalues. */
+/* Not referenced if SIDE = 'R'. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. LDVL >= 1, and if */
+/* SIDE = 'L' or 'B', LDVL >= N. */
+
+/* VR (input/output) COMPLEX array, dimension (LDVR,MM) */
+/* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */
+/* contain an N-by-N matrix Q (usually the unitary matrix Q of */
+/* Schur vectors returned by CHSEQR). */
+/* On exit, if SIDE = 'R' or 'B', VR contains: */
+/* if HOWMNY = 'A', the matrix X of right eigenvectors of T; */
+/* if HOWMNY = 'B', the matrix Q*X; */
+/* if HOWMNY = 'S', the right eigenvectors of T specified by */
+/* SELECT, stored consecutively in the columns */
+/* of VR, in the same order as their */
+/* eigenvalues. */
+/* Not referenced if SIDE = 'L'. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. LDVR >= 1, and if */
+/* SIDE = 'R' or 'B'; LDVR >= N. */
+
+/* MM (input) INTEGER */
+/* The number of columns in the arrays VL and/or VR. MM >= M. */
+
+/* M (output) INTEGER */
+/* The number of columns in the arrays VL and/or VR actually */
+/* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M */
+/* is set to N. Each selected eigenvector occupies one */
+/* column. */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The algorithm used in this program is basically backward (forward) */
+/* substitution, with scaling to make the the code robust against */
+/* possible overflow. */
+
+/* Each eigenvector is normalized so that the element of largest */
+/* magnitude has magnitude 1; here the magnitude of a complex number */
+/* (x,y) is taken to be |x| + |y|. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ --select;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ bothv = lsame_(side, "B");
+ rightv = lsame_(side, "R") || bothv;
+ leftv = lsame_(side, "L") || bothv;
+
+ allv = lsame_(howmny, "A");
+ over = lsame_(howmny, "B");
+ somev = lsame_(howmny, "S");
+
+/* Set M to the number of columns required to store the selected */
+/* eigenvectors. */
+
+ if (somev) {
+ *m = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (select[j]) {
+ ++(*m);
+ }
+/* L10: */
+ }
+ } else {
+ *m = *n;
+ }
+
+ *info = 0;
+ if (! rightv && ! leftv) {
+ *info = -1;
+ } else if (! allv && ! over && ! somev) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldt < max(1,*n)) {
+ *info = -6;
+ } else if (*ldvl < 1 || leftv && *ldvl < *n) {
+ *info = -8;
+ } else if (*ldvr < 1 || rightv && *ldvr < *n) {
+ *info = -10;
+ } else if (*mm < *m) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTREVC", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Set the constants to control overflow. */
+
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ slabad_(&unfl, &ovfl);
+ ulp = slamch_("Precision");
+ smlnum = unfl * (*n / ulp);
+
+/* Store the diagonal elements of T in working array WORK. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + *n;
+ i__3 = i__ + i__ * t_dim1;
+ work[i__2].r = t[i__3].r, work[i__2].i = t[i__3].i;
+/* L20: */
+ }
+
+/* Compute 1-norm of each column of strictly upper triangular */
+/* part of T to control overflow in triangular solver. */
+
+ rwork[1] = 0.f;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ rwork[j] = scasum_(&i__2, &t[j * t_dim1 + 1], &c__1);
+/* L30: */
+ }
+
+ if (rightv) {
+
+/* Compute right eigenvectors. */
+
+ is = *m;
+ for (ki = *n; ki >= 1; --ki) {
+
+ if (somev) {
+ if (! select[ki]) {
+ goto L80;
+ }
+ }
+/* Computing MAX */
+ i__1 = ki + ki * t_dim1;
+ r__3 = ulp * ((r__1 = t[i__1].r, dabs(r__1)) + (r__2 = r_imag(&t[
+ ki + ki * t_dim1]), dabs(r__2)));
+ smin = dmax(r__3,smlnum);
+
+ work[1].r = 1.f, work[1].i = 0.f;
+
+/* Form right-hand side. */
+
+ i__1 = ki - 1;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = k;
+ i__3 = k + ki * t_dim1;
+ q__1.r = -t[i__3].r, q__1.i = -t[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L40: */
+ }
+
+/* Solve the triangular system: */
+/* (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK. */
+
+ i__1 = ki - 1;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = k + k * t_dim1;
+ i__3 = k + k * t_dim1;
+ i__4 = ki + ki * t_dim1;
+ q__1.r = t[i__3].r - t[i__4].r, q__1.i = t[i__3].i - t[i__4]
+ .i;
+ t[i__2].r = q__1.r, t[i__2].i = q__1.i;
+ i__2 = k + k * t_dim1;
+ if ((r__1 = t[i__2].r, dabs(r__1)) + (r__2 = r_imag(&t[k + k *
+ t_dim1]), dabs(r__2)) < smin) {
+ i__3 = k + k * t_dim1;
+ t[i__3].r = smin, t[i__3].i = 0.f;
+ }
+/* L50: */
+ }
+
+ if (ki > 1) {
+ i__1 = ki - 1;
+ clatrs_("Upper", "No transpose", "Non-unit", "Y", &i__1, &t[
+ t_offset], ldt, &work[1], &scale, &rwork[1], info);
+ i__1 = ki;
+ work[i__1].r = scale, work[i__1].i = 0.f;
+ }
+
+/* Copy the vector x or Q*x to VR and normalize. */
+
+ if (! over) {
+ ccopy_(&ki, &work[1], &c__1, &vr[is * vr_dim1 + 1], &c__1);
+
+ ii = icamax_(&ki, &vr[is * vr_dim1 + 1], &c__1);
+ i__1 = ii + is * vr_dim1;
+ remax = 1.f / ((r__1 = vr[i__1].r, dabs(r__1)) + (r__2 =
+ r_imag(&vr[ii + is * vr_dim1]), dabs(r__2)));
+ csscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1);
+
+ i__1 = *n;
+ for (k = ki + 1; k <= i__1; ++k) {
+ i__2 = k + is * vr_dim1;
+ vr[i__2].r = 0.f, vr[i__2].i = 0.f;
+/* L60: */
+ }
+ } else {
+ if (ki > 1) {
+ i__1 = ki - 1;
+ q__1.r = scale, q__1.i = 0.f;
+ cgemv_("N", n, &i__1, &c_b2, &vr[vr_offset], ldvr, &work[
+ 1], &c__1, &q__1, &vr[ki * vr_dim1 + 1], &c__1);
+ }
+
+ ii = icamax_(n, &vr[ki * vr_dim1 + 1], &c__1);
+ i__1 = ii + ki * vr_dim1;
+ remax = 1.f / ((r__1 = vr[i__1].r, dabs(r__1)) + (r__2 =
+ r_imag(&vr[ii + ki * vr_dim1]), dabs(r__2)));
+ csscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1);
+ }
+
+/* Set back the original diagonal elements of T. */
+
+ i__1 = ki - 1;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = k + k * t_dim1;
+ i__3 = k + *n;
+ t[i__2].r = work[i__3].r, t[i__2].i = work[i__3].i;
+/* L70: */
+ }
+
+ --is;
+L80:
+ ;
+ }
+ }
+
+ if (leftv) {
+
+/* Compute left eigenvectors. */
+
+ is = 1;
+ i__1 = *n;
+ for (ki = 1; ki <= i__1; ++ki) {
+
+ if (somev) {
+ if (! select[ki]) {
+ goto L130;
+ }
+ }
+/* Computing MAX */
+ i__2 = ki + ki * t_dim1;
+ r__3 = ulp * ((r__1 = t[i__2].r, dabs(r__1)) + (r__2 = r_imag(&t[
+ ki + ki * t_dim1]), dabs(r__2)));
+ smin = dmax(r__3,smlnum);
+
+ i__2 = *n;
+ work[i__2].r = 1.f, work[i__2].i = 0.f;
+
+/* Form right-hand side. */
+
+ i__2 = *n;
+ for (k = ki + 1; k <= i__2; ++k) {
+ i__3 = k;
+ r_cnjg(&q__2, &t[ki + k * t_dim1]);
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L90: */
+ }
+
+/* Solve the triangular system: */
+/* (T(KI+1:N,KI+1:N) - T(KI,KI))'*X = SCALE*WORK. */
+
+ i__2 = *n;
+ for (k = ki + 1; k <= i__2; ++k) {
+ i__3 = k + k * t_dim1;
+ i__4 = k + k * t_dim1;
+ i__5 = ki + ki * t_dim1;
+ q__1.r = t[i__4].r - t[i__5].r, q__1.i = t[i__4].i - t[i__5]
+ .i;
+ t[i__3].r = q__1.r, t[i__3].i = q__1.i;
+ i__3 = k + k * t_dim1;
+ if ((r__1 = t[i__3].r, dabs(r__1)) + (r__2 = r_imag(&t[k + k *
+ t_dim1]), dabs(r__2)) < smin) {
+ i__4 = k + k * t_dim1;
+ t[i__4].r = smin, t[i__4].i = 0.f;
+ }
+/* L100: */
+ }
+
+ if (ki < *n) {
+ i__2 = *n - ki;
+ clatrs_("Upper", "Conjugate transpose", "Non-unit", "Y", &
+ i__2, &t[ki + 1 + (ki + 1) * t_dim1], ldt, &work[ki +
+ 1], &scale, &rwork[1], info);
+ i__2 = ki;
+ work[i__2].r = scale, work[i__2].i = 0.f;
+ }
+
+/* Copy the vector x or Q*x to VL and normalize. */
+
+ if (! over) {
+ i__2 = *n - ki + 1;
+ ccopy_(&i__2, &work[ki], &c__1, &vl[ki + is * vl_dim1], &c__1)
+ ;
+
+ i__2 = *n - ki + 1;
+ ii = icamax_(&i__2, &vl[ki + is * vl_dim1], &c__1) + ki - 1;
+ i__2 = ii + is * vl_dim1;
+ remax = 1.f / ((r__1 = vl[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&vl[ii + is * vl_dim1]), dabs(r__2)));
+ i__2 = *n - ki + 1;
+ csscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1);
+
+ i__2 = ki - 1;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + is * vl_dim1;
+ vl[i__3].r = 0.f, vl[i__3].i = 0.f;
+/* L110: */
+ }
+ } else {
+ if (ki < *n) {
+ i__2 = *n - ki;
+ q__1.r = scale, q__1.i = 0.f;
+ cgemv_("N", n, &i__2, &c_b2, &vl[(ki + 1) * vl_dim1 + 1],
+ ldvl, &work[ki + 1], &c__1, &q__1, &vl[ki *
+ vl_dim1 + 1], &c__1);
+ }
+
+ ii = icamax_(n, &vl[ki * vl_dim1 + 1], &c__1);
+ i__2 = ii + ki * vl_dim1;
+ remax = 1.f / ((r__1 = vl[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&vl[ii + ki * vl_dim1]), dabs(r__2)));
+ csscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1);
+ }
+
+/* Set back the original diagonal elements of T. */
+
+ i__2 = *n;
+ for (k = ki + 1; k <= i__2; ++k) {
+ i__3 = k + k * t_dim1;
+ i__4 = k + *n;
+ t[i__3].r = work[i__4].r, t[i__3].i = work[i__4].i;
+/* L120: */
+ }
+
+ ++is;
+L130:
+ ;
+ }
+ }
+
+ return 0;
+
+/* End of CTREVC */
+
+} /* ctrevc_ */
diff --git a/SRC/ctrexc.c b/SRC/ctrexc.c
new file mode 100644
index 0000000..7f292e4
--- /dev/null
+++ b/SRC/ctrexc.c
@@ -0,0 +1,215 @@
+/* ctrexc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ctrexc_(char *compq, integer *n, complex *t, integer *
+ ldt, complex *q, integer *ldq, integer *ifst, integer *ilst, integer *
+ info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, t_dim1, t_offset, i__1, i__2, i__3;
+ complex q__1;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer k, m1, m2, m3;
+ real cs;
+ complex t11, t22, sn, temp;
+ extern /* Subroutine */ int crot_(integer *, complex *, integer *,
+ complex *, integer *, real *, complex *);
+ extern logical lsame_(char *, char *);
+ logical wantq;
+ extern /* Subroutine */ int clartg_(complex *, complex *, real *, complex
+ *, complex *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTREXC reorders the Schur factorization of a complex matrix */
+/* A = Q*T*Q**H, so that the diagonal element of T with row index IFST */
+/* is moved to row ILST. */
+
+/* The Schur form T is reordered by a unitary similarity transformation */
+/* Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by */
+/* postmultplying it with Z. */
+
+/* Arguments */
+/* ========= */
+
+/* COMPQ (input) CHARACTER*1 */
+/* = 'V': update the matrix Q of Schur vectors; */
+/* = 'N': do not update Q. */
+
+/* N (input) INTEGER */
+/* The order of the matrix T. N >= 0. */
+
+/* T (input/output) COMPLEX array, dimension (LDT,N) */
+/* On entry, the upper triangular matrix T. */
+/* On exit, the reordered upper triangular matrix. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= max(1,N). */
+
+/* Q (input/output) COMPLEX array, dimension (LDQ,N) */
+/* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */
+/* On exit, if COMPQ = 'V', Q has been postmultiplied by the */
+/* unitary transformation matrix Z which reorders T. */
+/* If COMPQ = 'N', Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* IFST (input) INTEGER */
+/* ILST (input) INTEGER */
+/* Specify the reordering of the diagonal elements of T: */
+/* The element with row index IFST is moved to row ILST by a */
+/* sequence of transpositions between adjacent elements. */
+/* 1 <= IFST <= N; 1 <= ILST <= N. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters. */
+
+ /* Parameter adjustments */
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+
+ /* Function Body */
+ *info = 0;
+ wantq = lsame_(compq, "V");
+ if (! lsame_(compq, "N") && ! wantq) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldt < max(1,*n)) {
+ *info = -4;
+ } else if (*ldq < 1 || wantq && *ldq < max(1,*n)) {
+ *info = -6;
+ } else if (*ifst < 1 || *ifst > *n) {
+ *info = -7;
+ } else if (*ilst < 1 || *ilst > *n) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTREXC", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 1 || *ifst == *ilst) {
+ return 0;
+ }
+
+ if (*ifst < *ilst) {
+
+/* Move the IFST-th diagonal element forward down the diagonal. */
+
+ m1 = 0;
+ m2 = -1;
+ m3 = 1;
+ } else {
+
+/* Move the IFST-th diagonal element backward up the diagonal. */
+
+ m1 = -1;
+ m2 = 0;
+ m3 = -1;
+ }
+
+ i__1 = *ilst + m2;
+ i__2 = m3;
+ for (k = *ifst + m1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+
+/* Interchange the k-th and (k+1)-th diagonal elements. */
+
+ i__3 = k + k * t_dim1;
+ t11.r = t[i__3].r, t11.i = t[i__3].i;
+ i__3 = k + 1 + (k + 1) * t_dim1;
+ t22.r = t[i__3].r, t22.i = t[i__3].i;
+
+/* Determine the transformation to perform the interchange. */
+
+ q__1.r = t22.r - t11.r, q__1.i = t22.i - t11.i;
+ clartg_(&t[k + (k + 1) * t_dim1], &q__1, &cs, &sn, &temp);
+
+/* Apply transformation to the matrix T. */
+
+ if (k + 2 <= *n) {
+ i__3 = *n - k - 1;
+ crot_(&i__3, &t[k + (k + 2) * t_dim1], ldt, &t[k + 1 + (k + 2) *
+ t_dim1], ldt, &cs, &sn);
+ }
+ i__3 = k - 1;
+ r_cnjg(&q__1, &sn);
+ crot_(&i__3, &t[k * t_dim1 + 1], &c__1, &t[(k + 1) * t_dim1 + 1], &
+ c__1, &cs, &q__1);
+
+ i__3 = k + k * t_dim1;
+ t[i__3].r = t22.r, t[i__3].i = t22.i;
+ i__3 = k + 1 + (k + 1) * t_dim1;
+ t[i__3].r = t11.r, t[i__3].i = t11.i;
+
+ if (wantq) {
+
+/* Accumulate transformation in the matrix Q. */
+
+ r_cnjg(&q__1, &sn);
+ crot_(n, &q[k * q_dim1 + 1], &c__1, &q[(k + 1) * q_dim1 + 1], &
+ c__1, &cs, &q__1);
+ }
+
+/* L10: */
+ }
+
+ return 0;
+
+/* End of CTREXC */
+
+} /* ctrexc_ */
diff --git a/SRC/ctrrfs.c b/SRC/ctrrfs.c
new file mode 100644
index 0000000..c7748a6
--- /dev/null
+++ b/SRC/ctrrfs.c
@@ -0,0 +1,562 @@
+/* ctrrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ctrrfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, complex *a, integer *lda, complex *b, integer *ldb,
+ complex *x, integer *ldx, real *ferr, real *berr, complex *work, real
+ *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2,
+ i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ real s, xk;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
+ complex *, integer *, complex *, integer *), ctrsv_(char *, char *, char *, integer *, complex *,
+ integer *, complex *, integer *), clacn2_(
+ integer *, complex *, complex *, real *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+ char transn[1], transt[1];
+ logical nounit;
+ real lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTRRFS provides error bounds and backward error estimates for the */
+/* solution to a system of linear equations with a triangular */
+/* coefficient matrix. */
+
+/* The solution matrix X must be computed by CTRTRS or some other */
+/* means before entering this routine. CTRRFS does not do iterative */
+/* refinement because doing so cannot improve the backward error. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTRRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transn = 'N';
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transn = 'C';
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A, A**T, or A**H, depending on TRANS. */
+
+ ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ctrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
+ q__1.r = -1.f, q__1.i = -0.f;
+ caxpy_(n, &q__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[
+ i__ + j * b_dim1]), dabs(r__2));
+/* L20: */
+ }
+
+ if (notran) {
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ x[k + j * x_dim1]), dabs(r__2));
+ i__3 = k;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (
+ r__2 = r_imag(&a[i__ + k * a_dim1]), dabs(
+ r__2))) * xk;
+/* L30: */
+ }
+/* L40: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ x[k + j * x_dim1]), dabs(r__2));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (
+ r__2 = r_imag(&a[i__ + k * a_dim1]), dabs(
+ r__2))) * xk;
+/* L50: */
+ }
+ rwork[k] += xk;
+/* L60: */
+ }
+ }
+ } else {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ x[k + j * x_dim1]), dabs(r__2));
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (
+ r__2 = r_imag(&a[i__ + k * a_dim1]), dabs(
+ r__2))) * xk;
+/* L70: */
+ }
+/* L80: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ x[k + j * x_dim1]), dabs(r__2));
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (
+ r__2 = r_imag(&a[i__ + k * a_dim1]), dabs(
+ r__2))) * xk;
+/* L90: */
+ }
+ rwork[k] += xk;
+/* L100: */
+ }
+ }
+ }
+ } else {
+
+/* Compute abs(A**H)*abs(X) + abs(B). */
+
+ if (upper) {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__3 = k;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + k * a_dim1]), dabs(r__2)))
+ * ((r__3 = x[i__5].r, dabs(r__3)) + (
+ r__4 = r_imag(&x[i__ + j * x_dim1]), dabs(
+ r__4)));
+/* L110: */
+ }
+ rwork[k] += s;
+/* L120: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ s = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ x[k + j * x_dim1]), dabs(r__2));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + k * a_dim1]), dabs(r__2)))
+ * ((r__3 = x[i__5].r, dabs(r__3)) + (
+ r__4 = r_imag(&x[i__ + j * x_dim1]), dabs(
+ r__4)));
+/* L130: */
+ }
+ rwork[k] += s;
+/* L140: */
+ }
+ }
+ } else {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + k * a_dim1]), dabs(r__2)))
+ * ((r__3 = x[i__5].r, dabs(r__3)) + (
+ r__4 = r_imag(&x[i__ + j * x_dim1]), dabs(
+ r__4)));
+/* L150: */
+ }
+ rwork[k] += s;
+/* L160: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ s = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ x[k + j * x_dim1]), dabs(r__2));
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + k * a_dim1]), dabs(r__2)))
+ * ((r__3 = x[i__5].r, dabs(r__3)) + (
+ r__4 = r_imag(&x[i__ + j * x_dim1]), dabs(
+ r__4)));
+/* L170: */
+ }
+ rwork[k] += s;
+/* L180: */
+ }
+ }
+ }
+ }
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__3 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
+ s = dmax(r__3,r__4);
+ } else {
+/* Computing MAX */
+ i__3 = i__;
+ r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = dmax(r__3,r__4);
+ }
+/* L190: */
+ }
+ berr[j] = s;
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use CLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__3 = i__;
+ rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__];
+ } else {
+ i__3 = i__;
+ rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
+ i__] + safe1;
+ }
+/* L200: */
+ }
+
+ kase = 0;
+L210:
+ clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)**H). */
+
+ ctrsv_(uplo, transt, diag, n, &a[a_offset], lda, &work[1], &
+ c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L220: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L230: */
+ }
+ ctrsv_(uplo, transn, diag, n, &a[a_offset], lda, &work[1], &
+ c__1);
+ }
+ goto L210;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * x_dim1;
+ r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + j * x_dim1]), dabs(r__2));
+ lstres = dmax(r__3,r__4);
+/* L240: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L250: */
+ }
+
+ return 0;
+
+/* End of CTRRFS */
+
+} /* ctrrfs_ */
diff --git a/SRC/ctrsen.c b/SRC/ctrsen.c
new file mode 100644
index 0000000..7e45587
--- /dev/null
+++ b/SRC/ctrsen.c
@@ -0,0 +1,422 @@
+/* ctrsen.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+
+/* Subroutine */ int ctrsen_(char *job, char *compq, logical *select, integer
+ *n, complex *t, integer *ldt, complex *q, integer *ldq, complex *w,
+ integer *m, real *s, real *sep, complex *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, t_dim1, t_offset, i__1, i__2, i__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer k, n1, n2, nn, ks;
+ real est;
+ integer kase, ierr;
+ real scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3], lwmin;
+ logical wantq, wants;
+ real rnorm;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *);
+ real rwork[1];
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), xerbla_(char *,
+ integer *);
+ logical wantbh;
+ extern /* Subroutine */ int ctrexc_(char *, integer *, complex *, integer
+ *, complex *, integer *, integer *, integer *, integer *);
+ logical wantsp;
+ extern /* Subroutine */ int ctrsyl_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, real *, integer *);
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTRSEN reorders the Schur factorization of a complex matrix */
+/* A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in */
+/* the leading positions on the diagonal of the upper triangular matrix */
+/* T, and the leading columns of Q form an orthonormal basis of the */
+/* corresponding right invariant subspace. */
+
+/* Optionally the routine computes the reciprocal condition numbers of */
+/* the cluster of eigenvalues and/or the invariant subspace. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies whether condition numbers are required for the */
+/* cluster of eigenvalues (S) or the invariant subspace (SEP): */
+/* = 'N': none; */
+/* = 'E': for eigenvalues only (S); */
+/* = 'V': for invariant subspace only (SEP); */
+/* = 'B': for both eigenvalues and invariant subspace (S and */
+/* SEP). */
+
+/* COMPQ (input) CHARACTER*1 */
+/* = 'V': update the matrix Q of Schur vectors; */
+/* = 'N': do not update Q. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* SELECT specifies the eigenvalues in the selected cluster. To */
+/* select the j-th eigenvalue, SELECT(j) must be set to .TRUE.. */
+
+/* N (input) INTEGER */
+/* The order of the matrix T. N >= 0. */
+
+/* T (input/output) COMPLEX array, dimension (LDT,N) */
+/* On entry, the upper triangular matrix T. */
+/* On exit, T is overwritten by the reordered matrix T, with the */
+/* selected eigenvalues as the leading diagonal elements. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= max(1,N). */
+
+/* Q (input/output) COMPLEX array, dimension (LDQ,N) */
+/* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */
+/* On exit, if COMPQ = 'V', Q has been postmultiplied by the */
+/* unitary transformation matrix which reorders T; the leading M */
+/* columns of Q form an orthonormal basis for the specified */
+/* invariant subspace. */
+/* If COMPQ = 'N', Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. */
+/* LDQ >= 1; and if COMPQ = 'V', LDQ >= N. */
+
+/* W (output) COMPLEX array, dimension (N) */
+/* The reordered eigenvalues of T, in the same order as they */
+/* appear on the diagonal of T. */
+
+/* M (output) INTEGER */
+/* The dimension of the specified invariant subspace. */
+/* 0 <= M <= N. */
+
+/* S (output) REAL */
+/* If JOB = 'E' or 'B', S is a lower bound on the reciprocal */
+/* condition number for the selected cluster of eigenvalues. */
+/* S cannot underestimate the true reciprocal condition number */
+/* by more than a factor of sqrt(N). If M = 0 or N, S = 1. */
+/* If JOB = 'N' or 'V', S is not referenced. */
+
+/* SEP (output) REAL */
+/* If JOB = 'V' or 'B', SEP is the estimated reciprocal */
+/* condition number of the specified invariant subspace. If */
+/* M = 0 or N, SEP = norm(T). */
+/* If JOB = 'N' or 'E', SEP is not referenced. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If JOB = 'N', LWORK >= 1; */
+/* if JOB = 'E', LWORK = max(1,M*(N-M)); */
+/* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)). */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* CTRSEN first collects the selected eigenvalues by computing a unitary */
+/* transformation Z to move them to the top left corner of T. In other */
+/* words, the selected eigenvalues are the eigenvalues of T11 in: */
+
+/* Z'*T*Z = ( T11 T12 ) n1 */
+/* ( 0 T22 ) n2 */
+/* n1 n2 */
+
+/* where N = n1+n2 and Z' means the conjugate transpose of Z. The first */
+/* n1 columns of Z span the specified invariant subspace of T. */
+
+/* If T has been obtained from the Schur factorization of a matrix */
+/* A = Q*T*Q', then the reordered Schur factorization of A is given by */
+/* A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span the */
+/* corresponding invariant subspace of A. */
+
+/* The reciprocal condition number of the average of the eigenvalues of */
+/* T11 may be returned in S. S lies between 0 (very badly conditioned) */
+/* and 1 (very well conditioned). It is computed as follows. First we */
+/* compute R so that */
+
+/* P = ( I R ) n1 */
+/* ( 0 0 ) n2 */
+/* n1 n2 */
+
+/* is the projector on the invariant subspace associated with T11. */
+/* R is the solution of the Sylvester equation: */
+
+/* T11*R - R*T22 = T12. */
+
+/* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote */
+/* the two-norm of M. Then S is computed as the lower bound */
+
+/* (1 + F-norm(R)**2)**(-1/2) */
+
+/* on the reciprocal of 2-norm(P), the true reciprocal condition number. */
+/* S cannot underestimate 1 / 2-norm(P) by more than a factor of */
+/* sqrt(N). */
+
+/* An approximate error bound for the computed average of the */
+/* eigenvalues of T11 is */
+
+/* EPS * norm(T) / S */
+
+/* where EPS is the machine precision. */
+
+/* The reciprocal condition number of the right invariant subspace */
+/* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. */
+/* SEP is defined as the separation of T11 and T22: */
+
+/* sep( T11, T22 ) = sigma-min( C ) */
+
+/* where sigma-min(C) is the smallest singular value of the */
+/* n1*n2-by-n1*n2 matrix */
+
+/* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) */
+
+/* I(m) is an m by m identity matrix, and kprod denotes the Kronecker */
+/* product. We estimate sigma-min(C) by the reciprocal of an estimate of */
+/* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) */
+/* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2). */
+
+/* When SEP is small, small changes in T can cause large changes in */
+/* the invariant subspace. An approximate bound on the maximum angular */
+/* error in the computed right invariant subspace is */
+
+/* EPS * norm(T) / SEP */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters. */
+
+ /* Parameter adjustments */
+ --select;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --w;
+ --work;
+
+ /* Function Body */
+ wantbh = lsame_(job, "B");
+ wants = lsame_(job, "E") || wantbh;
+ wantsp = lsame_(job, "V") || wantbh;
+ wantq = lsame_(compq, "V");
+
+/* Set M to the number of selected eigenvalues. */
+
+ *m = 0;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (select[k]) {
+ ++(*m);
+ }
+/* L10: */
+ }
+
+ n1 = *m;
+ n2 = *n - *m;
+ nn = n1 * n2;
+
+ *info = 0;
+ lquery = *lwork == -1;
+
+ if (wantsp) {
+/* Computing MAX */
+ i__1 = 1, i__2 = nn << 1;
+ lwmin = max(i__1,i__2);
+ } else if (lsame_(job, "N")) {
+ lwmin = 1;
+ } else if (lsame_(job, "E")) {
+ lwmin = max(1,nn);
+ }
+
+ if (! lsame_(job, "N") && ! wants && ! wantsp) {
+ *info = -1;
+ } else if (! lsame_(compq, "N") && ! wantq) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldt < max(1,*n)) {
+ *info = -6;
+ } else if (*ldq < 1 || wantq && *ldq < *n) {
+ *info = -8;
+ } else if (*lwork < lwmin && ! lquery) {
+ *info = -14;
+ }
+
+ if (*info == 0) {
+ work[1].r = (real) lwmin, work[1].i = 0.f;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTRSEN", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == *n || *m == 0) {
+ if (wants) {
+ *s = 1.f;
+ }
+ if (wantsp) {
+ *sep = clange_("1", n, n, &t[t_offset], ldt, rwork);
+ }
+ goto L40;
+ }
+
+/* Collect the selected eigenvalues at the top left corner of T. */
+
+ ks = 0;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (select[k]) {
+ ++ks;
+
+/* Swap the K-th eigenvalue to position KS. */
+
+ if (k != ks) {
+ ctrexc_(compq, n, &t[t_offset], ldt, &q[q_offset], ldq, &k, &
+ ks, &ierr);
+ }
+ }
+/* L20: */
+ }
+
+ if (wants) {
+
+/* Solve the Sylvester equation for R: */
+
+/* T11*R - R*T22 = scale*T12 */
+
+ clacpy_("F", &n1, &n2, &t[(n1 + 1) * t_dim1 + 1], ldt, &work[1], &n1);
+ ctrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1
+ + 1) * t_dim1], ldt, &work[1], &n1, &scale, &ierr);
+
+/* Estimate the reciprocal of the condition number of the cluster */
+/* of eigenvalues. */
+
+ rnorm = clange_("F", &n1, &n2, &work[1], &n1, rwork);
+ if (rnorm == 0.f) {
+ *s = 1.f;
+ } else {
+ *s = scale / (sqrt(scale * scale / rnorm + rnorm) * sqrt(rnorm));
+ }
+ }
+
+ if (wantsp) {
+
+/* Estimate sep(T11,T22). */
+
+ est = 0.f;
+ kase = 0;
+L30:
+ clacn2_(&nn, &work[nn + 1], &work[1], &est, &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Solve T11*R - R*T22 = scale*X. */
+
+ ctrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 +
+ 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &
+ ierr);
+ } else {
+
+/* Solve T11'*R - R*T22' = scale*X. */
+
+ ctrsyl_("C", "C", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 +
+ 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &
+ ierr);
+ }
+ goto L30;
+ }
+
+ *sep = scale / est;
+ }
+
+L40:
+
+/* Copy reordered eigenvalues to W. */
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = k;
+ i__3 = k + k * t_dim1;
+ w[i__2].r = t[i__3].r, w[i__2].i = t[i__3].i;
+/* L50: */
+ }
+
+ work[1].r = (real) lwmin, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CTRSEN */
+
+} /* ctrsen_ */
diff --git a/SRC/ctrsna.c b/SRC/ctrsna.c
new file mode 100644
index 0000000..0ca9457
--- /dev/null
+++ b/SRC/ctrsna.c
@@ -0,0 +1,445 @@
+/* ctrsna.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ctrsna_(char *job, char *howmny, logical *select,
+ integer *n, complex *t, integer *ldt, complex *vl, integer *ldvl,
+ complex *vr, integer *ldvr, real *s, real *sep, integer *mm, integer *
+ m, complex *work, integer *ldwork, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset,
+ work_dim1, work_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ double c_abs(complex *), r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k, ks, ix;
+ real eps, est;
+ integer kase, ierr;
+ complex prod;
+ real lnrm, rnrm, scale;
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ complex dummy[1];
+ logical wants;
+ extern /* Subroutine */ int clacn2_(integer *, complex *, complex *, real
+ *, integer *, integer *);
+ real xnorm;
+ extern doublereal scnrm2_(integer *, complex *, integer *);
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), xerbla_(char *,
+ integer *);
+ real bignum;
+ logical wantbh;
+ extern /* Subroutine */ int clatrs_(char *, char *, char *, char *,
+ integer *, complex *, integer *, complex *, real *, real *,
+ integer *), csrscl_(integer *,
+ real *, complex *, integer *), ctrexc_(char *, integer *, complex
+ *, integer *, complex *, integer *, integer *, integer *, integer
+ *);
+ logical somcon;
+ char normin[1];
+ real smlnum;
+ logical wantsp;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTRSNA estimates reciprocal condition numbers for specified */
+/* eigenvalues and/or right eigenvectors of a complex upper triangular */
+/* matrix T (or of any matrix Q*T*Q**H with Q unitary). */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies whether condition numbers are required for */
+/* eigenvalues (S) or eigenvectors (SEP): */
+/* = 'E': for eigenvalues only (S); */
+/* = 'V': for eigenvectors only (SEP); */
+/* = 'B': for both eigenvalues and eigenvectors (S and SEP). */
+
+/* HOWMNY (input) CHARACTER*1 */
+/* = 'A': compute condition numbers for all eigenpairs; */
+/* = 'S': compute condition numbers for selected eigenpairs */
+/* specified by the array SELECT. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* If HOWMNY = 'S', SELECT specifies the eigenpairs for which */
+/* condition numbers are required. To select condition numbers */
+/* for the j-th eigenpair, SELECT(j) must be set to .TRUE.. */
+/* If HOWMNY = 'A', SELECT is not referenced. */
+
+/* N (input) INTEGER */
+/* The order of the matrix T. N >= 0. */
+
+/* T (input) COMPLEX array, dimension (LDT,N) */
+/* The upper triangular matrix T. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= max(1,N). */
+
+/* VL (input) COMPLEX array, dimension (LDVL,M) */
+/* If JOB = 'E' or 'B', VL must contain left eigenvectors of T */
+/* (or of any Q*T*Q**H with Q unitary), corresponding to the */
+/* eigenpairs specified by HOWMNY and SELECT. The eigenvectors */
+/* must be stored in consecutive columns of VL, as returned by */
+/* CHSEIN or CTREVC. */
+/* If JOB = 'V', VL is not referenced. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. */
+/* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N. */
+
+/* VR (input) COMPLEX array, dimension (LDVR,M) */
+/* If JOB = 'E' or 'B', VR must contain right eigenvectors of T */
+/* (or of any Q*T*Q**H with Q unitary), corresponding to the */
+/* eigenpairs specified by HOWMNY and SELECT. The eigenvectors */
+/* must be stored in consecutive columns of VR, as returned by */
+/* CHSEIN or CTREVC. */
+/* If JOB = 'V', VR is not referenced. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. */
+/* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N. */
+
+/* S (output) REAL array, dimension (MM) */
+/* If JOB = 'E' or 'B', the reciprocal condition numbers of the */
+/* selected eigenvalues, stored in consecutive elements of the */
+/* array. Thus S(j), SEP(j), and the j-th columns of VL and VR */
+/* all correspond to the same eigenpair (but not in general the */
+/* j-th eigenpair, unless all eigenpairs are selected). */
+/* If JOB = 'V', S is not referenced. */
+
+/* SEP (output) REAL array, dimension (MM) */
+/* If JOB = 'V' or 'B', the estimated reciprocal condition */
+/* numbers of the selected eigenvectors, stored in consecutive */
+/* elements of the array. */
+/* If JOB = 'E', SEP is not referenced. */
+
+/* MM (input) INTEGER */
+/* The number of elements in the arrays S (if JOB = 'E' or 'B') */
+/* and/or SEP (if JOB = 'V' or 'B'). MM >= M. */
+
+/* M (output) INTEGER */
+/* The number of elements of the arrays S and/or SEP actually */
+/* used to store the estimated condition numbers. */
+/* If HOWMNY = 'A', M is set to N. */
+
+/* WORK (workspace) COMPLEX array, dimension (LDWORK,N+6) */
+/* If JOB = 'E', WORK is not referenced. */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. */
+/* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N. */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+/* If JOB = 'E', RWORK is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The reciprocal of the condition number of an eigenvalue lambda is */
+/* defined as */
+
+/* S(lambda) = |v'*u| / (norm(u)*norm(v)) */
+
+/* where u and v are the right and left eigenvectors of T corresponding */
+/* to lambda; v' denotes the conjugate transpose of v, and norm(u) */
+/* denotes the Euclidean norm. These reciprocal condition numbers always */
+/* lie between zero (very badly conditioned) and one (very well */
+/* conditioned). If n = 1, S(lambda) is defined to be 1. */
+
+/* An approximate error bound for a computed eigenvalue W(i) is given by */
+
+/* EPS * norm(T) / S(i) */
+
+/* where EPS is the machine precision. */
+
+/* The reciprocal of the condition number of the right eigenvector u */
+/* corresponding to lambda is defined as follows. Suppose */
+
+/* T = ( lambda c ) */
+/* ( 0 T22 ) */
+
+/* Then the reciprocal condition number is */
+
+/* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I ) */
+
+/* where sigma-min denotes the smallest singular value. We approximate */
+/* the smallest singular value by the reciprocal of an estimate of the */
+/* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is */
+/* defined to be abs(T(1,1)). */
+
+/* An approximate error bound for a computed right eigenvector VR(i) */
+/* is given by */
+
+/* EPS * norm(T) / SEP(i) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ --select;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --s;
+ --sep;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+
+ /* Function Body */
+ wantbh = lsame_(job, "B");
+ wants = lsame_(job, "E") || wantbh;
+ wantsp = lsame_(job, "V") || wantbh;
+
+ somcon = lsame_(howmny, "S");
+
+/* Set M to the number of eigenpairs for which condition numbers are */
+/* to be computed. */
+
+ if (somcon) {
+ *m = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (select[j]) {
+ ++(*m);
+ }
+/* L10: */
+ }
+ } else {
+ *m = *n;
+ }
+
+ *info = 0;
+ if (! wants && ! wantsp) {
+ *info = -1;
+ } else if (! lsame_(howmny, "A") && ! somcon) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldt < max(1,*n)) {
+ *info = -6;
+ } else if (*ldvl < 1 || wants && *ldvl < *n) {
+ *info = -8;
+ } else if (*ldvr < 1 || wants && *ldvr < *n) {
+ *info = -10;
+ } else if (*mm < *m) {
+ *info = -13;
+ } else if (*ldwork < 1 || wantsp && *ldwork < *n) {
+ *info = -16;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTRSNA", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (somcon) {
+ if (! select[1]) {
+ return 0;
+ }
+ }
+ if (wants) {
+ s[1] = 1.f;
+ }
+ if (wantsp) {
+ sep[1] = c_abs(&t[t_dim1 + 1]);
+ }
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S") / eps;
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+ ks = 1;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+ if (somcon) {
+ if (! select[k]) {
+ goto L50;
+ }
+ }
+
+ if (wants) {
+
+/* Compute the reciprocal condition number of the k-th */
+/* eigenvalue. */
+
+ cdotc_(&q__1, n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks * vl_dim1 +
+ 1], &c__1);
+ prod.r = q__1.r, prod.i = q__1.i;
+ rnrm = scnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
+ lnrm = scnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
+ s[ks] = c_abs(&prod) / (rnrm * lnrm);
+
+ }
+
+ if (wantsp) {
+
+/* Estimate the reciprocal condition number of the k-th */
+/* eigenvector. */
+
+/* Copy the matrix T to the array WORK and swap the k-th */
+/* diagonal element to the (1,1) position. */
+
+ clacpy_("Full", n, n, &t[t_offset], ldt, &work[work_offset],
+ ldwork);
+ ctrexc_("No Q", n, &work[work_offset], ldwork, dummy, &c__1, &k, &
+ c__1, &ierr);
+
+/* Form C = T22 - lambda*I in WORK(2:N,2:N). */
+
+ i__2 = *n;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + i__ * work_dim1;
+ i__4 = i__ + i__ * work_dim1;
+ i__5 = work_dim1 + 1;
+ q__1.r = work[i__4].r - work[i__5].r, q__1.i = work[i__4].i -
+ work[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L20: */
+ }
+
+/* Estimate a lower bound for the 1-norm of inv(C'). The 1st */
+/* and (N+1)th columns of WORK are used to store work vectors. */
+
+ sep[ks] = 0.f;
+ est = 0.f;
+ kase = 0;
+ *(unsigned char *)normin = 'N';
+L30:
+ i__2 = *n - 1;
+ clacn2_(&i__2, &work[(*n + 1) * work_dim1 + 1], &work[work_offset]
+, &est, &kase, isave);
+
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Solve C'*x = scale*b */
+
+ i__2 = *n - 1;
+ clatrs_("Upper", "Conjugate transpose", "Nonunit", normin,
+ &i__2, &work[(work_dim1 << 1) + 2], ldwork, &
+ work[work_offset], &scale, &rwork[1], &ierr);
+ } else {
+
+/* Solve C*x = scale*b */
+
+ i__2 = *n - 1;
+ clatrs_("Upper", "No transpose", "Nonunit", normin, &i__2,
+ &work[(work_dim1 << 1) + 2], ldwork, &work[
+ work_offset], &scale, &rwork[1], &ierr);
+ }
+ *(unsigned char *)normin = 'Y';
+ if (scale != 1.f) {
+
+/* Multiply by 1/SCALE if doing so will not cause */
+/* overflow. */
+
+ i__2 = *n - 1;
+ ix = icamax_(&i__2, &work[work_offset], &c__1);
+ i__2 = ix + work_dim1;
+ xnorm = (r__1 = work[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&work[ix + work_dim1]), dabs(r__2));
+ if (scale < xnorm * smlnum || scale == 0.f) {
+ goto L40;
+ }
+ csrscl_(n, &scale, &work[work_offset], &c__1);
+ }
+ goto L30;
+ }
+
+ sep[ks] = 1.f / dmax(est,smlnum);
+ }
+
+L40:
+ ++ks;
+L50:
+ ;
+ }
+ return 0;
+
+/* End of CTRSNA */
+
+} /* ctrsna_ */
diff --git a/SRC/ctrsyl.c b/SRC/ctrsyl.c
new file mode 100644
index 0000000..1d525ae
--- /dev/null
+++ b/SRC/ctrsyl.c
@@ -0,0 +1,544 @@
+/* ctrsyl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ctrsyl_(char *trana, char *tranb, integer *isgn, integer
+ *m, integer *n, complex *a, integer *lda, complex *b, integer *ldb,
+ complex *c__, integer *ldc, real *scale, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4;
+ real r__1, r__2;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer j, k, l;
+ complex a11;
+ real db;
+ complex x11;
+ real da11;
+ complex vec;
+ real dum[1], eps, sgn, smin;
+ complex suml, sumr;
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
+ real scaloc;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), xerbla_(char *, integer *);
+ real bignum;
+ logical notrna, notrnb;
+ real smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTRSYL solves the complex Sylvester matrix equation: */
+
+/* op(A)*X + X*op(B) = scale*C or */
+/* op(A)*X - X*op(B) = scale*C, */
+
+/* where op(A) = A or A**H, and A and B are both upper triangular. A is */
+/* M-by-M and B is N-by-N; the right hand side C and the solution X are */
+/* M-by-N; and scale is an output scale factor, set <= 1 to avoid */
+/* overflow in X. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANA (input) CHARACTER*1 */
+/* Specifies the option op(A): */
+/* = 'N': op(A) = A (No transpose) */
+/* = 'C': op(A) = A**H (Conjugate transpose) */
+
+/* TRANB (input) CHARACTER*1 */
+/* Specifies the option op(B): */
+/* = 'N': op(B) = B (No transpose) */
+/* = 'C': op(B) = B**H (Conjugate transpose) */
+
+/* ISGN (input) INTEGER */
+/* Specifies the sign in the equation: */
+/* = +1: solve op(A)*X + X*op(B) = scale*C */
+/* = -1: solve op(A)*X - X*op(B) = scale*C */
+
+/* M (input) INTEGER */
+/* The order of the matrix A, and the number of rows in the */
+/* matrices X and C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The order of the matrix B, and the number of columns in the */
+/* matrices X and C. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,M) */
+/* The upper triangular matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input) COMPLEX array, dimension (LDB,N) */
+/* The upper triangular matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* C (input/output) COMPLEX array, dimension (LDC,N) */
+/* On entry, the M-by-N right hand side matrix C. */
+/* On exit, C is overwritten by the solution matrix X. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M) */
+
+/* SCALE (output) REAL */
+/* The scale factor, scale, set <= 1 to avoid overflow in X. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* = 1: A and B have common or very close eigenvalues; perturbed */
+/* values were used to solve the equation (but the matrices */
+/* A and B are unchanged). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and Test input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ notrna = lsame_(trana, "N");
+ notrnb = lsame_(tranb, "N");
+
+ *info = 0;
+ if (! notrna && ! lsame_(trana, "C")) {
+ *info = -1;
+ } else if (! notrnb && ! lsame_(tranb, "C")) {
+ *info = -2;
+ } else if (*isgn != 1 && *isgn != -1) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*m)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldc < max(1,*m)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTRSYL", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *scale = 1.f;
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Set constants to control overflow */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ smlnum = smlnum * (real) (*m * *n) / eps;
+ bignum = 1.f / smlnum;
+/* Computing MAX */
+ r__1 = smlnum, r__2 = eps * clange_("M", m, m, &a[a_offset], lda, dum), r__1 = max(r__1,r__2), r__2 = eps * clange_("M", n, n,
+ &b[b_offset], ldb, dum);
+ smin = dmax(r__1,r__2);
+ sgn = (real) (*isgn);
+
+ if (notrna && notrnb) {
+
+/* Solve A*X + ISGN*X*B = scale*C. */
+
+/* The (K,L)th block of X is determined starting from */
+/* bottom-left corner column by column by */
+
+/* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */
+
+/* Where */
+/* M L-1 */
+/* R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)]. */
+/* I=K+1 J=1 */
+
+ i__1 = *n;
+ for (l = 1; l <= i__1; ++l) {
+ for (k = *m; k >= 1; --k) {
+
+ i__2 = *m - k;
+/* Computing MIN */
+ i__3 = k + 1;
+/* Computing MIN */
+ i__4 = k + 1;
+ cdotu_(&q__1, &i__2, &a[k + min(i__3, *m)* a_dim1], lda, &c__[
+ min(i__4, *m)+ l * c_dim1], &c__1);
+ suml.r = q__1.r, suml.i = q__1.i;
+ i__2 = l - 1;
+ cdotu_(&q__1, &i__2, &c__[k + c_dim1], ldc, &b[l * b_dim1 + 1]
+, &c__1);
+ sumr.r = q__1.r, sumr.i = q__1.i;
+ i__2 = k + l * c_dim1;
+ q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i;
+ q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
+ q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i;
+ vec.r = q__1.r, vec.i = q__1.i;
+
+ scaloc = 1.f;
+ i__2 = k + k * a_dim1;
+ i__3 = l + l * b_dim1;
+ q__2.r = sgn * b[i__3].r, q__2.i = sgn * b[i__3].i;
+ q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
+ a11.r = q__1.r, a11.i = q__1.i;
+ da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
+ dabs(r__2));
+ if (da11 <= smin) {
+ a11.r = smin, a11.i = 0.f;
+ da11 = smin;
+ *info = 1;
+ }
+ db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
+ r__2));
+ if (da11 < 1.f && db > 1.f) {
+ if (db > bignum * da11) {
+ scaloc = 1.f / db;
+ }
+ }
+ q__3.r = scaloc, q__3.i = 0.f;
+ q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
+ q__3.i + vec.i * q__3.r;
+ cladiv_(&q__1, &q__2, &a11);
+ x11.r = q__1.r, x11.i = q__1.i;
+
+ if (scaloc != 1.f) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ csscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L10: */
+ }
+ *scale *= scaloc;
+ }
+ i__2 = k + l * c_dim1;
+ c__[i__2].r = x11.r, c__[i__2].i = x11.i;
+
+/* L20: */
+ }
+/* L30: */
+ }
+
+ } else if (! notrna && notrnb) {
+
+/* Solve A' *X + ISGN*X*B = scale*C. */
+
+/* The (K,L)th block of X is determined starting from */
+/* upper-left corner column by column by */
+
+/* A'(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */
+
+/* Where */
+/* K-1 L-1 */
+/* R(K,L) = SUM [A'(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)] */
+/* I=1 J=1 */
+
+ i__1 = *n;
+ for (l = 1; l <= i__1; ++l) {
+ i__2 = *m;
+ for (k = 1; k <= i__2; ++k) {
+
+ i__3 = k - 1;
+ cdotc_(&q__1, &i__3, &a[k * a_dim1 + 1], &c__1, &c__[l *
+ c_dim1 + 1], &c__1);
+ suml.r = q__1.r, suml.i = q__1.i;
+ i__3 = l - 1;
+ cdotu_(&q__1, &i__3, &c__[k + c_dim1], ldc, &b[l * b_dim1 + 1]
+, &c__1);
+ sumr.r = q__1.r, sumr.i = q__1.i;
+ i__3 = k + l * c_dim1;
+ q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i;
+ q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
+ q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
+ vec.r = q__1.r, vec.i = q__1.i;
+
+ scaloc = 1.f;
+ r_cnjg(&q__2, &a[k + k * a_dim1]);
+ i__3 = l + l * b_dim1;
+ q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ a11.r = q__1.r, a11.i = q__1.i;
+ da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
+ dabs(r__2));
+ if (da11 <= smin) {
+ a11.r = smin, a11.i = 0.f;
+ da11 = smin;
+ *info = 1;
+ }
+ db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
+ r__2));
+ if (da11 < 1.f && db > 1.f) {
+ if (db > bignum * da11) {
+ scaloc = 1.f / db;
+ }
+ }
+
+ q__3.r = scaloc, q__3.i = 0.f;
+ q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
+ q__3.i + vec.i * q__3.r;
+ cladiv_(&q__1, &q__2, &a11);
+ x11.r = q__1.r, x11.i = q__1.i;
+
+ if (scaloc != 1.f) {
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ csscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L40: */
+ }
+ *scale *= scaloc;
+ }
+ i__3 = k + l * c_dim1;
+ c__[i__3].r = x11.r, c__[i__3].i = x11.i;
+
+/* L50: */
+ }
+/* L60: */
+ }
+
+ } else if (! notrna && ! notrnb) {
+
+/* Solve A'*X + ISGN*X*B' = C. */
+
+/* The (K,L)th block of X is determined starting from */
+/* upper-right corner column by column by */
+
+/* A'(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L) */
+
+/* Where */
+/* K-1 */
+/* R(K,L) = SUM [A'(I,K)*X(I,L)] + */
+/* I=1 */
+/* N */
+/* ISGN*SUM [X(K,J)*B'(L,J)]. */
+/* J=L+1 */
+
+ for (l = *n; l >= 1; --l) {
+ i__1 = *m;
+ for (k = 1; k <= i__1; ++k) {
+
+ i__2 = k - 1;
+ cdotc_(&q__1, &i__2, &a[k * a_dim1 + 1], &c__1, &c__[l *
+ c_dim1 + 1], &c__1);
+ suml.r = q__1.r, suml.i = q__1.i;
+ i__2 = *n - l;
+/* Computing MIN */
+ i__3 = l + 1;
+/* Computing MIN */
+ i__4 = l + 1;
+ cdotc_(&q__1, &i__2, &c__[k + min(i__3, *n)* c_dim1], ldc, &b[
+ l + min(i__4, *n)* b_dim1], ldb);
+ sumr.r = q__1.r, sumr.i = q__1.i;
+ i__2 = k + l * c_dim1;
+ r_cnjg(&q__4, &sumr);
+ q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i;
+ q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
+ q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i;
+ vec.r = q__1.r, vec.i = q__1.i;
+
+ scaloc = 1.f;
+ i__2 = k + k * a_dim1;
+ i__3 = l + l * b_dim1;
+ q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i;
+ q__2.r = a[i__2].r + q__3.r, q__2.i = a[i__2].i + q__3.i;
+ r_cnjg(&q__1, &q__2);
+ a11.r = q__1.r, a11.i = q__1.i;
+ da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
+ dabs(r__2));
+ if (da11 <= smin) {
+ a11.r = smin, a11.i = 0.f;
+ da11 = smin;
+ *info = 1;
+ }
+ db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
+ r__2));
+ if (da11 < 1.f && db > 1.f) {
+ if (db > bignum * da11) {
+ scaloc = 1.f / db;
+ }
+ }
+
+ q__3.r = scaloc, q__3.i = 0.f;
+ q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
+ q__3.i + vec.i * q__3.r;
+ cladiv_(&q__1, &q__2, &a11);
+ x11.r = q__1.r, x11.i = q__1.i;
+
+ if (scaloc != 1.f) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ csscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L70: */
+ }
+ *scale *= scaloc;
+ }
+ i__2 = k + l * c_dim1;
+ c__[i__2].r = x11.r, c__[i__2].i = x11.i;
+
+/* L80: */
+ }
+/* L90: */
+ }
+
+ } else if (notrna && ! notrnb) {
+
+/* Solve A*X + ISGN*X*B' = C. */
+
+/* The (K,L)th block of X is determined starting from */
+/* bottom-left corner column by column by */
+
+/* A(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L) */
+
+/* Where */
+/* M N */
+/* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B'(L,J)] */
+/* I=K+1 J=L+1 */
+
+ for (l = *n; l >= 1; --l) {
+ for (k = *m; k >= 1; --k) {
+
+ i__1 = *m - k;
+/* Computing MIN */
+ i__2 = k + 1;
+/* Computing MIN */
+ i__3 = k + 1;
+ cdotu_(&q__1, &i__1, &a[k + min(i__2, *m)* a_dim1], lda, &c__[
+ min(i__3, *m)+ l * c_dim1], &c__1);
+ suml.r = q__1.r, suml.i = q__1.i;
+ i__1 = *n - l;
+/* Computing MIN */
+ i__2 = l + 1;
+/* Computing MIN */
+ i__3 = l + 1;
+ cdotc_(&q__1, &i__1, &c__[k + min(i__2, *n)* c_dim1], ldc, &b[
+ l + min(i__3, *n)* b_dim1], ldb);
+ sumr.r = q__1.r, sumr.i = q__1.i;
+ i__1 = k + l * c_dim1;
+ r_cnjg(&q__4, &sumr);
+ q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i;
+ q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
+ q__1.r = c__[i__1].r - q__2.r, q__1.i = c__[i__1].i - q__2.i;
+ vec.r = q__1.r, vec.i = q__1.i;
+
+ scaloc = 1.f;
+ i__1 = k + k * a_dim1;
+ r_cnjg(&q__3, &b[l + l * b_dim1]);
+ q__2.r = sgn * q__3.r, q__2.i = sgn * q__3.i;
+ q__1.r = a[i__1].r + q__2.r, q__1.i = a[i__1].i + q__2.i;
+ a11.r = q__1.r, a11.i = q__1.i;
+ da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
+ dabs(r__2));
+ if (da11 <= smin) {
+ a11.r = smin, a11.i = 0.f;
+ da11 = smin;
+ *info = 1;
+ }
+ db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
+ r__2));
+ if (da11 < 1.f && db > 1.f) {
+ if (db > bignum * da11) {
+ scaloc = 1.f / db;
+ }
+ }
+
+ q__3.r = scaloc, q__3.i = 0.f;
+ q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
+ q__3.i + vec.i * q__3.r;
+ cladiv_(&q__1, &q__2, &a11);
+ x11.r = q__1.r, x11.i = q__1.i;
+
+ if (scaloc != 1.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ csscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L100: */
+ }
+ *scale *= scaloc;
+ }
+ i__1 = k + l * c_dim1;
+ c__[i__1].r = x11.r, c__[i__1].i = x11.i;
+
+/* L110: */
+ }
+/* L120: */
+ }
+
+ }
+
+ return 0;
+
+/* End of CTRSYL */
+
+} /* ctrsyl_ */
diff --git a/SRC/ctrti2.c b/SRC/ctrti2.c
new file mode 100644
index 0000000..36dee65
--- /dev/null
+++ b/SRC/ctrti2.c
@@ -0,0 +1,198 @@
+/* ctrti2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int ctrti2_(char *uplo, char *diag, integer *n, complex *a,
+ integer *lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ complex q__1;
+
+ /* Builtin functions */
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer j;
+ complex ajj;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
+ complex *, integer *, complex *, integer *), xerbla_(char *, integer *);
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTRTI2 computes the inverse of a complex upper or lower triangular */
+/* matrix. */
+
+/* This is the Level 2 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the triangular matrix A. If UPLO = 'U', the */
+/* leading n by n upper triangular part of the array A contains */
+/* the upper triangular matrix, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n by n lower triangular part of the array A contains */
+/* the lower triangular matrix, and the strictly upper */
+/* triangular part of A is not referenced. If DIAG = 'U', the */
+/* diagonal elements of A are also not referenced and are */
+/* assumed to be 1. */
+
+/* On exit, the (triangular) inverse of the original matrix, in */
+/* the same storage format. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ nounit = lsame_(diag, "N");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTRTI2", &i__1);
+ return 0;
+ }
+
+ if (upper) {
+
+/* Compute inverse of upper triangular matrix. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (nounit) {
+ i__2 = j + j * a_dim1;
+ c_div(&q__1, &c_b1, &a[j + j * a_dim1]);
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ i__2 = j + j * a_dim1;
+ q__1.r = -a[i__2].r, q__1.i = -a[i__2].i;
+ ajj.r = q__1.r, ajj.i = q__1.i;
+ } else {
+ q__1.r = -1.f, q__1.i = -0.f;
+ ajj.r = q__1.r, ajj.i = q__1.i;
+ }
+
+/* Compute elements 1:j-1 of j-th column. */
+
+ i__2 = j - 1;
+ ctrmv_("Upper", "No transpose", diag, &i__2, &a[a_offset], lda, &
+ a[j * a_dim1 + 1], &c__1);
+ i__2 = j - 1;
+ cscal_(&i__2, &ajj, &a[j * a_dim1 + 1], &c__1);
+/* L10: */
+ }
+ } else {
+
+/* Compute inverse of lower triangular matrix. */
+
+ for (j = *n; j >= 1; --j) {
+ if (nounit) {
+ i__1 = j + j * a_dim1;
+ c_div(&q__1, &c_b1, &a[j + j * a_dim1]);
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = j + j * a_dim1;
+ q__1.r = -a[i__1].r, q__1.i = -a[i__1].i;
+ ajj.r = q__1.r, ajj.i = q__1.i;
+ } else {
+ q__1.r = -1.f, q__1.i = -0.f;
+ ajj.r = q__1.r, ajj.i = q__1.i;
+ }
+ if (j < *n) {
+
+/* Compute elements j+1:n of j-th column. */
+
+ i__1 = *n - j;
+ ctrmv_("Lower", "No transpose", diag, &i__1, &a[j + 1 + (j +
+ 1) * a_dim1], lda, &a[j + 1 + j * a_dim1], &c__1);
+ i__1 = *n - j;
+ cscal_(&i__1, &ajj, &a[j + 1 + j * a_dim1], &c__1);
+ }
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of CTRTI2 */
+
+} /* ctrti2_ */
diff --git a/SRC/ctrtri.c b/SRC/ctrtri.c
new file mode 100644
index 0000000..4647bbf
--- /dev/null
+++ b/SRC/ctrtri.c
@@ -0,0 +1,244 @@
+/* ctrtri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int ctrtri_(char *uplo, char *diag, integer *n, complex *a,
+ integer *lda, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, i__1, i__2, i__3[2], i__4, i__5;
+ complex q__1;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer j, jb, nb, nn;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *), ctrsm_(char *, char *,
+ char *, char *, integer *, integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int ctrti2_(char *, char *, integer *, complex *,
+ integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTRTRI computes the inverse of a complex upper or lower triangular */
+/* matrix A. */
+
+/* This is the Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the triangular matrix A. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of the array A contains */
+/* the upper triangular matrix, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of the array A contains */
+/* the lower triangular matrix, and the strictly upper */
+/* triangular part of A is not referenced. If DIAG = 'U', the */
+/* diagonal elements of A are also not referenced and are */
+/* assumed to be 1. */
+/* On exit, the (triangular) inverse of the original matrix, in */
+/* the same storage format. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */
+/* matrix is singular and its inverse can not be computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ nounit = lsame_(diag, "N");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTRTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check for singularity if non-unit. */
+
+ if (nounit) {
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ i__2 = *info + *info * a_dim1;
+ if (a[i__2].r == 0.f && a[i__2].i == 0.f) {
+ return 0;
+ }
+/* L10: */
+ }
+ *info = 0;
+ }
+
+/* Determine the block size for this environment. */
+
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = uplo;
+ i__3[1] = 1, a__1[1] = diag;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ nb = ilaenv_(&c__1, "CTRTRI", ch__1, n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code */
+
+ ctrti2_(uplo, diag, n, &a[a_offset], lda, info);
+ } else {
+
+/* Use blocked code */
+
+ if (upper) {
+
+/* Compute inverse of upper triangular matrix */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *n - j + 1;
+ jb = min(i__4,i__5);
+
+/* Compute rows 1:j-1 of current block column */
+
+ i__4 = j - 1;
+ ctrmm_("Left", "Upper", "No transpose", diag, &i__4, &jb, &
+ c_b1, &a[a_offset], lda, &a[j * a_dim1 + 1], lda);
+ i__4 = j - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ ctrsm_("Right", "Upper", "No transpose", diag, &i__4, &jb, &
+ q__1, &a[j + j * a_dim1], lda, &a[j * a_dim1 + 1],
+ lda);
+
+/* Compute inverse of current diagonal block */
+
+ ctrti2_("Upper", diag, &jb, &a[j + j * a_dim1], lda, info);
+/* L20: */
+ }
+ } else {
+
+/* Compute inverse of lower triangular matrix */
+
+ nn = (*n - 1) / nb * nb + 1;
+ i__2 = -nb;
+ for (j = nn; i__2 < 0 ? j >= 1 : j <= 1; j += i__2) {
+/* Computing MIN */
+ i__1 = nb, i__4 = *n - j + 1;
+ jb = min(i__1,i__4);
+ if (j + jb <= *n) {
+
+/* Compute rows j+jb:n of current block column */
+
+ i__1 = *n - j - jb + 1;
+ ctrmm_("Left", "Lower", "No transpose", diag, &i__1, &jb,
+ &c_b1, &a[j + jb + (j + jb) * a_dim1], lda, &a[j
+ + jb + j * a_dim1], lda);
+ i__1 = *n - j - jb + 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ ctrsm_("Right", "Lower", "No transpose", diag, &i__1, &jb,
+ &q__1, &a[j + j * a_dim1], lda, &a[j + jb + j *
+ a_dim1], lda);
+ }
+
+/* Compute inverse of current diagonal block */
+
+ ctrti2_("Lower", diag, &jb, &a[j + j * a_dim1], lda, info);
+/* L30: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CTRTRI */
+
+} /* ctrtri_ */
diff --git a/SRC/ctrtrs.c b/SRC/ctrtrs.c
new file mode 100644
index 0000000..71692d1
--- /dev/null
+++ b/SRC/ctrtrs.c
@@ -0,0 +1,184 @@
+/* ctrtrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b2 = {1.f,0.f};
+
+/* Subroutine */ int ctrtrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, complex *a, integer *lda, complex *b, integer *ldb,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *), xerbla_(char *,
+ integer *);
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTRTRS solves a triangular system of the form */
+
+/* A * X = B, A**T * X = B, or A**H * X = B, */
+
+/* where A is a triangular matrix of order N, and B is an N-by-NRHS */
+/* matrix. A check is made to verify that A is nonsingular. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, if INFO = 0, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element of A is zero, */
+/* indicating that the matrix is singular and the solutions */
+/* X have not been computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ nounit = lsame_(diag, "N");
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTRTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check for singularity. */
+
+ if (nounit) {
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ i__2 = *info + *info * a_dim1;
+ if (a[i__2].r == 0.f && a[i__2].i == 0.f) {
+ return 0;
+ }
+/* L10: */
+ }
+ }
+ *info = 0;
+
+/* Solve A * x = b, A**T * x = b, or A**H * x = b. */
+
+ ctrsm_("Left", uplo, trans, diag, n, nrhs, &c_b2, &a[a_offset], lda, &b[
+ b_offset], ldb);
+
+ return 0;
+
+/* End of CTRTRS */
+
+} /* ctrtrs_ */
diff --git a/SRC/ctrttf.c b/SRC/ctrttf.c
new file mode 100644
index 0000000..406aaed
--- /dev/null
+++ b/SRC/ctrttf.c
@@ -0,0 +1,580 @@
+/* ctrttf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ctrttf_(char *transr, char *uplo, integer *n, complex *a,
+ integer *lda, complex *arf, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ complex q__1;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k, l, n1, n2, ij, nt, nx2, np1x2;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nisodd;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTRTTF copies a triangular matrix A from standard full format (TR) */
+/* to rectangular full packed format (TF) . */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': ARF in Normal mode is wanted; */
+/* = 'C': ARF in Conjugate Transpose mode is wanted; */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension ( LDA, N ) */
+/* On entry, the triangular matrix A. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of the array A contains */
+/* the upper triangular matrix, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of the array A contains */
+/* the lower triangular matrix, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the matrix A. LDA >= max(1,N). */
+
+/* ARF (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ), */
+/* On exit, the upper or lower triangular matrix A stored in */
+/* RFP format. For a further discussion see Notes below. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Notes */
+/* ===== */
+
+/* We first consider Standard Packed Format when N is even. */
+/* We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = `N'. RFP holds AP as follows: */
+/* For UPLO = `U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* conjugate-transpose of the first three columns of AP upper. */
+/* For UPLO = `L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* conjugate-transpose of the last three columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N even and TRANSR = `N'. */
+
+/* RFP A RFP A */
+
+/* -- -- -- */
+/* 03 04 05 33 43 53 */
+/* -- -- */
+/* 13 14 15 00 44 54 */
+/* -- */
+/* 23 24 25 10 11 55 */
+
+/* 33 34 35 20 21 22 */
+/* -- */
+/* 00 44 45 30 31 32 */
+/* -- -- */
+/* 01 11 55 40 41 42 */
+/* -- -- -- */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We next consider Standard Packed Format when N is odd. */
+/* We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = `N'. RFP holds AP as follows: */
+/* For UPLO = `U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* conjugate-transpose of the first two columns of AP upper. */
+/* For UPLO = `L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* conjugate-transpose of the last two columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N odd and TRANSR = `N'. */
+
+/* RFP A RFP A */
+
+/* -- -- */
+/* 02 03 04 00 33 43 */
+/* -- */
+/* 12 13 14 10 11 44 */
+
+/* 22 23 24 20 21 22 */
+/* -- */
+/* 00 33 34 30 31 32 */
+/* -- -- */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- */
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda - 1 - 0 + 1;
+ a_offset = 0 + a_dim1 * 0;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "C")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTRTTF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 1) {
+ if (*n == 1) {
+ if (normaltransr) {
+ arf[0].r = a[0].r, arf[0].i = a[0].i;
+ } else {
+ r_cnjg(&q__1, a);
+ arf[0].r = q__1.r, arf[0].i = q__1.i;
+ }
+ }
+ return 0;
+ }
+
+/* Size of array ARF(1:2,0:nt-1) */
+
+ nt = *n * (*n + 1) / 2;
+
+/* set N1 and N2 depending on LOWER: for N even N1=N2=K */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. */
+/* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is */
+/* N--by--(N+1)/2. */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ if (! lower) {
+ np1x2 = *n + *n + 2;
+ }
+ } else {
+ nisodd = TRUE_;
+ if (! lower) {
+ nx2 = *n + *n;
+ }
+ }
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */
+/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */
+/* T1 -> a(0), T2 -> a(n), S -> a(n1); lda=n */
+
+ ij = 0;
+ i__1 = n2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = n2 + j;
+ for (i__ = n1; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ r_cnjg(&q__1, &a[n2 + j + i__ * a_dim1]);
+ arf[i__3].r = q__1.r, arf[i__3].i = q__1.i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ i__4 = i__ + j * a_dim1;
+ arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i;
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */
+/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */
+/* T1 -> a(n2), T2 -> a(n1), S -> a(0); lda=n */
+
+ ij = nt - *n;
+ i__1 = n1;
+ for (j = *n - 1; j >= i__1; --j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ i__4 = i__ + j * a_dim1;
+ arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i;
+ ++ij;
+ }
+ i__2 = n1 - 1;
+ for (l = j - n1; l <= i__2; ++l) {
+ i__3 = ij;
+ r_cnjg(&q__1, &a[j - n1 + l * a_dim1]);
+ arf[i__3].r = q__1.r, arf[i__3].i = q__1.i;
+ ++ij;
+ }
+ ij -= nx2;
+ }
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is odd */
+/* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */
+/* T1 -> A(0+0) , T2 -> A(1+0) , S -> A(0+n1*n1); lda=n1 */
+
+ ij = 0;
+ i__1 = n2 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ r_cnjg(&q__1, &a[j + i__ * a_dim1]);
+ arf[i__3].r = q__1.r, arf[i__3].i = q__1.i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = n1 + j; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ i__4 = i__ + (n1 + j) * a_dim1;
+ arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i;
+ ++ij;
+ }
+ }
+ i__1 = *n - 1;
+ for (j = n2; j <= i__1; ++j) {
+ i__2 = n1 - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ r_cnjg(&q__1, &a[j + i__ * a_dim1]);
+ arf[i__3].r = q__1.r, arf[i__3].i = q__1.i;
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is odd */
+/* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */
+/* T1 -> A(n2*n2), T2 -> A(n1*n2), S -> A(0); lda=n2 */
+
+ ij = 0;
+ i__1 = n1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = n1; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ r_cnjg(&q__1, &a[j + i__ * a_dim1]);
+ arf[i__3].r = q__1.r, arf[i__3].i = q__1.i;
+ ++ij;
+ }
+ }
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ i__4 = i__ + j * a_dim1;
+ arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (l = n2 + j; l <= i__2; ++l) {
+ i__3 = ij;
+ r_cnjg(&q__1, &a[n2 + j + l * a_dim1]);
+ arf[i__3].r = q__1.r, arf[i__3].i = q__1.i;
+ ++ij;
+ }
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
+/* T1 -> a(1), T2 -> a(0), S -> a(k+1); lda=n+1 */
+
+ ij = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k + j;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ r_cnjg(&q__1, &a[k + j + i__ * a_dim1]);
+ arf[i__3].r = q__1.r, arf[i__3].i = q__1.i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ i__4 = i__ + j * a_dim1;
+ arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i;
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
+/* T1 -> a(k+1), T2 -> a(k), S -> a(0); lda=n+1 */
+
+ ij = nt - *n - 1;
+ i__1 = k;
+ for (j = *n - 1; j >= i__1; --j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ i__4 = i__ + j * a_dim1;
+ arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i;
+ ++ij;
+ }
+ i__2 = k - 1;
+ for (l = j - k; l <= i__2; ++l) {
+ i__3 = ij;
+ r_cnjg(&q__1, &a[j - k + l * a_dim1]);
+ arf[i__3].r = q__1.r, arf[i__3].i = q__1.i;
+ ++ij;
+ }
+ ij -= np1x2;
+ }
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is even (see paper, A=B) */
+/* T1 -> A(0,1) , T2 -> A(0,0) , S -> A(0,k+1) : */
+/* T1 -> A(0+k) , T2 -> A(0+0) , S -> A(0+k*(k+1)); lda=k */
+
+ ij = 0;
+ j = k;
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ i__2 = ij;
+ i__3 = i__ + j * a_dim1;
+ arf[i__2].r = a[i__3].r, arf[i__2].i = a[i__3].i;
+ ++ij;
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ r_cnjg(&q__1, &a[j + i__ * a_dim1]);
+ arf[i__3].r = q__1.r, arf[i__3].i = q__1.i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = k + 1 + j; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ i__4 = i__ + (k + 1 + j) * a_dim1;
+ arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i;
+ ++ij;
+ }
+ }
+ i__1 = *n - 1;
+ for (j = k - 1; j <= i__1; ++j) {
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ r_cnjg(&q__1, &a[j + i__ * a_dim1]);
+ arf[i__3].r = q__1.r, arf[i__3].i = q__1.i;
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is even (see paper, A=B) */
+/* T1 -> A(0,k+1) , T2 -> A(0,k) , S -> A(0,0) */
+/* T1 -> A(0+k*(k+1)) , T2 -> A(0+k*k) , S -> A(0+0)); lda=k */
+
+ ij = 0;
+ i__1 = k;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ r_cnjg(&q__1, &a[j + i__ * a_dim1]);
+ arf[i__3].r = q__1.r, arf[i__3].i = q__1.i;
+ ++ij;
+ }
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ i__4 = i__ + j * a_dim1;
+ arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (l = k + 1 + j; l <= i__2; ++l) {
+ i__3 = ij;
+ r_cnjg(&q__1, &a[k + 1 + j + l * a_dim1]);
+ arf[i__3].r = q__1.r, arf[i__3].i = q__1.i;
+ ++ij;
+ }
+ }
+
+/* Note that here J = K-1 */
+
+ i__1 = j;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = ij;
+ i__3 = i__ + j * a_dim1;
+ arf[i__2].r = a[i__3].r, arf[i__2].i = a[i__3].i;
+ ++ij;
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of CTRTTF */
+
+} /* ctrttf_ */
diff --git a/SRC/ctrttp.c b/SRC/ctrttp.c
new file mode 100644
index 0000000..bdf7acb
--- /dev/null
+++ b/SRC/ctrttp.c
@@ -0,0 +1,148 @@
+/* ctrttp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ctrttp_(char *uplo, integer *n, complex *a, integer *lda,
+ complex *ap, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, k;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- and Julien Langou of the Univ. of Colorado Denver -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTRTTP copies a triangular matrix A from full format (TR) to standard */
+/* packed format (TP). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrices AP and A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* On entry, the triangular matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AP (output) COMPLEX array, dimension ( N*(N+1)/2 ), */
+/* On exit, the upper or lower triangular matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ lower = lsame_(uplo, "L");
+ if (! lower && ! lsame_(uplo, "U")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTRTTP", &i__1);
+ return 0;
+ }
+
+ if (lower) {
+ k = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ++k;
+ i__3 = k;
+ i__4 = i__ + j * a_dim1;
+ ap[i__3].r = a[i__4].r, ap[i__3].i = a[i__4].i;
+ }
+ }
+ } else {
+ k = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ++k;
+ i__3 = k;
+ i__4 = i__ + j * a_dim1;
+ ap[i__3].r = a[i__4].r, ap[i__3].i = a[i__4].i;
+ }
+ }
+ }
+
+
+ return 0;
+
+/* End of CTRTTP */
+
+} /* ctrttp_ */
diff --git a/SRC/ctzrqf.c b/SRC/ctzrqf.c
new file mode 100644
index 0000000..80987b9
--- /dev/null
+++ b/SRC/ctzrqf.c
@@ -0,0 +1,241 @@
+/* ctzrqf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int ctzrqf_(integer *m, integer *n, complex *a, integer *lda,
+ complex *tau, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, k, m1;
+ extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *);
+ complex alpha;
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *), ccopy_(integer *, complex *, integer *,
+ complex *, integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *), clacgv_(integer *, complex *,
+ integer *), clarfp_(integer *, complex *, complex *, integer *,
+ complex *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine CTZRZF. */
+
+/* CTZRQF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A */
+/* to upper triangular form by means of unitary transformations. */
+
+/* The upper trapezoidal matrix A is factored as */
+
+/* A = ( R 0 ) * Z, */
+
+/* where Z is an N-by-N unitary matrix and R is an M-by-M upper */
+/* triangular matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= M. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the leading M-by-N upper trapezoidal part of the */
+/* array A must contain the matrix to be factorized. */
+/* On exit, the leading M-by-M upper triangular part of A */
+/* contains the upper triangular matrix R, and elements M+1 to */
+/* N of the first M rows of A, with the array TAU, represent the */
+/* unitary matrix Z as a product of M elementary reflectors. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX array, dimension (M) */
+/* The scalar factors of the elementary reflectors. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The factorization is obtained by Householder's method. The kth */
+/* transformation matrix, Z( k ), whose conjugate transpose is used to */
+/* introduce zeros into the (m - k + 1)th row of A, is given in the form */
+
+/* Z( k ) = ( I 0 ), */
+/* ( 0 T( k ) ) */
+
+/* where */
+
+/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */
+/* ( 0 ) */
+/* ( z( k ) ) */
+
+/* tau is a scalar and z( k ) is an ( n - m ) element vector. */
+/* tau and z( k ) are chosen to annihilate the elements of the kth row */
+/* of X. */
+
+/* The scalar tau is returned in the kth element of TAU and the vector */
+/* u( k ) in the kth row of A, such that the elements of z( k ) are */
+/* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */
+/* the upper triangular part of A. */
+
+/* Z is given by */
+
+/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTZRQF", &i__1);
+ return 0;
+ }
+
+/* Perform the factorization. */
+
+ if (*m == 0) {
+ return 0;
+ }
+ if (*m == *n) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ tau[i__2].r = 0.f, tau[i__2].i = 0.f;
+/* L10: */
+ }
+ } else {
+/* Computing MIN */
+ i__1 = *m + 1;
+ m1 = min(i__1,*n);
+ for (k = *m; k >= 1; --k) {
+
+/* Use a Householder reflection to zero the kth row of A. */
+/* First set up the reflection. */
+
+ i__1 = k + k * a_dim1;
+ r_cnjg(&q__1, &a[k + k * a_dim1]);
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = *n - *m;
+ clacgv_(&i__1, &a[k + m1 * a_dim1], lda);
+ i__1 = k + k * a_dim1;
+ alpha.r = a[i__1].r, alpha.i = a[i__1].i;
+ i__1 = *n - *m + 1;
+ clarfp_(&i__1, &alpha, &a[k + m1 * a_dim1], lda, &tau[k]);
+ i__1 = k + k * a_dim1;
+ a[i__1].r = alpha.r, a[i__1].i = alpha.i;
+ i__1 = k;
+ r_cnjg(&q__1, &tau[k]);
+ tau[i__1].r = q__1.r, tau[i__1].i = q__1.i;
+
+ i__1 = k;
+ if ((tau[i__1].r != 0.f || tau[i__1].i != 0.f) && k > 1) {
+
+/* We now perform the operation A := A*P( k )'. */
+
+/* Use the first ( k - 1 ) elements of TAU to store a( k ), */
+/* where a( k ) consists of the first ( k - 1 ) elements of */
+/* the kth column of A. Also let B denote the first */
+/* ( k - 1 ) rows of the last ( n - m ) columns of A. */
+
+ i__1 = k - 1;
+ ccopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &tau[1], &c__1);
+
+/* Form w = a( k ) + B*z( k ) in TAU. */
+
+ i__1 = k - 1;
+ i__2 = *n - *m;
+ cgemv_("No transpose", &i__1, &i__2, &c_b1, &a[m1 * a_dim1 +
+ 1], lda, &a[k + m1 * a_dim1], lda, &c_b1, &tau[1], &
+ c__1);
+
+/* Now form a( k ) := a( k ) - conjg(tau)*w */
+/* and B := B - conjg(tau)*w*z( k )'. */
+
+ i__1 = k - 1;
+ r_cnjg(&q__2, &tau[k]);
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ caxpy_(&i__1, &q__1, &tau[1], &c__1, &a[k * a_dim1 + 1], &
+ c__1);
+ i__1 = k - 1;
+ i__2 = *n - *m;
+ r_cnjg(&q__2, &tau[k]);
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ cgerc_(&i__1, &i__2, &q__1, &tau[1], &c__1, &a[k + m1 *
+ a_dim1], lda, &a[m1 * a_dim1 + 1], lda);
+ }
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of CTZRQF */
+
+} /* ctzrqf_ */
diff --git a/SRC/ctzrzf.c b/SRC/ctzrzf.c
new file mode 100644
index 0000000..759ccba
--- /dev/null
+++ b/SRC/ctzrzf.c
@@ -0,0 +1,310 @@
+/* ctzrzf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int ctzrzf_(integer *m, integer *n, complex *a, integer *lda,
+ complex *tau, complex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+
+ /* Local variables */
+ integer i__, m1, ib, nb, ki, kk, mu, nx, iws, nbmin;
+ extern /* Subroutine */ int clarzb_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, complex *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int clarzt_(char *, char *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *), clatrz_(integer *, integer *, integer *, complex *,
+ integer *, complex *, complex *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTZRZF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A */
+/* to upper triangular form by means of unitary transformations. */
+
+/* The upper trapezoidal matrix A is factored as */
+
+/* A = ( R 0 ) * Z, */
+
+/* where Z is an N-by-N unitary matrix and R is an M-by-M upper */
+/* triangular matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= M. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the leading M-by-N upper trapezoidal part of the */
+/* array A must contain the matrix to be factorized. */
+/* On exit, the leading M-by-M upper triangular part of A */
+/* contains the upper triangular matrix R, and elements M+1 to */
+/* N of the first M rows of A, with the array TAU, represent the */
+/* unitary matrix Z as a product of M elementary reflectors. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX array, dimension (M) */
+/* The scalar factors of the elementary reflectors. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M). */
+/* For optimum performance LWORK >= M*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* The factorization is obtained by Householder's method. The kth */
+/* transformation matrix, Z( k ), which is used to introduce zeros into */
+/* the ( m - k + 1 )th row of A, is given in the form */
+
+/* Z( k ) = ( I 0 ), */
+/* ( 0 T( k ) ) */
+
+/* where */
+
+/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */
+/* ( 0 ) */
+/* ( z( k ) ) */
+
+/* tau is a scalar and z( k ) is an ( n - m ) element vector. */
+/* tau and z( k ) are chosen to annihilate the elements of the kth row */
+/* of X. */
+
+/* The scalar tau is returned in the kth element of TAU and the vector */
+/* u( k ) in the kth row of A, such that the elements of z( k ) are */
+/* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */
+/* the upper triangular part of A. */
+
+/* Z is given by */
+
+/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ } else if (*lwork < max(1,*m) && ! lquery) {
+ *info = -7;
+ }
+
+ if (*info == 0) {
+ if (*m == 0 || *m == *n) {
+ lwkopt = 1;
+ } else {
+
+/* Determine the block size. */
+
+ nb = ilaenv_(&c__1, "CGERQF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = *m * nb;
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ if (*lwork < max(1,*m) && ! lquery) {
+ *info = -7;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CTZRZF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0) {
+ return 0;
+ } else if (*m == *n) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ tau[i__2].r = 0.f, tau[i__2].i = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 1;
+ iws = *m;
+ if (nb > 1 && nb < *m) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "CGERQF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *m) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *m;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "CGERQF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < *m && nx < *m) {
+
+/* Use blocked code initially. */
+/* The last kk rows are handled by the block method. */
+
+/* Computing MIN */
+ i__1 = *m + 1;
+ m1 = min(i__1,*n);
+ ki = (*m - nx - 1) / nb * nb;
+/* Computing MIN */
+ i__1 = *m, i__2 = ki + nb;
+ kk = min(i__1,i__2);
+
+ i__1 = *m - kk + 1;
+ i__2 = -nb;
+ for (i__ = *m - kk + ki + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1;
+ i__ += i__2) {
+/* Computing MIN */
+ i__3 = *m - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Compute the TZ factorization of the current block */
+/* A(i:i+ib-1,i:n) */
+
+ i__3 = *n - i__ + 1;
+ i__4 = *n - *m;
+ clatrz_(&ib, &i__3, &i__4, &a[i__ + i__ * a_dim1], lda, &tau[i__],
+ &work[1]);
+ if (i__ > 1) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__3 = *n - *m;
+ clarzt_("Backward", "Rowwise", &i__3, &ib, &a[i__ + m1 *
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H to A(1:i-1,i:n) from the right */
+
+ i__3 = i__ - 1;
+ i__4 = *n - i__ + 1;
+ i__5 = *n - *m;
+ clarzb_("Right", "No transpose", "Backward", "Rowwise", &i__3,
+ &i__4, &ib, &i__5, &a[i__ + m1 * a_dim1], lda, &work[
+ 1], &ldwork, &a[i__ * a_dim1 + 1], lda, &work[ib + 1],
+ &ldwork)
+ ;
+ }
+/* L20: */
+ }
+ mu = i__ + nb - 1;
+ } else {
+ mu = *m;
+ }
+
+/* Use unblocked code to factor the last or only block */
+
+ if (mu > 0) {
+ i__2 = *n - *m;
+ clatrz_(&mu, n, &i__2, &a[a_offset], lda, &tau[1], &work[1]);
+ }
+
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CTZRZF */
+
+} /* ctzrzf_ */
diff --git a/SRC/cung2l.c b/SRC/cung2l.c
new file mode 100644
index 0000000..5af1652
--- /dev/null
+++ b/SRC/cung2l.c
@@ -0,0 +1,182 @@
+/* cung2l.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cung2l_(integer *m, integer *n, integer *k, complex *a,
+ integer *lda, complex *tau, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j, l, ii;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *), clarf_(char *, integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, complex *),
+ xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNG2L generates an m by n complex matrix Q with orthonormal columns, */
+/* which is defined as the last n columns of a product of k elementary */
+/* reflectors of order m */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by CGEQLF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the (n-k+i)-th column must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by CGEQLF in the last k columns of its array */
+/* argument A. */
+/* On exit, the m-by-n matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) COMPLEX array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CGEQLF. */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUNG2L", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Initialise columns 1:n-k to columns of the unit matrix */
+
+ i__1 = *n - *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = l + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L10: */
+ }
+ i__2 = *m - *n + j + j * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+/* L20: */
+ }
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ii = *n - *k + i__;
+
+/* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left */
+
+ i__2 = *m - *n + ii + ii * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+ i__2 = *m - *n + ii;
+ i__3 = ii - 1;
+ clarf_("Left", &i__2, &i__3, &a[ii * a_dim1 + 1], &c__1, &tau[i__], &
+ a[a_offset], lda, &work[1]);
+ i__2 = *m - *n + ii - 1;
+ i__3 = i__;
+ q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i;
+ cscal_(&i__2, &q__1, &a[ii * a_dim1 + 1], &c__1);
+ i__2 = *m - *n + ii + ii * a_dim1;
+ i__3 = i__;
+ q__1.r = 1.f - tau[i__3].r, q__1.i = 0.f - tau[i__3].i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+
+/* Set A(m-k+i+1:m,n-k+i) to zero */
+
+ i__2 = *m;
+ for (l = *m - *n + ii + 1; l <= i__2; ++l) {
+ i__3 = l + ii * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+ return 0;
+
+/* End of CUNG2L */
+
+} /* cung2l_ */
diff --git a/SRC/cung2r.c b/SRC/cung2r.c
new file mode 100644
index 0000000..d02600f
--- /dev/null
+++ b/SRC/cung2r.c
@@ -0,0 +1,184 @@
+/* cung2r.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cung2r_(integer *m, integer *n, integer *k, complex *a,
+ integer *lda, complex *tau, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j, l;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *), clarf_(char *, integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, complex *),
+ xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNG2R generates an m by n complex matrix Q with orthonormal columns, */
+/* which is defined as the first n columns of a product of k elementary */
+/* reflectors of order m */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by CGEQRF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the i-th column must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by CGEQRF in the first k columns of its array */
+/* argument A. */
+/* On exit, the m by n matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) COMPLEX array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CGEQRF. */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUNG2R", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Initialise columns k+1:n to columns of the unit matrix */
+
+ i__1 = *n;
+ for (j = *k + 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = l + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L10: */
+ }
+ i__2 = j + j * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+/* L20: */
+ }
+
+ for (i__ = *k; i__ >= 1; --i__) {
+
+/* Apply H(i) to A(i:m,i:n) from the left */
+
+ if (i__ < *n) {
+ i__1 = i__ + i__ * a_dim1;
+ a[i__1].r = 1.f, a[i__1].i = 0.f;
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__;
+ clarf_("Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[
+ i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
+ }
+ if (i__ < *m) {
+ i__1 = *m - i__;
+ i__2 = i__;
+ q__1.r = -tau[i__2].r, q__1.i = -tau[i__2].i;
+ cscal_(&i__1, &q__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
+ }
+ i__1 = i__ + i__ * a_dim1;
+ i__2 = i__;
+ q__1.r = 1.f - tau[i__2].r, q__1.i = 0.f - tau[i__2].i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+
+/* Set A(1:i-1,i) to zero */
+
+ i__1 = i__ - 1;
+ for (l = 1; l <= i__1; ++l) {
+ i__2 = l + i__ * a_dim1;
+ a[i__2].r = 0.f, a[i__2].i = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+ return 0;
+
+/* End of CUNG2R */
+
+} /* cung2r_ */
diff --git a/SRC/cungbr.c b/SRC/cungbr.c
new file mode 100644
index 0000000..c8369b0
--- /dev/null
+++ b/SRC/cungbr.c
@@ -0,0 +1,309 @@
+/* cungbr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cungbr_(char *vect, integer *m, integer *n, integer *k,
+ complex *a, integer *lda, complex *tau, complex *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, nb, mn;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical wantq;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int cunglq_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *),
+ cungqr_(integer *, integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNGBR generates one of the complex unitary matrices Q or P**H */
+/* determined by CGEBRD when reducing a complex matrix A to bidiagonal */
+/* form: A = Q * B * P**H. Q and P**H are defined as products of */
+/* elementary reflectors H(i) or G(i) respectively. */
+
+/* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q */
+/* is of order M: */
+/* if m >= k, Q = H(1) H(2) . . . H(k) and CUNGBR returns the first n */
+/* columns of Q, where m >= n >= k; */
+/* if m < k, Q = H(1) H(2) . . . H(m-1) and CUNGBR returns Q as an */
+/* M-by-M matrix. */
+
+/* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H */
+/* is of order N: */
+/* if k < n, P**H = G(k) . . . G(2) G(1) and CUNGBR returns the first m */
+/* rows of P**H, where n >= m >= k; */
+/* if k >= n, P**H = G(n-1) . . . G(2) G(1) and CUNGBR returns P**H as */
+/* an N-by-N matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* VECT (input) CHARACTER*1 */
+/* Specifies whether the matrix Q or the matrix P**H is */
+/* required, as defined in the transformation applied by CGEBRD: */
+/* = 'Q': generate Q; */
+/* = 'P': generate P**H. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q or P**H to be returned. */
+/* M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q or P**H to be returned. */
+/* N >= 0. */
+/* If VECT = 'Q', M >= N >= min(M,K); */
+/* if VECT = 'P', N >= M >= min(N,K). */
+
+/* K (input) INTEGER */
+/* If VECT = 'Q', the number of columns in the original M-by-K */
+/* matrix reduced by CGEBRD. */
+/* If VECT = 'P', the number of rows in the original K-by-N */
+/* matrix reduced by CGEBRD. */
+/* K >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the vectors which define the elementary reflectors, */
+/* as returned by CGEBRD. */
+/* On exit, the M-by-N matrix Q or P**H. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* TAU (input) COMPLEX array, dimension */
+/* (min(M,K)) if VECT = 'Q' */
+/* (min(N,K)) if VECT = 'P' */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i) or G(i), which determines Q or P**H, as */
+/* returned by CGEBRD in its array argument TAUQ or TAUP. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,min(M,N)). */
+/* For optimum performance LWORK >= min(M,N)*NB, where NB */
+/* is the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ wantq = lsame_(vect, "Q");
+ mn = min(*m,*n);
+ lquery = *lwork == -1;
+ if (! wantq && ! lsame_(vect, "P")) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*n < 0 || wantq && (*n > *m || *n < min(*m,*k)) || ! wantq && (
+ *m > *n || *m < min(*n,*k))) {
+ *info = -3;
+ } else if (*k < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -6;
+ } else if (*lwork < max(1,mn) && ! lquery) {
+ *info = -9;
+ }
+
+ if (*info == 0) {
+ if (wantq) {
+ nb = ilaenv_(&c__1, "CUNGQR", " ", m, n, k, &c_n1);
+ } else {
+ nb = ilaenv_(&c__1, "CUNGLQ", " ", m, n, k, &c_n1);
+ }
+ lwkopt = max(1,mn) * nb;
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUNGBR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ work[1].r = 1.f, work[1].i = 0.f;
+ return 0;
+ }
+
+ if (wantq) {
+
+/* Form Q, determined by a call to CGEBRD to reduce an m-by-k */
+/* matrix */
+
+ if (*m >= *k) {
+
+/* If m >= k, assume m >= n >= k */
+
+ cungqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
+ iinfo);
+
+ } else {
+
+/* If m < k, assume m = n */
+
+/* Shift the vectors which define the elementary reflectors one */
+/* column to the right, and set the first row and column of Q */
+/* to those of the unit matrix */
+
+ for (j = *m; j >= 2; --j) {
+ i__1 = j * a_dim1 + 1;
+ a[i__1].r = 0.f, a[i__1].i = 0.f;
+ i__1 = *m;
+ for (i__ = j + 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * a_dim1;
+ i__3 = i__ + (j - 1) * a_dim1;
+ a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
+/* L10: */
+ }
+/* L20: */
+ }
+ i__1 = a_dim1 + 1;
+ a[i__1].r = 1.f, a[i__1].i = 0.f;
+ i__1 = *m;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__ + a_dim1;
+ a[i__2].r = 0.f, a[i__2].i = 0.f;
+/* L30: */
+ }
+ if (*m > 1) {
+
+/* Form Q(2:m,2:m) */
+
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ cungqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[
+ 1], &work[1], lwork, &iinfo);
+ }
+ }
+ } else {
+
+/* Form P', determined by a call to CGEBRD to reduce a k-by-n */
+/* matrix */
+
+ if (*k < *n) {
+
+/* If k < n, assume k <= m <= n */
+
+ cunglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
+ iinfo);
+
+ } else {
+
+/* If k >= n, assume m = n */
+
+/* Shift the vectors which define the elementary reflectors one */
+/* row downward, and set the first row and column of P' to */
+/* those of the unit matrix */
+
+ i__1 = a_dim1 + 1;
+ a[i__1].r = 1.f, a[i__1].i = 0.f;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__ + a_dim1;
+ a[i__2].r = 0.f, a[i__2].i = 0.f;
+/* L40: */
+ }
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ for (i__ = j - 1; i__ >= 2; --i__) {
+ i__2 = i__ + j * a_dim1;
+ i__3 = i__ - 1 + j * a_dim1;
+ a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
+/* L50: */
+ }
+ i__2 = j * a_dim1 + 1;
+ a[i__2].r = 0.f, a[i__2].i = 0.f;
+/* L60: */
+ }
+ if (*n > 1) {
+
+/* Form P'(2:n,2:n) */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ cunglq_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[
+ 1], &work[1], lwork, &iinfo);
+ }
+ }
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ return 0;
+
+/* End of CUNGBR */
+
+} /* cungbr_ */
diff --git a/SRC/cunghr.c b/SRC/cunghr.c
new file mode 100644
index 0000000..c52e4a4
--- /dev/null
+++ b/SRC/cunghr.c
@@ -0,0 +1,223 @@
+/* cunghr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cunghr_(integer *n, integer *ilo, integer *ihi, complex *
+ a, integer *lda, complex *tau, complex *work, integer *lwork, integer
+ *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, nb, nh, iinfo;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int cungqr_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNGHR generates a complex unitary matrix Q which is defined as the */
+/* product of IHI-ILO elementary reflectors of order N, as returned by */
+/* CGEHRD: */
+
+/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix Q. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* ILO and IHI must have the same values as in the previous call */
+/* of CGEHRD. Q is equal to the unit matrix except in the */
+/* submatrix Q(ilo+1:ihi,ilo+1:ihi). */
+/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the vectors which define the elementary reflectors, */
+/* as returned by CGEHRD. */
+/* On exit, the N-by-N unitary matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAU (input) COMPLEX array, dimension (N-1) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CGEHRD. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= IHI-ILO. */
+/* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nh = *ihi - *ilo;
+ lquery = *lwork == -1;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*ilo < 1 || *ilo > max(1,*n)) {
+ *info = -2;
+ } else if (*ihi < min(*ilo,*n) || *ihi > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*lwork < max(1,nh) && ! lquery) {
+ *info = -8;
+ }
+
+ if (*info == 0) {
+ nb = ilaenv_(&c__1, "CUNGQR", " ", &nh, &nh, &nh, &c_n1);
+ lwkopt = max(1,nh) * nb;
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUNGHR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ work[1].r = 1.f, work[1].i = 0.f;
+ return 0;
+ }
+
+/* Shift the vectors which define the elementary reflectors one */
+/* column to the right, and set the first ilo and the last n-ihi */
+/* rows and columns to those of the unit matrix */
+
+ i__1 = *ilo + 1;
+ for (j = *ihi; j >= i__1; --j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L10: */
+ }
+ i__2 = *ihi;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + (j - 1) * a_dim1;
+ a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
+/* L20: */
+ }
+ i__2 = *n;
+ for (i__ = *ihi + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+ i__1 = *ilo;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L50: */
+ }
+ i__2 = j + j * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+/* L60: */
+ }
+ i__1 = *n;
+ for (j = *ihi + 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L70: */
+ }
+ i__2 = j + j * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+/* L80: */
+ }
+
+ if (nh > 0) {
+
+/* Generate Q(ilo+1:ihi,ilo+1:ihi) */
+
+ cungqr_(&nh, &nh, &nh, &a[*ilo + 1 + (*ilo + 1) * a_dim1], lda, &tau[*
+ ilo], &work[1], lwork, &iinfo);
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ return 0;
+
+/* End of CUNGHR */
+
+} /* cunghr_ */
diff --git a/SRC/cungl2.c b/SRC/cungl2.c
new file mode 100644
index 0000000..6a74939
--- /dev/null
+++ b/SRC/cungl2.c
@@ -0,0 +1,193 @@
+/* cungl2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cungl2_(integer *m, integer *n, integer *k, complex *a,
+ integer *lda, complex *tau, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, l;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *), clarf_(char *, integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, complex *),
+ clacgv_(integer *, complex *, integer *), xerbla_(char *, integer
+ *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNGL2 generates an m-by-n complex matrix Q with orthonormal rows, */
+/* which is defined as the first m rows of a product of k elementary */
+/* reflectors of order n */
+
+/* Q = H(k)' . . . H(2)' H(1)' */
+
+/* as returned by CGELQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. N >= M. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the i-th row must contain the vector which defines */
+/* the elementary reflector H(i), for i = 1,2,...,k, as returned */
+/* by CGELQF in the first k rows of its array argument A. */
+/* On exit, the m by n matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) COMPLEX array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CGELQF. */
+
+/* WORK (workspace) COMPLEX array, dimension (M) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *m) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUNGL2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0) {
+ return 0;
+ }
+
+ if (*k < *m) {
+
+/* Initialise rows k+1:m to rows of the unit matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (l = *k + 1; l <= i__2; ++l) {
+ i__3 = l + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L10: */
+ }
+ if (j > *k && j <= *m) {
+ i__2 = j + j * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+ }
+/* L20: */
+ }
+ }
+
+ for (i__ = *k; i__ >= 1; --i__) {
+
+/* Apply H(i)' to A(i:m,i:n) from the right */
+
+ if (i__ < *n) {
+ i__1 = *n - i__;
+ clacgv_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda);
+ if (i__ < *m) {
+ i__1 = i__ + i__ * a_dim1;
+ a[i__1].r = 1.f, a[i__1].i = 0.f;
+ i__1 = *m - i__;
+ i__2 = *n - i__ + 1;
+ r_cnjg(&q__1, &tau[i__]);
+ clarf_("Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &
+ q__1, &a[i__ + 1 + i__ * a_dim1], lda, &work[1]);
+ }
+ i__1 = *n - i__;
+ i__2 = i__;
+ q__1.r = -tau[i__2].r, q__1.i = -tau[i__2].i;
+ cscal_(&i__1, &q__1, &a[i__ + (i__ + 1) * a_dim1], lda);
+ i__1 = *n - i__;
+ clacgv_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda);
+ }
+ i__1 = i__ + i__ * a_dim1;
+ r_cnjg(&q__2, &tau[i__]);
+ q__1.r = 1.f - q__2.r, q__1.i = 0.f - q__2.i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+
+/* Set A(i,1:i-1,i) to zero */
+
+ i__1 = i__ - 1;
+ for (l = 1; l <= i__1; ++l) {
+ i__2 = i__ + l * a_dim1;
+ a[i__2].r = 0.f, a[i__2].i = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+ return 0;
+
+/* End of CUNGL2 */
+
+} /* cungl2_ */
diff --git a/SRC/cunglq.c b/SRC/cunglq.c
new file mode 100644
index 0000000..9165a47
--- /dev/null
+++ b/SRC/cunglq.c
@@ -0,0 +1,284 @@
+/* cunglq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int cunglq_(integer *m, integer *n, integer *k, complex *a,
+ integer *lda, complex *tau, complex *work, integer *lwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int cungl2_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *), clarfb_(
+ char *, char *, char *, char *, integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *), clarft_(
+ char *, char *, integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *), xerbla_(char *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNGLQ generates an M-by-N complex matrix Q with orthonormal rows, */
+/* which is defined as the first M rows of a product of K elementary */
+/* reflectors of order N */
+
+/* Q = H(k)' . . . H(2)' H(1)' */
+
+/* as returned by CGELQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. N >= M. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the i-th row must contain the vector which defines */
+/* the elementary reflector H(i), for i = 1,2,...,k, as returned */
+/* by CGELQF in the first k rows of its array argument A. */
+/* On exit, the M-by-N matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) COMPLEX array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CGELQF. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M). */
+/* For optimum performance LWORK >= M*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit; */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb = ilaenv_(&c__1, "CUNGLQ", " ", m, n, k, &c_n1);
+ lwkopt = max(1,*m) * nb;
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *m) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*lwork < max(1,*m) && ! lquery) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUNGLQ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0) {
+ work[1].r = 1.f, work[1].i = 0.f;
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *m;
+ if (nb > 1 && nb < *k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "CUNGLQ", " ", m, n, k, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *m;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "CUNGLQ", " ", m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < *k && nx < *k) {
+
+/* Use blocked code after the last block. */
+/* The first kk rows are handled by the block method. */
+
+ ki = (*k - nx - 1) / nb * nb;
+/* Computing MIN */
+ i__1 = *k, i__2 = ki + nb;
+ kk = min(i__1,i__2);
+
+/* Set A(kk+1:m,1:kk) to zero. */
+
+ i__1 = kk;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = kk + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ kk = 0;
+ }
+
+/* Use unblocked code for the last or only block. */
+
+ if (kk < *m) {
+ i__1 = *m - kk;
+ i__2 = *n - kk;
+ i__3 = *k - kk;
+ cungl2_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, &
+ tau[kk + 1], &work[1], &iinfo);
+ }
+
+ if (kk > 0) {
+
+/* Use blocked code */
+
+ i__1 = -nb;
+ for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) {
+/* Computing MIN */
+ i__2 = nb, i__3 = *k - i__ + 1;
+ ib = min(i__2,i__3);
+ if (i__ + ib <= *m) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__2 = *n - i__ + 1;
+ clarft_("Forward", "Rowwise", &i__2, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H' to A(i+ib:m,i:n) from the right */
+
+ i__2 = *m - i__ - ib + 1;
+ i__3 = *n - i__ + 1;
+ clarfb_("Right", "Conjugate transpose", "Forward", "Rowwise",
+ &i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[
+ 1], &ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[
+ ib + 1], &ldwork);
+ }
+
+/* Apply H' to columns i:n of current block */
+
+ i__2 = *n - i__ + 1;
+ cungl2_(&ib, &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
+ work[1], &iinfo);
+
+/* Set columns 1:i-1 of current block to zero */
+
+ i__2 = i__ - 1;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + ib - 1;
+ for (l = i__; l <= i__3; ++l) {
+ i__4 = l + j * a_dim1;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+ work[1].r = (real) iws, work[1].i = 0.f;
+ return 0;
+
+/* End of CUNGLQ */
+
+} /* cunglq_ */
diff --git a/SRC/cungql.c b/SRC/cungql.c
new file mode 100644
index 0000000..fc7f77d
--- /dev/null
+++ b/SRC/cungql.c
@@ -0,0 +1,293 @@
+/* cungql.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int cungql_(integer *m, integer *n, integer *k, complex *a,
+ integer *lda, complex *tau, complex *work, integer *lwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+
+ /* Local variables */
+ integer i__, j, l, ib, nb, kk, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int cung2l_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *), clarfb_(
+ char *, char *, char *, char *, integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *), clarft_(
+ char *, char *, integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *), xerbla_(char *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNGQL generates an M-by-N complex matrix Q with orthonormal columns, */
+/* which is defined as the last N columns of a product of K elementary */
+/* reflectors of order M */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by CGEQLF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the (n-k+i)-th column must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by CGEQLF in the last k columns of its array */
+/* argument A. */
+/* On exit, the M-by-N matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) COMPLEX array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CGEQLF. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* For optimum performance LWORK >= N*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+
+ if (*info == 0) {
+ if (*n == 0) {
+ lwkopt = 1;
+ } else {
+ nb = ilaenv_(&c__1, "CUNGQL", " ", m, n, k, &c_n1);
+ lwkopt = *n * nb;
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ if (*lwork < max(1,*n) && ! lquery) {
+ *info = -8;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUNGQL", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *n;
+ if (nb > 1 && nb < *k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "CUNGQL", " ", m, n, k, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *n;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "CUNGQL", " ", m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < *k && nx < *k) {
+
+/* Use blocked code after the first block. */
+/* The last kk columns are handled by the block method. */
+
+/* Computing MIN */
+ i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb;
+ kk = min(i__1,i__2);
+
+/* Set A(m-kk+1:m,1:n-kk) to zero. */
+
+ i__1 = *n - kk;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = *m - kk + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ kk = 0;
+ }
+
+/* Use unblocked code for the first or only block. */
+
+ i__1 = *m - kk;
+ i__2 = *n - kk;
+ i__3 = *k - kk;
+ cung2l_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &iinfo)
+ ;
+
+ if (kk > 0) {
+
+/* Use blocked code */
+
+ i__1 = *k;
+ i__2 = nb;
+ for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *k - i__ + 1;
+ ib = min(i__3,i__4);
+ if (*n - *k + i__ > 1) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__3 = *m - *k + i__ + ib - 1;
+ clarft_("Backward", "Columnwise", &i__3, &ib, &a[(*n - *k +
+ i__) * a_dim1 + 1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left */
+
+ i__3 = *m - *k + i__ + ib - 1;
+ i__4 = *n - *k + i__ - 1;
+ clarfb_("Left", "No transpose", "Backward", "Columnwise", &
+ i__3, &i__4, &ib, &a[(*n - *k + i__) * a_dim1 + 1],
+ lda, &work[1], &ldwork, &a[a_offset], lda, &work[ib +
+ 1], &ldwork);
+ }
+
+/* Apply H to rows 1:m-k+i+ib-1 of current block */
+
+ i__3 = *m - *k + i__ + ib - 1;
+ cung2l_(&i__3, &ib, &ib, &a[(*n - *k + i__) * a_dim1 + 1], lda, &
+ tau[i__], &work[1], &iinfo);
+
+/* Set rows m-k+i+ib:m of current block to zero */
+
+ i__3 = *n - *k + i__ + ib - 1;
+ for (j = *n - *k + i__; j <= i__3; ++j) {
+ i__4 = *m;
+ for (l = *m - *k + i__ + ib; l <= i__4; ++l) {
+ i__5 = l + j * a_dim1;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+ work[1].r = (real) iws, work[1].i = 0.f;
+ return 0;
+
+/* End of CUNGQL */
+
+} /* cungql_ */
diff --git a/SRC/cungqr.c b/SRC/cungqr.c
new file mode 100644
index 0000000..beb92b7
--- /dev/null
+++ b/SRC/cungqr.c
@@ -0,0 +1,285 @@
+/* cungqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int cungqr_(integer *m, integer *n, integer *k, complex *a,
+ integer *lda, complex *tau, complex *work, integer *lwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int cung2r_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *), clarfb_(
+ char *, char *, char *, char *, integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *), clarft_(
+ char *, char *, integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *), xerbla_(char *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNGQR generates an M-by-N complex matrix Q with orthonormal columns, */
+/* which is defined as the first N columns of a product of K elementary */
+/* reflectors of order M */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by CGEQRF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the i-th column must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by CGEQRF in the first k columns of its array */
+/* argument A. */
+/* On exit, the M-by-N matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) COMPLEX array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CGEQRF. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* For optimum performance LWORK >= N*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb = ilaenv_(&c__1, "CUNGQR", " ", m, n, k, &c_n1);
+ lwkopt = max(1,*n) * nb;
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUNGQR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ work[1].r = 1.f, work[1].i = 0.f;
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *n;
+ if (nb > 1 && nb < *k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "CUNGQR", " ", m, n, k, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *n;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "CUNGQR", " ", m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < *k && nx < *k) {
+
+/* Use blocked code after the last block. */
+/* The first kk columns are handled by the block method. */
+
+ ki = (*k - nx - 1) / nb * nb;
+/* Computing MIN */
+ i__1 = *k, i__2 = ki + nb;
+ kk = min(i__1,i__2);
+
+/* Set A(1:kk,kk+1:n) to zero. */
+
+ i__1 = *n;
+ for (j = kk + 1; j <= i__1; ++j) {
+ i__2 = kk;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ kk = 0;
+ }
+
+/* Use unblocked code for the last or only block. */
+
+ if (kk < *n) {
+ i__1 = *m - kk;
+ i__2 = *n - kk;
+ i__3 = *k - kk;
+ cung2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, &
+ tau[kk + 1], &work[1], &iinfo);
+ }
+
+ if (kk > 0) {
+
+/* Use blocked code */
+
+ i__1 = -nb;
+ for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) {
+/* Computing MIN */
+ i__2 = nb, i__3 = *k - i__ + 1;
+ ib = min(i__2,i__3);
+ if (i__ + ib <= *n) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__2 = *m - i__ + 1;
+ clarft_("Forward", "Columnwise", &i__2, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H to A(i:m,i+ib:n) from the left */
+
+ i__2 = *m - i__ + 1;
+ i__3 = *n - i__ - ib + 1;
+ clarfb_("Left", "No transpose", "Forward", "Columnwise", &
+ i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[
+ 1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &
+ work[ib + 1], &ldwork);
+ }
+
+/* Apply H to rows i:m of current block */
+
+ i__2 = *m - i__ + 1;
+ cung2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
+ work[1], &iinfo);
+
+/* Set rows 1:i-1 of current block to zero */
+
+ i__2 = i__ + ib - 1;
+ for (j = i__; j <= i__2; ++j) {
+ i__3 = i__ - 1;
+ for (l = 1; l <= i__3; ++l) {
+ i__4 = l + j * a_dim1;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+ work[1].r = (real) iws, work[1].i = 0.f;
+ return 0;
+
+/* End of CUNGQR */
+
+} /* cungqr_ */
diff --git a/SRC/cungr2.c b/SRC/cungr2.c
new file mode 100644
index 0000000..5a9c5f3
--- /dev/null
+++ b/SRC/cungr2.c
@@ -0,0 +1,192 @@
+/* cungr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cungr2_(integer *m, integer *n, integer *k, complex *a,
+ integer *lda, complex *tau, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, l, ii;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *), clarf_(char *, integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, complex *),
+ clacgv_(integer *, complex *, integer *), xerbla_(char *, integer
+ *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNGR2 generates an m by n complex matrix Q with orthonormal rows, */
+/* which is defined as the last m rows of a product of k elementary */
+/* reflectors of order n */
+
+/* Q = H(1)' H(2)' . . . H(k)' */
+
+/* as returned by CGERQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. N >= M. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the (m-k+i)-th row must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by CGERQF in the last k rows of its array argument */
+/* A. */
+/* On exit, the m-by-n matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) COMPLEX array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CGERQF. */
+
+/* WORK (workspace) COMPLEX array, dimension (M) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *m) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUNGR2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0) {
+ return 0;
+ }
+
+ if (*k < *m) {
+
+/* Initialise rows 1:m-k to rows of the unit matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m - *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = l + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L10: */
+ }
+ if (j > *n - *m && j <= *n - *k) {
+ i__2 = *m - *n + j + j * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+ }
+/* L20: */
+ }
+ }
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ii = *m - *k + i__;
+
+/* Apply H(i)' to A(1:m-k+i,1:n-k+i) from the right */
+
+ i__2 = *n - *m + ii - 1;
+ clacgv_(&i__2, &a[ii + a_dim1], lda);
+ i__2 = ii + (*n - *m + ii) * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+ i__2 = ii - 1;
+ i__3 = *n - *m + ii;
+ r_cnjg(&q__1, &tau[i__]);
+ clarf_("Right", &i__2, &i__3, &a[ii + a_dim1], lda, &q__1, &a[
+ a_offset], lda, &work[1]);
+ i__2 = *n - *m + ii - 1;
+ i__3 = i__;
+ q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i;
+ cscal_(&i__2, &q__1, &a[ii + a_dim1], lda);
+ i__2 = *n - *m + ii - 1;
+ clacgv_(&i__2, &a[ii + a_dim1], lda);
+ i__2 = ii + (*n - *m + ii) * a_dim1;
+ r_cnjg(&q__2, &tau[i__]);
+ q__1.r = 1.f - q__2.r, q__1.i = 0.f - q__2.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+
+/* Set A(m-k+i,n-k+i+1:n) to zero */
+
+ i__2 = *n;
+ for (l = *n - *m + ii + 1; l <= i__2; ++l) {
+ i__3 = ii + l * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+ return 0;
+
+/* End of CUNGR2 */
+
+} /* cungr2_ */
diff --git a/SRC/cungrq.c b/SRC/cungrq.c
new file mode 100644
index 0000000..5eeb910
--- /dev/null
+++ b/SRC/cungrq.c
@@ -0,0 +1,293 @@
+/* cungrq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int cungrq_(integer *m, integer *n, integer *k, complex *a,
+ integer *lda, complex *tau, complex *work, integer *lwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+
+ /* Local variables */
+ integer i__, j, l, ib, nb, ii, kk, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int cungr2_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *), clarfb_(
+ char *, char *, char *, char *, integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *), clarft_(
+ char *, char *, integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *), xerbla_(char *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNGRQ generates an M-by-N complex matrix Q with orthonormal rows, */
+/* which is defined as the last M rows of a product of K elementary */
+/* reflectors of order N */
+
+/* Q = H(1)' H(2)' . . . H(k)' */
+
+/* as returned by CGERQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. N >= M. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the (m-k+i)-th row must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by CGERQF in the last k rows of its array argument */
+/* A. */
+/* On exit, the M-by-N matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) COMPLEX array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CGERQF. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M). */
+/* For optimum performance LWORK >= M*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *m) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+
+ if (*info == 0) {
+ if (*m <= 0) {
+ lwkopt = 1;
+ } else {
+ nb = ilaenv_(&c__1, "CUNGRQ", " ", m, n, k, &c_n1);
+ lwkopt = *m * nb;
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ if (*lwork < max(1,*m) && ! lquery) {
+ *info = -8;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUNGRQ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *m;
+ if (nb > 1 && nb < *k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "CUNGRQ", " ", m, n, k, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *m;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "CUNGRQ", " ", m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < *k && nx < *k) {
+
+/* Use blocked code after the first block. */
+/* The last kk rows are handled by the block method. */
+
+/* Computing MIN */
+ i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb;
+ kk = min(i__1,i__2);
+
+/* Set A(1:m-kk,n-kk+1:n) to zero. */
+
+ i__1 = *n;
+ for (j = *n - kk + 1; j <= i__1; ++j) {
+ i__2 = *m - kk;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ kk = 0;
+ }
+
+/* Use unblocked code for the first or only block. */
+
+ i__1 = *m - kk;
+ i__2 = *n - kk;
+ i__3 = *k - kk;
+ cungr2_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &iinfo)
+ ;
+
+ if (kk > 0) {
+
+/* Use blocked code */
+
+ i__1 = *k;
+ i__2 = nb;
+ for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *k - i__ + 1;
+ ib = min(i__3,i__4);
+ ii = *m - *k + i__;
+ if (ii > 1) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__3 = *n - *k + i__ + ib - 1;
+ clarft_("Backward", "Rowwise", &i__3, &ib, &a[ii + a_dim1],
+ lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H' to A(1:m-k+i-1,1:n-k+i+ib-1) from the right */
+
+ i__3 = ii - 1;
+ i__4 = *n - *k + i__ + ib - 1;
+ clarfb_("Right", "Conjugate transpose", "Backward", "Rowwise",
+ &i__3, &i__4, &ib, &a[ii + a_dim1], lda, &work[1], &
+ ldwork, &a[a_offset], lda, &work[ib + 1], &ldwork);
+ }
+
+/* Apply H' to columns 1:n-k+i+ib-1 of current block */
+
+ i__3 = *n - *k + i__ + ib - 1;
+ cungr2_(&ib, &i__3, &ib, &a[ii + a_dim1], lda, &tau[i__], &work[1]
+, &iinfo);
+
+/* Set columns n-k+i+ib:n of current block to zero */
+
+ i__3 = *n;
+ for (l = *n - *k + i__ + ib; l <= i__3; ++l) {
+ i__4 = ii + ib - 1;
+ for (j = ii; j <= i__4; ++j) {
+ i__5 = j + l * a_dim1;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+ work[1].r = (real) iws, work[1].i = 0.f;
+ return 0;
+
+/* End of CUNGRQ */
+
+} /* cungrq_ */
diff --git a/SRC/cungtr.c b/SRC/cungtr.c
new file mode 100644
index 0000000..58997f7
--- /dev/null
+++ b/SRC/cungtr.c
@@ -0,0 +1,260 @@
+/* cungtr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cungtr_(char *uplo, integer *n, complex *a, integer *lda,
+ complex *tau, complex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, nb;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int cungql_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *),
+ cungqr_(integer *, integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNGTR generates a complex unitary matrix Q which is defined as the */
+/* product of n-1 elementary reflectors of order N, as returned by */
+/* CHETRD: */
+
+/* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), */
+
+/* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A contains elementary reflectors */
+/* from CHETRD; */
+/* = 'L': Lower triangle of A contains elementary reflectors */
+/* from CHETRD. */
+
+/* N (input) INTEGER */
+/* The order of the matrix Q. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the vectors which define the elementary reflectors, */
+/* as returned by CHETRD. */
+/* On exit, the N-by-N unitary matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= N. */
+
+/* TAU (input) COMPLEX array, dimension (N-1) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CHETRD. */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= N-1. */
+/* For optimum performance LWORK >= (N-1)*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n - 1;
+ if (*lwork < max(i__1,i__2) && ! lquery) {
+ *info = -7;
+ }
+ }
+
+ if (*info == 0) {
+ if (upper) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ nb = ilaenv_(&c__1, "CUNGQL", " ", &i__1, &i__2, &i__3, &c_n1);
+ } else {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ nb = ilaenv_(&c__1, "CUNGQR", " ", &i__1, &i__2, &i__3, &c_n1);
+ }
+/* Computing MAX */
+ i__1 = 1, i__2 = *n - 1;
+ lwkopt = max(i__1,i__2) * nb;
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUNGTR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ work[1].r = 1.f, work[1].i = 0.f;
+ return 0;
+ }
+
+ if (upper) {
+
+/* Q was determined by a call to CHETRD with UPLO = 'U' */
+
+/* Shift the vectors which define the elementary reflectors one */
+/* column to the left, and set the last row and column of Q to */
+/* those of the unit matrix */
+
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + (j + 1) * a_dim1;
+ a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
+/* L10: */
+ }
+ i__2 = *n + j * a_dim1;
+ a[i__2].r = 0.f, a[i__2].i = 0.f;
+/* L20: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + *n * a_dim1;
+ a[i__2].r = 0.f, a[i__2].i = 0.f;
+/* L30: */
+ }
+ i__1 = *n + *n * a_dim1;
+ a[i__1].r = 1.f, a[i__1].i = 0.f;
+
+/* Generate Q(1:n-1,1:n-1) */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ cungql_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1],
+ lwork, &iinfo);
+
+ } else {
+
+/* Q was determined by a call to CHETRD with UPLO = 'L'. */
+
+/* Shift the vectors which define the elementary reflectors one */
+/* column to the right, and set the first row and column of Q to */
+/* those of the unit matrix */
+
+ for (j = *n; j >= 2; --j) {
+ i__1 = j * a_dim1 + 1;
+ a[i__1].r = 0.f, a[i__1].i = 0.f;
+ i__1 = *n;
+ for (i__ = j + 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * a_dim1;
+ i__3 = i__ + (j - 1) * a_dim1;
+ a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
+/* L40: */
+ }
+/* L50: */
+ }
+ i__1 = a_dim1 + 1;
+ a[i__1].r = 1.f, a[i__1].i = 0.f;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__ + a_dim1;
+ a[i__2].r = 0.f, a[i__2].i = 0.f;
+/* L60: */
+ }
+ if (*n > 1) {
+
+/* Generate Q(2:n,2:n) */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ cungqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[1],
+ &work[1], lwork, &iinfo);
+ }
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ return 0;
+
+/* End of CUNGTR */
+
+} /* cungtr_ */
diff --git a/SRC/cunm2l.c b/SRC/cunm2l.c
new file mode 100644
index 0000000..c553f8f
--- /dev/null
+++ b/SRC/cunm2l.c
@@ -0,0 +1,245 @@
+/* cunm2l.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cunm2l_(char *side, char *trans, integer *m, integer *n,
+ integer *k, complex *a, integer *lda, complex *tau, complex *c__,
+ integer *ldc, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
+ complex q__1;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, i1, i2, i3, mi, ni, nq;
+ complex aii;
+ logical left;
+ complex taui;
+ extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
+, integer *, complex *, complex *, integer *, complex *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNM2L overwrites the general complex m-by-n matrix C with */
+
+/* Q * C if SIDE = 'L' and TRANS = 'N', or */
+
+/* Q'* C if SIDE = 'L' and TRANS = 'C', or */
+
+/* C * Q if SIDE = 'R' and TRANS = 'N', or */
+
+/* C * Q' if SIDE = 'R' and TRANS = 'C', */
+
+/* where Q is a complex unitary matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by CGEQLF. Q is of order m if SIDE = 'L' and of order n */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q' from the Left */
+/* = 'R': apply Q or Q' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply Q (No transpose) */
+/* = 'C': apply Q' (Conjugate transpose) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,K) */
+/* The i-th column must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* CGEQLF in the last k columns of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If SIDE = 'L', LDA >= max(1,M); */
+/* if SIDE = 'R', LDA >= max(1,N). */
+
+/* TAU (input) COMPLEX array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CGEQLF. */
+
+/* C (input/output) COMPLEX array, dimension (LDC,N) */
+/* On entry, the m-by-n matrix C. */
+/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (N) if SIDE = 'L', */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,nq)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUNM2L", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ return 0;
+ }
+
+ if (left && notran || ! left && ! notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = 1;
+ } else {
+ i1 = *k;
+ i2 = 1;
+ i3 = -1;
+ }
+
+ if (left) {
+ ni = *n;
+ } else {
+ mi = *m;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) or H(i)' is applied to C(1:m-k+i,1:n) */
+
+ mi = *m - *k + i__;
+ } else {
+
+/* H(i) or H(i)' is applied to C(1:m,1:n-k+i) */
+
+ ni = *n - *k + i__;
+ }
+
+/* Apply H(i) or H(i)' */
+
+ if (notran) {
+ i__3 = i__;
+ taui.r = tau[i__3].r, taui.i = tau[i__3].i;
+ } else {
+ r_cnjg(&q__1, &tau[i__]);
+ taui.r = q__1.r, taui.i = q__1.i;
+ }
+ i__3 = nq - *k + i__ + i__ * a_dim1;
+ aii.r = a[i__3].r, aii.i = a[i__3].i;
+ i__3 = nq - *k + i__ + i__ * a_dim1;
+ a[i__3].r = 1.f, a[i__3].i = 0.f;
+ clarf_(side, &mi, &ni, &a[i__ * a_dim1 + 1], &c__1, &taui, &c__[
+ c_offset], ldc, &work[1]);
+ i__3 = nq - *k + i__ + i__ * a_dim1;
+ a[i__3].r = aii.r, a[i__3].i = aii.i;
+/* L10: */
+ }
+ return 0;
+
+/* End of CUNM2L */
+
+} /* cunm2l_ */
diff --git a/SRC/cunm2r.c b/SRC/cunm2r.c
new file mode 100644
index 0000000..58c69ad
--- /dev/null
+++ b/SRC/cunm2r.c
@@ -0,0 +1,249 @@
+/* cunm2r.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cunm2r_(char *side, char *trans, integer *m, integer *n,
+ integer *k, complex *a, integer *lda, complex *tau, complex *c__,
+ integer *ldc, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
+ complex q__1;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, i1, i2, i3, ic, jc, mi, ni, nq;
+ complex aii;
+ logical left;
+ complex taui;
+ extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
+, integer *, complex *, complex *, integer *, complex *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNM2R overwrites the general complex m-by-n matrix C with */
+
+/* Q * C if SIDE = 'L' and TRANS = 'N', or */
+
+/* Q'* C if SIDE = 'L' and TRANS = 'C', or */
+
+/* C * Q if SIDE = 'R' and TRANS = 'N', or */
+
+/* C * Q' if SIDE = 'R' and TRANS = 'C', */
+
+/* where Q is a complex unitary matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by CGEQRF. Q is of order m if SIDE = 'L' and of order n */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q' from the Left */
+/* = 'R': apply Q or Q' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply Q (No transpose) */
+/* = 'C': apply Q' (Conjugate transpose) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,K) */
+/* The i-th column must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* CGEQRF in the first k columns of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If SIDE = 'L', LDA >= max(1,M); */
+/* if SIDE = 'R', LDA >= max(1,N). */
+
+/* TAU (input) COMPLEX array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CGEQRF. */
+
+/* C (input/output) COMPLEX array, dimension (LDC,N) */
+/* On entry, the m-by-n matrix C. */
+/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (N) if SIDE = 'L', */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,nq)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUNM2R", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ return 0;
+ }
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = 1;
+ } else {
+ i1 = *k;
+ i2 = 1;
+ i3 = -1;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) or H(i)' is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H(i) or H(i)' is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H(i) or H(i)' */
+
+ if (notran) {
+ i__3 = i__;
+ taui.r = tau[i__3].r, taui.i = tau[i__3].i;
+ } else {
+ r_cnjg(&q__1, &tau[i__]);
+ taui.r = q__1.r, taui.i = q__1.i;
+ }
+ i__3 = i__ + i__ * a_dim1;
+ aii.r = a[i__3].r, aii.i = a[i__3].i;
+ i__3 = i__ + i__ * a_dim1;
+ a[i__3].r = 1.f, a[i__3].i = 0.f;
+ clarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &taui, &c__[ic
+ + jc * c_dim1], ldc, &work[1]);
+ i__3 = i__ + i__ * a_dim1;
+ a[i__3].r = aii.r, a[i__3].i = aii.i;
+/* L10: */
+ }
+ return 0;
+
+/* End of CUNM2R */
+
+} /* cunm2r_ */
diff --git a/SRC/cunmbr.c b/SRC/cunmbr.c
new file mode 100644
index 0000000..ccf73e4
--- /dev/null
+++ b/SRC/cunmbr.c
@@ -0,0 +1,373 @@
+/* cunmbr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int cunmbr_(char *vect, char *side, char *trans, integer *m,
+ integer *n, integer *k, complex *a, integer *lda, complex *tau,
+ complex *c__, integer *ldc, complex *work, integer *lwork, integer *
+ info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i1, i2, nb, mi, ni, nq, nw;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int cunmlq_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *);
+ logical notran;
+ extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *);
+ logical applyq;
+ char transt[1];
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* If VECT = 'Q', CUNMBR overwrites the general complex M-by-N matrix C */
+/* with */
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'C': Q**H * C C * Q**H */
+
+/* If VECT = 'P', CUNMBR overwrites the general complex M-by-N matrix C */
+/* with */
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': P * C C * P */
+/* TRANS = 'C': P**H * C C * P**H */
+
+/* Here Q and P**H are the unitary matrices determined by CGEBRD when */
+/* reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q */
+/* and P**H are defined as products of elementary reflectors H(i) and */
+/* G(i) respectively. */
+
+/* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the */
+/* order of the unitary matrix Q or P**H that is applied. */
+
+/* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: */
+/* if nq >= k, Q = H(1) H(2) . . . H(k); */
+/* if nq < k, Q = H(1) H(2) . . . H(nq-1). */
+
+/* If VECT = 'P', A is assumed to have been a K-by-NQ matrix: */
+/* if k < nq, P = G(1) G(2) . . . G(k); */
+/* if k >= nq, P = G(1) G(2) . . . G(nq-1). */
+
+/* Arguments */
+/* ========= */
+
+/* VECT (input) CHARACTER*1 */
+/* = 'Q': apply Q or Q**H; */
+/* = 'P': apply P or P**H. */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q, Q**H, P or P**H from the Left; */
+/* = 'R': apply Q, Q**H, P or P**H from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q or P; */
+/* = 'C': Conjugate transpose, apply Q**H or P**H. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* If VECT = 'Q', the number of columns in the original */
+/* matrix reduced by CGEBRD. */
+/* If VECT = 'P', the number of rows in the original */
+/* matrix reduced by CGEBRD. */
+/* K >= 0. */
+
+/* A (input) COMPLEX array, dimension */
+/* (LDA,min(nq,K)) if VECT = 'Q' */
+/* (LDA,nq) if VECT = 'P' */
+/* The vectors which define the elementary reflectors H(i) and */
+/* G(i), whose products determine the matrices Q and P, as */
+/* returned by CGEBRD. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If VECT = 'Q', LDA >= max(1,nq); */
+/* if VECT = 'P', LDA >= max(1,min(nq,K)). */
+
+/* TAU (input) COMPLEX array, dimension (min(nq,K)) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i) or G(i) which determines Q or P, as returned */
+/* by CGEBRD in the array argument TAUQ or TAUP. */
+
+/* C (input/output) COMPLEX array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q */
+/* or P*C or P**H*C or C*P or C*P**H. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M); */
+/* if N = 0 or M = 0, LWORK >= 1. */
+/* For optimum performance LWORK >= max(1,N*NB) if SIDE = 'L', */
+/* and LWORK >= max(1,M*NB) if SIDE = 'R', where NB is the */
+/* optimal blocksize. (NB = 0 if M = 0 or N = 0.) */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ applyq = lsame_(vect, "Q");
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q or P and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = *n;
+ } else {
+ nq = *n;
+ nw = *m;
+ }
+ if (*m == 0 || *n == 0) {
+ nw = 0;
+ }
+ if (! applyq && ! lsame_(vect, "P")) {
+ *info = -1;
+ } else if (! left && ! lsame_(side, "R")) {
+ *info = -2;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*k < 0) {
+ *info = -6;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = 1, i__2 = min(nq,*k);
+ if (applyq && *lda < max(1,nq) || ! applyq && *lda < max(i__1,i__2)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -11;
+ } else if (*lwork < max(1,nw) && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info == 0) {
+ if (nw > 0) {
+ if (applyq) {
+ if (left) {
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ nb = ilaenv_(&c__1, "CUNMQR", ch__1, &i__1, n, &i__2, &
+ c_n1);
+ } else {
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ nb = ilaenv_(&c__1, "CUNMQR", ch__1, m, &i__1, &i__2, &
+ c_n1);
+ }
+ } else {
+ if (left) {
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ nb = ilaenv_(&c__1, "CUNMLQ", ch__1, &i__1, n, &i__2, &
+ c_n1);
+ } else {
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ nb = ilaenv_(&c__1, "CUNMLQ", ch__1, m, &i__1, &i__2, &
+ c_n1);
+ }
+ }
+/* Computing MAX */
+ i__1 = 1, i__2 = nw * nb;
+ lwkopt = max(i__1,i__2);
+ } else {
+ lwkopt = 1;
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUNMBR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ if (applyq) {
+
+/* Apply Q */
+
+ if (nq >= *k) {
+
+/* Q was determined by a call to CGEBRD with nq >= k */
+
+ cunmqr_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], lwork, &iinfo);
+ } else if (nq > 1) {
+
+/* Q was determined by a call to CGEBRD with nq < k */
+
+ if (left) {
+ mi = *m - 1;
+ ni = *n;
+ i1 = 2;
+ i2 = 1;
+ } else {
+ mi = *m;
+ ni = *n - 1;
+ i1 = 1;
+ i2 = 2;
+ }
+ i__1 = nq - 1;
+ cunmqr_(side, trans, &mi, &ni, &i__1, &a[a_dim1 + 2], lda, &tau[1]
+, &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo);
+ }
+ } else {
+
+/* Apply P */
+
+ if (notran) {
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+ if (nq > *k) {
+
+/* P was determined by a call to CGEBRD with nq > k */
+
+ cunmlq_(side, transt, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], lwork, &iinfo);
+ } else if (nq > 1) {
+
+/* P was determined by a call to CGEBRD with nq <= k */
+
+ if (left) {
+ mi = *m - 1;
+ ni = *n;
+ i1 = 2;
+ i2 = 1;
+ } else {
+ mi = *m;
+ ni = *n - 1;
+ i1 = 1;
+ i2 = 2;
+ }
+ i__1 = nq - 1;
+ cunmlq_(side, transt, &mi, &ni, &i__1, &a[(a_dim1 << 1) + 1], lda,
+ &tau[1], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &
+ iinfo);
+ }
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ return 0;
+
+/* End of CUNMBR */
+
+} /* cunmbr_ */
diff --git a/SRC/cunmhr.c b/SRC/cunmhr.c
new file mode 100644
index 0000000..687085a
--- /dev/null
+++ b/SRC/cunmhr.c
@@ -0,0 +1,257 @@
+/* cunmhr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int cunmhr_(char *side, char *trans, integer *m, integer *n,
+ integer *ilo, integer *ihi, complex *a, integer *lda, complex *tau,
+ complex *c__, integer *ldc, complex *work, integer *lwork, integer *
+ info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i1, i2, nb, mi, nh, ni, nq, nw;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNMHR overwrites the general complex M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'C': Q**H * C C * Q**H */
+
+/* where Q is a complex unitary matrix of order nq, with nq = m if */
+/* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */
+/* IHI-ILO elementary reflectors, as returned by CGEHRD: */
+
+/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**H from the Left; */
+/* = 'R': apply Q or Q**H from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply Q (No transpose) */
+/* = 'C': apply Q**H (Conjugate transpose) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* ILO and IHI must have the same values as in the previous call */
+/* of CGEHRD. Q is equal to the unit matrix except in the */
+/* submatrix Q(ilo+1:ihi,ilo+1:ihi). */
+/* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and */
+/* ILO = 1 and IHI = 0, if M = 0; */
+/* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and */
+/* ILO = 1 and IHI = 0, if N = 0. */
+
+/* A (input) COMPLEX array, dimension */
+/* (LDA,M) if SIDE = 'L' */
+/* (LDA,N) if SIDE = 'R' */
+/* The vectors which define the elementary reflectors, as */
+/* returned by CGEHRD. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. */
+
+/* TAU (input) COMPLEX array, dimension */
+/* (M-1) if SIDE = 'L' */
+/* (N-1) if SIDE = 'R' */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CGEHRD. */
+
+/* C (input/output) COMPLEX array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nh = *ihi - *ilo;
+ left = lsame_(side, "L");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = *n;
+ } else {
+ nq = *n;
+ nw = *m;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "C")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ilo < 1 || *ilo > max(1,nq)) {
+ *info = -5;
+ } else if (*ihi < min(*ilo,nq) || *ihi > nq) {
+ *info = -6;
+ } else if (*lda < max(1,nq)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -11;
+ } else if (*lwork < max(1,nw) && ! lquery) {
+ *info = -13;
+ }
+
+ if (*info == 0) {
+ if (left) {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ nb = ilaenv_(&c__1, "CUNMQR", ch__1, &nh, n, &nh, &c_n1);
+ } else {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ nb = ilaenv_(&c__1, "CUNMQR", ch__1, m, &nh, &nh, &c_n1);
+ }
+ lwkopt = max(1,nw) * nb;
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ }
+
+ if (*info != 0) {
+ i__2 = -(*info);
+ xerbla_("CUNMHR", &i__2);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || nh == 0) {
+ work[1].r = 1.f, work[1].i = 0.f;
+ return 0;
+ }
+
+ if (left) {
+ mi = nh;
+ ni = *n;
+ i1 = *ilo + 1;
+ i2 = 1;
+ } else {
+ mi = *m;
+ ni = nh;
+ i1 = 1;
+ i2 = *ilo + 1;
+ }
+
+ cunmqr_(side, trans, &mi, &ni, &nh, &a[*ilo + 1 + *ilo * a_dim1], lda, &
+ tau[*ilo], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo);
+
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ return 0;
+
+/* End of CUNMHR */
+
+} /* cunmhr_ */
diff --git a/SRC/cunml2.c b/SRC/cunml2.c
new file mode 100644
index 0000000..21b050e
--- /dev/null
+++ b/SRC/cunml2.c
@@ -0,0 +1,254 @@
+/* cunml2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cunml2_(char *side, char *trans, integer *m, integer *n,
+ integer *k, complex *a, integer *lda, complex *tau, complex *c__,
+ integer *ldc, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
+ complex q__1;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, i1, i2, i3, ic, jc, mi, ni, nq;
+ complex aii;
+ logical left;
+ complex taui;
+ extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
+, integer *, complex *, complex *, integer *, complex *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
+ xerbla_(char *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNML2 overwrites the general complex m-by-n matrix C with */
+
+/* Q * C if SIDE = 'L' and TRANS = 'N', or */
+
+/* Q'* C if SIDE = 'L' and TRANS = 'C', or */
+
+/* C * Q if SIDE = 'R' and TRANS = 'N', or */
+
+/* C * Q' if SIDE = 'R' and TRANS = 'C', */
+
+/* where Q is a complex unitary matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(k)' . . . H(2)' H(1)' */
+
+/* as returned by CGELQF. Q is of order m if SIDE = 'L' and of order n */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q' from the Left */
+/* = 'R': apply Q or Q' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply Q (No transpose) */
+/* = 'C': apply Q' (Conjugate transpose) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) COMPLEX array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* CGELQF in the first k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) COMPLEX array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CGELQF. */
+
+/* C (input/output) COMPLEX array, dimension (LDC,N) */
+/* On entry, the m-by-n matrix C. */
+/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (N) if SIDE = 'L', */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,*k)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUNML2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ return 0;
+ }
+
+ if (left && notran || ! left && ! notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = 1;
+ } else {
+ i1 = *k;
+ i2 = 1;
+ i3 = -1;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) or H(i)' is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H(i) or H(i)' is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H(i) or H(i)' */
+
+ if (notran) {
+ r_cnjg(&q__1, &tau[i__]);
+ taui.r = q__1.r, taui.i = q__1.i;
+ } else {
+ i__3 = i__;
+ taui.r = tau[i__3].r, taui.i = tau[i__3].i;
+ }
+ if (i__ < nq) {
+ i__3 = nq - i__;
+ clacgv_(&i__3, &a[i__ + (i__ + 1) * a_dim1], lda);
+ }
+ i__3 = i__ + i__ * a_dim1;
+ aii.r = a[i__3].r, aii.i = a[i__3].i;
+ i__3 = i__ + i__ * a_dim1;
+ a[i__3].r = 1.f, a[i__3].i = 0.f;
+ clarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &taui, &c__[ic +
+ jc * c_dim1], ldc, &work[1]);
+ i__3 = i__ + i__ * a_dim1;
+ a[i__3].r = aii.r, a[i__3].i = aii.i;
+ if (i__ < nq) {
+ i__3 = nq - i__;
+ clacgv_(&i__3, &a[i__ + (i__ + 1) * a_dim1], lda);
+ }
+/* L10: */
+ }
+ return 0;
+
+/* End of CUNML2 */
+
+} /* cunml2_ */
diff --git a/SRC/cunmlq.c b/SRC/cunmlq.c
new file mode 100644
index 0000000..d7aa7a4
--- /dev/null
+++ b/SRC/cunmlq.c
@@ -0,0 +1,335 @@
+/* cunmlq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int cunmlq_(char *side, char *trans, integer *m, integer *n,
+ integer *k, complex *a, integer *lda, complex *tau, complex *c__,
+ integer *ldc, complex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
+ i__5;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ complex t[4160] /* was [65][64] */;
+ integer i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iws;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int cunml2_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *), clarfb_(char *, char *,
+ char *, char *, integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *), clarft_(char *, char *
+, integer *, integer *, complex *, integer *, complex *, complex *
+, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical notran;
+ integer ldwork;
+ char transt[1];
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNMLQ overwrites the general complex M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'C': Q**H * C C * Q**H */
+
+/* where Q is a complex unitary matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(k)' . . . H(2)' H(1)' */
+
+/* as returned by CGELQF. Q is of order M if SIDE = 'L' and of order N */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**H from the Left; */
+/* = 'R': apply Q or Q**H from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'C': Conjugate transpose, apply Q**H. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) COMPLEX array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* CGELQF in the first k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) COMPLEX array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CGELQF. */
+
+/* C (input/output) COMPLEX array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = *n;
+ } else {
+ nq = *n;
+ nw = *m;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,*k)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ } else if (*lwork < max(1,nw) && ! lquery) {
+ *info = -12;
+ }
+
+ if (*info == 0) {
+
+/* Determine the block size. NB may be at most NBMAX, where NBMAX */
+/* is used to define the local array T. */
+
+/* Computing MIN */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 64, i__2 = ilaenv_(&c__1, "CUNMLQ", ch__1, m, n, k, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = max(1,nw) * nb;
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUNMLQ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ work[1].r = 1.f, work[1].i = 0.f;
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = nw;
+ if (nb > 1 && nb < *k) {
+ iws = nw * nb;
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 2, i__2 = ilaenv_(&c__2, "CUNMLQ", ch__1, m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = nw;
+ }
+
+ if (nb < nbmin || nb >= *k) {
+
+/* Use unblocked code */
+
+ cunml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], &iinfo);
+ } else {
+
+/* Use blocked code */
+
+ if (left && notran || ! left && ! notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = nb;
+ } else {
+ i1 = (*k - 1) / nb * nb + 1;
+ i2 = 1;
+ i3 = -nb;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ }
+
+ if (notran) {
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *k - i__ + 1;
+ ib = min(i__4,i__5);
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__4 = nq - i__ + 1;
+ clarft_("Forward", "Rowwise", &i__4, &ib, &a[i__ + i__ * a_dim1],
+ lda, &tau[i__], t, &c__65);
+ if (left) {
+
+/* H or H' is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H or H' is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H or H' */
+
+ clarfb_(side, transt, "Forward", "Rowwise", &mi, &ni, &ib, &a[i__
+ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1],
+ ldc, &work[1], &ldwork);
+/* L10: */
+ }
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ return 0;
+
+/* End of CUNMLQ */
+
+} /* cunmlq_ */
diff --git a/SRC/cunmql.c b/SRC/cunmql.c
new file mode 100644
index 0000000..cdd02a3
--- /dev/null
+++ b/SRC/cunmql.c
@@ -0,0 +1,328 @@
+/* cunmql.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int cunmql_(char *side, char *trans, integer *m, integer *n,
+ integer *k, complex *a, integer *lda, complex *tau, complex *c__,
+ integer *ldc, complex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
+ i__5;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ complex t[4160] /* was [65][64] */;
+ integer i1, i2, i3, ib, nb, mi, ni, nq, nw, iws;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int cunm2l_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *), clarfb_(char *, char *,
+ char *, char *, integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *), clarft_(char *, char *
+, integer *, integer *, complex *, integer *, complex *, complex *
+, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical notran;
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNMQL overwrites the general complex M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'C': Q**H * C C * Q**H */
+
+/* where Q is a complex unitary matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by CGEQLF. Q is of order M if SIDE = 'L' and of order N */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**H from the Left; */
+/* = 'R': apply Q or Q**H from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'C': Transpose, apply Q**H. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,K) */
+/* The i-th column must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* CGEQLF in the last k columns of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If SIDE = 'L', LDA >= max(1,M); */
+/* if SIDE = 'R', LDA >= max(1,N). */
+
+/* TAU (input) COMPLEX array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CGEQLF. */
+
+/* C (input/output) COMPLEX array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = max(1,*n);
+ } else {
+ nq = *n;
+ nw = max(1,*m);
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,nq)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+
+ if (*info == 0) {
+ if (*m == 0 || *n == 0) {
+ lwkopt = 1;
+ } else {
+
+/* Determine the block size. NB may be at most NBMAX, where */
+/* NBMAX is used to define the local array T. */
+
+/* Computing MIN */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 64, i__2 = ilaenv_(&c__1, "CUNMQL", ch__1, m, n, k, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = nw * nb;
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ if (*lwork < nw && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUNMQL", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = nw;
+ if (nb > 1 && nb < *k) {
+ iws = nw * nb;
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 2, i__2 = ilaenv_(&c__2, "CUNMQL", ch__1, m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = nw;
+ }
+
+ if (nb < nbmin || nb >= *k) {
+
+/* Use unblocked code */
+
+ cunm2l_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], &iinfo);
+ } else {
+
+/* Use blocked code */
+
+ if (left && notran || ! left && ! notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = nb;
+ } else {
+ i1 = (*k - 1) / nb * nb + 1;
+ i2 = 1;
+ i3 = -nb;
+ }
+
+ if (left) {
+ ni = *n;
+ } else {
+ mi = *m;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *k - i__ + 1;
+ ib = min(i__4,i__5);
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__4 = nq - *k + i__ + ib - 1;
+ clarft_("Backward", "Columnwise", &i__4, &ib, &a[i__ * a_dim1 + 1]
+, lda, &tau[i__], t, &c__65);
+ if (left) {
+
+/* H or H' is applied to C(1:m-k+i+ib-1,1:n) */
+
+ mi = *m - *k + i__ + ib - 1;
+ } else {
+
+/* H or H' is applied to C(1:m,1:n-k+i+ib-1) */
+
+ ni = *n - *k + i__ + ib - 1;
+ }
+
+/* Apply H or H' */
+
+ clarfb_(side, trans, "Backward", "Columnwise", &mi, &ni, &ib, &a[
+ i__ * a_dim1 + 1], lda, t, &c__65, &c__[c_offset], ldc, &
+ work[1], &ldwork);
+/* L10: */
+ }
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ return 0;
+
+/* End of CUNMQL */
+
+} /* cunmql_ */
diff --git a/SRC/cunmqr.c b/SRC/cunmqr.c
new file mode 100644
index 0000000..846c9a5
--- /dev/null
+++ b/SRC/cunmqr.c
@@ -0,0 +1,328 @@
+/* cunmqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int cunmqr_(char *side, char *trans, integer *m, integer *n,
+ integer *k, complex *a, integer *lda, complex *tau, complex *c__,
+ integer *ldc, complex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
+ i__5;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ complex t[4160] /* was [65][64] */;
+ integer i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iws;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int cunm2r_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *), clarfb_(char *, char *,
+ char *, char *, integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *), clarft_(char *, char *
+, integer *, integer *, complex *, integer *, complex *, complex *
+, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical notran;
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNMQR overwrites the general complex M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'C': Q**H * C C * Q**H */
+
+/* where Q is a complex unitary matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by CGEQRF. Q is of order M if SIDE = 'L' and of order N */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**H from the Left; */
+/* = 'R': apply Q or Q**H from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'C': Conjugate transpose, apply Q**H. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,K) */
+/* The i-th column must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* CGEQRF in the first k columns of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If SIDE = 'L', LDA >= max(1,M); */
+/* if SIDE = 'R', LDA >= max(1,N). */
+
+/* TAU (input) COMPLEX array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CGEQRF. */
+
+/* C (input/output) COMPLEX array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = *n;
+ } else {
+ nq = *n;
+ nw = *m;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,nq)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ } else if (*lwork < max(1,nw) && ! lquery) {
+ *info = -12;
+ }
+
+ if (*info == 0) {
+
+/* Determine the block size. NB may be at most NBMAX, where NBMAX */
+/* is used to define the local array T. */
+
+/* Computing MIN */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 64, i__2 = ilaenv_(&c__1, "CUNMQR", ch__1, m, n, k, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = max(1,nw) * nb;
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUNMQR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ work[1].r = 1.f, work[1].i = 0.f;
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = nw;
+ if (nb > 1 && nb < *k) {
+ iws = nw * nb;
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 2, i__2 = ilaenv_(&c__2, "CUNMQR", ch__1, m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = nw;
+ }
+
+ if (nb < nbmin || nb >= *k) {
+
+/* Use unblocked code */
+
+ cunm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], &iinfo);
+ } else {
+
+/* Use blocked code */
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = nb;
+ } else {
+ i1 = (*k - 1) / nb * nb + 1;
+ i2 = 1;
+ i3 = -nb;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *k - i__ + 1;
+ ib = min(i__4,i__5);
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__4 = nq - i__ + 1;
+ clarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], t, &c__65)
+ ;
+ if (left) {
+
+/* H or H' is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H or H' is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H or H' */
+
+ clarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &a[
+ i__ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc *
+ c_dim1], ldc, &work[1], &ldwork);
+/* L10: */
+ }
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ return 0;
+
+/* End of CUNMQR */
+
+} /* cunmqr_ */
diff --git a/SRC/cunmr2.c b/SRC/cunmr2.c
new file mode 100644
index 0000000..2cfe39e
--- /dev/null
+++ b/SRC/cunmr2.c
@@ -0,0 +1,246 @@
+/* cunmr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cunmr2_(char *side, char *trans, integer *m, integer *n,
+ integer *k, complex *a, integer *lda, complex *tau, complex *c__,
+ integer *ldc, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
+ complex q__1;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, i1, i2, i3, mi, ni, nq;
+ complex aii;
+ logical left;
+ complex taui;
+ extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
+, integer *, complex *, complex *, integer *, complex *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
+ xerbla_(char *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNMR2 overwrites the general complex m-by-n matrix C with */
+
+/* Q * C if SIDE = 'L' and TRANS = 'N', or */
+
+/* Q'* C if SIDE = 'L' and TRANS = 'C', or */
+
+/* C * Q if SIDE = 'R' and TRANS = 'N', or */
+
+/* C * Q' if SIDE = 'R' and TRANS = 'C', */
+
+/* where Q is a complex unitary matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1)' H(2)' . . . H(k)' */
+
+/* as returned by CGERQF. Q is of order m if SIDE = 'L' and of order n */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q' from the Left */
+/* = 'R': apply Q or Q' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply Q (No transpose) */
+/* = 'C': apply Q' (Conjugate transpose) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) COMPLEX array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* CGERQF in the last k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) COMPLEX array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CGERQF. */
+
+/* C (input/output) COMPLEX array, dimension (LDC,N) */
+/* On entry, the m-by-n matrix C. */
+/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (N) if SIDE = 'L', */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,*k)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUNMR2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ return 0;
+ }
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = 1;
+ } else {
+ i1 = *k;
+ i2 = 1;
+ i3 = -1;
+ }
+
+ if (left) {
+ ni = *n;
+ } else {
+ mi = *m;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) or H(i)' is applied to C(1:m-k+i,1:n) */
+
+ mi = *m - *k + i__;
+ } else {
+
+/* H(i) or H(i)' is applied to C(1:m,1:n-k+i) */
+
+ ni = *n - *k + i__;
+ }
+
+/* Apply H(i) or H(i)' */
+
+ if (notran) {
+ r_cnjg(&q__1, &tau[i__]);
+ taui.r = q__1.r, taui.i = q__1.i;
+ } else {
+ i__3 = i__;
+ taui.r = tau[i__3].r, taui.i = tau[i__3].i;
+ }
+ i__3 = nq - *k + i__ - 1;
+ clacgv_(&i__3, &a[i__ + a_dim1], lda);
+ i__3 = i__ + (nq - *k + i__) * a_dim1;
+ aii.r = a[i__3].r, aii.i = a[i__3].i;
+ i__3 = i__ + (nq - *k + i__) * a_dim1;
+ a[i__3].r = 1.f, a[i__3].i = 0.f;
+ clarf_(side, &mi, &ni, &a[i__ + a_dim1], lda, &taui, &c__[c_offset],
+ ldc, &work[1]);
+ i__3 = i__ + (nq - *k + i__) * a_dim1;
+ a[i__3].r = aii.r, a[i__3].i = aii.i;
+ i__3 = nq - *k + i__ - 1;
+ clacgv_(&i__3, &a[i__ + a_dim1], lda);
+/* L10: */
+ }
+ return 0;
+
+/* End of CUNMR2 */
+
+} /* cunmr2_ */
diff --git a/SRC/cunmr3.c b/SRC/cunmr3.c
new file mode 100644
index 0000000..ba5e2bd
--- /dev/null
+++ b/SRC/cunmr3.c
@@ -0,0 +1,253 @@
+/* cunmr3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cunmr3_(char *side, char *trans, integer *m, integer *n,
+ integer *k, integer *l, complex *a, integer *lda, complex *tau,
+ complex *c__, integer *ldc, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
+ complex q__1;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, i1, i2, i3, ja, ic, jc, mi, ni, nq;
+ logical left;
+ complex taui;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int clarz_(char *, integer *, integer *, integer *
+, complex *, integer *, complex *, complex *, integer *, complex *
+), xerbla_(char *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNMR3 overwrites the general complex m by n matrix C with */
+
+/* Q * C if SIDE = 'L' and TRANS = 'N', or */
+
+/* Q'* C if SIDE = 'L' and TRANS = 'C', or */
+
+/* C * Q if SIDE = 'R' and TRANS = 'N', or */
+
+/* C * Q' if SIDE = 'R' and TRANS = 'C', */
+
+/* where Q is a complex unitary matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by CTZRZF. Q is of order m if SIDE = 'L' and of order n */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q' from the Left */
+/* = 'R': apply Q or Q' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply Q (No transpose) */
+/* = 'C': apply Q' (Conjugate transpose) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* L (input) INTEGER */
+/* The number of columns of the matrix A containing */
+/* the meaningful part of the Householder reflectors. */
+/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */
+
+/* A (input) COMPLEX array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* CTZRZF in the last k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) COMPLEX array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CTZRZF. */
+
+/* C (input/output) COMPLEX array, dimension (LDC,N) */
+/* On entry, the m-by-n matrix C. */
+/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (N) if SIDE = 'L', */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*l < 0 || left && *l > *m || ! left && *l > *n) {
+ *info = -6;
+ } else if (*lda < max(1,*k)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUNMR3", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ return 0;
+ }
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = 1;
+ } else {
+ i1 = *k;
+ i2 = 1;
+ i3 = -1;
+ }
+
+ if (left) {
+ ni = *n;
+ ja = *m - *l + 1;
+ jc = 1;
+ } else {
+ mi = *m;
+ ja = *n - *l + 1;
+ ic = 1;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) or H(i)' is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H(i) or H(i)' is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H(i) or H(i)' */
+
+ if (notran) {
+ i__3 = i__;
+ taui.r = tau[i__3].r, taui.i = tau[i__3].i;
+ } else {
+ r_cnjg(&q__1, &tau[i__]);
+ taui.r = q__1.r, taui.i = q__1.i;
+ }
+ clarz_(side, &mi, &ni, l, &a[i__ + ja * a_dim1], lda, &taui, &c__[ic
+ + jc * c_dim1], ldc, &work[1]);
+
+/* L10: */
+ }
+
+ return 0;
+
+/* End of CUNMR3 */
+
+} /* cunmr3_ */
diff --git a/SRC/cunmrq.c b/SRC/cunmrq.c
new file mode 100644
index 0000000..020d684
--- /dev/null
+++ b/SRC/cunmrq.c
@@ -0,0 +1,336 @@
+/* cunmrq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int cunmrq_(char *side, char *trans, integer *m, integer *n,
+ integer *k, complex *a, integer *lda, complex *tau, complex *c__,
+ integer *ldc, complex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
+ i__5;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ complex t[4160] /* was [65][64] */;
+ integer i1, i2, i3, ib, nb, mi, ni, nq, nw, iws;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int cunmr2_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *), clarfb_(char *, char *,
+ char *, char *, integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *), clarft_(char *, char *
+, integer *, integer *, complex *, integer *, complex *, complex *
+, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical notran;
+ integer ldwork;
+ char transt[1];
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNMRQ overwrites the general complex M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'C': Q**H * C C * Q**H */
+
+/* where Q is a complex unitary matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1)' H(2)' . . . H(k)' */
+
+/* as returned by CGERQF. Q is of order M if SIDE = 'L' and of order N */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**H from the Left; */
+/* = 'R': apply Q or Q**H from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'C': Transpose, apply Q**H. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) COMPLEX array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* CGERQF in the last k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) COMPLEX array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CGERQF. */
+
+/* C (input/output) COMPLEX array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = max(1,*n);
+ } else {
+ nq = *n;
+ nw = max(1,*m);
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,*k)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+
+ if (*info == 0) {
+ if (*m == 0 || *n == 0) {
+ lwkopt = 1;
+ } else {
+
+/* Determine the block size. NB may be at most NBMAX, where */
+/* NBMAX is used to define the local array T. */
+
+/* Computing MIN */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 64, i__2 = ilaenv_(&c__1, "CUNMRQ", ch__1, m, n, k, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = nw * nb;
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ if (*lwork < nw && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUNMRQ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = nw;
+ if (nb > 1 && nb < *k) {
+ iws = nw * nb;
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 2, i__2 = ilaenv_(&c__2, "CUNMRQ", ch__1, m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = nw;
+ }
+
+ if (nb < nbmin || nb >= *k) {
+
+/* Use unblocked code */
+
+ cunmr2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], &iinfo);
+ } else {
+
+/* Use blocked code */
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = nb;
+ } else {
+ i1 = (*k - 1) / nb * nb + 1;
+ i2 = 1;
+ i3 = -nb;
+ }
+
+ if (left) {
+ ni = *n;
+ } else {
+ mi = *m;
+ }
+
+ if (notran) {
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *k - i__ + 1;
+ ib = min(i__4,i__5);
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__4 = nq - *k + i__ + ib - 1;
+ clarft_("Backward", "Rowwise", &i__4, &ib, &a[i__ + a_dim1], lda,
+ &tau[i__], t, &c__65);
+ if (left) {
+
+/* H or H' is applied to C(1:m-k+i+ib-1,1:n) */
+
+ mi = *m - *k + i__ + ib - 1;
+ } else {
+
+/* H or H' is applied to C(1:m,1:n-k+i+ib-1) */
+
+ ni = *n - *k + i__ + ib - 1;
+ }
+
+/* Apply H or H' */
+
+ clarfb_(side, transt, "Backward", "Rowwise", &mi, &ni, &ib, &a[
+ i__ + a_dim1], lda, t, &c__65, &c__[c_offset], ldc, &work[
+ 1], &ldwork);
+/* L10: */
+ }
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ return 0;
+
+/* End of CUNMRQ */
+
+} /* cunmrq_ */
diff --git a/SRC/cunmrz.c b/SRC/cunmrz.c
new file mode 100644
index 0000000..e9d4d63
--- /dev/null
+++ b/SRC/cunmrz.c
@@ -0,0 +1,370 @@
+/* cunmrz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int cunmrz_(char *side, char *trans, integer *m, integer *n,
+ integer *k, integer *l, complex *a, integer *lda, complex *tau,
+ complex *c__, integer *ldc, complex *work, integer *lwork, integer *
+ info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
+ i__5;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ complex t[4160] /* was [65][64] */;
+ integer i1, i2, i3, ib, ic, ja, jc, nb, mi, ni, nq, nw, iws;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int cunmr3_(char *, char *, integer *, integer *,
+ integer *, integer *, complex *, integer *, complex *, complex *,
+ integer *, complex *, integer *), clarzb_(char *,
+ char *, char *, char *, integer *, integer *, integer *, integer *
+, complex *, integer *, complex *, integer *, complex *, integer *
+, complex *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), clarzt_(
+ char *, char *, integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ logical notran;
+ integer ldwork;
+ char transt[1];
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNMRZ overwrites the general complex M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'C': Q**H * C C * Q**H */
+
+/* where Q is a complex unitary matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by CTZRZF. Q is of order M if SIDE = 'L' and of order N */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**H from the Left; */
+/* = 'R': apply Q or Q**H from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'C': Conjugate transpose, apply Q**H. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* L (input) INTEGER */
+/* The number of columns of the matrix A containing */
+/* the meaningful part of the Householder reflectors. */
+/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */
+
+/* A (input) COMPLEX array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* CTZRZF in the last k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) COMPLEX array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CTZRZF. */
+
+/* C (input/output) COMPLEX array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = max(1,*n);
+ } else {
+ nq = *n;
+ nw = max(1,*m);
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*l < 0 || left && *l > *m || ! left && *l > *n) {
+ *info = -6;
+ } else if (*lda < max(1,*k)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -11;
+ }
+
+ if (*info == 0) {
+ if (*m == 0 || *n == 0) {
+ lwkopt = 1;
+ } else {
+
+/* Determine the block size. NB may be at most NBMAX, where */
+/* NBMAX is used to define the local array T. */
+
+/* Computing MIN */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 64, i__2 = ilaenv_(&c__1, "CUNMRQ", ch__1, m, n, k, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = nw * nb;
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ if (*lwork < max(1,nw) && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUNMRZ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Determine the block size. NB may be at most NBMAX, where NBMAX */
+/* is used to define the local array T. */
+
+/* Computing MIN */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 64, i__2 = ilaenv_(&c__1, "CUNMRQ", ch__1, m, n, k, &c_n1);
+ nb = min(i__1,i__2);
+ nbmin = 2;
+ ldwork = nw;
+ if (nb > 1 && nb < *k) {
+ iws = nw * nb;
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 2, i__2 = ilaenv_(&c__2, "CUNMRQ", ch__1, m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = nw;
+ }
+
+ if (nb < nbmin || nb >= *k) {
+
+/* Use unblocked code */
+
+ cunmr3_(side, trans, m, n, k, l, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], &iinfo);
+ } else {
+
+/* Use blocked code */
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = nb;
+ } else {
+ i1 = (*k - 1) / nb * nb + 1;
+ i2 = 1;
+ i3 = -nb;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ ja = *m - *l + 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ ja = *n - *l + 1;
+ }
+
+ if (notran) {
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *k - i__ + 1;
+ ib = min(i__4,i__5);
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ clarzt_("Backward", "Rowwise", l, &ib, &a[i__ + ja * a_dim1], lda,
+ &tau[i__], t, &c__65);
+
+ if (left) {
+
+/* H or H' is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H or H' is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H or H' */
+
+ clarzb_(side, transt, "Backward", "Rowwise", &mi, &ni, &ib, l, &a[
+ i__ + ja * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1]
+, ldc, &work[1], &ldwork);
+/* L10: */
+ }
+
+ }
+
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+
+ return 0;
+
+/* End of CUNMRZ */
+
+} /* cunmrz_ */
diff --git a/SRC/cunmtr.c b/SRC/cunmtr.c
new file mode 100644
index 0000000..c1d63f4
--- /dev/null
+++ b/SRC/cunmtr.c
@@ -0,0 +1,294 @@
+/* cunmtr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int cunmtr_(char *side, char *uplo, char *trans, integer *m,
+ integer *n, complex *a, integer *lda, complex *tau, complex *c__,
+ integer *ldc, complex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2, i__3;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i1, i2, nb, mi, ni, nq, nw;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int cunmql_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *), cunmqr_(char *,
+ char *, integer *, integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *, complex *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNMTR overwrites the general complex M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'C': Q**H * C C * Q**H */
+
+/* where Q is a complex unitary matrix of order nq, with nq = m if */
+/* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */
+/* nq-1 elementary reflectors, as returned by CHETRD: */
+
+/* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); */
+
+/* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**H from the Left; */
+/* = 'R': apply Q or Q**H from the Right. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A contains elementary reflectors */
+/* from CHETRD; */
+/* = 'L': Lower triangle of A contains elementary reflectors */
+/* from CHETRD. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'C': Conjugate transpose, apply Q**H. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* A (input) COMPLEX array, dimension */
+/* (LDA,M) if SIDE = 'L' */
+/* (LDA,N) if SIDE = 'R' */
+/* The vectors which define the elementary reflectors, as */
+/* returned by CHETRD. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. */
+
+/* TAU (input) COMPLEX array, dimension */
+/* (M-1) if SIDE = 'L' */
+/* (N-1) if SIDE = 'R' */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CHETRD. */
+
+/* C (input/output) COMPLEX array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >=M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = *n;
+ } else {
+ nq = *n;
+ nw = *m;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "C")) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,nq)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ } else if (*lwork < max(1,nw) && ! lquery) {
+ *info = -12;
+ }
+
+ if (*info == 0) {
+ if (upper) {
+ if (left) {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ nb = ilaenv_(&c__1, "CUNMQL", ch__1, &i__2, n, &i__3, &c_n1);
+ } else {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ nb = ilaenv_(&c__1, "CUNMQL", ch__1, m, &i__2, &i__3, &c_n1);
+ }
+ } else {
+ if (left) {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ nb = ilaenv_(&c__1, "CUNMQR", ch__1, &i__2, n, &i__3, &c_n1);
+ } else {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ nb = ilaenv_(&c__1, "CUNMQR", ch__1, m, &i__2, &i__3, &c_n1);
+ }
+ }
+ lwkopt = max(1,nw) * nb;
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ }
+
+ if (*info != 0) {
+ i__2 = -(*info);
+ xerbla_("CUNMTR", &i__2);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || nq == 1) {
+ work[1].r = 1.f, work[1].i = 0.f;
+ return 0;
+ }
+
+ if (left) {
+ mi = *m - 1;
+ ni = *n;
+ } else {
+ mi = *m;
+ ni = *n - 1;
+ }
+
+ if (upper) {
+
+/* Q was determined by a call to CHETRD with UPLO = 'U' */
+
+ i__2 = nq - 1;
+ cunmql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, &
+ tau[1], &c__[c_offset], ldc, &work[1], lwork, &iinfo);
+ } else {
+
+/* Q was determined by a call to CHETRD with UPLO = 'L' */
+
+ if (left) {
+ i1 = 2;
+ i2 = 1;
+ } else {
+ i1 = 1;
+ i2 = 2;
+ }
+ i__2 = nq - 1;
+ cunmqr_(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], &
+ c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo);
+ }
+ work[1].r = (real) lwkopt, work[1].i = 0.f;
+ return 0;
+
+/* End of CUNMTR */
+
+} /* cunmtr_ */
diff --git a/SRC/cupgtr.c b/SRC/cupgtr.c
new file mode 100644
index 0000000..135728b
--- /dev/null
+++ b/SRC/cupgtr.c
@@ -0,0 +1,219 @@
+/* cupgtr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cupgtr_(char *uplo, integer *n, complex *ap, complex *
+ tau, complex *q, integer *ldq, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, ij;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical upper;
+ extern /* Subroutine */ int cung2l_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *), cung2r_(
+ integer *, integer *, integer *, complex *, integer *, complex *,
+ complex *, integer *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUPGTR generates a complex unitary matrix Q which is defined as the */
+/* product of n-1 elementary reflectors H(i) of order n, as returned by */
+/* CHPTRD using packed storage: */
+
+/* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), */
+
+/* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular packed storage used in previous */
+/* call to CHPTRD; */
+/* = 'L': Lower triangular packed storage used in previous */
+/* call to CHPTRD. */
+
+/* N (input) INTEGER */
+/* The order of the matrix Q. N >= 0. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The vectors which define the elementary reflectors, as */
+/* returned by CHPTRD. */
+
+/* TAU (input) COMPLEX array, dimension (N-1) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CHPTRD. */
+
+/* Q (output) COMPLEX array, dimension (LDQ,N) */
+/* The N-by-N unitary matrix Q. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* WORK (workspace) COMPLEX array, dimension (N-1) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --ap;
+ --tau;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldq < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUPGTR", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Q was determined by a call to CHPTRD with UPLO = 'U' */
+
+/* Unpack the vectors which define the elementary reflectors and */
+/* set the last row and column of Q equal to those of the unit */
+/* matrix */
+
+ ij = 2;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * q_dim1;
+ i__4 = ij;
+ q[i__3].r = ap[i__4].r, q[i__3].i = ap[i__4].i;
+ ++ij;
+/* L10: */
+ }
+ ij += 2;
+ i__2 = *n + j * q_dim1;
+ q[i__2].r = 0.f, q[i__2].i = 0.f;
+/* L20: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + *n * q_dim1;
+ q[i__2].r = 0.f, q[i__2].i = 0.f;
+/* L30: */
+ }
+ i__1 = *n + *n * q_dim1;
+ q[i__1].r = 1.f, q[i__1].i = 0.f;
+
+/* Generate Q(1:n-1,1:n-1) */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ cung2l_(&i__1, &i__2, &i__3, &q[q_offset], ldq, &tau[1], &work[1], &
+ iinfo);
+
+ } else {
+
+/* Q was determined by a call to CHPTRD with UPLO = 'L'. */
+
+/* Unpack the vectors which define the elementary reflectors and */
+/* set the first row and column of Q equal to those of the unit */
+/* matrix */
+
+ i__1 = q_dim1 + 1;
+ q[i__1].r = 1.f, q[i__1].i = 0.f;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__ + q_dim1;
+ q[i__2].r = 0.f, q[i__2].i = 0.f;
+/* L40: */
+ }
+ ij = 3;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j * q_dim1 + 1;
+ q[i__2].r = 0.f, q[i__2].i = 0.f;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * q_dim1;
+ i__4 = ij;
+ q[i__3].r = ap[i__4].r, q[i__3].i = ap[i__4].i;
+ ++ij;
+/* L50: */
+ }
+ ij += 2;
+/* L60: */
+ }
+ if (*n > 1) {
+
+/* Generate Q(2:n,2:n) */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ cung2r_(&i__1, &i__2, &i__3, &q[(q_dim1 << 1) + 2], ldq, &tau[1],
+ &work[1], &iinfo);
+ }
+ }
+ return 0;
+
+/* End of CUPGTR */
+
+} /* cupgtr_ */
diff --git a/SRC/cupmtr.c b/SRC/cupmtr.c
new file mode 100644
index 0000000..993d479
--- /dev/null
+++ b/SRC/cupmtr.c
@@ -0,0 +1,320 @@
+/* cupmtr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cupmtr_(char *side, char *uplo, char *trans, integer *m,
+ integer *n, complex *ap, complex *tau, complex *c__, integer *ldc,
+ complex *work, integer *info)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1, i__2, i__3;
+ complex q__1;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, i1, i2, i3, ic, jc, ii, mi, ni, nq;
+ complex aii;
+ logical left;
+ complex taui;
+ extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
+, integer *, complex *, complex *, integer *, complex *);
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran, forwrd;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUPMTR overwrites the general complex M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'C': Q**H * C C * Q**H */
+
+/* where Q is a complex unitary matrix of order nq, with nq = m if */
+/* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */
+/* nq-1 elementary reflectors, as returned by CHPTRD using packed */
+/* storage: */
+
+/* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); */
+
+/* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**H from the Left; */
+/* = 'R': apply Q or Q**H from the Right. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular packed storage used in previous */
+/* call to CHPTRD; */
+/* = 'L': Lower triangular packed storage used in previous */
+/* call to CHPTRD. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'C': Conjugate transpose, apply Q**H. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* AP (input) COMPLEX array, dimension */
+/* (M*(M+1)/2) if SIDE = 'L' */
+/* (N*(N+1)/2) if SIDE = 'R' */
+/* The vectors which define the elementary reflectors, as */
+/* returned by CHPTRD. AP is modified by the routine but */
+/* restored on exit. */
+
+/* TAU (input) COMPLEX array, dimension (M-1) if SIDE = 'L' */
+/* or (N-1) if SIDE = 'R' */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by CHPTRD. */
+
+/* C (input/output) COMPLEX array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (N) if SIDE = 'L' */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --ap;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ upper = lsame_(uplo, "U");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*ldc < max(1,*m)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUPMTR", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Q was determined by a call to CHPTRD with UPLO = 'U' */
+
+ forwrd = left && notran || ! left && ! notran;
+
+ if (forwrd) {
+ i1 = 1;
+ i2 = nq - 1;
+ i3 = 1;
+ ii = 2;
+ } else {
+ i1 = nq - 1;
+ i2 = 1;
+ i3 = -1;
+ ii = nq * (nq + 1) / 2 - 1;
+ }
+
+ if (left) {
+ ni = *n;
+ } else {
+ mi = *m;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) or H(i)' is applied to C(1:i,1:n) */
+
+ mi = i__;
+ } else {
+
+/* H(i) or H(i)' is applied to C(1:m,1:i) */
+
+ ni = i__;
+ }
+
+/* Apply H(i) or H(i)' */
+
+ if (notran) {
+ i__3 = i__;
+ taui.r = tau[i__3].r, taui.i = tau[i__3].i;
+ } else {
+ r_cnjg(&q__1, &tau[i__]);
+ taui.r = q__1.r, taui.i = q__1.i;
+ }
+ i__3 = ii;
+ aii.r = ap[i__3].r, aii.i = ap[i__3].i;
+ i__3 = ii;
+ ap[i__3].r = 1.f, ap[i__3].i = 0.f;
+ clarf_(side, &mi, &ni, &ap[ii - i__ + 1], &c__1, &taui, &c__[
+ c_offset], ldc, &work[1]);
+ i__3 = ii;
+ ap[i__3].r = aii.r, ap[i__3].i = aii.i;
+
+ if (forwrd) {
+ ii = ii + i__ + 2;
+ } else {
+ ii = ii - i__ - 1;
+ }
+/* L10: */
+ }
+ } else {
+
+/* Q was determined by a call to CHPTRD with UPLO = 'L'. */
+
+ forwrd = left && ! notran || ! left && notran;
+
+ if (forwrd) {
+ i1 = 1;
+ i2 = nq - 1;
+ i3 = 1;
+ ii = 2;
+ } else {
+ i1 = nq - 1;
+ i2 = 1;
+ i3 = -1;
+ ii = nq * (nq + 1) / 2 - 1;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ }
+
+ i__2 = i2;
+ i__1 = i3;
+ for (i__ = i1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
+ i__3 = ii;
+ aii.r = ap[i__3].r, aii.i = ap[i__3].i;
+ i__3 = ii;
+ ap[i__3].r = 1.f, ap[i__3].i = 0.f;
+ if (left) {
+
+/* H(i) or H(i)' is applied to C(i+1:m,1:n) */
+
+ mi = *m - i__;
+ ic = i__ + 1;
+ } else {
+
+/* H(i) or H(i)' is applied to C(1:m,i+1:n) */
+
+ ni = *n - i__;
+ jc = i__ + 1;
+ }
+
+/* Apply H(i) or H(i)' */
+
+ if (notran) {
+ i__3 = i__;
+ taui.r = tau[i__3].r, taui.i = tau[i__3].i;
+ } else {
+ r_cnjg(&q__1, &tau[i__]);
+ taui.r = q__1.r, taui.i = q__1.i;
+ }
+ clarf_(side, &mi, &ni, &ap[ii], &c__1, &taui, &c__[ic + jc *
+ c_dim1], ldc, &work[1]);
+ i__3 = ii;
+ ap[i__3].r = aii.r, ap[i__3].i = aii.i;
+
+ if (forwrd) {
+ ii = ii + nq - i__ + 1;
+ } else {
+ ii = ii - nq + i__ - 2;
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+/* End of CUPMTR */
+
+} /* cupmtr_ */
diff --git a/SRC/dbdsdc.c b/SRC/dbdsdc.c
new file mode 100644
index 0000000..6096e4f
--- /dev/null
+++ b/SRC/dbdsdc.c
@@ -0,0 +1,514 @@
+/* dbdsdc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__9 = 9;
+static integer c__0 = 0;
+static doublereal c_b15 = 1.;
+static integer c__1 = 1;
+static doublereal c_b29 = 0.;
+
+/* Subroutine */ int dbdsdc_(char *uplo, char *compq, integer *n, doublereal *
+ d__, doublereal *e, doublereal *u, integer *ldu, doublereal *vt,
+ integer *ldvt, doublereal *q, integer *iq, doublereal *work, integer *
+ iwork, integer *info)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *), log(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal p, r__;
+ integer z__, ic, ii, kk;
+ doublereal cs;
+ integer is, iu;
+ doublereal sn;
+ integer nm1;
+ doublereal eps;
+ integer ivt, difl, difr, ierr, perm, mlvl, sqre;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *), dcopy_(integer *, doublereal *, integer *
+, doublereal *, integer *), dswap_(integer *, doublereal *,
+ integer *, doublereal *, integer *);
+ integer poles, iuplo, nsize, start;
+ extern /* Subroutine */ int dlasd0_(integer *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *, doublereal *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlasda_(integer *, integer *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *), dlascl_(char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *), dlasdq_(char *, integer *, integer *, integer
+ *, integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *), dlaset_(char *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *), dlartg_(doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer givcol;
+ extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
+ integer icompq;
+ doublereal orgnrm;
+ integer givnum, givptr, qstart, smlsiz, wstart, smlszp;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DBDSDC computes the singular value decomposition (SVD) of a real */
+/* N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT, */
+/* using a divide and conquer method, where S is a diagonal matrix */
+/* with non-negative diagonal elements (the singular values of B), and */
+/* U and VT are orthogonal matrices of left and right singular vectors, */
+/* respectively. DBDSDC can be used to compute all singular values, */
+/* and optionally, singular vectors or singular vectors in compact form. */
+
+/* This code makes very mild assumptions about floating point */
+/* arithmetic. It will work on machines with a guard digit in */
+/* add/subtract, or on those binary machines without guard digits */
+/* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */
+/* It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. See DLASD3 for details. */
+
+/* The code currently calls DLASDQ if singular values only are desired. */
+/* However, it can be slightly modified to compute singular values */
+/* using the divide and conquer method. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': B is upper bidiagonal. */
+/* = 'L': B is lower bidiagonal. */
+
+/* COMPQ (input) CHARACTER*1 */
+/* Specifies whether singular vectors are to be computed */
+/* as follows: */
+/* = 'N': Compute singular values only; */
+/* = 'P': Compute singular values and compute singular */
+/* vectors in compact form; */
+/* = 'I': Compute singular values and singular vectors. */
+
+/* N (input) INTEGER */
+/* The order of the matrix B. N >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the n diagonal elements of the bidiagonal matrix B. */
+/* On exit, if INFO=0, the singular values of B. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* On entry, the elements of E contain the offdiagonal */
+/* elements of the bidiagonal matrix whose SVD is desired. */
+/* On exit, E has been destroyed. */
+
+/* U (output) DOUBLE PRECISION array, dimension (LDU,N) */
+/* If COMPQ = 'I', then: */
+/* On exit, if INFO = 0, U contains the left singular vectors */
+/* of the bidiagonal matrix. */
+/* For other values of COMPQ, U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= 1. */
+/* If singular vectors are desired, then LDU >= max( 1, N ). */
+
+/* VT (output) DOUBLE PRECISION array, dimension (LDVT,N) */
+/* If COMPQ = 'I', then: */
+/* On exit, if INFO = 0, VT' contains the right singular */
+/* vectors of the bidiagonal matrix. */
+/* For other values of COMPQ, VT is not referenced. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. LDVT >= 1. */
+/* If singular vectors are desired, then LDVT >= max( 1, N ). */
+
+/* Q (output) DOUBLE PRECISION array, dimension (LDQ) */
+/* If COMPQ = 'P', then: */
+/* On exit, if INFO = 0, Q and IQ contain the left */
+/* and right singular vectors in a compact form, */
+/* requiring O(N log N) space instead of 2*N**2. */
+/* In particular, Q contains all the DOUBLE PRECISION data in */
+/* LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1)))) */
+/* words of memory, where SMLSIZ is returned by ILAENV and */
+/* is equal to the maximum size of the subproblems at the */
+/* bottom of the computation tree (usually about 25). */
+/* For other values of COMPQ, Q is not referenced. */
+
+/* IQ (output) INTEGER array, dimension (LDIQ) */
+/* If COMPQ = 'P', then: */
+/* On exit, if INFO = 0, Q and IQ contain the left */
+/* and right singular vectors in a compact form, */
+/* requiring O(N log N) space instead of 2*N**2. */
+/* In particular, IQ contains all INTEGER data in */
+/* LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1)))) */
+/* words of memory, where SMLSIZ is returned by ILAENV and */
+/* is equal to the maximum size of the subproblems at the */
+/* bottom of the computation tree (usually about 25). */
+/* For other values of COMPQ, IQ is not referenced. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* If COMPQ = 'N' then LWORK >= (4 * N). */
+/* If COMPQ = 'P' then LWORK >= (6 * N). */
+/* If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N). */
+
+/* IWORK (workspace) INTEGER array, dimension (8*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: The algorithm failed to compute an singular value. */
+/* The update process of divide and conquer failed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+/* Changed dimension statement in comment describing E from (N) to */
+/* (N-1). Sven, 17 Feb 05. */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --q;
+ --iq;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+ iuplo = 0;
+ if (lsame_(uplo, "U")) {
+ iuplo = 1;
+ }
+ if (lsame_(uplo, "L")) {
+ iuplo = 2;
+ }
+ if (lsame_(compq, "N")) {
+ icompq = 0;
+ } else if (lsame_(compq, "P")) {
+ icompq = 1;
+ } else if (lsame_(compq, "I")) {
+ icompq = 2;
+ } else {
+ icompq = -1;
+ }
+ if (iuplo == 0) {
+ *info = -1;
+ } else if (icompq < 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ldu < 1 || icompq == 2 && *ldu < *n) {
+ *info = -7;
+ } else if (*ldvt < 1 || icompq == 2 && *ldvt < *n) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DBDSDC", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+ smlsiz = ilaenv_(&c__9, "DBDSDC", " ", &c__0, &c__0, &c__0, &c__0);
+ if (*n == 1) {
+ if (icompq == 1) {
+ q[1] = d_sign(&c_b15, &d__[1]);
+ q[smlsiz * *n + 1] = 1.;
+ } else if (icompq == 2) {
+ u[u_dim1 + 1] = d_sign(&c_b15, &d__[1]);
+ vt[vt_dim1 + 1] = 1.;
+ }
+ d__[1] = abs(d__[1]);
+ return 0;
+ }
+ nm1 = *n - 1;
+
+/* If matrix lower bidiagonal, rotate to be upper bidiagonal */
+/* by applying Givens rotations on the left */
+
+ wstart = 1;
+ qstart = 3;
+ if (icompq == 1) {
+ dcopy_(n, &d__[1], &c__1, &q[1], &c__1);
+ i__1 = *n - 1;
+ dcopy_(&i__1, &e[1], &c__1, &q[*n + 1], &c__1);
+ }
+ if (iuplo == 2) {
+ qstart = 5;
+ wstart = (*n << 1) - 1;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
+ d__[i__] = r__;
+ e[i__] = sn * d__[i__ + 1];
+ d__[i__ + 1] = cs * d__[i__ + 1];
+ if (icompq == 1) {
+ q[i__ + (*n << 1)] = cs;
+ q[i__ + *n * 3] = sn;
+ } else if (icompq == 2) {
+ work[i__] = cs;
+ work[nm1 + i__] = -sn;
+ }
+/* L10: */
+ }
+ }
+
+/* If ICOMPQ = 0, use DLASDQ to compute the singular values. */
+
+ if (icompq == 0) {
+ dlasdq_("U", &c__0, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[
+ wstart], info);
+ goto L40;
+ }
+
+/* If N is smaller than the minimum divide size SMLSIZ, then solve */
+/* the problem with another solver. */
+
+ if (*n <= smlsiz) {
+ if (icompq == 2) {
+ dlaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu);
+ dlaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt);
+ dlasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &vt[vt_offset]
+, ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[
+ wstart], info);
+ } else if (icompq == 1) {
+ iu = 1;
+ ivt = iu + *n;
+ dlaset_("A", n, n, &c_b29, &c_b15, &q[iu + (qstart - 1) * *n], n);
+ dlaset_("A", n, n, &c_b29, &c_b15, &q[ivt + (qstart - 1) * *n], n);
+ dlasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &q[ivt + (
+ qstart - 1) * *n], n, &q[iu + (qstart - 1) * *n], n, &q[
+ iu + (qstart - 1) * *n], n, &work[wstart], info);
+ }
+ goto L40;
+ }
+
+ if (icompq == 2) {
+ dlaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu);
+ dlaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt);
+ }
+
+/* Scale. */
+
+ orgnrm = dlanst_("M", n, &d__[1], &e[1]);
+ if (orgnrm == 0.) {
+ return 0;
+ }
+ dlascl_("G", &c__0, &c__0, &orgnrm, &c_b15, n, &c__1, &d__[1], n, &ierr);
+ dlascl_("G", &c__0, &c__0, &orgnrm, &c_b15, &nm1, &c__1, &e[1], &nm1, &
+ ierr);
+
+ eps = dlamch_("Epsilon");
+
+ mlvl = (integer) (log((doublereal) (*n) / (doublereal) (smlsiz + 1)) /
+ log(2.)) + 1;
+ smlszp = smlsiz + 1;
+
+ if (icompq == 1) {
+ iu = 1;
+ ivt = smlsiz + 1;
+ difl = ivt + smlszp;
+ difr = difl + mlvl;
+ z__ = difr + (mlvl << 1);
+ ic = z__ + mlvl;
+ is = ic + 1;
+ poles = is + 1;
+ givnum = poles + (mlvl << 1);
+
+ k = 1;
+ givptr = 2;
+ perm = 3;
+ givcol = perm + mlvl;
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((d__1 = d__[i__], abs(d__1)) < eps) {
+ d__[i__] = d_sign(&eps, &d__[i__]);
+ }
+/* L20: */
+ }
+
+ start = 1;
+ sqre = 0;
+
+ i__1 = nm1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) {
+
+/* Subproblem found. First determine its size and then */
+/* apply divide and conquer on it. */
+
+ if (i__ < nm1) {
+
+/* A subproblem with E(I) small for I < NM1. */
+
+ nsize = i__ - start + 1;
+ } else if ((d__1 = e[i__], abs(d__1)) >= eps) {
+
+/* A subproblem with E(NM1) not too small but I = NM1. */
+
+ nsize = *n - start + 1;
+ } else {
+
+/* A subproblem with E(NM1) small. This implies an */
+/* 1-by-1 subproblem at D(N). Solve this 1-by-1 problem */
+/* first. */
+
+ nsize = i__ - start + 1;
+ if (icompq == 2) {
+ u[*n + *n * u_dim1] = d_sign(&c_b15, &d__[*n]);
+ vt[*n + *n * vt_dim1] = 1.;
+ } else if (icompq == 1) {
+ q[*n + (qstart - 1) * *n] = d_sign(&c_b15, &d__[*n]);
+ q[*n + (smlsiz + qstart - 1) * *n] = 1.;
+ }
+ d__[*n] = (d__1 = d__[*n], abs(d__1));
+ }
+ if (icompq == 2) {
+ dlasd0_(&nsize, &sqre, &d__[start], &e[start], &u[start +
+ start * u_dim1], ldu, &vt[start + start * vt_dim1],
+ ldvt, &smlsiz, &iwork[1], &work[wstart], info);
+ } else {
+ dlasda_(&icompq, &smlsiz, &nsize, &sqre, &d__[start], &e[
+ start], &q[start + (iu + qstart - 2) * *n], n, &q[
+ start + (ivt + qstart - 2) * *n], &iq[start + k * *n],
+ &q[start + (difl + qstart - 2) * *n], &q[start + (
+ difr + qstart - 2) * *n], &q[start + (z__ + qstart -
+ 2) * *n], &q[start + (poles + qstart - 2) * *n], &iq[
+ start + givptr * *n], &iq[start + givcol * *n], n, &
+ iq[start + perm * *n], &q[start + (givnum + qstart -
+ 2) * *n], &q[start + (ic + qstart - 2) * *n], &q[
+ start + (is + qstart - 2) * *n], &work[wstart], &
+ iwork[1], info);
+ if (*info != 0) {
+ return 0;
+ }
+ }
+ start = i__ + 1;
+ }
+/* L30: */
+ }
+
+/* Unscale */
+
+ dlascl_("G", &c__0, &c__0, &c_b15, &orgnrm, n, &c__1, &d__[1], n, &ierr);
+L40:
+
+/* Use Selection Sort to minimize swaps of singular vectors */
+
+ i__1 = *n;
+ for (ii = 2; ii <= i__1; ++ii) {
+ i__ = ii - 1;
+ kk = i__;
+ p = d__[i__];
+ i__2 = *n;
+ for (j = ii; j <= i__2; ++j) {
+ if (d__[j] > p) {
+ kk = j;
+ p = d__[j];
+ }
+/* L50: */
+ }
+ if (kk != i__) {
+ d__[kk] = d__[i__];
+ d__[i__] = p;
+ if (icompq == 1) {
+ iq[i__] = kk;
+ } else if (icompq == 2) {
+ dswap_(n, &u[i__ * u_dim1 + 1], &c__1, &u[kk * u_dim1 + 1], &
+ c__1);
+ dswap_(n, &vt[i__ + vt_dim1], ldvt, &vt[kk + vt_dim1], ldvt);
+ }
+ } else if (icompq == 1) {
+ iq[i__] = i__;
+ }
+/* L60: */
+ }
+
+/* If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO */
+
+ if (icompq == 1) {
+ if (iuplo == 1) {
+ iq[*n] = 1;
+ } else {
+ iq[*n] = 0;
+ }
+ }
+
+/* If B is lower bidiagonal, update U by those Givens rotations */
+/* which rotated B to be upper bidiagonal */
+
+ if (iuplo == 2 && icompq == 2) {
+ dlasr_("L", "V", "B", n, n, &work[1], &work[*n], &u[u_offset], ldu);
+ }
+
+ return 0;
+
+/* End of DBDSDC */
+
+} /* dbdsdc_ */
diff --git a/SRC/dbdsqr.c b/SRC/dbdsqr.c
new file mode 100644
index 0000000..08b04fc
--- /dev/null
+++ b/SRC/dbdsqr.c
@@ -0,0 +1,918 @@
+/* dbdsqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b15 = -.125;
+static integer c__1 = 1;
+static doublereal c_b49 = 1.;
+static doublereal c_b72 = -1.;
+
+/* Subroutine */ int dbdsqr_(char *uplo, integer *n, integer *ncvt, integer *
+ nru, integer *ncc, doublereal *d__, doublereal *e, doublereal *vt,
+ integer *ldvt, doublereal *u, integer *ldu, doublereal *c__, integer *
+ ldc, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
+ i__2;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double pow_dd(doublereal *, doublereal *), sqrt(doublereal), d_sign(
+ doublereal *, doublereal *);
+
+ /* Local variables */
+ doublereal f, g, h__;
+ integer i__, j, m;
+ doublereal r__, cs;
+ integer ll;
+ doublereal sn, mu;
+ integer nm1, nm12, nm13, lll;
+ doublereal eps, sll, tol, abse;
+ integer idir;
+ doublereal abss;
+ integer oldm;
+ doublereal cosl;
+ integer isub, iter;
+ doublereal unfl, sinl, cosr, smin, smax, sinr;
+ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *), dlas2_(
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *), dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ doublereal oldcs;
+ extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *);
+ integer oldll;
+ doublereal shift, sigmn, oldsn;
+ extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer maxit;
+ doublereal sminl, sigmx;
+ logical lower;
+ extern /* Subroutine */ int dlasq1_(integer *, doublereal *, doublereal *,
+ doublereal *, integer *), dlasv2_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *), xerbla_(char *,
+ integer *);
+ doublereal sminoa, thresh;
+ logical rotate;
+ doublereal tolmul;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DBDSQR computes the singular values and, optionally, the right and/or */
+/* left singular vectors from the singular value decomposition (SVD) of */
+/* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit */
+/* zero-shift QR algorithm. The SVD of B has the form */
+
+/* B = Q * S * P**T */
+
+/* where S is the diagonal matrix of singular values, Q is an orthogonal */
+/* matrix of left singular vectors, and P is an orthogonal matrix of */
+/* right singular vectors. If left singular vectors are requested, this */
+/* subroutine actually returns U*Q instead of Q, and, if right singular */
+/* vectors are requested, this subroutine returns P**T*VT instead of */
+/* P**T, for given real input matrices U and VT. When U and VT are the */
+/* orthogonal matrices that reduce a general matrix A to bidiagonal */
+/* form: A = U*B*VT, as computed by DGEBRD, then */
+
+/* A = (U*Q) * S * (P**T*VT) */
+
+/* is the SVD of A. Optionally, the subroutine may also compute Q**T*C */
+/* for a given real input matrix C. */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices With */
+/* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, */
+/* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, */
+/* no. 5, pp. 873-912, Sept 1990) and */
+/* "Accurate singular values and differential qd algorithms," by */
+/* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics */
+/* Department, University of California at Berkeley, July 1992 */
+/* for a detailed description of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': B is upper bidiagonal; */
+/* = 'L': B is lower bidiagonal. */
+
+/* N (input) INTEGER */
+/* The order of the matrix B. N >= 0. */
+
+/* NCVT (input) INTEGER */
+/* The number of columns of the matrix VT. NCVT >= 0. */
+
+/* NRU (input) INTEGER */
+/* The number of rows of the matrix U. NRU >= 0. */
+
+/* NCC (input) INTEGER */
+/* The number of columns of the matrix C. NCC >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the n diagonal elements of the bidiagonal matrix B. */
+/* On exit, if INFO=0, the singular values of B in decreasing */
+/* order. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* On entry, the N-1 offdiagonal elements of the bidiagonal */
+/* matrix B. */
+/* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E */
+/* will contain the diagonal and superdiagonal elements of a */
+/* bidiagonal matrix orthogonally equivalent to the one given */
+/* as input. */
+
+/* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) */
+/* On entry, an N-by-NCVT matrix VT. */
+/* On exit, VT is overwritten by P**T * VT. */
+/* Not referenced if NCVT = 0. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. */
+/* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. */
+
+/* U (input/output) DOUBLE PRECISION array, dimension (LDU, N) */
+/* On entry, an NRU-by-N matrix U. */
+/* On exit, U is overwritten by U * Q. */
+/* Not referenced if NRU = 0. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,NRU). */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) */
+/* On entry, an N-by-NCC matrix C. */
+/* On exit, C is overwritten by Q**T * C. */
+/* Not referenced if NCC = 0. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. */
+/* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0: */
+/* if NCVT = NRU = NCC = 0, */
+/* = 1, a split was marked by a positive value in E */
+/* = 2, current block of Z not diagonalized after 30*N */
+/* iterations (in inner while loop) */
+/* = 3, termination criterion of outer while loop not met */
+/* (program created more than N unreduced blocks) */
+/* else NCVT = NRU = NCC = 0, */
+/* the algorithm did not converge; D and E contain the */
+/* elements of a bidiagonal matrix which is orthogonally */
+/* similar to the input matrix B; if INFO = i, i */
+/* elements of E have not converged to zero. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8))) */
+/* TOLMUL controls the convergence criterion of the QR loop. */
+/* If it is positive, TOLMUL*EPS is the desired relative */
+/* precision in the computed singular values. */
+/* If it is negative, abs(TOLMUL*EPS*sigma_max) is the */
+/* desired absolute accuracy in the computed singular */
+/* values (corresponds to relative accuracy */
+/* abs(TOLMUL*EPS) in the largest singular value. */
+/* abs(TOLMUL) should be between 1 and 1/EPS, and preferably */
+/* between 10 (for fast convergence) and .1/EPS */
+/* (for there to be some accuracy in the results). */
+/* Default is to lose at either one eighth or 2 of the */
+/* available decimal digits in each computed singular value */
+/* (whichever is smaller). */
+
+/* MAXITR INTEGER, default = 6 */
+/* MAXITR controls the maximum number of passes of the */
+/* algorithm through its inner loop. The algorithms stops */
+/* (and so fails to converge) if the number of passes */
+/* through the inner loop exceeds MAXITR*N**2. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lower = lsame_(uplo, "L");
+ if (! lsame_(uplo, "U") && ! lower) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ncvt < 0) {
+ *info = -3;
+ } else if (*nru < 0) {
+ *info = -4;
+ } else if (*ncc < 0) {
+ *info = -5;
+ } else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1,*n)) {
+ *info = -9;
+ } else if (*ldu < max(1,*nru)) {
+ *info = -11;
+ } else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1,*n)) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DBDSQR", &i__1);
+ return 0;
+ }
+ if (*n == 0) {
+ return 0;
+ }
+ if (*n == 1) {
+ goto L160;
+ }
+
+/* ROTATE is true if any singular vectors desired, false otherwise */
+
+ rotate = *ncvt > 0 || *nru > 0 || *ncc > 0;
+
+/* If no singular vectors desired, use qd algorithm */
+
+ if (! rotate) {
+ dlasq1_(n, &d__[1], &e[1], &work[1], info);
+ return 0;
+ }
+
+ nm1 = *n - 1;
+ nm12 = nm1 + nm1;
+ nm13 = nm12 + nm1;
+ idir = 0;
+
+/* Get machine constants */
+
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+
+/* If matrix lower bidiagonal, rotate to be upper bidiagonal */
+/* by applying Givens rotations on the left */
+
+ if (lower) {
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
+ d__[i__] = r__;
+ e[i__] = sn * d__[i__ + 1];
+ d__[i__ + 1] = cs * d__[i__ + 1];
+ work[i__] = cs;
+ work[nm1 + i__] = sn;
+/* L10: */
+ }
+
+/* Update singular vectors if desired */
+
+ if (*nru > 0) {
+ dlasr_("R", "V", "F", nru, n, &work[1], &work[*n], &u[u_offset],
+ ldu);
+ }
+ if (*ncc > 0) {
+ dlasr_("L", "V", "F", n, ncc, &work[1], &work[*n], &c__[c_offset],
+ ldc);
+ }
+ }
+
+/* Compute singular values to relative accuracy TOL */
+/* (By setting TOL to be negative, algorithm will compute */
+/* singular values to absolute accuracy ABS(TOL)*norm(input matrix)) */
+
+/* Computing MAX */
+/* Computing MIN */
+ d__3 = 100., d__4 = pow_dd(&eps, &c_b15);
+ d__1 = 10., d__2 = min(d__3,d__4);
+ tolmul = max(d__1,d__2);
+ tol = tolmul * eps;
+
+/* Compute approximate maximum, minimum singular values */
+
+ smax = 0.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = smax, d__3 = (d__1 = d__[i__], abs(d__1));
+ smax = max(d__2,d__3);
+/* L20: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = smax, d__3 = (d__1 = e[i__], abs(d__1));
+ smax = max(d__2,d__3);
+/* L30: */
+ }
+ sminl = 0.;
+ if (tol >= 0.) {
+
+/* Relative accuracy desired */
+
+ sminoa = abs(d__[1]);
+ if (sminoa == 0.) {
+ goto L50;
+ }
+ mu = sminoa;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ mu = (d__2 = d__[i__], abs(d__2)) * (mu / (mu + (d__1 = e[i__ - 1]
+ , abs(d__1))));
+ sminoa = min(sminoa,mu);
+ if (sminoa == 0.) {
+ goto L50;
+ }
+/* L40: */
+ }
+L50:
+ sminoa /= sqrt((doublereal) (*n));
+/* Computing MAX */
+ d__1 = tol * sminoa, d__2 = *n * 6 * *n * unfl;
+ thresh = max(d__1,d__2);
+ } else {
+
+/* Absolute accuracy desired */
+
+/* Computing MAX */
+ d__1 = abs(tol) * smax, d__2 = *n * 6 * *n * unfl;
+ thresh = max(d__1,d__2);
+ }
+
+/* Prepare for main iteration loop for the singular values */
+/* (MAXIT is the maximum number of passes through the inner */
+/* loop permitted before nonconvergence signalled.) */
+
+ maxit = *n * 6 * *n;
+ iter = 0;
+ oldll = -1;
+ oldm = -1;
+
+/* M points to last element of unconverged part of matrix */
+
+ m = *n;
+
+/* Begin main iteration loop */
+
+L60:
+
+/* Check for convergence or exceeding iteration count */
+
+ if (m <= 1) {
+ goto L160;
+ }
+ if (iter > maxit) {
+ goto L200;
+ }
+
+/* Find diagonal block of matrix to work on */
+
+ if (tol < 0. && (d__1 = d__[m], abs(d__1)) <= thresh) {
+ d__[m] = 0.;
+ }
+ smax = (d__1 = d__[m], abs(d__1));
+ smin = smax;
+ i__1 = m - 1;
+ for (lll = 1; lll <= i__1; ++lll) {
+ ll = m - lll;
+ abss = (d__1 = d__[ll], abs(d__1));
+ abse = (d__1 = e[ll], abs(d__1));
+ if (tol < 0. && abss <= thresh) {
+ d__[ll] = 0.;
+ }
+ if (abse <= thresh) {
+ goto L80;
+ }
+ smin = min(smin,abss);
+/* Computing MAX */
+ d__1 = max(smax,abss);
+ smax = max(d__1,abse);
+/* L70: */
+ }
+ ll = 0;
+ goto L90;
+L80:
+ e[ll] = 0.;
+
+/* Matrix splits since E(LL) = 0 */
+
+ if (ll == m - 1) {
+
+/* Convergence of bottom singular value, return to top of loop */
+
+ --m;
+ goto L60;
+ }
+L90:
+ ++ll;
+
+/* E(LL) through E(M-1) are nonzero, E(LL-1) is zero */
+
+ if (ll == m - 1) {
+
+/* 2 by 2 block, handle separately */
+
+ dlasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr,
+ &sinl, &cosl);
+ d__[m - 1] = sigmx;
+ e[m - 1] = 0.;
+ d__[m] = sigmn;
+
+/* Compute singular vectors, if desired */
+
+ if (*ncvt > 0) {
+ drot_(ncvt, &vt[m - 1 + vt_dim1], ldvt, &vt[m + vt_dim1], ldvt, &
+ cosr, &sinr);
+ }
+ if (*nru > 0) {
+ drot_(nru, &u[(m - 1) * u_dim1 + 1], &c__1, &u[m * u_dim1 + 1], &
+ c__1, &cosl, &sinl);
+ }
+ if (*ncc > 0) {
+ drot_(ncc, &c__[m - 1 + c_dim1], ldc, &c__[m + c_dim1], ldc, &
+ cosl, &sinl);
+ }
+ m += -2;
+ goto L60;
+ }
+
+/* If working on new submatrix, choose shift direction */
+/* (from larger end diagonal element towards smaller) */
+
+ if (ll > oldm || m < oldll) {
+ if ((d__1 = d__[ll], abs(d__1)) >= (d__2 = d__[m], abs(d__2))) {
+
+/* Chase bulge from top (big end) to bottom (small end) */
+
+ idir = 1;
+ } else {
+
+/* Chase bulge from bottom (big end) to top (small end) */
+
+ idir = 2;
+ }
+ }
+
+/* Apply convergence tests */
+
+ if (idir == 1) {
+
+/* Run convergence test in forward direction */
+/* First apply standard test to bottom of matrix */
+
+ if ((d__2 = e[m - 1], abs(d__2)) <= abs(tol) * (d__1 = d__[m], abs(
+ d__1)) || tol < 0. && (d__3 = e[m - 1], abs(d__3)) <= thresh)
+ {
+ e[m - 1] = 0.;
+ goto L60;
+ }
+
+ if (tol >= 0.) {
+
+/* If relative accuracy desired, */
+/* apply convergence criterion forward */
+
+ mu = (d__1 = d__[ll], abs(d__1));
+ sminl = mu;
+ i__1 = m - 1;
+ for (lll = ll; lll <= i__1; ++lll) {
+ if ((d__1 = e[lll], abs(d__1)) <= tol * mu) {
+ e[lll] = 0.;
+ goto L60;
+ }
+ mu = (d__2 = d__[lll + 1], abs(d__2)) * (mu / (mu + (d__1 = e[
+ lll], abs(d__1))));
+ sminl = min(sminl,mu);
+/* L100: */
+ }
+ }
+
+ } else {
+
+/* Run convergence test in backward direction */
+/* First apply standard test to top of matrix */
+
+ if ((d__2 = e[ll], abs(d__2)) <= abs(tol) * (d__1 = d__[ll], abs(d__1)
+ ) || tol < 0. && (d__3 = e[ll], abs(d__3)) <= thresh) {
+ e[ll] = 0.;
+ goto L60;
+ }
+
+ if (tol >= 0.) {
+
+/* If relative accuracy desired, */
+/* apply convergence criterion backward */
+
+ mu = (d__1 = d__[m], abs(d__1));
+ sminl = mu;
+ i__1 = ll;
+ for (lll = m - 1; lll >= i__1; --lll) {
+ if ((d__1 = e[lll], abs(d__1)) <= tol * mu) {
+ e[lll] = 0.;
+ goto L60;
+ }
+ mu = (d__2 = d__[lll], abs(d__2)) * (mu / (mu + (d__1 = e[lll]
+ , abs(d__1))));
+ sminl = min(sminl,mu);
+/* L110: */
+ }
+ }
+ }
+ oldll = ll;
+ oldm = m;
+
+/* Compute shift. First, test if shifting would ruin relative */
+/* accuracy, and if so set the shift to zero. */
+
+/* Computing MAX */
+ d__1 = eps, d__2 = tol * .01;
+ if (tol >= 0. && *n * tol * (sminl / smax) <= max(d__1,d__2)) {
+
+/* Use a zero shift to avoid loss of relative accuracy */
+
+ shift = 0.;
+ } else {
+
+/* Compute the shift from 2-by-2 block at end of matrix */
+
+ if (idir == 1) {
+ sll = (d__1 = d__[ll], abs(d__1));
+ dlas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__);
+ } else {
+ sll = (d__1 = d__[m], abs(d__1));
+ dlas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__);
+ }
+
+/* Test if shift negligible, and if so set to zero */
+
+ if (sll > 0.) {
+/* Computing 2nd power */
+ d__1 = shift / sll;
+ if (d__1 * d__1 < eps) {
+ shift = 0.;
+ }
+ }
+ }
+
+/* Increment iteration count */
+
+ iter = iter + m - ll;
+
+/* If SHIFT = 0, do simplified QR iteration */
+
+ if (shift == 0.) {
+ if (idir == 1) {
+
+/* Chase bulge from top to bottom */
+/* Save cosines and sines for later singular vector updates */
+
+ cs = 1.;
+ oldcs = 1.;
+ i__1 = m - 1;
+ for (i__ = ll; i__ <= i__1; ++i__) {
+ d__1 = d__[i__] * cs;
+ dlartg_(&d__1, &e[i__], &cs, &sn, &r__);
+ if (i__ > ll) {
+ e[i__ - 1] = oldsn * r__;
+ }
+ d__1 = oldcs * r__;
+ d__2 = d__[i__ + 1] * sn;
+ dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
+ work[i__ - ll + 1] = cs;
+ work[i__ - ll + 1 + nm1] = sn;
+ work[i__ - ll + 1 + nm12] = oldcs;
+ work[i__ - ll + 1 + nm13] = oldsn;
+/* L120: */
+ }
+ h__ = d__[m] * cs;
+ d__[m] = h__ * oldcs;
+ e[m - 1] = h__ * oldsn;
+
+/* Update singular vectors */
+
+ if (*ncvt > 0) {
+ i__1 = m - ll + 1;
+ dlasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[
+ ll + vt_dim1], ldvt);
+ }
+ if (*nru > 0) {
+ i__1 = m - ll + 1;
+ dlasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13
+ + 1], &u[ll * u_dim1 + 1], ldu);
+ }
+ if (*ncc > 0) {
+ i__1 = m - ll + 1;
+ dlasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13
+ + 1], &c__[ll + c_dim1], ldc);
+ }
+
+/* Test convergence */
+
+ if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
+ e[m - 1] = 0.;
+ }
+
+ } else {
+
+/* Chase bulge from bottom to top */
+/* Save cosines and sines for later singular vector updates */
+
+ cs = 1.;
+ oldcs = 1.;
+ i__1 = ll + 1;
+ for (i__ = m; i__ >= i__1; --i__) {
+ d__1 = d__[i__] * cs;
+ dlartg_(&d__1, &e[i__ - 1], &cs, &sn, &r__);
+ if (i__ < m) {
+ e[i__] = oldsn * r__;
+ }
+ d__1 = oldcs * r__;
+ d__2 = d__[i__ - 1] * sn;
+ dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
+ work[i__ - ll] = cs;
+ work[i__ - ll + nm1] = -sn;
+ work[i__ - ll + nm12] = oldcs;
+ work[i__ - ll + nm13] = -oldsn;
+/* L130: */
+ }
+ h__ = d__[ll] * cs;
+ d__[ll] = h__ * oldcs;
+ e[ll] = h__ * oldsn;
+
+/* Update singular vectors */
+
+ if (*ncvt > 0) {
+ i__1 = m - ll + 1;
+ dlasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[
+ nm13 + 1], &vt[ll + vt_dim1], ldvt);
+ }
+ if (*nru > 0) {
+ i__1 = m - ll + 1;
+ dlasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll *
+ u_dim1 + 1], ldu);
+ }
+ if (*ncc > 0) {
+ i__1 = m - ll + 1;
+ dlasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &c__[
+ ll + c_dim1], ldc);
+ }
+
+/* Test convergence */
+
+ if ((d__1 = e[ll], abs(d__1)) <= thresh) {
+ e[ll] = 0.;
+ }
+ }
+ } else {
+
+/* Use nonzero shift */
+
+ if (idir == 1) {
+
+/* Chase bulge from top to bottom */
+/* Save cosines and sines for later singular vector updates */
+
+ f = ((d__1 = d__[ll], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[
+ ll]) + shift / d__[ll]);
+ g = e[ll];
+ i__1 = m - 1;
+ for (i__ = ll; i__ <= i__1; ++i__) {
+ dlartg_(&f, &g, &cosr, &sinr, &r__);
+ if (i__ > ll) {
+ e[i__ - 1] = r__;
+ }
+ f = cosr * d__[i__] + sinr * e[i__];
+ e[i__] = cosr * e[i__] - sinr * d__[i__];
+ g = sinr * d__[i__ + 1];
+ d__[i__ + 1] = cosr * d__[i__ + 1];
+ dlartg_(&f, &g, &cosl, &sinl, &r__);
+ d__[i__] = r__;
+ f = cosl * e[i__] + sinl * d__[i__ + 1];
+ d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__];
+ if (i__ < m - 1) {
+ g = sinl * e[i__ + 1];
+ e[i__ + 1] = cosl * e[i__ + 1];
+ }
+ work[i__ - ll + 1] = cosr;
+ work[i__ - ll + 1 + nm1] = sinr;
+ work[i__ - ll + 1 + nm12] = cosl;
+ work[i__ - ll + 1 + nm13] = sinl;
+/* L140: */
+ }
+ e[m - 1] = f;
+
+/* Update singular vectors */
+
+ if (*ncvt > 0) {
+ i__1 = m - ll + 1;
+ dlasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[
+ ll + vt_dim1], ldvt);
+ }
+ if (*nru > 0) {
+ i__1 = m - ll + 1;
+ dlasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13
+ + 1], &u[ll * u_dim1 + 1], ldu);
+ }
+ if (*ncc > 0) {
+ i__1 = m - ll + 1;
+ dlasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13
+ + 1], &c__[ll + c_dim1], ldc);
+ }
+
+/* Test convergence */
+
+ if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
+ e[m - 1] = 0.;
+ }
+
+ } else {
+
+/* Chase bulge from bottom to top */
+/* Save cosines and sines for later singular vector updates */
+
+ f = ((d__1 = d__[m], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[m]
+ ) + shift / d__[m]);
+ g = e[m - 1];
+ i__1 = ll + 1;
+ for (i__ = m; i__ >= i__1; --i__) {
+ dlartg_(&f, &g, &cosr, &sinr, &r__);
+ if (i__ < m) {
+ e[i__] = r__;
+ }
+ f = cosr * d__[i__] + sinr * e[i__ - 1];
+ e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__];
+ g = sinr * d__[i__ - 1];
+ d__[i__ - 1] = cosr * d__[i__ - 1];
+ dlartg_(&f, &g, &cosl, &sinl, &r__);
+ d__[i__] = r__;
+ f = cosl * e[i__ - 1] + sinl * d__[i__ - 1];
+ d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1];
+ if (i__ > ll + 1) {
+ g = sinl * e[i__ - 2];
+ e[i__ - 2] = cosl * e[i__ - 2];
+ }
+ work[i__ - ll] = cosr;
+ work[i__ - ll + nm1] = -sinr;
+ work[i__ - ll + nm12] = cosl;
+ work[i__ - ll + nm13] = -sinl;
+/* L150: */
+ }
+ e[ll] = f;
+
+/* Test convergence */
+
+ if ((d__1 = e[ll], abs(d__1)) <= thresh) {
+ e[ll] = 0.;
+ }
+
+/* Update singular vectors if desired */
+
+ if (*ncvt > 0) {
+ i__1 = m - ll + 1;
+ dlasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[
+ nm13 + 1], &vt[ll + vt_dim1], ldvt);
+ }
+ if (*nru > 0) {
+ i__1 = m - ll + 1;
+ dlasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll *
+ u_dim1 + 1], ldu);
+ }
+ if (*ncc > 0) {
+ i__1 = m - ll + 1;
+ dlasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &c__[
+ ll + c_dim1], ldc);
+ }
+ }
+ }
+
+/* QR iteration finished, go back and check convergence */
+
+ goto L60;
+
+/* All singular values converged, so make them positive */
+
+L160:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (d__[i__] < 0.) {
+ d__[i__] = -d__[i__];
+
+/* Change sign of singular vectors, if desired */
+
+ if (*ncvt > 0) {
+ dscal_(ncvt, &c_b72, &vt[i__ + vt_dim1], ldvt);
+ }
+ }
+/* L170: */
+ }
+
+/* Sort the singular values into decreasing order (insertion sort on */
+/* singular values, but only one transposition per singular vector) */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Scan for smallest D(I) */
+
+ isub = 1;
+ smin = d__[1];
+ i__2 = *n + 1 - i__;
+ for (j = 2; j <= i__2; ++j) {
+ if (d__[j] <= smin) {
+ isub = j;
+ smin = d__[j];
+ }
+/* L180: */
+ }
+ if (isub != *n + 1 - i__) {
+
+/* Swap singular values and vectors */
+
+ d__[isub] = d__[*n + 1 - i__];
+ d__[*n + 1 - i__] = smin;
+ if (*ncvt > 0) {
+ dswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[*n + 1 - i__ +
+ vt_dim1], ldvt);
+ }
+ if (*nru > 0) {
+ dswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[(*n + 1 - i__) *
+ u_dim1 + 1], &c__1);
+ }
+ if (*ncc > 0) {
+ dswap_(ncc, &c__[isub + c_dim1], ldc, &c__[*n + 1 - i__ +
+ c_dim1], ldc);
+ }
+ }
+/* L190: */
+ }
+ goto L220;
+
+/* Maximum number of iterations exceeded, failure to converge */
+
+L200:
+ *info = 0;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (e[i__] != 0.) {
+ ++(*info);
+ }
+/* L210: */
+ }
+L220:
+ return 0;
+
+/* End of DBDSQR */
+
+} /* dbdsqr_ */
diff --git a/SRC/ddisna.c b/SRC/ddisna.c
new file mode 100644
index 0000000..ad7c367
--- /dev/null
+++ b/SRC/ddisna.c
@@ -0,0 +1,227 @@
+/* ddisna.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ddisna_(char *job, integer *m, integer *n, doublereal *
+ d__, doublereal *sep, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, k;
+ doublereal eps;
+ logical decr, left, incr, sing, eigen;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ logical right;
+ extern doublereal dlamch_(char *);
+ doublereal oldgap, safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal newgap, thresh;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDISNA computes the reciprocal condition numbers for the eigenvectors */
+/* of a real symmetric or complex Hermitian matrix or for the left or */
+/* right singular vectors of a general m-by-n matrix. The reciprocal */
+/* condition number is the 'gap' between the corresponding eigenvalue or */
+/* singular value and the nearest other one. */
+
+/* The bound on the error, measured by angle in radians, in the I-th */
+/* computed vector is given by */
+
+/* DLAMCH( 'E' ) * ( ANORM / SEP( I ) ) */
+
+/* where ANORM = 2-norm(A) = max( abs( D(j) ) ). SEP(I) is not allowed */
+/* to be smaller than DLAMCH( 'E' )*ANORM in order to limit the size of */
+/* the error bound. */
+
+/* DDISNA may also be used to compute error bounds for eigenvectors of */
+/* the generalized symmetric definite eigenproblem. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies for which problem the reciprocal condition numbers */
+/* should be computed: */
+/* = 'E': the eigenvectors of a symmetric/Hermitian matrix; */
+/* = 'L': the left singular vectors of a general matrix; */
+/* = 'R': the right singular vectors of a general matrix. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix. M >= 0. */
+
+/* N (input) INTEGER */
+/* If JOB = 'L' or 'R', the number of columns of the matrix, */
+/* in which case N >= 0. Ignored if JOB = 'E'. */
+
+/* D (input) DOUBLE PRECISION array, dimension (M) if JOB = 'E' */
+/* dimension (min(M,N)) if JOB = 'L' or 'R' */
+/* The eigenvalues (if JOB = 'E') or singular values (if JOB = */
+/* 'L' or 'R') of the matrix, in either increasing or decreasing */
+/* order. If singular values, they must be non-negative. */
+
+/* SEP (output) DOUBLE PRECISION array, dimension (M) if JOB = 'E' */
+/* dimension (min(M,N)) if JOB = 'L' or 'R' */
+/* The reciprocal condition numbers of the vectors. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --sep;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+ eigen = lsame_(job, "E");
+ left = lsame_(job, "L");
+ right = lsame_(job, "R");
+ sing = left || right;
+ if (eigen) {
+ k = *m;
+ } else if (sing) {
+ k = min(*m,*n);
+ }
+ if (! eigen && ! sing) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (k < 0) {
+ *info = -3;
+ } else {
+ incr = TRUE_;
+ decr = TRUE_;
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (incr) {
+ incr = incr && d__[i__] <= d__[i__ + 1];
+ }
+ if (decr) {
+ decr = decr && d__[i__] >= d__[i__ + 1];
+ }
+/* L10: */
+ }
+ if (sing && k > 0) {
+ if (incr) {
+ incr = incr && 0. <= d__[1];
+ }
+ if (decr) {
+ decr = decr && d__[k] >= 0.;
+ }
+ }
+ if (! (incr || decr)) {
+ *info = -4;
+ }
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DDISNA", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (k == 0) {
+ return 0;
+ }
+
+/* Compute reciprocal condition numbers */
+
+ if (k == 1) {
+ sep[1] = dlamch_("O");
+ } else {
+ oldgap = (d__1 = d__[2] - d__[1], abs(d__1));
+ sep[1] = oldgap;
+ i__1 = k - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ newgap = (d__1 = d__[i__ + 1] - d__[i__], abs(d__1));
+ sep[i__] = min(oldgap,newgap);
+ oldgap = newgap;
+/* L20: */
+ }
+ sep[k] = oldgap;
+ }
+ if (sing) {
+ if (left && *m > *n || right && *m < *n) {
+ if (incr) {
+ sep[1] = min(sep[1],d__[1]);
+ }
+ if (decr) {
+/* Computing MIN */
+ d__1 = sep[k], d__2 = d__[k];
+ sep[k] = min(d__1,d__2);
+ }
+ }
+ }
+
+/* Ensure that reciprocal condition numbers are not less than */
+/* threshold, in order to limit the size of the error bound */
+
+ eps = dlamch_("E");
+ safmin = dlamch_("S");
+/* Computing MAX */
+ d__2 = abs(d__[1]), d__3 = (d__1 = d__[k], abs(d__1));
+ anorm = max(d__2,d__3);
+ if (anorm == 0.) {
+ thresh = eps;
+ } else {
+/* Computing MAX */
+ d__1 = eps * anorm;
+ thresh = max(d__1,safmin);
+ }
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = sep[i__];
+ sep[i__] = max(d__1,thresh);
+/* L30: */
+ }
+
+ return 0;
+
+/* End of DDISNA */
+
+} /* ddisna_ */
diff --git a/SRC/dgbbrd.c b/SRC/dgbbrd.c
new file mode 100644
index 0000000..03e09a7
--- /dev/null
+++ b/SRC/dgbbrd.c
@@ -0,0 +1,566 @@
+/* dgbbrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b8 = 0.;
+static doublereal c_b9 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dgbbrd_(char *vect, integer *m, integer *n, integer *ncc,
+ integer *kl, integer *ku, doublereal *ab, integer *ldab, doublereal *
+ d__, doublereal *e, doublereal *q, integer *ldq, doublereal *pt,
+ integer *ldpt, doublereal *c__, integer *ldc, doublereal *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, c_dim1, c_offset, pt_dim1, pt_offset, q_dim1,
+ q_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+
+ /* Local variables */
+ integer i__, j, l, j1, j2, kb;
+ doublereal ra, rb, rc;
+ integer kk, ml, mn, nr, mu;
+ doublereal rs;
+ integer kb1, ml0, mu0, klm, kun, nrt, klu1, inca;
+ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ extern logical lsame_(char *, char *);
+ logical wantb, wantc;
+ integer minmn;
+ logical wantq;
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ dlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *), xerbla_(char *, integer *), dlargv_(
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *), dlartv_(integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ logical wantpt;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGBBRD reduces a real general m-by-n band matrix A to upper */
+/* bidiagonal form B by an orthogonal transformation: Q' * A * P = B. */
+
+/* The routine computes B, and optionally forms Q or P', or computes */
+/* Q'*C for a given matrix C. */
+
+/* Arguments */
+/* ========= */
+
+/* VECT (input) CHARACTER*1 */
+/* Specifies whether or not the matrices Q and P' are to be */
+/* formed. */
+/* = 'N': do not form Q or P'; */
+/* = 'Q': form Q only; */
+/* = 'P': form P' only; */
+/* = 'B': form both. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NCC (input) INTEGER */
+/* The number of columns of the matrix C. NCC >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals of the matrix A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals of the matrix A. KU >= 0. */
+
+/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* On entry, the m-by-n band matrix A, stored in rows 1 to */
+/* KL+KU+1. The j-th column of A is stored in the j-th column of */
+/* the array AB as follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). */
+/* On exit, A is overwritten by values generated during the */
+/* reduction. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array A. LDAB >= KL+KU+1. */
+
+/* D (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The diagonal elements of the bidiagonal matrix B. */
+
+/* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) */
+/* The superdiagonal elements of the bidiagonal matrix B. */
+
+/* Q (output) DOUBLE PRECISION array, dimension (LDQ,M) */
+/* If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q. */
+/* If VECT = 'N' or 'P', the array Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. */
+/* LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise. */
+
+/* PT (output) DOUBLE PRECISION array, dimension (LDPT,N) */
+/* If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'. */
+/* If VECT = 'N' or 'Q', the array PT is not referenced. */
+
+/* LDPT (input) INTEGER */
+/* The leading dimension of the array PT. */
+/* LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise. */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC,NCC) */
+/* On entry, an m-by-ncc matrix C. */
+/* On exit, C is overwritten by Q'*C. */
+/* C is not referenced if NCC = 0. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. */
+/* LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (2*max(M,N)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --d__;
+ --e;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ pt_dim1 = *ldpt;
+ pt_offset = 1 + pt_dim1;
+ pt -= pt_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ wantb = lsame_(vect, "B");
+ wantq = lsame_(vect, "Q") || wantb;
+ wantpt = lsame_(vect, "P") || wantb;
+ wantc = *ncc > 0;
+ klu1 = *kl + *ku + 1;
+ *info = 0;
+ if (! wantq && ! wantpt && ! lsame_(vect, "N")) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ncc < 0) {
+ *info = -4;
+ } else if (*kl < 0) {
+ *info = -5;
+ } else if (*ku < 0) {
+ *info = -6;
+ } else if (*ldab < klu1) {
+ *info = -8;
+ } else if (*ldq < 1 || wantq && *ldq < max(1,*m)) {
+ *info = -12;
+ } else if (*ldpt < 1 || wantpt && *ldpt < max(1,*n)) {
+ *info = -14;
+ } else if (*ldc < 1 || wantc && *ldc < max(1,*m)) {
+ *info = -16;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGBBRD", &i__1);
+ return 0;
+ }
+
+/* Initialize Q and P' to the unit matrix, if needed */
+
+ if (wantq) {
+ dlaset_("Full", m, m, &c_b8, &c_b9, &q[q_offset], ldq);
+ }
+ if (wantpt) {
+ dlaset_("Full", n, n, &c_b8, &c_b9, &pt[pt_offset], ldpt);
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ minmn = min(*m,*n);
+
+ if (*kl + *ku > 1) {
+
+/* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce */
+/* first to lower bidiagonal form and then transform to upper */
+/* bidiagonal */
+
+ if (*ku > 0) {
+ ml0 = 1;
+ mu0 = 2;
+ } else {
+ ml0 = 2;
+ mu0 = 1;
+ }
+
+/* Wherever possible, plane rotations are generated and applied in */
+/* vector operations of length NR over the index set J1:J2:KLU1. */
+
+/* The sines of the plane rotations are stored in WORK(1:max(m,n)) */
+/* and the cosines in WORK(max(m,n)+1:2*max(m,n)). */
+
+ mn = max(*m,*n);
+/* Computing MIN */
+ i__1 = *m - 1;
+ klm = min(i__1,*kl);
+/* Computing MIN */
+ i__1 = *n - 1;
+ kun = min(i__1,*ku);
+ kb = klm + kun;
+ kb1 = kb + 1;
+ inca = kb1 * *ldab;
+ nr = 0;
+ j1 = klm + 2;
+ j2 = 1 - kun;
+
+ i__1 = minmn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Reduce i-th column and i-th row of matrix to bidiagonal form */
+
+ ml = klm + 1;
+ mu = kun + 1;
+ i__2 = kb;
+ for (kk = 1; kk <= i__2; ++kk) {
+ j1 += kb;
+ j2 += kb;
+
+/* generate plane rotations to annihilate nonzero elements */
+/* which have been created below the band */
+
+ if (nr > 0) {
+ dlargv_(&nr, &ab[klu1 + (j1 - klm - 1) * ab_dim1], &inca,
+ &work[j1], &kb1, &work[mn + j1], &kb1);
+ }
+
+/* apply plane rotations from the left */
+
+ i__3 = kb;
+ for (l = 1; l <= i__3; ++l) {
+ if (j2 - klm + l - 1 > *n) {
+ nrt = nr - 1;
+ } else {
+ nrt = nr;
+ }
+ if (nrt > 0) {
+ dlartv_(&nrt, &ab[klu1 - l + (j1 - klm + l - 1) *
+ ab_dim1], &inca, &ab[klu1 - l + 1 + (j1 - klm
+ + l - 1) * ab_dim1], &inca, &work[mn + j1], &
+ work[j1], &kb1);
+ }
+/* L10: */
+ }
+
+ if (ml > ml0) {
+ if (ml <= *m - i__ + 1) {
+
+/* generate plane rotation to annihilate a(i+ml-1,i) */
+/* within the band, and apply rotation from the left */
+
+ dlartg_(&ab[*ku + ml - 1 + i__ * ab_dim1], &ab[*ku +
+ ml + i__ * ab_dim1], &work[mn + i__ + ml - 1],
+ &work[i__ + ml - 1], &ra);
+ ab[*ku + ml - 1 + i__ * ab_dim1] = ra;
+ if (i__ < *n) {
+/* Computing MIN */
+ i__4 = *ku + ml - 2, i__5 = *n - i__;
+ i__3 = min(i__4,i__5);
+ i__6 = *ldab - 1;
+ i__7 = *ldab - 1;
+ drot_(&i__3, &ab[*ku + ml - 2 + (i__ + 1) *
+ ab_dim1], &i__6, &ab[*ku + ml - 1 + (i__
+ + 1) * ab_dim1], &i__7, &work[mn + i__ +
+ ml - 1], &work[i__ + ml - 1]);
+ }
+ }
+ ++nr;
+ j1 -= kb1;
+ }
+
+ if (wantq) {
+
+/* accumulate product of plane rotations in Q */
+
+ i__3 = j2;
+ i__4 = kb1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4)
+ {
+ drot_(m, &q[(j - 1) * q_dim1 + 1], &c__1, &q[j *
+ q_dim1 + 1], &c__1, &work[mn + j], &work[j]);
+/* L20: */
+ }
+ }
+
+ if (wantc) {
+
+/* apply plane rotations to C */
+
+ i__4 = j2;
+ i__3 = kb1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3)
+ {
+ drot_(ncc, &c__[j - 1 + c_dim1], ldc, &c__[j + c_dim1]
+, ldc, &work[mn + j], &work[j]);
+/* L30: */
+ }
+ }
+
+ if (j2 + kun > *n) {
+
+/* adjust J2 to keep within the bounds of the matrix */
+
+ --nr;
+ j2 -= kb1;
+ }
+
+ i__3 = j2;
+ i__4 = kb1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+
+/* create nonzero element a(j-1,j+ku) above the band */
+/* and store it in WORK(n+1:2*n) */
+
+ work[j + kun] = work[j] * ab[(j + kun) * ab_dim1 + 1];
+ ab[(j + kun) * ab_dim1 + 1] = work[mn + j] * ab[(j + kun)
+ * ab_dim1 + 1];
+/* L40: */
+ }
+
+/* generate plane rotations to annihilate nonzero elements */
+/* which have been generated above the band */
+
+ if (nr > 0) {
+ dlargv_(&nr, &ab[(j1 + kun - 1) * ab_dim1 + 1], &inca, &
+ work[j1 + kun], &kb1, &work[mn + j1 + kun], &kb1);
+ }
+
+/* apply plane rotations from the right */
+
+ i__4 = kb;
+ for (l = 1; l <= i__4; ++l) {
+ if (j2 + l - 1 > *m) {
+ nrt = nr - 1;
+ } else {
+ nrt = nr;
+ }
+ if (nrt > 0) {
+ dlartv_(&nrt, &ab[l + 1 + (j1 + kun - 1) * ab_dim1], &
+ inca, &ab[l + (j1 + kun) * ab_dim1], &inca, &
+ work[mn + j1 + kun], &work[j1 + kun], &kb1);
+ }
+/* L50: */
+ }
+
+ if (ml == ml0 && mu > mu0) {
+ if (mu <= *n - i__ + 1) {
+
+/* generate plane rotation to annihilate a(i,i+mu-1) */
+/* within the band, and apply rotation from the right */
+
+ dlartg_(&ab[*ku - mu + 3 + (i__ + mu - 2) * ab_dim1],
+ &ab[*ku - mu + 2 + (i__ + mu - 1) * ab_dim1],
+ &work[mn + i__ + mu - 1], &work[i__ + mu - 1],
+ &ra);
+ ab[*ku - mu + 3 + (i__ + mu - 2) * ab_dim1] = ra;
+/* Computing MIN */
+ i__3 = *kl + mu - 2, i__5 = *m - i__;
+ i__4 = min(i__3,i__5);
+ drot_(&i__4, &ab[*ku - mu + 4 + (i__ + mu - 2) *
+ ab_dim1], &c__1, &ab[*ku - mu + 3 + (i__ + mu
+ - 1) * ab_dim1], &c__1, &work[mn + i__ + mu -
+ 1], &work[i__ + mu - 1]);
+ }
+ ++nr;
+ j1 -= kb1;
+ }
+
+ if (wantpt) {
+
+/* accumulate product of plane rotations in P' */
+
+ i__4 = j2;
+ i__3 = kb1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3)
+ {
+ drot_(n, &pt[j + kun - 1 + pt_dim1], ldpt, &pt[j +
+ kun + pt_dim1], ldpt, &work[mn + j + kun], &
+ work[j + kun]);
+/* L60: */
+ }
+ }
+
+ if (j2 + kb > *m) {
+
+/* adjust J2 to keep within the bounds of the matrix */
+
+ --nr;
+ j2 -= kb1;
+ }
+
+ i__3 = j2;
+ i__4 = kb1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+
+/* create nonzero element a(j+kl+ku,j+ku-1) below the */
+/* band and store it in WORK(1:n) */
+
+ work[j + kb] = work[j + kun] * ab[klu1 + (j + kun) *
+ ab_dim1];
+ ab[klu1 + (j + kun) * ab_dim1] = work[mn + j + kun] * ab[
+ klu1 + (j + kun) * ab_dim1];
+/* L70: */
+ }
+
+ if (ml > ml0) {
+ --ml;
+ } else {
+ --mu;
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+
+ if (*ku == 0 && *kl > 0) {
+
+/* A has been reduced to lower bidiagonal form */
+
+/* Transform lower bidiagonal form to upper bidiagonal by applying */
+/* plane rotations from the left, storing diagonal elements in D */
+/* and off-diagonal elements in E */
+
+/* Computing MIN */
+ i__2 = *m - 1;
+ i__1 = min(i__2,*n);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dlartg_(&ab[i__ * ab_dim1 + 1], &ab[i__ * ab_dim1 + 2], &rc, &rs,
+ &ra);
+ d__[i__] = ra;
+ if (i__ < *n) {
+ e[i__] = rs * ab[(i__ + 1) * ab_dim1 + 1];
+ ab[(i__ + 1) * ab_dim1 + 1] = rc * ab[(i__ + 1) * ab_dim1 + 1]
+ ;
+ }
+ if (wantq) {
+ drot_(m, &q[i__ * q_dim1 + 1], &c__1, &q[(i__ + 1) * q_dim1 +
+ 1], &c__1, &rc, &rs);
+ }
+ if (wantc) {
+ drot_(ncc, &c__[i__ + c_dim1], ldc, &c__[i__ + 1 + c_dim1],
+ ldc, &rc, &rs);
+ }
+/* L100: */
+ }
+ if (*m <= *n) {
+ d__[*m] = ab[*m * ab_dim1 + 1];
+ }
+ } else if (*ku > 0) {
+
+/* A has been reduced to upper bidiagonal form */
+
+ if (*m < *n) {
+
+/* Annihilate a(m,m+1) by applying plane rotations from the */
+/* right, storing diagonal elements in D and off-diagonal */
+/* elements in E */
+
+ rb = ab[*ku + (*m + 1) * ab_dim1];
+ for (i__ = *m; i__ >= 1; --i__) {
+ dlartg_(&ab[*ku + 1 + i__ * ab_dim1], &rb, &rc, &rs, &ra);
+ d__[i__] = ra;
+ if (i__ > 1) {
+ rb = -rs * ab[*ku + i__ * ab_dim1];
+ e[i__ - 1] = rc * ab[*ku + i__ * ab_dim1];
+ }
+ if (wantpt) {
+ drot_(n, &pt[i__ + pt_dim1], ldpt, &pt[*m + 1 + pt_dim1],
+ ldpt, &rc, &rs);
+ }
+/* L110: */
+ }
+ } else {
+
+/* Copy off-diagonal elements to E and diagonal elements to D */
+
+ i__1 = minmn - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ e[i__] = ab[*ku + (i__ + 1) * ab_dim1];
+/* L120: */
+ }
+ i__1 = minmn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = ab[*ku + 1 + i__ * ab_dim1];
+/* L130: */
+ }
+ }
+ } else {
+
+/* A is diagonal. Set elements of E to zero and copy diagonal */
+/* elements to D. */
+
+ i__1 = minmn - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ e[i__] = 0.;
+/* L140: */
+ }
+ i__1 = minmn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = ab[i__ * ab_dim1 + 1];
+/* L150: */
+ }
+ }
+ return 0;
+
+/* End of DGBBRD */
+
+} /* dgbbrd_ */
diff --git a/SRC/dgbcon.c b/SRC/dgbcon.c
new file mode 100644
index 0000000..8b6144c
--- /dev/null
+++ b/SRC/dgbcon.c
@@ -0,0 +1,284 @@
+/* dgbcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dgbcon_(char *norm, integer *n, integer *kl, integer *ku,
+ doublereal *ab, integer *ldab, integer *ipiv, doublereal *anorm,
+ doublereal *rcond, doublereal *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Local variables */
+ integer j;
+ doublereal t;
+ integer kd, lm, jp, ix, kase;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer kase1;
+ doublereal scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int drscl_(integer *, doublereal *, doublereal *,
+ integer *);
+ logical lnoti;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *), dlacn2_(integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ integer *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dlatbs_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
+ doublereal ainvnm;
+ logical onenrm;
+ char normin[1];
+ doublereal smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGBCON estimates the reciprocal of the condition number of a real */
+/* general band matrix A, in either the 1-norm or the infinity-norm, */
+/* using the LU factorization computed by DGBTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as */
+/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by DGBTRF. U is stored as an upper triangular band */
+/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
+/* the multipliers used during the factorization are stored in */
+/* rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= N, row i of the matrix was */
+/* interchanged with row IPIV(i). */
+
+/* ANORM (input) DOUBLE PRECISION */
+/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */
+/* If NORM = 'I', the infinity-norm of the original matrix A. */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --ipiv;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*ldab < (*kl << 1) + *ku + 1) {
+ *info = -6;
+ } else if (*anorm < 0.) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGBCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.;
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ } else if (*anorm == 0.) {
+ return 0;
+ }
+
+ smlnum = dlamch_("Safe minimum");
+
+/* Estimate the norm of inv(A). */
+
+ ainvnm = 0.;
+ *(unsigned char *)normin = 'N';
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kd = *kl + *ku + 1;
+ lnoti = *kl > 0;
+ kase = 0;
+L10:
+ dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(L). */
+
+ if (lnoti) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *kl, i__3 = *n - j;
+ lm = min(i__2,i__3);
+ jp = ipiv[j];
+ t = work[jp];
+ if (jp != j) {
+ work[jp] = work[j];
+ work[j] = t;
+ }
+ d__1 = -t;
+ daxpy_(&lm, &d__1, &ab[kd + 1 + j * ab_dim1], &c__1, &
+ work[j + 1], &c__1);
+/* L20: */
+ }
+ }
+
+/* Multiply by inv(U). */
+
+ i__1 = *kl + *ku;
+ dlatbs_("Upper", "No transpose", "Non-unit", normin, n, &i__1, &
+ ab[ab_offset], ldab, &work[1], &scale, &work[(*n << 1) +
+ 1], info);
+ } else {
+
+/* Multiply by inv(U'). */
+
+ i__1 = *kl + *ku;
+ dlatbs_("Upper", "Transpose", "Non-unit", normin, n, &i__1, &ab[
+ ab_offset], ldab, &work[1], &scale, &work[(*n << 1) + 1],
+ info);
+
+/* Multiply by inv(L'). */
+
+ if (lnoti) {
+ for (j = *n - 1; j >= 1; --j) {
+/* Computing MIN */
+ i__1 = *kl, i__2 = *n - j;
+ lm = min(i__1,i__2);
+ work[j] -= ddot_(&lm, &ab[kd + 1 + j * ab_dim1], &c__1, &
+ work[j + 1], &c__1);
+ jp = ipiv[j];
+ if (jp != j) {
+ t = work[jp];
+ work[jp] = work[j];
+ work[j] = t;
+ }
+/* L30: */
+ }
+ }
+ }
+
+/* Divide X by 1/SCALE if doing so will not cause overflow. */
+
+ *(unsigned char *)normin = 'Y';
+ if (scale != 1.) {
+ ix = idamax_(n, &work[1], &c__1);
+ if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.)
+ {
+ goto L40;
+ }
+ drscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / ainvnm / *anorm;
+ }
+
+L40:
+ return 0;
+
+/* End of DGBCON */
+
+} /* dgbcon_ */
diff --git a/SRC/dgbequ.c b/SRC/dgbequ.c
new file mode 100644
index 0000000..d104537
--- /dev/null
+++ b/SRC/dgbequ.c
@@ -0,0 +1,320 @@
+/* dgbequ.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgbequ_(integer *m, integer *n, integer *kl, integer *ku,
+ doublereal *ab, integer *ldab, doublereal *r__, doublereal *c__,
+ doublereal *rowcnd, doublereal *colcnd, doublereal *amax, integer *
+ info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, kd;
+ doublereal rcmin, rcmax;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum, smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGBEQU computes row and column scalings intended to equilibrate an */
+/* M-by-N band matrix A and reduce its condition number. R returns the */
+/* row scale factors and C the column scale factors, chosen to try to */
+/* make the largest element in each row and column of the matrix B with */
+/* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. */
+
+/* R(i) and C(j) are restricted to be between SMLNUM = smallest safe */
+/* number and BIGNUM = largest safe number. Use of these scaling */
+/* factors is not guaranteed to reduce the condition number of A but */
+/* works well in practice. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The band matrix A, stored in rows 1 to KL+KU+1. The j-th */
+/* column of A is stored in the j-th column of the array AB as */
+/* follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* R (output) DOUBLE PRECISION array, dimension (M) */
+/* If INFO = 0, or INFO > M, R contains the row scale factors */
+/* for A. */
+
+/* C (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, C contains the column scale factors for A. */
+
+/* ROWCND (output) DOUBLE PRECISION */
+/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */
+/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */
+/* AMAX is neither too large nor too small, it is not worth */
+/* scaling by R. */
+
+/* COLCND (output) DOUBLE PRECISION */
+/* If INFO = 0, COLCND contains the ratio of the smallest */
+/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */
+/* worth scaling by C. */
+
+/* AMAX (output) DOUBLE PRECISION */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= M: the i-th row of A is exactly zero */
+/* > M: the (i-M)-th column of A is exactly zero */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGBEQU", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ *rowcnd = 1.;
+ *colcnd = 1.;
+ *amax = 0.;
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+
+/* Compute row scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__[i__] = 0.;
+/* L10: */
+ }
+
+/* Find the maximum element in each row. */
+
+ kd = *ku + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j - *ku;
+/* Computing MIN */
+ i__4 = j + *kl;
+ i__3 = min(i__4,*m);
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ d__2 = r__[i__], d__3 = (d__1 = ab[kd + i__ - j + j * ab_dim1],
+ abs(d__1));
+ r__[i__] = max(d__2,d__3);
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = rcmax, d__2 = r__[i__];
+ rcmax = max(d__1,d__2);
+/* Computing MIN */
+ d__1 = rcmin, d__2 = r__[i__];
+ rcmin = min(d__1,d__2);
+/* L40: */
+ }
+ *amax = rcmax;
+
+ if (rcmin == 0.) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] == 0.) {
+ *info = i__;
+ return 0;
+ }
+/* L50: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MIN */
+/* Computing MAX */
+ d__2 = r__[i__];
+ d__1 = max(d__2,smlnum);
+ r__[i__] = 1. / min(d__1,bignum);
+/* L60: */
+ }
+
+/* Compute ROWCND = min(R(I)) / max(R(I)) */
+
+ *rowcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ }
+
+/* Compute column scale factors */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 0.;
+/* L70: */
+ }
+
+/* Find the maximum element in each column, */
+/* assuming the row scaling computed above. */
+
+ kd = *ku + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__3 = j - *ku;
+/* Computing MIN */
+ i__4 = j + *kl;
+ i__2 = min(i__4,*m);
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = c__[j], d__3 = (d__1 = ab[kd + i__ - j + j * ab_dim1], abs(
+ d__1)) * r__[i__];
+ c__[j] = max(d__2,d__3);
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = c__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = c__[j];
+ rcmax = max(d__1,d__2);
+/* L100: */
+ }
+
+ if (rcmin == 0.) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (c__[j] == 0.) {
+ *info = *m + j;
+ return 0;
+ }
+/* L110: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+/* Computing MAX */
+ d__2 = c__[j];
+ d__1 = max(d__2,smlnum);
+ c__[j] = 1. / min(d__1,bignum);
+/* L120: */
+ }
+
+/* Compute COLCND = min(C(J)) / max(C(J)) */
+
+ *colcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ }
+
+ return 0;
+
+/* End of DGBEQU */
+
+} /* dgbequ_ */
diff --git a/SRC/dgbequb.c b/SRC/dgbequb.c
new file mode 100644
index 0000000..4a0f34b
--- /dev/null
+++ b/SRC/dgbequb.c
@@ -0,0 +1,347 @@
+/* dgbequb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgbequb_(integer *m, integer *n, integer *kl, integer *
+ ku, doublereal *ab, integer *ldab, doublereal *r__, doublereal *c__,
+ doublereal *rowcnd, doublereal *colcnd, doublereal *amax, integer *
+ info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double log(doublereal), pow_di(doublereal *, integer *);
+
+ /* Local variables */
+ integer i__, j, kd;
+ doublereal radix, rcmin, rcmax;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum, logrdx, smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGBEQUB computes row and column scalings intended to equilibrate an */
+/* M-by-N matrix A and reduce its condition number. R returns the row */
+/* scale factors and C the column scale factors, chosen to try to make */
+/* the largest element in each row and column of the matrix B with */
+/* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most */
+/* the radix. */
+
+/* R(i) and C(j) are restricted to be a power of the radix between */
+/* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use */
+/* of these scaling factors is not guaranteed to reduce the condition */
+/* number of A but works well in practice. */
+
+/* This routine differs from DGEEQU by restricting the scaling factors */
+/* to a power of the radix. Baring over- and underflow, scaling by */
+/* these factors introduces no additional rounding errors. However, the */
+/* scaled entries' magnitured are no longer approximately 1 but lie */
+/* between sqrt(radix) and 1/sqrt(radix). */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array A. LDAB >= max(1,M). */
+
+/* R (output) DOUBLE PRECISION array, dimension (M) */
+/* If INFO = 0 or INFO > M, R contains the row scale factors */
+/* for A. */
+
+/* C (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, C contains the column scale factors for A. */
+
+/* ROWCND (output) DOUBLE PRECISION */
+/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */
+/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */
+/* AMAX is neither too large nor too small, it is not worth */
+/* scaling by R. */
+
+/* COLCND (output) DOUBLE PRECISION */
+/* If INFO = 0, COLCND contains the ratio of the smallest */
+/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */
+/* worth scaling by C. */
+
+/* AMAX (output) DOUBLE PRECISION */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= M: the i-th row of A is exactly zero */
+/* > M: the (i-M)-th column of A is exactly zero */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGBEQUB", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ *rowcnd = 1.;
+ *colcnd = 1.;
+ *amax = 0.;
+ return 0;
+ }
+
+/* Get machine constants. Assume SMLNUM is a power of the radix. */
+
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+ radix = dlamch_("B");
+ logrdx = log(radix);
+
+/* Compute row scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__[i__] = 0.;
+/* L10: */
+ }
+
+/* Find the maximum element in each row. */
+
+ kd = *ku + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j - *ku;
+/* Computing MIN */
+ i__4 = j + *kl;
+ i__3 = min(i__4,*m);
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ d__2 = r__[i__], d__3 = (d__1 = ab[kd + i__ - j + j * ab_dim1],
+ abs(d__1));
+ r__[i__] = max(d__2,d__3);
+/* L20: */
+ }
+/* L30: */
+ }
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] > 0.) {
+ i__3 = (integer) (log(r__[i__]) / logrdx);
+ r__[i__] = pow_di(&radix, &i__3);
+ }
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = rcmax, d__2 = r__[i__];
+ rcmax = max(d__1,d__2);
+/* Computing MIN */
+ d__1 = rcmin, d__2 = r__[i__];
+ rcmin = min(d__1,d__2);
+/* L40: */
+ }
+ *amax = rcmax;
+
+ if (rcmin == 0.) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] == 0.) {
+ *info = i__;
+ return 0;
+ }
+/* L50: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MIN */
+/* Computing MAX */
+ d__2 = r__[i__];
+ d__1 = max(d__2,smlnum);
+ r__[i__] = 1. / min(d__1,bignum);
+/* L60: */
+ }
+
+/* Compute ROWCND = min(R(I)) / max(R(I)). */
+
+ *rowcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ }
+
+/* Compute column scale factors. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 0.;
+/* L70: */
+ }
+
+/* Find the maximum element in each column, */
+/* assuming the row scaling computed above. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__3 = j - *ku;
+/* Computing MIN */
+ i__4 = j + *kl;
+ i__2 = min(i__4,*m);
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = c__[j], d__3 = (d__1 = ab[kd + i__ - j + j * ab_dim1], abs(
+ d__1)) * r__[i__];
+ c__[j] = max(d__2,d__3);
+/* L80: */
+ }
+ if (c__[j] > 0.) {
+ i__2 = (integer) (log(c__[j]) / logrdx);
+ c__[j] = pow_di(&radix, &i__2);
+ }
+/* L90: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = c__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = c__[j];
+ rcmax = max(d__1,d__2);
+/* L100: */
+ }
+
+ if (rcmin == 0.) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (c__[j] == 0.) {
+ *info = *m + j;
+ return 0;
+ }
+/* L110: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+/* Computing MAX */
+ d__2 = c__[j];
+ d__1 = max(d__2,smlnum);
+ c__[j] = 1. / min(d__1,bignum);
+/* L120: */
+ }
+
+/* Compute COLCND = min(C(J)) / max(C(J)). */
+
+ *colcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ }
+
+ return 0;
+
+/* End of DGBEQUB */
+
+} /* dgbequb_ */
diff --git a/SRC/dgbrfs.c b/SRC/dgbrfs.c
new file mode 100644
index 0000000..e95b2dc
--- /dev/null
+++ b/SRC/dgbrfs.c
@@ -0,0 +1,455 @@
+/* dgbrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b15 = -1.;
+static doublereal c_b17 = 1.;
+
+/* Subroutine */ int dgbrfs_(char *trans, integer *n, integer *kl, integer *
+ ku, integer *nrhs, doublereal *ab, integer *ldab, doublereal *afb,
+ integer *ldafb, integer *ipiv, doublereal *b, integer *ldb,
+ doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr,
+ doublereal *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal s;
+ integer kk;
+ doublereal xk;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern /* Subroutine */ int dgbmv_(char *, integer *, integer *, integer *
+, integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *);
+ integer count;
+ extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *), dgbtrs_(
+ char *, integer *, integer *, integer *, integer *, doublereal *,
+ integer *, integer *, doublereal *, integer *, integer *);
+ logical notran;
+ char transt[1];
+ doublereal lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGBRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is banded, and provides */
+/* error bounds and backward error estimates for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The original band matrix A, stored in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by DGBTRF. U is stored as an upper triangular band */
+/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
+/* the multipliers used during the factorization are stored in */
+/* rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from DGBTRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by DGBTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -7;
+ } else if (*ldafb < (*kl << 1) + *ku + 1) {
+ *info = -9;
+ } else if (*ldb < max(1,*n)) {
+ *info = -12;
+ } else if (*ldx < max(1,*n)) {
+ *info = -14;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGBRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+/* Computing MIN */
+ i__1 = *kl + *ku + 2, i__2 = *n + 1;
+ nz = min(i__1,i__2);
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A, A**T, or A**H, depending on TRANS. */
+
+ dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+ dgbmv_(trans, n, n, kl, ku, &c_b15, &ab[ab_offset], ldab, &x[j *
+ x_dim1 + 1], &c__1, &c_b17, &work[*n + 1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1));
+/* L30: */
+ }
+
+/* Compute abs(op(A))*abs(X) + abs(B). */
+
+ if (notran) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ kk = *ku + 1 - k;
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+/* Computing MAX */
+ i__3 = 1, i__4 = k - *ku;
+/* Computing MIN */
+ i__6 = *n, i__7 = k + *kl;
+ i__5 = min(i__6,i__7);
+ for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
+ work[i__] += (d__1 = ab[kk + i__ + k * ab_dim1], abs(d__1)
+ ) * xk;
+/* L40: */
+ }
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ kk = *ku + 1 - k;
+/* Computing MAX */
+ i__5 = 1, i__3 = k - *ku;
+/* Computing MIN */
+ i__6 = *n, i__7 = k + *kl;
+ i__4 = min(i__6,i__7);
+ for (i__ = max(i__5,i__3); i__ <= i__4; ++i__) {
+ s += (d__1 = ab[kk + i__ + k * ab_dim1], abs(d__1)) * (
+ d__2 = x[i__ + j * x_dim1], abs(d__2));
+/* L60: */
+ }
+ work[k] += s;
+/* L70: */
+ }
+ }
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[
+ i__];
+ s = max(d__2,d__3);
+ } else {
+/* Computing MAX */
+ d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1)
+ / (work[i__] + safe1);
+ s = max(d__2,d__3);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ dgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1]
+, &work[*n + 1], n, info);
+ daxpy_(n, &c_b17, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
+ ;
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use DLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+ kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)**T). */
+
+ dgbtrs_(transt, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &
+ ipiv[1], &work[*n + 1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] *= work[i__];
+/* L110: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] *= work[i__];
+/* L120: */
+ }
+ dgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &
+ ipiv[1], &work[*n + 1], n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1));
+ lstres = max(d__2,d__3);
+/* L130: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of DGBRFS */
+
+} /* dgbrfs_ */
diff --git a/SRC/dgbrfsx.c b/SRC/dgbrfsx.c
new file mode 100644
index 0000000..73ab53f
--- /dev/null
+++ b/SRC/dgbrfsx.c
@@ -0,0 +1,687 @@
+/* dgbrfsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int dgbrfsx_(char *trans, char *equed, integer *n, integer *
+ kl, integer *ku, integer *nrhs, doublereal *ab, integer *ldab,
+ doublereal *afb, integer *ldafb, integer *ipiv, doublereal *r__,
+ doublereal *c__, doublereal *b, integer *ldb, doublereal *x, integer *
+ ldx, doublereal *rcond, doublereal *berr, integer *n_err_bnds__,
+ doublereal *err_bnds_norm__, doublereal *err_bnds_comp__, integer *
+ nparams, doublereal *params, doublereal *work, integer *iwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal illrcond_thresh__, unstable_thresh__, err_lbnd__;
+ integer ref_type__;
+ extern integer ilatrans_(char *);
+ integer j;
+ doublereal rcond_tmp__;
+ integer prec_type__, trans_type__;
+ extern doublereal dla_gbrcond__(char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ ftnlen);
+ doublereal cwise_wrong__;
+ extern /* Subroutine */ int dla_gbrfsx_extended__(integer *, integer *,
+ integer *, integer *, integer *, integer *, doublereal *, integer
+ *, doublereal *, integer *, integer *, logical *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *
+ , doublereal *, logical *, integer *);
+ char norm[1];
+ logical ignore_cwise__;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern doublereal dlangb_(char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *), dlamch_(char *);
+ extern /* Subroutine */ int dgbcon_(char *, integer *, integer *, integer
+ *, doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *), xerbla_(char *,
+ integer *);
+ logical colequ, notran, rowequ;
+ extern integer ilaprec_(char *);
+ integer ithresh, n_norms__;
+ doublereal rthresh;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGBRFSX improves the computed solution to a system of linear */
+/* equations and provides error bounds and backward error estimates */
+/* for the solution. In addition to normwise error bound, the code */
+/* provides maximum componentwise error bound if possible. See */
+/* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the */
+/* error bounds. */
+
+/* The original system of linear equations may have been equilibrated */
+/* before calling this routine, as described by arguments EQUED, R */
+/* and C below. In this case, the solution and error bounds returned */
+/* are for the original unequilibrated system. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* EQUED (input) CHARACTER*1 */
+/* Specifies the form of equilibration that was done to A */
+/* before calling this routine. This is needed to compute */
+/* the solution and error bounds correctly. */
+/* = 'N': No equilibration */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* The right hand side B has been changed accordingly. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The original band matrix A, stored in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by DGBTRF. U is stored as an upper triangular band */
+/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
+/* the multipliers used during the factorization are stored in */
+/* rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from DGETRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* R (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+/* If R is output, each element of R is a power of the radix. */
+/* If R is input, each element of R should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* C (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+/* If C is output, each element of C is a power of the radix. */
+/* If C is input, each element of C should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by DGETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0D+0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check the input parameters. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ trans_type__ = ilatrans_(trans);
+ ref_type__ = 1;
+ if (*nparams >= 1) {
+ if (params[1] < 0.) {
+ params[1] = 1.;
+ } else {
+ ref_type__ = (integer) params[1];
+ }
+ }
+
+/* Set default parameters. */
+
+ illrcond_thresh__ = (doublereal) (*n) * dlamch_("Epsilon");
+ ithresh = 10;
+ rthresh = .5;
+ unstable_thresh__ = .25;
+ ignore_cwise__ = FALSE_;
+
+ if (*nparams >= 2) {
+ if (params[2] < 0.) {
+ params[2] = (doublereal) ithresh;
+ } else {
+ ithresh = (integer) params[2];
+ }
+ }
+ if (*nparams >= 3) {
+ if (params[3] < 0.) {
+ if (ignore_cwise__) {
+ params[3] = 0.;
+ } else {
+ params[3] = 1.;
+ }
+ } else {
+ ignore_cwise__ = params[3] == 0.;
+ }
+ }
+ if (ref_type__ == 0 || *n_err_bnds__ == 0) {
+ n_norms__ = 0;
+ } else if (ignore_cwise__) {
+ n_norms__ = 1;
+ } else {
+ n_norms__ = 2;
+ }
+
+ notran = lsame_(trans, "N");
+ rowequ = lsame_(equed, "R") || lsame_(equed, "B");
+ colequ = lsame_(equed, "C") || lsame_(equed, "B");
+
+/* Test input parameters. */
+
+ if (trans_type__ == -1) {
+ *info = -1;
+ } else if (! rowequ && ! colequ && ! lsame_(equed, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kl < 0) {
+ *info = -4;
+ } else if (*ku < 0) {
+ *info = -5;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -8;
+ } else if (*ldafb < (*kl << 1) + *ku + 1) {
+ *info = -10;
+ } else if (*ldb < max(1,*n)) {
+ *info = -13;
+ } else if (*ldx < max(1,*n)) {
+ *info = -15;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGBRFSX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *nrhs == 0) {
+ *rcond = 1.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 0.;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.;
+ }
+ }
+ return 0;
+ }
+
+/* Default to failure. */
+
+ *rcond = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 1.;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.;
+ }
+ }
+
+/* Compute the norm of A and the reciprocal of the condition */
+/* number of A. */
+
+ if (notran) {
+ *(unsigned char *)norm = 'I';
+ } else {
+ *(unsigned char *)norm = '1';
+ }
+ anorm = dlangb_(norm, n, kl, ku, &ab[ab_offset], ldab, &work[1]);
+ dgbcon_(norm, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], &anorm, rcond,
+ &work[1], &iwork[1], info);
+
+/* Perform refinement on each right-hand side */
+
+ if (ref_type__ != 0) {
+ prec_type__ = ilaprec_("E");
+ if (notran) {
+ dla_gbrfsx_extended__(&prec_type__, &trans_type__, n, kl, ku,
+ nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, &
+ ipiv[1], &colequ, &c__[1], &b[b_offset], ldb, &x[x_offset]
+ , ldx, &berr[1], &n_norms__, &err_bnds_norm__[
+ err_bnds_norm_offset], &err_bnds_comp__[
+ err_bnds_comp_offset], &work[*n + 1], &work[1], &work[(*n
+ << 1) + 1], &work[1], rcond, &ithresh, &rthresh, &
+ unstable_thresh__, &ignore_cwise__, info);
+ } else {
+ dla_gbrfsx_extended__(&prec_type__, &trans_type__, n, kl, ku,
+ nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, &
+ ipiv[1], &rowequ, &r__[1], &b[b_offset], ldb, &x[x_offset]
+ , ldx, &berr[1], &n_norms__, &err_bnds_norm__[
+ err_bnds_norm_offset], &err_bnds_comp__[
+ err_bnds_comp_offset], &work[*n + 1], &work[1], &work[(*n
+ << 1) + 1], &work[1], rcond, &ithresh, &rthresh, &
+ unstable_thresh__, &ignore_cwise__, info);
+ }
+ }
+/* Computing MAX */
+ d__1 = 10., d__2 = sqrt((doublereal) (*n));
+ err_lbnd__ = max(d__1,d__2) * dlamch_("Epsilon");
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {
+
+/* Compute scaled normwise condition number cond(A*C). */
+
+ if (colequ && notran) {
+ rcond_tmp__ = dla_gbrcond__(trans, n, kl, ku, &ab[ab_offset],
+ ldab, &afb[afb_offset], ldafb, &ipiv[1], &c_n1, &c__[1],
+ info, &work[1], &iwork[1], (ftnlen)1);
+ } else if (rowequ && ! notran) {
+ rcond_tmp__ = dla_gbrcond__(trans, n, kl, ku, &ab[ab_offset],
+ ldab, &afb[afb_offset], ldafb, &ipiv[1], &c_n1, &r__[1],
+ info, &work[1], &iwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = dla_gbrcond__(trans, n, kl, ku, &ab[ab_offset],
+ ldab, &afb[afb_offset], ldafb, &ipiv[1], &c__0, &r__[1],
+ info, &work[1], &iwork[1], (ftnlen)1);
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1
+ << 1)] > 1.) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 0.;
+ if (*info <= *n) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {
+
+/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
+/* each right-hand side using the current solution as an estimate of */
+/* the true solution. If the componentwise error estimate is too */
+/* large, then the solution is a lousy estimate of truth and the */
+/* estimated RCOND may be too optimistic. To avoid misleading users, */
+/* the inverse condition number is set to 0.0 when the estimated */
+/* cwise error is at least CWISE_WRONG. */
+
+ cwise_wrong__ = sqrt(dlamch_("Epsilon"));
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ cwise_wrong__) {
+ rcond_tmp__ = dla_gbrcond__(trans, n, kl, ku, &ab[ab_offset],
+ ldab, &afb[afb_offset], ldafb, &ipiv[1], &c__1, &x[j *
+ x_dim1 + 1], info, &work[1], &iwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = 0.;
+ }
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1
+ << 1)] > 1.) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 0.;
+ if (params[3] == 1. && *info < *n + j) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DGBRFSX */
+
+} /* dgbrfsx_ */
diff --git a/SRC/dgbsv.c b/SRC/dgbsv.c
new file mode 100644
index 0000000..97c0538
--- /dev/null
+++ b/SRC/dgbsv.c
@@ -0,0 +1,176 @@
+/* dgbsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgbsv_(integer *n, integer *kl, integer *ku, integer *
+ nrhs, doublereal *ab, integer *ldab, integer *ipiv, doublereal *b,
+ integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int dgbtrf_(integer *, integer *, integer *,
+ integer *, doublereal *, integer *, integer *, integer *),
+ xerbla_(char *, integer *), dgbtrs_(char *, integer *,
+ integer *, integer *, integer *, doublereal *, integer *, integer
+ *, doublereal *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGBSV computes the solution to a real system of linear equations */
+/* A * X = B, where A is a band matrix of order N with KL subdiagonals */
+/* and KU superdiagonals, and X and B are N-by-NRHS matrices. */
+
+/* The LU decomposition with partial pivoting and row interchanges is */
+/* used to factor A as A = L * U, where L is a product of permutation */
+/* and unit lower triangular matrices with KL subdiagonals, and U is */
+/* upper triangular with KL+KU superdiagonals. The factored form of A */
+/* is then used to solve the system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows KL+1 to */
+/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL) */
+/* On exit, details of the factorization: U is stored as an */
+/* upper triangular band matrix with KL+KU superdiagonals in */
+/* rows 1 to KL+KU+1, and the multipliers used during the */
+/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */
+/* See below for further details. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* The pivot indices that define the permutation matrix P; */
+/* row i of the matrix was interchanged with row IPIV(i). */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and the solution has not been computed. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* M = N = 6, KL = 2, KU = 1: */
+
+/* On entry: On exit: */
+
+/* * * * + + + * * * u14 u25 u36 */
+/* * * + + + + * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */
+/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */
+
+/* Array elements marked * are not used by the routine; elements marked */
+/* + need not be set on entry, but are required by the routine to store */
+/* elements of U because of fill-in resulting from the row interchanges. */
+
+/* ===================================================================== */
+
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*kl < 0) {
+ *info = -2;
+ } else if (*ku < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldab < (*kl << 1) + *ku + 1) {
+ *info = -6;
+ } else if (*ldb < max(*n,1)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGBSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the LU factorization of the band matrix A. */
+
+ dgbtrf_(n, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ dgbtrs_("No transpose", n, kl, ku, nrhs, &ab[ab_offset], ldab, &ipiv[
+ 1], &b[b_offset], ldb, info);
+ }
+ return 0;
+
+/* End of DGBSV */
+
+} /* dgbsv_ */
diff --git a/SRC/dgbsvx.c b/SRC/dgbsvx.c
new file mode 100644
index 0000000..7e414cc
--- /dev/null
+++ b/SRC/dgbsvx.c
@@ -0,0 +1,650 @@
+/* dgbsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dgbsvx_(char *fact, char *trans, integer *n, integer *kl,
+ integer *ku, integer *nrhs, doublereal *ab, integer *ldab,
+ doublereal *afb, integer *ldafb, integer *ipiv, char *equed,
+ doublereal *r__, doublereal *c__, doublereal *b, integer *ldb,
+ doublereal *x, integer *ldx, doublereal *rcond, doublereal *ferr,
+ doublereal *berr, doublereal *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, j1, j2;
+ doublereal amax;
+ char norm[1];
+ extern logical lsame_(char *, char *);
+ doublereal rcmin, rcmax, anorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical equil;
+ extern doublereal dlangb_(char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *), dlamch_(char *);
+ extern /* Subroutine */ int dlaqgb_(integer *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, char *),
+ dgbcon_(char *, integer *, integer *, integer *, doublereal *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *);
+ doublereal colcnd;
+ extern doublereal dlantb_(char *, char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dgbequ_(integer *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *), dgbrfs_(
+ char *, integer *, integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *), dgbtrf_(integer *,
+ integer *, integer *, integer *, doublereal *, integer *, integer
+ *, integer *);
+ logical nofact;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dgbtrs_(char *, integer *, integer *, integer
+ *, integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ integer infequ;
+ logical colequ;
+ doublereal rowcnd;
+ logical notran;
+ doublereal smlnum;
+ logical rowequ;
+ doublereal rpvgrw;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGBSVX uses the LU factorization to compute the solution to a real */
+/* system of linear equations A * X = B, A**T * X = B, or A**H * X = B, */
+/* where A is a band matrix of order N with KL subdiagonals and KU */
+/* superdiagonals, and X and B are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed by this subroutine: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */
+/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */
+/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */
+/* or diag(C)*B (if TRANS = 'T' or 'C'). */
+
+/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the */
+/* matrix A (after equilibration if FACT = 'E') as */
+/* A = L * U, */
+/* where L is a product of permutation and unit lower triangular */
+/* matrices with KL subdiagonals, and U is upper triangular with */
+/* KL+KU superdiagonals. */
+
+/* 3. If some U(i,i)=0, so that U is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */
+/* that it solves the original system before equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AFB and IPIV contain the factored form of */
+/* A. If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by R and C. */
+/* AB, AFB, and IPIV are not modified. */
+/* = 'N': The matrix A will be copied to AFB and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AFB and factored. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
+
+/* If FACT = 'F' and EQUED is not 'N', then A must have been */
+/* equilibrated by the scaling factors in R and/or C. AB is not */
+/* modified if FACT = 'F' or 'N', or if FACT = 'E' and */
+/* EQUED = 'N' on exit. */
+
+/* On exit, if EQUED .ne. 'N', A is scaled as follows: */
+/* EQUED = 'R': A := diag(R) * A */
+/* EQUED = 'C': A := A * diag(C) */
+/* EQUED = 'B': A := diag(R) * A * diag(C). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N) */
+/* If FACT = 'F', then AFB is an input argument and on entry */
+/* contains details of the LU factorization of the band matrix */
+/* A, as computed by DGBTRF. U is stored as an upper triangular */
+/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */
+/* and the multipliers used during the factorization are stored */
+/* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is */
+/* the factored form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AFB is an output argument and on exit */
+/* returns details of the LU factorization of A. */
+
+/* If FACT = 'E', then AFB is an output argument and on exit */
+/* returns details of the LU factorization of the equilibrated */
+/* matrix A (see the description of AB for the form of the */
+/* equilibrated matrix). */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains the pivot indices from the factorization A = L*U */
+/* as computed by DGBTRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = L*U */
+/* of the equilibrated matrix A. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* R (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+
+/* C (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */
+/* diag(R)*B; */
+/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */
+/* overwritten by diag(C)*B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X */
+/* to the original system of equations. Note that A and B are */
+/* modified on exit if EQUED .ne. 'N', and the solution to the */
+/* equilibrated system is inv(diag(C))*X if TRANS = 'N' and */
+/* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' */
+/* and EQUED = 'R' or 'B'. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A after equilibration (if done). If RCOND is less than the */
+/* machine precision (in particular, if RCOND = 0), the matrix */
+/* is singular to working precision. This condition is */
+/* indicated by a return code of INFO > 0. */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (3*N) */
+/* On exit, WORK(1) contains the reciprocal pivot growth */
+/* factor norm(A)/norm(U). The "max absolute element" norm is */
+/* used. If WORK(1) is much less than 1, then the stability */
+/* of the LU factorization of the (equilibrated) matrix A */
+/* could be poor. This also means that the solution X, condition */
+/* estimator RCOND, and forward error bound FERR could be */
+/* unreliable. If factorization fails with 0<INFO<=N, then */
+/* WORK(1) contains the reciprocal pivot growth factor for the */
+/* leading INFO columns of A. */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, so the solution and error bounds */
+/* could not be computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ notran = lsame_(trans, "N");
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rowequ = FALSE_;
+ colequ = FALSE_;
+ } else {
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ }
+
+/* Test the input parameters. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kl < 0) {
+ *info = -4;
+ } else if (*ku < 0) {
+ *info = -5;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -8;
+ } else if (*ldafb < (*kl << 1) + *ku + 1) {
+ *info = -10;
+ } else if (lsame_(fact, "F") && ! (rowequ || colequ
+ || lsame_(equed, "N"))) {
+ *info = -12;
+ } else {
+ if (rowequ) {
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = r__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = r__[j];
+ rcmax = max(d__1,d__2);
+/* L10: */
+ }
+ if (rcmin <= 0.) {
+ *info = -13;
+ } else if (*n > 0) {
+ rowcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ } else {
+ rowcnd = 1.;
+ }
+ }
+ if (colequ && *info == 0) {
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = c__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = c__[j];
+ rcmax = max(d__1,d__2);
+/* L20: */
+ }
+ if (rcmin <= 0.) {
+ *info = -14;
+ } else if (*n > 0) {
+ colcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ } else {
+ colcnd = 1.;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -16;
+ } else if (*ldx < max(1,*n)) {
+ *info = -18;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGBSVX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ dgbequ_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &rowcnd,
+ &colcnd, &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ dlaqgb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &
+ rowcnd, &colcnd, &amax, equed);
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+ }
+
+/* Scale the right hand side. */
+
+ if (notran) {
+ if (rowequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = r__[i__] * b[i__ + j * b_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else if (colequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = c__[i__] * b[i__ + j * b_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of the band matrix A. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j - *ku;
+ j1 = max(i__2,1);
+/* Computing MIN */
+ i__2 = j + *kl;
+ j2 = min(i__2,*n);
+ i__2 = j2 - j1 + 1;
+ dcopy_(&i__2, &ab[*ku + 1 - j + j1 + j * ab_dim1], &c__1, &afb[*
+ kl + *ku + 1 - j + j1 + j * afb_dim1], &c__1);
+/* L70: */
+ }
+
+ dgbtrf_(n, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ anorm = 0.;
+ i__1 = *info;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = *ku + 2 - j;
+/* Computing MIN */
+ i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1;
+ i__3 = min(i__4,i__5);
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ d__2 = anorm, d__3 = (d__1 = ab[i__ + j * ab_dim1], abs(
+ d__1));
+ anorm = max(d__2,d__3);
+/* L80: */
+ }
+/* L90: */
+ }
+/* Computing MIN */
+ i__3 = *info - 1, i__2 = *kl + *ku;
+ i__1 = min(i__3,i__2);
+/* Computing MAX */
+ i__4 = 1, i__5 = *kl + *ku + 2 - *info;
+ rpvgrw = dlantb_("M", "U", "N", info, &i__1, &afb[max(i__4, i__5)
+ + afb_dim1], ldafb, &work[1]);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = anorm / rpvgrw;
+ }
+ work[1] = rpvgrw;
+ *rcond = 0.;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A and the */
+/* reciprocal pivot growth factor RPVGRW. */
+
+ if (notran) {
+ *(unsigned char *)norm = '1';
+ } else {
+ *(unsigned char *)norm = 'I';
+ }
+ anorm = dlangb_(norm, n, kl, ku, &ab[ab_offset], ldab, &work[1]);
+ i__1 = *kl + *ku;
+ rpvgrw = dlantb_("M", "U", "N", n, &i__1, &afb[afb_offset], ldafb, &work[
+ 1]);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = dlangb_("M", n, kl, ku, &ab[ab_offset], ldab, &work[1]) / rpvgrw;
+ }
+
+/* Compute the reciprocal of the condition number of A. */
+
+ dgbcon_(norm, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], &anorm, rcond,
+ &work[1], &iwork[1], info);
+
+/* Compute the solution matrix X. */
+
+ dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ dgbtrs_(trans, n, kl, ku, nrhs, &afb[afb_offset], ldafb, &ipiv[1], &x[
+ x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ dgbrfs_(trans, n, kl, ku, nrhs, &ab[ab_offset], ldab, &afb[afb_offset],
+ ldafb, &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &
+ berr[1], &work[1], &iwork[1], info);
+
+/* Transform the solution matrix X to a solution of the original */
+/* system. */
+
+ if (notran) {
+ if (colequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ x[i__ + j * x_dim1] = c__[i__] * x[i__ + j * x_dim1];
+/* L100: */
+ }
+/* L110: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= colcnd;
+/* L120: */
+ }
+ }
+ } else if (rowequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ x[i__ + j * x_dim1] = r__[i__] * x[i__ + j * x_dim1];
+/* L130: */
+ }
+/* L140: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= rowcnd;
+/* L150: */
+ }
+ }
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < dlamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ work[1] = rpvgrw;
+ return 0;
+
+/* End of DGBSVX */
+
+} /* dgbsvx_ */
diff --git a/SRC/dgbsvxx.c b/SRC/dgbsvxx.c
new file mode 100644
index 0000000..aeb294b
--- /dev/null
+++ b/SRC/dgbsvxx.c
@@ -0,0 +1,745 @@
+/* dgbsvxx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgbsvxx_(char *fact, char *trans, integer *n, integer *
+ kl, integer *ku, integer *nrhs, doublereal *ab, integer *ldab,
+ doublereal *afb, integer *ldafb, integer *ipiv, char *equed,
+ doublereal *r__, doublereal *c__, doublereal *b, integer *ldb,
+ doublereal *x, integer *ldx, doublereal *rcond, doublereal *rpvgrw,
+ doublereal *berr, integer *n_err_bnds__, doublereal *err_bnds_norm__,
+ doublereal *err_bnds_comp__, integer *nparams, doublereal *params,
+ doublereal *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal amax;
+ extern doublereal dla_gbrpvgrw__(integer *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ doublereal rcmin, rcmax;
+ logical equil;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlaqgb_(integer *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, char *);
+ doublereal colcnd;
+ extern /* Subroutine */ int dgbtrf_(integer *, integer *, integer *,
+ integer *, doublereal *, integer *, integer *, integer *);
+ logical nofact;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dgbtrs_(char *, integer *, integer *, integer
+ *, integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ integer infequ;
+ logical colequ;
+ doublereal rowcnd;
+ logical notran;
+ doublereal smlnum;
+ logical rowequ;
+ extern /* Subroutine */ int dlascl2_(integer *, integer *, doublereal *,
+ doublereal *, integer *), dgbequb_(integer *, integer *, integer *
+, integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *), dgbrfsx_(
+ char *, char *, integer *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGBSVXX uses the LU factorization to compute the solution to a */
+/* double precision system of linear equations A * X = B, where A is an */
+/* N-by-N matrix and X and B are N-by-NRHS matrices. */
+
+/* If requested, both normwise and maximum componentwise error bounds */
+/* are returned. DGBSVXX will return a solution with a tiny */
+/* guaranteed error (O(eps) where eps is the working machine */
+/* precision) unless the matrix is very ill-conditioned, in which */
+/* case a warning is returned. Relevant condition numbers also are */
+/* calculated and returned. */
+
+/* DGBSVXX accepts user-provided factorizations and equilibration */
+/* factors; see the definitions of the FACT and EQUED options. */
+/* Solving with refinement and using a factorization from a previous */
+/* DGBSVXX call will also produce a solution with either O(eps) */
+/* errors or warnings, but we cannot make that claim for general */
+/* user-provided factorizations and equilibration factors if they */
+/* differ from what DGBSVXX would itself produce. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate */
+/* the system: */
+
+/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */
+/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */
+/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */
+
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */
+/* or diag(C)*B (if TRANS = 'T' or 'C'). */
+
+/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */
+/* the matrix A (after equilibration if FACT = 'E') as */
+
+/* A = P * L * U, */
+
+/* where P is a permutation matrix, L is a unit lower triangular */
+/* matrix, and U is upper triangular. */
+
+/* 3. If some U(i,i)=0, so that U is exactly singular, then the */
+/* routine returns with INFO = i. Otherwise, the factored form of A */
+/* is used to estimate the condition number of the matrix A (see */
+/* argument RCOND). If the reciprocal of the condition number is less */
+/* than machine precision, the routine still goes on to solve for X */
+/* and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */
+/* the routine will use iterative refinement to try to get a small */
+/* error and error bounds. Refinement calculates the residual to at */
+/* least twice the working precision. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */
+/* that it solves the original system before equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF and IPIV contain the factored form of A. */
+/* If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by R and C. */
+/* A, AF, and IPIV are not modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
+
+/* If FACT = 'F' and EQUED is not 'N', then AB must have been */
+/* equilibrated by the scaling factors in R and/or C. AB is not */
+/* modified if FACT = 'F' or 'N', or if FACT = 'E' and */
+/* EQUED = 'N' on exit. */
+
+/* On exit, if EQUED .ne. 'N', A is scaled as follows: */
+/* EQUED = 'R': A := diag(R) * A */
+/* EQUED = 'C': A := A * diag(C) */
+/* EQUED = 'B': A := diag(R) * A * diag(C). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N) */
+/* If FACT = 'F', then AFB is an input argument and on entry */
+/* contains details of the LU factorization of the band matrix */
+/* A, as computed by DGBTRF. U is stored as an upper triangular */
+/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */
+/* and the multipliers used during the factorization are stored */
+/* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is */
+/* the factored form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the equilibrated matrix A (see the description of A for */
+/* the form of the equilibrated matrix). */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* as computed by DGETRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the equilibrated matrix A. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* R (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+/* If R is output, each element of R is a power of the radix. */
+/* If R is input, each element of R should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* C (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+/* If C is output, each element of C is a power of the radix. */
+/* If C is input, each element of C should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */
+/* diag(R)*B; */
+/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */
+/* overwritten by diag(C)*B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* If INFO = 0, the N-by-NRHS solution matrix X to the original */
+/* system of equations. Note that A and B are modified on exit */
+/* if EQUED .ne. 'N', and the solution to the equilibrated system is */
+/* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or */
+/* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* RPVGRW (output) DOUBLE PRECISION */
+/* Reciprocal pivot growth. On exit, this contains the reciprocal */
+/* pivot growth factor norm(A)/norm(U). The "max absolute element" */
+/* norm is used. If this is much less than 1, then the stability of */
+/* the LU factorization of the (equilibrated) matrix A could be poor. */
+/* This also means that the solution X, estimated condition numbers, */
+/* and error bounds could be unreliable. If factorization fails with */
+/* 0<INFO<=N, then this contains the reciprocal pivot growth factor */
+/* for the leading INFO columns of A. In DGESVX, this quantity is */
+/* returned in WORK(1). */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0D+0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the extra-precise refinement algorithm. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ notran = lsame_(trans, "N");
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rowequ = FALSE_;
+ colequ = FALSE_;
+ } else {
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+
+/* Default is failure. If an input parameter is wrong or */
+/* factorization fails, make everything look horrible. Only the */
+/* pivot growth is set here, the rest is initialized in DGBRFSX. */
+
+ *rpvgrw = 0.;
+
+/* Test the input parameters. PARAMS is not tested until DGBRFSX. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kl < 0) {
+ *info = -4;
+ } else if (*ku < 0) {
+ *info = -5;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -8;
+ } else if (*ldafb < (*kl << 1) + *ku + 1) {
+ *info = -10;
+ } else if (lsame_(fact, "F") && ! (rowequ || colequ
+ || lsame_(equed, "N"))) {
+ *info = -12;
+ } else {
+ if (rowequ) {
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = r__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = r__[j];
+ rcmax = max(d__1,d__2);
+/* L10: */
+ }
+ if (rcmin <= 0.) {
+ *info = -13;
+ } else if (*n > 0) {
+ rowcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ } else {
+ rowcnd = 1.;
+ }
+ }
+ if (colequ && *info == 0) {
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = c__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = c__[j];
+ rcmax = max(d__1,d__2);
+/* L20: */
+ }
+ if (rcmin <= 0.) {
+ *info = -14;
+ } else if (*n > 0) {
+ colcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ } else {
+ colcnd = 1.;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -15;
+ } else if (*ldx < max(1,*n)) {
+ *info = -16;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGBSVXX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ dgbequb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &
+ rowcnd, &colcnd, &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ dlaqgb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &
+ rowcnd, &colcnd, &amax, equed);
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+
+/* If the scaling factors are not applied, set them to 1.0. */
+
+ if (! rowequ) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ r__[j] = 1.;
+ }
+ }
+ if (! colequ) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 1.;
+ }
+ }
+ }
+
+/* Scale the right hand side. */
+
+ if (notran) {
+ if (rowequ) {
+ dlascl2_(n, nrhs, &r__[1], &b[b_offset], ldb);
+ }
+ } else {
+ if (colequ) {
+ dlascl2_(n, nrhs, &c__[1], &b[b_offset], ldb);
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of A. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (*kl << 1) + *ku + 1;
+ for (i__ = *kl + 1; i__ <= i__2; ++i__) {
+ afb[i__ + j * afb_dim1] = ab[i__ - *kl + j * ab_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ dgbtrf_(n, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Pivot in column INFO is exactly 0 */
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ *rpvgrw = dla_gbrpvgrw__(n, kl, ku, info, &ab[ab_offset], ldab, &
+ afb[afb_offset], ldafb);
+ return 0;
+ }
+ }
+
+/* Compute the reciprocal pivot growth factor RPVGRW. */
+
+ *rpvgrw = dla_gbrpvgrw__(n, kl, ku, n, &ab[ab_offset], ldab, &afb[
+ afb_offset], ldafb);
+
+/* Compute the solution matrix X. */
+
+ dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ dgbtrs_(trans, n, kl, ku, nrhs, &afb[afb_offset], ldafb, &ipiv[1], &x[
+ x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ dgbrfsx_(trans, equed, n, kl, ku, nrhs, &ab[ab_offset], ldab, &afb[
+ afb_offset], ldafb, &ipiv[1], &r__[1], &c__[1], &b[b_offset], ldb,
+ &x[x_offset], ldx, rcond, &berr[1], n_err_bnds__, &
+ err_bnds_norm__[err_bnds_norm_offset], &err_bnds_comp__[
+ err_bnds_comp_offset], nparams, ¶ms[1], &work[1], &iwork[1],
+ info);
+
+/* Scale solutions. */
+
+ if (colequ && notran) {
+ dlascl2_(n, nrhs, &c__[1], &x[x_offset], ldx);
+ } else if (rowequ && ! notran) {
+ dlascl2_(n, nrhs, &r__[1], &x[x_offset], ldx);
+ }
+
+ return 0;
+
+/* End of DGBSVXX */
+
+} /* dgbsvxx_ */
diff --git a/SRC/dgbtf2.c b/SRC/dgbtf2.c
new file mode 100644
index 0000000..400eafb
--- /dev/null
+++ b/SRC/dgbtf2.c
@@ -0,0 +1,262 @@
+/* dgbtf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b9 = -1.;
+
+/* Subroutine */ int dgbtf2_(integer *m, integer *n, integer *kl, integer *ku,
+ doublereal *ab, integer *ldab, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, j, km, jp, ju, kv;
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dscal_(integer *, doublereal *, doublereal *, integer
+ *), dswap_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGBTF2 computes an LU factorization of a real m-by-n band matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows KL+1 to */
+/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */
+
+/* On exit, details of the factorization: U is stored as an */
+/* upper triangular band matrix with KL+KU superdiagonals in */
+/* rows 1 to KL+KU+1, and the multipliers used during the */
+/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */
+/* See below for further details. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* M = N = 6, KL = 2, KU = 1: */
+
+/* On entry: On exit: */
+
+/* * * * + + + * * * u14 u25 u36 */
+/* * * + + + + * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */
+/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */
+
+/* Array elements marked * are not used by the routine; elements marked */
+/* + need not be set on entry, but are required by the routine to store */
+/* elements of U, because of fill-in resulting from the row */
+/* interchanges. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* KV is the number of superdiagonals in the factor U, allowing for */
+/* fill-in. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --ipiv;
+
+ /* Function Body */
+ kv = *ku + *kl;
+
+/* Test the input parameters. */
+
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*ldab < *kl + kv + 1) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGBTF2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Gaussian elimination with partial pivoting */
+
+/* Set fill-in elements in columns KU+2 to KV to zero. */
+
+ i__1 = min(kv,*n);
+ for (j = *ku + 2; j <= i__1; ++j) {
+ i__2 = *kl;
+ for (i__ = kv - j + 2; i__ <= i__2; ++i__) {
+ ab[i__ + j * ab_dim1] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* JU is the index of the last column affected by the current stage */
+/* of the factorization. */
+
+ ju = 1;
+
+ i__1 = min(*m,*n);
+ for (j = 1; j <= i__1; ++j) {
+
+/* Set fill-in elements in column J+KV to zero. */
+
+ if (j + kv <= *n) {
+ i__2 = *kl;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ab[i__ + (j + kv) * ab_dim1] = 0.;
+/* L30: */
+ }
+ }
+
+/* Find pivot and test for singularity. KM is the number of */
+/* subdiagonal elements in the current column. */
+
+/* Computing MIN */
+ i__2 = *kl, i__3 = *m - j;
+ km = min(i__2,i__3);
+ i__2 = km + 1;
+ jp = idamax_(&i__2, &ab[kv + 1 + j * ab_dim1], &c__1);
+ ipiv[j] = jp + j - 1;
+ if (ab[kv + jp + j * ab_dim1] != 0.) {
+/* Computing MAX */
+/* Computing MIN */
+ i__4 = j + *ku + jp - 1;
+ i__2 = ju, i__3 = min(i__4,*n);
+ ju = max(i__2,i__3);
+
+/* Apply interchange to columns J to JU. */
+
+ if (jp != 1) {
+ i__2 = ju - j + 1;
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ dswap_(&i__2, &ab[kv + jp + j * ab_dim1], &i__3, &ab[kv + 1 +
+ j * ab_dim1], &i__4);
+ }
+
+ if (km > 0) {
+
+/* Compute multipliers. */
+
+ d__1 = 1. / ab[kv + 1 + j * ab_dim1];
+ dscal_(&km, &d__1, &ab[kv + 2 + j * ab_dim1], &c__1);
+
+/* Update trailing submatrix within the band. */
+
+ if (ju > j) {
+ i__2 = ju - j;
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ dger_(&km, &i__2, &c_b9, &ab[kv + 2 + j * ab_dim1], &c__1,
+ &ab[kv + (j + 1) * ab_dim1], &i__3, &ab[kv + 1 +
+ (j + 1) * ab_dim1], &i__4);
+ }
+ }
+ } else {
+
+/* If pivot is zero, set INFO to the index of the pivot */
+/* unless a zero pivot has already been found. */
+
+ if (*info == 0) {
+ *info = j;
+ }
+ }
+/* L40: */
+ }
+ return 0;
+
+/* End of DGBTF2 */
+
+} /* dgbtf2_ */
diff --git a/SRC/dgbtrf.c b/SRC/dgbtrf.c
new file mode 100644
index 0000000..7b90c9b
--- /dev/null
+++ b/SRC/dgbtrf.c
@@ -0,0 +1,588 @@
+/* dgbtrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__65 = 65;
+static doublereal c_b18 = -1.;
+static doublereal c_b31 = 1.;
+
+/* Subroutine */ int dgbtrf_(integer *m, integer *n, integer *kl, integer *ku,
+ doublereal *ab, integer *ldab, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, j, i2, i3, j2, j3, k2, jb, nb, ii, jj, jm, ip, jp, km, ju,
+ kv, nw;
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal temp;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *), dgemm_(char *, char *, integer *, integer *, integer *
+, doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dcopy_(
+ integer *, doublereal *, integer *, doublereal *, integer *),
+ dswap_(integer *, doublereal *, integer *, doublereal *, integer *
+);
+ doublereal work13[4160] /* was [65][64] */, work31[4160] /*
+ was [65][64] */;
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), dgbtf2_(
+ integer *, integer *, integer *, integer *, doublereal *, integer
+ *, integer *, integer *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dlaswp_(integer *, doublereal *, integer *,
+ integer *, integer *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGBTRF computes an LU factorization of a real m-by-n band matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* This is the blocked version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows KL+1 to */
+/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */
+
+/* On exit, details of the factorization: U is stored as an */
+/* upper triangular band matrix with KL+KU superdiagonals in */
+/* rows 1 to KL+KU+1, and the multipliers used during the */
+/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */
+/* See below for further details. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* M = N = 6, KL = 2, KU = 1: */
+
+/* On entry: On exit: */
+
+/* * * * + + + * * * u14 u25 u36 */
+/* * * + + + + * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */
+/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */
+
+/* Array elements marked * are not used by the routine; elements marked */
+/* + need not be set on entry, but are required by the routine to store */
+/* elements of U because of fill-in resulting from the row interchanges. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* KV is the number of superdiagonals in the factor U, allowing for */
+/* fill-in */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --ipiv;
+
+ /* Function Body */
+ kv = *ku + *kl;
+
+/* Test the input parameters. */
+
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*ldab < *kl + kv + 1) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGBTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment */
+
+ nb = ilaenv_(&c__1, "DGBTRF", " ", m, n, kl, ku);
+
+/* The block size must not exceed the limit set by the size of the */
+/* local arrays WORK13 and WORK31. */
+
+ nb = min(nb,64);
+
+ if (nb <= 1 || nb > *kl) {
+
+/* Use unblocked code */
+
+ dgbtf2_(m, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info);
+ } else {
+
+/* Use blocked code */
+
+/* Zero the superdiagonal elements of the work array WORK13 */
+
+ i__1 = nb;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work13[i__ + j * 65 - 66] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Zero the subdiagonal elements of the work array WORK31 */
+
+ i__1 = nb;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = nb;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ work31[i__ + j * 65 - 66] = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Gaussian elimination with partial pivoting */
+
+/* Set fill-in elements in columns KU+2 to KV to zero */
+
+ i__1 = min(kv,*n);
+ for (j = *ku + 2; j <= i__1; ++j) {
+ i__2 = *kl;
+ for (i__ = kv - j + 2; i__ <= i__2; ++i__) {
+ ab[i__ + j * ab_dim1] = 0.;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* JU is the index of the last column affected by the current */
+/* stage of the factorization */
+
+ ju = 1;
+
+ i__1 = min(*m,*n);
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = min(*m,*n) - j + 1;
+ jb = min(i__3,i__4);
+
+/* The active part of the matrix is partitioned */
+
+/* A11 A12 A13 */
+/* A21 A22 A23 */
+/* A31 A32 A33 */
+
+/* Here A11, A21 and A31 denote the current block of JB columns */
+/* which is about to be factorized. The number of rows in the */
+/* partitioning are JB, I2, I3 respectively, and the numbers */
+/* of columns are JB, J2, J3. The superdiagonal elements of A13 */
+/* and the subdiagonal elements of A31 lie outside the band. */
+
+/* Computing MIN */
+ i__3 = *kl - jb, i__4 = *m - j - jb + 1;
+ i2 = min(i__3,i__4);
+/* Computing MIN */
+ i__3 = jb, i__4 = *m - j - *kl + 1;
+ i3 = min(i__3,i__4);
+
+/* J2 and J3 are computed after JU has been updated. */
+
+/* Factorize the current block of JB columns */
+
+ i__3 = j + jb - 1;
+ for (jj = j; jj <= i__3; ++jj) {
+
+/* Set fill-in elements in column JJ+KV to zero */
+
+ if (jj + kv <= *n) {
+ i__4 = *kl;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ ab[i__ + (jj + kv) * ab_dim1] = 0.;
+/* L70: */
+ }
+ }
+
+/* Find pivot and test for singularity. KM is the number of */
+/* subdiagonal elements in the current column. */
+
+/* Computing MIN */
+ i__4 = *kl, i__5 = *m - jj;
+ km = min(i__4,i__5);
+ i__4 = km + 1;
+ jp = idamax_(&i__4, &ab[kv + 1 + jj * ab_dim1], &c__1);
+ ipiv[jj] = jp + jj - j;
+ if (ab[kv + jp + jj * ab_dim1] != 0.) {
+/* Computing MAX */
+/* Computing MIN */
+ i__6 = jj + *ku + jp - 1;
+ i__4 = ju, i__5 = min(i__6,*n);
+ ju = max(i__4,i__5);
+ if (jp != 1) {
+
+/* Apply interchange to columns J to J+JB-1 */
+
+ if (jp + jj - 1 < j + *kl) {
+
+ i__4 = *ldab - 1;
+ i__5 = *ldab - 1;
+ dswap_(&jb, &ab[kv + 1 + jj - j + j * ab_dim1], &
+ i__4, &ab[kv + jp + jj - j + j * ab_dim1],
+ &i__5);
+ } else {
+
+/* The interchange affects columns J to JJ-1 of A31 */
+/* which are stored in the work array WORK31 */
+
+ i__4 = jj - j;
+ i__5 = *ldab - 1;
+ dswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1],
+ &i__5, &work31[jp + jj - j - *kl - 1], &
+ c__65);
+ i__4 = j + jb - jj;
+ i__5 = *ldab - 1;
+ i__6 = *ldab - 1;
+ dswap_(&i__4, &ab[kv + 1 + jj * ab_dim1], &i__5, &
+ ab[kv + jp + jj * ab_dim1], &i__6);
+ }
+ }
+
+/* Compute multipliers */
+
+ d__1 = 1. / ab[kv + 1 + jj * ab_dim1];
+ dscal_(&km, &d__1, &ab[kv + 2 + jj * ab_dim1], &c__1);
+
+/* Update trailing submatrix within the band and within */
+/* the current block. JM is the index of the last column */
+/* which needs to be updated. */
+
+/* Computing MIN */
+ i__4 = ju, i__5 = j + jb - 1;
+ jm = min(i__4,i__5);
+ if (jm > jj) {
+ i__4 = jm - jj;
+ i__5 = *ldab - 1;
+ i__6 = *ldab - 1;
+ dger_(&km, &i__4, &c_b18, &ab[kv + 2 + jj * ab_dim1],
+ &c__1, &ab[kv + (jj + 1) * ab_dim1], &i__5, &
+ ab[kv + 1 + (jj + 1) * ab_dim1], &i__6);
+ }
+ } else {
+
+/* If pivot is zero, set INFO to the index of the pivot */
+/* unless a zero pivot has already been found. */
+
+ if (*info == 0) {
+ *info = jj;
+ }
+ }
+
+/* Copy current column of A31 into the work array WORK31 */
+
+/* Computing MIN */
+ i__4 = jj - j + 1;
+ nw = min(i__4,i3);
+ if (nw > 0) {
+ dcopy_(&nw, &ab[kv + *kl + 1 - jj + j + jj * ab_dim1], &
+ c__1, &work31[(jj - j + 1) * 65 - 65], &c__1);
+ }
+/* L80: */
+ }
+ if (j + jb <= *n) {
+
+/* Apply the row interchanges to the other blocks. */
+
+/* Computing MIN */
+ i__3 = ju - j + 1;
+ j2 = min(i__3,kv) - jb;
+/* Computing MAX */
+ i__3 = 0, i__4 = ju - j - kv + 1;
+ j3 = max(i__3,i__4);
+
+/* Use DLASWP to apply the row interchanges to A12, A22, and */
+/* A32. */
+
+ i__3 = *ldab - 1;
+ dlaswp_(&j2, &ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__3, &
+ c__1, &jb, &ipiv[j], &c__1);
+
+/* Adjust the pivot indices. */
+
+ i__3 = j + jb - 1;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ ipiv[i__] = ipiv[i__] + j - 1;
+/* L90: */
+ }
+
+/* Apply the row interchanges to A13, A23, and A33 */
+/* columnwise. */
+
+ k2 = j - 1 + jb + j2;
+ i__3 = j3;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ jj = k2 + i__;
+ i__4 = j + jb - 1;
+ for (ii = j + i__ - 1; ii <= i__4; ++ii) {
+ ip = ipiv[ii];
+ if (ip != ii) {
+ temp = ab[kv + 1 + ii - jj + jj * ab_dim1];
+ ab[kv + 1 + ii - jj + jj * ab_dim1] = ab[kv + 1 +
+ ip - jj + jj * ab_dim1];
+ ab[kv + 1 + ip - jj + jj * ab_dim1] = temp;
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+
+/* Update the relevant part of the trailing submatrix */
+
+ if (j2 > 0) {
+
+/* Update A12 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j2,
+ &c_b31, &ab[kv + 1 + j * ab_dim1], &i__3, &ab[kv
+ + 1 - jb + (j + jb) * ab_dim1], &i__4);
+
+ if (i2 > 0) {
+
+/* Update A22 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ i__5 = *ldab - 1;
+ dgemm_("No transpose", "No transpose", &i2, &j2, &jb,
+ &c_b18, &ab[kv + 1 + jb + j * ab_dim1], &i__3,
+ &ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__4,
+ &c_b31, &ab[kv + 1 + (j + jb) * ab_dim1], &
+ i__5);
+ }
+
+ if (i3 > 0) {
+
+/* Update A32 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ dgemm_("No transpose", "No transpose", &i3, &j2, &jb,
+ &c_b18, work31, &c__65, &ab[kv + 1 - jb + (j
+ + jb) * ab_dim1], &i__3, &c_b31, &ab[kv + *kl
+ + 1 - jb + (j + jb) * ab_dim1], &i__4);
+ }
+ }
+
+ if (j3 > 0) {
+
+/* Copy the lower triangle of A13 into the work array */
+/* WORK13 */
+
+ i__3 = j3;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = jb;
+ for (ii = jj; ii <= i__4; ++ii) {
+ work13[ii + jj * 65 - 66] = ab[ii - jj + 1 + (jj
+ + j + kv - 1) * ab_dim1];
+/* L120: */
+ }
+/* L130: */
+ }
+
+/* Update A13 in the work array */
+
+ i__3 = *ldab - 1;
+ dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j3,
+ &c_b31, &ab[kv + 1 + j * ab_dim1], &i__3, work13,
+ &c__65);
+
+ if (i2 > 0) {
+
+/* Update A23 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ dgemm_("No transpose", "No transpose", &i2, &j3, &jb,
+ &c_b18, &ab[kv + 1 + jb + j * ab_dim1], &i__3,
+ work13, &c__65, &c_b31, &ab[jb + 1 + (j + kv)
+ * ab_dim1], &i__4);
+ }
+
+ if (i3 > 0) {
+
+/* Update A33 */
+
+ i__3 = *ldab - 1;
+ dgemm_("No transpose", "No transpose", &i3, &j3, &jb,
+ &c_b18, work31, &c__65, work13, &c__65, &
+ c_b31, &ab[*kl + 1 + (j + kv) * ab_dim1], &
+ i__3);
+ }
+
+/* Copy the lower triangle of A13 back into place */
+
+ i__3 = j3;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = jb;
+ for (ii = jj; ii <= i__4; ++ii) {
+ ab[ii - jj + 1 + (jj + j + kv - 1) * ab_dim1] =
+ work13[ii + jj * 65 - 66];
+/* L140: */
+ }
+/* L150: */
+ }
+ }
+ } else {
+
+/* Adjust the pivot indices. */
+
+ i__3 = j + jb - 1;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ ipiv[i__] = ipiv[i__] + j - 1;
+/* L160: */
+ }
+ }
+
+/* Partially undo the interchanges in the current block to */
+/* restore the upper triangular form of A31 and copy the upper */
+/* triangle of A31 back into place */
+
+ i__3 = j;
+ for (jj = j + jb - 1; jj >= i__3; --jj) {
+ jp = ipiv[jj] - jj + 1;
+ if (jp != 1) {
+
+/* Apply interchange to columns J to JJ-1 */
+
+ if (jp + jj - 1 < j + *kl) {
+
+/* The interchange does not affect A31 */
+
+ i__4 = jj - j;
+ i__5 = *ldab - 1;
+ i__6 = *ldab - 1;
+ dswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], &
+ i__5, &ab[kv + jp + jj - j + j * ab_dim1], &
+ i__6);
+ } else {
+
+/* The interchange does affect A31 */
+
+ i__4 = jj - j;
+ i__5 = *ldab - 1;
+ dswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], &
+ i__5, &work31[jp + jj - j - *kl - 1], &c__65);
+ }
+ }
+
+/* Copy the current column of A31 back into place */
+
+/* Computing MIN */
+ i__4 = i3, i__5 = jj - j + 1;
+ nw = min(i__4,i__5);
+ if (nw > 0) {
+ dcopy_(&nw, &work31[(jj - j + 1) * 65 - 65], &c__1, &ab[
+ kv + *kl + 1 - jj + j + jj * ab_dim1], &c__1);
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+
+ return 0;
+
+/* End of DGBTRF */
+
+} /* dgbtrf_ */
diff --git a/SRC/dgbtrs.c b/SRC/dgbtrs.c
new file mode 100644
index 0000000..83d8460
--- /dev/null
+++ b/SRC/dgbtrs.c
@@ -0,0 +1,244 @@
+/* dgbtrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b7 = -1.;
+static integer c__1 = 1;
+static doublereal c_b23 = 1.;
+
+/* Subroutine */ int dgbtrs_(char *trans, integer *n, integer *kl, integer *
+ ku, integer *nrhs, doublereal *ab, integer *ldab, integer *ipiv,
+ doublereal *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, l, kd, lm;
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dswap_(integer *,
+ doublereal *, integer *, doublereal *, integer *), dtbsv_(char *,
+ char *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical lnoti;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGBTRS solves a system of linear equations */
+/* A * X = B or A' * X = B */
+/* with a general band matrix A using the LU factorization computed */
+/* by DGBTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A'* X = B (Transpose) */
+/* = 'C': A'* X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by DGBTRF. U is stored as an upper triangular band */
+/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
+/* the multipliers used during the factorization are stored in */
+/* rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= N, row i of the matrix was */
+/* interchanged with row IPIV(i). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*ldab < (*kl << 1) + *ku + 1) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGBTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ kd = *ku + *kl + 1;
+ lnoti = *kl > 0;
+
+ if (notran) {
+
+/* Solve A*X = B. */
+
+/* Solve L*X = B, overwriting B with X. */
+
+/* L is represented as a product of permutations and unit lower */
+/* triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), */
+/* where each transformation L(i) is a rank-one modification of */
+/* the identity matrix. */
+
+ if (lnoti) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *kl, i__3 = *n - j;
+ lm = min(i__2,i__3);
+ l = ipiv[j];
+ if (l != j) {
+ dswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb);
+ }
+ dger_(&lm, nrhs, &c_b7, &ab[kd + 1 + j * ab_dim1], &c__1, &b[
+ j + b_dim1], ldb, &b[j + 1 + b_dim1], ldb);
+/* L10: */
+ }
+ }
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Solve U*X = B, overwriting B with X. */
+
+ i__2 = *kl + *ku;
+ dtbsv_("Upper", "No transpose", "Non-unit", n, &i__2, &ab[
+ ab_offset], ldab, &b[i__ * b_dim1 + 1], &c__1);
+/* L20: */
+ }
+
+ } else {
+
+/* Solve A'*X = B. */
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Solve U'*X = B, overwriting B with X. */
+
+ i__2 = *kl + *ku;
+ dtbsv_("Upper", "Transpose", "Non-unit", n, &i__2, &ab[ab_offset],
+ ldab, &b[i__ * b_dim1 + 1], &c__1);
+/* L30: */
+ }
+
+/* Solve L'*X = B, overwriting B with X. */
+
+ if (lnoti) {
+ for (j = *n - 1; j >= 1; --j) {
+/* Computing MIN */
+ i__1 = *kl, i__2 = *n - j;
+ lm = min(i__1,i__2);
+ dgemv_("Transpose", &lm, nrhs, &c_b7, &b[j + 1 + b_dim1], ldb,
+ &ab[kd + 1 + j * ab_dim1], &c__1, &c_b23, &b[j +
+ b_dim1], ldb);
+ l = ipiv[j];
+ if (l != j) {
+ dswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb);
+ }
+/* L40: */
+ }
+ }
+ }
+ return 0;
+
+/* End of DGBTRS */
+
+} /* dgbtrs_ */
diff --git a/SRC/dgebak.c b/SRC/dgebak.c
new file mode 100644
index 0000000..db1af91
--- /dev/null
+++ b/SRC/dgebak.c
@@ -0,0 +1,237 @@
+/* dgebak.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgebak_(char *job, char *side, integer *n, integer *ilo,
+ integer *ihi, doublereal *scale, integer *m, doublereal *v, integer *
+ ldv, integer *info)
+{
+ /* System generated locals */
+ integer v_dim1, v_offset, i__1;
+
+ /* Local variables */
+ integer i__, k;
+ doublereal s;
+ integer ii;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical leftv;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical rightv;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGEBAK forms the right or left eigenvectors of a real general matrix */
+/* by backward transformation on the computed eigenvectors of the */
+/* balanced matrix output by DGEBAL. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies the type of backward transformation required: */
+/* = 'N', do nothing, return immediately; */
+/* = 'P', do backward transformation for permutation only; */
+/* = 'S', do backward transformation for scaling only; */
+/* = 'B', do backward transformations for both permutation and */
+/* scaling. */
+/* JOB must be the same as the argument JOB supplied to DGEBAL. */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'R': V contains right eigenvectors; */
+/* = 'L': V contains left eigenvectors. */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrix V. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* The integers ILO and IHI determined by DGEBAL. */
+/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
+
+/* SCALE (input) DOUBLE PRECISION array, dimension (N) */
+/* Details of the permutation and scaling factors, as returned */
+/* by DGEBAL. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix V. M >= 0. */
+
+/* V (input/output) DOUBLE PRECISION array, dimension (LDV,M) */
+/* On entry, the matrix of right or left eigenvectors to be */
+/* transformed, as returned by DHSEIN or DTREVC. */
+/* On exit, V is overwritten by the transformed eigenvectors. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. LDV >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and Test the input parameters */
+
+ /* Parameter adjustments */
+ --scale;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+
+ /* Function Body */
+ rightv = lsame_(side, "R");
+ leftv = lsame_(side, "L");
+
+ *info = 0;
+ if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
+ && ! lsame_(job, "B")) {
+ *info = -1;
+ } else if (! rightv && ! leftv) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ilo < 1 || *ilo > max(1,*n)) {
+ *info = -4;
+ } else if (*ihi < min(*ilo,*n) || *ihi > *n) {
+ *info = -5;
+ } else if (*m < 0) {
+ *info = -7;
+ } else if (*ldv < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGEBAK", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+ if (*m == 0) {
+ return 0;
+ }
+ if (lsame_(job, "N")) {
+ return 0;
+ }
+
+ if (*ilo == *ihi) {
+ goto L30;
+ }
+
+/* Backward balance */
+
+ if (lsame_(job, "S") || lsame_(job, "B")) {
+
+ if (rightv) {
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ s = scale[i__];
+ dscal_(m, &s, &v[i__ + v_dim1], ldv);
+/* L10: */
+ }
+ }
+
+ if (leftv) {
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ s = 1. / scale[i__];
+ dscal_(m, &s, &v[i__ + v_dim1], ldv);
+/* L20: */
+ }
+ }
+
+ }
+
+/* Backward permutation */
+
+/* For I = ILO-1 step -1 until 1, */
+/* IHI+1 step 1 until N do -- */
+
+L30:
+ if (lsame_(job, "P") || lsame_(job, "B")) {
+ if (rightv) {
+ i__1 = *n;
+ for (ii = 1; ii <= i__1; ++ii) {
+ i__ = ii;
+ if (i__ >= *ilo && i__ <= *ihi) {
+ goto L40;
+ }
+ if (i__ < *ilo) {
+ i__ = *ilo - ii;
+ }
+ k = (integer) scale[i__];
+ if (k == i__) {
+ goto L40;
+ }
+ dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L40:
+ ;
+ }
+ }
+
+ if (leftv) {
+ i__1 = *n;
+ for (ii = 1; ii <= i__1; ++ii) {
+ i__ = ii;
+ if (i__ >= *ilo && i__ <= *ihi) {
+ goto L50;
+ }
+ if (i__ < *ilo) {
+ i__ = *ilo - ii;
+ }
+ k = (integer) scale[i__];
+ if (k == i__) {
+ goto L50;
+ }
+ dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L50:
+ ;
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DGEBAK */
+
+} /* dgebak_ */
diff --git a/SRC/dgebal.c b/SRC/dgebal.c
new file mode 100644
index 0000000..aef5ab8
--- /dev/null
+++ b/SRC/dgebal.c
@@ -0,0 +1,402 @@
+/* dgebal.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dgebal_(char *job, integer *n, doublereal *a, integer *
+ lda, integer *ilo, integer *ihi, doublereal *scale, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ doublereal c__, f, g;
+ integer i__, j, k, l, m;
+ doublereal r__, s, ca, ra;
+ integer ica, ira, iexc;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ doublereal sfmin1, sfmin2, sfmax1, sfmax2;
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical noconv;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGEBAL balances a general real matrix A. This involves, first, */
+/* permuting A by a similarity transformation to isolate eigenvalues */
+/* in the first 1 to ILO-1 and last IHI+1 to N elements on the */
+/* diagonal; and second, applying a diagonal similarity transformation */
+/* to rows and columns ILO to IHI to make the rows and columns as */
+/* close in norm as possible. Both steps are optional. */
+
+/* Balancing may reduce the 1-norm of the matrix, and improve the */
+/* accuracy of the computed eigenvalues and/or eigenvectors. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies the operations to be performed on A: */
+/* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 */
+/* for i = 1,...,N; */
+/* = 'P': permute only; */
+/* = 'S': scale only; */
+/* = 'B': both permute and scale. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the input matrix A. */
+/* On exit, A is overwritten by the balanced matrix. */
+/* If JOB = 'N', A is not referenced. */
+/* See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* ILO (output) INTEGER */
+/* IHI (output) INTEGER */
+/* ILO and IHI are set to integers such that on exit */
+/* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. */
+/* If JOB = 'N' or 'S', ILO = 1 and IHI = N. */
+
+/* SCALE (output) DOUBLE PRECISION array, dimension (N) */
+/* Details of the permutations and scaling factors applied to */
+/* A. If P(j) is the index of the row and column interchanged */
+/* with row and column j and D(j) is the scaling factor */
+/* applied to row and column j, then */
+/* SCALE(j) = P(j) for j = 1,...,ILO-1 */
+/* = D(j) for j = ILO,...,IHI */
+/* = P(j) for j = IHI+1,...,N. */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The permutations consist of row and column interchanges which put */
+/* the matrix in the form */
+
+/* ( T1 X Y ) */
+/* P A P = ( 0 B Z ) */
+/* ( 0 0 T2 ) */
+
+/* where T1 and T2 are upper triangular matrices whose eigenvalues lie */
+/* along the diagonal. The column indices ILO and IHI mark the starting */
+/* and ending columns of the submatrix B. Balancing consists of applying */
+/* a diagonal similarity transformation inv(D) * B * D to make the */
+/* 1-norms of each row of B and its corresponding column nearly equal. */
+/* The output matrix is */
+
+/* ( T1 X*D Y ) */
+/* ( 0 inv(D)*B*D inv(D)*Z ). */
+/* ( 0 0 T2 ) */
+
+/* Information about the permutations P and the diagonal matrix D is */
+/* returned in the vector SCALE. */
+
+/* This subroutine is based on the EISPACK routine BALANC. */
+
+/* Modified by Tzu-Yi Chen, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --scale;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
+ && ! lsame_(job, "B")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGEBAL", &i__1);
+ return 0;
+ }
+
+ k = 1;
+ l = *n;
+
+ if (*n == 0) {
+ goto L210;
+ }
+
+ if (lsame_(job, "N")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ scale[i__] = 1.;
+/* L10: */
+ }
+ goto L210;
+ }
+
+ if (lsame_(job, "S")) {
+ goto L120;
+ }
+
+/* Permutation to isolate eigenvalues if possible */
+
+ goto L50;
+
+/* Row and column exchange. */
+
+L20:
+ scale[m] = (doublereal) j;
+ if (j == m) {
+ goto L30;
+ }
+
+ dswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
+ i__1 = *n - k + 1;
+ dswap_(&i__1, &a[j + k * a_dim1], lda, &a[m + k * a_dim1], lda);
+
+L30:
+ switch (iexc) {
+ case 1: goto L40;
+ case 2: goto L80;
+ }
+
+/* Search for rows isolating an eigenvalue and push them down. */
+
+L40:
+ if (l == 1) {
+ goto L210;
+ }
+ --l;
+
+L50:
+ for (j = l; j >= 1; --j) {
+
+ i__1 = l;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (i__ == j) {
+ goto L60;
+ }
+ if (a[j + i__ * a_dim1] != 0.) {
+ goto L70;
+ }
+L60:
+ ;
+ }
+
+ m = l;
+ iexc = 1;
+ goto L20;
+L70:
+ ;
+ }
+
+ goto L90;
+
+/* Search for columns isolating an eigenvalue and push them left. */
+
+L80:
+ ++k;
+
+L90:
+ i__1 = l;
+ for (j = k; j <= i__1; ++j) {
+
+ i__2 = l;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ if (i__ == j) {
+ goto L100;
+ }
+ if (a[i__ + j * a_dim1] != 0.) {
+ goto L110;
+ }
+L100:
+ ;
+ }
+
+ m = k;
+ iexc = 2;
+ goto L20;
+L110:
+ ;
+ }
+
+L120:
+ i__1 = l;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ scale[i__] = 1.;
+/* L130: */
+ }
+
+ if (lsame_(job, "P")) {
+ goto L210;
+ }
+
+/* Balance the submatrix in rows K to L. */
+
+/* Iterative loop for norm reduction */
+
+ sfmin1 = dlamch_("S") / dlamch_("P");
+ sfmax1 = 1. / sfmin1;
+ sfmin2 = sfmin1 * 2.;
+ sfmax2 = 1. / sfmin2;
+L140:
+ noconv = FALSE_;
+
+ i__1 = l;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ c__ = 0.;
+ r__ = 0.;
+
+ i__2 = l;
+ for (j = k; j <= i__2; ++j) {
+ if (j == i__) {
+ goto L150;
+ }
+ c__ += (d__1 = a[j + i__ * a_dim1], abs(d__1));
+ r__ += (d__1 = a[i__ + j * a_dim1], abs(d__1));
+L150:
+ ;
+ }
+ ica = idamax_(&l, &a[i__ * a_dim1 + 1], &c__1);
+ ca = (d__1 = a[ica + i__ * a_dim1], abs(d__1));
+ i__2 = *n - k + 1;
+ ira = idamax_(&i__2, &a[i__ + k * a_dim1], lda);
+ ra = (d__1 = a[i__ + (ira + k - 1) * a_dim1], abs(d__1));
+
+/* Guard against zero C or R due to underflow. */
+
+ if (c__ == 0. || r__ == 0.) {
+ goto L200;
+ }
+ g = r__ / 2.;
+ f = 1.;
+ s = c__ + r__;
+L160:
+/* Computing MAX */
+ d__1 = max(f,c__);
+/* Computing MIN */
+ d__2 = min(r__,g);
+ if (c__ >= g || max(d__1,ca) >= sfmax2 || min(d__2,ra) <= sfmin2) {
+ goto L170;
+ }
+ f *= 2.;
+ c__ *= 2.;
+ ca *= 2.;
+ r__ /= 2.;
+ g /= 2.;
+ ra /= 2.;
+ goto L160;
+
+L170:
+ g = c__ / 2.;
+L180:
+/* Computing MIN */
+ d__1 = min(f,c__), d__1 = min(d__1,g);
+ if (g < r__ || max(r__,ra) >= sfmax2 || min(d__1,ca) <= sfmin2) {
+ goto L190;
+ }
+ f /= 2.;
+ c__ /= 2.;
+ g /= 2.;
+ ca /= 2.;
+ r__ *= 2.;
+ ra *= 2.;
+ goto L180;
+
+/* Now balance. */
+
+L190:
+ if (c__ + r__ >= s * .95) {
+ goto L200;
+ }
+ if (f < 1. && scale[i__] < 1.) {
+ if (f * scale[i__] <= sfmin1) {
+ goto L200;
+ }
+ }
+ if (f > 1. && scale[i__] > 1.) {
+ if (scale[i__] >= sfmax1 / f) {
+ goto L200;
+ }
+ }
+ g = 1. / f;
+ scale[i__] *= f;
+ noconv = TRUE_;
+
+ i__2 = *n - k + 1;
+ dscal_(&i__2, &g, &a[i__ + k * a_dim1], lda);
+ dscal_(&l, &f, &a[i__ * a_dim1 + 1], &c__1);
+
+L200:
+ ;
+ }
+
+ if (noconv) {
+ goto L140;
+ }
+
+L210:
+ *ilo = k;
+ *ihi = l;
+
+ return 0;
+
+/* End of DGEBAL */
+
+} /* dgebal_ */
diff --git a/SRC/dgebd2.c b/SRC/dgebd2.c
new file mode 100644
index 0000000..e2e5472
--- /dev/null
+++ b/SRC/dgebd2.c
@@ -0,0 +1,304 @@
+/* dgebd2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dgebd2_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *d__, doublereal *e, doublereal *tauq, doublereal *
+ taup, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__;
+ extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *), dlarfg_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGEBD2 reduces a real general m by n matrix A to upper or lower */
+/* bidiagonal form B by an orthogonal transformation: Q' * A * P = B. */
+
+/* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows in the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns in the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the m by n general matrix to be reduced. */
+/* On exit, */
+/* if m >= n, the diagonal and the first superdiagonal are */
+/* overwritten with the upper bidiagonal matrix B; the */
+/* elements below the diagonal, with the array TAUQ, represent */
+/* the orthogonal matrix Q as a product of elementary */
+/* reflectors, and the elements above the first superdiagonal, */
+/* with the array TAUP, represent the orthogonal matrix P as */
+/* a product of elementary reflectors; */
+/* if m < n, the diagonal and the first subdiagonal are */
+/* overwritten with the lower bidiagonal matrix B; the */
+/* elements below the first subdiagonal, with the array TAUQ, */
+/* represent the orthogonal matrix Q as a product of */
+/* elementary reflectors, and the elements above the diagonal, */
+/* with the array TAUP, represent the orthogonal matrix P as */
+/* a product of elementary reflectors. */
+/* See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* D (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The diagonal elements of the bidiagonal matrix B: */
+/* D(i) = A(i,i). */
+
+/* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) */
+/* The off-diagonal elements of the bidiagonal matrix B: */
+/* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */
+/* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */
+
+/* TAUQ (output) DOUBLE PRECISION array dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the orthogonal matrix Q. See Further Details. */
+
+/* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the orthogonal matrix P. See Further Details. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (max(M,N)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrices Q and P are represented as products of elementary */
+/* reflectors: */
+
+/* If m >= n, */
+
+/* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) */
+
+/* Each H(i) and G(i) has the form: */
+
+/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
+
+/* where tauq and taup are real scalars, and v and u are real vectors; */
+/* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); */
+/* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); */
+/* tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* If m < n, */
+
+/* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) */
+
+/* Each H(i) and G(i) has the form: */
+
+/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
+
+/* where tauq and taup are real scalars, and v and u are real vectors; */
+/* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); */
+/* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); */
+/* tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* The contents of A on exit are illustrated by the following examples: */
+
+/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
+
+/* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) */
+/* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) */
+/* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) */
+/* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) */
+/* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) */
+/* ( v1 v2 v3 v4 v5 ) */
+
+/* where d and e denote diagonal and off-diagonal elements of B, vi */
+/* denotes an element of the vector defining H(i), and ui an element of */
+/* the vector defining G(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ --tauq;
+ --taup;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("DGEBD2", &i__1);
+ return 0;
+ }
+
+ if (*m >= *n) {
+
+/* Reduce to upper bidiagonal form */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
+
+ i__2 = *m - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3, *m)+ i__ *
+ a_dim1], &c__1, &tauq[i__]);
+ d__[i__] = a[i__ + i__ * a_dim1];
+ a[i__ + i__ * a_dim1] = 1.;
+
+/* Apply H(i) to A(i:m,i+1:n) from the left */
+
+ if (i__ < *n) {
+ i__2 = *m - i__ + 1;
+ i__3 = *n - i__;
+ dlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
+ tauq[i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]
+);
+ }
+ a[i__ + i__ * a_dim1] = d__[i__];
+
+ if (i__ < *n) {
+
+/* Generate elementary reflector G(i) to annihilate */
+/* A(i,i+2:n) */
+
+ i__2 = *n - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + min(
+ i__3, *n)* a_dim1], lda, &taup[i__]);
+ e[i__] = a[i__ + (i__ + 1) * a_dim1];
+ a[i__ + (i__ + 1) * a_dim1] = 1.;
+
+/* Apply G(i) to A(i+1:m,i+1:n) from the right */
+
+ i__2 = *m - i__;
+ i__3 = *n - i__;
+ dlarf_("Right", &i__2, &i__3, &a[i__ + (i__ + 1) * a_dim1],
+ lda, &taup[i__], &a[i__ + 1 + (i__ + 1) * a_dim1],
+ lda, &work[1]);
+ a[i__ + (i__ + 1) * a_dim1] = e[i__];
+ } else {
+ taup[i__] = 0.;
+ }
+/* L10: */
+ }
+ } else {
+
+/* Reduce to lower bidiagonal form */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Generate elementary reflector G(i) to annihilate A(i,i+1:n) */
+
+ i__2 = *n - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3, *n)*
+ a_dim1], lda, &taup[i__]);
+ d__[i__] = a[i__ + i__ * a_dim1];
+ a[i__ + i__ * a_dim1] = 1.;
+
+/* Apply G(i) to A(i+1:m,i:n) from the right */
+
+ if (i__ < *m) {
+ i__2 = *m - i__;
+ i__3 = *n - i__ + 1;
+ dlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &
+ taup[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]);
+ }
+ a[i__ + i__ * a_dim1] = d__[i__];
+
+ if (i__ < *m) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* A(i+2:m,i) */
+
+ i__2 = *m - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *m)+
+ i__ * a_dim1], &c__1, &tauq[i__]);
+ e[i__] = a[i__ + 1 + i__ * a_dim1];
+ a[i__ + 1 + i__ * a_dim1] = 1.;
+
+/* Apply H(i) to A(i+1:m,i+1:n) from the left */
+
+ i__2 = *m - i__;
+ i__3 = *n - i__;
+ dlarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &
+ c__1, &tauq[i__], &a[i__ + 1 + (i__ + 1) * a_dim1],
+ lda, &work[1]);
+ a[i__ + 1 + i__ * a_dim1] = e[i__];
+ } else {
+ tauq[i__] = 0.;
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+/* End of DGEBD2 */
+
+} /* dgebd2_ */
diff --git a/SRC/dgebrd.c b/SRC/dgebrd.c
new file mode 100644
index 0000000..d5202c8
--- /dev/null
+++ b/SRC/dgebrd.c
@@ -0,0 +1,336 @@
+/* dgebrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+static doublereal c_b21 = -1.;
+static doublereal c_b22 = 1.;
+
+/* Subroutine */ int dgebrd_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *d__, doublereal *e, doublereal *tauq, doublereal *
+ taup, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, nb, nx;
+ doublereal ws;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ integer nbmin, iinfo, minmn;
+ extern /* Subroutine */ int dgebd2_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *), dlabrd_(integer *, integer *, integer *
+, doublereal *, integer *, doublereal *, doublereal *, doublereal
+ *, doublereal *, doublereal *, integer *, doublereal *, integer *)
+ , xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwrkx, ldwrky, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGEBRD reduces a general real M-by-N matrix A to upper or lower */
+/* bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. */
+
+/* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows in the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns in the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N general matrix to be reduced. */
+/* On exit, */
+/* if m >= n, the diagonal and the first superdiagonal are */
+/* overwritten with the upper bidiagonal matrix B; the */
+/* elements below the diagonal, with the array TAUQ, represent */
+/* the orthogonal matrix Q as a product of elementary */
+/* reflectors, and the elements above the first superdiagonal, */
+/* with the array TAUP, represent the orthogonal matrix P as */
+/* a product of elementary reflectors; */
+/* if m < n, the diagonal and the first subdiagonal are */
+/* overwritten with the lower bidiagonal matrix B; the */
+/* elements below the first subdiagonal, with the array TAUQ, */
+/* represent the orthogonal matrix Q as a product of */
+/* elementary reflectors, and the elements above the diagonal, */
+/* with the array TAUP, represent the orthogonal matrix P as */
+/* a product of elementary reflectors. */
+/* See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* D (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The diagonal elements of the bidiagonal matrix B: */
+/* D(i) = A(i,i). */
+
+/* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) */
+/* The off-diagonal elements of the bidiagonal matrix B: */
+/* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */
+/* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */
+
+/* TAUQ (output) DOUBLE PRECISION array dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the orthogonal matrix Q. See Further Details. */
+
+/* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the orthogonal matrix P. See Further Details. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(1,M,N). */
+/* For optimum performance LWORK >= (M+N)*NB, where NB */
+/* is the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrices Q and P are represented as products of elementary */
+/* reflectors: */
+
+/* If m >= n, */
+
+/* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) */
+
+/* Each H(i) and G(i) has the form: */
+
+/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
+
+/* where tauq and taup are real scalars, and v and u are real vectors; */
+/* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); */
+/* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); */
+/* tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* If m < n, */
+
+/* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) */
+
+/* Each H(i) and G(i) has the form: */
+
+/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
+
+/* where tauq and taup are real scalars, and v and u are real vectors; */
+/* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); */
+/* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); */
+/* tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* The contents of A on exit are illustrated by the following examples: */
+
+/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
+
+/* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) */
+/* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) */
+/* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) */
+/* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) */
+/* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) */
+/* ( v1 v2 v3 v4 v5 ) */
+
+/* where d and e denote diagonal and off-diagonal elements of B, vi */
+/* denotes an element of the vector defining H(i), and ui an element of */
+/* the vector defining G(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ --tauq;
+ --taup;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+/* Computing MAX */
+ i__1 = 1, i__2 = ilaenv_(&c__1, "DGEBRD", " ", m, n, &c_n1, &c_n1);
+ nb = max(i__1,i__2);
+ lwkopt = (*m + *n) * nb;
+ work[1] = (doublereal) lwkopt;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ if (*lwork < max(i__1,*n) && ! lquery) {
+ *info = -10;
+ }
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("DGEBRD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ minmn = min(*m,*n);
+ if (minmn == 0) {
+ work[1] = 1.;
+ return 0;
+ }
+
+ ws = (doublereal) max(*m,*n);
+ ldwrkx = *m;
+ ldwrky = *n;
+
+ if (nb > 1 && nb < minmn) {
+
+/* Set the crossover point NX. */
+
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__3, "DGEBRD", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+
+/* Determine when to switch from blocked to unblocked code. */
+
+ if (nx < minmn) {
+ ws = (doublereal) ((*m + *n) * nb);
+ if ((doublereal) (*lwork) < ws) {
+
+/* Not enough work space for the optimal NB, consider using */
+/* a smaller block size. */
+
+ nbmin = ilaenv_(&c__2, "DGEBRD", " ", m, n, &c_n1, &c_n1);
+ if (*lwork >= (*m + *n) * nbmin) {
+ nb = *lwork / (*m + *n);
+ } else {
+ nb = 1;
+ nx = minmn;
+ }
+ }
+ }
+ } else {
+ nx = minmn;
+ }
+
+ i__1 = minmn - nx;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+
+/* Reduce rows and columns i:i+nb-1 to bidiagonal form and return */
+/* the matrices X and Y which are needed to update the unreduced */
+/* part of the matrix */
+
+ i__3 = *m - i__ + 1;
+ i__4 = *n - i__ + 1;
+ dlabrd_(&i__3, &i__4, &nb, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[
+ i__], &tauq[i__], &taup[i__], &work[1], &ldwrkx, &work[ldwrkx
+ * nb + 1], &ldwrky);
+
+/* Update the trailing submatrix A(i+nb:m,i+nb:n), using an update */
+/* of the form A := A - V*Y' - X*U' */
+
+ i__3 = *m - i__ - nb + 1;
+ i__4 = *n - i__ - nb + 1;
+ dgemm_("No transpose", "Transpose", &i__3, &i__4, &nb, &c_b21, &a[i__
+ + nb + i__ * a_dim1], lda, &work[ldwrkx * nb + nb + 1], &
+ ldwrky, &c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda);
+ i__3 = *m - i__ - nb + 1;
+ i__4 = *n - i__ - nb + 1;
+ dgemm_("No transpose", "No transpose", &i__3, &i__4, &nb, &c_b21, &
+ work[nb + 1], &ldwrkx, &a[i__ + (i__ + nb) * a_dim1], lda, &
+ c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda);
+
+/* Copy diagonal and off-diagonal elements of B back into A */
+
+ if (*m >= *n) {
+ i__3 = i__ + nb - 1;
+ for (j = i__; j <= i__3; ++j) {
+ a[j + j * a_dim1] = d__[j];
+ a[j + (j + 1) * a_dim1] = e[j];
+/* L10: */
+ }
+ } else {
+ i__3 = i__ + nb - 1;
+ for (j = i__; j <= i__3; ++j) {
+ a[j + j * a_dim1] = d__[j];
+ a[j + 1 + j * a_dim1] = e[j];
+/* L20: */
+ }
+ }
+/* L30: */
+ }
+
+/* Use unblocked code to reduce the remainder of the matrix */
+
+ i__2 = *m - i__ + 1;
+ i__1 = *n - i__ + 1;
+ dgebd2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], &
+ tauq[i__], &taup[i__], &work[1], &iinfo);
+ work[1] = ws;
+ return 0;
+
+/* End of DGEBRD */
+
+} /* dgebrd_ */
diff --git a/SRC/dgecon.c b/SRC/dgecon.c
new file mode 100644
index 0000000..ba86cf6
--- /dev/null
+++ b/SRC/dgecon.c
@@ -0,0 +1,226 @@
+/* dgecon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dgecon_(char *norm, integer *n, doublereal *a, integer *
+ lda, doublereal *anorm, doublereal *rcond, doublereal *work, integer *
+ iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ doublereal d__1;
+
+ /* Local variables */
+ doublereal sl;
+ integer ix;
+ doublereal su;
+ integer kase, kase1;
+ doublereal scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int drscl_(integer *, doublereal *, doublereal *,
+ integer *), dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int dlatrs_(char *, char *, char *, char *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *);
+ logical onenrm;
+ char normin[1];
+ doublereal smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGECON estimates the reciprocal of the condition number of a general */
+/* real matrix A, in either the 1-norm or the infinity-norm, using */
+/* the LU factorization computed by DGETRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as */
+/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The factors L and U from the factorization A = P*L*U */
+/* as computed by DGETRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* ANORM (input) DOUBLE PRECISION */
+/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */
+/* If NORM = 'I', the infinity-norm of the original matrix A. */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*anorm < 0.) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGECON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.;
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ } else if (*anorm == 0.) {
+ return 0;
+ }
+
+ smlnum = dlamch_("Safe minimum");
+
+/* Estimate the norm of inv(A). */
+
+ ainvnm = 0.;
+ *(unsigned char *)normin = 'N';
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kase = 0;
+L10:
+ dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(L). */
+
+ dlatrs_("Lower", "No transpose", "Unit", normin, n, &a[a_offset],
+ lda, &work[1], &sl, &work[(*n << 1) + 1], info);
+
+/* Multiply by inv(U). */
+
+ dlatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[
+ a_offset], lda, &work[1], &su, &work[*n * 3 + 1], info);
+ } else {
+
+/* Multiply by inv(U'). */
+
+ dlatrs_("Upper", "Transpose", "Non-unit", normin, n, &a[a_offset],
+ lda, &work[1], &su, &work[*n * 3 + 1], info);
+
+/* Multiply by inv(L'). */
+
+ dlatrs_("Lower", "Transpose", "Unit", normin, n, &a[a_offset],
+ lda, &work[1], &sl, &work[(*n << 1) + 1], info);
+ }
+
+/* Divide X by 1/(SL*SU) if doing so will not cause overflow. */
+
+ scale = sl * su;
+ *(unsigned char *)normin = 'Y';
+ if (scale != 1.) {
+ ix = idamax_(n, &work[1], &c__1);
+ if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.)
+ {
+ goto L20;
+ }
+ drscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / ainvnm / *anorm;
+ }
+
+L20:
+ return 0;
+
+/* End of DGECON */
+
+} /* dgecon_ */
diff --git a/SRC/dgeequ.c b/SRC/dgeequ.c
new file mode 100644
index 0000000..b0b1462
--- /dev/null
+++ b/SRC/dgeequ.c
@@ -0,0 +1,296 @@
+/* dgeequ.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgeequ_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *r__, doublereal *c__, doublereal *rowcnd, doublereal
+ *colcnd, doublereal *amax, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal rcmin, rcmax;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum, smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGEEQU computes row and column scalings intended to equilibrate an */
+/* M-by-N matrix A and reduce its condition number. R returns the row */
+/* scale factors and C the column scale factors, chosen to try to make */
+/* the largest element in each row and column of the matrix B with */
+/* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. */
+
+/* R(i) and C(j) are restricted to be between SMLNUM = smallest safe */
+/* number and BIGNUM = largest safe number. Use of these scaling */
+/* factors is not guaranteed to reduce the condition number of A but */
+/* works well in practice. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The M-by-N matrix whose equilibration factors are */
+/* to be computed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* R (output) DOUBLE PRECISION array, dimension (M) */
+/* If INFO = 0 or INFO > M, R contains the row scale factors */
+/* for A. */
+
+/* C (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, C contains the column scale factors for A. */
+
+/* ROWCND (output) DOUBLE PRECISION */
+/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */
+/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */
+/* AMAX is neither too large nor too small, it is not worth */
+/* scaling by R. */
+
+/* COLCND (output) DOUBLE PRECISION */
+/* If INFO = 0, COLCND contains the ratio of the smallest */
+/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */
+/* worth scaling by C. */
+
+/* AMAX (output) DOUBLE PRECISION */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= M: the i-th row of A is exactly zero */
+/* > M: the (i-M)-th column of A is exactly zero */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGEEQU", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ *rowcnd = 1.;
+ *colcnd = 1.;
+ *amax = 0.;
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+
+/* Compute row scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__[i__] = 0.;
+/* L10: */
+ }
+
+/* Find the maximum element in each row. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = r__[i__], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ r__[i__] = max(d__2,d__3);
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = rcmax, d__2 = r__[i__];
+ rcmax = max(d__1,d__2);
+/* Computing MIN */
+ d__1 = rcmin, d__2 = r__[i__];
+ rcmin = min(d__1,d__2);
+/* L40: */
+ }
+ *amax = rcmax;
+
+ if (rcmin == 0.) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] == 0.) {
+ *info = i__;
+ return 0;
+ }
+/* L50: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MIN */
+/* Computing MAX */
+ d__2 = r__[i__];
+ d__1 = max(d__2,smlnum);
+ r__[i__] = 1. / min(d__1,bignum);
+/* L60: */
+ }
+
+/* Compute ROWCND = min(R(I)) / max(R(I)) */
+
+ *rowcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ }
+
+/* Compute column scale factors */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 0.;
+/* L70: */
+ }
+
+/* Find the maximum element in each column, */
+/* assuming the row scaling computed above. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = c__[j], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)) *
+ r__[i__];
+ c__[j] = max(d__2,d__3);
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = c__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = c__[j];
+ rcmax = max(d__1,d__2);
+/* L100: */
+ }
+
+ if (rcmin == 0.) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (c__[j] == 0.) {
+ *info = *m + j;
+ return 0;
+ }
+/* L110: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+/* Computing MAX */
+ d__2 = c__[j];
+ d__1 = max(d__2,smlnum);
+ c__[j] = 1. / min(d__1,bignum);
+/* L120: */
+ }
+
+/* Compute COLCND = min(C(J)) / max(C(J)) */
+
+ *colcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ }
+
+ return 0;
+
+/* End of DGEEQU */
+
+} /* dgeequ_ */
diff --git a/SRC/dgeequb.c b/SRC/dgeequb.c
new file mode 100644
index 0000000..fbaeb2f
--- /dev/null
+++ b/SRC/dgeequb.c
@@ -0,0 +1,324 @@
+/* dgeequb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgeequb_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *r__, doublereal *c__, doublereal *rowcnd, doublereal
+ *colcnd, doublereal *amax, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double log(doublereal), pow_di(doublereal *, integer *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal radix, rcmin, rcmax;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum, logrdx, smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGEEQUB computes row and column scalings intended to equilibrate an */
+/* M-by-N matrix A and reduce its condition number. R returns the row */
+/* scale factors and C the column scale factors, chosen to try to make */
+/* the largest element in each row and column of the matrix B with */
+/* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most */
+/* the radix. */
+
+/* R(i) and C(j) are restricted to be a power of the radix between */
+/* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use */
+/* of these scaling factors is not guaranteed to reduce the condition */
+/* number of A but works well in practice. */
+
+/* This routine differs from DGEEQU by restricting the scaling factors */
+/* to a power of the radix. Baring over- and underflow, scaling by */
+/* these factors introduces no additional rounding errors. However, the */
+/* scaled entries' magnitured are no longer approximately 1 but lie */
+/* between sqrt(radix) and 1/sqrt(radix). */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The M-by-N matrix whose equilibration factors are */
+/* to be computed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* R (output) DOUBLE PRECISION array, dimension (M) */
+/* If INFO = 0 or INFO > M, R contains the row scale factors */
+/* for A. */
+
+/* C (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, C contains the column scale factors for A. */
+
+/* ROWCND (output) DOUBLE PRECISION */
+/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */
+/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */
+/* AMAX is neither too large nor too small, it is not worth */
+/* scaling by R. */
+
+/* COLCND (output) DOUBLE PRECISION */
+/* If INFO = 0, COLCND contains the ratio of the smallest */
+/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */
+/* worth scaling by C. */
+
+/* AMAX (output) DOUBLE PRECISION */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= M: the i-th row of A is exactly zero */
+/* > M: the (i-M)-th column of A is exactly zero */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGEEQUB", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ *rowcnd = 1.;
+ *colcnd = 1.;
+ *amax = 0.;
+ return 0;
+ }
+
+/* Get machine constants. Assume SMLNUM is a power of the radix. */
+
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+ radix = dlamch_("B");
+ logrdx = log(radix);
+
+/* Compute row scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__[i__] = 0.;
+/* L10: */
+ }
+
+/* Find the maximum element in each row. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = r__[i__], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ r__[i__] = max(d__2,d__3);
+/* L20: */
+ }
+/* L30: */
+ }
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] > 0.) {
+ i__2 = (integer) (log(r__[i__]) / logrdx);
+ r__[i__] = pow_di(&radix, &i__2);
+ }
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = rcmax, d__2 = r__[i__];
+ rcmax = max(d__1,d__2);
+/* Computing MIN */
+ d__1 = rcmin, d__2 = r__[i__];
+ rcmin = min(d__1,d__2);
+/* L40: */
+ }
+ *amax = rcmax;
+
+ if (rcmin == 0.) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] == 0.) {
+ *info = i__;
+ return 0;
+ }
+/* L50: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MIN */
+/* Computing MAX */
+ d__2 = r__[i__];
+ d__1 = max(d__2,smlnum);
+ r__[i__] = 1. / min(d__1,bignum);
+/* L60: */
+ }
+
+/* Compute ROWCND = min(R(I)) / max(R(I)). */
+
+ *rowcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ }
+
+/* Compute column scale factors */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 0.;
+/* L70: */
+ }
+
+/* Find the maximum element in each column, */
+/* assuming the row scaling computed above. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = c__[j], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)) *
+ r__[i__];
+ c__[j] = max(d__2,d__3);
+/* L80: */
+ }
+ if (c__[j] > 0.) {
+ i__2 = (integer) (log(c__[j]) / logrdx);
+ c__[j] = pow_di(&radix, &i__2);
+ }
+/* L90: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = c__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = c__[j];
+ rcmax = max(d__1,d__2);
+/* L100: */
+ }
+
+ if (rcmin == 0.) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (c__[j] == 0.) {
+ *info = *m + j;
+ return 0;
+ }
+/* L110: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+/* Computing MAX */
+ d__2 = c__[j];
+ d__1 = max(d__2,smlnum);
+ c__[j] = 1. / min(d__1,bignum);
+/* L120: */
+ }
+
+/* Compute COLCND = min(C(J)) / max(C(J)). */
+
+ *colcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ }
+
+ return 0;
+
+/* End of DGEEQUB */
+
+} /* dgeequb_ */
diff --git a/SRC/dgees.c b/SRC/dgees.c
new file mode 100644
index 0000000..9de8ab0
--- /dev/null
+++ b/SRC/dgees.c
@@ -0,0 +1,549 @@
+/* dgees.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dgees_(char *jobvs, char *sort, L_fp select, integer *n,
+ doublereal *a, integer *lda, integer *sdim, doublereal *wr,
+ doublereal *wi, doublereal *vs, integer *ldvs, doublereal *work,
+ integer *lwork, logical *bwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2, i__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal s;
+ integer i1, i2, ip, ihi, ilo;
+ doublereal dum[1], eps, sep;
+ integer ibal;
+ doublereal anrm;
+ integer idum[1], ierr, itau, iwrk, inxt, icond, ieval;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dswap_(integer *, doublereal *, integer
+ *, doublereal *, integer *);
+ logical cursl;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), dgebak_(
+ char *, char *, integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *),
+ dgebal_(char *, integer *, doublereal *, integer *, integer *,
+ integer *, doublereal *, integer *);
+ logical lst2sl, scalea;
+ extern doublereal dlamch_(char *);
+ doublereal cscale;
+ extern doublereal dlange_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dgehrd_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dlascl_(char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *), dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dorghr_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dhseqr_(char *, char *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dtrsen_(char *, char *, logical *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *, integer *, integer *);
+ logical lastsl;
+ integer minwrk, maxwrk;
+ doublereal smlnum;
+ integer hswork;
+ logical wantst, lquery, wantvs;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+/* .. Function Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGEES computes for an N-by-N real nonsymmetric matrix A, the */
+/* eigenvalues, the real Schur form T, and, optionally, the matrix of */
+/* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). */
+
+/* Optionally, it also orders the eigenvalues on the diagonal of the */
+/* real Schur form so that selected eigenvalues are at the top left. */
+/* The leading columns of Z then form an orthonormal basis for the */
+/* invariant subspace corresponding to the selected eigenvalues. */
+
+/* A matrix is in real Schur form if it is upper quasi-triangular with */
+/* 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the */
+/* form */
+/* [ a b ] */
+/* [ c a ] */
+
+/* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVS (input) CHARACTER*1 */
+/* = 'N': Schur vectors are not computed; */
+/* = 'V': Schur vectors are computed. */
+
+/* SORT (input) CHARACTER*1 */
+/* Specifies whether or not to order the eigenvalues on the */
+/* diagonal of the Schur form. */
+/* = 'N': Eigenvalues are not ordered; */
+/* = 'S': Eigenvalues are ordered (see SELECT). */
+
+/* SELECT (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments */
+/* SELECT must be declared EXTERNAL in the calling subroutine. */
+/* If SORT = 'S', SELECT is used to select eigenvalues to sort */
+/* to the top left of the Schur form. */
+/* If SORT = 'N', SELECT is not referenced. */
+/* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if */
+/* SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex */
+/* conjugate pair of eigenvalues is selected, then both complex */
+/* eigenvalues are selected. */
+/* Note that a selected complex eigenvalue may no longer */
+/* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since */
+/* ordering may change the value of complex eigenvalues */
+/* (especially if the eigenvalue is ill-conditioned); in this */
+/* case INFO is set to N+2 (see INFO below). */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+/* On exit, A has been overwritten by its real Schur form T. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* SDIM (output) INTEGER */
+/* If SORT = 'N', SDIM = 0. */
+/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */
+/* for which SELECT is true. (Complex conjugate */
+/* pairs for which SELECT is true for either */
+/* eigenvalue count as 2.) */
+
+/* WR (output) DOUBLE PRECISION array, dimension (N) */
+/* WI (output) DOUBLE PRECISION array, dimension (N) */
+/* WR and WI contain the real and imaginary parts, */
+/* respectively, of the computed eigenvalues in the same order */
+/* that they appear on the diagonal of the output Schur form T. */
+/* Complex conjugate pairs of eigenvalues will appear */
+/* consecutively with the eigenvalue having the positive */
+/* imaginary part first. */
+
+/* VS (output) DOUBLE PRECISION array, dimension (LDVS,N) */
+/* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur */
+/* vectors. */
+/* If JOBVS = 'N', VS is not referenced. */
+
+/* LDVS (input) INTEGER */
+/* The leading dimension of the array VS. LDVS >= 1; if */
+/* JOBVS = 'V', LDVS >= N. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) contains the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,3*N). */
+/* For good performance, LWORK must generally be larger. */
+
+/* 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. */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+/* Not referenced if SORT = 'N'. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, and i is */
+/* <= N: the QR algorithm failed to compute all the */
+/* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI */
+/* contain those eigenvalues which have converged; if */
+/* JOBVS = 'V', VS contains the matrix which reduces A */
+/* to its partially converged Schur form. */
+/* = N+1: the eigenvalues could not be reordered because some */
+/* eigenvalues were too close to separate (the problem */
+/* is very ill-conditioned); */
+/* = N+2: after reordering, roundoff changed values of some */
+/* complex eigenvalues so that leading eigenvalues in */
+/* the Schur form no longer satisfy SELECT=.TRUE. This */
+/* could also be caused by underflow due to scaling. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --wr;
+ --wi;
+ vs_dim1 = *ldvs;
+ vs_offset = 1 + vs_dim1;
+ vs -= vs_offset;
+ --work;
+ --bwork;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ wantvs = lsame_(jobvs, "V");
+ wantst = lsame_(sort, "S");
+ if (! wantvs && ! lsame_(jobvs, "N")) {
+ *info = -1;
+ } else if (! wantst && ! lsame_(sort, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldvs < 1 || wantvs && *ldvs < *n) {
+ *info = -11;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. */
+/* HSWORK refers to the workspace preferred by DHSEQR, as */
+/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
+/* the worst case.) */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ } else {
+ maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "DGEHRD", " ", n, &c__1,
+ n, &c__0);
+ minwrk = *n * 3;
+
+ dhseqr_("S", jobvs, n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[1]
+, &vs[vs_offset], ldvs, &work[1], &c_n1, &ieval);
+ hswork = (integer) work[1];
+
+ if (! wantvs) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + hswork;
+ maxwrk = max(i__1,i__2);
+ } else {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
+ "DORGHR", " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + hswork;
+ maxwrk = max(i__1,i__2);
+ }
+ }
+ work[1] = (doublereal) maxwrk;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGEES ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *sdim = 0;
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1. / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = dlange_("M", n, n, &a[a_offset], lda, dum);
+ scalea = FALSE_;
+ if (anrm > 0. && anrm < smlnum) {
+ scalea = TRUE_;
+ cscale = smlnum;
+ } else if (anrm > bignum) {
+ scalea = TRUE_;
+ cscale = bignum;
+ }
+ if (scalea) {
+ dlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Permute the matrix to make it more nearly triangular */
+/* (Workspace: need N) */
+
+ ibal = 1;
+ dgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr);
+
+/* Reduce to upper Hessenberg form */
+/* (Workspace: need 3*N, prefer 2*N+N*NB) */
+
+ itau = *n + ibal;
+ iwrk = *n + itau;
+ i__1 = *lwork - iwrk + 1;
+ dgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
+ &ierr);
+
+ if (wantvs) {
+
+/* Copy Householder vectors to VS */
+
+ dlacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs)
+ ;
+
+/* Generate orthogonal matrix in VS */
+/* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+
+ i__1 = *lwork - iwrk + 1;
+ dorghr_(n, &ilo, &ihi, &vs[vs_offset], ldvs, &work[itau], &work[iwrk],
+ &i__1, &ierr);
+ }
+
+ *sdim = 0;
+
+/* Perform QR iteration, accumulating Schur vectors in VS if desired */
+/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ dhseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &vs[
+ vs_offset], ldvs, &work[iwrk], &i__1, &ieval);
+ if (ieval > 0) {
+ *info = ieval;
+ }
+
+/* Sort eigenvalues if desired */
+
+ if (wantst && *info == 0) {
+ if (scalea) {
+ dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wr[1], n, &
+ ierr);
+ dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wi[1], n, &
+ ierr);
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ bwork[i__] = (*select)(&wr[i__], &wi[i__]);
+/* L10: */
+ }
+
+/* Reorder eigenvalues and transform Schur vectors */
+/* (Workspace: none needed) */
+
+ i__1 = *lwork - iwrk + 1;
+ dtrsen_("N", jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset],
+ ldvs, &wr[1], &wi[1], sdim, &s, &sep, &work[iwrk], &i__1,
+ idum, &c__1, &icond);
+ if (icond > 0) {
+ *info = *n + icond;
+ }
+ }
+
+ if (wantvs) {
+
+/* Undo balancing */
+/* (Workspace: need N) */
+
+ dgebak_("P", "R", n, &ilo, &ihi, &work[ibal], n, &vs[vs_offset], ldvs,
+ &ierr);
+ }
+
+ if (scalea) {
+
+/* Undo scaling for the Schur form of A */
+
+ dlascl_("H", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, &
+ ierr);
+ i__1 = *lda + 1;
+ dcopy_(n, &a[a_offset], &i__1, &wr[1], &c__1);
+ if (cscale == smlnum) {
+
+/* If scaling back towards underflow, adjust WI if an */
+/* offdiagonal element of a 2-by-2 block in the Schur form */
+/* underflows. */
+
+ if (ieval > 0) {
+ i1 = ieval + 1;
+ i2 = ihi - 1;
+ i__1 = ilo - 1;
+/* Computing MAX */
+ i__3 = ilo - 1;
+ i__2 = max(i__3,1);
+ dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[
+ 1], &i__2, &ierr);
+ } else if (wantst) {
+ i1 = 1;
+ i2 = *n - 1;
+ } else {
+ i1 = ilo;
+ i2 = ihi - 1;
+ }
+ inxt = i1 - 1;
+ i__1 = i2;
+ for (i__ = i1; i__ <= i__1; ++i__) {
+ if (i__ < inxt) {
+ goto L20;
+ }
+ if (wi[i__] == 0.) {
+ inxt = i__ + 1;
+ } else {
+ if (a[i__ + 1 + i__ * a_dim1] == 0.) {
+ wi[i__] = 0.;
+ wi[i__ + 1] = 0.;
+ } else if (a[i__ + 1 + i__ * a_dim1] != 0. && a[i__ + (
+ i__ + 1) * a_dim1] == 0.) {
+ wi[i__] = 0.;
+ wi[i__ + 1] = 0.;
+ if (i__ > 1) {
+ i__2 = i__ - 1;
+ dswap_(&i__2, &a[i__ * a_dim1 + 1], &c__1, &a[(
+ i__ + 1) * a_dim1 + 1], &c__1);
+ }
+ if (*n > i__ + 1) {
+ i__2 = *n - i__ - 1;
+ dswap_(&i__2, &a[i__ + (i__ + 2) * a_dim1], lda, &
+ a[i__ + 1 + (i__ + 2) * a_dim1], lda);
+ }
+ if (wantvs) {
+ dswap_(n, &vs[i__ * vs_dim1 + 1], &c__1, &vs[(i__
+ + 1) * vs_dim1 + 1], &c__1);
+ }
+ a[i__ + (i__ + 1) * a_dim1] = a[i__ + 1 + i__ *
+ a_dim1];
+ a[i__ + 1 + i__ * a_dim1] = 0.;
+ }
+ inxt = i__ + 2;
+ }
+L20:
+ ;
+ }
+ }
+
+/* Undo scaling for the imaginary part of the eigenvalues */
+
+ i__1 = *n - ieval;
+/* Computing MAX */
+ i__3 = *n - ieval;
+ i__2 = max(i__3,1);
+ dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[ieval +
+ 1], &i__2, &ierr);
+ }
+
+ if (wantst && *info == 0) {
+
+/* Check if reordering successful */
+
+ lastsl = TRUE_;
+ lst2sl = TRUE_;
+ *sdim = 0;
+ ip = 0;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ cursl = (*select)(&wr[i__], &wi[i__]);
+ if (wi[i__] == 0.) {
+ if (cursl) {
+ ++(*sdim);
+ }
+ ip = 0;
+ if (cursl && ! lastsl) {
+ *info = *n + 2;
+ }
+ } else {
+ if (ip == 1) {
+
+/* Last eigenvalue of conjugate pair */
+
+ cursl = cursl || lastsl;
+ lastsl = cursl;
+ if (cursl) {
+ *sdim += 2;
+ }
+ ip = -1;
+ if (cursl && ! lst2sl) {
+ *info = *n + 2;
+ }
+ } else {
+
+/* First eigenvalue of conjugate pair */
+
+ ip = 1;
+ }
+ }
+ lst2sl = lastsl;
+ lastsl = cursl;
+/* L30: */
+ }
+ }
+
+ work[1] = (doublereal) maxwrk;
+ return 0;
+
+/* End of DGEES */
+
+} /* dgees_ */
diff --git a/SRC/dgeesx.c b/SRC/dgeesx.c
new file mode 100644
index 0000000..d404f4a
--- /dev/null
+++ b/SRC/dgeesx.c
@@ -0,0 +1,649 @@
+/* dgeesx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dgeesx_(char *jobvs, char *sort, L_fp select, char *
+ sense, integer *n, doublereal *a, integer *lda, integer *sdim,
+ doublereal *wr, doublereal *wi, doublereal *vs, integer *ldvs,
+ doublereal *rconde, doublereal *rcondv, doublereal *work, integer *
+ lwork, integer *iwork, integer *liwork, logical *bwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2, i__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, i1, i2, ip, ihi, ilo;
+ doublereal dum[1], eps;
+ integer ibal;
+ doublereal anrm;
+ integer ierr, itau, iwrk, lwrk, inxt, icond, ieval;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dswap_(integer *, doublereal *, integer
+ *, doublereal *, integer *);
+ logical cursl;
+ integer liwrk;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), dgebak_(
+ char *, char *, integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *),
+ dgebal_(char *, integer *, doublereal *, integer *, integer *,
+ integer *, doublereal *, integer *);
+ logical lst2sl, scalea;
+ extern doublereal dlamch_(char *);
+ doublereal cscale;
+ extern doublereal dlange_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dgehrd_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dlascl_(char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *), dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dorghr_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dhseqr_(char *, char *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+ logical wantsb;
+ extern /* Subroutine */ int dtrsen_(char *, char *, logical *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *, integer *, integer *);
+ logical wantse, lastsl;
+ integer minwrk, maxwrk;
+ logical wantsn;
+ doublereal smlnum;
+ integer hswork;
+ logical wantst, lquery, wantsv, wantvs;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+/* .. Function Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGEESX computes for an N-by-N real nonsymmetric matrix A, the */
+/* eigenvalues, the real Schur form T, and, optionally, the matrix of */
+/* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). */
+
+/* Optionally, it also orders the eigenvalues on the diagonal of the */
+/* real Schur form so that selected eigenvalues are at the top left; */
+/* computes a reciprocal condition number for the average of the */
+/* selected eigenvalues (RCONDE); and computes a reciprocal condition */
+/* number for the right invariant subspace corresponding to the */
+/* selected eigenvalues (RCONDV). The leading columns of Z form an */
+/* orthonormal basis for this invariant subspace. */
+
+/* For further explanation of the reciprocal condition numbers RCONDE */
+/* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where */
+/* these quantities are called s and sep respectively). */
+
+/* A real matrix is in real Schur form if it is upper quasi-triangular */
+/* with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in */
+/* the form */
+/* [ a b ] */
+/* [ c a ] */
+
+/* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVS (input) CHARACTER*1 */
+/* = 'N': Schur vectors are not computed; */
+/* = 'V': Schur vectors are computed. */
+
+/* SORT (input) CHARACTER*1 */
+/* Specifies whether or not to order the eigenvalues on the */
+/* diagonal of the Schur form. */
+/* = 'N': Eigenvalues are not ordered; */
+/* = 'S': Eigenvalues are ordered (see SELECT). */
+
+/* SELECT (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments */
+/* SELECT must be declared EXTERNAL in the calling subroutine. */
+/* If SORT = 'S', SELECT is used to select eigenvalues to sort */
+/* to the top left of the Schur form. */
+/* If SORT = 'N', SELECT is not referenced. */
+/* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if */
+/* SELECT(WR(j),WI(j)) is true; i.e., if either one of a */
+/* complex conjugate pair of eigenvalues is selected, then both */
+/* are. Note that a selected complex eigenvalue may no longer */
+/* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since */
+/* ordering may change the value of complex eigenvalues */
+/* (especially if the eigenvalue is ill-conditioned); in this */
+/* case INFO may be set to N+3 (see INFO below). */
+
+/* SENSE (input) CHARACTER*1 */
+/* Determines which reciprocal condition numbers are computed. */
+/* = 'N': None are computed; */
+/* = 'E': Computed for average of selected eigenvalues only; */
+/* = 'V': Computed for selected right invariant subspace only; */
+/* = 'B': Computed for both. */
+/* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
+/* On entry, the N-by-N matrix A. */
+/* On exit, A is overwritten by its real Schur form T. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* SDIM (output) INTEGER */
+/* If SORT = 'N', SDIM = 0. */
+/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */
+/* for which SELECT is true. (Complex conjugate */
+/* pairs for which SELECT is true for either */
+/* eigenvalue count as 2.) */
+
+/* WR (output) DOUBLE PRECISION array, dimension (N) */
+/* WI (output) DOUBLE PRECISION array, dimension (N) */
+/* WR and WI contain the real and imaginary parts, respectively, */
+/* of the computed eigenvalues, in the same order that they */
+/* appear on the diagonal of the output Schur form T. Complex */
+/* conjugate pairs of eigenvalues appear consecutively with the */
+/* eigenvalue having the positive imaginary part first. */
+
+/* VS (output) DOUBLE PRECISION array, dimension (LDVS,N) */
+/* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur */
+/* vectors. */
+/* If JOBVS = 'N', VS is not referenced. */
+
+/* LDVS (input) INTEGER */
+/* The leading dimension of the array VS. LDVS >= 1, and if */
+/* JOBVS = 'V', LDVS >= N. */
+
+/* RCONDE (output) DOUBLE PRECISION */
+/* If SENSE = 'E' or 'B', RCONDE contains the reciprocal */
+/* condition number for the average of the selected eigenvalues. */
+/* Not referenced if SENSE = 'N' or 'V'. */
+
+/* RCONDV (output) DOUBLE PRECISION */
+/* If SENSE = 'V' or 'B', RCONDV contains the reciprocal */
+/* condition number for the selected right invariant subspace. */
+/* Not referenced if SENSE = 'N' or 'E'. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,3*N). */
+/* Also, if SENSE = 'E' or 'V' or 'B', */
+/* LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of */
+/* selected eigenvalues computed by this routine. Note that */
+/* N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only */
+/* returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or */
+/* 'B' this may not be large enough. */
+/* For good performance, LWORK must generally be larger. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates upper bounds on the optimal sizes of the */
+/* arrays WORK and IWORK, returns these values as the first */
+/* entries of the WORK and IWORK arrays, and no error messages */
+/* related to LWORK or LIWORK are issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM). */
+/* Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is */
+/* only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this */
+/* may not be large enough. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates upper bounds on the optimal sizes of */
+/* the arrays WORK and IWORK, returns these values as the first */
+/* entries of the WORK and IWORK arrays, and no error messages */
+/* related to LWORK or LIWORK are issued by XERBLA. */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+/* Not referenced if SORT = 'N'. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, and i is */
+/* <= N: the QR algorithm failed to compute all the */
+/* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI */
+/* contain those eigenvalues which have converged; if */
+/* JOBVS = 'V', VS contains the transformation which */
+/* reduces A to its partially converged Schur form. */
+/* = N+1: the eigenvalues could not be reordered because some */
+/* eigenvalues were too close to separate (the problem */
+/* is very ill-conditioned); */
+/* = N+2: after reordering, roundoff changed values of some */
+/* complex eigenvalues so that leading eigenvalues in */
+/* the Schur form no longer satisfy SELECT=.TRUE. This */
+/* could also be caused by underflow due to scaling. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --wr;
+ --wi;
+ vs_dim1 = *ldvs;
+ vs_offset = 1 + vs_dim1;
+ vs -= vs_offset;
+ --work;
+ --iwork;
+ --bwork;
+
+ /* Function Body */
+ *info = 0;
+ wantvs = lsame_(jobvs, "V");
+ wantst = lsame_(sort, "S");
+ wantsn = lsame_(sense, "N");
+ wantse = lsame_(sense, "E");
+ wantsv = lsame_(sense, "V");
+ wantsb = lsame_(sense, "B");
+ lquery = *lwork == -1 || *liwork == -1;
+ if (! wantvs && ! lsame_(jobvs, "N")) {
+ *info = -1;
+ } else if (! wantst && ! lsame_(sort, "N")) {
+ *info = -2;
+ } else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && !
+ wantsn) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvs < 1 || wantvs && *ldvs < *n) {
+ *info = -12;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "RWorkspace:" describe the */
+/* minimal amount of real workspace needed at that point in the */
+/* code, as well as the preferred amount for good performance. */
+/* IWorkspace refers to integer workspace. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. */
+/* HSWORK refers to the workspace preferred by DHSEQR, as */
+/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
+/* the worst case. */
+/* If SENSE = 'E', 'V' or 'B', then the amount of workspace needed */
+/* depends on SDIM, which is computed by the routine DTRSEN later */
+/* in the code.) */
+
+ if (*info == 0) {
+ liwrk = 1;
+ if (*n == 0) {
+ minwrk = 1;
+ lwrk = 1;
+ } else {
+ maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "DGEHRD", " ", n, &c__1,
+ n, &c__0);
+ minwrk = *n * 3;
+
+ dhseqr_("S", jobvs, n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[1]
+, &vs[vs_offset], ldvs, &work[1], &c_n1, &ieval);
+ hswork = (integer) work[1];
+
+ if (! wantvs) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + hswork;
+ maxwrk = max(i__1,i__2);
+ } else {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
+ "DORGHR", " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + hswork;
+ maxwrk = max(i__1,i__2);
+ }
+ lwrk = maxwrk;
+ if (! wantsn) {
+/* Computing MAX */
+ i__1 = lwrk, i__2 = *n + *n * *n / 2;
+ lwrk = max(i__1,i__2);
+ }
+ if (wantsv || wantsb) {
+ liwrk = *n * *n / 4;
+ }
+ }
+ iwork[1] = liwrk;
+ work[1] = (doublereal) lwrk;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -16;
+ } else if (*liwork < 1 && ! lquery) {
+ *info = -18;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGEESX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *sdim = 0;
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1. / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = dlange_("M", n, n, &a[a_offset], lda, dum);
+ scalea = FALSE_;
+ if (anrm > 0. && anrm < smlnum) {
+ scalea = TRUE_;
+ cscale = smlnum;
+ } else if (anrm > bignum) {
+ scalea = TRUE_;
+ cscale = bignum;
+ }
+ if (scalea) {
+ dlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Permute the matrix to make it more nearly triangular */
+/* (RWorkspace: need N) */
+
+ ibal = 1;
+ dgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr);
+
+/* Reduce to upper Hessenberg form */
+/* (RWorkspace: need 3*N, prefer 2*N+N*NB) */
+
+ itau = *n + ibal;
+ iwrk = *n + itau;
+ i__1 = *lwork - iwrk + 1;
+ dgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
+ &ierr);
+
+ if (wantvs) {
+
+/* Copy Householder vectors to VS */
+
+ dlacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs)
+ ;
+
+/* Generate orthogonal matrix in VS */
+/* (RWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+
+ i__1 = *lwork - iwrk + 1;
+ dorghr_(n, &ilo, &ihi, &vs[vs_offset], ldvs, &work[itau], &work[iwrk],
+ &i__1, &ierr);
+ }
+
+ *sdim = 0;
+
+/* Perform QR iteration, accumulating Schur vectors in VS if desired */
+/* (RWorkspace: need N+1, prefer N+HSWORK (see comments) ) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ dhseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &vs[
+ vs_offset], ldvs, &work[iwrk], &i__1, &ieval);
+ if (ieval > 0) {
+ *info = ieval;
+ }
+
+/* Sort eigenvalues if desired */
+
+ if (wantst && *info == 0) {
+ if (scalea) {
+ dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wr[1], n, &
+ ierr);
+ dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wi[1], n, &
+ ierr);
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ bwork[i__] = (*select)(&wr[i__], &wi[i__]);
+/* L10: */
+ }
+
+/* Reorder eigenvalues, transform Schur vectors, and compute */
+/* reciprocal condition numbers */
+/* (RWorkspace: if SENSE is not 'N', need N+2*SDIM*(N-SDIM) */
+/* otherwise, need N ) */
+/* (IWorkspace: if SENSE is 'V' or 'B', need SDIM*(N-SDIM) */
+/* otherwise, need 0 ) */
+
+ i__1 = *lwork - iwrk + 1;
+ dtrsen_(sense, jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset],
+ ldvs, &wr[1], &wi[1], sdim, rconde, rcondv, &work[iwrk], &
+ i__1, &iwork[1], liwork, &icond);
+ if (! wantsn) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + (*sdim << 1) * (*n - *sdim);
+ maxwrk = max(i__1,i__2);
+ }
+ if (icond == -15) {
+
+/* Not enough real workspace */
+
+ *info = -16;
+ } else if (icond == -17) {
+
+/* Not enough integer workspace */
+
+ *info = -18;
+ } else if (icond > 0) {
+
+/* DTRSEN failed to reorder or to restore standard Schur form */
+
+ *info = icond + *n;
+ }
+ }
+
+ if (wantvs) {
+
+/* Undo balancing */
+/* (RWorkspace: need N) */
+
+ dgebak_("P", "R", n, &ilo, &ihi, &work[ibal], n, &vs[vs_offset], ldvs,
+ &ierr);
+ }
+
+ if (scalea) {
+
+/* Undo scaling for the Schur form of A */
+
+ dlascl_("H", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, &
+ ierr);
+ i__1 = *lda + 1;
+ dcopy_(n, &a[a_offset], &i__1, &wr[1], &c__1);
+ if ((wantsv || wantsb) && *info == 0) {
+ dum[0] = *rcondv;
+ dlascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &
+ c__1, &ierr);
+ *rcondv = dum[0];
+ }
+ if (cscale == smlnum) {
+
+/* If scaling back towards underflow, adjust WI if an */
+/* offdiagonal element of a 2-by-2 block in the Schur form */
+/* underflows. */
+
+ if (ieval > 0) {
+ i1 = ieval + 1;
+ i2 = ihi - 1;
+ i__1 = ilo - 1;
+ dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[
+ 1], n, &ierr);
+ } else if (wantst) {
+ i1 = 1;
+ i2 = *n - 1;
+ } else {
+ i1 = ilo;
+ i2 = ihi - 1;
+ }
+ inxt = i1 - 1;
+ i__1 = i2;
+ for (i__ = i1; i__ <= i__1; ++i__) {
+ if (i__ < inxt) {
+ goto L20;
+ }
+ if (wi[i__] == 0.) {
+ inxt = i__ + 1;
+ } else {
+ if (a[i__ + 1 + i__ * a_dim1] == 0.) {
+ wi[i__] = 0.;
+ wi[i__ + 1] = 0.;
+ } else if (a[i__ + 1 + i__ * a_dim1] != 0. && a[i__ + (
+ i__ + 1) * a_dim1] == 0.) {
+ wi[i__] = 0.;
+ wi[i__ + 1] = 0.;
+ if (i__ > 1) {
+ i__2 = i__ - 1;
+ dswap_(&i__2, &a[i__ * a_dim1 + 1], &c__1, &a[(
+ i__ + 1) * a_dim1 + 1], &c__1);
+ }
+ if (*n > i__ + 1) {
+ i__2 = *n - i__ - 1;
+ dswap_(&i__2, &a[i__ + (i__ + 2) * a_dim1], lda, &
+ a[i__ + 1 + (i__ + 2) * a_dim1], lda);
+ }
+ dswap_(n, &vs[i__ * vs_dim1 + 1], &c__1, &vs[(i__ + 1)
+ * vs_dim1 + 1], &c__1);
+ a[i__ + (i__ + 1) * a_dim1] = a[i__ + 1 + i__ *
+ a_dim1];
+ a[i__ + 1 + i__ * a_dim1] = 0.;
+ }
+ inxt = i__ + 2;
+ }
+L20:
+ ;
+ }
+ }
+ i__1 = *n - ieval;
+/* Computing MAX */
+ i__3 = *n - ieval;
+ i__2 = max(i__3,1);
+ dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[ieval +
+ 1], &i__2, &ierr);
+ }
+
+ if (wantst && *info == 0) {
+
+/* Check if reordering successful */
+
+ lastsl = TRUE_;
+ lst2sl = TRUE_;
+ *sdim = 0;
+ ip = 0;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ cursl = (*select)(&wr[i__], &wi[i__]);
+ if (wi[i__] == 0.) {
+ if (cursl) {
+ ++(*sdim);
+ }
+ ip = 0;
+ if (cursl && ! lastsl) {
+ *info = *n + 2;
+ }
+ } else {
+ if (ip == 1) {
+
+/* Last eigenvalue of conjugate pair */
+
+ cursl = cursl || lastsl;
+ lastsl = cursl;
+ if (cursl) {
+ *sdim += 2;
+ }
+ ip = -1;
+ if (cursl && ! lst2sl) {
+ *info = *n + 2;
+ }
+ } else {
+
+/* First eigenvalue of conjugate pair */
+
+ ip = 1;
+ }
+ }
+ lst2sl = lastsl;
+ lastsl = cursl;
+/* L30: */
+ }
+ }
+
+ work[1] = (doublereal) maxwrk;
+ if (wantsv || wantsb) {
+/* Computing MAX */
+ i__1 = 1, i__2 = *sdim * (*n - *sdim);
+ iwork[1] = max(i__1,i__2);
+ } else {
+ iwork[1] = 1;
+ }
+
+ return 0;
+
+/* End of DGEESX */
+
+} /* dgeesx_ */
diff --git a/SRC/dgeev.c b/SRC/dgeev.c
new file mode 100644
index 0000000..d523306
--- /dev/null
+++ b/SRC/dgeev.c
@@ -0,0 +1,566 @@
+/* dgeev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dgeev_(char *jobvl, char *jobvr, integer *n, doublereal *
+ a, integer *lda, doublereal *wr, doublereal *wi, doublereal *vl,
+ integer *ldvl, doublereal *vr, integer *ldvr, doublereal *work,
+ integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
+ i__2, i__3;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, k;
+ doublereal r__, cs, sn;
+ integer ihi;
+ doublereal scl;
+ integer ilo;
+ doublereal dum[1], eps;
+ integer ibal;
+ char side[1];
+ doublereal anrm;
+ integer ierr, itau;
+ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ integer iwrk, nout;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern doublereal dlapy2_(doublereal *, doublereal *);
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), dgebak_(
+ char *, char *, integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *),
+ dgebal_(char *, integer *, doublereal *, integer *, integer *,
+ integer *, doublereal *, integer *);
+ logical scalea;
+ extern doublereal dlamch_(char *);
+ doublereal cscale;
+ extern doublereal dlange_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dgehrd_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dlascl_(char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *), xerbla_(char *, integer *);
+ logical select[1];
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dorghr_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dhseqr_(char *, char *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dtrevc_(char *, char *, logical *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *, integer *, doublereal *, integer *);
+ integer minwrk, maxwrk;
+ logical wantvl;
+ doublereal smlnum;
+ integer hswork;
+ logical lquery, wantvr;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGEEV computes for an N-by-N real nonsymmetric matrix A, the */
+/* eigenvalues and, optionally, the left and/or right eigenvectors. */
+
+/* The right eigenvector v(j) of A satisfies */
+/* A * v(j) = lambda(j) * v(j) */
+/* where lambda(j) is its eigenvalue. */
+/* The left eigenvector u(j) of A satisfies */
+/* u(j)**H * A = lambda(j) * u(j)**H */
+/* where u(j)**H denotes the conjugate transpose of u(j). */
+
+/* The computed eigenvectors are normalized to have Euclidean norm */
+/* equal to 1 and largest component real. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVL (input) CHARACTER*1 */
+/* = 'N': left eigenvectors of A are not computed; */
+/* = 'V': left eigenvectors of A are computed. */
+
+/* JOBVR (input) CHARACTER*1 */
+/* = 'N': right eigenvectors of A are not computed; */
+/* = 'V': right eigenvectors of A are computed. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+/* On exit, A has been overwritten. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* WR (output) DOUBLE PRECISION array, dimension (N) */
+/* WI (output) DOUBLE PRECISION array, dimension (N) */
+/* WR and WI contain the real and imaginary parts, */
+/* respectively, of the computed eigenvalues. Complex */
+/* conjugate pairs of eigenvalues appear consecutively */
+/* with the eigenvalue having the positive imaginary part */
+/* first. */
+
+/* VL (output) DOUBLE PRECISION array, dimension (LDVL,N) */
+/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
+/* after another in the columns of VL, in the same order */
+/* as their eigenvalues. */
+/* If JOBVL = 'N', VL is not referenced. */
+/* If the j-th eigenvalue is real, then u(j) = VL(:,j), */
+/* the j-th column of VL. */
+/* If the j-th and (j+1)-st eigenvalues form a complex */
+/* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and */
+/* u(j+1) = VL(:,j) - i*VL(:,j+1). */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. LDVL >= 1; if */
+/* JOBVL = 'V', LDVL >= N. */
+
+/* VR (output) DOUBLE PRECISION array, dimension (LDVR,N) */
+/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
+/* after another in the columns of VR, in the same order */
+/* as their eigenvalues. */
+/* If JOBVR = 'N', VR is not referenced. */
+/* If the j-th eigenvalue is real, then v(j) = VR(:,j), */
+/* the j-th column of VR. */
+/* If the j-th and (j+1)-st eigenvalues form a complex */
+/* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and */
+/* v(j+1) = VR(:,j) - i*VR(:,j+1). */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. LDVR >= 1; if */
+/* JOBVR = 'V', LDVR >= N. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,3*N), and */
+/* if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good */
+/* performance, LWORK must generally be larger. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the QR algorithm failed to compute all the */
+/* eigenvalues, and no eigenvectors have been computed; */
+/* elements i+1:N of WR and WI contain eigenvalues which */
+/* have converged. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --wr;
+ --wi;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ wantvl = lsame_(jobvl, "V");
+ wantvr = lsame_(jobvr, "V");
+ if (! wantvl && ! lsame_(jobvl, "N")) {
+ *info = -1;
+ } else if (! wantvr && ! lsame_(jobvr, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldvl < 1 || wantvl && *ldvl < *n) {
+ *info = -9;
+ } else if (*ldvr < 1 || wantvr && *ldvr < *n) {
+ *info = -11;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. */
+/* HSWORK refers to the workspace preferred by DHSEQR, as */
+/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
+/* the worst case.) */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ } else {
+ maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "DGEHRD", " ", n, &c__1,
+ n, &c__0);
+ if (wantvl) {
+ minwrk = *n << 2;
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
+ "DORGHR", " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ dhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
+ 1], &vl[vl_offset], ldvl, &work[1], &c_n1, info);
+ hswork = (integer) work[1];
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = *
+ n + hswork;
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n << 2;
+ maxwrk = max(i__1,i__2);
+ } else if (wantvr) {
+ minwrk = *n << 2;
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
+ "DORGHR", " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ dhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
+ 1], &vr[vr_offset], ldvr, &work[1], &c_n1, info);
+ hswork = (integer) work[1];
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = *
+ n + hswork;
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n << 2;
+ maxwrk = max(i__1,i__2);
+ } else {
+ minwrk = *n * 3;
+ dhseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
+ 1], &vr[vr_offset], ldvr, &work[1], &c_n1, info);
+ hswork = (integer) work[1];
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = *
+ n + hswork;
+ maxwrk = max(i__1,i__2);
+ }
+ maxwrk = max(maxwrk,minwrk);
+ }
+ work[1] = (doublereal) maxwrk;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGEEV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1. / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = dlange_("M", n, n, &a[a_offset], lda, dum);
+ scalea = FALSE_;
+ if (anrm > 0. && anrm < smlnum) {
+ scalea = TRUE_;
+ cscale = smlnum;
+ } else if (anrm > bignum) {
+ scalea = TRUE_;
+ cscale = bignum;
+ }
+ if (scalea) {
+ dlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Balance the matrix */
+/* (Workspace: need N) */
+
+ ibal = 1;
+ dgebal_("B", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr);
+
+/* Reduce to upper Hessenberg form */
+/* (Workspace: need 3*N, prefer 2*N+N*NB) */
+
+ itau = ibal + *n;
+ iwrk = itau + *n;
+ i__1 = *lwork - iwrk + 1;
+ dgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
+ &ierr);
+
+ if (wantvl) {
+
+/* Want left eigenvectors */
+/* Copy Householder vectors to VL */
+
+ *(unsigned char *)side = 'L';
+ dlacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
+ ;
+
+/* Generate orthogonal matrix in VL */
+/* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+
+ i__1 = *lwork - iwrk + 1;
+ dorghr_(n, &ilo, &ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk],
+ &i__1, &ierr);
+
+/* Perform QR iteration, accumulating Schur vectors in VL */
+/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ dhseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &
+ vl[vl_offset], ldvl, &work[iwrk], &i__1, info);
+
+ if (wantvr) {
+
+/* Want left and right eigenvectors */
+/* Copy Schur vectors to VR */
+
+ *(unsigned char *)side = 'B';
+ dlacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
+ }
+
+ } else if (wantvr) {
+
+/* Want right eigenvectors */
+/* Copy Householder vectors to VR */
+
+ *(unsigned char *)side = 'R';
+ dlacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
+ ;
+
+/* Generate orthogonal matrix in VR */
+/* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+
+ i__1 = *lwork - iwrk + 1;
+ dorghr_(n, &ilo, &ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk],
+ &i__1, &ierr);
+
+/* Perform QR iteration, accumulating Schur vectors in VR */
+/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ dhseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &
+ vr[vr_offset], ldvr, &work[iwrk], &i__1, info);
+
+ } else {
+
+/* Compute eigenvalues only */
+/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ dhseqr_("E", "N", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &
+ vr[vr_offset], ldvr, &work[iwrk], &i__1, info);
+ }
+
+/* If INFO > 0 from DHSEQR, then quit */
+
+ if (*info > 0) {
+ goto L50;
+ }
+
+ if (wantvl || wantvr) {
+
+/* Compute left and/or right eigenvectors */
+/* (Workspace: need 4*N) */
+
+ dtrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
+ &vr[vr_offset], ldvr, n, &nout, &work[iwrk], &ierr);
+ }
+
+ if (wantvl) {
+
+/* Undo balancing of left eigenvectors */
+/* (Workspace: need N) */
+
+ dgebak_("B", "L", n, &ilo, &ihi, &work[ibal], n, &vl[vl_offset], ldvl,
+ &ierr);
+
+/* Normalize left eigenvectors and make largest component real */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (wi[i__] == 0.) {
+ scl = 1. / dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
+ dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
+ } else if (wi[i__] > 0.) {
+ d__1 = dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
+ d__2 = dnrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
+ scl = 1. / dlapy2_(&d__1, &d__2);
+ dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
+ dscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+/* Computing 2nd power */
+ d__1 = vl[k + i__ * vl_dim1];
+/* Computing 2nd power */
+ d__2 = vl[k + (i__ + 1) * vl_dim1];
+ work[iwrk + k - 1] = d__1 * d__1 + d__2 * d__2;
+/* L10: */
+ }
+ k = idamax_(n, &work[iwrk], &c__1);
+ dlartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1],
+ &cs, &sn, &r__);
+ drot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) *
+ vl_dim1 + 1], &c__1, &cs, &sn);
+ vl[k + (i__ + 1) * vl_dim1] = 0.;
+ }
+/* L20: */
+ }
+ }
+
+ if (wantvr) {
+
+/* Undo balancing of right eigenvectors */
+/* (Workspace: need N) */
+
+ dgebak_("B", "R", n, &ilo, &ihi, &work[ibal], n, &vr[vr_offset], ldvr,
+ &ierr);
+
+/* Normalize right eigenvectors and make largest component real */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (wi[i__] == 0.) {
+ scl = 1. / dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
+ dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
+ } else if (wi[i__] > 0.) {
+ d__1 = dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
+ d__2 = dnrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
+ scl = 1. / dlapy2_(&d__1, &d__2);
+ dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
+ dscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+/* Computing 2nd power */
+ d__1 = vr[k + i__ * vr_dim1];
+/* Computing 2nd power */
+ d__2 = vr[k + (i__ + 1) * vr_dim1];
+ work[iwrk + k - 1] = d__1 * d__1 + d__2 * d__2;
+/* L30: */
+ }
+ k = idamax_(n, &work[iwrk], &c__1);
+ dlartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1],
+ &cs, &sn, &r__);
+ drot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) *
+ vr_dim1 + 1], &c__1, &cs, &sn);
+ vr[k + (i__ + 1) * vr_dim1] = 0.;
+ }
+/* L40: */
+ }
+ }
+
+/* Undo scaling if necessary */
+
+L50:
+ if (scalea) {
+ i__1 = *n - *info;
+/* Computing MAX */
+ i__3 = *n - *info;
+ i__2 = max(i__3,1);
+ dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info +
+ 1], &i__2, &ierr);
+ i__1 = *n - *info;
+/* Computing MAX */
+ i__3 = *n - *info;
+ i__2 = max(i__3,1);
+ dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info +
+ 1], &i__2, &ierr);
+ if (*info > 0) {
+ i__1 = ilo - 1;
+ dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1],
+ n, &ierr);
+ i__1 = ilo - 1;
+ dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1],
+ n, &ierr);
+ }
+ }
+
+ work[1] = (doublereal) maxwrk;
+ return 0;
+
+/* End of DGEEV */
+
+} /* dgeev_ */
diff --git a/SRC/dgeevx.c b/SRC/dgeevx.c
new file mode 100644
index 0000000..2907767
--- /dev/null
+++ b/SRC/dgeevx.c
@@ -0,0 +1,703 @@
+/* dgeevx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dgeevx_(char *balanc, char *jobvl, char *jobvr, char *
+ sense, integer *n, doublereal *a, integer *lda, doublereal *wr,
+ doublereal *wi, doublereal *vl, integer *ldvl, doublereal *vr,
+ integer *ldvr, integer *ilo, integer *ihi, doublereal *scale,
+ doublereal *abnrm, doublereal *rconde, doublereal *rcondv, doublereal
+ *work, integer *lwork, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
+ i__2, i__3;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, k;
+ doublereal r__, cs, sn;
+ char job[1];
+ doublereal scl, dum[1], eps;
+ char side[1];
+ doublereal anrm;
+ integer ierr, itau;
+ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ integer iwrk, nout;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ integer icond;
+ extern logical lsame_(char *, char *);
+ extern doublereal dlapy2_(doublereal *, doublereal *);
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), dgebak_(
+ char *, char *, integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *),
+ dgebal_(char *, integer *, doublereal *, integer *, integer *,
+ integer *, doublereal *, integer *);
+ logical scalea;
+ extern doublereal dlamch_(char *);
+ doublereal cscale;
+ extern doublereal dlange_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dgehrd_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dlascl_(char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *), xerbla_(char *, integer *);
+ logical select[1];
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dorghr_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dhseqr_(char *, char *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dtrevc_(char *, char *, logical *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *, integer *, doublereal *, integer *), dtrsna_(char *, char *, logical *, integer *, doublereal
+ *, integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *, integer *);
+ integer minwrk, maxwrk;
+ logical wantvl, wntsnb;
+ integer hswork;
+ logical wntsne;
+ doublereal smlnum;
+ logical lquery, wantvr, wntsnn, wntsnv;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGEEVX computes for an N-by-N real nonsymmetric matrix A, the */
+/* eigenvalues and, optionally, the left and/or right eigenvectors. */
+
+/* Optionally also, it computes a balancing transformation to improve */
+/* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */
+/* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues */
+/* (RCONDE), and reciprocal condition numbers for the right */
+/* eigenvectors (RCONDV). */
+
+/* The right eigenvector v(j) of A satisfies */
+/* A * v(j) = lambda(j) * v(j) */
+/* where lambda(j) is its eigenvalue. */
+/* The left eigenvector u(j) of A satisfies */
+/* u(j)**H * A = lambda(j) * u(j)**H */
+/* where u(j)**H denotes the conjugate transpose of u(j). */
+
+/* The computed eigenvectors are normalized to have Euclidean norm */
+/* equal to 1 and largest component real. */
+
+/* Balancing a matrix means permuting the rows and columns to make it */
+/* more nearly upper triangular, and applying a diagonal similarity */
+/* transformation D * A * D**(-1), where D is a diagonal matrix, to */
+/* make its rows and columns closer in norm and the condition numbers */
+/* of its eigenvalues and eigenvectors smaller. The computed */
+/* reciprocal condition numbers correspond to the balanced matrix. */
+/* Permuting rows and columns will not change the condition numbers */
+/* (in exact arithmetic) but diagonal scaling will. For further */
+/* explanation of balancing, see section 4.10.2 of the LAPACK */
+/* Users' Guide. */
+
+/* Arguments */
+/* ========= */
+
+/* BALANC (input) CHARACTER*1 */
+/* Indicates how the input matrix should be diagonally scaled */
+/* and/or permuted to improve the conditioning of its */
+/* eigenvalues. */
+/* = 'N': Do not diagonally scale or permute; */
+/* = 'P': Perform permutations to make the matrix more nearly */
+/* upper triangular. Do not diagonally scale; */
+/* = 'S': Diagonally scale the matrix, i.e. replace A by */
+/* D*A*D**(-1), where D is a diagonal matrix chosen */
+/* to make the rows and columns of A more equal in */
+/* norm. Do not permute; */
+/* = 'B': Both diagonally scale and permute A. */
+
+/* Computed reciprocal condition numbers will be for the matrix */
+/* after balancing and/or permuting. Permuting does not change */
+/* condition numbers (in exact arithmetic), but balancing does. */
+
+/* JOBVL (input) CHARACTER*1 */
+/* = 'N': left eigenvectors of A are not computed; */
+/* = 'V': left eigenvectors of A are computed. */
+/* If SENSE = 'E' or 'B', JOBVL must = 'V'. */
+
+/* JOBVR (input) CHARACTER*1 */
+/* = 'N': right eigenvectors of A are not computed; */
+/* = 'V': right eigenvectors of A are computed. */
+/* If SENSE = 'E' or 'B', JOBVR must = 'V'. */
+
+/* SENSE (input) CHARACTER*1 */
+/* Determines which reciprocal condition numbers are computed. */
+/* = 'N': None are computed; */
+/* = 'E': Computed for eigenvalues only; */
+/* = 'V': Computed for right eigenvectors only; */
+/* = 'B': Computed for eigenvalues and right eigenvectors. */
+
+/* If SENSE = 'E' or 'B', both left and right eigenvectors */
+/* must also be computed (JOBVL = 'V' and JOBVR = 'V'). */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+/* On exit, A has been overwritten. If JOBVL = 'V' or */
+/* JOBVR = 'V', A contains the real Schur form of the balanced */
+/* version of the input matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* WR (output) DOUBLE PRECISION array, dimension (N) */
+/* WI (output) DOUBLE PRECISION array, dimension (N) */
+/* WR and WI contain the real and imaginary parts, */
+/* respectively, of the computed eigenvalues. Complex */
+/* conjugate pairs of eigenvalues will appear consecutively */
+/* with the eigenvalue having the positive imaginary part */
+/* first. */
+
+/* VL (output) DOUBLE PRECISION array, dimension (LDVL,N) */
+/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
+/* after another in the columns of VL, in the same order */
+/* as their eigenvalues. */
+/* If JOBVL = 'N', VL is not referenced. */
+/* If the j-th eigenvalue is real, then u(j) = VL(:,j), */
+/* the j-th column of VL. */
+/* If the j-th and (j+1)-st eigenvalues form a complex */
+/* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and */
+/* u(j+1) = VL(:,j) - i*VL(:,j+1). */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. LDVL >= 1; if */
+/* JOBVL = 'V', LDVL >= N. */
+
+/* VR (output) DOUBLE PRECISION array, dimension (LDVR,N) */
+/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
+/* after another in the columns of VR, in the same order */
+/* as their eigenvalues. */
+/* If JOBVR = 'N', VR is not referenced. */
+/* If the j-th eigenvalue is real, then v(j) = VR(:,j), */
+/* the j-th column of VR. */
+/* If the j-th and (j+1)-st eigenvalues form a complex */
+/* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and */
+/* v(j+1) = VR(:,j) - i*VR(:,j+1). */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. LDVR >= 1, and if */
+/* JOBVR = 'V', LDVR >= N. */
+
+/* ILO (output) INTEGER */
+/* IHI (output) INTEGER */
+/* ILO and IHI are integer values determined when A was */
+/* balanced. The balanced A(i,j) = 0 if I > J and */
+/* J = 1,...,ILO-1 or I = IHI+1,...,N. */
+
+/* SCALE (output) DOUBLE PRECISION array, dimension (N) */
+/* Details of the permutations and scaling factors applied */
+/* when balancing A. If P(j) is the index of the row and column */
+/* interchanged with row and column j, and D(j) is the scaling */
+/* factor applied to row and column j, then */
+/* SCALE(J) = P(J), for J = 1,...,ILO-1 */
+/* = D(J), for J = ILO,...,IHI */
+/* = P(J) for J = IHI+1,...,N. */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* ABNRM (output) DOUBLE PRECISION */
+/* The one-norm of the balanced matrix (the maximum */
+/* of the sum of absolute values of elements of any column). */
+
+/* RCONDE (output) DOUBLE PRECISION array, dimension (N) */
+/* RCONDE(j) is the reciprocal condition number of the j-th */
+/* eigenvalue. */
+
+/* RCONDV (output) DOUBLE PRECISION array, dimension (N) */
+/* RCONDV(j) is the reciprocal condition number of the j-th */
+/* right eigenvector. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. If SENSE = 'N' or 'E', */
+/* LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V', */
+/* LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6). */
+/* For good performance, LWORK must generally be larger. */
+
+/* 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. */
+
+/* IWORK (workspace) INTEGER array, dimension (2*N-2) */
+/* If SENSE = 'N' or 'E', not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the QR algorithm failed to compute all the */
+/* eigenvalues, and no eigenvectors or condition numbers */
+/* have been computed; elements 1:ILO-1 and i+1:N of WR */
+/* and WI contain eigenvalues which have converged. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --wr;
+ --wi;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --scale;
+ --rconde;
+ --rcondv;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ wantvl = lsame_(jobvl, "V");
+ wantvr = lsame_(jobvr, "V");
+ wntsnn = lsame_(sense, "N");
+ wntsne = lsame_(sense, "E");
+ wntsnv = lsame_(sense, "V");
+ wntsnb = lsame_(sense, "B");
+ if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P")
+ || lsame_(balanc, "B"))) {
+ *info = -1;
+ } else if (! wantvl && ! lsame_(jobvl, "N")) {
+ *info = -2;
+ } else if (! wantvr && ! lsame_(jobvr, "N")) {
+ *info = -3;
+ } else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb)
+ && ! (wantvl && wantvr)) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvl < 1 || wantvl && *ldvl < *n) {
+ *info = -11;
+ } else if (*ldvr < 1 || wantvr && *ldvr < *n) {
+ *info = -13;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. */
+/* HSWORK refers to the workspace preferred by DHSEQR, as */
+/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
+/* the worst case.) */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ } else {
+ maxwrk = *n + *n * ilaenv_(&c__1, "DGEHRD", " ", n, &c__1, n, &
+ c__0);
+
+ if (wantvl) {
+ dhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
+ 1], &vl[vl_offset], ldvl, &work[1], &c_n1, info);
+ } else if (wantvr) {
+ dhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
+ 1], &vr[vr_offset], ldvr, &work[1], &c_n1, info);
+ } else {
+ if (wntsnn) {
+ dhseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1],
+ &wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1,
+ info);
+ } else {
+ dhseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &wr[1],
+ &wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1,
+ info);
+ }
+ }
+ hswork = (integer) work[1];
+
+ if (! wantvl && ! wantvr) {
+ minwrk = *n << 1;
+ if (! wntsnn) {
+/* Computing MAX */
+ i__1 = minwrk, i__2 = *n * *n + *n * 6;
+ minwrk = max(i__1,i__2);
+ }
+ maxwrk = max(maxwrk,hswork);
+ if (! wntsnn) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * *n + *n * 6;
+ maxwrk = max(i__1,i__2);
+ }
+ } else {
+ minwrk = *n * 3;
+ if (! wntsnn && ! wntsne) {
+/* Computing MAX */
+ i__1 = minwrk, i__2 = *n * *n + *n * 6;
+ minwrk = max(i__1,i__2);
+ }
+ maxwrk = max(maxwrk,hswork);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "DORGHR",
+ " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ if (! wntsnn && ! wntsne) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * *n + *n * 6;
+ maxwrk = max(i__1,i__2);
+ }
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * 3;
+ maxwrk = max(i__1,i__2);
+ }
+ maxwrk = max(maxwrk,minwrk);
+ }
+ work[1] = (doublereal) maxwrk;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -21;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGEEVX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1. / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ icond = 0;
+ anrm = dlange_("M", n, n, &a[a_offset], lda, dum);
+ scalea = FALSE_;
+ if (anrm > 0. && anrm < smlnum) {
+ scalea = TRUE_;
+ cscale = smlnum;
+ } else if (anrm > bignum) {
+ scalea = TRUE_;
+ cscale = bignum;
+ }
+ if (scalea) {
+ dlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Balance the matrix and compute ABNRM */
+
+ dgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr);
+ *abnrm = dlange_("1", n, n, &a[a_offset], lda, dum);
+ if (scalea) {
+ dum[0] = *abnrm;
+ dlascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, &
+ ierr);
+ *abnrm = dum[0];
+ }
+
+/* Reduce to upper Hessenberg form */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ itau = 1;
+ iwrk = itau + *n;
+ i__1 = *lwork - iwrk + 1;
+ dgehrd_(n, ilo, ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, &
+ ierr);
+
+ if (wantvl) {
+
+/* Want left eigenvectors */
+/* Copy Householder vectors to VL */
+
+ *(unsigned char *)side = 'L';
+ dlacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
+ ;
+
+/* Generate orthogonal matrix in VL */
+/* (Workspace: need 2*N-1, prefer N+(N-1)*NB) */
+
+ i__1 = *lwork - iwrk + 1;
+ dorghr_(n, ilo, ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], &
+ i__1, &ierr);
+
+/* Perform QR iteration, accumulating Schur vectors in VL */
+/* (Workspace: need 1, prefer HSWORK (see comments) ) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ dhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vl[
+ vl_offset], ldvl, &work[iwrk], &i__1, info);
+
+ if (wantvr) {
+
+/* Want left and right eigenvectors */
+/* Copy Schur vectors to VR */
+
+ *(unsigned char *)side = 'B';
+ dlacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
+ }
+
+ } else if (wantvr) {
+
+/* Want right eigenvectors */
+/* Copy Householder vectors to VR */
+
+ *(unsigned char *)side = 'R';
+ dlacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
+ ;
+
+/* Generate orthogonal matrix in VR */
+/* (Workspace: need 2*N-1, prefer N+(N-1)*NB) */
+
+ i__1 = *lwork - iwrk + 1;
+ dorghr_(n, ilo, ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], &
+ i__1, &ierr);
+
+/* Perform QR iteration, accumulating Schur vectors in VR */
+/* (Workspace: need 1, prefer HSWORK (see comments) ) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ dhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[
+ vr_offset], ldvr, &work[iwrk], &i__1, info);
+
+ } else {
+
+/* Compute eigenvalues only */
+/* If condition numbers desired, compute Schur form */
+
+ if (wntsnn) {
+ *(unsigned char *)job = 'E';
+ } else {
+ *(unsigned char *)job = 'S';
+ }
+
+/* (Workspace: need 1, prefer HSWORK (see comments) ) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ dhseqr_(job, "N", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[
+ vr_offset], ldvr, &work[iwrk], &i__1, info);
+ }
+
+/* If INFO > 0 from DHSEQR, then quit */
+
+ if (*info > 0) {
+ goto L50;
+ }
+
+ if (wantvl || wantvr) {
+
+/* Compute left and/or right eigenvectors */
+/* (Workspace: need 3*N) */
+
+ dtrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
+ &vr[vr_offset], ldvr, n, &nout, &work[iwrk], &ierr);
+ }
+
+/* Compute condition numbers if desired */
+/* (Workspace: need N*N+6*N unless SENSE = 'E') */
+
+ if (! wntsnn) {
+ dtrsna_(sense, "A", select, n, &a[a_offset], lda, &vl[vl_offset],
+ ldvl, &vr[vr_offset], ldvr, &rconde[1], &rcondv[1], n, &nout,
+ &work[iwrk], n, &iwork[1], &icond);
+ }
+
+ if (wantvl) {
+
+/* Undo balancing of left eigenvectors */
+
+ dgebak_(balanc, "L", n, ilo, ihi, &scale[1], n, &vl[vl_offset], ldvl,
+ &ierr);
+
+/* Normalize left eigenvectors and make largest component real */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (wi[i__] == 0.) {
+ scl = 1. / dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
+ dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
+ } else if (wi[i__] > 0.) {
+ d__1 = dnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
+ d__2 = dnrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
+ scl = 1. / dlapy2_(&d__1, &d__2);
+ dscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
+ dscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+/* Computing 2nd power */
+ d__1 = vl[k + i__ * vl_dim1];
+/* Computing 2nd power */
+ d__2 = vl[k + (i__ + 1) * vl_dim1];
+ work[k] = d__1 * d__1 + d__2 * d__2;
+/* L10: */
+ }
+ k = idamax_(n, &work[1], &c__1);
+ dlartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1],
+ &cs, &sn, &r__);
+ drot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) *
+ vl_dim1 + 1], &c__1, &cs, &sn);
+ vl[k + (i__ + 1) * vl_dim1] = 0.;
+ }
+/* L20: */
+ }
+ }
+
+ if (wantvr) {
+
+/* Undo balancing of right eigenvectors */
+
+ dgebak_(balanc, "R", n, ilo, ihi, &scale[1], n, &vr[vr_offset], ldvr,
+ &ierr);
+
+/* Normalize right eigenvectors and make largest component real */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (wi[i__] == 0.) {
+ scl = 1. / dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
+ dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
+ } else if (wi[i__] > 0.) {
+ d__1 = dnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
+ d__2 = dnrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
+ scl = 1. / dlapy2_(&d__1, &d__2);
+ dscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
+ dscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+/* Computing 2nd power */
+ d__1 = vr[k + i__ * vr_dim1];
+/* Computing 2nd power */
+ d__2 = vr[k + (i__ + 1) * vr_dim1];
+ work[k] = d__1 * d__1 + d__2 * d__2;
+/* L30: */
+ }
+ k = idamax_(n, &work[1], &c__1);
+ dlartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1],
+ &cs, &sn, &r__);
+ drot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) *
+ vr_dim1 + 1], &c__1, &cs, &sn);
+ vr[k + (i__ + 1) * vr_dim1] = 0.;
+ }
+/* L40: */
+ }
+ }
+
+/* Undo scaling if necessary */
+
+L50:
+ if (scalea) {
+ i__1 = *n - *info;
+/* Computing MAX */
+ i__3 = *n - *info;
+ i__2 = max(i__3,1);
+ dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info +
+ 1], &i__2, &ierr);
+ i__1 = *n - *info;
+/* Computing MAX */
+ i__3 = *n - *info;
+ i__2 = max(i__3,1);
+ dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info +
+ 1], &i__2, &ierr);
+ if (*info == 0) {
+ if ((wntsnv || wntsnb) && icond == 0) {
+ dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &rcondv[
+ 1], n, &ierr);
+ }
+ } else {
+ i__1 = *ilo - 1;
+ dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1],
+ n, &ierr);
+ i__1 = *ilo - 1;
+ dlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1],
+ n, &ierr);
+ }
+ }
+
+ work[1] = (doublereal) maxwrk;
+ return 0;
+
+/* End of DGEEVX */
+
+} /* dgeevx_ */
diff --git a/SRC/dgegs.c b/SRC/dgegs.c
new file mode 100644
index 0000000..cb409fb
--- /dev/null
+++ b/SRC/dgegs.c
@@ -0,0 +1,548 @@
+/* dgegs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b36 = 0.;
+static doublereal c_b37 = 1.;
+
+/* Subroutine */ int dgegs_(char *jobvsl, char *jobvsr, integer *n,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
+ alphar, doublereal *alphai, doublereal *beta, doublereal *vsl,
+ integer *ldvsl, doublereal *vsr, integer *ldvsr, doublereal *work,
+ integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
+ vsr_dim1, vsr_offset, i__1, i__2;
+
+ /* Local variables */
+ integer nb, nb1, nb2, nb3, ihi, ilo;
+ doublereal eps, anrm, bnrm;
+ integer itau, lopt;
+ extern logical lsame_(char *, char *);
+ integer ileft, iinfo, icols;
+ logical ilvsl;
+ integer iwork;
+ logical ilvsr;
+ integer irows;
+ extern /* Subroutine */ int dggbak_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, integer *), dggbal_(char *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dgghrd_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dlascl_(char *, integer *, integer *, doublereal
+ *, doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *);
+ logical ilascl, ilbscl;
+ extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *),
+ dlacpy_(char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ doublereal safmin;
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dhgeqz_(char *, char *, char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *);
+ integer ijobvl, iright, ijobvr;
+ extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+ doublereal anrmto;
+ integer lwkmin;
+ doublereal bnrmto;
+ extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ doublereal smlnum;
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine DGGES. */
+
+/* DGEGS computes the eigenvalues, real Schur form, and, optionally, */
+/* left and or/right Schur vectors of a real matrix pair (A,B). */
+/* Given two square matrices A and B, the generalized real Schur */
+/* factorization has the form */
+
+/* A = Q*S*Z**T, B = Q*T*Z**T */
+
+/* where Q and Z are orthogonal matrices, T is upper triangular, and S */
+/* is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal */
+/* blocks, the 2-by-2 blocks corresponding to complex conjugate pairs */
+/* of eigenvalues of (A,B). The columns of Q are the left Schur vectors */
+/* and the columns of Z are the right Schur vectors. */
+
+/* If only the eigenvalues of (A,B) are needed, the driver routine */
+/* DGEGV should be used instead. See DGEGV for a description of the */
+/* eigenvalues of the generalized nonsymmetric eigenvalue problem */
+/* (GNEP). */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVSL (input) CHARACTER*1 */
+/* = 'N': do not compute the left Schur vectors; */
+/* = 'V': compute the left Schur vectors (returned in VSL). */
+
+/* JOBVSR (input) CHARACTER*1 */
+/* = 'N': do not compute the right Schur vectors; */
+/* = 'V': compute the right Schur vectors (returned in VSR). */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VSL, and VSR. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
+/* On entry, the matrix A. */
+/* On exit, the upper quasi-triangular matrix S from the */
+/* generalized real Schur factorization. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */
+/* On entry, the matrix B. */
+/* On exit, the upper triangular matrix T from the generalized */
+/* real Schur factorization. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */
+/* The real parts of each scalar alpha defining an eigenvalue */
+/* of GNEP. */
+
+/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */
+/* The imaginary parts of each scalar alpha defining an */
+/* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th */
+/* eigenvalue is real; if positive, then the j-th and (j+1)-st */
+/* eigenvalues are a complex conjugate pair, with */
+/* ALPHAI(j+1) = -ALPHAI(j). */
+
+/* BETA (output) DOUBLE PRECISION array, dimension (N) */
+/* The scalars beta that define the eigenvalues of GNEP. */
+/* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and */
+/* beta = BETA(j) represent the j-th eigenvalue of the matrix */
+/* pair (A,B), in one of the forms lambda = alpha/beta or */
+/* mu = beta/alpha. Since either lambda or mu may overflow, */
+/* they should not, in general, be computed. */
+
+/* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N) */
+/* If JOBVSL = 'V', the matrix of left Schur vectors Q. */
+/* Not referenced if JOBVSL = 'N'. */
+
+/* LDVSL (input) INTEGER */
+/* The leading dimension of the matrix VSL. LDVSL >=1, and */
+/* if JOBVSL = 'V', LDVSL >= N. */
+
+/* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N) */
+/* If JOBVSR = 'V', the matrix of right Schur vectors Z. */
+/* Not referenced if JOBVSR = 'N'. */
+
+/* LDVSR (input) INTEGER */
+/* The leading dimension of the matrix VSR. LDVSR >= 1, and */
+/* if JOBVSR = 'V', LDVSR >= N. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,4*N). */
+/* For good performance, LWORK must generally be larger. */
+/* To compute the optimal value of LWORK, call ILAENV to get */
+/* blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute: */
+/* NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR */
+/* The optimal LWORK is 2*N + N*(NB+1). */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1,...,N: */
+/* The QZ iteration failed. (A,B) are not in Schur */
+/* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should */
+/* be correct for j=INFO+1,...,N. */
+/* > N: errors that usually indicate LAPACK problems: */
+/* =N+1: error return from DGGBAL */
+/* =N+2: error return from DGEQRF */
+/* =N+3: error return from DORMQR */
+/* =N+4: error return from DORGQR */
+/* =N+5: error return from DGGHRD */
+/* =N+6: error return from DHGEQZ (other than failed */
+/* iteration) */
+/* =N+7: error return from DGGBAK (computing VSL) */
+/* =N+8: error return from DGGBAK (computing VSR) */
+/* =N+9: error return from DLASCL (various places) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ vsl_dim1 = *ldvsl;
+ vsl_offset = 1 + vsl_dim1;
+ vsl -= vsl_offset;
+ vsr_dim1 = *ldvsr;
+ vsr_offset = 1 + vsr_dim1;
+ vsr -= vsr_offset;
+ --work;
+
+ /* Function Body */
+ if (lsame_(jobvsl, "N")) {
+ ijobvl = 1;
+ ilvsl = FALSE_;
+ } else if (lsame_(jobvsl, "V")) {
+ ijobvl = 2;
+ ilvsl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvsl = FALSE_;
+ }
+
+ if (lsame_(jobvsr, "N")) {
+ ijobvr = 1;
+ ilvsr = FALSE_;
+ } else if (lsame_(jobvsr, "V")) {
+ ijobvr = 2;
+ ilvsr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvsr = FALSE_;
+ }
+
+/* Test the input arguments */
+
+/* Computing MAX */
+ i__1 = *n << 2;
+ lwkmin = max(i__1,1);
+ lwkopt = lwkmin;
+ work[1] = (doublereal) lwkopt;
+ lquery = *lwork == -1;
+ *info = 0;
+ if (ijobvl <= 0) {
+ *info = -1;
+ } else if (ijobvr <= 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
+ *info = -12;
+ } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
+ *info = -14;
+ } else if (*lwork < lwkmin && ! lquery) {
+ *info = -16;
+ }
+
+ if (*info == 0) {
+ nb1 = ilaenv_(&c__1, "DGEQRF", " ", n, n, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "DORMQR", " ", n, n, n, &c_n1);
+ nb3 = ilaenv_(&c__1, "DORGQR", " ", n, n, n, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2);
+ nb = max(i__1,nb3);
+ lopt = (*n << 1) + *n * (nb + 1);
+ work[1] = (doublereal) lopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGEGS ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("E") * dlamch_("B");
+ safmin = dlamch_("S");
+ smlnum = *n * safmin / eps;
+ bignum = 1. / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]);
+ ilascl = FALSE_;
+ if (anrm > 0. && anrm < smlnum) {
+ anrmto = smlnum;
+ ilascl = TRUE_;
+ } else if (anrm > bignum) {
+ anrmto = bignum;
+ ilascl = TRUE_;
+ }
+
+ if (ilascl) {
+ dlascl_("G", &c_n1, &c_n1, &anrm, &anrmto, n, n, &a[a_offset], lda, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]);
+ ilbscl = FALSE_;
+ if (bnrm > 0. && bnrm < smlnum) {
+ bnrmto = smlnum;
+ ilbscl = TRUE_;
+ } else if (bnrm > bignum) {
+ bnrmto = bignum;
+ ilbscl = TRUE_;
+ }
+
+ if (ilbscl) {
+ dlascl_("G", &c_n1, &c_n1, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ }
+
+/* Permute the matrix to make it more nearly triangular */
+/* Workspace layout: (2*N words -- "work..." not actually used) */
+/* left_permutation, right_permutation, work... */
+
+ ileft = 1;
+ iright = *n + 1;
+ iwork = iright + *n;
+ dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[
+ ileft], &work[iright], &work[iwork], &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 1;
+ goto L10;
+ }
+
+/* Reduce B to triangular form, and initialize VSL and/or VSR */
+/* Workspace layout: ("work..." must have at least N words) */
+/* left_permutation, right_permutation, tau, work... */
+
+ irows = ihi + 1 - ilo;
+ icols = *n + 1 - ilo;
+ itau = iwork;
+ iwork = itau + irows;
+ i__1 = *lwork + 1 - iwork;
+ dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
+ iwork], &i__1, &iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 2;
+ goto L10;
+ }
+
+ i__1 = *lwork + 1 - iwork;
+ dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
+ work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, &
+ iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 3;
+ goto L10;
+ }
+
+ if (ilvsl) {
+ dlaset_("Full", n, n, &c_b36, &c_b37, &vsl[vsl_offset], ldvsl);
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[ilo
+ + 1 + ilo * vsl_dim1], ldvsl);
+ i__1 = *lwork + 1 - iwork;
+ dorgqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, &
+ work[itau], &work[iwork], &i__1, &iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 4;
+ goto L10;
+ }
+ }
+
+ if (ilvsr) {
+ dlaset_("Full", n, n, &c_b36, &c_b37, &vsr[vsr_offset], ldvsr);
+ }
+
+/* Reduce to generalized Hessenberg form */
+
+ dgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 5;
+ goto L10;
+ }
+
+/* Perform QZ algorithm, computing Schur vectors if desired */
+/* Workspace layout: ("work..." must have at least 1 word) */
+/* left_permutation, right_permutation, work... */
+
+ iwork = itau;
+ i__1 = *lwork + 1 - iwork;
+ dhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[
+ b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset]
+, ldvsl, &vsr[vsr_offset], ldvsr, &work[iwork], &i__1, &iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ if (iinfo > 0 && iinfo <= *n) {
+ *info = iinfo;
+ } else if (iinfo > *n && iinfo <= *n << 1) {
+ *info = iinfo - *n;
+ } else {
+ *info = *n + 6;
+ }
+ goto L10;
+ }
+
+/* Apply permutation to VSL and VSR */
+
+ if (ilvsl) {
+ dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[
+ vsl_offset], ldvsl, &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 7;
+ goto L10;
+ }
+ }
+ if (ilvsr) {
+ dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[
+ vsr_offset], ldvsr, &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 8;
+ goto L10;
+ }
+ }
+
+/* Undo scaling */
+
+ if (ilascl) {
+ dlascl_("H", &c_n1, &c_n1, &anrmto, &anrm, n, n, &a[a_offset], lda, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ dlascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alphar[1], n, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ dlascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alphai[1], n, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ }
+
+ if (ilbscl) {
+ dlascl_("U", &c_n1, &c_n1, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ dlascl_("G", &c_n1, &c_n1, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ }
+
+L10:
+ work[1] = (doublereal) lwkopt;
+
+ return 0;
+
+/* End of DGEGS */
+
+} /* dgegs_ */
diff --git a/SRC/dgegv.c b/SRC/dgegv.c
new file mode 100644
index 0000000..8551895
--- /dev/null
+++ b/SRC/dgegv.c
@@ -0,0 +1,842 @@
+/* dgegv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b27 = 1.;
+static doublereal c_b38 = 0.;
+
+/* Subroutine */ int dgegv_(char *jobvl, char *jobvr, integer *n, doublereal *
+ a, integer *lda, doublereal *b, integer *ldb, doublereal *alphar,
+ doublereal *alphai, doublereal *beta, doublereal *vl, integer *ldvl,
+ doublereal *vr, integer *ldvr, doublereal *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
+ vr_offset, i__1, i__2;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Local variables */
+ integer jc, nb, in, jr, nb1, nb2, nb3, ihi, ilo;
+ doublereal eps;
+ logical ilv;
+ doublereal absb, anrm, bnrm;
+ integer itau;
+ doublereal temp;
+ logical ilvl, ilvr;
+ integer lopt;
+ doublereal anrm1, anrm2, bnrm1, bnrm2, absai, scale, absar, sbeta;
+ extern logical lsame_(char *, char *);
+ integer ileft, iinfo, icols, iwork, irows;
+ extern /* Subroutine */ int dggbak_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, integer *), dggbal_(char *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ doublereal salfai;
+ extern /* Subroutine */ int dgghrd_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dlascl_(char *, integer *, integer *, doublereal
+ *, doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *);
+ doublereal salfar;
+ extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *),
+ dlacpy_(char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ doublereal safmin;
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ doublereal safmax;
+ char chtemp[1];
+ logical ldumma[1];
+ extern /* Subroutine */ int dhgeqz_(char *, char *, char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *), dtgevc_(char *, char *,
+ logical *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ integer ijobvl, iright;
+ logical ilimit;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ijobvr;
+ extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+ doublereal onepls;
+ integer lwkmin;
+ extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine DGGEV. */
+
+/* DGEGV computes the eigenvalues and, optionally, the left and/or right */
+/* eigenvectors of a real matrix pair (A,B). */
+/* Given two square matrices A and B, */
+/* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the */
+/* eigenvalues lambda and corresponding (non-zero) eigenvectors x such */
+/* that */
+
+/* A*x = lambda*B*x. */
+
+/* An alternate form is to find the eigenvalues mu and corresponding */
+/* eigenvectors y such that */
+
+/* mu*A*y = B*y. */
+
+/* These two forms are equivalent with mu = 1/lambda and x = y if */
+/* neither lambda nor mu is zero. In order to deal with the case that */
+/* lambda or mu is zero or small, two values alpha and beta are returned */
+/* for each eigenvalue, such that lambda = alpha/beta and */
+/* mu = beta/alpha. */
+
+/* The vectors x and y in the above equations are right eigenvectors of */
+/* the matrix pair (A,B). Vectors u and v satisfying */
+
+/* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B */
+
+/* are left eigenvectors of (A,B). */
+
+/* Note: this routine performs "full balancing" on A and B -- see */
+/* "Further Details", below. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVL (input) CHARACTER*1 */
+/* = 'N': do not compute the left generalized eigenvectors; */
+/* = 'V': compute the left generalized eigenvectors (returned */
+/* in VL). */
+
+/* JOBVR (input) CHARACTER*1 */
+/* = 'N': do not compute the right generalized eigenvectors; */
+/* = 'V': compute the right generalized eigenvectors (returned */
+/* in VR). */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VL, and VR. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
+/* On entry, the matrix A. */
+/* If JOBVL = 'V' or JOBVR = 'V', then on exit A */
+/* contains the real Schur form of A from the generalized Schur */
+/* factorization of the pair (A,B) after balancing. */
+/* If no eigenvectors were computed, then only the diagonal */
+/* blocks from the Schur form will be correct. See DGGHRD and */
+/* DHGEQZ for details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */
+/* On entry, the matrix B. */
+/* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the */
+/* upper triangular matrix obtained from B in the generalized */
+/* Schur factorization of the pair (A,B) after balancing. */
+/* If no eigenvectors were computed, then only those elements of */
+/* B corresponding to the diagonal blocks from the Schur form of */
+/* A will be correct. See DGGHRD and DHGEQZ for details. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */
+/* The real parts of each scalar alpha defining an eigenvalue of */
+/* GNEP. */
+
+/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */
+/* The imaginary parts of each scalar alpha defining an */
+/* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th */
+/* eigenvalue is real; if positive, then the j-th and */
+/* (j+1)-st eigenvalues are a complex conjugate pair, with */
+/* ALPHAI(j+1) = -ALPHAI(j). */
+
+/* BETA (output) DOUBLE PRECISION array, dimension (N) */
+/* The scalars beta that define the eigenvalues of GNEP. */
+
+/* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and */
+/* beta = BETA(j) represent the j-th eigenvalue of the matrix */
+/* pair (A,B), in one of the forms lambda = alpha/beta or */
+/* mu = beta/alpha. Since either lambda or mu may overflow, */
+/* they should not, in general, be computed. */
+
+/* VL (output) DOUBLE PRECISION array, dimension (LDVL,N) */
+/* If JOBVL = 'V', the left eigenvectors u(j) are stored */
+/* in the columns of VL, in the same order as their eigenvalues. */
+/* If the j-th eigenvalue is real, then u(j) = VL(:,j). */
+/* If the j-th and (j+1)-st eigenvalues form a complex conjugate */
+/* pair, then */
+/* u(j) = VL(:,j) + i*VL(:,j+1) */
+/* and */
+/* u(j+1) = VL(:,j) - i*VL(:,j+1). */
+
+/* Each eigenvector is scaled so that its largest component has */
+/* abs(real part) + abs(imag. part) = 1, except for eigenvectors */
+/* corresponding to an eigenvalue with alpha = beta = 0, which */
+/* are set to zero. */
+/* Not referenced if JOBVL = 'N'. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the matrix VL. LDVL >= 1, and */
+/* if JOBVL = 'V', LDVL >= N. */
+
+/* VR (output) DOUBLE PRECISION array, dimension (LDVR,N) */
+/* If JOBVR = 'V', the right eigenvectors x(j) are stored */
+/* in the columns of VR, in the same order as their eigenvalues. */
+/* If the j-th eigenvalue is real, then x(j) = VR(:,j). */
+/* If the j-th and (j+1)-st eigenvalues form a complex conjugate */
+/* pair, then */
+/* x(j) = VR(:,j) + i*VR(:,j+1) */
+/* and */
+/* x(j+1) = VR(:,j) - i*VR(:,j+1). */
+
+/* Each eigenvector is scaled so that its largest component has */
+/* abs(real part) + abs(imag. part) = 1, except for eigenvalues */
+/* corresponding to an eigenvalue with alpha = beta = 0, which */
+/* are set to zero. */
+/* Not referenced if JOBVR = 'N'. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the matrix VR. LDVR >= 1, and */
+/* if JOBVR = 'V', LDVR >= N. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,8*N). */
+/* For good performance, LWORK must generally be larger. */
+/* To compute the optimal value of LWORK, call ILAENV to get */
+/* blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute: */
+/* NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR; */
+/* The optimal LWORK is: */
+/* 2*N + MAX( 6*N, N*(NB+1) ). */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1,...,N: */
+/* The QZ iteration failed. No eigenvectors have been */
+/* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) */
+/* should be correct for j=INFO+1,...,N. */
+/* > N: errors that usually indicate LAPACK problems: */
+/* =N+1: error return from DGGBAL */
+/* =N+2: error return from DGEQRF */
+/* =N+3: error return from DORMQR */
+/* =N+4: error return from DORGQR */
+/* =N+5: error return from DGGHRD */
+/* =N+6: error return from DHGEQZ (other than failed */
+/* iteration) */
+/* =N+7: error return from DTGEVC */
+/* =N+8: error return from DGGBAK (computing VL) */
+/* =N+9: error return from DGGBAK (computing VR) */
+/* =N+10: error return from DLASCL (various calls) */
+
+/* Further Details */
+/* =============== */
+
+/* Balancing */
+/* --------- */
+
+/* This driver calls DGGBAL to both permute and scale rows and columns */
+/* of A and B. The permutations PL and PR are chosen so that PL*A*PR */
+/* and PL*B*R will be upper triangular except for the diagonal blocks */
+/* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as */
+/* possible. The diagonal scaling matrices DL and DR are chosen so */
+/* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to */
+/* one (except for the elements that start out zero.) */
+
+/* After the eigenvalues and eigenvectors of the balanced matrices */
+/* have been computed, DGGBAK transforms the eigenvectors back to what */
+/* they would have been (in perfect arithmetic) if they had not been */
+/* balanced. */
+
+/* Contents of A and B on Exit */
+/* -------- -- - --- - -- ---- */
+
+/* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or */
+/* both), then on exit the arrays A and B will contain the real Schur */
+/* form[*] of the "balanced" versions of A and B. If no eigenvectors */
+/* are computed, then only the diagonal blocks will be correct. */
+
+/* [*] See DHGEQZ, DGEGS, or read the book "Matrix Computations", */
+/* by Golub & van Loan, pub. by Johns Hopkins U. Press. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+
+ /* Function Body */
+ if (lsame_(jobvl, "N")) {
+ ijobvl = 1;
+ ilvl = FALSE_;
+ } else if (lsame_(jobvl, "V")) {
+ ijobvl = 2;
+ ilvl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvl = FALSE_;
+ }
+
+ if (lsame_(jobvr, "N")) {
+ ijobvr = 1;
+ ilvr = FALSE_;
+ } else if (lsame_(jobvr, "V")) {
+ ijobvr = 2;
+ ilvr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvr = FALSE_;
+ }
+ ilv = ilvl || ilvr;
+
+/* Test the input arguments */
+
+/* Computing MAX */
+ i__1 = *n << 3;
+ lwkmin = max(i__1,1);
+ lwkopt = lwkmin;
+ work[1] = (doublereal) lwkopt;
+ lquery = *lwork == -1;
+ *info = 0;
+ if (ijobvl <= 0) {
+ *info = -1;
+ } else if (ijobvr <= 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvl < 1 || ilvl && *ldvl < *n) {
+ *info = -12;
+ } else if (*ldvr < 1 || ilvr && *ldvr < *n) {
+ *info = -14;
+ } else if (*lwork < lwkmin && ! lquery) {
+ *info = -16;
+ }
+
+ if (*info == 0) {
+ nb1 = ilaenv_(&c__1, "DGEQRF", " ", n, n, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "DORMQR", " ", n, n, n, &c_n1);
+ nb3 = ilaenv_(&c__1, "DORGQR", " ", n, n, n, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2);
+ nb = max(i__1,nb3);
+/* Computing MAX */
+ i__1 = *n * 6, i__2 = *n * (nb + 1);
+ lopt = (*n << 1) + max(i__1,i__2);
+ work[1] = (doublereal) lopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGEGV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("E") * dlamch_("B");
+ safmin = dlamch_("S");
+ safmin += safmin;
+ safmax = 1. / safmin;
+ onepls = eps * 4 + 1.;
+
+/* Scale A */
+
+ anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]);
+ anrm1 = anrm;
+ anrm2 = 1.;
+ if (anrm < 1.) {
+ if (safmax * anrm < 1.) {
+ anrm1 = safmin;
+ anrm2 = safmax * anrm;
+ }
+ }
+
+ if (anrm > 0.) {
+ dlascl_("G", &c_n1, &c_n1, &anrm, &c_b27, n, n, &a[a_offset], lda, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 10;
+ return 0;
+ }
+ }
+
+/* Scale B */
+
+ bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]);
+ bnrm1 = bnrm;
+ bnrm2 = 1.;
+ if (bnrm < 1.) {
+ if (safmax * bnrm < 1.) {
+ bnrm1 = safmin;
+ bnrm2 = safmax * bnrm;
+ }
+ }
+
+ if (bnrm > 0.) {
+ dlascl_("G", &c_n1, &c_n1, &bnrm, &c_b27, n, n, &b[b_offset], ldb, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 10;
+ return 0;
+ }
+ }
+
+/* Permute the matrix to make it more nearly triangular */
+/* Workspace layout: (8*N words -- "work" requires 6*N words) */
+/* left_permutation, right_permutation, work... */
+
+ ileft = 1;
+ iright = *n + 1;
+ iwork = iright + *n;
+ dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[
+ ileft], &work[iright], &work[iwork], &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 1;
+ goto L120;
+ }
+
+/* Reduce B to triangular form, and initialize VL and/or VR */
+/* Workspace layout: ("work..." must have at least N words) */
+/* left_permutation, right_permutation, tau, work... */
+
+ irows = ihi + 1 - ilo;
+ if (ilv) {
+ icols = *n + 1 - ilo;
+ } else {
+ icols = irows;
+ }
+ itau = iwork;
+ iwork = itau + irows;
+ i__1 = *lwork + 1 - iwork;
+ dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
+ iwork], &i__1, &iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 2;
+ goto L120;
+ }
+
+ i__1 = *lwork + 1 - iwork;
+ dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
+ work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, &
+ iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 3;
+ goto L120;
+ }
+
+ if (ilvl) {
+ dlaset_("Full", n, n, &c_b38, &c_b27, &vl[vl_offset], ldvl)
+ ;
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vl[ilo +
+ 1 + ilo * vl_dim1], ldvl);
+ i__1 = *lwork + 1 - iwork;
+ dorgqr_(&irows, &irows, &irows, &vl[ilo + ilo * vl_dim1], ldvl, &work[
+ itau], &work[iwork], &i__1, &iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 4;
+ goto L120;
+ }
+ }
+
+ if (ilvr) {
+ dlaset_("Full", n, n, &c_b38, &c_b27, &vr[vr_offset], ldvr)
+ ;
+ }
+
+/* Reduce to generalized Hessenberg form */
+
+ if (ilv) {
+
+/* Eigenvectors requested -- work on whole matrix. */
+
+ dgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &iinfo);
+ } else {
+ dgghrd_("N", "N", &irows, &c__1, &irows, &a[ilo + ilo * a_dim1], lda,
+ &b[ilo + ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[
+ vr_offset], ldvr, &iinfo);
+ }
+ if (iinfo != 0) {
+ *info = *n + 5;
+ goto L120;
+ }
+
+/* Perform QZ algorithm */
+/* Workspace layout: ("work..." must have at least 1 word) */
+/* left_permutation, right_permutation, work... */
+
+ iwork = itau;
+ if (ilv) {
+ *(unsigned char *)chtemp = 'S';
+ } else {
+ *(unsigned char *)chtemp = 'E';
+ }
+ i__1 = *lwork + 1 - iwork;
+ dhgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[
+ b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset],
+ ldvl, &vr[vr_offset], ldvr, &work[iwork], &i__1, &iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ if (iinfo > 0 && iinfo <= *n) {
+ *info = iinfo;
+ } else if (iinfo > *n && iinfo <= *n << 1) {
+ *info = iinfo - *n;
+ } else {
+ *info = *n + 6;
+ }
+ goto L120;
+ }
+
+ if (ilv) {
+
+/* Compute Eigenvectors (DTGEVC requires 6*N words of workspace) */
+
+ if (ilvl) {
+ if (ilvr) {
+ *(unsigned char *)chtemp = 'B';
+ } else {
+ *(unsigned char *)chtemp = 'L';
+ }
+ } else {
+ *(unsigned char *)chtemp = 'R';
+ }
+
+ dtgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb,
+ &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[
+ iwork], &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 7;
+ goto L120;
+ }
+
+/* Undo balancing on VL and VR, rescale */
+
+ if (ilvl) {
+ dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &
+ vl[vl_offset], ldvl, &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 8;
+ goto L120;
+ }
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ if (alphai[jc] < 0.) {
+ goto L50;
+ }
+ temp = 0.;
+ if (alphai[jc] == 0.) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ d__2 = temp, d__3 = (d__1 = vl[jr + jc * vl_dim1],
+ abs(d__1));
+ temp = max(d__2,d__3);
+/* L10: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ d__3 = temp, d__4 = (d__1 = vl[jr + jc * vl_dim1],
+ abs(d__1)) + (d__2 = vl[jr + (jc + 1) *
+ vl_dim1], abs(d__2));
+ temp = max(d__3,d__4);
+/* L20: */
+ }
+ }
+ if (temp < safmin) {
+ goto L50;
+ }
+ temp = 1. / temp;
+ if (alphai[jc] == 0.) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vl[jr + jc * vl_dim1] *= temp;
+/* L30: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vl[jr + jc * vl_dim1] *= temp;
+ vl[jr + (jc + 1) * vl_dim1] *= temp;
+/* L40: */
+ }
+ }
+L50:
+ ;
+ }
+ }
+ if (ilvr) {
+ dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &
+ vr[vr_offset], ldvr, &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ goto L120;
+ }
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ if (alphai[jc] < 0.) {
+ goto L100;
+ }
+ temp = 0.;
+ if (alphai[jc] == 0.) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ d__2 = temp, d__3 = (d__1 = vr[jr + jc * vr_dim1],
+ abs(d__1));
+ temp = max(d__2,d__3);
+/* L60: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ d__3 = temp, d__4 = (d__1 = vr[jr + jc * vr_dim1],
+ abs(d__1)) + (d__2 = vr[jr + (jc + 1) *
+ vr_dim1], abs(d__2));
+ temp = max(d__3,d__4);
+/* L70: */
+ }
+ }
+ if (temp < safmin) {
+ goto L100;
+ }
+ temp = 1. / temp;
+ if (alphai[jc] == 0.) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vr[jr + jc * vr_dim1] *= temp;
+/* L80: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vr[jr + jc * vr_dim1] *= temp;
+ vr[jr + (jc + 1) * vr_dim1] *= temp;
+/* L90: */
+ }
+ }
+L100:
+ ;
+ }
+ }
+
+/* End of eigenvector calculation */
+
+ }
+
+/* Undo scaling in alpha, beta */
+
+/* Note: this does not give the alpha and beta for the unscaled */
+/* problem. */
+
+/* Un-scaling is limited to avoid underflow in alpha and beta */
+/* if they are significant. */
+
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ absar = (d__1 = alphar[jc], abs(d__1));
+ absai = (d__1 = alphai[jc], abs(d__1));
+ absb = (d__1 = beta[jc], abs(d__1));
+ salfar = anrm * alphar[jc];
+ salfai = anrm * alphai[jc];
+ sbeta = bnrm * beta[jc];
+ ilimit = FALSE_;
+ scale = 1.;
+
+/* Check for significant underflow in ALPHAI */
+
+/* Computing MAX */
+ d__1 = safmin, d__2 = eps * absar, d__1 = max(d__1,d__2), d__2 = eps *
+ absb;
+ if (abs(salfai) < safmin && absai >= max(d__1,d__2)) {
+ ilimit = TRUE_;
+/* Computing MAX */
+ d__1 = onepls * safmin, d__2 = anrm2 * absai;
+ scale = onepls * safmin / anrm1 / max(d__1,d__2);
+
+ } else if (salfai == 0.) {
+
+/* If insignificant underflow in ALPHAI, then make the */
+/* conjugate eigenvalue real. */
+
+ if (alphai[jc] < 0. && jc > 1) {
+ alphai[jc - 1] = 0.;
+ } else if (alphai[jc] > 0. && jc < *n) {
+ alphai[jc + 1] = 0.;
+ }
+ }
+
+/* Check for significant underflow in ALPHAR */
+
+/* Computing MAX */
+ d__1 = safmin, d__2 = eps * absai, d__1 = max(d__1,d__2), d__2 = eps *
+ absb;
+ if (abs(salfar) < safmin && absar >= max(d__1,d__2)) {
+ ilimit = TRUE_;
+/* Computing MAX */
+/* Computing MAX */
+ d__3 = onepls * safmin, d__4 = anrm2 * absar;
+ d__1 = scale, d__2 = onepls * safmin / anrm1 / max(d__3,d__4);
+ scale = max(d__1,d__2);
+ }
+
+/* Check for significant underflow in BETA */
+
+/* Computing MAX */
+ d__1 = safmin, d__2 = eps * absar, d__1 = max(d__1,d__2), d__2 = eps *
+ absai;
+ if (abs(sbeta) < safmin && absb >= max(d__1,d__2)) {
+ ilimit = TRUE_;
+/* Computing MAX */
+/* Computing MAX */
+ d__3 = onepls * safmin, d__4 = bnrm2 * absb;
+ d__1 = scale, d__2 = onepls * safmin / bnrm1 / max(d__3,d__4);
+ scale = max(d__1,d__2);
+ }
+
+/* Check for possible overflow when limiting scaling */
+
+ if (ilimit) {
+/* Computing MAX */
+ d__1 = abs(salfar), d__2 = abs(salfai), d__1 = max(d__1,d__2),
+ d__2 = abs(sbeta);
+ temp = scale * safmin * max(d__1,d__2);
+ if (temp > 1.) {
+ scale /= temp;
+ }
+ if (scale < 1.) {
+ ilimit = FALSE_;
+ }
+ }
+
+/* Recompute un-scaled ALPHAR, ALPHAI, BETA if necessary. */
+
+ if (ilimit) {
+ salfar = scale * alphar[jc] * anrm;
+ salfai = scale * alphai[jc] * anrm;
+ sbeta = scale * beta[jc] * bnrm;
+ }
+ alphar[jc] = salfar;
+ alphai[jc] = salfai;
+ beta[jc] = sbeta;
+/* L110: */
+ }
+
+L120:
+ work[1] = (doublereal) lwkopt;
+
+ return 0;
+
+/* End of DGEGV */
+
+} /* dgegv_ */
diff --git a/SRC/dgehd2.c b/SRC/dgehd2.c
new file mode 100644
index 0000000..b9a4c75
--- /dev/null
+++ b/SRC/dgehd2.c
@@ -0,0 +1,191 @@
+/* dgehd2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dgehd2_(integer *n, integer *ilo, integer *ihi,
+ doublereal *a, integer *lda, doublereal *tau, doublereal *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__;
+ doublereal aii;
+ extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *), dlarfg_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGEHD2 reduces a real general matrix A to upper Hessenberg form H by */
+/* an orthogonal similarity transformation: Q' * A * Q = H . */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that A is already upper triangular in rows */
+/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
+/* set by a previous call to DGEBAL; otherwise they should be */
+/* set to 1 and N respectively. See Further Details. */
+/* 1 <= ILO <= IHI <= max(1,N). */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the n by n general matrix to be reduced. */
+/* On exit, the upper triangle and the first subdiagonal of A */
+/* are overwritten with the upper Hessenberg matrix H, and the */
+/* elements below the first subdiagonal, with the array TAU, */
+/* represent the orthogonal matrix Q as a product of elementary */
+/* reflectors. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of (ihi-ilo) elementary */
+/* reflectors */
+
+/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */
+/* exit in A(i+2:ihi,i), and tau in TAU(i). */
+
+/* The contents of A are illustrated by the following example, with */
+/* n = 7, ilo = 2 and ihi = 6: */
+
+/* on entry, on exit, */
+
+/* ( a a a a a a a ) ( a a h h h h a ) */
+/* ( a a a a a a ) ( a h h h h a ) */
+/* ( a a a a a a ) ( h h h h h h ) */
+/* ( a a a a a a ) ( v2 h h h h h ) */
+/* ( a a a a a a ) ( v2 v3 h h h h ) */
+/* ( a a a a a a ) ( v2 v3 v4 h h h ) */
+/* ( a ) ( a ) */
+
+/* where a denotes an element of the original matrix A, h denotes a */
+/* modified element of the upper Hessenberg matrix H, and vi denotes an */
+/* element of the vector defining H(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*ilo < 1 || *ilo > max(1,*n)) {
+ *info = -2;
+ } else if (*ihi < min(*ilo,*n) || *ihi > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGEHD2", &i__1);
+ return 0;
+ }
+
+ i__1 = *ihi - 1;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+
+/* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) */
+
+ i__2 = *ihi - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *n)+ i__ *
+ a_dim1], &c__1, &tau[i__]);
+ aii = a[i__ + 1 + i__ * a_dim1];
+ a[i__ + 1 + i__ * a_dim1] = 1.;
+
+/* Apply H(i) to A(1:ihi,i+1:ihi) from the right */
+
+ i__2 = *ihi - i__;
+ dlarf_("Right", ihi, &i__2, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
+ i__], &a[(i__ + 1) * a_dim1 + 1], lda, &work[1]);
+
+/* Apply H(i) to A(i+1:ihi,i+1:n) from the left */
+
+ i__2 = *ihi - i__;
+ i__3 = *n - i__;
+ dlarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
+ i__], &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1]);
+
+ a[i__ + 1 + i__ * a_dim1] = aii;
+/* L10: */
+ }
+
+ return 0;
+
+/* End of DGEHD2 */
+
+} /* dgehd2_ */
diff --git a/SRC/dgehrd.c b/SRC/dgehrd.c
new file mode 100644
index 0000000..6e88e9d
--- /dev/null
+++ b/SRC/dgehrd.c
@@ -0,0 +1,342 @@
+/* dgehrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+static integer c__65 = 65;
+static doublereal c_b25 = -1.;
+static doublereal c_b26 = 1.;
+
+/* Subroutine */ int dgehrd_(integer *n, integer *ilo, integer *ihi,
+ doublereal *a, integer *lda, doublereal *tau, doublereal *work,
+ integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal t[4160] /* was [65][64] */;
+ integer ib;
+ doublereal ei;
+ integer nb, nh, nx, iws;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), daxpy_(
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *), dgehd2_(integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *), dlahr2_(
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *),
+ dlarfb_(char *, char *, char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGEHRD reduces a real general matrix A to upper Hessenberg form H by */
+/* an orthogonal similarity transformation: Q' * A * Q = H . */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that A is already upper triangular in rows */
+/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
+/* set by a previous call to DGEBAL; otherwise they should be */
+/* set to 1 and N respectively. See Further Details. */
+/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the N-by-N general matrix to be reduced. */
+/* On exit, the upper triangle and the first subdiagonal of A */
+/* are overwritten with the upper Hessenberg matrix H, and the */
+/* elements below the first subdiagonal, with the array TAU, */
+/* represent the orthogonal matrix Q as a product of elementary */
+/* reflectors. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to */
+/* zero. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(1,N). */
+/* For optimum performance LWORK >= N*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of (ihi-ilo) elementary */
+/* reflectors */
+
+/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */
+/* exit in A(i+2:ihi,i), and tau in TAU(i). */
+
+/* The contents of A are illustrated by the following example, with */
+/* n = 7, ilo = 2 and ihi = 6: */
+
+/* on entry, on exit, */
+
+/* ( a a a a a a a ) ( a a h h h h a ) */
+/* ( a a a a a a ) ( a h h h h a ) */
+/* ( a a a a a a ) ( h h h h h h ) */
+/* ( a a a a a a ) ( v2 h h h h h ) */
+/* ( a a a a a a ) ( v2 v3 h h h h ) */
+/* ( a a a a a a ) ( v2 v3 v4 h h h ) */
+/* ( a ) ( a ) */
+
+/* where a denotes an element of the original matrix A, h denotes a */
+/* modified element of the upper Hessenberg matrix H, and vi denotes an */
+/* element of the vector defining H(i). */
+
+/* This file is a slight modification of LAPACK-3.0's DGEHRD */
+/* subroutine incorporating improvements proposed by Quintana-Orti and */
+/* Van de Geijn (2005). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+/* Computing MIN */
+ i__1 = 64, i__2 = ilaenv_(&c__1, "DGEHRD", " ", n, ilo, ihi, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = *n * nb;
+ work[1] = (doublereal) lwkopt;
+ lquery = *lwork == -1;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*ilo < 1 || *ilo > max(1,*n)) {
+ *info = -2;
+ } else if (*ihi < min(*ilo,*n) || *ihi > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGEHRD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero */
+
+ i__1 = *ilo - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tau[i__] = 0.;
+/* L10: */
+ }
+ i__1 = *n - 1;
+ for (i__ = max(1,*ihi); i__ <= i__1; ++i__) {
+ tau[i__] = 0.;
+/* L20: */
+ }
+
+/* Quick return if possible */
+
+ nh = *ihi - *ilo + 1;
+ if (nh <= 1) {
+ work[1] = 1.;
+ return 0;
+ }
+
+/* Determine the block size */
+
+/* Computing MIN */
+ i__1 = 64, i__2 = ilaenv_(&c__1, "DGEHRD", " ", n, ilo, ihi, &c_n1);
+ nb = min(i__1,i__2);
+ nbmin = 2;
+ iws = 1;
+ if (nb > 1 && nb < nh) {
+
+/* Determine when to cross over from blocked to unblocked code */
+/* (last block is always handled by unblocked code) */
+
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__3, "DGEHRD", " ", n, ilo, ihi, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < nh) {
+
+/* Determine if workspace is large enough for blocked code */
+
+ iws = *n * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: determine the */
+/* minimum value of NB, and reduce NB or force use of */
+/* unblocked code */
+
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "DGEHRD", " ", n, ilo, ihi, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ if (*lwork >= *n * nbmin) {
+ nb = *lwork / *n;
+ } else {
+ nb = 1;
+ }
+ }
+ }
+ }
+ ldwork = *n;
+
+ if (nb < nbmin || nb >= nh) {
+
+/* Use unblocked code below */
+
+ i__ = *ilo;
+
+ } else {
+
+/* Use blocked code */
+
+ i__1 = *ihi - 1 - nx;
+ i__2 = nb;
+ for (i__ = *ilo; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *ihi - i__;
+ ib = min(i__3,i__4);
+
+/* Reduce columns i:i+ib-1 to Hessenberg form, returning the */
+/* matrices V and T of the block reflector H = I - V*T*V' */
+/* which performs the reduction, and also the matrix Y = A*V*T */
+
+ dlahr2_(ihi, &i__, &ib, &a[i__ * a_dim1 + 1], lda, &tau[i__], t, &
+ c__65, &work[1], &ldwork);
+
+/* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the */
+/* right, computing A := A - Y * V'. V(i+ib,ib-1) must be set */
+/* to 1 */
+
+ ei = a[i__ + ib + (i__ + ib - 1) * a_dim1];
+ a[i__ + ib + (i__ + ib - 1) * a_dim1] = 1.;
+ i__3 = *ihi - i__ - ib + 1;
+ dgemm_("No transpose", "Transpose", ihi, &i__3, &ib, &c_b25, &
+ work[1], &ldwork, &a[i__ + ib + i__ * a_dim1], lda, &
+ c_b26, &a[(i__ + ib) * a_dim1 + 1], lda);
+ a[i__ + ib + (i__ + ib - 1) * a_dim1] = ei;
+
+/* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the */
+/* right */
+
+ i__3 = ib - 1;
+ dtrmm_("Right", "Lower", "Transpose", "Unit", &i__, &i__3, &c_b26,
+ &a[i__ + 1 + i__ * a_dim1], lda, &work[1], &ldwork);
+ i__3 = ib - 2;
+ for (j = 0; j <= i__3; ++j) {
+ daxpy_(&i__, &c_b25, &work[ldwork * j + 1], &c__1, &a[(i__ +
+ j + 1) * a_dim1 + 1], &c__1);
+/* L30: */
+ }
+
+/* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the */
+/* left */
+
+ i__3 = *ihi - i__;
+ i__4 = *n - i__ - ib + 1;
+ dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__3, &
+ i__4, &ib, &a[i__ + 1 + i__ * a_dim1], lda, t, &c__65, &a[
+ i__ + 1 + (i__ + ib) * a_dim1], lda, &work[1], &ldwork);
+/* L40: */
+ }
+ }
+
+/* Use unblocked code to reduce the rest of the matrix */
+
+ dgehd2_(n, &i__, ihi, &a[a_offset], lda, &tau[1], &work[1], &iinfo);
+ work[1] = (doublereal) iws;
+
+ return 0;
+
+/* End of DGEHRD */
+
+} /* dgehrd_ */
diff --git a/SRC/dgejsv.c b/SRC/dgejsv.c
new file mode 100644
index 0000000..0b0376b
--- /dev/null
+++ b/SRC/dgejsv.c
@@ -0,0 +1,2218 @@
+/* dgejsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b34 = 0.;
+static doublereal c_b35 = 1.;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dgejsv_(char *joba, char *jobu, char *jobv, char *jobr,
+ char *jobt, char *jobp, integer *m, integer *n, doublereal *a,
+ integer *lda, doublereal *sva, doublereal *u, integer *ldu,
+ doublereal *v, integer *ldv, doublereal *work, integer *lwork,
+ integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal), log(doublereal), d_sign(doublereal *, doublereal
+ *);
+ integer i_dnnt(doublereal *);
+
+ /* Local variables */
+ integer p, q, n1, nr;
+ doublereal big, xsc, big1;
+ logical defr;
+ doublereal aapp, aaqq;
+ logical kill;
+ integer ierr;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ doublereal temp1;
+ logical jracc;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ doublereal small, entra, sfmin;
+ logical lsvec;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dswap_(integer *, doublereal *, integer
+ *, doublereal *, integer *);
+ doublereal epsln;
+ logical rsvec;
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical l2aber;
+ extern /* Subroutine */ int dgeqp3_(integer *, integer *, doublereal *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+ doublereal condr1, condr2, uscal1, uscal2;
+ logical l2kill, l2rank, l2tran, l2pert;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal scalem;
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ doublereal sconda;
+ logical goscal;
+ doublereal aatmin;
+ extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *);
+ doublereal aatmax;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), xerbla_(char *, integer *);
+ logical noscal;
+ extern /* Subroutine */ int dpocon_(char *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *), dgesvj_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dlassq_(integer *, doublereal *, integer
+ *, doublereal *, doublereal *), dlaswp_(integer *, doublereal *,
+ integer *, integer *, integer *, integer *, integer *);
+ doublereal entrat;
+ logical almort;
+ extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dormlq_(char *, char *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *);
+ doublereal maxprj;
+ logical errest;
+ extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ logical transp, rowpiv;
+ doublereal cond_ok__;
+ integer warning, numrank;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Zlatko Drmac of the University of Zagreb and -- */
+/* -- Kresimir Veselic of the Fernuniversitaet Hagen -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* This routine is also part of SIGMA (version 1.23, October 23. 2008.) */
+/* SIGMA is a library of algorithms for highly accurate algorithms for */
+/* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the */
+/* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0. */
+
+/* -#- Scalar Arguments -#- */
+
+
+/* -#- Array Arguments -#- */
+
+/* .. */
+
+/* Purpose */
+/* ~~~~~~~ */
+/* DGEJSV computes the singular value decomposition (SVD) of a real M-by-N */
+/* matrix [A], where M >= N. The SVD of [A] is written as */
+
+/* [A] = [U] * [SIGMA] * [V]^t, */
+
+/* where [SIGMA] is an N-by-N (M-by-N) matrix which is zero except for its N */
+/* diagonal elements, [U] is an M-by-N (or M-by-M) orthonormal matrix, and */
+/* [V] is an N-by-N orthogonal matrix. The diagonal elements of [SIGMA] are */
+/* the singular values of [A]. The columns of [U] and [V] are the left and */
+/* the right singular vectors of [A], respectively. The matrices [U] and [V] */
+/* are computed and stored in the arrays U and V, respectively. The diagonal */
+/* of [SIGMA] is computed and stored in the array SVA. */
+
+/* Further details */
+/* ~~~~~~~~~~~~~~~ */
+/* DGEJSV implements a preconditioned Jacobi SVD algorithm. It uses SGEQP3, */
+/* SGEQRF, and SGELQF as preprocessors and preconditioners. Optionally, an */
+/* additional row pivoting can be used as a preprocessor, which in some */
+/* cases results in much higher accuracy. An example is matrix A with the */
+/* structure A = D1 * C * D2, where D1, D2 are arbitrarily ill-conditioned */
+/* diagonal matrices and C is well-conditioned matrix. In that case, complete */
+/* pivoting in the first QR factorizations provides accuracy dependent on the */
+/* condition number of C, and independent of D1, D2. Such higher accuracy is */
+/* not completely understood theoretically, but it works well in practice. */
+/* Further, if A can be written as A = B*D, with well-conditioned B and some */
+/* diagonal D, then the high accuracy is guaranteed, both theoretically and */
+/* in software, independent of D. For more details see [1], [2]. */
+/* The computational range for the singular values can be the full range */
+/* ( UNDERFLOW,OVERFLOW ), provided that the machine arithmetic and the BLAS */
+/* & LAPACK routines called by DGEJSV are implemented to work in that range. */
+/* If that is not the case, then the restriction for safe computation with */
+/* the singular values in the range of normalized IEEE numbers is that the */
+/* spectral condition number kappa(A)=sigma_max(A)/sigma_min(A) does not */
+/* overflow. This code (DGEJSV) is best used in this restricted range, */
+/* meaning that singular values of magnitude below ||A||_2 / SLAMCH('O') are */
+/* returned as zeros. See JOBR for details on this. */
+/* Further, this implementation is somewhat slower than the one described */
+/* in [1,2] due to replacement of some non-LAPACK components, and because */
+/* the choice of some tuning parameters in the iterative part (DGESVJ) is */
+/* left to the implementer on a particular machine. */
+/* The rank revealing QR factorization (in this code: SGEQP3) should be */
+/* implemented as in [3]. We have a new version of SGEQP3 under development */
+/* that is more robust than the current one in LAPACK, with a cleaner cut in */
+/* rank defficient cases. It will be available in the SIGMA library [4]. */
+/* If M is much larger than N, it is obvious that the inital QRF with */
+/* column pivoting can be preprocessed by the QRF without pivoting. That */
+/* well known trick is not used in DGEJSV because in some cases heavy row */
+/* weighting can be treated with complete pivoting. The overhead in cases */
+/* M much larger than N is then only due to pivoting, but the benefits in */
+/* terms of accuracy have prevailed. The implementer/user can incorporate */
+/* this extra QRF step easily. The implementer can also improve data movement */
+/* (matrix transpose, matrix copy, matrix transposed copy) - this */
+/* implementation of DGEJSV uses only the simplest, naive data movement. */
+
+/* Contributors */
+/* ~~~~~~~~~~~~ */
+/* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) */
+
+/* References */
+/* ~~~~~~~~~~ */
+/* [1] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I. */
+/* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342. */
+/* LAPACK Working note 169. */
+/* [2] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II. */
+/* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362. */
+/* LAPACK Working note 170. */
+/* [3] Z. Drmac and Z. Bujanovic: On the failure of rank-revealing QR */
+/* factorization software - a case study. */
+/* ACM Trans. Math. Softw. Vol. 35, No 2 (2008), pp. 1-28. */
+/* LAPACK Working note 176. */
+/* [4] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV, */
+/* QSVD, (H,K)-SVD computations. */
+/* Department of Mathematics, University of Zagreb, 2008. */
+
+/* Bugs, examples and comments */
+/* ~~~~~~~~~~~~~~~~~~~~~~~~~~~ */
+/* Please report all bugs and send interesting examples and/or comments to */
+/* drmac at math.hr. Thank you. */
+
+/* Arguments */
+/* ~~~~~~~~~ */
+/* ............................................................................ */
+/* . JOBA (input) CHARACTER*1 */
+/* . Specifies the level of accuracy: */
+/* . = 'C': This option works well (high relative accuracy) if A = B * D, */
+/* . with well-conditioned B and arbitrary diagonal matrix D. */
+/* . The accuracy cannot be spoiled by COLUMN scaling. The */
+/* . accuracy of the computed output depends on the condition of */
+/* . B, and the procedure aims at the best theoretical accuracy. */
+/* . The relative error max_{i=1:N}|d sigma_i| / sigma_i is */
+/* . bounded by f(M,N)*epsilon* cond(B), independent of D. */
+/* . The input matrix is preprocessed with the QRF with column */
+/* . pivoting. This initial preprocessing and preconditioning by */
+/* . a rank revealing QR factorization is common for all values of */
+/* . JOBA. Additional actions are specified as follows: */
+/* . = 'E': Computation as with 'C' with an additional estimate of the */
+/* . condition number of B. It provides a realistic error bound. */
+/* . = 'F': If A = D1 * C * D2 with ill-conditioned diagonal scalings */
+/* . D1, D2, and well-conditioned matrix C, this option gives */
+/* . higher accuracy than the 'C' option. If the structure of the */
+/* . input matrix is not known, and relative accuracy is */
+/* . desirable, then this option is advisable. The input matrix A */
+/* . is preprocessed with QR factorization with FULL (row and */
+/* . column) pivoting. */
+/* . = 'G' Computation as with 'F' with an additional estimate of the */
+/* . condition number of B, where A=D*B. If A has heavily weighted */
+/* . rows, then using this condition number gives too pessimistic */
+/* . error bound. */
+/* . = 'A': Small singular values are the noise and the matrix is treated */
+/* . as numerically rank defficient. The error in the computed */
+/* . singular values is bounded by f(m,n)*epsilon*||A||. */
+/* . The computed SVD A = U * S * V^t restores A up to */
+/* . f(m,n)*epsilon*||A||. */
+/* . This gives the procedure the licence to discard (set to zero) */
+/* . all singular values below N*epsilon*||A||. */
+/* . = 'R': Similar as in 'A'. Rank revealing property of the initial */
+/* . QR factorization is used do reveal (using triangular factor) */
+/* . a gap sigma_{r+1} < epsilon * sigma_r in which case the */
+/* . numerical RANK is declared to be r. The SVD is computed with */
+/* . absolute error bounds, but more accurately than with 'A'. */
+/* . */
+/* . JOBU (input) CHARACTER*1 */
+/* . Specifies whether to compute the columns of U: */
+/* . = 'U': N columns of U are returned in the array U. */
+/* . = 'F': full set of M left sing. vectors is returned in the array U. */
+/* . = 'W': U may be used as workspace of length M*N. See the description */
+/* . of U. */
+/* . = 'N': U is not computed. */
+/* . */
+/* . JOBV (input) CHARACTER*1 */
+/* . Specifies whether to compute the matrix V: */
+/* . = 'V': N columns of V are returned in the array V; Jacobi rotations */
+/* . are not explicitly accumulated. */
+/* . = 'J': N columns of V are returned in the array V, but they are */
+/* . computed as the product of Jacobi rotations. This option is */
+/* . allowed only if JOBU .NE. 'N', i.e. in computing the full SVD. */
+/* . = 'W': V may be used as workspace of length N*N. See the description */
+/* . of V. */
+/* . = 'N': V is not computed. */
+/* . */
+/* . JOBR (input) CHARACTER*1 */
+/* . Specifies the RANGE for the singular values. Issues the licence to */
+/* . set to zero small positive singular values if they are outside */
+/* . specified range. If A .NE. 0 is scaled so that the largest singular */
+/* . value of c*A is around DSQRT(BIG), BIG=SLAMCH('O'), then JOBR issues */
+/* . the licence to kill columns of A whose norm in c*A is less than */
+/* . DSQRT(SFMIN) (for JOBR.EQ.'R'), or less than SMALL=SFMIN/EPSLN, */
+/* . where SFMIN=SLAMCH('S'), EPSLN=SLAMCH('E'). */
+/* . = 'N': Do not kill small columns of c*A. This option assumes that */
+/* . BLAS and QR factorizations and triangular solvers are */
+/* . implemented to work in that range. If the condition of A */
+/* . is greater than BIG, use DGESVJ. */
+/* . = 'R': RESTRICTED range for sigma(c*A) is [DSQRT(SFMIN), DSQRT(BIG)] */
+/* . (roughly, as described above). This option is recommended. */
+/* . ~~~~~~~~~~~~~~~~~~~~~~~~~~~ */
+/* . For computing the singular values in the FULL range [SFMIN,BIG] */
+/* . use DGESVJ. */
+/* . */
+/* . JOBT (input) CHARACTER*1 */
+/* . If the matrix is square then the procedure may determine to use */
+/* . transposed A if A^t seems to be better with respect to convergence. */
+/* . If the matrix is not square, JOBT is ignored. This is subject to */
+/* . changes in the future. */
+/* . The decision is based on two values of entropy over the adjoint */
+/* . orbit of A^t * A. See the descriptions of WORK(6) and WORK(7). */
+/* . = 'T': transpose if entropy test indicates possibly faster */
+/* . convergence of Jacobi process if A^t is taken as input. If A is */
+/* . replaced with A^t, then the row pivoting is included automatically. */
+/* . = 'N': do not speculate. */
+/* . This option can be used to compute only the singular values, or the */
+/* . full SVD (U, SIGMA and V). For only one set of singular vectors */
+/* . (U or V), the caller should provide both U and V, as one of the */
+/* . matrices is used as workspace if the matrix A is transposed. */
+/* . The implementer can easily remove this constraint and make the */
+/* . code more complicated. See the descriptions of U and V. */
+/* . */
+/* . JOBP (input) CHARACTER*1 */
+/* . Issues the licence to introduce structured perturbations to drown */
+/* . denormalized numbers. This licence should be active if the */
+/* . denormals are poorly implemented, causing slow computation, */
+/* . especially in cases of fast convergence (!). For details see [1,2]. */
+/* . For the sake of simplicity, this perturbations are included only */
+/* . when the full SVD or only the singular values are requested. The */
+/* . implementer/user can easily add the perturbation for the cases of */
+/* . computing one set of singular vectors. */
+/* . = 'P': introduce perturbation */
+/* . = 'N': do not perturb */
+/* ............................................................................ */
+
+/* M (input) INTEGER */
+/* The number of rows of the input matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the input matrix A. M >= N >= 0. */
+
+/* A (input/workspace) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* SVA (workspace/output) REAL array, dimension (N) */
+/* On exit, */
+/* - For WORK(1)/WORK(2) = ONE: The singular values of A. During the */
+/* computation SVA contains Euclidean column norms of the */
+/* iterated matrices in the array A. */
+/* - For WORK(1) .NE. WORK(2): The singular values of A are */
+/* (WORK(1)/WORK(2)) * SVA(1:N). This factored form is used if */
+/* sigma_max(A) overflows or if small singular values have been */
+/* saved from underflow by scaling the input matrix A. */
+/* - If JOBR='R' then some of the singular values may be returned */
+/* as exact zeros obtained by "set to zero" because they are */
+/* below the numerical rank threshold or are denormalized numbers. */
+
+/* U (workspace/output) REAL array, dimension ( LDU, N ) */
+/* If JOBU = 'U', then U contains on exit the M-by-N matrix of */
+/* the left singular vectors. */
+/* If JOBU = 'F', then U contains on exit the M-by-M matrix of */
+/* the left singular vectors, including an ONB */
+/* of the orthogonal complement of the Range(A). */
+/* If JOBU = 'W' .AND. (JOBV.EQ.'V' .AND. JOBT.EQ.'T' .AND. M.EQ.N), */
+/* then U is used as workspace if the procedure */
+/* replaces A with A^t. In that case, [V] is computed */
+/* in U as left singular vectors of A^t and then */
+/* copied back to the V array. This 'W' option is just */
+/* a reminder to the caller that in this case U is */
+/* reserved as workspace of length N*N. */
+/* If JOBU = 'N' U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U, LDU >= 1. */
+/* IF JOBU = 'U' or 'F' or 'W', then LDU >= M. */
+
+/* V (workspace/output) REAL array, dimension ( LDV, N ) */
+/* If JOBV = 'V', 'J' then V contains on exit the N-by-N matrix of */
+/* the right singular vectors; */
+/* If JOBV = 'W', AND (JOBU.EQ.'U' AND JOBT.EQ.'T' AND M.EQ.N), */
+/* then V is used as workspace if the pprocedure */
+/* replaces A with A^t. In that case, [U] is computed */
+/* in V as right singular vectors of A^t and then */
+/* copied back to the U array. This 'W' option is just */
+/* a reminder to the caller that in this case V is */
+/* reserved as workspace of length N*N. */
+/* If JOBV = 'N' V is not referenced. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V, LDV >= 1. */
+/* If JOBV = 'V' or 'J' or 'W', then LDV >= N. */
+
+/* WORK (workspace/output) REAL array, dimension at least LWORK. */
+/* On exit, */
+/* WORK(1) = SCALE = WORK(2) / WORK(1) is the scaling factor such */
+/* that SCALE*SVA(1:N) are the computed singular values */
+/* of A. (See the description of SVA().) */
+/* WORK(2) = See the description of WORK(1). */
+/* WORK(3) = SCONDA is an estimate for the condition number of */
+/* column equilibrated A. (If JOBA .EQ. 'E' or 'G') */
+/* SCONDA is an estimate of DSQRT(||(R^t * R)^(-1)||_1). */
+/* It is computed using DPOCON. It holds */
+/* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA */
+/* where R is the triangular factor from the QRF of A. */
+/* However, if R is truncated and the numerical rank is */
+/* determined to be strictly smaller than N, SCONDA is */
+/* returned as -1, thus indicating that the smallest */
+/* singular values might be lost. */
+
+/* If full SVD is needed, the following two condition numbers are */
+/* useful for the analysis of the algorithm. They are provied for */
+/* a developer/implementer who is familiar with the details of */
+/* the method. */
+
+/* WORK(4) = an estimate of the scaled condition number of the */
+/* triangular factor in the first QR factorization. */
+/* WORK(5) = an estimate of the scaled condition number of the */
+/* triangular factor in the second QR factorization. */
+/* The following two parameters are computed if JOBT .EQ. 'T'. */
+/* They are provided for a developer/implementer who is familiar */
+/* with the details of the method. */
+
+/* WORK(6) = the entropy of A^t*A :: this is the Shannon entropy */
+/* of diag(A^t*A) / Trace(A^t*A) taken as point in the */
+/* probability simplex. */
+/* WORK(7) = the entropy of A*A^t. */
+
+/* LWORK (input) INTEGER */
+/* Length of WORK to confirm proper allocation of work space. */
+/* LWORK depends on the job: */
+
+/* If only SIGMA is needed ( JOBU.EQ.'N', JOBV.EQ.'N' ) and */
+/* -> .. no scaled condition estimate required ( JOBE.EQ.'N'): */
+/* LWORK >= max(2*M+N,4*N+1,7). This is the minimal requirement. */
+/* For optimal performance (blocked code) the optimal value */
+/* is LWORK >= max(2*M+N,3*N+(N+1)*NB,7). Here NB is the optimal */
+/* block size for xGEQP3/xGEQRF. */
+/* -> .. an estimate of the scaled condition number of A is */
+/* required (JOBA='E', 'G'). In this case, LWORK is the maximum */
+/* of the above and N*N+4*N, i.e. LWORK >= max(2*M+N,N*N+4N,7). */
+
+/* If SIGMA and the right singular vectors are needed (JOBV.EQ.'V'), */
+/* -> the minimal requirement is LWORK >= max(2*N+M,7). */
+/* -> For optimal performance, LWORK >= max(2*N+M,2*N+N*NB,7), */
+/* where NB is the optimal block size. */
+
+/* If SIGMA and the left singular vectors are needed */
+/* -> the minimal requirement is LWORK >= max(2*N+M,7). */
+/* -> For optimal performance, LWORK >= max(2*N+M,2*N+N*NB,7), */
+/* where NB is the optimal block size. */
+
+/* If full SVD is needed ( JOBU.EQ.'U' or 'F', JOBV.EQ.'V' ) and */
+/* -> .. the singular vectors are computed without explicit */
+/* accumulation of the Jacobi rotations, LWORK >= 6*N+2*N*N */
+/* -> .. in the iterative part, the Jacobi rotations are */
+/* explicitly accumulated (option, see the description of JOBV), */
+/* then the minimal requirement is LWORK >= max(M+3*N+N*N,7). */
+/* For better performance, if NB is the optimal block size, */
+/* LWORK >= max(3*N+N*N+M,3*N+N*N+N*NB,7). */
+
+/* IWORK (workspace/output) INTEGER array, dimension M+3*N. */
+/* On exit, */
+/* IWORK(1) = the numerical rank determined after the initial */
+/* QR factorization with pivoting. See the descriptions */
+/* of JOBA and JOBR. */
+/* IWORK(2) = the number of the computed nonzero singular values */
+/* IWORK(3) = if nonzero, a warning message: */
+/* If IWORK(3).EQ.1 then some of the column norms of A */
+/* were denormalized floats. The requested high accuracy */
+/* is not warranted by the data. */
+
+/* INFO (output) INTEGER */
+/* < 0 : if INFO = -i, then the i-th argument had an illegal value. */
+/* = 0 : successfull exit; */
+/* > 0 : DGEJSV did not converge in the maximal allowed number */
+/* of sweeps. The computed values may be inaccurate. */
+
+/* ............................................................................ */
+
+/* Local Parameters: */
+
+
+/* Local Scalars: */
+
+
+/* Intrinsic Functions: */
+
+
+/* External Functions: */
+
+
+/* External Subroutines ( BLAS, LAPACK ): */
+
+
+
+/* ............................................................................ */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --sva;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ lsvec = lsame_(jobu, "U") || lsame_(jobu, "F");
+ jracc = lsame_(jobv, "J");
+ rsvec = lsame_(jobv, "V") || jracc;
+ rowpiv = lsame_(joba, "F") || lsame_(joba, "G");
+ l2rank = lsame_(joba, "R");
+ l2aber = lsame_(joba, "A");
+ errest = lsame_(joba, "E") || lsame_(joba, "G");
+ l2tran = lsame_(jobt, "T");
+ l2kill = lsame_(jobr, "R");
+ defr = lsame_(jobr, "N");
+ l2pert = lsame_(jobp, "P");
+
+ if (! (rowpiv || l2rank || l2aber || errest || lsame_(joba, "C"))) {
+ *info = -1;
+ } else if (! (lsvec || lsame_(jobu, "N") || lsame_(
+ jobu, "W"))) {
+ *info = -2;
+ } else if (! (rsvec || lsame_(jobv, "N") || lsame_(
+ jobv, "W")) || jracc && ! lsvec) {
+ *info = -3;
+ } else if (! (l2kill || defr)) {
+ *info = -4;
+ } else if (! (l2tran || lsame_(jobt, "N"))) {
+ *info = -5;
+ } else if (! (l2pert || lsame_(jobp, "N"))) {
+ *info = -6;
+ } else if (*m < 0) {
+ *info = -7;
+ } else if (*n < 0 || *n > *m) {
+ *info = -8;
+ } else if (*lda < *m) {
+ *info = -10;
+ } else if (lsvec && *ldu < *m) {
+ *info = -13;
+ } else if (rsvec && *ldv < *n) {
+ *info = -14;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = 7, i__2 = (*n << 2) + 1, i__1 = max(i__1,i__2), i__2 = (*m <<
+ 1) + *n;
+/* Computing MAX */
+ i__3 = 7, i__4 = (*n << 2) + *n * *n, i__3 = max(i__3,i__4), i__4 = (*
+ m << 1) + *n;
+/* Computing MAX */
+ i__5 = 7, i__6 = (*n << 1) + *m;
+/* Computing MAX */
+ i__7 = 7, i__8 = (*n << 1) + *m;
+/* Computing MAX */
+ i__9 = 7, i__10 = *m + *n * 3 + *n * *n;
+ if (! (lsvec || rsvec || errest) && *lwork < max(i__1,i__2) || ! (
+ lsvec || lsvec) && errest && *lwork < max(i__3,i__4) || lsvec
+ && ! rsvec && *lwork < max(i__5,i__6) || rsvec && ! lsvec && *
+ lwork < max(i__7,i__8) || lsvec && rsvec && ! jracc && *lwork
+ < *n * 6 + (*n << 1) * *n || lsvec && rsvec && jracc && *
+ lwork < max(i__9,i__10)) {
+ *info = -17;
+ } else {
+/* #:) */
+ *info = 0;
+ }
+ }
+
+ if (*info != 0) {
+/* #:( */
+ i__1 = -(*info);
+ xerbla_("DGEJSV", &i__1);
+ }
+
+/* Quick return for void matrix (Y3K safe) */
+/* #:) */
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Determine whether the matrix U should be M x N or M x M */
+
+ if (lsvec) {
+ n1 = *n;
+ if (lsame_(jobu, "F")) {
+ n1 = *m;
+ }
+ }
+
+/* Set numerical parameters */
+
+/* ! NOTE: Make sure DLAMCH() does not fail on the target architecture. */
+
+ epsln = dlamch_("Epsilon");
+ sfmin = dlamch_("SafeMinimum");
+ small = sfmin / epsln;
+ big = dlamch_("O");
+/* BIG = ONE / SFMIN */
+
+/* Initialize SVA(1:N) = diag( ||A e_i||_2 )_1^N */
+
+/* (!) If necessary, scale SVA() to protect the largest norm from */
+/* overflow. It is possible that this scaling pushes the smallest */
+/* column norm left from the underflow threshold (extreme case). */
+
+ scalem = 1. / sqrt((doublereal) (*m) * (doublereal) (*n));
+ noscal = TRUE_;
+ goscal = TRUE_;
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ aapp = 0.;
+ aaqq = 0.;
+ dlassq_(m, &a[p * a_dim1 + 1], &c__1, &aapp, &aaqq);
+ if (aapp > big) {
+ *info = -9;
+ i__2 = -(*info);
+ xerbla_("DGEJSV", &i__2);
+ return 0;
+ }
+ aaqq = sqrt(aaqq);
+ if (aapp < big / aaqq && noscal) {
+ sva[p] = aapp * aaqq;
+ } else {
+ noscal = FALSE_;
+ sva[p] = aapp * (aaqq * scalem);
+ if (goscal) {
+ goscal = FALSE_;
+ i__2 = p - 1;
+ dscal_(&i__2, &scalem, &sva[1], &c__1);
+ }
+ }
+/* L1874: */
+ }
+
+ if (noscal) {
+ scalem = 1.;
+ }
+
+ aapp = 0.;
+ aaqq = big;
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+/* Computing MAX */
+ d__1 = aapp, d__2 = sva[p];
+ aapp = max(d__1,d__2);
+ if (sva[p] != 0.) {
+/* Computing MIN */
+ d__1 = aaqq, d__2 = sva[p];
+ aaqq = min(d__1,d__2);
+ }
+/* L4781: */
+ }
+
+/* Quick return for zero M x N matrix */
+/* #:) */
+ if (aapp == 0.) {
+ if (lsvec) {
+ dlaset_("G", m, &n1, &c_b34, &c_b35, &u[u_offset], ldu)
+ ;
+ }
+ if (rsvec) {
+ dlaset_("G", n, n, &c_b34, &c_b35, &v[v_offset], ldv);
+ }
+ work[1] = 1.;
+ work[2] = 1.;
+ if (errest) {
+ work[3] = 1.;
+ }
+ if (lsvec && rsvec) {
+ work[4] = 1.;
+ work[5] = 1.;
+ }
+ if (l2tran) {
+ work[6] = 0.;
+ work[7] = 0.;
+ }
+ iwork[1] = 0;
+ iwork[2] = 0;
+ return 0;
+ }
+
+/* Issue warning if denormalized column norms detected. Override the */
+/* high relative accuracy request. Issue licence to kill columns */
+/* (set them to zero) whose norm is less than sigma_max / BIG (roughly). */
+/* #:( */
+ warning = 0;
+ if (aaqq <= sfmin) {
+ l2rank = TRUE_;
+ l2kill = TRUE_;
+ warning = 1;
+ }
+
+/* Quick return for one-column matrix */
+/* #:) */
+ if (*n == 1) {
+
+ if (lsvec) {
+ dlascl_("G", &c__0, &c__0, &sva[1], &scalem, m, &c__1, &a[a_dim1
+ + 1], lda, &ierr);
+ dlacpy_("A", m, &c__1, &a[a_offset], lda, &u[u_offset], ldu);
+/* computing all M left singular vectors of the M x 1 matrix */
+ if (n1 != *n) {
+ i__1 = *lwork - *n;
+ dgeqrf_(m, n, &u[u_offset], ldu, &work[1], &work[*n + 1], &
+ i__1, &ierr);
+ i__1 = *lwork - *n;
+ dorgqr_(m, &n1, &c__1, &u[u_offset], ldu, &work[1], &work[*n
+ + 1], &i__1, &ierr);
+ dcopy_(m, &a[a_dim1 + 1], &c__1, &u[u_dim1 + 1], &c__1);
+ }
+ }
+ if (rsvec) {
+ v[v_dim1 + 1] = 1.;
+ }
+ if (sva[1] < big * scalem) {
+ sva[1] /= scalem;
+ scalem = 1.;
+ }
+ work[1] = 1. / scalem;
+ work[2] = 1.;
+ if (sva[1] != 0.) {
+ iwork[1] = 1;
+ if (sva[1] / scalem >= sfmin) {
+ iwork[2] = 1;
+ } else {
+ iwork[2] = 0;
+ }
+ } else {
+ iwork[1] = 0;
+ iwork[2] = 0;
+ }
+ if (errest) {
+ work[3] = 1.;
+ }
+ if (lsvec && rsvec) {
+ work[4] = 1.;
+ work[5] = 1.;
+ }
+ if (l2tran) {
+ work[6] = 0.;
+ work[7] = 0.;
+ }
+ return 0;
+
+ }
+
+ transp = FALSE_;
+ l2tran = l2tran && *m == *n;
+
+ aatmax = -1.;
+ aatmin = big;
+ if (rowpiv || l2tran) {
+
+/* Compute the row norms, needed to determine row pivoting sequence */
+/* (in the case of heavily row weighted A, row pivoting is strongly */
+/* advised) and to collect information needed to compare the */
+/* structures of A * A^t and A^t * A (in the case L2TRAN.EQ..TRUE.). */
+
+ if (l2tran) {
+ i__1 = *m;
+ for (p = 1; p <= i__1; ++p) {
+ xsc = 0.;
+ temp1 = 0.;
+ dlassq_(n, &a[p + a_dim1], lda, &xsc, &temp1);
+/* DLASSQ gets both the ell_2 and the ell_infinity norm */
+/* in one pass through the vector */
+ work[*m + *n + p] = xsc * scalem;
+ work[*n + p] = xsc * (scalem * sqrt(temp1));
+/* Computing MAX */
+ d__1 = aatmax, d__2 = work[*n + p];
+ aatmax = max(d__1,d__2);
+ if (work[*n + p] != 0.) {
+/* Computing MIN */
+ d__1 = aatmin, d__2 = work[*n + p];
+ aatmin = min(d__1,d__2);
+ }
+/* L1950: */
+ }
+ } else {
+ i__1 = *m;
+ for (p = 1; p <= i__1; ++p) {
+ work[*m + *n + p] = scalem * (d__1 = a[p + idamax_(n, &a[p +
+ a_dim1], lda) * a_dim1], abs(d__1));
+/* Computing MAX */
+ d__1 = aatmax, d__2 = work[*m + *n + p];
+ aatmax = max(d__1,d__2);
+/* Computing MIN */
+ d__1 = aatmin, d__2 = work[*m + *n + p];
+ aatmin = min(d__1,d__2);
+/* L1904: */
+ }
+ }
+
+ }
+
+/* For square matrix A try to determine whether A^t would be better */
+/* input for the preconditioned Jacobi SVD, with faster convergence. */
+/* The decision is based on an O(N) function of the vector of column */
+/* and row norms of A, based on the Shannon entropy. This should give */
+/* the right choice in most cases when the difference actually matters. */
+/* It may fail and pick the slower converging side. */
+
+ entra = 0.;
+ entrat = 0.;
+ if (l2tran) {
+
+ xsc = 0.;
+ temp1 = 0.;
+ dlassq_(n, &sva[1], &c__1, &xsc, &temp1);
+ temp1 = 1. / temp1;
+
+ entra = 0.;
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+/* Computing 2nd power */
+ d__1 = sva[p] / xsc;
+ big1 = d__1 * d__1 * temp1;
+ if (big1 != 0.) {
+ entra += big1 * log(big1);
+ }
+/* L1113: */
+ }
+ entra = -entra / log((doublereal) (*n));
+
+/* Now, SVA().^2/Trace(A^t * A) is a point in the probability simplex. */
+/* It is derived from the diagonal of A^t * A. Do the same with the */
+/* diagonal of A * A^t, compute the entropy of the corresponding */
+/* probability distribution. Note that A * A^t and A^t * A have the */
+/* same trace. */
+
+ entrat = 0.;
+ i__1 = *n + *m;
+ for (p = *n + 1; p <= i__1; ++p) {
+/* Computing 2nd power */
+ d__1 = work[p] / xsc;
+ big1 = d__1 * d__1 * temp1;
+ if (big1 != 0.) {
+ entrat += big1 * log(big1);
+ }
+/* L1114: */
+ }
+ entrat = -entrat / log((doublereal) (*m));
+
+/* Analyze the entropies and decide A or A^t. Smaller entropy */
+/* usually means better input for the algorithm. */
+
+ transp = entrat < entra;
+
+/* If A^t is better than A, transpose A. */
+
+ if (transp) {
+/* In an optimal implementation, this trivial transpose */
+/* should be replaced with faster transpose. */
+ i__1 = *n - 1;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = *n;
+ for (q = p + 1; q <= i__2; ++q) {
+ temp1 = a[q + p * a_dim1];
+ a[q + p * a_dim1] = a[p + q * a_dim1];
+ a[p + q * a_dim1] = temp1;
+/* L1116: */
+ }
+/* L1115: */
+ }
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ work[*m + *n + p] = sva[p];
+ sva[p] = work[*n + p];
+/* L1117: */
+ }
+ temp1 = aapp;
+ aapp = aatmax;
+ aatmax = temp1;
+ temp1 = aaqq;
+ aaqq = aatmin;
+ aatmin = temp1;
+ kill = lsvec;
+ lsvec = rsvec;
+ rsvec = kill;
+
+ rowpiv = TRUE_;
+ }
+
+ }
+/* END IF L2TRAN */
+
+/* Scale the matrix so that its maximal singular value remains less */
+/* than DSQRT(BIG) -- the matrix is scaled so that its maximal column */
+/* has Euclidean norm equal to DSQRT(BIG/N). The only reason to keep */
+/* DSQRT(BIG) instead of BIG is the fact that DGEJSV uses LAPACK and */
+/* BLAS routines that, in some implementations, are not capable of */
+/* working in the full interval [SFMIN,BIG] and that they may provoke */
+/* overflows in the intermediate results. If the singular values spread */
+/* from SFMIN to BIG, then DGESVJ will compute them. So, in that case, */
+/* one should use DGESVJ instead of DGEJSV. */
+
+ big1 = sqrt(big);
+ temp1 = sqrt(big / (doublereal) (*n));
+
+ dlascl_("G", &c__0, &c__0, &aapp, &temp1, n, &c__1, &sva[1], n, &ierr);
+ if (aaqq > aapp * sfmin) {
+ aaqq = aaqq / aapp * temp1;
+ } else {
+ aaqq = aaqq * temp1 / aapp;
+ }
+ temp1 *= scalem;
+ dlascl_("G", &c__0, &c__0, &aapp, &temp1, m, n, &a[a_offset], lda, &ierr);
+
+/* To undo scaling at the end of this procedure, multiply the */
+/* computed singular values with USCAL2 / USCAL1. */
+
+ uscal1 = temp1;
+ uscal2 = aapp;
+
+ if (l2kill) {
+/* L2KILL enforces computation of nonzero singular values in */
+/* the restricted range of condition number of the initial A, */
+/* sigma_max(A) / sigma_min(A) approx. DSQRT(BIG)/DSQRT(SFMIN). */
+ xsc = sqrt(sfmin);
+ } else {
+ xsc = small;
+
+/* Now, if the condition number of A is too big, */
+/* sigma_max(A) / sigma_min(A) .GT. DSQRT(BIG/N) * EPSLN / SFMIN, */
+/* as a precaution measure, the full SVD is computed using DGESVJ */
+/* with accumulated Jacobi rotations. This provides numerically */
+/* more robust computation, at the cost of slightly increased run */
+/* time. Depending on the concrete implementation of BLAS and LAPACK */
+/* (i.e. how they behave in presence of extreme ill-conditioning) the */
+/* implementor may decide to remove this switch. */
+ if (aaqq < sqrt(sfmin) && lsvec && rsvec) {
+ jracc = TRUE_;
+ }
+
+ }
+ if (aaqq < xsc) {
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ if (sva[p] < xsc) {
+ dlaset_("A", m, &c__1, &c_b34, &c_b34, &a[p * a_dim1 + 1],
+ lda);
+ sva[p] = 0.;
+ }
+/* L700: */
+ }
+ }
+
+/* Preconditioning using QR factorization with pivoting */
+
+ if (rowpiv) {
+/* Optional row permutation (Bjoerck row pivoting): */
+/* A result by Cox and Higham shows that the Bjoerck's */
+/* row pivoting combined with standard column pivoting */
+/* has similar effect as Powell-Reid complete pivoting. */
+/* The ell-infinity norms of A are made nonincreasing. */
+ i__1 = *m - 1;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = *m - p + 1;
+ q = idamax_(&i__2, &work[*m + *n + p], &c__1) + p - 1;
+ iwork[(*n << 1) + p] = q;
+ if (p != q) {
+ temp1 = work[*m + *n + p];
+ work[*m + *n + p] = work[*m + *n + q];
+ work[*m + *n + q] = temp1;
+ }
+/* L1952: */
+ }
+ i__1 = *m - 1;
+ dlaswp_(n, &a[a_offset], lda, &c__1, &i__1, &iwork[(*n << 1) + 1], &
+ c__1);
+ }
+
+/* End of the preparation phase (scaling, optional sorting and */
+/* transposing, optional flushing of small columns). */
+
+/* Preconditioning */
+
+/* If the full SVD is needed, the right singular vectors are computed */
+/* from a matrix equation, and for that we need theoretical analysis */
+/* of the Businger-Golub pivoting. So we use DGEQP3 as the first RR QRF. */
+/* In all other cases the first RR QRF can be chosen by other criteria */
+/* (eg speed by replacing global with restricted window pivoting, such */
+/* as in SGEQPX from TOMS # 782). Good results will be obtained using */
+/* SGEQPX with properly (!) chosen numerical parameters. */
+/* Any improvement of DGEQP3 improves overal performance of DGEJSV. */
+
+/* A * P1 = Q1 * [ R1^t 0]^t: */
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+/* .. all columns are free columns */
+ iwork[p] = 0;
+/* L1963: */
+ }
+ i__1 = *lwork - *n;
+ dgeqp3_(m, n, &a[a_offset], lda, &iwork[1], &work[1], &work[*n + 1], &
+ i__1, &ierr);
+
+/* The upper triangular matrix R1 from the first QRF is inspected for */
+/* rank deficiency and possibilities for deflation, or possible */
+/* ill-conditioning. Depending on the user specified flag L2RANK, */
+/* the procedure explores possibilities to reduce the numerical */
+/* rank by inspecting the computed upper triangular factor. If */
+/* L2RANK or L2ABER are up, then DGEJSV will compute the SVD of */
+/* A + dA, where ||dA|| <= f(M,N)*EPSLN. */
+
+ nr = 1;
+ if (l2aber) {
+/* Standard absolute error bound suffices. All sigma_i with */
+/* sigma_i < N*EPSLN*||A|| are flushed to zero. This is an */
+/* agressive enforcement of lower numerical rank by introducing a */
+/* backward error of the order of N*EPSLN*||A||. */
+ temp1 = sqrt((doublereal) (*n)) * epsln;
+ i__1 = *n;
+ for (p = 2; p <= i__1; ++p) {
+ if ((d__2 = a[p + p * a_dim1], abs(d__2)) >= temp1 * (d__1 = a[
+ a_dim1 + 1], abs(d__1))) {
+ ++nr;
+ } else {
+ goto L3002;
+ }
+/* L3001: */
+ }
+L3002:
+ ;
+ } else if (l2rank) {
+/* .. similarly as above, only slightly more gentle (less agressive). */
+/* Sudden drop on the diagonal of R1 is used as the criterion for */
+/* close-to-rank-defficient. */
+ temp1 = sqrt(sfmin);
+ i__1 = *n;
+ for (p = 2; p <= i__1; ++p) {
+ if ((d__2 = a[p + p * a_dim1], abs(d__2)) < epsln * (d__1 = a[p -
+ 1 + (p - 1) * a_dim1], abs(d__1)) || (d__3 = a[p + p *
+ a_dim1], abs(d__3)) < small || l2kill && (d__4 = a[p + p *
+ a_dim1], abs(d__4)) < temp1) {
+ goto L3402;
+ }
+ ++nr;
+/* L3401: */
+ }
+L3402:
+
+ ;
+ } else {
+/* The goal is high relative accuracy. However, if the matrix */
+/* has high scaled condition number the relative accuracy is in */
+/* general not feasible. Later on, a condition number estimator */
+/* will be deployed to estimate the scaled condition number. */
+/* Here we just remove the underflowed part of the triangular */
+/* factor. This prevents the situation in which the code is */
+/* working hard to get the accuracy not warranted by the data. */
+ temp1 = sqrt(sfmin);
+ i__1 = *n;
+ for (p = 2; p <= i__1; ++p) {
+ if ((d__1 = a[p + p * a_dim1], abs(d__1)) < small || l2kill && (
+ d__2 = a[p + p * a_dim1], abs(d__2)) < temp1) {
+ goto L3302;
+ }
+ ++nr;
+/* L3301: */
+ }
+L3302:
+
+ ;
+ }
+
+ almort = FALSE_;
+ if (nr == *n) {
+ maxprj = 1.;
+ i__1 = *n;
+ for (p = 2; p <= i__1; ++p) {
+ temp1 = (d__1 = a[p + p * a_dim1], abs(d__1)) / sva[iwork[p]];
+ maxprj = min(maxprj,temp1);
+/* L3051: */
+ }
+/* Computing 2nd power */
+ d__1 = maxprj;
+ if (d__1 * d__1 >= 1. - (doublereal) (*n) * epsln) {
+ almort = TRUE_;
+ }
+ }
+
+
+ sconda = -1.;
+ condr1 = -1.;
+ condr2 = -1.;
+
+ if (errest) {
+ if (*n == nr) {
+ if (rsvec) {
+/* .. V is available as workspace */
+ dlacpy_("U", n, n, &a[a_offset], lda, &v[v_offset], ldv);
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ temp1 = sva[iwork[p]];
+ d__1 = 1. / temp1;
+ dscal_(&p, &d__1, &v[p * v_dim1 + 1], &c__1);
+/* L3053: */
+ }
+ dpocon_("U", n, &v[v_offset], ldv, &c_b35, &temp1, &work[*n +
+ 1], &iwork[(*n << 1) + *m + 1], &ierr);
+ } else if (lsvec) {
+/* .. U is available as workspace */
+ dlacpy_("U", n, n, &a[a_offset], lda, &u[u_offset], ldu);
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ temp1 = sva[iwork[p]];
+ d__1 = 1. / temp1;
+ dscal_(&p, &d__1, &u[p * u_dim1 + 1], &c__1);
+/* L3054: */
+ }
+ dpocon_("U", n, &u[u_offset], ldu, &c_b35, &temp1, &work[*n +
+ 1], &iwork[(*n << 1) + *m + 1], &ierr);
+ } else {
+ dlacpy_("U", n, n, &a[a_offset], lda, &work[*n + 1], n);
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ temp1 = sva[iwork[p]];
+ d__1 = 1. / temp1;
+ dscal_(&p, &d__1, &work[*n + (p - 1) * *n + 1], &c__1);
+/* L3052: */
+ }
+/* .. the columns of R are scaled to have unit Euclidean lengths. */
+ dpocon_("U", n, &work[*n + 1], n, &c_b35, &temp1, &work[*n + *
+ n * *n + 1], &iwork[(*n << 1) + *m + 1], &ierr);
+ }
+ sconda = 1. / sqrt(temp1);
+/* SCONDA is an estimate of DSQRT(||(R^t * R)^(-1)||_1). */
+/* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA */
+ } else {
+ sconda = -1.;
+ }
+ }
+
+ l2pert = l2pert && (d__1 = a[a_dim1 + 1] / a[nr + nr * a_dim1], abs(d__1))
+ > sqrt(big1);
+/* If there is no violent scaling, artificial perturbation is not needed. */
+
+/* Phase 3: */
+
+ if (! (rsvec || lsvec)) {
+
+/* Singular Values only */
+
+/* .. transpose A(1:NR,1:N) */
+/* Computing MIN */
+ i__2 = *n - 1;
+ i__1 = min(i__2,nr);
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = *n - p;
+ dcopy_(&i__2, &a[p + (p + 1) * a_dim1], lda, &a[p + 1 + p *
+ a_dim1], &c__1);
+/* L1946: */
+ }
+
+/* The following two DO-loops introduce small relative perturbation */
+/* into the strict upper triangle of the lower triangular matrix. */
+/* Small entries below the main diagonal are also changed. */
+/* This modification is useful if the computing environment does not */
+/* provide/allow FLUSH TO ZERO underflow, for it prevents many */
+/* annoying denormalized numbers in case of strongly scaled matrices. */
+/* The perturbation is structured so that it does not introduce any */
+/* new perturbation of the singular values, and it does not destroy */
+/* the job done by the preconditioner. */
+/* The licence for this perturbation is in the variable L2PERT, which */
+/* should be .FALSE. if FLUSH TO ZERO underflow is active. */
+
+ if (! almort) {
+
+ if (l2pert) {
+/* XSC = DSQRT(SMALL) */
+ xsc = epsln / (doublereal) (*n);
+ i__1 = nr;
+ for (q = 1; q <= i__1; ++q) {
+ temp1 = xsc * (d__1 = a[q + q * a_dim1], abs(d__1));
+ i__2 = *n;
+ for (p = 1; p <= i__2; ++p) {
+ if (p > q && (d__1 = a[p + q * a_dim1], abs(d__1)) <=
+ temp1 || p < q) {
+ a[p + q * a_dim1] = d_sign(&temp1, &a[p + q *
+ a_dim1]);
+ }
+/* L4949: */
+ }
+/* L4947: */
+ }
+ } else {
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ dlaset_("U", &i__1, &i__2, &c_b34, &c_b34, &a[(a_dim1 << 1) +
+ 1], lda);
+ }
+
+/* .. second preconditioning using the QR factorization */
+
+ i__1 = *lwork - *n;
+ dgeqrf_(n, &nr, &a[a_offset], lda, &work[1], &work[*n + 1], &i__1,
+ &ierr);
+
+/* .. and transpose upper to lower triangular */
+ i__1 = nr - 1;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = nr - p;
+ dcopy_(&i__2, &a[p + (p + 1) * a_dim1], lda, &a[p + 1 + p *
+ a_dim1], &c__1);
+/* L1948: */
+ }
+
+ }
+
+/* Row-cyclic Jacobi SVD algorithm with column pivoting */
+
+/* .. again some perturbation (a "background noise") is added */
+/* to drown denormals */
+ if (l2pert) {
+/* XSC = DSQRT(SMALL) */
+ xsc = epsln / (doublereal) (*n);
+ i__1 = nr;
+ for (q = 1; q <= i__1; ++q) {
+ temp1 = xsc * (d__1 = a[q + q * a_dim1], abs(d__1));
+ i__2 = nr;
+ for (p = 1; p <= i__2; ++p) {
+ if (p > q && (d__1 = a[p + q * a_dim1], abs(d__1)) <=
+ temp1 || p < q) {
+ a[p + q * a_dim1] = d_sign(&temp1, &a[p + q * a_dim1])
+ ;
+ }
+/* L1949: */
+ }
+/* L1947: */
+ }
+ } else {
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ dlaset_("U", &i__1, &i__2, &c_b34, &c_b34, &a[(a_dim1 << 1) + 1],
+ lda);
+ }
+
+/* .. and one-sided Jacobi rotations are started on a lower */
+/* triangular matrix (plus perturbation which is ignored in */
+/* the part which destroys triangular form (confusing?!)) */
+
+ dgesvj_("L", "NoU", "NoV", &nr, &nr, &a[a_offset], lda, &sva[1], n, &
+ v[v_offset], ldv, &work[1], lwork, info);
+
+ scalem = work[1];
+ numrank = i_dnnt(&work[2]);
+
+
+ } else if (rsvec && ! lsvec) {
+
+/* -> Singular Values and Right Singular Vectors <- */
+
+ if (almort) {
+
+/* .. in this case NR equals N */
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = *n - p + 1;
+ dcopy_(&i__2, &a[p + p * a_dim1], lda, &v[p + p * v_dim1], &
+ c__1);
+/* L1998: */
+ }
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ dlaset_("Upper", &i__1, &i__2, &c_b34, &c_b34, &v[(v_dim1 << 1) +
+ 1], ldv);
+
+ dgesvj_("L", "U", "N", n, &nr, &v[v_offset], ldv, &sva[1], &nr, &
+ a[a_offset], lda, &work[1], lwork, info);
+ scalem = work[1];
+ numrank = i_dnnt(&work[2]);
+ } else {
+
+/* .. two more QR factorizations ( one QRF is not enough, two require */
+/* accumulated product of Jacobi rotations, three are perfect ) */
+
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ dlaset_("Lower", &i__1, &i__2, &c_b34, &c_b34, &a[a_dim1 + 2],
+ lda);
+ i__1 = *lwork - *n;
+ dgelqf_(&nr, n, &a[a_offset], lda, &work[1], &work[*n + 1], &i__1,
+ &ierr);
+ dlacpy_("Lower", &nr, &nr, &a[a_offset], lda, &v[v_offset], ldv);
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ dlaset_("Upper", &i__1, &i__2, &c_b34, &c_b34, &v[(v_dim1 << 1) +
+ 1], ldv);
+ i__1 = *lwork - (*n << 1);
+ dgeqrf_(&nr, &nr, &v[v_offset], ldv, &work[*n + 1], &work[(*n <<
+ 1) + 1], &i__1, &ierr);
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = nr - p + 1;
+ dcopy_(&i__2, &v[p + p * v_dim1], ldv, &v[p + p * v_dim1], &
+ c__1);
+/* L8998: */
+ }
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ dlaset_("Upper", &i__1, &i__2, &c_b34, &c_b34, &v[(v_dim1 << 1) +
+ 1], ldv);
+
+ dgesvj_("Lower", "U", "N", &nr, &nr, &v[v_offset], ldv, &sva[1], &
+ nr, &u[u_offset], ldu, &work[*n + 1], lwork, info);
+ scalem = work[*n + 1];
+ numrank = i_dnnt(&work[*n + 2]);
+ if (nr < *n) {
+ i__1 = *n - nr;
+ dlaset_("A", &i__1, &nr, &c_b34, &c_b34, &v[nr + 1 + v_dim1],
+ ldv);
+ i__1 = *n - nr;
+ dlaset_("A", &nr, &i__1, &c_b34, &c_b34, &v[(nr + 1) * v_dim1
+ + 1], ldv);
+ i__1 = *n - nr;
+ i__2 = *n - nr;
+ dlaset_("A", &i__1, &i__2, &c_b34, &c_b35, &v[nr + 1 + (nr +
+ 1) * v_dim1], ldv);
+ }
+
+ i__1 = *lwork - *n;
+ dormlq_("Left", "Transpose", n, n, &nr, &a[a_offset], lda, &work[
+ 1], &v[v_offset], ldv, &work[*n + 1], &i__1, &ierr);
+
+ }
+
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ dcopy_(n, &v[p + v_dim1], ldv, &a[iwork[p] + a_dim1], lda);
+/* L8991: */
+ }
+ dlacpy_("All", n, n, &a[a_offset], lda, &v[v_offset], ldv);
+
+ if (transp) {
+ dlacpy_("All", n, n, &v[v_offset], ldv, &u[u_offset], ldu);
+ }
+
+ } else if (lsvec && ! rsvec) {
+
+/* -#- Singular Values and Left Singular Vectors -#- */
+
+/* .. second preconditioning step to avoid need to accumulate */
+/* Jacobi rotations in the Jacobi iterations. */
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = *n - p + 1;
+ dcopy_(&i__2, &a[p + p * a_dim1], lda, &u[p + p * u_dim1], &c__1);
+/* L1965: */
+ }
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ dlaset_("Upper", &i__1, &i__2, &c_b34, &c_b34, &u[(u_dim1 << 1) + 1],
+ ldu);
+
+ i__1 = *lwork - (*n << 1);
+ dgeqrf_(n, &nr, &u[u_offset], ldu, &work[*n + 1], &work[(*n << 1) + 1]
+, &i__1, &ierr);
+
+ i__1 = nr - 1;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = nr - p;
+ dcopy_(&i__2, &u[p + (p + 1) * u_dim1], ldu, &u[p + 1 + p *
+ u_dim1], &c__1);
+/* L1967: */
+ }
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ dlaset_("Upper", &i__1, &i__2, &c_b34, &c_b34, &u[(u_dim1 << 1) + 1],
+ ldu);
+
+ i__1 = *lwork - *n;
+ dgesvj_("Lower", "U", "N", &nr, &nr, &u[u_offset], ldu, &sva[1], &nr,
+ &a[a_offset], lda, &work[*n + 1], &i__1, info);
+ scalem = work[*n + 1];
+ numrank = i_dnnt(&work[*n + 2]);
+
+ if (nr < *m) {
+ i__1 = *m - nr;
+ dlaset_("A", &i__1, &nr, &c_b34, &c_b34, &u[nr + 1 + u_dim1], ldu);
+ if (nr < n1) {
+ i__1 = n1 - nr;
+ dlaset_("A", &nr, &i__1, &c_b34, &c_b34, &u[(nr + 1) * u_dim1
+ + 1], ldu);
+ i__1 = *m - nr;
+ i__2 = n1 - nr;
+ dlaset_("A", &i__1, &i__2, &c_b34, &c_b35, &u[nr + 1 + (nr +
+ 1) * u_dim1], ldu);
+ }
+ }
+
+ i__1 = *lwork - *n;
+ dormqr_("Left", "No Tr", m, &n1, n, &a[a_offset], lda, &work[1], &u[
+ u_offset], ldu, &work[*n + 1], &i__1, &ierr);
+
+ if (rowpiv) {
+ i__1 = *m - 1;
+ dlaswp_(&n1, &u[u_offset], ldu, &c__1, &i__1, &iwork[(*n << 1) +
+ 1], &c_n1);
+ }
+
+ i__1 = n1;
+ for (p = 1; p <= i__1; ++p) {
+ xsc = 1. / dnrm2_(m, &u[p * u_dim1 + 1], &c__1);
+ dscal_(m, &xsc, &u[p * u_dim1 + 1], &c__1);
+/* L1974: */
+ }
+
+ if (transp) {
+ dlacpy_("All", n, n, &u[u_offset], ldu, &v[v_offset], ldv);
+ }
+
+ } else {
+
+/* -#- Full SVD -#- */
+
+ if (! jracc) {
+
+ if (! almort) {
+
+/* Second Preconditioning Step (QRF [with pivoting]) */
+/* Note that the composition of TRANSPOSE, QRF and TRANSPOSE is */
+/* equivalent to an LQF CALL. Since in many libraries the QRF */
+/* seems to be better optimized than the LQF, we do explicit */
+/* transpose and use the QRF. This is subject to changes in an */
+/* optimized implementation of DGEJSV. */
+
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = *n - p + 1;
+ dcopy_(&i__2, &a[p + p * a_dim1], lda, &v[p + p * v_dim1],
+ &c__1);
+/* L1968: */
+ }
+
+/* .. the following two loops perturb small entries to avoid */
+/* denormals in the second QR factorization, where they are */
+/* as good as zeros. This is done to avoid painfully slow */
+/* computation with denormals. The relative size of the perturbation */
+/* is a parameter that can be changed by the implementer. */
+/* This perturbation device will be obsolete on machines with */
+/* properly implemented arithmetic. */
+/* To switch it off, set L2PERT=.FALSE. To remove it from the */
+/* code, remove the action under L2PERT=.TRUE., leave the ELSE part. */
+/* The following two loops should be blocked and fused with the */
+/* transposed copy above. */
+
+ if (l2pert) {
+ xsc = sqrt(small);
+ i__1 = nr;
+ for (q = 1; q <= i__1; ++q) {
+ temp1 = xsc * (d__1 = v[q + q * v_dim1], abs(d__1));
+ i__2 = *n;
+ for (p = 1; p <= i__2; ++p) {
+ if (p > q && (d__1 = v[p + q * v_dim1], abs(d__1))
+ <= temp1 || p < q) {
+ v[p + q * v_dim1] = d_sign(&temp1, &v[p + q *
+ v_dim1]);
+ }
+ if (p < q) {
+ v[p + q * v_dim1] = -v[p + q * v_dim1];
+ }
+/* L2968: */
+ }
+/* L2969: */
+ }
+ } else {
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ dlaset_("U", &i__1, &i__2, &c_b34, &c_b34, &v[(v_dim1 <<
+ 1) + 1], ldv);
+ }
+
+/* Estimate the row scaled condition number of R1 */
+/* (If R1 is rectangular, N > NR, then the condition number */
+/* of the leading NR x NR submatrix is estimated.) */
+
+ dlacpy_("L", &nr, &nr, &v[v_offset], ldv, &work[(*n << 1) + 1]
+, &nr);
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = nr - p + 1;
+ temp1 = dnrm2_(&i__2, &work[(*n << 1) + (p - 1) * nr + p],
+ &c__1);
+ i__2 = nr - p + 1;
+ d__1 = 1. / temp1;
+ dscal_(&i__2, &d__1, &work[(*n << 1) + (p - 1) * nr + p],
+ &c__1);
+/* L3950: */
+ }
+ dpocon_("Lower", &nr, &work[(*n << 1) + 1], &nr, &c_b35, &
+ temp1, &work[(*n << 1) + nr * nr + 1], &iwork[*m + (*
+ n << 1) + 1], &ierr);
+ condr1 = 1. / sqrt(temp1);
+/* .. here need a second oppinion on the condition number */
+/* .. then assume worst case scenario */
+/* R1 is OK for inverse <=> CONDR1 .LT. DBLE(N) */
+/* more conservative <=> CONDR1 .LT. DSQRT(DBLE(N)) */
+
+ cond_ok__ = sqrt((doublereal) nr);
+/* [TP] COND_OK is a tuning parameter. */
+ if (condr1 < cond_ok__) {
+/* .. the second QRF without pivoting. Note: in an optimized */
+/* implementation, this QRF should be implemented as the QRF */
+/* of a lower triangular matrix. */
+/* R1^t = Q2 * R2 */
+ i__1 = *lwork - (*n << 1);
+ dgeqrf_(n, &nr, &v[v_offset], ldv, &work[*n + 1], &work[(*
+ n << 1) + 1], &i__1, &ierr);
+
+ if (l2pert) {
+ xsc = sqrt(small) / epsln;
+ i__1 = nr;
+ for (p = 2; p <= i__1; ++p) {
+ i__2 = p - 1;
+ for (q = 1; q <= i__2; ++q) {
+/* Computing MIN */
+ d__3 = (d__1 = v[p + p * v_dim1], abs(d__1)),
+ d__4 = (d__2 = v[q + q * v_dim1], abs(
+ d__2));
+ temp1 = xsc * min(d__3,d__4);
+ if ((d__1 = v[q + p * v_dim1], abs(d__1)) <=
+ temp1) {
+ v[q + p * v_dim1] = d_sign(&temp1, &v[q +
+ p * v_dim1]);
+ }
+/* L3958: */
+ }
+/* L3959: */
+ }
+ }
+
+ if (nr != *n) {
+ dlacpy_("A", n, &nr, &v[v_offset], ldv, &work[(*n <<
+ 1) + 1], n);
+ }
+/* .. save ... */
+
+/* .. this transposed copy should be better than naive */
+ i__1 = nr - 1;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = nr - p;
+ dcopy_(&i__2, &v[p + (p + 1) * v_dim1], ldv, &v[p + 1
+ + p * v_dim1], &c__1);
+/* L1969: */
+ }
+
+ condr2 = condr1;
+
+ } else {
+
+/* .. ill-conditioned case: second QRF with pivoting */
+/* Note that windowed pivoting would be equaly good */
+/* numerically, and more run-time efficient. So, in */
+/* an optimal implementation, the next call to DGEQP3 */
+/* should be replaced with eg. CALL SGEQPX (ACM TOMS #782) */
+/* with properly (carefully) chosen parameters. */
+
+/* R1^t * P2 = Q2 * R2 */
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ iwork[*n + p] = 0;
+/* L3003: */
+ }
+ i__1 = *lwork - (*n << 1);
+ dgeqp3_(n, &nr, &v[v_offset], ldv, &iwork[*n + 1], &work[*
+ n + 1], &work[(*n << 1) + 1], &i__1, &ierr);
+/* * CALL DGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1), */
+/* * & LWORK-2*N, IERR ) */
+ if (l2pert) {
+ xsc = sqrt(small);
+ i__1 = nr;
+ for (p = 2; p <= i__1; ++p) {
+ i__2 = p - 1;
+ for (q = 1; q <= i__2; ++q) {
+/* Computing MIN */
+ d__3 = (d__1 = v[p + p * v_dim1], abs(d__1)),
+ d__4 = (d__2 = v[q + q * v_dim1], abs(
+ d__2));
+ temp1 = xsc * min(d__3,d__4);
+ if ((d__1 = v[q + p * v_dim1], abs(d__1)) <=
+ temp1) {
+ v[q + p * v_dim1] = d_sign(&temp1, &v[q +
+ p * v_dim1]);
+ }
+/* L3968: */
+ }
+/* L3969: */
+ }
+ }
+
+ dlacpy_("A", n, &nr, &v[v_offset], ldv, &work[(*n << 1) +
+ 1], n);
+
+ if (l2pert) {
+ xsc = sqrt(small);
+ i__1 = nr;
+ for (p = 2; p <= i__1; ++p) {
+ i__2 = p - 1;
+ for (q = 1; q <= i__2; ++q) {
+/* Computing MIN */
+ d__3 = (d__1 = v[p + p * v_dim1], abs(d__1)),
+ d__4 = (d__2 = v[q + q * v_dim1], abs(
+ d__2));
+ temp1 = xsc * min(d__3,d__4);
+ v[p + q * v_dim1] = -d_sign(&temp1, &v[q + p *
+ v_dim1]);
+/* L8971: */
+ }
+/* L8970: */
+ }
+ } else {
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ dlaset_("L", &i__1, &i__2, &c_b34, &c_b34, &v[v_dim1
+ + 2], ldv);
+ }
+/* Now, compute R2 = L3 * Q3, the LQ factorization. */
+ i__1 = *lwork - (*n << 1) - *n * nr - nr;
+ dgelqf_(&nr, &nr, &v[v_offset], ldv, &work[(*n << 1) + *n
+ * nr + 1], &work[(*n << 1) + *n * nr + nr + 1], &
+ i__1, &ierr);
+/* .. and estimate the condition number */
+ dlacpy_("L", &nr, &nr, &v[v_offset], ldv, &work[(*n << 1)
+ + *n * nr + nr + 1], &nr);
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ temp1 = dnrm2_(&p, &work[(*n << 1) + *n * nr + nr + p]
+, &nr);
+ d__1 = 1. / temp1;
+ dscal_(&p, &d__1, &work[(*n << 1) + *n * nr + nr + p],
+ &nr);
+/* L4950: */
+ }
+ dpocon_("L", &nr, &work[(*n << 1) + *n * nr + nr + 1], &
+ nr, &c_b35, &temp1, &work[(*n << 1) + *n * nr +
+ nr + nr * nr + 1], &iwork[*m + (*n << 1) + 1], &
+ ierr);
+ condr2 = 1. / sqrt(temp1);
+
+ if (condr2 >= cond_ok__) {
+/* .. save the Householder vectors used for Q3 */
+/* (this overwrittes the copy of R2, as it will not be */
+/* needed in this branch, but it does not overwritte the */
+/* Huseholder vectors of Q2.). */
+ dlacpy_("U", &nr, &nr, &v[v_offset], ldv, &work[(*n <<
+ 1) + 1], n);
+/* .. and the rest of the information on Q3 is in */
+/* WORK(2*N+N*NR+1:2*N+N*NR+N) */
+ }
+
+ }
+
+ if (l2pert) {
+ xsc = sqrt(small);
+ i__1 = nr;
+ for (q = 2; q <= i__1; ++q) {
+ temp1 = xsc * v[q + q * v_dim1];
+ i__2 = q - 1;
+ for (p = 1; p <= i__2; ++p) {
+/* V(p,q) = - DSIGN( TEMP1, V(q,p) ) */
+ v[p + q * v_dim1] = -d_sign(&temp1, &v[p + q *
+ v_dim1]);
+/* L4969: */
+ }
+/* L4968: */
+ }
+ } else {
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ dlaset_("U", &i__1, &i__2, &c_b34, &c_b34, &v[(v_dim1 <<
+ 1) + 1], ldv);
+ }
+
+/* Second preconditioning finished; continue with Jacobi SVD */
+/* The input matrix is lower trinagular. */
+
+/* Recover the right singular vectors as solution of a well */
+/* conditioned triangular matrix equation. */
+
+ if (condr1 < cond_ok__) {
+
+ i__1 = *lwork - (*n << 1) - *n * nr - nr;
+ dgesvj_("L", "U", "N", &nr, &nr, &v[v_offset], ldv, &sva[
+ 1], &nr, &u[u_offset], ldu, &work[(*n << 1) + *n *
+ nr + nr + 1], &i__1, info);
+ scalem = work[(*n << 1) + *n * nr + nr + 1];
+ numrank = i_dnnt(&work[(*n << 1) + *n * nr + nr + 2]);
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ dcopy_(&nr, &v[p * v_dim1 + 1], &c__1, &u[p * u_dim1
+ + 1], &c__1);
+ dscal_(&nr, &sva[p], &v[p * v_dim1 + 1], &c__1);
+/* L3970: */
+ }
+/* .. pick the right matrix equation and solve it */
+
+ if (nr == *n) {
+/* :)) .. best case, R1 is inverted. The solution of this matrix */
+/* equation is Q2*V2 = the product of the Jacobi rotations */
+/* used in DGESVJ, premultiplied with the orthogonal matrix */
+/* from the second QR factorization. */
+ dtrsm_("L", "U", "N", "N", &nr, &nr, &c_b35, &a[
+ a_offset], lda, &v[v_offset], ldv);
+ } else {
+/* .. R1 is well conditioned, but non-square. Transpose(R2) */
+/* is inverted to get the product of the Jacobi rotations */
+/* used in DGESVJ. The Q-factor from the second QR */
+/* factorization is then built in explicitly. */
+ dtrsm_("L", "U", "T", "N", &nr, &nr, &c_b35, &work[(*
+ n << 1) + 1], n, &v[v_offset], ldv);
+ if (nr < *n) {
+ i__1 = *n - nr;
+ dlaset_("A", &i__1, &nr, &c_b34, &c_b34, &v[nr +
+ 1 + v_dim1], ldv);
+ i__1 = *n - nr;
+ dlaset_("A", &nr, &i__1, &c_b34, &c_b34, &v[(nr +
+ 1) * v_dim1 + 1], ldv);
+ i__1 = *n - nr;
+ i__2 = *n - nr;
+ dlaset_("A", &i__1, &i__2, &c_b34, &c_b35, &v[nr
+ + 1 + (nr + 1) * v_dim1], ldv);
+ }
+ i__1 = *lwork - (*n << 1) - *n * nr - nr;
+ dormqr_("L", "N", n, n, &nr, &work[(*n << 1) + 1], n,
+ &work[*n + 1], &v[v_offset], ldv, &work[(*n <<
+ 1) + *n * nr + nr + 1], &i__1, &ierr);
+ }
+
+ } else if (condr2 < cond_ok__) {
+
+/* :) .. the input matrix A is very likely a relative of */
+/* the Kahan matrix :) */
+/* The matrix R2 is inverted. The solution of the matrix equation */
+/* is Q3^T*V3 = the product of the Jacobi rotations (appplied to */
+/* the lower triangular L3 from the LQ factorization of */
+/* R2=L3*Q3), pre-multiplied with the transposed Q3. */
+ i__1 = *lwork - (*n << 1) - *n * nr - nr;
+ dgesvj_("L", "U", "N", &nr, &nr, &v[v_offset], ldv, &sva[
+ 1], &nr, &u[u_offset], ldu, &work[(*n << 1) + *n *
+ nr + nr + 1], &i__1, info);
+ scalem = work[(*n << 1) + *n * nr + nr + 1];
+ numrank = i_dnnt(&work[(*n << 1) + *n * nr + nr + 2]);
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ dcopy_(&nr, &v[p * v_dim1 + 1], &c__1, &u[p * u_dim1
+ + 1], &c__1);
+ dscal_(&nr, &sva[p], &u[p * u_dim1 + 1], &c__1);
+/* L3870: */
+ }
+ dtrsm_("L", "U", "N", "N", &nr, &nr, &c_b35, &work[(*n <<
+ 1) + 1], n, &u[u_offset], ldu);
+/* .. apply the permutation from the second QR factorization */
+ i__1 = nr;
+ for (q = 1; q <= i__1; ++q) {
+ i__2 = nr;
+ for (p = 1; p <= i__2; ++p) {
+ work[(*n << 1) + *n * nr + nr + iwork[*n + p]] =
+ u[p + q * u_dim1];
+/* L872: */
+ }
+ i__2 = nr;
+ for (p = 1; p <= i__2; ++p) {
+ u[p + q * u_dim1] = work[(*n << 1) + *n * nr + nr
+ + p];
+/* L874: */
+ }
+/* L873: */
+ }
+ if (nr < *n) {
+ i__1 = *n - nr;
+ dlaset_("A", &i__1, &nr, &c_b34, &c_b34, &v[nr + 1 +
+ v_dim1], ldv);
+ i__1 = *n - nr;
+ dlaset_("A", &nr, &i__1, &c_b34, &c_b34, &v[(nr + 1) *
+ v_dim1 + 1], ldv);
+ i__1 = *n - nr;
+ i__2 = *n - nr;
+ dlaset_("A", &i__1, &i__2, &c_b34, &c_b35, &v[nr + 1
+ + (nr + 1) * v_dim1], ldv);
+ }
+ i__1 = *lwork - (*n << 1) - *n * nr - nr;
+ dormqr_("L", "N", n, n, &nr, &work[(*n << 1) + 1], n, &
+ work[*n + 1], &v[v_offset], ldv, &work[(*n << 1)
+ + *n * nr + nr + 1], &i__1, &ierr);
+ } else {
+/* Last line of defense. */
+/* #:( This is a rather pathological case: no scaled condition */
+/* improvement after two pivoted QR factorizations. Other */
+/* possibility is that the rank revealing QR factorization */
+/* or the condition estimator has failed, or the COND_OK */
+/* is set very close to ONE (which is unnecessary). Normally, */
+/* this branch should never be executed, but in rare cases of */
+/* failure of the RRQR or condition estimator, the last line of */
+/* defense ensures that DGEJSV completes the task. */
+/* Compute the full SVD of L3 using DGESVJ with explicit */
+/* accumulation of Jacobi rotations. */
+ i__1 = *lwork - (*n << 1) - *n * nr - nr;
+ dgesvj_("L", "U", "V", &nr, &nr, &v[v_offset], ldv, &sva[
+ 1], &nr, &u[u_offset], ldu, &work[(*n << 1) + *n *
+ nr + nr + 1], &i__1, info);
+ scalem = work[(*n << 1) + *n * nr + nr + 1];
+ numrank = i_dnnt(&work[(*n << 1) + *n * nr + nr + 2]);
+ if (nr < *n) {
+ i__1 = *n - nr;
+ dlaset_("A", &i__1, &nr, &c_b34, &c_b34, &v[nr + 1 +
+ v_dim1], ldv);
+ i__1 = *n - nr;
+ dlaset_("A", &nr, &i__1, &c_b34, &c_b34, &v[(nr + 1) *
+ v_dim1 + 1], ldv);
+ i__1 = *n - nr;
+ i__2 = *n - nr;
+ dlaset_("A", &i__1, &i__2, &c_b34, &c_b35, &v[nr + 1
+ + (nr + 1) * v_dim1], ldv);
+ }
+ i__1 = *lwork - (*n << 1) - *n * nr - nr;
+ dormqr_("L", "N", n, n, &nr, &work[(*n << 1) + 1], n, &
+ work[*n + 1], &v[v_offset], ldv, &work[(*n << 1)
+ + *n * nr + nr + 1], &i__1, &ierr);
+
+ i__1 = *lwork - (*n << 1) - *n * nr - nr;
+ dormlq_("L", "T", &nr, &nr, &nr, &work[(*n << 1) + 1], n,
+ &work[(*n << 1) + *n * nr + 1], &u[u_offset], ldu,
+ &work[(*n << 1) + *n * nr + nr + 1], &i__1, &
+ ierr);
+ i__1 = nr;
+ for (q = 1; q <= i__1; ++q) {
+ i__2 = nr;
+ for (p = 1; p <= i__2; ++p) {
+ work[(*n << 1) + *n * nr + nr + iwork[*n + p]] =
+ u[p + q * u_dim1];
+/* L772: */
+ }
+ i__2 = nr;
+ for (p = 1; p <= i__2; ++p) {
+ u[p + q * u_dim1] = work[(*n << 1) + *n * nr + nr
+ + p];
+/* L774: */
+ }
+/* L773: */
+ }
+
+ }
+
+/* Permute the rows of V using the (column) permutation from the */
+/* first QRF. Also, scale the columns to make them unit in */
+/* Euclidean norm. This applies to all cases. */
+
+ temp1 = sqrt((doublereal) (*n)) * epsln;
+ i__1 = *n;
+ for (q = 1; q <= i__1; ++q) {
+ i__2 = *n;
+ for (p = 1; p <= i__2; ++p) {
+ work[(*n << 1) + *n * nr + nr + iwork[p]] = v[p + q *
+ v_dim1];
+/* L972: */
+ }
+ i__2 = *n;
+ for (p = 1; p <= i__2; ++p) {
+ v[p + q * v_dim1] = work[(*n << 1) + *n * nr + nr + p]
+ ;
+/* L973: */
+ }
+ xsc = 1. / dnrm2_(n, &v[q * v_dim1 + 1], &c__1);
+ if (xsc < 1. - temp1 || xsc > temp1 + 1.) {
+ dscal_(n, &xsc, &v[q * v_dim1 + 1], &c__1);
+ }
+/* L1972: */
+ }
+/* At this moment, V contains the right singular vectors of A. */
+/* Next, assemble the left singular vector matrix U (M x N). */
+ if (nr < *m) {
+ i__1 = *m - nr;
+ dlaset_("A", &i__1, &nr, &c_b34, &c_b34, &u[nr + 1 +
+ u_dim1], ldu);
+ if (nr < n1) {
+ i__1 = n1 - nr;
+ dlaset_("A", &nr, &i__1, &c_b34, &c_b34, &u[(nr + 1) *
+ u_dim1 + 1], ldu);
+ i__1 = *m - nr;
+ i__2 = n1 - nr;
+ dlaset_("A", &i__1, &i__2, &c_b34, &c_b35, &u[nr + 1
+ + (nr + 1) * u_dim1], ldu);
+ }
+ }
+
+/* The Q matrix from the first QRF is built into the left singular */
+/* matrix U. This applies to all cases. */
+
+ i__1 = *lwork - *n;
+ dormqr_("Left", "No_Tr", m, &n1, n, &a[a_offset], lda, &work[
+ 1], &u[u_offset], ldu, &work[*n + 1], &i__1, &ierr);
+/* The columns of U are normalized. The cost is O(M*N) flops. */
+ temp1 = sqrt((doublereal) (*m)) * epsln;
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ xsc = 1. / dnrm2_(m, &u[p * u_dim1 + 1], &c__1);
+ if (xsc < 1. - temp1 || xsc > temp1 + 1.) {
+ dscal_(m, &xsc, &u[p * u_dim1 + 1], &c__1);
+ }
+/* L1973: */
+ }
+
+/* If the initial QRF is computed with row pivoting, the left */
+/* singular vectors must be adjusted. */
+
+ if (rowpiv) {
+ i__1 = *m - 1;
+ dlaswp_(&n1, &u[u_offset], ldu, &c__1, &i__1, &iwork[(*n
+ << 1) + 1], &c_n1);
+ }
+
+ } else {
+
+/* .. the initial matrix A has almost orthogonal columns and */
+/* the second QRF is not needed */
+
+ dlacpy_("Upper", n, n, &a[a_offset], lda, &work[*n + 1], n);
+ if (l2pert) {
+ xsc = sqrt(small);
+ i__1 = *n;
+ for (p = 2; p <= i__1; ++p) {
+ temp1 = xsc * work[*n + (p - 1) * *n + p];
+ i__2 = p - 1;
+ for (q = 1; q <= i__2; ++q) {
+ work[*n + (q - 1) * *n + p] = -d_sign(&temp1, &
+ work[*n + (p - 1) * *n + q]);
+/* L5971: */
+ }
+/* L5970: */
+ }
+ } else {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ dlaset_("Lower", &i__1, &i__2, &c_b34, &c_b34, &work[*n +
+ 2], n);
+ }
+
+ i__1 = *lwork - *n - *n * *n;
+ dgesvj_("Upper", "U", "N", n, n, &work[*n + 1], n, &sva[1], n,
+ &u[u_offset], ldu, &work[*n + *n * *n + 1], &i__1,
+ info);
+
+ scalem = work[*n + *n * *n + 1];
+ numrank = i_dnnt(&work[*n + *n * *n + 2]);
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ dcopy_(n, &work[*n + (p - 1) * *n + 1], &c__1, &u[p *
+ u_dim1 + 1], &c__1);
+ dscal_(n, &sva[p], &work[*n + (p - 1) * *n + 1], &c__1);
+/* L6970: */
+ }
+
+ dtrsm_("Left", "Upper", "NoTrans", "No UD", n, n, &c_b35, &a[
+ a_offset], lda, &work[*n + 1], n);
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ dcopy_(n, &work[*n + p], n, &v[iwork[p] + v_dim1], ldv);
+/* L6972: */
+ }
+ temp1 = sqrt((doublereal) (*n)) * epsln;
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ xsc = 1. / dnrm2_(n, &v[p * v_dim1 + 1], &c__1);
+ if (xsc < 1. - temp1 || xsc > temp1 + 1.) {
+ dscal_(n, &xsc, &v[p * v_dim1 + 1], &c__1);
+ }
+/* L6971: */
+ }
+
+/* Assemble the left singular vector matrix U (M x N). */
+
+ if (*n < *m) {
+ i__1 = *m - *n;
+ dlaset_("A", &i__1, n, &c_b34, &c_b34, &u[nr + 1 + u_dim1]
+, ldu);
+ if (*n < n1) {
+ i__1 = n1 - *n;
+ dlaset_("A", n, &i__1, &c_b34, &c_b34, &u[(*n + 1) *
+ u_dim1 + 1], ldu);
+ i__1 = *m - *n;
+ i__2 = n1 - *n;
+ dlaset_("A", &i__1, &i__2, &c_b34, &c_b35, &u[nr + 1
+ + (*n + 1) * u_dim1], ldu);
+ }
+ }
+ i__1 = *lwork - *n;
+ dormqr_("Left", "No Tr", m, &n1, n, &a[a_offset], lda, &work[
+ 1], &u[u_offset], ldu, &work[*n + 1], &i__1, &ierr);
+ temp1 = sqrt((doublereal) (*m)) * epsln;
+ i__1 = n1;
+ for (p = 1; p <= i__1; ++p) {
+ xsc = 1. / dnrm2_(m, &u[p * u_dim1 + 1], &c__1);
+ if (xsc < 1. - temp1 || xsc > temp1 + 1.) {
+ dscal_(m, &xsc, &u[p * u_dim1 + 1], &c__1);
+ }
+/* L6973: */
+ }
+
+ if (rowpiv) {
+ i__1 = *m - 1;
+ dlaswp_(&n1, &u[u_offset], ldu, &c__1, &i__1, &iwork[(*n
+ << 1) + 1], &c_n1);
+ }
+
+ }
+
+/* end of the >> almost orthogonal case << in the full SVD */
+
+ } else {
+
+/* This branch deploys a preconditioned Jacobi SVD with explicitly */
+/* accumulated rotations. It is included as optional, mainly for */
+/* experimental purposes. It does perfom well, and can also be used. */
+/* In this implementation, this branch will be automatically activated */
+/* if the condition number sigma_max(A) / sigma_min(A) is predicted */
+/* to be greater than the overflow threshold. This is because the */
+/* a posteriori computation of the singular vectors assumes robust */
+/* implementation of BLAS and some LAPACK procedures, capable of working */
+/* in presence of extreme values. Since that is not always the case, ... */
+
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = *n - p + 1;
+ dcopy_(&i__2, &a[p + p * a_dim1], lda, &v[p + p * v_dim1], &
+ c__1);
+/* L7968: */
+ }
+
+ if (l2pert) {
+ xsc = sqrt(small / epsln);
+ i__1 = nr;
+ for (q = 1; q <= i__1; ++q) {
+ temp1 = xsc * (d__1 = v[q + q * v_dim1], abs(d__1));
+ i__2 = *n;
+ for (p = 1; p <= i__2; ++p) {
+ if (p > q && (d__1 = v[p + q * v_dim1], abs(d__1)) <=
+ temp1 || p < q) {
+ v[p + q * v_dim1] = d_sign(&temp1, &v[p + q *
+ v_dim1]);
+ }
+ if (p < q) {
+ v[p + q * v_dim1] = -v[p + q * v_dim1];
+ }
+/* L5968: */
+ }
+/* L5969: */
+ }
+ } else {
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ dlaset_("U", &i__1, &i__2, &c_b34, &c_b34, &v[(v_dim1 << 1) +
+ 1], ldv);
+ }
+ i__1 = *lwork - (*n << 1);
+ dgeqrf_(n, &nr, &v[v_offset], ldv, &work[*n + 1], &work[(*n << 1)
+ + 1], &i__1, &ierr);
+ dlacpy_("L", n, &nr, &v[v_offset], ldv, &work[(*n << 1) + 1], n);
+
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = nr - p + 1;
+ dcopy_(&i__2, &v[p + p * v_dim1], ldv, &u[p + p * u_dim1], &
+ c__1);
+/* L7969: */
+ }
+ if (l2pert) {
+ xsc = sqrt(small / epsln);
+ i__1 = nr;
+ for (q = 2; q <= i__1; ++q) {
+ i__2 = q - 1;
+ for (p = 1; p <= i__2; ++p) {
+/* Computing MIN */
+ d__3 = (d__1 = u[p + p * u_dim1], abs(d__1)), d__4 = (
+ d__2 = u[q + q * u_dim1], abs(d__2));
+ temp1 = xsc * min(d__3,d__4);
+ u[p + q * u_dim1] = -d_sign(&temp1, &u[q + p * u_dim1]
+ );
+/* L9971: */
+ }
+/* L9970: */
+ }
+ } else {
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ dlaset_("U", &i__1, &i__2, &c_b34, &c_b34, &u[(u_dim1 << 1) +
+ 1], ldu);
+ }
+ i__1 = *lwork - (*n << 1) - *n * nr;
+ dgesvj_("G", "U", "V", &nr, &nr, &u[u_offset], ldu, &sva[1], n, &
+ v[v_offset], ldv, &work[(*n << 1) + *n * nr + 1], &i__1,
+ info);
+ scalem = work[(*n << 1) + *n * nr + 1];
+ numrank = i_dnnt(&work[(*n << 1) + *n * nr + 2]);
+ if (nr < *n) {
+ i__1 = *n - nr;
+ dlaset_("A", &i__1, &nr, &c_b34, &c_b34, &v[nr + 1 + v_dim1],
+ ldv);
+ i__1 = *n - nr;
+ dlaset_("A", &nr, &i__1, &c_b34, &c_b34, &v[(nr + 1) * v_dim1
+ + 1], ldv);
+ i__1 = *n - nr;
+ i__2 = *n - nr;
+ dlaset_("A", &i__1, &i__2, &c_b34, &c_b35, &v[nr + 1 + (nr +
+ 1) * v_dim1], ldv);
+ }
+ i__1 = *lwork - (*n << 1) - *n * nr - nr;
+ dormqr_("L", "N", n, n, &nr, &work[(*n << 1) + 1], n, &work[*n +
+ 1], &v[v_offset], ldv, &work[(*n << 1) + *n * nr + nr + 1]
+, &i__1, &ierr);
+
+/* Permute the rows of V using the (column) permutation from the */
+/* first QRF. Also, scale the columns to make them unit in */
+/* Euclidean norm. This applies to all cases. */
+
+ temp1 = sqrt((doublereal) (*n)) * epsln;
+ i__1 = *n;
+ for (q = 1; q <= i__1; ++q) {
+ i__2 = *n;
+ for (p = 1; p <= i__2; ++p) {
+ work[(*n << 1) + *n * nr + nr + iwork[p]] = v[p + q *
+ v_dim1];
+/* L8972: */
+ }
+ i__2 = *n;
+ for (p = 1; p <= i__2; ++p) {
+ v[p + q * v_dim1] = work[(*n << 1) + *n * nr + nr + p];
+/* L8973: */
+ }
+ xsc = 1. / dnrm2_(n, &v[q * v_dim1 + 1], &c__1);
+ if (xsc < 1. - temp1 || xsc > temp1 + 1.) {
+ dscal_(n, &xsc, &v[q * v_dim1 + 1], &c__1);
+ }
+/* L7972: */
+ }
+
+/* At this moment, V contains the right singular vectors of A. */
+/* Next, assemble the left singular vector matrix U (M x N). */
+
+ if (*n < *m) {
+ i__1 = *m - *n;
+ dlaset_("A", &i__1, n, &c_b34, &c_b34, &u[nr + 1 + u_dim1],
+ ldu);
+ if (*n < n1) {
+ i__1 = n1 - *n;
+ dlaset_("A", n, &i__1, &c_b34, &c_b34, &u[(*n + 1) *
+ u_dim1 + 1], ldu);
+ i__1 = *m - *n;
+ i__2 = n1 - *n;
+ dlaset_("A", &i__1, &i__2, &c_b34, &c_b35, &u[nr + 1 + (*
+ n + 1) * u_dim1], ldu);
+ }
+ }
+
+ i__1 = *lwork - *n;
+ dormqr_("Left", "No Tr", m, &n1, n, &a[a_offset], lda, &work[1], &
+ u[u_offset], ldu, &work[*n + 1], &i__1, &ierr);
+
+ if (rowpiv) {
+ i__1 = *m - 1;
+ dlaswp_(&n1, &u[u_offset], ldu, &c__1, &i__1, &iwork[(*n << 1)
+ + 1], &c_n1);
+ }
+
+
+ }
+ if (transp) {
+/* .. swap U and V because the procedure worked on A^t */
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ dswap_(n, &u[p * u_dim1 + 1], &c__1, &v[p * v_dim1 + 1], &
+ c__1);
+/* L6974: */
+ }
+ }
+
+ }
+/* end of the full SVD */
+
+/* Undo scaling, if necessary (and possible) */
+
+ if (uscal2 <= big / sva[1] * uscal1) {
+ dlascl_("G", &c__0, &c__0, &uscal1, &uscal2, &nr, &c__1, &sva[1], n, &
+ ierr);
+ uscal1 = 1.;
+ uscal2 = 1.;
+ }
+
+ if (nr < *n) {
+ i__1 = *n;
+ for (p = nr + 1; p <= i__1; ++p) {
+ sva[p] = 0.;
+/* L3004: */
+ }
+ }
+
+ work[1] = uscal2 * scalem;
+ work[2] = uscal1;
+ if (errest) {
+ work[3] = sconda;
+ }
+ if (lsvec && rsvec) {
+ work[4] = condr1;
+ work[5] = condr2;
+ }
+ if (l2tran) {
+ work[6] = entra;
+ work[7] = entrat;
+ }
+
+ iwork[1] = nr;
+ iwork[2] = numrank;
+ iwork[3] = warning;
+
+ return 0;
+/* .. */
+/* .. END OF DGEJSV */
+/* .. */
+} /* dgejsv_ */
diff --git a/SRC/dgelq2.c b/SRC/dgelq2.c
new file mode 100644
index 0000000..c77e5a8
--- /dev/null
+++ b/SRC/dgelq2.c
@@ -0,0 +1,157 @@
+/* dgelq2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgelq2_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *tau, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, k;
+ doublereal aii;
+ extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *), dlarfp_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGELQ2 computes an LQ factorization of a real m by n matrix A: */
+/* A = L * Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the m by n matrix A. */
+/* On exit, the elements on and below the diagonal of the array */
+/* contain the m by min(m,n) lower trapezoidal matrix L (L is */
+/* lower triangular if m <= n); the elements above the diagonal, */
+/* with the array TAU, represent the orthogonal matrix Q as a */
+/* product of elementary reflectors (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), */
+/* and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGELQ2", &i__1);
+ return 0;
+ }
+
+ k = min(*m,*n);
+
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Generate elementary reflector H(i) to annihilate A(i,i+1:n) */
+
+ i__2 = *n - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ dlarfp_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3, *n)* a_dim1]
+, lda, &tau[i__]);
+ if (i__ < *m) {
+
+/* Apply H(i) to A(i+1:m,i:n) from the right */
+
+ aii = a[i__ + i__ * a_dim1];
+ a[i__ + i__ * a_dim1] = 1.;
+ i__2 = *m - i__;
+ i__3 = *n - i__ + 1;
+ dlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[
+ i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]);
+ a[i__ + i__ * a_dim1] = aii;
+ }
+/* L10: */
+ }
+ return 0;
+
+/* End of DGELQ2 */
+
+} /* dgelq2_ */
diff --git a/SRC/dgelqf.c b/SRC/dgelqf.c
new file mode 100644
index 0000000..08bc818
--- /dev/null
+++ b/SRC/dgelqf.c
@@ -0,0 +1,251 @@
+/* dgelqf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int dgelqf_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *tau, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, k, ib, nb, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int dgelq2_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *), dlarfb_(char *,
+ char *, char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *), dlarft_(char *, char *, integer *, integer *, doublereal
+ *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGELQF computes an LQ factorization of a real M-by-N matrix A: */
+/* A = L * Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the elements on and below the diagonal of the array */
+/* contain the m-by-min(m,n) lower trapezoidal matrix L (L is */
+/* lower triangular if m <= n); the elements above the diagonal, */
+/* with the array TAU, represent the orthogonal matrix Q as a */
+/* product of elementary reflectors (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M). */
+/* For optimum performance LWORK >= M*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), */
+/* and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb = ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = *m * nb;
+ work[1] = (doublereal) lwkopt;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ } else if (*lwork < max(1,*m) && ! lquery) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGELQF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ k = min(*m,*n);
+ if (k == 0) {
+ work[1] = 1.;
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *m;
+ if (nb > 1 && nb < k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "DGELQF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *m;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "DGELQF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < k && nx < k) {
+
+/* Use blocked code initially */
+
+ i__1 = k - nx;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = k - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Compute the LQ factorization of the current block */
+/* A(i:i+ib-1,i:n) */
+
+ i__3 = *n - i__ + 1;
+ dgelq2_(&ib, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
+ 1], &iinfo);
+ if (i__ + ib <= *m) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__3 = *n - i__ + 1;
+ dlarft_("Forward", "Rowwise", &i__3, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H to A(i+ib:m,i:n) from the right */
+
+ i__3 = *m - i__ - ib + 1;
+ i__4 = *n - i__ + 1;
+ dlarfb_("Right", "No transpose", "Forward", "Rowwise", &i__3,
+ &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
+ ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib +
+ 1], &ldwork);
+ }
+/* L10: */
+ }
+ } else {
+ i__ = 1;
+ }
+
+/* Use unblocked code to factor the last or only block. */
+
+ if (i__ <= k) {
+ i__2 = *m - i__ + 1;
+ i__1 = *n - i__ + 1;
+ dgelq2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
+, &iinfo);
+ }
+
+ work[1] = (doublereal) iws;
+ return 0;
+
+/* End of DGELQF */
+
+} /* dgelqf_ */
diff --git a/SRC/dgels.c b/SRC/dgels.c
new file mode 100644
index 0000000..55b28c7
--- /dev/null
+++ b/SRC/dgels.c
@@ -0,0 +1,515 @@
+/* dgels.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b33 = 0.;
+static integer c__0 = 0;
+
+/* Subroutine */ int dgels_(char *trans, integer *m, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb,
+ doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, nb, mn;
+ doublereal anrm, bnrm;
+ integer brow;
+ logical tpsd;
+ integer iascl, ibscl;
+ extern logical lsame_(char *, char *);
+ integer wsize;
+ doublereal rwork[1];
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *),
+ dlascl_(char *, integer *, integer *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, integer *, integer *),
+ dgeqrf_(integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *), dlaset_(char *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer scllen;
+ doublereal bignum;
+ extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *),
+ dormqr_(char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *);
+ doublereal smlnum;
+ logical lquery;
+ extern /* Subroutine */ int dtrtrs_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGELS solves overdetermined or underdetermined real linear systems */
+/* involving an M-by-N matrix A, or its transpose, using a QR or LQ */
+/* factorization of A. It is assumed that A has full rank. */
+
+/* The following options are provided: */
+
+/* 1. If TRANS = 'N' and m >= n: find the least squares solution of */
+/* an overdetermined system, i.e., solve the least squares problem */
+/* minimize || B - A*X ||. */
+
+/* 2. If TRANS = 'N' and m < n: find the minimum norm solution of */
+/* an underdetermined system A * X = B. */
+
+/* 3. If TRANS = 'T' and m >= n: find the minimum norm solution of */
+/* an undetermined system A**T * X = B. */
+
+/* 4. If TRANS = 'T' and m < n: find the least squares solution of */
+/* an overdetermined system, i.e., solve the least squares problem */
+/* minimize || B - A**T * X ||. */
+
+/* Several right hand side vectors b and solution vectors x can be */
+/* handled in a single call; they are stored as the columns of the */
+/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
+/* matrix X. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': the linear system involves A; */
+/* = 'T': the linear system involves A**T. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of */
+/* columns of the matrices B and X. NRHS >=0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, */
+/* if M >= N, A is overwritten by details of its QR */
+/* factorization as returned by DGEQRF; */
+/* if M < N, A is overwritten by details of its LQ */
+/* factorization as returned by DGELQF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the matrix B of right hand side vectors, stored */
+/* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS */
+/* if TRANS = 'T'. */
+/* On exit, if INFO = 0, B is overwritten by the solution */
+/* vectors, stored columnwise: */
+/* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least */
+/* squares solution vectors; the residual sum of squares for the */
+/* solution in each column is given by the sum of squares of */
+/* elements N+1 to M in that column; */
+/* if TRANS = 'N' and m < n, rows 1 to N of B contain the */
+/* minimum norm solution vectors; */
+/* if TRANS = 'T' and m >= n, rows 1 to M of B contain the */
+/* minimum norm solution vectors; */
+/* if TRANS = 'T' and m < n, rows 1 to M of B contain the */
+/* least squares solution vectors; the residual sum of squares */
+/* for the solution in each column is given by the sum of */
+/* squares of elements M+1 to N in that column. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= MAX(1,M,N). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* LWORK >= max( 1, MN + max( MN, NRHS ) ). */
+/* For optimal performance, */
+/* LWORK >= max( 1, MN + max( MN, NRHS )*NB ). */
+/* where MN = min(M,N) and NB is the optimum block size. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element of the */
+/* triangular factor of A is zero, so that A does not have */
+/* full rank; the least squares solution could not be */
+/* computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ mn = min(*m,*n);
+ lquery = *lwork == -1;
+ if (! (lsame_(trans, "N") || lsame_(trans, "T"))) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -6;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ if (*ldb < max(i__1,*n)) {
+ *info = -8;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = 1, i__2 = mn + max(mn,*nrhs);
+ if (*lwork < max(i__1,i__2) && ! lquery) {
+ *info = -10;
+ }
+ }
+ }
+
+/* Figure out optimal block size */
+
+ if (*info == 0 || *info == -10) {
+
+ tpsd = TRUE_;
+ if (lsame_(trans, "N")) {
+ tpsd = FALSE_;
+ }
+
+ if (*m >= *n) {
+ nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1);
+ if (tpsd) {
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "DORMQR", "LN", m, nrhs, n, &
+ c_n1);
+ nb = max(i__1,i__2);
+ } else {
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "DORMQR", "LT", m, nrhs, n, &
+ c_n1);
+ nb = max(i__1,i__2);
+ }
+ } else {
+ nb = ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, &c_n1);
+ if (tpsd) {
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "DORMLQ", "LT", n, nrhs, m, &
+ c_n1);
+ nb = max(i__1,i__2);
+ } else {
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "DORMLQ", "LN", n, nrhs, m, &
+ c_n1);
+ nb = max(i__1,i__2);
+ }
+ }
+
+/* Computing MAX */
+ i__1 = 1, i__2 = mn + max(mn,*nrhs) * nb;
+ wsize = max(i__1,i__2);
+ work[1] = (doublereal) wsize;
+
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGELS ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+/* Computing MIN */
+ i__1 = min(*m,*n);
+ if (min(i__1,*nrhs) == 0) {
+ i__1 = max(*m,*n);
+ dlaset_("Full", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb);
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ smlnum = dlamch_("S") / dlamch_("P");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Scale A, B if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = dlange_("M", m, n, &a[a_offset], lda, rwork);
+ iascl = 0;
+ if (anrm > 0. && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 2;
+ } else if (anrm == 0.) {
+
+/* Matrix all zero. Return zero solution. */
+
+ i__1 = max(*m,*n);
+ dlaset_("F", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb);
+ goto L50;
+ }
+
+ brow = *m;
+ if (tpsd) {
+ brow = *n;
+ }
+ bnrm = dlange_("M", &brow, nrhs, &b[b_offset], ldb, rwork);
+ ibscl = 0;
+ if (bnrm > 0. && bnrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, &brow, nrhs, &b[b_offset],
+ ldb, info);
+ ibscl = 1;
+ } else if (bnrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ dlascl_("G", &c__0, &c__0, &bnrm, &bignum, &brow, nrhs, &b[b_offset],
+ ldb, info);
+ ibscl = 2;
+ }
+
+ if (*m >= *n) {
+
+/* compute QR factorization of A */
+
+ i__1 = *lwork - mn;
+ dgeqrf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
+ ;
+
+/* workspace at least N, optimally N*NB */
+
+ if (! tpsd) {
+
+/* Least-Squares Problem min || A * X - B || */
+
+/* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */
+
+ i__1 = *lwork - mn;
+ dormqr_("Left", "Transpose", m, nrhs, n, &a[a_offset], lda, &work[
+ 1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
+
+/* workspace at least NRHS, optimally NRHS*NB */
+
+/* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) */
+
+ dtrtrs_("Upper", "No transpose", "Non-unit", n, nrhs, &a[a_offset]
+, lda, &b[b_offset], ldb, info);
+
+ if (*info > 0) {
+ return 0;
+ }
+
+ scllen = *n;
+
+ } else {
+
+/* Overdetermined system of equations A' * X = B */
+
+/* B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS) */
+
+ dtrtrs_("Upper", "Transpose", "Non-unit", n, nrhs, &a[a_offset],
+ lda, &b[b_offset], ldb, info);
+
+ if (*info > 0) {
+ return 0;
+ }
+
+/* B(N+1:M,1:NRHS) = ZERO */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = *n + 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) */
+
+ i__1 = *lwork - mn;
+ dormqr_("Left", "No transpose", m, nrhs, n, &a[a_offset], lda, &
+ work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
+
+/* workspace at least NRHS, optimally NRHS*NB */
+
+ scllen = *m;
+
+ }
+
+ } else {
+
+/* Compute LQ factorization of A */
+
+ i__1 = *lwork - mn;
+ dgelqf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
+ ;
+
+/* workspace at least M, optimally M*NB. */
+
+ if (! tpsd) {
+
+/* underdetermined system of equations A * X = B */
+
+/* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) */
+
+ dtrtrs_("Lower", "No transpose", "Non-unit", m, nrhs, &a[a_offset]
+, lda, &b[b_offset], ldb, info);
+
+ if (*info > 0) {
+ return 0;
+ }
+
+/* B(M+1:N,1:NRHS) = 0 */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = *m + 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS) */
+
+ i__1 = *lwork - mn;
+ dormlq_("Left", "Transpose", n, nrhs, m, &a[a_offset], lda, &work[
+ 1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
+
+/* workspace at least NRHS, optimally NRHS*NB */
+
+ scllen = *n;
+
+ } else {
+
+/* overdetermined system min || A' * X - B || */
+
+/* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) */
+
+ i__1 = *lwork - mn;
+ dormlq_("Left", "No transpose", n, nrhs, m, &a[a_offset], lda, &
+ work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
+
+/* workspace at least NRHS, optimally NRHS*NB */
+
+/* B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS) */
+
+ dtrtrs_("Lower", "Transpose", "Non-unit", m, nrhs, &a[a_offset],
+ lda, &b[b_offset], ldb, info);
+
+ if (*info > 0) {
+ return 0;
+ }
+
+ scllen = *m;
+
+ }
+
+ }
+
+/* Undo scaling */
+
+ if (iascl == 1) {
+ dlascl_("G", &c__0, &c__0, &anrm, &smlnum, &scllen, nrhs, &b[b_offset]
+, ldb, info);
+ } else if (iascl == 2) {
+ dlascl_("G", &c__0, &c__0, &anrm, &bignum, &scllen, nrhs, &b[b_offset]
+, ldb, info);
+ }
+ if (ibscl == 1) {
+ dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, &scllen, nrhs, &b[b_offset]
+, ldb, info);
+ } else if (ibscl == 2) {
+ dlascl_("G", &c__0, &c__0, &bignum, &bnrm, &scllen, nrhs, &b[b_offset]
+, ldb, info);
+ }
+
+L50:
+ work[1] = (doublereal) wsize;
+
+ return 0;
+
+/* End of DGELS */
+
+} /* dgels_ */
diff --git a/SRC/dgelsd.c b/SRC/dgelsd.c
new file mode 100644
index 0000000..01a638d
--- /dev/null
+++ b/SRC/dgelsd.c
@@ -0,0 +1,693 @@
+/* dgelsd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__6 = 6;
+static integer c_n1 = -1;
+static integer c__9 = 9;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static doublereal c_b82 = 0.;
+
+/* Subroutine */ int dgelsd_(integer *m, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
+ s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork,
+ integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ double log(doublereal);
+
+ /* Local variables */
+ integer ie, il, mm;
+ doublereal eps, anrm, bnrm;
+ integer itau, nlvl, iascl, ibscl;
+ doublereal sfmin;
+ integer minmn, maxmn, itaup, itauq, mnthr, nwork;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), dgebrd_(
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *),
+ dlalsd_(char *, integer *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, integer *), dlascl_(char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ integer *, doublereal *, integer *, integer *), dgeqrf_(
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *), dlacpy_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *), dlaset_(char *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *), xerbla_(char *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dormbr_(char *, char *, char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+ integer wlalsd;
+ extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ integer ldwork;
+ extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ integer minwrk, maxwrk;
+ doublereal smlnum;
+ logical lquery;
+ integer smlsiz;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGELSD computes the minimum-norm solution to a real linear least */
+/* squares problem: */
+/* minimize 2-norm(| b - A*x |) */
+/* using the singular value decomposition (SVD) of A. A is an M-by-N */
+/* matrix which may be rank-deficient. */
+
+/* Several right hand side vectors b and solution vectors x can be */
+/* handled in a single call; they are stored as the columns of the */
+/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
+/* matrix X. */
+
+/* The problem is solved in three steps: */
+/* (1) Reduce the coefficient matrix A to bidiagonal form with */
+/* Householder transformations, reducing the original problem */
+/* into a "bidiagonal least squares problem" (BLS) */
+/* (2) Solve the BLS using a divide and conquer approach. */
+/* (3) Apply back all the Householder tranformations to solve */
+/* the original least squares problem. */
+
+/* The effective rank of A is determined by treating as zero those */
+/* singular values which are less than RCOND times the largest singular */
+/* value. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A has been destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the M-by-NRHS right hand side matrix B. */
+/* On exit, B is overwritten by the N-by-NRHS solution */
+/* matrix X. If m >= n and RANK = n, the residual */
+/* sum-of-squares for the solution in the i-th column is given */
+/* by the sum of squares of elements n+1:m in that column. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,max(M,N)). */
+
+/* S (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The singular values of A in decreasing order. */
+/* The condition number of A in the 2-norm = S(1)/S(min(m,n)). */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* RCOND is used to determine the effective rank of A. */
+/* Singular values S(i) <= RCOND*S(1) are treated as zero. */
+/* If RCOND < 0, machine precision is used instead. */
+
+/* RANK (output) INTEGER */
+/* The effective rank of A, i.e., the number of singular values */
+/* which are greater than RCOND*S(1). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK must be at least 1. */
+/* The exact minimum amount of workspace needed depends on M, */
+/* N and NRHS. As long as LWORK is at least */
+/* 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2, */
+/* if M is greater than or equal to N or */
+/* 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2, */
+/* if M is less than N, the code will execute correctly. */
+/* SMLSIZ is returned by ILAENV and is equal to the maximum */
+/* size of the subproblems at the bottom of the computation */
+/* tree (usually about 25), and */
+/* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) */
+/* For good performance, LWORK should generally be larger. */
+
+/* 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. */
+
+/* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* LIWORK >= 3 * MINMN * NLVL + 11 * MINMN, */
+/* where MINMN = MIN( M,N ). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: the algorithm for computing the SVD failed to converge; */
+/* if INFO = i, i off-diagonal elements of an intermediate */
+/* bidiagonal form did not converge to zero. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */
+/* California at Berkeley, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --s;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ minmn = min(*m,*n);
+ maxmn = max(*m,*n);
+ mnthr = ilaenv_(&c__6, "DGELSD", " ", m, n, nrhs, &c_n1);
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,maxmn)) {
+ *info = -7;
+ }
+
+ smlsiz = ilaenv_(&c__9, "DGELSD", " ", &c__0, &c__0, &c__0, &c__0);
+
+/* Compute workspace. */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ minwrk = 1;
+ minmn = max(1,minmn);
+/* Computing MAX */
+ i__1 = (integer) (log((doublereal) minmn / (doublereal) (smlsiz + 1)) /
+ log(2.)) + 1;
+ nlvl = max(i__1,0);
+
+ if (*info == 0) {
+ maxwrk = 0;
+ mm = *m;
+ if (*m >= *n && *m >= mnthr) {
+
+/* Path 1a - overdetermined, with many more rows than columns. */
+
+ mm = *n;
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m,
+ n, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "DORMQR", "LT",
+ m, nrhs, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ }
+ if (*m >= *n) {
+
+/* Path 1 - overdetermined or exactly determined. */
+
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * 3 + (mm + *n) * ilaenv_(&c__1, "DGEBRD"
+, " ", &mm, n, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, "DORMBR",
+ "QLT", &mm, nrhs, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * 3 + (*n - 1) * ilaenv_(&c__1, "DORMBR",
+ "PLN", n, nrhs, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing 2nd power */
+ i__1 = smlsiz + 1;
+ wlalsd = *n * 9 + (*n << 1) * smlsiz + (*n << 3) * nlvl + *n * *
+ nrhs + i__1 * i__1;
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * 3 + wlalsd;
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = max(i__1,i__2),
+ i__2 = *n * 3 + wlalsd;
+ minwrk = max(i__1,i__2);
+ }
+ if (*n > *m) {
+/* Computing 2nd power */
+ i__1 = smlsiz + 1;
+ wlalsd = *m * 9 + (*m << 1) * smlsiz + (*m << 3) * nlvl + *m * *
+ nrhs + i__1 * i__1;
+ if (*n >= mnthr) {
+
+/* Path 2a - underdetermined, with many more columns */
+/* than rows. */
+
+ maxwrk = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1,
+ &c_n1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) *
+ ilaenv_(&c__1, "DGEBRD", " ", m, m, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs * ilaenv_(&
+ c__1, "DORMBR", "QLT", m, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) *
+ ilaenv_(&c__1, "DORMBR", "PLN", m, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+ if (*nrhs > 1) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs;
+ maxwrk = max(i__1,i__2);
+ } else {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 1);
+ maxwrk = max(i__1,i__2);
+ }
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, "DORMLQ",
+ "LT", n, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + wlalsd;
+ maxwrk = max(i__1,i__2);
+/* XXX: Ensure the Path 2a case below is triggered. The workspace */
+/* calculation should use queries for all routines eventually. */
+/* Computing MAX */
+/* Computing MAX */
+ i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 =
+ max(i__3,*nrhs), i__4 = *n - *m * 3;
+ i__1 = maxwrk, i__2 = (*m << 2) + *m * *m + max(i__3,i__4);
+ maxwrk = max(i__1,i__2);
+ } else {
+
+/* Path 2 - remaining underdetermined cases. */
+
+ maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, "DGEBRD", " ", m,
+ n, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1, "DORMBR"
+, "QLT", m, nrhs, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR",
+ "PLN", n, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * 3 + wlalsd;
+ maxwrk = max(i__1,i__2);
+ }
+/* Computing MAX */
+ i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *m, i__1 = max(i__1,i__2),
+ i__2 = *m * 3 + wlalsd;
+ minwrk = max(i__1,i__2);
+ }
+ minwrk = min(minwrk,maxwrk);
+ work[1] = (doublereal) maxwrk;
+ if (*lwork < minwrk && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGELSD", &i__1);
+ return 0;
+ } else if (lquery) {
+ goto L10;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ *rank = 0;
+ return 0;
+ }
+
+/* Get machine parameters. */
+
+ eps = dlamch_("P");
+ sfmin = dlamch_("S");
+ smlnum = sfmin / eps;
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Scale A if max entry outside range [SMLNUM,BIGNUM]. */
+
+ anrm = dlange_("M", m, n, &a[a_offset], lda, &work[1]);
+ iascl = 0;
+ if (anrm > 0. && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM. */
+
+ dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM. */
+
+ dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 2;
+ } else if (anrm == 0.) {
+
+/* Matrix all zero. Return zero solution. */
+
+ i__1 = max(*m,*n);
+ dlaset_("F", &i__1, nrhs, &c_b82, &c_b82, &b[b_offset], ldb);
+ dlaset_("F", &minmn, &c__1, &c_b82, &c_b82, &s[1], &c__1);
+ *rank = 0;
+ goto L10;
+ }
+
+/* Scale B if max entry outside range [SMLNUM,BIGNUM]. */
+
+ bnrm = dlange_("M", m, nrhs, &b[b_offset], ldb, &work[1]);
+ ibscl = 0;
+ if (bnrm > 0. && bnrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM. */
+
+ dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 1;
+ } else if (bnrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM. */
+
+ dlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 2;
+ }
+
+/* If M < N make sure certain entries of B are zero. */
+
+ if (*m < *n) {
+ i__1 = *n - *m;
+ dlaset_("F", &i__1, nrhs, &c_b82, &c_b82, &b[*m + 1 + b_dim1], ldb);
+ }
+
+/* Overdetermined case. */
+
+ if (*m >= *n) {
+
+/* Path 1 - overdetermined or exactly determined. */
+
+ mm = *m;
+ if (*m >= mnthr) {
+
+/* Path 1a - overdetermined, with many more rows than columns. */
+
+ mm = *n;
+ itau = 1;
+ nwork = itau + *n;
+
+/* Compute A=Q*R. */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1,
+ info);
+
+/* Multiply B by transpose(Q). */
+/* (Workspace: need N+NRHS, prefer N+NRHS*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dormqr_("L", "T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[
+ b_offset], ldb, &work[nwork], &i__1, info);
+
+/* Zero out below R. */
+
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ dlaset_("L", &i__1, &i__2, &c_b82, &c_b82, &a[a_dim1 + 2],
+ lda);
+ }
+ }
+
+ ie = 1;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize R in A. */
+/* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
+ work[itaup], &work[nwork], &i__1, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors of R. */
+/* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dormbr_("Q", "L", "T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq],
+ &b[b_offset], ldb, &work[nwork], &i__1, info);
+
+/* Solve the bidiagonal least squares problem. */
+
+ dlalsd_("U", &smlsiz, n, nrhs, &s[1], &work[ie], &b[b_offset], ldb,
+ rcond, rank, &work[nwork], &iwork[1], info);
+ if (*info != 0) {
+ goto L10;
+ }
+
+/* Multiply B by right bidiagonalizing vectors of R. */
+
+ i__1 = *lwork - nwork + 1;
+ dormbr_("P", "L", "N", n, nrhs, n, &a[a_offset], lda, &work[itaup], &
+ b[b_offset], ldb, &work[nwork], &i__1, info);
+
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = *m, i__2 = (*m << 1) - 4, i__1 = max(i__1,i__2), i__1 = max(
+ i__1,*nrhs), i__2 = *n - *m * 3, i__1 = max(i__1,i__2);
+ if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__1,wlalsd)) {
+
+/* Path 2a - underdetermined, with many more columns than rows */
+/* and sufficient workspace for an efficient algorithm. */
+
+ ldwork = *m;
+/* Computing MAX */
+/* Computing MAX */
+ i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 =
+ max(i__3,*nrhs), i__4 = *n - *m * 3;
+ i__1 = (*m << 2) + *m * *lda + max(i__3,i__4), i__2 = *m * *lda +
+ *m + *m * *nrhs, i__1 = max(i__1,i__2), i__2 = (*m << 2)
+ + *m * *lda + wlalsd;
+ if (*lwork >= max(i__1,i__2)) {
+ ldwork = *lda;
+ }
+ itau = 1;
+ nwork = *m + 1;
+
+/* Compute A=L*Q. */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1,
+ info);
+ il = nwork;
+
+/* Copy L to WORK(IL), zeroing out above its diagonal. */
+
+ dlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork);
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ dlaset_("U", &i__1, &i__2, &c_b82, &c_b82, &work[il + ldwork], &
+ ldwork);
+ ie = il + ldwork * *m;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IL). */
+/* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq],
+ &work[itaup], &work[nwork], &i__1, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors of L. */
+/* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dormbr_("Q", "L", "T", m, nrhs, m, &work[il], &ldwork, &work[
+ itauq], &b[b_offset], ldb, &work[nwork], &i__1, info);
+
+/* Solve the bidiagonal least squares problem. */
+
+ dlalsd_("U", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset],
+ ldb, rcond, rank, &work[nwork], &iwork[1], info);
+ if (*info != 0) {
+ goto L10;
+ }
+
+/* Multiply B by right bidiagonalizing vectors of L. */
+
+ i__1 = *lwork - nwork + 1;
+ dormbr_("P", "L", "N", m, nrhs, m, &work[il], &ldwork, &work[
+ itaup], &b[b_offset], ldb, &work[nwork], &i__1, info);
+
+/* Zero out below first M rows of B. */
+
+ i__1 = *n - *m;
+ dlaset_("F", &i__1, nrhs, &c_b82, &c_b82, &b[*m + 1 + b_dim1],
+ ldb);
+ nwork = itau + *m;
+
+/* Multiply transpose(Q) by B. */
+/* (Workspace: need M+NRHS, prefer M+NRHS*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dormlq_("L", "T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[
+ b_offset], ldb, &work[nwork], &i__1, info);
+
+ } else {
+
+/* Path 2 - remaining underdetermined cases. */
+
+ ie = 1;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize A. */
+/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
+ work[itaup], &work[nwork], &i__1, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors. */
+/* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dormbr_("Q", "L", "T", m, nrhs, n, &a[a_offset], lda, &work[itauq]
+, &b[b_offset], ldb, &work[nwork], &i__1, info);
+
+/* Solve the bidiagonal least squares problem. */
+
+ dlalsd_("L", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset],
+ ldb, rcond, rank, &work[nwork], &iwork[1], info);
+ if (*info != 0) {
+ goto L10;
+ }
+
+/* Multiply B by right bidiagonalizing vectors of A. */
+
+ i__1 = *lwork - nwork + 1;
+ dormbr_("P", "L", "N", n, nrhs, m, &a[a_offset], lda, &work[itaup]
+, &b[b_offset], ldb, &work[nwork], &i__1, info);
+
+ }
+ }
+
+/* Undo scaling. */
+
+ if (iascl == 1) {
+ dlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
+ info);
+ dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, info);
+ } else if (iascl == 2) {
+ dlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
+ info);
+ dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, info);
+ }
+ if (ibscl == 1) {
+ dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ } else if (ibscl == 2) {
+ dlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ }
+
+L10:
+ work[1] = (doublereal) maxwrk;
+ return 0;
+
+/* End of DGELSD */
+
+} /* dgelsd_ */
diff --git a/SRC/dgelss.c b/SRC/dgelss.c
new file mode 100644
index 0000000..82cf9a4
--- /dev/null
+++ b/SRC/dgelss.c
@@ -0,0 +1,828 @@
+/* dgelss.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__6 = 6;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__0 = 0;
+static doublereal c_b74 = 0.;
+static doublereal c_b108 = 1.;
+
+/* Subroutine */ int dgelss_(integer *m, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
+ s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, bl, ie, il, mm;
+ doublereal eps, thr, anrm, bnrm;
+ integer itau;
+ doublereal vdum[1];
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ integer iascl, ibscl;
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), drscl_(integer *,
+ doublereal *, doublereal *, integer *);
+ integer chunk;
+ doublereal sfmin;
+ integer minmn;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer maxmn, itaup, itauq, mnthr, iwork;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), dgebrd_(
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ integer bdspac;
+ extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *),
+ dlascl_(char *, integer *, integer *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, integer *, integer *),
+ dgeqrf_(integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *), dlacpy_(char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *), dbdsqr_(char *, integer *,
+ integer *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *), dorgbr_(char *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *);
+ doublereal bignum;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dormbr_(char *, char *, char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dormlq_(char *, char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+ integer ldwork;
+ extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ integer minwrk, maxwrk;
+ doublereal smlnum;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGELSS computes the minimum norm solution to a real linear least */
+/* squares problem: */
+
+/* Minimize 2-norm(| b - A*x |). */
+
+/* using the singular value decomposition (SVD) of A. A is an M-by-N */
+/* matrix which may be rank-deficient. */
+
+/* Several right hand side vectors b and solution vectors x can be */
+/* handled in a single call; they are stored as the columns of the */
+/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix */
+/* X. */
+
+/* The effective rank of A is determined by treating as zero those */
+/* singular values which are less than RCOND times the largest singular */
+/* value. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the first min(m,n) rows of A are overwritten with */
+/* its right singular vectors, stored rowwise. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the M-by-NRHS right hand side matrix B. */
+/* On exit, B is overwritten by the N-by-NRHS solution */
+/* matrix X. If m >= n and RANK = n, the residual */
+/* sum-of-squares for the solution in the i-th column is given */
+/* by the sum of squares of elements n+1:m in that column. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,max(M,N)). */
+
+/* S (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The singular values of A in decreasing order. */
+/* The condition number of A in the 2-norm = S(1)/S(min(m,n)). */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* RCOND is used to determine the effective rank of A. */
+/* Singular values S(i) <= RCOND*S(1) are treated as zero. */
+/* If RCOND < 0, machine precision is used instead. */
+
+/* RANK (output) INTEGER */
+/* The effective rank of A, i.e., the number of singular values */
+/* which are greater than RCOND*S(1). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= 1, and also: */
+/* LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS ) */
+/* For good performance, LWORK should generally be larger. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: the algorithm for computing the SVD failed to converge; */
+/* if INFO = i, i off-diagonal elements of an intermediate */
+/* bidiagonal form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --s;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ minmn = min(*m,*n);
+ maxmn = max(*m,*n);
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,maxmn)) {
+ *info = -7;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ if (*info == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ if (minmn > 0) {
+ mm = *m;
+ mnthr = ilaenv_(&c__6, "DGELSS", " ", m, n, nrhs, &c_n1);
+ if (*m >= *n && *m >= mnthr) {
+
+/* Path 1a - overdetermined, with many more rows than */
+/* columns */
+
+ mm = *n;
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DGEQRF",
+ " ", m, n, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "DORMQR",
+ "LT", m, nrhs, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ }
+ if (*m >= *n) {
+
+/* Path 1 - overdetermined or exactly determined */
+
+/* Compute workspace needed for DBDSQR */
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * 5;
+ bdspac = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * 3 + (mm + *n) * ilaenv_(&c__1,
+ "DGEBRD", " ", &mm, n, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, "DORMBR"
+, "QLT", &mm, nrhs, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
+ "DORGBR", "P", n, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ maxwrk = max(maxwrk,bdspac);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * *nrhs;
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = max(i__1,
+ i__2);
+ minwrk = max(i__1,bdspac);
+ maxwrk = max(minwrk,maxwrk);
+ }
+ if (*n > *m) {
+
+/* Compute workspace needed for DBDSQR */
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *m * 5;
+ bdspac = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *n, i__1 = max(i__1,
+ i__2);
+ minwrk = max(i__1,bdspac);
+ if (*n >= mnthr) {
+
+/* Path 2a - underdetermined, with many more columns */
+/* than rows */
+
+ maxwrk = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) *
+ ilaenv_(&c__1, "DGEBRD", " ", m, m, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs *
+ ilaenv_(&c__1, "DORMBR", "QLT", m, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) *
+ ilaenv_(&c__1, "DORGBR", "P", m, m, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + *m + bdspac;
+ maxwrk = max(i__1,i__2);
+ if (*nrhs > 1) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs;
+ maxwrk = max(i__1,i__2);
+ } else {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 1);
+ maxwrk = max(i__1,i__2);
+ }
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, "DORMLQ"
+, "LT", n, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+ } else {
+
+/* Path 2 - underdetermined */
+
+ maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, "DGEBRD",
+ " ", m, n, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1,
+ "DORMBR", "QLT", m, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORG"
+ "BR", "P", m, n, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+ maxwrk = max(maxwrk,bdspac);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * *nrhs;
+ maxwrk = max(i__1,i__2);
+ }
+ }
+ maxwrk = max(minwrk,maxwrk);
+ }
+ work[1] = (doublereal) maxwrk;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGELSS", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ *rank = 0;
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ eps = dlamch_("P");
+ sfmin = dlamch_("S");
+ smlnum = sfmin / eps;
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = dlange_("M", m, n, &a[a_offset], lda, &work[1]);
+ iascl = 0;
+ if (anrm > 0. && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 2;
+ } else if (anrm == 0.) {
+
+/* Matrix all zero. Return zero solution. */
+
+ i__1 = max(*m,*n);
+ dlaset_("F", &i__1, nrhs, &c_b74, &c_b74, &b[b_offset], ldb);
+ dlaset_("F", &minmn, &c__1, &c_b74, &c_b74, &s[1], &c__1);
+ *rank = 0;
+ goto L70;
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = dlange_("M", m, nrhs, &b[b_offset], ldb, &work[1]);
+ ibscl = 0;
+ if (bnrm > 0. && bnrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 1;
+ } else if (bnrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ dlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 2;
+ }
+
+/* Overdetermined case */
+
+ if (*m >= *n) {
+
+/* Path 1 - overdetermined or exactly determined */
+
+ mm = *m;
+ if (*m >= mnthr) {
+
+/* Path 1a - overdetermined, with many more rows than columns */
+
+ mm = *n;
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__1 = *lwork - iwork + 1;
+ dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__1,
+ info);
+
+/* Multiply B by transpose(Q) */
+/* (Workspace: need N+NRHS, prefer N+NRHS*NB) */
+
+ i__1 = *lwork - iwork + 1;
+ dormqr_("L", "T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[
+ b_offset], ldb, &work[iwork], &i__1, info);
+
+/* Zero out below R */
+
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ dlaset_("L", &i__1, &i__2, &c_b74, &c_b74, &a[a_dim1 + 2],
+ lda);
+ }
+ }
+
+ ie = 1;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in A */
+/* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) */
+
+ i__1 = *lwork - iwork + 1;
+ dgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
+ work[itaup], &work[iwork], &i__1, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors of R */
+/* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) */
+
+ i__1 = *lwork - iwork + 1;
+ dormbr_("Q", "L", "T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq],
+ &b[b_offset], ldb, &work[iwork], &i__1, info);
+
+/* Generate right bidiagonalizing vectors of R in A */
+/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */
+
+ i__1 = *lwork - iwork + 1;
+ dorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[iwork], &
+ i__1, info);
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration */
+/* multiply B by transpose of left singular vectors */
+/* compute right singular vectors in A */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("U", n, n, &c__0, nrhs, &s[1], &work[ie], &a[a_offset], lda,
+ vdum, &c__1, &b[b_offset], ldb, &work[iwork], info)
+ ;
+ if (*info != 0) {
+ goto L70;
+ }
+
+/* Multiply B by reciprocals of singular values */
+
+/* Computing MAX */
+ d__1 = *rcond * s[1];
+ thr = max(d__1,sfmin);
+ if (*rcond < 0.) {
+/* Computing MAX */
+ d__1 = eps * s[1];
+ thr = max(d__1,sfmin);
+ }
+ *rank = 0;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] > thr) {
+ drscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb);
+ ++(*rank);
+ } else {
+ dlaset_("F", &c__1, nrhs, &c_b74, &c_b74, &b[i__ + b_dim1],
+ ldb);
+ }
+/* L10: */
+ }
+
+/* Multiply B by right singular vectors */
+/* (Workspace: need N, prefer N*NRHS) */
+
+ if (*lwork >= *ldb * *nrhs && *nrhs > 1) {
+ dgemm_("T", "N", n, nrhs, n, &c_b108, &a[a_offset], lda, &b[
+ b_offset], ldb, &c_b74, &work[1], ldb);
+ dlacpy_("G", n, nrhs, &work[1], ldb, &b[b_offset], ldb)
+ ;
+ } else if (*nrhs > 1) {
+ chunk = *lwork / *n;
+ i__1 = *nrhs;
+ i__2 = chunk;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = *nrhs - i__ + 1;
+ bl = min(i__3,chunk);
+ dgemm_("T", "N", n, &bl, n, &c_b108, &a[a_offset], lda, &b[
+ i__ * b_dim1 + 1], ldb, &c_b74, &work[1], n);
+ dlacpy_("G", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1], ldb);
+/* L20: */
+ }
+ } else {
+ dgemv_("T", n, n, &c_b108, &a[a_offset], lda, &b[b_offset], &c__1,
+ &c_b74, &work[1], &c__1);
+ dcopy_(n, &work[1], &c__1, &b[b_offset], &c__1);
+ }
+
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__2 = *m, i__1 = (*m << 1) - 4, i__2 = max(i__2,i__1), i__2 = max(
+ i__2,*nrhs), i__1 = *n - *m * 3;
+ if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__2,i__1)) {
+
+/* Path 2a - underdetermined, with many more columns than rows */
+/* and sufficient workspace for an efficient algorithm */
+
+ ldwork = *m;
+/* Computing MAX */
+/* Computing MAX */
+ i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 =
+ max(i__3,*nrhs), i__4 = *n - *m * 3;
+ i__2 = (*m << 2) + *m * *lda + max(i__3,i__4), i__1 = *m * *lda +
+ *m + *m * *nrhs;
+ if (*lwork >= max(i__2,i__1)) {
+ ldwork = *lda;
+ }
+ itau = 1;
+ iwork = *m + 1;
+
+/* Compute A=L*Q */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2,
+ info);
+ il = iwork;
+
+/* Copy L to WORK(IL), zeroing out above it */
+
+ dlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork);
+ i__2 = *m - 1;
+ i__1 = *m - 1;
+ dlaset_("U", &i__2, &i__1, &c_b74, &c_b74, &work[il + ldwork], &
+ ldwork);
+ ie = il + ldwork * *m;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IL) */
+/* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq],
+ &work[itaup], &work[iwork], &i__2, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors of L */
+/* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dormbr_("Q", "L", "T", m, nrhs, m, &work[il], &ldwork, &work[
+ itauq], &b[b_offset], ldb, &work[iwork], &i__2, info);
+
+/* Generate right bidiagonalizing vectors of R in WORK(IL) */
+/* (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("P", m, m, m, &work[il], &ldwork, &work[itaup], &work[
+ iwork], &i__2, info);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, */
+/* computing right singular vectors of L in WORK(IL) and */
+/* multiplying B by transpose of left singular vectors */
+/* (Workspace: need M*M+M+BDSPAC) */
+
+ dbdsqr_("U", m, m, &c__0, nrhs, &s[1], &work[ie], &work[il], &
+ ldwork, &a[a_offset], lda, &b[b_offset], ldb, &work[iwork]
+, info);
+ if (*info != 0) {
+ goto L70;
+ }
+
+/* Multiply B by reciprocals of singular values */
+
+/* Computing MAX */
+ d__1 = *rcond * s[1];
+ thr = max(d__1,sfmin);
+ if (*rcond < 0.) {
+/* Computing MAX */
+ d__1 = eps * s[1];
+ thr = max(d__1,sfmin);
+ }
+ *rank = 0;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (s[i__] > thr) {
+ drscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb);
+ ++(*rank);
+ } else {
+ dlaset_("F", &c__1, nrhs, &c_b74, &c_b74, &b[i__ + b_dim1]
+, ldb);
+ }
+/* L30: */
+ }
+ iwork = ie;
+
+/* Multiply B by right singular vectors of L in WORK(IL) */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS) */
+
+ if (*lwork >= *ldb * *nrhs + iwork - 1 && *nrhs > 1) {
+ dgemm_("T", "N", m, nrhs, m, &c_b108, &work[il], &ldwork, &b[
+ b_offset], ldb, &c_b74, &work[iwork], ldb);
+ dlacpy_("G", m, nrhs, &work[iwork], ldb, &b[b_offset], ldb);
+ } else if (*nrhs > 1) {
+ chunk = (*lwork - iwork + 1) / *m;
+ i__2 = *nrhs;
+ i__1 = chunk;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
+ i__1) {
+/* Computing MIN */
+ i__3 = *nrhs - i__ + 1;
+ bl = min(i__3,chunk);
+ dgemm_("T", "N", m, &bl, m, &c_b108, &work[il], &ldwork, &
+ b[i__ * b_dim1 + 1], ldb, &c_b74, &work[iwork], m);
+ dlacpy_("G", m, &bl, &work[iwork], m, &b[i__ * b_dim1 + 1]
+, ldb);
+/* L40: */
+ }
+ } else {
+ dgemv_("T", m, m, &c_b108, &work[il], &ldwork, &b[b_dim1 + 1],
+ &c__1, &c_b74, &work[iwork], &c__1);
+ dcopy_(m, &work[iwork], &c__1, &b[b_dim1 + 1], &c__1);
+ }
+
+/* Zero out below first M rows of B */
+
+ i__1 = *n - *m;
+ dlaset_("F", &i__1, nrhs, &c_b74, &c_b74, &b[*m + 1 + b_dim1],
+ ldb);
+ iwork = itau + *m;
+
+/* Multiply transpose(Q) by B */
+/* (Workspace: need M+NRHS, prefer M+NRHS*NB) */
+
+ i__1 = *lwork - iwork + 1;
+ dormlq_("L", "T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[
+ b_offset], ldb, &work[iwork], &i__1, info);
+
+ } else {
+
+/* Path 2 - remaining underdetermined cases */
+
+ ie = 1;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize A */
+/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */
+
+ i__1 = *lwork - iwork + 1;
+ dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
+ work[itaup], &work[iwork], &i__1, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors */
+/* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) */
+
+ i__1 = *lwork - iwork + 1;
+ dormbr_("Q", "L", "T", m, nrhs, n, &a[a_offset], lda, &work[itauq]
+, &b[b_offset], ldb, &work[iwork], &i__1, info);
+
+/* Generate right bidiagonalizing vectors in A */
+/* (Workspace: need 4*M, prefer 3*M+M*NB) */
+
+ i__1 = *lwork - iwork + 1;
+ dorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[
+ iwork], &i__1, info);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, */
+/* computing right singular vectors of A in A and */
+/* multiplying B by transpose of left singular vectors */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("L", m, n, &c__0, nrhs, &s[1], &work[ie], &a[a_offset],
+ lda, vdum, &c__1, &b[b_offset], ldb, &work[iwork], info);
+ if (*info != 0) {
+ goto L70;
+ }
+
+/* Multiply B by reciprocals of singular values */
+
+/* Computing MAX */
+ d__1 = *rcond * s[1];
+ thr = max(d__1,sfmin);
+ if (*rcond < 0.) {
+/* Computing MAX */
+ d__1 = eps * s[1];
+ thr = max(d__1,sfmin);
+ }
+ *rank = 0;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] > thr) {
+ drscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb);
+ ++(*rank);
+ } else {
+ dlaset_("F", &c__1, nrhs, &c_b74, &c_b74, &b[i__ + b_dim1]
+, ldb);
+ }
+/* L50: */
+ }
+
+/* Multiply B by right singular vectors of A */
+/* (Workspace: need N, prefer N*NRHS) */
+
+ if (*lwork >= *ldb * *nrhs && *nrhs > 1) {
+ dgemm_("T", "N", n, nrhs, m, &c_b108, &a[a_offset], lda, &b[
+ b_offset], ldb, &c_b74, &work[1], ldb);
+ dlacpy_("F", n, nrhs, &work[1], ldb, &b[b_offset], ldb);
+ } else if (*nrhs > 1) {
+ chunk = *lwork / *n;
+ i__1 = *nrhs;
+ i__2 = chunk;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *nrhs - i__ + 1;
+ bl = min(i__3,chunk);
+ dgemm_("T", "N", n, &bl, m, &c_b108, &a[a_offset], lda, &
+ b[i__ * b_dim1 + 1], ldb, &c_b74, &work[1], n);
+ dlacpy_("F", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1],
+ ldb);
+/* L60: */
+ }
+ } else {
+ dgemv_("T", m, n, &c_b108, &a[a_offset], lda, &b[b_offset], &
+ c__1, &c_b74, &work[1], &c__1);
+ dcopy_(n, &work[1], &c__1, &b[b_offset], &c__1);
+ }
+ }
+ }
+
+/* Undo scaling */
+
+ if (iascl == 1) {
+ dlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
+ info);
+ dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, info);
+ } else if (iascl == 2) {
+ dlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
+ info);
+ dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, info);
+ }
+ if (ibscl == 1) {
+ dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ } else if (ibscl == 2) {
+ dlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ }
+
+L70:
+ work[1] = (doublereal) maxwrk;
+ return 0;
+
+/* End of DGELSS */
+
+} /* dgelss_ */
diff --git a/SRC/dgelsx.c b/SRC/dgelsx.c
new file mode 100644
index 0000000..75217ae
--- /dev/null
+++ b/SRC/dgelsx.c
@@ -0,0 +1,438 @@
+/* dgelsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static doublereal c_b13 = 0.;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static doublereal c_b36 = 1.;
+
+/* Subroutine */ int dgelsx_(integer *m, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *
+ jpvt, doublereal *rcond, integer *rank, doublereal *work, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal c1, c2, s1, s2, t1, t2;
+ integer mn;
+ doublereal anrm, bnrm, smin, smax;
+ integer iascl, ibscl, ismin, ismax;
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), dlaic1_(
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *), dorm2r_(
+ char *, char *, integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *), dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), dgeqpf_(integer *, integer *,
+ doublereal *, integer *, integer *, doublereal *, doublereal *,
+ integer *), dlaset_(char *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *), xerbla_(char *,
+ integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dlatzm_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *);
+ doublereal sminpr, smaxpr, smlnum;
+ extern /* Subroutine */ int dtzrqf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine DGELSY. */
+
+/* DGELSX computes the minimum-norm solution to a real linear least */
+/* squares problem: */
+/* minimize || A * X - B || */
+/* using a complete orthogonal factorization of A. A is an M-by-N */
+/* matrix which may be rank-deficient. */
+
+/* Several right hand side vectors b and solution vectors x can be */
+/* handled in a single call; they are stored as the columns of the */
+/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
+/* matrix X. */
+
+/* The routine first computes a QR factorization with column pivoting: */
+/* A * P = Q * [ R11 R12 ] */
+/* [ 0 R22 ] */
+/* with R11 defined as the largest leading submatrix whose estimated */
+/* condition number is less than 1/RCOND. The order of R11, RANK, */
+/* is the effective rank of A. */
+
+/* Then, R22 is considered to be negligible, and R12 is annihilated */
+/* by orthogonal transformations from the right, arriving at the */
+/* complete orthogonal factorization: */
+/* A * P = Q * [ T11 0 ] * Z */
+/* [ 0 0 ] */
+/* The minimum-norm solution is then */
+/* X = P * Z' [ inv(T11)*Q1'*B ] */
+/* [ 0 ] */
+/* where Q1 consists of the first RANK columns of Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of */
+/* columns of matrices B and X. NRHS >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A has been overwritten by details of its */
+/* complete orthogonal factorization. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the M-by-NRHS right hand side matrix B. */
+/* On exit, the N-by-NRHS solution matrix X. */
+/* If m >= n and RANK = n, the residual sum-of-squares for */
+/* the solution in the i-th column is given by the sum of */
+/* squares of elements N+1:M in that column. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M,N). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* On entry, if JPVT(i) .ne. 0, the i-th column of A is an */
+/* initial column, otherwise it is a free column. Before */
+/* the QR factorization of A, all initial columns are */
+/* permuted to the leading positions; only the remaining */
+/* free columns are moved as a result of column pivoting */
+/* during the factorization. */
+/* On exit, if JPVT(i) = k, then the i-th column of A*P */
+/* was the k-th column of A. */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* RCOND is used to determine the effective rank of A, which */
+/* is defined as the order of the largest leading triangular */
+/* submatrix R11 in the QR factorization with pivoting of A, */
+/* whose estimated condition number < 1/RCOND. */
+
+/* RANK (output) INTEGER */
+/* The effective rank of A, i.e., the order of the submatrix */
+/* R11. This is the same as the order of the submatrix T11 */
+/* in the complete orthogonal factorization of A. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max( min(M,N)+3*N, 2*min(M,N)+NRHS )), */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --jpvt;
+ --work;
+
+ /* Function Body */
+ mn = min(*m,*n);
+ ismin = mn + 1;
+ ismax = (mn << 1) + 1;
+
+/* Test the input arguments. */
+
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ if (*ldb < max(i__1,*n)) {
+ *info = -7;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGELSX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+/* Computing MIN */
+ i__1 = min(*m,*n);
+ if (min(i__1,*nrhs) == 0) {
+ *rank = 0;
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ smlnum = dlamch_("S") / dlamch_("P");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Scale A, B if max elements outside range [SMLNUM,BIGNUM] */
+
+ anrm = dlange_("M", m, n, &a[a_offset], lda, &work[1]);
+ iascl = 0;
+ if (anrm > 0. && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 2;
+ } else if (anrm == 0.) {
+
+/* Matrix all zero. Return zero solution. */
+
+ i__1 = max(*m,*n);
+ dlaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb);
+ *rank = 0;
+ goto L100;
+ }
+
+ bnrm = dlange_("M", m, nrhs, &b[b_offset], ldb, &work[1]);
+ ibscl = 0;
+ if (bnrm > 0. && bnrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 1;
+ } else if (bnrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ dlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 2;
+ }
+
+/* Compute QR factorization with column pivoting of A: */
+/* A * P = Q * R */
+
+ dgeqpf_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], info);
+
+/* workspace 3*N. Details of Householder rotations stored */
+/* in WORK(1:MN). */
+
+/* Determine RANK using incremental condition estimation */
+
+ work[ismin] = 1.;
+ work[ismax] = 1.;
+ smax = (d__1 = a[a_dim1 + 1], abs(d__1));
+ smin = smax;
+ if ((d__1 = a[a_dim1 + 1], abs(d__1)) == 0.) {
+ *rank = 0;
+ i__1 = max(*m,*n);
+ dlaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb);
+ goto L100;
+ } else {
+ *rank = 1;
+ }
+
+L10:
+ if (*rank < mn) {
+ i__ = *rank + 1;
+ dlaic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[
+ i__ + i__ * a_dim1], &sminpr, &s1, &c1);
+ dlaic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[
+ i__ + i__ * a_dim1], &smaxpr, &s2, &c2);
+
+ if (smaxpr * *rcond <= sminpr) {
+ i__1 = *rank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[ismin + i__ - 1] = s1 * work[ismin + i__ - 1];
+ work[ismax + i__ - 1] = s2 * work[ismax + i__ - 1];
+/* L20: */
+ }
+ work[ismin + *rank] = c1;
+ work[ismax + *rank] = c2;
+ smin = sminpr;
+ smax = smaxpr;
+ ++(*rank);
+ goto L10;
+ }
+ }
+
+/* Logically partition R = [ R11 R12 ] */
+/* [ 0 R22 ] */
+/* where R11 = R(1:RANK,1:RANK) */
+
+/* [R11,R12] = [ T11, 0 ] * Y */
+
+ if (*rank < *n) {
+ dtzrqf_(rank, n, &a[a_offset], lda, &work[mn + 1], info);
+ }
+
+/* Details of Householder rotations stored in WORK(MN+1:2*MN) */
+
+/* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */
+
+ dorm2r_("Left", "Transpose", m, nrhs, &mn, &a[a_offset], lda, &work[1], &
+ b[b_offset], ldb, &work[(mn << 1) + 1], info);
+
+/* workspace NRHS */
+
+/* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */
+
+ dtrsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b36, &
+ a[a_offset], lda, &b[b_offset], ldb);
+
+ i__1 = *n;
+ for (i__ = *rank + 1; i__ <= i__1; ++i__) {
+ i__2 = *nrhs;
+ for (j = 1; j <= i__2; ++j) {
+ b[i__ + j * b_dim1] = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) */
+
+ if (*rank < *n) {
+ i__1 = *rank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n - *rank + 1;
+ dlatzm_("Left", &i__2, nrhs, &a[i__ + (*rank + 1) * a_dim1], lda,
+ &work[mn + i__], &b[i__ + b_dim1], &b[*rank + 1 + b_dim1],
+ ldb, &work[(mn << 1) + 1]);
+/* L50: */
+ }
+ }
+
+/* workspace NRHS */
+
+/* B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[(mn << 1) + i__] = 1.;
+/* L60: */
+ }
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[(mn << 1) + i__] == 1.) {
+ if (jpvt[i__] != i__) {
+ k = i__;
+ t1 = b[k + j * b_dim1];
+ t2 = b[jpvt[k] + j * b_dim1];
+L70:
+ b[jpvt[k] + j * b_dim1] = t1;
+ work[(mn << 1) + k] = 0.;
+ t1 = t2;
+ k = jpvt[k];
+ t2 = b[jpvt[k] + j * b_dim1];
+ if (jpvt[k] != i__) {
+ goto L70;
+ }
+ b[i__ + j * b_dim1] = t1;
+ work[(mn << 1) + k] = 0.;
+ }
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Undo scaling */
+
+ if (iascl == 1) {
+ dlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
+ info);
+ dlascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset],
+ lda, info);
+ } else if (iascl == 2) {
+ dlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
+ info);
+ dlascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset],
+ lda, info);
+ }
+ if (ibscl == 1) {
+ dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ } else if (ibscl == 2) {
+ dlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ }
+
+L100:
+
+ return 0;
+
+/* End of DGELSX */
+
+} /* dgelsx_ */
diff --git a/SRC/dgelsy.c b/SRC/dgelsy.c
new file mode 100644
index 0000000..0ae3452
--- /dev/null
+++ b/SRC/dgelsy.c
@@ -0,0 +1,495 @@
+/* dgelsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static doublereal c_b31 = 0.;
+static integer c__2 = 2;
+static doublereal c_b54 = 1.;
+
+/* Subroutine */ int dgelsy_(integer *m, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *
+ jpvt, doublereal *rcond, integer *rank, doublereal *work, integer *
+ lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal c1, c2, s1, s2;
+ integer nb, mn, nb1, nb2, nb3, nb4;
+ doublereal anrm, bnrm, smin, smax;
+ integer iascl, ibscl;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer ismin, ismax;
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), dlaic1_(
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *);
+ doublereal wsize;
+ extern /* Subroutine */ int dgeqp3_(integer *, integer *, doublereal *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), dlaset_(char *, integer *, integer
+ *, doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ doublereal bignum;
+ integer lwkmin;
+ extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ doublereal sminpr, smaxpr, smlnum;
+ extern /* Subroutine */ int dormrz_(char *, char *, integer *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int dtzrzf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGELSY computes the minimum-norm solution to a real linear least */
+/* squares problem: */
+/* minimize || A * X - B || */
+/* using a complete orthogonal factorization of A. A is an M-by-N */
+/* matrix which may be rank-deficient. */
+
+/* Several right hand side vectors b and solution vectors x can be */
+/* handled in a single call; they are stored as the columns of the */
+/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
+/* matrix X. */
+
+/* The routine first computes a QR factorization with column pivoting: */
+/* A * P = Q * [ R11 R12 ] */
+/* [ 0 R22 ] */
+/* with R11 defined as the largest leading submatrix whose estimated */
+/* condition number is less than 1/RCOND. The order of R11, RANK, */
+/* is the effective rank of A. */
+
+/* Then, R22 is considered to be negligible, and R12 is annihilated */
+/* by orthogonal transformations from the right, arriving at the */
+/* complete orthogonal factorization: */
+/* A * P = Q * [ T11 0 ] * Z */
+/* [ 0 0 ] */
+/* The minimum-norm solution is then */
+/* X = P * Z' [ inv(T11)*Q1'*B ] */
+/* [ 0 ] */
+/* where Q1 consists of the first RANK columns of Q. */
+
+/* This routine is basically identical to the original xGELSX except */
+/* three differences: */
+/* o The call to the subroutine xGEQPF has been substituted by the */
+/* the call to the subroutine xGEQP3. This subroutine is a Blas-3 */
+/* version of the QR factorization with column pivoting. */
+/* o Matrix B (the right hand side) is updated with Blas-3. */
+/* o The permutation of matrix B (the right hand side) is faster and */
+/* more simple. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of */
+/* columns of matrices B and X. NRHS >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A has been overwritten by details of its */
+/* complete orthogonal factorization. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the M-by-NRHS right hand side matrix B. */
+/* On exit, the N-by-NRHS solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M,N). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
+/* to the front of AP, otherwise column i is a free column. */
+/* On exit, if JPVT(i) = k, then the i-th column of AP */
+/* was the k-th column of A. */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* RCOND is used to determine the effective rank of A, which */
+/* is defined as the order of the largest leading triangular */
+/* submatrix R11 in the QR factorization with pivoting of A, */
+/* whose estimated condition number < 1/RCOND. */
+
+/* RANK (output) INTEGER */
+/* The effective rank of A, i.e., the order of the submatrix */
+/* R11. This is the same as the order of the submatrix T11 */
+/* in the complete orthogonal factorization of A. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* The unblocked strategy requires that: */
+/* LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ), */
+/* where MN = min( M, N ). */
+/* The block algorithm requires that: */
+/* LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ), */
+/* where NB is an upper bound on the blocksize returned */
+/* by ILAENV for the routines DGEQP3, DTZRZF, STZRQF, DORMQR, */
+/* and DORMRZ. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: If INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+/* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
+/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --jpvt;
+ --work;
+
+ /* Function Body */
+ mn = min(*m,*n);
+ ismin = mn + 1;
+ ismax = (mn << 1) + 1;
+
+/* Test the input arguments. */
+
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ if (*ldb < max(i__1,*n)) {
+ *info = -7;
+ }
+ }
+
+/* Figure out optimal block size */
+
+ if (*info == 0) {
+ if (mn == 0 || *nrhs == 0) {
+ lwkmin = 1;
+ lwkopt = 1;
+ } else {
+ nb1 = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1);
+ nb3 = ilaenv_(&c__1, "DORMQR", " ", m, n, nrhs, &c_n1);
+ nb4 = ilaenv_(&c__1, "DORMRQ", " ", m, n, nrhs, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2), i__1 = max(i__1,nb3);
+ nb = max(i__1,nb4);
+/* Computing MAX */
+ i__1 = mn << 1, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = mn +
+ *nrhs;
+ lwkmin = mn + max(i__1,i__2);
+/* Computing MAX */
+ i__1 = lwkmin, i__2 = mn + (*n << 1) + nb * (*n + 1), i__1 = max(
+ i__1,i__2), i__2 = (mn << 1) + nb * *nrhs;
+ lwkopt = max(i__1,i__2);
+ }
+ work[1] = (doublereal) lwkopt;
+
+ if (*lwork < lwkmin && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGELSY", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (mn == 0 || *nrhs == 0) {
+ *rank = 0;
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ smlnum = dlamch_("S") / dlamch_("P");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Scale A, B if max entries outside range [SMLNUM,BIGNUM] */
+
+ anrm = dlange_("M", m, n, &a[a_offset], lda, &work[1]);
+ iascl = 0;
+ if (anrm > 0. && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 2;
+ } else if (anrm == 0.) {
+
+/* Matrix all zero. Return zero solution. */
+
+ i__1 = max(*m,*n);
+ dlaset_("F", &i__1, nrhs, &c_b31, &c_b31, &b[b_offset], ldb);
+ *rank = 0;
+ goto L70;
+ }
+
+ bnrm = dlange_("M", m, nrhs, &b[b_offset], ldb, &work[1]);
+ ibscl = 0;
+ if (bnrm > 0. && bnrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 1;
+ } else if (bnrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ dlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 2;
+ }
+
+/* Compute QR factorization with column pivoting of A: */
+/* A * P = Q * R */
+
+ i__1 = *lwork - mn;
+ dgeqp3_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], &i__1,
+ info);
+ wsize = mn + work[mn + 1];
+
+/* workspace: MN+2*N+NB*(N+1). */
+/* Details of Householder rotations stored in WORK(1:MN). */
+
+/* Determine RANK using incremental condition estimation */
+
+ work[ismin] = 1.;
+ work[ismax] = 1.;
+ smax = (d__1 = a[a_dim1 + 1], abs(d__1));
+ smin = smax;
+ if ((d__1 = a[a_dim1 + 1], abs(d__1)) == 0.) {
+ *rank = 0;
+ i__1 = max(*m,*n);
+ dlaset_("F", &i__1, nrhs, &c_b31, &c_b31, &b[b_offset], ldb);
+ goto L70;
+ } else {
+ *rank = 1;
+ }
+
+L10:
+ if (*rank < mn) {
+ i__ = *rank + 1;
+ dlaic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[
+ i__ + i__ * a_dim1], &sminpr, &s1, &c1);
+ dlaic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[
+ i__ + i__ * a_dim1], &smaxpr, &s2, &c2);
+
+ if (smaxpr * *rcond <= sminpr) {
+ i__1 = *rank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[ismin + i__ - 1] = s1 * work[ismin + i__ - 1];
+ work[ismax + i__ - 1] = s2 * work[ismax + i__ - 1];
+/* L20: */
+ }
+ work[ismin + *rank] = c1;
+ work[ismax + *rank] = c2;
+ smin = sminpr;
+ smax = smaxpr;
+ ++(*rank);
+ goto L10;
+ }
+ }
+
+/* workspace: 3*MN. */
+
+/* Logically partition R = [ R11 R12 ] */
+/* [ 0 R22 ] */
+/* where R11 = R(1:RANK,1:RANK) */
+
+/* [R11,R12] = [ T11, 0 ] * Y */
+
+ if (*rank < *n) {
+ i__1 = *lwork - (mn << 1);
+ dtzrzf_(rank, n, &a[a_offset], lda, &work[mn + 1], &work[(mn << 1) +
+ 1], &i__1, info);
+ }
+
+/* workspace: 2*MN. */
+/* Details of Householder rotations stored in WORK(MN+1:2*MN) */
+
+/* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */
+
+ i__1 = *lwork - (mn << 1);
+ dormqr_("Left", "Transpose", m, nrhs, &mn, &a[a_offset], lda, &work[1], &
+ b[b_offset], ldb, &work[(mn << 1) + 1], &i__1, info);
+/* Computing MAX */
+ d__1 = wsize, d__2 = (mn << 1) + work[(mn << 1) + 1];
+ wsize = max(d__1,d__2);
+
+/* workspace: 2*MN+NB*NRHS. */
+
+/* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */
+
+ dtrsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b54, &
+ a[a_offset], lda, &b[b_offset], ldb);
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = *rank + 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) */
+
+ if (*rank < *n) {
+ i__1 = *n - *rank;
+ i__2 = *lwork - (mn << 1);
+ dormrz_("Left", "Transpose", n, nrhs, rank, &i__1, &a[a_offset], lda,
+ &work[mn + 1], &b[b_offset], ldb, &work[(mn << 1) + 1], &i__2,
+ info);
+ }
+
+/* workspace: 2*MN+NRHS. */
+
+/* B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[jpvt[i__]] = b[i__ + j * b_dim1];
+/* L50: */
+ }
+ dcopy_(n, &work[1], &c__1, &b[j * b_dim1 + 1], &c__1);
+/* L60: */
+ }
+
+/* workspace: N. */
+
+/* Undo scaling */
+
+ if (iascl == 1) {
+ dlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
+ info);
+ dlascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset],
+ lda, info);
+ } else if (iascl == 2) {
+ dlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
+ info);
+ dlascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset],
+ lda, info);
+ }
+ if (ibscl == 1) {
+ dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ } else if (ibscl == 2) {
+ dlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ }
+
+L70:
+ work[1] = (doublereal) lwkopt;
+
+ return 0;
+
+/* End of DGELSY */
+
+} /* dgelsy_ */
diff --git a/SRC/dgeql2.c b/SRC/dgeql2.c
new file mode 100644
index 0000000..07cd966
--- /dev/null
+++ b/SRC/dgeql2.c
@@ -0,0 +1,159 @@
+/* dgeql2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dgeql2_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *tau, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, k;
+ doublereal aii;
+ extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *), dlarfp_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGEQL2 computes a QL factorization of a real m by n matrix A: */
+/* A = Q * L. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the m by n matrix A. */
+/* On exit, if m >= n, the lower triangle of the subarray */
+/* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L; */
+/* if m <= n, the elements on and below the (n-m)-th */
+/* superdiagonal contain the m by n lower trapezoidal matrix L; */
+/* the remaining elements, with the array TAU, represent the */
+/* orthogonal matrix Q as a product of elementary reflectors */
+/* (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in */
+/* A(1:m-k+i-1,n-k+i), and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGEQL2", &i__1);
+ return 0;
+ }
+
+ k = min(*m,*n);
+
+ for (i__ = k; i__ >= 1; --i__) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* A(1:m-k+i-1,n-k+i) */
+
+ i__1 = *m - k + i__;
+ dlarfp_(&i__1, &a[*m - k + i__ + (*n - k + i__) * a_dim1], &a[(*n - k
+ + i__) * a_dim1 + 1], &c__1, &tau[i__]);
+
+/* Apply H(i) to A(1:m-k+i,1:n-k+i-1) from the left */
+
+ aii = a[*m - k + i__ + (*n - k + i__) * a_dim1];
+ a[*m - k + i__ + (*n - k + i__) * a_dim1] = 1.;
+ i__1 = *m - k + i__;
+ i__2 = *n - k + i__ - 1;
+ dlarf_("Left", &i__1, &i__2, &a[(*n - k + i__) * a_dim1 + 1], &c__1, &
+ tau[i__], &a[a_offset], lda, &work[1]);
+ a[*m - k + i__ + (*n - k + i__) * a_dim1] = aii;
+/* L10: */
+ }
+ return 0;
+
+/* End of DGEQL2 */
+
+} /* dgeql2_ */
diff --git a/SRC/dgeqlf.c b/SRC/dgeqlf.c
new file mode 100644
index 0000000..0b97795
--- /dev/null
+++ b/SRC/dgeqlf.c
@@ -0,0 +1,270 @@
+/* dgeqlf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int dgeqlf_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *tau, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, k, ib, nb, ki, kk, mu, nu, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int dgeql2_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *), dlarfb_(char *,
+ char *, char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *), dlarft_(char *, char *, integer *, integer *, doublereal
+ *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGEQLF computes a QL factorization of a real M-by-N matrix A: */
+/* A = Q * L. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, */
+/* if m >= n, the lower triangle of the subarray */
+/* A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L; */
+/* if m <= n, the elements on and below the (n-m)-th */
+/* superdiagonal contain the M-by-N lower trapezoidal matrix L; */
+/* the remaining elements, with the array TAU, represent the */
+/* orthogonal matrix Q as a product of elementary reflectors */
+/* (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* For optimum performance LWORK >= N*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in */
+/* A(1:m-k+i-1,n-k+i), and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+
+ if (*info == 0) {
+ k = min(*m,*n);
+ if (k == 0) {
+ lwkopt = 1;
+ } else {
+ nb = ilaenv_(&c__1, "DGEQLF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ }
+ work[1] = (doublereal) lwkopt;
+
+ if (*lwork < max(1,*n) && ! lquery) {
+ *info = -7;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGEQLF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (k == 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 1;
+ iws = *n;
+ if (nb > 1 && nb < k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "DGEQLF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *n;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "DGEQLF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < k && nx < k) {
+
+/* Use blocked code initially. */
+/* The last kk columns are handled by the block method. */
+
+ ki = (k - nx - 1) / nb * nb;
+/* Computing MIN */
+ i__1 = k, i__2 = ki + nb;
+ kk = min(i__1,i__2);
+
+ i__1 = k - kk + 1;
+ i__2 = -nb;
+ for (i__ = k - kk + ki + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__
+ += i__2) {
+/* Computing MIN */
+ i__3 = k - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Compute the QL factorization of the current block */
+/* A(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1) */
+
+ i__3 = *m - k + i__ + ib - 1;
+ dgeql2_(&i__3, &ib, &a[(*n - k + i__) * a_dim1 + 1], lda, &tau[
+ i__], &work[1], &iinfo);
+ if (*n - k + i__ > 1) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__3 = *m - k + i__ + ib - 1;
+ dlarft_("Backward", "Columnwise", &i__3, &ib, &a[(*n - k +
+ i__) * a_dim1 + 1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H' to A(1:m-k+i+ib-1,1:n-k+i-1) from the left */
+
+ i__3 = *m - k + i__ + ib - 1;
+ i__4 = *n - k + i__ - 1;
+ dlarfb_("Left", "Transpose", "Backward", "Columnwise", &i__3,
+ &i__4, &ib, &a[(*n - k + i__) * a_dim1 + 1], lda, &
+ work[1], &ldwork, &a[a_offset], lda, &work[ib + 1], &
+ ldwork);
+ }
+/* L10: */
+ }
+ mu = *m - k + i__ + nb - 1;
+ nu = *n - k + i__ + nb - 1;
+ } else {
+ mu = *m;
+ nu = *n;
+ }
+
+/* Use unblocked code to factor the last or only block */
+
+ if (mu > 0 && nu > 0) {
+ dgeql2_(&mu, &nu, &a[a_offset], lda, &tau[1], &work[1], &iinfo);
+ }
+
+ work[1] = (doublereal) iws;
+ return 0;
+
+/* End of DGEQLF */
+
+} /* dgeqlf_ */
diff --git a/SRC/dgeqp3.c b/SRC/dgeqp3.c
new file mode 100644
index 0000000..e3fda57
--- /dev/null
+++ b/SRC/dgeqp3.c
@@ -0,0 +1,358 @@
+/* dgeqp3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int dgeqp3_(integer *m, integer *n, doublereal *a, integer *
+ lda, integer *jpvt, doublereal *tau, doublereal *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer j, jb, na, nb, sm, sn, nx, fjb, iws, nfxd;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ integer nbmin, minmn;
+ extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer minws;
+ extern /* Subroutine */ int dlaqp2_(integer *, integer *, integer *,
+ doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *), dgeqrf_(integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dlaqps_(integer *, integer *, integer *,
+ integer *, integer *, doublereal *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *);
+ integer topbmn, sminmn;
+ extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGEQP3 computes a QR factorization with column pivoting of a */
+/* matrix A: A*P = Q*R using Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the upper triangle of the array contains the */
+/* min(M,N)-by-N upper trapezoidal matrix R; the elements below */
+/* the diagonal, together with the array TAU, represent the */
+/* orthogonal matrix Q as a product of min(M,N) elementary */
+/* reflectors. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* On entry, if JPVT(J).ne.0, the J-th column of A is permuted */
+/* to the front of A*P (a leading column); if JPVT(J)=0, */
+/* the J-th column of A is a free column. */
+/* On exit, if JPVT(J)=K, then the J-th column of A*P was the */
+/* the K-th column of A. */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO=0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= 3*N+1. */
+/* For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB */
+/* is the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real/complex scalar, and v is a real/complex vector */
+/* with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in */
+/* A(i+1:m,i), and tau in TAU(i). */
+
+/* Based on contributions by */
+/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
+/* X. Sun, Computer Science Dept., Duke University, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test input arguments */
+/* ==================== */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --jpvt;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+
+ if (*info == 0) {
+ minmn = min(*m,*n);
+ if (minmn == 0) {
+ iws = 1;
+ lwkopt = 1;
+ } else {
+ iws = *n * 3 + 1;
+ nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = (*n << 1) + (*n + 1) * nb;
+ }
+ work[1] = (doublereal) lwkopt;
+
+ if (*lwork < iws && ! lquery) {
+ *info = -8;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGEQP3", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (minmn == 0) {
+ return 0;
+ }
+
+/* Move initial columns up front. */
+
+ nfxd = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (jpvt[j] != 0) {
+ if (j != nfxd) {
+ dswap_(m, &a[j * a_dim1 + 1], &c__1, &a[nfxd * a_dim1 + 1], &
+ c__1);
+ jpvt[j] = jpvt[nfxd];
+ jpvt[nfxd] = j;
+ } else {
+ jpvt[j] = j;
+ }
+ ++nfxd;
+ } else {
+ jpvt[j] = j;
+ }
+/* L10: */
+ }
+ --nfxd;
+
+/* Factorize fixed columns */
+/* ======================= */
+
+/* Compute the QR factorization of fixed columns and update */
+/* remaining columns. */
+
+ if (nfxd > 0) {
+ na = min(*m,nfxd);
+/* CC CALL DGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) */
+ dgeqrf_(m, &na, &a[a_offset], lda, &tau[1], &work[1], lwork, info);
+/* Computing MAX */
+ i__1 = iws, i__2 = (integer) work[1];
+ iws = max(i__1,i__2);
+ if (na < *n) {
+/* CC CALL DORM2R( 'Left', 'Transpose', M, N-NA, NA, A, LDA, */
+/* CC $ TAU, A( 1, NA+1 ), LDA, WORK, INFO ) */
+ i__1 = *n - na;
+ dormqr_("Left", "Transpose", m, &i__1, &na, &a[a_offset], lda, &
+ tau[1], &a[(na + 1) * a_dim1 + 1], lda, &work[1], lwork,
+ info);
+/* Computing MAX */
+ i__1 = iws, i__2 = (integer) work[1];
+ iws = max(i__1,i__2);
+ }
+ }
+
+/* Factorize free columns */
+/* ====================== */
+
+ if (nfxd < minmn) {
+
+ sm = *m - nfxd;
+ sn = *n - nfxd;
+ sminmn = minmn - nfxd;
+
+/* Determine the block size. */
+
+ nb = ilaenv_(&c__1, "DGEQRF", " ", &sm, &sn, &c_n1, &c_n1);
+ nbmin = 2;
+ nx = 0;
+
+ if (nb > 1 && nb < sminmn) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "DGEQRF", " ", &sm, &sn, &c_n1, &
+ c_n1);
+ nx = max(i__1,i__2);
+
+
+ if (nx < sminmn) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ minws = (sn << 1) + (sn + 1) * nb;
+ iws = max(iws,minws);
+ if (*lwork < minws) {
+
+/* Not enough workspace to use optimal NB: Reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = (*lwork - (sn << 1)) / (sn + 1);
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "DGEQRF", " ", &sm, &sn, &
+ c_n1, &c_n1);
+ nbmin = max(i__1,i__2);
+
+
+ }
+ }
+ }
+
+/* Initialize partial column norms. The first N elements of work */
+/* store the exact column norms. */
+
+ i__1 = *n;
+ for (j = nfxd + 1; j <= i__1; ++j) {
+ work[j] = dnrm2_(&sm, &a[nfxd + 1 + j * a_dim1], &c__1);
+ work[*n + j] = work[j];
+/* L20: */
+ }
+
+ if (nb >= nbmin && nb < sminmn && nx < sminmn) {
+
+/* Use blocked code initially. */
+
+ j = nfxd + 1;
+
+/* Compute factorization: while loop. */
+
+
+ topbmn = minmn - nx;
+L30:
+ if (j <= topbmn) {
+/* Computing MIN */
+ i__1 = nb, i__2 = topbmn - j + 1;
+ jb = min(i__1,i__2);
+
+/* Factorize JB columns among columns J:N. */
+
+ i__1 = *n - j + 1;
+ i__2 = j - 1;
+ i__3 = *n - j + 1;
+ dlaqps_(m, &i__1, &i__2, &jb, &fjb, &a[j * a_dim1 + 1], lda, &
+ jpvt[j], &tau[j], &work[j], &work[*n + j], &work[(*n
+ << 1) + 1], &work[(*n << 1) + jb + 1], &i__3);
+
+ j += fjb;
+ goto L30;
+ }
+ } else {
+ j = nfxd + 1;
+ }
+
+/* Use unblocked code to factor the last or only block. */
+
+
+ if (j <= minmn) {
+ i__1 = *n - j + 1;
+ i__2 = j - 1;
+ dlaqp2_(m, &i__1, &i__2, &a[j * a_dim1 + 1], lda, &jpvt[j], &tau[
+ j], &work[j], &work[*n + j], &work[(*n << 1) + 1]);
+ }
+
+ }
+
+ work[1] = (doublereal) iws;
+ return 0;
+
+/* End of DGEQP3 */
+
+} /* dgeqp3_ */
diff --git a/SRC/dgeqpf.c b/SRC/dgeqpf.c
new file mode 100644
index 0000000..10743f5
--- /dev/null
+++ b/SRC/dgeqpf.c
@@ -0,0 +1,304 @@
+/* dgeqpf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dgeqpf_(integer *m, integer *n, doublereal *a, integer *
+ lda, integer *jpvt, doublereal *tau, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, ma, mn;
+ doublereal aii;
+ integer pvt;
+ doublereal temp;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ doublereal temp2, tol3z;
+ extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *);
+ integer itemp;
+ extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dgeqr2_(integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *),
+ dorm2r_(char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dlarfp_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK deprecated driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine DGEQP3. */
+
+/* DGEQPF computes a QR factorization with column pivoting of a */
+/* real M-by-N matrix A: A*P = Q*R. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0 */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the upper triangle of the array contains the */
+/* min(M,N)-by-N upper triangular matrix R; the elements */
+/* below the diagonal, together with the array TAU, */
+/* represent the orthogonal matrix Q as a product of */
+/* min(m,n) elementary reflectors. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
+/* to the front of A*P (a leading column); if JPVT(i) = 0, */
+/* the i-th column of A is a free column. */
+/* On exit, if JPVT(i) = k, then the i-th column of A*P */
+/* was the k-th column of A. */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(n) */
+
+/* Each H(i) has the form */
+
+/* H = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). */
+
+/* The matrix P is represented in jpvt as follows: If */
+/* jpvt(j) = i */
+/* then the jth column of P is the ith canonical unit vector. */
+
+/* Partial column norm updating strategy modified by */
+/* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */
+/* University of Zagreb, Croatia. */
+/* June 2006. */
+/* For more details see LAPACK Working Note 176. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --jpvt;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGEQPF", &i__1);
+ return 0;
+ }
+
+ mn = min(*m,*n);
+ tol3z = sqrt(dlamch_("Epsilon"));
+
+/* Move initial columns up front */
+
+ itemp = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (jpvt[i__] != 0) {
+ if (i__ != itemp) {
+ dswap_(m, &a[i__ * a_dim1 + 1], &c__1, &a[itemp * a_dim1 + 1],
+ &c__1);
+ jpvt[i__] = jpvt[itemp];
+ jpvt[itemp] = i__;
+ } else {
+ jpvt[i__] = i__;
+ }
+ ++itemp;
+ } else {
+ jpvt[i__] = i__;
+ }
+/* L10: */
+ }
+ --itemp;
+
+/* Compute the QR factorization and update remaining columns */
+
+ if (itemp > 0) {
+ ma = min(itemp,*m);
+ dgeqr2_(m, &ma, &a[a_offset], lda, &tau[1], &work[1], info);
+ if (ma < *n) {
+ i__1 = *n - ma;
+ dorm2r_("Left", "Transpose", m, &i__1, &ma, &a[a_offset], lda, &
+ tau[1], &a[(ma + 1) * a_dim1 + 1], lda, &work[1], info);
+ }
+ }
+
+ if (itemp < mn) {
+
+/* Initialize partial column norms. The first n elements of */
+/* work store the exact column norms. */
+
+ i__1 = *n;
+ for (i__ = itemp + 1; i__ <= i__1; ++i__) {
+ i__2 = *m - itemp;
+ work[i__] = dnrm2_(&i__2, &a[itemp + 1 + i__ * a_dim1], &c__1);
+ work[*n + i__] = work[i__];
+/* L20: */
+ }
+
+/* Compute factorization */
+
+ i__1 = mn;
+ for (i__ = itemp + 1; i__ <= i__1; ++i__) {
+
+/* Determine ith pivot column and swap if necessary */
+
+ i__2 = *n - i__ + 1;
+ pvt = i__ - 1 + idamax_(&i__2, &work[i__], &c__1);
+
+ if (pvt != i__) {
+ dswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
+ c__1);
+ itemp = jpvt[pvt];
+ jpvt[pvt] = jpvt[i__];
+ jpvt[i__] = itemp;
+ work[pvt] = work[i__];
+ work[*n + pvt] = work[*n + i__];
+ }
+
+/* Generate elementary reflector H(i) */
+
+ if (i__ < *m) {
+ i__2 = *m - i__ + 1;
+ dlarfp_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + 1 + i__ *
+ a_dim1], &c__1, &tau[i__]);
+ } else {
+ dlarfp_(&c__1, &a[*m + *m * a_dim1], &a[*m + *m * a_dim1], &
+ c__1, &tau[*m]);
+ }
+
+ if (i__ < *n) {
+
+/* Apply H(i) to A(i:m,i+1:n) from the left */
+
+ aii = a[i__ + i__ * a_dim1];
+ a[i__ + i__ * a_dim1] = 1.;
+ i__2 = *m - i__ + 1;
+ i__3 = *n - i__;
+ dlarf_("LEFT", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
+ tau[i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[(*
+ n << 1) + 1]);
+ a[i__ + i__ * a_dim1] = aii;
+ }
+
+/* Update partial column norms */
+
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (work[j] != 0.) {
+
+/* NOTE: The following 4 lines follow from the analysis in */
+/* Lapack Working Note 176. */
+
+ temp = (d__1 = a[i__ + j * a_dim1], abs(d__1)) / work[j];
+/* Computing MAX */
+ d__1 = 0., d__2 = (temp + 1.) * (1. - temp);
+ temp = max(d__1,d__2);
+/* Computing 2nd power */
+ d__1 = work[j] / work[*n + j];
+ temp2 = temp * (d__1 * d__1);
+ if (temp2 <= tol3z) {
+ if (*m - i__ > 0) {
+ i__3 = *m - i__;
+ work[j] = dnrm2_(&i__3, &a[i__ + 1 + j * a_dim1],
+ &c__1);
+ work[*n + j] = work[j];
+ } else {
+ work[j] = 0.;
+ work[*n + j] = 0.;
+ }
+ } else {
+ work[j] *= sqrt(temp);
+ }
+ }
+/* L30: */
+ }
+
+/* L40: */
+ }
+ }
+ return 0;
+
+/* End of DGEQPF */
+
+} /* dgeqpf_ */
diff --git a/SRC/dgeqr2.c b/SRC/dgeqr2.c
new file mode 100644
index 0000000..663388f
--- /dev/null
+++ b/SRC/dgeqr2.c
@@ -0,0 +1,161 @@
+/* dgeqr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dgeqr2_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *tau, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, k;
+ doublereal aii;
+ extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *), dlarfp_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGEQR2 computes a QR factorization of a real m by n matrix A: */
+/* A = Q * R. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the m by n matrix A. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(m,n) by n upper trapezoidal matrix R (R is */
+/* upper triangular if m >= n); the elements below the diagonal, */
+/* with the array TAU, represent the orthogonal matrix Q as a */
+/* product of elementary reflectors (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */
+/* and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGEQR2", &i__1);
+ return 0;
+ }
+
+ k = min(*m,*n);
+
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
+
+ i__2 = *m - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ dlarfp_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3, *m)+ i__ * a_dim1]
+, &c__1, &tau[i__]);
+ if (i__ < *n) {
+
+/* Apply H(i) to A(i:m,i+1:n) from the left */
+
+ aii = a[i__ + i__ * a_dim1];
+ a[i__ + i__ * a_dim1] = 1.;
+ i__2 = *m - i__ + 1;
+ i__3 = *n - i__;
+ dlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &tau[
+ i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
+ a[i__ + i__ * a_dim1] = aii;
+ }
+/* L10: */
+ }
+ return 0;
+
+/* End of DGEQR2 */
+
+} /* dgeqr2_ */
diff --git a/SRC/dgeqrf.c b/SRC/dgeqrf.c
new file mode 100644
index 0000000..1062e27
--- /dev/null
+++ b/SRC/dgeqrf.c
@@ -0,0 +1,252 @@
+/* dgeqrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int dgeqrf_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *tau, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, k, ib, nb, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *), dlarfb_(char *,
+ char *, char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *), dlarft_(char *, char *, integer *, integer *, doublereal
+ *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGEQRF computes a QR factorization of a real M-by-N matrix A: */
+/* A = Q * R. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(M,N)-by-N upper trapezoidal matrix R (R is */
+/* upper triangular if m >= n); the elements below the diagonal, */
+/* with the array TAU, represent the orthogonal matrix Q as a */
+/* product of min(m,n) elementary reflectors (see Further */
+/* Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* For optimum performance LWORK >= N*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */
+/* and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ work[1] = (doublereal) lwkopt;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGEQRF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ k = min(*m,*n);
+ if (k == 0) {
+ work[1] = 1.;
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *n;
+ if (nb > 1 && nb < k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "DGEQRF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *n;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "DGEQRF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < k && nx < k) {
+
+/* Use blocked code initially */
+
+ i__1 = k - nx;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = k - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Compute the QR factorization of the current block */
+/* A(i:m,i:i+ib-1) */
+
+ i__3 = *m - i__ + 1;
+ dgeqr2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
+ 1], &iinfo);
+ if (i__ + ib <= *n) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__3 = *m - i__ + 1;
+ dlarft_("Forward", "Columnwise", &i__3, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H' to A(i:m,i+ib:n) from the left */
+
+ i__3 = *m - i__ + 1;
+ i__4 = *n - i__ - ib + 1;
+ dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__3, &
+ i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
+ ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &work[ib
+ + 1], &ldwork);
+ }
+/* L10: */
+ }
+ } else {
+ i__ = 1;
+ }
+
+/* Use unblocked code to factor the last or only block. */
+
+ if (i__ <= k) {
+ i__2 = *m - i__ + 1;
+ i__1 = *n - i__ + 1;
+ dgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
+, &iinfo);
+ }
+
+ work[1] = (doublereal) iws;
+ return 0;
+
+/* End of DGEQRF */
+
+} /* dgeqrf_ */
diff --git a/SRC/dgerfs.c b/SRC/dgerfs.c
new file mode 100644
index 0000000..d8f941d
--- /dev/null
+++ b/SRC/dgerfs.c
@@ -0,0 +1,424 @@
+/* dgerfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b15 = -1.;
+static doublereal c_b17 = 1.;
+
+/* Subroutine */ int dgerfs_(char *trans, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *
+ ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx,
+ doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal s, xk;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ integer isave[3];
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *);
+ integer count;
+ extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *), dgetrs_(
+ char *, integer *, integer *, doublereal *, integer *, integer *,
+ doublereal *, integer *, integer *);
+ logical notran;
+ char transt[1];
+ doublereal lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGERFS improves the computed solution to a system of linear */
+/* equations and provides error bounds and backward error estimates for */
+/* the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The original N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
+/* The factors L and U from the factorization A = P*L*U */
+/* as computed by DGETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from DGETRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by DGETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldx < max(1,*n)) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGERFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A, A**T, or A**H, depending on TRANS. */
+
+ dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+ dgemv_(trans, n, n, &c_b15, &a[a_offset], lda, &x[j * x_dim1 + 1], &
+ c__1, &c_b17, &work[*n + 1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1));
+/* L30: */
+ }
+
+/* Compute abs(op(A))*abs(X) + abs(B). */
+
+ if (notran) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ work[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * xk;
+/* L40: */
+ }
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 = x[
+ i__ + j * x_dim1], abs(d__2));
+/* L60: */
+ }
+ work[k] += s;
+/* L70: */
+ }
+ }
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[
+ i__];
+ s = max(d__2,d__3);
+ } else {
+/* Computing MAX */
+ d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1)
+ / (work[i__] + safe1);
+ s = max(d__2,d__3);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ dgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[*n
+ + 1], n, info);
+ daxpy_(n, &c_b17, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
+ ;
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use DLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+ kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)**T). */
+
+ dgetrs_(transt, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &
+ work[*n + 1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L110: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L120: */
+ }
+ dgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &
+ work[*n + 1], n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1));
+ lstres = max(d__2,d__3);
+/* L130: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of DGERFS */
+
+} /* dgerfs_ */
diff --git a/SRC/dgerfsx.c b/SRC/dgerfsx.c
new file mode 100644
index 0000000..a9698eb
--- /dev/null
+++ b/SRC/dgerfsx.c
@@ -0,0 +1,666 @@
+/* dgerfsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int dgerfsx_(char *trans, char *equed, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
+ integer *ipiv, doublereal *r__, doublereal *c__, doublereal *b,
+ integer *ldb, doublereal *x, integer *ldx, doublereal *rcond,
+ doublereal *berr, integer *n_err_bnds__, doublereal *err_bnds_norm__,
+ doublereal *err_bnds_comp__, integer *nparams, doublereal *params,
+ doublereal *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal illrcond_thresh__, unstable_thresh__, err_lbnd__;
+ integer ref_type__;
+ extern integer ilatrans_(char *);
+ integer j;
+ doublereal rcond_tmp__;
+ integer prec_type__, trans_type__;
+ extern doublereal dla_gercond__(char *, integer *, doublereal *, integer *
+ , doublereal *, integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, ftnlen);
+ doublereal cwise_wrong__;
+ extern /* Subroutine */ int dla_gerfsx_extended__(integer *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *, logical *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, logical *, integer *);
+ char norm[1];
+ logical ignore_cwise__;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dgecon_(char *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *), xerbla_(char *, integer *);
+ logical colequ, notran, rowequ;
+ extern integer ilaprec_(char *);
+ integer ithresh, n_norms__;
+ doublereal rthresh;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGERFSX improves the computed solution to a system of linear */
+/* equations and provides error bounds and backward error estimates */
+/* for the solution. In addition to normwise error bound, the code */
+/* provides maximum componentwise error bound if possible. See */
+/* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the */
+/* error bounds. */
+
+/* The original system of linear equations may have been equilibrated */
+/* before calling this routine, as described by arguments EQUED, R */
+/* and C below. In this case, the solution and error bounds returned */
+/* are for the original unequilibrated system. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* EQUED (input) CHARACTER*1 */
+/* Specifies the form of equilibration that was done to A */
+/* before calling this routine. This is needed to compute */
+/* the solution and error bounds correctly. */
+/* = 'N': No equilibration */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* The right hand side B has been changed accordingly. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The original N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
+/* The factors L and U from the factorization A = P*L*U */
+/* as computed by DGETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from DGETRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* R (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+/* If R is output, each element of R is a power of the radix. */
+/* If R is input, each element of R should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* C (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+/* If C is output, each element of C is a power of the radix. */
+/* If C is input, each element of C should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by DGETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0D+0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check the input parameters. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ trans_type__ = ilatrans_(trans);
+ ref_type__ = 1;
+ if (*nparams >= 1) {
+ if (params[1] < 0.) {
+ params[1] = 1.;
+ } else {
+ ref_type__ = (integer) params[1];
+ }
+ }
+
+/* Set default parameters. */
+
+ illrcond_thresh__ = (doublereal) (*n) * dlamch_("Epsilon");
+ ithresh = 10;
+ rthresh = .5;
+ unstable_thresh__ = .25;
+ ignore_cwise__ = FALSE_;
+
+ if (*nparams >= 2) {
+ if (params[2] < 0.) {
+ params[2] = (doublereal) ithresh;
+ } else {
+ ithresh = (integer) params[2];
+ }
+ }
+ if (*nparams >= 3) {
+ if (params[3] < 0.) {
+ if (ignore_cwise__) {
+ params[3] = 0.;
+ } else {
+ params[3] = 1.;
+ }
+ } else {
+ ignore_cwise__ = params[3] == 0.;
+ }
+ }
+ if (ref_type__ == 0 || *n_err_bnds__ == 0) {
+ n_norms__ = 0;
+ } else if (ignore_cwise__) {
+ n_norms__ = 1;
+ } else {
+ n_norms__ = 2;
+ }
+
+ notran = lsame_(trans, "N");
+ rowequ = lsame_(equed, "R") || lsame_(equed, "B");
+ colequ = lsame_(equed, "C") || lsame_(equed, "B");
+
+/* Test input parameters. */
+
+ if (trans_type__ == -1) {
+ *info = -1;
+ } else if (! rowequ && ! colequ && ! lsame_(equed, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -13;
+ } else if (*ldx < max(1,*n)) {
+ *info = -15;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGERFSX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *nrhs == 0) {
+ *rcond = 1.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 0.;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.;
+ }
+ }
+ return 0;
+ }
+
+/* Default to failure. */
+
+ *rcond = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 1.;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.;
+ }
+ }
+
+/* Compute the norm of A and the reciprocal of the condition */
+/* number of A. */
+
+ if (notran) {
+ *(unsigned char *)norm = 'I';
+ } else {
+ *(unsigned char *)norm = '1';
+ }
+ anorm = dlange_(norm, n, n, &a[a_offset], lda, &work[1]);
+ dgecon_(norm, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &iwork[1],
+ info);
+
+/* Perform refinement on each right-hand side */
+
+ if (ref_type__ != 0) {
+ prec_type__ = ilaprec_("E");
+ if (notran) {
+ dla_gerfsx_extended__(&prec_type__, &trans_type__, n, nrhs, &a[
+ a_offset], lda, &af[af_offset], ldaf, &ipiv[1], &colequ, &
+ c__[1], &b[b_offset], ldb, &x[x_offset], ldx, &berr[1], &
+ n_norms__, &err_bnds_norm__[err_bnds_norm_offset], &
+ err_bnds_comp__[err_bnds_comp_offset], &work[*n + 1], &
+ work[1], &work[(*n << 1) + 1], &work[1], rcond, &ithresh,
+ &rthresh, &unstable_thresh__, &ignore_cwise__, info);
+ } else {
+ dla_gerfsx_extended__(&prec_type__, &trans_type__, n, nrhs, &a[
+ a_offset], lda, &af[af_offset], ldaf, &ipiv[1], &rowequ, &
+ r__[1], &b[b_offset], ldb, &x[x_offset], ldx, &berr[1], &
+ n_norms__, &err_bnds_norm__[err_bnds_norm_offset], &
+ err_bnds_comp__[err_bnds_comp_offset], &work[*n + 1], &
+ work[1], &work[(*n << 1) + 1], &work[1], rcond, &ithresh,
+ &rthresh, &unstable_thresh__, &ignore_cwise__, info);
+ }
+ }
+/* Computing MAX */
+ d__1 = 10., d__2 = sqrt((doublereal) (*n));
+ err_lbnd__ = max(d__1,d__2) * dlamch_("Epsilon");
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {
+
+/* Compute scaled normwise condition number cond(A*C). */
+
+ if (colequ && notran) {
+ rcond_tmp__ = dla_gercond__(trans, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &c_n1, &c__[1], info, &work[1]
+ , &iwork[1], (ftnlen)1);
+ } else if (rowequ && ! notran) {
+ rcond_tmp__ = dla_gercond__(trans, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &c_n1, &r__[1], info, &work[1]
+ , &iwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = dla_gercond__(trans, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &c__0, &r__[1], info, &work[1]
+ , &iwork[1], (ftnlen)1);
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1
+ << 1)] > 1.) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 0.;
+ if (*info <= *n) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {
+
+/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
+/* each right-hand side using the current solution as an estimate of */
+/* the true solution. If the componentwise error estimate is too */
+/* large, then the solution is a lousy estimate of truth and the */
+/* estimated RCOND may be too optimistic. To avoid misleading users, */
+/* the inverse condition number is set to 0.0 when the estimated */
+/* cwise error is at least CWISE_WRONG. */
+
+ cwise_wrong__ = sqrt(dlamch_("Epsilon"));
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ cwise_wrong__) {
+ rcond_tmp__ = dla_gercond__(trans, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &c__1, &x[j * x_dim1 + 1],
+ info, &work[1], &iwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = 0.;
+ }
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1
+ << 1)] > 1.) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 0.;
+ if (params[3] == 1. && *info < *n + j) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DGERFSX */
+
+} /* dgerfsx_ */
diff --git a/SRC/dgerq2.c b/SRC/dgerq2.c
new file mode 100644
index 0000000..13ccabf
--- /dev/null
+++ b/SRC/dgerq2.c
@@ -0,0 +1,155 @@
+/* dgerq2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgerq2_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *tau, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, k;
+ doublereal aii;
+ extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *), dlarfp_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGERQ2 computes an RQ factorization of a real m by n matrix A: */
+/* A = R * Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the m by n matrix A. */
+/* On exit, if m <= n, the upper triangle of the subarray */
+/* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R; */
+/* if m >= n, the elements on and above the (m-n)-th subdiagonal */
+/* contain the m by n upper trapezoidal matrix R; the remaining */
+/* elements, with the array TAU, represent the orthogonal matrix */
+/* Q as a product of elementary reflectors (see Further */
+/* Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in */
+/* A(m-k+i,1:n-k+i-1), and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGERQ2", &i__1);
+ return 0;
+ }
+
+ k = min(*m,*n);
+
+ for (i__ = k; i__ >= 1; --i__) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* A(m-k+i,1:n-k+i-1) */
+
+ i__1 = *n - k + i__;
+ dlarfp_(&i__1, &a[*m - k + i__ + (*n - k + i__) * a_dim1], &a[*m - k
+ + i__ + a_dim1], lda, &tau[i__]);
+
+/* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right */
+
+ aii = a[*m - k + i__ + (*n - k + i__) * a_dim1];
+ a[*m - k + i__ + (*n - k + i__) * a_dim1] = 1.;
+ i__1 = *m - k + i__ - 1;
+ i__2 = *n - k + i__;
+ dlarf_("Right", &i__1, &i__2, &a[*m - k + i__ + a_dim1], lda, &tau[
+ i__], &a[a_offset], lda, &work[1]);
+ a[*m - k + i__ + (*n - k + i__) * a_dim1] = aii;
+/* L10: */
+ }
+ return 0;
+
+/* End of DGERQ2 */
+
+} /* dgerq2_ */
diff --git a/SRC/dgerqf.c b/SRC/dgerqf.c
new file mode 100644
index 0000000..1d78250
--- /dev/null
+++ b/SRC/dgerqf.c
@@ -0,0 +1,269 @@
+/* dgerqf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int dgerqf_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *tau, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, k, ib, nb, ki, kk, mu, nu, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int dgerq2_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *), dlarfb_(char *,
+ char *, char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *), dlarft_(char *, char *, integer *, integer *, doublereal
+ *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGERQF computes an RQ factorization of a real M-by-N matrix A: */
+/* A = R * Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, */
+/* if m <= n, the upper triangle of the subarray */
+/* A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R; */
+/* if m >= n, the elements on and above the (m-n)-th subdiagonal */
+/* contain the M-by-N upper trapezoidal matrix R; */
+/* the remaining elements, with the array TAU, represent the */
+/* orthogonal matrix Q as a product of min(m,n) elementary */
+/* reflectors (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M). */
+/* For optimum performance LWORK >= M*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in */
+/* A(m-k+i,1:n-k+i-1), and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+
+ if (*info == 0) {
+ k = min(*m,*n);
+ if (k == 0) {
+ lwkopt = 1;
+ } else {
+ nb = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = *m * nb;
+ }
+ work[1] = (doublereal) lwkopt;
+
+ if (*lwork < max(1,*m) && ! lquery) {
+ *info = -7;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGERQF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (k == 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 1;
+ iws = *m;
+ if (nb > 1 && nb < k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "DGERQF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *m;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "DGERQF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < k && nx < k) {
+
+/* Use blocked code initially. */
+/* The last kk rows are handled by the block method. */
+
+ ki = (k - nx - 1) / nb * nb;
+/* Computing MIN */
+ i__1 = k, i__2 = ki + nb;
+ kk = min(i__1,i__2);
+
+ i__1 = k - kk + 1;
+ i__2 = -nb;
+ for (i__ = k - kk + ki + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__
+ += i__2) {
+/* Computing MIN */
+ i__3 = k - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Compute the RQ factorization of the current block */
+/* A(m-k+i:m-k+i+ib-1,1:n-k+i+ib-1) */
+
+ i__3 = *n - k + i__ + ib - 1;
+ dgerq2_(&ib, &i__3, &a[*m - k + i__ + a_dim1], lda, &tau[i__], &
+ work[1], &iinfo);
+ if (*m - k + i__ > 1) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__3 = *n - k + i__ + ib - 1;
+ dlarft_("Backward", "Rowwise", &i__3, &ib, &a[*m - k + i__ +
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H to A(1:m-k+i-1,1:n-k+i+ib-1) from the right */
+
+ i__3 = *m - k + i__ - 1;
+ i__4 = *n - k + i__ + ib - 1;
+ dlarfb_("Right", "No transpose", "Backward", "Rowwise", &i__3,
+ &i__4, &ib, &a[*m - k + i__ + a_dim1], lda, &work[1],
+ &ldwork, &a[a_offset], lda, &work[ib + 1], &ldwork);
+ }
+/* L10: */
+ }
+ mu = *m - k + i__ + nb - 1;
+ nu = *n - k + i__ + nb - 1;
+ } else {
+ mu = *m;
+ nu = *n;
+ }
+
+/* Use unblocked code to factor the last or only block */
+
+ if (mu > 0 && nu > 0) {
+ dgerq2_(&mu, &nu, &a[a_offset], lda, &tau[1], &work[1], &iinfo);
+ }
+
+ work[1] = (doublereal) iws;
+ return 0;
+
+/* End of DGERQF */
+
+} /* dgerqf_ */
diff --git a/SRC/dgesc2.c b/SRC/dgesc2.c
new file mode 100644
index 0000000..1f71631
--- /dev/null
+++ b/SRC/dgesc2.c
@@ -0,0 +1,176 @@
+/* dgesc2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dgesc2_(integer *n, doublereal *a, integer *lda,
+ doublereal *rhs, integer *ipiv, integer *jpiv, doublereal *scale)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal eps, temp;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *), dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dlaswp_(integer *, doublereal *, integer *,
+ integer *, integer *, integer *, integer *);
+ doublereal smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGESC2 solves a system of linear equations */
+
+/* A * X = scale* RHS */
+
+/* with a general N-by-N matrix A using the LU factorization with */
+/* complete pivoting computed by DGETC2. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the LU part of the factorization of the n-by-n */
+/* matrix A computed by DGETC2: A = P * L * U * Q */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1, N). */
+
+/* RHS (input/output) DOUBLE PRECISION array, dimension (N). */
+/* On entry, the right hand side vector b. */
+/* On exit, the solution vector X. */
+
+/* IPIV (input) INTEGER array, dimension (N). */
+/* The pivot indices; for 1 <= i <= N, row i of the */
+/* matrix has been interchanged with row IPIV(i). */
+
+/* JPIV (input) INTEGER array, dimension (N). */
+/* The pivot indices; for 1 <= j <= N, column j of the */
+/* matrix has been interchanged with column JPIV(j). */
+
+/* SCALE (output) DOUBLE PRECISION */
+/* On exit, SCALE contains the scale factor. SCALE is chosen */
+/* 0 <= SCALE <= 1 to prevent owerflow in the solution. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Set constant to control owerflow */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --rhs;
+ --ipiv;
+ --jpiv;
+
+ /* Function Body */
+ eps = dlamch_("P");
+ smlnum = dlamch_("S") / eps;
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Apply permutations IPIV to RHS */
+
+ i__1 = *n - 1;
+ dlaswp_(&c__1, &rhs[1], lda, &c__1, &i__1, &ipiv[1], &c__1);
+
+/* Solve for L part */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ rhs[j] -= a[j + i__ * a_dim1] * rhs[i__];
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Solve for U part */
+
+ *scale = 1.;
+
+/* Check for scaling */
+
+ i__ = idamax_(n, &rhs[1], &c__1);
+ if (smlnum * 2. * (d__1 = rhs[i__], abs(d__1)) > (d__2 = a[*n + *n *
+ a_dim1], abs(d__2))) {
+ temp = .5 / (d__1 = rhs[i__], abs(d__1));
+ dscal_(n, &temp, &rhs[1], &c__1);
+ *scale *= temp;
+ }
+
+ for (i__ = *n; i__ >= 1; --i__) {
+ temp = 1. / a[i__ + i__ * a_dim1];
+ rhs[i__] *= temp;
+ i__1 = *n;
+ for (j = i__ + 1; j <= i__1; ++j) {
+ rhs[i__] -= rhs[j] * (a[i__ + j * a_dim1] * temp);
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Apply permutations JPIV to the solution (RHS) */
+
+ i__1 = *n - 1;
+ dlaswp_(&c__1, &rhs[1], lda, &c__1, &i__1, &jpiv[1], &c_n1);
+ return 0;
+
+/* End of DGESC2 */
+
+} /* dgesc2_ */
diff --git a/SRC/dgesdd.c b/SRC/dgesdd.c
new file mode 100644
index 0000000..9a12830
--- /dev/null
+++ b/SRC/dgesdd.c
@@ -0,0 +1,1609 @@
+/* dgesdd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static doublereal c_b227 = 0.;
+static doublereal c_b248 = 1.;
+
+/* Subroutine */ int dgesdd_(char *jobz, integer *m, integer *n, doublereal *
+ a, integer *lda, doublereal *s, doublereal *u, integer *ldu,
+ doublereal *vt, integer *ldvt, doublereal *work, integer *lwork,
+ integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
+ i__2, i__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, ie, il, ir, iu, blk;
+ doublereal dum[1], eps;
+ integer ivt, iscl;
+ doublereal anrm;
+ integer idum[1], ierr, itau;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ integer chunk, minmn, wrkbl, itaup, itauq, mnthr;
+ logical wntqa;
+ integer nwork;
+ logical wntqn, wntqo, wntqs;
+ extern /* Subroutine */ int dbdsdc_(char *, char *, integer *, doublereal
+ *, doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dgebrd_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ integer bdspac;
+ extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *),
+ dlascl_(char *, integer *, integer *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, integer *, integer *),
+ dgeqrf_(integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *), dlacpy_(char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *), dorgbr_(char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dormbr_(char *, char *, char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dorglq_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dorgqr_(integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *);
+ integer ldwrkl, ldwrkr, minwrk, ldwrku, maxwrk, ldwkvt;
+ doublereal smlnum;
+ logical wntqas, lquery;
+
+
+/* -- LAPACK driver routine (version 3.2.1) -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/* March 2009 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGESDD computes the singular value decomposition (SVD) of a real */
+/* M-by-N matrix A, optionally computing the left and right singular */
+/* vectors. If singular vectors are desired, it uses a */
+/* divide-and-conquer algorithm. */
+
+/* The SVD is written */
+
+/* A = U * SIGMA * transpose(V) */
+
+/* where SIGMA is an M-by-N matrix which is zero except for its */
+/* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and */
+/* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA */
+/* are the singular values of A; they are real and non-negative, and */
+/* are returned in descending order. The first min(m,n) columns of */
+/* U and V are the left and right singular vectors of A. */
+
+/* Note that the routine returns VT = V**T, not V. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* Specifies options for computing all or part of the matrix U: */
+/* = 'A': all M columns of U and all N rows of V**T are */
+/* returned in the arrays U and VT; */
+/* = 'S': the first min(M,N) columns of U and the first */
+/* min(M,N) rows of V**T are returned in the arrays U */
+/* and VT; */
+/* = 'O': If M >= N, the first N columns of U are overwritten */
+/* on the array A and all rows of V**T are returned in */
+/* the array VT; */
+/* otherwise, all columns of U are returned in the */
+/* array U and the first M rows of V**T are overwritten */
+/* in the array A; */
+/* = 'N': no columns of U or rows of V**T are computed. */
+
+/* M (input) INTEGER */
+/* The number of rows of the input matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the input matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, */
+/* if JOBZ = 'O', A is overwritten with the first N columns */
+/* of U (the left singular vectors, stored */
+/* columnwise) if M >= N; */
+/* A is overwritten with the first M rows */
+/* of V**T (the right singular vectors, stored */
+/* rowwise) otherwise. */
+/* if JOBZ .ne. 'O', the contents of A are destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* S (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The singular values of A, sorted so that S(i) >= S(i+1). */
+
+/* U (output) DOUBLE PRECISION array, dimension (LDU,UCOL) */
+/* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N; */
+/* UCOL = min(M,N) if JOBZ = 'S'. */
+/* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M */
+/* orthogonal matrix U; */
+/* if JOBZ = 'S', U contains the first min(M,N) columns of U */
+/* (the left singular vectors, stored columnwise); */
+/* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= 1; if */
+/* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M. */
+
+/* VT (output) DOUBLE PRECISION array, dimension (LDVT,N) */
+/* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the */
+/* N-by-N orthogonal matrix V**T; */
+/* if JOBZ = 'S', VT contains the first min(M,N) rows of */
+/* V**T (the right singular vectors, stored rowwise); */
+/* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. LDVT >= 1; if */
+/* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N; */
+/* if JOBZ = 'S', LDVT >= min(M,N). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK; */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= 1. */
+/* If JOBZ = 'N', */
+/* LWORK >= 3*min(M,N) + max(max(M,N),7*min(M,N)). */
+/* If JOBZ = 'O', */
+/* LWORK >= 3*min(M,N) + */
+/* max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)). */
+/* If JOBZ = 'S' or 'A' */
+/* LWORK >= 3*min(M,N) + */
+/* max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)). */
+/* For good performance, LWORK should generally be larger. */
+/* If LWORK = -1 but other input arguments are legal, WORK(1) */
+/* returns the optimal LWORK. */
+
+/* IWORK (workspace) INTEGER array, dimension (8*min(M,N)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: DBDSDC did not converge, updating process failed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ minmn = min(*m,*n);
+ wntqa = lsame_(jobz, "A");
+ wntqs = lsame_(jobz, "S");
+ wntqas = wntqa || wntqs;
+ wntqo = lsame_(jobz, "O");
+ wntqn = lsame_(jobz, "N");
+ lquery = *lwork == -1;
+
+ if (! (wntqa || wntqs || wntqo || wntqn)) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldu < 1 || wntqas && *ldu < *m || wntqo && *m < *n && *ldu < *
+ m) {
+ *info = -8;
+ } else if (*ldvt < 1 || wntqa && *ldvt < *n || wntqs && *ldvt < minmn ||
+ wntqo && *m >= *n && *ldvt < *n) {
+ *info = -10;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ if (*info == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ if (*m >= *n && minmn > 0) {
+
+/* Compute space needed for DBDSDC */
+
+ mnthr = (integer) (minmn * 11. / 6.);
+ if (wntqn) {
+ bdspac = *n * 7;
+ } else {
+ bdspac = *n * 3 * *n + (*n << 2);
+ }
+ if (*m >= mnthr) {
+ if (wntqn) {
+
+/* Path 1 (M much larger than N, JOBZ='N') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *n;
+ maxwrk = max(i__1,i__2);
+ minwrk = bdspac + *n;
+ } else if (wntqo) {
+
+/* Path 2 (M much larger than N, JOBZ='O') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n + *n * ilaenv_(&c__1, "DORGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR"
+, "QLN", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR"
+, "PRT", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *n * 3;
+ wrkbl = max(i__1,i__2);
+ maxwrk = wrkbl + (*n << 1) * *n;
+ minwrk = bdspac + (*n << 1) * *n + *n * 3;
+ } else if (wntqs) {
+
+/* Path 3 (M much larger than N, JOBZ='S') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n + *n * ilaenv_(&c__1, "DORGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR"
+, "QLN", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR"
+, "PRT", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *n * 3;
+ wrkbl = max(i__1,i__2);
+ maxwrk = wrkbl + *n * *n;
+ minwrk = bdspac + *n * *n + *n * 3;
+ } else if (wntqa) {
+
+/* Path 4 (M much larger than N, JOBZ='A') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n + *m * ilaenv_(&c__1, "DORGQR",
+ " ", m, m, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR"
+, "QLN", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR"
+, "PRT", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *n * 3;
+ wrkbl = max(i__1,i__2);
+ maxwrk = wrkbl + *n * *n;
+ minwrk = bdspac + *n * *n + *n * 3;
+ }
+ } else {
+
+/* Path 5 (M at least N, but not much larger) */
+
+ wrkbl = *n * 3 + (*m + *n) * ilaenv_(&c__1, "DGEBRD", " ", m,
+ n, &c_n1, &c_n1);
+ if (wntqn) {
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *n * 3;
+ maxwrk = max(i__1,i__2);
+ minwrk = *n * 3 + max(*m,bdspac);
+ } else if (wntqo) {
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR"
+, "QLN", m, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR"
+, "PRT", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *n * 3;
+ wrkbl = max(i__1,i__2);
+ maxwrk = wrkbl + *m * *n;
+/* Computing MAX */
+ i__1 = *m, i__2 = *n * *n + bdspac;
+ minwrk = *n * 3 + max(i__1,i__2);
+ } else if (wntqs) {
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR"
+, "QLN", m, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR"
+, "PRT", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *n * 3;
+ maxwrk = max(i__1,i__2);
+ minwrk = *n * 3 + max(*m,bdspac);
+ } else if (wntqa) {
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *m * ilaenv_(&c__1, "DORMBR"
+, "QLN", m, m, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "DORMBR"
+, "PRT", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = bdspac + *n * 3;
+ maxwrk = max(i__1,i__2);
+ minwrk = *n * 3 + max(*m,bdspac);
+ }
+ }
+ } else if (minmn > 0) {
+
+/* Compute space needed for DBDSDC */
+
+ mnthr = (integer) (minmn * 11. / 6.);
+ if (wntqn) {
+ bdspac = *m * 7;
+ } else {
+ bdspac = *m * 3 * *m + (*m << 2);
+ }
+ if (*n >= mnthr) {
+ if (wntqn) {
+
+/* Path 1t (N much larger than M, JOBZ='N') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *m;
+ maxwrk = max(i__1,i__2);
+ minwrk = bdspac + *m;
+ } else if (wntqo) {
+
+/* Path 2t (N much larger than M, JOBZ='O') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m + *m * ilaenv_(&c__1, "DORGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR"
+, "QLN", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR"
+, "PRT", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *m * 3;
+ wrkbl = max(i__1,i__2);
+ maxwrk = wrkbl + (*m << 1) * *m;
+ minwrk = bdspac + (*m << 1) * *m + *m * 3;
+ } else if (wntqs) {
+
+/* Path 3t (N much larger than M, JOBZ='S') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m + *m * ilaenv_(&c__1, "DORGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR"
+, "QLN", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR"
+, "PRT", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *m * 3;
+ wrkbl = max(i__1,i__2);
+ maxwrk = wrkbl + *m * *m;
+ minwrk = bdspac + *m * *m + *m * 3;
+ } else if (wntqa) {
+
+/* Path 4t (N much larger than M, JOBZ='A') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m + *n * ilaenv_(&c__1, "DORGLQ",
+ " ", n, n, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR"
+, "QLN", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR"
+, "PRT", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *m * 3;
+ wrkbl = max(i__1,i__2);
+ maxwrk = wrkbl + *m * *m;
+ minwrk = bdspac + *m * *m + *m * 3;
+ }
+ } else {
+
+/* Path 5t (N greater than M, but not much larger) */
+
+ wrkbl = *m * 3 + (*m + *n) * ilaenv_(&c__1, "DGEBRD", " ", m,
+ n, &c_n1, &c_n1);
+ if (wntqn) {
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *m * 3;
+ maxwrk = max(i__1,i__2);
+ minwrk = *m * 3 + max(*n,bdspac);
+ } else if (wntqo) {
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR"
+, "QLN", m, m, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR"
+, "PRT", m, n, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *m * 3;
+ wrkbl = max(i__1,i__2);
+ maxwrk = wrkbl + *m * *n;
+/* Computing MAX */
+ i__1 = *n, i__2 = *m * *m + bdspac;
+ minwrk = *m * 3 + max(i__1,i__2);
+ } else if (wntqs) {
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR"
+, "QLN", m, m, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR"
+, "PRT", m, n, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *m * 3;
+ maxwrk = max(i__1,i__2);
+ minwrk = *m * 3 + max(*n,bdspac);
+ } else if (wntqa) {
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR"
+, "QLN", m, m, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORMBR"
+, "PRT", n, n, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *m * 3;
+ maxwrk = max(i__1,i__2);
+ minwrk = *m * 3 + max(*n,bdspac);
+ }
+ }
+ }
+ maxwrk = max(maxwrk,minwrk);
+ work[1] = (doublereal) maxwrk;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGESDD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ smlnum = sqrt(dlamch_("S")) / eps;
+ bignum = 1. / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = dlange_("M", m, n, &a[a_offset], lda, dum);
+ iscl = 0;
+ if (anrm > 0. && anrm < smlnum) {
+ iscl = 1;
+ dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, &
+ ierr);
+ } else if (anrm > bignum) {
+ iscl = 1;
+ dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+ if (*m >= *n) {
+
+/* A has at least as many rows as columns. If A has sufficiently */
+/* more rows than columns, first reduce using the QR */
+/* decomposition (if sufficient workspace available) */
+
+ if (*m >= mnthr) {
+
+ if (wntqn) {
+
+/* Path 1 (M much larger than N, JOBZ='N') */
+/* No singular vectors to be computed */
+
+ itau = 1;
+ nwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__1, &ierr);
+
+/* Zero out below R */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ dlaset_("L", &i__1, &i__2, &c_b227, &c_b227, &a[a_dim1 + 2],
+ lda);
+ ie = 1;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize R in A */
+/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__1, &ierr);
+ nwork = ie + *n;
+
+/* Perform bidiagonal SVD, computing singular values only */
+/* (Workspace: need N+BDSPAC) */
+
+ dbdsdc_("U", "N", n, &s[1], &work[ie], dum, &c__1, dum, &c__1,
+ dum, idum, &work[nwork], &iwork[1], info);
+
+ } else if (wntqo) {
+
+/* Path 2 (M much larger than N, JOBZ = 'O') */
+/* N left singular vectors to be overwritten on A and */
+/* N right singular vectors to be computed in VT */
+
+ ir = 1;
+
+/* WORK(IR) is LDWRKR by N */
+
+ if (*lwork >= *lda * *n + *n * *n + *n * 3 + bdspac) {
+ ldwrkr = *lda;
+ } else {
+ ldwrkr = (*lwork - *n * *n - *n * 3 - bdspac) / *n;
+ }
+ itau = ir + ldwrkr * *n;
+ nwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__1, &ierr);
+
+/* Copy R to WORK(IR), zeroing out below it */
+
+ dlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr);
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ dlaset_("L", &i__1, &i__2, &c_b227, &c_b227, &work[ir + 1], &
+ ldwrkr);
+
+/* Generate Q in A */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[nwork],
+ &i__1, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize R in VT, copying result to WORK(IR) */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__1, &ierr);
+
+/* WORK(IU) is N by N */
+
+ iu = nwork;
+ nwork = iu + *n * *n;
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in WORK(IU) and computing right */
+/* singular vectors of bidiagonal matrix in VT */
+/* (Workspace: need N+N*N+BDSPAC) */
+
+ dbdsdc_("U", "I", n, &s[1], &work[ie], &work[iu], n, &vt[
+ vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1],
+ info);
+
+/* Overwrite WORK(IU) by left singular vectors of R */
+/* and VT by right singular vectors of R */
+/* (Workspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dormbr_("Q", "L", "N", n, n, n, &work[ir], &ldwrkr, &work[
+ itauq], &work[iu], n, &work[nwork], &i__1, &ierr);
+ i__1 = *lwork - nwork + 1;
+ dormbr_("P", "R", "T", n, n, n, &work[ir], &ldwrkr, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, &
+ ierr);
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IU), storing result in WORK(IR) and copying to A */
+/* (Workspace: need 2*N*N, prefer N*N+M*N) */
+
+ i__1 = *m;
+ i__2 = ldwrkr;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *m - i__ + 1;
+ chunk = min(i__3,ldwrkr);
+ dgemm_("N", "N", &chunk, n, n, &c_b248, &a[i__ + a_dim1],
+ lda, &work[iu], n, &c_b227, &work[ir], &ldwrkr);
+ dlacpy_("F", &chunk, n, &work[ir], &ldwrkr, &a[i__ +
+ a_dim1], lda);
+/* L10: */
+ }
+
+ } else if (wntqs) {
+
+/* Path 3 (M much larger than N, JOBZ='S') */
+/* N left singular vectors to be computed in U and */
+/* N right singular vectors to be computed in VT */
+
+ ir = 1;
+
+/* WORK(IR) is N by N */
+
+ ldwrkr = *n;
+ itau = ir + ldwrkr * *n;
+ nwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__2, &ierr);
+
+/* Copy R to WORK(IR), zeroing out below it */
+
+ dlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr);
+ i__2 = *n - 1;
+ i__1 = *n - 1;
+ dlaset_("L", &i__2, &i__1, &c_b227, &c_b227, &work[ir + 1], &
+ ldwrkr);
+
+/* Generate Q in A */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[nwork],
+ &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IR) */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__2, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagoal matrix in U and computing right singular */
+/* vectors of bidiagonal matrix in VT */
+/* (Workspace: need N+BDSPAC) */
+
+ dbdsdc_("U", "I", n, &s[1], &work[ie], &u[u_offset], ldu, &vt[
+ vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1],
+ info);
+
+/* Overwrite U by left singular vectors of R and VT */
+/* by right singular vectors of R */
+/* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ dormbr_("Q", "L", "N", n, n, n, &work[ir], &ldwrkr, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr);
+
+ i__2 = *lwork - nwork + 1;
+ dormbr_("P", "R", "T", n, n, n, &work[ir], &ldwrkr, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, &
+ ierr);
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IR), storing result in U */
+/* (Workspace: need N*N) */
+
+ dlacpy_("F", n, n, &u[u_offset], ldu, &work[ir], &ldwrkr);
+ dgemm_("N", "N", m, n, n, &c_b248, &a[a_offset], lda, &work[
+ ir], &ldwrkr, &c_b227, &u[u_offset], ldu);
+
+ } else if (wntqa) {
+
+/* Path 4 (M much larger than N, JOBZ='A') */
+/* M left singular vectors to be computed in U and */
+/* N right singular vectors to be computed in VT */
+
+ iu = 1;
+
+/* WORK(IU) is N by N */
+
+ ldwrku = *n;
+ itau = iu + ldwrku * *n;
+ nwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__2, &ierr);
+ dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu);
+
+/* Generate Q in U */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+ i__2 = *lwork - nwork + 1;
+ dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &work[nwork],
+ &i__2, &ierr);
+
+/* Produce R in A, zeroing out other entries */
+
+ i__2 = *n - 1;
+ i__1 = *n - 1;
+ dlaset_("L", &i__2, &i__1, &c_b227, &c_b227, &a[a_dim1 + 2],
+ lda);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize R in A */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__2, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in WORK(IU) and computing right */
+/* singular vectors of bidiagonal matrix in VT */
+/* (Workspace: need N+N*N+BDSPAC) */
+
+ dbdsdc_("U", "I", n, &s[1], &work[ie], &work[iu], n, &vt[
+ vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1],
+ info);
+
+/* Overwrite WORK(IU) by left singular vectors of R and VT */
+/* by right singular vectors of R */
+/* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ dormbr_("Q", "L", "N", n, n, n, &a[a_offset], lda, &work[
+ itauq], &work[iu], &ldwrku, &work[nwork], &i__2, &
+ ierr);
+ i__2 = *lwork - nwork + 1;
+ dormbr_("P", "R", "T", n, n, n, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, &
+ ierr);
+
+/* Multiply Q in U by left singular vectors of R in */
+/* WORK(IU), storing result in A */
+/* (Workspace: need N*N) */
+
+ dgemm_("N", "N", m, n, n, &c_b248, &u[u_offset], ldu, &work[
+ iu], &ldwrku, &c_b227, &a[a_offset], lda);
+
+/* Copy left singular vectors of A from A to U */
+
+ dlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset], ldu);
+
+ }
+
+ } else {
+
+/* M .LT. MNTHR */
+
+/* Path 5 (M at least N, but not much larger) */
+/* Reduce to bidiagonal form without QR decomposition */
+
+ ie = 1;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize A */
+/* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
+ work[itaup], &work[nwork], &i__2, &ierr);
+ if (wntqn) {
+
+/* Perform bidiagonal SVD, only computing singular values */
+/* (Workspace: need N+BDSPAC) */
+
+ dbdsdc_("U", "N", n, &s[1], &work[ie], dum, &c__1, dum, &c__1,
+ dum, idum, &work[nwork], &iwork[1], info);
+ } else if (wntqo) {
+ iu = nwork;
+ if (*lwork >= *m * *n + *n * 3 + bdspac) {
+
+/* WORK( IU ) is M by N */
+
+ ldwrku = *m;
+ nwork = iu + ldwrku * *n;
+ dlaset_("F", m, n, &c_b227, &c_b227, &work[iu], &ldwrku);
+ } else {
+
+/* WORK( IU ) is N by N */
+
+ ldwrku = *n;
+ nwork = iu + ldwrku * *n;
+
+/* WORK(IR) is LDWRKR by N */
+
+ ir = nwork;
+ ldwrkr = (*lwork - *n * *n - *n * 3) / *n;
+ }
+ nwork = iu + ldwrku * *n;
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in WORK(IU) and computing right */
+/* singular vectors of bidiagonal matrix in VT */
+/* (Workspace: need N+N*N+BDSPAC) */
+
+ dbdsdc_("U", "I", n, &s[1], &work[ie], &work[iu], &ldwrku, &
+ vt[vt_offset], ldvt, dum, idum, &work[nwork], &iwork[
+ 1], info);
+
+/* Overwrite VT by right singular vectors of A */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ dormbr_("P", "R", "T", n, n, n, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, &
+ ierr);
+
+ if (*lwork >= *m * *n + *n * 3 + bdspac) {
+
+/* Overwrite WORK(IU) by left singular vectors of A */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ dormbr_("Q", "L", "N", m, n, n, &a[a_offset], lda, &work[
+ itauq], &work[iu], &ldwrku, &work[nwork], &i__2, &
+ ierr);
+
+/* Copy left singular vectors of A from WORK(IU) to A */
+
+ dlacpy_("F", m, n, &work[iu], &ldwrku, &a[a_offset], lda);
+ } else {
+
+/* Generate Q in A */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ dorgbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], &
+ work[nwork], &i__2, &ierr);
+
+/* Multiply Q in A by left singular vectors of */
+/* bidiagonal matrix in WORK(IU), storing result in */
+/* WORK(IR) and copying to A */
+/* (Workspace: need 2*N*N, prefer N*N+M*N) */
+
+ i__2 = *m;
+ i__1 = ldwrkr;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
+ i__1) {
+/* Computing MIN */
+ i__3 = *m - i__ + 1;
+ chunk = min(i__3,ldwrkr);
+ dgemm_("N", "N", &chunk, n, n, &c_b248, &a[i__ +
+ a_dim1], lda, &work[iu], &ldwrku, &c_b227, &
+ work[ir], &ldwrkr);
+ dlacpy_("F", &chunk, n, &work[ir], &ldwrkr, &a[i__ +
+ a_dim1], lda);
+/* L20: */
+ }
+ }
+
+ } else if (wntqs) {
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in U and computing right singular */
+/* vectors of bidiagonal matrix in VT */
+/* (Workspace: need N+BDSPAC) */
+
+ dlaset_("F", m, n, &c_b227, &c_b227, &u[u_offset], ldu);
+ dbdsdc_("U", "I", n, &s[1], &work[ie], &u[u_offset], ldu, &vt[
+ vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1],
+ info);
+
+/* Overwrite U by left singular vectors of A and VT */
+/* by right singular vectors of A */
+/* (Workspace: need 3*N, prefer 2*N+N*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dormbr_("Q", "L", "N", m, n, n, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr);
+ i__1 = *lwork - nwork + 1;
+ dormbr_("P", "R", "T", n, n, n, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, &
+ ierr);
+ } else if (wntqa) {
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in U and computing right singular */
+/* vectors of bidiagonal matrix in VT */
+/* (Workspace: need N+BDSPAC) */
+
+ dlaset_("F", m, m, &c_b227, &c_b227, &u[u_offset], ldu);
+ dbdsdc_("U", "I", n, &s[1], &work[ie], &u[u_offset], ldu, &vt[
+ vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1],
+ info);
+
+/* Set the right corner of U to identity matrix */
+
+ if (*m > *n) {
+ i__1 = *m - *n;
+ i__2 = *m - *n;
+ dlaset_("F", &i__1, &i__2, &c_b227, &c_b248, &u[*n + 1 + (
+ *n + 1) * u_dim1], ldu);
+ }
+
+/* Overwrite U by left singular vectors of A and VT */
+/* by right singular vectors of A */
+/* (Workspace: need N*N+2*N+M, prefer N*N+2*N+M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr);
+ i__1 = *lwork - nwork + 1;
+ dormbr_("P", "R", "T", n, n, m, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, &
+ ierr);
+ }
+
+ }
+
+ } else {
+
+/* A has more columns than rows. If A has sufficiently more */
+/* columns than rows, first reduce using the LQ decomposition (if */
+/* sufficient workspace available) */
+
+ if (*n >= mnthr) {
+
+ if (wntqn) {
+
+/* Path 1t (N much larger than M, JOBZ='N') */
+/* No singular vectors to be computed */
+
+ itau = 1;
+ nwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__1, &ierr);
+
+/* Zero out above L */
+
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ dlaset_("U", &i__1, &i__2, &c_b227, &c_b227, &a[(a_dim1 << 1)
+ + 1], lda);
+ ie = 1;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize L in A */
+/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__1, &ierr);
+ nwork = ie + *m;
+
+/* Perform bidiagonal SVD, computing singular values only */
+/* (Workspace: need M+BDSPAC) */
+
+ dbdsdc_("U", "N", m, &s[1], &work[ie], dum, &c__1, dum, &c__1,
+ dum, idum, &work[nwork], &iwork[1], info);
+
+ } else if (wntqo) {
+
+/* Path 2t (N much larger than M, JOBZ='O') */
+/* M right singular vectors to be overwritten on A and */
+/* M left singular vectors to be computed in U */
+
+ ivt = 1;
+
+/* IVT is M by M */
+
+ il = ivt + *m * *m;
+ if (*lwork >= *m * *n + *m * *m + *m * 3 + bdspac) {
+
+/* WORK(IL) is M by N */
+
+ ldwrkl = *m;
+ chunk = *n;
+ } else {
+ ldwrkl = *m;
+ chunk = (*lwork - *m * *m) / *m;
+ }
+ itau = il + ldwrkl * *m;
+ nwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__1, &ierr);
+
+/* Copy L to WORK(IL), zeroing about above it */
+
+ dlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwrkl);
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ dlaset_("U", &i__1, &i__2, &c_b227, &c_b227, &work[il +
+ ldwrkl], &ldwrkl);
+
+/* Generate Q in A */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[nwork],
+ &i__1, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IL) */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dgebrd_(m, m, &work[il], &ldwrkl, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__1, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in U, and computing right singular */
+/* vectors of bidiagonal matrix in WORK(IVT) */
+/* (Workspace: need M+M*M+BDSPAC) */
+
+ dbdsdc_("U", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &
+ work[ivt], m, dum, idum, &work[nwork], &iwork[1],
+ info);
+
+/* Overwrite U by left singular vectors of L and WORK(IVT) */
+/* by right singular vectors of L */
+/* (Workspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dormbr_("Q", "L", "N", m, m, m, &work[il], &ldwrkl, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr);
+ i__1 = *lwork - nwork + 1;
+ dormbr_("P", "R", "T", m, m, m, &work[il], &ldwrkl, &work[
+ itaup], &work[ivt], m, &work[nwork], &i__1, &ierr);
+
+/* Multiply right singular vectors of L in WORK(IVT) by Q */
+/* in A, storing result in WORK(IL) and copying to A */
+/* (Workspace: need 2*M*M, prefer M*M+M*N) */
+
+ i__1 = *n;
+ i__2 = chunk;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *n - i__ + 1;
+ blk = min(i__3,chunk);
+ dgemm_("N", "N", m, &blk, m, &c_b248, &work[ivt], m, &a[
+ i__ * a_dim1 + 1], lda, &c_b227, &work[il], &
+ ldwrkl);
+ dlacpy_("F", m, &blk, &work[il], &ldwrkl, &a[i__ * a_dim1
+ + 1], lda);
+/* L30: */
+ }
+
+ } else if (wntqs) {
+
+/* Path 3t (N much larger than M, JOBZ='S') */
+/* M right singular vectors to be computed in VT and */
+/* M left singular vectors to be computed in U */
+
+ il = 1;
+
+/* WORK(IL) is M by M */
+
+ ldwrkl = *m;
+ itau = il + ldwrkl * *m;
+ nwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__2, &ierr);
+
+/* Copy L to WORK(IL), zeroing out above it */
+
+ dlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwrkl);
+ i__2 = *m - 1;
+ i__1 = *m - 1;
+ dlaset_("U", &i__2, &i__1, &c_b227, &c_b227, &work[il +
+ ldwrkl], &ldwrkl);
+
+/* Generate Q in A */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[nwork],
+ &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IU), copying result to U */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ dgebrd_(m, m, &work[il], &ldwrkl, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__2, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in U and computing right singular */
+/* vectors of bidiagonal matrix in VT */
+/* (Workspace: need M+BDSPAC) */
+
+ dbdsdc_("U", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &vt[
+ vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1],
+ info);
+
+/* Overwrite U by left singular vectors of L and VT */
+/* by right singular vectors of L */
+/* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ dormbr_("Q", "L", "N", m, m, m, &work[il], &ldwrkl, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr);
+ i__2 = *lwork - nwork + 1;
+ dormbr_("P", "R", "T", m, m, m, &work[il], &ldwrkl, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, &
+ ierr);
+
+/* Multiply right singular vectors of L in WORK(IL) by */
+/* Q in A, storing result in VT */
+/* (Workspace: need M*M) */
+
+ dlacpy_("F", m, m, &vt[vt_offset], ldvt, &work[il], &ldwrkl);
+ dgemm_("N", "N", m, n, m, &c_b248, &work[il], &ldwrkl, &a[
+ a_offset], lda, &c_b227, &vt[vt_offset], ldvt);
+
+ } else if (wntqa) {
+
+/* Path 4t (N much larger than M, JOBZ='A') */
+/* N right singular vectors to be computed in VT and */
+/* M left singular vectors to be computed in U */
+
+ ivt = 1;
+
+/* WORK(IVT) is M by M */
+
+ ldwkvt = *m;
+ itau = ivt + ldwkvt * *m;
+ nwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__2, &ierr);
+ dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+
+/* Generate Q in VT */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &work[
+ nwork], &i__2, &ierr);
+
+/* Produce L in A, zeroing out other entries */
+
+ i__2 = *m - 1;
+ i__1 = *m - 1;
+ dlaset_("U", &i__2, &i__1, &c_b227, &c_b227, &a[(a_dim1 << 1)
+ + 1], lda);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize L in A */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__2, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in U and computing right singular */
+/* vectors of bidiagonal matrix in WORK(IVT) */
+/* (Workspace: need M+M*M+BDSPAC) */
+
+ dbdsdc_("U", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &
+ work[ivt], &ldwkvt, dum, idum, &work[nwork], &iwork[1]
+, info);
+
+/* Overwrite U by left singular vectors of L and WORK(IVT) */
+/* by right singular vectors of L */
+/* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ dormbr_("Q", "L", "N", m, m, m, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr);
+ i__2 = *lwork - nwork + 1;
+ dormbr_("P", "R", "T", m, m, m, &a[a_offset], lda, &work[
+ itaup], &work[ivt], &ldwkvt, &work[nwork], &i__2, &
+ ierr);
+
+/* Multiply right singular vectors of L in WORK(IVT) by */
+/* Q in VT, storing result in A */
+/* (Workspace: need M*M) */
+
+ dgemm_("N", "N", m, n, m, &c_b248, &work[ivt], &ldwkvt, &vt[
+ vt_offset], ldvt, &c_b227, &a[a_offset], lda);
+
+/* Copy right singular vectors of A from A to VT */
+
+ dlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+
+ }
+
+ } else {
+
+/* N .LT. MNTHR */
+
+/* Path 5t (N greater than M, but not much larger) */
+/* Reduce to bidiagonal form without LQ decomposition */
+
+ ie = 1;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize A */
+/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
+ work[itaup], &work[nwork], &i__2, &ierr);
+ if (wntqn) {
+
+/* Perform bidiagonal SVD, only computing singular values */
+/* (Workspace: need M+BDSPAC) */
+
+ dbdsdc_("L", "N", m, &s[1], &work[ie], dum, &c__1, dum, &c__1,
+ dum, idum, &work[nwork], &iwork[1], info);
+ } else if (wntqo) {
+ ldwkvt = *m;
+ ivt = nwork;
+ if (*lwork >= *m * *n + *m * 3 + bdspac) {
+
+/* WORK( IVT ) is M by N */
+
+ dlaset_("F", m, n, &c_b227, &c_b227, &work[ivt], &ldwkvt);
+ nwork = ivt + ldwkvt * *n;
+ } else {
+
+/* WORK( IVT ) is M by M */
+
+ nwork = ivt + ldwkvt * *m;
+ il = nwork;
+
+/* WORK(IL) is M by CHUNK */
+
+ chunk = (*lwork - *m * *m - *m * 3) / *m;
+ }
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in U and computing right singular */
+/* vectors of bidiagonal matrix in WORK(IVT) */
+/* (Workspace: need M*M+BDSPAC) */
+
+ dbdsdc_("L", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &
+ work[ivt], &ldwkvt, dum, idum, &work[nwork], &iwork[1]
+, info);
+
+/* Overwrite U by left singular vectors of A */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ dormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr);
+
+ if (*lwork >= *m * *n + *m * 3 + bdspac) {
+
+/* Overwrite WORK(IVT) by left singular vectors of A */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ dormbr_("P", "R", "T", m, n, m, &a[a_offset], lda, &work[
+ itaup], &work[ivt], &ldwkvt, &work[nwork], &i__2,
+ &ierr);
+
+/* Copy right singular vectors of A from WORK(IVT) to A */
+
+ dlacpy_("F", m, n, &work[ivt], &ldwkvt, &a[a_offset], lda);
+ } else {
+
+/* Generate P**T in A */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ dorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &
+ work[nwork], &i__2, &ierr);
+
+/* Multiply Q in A by right singular vectors of */
+/* bidiagonal matrix in WORK(IVT), storing result in */
+/* WORK(IL) and copying to A */
+/* (Workspace: need 2*M*M, prefer M*M+M*N) */
+
+ i__2 = *n;
+ i__1 = chunk;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
+ i__1) {
+/* Computing MIN */
+ i__3 = *n - i__ + 1;
+ blk = min(i__3,chunk);
+ dgemm_("N", "N", m, &blk, m, &c_b248, &work[ivt], &
+ ldwkvt, &a[i__ * a_dim1 + 1], lda, &c_b227, &
+ work[il], m);
+ dlacpy_("F", m, &blk, &work[il], m, &a[i__ * a_dim1 +
+ 1], lda);
+/* L40: */
+ }
+ }
+ } else if (wntqs) {
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in U and computing right singular */
+/* vectors of bidiagonal matrix in VT */
+/* (Workspace: need M+BDSPAC) */
+
+ dlaset_("F", m, n, &c_b227, &c_b227, &vt[vt_offset], ldvt);
+ dbdsdc_("L", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &vt[
+ vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1],
+ info);
+
+/* Overwrite U by left singular vectors of A and VT */
+/* by right singular vectors of A */
+/* (Workspace: need 3*M, prefer 2*M+M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr);
+ i__1 = *lwork - nwork + 1;
+ dormbr_("P", "R", "T", m, n, m, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, &
+ ierr);
+ } else if (wntqa) {
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in U and computing right singular */
+/* vectors of bidiagonal matrix in VT */
+/* (Workspace: need M+BDSPAC) */
+
+ dlaset_("F", n, n, &c_b227, &c_b227, &vt[vt_offset], ldvt);
+ dbdsdc_("L", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &vt[
+ vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1],
+ info);
+
+/* Set the right corner of VT to identity matrix */
+
+ if (*n > *m) {
+ i__1 = *n - *m;
+ i__2 = *n - *m;
+ dlaset_("F", &i__1, &i__2, &c_b227, &c_b248, &vt[*m + 1 +
+ (*m + 1) * vt_dim1], ldvt);
+ }
+
+/* Overwrite U by left singular vectors of A and VT */
+/* by right singular vectors of A */
+/* (Workspace: need 2*M+N, prefer 2*M+N*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ dormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr);
+ i__1 = *lwork - nwork + 1;
+ dormbr_("P", "R", "T", n, n, m, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, &
+ ierr);
+ }
+
+ }
+
+ }
+
+/* Undo scaling if necessary */
+
+ if (iscl == 1) {
+ if (anrm > bignum) {
+ dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, &ierr);
+ }
+ if (anrm < smlnum) {
+ dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, &ierr);
+ }
+ }
+
+/* Return optimal workspace in WORK(1) */
+
+ work[1] = (doublereal) maxwrk;
+
+ return 0;
+
+/* End of DGESDD */
+
+} /* dgesdd_ */
diff --git a/SRC/dgesv.c b/SRC/dgesv.c
new file mode 100644
index 0000000..c44d06f
--- /dev/null
+++ b/SRC/dgesv.c
@@ -0,0 +1,138 @@
+/* dgesv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgesv_(integer *n, integer *nrhs, doublereal *a, integer
+ *lda, integer *ipiv, doublereal *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int dgetrf_(integer *, integer *, doublereal *,
+ integer *, integer *, integer *), xerbla_(char *, integer *), dgetrs_(char *, integer *, integer *, doublereal *,
+ integer *, integer *, doublereal *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGESV computes the solution to a real system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */
+
+/* The LU decomposition with partial pivoting and row interchanges is */
+/* used to factor A as */
+/* A = P * L * U, */
+/* where P is a permutation matrix, L is unit lower triangular, and U is */
+/* upper triangular. The factored form of A is then used to solve the */
+/* system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the N-by-N coefficient matrix A. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* The pivot indices that define the permutation matrix P; */
+/* row i of the matrix was interchanged with row IPIV(i). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS matrix of right hand side matrix B. */
+/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, so the solution could not be computed. */
+
+/* ===================================================================== */
+
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGESV ", &i__1);
+ return 0;
+ }
+
+/* Compute the LU factorization of A. */
+
+ dgetrf_(n, n, &a[a_offset], lda, &ipiv[1], info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ dgetrs_("No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &b[
+ b_offset], ldb, info);
+ }
+ return 0;
+
+/* End of DGESV */
+
+} /* dgesv_ */
diff --git a/SRC/dgesvd.c b/SRC/dgesvd.c
new file mode 100644
index 0000000..a667033
--- /dev/null
+++ b/SRC/dgesvd.c
@@ -0,0 +1,4050 @@
+/* dgesvd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__6 = 6;
+static integer c__0 = 0;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b421 = 0.;
+static doublereal c_b443 = 1.;
+
+/* Subroutine */ int dgesvd_(char *jobu, char *jobvt, integer *m, integer *n,
+ doublereal *a, integer *lda, doublereal *s, doublereal *u, integer *
+ ldu, doublereal *vt, integer *ldvt, doublereal *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1[2],
+ i__2, i__3, i__4;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, ie, ir, iu, blk, ncu;
+ doublereal dum[1], eps;
+ integer nru, iscl;
+ doublereal anrm;
+ integer ierr, itau, ncvt, nrvt;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ integer chunk, minmn, wrkbl, itaup, itauq, mnthr, iwork;
+ logical wntua, wntva, wntun, wntuo, wntvn, wntvo, wntus, wntvs;
+ extern /* Subroutine */ int dgebrd_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ integer bdspac;
+ extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *),
+ dlascl_(char *, integer *, integer *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, integer *, integer *),
+ dgeqrf_(integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *), dlacpy_(char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ dbdsqr_(char *, integer *, integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *), dorgbr_(char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dormbr_(char *, char *, char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dorglq_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dorgqr_(integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *);
+ integer ldwrkr, minwrk, ldwrku, maxwrk;
+ doublereal smlnum;
+ logical lquery, wntuas, wntvas;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGESVD computes the singular value decomposition (SVD) of a real */
+/* M-by-N matrix A, optionally computing the left and/or right singular */
+/* vectors. The SVD is written */
+
+/* A = U * SIGMA * transpose(V) */
+
+/* where SIGMA is an M-by-N matrix which is zero except for its */
+/* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and */
+/* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA */
+/* are the singular values of A; they are real and non-negative, and */
+/* are returned in descending order. The first min(m,n) columns of */
+/* U and V are the left and right singular vectors of A. */
+
+/* Note that the routine returns V**T, not V. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBU (input) CHARACTER*1 */
+/* Specifies options for computing all or part of the matrix U: */
+/* = 'A': all M columns of U are returned in array U: */
+/* = 'S': the first min(m,n) columns of U (the left singular */
+/* vectors) are returned in the array U; */
+/* = 'O': the first min(m,n) columns of U (the left singular */
+/* vectors) are overwritten on the array A; */
+/* = 'N': no columns of U (no left singular vectors) are */
+/* computed. */
+
+/* JOBVT (input) CHARACTER*1 */
+/* Specifies options for computing all or part of the matrix */
+/* V**T: */
+/* = 'A': all N rows of V**T are returned in the array VT; */
+/* = 'S': the first min(m,n) rows of V**T (the right singular */
+/* vectors) are returned in the array VT; */
+/* = 'O': the first min(m,n) rows of V**T (the right singular */
+/* vectors) are overwritten on the array A; */
+/* = 'N': no rows of V**T (no right singular vectors) are */
+/* computed. */
+
+/* JOBVT and JOBU cannot both be 'O'. */
+
+/* M (input) INTEGER */
+/* The number of rows of the input matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the input matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, */
+/* if JOBU = 'O', A is overwritten with the first min(m,n) */
+/* columns of U (the left singular vectors, */
+/* stored columnwise); */
+/* if JOBVT = 'O', A is overwritten with the first min(m,n) */
+/* rows of V**T (the right singular vectors, */
+/* stored rowwise); */
+/* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A */
+/* are destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* S (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The singular values of A, sorted so that S(i) >= S(i+1). */
+
+/* U (output) DOUBLE PRECISION array, dimension (LDU,UCOL) */
+/* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'. */
+/* If JOBU = 'A', U contains the M-by-M orthogonal matrix U; */
+/* if JOBU = 'S', U contains the first min(m,n) columns of U */
+/* (the left singular vectors, stored columnwise); */
+/* if JOBU = 'N' or 'O', U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= 1; if */
+/* JOBU = 'S' or 'A', LDU >= M. */
+
+/* VT (output) DOUBLE PRECISION array, dimension (LDVT,N) */
+/* If JOBVT = 'A', VT contains the N-by-N orthogonal matrix */
+/* V**T; */
+/* if JOBVT = 'S', VT contains the first min(m,n) rows of */
+/* V**T (the right singular vectors, stored rowwise); */
+/* if JOBVT = 'N' or 'O', VT is not referenced. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. LDVT >= 1; if */
+/* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK; */
+/* if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged */
+/* superdiagonal elements of an upper bidiagonal matrix B */
+/* whose diagonal is in S (not necessarily sorted). B */
+/* satisfies A = U * B * VT, so it has the same singular values */
+/* as A, and singular vectors related by U and VT. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)). */
+/* For good performance, LWORK should generally be larger. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if DBDSQR did not converge, INFO specifies how many */
+/* superdiagonals of an intermediate bidiagonal form B */
+/* did not converge to zero. See the description of WORK */
+/* above for details. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ minmn = min(*m,*n);
+ wntua = lsame_(jobu, "A");
+ wntus = lsame_(jobu, "S");
+ wntuas = wntua || wntus;
+ wntuo = lsame_(jobu, "O");
+ wntun = lsame_(jobu, "N");
+ wntva = lsame_(jobvt, "A");
+ wntvs = lsame_(jobvt, "S");
+ wntvas = wntva || wntvs;
+ wntvo = lsame_(jobvt, "O");
+ wntvn = lsame_(jobvt, "N");
+ lquery = *lwork == -1;
+
+ if (! (wntua || wntus || wntuo || wntun)) {
+ *info = -1;
+ } else if (! (wntva || wntvs || wntvo || wntvn) || wntvo && wntuo) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -6;
+ } else if (*ldu < 1 || wntuas && *ldu < *m) {
+ *info = -9;
+ } else if (*ldvt < 1 || wntva && *ldvt < *n || wntvs && *ldvt < minmn) {
+ *info = -11;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ if (*info == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ if (*m >= *n && minmn > 0) {
+
+/* Compute space needed for DBDSQR */
+
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = jobu;
+ i__1[1] = 1, a__1[1] = jobvt;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ mnthr = ilaenv_(&c__6, "DGESVD", ch__1, m, n, &c__0, &c__0);
+ bdspac = *n * 5;
+ if (*m >= mnthr) {
+ if (wntun) {
+
+/* Path 1 (M much larger than N, JOBU='N') */
+
+ maxwrk = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", n, n, &c_n1, &c_n1);
+ maxwrk = max(i__2,i__3);
+ if (wntvo || wntvas) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = *n * 3 + (*n - 1) * ilaenv_(&
+ c__1, "DORGBR", "P", n, n, n, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ maxwrk = max(maxwrk,bdspac);
+/* Computing MAX */
+ i__2 = *n << 2;
+ minwrk = max(i__2,bdspac);
+ } else if (wntuo && wntvn) {
+
+/* Path 2 (M much larger than N, JOBU='O', JOBVT='N') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "DORGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR"
+, "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+/* Computing MAX */
+ i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n + *n;
+ maxwrk = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = *n * 3 + *m;
+ minwrk = max(i__2,bdspac);
+ } else if (wntuo && wntvas) {
+
+/* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or */
+/* 'A') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "DORGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR"
+, "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
+ "DORGBR", "P", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+/* Computing MAX */
+ i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n + *n;
+ maxwrk = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = *n * 3 + *m;
+ minwrk = max(i__2,bdspac);
+ } else if (wntus && wntvn) {
+
+/* Path 4 (M much larger than N, JOBU='S', JOBVT='N') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "DORGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR"
+, "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = *n * *n + wrkbl;
+/* Computing MAX */
+ i__2 = *n * 3 + *m;
+ minwrk = max(i__2,bdspac);
+ } else if (wntus && wntvo) {
+
+/* Path 5 (M much larger than N, JOBU='S', JOBVT='O') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "DORGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR"
+, "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
+ "DORGBR", "P", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = (*n << 1) * *n + wrkbl;
+/* Computing MAX */
+ i__2 = *n * 3 + *m;
+ minwrk = max(i__2,bdspac);
+ } else if (wntus && wntvas) {
+
+/* Path 6 (M much larger than N, JOBU='S', JOBVT='S' or */
+/* 'A') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "DORGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR"
+, "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
+ "DORGBR", "P", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = *n * *n + wrkbl;
+/* Computing MAX */
+ i__2 = *n * 3 + *m;
+ minwrk = max(i__2,bdspac);
+ } else if (wntua && wntvn) {
+
+/* Path 7 (M much larger than N, JOBU='A', JOBVT='N') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "DORGQR",
+ " ", m, m, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR"
+, "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = *n * *n + wrkbl;
+/* Computing MAX */
+ i__2 = *n * 3 + *m;
+ minwrk = max(i__2,bdspac);
+ } else if (wntua && wntvo) {
+
+/* Path 8 (M much larger than N, JOBU='A', JOBVT='O') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "DORGQR",
+ " ", m, m, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR"
+, "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
+ "DORGBR", "P", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = (*n << 1) * *n + wrkbl;
+/* Computing MAX */
+ i__2 = *n * 3 + *m;
+ minwrk = max(i__2,bdspac);
+ } else if (wntua && wntvas) {
+
+/* Path 9 (M much larger than N, JOBU='A', JOBVT='S' or */
+/* 'A') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "DORGQR",
+ " ", m, m, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORGBR"
+, "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
+ "DORGBR", "P", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = *n * *n + wrkbl;
+/* Computing MAX */
+ i__2 = *n * 3 + *m;
+ minwrk = max(i__2,bdspac);
+ }
+ } else {
+
+/* Path 10 (M at least N, but not much larger) */
+
+ maxwrk = *n * 3 + (*m + *n) * ilaenv_(&c__1, "DGEBRD", " ", m,
+ n, &c_n1, &c_n1);
+ if (wntus || wntuo) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = *n * 3 + *n * ilaenv_(&c__1, "DORG"
+ "BR", "Q", m, n, n, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ if (wntua) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = *n * 3 + *m * ilaenv_(&c__1, "DORG"
+ "BR", "Q", m, m, n, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ if (! wntvn) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
+ "DORGBR", "P", n, n, n, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ maxwrk = max(maxwrk,bdspac);
+/* Computing MAX */
+ i__2 = *n * 3 + *m;
+ minwrk = max(i__2,bdspac);
+ }
+ } else if (minmn > 0) {
+
+/* Compute space needed for DBDSQR */
+
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = jobu;
+ i__1[1] = 1, a__1[1] = jobvt;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ mnthr = ilaenv_(&c__6, "DGESVD", ch__1, m, n, &c__0, &c__0);
+ bdspac = *m * 5;
+ if (*n >= mnthr) {
+ if (wntvn) {
+
+/* Path 1t(N much larger than M, JOBVT='N') */
+
+ maxwrk = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", m, m, &c_n1, &c_n1);
+ maxwrk = max(i__2,i__3);
+ if (wntuo || wntuas) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = *m * 3 + *m * ilaenv_(&c__1,
+ "DORGBR", "Q", m, m, m, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ maxwrk = max(maxwrk,bdspac);
+/* Computing MAX */
+ i__2 = *m << 2;
+ minwrk = max(i__2,bdspac);
+ } else if (wntvo && wntun) {
+
+/* Path 2t(N much larger than M, JOBU='N', JOBVT='O') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "DORGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
+ "DORGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+/* Computing MAX */
+ i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n + *m;
+ maxwrk = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = *m * 3 + *n;
+ minwrk = max(i__2,bdspac);
+ } else if (wntvo && wntuas) {
+
+/* Path 3t(N much larger than M, JOBU='S' or 'A', */
+/* JOBVT='O') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "DORGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
+ "DORGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORGBR"
+, "Q", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+/* Computing MAX */
+ i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n + *m;
+ maxwrk = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = *m * 3 + *n;
+ minwrk = max(i__2,bdspac);
+ } else if (wntvs && wntun) {
+
+/* Path 4t(N much larger than M, JOBU='N', JOBVT='S') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "DORGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
+ "DORGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = *m * *m + wrkbl;
+/* Computing MAX */
+ i__2 = *m * 3 + *n;
+ minwrk = max(i__2,bdspac);
+ } else if (wntvs && wntuo) {
+
+/* Path 5t(N much larger than M, JOBU='O', JOBVT='S') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "DORGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
+ "DORGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORGBR"
+, "Q", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = (*m << 1) * *m + wrkbl;
+/* Computing MAX */
+ i__2 = *m * 3 + *n;
+ minwrk = max(i__2,bdspac);
+ } else if (wntvs && wntuas) {
+
+/* Path 6t(N much larger than M, JOBU='S' or 'A', */
+/* JOBVT='S') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "DORGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
+ "DORGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORGBR"
+, "Q", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = *m * *m + wrkbl;
+/* Computing MAX */
+ i__2 = *m * 3 + *n;
+ minwrk = max(i__2,bdspac);
+ } else if (wntva && wntun) {
+
+/* Path 7t(N much larger than M, JOBU='N', JOBVT='A') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "DORGLQ",
+ " ", n, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
+ "DORGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = *m * *m + wrkbl;
+/* Computing MAX */
+ i__2 = *m * 3 + *n;
+ minwrk = max(i__2,bdspac);
+ } else if (wntva && wntuo) {
+
+/* Path 8t(N much larger than M, JOBU='O', JOBVT='A') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "DORGLQ",
+ " ", n, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
+ "DORGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORGBR"
+, "Q", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = (*m << 1) * *m + wrkbl;
+/* Computing MAX */
+ i__2 = *m * 3 + *n;
+ minwrk = max(i__2,bdspac);
+ } else if (wntva && wntuas) {
+
+/* Path 9t(N much larger than M, JOBU='S' or 'A', */
+/* JOBVT='A') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "DORGLQ",
+ " ", n, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "DGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
+ "DORGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORGBR"
+, "Q", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = *m * *m + wrkbl;
+/* Computing MAX */
+ i__2 = *m * 3 + *n;
+ minwrk = max(i__2,bdspac);
+ }
+ } else {
+
+/* Path 10t(N greater than M, but not much larger) */
+
+ maxwrk = *m * 3 + (*m + *n) * ilaenv_(&c__1, "DGEBRD", " ", m,
+ n, &c_n1, &c_n1);
+ if (wntvs || wntvo) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = *m * 3 + *m * ilaenv_(&c__1, "DORG"
+ "BR", "P", m, n, m, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ if (wntva) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = *m * 3 + *n * ilaenv_(&c__1, "DORG"
+ "BR", "P", n, n, m, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ if (! wntun) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
+ "DORGBR", "Q", m, m, m, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ maxwrk = max(maxwrk,bdspac);
+/* Computing MAX */
+ i__2 = *m * 3 + *n;
+ minwrk = max(i__2,bdspac);
+ }
+ }
+ maxwrk = max(maxwrk,minwrk);
+ work[1] = (doublereal) maxwrk;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info != 0) {
+ i__2 = -(*info);
+ xerbla_("DGESVD", &i__2);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ smlnum = sqrt(dlamch_("S")) / eps;
+ bignum = 1. / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = dlange_("M", m, n, &a[a_offset], lda, dum);
+ iscl = 0;
+ if (anrm > 0. && anrm < smlnum) {
+ iscl = 1;
+ dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, &
+ ierr);
+ } else if (anrm > bignum) {
+ iscl = 1;
+ dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+ if (*m >= *n) {
+
+/* A has at least as many rows as columns. If A has sufficiently */
+/* more rows than columns, first reduce using the QR */
+/* decomposition (if sufficient workspace available) */
+
+ if (*m >= mnthr) {
+
+ if (wntun) {
+
+/* Path 1 (M much larger than N, JOBU='N') */
+/* No left singular vectors to be computed */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &
+ i__2, &ierr);
+
+/* Zero out below R */
+
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &a[a_dim1 + 2],
+ lda);
+ ie = 1;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in A */
+/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__2, &ierr);
+ ncvt = 0;
+ if (wntvo || wntvas) {
+
+/* If right singular vectors desired, generate P'. */
+/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &
+ work[iwork], &i__2, &ierr);
+ ncvt = *n;
+ }
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of A in A if desired */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("U", n, &ncvt, &c__0, &c__0, &s[1], &work[ie], &a[
+ a_offset], lda, dum, &c__1, dum, &c__1, &work[iwork],
+ info);
+
+/* If right singular vectors desired in VT, copy them there */
+
+ if (wntvas) {
+ dlacpy_("F", n, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+ }
+
+ } else if (wntuo && wntvn) {
+
+/* Path 2 (M much larger than N, JOBU='O', JOBVT='N') */
+/* N left singular vectors to be overwritten on A and */
+/* no right singular vectors to be computed */
+
+/* Computing MAX */
+ i__2 = *n << 2;
+ if (*lwork >= *n * *n + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *lda * *n + *n;
+ if (*lwork >= max(i__2,i__3) + *lda * *n) {
+
+/* WORK(IU) is LDA by N, WORK(IR) is LDA by N */
+
+ ldwrku = *lda;
+ ldwrkr = *lda;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *lda * *n + *n;
+ if (*lwork >= max(i__2,i__3) + *n * *n) {
+
+/* WORK(IU) is LDA by N, WORK(IR) is N by N */
+
+ ldwrku = *lda;
+ ldwrkr = *n;
+ } else {
+
+/* WORK(IU) is LDWRKU by N, WORK(IR) is N by N */
+
+ ldwrku = (*lwork - *n * *n - *n) / *n;
+ ldwrkr = *n;
+ }
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__2, &ierr);
+
+/* Copy R to WORK(IR) and zero out below it */
+
+ dlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[ir + 1]
+, &ldwrkr);
+
+/* Generate Q in A */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IR) */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__2, &ierr);
+
+/* Generate left vectors bidiagonalizing R */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], &
+ work[iwork], &i__2, &ierr);
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IR) */
+/* (Workspace: need N*N+BDSPAC) */
+
+ dbdsqr_("U", n, &c__0, n, &c__0, &s[1], &work[ie], dum, &
+ c__1, &work[ir], &ldwrkr, dum, &c__1, &work[iwork]
+, info);
+ iu = ie + *n;
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IR), storing result in WORK(IU) and copying to A */
+/* (Workspace: need N*N+2*N, prefer N*N+M*N+N) */
+
+ i__2 = *m;
+ i__3 = ldwrku;
+ for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
+ i__3) {
+/* Computing MIN */
+ i__4 = *m - i__ + 1;
+ chunk = min(i__4,ldwrku);
+ dgemm_("N", "N", &chunk, n, n, &c_b443, &a[i__ +
+ a_dim1], lda, &work[ir], &ldwrkr, &c_b421, &
+ work[iu], &ldwrku);
+ dlacpy_("F", &chunk, n, &work[iu], &ldwrku, &a[i__ +
+ a_dim1], lda);
+/* L10: */
+ }
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ ie = 1;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize A */
+/* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__3, &ierr);
+
+/* Generate left vectors bidiagonalizing A */
+/* (Workspace: need 4*N, prefer 3*N+N*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ dorgbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], &
+ work[iwork], &i__3, &ierr);
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in A */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("U", n, &c__0, m, &c__0, &s[1], &work[ie], dum, &
+ c__1, &a[a_offset], lda, dum, &c__1, &work[iwork],
+ info);
+
+ }
+
+ } else if (wntuo && wntvas) {
+
+/* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A') */
+/* N left singular vectors to be overwritten on A and */
+/* N right singular vectors to be computed in VT */
+
+/* Computing MAX */
+ i__3 = *n << 2;
+ if (*lwork >= *n * *n + max(i__3,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+/* Computing MAX */
+ i__3 = wrkbl, i__2 = *lda * *n + *n;
+ if (*lwork >= max(i__3,i__2) + *lda * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is LDA by N */
+
+ ldwrku = *lda;
+ ldwrkr = *lda;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__3 = wrkbl, i__2 = *lda * *n + *n;
+ if (*lwork >= max(i__3,i__2) + *n * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is N by N */
+
+ ldwrku = *lda;
+ ldwrkr = *n;
+ } else {
+
+/* WORK(IU) is LDWRKU by N and WORK(IR) is N by N */
+
+ ldwrku = (*lwork - *n * *n - *n) / *n;
+ ldwrkr = *n;
+ }
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__3, &ierr);
+
+/* Copy R to VT, zeroing out below it */
+
+ dlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+ if (*n > 1) {
+ i__3 = *n - 1;
+ i__2 = *n - 1;
+ dlaset_("L", &i__3, &i__2, &c_b421, &c_b421, &vt[
+ vt_dim1 + 2], ldvt);
+ }
+
+/* Generate Q in A */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__3, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in VT, copying result to WORK(IR) */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &i__3, &
+ ierr);
+ dlacpy_("L", n, n, &vt[vt_offset], ldvt, &work[ir], &
+ ldwrkr);
+
+/* Generate left vectors bidiagonalizing R in WORK(IR) */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ dorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], &
+ work[iwork], &i__3, &ierr);
+
+/* Generate right vectors bidiagonalizing R in VT */
+/* (Workspace: need N*N+4*N-1, prefer N*N+3*N+(N-1)*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup],
+ &work[iwork], &i__3, &ierr);
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IR) and computing right */
+/* singular vectors of R in VT */
+/* (Workspace: need N*N+BDSPAC) */
+
+ dbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &work[ir], &ldwrkr, dum, &c__1,
+ &work[iwork], info);
+ iu = ie + *n;
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IR), storing result in WORK(IU) and copying to A */
+/* (Workspace: need N*N+2*N, prefer N*N+M*N+N) */
+
+ i__3 = *m;
+ i__2 = ldwrku;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__4 = *m - i__ + 1;
+ chunk = min(i__4,ldwrku);
+ dgemm_("N", "N", &chunk, n, n, &c_b443, &a[i__ +
+ a_dim1], lda, &work[ir], &ldwrkr, &c_b421, &
+ work[iu], &ldwrku);
+ dlacpy_("F", &chunk, n, &work[iu], &ldwrku, &a[i__ +
+ a_dim1], lda);
+/* L20: */
+ }
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__2, &ierr);
+
+/* Copy R to VT, zeroing out below it */
+
+ dlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+ if (*n > 1) {
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &vt[
+ vt_dim1 + 2], ldvt);
+ }
+
+/* Generate Q in A */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in VT */
+/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &i__2, &
+ ierr);
+
+/* Multiply Q in A by left vectors bidiagonalizing R */
+/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dormbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt, &
+ work[itauq], &a[a_offset], lda, &work[iwork], &
+ i__2, &ierr);
+
+/* Generate right vectors bidiagonalizing R in VT */
+/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup],
+ &work[iwork], &i__2, &ierr);
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in A and computing right */
+/* singular vectors of A in VT */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, &
+ work[iwork], info);
+
+ }
+
+ } else if (wntus) {
+
+ if (wntvn) {
+
+/* Path 4 (M much larger than N, JOBU='S', JOBVT='N') */
+/* N left singular vectors to be computed in U and */
+/* no right singular vectors to be computed */
+
+/* Computing MAX */
+ i__2 = *n << 2;
+ if (*lwork >= *n * *n + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+ if (*lwork >= wrkbl + *lda * *n) {
+
+/* WORK(IR) is LDA by N */
+
+ ldwrkr = *lda;
+ } else {
+
+/* WORK(IR) is N by N */
+
+ ldwrkr = *n;
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy R to WORK(IR), zeroing out below it */
+
+ dlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &
+ ldwrkr);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[ir
+ + 1], &ldwrkr);
+
+/* Generate Q in A */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IR) */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Generate left vectors bidiagonalizing R in WORK(IR) */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IR) */
+/* (Workspace: need N*N+BDSPAC) */
+
+ dbdsqr_("U", n, &c__0, n, &c__0, &s[1], &work[ie],
+ dum, &c__1, &work[ir], &ldwrkr, dum, &c__1, &
+ work[iwork], info);
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IR), storing result in U */
+/* (Workspace: need N*N) */
+
+ dgemm_("N", "N", m, n, n, &c_b443, &a[a_offset], lda,
+ &work[ir], &ldwrkr, &c_b421, &u[u_offset],
+ ldu);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Zero out below R in A */
+
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &a[
+ a_dim1 + 2], lda);
+
+/* Bidiagonalize R in A */
+/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left vectors bidiagonalizing R */
+/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
+ work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr)
+ ;
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("U", n, &c__0, m, &c__0, &s[1], &work[ie],
+ dum, &c__1, &u[u_offset], ldu, dum, &c__1, &
+ work[iwork], info);
+
+ }
+
+ } else if (wntvo) {
+
+/* Path 5 (M much larger than N, JOBU='S', JOBVT='O') */
+/* N left singular vectors to be computed in U and */
+/* N right singular vectors to be overwritten on A */
+
+/* Computing MAX */
+ i__2 = *n << 2;
+ if (*lwork >= (*n << 1) * *n + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + (*lda << 1) * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is LDA by N */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *lda;
+ } else if (*lwork >= wrkbl + (*lda + *n) * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is N by N */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *n;
+ } else {
+
+/* WORK(IU) is N by N and WORK(IR) is N by N */
+
+ ldwrku = *n;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *n;
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy R to WORK(IU), zeroing out below it */
+
+ dlacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[iu
+ + 1], &ldwrku);
+
+/* Generate Q in A */
+/* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IU), copying result to */
+/* WORK(IR) */
+/* (Workspace: need 2*N*N+4*N, */
+/* prefer 2*N*N+3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ dlacpy_("U", n, n, &work[iu], &ldwrku, &work[ir], &
+ ldwrkr);
+
+/* Generate left bidiagonalizing vectors in WORK(IU) */
+/* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in WORK(IR) */
+/* (Workspace: need 2*N*N+4*N-1, */
+/* prefer 2*N*N+3*N+(N-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("P", n, n, n, &work[ir], &ldwrkr, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IU) and computing */
+/* right singular vectors of R in WORK(IR) */
+/* (Workspace: need 2*N*N+BDSPAC) */
+
+ dbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &work[
+ ir], &ldwrkr, &work[iu], &ldwrku, dum, &c__1,
+ &work[iwork], info);
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IU), storing result in U */
+/* (Workspace: need N*N) */
+
+ dgemm_("N", "N", m, n, n, &c_b443, &a[a_offset], lda,
+ &work[iu], &ldwrku, &c_b421, &u[u_offset],
+ ldu);
+
+/* Copy right singular vectors of R to A */
+/* (Workspace: need N*N) */
+
+ dlacpy_("F", n, n, &work[ir], &ldwrkr, &a[a_offset],
+ lda);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Zero out below R in A */
+
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &a[
+ a_dim1 + 2], lda);
+
+/* Bidiagonalize R in A */
+/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left vectors bidiagonalizing R */
+/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
+ work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr)
+ ;
+
+/* Generate right vectors bidiagonalizing R in A */
+/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup],
+ &work[iwork], &i__2, &ierr);
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in A */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &a[
+ a_offset], lda, &u[u_offset], ldu, dum, &c__1,
+ &work[iwork], info);
+
+ }
+
+ } else if (wntvas) {
+
+/* Path 6 (M much larger than N, JOBU='S', JOBVT='S' */
+/* or 'A') */
+/* N left singular vectors to be computed in U and */
+/* N right singular vectors to be computed in VT */
+
+/* Computing MAX */
+ i__2 = *n << 2;
+ if (*lwork >= *n * *n + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + *lda * *n) {
+
+/* WORK(IU) is LDA by N */
+
+ ldwrku = *lda;
+ } else {
+
+/* WORK(IU) is N by N */
+
+ ldwrku = *n;
+ }
+ itau = iu + ldwrku * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy R to WORK(IU), zeroing out below it */
+
+ dlacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[iu
+ + 1], &ldwrku);
+
+/* Generate Q in A */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IU), copying result to VT */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ dlacpy_("U", n, n, &work[iu], &ldwrku, &vt[vt_offset],
+ ldvt);
+
+/* Generate left bidiagonalizing vectors in WORK(IU) */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in VT */
+/* (Workspace: need N*N+4*N-1, */
+/* prefer N*N+3*N+(N-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
+ itaup], &work[iwork], &i__2, &ierr)
+ ;
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IU) and computing */
+/* right singular vectors of R in VT */
+/* (Workspace: need N*N+BDSPAC) */
+
+ dbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &work[iu], &ldwrku, dum, &
+ c__1, &work[iwork], info);
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IU), storing result in U */
+/* (Workspace: need N*N) */
+
+ dgemm_("N", "N", m, n, n, &c_b443, &a[a_offset], lda,
+ &work[iu], &ldwrku, &c_b421, &u[u_offset],
+ ldu);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy R to VT, zeroing out below it */
+
+ dlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+ if (*n > 1) {
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &vt[
+ vt_dim1 + 2], ldvt);
+ }
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in VT */
+/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie],
+ &work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left bidiagonalizing vectors */
+/* in VT */
+/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dormbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt,
+ &work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in VT */
+/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
+ itaup], &work[iwork], &i__2, &ierr)
+ ;
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in VT */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, dum, &
+ c__1, &work[iwork], info);
+
+ }
+
+ }
+
+ } else if (wntua) {
+
+ if (wntvn) {
+
+/* Path 7 (M much larger than N, JOBU='A', JOBVT='N') */
+/* M left singular vectors to be computed in U and */
+/* no right singular vectors to be computed */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *n << 2, i__2 = max(i__2,i__3);
+ if (*lwork >= *n * *n + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+ if (*lwork >= wrkbl + *lda * *n) {
+
+/* WORK(IR) is LDA by N */
+
+ ldwrkr = *lda;
+ } else {
+
+/* WORK(IR) is N by N */
+
+ ldwrkr = *n;
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Copy R to WORK(IR), zeroing out below it */
+
+ dlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &
+ ldwrkr);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[ir
+ + 1], &ldwrkr);
+
+/* Generate Q in U */
+/* (Workspace: need N*N+N+M, prefer N*N+N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IR) */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in WORK(IR) */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IR) */
+/* (Workspace: need N*N+BDSPAC) */
+
+ dbdsqr_("U", n, &c__0, n, &c__0, &s[1], &work[ie],
+ dum, &c__1, &work[ir], &ldwrkr, dum, &c__1, &
+ work[iwork], info);
+
+/* Multiply Q in U by left singular vectors of R in */
+/* WORK(IR), storing result in A */
+/* (Workspace: need N*N) */
+
+ dgemm_("N", "N", m, n, n, &c_b443, &u[u_offset], ldu,
+ &work[ir], &ldwrkr, &c_b421, &a[a_offset],
+ lda);
+
+/* Copy left singular vectors of A from A to U */
+
+ dlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (Workspace: need N+M, prefer N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Zero out below R in A */
+
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &a[
+ a_dim1 + 2], lda);
+
+/* Bidiagonalize R in A */
+/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left bidiagonalizing vectors */
+/* in A */
+/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
+ work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr)
+ ;
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("U", n, &c__0, m, &c__0, &s[1], &work[ie],
+ dum, &c__1, &u[u_offset], ldu, dum, &c__1, &
+ work[iwork], info);
+
+ }
+
+ } else if (wntvo) {
+
+/* Path 8 (M much larger than N, JOBU='A', JOBVT='O') */
+/* M left singular vectors to be computed in U and */
+/* N right singular vectors to be overwritten on A */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *n << 2, i__2 = max(i__2,i__3);
+ if (*lwork >= (*n << 1) * *n + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + (*lda << 1) * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is LDA by N */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *lda;
+ } else if (*lwork >= wrkbl + (*lda + *n) * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is N by N */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *n;
+ } else {
+
+/* WORK(IU) is N by N and WORK(IR) is N by N */
+
+ ldwrku = *n;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *n;
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (Workspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy R to WORK(IU), zeroing out below it */
+
+ dlacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[iu
+ + 1], &ldwrku);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IU), copying result to */
+/* WORK(IR) */
+/* (Workspace: need 2*N*N+4*N, */
+/* prefer 2*N*N+3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ dlacpy_("U", n, n, &work[iu], &ldwrku, &work[ir], &
+ ldwrkr);
+
+/* Generate left bidiagonalizing vectors in WORK(IU) */
+/* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in WORK(IR) */
+/* (Workspace: need 2*N*N+4*N-1, */
+/* prefer 2*N*N+3*N+(N-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("P", n, n, n, &work[ir], &ldwrkr, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IU) and computing */
+/* right singular vectors of R in WORK(IR) */
+/* (Workspace: need 2*N*N+BDSPAC) */
+
+ dbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &work[
+ ir], &ldwrkr, &work[iu], &ldwrku, dum, &c__1,
+ &work[iwork], info);
+
+/* Multiply Q in U by left singular vectors of R in */
+/* WORK(IU), storing result in A */
+/* (Workspace: need N*N) */
+
+ dgemm_("N", "N", m, n, n, &c_b443, &u[u_offset], ldu,
+ &work[iu], &ldwrku, &c_b421, &a[a_offset],
+ lda);
+
+/* Copy left singular vectors of A from A to U */
+
+ dlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Copy right singular vectors of R from WORK(IR) to A */
+
+ dlacpy_("F", n, n, &work[ir], &ldwrkr, &a[a_offset],
+ lda);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (Workspace: need N+M, prefer N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Zero out below R in A */
+
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &a[
+ a_dim1 + 2], lda);
+
+/* Bidiagonalize R in A */
+/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left bidiagonalizing vectors */
+/* in A */
+/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
+ work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr)
+ ;
+
+/* Generate right bidiagonalizing vectors in A */
+/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup],
+ &work[iwork], &i__2, &ierr);
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in A */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &a[
+ a_offset], lda, &u[u_offset], ldu, dum, &c__1,
+ &work[iwork], info);
+
+ }
+
+ } else if (wntvas) {
+
+/* Path 9 (M much larger than N, JOBU='A', JOBVT='S' */
+/* or 'A') */
+/* M left singular vectors to be computed in U and */
+/* N right singular vectors to be computed in VT */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *n << 2, i__2 = max(i__2,i__3);
+ if (*lwork >= *n * *n + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + *lda * *n) {
+
+/* WORK(IU) is LDA by N */
+
+ ldwrku = *lda;
+ } else {
+
+/* WORK(IU) is N by N */
+
+ ldwrku = *n;
+ }
+ itau = iu + ldwrku * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (Workspace: need N*N+N+M, prefer N*N+N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy R to WORK(IU), zeroing out below it */
+
+ dlacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[iu
+ + 1], &ldwrku);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IU), copying result to VT */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ dlacpy_("U", n, n, &work[iu], &ldwrku, &vt[vt_offset],
+ ldvt);
+
+/* Generate left bidiagonalizing vectors in WORK(IU) */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in VT */
+/* (Workspace: need N*N+4*N-1, */
+/* prefer N*N+3*N+(N-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
+ itaup], &work[iwork], &i__2, &ierr)
+ ;
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IU) and computing */
+/* right singular vectors of R in VT */
+/* (Workspace: need N*N+BDSPAC) */
+
+ dbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &work[iu], &ldwrku, dum, &
+ c__1, &work[iwork], info);
+
+/* Multiply Q in U by left singular vectors of R in */
+/* WORK(IU), storing result in A */
+/* (Workspace: need N*N) */
+
+ dgemm_("N", "N", m, n, n, &c_b443, &u[u_offset], ldu,
+ &work[iu], &ldwrku, &c_b421, &a[a_offset],
+ lda);
+
+/* Copy left singular vectors of A from A to U */
+
+ dlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (Workspace: need N+M, prefer N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy R from A to VT, zeroing out below it */
+
+ dlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+ if (*n > 1) {
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ dlaset_("L", &i__2, &i__3, &c_b421, &c_b421, &vt[
+ vt_dim1 + 2], ldvt);
+ }
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in VT */
+/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie],
+ &work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left bidiagonalizing vectors */
+/* in VT */
+/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dormbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt,
+ &work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in VT */
+/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
+ itaup], &work[iwork], &i__2, &ierr)
+ ;
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in VT */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, dum, &
+ c__1, &work[iwork], info);
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* M .LT. MNTHR */
+
+/* Path 10 (M at least N, but not much larger) */
+/* Reduce to bidiagonal form without QR decomposition */
+
+ ie = 1;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize A */
+/* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
+ work[itaup], &work[iwork], &i__2, &ierr);
+ if (wntuas) {
+
+/* If left singular vectors desired in U, copy result to U */
+/* and generate left bidiagonalizing vectors in U */
+/* (Workspace: need 3*N+NCU, prefer 3*N+NCU*NB) */
+
+ dlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu);
+ if (wntus) {
+ ncu = *n;
+ }
+ if (wntua) {
+ ncu = *m;
+ }
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("Q", m, &ncu, n, &u[u_offset], ldu, &work[itauq], &
+ work[iwork], &i__2, &ierr);
+ }
+ if (wntvas) {
+
+/* If right singular vectors desired in VT, copy result to */
+/* VT and generate right bidiagonalizing vectors in VT */
+/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */
+
+ dlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], &
+ work[iwork], &i__2, &ierr);
+ }
+ if (wntuo) {
+
+/* If left singular vectors desired in A, generate left */
+/* bidiagonalizing vectors in A */
+/* (Workspace: need 4*N, prefer 3*N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], &work[
+ iwork], &i__2, &ierr);
+ }
+ if (wntvo) {
+
+/* If right singular vectors desired in A, generate right */
+/* bidiagonalizing vectors in A */
+/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[
+ iwork], &i__2, &ierr);
+ }
+ iwork = ie + *n;
+ if (wntuas || wntuo) {
+ nru = *m;
+ }
+ if (wntun) {
+ nru = 0;
+ }
+ if (wntvas || wntvo) {
+ ncvt = *n;
+ }
+ if (wntvn) {
+ ncvt = 0;
+ }
+ if (! wntuo && ! wntvo) {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in U and computing right singular */
+/* vectors in VT */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, dum, &c__1, &
+ work[iwork], info);
+ } else if (! wntuo && wntvo) {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in U and computing right singular */
+/* vectors in A */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &a[
+ a_offset], lda, &u[u_offset], ldu, dum, &c__1, &work[
+ iwork], info);
+ } else {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in A and computing right singular */
+/* vectors in VT */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, &
+ work[iwork], info);
+ }
+
+ }
+
+ } else {
+
+/* A has more columns than rows. If A has sufficiently more */
+/* columns than rows, first reduce using the LQ decomposition (if */
+/* sufficient workspace available) */
+
+ if (*n >= mnthr) {
+
+ if (wntvn) {
+
+/* Path 1t(N much larger than M, JOBVT='N') */
+/* No right singular vectors to be computed */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &
+ i__2, &ierr);
+
+/* Zero out above L */
+
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &a[(a_dim1 << 1)
+ + 1], lda);
+ ie = 1;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in A */
+/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__2, &ierr);
+ if (wntuo || wntuas) {
+
+/* If left singular vectors desired, generate Q */
+/* (Workspace: need 4*M, prefer 3*M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq], &
+ work[iwork], &i__2, &ierr);
+ }
+ iwork = ie + *m;
+ nru = 0;
+ if (wntuo || wntuas) {
+ nru = *m;
+ }
+
+/* Perform bidiagonal QR iteration, computing left singular */
+/* vectors of A in A if desired */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("U", m, &c__0, &nru, &c__0, &s[1], &work[ie], dum, &
+ c__1, &a[a_offset], lda, dum, &c__1, &work[iwork],
+ info);
+
+/* If left singular vectors desired in U, copy them there */
+
+ if (wntuas) {
+ dlacpy_("F", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+ }
+
+ } else if (wntvo && wntun) {
+
+/* Path 2t(N much larger than M, JOBU='N', JOBVT='O') */
+/* M right singular vectors to be overwritten on A and */
+/* no left singular vectors to be computed */
+
+/* Computing MAX */
+ i__2 = *m << 2;
+ if (*lwork >= *m * *m + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *lda * *n + *m;
+ if (*lwork >= max(i__2,i__3) + *lda * *m) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is LDA by M */
+
+ ldwrku = *lda;
+ chunk = *n;
+ ldwrkr = *lda;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *lda * *n + *m;
+ if (*lwork >= max(i__2,i__3) + *m * *m) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is M by M */
+
+ ldwrku = *lda;
+ chunk = *n;
+ ldwrkr = *m;
+ } else {
+
+/* WORK(IU) is M by CHUNK and WORK(IR) is M by M */
+
+ ldwrku = *m;
+ chunk = (*lwork - *m * *m - *m) / *m;
+ ldwrkr = *m;
+ }
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__2, &ierr);
+
+/* Copy L to WORK(IR) and zero out above it */
+
+ dlacpy_("L", m, m, &a[a_offset], lda, &work[ir], &ldwrkr);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[ir +
+ ldwrkr], &ldwrkr);
+
+/* Generate Q in A */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IR) */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__2, &ierr);
+
+/* Generate right vectors bidiagonalizing L */
+/* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup], &
+ work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of L in WORK(IR) */
+/* (Workspace: need M*M+BDSPAC) */
+
+ dbdsqr_("U", m, m, &c__0, &c__0, &s[1], &work[ie], &work[
+ ir], &ldwrkr, dum, &c__1, dum, &c__1, &work[iwork]
+, info);
+ iu = ie + *m;
+
+/* Multiply right singular vectors of L in WORK(IR) by Q */
+/* in A, storing result in WORK(IU) and copying to A */
+/* (Workspace: need M*M+2*M, prefer M*M+M*N+M) */
+
+ i__2 = *n;
+ i__3 = chunk;
+ for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
+ i__3) {
+/* Computing MIN */
+ i__4 = *n - i__ + 1;
+ blk = min(i__4,chunk);
+ dgemm_("N", "N", m, &blk, m, &c_b443, &work[ir], &
+ ldwrkr, &a[i__ * a_dim1 + 1], lda, &c_b421, &
+ work[iu], &ldwrku);
+ dlacpy_("F", m, &blk, &work[iu], &ldwrku, &a[i__ *
+ a_dim1 + 1], lda);
+/* L30: */
+ }
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ ie = 1;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize A */
+/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__3, &ierr);
+
+/* Generate right vectors bidiagonalizing A */
+/* (Workspace: need 4*M, prefer 3*M+M*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ dorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &
+ work[iwork], &i__3, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of A in A */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("L", m, n, &c__0, &c__0, &s[1], &work[ie], &a[
+ a_offset], lda, dum, &c__1, dum, &c__1, &work[
+ iwork], info);
+
+ }
+
+ } else if (wntvo && wntuas) {
+
+/* Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O') */
+/* M right singular vectors to be overwritten on A and */
+/* M left singular vectors to be computed in U */
+
+/* Computing MAX */
+ i__3 = *m << 2;
+ if (*lwork >= *m * *m + max(i__3,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+/* Computing MAX */
+ i__3 = wrkbl, i__2 = *lda * *n + *m;
+ if (*lwork >= max(i__3,i__2) + *lda * *m) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is LDA by M */
+
+ ldwrku = *lda;
+ chunk = *n;
+ ldwrkr = *lda;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__3 = wrkbl, i__2 = *lda * *n + *m;
+ if (*lwork >= max(i__3,i__2) + *m * *m) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is M by M */
+
+ ldwrku = *lda;
+ chunk = *n;
+ ldwrkr = *m;
+ } else {
+
+/* WORK(IU) is M by CHUNK and WORK(IR) is M by M */
+
+ ldwrku = *m;
+ chunk = (*lwork - *m * *m - *m) / *m;
+ ldwrkr = *m;
+ }
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__3, &ierr);
+
+/* Copy L to U, zeroing about above it */
+
+ dlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+ i__3 = *m - 1;
+ i__2 = *m - 1;
+ dlaset_("U", &i__3, &i__2, &c_b421, &c_b421, &u[(u_dim1 <<
+ 1) + 1], ldu);
+
+/* Generate Q in A */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__3, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in U, copying result to WORK(IR) */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__3, &ierr);
+ dlacpy_("U", m, m, &u[u_offset], ldu, &work[ir], &ldwrkr);
+
+/* Generate right vectors bidiagonalizing L in WORK(IR) */
+/* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ dorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup], &
+ work[iwork], &i__3, &ierr);
+
+/* Generate left vectors bidiagonalizing L in U */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], &
+ work[iwork], &i__3, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of L in U, and computing right */
+/* singular vectors of L in WORK(IR) */
+/* (Workspace: need M*M+BDSPAC) */
+
+ dbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[ir],
+ &ldwrkr, &u[u_offset], ldu, dum, &c__1, &work[
+ iwork], info);
+ iu = ie + *m;
+
+/* Multiply right singular vectors of L in WORK(IR) by Q */
+/* in A, storing result in WORK(IU) and copying to A */
+/* (Workspace: need M*M+2*M, prefer M*M+M*N+M)) */
+
+ i__3 = *n;
+ i__2 = chunk;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__4 = *n - i__ + 1;
+ blk = min(i__4,chunk);
+ dgemm_("N", "N", m, &blk, m, &c_b443, &work[ir], &
+ ldwrkr, &a[i__ * a_dim1 + 1], lda, &c_b421, &
+ work[iu], &ldwrku);
+ dlacpy_("F", m, &blk, &work[iu], &ldwrku, &a[i__ *
+ a_dim1 + 1], lda);
+/* L40: */
+ }
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__2, &ierr);
+
+/* Copy L to U, zeroing out above it */
+
+ dlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &u[(u_dim1 <<
+ 1) + 1], ldu);
+
+/* Generate Q in A */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in U */
+/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__2, &ierr);
+
+/* Multiply right vectors bidiagonalizing L by Q in A */
+/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dormbr_("P", "L", "T", m, n, m, &u[u_offset], ldu, &work[
+ itaup], &a[a_offset], lda, &work[iwork], &i__2, &
+ ierr);
+
+/* Generate left vectors bidiagonalizing L in U */
+/* (Workspace: need 4*M, prefer 3*M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], &
+ work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in A */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &a[
+ a_offset], lda, &u[u_offset], ldu, dum, &c__1, &
+ work[iwork], info);
+
+ }
+
+ } else if (wntvs) {
+
+ if (wntun) {
+
+/* Path 4t(N much larger than M, JOBU='N', JOBVT='S') */
+/* M right singular vectors to be computed in VT and */
+/* no left singular vectors to be computed */
+
+/* Computing MAX */
+ i__2 = *m << 2;
+ if (*lwork >= *m * *m + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+ if (*lwork >= wrkbl + *lda * *m) {
+
+/* WORK(IR) is LDA by M */
+
+ ldwrkr = *lda;
+ } else {
+
+/* WORK(IR) is M by M */
+
+ ldwrkr = *m;
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy L to WORK(IR), zeroing out above it */
+
+ dlacpy_("L", m, m, &a[a_offset], lda, &work[ir], &
+ ldwrkr);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[ir
+ + ldwrkr], &ldwrkr);
+
+/* Generate Q in A */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IR) */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Generate right vectors bidiagonalizing L in */
+/* WORK(IR) */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of L in WORK(IR) */
+/* (Workspace: need M*M+BDSPAC) */
+
+ dbdsqr_("U", m, m, &c__0, &c__0, &s[1], &work[ie], &
+ work[ir], &ldwrkr, dum, &c__1, dum, &c__1, &
+ work[iwork], info);
+
+/* Multiply right singular vectors of L in WORK(IR) by */
+/* Q in A, storing result in VT */
+/* (Workspace: need M*M) */
+
+ dgemm_("N", "N", m, n, m, &c_b443, &work[ir], &ldwrkr,
+ &a[a_offset], lda, &c_b421, &vt[vt_offset],
+ ldvt);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy result to VT */
+
+ dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Zero out above L in A */
+
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &a[(
+ a_dim1 << 1) + 1], lda);
+
+/* Bidiagonalize L in A */
+/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right vectors bidiagonalizing L by Q in VT */
+/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of A in VT */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("U", m, n, &c__0, &c__0, &s[1], &work[ie], &
+ vt[vt_offset], ldvt, dum, &c__1, dum, &c__1, &
+ work[iwork], info);
+
+ }
+
+ } else if (wntuo) {
+
+/* Path 5t(N much larger than M, JOBU='O', JOBVT='S') */
+/* M right singular vectors to be computed in VT and */
+/* M left singular vectors to be overwritten on A */
+
+/* Computing MAX */
+ i__2 = *m << 2;
+ if (*lwork >= (*m << 1) * *m + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + (*lda << 1) * *m) {
+
+/* WORK(IU) is LDA by M and WORK(IR) is LDA by M */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *lda;
+ } else if (*lwork >= wrkbl + (*lda + *m) * *m) {
+
+/* WORK(IU) is LDA by M and WORK(IR) is M by M */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *m;
+ } else {
+
+/* WORK(IU) is M by M and WORK(IR) is M by M */
+
+ ldwrku = *m;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *m;
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy L to WORK(IU), zeroing out below it */
+
+ dlacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[iu
+ + ldwrku], &ldwrku);
+
+/* Generate Q in A */
+/* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IU), copying result to */
+/* WORK(IR) */
+/* (Workspace: need 2*M*M+4*M, */
+/* prefer 2*M*M+3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ dlacpy_("L", m, m, &work[iu], &ldwrku, &work[ir], &
+ ldwrkr);
+
+/* Generate right bidiagonalizing vectors in WORK(IU) */
+/* (Workspace: need 2*M*M+4*M-1, */
+/* prefer 2*M*M+3*M+(M-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in WORK(IR) */
+/* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("Q", m, m, m, &work[ir], &ldwrkr, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of L in WORK(IR) and computing */
+/* right singular vectors of L in WORK(IU) */
+/* (Workspace: need 2*M*M+BDSPAC) */
+
+ dbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[
+ iu], &ldwrku, &work[ir], &ldwrkr, dum, &c__1,
+ &work[iwork], info);
+
+/* Multiply right singular vectors of L in WORK(IU) by */
+/* Q in A, storing result in VT */
+/* (Workspace: need M*M) */
+
+ dgemm_("N", "N", m, n, m, &c_b443, &work[iu], &ldwrku,
+ &a[a_offset], lda, &c_b421, &vt[vt_offset],
+ ldvt);
+
+/* Copy left singular vectors of L to A */
+/* (Workspace: need M*M) */
+
+ dlacpy_("F", m, m, &work[ir], &ldwrkr, &a[a_offset],
+ lda);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Zero out above L in A */
+
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &a[(
+ a_dim1 << 1) + 1], lda);
+
+/* Bidiagonalize L in A */
+/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right vectors bidiagonalizing L by Q in VT */
+/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors of L in A */
+/* (Workspace: need 4*M, prefer 3*M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, compute left */
+/* singular vectors of A in A and compute right */
+/* singular vectors of A in VT */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &a[a_offset], lda, dum, &
+ c__1, &work[iwork], info);
+
+ }
+
+ } else if (wntuas) {
+
+/* Path 6t(N much larger than M, JOBU='S' or 'A', */
+/* JOBVT='S') */
+/* M right singular vectors to be computed in VT and */
+/* M left singular vectors to be computed in U */
+
+/* Computing MAX */
+ i__2 = *m << 2;
+ if (*lwork >= *m * *m + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + *lda * *m) {
+
+/* WORK(IU) is LDA by N */
+
+ ldwrku = *lda;
+ } else {
+
+/* WORK(IU) is LDA by M */
+
+ ldwrku = *m;
+ }
+ itau = iu + ldwrku * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy L to WORK(IU), zeroing out above it */
+
+ dlacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[iu
+ + ldwrku], &ldwrku);
+
+/* Generate Q in A */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorglq_(m, n, m, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IU), copying result to U */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ dlacpy_("L", m, m, &work[iu], &ldwrku, &u[u_offset],
+ ldu);
+
+/* Generate right bidiagonalizing vectors in WORK(IU) */
+/* (Workspace: need M*M+4*M-1, */
+/* prefer M*M+3*M+(M-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in U */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of L in U and computing right */
+/* singular vectors of L in WORK(IU) */
+/* (Workspace: need M*M+BDSPAC) */
+
+ dbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[
+ iu], &ldwrku, &u[u_offset], ldu, dum, &c__1, &
+ work[iwork], info);
+
+/* Multiply right singular vectors of L in WORK(IU) by */
+/* Q in A, storing result in VT */
+/* (Workspace: need M*M) */
+
+ dgemm_("N", "N", m, n, m, &c_b443, &work[iu], &ldwrku,
+ &a[a_offset], lda, &c_b421, &vt[vt_offset],
+ ldvt);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy L to U, zeroing out above it */
+
+ dlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset],
+ ldu);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &u[(
+ u_dim1 << 1) + 1], ldu);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in U */
+/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right bidiagonalizing vectors in U by Q */
+/* in VT */
+/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dormbr_("P", "L", "T", m, n, m, &u[u_offset], ldu, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in U */
+/* (Workspace: need 4*M, prefer 3*M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in VT */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, dum, &
+ c__1, &work[iwork], info);
+
+ }
+
+ }
+
+ } else if (wntva) {
+
+ if (wntun) {
+
+/* Path 7t(N much larger than M, JOBU='N', JOBVT='A') */
+/* N right singular vectors to be computed in VT and */
+/* no left singular vectors to be computed */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *m << 2, i__2 = max(i__2,i__3);
+ if (*lwork >= *m * *m + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+ if (*lwork >= wrkbl + *lda * *m) {
+
+/* WORK(IR) is LDA by M */
+
+ ldwrkr = *lda;
+ } else {
+
+/* WORK(IR) is M by M */
+
+ ldwrkr = *m;
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Copy L to WORK(IR), zeroing out above it */
+
+ dlacpy_("L", m, m, &a[a_offset], lda, &work[ir], &
+ ldwrkr);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[ir
+ + ldwrkr], &ldwrkr);
+
+/* Generate Q in VT */
+/* (Workspace: need M*M+M+N, prefer M*M+M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IR) */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in WORK(IR) */
+/* (Workspace: need M*M+4*M-1, */
+/* prefer M*M+3*M+(M-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of L in WORK(IR) */
+/* (Workspace: need M*M+BDSPAC) */
+
+ dbdsqr_("U", m, m, &c__0, &c__0, &s[1], &work[ie], &
+ work[ir], &ldwrkr, dum, &c__1, dum, &c__1, &
+ work[iwork], info);
+
+/* Multiply right singular vectors of L in WORK(IR) by */
+/* Q in VT, storing result in A */
+/* (Workspace: need M*M) */
+
+ dgemm_("N", "N", m, n, m, &c_b443, &work[ir], &ldwrkr,
+ &vt[vt_offset], ldvt, &c_b421, &a[a_offset],
+ lda);
+
+/* Copy right singular vectors of A from A to VT */
+
+ dlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (Workspace: need M+N, prefer M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Zero out above L in A */
+
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &a[(
+ a_dim1 << 1) + 1], lda);
+
+/* Bidiagonalize L in A */
+/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right bidiagonalizing vectors in A by Q */
+/* in VT */
+/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of A in VT */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("U", m, n, &c__0, &c__0, &s[1], &work[ie], &
+ vt[vt_offset], ldvt, dum, &c__1, dum, &c__1, &
+ work[iwork], info);
+
+ }
+
+ } else if (wntuo) {
+
+/* Path 8t(N much larger than M, JOBU='O', JOBVT='A') */
+/* N right singular vectors to be computed in VT and */
+/* M left singular vectors to be overwritten on A */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *m << 2, i__2 = max(i__2,i__3);
+ if (*lwork >= (*m << 1) * *m + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + (*lda << 1) * *m) {
+
+/* WORK(IU) is LDA by M and WORK(IR) is LDA by M */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *lda;
+ } else if (*lwork >= wrkbl + (*lda + *m) * *m) {
+
+/* WORK(IU) is LDA by M and WORK(IR) is M by M */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *m;
+ } else {
+
+/* WORK(IU) is M by M and WORK(IR) is M by M */
+
+ ldwrku = *m;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *m;
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (Workspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy L to WORK(IU), zeroing out above it */
+
+ dlacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[iu
+ + ldwrku], &ldwrku);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IU), copying result to */
+/* WORK(IR) */
+/* (Workspace: need 2*M*M+4*M, */
+/* prefer 2*M*M+3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ dlacpy_("L", m, m, &work[iu], &ldwrku, &work[ir], &
+ ldwrkr);
+
+/* Generate right bidiagonalizing vectors in WORK(IU) */
+/* (Workspace: need 2*M*M+4*M-1, */
+/* prefer 2*M*M+3*M+(M-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in WORK(IR) */
+/* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("Q", m, m, m, &work[ir], &ldwrkr, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of L in WORK(IR) and computing */
+/* right singular vectors of L in WORK(IU) */
+/* (Workspace: need 2*M*M+BDSPAC) */
+
+ dbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[
+ iu], &ldwrku, &work[ir], &ldwrkr, dum, &c__1,
+ &work[iwork], info);
+
+/* Multiply right singular vectors of L in WORK(IU) by */
+/* Q in VT, storing result in A */
+/* (Workspace: need M*M) */
+
+ dgemm_("N", "N", m, n, m, &c_b443, &work[iu], &ldwrku,
+ &vt[vt_offset], ldvt, &c_b421, &a[a_offset],
+ lda);
+
+/* Copy right singular vectors of A from A to VT */
+
+ dlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Copy left singular vectors of A from WORK(IR) to A */
+
+ dlacpy_("F", m, m, &work[ir], &ldwrkr, &a[a_offset],
+ lda);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (Workspace: need M+N, prefer M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Zero out above L in A */
+
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &a[(
+ a_dim1 << 1) + 1], lda);
+
+/* Bidiagonalize L in A */
+/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right bidiagonalizing vectors in A by Q */
+/* in VT */
+/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in A */
+/* (Workspace: need 4*M, prefer 3*M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in A and computing right */
+/* singular vectors of A in VT */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &a[a_offset], lda, dum, &
+ c__1, &work[iwork], info);
+
+ }
+
+ } else if (wntuas) {
+
+/* Path 9t(N much larger than M, JOBU='S' or 'A', */
+/* JOBVT='A') */
+/* N right singular vectors to be computed in VT and */
+/* M left singular vectors to be computed in U */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *m << 2, i__2 = max(i__2,i__3);
+ if (*lwork >= *m * *m + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + *lda * *m) {
+
+/* WORK(IU) is LDA by M */
+
+ ldwrku = *lda;
+ } else {
+
+/* WORK(IU) is M by M */
+
+ ldwrku = *m;
+ }
+ itau = iu + ldwrku * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (Workspace: need M*M+M+N, prefer M*M+M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy L to WORK(IU), zeroing out above it */
+
+ dlacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[iu
+ + ldwrku], &ldwrku);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IU), copying result to U */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ dlacpy_("L", m, m, &work[iu], &ldwrku, &u[u_offset],
+ ldu);
+
+/* Generate right bidiagonalizing vectors in WORK(IU) */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in U */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of L in U and computing right */
+/* singular vectors of L in WORK(IU) */
+/* (Workspace: need M*M+BDSPAC) */
+
+ dbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[
+ iu], &ldwrku, &u[u_offset], ldu, dum, &c__1, &
+ work[iwork], info);
+
+/* Multiply right singular vectors of L in WORK(IU) by */
+/* Q in VT, storing result in A */
+/* (Workspace: need M*M) */
+
+ dgemm_("N", "N", m, n, m, &c_b443, &work[iu], &ldwrku,
+ &vt[vt_offset], ldvt, &c_b421, &a[a_offset],
+ lda);
+
+/* Copy right singular vectors of A from A to VT */
+
+ dlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (Workspace: need M+N, prefer M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy L to U, zeroing out above it */
+
+ dlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset],
+ ldu);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ dlaset_("U", &i__2, &i__3, &c_b421, &c_b421, &u[(
+ u_dim1 << 1) + 1], ldu);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in U */
+/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right bidiagonalizing vectors in U by Q */
+/* in VT */
+/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dormbr_("P", "L", "T", m, n, m, &u[u_offset], ldu, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in U */
+/* (Workspace: need 4*M, prefer 3*M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in VT */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, dum, &
+ c__1, &work[iwork], info);
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N .LT. MNTHR */
+
+/* Path 10t(N greater than M, but not much larger) */
+/* Reduce to bidiagonal form without LQ decomposition */
+
+ ie = 1;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize A */
+/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
+ work[itaup], &work[iwork], &i__2, &ierr);
+ if (wntuas) {
+
+/* If left singular vectors desired in U, copy result to U */
+/* and generate left bidiagonalizing vectors in U */
+/* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB) */
+
+ dlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("Q", m, m, n, &u[u_offset], ldu, &work[itauq], &work[
+ iwork], &i__2, &ierr);
+ }
+ if (wntvas) {
+
+/* If right singular vectors desired in VT, copy result to */
+/* VT and generate right bidiagonalizing vectors in VT */
+/* (Workspace: need 3*M+NRVT, prefer 3*M+NRVT*NB) */
+
+ dlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+ if (wntva) {
+ nrvt = *n;
+ }
+ if (wntvs) {
+ nrvt = *m;
+ }
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("P", &nrvt, n, m, &vt[vt_offset], ldvt, &work[itaup],
+ &work[iwork], &i__2, &ierr);
+ }
+ if (wntuo) {
+
+/* If left singular vectors desired in A, generate left */
+/* bidiagonalizing vectors in A */
+/* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("Q", m, m, n, &a[a_offset], lda, &work[itauq], &work[
+ iwork], &i__2, &ierr);
+ }
+ if (wntvo) {
+
+/* If right singular vectors desired in A, generate right */
+/* bidiagonalizing vectors in A */
+/* (Workspace: need 4*M, prefer 3*M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ dorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[
+ iwork], &i__2, &ierr);
+ }
+ iwork = ie + *m;
+ if (wntuas || wntuo) {
+ nru = *m;
+ }
+ if (wntun) {
+ nru = 0;
+ }
+ if (wntvas || wntvo) {
+ ncvt = *n;
+ }
+ if (wntvn) {
+ ncvt = 0;
+ }
+ if (! wntuo && ! wntvo) {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in U and computing right singular */
+/* vectors in VT */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, dum, &c__1, &
+ work[iwork], info);
+ } else if (! wntuo && wntvo) {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in U and computing right singular */
+/* vectors in A */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &a[
+ a_offset], lda, &u[u_offset], ldu, dum, &c__1, &work[
+ iwork], info);
+ } else {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in A and computing right singular */
+/* vectors in VT */
+/* (Workspace: need BDSPAC) */
+
+ dbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, &
+ work[iwork], info);
+ }
+
+ }
+
+ }
+
+/* If DBDSQR failed to converge, copy unconverged superdiagonals */
+/* to WORK( 2:MINMN ) */
+
+ if (*info != 0) {
+ if (ie > 2) {
+ i__2 = minmn - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__ + 1] = work[i__ + ie - 1];
+/* L50: */
+ }
+ }
+ if (ie < 2) {
+ for (i__ = minmn - 1; i__ >= 1; --i__) {
+ work[i__ + 1] = work[i__ + ie - 1];
+/* L60: */
+ }
+ }
+ }
+
+/* Undo scaling if necessary */
+
+ if (iscl == 1) {
+ if (anrm > bignum) {
+ dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, &ierr);
+ }
+ if (*info != 0 && anrm > bignum) {
+ i__2 = minmn - 1;
+ dlascl_("G", &c__0, &c__0, &bignum, &anrm, &i__2, &c__1, &work[2],
+ &minmn, &ierr);
+ }
+ if (anrm < smlnum) {
+ dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, &ierr);
+ }
+ if (*info != 0 && anrm < smlnum) {
+ i__2 = minmn - 1;
+ dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &i__2, &c__1, &work[2],
+ &minmn, &ierr);
+ }
+ }
+
+/* Return optimal workspace in WORK(1) */
+
+ work[1] = (doublereal) maxwrk;
+
+ return 0;
+
+/* End of DGESVD */
+
+} /* dgesvd_ */
diff --git a/SRC/dgesvj.c b/SRC/dgesvj.c
new file mode 100644
index 0000000..2d36977
--- /dev/null
+++ b/SRC/dgesvj.c
@@ -0,0 +1,1796 @@
+/* dgesvj.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b17 = 0.;
+static doublereal c_b18 = 1.;
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c__2 = 2;
+
+/* Subroutine */ int dgesvj_(char *joba, char *jobu, char *jobv, integer *m,
+ integer *n, doublereal *a, integer *lda, doublereal *sva, integer *mv,
+ doublereal *v, integer *ldv, doublereal *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ doublereal bigtheta;
+ integer pskipped, i__, p, q;
+ doublereal t;
+ integer n2, n4;
+ doublereal rootsfmin;
+ integer n34;
+ doublereal cs, sn;
+ integer ir1, jbc;
+ doublereal big;
+ integer kbl, igl, ibr, jgl, nbl;
+ doublereal tol;
+ integer mvl;
+ doublereal aapp, aapq, aaqq;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal ctol;
+ integer ierr;
+ doublereal aapp0;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ doublereal temp1;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal scale, large, apoaq, aqoap;
+ extern logical lsame_(char *, char *);
+ doublereal theta, small, sfmin;
+ logical lsvec;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ doublereal fastr[5];
+ extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical applv, rsvec;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *);
+ logical uctol;
+ extern /* Subroutine */ int drotm_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *);
+ logical lower, upper, rotok;
+ extern /* Subroutine */ int dgsvj0_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *), dgsvj1_(
+ char *, integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ integer ijblsk, swband, blskip;
+ doublereal mxaapq;
+ extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
+ doublereal *, doublereal *);
+ doublereal thsign, mxsinj;
+ integer emptsw, notrot, iswrot, lkahead;
+ logical goscale, noscale;
+ doublereal rootbig, epsilon, rooteps;
+ integer rowskip;
+ doublereal roottol;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Zlatko Drmac of the University of Zagreb and -- */
+/* -- Kresimir Veselic of the Fernuniversitaet Hagen -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* This routine is also part of SIGMA (version 1.23, October 23. 2008.) */
+/* SIGMA is a library of algorithms for highly accurate algorithms for */
+/* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the */
+/* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0. */
+
+/* -#- Scalar Arguments -#- */
+
+
+/* -#- Array Arguments -#- */
+
+/* .. */
+
+/* Purpose */
+/* ~~~~~~~ */
+/* DGESVJ computes the singular value decomposition (SVD) of a real */
+/* M-by-N matrix A, where M >= N. The SVD of A is written as */
+/* [++] [xx] [x0] [xx] */
+/* A = U * SIGMA * V^t, [++] = [xx] * [ox] * [xx] */
+/* [++] [xx] */
+/* where SIGMA is an N-by-N diagonal matrix, U is an M-by-N orthonormal */
+/* matrix, and V is an N-by-N orthogonal matrix. The diagonal elements */
+/* of SIGMA are the singular values of A. The columns of U and V are the */
+/* left and the right singular vectors of A, respectively. */
+
+/* Further Details */
+/* ~~~~~~~~~~~~~~~ */
+/* The orthogonal N-by-N matrix V is obtained as a product of Jacobi plane */
+/* rotations. The rotations are implemented as fast scaled rotations of */
+/* Anda and Park [1]. In the case of underflow of the Jacobi angle, a */
+/* modified Jacobi transformation of Drmac [4] is used. Pivot strategy uses */
+/* column interchanges of de Rijk [2]. The relative accuracy of the computed */
+/* singular values and the accuracy of the computed singular vectors (in */
+/* angle metric) is as guaranteed by the theory of Demmel and Veselic [3]. */
+/* The condition number that determines the accuracy in the full rank case */
+/* is essentially min_{D=diag} kappa(A*D), where kappa(.) is the */
+/* spectral condition number. The best performance of this Jacobi SVD */
+/* procedure is achieved if used in an accelerated version of Drmac and */
+/* Veselic [5,6], and it is the kernel routine in the SIGMA library [7]. */
+/* Some tunning parameters (marked with [TP]) are available for the */
+/* implementer. */
+/* The computational range for the nonzero singular values is the machine */
+/* number interval ( UNDERFLOW , OVERFLOW ). In extreme cases, even */
+/* denormalized singular values can be computed with the corresponding */
+/* gradual loss of accurate digits. */
+
+/* Contributors */
+/* ~~~~~~~~~~~~ */
+/* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) */
+
+/* References */
+/* ~~~~~~~~~~ */
+/* [1] A. A. Anda and H. Park: Fast plane rotations with dynamic scaling. */
+/* SIAM J. matrix Anal. Appl., Vol. 15 (1994), pp. 162-174. */
+/* [2] P. P. M. De Rijk: A one-sided Jacobi algorithm for computing the */
+/* singular value decomposition on a vector computer. */
+/* SIAM J. Sci. Stat. Comp., Vol. 10 (1998), pp. 359-371. */
+/* [3] J. Demmel and K. Veselic: Jacobi method is more accurate than QR. */
+/* [4] Z. Drmac: Implementation of Jacobi rotations for accurate singular */
+/* value computation in floating point arithmetic. */
+/* SIAM J. Sci. Comp., Vol. 18 (1997), pp. 1200-1222. */
+/* [5] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I. */
+/* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342. */
+/* LAPACK Working note 169. */
+/* [6] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II. */
+/* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362. */
+/* LAPACK Working note 170. */
+/* [7] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV, */
+/* QSVD, (H,K)-SVD computations. */
+/* Department of Mathematics, University of Zagreb, 2008. */
+
+/* Bugs, Examples and Comments */
+/* ~~~~~~~~~~~~~~~~~~~~~~~~~~~ */
+/* Please report all bugs and send interesting test examples and comments to */
+/* drmac at math.hr. Thank you. */
+
+/* Arguments */
+/* ~~~~~~~~~ */
+
+/* JOBA (input) CHARACTER* 1 */
+/* Specifies the structure of A. */
+/* = 'L': The input matrix A is lower triangular; */
+/* = 'U': The input matrix A is upper triangular; */
+/* = 'G': The input matrix A is general M-by-N matrix, M >= N. */
+
+/* JOBU (input) CHARACTER*1 */
+/* Specifies whether to compute the left singular vectors */
+/* (columns of U): */
+
+/* = 'U': The left singular vectors corresponding to the nonzero */
+/* singular values are computed and returned in the leading */
+/* columns of A. See more details in the description of A. */
+/* The default numerical orthogonality threshold is set to */
+/* approximately TOL=CTOL*EPS, CTOL=DSQRT(M), EPS=DLAMCH('E'). */
+/* = 'C': Analogous to JOBU='U', except that user can control the */
+/* level of numerical orthogonality of the computed left */
+/* singular vectors. TOL can be set to TOL = CTOL*EPS, where */
+/* CTOL is given on input in the array WORK. */
+/* No CTOL smaller than ONE is allowed. CTOL greater */
+/* than 1 / EPS is meaningless. The option 'C' */
+/* can be used if M*EPS is satisfactory orthogonality */
+/* of the computed left singular vectors, so CTOL=M could */
+/* save few sweeps of Jacobi rotations. */
+/* See the descriptions of A and WORK(1). */
+/* = 'N': The matrix U is not computed. However, see the */
+/* description of A. */
+
+/* JOBV (input) CHARACTER*1 */
+/* Specifies whether to compute the right singular vectors, that */
+/* is, the matrix V: */
+/* = 'V' : the matrix V is computed and returned in the array V */
+/* = 'A' : the Jacobi rotations are applied to the MV-by-N */
+/* array V. In other words, the right singular vector */
+/* matrix V is not computed explicitly, instead it is */
+/* applied to an MV-by-N matrix initially stored in the */
+/* first MV rows of V. */
+/* = 'N' : the matrix V is not computed and the array V is not */
+/* referenced */
+
+/* M (input) INTEGER */
+/* The number of rows of the input matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the input matrix A. */
+/* M >= N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, */
+/* If JOBU .EQ. 'U' .OR. JOBU .EQ. 'C': */
+/* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ */
+/* If INFO .EQ. 0, */
+/* ~~~~~~~~~~~~~~~ */
+/* RANKA orthonormal columns of U are returned in the */
+/* leading RANKA columns of the array A. Here RANKA <= N */
+/* is the number of computed singular values of A that are */
+/* above the underflow threshold DLAMCH('S'). The singular */
+/* vectors corresponding to underflowed or zero singular */
+/* values are not computed. The value of RANKA is returned */
+/* in the array WORK as RANKA=NINT(WORK(2)). Also see the */
+/* descriptions of SVA and WORK. The computed columns of U */
+/* are mutually numerically orthogonal up to approximately */
+/* TOL=DSQRT(M)*EPS (default); or TOL=CTOL*EPS (JOBU.EQ.'C'), */
+/* see the description of JOBU. */
+/* If INFO .GT. 0, */
+/* ~~~~~~~~~~~~~~~ */
+/* the procedure DGESVJ did not converge in the given number */
+/* of iterations (sweeps). In that case, the computed */
+/* columns of U may not be orthogonal up to TOL. The output */
+/* U (stored in A), SIGMA (given by the computed singular */
+/* values in SVA(1:N)) and V is still a decomposition of the */
+/* input matrix A in the sense that the residual */
+/* ||A-SCALE*U*SIGMA*V^T||_2 / ||A||_2 is small. */
+
+/* If JOBU .EQ. 'N': */
+/* ~~~~~~~~~~~~~~~~~ */
+/* If INFO .EQ. 0 */
+/* ~~~~~~~~~~~~~~ */
+/* Note that the left singular vectors are 'for free' in the */
+/* one-sided Jacobi SVD algorithm. However, if only the */
+/* singular values are needed, the level of numerical */
+/* orthogonality of U is not an issue and iterations are */
+/* stopped when the columns of the iterated matrix are */
+/* numerically orthogonal up to approximately M*EPS. Thus, */
+/* on exit, A contains the columns of U scaled with the */
+/* corresponding singular values. */
+/* If INFO .GT. 0, */
+/* ~~~~~~~~~~~~~~~ */
+/* the procedure DGESVJ did not converge in the given number */
+/* of iterations (sweeps). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* SVA (workspace/output) REAL array, dimension (N) */
+/* On exit, */
+/* If INFO .EQ. 0, */
+/* ~~~~~~~~~~~~~~~ */
+/* depending on the value SCALE = WORK(1), we have: */
+/* If SCALE .EQ. ONE: */
+/* ~~~~~~~~~~~~~~~~~~ */
+/* SVA(1:N) contains the computed singular values of A. */
+/* During the computation SVA contains the Euclidean column */
+/* norms of the iterated matrices in the array A. */
+/* If SCALE .NE. ONE: */
+/* ~~~~~~~~~~~~~~~~~~ */
+/* The singular values of A are SCALE*SVA(1:N), and this */
+/* factored representation is due to the fact that some of the */
+/* singular values of A might underflow or overflow. */
+
+/* If INFO .GT. 0, */
+/* ~~~~~~~~~~~~~~~ */
+/* the procedure DGESVJ did not converge in the given number of */
+/* iterations (sweeps) and SCALE*SVA(1:N) may not be accurate. */
+
+/* MV (input) INTEGER */
+/* If JOBV .EQ. 'A', then the product of Jacobi rotations in DGESVJ */
+/* is applied to the first MV rows of V. See the description of JOBV. */
+
+/* V (input/output) REAL array, dimension (LDV,N) */
+/* If JOBV = 'V', then V contains on exit the N-by-N matrix of */
+/* the right singular vectors; */
+/* If JOBV = 'A', then V contains the product of the computed right */
+/* singular vector matrix and the initial matrix in */
+/* the array V. */
+/* If JOBV = 'N', then V is not referenced. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V, LDV .GE. 1. */
+/* If JOBV .EQ. 'V', then LDV .GE. max(1,N). */
+/* If JOBV .EQ. 'A', then LDV .GE. max(1,MV) . */
+
+/* WORK (input/workspace/output) REAL array, dimension max(4,M+N). */
+/* On entry, */
+/* If JOBU .EQ. 'C', */
+/* ~~~~~~~~~~~~~~~~~ */
+/* WORK(1) = CTOL, where CTOL defines the threshold for convergence. */
+/* The process stops if all columns of A are mutually */
+/* orthogonal up to CTOL*EPS, EPS=DLAMCH('E'). */
+/* It is required that CTOL >= ONE, i.e. it is not */
+/* allowed to force the routine to obtain orthogonality */
+/* below EPSILON. */
+/* On exit, */
+/* WORK(1) = SCALE is the scaling factor such that SCALE*SVA(1:N) */
+/* are the computed singular vcalues of A. */
+/* (See description of SVA().) */
+/* WORK(2) = NINT(WORK(2)) is the number of the computed nonzero */
+/* singular values. */
+/* WORK(3) = NINT(WORK(3)) is the number of the computed singular */
+/* values that are larger than the underflow threshold. */
+/* WORK(4) = NINT(WORK(4)) is the number of sweeps of Jacobi */
+/* rotations needed for numerical convergence. */
+/* WORK(5) = max_{i.NE.j} |COS(A(:,i),A(:,j))| in the last sweep. */
+/* This is useful information in cases when DGESVJ did */
+/* not converge, as it can be used to estimate whether */
+/* the output is stil useful and for post festum analysis. */
+/* WORK(6) = the largest absolute value over all sines of the */
+/* Jacobi rotation angles in the last sweep. It can be */
+/* useful for a post festum analysis. */
+
+/* LWORK length of WORK, WORK >= MAX(6,M+N) */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit. */
+/* < 0 : if INFO = -i, then the i-th argument had an illegal value */
+/* > 0 : DGESVJ did not converge in the maximal allowed number (30) */
+/* of sweeps. The output may still be useful. See the */
+/* description of WORK. */
+
+/* Local Parameters */
+
+
+/* Local Scalars */
+
+
+/* Local Arrays */
+
+
+/* Intrinsic Functions */
+
+
+/* External Functions */
+/* .. from BLAS */
+/* .. from LAPACK */
+
+/* External Subroutines */
+/* .. from BLAS */
+/* .. from LAPACK */
+
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --sva;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --work;
+
+ /* Function Body */
+ lsvec = lsame_(jobu, "U");
+ uctol = lsame_(jobu, "C");
+ rsvec = lsame_(jobv, "V");
+ applv = lsame_(jobv, "A");
+ upper = lsame_(joba, "U");
+ lower = lsame_(joba, "L");
+
+ if (! (upper || lower || lsame_(joba, "G"))) {
+ *info = -1;
+ } else if (! (lsvec || uctol || lsame_(jobu, "N")))
+ {
+ *info = -2;
+ } else if (! (rsvec || applv || lsame_(jobv, "N")))
+ {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*n < 0 || *n > *m) {
+ *info = -5;
+ } else if (*lda < *m) {
+ *info = -7;
+ } else if (*mv < 0) {
+ *info = -9;
+ } else if (rsvec && *ldv < *n || applv && *ldv < *mv) {
+ *info = -11;
+ } else if (uctol && work[1] <= 1.) {
+ *info = -12;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = *m + *n;
+ if (*lwork < max(i__1,6)) {
+ *info = -13;
+ } else {
+ *info = 0;
+ }
+ }
+
+/* #:( */
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGESVJ", &i__1);
+ return 0;
+ }
+
+/* #:) Quick return for void matrix */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Set numerical parameters */
+/* The stopping criterion for Jacobi rotations is */
+
+/* max_{i<>j}|A(:,i)^T * A(:,j)|/(||A(:,i)||*||A(:,j)||) < CTOL*EPS */
+
+/* where EPS is the round-off and CTOL is defined as follows: */
+
+ if (uctol) {
+/* ... user controlled */
+ ctol = work[1];
+ } else {
+/* ... default */
+ if (lsvec || rsvec || applv) {
+ ctol = sqrt((doublereal) (*m));
+ } else {
+ ctol = (doublereal) (*m);
+ }
+ }
+/* ... and the machine dependent parameters are */
+/* [!] (Make sure that DLAMCH() works properly on the target machine.) */
+
+ epsilon = dlamch_("Epsilon");
+ rooteps = sqrt(epsilon);
+ sfmin = dlamch_("SafeMinimum");
+ rootsfmin = sqrt(sfmin);
+ small = sfmin / epsilon;
+ big = dlamch_("Overflow");
+/* BIG = ONE / SFMIN */
+ rootbig = 1. / rootsfmin;
+ large = big / sqrt((doublereal) (*m * *n));
+ bigtheta = 1. / rooteps;
+
+ tol = ctol * epsilon;
+ roottol = sqrt(tol);
+
+ if ((doublereal) (*m) * epsilon >= 1.) {
+ *info = -5;
+ i__1 = -(*info);
+ xerbla_("DGESVJ", &i__1);
+ return 0;
+ }
+
+/* Initialize the right singular vector matrix. */
+
+ if (rsvec) {
+ mvl = *n;
+ dlaset_("A", &mvl, n, &c_b17, &c_b18, &v[v_offset], ldv);
+ } else if (applv) {
+ mvl = *mv;
+ }
+ rsvec = rsvec || applv;
+
+/* Initialize SVA( 1:N ) = ( ||A e_i||_2, i = 1:N ) */
+/* (!) If necessary, scale A to protect the largest singular value */
+/* from overflow. It is possible that saving the largest singular */
+/* value destroys the information about the small ones. */
+/* This initial scaling is almost minimal in the sense that the */
+/* goal is to make sure that no column norm overflows, and that */
+/* DSQRT(N)*max_i SVA(i) does not overflow. If INFinite entries */
+/* in A are detected, the procedure returns with INFO=-6. */
+
+ scale = 1. / sqrt((doublereal) (*m) * (doublereal) (*n));
+ noscale = TRUE_;
+ goscale = TRUE_;
+
+ if (lower) {
+/* the input matrix is M-by-N lower triangular (trapezoidal) */
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ aapp = 0.;
+ aaqq = 0.;
+ i__2 = *m - p + 1;
+ dlassq_(&i__2, &a[p + p * a_dim1], &c__1, &aapp, &aaqq);
+ if (aapp > big) {
+ *info = -6;
+ i__2 = -(*info);
+ xerbla_("DGESVJ", &i__2);
+ return 0;
+ }
+ aaqq = sqrt(aaqq);
+ if (aapp < big / aaqq && noscale) {
+ sva[p] = aapp * aaqq;
+ } else {
+ noscale = FALSE_;
+ sva[p] = aapp * (aaqq * scale);
+ if (goscale) {
+ goscale = FALSE_;
+ i__2 = p - 1;
+ for (q = 1; q <= i__2; ++q) {
+ sva[q] *= scale;
+/* L1873: */
+ }
+ }
+ }
+/* L1874: */
+ }
+ } else if (upper) {
+/* the input matrix is M-by-N upper triangular (trapezoidal) */
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ aapp = 0.;
+ aaqq = 0.;
+ dlassq_(&p, &a[p * a_dim1 + 1], &c__1, &aapp, &aaqq);
+ if (aapp > big) {
+ *info = -6;
+ i__2 = -(*info);
+ xerbla_("DGESVJ", &i__2);
+ return 0;
+ }
+ aaqq = sqrt(aaqq);
+ if (aapp < big / aaqq && noscale) {
+ sva[p] = aapp * aaqq;
+ } else {
+ noscale = FALSE_;
+ sva[p] = aapp * (aaqq * scale);
+ if (goscale) {
+ goscale = FALSE_;
+ i__2 = p - 1;
+ for (q = 1; q <= i__2; ++q) {
+ sva[q] *= scale;
+/* L2873: */
+ }
+ }
+ }
+/* L2874: */
+ }
+ } else {
+/* the input matrix is M-by-N general dense */
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ aapp = 0.;
+ aaqq = 0.;
+ dlassq_(m, &a[p * a_dim1 + 1], &c__1, &aapp, &aaqq);
+ if (aapp > big) {
+ *info = -6;
+ i__2 = -(*info);
+ xerbla_("DGESVJ", &i__2);
+ return 0;
+ }
+ aaqq = sqrt(aaqq);
+ if (aapp < big / aaqq && noscale) {
+ sva[p] = aapp * aaqq;
+ } else {
+ noscale = FALSE_;
+ sva[p] = aapp * (aaqq * scale);
+ if (goscale) {
+ goscale = FALSE_;
+ i__2 = p - 1;
+ for (q = 1; q <= i__2; ++q) {
+ sva[q] *= scale;
+/* L3873: */
+ }
+ }
+ }
+/* L3874: */
+ }
+ }
+
+ if (noscale) {
+ scale = 1.;
+ }
+
+/* Move the smaller part of the spectrum from the underflow threshold */
+/* (!) Start by determining the position of the nonzero entries of the */
+/* array SVA() relative to ( SFMIN, BIG ). */
+
+ aapp = 0.;
+ aaqq = big;
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ if (sva[p] != 0.) {
+/* Computing MIN */
+ d__1 = aaqq, d__2 = sva[p];
+ aaqq = min(d__1,d__2);
+ }
+/* Computing MAX */
+ d__1 = aapp, d__2 = sva[p];
+ aapp = max(d__1,d__2);
+/* L4781: */
+ }
+
+/* #:) Quick return for zero matrix */
+
+ if (aapp == 0.) {
+ if (lsvec) {
+ dlaset_("G", m, n, &c_b17, &c_b18, &a[a_offset], lda);
+ }
+ work[1] = 1.;
+ work[2] = 0.;
+ work[3] = 0.;
+ work[4] = 0.;
+ work[5] = 0.;
+ work[6] = 0.;
+ return 0;
+ }
+
+/* #:) Quick return for one-column matrix */
+
+ if (*n == 1) {
+ if (lsvec) {
+ dlascl_("G", &c__0, &c__0, &sva[1], &scale, m, &c__1, &a[a_dim1 +
+ 1], lda, &ierr);
+ }
+ work[1] = 1. / scale;
+ if (sva[1] >= sfmin) {
+ work[2] = 1.;
+ } else {
+ work[2] = 0.;
+ }
+ work[3] = 0.;
+ work[4] = 0.;
+ work[5] = 0.;
+ work[6] = 0.;
+ return 0;
+ }
+
+/* Protect small singular values from underflow, and try to */
+/* avoid underflows/overflows in computing Jacobi rotations. */
+
+ sn = sqrt(sfmin / epsilon);
+ temp1 = sqrt(big / (doublereal) (*n));
+ if (aapp <= sn || aaqq >= temp1 || sn <= aaqq && aapp <= temp1) {
+/* Computing MIN */
+ d__1 = big, d__2 = temp1 / aapp;
+ temp1 = min(d__1,d__2);
+/* AAQQ = AAQQ*TEMP1 */
+/* AAPP = AAPP*TEMP1 */
+ } else if (aaqq <= sn && aapp <= temp1) {
+/* Computing MIN */
+ d__1 = sn / aaqq, d__2 = big / (aapp * sqrt((doublereal) (*n)));
+ temp1 = min(d__1,d__2);
+/* AAQQ = AAQQ*TEMP1 */
+/* AAPP = AAPP*TEMP1 */
+ } else if (aaqq >= sn && aapp >= temp1) {
+/* Computing MAX */
+ d__1 = sn / aaqq, d__2 = temp1 / aapp;
+ temp1 = max(d__1,d__2);
+/* AAQQ = AAQQ*TEMP1 */
+/* AAPP = AAPP*TEMP1 */
+ } else if (aaqq <= sn && aapp >= temp1) {
+/* Computing MIN */
+ d__1 = sn / aaqq, d__2 = big / (sqrt((doublereal) (*n)) * aapp);
+ temp1 = min(d__1,d__2);
+/* AAQQ = AAQQ*TEMP1 */
+/* AAPP = AAPP*TEMP1 */
+ } else {
+ temp1 = 1.;
+ }
+
+/* Scale, if necessary */
+
+ if (temp1 != 1.) {
+ dlascl_("G", &c__0, &c__0, &c_b18, &temp1, n, &c__1, &sva[1], n, &
+ ierr);
+ }
+ scale = temp1 * scale;
+ if (scale != 1.) {
+ dlascl_(joba, &c__0, &c__0, &c_b18, &scale, m, n, &a[a_offset], lda, &
+ ierr);
+ scale = 1. / scale;
+ }
+
+/* Row-cyclic Jacobi SVD algorithm with column pivoting */
+
+ emptsw = *n * (*n - 1) / 2;
+ notrot = 0;
+ fastr[0] = 0.;
+
+/* A is represented in factored form A = A * diag(WORK), where diag(WORK) */
+/* is initialized to identity. WORK is updated during fast scaled */
+/* rotations. */
+
+ i__1 = *n;
+ for (q = 1; q <= i__1; ++q) {
+ work[q] = 1.;
+/* L1868: */
+ }
+
+
+ swband = 3;
+/* [TP] SWBAND is a tuning parameter [TP]. It is meaningful and effective */
+/* if DGESVJ is used as a computational routine in the preconditioned */
+/* Jacobi SVD algorithm DGESVJ. For sweeps i=1:SWBAND the procedure */
+/* works on pivots inside a band-like region around the diagonal. */
+/* The boundaries are determined dynamically, based on the number of */
+/* pivots above a threshold. */
+
+ kbl = min(8,*n);
+/* [TP] KBL is a tuning parameter that defines the tile size in the */
+/* tiling of the p-q loops of pivot pairs. In general, an optimal */
+/* value of KBL depends on the matrix dimensions and on the */
+/* parameters of the computer's memory. */
+
+ nbl = *n / kbl;
+ if (nbl * kbl != *n) {
+ ++nbl;
+ }
+
+/* Computing 2nd power */
+ i__1 = kbl;
+ blskip = i__1 * i__1;
+/* [TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. */
+
+ rowskip = min(5,kbl);
+/* [TP] ROWSKIP is a tuning parameter. */
+
+ lkahead = 1;
+/* [TP] LKAHEAD is a tuning parameter. */
+
+/* Quasi block transformations, using the lower (upper) triangular */
+/* structure of the input matrix. The quasi-block-cycling usually */
+/* invokes cubic convergence. Big part of this cycle is done inside */
+/* canonical subspaces of dimensions less than M. */
+
+/* Computing MAX */
+ i__1 = 64, i__2 = kbl << 2;
+ if ((lower || upper) && *n > max(i__1,i__2)) {
+/* [TP] The number of partition levels and the actual partition are */
+/* tuning parameters. */
+ n4 = *n / 4;
+ n2 = *n / 2;
+ n34 = n4 * 3;
+ if (applv) {
+ q = 0;
+ } else {
+ q = 1;
+ }
+
+ if (lower) {
+
+/* This works very well on lower triangular matrices, in particular */
+/* in the framework of the preconditioned Jacobi SVD (xGEJSV). */
+/* The idea is simple: */
+/* [+ 0 0 0] Note that Jacobi transformations of [0 0] */
+/* [+ + 0 0] [0 0] */
+/* [+ + x 0] actually work on [x 0] [x 0] */
+/* [+ + x x] [x x]. [x x] */
+
+ i__1 = *m - n34;
+ i__2 = *n - n34;
+ i__3 = *lwork - *n;
+ dgsvj0_(jobv, &i__1, &i__2, &a[n34 + 1 + (n34 + 1) * a_dim1], lda,
+ &work[n34 + 1], &sva[n34 + 1], &mvl, &v[n34 * q + 1 + (
+ n34 + 1) * v_dim1], ldv, &epsilon, &sfmin, &tol, &c__2, &
+ work[*n + 1], &i__3, &ierr);
+
+ i__1 = *m - n2;
+ i__2 = n34 - n2;
+ i__3 = *lwork - *n;
+ dgsvj0_(jobv, &i__1, &i__2, &a[n2 + 1 + (n2 + 1) * a_dim1], lda, &
+ work[n2 + 1], &sva[n2 + 1], &mvl, &v[n2 * q + 1 + (n2 + 1)
+ * v_dim1], ldv, &epsilon, &sfmin, &tol, &c__2, &work[*n
+ + 1], &i__3, &ierr);
+
+ i__1 = *m - n2;
+ i__2 = *n - n2;
+ i__3 = *lwork - *n;
+ dgsvj1_(jobv, &i__1, &i__2, &n4, &a[n2 + 1 + (n2 + 1) * a_dim1],
+ lda, &work[n2 + 1], &sva[n2 + 1], &mvl, &v[n2 * q + 1 + (
+ n2 + 1) * v_dim1], ldv, &epsilon, &sfmin, &tol, &c__1, &
+ work[*n + 1], &i__3, &ierr);
+
+ i__1 = *m - n4;
+ i__2 = n2 - n4;
+ i__3 = *lwork - *n;
+ dgsvj0_(jobv, &i__1, &i__2, &a[n4 + 1 + (n4 + 1) * a_dim1], lda, &
+ work[n4 + 1], &sva[n4 + 1], &mvl, &v[n4 * q + 1 + (n4 + 1)
+ * v_dim1], ldv, &epsilon, &sfmin, &tol, &c__1, &work[*n
+ + 1], &i__3, &ierr);
+
+ i__1 = *lwork - *n;
+ dgsvj0_(jobv, m, &n4, &a[a_offset], lda, &work[1], &sva[1], &mvl,
+ &v[v_offset], ldv, &epsilon, &sfmin, &tol, &c__1, &work[*
+ n + 1], &i__1, &ierr);
+
+ i__1 = *lwork - *n;
+ dgsvj1_(jobv, m, &n2, &n4, &a[a_offset], lda, &work[1], &sva[1], &
+ mvl, &v[v_offset], ldv, &epsilon, &sfmin, &tol, &c__1, &
+ work[*n + 1], &i__1, &ierr);
+
+
+ } else if (upper) {
+
+
+ i__1 = *lwork - *n;
+ dgsvj0_(jobv, &n4, &n4, &a[a_offset], lda, &work[1], &sva[1], &
+ mvl, &v[v_offset], ldv, &epsilon, &sfmin, &tol, &c__2, &
+ work[*n + 1], &i__1, &ierr);
+
+ i__1 = *lwork - *n;
+ dgsvj0_(jobv, &n2, &n4, &a[(n4 + 1) * a_dim1 + 1], lda, &work[n4
+ + 1], &sva[n4 + 1], &mvl, &v[n4 * q + 1 + (n4 + 1) *
+ v_dim1], ldv, &epsilon, &sfmin, &tol, &c__1, &work[*n + 1]
+, &i__1, &ierr);
+
+ i__1 = *lwork - *n;
+ dgsvj1_(jobv, &n2, &n2, &n4, &a[a_offset], lda, &work[1], &sva[1],
+ &mvl, &v[v_offset], ldv, &epsilon, &sfmin, &tol, &c__1, &
+ work[*n + 1], &i__1, &ierr);
+
+ i__1 = n2 + n4;
+ i__2 = *lwork - *n;
+ dgsvj0_(jobv, &i__1, &n4, &a[(n2 + 1) * a_dim1 + 1], lda, &work[
+ n2 + 1], &sva[n2 + 1], &mvl, &v[n2 * q + 1 + (n2 + 1) *
+ v_dim1], ldv, &epsilon, &sfmin, &tol, &c__1, &work[*n + 1]
+, &i__2, &ierr);
+ }
+
+ }
+
+/* -#- Row-cyclic pivot strategy with de Rijk's pivoting -#- */
+
+ for (i__ = 1; i__ <= 30; ++i__) {
+
+/* .. go go go ... */
+
+ mxaapq = 0.;
+ mxsinj = 0.;
+ iswrot = 0;
+
+ notrot = 0;
+ pskipped = 0;
+
+/* Each sweep is unrolled using KBL-by-KBL tiles over the pivot pairs */
+/* 1 <= p < q <= N. This is the first step toward a blocked implementation */
+/* of the rotations. New implementation, based on block transformations, */
+/* is under development. */
+
+ i__1 = nbl;
+ for (ibr = 1; ibr <= i__1; ++ibr) {
+
+ igl = (ibr - 1) * kbl + 1;
+
+/* Computing MIN */
+ i__3 = lkahead, i__4 = nbl - ibr;
+ i__2 = min(i__3,i__4);
+ for (ir1 = 0; ir1 <= i__2; ++ir1) {
+
+ igl += ir1 * kbl;
+
+/* Computing MIN */
+ i__4 = igl + kbl - 1, i__5 = *n - 1;
+ i__3 = min(i__4,i__5);
+ for (p = igl; p <= i__3; ++p) {
+
+/* .. de Rijk's pivoting */
+
+ i__4 = *n - p + 1;
+ q = idamax_(&i__4, &sva[p], &c__1) + p - 1;
+ if (p != q) {
+ dswap_(m, &a[p * a_dim1 + 1], &c__1, &a[q * a_dim1 +
+ 1], &c__1);
+ if (rsvec) {
+ dswap_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q *
+ v_dim1 + 1], &c__1);
+ }
+ temp1 = sva[p];
+ sva[p] = sva[q];
+ sva[q] = temp1;
+ temp1 = work[p];
+ work[p] = work[q];
+ work[q] = temp1;
+ }
+
+ if (ir1 == 0) {
+
+/* Column norms are periodically updated by explicit */
+/* norm computation. */
+/* Caveat: */
+/* Unfortunately, some BLAS implementations compute DNRM2(M,A(1,p),1) */
+/* as DSQRT(DDOT(M,A(1,p),1,A(1,p),1)), which may cause the result to */
+/* overflow for ||A(:,p)||_2 > DSQRT(overflow_threshold), and to */
+/* underflow for ||A(:,p)||_2 < DSQRT(underflow_threshold). */
+/* Hence, DNRM2 cannot be trusted, not even in the case when */
+/* the true norm is far from the under(over)flow boundaries. */
+/* If properly implemented DNRM2 is available, the IF-THEN-ELSE */
+/* below should read "AAPP = DNRM2( M, A(1,p), 1 ) * WORK(p)". */
+
+ if (sva[p] < rootbig && sva[p] > rootsfmin) {
+ sva[p] = dnrm2_(m, &a[p * a_dim1 + 1], &c__1) *
+ work[p];
+ } else {
+ temp1 = 0.;
+ aapp = 0.;
+ dlassq_(m, &a[p * a_dim1 + 1], &c__1, &temp1, &
+ aapp);
+ sva[p] = temp1 * sqrt(aapp) * work[p];
+ }
+ aapp = sva[p];
+ } else {
+ aapp = sva[p];
+ }
+
+ if (aapp > 0.) {
+
+ pskipped = 0;
+
+/* Computing MIN */
+ i__5 = igl + kbl - 1;
+ i__4 = min(i__5,*n);
+ for (q = p + 1; q <= i__4; ++q) {
+
+ aaqq = sva[q];
+
+ if (aaqq > 0.) {
+
+ aapp0 = aapp;
+ if (aaqq >= 1.) {
+ rotok = small * aapp <= aaqq;
+ if (aapp < big / aaqq) {
+ aapq = ddot_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1], &
+ c__1) * work[p] * work[q] /
+ aaqq / aapp;
+ } else {
+ dcopy_(m, &a[p * a_dim1 + 1], &c__1, &
+ work[*n + 1], &c__1);
+ dlascl_("G", &c__0, &c__0, &aapp, &
+ work[p], m, &c__1, &work[*n +
+ 1], lda, &ierr);
+ aapq = ddot_(m, &work[*n + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1) *
+ work[q] / aaqq;
+ }
+ } else {
+ rotok = aapp <= aaqq / small;
+ if (aapp > small / aaqq) {
+ aapq = ddot_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1], &
+ c__1) * work[p] * work[q] /
+ aaqq / aapp;
+ } else {
+ dcopy_(m, &a[q * a_dim1 + 1], &c__1, &
+ work[*n + 1], &c__1);
+ dlascl_("G", &c__0, &c__0, &aaqq, &
+ work[q], m, &c__1, &work[*n +
+ 1], lda, &ierr);
+ aapq = ddot_(m, &work[*n + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1) *
+ work[p] / aapp;
+ }
+ }
+
+/* Computing MAX */
+ d__1 = mxaapq, d__2 = abs(aapq);
+ mxaapq = max(d__1,d__2);
+
+/* TO rotate or NOT to rotate, THAT is the question ... */
+
+ if (abs(aapq) > tol) {
+
+/* .. rotate */
+/* [RTD] ROTATED = ROTATED + ONE */
+
+ if (ir1 == 0) {
+ notrot = 0;
+ pskipped = 0;
+ ++iswrot;
+ }
+
+ if (rotok) {
+
+ aqoap = aaqq / aapp;
+ apoaq = aapp / aaqq;
+ theta = (d__1 = aqoap - apoaq, abs(
+ d__1)) * -.5 / aapq;
+
+ if (abs(theta) > bigtheta) {
+
+ t = .5 / theta;
+ fastr[2] = t * work[p] / work[q];
+ fastr[3] = -t * work[q] / work[p];
+ drotm_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1],
+ &c__1, fastr);
+ if (rsvec) {
+ drotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q *
+ v_dim1 + 1], &c__1, fastr);
+ }
+/* Computing MAX */
+ d__1 = 0., d__2 = t * apoaq *
+ aapq + 1.;
+ sva[q] = aaqq * sqrt((max(d__1,
+ d__2)));
+ aapp *= sqrt(1. - t * aqoap *
+ aapq);
+/* Computing MAX */
+ d__1 = mxsinj, d__2 = abs(t);
+ mxsinj = max(d__1,d__2);
+
+ } else {
+
+/* .. choose correct signum for THETA and rotate */
+
+ thsign = -d_sign(&c_b18, &aapq);
+ t = 1. / (theta + thsign * sqrt(
+ theta * theta + 1.));
+ cs = sqrt(1. / (t * t + 1.));
+ sn = t * cs;
+
+/* Computing MAX */
+ d__1 = mxsinj, d__2 = abs(sn);
+ mxsinj = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = 0., d__2 = t * apoaq *
+ aapq + 1.;
+ sva[q] = aaqq * sqrt((max(d__1,
+ d__2)));
+/* Computing MAX */
+ d__1 = 0., d__2 = 1. - t * aqoap *
+ aapq;
+ aapp *= sqrt((max(d__1,d__2)));
+
+ apoaq = work[p] / work[q];
+ aqoap = work[q] / work[p];
+ if (work[p] >= 1.) {
+ if (work[q] >= 1.) {
+ fastr[2] = t * apoaq;
+ fastr[3] = -t * aqoap;
+ work[p] *= cs;
+ work[q] *= cs;
+ drotm_(m, &a[p * a_dim1 + 1], &c__1, &a[q *
+ a_dim1 + 1], &c__1, fastr);
+ if (rsvec) {
+ drotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[
+ q * v_dim1 + 1], &c__1, fastr);
+ }
+ } else {
+ d__1 = -t * aqoap;
+ daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1, &a[
+ p * a_dim1 + 1], &c__1);
+ d__1 = cs * sn * apoaq;
+ daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1, &a[
+ q * a_dim1 + 1], &c__1);
+ work[p] *= cs;
+ work[q] /= cs;
+ if (rsvec) {
+ d__1 = -t * aqoap;
+ daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1], &
+ c__1, &v[p * v_dim1 + 1], &c__1);
+ d__1 = cs * sn * apoaq;
+ daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1], &
+ c__1, &v[q * v_dim1 + 1], &c__1);
+ }
+ }
+ } else {
+ if (work[q] >= 1.) {
+ d__1 = t * apoaq;
+ daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1, &a[
+ q * a_dim1 + 1], &c__1);
+ d__1 = -cs * sn * aqoap;
+ daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1, &a[
+ p * a_dim1 + 1], &c__1);
+ work[p] /= cs;
+ work[q] *= cs;
+ if (rsvec) {
+ d__1 = t * apoaq;
+ daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1], &
+ c__1, &v[q * v_dim1 + 1], &c__1);
+ d__1 = -cs * sn * aqoap;
+ daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1], &
+ c__1, &v[p * v_dim1 + 1], &c__1);
+ }
+ } else {
+ if (work[p] >= work[q]) {
+ d__1 = -t * aqoap;
+ daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1);
+ d__1 = cs * sn * apoaq;
+ daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1);
+ work[p] *= cs;
+ work[q] /= cs;
+ if (rsvec) {
+ d__1 = -t * aqoap;
+ daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1],
+ &c__1, &v[p * v_dim1 + 1], &
+ c__1);
+ d__1 = cs * sn * apoaq;
+ daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1],
+ &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ }
+ } else {
+ d__1 = t * apoaq;
+ daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1);
+ d__1 = -cs * sn * aqoap;
+ daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1);
+ work[p] /= cs;
+ work[q] *= cs;
+ if (rsvec) {
+ d__1 = t * apoaq;
+ daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1],
+ &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ d__1 = -cs * sn * aqoap;
+ daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1],
+ &c__1, &v[p * v_dim1 + 1], &
+ c__1);
+ }
+ }
+ }
+ }
+ }
+
+ } else {
+/* .. have to use modified Gram-Schmidt like transformation */
+ dcopy_(m, &a[p * a_dim1 + 1], &c__1, &
+ work[*n + 1], &c__1);
+ dlascl_("G", &c__0, &c__0, &aapp, &
+ c_b18, m, &c__1, &work[*n + 1]
+, lda, &ierr);
+ dlascl_("G", &c__0, &c__0, &aaqq, &
+ c_b18, m, &c__1, &a[q *
+ a_dim1 + 1], lda, &ierr);
+ temp1 = -aapq * work[p] / work[q];
+ daxpy_(m, &temp1, &work[*n + 1], &
+ c__1, &a[q * a_dim1 + 1], &
+ c__1);
+ dlascl_("G", &c__0, &c__0, &c_b18, &
+ aaqq, m, &c__1, &a[q * a_dim1
+ + 1], lda, &ierr);
+/* Computing MAX */
+ d__1 = 0., d__2 = 1. - aapq * aapq;
+ sva[q] = aaqq * sqrt((max(d__1,d__2)))
+ ;
+ mxsinj = max(mxsinj,sfmin);
+ }
+/* END IF ROTOK THEN ... ELSE */
+
+/* In the case of cancellation in updating SVA(q), SVA(p) */
+/* recompute SVA(q), SVA(p). */
+
+/* Computing 2nd power */
+ d__1 = sva[q] / aaqq;
+ if (d__1 * d__1 <= rooteps) {
+ if (aaqq < rootbig && aaqq >
+ rootsfmin) {
+ sva[q] = dnrm2_(m, &a[q * a_dim1
+ + 1], &c__1) * work[q];
+ } else {
+ t = 0.;
+ aaqq = 0.;
+ dlassq_(m, &a[q * a_dim1 + 1], &
+ c__1, &t, &aaqq);
+ sva[q] = t * sqrt(aaqq) * work[q];
+ }
+ }
+ if (aapp / aapp0 <= rooteps) {
+ if (aapp < rootbig && aapp >
+ rootsfmin) {
+ aapp = dnrm2_(m, &a[p * a_dim1 +
+ 1], &c__1) * work[p];
+ } else {
+ t = 0.;
+ aapp = 0.;
+ dlassq_(m, &a[p * a_dim1 + 1], &
+ c__1, &t, &aapp);
+ aapp = t * sqrt(aapp) * work[p];
+ }
+ sva[p] = aapp;
+ }
+
+ } else {
+/* A(:,p) and A(:,q) already numerically orthogonal */
+ if (ir1 == 0) {
+ ++notrot;
+ }
+/* [RTD] SKIPPED = SKIPPED + 1 */
+ ++pskipped;
+ }
+ } else {
+/* A(:,q) is zero column */
+ if (ir1 == 0) {
+ ++notrot;
+ }
+ ++pskipped;
+ }
+
+ if (i__ <= swband && pskipped > rowskip) {
+ if (ir1 == 0) {
+ aapp = -aapp;
+ }
+ notrot = 0;
+ goto L2103;
+ }
+
+/* L2002: */
+ }
+/* END q-LOOP */
+
+L2103:
+/* bailed out of q-loop */
+
+ sva[p] = aapp;
+
+ } else {
+ sva[p] = aapp;
+ if (ir1 == 0 && aapp == 0.) {
+/* Computing MIN */
+ i__4 = igl + kbl - 1;
+ notrot = notrot + min(i__4,*n) - p;
+ }
+ }
+
+/* L2001: */
+ }
+/* end of the p-loop */
+/* end of doing the block ( ibr, ibr ) */
+/* L1002: */
+ }
+/* end of ir1-loop */
+
+/* ... go to the off diagonal blocks */
+
+ igl = (ibr - 1) * kbl + 1;
+
+ i__2 = nbl;
+ for (jbc = ibr + 1; jbc <= i__2; ++jbc) {
+
+ jgl = (jbc - 1) * kbl + 1;
+
+/* doing the block at ( ibr, jbc ) */
+
+ ijblsk = 0;
+/* Computing MIN */
+ i__4 = igl + kbl - 1;
+ i__3 = min(i__4,*n);
+ for (p = igl; p <= i__3; ++p) {
+
+ aapp = sva[p];
+ if (aapp > 0.) {
+
+ pskipped = 0;
+
+/* Computing MIN */
+ i__5 = jgl + kbl - 1;
+ i__4 = min(i__5,*n);
+ for (q = jgl; q <= i__4; ++q) {
+
+ aaqq = sva[q];
+ if (aaqq > 0.) {
+ aapp0 = aapp;
+
+/* -#- M x 2 Jacobi SVD -#- */
+
+/* Safe Gram matrix computation */
+
+ if (aaqq >= 1.) {
+ if (aapp >= aaqq) {
+ rotok = small * aapp <= aaqq;
+ } else {
+ rotok = small * aaqq <= aapp;
+ }
+ if (aapp < big / aaqq) {
+ aapq = ddot_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1], &
+ c__1) * work[p] * work[q] /
+ aaqq / aapp;
+ } else {
+ dcopy_(m, &a[p * a_dim1 + 1], &c__1, &
+ work[*n + 1], &c__1);
+ dlascl_("G", &c__0, &c__0, &aapp, &
+ work[p], m, &c__1, &work[*n +
+ 1], lda, &ierr);
+ aapq = ddot_(m, &work[*n + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1) *
+ work[q] / aaqq;
+ }
+ } else {
+ if (aapp >= aaqq) {
+ rotok = aapp <= aaqq / small;
+ } else {
+ rotok = aaqq <= aapp / small;
+ }
+ if (aapp > small / aaqq) {
+ aapq = ddot_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1], &
+ c__1) * work[p] * work[q] /
+ aaqq / aapp;
+ } else {
+ dcopy_(m, &a[q * a_dim1 + 1], &c__1, &
+ work[*n + 1], &c__1);
+ dlascl_("G", &c__0, &c__0, &aaqq, &
+ work[q], m, &c__1, &work[*n +
+ 1], lda, &ierr);
+ aapq = ddot_(m, &work[*n + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1) *
+ work[p] / aapp;
+ }
+ }
+
+/* Computing MAX */
+ d__1 = mxaapq, d__2 = abs(aapq);
+ mxaapq = max(d__1,d__2);
+
+/* TO rotate or NOT to rotate, THAT is the question ... */
+
+ if (abs(aapq) > tol) {
+ notrot = 0;
+/* [RTD] ROTATED = ROTATED + 1 */
+ pskipped = 0;
+ ++iswrot;
+
+ if (rotok) {
+
+ aqoap = aaqq / aapp;
+ apoaq = aapp / aaqq;
+ theta = (d__1 = aqoap - apoaq, abs(
+ d__1)) * -.5 / aapq;
+ if (aaqq > aapp0) {
+ theta = -theta;
+ }
+
+ if (abs(theta) > bigtheta) {
+ t = .5 / theta;
+ fastr[2] = t * work[p] / work[q];
+ fastr[3] = -t * work[q] / work[p];
+ drotm_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1],
+ &c__1, fastr);
+ if (rsvec) {
+ drotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q *
+ v_dim1 + 1], &c__1, fastr);
+ }
+/* Computing MAX */
+ d__1 = 0., d__2 = t * apoaq *
+ aapq + 1.;
+ sva[q] = aaqq * sqrt((max(d__1,
+ d__2)));
+/* Computing MAX */
+ d__1 = 0., d__2 = 1. - t * aqoap *
+ aapq;
+ aapp *= sqrt((max(d__1,d__2)));
+/* Computing MAX */
+ d__1 = mxsinj, d__2 = abs(t);
+ mxsinj = max(d__1,d__2);
+ } else {
+
+/* .. choose correct signum for THETA and rotate */
+
+ thsign = -d_sign(&c_b18, &aapq);
+ if (aaqq > aapp0) {
+ thsign = -thsign;
+ }
+ t = 1. / (theta + thsign * sqrt(
+ theta * theta + 1.));
+ cs = sqrt(1. / (t * t + 1.));
+ sn = t * cs;
+/* Computing MAX */
+ d__1 = mxsinj, d__2 = abs(sn);
+ mxsinj = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = 0., d__2 = t * apoaq *
+ aapq + 1.;
+ sva[q] = aaqq * sqrt((max(d__1,
+ d__2)));
+ aapp *= sqrt(1. - t * aqoap *
+ aapq);
+
+ apoaq = work[p] / work[q];
+ aqoap = work[q] / work[p];
+ if (work[p] >= 1.) {
+
+ if (work[q] >= 1.) {
+ fastr[2] = t * apoaq;
+ fastr[3] = -t * aqoap;
+ work[p] *= cs;
+ work[q] *= cs;
+ drotm_(m, &a[p * a_dim1 + 1], &c__1, &a[q *
+ a_dim1 + 1], &c__1, fastr);
+ if (rsvec) {
+ drotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[
+ q * v_dim1 + 1], &c__1, fastr);
+ }
+ } else {
+ d__1 = -t * aqoap;
+ daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1, &a[
+ p * a_dim1 + 1], &c__1);
+ d__1 = cs * sn * apoaq;
+ daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1, &a[
+ q * a_dim1 + 1], &c__1);
+ if (rsvec) {
+ d__1 = -t * aqoap;
+ daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1], &
+ c__1, &v[p * v_dim1 + 1], &c__1);
+ d__1 = cs * sn * apoaq;
+ daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1], &
+ c__1, &v[q * v_dim1 + 1], &c__1);
+ }
+ work[p] *= cs;
+ work[q] /= cs;
+ }
+ } else {
+ if (work[q] >= 1.) {
+ d__1 = t * apoaq;
+ daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1, &a[
+ q * a_dim1 + 1], &c__1);
+ d__1 = -cs * sn * aqoap;
+ daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1, &a[
+ p * a_dim1 + 1], &c__1);
+ if (rsvec) {
+ d__1 = t * apoaq;
+ daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1], &
+ c__1, &v[q * v_dim1 + 1], &c__1);
+ d__1 = -cs * sn * aqoap;
+ daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1], &
+ c__1, &v[p * v_dim1 + 1], &c__1);
+ }
+ work[p] /= cs;
+ work[q] *= cs;
+ } else {
+ if (work[p] >= work[q]) {
+ d__1 = -t * aqoap;
+ daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1);
+ d__1 = cs * sn * apoaq;
+ daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1);
+ work[p] *= cs;
+ work[q] /= cs;
+ if (rsvec) {
+ d__1 = -t * aqoap;
+ daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1],
+ &c__1, &v[p * v_dim1 + 1], &
+ c__1);
+ d__1 = cs * sn * apoaq;
+ daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1],
+ &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ }
+ } else {
+ d__1 = t * apoaq;
+ daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1);
+ d__1 = -cs * sn * aqoap;
+ daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1);
+ work[p] /= cs;
+ work[q] *= cs;
+ if (rsvec) {
+ d__1 = t * apoaq;
+ daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1],
+ &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ d__1 = -cs * sn * aqoap;
+ daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1],
+ &c__1, &v[p * v_dim1 + 1], &
+ c__1);
+ }
+ }
+ }
+ }
+ }
+
+ } else {
+ if (aapp > aaqq) {
+ dcopy_(m, &a[p * a_dim1 + 1], &
+ c__1, &work[*n + 1], &
+ c__1);
+ dlascl_("G", &c__0, &c__0, &aapp,
+ &c_b18, m, &c__1, &work[*
+ n + 1], lda, &ierr);
+ dlascl_("G", &c__0, &c__0, &aaqq,
+ &c_b18, m, &c__1, &a[q *
+ a_dim1 + 1], lda, &ierr);
+ temp1 = -aapq * work[p] / work[q];
+ daxpy_(m, &temp1, &work[*n + 1], &
+ c__1, &a[q * a_dim1 + 1],
+ &c__1);
+ dlascl_("G", &c__0, &c__0, &c_b18,
+ &aaqq, m, &c__1, &a[q *
+ a_dim1 + 1], lda, &ierr);
+/* Computing MAX */
+ d__1 = 0., d__2 = 1. - aapq *
+ aapq;
+ sva[q] = aaqq * sqrt((max(d__1,
+ d__2)));
+ mxsinj = max(mxsinj,sfmin);
+ } else {
+ dcopy_(m, &a[q * a_dim1 + 1], &
+ c__1, &work[*n + 1], &
+ c__1);
+ dlascl_("G", &c__0, &c__0, &aaqq,
+ &c_b18, m, &c__1, &work[*
+ n + 1], lda, &ierr);
+ dlascl_("G", &c__0, &c__0, &aapp,
+ &c_b18, m, &c__1, &a[p *
+ a_dim1 + 1], lda, &ierr);
+ temp1 = -aapq * work[q] / work[p];
+ daxpy_(m, &temp1, &work[*n + 1], &
+ c__1, &a[p * a_dim1 + 1],
+ &c__1);
+ dlascl_("G", &c__0, &c__0, &c_b18,
+ &aapp, m, &c__1, &a[p *
+ a_dim1 + 1], lda, &ierr);
+/* Computing MAX */
+ d__1 = 0., d__2 = 1. - aapq *
+ aapq;
+ sva[p] = aapp * sqrt((max(d__1,
+ d__2)));
+ mxsinj = max(mxsinj,sfmin);
+ }
+ }
+/* END IF ROTOK THEN ... ELSE */
+
+/* In the case of cancellation in updating SVA(q) */
+/* .. recompute SVA(q) */
+/* Computing 2nd power */
+ d__1 = sva[q] / aaqq;
+ if (d__1 * d__1 <= rooteps) {
+ if (aaqq < rootbig && aaqq >
+ rootsfmin) {
+ sva[q] = dnrm2_(m, &a[q * a_dim1
+ + 1], &c__1) * work[q];
+ } else {
+ t = 0.;
+ aaqq = 0.;
+ dlassq_(m, &a[q * a_dim1 + 1], &
+ c__1, &t, &aaqq);
+ sva[q] = t * sqrt(aaqq) * work[q];
+ }
+ }
+/* Computing 2nd power */
+ d__1 = aapp / aapp0;
+ if (d__1 * d__1 <= rooteps) {
+ if (aapp < rootbig && aapp >
+ rootsfmin) {
+ aapp = dnrm2_(m, &a[p * a_dim1 +
+ 1], &c__1) * work[p];
+ } else {
+ t = 0.;
+ aapp = 0.;
+ dlassq_(m, &a[p * a_dim1 + 1], &
+ c__1, &t, &aapp);
+ aapp = t * sqrt(aapp) * work[p];
+ }
+ sva[p] = aapp;
+ }
+/* end of OK rotation */
+ } else {
+ ++notrot;
+/* [RTD] SKIPPED = SKIPPED + 1 */
+ ++pskipped;
+ ++ijblsk;
+ }
+ } else {
+ ++notrot;
+ ++pskipped;
+ ++ijblsk;
+ }
+
+ if (i__ <= swband && ijblsk >= blskip) {
+ sva[p] = aapp;
+ notrot = 0;
+ goto L2011;
+ }
+ if (i__ <= swband && pskipped > rowskip) {
+ aapp = -aapp;
+ notrot = 0;
+ goto L2203;
+ }
+
+/* L2200: */
+ }
+/* end of the q-loop */
+L2203:
+
+ sva[p] = aapp;
+
+ } else {
+
+ if (aapp == 0.) {
+/* Computing MIN */
+ i__4 = jgl + kbl - 1;
+ notrot = notrot + min(i__4,*n) - jgl + 1;
+ }
+ if (aapp < 0.) {
+ notrot = 0;
+ }
+
+ }
+
+/* L2100: */
+ }
+/* end of the p-loop */
+/* L2010: */
+ }
+/* end of the jbc-loop */
+L2011:
+/* 2011 bailed out of the jbc-loop */
+/* Computing MIN */
+ i__3 = igl + kbl - 1;
+ i__2 = min(i__3,*n);
+ for (p = igl; p <= i__2; ++p) {
+ sva[p] = (d__1 = sva[p], abs(d__1));
+/* L2012: */
+ }
+/* ** */
+/* L2000: */
+ }
+/* 2000 :: end of the ibr-loop */
+
+/* .. update SVA(N) */
+ if (sva[*n] < rootbig && sva[*n] > rootsfmin) {
+ sva[*n] = dnrm2_(m, &a[*n * a_dim1 + 1], &c__1) * work[*n];
+ } else {
+ t = 0.;
+ aapp = 0.;
+ dlassq_(m, &a[*n * a_dim1 + 1], &c__1, &t, &aapp);
+ sva[*n] = t * sqrt(aapp) * work[*n];
+ }
+
+/* Additional steering devices */
+
+ if (i__ < swband && (mxaapq <= roottol || iswrot <= *n)) {
+ swband = i__;
+ }
+
+ if (i__ > swband + 1 && mxaapq < sqrt((doublereal) (*n)) * tol && (
+ doublereal) (*n) * mxaapq * mxsinj < tol) {
+ goto L1994;
+ }
+
+ if (notrot >= emptsw) {
+ goto L1994;
+ }
+
+/* L1993: */
+ }
+/* end i=1:NSWEEP loop */
+
+/* #:( Reaching this point means that the procedure has not converged. */
+ *info = 29;
+ goto L1995;
+
+L1994:
+/* #:) Reaching this point means numerical convergence after the i-th */
+/* sweep. */
+
+ *info = 0;
+/* #:) INFO = 0 confirms successful iterations. */
+L1995:
+
+/* Sort the singular values and find how many are above */
+/* the underflow threshold. */
+
+ n2 = 0;
+ n4 = 0;
+ i__1 = *n - 1;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = *n - p + 1;
+ q = idamax_(&i__2, &sva[p], &c__1) + p - 1;
+ if (p != q) {
+ temp1 = sva[p];
+ sva[p] = sva[q];
+ sva[q] = temp1;
+ temp1 = work[p];
+ work[p] = work[q];
+ work[q] = temp1;
+ dswap_(m, &a[p * a_dim1 + 1], &c__1, &a[q * a_dim1 + 1], &c__1);
+ if (rsvec) {
+ dswap_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ }
+ }
+ if (sva[p] != 0.) {
+ ++n4;
+ if (sva[p] * scale > sfmin) {
+ ++n2;
+ }
+ }
+/* L5991: */
+ }
+ if (sva[*n] != 0.) {
+ ++n4;
+ if (sva[*n] * scale > sfmin) {
+ ++n2;
+ }
+ }
+
+/* Normalize the left singular vectors. */
+
+ if (lsvec || uctol) {
+ i__1 = n2;
+ for (p = 1; p <= i__1; ++p) {
+ d__1 = work[p] / sva[p];
+ dscal_(m, &d__1, &a[p * a_dim1 + 1], &c__1);
+/* L1998: */
+ }
+ }
+
+/* Scale the product of Jacobi rotations (assemble the fast rotations). */
+
+ if (rsvec) {
+ if (applv) {
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ dscal_(&mvl, &work[p], &v[p * v_dim1 + 1], &c__1);
+/* L2398: */
+ }
+ } else {
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ temp1 = 1. / dnrm2_(&mvl, &v[p * v_dim1 + 1], &c__1);
+ dscal_(&mvl, &temp1, &v[p * v_dim1 + 1], &c__1);
+/* L2399: */
+ }
+ }
+ }
+
+/* Undo scaling, if necessary (and possible). */
+ if (scale > 1. && sva[1] < big / scale || scale < 1. && sva[n2] > sfmin /
+ scale) {
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ sva[p] = scale * sva[p];
+/* L2400: */
+ }
+ scale = 1.;
+ }
+
+ work[1] = scale;
+/* The singular values of A are SCALE*SVA(1:N). If SCALE.NE.ONE */
+/* then some of the singular values may overflow or underflow and */
+/* the spectrum is given in this factored representation. */
+
+ work[2] = (doublereal) n4;
+/* N4 is the number of computed nonzero singular values of A. */
+
+ work[3] = (doublereal) n2;
+/* N2 is the number of singular values of A greater than SFMIN. */
+/* If N2<N, SVA(N2:N) contains ZEROS and/or denormalized numbers */
+/* that may carry some information. */
+
+ work[4] = (doublereal) i__;
+/* i is the index of the last sweep before declaring convergence. */
+
+ work[5] = mxaapq;
+/* MXAAPQ is the largest absolute value of scaled pivots in the */
+/* last sweep */
+
+ work[6] = mxsinj;
+/* MXSINJ is the largest absolute value of the sines of Jacobi angles */
+/* in the last sweep */
+
+ return 0;
+/* .. */
+/* .. END OF DGESVJ */
+/* .. */
+} /* dgesvj_ */
diff --git a/SRC/dgesvx.c b/SRC/dgesvx.c
new file mode 100644
index 0000000..ab372d0
--- /dev/null
+++ b/SRC/dgesvx.c
@@ -0,0 +1,587 @@
+/* dgesvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgesvx_(char *fact, char *trans, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
+ integer *ipiv, char *equed, doublereal *r__, doublereal *c__,
+ doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
+ rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *
+ iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal amax;
+ char norm[1];
+ extern logical lsame_(char *, char *);
+ doublereal rcmin, rcmax, anorm;
+ logical equil;
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlaqge_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, char *), dgecon_(char *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *);
+ doublereal colcnd;
+ logical nofact;
+ extern /* Subroutine */ int dgeequ_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *), dgerfs_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *),
+ dgetrf_(integer *, integer *, doublereal *, integer *, integer *,
+ integer *), dlacpy_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *), xerbla_(char *,
+ integer *);
+ doublereal bignum;
+ extern doublereal dlantr_(char *, char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *);
+ integer infequ;
+ logical colequ;
+ extern /* Subroutine */ int dgetrs_(char *, integer *, integer *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *);
+ doublereal rowcnd;
+ logical notran;
+ doublereal smlnum;
+ logical rowequ;
+ doublereal rpvgrw;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGESVX uses the LU factorization to compute the solution to a real */
+/* system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */
+/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */
+/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */
+/* or diag(C)*B (if TRANS = 'T' or 'C'). */
+
+/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the */
+/* matrix A (after equilibration if FACT = 'E') as */
+/* A = P * L * U, */
+/* where P is a permutation matrix, L is a unit lower triangular */
+/* matrix, and U is upper triangular. */
+
+/* 3. If some U(i,i)=0, so that U is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */
+/* that it solves the original system before equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF and IPIV contain the factored form of A. */
+/* If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by R and C. */
+/* A, AF, and IPIV are not modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is */
+/* not 'N', then A must have been equilibrated by the scaling */
+/* factors in R and/or C. A is not modified if FACT = 'F' or */
+/* 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
+
+/* On exit, if EQUED .ne. 'N', A is scaled as follows: */
+/* EQUED = 'R': A := diag(R) * A */
+/* EQUED = 'C': A := A * diag(C) */
+/* EQUED = 'B': A := diag(R) * A * diag(C). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the factors L and U from the factorization */
+/* A = P*L*U as computed by DGETRF. If EQUED .ne. 'N', then */
+/* AF is the factored form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the equilibrated matrix A (see the description of A for */
+/* the form of the equilibrated matrix). */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* as computed by DGETRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the equilibrated matrix A. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* R (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+
+/* C (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */
+/* diag(R)*B; */
+/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */
+/* overwritten by diag(C)*B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X */
+/* to the original system of equations. Note that A and B are */
+/* modified on exit if EQUED .ne. 'N', and the solution to the */
+/* equilibrated system is inv(diag(C))*X if TRANS = 'N' and */
+/* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' */
+/* and EQUED = 'R' or 'B'. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A after equilibration (if done). If RCOND is less than the */
+/* machine precision (in particular, if RCOND = 0), the matrix */
+/* is singular to working precision. This condition is */
+/* indicated by a return code of INFO > 0. */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (4*N) */
+/* On exit, WORK(1) contains the reciprocal pivot growth */
+/* factor norm(A)/norm(U). The "max absolute element" norm is */
+/* used. If WORK(1) is much less than 1, then the stability */
+/* of the LU factorization of the (equilibrated) matrix A */
+/* could be poor. This also means that the solution X, condition */
+/* estimator RCOND, and forward error bound FERR could be */
+/* unreliable. If factorization fails with 0<INFO<=N, then */
+/* WORK(1) contains the reciprocal pivot growth factor for the */
+/* leading INFO columns of A. */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: U(i,i) is exactly zero. The factorization has */
+/* been completed, but the factor U is exactly */
+/* singular, so the solution and error bounds */
+/* could not be computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ notran = lsame_(trans, "N");
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rowequ = FALSE_;
+ colequ = FALSE_;
+ } else {
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ }
+
+/* Test the input parameters. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (lsame_(fact, "F") && ! (rowequ || colequ
+ || lsame_(equed, "N"))) {
+ *info = -10;
+ } else {
+ if (rowequ) {
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = r__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = r__[j];
+ rcmax = max(d__1,d__2);
+/* L10: */
+ }
+ if (rcmin <= 0.) {
+ *info = -11;
+ } else if (*n > 0) {
+ rowcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ } else {
+ rowcnd = 1.;
+ }
+ }
+ if (colequ && *info == 0) {
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = c__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = c__[j];
+ rcmax = max(d__1,d__2);
+/* L20: */
+ }
+ if (rcmin <= 0.) {
+ *info = -12;
+ } else if (*n > 0) {
+ colcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ } else {
+ colcnd = 1.;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -14;
+ } else if (*ldx < max(1,*n)) {
+ *info = -16;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGESVX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ dgeequ_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &colcnd, &
+ amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ dlaqge_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &
+ colcnd, &amax, equed);
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+ }
+
+/* Scale the right hand side. */
+
+ if (notran) {
+ if (rowequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = r__[i__] * b[i__ + j * b_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else if (colequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = c__[i__] * b[i__ + j * b_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of A. */
+
+ dlacpy_("Full", n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ dgetrf_(n, n, &af[af_offset], ldaf, &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ rpvgrw = dlantr_("M", "U", "N", info, info, &af[af_offset], ldaf,
+ &work[1]);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = dlange_("M", n, info, &a[a_offset], lda, &work[1]) / rpvgrw;
+ }
+ work[1] = rpvgrw;
+ *rcond = 0.;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A and the */
+/* reciprocal pivot growth factor RPVGRW. */
+
+ if (notran) {
+ *(unsigned char *)norm = '1';
+ } else {
+ *(unsigned char *)norm = 'I';
+ }
+ anorm = dlange_(norm, n, n, &a[a_offset], lda, &work[1]);
+ rpvgrw = dlantr_("M", "U", "N", n, n, &af[af_offset], ldaf, &work[1]);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = dlange_("M", n, n, &a[a_offset], lda, &work[1]) /
+ rpvgrw;
+ }
+
+/* Compute the reciprocal of the condition number of A. */
+
+ dgecon_(norm, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &iwork[1],
+ info);
+
+/* Compute the solution matrix X. */
+
+ dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ dgetrs_(trans, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ dgerfs_(trans, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1],
+ &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[
+ 1], &iwork[1], info);
+
+/* Transform the solution matrix X to a solution of the original */
+/* system. */
+
+ if (notran) {
+ if (colequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__ + j * x_dim1] = c__[i__] * x[i__ + j * x_dim1];
+/* L70: */
+ }
+/* L80: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= colcnd;
+/* L90: */
+ }
+ }
+ } else if (rowequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__ + j * x_dim1] = r__[i__] * x[i__ + j * x_dim1];
+/* L100: */
+ }
+/* L110: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= rowcnd;
+/* L120: */
+ }
+ }
+
+ work[1] = rpvgrw;
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < dlamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+ return 0;
+
+/* End of DGESVX */
+
+} /* dgesvx_ */
diff --git a/SRC/dgesvxx.c b/SRC/dgesvxx.c
new file mode 100644
index 0000000..4f2600c
--- /dev/null
+++ b/SRC/dgesvxx.c
@@ -0,0 +1,713 @@
+/* dgesvxx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgesvxx_(char *fact, char *trans, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
+ integer *ipiv, char *equed, doublereal *r__, doublereal *c__,
+ doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
+ rcond, doublereal *rpvgrw, doublereal *berr, integer *n_err_bnds__,
+ doublereal *err_bnds_norm__, doublereal *err_bnds_comp__, integer *
+ nparams, doublereal *params, doublereal *work, integer *iwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ extern doublereal dla_rpvgrw__(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *);
+ doublereal amax;
+ extern logical lsame_(char *, char *);
+ doublereal rcmin, rcmax;
+ logical equil;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlaqge_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, char *);
+ doublereal colcnd;
+ logical nofact;
+ extern /* Subroutine */ int dgetrf_(integer *, integer *, doublereal *,
+ integer *, integer *, integer *), dlacpy_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *);
+ doublereal bignum;
+ integer infequ;
+ logical colequ;
+ extern /* Subroutine */ int dgetrs_(char *, integer *, integer *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *);
+ doublereal rowcnd;
+ logical notran;
+ doublereal smlnum;
+ logical rowequ;
+ extern /* Subroutine */ int dlascl2_(integer *, integer *, doublereal *,
+ doublereal *, integer *), dgeequb_(integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *), dgerfsx_(char *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGESVXX uses the LU factorization to compute the solution to a */
+/* double precision system of linear equations A * X = B, where A is an */
+/* N-by-N matrix and X and B are N-by-NRHS matrices. */
+
+/* If requested, both normwise and maximum componentwise error bounds */
+/* are returned. DGESVXX will return a solution with a tiny */
+/* guaranteed error (O(eps) where eps is the working machine */
+/* precision) unless the matrix is very ill-conditioned, in which */
+/* case a warning is returned. Relevant condition numbers also are */
+/* calculated and returned. */
+
+/* DGESVXX accepts user-provided factorizations and equilibration */
+/* factors; see the definitions of the FACT and EQUED options. */
+/* Solving with refinement and using a factorization from a previous */
+/* DGESVXX call will also produce a solution with either O(eps) */
+/* errors or warnings, but we cannot make that claim for general */
+/* user-provided factorizations and equilibration factors if they */
+/* differ from what DGESVXX would itself produce. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate */
+/* the system: */
+
+/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */
+/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */
+/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */
+
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */
+/* or diag(C)*B (if TRANS = 'T' or 'C'). */
+
+/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */
+/* the matrix A (after equilibration if FACT = 'E') as */
+
+/* A = P * L * U, */
+
+/* where P is a permutation matrix, L is a unit lower triangular */
+/* matrix, and U is upper triangular. */
+
+/* 3. If some U(i,i)=0, so that U is exactly singular, then the */
+/* routine returns with INFO = i. Otherwise, the factored form of A */
+/* is used to estimate the condition number of the matrix A (see */
+/* argument RCOND). If the reciprocal of the condition number is less */
+/* than machine precision, the routine still goes on to solve for X */
+/* and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */
+/* the routine will use iterative refinement to try to get a small */
+/* error and error bounds. Refinement calculates the residual to at */
+/* least twice the working precision. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */
+/* that it solves the original system before equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF and IPIV contain the factored form of A. */
+/* If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by R and C. */
+/* A, AF, and IPIV are not modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is */
+/* not 'N', then A must have been equilibrated by the scaling */
+/* factors in R and/or C. A is not modified if FACT = 'F' or */
+/* 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
+
+/* On exit, if EQUED .ne. 'N', A is scaled as follows: */
+/* EQUED = 'R': A := diag(R) * A */
+/* EQUED = 'C': A := A * diag(C) */
+/* EQUED = 'B': A := diag(R) * A * diag(C). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the factors L and U from the factorization */
+/* A = P*L*U as computed by DGETRF. If EQUED .ne. 'N', then */
+/* AF is the factored form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the equilibrated matrix A (see the description of A for */
+/* the form of the equilibrated matrix). */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* as computed by DGETRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the equilibrated matrix A. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* R (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+/* If R is output, each element of R is a power of the radix. */
+/* If R is input, each element of R should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* C (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+/* If C is output, each element of C is a power of the radix. */
+/* If C is input, each element of C should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */
+/* diag(R)*B; */
+/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */
+/* overwritten by diag(C)*B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* If INFO = 0, the N-by-NRHS solution matrix X to the original */
+/* system of equations. Note that A and B are modified on exit */
+/* if EQUED .ne. 'N', and the solution to the equilibrated system is */
+/* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or */
+/* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* RPVGRW (output) DOUBLE PRECISION */
+/* Reciprocal pivot growth. On exit, this contains the reciprocal */
+/* pivot growth factor norm(A)/norm(U). The "max absolute element" */
+/* norm is used. If this is much less than 1, then the stability of */
+/* the LU factorization of the (equilibrated) matrix A could be poor. */
+/* This also means that the solution X, estimated condition numbers, */
+/* and error bounds could be unreliable. If factorization fails with */
+/* 0<INFO<=N, then this contains the reciprocal pivot growth factor */
+/* for the leading INFO columns of A. In DGESVX, this quantity is */
+/* returned in WORK(1). */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0D+0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the extra-precise refinement algorithm. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ notran = lsame_(trans, "N");
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rowequ = FALSE_;
+ colequ = FALSE_;
+ } else {
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+
+/* Default is failure. If an input parameter is wrong or */
+/* factorization fails, make everything look horrible. Only the */
+/* pivot growth is set here, the rest is initialized in DGERFSX. */
+
+ *rpvgrw = 0.;
+
+/* Test the input parameters. PARAMS is not tested until DGERFSX. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (lsame_(fact, "F") && ! (rowequ || colequ
+ || lsame_(equed, "N"))) {
+ *info = -10;
+ } else {
+ if (rowequ) {
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = r__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = r__[j];
+ rcmax = max(d__1,d__2);
+/* L10: */
+ }
+ if (rcmin <= 0.) {
+ *info = -11;
+ } else if (*n > 0) {
+ rowcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ } else {
+ rowcnd = 1.;
+ }
+ }
+ if (colequ && *info == 0) {
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = c__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = c__[j];
+ rcmax = max(d__1,d__2);
+/* L20: */
+ }
+ if (rcmin <= 0.) {
+ *info = -12;
+ } else if (*n > 0) {
+ colcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ } else {
+ colcnd = 1.;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -14;
+ } else if (*ldx < max(1,*n)) {
+ *info = -16;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGESVXX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ dgeequb_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &colcnd,
+ &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ dlaqge_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &
+ colcnd, &amax, equed);
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+
+/* If the scaling factors are not applied, set them to 1.0. */
+
+ if (! rowequ) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ r__[j] = 1.;
+ }
+ }
+ if (! colequ) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 1.;
+ }
+ }
+ }
+
+/* Scale the right-hand side. */
+
+ if (notran) {
+ if (rowequ) {
+ dlascl2_(n, nrhs, &r__[1], &b[b_offset], ldb);
+ }
+ } else {
+ if (colequ) {
+ dlascl2_(n, nrhs, &c__[1], &b[b_offset], ldb);
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of A. */
+
+ dlacpy_("Full", n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ dgetrf_(n, n, &af[af_offset], ldaf, &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Pivot in column INFO is exactly 0 */
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ *rpvgrw = dla_rpvgrw__(n, info, &a[a_offset], lda, &af[af_offset],
+ ldaf);
+ return 0;
+ }
+ }
+
+/* Compute the reciprocal pivot growth factor RPVGRW. */
+
+ *rpvgrw = dla_rpvgrw__(n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+
+/* Compute the solution matrix X. */
+
+ dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ dgetrs_(trans, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ dgerfsx_(trans, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &
+ ipiv[1], &r__[1], &c__[1], &b[b_offset], ldb, &x[x_offset], ldx,
+ rcond, &berr[1], n_err_bnds__, &err_bnds_norm__[
+ err_bnds_norm_offset], &err_bnds_comp__[err_bnds_comp_offset],
+ nparams, ¶ms[1], &work[1], &iwork[1], info);
+
+/* Scale solutions. */
+
+ if (colequ && notran) {
+ dlascl2_(n, nrhs, &c__[1], &x[x_offset], ldx);
+ } else if (rowequ && ! notran) {
+ dlascl2_(n, nrhs, &r__[1], &x[x_offset], ldx);
+ }
+
+ return 0;
+
+/* End of DGESVXX */
+} /* dgesvxx_ */
diff --git a/SRC/dgetc2.c b/SRC/dgetc2.c
new file mode 100644
index 0000000..4c6e8c5
--- /dev/null
+++ b/SRC/dgetc2.c
@@ -0,0 +1,199 @@
+/* dgetc2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b10 = -1.;
+
+/* Subroutine */ int dgetc2_(integer *n, doublereal *a, integer *lda, integer
+ *ipiv, integer *jpiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, j, ip, jp;
+ doublereal eps;
+ integer ipv, jpv;
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal smin, xmax;
+ extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ doublereal bignum, smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGETC2 computes an LU factorization with complete pivoting of the */
+/* n-by-n matrix A. The factorization has the form A = P * L * U * Q, */
+/* where P and Q are permutation matrices, L is lower triangular with */
+/* unit diagonal elements and U is upper triangular. */
+
+/* This is the Level 2 BLAS algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
+/* On entry, the n-by-n matrix A to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U*Q; the unit diagonal elements of L are not stored. */
+/* If U(k, k) appears to be less than SMIN, U(k, k) is given the */
+/* value of SMIN, i.e., giving a nonsingular perturbed system. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension(N). */
+/* The pivot indices; for 1 <= i <= N, row i of the */
+/* matrix has been interchanged with row IPIV(i). */
+
+/* JPIV (output) INTEGER array, dimension(N). */
+/* The pivot indices; for 1 <= j <= N, column j of the */
+/* matrix has been interchanged with column JPIV(j). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* > 0: if INFO = k, U(k, k) is likely to produce owerflow if */
+/* we try to solve for x in Ax = b. So U is perturbed to */
+/* avoid the overflow. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Set constants to control overflow */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --jpiv;
+
+ /* Function Body */
+ *info = 0;
+ eps = dlamch_("P");
+ smlnum = dlamch_("S") / eps;
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Factorize A using complete pivoting. */
+/* Set pivots less than SMIN to SMIN. */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Find max element in matrix A */
+
+ xmax = 0.;
+ i__2 = *n;
+ for (ip = i__; ip <= i__2; ++ip) {
+ i__3 = *n;
+ for (jp = i__; jp <= i__3; ++jp) {
+ if ((d__1 = a[ip + jp * a_dim1], abs(d__1)) >= xmax) {
+ xmax = (d__1 = a[ip + jp * a_dim1], abs(d__1));
+ ipv = ip;
+ jpv = jp;
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+ if (i__ == 1) {
+/* Computing MAX */
+ d__1 = eps * xmax;
+ smin = max(d__1,smlnum);
+ }
+
+/* Swap rows */
+
+ if (ipv != i__) {
+ dswap_(n, &a[ipv + a_dim1], lda, &a[i__ + a_dim1], lda);
+ }
+ ipiv[i__] = ipv;
+
+/* Swap columns */
+
+ if (jpv != i__) {
+ dswap_(n, &a[jpv * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
+ c__1);
+ }
+ jpiv[i__] = jpv;
+
+/* Check for singularity */
+
+ if ((d__1 = a[i__ + i__ * a_dim1], abs(d__1)) < smin) {
+ *info = i__;
+ a[i__ + i__ * a_dim1] = smin;
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ a[j + i__ * a_dim1] /= a[i__ + i__ * a_dim1];
+/* L30: */
+ }
+ i__2 = *n - i__;
+ i__3 = *n - i__;
+ dger_(&i__2, &i__3, &c_b10, &a[i__ + 1 + i__ * a_dim1], &c__1, &a[i__
+ + (i__ + 1) * a_dim1], lda, &a[i__ + 1 + (i__ + 1) * a_dim1],
+ lda);
+/* L40: */
+ }
+
+ if ((d__1 = a[*n + *n * a_dim1], abs(d__1)) < smin) {
+ *info = *n;
+ a[*n + *n * a_dim1] = smin;
+ }
+
+ return 0;
+
+/* End of DGETC2 */
+
+} /* dgetc2_ */
diff --git a/SRC/dgetf2.c b/SRC/dgetf2.c
new file mode 100644
index 0000000..be6639a
--- /dev/null
+++ b/SRC/dgetf2.c
@@ -0,0 +1,193 @@
+/* dgetf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b8 = -1.;
+
+/* Subroutine */ int dgetf2_(integer *m, integer *n, doublereal *a, integer *
+ lda, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, j, jp;
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dscal_(integer *, doublereal *, doublereal *, integer
+ *);
+ doublereal sfmin;
+ extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGETF2 computes an LU factorization of a general m-by-n matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* The factorization has the form */
+/* A = P * L * U */
+/* where P is a permutation matrix, L is lower triangular with unit */
+/* diagonal elements (lower trapezoidal if m > n), and U is upper */
+/* triangular (upper trapezoidal if m < n). */
+
+/* This is the right-looking Level 2 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the m by n matrix to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, U(k,k) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGETF2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Compute machine safe minimum */
+
+ sfmin = dlamch_("S");
+
+ i__1 = min(*m,*n);
+ for (j = 1; j <= i__1; ++j) {
+
+/* Find pivot and test for singularity. */
+
+ i__2 = *m - j + 1;
+ jp = j - 1 + idamax_(&i__2, &a[j + j * a_dim1], &c__1);
+ ipiv[j] = jp;
+ if (a[jp + j * a_dim1] != 0.) {
+
+/* Apply the interchange to columns 1:N. */
+
+ if (jp != j) {
+ dswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda);
+ }
+
+/* Compute elements J+1:M of J-th column. */
+
+ if (j < *m) {
+ if ((d__1 = a[j + j * a_dim1], abs(d__1)) >= sfmin) {
+ i__2 = *m - j;
+ d__1 = 1. / a[j + j * a_dim1];
+ dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1);
+ } else {
+ i__2 = *m - j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[j + i__ + j * a_dim1] /= a[j + j * a_dim1];
+/* L20: */
+ }
+ }
+ }
+
+ } else if (*info == 0) {
+
+ *info = j;
+ }
+
+ if (j < min(*m,*n)) {
+
+/* Update trailing submatrix. */
+
+ i__2 = *m - j;
+ i__3 = *n - j;
+ dger_(&i__2, &i__3, &c_b8, &a[j + 1 + j * a_dim1], &c__1, &a[j + (
+ j + 1) * a_dim1], lda, &a[j + 1 + (j + 1) * a_dim1], lda);
+ }
+/* L10: */
+ }
+ return 0;
+
+/* End of DGETF2 */
+
+} /* dgetf2_ */
diff --git a/SRC/dgetrf.c b/SRC/dgetrf.c
new file mode 100644
index 0000000..8a945af
--- /dev/null
+++ b/SRC/dgetrf.c
@@ -0,0 +1,219 @@
+/* dgetrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b16 = 1.;
+static doublereal c_b19 = -1.;
+
+/* Subroutine */ int dgetrf_(integer *m, integer *n, doublereal *a, integer *
+ lda, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+
+ /* Local variables */
+ integer i__, j, jb, nb;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ integer iinfo;
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), dgetf2_(
+ integer *, integer *, doublereal *, integer *, integer *, integer
+ *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dlaswp_(integer *, doublereal *, integer *,
+ integer *, integer *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGETRF computes an LU factorization of a general M-by-N matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* The factorization has the form */
+/* A = P * L * U */
+/* where P is a permutation matrix, L is lower triangular with unit */
+/* diagonal elements (lower trapezoidal if m > n), and U is upper */
+/* triangular (upper trapezoidal if m < n). */
+
+/* This is the right-looking Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGETRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "DGETRF", " ", m, n, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= min(*m,*n)) {
+
+/* Use unblocked code. */
+
+ dgetf2_(m, n, &a[a_offset], lda, &ipiv[1], info);
+ } else {
+
+/* Use blocked code. */
+
+ i__1 = min(*m,*n);
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = min(*m,*n) - j + 1;
+ jb = min(i__3,nb);
+
+/* Factor diagonal and subdiagonal blocks and test for exact */
+/* singularity. */
+
+ i__3 = *m - j + 1;
+ dgetf2_(&i__3, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo);
+
+/* Adjust INFO and the pivot indices. */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo + j - 1;
+ }
+/* Computing MIN */
+ i__4 = *m, i__5 = j + jb - 1;
+ i__3 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__3; ++i__) {
+ ipiv[i__] = j - 1 + ipiv[i__];
+/* L10: */
+ }
+
+/* Apply interchanges to columns 1:J-1. */
+
+ i__3 = j - 1;
+ i__4 = j + jb - 1;
+ dlaswp_(&i__3, &a[a_offset], lda, &j, &i__4, &ipiv[1], &c__1);
+
+ if (j + jb <= *n) {
+
+/* Apply interchanges to columns J+JB:N. */
+
+ i__3 = *n - j - jb + 1;
+ i__4 = j + jb - 1;
+ dlaswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, &
+ ipiv[1], &c__1);
+
+/* Compute block row of U. */
+
+ i__3 = *n - j - jb + 1;
+ dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &i__3, &
+ c_b16, &a[j + j * a_dim1], lda, &a[j + (j + jb) *
+ a_dim1], lda);
+ if (j + jb <= *m) {
+
+/* Update trailing submatrix. */
+
+ i__3 = *m - j - jb + 1;
+ i__4 = *n - j - jb + 1;
+ dgemm_("No transpose", "No transpose", &i__3, &i__4, &jb,
+ &c_b19, &a[j + jb + j * a_dim1], lda, &a[j + (j +
+ jb) * a_dim1], lda, &c_b16, &a[j + jb + (j + jb) *
+ a_dim1], lda);
+ }
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+/* End of DGETRF */
+
+} /* dgetrf_ */
diff --git a/SRC/dgetri.c b/SRC/dgetri.c
new file mode 100644
index 0000000..d075f0c
--- /dev/null
+++ b/SRC/dgetri.c
@@ -0,0 +1,264 @@
+/* dgetri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static doublereal c_b20 = -1.;
+static doublereal c_b22 = 1.;
+
+/* Subroutine */ int dgetri_(integer *n, doublereal *a, integer *lda, integer
+ *ipiv, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, jb, nb, jj, jp, nn, iws;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *),
+ dgemv_(char *, integer *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ integer nbmin;
+ extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), xerbla_(
+ char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork;
+ extern /* Subroutine */ int dtrtri_(char *, char *, integer *, doublereal
+ *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGETRI computes the inverse of a matrix using the LU factorization */
+/* computed by DGETRF. */
+
+/* This method inverts U and then computes inv(A) by solving the system */
+/* inv(A)*L = inv(U) for inv(A). */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the factors L and U from the factorization */
+/* A = P*L*U as computed by DGETRF. */
+/* On exit, if INFO = 0, the inverse of the original matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from DGETRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO=0, then WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* For optimal performance LWORK >= N*NB, where NB is */
+/* the optimal blocksize 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is */
+/* singular and its inverse could not be computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb = ilaenv_(&c__1, "DGETRI", " ", n, &c_n1, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ work[1] = (doublereal) lwkopt;
+ lquery = *lwork == -1;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*lda < max(1,*n)) {
+ *info = -3;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGETRI", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form inv(U). If INFO > 0 from DTRTRI, then U is singular, */
+/* and the inverse is not computed. */
+
+ dtrtri_("Upper", "Non-unit", n, &a[a_offset], lda, info);
+ if (*info > 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = *n;
+ if (nb > 1 && nb < *n) {
+/* Computing MAX */
+ i__1 = ldwork * nb;
+ iws = max(i__1,1);
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "DGETRI", " ", n, &c_n1, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = *n;
+ }
+
+/* Solve the equation inv(A)*L = inv(U) for inv(A). */
+
+ if (nb < nbmin || nb >= *n) {
+
+/* Use unblocked code. */
+
+ for (j = *n; j >= 1; --j) {
+
+/* Copy current column of L to WORK and replace with zeros. */
+
+ i__1 = *n;
+ for (i__ = j + 1; i__ <= i__1; ++i__) {
+ work[i__] = a[i__ + j * a_dim1];
+ a[i__ + j * a_dim1] = 0.;
+/* L10: */
+ }
+
+/* Compute current column of inv(A). */
+
+ if (j < *n) {
+ i__1 = *n - j;
+ dgemv_("No transpose", n, &i__1, &c_b20, &a[(j + 1) * a_dim1
+ + 1], lda, &work[j + 1], &c__1, &c_b22, &a[j * a_dim1
+ + 1], &c__1);
+ }
+/* L20: */
+ }
+ } else {
+
+/* Use blocked code. */
+
+ nn = (*n - 1) / nb * nb + 1;
+ i__1 = -nb;
+ for (j = nn; i__1 < 0 ? j >= 1 : j <= 1; j += i__1) {
+/* Computing MIN */
+ i__2 = nb, i__3 = *n - j + 1;
+ jb = min(i__2,i__3);
+
+/* Copy current block column of L to WORK and replace with */
+/* zeros. */
+
+ i__2 = j + jb - 1;
+ for (jj = j; jj <= i__2; ++jj) {
+ i__3 = *n;
+ for (i__ = jj + 1; i__ <= i__3; ++i__) {
+ work[i__ + (jj - j) * ldwork] = a[i__ + jj * a_dim1];
+ a[i__ + jj * a_dim1] = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Compute current block column of inv(A). */
+
+ if (j + jb <= *n) {
+ i__2 = *n - j - jb + 1;
+ dgemm_("No transpose", "No transpose", n, &jb, &i__2, &c_b20,
+ &a[(j + jb) * a_dim1 + 1], lda, &work[j + jb], &
+ ldwork, &c_b22, &a[j * a_dim1 + 1], lda);
+ }
+ dtrsm_("Right", "Lower", "No transpose", "Unit", n, &jb, &c_b22, &
+ work[j], &ldwork, &a[j * a_dim1 + 1], lda);
+/* L50: */
+ }
+ }
+
+/* Apply column interchanges. */
+
+ for (j = *n - 1; j >= 1; --j) {
+ jp = ipiv[j];
+ if (jp != j) {
+ dswap_(n, &a[j * a_dim1 + 1], &c__1, &a[jp * a_dim1 + 1], &c__1);
+ }
+/* L60: */
+ }
+
+ work[1] = (doublereal) iws;
+ return 0;
+
+/* End of DGETRI */
+
+} /* dgetri_ */
diff --git a/SRC/dgetrs.c b/SRC/dgetrs.c
new file mode 100644
index 0000000..943e22f
--- /dev/null
+++ b/SRC/dgetrs.c
@@ -0,0 +1,186 @@
+/* dgetrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b12 = 1.;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dgetrs_(char *trans, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer *
+ ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), xerbla_(
+ char *, integer *), dlaswp_(integer *, doublereal *,
+ integer *, integer *, integer *, integer *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGETRS solves a system of linear equations */
+/* A * X = B or A' * X = B */
+/* with a general N-by-N matrix A using the LU factorization computed */
+/* by DGETRF. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A'* X = B (Transpose) */
+/* = 'C': A'* X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The factors L and U from the factorization A = P*L*U */
+/* as computed by DGETRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from DGETRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGETRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (notran) {
+
+/* Solve A * X = B. */
+
+/* Apply row interchanges to the right hand sides. */
+
+ dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c__1);
+
+/* Solve L*X = B, overwriting B with X. */
+
+ dtrsm_("Left", "Lower", "No transpose", "Unit", n, nrhs, &c_b12, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+/* Solve U*X = B, overwriting B with X. */
+
+ dtrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b12, &
+ a[a_offset], lda, &b[b_offset], ldb);
+ } else {
+
+/* Solve A' * X = B. */
+
+/* Solve U'*X = B, overwriting B with X. */
+
+ dtrsm_("Left", "Upper", "Transpose", "Non-unit", n, nrhs, &c_b12, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+/* Solve L'*X = B, overwriting B with X. */
+
+ dtrsm_("Left", "Lower", "Transpose", "Unit", n, nrhs, &c_b12, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+/* Apply row interchanges to the solution vectors. */
+
+ dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c_n1);
+ }
+
+ return 0;
+
+/* End of DGETRS */
+
+} /* dgetrs_ */
diff --git a/SRC/dggbak.c b/SRC/dggbak.c
new file mode 100644
index 0000000..a581392
--- /dev/null
+++ b/SRC/dggbak.c
@@ -0,0 +1,276 @@
+/* dggbak.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dggbak_(char *job, char *side, integer *n, integer *ilo,
+ integer *ihi, doublereal *lscale, doublereal *rscale, integer *m,
+ doublereal *v, integer *ldv, integer *info)
+{
+ /* System generated locals */
+ integer v_dim1, v_offset, i__1;
+
+ /* Local variables */
+ integer i__, k;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical leftv;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical rightv;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGGBAK forms the right or left eigenvectors of a real generalized */
+/* eigenvalue problem A*x = lambda*B*x, by backward transformation on */
+/* the computed eigenvectors of the balanced pair of matrices output by */
+/* DGGBAL. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies the type of backward transformation required: */
+/* = 'N': do nothing, return immediately; */
+/* = 'P': do backward transformation for permutation only; */
+/* = 'S': do backward transformation for scaling only; */
+/* = 'B': do backward transformations for both permutation and */
+/* scaling. */
+/* JOB must be the same as the argument JOB supplied to DGGBAL. */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'R': V contains right eigenvectors; */
+/* = 'L': V contains left eigenvectors. */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrix V. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* The integers ILO and IHI determined by DGGBAL. */
+/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
+
+/* LSCALE (input) DOUBLE PRECISION array, dimension (N) */
+/* Details of the permutations and/or scaling factors applied */
+/* to the left side of A and B, as returned by DGGBAL. */
+
+/* RSCALE (input) DOUBLE PRECISION array, dimension (N) */
+/* Details of the permutations and/or scaling factors applied */
+/* to the right side of A and B, as returned by DGGBAL. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix V. M >= 0. */
+
+/* V (input/output) DOUBLE PRECISION array, dimension (LDV,M) */
+/* On entry, the matrix of right or left eigenvectors to be */
+/* transformed, as returned by DTGEVC. */
+/* On exit, V is overwritten by the transformed eigenvectors. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the matrix V. LDV >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* See R.C. Ward, Balancing the generalized eigenvalue problem, */
+/* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ --lscale;
+ --rscale;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+
+ /* Function Body */
+ rightv = lsame_(side, "R");
+ leftv = lsame_(side, "L");
+
+ *info = 0;
+ if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
+ && ! lsame_(job, "B")) {
+ *info = -1;
+ } else if (! rightv && ! leftv) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ilo < 1) {
+ *info = -4;
+ } else if (*n == 0 && *ihi == 0 && *ilo != 1) {
+ *info = -4;
+ } else if (*n > 0 && (*ihi < *ilo || *ihi > max(1,*n))) {
+ *info = -5;
+ } else if (*n == 0 && *ilo == 1 && *ihi != 0) {
+ *info = -5;
+ } else if (*m < 0) {
+ *info = -8;
+ } else if (*ldv < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGGBAK", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+ if (*m == 0) {
+ return 0;
+ }
+ if (lsame_(job, "N")) {
+ return 0;
+ }
+
+ if (*ilo == *ihi) {
+ goto L30;
+ }
+
+/* Backward balance */
+
+ if (lsame_(job, "S") || lsame_(job, "B")) {
+
+/* Backward transformation on right eigenvectors */
+
+ if (rightv) {
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ dscal_(m, &rscale[i__], &v[i__ + v_dim1], ldv);
+/* L10: */
+ }
+ }
+
+/* Backward transformation on left eigenvectors */
+
+ if (leftv) {
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ dscal_(m, &lscale[i__], &v[i__ + v_dim1], ldv);
+/* L20: */
+ }
+ }
+ }
+
+/* Backward permutation */
+
+L30:
+ if (lsame_(job, "P") || lsame_(job, "B")) {
+
+/* Backward permutation on right eigenvectors */
+
+ if (rightv) {
+ if (*ilo == 1) {
+ goto L50;
+ }
+
+ for (i__ = *ilo - 1; i__ >= 1; --i__) {
+ k = (integer) rscale[i__];
+ if (k == i__) {
+ goto L40;
+ }
+ dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L40:
+ ;
+ }
+
+L50:
+ if (*ihi == *n) {
+ goto L70;
+ }
+ i__1 = *n;
+ for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
+ k = (integer) rscale[i__];
+ if (k == i__) {
+ goto L60;
+ }
+ dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L60:
+ ;
+ }
+ }
+
+/* Backward permutation on left eigenvectors */
+
+L70:
+ if (leftv) {
+ if (*ilo == 1) {
+ goto L90;
+ }
+ for (i__ = *ilo - 1; i__ >= 1; --i__) {
+ k = (integer) lscale[i__];
+ if (k == i__) {
+ goto L80;
+ }
+ dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L80:
+ ;
+ }
+
+L90:
+ if (*ihi == *n) {
+ goto L110;
+ }
+ i__1 = *n;
+ for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
+ k = (integer) lscale[i__];
+ if (k == i__) {
+ goto L100;
+ }
+ dswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L100:
+ ;
+ }
+ }
+ }
+
+L110:
+
+ return 0;
+
+/* End of DGGBAK */
+
+} /* dggbak_ */
diff --git a/SRC/dggbal.c b/SRC/dggbal.c
new file mode 100644
index 0000000..27a4b34
--- /dev/null
+++ b/SRC/dggbal.c
@@ -0,0 +1,627 @@
+/* dggbal.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b35 = 10.;
+static doublereal c_b71 = .5;
+
+/* Subroutine */ int dggbal_(char *job, integer *n, doublereal *a, integer *
+ lda, doublereal *b, integer *ldb, integer *ilo, integer *ihi,
+ doublereal *lscale, doublereal *rscale, doublereal *work, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double d_lg10(doublereal *), d_sign(doublereal *, doublereal *), pow_di(
+ doublereal *, integer *);
+
+ /* Local variables */
+ integer i__, j, k, l, m;
+ doublereal t;
+ integer jc;
+ doublereal ta, tb, tc;
+ integer ir;
+ doublereal ew;
+ integer it, nr, ip1, jp1, lm1;
+ doublereal cab, rab, ewc, cor, sum;
+ integer nrp2, icab, lcab;
+ doublereal beta, coef;
+ integer irab, lrab;
+ doublereal basl, cmax;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal coef2, coef5, gamma, alpha;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ doublereal sfmin, sfmax;
+ extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer iflow;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *);
+ integer kount;
+ extern doublereal dlamch_(char *);
+ doublereal pgamma;
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer lsfmin, lsfmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGGBAL balances a pair of general real matrices (A,B). This */
+/* involves, first, permuting A and B by similarity transformations to */
+/* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N */
+/* elements on the diagonal; and second, applying a diagonal similarity */
+/* transformation to rows and columns ILO to IHI to make the rows */
+/* and columns as close in norm as possible. Both steps are optional. */
+
+/* Balancing may reduce the 1-norm of the matrices, and improve the */
+/* accuracy of the computed eigenvalues and/or eigenvectors in the */
+/* generalized eigenvalue problem A*x = lambda*B*x. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies the operations to be performed on A and B: */
+/* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0 */
+/* and RSCALE(I) = 1.0 for i = 1,...,N. */
+/* = 'P': permute only; */
+/* = 'S': scale only; */
+/* = 'B': both permute and scale. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the input matrix A. */
+/* On exit, A is overwritten by the balanced matrix. */
+/* If JOB = 'N', A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */
+/* On entry, the input matrix B. */
+/* On exit, B is overwritten by the balanced matrix. */
+/* If JOB = 'N', B is not referenced. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* ILO (output) INTEGER */
+/* IHI (output) INTEGER */
+/* ILO and IHI are set to integers such that on exit */
+/* A(i,j) = 0 and B(i,j) = 0 if i > j and */
+/* j = 1,...,ILO-1 or i = IHI+1,...,N. */
+/* If JOB = 'N' or 'S', ILO = 1 and IHI = N. */
+
+/* LSCALE (output) DOUBLE PRECISION array, dimension (N) */
+/* Details of the permutations and scaling factors applied */
+/* to the left side of A and B. If P(j) is the index of the */
+/* row interchanged with row j, and D(j) */
+/* is the scaling factor applied to row j, then */
+/* LSCALE(j) = P(j) for J = 1,...,ILO-1 */
+/* = D(j) for J = ILO,...,IHI */
+/* = P(j) for J = IHI+1,...,N. */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* RSCALE (output) DOUBLE PRECISION array, dimension (N) */
+/* Details of the permutations and scaling factors applied */
+/* to the right side of A and B. If P(j) is the index of the */
+/* column interchanged with column j, and D(j) */
+/* is the scaling factor applied to column j, then */
+/* LSCALE(j) = P(j) for J = 1,...,ILO-1 */
+/* = D(j) for J = ILO,...,IHI */
+/* = P(j) for J = IHI+1,...,N. */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* WORK (workspace) REAL array, dimension (lwork) */
+/* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and */
+/* at least 1 when JOB = 'N' or 'P'. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* See R.C. WARD, Balancing the generalized eigenvalue problem, */
+/* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --lscale;
+ --rscale;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
+ && ! lsame_(job, "B")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGGBAL", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *ilo = 1;
+ *ihi = *n;
+ return 0;
+ }
+
+ if (*n == 1) {
+ *ilo = 1;
+ *ihi = *n;
+ lscale[1] = 1.;
+ rscale[1] = 1.;
+ return 0;
+ }
+
+ if (lsame_(job, "N")) {
+ *ilo = 1;
+ *ihi = *n;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ lscale[i__] = 1.;
+ rscale[i__] = 1.;
+/* L10: */
+ }
+ return 0;
+ }
+
+ k = 1;
+ l = *n;
+ if (lsame_(job, "S")) {
+ goto L190;
+ }
+
+ goto L30;
+
+/* Permute the matrices A and B to isolate the eigenvalues. */
+
+/* Find row with one nonzero in columns 1 through L */
+
+L20:
+ l = lm1;
+ if (l != 1) {
+ goto L30;
+ }
+
+ rscale[1] = 1.;
+ lscale[1] = 1.;
+ goto L190;
+
+L30:
+ lm1 = l - 1;
+ for (i__ = l; i__ >= 1; --i__) {
+ i__1 = lm1;
+ for (j = 1; j <= i__1; ++j) {
+ jp1 = j + 1;
+ if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.) {
+ goto L50;
+ }
+/* L40: */
+ }
+ j = l;
+ goto L70;
+
+L50:
+ i__1 = l;
+ for (j = jp1; j <= i__1; ++j) {
+ if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.) {
+ goto L80;
+ }
+/* L60: */
+ }
+ j = jp1 - 1;
+
+L70:
+ m = l;
+ iflow = 1;
+ goto L160;
+L80:
+ ;
+ }
+ goto L100;
+
+/* Find column with one nonzero in rows K through N */
+
+L90:
+ ++k;
+
+L100:
+ i__1 = l;
+ for (j = k; j <= i__1; ++j) {
+ i__2 = lm1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ ip1 = i__ + 1;
+ if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.) {
+ goto L120;
+ }
+/* L110: */
+ }
+ i__ = l;
+ goto L140;
+L120:
+ i__2 = l;
+ for (i__ = ip1; i__ <= i__2; ++i__) {
+ if (a[i__ + j * a_dim1] != 0. || b[i__ + j * b_dim1] != 0.) {
+ goto L150;
+ }
+/* L130: */
+ }
+ i__ = ip1 - 1;
+L140:
+ m = k;
+ iflow = 2;
+ goto L160;
+L150:
+ ;
+ }
+ goto L190;
+
+/* Permute rows M and I */
+
+L160:
+ lscale[m] = (doublereal) i__;
+ if (i__ == m) {
+ goto L170;
+ }
+ i__1 = *n - k + 1;
+ dswap_(&i__1, &a[i__ + k * a_dim1], lda, &a[m + k * a_dim1], lda);
+ i__1 = *n - k + 1;
+ dswap_(&i__1, &b[i__ + k * b_dim1], ldb, &b[m + k * b_dim1], ldb);
+
+/* Permute columns M and J */
+
+L170:
+ rscale[m] = (doublereal) j;
+ if (j == m) {
+ goto L180;
+ }
+ dswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
+ dswap_(&l, &b[j * b_dim1 + 1], &c__1, &b[m * b_dim1 + 1], &c__1);
+
+L180:
+ switch (iflow) {
+ case 1: goto L20;
+ case 2: goto L90;
+ }
+
+L190:
+ *ilo = k;
+ *ihi = l;
+
+ if (lsame_(job, "P")) {
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ lscale[i__] = 1.;
+ rscale[i__] = 1.;
+/* L195: */
+ }
+ return 0;
+ }
+
+ if (*ilo == *ihi) {
+ return 0;
+ }
+
+/* Balance the submatrix in rows ILO to IHI. */
+
+ nr = *ihi - *ilo + 1;
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ rscale[i__] = 0.;
+ lscale[i__] = 0.;
+
+ work[i__] = 0.;
+ work[i__ + *n] = 0.;
+ work[i__ + (*n << 1)] = 0.;
+ work[i__ + *n * 3] = 0.;
+ work[i__ + (*n << 2)] = 0.;
+ work[i__ + *n * 5] = 0.;
+/* L200: */
+ }
+
+/* Compute right side vector in resulting linear equations */
+
+ basl = d_lg10(&c_b35);
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ i__2 = *ihi;
+ for (j = *ilo; j <= i__2; ++j) {
+ tb = b[i__ + j * b_dim1];
+ ta = a[i__ + j * a_dim1];
+ if (ta == 0.) {
+ goto L210;
+ }
+ d__1 = abs(ta);
+ ta = d_lg10(&d__1) / basl;
+L210:
+ if (tb == 0.) {
+ goto L220;
+ }
+ d__1 = abs(tb);
+ tb = d_lg10(&d__1) / basl;
+L220:
+ work[i__ + (*n << 2)] = work[i__ + (*n << 2)] - ta - tb;
+ work[j + *n * 5] = work[j + *n * 5] - ta - tb;
+/* L230: */
+ }
+/* L240: */
+ }
+
+ coef = 1. / (doublereal) (nr << 1);
+ coef2 = coef * coef;
+ coef5 = coef2 * .5;
+ nrp2 = nr + 2;
+ beta = 0.;
+ it = 1;
+
+/* Start generalized conjugate gradient iteration */
+
+L250:
+
+ gamma = ddot_(&nr, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + (*n << 2)]
+, &c__1) + ddot_(&nr, &work[*ilo + *n * 5], &c__1, &work[*ilo + *
+ n * 5], &c__1);
+
+ ew = 0.;
+ ewc = 0.;
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ ew += work[i__ + (*n << 2)];
+ ewc += work[i__ + *n * 5];
+/* L260: */
+ }
+
+/* Computing 2nd power */
+ d__1 = ew;
+/* Computing 2nd power */
+ d__2 = ewc;
+/* Computing 2nd power */
+ d__3 = ew - ewc;
+ gamma = coef * gamma - coef2 * (d__1 * d__1 + d__2 * d__2) - coef5 * (
+ d__3 * d__3);
+ if (gamma == 0.) {
+ goto L350;
+ }
+ if (it != 1) {
+ beta = gamma / pgamma;
+ }
+ t = coef5 * (ewc - ew * 3.);
+ tc = coef5 * (ew - ewc * 3.);
+
+ dscal_(&nr, &beta, &work[*ilo], &c__1);
+ dscal_(&nr, &beta, &work[*ilo + *n], &c__1);
+
+ daxpy_(&nr, &coef, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + *n], &
+ c__1);
+ daxpy_(&nr, &coef, &work[*ilo + *n * 5], &c__1, &work[*ilo], &c__1);
+
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ work[i__] += tc;
+ work[i__ + *n] += t;
+/* L270: */
+ }
+
+/* Apply matrix to vector */
+
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ kount = 0;
+ sum = 0.;
+ i__2 = *ihi;
+ for (j = *ilo; j <= i__2; ++j) {
+ if (a[i__ + j * a_dim1] == 0.) {
+ goto L280;
+ }
+ ++kount;
+ sum += work[j];
+L280:
+ if (b[i__ + j * b_dim1] == 0.) {
+ goto L290;
+ }
+ ++kount;
+ sum += work[j];
+L290:
+ ;
+ }
+ work[i__ + (*n << 1)] = (doublereal) kount * work[i__ + *n] + sum;
+/* L300: */
+ }
+
+ i__1 = *ihi;
+ for (j = *ilo; j <= i__1; ++j) {
+ kount = 0;
+ sum = 0.;
+ i__2 = *ihi;
+ for (i__ = *ilo; i__ <= i__2; ++i__) {
+ if (a[i__ + j * a_dim1] == 0.) {
+ goto L310;
+ }
+ ++kount;
+ sum += work[i__ + *n];
+L310:
+ if (b[i__ + j * b_dim1] == 0.) {
+ goto L320;
+ }
+ ++kount;
+ sum += work[i__ + *n];
+L320:
+ ;
+ }
+ work[j + *n * 3] = (doublereal) kount * work[j] + sum;
+/* L330: */
+ }
+
+ sum = ddot_(&nr, &work[*ilo + *n], &c__1, &work[*ilo + (*n << 1)], &c__1)
+ + ddot_(&nr, &work[*ilo], &c__1, &work[*ilo + *n * 3], &c__1);
+ alpha = gamma / sum;
+
+/* Determine correction to current iteration */
+
+ cmax = 0.;
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ cor = alpha * work[i__ + *n];
+ if (abs(cor) > cmax) {
+ cmax = abs(cor);
+ }
+ lscale[i__] += cor;
+ cor = alpha * work[i__];
+ if (abs(cor) > cmax) {
+ cmax = abs(cor);
+ }
+ rscale[i__] += cor;
+/* L340: */
+ }
+ if (cmax < .5) {
+ goto L350;
+ }
+
+ d__1 = -alpha;
+ daxpy_(&nr, &d__1, &work[*ilo + (*n << 1)], &c__1, &work[*ilo + (*n << 2)]
+, &c__1);
+ d__1 = -alpha;
+ daxpy_(&nr, &d__1, &work[*ilo + *n * 3], &c__1, &work[*ilo + *n * 5], &
+ c__1);
+
+ pgamma = gamma;
+ ++it;
+ if (it <= nrp2) {
+ goto L250;
+ }
+
+/* End generalized conjugate gradient iteration */
+
+L350:
+ sfmin = dlamch_("S");
+ sfmax = 1. / sfmin;
+ lsfmin = (integer) (d_lg10(&sfmin) / basl + 1.);
+ lsfmax = (integer) (d_lg10(&sfmax) / basl);
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ i__2 = *n - *ilo + 1;
+ irab = idamax_(&i__2, &a[i__ + *ilo * a_dim1], lda);
+ rab = (d__1 = a[i__ + (irab + *ilo - 1) * a_dim1], abs(d__1));
+ i__2 = *n - *ilo + 1;
+ irab = idamax_(&i__2, &b[i__ + *ilo * b_dim1], ldb);
+/* Computing MAX */
+ d__2 = rab, d__3 = (d__1 = b[i__ + (irab + *ilo - 1) * b_dim1], abs(
+ d__1));
+ rab = max(d__2,d__3);
+ d__1 = rab + sfmin;
+ lrab = (integer) (d_lg10(&d__1) / basl + 1.);
+ ir = (integer) (lscale[i__] + d_sign(&c_b71, &lscale[i__]));
+/* Computing MIN */
+ i__2 = max(ir,lsfmin), i__2 = min(i__2,lsfmax), i__3 = lsfmax - lrab;
+ ir = min(i__2,i__3);
+ lscale[i__] = pow_di(&c_b35, &ir);
+ icab = idamax_(ihi, &a[i__ * a_dim1 + 1], &c__1);
+ cab = (d__1 = a[icab + i__ * a_dim1], abs(d__1));
+ icab = idamax_(ihi, &b[i__ * b_dim1 + 1], &c__1);
+/* Computing MAX */
+ d__2 = cab, d__3 = (d__1 = b[icab + i__ * b_dim1], abs(d__1));
+ cab = max(d__2,d__3);
+ d__1 = cab + sfmin;
+ lcab = (integer) (d_lg10(&d__1) / basl + 1.);
+ jc = (integer) (rscale[i__] + d_sign(&c_b71, &rscale[i__]));
+/* Computing MIN */
+ i__2 = max(jc,lsfmin), i__2 = min(i__2,lsfmax), i__3 = lsfmax - lcab;
+ jc = min(i__2,i__3);
+ rscale[i__] = pow_di(&c_b35, &jc);
+/* L360: */
+ }
+
+/* Row scaling of matrices A and B */
+
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ i__2 = *n - *ilo + 1;
+ dscal_(&i__2, &lscale[i__], &a[i__ + *ilo * a_dim1], lda);
+ i__2 = *n - *ilo + 1;
+ dscal_(&i__2, &lscale[i__], &b[i__ + *ilo * b_dim1], ldb);
+/* L370: */
+ }
+
+/* Column scaling of matrices A and B */
+
+ i__1 = *ihi;
+ for (j = *ilo; j <= i__1; ++j) {
+ dscal_(ihi, &rscale[j], &a[j * a_dim1 + 1], &c__1);
+ dscal_(ihi, &rscale[j], &b[j * b_dim1 + 1], &c__1);
+/* L380: */
+ }
+
+ return 0;
+
+/* End of DGGBAL */
+
+} /* dggbal_ */
diff --git a/SRC/dgges.c b/SRC/dgges.c
new file mode 100644
index 0000000..57a40f7
--- /dev/null
+++ b/SRC/dgges.c
@@ -0,0 +1,692 @@
+/* dgges.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublereal c_b38 = 0.;
+static doublereal c_b39 = 1.;
+
+/* Subroutine */ int dgges_(char *jobvsl, char *jobvsr, char *sort, L_fp
+ selctg, integer *n, doublereal *a, integer *lda, doublereal *b,
+ integer *ldb, integer *sdim, doublereal *alphar, doublereal *alphai,
+ doublereal *beta, doublereal *vsl, integer *ldvsl, doublereal *vsr,
+ integer *ldvsr, doublereal *work, integer *lwork, logical *bwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
+ vsr_dim1, vsr_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, ip;
+ doublereal dif[2];
+ integer ihi, ilo;
+ doublereal eps, anrm, bnrm;
+ integer idum[1], ierr, itau, iwrk;
+ doublereal pvsl, pvsr;
+ extern logical lsame_(char *, char *);
+ integer ileft, icols;
+ logical cursl, ilvsl, ilvsr;
+ integer irows;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), dggbak_(
+ char *, char *, integer *, integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dggbal_(char *, integer *, doublereal *, integer
+ *, doublereal *, integer *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *);
+ logical lst2sl;
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dgghrd_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dlascl_(char *, integer *, integer *, doublereal
+ *, doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *);
+ logical ilascl, ilbscl;
+ extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *),
+ dlacpy_(char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ doublereal safmin;
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ doublereal safmax;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dhgeqz_(char *, char *, char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *), dtgsen_(integer *, logical *,
+ logical *, logical *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *, integer *, integer *);
+ integer ijobvl, iright;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ijobvr;
+ extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+ doublereal anrmto, bnrmto;
+ logical lastsl;
+ extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ integer minwrk, maxwrk;
+ doublereal smlnum;
+ logical wantst, lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+/* .. Function Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B), */
+/* the generalized eigenvalues, the generalized real Schur form (S,T), */
+/* optionally, the left and/or right matrices of Schur vectors (VSL and */
+/* VSR). This gives the generalized Schur factorization */
+
+/* (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T ) */
+
+/* Optionally, it also orders the eigenvalues so that a selected cluster */
+/* of eigenvalues appears in the leading diagonal blocks of the upper */
+/* quasi-triangular matrix S and the upper triangular matrix T.The */
+/* leading columns of VSL and VSR then form an orthonormal basis for the */
+/* corresponding left and right eigenspaces (deflating subspaces). */
+
+/* (If only the generalized eigenvalues are needed, use the driver */
+/* DGGEV instead, which is faster.) */
+
+/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w */
+/* or a ratio alpha/beta = w, such that A - w*B is singular. It is */
+/* usually represented as the pair (alpha,beta), as there is a */
+/* reasonable interpretation for beta=0 or both being zero. */
+
+/* A pair of matrices (S,T) is in generalized real Schur form if T is */
+/* upper triangular with non-negative diagonal and S is block upper */
+/* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond */
+/* to real generalized eigenvalues, while 2-by-2 blocks of S will be */
+/* "standardized" by making the corresponding elements of T have the */
+/* form: */
+/* [ a 0 ] */
+/* [ 0 b ] */
+
+/* and the pair of corresponding 2-by-2 blocks in S and T will have a */
+/* complex conjugate pair of generalized eigenvalues. */
+
+
+/* Arguments */
+/* ========= */
+
+/* JOBVSL (input) CHARACTER*1 */
+/* = 'N': do not compute the left Schur vectors; */
+/* = 'V': compute the left Schur vectors. */
+
+/* JOBVSR (input) CHARACTER*1 */
+/* = 'N': do not compute the right Schur vectors; */
+/* = 'V': compute the right Schur vectors. */
+
+/* SORT (input) CHARACTER*1 */
+/* Specifies whether or not to order the eigenvalues on the */
+/* diagonal of the generalized Schur form. */
+/* = 'N': Eigenvalues are not ordered; */
+/* = 'S': Eigenvalues are ordered (see SELCTG); */
+
+/* SELCTG (external procedure) LOGICAL FUNCTION of three DOUBLE PRECISION arguments */
+/* SELCTG must be declared EXTERNAL in the calling subroutine. */
+/* If SORT = 'N', SELCTG is not referenced. */
+/* If SORT = 'S', SELCTG is used to select eigenvalues to sort */
+/* to the top left of the Schur form. */
+/* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if */
+/* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either */
+/* one of a complex conjugate pair of eigenvalues is selected, */
+/* then both complex eigenvalues are selected. */
+
+/* Note that in the ill-conditioned case, a selected complex */
+/* eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j), */
+/* BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2 */
+/* in this case. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VSL, and VSR. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
+/* On entry, the first of the pair of matrices. */
+/* On exit, A has been overwritten by its generalized Schur */
+/* form S. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */
+/* On entry, the second of the pair of matrices. */
+/* On exit, B has been overwritten by its generalized Schur */
+/* form T. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* SDIM (output) INTEGER */
+/* If SORT = 'N', SDIM = 0. */
+/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */
+/* for which SELCTG is true. (Complex conjugate pairs for which */
+/* SELCTG is true for either eigenvalue count as 2.) */
+
+/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */
+/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */
+/* BETA (output) DOUBLE PRECISION array, dimension (N) */
+/* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */
+/* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i, */
+/* and BETA(j),j=1,...,N are the diagonals of the complex Schur */
+/* form (S,T) that would result if the 2-by-2 diagonal blocks of */
+/* the real Schur form of (A,B) were further reduced to */
+/* triangular form using 2-by-2 complex unitary transformations. */
+/* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */
+/* positive, then the j-th and (j+1)-st eigenvalues are a */
+/* complex conjugate pair, with ALPHAI(j+1) negative. */
+
+/* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */
+/* may easily over- or underflow, and BETA(j) may even be zero. */
+/* Thus, the user should avoid naively computing the ratio. */
+/* However, ALPHAR and ALPHAI will be always less than and */
+/* usually comparable with norm(A) in magnitude, and BETA always */
+/* less than and usually comparable with norm(B). */
+
+/* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N) */
+/* If JOBVSL = 'V', VSL will contain the left Schur vectors. */
+/* Not referenced if JOBVSL = 'N'. */
+
+/* LDVSL (input) INTEGER */
+/* The leading dimension of the matrix VSL. LDVSL >=1, and */
+/* if JOBVSL = 'V', LDVSL >= N. */
+
+/* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N) */
+/* If JOBVSR = 'V', VSR will contain the right Schur vectors. */
+/* Not referenced if JOBVSR = 'N'. */
+
+/* LDVSR (input) INTEGER */
+/* The leading dimension of the matrix VSR. LDVSR >= 1, and */
+/* if JOBVSR = 'V', LDVSR >= N. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If N = 0, LWORK >= 1, else LWORK >= 8*N+16. */
+/* For good performance , LWORK must generally be larger. */
+
+/* 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. */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+/* Not referenced if SORT = 'N'. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1,...,N: */
+/* The QZ iteration failed. (A,B) are not in Schur */
+/* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should */
+/* be correct for j=INFO+1,...,N. */
+/* > N: =N+1: other than QZ iteration failed in DHGEQZ. */
+/* =N+2: after reordering, roundoff changed values of */
+/* some complex eigenvalues so that leading */
+/* eigenvalues in the Generalized Schur form no */
+/* longer satisfy SELCTG=.TRUE. This could also */
+/* be caused due to scaling. */
+/* =N+3: reordering failed in DTGSEN. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ vsl_dim1 = *ldvsl;
+ vsl_offset = 1 + vsl_dim1;
+ vsl -= vsl_offset;
+ vsr_dim1 = *ldvsr;
+ vsr_offset = 1 + vsr_dim1;
+ vsr -= vsr_offset;
+ --work;
+ --bwork;
+
+ /* Function Body */
+ if (lsame_(jobvsl, "N")) {
+ ijobvl = 1;
+ ilvsl = FALSE_;
+ } else if (lsame_(jobvsl, "V")) {
+ ijobvl = 2;
+ ilvsl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvsl = FALSE_;
+ }
+
+ if (lsame_(jobvsr, "N")) {
+ ijobvr = 1;
+ ilvsr = FALSE_;
+ } else if (lsame_(jobvsr, "V")) {
+ ijobvr = 2;
+ ilvsr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvsr = FALSE_;
+ }
+
+ wantst = lsame_(sort, "S");
+
+/* Test the input arguments */
+
+ *info = 0;
+ lquery = *lwork == -1;
+ if (ijobvl <= 0) {
+ *info = -1;
+ } else if (ijobvr <= 0) {
+ *info = -2;
+ } else if (! wantst && ! lsame_(sort, "N")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
+ *info = -15;
+ } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
+ *info = -17;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ if (*info == 0) {
+ if (*n > 0) {
+/* Computing MAX */
+ i__1 = *n << 3, i__2 = *n * 6 + 16;
+ minwrk = max(i__1,i__2);
+ maxwrk = minwrk - *n + *n * ilaenv_(&c__1, "DGEQRF", " ", n, &
+ c__1, n, &c__0);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = minwrk - *n + *n * ilaenv_(&c__1, "DORMQR",
+ " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ if (ilvsl) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = minwrk - *n + *n * ilaenv_(&c__1, "DOR"
+ "GQR", " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ }
+ } else {
+ minwrk = 1;
+ maxwrk = 1;
+ }
+ work[1] = (doublereal) maxwrk;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -19;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGGES ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *sdim = 0;
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ safmin = dlamch_("S");
+ safmax = 1. / safmin;
+ dlabad_(&safmin, &safmax);
+ smlnum = sqrt(safmin) / eps;
+ bignum = 1. / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]);
+ ilascl = FALSE_;
+ if (anrm > 0. && anrm < smlnum) {
+ anrmto = smlnum;
+ ilascl = TRUE_;
+ } else if (anrm > bignum) {
+ anrmto = bignum;
+ ilascl = TRUE_;
+ }
+ if (ilascl) {
+ dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]);
+ ilbscl = FALSE_;
+ if (bnrm > 0. && bnrm < smlnum) {
+ bnrmto = smlnum;
+ ilbscl = TRUE_;
+ } else if (bnrm > bignum) {
+ bnrmto = bignum;
+ ilbscl = TRUE_;
+ }
+ if (ilbscl) {
+ dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
+ ierr);
+ }
+
+/* Permute the matrix to make it more nearly triangular */
+/* (Workspace: need 6*N + 2*N space for storing balancing factors) */
+
+ ileft = 1;
+ iright = *n + 1;
+ iwrk = iright + *n;
+ dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[
+ ileft], &work[iright], &work[iwrk], &ierr);
+
+/* Reduce B to triangular form (QR decomposition of B) */
+/* (Workspace: need N, prefer N*NB) */
+
+ irows = ihi + 1 - ilo;
+ icols = *n + 1 - ilo;
+ itau = iwrk;
+ iwrk = itau + irows;
+ i__1 = *lwork + 1 - iwrk;
+ dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
+ iwrk], &i__1, &ierr);
+
+/* Apply the orthogonal transformation to matrix A */
+/* (Workspace: need N, prefer N*NB) */
+
+ i__1 = *lwork + 1 - iwrk;
+ dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
+ work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, &
+ ierr);
+
+/* Initialize VSL */
+/* (Workspace: need N, prefer N*NB) */
+
+ if (ilvsl) {
+ dlaset_("Full", n, n, &c_b38, &c_b39, &vsl[vsl_offset], ldvsl);
+ if (irows > 1) {
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[
+ ilo + 1 + ilo * vsl_dim1], ldvsl);
+ }
+ i__1 = *lwork + 1 - iwrk;
+ dorgqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, &
+ work[itau], &work[iwrk], &i__1, &ierr);
+ }
+
+/* Initialize VSR */
+
+ if (ilvsr) {
+ dlaset_("Full", n, n, &c_b38, &c_b39, &vsr[vsr_offset], ldvsr);
+ }
+
+/* Reduce to generalized Hessenberg form */
+/* (Workspace: none needed) */
+
+ dgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &ierr);
+
+/* Perform QZ algorithm, computing Schur vectors if desired */
+/* (Workspace: need N) */
+
+ iwrk = itau;
+ i__1 = *lwork + 1 - iwrk;
+ dhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[
+ b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset]
+, ldvsl, &vsr[vsr_offset], ldvsr, &work[iwrk], &i__1, &ierr);
+ if (ierr != 0) {
+ if (ierr > 0 && ierr <= *n) {
+ *info = ierr;
+ } else if (ierr > *n && ierr <= *n << 1) {
+ *info = ierr - *n;
+ } else {
+ *info = *n + 1;
+ }
+ goto L50;
+ }
+
+/* Sort eigenvalues ALPHA/BETA if desired */
+/* (Workspace: need 4*N+16 ) */
+
+ *sdim = 0;
+ if (wantst) {
+
+/* Undo scaling on eigenvalues before SELCTGing */
+
+ if (ilascl) {
+ dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1],
+ n, &ierr);
+ dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1],
+ n, &ierr);
+ }
+ if (ilbscl) {
+ dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n,
+ &ierr);
+ }
+
+/* Select eigenvalues */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ bwork[i__] = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]);
+/* L10: */
+ }
+
+ i__1 = *lwork - iwrk + 1;
+ dtgsen_(&c__0, &ilvsl, &ilvsr, &bwork[1], n, &a[a_offset], lda, &b[
+ b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[
+ vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, sdim, &pvsl, &
+ pvsr, dif, &work[iwrk], &i__1, idum, &c__1, &ierr);
+ if (ierr == 1) {
+ *info = *n + 3;
+ }
+
+ }
+
+/* Apply back-permutation to VSL and VSR */
+/* (Workspace: none needed) */
+
+ if (ilvsl) {
+ dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[
+ vsl_offset], ldvsl, &ierr);
+ }
+
+ if (ilvsr) {
+ dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[
+ vsr_offset], ldvsr, &ierr);
+ }
+
+/* Check if unscaling would cause over/underflow, if so, rescale */
+/* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of */
+/* B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I) */
+
+ if (ilascl) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (alphai[i__] != 0.) {
+ if (alphar[i__] / safmax > anrmto / anrm || safmin / alphar[
+ i__] > anrm / anrmto) {
+ work[1] = (d__1 = a[i__ + i__ * a_dim1] / alphar[i__],
+ abs(d__1));
+ beta[i__] *= work[1];
+ alphar[i__] *= work[1];
+ alphai[i__] *= work[1];
+ } else if (alphai[i__] / safmax > anrmto / anrm || safmin /
+ alphai[i__] > anrm / anrmto) {
+ work[1] = (d__1 = a[i__ + (i__ + 1) * a_dim1] / alphai[
+ i__], abs(d__1));
+ beta[i__] *= work[1];
+ alphar[i__] *= work[1];
+ alphai[i__] *= work[1];
+ }
+ }
+/* L20: */
+ }
+ }
+
+ if (ilbscl) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (alphai[i__] != 0.) {
+ if (beta[i__] / safmax > bnrmto / bnrm || safmin / beta[i__]
+ > bnrm / bnrmto) {
+ work[1] = (d__1 = b[i__ + i__ * b_dim1] / beta[i__], abs(
+ d__1));
+ beta[i__] *= work[1];
+ alphar[i__] *= work[1];
+ alphai[i__] *= work[1];
+ }
+ }
+/* L30: */
+ }
+ }
+
+/* Undo scaling */
+
+ if (ilascl) {
+ dlascl_("H", &c__0, &c__0, &anrmto, &anrm, n, n, &a[a_offset], lda, &
+ ierr);
+ dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, &
+ ierr);
+ dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, &
+ ierr);
+ }
+
+ if (ilbscl) {
+ dlascl_("U", &c__0, &c__0, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, &
+ ierr);
+ dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
+ ierr);
+ }
+
+ if (wantst) {
+
+/* Check if reordering is correct */
+
+ lastsl = TRUE_;
+ lst2sl = TRUE_;
+ *sdim = 0;
+ ip = 0;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ cursl = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]);
+ if (alphai[i__] == 0.) {
+ if (cursl) {
+ ++(*sdim);
+ }
+ ip = 0;
+ if (cursl && ! lastsl) {
+ *info = *n + 2;
+ }
+ } else {
+ if (ip == 1) {
+
+/* Last eigenvalue of conjugate pair */
+
+ cursl = cursl || lastsl;
+ lastsl = cursl;
+ if (cursl) {
+ *sdim += 2;
+ }
+ ip = -1;
+ if (cursl && ! lst2sl) {
+ *info = *n + 2;
+ }
+ } else {
+
+/* First eigenvalue of conjugate pair */
+
+ ip = 1;
+ }
+ }
+ lst2sl = lastsl;
+ lastsl = cursl;
+/* L40: */
+ }
+
+ }
+
+L50:
+
+ work[1] = (doublereal) maxwrk;
+
+ return 0;
+
+/* End of DGGES */
+
+} /* dgges_ */
diff --git a/SRC/dggesx.c b/SRC/dggesx.c
new file mode 100644
index 0000000..c0bd11f
--- /dev/null
+++ b/SRC/dggesx.c
@@ -0,0 +1,818 @@
+/* dggesx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublereal c_b42 = 0.;
+static doublereal c_b43 = 1.;
+
+/* Subroutine */ int dggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp
+ selctg, char *sense, integer *n, doublereal *a, integer *lda,
+ doublereal *b, integer *ldb, integer *sdim, doublereal *alphar,
+ doublereal *alphai, doublereal *beta, doublereal *vsl, integer *ldvsl,
+ doublereal *vsr, integer *ldvsr, doublereal *rconde, doublereal *
+ rcondv, doublereal *work, integer *lwork, integer *iwork, integer *
+ liwork, logical *bwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
+ vsr_dim1, vsr_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, ip;
+ doublereal pl, pr, dif[2];
+ integer ihi, ilo;
+ doublereal eps;
+ integer ijob;
+ doublereal anrm, bnrm;
+ integer ierr, itau, iwrk, lwrk;
+ extern logical lsame_(char *, char *);
+ integer ileft, icols;
+ logical cursl, ilvsl, ilvsr;
+ integer irows;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), dggbak_(
+ char *, char *, integer *, integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dggbal_(char *, integer *, doublereal *, integer
+ *, doublereal *, integer *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *);
+ logical lst2sl;
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dgghrd_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dlascl_(char *, integer *, integer *, doublereal
+ *, doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *);
+ logical ilascl, ilbscl;
+ extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *),
+ dlacpy_(char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ doublereal safmin;
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ doublereal safmax;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dhgeqz_(char *, char *, char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *);
+ integer ijobvl, iright;
+ extern /* Subroutine */ int dtgsen_(integer *, logical *, logical *,
+ logical *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *,
+ integer *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ijobvr;
+ logical wantsb;
+ integer liwmin;
+ logical wantse, lastsl;
+ doublereal anrmto, bnrmto;
+ extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+ integer minwrk, maxwrk;
+ logical wantsn;
+ doublereal smlnum;
+ extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ logical wantst, lquery, wantsv;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+/* .. Function Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGGESX computes for a pair of N-by-N real nonsymmetric matrices */
+/* (A,B), the generalized eigenvalues, the real Schur form (S,T), and, */
+/* optionally, the left and/or right matrices of Schur vectors (VSL and */
+/* VSR). This gives the generalized Schur factorization */
+
+/* (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T ) */
+
+/* Optionally, it also orders the eigenvalues so that a selected cluster */
+/* of eigenvalues appears in the leading diagonal blocks of the upper */
+/* quasi-triangular matrix S and the upper triangular matrix T; computes */
+/* a reciprocal condition number for the average of the selected */
+/* eigenvalues (RCONDE); and computes a reciprocal condition number for */
+/* the right and left deflating subspaces corresponding to the selected */
+/* eigenvalues (RCONDV). The leading columns of VSL and VSR then form */
+/* an orthonormal basis for the corresponding left and right eigenspaces */
+/* (deflating subspaces). */
+
+/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w */
+/* or a ratio alpha/beta = w, such that A - w*B is singular. It is */
+/* usually represented as the pair (alpha,beta), as there is a */
+/* reasonable interpretation for beta=0 or for both being zero. */
+
+/* A pair of matrices (S,T) is in generalized real Schur form if T is */
+/* upper triangular with non-negative diagonal and S is block upper */
+/* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond */
+/* to real generalized eigenvalues, while 2-by-2 blocks of S will be */
+/* "standardized" by making the corresponding elements of T have the */
+/* form: */
+/* [ a 0 ] */
+/* [ 0 b ] */
+
+/* and the pair of corresponding 2-by-2 blocks in S and T will have a */
+/* complex conjugate pair of generalized eigenvalues. */
+
+
+/* Arguments */
+/* ========= */
+
+/* JOBVSL (input) CHARACTER*1 */
+/* = 'N': do not compute the left Schur vectors; */
+/* = 'V': compute the left Schur vectors. */
+
+/* JOBVSR (input) CHARACTER*1 */
+/* = 'N': do not compute the right Schur vectors; */
+/* = 'V': compute the right Schur vectors. */
+
+/* SORT (input) CHARACTER*1 */
+/* Specifies whether or not to order the eigenvalues on the */
+/* diagonal of the generalized Schur form. */
+/* = 'N': Eigenvalues are not ordered; */
+/* = 'S': Eigenvalues are ordered (see SELCTG). */
+
+/* SELCTG (external procedure) LOGICAL FUNCTION of three DOUBLE PRECISION arguments */
+/* SELCTG must be declared EXTERNAL in the calling subroutine. */
+/* If SORT = 'N', SELCTG is not referenced. */
+/* If SORT = 'S', SELCTG is used to select eigenvalues to sort */
+/* to the top left of the Schur form. */
+/* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if */
+/* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either */
+/* one of a complex conjugate pair of eigenvalues is selected, */
+/* then both complex eigenvalues are selected. */
+/* Note that a selected complex eigenvalue may no longer satisfy */
+/* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering, */
+/* since ordering may change the value of complex eigenvalues */
+/* (especially if the eigenvalue is ill-conditioned), in this */
+/* case INFO is set to N+3. */
+
+/* SENSE (input) CHARACTER*1 */
+/* Determines which reciprocal condition numbers are computed. */
+/* = 'N' : None are computed; */
+/* = 'E' : Computed for average of selected eigenvalues only; */
+/* = 'V' : Computed for selected deflating subspaces only; */
+/* = 'B' : Computed for both. */
+/* If SENSE = 'E', 'V', or 'B', SORT must equal 'S'. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VSL, and VSR. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
+/* On entry, the first of the pair of matrices. */
+/* On exit, A has been overwritten by its generalized Schur */
+/* form S. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */
+/* On entry, the second of the pair of matrices. */
+/* On exit, B has been overwritten by its generalized Schur */
+/* form T. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* SDIM (output) INTEGER */
+/* If SORT = 'N', SDIM = 0. */
+/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */
+/* for which SELCTG is true. (Complex conjugate pairs for which */
+/* SELCTG is true for either eigenvalue count as 2.) */
+
+/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */
+/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */
+/* BETA (output) DOUBLE PRECISION array, dimension (N) */
+/* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */
+/* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i */
+/* and BETA(j),j=1,...,N are the diagonals of the complex Schur */
+/* form (S,T) that would result if the 2-by-2 diagonal blocks of */
+/* the real Schur form of (A,B) were further reduced to */
+/* triangular form using 2-by-2 complex unitary transformations. */
+/* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */
+/* positive, then the j-th and (j+1)-st eigenvalues are a */
+/* complex conjugate pair, with ALPHAI(j+1) negative. */
+
+/* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */
+/* may easily over- or underflow, and BETA(j) may even be zero. */
+/* Thus, the user should avoid naively computing the ratio. */
+/* However, ALPHAR and ALPHAI will be always less than and */
+/* usually comparable with norm(A) in magnitude, and BETA always */
+/* less than and usually comparable with norm(B). */
+
+/* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N) */
+/* If JOBVSL = 'V', VSL will contain the left Schur vectors. */
+/* Not referenced if JOBVSL = 'N'. */
+
+/* LDVSL (input) INTEGER */
+/* The leading dimension of the matrix VSL. LDVSL >=1, and */
+/* if JOBVSL = 'V', LDVSL >= N. */
+
+/* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N) */
+/* If JOBVSR = 'V', VSR will contain the right Schur vectors. */
+/* Not referenced if JOBVSR = 'N'. */
+
+/* LDVSR (input) INTEGER */
+/* The leading dimension of the matrix VSR. LDVSR >= 1, and */
+/* if JOBVSR = 'V', LDVSR >= N. */
+
+/* RCONDE (output) DOUBLE PRECISION array, dimension ( 2 ) */
+/* If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the */
+/* reciprocal condition numbers for the average of the selected */
+/* eigenvalues. */
+/* Not referenced if SENSE = 'N' or 'V'. */
+
+/* RCONDV (output) DOUBLE PRECISION array, dimension ( 2 ) */
+/* If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the */
+/* reciprocal condition numbers for the selected deflating */
+/* subspaces. */
+/* Not referenced if SENSE = 'N' or 'E'. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B', */
+/* LWORK >= max( 8*N, 6*N+16, 2*SDIM*(N-SDIM) ), else */
+/* LWORK >= max( 8*N, 6*N+16 ). */
+/* Note that 2*SDIM*(N-SDIM) <= N*N/2. */
+/* Note also that an error is only returned if */
+/* LWORK < max( 8*N, 6*N+16), but if SENSE = 'E' or 'V' or 'B' */
+/* this may not be large enough. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the bound on the optimal size of the WORK */
+/* array and the minimum size of the IWORK array, returns these */
+/* values as the first entries of the WORK and IWORK arrays, and */
+/* no error message related to LWORK or LIWORK is issued by */
+/* XERBLA. */
+
+/* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise */
+/* LIWORK >= N+6. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the bound on the optimal size of the */
+/* WORK array and the minimum size of the IWORK array, returns */
+/* these values as the first entries of the WORK and IWORK */
+/* arrays, and no error message related to LWORK or LIWORK is */
+/* issued by XERBLA. */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+/* Not referenced if SORT = 'N'. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1,...,N: */
+/* The QZ iteration failed. (A,B) are not in Schur */
+/* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should */
+/* be correct for j=INFO+1,...,N. */
+/* > N: =N+1: other than QZ iteration failed in DHGEQZ */
+/* =N+2: after reordering, roundoff changed values of */
+/* some complex eigenvalues so that leading */
+/* eigenvalues in the Generalized Schur form no */
+/* longer satisfy SELCTG=.TRUE. This could also */
+/* be caused due to scaling. */
+/* =N+3: reordering failed in DTGSEN. */
+
+/* Further details */
+/* =============== */
+
+/* An approximate (asymptotic) bound on the average absolute error of */
+/* the selected eigenvalues is */
+
+/* EPS * norm((A, B)) / RCONDE( 1 ). */
+
+/* An approximate (asymptotic) bound on the maximum angular error in */
+/* the computed deflating subspaces is */
+
+/* EPS * norm((A, B)) / RCONDV( 2 ). */
+
+/* See LAPACK User's Guide, section 4.11 for more information. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ vsl_dim1 = *ldvsl;
+ vsl_offset = 1 + vsl_dim1;
+ vsl -= vsl_offset;
+ vsr_dim1 = *ldvsr;
+ vsr_offset = 1 + vsr_dim1;
+ vsr -= vsr_offset;
+ --rconde;
+ --rcondv;
+ --work;
+ --iwork;
+ --bwork;
+
+ /* Function Body */
+ if (lsame_(jobvsl, "N")) {
+ ijobvl = 1;
+ ilvsl = FALSE_;
+ } else if (lsame_(jobvsl, "V")) {
+ ijobvl = 2;
+ ilvsl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvsl = FALSE_;
+ }
+
+ if (lsame_(jobvsr, "N")) {
+ ijobvr = 1;
+ ilvsr = FALSE_;
+ } else if (lsame_(jobvsr, "V")) {
+ ijobvr = 2;
+ ilvsr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvsr = FALSE_;
+ }
+
+ wantst = lsame_(sort, "S");
+ wantsn = lsame_(sense, "N");
+ wantse = lsame_(sense, "E");
+ wantsv = lsame_(sense, "V");
+ wantsb = lsame_(sense, "B");
+ lquery = *lwork == -1 || *liwork == -1;
+ if (wantsn) {
+ ijob = 0;
+ } else if (wantse) {
+ ijob = 1;
+ } else if (wantsv) {
+ ijob = 2;
+ } else if (wantsb) {
+ ijob = 4;
+ }
+
+/* Test the input arguments */
+
+ *info = 0;
+ if (ijobvl <= 0) {
+ *info = -1;
+ } else if (ijobvr <= 0) {
+ *info = -2;
+ } else if (! wantst && ! lsame_(sort, "N")) {
+ *info = -3;
+ } else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && !
+ wantsn) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (*lda < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
+ *info = -16;
+ } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
+ *info = -18;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ if (*info == 0) {
+ if (*n > 0) {
+/* Computing MAX */
+ i__1 = *n << 3, i__2 = *n * 6 + 16;
+ minwrk = max(i__1,i__2);
+ maxwrk = minwrk - *n + *n * ilaenv_(&c__1, "DGEQRF", " ", n, &
+ c__1, n, &c__0);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = minwrk - *n + *n * ilaenv_(&c__1, "DORMQR",
+ " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ if (ilvsl) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = minwrk - *n + *n * ilaenv_(&c__1, "DOR"
+ "GQR", " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ }
+ lwrk = maxwrk;
+ if (ijob >= 1) {
+/* Computing MAX */
+ i__1 = lwrk, i__2 = *n * *n / 2;
+ lwrk = max(i__1,i__2);
+ }
+ } else {
+ minwrk = 1;
+ maxwrk = 1;
+ lwrk = 1;
+ }
+ work[1] = (doublereal) lwrk;
+ if (wantsn || *n == 0) {
+ liwmin = 1;
+ } else {
+ liwmin = *n + 6;
+ }
+ iwork[1] = liwmin;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -22;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -24;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGGESX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *sdim = 0;
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ safmin = dlamch_("S");
+ safmax = 1. / safmin;
+ dlabad_(&safmin, &safmax);
+ smlnum = sqrt(safmin) / eps;
+ bignum = 1. / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]);
+ ilascl = FALSE_;
+ if (anrm > 0. && anrm < smlnum) {
+ anrmto = smlnum;
+ ilascl = TRUE_;
+ } else if (anrm > bignum) {
+ anrmto = bignum;
+ ilascl = TRUE_;
+ }
+ if (ilascl) {
+ dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]);
+ ilbscl = FALSE_;
+ if (bnrm > 0. && bnrm < smlnum) {
+ bnrmto = smlnum;
+ ilbscl = TRUE_;
+ } else if (bnrm > bignum) {
+ bnrmto = bignum;
+ ilbscl = TRUE_;
+ }
+ if (ilbscl) {
+ dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
+ ierr);
+ }
+
+/* Permute the matrix to make it more nearly triangular */
+/* (Workspace: need 6*N + 2*N for permutation parameters) */
+
+ ileft = 1;
+ iright = *n + 1;
+ iwrk = iright + *n;
+ dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[
+ ileft], &work[iright], &work[iwrk], &ierr);
+
+/* Reduce B to triangular form (QR decomposition of B) */
+/* (Workspace: need N, prefer N*NB) */
+
+ irows = ihi + 1 - ilo;
+ icols = *n + 1 - ilo;
+ itau = iwrk;
+ iwrk = itau + irows;
+ i__1 = *lwork + 1 - iwrk;
+ dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
+ iwrk], &i__1, &ierr);
+
+/* Apply the orthogonal transformation to matrix A */
+/* (Workspace: need N, prefer N*NB) */
+
+ i__1 = *lwork + 1 - iwrk;
+ dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
+ work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, &
+ ierr);
+
+/* Initialize VSL */
+/* (Workspace: need N, prefer N*NB) */
+
+ if (ilvsl) {
+ dlaset_("Full", n, n, &c_b42, &c_b43, &vsl[vsl_offset], ldvsl);
+ if (irows > 1) {
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[
+ ilo + 1 + ilo * vsl_dim1], ldvsl);
+ }
+ i__1 = *lwork + 1 - iwrk;
+ dorgqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, &
+ work[itau], &work[iwrk], &i__1, &ierr);
+ }
+
+/* Initialize VSR */
+
+ if (ilvsr) {
+ dlaset_("Full", n, n, &c_b42, &c_b43, &vsr[vsr_offset], ldvsr);
+ }
+
+/* Reduce to generalized Hessenberg form */
+/* (Workspace: none needed) */
+
+ dgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &ierr);
+
+ *sdim = 0;
+
+/* Perform QZ algorithm, computing Schur vectors if desired */
+/* (Workspace: need N) */
+
+ iwrk = itau;
+ i__1 = *lwork + 1 - iwrk;
+ dhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[
+ b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset]
+, ldvsl, &vsr[vsr_offset], ldvsr, &work[iwrk], &i__1, &ierr);
+ if (ierr != 0) {
+ if (ierr > 0 && ierr <= *n) {
+ *info = ierr;
+ } else if (ierr > *n && ierr <= *n << 1) {
+ *info = ierr - *n;
+ } else {
+ *info = *n + 1;
+ }
+ goto L60;
+ }
+
+/* Sort eigenvalues ALPHA/BETA and compute the reciprocal of */
+/* condition number(s) */
+/* (Workspace: If IJOB >= 1, need MAX( 8*(N+1), 2*SDIM*(N-SDIM) ) */
+/* otherwise, need 8*(N+1) ) */
+
+ if (wantst) {
+
+/* Undo scaling on eigenvalues before SELCTGing */
+
+ if (ilascl) {
+ dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1],
+ n, &ierr);
+ dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1],
+ n, &ierr);
+ }
+ if (ilbscl) {
+ dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n,
+ &ierr);
+ }
+
+/* Select eigenvalues */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ bwork[i__] = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]);
+/* L10: */
+ }
+
+/* Reorder eigenvalues, transform Generalized Schur vectors, and */
+/* compute reciprocal condition numbers */
+
+ i__1 = *lwork - iwrk + 1;
+ dtgsen_(&ijob, &ilvsl, &ilvsr, &bwork[1], n, &a[a_offset], lda, &b[
+ b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[
+ vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, sdim, &pl, &pr,
+ dif, &work[iwrk], &i__1, &iwork[1], liwork, &ierr);
+
+ if (ijob >= 1) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*sdim << 1) * (*n - *sdim);
+ maxwrk = max(i__1,i__2);
+ }
+ if (ierr == -22) {
+
+/* not enough real workspace */
+
+ *info = -22;
+ } else {
+ if (ijob == 1 || ijob == 4) {
+ rconde[1] = pl;
+ rconde[2] = pr;
+ }
+ if (ijob == 2 || ijob == 4) {
+ rcondv[1] = dif[0];
+ rcondv[2] = dif[1];
+ }
+ if (ierr == 1) {
+ *info = *n + 3;
+ }
+ }
+
+ }
+
+/* Apply permutation to VSL and VSR */
+/* (Workspace: none needed) */
+
+ if (ilvsl) {
+ dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[
+ vsl_offset], ldvsl, &ierr);
+ }
+
+ if (ilvsr) {
+ dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[
+ vsr_offset], ldvsr, &ierr);
+ }
+
+/* Check if unscaling would cause over/underflow, if so, rescale */
+/* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of */
+/* B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I) */
+
+ if (ilascl) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (alphai[i__] != 0.) {
+ if (alphar[i__] / safmax > anrmto / anrm || safmin / alphar[
+ i__] > anrm / anrmto) {
+ work[1] = (d__1 = a[i__ + i__ * a_dim1] / alphar[i__],
+ abs(d__1));
+ beta[i__] *= work[1];
+ alphar[i__] *= work[1];
+ alphai[i__] *= work[1];
+ } else if (alphai[i__] / safmax > anrmto / anrm || safmin /
+ alphai[i__] > anrm / anrmto) {
+ work[1] = (d__1 = a[i__ + (i__ + 1) * a_dim1] / alphai[
+ i__], abs(d__1));
+ beta[i__] *= work[1];
+ alphar[i__] *= work[1];
+ alphai[i__] *= work[1];
+ }
+ }
+/* L20: */
+ }
+ }
+
+ if (ilbscl) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (alphai[i__] != 0.) {
+ if (beta[i__] / safmax > bnrmto / bnrm || safmin / beta[i__]
+ > bnrm / bnrmto) {
+ work[1] = (d__1 = b[i__ + i__ * b_dim1] / beta[i__], abs(
+ d__1));
+ beta[i__] *= work[1];
+ alphar[i__] *= work[1];
+ alphai[i__] *= work[1];
+ }
+ }
+/* L30: */
+ }
+ }
+
+/* Undo scaling */
+
+ if (ilascl) {
+ dlascl_("H", &c__0, &c__0, &anrmto, &anrm, n, n, &a[a_offset], lda, &
+ ierr);
+ dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, &
+ ierr);
+ dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, &
+ ierr);
+ }
+
+ if (ilbscl) {
+ dlascl_("U", &c__0, &c__0, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, &
+ ierr);
+ dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
+ ierr);
+ }
+
+ if (wantst) {
+
+/* Check if reordering is correct */
+
+ lastsl = TRUE_;
+ lst2sl = TRUE_;
+ *sdim = 0;
+ ip = 0;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ cursl = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]);
+ if (alphai[i__] == 0.) {
+ if (cursl) {
+ ++(*sdim);
+ }
+ ip = 0;
+ if (cursl && ! lastsl) {
+ *info = *n + 2;
+ }
+ } else {
+ if (ip == 1) {
+
+/* Last eigenvalue of conjugate pair */
+
+ cursl = cursl || lastsl;
+ lastsl = cursl;
+ if (cursl) {
+ *sdim += 2;
+ }
+ ip = -1;
+ if (cursl && ! lst2sl) {
+ *info = *n + 2;
+ }
+ } else {
+
+/* First eigenvalue of conjugate pair */
+
+ ip = 1;
+ }
+ }
+ lst2sl = lastsl;
+ lastsl = cursl;
+/* L50: */
+ }
+
+ }
+
+L60:
+
+ work[1] = (doublereal) maxwrk;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of DGGESX */
+
+} /* dggesx_ */
diff --git a/SRC/dggev.c b/SRC/dggev.c
new file mode 100644
index 0000000..4b47f8b
--- /dev/null
+++ b/SRC/dggev.c
@@ -0,0 +1,641 @@
+/* dggev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublereal c_b36 = 0.;
+static doublereal c_b37 = 1.;
+
+/* Subroutine */ int dggev_(char *jobvl, char *jobvr, integer *n, doublereal *
+ a, integer *lda, doublereal *b, integer *ldb, doublereal *alphar,
+ doublereal *alphai, doublereal *beta, doublereal *vl, integer *ldvl,
+ doublereal *vr, integer *ldvr, doublereal *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
+ vr_offset, i__1, i__2;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer jc, in, jr, ihi, ilo;
+ doublereal eps;
+ logical ilv;
+ doublereal anrm, bnrm;
+ integer ierr, itau;
+ doublereal temp;
+ logical ilvl, ilvr;
+ integer iwrk;
+ extern logical lsame_(char *, char *);
+ integer ileft, icols, irows;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), dggbak_(
+ char *, char *, integer *, integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dggbal_(char *, integer *, doublereal *, integer
+ *, doublereal *, integer *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dgghrd_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dlascl_(char *, integer *, integer *, doublereal
+ *, doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *);
+ logical ilascl, ilbscl;
+ extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *),
+ dlacpy_(char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *), dlaset_(char *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *), dtgevc_(char *, char *, logical *, integer *, doublereal
+ *, integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, integer *, integer *, doublereal *,
+ integer *);
+ logical ldumma[1];
+ char chtemp[1];
+ doublereal bignum;
+ extern /* Subroutine */ int dhgeqz_(char *, char *, char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ijobvl, iright, ijobvr;
+ extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+ doublereal anrmto, bnrmto;
+ extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ integer minwrk, maxwrk;
+ doublereal smlnum;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B) */
+/* the generalized eigenvalues, and optionally, the left and/or right */
+/* generalized eigenvectors. */
+
+/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar */
+/* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is */
+/* singular. It is usually represented as the pair (alpha,beta), as */
+/* there is a reasonable interpretation for beta=0, and even for both */
+/* being zero. */
+
+/* The right eigenvector v(j) corresponding to the eigenvalue lambda(j) */
+/* of (A,B) satisfies */
+
+/* A * v(j) = lambda(j) * B * v(j). */
+
+/* The left eigenvector u(j) corresponding to the eigenvalue lambda(j) */
+/* of (A,B) satisfies */
+
+/* u(j)**H * A = lambda(j) * u(j)**H * B . */
+
+/* where u(j)**H is the conjugate-transpose of u(j). */
+
+
+/* Arguments */
+/* ========= */
+
+/* JOBVL (input) CHARACTER*1 */
+/* = 'N': do not compute the left generalized eigenvectors; */
+/* = 'V': compute the left generalized eigenvectors. */
+
+/* JOBVR (input) CHARACTER*1 */
+/* = 'N': do not compute the right generalized eigenvectors; */
+/* = 'V': compute the right generalized eigenvectors. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VL, and VR. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
+/* On entry, the matrix A in the pair (A,B). */
+/* On exit, A has been overwritten. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */
+/* On entry, the matrix B in the pair (A,B). */
+/* On exit, B has been overwritten. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */
+/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */
+/* BETA (output) DOUBLE PRECISION array, dimension (N) */
+/* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */
+/* be the generalized eigenvalues. If ALPHAI(j) is zero, then */
+/* the j-th eigenvalue is real; if positive, then the j-th and */
+/* (j+1)-st eigenvalues are a complex conjugate pair, with */
+/* ALPHAI(j+1) negative. */
+
+/* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */
+/* may easily over- or underflow, and BETA(j) may even be zero. */
+/* Thus, the user should avoid naively computing the ratio */
+/* alpha/beta. However, ALPHAR and ALPHAI will be always less */
+/* than and usually comparable with norm(A) in magnitude, and */
+/* BETA always less than and usually comparable with norm(B). */
+
+/* VL (output) DOUBLE PRECISION array, dimension (LDVL,N) */
+/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
+/* after another in the columns of VL, in the same order as */
+/* their eigenvalues. If the j-th eigenvalue is real, then */
+/* u(j) = VL(:,j), the j-th column of VL. If the j-th and */
+/* (j+1)-th eigenvalues form a complex conjugate pair, then */
+/* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1). */
+/* Each eigenvector is scaled so the largest component has */
+/* abs(real part)+abs(imag. part)=1. */
+/* Not referenced if JOBVL = 'N'. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the matrix VL. LDVL >= 1, and */
+/* if JOBVL = 'V', LDVL >= N. */
+
+/* VR (output) DOUBLE PRECISION array, dimension (LDVR,N) */
+/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
+/* after another in the columns of VR, in the same order as */
+/* their eigenvalues. If the j-th eigenvalue is real, then */
+/* v(j) = VR(:,j), the j-th column of VR. If the j-th and */
+/* (j+1)-th eigenvalues form a complex conjugate pair, then */
+/* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1). */
+/* Each eigenvector is scaled so the largest component has */
+/* abs(real part)+abs(imag. part)=1. */
+/* Not referenced if JOBVR = 'N'. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the matrix VR. LDVR >= 1, and */
+/* if JOBVR = 'V', LDVR >= N. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,8*N). */
+/* For good performance, LWORK must generally be larger. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1,...,N: */
+/* The QZ iteration failed. No eigenvectors have been */
+/* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) */
+/* should be correct for j=INFO+1,...,N. */
+/* > N: =N+1: other than QZ iteration failed in DHGEQZ. */
+/* =N+2: error return from DTGEVC. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+
+ /* Function Body */
+ if (lsame_(jobvl, "N")) {
+ ijobvl = 1;
+ ilvl = FALSE_;
+ } else if (lsame_(jobvl, "V")) {
+ ijobvl = 2;
+ ilvl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvl = FALSE_;
+ }
+
+ if (lsame_(jobvr, "N")) {
+ ijobvr = 1;
+ ilvr = FALSE_;
+ } else if (lsame_(jobvr, "V")) {
+ ijobvr = 2;
+ ilvr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvr = FALSE_;
+ }
+ ilv = ilvl || ilvr;
+
+/* Test the input arguments */
+
+ *info = 0;
+ lquery = *lwork == -1;
+ if (ijobvl <= 0) {
+ *info = -1;
+ } else if (ijobvr <= 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvl < 1 || ilvl && *ldvl < *n) {
+ *info = -12;
+ } else if (*ldvr < 1 || ilvr && *ldvr < *n) {
+ *info = -14;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. The workspace is */
+/* computed assuming ILO = 1 and IHI = N, the worst case.) */
+
+ if (*info == 0) {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n << 3;
+ minwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * (ilaenv_(&c__1, "DGEQRF", " ", n, &c__1, n, &
+ c__0) + 7);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * (ilaenv_(&c__1, "DORMQR", " ", n, &c__1, n,
+ &c__0) + 7);
+ maxwrk = max(i__1,i__2);
+ if (ilvl) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * (ilaenv_(&c__1, "DORGQR", " ", n, &
+ c__1, n, &c_n1) + 7);
+ maxwrk = max(i__1,i__2);
+ }
+ work[1] = (doublereal) maxwrk;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -16;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGGEV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1. / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]);
+ ilascl = FALSE_;
+ if (anrm > 0. && anrm < smlnum) {
+ anrmto = smlnum;
+ ilascl = TRUE_;
+ } else if (anrm > bignum) {
+ anrmto = bignum;
+ ilascl = TRUE_;
+ }
+ if (ilascl) {
+ dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]);
+ ilbscl = FALSE_;
+ if (bnrm > 0. && bnrm < smlnum) {
+ bnrmto = smlnum;
+ ilbscl = TRUE_;
+ } else if (bnrm > bignum) {
+ bnrmto = bignum;
+ ilbscl = TRUE_;
+ }
+ if (ilbscl) {
+ dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
+ ierr);
+ }
+
+/* Permute the matrices A, B to isolate eigenvalues if possible */
+/* (Workspace: need 6*N) */
+
+ ileft = 1;
+ iright = *n + 1;
+ iwrk = iright + *n;
+ dggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[
+ ileft], &work[iright], &work[iwrk], &ierr);
+
+/* Reduce B to triangular form (QR decomposition of B) */
+/* (Workspace: need N, prefer N*NB) */
+
+ irows = ihi + 1 - ilo;
+ if (ilv) {
+ icols = *n + 1 - ilo;
+ } else {
+ icols = irows;
+ }
+ itau = iwrk;
+ iwrk = itau + irows;
+ i__1 = *lwork + 1 - iwrk;
+ dgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
+ iwrk], &i__1, &ierr);
+
+/* Apply the orthogonal transformation to matrix A */
+/* (Workspace: need N, prefer N*NB) */
+
+ i__1 = *lwork + 1 - iwrk;
+ dormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
+ work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, &
+ ierr);
+
+/* Initialize VL */
+/* (Workspace: need N, prefer N*NB) */
+
+ if (ilvl) {
+ dlaset_("Full", n, n, &c_b36, &c_b37, &vl[vl_offset], ldvl)
+ ;
+ if (irows > 1) {
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ dlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vl[
+ ilo + 1 + ilo * vl_dim1], ldvl);
+ }
+ i__1 = *lwork + 1 - iwrk;
+ dorgqr_(&irows, &irows, &irows, &vl[ilo + ilo * vl_dim1], ldvl, &work[
+ itau], &work[iwrk], &i__1, &ierr);
+ }
+
+/* Initialize VR */
+
+ if (ilvr) {
+ dlaset_("Full", n, n, &c_b36, &c_b37, &vr[vr_offset], ldvr)
+ ;
+ }
+
+/* Reduce to generalized Hessenberg form */
+/* (Workspace: none needed) */
+
+ if (ilv) {
+
+/* Eigenvectors requested -- work on whole matrix. */
+
+ dgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr);
+ } else {
+ dgghrd_("N", "N", &irows, &c__1, &irows, &a[ilo + ilo * a_dim1], lda,
+ &b[ilo + ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[
+ vr_offset], ldvr, &ierr);
+ }
+
+/* Perform QZ algorithm (Compute eigenvalues, and optionally, the */
+/* Schur forms and Schur vectors) */
+/* (Workspace: need N) */
+
+ iwrk = itau;
+ if (ilv) {
+ *(unsigned char *)chtemp = 'S';
+ } else {
+ *(unsigned char *)chtemp = 'E';
+ }
+ i__1 = *lwork + 1 - iwrk;
+ dhgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[
+ b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset],
+ ldvl, &vr[vr_offset], ldvr, &work[iwrk], &i__1, &ierr);
+ if (ierr != 0) {
+ if (ierr > 0 && ierr <= *n) {
+ *info = ierr;
+ } else if (ierr > *n && ierr <= *n << 1) {
+ *info = ierr - *n;
+ } else {
+ *info = *n + 1;
+ }
+ goto L110;
+ }
+
+/* Compute Eigenvectors */
+/* (Workspace: need 6*N) */
+
+ if (ilv) {
+ if (ilvl) {
+ if (ilvr) {
+ *(unsigned char *)chtemp = 'B';
+ } else {
+ *(unsigned char *)chtemp = 'L';
+ }
+ } else {
+ *(unsigned char *)chtemp = 'R';
+ }
+ dtgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb,
+ &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[
+ iwrk], &ierr);
+ if (ierr != 0) {
+ *info = *n + 2;
+ goto L110;
+ }
+
+/* Undo balancing on VL and VR and normalization */
+/* (Workspace: none needed) */
+
+ if (ilvl) {
+ dggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &
+ vl[vl_offset], ldvl, &ierr);
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ if (alphai[jc] < 0.) {
+ goto L50;
+ }
+ temp = 0.;
+ if (alphai[jc] == 0.) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ d__2 = temp, d__3 = (d__1 = vl[jr + jc * vl_dim1],
+ abs(d__1));
+ temp = max(d__2,d__3);
+/* L10: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ d__3 = temp, d__4 = (d__1 = vl[jr + jc * vl_dim1],
+ abs(d__1)) + (d__2 = vl[jr + (jc + 1) *
+ vl_dim1], abs(d__2));
+ temp = max(d__3,d__4);
+/* L20: */
+ }
+ }
+ if (temp < smlnum) {
+ goto L50;
+ }
+ temp = 1. / temp;
+ if (alphai[jc] == 0.) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vl[jr + jc * vl_dim1] *= temp;
+/* L30: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vl[jr + jc * vl_dim1] *= temp;
+ vl[jr + (jc + 1) * vl_dim1] *= temp;
+/* L40: */
+ }
+ }
+L50:
+ ;
+ }
+ }
+ if (ilvr) {
+ dggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &
+ vr[vr_offset], ldvr, &ierr);
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ if (alphai[jc] < 0.) {
+ goto L100;
+ }
+ temp = 0.;
+ if (alphai[jc] == 0.) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ d__2 = temp, d__3 = (d__1 = vr[jr + jc * vr_dim1],
+ abs(d__1));
+ temp = max(d__2,d__3);
+/* L60: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ d__3 = temp, d__4 = (d__1 = vr[jr + jc * vr_dim1],
+ abs(d__1)) + (d__2 = vr[jr + (jc + 1) *
+ vr_dim1], abs(d__2));
+ temp = max(d__3,d__4);
+/* L70: */
+ }
+ }
+ if (temp < smlnum) {
+ goto L100;
+ }
+ temp = 1. / temp;
+ if (alphai[jc] == 0.) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vr[jr + jc * vr_dim1] *= temp;
+/* L80: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vr[jr + jc * vr_dim1] *= temp;
+ vr[jr + (jc + 1) * vr_dim1] *= temp;
+/* L90: */
+ }
+ }
+L100:
+ ;
+ }
+ }
+
+/* End of eigenvector calculation */
+
+ }
+
+/* Undo scaling if necessary */
+
+ if (ilascl) {
+ dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, &
+ ierr);
+ dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, &
+ ierr);
+ }
+
+ if (ilbscl) {
+ dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
+ ierr);
+ }
+
+L110:
+
+ work[1] = (doublereal) maxwrk;
+
+ return 0;
+
+/* End of DGGEV */
+
+} /* dggev_ */
diff --git a/SRC/dggevx.c b/SRC/dggevx.c
new file mode 100644
index 0000000..50bb670
--- /dev/null
+++ b/SRC/dggevx.c
@@ -0,0 +1,885 @@
+/* dggevx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static doublereal c_b59 = 0.;
+static doublereal c_b60 = 1.;
+
+/* Subroutine */ int dggevx_(char *balanc, char *jobvl, char *jobvr, char *
+ sense, integer *n, doublereal *a, integer *lda, doublereal *b,
+ integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *
+ beta, doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr,
+ integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale,
+ doublereal *abnrm, doublereal *bbnrm, doublereal *rconde, doublereal *
+ rcondv, doublereal *work, integer *lwork, integer *iwork, logical *
+ bwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
+ vr_offset, i__1, i__2;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, m, jc, in, mm, jr;
+ doublereal eps;
+ logical ilv, pair;
+ doublereal anrm, bnrm;
+ integer ierr, itau;
+ doublereal temp;
+ logical ilvl, ilvr;
+ integer iwrk, iwrk1;
+ extern logical lsame_(char *, char *);
+ integer icols;
+ logical noscl;
+ integer irows;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), dggbak_(
+ char *, char *, integer *, integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dggbal_(char *, integer *, doublereal *, integer
+ *, doublereal *, integer *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dgghrd_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dlascl_(char *, integer *, integer *, doublereal
+ *, doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *);
+ logical ilascl, ilbscl;
+ extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *),
+ dlacpy_(char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *), dlaset_(char *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *);
+ logical ldumma[1];
+ char chtemp[1];
+ doublereal bignum;
+ extern /* Subroutine */ int dhgeqz_(char *, char *, char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *), dtgevc_(char *, char *,
+ logical *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *, doublereal *, integer *);
+ integer ijobvl;
+ extern /* Subroutine */ int dtgsna_(char *, char *, logical *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, integer *, integer *, integer
+ *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ijobvr;
+ logical wantsb;
+ extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+ doublereal anrmto;
+ logical wantse;
+ doublereal bnrmto;
+ extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ integer minwrk, maxwrk;
+ logical wantsn;
+ doublereal smlnum;
+ logical lquery, wantsv;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B) */
+/* the generalized eigenvalues, and optionally, the left and/or right */
+/* generalized eigenvectors. */
+
+/* Optionally also, it computes a balancing transformation to improve */
+/* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */
+/* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for */
+/* the eigenvalues (RCONDE), and reciprocal condition numbers for the */
+/* right eigenvectors (RCONDV). */
+
+/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar */
+/* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is */
+/* singular. It is usually represented as the pair (alpha,beta), as */
+/* there is a reasonable interpretation for beta=0, and even for both */
+/* being zero. */
+
+/* The right eigenvector v(j) corresponding to the eigenvalue lambda(j) */
+/* of (A,B) satisfies */
+
+/* A * v(j) = lambda(j) * B * v(j) . */
+
+/* The left eigenvector u(j) corresponding to the eigenvalue lambda(j) */
+/* of (A,B) satisfies */
+
+/* u(j)**H * A = lambda(j) * u(j)**H * B. */
+
+/* where u(j)**H is the conjugate-transpose of u(j). */
+
+
+/* Arguments */
+/* ========= */
+
+/* BALANC (input) CHARACTER*1 */
+/* Specifies the balance option to be performed. */
+/* = 'N': do not diagonally scale or permute; */
+/* = 'P': permute only; */
+/* = 'S': scale only; */
+/* = 'B': both permute and scale. */
+/* Computed reciprocal condition numbers will be for the */
+/* matrices after permuting and/or balancing. Permuting does */
+/* not change condition numbers (in exact arithmetic), but */
+/* balancing does. */
+
+/* JOBVL (input) CHARACTER*1 */
+/* = 'N': do not compute the left generalized eigenvectors; */
+/* = 'V': compute the left generalized eigenvectors. */
+
+/* JOBVR (input) CHARACTER*1 */
+/* = 'N': do not compute the right generalized eigenvectors; */
+/* = 'V': compute the right generalized eigenvectors. */
+
+/* SENSE (input) CHARACTER*1 */
+/* Determines which reciprocal condition numbers are computed. */
+/* = 'N': none are computed; */
+/* = 'E': computed for eigenvalues only; */
+/* = 'V': computed for eigenvectors only; */
+/* = 'B': computed for eigenvalues and eigenvectors. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VL, and VR. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
+/* On entry, the matrix A in the pair (A,B). */
+/* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V' */
+/* or both, then A contains the first part of the real Schur */
+/* form of the "balanced" versions of the input A and B. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */
+/* On entry, the matrix B in the pair (A,B). */
+/* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V' */
+/* or both, then B contains the second part of the real Schur */
+/* form of the "balanced" versions of the input A and B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */
+/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */
+/* BETA (output) DOUBLE PRECISION array, dimension (N) */
+/* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */
+/* be the generalized eigenvalues. If ALPHAI(j) is zero, then */
+/* the j-th eigenvalue is real; if positive, then the j-th and */
+/* (j+1)-st eigenvalues are a complex conjugate pair, with */
+/* ALPHAI(j+1) negative. */
+
+/* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */
+/* may easily over- or underflow, and BETA(j) may even be zero. */
+/* Thus, the user should avoid naively computing the ratio */
+/* ALPHA/BETA. However, ALPHAR and ALPHAI will be always less */
+/* than and usually comparable with norm(A) in magnitude, and */
+/* BETA always less than and usually comparable with norm(B). */
+
+/* VL (output) DOUBLE PRECISION array, dimension (LDVL,N) */
+/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
+/* after another in the columns of VL, in the same order as */
+/* their eigenvalues. If the j-th eigenvalue is real, then */
+/* u(j) = VL(:,j), the j-th column of VL. If the j-th and */
+/* (j+1)-th eigenvalues form a complex conjugate pair, then */
+/* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1). */
+/* Each eigenvector will be scaled so the largest component have */
+/* abs(real part) + abs(imag. part) = 1. */
+/* Not referenced if JOBVL = 'N'. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the matrix VL. LDVL >= 1, and */
+/* if JOBVL = 'V', LDVL >= N. */
+
+/* VR (output) DOUBLE PRECISION array, dimension (LDVR,N) */
+/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
+/* after another in the columns of VR, in the same order as */
+/* their eigenvalues. If the j-th eigenvalue is real, then */
+/* v(j) = VR(:,j), the j-th column of VR. If the j-th and */
+/* (j+1)-th eigenvalues form a complex conjugate pair, then */
+/* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1). */
+/* Each eigenvector will be scaled so the largest component have */
+/* abs(real part) + abs(imag. part) = 1. */
+/* Not referenced if JOBVR = 'N'. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the matrix VR. LDVR >= 1, and */
+/* if JOBVR = 'V', LDVR >= N. */
+
+/* ILO (output) INTEGER */
+/* IHI (output) INTEGER */
+/* ILO and IHI are integer values such that on exit */
+/* A(i,j) = 0 and B(i,j) = 0 if i > j and */
+/* j = 1,...,ILO-1 or i = IHI+1,...,N. */
+/* If BALANC = 'N' or 'S', ILO = 1 and IHI = N. */
+
+/* LSCALE (output) DOUBLE PRECISION array, dimension (N) */
+/* Details of the permutations and scaling factors applied */
+/* to the left side of A and B. If PL(j) is the index of the */
+/* row interchanged with row j, and DL(j) is the scaling */
+/* factor applied to row j, then */
+/* LSCALE(j) = PL(j) for j = 1,...,ILO-1 */
+/* = DL(j) for j = ILO,...,IHI */
+/* = PL(j) for j = IHI+1,...,N. */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* RSCALE (output) DOUBLE PRECISION array, dimension (N) */
+/* Details of the permutations and scaling factors applied */
+/* to the right side of A and B. If PR(j) is the index of the */
+/* column interchanged with column j, and DR(j) is the scaling */
+/* factor applied to column j, then */
+/* RSCALE(j) = PR(j) for j = 1,...,ILO-1 */
+/* = DR(j) for j = ILO,...,IHI */
+/* = PR(j) for j = IHI+1,...,N */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* ABNRM (output) DOUBLE PRECISION */
+/* The one-norm of the balanced matrix A. */
+
+/* BBNRM (output) DOUBLE PRECISION */
+/* The one-norm of the balanced matrix B. */
+
+/* RCONDE (output) DOUBLE PRECISION array, dimension (N) */
+/* If SENSE = 'E' or 'B', the reciprocal condition numbers of */
+/* the eigenvalues, stored in consecutive elements of the array. */
+/* For a complex conjugate pair of eigenvalues two consecutive */
+/* elements of RCONDE are set to the same value. Thus RCONDE(j), */
+/* RCONDV(j), and the j-th columns of VL and VR all correspond */
+/* to the j-th eigenpair. */
+/* If SENSE = 'N or 'V', RCONDE is not referenced. */
+
+/* RCONDV (output) DOUBLE PRECISION array, dimension (N) */
+/* If SENSE = 'V' or 'B', the estimated reciprocal condition */
+/* numbers of the eigenvectors, stored in consecutive elements */
+/* of the array. For a complex eigenvector two consecutive */
+/* elements of RCONDV are set to the same value. If the */
+/* eigenvalues cannot be reordered to compute RCONDV(j), */
+/* RCONDV(j) is set to 0; this can only occur when the true */
+/* value would be very small anyway. */
+/* If SENSE = 'N' or 'E', RCONDV is not referenced. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,2*N). */
+/* If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V', */
+/* LWORK >= max(1,6*N). */
+/* If SENSE = 'E' or 'B', LWORK >= max(1,10*N). */
+/* If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16. */
+
+/* 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. */
+
+/* IWORK (workspace) INTEGER array, dimension (N+6) */
+/* If SENSE = 'E', IWORK is not referenced. */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+/* If SENSE = 'N', BWORK is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1,...,N: */
+/* The QZ iteration failed. No eigenvectors have been */
+/* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) */
+/* should be correct for j=INFO+1,...,N. */
+/* > N: =N+1: other than QZ iteration failed in DHGEQZ. */
+/* =N+2: error return from DTGEVC. */
+
+/* Further Details */
+/* =============== */
+
+/* Balancing a matrix pair (A,B) includes, first, permuting rows and */
+/* columns to isolate eigenvalues, second, applying diagonal similarity */
+/* transformation to the rows and columns to make the rows and columns */
+/* as close in norm as possible. The computed reciprocal condition */
+/* numbers correspond to the balanced matrix. Permuting rows and columns */
+/* will not change the condition numbers (in exact arithmetic) but */
+/* diagonal scaling will. For further explanation of balancing, see */
+/* section 4.11.1.2 of LAPACK Users' Guide. */
+
+/* An approximate error bound on the chordal distance between the i-th */
+/* computed generalized eigenvalue w and the corresponding exact */
+/* eigenvalue lambda is */
+
+/* chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I) */
+
+/* An approximate error bound for the angle between the i-th computed */
+/* eigenvector VL(i) or VR(i) is given by */
+
+/* EPS * norm(ABNRM, BBNRM) / DIF(i). */
+
+/* For further explanation of the reciprocal condition numbers RCONDE */
+/* and RCONDV, see section 4.11 of LAPACK User's Guide. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --lscale;
+ --rscale;
+ --rconde;
+ --rcondv;
+ --work;
+ --iwork;
+ --bwork;
+
+ /* Function Body */
+ if (lsame_(jobvl, "N")) {
+ ijobvl = 1;
+ ilvl = FALSE_;
+ } else if (lsame_(jobvl, "V")) {
+ ijobvl = 2;
+ ilvl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvl = FALSE_;
+ }
+
+ if (lsame_(jobvr, "N")) {
+ ijobvr = 1;
+ ilvr = FALSE_;
+ } else if (lsame_(jobvr, "V")) {
+ ijobvr = 2;
+ ilvr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvr = FALSE_;
+ }
+ ilv = ilvl || ilvr;
+
+ noscl = lsame_(balanc, "N") || lsame_(balanc, "P");
+ wantsn = lsame_(sense, "N");
+ wantse = lsame_(sense, "E");
+ wantsv = lsame_(sense, "V");
+ wantsb = lsame_(sense, "B");
+
+/* Test the input arguments */
+
+ *info = 0;
+ lquery = *lwork == -1;
+ if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P")
+ || lsame_(balanc, "B"))) {
+ *info = -1;
+ } else if (ijobvl <= 0) {
+ *info = -2;
+ } else if (ijobvr <= 0) {
+ *info = -3;
+ } else if (! (wantsn || wantse || wantsb || wantsv)) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldvl < 1 || ilvl && *ldvl < *n) {
+ *info = -14;
+ } else if (*ldvr < 1 || ilvr && *ldvr < *n) {
+ *info = -16;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. The workspace is */
+/* computed assuming ILO = 1 and IHI = N, the worst case.) */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ } else {
+ if (noscl && ! ilv) {
+ minwrk = *n << 1;
+ } else {
+ minwrk = *n * 6;
+ }
+ if (wantse || wantsb) {
+ minwrk = *n * 10;
+ }
+ if (wantsv || wantsb) {
+/* Computing MAX */
+ i__1 = minwrk, i__2 = (*n << 1) * (*n + 4) + 16;
+ minwrk = max(i__1,i__2);
+ }
+ maxwrk = minwrk;
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", n, &
+ c__1, n, &c__0);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DORMQR", " ", n, &
+ c__1, n, &c__0);
+ maxwrk = max(i__1,i__2);
+ if (ilvl) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DORGQR",
+ " ", n, &c__1, n, &c__0);
+ maxwrk = max(i__1,i__2);
+ }
+ }
+ work[1] = (doublereal) maxwrk;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -26;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGGEVX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1. / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = dlange_("M", n, n, &a[a_offset], lda, &work[1]);
+ ilascl = FALSE_;
+ if (anrm > 0. && anrm < smlnum) {
+ anrmto = smlnum;
+ ilascl = TRUE_;
+ } else if (anrm > bignum) {
+ anrmto = bignum;
+ ilascl = TRUE_;
+ }
+ if (ilascl) {
+ dlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = dlange_("M", n, n, &b[b_offset], ldb, &work[1]);
+ ilbscl = FALSE_;
+ if (bnrm > 0. && bnrm < smlnum) {
+ bnrmto = smlnum;
+ ilbscl = TRUE_;
+ } else if (bnrm > bignum) {
+ bnrmto = bignum;
+ ilbscl = TRUE_;
+ }
+ if (ilbscl) {
+ dlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
+ ierr);
+ }
+
+/* Permute and/or balance the matrix pair (A,B) */
+/* (Workspace: need 6*N if BALANC = 'S' or 'B', 1 otherwise) */
+
+ dggbal_(balanc, n, &a[a_offset], lda, &b[b_offset], ldb, ilo, ihi, &
+ lscale[1], &rscale[1], &work[1], &ierr);
+
+/* Compute ABNRM and BBNRM */
+
+ *abnrm = dlange_("1", n, n, &a[a_offset], lda, &work[1]);
+ if (ilascl) {
+ work[1] = *abnrm;
+ dlascl_("G", &c__0, &c__0, &anrmto, &anrm, &c__1, &c__1, &work[1], &
+ c__1, &ierr);
+ *abnrm = work[1];
+ }
+
+ *bbnrm = dlange_("1", n, n, &b[b_offset], ldb, &work[1]);
+ if (ilbscl) {
+ work[1] = *bbnrm;
+ dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, &c__1, &c__1, &work[1], &
+ c__1, &ierr);
+ *bbnrm = work[1];
+ }
+
+/* Reduce B to triangular form (QR decomposition of B) */
+/* (Workspace: need N, prefer N*NB ) */
+
+ irows = *ihi + 1 - *ilo;
+ if (ilv || ! wantsn) {
+ icols = *n + 1 - *ilo;
+ } else {
+ icols = irows;
+ }
+ itau = 1;
+ iwrk = itau + irows;
+ i__1 = *lwork + 1 - iwrk;
+ dgeqrf_(&irows, &icols, &b[*ilo + *ilo * b_dim1], ldb, &work[itau], &work[
+ iwrk], &i__1, &ierr);
+
+/* Apply the orthogonal transformation to A */
+/* (Workspace: need N, prefer N*NB) */
+
+ i__1 = *lwork + 1 - iwrk;
+ dormqr_("L", "T", &irows, &icols, &irows, &b[*ilo + *ilo * b_dim1], ldb, &
+ work[itau], &a[*ilo + *ilo * a_dim1], lda, &work[iwrk], &i__1, &
+ ierr);
+
+/* Initialize VL and/or VR */
+/* (Workspace: need N, prefer N*NB) */
+
+ if (ilvl) {
+ dlaset_("Full", n, n, &c_b59, &c_b60, &vl[vl_offset], ldvl)
+ ;
+ if (irows > 1) {
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ dlacpy_("L", &i__1, &i__2, &b[*ilo + 1 + *ilo * b_dim1], ldb, &vl[
+ *ilo + 1 + *ilo * vl_dim1], ldvl);
+ }
+ i__1 = *lwork + 1 - iwrk;
+ dorgqr_(&irows, &irows, &irows, &vl[*ilo + *ilo * vl_dim1], ldvl, &
+ work[itau], &work[iwrk], &i__1, &ierr);
+ }
+
+ if (ilvr) {
+ dlaset_("Full", n, n, &c_b59, &c_b60, &vr[vr_offset], ldvr)
+ ;
+ }
+
+/* Reduce to generalized Hessenberg form */
+/* (Workspace: none needed) */
+
+ if (ilv || ! wantsn) {
+
+/* Eigenvectors requested -- work on whole matrix. */
+
+ dgghrd_(jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr);
+ } else {
+ dgghrd_("N", "N", &irows, &c__1, &irows, &a[*ilo + *ilo * a_dim1],
+ lda, &b[*ilo + *ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[
+ vr_offset], ldvr, &ierr);
+ }
+
+/* Perform QZ algorithm (Compute eigenvalues, and optionally, the */
+/* Schur forms and Schur vectors) */
+/* (Workspace: need N) */
+
+ if (ilv || ! wantsn) {
+ *(unsigned char *)chtemp = 'S';
+ } else {
+ *(unsigned char *)chtemp = 'E';
+ }
+
+ dhgeqz_(chtemp, jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset]
+, ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset], ldvl, &
+ vr[vr_offset], ldvr, &work[1], lwork, &ierr);
+ if (ierr != 0) {
+ if (ierr > 0 && ierr <= *n) {
+ *info = ierr;
+ } else if (ierr > *n && ierr <= *n << 1) {
+ *info = ierr - *n;
+ } else {
+ *info = *n + 1;
+ }
+ goto L130;
+ }
+
+/* Compute Eigenvectors and estimate condition numbers if desired */
+/* (Workspace: DTGEVC: need 6*N */
+/* DTGSNA: need 2*N*(N+2)+16 if SENSE = 'V' or 'B', */
+/* need N otherwise ) */
+
+ if (ilv || ! wantsn) {
+ if (ilv) {
+ if (ilvl) {
+ if (ilvr) {
+ *(unsigned char *)chtemp = 'B';
+ } else {
+ *(unsigned char *)chtemp = 'L';
+ }
+ } else {
+ *(unsigned char *)chtemp = 'R';
+ }
+
+ dtgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset],
+ ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &
+ work[1], &ierr);
+ if (ierr != 0) {
+ *info = *n + 2;
+ goto L130;
+ }
+ }
+
+ if (! wantsn) {
+
+/* compute eigenvectors (DTGEVC) and estimate condition */
+/* numbers (DTGSNA). Note that the definition of the condition */
+/* number is not invariant under transformation (u,v) to */
+/* (Q*u, Z*v), where (u,v) are eigenvectors of the generalized */
+/* Schur form (S,T), Q and Z are orthogonal matrices. In order */
+/* to avoid using extra 2*N*N workspace, we have to recalculate */
+/* eigenvectors and estimate one condition numbers at a time. */
+
+ pair = FALSE_;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+ if (pair) {
+ pair = FALSE_;
+ goto L20;
+ }
+ mm = 1;
+ if (i__ < *n) {
+ if (a[i__ + 1 + i__ * a_dim1] != 0.) {
+ pair = TRUE_;
+ mm = 2;
+ }
+ }
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ bwork[j] = FALSE_;
+/* L10: */
+ }
+ if (mm == 1) {
+ bwork[i__] = TRUE_;
+ } else if (mm == 2) {
+ bwork[i__] = TRUE_;
+ bwork[i__ + 1] = TRUE_;
+ }
+
+ iwrk = mm * *n + 1;
+ iwrk1 = iwrk + mm * *n;
+
+/* Compute a pair of left and right eigenvectors. */
+/* (compute workspace: need up to 4*N + 6*N) */
+
+ if (wantse || wantsb) {
+ dtgevc_("B", "S", &bwork[1], n, &a[a_offset], lda, &b[
+ b_offset], ldb, &work[1], n, &work[iwrk], n, &mm,
+ &m, &work[iwrk1], &ierr);
+ if (ierr != 0) {
+ *info = *n + 2;
+ goto L130;
+ }
+ }
+
+ i__2 = *lwork - iwrk1 + 1;
+ dtgsna_(sense, "S", &bwork[1], n, &a[a_offset], lda, &b[
+ b_offset], ldb, &work[1], n, &work[iwrk], n, &rconde[
+ i__], &rcondv[i__], &mm, &m, &work[iwrk1], &i__2, &
+ iwork[1], &ierr);
+
+L20:
+ ;
+ }
+ }
+ }
+
+/* Undo balancing on VL and VR and normalization */
+/* (Workspace: none needed) */
+
+ if (ilvl) {
+ dggbak_(balanc, "L", n, ilo, ihi, &lscale[1], &rscale[1], n, &vl[
+ vl_offset], ldvl, &ierr);
+
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ if (alphai[jc] < 0.) {
+ goto L70;
+ }
+ temp = 0.;
+ if (alphai[jc] == 0.) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ d__2 = temp, d__3 = (d__1 = vl[jr + jc * vl_dim1], abs(
+ d__1));
+ temp = max(d__2,d__3);
+/* L30: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ d__3 = temp, d__4 = (d__1 = vl[jr + jc * vl_dim1], abs(
+ d__1)) + (d__2 = vl[jr + (jc + 1) * vl_dim1], abs(
+ d__2));
+ temp = max(d__3,d__4);
+/* L40: */
+ }
+ }
+ if (temp < smlnum) {
+ goto L70;
+ }
+ temp = 1. / temp;
+ if (alphai[jc] == 0.) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vl[jr + jc * vl_dim1] *= temp;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vl[jr + jc * vl_dim1] *= temp;
+ vl[jr + (jc + 1) * vl_dim1] *= temp;
+/* L60: */
+ }
+ }
+L70:
+ ;
+ }
+ }
+ if (ilvr) {
+ dggbak_(balanc, "R", n, ilo, ihi, &lscale[1], &rscale[1], n, &vr[
+ vr_offset], ldvr, &ierr);
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ if (alphai[jc] < 0.) {
+ goto L120;
+ }
+ temp = 0.;
+ if (alphai[jc] == 0.) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ d__2 = temp, d__3 = (d__1 = vr[jr + jc * vr_dim1], abs(
+ d__1));
+ temp = max(d__2,d__3);
+/* L80: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ d__3 = temp, d__4 = (d__1 = vr[jr + jc * vr_dim1], abs(
+ d__1)) + (d__2 = vr[jr + (jc + 1) * vr_dim1], abs(
+ d__2));
+ temp = max(d__3,d__4);
+/* L90: */
+ }
+ }
+ if (temp < smlnum) {
+ goto L120;
+ }
+ temp = 1. / temp;
+ if (alphai[jc] == 0.) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vr[jr + jc * vr_dim1] *= temp;
+/* L100: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vr[jr + jc * vr_dim1] *= temp;
+ vr[jr + (jc + 1) * vr_dim1] *= temp;
+/* L110: */
+ }
+ }
+L120:
+ ;
+ }
+ }
+
+/* Undo scaling if necessary */
+
+ if (ilascl) {
+ dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, &
+ ierr);
+ dlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, &
+ ierr);
+ }
+
+ if (ilbscl) {
+ dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
+ ierr);
+ }
+
+L130:
+ work[1] = (doublereal) maxwrk;
+
+ return 0;
+
+/* End of DGGEVX */
+
+} /* dggevx_ */
diff --git a/SRC/dggglm.c b/SRC/dggglm.c
new file mode 100644
index 0000000..378885e
--- /dev/null
+++ b/SRC/dggglm.c
@@ -0,0 +1,331 @@
+/* dggglm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b32 = -1.;
+static doublereal c_b34 = 1.;
+
+/* Subroutine */ int dggglm_(integer *n, integer *m, integer *p, doublereal *
+ a, integer *lda, doublereal *b, integer *ldb, doublereal *d__,
+ doublereal *x, doublereal *y, doublereal *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, nb, np, nb1, nb2, nb3, nb4, lopt;
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dcopy_(integer *,
+ doublereal *, integer *, doublereal *, integer *), dggqrf_(
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer lwkmin;
+ extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *),
+ dormrq_(char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int dtrtrs_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGGGLM solves a general Gauss-Markov linear model (GLM) problem: */
+
+/* minimize || y ||_2 subject to d = A*x + B*y */
+/* x */
+
+/* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a */
+/* given N-vector. It is assumed that M <= N <= M+P, and */
+
+/* rank(A) = M and rank( A B ) = N. */
+
+/* Under these assumptions, the constrained equation is always */
+/* consistent, and there is a unique solution x and a minimal 2-norm */
+/* solution y, which is obtained using a generalized QR factorization */
+/* of the matrices (A, B) given by */
+
+/* A = Q*(R), B = Q*T*Z. */
+/* (0) */
+
+/* In particular, if matrix B is square nonsingular, then the problem */
+/* GLM is equivalent to the following weighted linear least squares */
+/* problem */
+
+/* minimize || inv(B)*(d-A*x) ||_2 */
+/* x */
+
+/* where inv(B) denotes the inverse of B. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices A and B. N >= 0. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix A. 0 <= M <= N. */
+
+/* P (input) INTEGER */
+/* The number of columns of the matrix B. P >= N-M. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,M) */
+/* On entry, the N-by-M matrix A. */
+/* On exit, the upper triangular part of the array A contains */
+/* the M-by-M upper triangular matrix R. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,P) */
+/* On entry, the N-by-P matrix B. */
+/* On exit, if N <= P, the upper triangle of the subarray */
+/* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T; */
+/* if N > P, the elements on and above the (N-P)th subdiagonal */
+/* contain the N-by-P upper trapezoidal matrix T. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, D is the left hand side of the GLM equation. */
+/* On exit, D is destroyed. */
+
+/* X (output) DOUBLE PRECISION array, dimension (M) */
+/* Y (output) DOUBLE PRECISION array, dimension (P) */
+/* On exit, X and Y are the solutions of the GLM problem. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N+M+P). */
+/* For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB, */
+/* where NB is an upper bound for the optimal blocksizes for */
+/* DGEQRF, SGERQF, DORMQR and SORMRQ. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1: the upper triangular factor R associated with A in the */
+/* generalized QR factorization of the pair (A, B) is */
+/* singular, so that rank(A) < M; the least squares */
+/* solution could not be computed. */
+/* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal */
+/* factor T associated with B in the generalized QR */
+/* factorization of the pair (A, B) is singular, so that */
+/* rank( A B ) < N; the least squares solution could not */
+/* be computed. */
+
+/* =================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --d__;
+ --x;
+ --y;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ np = min(*n,*p);
+ lquery = *lwork == -1;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*m < 0 || *m > *n) {
+ *info = -2;
+ } else if (*p < 0 || *p < *n - *m) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+
+/* Calculate workspace */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ lwkmin = 1;
+ lwkopt = 1;
+ } else {
+ nb1 = ilaenv_(&c__1, "DGEQRF", " ", n, m, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "DGERQF", " ", n, m, &c_n1, &c_n1);
+ nb3 = ilaenv_(&c__1, "DORMQR", " ", n, m, p, &c_n1);
+ nb4 = ilaenv_(&c__1, "DORMRQ", " ", n, m, p, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2), i__1 = max(i__1,nb3);
+ nb = max(i__1,nb4);
+ lwkmin = *m + *n + *p;
+ lwkopt = *m + np + max(*n,*p) * nb;
+ }
+ work[1] = (doublereal) lwkopt;
+
+ if (*lwork < lwkmin && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGGGLM", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Compute the GQR factorization of matrices A and B: */
+
+/* Q'*A = ( R11 ) M, Q'*B*Z' = ( T11 T12 ) M */
+/* ( 0 ) N-M ( 0 T22 ) N-M */
+/* M M+P-N N-M */
+
+/* where R11 and T22 are upper triangular, and Q and Z are */
+/* orthogonal. */
+
+ i__1 = *lwork - *m - np;
+ dggqrf_(n, m, p, &a[a_offset], lda, &work[1], &b[b_offset], ldb, &work[*m
+ + 1], &work[*m + np + 1], &i__1, info);
+ lopt = (integer) work[*m + np + 1];
+
+/* Update left-hand-side vector d = Q'*d = ( d1 ) M */
+/* ( d2 ) N-M */
+
+ i__1 = max(1,*n);
+ i__2 = *lwork - *m - np;
+ dormqr_("Left", "Transpose", n, &c__1, m, &a[a_offset], lda, &work[1], &
+ d__[1], &i__1, &work[*m + np + 1], &i__2, info);
+/* Computing MAX */
+ i__1 = lopt, i__2 = (integer) work[*m + np + 1];
+ lopt = max(i__1,i__2);
+
+/* Solve T22*y2 = d2 for y2 */
+
+ if (*n > *m) {
+ i__1 = *n - *m;
+ i__2 = *n - *m;
+ dtrtrs_("Upper", "No transpose", "Non unit", &i__1, &c__1, &b[*m + 1
+ + (*m + *p - *n + 1) * b_dim1], ldb, &d__[*m + 1], &i__2,
+ info);
+
+ if (*info > 0) {
+ *info = 1;
+ return 0;
+ }
+
+ i__1 = *n - *m;
+ dcopy_(&i__1, &d__[*m + 1], &c__1, &y[*m + *p - *n + 1], &c__1);
+ }
+
+/* Set y1 = 0 */
+
+ i__1 = *m + *p - *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[i__] = 0.;
+/* L10: */
+ }
+
+/* Update d1 = d1 - T12*y2 */
+
+ i__1 = *n - *m;
+ dgemv_("No transpose", m, &i__1, &c_b32, &b[(*m + *p - *n + 1) * b_dim1 +
+ 1], ldb, &y[*m + *p - *n + 1], &c__1, &c_b34, &d__[1], &c__1);
+
+/* Solve triangular system: R11*x = d1 */
+
+ if (*m > 0) {
+ dtrtrs_("Upper", "No Transpose", "Non unit", m, &c__1, &a[a_offset],
+ lda, &d__[1], m, info);
+
+ if (*info > 0) {
+ *info = 2;
+ return 0;
+ }
+
+/* Copy D to X */
+
+ dcopy_(m, &d__[1], &c__1, &x[1], &c__1);
+ }
+
+/* Backward transformation y = Z'*y */
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *n - *p + 1;
+ i__3 = max(1,*p);
+ i__4 = *lwork - *m - np;
+ dormrq_("Left", "Transpose", p, &c__1, &np, &b[max(i__1, i__2)+ b_dim1],
+ ldb, &work[*m + 1], &y[1], &i__3, &work[*m + np + 1], &i__4, info);
+/* Computing MAX */
+ i__1 = lopt, i__2 = (integer) work[*m + np + 1];
+ work[1] = (doublereal) (*m + np + max(i__1,i__2));
+
+ return 0;
+
+/* End of DGGGLM */
+
+} /* dggglm_ */
diff --git a/SRC/dgghrd.c b/SRC/dgghrd.c
new file mode 100644
index 0000000..2d73bfa
--- /dev/null
+++ b/SRC/dgghrd.c
@@ -0,0 +1,329 @@
+/* dgghrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b10 = 0.;
+static doublereal c_b11 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dgghrd_(char *compq, char *compz, integer *n, integer *
+ ilo, integer *ihi, doublereal *a, integer *lda, doublereal *b,
+ integer *ldb, doublereal *q, integer *ldq, doublereal *z__, integer *
+ ldz, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
+ z_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ doublereal c__, s;
+ logical ilq, ilz;
+ integer jcol;
+ doublereal temp;
+ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ integer jrow;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ dlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *), xerbla_(char *, integer *);
+ integer icompq, icompz;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGGHRD reduces a pair of real matrices (A,B) to generalized upper */
+/* Hessenberg form using orthogonal transformations, where A is a */
+/* general matrix and B is upper triangular. The form of the */
+/* generalized eigenvalue problem is */
+/* A*x = lambda*B*x, */
+/* and B is typically made upper triangular by computing its QR */
+/* factorization and moving the orthogonal matrix Q to the left side */
+/* of the equation. */
+
+/* This subroutine simultaneously reduces A to a Hessenberg matrix H: */
+/* Q**T*A*Z = H */
+/* and transforms B to another upper triangular matrix T: */
+/* Q**T*B*Z = T */
+/* in order to reduce the problem to its standard form */
+/* H*y = lambda*T*y */
+/* where y = Z**T*x. */
+
+/* The orthogonal matrices Q and Z are determined as products of Givens */
+/* rotations. They may either be formed explicitly, or they may be */
+/* postmultiplied into input matrices Q1 and Z1, so that */
+
+/* Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T */
+
+/* Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T */
+
+/* If Q1 is the orthogonal matrix from the QR factorization of B in the */
+/* original equation A*x = lambda*B*x, then DGGHRD reduces the original */
+/* problem to generalized Hessenberg form. */
+
+/* Arguments */
+/* ========= */
+
+/* COMPQ (input) CHARACTER*1 */
+/* = 'N': do not compute Q; */
+/* = 'I': Q is initialized to the unit matrix, and the */
+/* orthogonal matrix Q is returned; */
+/* = 'V': Q must contain an orthogonal matrix Q1 on entry, */
+/* and the product Q1*Q is returned. */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': do not compute Z; */
+/* = 'I': Z is initialized to the unit matrix, and the */
+/* orthogonal matrix Z is returned; */
+/* = 'V': Z must contain an orthogonal matrix Z1 on entry, */
+/* and the product Z1*Z is returned. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* ILO and IHI mark the rows and columns of A which are to be */
+/* reduced. It is assumed that A is already upper triangular */
+/* in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are */
+/* normally set by a previous call to SGGBAL; otherwise they */
+/* should be set to 1 and N respectively. */
+/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
+/* On entry, the N-by-N general matrix to be reduced. */
+/* On exit, the upper triangle and the first subdiagonal of A */
+/* are overwritten with the upper Hessenberg matrix H, and the */
+/* rest is set to zero. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */
+/* On entry, the N-by-N upper triangular matrix B. */
+/* On exit, the upper triangular matrix T = Q**T B Z. The */
+/* elements below the diagonal are set to zero. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) */
+/* On entry, if COMPQ = 'V', the orthogonal matrix Q1, */
+/* typically from the QR factorization of B. */
+/* On exit, if COMPQ='I', the orthogonal matrix Q, and if */
+/* COMPQ = 'V', the product Q1*Q. */
+/* Not referenced if COMPQ='N'. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. */
+/* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. */
+
+/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) */
+/* On entry, if COMPZ = 'V', the orthogonal matrix Z1. */
+/* On exit, if COMPZ='I', the orthogonal matrix Z, and if */
+/* COMPZ = 'V', the product Z1*Z. */
+/* Not referenced if COMPZ='N'. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. */
+/* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* This routine reduces A to Hessenberg and B to triangular form by */
+/* an unblocked reduction, as described in _Matrix_Computations_, */
+/* by Golub and Van Loan (Johns Hopkins Press.) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode COMPQ */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+
+ /* Function Body */
+ if (lsame_(compq, "N")) {
+ ilq = FALSE_;
+ icompq = 1;
+ } else if (lsame_(compq, "V")) {
+ ilq = TRUE_;
+ icompq = 2;
+ } else if (lsame_(compq, "I")) {
+ ilq = TRUE_;
+ icompq = 3;
+ } else {
+ icompq = 0;
+ }
+
+/* Decode COMPZ */
+
+ if (lsame_(compz, "N")) {
+ ilz = FALSE_;
+ icompz = 1;
+ } else if (lsame_(compz, "V")) {
+ ilz = TRUE_;
+ icompz = 2;
+ } else if (lsame_(compz, "I")) {
+ ilz = TRUE_;
+ icompz = 3;
+ } else {
+ icompz = 0;
+ }
+
+/* Test the input parameters. */
+
+ *info = 0;
+ if (icompq <= 0) {
+ *info = -1;
+ } else if (icompz <= 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ilo < 1) {
+ *info = -4;
+ } else if (*ihi > *n || *ihi < *ilo - 1) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (ilq && *ldq < *n || *ldq < 1) {
+ *info = -11;
+ } else if (ilz && *ldz < *n || *ldz < 1) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGGHRD", &i__1);
+ return 0;
+ }
+
+/* Initialize Q and Z if desired. */
+
+ if (icompq == 3) {
+ dlaset_("Full", n, n, &c_b10, &c_b11, &q[q_offset], ldq);
+ }
+ if (icompz == 3) {
+ dlaset_("Full", n, n, &c_b10, &c_b11, &z__[z_offset], ldz);
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 1) {
+ return 0;
+ }
+
+/* Zero out lower triangle of B */
+
+ i__1 = *n - 1;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ i__2 = *n;
+ for (jrow = jcol + 1; jrow <= i__2; ++jrow) {
+ b[jrow + jcol * b_dim1] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Reduce A and B */
+
+ i__1 = *ihi - 2;
+ for (jcol = *ilo; jcol <= i__1; ++jcol) {
+
+ i__2 = jcol + 2;
+ for (jrow = *ihi; jrow >= i__2; --jrow) {
+
+/* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL) */
+
+ temp = a[jrow - 1 + jcol * a_dim1];
+ dlartg_(&temp, &a[jrow + jcol * a_dim1], &c__, &s, &a[jrow - 1 +
+ jcol * a_dim1]);
+ a[jrow + jcol * a_dim1] = 0.;
+ i__3 = *n - jcol;
+ drot_(&i__3, &a[jrow - 1 + (jcol + 1) * a_dim1], lda, &a[jrow + (
+ jcol + 1) * a_dim1], lda, &c__, &s);
+ i__3 = *n + 2 - jrow;
+ drot_(&i__3, &b[jrow - 1 + (jrow - 1) * b_dim1], ldb, &b[jrow + (
+ jrow - 1) * b_dim1], ldb, &c__, &s);
+ if (ilq) {
+ drot_(n, &q[(jrow - 1) * q_dim1 + 1], &c__1, &q[jrow * q_dim1
+ + 1], &c__1, &c__, &s);
+ }
+
+/* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1) */
+
+ temp = b[jrow + jrow * b_dim1];
+ dlartg_(&temp, &b[jrow + (jrow - 1) * b_dim1], &c__, &s, &b[jrow
+ + jrow * b_dim1]);
+ b[jrow + (jrow - 1) * b_dim1] = 0.;
+ drot_(ihi, &a[jrow * a_dim1 + 1], &c__1, &a[(jrow - 1) * a_dim1 +
+ 1], &c__1, &c__, &s);
+ i__3 = jrow - 1;
+ drot_(&i__3, &b[jrow * b_dim1 + 1], &c__1, &b[(jrow - 1) * b_dim1
+ + 1], &c__1, &c__, &s);
+ if (ilz) {
+ drot_(n, &z__[jrow * z_dim1 + 1], &c__1, &z__[(jrow - 1) *
+ z_dim1 + 1], &c__1, &c__, &s);
+ }
+/* L30: */
+ }
+/* L40: */
+ }
+
+ return 0;
+
+/* End of DGGHRD */
+
+} /* dgghrd_ */
diff --git a/SRC/dgglse.c b/SRC/dgglse.c
new file mode 100644
index 0000000..4a02183
--- /dev/null
+++ b/SRC/dgglse.c
@@ -0,0 +1,340 @@
+/* dgglse.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b31 = -1.;
+static doublereal c_b33 = 1.;
+
+/* Subroutine */ int dgglse_(integer *m, integer *n, integer *p, doublereal *
+ a, integer *lda, doublereal *b, integer *ldb, doublereal *c__,
+ doublereal *d__, doublereal *x, doublereal *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+
+ /* Local variables */
+ integer nb, mn, nr, nb1, nb2, nb3, nb4, lopt;
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dcopy_(integer *,
+ doublereal *, integer *, doublereal *, integer *), daxpy_(integer
+ *, doublereal *, doublereal *, integer *, doublereal *, integer *)
+ , dtrmv_(char *, char *, char *, integer *, doublereal *, integer
+ *, doublereal *, integer *), dggrqf_(
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer lwkmin;
+ extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *),
+ dormrq_(char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int dtrtrs_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGGLSE solves the linear equality-constrained least squares (LSE) */
+/* problem: */
+
+/* minimize || c - A*x ||_2 subject to B*x = d */
+
+/* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given */
+/* M-vector, and d is a given P-vector. It is assumed that */
+/* P <= N <= M+P, and */
+
+/* rank(B) = P and rank( (A) ) = N. */
+/* ( (B) ) */
+
+/* These conditions ensure that the LSE problem has a unique solution, */
+/* which is obtained using a generalized RQ factorization of the */
+/* matrices (B, A) given by */
+
+/* B = (0 R)*Q, A = Z*T*Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. 0 <= P <= N <= M+P. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(M,N)-by-N upper trapezoidal matrix T. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix B. */
+/* On exit, the upper triangle of the subarray B(1:P,N-P+1:N) */
+/* contains the P-by-P upper triangular matrix R. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,P). */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (M) */
+/* On entry, C contains the right hand side vector for the */
+/* least squares part of the LSE problem. */
+/* On exit, the residual sum of squares for the solution */
+/* is given by the sum of squares of elements N-P+1 to M of */
+/* vector C. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (P) */
+/* On entry, D contains the right hand side vector for the */
+/* constrained equation. */
+/* On exit, D is destroyed. */
+
+/* X (output) DOUBLE PRECISION array, dimension (N) */
+/* On exit, X is the solution of the LSE problem. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M+N+P). */
+/* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB, */
+/* where NB is an upper bound for the optimal blocksizes for */
+/* DGEQRF, SGERQF, DORMQR and SORMRQ. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1: the upper triangular factor R associated with B in the */
+/* generalized RQ factorization of the pair (B, A) is */
+/* singular, so that rank(B) < P; the least squares */
+/* solution could not be computed. */
+/* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor */
+/* T associated with A in the generalized RQ factorization */
+/* of the pair (B, A) is singular, so that */
+/* rank( (A) ) < N; the least squares solution could not */
+/* ( (B) ) */
+/* be computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --c__;
+ --d__;
+ --x;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ mn = min(*m,*n);
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*p < 0 || *p > *n || *p < *n - *m) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*p)) {
+ *info = -7;
+ }
+
+/* Calculate workspace */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ lwkmin = 1;
+ lwkopt = 1;
+ } else {
+ nb1 = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1);
+ nb3 = ilaenv_(&c__1, "DORMQR", " ", m, n, p, &c_n1);
+ nb4 = ilaenv_(&c__1, "DORMRQ", " ", m, n, p, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2), i__1 = max(i__1,nb3);
+ nb = max(i__1,nb4);
+ lwkmin = *m + *n + *p;
+ lwkopt = *p + mn + max(*m,*n) * nb;
+ }
+ work[1] = (doublereal) lwkopt;
+
+ if (*lwork < lwkmin && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGGLSE", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Compute the GRQ factorization of matrices B and A: */
+
+/* B*Q' = ( 0 T12 ) P Z'*A*Q' = ( R11 R12 ) N-P */
+/* N-P P ( 0 R22 ) M+P-N */
+/* N-P P */
+
+/* where T12 and R11 are upper triangular, and Q and Z are */
+/* orthogonal. */
+
+ i__1 = *lwork - *p - mn;
+ dggrqf_(p, m, n, &b[b_offset], ldb, &work[1], &a[a_offset], lda, &work[*p
+ + 1], &work[*p + mn + 1], &i__1, info);
+ lopt = (integer) work[*p + mn + 1];
+
+/* Update c = Z'*c = ( c1 ) N-P */
+/* ( c2 ) M+P-N */
+
+ i__1 = max(1,*m);
+ i__2 = *lwork - *p - mn;
+ dormqr_("Left", "Transpose", m, &c__1, &mn, &a[a_offset], lda, &work[*p +
+ 1], &c__[1], &i__1, &work[*p + mn + 1], &i__2, info);
+/* Computing MAX */
+ i__1 = lopt, i__2 = (integer) work[*p + mn + 1];
+ lopt = max(i__1,i__2);
+
+/* Solve T12*x2 = d for x2 */
+
+ if (*p > 0) {
+ dtrtrs_("Upper", "No transpose", "Non-unit", p, &c__1, &b[(*n - *p +
+ 1) * b_dim1 + 1], ldb, &d__[1], p, info);
+
+ if (*info > 0) {
+ *info = 1;
+ return 0;
+ }
+
+/* Put the solution in X */
+
+ dcopy_(p, &d__[1], &c__1, &x[*n - *p + 1], &c__1);
+
+/* Update c1 */
+
+ i__1 = *n - *p;
+ dgemv_("No transpose", &i__1, p, &c_b31, &a[(*n - *p + 1) * a_dim1 +
+ 1], lda, &d__[1], &c__1, &c_b33, &c__[1], &c__1);
+ }
+
+/* Solve R11*x1 = c1 for x1 */
+
+ if (*n > *p) {
+ i__1 = *n - *p;
+ i__2 = *n - *p;
+ dtrtrs_("Upper", "No transpose", "Non-unit", &i__1, &c__1, &a[
+ a_offset], lda, &c__[1], &i__2, info);
+
+ if (*info > 0) {
+ *info = 2;
+ return 0;
+ }
+
+/* Put the solutions in X */
+
+ i__1 = *n - *p;
+ dcopy_(&i__1, &c__[1], &c__1, &x[1], &c__1);
+ }
+
+/* Compute the residual vector: */
+
+ if (*m < *n) {
+ nr = *m + *p - *n;
+ if (nr > 0) {
+ i__1 = *n - *m;
+ dgemv_("No transpose", &nr, &i__1, &c_b31, &a[*n - *p + 1 + (*m +
+ 1) * a_dim1], lda, &d__[nr + 1], &c__1, &c_b33, &c__[*n -
+ *p + 1], &c__1);
+ }
+ } else {
+ nr = *p;
+ }
+ if (nr > 0) {
+ dtrmv_("Upper", "No transpose", "Non unit", &nr, &a[*n - *p + 1 + (*n
+ - *p + 1) * a_dim1], lda, &d__[1], &c__1);
+ daxpy_(&nr, &c_b31, &d__[1], &c__1, &c__[*n - *p + 1], &c__1);
+ }
+
+/* Backward transformation x = Q'*x */
+
+ i__1 = *lwork - *p - mn;
+ dormrq_("Left", "Transpose", n, &c__1, p, &b[b_offset], ldb, &work[1], &x[
+ 1], n, &work[*p + mn + 1], &i__1, info);
+/* Computing MAX */
+ i__1 = lopt, i__2 = (integer) work[*p + mn + 1];
+ work[1] = (doublereal) (*p + mn + max(i__1,i__2));
+
+ return 0;
+
+/* End of DGGLSE */
+
+} /* dgglse_ */
diff --git a/SRC/dggqrf.c b/SRC/dggqrf.c
new file mode 100644
index 0000000..b75d005
--- /dev/null
+++ b/SRC/dggqrf.c
@@ -0,0 +1,267 @@
+/* dggqrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dggqrf_(integer *n, integer *m, integer *p, doublereal *
+ a, integer *lda, doublereal *taua, doublereal *b, integer *ldb,
+ doublereal *taub, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+
+ /* Local variables */
+ integer nb, nb1, nb2, nb3, lopt;
+ extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *),
+ dgerqf_(integer *, integer *, doublereal *, integer *, doublereal
+ *, doublereal *, integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGGQRF computes a generalized QR factorization of an N-by-M matrix A */
+/* and an N-by-P matrix B: */
+
+/* A = Q*R, B = Q*T*Z, */
+
+/* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal */
+/* matrix, and R and T assume one of the forms: */
+
+/* if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N, */
+/* ( 0 ) N-M N M-N */
+/* M */
+
+/* where R11 is upper triangular, and */
+
+/* if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P, */
+/* P-N N ( T21 ) P */
+/* P */
+
+/* where T12 or T21 is upper triangular. */
+
+/* In particular, if B is square and nonsingular, the GQR factorization */
+/* of A and B implicitly gives the QR factorization of inv(B)*A: */
+
+/* inv(B)*A = Z'*(inv(T)*R) */
+
+/* where inv(B) denotes the inverse of the matrix B, and Z' denotes the */
+/* transpose of the matrix Z. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices A and B. N >= 0. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of columns of the matrix B. P >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,M) */
+/* On entry, the N-by-M matrix A. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(N,M)-by-M upper trapezoidal matrix R (R is */
+/* upper triangular if N >= M); the elements below the diagonal, */
+/* with the array TAUA, represent the orthogonal matrix Q as a */
+/* product of min(N,M) elementary reflectors (see Further */
+/* Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAUA (output) DOUBLE PRECISION array, dimension (min(N,M)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the orthogonal matrix Q (see Further Details). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,P) */
+/* On entry, the N-by-P matrix B. */
+/* On exit, if N <= P, the upper triangle of the subarray */
+/* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T; */
+/* if N > P, the elements on and above the (N-P)-th subdiagonal */
+/* contain the N-by-P upper trapezoidal matrix T; the remaining */
+/* elements, with the array TAUB, represent the orthogonal */
+/* matrix Z as a product of elementary reflectors (see Further */
+/* Details). */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* TAUB (output) DOUBLE PRECISION array, dimension (min(N,P)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the orthogonal matrix Z (see Further Details). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N,M,P). */
+/* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3), */
+/* where NB1 is the optimal blocksize for the QR factorization */
+/* of an N-by-M matrix, NB2 is the optimal blocksize for the */
+/* RQ factorization of an N-by-P matrix, and NB3 is the optimal */
+/* blocksize for a call of DORMQR. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(n,m). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - taua * v * v' */
+
+/* where taua is a real scalar, and v is a real vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */
+/* and taua in TAUA(i). */
+/* To form Q explicitly, use LAPACK subroutine DORGQR. */
+/* To use Q to update another matrix, use LAPACK subroutine DORMQR. */
+
+/* The matrix Z is represented as a product of elementary reflectors */
+
+/* Z = H(1) H(2) . . . H(k), where k = min(n,p). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - taub * v * v' */
+
+/* where taub is a real scalar, and v is a real vector with */
+/* v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in */
+/* B(n-k+i,1:p-k+i-1), and taub in TAUB(i). */
+/* To form Z explicitly, use LAPACK subroutine DORGRQ. */
+/* To use Z to update another matrix, use LAPACK subroutine DORMRQ. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --taua;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --taub;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb1 = ilaenv_(&c__1, "DGEQRF", " ", n, m, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "DGERQF", " ", n, p, &c_n1, &c_n1);
+ nb3 = ilaenv_(&c__1, "DORMQR", " ", n, m, p, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2);
+ nb = max(i__1,nb3);
+/* Computing MAX */
+ i__1 = max(*n,*m);
+ lwkopt = max(i__1,*p) * nb;
+ work[1] = (doublereal) lwkopt;
+ lquery = *lwork == -1;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*p < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*n), i__1 = max(i__1,*m);
+ if (*lwork < max(i__1,*p) && ! lquery) {
+ *info = -11;
+ }
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGGQRF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* QR factorization of N-by-M matrix A: A = Q*R */
+
+ dgeqrf_(n, m, &a[a_offset], lda, &taua[1], &work[1], lwork, info);
+ lopt = (integer) work[1];
+
+/* Update B := Q'*B. */
+
+ i__1 = min(*n,*m);
+ dormqr_("Left", "Transpose", n, p, &i__1, &a[a_offset], lda, &taua[1], &b[
+ b_offset], ldb, &work[1], lwork, info);
+/* Computing MAX */
+ i__1 = lopt, i__2 = (integer) work[1];
+ lopt = max(i__1,i__2);
+
+/* RQ factorization of N-by-P matrix B: B = T*Z. */
+
+ dgerqf_(n, p, &b[b_offset], ldb, &taub[1], &work[1], lwork, info);
+/* Computing MAX */
+ i__1 = lopt, i__2 = (integer) work[1];
+ work[1] = (doublereal) max(i__1,i__2);
+
+ return 0;
+
+/* End of DGGQRF */
+
+} /* dggqrf_ */
diff --git a/SRC/dggrqf.c b/SRC/dggrqf.c
new file mode 100644
index 0000000..1a49ec9
--- /dev/null
+++ b/SRC/dggrqf.c
@@ -0,0 +1,268 @@
+/* dggrqf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dggrqf_(integer *m, integer *p, integer *n, doublereal *
+ a, integer *lda, doublereal *taua, doublereal *b, integer *ldb,
+ doublereal *taub, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer nb, nb1, nb2, nb3, lopt;
+ extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *),
+ dgerqf_(integer *, integer *, doublereal *, integer *, doublereal
+ *, doublereal *, integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dormrq_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGGRQF computes a generalized RQ factorization of an M-by-N matrix A */
+/* and a P-by-N matrix B: */
+
+/* A = R*Q, B = Z*T*Q, */
+
+/* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal */
+/* matrix, and R and T assume one of the forms: */
+
+/* if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N, */
+/* N-M M ( R21 ) N */
+/* N */
+
+/* where R12 or R21 is upper triangular, and */
+
+/* if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P, */
+/* ( 0 ) P-N P N-P */
+/* N */
+
+/* where T11 is upper triangular. */
+
+/* In particular, if B is square and nonsingular, the GRQ factorization */
+/* of A and B implicitly gives the RQ factorization of A*inv(B): */
+
+/* A*inv(B) = (R*inv(T))*Z' */
+
+/* where inv(B) denotes the inverse of the matrix B, and Z' denotes the */
+/* transpose of the matrix Z. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, if M <= N, the upper triangle of the subarray */
+/* A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R; */
+/* if M > N, the elements on and above the (M-N)-th subdiagonal */
+/* contain the M-by-N upper trapezoidal matrix R; the remaining */
+/* elements, with the array TAUA, represent the orthogonal */
+/* matrix Q as a product of elementary reflectors (see Further */
+/* Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAUA (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the orthogonal matrix Q (see Further Details). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix B. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(P,N)-by-N upper trapezoidal matrix T (T is */
+/* upper triangular if P >= N); the elements below the diagonal, */
+/* with the array TAUB, represent the orthogonal matrix Z as a */
+/* product of elementary reflectors (see Further Details). */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,P). */
+
+/* TAUB (output) DOUBLE PRECISION array, dimension (min(P,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the orthogonal matrix Z (see Further Details). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N,M,P). */
+/* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3), */
+/* where NB1 is the optimal blocksize for the RQ factorization */
+/* of an M-by-N matrix, NB2 is the optimal blocksize for the */
+/* QR factorization of a P-by-N matrix, and NB3 is the optimal */
+/* blocksize for a call of DORMRQ. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INF0= -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - taua * v * v' */
+
+/* where taua is a real scalar, and v is a real vector with */
+/* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in */
+/* A(m-k+i,1:n-k+i-1), and taua in TAUA(i). */
+/* To form Q explicitly, use LAPACK subroutine DORGRQ. */
+/* To use Q to update another matrix, use LAPACK subroutine DORMRQ. */
+
+/* The matrix Z is represented as a product of elementary reflectors */
+
+/* Z = H(1) H(2) . . . H(k), where k = min(p,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - taub * v * v' */
+
+/* where taub is a real scalar, and v is a real vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i), */
+/* and taub in TAUB(i). */
+/* To form Z explicitly, use LAPACK subroutine DORGQR. */
+/* To use Z to update another matrix, use LAPACK subroutine DORMQR. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --taua;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --taub;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb1 = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "DGEQRF", " ", p, n, &c_n1, &c_n1);
+ nb3 = ilaenv_(&c__1, "DORMRQ", " ", m, n, p, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2);
+ nb = max(i__1,nb3);
+/* Computing MAX */
+ i__1 = max(*n,*m);
+ lwkopt = max(i__1,*p) * nb;
+ work[1] = (doublereal) lwkopt;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*p < 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*p)) {
+ *info = -8;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*m), i__1 = max(i__1,*p);
+ if (*lwork < max(i__1,*n) && ! lquery) {
+ *info = -11;
+ }
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGGRQF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* RQ factorization of M-by-N matrix A: A = R*Q */
+
+ dgerqf_(m, n, &a[a_offset], lda, &taua[1], &work[1], lwork, info);
+ lopt = (integer) work[1];
+
+/* Update B := B*Q' */
+
+ i__1 = min(*m,*n);
+/* Computing MAX */
+ i__2 = 1, i__3 = *m - *n + 1;
+ dormrq_("Right", "Transpose", p, n, &i__1, &a[max(i__2, i__3)+ a_dim1],
+ lda, &taua[1], &b[b_offset], ldb, &work[1], lwork, info);
+/* Computing MAX */
+ i__1 = lopt, i__2 = (integer) work[1];
+ lopt = max(i__1,i__2);
+
+/* QR factorization of P-by-N matrix B: B = Z*T */
+
+ dgeqrf_(p, n, &b[b_offset], ldb, &taub[1], &work[1], lwork, info);
+/* Computing MAX */
+ i__1 = lopt, i__2 = (integer) work[1];
+ work[1] = (doublereal) max(i__1,i__2);
+
+ return 0;
+
+/* End of DGGRQF */
+
+} /* dggrqf_ */
diff --git a/SRC/dggsvd.c b/SRC/dggsvd.c
new file mode 100644
index 0000000..b9b567e
--- /dev/null
+++ b/SRC/dggsvd.c
@@ -0,0 +1,405 @@
+/* dggsvd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dggsvd_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *n, integer *p, integer *k, integer *l, doublereal *a,
+ integer *lda, doublereal *b, integer *ldb, doublereal *alpha,
+ doublereal *beta, doublereal *u, integer *ldu, doublereal *v, integer
+ *ldv, doublereal *q, integer *ldq, doublereal *work, integer *iwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1,
+ u_offset, v_dim1, v_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal ulp;
+ integer ibnd;
+ doublereal tola;
+ integer isub;
+ doublereal tolb, unfl, temp, smax;
+ extern logical lsame_(char *, char *);
+ doublereal anorm, bnorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical wantq, wantu, wantv;
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dtgsja_(char *, char *, char *, integer *,
+ integer *, integer *, integer *, integer *, doublereal *, integer
+ *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *);
+ integer ncycle;
+ extern /* Subroutine */ int xerbla_(char *, integer *), dggsvp_(
+ char *, char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ doublereal *, doublereal *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGGSVD computes the generalized singular value decomposition (GSVD) */
+/* of an M-by-N real matrix A and P-by-N real matrix B: */
+
+/* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ) */
+
+/* where U, V and Q are orthogonal matrices, and Z' is the transpose */
+/* of Z. Let K+L = the effective numerical rank of the matrix (A',B')', */
+/* then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and */
+/* D2 are M-by-(K+L) and P-by-(K+L) "diagonal" matrices and of the */
+/* following structures, respectively: */
+
+/* If M-K-L >= 0, */
+
+/* K L */
+/* D1 = K ( I 0 ) */
+/* L ( 0 C ) */
+/* M-K-L ( 0 0 ) */
+
+/* K L */
+/* D2 = L ( 0 S ) */
+/* P-L ( 0 0 ) */
+
+/* N-K-L K L */
+/* ( 0 R ) = K ( 0 R11 R12 ) */
+/* L ( 0 0 R22 ) */
+
+/* where */
+
+/* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */
+/* S = diag( BETA(K+1), ... , BETA(K+L) ), */
+/* C**2 + S**2 = I. */
+
+/* R is stored in A(1:K+L,N-K-L+1:N) on exit. */
+
+/* If M-K-L < 0, */
+
+/* K M-K K+L-M */
+/* D1 = K ( I 0 0 ) */
+/* M-K ( 0 C 0 ) */
+
+/* K M-K K+L-M */
+/* D2 = M-K ( 0 S 0 ) */
+/* K+L-M ( 0 0 I ) */
+/* P-L ( 0 0 0 ) */
+
+/* N-K-L K M-K K+L-M */
+/* ( 0 R ) = K ( 0 R11 R12 R13 ) */
+/* M-K ( 0 0 R22 R23 ) */
+/* K+L-M ( 0 0 0 R33 ) */
+
+/* where */
+
+/* C = diag( ALPHA(K+1), ... , ALPHA(M) ), */
+/* S = diag( BETA(K+1), ... , BETA(M) ), */
+/* C**2 + S**2 = I. */
+
+/* (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored */
+/* ( 0 R22 R23 ) */
+/* in B(M-K+1:L,N+M-K-L+1:N) on exit. */
+
+/* The routine computes C, S, R, and optionally the orthogonal */
+/* transformation matrices U, V and Q. */
+
+/* In particular, if B is an N-by-N nonsingular matrix, then the GSVD of */
+/* A and B implicitly gives the SVD of A*inv(B): */
+/* A*inv(B) = U*(D1*inv(D2))*V'. */
+/* If ( A',B')' has orthonormal columns, then the GSVD of A and B is */
+/* also equal to the CS decomposition of A and B. Furthermore, the GSVD */
+/* can be used to derive the solution of the eigenvalue problem: */
+/* A'*A x = lambda* B'*B x. */
+/* In some literature, the GSVD of A and B is presented in the form */
+/* U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 ) */
+/* where U and V are orthogonal and X is nonsingular, D1 and D2 are */
+/* ``diagonal''. The former GSVD form can be converted to the latter */
+/* form by taking the nonsingular matrix X as */
+
+/* X = Q*( I 0 ) */
+/* ( 0 inv(R) ). */
+
+/* Arguments */
+/* ========= */
+
+/* JOBU (input) CHARACTER*1 */
+/* = 'U': Orthogonal matrix U is computed; */
+/* = 'N': U is not computed. */
+
+/* JOBV (input) CHARACTER*1 */
+/* = 'V': Orthogonal matrix V is computed; */
+/* = 'N': V is not computed. */
+
+/* JOBQ (input) CHARACTER*1 */
+/* = 'Q': Orthogonal matrix Q is computed; */
+/* = 'N': Q is not computed. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* K (output) INTEGER */
+/* L (output) INTEGER */
+/* On exit, K and L specify the dimension of the subblocks */
+/* described in the Purpose section. */
+/* K + L = effective numerical rank of (A',B')'. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A contains the triangular matrix R, or part of R. */
+/* See Purpose for details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix B. */
+/* On exit, B contains the triangular matrix R if M-K-L < 0. */
+/* See Purpose for details. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,P). */
+
+/* ALPHA (output) DOUBLE PRECISION array, dimension (N) */
+/* BETA (output) DOUBLE PRECISION array, dimension (N) */
+/* On exit, ALPHA and BETA contain the generalized singular */
+/* value pairs of A and B; */
+/* ALPHA(1:K) = 1, */
+/* BETA(1:K) = 0, */
+/* and if M-K-L >= 0, */
+/* ALPHA(K+1:K+L) = C, */
+/* BETA(K+1:K+L) = S, */
+/* or if M-K-L < 0, */
+/* ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0 */
+/* BETA(K+1:M) =S, BETA(M+1:K+L) =1 */
+/* and */
+/* ALPHA(K+L+1:N) = 0 */
+/* BETA(K+L+1:N) = 0 */
+
+/* U (output) DOUBLE PRECISION array, dimension (LDU,M) */
+/* If JOBU = 'U', U contains the M-by-M orthogonal matrix U. */
+/* If JOBU = 'N', U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M) if */
+/* JOBU = 'U'; LDU >= 1 otherwise. */
+
+/* V (output) DOUBLE PRECISION array, dimension (LDV,P) */
+/* If JOBV = 'V', V contains the P-by-P orthogonal matrix V. */
+/* If JOBV = 'N', V is not referenced. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. LDV >= max(1,P) if */
+/* JOBV = 'V'; LDV >= 1 otherwise. */
+
+/* Q (output) DOUBLE PRECISION array, dimension (LDQ,N) */
+/* If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q. */
+/* If JOBQ = 'N', Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N) if */
+/* JOBQ = 'Q'; LDQ >= 1 otherwise. */
+
+/* WORK (workspace) DOUBLE PRECISION array, */
+/* dimension (max(3*N,M,P)+N) */
+
+/* IWORK (workspace/output) INTEGER array, dimension (N) */
+/* On exit, IWORK stores the sorting information. More */
+/* precisely, the following loop will sort ALPHA */
+/* for I = K+1, min(M,K+L) */
+/* swap ALPHA(I) and ALPHA(IWORK(I)) */
+/* endfor */
+/* such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, the Jacobi-type procedure failed to */
+/* converge. For further details, see subroutine DTGSJA. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* TOLA DOUBLE PRECISION */
+/* TOLB DOUBLE PRECISION */
+/* TOLA and TOLB are the thresholds to determine the effective */
+/* rank of (A',B')'. Generally, they are set to */
+/* TOLA = MAX(M,N)*norm(A)*MAZHEPS, */
+/* TOLB = MAX(P,N)*norm(B)*MAZHEPS. */
+/* The size of TOLA and TOLB may affect the size of backward */
+/* errors of the decomposition. */
+
+/* Further Details */
+/* =============== */
+
+/* 2-96 Based on modifications by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alpha;
+ --beta;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantu = lsame_(jobu, "U");
+ wantv = lsame_(jobv, "V");
+ wantq = lsame_(jobq, "Q");
+
+ *info = 0;
+ if (! (wantu || lsame_(jobu, "N"))) {
+ *info = -1;
+ } else if (! (wantv || lsame_(jobv, "N"))) {
+ *info = -2;
+ } else if (! (wantq || lsame_(jobq, "N"))) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*p < 0) {
+ *info = -6;
+ } else if (*lda < max(1,*m)) {
+ *info = -10;
+ } else if (*ldb < max(1,*p)) {
+ *info = -12;
+ } else if (*ldu < 1 || wantu && *ldu < *m) {
+ *info = -16;
+ } else if (*ldv < 1 || wantv && *ldv < *p) {
+ *info = -18;
+ } else if (*ldq < 1 || wantq && *ldq < *n) {
+ *info = -20;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGGSVD", &i__1);
+ return 0;
+ }
+
+/* Compute the Frobenius norm of matrices A and B */
+
+ anorm = dlange_("1", m, n, &a[a_offset], lda, &work[1]);
+ bnorm = dlange_("1", p, n, &b[b_offset], ldb, &work[1]);
+
+/* Get machine precision and set up threshold for determining */
+/* the effective numerical rank of the matrices A and B. */
+
+ ulp = dlamch_("Precision");
+ unfl = dlamch_("Safe Minimum");
+ tola = max(*m,*n) * max(anorm,unfl) * ulp;
+ tolb = max(*p,*n) * max(bnorm,unfl) * ulp;
+
+/* Preprocessing */
+
+ dggsvp_(jobu, jobv, jobq, m, p, n, &a[a_offset], lda, &b[b_offset], ldb, &
+ tola, &tolb, k, l, &u[u_offset], ldu, &v[v_offset], ldv, &q[
+ q_offset], ldq, &iwork[1], &work[1], &work[*n + 1], info);
+
+/* Compute the GSVD of two upper "triangular" matrices */
+
+ dtgsja_(jobu, jobv, jobq, m, p, n, k, l, &a[a_offset], lda, &b[b_offset],
+ ldb, &tola, &tolb, &alpha[1], &beta[1], &u[u_offset], ldu, &v[
+ v_offset], ldv, &q[q_offset], ldq, &work[1], &ncycle, info);
+
+/* Sort the singular values and store the pivot indices in IWORK */
+/* Copy ALPHA to WORK, then sort ALPHA in WORK */
+
+ dcopy_(n, &alpha[1], &c__1, &work[1], &c__1);
+/* Computing MIN */
+ i__1 = *l, i__2 = *m - *k;
+ ibnd = min(i__1,i__2);
+ i__1 = ibnd;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Scan for largest ALPHA(K+I) */
+
+ isub = i__;
+ smax = work[*k + i__];
+ i__2 = ibnd;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ temp = work[*k + j];
+ if (temp > smax) {
+ isub = j;
+ smax = temp;
+ }
+/* L10: */
+ }
+ if (isub != i__) {
+ work[*k + isub] = work[*k + i__];
+ work[*k + i__] = smax;
+ iwork[*k + i__] = *k + isub;
+ } else {
+ iwork[*k + i__] = *k + i__;
+ }
+/* L20: */
+ }
+
+ return 0;
+
+/* End of DGGSVD */
+
+} /* dggsvd_ */
diff --git a/SRC/dggsvp.c b/SRC/dggsvp.c
new file mode 100644
index 0000000..7cf51c2
--- /dev/null
+++ b/SRC/dggsvp.c
@@ -0,0 +1,512 @@
+/* dggsvp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b12 = 0.;
+static doublereal c_b22 = 1.;
+
+/* Subroutine */ int dggsvp_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *p, integer *n, doublereal *a, integer *lda, doublereal *b,
+ integer *ldb, doublereal *tola, doublereal *tolb, integer *k, integer
+ *l, doublereal *u, integer *ldu, doublereal *v, integer *ldv,
+ doublereal *q, integer *ldq, integer *iwork, doublereal *tau,
+ doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1,
+ u_offset, v_dim1, v_offset, i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, j;
+ extern logical lsame_(char *, char *);
+ logical wantq, wantu, wantv;
+ extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *), dgerq2_(
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *), dorg2r_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *),
+ dorm2r_(char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), dormr2_(char *, char *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *), dgeqpf_(integer *, integer *, doublereal *,
+ integer *, integer *, doublereal *, doublereal *, integer *),
+ dlacpy_(char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *), dlaset_(char *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *), dlapmt_(logical *,
+ integer *, integer *, doublereal *, integer *, integer *);
+ logical forwrd;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGGSVP computes orthogonal matrices U, V and Q such that */
+
+/* N-K-L K L */
+/* U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0; */
+/* L ( 0 0 A23 ) */
+/* M-K-L ( 0 0 0 ) */
+
+/* N-K-L K L */
+/* = K ( 0 A12 A13 ) if M-K-L < 0; */
+/* M-K ( 0 0 A23 ) */
+
+/* N-K-L K L */
+/* V'*B*Q = L ( 0 0 B13 ) */
+/* P-L ( 0 0 0 ) */
+
+/* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */
+/* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */
+/* otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective */
+/* numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the */
+/* transpose of Z. */
+
+/* This decomposition is the preprocessing step for computing the */
+/* Generalized Singular Value Decomposition (GSVD), see subroutine */
+/* DGGSVD. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBU (input) CHARACTER*1 */
+/* = 'U': Orthogonal matrix U is computed; */
+/* = 'N': U is not computed. */
+
+/* JOBV (input) CHARACTER*1 */
+/* = 'V': Orthogonal matrix V is computed; */
+/* = 'N': V is not computed. */
+
+/* JOBQ (input) CHARACTER*1 */
+/* = 'Q': Orthogonal matrix Q is computed; */
+/* = 'N': Q is not computed. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A contains the triangular (or trapezoidal) matrix */
+/* described in the Purpose section. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix B. */
+/* On exit, B contains the triangular matrix described in */
+/* the Purpose section. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,P). */
+
+/* TOLA (input) DOUBLE PRECISION */
+/* TOLB (input) DOUBLE PRECISION */
+/* TOLA and TOLB are the thresholds to determine the effective */
+/* numerical rank of matrix B and a subblock of A. Generally, */
+/* they are set to */
+/* TOLA = MAX(M,N)*norm(A)*MAZHEPS, */
+/* TOLB = MAX(P,N)*norm(B)*MAZHEPS. */
+/* The size of TOLA and TOLB may affect the size of backward */
+/* errors of the decomposition. */
+
+/* K (output) INTEGER */
+/* L (output) INTEGER */
+/* On exit, K and L specify the dimension of the subblocks */
+/* described in Purpose. */
+/* K + L = effective numerical rank of (A',B')'. */
+
+/* U (output) DOUBLE PRECISION array, dimension (LDU,M) */
+/* If JOBU = 'U', U contains the orthogonal matrix U. */
+/* If JOBU = 'N', U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M) if */
+/* JOBU = 'U'; LDU >= 1 otherwise. */
+
+/* V (output) DOUBLE PRECISION array, dimension (LDV,P) */
+/* If JOBV = 'V', V contains the orthogonal matrix V. */
+/* If JOBV = 'N', V is not referenced. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. LDV >= max(1,P) if */
+/* JOBV = 'V'; LDV >= 1 otherwise. */
+
+/* Q (output) DOUBLE PRECISION array, dimension (LDQ,N) */
+/* If JOBQ = 'Q', Q contains the orthogonal matrix Q. */
+/* If JOBQ = 'N', Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N) if */
+/* JOBQ = 'Q'; LDQ >= 1 otherwise. */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* TAU (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (max(3*N,M,P)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+
+/* Further Details */
+/* =============== */
+
+/* The subroutine uses LAPACK subroutine DGEQPF for the QR factorization */
+/* with column pivoting to detect the effective numerical rank of the */
+/* a matrix. It may be replaced by a better rank determination strategy. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --iwork;
+ --tau;
+ --work;
+
+ /* Function Body */
+ wantu = lsame_(jobu, "U");
+ wantv = lsame_(jobv, "V");
+ wantq = lsame_(jobq, "Q");
+ forwrd = TRUE_;
+
+ *info = 0;
+ if (! (wantu || lsame_(jobu, "N"))) {
+ *info = -1;
+ } else if (! (wantv || lsame_(jobv, "N"))) {
+ *info = -2;
+ } else if (! (wantq || lsame_(jobq, "N"))) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*p < 0) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (*lda < max(1,*m)) {
+ *info = -8;
+ } else if (*ldb < max(1,*p)) {
+ *info = -10;
+ } else if (*ldu < 1 || wantu && *ldu < *m) {
+ *info = -16;
+ } else if (*ldv < 1 || wantv && *ldv < *p) {
+ *info = -18;
+ } else if (*ldq < 1 || wantq && *ldq < *n) {
+ *info = -20;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGGSVP", &i__1);
+ return 0;
+ }
+
+/* QR with column pivoting of B: B*P = V*( S11 S12 ) */
+/* ( 0 0 ) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ iwork[i__] = 0;
+/* L10: */
+ }
+ dgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], info);
+
+/* Update A := A*P */
+
+ dlapmt_(&forwrd, m, n, &a[a_offset], lda, &iwork[1]);
+
+/* Determine the effective rank of matrix B. */
+
+ *l = 0;
+ i__1 = min(*p,*n);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((d__1 = b[i__ + i__ * b_dim1], abs(d__1)) > *tolb) {
+ ++(*l);
+ }
+/* L20: */
+ }
+
+ if (wantv) {
+
+/* Copy the details of V, and form V. */
+
+ dlaset_("Full", p, p, &c_b12, &c_b12, &v[v_offset], ldv);
+ if (*p > 1) {
+ i__1 = *p - 1;
+ dlacpy_("Lower", &i__1, n, &b[b_dim1 + 2], ldb, &v[v_dim1 + 2],
+ ldv);
+ }
+ i__1 = min(*p,*n);
+ dorg2r_(p, p, &i__1, &v[v_offset], ldv, &tau[1], &work[1], info);
+ }
+
+/* Clean up B */
+
+ i__1 = *l - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *l;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+ if (*p > *l) {
+ i__1 = *p - *l;
+ dlaset_("Full", &i__1, n, &c_b12, &c_b12, &b[*l + 1 + b_dim1], ldb);
+ }
+
+ if (wantq) {
+
+/* Set Q = I and Update Q := Q*P */
+
+ dlaset_("Full", n, n, &c_b12, &c_b22, &q[q_offset], ldq);
+ dlapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]);
+ }
+
+ if (*p >= *l && *n != *l) {
+
+/* RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z */
+
+ dgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info);
+
+/* Update A := A*Z' */
+
+ dormr2_("Right", "Transpose", m, n, l, &b[b_offset], ldb, &tau[1], &a[
+ a_offset], lda, &work[1], info);
+
+ if (wantq) {
+
+/* Update Q := Q*Z' */
+
+ dormr2_("Right", "Transpose", n, n, l, &b[b_offset], ldb, &tau[1],
+ &q[q_offset], ldq, &work[1], info);
+ }
+
+/* Clean up B */
+
+ i__1 = *n - *l;
+ dlaset_("Full", l, &i__1, &c_b12, &c_b12, &b[b_offset], ldb);
+ i__1 = *n;
+ for (j = *n - *l + 1; j <= i__1; ++j) {
+ i__2 = *l;
+ for (i__ = j - *n + *l + 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = 0.;
+/* L50: */
+ }
+/* L60: */
+ }
+
+ }
+
+/* Let N-L L */
+/* A = ( A11 A12 ) M, */
+
+/* then the following does the complete QR decomposition of A11: */
+
+/* A11 = U*( 0 T12 )*P1' */
+/* ( 0 0 ) */
+
+ i__1 = *n - *l;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ iwork[i__] = 0;
+/* L70: */
+ }
+ i__1 = *n - *l;
+ dgeqpf_(m, &i__1, &a[a_offset], lda, &iwork[1], &tau[1], &work[1], info);
+
+/* Determine the effective rank of A11 */
+
+ *k = 0;
+/* Computing MIN */
+ i__2 = *m, i__3 = *n - *l;
+ i__1 = min(i__2,i__3);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((d__1 = a[i__ + i__ * a_dim1], abs(d__1)) > *tola) {
+ ++(*k);
+ }
+/* L80: */
+ }
+
+/* Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N ) */
+
+/* Computing MIN */
+ i__2 = *m, i__3 = *n - *l;
+ i__1 = min(i__2,i__3);
+ dorm2r_("Left", "Transpose", m, l, &i__1, &a[a_offset], lda, &tau[1], &a[(
+ *n - *l + 1) * a_dim1 + 1], lda, &work[1], info);
+
+ if (wantu) {
+
+/* Copy the details of U, and form U */
+
+ dlaset_("Full", m, m, &c_b12, &c_b12, &u[u_offset], ldu);
+ if (*m > 1) {
+ i__1 = *m - 1;
+ i__2 = *n - *l;
+ dlacpy_("Lower", &i__1, &i__2, &a[a_dim1 + 2], lda, &u[u_dim1 + 2]
+, ldu);
+ }
+/* Computing MIN */
+ i__2 = *m, i__3 = *n - *l;
+ i__1 = min(i__2,i__3);
+ dorg2r_(m, m, &i__1, &u[u_offset], ldu, &tau[1], &work[1], info);
+ }
+
+ if (wantq) {
+
+/* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 */
+
+ i__1 = *n - *l;
+ dlapmt_(&forwrd, n, &i__1, &q[q_offset], ldq, &iwork[1]);
+ }
+
+/* Clean up A: set the strictly lower triangular part of */
+/* A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. */
+
+ i__1 = *k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *k;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L90: */
+ }
+/* L100: */
+ }
+ if (*m > *k) {
+ i__1 = *m - *k;
+ i__2 = *n - *l;
+ dlaset_("Full", &i__1, &i__2, &c_b12, &c_b12, &a[*k + 1 + a_dim1],
+ lda);
+ }
+
+ if (*n - *l > *k) {
+
+/* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */
+
+ i__1 = *n - *l;
+ dgerq2_(k, &i__1, &a[a_offset], lda, &tau[1], &work[1], info);
+
+ if (wantq) {
+
+/* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1' */
+
+ i__1 = *n - *l;
+ dormr2_("Right", "Transpose", n, &i__1, k, &a[a_offset], lda, &
+ tau[1], &q[q_offset], ldq, &work[1], info);
+ }
+
+/* Clean up A */
+
+ i__1 = *n - *l - *k;
+ dlaset_("Full", k, &i__1, &c_b12, &c_b12, &a[a_offset], lda);
+ i__1 = *n - *l;
+ for (j = *n - *l - *k + 1; j <= i__1; ++j) {
+ i__2 = *k;
+ for (i__ = j - *n + *l + *k + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L110: */
+ }
+/* L120: */
+ }
+
+ }
+
+ if (*m > *k) {
+
+/* QR factorization of A( K+1:M,N-L+1:N ) */
+
+ i__1 = *m - *k;
+ dgeqr2_(&i__1, l, &a[*k + 1 + (*n - *l + 1) * a_dim1], lda, &tau[1], &
+ work[1], info);
+
+ if (wantu) {
+
+/* Update U(:,K+1:M) := U(:,K+1:M)*U1 */
+
+ i__1 = *m - *k;
+/* Computing MIN */
+ i__3 = *m - *k;
+ i__2 = min(i__3,*l);
+ dorm2r_("Right", "No transpose", m, &i__1, &i__2, &a[*k + 1 + (*n
+ - *l + 1) * a_dim1], lda, &tau[1], &u[(*k + 1) * u_dim1 +
+ 1], ldu, &work[1], info);
+ }
+
+/* Clean up */
+
+ i__1 = *n;
+ for (j = *n - *l + 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j - *n + *k + *l + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L130: */
+ }
+/* L140: */
+ }
+
+ }
+
+ return 0;
+
+/* End of DGGSVP */
+
+} /* dggsvp_ */
diff --git a/SRC/dgsvj0.c b/SRC/dgsvj0.c
new file mode 100644
index 0000000..c10304b
--- /dev/null
+++ b/SRC/dgsvj0.c
@@ -0,0 +1,1159 @@
+/* dgsvj0.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static doublereal c_b42 = 1.;
+
+/* Subroutine */ int dgsvj0_(char *jobv, integer *m, integer *n, doublereal *
+ a, integer *lda, doublereal *d__, doublereal *sva, integer *mv,
+ doublereal *v, integer *ldv, doublereal *eps, doublereal *sfmin,
+ doublereal *tol, integer *nsweep, doublereal *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ doublereal bigtheta;
+ integer pskipped, i__, p, q;
+ doublereal t, rootsfmin, cs, sn;
+ integer ir1, jbc;
+ doublereal big;
+ integer kbl, igl, ibr, jgl, nbl, mvl;
+ doublereal aapp, aapq, aaqq;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer ierr;
+ doublereal aapp0;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ doublereal temp1, apoaq, aqoap;
+ extern logical lsame_(char *, char *);
+ doublereal theta, small;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ doublereal fastr[5];
+ extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical applv, rsvec;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *), drotm_(integer *, doublereal
+ *, integer *, doublereal *, integer *, doublereal *);
+ logical rotok;
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer ijblsk, swband, blskip;
+ doublereal mxaapq;
+ extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
+ doublereal *, doublereal *);
+ doublereal thsign, mxsinj;
+ integer emptsw, notrot, iswrot, lkahead;
+ doublereal rootbig, rooteps;
+ integer rowskip;
+ doublereal roottol;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Zlatko Drmac of the University of Zagreb and -- */
+/* -- Kresimir Veselic of the Fernuniversitaet Hagen -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* This routine is also part of SIGMA (version 1.23, October 23. 2008.) */
+/* SIGMA is a library of algorithms for highly accurate algorithms for */
+/* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the */
+/* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0. */
+
+/* Scalar Arguments */
+
+
+/* Array Arguments */
+
+/* .. */
+
+/* Purpose */
+/* ~~~~~~~ */
+/* DGSVJ0 is called from DGESVJ as a pre-processor and that is its main */
+/* purpose. It applies Jacobi rotations in the same way as DGESVJ does, but */
+/* it does not check convergence (stopping criterion). Few tuning */
+/* parameters (marked by [TP]) are available for the implementer. */
+
+/* Further details */
+/* ~~~~~~~~~~~~~~~ */
+/* DGSVJ0 is used just to enable SGESVJ to call a simplified version of */
+/* itself to work on a submatrix of the original matrix. */
+
+/* Contributors */
+/* ~~~~~~~~~~~~ */
+/* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) */
+
+/* Bugs, Examples and Comments */
+/* ~~~~~~~~~~~~~~~~~~~~~~~~~~~ */
+/* Please report all bugs and send interesting test examples and comments to */
+/* drmac at math.hr. Thank you. */
+
+/* Arguments */
+/* ~~~~~~~~~ */
+
+/* JOBV (input) CHARACTER*1 */
+/* Specifies whether the output from this procedure is used */
+/* to compute the matrix V: */
+/* = 'V': the product of the Jacobi rotations is accumulated */
+/* by postmulyiplying the N-by-N array V. */
+/* (See the description of V.) */
+/* = 'A': the product of the Jacobi rotations is accumulated */
+/* by postmulyiplying the MV-by-N array V. */
+/* (See the descriptions of MV and V.) */
+/* = 'N': the Jacobi rotations are not accumulated. */
+
+/* M (input) INTEGER */
+/* The number of rows of the input matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the input matrix A. */
+/* M >= N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, M-by-N matrix A, such that A*diag(D) represents */
+/* the input matrix. */
+/* On exit, */
+/* A_onexit * D_onexit represents the input matrix A*diag(D) */
+/* post-multiplied by a sequence of Jacobi rotations, where the */
+/* rotation threshold and the total number of sweeps are given in */
+/* TOL and NSWEEP, respectively. */
+/* (See the descriptions of D, TOL and NSWEEP.) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* D (input/workspace/output) REAL array, dimension (N) */
+/* The array D accumulates the scaling factors from the fast scaled */
+/* Jacobi rotations. */
+/* On entry, A*diag(D) represents the input matrix. */
+/* On exit, A_onexit*diag(D_onexit) represents the input matrix */
+/* post-multiplied by a sequence of Jacobi rotations, where the */
+/* rotation threshold and the total number of sweeps are given in */
+/* TOL and NSWEEP, respectively. */
+/* (See the descriptions of A, TOL and NSWEEP.) */
+
+/* SVA (input/workspace/output) REAL array, dimension (N) */
+/* On entry, SVA contains the Euclidean norms of the columns of */
+/* the matrix A*diag(D). */
+/* On exit, SVA contains the Euclidean norms of the columns of */
+/* the matrix onexit*diag(D_onexit). */
+
+/* MV (input) INTEGER */
+/* If JOBV .EQ. 'A', then MV rows of V are post-multipled by a */
+/* sequence of Jacobi rotations. */
+/* If JOBV = 'N', then MV is not referenced. */
+
+/* V (input/output) REAL array, dimension (LDV,N) */
+/* If JOBV .EQ. 'V' then N rows of V are post-multipled by a */
+/* sequence of Jacobi rotations. */
+/* If JOBV .EQ. 'A' then MV rows of V are post-multipled by a */
+/* sequence of Jacobi rotations. */
+/* If JOBV = 'N', then V is not referenced. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V, LDV >= 1. */
+/* If JOBV = 'V', LDV .GE. N. */
+/* If JOBV = 'A', LDV .GE. MV. */
+
+/* EPS (input) INTEGER */
+/* EPS = SLAMCH('Epsilon') */
+
+/* SFMIN (input) INTEGER */
+/* SFMIN = SLAMCH('Safe Minimum') */
+
+/* TOL (input) REAL */
+/* TOL is the threshold for Jacobi rotations. For a pair */
+/* A(:,p), A(:,q) of pivot columns, the Jacobi rotation is */
+/* applied only if DABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL. */
+
+/* NSWEEP (input) INTEGER */
+/* NSWEEP is the number of sweeps of Jacobi rotations to be */
+/* performed. */
+
+/* WORK (workspace) REAL array, dimension LWORK. */
+
+/* LWORK (input) INTEGER */
+/* LWORK is the dimension of WORK. LWORK .GE. M. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit. */
+/* < 0 : if INFO = -i, then the i-th argument had an illegal value */
+
+/* Local Parameters */
+/* Local Scalars */
+/* Local Arrays */
+
+
+/* Intrinsic Functions */
+
+
+/* External Functions */
+
+
+/* External Subroutines */
+
+
+/* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| */
+
+ /* Parameter adjustments */
+ --sva;
+ --d__;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --work;
+
+ /* Function Body */
+ applv = lsame_(jobv, "A");
+ rsvec = lsame_(jobv, "V");
+ if (! (rsvec || applv || lsame_(jobv, "N"))) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*n < 0 || *n > *m) {
+ *info = -3;
+ } else if (*lda < *m) {
+ *info = -5;
+ } else if (*mv < 0) {
+ *info = -8;
+ } else if (*ldv < *m) {
+ *info = -10;
+ } else if (*tol <= *eps) {
+ *info = -13;
+ } else if (*nsweep < 0) {
+ *info = -14;
+ } else if (*lwork < *m) {
+ *info = -16;
+ } else {
+ *info = 0;
+ }
+
+/* #:( */
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGSVJ0", &i__1);
+ return 0;
+ }
+
+ if (rsvec) {
+ mvl = *n;
+ } else if (applv) {
+ mvl = *mv;
+ }
+ rsvec = rsvec || applv;
+ rooteps = sqrt(*eps);
+ rootsfmin = sqrt(*sfmin);
+ small = *sfmin / *eps;
+ big = 1. / *sfmin;
+ rootbig = 1. / rootsfmin;
+ bigtheta = 1. / rooteps;
+ roottol = sqrt(*tol);
+
+
+/* -#- Row-cyclic Jacobi SVD algorithm with column pivoting -#- */
+
+ emptsw = *n * (*n - 1) / 2;
+ notrot = 0;
+ fastr[0] = 0.;
+
+/* -#- Row-cyclic pivot strategy with de Rijk's pivoting -#- */
+
+ swband = 0;
+/* [TP] SWBAND is a tuning parameter. It is meaningful and effective */
+/* if SGESVJ is used as a computational routine in the preconditioned */
+/* Jacobi SVD algorithm SGESVJ. For sweeps i=1:SWBAND the procedure */
+/* ...... */
+ kbl = min(8,*n);
+/* [TP] KBL is a tuning parameter that defines the tile size in the */
+/* tiling of the p-q loops of pivot pairs. In general, an optimal */
+/* value of KBL depends on the matrix dimensions and on the */
+/* parameters of the computer's memory. */
+
+ nbl = *n / kbl;
+ if (nbl * kbl != *n) {
+ ++nbl;
+ }
+/* Computing 2nd power */
+ i__1 = kbl;
+ blskip = i__1 * i__1 + 1;
+/* [TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. */
+ rowskip = min(5,kbl);
+/* [TP] ROWSKIP is a tuning parameter. */
+ lkahead = 1;
+/* [TP] LKAHEAD is a tuning parameter. */
+ swband = 0;
+ pskipped = 0;
+
+ i__1 = *nsweep;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* .. go go go ... */
+
+ mxaapq = 0.;
+ mxsinj = 0.;
+ iswrot = 0;
+
+ notrot = 0;
+ pskipped = 0;
+
+ i__2 = nbl;
+ for (ibr = 1; ibr <= i__2; ++ibr) {
+ igl = (ibr - 1) * kbl + 1;
+
+/* Computing MIN */
+ i__4 = lkahead, i__5 = nbl - ibr;
+ i__3 = min(i__4,i__5);
+ for (ir1 = 0; ir1 <= i__3; ++ir1) {
+
+ igl += ir1 * kbl;
+
+/* Computing MIN */
+ i__5 = igl + kbl - 1, i__6 = *n - 1;
+ i__4 = min(i__5,i__6);
+ for (p = igl; p <= i__4; ++p) {
+/* .. de Rijk's pivoting */
+ i__5 = *n - p + 1;
+ q = idamax_(&i__5, &sva[p], &c__1) + p - 1;
+ if (p != q) {
+ dswap_(m, &a[p * a_dim1 + 1], &c__1, &a[q * a_dim1 +
+ 1], &c__1);
+ if (rsvec) {
+ dswap_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q *
+ v_dim1 + 1], &c__1);
+ }
+ temp1 = sva[p];
+ sva[p] = sva[q];
+ sva[q] = temp1;
+ temp1 = d__[p];
+ d__[p] = d__[q];
+ d__[q] = temp1;
+ }
+
+ if (ir1 == 0) {
+
+/* Column norms are periodically updated by explicit */
+/* norm computation. */
+/* Caveat: */
+/* Some BLAS implementations compute DNRM2(M,A(1,p),1) */
+/* as DSQRT(DDOT(M,A(1,p),1,A(1,p),1)), which may result in */
+/* overflow for ||A(:,p)||_2 > DSQRT(overflow_threshold), and */
+/* undeflow for ||A(:,p)||_2 < DSQRT(underflow_threshold). */
+/* Hence, DNRM2 cannot be trusted, not even in the case when */
+/* the true norm is far from the under(over)flow boundaries. */
+/* If properly implemented DNRM2 is available, the IF-THEN-ELSE */
+/* below should read "AAPP = DNRM2( M, A(1,p), 1 ) * D(p)". */
+
+ if (sva[p] < rootbig && sva[p] > rootsfmin) {
+ sva[p] = dnrm2_(m, &a[p * a_dim1 + 1], &c__1) *
+ d__[p];
+ } else {
+ temp1 = 0.;
+ aapp = 0.;
+ dlassq_(m, &a[p * a_dim1 + 1], &c__1, &temp1, &
+ aapp);
+ sva[p] = temp1 * sqrt(aapp) * d__[p];
+ }
+ aapp = sva[p];
+ } else {
+ aapp = sva[p];
+ }
+
+ if (aapp > 0.) {
+
+ pskipped = 0;
+
+/* Computing MIN */
+ i__6 = igl + kbl - 1;
+ i__5 = min(i__6,*n);
+ for (q = p + 1; q <= i__5; ++q) {
+
+ aaqq = sva[q];
+ if (aaqq > 0.) {
+
+ aapp0 = aapp;
+ if (aaqq >= 1.) {
+ rotok = small * aapp <= aaqq;
+ if (aapp < big / aaqq) {
+ aapq = ddot_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1], &
+ c__1) * d__[p] * d__[q] /
+ aaqq / aapp;
+ } else {
+ dcopy_(m, &a[p * a_dim1 + 1], &c__1, &
+ work[1], &c__1);
+ dlascl_("G", &c__0, &c__0, &aapp, &
+ d__[p], m, &c__1, &work[1],
+ lda, &ierr);
+ aapq = ddot_(m, &work[1], &c__1, &a[q
+ * a_dim1 + 1], &c__1) * d__[q]
+ / aaqq;
+ }
+ } else {
+ rotok = aapp <= aaqq / small;
+ if (aapp > small / aaqq) {
+ aapq = ddot_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1], &
+ c__1) * d__[p] * d__[q] /
+ aaqq / aapp;
+ } else {
+ dcopy_(m, &a[q * a_dim1 + 1], &c__1, &
+ work[1], &c__1);
+ dlascl_("G", &c__0, &c__0, &aaqq, &
+ d__[q], m, &c__1, &work[1],
+ lda, &ierr);
+ aapq = ddot_(m, &work[1], &c__1, &a[p
+ * a_dim1 + 1], &c__1) * d__[p]
+ / aapp;
+ }
+ }
+
+/* Computing MAX */
+ d__1 = mxaapq, d__2 = abs(aapq);
+ mxaapq = max(d__1,d__2);
+
+/* TO rotate or NOT to rotate, THAT is the question ... */
+
+ if (abs(aapq) > *tol) {
+
+/* .. rotate */
+/* ROTATED = ROTATED + ONE */
+
+ if (ir1 == 0) {
+ notrot = 0;
+ pskipped = 0;
+ ++iswrot;
+ }
+
+ if (rotok) {
+
+ aqoap = aaqq / aapp;
+ apoaq = aapp / aaqq;
+ theta = (d__1 = aqoap - apoaq, abs(
+ d__1)) * -.5 / aapq;
+
+ if (abs(theta) > bigtheta) {
+
+ t = .5 / theta;
+ fastr[2] = t * d__[p] / d__[q];
+ fastr[3] = -t * d__[q] / d__[p];
+ drotm_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1],
+ &c__1, fastr);
+ if (rsvec) {
+ drotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q *
+ v_dim1 + 1], &c__1, fastr);
+ }
+/* Computing MAX */
+ d__1 = 0., d__2 = t * apoaq *
+ aapq + 1.;
+ sva[q] = aaqq * sqrt((max(d__1,
+ d__2)));
+ aapp *= sqrt(1. - t * aqoap *
+ aapq);
+/* Computing MAX */
+ d__1 = mxsinj, d__2 = abs(t);
+ mxsinj = max(d__1,d__2);
+
+ } else {
+
+/* .. choose correct signum for THETA and rotate */
+
+ thsign = -d_sign(&c_b42, &aapq);
+ t = 1. / (theta + thsign * sqrt(
+ theta * theta + 1.));
+ cs = sqrt(1. / (t * t + 1.));
+ sn = t * cs;
+
+/* Computing MAX */
+ d__1 = mxsinj, d__2 = abs(sn);
+ mxsinj = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = 0., d__2 = t * apoaq *
+ aapq + 1.;
+ sva[q] = aaqq * sqrt((max(d__1,
+ d__2)));
+/* Computing MAX */
+ d__1 = 0., d__2 = 1. - t * aqoap *
+ aapq;
+ aapp *= sqrt((max(d__1,d__2)));
+
+ apoaq = d__[p] / d__[q];
+ aqoap = d__[q] / d__[p];
+ if (d__[p] >= 1.) {
+ if (d__[q] >= 1.) {
+ fastr[2] = t * apoaq;
+ fastr[3] = -t * aqoap;
+ d__[p] *= cs;
+ d__[q] *= cs;
+ drotm_(m, &a[p * a_dim1 + 1], &c__1, &a[q *
+ a_dim1 + 1], &c__1, fastr);
+ if (rsvec) {
+ drotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[
+ q * v_dim1 + 1], &c__1, fastr);
+ }
+ } else {
+ d__1 = -t * aqoap;
+ daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1, &a[
+ p * a_dim1 + 1], &c__1);
+ d__1 = cs * sn * apoaq;
+ daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1, &a[
+ q * a_dim1 + 1], &c__1);
+ d__[p] *= cs;
+ d__[q] /= cs;
+ if (rsvec) {
+ d__1 = -t * aqoap;
+ daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1], &
+ c__1, &v[p * v_dim1 + 1], &c__1);
+ d__1 = cs * sn * apoaq;
+ daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1], &
+ c__1, &v[q * v_dim1 + 1], &c__1);
+ }
+ }
+ } else {
+ if (d__[q] >= 1.) {
+ d__1 = t * apoaq;
+ daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1, &a[
+ q * a_dim1 + 1], &c__1);
+ d__1 = -cs * sn * aqoap;
+ daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1, &a[
+ p * a_dim1 + 1], &c__1);
+ d__[p] /= cs;
+ d__[q] *= cs;
+ if (rsvec) {
+ d__1 = t * apoaq;
+ daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1], &
+ c__1, &v[q * v_dim1 + 1], &c__1);
+ d__1 = -cs * sn * aqoap;
+ daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1], &
+ c__1, &v[p * v_dim1 + 1], &c__1);
+ }
+ } else {
+ if (d__[p] >= d__[q]) {
+ d__1 = -t * aqoap;
+ daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1);
+ d__1 = cs * sn * apoaq;
+ daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1);
+ d__[p] *= cs;
+ d__[q] /= cs;
+ if (rsvec) {
+ d__1 = -t * aqoap;
+ daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1],
+ &c__1, &v[p * v_dim1 + 1], &
+ c__1);
+ d__1 = cs * sn * apoaq;
+ daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1],
+ &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ }
+ } else {
+ d__1 = t * apoaq;
+ daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1);
+ d__1 = -cs * sn * aqoap;
+ daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1);
+ d__[p] /= cs;
+ d__[q] *= cs;
+ if (rsvec) {
+ d__1 = t * apoaq;
+ daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1],
+ &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ d__1 = -cs * sn * aqoap;
+ daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1],
+ &c__1, &v[p * v_dim1 + 1], &
+ c__1);
+ }
+ }
+ }
+ }
+ }
+
+ } else {
+/* .. have to use modified Gram-Schmidt like transformation */
+ dcopy_(m, &a[p * a_dim1 + 1], &c__1, &
+ work[1], &c__1);
+ dlascl_("G", &c__0, &c__0, &aapp, &
+ c_b42, m, &c__1, &work[1],
+ lda, &ierr);
+ dlascl_("G", &c__0, &c__0, &aaqq, &
+ c_b42, m, &c__1, &a[q *
+ a_dim1 + 1], lda, &ierr);
+ temp1 = -aapq * d__[p] / d__[q];
+ daxpy_(m, &temp1, &work[1], &c__1, &a[
+ q * a_dim1 + 1], &c__1);
+ dlascl_("G", &c__0, &c__0, &c_b42, &
+ aaqq, m, &c__1, &a[q * a_dim1
+ + 1], lda, &ierr);
+/* Computing MAX */
+ d__1 = 0., d__2 = 1. - aapq * aapq;
+ sva[q] = aaqq * sqrt((max(d__1,d__2)))
+ ;
+ mxsinj = max(mxsinj,*sfmin);
+ }
+/* END IF ROTOK THEN ... ELSE */
+
+/* In the case of cancellation in updating SVA(q), SVA(p) */
+/* recompute SVA(q), SVA(p). */
+/* Computing 2nd power */
+ d__1 = sva[q] / aaqq;
+ if (d__1 * d__1 <= rooteps) {
+ if (aaqq < rootbig && aaqq >
+ rootsfmin) {
+ sva[q] = dnrm2_(m, &a[q * a_dim1
+ + 1], &c__1) * d__[q];
+ } else {
+ t = 0.;
+ aaqq = 0.;
+ dlassq_(m, &a[q * a_dim1 + 1], &
+ c__1, &t, &aaqq);
+ sva[q] = t * sqrt(aaqq) * d__[q];
+ }
+ }
+ if (aapp / aapp0 <= rooteps) {
+ if (aapp < rootbig && aapp >
+ rootsfmin) {
+ aapp = dnrm2_(m, &a[p * a_dim1 +
+ 1], &c__1) * d__[p];
+ } else {
+ t = 0.;
+ aapp = 0.;
+ dlassq_(m, &a[p * a_dim1 + 1], &
+ c__1, &t, &aapp);
+ aapp = t * sqrt(aapp) * d__[p];
+ }
+ sva[p] = aapp;
+ }
+
+ } else {
+/* A(:,p) and A(:,q) already numerically orthogonal */
+ if (ir1 == 0) {
+ ++notrot;
+ }
+ ++pskipped;
+ }
+ } else {
+/* A(:,q) is zero column */
+ if (ir1 == 0) {
+ ++notrot;
+ }
+ ++pskipped;
+ }
+
+ if (i__ <= swband && pskipped > rowskip) {
+ if (ir1 == 0) {
+ aapp = -aapp;
+ }
+ notrot = 0;
+ goto L2103;
+ }
+
+/* L2002: */
+ }
+/* END q-LOOP */
+
+L2103:
+/* bailed out of q-loop */
+ sva[p] = aapp;
+ } else {
+ sva[p] = aapp;
+ if (ir1 == 0 && aapp == 0.) {
+/* Computing MIN */
+ i__5 = igl + kbl - 1;
+ notrot = notrot + min(i__5,*n) - p;
+ }
+ }
+
+/* L2001: */
+ }
+/* end of the p-loop */
+/* end of doing the block ( ibr, ibr ) */
+/* L1002: */
+ }
+/* end of ir1-loop */
+
+/* ........................................................ */
+/* ... go to the off diagonal blocks */
+
+ igl = (ibr - 1) * kbl + 1;
+
+ i__3 = nbl;
+ for (jbc = ibr + 1; jbc <= i__3; ++jbc) {
+
+ jgl = (jbc - 1) * kbl + 1;
+
+/* doing the block at ( ibr, jbc ) */
+
+ ijblsk = 0;
+/* Computing MIN */
+ i__5 = igl + kbl - 1;
+ i__4 = min(i__5,*n);
+ for (p = igl; p <= i__4; ++p) {
+
+ aapp = sva[p];
+
+ if (aapp > 0.) {
+
+ pskipped = 0;
+
+/* Computing MIN */
+ i__6 = jgl + kbl - 1;
+ i__5 = min(i__6,*n);
+ for (q = jgl; q <= i__5; ++q) {
+
+ aaqq = sva[q];
+
+ if (aaqq > 0.) {
+ aapp0 = aapp;
+
+/* -#- M x 2 Jacobi SVD -#- */
+
+/* -#- Safe Gram matrix computation -#- */
+
+ if (aaqq >= 1.) {
+ if (aapp >= aaqq) {
+ rotok = small * aapp <= aaqq;
+ } else {
+ rotok = small * aaqq <= aapp;
+ }
+ if (aapp < big / aaqq) {
+ aapq = ddot_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1], &
+ c__1) * d__[p] * d__[q] /
+ aaqq / aapp;
+ } else {
+ dcopy_(m, &a[p * a_dim1 + 1], &c__1, &
+ work[1], &c__1);
+ dlascl_("G", &c__0, &c__0, &aapp, &
+ d__[p], m, &c__1, &work[1],
+ lda, &ierr);
+ aapq = ddot_(m, &work[1], &c__1, &a[q
+ * a_dim1 + 1], &c__1) * d__[q]
+ / aaqq;
+ }
+ } else {
+ if (aapp >= aaqq) {
+ rotok = aapp <= aaqq / small;
+ } else {
+ rotok = aaqq <= aapp / small;
+ }
+ if (aapp > small / aaqq) {
+ aapq = ddot_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1], &
+ c__1) * d__[p] * d__[q] /
+ aaqq / aapp;
+ } else {
+ dcopy_(m, &a[q * a_dim1 + 1], &c__1, &
+ work[1], &c__1);
+ dlascl_("G", &c__0, &c__0, &aaqq, &
+ d__[q], m, &c__1, &work[1],
+ lda, &ierr);
+ aapq = ddot_(m, &work[1], &c__1, &a[p
+ * a_dim1 + 1], &c__1) * d__[p]
+ / aapp;
+ }
+ }
+
+/* Computing MAX */
+ d__1 = mxaapq, d__2 = abs(aapq);
+ mxaapq = max(d__1,d__2);
+
+/* TO rotate or NOT to rotate, THAT is the question ... */
+
+ if (abs(aapq) > *tol) {
+ notrot = 0;
+/* ROTATED = ROTATED + 1 */
+ pskipped = 0;
+ ++iswrot;
+
+ if (rotok) {
+
+ aqoap = aaqq / aapp;
+ apoaq = aapp / aaqq;
+ theta = (d__1 = aqoap - apoaq, abs(
+ d__1)) * -.5 / aapq;
+ if (aaqq > aapp0) {
+ theta = -theta;
+ }
+
+ if (abs(theta) > bigtheta) {
+ t = .5 / theta;
+ fastr[2] = t * d__[p] / d__[q];
+ fastr[3] = -t * d__[q] / d__[p];
+ drotm_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1],
+ &c__1, fastr);
+ if (rsvec) {
+ drotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q *
+ v_dim1 + 1], &c__1, fastr);
+ }
+/* Computing MAX */
+ d__1 = 0., d__2 = t * apoaq *
+ aapq + 1.;
+ sva[q] = aaqq * sqrt((max(d__1,
+ d__2)));
+/* Computing MAX */
+ d__1 = 0., d__2 = 1. - t * aqoap *
+ aapq;
+ aapp *= sqrt((max(d__1,d__2)));
+/* Computing MAX */
+ d__1 = mxsinj, d__2 = abs(t);
+ mxsinj = max(d__1,d__2);
+ } else {
+
+/* .. choose correct signum for THETA and rotate */
+
+ thsign = -d_sign(&c_b42, &aapq);
+ if (aaqq > aapp0) {
+ thsign = -thsign;
+ }
+ t = 1. / (theta + thsign * sqrt(
+ theta * theta + 1.));
+ cs = sqrt(1. / (t * t + 1.));
+ sn = t * cs;
+/* Computing MAX */
+ d__1 = mxsinj, d__2 = abs(sn);
+ mxsinj = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = 0., d__2 = t * apoaq *
+ aapq + 1.;
+ sva[q] = aaqq * sqrt((max(d__1,
+ d__2)));
+ aapp *= sqrt(1. - t * aqoap *
+ aapq);
+
+ apoaq = d__[p] / d__[q];
+ aqoap = d__[q] / d__[p];
+ if (d__[p] >= 1.) {
+
+ if (d__[q] >= 1.) {
+ fastr[2] = t * apoaq;
+ fastr[3] = -t * aqoap;
+ d__[p] *= cs;
+ d__[q] *= cs;
+ drotm_(m, &a[p * a_dim1 + 1], &c__1, &a[q *
+ a_dim1 + 1], &c__1, fastr);
+ if (rsvec) {
+ drotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[
+ q * v_dim1 + 1], &c__1, fastr);
+ }
+ } else {
+ d__1 = -t * aqoap;
+ daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1, &a[
+ p * a_dim1 + 1], &c__1);
+ d__1 = cs * sn * apoaq;
+ daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1, &a[
+ q * a_dim1 + 1], &c__1);
+ if (rsvec) {
+ d__1 = -t * aqoap;
+ daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1], &
+ c__1, &v[p * v_dim1 + 1], &c__1);
+ d__1 = cs * sn * apoaq;
+ daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1], &
+ c__1, &v[q * v_dim1 + 1], &c__1);
+ }
+ d__[p] *= cs;
+ d__[q] /= cs;
+ }
+ } else {
+ if (d__[q] >= 1.) {
+ d__1 = t * apoaq;
+ daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1, &a[
+ q * a_dim1 + 1], &c__1);
+ d__1 = -cs * sn * aqoap;
+ daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1, &a[
+ p * a_dim1 + 1], &c__1);
+ if (rsvec) {
+ d__1 = t * apoaq;
+ daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1], &
+ c__1, &v[q * v_dim1 + 1], &c__1);
+ d__1 = -cs * sn * aqoap;
+ daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1], &
+ c__1, &v[p * v_dim1 + 1], &c__1);
+ }
+ d__[p] /= cs;
+ d__[q] *= cs;
+ } else {
+ if (d__[p] >= d__[q]) {
+ d__1 = -t * aqoap;
+ daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1);
+ d__1 = cs * sn * apoaq;
+ daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1);
+ d__[p] *= cs;
+ d__[q] /= cs;
+ if (rsvec) {
+ d__1 = -t * aqoap;
+ daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1],
+ &c__1, &v[p * v_dim1 + 1], &
+ c__1);
+ d__1 = cs * sn * apoaq;
+ daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1],
+ &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ }
+ } else {
+ d__1 = t * apoaq;
+ daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1);
+ d__1 = -cs * sn * aqoap;
+ daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1);
+ d__[p] /= cs;
+ d__[q] *= cs;
+ if (rsvec) {
+ d__1 = t * apoaq;
+ daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1],
+ &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ d__1 = -cs * sn * aqoap;
+ daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1],
+ &c__1, &v[p * v_dim1 + 1], &
+ c__1);
+ }
+ }
+ }
+ }
+ }
+
+ } else {
+ if (aapp > aaqq) {
+ dcopy_(m, &a[p * a_dim1 + 1], &
+ c__1, &work[1], &c__1);
+ dlascl_("G", &c__0, &c__0, &aapp,
+ &c_b42, m, &c__1, &work[1]
+, lda, &ierr);
+ dlascl_("G", &c__0, &c__0, &aaqq,
+ &c_b42, m, &c__1, &a[q *
+ a_dim1 + 1], lda, &ierr);
+ temp1 = -aapq * d__[p] / d__[q];
+ daxpy_(m, &temp1, &work[1], &c__1,
+ &a[q * a_dim1 + 1], &
+ c__1);
+ dlascl_("G", &c__0, &c__0, &c_b42,
+ &aaqq, m, &c__1, &a[q *
+ a_dim1 + 1], lda, &ierr);
+/* Computing MAX */
+ d__1 = 0., d__2 = 1. - aapq *
+ aapq;
+ sva[q] = aaqq * sqrt((max(d__1,
+ d__2)));
+ mxsinj = max(mxsinj,*sfmin);
+ } else {
+ dcopy_(m, &a[q * a_dim1 + 1], &
+ c__1, &work[1], &c__1);
+ dlascl_("G", &c__0, &c__0, &aaqq,
+ &c_b42, m, &c__1, &work[1]
+, lda, &ierr);
+ dlascl_("G", &c__0, &c__0, &aapp,
+ &c_b42, m, &c__1, &a[p *
+ a_dim1 + 1], lda, &ierr);
+ temp1 = -aapq * d__[q] / d__[p];
+ daxpy_(m, &temp1, &work[1], &c__1,
+ &a[p * a_dim1 + 1], &
+ c__1);
+ dlascl_("G", &c__0, &c__0, &c_b42,
+ &aapp, m, &c__1, &a[p *
+ a_dim1 + 1], lda, &ierr);
+/* Computing MAX */
+ d__1 = 0., d__2 = 1. - aapq *
+ aapq;
+ sva[p] = aapp * sqrt((max(d__1,
+ d__2)));
+ mxsinj = max(mxsinj,*sfmin);
+ }
+ }
+/* END IF ROTOK THEN ... ELSE */
+
+/* In the case of cancellation in updating SVA(q) */
+/* .. recompute SVA(q) */
+/* Computing 2nd power */
+ d__1 = sva[q] / aaqq;
+ if (d__1 * d__1 <= rooteps) {
+ if (aaqq < rootbig && aaqq >
+ rootsfmin) {
+ sva[q] = dnrm2_(m, &a[q * a_dim1
+ + 1], &c__1) * d__[q];
+ } else {
+ t = 0.;
+ aaqq = 0.;
+ dlassq_(m, &a[q * a_dim1 + 1], &
+ c__1, &t, &aaqq);
+ sva[q] = t * sqrt(aaqq) * d__[q];
+ }
+ }
+/* Computing 2nd power */
+ d__1 = aapp / aapp0;
+ if (d__1 * d__1 <= rooteps) {
+ if (aapp < rootbig && aapp >
+ rootsfmin) {
+ aapp = dnrm2_(m, &a[p * a_dim1 +
+ 1], &c__1) * d__[p];
+ } else {
+ t = 0.;
+ aapp = 0.;
+ dlassq_(m, &a[p * a_dim1 + 1], &
+ c__1, &t, &aapp);
+ aapp = t * sqrt(aapp) * d__[p];
+ }
+ sva[p] = aapp;
+ }
+/* end of OK rotation */
+ } else {
+ ++notrot;
+ ++pskipped;
+ ++ijblsk;
+ }
+ } else {
+ ++notrot;
+ ++pskipped;
+ ++ijblsk;
+ }
+
+ if (i__ <= swband && ijblsk >= blskip) {
+ sva[p] = aapp;
+ notrot = 0;
+ goto L2011;
+ }
+ if (i__ <= swband && pskipped > rowskip) {
+ aapp = -aapp;
+ notrot = 0;
+ goto L2203;
+ }
+
+/* L2200: */
+ }
+/* end of the q-loop */
+L2203:
+
+ sva[p] = aapp;
+
+ } else {
+ if (aapp == 0.) {
+/* Computing MIN */
+ i__5 = jgl + kbl - 1;
+ notrot = notrot + min(i__5,*n) - jgl + 1;
+ }
+ if (aapp < 0.) {
+ notrot = 0;
+ }
+ }
+/* L2100: */
+ }
+/* end of the p-loop */
+/* L2010: */
+ }
+/* end of the jbc-loop */
+L2011:
+/* 2011 bailed out of the jbc-loop */
+/* Computing MIN */
+ i__4 = igl + kbl - 1;
+ i__3 = min(i__4,*n);
+ for (p = igl; p <= i__3; ++p) {
+ sva[p] = (d__1 = sva[p], abs(d__1));
+/* L2012: */
+ }
+
+/* L2000: */
+ }
+/* 2000 :: end of the ibr-loop */
+
+/* .. update SVA(N) */
+ if (sva[*n] < rootbig && sva[*n] > rootsfmin) {
+ sva[*n] = dnrm2_(m, &a[*n * a_dim1 + 1], &c__1) * d__[*n];
+ } else {
+ t = 0.;
+ aapp = 0.;
+ dlassq_(m, &a[*n * a_dim1 + 1], &c__1, &t, &aapp);
+ sva[*n] = t * sqrt(aapp) * d__[*n];
+ }
+
+/* Additional steering devices */
+
+ if (i__ < swband && (mxaapq <= roottol || iswrot <= *n)) {
+ swband = i__;
+ }
+
+ if (i__ > swband + 1 && mxaapq < (doublereal) (*n) * *tol && (
+ doublereal) (*n) * mxaapq * mxsinj < *tol) {
+ goto L1994;
+ }
+
+ if (notrot >= emptsw) {
+ goto L1994;
+ }
+/* L1993: */
+ }
+/* end i=1:NSWEEP loop */
+/* #:) Reaching this point means that the procedure has comleted the given */
+/* number of iterations. */
+ *info = *nsweep - 1;
+ goto L1995;
+L1994:
+/* #:) Reaching this point means that during the i-th sweep all pivots were */
+/* below the given tolerance, causing early exit. */
+
+ *info = 0;
+/* #:) INFO = 0 confirms successful iterations. */
+L1995:
+
+/* Sort the vector D. */
+ i__1 = *n - 1;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = *n - p + 1;
+ q = idamax_(&i__2, &sva[p], &c__1) + p - 1;
+ if (p != q) {
+ temp1 = sva[p];
+ sva[p] = sva[q];
+ sva[q] = temp1;
+ temp1 = d__[p];
+ d__[p] = d__[q];
+ d__[q] = temp1;
+ dswap_(m, &a[p * a_dim1 + 1], &c__1, &a[q * a_dim1 + 1], &c__1);
+ if (rsvec) {
+ dswap_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ }
+ }
+/* L5991: */
+ }
+
+ return 0;
+/* .. */
+/* .. END OF DGSVJ0 */
+/* .. */
+} /* dgsvj0_ */
diff --git a/SRC/dgsvj1.c b/SRC/dgsvj1.c
new file mode 100644
index 0000000..eb6a967
--- /dev/null
+++ b/SRC/dgsvj1.c
@@ -0,0 +1,798 @@
+/* dgsvj1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static doublereal c_b35 = 1.;
+
+/* Subroutine */ int dgsvj1_(char *jobv, integer *m, integer *n, integer *n1,
+ doublereal *a, integer *lda, doublereal *d__, doublereal *sva,
+ integer *mv, doublereal *v, integer *ldv, doublereal *eps, doublereal
+ *sfmin, doublereal *tol, integer *nsweep, doublereal *work, integer *
+ lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ doublereal bigtheta;
+ integer pskipped, i__, p, q;
+ doublereal t, rootsfmin, cs, sn;
+ integer jbc;
+ doublereal big;
+ integer kbl, igl, ibr, jgl, mvl, nblc;
+ doublereal aapp, aapq, aaqq;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer nblr, ierr;
+ doublereal aapp0;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ doublereal temp1, large, apoaq, aqoap;
+ extern logical lsame_(char *, char *);
+ doublereal theta, small;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ doublereal fastr[5];
+ extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical applv, rsvec;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *), drotm_(integer *, doublereal
+ *, integer *, doublereal *, integer *, doublereal *);
+ logical rotok;
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer ijblsk, swband, blskip;
+ doublereal mxaapq;
+ extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
+ doublereal *, doublereal *);
+ doublereal thsign, mxsinj;
+ integer emptsw, notrot, iswrot;
+ doublereal rootbig, rooteps;
+ integer rowskip;
+ doublereal roottol;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Zlatko Drmac of the University of Zagreb and -- */
+/* -- Kresimir Veselic of the Fernuniversitaet Hagen -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* This routine is also part of SIGMA (version 1.23, October 23. 2008.) */
+/* SIGMA is a library of algorithms for highly accurate algorithms for */
+/* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the */
+/* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0. */
+
+/* -#- Scalar Arguments -#- */
+
+
+/* -#- Array Arguments -#- */
+
+/* .. */
+
+/* Purpose */
+/* ~~~~~~~ */
+/* DGSVJ1 is called from SGESVJ as a pre-processor and that is its main */
+/* purpose. It applies Jacobi rotations in the same way as SGESVJ does, but */
+/* it targets only particular pivots and it does not check convergence */
+/* (stopping criterion). Few tunning parameters (marked by [TP]) are */
+/* available for the implementer. */
+
+/* Further details */
+/* ~~~~~~~~~~~~~~~ */
+/* DGSVJ1 applies few sweeps of Jacobi rotations in the column space of */
+/* the input M-by-N matrix A. The pivot pairs are taken from the (1,2) */
+/* off-diagonal block in the corresponding N-by-N Gram matrix A^T * A. The */
+/* block-entries (tiles) of the (1,2) off-diagonal block are marked by the */
+/* [x]'s in the following scheme: */
+
+/* | * * * [x] [x] [x]| */
+/* | * * * [x] [x] [x]| Row-cycling in the nblr-by-nblc [x] blocks. */
+/* | * * * [x] [x] [x]| Row-cyclic pivoting inside each [x] block. */
+/* |[x] [x] [x] * * * | */
+/* |[x] [x] [x] * * * | */
+/* |[x] [x] [x] * * * | */
+
+/* In terms of the columns of A, the first N1 columns are rotated 'against' */
+/* the remaining N-N1 columns, trying to increase the angle between the */
+/* corresponding subspaces. The off-diagonal block is N1-by(N-N1) and it is */
+/* tiled using quadratic tiles of side KBL. Here, KBL is a tunning parmeter. */
+/* The number of sweeps is given in NSWEEP and the orthogonality threshold */
+/* is given in TOL. */
+
+/* Contributors */
+/* ~~~~~~~~~~~~ */
+/* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) */
+
+/* Arguments */
+/* ~~~~~~~~~ */
+
+/* JOBV (input) CHARACTER*1 */
+/* Specifies whether the output from this procedure is used */
+/* to compute the matrix V: */
+/* = 'V': the product of the Jacobi rotations is accumulated */
+/* by postmulyiplying the N-by-N array V. */
+/* (See the description of V.) */
+/* = 'A': the product of the Jacobi rotations is accumulated */
+/* by postmulyiplying the MV-by-N array V. */
+/* (See the descriptions of MV and V.) */
+/* = 'N': the Jacobi rotations are not accumulated. */
+
+/* M (input) INTEGER */
+/* The number of rows of the input matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the input matrix A. */
+/* M >= N >= 0. */
+
+/* N1 (input) INTEGER */
+/* N1 specifies the 2 x 2 block partition, the first N1 columns are */
+/* rotated 'against' the remaining N-N1 columns of A. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, M-by-N matrix A, such that A*diag(D) represents */
+/* the input matrix. */
+/* On exit, */
+/* A_onexit * D_onexit represents the input matrix A*diag(D) */
+/* post-multiplied by a sequence of Jacobi rotations, where the */
+/* rotation threshold and the total number of sweeps are given in */
+/* TOL and NSWEEP, respectively. */
+/* (See the descriptions of N1, D, TOL and NSWEEP.) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* D (input/workspace/output) REAL array, dimension (N) */
+/* The array D accumulates the scaling factors from the fast scaled */
+/* Jacobi rotations. */
+/* On entry, A*diag(D) represents the input matrix. */
+/* On exit, A_onexit*diag(D_onexit) represents the input matrix */
+/* post-multiplied by a sequence of Jacobi rotations, where the */
+/* rotation threshold and the total number of sweeps are given in */
+/* TOL and NSWEEP, respectively. */
+/* (See the descriptions of N1, A, TOL and NSWEEP.) */
+
+/* SVA (input/workspace/output) REAL array, dimension (N) */
+/* On entry, SVA contains the Euclidean norms of the columns of */
+/* the matrix A*diag(D). */
+/* On exit, SVA contains the Euclidean norms of the columns of */
+/* the matrix onexit*diag(D_onexit). */
+
+/* MV (input) INTEGER */
+/* If JOBV .EQ. 'A', then MV rows of V are post-multipled by a */
+/* sequence of Jacobi rotations. */
+/* If JOBV = 'N', then MV is not referenced. */
+
+/* V (input/output) REAL array, dimension (LDV,N) */
+/* If JOBV .EQ. 'V' then N rows of V are post-multipled by a */
+/* sequence of Jacobi rotations. */
+/* If JOBV .EQ. 'A' then MV rows of V are post-multipled by a */
+/* sequence of Jacobi rotations. */
+/* If JOBV = 'N', then V is not referenced. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V, LDV >= 1. */
+/* If JOBV = 'V', LDV .GE. N. */
+/* If JOBV = 'A', LDV .GE. MV. */
+
+/* EPS (input) INTEGER */
+/* EPS = SLAMCH('Epsilon') */
+
+/* SFMIN (input) INTEGER */
+/* SFMIN = SLAMCH('Safe Minimum') */
+
+/* TOL (input) REAL */
+/* TOL is the threshold for Jacobi rotations. For a pair */
+/* A(:,p), A(:,q) of pivot columns, the Jacobi rotation is */
+/* applied only if DABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL. */
+
+/* NSWEEP (input) INTEGER */
+/* NSWEEP is the number of sweeps of Jacobi rotations to be */
+/* performed. */
+
+/* WORK (workspace) REAL array, dimension LWORK. */
+
+/* LWORK (input) INTEGER */
+/* LWORK is the dimension of WORK. LWORK .GE. M. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit. */
+/* < 0 : if INFO = -i, then the i-th argument had an illegal value */
+
+/* -#- Local Parameters -#- */
+
+/* -#- Local Scalars -#- */
+
+
+/* Local Arrays */
+
+
+/* Intrinsic Functions */
+
+
+/* External Functions */
+
+
+/* External Subroutines */
+
+
+
+ /* Parameter adjustments */
+ --sva;
+ --d__;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --work;
+
+ /* Function Body */
+ applv = lsame_(jobv, "A");
+ rsvec = lsame_(jobv, "V");
+ if (! (rsvec || applv || lsame_(jobv, "N"))) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*n < 0 || *n > *m) {
+ *info = -3;
+ } else if (*n1 < 0) {
+ *info = -4;
+ } else if (*lda < *m) {
+ *info = -6;
+ } else if (*mv < 0) {
+ *info = -9;
+ } else if (*ldv < *m) {
+ *info = -11;
+ } else if (*tol <= *eps) {
+ *info = -14;
+ } else if (*nsweep < 0) {
+ *info = -15;
+ } else if (*lwork < *m) {
+ *info = -17;
+ } else {
+ *info = 0;
+ }
+
+/* #:( */
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGSVJ1", &i__1);
+ return 0;
+ }
+
+ if (rsvec) {
+ mvl = *n;
+ } else if (applv) {
+ mvl = *mv;
+ }
+ rsvec = rsvec || applv;
+ rooteps = sqrt(*eps);
+ rootsfmin = sqrt(*sfmin);
+ small = *sfmin / *eps;
+ big = 1. / *sfmin;
+ rootbig = 1. / rootsfmin;
+ large = big / sqrt((doublereal) (*m * *n));
+ bigtheta = 1. / rooteps;
+ roottol = sqrt(*tol);
+
+/* -#- Initialize the right singular vector matrix -#- */
+
+/* RSVEC = LSAME( JOBV, 'Y' ) */
+
+ emptsw = *n1 * (*n - *n1);
+ notrot = 0;
+ fastr[0] = 0.;
+
+/* -#- Row-cyclic pivot strategy with de Rijk's pivoting -#- */
+
+ kbl = min(8,*n);
+ nblr = *n1 / kbl;
+ if (nblr * kbl != *n1) {
+ ++nblr;
+ }
+/* .. the tiling is nblr-by-nblc [tiles] */
+ nblc = (*n - *n1) / kbl;
+ if (nblc * kbl != *n - *n1) {
+ ++nblc;
+ }
+/* Computing 2nd power */
+ i__1 = kbl;
+ blskip = i__1 * i__1 + 1;
+/* [TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. */
+ rowskip = min(5,kbl);
+/* [TP] ROWSKIP is a tuning parameter. */
+ swband = 0;
+/* [TP] SWBAND is a tuning parameter. It is meaningful and effective */
+/* if SGESVJ is used as a computational routine in the preconditioned */
+/* Jacobi SVD algorithm SGESVJ. */
+
+
+/* | * * * [x] [x] [x]| */
+/* | * * * [x] [x] [x]| Row-cycling in the nblr-by-nblc [x] blocks. */
+/* | * * * [x] [x] [x]| Row-cyclic pivoting inside each [x] block. */
+/* |[x] [x] [x] * * * | */
+/* |[x] [x] [x] * * * | */
+/* |[x] [x] [x] * * * | */
+
+
+ i__1 = *nsweep;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* .. go go go ... */
+
+ mxaapq = 0.;
+ mxsinj = 0.;
+ iswrot = 0;
+
+ notrot = 0;
+ pskipped = 0;
+
+ i__2 = nblr;
+ for (ibr = 1; ibr <= i__2; ++ibr) {
+ igl = (ibr - 1) * kbl + 1;
+
+
+/* ........................................................ */
+/* ... go to the off diagonal blocks */
+ igl = (ibr - 1) * kbl + 1;
+ i__3 = nblc;
+ for (jbc = 1; jbc <= i__3; ++jbc) {
+ jgl = *n1 + (jbc - 1) * kbl + 1;
+/* doing the block at ( ibr, jbc ) */
+ ijblsk = 0;
+/* Computing MIN */
+ i__5 = igl + kbl - 1;
+ i__4 = min(i__5,*n1);
+ for (p = igl; p <= i__4; ++p) {
+ aapp = sva[p];
+ if (aapp > 0.) {
+ pskipped = 0;
+/* Computing MIN */
+ i__6 = jgl + kbl - 1;
+ i__5 = min(i__6,*n);
+ for (q = jgl; q <= i__5; ++q) {
+
+ aaqq = sva[q];
+ if (aaqq > 0.) {
+ aapp0 = aapp;
+
+/* -#- M x 2 Jacobi SVD -#- */
+
+/* -#- Safe Gram matrix computation -#- */
+
+ if (aaqq >= 1.) {
+ if (aapp >= aaqq) {
+ rotok = small * aapp <= aaqq;
+ } else {
+ rotok = small * aaqq <= aapp;
+ }
+ if (aapp < big / aaqq) {
+ aapq = ddot_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1], &
+ c__1) * d__[p] * d__[q] /
+ aaqq / aapp;
+ } else {
+ dcopy_(m, &a[p * a_dim1 + 1], &c__1, &
+ work[1], &c__1);
+ dlascl_("G", &c__0, &c__0, &aapp, &
+ d__[p], m, &c__1, &work[1],
+ lda, &ierr);
+ aapq = ddot_(m, &work[1], &c__1, &a[q
+ * a_dim1 + 1], &c__1) * d__[q]
+ / aaqq;
+ }
+ } else {
+ if (aapp >= aaqq) {
+ rotok = aapp <= aaqq / small;
+ } else {
+ rotok = aaqq <= aapp / small;
+ }
+ if (aapp > small / aaqq) {
+ aapq = ddot_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1], &
+ c__1) * d__[p] * d__[q] /
+ aaqq / aapp;
+ } else {
+ dcopy_(m, &a[q * a_dim1 + 1], &c__1, &
+ work[1], &c__1);
+ dlascl_("G", &c__0, &c__0, &aaqq, &
+ d__[q], m, &c__1, &work[1],
+ lda, &ierr);
+ aapq = ddot_(m, &work[1], &c__1, &a[p
+ * a_dim1 + 1], &c__1) * d__[p]
+ / aapp;
+ }
+ }
+/* Computing MAX */
+ d__1 = mxaapq, d__2 = abs(aapq);
+ mxaapq = max(d__1,d__2);
+/* TO rotate or NOT to rotate, THAT is the question ... */
+
+ if (abs(aapq) > *tol) {
+ notrot = 0;
+/* ROTATED = ROTATED + 1 */
+ pskipped = 0;
+ ++iswrot;
+
+ if (rotok) {
+
+ aqoap = aaqq / aapp;
+ apoaq = aapp / aaqq;
+ theta = (d__1 = aqoap - apoaq, abs(
+ d__1)) * -.5 / aapq;
+ if (aaqq > aapp0) {
+ theta = -theta;
+ }
+ if (abs(theta) > bigtheta) {
+ t = .5 / theta;
+ fastr[2] = t * d__[p] / d__[q];
+ fastr[3] = -t * d__[q] / d__[p];
+ drotm_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1],
+ &c__1, fastr);
+ if (rsvec) {
+ drotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q *
+ v_dim1 + 1], &c__1, fastr);
+ }
+/* Computing MAX */
+ d__1 = 0., d__2 = t * apoaq *
+ aapq + 1.;
+ sva[q] = aaqq * sqrt((max(d__1,
+ d__2)));
+/* Computing MAX */
+ d__1 = 0., d__2 = 1. - t * aqoap *
+ aapq;
+ aapp *= sqrt((max(d__1,d__2)));
+/* Computing MAX */
+ d__1 = mxsinj, d__2 = abs(t);
+ mxsinj = max(d__1,d__2);
+ } else {
+
+/* .. choose correct signum for THETA and rotate */
+
+ thsign = -d_sign(&c_b35, &aapq);
+ if (aaqq > aapp0) {
+ thsign = -thsign;
+ }
+ t = 1. / (theta + thsign * sqrt(
+ theta * theta + 1.));
+ cs = sqrt(1. / (t * t + 1.));
+ sn = t * cs;
+/* Computing MAX */
+ d__1 = mxsinj, d__2 = abs(sn);
+ mxsinj = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = 0., d__2 = t * apoaq *
+ aapq + 1.;
+ sva[q] = aaqq * sqrt((max(d__1,
+ d__2)));
+ aapp *= sqrt(1. - t * aqoap *
+ aapq);
+ apoaq = d__[p] / d__[q];
+ aqoap = d__[q] / d__[p];
+ if (d__[p] >= 1.) {
+
+ if (d__[q] >= 1.) {
+ fastr[2] = t * apoaq;
+ fastr[3] = -t * aqoap;
+ d__[p] *= cs;
+ d__[q] *= cs;
+ drotm_(m, &a[p * a_dim1 + 1], &c__1, &a[q *
+ a_dim1 + 1], &c__1, fastr);
+ if (rsvec) {
+ drotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[
+ q * v_dim1 + 1], &c__1, fastr);
+ }
+ } else {
+ d__1 = -t * aqoap;
+ daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1, &a[
+ p * a_dim1 + 1], &c__1);
+ d__1 = cs * sn * apoaq;
+ daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1, &a[
+ q * a_dim1 + 1], &c__1);
+ if (rsvec) {
+ d__1 = -t * aqoap;
+ daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1], &
+ c__1, &v[p * v_dim1 + 1], &c__1);
+ d__1 = cs * sn * apoaq;
+ daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1], &
+ c__1, &v[q * v_dim1 + 1], &c__1);
+ }
+ d__[p] *= cs;
+ d__[q] /= cs;
+ }
+ } else {
+ if (d__[q] >= 1.) {
+ d__1 = t * apoaq;
+ daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1, &a[
+ q * a_dim1 + 1], &c__1);
+ d__1 = -cs * sn * aqoap;
+ daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1, &a[
+ p * a_dim1 + 1], &c__1);
+ if (rsvec) {
+ d__1 = t * apoaq;
+ daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1], &
+ c__1, &v[q * v_dim1 + 1], &c__1);
+ d__1 = -cs * sn * aqoap;
+ daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1], &
+ c__1, &v[p * v_dim1 + 1], &c__1);
+ }
+ d__[p] /= cs;
+ d__[q] *= cs;
+ } else {
+ if (d__[p] >= d__[q]) {
+ d__1 = -t * aqoap;
+ daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1);
+ d__1 = cs * sn * apoaq;
+ daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1);
+ d__[p] *= cs;
+ d__[q] /= cs;
+ if (rsvec) {
+ d__1 = -t * aqoap;
+ daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1],
+ &c__1, &v[p * v_dim1 + 1], &
+ c__1);
+ d__1 = cs * sn * apoaq;
+ daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1],
+ &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ }
+ } else {
+ d__1 = t * apoaq;
+ daxpy_(m, &d__1, &a[p * a_dim1 + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1);
+ d__1 = -cs * sn * aqoap;
+ daxpy_(m, &d__1, &a[q * a_dim1 + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1);
+ d__[p] /= cs;
+ d__[q] *= cs;
+ if (rsvec) {
+ d__1 = t * apoaq;
+ daxpy_(&mvl, &d__1, &v[p * v_dim1 + 1],
+ &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ d__1 = -cs * sn * aqoap;
+ daxpy_(&mvl, &d__1, &v[q * v_dim1 + 1],
+ &c__1, &v[p * v_dim1 + 1], &
+ c__1);
+ }
+ }
+ }
+ }
+ }
+ } else {
+ if (aapp > aaqq) {
+ dcopy_(m, &a[p * a_dim1 + 1], &
+ c__1, &work[1], &c__1);
+ dlascl_("G", &c__0, &c__0, &aapp,
+ &c_b35, m, &c__1, &work[1]
+, lda, &ierr);
+ dlascl_("G", &c__0, &c__0, &aaqq,
+ &c_b35, m, &c__1, &a[q *
+ a_dim1 + 1], lda, &ierr);
+ temp1 = -aapq * d__[p] / d__[q];
+ daxpy_(m, &temp1, &work[1], &c__1,
+ &a[q * a_dim1 + 1], &
+ c__1);
+ dlascl_("G", &c__0, &c__0, &c_b35,
+ &aaqq, m, &c__1, &a[q *
+ a_dim1 + 1], lda, &ierr);
+/* Computing MAX */
+ d__1 = 0., d__2 = 1. - aapq *
+ aapq;
+ sva[q] = aaqq * sqrt((max(d__1,
+ d__2)));
+ mxsinj = max(mxsinj,*sfmin);
+ } else {
+ dcopy_(m, &a[q * a_dim1 + 1], &
+ c__1, &work[1], &c__1);
+ dlascl_("G", &c__0, &c__0, &aaqq,
+ &c_b35, m, &c__1, &work[1]
+, lda, &ierr);
+ dlascl_("G", &c__0, &c__0, &aapp,
+ &c_b35, m, &c__1, &a[p *
+ a_dim1 + 1], lda, &ierr);
+ temp1 = -aapq * d__[q] / d__[p];
+ daxpy_(m, &temp1, &work[1], &c__1,
+ &a[p * a_dim1 + 1], &
+ c__1);
+ dlascl_("G", &c__0, &c__0, &c_b35,
+ &aapp, m, &c__1, &a[p *
+ a_dim1 + 1], lda, &ierr);
+/* Computing MAX */
+ d__1 = 0., d__2 = 1. - aapq *
+ aapq;
+ sva[p] = aapp * sqrt((max(d__1,
+ d__2)));
+ mxsinj = max(mxsinj,*sfmin);
+ }
+ }
+/* END IF ROTOK THEN ... ELSE */
+
+/* In the case of cancellation in updating SVA(q) */
+/* .. recompute SVA(q) */
+/* Computing 2nd power */
+ d__1 = sva[q] / aaqq;
+ if (d__1 * d__1 <= rooteps) {
+ if (aaqq < rootbig && aaqq >
+ rootsfmin) {
+ sva[q] = dnrm2_(m, &a[q * a_dim1
+ + 1], &c__1) * d__[q];
+ } else {
+ t = 0.;
+ aaqq = 0.;
+ dlassq_(m, &a[q * a_dim1 + 1], &
+ c__1, &t, &aaqq);
+ sva[q] = t * sqrt(aaqq) * d__[q];
+ }
+ }
+/* Computing 2nd power */
+ d__1 = aapp / aapp0;
+ if (d__1 * d__1 <= rooteps) {
+ if (aapp < rootbig && aapp >
+ rootsfmin) {
+ aapp = dnrm2_(m, &a[p * a_dim1 +
+ 1], &c__1) * d__[p];
+ } else {
+ t = 0.;
+ aapp = 0.;
+ dlassq_(m, &a[p * a_dim1 + 1], &
+ c__1, &t, &aapp);
+ aapp = t * sqrt(aapp) * d__[p];
+ }
+ sva[p] = aapp;
+ }
+/* end of OK rotation */
+ } else {
+ ++notrot;
+/* SKIPPED = SKIPPED + 1 */
+ ++pskipped;
+ ++ijblsk;
+ }
+ } else {
+ ++notrot;
+ ++pskipped;
+ ++ijblsk;
+ }
+/* IF ( NOTROT .GE. EMPTSW ) GO TO 2011 */
+ if (i__ <= swband && ijblsk >= blskip) {
+ sva[p] = aapp;
+ notrot = 0;
+ goto L2011;
+ }
+ if (i__ <= swband && pskipped > rowskip) {
+ aapp = -aapp;
+ notrot = 0;
+ goto L2203;
+ }
+
+/* L2200: */
+ }
+/* end of the q-loop */
+L2203:
+ sva[p] = aapp;
+
+ } else {
+ if (aapp == 0.) {
+/* Computing MIN */
+ i__5 = jgl + kbl - 1;
+ notrot = notrot + min(i__5,*n) - jgl + 1;
+ }
+ if (aapp < 0.) {
+ notrot = 0;
+ }
+/* ** IF ( NOTROT .GE. EMPTSW ) GO TO 2011 */
+ }
+/* L2100: */
+ }
+/* end of the p-loop */
+/* L2010: */
+ }
+/* end of the jbc-loop */
+L2011:
+/* 2011 bailed out of the jbc-loop */
+/* Computing MIN */
+ i__4 = igl + kbl - 1;
+ i__3 = min(i__4,*n);
+ for (p = igl; p <= i__3; ++p) {
+ sva[p] = (d__1 = sva[p], abs(d__1));
+/* L2012: */
+ }
+/* ** IF ( NOTROT .GE. EMPTSW ) GO TO 1994 */
+/* L2000: */
+ }
+/* 2000 :: end of the ibr-loop */
+
+/* .. update SVA(N) */
+ if (sva[*n] < rootbig && sva[*n] > rootsfmin) {
+ sva[*n] = dnrm2_(m, &a[*n * a_dim1 + 1], &c__1) * d__[*n];
+ } else {
+ t = 0.;
+ aapp = 0.;
+ dlassq_(m, &a[*n * a_dim1 + 1], &c__1, &t, &aapp);
+ sva[*n] = t * sqrt(aapp) * d__[*n];
+ }
+
+/* Additional steering devices */
+
+ if (i__ < swband && (mxaapq <= roottol || iswrot <= *n)) {
+ swband = i__;
+ }
+ if (i__ > swband + 1 && mxaapq < (doublereal) (*n) * *tol && (
+ doublereal) (*n) * mxaapq * mxsinj < *tol) {
+ goto L1994;
+ }
+
+ if (notrot >= emptsw) {
+ goto L1994;
+ }
+/* L1993: */
+ }
+/* end i=1:NSWEEP loop */
+/* #:) Reaching this point means that the procedure has completed the given */
+/* number of sweeps. */
+ *info = *nsweep - 1;
+ goto L1995;
+L1994:
+/* #:) Reaching this point means that during the i-th sweep all pivots were */
+/* below the given threshold, causing early exit. */
+ *info = 0;
+/* #:) INFO = 0 confirms successful iterations. */
+L1995:
+
+/* Sort the vector D */
+
+ i__1 = *n - 1;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = *n - p + 1;
+ q = idamax_(&i__2, &sva[p], &c__1) + p - 1;
+ if (p != q) {
+ temp1 = sva[p];
+ sva[p] = sva[q];
+ sva[q] = temp1;
+ temp1 = d__[p];
+ d__[p] = d__[q];
+ d__[q] = temp1;
+ dswap_(m, &a[p * a_dim1 + 1], &c__1, &a[q * a_dim1 + 1], &c__1);
+ if (rsvec) {
+ dswap_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ }
+ }
+/* L5991: */
+ }
+
+ return 0;
+/* .. */
+/* .. END OF DGSVJ1 */
+/* .. */
+} /* dgsvj1_ */
diff --git a/SRC/dgtcon.c b/SRC/dgtcon.c
new file mode 100644
index 0000000..ef4721d
--- /dev/null
+++ b/SRC/dgtcon.c
@@ -0,0 +1,209 @@
+/* dgtcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dgtcon_(char *norm, integer *n, doublereal *dl,
+ doublereal *d__, doublereal *du, doublereal *du2, integer *ipiv,
+ doublereal *anorm, doublereal *rcond, doublereal *work, integer *
+ iwork, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, kase, kase1;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *), xerbla_(char *,
+ integer *);
+ doublereal ainvnm;
+ logical onenrm;
+ extern /* Subroutine */ int dgttrs_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGTCON estimates the reciprocal of the condition number of a real */
+/* tridiagonal matrix A using the LU factorization as computed by */
+/* DGTTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* DL (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) multipliers that define the matrix L from the */
+/* LU factorization of A as computed by DGTTRF. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the upper triangular matrix U from */
+/* the LU factorization of A. */
+
+/* DU (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) elements of the first superdiagonal of U. */
+
+/* DU2 (input) DOUBLE PRECISION array, dimension (N-2) */
+/* The (n-2) elements of the second superdiagonal of U. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* ANORM (input) DOUBLE PRECISION */
+/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */
+/* If NORM = 'I', the infinity-norm of the original matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --ipiv;
+ --du2;
+ --du;
+ --d__;
+ --dl;
+
+ /* Function Body */
+ *info = 0;
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*anorm < 0.) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGTCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.;
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ } else if (*anorm == 0.) {
+ return 0;
+ }
+
+/* Check that D(1:N) is non-zero. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (d__[i__] == 0.) {
+ return 0;
+ }
+/* L10: */
+ }
+
+ ainvnm = 0.;
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kase = 0;
+L20:
+ dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(U)*inv(L). */
+
+ dgttrs_("No transpose", n, &c__1, &dl[1], &d__[1], &du[1], &du2[1]
+, &ipiv[1], &work[1], n, info);
+ } else {
+
+/* Multiply by inv(L')*inv(U'). */
+
+ dgttrs_("Transpose", n, &c__1, &dl[1], &d__[1], &du[1], &du2[1], &
+ ipiv[1], &work[1], n, info);
+ }
+ goto L20;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / ainvnm / *anorm;
+ }
+
+ return 0;
+
+/* End of DGTCON */
+
+} /* dgtcon_ */
diff --git a/SRC/dgtrfs.c b/SRC/dgtrfs.c
new file mode 100644
index 0000000..fa9a4c6
--- /dev/null
+++ b/SRC/dgtrfs.c
@@ -0,0 +1,451 @@
+/* dgtrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b18 = -1.;
+static doublereal c_b19 = 1.;
+
+/* Subroutine */ int dgtrfs_(char *trans, integer *n, integer *nrhs,
+ doublereal *dl, doublereal *d__, doublereal *du, doublereal *dlf,
+ doublereal *df, doublereal *duf, doublereal *du2, integer *ipiv,
+ doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
+ ferr, doublereal *berr, doublereal *work, integer *iwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal s;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *);
+ integer count;
+ extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlagtm_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+ char transn[1];
+ extern /* Subroutine */ int dgttrs_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *);
+ char transt[1];
+ doublereal lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGTRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is tridiagonal, and provides */
+/* error bounds and backward error estimates for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* DL (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of A. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* DU (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) superdiagonal elements of A. */
+
+/* DLF (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) multipliers that define the matrix L from the */
+/* LU factorization of A as computed by DGTTRF. */
+
+/* DF (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the upper triangular matrix U from */
+/* the LU factorization of A. */
+
+/* DUF (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) elements of the first superdiagonal of U. */
+
+/* DU2 (input) DOUBLE PRECISION array, dimension (N-2) */
+/* The (n-2) elements of the second superdiagonal of U. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by DGTTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ --dlf;
+ --df;
+ --duf;
+ --du2;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -13;
+ } else if (*ldx < max(1,*n)) {
+ *info = -15;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGTRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transn = 'N';
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transn = 'T';
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = 4;
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A, A**T, or A**H, depending on TRANS. */
+
+ dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+ dlagtm_(trans, n, &c__1, &c_b18, &dl[1], &d__[1], &du[1], &x[j *
+ x_dim1 + 1], ldx, &c_b19, &work[*n + 1], n);
+
+/* Compute abs(op(A))*abs(x) + abs(b) for use in the backward */
+/* error bound. */
+
+ if (notran) {
+ if (*n == 1) {
+ work[1] = (d__1 = b[j * b_dim1 + 1], abs(d__1)) + (d__2 = d__[
+ 1] * x[j * x_dim1 + 1], abs(d__2));
+ } else {
+ work[1] = (d__1 = b[j * b_dim1 + 1], abs(d__1)) + (d__2 = d__[
+ 1] * x[j * x_dim1 + 1], abs(d__2)) + (d__3 = du[1] *
+ x[j * x_dim1 + 2], abs(d__3));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)) + (
+ d__2 = dl[i__ - 1] * x[i__ - 1 + j * x_dim1], abs(
+ d__2)) + (d__3 = d__[i__] * x[i__ + j * x_dim1],
+ abs(d__3)) + (d__4 = du[i__] * x[i__ + 1 + j *
+ x_dim1], abs(d__4));
+/* L30: */
+ }
+ work[*n] = (d__1 = b[*n + j * b_dim1], abs(d__1)) + (d__2 =
+ dl[*n - 1] * x[*n - 1 + j * x_dim1], abs(d__2)) + (
+ d__3 = d__[*n] * x[*n + j * x_dim1], abs(d__3));
+ }
+ } else {
+ if (*n == 1) {
+ work[1] = (d__1 = b[j * b_dim1 + 1], abs(d__1)) + (d__2 = d__[
+ 1] * x[j * x_dim1 + 1], abs(d__2));
+ } else {
+ work[1] = (d__1 = b[j * b_dim1 + 1], abs(d__1)) + (d__2 = d__[
+ 1] * x[j * x_dim1 + 1], abs(d__2)) + (d__3 = dl[1] *
+ x[j * x_dim1 + 2], abs(d__3));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)) + (
+ d__2 = du[i__ - 1] * x[i__ - 1 + j * x_dim1], abs(
+ d__2)) + (d__3 = d__[i__] * x[i__ + j * x_dim1],
+ abs(d__3)) + (d__4 = dl[i__] * x[i__ + 1 + j *
+ x_dim1], abs(d__4));
+/* L40: */
+ }
+ work[*n] = (d__1 = b[*n + j * b_dim1], abs(d__1)) + (d__2 =
+ du[*n - 1] * x[*n - 1 + j * x_dim1], abs(d__2)) + (
+ d__3 = d__[*n] * x[*n + j * x_dim1], abs(d__3));
+ }
+ }
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[
+ i__];
+ s = max(d__2,d__3);
+ } else {
+/* Computing MAX */
+ d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1)
+ / (work[i__] + safe1);
+ s = max(d__2,d__3);
+ }
+/* L50: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ dgttrs_(trans, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[
+ 1], &work[*n + 1], n, info);
+ daxpy_(n, &c_b19, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
+ ;
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use DLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L60: */
+ }
+
+ kase = 0;
+L70:
+ dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+ kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)**T). */
+
+ dgttrs_(transt, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &
+ ipiv[1], &work[*n + 1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L80: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L90: */
+ }
+ dgttrs_(transn, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &
+ ipiv[1], &work[*n + 1], n, info);
+ }
+ goto L70;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1));
+ lstres = max(d__2,d__3);
+/* L100: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L110: */
+ }
+
+ return 0;
+
+/* End of DGTRFS */
+
+} /* dgtrfs_ */
diff --git a/SRC/dgtsv.c b/SRC/dgtsv.c
new file mode 100644
index 0000000..3d5995a
--- /dev/null
+++ b/SRC/dgtsv.c
@@ -0,0 +1,315 @@
+/* dgtsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgtsv_(integer *n, integer *nrhs, doublereal *dl,
+ doublereal *d__, doublereal *du, doublereal *b, integer *ldb, integer
+ *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal fact, temp;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGTSV solves the equation */
+
+/* A*X = B, */
+
+/* where A is an n by n tridiagonal matrix, by Gaussian elimination with */
+/* partial pivoting. */
+
+/* Note that the equation A'*X = B may be solved by interchanging the */
+/* order of the arguments DU and DL. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* DL (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* On entry, DL must contain the (n-1) sub-diagonal elements of */
+/* A. */
+
+/* On exit, DL is overwritten by the (n-2) elements of the */
+/* second super-diagonal of the upper triangular matrix U from */
+/* the LU factorization of A, in DL(1), ..., DL(n-2). */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, D must contain the diagonal elements of A. */
+
+/* On exit, D is overwritten by the n diagonal elements of U. */
+
+/* DU (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* On entry, DU must contain the (n-1) super-diagonal elements */
+/* of A. */
+
+/* On exit, DU is overwritten by the (n-1) elements of the first */
+/* super-diagonal of U. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the N by NRHS matrix of right hand side matrix B. */
+/* On exit, if INFO = 0, the N by NRHS solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero, and the solution */
+/* has not been computed. The factorization has not been */
+/* completed unless i = N. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGTSV ", &i__1);
+ return 0;
+ }
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*nrhs == 1) {
+ i__1 = *n - 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) {
+
+/* No row interchange required */
+
+ if (d__[i__] != 0.) {
+ fact = dl[i__] / d__[i__];
+ d__[i__ + 1] -= fact * du[i__];
+ b[i__ + 1 + b_dim1] -= fact * b[i__ + b_dim1];
+ } else {
+ *info = i__;
+ return 0;
+ }
+ dl[i__] = 0.;
+ } else {
+
+/* Interchange rows I and I+1 */
+
+ fact = d__[i__] / dl[i__];
+ d__[i__] = dl[i__];
+ temp = d__[i__ + 1];
+ d__[i__ + 1] = du[i__] - fact * temp;
+ dl[i__] = du[i__ + 1];
+ du[i__ + 1] = -fact * dl[i__];
+ du[i__] = temp;
+ temp = b[i__ + b_dim1];
+ b[i__ + b_dim1] = b[i__ + 1 + b_dim1];
+ b[i__ + 1 + b_dim1] = temp - fact * b[i__ + 1 + b_dim1];
+ }
+/* L10: */
+ }
+ if (*n > 1) {
+ i__ = *n - 1;
+ if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) {
+ if (d__[i__] != 0.) {
+ fact = dl[i__] / d__[i__];
+ d__[i__ + 1] -= fact * du[i__];
+ b[i__ + 1 + b_dim1] -= fact * b[i__ + b_dim1];
+ } else {
+ *info = i__;
+ return 0;
+ }
+ } else {
+ fact = d__[i__] / dl[i__];
+ d__[i__] = dl[i__];
+ temp = d__[i__ + 1];
+ d__[i__ + 1] = du[i__] - fact * temp;
+ du[i__] = temp;
+ temp = b[i__ + b_dim1];
+ b[i__ + b_dim1] = b[i__ + 1 + b_dim1];
+ b[i__ + 1 + b_dim1] = temp - fact * b[i__ + 1 + b_dim1];
+ }
+ }
+ if (d__[*n] == 0.) {
+ *info = *n;
+ return 0;
+ }
+ } else {
+ i__1 = *n - 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) {
+
+/* No row interchange required */
+
+ if (d__[i__] != 0.) {
+ fact = dl[i__] / d__[i__];
+ d__[i__ + 1] -= fact * du[i__];
+ i__2 = *nrhs;
+ for (j = 1; j <= i__2; ++j) {
+ b[i__ + 1 + j * b_dim1] -= fact * b[i__ + j * b_dim1];
+/* L20: */
+ }
+ } else {
+ *info = i__;
+ return 0;
+ }
+ dl[i__] = 0.;
+ } else {
+
+/* Interchange rows I and I+1 */
+
+ fact = d__[i__] / dl[i__];
+ d__[i__] = dl[i__];
+ temp = d__[i__ + 1];
+ d__[i__ + 1] = du[i__] - fact * temp;
+ dl[i__] = du[i__ + 1];
+ du[i__ + 1] = -fact * dl[i__];
+ du[i__] = temp;
+ i__2 = *nrhs;
+ for (j = 1; j <= i__2; ++j) {
+ temp = b[i__ + j * b_dim1];
+ b[i__ + j * b_dim1] = b[i__ + 1 + j * b_dim1];
+ b[i__ + 1 + j * b_dim1] = temp - fact * b[i__ + 1 + j *
+ b_dim1];
+/* L30: */
+ }
+ }
+/* L40: */
+ }
+ if (*n > 1) {
+ i__ = *n - 1;
+ if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) {
+ if (d__[i__] != 0.) {
+ fact = dl[i__] / d__[i__];
+ d__[i__ + 1] -= fact * du[i__];
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ b[i__ + 1 + j * b_dim1] -= fact * b[i__ + j * b_dim1];
+/* L50: */
+ }
+ } else {
+ *info = i__;
+ return 0;
+ }
+ } else {
+ fact = d__[i__] / dl[i__];
+ d__[i__] = dl[i__];
+ temp = d__[i__ + 1];
+ d__[i__ + 1] = du[i__] - fact * temp;
+ du[i__] = temp;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ temp = b[i__ + j * b_dim1];
+ b[i__ + j * b_dim1] = b[i__ + 1 + j * b_dim1];
+ b[i__ + 1 + j * b_dim1] = temp - fact * b[i__ + 1 + j *
+ b_dim1];
+/* L60: */
+ }
+ }
+ }
+ if (d__[*n] == 0.) {
+ *info = *n;
+ return 0;
+ }
+ }
+
+/* Back solve with the matrix U from the factorization. */
+
+ if (*nrhs <= 2) {
+ j = 1;
+L70:
+ b[*n + j * b_dim1] /= d__[*n];
+ if (*n > 1) {
+ b[*n - 1 + j * b_dim1] = (b[*n - 1 + j * b_dim1] - du[*n - 1] * b[
+ *n + j * b_dim1]) / d__[*n - 1];
+ }
+ for (i__ = *n - 2; i__ >= 1; --i__) {
+ b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__] * b[i__ + 1
+ + j * b_dim1] - dl[i__] * b[i__ + 2 + j * b_dim1]) / d__[
+ i__];
+/* L80: */
+ }
+ if (j < *nrhs) {
+ ++j;
+ goto L70;
+ }
+ } else {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ b[*n + j * b_dim1] /= d__[*n];
+ if (*n > 1) {
+ b[*n - 1 + j * b_dim1] = (b[*n - 1 + j * b_dim1] - du[*n - 1]
+ * b[*n + j * b_dim1]) / d__[*n - 1];
+ }
+ for (i__ = *n - 2; i__ >= 1; --i__) {
+ b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__] * b[i__
+ + 1 + j * b_dim1] - dl[i__] * b[i__ + 2 + j * b_dim1])
+ / d__[i__];
+/* L90: */
+ }
+/* L100: */
+ }
+ }
+
+ return 0;
+
+/* End of DGTSV */
+
+} /* dgtsv_ */
diff --git a/SRC/dgtsvx.c b/SRC/dgtsvx.c
new file mode 100644
index 0000000..807c6e8
--- /dev/null
+++ b/SRC/dgtsvx.c
@@ -0,0 +1,349 @@
+/* dgtsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dgtsvx_(char *fact, char *trans, integer *n, integer *
+ nrhs, doublereal *dl, doublereal *d__, doublereal *du, doublereal *
+ dlf, doublereal *df, doublereal *duf, doublereal *du2, integer *ipiv,
+ doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
+ rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *
+ iwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+
+ /* Local variables */
+ char norm[1];
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlangt_(char *, integer *,
+ doublereal *, doublereal *, doublereal *);
+ logical nofact;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *), dgtcon_(char *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *), dgtrfs_(char *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *), dgttrf_(integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *);
+ logical notran;
+ extern /* Subroutine */ int dgttrs_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGTSVX uses the LU factorization to compute the solution to a real */
+/* system of linear equations A * X = B or A**T * X = B, */
+/* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS */
+/* matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A */
+/* as A = L * U, where L is a product of permutation and unit lower */
+/* bidiagonal matrices and U is upper triangular with nonzeros in */
+/* only the main diagonal and first two superdiagonals. */
+
+/* 2. If some U(i,i)=0, so that U is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 3. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 4. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of A has been */
+/* supplied on entry. */
+/* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored */
+/* form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV */
+/* will not be modified. */
+/* = 'N': The matrix will be copied to DLF, DF, and DUF */
+/* and factored. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* DL (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of A. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of A. */
+
+/* DU (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) superdiagonal elements of A. */
+
+/* DLF (input or output) DOUBLE PRECISION array, dimension (N-1) */
+/* If FACT = 'F', then DLF is an input argument and on entry */
+/* contains the (n-1) multipliers that define the matrix L from */
+/* the LU factorization of A as computed by DGTTRF. */
+
+/* If FACT = 'N', then DLF is an output argument and on exit */
+/* contains the (n-1) multipliers that define the matrix L from */
+/* the LU factorization of A. */
+
+/* DF (input or output) DOUBLE PRECISION array, dimension (N) */
+/* If FACT = 'F', then DF is an input argument and on entry */
+/* contains the n diagonal elements of the upper triangular */
+/* matrix U from the LU factorization of A. */
+
+/* If FACT = 'N', then DF is an output argument and on exit */
+/* contains the n diagonal elements of the upper triangular */
+/* matrix U from the LU factorization of A. */
+
+/* DUF (input or output) DOUBLE PRECISION array, dimension (N-1) */
+/* If FACT = 'F', then DUF is an input argument and on entry */
+/* contains the (n-1) elements of the first superdiagonal of U. */
+
+/* If FACT = 'N', then DUF is an output argument and on exit */
+/* contains the (n-1) elements of the first superdiagonal of U. */
+
+/* DU2 (input or output) DOUBLE PRECISION array, dimension (N-2) */
+/* If FACT = 'F', then DU2 is an input argument and on entry */
+/* contains the (n-2) elements of the second superdiagonal of */
+/* U. */
+
+/* If FACT = 'N', then DU2 is an output argument and on exit */
+/* contains the (n-2) elements of the second superdiagonal of */
+/* U. */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains the pivot indices from the LU factorization of A as */
+/* computed by DGTTRF. */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the LU factorization of A; */
+/* row i of the matrix was interchanged with row IPIV(i). */
+/* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates */
+/* a row interchange was not required. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A. If RCOND is less than the machine precision (in */
+/* particular, if RCOND = 0), the matrix is singular to working */
+/* precision. This condition is indicated by a return code of */
+/* INFO > 0. */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: U(i,i) is exactly zero. The factorization */
+/* has not been completed unless i = N, but the */
+/* factor U is exactly singular, so the solution */
+/* and error bounds could not be computed. */
+/* RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ --dlf;
+ --df;
+ --duf;
+ --du2;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ notran = lsame_(trans, "N");
+ if (! nofact && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -14;
+ } else if (*ldx < max(1,*n)) {
+ *info = -16;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGTSVX", &i__1);
+ return 0;
+ }
+
+ if (nofact) {
+
+/* Compute the LU factorization of A. */
+
+ dcopy_(n, &d__[1], &c__1, &df[1], &c__1);
+ if (*n > 1) {
+ i__1 = *n - 1;
+ dcopy_(&i__1, &dl[1], &c__1, &dlf[1], &c__1);
+ i__1 = *n - 1;
+ dcopy_(&i__1, &du[1], &c__1, &duf[1], &c__1);
+ }
+ dgttrf_(n, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ if (notran) {
+ *(unsigned char *)norm = '1';
+ } else {
+ *(unsigned char *)norm = 'I';
+ }
+ anorm = dlangt_(norm, n, &dl[1], &d__[1], &du[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ dgtcon_(norm, n, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], &anorm,
+ rcond, &work[1], &iwork[1], info);
+
+/* Compute the solution vectors X. */
+
+ dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ dgttrs_(trans, n, nrhs, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], &x[
+ x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solutions and */
+/* compute error bounds and backward error estimates for them. */
+
+ dgtrfs_(trans, n, nrhs, &dl[1], &d__[1], &du[1], &dlf[1], &df[1], &duf[1],
+ &du2[1], &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1]
+, &berr[1], &work[1], &iwork[1], info);
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < dlamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of DGTSVX */
+
+} /* dgtsvx_ */
diff --git a/SRC/dgttrf.c b/SRC/dgttrf.c
new file mode 100644
index 0000000..510bc02
--- /dev/null
+++ b/SRC/dgttrf.c
@@ -0,0 +1,203 @@
+/* dgttrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgttrf_(integer *n, doublereal *dl, doublereal *d__,
+ doublereal *du, doublereal *du2, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer i__;
+ doublereal fact, temp;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGTTRF computes an LU factorization of a real tridiagonal matrix A */
+/* using elimination with partial pivoting and row interchanges. */
+
+/* The factorization has the form */
+/* A = L * U */
+/* where L is a product of permutation and unit lower bidiagonal */
+/* matrices and U is upper triangular with nonzeros in only the main */
+/* diagonal and first two superdiagonals. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* DL (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* On entry, DL must contain the (n-1) sub-diagonal elements of */
+/* A. */
+
+/* On exit, DL is overwritten by the (n-1) multipliers that */
+/* define the matrix L from the LU factorization of A. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, D must contain the diagonal elements of A. */
+
+/* On exit, D is overwritten by the n diagonal elements of the */
+/* upper triangular matrix U from the LU factorization of A. */
+
+/* DU (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* On entry, DU must contain the (n-1) super-diagonal elements */
+/* of A. */
+
+/* On exit, DU is overwritten by the (n-1) elements of the first */
+/* super-diagonal of U. */
+
+/* DU2 (output) DOUBLE PRECISION array, dimension (N-2) */
+/* On exit, DU2 is overwritten by the (n-2) elements of the */
+/* second super-diagonal of U. */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, U(k,k) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ipiv;
+ --du2;
+ --du;
+ --d__;
+ --dl;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ i__1 = -(*info);
+ xerbla_("DGTTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Initialize IPIV(i) = i and DU2(I) = 0 */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ipiv[i__] = i__;
+/* L10: */
+ }
+ i__1 = *n - 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ du2[i__] = 0.;
+/* L20: */
+ }
+
+ i__1 = *n - 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) {
+
+/* No row interchange required, eliminate DL(I) */
+
+ if (d__[i__] != 0.) {
+ fact = dl[i__] / d__[i__];
+ dl[i__] = fact;
+ d__[i__ + 1] -= fact * du[i__];
+ }
+ } else {
+
+/* Interchange rows I and I+1, eliminate DL(I) */
+
+ fact = d__[i__] / dl[i__];
+ d__[i__] = dl[i__];
+ dl[i__] = fact;
+ temp = du[i__];
+ du[i__] = d__[i__ + 1];
+ d__[i__ + 1] = temp - fact * d__[i__ + 1];
+ du2[i__] = du[i__ + 1];
+ du[i__ + 1] = -fact * du[i__ + 1];
+ ipiv[i__] = i__ + 1;
+ }
+/* L30: */
+ }
+ if (*n > 1) {
+ i__ = *n - 1;
+ if ((d__1 = d__[i__], abs(d__1)) >= (d__2 = dl[i__], abs(d__2))) {
+ if (d__[i__] != 0.) {
+ fact = dl[i__] / d__[i__];
+ dl[i__] = fact;
+ d__[i__ + 1] -= fact * du[i__];
+ }
+ } else {
+ fact = d__[i__] / dl[i__];
+ d__[i__] = dl[i__];
+ dl[i__] = fact;
+ temp = du[i__];
+ du[i__] = d__[i__ + 1];
+ d__[i__ + 1] = temp - fact * d__[i__ + 1];
+ ipiv[i__] = i__ + 1;
+ }
+ }
+
+/* Check for a zero on the diagonal of U. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (d__[i__] == 0.) {
+ *info = i__;
+ goto L50;
+ }
+/* L40: */
+ }
+L50:
+
+ return 0;
+
+/* End of DGTTRF */
+
+} /* dgttrf_ */
diff --git a/SRC/dgttrs.c b/SRC/dgttrs.c
new file mode 100644
index 0000000..7b4c5b3
--- /dev/null
+++ b/SRC/dgttrs.c
@@ -0,0 +1,189 @@
+/* dgttrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dgttrs_(char *trans, integer *n, integer *nrhs,
+ doublereal *dl, doublereal *d__, doublereal *du, doublereal *du2,
+ integer *ipiv, doublereal *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer j, jb, nb;
+ extern /* Subroutine */ int dgtts2_(integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer itrans;
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGTTRS solves one of the systems of equations */
+/* A*X = B or A'*X = B, */
+/* with a tridiagonal matrix A using the LU factorization computed */
+/* by DGTTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A'* X = B (Transpose) */
+/* = 'C': A'* X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* DL (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) multipliers that define the matrix L from the */
+/* LU factorization of A. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the upper triangular matrix U from */
+/* the LU factorization of A. */
+
+/* DU (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) elements of the first super-diagonal of U. */
+
+/* DU2 (input) DOUBLE PRECISION array, dimension (N-2) */
+/* The (n-2) elements of the second super-diagonal of U. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the matrix of right hand side vectors B. */
+/* On exit, B is overwritten by the solution vectors X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ --du2;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ notran = *(unsigned char *)trans == 'N' || *(unsigned char *)trans == 'n';
+ if (! notran && ! (*(unsigned char *)trans == 'T' || *(unsigned char *)
+ trans == 't') && ! (*(unsigned char *)trans == 'C' || *(unsigned
+ char *)trans == 'c')) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(*n,1)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGTTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+/* Decode TRANS */
+
+ if (notran) {
+ itrans = 0;
+ } else {
+ itrans = 1;
+ }
+
+/* Determine the number of right-hand sides to solve at a time. */
+
+ if (*nrhs == 1) {
+ nb = 1;
+ } else {
+/* Computing MAX */
+ i__1 = 1, i__2 = ilaenv_(&c__1, "DGTTRS", trans, n, nrhs, &c_n1, &
+ c_n1);
+ nb = max(i__1,i__2);
+ }
+
+ if (nb >= *nrhs) {
+ dgtts2_(&itrans, n, nrhs, &dl[1], &d__[1], &du[1], &du2[1], &ipiv[1],
+ &b[b_offset], ldb);
+ } else {
+ i__1 = *nrhs;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = *nrhs - j + 1;
+ jb = min(i__3,nb);
+ dgtts2_(&itrans, n, &jb, &dl[1], &d__[1], &du[1], &du2[1], &ipiv[
+ 1], &b[j * b_dim1 + 1], ldb);
+/* L10: */
+ }
+ }
+
+/* End of DGTTRS */
+
+ return 0;
+} /* dgttrs_ */
diff --git a/SRC/dgtts2.c b/SRC/dgtts2.c
new file mode 100644
index 0000000..fce9cc8
--- /dev/null
+++ b/SRC/dgtts2.c
@@ -0,0 +1,261 @@
+/* dgtts2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgtts2_(integer *itrans, integer *n, integer *nrhs,
+ doublereal *dl, doublereal *d__, doublereal *du, doublereal *du2,
+ integer *ipiv, doublereal *b, integer *ldb)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, ip;
+ doublereal temp;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGTTS2 solves one of the systems of equations */
+/* A*X = B or A'*X = B, */
+/* with a tridiagonal matrix A using the LU factorization computed */
+/* by DGTTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* ITRANS (input) INTEGER */
+/* Specifies the form of the system of equations. */
+/* = 0: A * X = B (No transpose) */
+/* = 1: A'* X = B (Transpose) */
+/* = 2: A'* X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* DL (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) multipliers that define the matrix L from the */
+/* LU factorization of A. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the upper triangular matrix U from */
+/* the LU factorization of A. */
+
+/* DU (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) elements of the first super-diagonal of U. */
+
+/* DU2 (input) DOUBLE PRECISION array, dimension (N-2) */
+/* The (n-2) elements of the second super-diagonal of U. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the matrix of right hand side vectors B. */
+/* On exit, B is overwritten by the solution vectors X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ --du2;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (*itrans == 0) {
+
+/* Solve A*X = B using the LU factorization of A, */
+/* overwriting each right hand side vector with its solution. */
+
+ if (*nrhs <= 1) {
+ j = 1;
+L10:
+
+/* Solve L*x = b. */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ip = ipiv[i__];
+ temp = b[i__ + 1 - ip + i__ + j * b_dim1] - dl[i__] * b[ip +
+ j * b_dim1];
+ b[i__ + j * b_dim1] = b[ip + j * b_dim1];
+ b[i__ + 1 + j * b_dim1] = temp;
+/* L20: */
+ }
+
+/* Solve U*x = b. */
+
+ b[*n + j * b_dim1] /= d__[*n];
+ if (*n > 1) {
+ b[*n - 1 + j * b_dim1] = (b[*n - 1 + j * b_dim1] - du[*n - 1]
+ * b[*n + j * b_dim1]) / d__[*n - 1];
+ }
+ for (i__ = *n - 2; i__ >= 1; --i__) {
+ b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__] * b[i__
+ + 1 + j * b_dim1] - du2[i__] * b[i__ + 2 + j * b_dim1]
+ ) / d__[i__];
+/* L30: */
+ }
+ if (j < *nrhs) {
+ ++j;
+ goto L10;
+ }
+ } else {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve L*x = b. */
+
+ i__2 = *n - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (ipiv[i__] == i__) {
+ b[i__ + 1 + j * b_dim1] -= dl[i__] * b[i__ + j *
+ b_dim1];
+ } else {
+ temp = b[i__ + j * b_dim1];
+ b[i__ + j * b_dim1] = b[i__ + 1 + j * b_dim1];
+ b[i__ + 1 + j * b_dim1] = temp - dl[i__] * b[i__ + j *
+ b_dim1];
+ }
+/* L40: */
+ }
+
+/* Solve U*x = b. */
+
+ b[*n + j * b_dim1] /= d__[*n];
+ if (*n > 1) {
+ b[*n - 1 + j * b_dim1] = (b[*n - 1 + j * b_dim1] - du[*n
+ - 1] * b[*n + j * b_dim1]) / d__[*n - 1];
+ }
+ for (i__ = *n - 2; i__ >= 1; --i__) {
+ b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__] * b[
+ i__ + 1 + j * b_dim1] - du2[i__] * b[i__ + 2 + j *
+ b_dim1]) / d__[i__];
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+ } else {
+
+/* Solve A' * X = B. */
+
+ if (*nrhs <= 1) {
+
+/* Solve U'*x = b. */
+
+ j = 1;
+L70:
+ b[j * b_dim1 + 1] /= d__[1];
+ if (*n > 1) {
+ b[j * b_dim1 + 2] = (b[j * b_dim1 + 2] - du[1] * b[j * b_dim1
+ + 1]) / d__[2];
+ }
+ i__1 = *n;
+ for (i__ = 3; i__ <= i__1; ++i__) {
+ b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__ - 1] * b[
+ i__ - 1 + j * b_dim1] - du2[i__ - 2] * b[i__ - 2 + j *
+ b_dim1]) / d__[i__];
+/* L80: */
+ }
+
+/* Solve L'*x = b. */
+
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ ip = ipiv[i__];
+ temp = b[i__ + j * b_dim1] - dl[i__] * b[i__ + 1 + j * b_dim1]
+ ;
+ b[i__ + j * b_dim1] = b[ip + j * b_dim1];
+ b[ip + j * b_dim1] = temp;
+/* L90: */
+ }
+ if (j < *nrhs) {
+ ++j;
+ goto L70;
+ }
+
+ } else {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve U'*x = b. */
+
+ b[j * b_dim1 + 1] /= d__[1];
+ if (*n > 1) {
+ b[j * b_dim1 + 2] = (b[j * b_dim1 + 2] - du[1] * b[j *
+ b_dim1 + 1]) / d__[2];
+ }
+ i__2 = *n;
+ for (i__ = 3; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__ - 1] *
+ b[i__ - 1 + j * b_dim1] - du2[i__ - 2] * b[i__ -
+ 2 + j * b_dim1]) / d__[i__];
+/* L100: */
+ }
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ if (ipiv[i__] == i__) {
+ b[i__ + j * b_dim1] -= dl[i__] * b[i__ + 1 + j *
+ b_dim1];
+ } else {
+ temp = b[i__ + 1 + j * b_dim1];
+ b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - dl[
+ i__] * temp;
+ b[i__ + j * b_dim1] = temp;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+ }
+ }
+
+/* End of DGTTS2 */
+
+ return 0;
+} /* dgtts2_ */
diff --git a/SRC/dhgeqz.c b/SRC/dhgeqz.c
new file mode 100644
index 0000000..b594c95
--- /dev/null
+++ b/SRC/dhgeqz.c
@@ -0,0 +1,1498 @@
+/* dhgeqz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b12 = 0.;
+static doublereal c_b13 = 1.;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int dhgeqz_(char *job, char *compq, char *compz, integer *n,
+ integer *ilo, integer *ihi, doublereal *h__, integer *ldh, doublereal
+ *t, integer *ldt, doublereal *alphar, doublereal *alphai, doublereal *
+ beta, doublereal *q, integer *ldq, doublereal *z__, integer *ldz,
+ doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, q_dim1, q_offset, t_dim1, t_offset, z_dim1,
+ z_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal c__;
+ integer j;
+ doublereal s, v[3], s1, s2, t1, u1, u2, a11, a12, a21, a22, b11, b22, c12,
+ c21;
+ integer jc;
+ doublereal an, bn, cl, cq, cr;
+ integer in;
+ doublereal u12, w11, w12, w21;
+ integer jr;
+ doublereal cz, w22, sl, wi, sr, vs, wr, b1a, b2a, a1i, a2i, b1i, b2i, a1r,
+ a2r, b1r, b2r, wr2, ad11, ad12, ad21, ad22, c11i, c22i;
+ integer jch;
+ doublereal c11r, c22r;
+ logical ilq;
+ doublereal u12l, tau, sqi;
+ logical ilz;
+ doublereal ulp, sqr, szi, szr, ad11l, ad12l, ad21l, ad22l, ad32l, wabs,
+ atol, btol, temp;
+ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *), dlag2_(
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *);
+ doublereal temp2, s1inv, scale;
+ extern logical lsame_(char *, char *);
+ integer iiter, ilast, jiter;
+ doublereal anorm, bnorm;
+ integer maxit;
+ doublereal tempi, tempr;
+ extern doublereal dlapy2_(doublereal *, doublereal *), dlapy3_(doublereal
+ *, doublereal *, doublereal *);
+ extern /* Subroutine */ int dlasv2_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *);
+ logical ilazr2;
+ doublereal ascale, bscale;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *);
+ extern doublereal dlanhs_(char *, integer *, doublereal *, integer *,
+ doublereal *);
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ doublereal safmin;
+ extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *);
+ doublereal safmax;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal eshift;
+ logical ilschr;
+ integer icompq, ilastm, ischur;
+ logical ilazro;
+ integer icompz, ifirst, ifrstm, istart;
+ logical ilpivt, lquery;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/* -- April 2009 -- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DHGEQZ computes the eigenvalues of a real matrix pair (H,T), */
+/* where H is an upper Hessenberg matrix and T is upper triangular, */
+/* using the double-shift QZ method. */
+/* Matrix pairs of this type are produced by the reduction to */
+/* generalized upper Hessenberg form of a real matrix pair (A,B): */
+
+/* A = Q1*H*Z1**T, B = Q1*T*Z1**T, */
+
+/* as computed by DGGHRD. */
+
+/* If JOB='S', then the Hessenberg-triangular pair (H,T) is */
+/* also reduced to generalized Schur form, */
+
+/* H = Q*S*Z**T, T = Q*P*Z**T, */
+
+/* where Q and Z are orthogonal matrices, P is an upper triangular */
+/* matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2 */
+/* diagonal blocks. */
+
+/* The 1-by-1 blocks correspond to real eigenvalues of the matrix pair */
+/* (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of */
+/* eigenvalues. */
+
+/* Additionally, the 2-by-2 upper triangular diagonal blocks of P */
+/* corresponding to 2-by-2 blocks of S are reduced to positive diagonal */
+/* form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0, */
+/* P(j,j) > 0, and P(j+1,j+1) > 0. */
+
+/* Optionally, the orthogonal matrix Q from the generalized Schur */
+/* factorization may be postmultiplied into an input matrix Q1, and the */
+/* orthogonal matrix Z may be postmultiplied into an input matrix Z1. */
+/* If Q1 and Z1 are the orthogonal matrices from DGGHRD that reduced */
+/* the matrix pair (A,B) to generalized upper Hessenberg form, then the */
+/* output matrices Q1*Q and Z1*Z are the orthogonal factors from the */
+/* generalized Schur factorization of (A,B): */
+
+/* A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T. */
+
+/* To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently, */
+/* of (A,B)) are computed as a pair of values (alpha,beta), where alpha is */
+/* complex and beta real. */
+/* If beta is nonzero, lambda = alpha / beta is an eigenvalue of the */
+/* generalized nonsymmetric eigenvalue problem (GNEP) */
+/* A*x = lambda*B*x */
+/* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the */
+/* alternate form of the GNEP */
+/* mu*A*y = B*y. */
+/* Real eigenvalues can be read directly from the generalized Schur */
+/* form: */
+/* alpha = S(i,i), beta = P(i,i). */
+
+/* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix */
+/* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), */
+/* pp. 241--256. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* = 'E': Compute eigenvalues only; */
+/* = 'S': Compute eigenvalues and the Schur form. */
+
+/* COMPQ (input) CHARACTER*1 */
+/* = 'N': Left Schur vectors (Q) are not computed; */
+/* = 'I': Q is initialized to the unit matrix and the matrix Q */
+/* of left Schur vectors of (H,T) is returned; */
+/* = 'V': Q must contain an orthogonal matrix Q1 on entry and */
+/* the product Q1*Q is returned. */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': Right Schur vectors (Z) are not computed; */
+/* = 'I': Z is initialized to the unit matrix and the matrix Z */
+/* of right Schur vectors of (H,T) is returned; */
+/* = 'V': Z must contain an orthogonal matrix Z1 on entry and */
+/* the product Z1*Z is returned. */
+
+/* N (input) INTEGER */
+/* The order of the matrices H, T, Q, and Z. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* ILO and IHI mark the rows and columns of H which are in */
+/* Hessenberg form. It is assumed that A is already upper */
+/* triangular in rows and columns 1:ILO-1 and IHI+1:N. */
+/* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. */
+
+/* H (input/output) DOUBLE PRECISION array, dimension (LDH, N) */
+/* On entry, the N-by-N upper Hessenberg matrix H. */
+/* On exit, if JOB = 'S', H contains the upper quasi-triangular */
+/* matrix S from the generalized Schur factorization; */
+/* 2-by-2 diagonal blocks (corresponding to complex conjugate */
+/* pairs of eigenvalues) are returned in standard form, with */
+/* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. */
+/* If JOB = 'E', the diagonal blocks of H match those of S, but */
+/* the rest of H is unspecified. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH >= max( 1, N ). */
+
+/* T (input/output) DOUBLE PRECISION array, dimension (LDT, N) */
+/* On entry, the N-by-N upper triangular matrix T. */
+/* On exit, if JOB = 'S', T contains the upper triangular */
+/* matrix P from the generalized Schur factorization; */
+/* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S */
+/* are reduced to positive diagonal form, i.e., if H(j+1,j) is */
+/* non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and */
+/* T(j+1,j+1) > 0. */
+/* If JOB = 'E', the diagonal blocks of T match those of P, but */
+/* the rest of T is unspecified. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= max( 1, N ). */
+
+/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */
+/* The real parts of each scalar alpha defining an eigenvalue */
+/* of GNEP. */
+
+/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */
+/* The imaginary parts of each scalar alpha defining an */
+/* eigenvalue of GNEP. */
+/* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */
+/* positive, then the j-th and (j+1)-st eigenvalues are a */
+/* complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j). */
+
+/* BETA (output) DOUBLE PRECISION array, dimension (N) */
+/* The scalars beta that define the eigenvalues of GNEP. */
+/* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and */
+/* beta = BETA(j) represent the j-th eigenvalue of the matrix */
+/* pair (A,B), in one of the forms lambda = alpha/beta or */
+/* mu = beta/alpha. Since either lambda or mu may overflow, */
+/* they should not, in general, be computed. */
+
+/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) */
+/* On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in */
+/* the reduction of (A,B) to generalized Hessenberg form. */
+/* On exit, if COMPZ = 'I', the orthogonal matrix of left Schur */
+/* vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix */
+/* of left Schur vectors of (A,B). */
+/* Not referenced if COMPZ = 'N'. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= 1. */
+/* If COMPQ='V' or 'I', then LDQ >= N. */
+
+/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) */
+/* On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in */
+/* the reduction of (A,B) to generalized Hessenberg form. */
+/* On exit, if COMPZ = 'I', the orthogonal matrix of */
+/* right Schur vectors of (H,T), and if COMPZ = 'V', the */
+/* orthogonal matrix of right Schur vectors of (A,B). */
+/* Not referenced if COMPZ = 'N'. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1. */
+/* If COMPZ='V' or 'I', then LDZ >= N. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* = 1,...,N: the QZ iteration did not converge. (H,T) is not */
+/* in Schur form, but ALPHAR(i), ALPHAI(i), and */
+/* BETA(i), i=INFO+1,...,N should be correct. */
+/* = N+1,...,2*N: the shift calculation failed. (H,T) is not */
+/* in Schur form, but ALPHAR(i), ALPHAI(i), and */
+/* BETA(i), i=INFO-N+1,...,N should be correct. */
+
+/* Further Details */
+/* =============== */
+
+/* Iteration counters: */
+
+/* JITER -- counts iterations. */
+/* IITER -- counts iterations run since ILAST was last */
+/* changed. This is therefore reset only when a 1-by-1 or */
+/* 2-by-2 block deflates off the bottom. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* $ SAFETY = 1.0E+0 ) */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode JOB, COMPQ, COMPZ */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ if (lsame_(job, "E")) {
+ ilschr = FALSE_;
+ ischur = 1;
+ } else if (lsame_(job, "S")) {
+ ilschr = TRUE_;
+ ischur = 2;
+ } else {
+ ischur = 0;
+ }
+
+ if (lsame_(compq, "N")) {
+ ilq = FALSE_;
+ icompq = 1;
+ } else if (lsame_(compq, "V")) {
+ ilq = TRUE_;
+ icompq = 2;
+ } else if (lsame_(compq, "I")) {
+ ilq = TRUE_;
+ icompq = 3;
+ } else {
+ icompq = 0;
+ }
+
+ if (lsame_(compz, "N")) {
+ ilz = FALSE_;
+ icompz = 1;
+ } else if (lsame_(compz, "V")) {
+ ilz = TRUE_;
+ icompz = 2;
+ } else if (lsame_(compz, "I")) {
+ ilz = TRUE_;
+ icompz = 3;
+ } else {
+ icompz = 0;
+ }
+
+/* Check Argument Values */
+
+ *info = 0;
+ work[1] = (doublereal) max(1,*n);
+ lquery = *lwork == -1;
+ if (ischur == 0) {
+ *info = -1;
+ } else if (icompq == 0) {
+ *info = -2;
+ } else if (icompz == 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ilo < 1) {
+ *info = -5;
+ } else if (*ihi > *n || *ihi < *ilo - 1) {
+ *info = -6;
+ } else if (*ldh < *n) {
+ *info = -8;
+ } else if (*ldt < *n) {
+ *info = -10;
+ } else if (*ldq < 1 || ilq && *ldq < *n) {
+ *info = -15;
+ } else if (*ldz < 1 || ilz && *ldz < *n) {
+ *info = -17;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -19;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DHGEQZ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ work[1] = 1.;
+ return 0;
+ }
+
+/* Initialize Q and Z */
+
+ if (icompq == 3) {
+ dlaset_("Full", n, n, &c_b12, &c_b13, &q[q_offset], ldq);
+ }
+ if (icompz == 3) {
+ dlaset_("Full", n, n, &c_b12, &c_b13, &z__[z_offset], ldz);
+ }
+
+/* Machine Constants */
+
+ in = *ihi + 1 - *ilo;
+ safmin = dlamch_("S");
+ safmax = 1. / safmin;
+ ulp = dlamch_("E") * dlamch_("B");
+ anorm = dlanhs_("F", &in, &h__[*ilo + *ilo * h_dim1], ldh, &work[1]);
+ bnorm = dlanhs_("F", &in, &t[*ilo + *ilo * t_dim1], ldt, &work[1]);
+/* Computing MAX */
+ d__1 = safmin, d__2 = ulp * anorm;
+ atol = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = safmin, d__2 = ulp * bnorm;
+ btol = max(d__1,d__2);
+ ascale = 1. / max(safmin,anorm);
+ bscale = 1. / max(safmin,bnorm);
+
+/* Set Eigenvalues IHI+1:N */
+
+ i__1 = *n;
+ for (j = *ihi + 1; j <= i__1; ++j) {
+ if (t[j + j * t_dim1] < 0.) {
+ if (ilschr) {
+ i__2 = j;
+ for (jr = 1; jr <= i__2; ++jr) {
+ h__[jr + j * h_dim1] = -h__[jr + j * h_dim1];
+ t[jr + j * t_dim1] = -t[jr + j * t_dim1];
+/* L10: */
+ }
+ } else {
+ h__[j + j * h_dim1] = -h__[j + j * h_dim1];
+ t[j + j * t_dim1] = -t[j + j * t_dim1];
+ }
+ if (ilz) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ z__[jr + j * z_dim1] = -z__[jr + j * z_dim1];
+/* L20: */
+ }
+ }
+ }
+ alphar[j] = h__[j + j * h_dim1];
+ alphai[j] = 0.;
+ beta[j] = t[j + j * t_dim1];
+/* L30: */
+ }
+
+/* If IHI < ILO, skip QZ steps */
+
+ if (*ihi < *ilo) {
+ goto L380;
+ }
+
+/* MAIN QZ ITERATION LOOP */
+
+/* Initialize dynamic indices */
+
+/* Eigenvalues ILAST+1:N have been found. */
+/* Column operations modify rows IFRSTM:whatever. */
+/* Row operations modify columns whatever:ILASTM. */
+
+/* If only eigenvalues are being computed, then */
+/* IFRSTM is the row of the last splitting row above row ILAST; */
+/* this is always at least ILO. */
+/* IITER counts iterations since the last eigenvalue was found, */
+/* to tell when to use an extraordinary shift. */
+/* MAXIT is the maximum number of QZ sweeps allowed. */
+
+ ilast = *ihi;
+ if (ilschr) {
+ ifrstm = 1;
+ ilastm = *n;
+ } else {
+ ifrstm = *ilo;
+ ilastm = *ihi;
+ }
+ iiter = 0;
+ eshift = 0.;
+ maxit = (*ihi - *ilo + 1) * 30;
+
+ i__1 = maxit;
+ for (jiter = 1; jiter <= i__1; ++jiter) {
+
+/* Split the matrix if possible. */
+
+/* Two tests: */
+/* 1: H(j,j-1)=0 or j=ILO */
+/* 2: T(j,j)=0 */
+
+ if (ilast == *ilo) {
+
+/* Special case: j=ILAST */
+
+ goto L80;
+ } else {
+ if ((d__1 = h__[ilast + (ilast - 1) * h_dim1], abs(d__1)) <= atol)
+ {
+ h__[ilast + (ilast - 1) * h_dim1] = 0.;
+ goto L80;
+ }
+ }
+
+ if ((d__1 = t[ilast + ilast * t_dim1], abs(d__1)) <= btol) {
+ t[ilast + ilast * t_dim1] = 0.;
+ goto L70;
+ }
+
+/* General case: j<ILAST */
+
+ i__2 = *ilo;
+ for (j = ilast - 1; j >= i__2; --j) {
+
+/* Test 1: for H(j,j-1)=0 or j=ILO */
+
+ if (j == *ilo) {
+ ilazro = TRUE_;
+ } else {
+ if ((d__1 = h__[j + (j - 1) * h_dim1], abs(d__1)) <= atol) {
+ h__[j + (j - 1) * h_dim1] = 0.;
+ ilazro = TRUE_;
+ } else {
+ ilazro = FALSE_;
+ }
+ }
+
+/* Test 2: for T(j,j)=0 */
+
+ if ((d__1 = t[j + j * t_dim1], abs(d__1)) < btol) {
+ t[j + j * t_dim1] = 0.;
+
+/* Test 1a: Check for 2 consecutive small subdiagonals in A */
+
+ ilazr2 = FALSE_;
+ if (! ilazro) {
+ temp = (d__1 = h__[j + (j - 1) * h_dim1], abs(d__1));
+ temp2 = (d__1 = h__[j + j * h_dim1], abs(d__1));
+ tempr = max(temp,temp2);
+ if (tempr < 1. && tempr != 0.) {
+ temp /= tempr;
+ temp2 /= tempr;
+ }
+ if (temp * (ascale * (d__1 = h__[j + 1 + j * h_dim1], abs(
+ d__1))) <= temp2 * (ascale * atol)) {
+ ilazr2 = TRUE_;
+ }
+ }
+
+/* If both tests pass (1 & 2), i.e., the leading diagonal */
+/* element of B in the block is zero, split a 1x1 block off */
+/* at the top. (I.e., at the J-th row/column) The leading */
+/* diagonal element of the remainder can also be zero, so */
+/* this may have to be done repeatedly. */
+
+ if (ilazro || ilazr2) {
+ i__3 = ilast - 1;
+ for (jch = j; jch <= i__3; ++jch) {
+ temp = h__[jch + jch * h_dim1];
+ dlartg_(&temp, &h__[jch + 1 + jch * h_dim1], &c__, &s,
+ &h__[jch + jch * h_dim1]);
+ h__[jch + 1 + jch * h_dim1] = 0.;
+ i__4 = ilastm - jch;
+ drot_(&i__4, &h__[jch + (jch + 1) * h_dim1], ldh, &
+ h__[jch + 1 + (jch + 1) * h_dim1], ldh, &c__,
+ &s);
+ i__4 = ilastm - jch;
+ drot_(&i__4, &t[jch + (jch + 1) * t_dim1], ldt, &t[
+ jch + 1 + (jch + 1) * t_dim1], ldt, &c__, &s);
+ if (ilq) {
+ drot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1)
+ * q_dim1 + 1], &c__1, &c__, &s);
+ }
+ if (ilazr2) {
+ h__[jch + (jch - 1) * h_dim1] *= c__;
+ }
+ ilazr2 = FALSE_;
+ if ((d__1 = t[jch + 1 + (jch + 1) * t_dim1], abs(d__1)
+ ) >= btol) {
+ if (jch + 1 >= ilast) {
+ goto L80;
+ } else {
+ ifirst = jch + 1;
+ goto L110;
+ }
+ }
+ t[jch + 1 + (jch + 1) * t_dim1] = 0.;
+/* L40: */
+ }
+ goto L70;
+ } else {
+
+/* Only test 2 passed -- chase the zero to T(ILAST,ILAST) */
+/* Then process as in the case T(ILAST,ILAST)=0 */
+
+ i__3 = ilast - 1;
+ for (jch = j; jch <= i__3; ++jch) {
+ temp = t[jch + (jch + 1) * t_dim1];
+ dlartg_(&temp, &t[jch + 1 + (jch + 1) * t_dim1], &c__,
+ &s, &t[jch + (jch + 1) * t_dim1]);
+ t[jch + 1 + (jch + 1) * t_dim1] = 0.;
+ if (jch < ilastm - 1) {
+ i__4 = ilastm - jch - 1;
+ drot_(&i__4, &t[jch + (jch + 2) * t_dim1], ldt, &
+ t[jch + 1 + (jch + 2) * t_dim1], ldt, &
+ c__, &s);
+ }
+ i__4 = ilastm - jch + 2;
+ drot_(&i__4, &h__[jch + (jch - 1) * h_dim1], ldh, &
+ h__[jch + 1 + (jch - 1) * h_dim1], ldh, &c__,
+ &s);
+ if (ilq) {
+ drot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1)
+ * q_dim1 + 1], &c__1, &c__, &s);
+ }
+ temp = h__[jch + 1 + jch * h_dim1];
+ dlartg_(&temp, &h__[jch + 1 + (jch - 1) * h_dim1], &
+ c__, &s, &h__[jch + 1 + jch * h_dim1]);
+ h__[jch + 1 + (jch - 1) * h_dim1] = 0.;
+ i__4 = jch + 1 - ifrstm;
+ drot_(&i__4, &h__[ifrstm + jch * h_dim1], &c__1, &h__[
+ ifrstm + (jch - 1) * h_dim1], &c__1, &c__, &s)
+ ;
+ i__4 = jch - ifrstm;
+ drot_(&i__4, &t[ifrstm + jch * t_dim1], &c__1, &t[
+ ifrstm + (jch - 1) * t_dim1], &c__1, &c__, &s)
+ ;
+ if (ilz) {
+ drot_(n, &z__[jch * z_dim1 + 1], &c__1, &z__[(jch
+ - 1) * z_dim1 + 1], &c__1, &c__, &s);
+ }
+/* L50: */
+ }
+ goto L70;
+ }
+ } else if (ilazro) {
+
+/* Only test 1 passed -- work on J:ILAST */
+
+ ifirst = j;
+ goto L110;
+ }
+
+/* Neither test passed -- try next J */
+
+/* L60: */
+ }
+
+/* (Drop-through is "impossible") */
+
+ *info = *n + 1;
+ goto L420;
+
+/* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a */
+/* 1x1 block. */
+
+L70:
+ temp = h__[ilast + ilast * h_dim1];
+ dlartg_(&temp, &h__[ilast + (ilast - 1) * h_dim1], &c__, &s, &h__[
+ ilast + ilast * h_dim1]);
+ h__[ilast + (ilast - 1) * h_dim1] = 0.;
+ i__2 = ilast - ifrstm;
+ drot_(&i__2, &h__[ifrstm + ilast * h_dim1], &c__1, &h__[ifrstm + (
+ ilast - 1) * h_dim1], &c__1, &c__, &s);
+ i__2 = ilast - ifrstm;
+ drot_(&i__2, &t[ifrstm + ilast * t_dim1], &c__1, &t[ifrstm + (ilast -
+ 1) * t_dim1], &c__1, &c__, &s);
+ if (ilz) {
+ drot_(n, &z__[ilast * z_dim1 + 1], &c__1, &z__[(ilast - 1) *
+ z_dim1 + 1], &c__1, &c__, &s);
+ }
+
+/* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI, */
+/* and BETA */
+
+L80:
+ if (t[ilast + ilast * t_dim1] < 0.) {
+ if (ilschr) {
+ i__2 = ilast;
+ for (j = ifrstm; j <= i__2; ++j) {
+ h__[j + ilast * h_dim1] = -h__[j + ilast * h_dim1];
+ t[j + ilast * t_dim1] = -t[j + ilast * t_dim1];
+/* L90: */
+ }
+ } else {
+ h__[ilast + ilast * h_dim1] = -h__[ilast + ilast * h_dim1];
+ t[ilast + ilast * t_dim1] = -t[ilast + ilast * t_dim1];
+ }
+ if (ilz) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ z__[j + ilast * z_dim1] = -z__[j + ilast * z_dim1];
+/* L100: */
+ }
+ }
+ }
+ alphar[ilast] = h__[ilast + ilast * h_dim1];
+ alphai[ilast] = 0.;
+ beta[ilast] = t[ilast + ilast * t_dim1];
+
+/* Go to next block -- exit if finished. */
+
+ --ilast;
+ if (ilast < *ilo) {
+ goto L380;
+ }
+
+/* Reset counters */
+
+ iiter = 0;
+ eshift = 0.;
+ if (! ilschr) {
+ ilastm = ilast;
+ if (ifrstm > ilast) {
+ ifrstm = *ilo;
+ }
+ }
+ goto L350;
+
+/* QZ step */
+
+/* This iteration only involves rows/columns IFIRST:ILAST. We */
+/* assume IFIRST < ILAST, and that the diagonal of B is non-zero. */
+
+L110:
+ ++iiter;
+ if (! ilschr) {
+ ifrstm = ifirst;
+ }
+
+/* Compute single shifts. */
+
+/* At this point, IFIRST < ILAST, and the diagonal elements of */
+/* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in */
+/* magnitude) */
+
+ if (iiter / 10 * 10 == iiter) {
+
+/* Exceptional shift. Chosen for no particularly good reason. */
+/* (Single shift only.) */
+
+ if ((doublereal) maxit * safmin * (d__1 = h__[ilast - 1 + ilast *
+ h_dim1], abs(d__1)) < (d__2 = t[ilast - 1 + (ilast - 1) *
+ t_dim1], abs(d__2))) {
+ eshift += h__[ilast - 1 + ilast * h_dim1] / t[ilast - 1 + (
+ ilast - 1) * t_dim1];
+ } else {
+ eshift += 1. / (safmin * (doublereal) maxit);
+ }
+ s1 = 1.;
+ wr = eshift;
+
+ } else {
+
+/* Shifts based on the generalized eigenvalues of the */
+/* bottom-right 2x2 block of A and B. The first eigenvalue */
+/* returned by DLAG2 is the Wilkinson shift (AEP p.512), */
+
+ d__1 = safmin * 100.;
+ dlag2_(&h__[ilast - 1 + (ilast - 1) * h_dim1], ldh, &t[ilast - 1
+ + (ilast - 1) * t_dim1], ldt, &d__1, &s1, &s2, &wr, &wr2,
+ &wi);
+
+/* Computing MAX */
+/* Computing MAX */
+ d__3 = 1., d__4 = abs(wr), d__3 = max(d__3,d__4), d__4 = abs(wi);
+ d__1 = s1, d__2 = safmin * max(d__3,d__4);
+ temp = max(d__1,d__2);
+ if (wi != 0.) {
+ goto L200;
+ }
+ }
+
+/* Fiddle with shift to avoid overflow */
+
+ temp = min(ascale,1.) * (safmax * .5);
+ if (s1 > temp) {
+ scale = temp / s1;
+ } else {
+ scale = 1.;
+ }
+
+ temp = min(bscale,1.) * (safmax * .5);
+ if (abs(wr) > temp) {
+/* Computing MIN */
+ d__1 = scale, d__2 = temp / abs(wr);
+ scale = min(d__1,d__2);
+ }
+ s1 = scale * s1;
+ wr = scale * wr;
+
+/* Now check for two consecutive small subdiagonals. */
+
+ i__2 = ifirst + 1;
+ for (j = ilast - 1; j >= i__2; --j) {
+ istart = j;
+ temp = (d__1 = s1 * h__[j + (j - 1) * h_dim1], abs(d__1));
+ temp2 = (d__1 = s1 * h__[j + j * h_dim1] - wr * t[j + j * t_dim1],
+ abs(d__1));
+ tempr = max(temp,temp2);
+ if (tempr < 1. && tempr != 0.) {
+ temp /= tempr;
+ temp2 /= tempr;
+ }
+ if ((d__1 = ascale * h__[j + 1 + j * h_dim1] * temp, abs(d__1)) <=
+ ascale * atol * temp2) {
+ goto L130;
+ }
+/* L120: */
+ }
+
+ istart = ifirst;
+L130:
+
+/* Do an implicit single-shift QZ sweep. */
+
+/* Initial Q */
+
+ temp = s1 * h__[istart + istart * h_dim1] - wr * t[istart + istart *
+ t_dim1];
+ temp2 = s1 * h__[istart + 1 + istart * h_dim1];
+ dlartg_(&temp, &temp2, &c__, &s, &tempr);
+
+/* Sweep */
+
+ i__2 = ilast - 1;
+ for (j = istart; j <= i__2; ++j) {
+ if (j > istart) {
+ temp = h__[j + (j - 1) * h_dim1];
+ dlartg_(&temp, &h__[j + 1 + (j - 1) * h_dim1], &c__, &s, &h__[
+ j + (j - 1) * h_dim1]);
+ h__[j + 1 + (j - 1) * h_dim1] = 0.;
+ }
+
+ i__3 = ilastm;
+ for (jc = j; jc <= i__3; ++jc) {
+ temp = c__ * h__[j + jc * h_dim1] + s * h__[j + 1 + jc *
+ h_dim1];
+ h__[j + 1 + jc * h_dim1] = -s * h__[j + jc * h_dim1] + c__ *
+ h__[j + 1 + jc * h_dim1];
+ h__[j + jc * h_dim1] = temp;
+ temp2 = c__ * t[j + jc * t_dim1] + s * t[j + 1 + jc * t_dim1];
+ t[j + 1 + jc * t_dim1] = -s * t[j + jc * t_dim1] + c__ * t[j
+ + 1 + jc * t_dim1];
+ t[j + jc * t_dim1] = temp2;
+/* L140: */
+ }
+ if (ilq) {
+ i__3 = *n;
+ for (jr = 1; jr <= i__3; ++jr) {
+ temp = c__ * q[jr + j * q_dim1] + s * q[jr + (j + 1) *
+ q_dim1];
+ q[jr + (j + 1) * q_dim1] = -s * q[jr + j * q_dim1] + c__ *
+ q[jr + (j + 1) * q_dim1];
+ q[jr + j * q_dim1] = temp;
+/* L150: */
+ }
+ }
+
+ temp = t[j + 1 + (j + 1) * t_dim1];
+ dlartg_(&temp, &t[j + 1 + j * t_dim1], &c__, &s, &t[j + 1 + (j +
+ 1) * t_dim1]);
+ t[j + 1 + j * t_dim1] = 0.;
+
+/* Computing MIN */
+ i__4 = j + 2;
+ i__3 = min(i__4,ilast);
+ for (jr = ifrstm; jr <= i__3; ++jr) {
+ temp = c__ * h__[jr + (j + 1) * h_dim1] + s * h__[jr + j *
+ h_dim1];
+ h__[jr + j * h_dim1] = -s * h__[jr + (j + 1) * h_dim1] + c__ *
+ h__[jr + j * h_dim1];
+ h__[jr + (j + 1) * h_dim1] = temp;
+/* L160: */
+ }
+ i__3 = j;
+ for (jr = ifrstm; jr <= i__3; ++jr) {
+ temp = c__ * t[jr + (j + 1) * t_dim1] + s * t[jr + j * t_dim1]
+ ;
+ t[jr + j * t_dim1] = -s * t[jr + (j + 1) * t_dim1] + c__ * t[
+ jr + j * t_dim1];
+ t[jr + (j + 1) * t_dim1] = temp;
+/* L170: */
+ }
+ if (ilz) {
+ i__3 = *n;
+ for (jr = 1; jr <= i__3; ++jr) {
+ temp = c__ * z__[jr + (j + 1) * z_dim1] + s * z__[jr + j *
+ z_dim1];
+ z__[jr + j * z_dim1] = -s * z__[jr + (j + 1) * z_dim1] +
+ c__ * z__[jr + j * z_dim1];
+ z__[jr + (j + 1) * z_dim1] = temp;
+/* L180: */
+ }
+ }
+/* L190: */
+ }
+
+ goto L350;
+
+/* Use Francis double-shift */
+
+/* Note: the Francis double-shift should work with real shifts, */
+/* but only if the block is at least 3x3. */
+/* This code may break if this point is reached with */
+/* a 2x2 block with real eigenvalues. */
+
+L200:
+ if (ifirst + 1 == ilast) {
+
+/* Special case -- 2x2 block with complex eigenvectors */
+
+/* Step 1: Standardize, that is, rotate so that */
+
+/* ( B11 0 ) */
+/* B = ( ) with B11 non-negative. */
+/* ( 0 B22 ) */
+
+ dlasv2_(&t[ilast - 1 + (ilast - 1) * t_dim1], &t[ilast - 1 +
+ ilast * t_dim1], &t[ilast + ilast * t_dim1], &b22, &b11, &
+ sr, &cr, &sl, &cl);
+
+ if (b11 < 0.) {
+ cr = -cr;
+ sr = -sr;
+ b11 = -b11;
+ b22 = -b22;
+ }
+
+ i__2 = ilastm + 1 - ifirst;
+ drot_(&i__2, &h__[ilast - 1 + (ilast - 1) * h_dim1], ldh, &h__[
+ ilast + (ilast - 1) * h_dim1], ldh, &cl, &sl);
+ i__2 = ilast + 1 - ifrstm;
+ drot_(&i__2, &h__[ifrstm + (ilast - 1) * h_dim1], &c__1, &h__[
+ ifrstm + ilast * h_dim1], &c__1, &cr, &sr);
+
+ if (ilast < ilastm) {
+ i__2 = ilastm - ilast;
+ drot_(&i__2, &t[ilast - 1 + (ilast + 1) * t_dim1], ldt, &t[
+ ilast + (ilast + 1) * t_dim1], ldt, &cl, &sl);
+ }
+ if (ifrstm < ilast - 1) {
+ i__2 = ifirst - ifrstm;
+ drot_(&i__2, &t[ifrstm + (ilast - 1) * t_dim1], &c__1, &t[
+ ifrstm + ilast * t_dim1], &c__1, &cr, &sr);
+ }
+
+ if (ilq) {
+ drot_(n, &q[(ilast - 1) * q_dim1 + 1], &c__1, &q[ilast *
+ q_dim1 + 1], &c__1, &cl, &sl);
+ }
+ if (ilz) {
+ drot_(n, &z__[(ilast - 1) * z_dim1 + 1], &c__1, &z__[ilast *
+ z_dim1 + 1], &c__1, &cr, &sr);
+ }
+
+ t[ilast - 1 + (ilast - 1) * t_dim1] = b11;
+ t[ilast - 1 + ilast * t_dim1] = 0.;
+ t[ilast + (ilast - 1) * t_dim1] = 0.;
+ t[ilast + ilast * t_dim1] = b22;
+
+/* If B22 is negative, negate column ILAST */
+
+ if (b22 < 0.) {
+ i__2 = ilast;
+ for (j = ifrstm; j <= i__2; ++j) {
+ h__[j + ilast * h_dim1] = -h__[j + ilast * h_dim1];
+ t[j + ilast * t_dim1] = -t[j + ilast * t_dim1];
+/* L210: */
+ }
+
+ if (ilz) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ z__[j + ilast * z_dim1] = -z__[j + ilast * z_dim1];
+/* L220: */
+ }
+ }
+ }
+
+/* Step 2: Compute ALPHAR, ALPHAI, and BETA (see refs.) */
+
+/* Recompute shift */
+
+ d__1 = safmin * 100.;
+ dlag2_(&h__[ilast - 1 + (ilast - 1) * h_dim1], ldh, &t[ilast - 1
+ + (ilast - 1) * t_dim1], ldt, &d__1, &s1, &temp, &wr, &
+ temp2, &wi);
+
+/* If standardization has perturbed the shift onto real line, */
+/* do another (real single-shift) QR step. */
+
+ if (wi == 0.) {
+ goto L350;
+ }
+ s1inv = 1. / s1;
+
+/* Do EISPACK (QZVAL) computation of alpha and beta */
+
+ a11 = h__[ilast - 1 + (ilast - 1) * h_dim1];
+ a21 = h__[ilast + (ilast - 1) * h_dim1];
+ a12 = h__[ilast - 1 + ilast * h_dim1];
+ a22 = h__[ilast + ilast * h_dim1];
+
+/* Compute complex Givens rotation on right */
+/* (Assume some element of C = (sA - wB) > unfl ) */
+/* __ */
+/* (sA - wB) ( CZ -SZ ) */
+/* ( SZ CZ ) */
+
+ c11r = s1 * a11 - wr * b11;
+ c11i = -wi * b11;
+ c12 = s1 * a12;
+ c21 = s1 * a21;
+ c22r = s1 * a22 - wr * b22;
+ c22i = -wi * b22;
+
+ if (abs(c11r) + abs(c11i) + abs(c12) > abs(c21) + abs(c22r) + abs(
+ c22i)) {
+ t1 = dlapy3_(&c12, &c11r, &c11i);
+ cz = c12 / t1;
+ szr = -c11r / t1;
+ szi = -c11i / t1;
+ } else {
+ cz = dlapy2_(&c22r, &c22i);
+ if (cz <= safmin) {
+ cz = 0.;
+ szr = 1.;
+ szi = 0.;
+ } else {
+ tempr = c22r / cz;
+ tempi = c22i / cz;
+ t1 = dlapy2_(&cz, &c21);
+ cz /= t1;
+ szr = -c21 * tempr / t1;
+ szi = c21 * tempi / t1;
+ }
+ }
+
+/* Compute Givens rotation on left */
+
+/* ( CQ SQ ) */
+/* ( __ ) A or B */
+/* ( -SQ CQ ) */
+
+ an = abs(a11) + abs(a12) + abs(a21) + abs(a22);
+ bn = abs(b11) + abs(b22);
+ wabs = abs(wr) + abs(wi);
+ if (s1 * an > wabs * bn) {
+ cq = cz * b11;
+ sqr = szr * b22;
+ sqi = -szi * b22;
+ } else {
+ a1r = cz * a11 + szr * a12;
+ a1i = szi * a12;
+ a2r = cz * a21 + szr * a22;
+ a2i = szi * a22;
+ cq = dlapy2_(&a1r, &a1i);
+ if (cq <= safmin) {
+ cq = 0.;
+ sqr = 1.;
+ sqi = 0.;
+ } else {
+ tempr = a1r / cq;
+ tempi = a1i / cq;
+ sqr = tempr * a2r + tempi * a2i;
+ sqi = tempi * a2r - tempr * a2i;
+ }
+ }
+ t1 = dlapy3_(&cq, &sqr, &sqi);
+ cq /= t1;
+ sqr /= t1;
+ sqi /= t1;
+
+/* Compute diagonal elements of QBZ */
+
+ tempr = sqr * szr - sqi * szi;
+ tempi = sqr * szi + sqi * szr;
+ b1r = cq * cz * b11 + tempr * b22;
+ b1i = tempi * b22;
+ b1a = dlapy2_(&b1r, &b1i);
+ b2r = cq * cz * b22 + tempr * b11;
+ b2i = -tempi * b11;
+ b2a = dlapy2_(&b2r, &b2i);
+
+/* Normalize so beta > 0, and Im( alpha1 ) > 0 */
+
+ beta[ilast - 1] = b1a;
+ beta[ilast] = b2a;
+ alphar[ilast - 1] = wr * b1a * s1inv;
+ alphai[ilast - 1] = wi * b1a * s1inv;
+ alphar[ilast] = wr * b2a * s1inv;
+ alphai[ilast] = -(wi * b2a) * s1inv;
+
+/* Step 3: Go to next block -- exit if finished. */
+
+ ilast = ifirst - 1;
+ if (ilast < *ilo) {
+ goto L380;
+ }
+
+/* Reset counters */
+
+ iiter = 0;
+ eshift = 0.;
+ if (! ilschr) {
+ ilastm = ilast;
+ if (ifrstm > ilast) {
+ ifrstm = *ilo;
+ }
+ }
+ goto L350;
+ } else {
+
+/* Usual case: 3x3 or larger block, using Francis implicit */
+/* double-shift */
+
+/* 2 */
+/* Eigenvalue equation is w - c w + d = 0, */
+
+/* -1 2 -1 */
+/* so compute 1st column of (A B ) - c A B + d */
+/* using the formula in QZIT (from EISPACK) */
+
+/* We assume that the block is at least 3x3 */
+
+ ad11 = ascale * h__[ilast - 1 + (ilast - 1) * h_dim1] / (bscale *
+ t[ilast - 1 + (ilast - 1) * t_dim1]);
+ ad21 = ascale * h__[ilast + (ilast - 1) * h_dim1] / (bscale * t[
+ ilast - 1 + (ilast - 1) * t_dim1]);
+ ad12 = ascale * h__[ilast - 1 + ilast * h_dim1] / (bscale * t[
+ ilast + ilast * t_dim1]);
+ ad22 = ascale * h__[ilast + ilast * h_dim1] / (bscale * t[ilast +
+ ilast * t_dim1]);
+ u12 = t[ilast - 1 + ilast * t_dim1] / t[ilast + ilast * t_dim1];
+ ad11l = ascale * h__[ifirst + ifirst * h_dim1] / (bscale * t[
+ ifirst + ifirst * t_dim1]);
+ ad21l = ascale * h__[ifirst + 1 + ifirst * h_dim1] / (bscale * t[
+ ifirst + ifirst * t_dim1]);
+ ad12l = ascale * h__[ifirst + (ifirst + 1) * h_dim1] / (bscale *
+ t[ifirst + 1 + (ifirst + 1) * t_dim1]);
+ ad22l = ascale * h__[ifirst + 1 + (ifirst + 1) * h_dim1] / (
+ bscale * t[ifirst + 1 + (ifirst + 1) * t_dim1]);
+ ad32l = ascale * h__[ifirst + 2 + (ifirst + 1) * h_dim1] / (
+ bscale * t[ifirst + 1 + (ifirst + 1) * t_dim1]);
+ u12l = t[ifirst + (ifirst + 1) * t_dim1] / t[ifirst + 1 + (ifirst
+ + 1) * t_dim1];
+
+ v[0] = (ad11 - ad11l) * (ad22 - ad11l) - ad12 * ad21 + ad21 * u12
+ * ad11l + (ad12l - ad11l * u12l) * ad21l;
+ v[1] = (ad22l - ad11l - ad21l * u12l - (ad11 - ad11l) - (ad22 -
+ ad11l) + ad21 * u12) * ad21l;
+ v[2] = ad32l * ad21l;
+
+ istart = ifirst;
+
+ dlarfg_(&c__3, v, &v[1], &c__1, &tau);
+ v[0] = 1.;
+
+/* Sweep */
+
+ i__2 = ilast - 2;
+ for (j = istart; j <= i__2; ++j) {
+
+/* All but last elements: use 3x3 Householder transforms. */
+
+/* Zero (j-1)st column of A */
+
+ if (j > istart) {
+ v[0] = h__[j + (j - 1) * h_dim1];
+ v[1] = h__[j + 1 + (j - 1) * h_dim1];
+ v[2] = h__[j + 2 + (j - 1) * h_dim1];
+
+ dlarfg_(&c__3, &h__[j + (j - 1) * h_dim1], &v[1], &c__1, &
+ tau);
+ v[0] = 1.;
+ h__[j + 1 + (j - 1) * h_dim1] = 0.;
+ h__[j + 2 + (j - 1) * h_dim1] = 0.;
+ }
+
+ i__3 = ilastm;
+ for (jc = j; jc <= i__3; ++jc) {
+ temp = tau * (h__[j + jc * h_dim1] + v[1] * h__[j + 1 +
+ jc * h_dim1] + v[2] * h__[j + 2 + jc * h_dim1]);
+ h__[j + jc * h_dim1] -= temp;
+ h__[j + 1 + jc * h_dim1] -= temp * v[1];
+ h__[j + 2 + jc * h_dim1] -= temp * v[2];
+ temp2 = tau * (t[j + jc * t_dim1] + v[1] * t[j + 1 + jc *
+ t_dim1] + v[2] * t[j + 2 + jc * t_dim1]);
+ t[j + jc * t_dim1] -= temp2;
+ t[j + 1 + jc * t_dim1] -= temp2 * v[1];
+ t[j + 2 + jc * t_dim1] -= temp2 * v[2];
+/* L230: */
+ }
+ if (ilq) {
+ i__3 = *n;
+ for (jr = 1; jr <= i__3; ++jr) {
+ temp = tau * (q[jr + j * q_dim1] + v[1] * q[jr + (j +
+ 1) * q_dim1] + v[2] * q[jr + (j + 2) * q_dim1]
+ );
+ q[jr + j * q_dim1] -= temp;
+ q[jr + (j + 1) * q_dim1] -= temp * v[1];
+ q[jr + (j + 2) * q_dim1] -= temp * v[2];
+/* L240: */
+ }
+ }
+
+/* Zero j-th column of B (see DLAGBC for details) */
+
+/* Swap rows to pivot */
+
+ ilpivt = FALSE_;
+/* Computing MAX */
+ d__3 = (d__1 = t[j + 1 + (j + 1) * t_dim1], abs(d__1)), d__4 =
+ (d__2 = t[j + 1 + (j + 2) * t_dim1], abs(d__2));
+ temp = max(d__3,d__4);
+/* Computing MAX */
+ d__3 = (d__1 = t[j + 2 + (j + 1) * t_dim1], abs(d__1)), d__4 =
+ (d__2 = t[j + 2 + (j + 2) * t_dim1], abs(d__2));
+ temp2 = max(d__3,d__4);
+ if (max(temp,temp2) < safmin) {
+ scale = 0.;
+ u1 = 1.;
+ u2 = 0.;
+ goto L250;
+ } else if (temp >= temp2) {
+ w11 = t[j + 1 + (j + 1) * t_dim1];
+ w21 = t[j + 2 + (j + 1) * t_dim1];
+ w12 = t[j + 1 + (j + 2) * t_dim1];
+ w22 = t[j + 2 + (j + 2) * t_dim1];
+ u1 = t[j + 1 + j * t_dim1];
+ u2 = t[j + 2 + j * t_dim1];
+ } else {
+ w21 = t[j + 1 + (j + 1) * t_dim1];
+ w11 = t[j + 2 + (j + 1) * t_dim1];
+ w22 = t[j + 1 + (j + 2) * t_dim1];
+ w12 = t[j + 2 + (j + 2) * t_dim1];
+ u2 = t[j + 1 + j * t_dim1];
+ u1 = t[j + 2 + j * t_dim1];
+ }
+
+/* Swap columns if nec. */
+
+ if (abs(w12) > abs(w11)) {
+ ilpivt = TRUE_;
+ temp = w12;
+ temp2 = w22;
+ w12 = w11;
+ w22 = w21;
+ w11 = temp;
+ w21 = temp2;
+ }
+
+/* LU-factor */
+
+ temp = w21 / w11;
+ u2 -= temp * u1;
+ w22 -= temp * w12;
+ w21 = 0.;
+
+/* Compute SCALE */
+
+ scale = 1.;
+ if (abs(w22) < safmin) {
+ scale = 0.;
+ u2 = 1.;
+ u1 = -w12 / w11;
+ goto L250;
+ }
+ if (abs(w22) < abs(u2)) {
+ scale = (d__1 = w22 / u2, abs(d__1));
+ }
+ if (abs(w11) < abs(u1)) {
+/* Computing MIN */
+ d__2 = scale, d__3 = (d__1 = w11 / u1, abs(d__1));
+ scale = min(d__2,d__3);
+ }
+
+/* Solve */
+
+ u2 = scale * u2 / w22;
+ u1 = (scale * u1 - w12 * u2) / w11;
+
+L250:
+ if (ilpivt) {
+ temp = u2;
+ u2 = u1;
+ u1 = temp;
+ }
+
+/* Compute Householder Vector */
+
+/* Computing 2nd power */
+ d__1 = scale;
+/* Computing 2nd power */
+ d__2 = u1;
+/* Computing 2nd power */
+ d__3 = u2;
+ t1 = sqrt(d__1 * d__1 + d__2 * d__2 + d__3 * d__3);
+ tau = scale / t1 + 1.;
+ vs = -1. / (scale + t1);
+ v[0] = 1.;
+ v[1] = vs * u1;
+ v[2] = vs * u2;
+
+/* Apply transformations from the right. */
+
+/* Computing MIN */
+ i__4 = j + 3;
+ i__3 = min(i__4,ilast);
+ for (jr = ifrstm; jr <= i__3; ++jr) {
+ temp = tau * (h__[jr + j * h_dim1] + v[1] * h__[jr + (j +
+ 1) * h_dim1] + v[2] * h__[jr + (j + 2) * h_dim1]);
+ h__[jr + j * h_dim1] -= temp;
+ h__[jr + (j + 1) * h_dim1] -= temp * v[1];
+ h__[jr + (j + 2) * h_dim1] -= temp * v[2];
+/* L260: */
+ }
+ i__3 = j + 2;
+ for (jr = ifrstm; jr <= i__3; ++jr) {
+ temp = tau * (t[jr + j * t_dim1] + v[1] * t[jr + (j + 1) *
+ t_dim1] + v[2] * t[jr + (j + 2) * t_dim1]);
+ t[jr + j * t_dim1] -= temp;
+ t[jr + (j + 1) * t_dim1] -= temp * v[1];
+ t[jr + (j + 2) * t_dim1] -= temp * v[2];
+/* L270: */
+ }
+ if (ilz) {
+ i__3 = *n;
+ for (jr = 1; jr <= i__3; ++jr) {
+ temp = tau * (z__[jr + j * z_dim1] + v[1] * z__[jr + (
+ j + 1) * z_dim1] + v[2] * z__[jr + (j + 2) *
+ z_dim1]);
+ z__[jr + j * z_dim1] -= temp;
+ z__[jr + (j + 1) * z_dim1] -= temp * v[1];
+ z__[jr + (j + 2) * z_dim1] -= temp * v[2];
+/* L280: */
+ }
+ }
+ t[j + 1 + j * t_dim1] = 0.;
+ t[j + 2 + j * t_dim1] = 0.;
+/* L290: */
+ }
+
+/* Last elements: Use Givens rotations */
+
+/* Rotations from the left */
+
+ j = ilast - 1;
+ temp = h__[j + (j - 1) * h_dim1];
+ dlartg_(&temp, &h__[j + 1 + (j - 1) * h_dim1], &c__, &s, &h__[j +
+ (j - 1) * h_dim1]);
+ h__[j + 1 + (j - 1) * h_dim1] = 0.;
+
+ i__2 = ilastm;
+ for (jc = j; jc <= i__2; ++jc) {
+ temp = c__ * h__[j + jc * h_dim1] + s * h__[j + 1 + jc *
+ h_dim1];
+ h__[j + 1 + jc * h_dim1] = -s * h__[j + jc * h_dim1] + c__ *
+ h__[j + 1 + jc * h_dim1];
+ h__[j + jc * h_dim1] = temp;
+ temp2 = c__ * t[j + jc * t_dim1] + s * t[j + 1 + jc * t_dim1];
+ t[j + 1 + jc * t_dim1] = -s * t[j + jc * t_dim1] + c__ * t[j
+ + 1 + jc * t_dim1];
+ t[j + jc * t_dim1] = temp2;
+/* L300: */
+ }
+ if (ilq) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ temp = c__ * q[jr + j * q_dim1] + s * q[jr + (j + 1) *
+ q_dim1];
+ q[jr + (j + 1) * q_dim1] = -s * q[jr + j * q_dim1] + c__ *
+ q[jr + (j + 1) * q_dim1];
+ q[jr + j * q_dim1] = temp;
+/* L310: */
+ }
+ }
+
+/* Rotations from the right. */
+
+ temp = t[j + 1 + (j + 1) * t_dim1];
+ dlartg_(&temp, &t[j + 1 + j * t_dim1], &c__, &s, &t[j + 1 + (j +
+ 1) * t_dim1]);
+ t[j + 1 + j * t_dim1] = 0.;
+
+ i__2 = ilast;
+ for (jr = ifrstm; jr <= i__2; ++jr) {
+ temp = c__ * h__[jr + (j + 1) * h_dim1] + s * h__[jr + j *
+ h_dim1];
+ h__[jr + j * h_dim1] = -s * h__[jr + (j + 1) * h_dim1] + c__ *
+ h__[jr + j * h_dim1];
+ h__[jr + (j + 1) * h_dim1] = temp;
+/* L320: */
+ }
+ i__2 = ilast - 1;
+ for (jr = ifrstm; jr <= i__2; ++jr) {
+ temp = c__ * t[jr + (j + 1) * t_dim1] + s * t[jr + j * t_dim1]
+ ;
+ t[jr + j * t_dim1] = -s * t[jr + (j + 1) * t_dim1] + c__ * t[
+ jr + j * t_dim1];
+ t[jr + (j + 1) * t_dim1] = temp;
+/* L330: */
+ }
+ if (ilz) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ temp = c__ * z__[jr + (j + 1) * z_dim1] + s * z__[jr + j *
+ z_dim1];
+ z__[jr + j * z_dim1] = -s * z__[jr + (j + 1) * z_dim1] +
+ c__ * z__[jr + j * z_dim1];
+ z__[jr + (j + 1) * z_dim1] = temp;
+/* L340: */
+ }
+ }
+
+/* End of Double-Shift code */
+
+ }
+
+ goto L350;
+
+/* End of iteration loop */
+
+L350:
+/* L360: */
+ ;
+ }
+
+/* Drop-through = non-convergence */
+
+ *info = ilast;
+ goto L420;
+
+/* Successful completion of all QZ steps */
+
+L380:
+
+/* Set Eigenvalues 1:ILO-1 */
+
+ i__1 = *ilo - 1;
+ for (j = 1; j <= i__1; ++j) {
+ if (t[j + j * t_dim1] < 0.) {
+ if (ilschr) {
+ i__2 = j;
+ for (jr = 1; jr <= i__2; ++jr) {
+ h__[jr + j * h_dim1] = -h__[jr + j * h_dim1];
+ t[jr + j * t_dim1] = -t[jr + j * t_dim1];
+/* L390: */
+ }
+ } else {
+ h__[j + j * h_dim1] = -h__[j + j * h_dim1];
+ t[j + j * t_dim1] = -t[j + j * t_dim1];
+ }
+ if (ilz) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ z__[jr + j * z_dim1] = -z__[jr + j * z_dim1];
+/* L400: */
+ }
+ }
+ }
+ alphar[j] = h__[j + j * h_dim1];
+ alphai[j] = 0.;
+ beta[j] = t[j + j * t_dim1];
+/* L410: */
+ }
+
+/* Normal Termination */
+
+ *info = 0;
+
+/* Exit (other than argument error) -- return optimal workspace size */
+
+L420:
+ work[1] = (doublereal) (*n);
+ return 0;
+
+/* End of DHGEQZ */
+
+} /* dhgeqz_ */
diff --git a/SRC/dhsein.c b/SRC/dhsein.c
new file mode 100644
index 0000000..7220f14
--- /dev/null
+++ b/SRC/dhsein.c
@@ -0,0 +1,491 @@
+/* dhsein.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static logical c_false = FALSE_;
+static logical c_true = TRUE_;
+
+/* Subroutine */ int dhsein_(char *side, char *eigsrc, char *initv, logical *
+ select, integer *n, doublereal *h__, integer *ldh, doublereal *wr,
+ doublereal *wi, doublereal *vl, integer *ldvl, doublereal *vr,
+ integer *ldvr, integer *mm, integer *m, doublereal *work, integer *
+ ifaill, integer *ifailr, integer *info)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
+ i__2;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer i__, k, kl, kr, kln, ksi;
+ doublereal wki;
+ integer ksr;
+ doublereal ulp, wkr, eps3;
+ logical pair;
+ doublereal unfl;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical leftv, bothv;
+ doublereal hnorm;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlaein_(logical *, logical *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *
+, doublereal *, doublereal *, integer *);
+ extern doublereal dlanhs_(char *, integer *, doublereal *, integer *,
+ doublereal *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ logical noinit;
+ integer ldwork;
+ logical rightv, fromqr;
+ doublereal smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DHSEIN uses inverse iteration to find specified right and/or left */
+/* eigenvectors of a real upper Hessenberg matrix H. */
+
+/* The right eigenvector x and the left eigenvector y of the matrix H */
+/* corresponding to an eigenvalue w are defined by: */
+
+/* H * x = w * x, y**h * H = w * y**h */
+
+/* where y**h denotes the conjugate transpose of the vector y. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'R': compute right eigenvectors only; */
+/* = 'L': compute left eigenvectors only; */
+/* = 'B': compute both right and left eigenvectors. */
+
+/* EIGSRC (input) CHARACTER*1 */
+/* Specifies the source of eigenvalues supplied in (WR,WI): */
+/* = 'Q': the eigenvalues were found using DHSEQR; thus, if */
+/* H has zero subdiagonal elements, and so is */
+/* block-triangular, then the j-th eigenvalue can be */
+/* assumed to be an eigenvalue of the block containing */
+/* the j-th row/column. This property allows DHSEIN to */
+/* perform inverse iteration on just one diagonal block. */
+/* = 'N': no assumptions are made on the correspondence */
+/* between eigenvalues and diagonal blocks. In this */
+/* case, DHSEIN must always perform inverse iteration */
+/* using the whole matrix H. */
+
+/* INITV (input) CHARACTER*1 */
+/* = 'N': no initial vectors are supplied; */
+/* = 'U': user-supplied initial vectors are stored in the arrays */
+/* VL and/or VR. */
+
+/* SELECT (input/output) LOGICAL array, dimension (N) */
+/* Specifies the eigenvectors to be computed. To select the */
+/* real eigenvector corresponding to a real eigenvalue WR(j), */
+/* SELECT(j) must be set to .TRUE.. To select the complex */
+/* eigenvector corresponding to a complex eigenvalue */
+/* (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)), */
+/* either SELECT(j) or SELECT(j+1) or both must be set to */
+/* .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is */
+/* .FALSE.. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N >= 0. */
+
+/* H (input) DOUBLE PRECISION array, dimension (LDH,N) */
+/* The upper Hessenberg matrix H. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH >= max(1,N). */
+
+/* WR (input/output) DOUBLE PRECISION array, dimension (N) */
+/* WI (input) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the real and imaginary parts of the eigenvalues of */
+/* H; a complex conjugate pair of eigenvalues must be stored in */
+/* consecutive elements of WR and WI. */
+/* On exit, WR may have been altered since close eigenvalues */
+/* are perturbed slightly in searching for independent */
+/* eigenvectors. */
+
+/* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM) */
+/* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must */
+/* contain starting vectors for the inverse iteration for the */
+/* left eigenvectors; the starting vector for each eigenvector */
+/* must be in the same column(s) in which the eigenvector will */
+/* be stored. */
+/* On exit, if SIDE = 'L' or 'B', the left eigenvectors */
+/* specified by SELECT will be stored consecutively in the */
+/* columns of VL, in the same order as their eigenvalues. A */
+/* complex eigenvector corresponding to a complex eigenvalue is */
+/* stored in two consecutive columns, the first holding the real */
+/* part and the second the imaginary part. */
+/* If SIDE = 'R', VL is not referenced. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. */
+/* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. */
+
+/* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) */
+/* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must */
+/* contain starting vectors for the inverse iteration for the */
+/* right eigenvectors; the starting vector for each eigenvector */
+/* must be in the same column(s) in which the eigenvector will */
+/* be stored. */
+/* On exit, if SIDE = 'R' or 'B', the right eigenvectors */
+/* specified by SELECT will be stored consecutively in the */
+/* columns of VR, in the same order as their eigenvalues. A */
+/* complex eigenvector corresponding to a complex eigenvalue is */
+/* stored in two consecutive columns, the first holding the real */
+/* part and the second the imaginary part. */
+/* If SIDE = 'L', VR is not referenced. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. */
+/* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. */
+
+/* MM (input) INTEGER */
+/* The number of columns in the arrays VL and/or VR. MM >= M. */
+
+/* M (output) INTEGER */
+/* The number of columns in the arrays VL and/or VR required to */
+/* store the eigenvectors; each selected real eigenvector */
+/* occupies one column and each selected complex eigenvector */
+/* occupies two columns. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension ((N+2)*N) */
+
+/* IFAILL (output) INTEGER array, dimension (MM) */
+/* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left */
+/* eigenvector in the i-th column of VL (corresponding to the */
+/* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the */
+/* eigenvector converged satisfactorily. If the i-th and (i+1)th */
+/* columns of VL hold a complex eigenvector, then IFAILL(i) and */
+/* IFAILL(i+1) are set to the same value. */
+/* If SIDE = 'R', IFAILL is not referenced. */
+
+/* IFAILR (output) INTEGER array, dimension (MM) */
+/* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right */
+/* eigenvector in the i-th column of VR (corresponding to the */
+/* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the */
+/* eigenvector converged satisfactorily. If the i-th and (i+1)th */
+/* columns of VR hold a complex eigenvector, then IFAILR(i) and */
+/* IFAILR(i+1) are set to the same value. */
+/* If SIDE = 'L', IFAILR is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, i is the number of eigenvectors which */
+/* failed to converge; see IFAILL and IFAILR for further */
+/* details. */
+
+/* Further Details */
+/* =============== */
+
+/* Each eigenvector is normalized so that the element of largest */
+/* magnitude has magnitude 1; here the magnitude of a complex number */
+/* (x,y) is taken to be |x|+|y|. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters. */
+
+ /* Parameter adjustments */
+ --select;
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --wr;
+ --wi;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+ --ifaill;
+ --ifailr;
+
+ /* Function Body */
+ bothv = lsame_(side, "B");
+ rightv = lsame_(side, "R") || bothv;
+ leftv = lsame_(side, "L") || bothv;
+
+ fromqr = lsame_(eigsrc, "Q");
+
+ noinit = lsame_(initv, "N");
+
+/* Set M to the number of columns required to store the selected */
+/* eigenvectors, and standardize the array SELECT. */
+
+ *m = 0;
+ pair = FALSE_;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (pair) {
+ pair = FALSE_;
+ select[k] = FALSE_;
+ } else {
+ if (wi[k] == 0.) {
+ if (select[k]) {
+ ++(*m);
+ }
+ } else {
+ pair = TRUE_;
+ if (select[k] || select[k + 1]) {
+ select[k] = TRUE_;
+ *m += 2;
+ }
+ }
+ }
+/* L10: */
+ }
+
+ *info = 0;
+ if (! rightv && ! leftv) {
+ *info = -1;
+ } else if (! fromqr && ! lsame_(eigsrc, "N")) {
+ *info = -2;
+ } else if (! noinit && ! lsame_(initv, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*ldh < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvl < 1 || leftv && *ldvl < *n) {
+ *info = -11;
+ } else if (*ldvr < 1 || rightv && *ldvr < *n) {
+ *info = -13;
+ } else if (*mm < *m) {
+ *info = -14;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DHSEIN", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Set machine-dependent constants. */
+
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Precision");
+ smlnum = unfl * (*n / ulp);
+ bignum = (1. - ulp) / smlnum;
+
+ ldwork = *n + 1;
+
+ kl = 1;
+ kln = 0;
+ if (fromqr) {
+ kr = 0;
+ } else {
+ kr = *n;
+ }
+ ksr = 1;
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (select[k]) {
+
+/* Compute eigenvector(s) corresponding to W(K). */
+
+ if (fromqr) {
+
+/* If affiliation of eigenvalues is known, check whether */
+/* the matrix splits. */
+
+/* Determine KL and KR such that 1 <= KL <= K <= KR <= N */
+/* and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or */
+/* KR = N). */
+
+/* Then inverse iteration can be performed with the */
+/* submatrix H(KL:N,KL:N) for a left eigenvector, and with */
+/* the submatrix H(1:KR,1:KR) for a right eigenvector. */
+
+ i__2 = kl + 1;
+ for (i__ = k; i__ >= i__2; --i__) {
+ if (h__[i__ + (i__ - 1) * h_dim1] == 0.) {
+ goto L30;
+ }
+/* L20: */
+ }
+L30:
+ kl = i__;
+ if (k > kr) {
+ i__2 = *n - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ if (h__[i__ + 1 + i__ * h_dim1] == 0.) {
+ goto L50;
+ }
+/* L40: */
+ }
+L50:
+ kr = i__;
+ }
+ }
+
+ if (kl != kln) {
+ kln = kl;
+
+/* Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it */
+/* has not ben computed before. */
+
+ i__2 = kr - kl + 1;
+ hnorm = dlanhs_("I", &i__2, &h__[kl + kl * h_dim1], ldh, &
+ work[1]);
+ if (hnorm > 0.) {
+ eps3 = hnorm * ulp;
+ } else {
+ eps3 = smlnum;
+ }
+ }
+
+/* Perturb eigenvalue if it is close to any previous */
+/* selected eigenvalues affiliated to the submatrix */
+/* H(KL:KR,KL:KR). Close roots are modified by EPS3. */
+
+ wkr = wr[k];
+ wki = wi[k];
+L60:
+ i__2 = kl;
+ for (i__ = k - 1; i__ >= i__2; --i__) {
+ if (select[i__] && (d__1 = wr[i__] - wkr, abs(d__1)) + (d__2 =
+ wi[i__] - wki, abs(d__2)) < eps3) {
+ wkr += eps3;
+ goto L60;
+ }
+/* L70: */
+ }
+ wr[k] = wkr;
+
+ pair = wki != 0.;
+ if (pair) {
+ ksi = ksr + 1;
+ } else {
+ ksi = ksr;
+ }
+ if (leftv) {
+
+/* Compute left eigenvector. */
+
+ i__2 = *n - kl + 1;
+ dlaein_(&c_false, &noinit, &i__2, &h__[kl + kl * h_dim1], ldh,
+ &wkr, &wki, &vl[kl + ksr * vl_dim1], &vl[kl + ksi *
+ vl_dim1], &work[1], &ldwork, &work[*n * *n + *n + 1],
+ &eps3, &smlnum, &bignum, &iinfo);
+ if (iinfo > 0) {
+ if (pair) {
+ *info += 2;
+ } else {
+ ++(*info);
+ }
+ ifaill[ksr] = k;
+ ifaill[ksi] = k;
+ } else {
+ ifaill[ksr] = 0;
+ ifaill[ksi] = 0;
+ }
+ i__2 = kl - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ vl[i__ + ksr * vl_dim1] = 0.;
+/* L80: */
+ }
+ if (pair) {
+ i__2 = kl - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ vl[i__ + ksi * vl_dim1] = 0.;
+/* L90: */
+ }
+ }
+ }
+ if (rightv) {
+
+/* Compute right eigenvector. */
+
+ dlaein_(&c_true, &noinit, &kr, &h__[h_offset], ldh, &wkr, &
+ wki, &vr[ksr * vr_dim1 + 1], &vr[ksi * vr_dim1 + 1], &
+ work[1], &ldwork, &work[*n * *n + *n + 1], &eps3, &
+ smlnum, &bignum, &iinfo);
+ if (iinfo > 0) {
+ if (pair) {
+ *info += 2;
+ } else {
+ ++(*info);
+ }
+ ifailr[ksr] = k;
+ ifailr[ksi] = k;
+ } else {
+ ifailr[ksr] = 0;
+ ifailr[ksi] = 0;
+ }
+ i__2 = *n;
+ for (i__ = kr + 1; i__ <= i__2; ++i__) {
+ vr[i__ + ksr * vr_dim1] = 0.;
+/* L100: */
+ }
+ if (pair) {
+ i__2 = *n;
+ for (i__ = kr + 1; i__ <= i__2; ++i__) {
+ vr[i__ + ksi * vr_dim1] = 0.;
+/* L110: */
+ }
+ }
+ }
+
+ if (pair) {
+ ksr += 2;
+ } else {
+ ++ksr;
+ }
+ }
+/* L120: */
+ }
+
+ return 0;
+
+/* End of DHSEIN */
+
+} /* dhsein_ */
diff --git a/SRC/dhseqr.c b/SRC/dhseqr.c
new file mode 100644
index 0000000..48ad560
--- /dev/null
+++ b/SRC/dhseqr.c
@@ -0,0 +1,487 @@
+/* dhseqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b11 = 0.;
+static doublereal c_b12 = 1.;
+static integer c__12 = 12;
+static integer c__2 = 2;
+static integer c__49 = 49;
+
+/* Subroutine */ int dhseqr_(char *job, char *compz, integer *n, integer *ilo,
+ integer *ihi, doublereal *h__, integer *ldh, doublereal *wr,
+ doublereal *wi, doublereal *z__, integer *ldz, doublereal *work,
+ integer *lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2[2], i__3;
+ doublereal d__1;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ doublereal hl[2401] /* was [49][49] */;
+ integer kbot, nmin;
+ extern logical lsame_(char *, char *);
+ logical initz;
+ doublereal workl[49];
+ logical wantt, wantz;
+ extern /* Subroutine */ int dlaqr0_(logical *, logical *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, integer *), dlahqr_(logical *, logical *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+/* Purpose */
+/* ======= */
+
+/* DHSEQR computes the eigenvalues of a Hessenberg matrix H */
+/* and, optionally, the matrices T and Z from the Schur decomposition */
+/* H = Z T Z**T, where T is an upper quasi-triangular matrix (the */
+/* Schur form), and Z is the orthogonal matrix of Schur vectors. */
+
+/* Optionally Z may be postmultiplied into an input orthogonal */
+/* matrix Q so that this routine can give the Schur factorization */
+/* of a matrix A which has been reduced to the Hessenberg form H */
+/* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* = 'E': compute eigenvalues only; */
+/* = 'S': compute eigenvalues and the Schur form T. */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': no Schur vectors are computed; */
+/* = 'I': Z is initialized to the unit matrix and the matrix Z */
+/* of Schur vectors of H is returned; */
+/* = 'V': Z must contain an orthogonal matrix Q on entry, and */
+/* the product Q*Z is returned. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N .GE. 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that H is already upper triangular in rows */
+/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
+/* set by a previous call to DGEBAL, and then passed to DGEHRD */
+/* when the matrix output by DGEBAL is reduced to Hessenberg */
+/* form. Otherwise ILO and IHI should be set to 1 and N */
+/* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */
+/* If N = 0, then ILO = 1 and IHI = 0. */
+
+/* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */
+/* On entry, the upper Hessenberg matrix H. */
+/* On exit, if INFO = 0 and JOB = 'S', then H contains the */
+/* upper quasi-triangular matrix T from the Schur decomposition */
+/* (the Schur form); 2-by-2 diagonal blocks (corresponding to */
+/* complex conjugate pairs of eigenvalues) are returned in */
+/* standard form, with H(i,i) = H(i+1,i+1) and */
+/* H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the */
+/* contents of H are unspecified on exit. (The output value of */
+/* H when INFO.GT.0 is given under the description of INFO */
+/* below.) */
+
+/* Unlike earlier versions of DHSEQR, this subroutine may */
+/* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 */
+/* or j = IHI+1, IHI+2, ... N. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH .GE. max(1,N). */
+
+/* WR (output) DOUBLE PRECISION array, dimension (N) */
+/* WI (output) DOUBLE PRECISION array, dimension (N) */
+/* The real and imaginary parts, respectively, of the computed */
+/* eigenvalues. If two eigenvalues are computed as a complex */
+/* conjugate pair, they are stored in consecutive elements of */
+/* WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and */
+/* WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in */
+/* the same order as on the diagonal of the Schur form returned */
+/* in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 */
+/* diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and */
+/* WI(i+1) = -WI(i). */
+
+/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
+/* If COMPZ = 'N', Z is not referenced. */
+/* If COMPZ = 'I', on entry Z need not be set and on exit, */
+/* if INFO = 0, Z contains the orthogonal matrix Z of the Schur */
+/* vectors of H. If COMPZ = 'V', on entry Z must contain an */
+/* N-by-N matrix Q, which is assumed to be equal to the unit */
+/* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, */
+/* if INFO = 0, Z contains Q*Z. */
+/* Normally Q is the orthogonal matrix generated by DORGHR */
+/* after the call to DGEHRD which formed the Hessenberg matrix */
+/* H. (The output value of Z when INFO.GT.0 is given under */
+/* the description of INFO below.) */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. if COMPZ = 'I' or */
+/* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns an estimate of */
+/* the optimal value for LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK .GE. max(1,N) */
+/* is sufficient and delivers very good and sometimes */
+/* optimal performance. However, LWORK as large as 11*N */
+/* may be required for optimal performance. A workspace */
+/* query is recommended to determine the optimal workspace */
+/* size. */
+
+/* If LWORK = -1, then DHSEQR does a workspace query. */
+/* In this case, DHSEQR checks the input parameters and */
+/* estimates the optimal workspace size for the given */
+/* values of N, ILO and IHI. The estimate is returned */
+/* in WORK(1). No error message related to LWORK is */
+/* issued by XERBLA. Neither H nor Z are accessed. */
+
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* .LT. 0: if INFO = -i, the i-th argument had an illegal */
+/* value */
+/* .GT. 0: if INFO = i, DHSEQR failed to compute all of */
+/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */
+/* and WI contain those eigenvalues which have been */
+/* successfully computed. (Failures are rare.) */
+
+/* If INFO .GT. 0 and JOB = 'E', then on exit, the */
+/* remaining unconverged eigenvalues are the eigen- */
+/* values of the upper Hessenberg matrix rows and */
+/* columns ILO through INFO of the final, output */
+/* value of H. */
+
+/* If INFO .GT. 0 and JOB = 'S', then on exit */
+
+/* (*) (initial value of H)*U = U*(final value of H) */
+
+/* where U is an orthogonal matrix. The final */
+/* value of H is upper Hessenberg and quasi-triangular */
+/* in rows and columns INFO+1 through IHI. */
+
+/* If INFO .GT. 0 and COMPZ = 'V', then on exit */
+
+/* (final value of Z) = (initial value of Z)*U */
+
+/* where U is the orthogonal matrix in (*) (regard- */
+/* less of the value of JOB.) */
+
+/* If INFO .GT. 0 and COMPZ = 'I', then on exit */
+/* (final value of Z) = U */
+/* where U is the orthogonal matrix in (*) (regard- */
+/* less of the value of JOB.) */
+
+/* If INFO .GT. 0 and COMPZ = 'N', then Z is not */
+/* accessed. */
+
+/* ================================================================ */
+/* Default values supplied by */
+/* ILAENV(ISPEC,'DHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). */
+/* It is suggested that these defaults be adjusted in order */
+/* to attain best performance in each particular */
+/* computational environment. */
+
+/* ISPEC=12: The DLAHQR vs DLAQR0 crossover point. */
+/* Default: 75. (Must be at least 11.) */
+
+/* ISPEC=13: Recommended deflation window size. */
+/* This depends on ILO, IHI and NS. NS is the */
+/* number of simultaneous shifts returned */
+/* by ILAENV(ISPEC=15). (See ISPEC=15 below.) */
+/* The default for (IHI-ILO+1).LE.500 is NS. */
+/* The default for (IHI-ILO+1).GT.500 is 3*NS/2. */
+
+/* ISPEC=14: Nibble crossover point. (See IPARMQ for */
+/* details.) Default: 14% of deflation window */
+/* size. */
+
+/* ISPEC=15: Number of simultaneous shifts in a multishift */
+/* QR iteration. */
+
+/* If IHI-ILO+1 is ... */
+
+/* greater than ...but less ... the */
+/* or equal to ... than default is */
+
+/* 1 30 NS = 2(+) */
+/* 30 60 NS = 4(+) */
+/* 60 150 NS = 10(+) */
+/* 150 590 NS = ** */
+/* 590 3000 NS = 64 */
+/* 3000 6000 NS = 128 */
+/* 6000 infinity NS = 256 */
+
+/* (+) By default some or all matrices of this order */
+/* are passed to the implicit double shift routine */
+/* DLAHQR and this parameter is ignored. See */
+/* ISPEC=12 above and comments in IPARMQ for */
+/* details. */
+
+/* (**) The asterisks (**) indicate an ad-hoc */
+/* function of N increasing from 10 to 64. */
+
+/* ISPEC=16: Select structured matrix multiply. */
+/* If the number of simultaneous shifts (specified */
+/* by ISPEC=15) is less than 14, then the default */
+/* for ISPEC=16 is 0. Otherwise the default for */
+/* ISPEC=16 is 2. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* References: */
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */
+/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */
+/* 929--947, 2002. */
+
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */
+/* of Matrix Analysis, volume 23, pages 948--973, 2002. */
+
+/* ================================================================ */
+/* .. Parameters .. */
+
+/* ==== Matrices of order NTINY or smaller must be processed by */
+/* . DLAHQR because of insufficient subdiagonal scratch space. */
+/* . (This is a hard limit.) ==== */
+
+/* ==== NL allocates some local workspace to help small matrices */
+/* . through a rare DLAHQR failure. NL .GT. NTINY = 11 is */
+/* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- */
+/* . mended. (The default value of NMIN is 75.) Using NL = 49 */
+/* . allows up to six simultaneous shifts and a 16-by-16 */
+/* . deflation window. ==== */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* ==== Decode and check the input parameters. ==== */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --wr;
+ --wi;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ wantt = lsame_(job, "S");
+ initz = lsame_(compz, "I");
+ wantz = initz || lsame_(compz, "V");
+ work[1] = (doublereal) max(1,*n);
+ lquery = *lwork == -1;
+
+ *info = 0;
+ if (! lsame_(job, "E") && ! wantt) {
+ *info = -1;
+ } else if (! lsame_(compz, "N") && ! wantz) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ilo < 1 || *ilo > max(1,*n)) {
+ *info = -4;
+ } else if (*ihi < min(*ilo,*n) || *ihi > *n) {
+ *info = -5;
+ } else if (*ldh < max(1,*n)) {
+ *info = -7;
+ } else if (*ldz < 1 || wantz && *ldz < max(1,*n)) {
+ *info = -11;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -13;
+ }
+
+ if (*info != 0) {
+
+/* ==== Quick return in case of invalid argument. ==== */
+
+ i__1 = -(*info);
+ xerbla_("DHSEQR", &i__1);
+ return 0;
+
+ } else if (*n == 0) {
+
+/* ==== Quick return in case N = 0; nothing to do. ==== */
+
+ return 0;
+
+ } else if (lquery) {
+
+/* ==== Quick return in case of a workspace query ==== */
+
+ dlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[
+ 1], ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, info);
+/* ==== Ensure reported workspace size is backward-compatible with */
+/* . previous LAPACK versions. ==== */
+/* Computing MAX */
+ d__1 = (doublereal) max(1,*n);
+ work[1] = max(d__1,work[1]);
+ return 0;
+
+ } else {
+
+/* ==== copy eigenvalues isolated by DGEBAL ==== */
+
+ i__1 = *ilo - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ wr[i__] = h__[i__ + i__ * h_dim1];
+ wi[i__] = 0.;
+/* L10: */
+ }
+ i__1 = *n;
+ for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
+ wr[i__] = h__[i__ + i__ * h_dim1];
+ wi[i__] = 0.;
+/* L20: */
+ }
+
+/* ==== Initialize Z, if requested ==== */
+
+ if (initz) {
+ dlaset_("A", n, n, &c_b11, &c_b12, &z__[z_offset], ldz)
+ ;
+ }
+
+/* ==== Quick return if possible ==== */
+
+ if (*ilo == *ihi) {
+ wr[*ilo] = h__[*ilo + *ilo * h_dim1];
+ wi[*ilo] = 0.;
+ return 0;
+ }
+
+/* ==== DLAHQR/DLAQR0 crossover point ==== */
+
+/* Writing concatenation */
+ i__2[0] = 1, a__1[0] = job;
+ i__2[1] = 1, a__1[1] = compz;
+ s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2);
+ nmin = ilaenv_(&c__12, "DHSEQR", ch__1, n, ilo, ihi, lwork);
+ nmin = max(11,nmin);
+
+/* ==== DLAQR0 for big matrices; DLAHQR for small ones ==== */
+
+ if (*n > nmin) {
+ dlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1],
+ &wi[1], ilo, ihi, &z__[z_offset], ldz, &work[1], lwork,
+ info);
+ } else {
+
+/* ==== Small matrix ==== */
+
+ dlahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1],
+ &wi[1], ilo, ihi, &z__[z_offset], ldz, info);
+
+ if (*info > 0) {
+
+/* ==== A rare DLAHQR failure! DLAQR0 sometimes succeeds */
+/* . when DLAHQR fails. ==== */
+
+ kbot = *info;
+
+ if (*n >= 49) {
+
+/* ==== Larger matrices have enough subdiagonal scratch */
+/* . space to call DLAQR0 directly. ==== */
+
+ dlaqr0_(&wantt, &wantz, n, ilo, &kbot, &h__[h_offset],
+ ldh, &wr[1], &wi[1], ilo, ihi, &z__[z_offset],
+ ldz, &work[1], lwork, info);
+
+ } else {
+
+/* ==== Tiny matrices don't have enough subdiagonal */
+/* . scratch space to benefit from DLAQR0. Hence, */
+/* . tiny matrices must be copied into a larger */
+/* . array before calling DLAQR0. ==== */
+
+ dlacpy_("A", n, n, &h__[h_offset], ldh, hl, &c__49);
+ hl[*n + 1 + *n * 49 - 50] = 0.;
+ i__1 = 49 - *n;
+ dlaset_("A", &c__49, &i__1, &c_b11, &c_b11, &hl[(*n + 1) *
+ 49 - 49], &c__49);
+ dlaqr0_(&wantt, &wantz, &c__49, ilo, &kbot, hl, &c__49, &
+ wr[1], &wi[1], ilo, ihi, &z__[z_offset], ldz,
+ workl, &c__49, info);
+ if (wantt || *info != 0) {
+ dlacpy_("A", n, n, hl, &c__49, &h__[h_offset], ldh);
+ }
+ }
+ }
+ }
+
+/* ==== Clear out the trash, if necessary. ==== */
+
+ if ((wantt || *info != 0) && *n > 2) {
+ i__1 = *n - 2;
+ i__3 = *n - 2;
+ dlaset_("L", &i__1, &i__3, &c_b11, &c_b11, &h__[h_dim1 + 3], ldh);
+ }
+
+/* ==== Ensure reported workspace size is backward-compatible with */
+/* . previous LAPACK versions. ==== */
+
+/* Computing MAX */
+ d__1 = (doublereal) max(1,*n);
+ work[1] = max(d__1,work[1]);
+ }
+
+/* ==== End of DHSEQR ==== */
+
+ return 0;
+} /* dhseqr_ */
diff --git a/SRC/disnan.c b/SRC/disnan.c
new file mode 100644
index 0000000..564ca2c
--- /dev/null
+++ b/SRC/disnan.c
@@ -0,0 +1,52 @@
+/* disnan.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+logical disnan_(doublereal *din)
+{
+ /* System generated locals */
+ logical ret_val;
+
+ /* Local variables */
+ extern logical dlaisnan_(doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DISNAN returns .TRUE. if its argument is NaN, and .FALSE. */
+/* otherwise. To be replaced by the Fortran 2003 intrinsic in the */
+/* future. */
+
+/* Arguments */
+/* ========= */
+
+/* DIN (input) DOUBLE PRECISION */
+/* Input to test for NaN. */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ ret_val = dlaisnan_(din, din);
+ return ret_val;
+} /* disnan_ */
diff --git a/SRC/dla_gbamv.c b/SRC/dla_gbamv.c
new file mode 100644
index 0000000..21c540e
--- /dev/null
+++ b/SRC/dla_gbamv.c
@@ -0,0 +1,316 @@
+/* dla_gbamv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dla_gbamv__(integer *trans, integer *m, integer *n,
+ integer *kl, integer *ku, doublereal *alpha, doublereal *ab, integer *
+ ldab, doublereal *x, integer *incx, doublereal *beta, doublereal *y,
+ integer *incy)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ extern integer ilatrans_(char *);
+ integer i__, j;
+ logical symb_zero__;
+ integer kd, iy, jx, kx, ky, info;
+ doublereal temp;
+ integer lenx, leny;
+ doublereal safe1;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLA_GEAMV performs one of the matrix-vector operations */
+
+/* y := alpha*abs(A)*abs(x) + beta*abs(y), */
+/* or y := alpha*abs(A)'*abs(x) + beta*abs(y), */
+
+/* where alpha and beta are scalars, x and y are vectors and A is an */
+/* m by n matrix. */
+
+/* This function is primarily used in calculating error bounds. */
+/* To protect against underflow during evaluation, components in */
+/* the resulting vector are perturbed away from zero by (N+1) */
+/* times the underflow threshold. To prevent unnecessarily large */
+/* errors for block-structure embedded in general matrices, */
+/* "symbolically" zero components are not perturbed. A zero */
+/* entry is considered "symbolic" if all multiplications involved */
+/* in computing that entry have at least one zero multiplicand. */
+
+/* Parameters */
+/* ========== */
+
+/* TRANS - INTEGER */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) */
+/* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) */
+/* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER */
+/* On entry, M specifies the number of rows of the matrix A. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* KL - INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU - INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* ALPHA - DOUBLE PRECISION */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ) */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+/* X - DOUBLE PRECISION array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - DOUBLE PRECISION */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - DOUBLE PRECISION array of DIMENSION at least */
+/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
+/* Before entry with BETA non-zero, the incremented array Y */
+/* must contain the vector y. On exit, Y is overwritten by the */
+/* updated vector y. */
+
+/* INCY - INTEGER */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! (*trans == ilatrans_("N") || *trans == ilatrans_("T") || *trans == ilatrans_("C"))) {
+ info = 1;
+ } else if (*m < 0) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*kl < 0) {
+ info = 4;
+ } else if (*ku < 0) {
+ info = 5;
+ } else if (*ldab < *kl + *ku + 1) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ } else if (*incy == 0) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("DLA_GBAMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) {
+ return 0;
+ }
+
+/* Set LENX and LENY, the lengths of the vectors x and y, and set */
+/* up the start points in X and Y. */
+
+ if (*trans == ilatrans_("N")) {
+ lenx = *n;
+ leny = *m;
+ } else {
+ lenx = *m;
+ leny = *n;
+ }
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (lenx - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (leny - 1) * *incy;
+ }
+
+/* Set SAFE1 essentially to be the underflow threshold times the */
+/* number of additions in each row. */
+
+ safe1 = dlamch_("Safe minimum");
+ safe1 = (*n + 1) * safe1;
+
+/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */
+
+/* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to */
+/* the inexact flag. Still doesn't help change the iteration order */
+/* to per-column. */
+
+ kd = *ku + 1;
+ iy = ky;
+ if (*incx == 1) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.;
+ } else if (y[iy] == 0.) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (d__1 = y[iy], abs(d__1));
+ }
+ if (*alpha != 0.) {
+/* Computing MAX */
+ i__2 = i__ - *ku;
+/* Computing MIN */
+ i__4 = i__ + *kl;
+ i__3 = min(i__4,lenx);
+ for (j = max(i__2,1); j <= i__3; ++j) {
+ if (*trans == ilatrans_("N")) {
+ temp = (d__1 = ab[kd + i__ - j + j * ab_dim1], abs(
+ d__1));
+ } else {
+ temp = (d__1 = ab[j + (kd + i__ - j) * ab_dim1], abs(
+ d__1));
+ }
+ symb_zero__ = symb_zero__ && (x[j] == 0. || temp == 0.);
+ y[iy] += *alpha * (d__1 = x[j], abs(d__1)) * temp;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += d_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.;
+ } else if (y[iy] == 0.) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (d__1 = y[iy], abs(d__1));
+ }
+ if (*alpha != 0.) {
+ jx = kx;
+/* Computing MAX */
+ i__3 = i__ - *ku;
+/* Computing MIN */
+ i__4 = i__ + *kl;
+ i__2 = min(i__4,lenx);
+ for (j = max(i__3,1); j <= i__2; ++j) {
+ if (*trans == ilatrans_("N")) {
+ temp = (d__1 = ab[kd + i__ - j + j * ab_dim1], abs(
+ d__1));
+ } else {
+ temp = (d__1 = ab[j + (kd + i__ - j) * ab_dim1], abs(
+ d__1));
+ }
+ symb_zero__ = symb_zero__ && (x[jx] == 0. || temp == 0.);
+ y[iy] += *alpha * (d__1 = x[jx], abs(d__1)) * temp;
+ jx += *incx;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += d_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ }
+
+ return 0;
+
+/* End of DLA_GBAMV */
+
+} /* dla_gbamv__ */
diff --git a/SRC/dla_gbrcond.c b/SRC/dla_gbrcond.c
new file mode 100644
index 0000000..462fa17
--- /dev/null
+++ b/SRC/dla_gbrcond.c
@@ -0,0 +1,345 @@
+/* dla_gbrcond.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal dla_gbrcond__(char *trans, integer *n, integer *kl, integer *ku,
+ doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb,
+ integer *ipiv, integer *cmode, doublereal *c__, integer *info,
+ doublereal *work, integer *iwork, ftnlen trans_len)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val, d__1;
+
+ /* Local variables */
+ integer i__, j, kd, ke;
+ doublereal tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *), xerbla_(char *,
+ integer *), dgbtrs_(char *, integer *, integer *, integer
+ *, integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ doublereal ainvnm;
+ logical notrans;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLA_GERCOND Estimates the Skeel condition number of op(A) * op2(C) */
+/* where op2 is determined by CMODE as follows */
+/* CMODE = 1 op2(C) = C */
+/* CMODE = 0 op2(C) = I */
+/* CMODE = -1 op2(C) = inv(C) */
+/* The Skeel condition number cond(A) = norminf( |inv(A)||A| ) */
+/* is computed by computing scaling factors R such that */
+/* diag(R)*A*op2(C) is row equilibrated and computing the standard */
+/* infinity-norm condition number. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by DGBTRF. U is stored as an upper triangular */
+/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */
+/* and the multipliers used during the factorization are stored */
+/* in rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from the factorization A = P*L*U */
+/* as computed by DGBTRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* CMODE (input) INTEGER */
+/* Determines op2(C) in the formula op(A) * op2(C) as follows: */
+/* CMODE = 1 op2(C) = C */
+/* CMODE = 0 op2(C) = I */
+/* CMODE = -1 op2(C) = inv(C) */
+
+/* C (input) DOUBLE PRECISION array, dimension (N) */
+/* The vector C in the formula op(A) * op2(C). */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) DOUBLE PRECISION array, dimension (5*N). */
+/* Workspace. */
+
+/* IWORK (input) INTEGER array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ --c__;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ *info = 0;
+ notrans = lsame_(trans, "N");
+ if (! notrans && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0 || *kl > *n - 1) {
+ *info = -3;
+ } else if (*ku < 0 || *ku > *n - 1) {
+ *info = -4;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -6;
+ } else if (*ldafb < (*kl << 1) + *ku + 1) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLA_GBRCOND", &i__1);
+ return ret_val;
+ }
+ if (*n == 0) {
+ ret_val = 1.;
+ return ret_val;
+ }
+
+/* Compute the equilibration matrix R such that */
+/* inv(R)*A*C has unit 1-norm. */
+
+ kd = *ku + 1;
+ ke = *kl + 1;
+ if (notrans) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ if (*cmode == 1) {
+/* Computing MAX */
+ i__2 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__3 = min(i__4,*n);
+ for (j = max(i__2,1); j <= i__3; ++j) {
+ tmp += (d__1 = ab[kd + i__ - j + j * ab_dim1] * c__[j],
+ abs(d__1));
+ }
+ } else if (*cmode == 0) {
+/* Computing MAX */
+ i__3 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__2 = min(i__4,*n);
+ for (j = max(i__3,1); j <= i__2; ++j) {
+ tmp += (d__1 = ab[kd + i__ - j + j * ab_dim1], abs(d__1));
+ }
+ } else {
+/* Computing MAX */
+ i__2 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__3 = min(i__4,*n);
+ for (j = max(i__2,1); j <= i__3; ++j) {
+ tmp += (d__1 = ab[kd + i__ - j + j * ab_dim1] / c__[j],
+ abs(d__1));
+ }
+ }
+ work[(*n << 1) + i__] = tmp;
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ if (*cmode == 1) {
+/* Computing MAX */
+ i__3 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__2 = min(i__4,*n);
+ for (j = max(i__3,1); j <= i__2; ++j) {
+ tmp += (d__1 = ab[ke - i__ + j + i__ * ab_dim1] * c__[j],
+ abs(d__1));
+ }
+ } else if (*cmode == 0) {
+/* Computing MAX */
+ i__2 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__3 = min(i__4,*n);
+ for (j = max(i__2,1); j <= i__3; ++j) {
+ tmp += (d__1 = ab[ke - i__ + j + i__ * ab_dim1], abs(d__1)
+ );
+ }
+ } else {
+/* Computing MAX */
+ i__3 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__2 = min(i__4,*n);
+ for (j = max(i__3,1); j <= i__2; ++j) {
+ tmp += (d__1 = ab[ke - i__ + j + i__ * ab_dim1] / c__[j],
+ abs(d__1));
+ }
+ }
+ work[(*n << 1) + i__] = tmp;
+ }
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.;
+ kase = 0;
+L10:
+ dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= work[(*n << 1) + i__];
+ }
+ if (notrans) {
+ dgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset],
+ ldafb, &ipiv[1], &work[1], n, info);
+ } else {
+ dgbtrs_("Transpose", n, kl, ku, &c__1, &afb[afb_offset],
+ ldafb, &ipiv[1], &work[1], n, info);
+ }
+
+/* Multiply by inv(C). */
+
+ if (*cmode == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] /= c__[i__];
+ }
+ } else if (*cmode == -1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= c__[i__];
+ }
+ }
+ } else {
+
+/* Multiply by inv(C'). */
+
+ if (*cmode == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] /= c__[i__];
+ }
+ } else if (*cmode == -1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= c__[i__];
+ }
+ }
+ if (notrans) {
+ dgbtrs_("Transpose", n, kl, ku, &c__1, &afb[afb_offset],
+ ldafb, &ipiv[1], &work[1], n, info);
+ } else {
+ dgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset],
+ ldafb, &ipiv[1], &work[1], n, info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= work[(*n << 1) + i__];
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ ret_val = 1. / ainvnm;
+ }
+
+ return ret_val;
+
+} /* dla_gbrcond__ */
diff --git a/SRC/dla_gbrfsx_extended.c b/SRC/dla_gbrfsx_extended.c
new file mode 100644
index 0000000..ac8cfbb
--- /dev/null
+++ b/SRC/dla_gbrfsx_extended.c
@@ -0,0 +1,630 @@
+/* dla_gbrfsx_extended.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b6 = -1.;
+static doublereal c_b8 = 1.;
+
+/* Subroutine */ int dla_gbrfsx_extended__(integer *prec_type__, integer *
+ trans_type__, integer *n, integer *kl, integer *ku, integer *nrhs,
+ doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb,
+ integer *ipiv, logical *colequ, doublereal *c__, doublereal *b,
+ integer *ldb, doublereal *y, integer *ldy, doublereal *berr_out__,
+ integer *n_norms__, doublereal *err_bnds_norm__, doublereal *
+ err_bnds_comp__, doublereal *res, doublereal *ayb, doublereal *dy,
+ doublereal *y_tail__, doublereal *rcond, integer *ithresh, doublereal
+ *rthresh, doublereal *dz_ub__, logical *ignore_cwise__, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ y_dim1, y_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2;
+ char ch__1[1];
+
+ /* Local variables */
+ doublereal dxratmax, dzratmax;
+ integer i__, j, m;
+ extern /* Subroutine */ int dla_gbamv__(integer *, integer *, integer *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *);
+ logical incr_prec__;
+ doublereal prev_dz_z__, yk, final_dx_x__;
+ extern /* Subroutine */ int dla_wwaddw__(integer *, doublereal *,
+ doublereal *, doublereal *);
+ doublereal final_dz_z__, prevnormdx;
+ integer cnt;
+ doublereal dyk, eps, incr_thresh__, dx_x__, dz_z__;
+ extern /* Subroutine */ int dla_lin_berr__(integer *, integer *, integer *
+ , doublereal *, doublereal *, doublereal *);
+ doublereal ymin;
+ extern /* Subroutine */ int blas_dgbmv_x__(integer *, integer *, integer *
+ , integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+ integer y_prec_state__;
+ extern /* Subroutine */ int blas_dgbmv2_x__(integer *, integer *, integer
+ *, integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *), dgbmv_(char *, integer *, integer *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *), dcopy_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal dxrat, dzrat;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *);
+ char trans[1];
+ doublereal normx, normy;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dgbtrs_(char *, integer *, integer *, integer
+ *, integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ doublereal normdx;
+ extern /* Character */ VOID chla_transtype__(char *, ftnlen, integer *);
+ doublereal hugeval;
+ integer x_state__, z_state__;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLA_GBRFSX_EXTENDED improves the computed solution to a system of */
+/* linear equations by performing extra-precise iterative refinement */
+/* and provides error bounds and backward error estimates for the solution. */
+/* This subroutine is called by DGBRFSX to perform iterative refinement. */
+/* In addition to normwise error bound, the code provides maximum */
+/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP for details of the error bounds. Note that this */
+/* subroutine is only resonsible for setting the second fields of */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP. */
+
+/* Arguments */
+/* ========= */
+
+/* PREC_TYPE (input) INTEGER */
+/* Specifies the intermediate precision to be used in refinement. */
+/* The value is defined by ILAPREC(P) where P is a CHARACTER and */
+/* P = 'S': Single */
+/* = 'D': Double */
+/* = 'I': Indigenous */
+/* = 'X', 'E': Extra */
+
+/* TRANS_TYPE (input) INTEGER */
+/* Specifies the transposition operation on A. */
+/* The value is defined by ILATRANS(T) where T is a CHARACTER and */
+/* T = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0 */
+
+/* NRHS (input) INTEGER */
+/* The number of right-hand-sides, i.e., the number of columns of the */
+/* matrix B. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
+/* The factors L and U from the factorization */
+/* A = P*L*U as computed by DGBTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from the factorization A = P*L*U */
+/* as computed by DGBTRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* COLEQU (input) LOGICAL */
+/* If .TRUE. then column equilibration was done to A before calling */
+/* this routine. This is needed to compute the solution and error */
+/* bounds correctly. */
+
+/* C (input) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. If COLEQU = .FALSE., C */
+/* is not accessed. If C is input, each element of C should be a power */
+/* of the radix to ensure a reliable solution and error estimates. */
+/* Scaling by powers of the radix does not cause rounding errors unless */
+/* the result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right-hand-side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Y (input/output) DOUBLE PRECISION array, dimension */
+/* (LDY,NRHS) */
+/* On entry, the solution matrix X, as computed by DGBTRS. */
+/* On exit, the improved solution matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= max(1,N). */
+
+/* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* On exit, BERR_OUT(j) contains the componentwise relative backward */
+/* error for right-hand-side j from the formula */
+/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. This is computed by DLA_LIN_BERR. */
+
+/* N_NORMS (input) INTEGER */
+/* Determines which error bounds to return (see ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP). */
+/* If N_NORMS >= 1 return normwise error bounds. */
+/* If N_NORMS >= 2 return componentwise error bounds. */
+
+/* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* RES (input) DOUBLE PRECISION array, dimension (N) */
+/* Workspace to hold the intermediate residual. */
+
+/* AYB (input) DOUBLE PRECISION array, dimension (N) */
+/* Workspace. This can be the same workspace passed for Y_TAIL. */
+
+/* DY (input) DOUBLE PRECISION array, dimension (N) */
+/* Workspace to hold the intermediate solution. */
+
+/* Y_TAIL (input) DOUBLE PRECISION array, dimension (N) */
+/* Workspace to hold the trailing bits of the intermediate solution. */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* ITHRESH (input) INTEGER */
+/* The maximum number of residual computations allowed for */
+/* refinement. The default is 10. For 'aggressive' set to 100 to */
+/* permit convergence using approximate factorizations or */
+/* factorizations other than LU. If the factorization uses a */
+/* technique other than Gaussian elimination, the guarantees in */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */
+
+/* RTHRESH (input) DOUBLE PRECISION */
+/* Determines when to stop refinement if the error estimate stops */
+/* decreasing. Refinement will stop when the next solution no longer */
+/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */
+/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */
+/* default value is 0.5. For 'aggressive' set to 0.9 to permit */
+/* convergence on extremely ill-conditioned matrices. See LAWN 165 */
+/* for more details. */
+
+/* DZ_UB (input) DOUBLE PRECISION */
+/* Determines when to start considering componentwise convergence. */
+/* Componentwise convergence is only considered after each component */
+/* of the solution Y is stable, which we definte as the relative */
+/* change in each component being less than DZ_UB. The default value */
+/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */
+/* more details. */
+
+/* IGNORE_CWISE (input) LOGICAL */
+/* If .TRUE. then ignore componentwise convergence. Default value */
+/* is .FALSE.. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* < 0: if INFO = -i, the ith argument to DGBTRS had an illegal */
+/* value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ --berr_out__;
+ --res;
+ --ayb;
+ --dy;
+ --y_tail__;
+
+ /* Function Body */
+ if (*info != 0) {
+ return 0;
+ }
+ chla_transtype__(ch__1, (ftnlen)1, trans_type__);
+ *(unsigned char *)trans = *(unsigned char *)&ch__1[0];
+ eps = dlamch_("Epsilon");
+ hugeval = dlamch_("Overflow");
+/* Force HUGEVAL to Inf */
+ hugeval *= hugeval;
+/* Using HUGEVAL may lead to spurious underflows. */
+ incr_thresh__ = (doublereal) (*n) * eps;
+ m = *kl + *ku + 1;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ y_prec_state__ = 1;
+ if (y_prec_state__ == 2) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ y_tail__[i__] = 0.;
+ }
+ }
+ dxrat = 0.;
+ dxratmax = 0.;
+ dzrat = 0.;
+ dzratmax = 0.;
+ final_dx_x__ = hugeval;
+ final_dz_z__ = hugeval;
+ prevnormdx = hugeval;
+ prev_dz_z__ = hugeval;
+ dz_z__ = hugeval;
+ dx_x__ = hugeval;
+ x_state__ = 1;
+ z_state__ = 0;
+ incr_prec__ = FALSE_;
+ i__2 = *ithresh;
+ for (cnt = 1; cnt <= i__2; ++cnt) {
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ if (y_prec_state__ == 0) {
+ dgbmv_(trans, &m, n, kl, ku, &c_b6, &ab[ab_offset], ldab, &y[
+ j * y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1);
+ } else if (y_prec_state__ == 1) {
+ blas_dgbmv_x__(trans_type__, n, n, kl, ku, &c_b6, &ab[
+ ab_offset], ldab, &y[j * y_dim1 + 1], &c__1, &c_b8, &
+ res[1], &c__1, prec_type__);
+ } else {
+ blas_dgbmv2_x__(trans_type__, n, n, kl, ku, &c_b6, &ab[
+ ab_offset], ldab, &y[j * y_dim1 + 1], &y_tail__[1], &
+ c__1, &c_b8, &res[1], &c__1, prec_type__);
+ }
+/* XXX: RES is no longer needed. */
+ dcopy_(n, &res[1], &c__1, &dy[1], &c__1);
+ dgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1]
+, &dy[1], n, info);
+
+/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
+
+ normx = 0.;
+ normy = 0.;
+ normdx = 0.;
+ dz_z__ = 0.;
+ ymin = hugeval;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ yk = (d__1 = y[i__ + j * y_dim1], abs(d__1));
+ dyk = (d__1 = dy[i__], abs(d__1));
+ if (yk != 0.) {
+/* Computing MAX */
+ d__1 = dz_z__, d__2 = dyk / yk;
+ dz_z__ = max(d__1,d__2);
+ } else if (dyk != 0.) {
+ dz_z__ = hugeval;
+ }
+ ymin = min(ymin,yk);
+ normy = max(normy,yk);
+ if (*colequ) {
+/* Computing MAX */
+ d__1 = normx, d__2 = yk * c__[i__];
+ normx = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = normdx, d__2 = dyk * c__[i__];
+ normdx = max(d__1,d__2);
+ } else {
+ normx = normy;
+ normdx = max(normdx,dyk);
+ }
+ }
+ if (normx != 0.) {
+ dx_x__ = normdx / normx;
+ } else if (normdx == 0.) {
+ dx_x__ = 0.;
+ } else {
+ dx_x__ = hugeval;
+ }
+ dxrat = normdx / prevnormdx;
+ dzrat = dz_z__ / prev_dz_z__;
+
+/* Check termination criteria. */
+
+ if (! (*ignore_cwise__) && ymin * *rcond < incr_thresh__ * normy
+ && y_prec_state__ < 2) {
+ incr_prec__ = TRUE_;
+ }
+ if (x_state__ == 3 && dxrat <= *rthresh) {
+ x_state__ = 1;
+ }
+ if (x_state__ == 1) {
+ if (dx_x__ <= eps) {
+ x_state__ = 2;
+ } else if (dxrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ x_state__ = 3;
+ }
+ } else {
+ if (dxrat > dxratmax) {
+ dxratmax = dxrat;
+ }
+ }
+ if (x_state__ > 1) {
+ final_dx_x__ = dx_x__;
+ }
+ }
+ if (z_state__ == 0 && dz_z__ <= *dz_ub__) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 3 && dzrat <= *rthresh) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 1) {
+ if (dz_z__ <= eps) {
+ z_state__ = 2;
+ } else if (dz_z__ > *dz_ub__) {
+ z_state__ = 0;
+ dzratmax = 0.;
+ final_dz_z__ = hugeval;
+ } else if (dzrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ z_state__ = 3;
+ }
+ } else {
+ if (dzrat > dzratmax) {
+ dzratmax = dzrat;
+ }
+ }
+ if (z_state__ > 1) {
+ final_dz_z__ = dz_z__;
+ }
+ }
+
+/* Exit if both normwise and componentwise stopped working, */
+/* but if componentwise is unstable, let it go at least two */
+/* iterations. */
+
+ if (x_state__ != 1) {
+ if (*ignore_cwise__) {
+ goto L666;
+ }
+ if (z_state__ == 3 || z_state__ == 2) {
+ goto L666;
+ }
+ if (z_state__ == 0 && cnt > 1) {
+ goto L666;
+ }
+ }
+ if (incr_prec__) {
+ incr_prec__ = FALSE_;
+ ++y_prec_state__;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ y_tail__[i__] = 0.;
+ }
+ }
+ prevnormdx = normdx;
+ prev_dz_z__ = dz_z__;
+
+/* Update soluton. */
+
+ if (y_prec_state__ < 2) {
+ daxpy_(n, &c_b8, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
+ } else {
+ dla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
+ }
+ }
+/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */
+L666:
+
+/* Set final_* when cnt hits ithresh. */
+
+ if (x_state__ == 1) {
+ final_dx_x__ = dx_x__;
+ }
+ if (z_state__ == 1) {
+ final_dz_z__ = dz_z__;
+ }
+
+/* Compute error bounds. */
+
+ if (*n_norms__ >= 1) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / (
+ 1 - dxratmax);
+ }
+ if (*n_norms__ >= 2) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / (
+ 1 - dzratmax);
+ }
+
+/* Compute componentwise relative backward error from formula */
+/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. */
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ dgbmv_(trans, n, n, kl, ku, &c_b6, &ab[ab_offset], ldab, &y[j *
+ y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ayb[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1));
+ }
+
+/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */
+
+ dla_gbamv__(trans_type__, n, n, kl, ku, &c_b8, &ab[ab_offset], ldab, &
+ y[j * y_dim1 + 1], &c__1, &c_b8, &ayb[1], &c__1);
+ dla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
+
+/* End of loop for each RHS */
+
+ }
+
+ return 0;
+} /* dla_gbrfsx_extended__ */
diff --git a/SRC/dla_gbrpvgrw.c b/SRC/dla_gbrpvgrw.c
new file mode 100644
index 0000000..2f99730
--- /dev/null
+++ b/SRC/dla_gbrpvgrw.c
@@ -0,0 +1,136 @@
+/* dla_gbrpvgrw.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dla_gbrpvgrw__(integer *n, integer *kl, integer *ku, integer *
+ ncols, doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val, d__1, d__2;
+
+ /* Local variables */
+ integer i__, j, kd;
+ doublereal amax, umax, rpvgrw;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLA_GBRPVGRW computes the reciprocal pivot growth factor */
+/* norm(A)/norm(U). The "max absolute element" norm is used. If this is */
+/* much less than 1, the stability of the LU factorization of the */
+/* (equilibrated) matrix A could be poor. This also means that the */
+/* solution X, estimated condition numbers, and error bounds could be */
+/* unreliable. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NCOLS (input) INTEGER */
+/* The number of columns of the matrix A. NCOLS >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by DGBTRF. U is stored as an upper triangular */
+/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */
+/* and the multipliers used during the factorization are stored */
+/* in rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+
+ /* Function Body */
+ rpvgrw = 1.;
+ kd = *ku + 1;
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ amax = 0.;
+ umax = 0.;
+/* Computing MAX */
+ i__2 = j - *ku;
+/* Computing MIN */
+ i__4 = j + *kl;
+ i__3 = min(i__4,*n);
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ d__2 = (d__1 = ab[kd + i__ - j + j * ab_dim1], abs(d__1));
+ amax = max(d__2,amax);
+ }
+/* Computing MAX */
+ i__3 = j - *ku;
+ i__2 = j;
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = (d__1 = afb[kd + i__ - j + j * afb_dim1], abs(d__1));
+ umax = max(d__2,umax);
+ }
+ if (umax != 0.) {
+/* Computing MIN */
+ d__1 = amax / umax;
+ rpvgrw = min(d__1,rpvgrw);
+ }
+ }
+ ret_val = rpvgrw;
+ return ret_val;
+} /* dla_gbrpvgrw__ */
diff --git a/SRC/dla_geamv.c b/SRC/dla_geamv.c
new file mode 100644
index 0000000..c7e11f8
--- /dev/null
+++ b/SRC/dla_geamv.c
@@ -0,0 +1,293 @@
+/* dla_geamv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dla_geamv__(integer *trans, integer *m, integer *n,
+ doublereal *alpha, doublereal *a, integer *lda, doublereal *x,
+ integer *incx, doublereal *beta, doublereal *y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ extern integer ilatrans_(char *);
+ integer i__, j;
+ logical symb_zero__;
+ integer iy, jx, kx, ky, info;
+ doublereal temp;
+ integer lenx, leny;
+ doublereal safe1;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLA_GEAMV performs one of the matrix-vector operations */
+
+/* y := alpha*abs(A)*abs(x) + beta*abs(y), */
+/* or y := alpha*abs(A)'*abs(x) + beta*abs(y), */
+
+/* where alpha and beta are scalars, x and y are vectors and A is an */
+/* m by n matrix. */
+
+/* This function is primarily used in calculating error bounds. */
+/* To protect against underflow during evaluation, components in */
+/* the resulting vector are perturbed away from zero by (N+1) */
+/* times the underflow threshold. To prevent unnecessarily large */
+/* errors for block-structure embedded in general matrices, */
+/* "symbolically" zero components are not perturbed. A zero */
+/* entry is considered "symbolic" if all multiplications involved */
+/* in computing that entry have at least one zero multiplicand. */
+
+/* Parameters */
+/* ========== */
+
+/* TRANS - INTEGER */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) */
+/* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) */
+/* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER */
+/* On entry, M specifies the number of rows of the matrix A. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ) */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+/* X - DOUBLE PRECISION array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - DOUBLE PRECISION */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - DOUBLE PRECISION */
+/* Array of DIMENSION at least */
+/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
+/* Before entry with BETA non-zero, the incremented array Y */
+/* must contain the vector y. On exit, Y is overwritten by the */
+/* updated vector y. */
+
+/* INCY - INTEGER */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* Level 2 Blas routine. */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! (*trans == ilatrans_("N") || *trans == ilatrans_("T") || *trans == ilatrans_("C"))) {
+ info = 1;
+ } else if (*m < 0) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*lda < max(1,*m)) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ } else if (*incy == 0) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("DLA_GEAMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) {
+ return 0;
+ }
+
+/* Set LENX and LENY, the lengths of the vectors x and y, and set */
+/* up the start points in X and Y. */
+
+ if (*trans == ilatrans_("N")) {
+ lenx = *n;
+ leny = *m;
+ } else {
+ lenx = *m;
+ leny = *n;
+ }
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (lenx - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (leny - 1) * *incy;
+ }
+
+/* Set SAFE1 essentially to be the underflow threshold times the */
+/* number of additions in each row. */
+
+ safe1 = dlamch_("Safe minimum");
+ safe1 = (*n + 1) * safe1;
+
+/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */
+
+/* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to */
+/* the inexact flag. Still doesn't help change the iteration order */
+/* to per-column. */
+
+ iy = ky;
+ if (*incx == 1) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.;
+ } else if (y[iy] == 0.) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (d__1 = y[iy], abs(d__1));
+ }
+ if (*alpha != 0.) {
+ i__2 = lenx;
+ for (j = 1; j <= i__2; ++j) {
+ if (*trans == ilatrans_("N")) {
+ temp = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ } else {
+ temp = (d__1 = a[j + i__ * a_dim1], abs(d__1));
+ }
+ symb_zero__ = symb_zero__ && (x[j] == 0. || temp == 0.);
+ y[iy] += *alpha * (d__1 = x[j], abs(d__1)) * temp;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += d_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.;
+ } else if (y[iy] == 0.) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (d__1 = y[iy], abs(d__1));
+ }
+ if (*alpha != 0.) {
+ jx = kx;
+ i__2 = lenx;
+ for (j = 1; j <= i__2; ++j) {
+ if (*trans == ilatrans_("N")) {
+ temp = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ } else {
+ temp = (d__1 = a[j + i__ * a_dim1], abs(d__1));
+ }
+ symb_zero__ = symb_zero__ && (x[jx] == 0. || temp == 0.);
+ y[iy] += *alpha * (d__1 = x[jx], abs(d__1)) * temp;
+ jx += *incx;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += d_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ }
+
+ return 0;
+
+/* End of DLA_GEAMV */
+
+} /* dla_geamv__ */
diff --git a/SRC/dla_gercond.c b/SRC/dla_gercond.c
new file mode 100644
index 0000000..a90ba0b
--- /dev/null
+++ b/SRC/dla_gercond.c
@@ -0,0 +1,299 @@
+/* dla_gercond.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal dla_gercond__(char *trans, integer *n, doublereal *a, integer *lda,
+ doublereal *af, integer *ldaf, integer *ipiv, integer *cmode,
+ doublereal *c__, integer *info, doublereal *work, integer *iwork,
+ ftnlen trans_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2;
+ doublereal ret_val, d__1;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *), xerbla_(char *,
+ integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int dgetrs_(char *, integer *, integer *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *);
+ logical notrans;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLA_GERCOND estimates the Skeel condition number of op(A) * op2(C) */
+/* where op2 is determined by CMODE as follows */
+/* CMODE = 1 op2(C) = C */
+/* CMODE = 0 op2(C) = I */
+/* CMODE = -1 op2(C) = inv(C) */
+/* The Skeel condition number cond(A) = norminf( |inv(A)||A| ) */
+/* is computed by computing scaling factors R such that */
+/* diag(R)*A*op2(C) is row equilibrated and computing the standard */
+/* infinity-norm condition number. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
+/* The factors L and U from the factorization */
+/* A = P*L*U as computed by DGETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from the factorization A = P*L*U */
+/* as computed by DGETRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* CMODE (input) INTEGER */
+/* Determines op2(C) in the formula op(A) * op2(C) as follows: */
+/* CMODE = 1 op2(C) = C */
+/* CMODE = 0 op2(C) = I */
+/* CMODE = -1 op2(C) = inv(C) */
+
+/* C (input) DOUBLE PRECISION array, dimension (N) */
+/* The vector C in the formula op(A) * op2(C). */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) DOUBLE PRECISION array, dimension (3*N). */
+/* Workspace. */
+
+/* IWORK (input) INTEGER array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --c__;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ *info = 0;
+ notrans = lsame_(trans, "N");
+ if (! notrans && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLA_GERCOND", &i__1);
+ return ret_val;
+ }
+ if (*n == 0) {
+ ret_val = 1.;
+ return ret_val;
+ }
+
+/* Compute the equilibration matrix R such that */
+/* inv(R)*A*C has unit 1-norm. */
+
+ if (notrans) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ if (*cmode == 1) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[i__ + j * a_dim1] * c__[j], abs(d__1));
+ }
+ } else if (*cmode == 0) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ }
+ } else {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[i__ + j * a_dim1] / c__[j], abs(d__1));
+ }
+ }
+ work[(*n << 1) + i__] = tmp;
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ if (*cmode == 1) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[j + i__ * a_dim1] * c__[j], abs(d__1));
+ }
+ } else if (*cmode == 0) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1));
+ }
+ } else {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[j + i__ * a_dim1] / c__[j], abs(d__1));
+ }
+ }
+ work[(*n << 1) + i__] = tmp;
+ }
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.;
+ kase = 0;
+L10:
+ dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= work[(*n << 1) + i__];
+ }
+ if (notrans) {
+ dgetrs_("No transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[
+ 1], &work[1], n, info);
+ } else {
+ dgetrs_("Transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[1],
+ &work[1], n, info);
+ }
+
+/* Multiply by inv(C). */
+
+ if (*cmode == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] /= c__[i__];
+ }
+ } else if (*cmode == -1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= c__[i__];
+ }
+ }
+ } else {
+
+/* Multiply by inv(C'). */
+
+ if (*cmode == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] /= c__[i__];
+ }
+ } else if (*cmode == -1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= c__[i__];
+ }
+ }
+ if (notrans) {
+ dgetrs_("Transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[1],
+ &work[1], n, info);
+ } else {
+ dgetrs_("No transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[
+ 1], &work[1], n, info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= work[(*n << 1) + i__];
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ ret_val = 1. / ainvnm;
+ }
+
+ return ret_val;
+
+} /* dla_gercond__ */
diff --git a/SRC/dla_gerfsx_extended.c b/SRC/dla_gerfsx_extended.c
new file mode 100644
index 0000000..8120cae
--- /dev/null
+++ b/SRC/dla_gerfsx_extended.c
@@ -0,0 +1,622 @@
+/* dla_gerfsx_extended.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b6 = -1.;
+static doublereal c_b8 = 1.;
+
+/* Subroutine */ int dla_gerfsx_extended__(integer *prec_type__, integer *
+ trans_type__, integer *n, integer *nrhs, doublereal *a, integer *lda,
+ doublereal *af, integer *ldaf, integer *ipiv, logical *colequ,
+ doublereal *c__, doublereal *b, integer *ldb, doublereal *y, integer *
+ ldy, doublereal *berr_out__, integer *n_norms__, doublereal *errs_n__,
+ doublereal *errs_c__, doublereal *res, doublereal *ayb, doublereal *
+ dy, doublereal *y_tail__, doublereal *rcond, integer *ithresh,
+ doublereal *rthresh, doublereal *dz_ub__, logical *ignore_cwise__,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1,
+ y_offset, errs_n_dim1, errs_n_offset, errs_c_dim1, errs_c_offset,
+ i__1, i__2, i__3;
+ doublereal d__1, d__2;
+ char ch__1[1];
+
+ /* Local variables */
+ doublereal dxratmax, dzratmax;
+ integer i__, j;
+ extern /* Subroutine */ int dla_geamv__(integer *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ logical incr_prec__;
+ doublereal prev_dz_z__, yk, final_dx_x__;
+ extern /* Subroutine */ int dla_wwaddw__(integer *, doublereal *,
+ doublereal *, doublereal *);
+ doublereal final_dz_z__, prevnormdx;
+ integer cnt;
+ doublereal dyk, eps, incr_thresh__, dx_x__, dz_z__;
+ extern /* Subroutine */ int dla_lin_berr__(integer *, integer *, integer *
+ , doublereal *, doublereal *, doublereal *);
+ doublereal ymin;
+ extern /* Subroutine */ int blas_dgemv_x__(integer *, integer *, integer *
+ , doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *);
+ integer y_prec_state__;
+ extern /* Subroutine */ int blas_dgemv2_x__(integer *, integer *, integer
+ *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dgemv_(char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *), dcopy_(integer *, doublereal *,
+ integer *, doublereal *, integer *);
+ doublereal dxrat, dzrat;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *);
+ char trans[1];
+ doublereal normx, normy;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dgetrs_(char *, integer *, integer *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *);
+ doublereal normdx;
+ extern /* Character */ VOID chla_transtype__(char *, ftnlen, integer *);
+ doublereal hugeval;
+ integer x_state__, z_state__;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLA_GERFSX_EXTENDED improves the computed solution to a system of */
+/* linear equations by performing extra-precise iterative refinement */
+/* and provides error bounds and backward error estimates for the solution. */
+/* This subroutine is called by DGERFSX to perform iterative refinement. */
+/* In addition to normwise error bound, the code provides maximum */
+/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP for details of the error bounds. Note that this */
+/* subroutine is only resonsible for setting the second fields of */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP. */
+
+/* Arguments */
+/* ========= */
+
+/* PREC_TYPE (input) INTEGER */
+/* Specifies the intermediate precision to be used in refinement. */
+/* The value is defined by ILAPREC(P) where P is a CHARACTER and */
+/* P = 'S': Single */
+/* = 'D': Double */
+/* = 'I': Indigenous */
+/* = 'X', 'E': Extra */
+
+/* TRANS_TYPE (input) INTEGER */
+/* Specifies the transposition operation on A. */
+/* The value is defined by ILATRANS(T) where T is a CHARACTER and */
+/* T = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right-hand-sides, i.e., the number of columns of the */
+/* matrix B. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
+/* The factors L and U from the factorization */
+/* A = P*L*U as computed by DGETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from the factorization A = P*L*U */
+/* as computed by DGETRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* COLEQU (input) LOGICAL */
+/* If .TRUE. then column equilibration was done to A before calling */
+/* this routine. This is needed to compute the solution and error */
+/* bounds correctly. */
+
+/* C (input) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. If COLEQU = .FALSE., C */
+/* is not accessed. If C is input, each element of C should be a power */
+/* of the radix to ensure a reliable solution and error estimates. */
+/* Scaling by powers of the radix does not cause rounding errors unless */
+/* the result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right-hand-side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Y (input/output) DOUBLE PRECISION array, dimension */
+/* (LDY,NRHS) */
+/* On entry, the solution matrix X, as computed by DGETRS. */
+/* On exit, the improved solution matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= max(1,N). */
+
+/* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* On exit, BERR_OUT(j) contains the componentwise relative backward */
+/* error for right-hand-side j from the formula */
+/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. This is computed by DLA_LIN_BERR. */
+
+/* N_NORMS (input) INTEGER */
+/* Determines which error bounds to return (see ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP). */
+/* If N_NORMS >= 1 return normwise error bounds. */
+/* If N_NORMS >= 2 return componentwise error bounds. */
+
+/* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* RES (input) DOUBLE PRECISION array, dimension (N) */
+/* Workspace to hold the intermediate residual. */
+
+/* AYB (input) DOUBLE PRECISION array, dimension (N) */
+/* Workspace. This can be the same workspace passed for Y_TAIL. */
+
+/* DY (input) DOUBLE PRECISION array, dimension (N) */
+/* Workspace to hold the intermediate solution. */
+
+/* Y_TAIL (input) DOUBLE PRECISION array, dimension (N) */
+/* Workspace to hold the trailing bits of the intermediate solution. */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* ITHRESH (input) INTEGER */
+/* The maximum number of residual computations allowed for */
+/* refinement. The default is 10. For 'aggressive' set to 100 to */
+/* permit convergence using approximate factorizations or */
+/* factorizations other than LU. If the factorization uses a */
+/* technique other than Gaussian elimination, the guarantees in */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */
+
+/* RTHRESH (input) DOUBLE PRECISION */
+/* Determines when to stop refinement if the error estimate stops */
+/* decreasing. Refinement will stop when the next solution no longer */
+/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */
+/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */
+/* default value is 0.5. For 'aggressive' set to 0.9 to permit */
+/* convergence on extremely ill-conditioned matrices. See LAWN 165 */
+/* for more details. */
+
+/* DZ_UB (input) DOUBLE PRECISION */
+/* Determines when to start considering componentwise convergence. */
+/* Componentwise convergence is only considered after each component */
+/* of the solution Y is stable, which we definte as the relative */
+/* change in each component being less than DZ_UB. The default value */
+/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */
+/* more details. */
+
+/* IGNORE_CWISE (input) LOGICAL */
+/* If .TRUE. then ignore componentwise convergence. Default value */
+/* is .FALSE.. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* < 0: if INFO = -i, the ith argument to DGETRS had an illegal */
+/* value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ errs_c_dim1 = *nrhs;
+ errs_c_offset = 1 + errs_c_dim1;
+ errs_c__ -= errs_c_offset;
+ errs_n_dim1 = *nrhs;
+ errs_n_offset = 1 + errs_n_dim1;
+ errs_n__ -= errs_n_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ --berr_out__;
+ --res;
+ --ayb;
+ --dy;
+ --y_tail__;
+
+ /* Function Body */
+ if (*info != 0) {
+ return 0;
+ }
+ chla_transtype__(ch__1, (ftnlen)1, trans_type__);
+ *(unsigned char *)trans = *(unsigned char *)&ch__1[0];
+ eps = dlamch_("Epsilon");
+ hugeval = dlamch_("Overflow");
+/* Force HUGEVAL to Inf */
+ hugeval *= hugeval;
+/* Using HUGEVAL may lead to spurious underflows. */
+ incr_thresh__ = (doublereal) (*n) * eps;
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ y_prec_state__ = 1;
+ if (y_prec_state__ == 2) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ y_tail__[i__] = 0.;
+ }
+ }
+ dxrat = 0.;
+ dxratmax = 0.;
+ dzrat = 0.;
+ dzratmax = 0.;
+ final_dx_x__ = hugeval;
+ final_dz_z__ = hugeval;
+ prevnormdx = hugeval;
+ prev_dz_z__ = hugeval;
+ dz_z__ = hugeval;
+ dx_x__ = hugeval;
+ x_state__ = 1;
+ z_state__ = 0;
+ incr_prec__ = FALSE_;
+ i__2 = *ithresh;
+ for (cnt = 1; cnt <= i__2; ++cnt) {
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ if (y_prec_state__ == 0) {
+ dgemv_(trans, n, n, &c_b6, &a[a_offset], lda, &y[j * y_dim1 +
+ 1], &c__1, &c_b8, &res[1], &c__1);
+ } else if (y_prec_state__ == 1) {
+ blas_dgemv_x__(trans_type__, n, n, &c_b6, &a[a_offset], lda, &
+ y[j * y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1,
+ prec_type__);
+ } else {
+ blas_dgemv2_x__(trans_type__, n, n, &c_b6, &a[a_offset], lda,
+ &y[j * y_dim1 + 1], &y_tail__[1], &c__1, &c_b8, &res[
+ 1], &c__1, prec_type__);
+ }
+/* XXX: RES is no longer needed. */
+ dcopy_(n, &res[1], &c__1, &dy[1], &c__1);
+ dgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &dy[1],
+ n, info);
+
+/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
+
+ normx = 0.;
+ normy = 0.;
+ normdx = 0.;
+ dz_z__ = 0.;
+ ymin = hugeval;
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ yk = (d__1 = y[i__ + j * y_dim1], abs(d__1));
+ dyk = (d__1 = dy[i__], abs(d__1));
+ if (yk != 0.) {
+/* Computing MAX */
+ d__1 = dz_z__, d__2 = dyk / yk;
+ dz_z__ = max(d__1,d__2);
+ } else if (dyk != 0.) {
+ dz_z__ = hugeval;
+ }
+ ymin = min(ymin,yk);
+ normy = max(normy,yk);
+ if (*colequ) {
+/* Computing MAX */
+ d__1 = normx, d__2 = yk * c__[i__];
+ normx = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = normdx, d__2 = dyk * c__[i__];
+ normdx = max(d__1,d__2);
+ } else {
+ normx = normy;
+ normdx = max(normdx,dyk);
+ }
+ }
+ if (normx != 0.) {
+ dx_x__ = normdx / normx;
+ } else if (normdx == 0.) {
+ dx_x__ = 0.;
+ } else {
+ dx_x__ = hugeval;
+ }
+ dxrat = normdx / prevnormdx;
+ dzrat = dz_z__ / prev_dz_z__;
+
+/* Check termination criteria */
+
+ if (! (*ignore_cwise__) && ymin * *rcond < incr_thresh__ * normy
+ && y_prec_state__ < 2) {
+ incr_prec__ = TRUE_;
+ }
+ if (x_state__ == 3 && dxrat <= *rthresh) {
+ x_state__ = 1;
+ }
+ if (x_state__ == 1) {
+ if (dx_x__ <= eps) {
+ x_state__ = 2;
+ } else if (dxrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ x_state__ = 3;
+ }
+ } else {
+ if (dxrat > dxratmax) {
+ dxratmax = dxrat;
+ }
+ }
+ if (x_state__ > 1) {
+ final_dx_x__ = dx_x__;
+ }
+ }
+ if (z_state__ == 0 && dz_z__ <= *dz_ub__) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 3 && dzrat <= *rthresh) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 1) {
+ if (dz_z__ <= eps) {
+ z_state__ = 2;
+ } else if (dz_z__ > *dz_ub__) {
+ z_state__ = 0;
+ dzratmax = 0.;
+ final_dz_z__ = hugeval;
+ } else if (dzrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ z_state__ = 3;
+ }
+ } else {
+ if (dzrat > dzratmax) {
+ dzratmax = dzrat;
+ }
+ }
+ if (z_state__ > 1) {
+ final_dz_z__ = dz_z__;
+ }
+ }
+
+/* Exit if both normwise and componentwise stopped working, */
+/* but if componentwise is unstable, let it go at least two */
+/* iterations. */
+
+ if (x_state__ != 1) {
+ if (*ignore_cwise__) {
+ goto L666;
+ }
+ if (z_state__ == 3 || z_state__ == 2) {
+ goto L666;
+ }
+ if (z_state__ == 0 && cnt > 1) {
+ goto L666;
+ }
+ }
+ if (incr_prec__) {
+ incr_prec__ = FALSE_;
+ ++y_prec_state__;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ y_tail__[i__] = 0.;
+ }
+ }
+ prevnormdx = normdx;
+ prev_dz_z__ = dz_z__;
+
+/* Update soluton. */
+
+ if (y_prec_state__ < 2) {
+ daxpy_(n, &c_b8, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
+ } else {
+ dla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
+ }
+ }
+/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */
+L666:
+
+/* Set final_* when cnt hits ithresh. */
+
+ if (x_state__ == 1) {
+ final_dx_x__ = dx_x__;
+ }
+ if (z_state__ == 1) {
+ final_dz_z__ = dz_z__;
+ }
+
+/* Compute error bounds */
+
+ if (*n_norms__ >= 1) {
+ errs_n__[j + (errs_n_dim1 << 1)] = final_dx_x__ / (1 - dxratmax);
+ }
+ if (*n_norms__ >= 2) {
+ errs_c__[j + (errs_c_dim1 << 1)] = final_dz_z__ / (1 - dzratmax);
+ }
+
+/* Compute componentwise relative backward error from formula */
+/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. */
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ dgemv_(trans, n, n, &c_b6, &a[a_offset], lda, &y[j * y_dim1 + 1], &
+ c__1, &c_b8, &res[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ayb[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1));
+ }
+
+/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */
+
+ dla_geamv__(trans_type__, n, n, &c_b8, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &c__1, &c_b8, &ayb[1], &c__1);
+ dla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
+
+/* End of loop for each RHS. */
+
+ }
+
+ return 0;
+} /* dla_gerfsx_extended__ */
diff --git a/SRC/dla_lin_berr.c b/SRC/dla_lin_berr.c
new file mode 100644
index 0000000..7d96681
--- /dev/null
+++ b/SRC/dla_lin_berr.c
@@ -0,0 +1,124 @@
+/* dla_lin_berr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dla_lin_berr__(integer *n, integer *nz, integer *nrhs,
+ doublereal *res, doublereal *ayb, doublereal *berr)
+{
+ /* System generated locals */
+ integer ayb_dim1, ayb_offset, res_dim1, res_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal tmp, safe1;
+ extern doublereal dlamch_(char *);
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLA_LIN_BERR computes componentwise relative backward error from */
+/* the formula */
+/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. */
+
+/* Arguments */
+/* ========== */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NZ (input) INTEGER */
+/* We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to */
+/* guard against spuriously zero residuals. Default value is N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices AYB, RES, and BERR. NRHS >= 0. */
+
+/* RES (input) DOUBLE PRECISION array, dimension (N,NRHS) */
+/* The residual matrix, i.e., the matrix R in the relative backward */
+/* error formula above. */
+
+/* AYB (input) DOUBLE PRECISION array, dimension (N, NRHS) */
+/* The denominator in the relative backward error formula above, i.e., */
+/* the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B */
+/* are from iterative refinement (see dla_gerfsx_extended.f). */
+
+/* RES (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error from the formula above. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Adding SAFE1 to the numerator guards against spuriously zero */
+/* residuals. A similar safeguard is in the SLA_yyAMV routine used */
+/* to compute AYB. */
+
+ /* Parameter adjustments */
+ --berr;
+ ayb_dim1 = *n;
+ ayb_offset = 1 + ayb_dim1;
+ ayb -= ayb_offset;
+ res_dim1 = *n;
+ res_offset = 1 + res_dim1;
+ res -= res_offset;
+
+ /* Function Body */
+ safe1 = dlamch_("Safe minimum");
+ safe1 = (*nz + 1) * safe1;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (ayb[i__ + j * ayb_dim1] != 0.) {
+ tmp = (safe1 + (d__1 = res[i__ + j * res_dim1], abs(d__1))) /
+ ayb[i__ + j * ayb_dim1];
+/* Computing MAX */
+ d__1 = berr[j];
+ berr[j] = max(d__1,tmp);
+ }
+
+/* If AYB is exactly 0.0 (and if computed by SLA_yyAMV), then we know */
+/* the true residual also must be exactly 0.0. */
+
+ }
+ }
+ return 0;
+} /* dla_lin_berr__ */
diff --git a/SRC/dla_porcond.c b/SRC/dla_porcond.c
new file mode 100644
index 0000000..e7674f8
--- /dev/null
+++ b/SRC/dla_porcond.c
@@ -0,0 +1,309 @@
+/* dla_porcond.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal dla_porcond__(char *uplo, integer *n, doublereal *a, integer *lda,
+ doublereal *af, integer *ldaf, integer *cmode, doublereal *c__,
+ integer *info, doublereal *work, integer *iwork, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2;
+ doublereal ret_val, d__1;
+
+ /* Local variables */
+ integer i__, j;
+ logical up;
+ doublereal tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *), xerbla_(char *,
+ integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int dpotrs_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLA_PORCOND Estimates the Skeel condition number of op(A) * op2(C) */
+/* where op2 is determined by CMODE as follows */
+/* CMODE = 1 op2(C) = C */
+/* CMODE = 0 op2(C) = I */
+/* CMODE = -1 op2(C) = inv(C) */
+/* The Skeel condition number cond(A) = norminf( |inv(A)||A| ) */
+/* is computed by computing scaling factors R such that */
+/* diag(R)*A*op2(C) is row equilibrated and computing the standard */
+/* infinity-norm condition number. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by DPOTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* CMODE (input) INTEGER */
+/* Determines op2(C) in the formula op(A) * op2(C) as follows: */
+/* CMODE = 1 op2(C) = C */
+/* CMODE = 0 op2(C) = I */
+/* CMODE = -1 op2(C) = inv(C) */
+
+/* C (input) DOUBLE PRECISION array, dimension (N) */
+/* The vector C in the formula op(A) * op2(C). */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) DOUBLE PRECISION array, dimension (3*N). */
+/* Workspace. */
+
+/* IWORK (input) INTEGER array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --c__;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ *info = 0;
+ if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLA_PORCOND", &i__1);
+ return ret_val;
+ }
+ if (*n == 0) {
+ ret_val = 1.;
+ return ret_val;
+ }
+ up = FALSE_;
+ if (lsame_(uplo, "U")) {
+ up = TRUE_;
+ }
+
+/* Compute the equilibration matrix R such that */
+/* inv(R)*A*C has unit 1-norm. */
+
+ if (up) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ if (*cmode == 1) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[j + i__ * a_dim1] * c__[j], abs(d__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[i__ + j * a_dim1] * c__[j], abs(d__1));
+ }
+ } else if (*cmode == 0) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[j + i__ * a_dim1] / c__[j], abs(d__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[i__ + j * a_dim1] / c__[j], abs(d__1));
+ }
+ }
+ work[(*n << 1) + i__] = tmp;
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ if (*cmode == 1) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[i__ + j * a_dim1] * c__[j], abs(d__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[j + i__ * a_dim1] * c__[j], abs(d__1));
+ }
+ } else if (*cmode == 0) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1));
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[i__ + j * a_dim1] / c__[j], abs(d__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[j + i__ * a_dim1] / c__[j], abs(d__1));
+ }
+ }
+ work[(*n << 1) + i__] = tmp;
+ }
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.;
+ kase = 0;
+L10:
+ dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= work[(*n << 1) + i__];
+ }
+ if (up) {
+ dpotrs_("Upper", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ } else {
+ dpotrs_("Lower", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ }
+
+/* Multiply by inv(C). */
+
+ if (*cmode == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] /= c__[i__];
+ }
+ } else if (*cmode == -1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= c__[i__];
+ }
+ }
+ } else {
+
+/* Multiply by inv(C'). */
+
+ if (*cmode == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] /= c__[i__];
+ }
+ } else if (*cmode == -1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= c__[i__];
+ }
+ }
+ if (up) {
+ dpotrs_("Upper", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ } else {
+ dpotrs_("Lower", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= work[(*n << 1) + i__];
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ ret_val = 1. / ainvnm;
+ }
+
+ return ret_val;
+
+} /* dla_porcond__ */
diff --git a/SRC/dla_porfsx_extended.c b/SRC/dla_porfsx_extended.c
new file mode 100644
index 0000000..bd7a11c
--- /dev/null
+++ b/SRC/dla_porfsx_extended.c
@@ -0,0 +1,602 @@
+/* dla_porfsx_extended.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b9 = -1.;
+static doublereal c_b11 = 1.;
+
+/* Subroutine */ int dla_porfsx_extended__(integer *prec_type__, char *uplo,
+ integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *
+ af, integer *ldaf, logical *colequ, doublereal *c__, doublereal *b,
+ integer *ldb, doublereal *y, integer *ldy, doublereal *berr_out__,
+ integer *n_norms__, doublereal *err_bnds_norm__, doublereal *
+ err_bnds_comp__, doublereal *res, doublereal *ayb, doublereal *dy,
+ doublereal *y_tail__, doublereal *rcond, integer *ithresh, doublereal
+ *rthresh, doublereal *dz_ub__, logical *ignore_cwise__, integer *info,
+ ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1,
+ y_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ doublereal dxratmax, dzratmax;
+ integer i__, j;
+ logical incr_prec__;
+ extern /* Subroutine */ int dla_syamv__(integer *, integer *, doublereal *
+ , doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *);
+ doublereal prev_dz_z__, yk, final_dx_x__;
+ extern /* Subroutine */ int dla_wwaddw__(integer *, doublereal *,
+ doublereal *, doublereal *);
+ doublereal final_dz_z__, prevnormdx;
+ integer cnt;
+ doublereal dyk, eps, incr_thresh__, dx_x__, dz_z__;
+ extern /* Subroutine */ int dla_lin_berr__(integer *, integer *, integer *
+ , doublereal *, doublereal *, doublereal *);
+ doublereal ymin;
+ integer y_prec_state__;
+ extern /* Subroutine */ int blas_dsymv_x__(integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *);
+ integer uplo2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int blas_dsymv2_x__(integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *),
+ dcopy_(integer *, doublereal *, integer *, doublereal *, integer *
+);
+ doublereal dxrat, dzrat;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *), dsymv_(char *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ doublereal normx, normy;
+ extern doublereal dlamch_(char *);
+ doublereal normdx;
+ extern /* Subroutine */ int dpotrs_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+ doublereal hugeval;
+ extern integer ilauplo_(char *);
+ integer x_state__, z_state__;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLA_PORFSX_EXTENDED improves the computed solution to a system of */
+/* linear equations by performing extra-precise iterative refinement */
+/* and provides error bounds and backward error estimates for the solution. */
+/* This subroutine is called by DPORFSX to perform iterative refinement. */
+/* In addition to normwise error bound, the code provides maximum */
+/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP for details of the error bounds. Note that this */
+/* subroutine is only resonsible for setting the second fields of */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP. */
+
+/* Arguments */
+/* ========= */
+
+/* PREC_TYPE (input) INTEGER */
+/* Specifies the intermediate precision to be used in refinement. */
+/* The value is defined by ILAPREC(P) where P is a CHARACTER and */
+/* P = 'S': Single */
+/* = 'D': Double */
+/* = 'I': Indigenous */
+/* = 'X', 'E': Extra */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right-hand-sides, i.e., the number of columns of the */
+/* matrix B. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by DPOTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* COLEQU (input) LOGICAL */
+/* If .TRUE. then column equilibration was done to A before calling */
+/* this routine. This is needed to compute the solution and error */
+/* bounds correctly. */
+
+/* C (input) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. If COLEQU = .FALSE., C */
+/* is not accessed. If C is input, each element of C should be a power */
+/* of the radix to ensure a reliable solution and error estimates. */
+/* Scaling by powers of the radix does not cause rounding errors unless */
+/* the result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right-hand-side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Y (input/output) DOUBLE PRECISION array, dimension */
+/* (LDY,NRHS) */
+/* On entry, the solution matrix X, as computed by DPOTRS. */
+/* On exit, the improved solution matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= max(1,N). */
+
+/* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* On exit, BERR_OUT(j) contains the componentwise relative backward */
+/* error for right-hand-side j from the formula */
+/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. This is computed by DLA_LIN_BERR. */
+
+/* N_NORMS (input) INTEGER */
+/* Determines which error bounds to return (see ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP). */
+/* If N_NORMS >= 1 return normwise error bounds. */
+/* If N_NORMS >= 2 return componentwise error bounds. */
+
+/* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* RES (input) DOUBLE PRECISION array, dimension (N) */
+/* Workspace to hold the intermediate residual. */
+
+/* AYB (input) DOUBLE PRECISION array, dimension (N) */
+/* Workspace. This can be the same workspace passed for Y_TAIL. */
+
+/* DY (input) DOUBLE PRECISION array, dimension (N) */
+/* Workspace to hold the intermediate solution. */
+
+/* Y_TAIL (input) DOUBLE PRECISION array, dimension (N) */
+/* Workspace to hold the trailing bits of the intermediate solution. */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* ITHRESH (input) INTEGER */
+/* The maximum number of residual computations allowed for */
+/* refinement. The default is 10. For 'aggressive' set to 100 to */
+/* permit convergence using approximate factorizations or */
+/* factorizations other than LU. If the factorization uses a */
+/* technique other than Gaussian elimination, the guarantees in */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */
+
+/* RTHRESH (input) DOUBLE PRECISION */
+/* Determines when to stop refinement if the error estimate stops */
+/* decreasing. Refinement will stop when the next solution no longer */
+/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */
+/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */
+/* default value is 0.5. For 'aggressive' set to 0.9 to permit */
+/* convergence on extremely ill-conditioned matrices. See LAWN 165 */
+/* for more details. */
+
+/* DZ_UB (input) DOUBLE PRECISION */
+/* Determines when to start considering componentwise convergence. */
+/* Componentwise convergence is only considered after each component */
+/* of the solution Y is stable, which we definte as the relative */
+/* change in each component being less than DZ_UB. The default value */
+/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */
+/* more details. */
+
+/* IGNORE_CWISE (input) LOGICAL */
+/* If .TRUE. then ignore componentwise convergence. Default value */
+/* is .FALSE.. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* < 0: if INFO = -i, the ith argument to DPOTRS had an illegal */
+/* value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ --berr_out__;
+ --res;
+ --ayb;
+ --dy;
+ --y_tail__;
+
+ /* Function Body */
+ if (*info != 0) {
+ return 0;
+ }
+ eps = dlamch_("Epsilon");
+ hugeval = dlamch_("Overflow");
+/* Force HUGEVAL to Inf */
+ hugeval *= hugeval;
+/* Using HUGEVAL may lead to spurious underflows. */
+ incr_thresh__ = (doublereal) (*n) * eps;
+ if (lsame_(uplo, "L")) {
+ uplo2 = ilauplo_("L");
+ } else {
+ uplo2 = ilauplo_("U");
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ y_prec_state__ = 1;
+ if (y_prec_state__ == 2) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ y_tail__[i__] = 0.;
+ }
+ }
+ dxrat = 0.;
+ dxratmax = 0.;
+ dzrat = 0.;
+ dzratmax = 0.;
+ final_dx_x__ = hugeval;
+ final_dz_z__ = hugeval;
+ prevnormdx = hugeval;
+ prev_dz_z__ = hugeval;
+ dz_z__ = hugeval;
+ dx_x__ = hugeval;
+ x_state__ = 1;
+ z_state__ = 0;
+ incr_prec__ = FALSE_;
+ i__2 = *ithresh;
+ for (cnt = 1; cnt <= i__2; ++cnt) {
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ if (y_prec_state__ == 0) {
+ dsymv_(uplo, n, &c_b9, &a[a_offset], lda, &y[j * y_dim1 + 1],
+ &c__1, &c_b11, &res[1], &c__1);
+ } else if (y_prec_state__ == 1) {
+ blas_dsymv_x__(&uplo2, n, &c_b9, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &c__1, &c_b11, &res[1], &c__1,
+ prec_type__);
+ } else {
+ blas_dsymv2_x__(&uplo2, n, &c_b9, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &y_tail__[1], &c__1, &c_b11, &res[1], &
+ c__1, prec_type__);
+ }
+/* XXX: RES is no longer needed. */
+ dcopy_(n, &res[1], &c__1, &dy[1], &c__1);
+ dpotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &dy[1], n, info);
+
+/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
+
+ normx = 0.;
+ normy = 0.;
+ normdx = 0.;
+ dz_z__ = 0.;
+ ymin = hugeval;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ yk = (d__1 = y[i__ + j * y_dim1], abs(d__1));
+ dyk = (d__1 = dy[i__], abs(d__1));
+ if (yk != 0.) {
+/* Computing MAX */
+ d__1 = dz_z__, d__2 = dyk / yk;
+ dz_z__ = max(d__1,d__2);
+ } else if (dyk != 0.) {
+ dz_z__ = hugeval;
+ }
+ ymin = min(ymin,yk);
+ normy = max(normy,yk);
+ if (*colequ) {
+/* Computing MAX */
+ d__1 = normx, d__2 = yk * c__[i__];
+ normx = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = normdx, d__2 = dyk * c__[i__];
+ normdx = max(d__1,d__2);
+ } else {
+ normx = normy;
+ normdx = max(normdx,dyk);
+ }
+ }
+ if (normx != 0.) {
+ dx_x__ = normdx / normx;
+ } else if (normdx == 0.) {
+ dx_x__ = 0.;
+ } else {
+ dx_x__ = hugeval;
+ }
+ dxrat = normdx / prevnormdx;
+ dzrat = dz_z__ / prev_dz_z__;
+
+/* Check termination criteria. */
+
+ if (ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2) {
+ incr_prec__ = TRUE_;
+ }
+ if (x_state__ == 3 && dxrat <= *rthresh) {
+ x_state__ = 1;
+ }
+ if (x_state__ == 1) {
+ if (dx_x__ <= eps) {
+ x_state__ = 2;
+ } else if (dxrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ x_state__ = 3;
+ }
+ } else {
+ if (dxrat > dxratmax) {
+ dxratmax = dxrat;
+ }
+ }
+ if (x_state__ > 1) {
+ final_dx_x__ = dx_x__;
+ }
+ }
+ if (z_state__ == 0 && dz_z__ <= *dz_ub__) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 3 && dzrat <= *rthresh) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 1) {
+ if (dz_z__ <= eps) {
+ z_state__ = 2;
+ } else if (dz_z__ > *dz_ub__) {
+ z_state__ = 0;
+ dzratmax = 0.;
+ final_dz_z__ = hugeval;
+ } else if (dzrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ z_state__ = 3;
+ }
+ } else {
+ if (dzrat > dzratmax) {
+ dzratmax = dzrat;
+ }
+ }
+ if (z_state__ > 1) {
+ final_dz_z__ = dz_z__;
+ }
+ }
+ if (x_state__ != 1 && (*ignore_cwise__ || z_state__ != 1)) {
+ goto L666;
+ }
+ if (incr_prec__) {
+ incr_prec__ = FALSE_;
+ ++y_prec_state__;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ y_tail__[i__] = 0.;
+ }
+ }
+ prevnormdx = normdx;
+ prev_dz_z__ = dz_z__;
+
+/* Update soluton. */
+
+ if (y_prec_state__ < 2) {
+ daxpy_(n, &c_b11, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
+ } else {
+ dla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
+ }
+ }
+/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */
+L666:
+
+/* Set final_* when cnt hits ithresh. */
+
+ if (x_state__ == 1) {
+ final_dx_x__ = dx_x__;
+ }
+ if (z_state__ == 1) {
+ final_dz_z__ = dz_z__;
+ }
+
+/* Compute error bounds. */
+
+ if (*n_norms__ >= 1) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / (
+ 1 - dxratmax);
+ }
+ if (*n_norms__ >= 2) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / (
+ 1 - dzratmax);
+ }
+
+/* Compute componentwise relative backward error from formula */
+/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. */
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ dsymv_(uplo, n, &c_b9, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1, &
+ c_b11, &res[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ayb[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1));
+ }
+
+/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */
+
+ dla_syamv__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1],
+ &c__1, &c_b11, &ayb[1], &c__1);
+ dla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
+
+/* End of loop for each RHS. */
+
+ }
+
+ return 0;
+} /* dla_porfsx_extended__ */
diff --git a/SRC/dla_porpvgrw.c b/SRC/dla_porpvgrw.c
new file mode 100644
index 0000000..239607e
--- /dev/null
+++ b/SRC/dla_porpvgrw.c
@@ -0,0 +1,197 @@
+/* dla_porpvgrw.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dla_porpvgrw__(char *uplo, integer *ncols, doublereal *a, integer *
+ lda, doublereal *af, integer *ldaf, doublereal *work, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2;
+ doublereal ret_val, d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal amax, umax;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ doublereal rpvgrw;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLA_PORPVGRW computes the reciprocal pivot growth factor */
+/* norm(A)/norm(U). The "max absolute element" norm is used. If this is */
+/* much less than 1, the stability of the LU factorization of the */
+/* (equilibrated) matrix A could be poor. This also means that the */
+/* solution X, estimated condition numbers, and error bounds could be */
+/* unreliable. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* NCOLS (input) INTEGER */
+/* The number of columns of the matrix A. NCOLS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by DPOTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* WORK (input) DOUBLE PRECISION array, dimension (2*N) */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --work;
+
+ /* Function Body */
+ upper = lsame_("Upper", uplo);
+
+/* DPOTRF will have factored only the NCOLSxNCOLS leading minor, so */
+/* we restrict the growth search to that minor and use only the first */
+/* 2*NCOLS workspace entries. */
+
+ rpvgrw = 1.;
+ i__1 = *ncols << 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+ }
+
+/* Find the max magnitude entry of each column. */
+
+ if (upper) {
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = (d__1 = a[i__ + j * a_dim1], abs(d__1)), d__3 = work[*
+ ncols + j];
+ work[*ncols + j] = max(d__2,d__3);
+ }
+ }
+ } else {
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *ncols;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = (d__1 = a[i__ + j * a_dim1], abs(d__1)), d__3 = work[*
+ ncols + j];
+ work[*ncols + j] = max(d__2,d__3);
+ }
+ }
+ }
+
+/* Now find the max magnitude entry of each column of the factor in */
+/* AF. No pivoting, so no permutations. */
+
+ if (lsame_("Upper", uplo)) {
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = (d__1 = af[i__ + j * af_dim1], abs(d__1)), d__3 = work[
+ j];
+ work[j] = max(d__2,d__3);
+ }
+ }
+ } else {
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *ncols;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = (d__1 = af[i__ + j * af_dim1], abs(d__1)), d__3 = work[
+ j];
+ work[j] = max(d__2,d__3);
+ }
+ }
+ }
+
+/* Compute the *inverse* of the max element growth factor. Dividing */
+/* by zero would imply the largest entry of the factor's column is */
+/* zero. Than can happen when either the column of A is zero or */
+/* massive pivots made the factor underflow to zero. Neither counts */
+/* as growth in itself, so simply ignore terms with zero */
+/* denominators. */
+
+ if (lsame_("Upper", uplo)) {
+ i__1 = *ncols;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ umax = work[i__];
+ amax = work[*ncols + i__];
+ if (umax != 0.) {
+/* Computing MIN */
+ d__1 = amax / umax;
+ rpvgrw = min(d__1,rpvgrw);
+ }
+ }
+ } else {
+ i__1 = *ncols;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ umax = work[i__];
+ amax = work[*ncols + i__];
+ if (umax != 0.) {
+/* Computing MIN */
+ d__1 = amax / umax;
+ rpvgrw = min(d__1,rpvgrw);
+ }
+ }
+ }
+ ret_val = rpvgrw;
+ return ret_val;
+} /* dla_porpvgrw__ */
diff --git a/SRC/dla_rpvgrw.c b/SRC/dla_rpvgrw.c
new file mode 100644
index 0000000..53d3c2c
--- /dev/null
+++ b/SRC/dla_rpvgrw.c
@@ -0,0 +1,117 @@
+/* dla_rpvgrw.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dla_rpvgrw__(integer *n, integer *ncols, doublereal *a, integer *
+ lda, doublereal *af, integer *ldaf)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2;
+ doublereal ret_val, d__1, d__2;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal amax, umax, rpvgrw;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLA_RPVGRW computes the reciprocal pivot growth factor */
+/* norm(A)/norm(U). The "max absolute element" norm is used. If this is */
+/* much less than 1, the stability of the LU factorization of the */
+/* (equilibrated) matrix A could be poor. This also means that the */
+/* solution X, estimated condition numbers, and error bounds could be */
+/* unreliable. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NCOLS (input) INTEGER */
+/* The number of columns of the matrix A. NCOLS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
+/* The factors L and U from the factorization */
+/* A = P*L*U as computed by DGETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+
+ /* Function Body */
+ rpvgrw = 1.;
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ amax = 0.;
+ umax = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ amax = max(d__2,amax);
+ }
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = (d__1 = af[i__ + j * af_dim1], abs(d__1));
+ umax = max(d__2,umax);
+ }
+ if (umax != 0.) {
+/* Computing MIN */
+ d__1 = amax / umax;
+ rpvgrw = min(d__1,rpvgrw);
+ }
+ }
+ ret_val = rpvgrw;
+ return ret_val;
+} /* dla_rpvgrw__ */
diff --git a/SRC/dla_syamv.c b/SRC/dla_syamv.c
new file mode 100644
index 0000000..cc9aefa
--- /dev/null
+++ b/SRC/dla_syamv.c
@@ -0,0 +1,299 @@
+/* dla_syamv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dla_syamv__(integer *uplo, integer *n, doublereal *alpha,
+ doublereal *a, integer *lda, doublereal *x, integer *incx,
+ doublereal *beta, doublereal *y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer i__, j;
+ logical symb_zero__;
+ integer iy, jx, kx, ky, info;
+ doublereal temp, safe1;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilauplo_(char *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLA_SYAMV performs the matrix-vector operation */
+
+/* y := alpha*abs(A)*abs(x) + beta*abs(y), */
+
+/* where alpha and beta are scalars, x and y are vectors and A is an */
+/* n by n symmetric matrix. */
+
+/* This function is primarily used in calculating error bounds. */
+/* To protect against underflow during evaluation, components in */
+/* the resulting vector are perturbed away from zero by (N+1) */
+/* times the underflow threshold. To prevent unnecessarily large */
+/* errors for block-structure embedded in general matrices, */
+/* "symbolically" zero components are not perturbed. A zero */
+/* entry is considered "symbolic" if all multiplications involved */
+/* in computing that entry have at least one zero multiplicand. */
+
+/* Parameters */
+/* ========== */
+
+/* UPLO - INTEGER */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array A is to be referenced as */
+/* follows: */
+
+/* UPLO = BLAS_UPPER Only the upper triangular part of A */
+/* is to be referenced. */
+
+/* UPLO = BLAS_LOWER Only the lower triangular part of A */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+/* X - DOUBLE PRECISION array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ) */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - DOUBLE PRECISION . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - DOUBLE PRECISION array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ) */
+/* Before entry with BETA non-zero, the incremented array Y */
+/* must contain the vector y. On exit, Y is overwritten by the */
+/* updated vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+/* -- Modified for the absolute-value product, April 2006 */
+/* Jason Riedy, UC Berkeley */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (*uplo != ilauplo_("U") && *uplo != ilauplo_("L")
+ ) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*lda < max(1,*n)) {
+ info = 5;
+ } else if (*incx == 0) {
+ info = 7;
+ } else if (*incy == 0) {
+ info = 10;
+ }
+ if (info != 0) {
+ xerbla_("DSYMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0. && *beta == 1.) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Set SAFE1 essentially to be the underflow threshold times the */
+/* number of additions in each row. */
+
+ safe1 = dlamch_("Safe minimum");
+ safe1 = (*n + 1) * safe1;
+
+/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */
+
+/* The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to */
+/* the inexact flag. Still doesn't help change the iteration order */
+/* to per-column. */
+
+ iy = ky;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.;
+ } else if (y[iy] == 0.) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (d__1 = y[iy], abs(d__1));
+ }
+ if (*alpha != 0.) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (*uplo == ilauplo_("U")) {
+ if (i__ <= j) {
+ temp = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ } else {
+ temp = (d__1 = a[j + i__ * a_dim1], abs(d__1));
+ }
+ } else {
+ if (i__ >= j) {
+ temp = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ } else {
+ temp = (d__1 = a[j + i__ * a_dim1], abs(d__1));
+ }
+ }
+ symb_zero__ = symb_zero__ && (x[j] == 0. || temp == 0.);
+ y[iy] += *alpha * (d__1 = x[j], abs(d__1)) * temp;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += d_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.;
+ } else if (y[iy] == 0.) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (d__1 = y[iy], abs(d__1));
+ }
+ jx = kx;
+ if (*alpha != 0.) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (*uplo == ilauplo_("U")) {
+ if (i__ <= j) {
+ temp = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ } else {
+ temp = (d__1 = a[j + i__ * a_dim1], abs(d__1));
+ }
+ } else {
+ if (i__ >= j) {
+ temp = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ } else {
+ temp = (d__1 = a[j + i__ * a_dim1], abs(d__1));
+ }
+ }
+ symb_zero__ = symb_zero__ && (x[j] == 0. || temp == 0.);
+ y[iy] += *alpha * (d__1 = x[jx], abs(d__1)) * temp;
+ jx += *incx;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += d_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ }
+
+ return 0;
+
+/* End of DLA_SYAMV */
+
+} /* dla_syamv__ */
diff --git a/SRC/dla_syrcond.c b/SRC/dla_syrcond.c
new file mode 100644
index 0000000..0371ccf
--- /dev/null
+++ b/SRC/dla_syrcond.c
@@ -0,0 +1,322 @@
+/* dla_syrcond.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal dla_syrcond__(char *uplo, integer *n, doublereal *a, integer *lda,
+ doublereal *af, integer *ldaf, integer *ipiv, integer *cmode,
+ doublereal *c__, integer *info, doublereal *work, integer *iwork,
+ ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2;
+ doublereal ret_val, d__1;
+
+ /* Local variables */
+ integer i__, j;
+ logical up;
+ doublereal tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal ainvnm;
+ char normin[1];
+ doublereal smlnum;
+ extern /* Subroutine */ int dsytrs_(char *, integer *, integer *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLA_SYRCOND estimates the Skeel condition number of op(A) * op2(C) */
+/* where op2 is determined by CMODE as follows */
+/* CMODE = 1 op2(C) = C */
+/* CMODE = 0 op2(C) = I */
+/* CMODE = -1 op2(C) = inv(C) */
+/* The Skeel condition number cond(A) = norminf( |inv(A)||A| ) */
+/* is computed by computing scaling factors R such that */
+/* diag(R)*A*op2(C) is row equilibrated and computing the standard */
+/* infinity-norm condition number. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by DSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by DSYTRF. */
+
+/* CMODE (input) INTEGER */
+/* Determines op2(C) in the formula op(A) * op2(C) as follows: */
+/* CMODE = 1 op2(C) = C */
+/* CMODE = 0 op2(C) = I */
+/* CMODE = -1 op2(C) = inv(C) */
+
+/* C (input) DOUBLE PRECISION array, dimension (N) */
+/* The vector C in the formula op(A) * op2(C). */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) DOUBLE PRECISION array, dimension (3*N). */
+/* Workspace. */
+
+/* IWORK (input) INTEGER array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --c__;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ *info = 0;
+ if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLA_SYRCOND", &i__1);
+ return ret_val;
+ }
+ if (*n == 0) {
+ ret_val = 1.;
+ return ret_val;
+ }
+ up = FALSE_;
+ if (lsame_(uplo, "U")) {
+ up = TRUE_;
+ }
+
+/* Compute the equilibration matrix R such that */
+/* inv(R)*A*C has unit 1-norm. */
+
+ if (up) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ if (*cmode == 1) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[j + i__ * a_dim1] * c__[j], abs(d__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[i__ + j * a_dim1] * c__[j], abs(d__1));
+ }
+ } else if (*cmode == 0) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[j + i__ * a_dim1] / c__[j], abs(d__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[i__ + j * a_dim1] / c__[j], abs(d__1));
+ }
+ }
+ work[(*n << 1) + i__] = tmp;
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ if (*cmode == 1) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[i__ + j * a_dim1] * c__[j], abs(d__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[j + i__ * a_dim1] * c__[j], abs(d__1));
+ }
+ } else if (*cmode == 0) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1));
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[i__ + j * a_dim1] / c__[j], abs(d__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (d__1 = a[j + i__ * a_dim1] / c__[j], abs(d__1));
+ }
+ }
+ work[(*n << 1) + i__] = tmp;
+ }
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ smlnum = dlamch_("Safe minimum");
+ ainvnm = 0.;
+ *(unsigned char *)normin = 'N';
+ kase = 0;
+L10:
+ dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= work[(*n << 1) + i__];
+ }
+ if (up) {
+ dsytrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ } else {
+ dsytrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+
+/* Multiply by inv(C). */
+
+ if (*cmode == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] /= c__[i__];
+ }
+ } else if (*cmode == -1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= c__[i__];
+ }
+ }
+ } else {
+
+/* Multiply by inv(C'). */
+
+ if (*cmode == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] /= c__[i__];
+ }
+ } else if (*cmode == -1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= c__[i__];
+ }
+ }
+ if (up) {
+ dsytrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ } else {
+ dsytrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= work[(*n << 1) + i__];
+ }
+ }
+
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ ret_val = 1. / ainvnm;
+ }
+
+ return ret_val;
+
+} /* dla_syrcond__ */
diff --git a/SRC/dla_syrfsx_extended.c b/SRC/dla_syrfsx_extended.c
new file mode 100644
index 0000000..bae1dad
--- /dev/null
+++ b/SRC/dla_syrfsx_extended.c
@@ -0,0 +1,608 @@
+/* dla_syrfsx_extended.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b9 = -1.;
+static doublereal c_b11 = 1.;
+
+/* Subroutine */ int dla_syrfsx_extended__(integer *prec_type__, char *uplo,
+ integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *
+ af, integer *ldaf, integer *ipiv, logical *colequ, doublereal *c__,
+ doublereal *b, integer *ldb, doublereal *y, integer *ldy, doublereal *
+ berr_out__, integer *n_norms__, doublereal *err_bnds_norm__,
+ doublereal *err_bnds_comp__, doublereal *res, doublereal *ayb,
+ doublereal *dy, doublereal *y_tail__, doublereal *rcond, integer *
+ ithresh, doublereal *rthresh, doublereal *dz_ub__, logical *
+ ignore_cwise__, integer *info, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1,
+ y_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ doublereal dxratmax, dzratmax;
+ integer i__, j;
+ logical incr_prec__;
+ extern /* Subroutine */ int dla_syamv__(integer *, integer *, doublereal *
+ , doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *);
+ doublereal prev_dz_z__, yk, final_dx_x__;
+ extern /* Subroutine */ int dla_wwaddw__(integer *, doublereal *,
+ doublereal *, doublereal *);
+ doublereal final_dz_z__, prevnormdx;
+ integer cnt;
+ doublereal dyk, eps, incr_thresh__, dx_x__, dz_z__;
+ extern /* Subroutine */ int dla_lin_berr__(integer *, integer *, integer *
+ , doublereal *, doublereal *, doublereal *);
+ doublereal ymin;
+ integer y_prec_state__;
+ extern /* Subroutine */ int blas_dsymv_x__(integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *);
+ integer uplo2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int blas_dsymv2_x__(integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *),
+ dcopy_(integer *, doublereal *, integer *, doublereal *, integer *
+);
+ doublereal dxrat, dzrat;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *), dsymv_(char *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ doublereal normx, normy;
+ extern doublereal dlamch_(char *);
+ doublereal normdx;
+ extern /* Subroutine */ int dsytrs_(char *, integer *, integer *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *);
+ doublereal hugeval;
+ extern integer ilauplo_(char *);
+ integer x_state__, z_state__;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLA_SYRFSX_EXTENDED improves the computed solution to a system of */
+/* linear equations by performing extra-precise iterative refinement */
+/* and provides error bounds and backward error estimates for the solution. */
+/* This subroutine is called by DSYRFSX to perform iterative refinement. */
+/* In addition to normwise error bound, the code provides maximum */
+/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP for details of the error bounds. Note that this */
+/* subroutine is only resonsible for setting the second fields of */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP. */
+
+/* Arguments */
+/* ========= */
+
+/* PREC_TYPE (input) INTEGER */
+/* Specifies the intermediate precision to be used in refinement. */
+/* The value is defined by ILAPREC(P) where P is a CHARACTER and */
+/* P = 'S': Single */
+/* = 'D': Double */
+/* = 'I': Indigenous */
+/* = 'X', 'E': Extra */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right-hand-sides, i.e., the number of columns of the */
+/* matrix B. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by DSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by DSYTRF. */
+
+/* COLEQU (input) LOGICAL */
+/* If .TRUE. then column equilibration was done to A before calling */
+/* this routine. This is needed to compute the solution and error */
+/* bounds correctly. */
+
+/* C (input) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. If COLEQU = .FALSE., C */
+/* is not accessed. If C is input, each element of C should be a power */
+/* of the radix to ensure a reliable solution and error estimates. */
+/* Scaling by powers of the radix does not cause rounding errors unless */
+/* the result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right-hand-side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Y (input/output) DOUBLE PRECISION array, dimension */
+/* (LDY,NRHS) */
+/* On entry, the solution matrix X, as computed by DSYTRS. */
+/* On exit, the improved solution matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= max(1,N). */
+
+/* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* On exit, BERR_OUT(j) contains the componentwise relative backward */
+/* error for right-hand-side j from the formula */
+/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. This is computed by DLA_LIN_BERR. */
+
+/* N_NORMS (input) INTEGER */
+/* Determines which error bounds to return (see ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP). */
+/* If N_NORMS >= 1 return normwise error bounds. */
+/* If N_NORMS >= 2 return componentwise error bounds. */
+
+/* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* RES (input) DOUBLE PRECISION array, dimension (N) */
+/* Workspace to hold the intermediate residual. */
+
+/* AYB (input) DOUBLE PRECISION array, dimension (N) */
+/* Workspace. This can be the same workspace passed for Y_TAIL. */
+
+/* DY (input) DOUBLE PRECISION array, dimension (N) */
+/* Workspace to hold the intermediate solution. */
+
+/* Y_TAIL (input) DOUBLE PRECISION array, dimension (N) */
+/* Workspace to hold the trailing bits of the intermediate solution. */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* ITHRESH (input) INTEGER */
+/* The maximum number of residual computations allowed for */
+/* refinement. The default is 10. For 'aggressive' set to 100 to */
+/* permit convergence using approximate factorizations or */
+/* factorizations other than LU. If the factorization uses a */
+/* technique other than Gaussian elimination, the guarantees in */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */
+
+/* RTHRESH (input) DOUBLE PRECISION */
+/* Determines when to stop refinement if the error estimate stops */
+/* decreasing. Refinement will stop when the next solution no longer */
+/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */
+/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */
+/* default value is 0.5. For 'aggressive' set to 0.9 to permit */
+/* convergence on extremely ill-conditioned matrices. See LAWN 165 */
+/* for more details. */
+
+/* DZ_UB (input) DOUBLE PRECISION */
+/* Determines when to start considering componentwise convergence. */
+/* Componentwise convergence is only considered after each component */
+/* of the solution Y is stable, which we definte as the relative */
+/* change in each component being less than DZ_UB. The default value */
+/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */
+/* more details. */
+
+/* IGNORE_CWISE (input) LOGICAL */
+/* If .TRUE. then ignore componentwise convergence. Default value */
+/* is .FALSE.. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* < 0: if INFO = -i, the ith argument to DSYTRS had an illegal */
+/* value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ --berr_out__;
+ --res;
+ --ayb;
+ --dy;
+ --y_tail__;
+
+ /* Function Body */
+ if (*info != 0) {
+ return 0;
+ }
+ eps = dlamch_("Epsilon");
+ hugeval = dlamch_("Overflow");
+/* Force HUGEVAL to Inf */
+ hugeval *= hugeval;
+/* Using HUGEVAL may lead to spurious underflows. */
+ incr_thresh__ = (doublereal) (*n) * eps;
+ if (lsame_(uplo, "L")) {
+ uplo2 = ilauplo_("L");
+ } else {
+ uplo2 = ilauplo_("U");
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ y_prec_state__ = 1;
+ if (y_prec_state__ == 2) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ y_tail__[i__] = 0.;
+ }
+ }
+ dxrat = 0.;
+ dxratmax = 0.;
+ dzrat = 0.;
+ dzratmax = 0.;
+ final_dx_x__ = hugeval;
+ final_dz_z__ = hugeval;
+ prevnormdx = hugeval;
+ prev_dz_z__ = hugeval;
+ dz_z__ = hugeval;
+ dx_x__ = hugeval;
+ x_state__ = 1;
+ z_state__ = 0;
+ incr_prec__ = FALSE_;
+ i__2 = *ithresh;
+ for (cnt = 1; cnt <= i__2; ++cnt) {
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ if (y_prec_state__ == 0) {
+ dsymv_(uplo, n, &c_b9, &a[a_offset], lda, &y[j * y_dim1 + 1],
+ &c__1, &c_b11, &res[1], &c__1);
+ } else if (y_prec_state__ == 1) {
+ blas_dsymv_x__(&uplo2, n, &c_b9, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &c__1, &c_b11, &res[1], &c__1,
+ prec_type__);
+ } else {
+ blas_dsymv2_x__(&uplo2, n, &c_b9, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &y_tail__[1], &c__1, &c_b11, &res[1], &
+ c__1, prec_type__);
+ }
+/* XXX: RES is no longer needed. */
+ dcopy_(n, &res[1], &c__1, &dy[1], &c__1);
+ dsytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &dy[1], n,
+ info);
+
+/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
+
+ normx = 0.;
+ normy = 0.;
+ normdx = 0.;
+ dz_z__ = 0.;
+ ymin = hugeval;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ yk = (d__1 = y[i__ + j * y_dim1], abs(d__1));
+ dyk = (d__1 = dy[i__], abs(d__1));
+ if (yk != 0.) {
+/* Computing MAX */
+ d__1 = dz_z__, d__2 = dyk / yk;
+ dz_z__ = max(d__1,d__2);
+ } else if (dyk != 0.) {
+ dz_z__ = hugeval;
+ }
+ ymin = min(ymin,yk);
+ normy = max(normy,yk);
+ if (*colequ) {
+/* Computing MAX */
+ d__1 = normx, d__2 = yk * c__[i__];
+ normx = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = normdx, d__2 = dyk * c__[i__];
+ normdx = max(d__1,d__2);
+ } else {
+ normx = normy;
+ normdx = max(normdx,dyk);
+ }
+ }
+ if (normx != 0.) {
+ dx_x__ = normdx / normx;
+ } else if (normdx == 0.) {
+ dx_x__ = 0.;
+ } else {
+ dx_x__ = hugeval;
+ }
+ dxrat = normdx / prevnormdx;
+ dzrat = dz_z__ / prev_dz_z__;
+
+/* Check termination criteria. */
+
+ if (ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2) {
+ incr_prec__ = TRUE_;
+ }
+ if (x_state__ == 3 && dxrat <= *rthresh) {
+ x_state__ = 1;
+ }
+ if (x_state__ == 1) {
+ if (dx_x__ <= eps) {
+ x_state__ = 2;
+ } else if (dxrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ x_state__ = 3;
+ }
+ } else {
+ if (dxrat > dxratmax) {
+ dxratmax = dxrat;
+ }
+ }
+ if (x_state__ > 1) {
+ final_dx_x__ = dx_x__;
+ }
+ }
+ if (z_state__ == 0 && dz_z__ <= *dz_ub__) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 3 && dzrat <= *rthresh) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 1) {
+ if (dz_z__ <= eps) {
+ z_state__ = 2;
+ } else if (dz_z__ > *dz_ub__) {
+ z_state__ = 0;
+ dzratmax = 0.;
+ final_dz_z__ = hugeval;
+ } else if (dzrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ z_state__ = 3;
+ }
+ } else {
+ if (dzrat > dzratmax) {
+ dzratmax = dzrat;
+ }
+ }
+ if (z_state__ > 1) {
+ final_dz_z__ = dz_z__;
+ }
+ }
+ if (x_state__ != 1 && (*ignore_cwise__ || z_state__ != 1)) {
+ goto L666;
+ }
+ if (incr_prec__) {
+ incr_prec__ = FALSE_;
+ ++y_prec_state__;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ y_tail__[i__] = 0.;
+ }
+ }
+ prevnormdx = normdx;
+ prev_dz_z__ = dz_z__;
+
+/* Update soluton. */
+
+ if (y_prec_state__ < 2) {
+ daxpy_(n, &c_b11, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
+ } else {
+ dla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
+ }
+ }
+/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */
+L666:
+
+/* Set final_* when cnt hits ithresh. */
+
+ if (x_state__ == 1) {
+ final_dx_x__ = dx_x__;
+ }
+ if (z_state__ == 1) {
+ final_dz_z__ = dz_z__;
+ }
+
+/* Compute error bounds. */
+
+ if (*n_norms__ >= 1) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / (
+ 1 - dxratmax);
+ }
+ if (*n_norms__ >= 2) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / (
+ 1 - dzratmax);
+ }
+
+/* Compute componentwise relative backward error from formula */
+/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. */
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+ dcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ dsymv_(uplo, n, &c_b9, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1, &
+ c_b11, &res[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ayb[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1));
+ }
+
+/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */
+
+ dla_syamv__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1],
+ &c__1, &c_b11, &ayb[1], &c__1);
+ dla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
+
+/* End of loop for each RHS. */
+
+ }
+
+ return 0;
+} /* dla_syrfsx_extended__ */
diff --git a/SRC/dla_syrpvgrw.c b/SRC/dla_syrpvgrw.c
new file mode 100644
index 0000000..bc6eb85
--- /dev/null
+++ b/SRC/dla_syrpvgrw.c
@@ -0,0 +1,330 @@
+/* dla_syrpvgrw.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dla_syrpvgrw__(char *uplo, integer *n, integer *info, doublereal *
+ a, integer *lda, doublereal *af, integer *ldaf, integer *ipiv,
+ doublereal *work, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2;
+ doublereal ret_val, d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, k, kp;
+ doublereal tmp, amax, umax;
+ extern logical lsame_(char *, char *);
+ integer ncols;
+ logical upper;
+ doublereal rpvgrw;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLA_SYRPVGRW computes the reciprocal pivot growth factor */
+/* norm(A)/norm(U). The "max absolute element" norm is used. If this is */
+/* much less than 1, the stability of the LU factorization of the */
+/* (equilibrated) matrix A could be poor. This also means that the */
+/* solution X, estimated condition numbers, and error bounds could be */
+/* unreliable. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* INFO (input) INTEGER */
+/* The value of INFO returned from DSYTRF, .i.e., the pivot in */
+/* column INFO is exactly 0. */
+
+/* NCOLS (input) INTEGER */
+/* The number of columns of the matrix A. NCOLS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by DSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by DSYTRF. */
+
+/* WORK (input) DOUBLE PRECISION array, dimension (2*N) */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ upper = lsame_("Upper", uplo);
+ if (*info == 0) {
+ if (upper) {
+ ncols = 1;
+ } else {
+ ncols = *n;
+ }
+ } else {
+ ncols = *info;
+ }
+ rpvgrw = 1.;
+ i__1 = *n << 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+ }
+
+/* Find the max magnitude entry of each column of A. Compute the max */
+/* for all N columns so we can apply the pivot permutation while */
+/* looping below. Assume a full factorization is the common case. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = (d__1 = a[i__ + j * a_dim1], abs(d__1)), d__3 = work[*
+ n + i__];
+ work[*n + i__] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = (d__1 = a[i__ + j * a_dim1], abs(d__1)), d__3 = work[*
+ n + j];
+ work[*n + j] = max(d__2,d__3);
+ }
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = (d__1 = a[i__ + j * a_dim1], abs(d__1)), d__3 = work[*
+ n + i__];
+ work[*n + i__] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = (d__1 = a[i__ + j * a_dim1], abs(d__1)), d__3 = work[*
+ n + j];
+ work[*n + j] = max(d__2,d__3);
+ }
+ }
+ }
+
+/* Now find the max magnitude entry of each column of U or L. Also */
+/* permute the magnitudes of A above so they're in the same order as */
+/* the factor. */
+
+/* The iteration orders and permutations were copied from dsytrs. */
+/* Calls to SSWAP would be severe overkill. */
+
+ if (upper) {
+ k = *n;
+ while(k < ncols && k > 0) {
+ if (ipiv[k] > 0) {
+/* 1x1 pivot */
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = (d__1 = af[i__ + k * af_dim1], abs(d__1)), d__3 =
+ work[k];
+ work[k] = max(d__2,d__3);
+ }
+ --k;
+ } else {
+/* 2x2 pivot */
+ kp = -ipiv[k];
+ tmp = work[*n + k - 1];
+ work[*n + k - 1] = work[*n + kp];
+ work[*n + kp] = tmp;
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = (d__1 = af[i__ + k * af_dim1], abs(d__1)), d__3 =
+ work[k];
+ work[k] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = (d__1 = af[i__ + (k - 1) * af_dim1], abs(d__1)),
+ d__3 = work[k - 1];
+ work[k - 1] = max(d__2,d__3);
+ }
+/* Computing MAX */
+ d__2 = (d__1 = af[k + k * af_dim1], abs(d__1)), d__3 = work[k]
+ ;
+ work[k] = max(d__2,d__3);
+ k += -2;
+ }
+ }
+ k = ncols;
+ while(k <= *n) {
+ if (ipiv[k] > 0) {
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ ++k;
+ } else {
+ kp = -ipiv[k];
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ k += 2;
+ }
+ }
+ } else {
+ k = 1;
+ while(k <= ncols) {
+ if (ipiv[k] > 0) {
+/* 1x1 pivot */
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ i__1 = *n;
+ for (i__ = k; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = (d__1 = af[i__ + k * af_dim1], abs(d__1)), d__3 =
+ work[k];
+ work[k] = max(d__2,d__3);
+ }
+ ++k;
+ } else {
+/* 2x2 pivot */
+ kp = -ipiv[k];
+ tmp = work[*n + k + 1];
+ work[*n + k + 1] = work[*n + kp];
+ work[*n + kp] = tmp;
+ i__1 = *n;
+ for (i__ = k + 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = (d__1 = af[i__ + k * af_dim1], abs(d__1)), d__3 =
+ work[k];
+ work[k] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = (d__1 = af[i__ + (k + 1) * af_dim1], abs(d__1)),
+ d__3 = work[k + 1];
+ work[k + 1] = max(d__2,d__3);
+ }
+/* Computing MAX */
+ d__2 = (d__1 = af[k + k * af_dim1], abs(d__1)), d__3 = work[k]
+ ;
+ work[k] = max(d__2,d__3);
+ k += 2;
+ }
+ }
+ k = ncols;
+ while(k >= 1) {
+ if (ipiv[k] > 0) {
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ --k;
+ } else {
+ kp = -ipiv[k];
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ k += -2;
+ }
+ }
+ }
+
+/* Compute the *inverse* of the max element growth factor. Dividing */
+/* by zero would imply the largest entry of the factor's column is */
+/* zero. Than can happen when either the column of A is zero or */
+/* massive pivots made the factor underflow to zero. Neither counts */
+/* as growth in itself, so simply ignore terms with zero */
+/* denominators. */
+
+ if (upper) {
+ i__1 = *n;
+ for (i__ = ncols; i__ <= i__1; ++i__) {
+ umax = work[i__];
+ amax = work[*n + i__];
+ if (umax != 0.) {
+/* Computing MIN */
+ d__1 = amax / umax;
+ rpvgrw = min(d__1,rpvgrw);
+ }
+ }
+ } else {
+ i__1 = ncols;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ umax = work[i__];
+ amax = work[*n + i__];
+ if (umax != 0.) {
+/* Computing MIN */
+ d__1 = amax / umax;
+ rpvgrw = min(d__1,rpvgrw);
+ }
+ }
+ }
+ ret_val = rpvgrw;
+ return ret_val;
+} /* dla_syrpvgrw__ */
diff --git a/SRC/dla_wwaddw.c b/SRC/dla_wwaddw.c
new file mode 100644
index 0000000..25b6e67
--- /dev/null
+++ b/SRC/dla_wwaddw.c
@@ -0,0 +1,80 @@
+/* dla_wwaddw.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dla_wwaddw__(integer *n, doublereal *x, doublereal *y,
+ doublereal *w)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__;
+ doublereal s;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLA_WWADDW adds a vector W into a doubled-single vector (X, Y). */
+
+/* This works for all extant IBM's hex and binary floating point */
+/* arithmetics, but not for decimal. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The length of vectors X, Y, and W. */
+
+/* X, Y (input/output) DOUBLE PRECISION array, length N */
+/* The doubled-single accumulation vector. */
+
+/* W (input) DOUBLE PRECISION array, length N */
+/* The vector to be added. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --w;
+ --y;
+ --x;
+
+ /* Function Body */
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s = x[i__] + w[i__];
+ s = s + s - s;
+ y[i__] = x[i__] - s + w[i__] + y[i__];
+ x[i__] = s;
+/* L10: */
+ }
+ return 0;
+} /* dla_wwaddw__ */
diff --git a/SRC/dlabad.c b/SRC/dlabad.c
new file mode 100644
index 0000000..01e6a9c
--- /dev/null
+++ b/SRC/dlabad.c
@@ -0,0 +1,72 @@
+/* dlabad.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlabad_(doublereal *small, doublereal *large)
+{
+ /* Builtin functions */
+ double d_lg10(doublereal *), sqrt(doublereal);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLABAD takes as input the values computed by DLAMCH for underflow and */
+/* overflow, and returns the square root of each of these values if the */
+/* log of LARGE is sufficiently large. This subroutine is intended to */
+/* identify machines with a large exponent range, such as the Crays, and */
+/* redefine the underflow and overflow limits to be the square roots of */
+/* the values computed by DLAMCH. This subroutine is needed because */
+/* DLAMCH does not compensate for poor arithmetic in the upper half of */
+/* the exponent range, as is found on a Cray. */
+
+/* Arguments */
+/* ========= */
+
+/* SMALL (input/output) DOUBLE PRECISION */
+/* On entry, the underflow threshold as computed by DLAMCH. */
+/* On exit, if LOG10(LARGE) is sufficiently large, the square */
+/* root of SMALL, otherwise unchanged. */
+
+/* LARGE (input/output) DOUBLE PRECISION */
+/* On entry, the overflow threshold as computed by DLAMCH. */
+/* On exit, if LOG10(LARGE) is sufficiently large, the square */
+/* root of LARGE, otherwise unchanged. */
+
+/* ===================================================================== */
+
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* If it looks like we're on a Cray, take the square root of */
+/* SMALL and LARGE to avoid overflow and underflow problems. */
+
+ if (d_lg10(large) > 2e3) {
+ *small = sqrt(*small);
+ *large = sqrt(*large);
+ }
+
+ return 0;
+
+/* End of DLABAD */
+
+} /* dlabad_ */
diff --git a/SRC/dlabrd.c b/SRC/dlabrd.c
new file mode 100644
index 0000000..2048ef7
--- /dev/null
+++ b/SRC/dlabrd.c
@@ -0,0 +1,434 @@
+/* dlabrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b4 = -1.;
+static doublereal c_b5 = 1.;
+static integer c__1 = 1;
+static doublereal c_b16 = 0.;
+
+/* Subroutine */ int dlabrd_(integer *m, integer *n, integer *nb, doublereal *
+ a, integer *lda, doublereal *d__, doublereal *e, doublereal *tauq,
+ doublereal *taup, doublereal *x, integer *ldx, doublereal *y, integer
+ *ldy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2,
+ i__3;
+
+ /* Local variables */
+ integer i__;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *), dgemv_(char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *), dlarfg_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLABRD reduces the first NB rows and columns of a real general */
+/* m by n matrix A to upper or lower bidiagonal form by an orthogonal */
+/* transformation Q' * A * P, and returns the matrices X and Y which */
+/* are needed to apply the transformation to the unreduced part of A. */
+
+/* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower */
+/* bidiagonal form. */
+
+/* This is an auxiliary routine called by DGEBRD */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows in the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns in the matrix A. */
+
+/* NB (input) INTEGER */
+/* The number of leading rows and columns of A to be reduced. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the m by n general matrix to be reduced. */
+/* On exit, the first NB rows and columns of the matrix are */
+/* overwritten; the rest of the array is unchanged. */
+/* If m >= n, elements on and below the diagonal in the first NB */
+/* columns, with the array TAUQ, represent the orthogonal */
+/* matrix Q as a product of elementary reflectors; and */
+/* elements above the diagonal in the first NB rows, with the */
+/* array TAUP, represent the orthogonal matrix P as a product */
+/* of elementary reflectors. */
+/* If m < n, elements below the diagonal in the first NB */
+/* columns, with the array TAUQ, represent the orthogonal */
+/* matrix Q as a product of elementary reflectors, and */
+/* elements on and above the diagonal in the first NB rows, */
+/* with the array TAUP, represent the orthogonal matrix P as */
+/* a product of elementary reflectors. */
+/* See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* D (output) DOUBLE PRECISION array, dimension (NB) */
+/* The diagonal elements of the first NB rows and columns of */
+/* the reduced matrix. D(i) = A(i,i). */
+
+/* E (output) DOUBLE PRECISION array, dimension (NB) */
+/* The off-diagonal elements of the first NB rows and columns of */
+/* the reduced matrix. */
+
+/* TAUQ (output) DOUBLE PRECISION array dimension (NB) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the orthogonal matrix Q. See Further Details. */
+
+/* TAUP (output) DOUBLE PRECISION array, dimension (NB) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the orthogonal matrix P. See Further Details. */
+
+/* X (output) DOUBLE PRECISION array, dimension (LDX,NB) */
+/* The m-by-nb matrix X required to update the unreduced part */
+/* of A. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= M. */
+
+/* Y (output) DOUBLE PRECISION array, dimension (LDY,NB) */
+/* The n-by-nb matrix Y required to update the unreduced part */
+/* of A. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= N. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrices Q and P are represented as products of elementary */
+/* reflectors: */
+
+/* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) */
+
+/* Each H(i) and G(i) has the form: */
+
+/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
+
+/* where tauq and taup are real scalars, and v and u are real vectors. */
+
+/* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in */
+/* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in */
+/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in */
+/* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in */
+/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* The elements of the vectors v and u together form the m-by-nb matrix */
+/* V and the nb-by-n matrix U' which are needed, with X and Y, to apply */
+/* the transformation to the unreduced part of the matrix, using a block */
+/* update of the form: A := A - V*Y' - X*U'. */
+
+/* The contents of A on exit are illustrated by the following examples */
+/* with nb = 2: */
+
+/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
+
+/* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) */
+/* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) */
+/* ( v1 v2 a a a ) ( v1 1 a a a a ) */
+/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */
+/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */
+/* ( v1 v2 a a a ) */
+
+/* where a denotes an element of the original matrix which is unchanged, */
+/* vi denotes an element of the vector defining H(i), and ui an element */
+/* of the vector defining G(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ --tauq;
+ --taup;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+ if (*m >= *n) {
+
+/* Reduce to upper bidiagonal form */
+
+ i__1 = *nb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Update A(i:m,i) */
+
+ i__2 = *m - i__ + 1;
+ i__3 = i__ - 1;
+ dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + a_dim1], lda,
+ &y[i__ + y_dim1], ldy, &c_b5, &a[i__ + i__ * a_dim1], &
+ c__1);
+ i__2 = *m - i__ + 1;
+ i__3 = i__ - 1;
+ dgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + x_dim1], ldx,
+ &a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[i__ + i__ *
+ a_dim1], &c__1);
+
+/* Generate reflection Q(i) to annihilate A(i+1:m,i) */
+
+ i__2 = *m - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3, *m)+ i__ *
+ a_dim1], &c__1, &tauq[i__]);
+ d__[i__] = a[i__ + i__ * a_dim1];
+ if (i__ < *n) {
+ a[i__ + i__ * a_dim1] = 1.;
+
+/* Compute Y(i+1:n,i) */
+
+ i__2 = *m - i__ + 1;
+ i__3 = *n - i__;
+ dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + (i__ + 1) *
+ a_dim1], lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &
+ y[i__ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *m - i__ + 1;
+ i__3 = i__ - 1;
+ dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1],
+ lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ *
+ y_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ dgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 +
+ y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[
+ i__ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *m - i__ + 1;
+ i__3 = i__ - 1;
+ dgemv_("Transpose", &i__2, &i__3, &c_b5, &x[i__ + x_dim1],
+ ldx, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ *
+ y_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ dgemv_("Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) *
+ a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5,
+ &y[i__ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *n - i__;
+ dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
+
+/* Update A(i,i+1:n) */
+
+ i__2 = *n - i__;
+ dgemv_("No transpose", &i__2, &i__, &c_b4, &y[i__ + 1 +
+ y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b5, &a[i__ + (
+ i__ + 1) * a_dim1], lda);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ dgemv_("Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) *
+ a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b5, &a[
+ i__ + (i__ + 1) * a_dim1], lda);
+
+/* Generate reflection P(i) to annihilate A(i,i+2:n) */
+
+ i__2 = *n - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ dlarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + min(
+ i__3, *n)* a_dim1], lda, &taup[i__]);
+ e[i__] = a[i__ + (i__ + 1) * a_dim1];
+ a[i__ + (i__ + 1) * a_dim1] = 1.;
+
+/* Compute X(i+1:m,i) */
+
+ i__2 = *m - i__;
+ i__3 = *n - i__;
+ dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__
+ + 1) * a_dim1], lda, &a[i__ + (i__ + 1) * a_dim1],
+ lda, &c_b16, &x[i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = *n - i__;
+ dgemv_("Transpose", &i__2, &i__, &c_b5, &y[i__ + 1 + y_dim1],
+ ldy, &a[i__ + (i__ + 1) * a_dim1], lda, &c_b16, &x[
+ i__ * x_dim1 + 1], &c__1);
+ i__2 = *m - i__;
+ dgemv_("No transpose", &i__2, &i__, &c_b4, &a[i__ + 1 +
+ a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
+ i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) *
+ a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, &
+ c_b16, &x[i__ * x_dim1 + 1], &c__1);
+ i__2 = *m - i__;
+ i__3 = i__ - 1;
+ dgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 +
+ x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
+ i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = *m - i__;
+ dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Reduce to lower bidiagonal form */
+
+ i__1 = *nb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Update A(i,i:n) */
+
+ i__2 = *n - i__ + 1;
+ i__3 = i__ - 1;
+ dgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + y_dim1], ldy,
+ &a[i__ + a_dim1], lda, &c_b5, &a[i__ + i__ * a_dim1],
+ lda);
+ i__2 = i__ - 1;
+ i__3 = *n - i__ + 1;
+ dgemv_("Transpose", &i__2, &i__3, &c_b4, &a[i__ * a_dim1 + 1],
+ lda, &x[i__ + x_dim1], ldx, &c_b5, &a[i__ + i__ * a_dim1],
+ lda);
+
+/* Generate reflection P(i) to annihilate A(i,i+1:n) */
+
+ i__2 = *n - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3, *n)*
+ a_dim1], lda, &taup[i__]);
+ d__[i__] = a[i__ + i__ * a_dim1];
+ if (i__ < *m) {
+ a[i__ + i__ * a_dim1] = 1.;
+
+/* Compute X(i+1:m,i) */
+
+ i__2 = *m - i__;
+ i__3 = *n - i__ + 1;
+ dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + i__ *
+ a_dim1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, &
+ x[i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = *n - i__ + 1;
+ i__3 = i__ - 1;
+ dgemv_("Transpose", &i__2, &i__3, &c_b5, &y[i__ + y_dim1],
+ ldy, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ *
+ x_dim1 + 1], &c__1);
+ i__2 = *m - i__;
+ i__3 = i__ - 1;
+ dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 +
+ a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
+ i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__ + 1;
+ dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ * a_dim1 +
+ 1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ *
+ x_dim1 + 1], &c__1);
+ i__2 = *m - i__;
+ i__3 = i__ - 1;
+ dgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 +
+ x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
+ i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = *m - i__;
+ dscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
+
+/* Update A(i+1:m,i) */
+
+ i__2 = *m - i__;
+ i__3 = i__ - 1;
+ dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 +
+ a_dim1], lda, &y[i__ + y_dim1], ldy, &c_b5, &a[i__ +
+ 1 + i__ * a_dim1], &c__1);
+ i__2 = *m - i__;
+ dgemv_("No transpose", &i__2, &i__, &c_b4, &x[i__ + 1 +
+ x_dim1], ldx, &a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[
+ i__ + 1 + i__ * a_dim1], &c__1);
+
+/* Generate reflection Q(i) to annihilate A(i+2:m,i) */
+
+ i__2 = *m - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *m)+
+ i__ * a_dim1], &c__1, &tauq[i__]);
+ e[i__] = a[i__ + 1 + i__ * a_dim1];
+ a[i__ + 1 + i__ * a_dim1] = 1.;
+
+/* Compute Y(i+1:n,i) */
+
+ i__2 = *m - i__;
+ i__3 = *n - i__;
+ dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__ +
+ 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1,
+ &c_b16, &y[i__ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *m - i__;
+ i__3 = i__ - 1;
+ dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + a_dim1],
+ lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[
+ i__ * y_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ dgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 +
+ y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[
+ i__ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *m - i__;
+ dgemv_("Transpose", &i__2, &i__, &c_b5, &x[i__ + 1 + x_dim1],
+ ldx, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[
+ i__ * y_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ dgemv_("Transpose", &i__, &i__2, &c_b4, &a[(i__ + 1) * a_dim1
+ + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[i__
+ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *n - i__;
+ dscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+/* End of DLABRD */
+
+} /* dlabrd_ */
diff --git a/SRC/dlacn2.c b/SRC/dlacn2.c
new file mode 100644
index 0000000..958f294
--- /dev/null
+++ b/SRC/dlacn2.c
@@ -0,0 +1,267 @@
+/* dlacn2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b11 = 1.;
+
+/* Subroutine */ int dlacn2_(integer *n, doublereal *v, doublereal *x,
+ integer *isgn, doublereal *est, integer *kase, integer *isave)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *);
+ integer i_dnnt(doublereal *);
+
+ /* Local variables */
+ integer i__;
+ doublereal temp;
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ integer jlast;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal altsgn, estold;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLACN2 estimates the 1-norm of a square, real matrix A. */
+/* Reverse communication is used for evaluating matrix-vector products. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 1. */
+
+/* V (workspace) DOUBLE PRECISION array, dimension (N) */
+/* On the final return, V = A*W, where EST = norm(V)/norm(W) */
+/* (W is not returned). */
+
+/* X (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On an intermediate return, X should be overwritten by */
+/* A * X, if KASE=1, */
+/* A' * X, if KASE=2, */
+/* and DLACN2 must be re-called with all the other parameters */
+/* unchanged. */
+
+/* ISGN (workspace) INTEGER array, dimension (N) */
+
+/* EST (input/output) DOUBLE PRECISION */
+/* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be */
+/* unchanged from the previous call to DLACN2. */
+/* On exit, EST is an estimate (a lower bound) for norm(A). */
+
+/* KASE (input/output) INTEGER */
+/* On the initial call to DLACN2, KASE should be 0. */
+/* On an intermediate return, KASE will be 1 or 2, indicating */
+/* whether X should be overwritten by A * X or A' * X. */
+/* On the final return from DLACN2, KASE will again be 0. */
+
+/* ISAVE (input/output) INTEGER array, dimension (3) */
+/* ISAVE is used to save variables between calls to DLACN2 */
+
+/* Further Details */
+/* ======= ======= */
+
+/* Contributed by Nick Higham, University of Manchester. */
+/* Originally named SONEST, dated March 16, 1988. */
+
+/* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */
+/* a real or complex matrix, with applications to condition estimation", */
+/* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */
+
+/* This is a thread safe version of DLACON, which uses the array ISAVE */
+/* in place of a SAVE statement, as follows: */
+
+/* DLACON DLACN2 */
+/* JUMP ISAVE(1) */
+/* J ISAVE(2) */
+/* ITER ISAVE(3) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --isave;
+ --isgn;
+ --x;
+ --v;
+
+ /* Function Body */
+ if (*kase == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ x[i__] = 1. / (doublereal) (*n);
+/* L10: */
+ }
+ *kase = 1;
+ isave[1] = 1;
+ return 0;
+ }
+
+ switch (isave[1]) {
+ case 1: goto L20;
+ case 2: goto L40;
+ case 3: goto L70;
+ case 4: goto L110;
+ case 5: goto L140;
+ }
+
+/* ................ ENTRY (ISAVE( 1 ) = 1) */
+/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */
+
+L20:
+ if (*n == 1) {
+ v[1] = x[1];
+ *est = abs(v[1]);
+/* ... QUIT */
+ goto L150;
+ }
+ *est = dasum_(n, &x[1], &c__1);
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ x[i__] = d_sign(&c_b11, &x[i__]);
+ isgn[i__] = i_dnnt(&x[i__]);
+/* L30: */
+ }
+ *kase = 2;
+ isave[1] = 2;
+ return 0;
+
+/* ................ ENTRY (ISAVE( 1 ) = 2) */
+/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
+
+L40:
+ isave[2] = idamax_(n, &x[1], &c__1);
+ isave[3] = 2;
+
+/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */
+
+L50:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ x[i__] = 0.;
+/* L60: */
+ }
+ x[isave[2]] = 1.;
+ *kase = 1;
+ isave[1] = 3;
+ return 0;
+
+/* ................ ENTRY (ISAVE( 1 ) = 3) */
+/* X HAS BEEN OVERWRITTEN BY A*X. */
+
+L70:
+ dcopy_(n, &x[1], &c__1, &v[1], &c__1);
+ estold = *est;
+ *est = dasum_(n, &v[1], &c__1);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__1 = d_sign(&c_b11, &x[i__]);
+ if (i_dnnt(&d__1) != isgn[i__]) {
+ goto L90;
+ }
+/* L80: */
+ }
+/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
+ goto L120;
+
+L90:
+/* TEST FOR CYCLING. */
+ if (*est <= estold) {
+ goto L120;
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ x[i__] = d_sign(&c_b11, &x[i__]);
+ isgn[i__] = i_dnnt(&x[i__]);
+/* L100: */
+ }
+ *kase = 2;
+ isave[1] = 4;
+ return 0;
+
+/* ................ ENTRY (ISAVE( 1 ) = 4) */
+/* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
+
+L110:
+ jlast = isave[2];
+ isave[2] = idamax_(n, &x[1], &c__1);
+ if (x[jlast] != (d__1 = x[isave[2]], abs(d__1)) && isave[3] < 5) {
+ ++isave[3];
+ goto L50;
+ }
+
+/* ITERATION COMPLETE. FINAL STAGE. */
+
+L120:
+ altsgn = 1.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ x[i__] = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) +
+ 1.);
+ altsgn = -altsgn;
+/* L130: */
+ }
+ *kase = 1;
+ isave[1] = 5;
+ return 0;
+
+/* ................ ENTRY (ISAVE( 1 ) = 5) */
+/* X HAS BEEN OVERWRITTEN BY A*X. */
+
+L140:
+ temp = dasum_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.;
+ if (temp > *est) {
+ dcopy_(n, &x[1], &c__1, &v[1], &c__1);
+ *est = temp;
+ }
+
+L150:
+ *kase = 0;
+ return 0;
+
+/* End of DLACN2 */
+
+} /* dlacn2_ */
diff --git a/SRC/dlacon.c b/SRC/dlacon.c
new file mode 100644
index 0000000..b99e00f
--- /dev/null
+++ b/SRC/dlacon.c
@@ -0,0 +1,258 @@
+/* dlacon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b11 = 1.;
+
+/* Subroutine */ int dlacon_(integer *n, doublereal *v, doublereal *x,
+ integer *isgn, doublereal *est, integer *kase)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *);
+ integer i_dnnt(doublereal *);
+
+ /* Local variables */
+ static integer i__, j, iter;
+ static doublereal temp;
+ static integer jump;
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ static integer jlast;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ static doublereal altsgn, estold;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLACON estimates the 1-norm of a square, real matrix A. */
+/* Reverse communication is used for evaluating matrix-vector products. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 1. */
+
+/* V (workspace) DOUBLE PRECISION array, dimension (N) */
+/* On the final return, V = A*W, where EST = norm(V)/norm(W) */
+/* (W is not returned). */
+
+/* X (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On an intermediate return, X should be overwritten by */
+/* A * X, if KASE=1, */
+/* A' * X, if KASE=2, */
+/* and DLACON must be re-called with all the other parameters */
+/* unchanged. */
+
+/* ISGN (workspace) INTEGER array, dimension (N) */
+
+/* EST (input/output) DOUBLE PRECISION */
+/* On entry with KASE = 1 or 2 and JUMP = 3, EST should be */
+/* unchanged from the previous call to DLACON. */
+/* On exit, EST is an estimate (a lower bound) for norm(A). */
+
+/* KASE (input/output) INTEGER */
+/* On the initial call to DLACON, KASE should be 0. */
+/* On an intermediate return, KASE will be 1 or 2, indicating */
+/* whether X should be overwritten by A * X or A' * X. */
+/* On the final return from DLACON, KASE will again be 0. */
+
+/* Further Details */
+/* ======= ======= */
+
+/* Contributed by Nick Higham, University of Manchester. */
+/* Originally named SONEST, dated March 16, 1988. */
+
+/* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */
+/* a real or complex matrix, with applications to condition estimation", */
+/* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --isgn;
+ --x;
+ --v;
+
+ /* Function Body */
+ if (*kase == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ x[i__] = 1. / (doublereal) (*n);
+/* L10: */
+ }
+ *kase = 1;
+ jump = 1;
+ return 0;
+ }
+
+ switch (jump) {
+ case 1: goto L20;
+ case 2: goto L40;
+ case 3: goto L70;
+ case 4: goto L110;
+ case 5: goto L140;
+ }
+
+/* ................ ENTRY (JUMP = 1) */
+/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */
+
+L20:
+ if (*n == 1) {
+ v[1] = x[1];
+ *est = abs(v[1]);
+/* ... QUIT */
+ goto L150;
+ }
+ *est = dasum_(n, &x[1], &c__1);
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ x[i__] = d_sign(&c_b11, &x[i__]);
+ isgn[i__] = i_dnnt(&x[i__]);
+/* L30: */
+ }
+ *kase = 2;
+ jump = 2;
+ return 0;
+
+/* ................ ENTRY (JUMP = 2) */
+/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
+
+L40:
+ j = idamax_(n, &x[1], &c__1);
+ iter = 2;
+
+/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */
+
+L50:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ x[i__] = 0.;
+/* L60: */
+ }
+ x[j] = 1.;
+ *kase = 1;
+ jump = 3;
+ return 0;
+
+/* ................ ENTRY (JUMP = 3) */
+/* X HAS BEEN OVERWRITTEN BY A*X. */
+
+L70:
+ dcopy_(n, &x[1], &c__1, &v[1], &c__1);
+ estold = *est;
+ *est = dasum_(n, &v[1], &c__1);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__1 = d_sign(&c_b11, &x[i__]);
+ if (i_dnnt(&d__1) != isgn[i__]) {
+ goto L90;
+ }
+/* L80: */
+ }
+/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
+ goto L120;
+
+L90:
+/* TEST FOR CYCLING. */
+ if (*est <= estold) {
+ goto L120;
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ x[i__] = d_sign(&c_b11, &x[i__]);
+ isgn[i__] = i_dnnt(&x[i__]);
+/* L100: */
+ }
+ *kase = 2;
+ jump = 4;
+ return 0;
+
+/* ................ ENTRY (JUMP = 4) */
+/* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
+
+L110:
+ jlast = j;
+ j = idamax_(n, &x[1], &c__1);
+ if (x[jlast] != (d__1 = x[j], abs(d__1)) && iter < 5) {
+ ++iter;
+ goto L50;
+ }
+
+/* ITERATION COMPLETE. FINAL STAGE. */
+
+L120:
+ altsgn = 1.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ x[i__] = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) +
+ 1.);
+ altsgn = -altsgn;
+/* L130: */
+ }
+ *kase = 1;
+ jump = 5;
+ return 0;
+
+/* ................ ENTRY (JUMP = 5) */
+/* X HAS BEEN OVERWRITTEN BY A*X. */
+
+L140:
+ temp = dasum_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.;
+ if (temp > *est) {
+ dcopy_(n, &x[1], &c__1, &v[1], &c__1);
+ *est = temp;
+ }
+
+L150:
+ *kase = 0;
+ return 0;
+
+/* End of DLACON */
+
+} /* dlacon_ */
diff --git a/SRC/dlacpy.c b/SRC/dlacpy.c
new file mode 100644
index 0000000..9fff495
--- /dev/null
+++ b/SRC/dlacpy.c
@@ -0,0 +1,125 @@
+/* dlacpy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlacpy_(char *uplo, integer *m, integer *n, doublereal *
+ a, integer *lda, doublereal *b, integer *ldb)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ extern logical lsame_(char *, char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLACPY copies all or part of a two-dimensional matrix A to another */
+/* matrix B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies the part of the matrix A to be copied to B. */
+/* = 'U': Upper triangular part */
+/* = 'L': Lower triangular part */
+/* Otherwise: All of the matrix A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The m by n matrix A. If UPLO = 'U', only the upper triangle */
+/* or trapezoid is accessed; if UPLO = 'L', only the lower */
+/* triangle or trapezoid is accessed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (output) DOUBLE PRECISION array, dimension (LDB,N) */
+/* On exit, B = A in the locations specified by UPLO. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(j,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = a[i__ + j * a_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (lsame_(uplo, "L")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = a[i__ + j * a_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = a[i__ + j * a_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+ return 0;
+
+/* End of DLACPY */
+
+} /* dlacpy_ */
diff --git a/SRC/dladiv.c b/SRC/dladiv.c
new file mode 100644
index 0000000..20fbe6b
--- /dev/null
+++ b/SRC/dladiv.c
@@ -0,0 +1,78 @@
+/* dladiv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dladiv_(doublereal *a, doublereal *b, doublereal *c__,
+ doublereal *d__, doublereal *p, doublereal *q)
+{
+ doublereal e, f;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLADIV performs complex division in real arithmetic */
+
+/* a + i*b */
+/* p + i*q = --------- */
+/* c + i*d */
+
+/* The algorithm is due to Robert L. Smith and can be found */
+/* in D. Knuth, The art of Computer Programming, Vol.2, p.195 */
+
+/* Arguments */
+/* ========= */
+
+/* A (input) DOUBLE PRECISION */
+/* B (input) DOUBLE PRECISION */
+/* C (input) DOUBLE PRECISION */
+/* D (input) DOUBLE PRECISION */
+/* The scalars a, b, c, and d in the above expression. */
+
+/* P (output) DOUBLE PRECISION */
+/* Q (output) DOUBLE PRECISION */
+/* The scalars p and q in the above expression. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (abs(*d__) < abs(*c__)) {
+ e = *d__ / *c__;
+ f = *c__ + *d__ * e;
+ *p = (*a + *b * e) / f;
+ *q = (*b - *a * e) / f;
+ } else {
+ e = *c__ / *d__;
+ f = *d__ + *c__ * e;
+ *p = (*b + *a * e) / f;
+ *q = (-(*a) + *b * e) / f;
+ }
+
+ return 0;
+
+/* End of DLADIV */
+
+} /* dladiv_ */
diff --git a/SRC/dlae2.c b/SRC/dlae2.c
new file mode 100644
index 0000000..c119034
--- /dev/null
+++ b/SRC/dlae2.c
@@ -0,0 +1,142 @@
+/* dlae2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlae2_(doublereal *a, doublereal *b, doublereal *c__,
+ doublereal *rt1, doublereal *rt2)
+{
+ /* System generated locals */
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal ab, df, tb, sm, rt, adf, acmn, acmx;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix */
+/* [ A B ] */
+/* [ B C ]. */
+/* On return, RT1 is the eigenvalue of larger absolute value, and RT2 */
+/* is the eigenvalue of smaller absolute value. */
+
+/* Arguments */
+/* ========= */
+
+/* A (input) DOUBLE PRECISION */
+/* The (1,1) element of the 2-by-2 matrix. */
+
+/* B (input) DOUBLE PRECISION */
+/* The (1,2) and (2,1) elements of the 2-by-2 matrix. */
+
+/* C (input) DOUBLE PRECISION */
+/* The (2,2) element of the 2-by-2 matrix. */
+
+/* RT1 (output) DOUBLE PRECISION */
+/* The eigenvalue of larger absolute value. */
+
+/* RT2 (output) DOUBLE PRECISION */
+/* The eigenvalue of smaller absolute value. */
+
+/* Further Details */
+/* =============== */
+
+/* RT1 is accurate to a few ulps barring over/underflow. */
+
+/* RT2 may be inaccurate if there is massive cancellation in the */
+/* determinant A*C-B*B; higher precision or correctly rounded or */
+/* correctly truncated arithmetic would be needed to compute RT2 */
+/* accurately in all cases. */
+
+/* Overflow is possible only if RT1 is within a factor of 5 of overflow. */
+/* Underflow is harmless if the input data is 0 or exceeds */
+/* underflow_threshold / macheps. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Compute the eigenvalues */
+
+ sm = *a + *c__;
+ df = *a - *c__;
+ adf = abs(df);
+ tb = *b + *b;
+ ab = abs(tb);
+ if (abs(*a) > abs(*c__)) {
+ acmx = *a;
+ acmn = *c__;
+ } else {
+ acmx = *c__;
+ acmn = *a;
+ }
+ if (adf > ab) {
+/* Computing 2nd power */
+ d__1 = ab / adf;
+ rt = adf * sqrt(d__1 * d__1 + 1.);
+ } else if (adf < ab) {
+/* Computing 2nd power */
+ d__1 = adf / ab;
+ rt = ab * sqrt(d__1 * d__1 + 1.);
+ } else {
+
+/* Includes case AB=ADF=0 */
+
+ rt = ab * sqrt(2.);
+ }
+ if (sm < 0.) {
+ *rt1 = (sm - rt) * .5;
+
+/* Order of execution important. */
+/* To get fully accurate smaller eigenvalue, */
+/* next line needs to be executed in higher precision. */
+
+ *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
+ } else if (sm > 0.) {
+ *rt1 = (sm + rt) * .5;
+
+/* Order of execution important. */
+/* To get fully accurate smaller eigenvalue, */
+/* next line needs to be executed in higher precision. */
+
+ *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
+ } else {
+
+/* Includes case RT1 = RT2 = 0 */
+
+ *rt1 = rt * .5;
+ *rt2 = rt * -.5;
+ }
+ return 0;
+
+/* End of DLAE2 */
+
+} /* dlae2_ */
diff --git a/SRC/dlaebz.c b/SRC/dlaebz.c
new file mode 100644
index 0000000..a628943
--- /dev/null
+++ b/SRC/dlaebz.c
@@ -0,0 +1,640 @@
+/* dlaebz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlaebz_(integer *ijob, integer *nitmax, integer *n,
+ integer *mmax, integer *minp, integer *nbmin, doublereal *abstol,
+ doublereal *reltol, doublereal *pivmin, doublereal *d__, doublereal *
+ e, doublereal *e2, integer *nval, doublereal *ab, doublereal *c__,
+ integer *mout, integer *nab, doublereal *work, integer *iwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer nab_dim1, nab_offset, ab_dim1, ab_offset, i__1, i__2, i__3, i__4,
+ i__5, i__6;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Local variables */
+ integer j, kf, ji, kl, jp, jit;
+ doublereal tmp1, tmp2;
+ integer itmp1, itmp2, kfnew, klnew;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAEBZ contains the iteration loops which compute and use the */
+/* function N(w), which is the count of eigenvalues of a symmetric */
+/* tridiagonal matrix T less than or equal to its argument w. It */
+/* performs a choice of two types of loops: */
+
+/* IJOB=1, followed by */
+/* IJOB=2: It takes as input a list of intervals and returns a list of */
+/* sufficiently small intervals whose union contains the same */
+/* eigenvalues as the union of the original intervals. */
+/* The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP. */
+/* The output interval (AB(j,1),AB(j,2)] will contain */
+/* eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT. */
+
+/* IJOB=3: It performs a binary search in each input interval */
+/* (AB(j,1),AB(j,2)] for a point w(j) such that */
+/* N(w(j))=NVAL(j), and uses C(j) as the starting point of */
+/* the search. If such a w(j) is found, then on output */
+/* AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output */
+/* (AB(j,1),AB(j,2)] will be a small interval containing the */
+/* point where N(w) jumps through NVAL(j), unless that point */
+/* lies outside the initial interval. */
+
+/* Note that the intervals are in all cases half-open intervals, */
+/* i.e., of the form (a,b] , which includes b but not a . */
+
+/* To avoid underflow, the matrix should be scaled so that its largest */
+/* element is no greater than overflow**(1/2) * underflow**(1/4) */
+/* in absolute value. To assure the most accurate computation */
+/* of small eigenvalues, the matrix should be scaled to be */
+/* not much smaller than that, either. */
+
+/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */
+/* Matrix", Report CS41, Computer Science Dept., Stanford */
+/* University, July 21, 1966 */
+
+/* Note: the arguments are, in general, *not* checked for unreasonable */
+/* values. */
+
+/* Arguments */
+/* ========= */
+
+/* IJOB (input) INTEGER */
+/* Specifies what is to be done: */
+/* = 1: Compute NAB for the initial intervals. */
+/* = 2: Perform bisection iteration to find eigenvalues of T. */
+/* = 3: Perform bisection iteration to invert N(w), i.e., */
+/* to find a point which has a specified number of */
+/* eigenvalues of T to its left. */
+/* Other values will cause DLAEBZ to return with INFO=-1. */
+
+/* NITMAX (input) INTEGER */
+/* The maximum number of "levels" of bisection to be */
+/* performed, i.e., an interval of width W will not be made */
+/* smaller than 2^(-NITMAX) * W. If not all intervals */
+/* have converged after NITMAX iterations, then INFO is set */
+/* to the number of non-converged intervals. */
+
+/* N (input) INTEGER */
+/* The dimension n of the tridiagonal matrix T. It must be at */
+/* least 1. */
+
+/* MMAX (input) INTEGER */
+/* The maximum number of intervals. If more than MMAX intervals */
+/* are generated, then DLAEBZ will quit with INFO=MMAX+1. */
+
+/* MINP (input) INTEGER */
+/* The initial number of intervals. It may not be greater than */
+/* MMAX. */
+
+/* NBMIN (input) INTEGER */
+/* The smallest number of intervals that should be processed */
+/* using a vector loop. If zero, then only the scalar loop */
+/* will be used. */
+
+/* ABSTOL (input) DOUBLE PRECISION */
+/* The minimum (absolute) width of an interval. When an */
+/* interval is narrower than ABSTOL, or than RELTOL times the */
+/* larger (in magnitude) endpoint, then it is considered to be */
+/* sufficiently small, i.e., converged. This must be at least */
+/* zero. */
+
+/* RELTOL (input) DOUBLE PRECISION */
+/* The minimum relative width of an interval. When an interval */
+/* is narrower than ABSTOL, or than RELTOL times the larger (in */
+/* magnitude) endpoint, then it is considered to be */
+/* sufficiently small, i.e., converged. Note: this should */
+/* always be at least radix*machine epsilon. */
+
+/* PIVMIN (input) DOUBLE PRECISION */
+/* The minimum absolute value of a "pivot" in the Sturm */
+/* sequence loop. This *must* be at least max |e(j)**2| * */
+/* safe_min and at least safe_min, where safe_min is at least */
+/* the smallest number that can divide one without overflow. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal elements of the tridiagonal matrix T. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N) */
+/* The offdiagonal elements of the tridiagonal matrix T in */
+/* positions 1 through N-1. E(N) is arbitrary. */
+
+/* E2 (input) DOUBLE PRECISION array, dimension (N) */
+/* The squares of the offdiagonal elements of the tridiagonal */
+/* matrix T. E2(N) is ignored. */
+
+/* NVAL (input/output) INTEGER array, dimension (MINP) */
+/* If IJOB=1 or 2, not referenced. */
+/* If IJOB=3, the desired values of N(w). The elements of NVAL */
+/* will be reordered to correspond with the intervals in AB. */
+/* Thus, NVAL(j) on output will not, in general be the same as */
+/* NVAL(j) on input, but it will correspond with the interval */
+/* (AB(j,1),AB(j,2)] on output. */
+
+/* AB (input/output) DOUBLE PRECISION array, dimension (MMAX,2) */
+/* The endpoints of the intervals. AB(j,1) is a(j), the left */
+/* endpoint of the j-th interval, and AB(j,2) is b(j), the */
+/* right endpoint of the j-th interval. The input intervals */
+/* will, in general, be modified, split, and reordered by the */
+/* calculation. */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (MMAX) */
+/* If IJOB=1, ignored. */
+/* If IJOB=2, workspace. */
+/* If IJOB=3, then on input C(j) should be initialized to the */
+/* first search point in the binary search. */
+
+/* MOUT (output) INTEGER */
+/* If IJOB=1, the number of eigenvalues in the intervals. */
+/* If IJOB=2 or 3, the number of intervals output. */
+/* If IJOB=3, MOUT will equal MINP. */
+
+/* NAB (input/output) INTEGER array, dimension (MMAX,2) */
+/* If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)). */
+/* If IJOB=2, then on input, NAB(i,j) should be set. It must */
+/* satisfy the condition: */
+/* N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)), */
+/* which means that in interval i only eigenvalues */
+/* NAB(i,1)+1,...,NAB(i,2) will be considered. Usually, */
+/* NAB(i,j)=N(AB(i,j)), from a previous call to DLAEBZ with */
+/* IJOB=1. */
+/* On output, NAB(i,j) will contain */
+/* max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of */
+/* the input interval that the output interval */
+/* (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the */
+/* the input values of NAB(k,1) and NAB(k,2). */
+/* If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)), */
+/* unless N(w) > NVAL(i) for all search points w , in which */
+/* case NAB(i,1) will not be modified, i.e., the output */
+/* value will be the same as the input value (modulo */
+/* reorderings -- see NVAL and AB), or unless N(w) < NVAL(i) */
+/* for all search points w , in which case NAB(i,2) will */
+/* not be modified. Normally, NAB should be set to some */
+/* distinctive value(s) before DLAEBZ is called. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MMAX) */
+/* Workspace. */
+
+/* IWORK (workspace) INTEGER array, dimension (MMAX) */
+/* Workspace. */
+
+/* INFO (output) INTEGER */
+/* = 0: All intervals converged. */
+/* = 1--MMAX: The last INFO intervals did not converge. */
+/* = MMAX+1: More than MMAX intervals were generated. */
+
+/* Further Details */
+/* =============== */
+
+/* This routine is intended to be called only by other LAPACK */
+/* routines, thus the interface is less user-friendly. It is intended */
+/* for two purposes: */
+
+/* (a) finding eigenvalues. In this case, DLAEBZ should have one or */
+/* more initial intervals set up in AB, and DLAEBZ should be called */
+/* with IJOB=1. This sets up NAB, and also counts the eigenvalues. */
+/* Intervals with no eigenvalues would usually be thrown out at */
+/* this point. Also, if not all the eigenvalues in an interval i */
+/* are desired, NAB(i,1) can be increased or NAB(i,2) decreased. */
+/* For example, set NAB(i,1)=NAB(i,2)-1 to get the largest */
+/* eigenvalue. DLAEBZ is then called with IJOB=2 and MMAX */
+/* no smaller than the value of MOUT returned by the call with */
+/* IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1 */
+/* through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the */
+/* tolerance specified by ABSTOL and RELTOL. */
+
+/* (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l). */
+/* In this case, start with a Gershgorin interval (a,b). Set up */
+/* AB to contain 2 search intervals, both initially (a,b). One */
+/* NVAL element should contain f-1 and the other should contain l */
+/* , while C should contain a and b, resp. NAB(i,1) should be -1 */
+/* and NAB(i,2) should be N+1, to flag an error if the desired */
+/* interval does not lie in (a,b). DLAEBZ is then called with */
+/* IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals -- */
+/* j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while */
+/* if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r */
+/* >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and */
+/* N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and */
+/* w(l-r)=...=w(l+k) are handled similarly. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for Errors */
+
+ /* Parameter adjustments */
+ nab_dim1 = *mmax;
+ nab_offset = 1 + nab_dim1;
+ nab -= nab_offset;
+ ab_dim1 = *mmax;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --d__;
+ --e;
+ --e2;
+ --nval;
+ --c__;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ if (*ijob < 1 || *ijob > 3) {
+ *info = -1;
+ return 0;
+ }
+
+/* Initialize NAB */
+
+ if (*ijob == 1) {
+
+/* Compute the number of eigenvalues in the initial intervals. */
+
+ *mout = 0;
+/* DIR$ NOVECTOR */
+ i__1 = *minp;
+ for (ji = 1; ji <= i__1; ++ji) {
+ for (jp = 1; jp <= 2; ++jp) {
+ tmp1 = d__[1] - ab[ji + jp * ab_dim1];
+ if (abs(tmp1) < *pivmin) {
+ tmp1 = -(*pivmin);
+ }
+ nab[ji + jp * nab_dim1] = 0;
+ if (tmp1 <= 0.) {
+ nab[ji + jp * nab_dim1] = 1;
+ }
+
+ i__2 = *n;
+ for (j = 2; j <= i__2; ++j) {
+ tmp1 = d__[j] - e2[j - 1] / tmp1 - ab[ji + jp * ab_dim1];
+ if (abs(tmp1) < *pivmin) {
+ tmp1 = -(*pivmin);
+ }
+ if (tmp1 <= 0.) {
+ ++nab[ji + jp * nab_dim1];
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+ *mout = *mout + nab[ji + (nab_dim1 << 1)] - nab[ji + nab_dim1];
+/* L30: */
+ }
+ return 0;
+ }
+
+/* Initialize for loop */
+
+/* KF and KL have the following meaning: */
+/* Intervals 1,...,KF-1 have converged. */
+/* Intervals KF,...,KL still need to be refined. */
+
+ kf = 1;
+ kl = *minp;
+
+/* If IJOB=2, initialize C. */
+/* If IJOB=3, use the user-supplied starting point. */
+
+ if (*ijob == 2) {
+ i__1 = *minp;
+ for (ji = 1; ji <= i__1; ++ji) {
+ c__[ji] = (ab[ji + ab_dim1] + ab[ji + (ab_dim1 << 1)]) * .5;
+/* L40: */
+ }
+ }
+
+/* Iteration loop */
+
+ i__1 = *nitmax;
+ for (jit = 1; jit <= i__1; ++jit) {
+
+/* Loop over intervals */
+
+ if (kl - kf + 1 >= *nbmin && *nbmin > 0) {
+
+/* Begin of Parallel Version of the loop */
+
+ i__2 = kl;
+ for (ji = kf; ji <= i__2; ++ji) {
+
+/* Compute N(c), the number of eigenvalues less than c */
+
+ work[ji] = d__[1] - c__[ji];
+ iwork[ji] = 0;
+ if (work[ji] <= *pivmin) {
+ iwork[ji] = 1;
+/* Computing MIN */
+ d__1 = work[ji], d__2 = -(*pivmin);
+ work[ji] = min(d__1,d__2);
+ }
+
+ i__3 = *n;
+ for (j = 2; j <= i__3; ++j) {
+ work[ji] = d__[j] - e2[j - 1] / work[ji] - c__[ji];
+ if (work[ji] <= *pivmin) {
+ ++iwork[ji];
+/* Computing MIN */
+ d__1 = work[ji], d__2 = -(*pivmin);
+ work[ji] = min(d__1,d__2);
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+
+ if (*ijob <= 2) {
+
+/* IJOB=2: Choose all intervals containing eigenvalues. */
+
+ klnew = kl;
+ i__2 = kl;
+ for (ji = kf; ji <= i__2; ++ji) {
+
+/* Insure that N(w) is monotone */
+
+/* Computing MIN */
+/* Computing MAX */
+ i__5 = nab[ji + nab_dim1], i__6 = iwork[ji];
+ i__3 = nab[ji + (nab_dim1 << 1)], i__4 = max(i__5,i__6);
+ iwork[ji] = min(i__3,i__4);
+
+/* Update the Queue -- add intervals if both halves */
+/* contain eigenvalues. */
+
+ if (iwork[ji] == nab[ji + (nab_dim1 << 1)]) {
+
+/* No eigenvalue in the upper interval: */
+/* just use the lower interval. */
+
+ ab[ji + (ab_dim1 << 1)] = c__[ji];
+
+ } else if (iwork[ji] == nab[ji + nab_dim1]) {
+
+/* No eigenvalue in the lower interval: */
+/* just use the upper interval. */
+
+ ab[ji + ab_dim1] = c__[ji];
+ } else {
+ ++klnew;
+ if (klnew <= *mmax) {
+
+/* Eigenvalue in both intervals -- add upper to */
+/* queue. */
+
+ ab[klnew + (ab_dim1 << 1)] = ab[ji + (ab_dim1 <<
+ 1)];
+ nab[klnew + (nab_dim1 << 1)] = nab[ji + (nab_dim1
+ << 1)];
+ ab[klnew + ab_dim1] = c__[ji];
+ nab[klnew + nab_dim1] = iwork[ji];
+ ab[ji + (ab_dim1 << 1)] = c__[ji];
+ nab[ji + (nab_dim1 << 1)] = iwork[ji];
+ } else {
+ *info = *mmax + 1;
+ }
+ }
+/* L70: */
+ }
+ if (*info != 0) {
+ return 0;
+ }
+ kl = klnew;
+ } else {
+
+/* IJOB=3: Binary search. Keep only the interval containing */
+/* w s.t. N(w) = NVAL */
+
+ i__2 = kl;
+ for (ji = kf; ji <= i__2; ++ji) {
+ if (iwork[ji] <= nval[ji]) {
+ ab[ji + ab_dim1] = c__[ji];
+ nab[ji + nab_dim1] = iwork[ji];
+ }
+ if (iwork[ji] >= nval[ji]) {
+ ab[ji + (ab_dim1 << 1)] = c__[ji];
+ nab[ji + (nab_dim1 << 1)] = iwork[ji];
+ }
+/* L80: */
+ }
+ }
+
+ } else {
+
+/* End of Parallel Version of the loop */
+
+/* Begin of Serial Version of the loop */
+
+ klnew = kl;
+ i__2 = kl;
+ for (ji = kf; ji <= i__2; ++ji) {
+
+/* Compute N(w), the number of eigenvalues less than w */
+
+ tmp1 = c__[ji];
+ tmp2 = d__[1] - tmp1;
+ itmp1 = 0;
+ if (tmp2 <= *pivmin) {
+ itmp1 = 1;
+/* Computing MIN */
+ d__1 = tmp2, d__2 = -(*pivmin);
+ tmp2 = min(d__1,d__2);
+ }
+
+/* A series of compiler directives to defeat vectorization */
+/* for the next loop */
+
+/* $PL$ CMCHAR=' ' */
+/* DIR$ NEXTSCALAR */
+/* $DIR SCALAR */
+/* DIR$ NEXT SCALAR */
+/* VD$L NOVECTOR */
+/* DEC$ NOVECTOR */
+/* VD$ NOVECTOR */
+/* VDIR NOVECTOR */
+/* VOCL LOOP,SCALAR */
+/* IBM PREFER SCALAR */
+/* $PL$ CMCHAR='*' */
+
+ i__3 = *n;
+ for (j = 2; j <= i__3; ++j) {
+ tmp2 = d__[j] - e2[j - 1] / tmp2 - tmp1;
+ if (tmp2 <= *pivmin) {
+ ++itmp1;
+/* Computing MIN */
+ d__1 = tmp2, d__2 = -(*pivmin);
+ tmp2 = min(d__1,d__2);
+ }
+/* L90: */
+ }
+
+ if (*ijob <= 2) {
+
+/* IJOB=2: Choose all intervals containing eigenvalues. */
+
+/* Insure that N(w) is monotone */
+
+/* Computing MIN */
+/* Computing MAX */
+ i__5 = nab[ji + nab_dim1];
+ i__3 = nab[ji + (nab_dim1 << 1)], i__4 = max(i__5,itmp1);
+ itmp1 = min(i__3,i__4);
+
+/* Update the Queue -- add intervals if both halves */
+/* contain eigenvalues. */
+
+ if (itmp1 == nab[ji + (nab_dim1 << 1)]) {
+
+/* No eigenvalue in the upper interval: */
+/* just use the lower interval. */
+
+ ab[ji + (ab_dim1 << 1)] = tmp1;
+
+ } else if (itmp1 == nab[ji + nab_dim1]) {
+
+/* No eigenvalue in the lower interval: */
+/* just use the upper interval. */
+
+ ab[ji + ab_dim1] = tmp1;
+ } else if (klnew < *mmax) {
+
+/* Eigenvalue in both intervals -- add upper to queue. */
+
+ ++klnew;
+ ab[klnew + (ab_dim1 << 1)] = ab[ji + (ab_dim1 << 1)];
+ nab[klnew + (nab_dim1 << 1)] = nab[ji + (nab_dim1 <<
+ 1)];
+ ab[klnew + ab_dim1] = tmp1;
+ nab[klnew + nab_dim1] = itmp1;
+ ab[ji + (ab_dim1 << 1)] = tmp1;
+ nab[ji + (nab_dim1 << 1)] = itmp1;
+ } else {
+ *info = *mmax + 1;
+ return 0;
+ }
+ } else {
+
+/* IJOB=3: Binary search. Keep only the interval */
+/* containing w s.t. N(w) = NVAL */
+
+ if (itmp1 <= nval[ji]) {
+ ab[ji + ab_dim1] = tmp1;
+ nab[ji + nab_dim1] = itmp1;
+ }
+ if (itmp1 >= nval[ji]) {
+ ab[ji + (ab_dim1 << 1)] = tmp1;
+ nab[ji + (nab_dim1 << 1)] = itmp1;
+ }
+ }
+/* L100: */
+ }
+ kl = klnew;
+
+/* End of Serial Version of the loop */
+
+ }
+
+/* Check for convergence */
+
+ kfnew = kf;
+ i__2 = kl;
+ for (ji = kf; ji <= i__2; ++ji) {
+ tmp1 = (d__1 = ab[ji + (ab_dim1 << 1)] - ab[ji + ab_dim1], abs(
+ d__1));
+/* Computing MAX */
+ d__3 = (d__1 = ab[ji + (ab_dim1 << 1)], abs(d__1)), d__4 = (d__2 =
+ ab[ji + ab_dim1], abs(d__2));
+ tmp2 = max(d__3,d__4);
+/* Computing MAX */
+ d__1 = max(*abstol,*pivmin), d__2 = *reltol * tmp2;
+ if (tmp1 < max(d__1,d__2) || nab[ji + nab_dim1] >= nab[ji + (
+ nab_dim1 << 1)]) {
+
+/* Converged -- Swap with position KFNEW, */
+/* then increment KFNEW */
+
+ if (ji > kfnew) {
+ tmp1 = ab[ji + ab_dim1];
+ tmp2 = ab[ji + (ab_dim1 << 1)];
+ itmp1 = nab[ji + nab_dim1];
+ itmp2 = nab[ji + (nab_dim1 << 1)];
+ ab[ji + ab_dim1] = ab[kfnew + ab_dim1];
+ ab[ji + (ab_dim1 << 1)] = ab[kfnew + (ab_dim1 << 1)];
+ nab[ji + nab_dim1] = nab[kfnew + nab_dim1];
+ nab[ji + (nab_dim1 << 1)] = nab[kfnew + (nab_dim1 << 1)];
+ ab[kfnew + ab_dim1] = tmp1;
+ ab[kfnew + (ab_dim1 << 1)] = tmp2;
+ nab[kfnew + nab_dim1] = itmp1;
+ nab[kfnew + (nab_dim1 << 1)] = itmp2;
+ if (*ijob == 3) {
+ itmp1 = nval[ji];
+ nval[ji] = nval[kfnew];
+ nval[kfnew] = itmp1;
+ }
+ }
+ ++kfnew;
+ }
+/* L110: */
+ }
+ kf = kfnew;
+
+/* Choose Midpoints */
+
+ i__2 = kl;
+ for (ji = kf; ji <= i__2; ++ji) {
+ c__[ji] = (ab[ji + ab_dim1] + ab[ji + (ab_dim1 << 1)]) * .5;
+/* L120: */
+ }
+
+/* If no more intervals to refine, quit. */
+
+ if (kf > kl) {
+ goto L140;
+ }
+/* L130: */
+ }
+
+/* Converged */
+
+L140:
+/* Computing MAX */
+ i__1 = kl + 1 - kf;
+ *info = max(i__1,0);
+ *mout = kl;
+
+ return 0;
+
+/* End of DLAEBZ */
+
+} /* dlaebz_ */
diff --git a/SRC/dlaed0.c b/SRC/dlaed0.c
new file mode 100644
index 0000000..e9cb080
--- /dev/null
+++ b/SRC/dlaed0.c
@@ -0,0 +1,440 @@
+/* dlaed0.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__9 = 9;
+static integer c__0 = 0;
+static integer c__2 = 2;
+static doublereal c_b23 = 1.;
+static doublereal c_b24 = 0.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dlaed0_(integer *icompq, integer *qsiz, integer *n,
+ doublereal *d__, doublereal *e, doublereal *q, integer *ldq,
+ doublereal *qstore, integer *ldqs, doublereal *work, integer *iwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double log(doublereal);
+ integer pow_ii(integer *, integer *);
+
+ /* Local variables */
+ integer i__, j, k, iq, lgn, msd2, smm1, spm1, spm2;
+ doublereal temp;
+ integer curr;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ integer iperm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer indxq, iwrem;
+ extern /* Subroutine */ int dlaed1_(integer *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *);
+ integer iqptr;
+ extern /* Subroutine */ int dlaed7_(integer *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *, integer *, integer *, integer *, doublereal
+ *, doublereal *, integer *, integer *);
+ integer tlvls;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ integer igivcl;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer igivnm, submat, curprb, subpbs, igivpt;
+ extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *);
+ integer curlvl, matsiz, iprmpt, smlsiz;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAED0 computes all eigenvalues and corresponding eigenvectors of a */
+/* symmetric tridiagonal matrix using the divide and conquer method. */
+
+/* Arguments */
+/* ========= */
+
+/* ICOMPQ (input) INTEGER */
+/* = 0: Compute eigenvalues only. */
+/* = 1: Compute eigenvectors of original dense symmetric matrix */
+/* also. On entry, Q contains the orthogonal matrix used */
+/* to reduce the original matrix to tridiagonal form. */
+/* = 2: Compute eigenvalues and eigenvectors of tridiagonal */
+/* matrix. */
+
+/* QSIZ (input) INTEGER */
+/* The dimension of the orthogonal matrix used to reduce */
+/* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. */
+
+/* N (input) INTEGER */
+/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the main diagonal of the tridiagonal matrix. */
+/* On exit, its eigenvalues. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The off-diagonal elements of the tridiagonal matrix. */
+/* On exit, E has been destroyed. */
+
+/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) */
+/* On entry, Q must contain an N-by-N orthogonal matrix. */
+/* If ICOMPQ = 0 Q is not referenced. */
+/* If ICOMPQ = 1 On entry, Q is a subset of the columns of the */
+/* orthogonal matrix used to reduce the full */
+/* matrix to tridiagonal form corresponding to */
+/* the subset of the full matrix which is being */
+/* decomposed at this time. */
+/* If ICOMPQ = 2 On entry, Q will be the identity matrix. */
+/* On exit, Q contains the eigenvectors of the */
+/* tridiagonal matrix. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. If eigenvectors are */
+/* desired, then LDQ >= max(1,N). In any case, LDQ >= 1. */
+
+/* QSTORE (workspace) DOUBLE PRECISION array, dimension (LDQS, N) */
+/* Referenced only when ICOMPQ = 1. Used to store parts of */
+/* the eigenvector matrix when the updating matrix multiplies */
+/* take place. */
+
+/* LDQS (input) INTEGER */
+/* The leading dimension of the array QSTORE. If ICOMPQ = 1, */
+/* then LDQS >= max(1,N). In any case, LDQS >= 1. */
+
+/* WORK (workspace) DOUBLE PRECISION array, */
+/* If ICOMPQ = 0 or 1, the dimension of WORK must be at least */
+/* 1 + 3*N + 2*N*lg N + 2*N**2 */
+/* ( lg( N ) = smallest integer k */
+/* such that 2^k >= N ) */
+/* If ICOMPQ = 2, the dimension of WORK must be at least */
+/* 4*N + N**2. */
+
+/* IWORK (workspace) INTEGER array, */
+/* If ICOMPQ = 0 or 1, the dimension of IWORK must be at least */
+/* 6 + 6*N + 5*N*lg N. */
+/* ( lg( N ) = smallest integer k */
+/* such that 2^k >= N ) */
+/* If ICOMPQ = 2, the dimension of IWORK must be at least */
+/* 3 + 5*N. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: The algorithm failed to compute an eigenvalue while */
+/* working on the submatrix lying in rows and columns */
+/* INFO/(N+1) through mod(INFO,N+1). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ qstore_dim1 = *ldqs;
+ qstore_offset = 1 + qstore_dim1;
+ qstore -= qstore_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*icompq < 0 || *icompq > 2) {
+ *info = -1;
+ } else if (*icompq == 1 && *qsiz < max(0,*n)) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ldq < max(1,*n)) {
+ *info = -7;
+ } else if (*ldqs < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLAED0", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ smlsiz = ilaenv_(&c__9, "DLAED0", " ", &c__0, &c__0, &c__0, &c__0);
+
+/* Determine the size and placement of the submatrices, and save in */
+/* the leading elements of IWORK. */
+
+ iwork[1] = *n;
+ subpbs = 1;
+ tlvls = 0;
+L10:
+ if (iwork[subpbs] > smlsiz) {
+ for (j = subpbs; j >= 1; --j) {
+ iwork[j * 2] = (iwork[j] + 1) / 2;
+ iwork[(j << 1) - 1] = iwork[j] / 2;
+/* L20: */
+ }
+ ++tlvls;
+ subpbs <<= 1;
+ goto L10;
+ }
+ i__1 = subpbs;
+ for (j = 2; j <= i__1; ++j) {
+ iwork[j] += iwork[j - 1];
+/* L30: */
+ }
+
+/* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 */
+/* using rank-1 modifications (cuts). */
+
+ spm1 = subpbs - 1;
+ i__1 = spm1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ submat = iwork[i__] + 1;
+ smm1 = submat - 1;
+ d__[smm1] -= (d__1 = e[smm1], abs(d__1));
+ d__[submat] -= (d__1 = e[smm1], abs(d__1));
+/* L40: */
+ }
+
+ indxq = (*n << 2) + 3;
+ if (*icompq != 2) {
+
+/* Set up workspaces for eigenvalues only/accumulate new vectors */
+/* routine */
+
+ temp = log((doublereal) (*n)) / log(2.);
+ lgn = (integer) temp;
+ if (pow_ii(&c__2, &lgn) < *n) {
+ ++lgn;
+ }
+ if (pow_ii(&c__2, &lgn) < *n) {
+ ++lgn;
+ }
+ iprmpt = indxq + *n + 1;
+ iperm = iprmpt + *n * lgn;
+ iqptr = iperm + *n * lgn;
+ igivpt = iqptr + *n + 2;
+ igivcl = igivpt + *n * lgn;
+
+ igivnm = 1;
+ iq = igivnm + (*n << 1) * lgn;
+/* Computing 2nd power */
+ i__1 = *n;
+ iwrem = iq + i__1 * i__1 + 1;
+
+/* Initialize pointers */
+
+ i__1 = subpbs;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ iwork[iprmpt + i__] = 1;
+ iwork[igivpt + i__] = 1;
+/* L50: */
+ }
+ iwork[iqptr] = 1;
+ }
+
+/* Solve each submatrix eigenproblem at the bottom of the divide and */
+/* conquer tree. */
+
+ curr = 0;
+ i__1 = spm1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ if (i__ == 0) {
+ submat = 1;
+ matsiz = iwork[1];
+ } else {
+ submat = iwork[i__] + 1;
+ matsiz = iwork[i__ + 1] - iwork[i__];
+ }
+ if (*icompq == 2) {
+ dsteqr_("I", &matsiz, &d__[submat], &e[submat], &q[submat +
+ submat * q_dim1], ldq, &work[1], info);
+ if (*info != 0) {
+ goto L130;
+ }
+ } else {
+ dsteqr_("I", &matsiz, &d__[submat], &e[submat], &work[iq - 1 +
+ iwork[iqptr + curr]], &matsiz, &work[1], info);
+ if (*info != 0) {
+ goto L130;
+ }
+ if (*icompq == 1) {
+ dgemm_("N", "N", qsiz, &matsiz, &matsiz, &c_b23, &q[submat *
+ q_dim1 + 1], ldq, &work[iq - 1 + iwork[iqptr + curr]],
+ &matsiz, &c_b24, &qstore[submat * qstore_dim1 + 1],
+ ldqs);
+ }
+/* Computing 2nd power */
+ i__2 = matsiz;
+ iwork[iqptr + curr + 1] = iwork[iqptr + curr] + i__2 * i__2;
+ ++curr;
+ }
+ k = 1;
+ i__2 = iwork[i__ + 1];
+ for (j = submat; j <= i__2; ++j) {
+ iwork[indxq + j] = k;
+ ++k;
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Successively merge eigensystems of adjacent submatrices */
+/* into eigensystem for the corresponding larger matrix. */
+
+/* while ( SUBPBS > 1 ) */
+
+ curlvl = 1;
+L80:
+ if (subpbs > 1) {
+ spm2 = subpbs - 2;
+ i__1 = spm2;
+ for (i__ = 0; i__ <= i__1; i__ += 2) {
+ if (i__ == 0) {
+ submat = 1;
+ matsiz = iwork[2];
+ msd2 = iwork[1];
+ curprb = 0;
+ } else {
+ submat = iwork[i__] + 1;
+ matsiz = iwork[i__ + 2] - iwork[i__];
+ msd2 = matsiz / 2;
+ ++curprb;
+ }
+
+/* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) */
+/* into an eigensystem of size MATSIZ. */
+/* DLAED1 is used only for the full eigensystem of a tridiagonal */
+/* matrix. */
+/* DLAED7 handles the cases in which eigenvalues only or eigenvalues */
+/* and eigenvectors of a full symmetric matrix (which was reduced to */
+/* tridiagonal form) are desired. */
+
+ if (*icompq == 2) {
+ dlaed1_(&matsiz, &d__[submat], &q[submat + submat * q_dim1],
+ ldq, &iwork[indxq + submat], &e[submat + msd2 - 1], &
+ msd2, &work[1], &iwork[subpbs + 1], info);
+ } else {
+ dlaed7_(icompq, &matsiz, qsiz, &tlvls, &curlvl, &curprb, &d__[
+ submat], &qstore[submat * qstore_dim1 + 1], ldqs, &
+ iwork[indxq + submat], &e[submat + msd2 - 1], &msd2, &
+ work[iq], &iwork[iqptr], &iwork[iprmpt], &iwork[iperm]
+, &iwork[igivpt], &iwork[igivcl], &work[igivnm], &
+ work[iwrem], &iwork[subpbs + 1], info);
+ }
+ if (*info != 0) {
+ goto L130;
+ }
+ iwork[i__ / 2 + 1] = iwork[i__ + 2];
+/* L90: */
+ }
+ subpbs /= 2;
+ ++curlvl;
+ goto L80;
+ }
+
+/* end while */
+
+/* Re-merge the eigenvalues/vectors which were deflated at the final */
+/* merge step. */
+
+ if (*icompq == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ j = iwork[indxq + i__];
+ work[i__] = d__[j];
+ dcopy_(qsiz, &qstore[j * qstore_dim1 + 1], &c__1, &q[i__ * q_dim1
+ + 1], &c__1);
+/* L100: */
+ }
+ dcopy_(n, &work[1], &c__1, &d__[1], &c__1);
+ } else if (*icompq == 2) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ j = iwork[indxq + i__];
+ work[i__] = d__[j];
+ dcopy_(n, &q[j * q_dim1 + 1], &c__1, &work[*n * i__ + 1], &c__1);
+/* L110: */
+ }
+ dcopy_(n, &work[1], &c__1, &d__[1], &c__1);
+ dlacpy_("A", n, n, &work[*n + 1], n, &q[q_offset], ldq);
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ j = iwork[indxq + i__];
+ work[i__] = d__[j];
+/* L120: */
+ }
+ dcopy_(n, &work[1], &c__1, &d__[1], &c__1);
+ }
+ goto L140;
+
+L130:
+ *info = submat * (*n + 1) + submat + matsiz - 1;
+
+L140:
+ return 0;
+
+/* End of DLAED0 */
+
+} /* dlaed0_ */
diff --git a/SRC/dlaed1.c b/SRC/dlaed1.c
new file mode 100644
index 0000000..170f2a0
--- /dev/null
+++ b/SRC/dlaed1.c
@@ -0,0 +1,249 @@
+/* dlaed1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dlaed1_(integer *n, doublereal *d__, doublereal *q,
+ integer *ldq, integer *indxq, doublereal *rho, integer *cutpnt,
+ doublereal *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, k, n1, n2, is, iw, iz, iq2, zpp1, indx, indxc;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer indxp;
+ extern /* Subroutine */ int dlaed2_(integer *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *, integer *, integer *, integer *), dlaed3_(integer *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *,
+ doublereal *, doublereal *, integer *);
+ integer idlmda;
+ extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *,
+ integer *, integer *, integer *), xerbla_(char *, integer *);
+ integer coltyp;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAED1 computes the updated eigensystem of a diagonal */
+/* matrix after modification by a rank-one symmetric matrix. This */
+/* routine is used only for the eigenproblem which requires all */
+/* eigenvalues and eigenvectors of a tridiagonal matrix. DLAED7 handles */
+/* the case in which eigenvalues only or eigenvalues and eigenvectors */
+/* of a full symmetric matrix (which was reduced to tridiagonal form) */
+/* are desired. */
+
+/* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out) */
+
+/* where Z = Q'u, u is a vector of length N with ones in the */
+/* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. */
+
+/* The eigenvectors of the original matrix are stored in Q, and the */
+/* eigenvalues are in D. The algorithm consists of three stages: */
+
+/* The first stage consists of deflating the size of the problem */
+/* when there are multiple eigenvalues or if there is a zero in */
+/* the Z vector. For each such occurence the dimension of the */
+/* secular equation problem is reduced by one. This stage is */
+/* performed by the routine DLAED2. */
+
+/* The second stage consists of calculating the updated */
+/* eigenvalues. This is done by finding the roots of the secular */
+/* equation via the routine DLAED4 (as called by DLAED3). */
+/* This routine also calculates the eigenvectors of the current */
+/* problem. */
+
+/* The final stage consists of computing the updated eigenvectors */
+/* directly using the updated eigenvalues. The eigenvectors for */
+/* the current problem are multiplied with the eigenvectors from */
+/* the overall problem. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the eigenvalues of the rank-1-perturbed matrix. */
+/* On exit, the eigenvalues of the repaired matrix. */
+
+/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */
+/* On entry, the eigenvectors of the rank-1-perturbed matrix. */
+/* On exit, the eigenvectors of the repaired tridiagonal matrix. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* INDXQ (input/output) INTEGER array, dimension (N) */
+/* On entry, the permutation which separately sorts the two */
+/* subproblems in D into ascending order. */
+/* On exit, the permutation which will reintegrate the */
+/* subproblems back into sorted order, */
+/* i.e. D( INDXQ( I = 1, N ) ) will be in ascending order. */
+
+/* RHO (input) DOUBLE PRECISION */
+/* The subdiagonal entry used to create the rank-1 modification. */
+
+/* CUTPNT (input) INTEGER */
+/* The location of the last eigenvalue in the leading sub-matrix. */
+/* min(1,N) <= CUTPNT <= N/2. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N + N**2) */
+
+/* IWORK (workspace) INTEGER array, dimension (4*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, an eigenvalue did not converge */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+/* Modified by Francoise Tisseur, University of Tennessee. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --indxq;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*n < 0) {
+ *info = -1;
+ } else if (*ldq < max(1,*n)) {
+ *info = -4;
+ } else /* if(complicated condition) */ {
+/* Computing MIN */
+ i__1 = 1, i__2 = *n / 2;
+ if (min(i__1,i__2) > *cutpnt || *n / 2 < *cutpnt) {
+ *info = -7;
+ }
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLAED1", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* The following values are integer pointers which indicate */
+/* the portion of the workspace */
+/* used by a particular array in DLAED2 and DLAED3. */
+
+ iz = 1;
+ idlmda = iz + *n;
+ iw = idlmda + *n;
+ iq2 = iw + *n;
+
+ indx = 1;
+ indxc = indx + *n;
+ coltyp = indxc + *n;
+ indxp = coltyp + *n;
+
+
+/* Form the z-vector which consists of the last row of Q_1 and the */
+/* first row of Q_2. */
+
+ dcopy_(cutpnt, &q[*cutpnt + q_dim1], ldq, &work[iz], &c__1);
+ zpp1 = *cutpnt + 1;
+ i__1 = *n - *cutpnt;
+ dcopy_(&i__1, &q[zpp1 + zpp1 * q_dim1], ldq, &work[iz + *cutpnt], &c__1);
+
+/* Deflate eigenvalues. */
+
+ dlaed2_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, &indxq[1], rho, &work[
+ iz], &work[idlmda], &work[iw], &work[iq2], &iwork[indx], &iwork[
+ indxc], &iwork[indxp], &iwork[coltyp], info);
+
+ if (*info != 0) {
+ goto L20;
+ }
+
+/* Solve Secular Equation. */
+
+ if (k != 0) {
+ is = (iwork[coltyp] + iwork[coltyp + 1]) * *cutpnt + (iwork[coltyp +
+ 1] + iwork[coltyp + 2]) * (*n - *cutpnt) + iq2;
+ dlaed3_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, rho, &work[idlmda],
+ &work[iq2], &iwork[indxc], &iwork[coltyp], &work[iw], &work[
+ is], info);
+ if (*info != 0) {
+ goto L20;
+ }
+
+/* Prepare the INDXQ sorting permutation. */
+
+ n1 = k;
+ n2 = *n - k;
+ dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]);
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ indxq[i__] = i__;
+/* L10: */
+ }
+ }
+
+L20:
+ return 0;
+
+/* End of DLAED1 */
+
+} /* dlaed1_ */
diff --git a/SRC/dlaed2.c b/SRC/dlaed2.c
new file mode 100644
index 0000000..20d93a0
--- /dev/null
+++ b/SRC/dlaed2.c
@@ -0,0 +1,532 @@
+/* dlaed2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b3 = -1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dlaed2_(integer *k, integer *n, integer *n1, doublereal *
+ d__, doublereal *q, integer *ldq, integer *indxq, doublereal *rho,
+ doublereal *z__, doublereal *dlamda, doublereal *w, doublereal *q2,
+ integer *indx, integer *indxc, integer *indxp, integer *coltyp,
+ integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, i__1, i__2;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal c__;
+ integer i__, j;
+ doublereal s, t;
+ integer k2, n2, ct, nj, pj, js, iq1, iq2, n1p1;
+ doublereal eps, tau, tol;
+ integer psm[4], imax, jmax;
+ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ integer ctot[4];
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *), dcopy_(integer *, doublereal *, integer *, doublereal
+ *, integer *);
+ extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *,
+ integer *, integer *, integer *), dlacpy_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAED2 merges the two sets of eigenvalues together into a single */
+/* sorted set. Then it tries to deflate the size of the problem. */
+/* There are two ways in which deflation can occur: when two or more */
+/* eigenvalues are close together or if there is a tiny entry in the */
+/* Z vector. For each such occurrence the order of the related secular */
+/* equation problem is reduced by one. */
+
+/* Arguments */
+/* ========= */
+
+/* K (output) INTEGER */
+/* The number of non-deflated eigenvalues, and the order of the */
+/* related secular equation. 0 <= K <=N. */
+
+/* N (input) INTEGER */
+/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
+
+/* N1 (input) INTEGER */
+/* The location of the last eigenvalue in the leading sub-matrix. */
+/* min(1,N) <= N1 <= N/2. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, D contains the eigenvalues of the two submatrices to */
+/* be combined. */
+/* On exit, D contains the trailing (N-K) updated eigenvalues */
+/* (those which were deflated) sorted into increasing order. */
+
+/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) */
+/* On entry, Q contains the eigenvectors of two submatrices in */
+/* the two square blocks with corners at (1,1), (N1,N1) */
+/* and (N1+1, N1+1), (N,N). */
+/* On exit, Q contains the trailing (N-K) updated eigenvectors */
+/* (those which were deflated) in its last N-K columns. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* INDXQ (input/output) INTEGER array, dimension (N) */
+/* The permutation which separately sorts the two sub-problems */
+/* in D into ascending order. Note that elements in the second */
+/* half of this permutation must first have N1 added to their */
+/* values. Destroyed on exit. */
+
+/* RHO (input/output) DOUBLE PRECISION */
+/* On entry, the off-diagonal element associated with the rank-1 */
+/* cut which originally split the two submatrices which are now */
+/* being recombined. */
+/* On exit, RHO has been modified to the value required by */
+/* DLAED3. */
+
+/* Z (input) DOUBLE PRECISION array, dimension (N) */
+/* On entry, Z contains the updating vector (the last */
+/* row of the first sub-eigenvector matrix and the first row of */
+/* the second sub-eigenvector matrix). */
+/* On exit, the contents of Z have been destroyed by the updating */
+/* process. */
+
+/* DLAMDA (output) DOUBLE PRECISION array, dimension (N) */
+/* A copy of the first K eigenvalues which will be used by */
+/* DLAED3 to form the secular equation. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* The first k values of the final deflation-altered z-vector */
+/* which will be passed to DLAED3. */
+
+/* Q2 (output) DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2) */
+/* A copy of the first K eigenvectors which will be used by */
+/* DLAED3 in a matrix multiply (DGEMM) to solve for the new */
+/* eigenvectors. */
+
+/* INDX (workspace) INTEGER array, dimension (N) */
+/* The permutation used to sort the contents of DLAMDA into */
+/* ascending order. */
+
+/* INDXC (output) INTEGER array, dimension (N) */
+/* The permutation used to arrange the columns of the deflated */
+/* Q matrix into three groups: the first group contains non-zero */
+/* elements only at and above N1, the second contains */
+/* non-zero elements only below N1, and the third is dense. */
+
+/* INDXP (workspace) INTEGER array, dimension (N) */
+/* The permutation used to place deflated values of D at the end */
+/* of the array. INDXP(1:K) points to the nondeflated D-values */
+/* and INDXP(K+1:N) points to the deflated eigenvalues. */
+
+/* COLTYP (workspace/output) INTEGER array, dimension (N) */
+/* During execution, a label which will indicate which of the */
+/* following types a column in the Q2 matrix is: */
+/* 1 : non-zero in the upper half only; */
+/* 2 : dense; */
+/* 3 : non-zero in the lower half only; */
+/* 4 : deflated. */
+/* On exit, COLTYP(i) is the number of columns of type i, */
+/* for i=1 to 4 only. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+/* Modified by Francoise Tisseur, University of Tennessee. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --indxq;
+ --z__;
+ --dlamda;
+ --w;
+ --q2;
+ --indx;
+ --indxc;
+ --indxp;
+ --coltyp;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*n < 0) {
+ *info = -2;
+ } else if (*ldq < max(1,*n)) {
+ *info = -6;
+ } else /* if(complicated condition) */ {
+/* Computing MIN */
+ i__1 = 1, i__2 = *n / 2;
+ if (min(i__1,i__2) > *n1 || *n / 2 < *n1) {
+ *info = -3;
+ }
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLAED2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ n2 = *n - *n1;
+ n1p1 = *n1 + 1;
+
+ if (*rho < 0.) {
+ dscal_(&n2, &c_b3, &z__[n1p1], &c__1);
+ }
+
+/* Normalize z so that norm(z) = 1. Since z is the concatenation of */
+/* two normalized vectors, norm2(z) = sqrt(2). */
+
+ t = 1. / sqrt(2.);
+ dscal_(n, &t, &z__[1], &c__1);
+
+/* RHO = ABS( norm(z)**2 * RHO ) */
+
+ *rho = (d__1 = *rho * 2., abs(d__1));
+
+/* Sort the eigenvalues into increasing order */
+
+ i__1 = *n;
+ for (i__ = n1p1; i__ <= i__1; ++i__) {
+ indxq[i__] += *n1;
+/* L10: */
+ }
+
+/* re-integrate the deflated parts from the last pass */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dlamda[i__] = d__[indxq[i__]];
+/* L20: */
+ }
+ dlamrg_(n1, &n2, &dlamda[1], &c__1, &c__1, &indxc[1]);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ indx[i__] = indxq[indxc[i__]];
+/* L30: */
+ }
+
+/* Calculate the allowable deflation tolerance */
+
+ imax = idamax_(n, &z__[1], &c__1);
+ jmax = idamax_(n, &d__[1], &c__1);
+ eps = dlamch_("Epsilon");
+/* Computing MAX */
+ d__3 = (d__1 = d__[jmax], abs(d__1)), d__4 = (d__2 = z__[imax], abs(d__2))
+ ;
+ tol = eps * 8. * max(d__3,d__4);
+
+/* If the rank-1 modifier is small enough, no more needs to be done */
+/* except to reorganize Q so that its columns correspond with the */
+/* elements in D. */
+
+ if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) {
+ *k = 0;
+ iq2 = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = indx[j];
+ dcopy_(n, &q[i__ * q_dim1 + 1], &c__1, &q2[iq2], &c__1);
+ dlamda[j] = d__[i__];
+ iq2 += *n;
+/* L40: */
+ }
+ dlacpy_("A", n, n, &q2[1], n, &q[q_offset], ldq);
+ dcopy_(n, &dlamda[1], &c__1, &d__[1], &c__1);
+ goto L190;
+ }
+
+/* If there are multiple eigenvalues then the problem deflates. Here */
+/* the number of equal eigenvalues are found. As each equal */
+/* eigenvalue is found, an elementary reflector is computed to rotate */
+/* the corresponding eigensubspace so that the corresponding */
+/* components of Z are zero in this new basis. */
+
+ i__1 = *n1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ coltyp[i__] = 1;
+/* L50: */
+ }
+ i__1 = *n;
+ for (i__ = n1p1; i__ <= i__1; ++i__) {
+ coltyp[i__] = 3;
+/* L60: */
+ }
+
+
+ *k = 0;
+ k2 = *n + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ nj = indx[j];
+ if (*rho * (d__1 = z__[nj], abs(d__1)) <= tol) {
+
+/* Deflate due to small z component. */
+
+ --k2;
+ coltyp[nj] = 4;
+ indxp[k2] = nj;
+ if (j == *n) {
+ goto L100;
+ }
+ } else {
+ pj = nj;
+ goto L80;
+ }
+/* L70: */
+ }
+L80:
+ ++j;
+ nj = indx[j];
+ if (j > *n) {
+ goto L100;
+ }
+ if (*rho * (d__1 = z__[nj], abs(d__1)) <= tol) {
+
+/* Deflate due to small z component. */
+
+ --k2;
+ coltyp[nj] = 4;
+ indxp[k2] = nj;
+ } else {
+
+/* Check if eigenvalues are close enough to allow deflation. */
+
+ s = z__[pj];
+ c__ = z__[nj];
+
+/* Find sqrt(a**2+b**2) without overflow or */
+/* destructive underflow. */
+
+ tau = dlapy2_(&c__, &s);
+ t = d__[nj] - d__[pj];
+ c__ /= tau;
+ s = -s / tau;
+ if ((d__1 = t * c__ * s, abs(d__1)) <= tol) {
+
+/* Deflation is possible. */
+
+ z__[nj] = tau;
+ z__[pj] = 0.;
+ if (coltyp[nj] != coltyp[pj]) {
+ coltyp[nj] = 2;
+ }
+ coltyp[pj] = 4;
+ drot_(n, &q[pj * q_dim1 + 1], &c__1, &q[nj * q_dim1 + 1], &c__1, &
+ c__, &s);
+/* Computing 2nd power */
+ d__1 = c__;
+/* Computing 2nd power */
+ d__2 = s;
+ t = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__2);
+/* Computing 2nd power */
+ d__1 = s;
+/* Computing 2nd power */
+ d__2 = c__;
+ d__[nj] = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__2);
+ d__[pj] = t;
+ --k2;
+ i__ = 1;
+L90:
+ if (k2 + i__ <= *n) {
+ if (d__[pj] < d__[indxp[k2 + i__]]) {
+ indxp[k2 + i__ - 1] = indxp[k2 + i__];
+ indxp[k2 + i__] = pj;
+ ++i__;
+ goto L90;
+ } else {
+ indxp[k2 + i__ - 1] = pj;
+ }
+ } else {
+ indxp[k2 + i__ - 1] = pj;
+ }
+ pj = nj;
+ } else {
+ ++(*k);
+ dlamda[*k] = d__[pj];
+ w[*k] = z__[pj];
+ indxp[*k] = pj;
+ pj = nj;
+ }
+ }
+ goto L80;
+L100:
+
+/* Record the last eigenvalue. */
+
+ ++(*k);
+ dlamda[*k] = d__[pj];
+ w[*k] = z__[pj];
+ indxp[*k] = pj;
+
+/* Count up the total number of the various types of columns, then */
+/* form a permutation which positions the four column types into */
+/* four uniform groups (although one or more of these groups may be */
+/* empty). */
+
+ for (j = 1; j <= 4; ++j) {
+ ctot[j - 1] = 0;
+/* L110: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ct = coltyp[j];
+ ++ctot[ct - 1];
+/* L120: */
+ }
+
+/* PSM(*) = Position in SubMatrix (of types 1 through 4) */
+
+ psm[0] = 1;
+ psm[1] = ctot[0] + 1;
+ psm[2] = psm[1] + ctot[1];
+ psm[3] = psm[2] + ctot[2];
+ *k = *n - ctot[3];
+
+/* Fill out the INDXC array so that the permutation which it induces */
+/* will place all type-1 columns first, all type-2 columns next, */
+/* then all type-3's, and finally all type-4's. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ js = indxp[j];
+ ct = coltyp[js];
+ indx[psm[ct - 1]] = js;
+ indxc[psm[ct - 1]] = j;
+ ++psm[ct - 1];
+/* L130: */
+ }
+
+/* Sort the eigenvalues and corresponding eigenvectors into DLAMDA */
+/* and Q2 respectively. The eigenvalues/vectors which were not */
+/* deflated go into the first K slots of DLAMDA and Q2 respectively, */
+/* while those which were deflated go into the last N - K slots. */
+
+ i__ = 1;
+ iq1 = 1;
+ iq2 = (ctot[0] + ctot[1]) * *n1 + 1;
+ i__1 = ctot[0];
+ for (j = 1; j <= i__1; ++j) {
+ js = indx[i__];
+ dcopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1);
+ z__[i__] = d__[js];
+ ++i__;
+ iq1 += *n1;
+/* L140: */
+ }
+
+ i__1 = ctot[1];
+ for (j = 1; j <= i__1; ++j) {
+ js = indx[i__];
+ dcopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1);
+ dcopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1);
+ z__[i__] = d__[js];
+ ++i__;
+ iq1 += *n1;
+ iq2 += n2;
+/* L150: */
+ }
+
+ i__1 = ctot[2];
+ for (j = 1; j <= i__1; ++j) {
+ js = indx[i__];
+ dcopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1);
+ z__[i__] = d__[js];
+ ++i__;
+ iq2 += n2;
+/* L160: */
+ }
+
+ iq1 = iq2;
+ i__1 = ctot[3];
+ for (j = 1; j <= i__1; ++j) {
+ js = indx[i__];
+ dcopy_(n, &q[js * q_dim1 + 1], &c__1, &q2[iq2], &c__1);
+ iq2 += *n;
+ z__[i__] = d__[js];
+ ++i__;
+/* L170: */
+ }
+
+/* The deflated eigenvalues and their corresponding vectors go back */
+/* into the last N - K slots of D and Q respectively. */
+
+ dlacpy_("A", n, &ctot[3], &q2[iq1], n, &q[(*k + 1) * q_dim1 + 1], ldq);
+ i__1 = *n - *k;
+ dcopy_(&i__1, &z__[*k + 1], &c__1, &d__[*k + 1], &c__1);
+
+/* Copy CTOT into COLTYP for referencing in DLAED3. */
+
+ for (j = 1; j <= 4; ++j) {
+ coltyp[j] = ctot[j - 1];
+/* L180: */
+ }
+
+L190:
+ return 0;
+
+/* End of DLAED2 */
+
+} /* dlaed2_ */
diff --git a/SRC/dlaed3.c b/SRC/dlaed3.c
new file mode 100644
index 0000000..ce4f772
--- /dev/null
+++ b/SRC/dlaed3.c
@@ -0,0 +1,338 @@
+/* dlaed3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b22 = 1.;
+static doublereal c_b23 = 0.;
+
+/* Subroutine */ int dlaed3_(integer *k, integer *n, integer *n1, doublereal *
+ d__, doublereal *q, integer *ldq, doublereal *rho, doublereal *dlamda,
+ doublereal *q2, integer *indx, integer *ctot, doublereal *w,
+ doublereal *s, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer i__, j, n2, n12, ii, n23, iq2;
+ doublereal temp;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *),
+ dcopy_(integer *, doublereal *, integer *, doublereal *, integer
+ *), dlaed4_(integer *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ extern doublereal dlamc3_(doublereal *, doublereal *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAED3 finds the roots of the secular equation, as defined by the */
+/* values in D, W, and RHO, between 1 and K. It makes the */
+/* appropriate calls to DLAED4 and then updates the eigenvectors by */
+/* multiplying the matrix of eigenvectors of the pair of eigensystems */
+/* being combined by the matrix of eigenvectors of the K-by-K system */
+/* which is solved here. */
+
+/* This code makes very mild assumptions about floating point */
+/* arithmetic. It will work on machines with a guard digit in */
+/* add/subtract, or on those binary machines without guard digits */
+/* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */
+/* It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* K (input) INTEGER */
+/* The number of terms in the rational function to be solved by */
+/* DLAED4. K >= 0. */
+
+/* N (input) INTEGER */
+/* The number of rows and columns in the Q matrix. */
+/* N >= K (deflation may result in N>K). */
+
+/* N1 (input) INTEGER */
+/* The location of the last eigenvalue in the leading submatrix. */
+/* min(1,N) <= N1 <= N/2. */
+
+/* D (output) DOUBLE PRECISION array, dimension (N) */
+/* D(I) contains the updated eigenvalues for */
+/* 1 <= I <= K. */
+
+/* Q (output) DOUBLE PRECISION array, dimension (LDQ,N) */
+/* Initially the first K columns are used as workspace. */
+/* On output the columns 1 to K contain */
+/* the updated eigenvectors. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* RHO (input) DOUBLE PRECISION */
+/* The value of the parameter in the rank one update equation. */
+/* RHO >= 0 required. */
+
+/* DLAMDA (input/output) DOUBLE PRECISION array, dimension (K) */
+/* The first K elements of this array contain the old roots */
+/* of the deflated updating problem. These are the poles */
+/* of the secular equation. May be changed on output by */
+/* having lowest order bit set to zero on Cray X-MP, Cray Y-MP, */
+/* Cray-2, or Cray C-90, as described above. */
+
+/* Q2 (input) DOUBLE PRECISION array, dimension (LDQ2, N) */
+/* The first K columns of this matrix contain the non-deflated */
+/* eigenvectors for the split problem. */
+
+/* INDX (input) INTEGER array, dimension (N) */
+/* The permutation used to arrange the columns of the deflated */
+/* Q matrix into three groups (see DLAED2). */
+/* The rows of the eigenvectors found by DLAED4 must be likewise */
+/* permuted before the matrix multiply can take place. */
+
+/* CTOT (input) INTEGER array, dimension (4) */
+/* A count of the total number of the various types of columns */
+/* in Q, as described in INDX. The fourth column type is any */
+/* column which has been deflated. */
+
+/* W (input/output) DOUBLE PRECISION array, dimension (K) */
+/* The first K elements of this array contain the components */
+/* of the deflation-adjusted updating vector. Destroyed on */
+/* output. */
+
+/* S (workspace) DOUBLE PRECISION array, dimension (N1 + 1)*K */
+/* Will contain the eigenvectors of the repaired matrix which */
+/* will be multiplied by the previously accumulated eigenvectors */
+/* to update the system. */
+
+/* LDS (input) INTEGER */
+/* The leading dimension of S. LDS >= max(1,K). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, an eigenvalue did not converge */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+/* Modified by Francoise Tisseur, University of Tennessee. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --dlamda;
+ --q2;
+ --indx;
+ --ctot;
+ --w;
+ --s;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*k < 0) {
+ *info = -1;
+ } else if (*n < *k) {
+ *info = -2;
+ } else if (*ldq < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLAED3", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*k == 0) {
+ return 0;
+ }
+
+/* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */
+/* be computed with high relative accuracy (barring over/underflow). */
+/* This is a problem on machines without a guard digit in */
+/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */
+/* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), */
+/* which on any of these machines zeros out the bottommost */
+/* bit of DLAMDA(I) if it is 1; this makes the subsequent */
+/* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation */
+/* occurs. On binary machines with a guard digit (almost all */
+/* machines) it does not change DLAMDA(I) at all. On hexadecimal */
+/* and decimal machines with a guard digit, it slightly */
+/* changes the bottommost bits of DLAMDA(I). It does not account */
+/* for hexadecimal or decimal machines without guard digits */
+/* (we know of none). We use a subroutine call to compute */
+/* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating */
+/* this code. */
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dlamda[i__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__];
+/* L10: */
+ }
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ dlaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j],
+ info);
+
+/* If the zero finder fails, the computation is terminated. */
+
+ if (*info != 0) {
+ goto L120;
+ }
+/* L20: */
+ }
+
+ if (*k == 1) {
+ goto L110;
+ }
+ if (*k == 2) {
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ w[1] = q[j * q_dim1 + 1];
+ w[2] = q[j * q_dim1 + 2];
+ ii = indx[1];
+ q[j * q_dim1 + 1] = w[ii];
+ ii = indx[2];
+ q[j * q_dim1 + 2] = w[ii];
+/* L30: */
+ }
+ goto L110;
+ }
+
+/* Compute updated W. */
+
+ dcopy_(k, &w[1], &c__1, &s[1], &c__1);
+
+/* Initialize W(I) = Q(I,I) */
+
+ i__1 = *ldq + 1;
+ dcopy_(k, &q[q_offset], &i__1, &w[1], &c__1);
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
+/* L40: */
+ }
+ i__2 = *k;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
+/* L50: */
+ }
+/* L60: */
+ }
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__1 = sqrt(-w[i__]);
+ w[i__] = d_sign(&d__1, &s[i__]);
+/* L70: */
+ }
+
+/* Compute eigenvectors of the modified rank-1 modification. */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *k;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ s[i__] = w[i__] / q[i__ + j * q_dim1];
+/* L80: */
+ }
+ temp = dnrm2_(k, &s[1], &c__1);
+ i__2 = *k;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ii = indx[i__];
+ q[i__ + j * q_dim1] = s[ii] / temp;
+/* L90: */
+ }
+/* L100: */
+ }
+
+/* Compute the updated eigenvectors. */
+
+L110:
+
+ n2 = *n - *n1;
+ n12 = ctot[1] + ctot[2];
+ n23 = ctot[2] + ctot[3];
+
+ dlacpy_("A", &n23, k, &q[ctot[1] + 1 + q_dim1], ldq, &s[1], &n23);
+ iq2 = *n1 * n12 + 1;
+ if (n23 != 0) {
+ dgemm_("N", "N", &n2, k, &n23, &c_b22, &q2[iq2], &n2, &s[1], &n23, &
+ c_b23, &q[*n1 + 1 + q_dim1], ldq);
+ } else {
+ dlaset_("A", &n2, k, &c_b23, &c_b23, &q[*n1 + 1 + q_dim1], ldq);
+ }
+
+ dlacpy_("A", &n12, k, &q[q_offset], ldq, &s[1], &n12);
+ if (n12 != 0) {
+ dgemm_("N", "N", n1, k, &n12, &c_b22, &q2[1], n1, &s[1], &n12, &c_b23,
+ &q[q_offset], ldq);
+ } else {
+ dlaset_("A", n1, k, &c_b23, &c_b23, &q[q_dim1 + 1], ldq);
+ }
+
+
+L120:
+ return 0;
+
+/* End of DLAED3 */
+
+} /* dlaed3_ */
diff --git a/SRC/dlaed4.c b/SRC/dlaed4.c
new file mode 100644
index 0000000..414c2cf
--- /dev/null
+++ b/SRC/dlaed4.c
@@ -0,0 +1,954 @@
+/* dlaed4.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlaed4_(integer *n, integer *i__, doublereal *d__,
+ doublereal *z__, doublereal *delta, doublereal *rho, doublereal *dlam,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal a, b, c__;
+ integer j;
+ doublereal w;
+ integer ii;
+ doublereal dw, zz[3];
+ integer ip1;
+ doublereal del, eta, phi, eps, tau, psi;
+ integer iim1, iip1;
+ doublereal dphi, dpsi;
+ integer iter;
+ doublereal temp, prew, temp1, dltlb, dltub, midpt;
+ integer niter;
+ logical swtch;
+ extern /* Subroutine */ int dlaed5_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *), dlaed6_(integer *,
+ logical *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *);
+ logical swtch3;
+ extern doublereal dlamch_(char *);
+ logical orgati;
+ doublereal erretm, rhoinv;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This subroutine computes the I-th updated eigenvalue of a symmetric */
+/* rank-one modification to a diagonal matrix whose elements are */
+/* given in the array d, and that */
+
+/* D(i) < D(j) for i < j */
+
+/* and that RHO > 0. This is arranged by the calling routine, and is */
+/* no loss in generality. The rank-one modified system is thus */
+
+/* diag( D ) + RHO * Z * Z_transpose. */
+
+/* where we assume the Euclidean norm of Z is 1. */
+
+/* The method consists of approximating the rational functions in the */
+/* secular equation by simpler interpolating rational functions. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The length of all arrays. */
+
+/* I (input) INTEGER */
+/* The index of the eigenvalue to be computed. 1 <= I <= N. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The original eigenvalues. It is assumed that they are in */
+/* order, D(I) < D(J) for I < J. */
+
+/* Z (input) DOUBLE PRECISION array, dimension (N) */
+/* The components of the updating vector. */
+
+/* DELTA (output) DOUBLE PRECISION array, dimension (N) */
+/* If N .GT. 2, DELTA contains (D(j) - lambda_I) in its j-th */
+/* component. If N = 1, then DELTA(1) = 1. If N = 2, see DLAED5 */
+/* for detail. The vector DELTA contains the information necessary */
+/* to construct the eigenvectors by DLAED3 and DLAED9. */
+
+/* RHO (input) DOUBLE PRECISION */
+/* The scalar in the symmetric updating formula. */
+
+/* DLAM (output) DOUBLE PRECISION */
+/* The computed lambda_I, the I-th updated eigenvalue. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* > 0: if INFO = 1, the updating process failed. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* Logical variable ORGATI (origin-at-i?) is used for distinguishing */
+/* whether D(i) or D(i+1) is treated as the origin. */
+
+/* ORGATI = .true. origin at i */
+/* ORGATI = .false. origin at i+1 */
+
+/* Logical variable SWTCH3 (switch-for-3-poles?) is for noting */
+/* if we are working with THREE poles! */
+
+/* MAXIT is the maximum number of iterations allowed for each */
+/* eigenvalue. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ren-Cang Li, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Since this routine is called in an inner loop, we do no argument */
+/* checking. */
+
+/* Quick return for N=1 and 2. */
+
+ /* Parameter adjustments */
+ --delta;
+ --z__;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+ if (*n == 1) {
+
+/* Presumably, I=1 upon entry */
+
+ *dlam = d__[1] + *rho * z__[1] * z__[1];
+ delta[1] = 1.;
+ return 0;
+ }
+ if (*n == 2) {
+ dlaed5_(i__, &d__[1], &z__[1], &delta[1], rho, dlam);
+ return 0;
+ }
+
+/* Compute machine epsilon */
+
+ eps = dlamch_("Epsilon");
+ rhoinv = 1. / *rho;
+
+/* The case I = N */
+
+ if (*i__ == *n) {
+
+/* Initialize some basic variables */
+
+ ii = *n - 1;
+ niter = 1;
+
+/* Calculate initial guess */
+
+ midpt = *rho / 2.;
+
+/* If ||Z||_2 is not one, then TEMP should be set to */
+/* RHO * ||Z||_2^2 / TWO */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] = d__[j] - d__[*i__] - midpt;
+/* L10: */
+ }
+
+ psi = 0.;
+ i__1 = *n - 2;
+ for (j = 1; j <= i__1; ++j) {
+ psi += z__[j] * z__[j] / delta[j];
+/* L20: */
+ }
+
+ c__ = rhoinv + psi;
+ w = c__ + z__[ii] * z__[ii] / delta[ii] + z__[*n] * z__[*n] / delta[*
+ n];
+
+ if (w <= 0.) {
+ temp = z__[*n - 1] * z__[*n - 1] / (d__[*n] - d__[*n - 1] + *rho)
+ + z__[*n] * z__[*n] / *rho;
+ if (c__ <= temp) {
+ tau = *rho;
+ } else {
+ del = d__[*n] - d__[*n - 1];
+ a = -c__ * del + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n]
+ ;
+ b = z__[*n] * z__[*n] * del;
+ if (a < 0.) {
+ tau = b * 2. / (sqrt(a * a + b * 4. * c__) - a);
+ } else {
+ tau = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.);
+ }
+ }
+
+/* It can be proved that */
+/* D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO */
+
+ dltlb = midpt;
+ dltub = *rho;
+ } else {
+ del = d__[*n] - d__[*n - 1];
+ a = -c__ * del + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n];
+ b = z__[*n] * z__[*n] * del;
+ if (a < 0.) {
+ tau = b * 2. / (sqrt(a * a + b * 4. * c__) - a);
+ } else {
+ tau = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.);
+ }
+
+/* It can be proved that */
+/* D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2 */
+
+ dltlb = 0.;
+ dltub = midpt;
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] = d__[j] - d__[*i__] - tau;
+/* L30: */
+ }
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.;
+ psi = 0.;
+ erretm = 0.;
+ i__1 = ii;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / delta[j];
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L40: */
+ }
+ erretm = abs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ temp = z__[*n] / delta[*n];
+ phi = z__[*n] * temp;
+ dphi = temp * temp;
+ erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (dpsi
+ + dphi);
+
+ w = rhoinv + phi + psi;
+
+/* Test for convergence */
+
+ if (abs(w) <= eps * erretm) {
+ *dlam = d__[*i__] + tau;
+ goto L250;
+ }
+
+ if (w <= 0.) {
+ dltlb = max(dltlb,tau);
+ } else {
+ dltub = min(dltub,tau);
+ }
+
+/* Calculate the new step */
+
+ ++niter;
+ c__ = w - delta[*n - 1] * dpsi - delta[*n] * dphi;
+ a = (delta[*n - 1] + delta[*n]) * w - delta[*n - 1] * delta[*n] * (
+ dpsi + dphi);
+ b = delta[*n - 1] * delta[*n] * w;
+ if (c__ < 0.) {
+ c__ = abs(c__);
+ }
+ if (c__ == 0.) {
+/* ETA = B/A */
+/* ETA = RHO - TAU */
+ eta = dltub - tau;
+ } else if (a >= 0.) {
+ eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__
+ * 2.);
+ } else {
+ eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))
+ );
+ }
+
+/* Note, eta should be positive if w is negative, and */
+/* eta should be negative otherwise. However, */
+/* if for some reason caused by roundoff, eta*w > 0, */
+/* we simply use one Newton step instead. This way */
+/* will guarantee eta*w < 0. */
+
+ if (w * eta > 0.) {
+ eta = -w / (dpsi + dphi);
+ }
+ temp = tau + eta;
+ if (temp > dltub || temp < dltlb) {
+ if (w < 0.) {
+ eta = (dltub - tau) / 2.;
+ } else {
+ eta = (dltlb - tau) / 2.;
+ }
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] -= eta;
+/* L50: */
+ }
+
+ tau += eta;
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.;
+ psi = 0.;
+ erretm = 0.;
+ i__1 = ii;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / delta[j];
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L60: */
+ }
+ erretm = abs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ temp = z__[*n] / delta[*n];
+ phi = z__[*n] * temp;
+ dphi = temp * temp;
+ erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (dpsi
+ + dphi);
+
+ w = rhoinv + phi + psi;
+
+/* Main loop to update the values of the array DELTA */
+
+ iter = niter + 1;
+
+ for (niter = iter; niter <= 30; ++niter) {
+
+/* Test for convergence */
+
+ if (abs(w) <= eps * erretm) {
+ *dlam = d__[*i__] + tau;
+ goto L250;
+ }
+
+ if (w <= 0.) {
+ dltlb = max(dltlb,tau);
+ } else {
+ dltub = min(dltub,tau);
+ }
+
+/* Calculate the new step */
+
+ c__ = w - delta[*n - 1] * dpsi - delta[*n] * dphi;
+ a = (delta[*n - 1] + delta[*n]) * w - delta[*n - 1] * delta[*n] *
+ (dpsi + dphi);
+ b = delta[*n - 1] * delta[*n] * w;
+ if (a >= 0.) {
+ eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (
+ c__ * 2.);
+ } else {
+ eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs(
+ d__1))));
+ }
+
+/* Note, eta should be positive if w is negative, and */
+/* eta should be negative otherwise. However, */
+/* if for some reason caused by roundoff, eta*w > 0, */
+/* we simply use one Newton step instead. This way */
+/* will guarantee eta*w < 0. */
+
+ if (w * eta > 0.) {
+ eta = -w / (dpsi + dphi);
+ }
+ temp = tau + eta;
+ if (temp > dltub || temp < dltlb) {
+ if (w < 0.) {
+ eta = (dltub - tau) / 2.;
+ } else {
+ eta = (dltlb - tau) / 2.;
+ }
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] -= eta;
+/* L70: */
+ }
+
+ tau += eta;
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.;
+ psi = 0.;
+ erretm = 0.;
+ i__1 = ii;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / delta[j];
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L80: */
+ }
+ erretm = abs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ temp = z__[*n] / delta[*n];
+ phi = z__[*n] * temp;
+ dphi = temp * temp;
+ erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (
+ dpsi + dphi);
+
+ w = rhoinv + phi + psi;
+/* L90: */
+ }
+
+/* Return with INFO = 1, NITER = MAXIT and not converged */
+
+ *info = 1;
+ *dlam = d__[*i__] + tau;
+ goto L250;
+
+/* End for the case I = N */
+
+ } else {
+
+/* The case for I < N */
+
+ niter = 1;
+ ip1 = *i__ + 1;
+
+/* Calculate initial guess */
+
+ del = d__[ip1] - d__[*i__];
+ midpt = del / 2.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] = d__[j] - d__[*i__] - midpt;
+/* L100: */
+ }
+
+ psi = 0.;
+ i__1 = *i__ - 1;
+ for (j = 1; j <= i__1; ++j) {
+ psi += z__[j] * z__[j] / delta[j];
+/* L110: */
+ }
+
+ phi = 0.;
+ i__1 = *i__ + 2;
+ for (j = *n; j >= i__1; --j) {
+ phi += z__[j] * z__[j] / delta[j];
+/* L120: */
+ }
+ c__ = rhoinv + psi + phi;
+ w = c__ + z__[*i__] * z__[*i__] / delta[*i__] + z__[ip1] * z__[ip1] /
+ delta[ip1];
+
+ if (w > 0.) {
+
+/* d(i)< the ith eigenvalue < (d(i)+d(i+1))/2 */
+
+/* We choose d(i) as origin. */
+
+ orgati = TRUE_;
+ a = c__ * del + z__[*i__] * z__[*i__] + z__[ip1] * z__[ip1];
+ b = z__[*i__] * z__[*i__] * del;
+ if (a > 0.) {
+ tau = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(
+ d__1))));
+ } else {
+ tau = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (
+ c__ * 2.);
+ }
+ dltlb = 0.;
+ dltub = midpt;
+ } else {
+
+/* (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1) */
+
+/* We choose d(i+1) as origin. */
+
+ orgati = FALSE_;
+ a = c__ * del - z__[*i__] * z__[*i__] - z__[ip1] * z__[ip1];
+ b = z__[ip1] * z__[ip1] * del;
+ if (a < 0.) {
+ tau = b * 2. / (a - sqrt((d__1 = a * a + b * 4. * c__, abs(
+ d__1))));
+ } else {
+ tau = -(a + sqrt((d__1 = a * a + b * 4. * c__, abs(d__1)))) /
+ (c__ * 2.);
+ }
+ dltlb = -midpt;
+ dltub = 0.;
+ }
+
+ if (orgati) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] = d__[j] - d__[*i__] - tau;
+/* L130: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] = d__[j] - d__[ip1] - tau;
+/* L140: */
+ }
+ }
+ if (orgati) {
+ ii = *i__;
+ } else {
+ ii = *i__ + 1;
+ }
+ iim1 = ii - 1;
+ iip1 = ii + 1;
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.;
+ psi = 0.;
+ erretm = 0.;
+ i__1 = iim1;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / delta[j];
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L150: */
+ }
+ erretm = abs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ dphi = 0.;
+ phi = 0.;
+ i__1 = iip1;
+ for (j = *n; j >= i__1; --j) {
+ temp = z__[j] / delta[j];
+ phi += z__[j] * temp;
+ dphi += temp * temp;
+ erretm += phi;
+/* L160: */
+ }
+
+ w = rhoinv + phi + psi;
+
+/* W is the value of the secular function with */
+/* its ii-th element removed. */
+
+ swtch3 = FALSE_;
+ if (orgati) {
+ if (w < 0.) {
+ swtch3 = TRUE_;
+ }
+ } else {
+ if (w > 0.) {
+ swtch3 = TRUE_;
+ }
+ }
+ if (ii == 1 || ii == *n) {
+ swtch3 = FALSE_;
+ }
+
+ temp = z__[ii] / delta[ii];
+ dw = dpsi + dphi + temp * temp;
+ temp = z__[ii] * temp;
+ w += temp;
+ erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. +
+ abs(tau) * dw;
+
+/* Test for convergence */
+
+ if (abs(w) <= eps * erretm) {
+ if (orgati) {
+ *dlam = d__[*i__] + tau;
+ } else {
+ *dlam = d__[ip1] + tau;
+ }
+ goto L250;
+ }
+
+ if (w <= 0.) {
+ dltlb = max(dltlb,tau);
+ } else {
+ dltub = min(dltub,tau);
+ }
+
+/* Calculate the new step */
+
+ ++niter;
+ if (! swtch3) {
+ if (orgati) {
+/* Computing 2nd power */
+ d__1 = z__[*i__] / delta[*i__];
+ c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * (d__1 *
+ d__1);
+ } else {
+/* Computing 2nd power */
+ d__1 = z__[ip1] / delta[ip1];
+ c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) * (d__1 *
+ d__1);
+ }
+ a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1] *
+ dw;
+ b = delta[*i__] * delta[ip1] * w;
+ if (c__ == 0.) {
+ if (a == 0.) {
+ if (orgati) {
+ a = z__[*i__] * z__[*i__] + delta[ip1] * delta[ip1] *
+ (dpsi + dphi);
+ } else {
+ a = z__[ip1] * z__[ip1] + delta[*i__] * delta[*i__] *
+ (dpsi + dphi);
+ }
+ }
+ eta = b / a;
+ } else if (a <= 0.) {
+ eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (
+ c__ * 2.);
+ } else {
+ eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(
+ d__1))));
+ }
+ } else {
+
+/* Interpolation using THREE most relevant poles */
+
+ temp = rhoinv + psi + phi;
+ if (orgati) {
+ temp1 = z__[iim1] / delta[iim1];
+ temp1 *= temp1;
+ c__ = temp - delta[iip1] * (dpsi + dphi) - (d__[iim1] - d__[
+ iip1]) * temp1;
+ zz[0] = z__[iim1] * z__[iim1];
+ zz[2] = delta[iip1] * delta[iip1] * (dpsi - temp1 + dphi);
+ } else {
+ temp1 = z__[iip1] / delta[iip1];
+ temp1 *= temp1;
+ c__ = temp - delta[iim1] * (dpsi + dphi) - (d__[iip1] - d__[
+ iim1]) * temp1;
+ zz[0] = delta[iim1] * delta[iim1] * (dpsi + (dphi - temp1));
+ zz[2] = z__[iip1] * z__[iip1];
+ }
+ zz[1] = z__[ii] * z__[ii];
+ dlaed6_(&niter, &orgati, &c__, &delta[iim1], zz, &w, &eta, info);
+ if (*info != 0) {
+ goto L250;
+ }
+ }
+
+/* Note, eta should be positive if w is negative, and */
+/* eta should be negative otherwise. However, */
+/* if for some reason caused by roundoff, eta*w > 0, */
+/* we simply use one Newton step instead. This way */
+/* will guarantee eta*w < 0. */
+
+ if (w * eta >= 0.) {
+ eta = -w / dw;
+ }
+ temp = tau + eta;
+ if (temp > dltub || temp < dltlb) {
+ if (w < 0.) {
+ eta = (dltub - tau) / 2.;
+ } else {
+ eta = (dltlb - tau) / 2.;
+ }
+ }
+
+ prew = w;
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] -= eta;
+/* L180: */
+ }
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.;
+ psi = 0.;
+ erretm = 0.;
+ i__1 = iim1;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / delta[j];
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L190: */
+ }
+ erretm = abs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ dphi = 0.;
+ phi = 0.;
+ i__1 = iip1;
+ for (j = *n; j >= i__1; --j) {
+ temp = z__[j] / delta[j];
+ phi += z__[j] * temp;
+ dphi += temp * temp;
+ erretm += phi;
+/* L200: */
+ }
+
+ temp = z__[ii] / delta[ii];
+ dw = dpsi + dphi + temp * temp;
+ temp = z__[ii] * temp;
+ w = rhoinv + phi + psi + temp;
+ erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. + (
+ d__1 = tau + eta, abs(d__1)) * dw;
+
+ swtch = FALSE_;
+ if (orgati) {
+ if (-w > abs(prew) / 10.) {
+ swtch = TRUE_;
+ }
+ } else {
+ if (w > abs(prew) / 10.) {
+ swtch = TRUE_;
+ }
+ }
+
+ tau += eta;
+
+/* Main loop to update the values of the array DELTA */
+
+ iter = niter + 1;
+
+ for (niter = iter; niter <= 30; ++niter) {
+
+/* Test for convergence */
+
+ if (abs(w) <= eps * erretm) {
+ if (orgati) {
+ *dlam = d__[*i__] + tau;
+ } else {
+ *dlam = d__[ip1] + tau;
+ }
+ goto L250;
+ }
+
+ if (w <= 0.) {
+ dltlb = max(dltlb,tau);
+ } else {
+ dltub = min(dltub,tau);
+ }
+
+/* Calculate the new step */
+
+ if (! swtch3) {
+ if (! swtch) {
+ if (orgati) {
+/* Computing 2nd power */
+ d__1 = z__[*i__] / delta[*i__];
+ c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * (
+ d__1 * d__1);
+ } else {
+/* Computing 2nd power */
+ d__1 = z__[ip1] / delta[ip1];
+ c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) *
+ (d__1 * d__1);
+ }
+ } else {
+ temp = z__[ii] / delta[ii];
+ if (orgati) {
+ dpsi += temp * temp;
+ } else {
+ dphi += temp * temp;
+ }
+ c__ = w - delta[*i__] * dpsi - delta[ip1] * dphi;
+ }
+ a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1]
+ * dw;
+ b = delta[*i__] * delta[ip1] * w;
+ if (c__ == 0.) {
+ if (a == 0.) {
+ if (! swtch) {
+ if (orgati) {
+ a = z__[*i__] * z__[*i__] + delta[ip1] *
+ delta[ip1] * (dpsi + dphi);
+ } else {
+ a = z__[ip1] * z__[ip1] + delta[*i__] * delta[
+ *i__] * (dpsi + dphi);
+ }
+ } else {
+ a = delta[*i__] * delta[*i__] * dpsi + delta[ip1]
+ * delta[ip1] * dphi;
+ }
+ }
+ eta = b / a;
+ } else if (a <= 0.) {
+ eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1))))
+ / (c__ * 2.);
+ } else {
+ eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__,
+ abs(d__1))));
+ }
+ } else {
+
+/* Interpolation using THREE most relevant poles */
+
+ temp = rhoinv + psi + phi;
+ if (swtch) {
+ c__ = temp - delta[iim1] * dpsi - delta[iip1] * dphi;
+ zz[0] = delta[iim1] * delta[iim1] * dpsi;
+ zz[2] = delta[iip1] * delta[iip1] * dphi;
+ } else {
+ if (orgati) {
+ temp1 = z__[iim1] / delta[iim1];
+ temp1 *= temp1;
+ c__ = temp - delta[iip1] * (dpsi + dphi) - (d__[iim1]
+ - d__[iip1]) * temp1;
+ zz[0] = z__[iim1] * z__[iim1];
+ zz[2] = delta[iip1] * delta[iip1] * (dpsi - temp1 +
+ dphi);
+ } else {
+ temp1 = z__[iip1] / delta[iip1];
+ temp1 *= temp1;
+ c__ = temp - delta[iim1] * (dpsi + dphi) - (d__[iip1]
+ - d__[iim1]) * temp1;
+ zz[0] = delta[iim1] * delta[iim1] * (dpsi + (dphi -
+ temp1));
+ zz[2] = z__[iip1] * z__[iip1];
+ }
+ }
+ dlaed6_(&niter, &orgati, &c__, &delta[iim1], zz, &w, &eta,
+ info);
+ if (*info != 0) {
+ goto L250;
+ }
+ }
+
+/* Note, eta should be positive if w is negative, and */
+/* eta should be negative otherwise. However, */
+/* if for some reason caused by roundoff, eta*w > 0, */
+/* we simply use one Newton step instead. This way */
+/* will guarantee eta*w < 0. */
+
+ if (w * eta >= 0.) {
+ eta = -w / dw;
+ }
+ temp = tau + eta;
+ if (temp > dltub || temp < dltlb) {
+ if (w < 0.) {
+ eta = (dltub - tau) / 2.;
+ } else {
+ eta = (dltlb - tau) / 2.;
+ }
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] -= eta;
+/* L210: */
+ }
+
+ tau += eta;
+ prew = w;
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.;
+ psi = 0.;
+ erretm = 0.;
+ i__1 = iim1;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / delta[j];
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L220: */
+ }
+ erretm = abs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ dphi = 0.;
+ phi = 0.;
+ i__1 = iip1;
+ for (j = *n; j >= i__1; --j) {
+ temp = z__[j] / delta[j];
+ phi += z__[j] * temp;
+ dphi += temp * temp;
+ erretm += phi;
+/* L230: */
+ }
+
+ temp = z__[ii] / delta[ii];
+ dw = dpsi + dphi + temp * temp;
+ temp = z__[ii] * temp;
+ w = rhoinv + phi + psi + temp;
+ erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3.
+ + abs(tau) * dw;
+ if (w * prew > 0. && abs(w) > abs(prew) / 10.) {
+ swtch = ! swtch;
+ }
+
+/* L240: */
+ }
+
+/* Return with INFO = 1, NITER = MAXIT and not converged */
+
+ *info = 1;
+ if (orgati) {
+ *dlam = d__[*i__] + tau;
+ } else {
+ *dlam = d__[ip1] + tau;
+ }
+
+ }
+
+L250:
+
+ return 0;
+
+/* End of DLAED4 */
+
+} /* dlaed4_ */
diff --git a/SRC/dlaed5.c b/SRC/dlaed5.c
new file mode 100644
index 0000000..fdec19f
--- /dev/null
+++ b/SRC/dlaed5.c
@@ -0,0 +1,148 @@
+/* dlaed5.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlaed5_(integer *i__, doublereal *d__, doublereal *z__,
+ doublereal *delta, doublereal *rho, doublereal *dlam)
+{
+ /* System generated locals */
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal b, c__, w, del, tau, temp;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This subroutine computes the I-th eigenvalue of a symmetric rank-one */
+/* modification of a 2-by-2 diagonal matrix */
+
+/* diag( D ) + RHO * Z * transpose(Z) . */
+
+/* The diagonal elements in the array D are assumed to satisfy */
+
+/* D(i) < D(j) for i < j . */
+
+/* We also assume RHO > 0 and that the Euclidean norm of the vector */
+/* Z is one. */
+
+/* Arguments */
+/* ========= */
+
+/* I (input) INTEGER */
+/* The index of the eigenvalue to be computed. I = 1 or I = 2. */
+
+/* D (input) DOUBLE PRECISION array, dimension (2) */
+/* The original eigenvalues. We assume D(1) < D(2). */
+
+/* Z (input) DOUBLE PRECISION array, dimension (2) */
+/* The components of the updating vector. */
+
+/* DELTA (output) DOUBLE PRECISION array, dimension (2) */
+/* The vector DELTA contains the information necessary */
+/* to construct the eigenvectors. */
+
+/* RHO (input) DOUBLE PRECISION */
+/* The scalar in the symmetric updating formula. */
+
+/* DLAM (output) DOUBLE PRECISION */
+/* The computed lambda_I, the I-th updated eigenvalue. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ren-Cang Li, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --delta;
+ --z__;
+ --d__;
+
+ /* Function Body */
+ del = d__[2] - d__[1];
+ if (*i__ == 1) {
+ w = *rho * 2. * (z__[2] * z__[2] - z__[1] * z__[1]) / del + 1.;
+ if (w > 0.) {
+ b = del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
+ c__ = *rho * z__[1] * z__[1] * del;
+
+/* B > ZERO, always */
+
+ tau = c__ * 2. / (b + sqrt((d__1 = b * b - c__ * 4., abs(d__1))));
+ *dlam = d__[1] + tau;
+ delta[1] = -z__[1] / tau;
+ delta[2] = z__[2] / (del - tau);
+ } else {
+ b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
+ c__ = *rho * z__[2] * z__[2] * del;
+ if (b > 0.) {
+ tau = c__ * -2. / (b + sqrt(b * b + c__ * 4.));
+ } else {
+ tau = (b - sqrt(b * b + c__ * 4.)) / 2.;
+ }
+ *dlam = d__[2] + tau;
+ delta[1] = -z__[1] / (del + tau);
+ delta[2] = -z__[2] / tau;
+ }
+ temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]);
+ delta[1] /= temp;
+ delta[2] /= temp;
+ } else {
+
+/* Now I=2 */
+
+ b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
+ c__ = *rho * z__[2] * z__[2] * del;
+ if (b > 0.) {
+ tau = (b + sqrt(b * b + c__ * 4.)) / 2.;
+ } else {
+ tau = c__ * 2. / (-b + sqrt(b * b + c__ * 4.));
+ }
+ *dlam = d__[2] + tau;
+ delta[1] = -z__[1] / (del + tau);
+ delta[2] = -z__[2] / tau;
+ temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]);
+ delta[1] /= temp;
+ delta[2] /= temp;
+ }
+ return 0;
+
+/* End OF DLAED5 */
+
+} /* dlaed5_ */
diff --git a/SRC/dlaed6.c b/SRC/dlaed6.c
new file mode 100644
index 0000000..eff20c2
--- /dev/null
+++ b/SRC/dlaed6.c
@@ -0,0 +1,374 @@
+/* dlaed6.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlaed6_(integer *kniter, logical *orgati, doublereal *
+ rho, doublereal *d__, doublereal *z__, doublereal *finit, doublereal *
+ tau, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal), log(doublereal), pow_di(doublereal *, integer *);
+
+ /* Local variables */
+ doublereal a, b, c__, f;
+ integer i__;
+ doublereal fc, df, ddf, lbd, eta, ubd, eps, base;
+ integer iter;
+ doublereal temp, temp1, temp2, temp3, temp4;
+ logical scale;
+ integer niter;
+ doublereal small1, small2, sminv1, sminv2;
+ extern doublereal dlamch_(char *);
+ doublereal dscale[3], sclfac, zscale[3], erretm, sclinv;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAED6 computes the positive or negative root (closest to the origin) */
+/* of */
+/* z(1) z(2) z(3) */
+/* f(x) = rho + --------- + ---------- + --------- */
+/* d(1)-x d(2)-x d(3)-x */
+
+/* It is assumed that */
+
+/* if ORGATI = .true. the root is between d(2) and d(3); */
+/* otherwise it is between d(1) and d(2) */
+
+/* This routine will be called by DLAED4 when necessary. In most cases, */
+/* the root sought is the smallest in magnitude, though it might not be */
+/* in some extremely rare situations. */
+
+/* Arguments */
+/* ========= */
+
+/* KNITER (input) INTEGER */
+/* Refer to DLAED4 for its significance. */
+
+/* ORGATI (input) LOGICAL */
+/* If ORGATI is true, the needed root is between d(2) and */
+/* d(3); otherwise it is between d(1) and d(2). See */
+/* DLAED4 for further details. */
+
+/* RHO (input) DOUBLE PRECISION */
+/* Refer to the equation f(x) above. */
+
+/* D (input) DOUBLE PRECISION array, dimension (3) */
+/* D satisfies d(1) < d(2) < d(3). */
+
+/* Z (input) DOUBLE PRECISION array, dimension (3) */
+/* Each of the elements in z must be positive. */
+
+/* FINIT (input) DOUBLE PRECISION */
+/* The value of f at 0. It is more accurate than the one */
+/* evaluated inside this routine (if someone wants to do */
+/* so). */
+
+/* TAU (output) DOUBLE PRECISION */
+/* The root of the equation f(x). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* > 0: if INFO = 1, failure to converge */
+
+/* Further Details */
+/* =============== */
+
+/* 30/06/99: Based on contributions by */
+/* Ren-Cang Li, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* 10/02/03: This version has a few statements commented out for thread */
+/* safety (machine parameters are computed on each entry). SJH. */
+
+/* 05/10/06: Modified from a new version of Ren-Cang Li, use */
+/* Gragg-Thornton-Warner cubic convergent scheme for better stability. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --z__;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*orgati) {
+ lbd = d__[2];
+ ubd = d__[3];
+ } else {
+ lbd = d__[1];
+ ubd = d__[2];
+ }
+ if (*finit < 0.) {
+ lbd = 0.;
+ } else {
+ ubd = 0.;
+ }
+
+ niter = 1;
+ *tau = 0.;
+ if (*kniter == 2) {
+ if (*orgati) {
+ temp = (d__[3] - d__[2]) / 2.;
+ c__ = *rho + z__[1] / (d__[1] - d__[2] - temp);
+ a = c__ * (d__[2] + d__[3]) + z__[2] + z__[3];
+ b = c__ * d__[2] * d__[3] + z__[2] * d__[3] + z__[3] * d__[2];
+ } else {
+ temp = (d__[1] - d__[2]) / 2.;
+ c__ = *rho + z__[3] / (d__[3] - d__[2] - temp);
+ a = c__ * (d__[1] + d__[2]) + z__[1] + z__[2];
+ b = c__ * d__[1] * d__[2] + z__[1] * d__[2] + z__[2] * d__[1];
+ }
+/* Computing MAX */
+ d__1 = abs(a), d__2 = abs(b), d__1 = max(d__1,d__2), d__2 = abs(c__);
+ temp = max(d__1,d__2);
+ a /= temp;
+ b /= temp;
+ c__ /= temp;
+ if (c__ == 0.) {
+ *tau = b / a;
+ } else if (a <= 0.) {
+ *tau = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (
+ c__ * 2.);
+ } else {
+ *tau = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1))
+ ));
+ }
+ if (*tau < lbd || *tau > ubd) {
+ *tau = (lbd + ubd) / 2.;
+ }
+ if (d__[1] == *tau || d__[2] == *tau || d__[3] == *tau) {
+ *tau = 0.;
+ } else {
+ temp = *finit + *tau * z__[1] / (d__[1] * (d__[1] - *tau)) + *tau
+ * z__[2] / (d__[2] * (d__[2] - *tau)) + *tau * z__[3] / (
+ d__[3] * (d__[3] - *tau));
+ if (temp <= 0.) {
+ lbd = *tau;
+ } else {
+ ubd = *tau;
+ }
+ if (abs(*finit) <= abs(temp)) {
+ *tau = 0.;
+ }
+ }
+ }
+
+/* get machine parameters for possible scaling to avoid overflow */
+
+/* modified by Sven: parameters SMALL1, SMINV1, SMALL2, */
+/* SMINV2, EPS are not SAVEd anymore between one call to the */
+/* others but recomputed at each call */
+
+ eps = dlamch_("Epsilon");
+ base = dlamch_("Base");
+ i__1 = (integer) (log(dlamch_("SafMin")) / log(base) / 3.);
+ small1 = pow_di(&base, &i__1);
+ sminv1 = 1. / small1;
+ small2 = small1 * small1;
+ sminv2 = sminv1 * sminv1;
+
+/* Determine if scaling of inputs necessary to avoid overflow */
+/* when computing 1/TEMP**3 */
+
+ if (*orgati) {
+/* Computing MIN */
+ d__3 = (d__1 = d__[2] - *tau, abs(d__1)), d__4 = (d__2 = d__[3] - *
+ tau, abs(d__2));
+ temp = min(d__3,d__4);
+ } else {
+/* Computing MIN */
+ d__3 = (d__1 = d__[1] - *tau, abs(d__1)), d__4 = (d__2 = d__[2] - *
+ tau, abs(d__2));
+ temp = min(d__3,d__4);
+ }
+ scale = FALSE_;
+ if (temp <= small1) {
+ scale = TRUE_;
+ if (temp <= small2) {
+
+/* Scale up by power of radix nearest 1/SAFMIN**(2/3) */
+
+ sclfac = sminv2;
+ sclinv = small2;
+ } else {
+
+/* Scale up by power of radix nearest 1/SAFMIN**(1/3) */
+
+ sclfac = sminv1;
+ sclinv = small1;
+ }
+
+/* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1) */
+
+ for (i__ = 1; i__ <= 3; ++i__) {
+ dscale[i__ - 1] = d__[i__] * sclfac;
+ zscale[i__ - 1] = z__[i__] * sclfac;
+/* L10: */
+ }
+ *tau *= sclfac;
+ lbd *= sclfac;
+ ubd *= sclfac;
+ } else {
+
+/* Copy D and Z to DSCALE and ZSCALE */
+
+ for (i__ = 1; i__ <= 3; ++i__) {
+ dscale[i__ - 1] = d__[i__];
+ zscale[i__ - 1] = z__[i__];
+/* L20: */
+ }
+ }
+
+ fc = 0.;
+ df = 0.;
+ ddf = 0.;
+ for (i__ = 1; i__ <= 3; ++i__) {
+ temp = 1. / (dscale[i__ - 1] - *tau);
+ temp1 = zscale[i__ - 1] * temp;
+ temp2 = temp1 * temp;
+ temp3 = temp2 * temp;
+ fc += temp1 / dscale[i__ - 1];
+ df += temp2;
+ ddf += temp3;
+/* L30: */
+ }
+ f = *finit + *tau * fc;
+
+ if (abs(f) <= 0.) {
+ goto L60;
+ }
+ if (f <= 0.) {
+ lbd = *tau;
+ } else {
+ ubd = *tau;
+ }
+
+/* Iteration begins -- Use Gragg-Thornton-Warner cubic convergent */
+/* scheme */
+
+/* It is not hard to see that */
+
+/* 1) Iterations will go up monotonically */
+/* if FINIT < 0; */
+
+/* 2) Iterations will go down monotonically */
+/* if FINIT > 0. */
+
+ iter = niter + 1;
+
+ for (niter = iter; niter <= 40; ++niter) {
+
+ if (*orgati) {
+ temp1 = dscale[1] - *tau;
+ temp2 = dscale[2] - *tau;
+ } else {
+ temp1 = dscale[0] - *tau;
+ temp2 = dscale[1] - *tau;
+ }
+ a = (temp1 + temp2) * f - temp1 * temp2 * df;
+ b = temp1 * temp2 * f;
+ c__ = f - (temp1 + temp2) * df + temp1 * temp2 * ddf;
+/* Computing MAX */
+ d__1 = abs(a), d__2 = abs(b), d__1 = max(d__1,d__2), d__2 = abs(c__);
+ temp = max(d__1,d__2);
+ a /= temp;
+ b /= temp;
+ c__ /= temp;
+ if (c__ == 0.) {
+ eta = b / a;
+ } else if (a <= 0.) {
+ eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__
+ * 2.);
+ } else {
+ eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))
+ );
+ }
+ if (f * eta >= 0.) {
+ eta = -f / df;
+ }
+
+ *tau += eta;
+ if (*tau < lbd || *tau > ubd) {
+ *tau = (lbd + ubd) / 2.;
+ }
+
+ fc = 0.;
+ erretm = 0.;
+ df = 0.;
+ ddf = 0.;
+ for (i__ = 1; i__ <= 3; ++i__) {
+ temp = 1. / (dscale[i__ - 1] - *tau);
+ temp1 = zscale[i__ - 1] * temp;
+ temp2 = temp1 * temp;
+ temp3 = temp2 * temp;
+ temp4 = temp1 / dscale[i__ - 1];
+ fc += temp4;
+ erretm += abs(temp4);
+ df += temp2;
+ ddf += temp3;
+/* L40: */
+ }
+ f = *finit + *tau * fc;
+ erretm = (abs(*finit) + abs(*tau) * erretm) * 8. + abs(*tau) * df;
+ if (abs(f) <= eps * erretm) {
+ goto L60;
+ }
+ if (f <= 0.) {
+ lbd = *tau;
+ } else {
+ ubd = *tau;
+ }
+/* L50: */
+ }
+ *info = 1;
+L60:
+
+/* Undo scaling */
+
+ if (scale) {
+ *tau *= sclinv;
+ }
+ return 0;
+
+/* End of DLAED6 */
+
+} /* dlaed6_ */
diff --git a/SRC/dlaed7.c b/SRC/dlaed7.c
new file mode 100644
index 0000000..93a1848
--- /dev/null
+++ b/SRC/dlaed7.c
@@ -0,0 +1,354 @@
+/* dlaed7.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static doublereal c_b10 = 1.;
+static doublereal c_b11 = 0.;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dlaed7_(integer *icompq, integer *n, integer *qsiz,
+ integer *tlvls, integer *curlvl, integer *curpbm, doublereal *d__,
+ doublereal *q, integer *ldq, integer *indxq, doublereal *rho, integer
+ *cutpnt, doublereal *qstore, integer *qptr, integer *prmptr, integer *
+ perm, integer *givptr, integer *givcol, doublereal *givnum,
+ doublereal *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, i__1, i__2;
+
+ /* Builtin functions */
+ integer pow_ii(integer *, integer *);
+
+ /* Local variables */
+ integer i__, k, n1, n2, is, iw, iz, iq2, ptr, ldq2, indx, curr;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ integer indxc, indxp;
+ extern /* Subroutine */ int dlaed8_(integer *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *, integer *,
+ doublereal *, integer *, integer *, integer *), dlaed9_(integer *,
+ integer *, integer *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *), dlaeda_(integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, doublereal
+ *, doublereal *, integer *, doublereal *, doublereal *, integer *)
+ ;
+ integer idlmda;
+ extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *,
+ integer *, integer *, integer *), xerbla_(char *, integer *);
+ integer coltyp;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAED7 computes the updated eigensystem of a diagonal */
+/* matrix after modification by a rank-one symmetric matrix. This */
+/* routine is used only for the eigenproblem which requires all */
+/* eigenvalues and optionally eigenvectors of a dense symmetric matrix */
+/* that has been reduced to tridiagonal form. DLAED1 handles */
+/* the case in which all eigenvalues and eigenvectors of a symmetric */
+/* tridiagonal matrix are desired. */
+
+/* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out) */
+
+/* where Z = Q'u, u is a vector of length N with ones in the */
+/* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. */
+
+/* The eigenvectors of the original matrix are stored in Q, and the */
+/* eigenvalues are in D. The algorithm consists of three stages: */
+
+/* The first stage consists of deflating the size of the problem */
+/* when there are multiple eigenvalues or if there is a zero in */
+/* the Z vector. For each such occurence the dimension of the */
+/* secular equation problem is reduced by one. This stage is */
+/* performed by the routine DLAED8. */
+
+/* The second stage consists of calculating the updated */
+/* eigenvalues. This is done by finding the roots of the secular */
+/* equation via the routine DLAED4 (as called by DLAED9). */
+/* This routine also calculates the eigenvectors of the current */
+/* problem. */
+
+/* The final stage consists of computing the updated eigenvectors */
+/* directly using the updated eigenvalues. The eigenvectors for */
+/* the current problem are multiplied with the eigenvectors from */
+/* the overall problem. */
+
+/* Arguments */
+/* ========= */
+
+/* ICOMPQ (input) INTEGER */
+/* = 0: Compute eigenvalues only. */
+/* = 1: Compute eigenvectors of original dense symmetric matrix */
+/* also. On entry, Q contains the orthogonal matrix used */
+/* to reduce the original matrix to tridiagonal form. */
+
+/* N (input) INTEGER */
+/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
+
+/* QSIZ (input) INTEGER */
+/* The dimension of the orthogonal matrix used to reduce */
+/* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. */
+
+/* TLVLS (input) INTEGER */
+/* The total number of merging levels in the overall divide and */
+/* conquer tree. */
+
+/* CURLVL (input) INTEGER */
+/* The current level in the overall merge routine, */
+/* 0 <= CURLVL <= TLVLS. */
+
+/* CURPBM (input) INTEGER */
+/* The current problem in the current level in the overall */
+/* merge routine (counting from upper left to lower right). */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the eigenvalues of the rank-1-perturbed matrix. */
+/* On exit, the eigenvalues of the repaired matrix. */
+
+/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) */
+/* On entry, the eigenvectors of the rank-1-perturbed matrix. */
+/* On exit, the eigenvectors of the repaired tridiagonal matrix. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* INDXQ (output) INTEGER array, dimension (N) */
+/* The permutation which will reintegrate the subproblem just */
+/* solved back into sorted order, i.e., D( INDXQ( I = 1, N ) ) */
+/* will be in ascending order. */
+
+/* RHO (input) DOUBLE PRECISION */
+/* The subdiagonal element used to create the rank-1 */
+/* modification. */
+
+/* CUTPNT (input) INTEGER */
+/* Contains the location of the last eigenvalue in the leading */
+/* sub-matrix. min(1,N) <= CUTPNT <= N. */
+
+/* QSTORE (input/output) DOUBLE PRECISION array, dimension (N**2+1) */
+/* Stores eigenvectors of submatrices encountered during */
+/* divide and conquer, packed together. QPTR points to */
+/* beginning of the submatrices. */
+
+/* QPTR (input/output) INTEGER array, dimension (N+2) */
+/* List of indices pointing to beginning of submatrices stored */
+/* in QSTORE. The submatrices are numbered starting at the */
+/* bottom left of the divide and conquer tree, from left to */
+/* right and bottom to top. */
+
+/* PRMPTR (input) INTEGER array, dimension (N lg N) */
+/* Contains a list of pointers which indicate where in PERM a */
+/* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) */
+/* indicates the size of the permutation and also the size of */
+/* the full, non-deflated problem. */
+
+/* PERM (input) INTEGER array, dimension (N lg N) */
+/* Contains the permutations (from deflation and sorting) to be */
+/* applied to each eigenblock. */
+
+/* GIVPTR (input) INTEGER array, dimension (N lg N) */
+/* Contains a list of pointers which indicate where in GIVCOL a */
+/* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) */
+/* indicates the number of Givens rotations. */
+
+/* GIVCOL (input) INTEGER array, dimension (2, N lg N) */
+/* Each pair of numbers indicates a pair of columns to take place */
+/* in a Givens rotation. */
+
+/* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N) */
+/* Each number indicates the S value to be used in the */
+/* corresponding Givens rotation. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N+QSIZ*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (4*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, an eigenvalue did not converge */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --indxq;
+ --qstore;
+ --qptr;
+ --prmptr;
+ --perm;
+ --givptr;
+ givcol -= 3;
+ givnum -= 3;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*icompq < 0 || *icompq > 1) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*icompq == 1 && *qsiz < *n) {
+ *info = -4;
+ } else if (*ldq < max(1,*n)) {
+ *info = -9;
+ } else if (min(1,*n) > *cutpnt || *n < *cutpnt) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLAED7", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* The following values are for bookkeeping purposes only. They are */
+/* integer pointers which indicate the portion of the workspace */
+/* used by a particular array in DLAED8 and DLAED9. */
+
+ if (*icompq == 1) {
+ ldq2 = *qsiz;
+ } else {
+ ldq2 = *n;
+ }
+
+ iz = 1;
+ idlmda = iz + *n;
+ iw = idlmda + *n;
+ iq2 = iw + *n;
+ is = iq2 + *n * ldq2;
+
+ indx = 1;
+ indxc = indx + *n;
+ coltyp = indxc + *n;
+ indxp = coltyp + *n;
+
+/* Form the z-vector which consists of the last row of Q_1 and the */
+/* first row of Q_2. */
+
+ ptr = pow_ii(&c__2, tlvls) + 1;
+ i__1 = *curlvl - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *tlvls - i__;
+ ptr += pow_ii(&c__2, &i__2);
+/* L10: */
+ }
+ curr = ptr + *curpbm;
+ dlaeda_(n, tlvls, curlvl, curpbm, &prmptr[1], &perm[1], &givptr[1], &
+ givcol[3], &givnum[3], &qstore[1], &qptr[1], &work[iz], &work[iz
+ + *n], info);
+
+/* When solving the final problem, we no longer need the stored data, */
+/* so we will overwrite the data from this level onto the previously */
+/* used storage space. */
+
+ if (*curlvl == *tlvls) {
+ qptr[curr] = 1;
+ prmptr[curr] = 1;
+ givptr[curr] = 1;
+ }
+
+/* Sort and Deflate eigenvalues. */
+
+ dlaed8_(icompq, &k, n, qsiz, &d__[1], &q[q_offset], ldq, &indxq[1], rho,
+ cutpnt, &work[iz], &work[idlmda], &work[iq2], &ldq2, &work[iw], &
+ perm[prmptr[curr]], &givptr[curr + 1], &givcol[(givptr[curr] << 1)
+ + 1], &givnum[(givptr[curr] << 1) + 1], &iwork[indxp], &iwork[
+ indx], info);
+ prmptr[curr + 1] = prmptr[curr] + *n;
+ givptr[curr + 1] += givptr[curr];
+
+/* Solve Secular Equation. */
+
+ if (k != 0) {
+ dlaed9_(&k, &c__1, &k, n, &d__[1], &work[is], &k, rho, &work[idlmda],
+ &work[iw], &qstore[qptr[curr]], &k, info);
+ if (*info != 0) {
+ goto L30;
+ }
+ if (*icompq == 1) {
+ dgemm_("N", "N", qsiz, &k, &k, &c_b10, &work[iq2], &ldq2, &qstore[
+ qptr[curr]], &k, &c_b11, &q[q_offset], ldq);
+ }
+/* Computing 2nd power */
+ i__1 = k;
+ qptr[curr + 1] = qptr[curr] + i__1 * i__1;
+
+/* Prepare the INDXQ sorting permutation. */
+
+ n1 = k;
+ n2 = *n - k;
+ dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]);
+ } else {
+ qptr[curr + 1] = qptr[curr];
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ indxq[i__] = i__;
+/* L20: */
+ }
+ }
+
+L30:
+ return 0;
+
+/* End of DLAED7 */
+
+} /* dlaed7_ */
diff --git a/SRC/dlaed8.c b/SRC/dlaed8.c
new file mode 100644
index 0000000..6c1656b
--- /dev/null
+++ b/SRC/dlaed8.c
@@ -0,0 +1,475 @@
+/* dlaed8.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b3 = -1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dlaed8_(integer *icompq, integer *k, integer *n, integer
+ *qsiz, doublereal *d__, doublereal *q, integer *ldq, integer *indxq,
+ doublereal *rho, integer *cutpnt, doublereal *z__, doublereal *dlamda,
+ doublereal *q2, integer *ldq2, doublereal *w, integer *perm, integer
+ *givptr, integer *givcol, doublereal *givnum, integer *indxp, integer
+ *indx, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, q2_dim1, q2_offset, i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal c__;
+ integer i__, j;
+ doublereal s, t;
+ integer k2, n1, n2, jp, n1p1;
+ doublereal eps, tau, tol;
+ integer jlam, imax, jmax;
+ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *), dscal_(
+ integer *, doublereal *, doublereal *, integer *), dcopy_(integer
+ *, doublereal *, integer *, doublereal *, integer *);
+ extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *,
+ integer *, integer *, integer *), dlacpy_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAED8 merges the two sets of eigenvalues together into a single */
+/* sorted set. Then it tries to deflate the size of the problem. */
+/* There are two ways in which deflation can occur: when two or more */
+/* eigenvalues are close together or if there is a tiny element in the */
+/* Z vector. For each such occurrence the order of the related secular */
+/* equation problem is reduced by one. */
+
+/* Arguments */
+/* ========= */
+
+/* ICOMPQ (input) INTEGER */
+/* = 0: Compute eigenvalues only. */
+/* = 1: Compute eigenvectors of original dense symmetric matrix */
+/* also. On entry, Q contains the orthogonal matrix used */
+/* to reduce the original matrix to tridiagonal form. */
+
+/* K (output) INTEGER */
+/* The number of non-deflated eigenvalues, and the order of the */
+/* related secular equation. */
+
+/* N (input) INTEGER */
+/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
+
+/* QSIZ (input) INTEGER */
+/* The dimension of the orthogonal matrix used to reduce */
+/* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the eigenvalues of the two submatrices to be */
+/* combined. On exit, the trailing (N-K) updated eigenvalues */
+/* (those which were deflated) sorted into increasing order. */
+
+/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */
+/* If ICOMPQ = 0, Q is not referenced. Otherwise, */
+/* on entry, Q contains the eigenvectors of the partially solved */
+/* system which has been previously updated in matrix */
+/* multiplies with other partially solved eigensystems. */
+/* On exit, Q contains the trailing (N-K) updated eigenvectors */
+/* (those which were deflated) in its last N-K columns. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* INDXQ (input) INTEGER array, dimension (N) */
+/* The permutation which separately sorts the two sub-problems */
+/* in D into ascending order. Note that elements in the second */
+/* half of this permutation must first have CUTPNT added to */
+/* their values in order to be accurate. */
+
+/* RHO (input/output) DOUBLE PRECISION */
+/* On entry, the off-diagonal element associated with the rank-1 */
+/* cut which originally split the two submatrices which are now */
+/* being recombined. */
+/* On exit, RHO has been modified to the value required by */
+/* DLAED3. */
+
+/* CUTPNT (input) INTEGER */
+/* The location of the last eigenvalue in the leading */
+/* sub-matrix. min(1,N) <= CUTPNT <= N. */
+
+/* Z (input) DOUBLE PRECISION array, dimension (N) */
+/* On entry, Z contains the updating vector (the last row of */
+/* the first sub-eigenvector matrix and the first row of the */
+/* second sub-eigenvector matrix). */
+/* On exit, the contents of Z are destroyed by the updating */
+/* process. */
+
+/* DLAMDA (output) DOUBLE PRECISION array, dimension (N) */
+/* A copy of the first K eigenvalues which will be used by */
+/* DLAED3 to form the secular equation. */
+
+/* Q2 (output) DOUBLE PRECISION array, dimension (LDQ2,N) */
+/* If ICOMPQ = 0, Q2 is not referenced. Otherwise, */
+/* a copy of the first K eigenvectors which will be used by */
+/* DLAED7 in a matrix multiply (DGEMM) to update the new */
+/* eigenvectors. */
+
+/* LDQ2 (input) INTEGER */
+/* The leading dimension of the array Q2. LDQ2 >= max(1,N). */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* The first k values of the final deflation-altered z-vector and */
+/* will be passed to DLAED3. */
+
+/* PERM (output) INTEGER array, dimension (N) */
+/* The permutations (from deflation and sorting) to be applied */
+/* to each eigenblock. */
+
+/* GIVPTR (output) INTEGER */
+/* The number of Givens rotations which took place in this */
+/* subproblem. */
+
+/* GIVCOL (output) INTEGER array, dimension (2, N) */
+/* Each pair of numbers indicates a pair of columns to take place */
+/* in a Givens rotation. */
+
+/* GIVNUM (output) DOUBLE PRECISION array, dimension (2, N) */
+/* Each number indicates the S value to be used in the */
+/* corresponding Givens rotation. */
+
+/* INDXP (workspace) INTEGER array, dimension (N) */
+/* The permutation used to place deflated values of D at the end */
+/* of the array. INDXP(1:K) points to the nondeflated D-values */
+/* and INDXP(K+1:N) points to the deflated eigenvalues. */
+
+/* INDX (workspace) INTEGER array, dimension (N) */
+/* The permutation used to sort the contents of D into ascending */
+/* order. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --indxq;
+ --z__;
+ --dlamda;
+ q2_dim1 = *ldq2;
+ q2_offset = 1 + q2_dim1;
+ q2 -= q2_offset;
+ --w;
+ --perm;
+ givcol -= 3;
+ givnum -= 3;
+ --indxp;
+ --indx;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*icompq < 0 || *icompq > 1) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*icompq == 1 && *qsiz < *n) {
+ *info = -4;
+ } else if (*ldq < max(1,*n)) {
+ *info = -7;
+ } else if (*cutpnt < min(1,*n) || *cutpnt > *n) {
+ *info = -10;
+ } else if (*ldq2 < max(1,*n)) {
+ *info = -14;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLAED8", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ n1 = *cutpnt;
+ n2 = *n - n1;
+ n1p1 = n1 + 1;
+
+ if (*rho < 0.) {
+ dscal_(&n2, &c_b3, &z__[n1p1], &c__1);
+ }
+
+/* Normalize z so that norm(z) = 1 */
+
+ t = 1. / sqrt(2.);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ indx[j] = j;
+/* L10: */
+ }
+ dscal_(n, &t, &z__[1], &c__1);
+ *rho = (d__1 = *rho * 2., abs(d__1));
+
+/* Sort the eigenvalues into increasing order */
+
+ i__1 = *n;
+ for (i__ = *cutpnt + 1; i__ <= i__1; ++i__) {
+ indxq[i__] += *cutpnt;
+/* L20: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dlamda[i__] = d__[indxq[i__]];
+ w[i__] = z__[indxq[i__]];
+/* L30: */
+ }
+ i__ = 1;
+ j = *cutpnt + 1;
+ dlamrg_(&n1, &n2, &dlamda[1], &c__1, &c__1, &indx[1]);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = dlamda[indx[i__]];
+ z__[i__] = w[indx[i__]];
+/* L40: */
+ }
+
+/* Calculate the allowable deflation tolerence */
+
+ imax = idamax_(n, &z__[1], &c__1);
+ jmax = idamax_(n, &d__[1], &c__1);
+ eps = dlamch_("Epsilon");
+ tol = eps * 8. * (d__1 = d__[jmax], abs(d__1));
+
+/* If the rank-1 modifier is small enough, no more needs to be done */
+/* except to reorganize Q so that its columns correspond with the */
+/* elements in D. */
+
+ if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) {
+ *k = 0;
+ if (*icompq == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ perm[j] = indxq[indx[j]];
+/* L50: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ perm[j] = indxq[indx[j]];
+ dcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1
+ + 1], &c__1);
+/* L60: */
+ }
+ dlacpy_("A", qsiz, n, &q2[q2_dim1 + 1], ldq2, &q[q_dim1 + 1], ldq);
+ }
+ return 0;
+ }
+
+/* If there are multiple eigenvalues then the problem deflates. Here */
+/* the number of equal eigenvalues are found. As each equal */
+/* eigenvalue is found, an elementary reflector is computed to rotate */
+/* the corresponding eigensubspace so that the corresponding */
+/* components of Z are zero in this new basis. */
+
+ *k = 0;
+ *givptr = 0;
+ k2 = *n + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) {
+
+/* Deflate due to small z component. */
+
+ --k2;
+ indxp[k2] = j;
+ if (j == *n) {
+ goto L110;
+ }
+ } else {
+ jlam = j;
+ goto L80;
+ }
+/* L70: */
+ }
+L80:
+ ++j;
+ if (j > *n) {
+ goto L100;
+ }
+ if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) {
+
+/* Deflate due to small z component. */
+
+ --k2;
+ indxp[k2] = j;
+ } else {
+
+/* Check if eigenvalues are close enough to allow deflation. */
+
+ s = z__[jlam];
+ c__ = z__[j];
+
+/* Find sqrt(a**2+b**2) without overflow or */
+/* destructive underflow. */
+
+ tau = dlapy2_(&c__, &s);
+ t = d__[j] - d__[jlam];
+ c__ /= tau;
+ s = -s / tau;
+ if ((d__1 = t * c__ * s, abs(d__1)) <= tol) {
+
+/* Deflation is possible. */
+
+ z__[j] = tau;
+ z__[jlam] = 0.;
+
+/* Record the appropriate Givens rotation */
+
+ ++(*givptr);
+ givcol[(*givptr << 1) + 1] = indxq[indx[jlam]];
+ givcol[(*givptr << 1) + 2] = indxq[indx[j]];
+ givnum[(*givptr << 1) + 1] = c__;
+ givnum[(*givptr << 1) + 2] = s;
+ if (*icompq == 1) {
+ drot_(qsiz, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, &q[
+ indxq[indx[j]] * q_dim1 + 1], &c__1, &c__, &s);
+ }
+ t = d__[jlam] * c__ * c__ + d__[j] * s * s;
+ d__[j] = d__[jlam] * s * s + d__[j] * c__ * c__;
+ d__[jlam] = t;
+ --k2;
+ i__ = 1;
+L90:
+ if (k2 + i__ <= *n) {
+ if (d__[jlam] < d__[indxp[k2 + i__]]) {
+ indxp[k2 + i__ - 1] = indxp[k2 + i__];
+ indxp[k2 + i__] = jlam;
+ ++i__;
+ goto L90;
+ } else {
+ indxp[k2 + i__ - 1] = jlam;
+ }
+ } else {
+ indxp[k2 + i__ - 1] = jlam;
+ }
+ jlam = j;
+ } else {
+ ++(*k);
+ w[*k] = z__[jlam];
+ dlamda[*k] = d__[jlam];
+ indxp[*k] = jlam;
+ jlam = j;
+ }
+ }
+ goto L80;
+L100:
+
+/* Record the last eigenvalue. */
+
+ ++(*k);
+ w[*k] = z__[jlam];
+ dlamda[*k] = d__[jlam];
+ indxp[*k] = jlam;
+
+L110:
+
+/* Sort the eigenvalues and corresponding eigenvectors into DLAMDA */
+/* and Q2 respectively. The eigenvalues/vectors which were not */
+/* deflated go into the first K slots of DLAMDA and Q2 respectively, */
+/* while those which were deflated go into the last N - K slots. */
+
+ if (*icompq == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ jp = indxp[j];
+ dlamda[j] = d__[jp];
+ perm[j] = indxq[indx[jp]];
+/* L120: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ jp = indxp[j];
+ dlamda[j] = d__[jp];
+ perm[j] = indxq[indx[jp]];
+ dcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1]
+, &c__1);
+/* L130: */
+ }
+ }
+
+/* The deflated eigenvalues and their corresponding vectors go back */
+/* into the last N - K slots of D and Q respectively. */
+
+ if (*k < *n) {
+ if (*icompq == 0) {
+ i__1 = *n - *k;
+ dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1);
+ } else {
+ i__1 = *n - *k;
+ dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1);
+ i__1 = *n - *k;
+ dlacpy_("A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(*
+ k + 1) * q_dim1 + 1], ldq);
+ }
+ }
+
+ return 0;
+
+/* End of DLAED8 */
+
+} /* dlaed8_ */
diff --git a/SRC/dlaed9.c b/SRC/dlaed9.c
new file mode 100644
index 0000000..25b3466
--- /dev/null
+++ b/SRC/dlaed9.c
@@ -0,0 +1,274 @@
+/* dlaed9.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dlaed9_(integer *k, integer *kstart, integer *kstop,
+ integer *n, doublereal *d__, doublereal *q, integer *ldq, doublereal *
+ rho, doublereal *dlamda, doublereal *w, doublereal *s, integer *lds,
+ integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, s_dim1, s_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal temp;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dlaed4_(integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *);
+ extern doublereal dlamc3_(doublereal *, doublereal *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAED9 finds the roots of the secular equation, as defined by the */
+/* values in D, Z, and RHO, between KSTART and KSTOP. It makes the */
+/* appropriate calls to DLAED4 and then stores the new matrix of */
+/* eigenvectors for use in calculating the next level of Z vectors. */
+
+/* Arguments */
+/* ========= */
+
+/* K (input) INTEGER */
+/* The number of terms in the rational function to be solved by */
+/* DLAED4. K >= 0. */
+
+/* KSTART (input) INTEGER */
+/* KSTOP (input) INTEGER */
+/* The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP */
+/* are to be computed. 1 <= KSTART <= KSTOP <= K. */
+
+/* N (input) INTEGER */
+/* The number of rows and columns in the Q matrix. */
+/* N >= K (delation may result in N > K). */
+
+/* D (output) DOUBLE PRECISION array, dimension (N) */
+/* D(I) contains the updated eigenvalues */
+/* for KSTART <= I <= KSTOP. */
+
+/* Q (workspace) DOUBLE PRECISION array, dimension (LDQ,N) */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max( 1, N ). */
+
+/* RHO (input) DOUBLE PRECISION */
+/* The value of the parameter in the rank one update equation. */
+/* RHO >= 0 required. */
+
+/* DLAMDA (input) DOUBLE PRECISION array, dimension (K) */
+/* The first K elements of this array contain the old roots */
+/* of the deflated updating problem. These are the poles */
+/* of the secular equation. */
+
+/* W (input) DOUBLE PRECISION array, dimension (K) */
+/* The first K elements of this array contain the components */
+/* of the deflation-adjusted updating vector. */
+
+/* S (output) DOUBLE PRECISION array, dimension (LDS, K) */
+/* Will contain the eigenvectors of the repaired matrix which */
+/* will be stored for subsequent Z vector calculation and */
+/* multiplied by the previously accumulated eigenvectors */
+/* to update the system. */
+
+/* LDS (input) INTEGER */
+/* The leading dimension of S. LDS >= max( 1, K ). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, an eigenvalue did not converge */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --dlamda;
+ --w;
+ s_dim1 = *lds;
+ s_offset = 1 + s_dim1;
+ s -= s_offset;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*k < 0) {
+ *info = -1;
+ } else if (*kstart < 1 || *kstart > max(1,*k)) {
+ *info = -2;
+ } else if (max(1,*kstop) < *kstart || *kstop > max(1,*k)) {
+ *info = -3;
+ } else if (*n < *k) {
+ *info = -4;
+ } else if (*ldq < max(1,*k)) {
+ *info = -7;
+ } else if (*lds < max(1,*k)) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLAED9", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*k == 0) {
+ return 0;
+ }
+
+/* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */
+/* be computed with high relative accuracy (barring over/underflow). */
+/* This is a problem on machines without a guard digit in */
+/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */
+/* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), */
+/* which on any of these machines zeros out the bottommost */
+/* bit of DLAMDA(I) if it is 1; this makes the subsequent */
+/* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation */
+/* occurs. On binary machines with a guard digit (almost all */
+/* machines) it does not change DLAMDA(I) at all. On hexadecimal */
+/* and decimal machines with a guard digit, it slightly */
+/* changes the bottommost bits of DLAMDA(I). It does not account */
+/* for hexadecimal or decimal machines without guard digits */
+/* (we know of none). We use a subroutine call to compute */
+/* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating */
+/* this code. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dlamda[i__] = dlamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__];
+/* L10: */
+ }
+
+ i__1 = *kstop;
+ for (j = *kstart; j <= i__1; ++j) {
+ dlaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j],
+ info);
+
+/* If the zero finder fails, the computation is terminated. */
+
+ if (*info != 0) {
+ goto L120;
+ }
+/* L20: */
+ }
+
+ if (*k == 1 || *k == 2) {
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *k;
+ for (j = 1; j <= i__2; ++j) {
+ s[j + i__ * s_dim1] = q[j + i__ * q_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ goto L120;
+ }
+
+/* Compute updated W. */
+
+ dcopy_(k, &w[1], &c__1, &s[s_offset], &c__1);
+
+/* Initialize W(I) = Q(I,I) */
+
+ i__1 = *ldq + 1;
+ dcopy_(k, &q[q_offset], &i__1, &w[1], &c__1);
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
+/* L50: */
+ }
+ i__2 = *k;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
+/* L60: */
+ }
+/* L70: */
+ }
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__1 = sqrt(-w[i__]);
+ w[i__] = d_sign(&d__1, &s[i__ + s_dim1]);
+/* L80: */
+ }
+
+/* Compute eigenvectors of the modified rank-1 modification. */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *k;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ q[i__ + j * q_dim1] = w[i__] / q[i__ + j * q_dim1];
+/* L90: */
+ }
+ temp = dnrm2_(k, &q[j * q_dim1 + 1], &c__1);
+ i__2 = *k;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ s[i__ + j * s_dim1] = q[i__ + j * q_dim1] / temp;
+/* L100: */
+ }
+/* L110: */
+ }
+
+L120:
+ return 0;
+
+/* End of DLAED9 */
+
+} /* dlaed9_ */
diff --git a/SRC/dlaeda.c b/SRC/dlaeda.c
new file mode 100644
index 0000000..f9d8536
--- /dev/null
+++ b/SRC/dlaeda.c
@@ -0,0 +1,287 @@
+/* dlaeda.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static doublereal c_b24 = 1.;
+static doublereal c_b26 = 0.;
+
+/* Subroutine */ int dlaeda_(integer *n, integer *tlvls, integer *curlvl,
+ integer *curpbm, integer *prmptr, integer *perm, integer *givptr,
+ integer *givcol, doublereal *givnum, doublereal *q, integer *qptr,
+ doublereal *z__, doublereal *ztemp, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+
+ /* Builtin functions */
+ integer pow_ii(integer *, integer *);
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, k, mid, ptr;
+ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ integer curr, bsiz1, bsiz2, psiz1, psiz2, zptr1;
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dcopy_(integer *,
+ doublereal *, integer *, doublereal *, integer *), xerbla_(char *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAEDA computes the Z vector corresponding to the merge step in the */
+/* CURLVLth step of the merge process with TLVLS steps for the CURPBMth */
+/* problem. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
+
+/* TLVLS (input) INTEGER */
+/* The total number of merging levels in the overall divide and */
+/* conquer tree. */
+
+/* CURLVL (input) INTEGER */
+/* The current level in the overall merge routine, */
+/* 0 <= curlvl <= tlvls. */
+
+/* CURPBM (input) INTEGER */
+/* The current problem in the current level in the overall */
+/* merge routine (counting from upper left to lower right). */
+
+/* PRMPTR (input) INTEGER array, dimension (N lg N) */
+/* Contains a list of pointers which indicate where in PERM a */
+/* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) */
+/* indicates the size of the permutation and incidentally the */
+/* size of the full, non-deflated problem. */
+
+/* PERM (input) INTEGER array, dimension (N lg N) */
+/* Contains the permutations (from deflation and sorting) to be */
+/* applied to each eigenblock. */
+
+/* GIVPTR (input) INTEGER array, dimension (N lg N) */
+/* Contains a list of pointers which indicate where in GIVCOL a */
+/* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) */
+/* indicates the number of Givens rotations. */
+
+/* GIVCOL (input) INTEGER array, dimension (2, N lg N) */
+/* Each pair of numbers indicates a pair of columns to take place */
+/* in a Givens rotation. */
+
+/* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N) */
+/* Each number indicates the S value to be used in the */
+/* corresponding Givens rotation. */
+
+/* Q (input) DOUBLE PRECISION array, dimension (N**2) */
+/* Contains the square eigenblocks from previous levels, the */
+/* starting positions for blocks are given by QPTR. */
+
+/* QPTR (input) INTEGER array, dimension (N+2) */
+/* Contains a list of pointers which indicate where in Q an */
+/* eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates */
+/* the size of the block. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (N) */
+/* On output this vector contains the updating vector (the last */
+/* row of the first sub-eigenvector matrix and the first row of */
+/* the second sub-eigenvector matrix). */
+
+/* ZTEMP (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ztemp;
+ --z__;
+ --qptr;
+ --q;
+ givnum -= 3;
+ givcol -= 3;
+ --givptr;
+ --perm;
+ --prmptr;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*n < 0) {
+ *info = -1;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLAEDA", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine location of first number in second half. */
+
+ mid = *n / 2 + 1;
+
+/* Gather last/first rows of appropriate eigenblocks into center of Z */
+
+ ptr = 1;
+
+/* Determine location of lowest level subproblem in the full storage */
+/* scheme */
+
+ i__1 = *curlvl - 1;
+ curr = ptr + *curpbm * pow_ii(&c__2, curlvl) + pow_ii(&c__2, &i__1) - 1;
+
+/* Determine size of these matrices. We add HALF to the value of */
+/* the SQRT in case the machine underestimates one of these square */
+/* roots. */
+
+ bsiz1 = (integer) (sqrt((doublereal) (qptr[curr + 1] - qptr[curr])) + .5);
+ bsiz2 = (integer) (sqrt((doublereal) (qptr[curr + 2] - qptr[curr + 1])) +
+ .5);
+ i__1 = mid - bsiz1 - 1;
+ for (k = 1; k <= i__1; ++k) {
+ z__[k] = 0.;
+/* L10: */
+ }
+ dcopy_(&bsiz1, &q[qptr[curr] + bsiz1 - 1], &bsiz1, &z__[mid - bsiz1], &
+ c__1);
+ dcopy_(&bsiz2, &q[qptr[curr + 1]], &bsiz2, &z__[mid], &c__1);
+ i__1 = *n;
+ for (k = mid + bsiz2; k <= i__1; ++k) {
+ z__[k] = 0.;
+/* L20: */
+ }
+
+/* Loop thru remaining levels 1 -> CURLVL applying the Givens */
+/* rotations and permutation and then multiplying the center matrices */
+/* against the current Z. */
+
+ ptr = pow_ii(&c__2, tlvls) + 1;
+ i__1 = *curlvl - 1;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *curlvl - k;
+ i__3 = *curlvl - k - 1;
+ curr = ptr + *curpbm * pow_ii(&c__2, &i__2) + pow_ii(&c__2, &i__3) -
+ 1;
+ psiz1 = prmptr[curr + 1] - prmptr[curr];
+ psiz2 = prmptr[curr + 2] - prmptr[curr + 1];
+ zptr1 = mid - psiz1;
+
+/* Apply Givens at CURR and CURR+1 */
+
+ i__2 = givptr[curr + 1] - 1;
+ for (i__ = givptr[curr]; i__ <= i__2; ++i__) {
+ drot_(&c__1, &z__[zptr1 + givcol[(i__ << 1) + 1] - 1], &c__1, &
+ z__[zptr1 + givcol[(i__ << 1) + 2] - 1], &c__1, &givnum[(
+ i__ << 1) + 1], &givnum[(i__ << 1) + 2]);
+/* L30: */
+ }
+ i__2 = givptr[curr + 2] - 1;
+ for (i__ = givptr[curr + 1]; i__ <= i__2; ++i__) {
+ drot_(&c__1, &z__[mid - 1 + givcol[(i__ << 1) + 1]], &c__1, &z__[
+ mid - 1 + givcol[(i__ << 1) + 2]], &c__1, &givnum[(i__ <<
+ 1) + 1], &givnum[(i__ << 1) + 2]);
+/* L40: */
+ }
+ psiz1 = prmptr[curr + 1] - prmptr[curr];
+ psiz2 = prmptr[curr + 2] - prmptr[curr + 1];
+ i__2 = psiz1 - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ ztemp[i__ + 1] = z__[zptr1 + perm[prmptr[curr] + i__] - 1];
+/* L50: */
+ }
+ i__2 = psiz2 - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ ztemp[psiz1 + i__ + 1] = z__[mid + perm[prmptr[curr + 1] + i__] -
+ 1];
+/* L60: */
+ }
+
+/* Multiply Blocks at CURR and CURR+1 */
+
+/* Determine size of these matrices. We add HALF to the value of */
+/* the SQRT in case the machine underestimates one of these */
+/* square roots. */
+
+ bsiz1 = (integer) (sqrt((doublereal) (qptr[curr + 1] - qptr[curr])) +
+ .5);
+ bsiz2 = (integer) (sqrt((doublereal) (qptr[curr + 2] - qptr[curr + 1])
+ ) + .5);
+ if (bsiz1 > 0) {
+ dgemv_("T", &bsiz1, &bsiz1, &c_b24, &q[qptr[curr]], &bsiz1, &
+ ztemp[1], &c__1, &c_b26, &z__[zptr1], &c__1);
+ }
+ i__2 = psiz1 - bsiz1;
+ dcopy_(&i__2, &ztemp[bsiz1 + 1], &c__1, &z__[zptr1 + bsiz1], &c__1);
+ if (bsiz2 > 0) {
+ dgemv_("T", &bsiz2, &bsiz2, &c_b24, &q[qptr[curr + 1]], &bsiz2, &
+ ztemp[psiz1 + 1], &c__1, &c_b26, &z__[mid], &c__1);
+ }
+ i__2 = psiz2 - bsiz2;
+ dcopy_(&i__2, &ztemp[psiz1 + bsiz2 + 1], &c__1, &z__[mid + bsiz2], &
+ c__1);
+
+ i__2 = *tlvls - k;
+ ptr += pow_ii(&c__2, &i__2);
+/* L70: */
+ }
+
+ return 0;
+
+/* End of DLAEDA */
+
+} /* dlaeda_ */
diff --git a/SRC/dlaein.c b/SRC/dlaein.c
new file mode 100644
index 0000000..133171e
--- /dev/null
+++ b/SRC/dlaein.c
@@ -0,0 +1,677 @@
+/* dlaein.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dlaein_(logical *rightv, logical *noinit, integer *n,
+ doublereal *h__, integer *ldh, doublereal *wr, doublereal *wi,
+ doublereal *vr, doublereal *vi, doublereal *b, integer *ldb,
+ doublereal *work, doublereal *eps3, doublereal *smlnum, doublereal *
+ bignum, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal w, x, y;
+ integer i1, i2, i3;
+ doublereal w1, ei, ej, xi, xr, rec;
+ integer its, ierr;
+ doublereal temp, norm, vmax;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal scale;
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ char trans[1];
+ doublereal vcrit, rootn, vnorm;
+ extern doublereal dlapy2_(doublereal *, doublereal *);
+ doublereal absbii, absbjj;
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dladiv_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *), dlatrs_(
+ char *, char *, char *, char *, integer *, doublereal *, integer *
+, doublereal *, doublereal *, doublereal *, integer *);
+ char normin[1];
+ doublereal nrmsml, growto;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAEIN uses inverse iteration to find a right or left eigenvector */
+/* corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg */
+/* matrix H. */
+
+/* Arguments */
+/* ========= */
+
+/* RIGHTV (input) LOGICAL */
+/* = .TRUE. : compute right eigenvector; */
+/* = .FALSE.: compute left eigenvector. */
+
+/* NOINIT (input) LOGICAL */
+/* = .TRUE. : no initial vector supplied in (VR,VI). */
+/* = .FALSE.: initial vector supplied in (VR,VI). */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N >= 0. */
+
+/* H (input) DOUBLE PRECISION array, dimension (LDH,N) */
+/* The upper Hessenberg matrix H. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH >= max(1,N). */
+
+/* WR (input) DOUBLE PRECISION */
+/* WI (input) DOUBLE PRECISION */
+/* The real and imaginary parts of the eigenvalue of H whose */
+/* corresponding right or left eigenvector is to be computed. */
+
+/* VR (input/output) DOUBLE PRECISION array, dimension (N) */
+/* VI (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain */
+/* a real starting vector for inverse iteration using the real */
+/* eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI */
+/* must contain the real and imaginary parts of a complex */
+/* starting vector for inverse iteration using the complex */
+/* eigenvalue (WR,WI); otherwise VR and VI need not be set. */
+/* On exit, if WI = 0.0 (real eigenvalue), VR contains the */
+/* computed real eigenvector; if WI.ne.0.0 (complex eigenvalue), */
+/* VR and VI contain the real and imaginary parts of the */
+/* computed complex eigenvector. The eigenvector is normalized */
+/* so that the component of largest magnitude has magnitude 1; */
+/* here the magnitude of a complex number (x,y) is taken to be */
+/* |x| + |y|. */
+/* VI is not referenced if WI = 0.0. */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (LDB,N) */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= N+1. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* EPS3 (input) DOUBLE PRECISION */
+/* A small machine-dependent value which is used to perturb */
+/* close eigenvalues, and to replace zero pivots. */
+
+/* SMLNUM (input) DOUBLE PRECISION */
+/* A machine-dependent value close to the underflow threshold. */
+
+/* BIGNUM (input) DOUBLE PRECISION */
+/* A machine-dependent value close to the overflow threshold. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* = 1: inverse iteration did not converge; VR is set to the */
+/* last iterate, and so is VI if WI.ne.0.0. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --vr;
+ --vi;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* GROWTO is the threshold used in the acceptance test for an */
+/* eigenvector. */
+
+ rootn = sqrt((doublereal) (*n));
+ growto = .1 / rootn;
+/* Computing MAX */
+ d__1 = 1., d__2 = *eps3 * rootn;
+ nrmsml = max(d__1,d__2) * *smlnum;
+
+/* Form B = H - (WR,WI)*I (except that the subdiagonal elements and */
+/* the imaginary parts of the diagonal elements are not stored). */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = h__[i__ + j * h_dim1];
+/* L10: */
+ }
+ b[j + j * b_dim1] = h__[j + j * h_dim1] - *wr;
+/* L20: */
+ }
+
+ if (*wi == 0.) {
+
+/* Real eigenvalue. */
+
+ if (*noinit) {
+
+/* Set initial vector. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ vr[i__] = *eps3;
+/* L30: */
+ }
+ } else {
+
+/* Scale supplied initial vector. */
+
+ vnorm = dnrm2_(n, &vr[1], &c__1);
+ d__1 = *eps3 * rootn / max(vnorm,nrmsml);
+ dscal_(n, &d__1, &vr[1], &c__1);
+ }
+
+ if (*rightv) {
+
+/* LU decomposition with partial pivoting of B, replacing zero */
+/* pivots by EPS3. */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ei = h__[i__ + 1 + i__ * h_dim1];
+ if ((d__1 = b[i__ + i__ * b_dim1], abs(d__1)) < abs(ei)) {
+
+/* Interchange rows and eliminate. */
+
+ x = b[i__ + i__ * b_dim1] / ei;
+ b[i__ + i__ * b_dim1] = ei;
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ temp = b[i__ + 1 + j * b_dim1];
+ b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - x *
+ temp;
+ b[i__ + j * b_dim1] = temp;
+/* L40: */
+ }
+ } else {
+
+/* Eliminate without interchange. */
+
+ if (b[i__ + i__ * b_dim1] == 0.) {
+ b[i__ + i__ * b_dim1] = *eps3;
+ }
+ x = ei / b[i__ + i__ * b_dim1];
+ if (x != 0.) {
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ b[i__ + 1 + j * b_dim1] -= x * b[i__ + j * b_dim1]
+ ;
+/* L50: */
+ }
+ }
+ }
+/* L60: */
+ }
+ if (b[*n + *n * b_dim1] == 0.) {
+ b[*n + *n * b_dim1] = *eps3;
+ }
+
+ *(unsigned char *)trans = 'N';
+
+ } else {
+
+/* UL decomposition with partial pivoting of B, replacing zero */
+/* pivots by EPS3. */
+
+ for (j = *n; j >= 2; --j) {
+ ej = h__[j + (j - 1) * h_dim1];
+ if ((d__1 = b[j + j * b_dim1], abs(d__1)) < abs(ej)) {
+
+/* Interchange columns and eliminate. */
+
+ x = b[j + j * b_dim1] / ej;
+ b[j + j * b_dim1] = ej;
+ i__1 = j - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = b[i__ + (j - 1) * b_dim1];
+ b[i__ + (j - 1) * b_dim1] = b[i__ + j * b_dim1] - x *
+ temp;
+ b[i__ + j * b_dim1] = temp;
+/* L70: */
+ }
+ } else {
+
+/* Eliminate without interchange. */
+
+ if (b[j + j * b_dim1] == 0.) {
+ b[j + j * b_dim1] = *eps3;
+ }
+ x = ej / b[j + j * b_dim1];
+ if (x != 0.) {
+ i__1 = j - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ b[i__ + (j - 1) * b_dim1] -= x * b[i__ + j *
+ b_dim1];
+/* L80: */
+ }
+ }
+ }
+/* L90: */
+ }
+ if (b[b_dim1 + 1] == 0.) {
+ b[b_dim1 + 1] = *eps3;
+ }
+
+ *(unsigned char *)trans = 'T';
+
+ }
+
+ *(unsigned char *)normin = 'N';
+ i__1 = *n;
+ for (its = 1; its <= i__1; ++its) {
+
+/* Solve U*x = scale*v for a right eigenvector */
+/* or U'*x = scale*v for a left eigenvector, */
+/* overwriting x on v. */
+
+ dlatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, &
+ vr[1], &scale, &work[1], &ierr);
+ *(unsigned char *)normin = 'Y';
+
+/* Test for sufficient growth in the norm of v. */
+
+ vnorm = dasum_(n, &vr[1], &c__1);
+ if (vnorm >= growto * scale) {
+ goto L120;
+ }
+
+/* Choose new orthogonal starting vector and try again. */
+
+ temp = *eps3 / (rootn + 1.);
+ vr[1] = *eps3;
+ i__2 = *n;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ vr[i__] = temp;
+/* L100: */
+ }
+ vr[*n - its + 1] -= *eps3 * rootn;
+/* L110: */
+ }
+
+/* Failure to find eigenvector in N iterations. */
+
+ *info = 1;
+
+L120:
+
+/* Normalize eigenvector. */
+
+ i__ = idamax_(n, &vr[1], &c__1);
+ d__2 = 1. / (d__1 = vr[i__], abs(d__1));
+ dscal_(n, &d__2, &vr[1], &c__1);
+ } else {
+
+/* Complex eigenvalue. */
+
+ if (*noinit) {
+
+/* Set initial vector. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ vr[i__] = *eps3;
+ vi[i__] = 0.;
+/* L130: */
+ }
+ } else {
+
+/* Scale supplied initial vector. */
+
+ d__1 = dnrm2_(n, &vr[1], &c__1);
+ d__2 = dnrm2_(n, &vi[1], &c__1);
+ norm = dlapy2_(&d__1, &d__2);
+ rec = *eps3 * rootn / max(norm,nrmsml);
+ dscal_(n, &rec, &vr[1], &c__1);
+ dscal_(n, &rec, &vi[1], &c__1);
+ }
+
+ if (*rightv) {
+
+/* LU decomposition with partial pivoting of B, replacing zero */
+/* pivots by EPS3. */
+
+/* The imaginary part of the (i,j)-th element of U is stored in */
+/* B(j+1,i). */
+
+ b[b_dim1 + 2] = -(*wi);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ b[i__ + 1 + b_dim1] = 0.;
+/* L140: */
+ }
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ absbii = dlapy2_(&b[i__ + i__ * b_dim1], &b[i__ + 1 + i__ *
+ b_dim1]);
+ ei = h__[i__ + 1 + i__ * h_dim1];
+ if (absbii < abs(ei)) {
+
+/* Interchange rows and eliminate. */
+
+ xr = b[i__ + i__ * b_dim1] / ei;
+ xi = b[i__ + 1 + i__ * b_dim1] / ei;
+ b[i__ + i__ * b_dim1] = ei;
+ b[i__ + 1 + i__ * b_dim1] = 0.;
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ temp = b[i__ + 1 + j * b_dim1];
+ b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - xr *
+ temp;
+ b[j + 1 + (i__ + 1) * b_dim1] = b[j + 1 + i__ *
+ b_dim1] - xi * temp;
+ b[i__ + j * b_dim1] = temp;
+ b[j + 1 + i__ * b_dim1] = 0.;
+/* L150: */
+ }
+ b[i__ + 2 + i__ * b_dim1] = -(*wi);
+ b[i__ + 1 + (i__ + 1) * b_dim1] -= xi * *wi;
+ b[i__ + 2 + (i__ + 1) * b_dim1] += xr * *wi;
+ } else {
+
+/* Eliminate without interchanging rows. */
+
+ if (absbii == 0.) {
+ b[i__ + i__ * b_dim1] = *eps3;
+ b[i__ + 1 + i__ * b_dim1] = 0.;
+ absbii = *eps3;
+ }
+ ei = ei / absbii / absbii;
+ xr = b[i__ + i__ * b_dim1] * ei;
+ xi = -b[i__ + 1 + i__ * b_dim1] * ei;
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ b[i__ + 1 + j * b_dim1] = b[i__ + 1 + j * b_dim1] -
+ xr * b[i__ + j * b_dim1] + xi * b[j + 1 + i__
+ * b_dim1];
+ b[j + 1 + (i__ + 1) * b_dim1] = -xr * b[j + 1 + i__ *
+ b_dim1] - xi * b[i__ + j * b_dim1];
+/* L160: */
+ }
+ b[i__ + 2 + (i__ + 1) * b_dim1] -= *wi;
+ }
+
+/* Compute 1-norm of offdiagonal elements of i-th row. */
+
+ i__2 = *n - i__;
+ i__3 = *n - i__;
+ work[i__] = dasum_(&i__2, &b[i__ + (i__ + 1) * b_dim1], ldb)
+ + dasum_(&i__3, &b[i__ + 2 + i__ * b_dim1], &c__1);
+/* L170: */
+ }
+ if (b[*n + *n * b_dim1] == 0. && b[*n + 1 + *n * b_dim1] == 0.) {
+ b[*n + *n * b_dim1] = *eps3;
+ }
+ work[*n] = 0.;
+
+ i1 = *n;
+ i2 = 1;
+ i3 = -1;
+ } else {
+
+/* UL decomposition with partial pivoting of conjg(B), */
+/* replacing zero pivots by EPS3. */
+
+/* The imaginary part of the (i,j)-th element of U is stored in */
+/* B(j+1,i). */
+
+ b[*n + 1 + *n * b_dim1] = *wi;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ b[*n + 1 + j * b_dim1] = 0.;
+/* L180: */
+ }
+
+ for (j = *n; j >= 2; --j) {
+ ej = h__[j + (j - 1) * h_dim1];
+ absbjj = dlapy2_(&b[j + j * b_dim1], &b[j + 1 + j * b_dim1]);
+ if (absbjj < abs(ej)) {
+
+/* Interchange columns and eliminate */
+
+ xr = b[j + j * b_dim1] / ej;
+ xi = b[j + 1 + j * b_dim1] / ej;
+ b[j + j * b_dim1] = ej;
+ b[j + 1 + j * b_dim1] = 0.;
+ i__1 = j - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = b[i__ + (j - 1) * b_dim1];
+ b[i__ + (j - 1) * b_dim1] = b[i__ + j * b_dim1] - xr *
+ temp;
+ b[j + i__ * b_dim1] = b[j + 1 + i__ * b_dim1] - xi *
+ temp;
+ b[i__ + j * b_dim1] = temp;
+ b[j + 1 + i__ * b_dim1] = 0.;
+/* L190: */
+ }
+ b[j + 1 + (j - 1) * b_dim1] = *wi;
+ b[j - 1 + (j - 1) * b_dim1] += xi * *wi;
+ b[j + (j - 1) * b_dim1] -= xr * *wi;
+ } else {
+
+/* Eliminate without interchange. */
+
+ if (absbjj == 0.) {
+ b[j + j * b_dim1] = *eps3;
+ b[j + 1 + j * b_dim1] = 0.;
+ absbjj = *eps3;
+ }
+ ej = ej / absbjj / absbjj;
+ xr = b[j + j * b_dim1] * ej;
+ xi = -b[j + 1 + j * b_dim1] * ej;
+ i__1 = j - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ b[i__ + (j - 1) * b_dim1] = b[i__ + (j - 1) * b_dim1]
+ - xr * b[i__ + j * b_dim1] + xi * b[j + 1 +
+ i__ * b_dim1];
+ b[j + i__ * b_dim1] = -xr * b[j + 1 + i__ * b_dim1] -
+ xi * b[i__ + j * b_dim1];
+/* L200: */
+ }
+ b[j + (j - 1) * b_dim1] += *wi;
+ }
+
+/* Compute 1-norm of offdiagonal elements of j-th column. */
+
+ i__1 = j - 1;
+ i__2 = j - 1;
+ work[j] = dasum_(&i__1, &b[j * b_dim1 + 1], &c__1) + dasum_(&
+ i__2, &b[j + 1 + b_dim1], ldb);
+/* L210: */
+ }
+ if (b[b_dim1 + 1] == 0. && b[b_dim1 + 2] == 0.) {
+ b[b_dim1 + 1] = *eps3;
+ }
+ work[1] = 0.;
+
+ i1 = 1;
+ i2 = *n;
+ i3 = 1;
+ }
+
+ i__1 = *n;
+ for (its = 1; its <= i__1; ++its) {
+ scale = 1.;
+ vmax = 1.;
+ vcrit = *bignum;
+
+/* Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector, */
+/* or U'*(xr,xi) = scale*(vr,vi) for a left eigenvector, */
+/* overwriting (xr,xi) on (vr,vi). */
+
+ i__2 = i2;
+ i__3 = i3;
+ for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3)
+ {
+
+ if (work[i__] > vcrit) {
+ rec = 1. / vmax;
+ dscal_(n, &rec, &vr[1], &c__1);
+ dscal_(n, &rec, &vi[1], &c__1);
+ scale *= rec;
+ vmax = 1.;
+ vcrit = *bignum;
+ }
+
+ xr = vr[i__];
+ xi = vi[i__];
+ if (*rightv) {
+ i__4 = *n;
+ for (j = i__ + 1; j <= i__4; ++j) {
+ xr = xr - b[i__ + j * b_dim1] * vr[j] + b[j + 1 + i__
+ * b_dim1] * vi[j];
+ xi = xi - b[i__ + j * b_dim1] * vi[j] - b[j + 1 + i__
+ * b_dim1] * vr[j];
+/* L220: */
+ }
+ } else {
+ i__4 = i__ - 1;
+ for (j = 1; j <= i__4; ++j) {
+ xr = xr - b[j + i__ * b_dim1] * vr[j] + b[i__ + 1 + j
+ * b_dim1] * vi[j];
+ xi = xi - b[j + i__ * b_dim1] * vi[j] - b[i__ + 1 + j
+ * b_dim1] * vr[j];
+/* L230: */
+ }
+ }
+
+ w = (d__1 = b[i__ + i__ * b_dim1], abs(d__1)) + (d__2 = b[i__
+ + 1 + i__ * b_dim1], abs(d__2));
+ if (w > *smlnum) {
+ if (w < 1.) {
+ w1 = abs(xr) + abs(xi);
+ if (w1 > w * *bignum) {
+ rec = 1. / w1;
+ dscal_(n, &rec, &vr[1], &c__1);
+ dscal_(n, &rec, &vi[1], &c__1);
+ xr = vr[i__];
+ xi = vi[i__];
+ scale *= rec;
+ vmax *= rec;
+ }
+ }
+
+/* Divide by diagonal element of B. */
+
+ dladiv_(&xr, &xi, &b[i__ + i__ * b_dim1], &b[i__ + 1 +
+ i__ * b_dim1], &vr[i__], &vi[i__]);
+/* Computing MAX */
+ d__3 = (d__1 = vr[i__], abs(d__1)) + (d__2 = vi[i__], abs(
+ d__2));
+ vmax = max(d__3,vmax);
+ vcrit = *bignum / vmax;
+ } else {
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+ vr[j] = 0.;
+ vi[j] = 0.;
+/* L240: */
+ }
+ vr[i__] = 1.;
+ vi[i__] = 1.;
+ scale = 0.;
+ vmax = 1.;
+ vcrit = *bignum;
+ }
+/* L250: */
+ }
+
+/* Test for sufficient growth in the norm of (VR,VI). */
+
+ vnorm = dasum_(n, &vr[1], &c__1) + dasum_(n, &vi[1], &c__1);
+ if (vnorm >= growto * scale) {
+ goto L280;
+ }
+
+/* Choose a new orthogonal starting vector and try again. */
+
+ y = *eps3 / (rootn + 1.);
+ vr[1] = *eps3;
+ vi[1] = 0.;
+
+ i__3 = *n;
+ for (i__ = 2; i__ <= i__3; ++i__) {
+ vr[i__] = y;
+ vi[i__] = 0.;
+/* L260: */
+ }
+ vr[*n - its + 1] -= *eps3 * rootn;
+/* L270: */
+ }
+
+/* Failure to find eigenvector in N iterations */
+
+ *info = 1;
+
+L280:
+
+/* Normalize eigenvector. */
+
+ vnorm = 0.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__3 = vnorm, d__4 = (d__1 = vr[i__], abs(d__1)) + (d__2 = vi[i__]
+ , abs(d__2));
+ vnorm = max(d__3,d__4);
+/* L290: */
+ }
+ d__1 = 1. / vnorm;
+ dscal_(n, &d__1, &vr[1], &c__1);
+ d__1 = 1. / vnorm;
+ dscal_(n, &d__1, &vi[1], &c__1);
+
+ }
+
+ return 0;
+
+/* End of DLAEIN */
+
+} /* dlaein_ */
diff --git a/SRC/dlaev2.c b/SRC/dlaev2.c
new file mode 100644
index 0000000..6cd4c93
--- /dev/null
+++ b/SRC/dlaev2.c
@@ -0,0 +1,188 @@
+/* dlaev2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlaev2_(doublereal *a, doublereal *b, doublereal *c__,
+ doublereal *rt1, doublereal *rt2, doublereal *cs1, doublereal *sn1)
+{
+ /* System generated locals */
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal ab, df, cs, ct, tb, sm, tn, rt, adf, acs;
+ integer sgn1, sgn2;
+ doublereal acmn, acmx;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix */
+/* [ A B ] */
+/* [ B C ]. */
+/* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the */
+/* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right */
+/* eigenvector for RT1, giving the decomposition */
+
+/* [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] */
+/* [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. */
+
+/* Arguments */
+/* ========= */
+
+/* A (input) DOUBLE PRECISION */
+/* The (1,1) element of the 2-by-2 matrix. */
+
+/* B (input) DOUBLE PRECISION */
+/* The (1,2) element and the conjugate of the (2,1) element of */
+/* the 2-by-2 matrix. */
+
+/* C (input) DOUBLE PRECISION */
+/* The (2,2) element of the 2-by-2 matrix. */
+
+/* RT1 (output) DOUBLE PRECISION */
+/* The eigenvalue of larger absolute value. */
+
+/* RT2 (output) DOUBLE PRECISION */
+/* The eigenvalue of smaller absolute value. */
+
+/* CS1 (output) DOUBLE PRECISION */
+/* SN1 (output) DOUBLE PRECISION */
+/* The vector (CS1, SN1) is a unit right eigenvector for RT1. */
+
+/* Further Details */
+/* =============== */
+
+/* RT1 is accurate to a few ulps barring over/underflow. */
+
+/* RT2 may be inaccurate if there is massive cancellation in the */
+/* determinant A*C-B*B; higher precision or correctly rounded or */
+/* correctly truncated arithmetic would be needed to compute RT2 */
+/* accurately in all cases. */
+
+/* CS1 and SN1 are accurate to a few ulps barring over/underflow. */
+
+/* Overflow is possible only if RT1 is within a factor of 5 of overflow. */
+/* Underflow is harmless if the input data is 0 or exceeds */
+/* underflow_threshold / macheps. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Compute the eigenvalues */
+
+ sm = *a + *c__;
+ df = *a - *c__;
+ adf = abs(df);
+ tb = *b + *b;
+ ab = abs(tb);
+ if (abs(*a) > abs(*c__)) {
+ acmx = *a;
+ acmn = *c__;
+ } else {
+ acmx = *c__;
+ acmn = *a;
+ }
+ if (adf > ab) {
+/* Computing 2nd power */
+ d__1 = ab / adf;
+ rt = adf * sqrt(d__1 * d__1 + 1.);
+ } else if (adf < ab) {
+/* Computing 2nd power */
+ d__1 = adf / ab;
+ rt = ab * sqrt(d__1 * d__1 + 1.);
+ } else {
+
+/* Includes case AB=ADF=0 */
+
+ rt = ab * sqrt(2.);
+ }
+ if (sm < 0.) {
+ *rt1 = (sm - rt) * .5;
+ sgn1 = -1;
+
+/* Order of execution important. */
+/* To get fully accurate smaller eigenvalue, */
+/* next line needs to be executed in higher precision. */
+
+ *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
+ } else if (sm > 0.) {
+ *rt1 = (sm + rt) * .5;
+ sgn1 = 1;
+
+/* Order of execution important. */
+/* To get fully accurate smaller eigenvalue, */
+/* next line needs to be executed in higher precision. */
+
+ *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
+ } else {
+
+/* Includes case RT1 = RT2 = 0 */
+
+ *rt1 = rt * .5;
+ *rt2 = rt * -.5;
+ sgn1 = 1;
+ }
+
+/* Compute the eigenvector */
+
+ if (df >= 0.) {
+ cs = df + rt;
+ sgn2 = 1;
+ } else {
+ cs = df - rt;
+ sgn2 = -1;
+ }
+ acs = abs(cs);
+ if (acs > ab) {
+ ct = -tb / cs;
+ *sn1 = 1. / sqrt(ct * ct + 1.);
+ *cs1 = ct * *sn1;
+ } else {
+ if (ab == 0.) {
+ *cs1 = 1.;
+ *sn1 = 0.;
+ } else {
+ tn = -cs / tb;
+ *cs1 = 1. / sqrt(tn * tn + 1.);
+ *sn1 = tn * *cs1;
+ }
+ }
+ if (sgn1 == sgn2) {
+ tn = *cs1;
+ *cs1 = -(*sn1);
+ *sn1 = tn;
+ }
+ return 0;
+
+/* End of DLAEV2 */
+
+} /* dlaev2_ */
diff --git a/SRC/dlaexc.c b/SRC/dlaexc.c
new file mode 100644
index 0000000..03d6679
--- /dev/null
+++ b/SRC/dlaexc.c
@@ -0,0 +1,459 @@
+/* dlaexc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__4 = 4;
+static logical c_false = FALSE_;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+
+/* Subroutine */ int dlaexc_(logical *wantq, integer *n, doublereal *t,
+ integer *ldt, doublereal *q, integer *ldq, integer *j1, integer *n1,
+ integer *n2, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, t_dim1, t_offset, i__1;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ doublereal d__[16] /* was [4][4] */;
+ integer k;
+ doublereal u[3], x[4] /* was [2][2] */;
+ integer j2, j3, j4;
+ doublereal u1[3], u2[3];
+ integer nd;
+ doublereal cs, t11, t22, t33, sn, wi1, wi2, wr1, wr2, eps, tau, tau1,
+ tau2;
+ integer ierr;
+ doublereal temp;
+ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ doublereal scale, dnorm, xnorm;
+ extern /* Subroutine */ int dlanv2_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *), dlasy2_(
+ logical *, logical *, integer *, integer *, integer *, doublereal
+ *, integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *), dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *), dlarfx_(char *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *);
+ doublereal thresh, smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in */
+/* an upper quasi-triangular matrix T by an orthogonal similarity */
+/* transformation. */
+
+/* T must be in Schur canonical form, that is, block upper triangular */
+/* with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block */
+/* has its diagonal elemnts equal and its off-diagonal elements of */
+/* opposite sign. */
+
+/* Arguments */
+/* ========= */
+
+/* WANTQ (input) LOGICAL */
+/* = .TRUE. : accumulate the transformation in the matrix Q; */
+/* = .FALSE.: do not accumulate the transformation. */
+
+/* N (input) INTEGER */
+/* The order of the matrix T. N >= 0. */
+
+/* T (input/output) DOUBLE PRECISION array, dimension (LDT,N) */
+/* On entry, the upper quasi-triangular matrix T, in Schur */
+/* canonical form. */
+/* On exit, the updated matrix T, again in Schur canonical form. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= max(1,N). */
+
+/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */
+/* On entry, if WANTQ is .TRUE., the orthogonal matrix Q. */
+/* On exit, if WANTQ is .TRUE., the updated matrix Q. */
+/* If WANTQ is .FALSE., Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. */
+/* LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N. */
+
+/* J1 (input) INTEGER */
+/* The index of the first row of the first block T11. */
+
+/* N1 (input) INTEGER */
+/* The order of the first block T11. N1 = 0, 1 or 2. */
+
+/* N2 (input) INTEGER */
+/* The order of the second block T22. N2 = 0, 1 or 2. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* = 1: the transformed matrix T would be too far from Schur */
+/* form; the blocks are not swapped and T and Q are */
+/* unchanged. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n == 0 || *n1 == 0 || *n2 == 0) {
+ return 0;
+ }
+ if (*j1 + *n1 > *n) {
+ return 0;
+ }
+
+ j2 = *j1 + 1;
+ j3 = *j1 + 2;
+ j4 = *j1 + 3;
+
+ if (*n1 == 1 && *n2 == 1) {
+
+/* Swap two 1-by-1 blocks. */
+
+ t11 = t[*j1 + *j1 * t_dim1];
+ t22 = t[j2 + j2 * t_dim1];
+
+/* Determine the transformation to perform the interchange. */
+
+ d__1 = t22 - t11;
+ dlartg_(&t[*j1 + j2 * t_dim1], &d__1, &cs, &sn, &temp);
+
+/* Apply transformation to the matrix T. */
+
+ if (j3 <= *n) {
+ i__1 = *n - *j1 - 1;
+ drot_(&i__1, &t[*j1 + j3 * t_dim1], ldt, &t[j2 + j3 * t_dim1],
+ ldt, &cs, &sn);
+ }
+ i__1 = *j1 - 1;
+ drot_(&i__1, &t[*j1 * t_dim1 + 1], &c__1, &t[j2 * t_dim1 + 1], &c__1,
+ &cs, &sn);
+
+ t[*j1 + *j1 * t_dim1] = t22;
+ t[j2 + j2 * t_dim1] = t11;
+
+ if (*wantq) {
+
+/* Accumulate transformation in the matrix Q. */
+
+ drot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[j2 * q_dim1 + 1], &c__1,
+ &cs, &sn);
+ }
+
+ } else {
+
+/* Swapping involves at least one 2-by-2 block. */
+
+/* Copy the diagonal block of order N1+N2 to the local array D */
+/* and compute its norm. */
+
+ nd = *n1 + *n2;
+ dlacpy_("Full", &nd, &nd, &t[*j1 + *j1 * t_dim1], ldt, d__, &c__4);
+ dnorm = dlange_("Max", &nd, &nd, d__, &c__4, &work[1]);
+
+/* Compute machine-dependent threshold for test for accepting */
+/* swap. */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S") / eps;
+/* Computing MAX */
+ d__1 = eps * 10. * dnorm;
+ thresh = max(d__1,smlnum);
+
+/* Solve T11*X - X*T22 = scale*T12 for X. */
+
+ dlasy2_(&c_false, &c_false, &c_n1, n1, n2, d__, &c__4, &d__[*n1 + 1 +
+ (*n1 + 1 << 2) - 5], &c__4, &d__[(*n1 + 1 << 2) - 4], &c__4, &
+ scale, x, &c__2, &xnorm, &ierr);
+
+/* Swap the adjacent diagonal blocks. */
+
+ k = *n1 + *n1 + *n2 - 3;
+ switch (k) {
+ case 1: goto L10;
+ case 2: goto L20;
+ case 3: goto L30;
+ }
+
+L10:
+
+/* N1 = 1, N2 = 2: generate elementary reflector H so that: */
+
+/* ( scale, X11, X12 ) H = ( 0, 0, * ) */
+
+ u[0] = scale;
+ u[1] = x[0];
+ u[2] = x[2];
+ dlarfg_(&c__3, &u[2], u, &c__1, &tau);
+ u[2] = 1.;
+ t11 = t[*j1 + *j1 * t_dim1];
+
+/* Perform swap provisionally on diagonal block in D. */
+
+ dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
+ dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
+
+/* Test whether to reject swap. */
+
+/* Computing MAX */
+ d__2 = abs(d__[2]), d__3 = abs(d__[6]), d__2 = max(d__2,d__3), d__3 =
+ (d__1 = d__[10] - t11, abs(d__1));
+ if (max(d__2,d__3) > thresh) {
+ goto L50;
+ }
+
+/* Accept swap: apply transformation to the entire matrix T. */
+
+ i__1 = *n - *j1 + 1;
+ dlarfx_("L", &c__3, &i__1, u, &tau, &t[*j1 + *j1 * t_dim1], ldt, &
+ work[1]);
+ dlarfx_("R", &j2, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1]);
+
+ t[j3 + *j1 * t_dim1] = 0.;
+ t[j3 + j2 * t_dim1] = 0.;
+ t[j3 + j3 * t_dim1] = t11;
+
+ if (*wantq) {
+
+/* Accumulate transformation in the matrix Q. */
+
+ dlarfx_("R", n, &c__3, u, &tau, &q[*j1 * q_dim1 + 1], ldq, &work[
+ 1]);
+ }
+ goto L40;
+
+L20:
+
+/* N1 = 2, N2 = 1: generate elementary reflector H so that: */
+
+/* H ( -X11 ) = ( * ) */
+/* ( -X21 ) = ( 0 ) */
+/* ( scale ) = ( 0 ) */
+
+ u[0] = -x[0];
+ u[1] = -x[1];
+ u[2] = scale;
+ dlarfg_(&c__3, u, &u[1], &c__1, &tau);
+ u[0] = 1.;
+ t33 = t[j3 + j3 * t_dim1];
+
+/* Perform swap provisionally on diagonal block in D. */
+
+ dlarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
+ dlarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
+
+/* Test whether to reject swap. */
+
+/* Computing MAX */
+ d__2 = abs(d__[1]), d__3 = abs(d__[2]), d__2 = max(d__2,d__3), d__3 =
+ (d__1 = d__[0] - t33, abs(d__1));
+ if (max(d__2,d__3) > thresh) {
+ goto L50;
+ }
+
+/* Accept swap: apply transformation to the entire matrix T. */
+
+ dlarfx_("R", &j3, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1]);
+ i__1 = *n - *j1;
+ dlarfx_("L", &c__3, &i__1, u, &tau, &t[*j1 + j2 * t_dim1], ldt, &work[
+ 1]);
+
+ t[*j1 + *j1 * t_dim1] = t33;
+ t[j2 + *j1 * t_dim1] = 0.;
+ t[j3 + *j1 * t_dim1] = 0.;
+
+ if (*wantq) {
+
+/* Accumulate transformation in the matrix Q. */
+
+ dlarfx_("R", n, &c__3, u, &tau, &q[*j1 * q_dim1 + 1], ldq, &work[
+ 1]);
+ }
+ goto L40;
+
+L30:
+
+/* N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so */
+/* that: */
+
+/* H(2) H(1) ( -X11 -X12 ) = ( * * ) */
+/* ( -X21 -X22 ) ( 0 * ) */
+/* ( scale 0 ) ( 0 0 ) */
+/* ( 0 scale ) ( 0 0 ) */
+
+ u1[0] = -x[0];
+ u1[1] = -x[1];
+ u1[2] = scale;
+ dlarfg_(&c__3, u1, &u1[1], &c__1, &tau1);
+ u1[0] = 1.;
+
+ temp = -tau1 * (x[2] + u1[1] * x[3]);
+ u2[0] = -temp * u1[1] - x[3];
+ u2[1] = -temp * u1[2];
+ u2[2] = scale;
+ dlarfg_(&c__3, u2, &u2[1], &c__1, &tau2);
+ u2[0] = 1.;
+
+/* Perform swap provisionally on diagonal block in D. */
+
+ dlarfx_("L", &c__3, &c__4, u1, &tau1, d__, &c__4, &work[1])
+ ;
+ dlarfx_("R", &c__4, &c__3, u1, &tau1, d__, &c__4, &work[1])
+ ;
+ dlarfx_("L", &c__3, &c__4, u2, &tau2, &d__[1], &c__4, &work[1]);
+ dlarfx_("R", &c__4, &c__3, u2, &tau2, &d__[4], &c__4, &work[1]);
+
+/* Test whether to reject swap. */
+
+/* Computing MAX */
+ d__1 = abs(d__[2]), d__2 = abs(d__[6]), d__1 = max(d__1,d__2), d__2 =
+ abs(d__[3]), d__1 = max(d__1,d__2), d__2 = abs(d__[7]);
+ if (max(d__1,d__2) > thresh) {
+ goto L50;
+ }
+
+/* Accept swap: apply transformation to the entire matrix T. */
+
+ i__1 = *n - *j1 + 1;
+ dlarfx_("L", &c__3, &i__1, u1, &tau1, &t[*j1 + *j1 * t_dim1], ldt, &
+ work[1]);
+ dlarfx_("R", &j4, &c__3, u1, &tau1, &t[*j1 * t_dim1 + 1], ldt, &work[
+ 1]);
+ i__1 = *n - *j1 + 1;
+ dlarfx_("L", &c__3, &i__1, u2, &tau2, &t[j2 + *j1 * t_dim1], ldt, &
+ work[1]);
+ dlarfx_("R", &j4, &c__3, u2, &tau2, &t[j2 * t_dim1 + 1], ldt, &work[1]
+);
+
+ t[j3 + *j1 * t_dim1] = 0.;
+ t[j3 + j2 * t_dim1] = 0.;
+ t[j4 + *j1 * t_dim1] = 0.;
+ t[j4 + j2 * t_dim1] = 0.;
+
+ if (*wantq) {
+
+/* Accumulate transformation in the matrix Q. */
+
+ dlarfx_("R", n, &c__3, u1, &tau1, &q[*j1 * q_dim1 + 1], ldq, &
+ work[1]);
+ dlarfx_("R", n, &c__3, u2, &tau2, &q[j2 * q_dim1 + 1], ldq, &work[
+ 1]);
+ }
+
+L40:
+
+ if (*n2 == 2) {
+
+/* Standardize new 2-by-2 block T11 */
+
+ dlanv2_(&t[*j1 + *j1 * t_dim1], &t[*j1 + j2 * t_dim1], &t[j2 + *
+ j1 * t_dim1], &t[j2 + j2 * t_dim1], &wr1, &wi1, &wr2, &
+ wi2, &cs, &sn);
+ i__1 = *n - *j1 - 1;
+ drot_(&i__1, &t[*j1 + (*j1 + 2) * t_dim1], ldt, &t[j2 + (*j1 + 2)
+ * t_dim1], ldt, &cs, &sn);
+ i__1 = *j1 - 1;
+ drot_(&i__1, &t[*j1 * t_dim1 + 1], &c__1, &t[j2 * t_dim1 + 1], &
+ c__1, &cs, &sn);
+ if (*wantq) {
+ drot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[j2 * q_dim1 + 1], &
+ c__1, &cs, &sn);
+ }
+ }
+
+ if (*n1 == 2) {
+
+/* Standardize new 2-by-2 block T22 */
+
+ j3 = *j1 + *n2;
+ j4 = j3 + 1;
+ dlanv2_(&t[j3 + j3 * t_dim1], &t[j3 + j4 * t_dim1], &t[j4 + j3 *
+ t_dim1], &t[j4 + j4 * t_dim1], &wr1, &wi1, &wr2, &wi2, &
+ cs, &sn);
+ if (j3 + 2 <= *n) {
+ i__1 = *n - j3 - 1;
+ drot_(&i__1, &t[j3 + (j3 + 2) * t_dim1], ldt, &t[j4 + (j3 + 2)
+ * t_dim1], ldt, &cs, &sn);
+ }
+ i__1 = j3 - 1;
+ drot_(&i__1, &t[j3 * t_dim1 + 1], &c__1, &t[j4 * t_dim1 + 1], &
+ c__1, &cs, &sn);
+ if (*wantq) {
+ drot_(n, &q[j3 * q_dim1 + 1], &c__1, &q[j4 * q_dim1 + 1], &
+ c__1, &cs, &sn);
+ }
+ }
+
+ }
+ return 0;
+
+/* Exit with INFO = 1 if swap was rejected. */
+
+L50:
+ *info = 1;
+ return 0;
+
+/* End of DLAEXC */
+
+} /* dlaexc_ */
diff --git a/SRC/dlag2.c b/SRC/dlag2.c
new file mode 100644
index 0000000..ecbc749
--- /dev/null
+++ b/SRC/dlag2.c
@@ -0,0 +1,356 @@
+/* dlag2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlag2_(doublereal *a, integer *lda, doublereal *b,
+ integer *ldb, doublereal *safmin, doublereal *scale1, doublereal *
+ scale2, doublereal *wr1, doublereal *wr2, doublereal *wi)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ doublereal r__, c1, c2, c3, c4, c5, s1, s2, a11, a12, a21, a22, b11, b12,
+ b22, pp, qq, ss, as11, as12, as22, sum, abi22, diff, bmin, wbig,
+ wabs, wdet, binv11, binv22, discr, anorm, bnorm, bsize, shift,
+ rtmin, rtmax, wsize, ascale, bscale, wscale, safmax, wsmall;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue */
+/* problem A - w B, with scaling as necessary to avoid over-/underflow. */
+
+/* The scaling factor "s" results in a modified eigenvalue equation */
+
+/* s A - w B */
+
+/* where s is a non-negative scaling factor chosen so that w, w B, */
+/* and s A do not overflow and, if possible, do not underflow, either. */
+
+/* Arguments */
+/* ========= */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA, 2) */
+/* On entry, the 2 x 2 matrix A. It is assumed that its 1-norm */
+/* is less than 1/SAFMIN. Entries less than */
+/* sqrt(SAFMIN)*norm(A) are subject to being treated as zero. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= 2. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB, 2) */
+/* On entry, the 2 x 2 upper triangular matrix B. It is */
+/* assumed that the one-norm of B is less than 1/SAFMIN. The */
+/* diagonals should be at least sqrt(SAFMIN) times the largest */
+/* element of B (in absolute value); if a diagonal is smaller */
+/* than that, then +/- sqrt(SAFMIN) will be used instead of */
+/* that diagonal. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= 2. */
+
+/* SAFMIN (input) DOUBLE PRECISION */
+/* The smallest positive number s.t. 1/SAFMIN does not */
+/* overflow. (This should always be DLAMCH('S') -- it is an */
+/* argument in order to avoid having to call DLAMCH frequently.) */
+
+/* SCALE1 (output) DOUBLE PRECISION */
+/* A scaling factor used to avoid over-/underflow in the */
+/* eigenvalue equation which defines the first eigenvalue. If */
+/* the eigenvalues are complex, then the eigenvalues are */
+/* ( WR1 +/- WI i ) / SCALE1 (which may lie outside the */
+/* exponent range of the machine), SCALE1=SCALE2, and SCALE1 */
+/* will always be positive. If the eigenvalues are real, then */
+/* the first (real) eigenvalue is WR1 / SCALE1 , but this may */
+/* overflow or underflow, and in fact, SCALE1 may be zero or */
+/* less than the underflow threshhold if the exact eigenvalue */
+/* is sufficiently large. */
+
+/* SCALE2 (output) DOUBLE PRECISION */
+/* A scaling factor used to avoid over-/underflow in the */
+/* eigenvalue equation which defines the second eigenvalue. If */
+/* the eigenvalues are complex, then SCALE2=SCALE1. If the */
+/* eigenvalues are real, then the second (real) eigenvalue is */
+/* WR2 / SCALE2 , but this may overflow or underflow, and in */
+/* fact, SCALE2 may be zero or less than the underflow */
+/* threshhold if the exact eigenvalue is sufficiently large. */
+
+/* WR1 (output) DOUBLE PRECISION */
+/* If the eigenvalue is real, then WR1 is SCALE1 times the */
+/* eigenvalue closest to the (2,2) element of A B**(-1). If the */
+/* eigenvalue is complex, then WR1=WR2 is SCALE1 times the real */
+/* part of the eigenvalues. */
+
+/* WR2 (output) DOUBLE PRECISION */
+/* If the eigenvalue is real, then WR2 is SCALE2 times the */
+/* other eigenvalue. If the eigenvalue is complex, then */
+/* WR1=WR2 is SCALE1 times the real part of the eigenvalues. */
+
+/* WI (output) DOUBLE PRECISION */
+/* If the eigenvalue is real, then WI is zero. If the */
+/* eigenvalue is complex, then WI is SCALE1 times the imaginary */
+/* part of the eigenvalues. WI will always be non-negative. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ rtmin = sqrt(*safmin);
+ rtmax = 1. / rtmin;
+ safmax = 1. / *safmin;
+
+/* Scale A */
+
+/* Computing MAX */
+ d__5 = (d__1 = a[a_dim1 + 1], abs(d__1)) + (d__2 = a[a_dim1 + 2], abs(
+ d__2)), d__6 = (d__3 = a[(a_dim1 << 1) + 1], abs(d__3)) + (d__4 =
+ a[(a_dim1 << 1) + 2], abs(d__4)), d__5 = max(d__5,d__6);
+ anorm = max(d__5,*safmin);
+ ascale = 1. / anorm;
+ a11 = ascale * a[a_dim1 + 1];
+ a21 = ascale * a[a_dim1 + 2];
+ a12 = ascale * a[(a_dim1 << 1) + 1];
+ a22 = ascale * a[(a_dim1 << 1) + 2];
+
+/* Perturb B if necessary to insure non-singularity */
+
+ b11 = b[b_dim1 + 1];
+ b12 = b[(b_dim1 << 1) + 1];
+ b22 = b[(b_dim1 << 1) + 2];
+/* Computing MAX */
+ d__1 = abs(b11), d__2 = abs(b12), d__1 = max(d__1,d__2), d__2 = abs(b22),
+ d__1 = max(d__1,d__2);
+ bmin = rtmin * max(d__1,rtmin);
+ if (abs(b11) < bmin) {
+ b11 = d_sign(&bmin, &b11);
+ }
+ if (abs(b22) < bmin) {
+ b22 = d_sign(&bmin, &b22);
+ }
+
+/* Scale B */
+
+/* Computing MAX */
+ d__1 = abs(b11), d__2 = abs(b12) + abs(b22), d__1 = max(d__1,d__2);
+ bnorm = max(d__1,*safmin);
+/* Computing MAX */
+ d__1 = abs(b11), d__2 = abs(b22);
+ bsize = max(d__1,d__2);
+ bscale = 1. / bsize;
+ b11 *= bscale;
+ b12 *= bscale;
+ b22 *= bscale;
+
+/* Compute larger eigenvalue by method described by C. van Loan */
+
+/* ( AS is A shifted by -SHIFT*B ) */
+
+ binv11 = 1. / b11;
+ binv22 = 1. / b22;
+ s1 = a11 * binv11;
+ s2 = a22 * binv22;
+ if (abs(s1) <= abs(s2)) {
+ as12 = a12 - s1 * b12;
+ as22 = a22 - s1 * b22;
+ ss = a21 * (binv11 * binv22);
+ abi22 = as22 * binv22 - ss * b12;
+ pp = abi22 * .5;
+ shift = s1;
+ } else {
+ as12 = a12 - s2 * b12;
+ as11 = a11 - s2 * b11;
+ ss = a21 * (binv11 * binv22);
+ abi22 = -ss * b12;
+ pp = (as11 * binv11 + abi22) * .5;
+ shift = s2;
+ }
+ qq = ss * as12;
+ if ((d__1 = pp * rtmin, abs(d__1)) >= 1.) {
+/* Computing 2nd power */
+ d__1 = rtmin * pp;
+ discr = d__1 * d__1 + qq * *safmin;
+ r__ = sqrt((abs(discr))) * rtmax;
+ } else {
+/* Computing 2nd power */
+ d__1 = pp;
+ if (d__1 * d__1 + abs(qq) <= *safmin) {
+/* Computing 2nd power */
+ d__1 = rtmax * pp;
+ discr = d__1 * d__1 + qq * safmax;
+ r__ = sqrt((abs(discr))) * rtmin;
+ } else {
+/* Computing 2nd power */
+ d__1 = pp;
+ discr = d__1 * d__1 + qq;
+ r__ = sqrt((abs(discr)));
+ }
+ }
+
+/* Note: the test of R in the following IF is to cover the case when */
+/* DISCR is small and negative and is flushed to zero during */
+/* the calculation of R. On machines which have a consistent */
+/* flush-to-zero threshhold and handle numbers above that */
+/* threshhold correctly, it would not be necessary. */
+
+ if (discr >= 0. || r__ == 0.) {
+ sum = pp + d_sign(&r__, &pp);
+ diff = pp - d_sign(&r__, &pp);
+ wbig = shift + sum;
+
+/* Compute smaller eigenvalue */
+
+ wsmall = shift + diff;
+/* Computing MAX */
+ d__1 = abs(wsmall);
+ if (abs(wbig) * .5 > max(d__1,*safmin)) {
+ wdet = (a11 * a22 - a12 * a21) * (binv11 * binv22);
+ wsmall = wdet / wbig;
+ }
+
+/* Choose (real) eigenvalue closest to 2,2 element of A*B**(-1) */
+/* for WR1. */
+
+ if (pp > abi22) {
+ *wr1 = min(wbig,wsmall);
+ *wr2 = max(wbig,wsmall);
+ } else {
+ *wr1 = max(wbig,wsmall);
+ *wr2 = min(wbig,wsmall);
+ }
+ *wi = 0.;
+ } else {
+
+/* Complex eigenvalues */
+
+ *wr1 = shift + pp;
+ *wr2 = *wr1;
+ *wi = r__;
+ }
+
+/* Further scaling to avoid underflow and overflow in computing */
+/* SCALE1 and overflow in computing w*B. */
+
+/* This scale factor (WSCALE) is bounded from above using C1 and C2, */
+/* and from below using C3 and C4. */
+/* C1 implements the condition s A must never overflow. */
+/* C2 implements the condition w B must never overflow. */
+/* C3, with C2, */
+/* implement the condition that s A - w B must never overflow. */
+/* C4 implements the condition s should not underflow. */
+/* C5 implements the condition max(s,|w|) should be at least 2. */
+
+ c1 = bsize * (*safmin * max(1.,ascale));
+ c2 = *safmin * max(1.,bnorm);
+ c3 = bsize * *safmin;
+ if (ascale <= 1. && bsize <= 1.) {
+/* Computing MIN */
+ d__1 = 1., d__2 = ascale / *safmin * bsize;
+ c4 = min(d__1,d__2);
+ } else {
+ c4 = 1.;
+ }
+ if (ascale <= 1. || bsize <= 1.) {
+/* Computing MIN */
+ d__1 = 1., d__2 = ascale * bsize;
+ c5 = min(d__1,d__2);
+ } else {
+ c5 = 1.;
+ }
+
+/* Scale first eigenvalue */
+
+ wabs = abs(*wr1) + abs(*wi);
+/* Computing MAX */
+/* Computing MIN */
+ d__3 = c4, d__4 = max(wabs,c5) * .5;
+ d__1 = max(*safmin,c1), d__2 = (wabs * c2 + c3) * 1.0000100000000001,
+ d__1 = max(d__1,d__2), d__2 = min(d__3,d__4);
+ wsize = max(d__1,d__2);
+ if (wsize != 1.) {
+ wscale = 1. / wsize;
+ if (wsize > 1.) {
+ *scale1 = max(ascale,bsize) * wscale * min(ascale,bsize);
+ } else {
+ *scale1 = min(ascale,bsize) * wscale * max(ascale,bsize);
+ }
+ *wr1 *= wscale;
+ if (*wi != 0.) {
+ *wi *= wscale;
+ *wr2 = *wr1;
+ *scale2 = *scale1;
+ }
+ } else {
+ *scale1 = ascale * bsize;
+ *scale2 = *scale1;
+ }
+
+/* Scale second eigenvalue (if real) */
+
+ if (*wi == 0.) {
+/* Computing MAX */
+/* Computing MIN */
+/* Computing MAX */
+ d__5 = abs(*wr2);
+ d__3 = c4, d__4 = max(d__5,c5) * .5;
+ d__1 = max(*safmin,c1), d__2 = (abs(*wr2) * c2 + c3) *
+ 1.0000100000000001, d__1 = max(d__1,d__2), d__2 = min(d__3,
+ d__4);
+ wsize = max(d__1,d__2);
+ if (wsize != 1.) {
+ wscale = 1. / wsize;
+ if (wsize > 1.) {
+ *scale2 = max(ascale,bsize) * wscale * min(ascale,bsize);
+ } else {
+ *scale2 = min(ascale,bsize) * wscale * max(ascale,bsize);
+ }
+ *wr2 *= wscale;
+ } else {
+ *scale2 = ascale * bsize;
+ }
+ }
+
+/* End of DLAG2 */
+
+ return 0;
+} /* dlag2_ */
diff --git a/SRC/dlag2s.c b/SRC/dlag2s.c
new file mode 100644
index 0000000..bdc68fc
--- /dev/null
+++ b/SRC/dlag2s.c
@@ -0,0 +1,115 @@
+/* dlag2s.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlag2s_(integer *m, integer *n, doublereal *a, integer *
+ lda, real *sa, integer *ldsa, integer *info)
+{
+ /* System generated locals */
+ integer sa_dim1, sa_offset, a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal rmax;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK PROTOTYPE auxiliary routine (version 3.1.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* August 2007 */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAG2S converts a DOUBLE PRECISION matrix, SA, to a SINGLE */
+/* PRECISION matrix, A. */
+
+/* RMAX is the overflow for the SINGLE PRECISION arithmetic */
+/* DLAG2S checks that all the entries of A are between -RMAX and */
+/* RMAX. If not the convertion is aborted and a flag is raised. */
+
+/* This is an auxiliary routine so there is no argument checking. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of lines of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N coefficient matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* SA (output) REAL array, dimension (LDSA,N) */
+/* On exit, if INFO=0, the M-by-N coefficient matrix SA; if */
+/* INFO>0, the content of SA is unspecified. */
+
+/* LDSA (input) INTEGER */
+/* The leading dimension of the array SA. LDSA >= max(1,M). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* = 1: an entry of the matrix A is greater than the SINGLE */
+/* PRECISION overflow threshold, in this case, the content */
+/* of SA in exit is unspecified. */
+
+/* ========= */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ sa_dim1 = *ldsa;
+ sa_offset = 1 + sa_dim1;
+ sa -= sa_offset;
+
+ /* Function Body */
+ rmax = slamch_("O");
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (a[i__ + j * a_dim1] < -rmax || a[i__ + j * a_dim1] > rmax) {
+ *info = 1;
+ goto L30;
+ }
+ sa[i__ + j * sa_dim1] = a[i__ + j * a_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+ *info = 0;
+L30:
+ return 0;
+
+/* End of DLAG2S */
+
+} /* dlag2s_ */
diff --git a/SRC/dlags2.c b/SRC/dlags2.c
new file mode 100644
index 0000000..4fb02ff
--- /dev/null
+++ b/SRC/dlags2.c
@@ -0,0 +1,292 @@
+/* dlags2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlags2_(logical *upper, doublereal *a1, doublereal *a2,
+ doublereal *a3, doublereal *b1, doublereal *b2, doublereal *b3,
+ doublereal *csu, doublereal *snu, doublereal *csv, doublereal *snv,
+ doublereal *csq, doublereal *snq)
+{
+ /* System generated locals */
+ doublereal d__1;
+
+ /* Local variables */
+ doublereal a, b, c__, d__, r__, s1, s2, ua11, ua12, ua21, ua22, vb11,
+ vb12, vb21, vb22, csl, csr, snl, snr, aua11, aua12, aua21, aua22,
+ avb11, avb12, avb21, avb22, ua11r, ua22r, vb11r, vb22r;
+ extern /* Subroutine */ int dlasv2_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *), dlartg_(doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such */
+/* that if ( UPPER ) then */
+
+/* U'*A*Q = U'*( A1 A2 )*Q = ( x 0 ) */
+/* ( 0 A3 ) ( x x ) */
+/* and */
+/* V'*B*Q = V'*( B1 B2 )*Q = ( x 0 ) */
+/* ( 0 B3 ) ( x x ) */
+
+/* or if ( .NOT.UPPER ) then */
+
+/* U'*A*Q = U'*( A1 0 )*Q = ( x x ) */
+/* ( A2 A3 ) ( 0 x ) */
+/* and */
+/* V'*B*Q = V'*( B1 0 )*Q = ( x x ) */
+/* ( B2 B3 ) ( 0 x ) */
+
+/* The rows of the transformed A and B are parallel, where */
+
+/* U = ( CSU SNU ), V = ( CSV SNV ), Q = ( CSQ SNQ ) */
+/* ( -SNU CSU ) ( -SNV CSV ) ( -SNQ CSQ ) */
+
+/* Z' denotes the transpose of Z. */
+
+
+/* Arguments */
+/* ========= */
+
+/* UPPER (input) LOGICAL */
+/* = .TRUE.: the input matrices A and B are upper triangular. */
+/* = .FALSE.: the input matrices A and B are lower triangular. */
+
+/* A1 (input) DOUBLE PRECISION */
+/* A2 (input) DOUBLE PRECISION */
+/* A3 (input) DOUBLE PRECISION */
+/* On entry, A1, A2 and A3 are elements of the input 2-by-2 */
+/* upper (lower) triangular matrix A. */
+
+/* B1 (input) DOUBLE PRECISION */
+/* B2 (input) DOUBLE PRECISION */
+/* B3 (input) DOUBLE PRECISION */
+/* On entry, B1, B2 and B3 are elements of the input 2-by-2 */
+/* upper (lower) triangular matrix B. */
+
+/* CSU (output) DOUBLE PRECISION */
+/* SNU (output) DOUBLE PRECISION */
+/* The desired orthogonal matrix U. */
+
+/* CSV (output) DOUBLE PRECISION */
+/* SNV (output) DOUBLE PRECISION */
+/* The desired orthogonal matrix V. */
+
+/* CSQ (output) DOUBLE PRECISION */
+/* SNQ (output) DOUBLE PRECISION */
+/* The desired orthogonal matrix Q. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (*upper) {
+
+/* Input matrices A and B are upper triangular matrices */
+
+/* Form matrix C = A*adj(B) = ( a b ) */
+/* ( 0 d ) */
+
+ a = *a1 * *b3;
+ d__ = *a3 * *b1;
+ b = *a2 * *b1 - *a1 * *b2;
+
+/* The SVD of real 2-by-2 triangular C */
+
+/* ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 ) */
+/* ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T ) */
+
+ dlasv2_(&a, &b, &d__, &s1, &s2, &snr, &csr, &snl, &csl);
+
+ if (abs(csl) >= abs(snl) || abs(csr) >= abs(snr)) {
+
+/* Compute the (1,1) and (1,2) elements of U'*A and V'*B, */
+/* and (1,2) element of |U|'*|A| and |V|'*|B|. */
+
+ ua11r = csl * *a1;
+ ua12 = csl * *a2 + snl * *a3;
+
+ vb11r = csr * *b1;
+ vb12 = csr * *b2 + snr * *b3;
+
+ aua12 = abs(csl) * abs(*a2) + abs(snl) * abs(*a3);
+ avb12 = abs(csr) * abs(*b2) + abs(snr) * abs(*b3);
+
+/* zero (1,2) elements of U'*A and V'*B */
+
+ if (abs(ua11r) + abs(ua12) != 0.) {
+ if (aua12 / (abs(ua11r) + abs(ua12)) <= avb12 / (abs(vb11r) +
+ abs(vb12))) {
+ d__1 = -ua11r;
+ dlartg_(&d__1, &ua12, csq, snq, &r__);
+ } else {
+ d__1 = -vb11r;
+ dlartg_(&d__1, &vb12, csq, snq, &r__);
+ }
+ } else {
+ d__1 = -vb11r;
+ dlartg_(&d__1, &vb12, csq, snq, &r__);
+ }
+
+ *csu = csl;
+ *snu = -snl;
+ *csv = csr;
+ *snv = -snr;
+
+ } else {
+
+/* Compute the (2,1) and (2,2) elements of U'*A and V'*B, */
+/* and (2,2) element of |U|'*|A| and |V|'*|B|. */
+
+ ua21 = -snl * *a1;
+ ua22 = -snl * *a2 + csl * *a3;
+
+ vb21 = -snr * *b1;
+ vb22 = -snr * *b2 + csr * *b3;
+
+ aua22 = abs(snl) * abs(*a2) + abs(csl) * abs(*a3);
+ avb22 = abs(snr) * abs(*b2) + abs(csr) * abs(*b3);
+
+/* zero (2,2) elements of U'*A and V'*B, and then swap. */
+
+ if (abs(ua21) + abs(ua22) != 0.) {
+ if (aua22 / (abs(ua21) + abs(ua22)) <= avb22 / (abs(vb21) +
+ abs(vb22))) {
+ d__1 = -ua21;
+ dlartg_(&d__1, &ua22, csq, snq, &r__);
+ } else {
+ d__1 = -vb21;
+ dlartg_(&d__1, &vb22, csq, snq, &r__);
+ }
+ } else {
+ d__1 = -vb21;
+ dlartg_(&d__1, &vb22, csq, snq, &r__);
+ }
+
+ *csu = snl;
+ *snu = csl;
+ *csv = snr;
+ *snv = csr;
+
+ }
+
+ } else {
+
+/* Input matrices A and B are lower triangular matrices */
+
+/* Form matrix C = A*adj(B) = ( a 0 ) */
+/* ( c d ) */
+
+ a = *a1 * *b3;
+ d__ = *a3 * *b1;
+ c__ = *a2 * *b3 - *a3 * *b2;
+
+/* The SVD of real 2-by-2 triangular C */
+
+/* ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 ) */
+/* ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T ) */
+
+ dlasv2_(&a, &c__, &d__, &s1, &s2, &snr, &csr, &snl, &csl);
+
+ if (abs(csr) >= abs(snr) || abs(csl) >= abs(snl)) {
+
+/* Compute the (2,1) and (2,2) elements of U'*A and V'*B, */
+/* and (2,1) element of |U|'*|A| and |V|'*|B|. */
+
+ ua21 = -snr * *a1 + csr * *a2;
+ ua22r = csr * *a3;
+
+ vb21 = -snl * *b1 + csl * *b2;
+ vb22r = csl * *b3;
+
+ aua21 = abs(snr) * abs(*a1) + abs(csr) * abs(*a2);
+ avb21 = abs(snl) * abs(*b1) + abs(csl) * abs(*b2);
+
+/* zero (2,1) elements of U'*A and V'*B. */
+
+ if (abs(ua21) + abs(ua22r) != 0.) {
+ if (aua21 / (abs(ua21) + abs(ua22r)) <= avb21 / (abs(vb21) +
+ abs(vb22r))) {
+ dlartg_(&ua22r, &ua21, csq, snq, &r__);
+ } else {
+ dlartg_(&vb22r, &vb21, csq, snq, &r__);
+ }
+ } else {
+ dlartg_(&vb22r, &vb21, csq, snq, &r__);
+ }
+
+ *csu = csr;
+ *snu = -snr;
+ *csv = csl;
+ *snv = -snl;
+
+ } else {
+
+/* Compute the (1,1) and (1,2) elements of U'*A and V'*B, */
+/* and (1,1) element of |U|'*|A| and |V|'*|B|. */
+
+ ua11 = csr * *a1 + snr * *a2;
+ ua12 = snr * *a3;
+
+ vb11 = csl * *b1 + snl * *b2;
+ vb12 = snl * *b3;
+
+ aua11 = abs(csr) * abs(*a1) + abs(snr) * abs(*a2);
+ avb11 = abs(csl) * abs(*b1) + abs(snl) * abs(*b2);
+
+/* zero (1,1) elements of U'*A and V'*B, and then swap. */
+
+ if (abs(ua11) + abs(ua12) != 0.) {
+ if (aua11 / (abs(ua11) + abs(ua12)) <= avb11 / (abs(vb11) +
+ abs(vb12))) {
+ dlartg_(&ua12, &ua11, csq, snq, &r__);
+ } else {
+ dlartg_(&vb12, &vb11, csq, snq, &r__);
+ }
+ } else {
+ dlartg_(&vb12, &vb11, csq, snq, &r__);
+ }
+
+ *csu = snr;
+ *snu = csr;
+ *csv = snl;
+ *snv = csl;
+
+ }
+
+ }
+
+ return 0;
+
+/* End of DLAGS2 */
+
+} /* dlags2_ */
diff --git a/SRC/dlagtf.c b/SRC/dlagtf.c
new file mode 100644
index 0000000..533f53d
--- /dev/null
+++ b/SRC/dlagtf.c
@@ -0,0 +1,224 @@
+/* dlagtf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlagtf_(integer *n, doublereal *a, doublereal *lambda,
+ doublereal *b, doublereal *c__, doublereal *tol, doublereal *d__,
+ integer *in, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer k;
+ doublereal tl, eps, piv1, piv2, temp, mult, scale1, scale2;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAGTF factorizes the matrix (T - lambda*I), where T is an n by n */
+/* tridiagonal matrix and lambda is a scalar, as */
+
+/* T - lambda*I = PLU, */
+
+/* where P is a permutation matrix, L is a unit lower tridiagonal matrix */
+/* with at most one non-zero sub-diagonal elements per column and U is */
+/* an upper triangular matrix with at most two non-zero super-diagonal */
+/* elements per column. */
+
+/* The factorization is obtained by Gaussian elimination with partial */
+/* pivoting and implicit row scaling. */
+
+/* The parameter LAMBDA is included in the routine so that DLAGTF may */
+/* be used, in conjunction with DLAGTS, to obtain eigenvectors of T by */
+/* inverse iteration. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix T. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, A must contain the diagonal elements of T. */
+
+/* On exit, A is overwritten by the n diagonal elements of the */
+/* upper triangular matrix U of the factorization of T. */
+
+/* LAMBDA (input) DOUBLE PRECISION */
+/* On entry, the scalar lambda. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* On entry, B must contain the (n-1) super-diagonal elements of */
+/* T. */
+
+/* On exit, B is overwritten by the (n-1) super-diagonal */
+/* elements of the matrix U of the factorization of T. */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* On entry, C must contain the (n-1) sub-diagonal elements of */
+/* T. */
+
+/* On exit, C is overwritten by the (n-1) sub-diagonal elements */
+/* of the matrix L of the factorization of T. */
+
+/* TOL (input) DOUBLE PRECISION */
+/* On entry, a relative tolerance used to indicate whether or */
+/* not the matrix (T - lambda*I) is nearly singular. TOL should */
+/* normally be chose as approximately the largest relative error */
+/* in the elements of T. For example, if the elements of T are */
+/* correct to about 4 significant figures, then TOL should be */
+/* set to about 5*10**(-4). If TOL is supplied as less than eps, */
+/* where eps is the relative machine precision, then the value */
+/* eps is used in place of TOL. */
+
+/* D (output) DOUBLE PRECISION array, dimension (N-2) */
+/* On exit, D is overwritten by the (n-2) second super-diagonal */
+/* elements of the matrix U of the factorization of T. */
+
+/* IN (output) INTEGER array, dimension (N) */
+/* On exit, IN contains details of the permutation matrix P. If */
+/* an interchange occurred at the kth step of the elimination, */
+/* then IN(k) = 1, otherwise IN(k) = 0. The element IN(n) */
+/* returns the smallest positive integer j such that */
+
+/* abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL, */
+
+/* where norm( A(j) ) denotes the sum of the absolute values of */
+/* the jth row of the matrix A. If no such j exists then IN(n) */
+/* is returned as zero. If IN(n) is returned as positive, then a */
+/* diagonal element of U is small, indicating that */
+/* (T - lambda*I) is singular or nearly singular, */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit */
+/* .lt. 0: if INFO = -k, the kth argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --in;
+ --d__;
+ --c__;
+ --b;
+ --a;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ i__1 = -(*info);
+ xerbla_("DLAGTF", &i__1);
+ return 0;
+ }
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ a[1] -= *lambda;
+ in[*n] = 0;
+ if (*n == 1) {
+ if (a[1] == 0.) {
+ in[1] = 1;
+ }
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+
+ tl = max(*tol,eps);
+ scale1 = abs(a[1]) + abs(b[1]);
+ i__1 = *n - 1;
+ for (k = 1; k <= i__1; ++k) {
+ a[k + 1] -= *lambda;
+ scale2 = (d__1 = c__[k], abs(d__1)) + (d__2 = a[k + 1], abs(d__2));
+ if (k < *n - 1) {
+ scale2 += (d__1 = b[k + 1], abs(d__1));
+ }
+ if (a[k] == 0.) {
+ piv1 = 0.;
+ } else {
+ piv1 = (d__1 = a[k], abs(d__1)) / scale1;
+ }
+ if (c__[k] == 0.) {
+ in[k] = 0;
+ piv2 = 0.;
+ scale1 = scale2;
+ if (k < *n - 1) {
+ d__[k] = 0.;
+ }
+ } else {
+ piv2 = (d__1 = c__[k], abs(d__1)) / scale2;
+ if (piv2 <= piv1) {
+ in[k] = 0;
+ scale1 = scale2;
+ c__[k] /= a[k];
+ a[k + 1] -= c__[k] * b[k];
+ if (k < *n - 1) {
+ d__[k] = 0.;
+ }
+ } else {
+ in[k] = 1;
+ mult = a[k] / c__[k];
+ a[k] = c__[k];
+ temp = a[k + 1];
+ a[k + 1] = b[k] - mult * temp;
+ if (k < *n - 1) {
+ d__[k] = b[k + 1];
+ b[k + 1] = -mult * d__[k];
+ }
+ b[k] = temp;
+ c__[k] = mult;
+ }
+ }
+ if (max(piv1,piv2) <= tl && in[*n] == 0) {
+ in[*n] = k;
+ }
+/* L10: */
+ }
+ if ((d__1 = a[*n], abs(d__1)) <= scale1 * tl && in[*n] == 0) {
+ in[*n] = *n;
+ }
+
+ return 0;
+
+/* End of DLAGTF */
+
+} /* dlagtf_ */
diff --git a/SRC/dlagtm.c b/SRC/dlagtm.c
new file mode 100644
index 0000000..4cd9226
--- /dev/null
+++ b/SRC/dlagtm.c
@@ -0,0 +1,254 @@
+/* dlagtm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlagtm_(char *trans, integer *n, integer *nrhs,
+ doublereal *alpha, doublereal *dl, doublereal *d__, doublereal *du,
+ doublereal *x, integer *ldx, doublereal *beta, doublereal *b, integer
+ *ldb)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ extern logical lsame_(char *, char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAGTM performs a matrix-vector product of the form */
+
+/* B := alpha * A * X + beta * B */
+
+/* where A is a tridiagonal matrix of order N, B and X are N by NRHS */
+/* matrices, and alpha and beta are real scalars, each of which may be */
+/* 0., 1., or -1. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': No transpose, B := alpha * A * X + beta * B */
+/* = 'T': Transpose, B := alpha * A'* X + beta * B */
+/* = 'C': Conjugate transpose = Transpose */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. */
+
+/* ALPHA (input) DOUBLE PRECISION */
+/* The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise, */
+/* it is assumed to be 0. */
+
+/* DL (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) sub-diagonal elements of T. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal elements of T. */
+
+/* DU (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) super-diagonal elements of T. */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The N by NRHS matrix X. */
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(N,1). */
+
+/* BETA (input) DOUBLE PRECISION */
+/* The scalar beta. BETA must be 0., 1., or -1.; otherwise, */
+/* it is assumed to be 1. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the N by NRHS matrix B. */
+/* On exit, B is overwritten by the matrix expression */
+/* B := alpha * A * X + beta * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(N,1). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Multiply B by BETA if BETA.NE.1. */
+
+ if (*beta == 0.) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (*beta == -1.) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = -b[i__ + j * b_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+ if (*alpha == 1.) {
+ if (lsame_(trans, "N")) {
+
+/* Compute B := B + A*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ b[j * b_dim1 + 1] += d__[1] * x[j * x_dim1 + 1];
+ } else {
+ b[j * b_dim1 + 1] = b[j * b_dim1 + 1] + d__[1] * x[j *
+ x_dim1 + 1] + du[1] * x[j * x_dim1 + 2];
+ b[*n + j * b_dim1] = b[*n + j * b_dim1] + dl[*n - 1] * x[*
+ n - 1 + j * x_dim1] + d__[*n] * x[*n + j * x_dim1]
+ ;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = b[i__ + j * b_dim1] + dl[i__ -
+ 1] * x[i__ - 1 + j * x_dim1] + d__[i__] * x[
+ i__ + j * x_dim1] + du[i__] * x[i__ + 1 + j *
+ x_dim1];
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else {
+
+/* Compute B := B + A'*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ b[j * b_dim1 + 1] += d__[1] * x[j * x_dim1 + 1];
+ } else {
+ b[j * b_dim1 + 1] = b[j * b_dim1 + 1] + d__[1] * x[j *
+ x_dim1 + 1] + dl[1] * x[j * x_dim1 + 2];
+ b[*n + j * b_dim1] = b[*n + j * b_dim1] + du[*n - 1] * x[*
+ n - 1 + j * x_dim1] + d__[*n] * x[*n + j * x_dim1]
+ ;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = b[i__ + j * b_dim1] + du[i__ -
+ 1] * x[i__ - 1 + j * x_dim1] + d__[i__] * x[
+ i__ + j * x_dim1] + dl[i__] * x[i__ + 1 + j *
+ x_dim1];
+/* L70: */
+ }
+ }
+/* L80: */
+ }
+ }
+ } else if (*alpha == -1.) {
+ if (lsame_(trans, "N")) {
+
+/* Compute B := B - A*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ b[j * b_dim1 + 1] -= d__[1] * x[j * x_dim1 + 1];
+ } else {
+ b[j * b_dim1 + 1] = b[j * b_dim1 + 1] - d__[1] * x[j *
+ x_dim1 + 1] - du[1] * x[j * x_dim1 + 2];
+ b[*n + j * b_dim1] = b[*n + j * b_dim1] - dl[*n - 1] * x[*
+ n - 1 + j * x_dim1] - d__[*n] * x[*n + j * x_dim1]
+ ;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = b[i__ + j * b_dim1] - dl[i__ -
+ 1] * x[i__ - 1 + j * x_dim1] - d__[i__] * x[
+ i__ + j * x_dim1] - du[i__] * x[i__ + 1 + j *
+ x_dim1];
+/* L90: */
+ }
+ }
+/* L100: */
+ }
+ } else {
+
+/* Compute B := B - A'*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ b[j * b_dim1 + 1] -= d__[1] * x[j * x_dim1 + 1];
+ } else {
+ b[j * b_dim1 + 1] = b[j * b_dim1 + 1] - d__[1] * x[j *
+ x_dim1 + 1] - dl[1] * x[j * x_dim1 + 2];
+ b[*n + j * b_dim1] = b[*n + j * b_dim1] - du[*n - 1] * x[*
+ n - 1 + j * x_dim1] - d__[*n] * x[*n + j * x_dim1]
+ ;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = b[i__ + j * b_dim1] - du[i__ -
+ 1] * x[i__ - 1 + j * x_dim1] - d__[i__] * x[
+ i__ + j * x_dim1] - dl[i__] * x[i__ + 1 + j *
+ x_dim1];
+/* L110: */
+ }
+ }
+/* L120: */
+ }
+ }
+ }
+ return 0;
+
+/* End of DLAGTM */
+
+} /* dlagtm_ */
diff --git a/SRC/dlagts.c b/SRC/dlagts.c
new file mode 100644
index 0000000..91e1ba1
--- /dev/null
+++ b/SRC/dlagts.c
@@ -0,0 +1,351 @@
+/* dlagts.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlagts_(integer *job, integer *n, doublereal *a,
+ doublereal *b, doublereal *c__, doublereal *d__, integer *in,
+ doublereal *y, doublereal *tol, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2, d__3, d__4, d__5;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer k;
+ doublereal ak, eps, temp, pert, absak, sfmin;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAGTS may be used to solve one of the systems of equations */
+
+/* (T - lambda*I)*x = y or (T - lambda*I)'*x = y, */
+
+/* where T is an n by n tridiagonal matrix, for x, following the */
+/* factorization of (T - lambda*I) as */
+
+/* (T - lambda*I) = P*L*U , */
+
+/* by routine DLAGTF. The choice of equation to be solved is */
+/* controlled by the argument JOB, and in each case there is an option */
+/* to perturb zero or very small diagonal elements of U, this option */
+/* being intended for use in applications such as inverse iteration. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) INTEGER */
+/* Specifies the job to be performed by DLAGTS as follows: */
+/* = 1: The equations (T - lambda*I)x = y are to be solved, */
+/* but diagonal elements of U are not to be perturbed. */
+/* = -1: The equations (T - lambda*I)x = y are to be solved */
+/* and, if overflow would otherwise occur, the diagonal */
+/* elements of U are to be perturbed. See argument TOL */
+/* below. */
+/* = 2: The equations (T - lambda*I)'x = y are to be solved, */
+/* but diagonal elements of U are not to be perturbed. */
+/* = -2: The equations (T - lambda*I)'x = y are to be solved */
+/* and, if overflow would otherwise occur, the diagonal */
+/* elements of U are to be perturbed. See argument TOL */
+/* below. */
+
+/* N (input) INTEGER */
+/* The order of the matrix T. */
+
+/* A (input) DOUBLE PRECISION array, dimension (N) */
+/* On entry, A must contain the diagonal elements of U as */
+/* returned from DLAGTF. */
+
+/* B (input) DOUBLE PRECISION array, dimension (N-1) */
+/* On entry, B must contain the first super-diagonal elements of */
+/* U as returned from DLAGTF. */
+
+/* C (input) DOUBLE PRECISION array, dimension (N-1) */
+/* On entry, C must contain the sub-diagonal elements of L as */
+/* returned from DLAGTF. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N-2) */
+/* On entry, D must contain the second super-diagonal elements */
+/* of U as returned from DLAGTF. */
+
+/* IN (input) INTEGER array, dimension (N) */
+/* On entry, IN must contain details of the matrix P as returned */
+/* from DLAGTF. */
+
+/* Y (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the right hand side vector y. */
+/* On exit, Y is overwritten by the solution vector x. */
+
+/* TOL (input/output) DOUBLE PRECISION */
+/* On entry, with JOB .lt. 0, TOL should be the minimum */
+/* perturbation to be made to very small diagonal elements of U. */
+/* TOL should normally be chosen as about eps*norm(U), where eps */
+/* is the relative machine precision, but if TOL is supplied as */
+/* non-positive, then it is reset to eps*max( abs( u(i,j) ) ). */
+/* If JOB .gt. 0 then TOL is not referenced. */
+
+/* On exit, TOL is changed as described above, only if TOL is */
+/* non-positive on entry. Otherwise TOL is unchanged. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit */
+/* .lt. 0: if INFO = -i, the i-th argument had an illegal value */
+/* .gt. 0: overflow would occur when computing the INFO(th) */
+/* element of the solution vector x. This can only occur */
+/* when JOB is supplied as positive and either means */
+/* that a diagonal element of U is very small, or that */
+/* the elements of the right-hand side vector y are very */
+/* large. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --y;
+ --in;
+ --d__;
+ --c__;
+ --b;
+ --a;
+
+ /* Function Body */
+ *info = 0;
+ if (abs(*job) > 2 || *job == 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLAGTS", &i__1);
+ return 0;
+ }
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+ sfmin = dlamch_("Safe minimum");
+ bignum = 1. / sfmin;
+
+ if (*job < 0) {
+ if (*tol <= 0.) {
+ *tol = abs(a[1]);
+ if (*n > 1) {
+/* Computing MAX */
+ d__1 = *tol, d__2 = abs(a[2]), d__1 = max(d__1,d__2), d__2 =
+ abs(b[1]);
+ *tol = max(d__1,d__2);
+ }
+ i__1 = *n;
+ for (k = 3; k <= i__1; ++k) {
+/* Computing MAX */
+ d__4 = *tol, d__5 = (d__1 = a[k], abs(d__1)), d__4 = max(d__4,
+ d__5), d__5 = (d__2 = b[k - 1], abs(d__2)), d__4 =
+ max(d__4,d__5), d__5 = (d__3 = d__[k - 2], abs(d__3));
+ *tol = max(d__4,d__5);
+/* L10: */
+ }
+ *tol *= eps;
+ if (*tol == 0.) {
+ *tol = eps;
+ }
+ }
+ }
+
+ if (abs(*job) == 1) {
+ i__1 = *n;
+ for (k = 2; k <= i__1; ++k) {
+ if (in[k - 1] == 0) {
+ y[k] -= c__[k - 1] * y[k - 1];
+ } else {
+ temp = y[k - 1];
+ y[k - 1] = y[k];
+ y[k] = temp - c__[k - 1] * y[k];
+ }
+/* L20: */
+ }
+ if (*job == 1) {
+ for (k = *n; k >= 1; --k) {
+ if (k <= *n - 2) {
+ temp = y[k] - b[k] * y[k + 1] - d__[k] * y[k + 2];
+ } else if (k == *n - 1) {
+ temp = y[k] - b[k] * y[k + 1];
+ } else {
+ temp = y[k];
+ }
+ ak = a[k];
+ absak = abs(ak);
+ if (absak < 1.) {
+ if (absak < sfmin) {
+ if (absak == 0. || abs(temp) * sfmin > absak) {
+ *info = k;
+ return 0;
+ } else {
+ temp *= bignum;
+ ak *= bignum;
+ }
+ } else if (abs(temp) > absak * bignum) {
+ *info = k;
+ return 0;
+ }
+ }
+ y[k] = temp / ak;
+/* L30: */
+ }
+ } else {
+ for (k = *n; k >= 1; --k) {
+ if (k <= *n - 2) {
+ temp = y[k] - b[k] * y[k + 1] - d__[k] * y[k + 2];
+ } else if (k == *n - 1) {
+ temp = y[k] - b[k] * y[k + 1];
+ } else {
+ temp = y[k];
+ }
+ ak = a[k];
+ pert = d_sign(tol, &ak);
+L40:
+ absak = abs(ak);
+ if (absak < 1.) {
+ if (absak < sfmin) {
+ if (absak == 0. || abs(temp) * sfmin > absak) {
+ ak += pert;
+ pert *= 2;
+ goto L40;
+ } else {
+ temp *= bignum;
+ ak *= bignum;
+ }
+ } else if (abs(temp) > absak * bignum) {
+ ak += pert;
+ pert *= 2;
+ goto L40;
+ }
+ }
+ y[k] = temp / ak;
+/* L50: */
+ }
+ }
+ } else {
+
+/* Come to here if JOB = 2 or -2 */
+
+ if (*job == 2) {
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (k >= 3) {
+ temp = y[k] - b[k - 1] * y[k - 1] - d__[k - 2] * y[k - 2];
+ } else if (k == 2) {
+ temp = y[k] - b[k - 1] * y[k - 1];
+ } else {
+ temp = y[k];
+ }
+ ak = a[k];
+ absak = abs(ak);
+ if (absak < 1.) {
+ if (absak < sfmin) {
+ if (absak == 0. || abs(temp) * sfmin > absak) {
+ *info = k;
+ return 0;
+ } else {
+ temp *= bignum;
+ ak *= bignum;
+ }
+ } else if (abs(temp) > absak * bignum) {
+ *info = k;
+ return 0;
+ }
+ }
+ y[k] = temp / ak;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (k >= 3) {
+ temp = y[k] - b[k - 1] * y[k - 1] - d__[k - 2] * y[k - 2];
+ } else if (k == 2) {
+ temp = y[k] - b[k - 1] * y[k - 1];
+ } else {
+ temp = y[k];
+ }
+ ak = a[k];
+ pert = d_sign(tol, &ak);
+L70:
+ absak = abs(ak);
+ if (absak < 1.) {
+ if (absak < sfmin) {
+ if (absak == 0. || abs(temp) * sfmin > absak) {
+ ak += pert;
+ pert *= 2;
+ goto L70;
+ } else {
+ temp *= bignum;
+ ak *= bignum;
+ }
+ } else if (abs(temp) > absak * bignum) {
+ ak += pert;
+ pert *= 2;
+ goto L70;
+ }
+ }
+ y[k] = temp / ak;
+/* L80: */
+ }
+ }
+
+ for (k = *n; k >= 2; --k) {
+ if (in[k - 1] == 0) {
+ y[k - 1] -= c__[k - 1] * y[k];
+ } else {
+ temp = y[k - 1];
+ y[k - 1] = y[k];
+ y[k] = temp - c__[k - 1] * y[k];
+ }
+/* L90: */
+ }
+ }
+
+/* End of DLAGTS */
+
+ return 0;
+} /* dlagts_ */
diff --git a/SRC/dlagv2.c b/SRC/dlagv2.c
new file mode 100644
index 0000000..634a888
--- /dev/null
+++ b/SRC/dlagv2.c
@@ -0,0 +1,351 @@
+/* dlagv2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* Subroutine */ int dlagv2_(doublereal *a, integer *lda, doublereal *b,
+ integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *
+ beta, doublereal *csl, doublereal *snl, doublereal *csr, doublereal *
+ snr)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6;
+
+ /* Local variables */
+ doublereal r__, t, h1, h2, h3, wi, qq, rr, wr1, wr2, ulp;
+ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *), dlag2_(
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *);
+ doublereal anorm, bnorm, scale1, scale2;
+ extern /* Subroutine */ int dlasv2_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *);
+ extern doublereal dlapy2_(doublereal *, doublereal *);
+ doublereal ascale, bscale;
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAGV2 computes the Generalized Schur factorization of a real 2-by-2 */
+/* matrix pencil (A,B) where B is upper triangular. This routine */
+/* computes orthogonal (rotation) matrices given by CSL, SNL and CSR, */
+/* SNR such that */
+
+/* 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0 */
+/* types), then */
+
+/* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] */
+/* [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] */
+
+/* [ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ] */
+/* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ], */
+
+/* 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues, */
+/* then */
+
+/* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] */
+/* [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] */
+
+/* [ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ] */
+/* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ] */
+
+/* where b11 >= b22 > 0. */
+
+
+/* Arguments */
+/* ========= */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA, 2) */
+/* On entry, the 2 x 2 matrix A. */
+/* On exit, A is overwritten by the ``A-part'' of the */
+/* generalized Schur form. */
+
+/* LDA (input) INTEGER */
+/* THe leading dimension of the array A. LDA >= 2. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB, 2) */
+/* On entry, the upper triangular 2 x 2 matrix B. */
+/* On exit, B is overwritten by the ``B-part'' of the */
+/* generalized Schur form. */
+
+/* LDB (input) INTEGER */
+/* THe leading dimension of the array B. LDB >= 2. */
+
+/* ALPHAR (output) DOUBLE PRECISION array, dimension (2) */
+/* ALPHAI (output) DOUBLE PRECISION array, dimension (2) */
+/* BETA (output) DOUBLE PRECISION array, dimension (2) */
+/* (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the */
+/* pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may */
+/* be zero. */
+
+/* CSL (output) DOUBLE PRECISION */
+/* The cosine of the left rotation matrix. */
+
+/* SNL (output) DOUBLE PRECISION */
+/* The sine of the left rotation matrix. */
+
+/* CSR (output) DOUBLE PRECISION */
+/* The cosine of the right rotation matrix. */
+
+/* SNR (output) DOUBLE PRECISION */
+/* The sine of the right rotation matrix. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alphar;
+ --alphai;
+ --beta;
+
+ /* Function Body */
+ safmin = dlamch_("S");
+ ulp = dlamch_("P");
+
+/* Scale A */
+
+/* Computing MAX */
+ d__5 = (d__1 = a[a_dim1 + 1], abs(d__1)) + (d__2 = a[a_dim1 + 2], abs(
+ d__2)), d__6 = (d__3 = a[(a_dim1 << 1) + 1], abs(d__3)) + (d__4 =
+ a[(a_dim1 << 1) + 2], abs(d__4)), d__5 = max(d__5,d__6);
+ anorm = max(d__5,safmin);
+ ascale = 1. / anorm;
+ a[a_dim1 + 1] = ascale * a[a_dim1 + 1];
+ a[(a_dim1 << 1) + 1] = ascale * a[(a_dim1 << 1) + 1];
+ a[a_dim1 + 2] = ascale * a[a_dim1 + 2];
+ a[(a_dim1 << 1) + 2] = ascale * a[(a_dim1 << 1) + 2];
+
+/* Scale B */
+
+/* Computing MAX */
+ d__4 = (d__3 = b[b_dim1 + 1], abs(d__3)), d__5 = (d__1 = b[(b_dim1 << 1)
+ + 1], abs(d__1)) + (d__2 = b[(b_dim1 << 1) + 2], abs(d__2)), d__4
+ = max(d__4,d__5);
+ bnorm = max(d__4,safmin);
+ bscale = 1. / bnorm;
+ b[b_dim1 + 1] = bscale * b[b_dim1 + 1];
+ b[(b_dim1 << 1) + 1] = bscale * b[(b_dim1 << 1) + 1];
+ b[(b_dim1 << 1) + 2] = bscale * b[(b_dim1 << 1) + 2];
+
+/* Check if A can be deflated */
+
+ if ((d__1 = a[a_dim1 + 2], abs(d__1)) <= ulp) {
+ *csl = 1.;
+ *snl = 0.;
+ *csr = 1.;
+ *snr = 0.;
+ a[a_dim1 + 2] = 0.;
+ b[b_dim1 + 2] = 0.;
+
+/* Check if B is singular */
+
+ } else if ((d__1 = b[b_dim1 + 1], abs(d__1)) <= ulp) {
+ dlartg_(&a[a_dim1 + 1], &a[a_dim1 + 2], csl, snl, &r__);
+ *csr = 1.;
+ *snr = 0.;
+ drot_(&c__2, &a[a_dim1 + 1], lda, &a[a_dim1 + 2], lda, csl, snl);
+ drot_(&c__2, &b[b_dim1 + 1], ldb, &b[b_dim1 + 2], ldb, csl, snl);
+ a[a_dim1 + 2] = 0.;
+ b[b_dim1 + 1] = 0.;
+ b[b_dim1 + 2] = 0.;
+
+ } else if ((d__1 = b[(b_dim1 << 1) + 2], abs(d__1)) <= ulp) {
+ dlartg_(&a[(a_dim1 << 1) + 2], &a[a_dim1 + 2], csr, snr, &t);
+ *snr = -(*snr);
+ drot_(&c__2, &a[a_dim1 + 1], &c__1, &a[(a_dim1 << 1) + 1], &c__1, csr,
+ snr);
+ drot_(&c__2, &b[b_dim1 + 1], &c__1, &b[(b_dim1 << 1) + 1], &c__1, csr,
+ snr);
+ *csl = 1.;
+ *snl = 0.;
+ a[a_dim1 + 2] = 0.;
+ b[b_dim1 + 2] = 0.;
+ b[(b_dim1 << 1) + 2] = 0.;
+
+ } else {
+
+/* B is nonsingular, first compute the eigenvalues of (A,B) */
+
+ dlag2_(&a[a_offset], lda, &b[b_offset], ldb, &safmin, &scale1, &
+ scale2, &wr1, &wr2, &wi);
+
+ if (wi == 0.) {
+
+/* two real eigenvalues, compute s*A-w*B */
+
+ h1 = scale1 * a[a_dim1 + 1] - wr1 * b[b_dim1 + 1];
+ h2 = scale1 * a[(a_dim1 << 1) + 1] - wr1 * b[(b_dim1 << 1) + 1];
+ h3 = scale1 * a[(a_dim1 << 1) + 2] - wr1 * b[(b_dim1 << 1) + 2];
+
+ rr = dlapy2_(&h1, &h2);
+ d__1 = scale1 * a[a_dim1 + 2];
+ qq = dlapy2_(&d__1, &h3);
+
+ if (rr > qq) {
+
+/* find right rotation matrix to zero 1,1 element of */
+/* (sA - wB) */
+
+ dlartg_(&h2, &h1, csr, snr, &t);
+
+ } else {
+
+/* find right rotation matrix to zero 2,1 element of */
+/* (sA - wB) */
+
+ d__1 = scale1 * a[a_dim1 + 2];
+ dlartg_(&h3, &d__1, csr, snr, &t);
+
+ }
+
+ *snr = -(*snr);
+ drot_(&c__2, &a[a_dim1 + 1], &c__1, &a[(a_dim1 << 1) + 1], &c__1,
+ csr, snr);
+ drot_(&c__2, &b[b_dim1 + 1], &c__1, &b[(b_dim1 << 1) + 1], &c__1,
+ csr, snr);
+
+/* compute inf norms of A and B */
+
+/* Computing MAX */
+ d__5 = (d__1 = a[a_dim1 + 1], abs(d__1)) + (d__2 = a[(a_dim1 << 1)
+ + 1], abs(d__2)), d__6 = (d__3 = a[a_dim1 + 2], abs(d__3)
+ ) + (d__4 = a[(a_dim1 << 1) + 2], abs(d__4));
+ h1 = max(d__5,d__6);
+/* Computing MAX */
+ d__5 = (d__1 = b[b_dim1 + 1], abs(d__1)) + (d__2 = b[(b_dim1 << 1)
+ + 1], abs(d__2)), d__6 = (d__3 = b[b_dim1 + 2], abs(d__3)
+ ) + (d__4 = b[(b_dim1 << 1) + 2], abs(d__4));
+ h2 = max(d__5,d__6);
+
+ if (scale1 * h1 >= abs(wr1) * h2) {
+
+/* find left rotation matrix Q to zero out B(2,1) */
+
+ dlartg_(&b[b_dim1 + 1], &b[b_dim1 + 2], csl, snl, &r__);
+
+ } else {
+
+/* find left rotation matrix Q to zero out A(2,1) */
+
+ dlartg_(&a[a_dim1 + 1], &a[a_dim1 + 2], csl, snl, &r__);
+
+ }
+
+ drot_(&c__2, &a[a_dim1 + 1], lda, &a[a_dim1 + 2], lda, csl, snl);
+ drot_(&c__2, &b[b_dim1 + 1], ldb, &b[b_dim1 + 2], ldb, csl, snl);
+
+ a[a_dim1 + 2] = 0.;
+ b[b_dim1 + 2] = 0.;
+
+ } else {
+
+/* a pair of complex conjugate eigenvalues */
+/* first compute the SVD of the matrix B */
+
+ dlasv2_(&b[b_dim1 + 1], &b[(b_dim1 << 1) + 1], &b[(b_dim1 << 1) +
+ 2], &r__, &t, snr, csr, snl, csl);
+
+/* Form (A,B) := Q(A,B)Z' where Q is left rotation matrix and */
+/* Z is right rotation matrix computed from DLASV2 */
+
+ drot_(&c__2, &a[a_dim1 + 1], lda, &a[a_dim1 + 2], lda, csl, snl);
+ drot_(&c__2, &b[b_dim1 + 1], ldb, &b[b_dim1 + 2], ldb, csl, snl);
+ drot_(&c__2, &a[a_dim1 + 1], &c__1, &a[(a_dim1 << 1) + 1], &c__1,
+ csr, snr);
+ drot_(&c__2, &b[b_dim1 + 1], &c__1, &b[(b_dim1 << 1) + 1], &c__1,
+ csr, snr);
+
+ b[b_dim1 + 2] = 0.;
+ b[(b_dim1 << 1) + 1] = 0.;
+
+ }
+
+ }
+
+/* Unscaling */
+
+ a[a_dim1 + 1] = anorm * a[a_dim1 + 1];
+ a[a_dim1 + 2] = anorm * a[a_dim1 + 2];
+ a[(a_dim1 << 1) + 1] = anorm * a[(a_dim1 << 1) + 1];
+ a[(a_dim1 << 1) + 2] = anorm * a[(a_dim1 << 1) + 2];
+ b[b_dim1 + 1] = bnorm * b[b_dim1 + 1];
+ b[b_dim1 + 2] = bnorm * b[b_dim1 + 2];
+ b[(b_dim1 << 1) + 1] = bnorm * b[(b_dim1 << 1) + 1];
+ b[(b_dim1 << 1) + 2] = bnorm * b[(b_dim1 << 1) + 2];
+
+ if (wi == 0.) {
+ alphar[1] = a[a_dim1 + 1];
+ alphar[2] = a[(a_dim1 << 1) + 2];
+ alphai[1] = 0.;
+ alphai[2] = 0.;
+ beta[1] = b[b_dim1 + 1];
+ beta[2] = b[(b_dim1 << 1) + 2];
+ } else {
+ alphar[1] = anorm * wr1 / scale1 / bnorm;
+ alphai[1] = anorm * wi / scale1 / bnorm;
+ alphar[2] = alphar[1];
+ alphai[2] = -alphai[1];
+ beta[1] = 1.;
+ beta[2] = 1.;
+ }
+
+ return 0;
+
+/* End of DLAGV2 */
+
+} /* dlagv2_ */
diff --git a/SRC/dlahqr.c b/SRC/dlahqr.c
new file mode 100644
index 0000000..555f584
--- /dev/null
+++ b/SRC/dlahqr.c
@@ -0,0 +1,631 @@
+/* dlahqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dlahqr_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, doublereal *h__, integer *ldh, doublereal
+ *wr, doublereal *wi, integer *iloz, integer *ihiz, doublereal *z__,
+ integer *ldz, integer *info)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, l, m;
+ doublereal s, v[3];
+ integer i1, i2;
+ doublereal t1, t2, t3, v2, v3, aa, ab, ba, bb, h11, h12, h21, h22, cs;
+ integer nh;
+ doublereal sn;
+ integer nr;
+ doublereal tr;
+ integer nz;
+ doublereal det, h21s;
+ integer its;
+ doublereal ulp, sum, tst, rt1i, rt2i, rt1r, rt2r;
+ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *), dcopy_(
+ integer *, doublereal *, integer *, doublereal *, integer *),
+ dlanv2_(doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *), dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *);
+ doublereal safmin, safmax, rtdisc, smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAHQR is an auxiliary routine called by DHSEQR to update the */
+/* eigenvalues and Schur decomposition already computed by DHSEQR, by */
+/* dealing with the Hessenberg submatrix in rows and columns ILO to */
+/* IHI. */
+
+/* Arguments */
+/* ========= */
+
+/* WANTT (input) LOGICAL */
+/* = .TRUE. : the full Schur form T is required; */
+/* = .FALSE.: only eigenvalues are required. */
+
+/* WANTZ (input) LOGICAL */
+/* = .TRUE. : the matrix of Schur vectors Z is required; */
+/* = .FALSE.: Schur vectors are not required. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that H is already upper quasi-triangular in */
+/* rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless */
+/* ILO = 1). DLAHQR works primarily with the Hessenberg */
+/* submatrix in rows and columns ILO to IHI, but applies */
+/* transformations to all of H if WANTT is .TRUE.. */
+/* 1 <= ILO <= max(1,IHI); IHI <= N. */
+
+/* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */
+/* On entry, the upper Hessenberg matrix H. */
+/* On exit, if INFO is zero and if WANTT is .TRUE., H is upper */
+/* quasi-triangular in rows and columns ILO:IHI, with any */
+/* 2-by-2 diagonal blocks in standard form. If INFO is zero */
+/* and WANTT is .FALSE., the contents of H are unspecified on */
+/* exit. The output state of H if INFO is nonzero is given */
+/* below under the description of INFO. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH >= max(1,N). */
+
+/* WR (output) DOUBLE PRECISION array, dimension (N) */
+/* WI (output) DOUBLE PRECISION array, dimension (N) */
+/* The real and imaginary parts, respectively, of the computed */
+/* eigenvalues ILO to IHI are stored in the corresponding */
+/* elements of WR and WI. If two eigenvalues are computed as a */
+/* complex conjugate pair, they are stored in consecutive */
+/* elements of WR and WI, say the i-th and (i+1)th, with */
+/* WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the */
+/* eigenvalues are stored in the same order as on the diagonal */
+/* of the Schur form returned in H, with WR(i) = H(i,i), and, if */
+/* H(i:i+1,i:i+1) is a 2-by-2 diagonal block, */
+/* WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). */
+
+/* ILOZ (input) INTEGER */
+/* IHIZ (input) INTEGER */
+/* Specify the rows of Z to which transformations must be */
+/* applied if WANTZ is .TRUE.. */
+/* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */
+
+/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
+/* If WANTZ is .TRUE., on entry Z must contain the current */
+/* matrix Z of transformations accumulated by DHSEQR, and on */
+/* exit Z has been updated; transformations are applied only to */
+/* the submatrix Z(ILOZ:IHIZ,ILO:IHI). */
+/* If WANTZ is .FALSE., Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* .GT. 0: If INFO = i, DLAHQR failed to compute all the */
+/* eigenvalues ILO to IHI in a total of 30 iterations */
+/* per eigenvalue; elements i+1:ihi of WR and WI */
+/* contain those eigenvalues which have been */
+/* successfully computed. */
+
+/* If INFO .GT. 0 and WANTT is .FALSE., then on exit, */
+/* the remaining unconverged eigenvalues are the */
+/* eigenvalues of the upper Hessenberg matrix rows */
+/* and columns ILO thorugh INFO of the final, output */
+/* value of H. */
+
+/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */
+/* (*) (initial value of H)*U = U*(final value of H) */
+/* where U is an orthognal matrix. The final */
+/* value of H is upper Hessenberg and triangular in */
+/* rows and columns INFO+1 through IHI. */
+
+/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
+/* (final value of Z) = (initial value of Z)*U */
+/* where U is the orthogonal matrix in (*) */
+/* (regardless of the value of WANTT.) */
+
+/* Further Details */
+/* =============== */
+
+/* 02-96 Based on modifications by */
+/* David Day, Sandia National Laboratory, USA */
+
+/* 12-04 Further modifications by */
+/* Ralph Byers, University of Kansas, USA */
+/* This is a modified version of DLAHQR from LAPACK version 3.0. */
+/* It is (1) more robust against overflow and underflow and */
+/* (2) adopts the more conservative Ahues & Tisseur stopping */
+/* criterion (LAWN 122, 1997). */
+
+/* ========================================================= */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --wr;
+ --wi;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+ if (*ilo == *ihi) {
+ wr[*ilo] = h__[*ilo + *ilo * h_dim1];
+ wi[*ilo] = 0.;
+ return 0;
+ }
+
+/* ==== clear out the trash ==== */
+ i__1 = *ihi - 3;
+ for (j = *ilo; j <= i__1; ++j) {
+ h__[j + 2 + j * h_dim1] = 0.;
+ h__[j + 3 + j * h_dim1] = 0.;
+/* L10: */
+ }
+ if (*ilo <= *ihi - 2) {
+ h__[*ihi + (*ihi - 2) * h_dim1] = 0.;
+ }
+
+ nh = *ihi - *ilo + 1;
+ nz = *ihiz - *iloz + 1;
+
+/* Set machine-dependent constants for the stopping criterion. */
+
+ safmin = dlamch_("SAFE MINIMUM");
+ safmax = 1. / safmin;
+ dlabad_(&safmin, &safmax);
+ ulp = dlamch_("PRECISION");
+ smlnum = safmin * ((doublereal) nh / ulp);
+
+/* I1 and I2 are the indices of the first row and last column of H */
+/* to which transformations must be applied. If eigenvalues only are */
+/* being computed, I1 and I2 are set inside the main loop. */
+
+ if (*wantt) {
+ i1 = 1;
+ i2 = *n;
+ }
+
+/* The main loop begins here. I is the loop index and decreases from */
+/* IHI to ILO in steps of 1 or 2. Each iteration of the loop works */
+/* with the active submatrix in rows and columns L to I. */
+/* Eigenvalues I+1 to IHI have already converged. Either L = ILO or */
+/* H(L,L-1) is negligible so that the matrix splits. */
+
+ i__ = *ihi;
+L20:
+ l = *ilo;
+ if (i__ < *ilo) {
+ goto L160;
+ }
+
+/* Perform QR iterations on rows and columns ILO to I until a */
+/* submatrix of order 1 or 2 splits off at the bottom because a */
+/* subdiagonal element has become negligible. */
+
+ for (its = 0; its <= 30; ++its) {
+
+/* Look for a single small subdiagonal element. */
+
+ i__1 = l + 1;
+ for (k = i__; k >= i__1; --k) {
+ if ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= smlnum) {
+ goto L40;
+ }
+ tst = (d__1 = h__[k - 1 + (k - 1) * h_dim1], abs(d__1)) + (d__2 =
+ h__[k + k * h_dim1], abs(d__2));
+ if (tst == 0.) {
+ if (k - 2 >= *ilo) {
+ tst += (d__1 = h__[k - 1 + (k - 2) * h_dim1], abs(d__1));
+ }
+ if (k + 1 <= *ihi) {
+ tst += (d__1 = h__[k + 1 + k * h_dim1], abs(d__1));
+ }
+ }
+/* ==== The following is a conservative small subdiagonal */
+/* . deflation criterion due to Ahues & Tisseur (LAWN 122, */
+/* . 1997). It has better mathematical foundation and */
+/* . improves accuracy in some cases. ==== */
+ if ((d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)) <= ulp * tst) {
+/* Computing MAX */
+ d__3 = (d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)), d__4 = (
+ d__2 = h__[k - 1 + k * h_dim1], abs(d__2));
+ ab = max(d__3,d__4);
+/* Computing MIN */
+ d__3 = (d__1 = h__[k + (k - 1) * h_dim1], abs(d__1)), d__4 = (
+ d__2 = h__[k - 1 + k * h_dim1], abs(d__2));
+ ba = min(d__3,d__4);
+/* Computing MAX */
+ d__3 = (d__1 = h__[k + k * h_dim1], abs(d__1)), d__4 = (d__2 =
+ h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1],
+ abs(d__2));
+ aa = max(d__3,d__4);
+/* Computing MIN */
+ d__3 = (d__1 = h__[k + k * h_dim1], abs(d__1)), d__4 = (d__2 =
+ h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1],
+ abs(d__2));
+ bb = min(d__3,d__4);
+ s = aa + ab;
+/* Computing MAX */
+ d__1 = smlnum, d__2 = ulp * (bb * (aa / s));
+ if (ba * (ab / s) <= max(d__1,d__2)) {
+ goto L40;
+ }
+ }
+/* L30: */
+ }
+L40:
+ l = k;
+ if (l > *ilo) {
+
+/* H(L,L-1) is negligible */
+
+ h__[l + (l - 1) * h_dim1] = 0.;
+ }
+
+/* Exit from loop if a submatrix of order 1 or 2 has split off. */
+
+ if (l >= i__ - 1) {
+ goto L150;
+ }
+
+/* Now the active submatrix is in rows and columns L to I. If */
+/* eigenvalues only are being computed, only the active submatrix */
+/* need be transformed. */
+
+ if (! (*wantt)) {
+ i1 = l;
+ i2 = i__;
+ }
+
+ if (its == 10) {
+
+/* Exceptional shift. */
+
+ s = (d__1 = h__[l + 1 + l * h_dim1], abs(d__1)) + (d__2 = h__[l +
+ 2 + (l + 1) * h_dim1], abs(d__2));
+ h11 = s * .75 + h__[l + l * h_dim1];
+ h12 = s * -.4375;
+ h21 = s;
+ h22 = h11;
+ } else if (its == 20) {
+
+/* Exceptional shift. */
+
+ s = (d__1 = h__[i__ + (i__ - 1) * h_dim1], abs(d__1)) + (d__2 =
+ h__[i__ - 1 + (i__ - 2) * h_dim1], abs(d__2));
+ h11 = s * .75 + h__[i__ + i__ * h_dim1];
+ h12 = s * -.4375;
+ h21 = s;
+ h22 = h11;
+ } else {
+
+/* Prepare to use Francis' double shift */
+/* (i.e. 2nd degree generalized Rayleigh quotient) */
+
+ h11 = h__[i__ - 1 + (i__ - 1) * h_dim1];
+ h21 = h__[i__ + (i__ - 1) * h_dim1];
+ h12 = h__[i__ - 1 + i__ * h_dim1];
+ h22 = h__[i__ + i__ * h_dim1];
+ }
+ s = abs(h11) + abs(h12) + abs(h21) + abs(h22);
+ if (s == 0.) {
+ rt1r = 0.;
+ rt1i = 0.;
+ rt2r = 0.;
+ rt2i = 0.;
+ } else {
+ h11 /= s;
+ h21 /= s;
+ h12 /= s;
+ h22 /= s;
+ tr = (h11 + h22) / 2.;
+ det = (h11 - tr) * (h22 - tr) - h12 * h21;
+ rtdisc = sqrt((abs(det)));
+ if (det >= 0.) {
+
+/* ==== complex conjugate shifts ==== */
+
+ rt1r = tr * s;
+ rt2r = rt1r;
+ rt1i = rtdisc * s;
+ rt2i = -rt1i;
+ } else {
+
+/* ==== real shifts (use only one of them) ==== */
+
+ rt1r = tr + rtdisc;
+ rt2r = tr - rtdisc;
+ if ((d__1 = rt1r - h22, abs(d__1)) <= (d__2 = rt2r - h22, abs(
+ d__2))) {
+ rt1r *= s;
+ rt2r = rt1r;
+ } else {
+ rt2r *= s;
+ rt1r = rt2r;
+ }
+ rt1i = 0.;
+ rt2i = 0.;
+ }
+ }
+
+/* Look for two consecutive small subdiagonal elements. */
+
+ i__1 = l;
+ for (m = i__ - 2; m >= i__1; --m) {
+/* Determine the effect of starting the double-shift QR */
+/* iteration at row M, and see if this would make H(M,M-1) */
+/* negligible. (The following uses scaling to avoid */
+/* overflows and most underflows.) */
+
+ h21s = h__[m + 1 + m * h_dim1];
+ s = (d__1 = h__[m + m * h_dim1] - rt2r, abs(d__1)) + abs(rt2i) +
+ abs(h21s);
+ h21s = h__[m + 1 + m * h_dim1] / s;
+ v[0] = h21s * h__[m + (m + 1) * h_dim1] + (h__[m + m * h_dim1] -
+ rt1r) * ((h__[m + m * h_dim1] - rt2r) / s) - rt1i * (rt2i
+ / s);
+ v[1] = h21s * (h__[m + m * h_dim1] + h__[m + 1 + (m + 1) * h_dim1]
+ - rt1r - rt2r);
+ v[2] = h21s * h__[m + 2 + (m + 1) * h_dim1];
+ s = abs(v[0]) + abs(v[1]) + abs(v[2]);
+ v[0] /= s;
+ v[1] /= s;
+ v[2] /= s;
+ if (m == l) {
+ goto L60;
+ }
+ if ((d__1 = h__[m + (m - 1) * h_dim1], abs(d__1)) * (abs(v[1]) +
+ abs(v[2])) <= ulp * abs(v[0]) * ((d__2 = h__[m - 1 + (m -
+ 1) * h_dim1], abs(d__2)) + (d__3 = h__[m + m * h_dim1],
+ abs(d__3)) + (d__4 = h__[m + 1 + (m + 1) * h_dim1], abs(
+ d__4)))) {
+ goto L60;
+ }
+/* L50: */
+ }
+L60:
+
+/* Double-shift QR step */
+
+ i__1 = i__ - 1;
+ for (k = m; k <= i__1; ++k) {
+
+/* The first iteration of this loop determines a reflection G */
+/* from the vector V and applies it from left and right to H, */
+/* thus creating a nonzero bulge below the subdiagonal. */
+
+/* Each subsequent iteration determines a reflection G to */
+/* restore the Hessenberg form in the (K-1)th column, and thus */
+/* chases the bulge one step toward the bottom of the active */
+/* submatrix. NR is the order of G. */
+
+/* Computing MIN */
+ i__2 = 3, i__3 = i__ - k + 1;
+ nr = min(i__2,i__3);
+ if (k > m) {
+ dcopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
+ }
+ dlarfg_(&nr, v, &v[1], &c__1, &t1);
+ if (k > m) {
+ h__[k + (k - 1) * h_dim1] = v[0];
+ h__[k + 1 + (k - 1) * h_dim1] = 0.;
+ if (k < i__ - 1) {
+ h__[k + 2 + (k - 1) * h_dim1] = 0.;
+ }
+ } else if (m > l) {
+/* ==== Use the following instead of */
+/* . H( K, K-1 ) = -H( K, K-1 ) to */
+/* . avoid a bug when v(2) and v(3) */
+/* . underflow. ==== */
+ h__[k + (k - 1) * h_dim1] *= 1. - t1;
+ }
+ v2 = v[1];
+ t2 = t1 * v2;
+ if (nr == 3) {
+ v3 = v[2];
+ t3 = t1 * v3;
+
+/* Apply G from the left to transform the rows of the matrix */
+/* in columns K to I2. */
+
+ i__2 = i2;
+ for (j = k; j <= i__2; ++j) {
+ sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1]
+ + v3 * h__[k + 2 + j * h_dim1];
+ h__[k + j * h_dim1] -= sum * t1;
+ h__[k + 1 + j * h_dim1] -= sum * t2;
+ h__[k + 2 + j * h_dim1] -= sum * t3;
+/* L70: */
+ }
+
+/* Apply G from the right to transform the columns of the */
+/* matrix in rows I1 to min(K+3,I). */
+
+/* Computing MIN */
+ i__3 = k + 3;
+ i__2 = min(i__3,i__);
+ for (j = i1; j <= i__2; ++j) {
+ sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
+ + v3 * h__[j + (k + 2) * h_dim1];
+ h__[j + k * h_dim1] -= sum * t1;
+ h__[j + (k + 1) * h_dim1] -= sum * t2;
+ h__[j + (k + 2) * h_dim1] -= sum * t3;
+/* L80: */
+ }
+
+ if (*wantz) {
+
+/* Accumulate transformations in the matrix Z */
+
+ i__2 = *ihiz;
+ for (j = *iloz; j <= i__2; ++j) {
+ sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) *
+ z_dim1] + v3 * z__[j + (k + 2) * z_dim1];
+ z__[j + k * z_dim1] -= sum * t1;
+ z__[j + (k + 1) * z_dim1] -= sum * t2;
+ z__[j + (k + 2) * z_dim1] -= sum * t3;
+/* L90: */
+ }
+ }
+ } else if (nr == 2) {
+
+/* Apply G from the left to transform the rows of the matrix */
+/* in columns K to I2. */
+
+ i__2 = i2;
+ for (j = k; j <= i__2; ++j) {
+ sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1];
+ h__[k + j * h_dim1] -= sum * t1;
+ h__[k + 1 + j * h_dim1] -= sum * t2;
+/* L100: */
+ }
+
+/* Apply G from the right to transform the columns of the */
+/* matrix in rows I1 to min(K+3,I). */
+
+ i__2 = i__;
+ for (j = i1; j <= i__2; ++j) {
+ sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
+ ;
+ h__[j + k * h_dim1] -= sum * t1;
+ h__[j + (k + 1) * h_dim1] -= sum * t2;
+/* L110: */
+ }
+
+ if (*wantz) {
+
+/* Accumulate transformations in the matrix Z */
+
+ i__2 = *ihiz;
+ for (j = *iloz; j <= i__2; ++j) {
+ sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) *
+ z_dim1];
+ z__[j + k * z_dim1] -= sum * t1;
+ z__[j + (k + 1) * z_dim1] -= sum * t2;
+/* L120: */
+ }
+ }
+ }
+/* L130: */
+ }
+
+/* L140: */
+ }
+
+/* Failure to converge in remaining number of iterations */
+
+ *info = i__;
+ return 0;
+
+L150:
+
+ if (l == i__) {
+
+/* H(I,I-1) is negligible: one eigenvalue has converged. */
+
+ wr[i__] = h__[i__ + i__ * h_dim1];
+ wi[i__] = 0.;
+ } else if (l == i__ - 1) {
+
+/* H(I-1,I-2) is negligible: a pair of eigenvalues have converged. */
+
+/* Transform the 2-by-2 submatrix to standard Schur form, */
+/* and compute and store the eigenvalues. */
+
+ dlanv2_(&h__[i__ - 1 + (i__ - 1) * h_dim1], &h__[i__ - 1 + i__ *
+ h_dim1], &h__[i__ + (i__ - 1) * h_dim1], &h__[i__ + i__ *
+ h_dim1], &wr[i__ - 1], &wi[i__ - 1], &wr[i__], &wi[i__], &cs,
+ &sn);
+
+ if (*wantt) {
+
+/* Apply the transformation to the rest of H. */
+
+ if (i2 > i__) {
+ i__1 = i2 - i__;
+ drot_(&i__1, &h__[i__ - 1 + (i__ + 1) * h_dim1], ldh, &h__[
+ i__ + (i__ + 1) * h_dim1], ldh, &cs, &sn);
+ }
+ i__1 = i__ - i1 - 1;
+ drot_(&i__1, &h__[i1 + (i__ - 1) * h_dim1], &c__1, &h__[i1 + i__ *
+ h_dim1], &c__1, &cs, &sn);
+ }
+ if (*wantz) {
+
+/* Apply the transformation to Z. */
+
+ drot_(&nz, &z__[*iloz + (i__ - 1) * z_dim1], &c__1, &z__[*iloz +
+ i__ * z_dim1], &c__1, &cs, &sn);
+ }
+ }
+
+/* return to start of the main loop with new value of I. */
+
+ i__ = l - 1;
+ goto L20;
+
+L160:
+ return 0;
+
+/* End of DLAHQR */
+
+} /* dlahqr_ */
diff --git a/SRC/dlahr2.c b/SRC/dlahr2.c
new file mode 100644
index 0000000..9a17c87
--- /dev/null
+++ b/SRC/dlahr2.c
@@ -0,0 +1,315 @@
+/* dlahr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b4 = -1.;
+static doublereal c_b5 = 1.;
+static integer c__1 = 1;
+static doublereal c_b38 = 0.;
+
+/* Subroutine */ int dlahr2_(integer *n, integer *k, integer *nb, doublereal *
+ a, integer *lda, doublereal *tau, doublereal *t, integer *ldt,
+ doublereal *y, integer *ldy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
+ i__3;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__;
+ doublereal ei;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *), dgemm_(char *, char *, integer *, integer *, integer *
+, doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dgemv_(
+ char *, integer *, integer *, doublereal *, doublereal *, integer
+ *, doublereal *, integer *, doublereal *, doublereal *, integer *), dcopy_(integer *, doublereal *, integer *, doublereal *,
+ integer *), dtrmm_(char *, char *, char *, char *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *), daxpy_(integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *),
+ dtrmv_(char *, char *, char *, integer *, doublereal *, integer *,
+ doublereal *, integer *), dlarfg_(
+ integer *, doublereal *, doublereal *, integer *, doublereal *),
+ dlacpy_(char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1) */
+/* matrix A so that elements below the k-th subdiagonal are zero. The */
+/* reduction is performed by an orthogonal similarity transformation */
+/* Q' * A * Q. The routine returns the matrices V and T which determine */
+/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */
+
+/* This is an auxiliary routine called by DGEHRD. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* K (input) INTEGER */
+/* The offset for the reduction. Elements below the k-th */
+/* subdiagonal in the first NB columns are reduced to zero. */
+/* K < N. */
+
+/* NB (input) INTEGER */
+/* The number of columns to be reduced. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1) */
+/* On entry, the n-by-(n-k+1) general matrix A. */
+/* On exit, the elements on and above the k-th subdiagonal in */
+/* the first NB columns are overwritten with the corresponding */
+/* elements of the reduced matrix; the elements below the k-th */
+/* subdiagonal, with the array TAU, represent the matrix Q as a */
+/* product of elementary reflectors. The other columns of A are */
+/* unchanged. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (NB) */
+/* The scalar factors of the elementary reflectors. See Further */
+/* Details. */
+
+/* T (output) DOUBLE PRECISION array, dimension (LDT,NB) */
+/* The upper triangular matrix T. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= NB. */
+
+/* Y (output) DOUBLE PRECISION array, dimension (LDY,NB) */
+/* The n-by-nb matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= N. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of nb elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(nb). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
+/* A(i+k+1:n,i), and tau in TAU(i). */
+
+/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */
+/* V which is needed, with T and Y, to apply the transformation to the */
+/* unreduced part of the matrix, using an update of the form: */
+/* A := (I - V*T*V') * (A - Y*V'). */
+
+/* The contents of A on exit are illustrated by the following example */
+/* with n = 7, k = 3 and nb = 2: */
+
+/* ( a a a a a ) */
+/* ( a a a a a ) */
+/* ( a a a a a ) */
+/* ( h h a a a ) */
+/* ( v1 h a a a ) */
+/* ( v1 v2 a a a ) */
+/* ( v1 v2 a a a ) */
+
+/* where a denotes an element of the original matrix A, h denotes a */
+/* modified element of the upper Hessenberg matrix H, and vi denotes an */
+/* element of the vector defining H(i). */
+
+/* This file is a slight modification of LAPACK-3.0's DLAHRD */
+/* incorporating improvements proposed by Quintana-Orti and Van de */
+/* Gejin. Note that the entries of A(1:K,2:NB) differ from those */
+/* returned by the original LAPACK routine. This function is */
+/* not backward compatible with LAPACK3.0. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --tau;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+
+ /* Function Body */
+ if (*n <= 1) {
+ return 0;
+ }
+
+ i__1 = *nb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (i__ > 1) {
+
+/* Update A(K+1:N,I) */
+
+/* Update I-th column of A - Y * V' */
+
+ i__2 = *n - *k;
+ i__3 = i__ - 1;
+ dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1],
+ ldy, &a[*k + i__ - 1 + a_dim1], lda, &c_b5, &a[*k + 1 +
+ i__ * a_dim1], &c__1);
+
+/* Apply I - V * T' * V' to this column (call it b) from the */
+/* left, using the last column of T as workspace */
+
+/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */
+/* ( V2 ) ( b2 ) */
+
+/* where V1 is unit lower triangular */
+
+/* w := V1' * b1 */
+
+ i__2 = i__ - 1;
+ dcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 +
+ 1], &c__1);
+ i__2 = i__ - 1;
+ dtrmv_("Lower", "Transpose", "UNIT", &i__2, &a[*k + 1 + a_dim1],
+ lda, &t[*nb * t_dim1 + 1], &c__1);
+
+/* w := w + V2'*b2 */
+
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1],
+ lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b5, &t[*nb *
+ t_dim1 + 1], &c__1);
+
+/* w := T'*w */
+
+ i__2 = i__ - 1;
+ dtrmv_("Upper", "Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt,
+ &t[*nb * t_dim1 + 1], &c__1);
+
+/* b2 := b2 - V2*w */
+
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &a[*k + i__ + a_dim1],
+ lda, &t[*nb * t_dim1 + 1], &c__1, &c_b5, &a[*k + i__ +
+ i__ * a_dim1], &c__1);
+
+/* b1 := b1 - V1*w */
+
+ i__2 = i__ - 1;
+ dtrmv_("Lower", "NO TRANSPOSE", "UNIT", &i__2, &a[*k + 1 + a_dim1]
+, lda, &t[*nb * t_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ daxpy_(&i__2, &c_b4, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__
+ * a_dim1], &c__1);
+
+ a[*k + i__ - 1 + (i__ - 1) * a_dim1] = ei;
+ }
+
+/* Generate the elementary reflector H(I) to annihilate */
+/* A(K+I+1:N,I) */
+
+ i__2 = *n - *k - i__ + 1;
+/* Computing MIN */
+ i__3 = *k + i__ + 1;
+ dlarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[min(i__3, *n)+ i__ *
+ a_dim1], &c__1, &tau[i__]);
+ ei = a[*k + i__ + i__ * a_dim1];
+ a[*k + i__ + i__ * a_dim1] = 1.;
+
+/* Compute Y(K+1:N,I) */
+
+ i__2 = *n - *k;
+ i__3 = *n - *k - i__ + 1;
+ dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b5, &a[*k + 1 + (i__ + 1) *
+ a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &y[*
+ k + 1 + i__ * y_dim1], &c__1);
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], lda, &
+ a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &t[i__ * t_dim1 +
+ 1], &c__1);
+ i__2 = *n - *k;
+ i__3 = i__ - 1;
+ dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1], ldy,
+ &t[i__ * t_dim1 + 1], &c__1, &c_b5, &y[*k + 1 + i__ * y_dim1],
+ &c__1);
+ i__2 = *n - *k;
+ dscal_(&i__2, &tau[i__], &y[*k + 1 + i__ * y_dim1], &c__1);
+
+/* Compute T(1:I,I) */
+
+ i__2 = i__ - 1;
+ d__1 = -tau[i__];
+ dscal_(&i__2, &d__1, &t[i__ * t_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ dtrmv_("Upper", "No Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt,
+ &t[i__ * t_dim1 + 1], &c__1)
+ ;
+ t[i__ + i__ * t_dim1] = tau[i__];
+
+/* L10: */
+ }
+ a[*k + *nb + *nb * a_dim1] = ei;
+
+/* Compute Y(1:K,1:NB) */
+
+ dlacpy_("ALL", k, nb, &a[(a_dim1 << 1) + 1], lda, &y[y_offset], ldy);
+ dtrmm_("RIGHT", "Lower", "NO TRANSPOSE", "UNIT", k, nb, &c_b5, &a[*k + 1
+ + a_dim1], lda, &y[y_offset], ldy);
+ if (*n > *k + *nb) {
+ i__1 = *n - *k - *nb;
+ dgemm_("NO TRANSPOSE", "NO TRANSPOSE", k, nb, &i__1, &c_b5, &a[(*nb +
+ 2) * a_dim1 + 1], lda, &a[*k + 1 + *nb + a_dim1], lda, &c_b5,
+ &y[y_offset], ldy);
+ }
+ dtrmm_("RIGHT", "Upper", "NO TRANSPOSE", "NON-UNIT", k, nb, &c_b5, &t[
+ t_offset], ldt, &y[y_offset], ldy);
+
+ return 0;
+
+/* End of DLAHR2 */
+
+} /* dlahr2_ */
diff --git a/SRC/dlahrd.c b/SRC/dlahrd.c
new file mode 100644
index 0000000..4516fba
--- /dev/null
+++ b/SRC/dlahrd.c
@@ -0,0 +1,285 @@
+/* dlahrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b4 = -1.;
+static doublereal c_b5 = 1.;
+static integer c__1 = 1;
+static doublereal c_b38 = 0.;
+
+/* Subroutine */ int dlahrd_(integer *n, integer *k, integer *nb, doublereal *
+ a, integer *lda, doublereal *tau, doublereal *t, integer *ldt,
+ doublereal *y, integer *ldy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
+ i__3;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__;
+ doublereal ei;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *), dgemv_(char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *), dcopy_(integer *, doublereal *,
+ integer *, doublereal *, integer *), daxpy_(integer *, doublereal
+ *, doublereal *, integer *, doublereal *, integer *), dtrmv_(char
+ *, char *, char *, integer *, doublereal *, integer *, doublereal
+ *, integer *), dlarfg_(integer *,
+ doublereal *, doublereal *, integer *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAHRD reduces the first NB columns of a real general n-by-(n-k+1) */
+/* matrix A so that elements below the k-th subdiagonal are zero. The */
+/* reduction is performed by an orthogonal similarity transformation */
+/* Q' * A * Q. The routine returns the matrices V and T which determine */
+/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */
+
+/* This is an OBSOLETE auxiliary routine. */
+/* This routine will be 'deprecated' in a future release. */
+/* Please use the new routine DLAHR2 instead. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* K (input) INTEGER */
+/* The offset for the reduction. Elements below the k-th */
+/* subdiagonal in the first NB columns are reduced to zero. */
+
+/* NB (input) INTEGER */
+/* The number of columns to be reduced. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1) */
+/* On entry, the n-by-(n-k+1) general matrix A. */
+/* On exit, the elements on and above the k-th subdiagonal in */
+/* the first NB columns are overwritten with the corresponding */
+/* elements of the reduced matrix; the elements below the k-th */
+/* subdiagonal, with the array TAU, represent the matrix Q as a */
+/* product of elementary reflectors. The other columns of A are */
+/* unchanged. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (NB) */
+/* The scalar factors of the elementary reflectors. See Further */
+/* Details. */
+
+/* T (output) DOUBLE PRECISION array, dimension (LDT,NB) */
+/* The upper triangular matrix T. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= NB. */
+
+/* Y (output) DOUBLE PRECISION array, dimension (LDY,NB) */
+/* The n-by-nb matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= N. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of nb elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(nb). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
+/* A(i+k+1:n,i), and tau in TAU(i). */
+
+/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */
+/* V which is needed, with T and Y, to apply the transformation to the */
+/* unreduced part of the matrix, using an update of the form: */
+/* A := (I - V*T*V') * (A - Y*V'). */
+
+/* The contents of A on exit are illustrated by the following example */
+/* with n = 7, k = 3 and nb = 2: */
+
+/* ( a h a a a ) */
+/* ( a h a a a ) */
+/* ( a h a a a ) */
+/* ( h h a a a ) */
+/* ( v1 h a a a ) */
+/* ( v1 v2 a a a ) */
+/* ( v1 v2 a a a ) */
+
+/* where a denotes an element of the original matrix A, h denotes a */
+/* modified element of the upper Hessenberg matrix H, and vi denotes an */
+/* element of the vector defining H(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --tau;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+
+ /* Function Body */
+ if (*n <= 1) {
+ return 0;
+ }
+
+ i__1 = *nb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (i__ > 1) {
+
+/* Update A(1:n,i) */
+
+/* Compute i-th column of A - Y * V' */
+
+ i__2 = i__ - 1;
+ dgemv_("No transpose", n, &i__2, &c_b4, &y[y_offset], ldy, &a[*k
+ + i__ - 1 + a_dim1], lda, &c_b5, &a[i__ * a_dim1 + 1], &
+ c__1);
+
+/* Apply I - V * T' * V' to this column (call it b) from the */
+/* left, using the last column of T as workspace */
+
+/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */
+/* ( V2 ) ( b2 ) */
+
+/* where V1 is unit lower triangular */
+
+/* w := V1' * b1 */
+
+ i__2 = i__ - 1;
+ dcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 +
+ 1], &c__1);
+ i__2 = i__ - 1;
+ dtrmv_("Lower", "Transpose", "Unit", &i__2, &a[*k + 1 + a_dim1],
+ lda, &t[*nb * t_dim1 + 1], &c__1);
+
+/* w := w + V2'*b2 */
+
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1],
+ lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b5, &t[*nb *
+ t_dim1 + 1], &c__1);
+
+/* w := T'*w */
+
+ i__2 = i__ - 1;
+ dtrmv_("Upper", "Transpose", "Non-unit", &i__2, &t[t_offset], ldt,
+ &t[*nb * t_dim1 + 1], &c__1);
+
+/* b2 := b2 - V2*w */
+
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ dgemv_("No transpose", &i__2, &i__3, &c_b4, &a[*k + i__ + a_dim1],
+ lda, &t[*nb * t_dim1 + 1], &c__1, &c_b5, &a[*k + i__ +
+ i__ * a_dim1], &c__1);
+
+/* b1 := b1 - V1*w */
+
+ i__2 = i__ - 1;
+ dtrmv_("Lower", "No transpose", "Unit", &i__2, &a[*k + 1 + a_dim1]
+, lda, &t[*nb * t_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ daxpy_(&i__2, &c_b4, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__
+ * a_dim1], &c__1);
+
+ a[*k + i__ - 1 + (i__ - 1) * a_dim1] = ei;
+ }
+
+/* Generate the elementary reflector H(i) to annihilate */
+/* A(k+i+1:n,i) */
+
+ i__2 = *n - *k - i__ + 1;
+/* Computing MIN */
+ i__3 = *k + i__ + 1;
+ dlarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[min(i__3, *n)+ i__ *
+ a_dim1], &c__1, &tau[i__]);
+ ei = a[*k + i__ + i__ * a_dim1];
+ a[*k + i__ + i__ * a_dim1] = 1.;
+
+/* Compute Y(1:n,i) */
+
+ i__2 = *n - *k - i__ + 1;
+ dgemv_("No transpose", n, &i__2, &c_b5, &a[(i__ + 1) * a_dim1 + 1],
+ lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &y[i__ *
+ y_dim1 + 1], &c__1);
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], lda, &
+ a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &t[i__ * t_dim1 +
+ 1], &c__1);
+ i__2 = i__ - 1;
+ dgemv_("No transpose", n, &i__2, &c_b4, &y[y_offset], ldy, &t[i__ *
+ t_dim1 + 1], &c__1, &c_b5, &y[i__ * y_dim1 + 1], &c__1);
+ dscal_(n, &tau[i__], &y[i__ * y_dim1 + 1], &c__1);
+
+/* Compute T(1:i,i) */
+
+ i__2 = i__ - 1;
+ d__1 = -tau[i__];
+ dscal_(&i__2, &d__1, &t[i__ * t_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt,
+ &t[i__ * t_dim1 + 1], &c__1)
+ ;
+ t[i__ + i__ * t_dim1] = tau[i__];
+
+/* L10: */
+ }
+ a[*k + *nb + *nb * a_dim1] = ei;
+
+ return 0;
+
+/* End of DLAHRD */
+
+} /* dlahrd_ */
diff --git a/SRC/dlaic1.c b/SRC/dlaic1.c
new file mode 100644
index 0000000..b1a54fc
--- /dev/null
+++ b/SRC/dlaic1.c
@@ -0,0 +1,326 @@
+/* dlaic1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b5 = 1.;
+
+/* Subroutine */ int dlaic1_(integer *job, integer *j, doublereal *x,
+ doublereal *sest, doublereal *w, doublereal *gamma, doublereal *
+ sestpr, doublereal *s, doublereal *c__)
+{
+ /* System generated locals */
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ doublereal b, t, s1, s2, eps, tmp;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal sine, test, zeta1, zeta2, alpha, norma;
+ extern doublereal dlamch_(char *);
+ doublereal absgam, absalp, cosine, absest;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAIC1 applies one step of incremental condition estimation in */
+/* its simplest version: */
+
+/* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j */
+/* lower triangular matrix L, such that */
+/* twonorm(L*x) = sest */
+/* Then DLAIC1 computes sestpr, s, c such that */
+/* the vector */
+/* [ s*x ] */
+/* xhat = [ c ] */
+/* is an approximate singular vector of */
+/* [ L 0 ] */
+/* Lhat = [ w' gamma ] */
+/* in the sense that */
+/* twonorm(Lhat*xhat) = sestpr. */
+
+/* Depending on JOB, an estimate for the largest or smallest singular */
+/* value is computed. */
+
+/* Note that [s c]' and sestpr**2 is an eigenpair of the system */
+
+/* diag(sest*sest, 0) + [alpha gamma] * [ alpha ] */
+/* [ gamma ] */
+
+/* where alpha = x'*w. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) INTEGER */
+/* = 1: an estimate for the largest singular value is computed. */
+/* = 2: an estimate for the smallest singular value is computed. */
+
+/* J (input) INTEGER */
+/* Length of X and W */
+
+/* X (input) DOUBLE PRECISION array, dimension (J) */
+/* The j-vector x. */
+
+/* SEST (input) DOUBLE PRECISION */
+/* Estimated singular value of j by j matrix L */
+
+/* W (input) DOUBLE PRECISION array, dimension (J) */
+/* The j-vector w. */
+
+/* GAMMA (input) DOUBLE PRECISION */
+/* The diagonal element gamma. */
+
+/* SESTPR (output) DOUBLE PRECISION */
+/* Estimated singular value of (j+1) by (j+1) matrix Lhat. */
+
+/* S (output) DOUBLE PRECISION */
+/* Sine needed in forming xhat. */
+
+/* C (output) DOUBLE PRECISION */
+/* Cosine needed in forming xhat. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --w;
+ --x;
+
+ /* Function Body */
+ eps = dlamch_("Epsilon");
+ alpha = ddot_(j, &x[1], &c__1, &w[1], &c__1);
+
+ absalp = abs(alpha);
+ absgam = abs(*gamma);
+ absest = abs(*sest);
+
+ if (*job == 1) {
+
+/* Estimating largest singular value */
+
+/* special cases */
+
+ if (*sest == 0.) {
+ s1 = max(absgam,absalp);
+ if (s1 == 0.) {
+ *s = 0.;
+ *c__ = 1.;
+ *sestpr = 0.;
+ } else {
+ *s = alpha / s1;
+ *c__ = *gamma / s1;
+ tmp = sqrt(*s * *s + *c__ * *c__);
+ *s /= tmp;
+ *c__ /= tmp;
+ *sestpr = s1 * tmp;
+ }
+ return 0;
+ } else if (absgam <= eps * absest) {
+ *s = 1.;
+ *c__ = 0.;
+ tmp = max(absest,absalp);
+ s1 = absest / tmp;
+ s2 = absalp / tmp;
+ *sestpr = tmp * sqrt(s1 * s1 + s2 * s2);
+ return 0;
+ } else if (absalp <= eps * absest) {
+ s1 = absgam;
+ s2 = absest;
+ if (s1 <= s2) {
+ *s = 1.;
+ *c__ = 0.;
+ *sestpr = s2;
+ } else {
+ *s = 0.;
+ *c__ = 1.;
+ *sestpr = s1;
+ }
+ return 0;
+ } else if (absest <= eps * absalp || absest <= eps * absgam) {
+ s1 = absgam;
+ s2 = absalp;
+ if (s1 <= s2) {
+ tmp = s1 / s2;
+ *s = sqrt(tmp * tmp + 1.);
+ *sestpr = s2 * *s;
+ *c__ = *gamma / s2 / *s;
+ *s = d_sign(&c_b5, &alpha) / *s;
+ } else {
+ tmp = s2 / s1;
+ *c__ = sqrt(tmp * tmp + 1.);
+ *sestpr = s1 * *c__;
+ *s = alpha / s1 / *c__;
+ *c__ = d_sign(&c_b5, gamma) / *c__;
+ }
+ return 0;
+ } else {
+
+/* normal case */
+
+ zeta1 = alpha / absest;
+ zeta2 = *gamma / absest;
+
+ b = (1. - zeta1 * zeta1 - zeta2 * zeta2) * .5;
+ *c__ = zeta1 * zeta1;
+ if (b > 0.) {
+ t = *c__ / (b + sqrt(b * b + *c__));
+ } else {
+ t = sqrt(b * b + *c__) - b;
+ }
+
+ sine = -zeta1 / t;
+ cosine = -zeta2 / (t + 1.);
+ tmp = sqrt(sine * sine + cosine * cosine);
+ *s = sine / tmp;
+ *c__ = cosine / tmp;
+ *sestpr = sqrt(t + 1.) * absest;
+ return 0;
+ }
+
+ } else if (*job == 2) {
+
+/* Estimating smallest singular value */
+
+/* special cases */
+
+ if (*sest == 0.) {
+ *sestpr = 0.;
+ if (max(absgam,absalp) == 0.) {
+ sine = 1.;
+ cosine = 0.;
+ } else {
+ sine = -(*gamma);
+ cosine = alpha;
+ }
+/* Computing MAX */
+ d__1 = abs(sine), d__2 = abs(cosine);
+ s1 = max(d__1,d__2);
+ *s = sine / s1;
+ *c__ = cosine / s1;
+ tmp = sqrt(*s * *s + *c__ * *c__);
+ *s /= tmp;
+ *c__ /= tmp;
+ return 0;
+ } else if (absgam <= eps * absest) {
+ *s = 0.;
+ *c__ = 1.;
+ *sestpr = absgam;
+ return 0;
+ } else if (absalp <= eps * absest) {
+ s1 = absgam;
+ s2 = absest;
+ if (s1 <= s2) {
+ *s = 0.;
+ *c__ = 1.;
+ *sestpr = s1;
+ } else {
+ *s = 1.;
+ *c__ = 0.;
+ *sestpr = s2;
+ }
+ return 0;
+ } else if (absest <= eps * absalp || absest <= eps * absgam) {
+ s1 = absgam;
+ s2 = absalp;
+ if (s1 <= s2) {
+ tmp = s1 / s2;
+ *c__ = sqrt(tmp * tmp + 1.);
+ *sestpr = absest * (tmp / *c__);
+ *s = -(*gamma / s2) / *c__;
+ *c__ = d_sign(&c_b5, &alpha) / *c__;
+ } else {
+ tmp = s2 / s1;
+ *s = sqrt(tmp * tmp + 1.);
+ *sestpr = absest / *s;
+ *c__ = alpha / s1 / *s;
+ *s = -d_sign(&c_b5, gamma) / *s;
+ }
+ return 0;
+ } else {
+
+/* normal case */
+
+ zeta1 = alpha / absest;
+ zeta2 = *gamma / absest;
+
+/* Computing MAX */
+ d__3 = zeta1 * zeta1 + 1. + (d__1 = zeta1 * zeta2, abs(d__1)),
+ d__4 = (d__2 = zeta1 * zeta2, abs(d__2)) + zeta2 * zeta2;
+ norma = max(d__3,d__4);
+
+/* See if root is closer to zero or to ONE */
+
+ test = (zeta1 - zeta2) * 2. * (zeta1 + zeta2) + 1.;
+ if (test >= 0.) {
+
+/* root is close to zero, compute directly */
+
+ b = (zeta1 * zeta1 + zeta2 * zeta2 + 1.) * .5;
+ *c__ = zeta2 * zeta2;
+ t = *c__ / (b + sqrt((d__1 = b * b - *c__, abs(d__1))));
+ sine = zeta1 / (1. - t);
+ cosine = -zeta2 / t;
+ *sestpr = sqrt(t + eps * 4. * eps * norma) * absest;
+ } else {
+
+/* root is closer to ONE, shift by that amount */
+
+ b = (zeta2 * zeta2 + zeta1 * zeta1 - 1.) * .5;
+ *c__ = zeta1 * zeta1;
+ if (b >= 0.) {
+ t = -(*c__) / (b + sqrt(b * b + *c__));
+ } else {
+ t = b - sqrt(b * b + *c__);
+ }
+ sine = -zeta1 / t;
+ cosine = -zeta2 / (t + 1.);
+ *sestpr = sqrt(t + 1. + eps * 4. * eps * norma) * absest;
+ }
+ tmp = sqrt(sine * sine + cosine * cosine);
+ *s = sine / tmp;
+ *c__ = cosine / tmp;
+ return 0;
+
+ }
+ }
+ return 0;
+
+/* End of DLAIC1 */
+
+} /* dlaic1_ */
diff --git a/SRC/dlaisnan.c b/SRC/dlaisnan.c
new file mode 100644
index 0000000..ea4703c
--- /dev/null
+++ b/SRC/dlaisnan.c
@@ -0,0 +1,58 @@
+/* dlaisnan.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+logical dlaisnan_(doublereal *din1, doublereal *din2)
+{
+ /* System generated locals */
+ logical ret_val;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is not for general use. It exists solely to avoid */
+/* over-optimization in DISNAN. */
+
+/* DLAISNAN checks for NaNs by comparing its two arguments for */
+/* inequality. NaN is the only floating-point value where NaN != NaN */
+/* returns .TRUE. To check for NaNs, pass the same variable as both */
+/* arguments. */
+
+/* A compiler must assume that the two arguments are */
+/* not the same variable, and the test will not be optimized away. */
+/* Interprocedural or whole-program optimization may delete this */
+/* test. The ISNAN functions will be replaced by the correct */
+/* Fortran 03 intrinsic once the intrinsic is widely available. */
+
+/* Arguments */
+/* ========= */
+
+/* DIN1 (input) DOUBLE PRECISION */
+/* DIN2 (input) DOUBLE PRECISION */
+/* Two numbers to compare for inequality. */
+
+/* ===================================================================== */
+
+/* .. Executable Statements .. */
+ ret_val = *din1 != *din2;
+ return ret_val;
+} /* dlaisnan_ */
diff --git a/SRC/dlaln2.c b/SRC/dlaln2.c
new file mode 100644
index 0000000..9eaa3ed
--- /dev/null
+++ b/SRC/dlaln2.c
@@ -0,0 +1,575 @@
+/* dlaln2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlaln2_(logical *ltrans, integer *na, integer *nw,
+ doublereal *smin, doublereal *ca, doublereal *a, integer *lda,
+ doublereal *d1, doublereal *d2, doublereal *b, integer *ldb,
+ doublereal *wr, doublereal *wi, doublereal *x, integer *ldx,
+ doublereal *scale, doublereal *xnorm, integer *info)
+{
+ /* Initialized data */
+
+ static logical zswap[4] = { FALSE_,FALSE_,TRUE_,TRUE_ };
+ static logical rswap[4] = { FALSE_,TRUE_,FALSE_,TRUE_ };
+ static integer ipivot[16] /* was [4][4] */ = { 1,2,3,4,2,1,4,3,3,4,1,2,
+ 4,3,2,1 };
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6;
+ static doublereal equiv_0[4], equiv_1[4];
+
+ /* Local variables */
+ integer j;
+#define ci (equiv_0)
+#define cr (equiv_1)
+ doublereal bi1, bi2, br1, br2, xi1, xi2, xr1, xr2, ci21, ci22, cr21, cr22,
+ li21, csi, ui11, lr21, ui12, ui22;
+#define civ (equiv_0)
+ doublereal csr, ur11, ur12, ur22;
+#define crv (equiv_1)
+ doublereal bbnd, cmax, ui11r, ui12s, temp, ur11r, ur12s, u22abs;
+ integer icmax;
+ doublereal bnorm, cnorm, smini;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dladiv_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *);
+ doublereal bignum, smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLALN2 solves a system of the form (ca A - w D ) X = s B */
+/* or (ca A' - w D) X = s B with possible scaling ("s") and */
+/* perturbation of A. (A' means A-transpose.) */
+
+/* A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA */
+/* real diagonal matrix, w is a real or complex value, and X and B are */
+/* NA x 1 matrices -- real if w is real, complex if w is complex. NA */
+/* may be 1 or 2. */
+
+/* If w is complex, X and B are represented as NA x 2 matrices, */
+/* the first column of each being the real part and the second */
+/* being the imaginary part. */
+
+/* "s" is a scaling factor (.LE. 1), computed by DLALN2, which is */
+/* so chosen that X can be computed without overflow. X is further */
+/* scaled if necessary to assure that norm(ca A - w D)*norm(X) is less */
+/* than overflow. */
+
+/* If both singular values of (ca A - w D) are less than SMIN, */
+/* SMIN*identity will be used instead of (ca A - w D). If only one */
+/* singular value is less than SMIN, one element of (ca A - w D) will be */
+/* perturbed enough to make the smallest singular value roughly SMIN. */
+/* If both singular values are at least SMIN, (ca A - w D) will not be */
+/* perturbed. In any case, the perturbation will be at most some small */
+/* multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values */
+/* are computed by infinity-norm approximations, and thus will only be */
+/* correct to a factor of 2 or so. */
+
+/* Note: all input quantities are assumed to be smaller than overflow */
+/* by a reasonable factor. (See BIGNUM.) */
+
+/* Arguments */
+/* ========== */
+
+/* LTRANS (input) LOGICAL */
+/* =.TRUE.: A-transpose will be used. */
+/* =.FALSE.: A will be used (not transposed.) */
+
+/* NA (input) INTEGER */
+/* The size of the matrix A. It may (only) be 1 or 2. */
+
+/* NW (input) INTEGER */
+/* 1 if "w" is real, 2 if "w" is complex. It may only be 1 */
+/* or 2. */
+
+/* SMIN (input) DOUBLE PRECISION */
+/* The desired lower bound on the singular values of A. This */
+/* should be a safe distance away from underflow or overflow, */
+/* say, between (underflow/machine precision) and (machine */
+/* precision * overflow ). (See BIGNUM and ULP.) */
+
+/* CA (input) DOUBLE PRECISION */
+/* The coefficient c, which A is multiplied by. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,NA) */
+/* The NA x NA matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least NA. */
+
+/* D1 (input) DOUBLE PRECISION */
+/* The 1,1 element in the diagonal matrix D. */
+
+/* D2 (input) DOUBLE PRECISION */
+/* The 2,2 element in the diagonal matrix D. Not used if NW=1. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NW) */
+/* The NA x NW matrix B (right-hand side). If NW=2 ("w" is */
+/* complex), column 1 contains the real part of B and column 2 */
+/* contains the imaginary part. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. It must be at least NA. */
+
+/* WR (input) DOUBLE PRECISION */
+/* The real part of the scalar "w". */
+
+/* WI (input) DOUBLE PRECISION */
+/* The imaginary part of the scalar "w". Not used if NW=1. */
+
+/* X (output) DOUBLE PRECISION array, dimension (LDX,NW) */
+/* The NA x NW matrix X (unknowns), as computed by DLALN2. */
+/* If NW=2 ("w" is complex), on exit, column 1 will contain */
+/* the real part of X and column 2 will contain the imaginary */
+/* part. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of X. It must be at least NA. */
+
+/* SCALE (output) DOUBLE PRECISION */
+/* The scale factor that B must be multiplied by to insure */
+/* that overflow does not occur when computing X. Thus, */
+/* (ca A - w D) X will be SCALE*B, not B (ignoring */
+/* perturbations of A.) It will be at most 1. */
+
+/* XNORM (output) DOUBLE PRECISION */
+/* The infinity-norm of X, when X is regarded as an NA x NW */
+/* real matrix. */
+
+/* INFO (output) INTEGER */
+/* An error flag. It will be set to zero if no error occurs, */
+/* a negative number if an argument is in error, or a positive */
+/* number if ca A - w D had to be perturbed. */
+/* The possible values are: */
+/* = 0: No error occurred, and (ca A - w D) did not have to be */
+/* perturbed. */
+/* = 1: (ca A - w D) had to be perturbed to make its smallest */
+/* (or only) singular value greater than SMIN. */
+/* NOTE: In the interests of speed, this routine does not */
+/* check the inputs for errors. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Equivalences .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Compute BIGNUM */
+
+ smlnum = 2. * dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ smini = max(*smin,smlnum);
+
+/* Don't check for input errors */
+
+ *info = 0;
+
+/* Standard Initializations */
+
+ *scale = 1.;
+
+ if (*na == 1) {
+
+/* 1 x 1 (i.e., scalar) system C X = B */
+
+ if (*nw == 1) {
+
+/* Real 1x1 system. */
+
+/* C = ca A - w D */
+
+ csr = *ca * a[a_dim1 + 1] - *wr * *d1;
+ cnorm = abs(csr);
+
+/* If | C | < SMINI, use C = SMINI */
+
+ if (cnorm < smini) {
+ csr = smini;
+ cnorm = smini;
+ *info = 1;
+ }
+
+/* Check scaling for X = B / C */
+
+ bnorm = (d__1 = b[b_dim1 + 1], abs(d__1));
+ if (cnorm < 1. && bnorm > 1.) {
+ if (bnorm > bignum * cnorm) {
+ *scale = 1. / bnorm;
+ }
+ }
+
+/* Compute X */
+
+ x[x_dim1 + 1] = b[b_dim1 + 1] * *scale / csr;
+ *xnorm = (d__1 = x[x_dim1 + 1], abs(d__1));
+ } else {
+
+/* Complex 1x1 system (w is complex) */
+
+/* C = ca A - w D */
+
+ csr = *ca * a[a_dim1 + 1] - *wr * *d1;
+ csi = -(*wi) * *d1;
+ cnorm = abs(csr) + abs(csi);
+
+/* If | C | < SMINI, use C = SMINI */
+
+ if (cnorm < smini) {
+ csr = smini;
+ csi = 0.;
+ cnorm = smini;
+ *info = 1;
+ }
+
+/* Check scaling for X = B / C */
+
+ bnorm = (d__1 = b[b_dim1 + 1], abs(d__1)) + (d__2 = b[(b_dim1 <<
+ 1) + 1], abs(d__2));
+ if (cnorm < 1. && bnorm > 1.) {
+ if (bnorm > bignum * cnorm) {
+ *scale = 1. / bnorm;
+ }
+ }
+
+/* Compute X */
+
+ d__1 = *scale * b[b_dim1 + 1];
+ d__2 = *scale * b[(b_dim1 << 1) + 1];
+ dladiv_(&d__1, &d__2, &csr, &csi, &x[x_dim1 + 1], &x[(x_dim1 << 1)
+ + 1]);
+ *xnorm = (d__1 = x[x_dim1 + 1], abs(d__1)) + (d__2 = x[(x_dim1 <<
+ 1) + 1], abs(d__2));
+ }
+
+ } else {
+
+/* 2x2 System */
+
+/* Compute the real part of C = ca A - w D (or ca A' - w D ) */
+
+ cr[0] = *ca * a[a_dim1 + 1] - *wr * *d1;
+ cr[3] = *ca * a[(a_dim1 << 1) + 2] - *wr * *d2;
+ if (*ltrans) {
+ cr[2] = *ca * a[a_dim1 + 2];
+ cr[1] = *ca * a[(a_dim1 << 1) + 1];
+ } else {
+ cr[1] = *ca * a[a_dim1 + 2];
+ cr[2] = *ca * a[(a_dim1 << 1) + 1];
+ }
+
+ if (*nw == 1) {
+
+/* Real 2x2 system (w is real) */
+
+/* Find the largest element in C */
+
+ cmax = 0.;
+ icmax = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ if ((d__1 = crv[j - 1], abs(d__1)) > cmax) {
+ cmax = (d__1 = crv[j - 1], abs(d__1));
+ icmax = j;
+ }
+/* L10: */
+ }
+
+/* If norm(C) < SMINI, use SMINI*identity. */
+
+ if (cmax < smini) {
+/* Computing MAX */
+ d__3 = (d__1 = b[b_dim1 + 1], abs(d__1)), d__4 = (d__2 = b[
+ b_dim1 + 2], abs(d__2));
+ bnorm = max(d__3,d__4);
+ if (smini < 1. && bnorm > 1.) {
+ if (bnorm > bignum * smini) {
+ *scale = 1. / bnorm;
+ }
+ }
+ temp = *scale / smini;
+ x[x_dim1 + 1] = temp * b[b_dim1 + 1];
+ x[x_dim1 + 2] = temp * b[b_dim1 + 2];
+ *xnorm = temp * bnorm;
+ *info = 1;
+ return 0;
+ }
+
+/* Gaussian elimination with complete pivoting. */
+
+ ur11 = crv[icmax - 1];
+ cr21 = crv[ipivot[(icmax << 2) - 3] - 1];
+ ur12 = crv[ipivot[(icmax << 2) - 2] - 1];
+ cr22 = crv[ipivot[(icmax << 2) - 1] - 1];
+ ur11r = 1. / ur11;
+ lr21 = ur11r * cr21;
+ ur22 = cr22 - ur12 * lr21;
+
+/* If smaller pivot < SMINI, use SMINI */
+
+ if (abs(ur22) < smini) {
+ ur22 = smini;
+ *info = 1;
+ }
+ if (rswap[icmax - 1]) {
+ br1 = b[b_dim1 + 2];
+ br2 = b[b_dim1 + 1];
+ } else {
+ br1 = b[b_dim1 + 1];
+ br2 = b[b_dim1 + 2];
+ }
+ br2 -= lr21 * br1;
+/* Computing MAX */
+ d__2 = (d__1 = br1 * (ur22 * ur11r), abs(d__1)), d__3 = abs(br2);
+ bbnd = max(d__2,d__3);
+ if (bbnd > 1. && abs(ur22) < 1.) {
+ if (bbnd >= bignum * abs(ur22)) {
+ *scale = 1. / bbnd;
+ }
+ }
+
+ xr2 = br2 * *scale / ur22;
+ xr1 = *scale * br1 * ur11r - xr2 * (ur11r * ur12);
+ if (zswap[icmax - 1]) {
+ x[x_dim1 + 1] = xr2;
+ x[x_dim1 + 2] = xr1;
+ } else {
+ x[x_dim1 + 1] = xr1;
+ x[x_dim1 + 2] = xr2;
+ }
+/* Computing MAX */
+ d__1 = abs(xr1), d__2 = abs(xr2);
+ *xnorm = max(d__1,d__2);
+
+/* Further scaling if norm(A) norm(X) > overflow */
+
+ if (*xnorm > 1. && cmax > 1.) {
+ if (*xnorm > bignum / cmax) {
+ temp = cmax / bignum;
+ x[x_dim1 + 1] = temp * x[x_dim1 + 1];
+ x[x_dim1 + 2] = temp * x[x_dim1 + 2];
+ *xnorm = temp * *xnorm;
+ *scale = temp * *scale;
+ }
+ }
+ } else {
+
+/* Complex 2x2 system (w is complex) */
+
+/* Find the largest element in C */
+
+ ci[0] = -(*wi) * *d1;
+ ci[1] = 0.;
+ ci[2] = 0.;
+ ci[3] = -(*wi) * *d2;
+ cmax = 0.;
+ icmax = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ if ((d__1 = crv[j - 1], abs(d__1)) + (d__2 = civ[j - 1], abs(
+ d__2)) > cmax) {
+ cmax = (d__1 = crv[j - 1], abs(d__1)) + (d__2 = civ[j - 1]
+ , abs(d__2));
+ icmax = j;
+ }
+/* L20: */
+ }
+
+/* If norm(C) < SMINI, use SMINI*identity. */
+
+ if (cmax < smini) {
+/* Computing MAX */
+ d__5 = (d__1 = b[b_dim1 + 1], abs(d__1)) + (d__2 = b[(b_dim1
+ << 1) + 1], abs(d__2)), d__6 = (d__3 = b[b_dim1 + 2],
+ abs(d__3)) + (d__4 = b[(b_dim1 << 1) + 2], abs(d__4));
+ bnorm = max(d__5,d__6);
+ if (smini < 1. && bnorm > 1.) {
+ if (bnorm > bignum * smini) {
+ *scale = 1. / bnorm;
+ }
+ }
+ temp = *scale / smini;
+ x[x_dim1 + 1] = temp * b[b_dim1 + 1];
+ x[x_dim1 + 2] = temp * b[b_dim1 + 2];
+ x[(x_dim1 << 1) + 1] = temp * b[(b_dim1 << 1) + 1];
+ x[(x_dim1 << 1) + 2] = temp * b[(b_dim1 << 1) + 2];
+ *xnorm = temp * bnorm;
+ *info = 1;
+ return 0;
+ }
+
+/* Gaussian elimination with complete pivoting. */
+
+ ur11 = crv[icmax - 1];
+ ui11 = civ[icmax - 1];
+ cr21 = crv[ipivot[(icmax << 2) - 3] - 1];
+ ci21 = civ[ipivot[(icmax << 2) - 3] - 1];
+ ur12 = crv[ipivot[(icmax << 2) - 2] - 1];
+ ui12 = civ[ipivot[(icmax << 2) - 2] - 1];
+ cr22 = crv[ipivot[(icmax << 2) - 1] - 1];
+ ci22 = civ[ipivot[(icmax << 2) - 1] - 1];
+ if (icmax == 1 || icmax == 4) {
+
+/* Code when off-diagonals of pivoted C are real */
+
+ if (abs(ur11) > abs(ui11)) {
+ temp = ui11 / ur11;
+/* Computing 2nd power */
+ d__1 = temp;
+ ur11r = 1. / (ur11 * (d__1 * d__1 + 1.));
+ ui11r = -temp * ur11r;
+ } else {
+ temp = ur11 / ui11;
+/* Computing 2nd power */
+ d__1 = temp;
+ ui11r = -1. / (ui11 * (d__1 * d__1 + 1.));
+ ur11r = -temp * ui11r;
+ }
+ lr21 = cr21 * ur11r;
+ li21 = cr21 * ui11r;
+ ur12s = ur12 * ur11r;
+ ui12s = ur12 * ui11r;
+ ur22 = cr22 - ur12 * lr21;
+ ui22 = ci22 - ur12 * li21;
+ } else {
+
+/* Code when diagonals of pivoted C are real */
+
+ ur11r = 1. / ur11;
+ ui11r = 0.;
+ lr21 = cr21 * ur11r;
+ li21 = ci21 * ur11r;
+ ur12s = ur12 * ur11r;
+ ui12s = ui12 * ur11r;
+ ur22 = cr22 - ur12 * lr21 + ui12 * li21;
+ ui22 = -ur12 * li21 - ui12 * lr21;
+ }
+ u22abs = abs(ur22) + abs(ui22);
+
+/* If smaller pivot < SMINI, use SMINI */
+
+ if (u22abs < smini) {
+ ur22 = smini;
+ ui22 = 0.;
+ *info = 1;
+ }
+ if (rswap[icmax - 1]) {
+ br2 = b[b_dim1 + 1];
+ br1 = b[b_dim1 + 2];
+ bi2 = b[(b_dim1 << 1) + 1];
+ bi1 = b[(b_dim1 << 1) + 2];
+ } else {
+ br1 = b[b_dim1 + 1];
+ br2 = b[b_dim1 + 2];
+ bi1 = b[(b_dim1 << 1) + 1];
+ bi2 = b[(b_dim1 << 1) + 2];
+ }
+ br2 = br2 - lr21 * br1 + li21 * bi1;
+ bi2 = bi2 - li21 * br1 - lr21 * bi1;
+/* Computing MAX */
+ d__1 = (abs(br1) + abs(bi1)) * (u22abs * (abs(ur11r) + abs(ui11r))
+ ), d__2 = abs(br2) + abs(bi2);
+ bbnd = max(d__1,d__2);
+ if (bbnd > 1. && u22abs < 1.) {
+ if (bbnd >= bignum * u22abs) {
+ *scale = 1. / bbnd;
+ br1 = *scale * br1;
+ bi1 = *scale * bi1;
+ br2 = *scale * br2;
+ bi2 = *scale * bi2;
+ }
+ }
+
+ dladiv_(&br2, &bi2, &ur22, &ui22, &xr2, &xi2);
+ xr1 = ur11r * br1 - ui11r * bi1 - ur12s * xr2 + ui12s * xi2;
+ xi1 = ui11r * br1 + ur11r * bi1 - ui12s * xr2 - ur12s * xi2;
+ if (zswap[icmax - 1]) {
+ x[x_dim1 + 1] = xr2;
+ x[x_dim1 + 2] = xr1;
+ x[(x_dim1 << 1) + 1] = xi2;
+ x[(x_dim1 << 1) + 2] = xi1;
+ } else {
+ x[x_dim1 + 1] = xr1;
+ x[x_dim1 + 2] = xr2;
+ x[(x_dim1 << 1) + 1] = xi1;
+ x[(x_dim1 << 1) + 2] = xi2;
+ }
+/* Computing MAX */
+ d__1 = abs(xr1) + abs(xi1), d__2 = abs(xr2) + abs(xi2);
+ *xnorm = max(d__1,d__2);
+
+/* Further scaling if norm(A) norm(X) > overflow */
+
+ if (*xnorm > 1. && cmax > 1.) {
+ if (*xnorm > bignum / cmax) {
+ temp = cmax / bignum;
+ x[x_dim1 + 1] = temp * x[x_dim1 + 1];
+ x[x_dim1 + 2] = temp * x[x_dim1 + 2];
+ x[(x_dim1 << 1) + 1] = temp * x[(x_dim1 << 1) + 1];
+ x[(x_dim1 << 1) + 2] = temp * x[(x_dim1 << 1) + 2];
+ *xnorm = temp * *xnorm;
+ *scale = temp * *scale;
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DLALN2 */
+
+} /* dlaln2_ */
+
+#undef crv
+#undef civ
+#undef cr
+#undef ci
diff --git a/SRC/dlals0.c b/SRC/dlals0.c
new file mode 100644
index 0000000..9f55866
--- /dev/null
+++ b/SRC/dlals0.c
@@ -0,0 +1,473 @@
+/* dlals0.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b5 = -1.;
+static integer c__1 = 1;
+static doublereal c_b11 = 1.;
+static doublereal c_b13 = 0.;
+static integer c__0 = 0;
+
+/* Subroutine */ int dlals0_(integer *icompq, integer *nl, integer *nr,
+ integer *sqre, integer *nrhs, doublereal *b, integer *ldb, doublereal
+ *bx, integer *ldbx, integer *perm, integer *givptr, integer *givcol,
+ integer *ldgcol, doublereal *givnum, integer *ldgnum, doublereal *
+ poles, doublereal *difl, doublereal *difr, doublereal *z__, integer *
+ k, doublereal *c__, doublereal *s, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer givcol_dim1, givcol_offset, b_dim1, b_offset, bx_dim1, bx_offset,
+ difr_dim1, difr_offset, givnum_dim1, givnum_offset, poles_dim1,
+ poles_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, j, m, n;
+ doublereal dj;
+ integer nlp1;
+ doublereal temp;
+ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal diflj, difrj, dsigj;
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dcopy_(integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ extern doublereal dlamc3_(doublereal *, doublereal *);
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), dlacpy_(char *, integer *, integer
+ *, doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ doublereal dsigjp;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLALS0 applies back the multiplying factors of either the left or the */
+/* right singular vector matrix of a diagonal matrix appended by a row */
+/* to the right hand side matrix B in solving the least squares problem */
+/* using the divide-and-conquer SVD approach. */
+
+/* For the left singular vector matrix, three types of orthogonal */
+/* matrices are involved: */
+
+/* (1L) Givens rotations: the number of such rotations is GIVPTR; the */
+/* pairs of columns/rows they were applied to are stored in GIVCOL; */
+/* and the C- and S-values of these rotations are stored in GIVNUM. */
+
+/* (2L) Permutation. The (NL+1)-st row of B is to be moved to the first */
+/* row, and for J=2:N, PERM(J)-th row of B is to be moved to the */
+/* J-th row. */
+
+/* (3L) The left singular vector matrix of the remaining matrix. */
+
+/* For the right singular vector matrix, four types of orthogonal */
+/* matrices are involved: */
+
+/* (1R) The right singular vector matrix of the remaining matrix. */
+
+/* (2R) If SQRE = 1, one extra Givens rotation to generate the right */
+/* null space. */
+
+/* (3R) The inverse transformation of (2L). */
+
+/* (4R) The inverse transformation of (1L). */
+
+/* Arguments */
+/* ========= */
+
+/* ICOMPQ (input) INTEGER */
+/* Specifies whether singular vectors are to be computed in */
+/* factored form: */
+/* = 0: Left singular vector matrix. */
+/* = 1: Right singular vector matrix. */
+
+/* NL (input) INTEGER */
+/* The row dimension of the upper block. NL >= 1. */
+
+/* NR (input) INTEGER */
+/* The row dimension of the lower block. NR >= 1. */
+
+/* SQRE (input) INTEGER */
+/* = 0: the lower block is an NR-by-NR square matrix. */
+/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */
+
+/* The bidiagonal matrix has row dimension N = NL + NR + 1, */
+/* and column dimension M = N + SQRE. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B and BX. NRHS must be at least 1. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS ) */
+/* On input, B contains the right hand sides of the least */
+/* squares problem in rows 1 through M. On output, B contains */
+/* the solution X in rows 1 through N. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB must be at least */
+/* max(1,MAX( M, N ) ). */
+
+/* BX (workspace) DOUBLE PRECISION array, dimension ( LDBX, NRHS ) */
+
+/* LDBX (input) INTEGER */
+/* The leading dimension of BX. */
+
+/* PERM (input) INTEGER array, dimension ( N ) */
+/* The permutations (from deflation and sorting) applied */
+/* to the two blocks. */
+
+/* GIVPTR (input) INTEGER */
+/* The number of Givens rotations which took place in this */
+/* subproblem. */
+
+/* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 ) */
+/* Each pair of numbers indicates a pair of rows/columns */
+/* involved in a Givens rotation. */
+
+/* LDGCOL (input) INTEGER */
+/* The leading dimension of GIVCOL, must be at least N. */
+
+/* GIVNUM (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */
+/* Each number indicates the C or S value used in the */
+/* corresponding Givens rotation. */
+
+/* LDGNUM (input) INTEGER */
+/* The leading dimension of arrays DIFR, POLES and */
+/* GIVNUM, must be at least K. */
+
+/* POLES (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */
+/* On entry, POLES(1:K, 1) contains the new singular */
+/* values obtained from solving the secular equation, and */
+/* POLES(1:K, 2) is an array containing the poles in the secular */
+/* equation. */
+
+/* DIFL (input) DOUBLE PRECISION array, dimension ( K ). */
+/* On entry, DIFL(I) is the distance between I-th updated */
+/* (undeflated) singular value and the I-th (undeflated) old */
+/* singular value. */
+
+/* DIFR (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ). */
+/* On entry, DIFR(I, 1) contains the distances between I-th */
+/* updated (undeflated) singular value and the I+1-th */
+/* (undeflated) old singular value. And DIFR(I, 2) is the */
+/* normalizing factor for the I-th right singular vector. */
+
+/* Z (input) DOUBLE PRECISION array, dimension ( K ) */
+/* Contain the components of the deflation-adjusted updating row */
+/* vector. */
+
+/* K (input) INTEGER */
+/* Contains the dimension of the non-deflated matrix, */
+/* This is the order of the related secular equation. 1 <= K <=N. */
+
+/* C (input) DOUBLE PRECISION */
+/* C contains garbage if SQRE =0 and the C-value of a Givens */
+/* rotation related to the right null space if SQRE = 1. */
+
+/* S (input) DOUBLE PRECISION */
+/* S contains garbage if SQRE =0 and the S-value of a Givens */
+/* rotation related to the right null space if SQRE = 1. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension ( K ) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */
+/* California at Berkeley, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ bx_dim1 = *ldbx;
+ bx_offset = 1 + bx_dim1;
+ bx -= bx_offset;
+ --perm;
+ givcol_dim1 = *ldgcol;
+ givcol_offset = 1 + givcol_dim1;
+ givcol -= givcol_offset;
+ difr_dim1 = *ldgnum;
+ difr_offset = 1 + difr_dim1;
+ difr -= difr_offset;
+ poles_dim1 = *ldgnum;
+ poles_offset = 1 + poles_dim1;
+ poles -= poles_offset;
+ givnum_dim1 = *ldgnum;
+ givnum_offset = 1 + givnum_dim1;
+ givnum -= givnum_offset;
+ --difl;
+ --z__;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*icompq < 0 || *icompq > 1) {
+ *info = -1;
+ } else if (*nl < 1) {
+ *info = -2;
+ } else if (*nr < 1) {
+ *info = -3;
+ } else if (*sqre < 0 || *sqre > 1) {
+ *info = -4;
+ }
+
+ n = *nl + *nr + 1;
+
+ if (*nrhs < 1) {
+ *info = -5;
+ } else if (*ldb < n) {
+ *info = -7;
+ } else if (*ldbx < n) {
+ *info = -9;
+ } else if (*givptr < 0) {
+ *info = -11;
+ } else if (*ldgcol < n) {
+ *info = -13;
+ } else if (*ldgnum < n) {
+ *info = -15;
+ } else if (*k < 1) {
+ *info = -20;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLALS0", &i__1);
+ return 0;
+ }
+
+ m = n + *sqre;
+ nlp1 = *nl + 1;
+
+ if (*icompq == 0) {
+
+/* Apply back orthogonal transformations from the left. */
+
+/* Step (1L): apply back the Givens rotations performed. */
+
+ i__1 = *givptr;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ drot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, &
+ b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ +
+ (givnum_dim1 << 1)], &givnum[i__ + givnum_dim1]);
+/* L10: */
+ }
+
+/* Step (2L): permute rows of B. */
+
+ dcopy_(nrhs, &b[nlp1 + b_dim1], ldb, &bx[bx_dim1 + 1], ldbx);
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ dcopy_(nrhs, &b[perm[i__] + b_dim1], ldb, &bx[i__ + bx_dim1],
+ ldbx);
+/* L20: */
+ }
+
+/* Step (3L): apply the inverse of the left singular vector */
+/* matrix to BX. */
+
+ if (*k == 1) {
+ dcopy_(nrhs, &bx[bx_offset], ldbx, &b[b_offset], ldb);
+ if (z__[1] < 0.) {
+ dscal_(nrhs, &c_b5, &b[b_offset], ldb);
+ }
+ } else {
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ diflj = difl[j];
+ dj = poles[j + poles_dim1];
+ dsigj = -poles[j + (poles_dim1 << 1)];
+ if (j < *k) {
+ difrj = -difr[j + difr_dim1];
+ dsigjp = -poles[j + 1 + (poles_dim1 << 1)];
+ }
+ if (z__[j] == 0. || poles[j + (poles_dim1 << 1)] == 0.) {
+ work[j] = 0.;
+ } else {
+ work[j] = -poles[j + (poles_dim1 << 1)] * z__[j] / diflj /
+ (poles[j + (poles_dim1 << 1)] + dj);
+ }
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] ==
+ 0.) {
+ work[i__] = 0.;
+ } else {
+ work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__]
+ / (dlamc3_(&poles[i__ + (poles_dim1 << 1)], &
+ dsigj) - diflj) / (poles[i__ + (poles_dim1 <<
+ 1)] + dj);
+ }
+/* L30: */
+ }
+ i__2 = *k;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] ==
+ 0.) {
+ work[i__] = 0.;
+ } else {
+ work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__]
+ / (dlamc3_(&poles[i__ + (poles_dim1 << 1)], &
+ dsigjp) + difrj) / (poles[i__ + (poles_dim1 <<
+ 1)] + dj);
+ }
+/* L40: */
+ }
+ work[1] = -1.;
+ temp = dnrm2_(k, &work[1], &c__1);
+ dgemv_("T", k, nrhs, &c_b11, &bx[bx_offset], ldbx, &work[1], &
+ c__1, &c_b13, &b[j + b_dim1], ldb);
+ dlascl_("G", &c__0, &c__0, &temp, &c_b11, &c__1, nrhs, &b[j +
+ b_dim1], ldb, info);
+/* L50: */
+ }
+ }
+
+/* Move the deflated rows of BX to B also. */
+
+ if (*k < max(m,n)) {
+ i__1 = n - *k;
+ dlacpy_("A", &i__1, nrhs, &bx[*k + 1 + bx_dim1], ldbx, &b[*k + 1
+ + b_dim1], ldb);
+ }
+ } else {
+
+/* Apply back the right orthogonal transformations. */
+
+/* Step (1R): apply back the new right singular vector matrix */
+/* to B. */
+
+ if (*k == 1) {
+ dcopy_(nrhs, &b[b_offset], ldb, &bx[bx_offset], ldbx);
+ } else {
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ dsigj = poles[j + (poles_dim1 << 1)];
+ if (z__[j] == 0.) {
+ work[j] = 0.;
+ } else {
+ work[j] = -z__[j] / difl[j] / (dsigj + poles[j +
+ poles_dim1]) / difr[j + (difr_dim1 << 1)];
+ }
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (z__[j] == 0.) {
+ work[i__] = 0.;
+ } else {
+ d__1 = -poles[i__ + 1 + (poles_dim1 << 1)];
+ work[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difr[
+ i__ + difr_dim1]) / (dsigj + poles[i__ +
+ poles_dim1]) / difr[i__ + (difr_dim1 << 1)];
+ }
+/* L60: */
+ }
+ i__2 = *k;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ if (z__[j] == 0.) {
+ work[i__] = 0.;
+ } else {
+ d__1 = -poles[i__ + (poles_dim1 << 1)];
+ work[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difl[
+ i__]) / (dsigj + poles[i__ + poles_dim1]) /
+ difr[i__ + (difr_dim1 << 1)];
+ }
+/* L70: */
+ }
+ dgemv_("T", k, nrhs, &c_b11, &b[b_offset], ldb, &work[1], &
+ c__1, &c_b13, &bx[j + bx_dim1], ldbx);
+/* L80: */
+ }
+ }
+
+/* Step (2R): if SQRE = 1, apply back the rotation that is */
+/* related to the right null space of the subproblem. */
+
+ if (*sqre == 1) {
+ dcopy_(nrhs, &b[m + b_dim1], ldb, &bx[m + bx_dim1], ldbx);
+ drot_(nrhs, &bx[bx_dim1 + 1], ldbx, &bx[m + bx_dim1], ldbx, c__,
+ s);
+ }
+ if (*k < max(m,n)) {
+ i__1 = n - *k;
+ dlacpy_("A", &i__1, nrhs, &b[*k + 1 + b_dim1], ldb, &bx[*k + 1 +
+ bx_dim1], ldbx);
+ }
+
+/* Step (3R): permute rows of B. */
+
+ dcopy_(nrhs, &bx[bx_dim1 + 1], ldbx, &b[nlp1 + b_dim1], ldb);
+ if (*sqre == 1) {
+ dcopy_(nrhs, &bx[m + bx_dim1], ldbx, &b[m + b_dim1], ldb);
+ }
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ dcopy_(nrhs, &bx[i__ + bx_dim1], ldbx, &b[perm[i__] + b_dim1],
+ ldb);
+/* L90: */
+ }
+
+/* Step (4R): apply back the Givens rotations performed. */
+
+ for (i__ = *givptr; i__ >= 1; --i__) {
+ d__1 = -givnum[i__ + givnum_dim1];
+ drot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, &
+ b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ +
+ (givnum_dim1 << 1)], &d__1);
+/* L100: */
+ }
+ }
+
+ return 0;
+
+/* End of DLALS0 */
+
+} /* dlals0_ */
diff --git a/SRC/dlalsa.c b/SRC/dlalsa.c
new file mode 100644
index 0000000..7c01dee
--- /dev/null
+++ b/SRC/dlalsa.c
@@ -0,0 +1,456 @@
+/* dlalsa.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b7 = 1.;
+static doublereal c_b8 = 0.;
+static integer c__2 = 2;
+
+/* Subroutine */ int dlalsa_(integer *icompq, integer *smlsiz, integer *n,
+ integer *nrhs, doublereal *b, integer *ldb, doublereal *bx, integer *
+ ldbx, doublereal *u, integer *ldu, doublereal *vt, integer *k,
+ doublereal *difl, doublereal *difr, doublereal *z__, doublereal *
+ poles, integer *givptr, integer *givcol, integer *ldgcol, integer *
+ perm, doublereal *givnum, doublereal *c__, doublereal *s, doublereal *
+ work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, b_dim1,
+ b_offset, bx_dim1, bx_offset, difl_dim1, difl_offset, difr_dim1,
+ difr_offset, givnum_dim1, givnum_offset, poles_dim1, poles_offset,
+ u_dim1, u_offset, vt_dim1, vt_offset, z_dim1, z_offset, i__1,
+ i__2;
+
+ /* Builtin functions */
+ integer pow_ii(integer *, integer *);
+
+ /* Local variables */
+ integer i__, j, i1, ic, lf, nd, ll, nl, nr, im1, nlf, nrf, lvl, ndb1,
+ nlp1, lvl2, nrp1, nlvl, sqre;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ integer inode, ndiml, ndimr;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dlals0_(integer *, integer *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *, integer *, integer *, integer *, doublereal
+ *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *), dlasdt_(integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLALSA is an itermediate step in solving the least squares problem */
+/* by computing the SVD of the coefficient matrix in compact form (The */
+/* singular vectors are computed as products of simple orthorgonal */
+/* matrices.). */
+
+/* If ICOMPQ = 0, DLALSA applies the inverse of the left singular vector */
+/* matrix of an upper bidiagonal matrix to the right hand side; and if */
+/* ICOMPQ = 1, DLALSA applies the right singular vector matrix to the */
+/* right hand side. The singular vector matrices were generated in */
+/* compact form by DLALSA. */
+
+/* Arguments */
+/* ========= */
+
+
+/* ICOMPQ (input) INTEGER */
+/* Specifies whether the left or the right singular vector */
+/* matrix is involved. */
+/* = 0: Left singular vector matrix */
+/* = 1: Right singular vector matrix */
+
+/* SMLSIZ (input) INTEGER */
+/* The maximum size of the subproblems at the bottom of the */
+/* computation tree. */
+
+/* N (input) INTEGER */
+/* The row and column dimensions of the upper bidiagonal matrix. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B and BX. NRHS must be at least 1. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS ) */
+/* On input, B contains the right hand sides of the least */
+/* squares problem in rows 1 through M. */
+/* On output, B contains the solution X in rows 1 through N. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B in the calling subprogram. */
+/* LDB must be at least max(1,MAX( M, N ) ). */
+
+/* BX (output) DOUBLE PRECISION array, dimension ( LDBX, NRHS ) */
+/* On exit, the result of applying the left or right singular */
+/* vector matrix to B. */
+
+/* LDBX (input) INTEGER */
+/* The leading dimension of BX. */
+
+/* U (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ). */
+/* On entry, U contains the left singular vector matrices of all */
+/* subproblems at the bottom level. */
+
+/* LDU (input) INTEGER, LDU = > N. */
+/* The leading dimension of arrays U, VT, DIFL, DIFR, */
+/* POLES, GIVNUM, and Z. */
+
+/* VT (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ). */
+/* On entry, VT' contains the right singular vector matrices of */
+/* all subproblems at the bottom level. */
+
+/* K (input) INTEGER array, dimension ( N ). */
+
+/* DIFL (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ). */
+/* where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1. */
+
+/* DIFR (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). */
+/* On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record */
+/* distances between singular values on the I-th level and */
+/* singular values on the (I -1)-th level, and DIFR(*, 2 * I) */
+/* record the normalizing factors of the right singular vectors */
+/* matrices of subproblems on I-th level. */
+
+/* Z (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ). */
+/* On entry, Z(1, I) contains the components of the deflation- */
+/* adjusted updating row vector for subproblems on the I-th */
+/* level. */
+
+/* POLES (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). */
+/* On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old */
+/* singular values involved in the secular equations on the I-th */
+/* level. */
+
+/* GIVPTR (input) INTEGER array, dimension ( N ). */
+/* On entry, GIVPTR( I ) records the number of Givens */
+/* rotations performed on the I-th problem on the computation */
+/* tree. */
+
+/* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ). */
+/* On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the */
+/* locations of Givens rotations performed on the I-th level on */
+/* the computation tree. */
+
+/* LDGCOL (input) INTEGER, LDGCOL = > N. */
+/* The leading dimension of arrays GIVCOL and PERM. */
+
+/* PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ). */
+/* On entry, PERM(*, I) records permutations done on the I-th */
+/* level of the computation tree. */
+
+/* GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). */
+/* On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S- */
+/* values of Givens rotations performed on the I-th level on the */
+/* computation tree. */
+
+/* C (input) DOUBLE PRECISION array, dimension ( N ). */
+/* On entry, if the I-th subproblem is not square, */
+/* C( I ) contains the C-value of a Givens rotation related to */
+/* the right null space of the I-th subproblem. */
+
+/* S (input) DOUBLE PRECISION array, dimension ( N ). */
+/* On entry, if the I-th subproblem is not square, */
+/* S( I ) contains the S-value of a Givens rotation related to */
+/* the right null space of the I-th subproblem. */
+
+/* WORK (workspace) DOUBLE PRECISION array. */
+/* The dimension must be at least N. */
+
+/* IWORK (workspace) INTEGER array. */
+/* The dimension must be at least 3 * N */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */
+/* California at Berkeley, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ bx_dim1 = *ldbx;
+ bx_offset = 1 + bx_dim1;
+ bx -= bx_offset;
+ givnum_dim1 = *ldu;
+ givnum_offset = 1 + givnum_dim1;
+ givnum -= givnum_offset;
+ poles_dim1 = *ldu;
+ poles_offset = 1 + poles_dim1;
+ poles -= poles_offset;
+ z_dim1 = *ldu;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ difr_dim1 = *ldu;
+ difr_offset = 1 + difr_dim1;
+ difr -= difr_offset;
+ difl_dim1 = *ldu;
+ difl_offset = 1 + difl_dim1;
+ difl -= difl_offset;
+ vt_dim1 = *ldu;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --k;
+ --givptr;
+ perm_dim1 = *ldgcol;
+ perm_offset = 1 + perm_dim1;
+ perm -= perm_offset;
+ givcol_dim1 = *ldgcol;
+ givcol_offset = 1 + givcol_dim1;
+ givcol -= givcol_offset;
+ --c__;
+ --s;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*icompq < 0 || *icompq > 1) {
+ *info = -1;
+ } else if (*smlsiz < 3) {
+ *info = -2;
+ } else if (*n < *smlsiz) {
+ *info = -3;
+ } else if (*nrhs < 1) {
+ *info = -4;
+ } else if (*ldb < *n) {
+ *info = -6;
+ } else if (*ldbx < *n) {
+ *info = -8;
+ } else if (*ldu < *n) {
+ *info = -10;
+ } else if (*ldgcol < *n) {
+ *info = -19;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLALSA", &i__1);
+ return 0;
+ }
+
+/* Book-keeping and setting up the computation tree. */
+
+ inode = 1;
+ ndiml = inode + *n;
+ ndimr = ndiml + *n;
+
+ dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr],
+ smlsiz);
+
+/* The following code applies back the left singular vector factors. */
+/* For applying back the right singular vector factors, go to 50. */
+
+ if (*icompq == 1) {
+ goto L50;
+ }
+
+/* The nodes on the bottom level of the tree were solved */
+/* by DLASDQ. The corresponding left and right singular vector */
+/* matrices are in explicit form. First apply back the left */
+/* singular vector matrices. */
+
+ ndb1 = (nd + 1) / 2;
+ i__1 = nd;
+ for (i__ = ndb1; i__ <= i__1; ++i__) {
+
+/* IC : center row of each node */
+/* NL : number of rows of left subproblem */
+/* NR : number of rows of right subproblem */
+/* NLF: starting row of the left subproblem */
+/* NRF: starting row of the right subproblem */
+
+ i1 = i__ - 1;
+ ic = iwork[inode + i1];
+ nl = iwork[ndiml + i1];
+ nr = iwork[ndimr + i1];
+ nlf = ic - nl;
+ nrf = ic + 1;
+ dgemm_("T", "N", &nl, nrhs, &nl, &c_b7, &u[nlf + u_dim1], ldu, &b[nlf
+ + b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx);
+ dgemm_("T", "N", &nr, nrhs, &nr, &c_b7, &u[nrf + u_dim1], ldu, &b[nrf
+ + b_dim1], ldb, &c_b8, &bx[nrf + bx_dim1], ldbx);
+/* L10: */
+ }
+
+/* Next copy the rows of B that correspond to unchanged rows */
+/* in the bidiagonal matrix to BX. */
+
+ i__1 = nd;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ic = iwork[inode + i__ - 1];
+ dcopy_(nrhs, &b[ic + b_dim1], ldb, &bx[ic + bx_dim1], ldbx);
+/* L20: */
+ }
+
+/* Finally go through the left singular vector matrices of all */
+/* the other subproblems bottom-up on the tree. */
+
+ j = pow_ii(&c__2, &nlvl);
+ sqre = 0;
+
+ for (lvl = nlvl; lvl >= 1; --lvl) {
+ lvl2 = (lvl << 1) - 1;
+
+/* find the first node LF and last node LL on */
+/* the current level LVL */
+
+ if (lvl == 1) {
+ lf = 1;
+ ll = 1;
+ } else {
+ i__1 = lvl - 1;
+ lf = pow_ii(&c__2, &i__1);
+ ll = (lf << 1) - 1;
+ }
+ i__1 = ll;
+ for (i__ = lf; i__ <= i__1; ++i__) {
+ im1 = i__ - 1;
+ ic = iwork[inode + im1];
+ nl = iwork[ndiml + im1];
+ nr = iwork[ndimr + im1];
+ nlf = ic - nl;
+ nrf = ic + 1;
+ --j;
+ dlals0_(icompq, &nl, &nr, &sqre, nrhs, &bx[nlf + bx_dim1], ldbx, &
+ b[nlf + b_dim1], ldb, &perm[nlf + lvl * perm_dim1], &
+ givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, &
+ givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 *
+ poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf +
+ lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[
+ j], &s[j], &work[1], info);
+/* L30: */
+ }
+/* L40: */
+ }
+ goto L90;
+
+/* ICOMPQ = 1: applying back the right singular vector factors. */
+
+L50:
+
+/* First now go through the right singular vector matrices of all */
+/* the tree nodes top-down. */
+
+ j = 0;
+ i__1 = nlvl;
+ for (lvl = 1; lvl <= i__1; ++lvl) {
+ lvl2 = (lvl << 1) - 1;
+
+/* Find the first node LF and last node LL on */
+/* the current level LVL. */
+
+ if (lvl == 1) {
+ lf = 1;
+ ll = 1;
+ } else {
+ i__2 = lvl - 1;
+ lf = pow_ii(&c__2, &i__2);
+ ll = (lf << 1) - 1;
+ }
+ i__2 = lf;
+ for (i__ = ll; i__ >= i__2; --i__) {
+ im1 = i__ - 1;
+ ic = iwork[inode + im1];
+ nl = iwork[ndiml + im1];
+ nr = iwork[ndimr + im1];
+ nlf = ic - nl;
+ nrf = ic + 1;
+ if (i__ == ll) {
+ sqre = 0;
+ } else {
+ sqre = 1;
+ }
+ ++j;
+ dlals0_(icompq, &nl, &nr, &sqre, nrhs, &b[nlf + b_dim1], ldb, &bx[
+ nlf + bx_dim1], ldbx, &perm[nlf + lvl * perm_dim1], &
+ givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, &
+ givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 *
+ poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf +
+ lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[
+ j], &s[j], &work[1], info);
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* The nodes on the bottom level of the tree were solved */
+/* by DLASDQ. The corresponding right singular vector */
+/* matrices are in explicit form. Apply them back. */
+
+ ndb1 = (nd + 1) / 2;
+ i__1 = nd;
+ for (i__ = ndb1; i__ <= i__1; ++i__) {
+ i1 = i__ - 1;
+ ic = iwork[inode + i1];
+ nl = iwork[ndiml + i1];
+ nr = iwork[ndimr + i1];
+ nlp1 = nl + 1;
+ if (i__ == nd) {
+ nrp1 = nr;
+ } else {
+ nrp1 = nr + 1;
+ }
+ nlf = ic - nl;
+ nrf = ic + 1;
+ dgemm_("T", "N", &nlp1, nrhs, &nlp1, &c_b7, &vt[nlf + vt_dim1], ldu, &
+ b[nlf + b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx);
+ dgemm_("T", "N", &nrp1, nrhs, &nrp1, &c_b7, &vt[nrf + vt_dim1], ldu, &
+ b[nrf + b_dim1], ldb, &c_b8, &bx[nrf + bx_dim1], ldbx);
+/* L80: */
+ }
+
+L90:
+
+ return 0;
+
+/* End of DLALSA */
+
+} /* dlalsa_ */
diff --git a/SRC/dlalsd.c b/SRC/dlalsd.c
new file mode 100644
index 0000000..2e52d50
--- /dev/null
+++ b/SRC/dlalsd.c
@@ -0,0 +1,529 @@
+/* dlalsd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b6 = 0.;
+static integer c__0 = 0;
+static doublereal c_b11 = 1.;
+
+/* Subroutine */ int dlalsd_(char *uplo, integer *smlsiz, integer *n, integer
+ *nrhs, doublereal *d__, doublereal *e, doublereal *b, integer *ldb,
+ doublereal *rcond, integer *rank, doublereal *work, integer *iwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double log(doublereal), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer c__, i__, j, k;
+ doublereal r__;
+ integer s, u, z__;
+ doublereal cs;
+ integer bx;
+ doublereal sn;
+ integer st, vt, nm1, st1;
+ doublereal eps;
+ integer iwk;
+ doublereal tol;
+ integer difl, difr;
+ doublereal rcnd;
+ integer perm, nsub;
+ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ integer nlvl, sqre, bxst;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *),
+ dcopy_(integer *, doublereal *, integer *, doublereal *, integer
+ *);
+ integer poles, sizei, nsize, nwork, icmpq1, icmpq2;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlasda_(integer *, integer *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *), dlalsa_(integer *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *), dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer
+ *, integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *), dlacpy_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *), dlartg_(doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *), dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ integer givcol;
+ extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
+ extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
+ integer *);
+ doublereal orgnrm;
+ integer givnum, givptr, smlszp;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLALSD uses the singular value decomposition of A to solve the least */
+/* squares problem of finding X to minimize the Euclidean norm of each */
+/* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B */
+/* are N-by-NRHS. The solution X overwrites B. */
+
+/* The singular values of A smaller than RCOND times the largest */
+/* singular value are treated as zero in solving the least squares */
+/* problem; in this case a minimum norm solution is returned. */
+/* The actual singular values are returned in D in ascending order. */
+
+/* This code makes very mild assumptions about floating point */
+/* arithmetic. It will work on machines with a guard digit in */
+/* add/subtract, or on those binary machines without guard digits */
+/* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. */
+/* It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': D and E define an upper bidiagonal matrix. */
+/* = 'L': D and E define a lower bidiagonal matrix. */
+
+/* SMLSIZ (input) INTEGER */
+/* The maximum size of the subproblems at the bottom of the */
+/* computation tree. */
+
+/* N (input) INTEGER */
+/* The dimension of the bidiagonal matrix. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS must be at least 1. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry D contains the main diagonal of the bidiagonal */
+/* matrix. On exit, if INFO = 0, D contains its singular values. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* Contains the super-diagonal entries of the bidiagonal matrix. */
+/* On exit, E has been destroyed. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On input, B contains the right hand sides of the least */
+/* squares problem. On output, B contains the solution X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B in the calling subprogram. */
+/* LDB must be at least max(1,N). */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* The singular values of A less than or equal to RCOND times */
+/* the largest singular value are treated as zero in solving */
+/* the least squares problem. If RCOND is negative, */
+/* machine precision is used instead. */
+/* For example, if diag(S)*X=B were the least squares problem, */
+/* where diag(S) is a diagonal matrix of singular values, the */
+/* solution would be X(i) = B(i) / S(i) if S(i) is greater than */
+/* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to */
+/* RCOND*max(S). */
+
+/* RANK (output) INTEGER */
+/* The number of singular values of A greater than RCOND times */
+/* the largest singular value. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension at least */
+/* (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2), */
+/* where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1). */
+
+/* IWORK (workspace) INTEGER array, dimension at least */
+/* (3*N*NLVL + 11*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: The algorithm failed to compute an singular value while */
+/* working on the submatrix lying in rows and columns */
+/* INFO/(N+1) through MOD(INFO,N+1). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */
+/* California at Berkeley, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 1) {
+ *info = -4;
+ } else if (*ldb < 1 || *ldb < *n) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLALSD", &i__1);
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+
+/* Set up the tolerance. */
+
+ if (*rcond <= 0. || *rcond >= 1.) {
+ rcnd = eps;
+ } else {
+ rcnd = *rcond;
+ }
+
+ *rank = 0;
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ } else if (*n == 1) {
+ if (d__[1] == 0.) {
+ dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[b_offset], ldb);
+ } else {
+ *rank = 1;
+ dlascl_("G", &c__0, &c__0, &d__[1], &c_b11, &c__1, nrhs, &b[
+ b_offset], ldb, info);
+ d__[1] = abs(d__[1]);
+ }
+ return 0;
+ }
+
+/* Rotate the matrix if it is lower bidiagonal. */
+
+ if (*(unsigned char *)uplo == 'L') {
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
+ d__[i__] = r__;
+ e[i__] = sn * d__[i__ + 1];
+ d__[i__ + 1] = cs * d__[i__ + 1];
+ if (*nrhs == 1) {
+ drot_(&c__1, &b[i__ + b_dim1], &c__1, &b[i__ + 1 + b_dim1], &
+ c__1, &cs, &sn);
+ } else {
+ work[(i__ << 1) - 1] = cs;
+ work[i__ * 2] = sn;
+ }
+/* L10: */
+ }
+ if (*nrhs > 1) {
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n - 1;
+ for (j = 1; j <= i__2; ++j) {
+ cs = work[(j << 1) - 1];
+ sn = work[j * 2];
+ drot_(&c__1, &b[j + i__ * b_dim1], &c__1, &b[j + 1 + i__ *
+ b_dim1], &c__1, &cs, &sn);
+/* L20: */
+ }
+/* L30: */
+ }
+ }
+ }
+
+/* Scale. */
+
+ nm1 = *n - 1;
+ orgnrm = dlanst_("M", n, &d__[1], &e[1]);
+ if (orgnrm == 0.) {
+ dlaset_("A", n, nrhs, &c_b6, &c_b6, &b[b_offset], ldb);
+ return 0;
+ }
+
+ dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, &c__1, &d__[1], n, info);
+ dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, &nm1, &c__1, &e[1], &nm1,
+ info);
+
+/* If N is smaller than the minimum divide size SMLSIZ, then solve */
+/* the problem with another solver. */
+
+ if (*n <= *smlsiz) {
+ nwork = *n * *n + 1;
+ dlaset_("A", n, n, &c_b6, &c_b11, &work[1], n);
+ dlasdq_("U", &c__0, n, n, &c__0, nrhs, &d__[1], &e[1], &work[1], n, &
+ work[1], n, &b[b_offset], ldb, &work[nwork], info);
+ if (*info != 0) {
+ return 0;
+ }
+ tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1));
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (d__[i__] <= tol) {
+ dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[i__ + b_dim1], ldb);
+ } else {
+ dlascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &b[
+ i__ + b_dim1], ldb, info);
+ ++(*rank);
+ }
+/* L40: */
+ }
+ dgemm_("T", "N", n, nrhs, n, &c_b11, &work[1], n, &b[b_offset], ldb, &
+ c_b6, &work[nwork], n);
+ dlacpy_("A", n, nrhs, &work[nwork], n, &b[b_offset], ldb);
+
+/* Unscale. */
+
+ dlascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n,
+ info);
+ dlasrt_("D", n, &d__[1], info);
+ dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset],
+ ldb, info);
+
+ return 0;
+ }
+
+/* Book-keeping and setting up some constants. */
+
+ nlvl = (integer) (log((doublereal) (*n) / (doublereal) (*smlsiz + 1)) /
+ log(2.)) + 1;
+
+ smlszp = *smlsiz + 1;
+
+ u = 1;
+ vt = *smlsiz * *n + 1;
+ difl = vt + smlszp * *n;
+ difr = difl + nlvl * *n;
+ z__ = difr + (nlvl * *n << 1);
+ c__ = z__ + nlvl * *n;
+ s = c__ + *n;
+ poles = s + *n;
+ givnum = poles + (nlvl << 1) * *n;
+ bx = givnum + (nlvl << 1) * *n;
+ nwork = bx + *n * *nrhs;
+
+ sizei = *n + 1;
+ k = sizei + *n;
+ givptr = k + *n;
+ perm = givptr + *n;
+ givcol = perm + nlvl * *n;
+ iwk = givcol + (nlvl * *n << 1);
+
+ st = 1;
+ sqre = 0;
+ icmpq1 = 1;
+ icmpq2 = 0;
+ nsub = 0;
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((d__1 = d__[i__], abs(d__1)) < eps) {
+ d__[i__] = d_sign(&eps, &d__[i__]);
+ }
+/* L50: */
+ }
+
+ i__1 = nm1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) {
+ ++nsub;
+ iwork[nsub] = st;
+
+/* Subproblem found. First determine its size and then */
+/* apply divide and conquer on it. */
+
+ if (i__ < nm1) {
+
+/* A subproblem with E(I) small for I < NM1. */
+
+ nsize = i__ - st + 1;
+ iwork[sizei + nsub - 1] = nsize;
+ } else if ((d__1 = e[i__], abs(d__1)) >= eps) {
+
+/* A subproblem with E(NM1) not too small but I = NM1. */
+
+ nsize = *n - st + 1;
+ iwork[sizei + nsub - 1] = nsize;
+ } else {
+
+/* A subproblem with E(NM1) small. This implies an */
+/* 1-by-1 subproblem at D(N), which is not solved */
+/* explicitly. */
+
+ nsize = i__ - st + 1;
+ iwork[sizei + nsub - 1] = nsize;
+ ++nsub;
+ iwork[nsub] = *n;
+ iwork[sizei + nsub - 1] = 1;
+ dcopy_(nrhs, &b[*n + b_dim1], ldb, &work[bx + nm1], n);
+ }
+ st1 = st - 1;
+ if (nsize == 1) {
+
+/* This is a 1-by-1 subproblem and is not solved */
+/* explicitly. */
+
+ dcopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n);
+ } else if (nsize <= *smlsiz) {
+
+/* This is a small subproblem and is solved by DLASDQ. */
+
+ dlaset_("A", &nsize, &nsize, &c_b6, &c_b11, &work[vt + st1],
+ n);
+ dlasdq_("U", &c__0, &nsize, &nsize, &c__0, nrhs, &d__[st], &e[
+ st], &work[vt + st1], n, &work[nwork], n, &b[st +
+ b_dim1], ldb, &work[nwork], info);
+ if (*info != 0) {
+ return 0;
+ }
+ dlacpy_("A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx +
+ st1], n);
+ } else {
+
+/* A large problem. Solve it using divide and conquer. */
+
+ dlasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], &
+ work[u + st1], n, &work[vt + st1], &iwork[k + st1], &
+ work[difl + st1], &work[difr + st1], &work[z__ + st1],
+ &work[poles + st1], &iwork[givptr + st1], &iwork[
+ givcol + st1], n, &iwork[perm + st1], &work[givnum +
+ st1], &work[c__ + st1], &work[s + st1], &work[nwork],
+ &iwork[iwk], info);
+ if (*info != 0) {
+ return 0;
+ }
+ bxst = bx + st1;
+ dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b[st + b_dim1], ldb, &
+ work[bxst], n, &work[u + st1], n, &work[vt + st1], &
+ iwork[k + st1], &work[difl + st1], &work[difr + st1],
+ &work[z__ + st1], &work[poles + st1], &iwork[givptr +
+ st1], &iwork[givcol + st1], n, &iwork[perm + st1], &
+ work[givnum + st1], &work[c__ + st1], &work[s + st1],
+ &work[nwork], &iwork[iwk], info);
+ if (*info != 0) {
+ return 0;
+ }
+ }
+ st = i__ + 1;
+ }
+/* L60: */
+ }
+
+/* Apply the singular values and treat the tiny ones as zero. */
+
+ tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1));
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Some of the elements in D can be negative because 1-by-1 */
+/* subproblems were not solved explicitly. */
+
+ if ((d__1 = d__[i__], abs(d__1)) <= tol) {
+ dlaset_("A", &c__1, nrhs, &c_b6, &c_b6, &work[bx + i__ - 1], n);
+ } else {
+ ++(*rank);
+ dlascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &work[
+ bx + i__ - 1], n, info);
+ }
+ d__[i__] = (d__1 = d__[i__], abs(d__1));
+/* L70: */
+ }
+
+/* Now apply back the right singular vectors. */
+
+ icmpq2 = 1;
+ i__1 = nsub;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ st = iwork[i__];
+ st1 = st - 1;
+ nsize = iwork[sizei + i__ - 1];
+ bxst = bx + st1;
+ if (nsize == 1) {
+ dcopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb);
+ } else if (nsize <= *smlsiz) {
+ dgemm_("T", "N", &nsize, nrhs, &nsize, &c_b11, &work[vt + st1], n,
+ &work[bxst], n, &c_b6, &b[st + b_dim1], ldb);
+ } else {
+ dlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b[st +
+ b_dim1], ldb, &work[u + st1], n, &work[vt + st1], &iwork[
+ k + st1], &work[difl + st1], &work[difr + st1], &work[z__
+ + st1], &work[poles + st1], &iwork[givptr + st1], &iwork[
+ givcol + st1], n, &iwork[perm + st1], &work[givnum + st1],
+ &work[c__ + st1], &work[s + st1], &work[nwork], &iwork[
+ iwk], info);
+ if (*info != 0) {
+ return 0;
+ }
+ }
+/* L80: */
+ }
+
+/* Unscale and sort the singular values. */
+
+ dlascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info);
+ dlasrt_("D", n, &d__[1], info);
+ dlascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb,
+ info);
+
+ return 0;
+
+/* End of DLALSD */
+
+} /* dlalsd_ */
diff --git a/SRC/dlamrg.c b/SRC/dlamrg.c
new file mode 100644
index 0000000..ce814be
--- /dev/null
+++ b/SRC/dlamrg.c
@@ -0,0 +1,131 @@
+/* dlamrg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlamrg_(integer *n1, integer *n2, doublereal *a, integer
+ *dtrd1, integer *dtrd2, integer *index)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, ind1, ind2, n1sv, n2sv;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAMRG will create a permutation list which will merge the elements */
+/* of A (which is composed of two independently sorted sets) into a */
+/* single set which is sorted in ascending order. */
+
+/* Arguments */
+/* ========= */
+
+/* N1 (input) INTEGER */
+/* N2 (input) INTEGER */
+/* These arguements contain the respective lengths of the two */
+/* sorted lists to be merged. */
+
+/* A (input) DOUBLE PRECISION array, dimension (N1+N2) */
+/* The first N1 elements of A contain a list of numbers which */
+/* are sorted in either ascending or descending order. Likewise */
+/* for the final N2 elements. */
+
+/* DTRD1 (input) INTEGER */
+/* DTRD2 (input) INTEGER */
+/* These are the strides to be taken through the array A. */
+/* Allowable strides are 1 and -1. They indicate whether a */
+/* subset of A is sorted in ascending (DTRDx = 1) or descending */
+/* (DTRDx = -1) order. */
+
+/* INDEX (output) INTEGER array, dimension (N1+N2) */
+/* On exit this array will contain a permutation such that */
+/* if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be */
+/* sorted in ascending order. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --index;
+ --a;
+
+ /* Function Body */
+ n1sv = *n1;
+ n2sv = *n2;
+ if (*dtrd1 > 0) {
+ ind1 = 1;
+ } else {
+ ind1 = *n1;
+ }
+ if (*dtrd2 > 0) {
+ ind2 = *n1 + 1;
+ } else {
+ ind2 = *n1 + *n2;
+ }
+ i__ = 1;
+/* while ( (N1SV > 0) & (N2SV > 0) ) */
+L10:
+ if (n1sv > 0 && n2sv > 0) {
+ if (a[ind1] <= a[ind2]) {
+ index[i__] = ind1;
+ ++i__;
+ ind1 += *dtrd1;
+ --n1sv;
+ } else {
+ index[i__] = ind2;
+ ++i__;
+ ind2 += *dtrd2;
+ --n2sv;
+ }
+ goto L10;
+ }
+/* end while */
+ if (n1sv == 0) {
+ i__1 = n2sv;
+ for (n1sv = 1; n1sv <= i__1; ++n1sv) {
+ index[i__] = ind2;
+ ++i__;
+ ind2 += *dtrd2;
+/* L20: */
+ }
+ } else {
+/* N2SV .EQ. 0 */
+ i__1 = n1sv;
+ for (n2sv = 1; n2sv <= i__1; ++n2sv) {
+ index[i__] = ind1;
+ ++i__;
+ ind1 += *dtrd1;
+/* L30: */
+ }
+ }
+
+ return 0;
+
+/* End of DLAMRG */
+
+} /* dlamrg_ */
diff --git a/SRC/dlaneg.c b/SRC/dlaneg.c
new file mode 100644
index 0000000..ee37d65
--- /dev/null
+++ b/SRC/dlaneg.c
@@ -0,0 +1,218 @@
+/* dlaneg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer dlaneg_(integer *n, doublereal *d__, doublereal *lld, doublereal *
+ sigma, doublereal *pivmin, integer *r__)
+{
+ /* System generated locals */
+ integer ret_val, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer j;
+ doublereal p, t;
+ integer bj;
+ doublereal tmp;
+ integer neg1, neg2;
+ doublereal bsav, gamma, dplus;
+ extern logical disnan_(doublereal *);
+ integer negcnt;
+ logical sawnan;
+ doublereal dminus;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLANEG computes the Sturm count, the number of negative pivots */
+/* encountered while factoring tridiagonal T - sigma I = L D L^T. */
+/* This implementation works directly on the factors without forming */
+/* the tridiagonal matrix T. The Sturm count is also the number of */
+/* eigenvalues of T less than sigma. */
+
+/* This routine is called from DLARRB. */
+
+/* The current routine does not use the PIVMIN parameter but rather */
+/* requires IEEE-754 propagation of Infinities and NaNs. This */
+/* routine also has no input range restrictions but does require */
+/* default exception handling such that x/0 produces Inf when x is */
+/* non-zero, and Inf/Inf produces NaN. For more information, see: */
+
+/* Marques, Riedy, and Voemel, "Benefits of IEEE-754 Features in */
+/* Modern Symmetric Tridiagonal Eigensolvers," SIAM Journal on */
+/* Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624 */
+/* (Tech report version in LAWN 172 with the same title.) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The N diagonal elements of the diagonal matrix D. */
+
+/* LLD (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (N-1) elements L(i)*L(i)*D(i). */
+
+/* SIGMA (input) DOUBLE PRECISION */
+/* Shift amount in T - sigma I = L D L^T. */
+
+/* PIVMIN (input) DOUBLE PRECISION */
+/* The minimum pivot in the Sturm sequence. May be used */
+/* when zero pivots are encountered on non-IEEE-754 */
+/* architectures. */
+
+/* R (input) INTEGER */
+/* The twist index for the twisted factorization that is used */
+/* for the negcount. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+/* Jason Riedy, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* Some architectures propagate Infinities and NaNs very slowly, so */
+/* the code computes counts in BLKLEN chunks. Then a NaN can */
+/* propagate at most BLKLEN columns before being detected. This is */
+/* not a general tuning parameter; it needs only to be just large */
+/* enough that the overhead is tiny in common cases. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ --lld;
+ --d__;
+
+ /* Function Body */
+ negcnt = 0;
+/* I) upper part: L D L^T - SIGMA I = L+ D+ L+^T */
+ t = -(*sigma);
+ i__1 = *r__ - 1;
+ for (bj = 1; bj <= i__1; bj += 128) {
+ neg1 = 0;
+ bsav = t;
+/* Computing MIN */
+ i__3 = bj + 127, i__4 = *r__ - 1;
+ i__2 = min(i__3,i__4);
+ for (j = bj; j <= i__2; ++j) {
+ dplus = d__[j] + t;
+ if (dplus < 0.) {
+ ++neg1;
+ }
+ tmp = t / dplus;
+ t = tmp * lld[j] - *sigma;
+/* L21: */
+ }
+ sawnan = disnan_(&t);
+/* Run a slower version of the above loop if a NaN is detected. */
+/* A NaN should occur only with a zero pivot after an infinite */
+/* pivot. In that case, substituting 1 for T/DPLUS is the */
+/* correct limit. */
+ if (sawnan) {
+ neg1 = 0;
+ t = bsav;
+/* Computing MIN */
+ i__3 = bj + 127, i__4 = *r__ - 1;
+ i__2 = min(i__3,i__4);
+ for (j = bj; j <= i__2; ++j) {
+ dplus = d__[j] + t;
+ if (dplus < 0.) {
+ ++neg1;
+ }
+ tmp = t / dplus;
+ if (disnan_(&tmp)) {
+ tmp = 1.;
+ }
+ t = tmp * lld[j] - *sigma;
+/* L22: */
+ }
+ }
+ negcnt += neg1;
+/* L210: */
+ }
+
+/* II) lower part: L D L^T - SIGMA I = U- D- U-^T */
+ p = d__[*n] - *sigma;
+ i__1 = *r__;
+ for (bj = *n - 1; bj >= i__1; bj += -128) {
+ neg2 = 0;
+ bsav = p;
+/* Computing MAX */
+ i__3 = bj - 127;
+ i__2 = max(i__3,*r__);
+ for (j = bj; j >= i__2; --j) {
+ dminus = lld[j] + p;
+ if (dminus < 0.) {
+ ++neg2;
+ }
+ tmp = p / dminus;
+ p = tmp * d__[j] - *sigma;
+/* L23: */
+ }
+ sawnan = disnan_(&p);
+/* As above, run a slower version that substitutes 1 for Inf/Inf. */
+
+ if (sawnan) {
+ neg2 = 0;
+ p = bsav;
+/* Computing MAX */
+ i__3 = bj - 127;
+ i__2 = max(i__3,*r__);
+ for (j = bj; j >= i__2; --j) {
+ dminus = lld[j] + p;
+ if (dminus < 0.) {
+ ++neg2;
+ }
+ tmp = p / dminus;
+ if (disnan_(&tmp)) {
+ tmp = 1.;
+ }
+ p = tmp * d__[j] - *sigma;
+/* L24: */
+ }
+ }
+ negcnt += neg2;
+/* L230: */
+ }
+
+/* III) Twist index */
+/* T was shifted by SIGMA initially. */
+ gamma = t + *sigma + p;
+ if (gamma < 0.) {
+ ++negcnt;
+ }
+ ret_val = negcnt;
+ return ret_val;
+} /* dlaneg_ */
diff --git a/SRC/dlangb.c b/SRC/dlangb.c
new file mode 100644
index 0000000..cb12546
--- /dev/null
+++ b/SRC/dlangb.c
@@ -0,0 +1,226 @@
+/* dlangb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal dlangb_(char *norm, integer *n, integer *kl, integer *ku,
+ doublereal *ab, integer *ldab, doublereal *work)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal ret_val, d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, l;
+ doublereal sum, scale;
+ extern logical lsame_(char *, char *);
+ doublereal value;
+ extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLANGB returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of an */
+/* n by n band matrix A, with kl sub-diagonals and ku super-diagonals. */
+
+/* Description */
+/* =========== */
+
+/* DLANGB returns the value */
+
+/* DLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in DLANGB as described */
+/* above. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, DLANGB is */
+/* set to zero. */
+
+/* KL (input) INTEGER */
+/* The number of sub-diagonals of the matrix A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of super-diagonals of the matrix A. KU >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The band matrix A, stored in rows 1 to KL+KU+1. The j-th */
+/* column of A is stored in the j-th column of the array AB as */
+/* follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = *ku + 2 - j;
+/* Computing MIN */
+ i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1;
+ i__3 = min(i__4,i__5);
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1], abs(d__1))
+ ;
+ value = max(d__2,d__3);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.;
+/* Computing MAX */
+ i__3 = *ku + 2 - j;
+/* Computing MIN */
+ i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1;
+ i__2 = min(i__4,i__5);
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+ sum += (d__1 = ab[i__ + j * ab_dim1], abs(d__1));
+/* L30: */
+ }
+ value = max(value,sum);
+/* L40: */
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L50: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ k = *ku + 1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *ku;
+/* Computing MIN */
+ i__5 = *n, i__6 = j + *kl;
+ i__4 = min(i__5,i__6);
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ work[i__] += (d__1 = ab[k + i__ + j * ab_dim1], abs(d__1));
+/* L60: */
+ }
+/* L70: */
+ }
+ value = 0.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = work[i__];
+ value = max(d__1,d__2);
+/* L80: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.;
+ sum = 1.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *ku;
+ l = max(i__4,i__2);
+ k = *ku + 1 - j + l;
+/* Computing MIN */
+ i__2 = *n, i__3 = j + *kl;
+ i__4 = min(i__2,i__3) - l + 1;
+ dlassq_(&i__4, &ab[k + j * ab_dim1], &c__1, &scale, &sum);
+/* L90: */
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of DLANGB */
+
+} /* dlangb_ */
diff --git a/SRC/dlange.c b/SRC/dlange.c
new file mode 100644
index 0000000..34c3039
--- /dev/null
+++ b/SRC/dlange.c
@@ -0,0 +1,199 @@
+/* dlange.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer
+ *lda, doublereal *work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal ret_val, d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal sum, scale;
+ extern logical lsame_(char *, char *);
+ doublereal value;
+ extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLANGE returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* real matrix A. */
+
+/* Description */
+/* =========== */
+
+/* DLANGE returns the value */
+
+/* DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in DLANGE as described */
+/* above. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. When M = 0, */
+/* DLANGE is set to zero. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. When N = 0, */
+/* DLANGE is set to zero. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(M,1). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ if (min(*m,*n) == 0) {
+ value = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ value = max(d__2,d__3);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ sum += (d__1 = a[i__ + j * a_dim1], abs(d__1));
+/* L30: */
+ }
+ value = max(value,sum);
+/* L40: */
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L50: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1));
+/* L60: */
+ }
+/* L70: */
+ }
+ value = 0.;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = work[i__];
+ value = max(d__1,d__2);
+/* L80: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.;
+ sum = 1.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dlassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
+/* L90: */
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of DLANGE */
+
+} /* dlange_ */
diff --git a/SRC/dlangt.c b/SRC/dlangt.c
new file mode 100644
index 0000000..806f39c
--- /dev/null
+++ b/SRC/dlangt.c
@@ -0,0 +1,195 @@
+/* dlangt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal dlangt_(char *norm, integer *n, doublereal *dl, doublereal *d__,
+ doublereal *du)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal ret_val, d__1, d__2, d__3, d__4, d__5;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal sum, scale;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLANGT returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* real tridiagonal matrix A. */
+
+/* Description */
+/* =========== */
+
+/* DLANGT returns the value */
+
+/* DLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in DLANGT as described */
+/* above. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, DLANGT is */
+/* set to zero. */
+
+/* DL (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) sub-diagonal elements of A. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* DU (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) super-diagonal elements of A. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --du;
+ --d__;
+ --dl;
+
+ /* Function Body */
+ if (*n <= 0) {
+ anorm = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ anorm = (d__1 = d__[*n], abs(d__1));
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = anorm, d__3 = (d__1 = dl[i__], abs(d__1));
+ anorm = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = anorm, d__3 = (d__1 = d__[i__], abs(d__1));
+ anorm = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = anorm, d__3 = (d__1 = du[i__], abs(d__1));
+ anorm = max(d__2,d__3);
+/* L10: */
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ if (*n == 1) {
+ anorm = abs(d__[1]);
+ } else {
+/* Computing MAX */
+ d__3 = abs(d__[1]) + abs(dl[1]), d__4 = (d__1 = d__[*n], abs(d__1)
+ ) + (d__2 = du[*n - 1], abs(d__2));
+ anorm = max(d__3,d__4);
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__4 = anorm, d__5 = (d__1 = d__[i__], abs(d__1)) + (d__2 =
+ dl[i__], abs(d__2)) + (d__3 = du[i__ - 1], abs(d__3));
+ anorm = max(d__4,d__5);
+/* L20: */
+ }
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ if (*n == 1) {
+ anorm = abs(d__[1]);
+ } else {
+/* Computing MAX */
+ d__3 = abs(d__[1]) + abs(du[1]), d__4 = (d__1 = d__[*n], abs(d__1)
+ ) + (d__2 = dl[*n - 1], abs(d__2));
+ anorm = max(d__3,d__4);
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__4 = anorm, d__5 = (d__1 = d__[i__], abs(d__1)) + (d__2 =
+ du[i__], abs(d__2)) + (d__3 = dl[i__ - 1], abs(d__3));
+ anorm = max(d__4,d__5);
+/* L30: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.;
+ sum = 1.;
+ dlassq_(n, &d__[1], &c__1, &scale, &sum);
+ if (*n > 1) {
+ i__1 = *n - 1;
+ dlassq_(&i__1, &dl[1], &c__1, &scale, &sum);
+ i__1 = *n - 1;
+ dlassq_(&i__1, &du[1], &c__1, &scale, &sum);
+ }
+ anorm = scale * sqrt(sum);
+ }
+
+ ret_val = anorm;
+ return ret_val;
+
+/* End of DLANGT */
+
+} /* dlangt_ */
diff --git a/SRC/dlanhs.c b/SRC/dlanhs.c
new file mode 100644
index 0000000..35711c0
--- /dev/null
+++ b/SRC/dlanhs.c
@@ -0,0 +1,205 @@
+/* dlanhs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal dlanhs_(char *norm, integer *n, doublereal *a, integer *lda,
+ doublereal *work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val, d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal sum, scale;
+ extern logical lsame_(char *, char *);
+ doublereal value;
+ extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLANHS returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* Hessenberg matrix A. */
+
+/* Description */
+/* =========== */
+
+/* DLANHS returns the value */
+
+/* DLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in DLANHS as described */
+/* above. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, DLANHS is */
+/* set to zero. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The n by n upper Hessenberg matrix A; the part of A below the */
+/* first sub-diagonal is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(N,1). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n, i__4 = j + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ value = max(d__2,d__3);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.;
+/* Computing MIN */
+ i__3 = *n, i__4 = j + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ sum += (d__1 = a[i__ + j * a_dim1], abs(d__1));
+/* L30: */
+ }
+ value = max(value,sum);
+/* L40: */
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L50: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n, i__4 = j + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1));
+/* L60: */
+ }
+/* L70: */
+ }
+ value = 0.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = work[i__];
+ value = max(d__1,d__2);
+/* L80: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.;
+ sum = 1.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n, i__4 = j + 1;
+ i__2 = min(i__3,i__4);
+ dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
+/* L90: */
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of DLANHS */
+
+} /* dlanhs_ */
diff --git a/SRC/dlansb.c b/SRC/dlansb.c
new file mode 100644
index 0000000..d6b9175
--- /dev/null
+++ b/SRC/dlansb.c
@@ -0,0 +1,263 @@
+/* dlansb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal dlansb_(char *norm, char *uplo, integer *n, integer *k, doublereal
+ *ab, integer *ldab, doublereal *work)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val, d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, l;
+ doublereal sum, absa, scale;
+ extern logical lsame_(char *, char *);
+ doublereal value;
+ extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLANSB returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of an */
+/* n by n symmetric band matrix A, with k super-diagonals. */
+
+/* Description */
+/* =========== */
+
+/* DLANSB returns the value */
+
+/* DLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in DLANSB as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* band matrix A is supplied. */
+/* = 'U': Upper triangular part is supplied */
+/* = 'L': Lower triangular part is supplied */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, DLANSB is */
+/* set to zero. */
+
+/* K (input) INTEGER */
+/* The number of super-diagonals or sub-diagonals of the */
+/* band matrix A. K >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The upper or lower triangle of the symmetric band matrix A, */
+/* stored in the first K+1 rows of AB. The j-th column of A is */
+/* stored in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= K+1. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
+/* WORK is not referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ i__3 = *k + 1;
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1], abs(
+ d__1));
+ value = max(d__2,d__3);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *n + 1 - j, i__4 = *k + 1;
+ i__3 = min(i__2,i__4);
+ for (i__ = 1; i__ <= i__3; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1], abs(
+ d__1));
+ value = max(d__2,d__3);
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
+
+/* Find normI(A) ( = norm1(A), since A is symmetric). */
+
+ value = 0.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.;
+ l = *k + 1 - j;
+/* Computing MAX */
+ i__3 = 1, i__2 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__3,i__2); i__ <= i__4; ++i__) {
+ absa = (d__1 = ab[l + i__ + j * ab_dim1], abs(d__1));
+ sum += absa;
+ work[i__] += absa;
+/* L50: */
+ }
+ work[j] = sum + (d__1 = ab[*k + 1 + j * ab_dim1], abs(d__1));
+/* L60: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = work[i__];
+ value = max(d__1,d__2);
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L80: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = work[j] + (d__1 = ab[j * ab_dim1 + 1], abs(d__1));
+ l = 1 - j;
+/* Computing MIN */
+ i__3 = *n, i__2 = j + *k;
+ i__4 = min(i__3,i__2);
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ absa = (d__1 = ab[l + i__ + j * ab_dim1], abs(d__1));
+ sum += absa;
+ work[i__] += absa;
+/* L90: */
+ }
+ value = max(value,sum);
+/* L100: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.;
+ sum = 1.;
+ if (*k > 0) {
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j - 1;
+ i__4 = min(i__3,*k);
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ dlassq_(&i__4, &ab[max(i__2, 1)+ j * ab_dim1], &c__1, &
+ scale, &sum);
+/* L110: */
+ }
+ l = *k + 1;
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n - j;
+ i__4 = min(i__3,*k);
+ dlassq_(&i__4, &ab[j * ab_dim1 + 2], &c__1, &scale, &sum);
+/* L120: */
+ }
+ l = 1;
+ }
+ sum *= 2;
+ } else {
+ l = 1;
+ }
+ dlassq_(n, &ab[l + ab_dim1], ldab, &scale, &sum);
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of DLANSB */
+
+} /* dlansb_ */
diff --git a/SRC/dlansf.c b/SRC/dlansf.c
new file mode 100644
index 0000000..19ce810
--- /dev/null
+++ b/SRC/dlansf.c
@@ -0,0 +1,1012 @@
+/* dlansf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal dlansf_(char *norm, char *transr, char *uplo, integer *n,
+ doublereal *a, doublereal *work)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal ret_val, d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, l;
+ doublereal s;
+ integer n1;
+ doublereal aa;
+ integer lda, ifm, noe, ilu;
+ doublereal scale;
+ extern logical lsame_(char *, char *);
+ doublereal value;
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLANSF returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* real symmetric matrix A in RFP format. */
+
+/* Description */
+/* =========== */
+
+/* DLANSF returns the value */
+
+/* DLANSF = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER */
+/* Specifies the value to be returned in DLANSF as described */
+/* above. */
+
+/* TRANSR (input) CHARACTER */
+/* Specifies whether the RFP format of A is normal or */
+/* transposed format. */
+/* = 'N': RFP format is Normal; */
+/* = 'T': RFP format is Transpose. */
+
+/* UPLO (input) CHARACTER */
+/* On entry, UPLO specifies whether the RFP matrix A came from */
+/* an upper or lower triangular matrix as follows: */
+/* = 'U': RFP A came from an upper triangular matrix; */
+/* = 'L': RFP A came from a lower triangular matrix. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, DLANSF is */
+/* set to zero. */
+
+/* A (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ); */
+/* On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L') */
+/* part of the symmetric matrix A stored in RFP format. See the */
+/* "Notes" below for more details. */
+/* Unchanged on exit. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
+/* WORK is not referenced. */
+
+/* Notes */
+/* ===== */
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* even. We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* the transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* the transpose of the last three columns of AP lower. */
+/* This covers the case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 03 04 05 33 43 53 */
+/* 13 14 15 00 44 54 */
+/* 23 24 25 10 11 55 */
+/* 33 34 35 20 21 22 */
+/* 00 44 45 30 31 32 */
+/* 01 11 55 40 41 42 */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* odd. We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* the transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* the transpose of the last two columns of AP lower. */
+/* This covers the case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 02 03 04 00 33 43 */
+/* 12 13 14 10 11 44 */
+/* 22 23 24 20 21 22 */
+/* 00 33 34 30 31 32 */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+/* RFP A RFP A */
+
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* Reference */
+/* ========= */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (*n == 0) {
+ ret_val = 0.;
+ return ret_val;
+ }
+
+/* set noe = 1 if n is odd. if n is even set noe=0 */
+
+ noe = 1;
+ if (*n % 2 == 0) {
+ noe = 0;
+ }
+
+/* set ifm = 0 when form='T or 't' and 1 otherwise */
+
+ ifm = 1;
+ if (lsame_(transr, "T")) {
+ ifm = 0;
+ }
+
+/* set ilu = 0 when uplo='U or 'u' and 1 otherwise */
+
+ ilu = 1;
+ if (lsame_(uplo, "U")) {
+ ilu = 0;
+ }
+
+/* set lda = (n+1)/2 when ifm = 0 */
+/* set lda = n when ifm = 1 and noe = 1 */
+/* set lda = n+1 when ifm = 1 and noe = 0 */
+
+ if (ifm == 1) {
+ if (noe == 1) {
+ lda = *n;
+ } else {
+/* noe=0 */
+ lda = *n + 1;
+ }
+ } else {
+/* ifm=0 */
+ lda = (*n + 1) / 2;
+ }
+
+ if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ k = (*n + 1) / 2;
+ value = 0.;
+ if (noe == 1) {
+/* n is odd */
+ if (ifm == 1) {
+/* A is n by k */
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = a[i__ + j * lda], abs(
+ d__1));
+ value = max(d__2,d__3);
+ }
+ }
+ } else {
+/* xpose case; A is k by n */
+ i__1 = *n - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = a[i__ + j * lda], abs(
+ d__1));
+ value = max(d__2,d__3);
+ }
+ }
+ }
+ } else {
+/* n is even */
+ if (ifm == 1) {
+/* A is n+1 by k */
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = a[i__ + j * lda], abs(
+ d__1));
+ value = max(d__2,d__3);
+ }
+ }
+ } else {
+/* xpose case; A is k by n+1 */
+ i__1 = *n;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = a[i__ + j * lda], abs(
+ d__1));
+ value = max(d__2,d__3);
+ }
+ }
+ }
+ }
+ } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
+
+/* Find normI(A) ( = norm1(A), since A is symmetric). */
+
+ if (ifm == 1) {
+ k = *n / 2;
+ if (noe == 1) {
+/* n is odd */
+ if (ilu == 0) {
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+ }
+ i__1 = k;
+ for (j = 0; j <= i__1; ++j) {
+ s = 0.;
+ i__2 = k + j - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* -> A(i,j+k) */
+ s += aa;
+ work[i__] += aa;
+ }
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* -> A(j+k,j+k) */
+ work[j + k] = s + aa;
+ if (i__ == k + k) {
+ goto L10;
+ }
+ ++i__;
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* -> A(j,j) */
+ work[j] += aa;
+ s = 0.;
+ i__2 = k - 1;
+ for (l = j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* -> A(l,j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[j] += s;
+ }
+L10:
+ i__ = idamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ } else {
+/* ilu = 1 */
+ ++k;
+/* k=(n+1)/2 for n odd and ilu=1 */
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+ }
+ for (j = k - 1; j >= 0; --j) {
+ s = 0.;
+ i__1 = j - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* -> A(j+k,i+k) */
+ s += aa;
+ work[i__ + k] += aa;
+ }
+ if (j > 0) {
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* -> A(j+k,j+k) */
+ s += aa;
+ work[i__ + k] += s;
+/* i=j */
+ ++i__;
+ }
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* -> A(j,j) */
+ work[j] = aa;
+ s = 0.;
+ i__1 = *n - 1;
+ for (l = j + 1; l <= i__1; ++l) {
+ ++i__;
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* -> A(l,j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[j] += s;
+ }
+ i__ = idamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ }
+ } else {
+/* n is even */
+ if (ilu == 0) {
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+ }
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ s = 0.;
+ i__2 = k + j - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* -> A(i,j+k) */
+ s += aa;
+ work[i__] += aa;
+ }
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* -> A(j+k,j+k) */
+ work[j + k] = s + aa;
+ ++i__;
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* -> A(j,j) */
+ work[j] += aa;
+ s = 0.;
+ i__2 = k - 1;
+ for (l = j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* -> A(l,j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[j] += s;
+ }
+ i__ = idamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ } else {
+/* ilu = 1 */
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+ }
+ for (j = k - 1; j >= 0; --j) {
+ s = 0.;
+ i__1 = j - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* -> A(j+k,i+k) */
+ s += aa;
+ work[i__ + k] += aa;
+ }
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* -> A(j+k,j+k) */
+ s += aa;
+ work[i__ + k] += s;
+/* i=j */
+ ++i__;
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* -> A(j,j) */
+ work[j] = aa;
+ s = 0.;
+ i__1 = *n - 1;
+ for (l = j + 1; l <= i__1; ++l) {
+ ++i__;
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* -> A(l,j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[j] += s;
+ }
+ i__ = idamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ }
+ }
+ } else {
+/* ifm=0 */
+ k = *n / 2;
+ if (noe == 1) {
+/* n is odd */
+ if (ilu == 0) {
+ n1 = k;
+/* n/2 */
+ ++k;
+/* k is the row size and lda */
+ i__1 = *n - 1;
+ for (i__ = n1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+ }
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ s = 0.;
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(j,n1+i) */
+ work[i__ + n1] += aa;
+ s += aa;
+ }
+ work[j] = s;
+ }
+/* j=n1=k-1 is special */
+ s = (d__1 = a[j * lda], abs(d__1));
+/* A(k-1,k-1) */
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(k-1,i+n1) */
+ work[i__ + n1] += aa;
+ s += aa;
+ }
+ work[j] += s;
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+ s = 0.;
+ i__2 = j - k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(i,j-k) */
+ work[i__] += aa;
+ s += aa;
+ }
+/* i=j-k */
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(j-k,j-k) */
+ s += aa;
+ work[j - k] += s;
+ ++i__;
+ s = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(j,j) */
+ i__2 = *n - 1;
+ for (l = j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(j,l) */
+ work[l] += aa;
+ s += aa;
+ }
+ work[j] += s;
+ }
+ i__ = idamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ } else {
+/* ilu=1 */
+ ++k;
+/* k=(n+1)/2 for n odd and ilu=1 */
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+/* process */
+ s = 0.;
+ i__2 = j - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(j,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* i=j so process of A(j,j) */
+ s += aa;
+ work[j] = s;
+/* is initialised here */
+ ++i__;
+/* i=j process A(j+k,j+k) */
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+ s = aa;
+ i__2 = *n - 1;
+ for (l = k + j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(l,k+j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[k + j] += s;
+ }
+/* j=k-1 is special :process col A(k-1,0:k-1) */
+ s = 0.;
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(k,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+/* i=k-1 */
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(k-1,k-1) */
+ s += aa;
+ work[i__] = s;
+/* done with col j=k+1 */
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+/* process col j of A = A(j,0:k-1) */
+ s = 0.;
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(j,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+ work[j] += s;
+ }
+ i__ = idamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ }
+ } else {
+/* n is even */
+ if (ilu == 0) {
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+ }
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ s = 0.;
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(j,i+k) */
+ work[i__ + k] += aa;
+ s += aa;
+ }
+ work[j] = s;
+ }
+/* j=k */
+ aa = (d__1 = a[j * lda], abs(d__1));
+/* A(k,k) */
+ s = aa;
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(k,k+i) */
+ work[i__ + k] += aa;
+ s += aa;
+ }
+ work[j] += s;
+ i__1 = *n - 1;
+ for (j = k + 1; j <= i__1; ++j) {
+ s = 0.;
+ i__2 = j - 2 - k;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(i,j-k-1) */
+ work[i__] += aa;
+ s += aa;
+ }
+/* i=j-1-k */
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(j-k-1,j-k-1) */
+ s += aa;
+ work[j - k - 1] += s;
+ ++i__;
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(j,j) */
+ s = aa;
+ i__2 = *n - 1;
+ for (l = j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(j,l) */
+ work[l] += aa;
+ s += aa;
+ }
+ work[j] += s;
+ }
+/* j=n */
+ s = 0.;
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(i,k-1) */
+ work[i__] += aa;
+ s += aa;
+ }
+/* i=k-1 */
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(k-1,k-1) */
+ s += aa;
+ work[i__] += s;
+ i__ = idamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ } else {
+/* ilu=1 */
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+ }
+/* j=0 is special :process col A(k:n-1,k) */
+ s = abs(a[0]);
+/* A(k,k) */
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ aa = (d__1 = a[i__], abs(d__1));
+/* A(k+i,k) */
+ work[i__ + k] += aa;
+ s += aa;
+ }
+ work[k] += s;
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* process */
+ s = 0.;
+ i__2 = j - 2;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(j-1,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* i=j-1 so process of A(j-1,j-1) */
+ s += aa;
+ work[j - 1] = s;
+/* is initialised here */
+ ++i__;
+/* i=j process A(j+k,j+k) */
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+ s = aa;
+ i__2 = *n - 1;
+ for (l = k + j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(l,k+j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[k + j] += s;
+ }
+/* j=k is special :process col A(k,0:k-1) */
+ s = 0.;
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(k,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+/* i=k-1 */
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(k-1,k-1) */
+ s += aa;
+ work[i__] = s;
+/* done with col j=k+1 */
+ i__1 = *n;
+ for (j = k + 1; j <= i__1; ++j) {
+/* process col j-1 of A = A(j-1,0:k-1) */
+ s = 0.;
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = (d__1 = a[i__ + j * lda], abs(d__1));
+/* A(j-1,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+ work[j - 1] += s;
+ }
+ i__ = idamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ }
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ k = (*n + 1) / 2;
+ scale = 0.;
+ s = 1.;
+ if (noe == 1) {
+/* n is odd */
+ if (ifm == 1) {
+/* A is normal */
+ if (ilu == 0) {
+/* A is upper */
+ i__1 = k - 3;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 2;
+ dlassq_(&i__2, &a[k + j + 1 + j * lda], &c__1, &scale,
+ &s);
+/* L at A(k,0) */
+ }
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k + j - 1;
+ dlassq_(&i__2, &a[j * lda], &c__1, &scale, &s);
+/* trap U at A(0,0) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ i__1 = k - 1;
+ i__2 = lda + 1;
+ dlassq_(&i__1, &a[k], &i__2, &scale, &s);
+/* tri L at A(k,0) */
+ i__1 = lda + 1;
+ dlassq_(&k, &a[k - 1], &i__1, &scale, &s);
+/* tri U at A(k-1,0) */
+ } else {
+/* ilu=1 & A is lower */
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - j - 1;
+ dlassq_(&i__2, &a[j + 1 + j * lda], &c__1, &scale, &s)
+ ;
+/* trap L at A(0,0) */
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ dlassq_(&j, &a[(j + 1) * lda], &c__1, &scale, &s);
+/* U at A(0,1) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ i__1 = lda + 1;
+ dlassq_(&k, a, &i__1, &scale, &s);
+/* tri L at A(0,0) */
+ i__1 = k - 1;
+ i__2 = lda + 1;
+ dlassq_(&i__1, &a[lda], &i__2, &scale, &s);
+/* tri U at A(0,1) */
+ }
+ } else {
+/* A is xpose */
+ if (ilu == 0) {
+/* A' is upper */
+ i__1 = k - 2;
+ for (j = 1; j <= i__1; ++j) {
+ dlassq_(&j, &a[(k + j) * lda], &c__1, &scale, &s);
+/* U at A(0,k) */
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ dlassq_(&k, &a[j * lda], &c__1, &scale, &s);
+/* k by k-1 rect. at A(0,0) */
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 1;
+ dlassq_(&i__2, &a[j + 1 + (j + k - 1) * lda], &c__1, &
+ scale, &s);
+/* L at A(0,k-1) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ i__1 = k - 1;
+ i__2 = lda + 1;
+ dlassq_(&i__1, &a[k * lda], &i__2, &scale, &s);
+/* tri U at A(0,k) */
+ i__1 = lda + 1;
+ dlassq_(&k, &a[(k - 1) * lda], &i__1, &scale, &s);
+/* tri L at A(0,k-1) */
+ } else {
+/* A' is lower */
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ dlassq_(&j, &a[j * lda], &c__1, &scale, &s);
+/* U at A(0,0) */
+ }
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+ dlassq_(&k, &a[j * lda], &c__1, &scale, &s);
+/* k by k-1 rect. at A(0,k) */
+ }
+ i__1 = k - 3;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 2;
+ dlassq_(&i__2, &a[j + 2 + j * lda], &c__1, &scale, &s)
+ ;
+/* L at A(1,0) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ i__1 = lda + 1;
+ dlassq_(&k, a, &i__1, &scale, &s);
+/* tri U at A(0,0) */
+ i__1 = k - 1;
+ i__2 = lda + 1;
+ dlassq_(&i__1, &a[1], &i__2, &scale, &s);
+/* tri L at A(1,0) */
+ }
+ }
+ } else {
+/* n is even */
+ if (ifm == 1) {
+/* A is normal */
+ if (ilu == 0) {
+/* A is upper */
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 1;
+ dlassq_(&i__2, &a[k + j + 2 + j * lda], &c__1, &scale,
+ &s);
+/* L at A(k+1,0) */
+ }
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k + j;
+ dlassq_(&i__2, &a[j * lda], &c__1, &scale, &s);
+/* trap U at A(0,0) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ i__1 = lda + 1;
+ dlassq_(&k, &a[k + 1], &i__1, &scale, &s);
+/* tri L at A(k+1,0) */
+ i__1 = lda + 1;
+ dlassq_(&k, &a[k], &i__1, &scale, &s);
+/* tri U at A(k,0) */
+ } else {
+/* ilu=1 & A is lower */
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - j - 1;
+ dlassq_(&i__2, &a[j + 2 + j * lda], &c__1, &scale, &s)
+ ;
+/* trap L at A(1,0) */
+ }
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ dlassq_(&j, &a[j * lda], &c__1, &scale, &s);
+/* U at A(0,0) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ i__1 = lda + 1;
+ dlassq_(&k, &a[1], &i__1, &scale, &s);
+/* tri L at A(1,0) */
+ i__1 = lda + 1;
+ dlassq_(&k, a, &i__1, &scale, &s);
+/* tri U at A(0,0) */
+ }
+ } else {
+/* A is xpose */
+ if (ilu == 0) {
+/* A' is upper */
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ dlassq_(&j, &a[(k + 1 + j) * lda], &c__1, &scale, &s);
+/* U at A(0,k+1) */
+ }
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ dlassq_(&k, &a[j * lda], &c__1, &scale, &s);
+/* k by k rect. at A(0,0) */
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 1;
+ dlassq_(&i__2, &a[j + 1 + (j + k) * lda], &c__1, &
+ scale, &s);
+/* L at A(0,k) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ i__1 = lda + 1;
+ dlassq_(&k, &a[(k + 1) * lda], &i__1, &scale, &s);
+/* tri U at A(0,k+1) */
+ i__1 = lda + 1;
+ dlassq_(&k, &a[k * lda], &i__1, &scale, &s);
+/* tri L at A(0,k) */
+ } else {
+/* A' is lower */
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ dlassq_(&j, &a[(j + 1) * lda], &c__1, &scale, &s);
+/* U at A(0,1) */
+ }
+ i__1 = *n;
+ for (j = k + 1; j <= i__1; ++j) {
+ dlassq_(&k, &a[j * lda], &c__1, &scale, &s);
+/* k by k rect. at A(0,k+1) */
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 1;
+ dlassq_(&i__2, &a[j + 1 + j * lda], &c__1, &scale, &s)
+ ;
+/* L at A(0,0) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ i__1 = lda + 1;
+ dlassq_(&k, &a[lda], &i__1, &scale, &s);
+/* tri L at A(0,1) */
+ i__1 = lda + 1;
+ dlassq_(&k, a, &i__1, &scale, &s);
+/* tri U at A(0,0) */
+ }
+ }
+ }
+ value = scale * sqrt(s);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of DLANSF */
+
+} /* dlansf_ */
diff --git a/SRC/dlansp.c b/SRC/dlansp.c
new file mode 100644
index 0000000..de8f50c
--- /dev/null
+++ b/SRC/dlansp.c
@@ -0,0 +1,263 @@
+/* dlansp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal dlansp_(char *norm, char *uplo, integer *n, doublereal *ap,
+ doublereal *work)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal ret_val, d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal sum, absa, scale;
+ extern logical lsame_(char *, char *);
+ doublereal value;
+ extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLANSP returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* real symmetric matrix A, supplied in packed form. */
+
+/* Description */
+/* =========== */
+
+/* DLANSP returns the value */
+
+/* DLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in DLANSP as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is supplied. */
+/* = 'U': Upper triangular part of A is supplied */
+/* = 'L': Lower triangular part of A is supplied */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, DLANSP is */
+/* set to zero. */
+
+/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the symmetric matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
+/* WORK is not referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --ap;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.;
+ if (lsame_(uplo, "U")) {
+ k = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1));
+ value = max(d__2,d__3);
+/* L10: */
+ }
+ k += j;
+/* L20: */
+ }
+ } else {
+ k = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + *n - j;
+ for (i__ = k; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1));
+ value = max(d__2,d__3);
+/* L30: */
+ }
+ k = k + *n - j + 1;
+/* L40: */
+ }
+ }
+ } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
+
+/* Find normI(A) ( = norm1(A), since A is symmetric). */
+
+ value = 0.;
+ k = 1;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ absa = (d__1 = ap[k], abs(d__1));
+ sum += absa;
+ work[i__] += absa;
+ ++k;
+/* L50: */
+ }
+ work[j] = sum + (d__1 = ap[k], abs(d__1));
+ ++k;
+/* L60: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = work[i__];
+ value = max(d__1,d__2);
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L80: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = work[j] + (d__1 = ap[k], abs(d__1));
+ ++k;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ absa = (d__1 = ap[k], abs(d__1));
+ sum += absa;
+ work[i__] += absa;
+ ++k;
+/* L90: */
+ }
+ value = max(value,sum);
+/* L100: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.;
+ sum = 1.;
+ k = 2;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ dlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k += j;
+/* L110: */
+ }
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ dlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k = k + *n - j + 1;
+/* L120: */
+ }
+ }
+ sum *= 2;
+ k = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (ap[k] != 0.) {
+ absa = (d__1 = ap[k], abs(d__1));
+ if (scale < absa) {
+/* Computing 2nd power */
+ d__1 = scale / absa;
+ sum = sum * (d__1 * d__1) + 1.;
+ scale = absa;
+ } else {
+/* Computing 2nd power */
+ d__1 = absa / scale;
+ sum += d__1 * d__1;
+ }
+ }
+ if (lsame_(uplo, "U")) {
+ k = k + i__ + 1;
+ } else {
+ k = k + *n - i__ + 1;
+ }
+/* L130: */
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of DLANSP */
+
+} /* dlansp_ */
diff --git a/SRC/dlanst.c b/SRC/dlanst.c
new file mode 100644
index 0000000..323713d
--- /dev/null
+++ b/SRC/dlanst.c
@@ -0,0 +1,166 @@
+/* dlanst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal dlanst_(char *norm, integer *n, doublereal *d__, doublereal *e)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal ret_val, d__1, d__2, d__3, d__4, d__5;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal sum, scale;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLANST returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* real symmetric tridiagonal matrix A. */
+
+/* Description */
+/* =========== */
+
+/* DLANST returns the value */
+
+/* DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in DLANST as described */
+/* above. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, DLANST is */
+/* set to zero. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) sub-diagonal or super-diagonal elements of A. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --e;
+ --d__;
+
+ /* Function Body */
+ if (*n <= 0) {
+ anorm = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ anorm = (d__1 = d__[*n], abs(d__1));
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = anorm, d__3 = (d__1 = d__[i__], abs(d__1));
+ anorm = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = anorm, d__3 = (d__1 = e[i__], abs(d__1));
+ anorm = max(d__2,d__3);
+/* L10: */
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1' || lsame_(norm, "I")) {
+
+/* Find norm1(A). */
+
+ if (*n == 1) {
+ anorm = abs(d__[1]);
+ } else {
+/* Computing MAX */
+ d__3 = abs(d__[1]) + abs(e[1]), d__4 = (d__1 = e[*n - 1], abs(
+ d__1)) + (d__2 = d__[*n], abs(d__2));
+ anorm = max(d__3,d__4);
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__4 = anorm, d__5 = (d__1 = d__[i__], abs(d__1)) + (d__2 = e[
+ i__], abs(d__2)) + (d__3 = e[i__ - 1], abs(d__3));
+ anorm = max(d__4,d__5);
+/* L20: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.;
+ sum = 1.;
+ if (*n > 1) {
+ i__1 = *n - 1;
+ dlassq_(&i__1, &e[1], &c__1, &scale, &sum);
+ sum *= 2;
+ }
+ dlassq_(n, &d__[1], &c__1, &scale, &sum);
+ anorm = scale * sqrt(sum);
+ }
+
+ ret_val = anorm;
+ return ret_val;
+
+/* End of DLANST */
+
+} /* dlanst_ */
diff --git a/SRC/dlansy.c b/SRC/dlansy.c
new file mode 100644
index 0000000..58d5c30
--- /dev/null
+++ b/SRC/dlansy.c
@@ -0,0 +1,239 @@
+/* dlansy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer
+ *lda, doublereal *work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal ret_val, d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal sum, absa, scale;
+ extern logical lsame_(char *, char *);
+ doublereal value;
+ extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLANSY returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* real symmetric matrix A. */
+
+/* Description */
+/* =========== */
+
+/* DLANSY returns the value */
+
+/* DLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in DLANSY as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is to be referenced. */
+/* = 'U': Upper triangular part of A is referenced */
+/* = 'L': Lower triangular part of A is referenced */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, DLANSY is */
+/* set to zero. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of A contains the upper triangular part */
+/* of the matrix A, and the strictly lower triangular part of A */
+/* is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of A contains the lower triangular part of */
+/* the matrix A, and the strictly upper triangular part of A is */
+/* not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(N,1). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
+/* WORK is not referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(
+ d__1));
+ value = max(d__2,d__3);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(
+ d__1));
+ value = max(d__2,d__3);
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
+
+/* Find normI(A) ( = norm1(A), since A is symmetric). */
+
+ value = 0.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ absa = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ sum += absa;
+ work[i__] += absa;
+/* L50: */
+ }
+ work[j] = sum + (d__1 = a[j + j * a_dim1], abs(d__1));
+/* L60: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = work[i__];
+ value = max(d__1,d__2);
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L80: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = work[j] + (d__1 = a[j + j * a_dim1], abs(d__1));
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ absa = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ sum += absa;
+ work[i__] += absa;
+/* L90: */
+ }
+ value = max(value,sum);
+/* L100: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.;
+ sum = 1.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
+/* L110: */
+ }
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ dlassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum);
+/* L120: */
+ }
+ }
+ sum *= 2;
+ i__1 = *lda + 1;
+ dlassq_(n, &a[a_offset], &i__1, &scale, &sum);
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of DLANSY */
+
+} /* dlansy_ */
diff --git a/SRC/dlantb.c b/SRC/dlantb.c
new file mode 100644
index 0000000..7aa82d8
--- /dev/null
+++ b/SRC/dlantb.c
@@ -0,0 +1,434 @@
+/* dlantb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal dlantb_(char *norm, char *uplo, char *diag, integer *n, integer *k,
+ doublereal *ab, integer *ldab, doublereal *work)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal ret_val, d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, l;
+ doublereal sum, scale;
+ logical udiag;
+ extern logical lsame_(char *, char *);
+ doublereal value;
+ extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLANTB returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of an */
+/* n by n triangular band matrix A, with ( k + 1 ) diagonals. */
+
+/* Description */
+/* =========== */
+
+/* DLANTB returns the value */
+
+/* DLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in DLANTB as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, DLANTB is */
+/* set to zero. */
+
+/* K (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals of the matrix A if UPLO = 'L'. */
+/* K >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first k+1 rows of AB. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). */
+/* Note that when DIAG = 'U', the elements of the array AB */
+/* corresponding to the diagonal elements of the matrix A are */
+/* not referenced, but are assumed to be one. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= K+1. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ if (lsame_(diag, "U")) {
+ value = 1.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ i__3 = *k;
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1],
+ abs(d__1));
+ value = max(d__2,d__3);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *n + 1 - j, i__4 = *k + 1;
+ i__3 = min(i__2,i__4);
+ for (i__ = 2; i__ <= i__3; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1],
+ abs(d__1));
+ value = max(d__2,d__3);
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else {
+ value = 0.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__3 = *k + 2 - j;
+ i__2 = *k + 1;
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1],
+ abs(d__1));
+ value = max(d__2,d__3);
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n + 1 - j, i__4 = *k + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = ab[i__ + j * ab_dim1],
+ abs(d__1));
+ value = max(d__2,d__3);
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.;
+ udiag = lsame_(diag, "U");
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag) {
+ sum = 1.;
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ i__3 = *k;
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+ sum += (d__1 = ab[i__ + j * ab_dim1], abs(d__1));
+/* L90: */
+ }
+ } else {
+ sum = 0.;
+/* Computing MAX */
+ i__3 = *k + 2 - j;
+ i__2 = *k + 1;
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+ sum += (d__1 = ab[i__ + j * ab_dim1], abs(d__1));
+/* L100: */
+ }
+ }
+ value = max(value,sum);
+/* L110: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag) {
+ sum = 1.;
+/* Computing MIN */
+ i__3 = *n + 1 - j, i__4 = *k + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ sum += (d__1 = ab[i__ + j * ab_dim1], abs(d__1));
+/* L120: */
+ }
+ } else {
+ sum = 0.;
+/* Computing MIN */
+ i__3 = *n + 1 - j, i__4 = *k + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ sum += (d__1 = ab[i__ + j * ab_dim1], abs(d__1));
+/* L130: */
+ }
+ }
+ value = max(value,sum);
+/* L140: */
+ }
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ value = 0.;
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.;
+/* L150: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ l = *k + 1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ work[i__] += (d__1 = ab[l + i__ + j * ab_dim1], abs(
+ d__1));
+/* L160: */
+ }
+/* L170: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L180: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ l = *k + 1 - j;
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *k;
+ i__3 = j;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ work[i__] += (d__1 = ab[l + i__ + j * ab_dim1], abs(
+ d__1));
+/* L190: */
+ }
+/* L200: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.;
+/* L210: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ l = 1 - j;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ work[i__] += (d__1 = ab[l + i__ + j * ab_dim1], abs(
+ d__1));
+/* L220: */
+ }
+/* L230: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L240: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ l = 1 - j;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j; i__ <= i__3; ++i__) {
+ work[i__] += (d__1 = ab[l + i__ + j * ab_dim1], abs(
+ d__1));
+/* L250: */
+ }
+/* L260: */
+ }
+ }
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = work[i__];
+ value = max(d__1,d__2);
+/* L270: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ scale = 1.;
+ sum = (doublereal) (*n);
+ if (*k > 0) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = j - 1;
+ i__3 = min(i__4,*k);
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ dlassq_(&i__3, &ab[max(i__2, 1)+ j * ab_dim1], &c__1,
+ &scale, &sum);
+/* L280: */
+ }
+ }
+ } else {
+ scale = 0.;
+ sum = 1.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = j, i__2 = *k + 1;
+ i__3 = min(i__4,i__2);
+/* Computing MAX */
+ i__5 = *k + 2 - j;
+ dlassq_(&i__3, &ab[max(i__5, 1)+ j * ab_dim1], &c__1, &
+ scale, &sum);
+/* L290: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ scale = 1.;
+ sum = (doublereal) (*n);
+ if (*k > 0) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = *n - j;
+ i__3 = min(i__4,*k);
+ dlassq_(&i__3, &ab[j * ab_dim1 + 2], &c__1, &scale, &
+ sum);
+/* L300: */
+ }
+ }
+ } else {
+ scale = 0.;
+ sum = 1.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = *n - j + 1, i__2 = *k + 1;
+ i__3 = min(i__4,i__2);
+ dlassq_(&i__3, &ab[j * ab_dim1 + 1], &c__1, &scale, &sum);
+/* L310: */
+ }
+ }
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of DLANTB */
+
+} /* dlantb_ */
diff --git a/SRC/dlantp.c b/SRC/dlantp.c
new file mode 100644
index 0000000..dd11098
--- /dev/null
+++ b/SRC/dlantp.c
@@ -0,0 +1,391 @@
+/* dlantp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal dlantp_(char *norm, char *uplo, char *diag, integer *n, doublereal
+ *ap, doublereal *work)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal ret_val, d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal sum, scale;
+ logical udiag;
+ extern logical lsame_(char *, char *);
+ doublereal value;
+ extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLANTP returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* triangular matrix A, supplied in packed form. */
+
+/* Description */
+/* =========== */
+
+/* DLANTP returns the value */
+
+/* DLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in DLANTP as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, DLANTP is */
+/* set to zero. */
+
+/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* Note that when DIAG = 'U', the elements of the array AP */
+/* corresponding to the diagonal elements of the matrix A are */
+/* not referenced, but are assumed to be one. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --ap;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ k = 1;
+ if (lsame_(diag, "U")) {
+ value = 1.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j - 2;
+ for (i__ = k; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1));
+ value = max(d__2,d__3);
+/* L10: */
+ }
+ k += j;
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + *n - j;
+ for (i__ = k + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1));
+ value = max(d__2,d__3);
+/* L30: */
+ }
+ k = k + *n - j + 1;
+/* L40: */
+ }
+ }
+ } else {
+ value = 0.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1));
+ value = max(d__2,d__3);
+/* L50: */
+ }
+ k += j;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + *n - j;
+ for (i__ = k; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = ap[i__], abs(d__1));
+ value = max(d__2,d__3);
+/* L70: */
+ }
+ k = k + *n - j + 1;
+/* L80: */
+ }
+ }
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.;
+ k = 1;
+ udiag = lsame_(diag, "U");
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag) {
+ sum = 1.;
+ i__2 = k + j - 2;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ sum += (d__1 = ap[i__], abs(d__1));
+/* L90: */
+ }
+ } else {
+ sum = 0.;
+ i__2 = k + j - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ sum += (d__1 = ap[i__], abs(d__1));
+/* L100: */
+ }
+ }
+ k += j;
+ value = max(value,sum);
+/* L110: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag) {
+ sum = 1.;
+ i__2 = k + *n - j;
+ for (i__ = k + 1; i__ <= i__2; ++i__) {
+ sum += (d__1 = ap[i__], abs(d__1));
+/* L120: */
+ }
+ } else {
+ sum = 0.;
+ i__2 = k + *n - j;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ sum += (d__1 = ap[i__], abs(d__1));
+/* L130: */
+ }
+ }
+ k = k + *n - j + 1;
+ value = max(value,sum);
+/* L140: */
+ }
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ k = 1;
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.;
+/* L150: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += (d__1 = ap[k], abs(d__1));
+ ++k;
+/* L160: */
+ }
+ ++k;
+/* L170: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L180: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += (d__1 = ap[k], abs(d__1));
+ ++k;
+/* L190: */
+ }
+/* L200: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.;
+/* L210: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ++k;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ work[i__] += (d__1 = ap[k], abs(d__1));
+ ++k;
+/* L220: */
+ }
+/* L230: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L240: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ work[i__] += (d__1 = ap[k], abs(d__1));
+ ++k;
+/* L250: */
+ }
+/* L260: */
+ }
+ }
+ }
+ value = 0.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = work[i__];
+ value = max(d__1,d__2);
+/* L270: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ scale = 1.;
+ sum = (doublereal) (*n);
+ k = 2;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ dlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k += j;
+/* L280: */
+ }
+ } else {
+ scale = 0.;
+ sum = 1.;
+ k = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dlassq_(&j, &ap[k], &c__1, &scale, &sum);
+ k += j;
+/* L290: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ scale = 1.;
+ sum = (doublereal) (*n);
+ k = 2;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ dlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k = k + *n - j + 1;
+/* L300: */
+ }
+ } else {
+ scale = 0.;
+ sum = 1.;
+ k = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ dlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k = k + *n - j + 1;
+/* L310: */
+ }
+ }
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of DLANTP */
+
+} /* dlantp_ */
diff --git a/SRC/dlantr.c b/SRC/dlantr.c
new file mode 100644
index 0000000..cc28cde
--- /dev/null
+++ b/SRC/dlantr.c
@@ -0,0 +1,398 @@
+/* dlantr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal dlantr_(char *norm, char *uplo, char *diag, integer *m, integer *n,
+ doublereal *a, integer *lda, doublereal *work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val, d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal sum, scale;
+ logical udiag;
+ extern logical lsame_(char *, char *);
+ doublereal value;
+ extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLANTR returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* trapezoidal or triangular matrix A. */
+
+/* Description */
+/* =========== */
+
+/* DLANTR returns the value */
+
+/* DLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in DLANTR as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower trapezoidal. */
+/* = 'U': Upper trapezoidal */
+/* = 'L': Lower trapezoidal */
+/* Note that A is triangular instead of trapezoidal if M = N. */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A has unit diagonal. */
+/* = 'N': Non-unit diagonal */
+/* = 'U': Unit diagonal */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0, and if */
+/* UPLO = 'U', M <= N. When M = 0, DLANTR is set to zero. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0, and if */
+/* UPLO = 'L', N <= M. When N = 0, DLANTR is set to zero. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The trapezoidal matrix A (A is triangular if M = N). */
+/* If UPLO = 'U', the leading m by n upper trapezoidal part of */
+/* the array A contains the upper trapezoidal matrix, and the */
+/* strictly lower triangular part of A is not referenced. */
+/* If UPLO = 'L', the leading m by n lower trapezoidal part of */
+/* the array A contains the lower trapezoidal matrix, and the */
+/* strictly upper triangular part of A is not referenced. Note */
+/* that when DIAG = 'U', the diagonal elements of A are not */
+/* referenced and are assumed to be one. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(M,1). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ if (min(*m,*n) == 0) {
+ value = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ if (lsame_(diag, "U")) {
+ value = 1.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *m, i__4 = j - 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(
+ d__1));
+ value = max(d__2,d__3);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(
+ d__1));
+ value = max(d__2,d__3);
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else {
+ value = 0.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(*m,j);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(
+ d__1));
+ value = max(d__2,d__3);
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(
+ d__1));
+ value = max(d__2,d__3);
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.;
+ udiag = lsame_(diag, "U");
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag && j <= *m) {
+ sum = 1.;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ sum += (d__1 = a[i__ + j * a_dim1], abs(d__1));
+/* L90: */
+ }
+ } else {
+ sum = 0.;
+ i__2 = min(*m,j);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ sum += (d__1 = a[i__ + j * a_dim1], abs(d__1));
+/* L100: */
+ }
+ }
+ value = max(value,sum);
+/* L110: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag) {
+ sum = 1.;
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ sum += (d__1 = a[i__ + j * a_dim1], abs(d__1));
+/* L120: */
+ }
+ } else {
+ sum = 0.;
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ sum += (d__1 = a[i__ + j * a_dim1], abs(d__1));
+/* L130: */
+ }
+ }
+ value = max(value,sum);
+/* L140: */
+ }
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.;
+/* L150: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *m, i__4 = j - 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1));
+/* L160: */
+ }
+/* L170: */
+ }
+ } else {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L180: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(*m,j);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1));
+/* L190: */
+ }
+/* L200: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.;
+/* L210: */
+ }
+ i__1 = *m;
+ for (i__ = *n + 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L220: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1));
+/* L230: */
+ }
+/* L240: */
+ }
+ } else {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L250: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1));
+/* L260: */
+ }
+/* L270: */
+ }
+ }
+ }
+ value = 0.;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = work[i__];
+ value = max(d__1,d__2);
+/* L280: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ scale = 1.;
+ sum = (doublereal) min(*m,*n);
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *m, i__4 = j - 1;
+ i__2 = min(i__3,i__4);
+ dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
+/* L290: */
+ }
+ } else {
+ scale = 0.;
+ sum = 1.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(*m,j);
+ dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
+/* L300: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ scale = 1.;
+ sum = (doublereal) min(*m,*n);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m - j;
+/* Computing MIN */
+ i__3 = *m, i__4 = j + 1;
+ dlassq_(&i__2, &a[min(i__3, i__4)+ j * a_dim1], &c__1, &
+ scale, &sum);
+/* L310: */
+ }
+ } else {
+ scale = 0.;
+ sum = 1.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m - j + 1;
+ dlassq_(&i__2, &a[j + j * a_dim1], &c__1, &scale, &sum);
+/* L320: */
+ }
+ }
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of DLANTR */
+
+} /* dlantr_ */
diff --git a/SRC/dlanv2.c b/SRC/dlanv2.c
new file mode 100644
index 0000000..14aa951
--- /dev/null
+++ b/SRC/dlanv2.c
@@ -0,0 +1,235 @@
+/* dlanv2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b4 = 1.;
+
+/* Subroutine */ int dlanv2_(doublereal *a, doublereal *b, doublereal *c__,
+ doublereal *d__, doublereal *rt1r, doublereal *rt1i, doublereal *rt2r,
+ doublereal *rt2i, doublereal *cs, doublereal *sn)
+{
+ /* System generated locals */
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *), sqrt(doublereal);
+
+ /* Local variables */
+ doublereal p, z__, aa, bb, cc, dd, cs1, sn1, sab, sac, eps, tau, temp,
+ scale, bcmax, bcmis, sigma;
+ extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric */
+/* matrix in standard form: */
+
+/* [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] */
+/* [ C D ] [ SN CS ] [ CC DD ] [-SN CS ] */
+
+/* where either */
+/* 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or */
+/* 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex */
+/* conjugate eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* A (input/output) DOUBLE PRECISION */
+/* B (input/output) DOUBLE PRECISION */
+/* C (input/output) DOUBLE PRECISION */
+/* D (input/output) DOUBLE PRECISION */
+/* On entry, the elements of the input matrix. */
+/* On exit, they are overwritten by the elements of the */
+/* standardised Schur form. */
+
+/* RT1R (output) DOUBLE PRECISION */
+/* RT1I (output) DOUBLE PRECISION */
+/* RT2R (output) DOUBLE PRECISION */
+/* RT2I (output) DOUBLE PRECISION */
+/* The real and imaginary parts of the eigenvalues. If the */
+/* eigenvalues are a complex conjugate pair, RT1I > 0. */
+
+/* CS (output) DOUBLE PRECISION */
+/* SN (output) DOUBLE PRECISION */
+/* Parameters of the rotation matrix. */
+
+/* Further Details */
+/* =============== */
+
+/* Modified by V. Sima, Research Institute for Informatics, Bucharest, */
+/* Romania, to reduce the risk of cancellation errors, */
+/* when computing real eigenvalues, and to ensure, if possible, that */
+/* abs(RT1R) >= abs(RT2R). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = dlamch_("P");
+ if (*c__ == 0.) {
+ *cs = 1.;
+ *sn = 0.;
+ goto L10;
+
+ } else if (*b == 0.) {
+
+/* Swap rows and columns */
+
+ *cs = 0.;
+ *sn = 1.;
+ temp = *d__;
+ *d__ = *a;
+ *a = temp;
+ *b = -(*c__);
+ *c__ = 0.;
+ goto L10;
+ } else if (*a - *d__ == 0. && d_sign(&c_b4, b) != d_sign(&c_b4, c__)) {
+ *cs = 1.;
+ *sn = 0.;
+ goto L10;
+ } else {
+
+ temp = *a - *d__;
+ p = temp * .5;
+/* Computing MAX */
+ d__1 = abs(*b), d__2 = abs(*c__);
+ bcmax = max(d__1,d__2);
+/* Computing MIN */
+ d__1 = abs(*b), d__2 = abs(*c__);
+ bcmis = min(d__1,d__2) * d_sign(&c_b4, b) * d_sign(&c_b4, c__);
+/* Computing MAX */
+ d__1 = abs(p);
+ scale = max(d__1,bcmax);
+ z__ = p / scale * p + bcmax / scale * bcmis;
+
+/* If Z is of the order of the machine accuracy, postpone the */
+/* decision on the nature of eigenvalues */
+
+ if (z__ >= eps * 4.) {
+
+/* Real eigenvalues. Compute A and D. */
+
+ d__1 = sqrt(scale) * sqrt(z__);
+ z__ = p + d_sign(&d__1, &p);
+ *a = *d__ + z__;
+ *d__ -= bcmax / z__ * bcmis;
+
+/* Compute B and the rotation matrix */
+
+ tau = dlapy2_(c__, &z__);
+ *cs = z__ / tau;
+ *sn = *c__ / tau;
+ *b -= *c__;
+ *c__ = 0.;
+ } else {
+
+/* Complex eigenvalues, or real (almost) equal eigenvalues. */
+/* Make diagonal elements equal. */
+
+ sigma = *b + *c__;
+ tau = dlapy2_(&sigma, &temp);
+ *cs = sqrt((abs(sigma) / tau + 1.) * .5);
+ *sn = -(p / (tau * *cs)) * d_sign(&c_b4, &sigma);
+
+/* Compute [ AA BB ] = [ A B ] [ CS -SN ] */
+/* [ CC DD ] [ C D ] [ SN CS ] */
+
+ aa = *a * *cs + *b * *sn;
+ bb = -(*a) * *sn + *b * *cs;
+ cc = *c__ * *cs + *d__ * *sn;
+ dd = -(*c__) * *sn + *d__ * *cs;
+
+/* Compute [ A B ] = [ CS SN ] [ AA BB ] */
+/* [ C D ] [-SN CS ] [ CC DD ] */
+
+ *a = aa * *cs + cc * *sn;
+ *b = bb * *cs + dd * *sn;
+ *c__ = -aa * *sn + cc * *cs;
+ *d__ = -bb * *sn + dd * *cs;
+
+ temp = (*a + *d__) * .5;
+ *a = temp;
+ *d__ = temp;
+
+ if (*c__ != 0.) {
+ if (*b != 0.) {
+ if (d_sign(&c_b4, b) == d_sign(&c_b4, c__)) {
+
+/* Real eigenvalues: reduce to upper triangular form */
+
+ sab = sqrt((abs(*b)));
+ sac = sqrt((abs(*c__)));
+ d__1 = sab * sac;
+ p = d_sign(&d__1, c__);
+ tau = 1. / sqrt((d__1 = *b + *c__, abs(d__1)));
+ *a = temp + p;
+ *d__ = temp - p;
+ *b -= *c__;
+ *c__ = 0.;
+ cs1 = sab * tau;
+ sn1 = sac * tau;
+ temp = *cs * cs1 - *sn * sn1;
+ *sn = *cs * sn1 + *sn * cs1;
+ *cs = temp;
+ }
+ } else {
+ *b = -(*c__);
+ *c__ = 0.;
+ temp = *cs;
+ *cs = -(*sn);
+ *sn = temp;
+ }
+ }
+ }
+
+ }
+
+L10:
+
+/* Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). */
+
+ *rt1r = *a;
+ *rt2r = *d__;
+ if (*c__ == 0.) {
+ *rt1i = 0.;
+ *rt2i = 0.;
+ } else {
+ *rt1i = sqrt((abs(*b))) * sqrt((abs(*c__)));
+ *rt2i = -(*rt1i);
+ }
+ return 0;
+
+/* End of DLANV2 */
+
+} /* dlanv2_ */
diff --git a/SRC/dlapll.c b/SRC/dlapll.c
new file mode 100644
index 0000000..90ef53f
--- /dev/null
+++ b/SRC/dlapll.c
@@ -0,0 +1,127 @@
+/* dlapll.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlapll_(integer *n, doublereal *x, integer *incx,
+ doublereal *y, integer *incy, doublereal *ssmin)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ doublereal c__, a11, a12, a22, tau;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ extern /* Subroutine */ int dlas2_(doublereal *, doublereal *, doublereal
+ *, doublereal *, doublereal *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *);
+ doublereal ssmax;
+ extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Given two column vectors X and Y, let */
+
+/* A = ( X Y ). */
+
+/* The subroutine first computes the QR factorization of A = Q*R, */
+/* and then computes the SVD of the 2-by-2 upper triangular matrix R. */
+/* The smaller singular value of R is returned in SSMIN, which is used */
+/* as the measurement of the linear dependency of the vectors X and Y. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The length of the vectors X and Y. */
+
+/* X (input/output) DOUBLE PRECISION array, */
+/* dimension (1+(N-1)*INCX) */
+/* On entry, X contains the N-vector X. */
+/* On exit, X is overwritten. */
+
+/* INCX (input) INTEGER */
+/* The increment between successive elements of X. INCX > 0. */
+
+/* Y (input/output) DOUBLE PRECISION array, */
+/* dimension (1+(N-1)*INCY) */
+/* On entry, Y contains the N-vector Y. */
+/* On exit, Y is overwritten. */
+
+/* INCY (input) INTEGER */
+/* The increment between successive elements of Y. INCY > 0. */
+
+/* SSMIN (output) DOUBLE PRECISION */
+/* The smallest singular value of the N-by-2 matrix A = ( X Y ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --y;
+ --x;
+
+ /* Function Body */
+ if (*n <= 1) {
+ *ssmin = 0.;
+ return 0;
+ }
+
+/* Compute the QR factorization of the N-by-2 matrix ( X Y ) */
+
+ dlarfg_(n, &x[1], &x[*incx + 1], incx, &tau);
+ a11 = x[1];
+ x[1] = 1.;
+
+ c__ = -tau * ddot_(n, &x[1], incx, &y[1], incy);
+ daxpy_(n, &c__, &x[1], incx, &y[1], incy);
+
+ i__1 = *n - 1;
+ dlarfg_(&i__1, &y[*incy + 1], &y[(*incy << 1) + 1], incy, &tau);
+
+ a12 = y[1];
+ a22 = y[*incy + 1];
+
+/* Compute the SVD of 2-by-2 Upper triangular matrix. */
+
+ dlas2_(&a11, &a12, &a22, ssmin, &ssmax);
+
+ return 0;
+
+/* End of DLAPLL */
+
+} /* dlapll_ */
diff --git a/SRC/dlapmt.c b/SRC/dlapmt.c
new file mode 100644
index 0000000..8a93785
--- /dev/null
+++ b/SRC/dlapmt.c
@@ -0,0 +1,178 @@
+/* dlapmt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlapmt_(logical *forwrd, integer *m, integer *n,
+ doublereal *x, integer *ldx, integer *k)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, ii, in;
+ doublereal temp;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAPMT rearranges the columns of the M by N matrix X as specified */
+/* by the permutation K(1),K(2),...,K(N) of the integers 1,...,N. */
+/* If FORWRD = .TRUE., forward permutation: */
+
+/* X(*,K(J)) is moved X(*,J) for J = 1,2,...,N. */
+
+/* If FORWRD = .FALSE., backward permutation: */
+
+/* X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N. */
+
+/* Arguments */
+/* ========= */
+
+/* FORWRD (input) LOGICAL */
+/* = .TRUE., forward permutation */
+/* = .FALSE., backward permutation */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix X. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix X. N >= 0. */
+
+/* X (input/output) DOUBLE PRECISION array, dimension (LDX,N) */
+/* On entry, the M by N matrix X. */
+/* On exit, X contains the permuted matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X, LDX >= MAX(1,M). */
+
+/* K (input/output) INTEGER array, dimension (N) */
+/* On entry, K contains the permutation vector. K is used as */
+/* internal workspace, but reset to its original value on */
+/* output. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --k;
+
+ /* Function Body */
+ if (*n <= 1) {
+ return 0;
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ k[i__] = -k[i__];
+/* L10: */
+ }
+
+ if (*forwrd) {
+
+/* Forward permutation */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+ if (k[i__] > 0) {
+ goto L40;
+ }
+
+ j = i__;
+ k[j] = -k[j];
+ in = k[j];
+
+L20:
+ if (k[in] > 0) {
+ goto L40;
+ }
+
+ i__2 = *m;
+ for (ii = 1; ii <= i__2; ++ii) {
+ temp = x[ii + j * x_dim1];
+ x[ii + j * x_dim1] = x[ii + in * x_dim1];
+ x[ii + in * x_dim1] = temp;
+/* L30: */
+ }
+
+ k[in] = -k[in];
+ j = in;
+ in = k[in];
+ goto L20;
+
+L40:
+
+/* L50: */
+ ;
+ }
+
+ } else {
+
+/* Backward permutation */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+ if (k[i__] > 0) {
+ goto L80;
+ }
+
+ k[i__] = -k[i__];
+ j = k[i__];
+L60:
+ if (j == i__) {
+ goto L80;
+ }
+
+ i__2 = *m;
+ for (ii = 1; ii <= i__2; ++ii) {
+ temp = x[ii + i__ * x_dim1];
+ x[ii + i__ * x_dim1] = x[ii + j * x_dim1];
+ x[ii + j * x_dim1] = temp;
+/* L70: */
+ }
+
+ k[j] = -k[j];
+ j = k[j];
+ goto L60;
+
+L80:
+
+/* L90: */
+ ;
+ }
+
+ }
+
+ return 0;
+
+/* End of DLAPMT */
+
+} /* dlapmt_ */
diff --git a/SRC/dlapy2.c b/SRC/dlapy2.c
new file mode 100644
index 0000000..6e88cd1
--- /dev/null
+++ b/SRC/dlapy2.c
@@ -0,0 +1,73 @@
+/* dlapy2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dlapy2_(doublereal *x, doublereal *y)
+{
+ /* System generated locals */
+ doublereal ret_val, d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal w, z__, xabs, yabs;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary */
+/* overflow. */
+
+/* Arguments */
+/* ========= */
+
+/* X (input) DOUBLE PRECISION */
+/* Y (input) DOUBLE PRECISION */
+/* X and Y specify the values x and y. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ xabs = abs(*x);
+ yabs = abs(*y);
+ w = max(xabs,yabs);
+ z__ = min(xabs,yabs);
+ if (z__ == 0.) {
+ ret_val = w;
+ } else {
+/* Computing 2nd power */
+ d__1 = z__ / w;
+ ret_val = w * sqrt(d__1 * d__1 + 1.);
+ }
+ return ret_val;
+
+/* End of DLAPY2 */
+
+} /* dlapy2_ */
diff --git a/SRC/dlapy3.c b/SRC/dlapy3.c
new file mode 100644
index 0000000..6aec3d0
--- /dev/null
+++ b/SRC/dlapy3.c
@@ -0,0 +1,83 @@
+/* dlapy3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dlapy3_(doublereal *x, doublereal *y, doublereal *z__)
+{
+ /* System generated locals */
+ doublereal ret_val, d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal w, xabs, yabs, zabs;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause */
+/* unnecessary overflow. */
+
+/* Arguments */
+/* ========= */
+
+/* X (input) DOUBLE PRECISION */
+/* Y (input) DOUBLE PRECISION */
+/* Z (input) DOUBLE PRECISION */
+/* X, Y and Z specify the values x, y and z. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ xabs = abs(*x);
+ yabs = abs(*y);
+ zabs = abs(*z__);
+/* Computing MAX */
+ d__1 = max(xabs,yabs);
+ w = max(d__1,zabs);
+ if (w == 0.) {
+/* W can be zero for max(0,nan,0) */
+/* adding all three entries together will make sure */
+/* NaN will not disappear. */
+ ret_val = xabs + yabs + zabs;
+ } else {
+/* Computing 2nd power */
+ d__1 = xabs / w;
+/* Computing 2nd power */
+ d__2 = yabs / w;
+/* Computing 2nd power */
+ d__3 = zabs / w;
+ ret_val = w * sqrt(d__1 * d__1 + d__2 * d__2 + d__3 * d__3);
+ }
+ return ret_val;
+
+/* End of DLAPY3 */
+
+} /* dlapy3_ */
diff --git a/SRC/dlaqgb.c b/SRC/dlaqgb.c
new file mode 100644
index 0000000..6d80b13
--- /dev/null
+++ b/SRC/dlaqgb.c
@@ -0,0 +1,216 @@
+/* dlaqgb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlaqgb_(integer *m, integer *n, integer *kl, integer *ku,
+ doublereal *ab, integer *ldab, doublereal *r__, doublereal *c__,
+ doublereal *rowcnd, doublereal *colcnd, doublereal *amax, char *equed)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal cj, large, small;
+ extern doublereal dlamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAQGB equilibrates a general M by N band matrix A with KL */
+/* subdiagonals and KU superdiagonals using the row and scaling factors */
+/* in the vectors R and C. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */
+
+/* On exit, the equilibrated matrix, in the same storage format */
+/* as A. See EQUED for the form of the equilibrated matrix. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDA >= KL+KU+1. */
+
+/* R (input) DOUBLE PRECISION array, dimension (M) */
+/* The row scale factors for A. */
+
+/* C (input) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. */
+
+/* ROWCND (input) DOUBLE PRECISION */
+/* Ratio of the smallest R(i) to the largest R(i). */
+
+/* COLCND (input) DOUBLE PRECISION */
+/* Ratio of the smallest C(i) to the largest C(i). */
+
+/* AMAX (input) DOUBLE PRECISION */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if row or column scaling */
+/* should be done based on the ratio of the row or column scaling */
+/* factors. If ROWCND < THRESH, row scaling is done, and if */
+/* COLCND < THRESH, column scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if row scaling */
+/* should be done based on the absolute size of the largest matrix */
+/* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = dlamch_("Safe minimum") / dlamch_("Precision");
+ large = 1. / small;
+
+ if (*rowcnd >= .1 && *amax >= small && *amax <= large) {
+
+/* No row scaling */
+
+ if (*colcnd >= .1) {
+
+/* No column scaling */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = c__[j];
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__4 = min(i__5,i__6);
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ ab[*ku + 1 + i__ - j + j * ab_dim1] = cj * ab[*ku + 1 +
+ i__ - j + j * ab_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+ *(unsigned char *)equed = 'C';
+ }
+ } else if (*colcnd >= .1) {
+
+/* Row scaling, no column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__3 = min(i__5,i__6);
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ ab[*ku + 1 + i__ - j + j * ab_dim1] = r__[i__] * ab[*ku + 1 +
+ i__ - j + j * ab_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ *(unsigned char *)equed = 'R';
+ } else {
+
+/* Row and column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = c__[j];
+/* Computing MAX */
+ i__3 = 1, i__4 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__2 = min(i__5,i__6);
+ for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) {
+ ab[*ku + 1 + i__ - j + j * ab_dim1] = cj * r__[i__] * ab[*ku
+ + 1 + i__ - j + j * ab_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+ *(unsigned char *)equed = 'B';
+ }
+
+ return 0;
+
+/* End of DLAQGB */
+
+} /* dlaqgb_ */
diff --git a/SRC/dlaqge.c b/SRC/dlaqge.c
new file mode 100644
index 0000000..1a43bf3
--- /dev/null
+++ b/SRC/dlaqge.c
@@ -0,0 +1,188 @@
+/* dlaqge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlaqge_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *r__, doublereal *c__, doublereal *rowcnd, doublereal
+ *colcnd, doublereal *amax, char *equed)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal cj, large, small;
+ extern doublereal dlamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAQGE equilibrates a general M by N matrix A using the row and */
+/* column scaling factors in the vectors R and C. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M by N matrix A. */
+/* On exit, the equilibrated matrix. See EQUED for the form of */
+/* the equilibrated matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(M,1). */
+
+/* R (input) DOUBLE PRECISION array, dimension (M) */
+/* The row scale factors for A. */
+
+/* C (input) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. */
+
+/* ROWCND (input) DOUBLE PRECISION */
+/* Ratio of the smallest R(i) to the largest R(i). */
+
+/* COLCND (input) DOUBLE PRECISION */
+/* Ratio of the smallest C(i) to the largest C(i). */
+
+/* AMAX (input) DOUBLE PRECISION */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if row or column scaling */
+/* should be done based on the ratio of the row or column scaling */
+/* factors. If ROWCND < THRESH, row scaling is done, and if */
+/* COLCND < THRESH, column scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if row scaling */
+/* should be done based on the absolute size of the largest matrix */
+/* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = dlamch_("Safe minimum") / dlamch_("Precision");
+ large = 1. / small;
+
+ if (*rowcnd >= .1 && *amax >= small && *amax <= large) {
+
+/* No row scaling */
+
+ if (*colcnd >= .1) {
+
+/* No column scaling */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = c__[j];
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = cj * a[i__ + j * a_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+ *(unsigned char *)equed = 'C';
+ }
+ } else if (*colcnd >= .1) {
+
+/* Row scaling, no column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = r__[i__] * a[i__ + j * a_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ *(unsigned char *)equed = 'R';
+ } else {
+
+/* Row and column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = c__[j];
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = cj * r__[i__] * a[i__ + j * a_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+ *(unsigned char *)equed = 'B';
+ }
+
+ return 0;
+
+/* End of DLAQGE */
+
+} /* dlaqge_ */
diff --git a/SRC/dlaqp2.c b/SRC/dlaqp2.c
new file mode 100644
index 0000000..a8fdf27
--- /dev/null
+++ b/SRC/dlaqp2.c
@@ -0,0 +1,237 @@
+/* dlaqp2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dlaqp2_(integer *m, integer *n, integer *offset,
+ doublereal *a, integer *lda, integer *jpvt, doublereal *tau,
+ doublereal *vn1, doublereal *vn2, doublereal *work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, mn;
+ doublereal aii;
+ integer pvt;
+ doublereal temp;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ doublereal temp2, tol3z;
+ extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *);
+ integer offpi, itemp;
+ extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dlarfp_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAQP2 computes a QR factorization with column pivoting of */
+/* the block A(OFFSET+1:M,1:N). */
+/* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* OFFSET (input) INTEGER */
+/* The number of rows of the matrix A that must be pivoted */
+/* but no factorized. OFFSET >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is */
+/* the triangular factor obtained; the elements in block */
+/* A(OFFSET+1:M,1:N) below the diagonal, together with the */
+/* array TAU, represent the orthogonal matrix Q as a product of */
+/* elementary reflectors. Block A(1:OFFSET,1:N) has been */
+/* accordingly pivoted, but no factorized. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
+/* to the front of A*P (a leading column); if JPVT(i) = 0, */
+/* the i-th column of A is a free column. */
+/* On exit, if JPVT(i) = k, then the i-th column of A*P */
+/* was the k-th column of A. */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors. */
+
+/* VN1 (input/output) DOUBLE PRECISION array, dimension (N) */
+/* The vector with the partial column norms. */
+
+/* VN2 (input/output) DOUBLE PRECISION array, dimension (N) */
+/* The vector with the exact column norms. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
+/* X. Sun, Computer Science Dept., Duke University, USA */
+
+/* Partial column norm updating strategy modified by */
+/* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */
+/* University of Zagreb, Croatia. */
+/* June 2006. */
+/* For more details see LAPACK Working Note 176. */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --jpvt;
+ --tau;
+ --vn1;
+ --vn2;
+ --work;
+
+ /* Function Body */
+/* Computing MIN */
+ i__1 = *m - *offset;
+ mn = min(i__1,*n);
+ tol3z = sqrt(dlamch_("Epsilon"));
+
+/* Compute factorization. */
+
+ i__1 = mn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+ offpi = *offset + i__;
+
+/* Determine ith pivot column and swap if necessary. */
+
+ i__2 = *n - i__ + 1;
+ pvt = i__ - 1 + idamax_(&i__2, &vn1[i__], &c__1);
+
+ if (pvt != i__) {
+ dswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
+ c__1);
+ itemp = jpvt[pvt];
+ jpvt[pvt] = jpvt[i__];
+ jpvt[i__] = itemp;
+ vn1[pvt] = vn1[i__];
+ vn2[pvt] = vn2[i__];
+ }
+
+/* Generate elementary reflector H(i). */
+
+ if (offpi < *m) {
+ i__2 = *m - offpi + 1;
+ dlarfp_(&i__2, &a[offpi + i__ * a_dim1], &a[offpi + 1 + i__ *
+ a_dim1], &c__1, &tau[i__]);
+ } else {
+ dlarfp_(&c__1, &a[*m + i__ * a_dim1], &a[*m + i__ * a_dim1], &
+ c__1, &tau[i__]);
+ }
+
+ if (i__ <= *n) {
+
+/* Apply H(i)' to A(offset+i:m,i+1:n) from the left. */
+
+ aii = a[offpi + i__ * a_dim1];
+ a[offpi + i__ * a_dim1] = 1.;
+ i__2 = *m - offpi + 1;
+ i__3 = *n - i__;
+ dlarf_("Left", &i__2, &i__3, &a[offpi + i__ * a_dim1], &c__1, &
+ tau[i__], &a[offpi + (i__ + 1) * a_dim1], lda, &work[1]);
+ a[offpi + i__ * a_dim1] = aii;
+ }
+
+/* Update partial column norms. */
+
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (vn1[j] != 0.) {
+
+/* NOTE: The following 4 lines follow from the analysis in */
+/* Lapack Working Note 176. */
+
+/* Computing 2nd power */
+ d__2 = (d__1 = a[offpi + j * a_dim1], abs(d__1)) / vn1[j];
+ temp = 1. - d__2 * d__2;
+ temp = max(temp,0.);
+/* Computing 2nd power */
+ d__1 = vn1[j] / vn2[j];
+ temp2 = temp * (d__1 * d__1);
+ if (temp2 <= tol3z) {
+ if (offpi < *m) {
+ i__3 = *m - offpi;
+ vn1[j] = dnrm2_(&i__3, &a[offpi + 1 + j * a_dim1], &
+ c__1);
+ vn2[j] = vn1[j];
+ } else {
+ vn1[j] = 0.;
+ vn2[j] = 0.;
+ }
+ } else {
+ vn1[j] *= sqrt(temp);
+ }
+ }
+/* L10: */
+ }
+
+/* L20: */
+ }
+
+ return 0;
+
+/* End of DLAQP2 */
+
+} /* dlaqp2_ */
diff --git a/SRC/dlaqps.c b/SRC/dlaqps.c
new file mode 100644
index 0000000..ad6d3a0
--- /dev/null
+++ b/SRC/dlaqps.c
@@ -0,0 +1,345 @@
+/* dlaqps.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b8 = -1.;
+static doublereal c_b9 = 1.;
+static doublereal c_b16 = 0.;
+
+/* Subroutine */ int dlaqps_(integer *m, integer *n, integer *offset, integer
+ *nb, integer *kb, doublereal *a, integer *lda, integer *jpvt,
+ doublereal *tau, doublereal *vn1, doublereal *vn2, doublereal *auxv,
+ doublereal *f, integer *ldf)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, f_dim1, f_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer i_dnnt(doublereal *);
+
+ /* Local variables */
+ integer j, k, rk;
+ doublereal akk;
+ integer pvt;
+ doublereal temp;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ doublereal temp2, tol3z;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *),
+ dgemv_(char *, integer *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ integer itemp;
+ extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dlarfp_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *);
+ integer lsticc, lastrk;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAQPS computes a step of QR factorization with column pivoting */
+/* of a real M-by-N matrix A by using Blas-3. It tries to factorize */
+/* NB columns from A starting from the row OFFSET+1, and updates all */
+/* of the matrix with Blas-3 xGEMM. */
+
+/* In some cases, due to catastrophic cancellations, it cannot */
+/* factorize NB columns. Hence, the actual number of factorized */
+/* columns is returned in KB. */
+
+/* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0 */
+
+/* OFFSET (input) INTEGER */
+/* The number of rows of A that have been factorized in */
+/* previous steps. */
+
+/* NB (input) INTEGER */
+/* The number of columns to factorize. */
+
+/* KB (output) INTEGER */
+/* The number of columns actually factorized. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, block A(OFFSET+1:M,1:KB) is the triangular */
+/* factor obtained and block A(1:OFFSET,1:N) has been */
+/* accordingly pivoted, but no factorized. */
+/* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has */
+/* been updated. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* JPVT(I) = K <==> Column K of the full matrix A has been */
+/* permuted into position I in AP. */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (KB) */
+/* The scalar factors of the elementary reflectors. */
+
+/* VN1 (input/output) DOUBLE PRECISION array, dimension (N) */
+/* The vector with the partial column norms. */
+
+/* VN2 (input/output) DOUBLE PRECISION array, dimension (N) */
+/* The vector with the exact column norms. */
+
+/* AUXV (input/output) DOUBLE PRECISION array, dimension (NB) */
+/* Auxiliar vector. */
+
+/* F (input/output) DOUBLE PRECISION array, dimension (LDF,NB) */
+/* Matrix F' = L*Y'*A. */
+
+/* LDF (input) INTEGER */
+/* The leading dimension of the array F. LDF >= max(1,N). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
+/* X. Sun, Computer Science Dept., Duke University, USA */
+
+/* Partial column norm updating strategy modified by */
+/* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */
+/* University of Zagreb, Croatia. */
+/* June 2006. */
+/* For more details see LAPACK Working Note 176. */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --jpvt;
+ --tau;
+ --vn1;
+ --vn2;
+ --auxv;
+ f_dim1 = *ldf;
+ f_offset = 1 + f_dim1;
+ f -= f_offset;
+
+ /* Function Body */
+/* Computing MIN */
+ i__1 = *m, i__2 = *n + *offset;
+ lastrk = min(i__1,i__2);
+ lsticc = 0;
+ k = 0;
+ tol3z = sqrt(dlamch_("Epsilon"));
+
+/* Beginning of while loop. */
+
+L10:
+ if (k < *nb && lsticc == 0) {
+ ++k;
+ rk = *offset + k;
+
+/* Determine ith pivot column and swap if necessary */
+
+ i__1 = *n - k + 1;
+ pvt = k - 1 + idamax_(&i__1, &vn1[k], &c__1);
+ if (pvt != k) {
+ dswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1);
+ i__1 = k - 1;
+ dswap_(&i__1, &f[pvt + f_dim1], ldf, &f[k + f_dim1], ldf);
+ itemp = jpvt[pvt];
+ jpvt[pvt] = jpvt[k];
+ jpvt[k] = itemp;
+ vn1[pvt] = vn1[k];
+ vn2[pvt] = vn2[k];
+ }
+
+/* Apply previous Householder reflectors to column K: */
+/* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)'. */
+
+ if (k > 1) {
+ i__1 = *m - rk + 1;
+ i__2 = k - 1;
+ dgemv_("No transpose", &i__1, &i__2, &c_b8, &a[rk + a_dim1], lda,
+ &f[k + f_dim1], ldf, &c_b9, &a[rk + k * a_dim1], &c__1);
+ }
+
+/* Generate elementary reflector H(k). */
+
+ if (rk < *m) {
+ i__1 = *m - rk + 1;
+ dlarfp_(&i__1, &a[rk + k * a_dim1], &a[rk + 1 + k * a_dim1], &
+ c__1, &tau[k]);
+ } else {
+ dlarfp_(&c__1, &a[rk + k * a_dim1], &a[rk + k * a_dim1], &c__1, &
+ tau[k]);
+ }
+
+ akk = a[rk + k * a_dim1];
+ a[rk + k * a_dim1] = 1.;
+
+/* Compute Kth column of F: */
+
+/* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)'*A(RK:M,K). */
+
+ if (k < *n) {
+ i__1 = *m - rk + 1;
+ i__2 = *n - k;
+ dgemv_("Transpose", &i__1, &i__2, &tau[k], &a[rk + (k + 1) *
+ a_dim1], lda, &a[rk + k * a_dim1], &c__1, &c_b16, &f[k +
+ 1 + k * f_dim1], &c__1);
+ }
+
+/* Padding F(1:K,K) with zeros. */
+
+ i__1 = k;
+ for (j = 1; j <= i__1; ++j) {
+ f[j + k * f_dim1] = 0.;
+/* L20: */
+ }
+
+/* Incremental updating of F: */
+/* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)' */
+/* *A(RK:M,K). */
+
+ if (k > 1) {
+ i__1 = *m - rk + 1;
+ i__2 = k - 1;
+ d__1 = -tau[k];
+ dgemv_("Transpose", &i__1, &i__2, &d__1, &a[rk + a_dim1], lda, &a[
+ rk + k * a_dim1], &c__1, &c_b16, &auxv[1], &c__1);
+
+ i__1 = k - 1;
+ dgemv_("No transpose", n, &i__1, &c_b9, &f[f_dim1 + 1], ldf, &
+ auxv[1], &c__1, &c_b9, &f[k * f_dim1 + 1], &c__1);
+ }
+
+/* Update the current row of A: */
+/* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)'. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ dgemv_("No transpose", &i__1, &k, &c_b8, &f[k + 1 + f_dim1], ldf,
+ &a[rk + a_dim1], lda, &c_b9, &a[rk + (k + 1) * a_dim1],
+ lda);
+ }
+
+/* Update partial column norms. */
+
+ if (rk < lastrk) {
+ i__1 = *n;
+ for (j = k + 1; j <= i__1; ++j) {
+ if (vn1[j] != 0.) {
+
+/* NOTE: The following 4 lines follow from the analysis in */
+/* Lapack Working Note 176. */
+
+ temp = (d__1 = a[rk + j * a_dim1], abs(d__1)) / vn1[j];
+/* Computing MAX */
+ d__1 = 0., d__2 = (temp + 1.) * (1. - temp);
+ temp = max(d__1,d__2);
+/* Computing 2nd power */
+ d__1 = vn1[j] / vn2[j];
+ temp2 = temp * (d__1 * d__1);
+ if (temp2 <= tol3z) {
+ vn2[j] = (doublereal) lsticc;
+ lsticc = j;
+ } else {
+ vn1[j] *= sqrt(temp);
+ }
+ }
+/* L30: */
+ }
+ }
+
+ a[rk + k * a_dim1] = akk;
+
+/* End of while loop. */
+
+ goto L10;
+ }
+ *kb = k;
+ rk = *offset + *kb;
+
+/* Apply the block reflector to the rest of the matrix: */
+/* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - */
+/* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)'. */
+
+/* Computing MIN */
+ i__1 = *n, i__2 = *m - *offset;
+ if (*kb < min(i__1,i__2)) {
+ i__1 = *m - rk;
+ i__2 = *n - *kb;
+ dgemm_("No transpose", "Transpose", &i__1, &i__2, kb, &c_b8, &a[rk +
+ 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b9, &a[rk + 1
+ + (*kb + 1) * a_dim1], lda);
+ }
+
+/* Recomputation of difficult columns. */
+
+L40:
+ if (lsticc > 0) {
+ itemp = i_dnnt(&vn2[lsticc]);
+ i__1 = *m - rk;
+ vn1[lsticc] = dnrm2_(&i__1, &a[rk + 1 + lsticc * a_dim1], &c__1);
+
+/* NOTE: The computation of VN1( LSTICC ) relies on the fact that */
+/* SNRM2 does not fail on vectors with norm below the value of */
+/* SQRT(DLAMCH('S')) */
+
+ vn2[lsticc] = vn1[lsticc];
+ lsticc = itemp;
+ goto L40;
+ }
+
+ return 0;
+
+/* End of DLAQPS */
+
+} /* dlaqps_ */
diff --git a/SRC/dlaqr0.c b/SRC/dlaqr0.c
new file mode 100644
index 0000000..fb20586
--- /dev/null
+++ b/SRC/dlaqr0.c
@@ -0,0 +1,758 @@
+/* dlaqr0.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__13 = 13;
+static integer c__15 = 15;
+static integer c_n1 = -1;
+static integer c__12 = 12;
+static integer c__14 = 14;
+static integer c__16 = 16;
+static logical c_false = FALSE_;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int dlaqr0_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, doublereal *h__, integer *ldh, doublereal
+ *wr, doublereal *wi, integer *iloz, integer *ihiz, doublereal *z__,
+ integer *ldz, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Local variables */
+ integer i__, k;
+ doublereal aa, bb, cc, dd;
+ integer ld;
+ doublereal cs;
+ integer nh, it, ks, kt;
+ doublereal sn;
+ integer ku, kv, ls, ns;
+ doublereal ss;
+ integer nw, inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot,
+ nmin;
+ doublereal swap;
+ integer ktop;
+ doublereal zdum[1] /* was [1][1] */;
+ integer kacc22, itmax, nsmax, nwmax, kwtop;
+ extern /* Subroutine */ int dlanv2_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *), dlaqr3_(
+ logical *, logical *, integer *, integer *, integer *, integer *,
+ doublereal *, integer *, integer *, integer *, doublereal *,
+ integer *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *),
+ dlaqr4_(logical *, logical *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *), dlaqr5_(logical *, logical *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *);
+ integer nibble;
+ extern /* Subroutine */ int dlahqr_(logical *, logical *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *), dlacpy_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ char jbcmpz[2];
+ integer nwupbd;
+ logical sorted;
+ integer lwkopt;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAQR0 computes the eigenvalues of a Hessenberg matrix H */
+/* and, optionally, the matrices T and Z from the Schur decomposition */
+/* H = Z T Z**T, where T is an upper quasi-triangular matrix (the */
+/* Schur form), and Z is the orthogonal matrix of Schur vectors. */
+
+/* Optionally Z may be postmultiplied into an input orthogonal */
+/* matrix Q so that this routine can give the Schur factorization */
+/* of a matrix A which has been reduced to the Hessenberg form H */
+/* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */
+
+/* Arguments */
+/* ========= */
+
+/* WANTT (input) LOGICAL */
+/* = .TRUE. : the full Schur form T is required; */
+/* = .FALSE.: only eigenvalues are required. */
+
+/* WANTZ (input) LOGICAL */
+/* = .TRUE. : the matrix of Schur vectors Z is required; */
+/* = .FALSE.: Schur vectors are not required. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N .GE. 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that H is already upper triangular in rows */
+/* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, */
+/* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a */
+/* previous call to DGEBAL, and then passed to DGEHRD when the */
+/* matrix output by DGEBAL is reduced to Hessenberg form. */
+/* Otherwise, ILO and IHI should be set to 1 and N, */
+/* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */
+/* If N = 0, then ILO = 1 and IHI = 0. */
+
+/* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */
+/* On entry, the upper Hessenberg matrix H. */
+/* On exit, if INFO = 0 and WANTT is .TRUE., then H contains */
+/* the upper quasi-triangular matrix T from the Schur */
+/* decomposition (the Schur form); 2-by-2 diagonal blocks */
+/* (corresponding to complex conjugate pairs of eigenvalues) */
+/* are returned in standard form, with H(i,i) = H(i+1,i+1) */
+/* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is */
+/* .FALSE., then the contents of H are unspecified on exit. */
+/* (The output value of H when INFO.GT.0 is given under the */
+/* description of INFO below.) */
+
+/* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and */
+/* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH .GE. max(1,N). */
+
+/* WR (output) DOUBLE PRECISION array, dimension (IHI) */
+/* WI (output) DOUBLE PRECISION array, dimension (IHI) */
+/* The real and imaginary parts, respectively, of the computed */
+/* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) */
+/* and WI(ILO:IHI). If two eigenvalues are computed as a */
+/* complex conjugate pair, they are stored in consecutive */
+/* elements of WR and WI, say the i-th and (i+1)th, with */
+/* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then */
+/* the eigenvalues are stored in the same order as on the */
+/* diagonal of the Schur form returned in H, with */
+/* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal */
+/* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and */
+/* WI(i+1) = -WI(i). */
+
+/* ILOZ (input) INTEGER */
+/* IHIZ (input) INTEGER */
+/* Specify the rows of Z to which transformations must be */
+/* applied if WANTZ is .TRUE.. */
+/* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. */
+
+/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI) */
+/* If WANTZ is .FALSE., then Z is not referenced. */
+/* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is */
+/* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the */
+/* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). */
+/* (The output value of Z when INFO.GT.0 is given under */
+/* the description of INFO below.) */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. if WANTZ is .TRUE. */
+/* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK */
+/* On exit, if LWORK = -1, WORK(1) returns an estimate of */
+/* the optimal value for LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK .GE. max(1,N) */
+/* is sufficient, but LWORK typically as large as 6*N may */
+/* be required for optimal performance. A workspace query */
+/* to determine the optimal workspace size is recommended. */
+
+/* If LWORK = -1, then DLAQR0 does a workspace query. */
+/* In this case, DLAQR0 checks the input parameters and */
+/* estimates the optimal workspace size for the given */
+/* values of N, ILO and IHI. The estimate is returned */
+/* in WORK(1). No error message related to LWORK is */
+/* issued by XERBLA. Neither H nor Z are accessed. */
+
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* .GT. 0: if INFO = i, DLAQR0 failed to compute all of */
+/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */
+/* and WI contain those eigenvalues which have been */
+/* successfully computed. (Failures are rare.) */
+
+/* If INFO .GT. 0 and WANT is .FALSE., then on exit, */
+/* the remaining unconverged eigenvalues are the eigen- */
+/* values of the upper Hessenberg matrix rows and */
+/* columns ILO through INFO of the final, output */
+/* value of H. */
+
+/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */
+
+/* (*) (initial value of H)*U = U*(final value of H) */
+
+/* where U is an orthogonal matrix. The final */
+/* value of H is upper Hessenberg and quasi-triangular */
+/* in rows and columns INFO+1 through IHI. */
+
+/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
+
+/* (final value of Z(ILO:IHI,ILOZ:IHIZ) */
+/* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U */
+
+/* where U is the orthogonal matrix in (*) (regard- */
+/* less of the value of WANTT.) */
+
+/* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not */
+/* accessed. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* References: */
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */
+/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */
+/* 929--947, 2002. */
+
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */
+/* of Matrix Analysis, volume 23, pages 948--973, 2002. */
+
+/* ================================================================ */
+/* .. Parameters .. */
+
+/* ==== Matrices of order NTINY or smaller must be processed by */
+/* . DLAHQR because of insufficient subdiagonal scratch space. */
+/* . (This is a hard limit.) ==== */
+
+/* ==== Exceptional deflation windows: try to cure rare */
+/* . slow convergence by varying the size of the */
+/* . deflation window after KEXNW iterations. ==== */
+
+/* ==== Exceptional shifts: try to cure rare slow convergence */
+/* . with ad-hoc exceptional shifts every KEXSH iterations. */
+/* . ==== */
+
+/* ==== The constants WILK1 and WILK2 are used to form the */
+/* . exceptional shifts. ==== */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --wr;
+ --wi;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* ==== Quick return for N = 0: nothing to do. ==== */
+
+ if (*n == 0) {
+ work[1] = 1.;
+ return 0;
+ }
+
+ if (*n <= 11) {
+
+/* ==== Tiny matrices must use DLAHQR. ==== */
+
+ lwkopt = 1;
+ if (*lwork != -1) {
+ dlahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &
+ wi[1], iloz, ihiz, &z__[z_offset], ldz, info);
+ }
+ } else {
+
+/* ==== Use small bulge multi-shift QR with aggressive early */
+/* . deflation on larger-than-tiny matrices. ==== */
+
+/* ==== Hope for the best. ==== */
+
+ *info = 0;
+
+/* ==== Set up job flags for ILAENV. ==== */
+
+ if (*wantt) {
+ *(unsigned char *)jbcmpz = 'S';
+ } else {
+ *(unsigned char *)jbcmpz = 'E';
+ }
+ if (*wantz) {
+ *(unsigned char *)&jbcmpz[1] = 'V';
+ } else {
+ *(unsigned char *)&jbcmpz[1] = 'N';
+ }
+
+/* ==== NWR = recommended deflation window size. At this */
+/* . point, N .GT. NTINY = 11, so there is enough */
+/* . subdiagonal workspace for NWR.GE.2 as required. */
+/* . (In fact, there is enough subdiagonal space for */
+/* . NWR.GE.3.) ==== */
+
+ nwr = ilaenv_(&c__13, "DLAQR0", jbcmpz, n, ilo, ihi, lwork);
+ nwr = max(2,nwr);
+/* Computing MIN */
+ i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = min(i__1,i__2);
+ nwr = min(i__1,nwr);
+
+/* ==== NSR = recommended number of simultaneous shifts. */
+/* . At this point N .GT. NTINY = 11, so there is at */
+/* . enough subdiagonal workspace for NSR to be even */
+/* . and greater than or equal to two as required. ==== */
+
+ nsr = ilaenv_(&c__15, "DLAQR0", jbcmpz, n, ilo, ihi, lwork);
+/* Computing MIN */
+ i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = min(i__1,i__2), i__2 = *ihi -
+ *ilo;
+ nsr = min(i__1,i__2);
+/* Computing MAX */
+ i__1 = 2, i__2 = nsr - nsr % 2;
+ nsr = max(i__1,i__2);
+
+/* ==== Estimate optimal workspace ==== */
+
+/* ==== Workspace query call to DLAQR3 ==== */
+
+ i__1 = nwr + 1;
+ dlaqr3_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz,
+ ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[
+ h_offset], ldh, n, &h__[h_offset], ldh, n, &h__[h_offset],
+ ldh, &work[1], &c_n1);
+
+/* ==== Optimal workspace = MAX(DLAQR5, DLAQR3) ==== */
+
+/* Computing MAX */
+ i__1 = nsr * 3 / 2, i__2 = (integer) work[1];
+ lwkopt = max(i__1,i__2);
+
+/* ==== Quick return in case of workspace query. ==== */
+
+ if (*lwork == -1) {
+ work[1] = (doublereal) lwkopt;
+ return 0;
+ }
+
+/* ==== DLAHQR/DLAQR0 crossover point ==== */
+
+ nmin = ilaenv_(&c__12, "DLAQR0", jbcmpz, n, ilo, ihi, lwork);
+ nmin = max(11,nmin);
+
+/* ==== Nibble crossover point ==== */
+
+ nibble = ilaenv_(&c__14, "DLAQR0", jbcmpz, n, ilo, ihi, lwork);
+ nibble = max(0,nibble);
+
+/* ==== Accumulate reflections during ttswp? Use block */
+/* . 2-by-2 structure during matrix-matrix multiply? ==== */
+
+ kacc22 = ilaenv_(&c__16, "DLAQR0", jbcmpz, n, ilo, ihi, lwork);
+ kacc22 = max(0,kacc22);
+ kacc22 = min(2,kacc22);
+
+/* ==== NWMAX = the largest possible deflation window for */
+/* . which there is sufficient workspace. ==== */
+
+/* Computing MIN */
+ i__1 = (*n - 1) / 3, i__2 = *lwork / 2;
+ nwmax = min(i__1,i__2);
+ nw = nwmax;
+
+/* ==== NSMAX = the Largest number of simultaneous shifts */
+/* . for which there is sufficient workspace. ==== */
+
+/* Computing MIN */
+ i__1 = (*n + 6) / 9, i__2 = (*lwork << 1) / 3;
+ nsmax = min(i__1,i__2);
+ nsmax -= nsmax % 2;
+
+/* ==== NDFL: an iteration count restarted at deflation. ==== */
+
+ ndfl = 1;
+
+/* ==== ITMAX = iteration limit ==== */
+
+/* Computing MAX */
+ i__1 = 10, i__2 = *ihi - *ilo + 1;
+ itmax = max(i__1,i__2) * 30;
+
+/* ==== Last row and column in the active block ==== */
+
+ kbot = *ihi;
+
+/* ==== Main Loop ==== */
+
+ i__1 = itmax;
+ for (it = 1; it <= i__1; ++it) {
+
+/* ==== Done when KBOT falls below ILO ==== */
+
+ if (kbot < *ilo) {
+ goto L90;
+ }
+
+/* ==== Locate active block ==== */
+
+ i__2 = *ilo + 1;
+ for (k = kbot; k >= i__2; --k) {
+ if (h__[k + (k - 1) * h_dim1] == 0.) {
+ goto L20;
+ }
+/* L10: */
+ }
+ k = *ilo;
+L20:
+ ktop = k;
+
+/* ==== Select deflation window size: */
+/* . Typical Case: */
+/* . If possible and advisable, nibble the entire */
+/* . active block. If not, use size MIN(NWR,NWMAX) */
+/* . or MIN(NWR+1,NWMAX) depending upon which has */
+/* . the smaller corresponding subdiagonal entry */
+/* . (a heuristic). */
+/* . */
+/* . Exceptional Case: */
+/* . If there have been no deflations in KEXNW or */
+/* . more iterations, then vary the deflation window */
+/* . size. At first, because, larger windows are, */
+/* . in general, more powerful than smaller ones, */
+/* . rapidly increase the window to the maximum possible. */
+/* . Then, gradually reduce the window size. ==== */
+
+ nh = kbot - ktop + 1;
+ nwupbd = min(nh,nwmax);
+ if (ndfl < 5) {
+ nw = min(nwupbd,nwr);
+ } else {
+/* Computing MIN */
+ i__2 = nwupbd, i__3 = nw << 1;
+ nw = min(i__2,i__3);
+ }
+ if (nw < nwmax) {
+ if (nw >= nh - 1) {
+ nw = nh;
+ } else {
+ kwtop = kbot - nw + 1;
+ if ((d__1 = h__[kwtop + (kwtop - 1) * h_dim1], abs(d__1))
+ > (d__2 = h__[kwtop - 1 + (kwtop - 2) * h_dim1],
+ abs(d__2))) {
+ ++nw;
+ }
+ }
+ }
+ if (ndfl < 5) {
+ ndec = -1;
+ } else if (ndec >= 0 || nw >= nwupbd) {
+ ++ndec;
+ if (nw - ndec < 2) {
+ ndec = 0;
+ }
+ nw -= ndec;
+ }
+
+/* ==== Aggressive early deflation: */
+/* . split workspace under the subdiagonal into */
+/* . - an nw-by-nw work array V in the lower */
+/* . left-hand-corner, */
+/* . - an NW-by-at-least-NW-but-more-is-better */
+/* . (NW-by-NHO) horizontal work array along */
+/* . the bottom edge, */
+/* . - an at-least-NW-but-more-is-better (NHV-by-NW) */
+/* . vertical work array along the left-hand-edge. */
+/* . ==== */
+
+ kv = *n - nw + 1;
+ kt = nw + 1;
+ nho = *n - nw - 1 - kt + 1;
+ kwv = nw + 2;
+ nve = *n - nw - kwv + 1;
+
+/* ==== Aggressive early deflation ==== */
+
+ dlaqr3_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh,
+ iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1],
+ &h__[kv + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1],
+ ldh, &nve, &h__[kwv + h_dim1], ldh, &work[1], lwork);
+
+/* ==== Adjust KBOT accounting for new deflations. ==== */
+
+ kbot -= ld;
+
+/* ==== KS points to the shifts. ==== */
+
+ ks = kbot - ls + 1;
+
+/* ==== Skip an expensive QR sweep if there is a (partly */
+/* . heuristic) reason to expect that many eigenvalues */
+/* . will deflate without it. Here, the QR sweep is */
+/* . skipped if many eigenvalues have just been deflated */
+/* . or if the remaining active block is small. */
+
+ if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > min(
+ nmin,nwmax)) {
+
+/* ==== NS = nominal number of simultaneous shifts. */
+/* . This may be lowered (slightly) if DLAQR3 */
+/* . did not provide that many shifts. ==== */
+
+/* Computing MIN */
+/* Computing MAX */
+ i__4 = 2, i__5 = kbot - ktop;
+ i__2 = min(nsmax,nsr), i__3 = max(i__4,i__5);
+ ns = min(i__2,i__3);
+ ns -= ns % 2;
+
+/* ==== If there have been no deflations */
+/* . in a multiple of KEXSH iterations, */
+/* . then try exceptional shifts. */
+/* . Otherwise use shifts provided by */
+/* . DLAQR3 above or from the eigenvalues */
+/* . of a trailing principal submatrix. ==== */
+
+ if (ndfl % 6 == 0) {
+ ks = kbot - ns + 1;
+/* Computing MAX */
+ i__3 = ks + 1, i__4 = ktop + 2;
+ i__2 = max(i__3,i__4);
+ for (i__ = kbot; i__ >= i__2; i__ += -2) {
+ ss = (d__1 = h__[i__ + (i__ - 1) * h_dim1], abs(d__1))
+ + (d__2 = h__[i__ - 1 + (i__ - 2) * h_dim1],
+ abs(d__2));
+ aa = ss * .75 + h__[i__ + i__ * h_dim1];
+ bb = ss;
+ cc = ss * -.4375;
+ dd = aa;
+ dlanv2_(&aa, &bb, &cc, &dd, &wr[i__ - 1], &wi[i__ - 1]
+, &wr[i__], &wi[i__], &cs, &sn);
+/* L30: */
+ }
+ if (ks == ktop) {
+ wr[ks + 1] = h__[ks + 1 + (ks + 1) * h_dim1];
+ wi[ks + 1] = 0.;
+ wr[ks] = wr[ks + 1];
+ wi[ks] = wi[ks + 1];
+ }
+ } else {
+
+/* ==== Got NS/2 or fewer shifts? Use DLAQR4 or */
+/* . DLAHQR on a trailing principal submatrix to */
+/* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, */
+/* . there is enough space below the subdiagonal */
+/* . to fit an NS-by-NS scratch array.) ==== */
+
+ if (kbot - ks + 1 <= ns / 2) {
+ ks = kbot - ns + 1;
+ kt = *n - ns + 1;
+ dlacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, &
+ h__[kt + h_dim1], ldh);
+ if (ns > nmin) {
+ dlaqr4_(&c_false, &c_false, &ns, &c__1, &ns, &h__[
+ kt + h_dim1], ldh, &wr[ks], &wi[ks], &
+ c__1, &c__1, zdum, &c__1, &work[1], lwork,
+ &inf);
+ } else {
+ dlahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[
+ kt + h_dim1], ldh, &wr[ks], &wi[ks], &
+ c__1, &c__1, zdum, &c__1, &inf);
+ }
+ ks += inf;
+
+/* ==== In case of a rare QR failure use */
+/* . eigenvalues of the trailing 2-by-2 */
+/* . principal submatrix. ==== */
+
+ if (ks >= kbot) {
+ aa = h__[kbot - 1 + (kbot - 1) * h_dim1];
+ cc = h__[kbot + (kbot - 1) * h_dim1];
+ bb = h__[kbot - 1 + kbot * h_dim1];
+ dd = h__[kbot + kbot * h_dim1];
+ dlanv2_(&aa, &bb, &cc, &dd, &wr[kbot - 1], &wi[
+ kbot - 1], &wr[kbot], &wi[kbot], &cs, &sn)
+ ;
+ ks = kbot - 1;
+ }
+ }
+
+ if (kbot - ks + 1 > ns) {
+
+/* ==== Sort the shifts (Helps a little) */
+/* . Bubble sort keeps complex conjugate */
+/* . pairs together. ==== */
+
+ sorted = FALSE_;
+ i__2 = ks + 1;
+ for (k = kbot; k >= i__2; --k) {
+ if (sorted) {
+ goto L60;
+ }
+ sorted = TRUE_;
+ i__3 = k - 1;
+ for (i__ = ks; i__ <= i__3; ++i__) {
+ if ((d__1 = wr[i__], abs(d__1)) + (d__2 = wi[
+ i__], abs(d__2)) < (d__3 = wr[i__ + 1]
+ , abs(d__3)) + (d__4 = wi[i__ + 1],
+ abs(d__4))) {
+ sorted = FALSE_;
+
+ swap = wr[i__];
+ wr[i__] = wr[i__ + 1];
+ wr[i__ + 1] = swap;
+
+ swap = wi[i__];
+ wi[i__] = wi[i__ + 1];
+ wi[i__ + 1] = swap;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+L60:
+ ;
+ }
+
+/* ==== Shuffle shifts into pairs of real shifts */
+/* . and pairs of complex conjugate shifts */
+/* . assuming complex conjugate shifts are */
+/* . already adjacent to one another. (Yes, */
+/* . they are.) ==== */
+
+ i__2 = ks + 2;
+ for (i__ = kbot; i__ >= i__2; i__ += -2) {
+ if (wi[i__] != -wi[i__ - 1]) {
+
+ swap = wr[i__];
+ wr[i__] = wr[i__ - 1];
+ wr[i__ - 1] = wr[i__ - 2];
+ wr[i__ - 2] = swap;
+
+ swap = wi[i__];
+ wi[i__] = wi[i__ - 1];
+ wi[i__ - 1] = wi[i__ - 2];
+ wi[i__ - 2] = swap;
+ }
+/* L70: */
+ }
+ }
+
+/* ==== If there are only two shifts and both are */
+/* . real, then use only one. ==== */
+
+ if (kbot - ks + 1 == 2) {
+ if (wi[kbot] == 0.) {
+ if ((d__1 = wr[kbot] - h__[kbot + kbot * h_dim1], abs(
+ d__1)) < (d__2 = wr[kbot - 1] - h__[kbot +
+ kbot * h_dim1], abs(d__2))) {
+ wr[kbot - 1] = wr[kbot];
+ } else {
+ wr[kbot] = wr[kbot - 1];
+ }
+ }
+ }
+
+/* ==== Use up to NS of the the smallest magnatiude */
+/* . shifts. If there aren't NS shifts available, */
+/* . then use them all, possibly dropping one to */
+/* . make the number of shifts even. ==== */
+
+/* Computing MIN */
+ i__2 = ns, i__3 = kbot - ks + 1;
+ ns = min(i__2,i__3);
+ ns -= ns % 2;
+ ks = kbot - ns + 1;
+
+/* ==== Small-bulge multi-shift QR sweep: */
+/* . split workspace under the subdiagonal into */
+/* . - a KDU-by-KDU work array U in the lower */
+/* . left-hand-corner, */
+/* . - a KDU-by-at-least-KDU-but-more-is-better */
+/* . (KDU-by-NHo) horizontal work array WH along */
+/* . the bottom edge, */
+/* . - and an at-least-KDU-but-more-is-better-by-KDU */
+/* . (NVE-by-KDU) vertical work WV arrow along */
+/* . the left-hand-edge. ==== */
+
+ kdu = ns * 3 - 3;
+ ku = *n - kdu + 1;
+ kwh = kdu + 1;
+ nho = *n - kdu - 3 - (kdu + 1) + 1;
+ kwv = kdu + 4;
+ nve = *n - kdu - kwv + 1;
+
+/* ==== Small-bulge multi-shift QR sweep ==== */
+
+ dlaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &wr[ks],
+ &wi[ks], &h__[h_offset], ldh, iloz, ihiz, &z__[
+ z_offset], ldz, &work[1], &c__3, &h__[ku + h_dim1],
+ ldh, &nve, &h__[kwv + h_dim1], ldh, &nho, &h__[ku +
+ kwh * h_dim1], ldh);
+ }
+
+/* ==== Note progress (or the lack of it). ==== */
+
+ if (ld > 0) {
+ ndfl = 1;
+ } else {
+ ++ndfl;
+ }
+
+/* ==== End of main loop ==== */
+/* L80: */
+ }
+
+/* ==== Iteration limit exceeded. Set INFO to show where */
+/* . the problem occurred and exit. ==== */
+
+ *info = kbot;
+L90:
+ ;
+ }
+
+/* ==== Return the optimal value of LWORK. ==== */
+
+ work[1] = (doublereal) lwkopt;
+
+/* ==== End of DLAQR0 ==== */
+
+ return 0;
+} /* dlaqr0_ */
diff --git a/SRC/dlaqr1.c b/SRC/dlaqr1.c
new file mode 100644
index 0000000..5870b41
--- /dev/null
+++ b/SRC/dlaqr1.c
@@ -0,0 +1,127 @@
+/* dlaqr1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlaqr1_(integer *n, doublereal *h__, integer *ldh,
+ doublereal *sr1, doublereal *si1, doublereal *sr2, doublereal *si2,
+ doublereal *v)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ doublereal s, h21s, h31s;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Given a 2-by-2 or 3-by-3 matrix H, DLAQR1 sets v to a */
+/* scalar multiple of the first column of the product */
+
+/* (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I) */
+
+/* scaling to avoid overflows and most underflows. It */
+/* is assumed that either */
+
+/* 1) sr1 = sr2 and si1 = -si2 */
+/* or */
+/* 2) si1 = si2 = 0. */
+
+/* This is useful for starting double implicit shift bulges */
+/* in the QR algorithm. */
+
+
+/* N (input) integer */
+/* Order of the matrix H. N must be either 2 or 3. */
+
+/* H (input) DOUBLE PRECISION array of dimension (LDH,N) */
+/* The 2-by-2 or 3-by-3 matrix H in (*). */
+
+/* LDH (input) integer */
+/* The leading dimension of H as declared in */
+/* the calling procedure. LDH.GE.N */
+
+/* SR1 (input) DOUBLE PRECISION */
+/* SI1 The shifts in (*). */
+/* SR2 */
+/* SI2 */
+
+/* V (output) DOUBLE PRECISION array of dimension N */
+/* A scalar multiple of the first column of the */
+/* matrix K in (*). */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --v;
+
+ /* Function Body */
+ if (*n == 2) {
+ s = (d__1 = h__[h_dim1 + 1] - *sr2, abs(d__1)) + abs(*si2) + (d__2 =
+ h__[h_dim1 + 2], abs(d__2));
+ if (s == 0.) {
+ v[1] = 0.;
+ v[2] = 0.;
+ } else {
+ h21s = h__[h_dim1 + 2] / s;
+ v[1] = h21s * h__[(h_dim1 << 1) + 1] + (h__[h_dim1 + 1] - *sr1) *
+ ((h__[h_dim1 + 1] - *sr2) / s) - *si1 * (*si2 / s);
+ v[2] = h21s * (h__[h_dim1 + 1] + h__[(h_dim1 << 1) + 2] - *sr1 - *
+ sr2);
+ }
+ } else {
+ s = (d__1 = h__[h_dim1 + 1] - *sr2, abs(d__1)) + abs(*si2) + (d__2 =
+ h__[h_dim1 + 2], abs(d__2)) + (d__3 = h__[h_dim1 + 3], abs(
+ d__3));
+ if (s == 0.) {
+ v[1] = 0.;
+ v[2] = 0.;
+ v[3] = 0.;
+ } else {
+ h21s = h__[h_dim1 + 2] / s;
+ h31s = h__[h_dim1 + 3] / s;
+ v[1] = (h__[h_dim1 + 1] - *sr1) * ((h__[h_dim1 + 1] - *sr2) / s)
+ - *si1 * (*si2 / s) + h__[(h_dim1 << 1) + 1] * h21s + h__[
+ h_dim1 * 3 + 1] * h31s;
+ v[2] = h21s * (h__[h_dim1 + 1] + h__[(h_dim1 << 1) + 2] - *sr1 - *
+ sr2) + h__[h_dim1 * 3 + 2] * h31s;
+ v[3] = h31s * (h__[h_dim1 + 1] + h__[h_dim1 * 3 + 3] - *sr1 - *
+ sr2) + h21s * h__[(h_dim1 << 1) + 3];
+ }
+ }
+ return 0;
+} /* dlaqr1_ */
diff --git a/SRC/dlaqr2.c b/SRC/dlaqr2.c
new file mode 100644
index 0000000..9990445
--- /dev/null
+++ b/SRC/dlaqr2.c
@@ -0,0 +1,698 @@
+/* dlaqr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b12 = 0.;
+static doublereal c_b13 = 1.;
+static logical c_true = TRUE_;
+
+/* Subroutine */ int dlaqr2_(logical *wantt, logical *wantz, integer *n,
+ integer *ktop, integer *kbot, integer *nw, doublereal *h__, integer *
+ ldh, integer *iloz, integer *ihiz, doublereal *z__, integer *ldz,
+ integer *ns, integer *nd, doublereal *sr, doublereal *si, doublereal *
+ v, integer *ldv, integer *nh, doublereal *t, integer *ldt, integer *
+ nv, doublereal *wv, integer *ldwv, doublereal *work, integer *lwork)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1,
+ wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal s, aa, bb, cc, dd, cs, sn;
+ integer jw;
+ doublereal evi, evk, foo;
+ integer kln;
+ doublereal tau, ulp;
+ integer lwk1, lwk2;
+ doublereal beta;
+ integer kend, kcol, info, ifst, ilst, ltop, krow;
+ extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *), dgemm_(char *, char *, integer *, integer *
+, integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ logical bulge;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer infqr, kwtop;
+ extern /* Subroutine */ int dlanv2_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *), dlabad_(
+ doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dgehrd_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dlarfg_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *), dlahqr_(logical *, logical *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *), dlacpy_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *);
+ doublereal safmin;
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ doublereal safmax;
+ extern /* Subroutine */ int dtrexc_(char *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, integer *,
+ doublereal *, integer *), dormhr_(char *, char *, integer
+ *, integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ integer *);
+ logical sorted;
+ doublereal smlnum;
+ integer lwkopt;
+
+
+/* -- LAPACK auxiliary routine (version 3.2.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* -- April 2009 -- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* This subroutine is identical to DLAQR3 except that it avoids */
+/* recursion by calling DLAHQR instead of DLAQR4. */
+
+
+/* ****************************************************************** */
+/* Aggressive early deflation: */
+
+/* This subroutine accepts as input an upper Hessenberg matrix */
+/* H and performs an orthogonal similarity transformation */
+/* designed to detect and deflate fully converged eigenvalues from */
+/* a trailing principal submatrix. On output H has been over- */
+/* written by a new Hessenberg matrix that is a perturbation of */
+/* an orthogonal similarity transformation of H. It is to be */
+/* hoped that the final version of H has many zero subdiagonal */
+/* entries. */
+
+/* ****************************************************************** */
+/* WANTT (input) LOGICAL */
+/* If .TRUE., then the Hessenberg matrix H is fully updated */
+/* so that the quasi-triangular Schur factor may be */
+/* computed (in cooperation with the calling subroutine). */
+/* If .FALSE., then only enough of H is updated to preserve */
+/* the eigenvalues. */
+
+/* WANTZ (input) LOGICAL */
+/* If .TRUE., then the orthogonal matrix Z is updated so */
+/* so that the orthogonal Schur factor may be computed */
+/* (in cooperation with the calling subroutine). */
+/* If .FALSE., then Z is not referenced. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H and (if WANTZ is .TRUE.) the */
+/* order of the orthogonal matrix Z. */
+
+/* KTOP (input) INTEGER */
+/* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */
+/* KBOT and KTOP together determine an isolated block */
+/* along the diagonal of the Hessenberg matrix. */
+
+/* KBOT (input) INTEGER */
+/* It is assumed without a check that either */
+/* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */
+/* determine an isolated block along the diagonal of the */
+/* Hessenberg matrix. */
+
+/* NW (input) INTEGER */
+/* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). */
+
+/* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */
+/* On input the initial N-by-N section of H stores the */
+/* Hessenberg matrix undergoing aggressive early deflation. */
+/* On output H has been transformed by an orthogonal */
+/* similarity transformation, perturbed, and the returned */
+/* to Hessenberg form that (it is to be hoped) has some */
+/* zero subdiagonal entries. */
+
+/* LDH (input) integer */
+/* Leading dimension of H just as declared in the calling */
+/* subroutine. N .LE. LDH */
+
+/* ILOZ (input) INTEGER */
+/* IHIZ (input) INTEGER */
+/* Specify the rows of Z to which transformations must be */
+/* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. */
+
+/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
+/* IF WANTZ is .TRUE., then on output, the orthogonal */
+/* similarity transformation mentioned above has been */
+/* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. */
+/* If WANTZ is .FALSE., then Z is unreferenced. */
+
+/* LDZ (input) integer */
+/* The leading dimension of Z just as declared in the */
+/* calling subroutine. 1 .LE. LDZ. */
+
+/* NS (output) integer */
+/* The number of unconverged (ie approximate) eigenvalues */
+/* returned in SR and SI that may be used as shifts by the */
+/* calling subroutine. */
+
+/* ND (output) integer */
+/* The number of converged eigenvalues uncovered by this */
+/* subroutine. */
+
+/* SR (output) DOUBLE PRECISION array, dimension KBOT */
+/* SI (output) DOUBLE PRECISION array, dimension KBOT */
+/* On output, the real and imaginary parts of approximate */
+/* eigenvalues that may be used for shifts are stored in */
+/* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and */
+/* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. */
+/* The real and imaginary parts of converged eigenvalues */
+/* are stored in SR(KBOT-ND+1) through SR(KBOT) and */
+/* SI(KBOT-ND+1) through SI(KBOT), respectively. */
+
+/* V (workspace) DOUBLE PRECISION array, dimension (LDV,NW) */
+/* An NW-by-NW work array. */
+
+/* LDV (input) integer scalar */
+/* The leading dimension of V just as declared in the */
+/* calling subroutine. NW .LE. LDV */
+
+/* NH (input) integer scalar */
+/* The number of columns of T. NH.GE.NW. */
+
+/* T (workspace) DOUBLE PRECISION array, dimension (LDT,NW) */
+
+/* LDT (input) integer */
+/* The leading dimension of T just as declared in the */
+/* calling subroutine. NW .LE. LDT */
+
+/* NV (input) integer */
+/* The number of rows of work array WV available for */
+/* workspace. NV.GE.NW. */
+
+/* WV (workspace) DOUBLE PRECISION array, dimension (LDWV,NW) */
+
+/* LDWV (input) integer */
+/* The leading dimension of W just as declared in the */
+/* calling subroutine. NW .LE. LDV */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension LWORK. */
+/* On exit, WORK(1) is set to an estimate of the optimal value */
+/* of LWORK for the given values of N, NW, KTOP and KBOT. */
+
+/* LWORK (input) integer */
+/* The dimension of the work array WORK. LWORK = 2*NW */
+/* suffices, but greater efficiency may result from larger */
+/* values of LWORK. */
+
+/* If LWORK = -1, then a workspace query is assumed; DLAQR2 */
+/* only estimates the optimal workspace size for the given */
+/* values of N, NW, KTOP and KBOT. The estimate is returned */
+/* in WORK(1). No error message related to LWORK is issued */
+/* by XERBLA. Neither H nor Z are accessed. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* ==== Estimate optimal workspace. ==== */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --sr;
+ --si;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ wv_dim1 = *ldwv;
+ wv_offset = 1 + wv_dim1;
+ wv -= wv_offset;
+ --work;
+
+ /* Function Body */
+/* Computing MIN */
+ i__1 = *nw, i__2 = *kbot - *ktop + 1;
+ jw = min(i__1,i__2);
+ if (jw <= 2) {
+ lwkopt = 1;
+ } else {
+
+/* ==== Workspace query call to DGEHRD ==== */
+
+ i__1 = jw - 1;
+ dgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], &
+ c_n1, &info);
+ lwk1 = (integer) work[1];
+
+/* ==== Workspace query call to DORMHR ==== */
+
+ i__1 = jw - 1;
+ dormhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1],
+ &v[v_offset], ldv, &work[1], &c_n1, &info);
+ lwk2 = (integer) work[1];
+
+/* ==== Optimal workspace ==== */
+
+ lwkopt = jw + max(lwk1,lwk2);
+ }
+
+/* ==== Quick return in case of workspace query. ==== */
+
+ if (*lwork == -1) {
+ work[1] = (doublereal) lwkopt;
+ return 0;
+ }
+
+/* ==== Nothing to do ... */
+/* ... for an empty active block ... ==== */
+ *ns = 0;
+ *nd = 0;
+ work[1] = 1.;
+ if (*ktop > *kbot) {
+ return 0;
+ }
+/* ... nor for an empty deflation window. ==== */
+ if (*nw < 1) {
+ return 0;
+ }
+
+/* ==== Machine constants ==== */
+
+ safmin = dlamch_("SAFE MINIMUM");
+ safmax = 1. / safmin;
+ dlabad_(&safmin, &safmax);
+ ulp = dlamch_("PRECISION");
+ smlnum = safmin * ((doublereal) (*n) / ulp);
+
+/* ==== Setup deflation window ==== */
+
+/* Computing MIN */
+ i__1 = *nw, i__2 = *kbot - *ktop + 1;
+ jw = min(i__1,i__2);
+ kwtop = *kbot - jw + 1;
+ if (kwtop == *ktop) {
+ s = 0.;
+ } else {
+ s = h__[kwtop + (kwtop - 1) * h_dim1];
+ }
+
+ if (*kbot == kwtop) {
+
+/* ==== 1-by-1 deflation window: not much to do ==== */
+
+ sr[kwtop] = h__[kwtop + kwtop * h_dim1];
+ si[kwtop] = 0.;
+ *ns = 1;
+ *nd = 0;
+/* Computing MAX */
+ d__2 = smlnum, d__3 = ulp * (d__1 = h__[kwtop + kwtop * h_dim1], abs(
+ d__1));
+ if (abs(s) <= max(d__2,d__3)) {
+ *ns = 0;
+ *nd = 1;
+ if (kwtop > *ktop) {
+ h__[kwtop + (kwtop - 1) * h_dim1] = 0.;
+ }
+ }
+ work[1] = 1.;
+ return 0;
+ }
+
+/* ==== Convert to spike-triangular form. (In case of a */
+/* . rare QR failure, this routine continues to do */
+/* . aggressive early deflation using that part of */
+/* . the deflation window that converged using INFQR */
+/* . here and there to keep track.) ==== */
+
+ dlacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset],
+ ldt);
+ i__1 = jw - 1;
+ i__2 = *ldh + 1;
+ i__3 = *ldt + 1;
+ dcopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], &
+ i__3);
+
+ dlaset_("A", &jw, &jw, &c_b12, &c_b13, &v[v_offset], ldv);
+ dlahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[kwtop],
+ &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr);
+
+/* ==== DTREXC needs a clean margin near the diagonal ==== */
+
+ i__1 = jw - 3;
+ for (j = 1; j <= i__1; ++j) {
+ t[j + 2 + j * t_dim1] = 0.;
+ t[j + 3 + j * t_dim1] = 0.;
+/* L10: */
+ }
+ if (jw > 2) {
+ t[jw + (jw - 2) * t_dim1] = 0.;
+ }
+
+/* ==== Deflation detection loop ==== */
+
+ *ns = jw;
+ ilst = infqr + 1;
+L20:
+ if (ilst <= *ns) {
+ if (*ns == 1) {
+ bulge = FALSE_;
+ } else {
+ bulge = t[*ns + (*ns - 1) * t_dim1] != 0.;
+ }
+
+/* ==== Small spike tip test for deflation ==== */
+
+ if (! bulge) {
+
+/* ==== Real eigenvalue ==== */
+
+ foo = (d__1 = t[*ns + *ns * t_dim1], abs(d__1));
+ if (foo == 0.) {
+ foo = abs(s);
+ }
+/* Computing MAX */
+ d__2 = smlnum, d__3 = ulp * foo;
+ if ((d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)) <= max(d__2,d__3))
+ {
+
+/* ==== Deflatable ==== */
+
+ --(*ns);
+ } else {
+
+/* ==== Undeflatable. Move it up out of the way. */
+/* . (DTREXC can not fail in this case.) ==== */
+
+ ifst = *ns;
+ dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
+ &ilst, &work[1], &info);
+ ++ilst;
+ }
+ } else {
+
+/* ==== Complex conjugate pair ==== */
+
+ foo = (d__3 = t[*ns + *ns * t_dim1], abs(d__3)) + sqrt((d__1 = t[*
+ ns + (*ns - 1) * t_dim1], abs(d__1))) * sqrt((d__2 = t[*
+ ns - 1 + *ns * t_dim1], abs(d__2)));
+ if (foo == 0.) {
+ foo = abs(s);
+ }
+/* Computing MAX */
+ d__3 = (d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)), d__4 = (d__2 =
+ s * v[(*ns - 1) * v_dim1 + 1], abs(d__2));
+/* Computing MAX */
+ d__5 = smlnum, d__6 = ulp * foo;
+ if (max(d__3,d__4) <= max(d__5,d__6)) {
+
+/* ==== Deflatable ==== */
+
+ *ns += -2;
+ } else {
+
+/* ==== Undeflatable. Move them up out of the way. */
+/* . Fortunately, DTREXC does the right thing with */
+/* . ILST in case of a rare exchange failure. ==== */
+
+ ifst = *ns;
+ dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
+ &ilst, &work[1], &info);
+ ilst += 2;
+ }
+ }
+
+/* ==== End deflation detection loop ==== */
+
+ goto L20;
+ }
+
+/* ==== Return to Hessenberg form ==== */
+
+ if (*ns == 0) {
+ s = 0.;
+ }
+
+ if (*ns < jw) {
+
+/* ==== sorting diagonal blocks of T improves accuracy for */
+/* . graded matrices. Bubble sort deals well with */
+/* . exchange failures. ==== */
+
+ sorted = FALSE_;
+ i__ = *ns + 1;
+L30:
+ if (sorted) {
+ goto L50;
+ }
+ sorted = TRUE_;
+
+ kend = i__ - 1;
+ i__ = infqr + 1;
+ if (i__ == *ns) {
+ k = i__ + 1;
+ } else if (t[i__ + 1 + i__ * t_dim1] == 0.) {
+ k = i__ + 1;
+ } else {
+ k = i__ + 2;
+ }
+L40:
+ if (k <= kend) {
+ if (k == i__ + 1) {
+ evi = (d__1 = t[i__ + i__ * t_dim1], abs(d__1));
+ } else {
+ evi = (d__3 = t[i__ + i__ * t_dim1], abs(d__3)) + sqrt((d__1 =
+ t[i__ + 1 + i__ * t_dim1], abs(d__1))) * sqrt((d__2 =
+ t[i__ + (i__ + 1) * t_dim1], abs(d__2)));
+ }
+
+ if (k == kend) {
+ evk = (d__1 = t[k + k * t_dim1], abs(d__1));
+ } else if (t[k + 1 + k * t_dim1] == 0.) {
+ evk = (d__1 = t[k + k * t_dim1], abs(d__1));
+ } else {
+ evk = (d__3 = t[k + k * t_dim1], abs(d__3)) + sqrt((d__1 = t[
+ k + 1 + k * t_dim1], abs(d__1))) * sqrt((d__2 = t[k +
+ (k + 1) * t_dim1], abs(d__2)));
+ }
+
+ if (evi >= evk) {
+ i__ = k;
+ } else {
+ sorted = FALSE_;
+ ifst = i__;
+ ilst = k;
+ dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
+ &ilst, &work[1], &info);
+ if (info == 0) {
+ i__ = ilst;
+ } else {
+ i__ = k;
+ }
+ }
+ if (i__ == kend) {
+ k = i__ + 1;
+ } else if (t[i__ + 1 + i__ * t_dim1] == 0.) {
+ k = i__ + 1;
+ } else {
+ k = i__ + 2;
+ }
+ goto L40;
+ }
+ goto L30;
+L50:
+ ;
+ }
+
+/* ==== Restore shift/eigenvalue array from T ==== */
+
+ i__ = jw;
+L60:
+ if (i__ >= infqr + 1) {
+ if (i__ == infqr + 1) {
+ sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
+ si[kwtop + i__ - 1] = 0.;
+ --i__;
+ } else if (t[i__ + (i__ - 1) * t_dim1] == 0.) {
+ sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
+ si[kwtop + i__ - 1] = 0.;
+ --i__;
+ } else {
+ aa = t[i__ - 1 + (i__ - 1) * t_dim1];
+ cc = t[i__ + (i__ - 1) * t_dim1];
+ bb = t[i__ - 1 + i__ * t_dim1];
+ dd = t[i__ + i__ * t_dim1];
+ dlanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__
+ - 2], &sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, &
+ sn);
+ i__ += -2;
+ }
+ goto L60;
+ }
+
+ if (*ns < jw || s == 0.) {
+ if (*ns > 1 && s != 0.) {
+
+/* ==== Reflect spike back into lower triangle ==== */
+
+ dcopy_(ns, &v[v_offset], ldv, &work[1], &c__1);
+ beta = work[1];
+ dlarfg_(ns, &beta, &work[2], &c__1, &tau);
+ work[1] = 1.;
+
+ i__1 = jw - 2;
+ i__2 = jw - 2;
+ dlaset_("L", &i__1, &i__2, &c_b12, &c_b12, &t[t_dim1 + 3], ldt);
+
+ dlarf_("L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, &
+ work[jw + 1]);
+ dlarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, &
+ work[jw + 1]);
+ dlarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, &
+ work[jw + 1]);
+
+ i__1 = *lwork - jw;
+ dgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1]
+, &i__1, &info);
+ }
+
+/* ==== Copy updated reduced window into place ==== */
+
+ if (kwtop > 1) {
+ h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1];
+ }
+ dlacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1]
+, ldh);
+ i__1 = jw - 1;
+ i__2 = *ldt + 1;
+ i__3 = *ldh + 1;
+ dcopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1],
+ &i__3);
+
+/* ==== Accumulate orthogonal matrix in order update */
+/* . H and Z, if requested. ==== */
+
+ if (*ns > 1 && s != 0.) {
+ i__1 = *lwork - jw;
+ dormhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1],
+ &v[v_offset], ldv, &work[jw + 1], &i__1, &info);
+ }
+
+/* ==== Update vertical slab in H ==== */
+
+ if (*wantt) {
+ ltop = 1;
+ } else {
+ ltop = *ktop;
+ }
+ i__1 = kwtop - 1;
+ i__2 = *nv;
+ for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *nv, i__4 = kwtop - krow;
+ kln = min(i__3,i__4);
+ dgemm_("N", "N", &kln, &jw, &jw, &c_b13, &h__[krow + kwtop *
+ h_dim1], ldh, &v[v_offset], ldv, &c_b12, &wv[wv_offset],
+ ldwv);
+ dlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop *
+ h_dim1], ldh);
+/* L70: */
+ }
+
+/* ==== Update horizontal slab in H ==== */
+
+ if (*wantt) {
+ i__2 = *n;
+ i__1 = *nh;
+ for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2;
+ kcol += i__1) {
+/* Computing MIN */
+ i__3 = *nh, i__4 = *n - kcol + 1;
+ kln = min(i__3,i__4);
+ dgemm_("C", "N", &jw, &kln, &jw, &c_b13, &v[v_offset], ldv, &
+ h__[kwtop + kcol * h_dim1], ldh, &c_b12, &t[t_offset],
+ ldt);
+ dlacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol *
+ h_dim1], ldh);
+/* L80: */
+ }
+ }
+
+/* ==== Update vertical slab in Z ==== */
+
+ if (*wantz) {
+ i__1 = *ihiz;
+ i__2 = *nv;
+ for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *nv, i__4 = *ihiz - krow + 1;
+ kln = min(i__3,i__4);
+ dgemm_("N", "N", &kln, &jw, &jw, &c_b13, &z__[krow + kwtop *
+ z_dim1], ldz, &v[v_offset], ldv, &c_b12, &wv[
+ wv_offset], ldwv);
+ dlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow +
+ kwtop * z_dim1], ldz);
+/* L90: */
+ }
+ }
+ }
+
+/* ==== Return the number of deflations ... ==== */
+
+ *nd = jw - *ns;
+
+/* ==== ... and the number of shifts. (Subtracting */
+/* . INFQR from the spike length takes care */
+/* . of the case of a rare QR failure while */
+/* . calculating eigenvalues of the deflation */
+/* . window.) ==== */
+
+ *ns -= infqr;
+
+/* ==== Return optimal workspace. ==== */
+
+ work[1] = (doublereal) lwkopt;
+
+/* ==== End of DLAQR2 ==== */
+
+ return 0;
+} /* dlaqr2_ */
diff --git a/SRC/dlaqr3.c b/SRC/dlaqr3.c
new file mode 100644
index 0000000..a8bae81
--- /dev/null
+++ b/SRC/dlaqr3.c
@@ -0,0 +1,715 @@
+/* dlaqr3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static logical c_true = TRUE_;
+static doublereal c_b17 = 0.;
+static doublereal c_b18 = 1.;
+static integer c__12 = 12;
+
+/* Subroutine */ int dlaqr3_(logical *wantt, logical *wantz, integer *n,
+ integer *ktop, integer *kbot, integer *nw, doublereal *h__, integer *
+ ldh, integer *iloz, integer *ihiz, doublereal *z__, integer *ldz,
+ integer *ns, integer *nd, doublereal *sr, doublereal *si, doublereal *
+ v, integer *ldv, integer *nh, doublereal *t, integer *ldt, integer *
+ nv, doublereal *wv, integer *ldwv, doublereal *work, integer *lwork)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1,
+ wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal s, aa, bb, cc, dd, cs, sn;
+ integer jw;
+ doublereal evi, evk, foo;
+ integer kln;
+ doublereal tau, ulp;
+ integer lwk1, lwk2, lwk3;
+ doublereal beta;
+ integer kend, kcol, info, nmin, ifst, ilst, ltop, krow;
+ extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *), dgemm_(char *, char *, integer *, integer *
+, integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ logical bulge;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer infqr, kwtop;
+ extern /* Subroutine */ int dlanv2_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *), dlaqr4_(
+ logical *, logical *, integer *, integer *, integer *, doublereal
+ *, integer *, doublereal *, doublereal *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *),
+ dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dgehrd_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dlarfg_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *), dlahqr_(logical *, logical *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *), dlacpy_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *);
+ doublereal safmin;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ doublereal safmax;
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ dtrexc_(char *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *, integer *, doublereal *, integer *),
+ dormhr_(char *, char *, integer *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *);
+ logical sorted;
+ doublereal smlnum;
+ integer lwkopt;
+
+
+/* -- LAPACK auxiliary routine (version 3.2.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* -- April 2009 -- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* ****************************************************************** */
+/* Aggressive early deflation: */
+
+/* This subroutine accepts as input an upper Hessenberg matrix */
+/* H and performs an orthogonal similarity transformation */
+/* designed to detect and deflate fully converged eigenvalues from */
+/* a trailing principal submatrix. On output H has been over- */
+/* written by a new Hessenberg matrix that is a perturbation of */
+/* an orthogonal similarity transformation of H. It is to be */
+/* hoped that the final version of H has many zero subdiagonal */
+/* entries. */
+
+/* ****************************************************************** */
+/* WANTT (input) LOGICAL */
+/* If .TRUE., then the Hessenberg matrix H is fully updated */
+/* so that the quasi-triangular Schur factor may be */
+/* computed (in cooperation with the calling subroutine). */
+/* If .FALSE., then only enough of H is updated to preserve */
+/* the eigenvalues. */
+
+/* WANTZ (input) LOGICAL */
+/* If .TRUE., then the orthogonal matrix Z is updated so */
+/* so that the orthogonal Schur factor may be computed */
+/* (in cooperation with the calling subroutine). */
+/* If .FALSE., then Z is not referenced. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H and (if WANTZ is .TRUE.) the */
+/* order of the orthogonal matrix Z. */
+
+/* KTOP (input) INTEGER */
+/* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */
+/* KBOT and KTOP together determine an isolated block */
+/* along the diagonal of the Hessenberg matrix. */
+
+/* KBOT (input) INTEGER */
+/* It is assumed without a check that either */
+/* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */
+/* determine an isolated block along the diagonal of the */
+/* Hessenberg matrix. */
+
+/* NW (input) INTEGER */
+/* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). */
+
+/* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */
+/* On input the initial N-by-N section of H stores the */
+/* Hessenberg matrix undergoing aggressive early deflation. */
+/* On output H has been transformed by an orthogonal */
+/* similarity transformation, perturbed, and the returned */
+/* to Hessenberg form that (it is to be hoped) has some */
+/* zero subdiagonal entries. */
+
+/* LDH (input) integer */
+/* Leading dimension of H just as declared in the calling */
+/* subroutine. N .LE. LDH */
+
+/* ILOZ (input) INTEGER */
+/* IHIZ (input) INTEGER */
+/* Specify the rows of Z to which transformations must be */
+/* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. */
+
+/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
+/* IF WANTZ is .TRUE., then on output, the orthogonal */
+/* similarity transformation mentioned above has been */
+/* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. */
+/* If WANTZ is .FALSE., then Z is unreferenced. */
+
+/* LDZ (input) integer */
+/* The leading dimension of Z just as declared in the */
+/* calling subroutine. 1 .LE. LDZ. */
+
+/* NS (output) integer */
+/* The number of unconverged (ie approximate) eigenvalues */
+/* returned in SR and SI that may be used as shifts by the */
+/* calling subroutine. */
+
+/* ND (output) integer */
+/* The number of converged eigenvalues uncovered by this */
+/* subroutine. */
+
+/* SR (output) DOUBLE PRECISION array, dimension KBOT */
+/* SI (output) DOUBLE PRECISION array, dimension KBOT */
+/* On output, the real and imaginary parts of approximate */
+/* eigenvalues that may be used for shifts are stored in */
+/* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and */
+/* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. */
+/* The real and imaginary parts of converged eigenvalues */
+/* are stored in SR(KBOT-ND+1) through SR(KBOT) and */
+/* SI(KBOT-ND+1) through SI(KBOT), respectively. */
+
+/* V (workspace) DOUBLE PRECISION array, dimension (LDV,NW) */
+/* An NW-by-NW work array. */
+
+/* LDV (input) integer scalar */
+/* The leading dimension of V just as declared in the */
+/* calling subroutine. NW .LE. LDV */
+
+/* NH (input) integer scalar */
+/* The number of columns of T. NH.GE.NW. */
+
+/* T (workspace) DOUBLE PRECISION array, dimension (LDT,NW) */
+
+/* LDT (input) integer */
+/* The leading dimension of T just as declared in the */
+/* calling subroutine. NW .LE. LDT */
+
+/* NV (input) integer */
+/* The number of rows of work array WV available for */
+/* workspace. NV.GE.NW. */
+
+/* WV (workspace) DOUBLE PRECISION array, dimension (LDWV,NW) */
+
+/* LDWV (input) integer */
+/* The leading dimension of W just as declared in the */
+/* calling subroutine. NW .LE. LDV */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension LWORK. */
+/* On exit, WORK(1) is set to an estimate of the optimal value */
+/* of LWORK for the given values of N, NW, KTOP and KBOT. */
+
+/* LWORK (input) integer */
+/* The dimension of the work array WORK. LWORK = 2*NW */
+/* suffices, but greater efficiency may result from larger */
+/* values of LWORK. */
+
+/* If LWORK = -1, then a workspace query is assumed; DLAQR3 */
+/* only estimates the optimal workspace size for the given */
+/* values of N, NW, KTOP and KBOT. The estimate is returned */
+/* in WORK(1). No error message related to LWORK is issued */
+/* by XERBLA. Neither H nor Z are accessed. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* ==== Estimate optimal workspace. ==== */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --sr;
+ --si;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ wv_dim1 = *ldwv;
+ wv_offset = 1 + wv_dim1;
+ wv -= wv_offset;
+ --work;
+
+ /* Function Body */
+/* Computing MIN */
+ i__1 = *nw, i__2 = *kbot - *ktop + 1;
+ jw = min(i__1,i__2);
+ if (jw <= 2) {
+ lwkopt = 1;
+ } else {
+
+/* ==== Workspace query call to DGEHRD ==== */
+
+ i__1 = jw - 1;
+ dgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], &
+ c_n1, &info);
+ lwk1 = (integer) work[1];
+
+/* ==== Workspace query call to DORMHR ==== */
+
+ i__1 = jw - 1;
+ dormhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1],
+ &v[v_offset], ldv, &work[1], &c_n1, &info);
+ lwk2 = (integer) work[1];
+
+/* ==== Workspace query call to DLAQR4 ==== */
+
+ dlaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[1],
+ &si[1], &c__1, &jw, &v[v_offset], ldv, &work[1], &c_n1, &
+ infqr);
+ lwk3 = (integer) work[1];
+
+/* ==== Optimal workspace ==== */
+
+/* Computing MAX */
+ i__1 = jw + max(lwk1,lwk2);
+ lwkopt = max(i__1,lwk3);
+ }
+
+/* ==== Quick return in case of workspace query. ==== */
+
+ if (*lwork == -1) {
+ work[1] = (doublereal) lwkopt;
+ return 0;
+ }
+
+/* ==== Nothing to do ... */
+/* ... for an empty active block ... ==== */
+ *ns = 0;
+ *nd = 0;
+ work[1] = 1.;
+ if (*ktop > *kbot) {
+ return 0;
+ }
+/* ... nor for an empty deflation window. ==== */
+ if (*nw < 1) {
+ return 0;
+ }
+
+/* ==== Machine constants ==== */
+
+ safmin = dlamch_("SAFE MINIMUM");
+ safmax = 1. / safmin;
+ dlabad_(&safmin, &safmax);
+ ulp = dlamch_("PRECISION");
+ smlnum = safmin * ((doublereal) (*n) / ulp);
+
+/* ==== Setup deflation window ==== */
+
+/* Computing MIN */
+ i__1 = *nw, i__2 = *kbot - *ktop + 1;
+ jw = min(i__1,i__2);
+ kwtop = *kbot - jw + 1;
+ if (kwtop == *ktop) {
+ s = 0.;
+ } else {
+ s = h__[kwtop + (kwtop - 1) * h_dim1];
+ }
+
+ if (*kbot == kwtop) {
+
+/* ==== 1-by-1 deflation window: not much to do ==== */
+
+ sr[kwtop] = h__[kwtop + kwtop * h_dim1];
+ si[kwtop] = 0.;
+ *ns = 1;
+ *nd = 0;
+/* Computing MAX */
+ d__2 = smlnum, d__3 = ulp * (d__1 = h__[kwtop + kwtop * h_dim1], abs(
+ d__1));
+ if (abs(s) <= max(d__2,d__3)) {
+ *ns = 0;
+ *nd = 1;
+ if (kwtop > *ktop) {
+ h__[kwtop + (kwtop - 1) * h_dim1] = 0.;
+ }
+ }
+ work[1] = 1.;
+ return 0;
+ }
+
+/* ==== Convert to spike-triangular form. (In case of a */
+/* . rare QR failure, this routine continues to do */
+/* . aggressive early deflation using that part of */
+/* . the deflation window that converged using INFQR */
+/* . here and there to keep track.) ==== */
+
+ dlacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset],
+ ldt);
+ i__1 = jw - 1;
+ i__2 = *ldh + 1;
+ i__3 = *ldt + 1;
+ dcopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], &
+ i__3);
+
+ dlaset_("A", &jw, &jw, &c_b17, &c_b18, &v[v_offset], ldv);
+ nmin = ilaenv_(&c__12, "DLAQR3", "SV", &jw, &c__1, &jw, lwork);
+ if (jw > nmin) {
+ dlaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[
+ kwtop], &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &work[1],
+ lwork, &infqr);
+ } else {
+ dlahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[
+ kwtop], &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr);
+ }
+
+/* ==== DTREXC needs a clean margin near the diagonal ==== */
+
+ i__1 = jw - 3;
+ for (j = 1; j <= i__1; ++j) {
+ t[j + 2 + j * t_dim1] = 0.;
+ t[j + 3 + j * t_dim1] = 0.;
+/* L10: */
+ }
+ if (jw > 2) {
+ t[jw + (jw - 2) * t_dim1] = 0.;
+ }
+
+/* ==== Deflation detection loop ==== */
+
+ *ns = jw;
+ ilst = infqr + 1;
+L20:
+ if (ilst <= *ns) {
+ if (*ns == 1) {
+ bulge = FALSE_;
+ } else {
+ bulge = t[*ns + (*ns - 1) * t_dim1] != 0.;
+ }
+
+/* ==== Small spike tip test for deflation ==== */
+
+ if (! bulge) {
+
+/* ==== Real eigenvalue ==== */
+
+ foo = (d__1 = t[*ns + *ns * t_dim1], abs(d__1));
+ if (foo == 0.) {
+ foo = abs(s);
+ }
+/* Computing MAX */
+ d__2 = smlnum, d__3 = ulp * foo;
+ if ((d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)) <= max(d__2,d__3))
+ {
+
+/* ==== Deflatable ==== */
+
+ --(*ns);
+ } else {
+
+/* ==== Undeflatable. Move it up out of the way. */
+/* . (DTREXC can not fail in this case.) ==== */
+
+ ifst = *ns;
+ dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
+ &ilst, &work[1], &info);
+ ++ilst;
+ }
+ } else {
+
+/* ==== Complex conjugate pair ==== */
+
+ foo = (d__3 = t[*ns + *ns * t_dim1], abs(d__3)) + sqrt((d__1 = t[*
+ ns + (*ns - 1) * t_dim1], abs(d__1))) * sqrt((d__2 = t[*
+ ns - 1 + *ns * t_dim1], abs(d__2)));
+ if (foo == 0.) {
+ foo = abs(s);
+ }
+/* Computing MAX */
+ d__3 = (d__1 = s * v[*ns * v_dim1 + 1], abs(d__1)), d__4 = (d__2 =
+ s * v[(*ns - 1) * v_dim1 + 1], abs(d__2));
+/* Computing MAX */
+ d__5 = smlnum, d__6 = ulp * foo;
+ if (max(d__3,d__4) <= max(d__5,d__6)) {
+
+/* ==== Deflatable ==== */
+
+ *ns += -2;
+ } else {
+
+/* ==== Undeflatable. Move them up out of the way. */
+/* . Fortunately, DTREXC does the right thing with */
+/* . ILST in case of a rare exchange failure. ==== */
+
+ ifst = *ns;
+ dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
+ &ilst, &work[1], &info);
+ ilst += 2;
+ }
+ }
+
+/* ==== End deflation detection loop ==== */
+
+ goto L20;
+ }
+
+/* ==== Return to Hessenberg form ==== */
+
+ if (*ns == 0) {
+ s = 0.;
+ }
+
+ if (*ns < jw) {
+
+/* ==== sorting diagonal blocks of T improves accuracy for */
+/* . graded matrices. Bubble sort deals well with */
+/* . exchange failures. ==== */
+
+ sorted = FALSE_;
+ i__ = *ns + 1;
+L30:
+ if (sorted) {
+ goto L50;
+ }
+ sorted = TRUE_;
+
+ kend = i__ - 1;
+ i__ = infqr + 1;
+ if (i__ == *ns) {
+ k = i__ + 1;
+ } else if (t[i__ + 1 + i__ * t_dim1] == 0.) {
+ k = i__ + 1;
+ } else {
+ k = i__ + 2;
+ }
+L40:
+ if (k <= kend) {
+ if (k == i__ + 1) {
+ evi = (d__1 = t[i__ + i__ * t_dim1], abs(d__1));
+ } else {
+ evi = (d__3 = t[i__ + i__ * t_dim1], abs(d__3)) + sqrt((d__1 =
+ t[i__ + 1 + i__ * t_dim1], abs(d__1))) * sqrt((d__2 =
+ t[i__ + (i__ + 1) * t_dim1], abs(d__2)));
+ }
+
+ if (k == kend) {
+ evk = (d__1 = t[k + k * t_dim1], abs(d__1));
+ } else if (t[k + 1 + k * t_dim1] == 0.) {
+ evk = (d__1 = t[k + k * t_dim1], abs(d__1));
+ } else {
+ evk = (d__3 = t[k + k * t_dim1], abs(d__3)) + sqrt((d__1 = t[
+ k + 1 + k * t_dim1], abs(d__1))) * sqrt((d__2 = t[k +
+ (k + 1) * t_dim1], abs(d__2)));
+ }
+
+ if (evi >= evk) {
+ i__ = k;
+ } else {
+ sorted = FALSE_;
+ ifst = i__;
+ ilst = k;
+ dtrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
+ &ilst, &work[1], &info);
+ if (info == 0) {
+ i__ = ilst;
+ } else {
+ i__ = k;
+ }
+ }
+ if (i__ == kend) {
+ k = i__ + 1;
+ } else if (t[i__ + 1 + i__ * t_dim1] == 0.) {
+ k = i__ + 1;
+ } else {
+ k = i__ + 2;
+ }
+ goto L40;
+ }
+ goto L30;
+L50:
+ ;
+ }
+
+/* ==== Restore shift/eigenvalue array from T ==== */
+
+ i__ = jw;
+L60:
+ if (i__ >= infqr + 1) {
+ if (i__ == infqr + 1) {
+ sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
+ si[kwtop + i__ - 1] = 0.;
+ --i__;
+ } else if (t[i__ + (i__ - 1) * t_dim1] == 0.) {
+ sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
+ si[kwtop + i__ - 1] = 0.;
+ --i__;
+ } else {
+ aa = t[i__ - 1 + (i__ - 1) * t_dim1];
+ cc = t[i__ + (i__ - 1) * t_dim1];
+ bb = t[i__ - 1 + i__ * t_dim1];
+ dd = t[i__ + i__ * t_dim1];
+ dlanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__
+ - 2], &sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, &
+ sn);
+ i__ += -2;
+ }
+ goto L60;
+ }
+
+ if (*ns < jw || s == 0.) {
+ if (*ns > 1 && s != 0.) {
+
+/* ==== Reflect spike back into lower triangle ==== */
+
+ dcopy_(ns, &v[v_offset], ldv, &work[1], &c__1);
+ beta = work[1];
+ dlarfg_(ns, &beta, &work[2], &c__1, &tau);
+ work[1] = 1.;
+
+ i__1 = jw - 2;
+ i__2 = jw - 2;
+ dlaset_("L", &i__1, &i__2, &c_b17, &c_b17, &t[t_dim1 + 3], ldt);
+
+ dlarf_("L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, &
+ work[jw + 1]);
+ dlarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, &
+ work[jw + 1]);
+ dlarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, &
+ work[jw + 1]);
+
+ i__1 = *lwork - jw;
+ dgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1]
+, &i__1, &info);
+ }
+
+/* ==== Copy updated reduced window into place ==== */
+
+ if (kwtop > 1) {
+ h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1];
+ }
+ dlacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1]
+, ldh);
+ i__1 = jw - 1;
+ i__2 = *ldt + 1;
+ i__3 = *ldh + 1;
+ dcopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1],
+ &i__3);
+
+/* ==== Accumulate orthogonal matrix in order update */
+/* . H and Z, if requested. ==== */
+
+ if (*ns > 1 && s != 0.) {
+ i__1 = *lwork - jw;
+ dormhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1],
+ &v[v_offset], ldv, &work[jw + 1], &i__1, &info);
+ }
+
+/* ==== Update vertical slab in H ==== */
+
+ if (*wantt) {
+ ltop = 1;
+ } else {
+ ltop = *ktop;
+ }
+ i__1 = kwtop - 1;
+ i__2 = *nv;
+ for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *nv, i__4 = kwtop - krow;
+ kln = min(i__3,i__4);
+ dgemm_("N", "N", &kln, &jw, &jw, &c_b18, &h__[krow + kwtop *
+ h_dim1], ldh, &v[v_offset], ldv, &c_b17, &wv[wv_offset],
+ ldwv);
+ dlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop *
+ h_dim1], ldh);
+/* L70: */
+ }
+
+/* ==== Update horizontal slab in H ==== */
+
+ if (*wantt) {
+ i__2 = *n;
+ i__1 = *nh;
+ for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2;
+ kcol += i__1) {
+/* Computing MIN */
+ i__3 = *nh, i__4 = *n - kcol + 1;
+ kln = min(i__3,i__4);
+ dgemm_("C", "N", &jw, &kln, &jw, &c_b18, &v[v_offset], ldv, &
+ h__[kwtop + kcol * h_dim1], ldh, &c_b17, &t[t_offset],
+ ldt);
+ dlacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol *
+ h_dim1], ldh);
+/* L80: */
+ }
+ }
+
+/* ==== Update vertical slab in Z ==== */
+
+ if (*wantz) {
+ i__1 = *ihiz;
+ i__2 = *nv;
+ for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *nv, i__4 = *ihiz - krow + 1;
+ kln = min(i__3,i__4);
+ dgemm_("N", "N", &kln, &jw, &jw, &c_b18, &z__[krow + kwtop *
+ z_dim1], ldz, &v[v_offset], ldv, &c_b17, &wv[
+ wv_offset], ldwv);
+ dlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow +
+ kwtop * z_dim1], ldz);
+/* L90: */
+ }
+ }
+ }
+
+/* ==== Return the number of deflations ... ==== */
+
+ *nd = jw - *ns;
+
+/* ==== ... and the number of shifts. (Subtracting */
+/* . INFQR from the spike length takes care */
+/* . of the case of a rare QR failure while */
+/* . calculating eigenvalues of the deflation */
+/* . window.) ==== */
+
+ *ns -= infqr;
+
+/* ==== Return optimal workspace. ==== */
+
+ work[1] = (doublereal) lwkopt;
+
+/* ==== End of DLAQR3 ==== */
+
+ return 0;
+} /* dlaqr3_ */
diff --git a/SRC/dlaqr4.c b/SRC/dlaqr4.c
new file mode 100644
index 0000000..737d0ad
--- /dev/null
+++ b/SRC/dlaqr4.c
@@ -0,0 +1,754 @@
+/* dlaqr4.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__13 = 13;
+static integer c__15 = 15;
+static integer c_n1 = -1;
+static integer c__12 = 12;
+static integer c__14 = 14;
+static integer c__16 = 16;
+static logical c_false = FALSE_;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int dlaqr4_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, doublereal *h__, integer *ldh, doublereal
+ *wr, doublereal *wi, integer *iloz, integer *ihiz, doublereal *z__,
+ integer *ldz, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Local variables */
+ integer i__, k;
+ doublereal aa, bb, cc, dd;
+ integer ld;
+ doublereal cs;
+ integer nh, it, ks, kt;
+ doublereal sn;
+ integer ku, kv, ls, ns;
+ doublereal ss;
+ integer nw, inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot,
+ nmin;
+ doublereal swap;
+ integer ktop;
+ doublereal zdum[1] /* was [1][1] */;
+ integer kacc22, itmax, nsmax, nwmax, kwtop;
+ extern /* Subroutine */ int dlaqr2_(logical *, logical *, integer *,
+ integer *, integer *, integer *, doublereal *, integer *, integer
+ *, integer *, doublereal *, integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *), dlanv2_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *), dlaqr5_(
+ logical *, logical *, integer *, integer *, integer *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *, doublereal *, integer *);
+ integer nibble;
+ extern /* Subroutine */ int dlahqr_(logical *, logical *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *), dlacpy_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ char jbcmpz[2];
+ integer nwupbd;
+ logical sorted;
+ integer lwkopt;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* This subroutine implements one level of recursion for DLAQR0. */
+/* It is a complete implementation of the small bulge multi-shift */
+/* QR algorithm. It may be called by DLAQR0 and, for large enough */
+/* deflation window size, it may be called by DLAQR3. This */
+/* subroutine is identical to DLAQR0 except that it calls DLAQR2 */
+/* instead of DLAQR3. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAQR4 computes the eigenvalues of a Hessenberg matrix H */
+/* and, optionally, the matrices T and Z from the Schur decomposition */
+/* H = Z T Z**T, where T is an upper quasi-triangular matrix (the */
+/* Schur form), and Z is the orthogonal matrix of Schur vectors. */
+
+/* Optionally Z may be postmultiplied into an input orthogonal */
+/* matrix Q so that this routine can give the Schur factorization */
+/* of a matrix A which has been reduced to the Hessenberg form H */
+/* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */
+
+/* Arguments */
+/* ========= */
+
+/* WANTT (input) LOGICAL */
+/* = .TRUE. : the full Schur form T is required; */
+/* = .FALSE.: only eigenvalues are required. */
+
+/* WANTZ (input) LOGICAL */
+/* = .TRUE. : the matrix of Schur vectors Z is required; */
+/* = .FALSE.: Schur vectors are not required. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N .GE. 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that H is already upper triangular in rows */
+/* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, */
+/* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a */
+/* previous call to DGEBAL, and then passed to DGEHRD when the */
+/* matrix output by DGEBAL is reduced to Hessenberg form. */
+/* Otherwise, ILO and IHI should be set to 1 and N, */
+/* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */
+/* If N = 0, then ILO = 1 and IHI = 0. */
+
+/* H (input/output) DOUBLE PRECISION array, dimension (LDH,N) */
+/* On entry, the upper Hessenberg matrix H. */
+/* On exit, if INFO = 0 and WANTT is .TRUE., then H contains */
+/* the upper quasi-triangular matrix T from the Schur */
+/* decomposition (the Schur form); 2-by-2 diagonal blocks */
+/* (corresponding to complex conjugate pairs of eigenvalues) */
+/* are returned in standard form, with H(i,i) = H(i+1,i+1) */
+/* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is */
+/* .FALSE., then the contents of H are unspecified on exit. */
+/* (The output value of H when INFO.GT.0 is given under the */
+/* description of INFO below.) */
+
+/* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and */
+/* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH .GE. max(1,N). */
+
+/* WR (output) DOUBLE PRECISION array, dimension (IHI) */
+/* WI (output) DOUBLE PRECISION array, dimension (IHI) */
+/* The real and imaginary parts, respectively, of the computed */
+/* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) */
+/* and WI(ILO:IHI). If two eigenvalues are computed as a */
+/* complex conjugate pair, they are stored in consecutive */
+/* elements of WR and WI, say the i-th and (i+1)th, with */
+/* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then */
+/* the eigenvalues are stored in the same order as on the */
+/* diagonal of the Schur form returned in H, with */
+/* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal */
+/* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and */
+/* WI(i+1) = -WI(i). */
+
+/* ILOZ (input) INTEGER */
+/* IHIZ (input) INTEGER */
+/* Specify the rows of Z to which transformations must be */
+/* applied if WANTZ is .TRUE.. */
+/* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. */
+
+/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI) */
+/* If WANTZ is .FALSE., then Z is not referenced. */
+/* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is */
+/* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the */
+/* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). */
+/* (The output value of Z when INFO.GT.0 is given under */
+/* the description of INFO below.) */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. if WANTZ is .TRUE. */
+/* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK */
+/* On exit, if LWORK = -1, WORK(1) returns an estimate of */
+/* the optimal value for LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK .GE. max(1,N) */
+/* is sufficient, but LWORK typically as large as 6*N may */
+/* be required for optimal performance. A workspace query */
+/* to determine the optimal workspace size is recommended. */
+
+/* If LWORK = -1, then DLAQR4 does a workspace query. */
+/* In this case, DLAQR4 checks the input parameters and */
+/* estimates the optimal workspace size for the given */
+/* values of N, ILO and IHI. The estimate is returned */
+/* in WORK(1). No error message related to LWORK is */
+/* issued by XERBLA. Neither H nor Z are accessed. */
+
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* .GT. 0: if INFO = i, DLAQR4 failed to compute all of */
+/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */
+/* and WI contain those eigenvalues which have been */
+/* successfully computed. (Failures are rare.) */
+
+/* If INFO .GT. 0 and WANT is .FALSE., then on exit, */
+/* the remaining unconverged eigenvalues are the eigen- */
+/* values of the upper Hessenberg matrix rows and */
+/* columns ILO through INFO of the final, output */
+/* value of H. */
+
+/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */
+
+/* (*) (initial value of H)*U = U*(final value of H) */
+
+/* where U is an orthogonal matrix. The final */
+/* value of H is upper Hessenberg and quasi-triangular */
+/* in rows and columns INFO+1 through IHI. */
+
+/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
+
+/* (final value of Z(ILO:IHI,ILOZ:IHIZ) */
+/* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U */
+
+/* where U is the orthogonal matrix in (*) (regard- */
+/* less of the value of WANTT.) */
+
+/* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not */
+/* accessed. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* References: */
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */
+/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */
+/* 929--947, 2002. */
+
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */
+/* of Matrix Analysis, volume 23, pages 948--973, 2002. */
+
+/* ================================================================ */
+/* .. Parameters .. */
+
+/* ==== Matrices of order NTINY or smaller must be processed by */
+/* . DLAHQR because of insufficient subdiagonal scratch space. */
+/* . (This is a hard limit.) ==== */
+
+/* ==== Exceptional deflation windows: try to cure rare */
+/* . slow convergence by varying the size of the */
+/* . deflation window after KEXNW iterations. ==== */
+
+/* ==== Exceptional shifts: try to cure rare slow convergence */
+/* . with ad-hoc exceptional shifts every KEXSH iterations. */
+/* . ==== */
+
+/* ==== The constants WILK1 and WILK2 are used to form the */
+/* . exceptional shifts. ==== */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --wr;
+ --wi;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* ==== Quick return for N = 0: nothing to do. ==== */
+
+ if (*n == 0) {
+ work[1] = 1.;
+ return 0;
+ }
+
+ if (*n <= 11) {
+
+/* ==== Tiny matrices must use DLAHQR. ==== */
+
+ lwkopt = 1;
+ if (*lwork != -1) {
+ dlahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &
+ wi[1], iloz, ihiz, &z__[z_offset], ldz, info);
+ }
+ } else {
+
+/* ==== Use small bulge multi-shift QR with aggressive early */
+/* . deflation on larger-than-tiny matrices. ==== */
+
+/* ==== Hope for the best. ==== */
+
+ *info = 0;
+
+/* ==== Set up job flags for ILAENV. ==== */
+
+ if (*wantt) {
+ *(unsigned char *)jbcmpz = 'S';
+ } else {
+ *(unsigned char *)jbcmpz = 'E';
+ }
+ if (*wantz) {
+ *(unsigned char *)&jbcmpz[1] = 'V';
+ } else {
+ *(unsigned char *)&jbcmpz[1] = 'N';
+ }
+
+/* ==== NWR = recommended deflation window size. At this */
+/* . point, N .GT. NTINY = 11, so there is enough */
+/* . subdiagonal workspace for NWR.GE.2 as required. */
+/* . (In fact, there is enough subdiagonal space for */
+/* . NWR.GE.3.) ==== */
+
+ nwr = ilaenv_(&c__13, "DLAQR4", jbcmpz, n, ilo, ihi, lwork);
+ nwr = max(2,nwr);
+/* Computing MIN */
+ i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = min(i__1,i__2);
+ nwr = min(i__1,nwr);
+
+/* ==== NSR = recommended number of simultaneous shifts. */
+/* . At this point N .GT. NTINY = 11, so there is at */
+/* . enough subdiagonal workspace for NSR to be even */
+/* . and greater than or equal to two as required. ==== */
+
+ nsr = ilaenv_(&c__15, "DLAQR4", jbcmpz, n, ilo, ihi, lwork);
+/* Computing MIN */
+ i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = min(i__1,i__2), i__2 = *ihi -
+ *ilo;
+ nsr = min(i__1,i__2);
+/* Computing MAX */
+ i__1 = 2, i__2 = nsr - nsr % 2;
+ nsr = max(i__1,i__2);
+
+/* ==== Estimate optimal workspace ==== */
+
+/* ==== Workspace query call to DLAQR2 ==== */
+
+ i__1 = nwr + 1;
+ dlaqr2_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz,
+ ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[
+ h_offset], ldh, n, &h__[h_offset], ldh, n, &h__[h_offset],
+ ldh, &work[1], &c_n1);
+
+/* ==== Optimal workspace = MAX(DLAQR5, DLAQR2) ==== */
+
+/* Computing MAX */
+ i__1 = nsr * 3 / 2, i__2 = (integer) work[1];
+ lwkopt = max(i__1,i__2);
+
+/* ==== Quick return in case of workspace query. ==== */
+
+ if (*lwork == -1) {
+ work[1] = (doublereal) lwkopt;
+ return 0;
+ }
+
+/* ==== DLAHQR/DLAQR0 crossover point ==== */
+
+ nmin = ilaenv_(&c__12, "DLAQR4", jbcmpz, n, ilo, ihi, lwork);
+ nmin = max(11,nmin);
+
+/* ==== Nibble crossover point ==== */
+
+ nibble = ilaenv_(&c__14, "DLAQR4", jbcmpz, n, ilo, ihi, lwork);
+ nibble = max(0,nibble);
+
+/* ==== Accumulate reflections during ttswp? Use block */
+/* . 2-by-2 structure during matrix-matrix multiply? ==== */
+
+ kacc22 = ilaenv_(&c__16, "DLAQR4", jbcmpz, n, ilo, ihi, lwork);
+ kacc22 = max(0,kacc22);
+ kacc22 = min(2,kacc22);
+
+/* ==== NWMAX = the largest possible deflation window for */
+/* . which there is sufficient workspace. ==== */
+
+/* Computing MIN */
+ i__1 = (*n - 1) / 3, i__2 = *lwork / 2;
+ nwmax = min(i__1,i__2);
+ nw = nwmax;
+
+/* ==== NSMAX = the Largest number of simultaneous shifts */
+/* . for which there is sufficient workspace. ==== */
+
+/* Computing MIN */
+ i__1 = (*n + 6) / 9, i__2 = (*lwork << 1) / 3;
+ nsmax = min(i__1,i__2);
+ nsmax -= nsmax % 2;
+
+/* ==== NDFL: an iteration count restarted at deflation. ==== */
+
+ ndfl = 1;
+
+/* ==== ITMAX = iteration limit ==== */
+
+/* Computing MAX */
+ i__1 = 10, i__2 = *ihi - *ilo + 1;
+ itmax = max(i__1,i__2) * 30;
+
+/* ==== Last row and column in the active block ==== */
+
+ kbot = *ihi;
+
+/* ==== Main Loop ==== */
+
+ i__1 = itmax;
+ for (it = 1; it <= i__1; ++it) {
+
+/* ==== Done when KBOT falls below ILO ==== */
+
+ if (kbot < *ilo) {
+ goto L90;
+ }
+
+/* ==== Locate active block ==== */
+
+ i__2 = *ilo + 1;
+ for (k = kbot; k >= i__2; --k) {
+ if (h__[k + (k - 1) * h_dim1] == 0.) {
+ goto L20;
+ }
+/* L10: */
+ }
+ k = *ilo;
+L20:
+ ktop = k;
+
+/* ==== Select deflation window size: */
+/* . Typical Case: */
+/* . If possible and advisable, nibble the entire */
+/* . active block. If not, use size MIN(NWR,NWMAX) */
+/* . or MIN(NWR+1,NWMAX) depending upon which has */
+/* . the smaller corresponding subdiagonal entry */
+/* . (a heuristic). */
+/* . */
+/* . Exceptional Case: */
+/* . If there have been no deflations in KEXNW or */
+/* . more iterations, then vary the deflation window */
+/* . size. At first, because, larger windows are, */
+/* . in general, more powerful than smaller ones, */
+/* . rapidly increase the window to the maximum possible. */
+/* . Then, gradually reduce the window size. ==== */
+
+ nh = kbot - ktop + 1;
+ nwupbd = min(nh,nwmax);
+ if (ndfl < 5) {
+ nw = min(nwupbd,nwr);
+ } else {
+/* Computing MIN */
+ i__2 = nwupbd, i__3 = nw << 1;
+ nw = min(i__2,i__3);
+ }
+ if (nw < nwmax) {
+ if (nw >= nh - 1) {
+ nw = nh;
+ } else {
+ kwtop = kbot - nw + 1;
+ if ((d__1 = h__[kwtop + (kwtop - 1) * h_dim1], abs(d__1))
+ > (d__2 = h__[kwtop - 1 + (kwtop - 2) * h_dim1],
+ abs(d__2))) {
+ ++nw;
+ }
+ }
+ }
+ if (ndfl < 5) {
+ ndec = -1;
+ } else if (ndec >= 0 || nw >= nwupbd) {
+ ++ndec;
+ if (nw - ndec < 2) {
+ ndec = 0;
+ }
+ nw -= ndec;
+ }
+
+/* ==== Aggressive early deflation: */
+/* . split workspace under the subdiagonal into */
+/* . - an nw-by-nw work array V in the lower */
+/* . left-hand-corner, */
+/* . - an NW-by-at-least-NW-but-more-is-better */
+/* . (NW-by-NHO) horizontal work array along */
+/* . the bottom edge, */
+/* . - an at-least-NW-but-more-is-better (NHV-by-NW) */
+/* . vertical work array along the left-hand-edge. */
+/* . ==== */
+
+ kv = *n - nw + 1;
+ kt = nw + 1;
+ nho = *n - nw - 1 - kt + 1;
+ kwv = nw + 2;
+ nve = *n - nw - kwv + 1;
+
+/* ==== Aggressive early deflation ==== */
+
+ dlaqr2_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh,
+ iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1],
+ &h__[kv + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1],
+ ldh, &nve, &h__[kwv + h_dim1], ldh, &work[1], lwork);
+
+/* ==== Adjust KBOT accounting for new deflations. ==== */
+
+ kbot -= ld;
+
+/* ==== KS points to the shifts. ==== */
+
+ ks = kbot - ls + 1;
+
+/* ==== Skip an expensive QR sweep if there is a (partly */
+/* . heuristic) reason to expect that many eigenvalues */
+/* . will deflate without it. Here, the QR sweep is */
+/* . skipped if many eigenvalues have just been deflated */
+/* . or if the remaining active block is small. */
+
+ if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > min(
+ nmin,nwmax)) {
+
+/* ==== NS = nominal number of simultaneous shifts. */
+/* . This may be lowered (slightly) if DLAQR2 */
+/* . did not provide that many shifts. ==== */
+
+/* Computing MIN */
+/* Computing MAX */
+ i__4 = 2, i__5 = kbot - ktop;
+ i__2 = min(nsmax,nsr), i__3 = max(i__4,i__5);
+ ns = min(i__2,i__3);
+ ns -= ns % 2;
+
+/* ==== If there have been no deflations */
+/* . in a multiple of KEXSH iterations, */
+/* . then try exceptional shifts. */
+/* . Otherwise use shifts provided by */
+/* . DLAQR2 above or from the eigenvalues */
+/* . of a trailing principal submatrix. ==== */
+
+ if (ndfl % 6 == 0) {
+ ks = kbot - ns + 1;
+/* Computing MAX */
+ i__3 = ks + 1, i__4 = ktop + 2;
+ i__2 = max(i__3,i__4);
+ for (i__ = kbot; i__ >= i__2; i__ += -2) {
+ ss = (d__1 = h__[i__ + (i__ - 1) * h_dim1], abs(d__1))
+ + (d__2 = h__[i__ - 1 + (i__ - 2) * h_dim1],
+ abs(d__2));
+ aa = ss * .75 + h__[i__ + i__ * h_dim1];
+ bb = ss;
+ cc = ss * -.4375;
+ dd = aa;
+ dlanv2_(&aa, &bb, &cc, &dd, &wr[i__ - 1], &wi[i__ - 1]
+, &wr[i__], &wi[i__], &cs, &sn);
+/* L30: */
+ }
+ if (ks == ktop) {
+ wr[ks + 1] = h__[ks + 1 + (ks + 1) * h_dim1];
+ wi[ks + 1] = 0.;
+ wr[ks] = wr[ks + 1];
+ wi[ks] = wi[ks + 1];
+ }
+ } else {
+
+/* ==== Got NS/2 or fewer shifts? Use DLAHQR */
+/* . on a trailing principal submatrix to */
+/* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, */
+/* . there is enough space below the subdiagonal */
+/* . to fit an NS-by-NS scratch array.) ==== */
+
+ if (kbot - ks + 1 <= ns / 2) {
+ ks = kbot - ns + 1;
+ kt = *n - ns + 1;
+ dlacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, &
+ h__[kt + h_dim1], ldh);
+ dlahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[kt
+ + h_dim1], ldh, &wr[ks], &wi[ks], &c__1, &
+ c__1, zdum, &c__1, &inf);
+ ks += inf;
+
+/* ==== In case of a rare QR failure use */
+/* . eigenvalues of the trailing 2-by-2 */
+/* . principal submatrix. ==== */
+
+ if (ks >= kbot) {
+ aa = h__[kbot - 1 + (kbot - 1) * h_dim1];
+ cc = h__[kbot + (kbot - 1) * h_dim1];
+ bb = h__[kbot - 1 + kbot * h_dim1];
+ dd = h__[kbot + kbot * h_dim1];
+ dlanv2_(&aa, &bb, &cc, &dd, &wr[kbot - 1], &wi[
+ kbot - 1], &wr[kbot], &wi[kbot], &cs, &sn)
+ ;
+ ks = kbot - 1;
+ }
+ }
+
+ if (kbot - ks + 1 > ns) {
+
+/* ==== Sort the shifts (Helps a little) */
+/* . Bubble sort keeps complex conjugate */
+/* . pairs together. ==== */
+
+ sorted = FALSE_;
+ i__2 = ks + 1;
+ for (k = kbot; k >= i__2; --k) {
+ if (sorted) {
+ goto L60;
+ }
+ sorted = TRUE_;
+ i__3 = k - 1;
+ for (i__ = ks; i__ <= i__3; ++i__) {
+ if ((d__1 = wr[i__], abs(d__1)) + (d__2 = wi[
+ i__], abs(d__2)) < (d__3 = wr[i__ + 1]
+ , abs(d__3)) + (d__4 = wi[i__ + 1],
+ abs(d__4))) {
+ sorted = FALSE_;
+
+ swap = wr[i__];
+ wr[i__] = wr[i__ + 1];
+ wr[i__ + 1] = swap;
+
+ swap = wi[i__];
+ wi[i__] = wi[i__ + 1];
+ wi[i__ + 1] = swap;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+L60:
+ ;
+ }
+
+/* ==== Shuffle shifts into pairs of real shifts */
+/* . and pairs of complex conjugate shifts */
+/* . assuming complex conjugate shifts are */
+/* . already adjacent to one another. (Yes, */
+/* . they are.) ==== */
+
+ i__2 = ks + 2;
+ for (i__ = kbot; i__ >= i__2; i__ += -2) {
+ if (wi[i__] != -wi[i__ - 1]) {
+
+ swap = wr[i__];
+ wr[i__] = wr[i__ - 1];
+ wr[i__ - 1] = wr[i__ - 2];
+ wr[i__ - 2] = swap;
+
+ swap = wi[i__];
+ wi[i__] = wi[i__ - 1];
+ wi[i__ - 1] = wi[i__ - 2];
+ wi[i__ - 2] = swap;
+ }
+/* L70: */
+ }
+ }
+
+/* ==== If there are only two shifts and both are */
+/* . real, then use only one. ==== */
+
+ if (kbot - ks + 1 == 2) {
+ if (wi[kbot] == 0.) {
+ if ((d__1 = wr[kbot] - h__[kbot + kbot * h_dim1], abs(
+ d__1)) < (d__2 = wr[kbot - 1] - h__[kbot +
+ kbot * h_dim1], abs(d__2))) {
+ wr[kbot - 1] = wr[kbot];
+ } else {
+ wr[kbot] = wr[kbot - 1];
+ }
+ }
+ }
+
+/* ==== Use up to NS of the the smallest magnatiude */
+/* . shifts. If there aren't NS shifts available, */
+/* . then use them all, possibly dropping one to */
+/* . make the number of shifts even. ==== */
+
+/* Computing MIN */
+ i__2 = ns, i__3 = kbot - ks + 1;
+ ns = min(i__2,i__3);
+ ns -= ns % 2;
+ ks = kbot - ns + 1;
+
+/* ==== Small-bulge multi-shift QR sweep: */
+/* . split workspace under the subdiagonal into */
+/* . - a KDU-by-KDU work array U in the lower */
+/* . left-hand-corner, */
+/* . - a KDU-by-at-least-KDU-but-more-is-better */
+/* . (KDU-by-NHo) horizontal work array WH along */
+/* . the bottom edge, */
+/* . - and an at-least-KDU-but-more-is-better-by-KDU */
+/* . (NVE-by-KDU) vertical work WV arrow along */
+/* . the left-hand-edge. ==== */
+
+ kdu = ns * 3 - 3;
+ ku = *n - kdu + 1;
+ kwh = kdu + 1;
+ nho = *n - kdu - 3 - (kdu + 1) + 1;
+ kwv = kdu + 4;
+ nve = *n - kdu - kwv + 1;
+
+/* ==== Small-bulge multi-shift QR sweep ==== */
+
+ dlaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &wr[ks],
+ &wi[ks], &h__[h_offset], ldh, iloz, ihiz, &z__[
+ z_offset], ldz, &work[1], &c__3, &h__[ku + h_dim1],
+ ldh, &nve, &h__[kwv + h_dim1], ldh, &nho, &h__[ku +
+ kwh * h_dim1], ldh);
+ }
+
+/* ==== Note progress (or the lack of it). ==== */
+
+ if (ld > 0) {
+ ndfl = 1;
+ } else {
+ ++ndfl;
+ }
+
+/* ==== End of main loop ==== */
+/* L80: */
+ }
+
+/* ==== Iteration limit exceeded. Set INFO to show where */
+/* . the problem occurred and exit. ==== */
+
+ *info = kbot;
+L90:
+ ;
+ }
+
+/* ==== Return the optimal value of LWORK. ==== */
+
+ work[1] = (doublereal) lwkopt;
+
+/* ==== End of DLAQR4 ==== */
+
+ return 0;
+} /* dlaqr4_ */
diff --git a/SRC/dlaqr5.c b/SRC/dlaqr5.c
new file mode 100644
index 0000000..ee5f7a1
--- /dev/null
+++ b/SRC/dlaqr5.c
@@ -0,0 +1,1025 @@
+/* dlaqr5.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b7 = 0.;
+static doublereal c_b8 = 1.;
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int dlaqr5_(logical *wantt, logical *wantz, integer *kacc22,
+ integer *n, integer *ktop, integer *kbot, integer *nshfts, doublereal
+ *sr, doublereal *si, doublereal *h__, integer *ldh, integer *iloz,
+ integer *ihiz, doublereal *z__, integer *ldz, doublereal *v, integer *
+ ldv, doublereal *u, integer *ldu, integer *nv, doublereal *wv,
+ integer *ldwv, integer *nh, doublereal *wh, integer *ldwh)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, u_dim1, u_offset, v_dim1, v_offset, wh_dim1,
+ wh_offset, wv_dim1, wv_offset, z_dim1, z_offset, i__1, i__2, i__3,
+ i__4, i__5, i__6, i__7;
+ doublereal d__1, d__2, d__3, d__4, d__5;
+
+ /* Local variables */
+ integer i__, j, k, m, i2, j2, i4, j4, k1;
+ doublereal h11, h12, h21, h22;
+ integer m22, ns, nu;
+ doublereal vt[3], scl;
+ integer kdu, kms;
+ doublereal ulp;
+ integer knz, kzs;
+ doublereal tst1, tst2, beta;
+ logical blk22, bmp22;
+ integer mend, jcol, jlen, jbot, mbot;
+ doublereal swap;
+ integer jtop, jrow, mtop;
+ doublereal alpha;
+ logical accum;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ integer ndcol, incol, krcol, nbmps;
+ extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), dlaqr1_(
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *), dlabad_(doublereal *,
+ doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *), dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ doublereal safmin;
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ doublereal safmax, refsum;
+ integer mstart;
+ doublereal smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* This auxiliary subroutine called by DLAQR0 performs a */
+/* single small-bulge multi-shift QR sweep. */
+
+/* WANTT (input) logical scalar */
+/* WANTT = .true. if the quasi-triangular Schur factor */
+/* is being computed. WANTT is set to .false. otherwise. */
+
+/* WANTZ (input) logical scalar */
+/* WANTZ = .true. if the orthogonal Schur factor is being */
+/* computed. WANTZ is set to .false. otherwise. */
+
+/* KACC22 (input) integer with value 0, 1, or 2. */
+/* Specifies the computation mode of far-from-diagonal */
+/* orthogonal updates. */
+/* = 0: DLAQR5 does not accumulate reflections and does not */
+/* use matrix-matrix multiply to update far-from-diagonal */
+/* matrix entries. */
+/* = 1: DLAQR5 accumulates reflections and uses matrix-matrix */
+/* multiply to update the far-from-diagonal matrix entries. */
+/* = 2: DLAQR5 accumulates reflections, uses matrix-matrix */
+/* multiply to update the far-from-diagonal matrix entries, */
+/* and takes advantage of 2-by-2 block structure during */
+/* matrix multiplies. */
+
+/* N (input) integer scalar */
+/* N is the order of the Hessenberg matrix H upon which this */
+/* subroutine operates. */
+
+/* KTOP (input) integer scalar */
+/* KBOT (input) integer scalar */
+/* These are the first and last rows and columns of an */
+/* isolated diagonal block upon which the QR sweep is to be */
+/* applied. It is assumed without a check that */
+/* either KTOP = 1 or H(KTOP,KTOP-1) = 0 */
+/* and */
+/* either KBOT = N or H(KBOT+1,KBOT) = 0. */
+
+/* NSHFTS (input) integer scalar */
+/* NSHFTS gives the number of simultaneous shifts. NSHFTS */
+/* must be positive and even. */
+
+/* SR (input/output) DOUBLE PRECISION array of size (NSHFTS) */
+/* SI (input/output) DOUBLE PRECISION array of size (NSHFTS) */
+/* SR contains the real parts and SI contains the imaginary */
+/* parts of the NSHFTS shifts of origin that define the */
+/* multi-shift QR sweep. On output SR and SI may be */
+/* reordered. */
+
+/* H (input/output) DOUBLE PRECISION array of size (LDH,N) */
+/* On input H contains a Hessenberg matrix. On output a */
+/* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied */
+/* to the isolated diagonal block in rows and columns KTOP */
+/* through KBOT. */
+
+/* LDH (input) integer scalar */
+/* LDH is the leading dimension of H just as declared in the */
+/* calling procedure. LDH.GE.MAX(1,N). */
+
+/* ILOZ (input) INTEGER */
+/* IHIZ (input) INTEGER */
+/* Specify the rows of Z to which transformations must be */
+/* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N */
+
+/* Z (input/output) DOUBLE PRECISION array of size (LDZ,IHI) */
+/* If WANTZ = .TRUE., then the QR Sweep orthogonal */
+/* similarity transformation is accumulated into */
+/* Z(ILOZ:IHIZ,ILO:IHI) from the right. */
+/* If WANTZ = .FALSE., then Z is unreferenced. */
+
+/* LDZ (input) integer scalar */
+/* LDA is the leading dimension of Z just as declared in */
+/* the calling procedure. LDZ.GE.N. */
+
+/* V (workspace) DOUBLE PRECISION array of size (LDV,NSHFTS/2) */
+
+/* LDV (input) integer scalar */
+/* LDV is the leading dimension of V as declared in the */
+/* calling procedure. LDV.GE.3. */
+
+/* U (workspace) DOUBLE PRECISION array of size */
+/* (LDU,3*NSHFTS-3) */
+
+/* LDU (input) integer scalar */
+/* LDU is the leading dimension of U just as declared in the */
+/* in the calling subroutine. LDU.GE.3*NSHFTS-3. */
+
+/* NH (input) integer scalar */
+/* NH is the number of columns in array WH available for */
+/* workspace. NH.GE.1. */
+
+/* WH (workspace) DOUBLE PRECISION array of size (LDWH,NH) */
+
+/* LDWH (input) integer scalar */
+/* Leading dimension of WH just as declared in the */
+/* calling procedure. LDWH.GE.3*NSHFTS-3. */
+
+/* NV (input) integer scalar */
+/* NV is the number of rows in WV agailable for workspace. */
+/* NV.GE.1. */
+
+/* WV (workspace) DOUBLE PRECISION array of size */
+/* (LDWV,3*NSHFTS-3) */
+
+/* LDWV (input) integer scalar */
+/* LDWV is the leading dimension of WV as declared in the */
+/* in the calling subroutine. LDWV.GE.NV. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* Reference: */
+
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part I: Maintaining Well Focused Shifts, and */
+/* Level 3 Performance, SIAM Journal of Matrix Analysis, */
+/* volume 23, pages 929--947, 2002. */
+
+/* ================================================================ */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* ==== If there are no shifts, then there is nothing to do. ==== */
+
+ /* Parameter adjustments */
+ --sr;
+ --si;
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ wv_dim1 = *ldwv;
+ wv_offset = 1 + wv_dim1;
+ wv -= wv_offset;
+ wh_dim1 = *ldwh;
+ wh_offset = 1 + wh_dim1;
+ wh -= wh_offset;
+
+ /* Function Body */
+ if (*nshfts < 2) {
+ return 0;
+ }
+
+/* ==== If the active block is empty or 1-by-1, then there */
+/* . is nothing to do. ==== */
+
+ if (*ktop >= *kbot) {
+ return 0;
+ }
+
+/* ==== Shuffle shifts into pairs of real shifts and pairs */
+/* . of complex conjugate shifts assuming complex */
+/* . conjugate shifts are already adjacent to one */
+/* . another. ==== */
+
+ i__1 = *nshfts - 2;
+ for (i__ = 1; i__ <= i__1; i__ += 2) {
+ if (si[i__] != -si[i__ + 1]) {
+
+ swap = sr[i__];
+ sr[i__] = sr[i__ + 1];
+ sr[i__ + 1] = sr[i__ + 2];
+ sr[i__ + 2] = swap;
+
+ swap = si[i__];
+ si[i__] = si[i__ + 1];
+ si[i__ + 1] = si[i__ + 2];
+ si[i__ + 2] = swap;
+ }
+/* L10: */
+ }
+
+/* ==== NSHFTS is supposed to be even, but if it is odd, */
+/* . then simply reduce it by one. The shuffle above */
+/* . ensures that the dropped shift is real and that */
+/* . the remaining shifts are paired. ==== */
+
+ ns = *nshfts - *nshfts % 2;
+
+/* ==== Machine constants for deflation ==== */
+
+ safmin = dlamch_("SAFE MINIMUM");
+ safmax = 1. / safmin;
+ dlabad_(&safmin, &safmax);
+ ulp = dlamch_("PRECISION");
+ smlnum = safmin * ((doublereal) (*n) / ulp);
+
+/* ==== Use accumulated reflections to update far-from-diagonal */
+/* . entries ? ==== */
+
+ accum = *kacc22 == 1 || *kacc22 == 2;
+
+/* ==== If so, exploit the 2-by-2 block structure? ==== */
+
+ blk22 = ns > 2 && *kacc22 == 2;
+
+/* ==== clear trash ==== */
+
+ if (*ktop + 2 <= *kbot) {
+ h__[*ktop + 2 + *ktop * h_dim1] = 0.;
+ }
+
+/* ==== NBMPS = number of 2-shift bulges in the chain ==== */
+
+ nbmps = ns / 2;
+
+/* ==== KDU = width of slab ==== */
+
+ kdu = nbmps * 6 - 3;
+
+/* ==== Create and chase chains of NBMPS bulges ==== */
+
+ i__1 = *kbot - 2;
+ i__2 = nbmps * 3 - 2;
+ for (incol = (1 - nbmps) * 3 + *ktop - 1; i__2 < 0 ? incol >= i__1 :
+ incol <= i__1; incol += i__2) {
+ ndcol = incol + kdu;
+ if (accum) {
+ dlaset_("ALL", &kdu, &kdu, &c_b7, &c_b8, &u[u_offset], ldu);
+ }
+
+/* ==== Near-the-diagonal bulge chase. The following loop */
+/* . performs the near-the-diagonal part of a small bulge */
+/* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal */
+/* . chunk extends from column INCOL to column NDCOL */
+/* . (including both column INCOL and column NDCOL). The */
+/* . following loop chases a 3*NBMPS column long chain of */
+/* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL */
+/* . may be less than KTOP and and NDCOL may be greater than */
+/* . KBOT indicating phantom columns from which to chase */
+/* . bulges before they are actually introduced or to which */
+/* . to chase bulges beyond column KBOT.) ==== */
+
+/* Computing MIN */
+ i__4 = incol + nbmps * 3 - 3, i__5 = *kbot - 2;
+ i__3 = min(i__4,i__5);
+ for (krcol = incol; krcol <= i__3; ++krcol) {
+
+/* ==== Bulges number MTOP to MBOT are active double implicit */
+/* . shift bulges. There may or may not also be small */
+/* . 2-by-2 bulge, if there is room. The inactive bulges */
+/* . (if any) must wait until the active bulges have moved */
+/* . down the diagonal to make room. The phantom matrix */
+/* . paradigm described above helps keep track. ==== */
+
+/* Computing MAX */
+ i__4 = 1, i__5 = (*ktop - 1 - krcol + 2) / 3 + 1;
+ mtop = max(i__4,i__5);
+/* Computing MIN */
+ i__4 = nbmps, i__5 = (*kbot - krcol) / 3;
+ mbot = min(i__4,i__5);
+ m22 = mbot + 1;
+ bmp22 = mbot < nbmps && krcol + (m22 - 1) * 3 == *kbot - 2;
+
+/* ==== Generate reflections to chase the chain right */
+/* . one column. (The minimum value of K is KTOP-1.) ==== */
+
+ i__4 = mbot;
+ for (m = mtop; m <= i__4; ++m) {
+ k = krcol + (m - 1) * 3;
+ if (k == *ktop - 1) {
+ dlaqr1_(&c__3, &h__[*ktop + *ktop * h_dim1], ldh, &sr[(m
+ << 1) - 1], &si[(m << 1) - 1], &sr[m * 2], &si[m *
+ 2], &v[m * v_dim1 + 1]);
+ alpha = v[m * v_dim1 + 1];
+ dlarfg_(&c__3, &alpha, &v[m * v_dim1 + 2], &c__1, &v[m *
+ v_dim1 + 1]);
+ } else {
+ beta = h__[k + 1 + k * h_dim1];
+ v[m * v_dim1 + 2] = h__[k + 2 + k * h_dim1];
+ v[m * v_dim1 + 3] = h__[k + 3 + k * h_dim1];
+ dlarfg_(&c__3, &beta, &v[m * v_dim1 + 2], &c__1, &v[m *
+ v_dim1 + 1]);
+
+/* ==== A Bulge may collapse because of vigilant */
+/* . deflation or destructive underflow. In the */
+/* . underflow case, try the two-small-subdiagonals */
+/* . trick to try to reinflate the bulge. ==== */
+
+ if (h__[k + 3 + k * h_dim1] != 0. || h__[k + 3 + (k + 1) *
+ h_dim1] != 0. || h__[k + 3 + (k + 2) * h_dim1] ==
+ 0.) {
+
+/* ==== Typical case: not collapsed (yet). ==== */
+
+ h__[k + 1 + k * h_dim1] = beta;
+ h__[k + 2 + k * h_dim1] = 0.;
+ h__[k + 3 + k * h_dim1] = 0.;
+ } else {
+
+/* ==== Atypical case: collapsed. Attempt to */
+/* . reintroduce ignoring H(K+1,K) and H(K+2,K). */
+/* . If the fill resulting from the new */
+/* . reflector is too large, then abandon it. */
+/* . Otherwise, use the new one. ==== */
+
+ dlaqr1_(&c__3, &h__[k + 1 + (k + 1) * h_dim1], ldh, &
+ sr[(m << 1) - 1], &si[(m << 1) - 1], &sr[m *
+ 2], &si[m * 2], vt);
+ alpha = vt[0];
+ dlarfg_(&c__3, &alpha, &vt[1], &c__1, vt);
+ refsum = vt[0] * (h__[k + 1 + k * h_dim1] + vt[1] *
+ h__[k + 2 + k * h_dim1]);
+
+ if ((d__1 = h__[k + 2 + k * h_dim1] - refsum * vt[1],
+ abs(d__1)) + (d__2 = refsum * vt[2], abs(d__2)
+ ) > ulp * ((d__3 = h__[k + k * h_dim1], abs(
+ d__3)) + (d__4 = h__[k + 1 + (k + 1) * h_dim1]
+ , abs(d__4)) + (d__5 = h__[k + 2 + (k + 2) *
+ h_dim1], abs(d__5)))) {
+
+/* ==== Starting a new bulge here would */
+/* . create non-negligible fill. Use */
+/* . the old one with trepidation. ==== */
+
+ h__[k + 1 + k * h_dim1] = beta;
+ h__[k + 2 + k * h_dim1] = 0.;
+ h__[k + 3 + k * h_dim1] = 0.;
+ } else {
+
+/* ==== Stating a new bulge here would */
+/* . create only negligible fill. */
+/* . Replace the old reflector with */
+/* . the new one. ==== */
+
+ h__[k + 1 + k * h_dim1] -= refsum;
+ h__[k + 2 + k * h_dim1] = 0.;
+ h__[k + 3 + k * h_dim1] = 0.;
+ v[m * v_dim1 + 1] = vt[0];
+ v[m * v_dim1 + 2] = vt[1];
+ v[m * v_dim1 + 3] = vt[2];
+ }
+ }
+ }
+/* L20: */
+ }
+
+/* ==== Generate a 2-by-2 reflection, if needed. ==== */
+
+ k = krcol + (m22 - 1) * 3;
+ if (bmp22) {
+ if (k == *ktop - 1) {
+ dlaqr1_(&c__2, &h__[k + 1 + (k + 1) * h_dim1], ldh, &sr[(
+ m22 << 1) - 1], &si[(m22 << 1) - 1], &sr[m22 * 2],
+ &si[m22 * 2], &v[m22 * v_dim1 + 1]);
+ beta = v[m22 * v_dim1 + 1];
+ dlarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22
+ * v_dim1 + 1]);
+ } else {
+ beta = h__[k + 1 + k * h_dim1];
+ v[m22 * v_dim1 + 2] = h__[k + 2 + k * h_dim1];
+ dlarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22
+ * v_dim1 + 1]);
+ h__[k + 1 + k * h_dim1] = beta;
+ h__[k + 2 + k * h_dim1] = 0.;
+ }
+ }
+
+/* ==== Multiply H by reflections from the left ==== */
+
+ if (accum) {
+ jbot = min(ndcol,*kbot);
+ } else if (*wantt) {
+ jbot = *n;
+ } else {
+ jbot = *kbot;
+ }
+ i__4 = jbot;
+ for (j = max(*ktop,krcol); j <= i__4; ++j) {
+/* Computing MIN */
+ i__5 = mbot, i__6 = (j - krcol + 2) / 3;
+ mend = min(i__5,i__6);
+ i__5 = mend;
+ for (m = mtop; m <= i__5; ++m) {
+ k = krcol + (m - 1) * 3;
+ refsum = v[m * v_dim1 + 1] * (h__[k + 1 + j * h_dim1] + v[
+ m * v_dim1 + 2] * h__[k + 2 + j * h_dim1] + v[m *
+ v_dim1 + 3] * h__[k + 3 + j * h_dim1]);
+ h__[k + 1 + j * h_dim1] -= refsum;
+ h__[k + 2 + j * h_dim1] -= refsum * v[m * v_dim1 + 2];
+ h__[k + 3 + j * h_dim1] -= refsum * v[m * v_dim1 + 3];
+/* L30: */
+ }
+/* L40: */
+ }
+ if (bmp22) {
+ k = krcol + (m22 - 1) * 3;
+/* Computing MAX */
+ i__4 = k + 1;
+ i__5 = jbot;
+ for (j = max(i__4,*ktop); j <= i__5; ++j) {
+ refsum = v[m22 * v_dim1 + 1] * (h__[k + 1 + j * h_dim1] +
+ v[m22 * v_dim1 + 2] * h__[k + 2 + j * h_dim1]);
+ h__[k + 1 + j * h_dim1] -= refsum;
+ h__[k + 2 + j * h_dim1] -= refsum * v[m22 * v_dim1 + 2];
+/* L50: */
+ }
+ }
+
+/* ==== Multiply H by reflections from the right. */
+/* . Delay filling in the last row until the */
+/* . vigilant deflation check is complete. ==== */
+
+ if (accum) {
+ jtop = max(*ktop,incol);
+ } else if (*wantt) {
+ jtop = 1;
+ } else {
+ jtop = *ktop;
+ }
+ i__5 = mbot;
+ for (m = mtop; m <= i__5; ++m) {
+ if (v[m * v_dim1 + 1] != 0.) {
+ k = krcol + (m - 1) * 3;
+/* Computing MIN */
+ i__6 = *kbot, i__7 = k + 3;
+ i__4 = min(i__6,i__7);
+ for (j = jtop; j <= i__4; ++j) {
+ refsum = v[m * v_dim1 + 1] * (h__[j + (k + 1) *
+ h_dim1] + v[m * v_dim1 + 2] * h__[j + (k + 2)
+ * h_dim1] + v[m * v_dim1 + 3] * h__[j + (k +
+ 3) * h_dim1]);
+ h__[j + (k + 1) * h_dim1] -= refsum;
+ h__[j + (k + 2) * h_dim1] -= refsum * v[m * v_dim1 +
+ 2];
+ h__[j + (k + 3) * h_dim1] -= refsum * v[m * v_dim1 +
+ 3];
+/* L60: */
+ }
+
+ if (accum) {
+
+/* ==== Accumulate U. (If necessary, update Z later */
+/* . with with an efficient matrix-matrix */
+/* . multiply.) ==== */
+
+ kms = k - incol;
+/* Computing MAX */
+ i__4 = 1, i__6 = *ktop - incol;
+ i__7 = kdu;
+ for (j = max(i__4,i__6); j <= i__7; ++j) {
+ refsum = v[m * v_dim1 + 1] * (u[j + (kms + 1) *
+ u_dim1] + v[m * v_dim1 + 2] * u[j + (kms
+ + 2) * u_dim1] + v[m * v_dim1 + 3] * u[j
+ + (kms + 3) * u_dim1]);
+ u[j + (kms + 1) * u_dim1] -= refsum;
+ u[j + (kms + 2) * u_dim1] -= refsum * v[m *
+ v_dim1 + 2];
+ u[j + (kms + 3) * u_dim1] -= refsum * v[m *
+ v_dim1 + 3];
+/* L70: */
+ }
+ } else if (*wantz) {
+
+/* ==== U is not accumulated, so update Z */
+/* . now by multiplying by reflections */
+/* . from the right. ==== */
+
+ i__7 = *ihiz;
+ for (j = *iloz; j <= i__7; ++j) {
+ refsum = v[m * v_dim1 + 1] * (z__[j + (k + 1) *
+ z_dim1] + v[m * v_dim1 + 2] * z__[j + (k
+ + 2) * z_dim1] + v[m * v_dim1 + 3] * z__[
+ j + (k + 3) * z_dim1]);
+ z__[j + (k + 1) * z_dim1] -= refsum;
+ z__[j + (k + 2) * z_dim1] -= refsum * v[m *
+ v_dim1 + 2];
+ z__[j + (k + 3) * z_dim1] -= refsum * v[m *
+ v_dim1 + 3];
+/* L80: */
+ }
+ }
+ }
+/* L90: */
+ }
+
+/* ==== Special case: 2-by-2 reflection (if needed) ==== */
+
+ k = krcol + (m22 - 1) * 3;
+ if (bmp22 && v[m22 * v_dim1 + 1] != 0.) {
+/* Computing MIN */
+ i__7 = *kbot, i__4 = k + 3;
+ i__5 = min(i__7,i__4);
+ for (j = jtop; j <= i__5; ++j) {
+ refsum = v[m22 * v_dim1 + 1] * (h__[j + (k + 1) * h_dim1]
+ + v[m22 * v_dim1 + 2] * h__[j + (k + 2) * h_dim1])
+ ;
+ h__[j + (k + 1) * h_dim1] -= refsum;
+ h__[j + (k + 2) * h_dim1] -= refsum * v[m22 * v_dim1 + 2];
+/* L100: */
+ }
+
+ if (accum) {
+ kms = k - incol;
+/* Computing MAX */
+ i__5 = 1, i__7 = *ktop - incol;
+ i__4 = kdu;
+ for (j = max(i__5,i__7); j <= i__4; ++j) {
+ refsum = v[m22 * v_dim1 + 1] * (u[j + (kms + 1) *
+ u_dim1] + v[m22 * v_dim1 + 2] * u[j + (kms +
+ 2) * u_dim1]);
+ u[j + (kms + 1) * u_dim1] -= refsum;
+ u[j + (kms + 2) * u_dim1] -= refsum * v[m22 * v_dim1
+ + 2];
+/* L110: */
+ }
+ } else if (*wantz) {
+ i__4 = *ihiz;
+ for (j = *iloz; j <= i__4; ++j) {
+ refsum = v[m22 * v_dim1 + 1] * (z__[j + (k + 1) *
+ z_dim1] + v[m22 * v_dim1 + 2] * z__[j + (k +
+ 2) * z_dim1]);
+ z__[j + (k + 1) * z_dim1] -= refsum;
+ z__[j + (k + 2) * z_dim1] -= refsum * v[m22 * v_dim1
+ + 2];
+/* L120: */
+ }
+ }
+ }
+
+/* ==== Vigilant deflation check ==== */
+
+ mstart = mtop;
+ if (krcol + (mstart - 1) * 3 < *ktop) {
+ ++mstart;
+ }
+ mend = mbot;
+ if (bmp22) {
+ ++mend;
+ }
+ if (krcol == *kbot - 2) {
+ ++mend;
+ }
+ i__4 = mend;
+ for (m = mstart; m <= i__4; ++m) {
+/* Computing MIN */
+ i__5 = *kbot - 1, i__7 = krcol + (m - 1) * 3;
+ k = min(i__5,i__7);
+
+/* ==== The following convergence test requires that */
+/* . the tradition small-compared-to-nearby-diagonals */
+/* . criterion and the Ahues & Tisseur (LAWN 122, 1997) */
+/* . criteria both be satisfied. The latter improves */
+/* . accuracy in some examples. Falling back on an */
+/* . alternate convergence criterion when TST1 or TST2 */
+/* . is zero (as done here) is traditional but probably */
+/* . unnecessary. ==== */
+
+ if (h__[k + 1 + k * h_dim1] != 0.) {
+ tst1 = (d__1 = h__[k + k * h_dim1], abs(d__1)) + (d__2 =
+ h__[k + 1 + (k + 1) * h_dim1], abs(d__2));
+ if (tst1 == 0.) {
+ if (k >= *ktop + 1) {
+ tst1 += (d__1 = h__[k + (k - 1) * h_dim1], abs(
+ d__1));
+ }
+ if (k >= *ktop + 2) {
+ tst1 += (d__1 = h__[k + (k - 2) * h_dim1], abs(
+ d__1));
+ }
+ if (k >= *ktop + 3) {
+ tst1 += (d__1 = h__[k + (k - 3) * h_dim1], abs(
+ d__1));
+ }
+ if (k <= *kbot - 2) {
+ tst1 += (d__1 = h__[k + 2 + (k + 1) * h_dim1],
+ abs(d__1));
+ }
+ if (k <= *kbot - 3) {
+ tst1 += (d__1 = h__[k + 3 + (k + 1) * h_dim1],
+ abs(d__1));
+ }
+ if (k <= *kbot - 4) {
+ tst1 += (d__1 = h__[k + 4 + (k + 1) * h_dim1],
+ abs(d__1));
+ }
+ }
+/* Computing MAX */
+ d__2 = smlnum, d__3 = ulp * tst1;
+ if ((d__1 = h__[k + 1 + k * h_dim1], abs(d__1)) <= max(
+ d__2,d__3)) {
+/* Computing MAX */
+ d__3 = (d__1 = h__[k + 1 + k * h_dim1], abs(d__1)),
+ d__4 = (d__2 = h__[k + (k + 1) * h_dim1], abs(
+ d__2));
+ h12 = max(d__3,d__4);
+/* Computing MIN */
+ d__3 = (d__1 = h__[k + 1 + k * h_dim1], abs(d__1)),
+ d__4 = (d__2 = h__[k + (k + 1) * h_dim1], abs(
+ d__2));
+ h21 = min(d__3,d__4);
+/* Computing MAX */
+ d__3 = (d__1 = h__[k + 1 + (k + 1) * h_dim1], abs(
+ d__1)), d__4 = (d__2 = h__[k + k * h_dim1] -
+ h__[k + 1 + (k + 1) * h_dim1], abs(d__2));
+ h11 = max(d__3,d__4);
+/* Computing MIN */
+ d__3 = (d__1 = h__[k + 1 + (k + 1) * h_dim1], abs(
+ d__1)), d__4 = (d__2 = h__[k + k * h_dim1] -
+ h__[k + 1 + (k + 1) * h_dim1], abs(d__2));
+ h22 = min(d__3,d__4);
+ scl = h11 + h12;
+ tst2 = h22 * (h11 / scl);
+
+/* Computing MAX */
+ d__1 = smlnum, d__2 = ulp * tst2;
+ if (tst2 == 0. || h21 * (h12 / scl) <= max(d__1,d__2))
+ {
+ h__[k + 1 + k * h_dim1] = 0.;
+ }
+ }
+ }
+/* L130: */
+ }
+
+/* ==== Fill in the last row of each bulge. ==== */
+
+/* Computing MIN */
+ i__4 = nbmps, i__5 = (*kbot - krcol - 1) / 3;
+ mend = min(i__4,i__5);
+ i__4 = mend;
+ for (m = mtop; m <= i__4; ++m) {
+ k = krcol + (m - 1) * 3;
+ refsum = v[m * v_dim1 + 1] * v[m * v_dim1 + 3] * h__[k + 4 + (
+ k + 3) * h_dim1];
+ h__[k + 4 + (k + 1) * h_dim1] = -refsum;
+ h__[k + 4 + (k + 2) * h_dim1] = -refsum * v[m * v_dim1 + 2];
+ h__[k + 4 + (k + 3) * h_dim1] -= refsum * v[m * v_dim1 + 3];
+/* L140: */
+ }
+
+/* ==== End of near-the-diagonal bulge chase. ==== */
+
+/* L150: */
+ }
+
+/* ==== Use U (if accumulated) to update far-from-diagonal */
+/* . entries in H. If required, use U to update Z as */
+/* . well. ==== */
+
+ if (accum) {
+ if (*wantt) {
+ jtop = 1;
+ jbot = *n;
+ } else {
+ jtop = *ktop;
+ jbot = *kbot;
+ }
+ if (! blk22 || incol < *ktop || ndcol > *kbot || ns <= 2) {
+
+/* ==== Updates not exploiting the 2-by-2 block */
+/* . structure of U. K1 and NU keep track of */
+/* . the location and size of U in the special */
+/* . cases of introducing bulges and chasing */
+/* . bulges off the bottom. In these special */
+/* . cases and in case the number of shifts */
+/* . is NS = 2, there is no 2-by-2 block */
+/* . structure to exploit. ==== */
+
+/* Computing MAX */
+ i__3 = 1, i__4 = *ktop - incol;
+ k1 = max(i__3,i__4);
+/* Computing MAX */
+ i__3 = 0, i__4 = ndcol - *kbot;
+ nu = kdu - max(i__3,i__4) - k1 + 1;
+
+/* ==== Horizontal Multiply ==== */
+
+ i__3 = jbot;
+ i__4 = *nh;
+ for (jcol = min(ndcol,*kbot) + 1; i__4 < 0 ? jcol >= i__3 :
+ jcol <= i__3; jcol += i__4) {
+/* Computing MIN */
+ i__5 = *nh, i__7 = jbot - jcol + 1;
+ jlen = min(i__5,i__7);
+ dgemm_("C", "N", &nu, &jlen, &nu, &c_b8, &u[k1 + k1 *
+ u_dim1], ldu, &h__[incol + k1 + jcol * h_dim1],
+ ldh, &c_b7, &wh[wh_offset], ldwh);
+ dlacpy_("ALL", &nu, &jlen, &wh[wh_offset], ldwh, &h__[
+ incol + k1 + jcol * h_dim1], ldh);
+/* L160: */
+ }
+
+/* ==== Vertical multiply ==== */
+
+ i__4 = max(*ktop,incol) - 1;
+ i__3 = *nv;
+ for (jrow = jtop; i__3 < 0 ? jrow >= i__4 : jrow <= i__4;
+ jrow += i__3) {
+/* Computing MIN */
+ i__5 = *nv, i__7 = max(*ktop,incol) - jrow;
+ jlen = min(i__5,i__7);
+ dgemm_("N", "N", &jlen, &nu, &nu, &c_b8, &h__[jrow + (
+ incol + k1) * h_dim1], ldh, &u[k1 + k1 * u_dim1],
+ ldu, &c_b7, &wv[wv_offset], ldwv);
+ dlacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &h__[
+ jrow + (incol + k1) * h_dim1], ldh);
+/* L170: */
+ }
+
+/* ==== Z multiply (also vertical) ==== */
+
+ if (*wantz) {
+ i__3 = *ihiz;
+ i__4 = *nv;
+ for (jrow = *iloz; i__4 < 0 ? jrow >= i__3 : jrow <= i__3;
+ jrow += i__4) {
+/* Computing MIN */
+ i__5 = *nv, i__7 = *ihiz - jrow + 1;
+ jlen = min(i__5,i__7);
+ dgemm_("N", "N", &jlen, &nu, &nu, &c_b8, &z__[jrow + (
+ incol + k1) * z_dim1], ldz, &u[k1 + k1 *
+ u_dim1], ldu, &c_b7, &wv[wv_offset], ldwv);
+ dlacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &z__[
+ jrow + (incol + k1) * z_dim1], ldz)
+ ;
+/* L180: */
+ }
+ }
+ } else {
+
+/* ==== Updates exploiting U's 2-by-2 block structure. */
+/* . (I2, I4, J2, J4 are the last rows and columns */
+/* . of the blocks.) ==== */
+
+ i2 = (kdu + 1) / 2;
+ i4 = kdu;
+ j2 = i4 - i2;
+ j4 = kdu;
+
+/* ==== KZS and KNZ deal with the band of zeros */
+/* . along the diagonal of one of the triangular */
+/* . blocks. ==== */
+
+ kzs = j4 - j2 - (ns + 1);
+ knz = ns + 1;
+
+/* ==== Horizontal multiply ==== */
+
+ i__4 = jbot;
+ i__3 = *nh;
+ for (jcol = min(ndcol,*kbot) + 1; i__3 < 0 ? jcol >= i__4 :
+ jcol <= i__4; jcol += i__3) {
+/* Computing MIN */
+ i__5 = *nh, i__7 = jbot - jcol + 1;
+ jlen = min(i__5,i__7);
+
+/* ==== Copy bottom of H to top+KZS of scratch ==== */
+/* (The first KZS rows get multiplied by zero.) ==== */
+
+ dlacpy_("ALL", &knz, &jlen, &h__[incol + 1 + j2 + jcol *
+ h_dim1], ldh, &wh[kzs + 1 + wh_dim1], ldwh);
+
+/* ==== Multiply by U21' ==== */
+
+ dlaset_("ALL", &kzs, &jlen, &c_b7, &c_b7, &wh[wh_offset],
+ ldwh);
+ dtrmm_("L", "U", "C", "N", &knz, &jlen, &c_b8, &u[j2 + 1
+ + (kzs + 1) * u_dim1], ldu, &wh[kzs + 1 + wh_dim1]
+, ldwh);
+
+/* ==== Multiply top of H by U11' ==== */
+
+ dgemm_("C", "N", &i2, &jlen, &j2, &c_b8, &u[u_offset],
+ ldu, &h__[incol + 1 + jcol * h_dim1], ldh, &c_b8,
+ &wh[wh_offset], ldwh);
+
+/* ==== Copy top of H to bottom of WH ==== */
+
+ dlacpy_("ALL", &j2, &jlen, &h__[incol + 1 + jcol * h_dim1]
+, ldh, &wh[i2 + 1 + wh_dim1], ldwh);
+
+/* ==== Multiply by U21' ==== */
+
+ dtrmm_("L", "L", "C", "N", &j2, &jlen, &c_b8, &u[(i2 + 1)
+ * u_dim1 + 1], ldu, &wh[i2 + 1 + wh_dim1], ldwh);
+
+/* ==== Multiply by U22 ==== */
+
+ i__5 = i4 - i2;
+ i__7 = j4 - j2;
+ dgemm_("C", "N", &i__5, &jlen, &i__7, &c_b8, &u[j2 + 1 + (
+ i2 + 1) * u_dim1], ldu, &h__[incol + 1 + j2 +
+ jcol * h_dim1], ldh, &c_b8, &wh[i2 + 1 + wh_dim1],
+ ldwh);
+
+/* ==== Copy it back ==== */
+
+ dlacpy_("ALL", &kdu, &jlen, &wh[wh_offset], ldwh, &h__[
+ incol + 1 + jcol * h_dim1], ldh);
+/* L190: */
+ }
+
+/* ==== Vertical multiply ==== */
+
+ i__3 = max(incol,*ktop) - 1;
+ i__4 = *nv;
+ for (jrow = jtop; i__4 < 0 ? jrow >= i__3 : jrow <= i__3;
+ jrow += i__4) {
+/* Computing MIN */
+ i__5 = *nv, i__7 = max(incol,*ktop) - jrow;
+ jlen = min(i__5,i__7);
+
+/* ==== Copy right of H to scratch (the first KZS */
+/* . columns get multiplied by zero) ==== */
+
+ dlacpy_("ALL", &jlen, &knz, &h__[jrow + (incol + 1 + j2) *
+ h_dim1], ldh, &wv[(kzs + 1) * wv_dim1 + 1], ldwv);
+
+/* ==== Multiply by U21 ==== */
+
+ dlaset_("ALL", &jlen, &kzs, &c_b7, &c_b7, &wv[wv_offset],
+ ldwv);
+ dtrmm_("R", "U", "N", "N", &jlen, &knz, &c_b8, &u[j2 + 1
+ + (kzs + 1) * u_dim1], ldu, &wv[(kzs + 1) *
+ wv_dim1 + 1], ldwv);
+
+/* ==== Multiply by U11 ==== */
+
+ dgemm_("N", "N", &jlen, &i2, &j2, &c_b8, &h__[jrow + (
+ incol + 1) * h_dim1], ldh, &u[u_offset], ldu, &
+ c_b8, &wv[wv_offset], ldwv);
+
+/* ==== Copy left of H to right of scratch ==== */
+
+ dlacpy_("ALL", &jlen, &j2, &h__[jrow + (incol + 1) *
+ h_dim1], ldh, &wv[(i2 + 1) * wv_dim1 + 1], ldwv);
+
+/* ==== Multiply by U21 ==== */
+
+ i__5 = i4 - i2;
+ dtrmm_("R", "L", "N", "N", &jlen, &i__5, &c_b8, &u[(i2 +
+ 1) * u_dim1 + 1], ldu, &wv[(i2 + 1) * wv_dim1 + 1]
+, ldwv);
+
+/* ==== Multiply by U22 ==== */
+
+ i__5 = i4 - i2;
+ i__7 = j4 - j2;
+ dgemm_("N", "N", &jlen, &i__5, &i__7, &c_b8, &h__[jrow + (
+ incol + 1 + j2) * h_dim1], ldh, &u[j2 + 1 + (i2 +
+ 1) * u_dim1], ldu, &c_b8, &wv[(i2 + 1) * wv_dim1
+ + 1], ldwv);
+
+/* ==== Copy it back ==== */
+
+ dlacpy_("ALL", &jlen, &kdu, &wv[wv_offset], ldwv, &h__[
+ jrow + (incol + 1) * h_dim1], ldh);
+/* L200: */
+ }
+
+/* ==== Multiply Z (also vertical) ==== */
+
+ if (*wantz) {
+ i__4 = *ihiz;
+ i__3 = *nv;
+ for (jrow = *iloz; i__3 < 0 ? jrow >= i__4 : jrow <= i__4;
+ jrow += i__3) {
+/* Computing MIN */
+ i__5 = *nv, i__7 = *ihiz - jrow + 1;
+ jlen = min(i__5,i__7);
+
+/* ==== Copy right of Z to left of scratch (first */
+/* . KZS columns get multiplied by zero) ==== */
+
+ dlacpy_("ALL", &jlen, &knz, &z__[jrow + (incol + 1 +
+ j2) * z_dim1], ldz, &wv[(kzs + 1) * wv_dim1 +
+ 1], ldwv);
+
+/* ==== Multiply by U12 ==== */
+
+ dlaset_("ALL", &jlen, &kzs, &c_b7, &c_b7, &wv[
+ wv_offset], ldwv);
+ dtrmm_("R", "U", "N", "N", &jlen, &knz, &c_b8, &u[j2
+ + 1 + (kzs + 1) * u_dim1], ldu, &wv[(kzs + 1)
+ * wv_dim1 + 1], ldwv);
+
+/* ==== Multiply by U11 ==== */
+
+ dgemm_("N", "N", &jlen, &i2, &j2, &c_b8, &z__[jrow + (
+ incol + 1) * z_dim1], ldz, &u[u_offset], ldu,
+ &c_b8, &wv[wv_offset], ldwv);
+
+/* ==== Copy left of Z to right of scratch ==== */
+
+ dlacpy_("ALL", &jlen, &j2, &z__[jrow + (incol + 1) *
+ z_dim1], ldz, &wv[(i2 + 1) * wv_dim1 + 1],
+ ldwv);
+
+/* ==== Multiply by U21 ==== */
+
+ i__5 = i4 - i2;
+ dtrmm_("R", "L", "N", "N", &jlen, &i__5, &c_b8, &u[(
+ i2 + 1) * u_dim1 + 1], ldu, &wv[(i2 + 1) *
+ wv_dim1 + 1], ldwv);
+
+/* ==== Multiply by U22 ==== */
+
+ i__5 = i4 - i2;
+ i__7 = j4 - j2;
+ dgemm_("N", "N", &jlen, &i__5, &i__7, &c_b8, &z__[
+ jrow + (incol + 1 + j2) * z_dim1], ldz, &u[j2
+ + 1 + (i2 + 1) * u_dim1], ldu, &c_b8, &wv[(i2
+ + 1) * wv_dim1 + 1], ldwv);
+
+/* ==== Copy the result back to Z ==== */
+
+ dlacpy_("ALL", &jlen, &kdu, &wv[wv_offset], ldwv, &
+ z__[jrow + (incol + 1) * z_dim1], ldz);
+/* L210: */
+ }
+ }
+ }
+ }
+/* L220: */
+ }
+
+/* ==== End of DLAQR5 ==== */
+
+ return 0;
+} /* dlaqr5_ */
diff --git a/SRC/dlaqsb.c b/SRC/dlaqsb.c
new file mode 100644
index 0000000..c7f457e
--- /dev/null
+++ b/SRC/dlaqsb.c
@@ -0,0 +1,185 @@
+/* dlaqsb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlaqsb_(char *uplo, integer *n, integer *kd, doublereal *
+ ab, integer *ldab, doublereal *s, doublereal *scond, doublereal *amax,
+ char *equed)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal cj, large;
+ extern logical lsame_(char *, char *);
+ doublereal small;
+ extern doublereal dlamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAQSB equilibrates a symmetric band matrix A using the scaling */
+/* factors in the vector S. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, if INFO = 0, the triangular factor U or L from the */
+/* Cholesky factorization A = U'*U or A = L*L' of the band */
+/* matrix A, in the same storage format as A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* S (input) DOUBLE PRECISION array, dimension (N) */
+/* The scale factors for A. */
+
+/* SCOND (input) DOUBLE PRECISION */
+/* Ratio of the smallest S(i) to the largest S(i). */
+
+/* AMAX (input) DOUBLE PRECISION */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies whether or not equilibration was done. */
+/* = 'N': No equilibration. */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if scaling should be done */
+/* based on the ratio of the scaling factors. If SCOND < THRESH, */
+/* scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if scaling should */
+/* be done based on the absolute size of the largest matrix element. */
+/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --s;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = dlamch_("Safe minimum") / dlamch_("Precision");
+ large = 1. / small;
+
+ if (*scond >= .1 && *amax >= small && *amax <= large) {
+
+/* No equilibration */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Replace A by diag(S) * A * diag(S). */
+
+ if (lsame_(uplo, "U")) {
+
+/* Upper triangle of A is stored in band format. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *kd;
+ i__4 = j;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ ab[*kd + 1 + i__ - j + j * ab_dim1] = cj * s[i__] * ab[*
+ kd + 1 + i__ - j + j * ab_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+
+/* Lower triangle of A is stored. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+/* Computing MIN */
+ i__2 = *n, i__3 = j + *kd;
+ i__4 = min(i__2,i__3);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ ab[i__ + 1 - j + j * ab_dim1] = cj * s[i__] * ab[i__ + 1
+ - j + j * ab_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ *(unsigned char *)equed = 'Y';
+ }
+
+ return 0;
+
+/* End of DLAQSB */
+
+} /* dlaqsb_ */
diff --git a/SRC/dlaqsp.c b/SRC/dlaqsp.c
new file mode 100644
index 0000000..dd22cea
--- /dev/null
+++ b/SRC/dlaqsp.c
@@ -0,0 +1,169 @@
+/* dlaqsp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlaqsp_(char *uplo, integer *n, doublereal *ap,
+ doublereal *s, doublereal *scond, doublereal *amax, char *equed)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, jc;
+ doublereal cj, large;
+ extern logical lsame_(char *, char *);
+ doublereal small;
+ extern doublereal dlamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAQSP equilibrates a symmetric matrix A using the scaling factors */
+/* in the vector S. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the equilibrated matrix: diag(S) * A * diag(S), in */
+/* the same storage format as A. */
+
+/* S (input) DOUBLE PRECISION array, dimension (N) */
+/* The scale factors for A. */
+
+/* SCOND (input) DOUBLE PRECISION */
+/* Ratio of the smallest S(i) to the largest S(i). */
+
+/* AMAX (input) DOUBLE PRECISION */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies whether or not equilibration was done. */
+/* = 'N': No equilibration. */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if scaling should be done */
+/* based on the ratio of the scaling factors. If SCOND < THRESH, */
+/* scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if scaling should */
+/* be done based on the absolute size of the largest matrix element. */
+/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --s;
+ --ap;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = dlamch_("Safe minimum") / dlamch_("Precision");
+ large = 1. / small;
+
+ if (*scond >= .1 && *amax >= small && *amax <= large) {
+
+/* No equilibration */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Replace A by diag(S) * A * diag(S). */
+
+ if (lsame_(uplo, "U")) {
+
+/* Upper triangle of A is stored. */
+
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ap[jc + i__ - 1] = cj * s[i__] * ap[jc + i__ - 1];
+/* L10: */
+ }
+ jc += j;
+/* L20: */
+ }
+ } else {
+
+/* Lower triangle of A is stored. */
+
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ap[jc + i__ - j] = cj * s[i__] * ap[jc + i__ - j];
+/* L30: */
+ }
+ jc = jc + *n - j + 1;
+/* L40: */
+ }
+ }
+ *(unsigned char *)equed = 'Y';
+ }
+
+ return 0;
+
+/* End of DLAQSP */
+
+} /* dlaqsp_ */
diff --git a/SRC/dlaqsy.c b/SRC/dlaqsy.c
new file mode 100644
index 0000000..698f9a3
--- /dev/null
+++ b/SRC/dlaqsy.c
@@ -0,0 +1,172 @@
+/* dlaqsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlaqsy_(char *uplo, integer *n, doublereal *a, integer *
+ lda, doublereal *s, doublereal *scond, doublereal *amax, char *equed)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal cj, large;
+ extern logical lsame_(char *, char *);
+ doublereal small;
+ extern doublereal dlamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAQSY equilibrates a symmetric matrix A using the scaling factors */
+/* in the vector S. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n by n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n by n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if EQUED = 'Y', the equilibrated matrix: */
+/* diag(S) * A * diag(S). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(N,1). */
+
+/* S (input) DOUBLE PRECISION array, dimension (N) */
+/* The scale factors for A. */
+
+/* SCOND (input) DOUBLE PRECISION */
+/* Ratio of the smallest S(i) to the largest S(i). */
+
+/* AMAX (input) DOUBLE PRECISION */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies whether or not equilibration was done. */
+/* = 'N': No equilibration. */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if scaling should be done */
+/* based on the ratio of the scaling factors. If SCOND < THRESH, */
+/* scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if scaling should */
+/* be done based on the absolute size of the largest matrix element. */
+/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = dlamch_("Safe minimum") / dlamch_("Precision");
+ large = 1. / small;
+
+ if (*scond >= .1 && *amax >= small && *amax <= large) {
+
+/* No equilibration */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Replace A by diag(S) * A * diag(S). */
+
+ if (lsame_(uplo, "U")) {
+
+/* Upper triangle of A is stored. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = cj * s[i__] * a[i__ + j * a_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+
+/* Lower triangle of A is stored. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = cj * s[i__] * a[i__ + j * a_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ *(unsigned char *)equed = 'Y';
+ }
+
+ return 0;
+
+/* End of DLAQSY */
+
+} /* dlaqsy_ */
diff --git a/SRC/dlaqtr.c b/SRC/dlaqtr.c
new file mode 100644
index 0000000..e8c7e93
--- /dev/null
+++ b/SRC/dlaqtr.c
@@ -0,0 +1,832 @@
+/* dlaqtr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static logical c_false = FALSE_;
+static integer c__2 = 2;
+static doublereal c_b21 = 1.;
+static doublereal c_b25 = 0.;
+static logical c_true = TRUE_;
+
+/* Subroutine */ int dlaqtr_(logical *ltran, logical *lreal, integer *n,
+ doublereal *t, integer *ldt, doublereal *b, doublereal *w, doublereal
+ *scale, doublereal *x, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer t_dim1, t_offset, i__1, i__2;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6;
+
+ /* Local variables */
+ doublereal d__[4] /* was [2][2] */;
+ integer i__, j, k;
+ doublereal v[4] /* was [2][2] */, z__;
+ integer j1, j2, n1, n2;
+ doublereal si, xj, sr, rec, eps, tjj, tmp;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer ierr;
+ doublereal smin, xmax;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *);
+ integer jnext;
+ doublereal sminw, xnorm;
+ extern /* Subroutine */ int dlaln2_(logical *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *
+, doublereal *, integer *, doublereal *, doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal scaloc;
+ extern /* Subroutine */ int dladiv_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *);
+ doublereal bignum;
+ logical notran;
+ doublereal smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAQTR solves the real quasi-triangular system */
+
+/* op(T)*p = scale*c, if LREAL = .TRUE. */
+
+/* or the complex quasi-triangular systems */
+
+/* op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE. */
+
+/* in real arithmetic, where T is upper quasi-triangular. */
+/* If LREAL = .FALSE., then the first diagonal block of T must be */
+/* 1 by 1, B is the specially structured matrix */
+
+/* B = [ b(1) b(2) ... b(n) ] */
+/* [ w ] */
+/* [ w ] */
+/* [ . ] */
+/* [ w ] */
+
+/* op(A) = A or A', A' denotes the conjugate transpose of */
+/* matrix A. */
+
+/* On input, X = [ c ]. On output, X = [ p ]. */
+/* [ d ] [ q ] */
+
+/* This subroutine is designed for the condition number estimation */
+/* in routine DTRSNA. */
+
+/* Arguments */
+/* ========= */
+
+/* LTRAN (input) LOGICAL */
+/* On entry, LTRAN specifies the option of conjugate transpose: */
+/* = .FALSE., op(T+i*B) = T+i*B, */
+/* = .TRUE., op(T+i*B) = (T+i*B)'. */
+
+/* LREAL (input) LOGICAL */
+/* On entry, LREAL specifies the input matrix structure: */
+/* = .FALSE., the input is complex */
+/* = .TRUE., the input is real */
+
+/* N (input) INTEGER */
+/* On entry, N specifies the order of T+i*B. N >= 0. */
+
+/* T (input) DOUBLE PRECISION array, dimension (LDT,N) */
+/* On entry, T contains a matrix in Schur canonical form. */
+/* If LREAL = .FALSE., then the first diagonal block of T mu */
+/* be 1 by 1. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the matrix T. LDT >= max(1,N). */
+
+/* B (input) DOUBLE PRECISION array, dimension (N) */
+/* On entry, B contains the elements to form the matrix */
+/* B as described above. */
+/* If LREAL = .TRUE., B is not referenced. */
+
+/* W (input) DOUBLE PRECISION */
+/* On entry, W is the diagonal element of the matrix B. */
+/* If LREAL = .TRUE., W is not referenced. */
+
+/* SCALE (output) DOUBLE PRECISION */
+/* On exit, SCALE is the scale factor. */
+
+/* X (input/output) DOUBLE PRECISION array, dimension (2*N) */
+/* On entry, X contains the right hand side of the system. */
+/* On exit, X is overwritten by the solution. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* On exit, INFO is set to */
+/* 0: successful exit. */
+/* 1: the some diagonal 1 by 1 block has been perturbed by */
+/* a small number SMIN to keep nonsingularity. */
+/* 2: the some diagonal 2 by 2 block has been perturbed by */
+/* a small number in DLALN2 to keep nonsingularity. */
+/* NOTE: In the interests of speed, this routine does not */
+/* check the inputs for errors. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Do not test the input parameters for errors */
+
+ /* Parameter adjustments */
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ --b;
+ --x;
+ --work;
+
+ /* Function Body */
+ notran = ! (*ltran);
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Set constants to control overflow */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S") / eps;
+ bignum = 1. / smlnum;
+
+ xnorm = dlange_("M", n, n, &t[t_offset], ldt, d__);
+ if (! (*lreal)) {
+/* Computing MAX */
+ d__1 = xnorm, d__2 = abs(*w), d__1 = max(d__1,d__2), d__2 = dlange_(
+ "M", n, &c__1, &b[1], n, d__);
+ xnorm = max(d__1,d__2);
+ }
+/* Computing MAX */
+ d__1 = smlnum, d__2 = eps * xnorm;
+ smin = max(d__1,d__2);
+
+/* Compute 1-norm of each column of strictly upper triangular */
+/* part of T to control overflow in triangular solver. */
+
+ work[1] = 0.;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ work[j] = dasum_(&i__2, &t[j * t_dim1 + 1], &c__1);
+/* L10: */
+ }
+
+ if (! (*lreal)) {
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ work[i__] += (d__1 = b[i__], abs(d__1));
+/* L20: */
+ }
+ }
+
+ n2 = *n << 1;
+ n1 = *n;
+ if (! (*lreal)) {
+ n1 = n2;
+ }
+ k = idamax_(&n1, &x[1], &c__1);
+ xmax = (d__1 = x[k], abs(d__1));
+ *scale = 1.;
+
+ if (xmax > bignum) {
+ *scale = bignum / xmax;
+ dscal_(&n1, scale, &x[1], &c__1);
+ xmax = bignum;
+ }
+
+ if (*lreal) {
+
+ if (notran) {
+
+/* Solve T*p = scale*c */
+
+ jnext = *n;
+ for (j = *n; j >= 1; --j) {
+ if (j > jnext) {
+ goto L30;
+ }
+ j1 = j;
+ j2 = j;
+ jnext = j - 1;
+ if (j > 1) {
+ if (t[j + (j - 1) * t_dim1] != 0.) {
+ j1 = j - 1;
+ jnext = j - 2;
+ }
+ }
+
+ if (j1 == j2) {
+
+/* Meet 1 by 1 diagonal block */
+
+/* Scale to avoid overflow when computing */
+/* x(j) = b(j)/T(j,j) */
+
+ xj = (d__1 = x[j1], abs(d__1));
+ tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1));
+ tmp = t[j1 + j1 * t_dim1];
+ if (tjj < smin) {
+ tmp = smin;
+ tjj = smin;
+ *info = 1;
+ }
+
+ if (xj == 0.) {
+ goto L30;
+ }
+
+ if (tjj < 1.) {
+ if (xj > bignum * tjj) {
+ rec = 1. / xj;
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ x[j1] /= tmp;
+ xj = (d__1 = x[j1], abs(d__1));
+
+/* Scale x if necessary to avoid overflow when adding a */
+/* multiple of column j1 of T. */
+
+ if (xj > 1.) {
+ rec = 1. / xj;
+ if (work[j1] > (bignum - xmax) * rec) {
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ }
+ }
+ if (j1 > 1) {
+ i__1 = j1 - 1;
+ d__1 = -x[j1];
+ daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
+, &c__1);
+ i__1 = j1 - 1;
+ k = idamax_(&i__1, &x[1], &c__1);
+ xmax = (d__1 = x[k], abs(d__1));
+ }
+
+ } else {
+
+/* Meet 2 by 2 diagonal block */
+
+/* Call 2 by 2 linear system solve, to take */
+/* care of possible overflow by scaling factor. */
+
+ d__[0] = x[j1];
+ d__[1] = x[j2];
+ dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b21, &t[j1 + j1
+ * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &
+ c_b25, &c_b25, v, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 2;
+ }
+
+ if (scaloc != 1.) {
+ dscal_(n, &scaloc, &x[1], &c__1);
+ *scale *= scaloc;
+ }
+ x[j1] = v[0];
+ x[j2] = v[1];
+
+/* Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2)) */
+/* to avoid overflow in updating right-hand side. */
+
+/* Computing MAX */
+ d__1 = abs(v[0]), d__2 = abs(v[1]);
+ xj = max(d__1,d__2);
+ if (xj > 1.) {
+ rec = 1. / xj;
+/* Computing MAX */
+ d__1 = work[j1], d__2 = work[j2];
+ if (max(d__1,d__2) > (bignum - xmax) * rec) {
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ }
+ }
+
+/* Update right-hand side */
+
+ if (j1 > 1) {
+ i__1 = j1 - 1;
+ d__1 = -x[j1];
+ daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
+, &c__1);
+ i__1 = j1 - 1;
+ d__1 = -x[j2];
+ daxpy_(&i__1, &d__1, &t[j2 * t_dim1 + 1], &c__1, &x[1]
+, &c__1);
+ i__1 = j1 - 1;
+ k = idamax_(&i__1, &x[1], &c__1);
+ xmax = (d__1 = x[k], abs(d__1));
+ }
+
+ }
+
+L30:
+ ;
+ }
+
+ } else {
+
+/* Solve T'*p = scale*c */
+
+ jnext = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (j < jnext) {
+ goto L40;
+ }
+ j1 = j;
+ j2 = j;
+ jnext = j + 1;
+ if (j < *n) {
+ if (t[j + 1 + j * t_dim1] != 0.) {
+ j2 = j + 1;
+ jnext = j + 2;
+ }
+ }
+
+ if (j1 == j2) {
+
+/* 1 by 1 diagonal block */
+
+/* Scale if necessary to avoid overflow in forming the */
+/* right-hand side element by inner product. */
+
+ xj = (d__1 = x[j1], abs(d__1));
+ if (xmax > 1.) {
+ rec = 1. / xmax;
+ if (work[j1] > (bignum - xj) * rec) {
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ i__2 = j1 - 1;
+ x[j1] -= ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], &
+ c__1);
+
+ xj = (d__1 = x[j1], abs(d__1));
+ tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1));
+ tmp = t[j1 + j1 * t_dim1];
+ if (tjj < smin) {
+ tmp = smin;
+ tjj = smin;
+ *info = 1;
+ }
+
+ if (tjj < 1.) {
+ if (xj > bignum * tjj) {
+ rec = 1. / xj;
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ x[j1] /= tmp;
+/* Computing MAX */
+ d__2 = xmax, d__3 = (d__1 = x[j1], abs(d__1));
+ xmax = max(d__2,d__3);
+
+ } else {
+
+/* 2 by 2 diagonal block */
+
+/* Scale if necessary to avoid overflow in forming the */
+/* right-hand side elements by inner product. */
+
+/* Computing MAX */
+ d__3 = (d__1 = x[j1], abs(d__1)), d__4 = (d__2 = x[j2],
+ abs(d__2));
+ xj = max(d__3,d__4);
+ if (xmax > 1.) {
+ rec = 1. / xmax;
+/* Computing MAX */
+ d__1 = work[j2], d__2 = work[j1];
+ if (max(d__1,d__2) > (bignum - xj) * rec) {
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ i__2 = j1 - 1;
+ d__[0] = x[j1] - ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1,
+ &x[1], &c__1);
+ i__2 = j1 - 1;
+ d__[1] = x[j2] - ddot_(&i__2, &t[j2 * t_dim1 + 1], &c__1,
+ &x[1], &c__1);
+
+ dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b21, &t[j1 + j1 *
+ t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &c_b25,
+ &c_b25, v, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 2;
+ }
+
+ if (scaloc != 1.) {
+ dscal_(n, &scaloc, &x[1], &c__1);
+ *scale *= scaloc;
+ }
+ x[j1] = v[0];
+ x[j2] = v[1];
+/* Computing MAX */
+ d__3 = (d__1 = x[j1], abs(d__1)), d__4 = (d__2 = x[j2],
+ abs(d__2)), d__3 = max(d__3,d__4);
+ xmax = max(d__3,xmax);
+
+ }
+L40:
+ ;
+ }
+ }
+
+ } else {
+
+/* Computing MAX */
+ d__1 = eps * abs(*w);
+ sminw = max(d__1,smin);
+ if (notran) {
+
+/* Solve (T + iB)*(p+iq) = c+id */
+
+ jnext = *n;
+ for (j = *n; j >= 1; --j) {
+ if (j > jnext) {
+ goto L70;
+ }
+ j1 = j;
+ j2 = j;
+ jnext = j - 1;
+ if (j > 1) {
+ if (t[j + (j - 1) * t_dim1] != 0.) {
+ j1 = j - 1;
+ jnext = j - 2;
+ }
+ }
+
+ if (j1 == j2) {
+
+/* 1 by 1 diagonal block */
+
+/* Scale if necessary to avoid overflow in division */
+
+ z__ = *w;
+ if (j1 == 1) {
+ z__ = b[1];
+ }
+ xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], abs(
+ d__2));
+ tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1)) + abs(z__);
+ tmp = t[j1 + j1 * t_dim1];
+ if (tjj < sminw) {
+ tmp = sminw;
+ tjj = sminw;
+ *info = 1;
+ }
+
+ if (xj == 0.) {
+ goto L70;
+ }
+
+ if (tjj < 1.) {
+ if (xj > bignum * tjj) {
+ rec = 1. / xj;
+ dscal_(&n2, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ dladiv_(&x[j1], &x[*n + j1], &tmp, &z__, &sr, &si);
+ x[j1] = sr;
+ x[*n + j1] = si;
+ xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], abs(
+ d__2));
+
+/* Scale x if necessary to avoid overflow when adding a */
+/* multiple of column j1 of T. */
+
+ if (xj > 1.) {
+ rec = 1. / xj;
+ if (work[j1] > (bignum - xmax) * rec) {
+ dscal_(&n2, &rec, &x[1], &c__1);
+ *scale *= rec;
+ }
+ }
+
+ if (j1 > 1) {
+ i__1 = j1 - 1;
+ d__1 = -x[j1];
+ daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
+, &c__1);
+ i__1 = j1 - 1;
+ d__1 = -x[*n + j1];
+ daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[*
+ n + 1], &c__1);
+
+ x[1] += b[j1] * x[*n + j1];
+ x[*n + 1] -= b[j1] * x[j1];
+
+ xmax = 0.;
+ i__1 = j1 - 1;
+ for (k = 1; k <= i__1; ++k) {
+/* Computing MAX */
+ d__3 = xmax, d__4 = (d__1 = x[k], abs(d__1)) + (
+ d__2 = x[k + *n], abs(d__2));
+ xmax = max(d__3,d__4);
+/* L50: */
+ }
+ }
+
+ } else {
+
+/* Meet 2 by 2 diagonal block */
+
+ d__[0] = x[j1];
+ d__[1] = x[j2];
+ d__[2] = x[*n + j1];
+ d__[3] = x[*n + j2];
+ d__1 = -(*w);
+ dlaln2_(&c_false, &c__2, &c__2, &sminw, &c_b21, &t[j1 +
+ j1 * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &
+ c_b25, &d__1, v, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 2;
+ }
+
+ if (scaloc != 1.) {
+ i__1 = *n << 1;
+ dscal_(&i__1, &scaloc, &x[1], &c__1);
+ *scale = scaloc * *scale;
+ }
+ x[j1] = v[0];
+ x[j2] = v[1];
+ x[*n + j1] = v[2];
+ x[*n + j2] = v[3];
+
+/* Scale X(J1), .... to avoid overflow in */
+/* updating right hand side. */
+
+/* Computing MAX */
+ d__1 = abs(v[0]) + abs(v[2]), d__2 = abs(v[1]) + abs(v[3])
+ ;
+ xj = max(d__1,d__2);
+ if (xj > 1.) {
+ rec = 1. / xj;
+/* Computing MAX */
+ d__1 = work[j1], d__2 = work[j2];
+ if (max(d__1,d__2) > (bignum - xmax) * rec) {
+ dscal_(&n2, &rec, &x[1], &c__1);
+ *scale *= rec;
+ }
+ }
+
+/* Update the right-hand side. */
+
+ if (j1 > 1) {
+ i__1 = j1 - 1;
+ d__1 = -x[j1];
+ daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
+, &c__1);
+ i__1 = j1 - 1;
+ d__1 = -x[j2];
+ daxpy_(&i__1, &d__1, &t[j2 * t_dim1 + 1], &c__1, &x[1]
+, &c__1);
+
+ i__1 = j1 - 1;
+ d__1 = -x[*n + j1];
+ daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[*
+ n + 1], &c__1);
+ i__1 = j1 - 1;
+ d__1 = -x[*n + j2];
+ daxpy_(&i__1, &d__1, &t[j2 * t_dim1 + 1], &c__1, &x[*
+ n + 1], &c__1);
+
+ x[1] = x[1] + b[j1] * x[*n + j1] + b[j2] * x[*n + j2];
+ x[*n + 1] = x[*n + 1] - b[j1] * x[j1] - b[j2] * x[j2];
+
+ xmax = 0.;
+ i__1 = j1 - 1;
+ for (k = 1; k <= i__1; ++k) {
+/* Computing MAX */
+ d__3 = (d__1 = x[k], abs(d__1)) + (d__2 = x[k + *
+ n], abs(d__2));
+ xmax = max(d__3,xmax);
+/* L60: */
+ }
+ }
+
+ }
+L70:
+ ;
+ }
+
+ } else {
+
+/* Solve (T + iB)'*(p+iq) = c+id */
+
+ jnext = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (j < jnext) {
+ goto L80;
+ }
+ j1 = j;
+ j2 = j;
+ jnext = j + 1;
+ if (j < *n) {
+ if (t[j + 1 + j * t_dim1] != 0.) {
+ j2 = j + 1;
+ jnext = j + 2;
+ }
+ }
+
+ if (j1 == j2) {
+
+/* 1 by 1 diagonal block */
+
+/* Scale if necessary to avoid overflow in forming the */
+/* right-hand side element by inner product. */
+
+ xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n], abs(
+ d__2));
+ if (xmax > 1.) {
+ rec = 1. / xmax;
+ if (work[j1] > (bignum - xj) * rec) {
+ dscal_(&n2, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ i__2 = j1 - 1;
+ x[j1] -= ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], &
+ c__1);
+ i__2 = j1 - 1;
+ x[*n + j1] -= ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[
+ *n + 1], &c__1);
+ if (j1 > 1) {
+ x[j1] -= b[j1] * x[*n + 1];
+ x[*n + j1] += b[j1] * x[1];
+ }
+ xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n], abs(
+ d__2));
+
+ z__ = *w;
+ if (j1 == 1) {
+ z__ = b[1];
+ }
+
+/* Scale if necessary to avoid overflow in */
+/* complex division */
+
+ tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1)) + abs(z__);
+ tmp = t[j1 + j1 * t_dim1];
+ if (tjj < sminw) {
+ tmp = sminw;
+ tjj = sminw;
+ *info = 1;
+ }
+
+ if (tjj < 1.) {
+ if (xj > bignum * tjj) {
+ rec = 1. / xj;
+ dscal_(&n2, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ d__1 = -z__;
+ dladiv_(&x[j1], &x[*n + j1], &tmp, &d__1, &sr, &si);
+ x[j1] = sr;
+ x[j1 + *n] = si;
+/* Computing MAX */
+ d__3 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n],
+ abs(d__2));
+ xmax = max(d__3,xmax);
+
+ } else {
+
+/* 2 by 2 diagonal block */
+
+/* Scale if necessary to avoid overflow in forming the */
+/* right-hand side element by inner product. */
+
+/* Computing MAX */
+ d__5 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1],
+ abs(d__2)), d__6 = (d__3 = x[j2], abs(d__3)) + (
+ d__4 = x[*n + j2], abs(d__4));
+ xj = max(d__5,d__6);
+ if (xmax > 1.) {
+ rec = 1. / xmax;
+/* Computing MAX */
+ d__1 = work[j1], d__2 = work[j2];
+ if (max(d__1,d__2) > (bignum - xj) / xmax) {
+ dscal_(&n2, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ i__2 = j1 - 1;
+ d__[0] = x[j1] - ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1,
+ &x[1], &c__1);
+ i__2 = j1 - 1;
+ d__[1] = x[j2] - ddot_(&i__2, &t[j2 * t_dim1 + 1], &c__1,
+ &x[1], &c__1);
+ i__2 = j1 - 1;
+ d__[2] = x[*n + j1] - ddot_(&i__2, &t[j1 * t_dim1 + 1], &
+ c__1, &x[*n + 1], &c__1);
+ i__2 = j1 - 1;
+ d__[3] = x[*n + j2] - ddot_(&i__2, &t[j2 * t_dim1 + 1], &
+ c__1, &x[*n + 1], &c__1);
+ d__[0] -= b[j1] * x[*n + 1];
+ d__[1] -= b[j2] * x[*n + 1];
+ d__[2] += b[j1] * x[1];
+ d__[3] += b[j2] * x[1];
+
+ dlaln2_(&c_true, &c__2, &c__2, &sminw, &c_b21, &t[j1 + j1
+ * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &
+ c_b25, w, v, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 2;
+ }
+
+ if (scaloc != 1.) {
+ dscal_(&n2, &scaloc, &x[1], &c__1);
+ *scale = scaloc * *scale;
+ }
+ x[j1] = v[0];
+ x[j2] = v[1];
+ x[*n + j1] = v[2];
+ x[*n + j2] = v[3];
+/* Computing MAX */
+ d__5 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1],
+ abs(d__2)), d__6 = (d__3 = x[j2], abs(d__3)) + (
+ d__4 = x[*n + j2], abs(d__4)), d__5 = max(d__5,
+ d__6);
+ xmax = max(d__5,xmax);
+
+ }
+
+L80:
+ ;
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of DLAQTR */
+
+} /* dlaqtr_ */
diff --git a/SRC/dlar1v.c b/SRC/dlar1v.c
new file mode 100644
index 0000000..2b3573e
--- /dev/null
+++ b/SRC/dlar1v.c
@@ -0,0 +1,441 @@
+/* dlar1v.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlar1v_(integer *n, integer *b1, integer *bn, doublereal
+ *lambda, doublereal *d__, doublereal *l, doublereal *ld, doublereal *
+ lld, doublereal *pivmin, doublereal *gaptol, doublereal *z__, logical
+ *wantnc, integer *negcnt, doublereal *ztz, doublereal *mingma,
+ integer *r__, integer *isuppz, doublereal *nrminv, doublereal *resid,
+ doublereal *rqcorr, doublereal *work)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal s;
+ integer r1, r2;
+ doublereal eps, tmp;
+ integer neg1, neg2, indp, inds;
+ doublereal dplus;
+ extern doublereal dlamch_(char *);
+ extern logical disnan_(doublereal *);
+ integer indlpl, indumn;
+ doublereal dminus;
+ logical sawnan1, sawnan2;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAR1V computes the (scaled) r-th column of the inverse of */
+/* the sumbmatrix in rows B1 through BN of the tridiagonal matrix */
+/* L D L^T - sigma I. When sigma is close to an eigenvalue, the */
+/* computed vector is an accurate eigenvector. Usually, r corresponds */
+/* to the index where the eigenvector is largest in magnitude. */
+/* The following steps accomplish this computation : */
+/* (a) Stationary qd transform, L D L^T - sigma I = L(+) D(+) L(+)^T, */
+/* (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T, */
+/* (c) Computation of the diagonal elements of the inverse of */
+/* L D L^T - sigma I by combining the above transforms, and choosing */
+/* r as the index where the diagonal of the inverse is (one of the) */
+/* largest in magnitude. */
+/* (d) Computation of the (scaled) r-th column of the inverse using the */
+/* twisted factorization obtained by combining the top part of the */
+/* the stationary and the bottom part of the progressive transform. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix L D L^T. */
+
+/* B1 (input) INTEGER */
+/* First index of the submatrix of L D L^T. */
+
+/* BN (input) INTEGER */
+/* Last index of the submatrix of L D L^T. */
+
+/* LAMBDA (input) DOUBLE PRECISION */
+/* The shift. In order to compute an accurate eigenvector, */
+/* LAMBDA should be a good approximation to an eigenvalue */
+/* of L D L^T. */
+
+/* L (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the unit bidiagonal matrix */
+/* L, in elements 1 to N-1. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the diagonal matrix D. */
+
+/* LD (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The n-1 elements L(i)*D(i). */
+
+/* LLD (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The n-1 elements L(i)*L(i)*D(i). */
+
+/* PIVMIN (input) DOUBLE PRECISION */
+/* The minimum pivot in the Sturm sequence. */
+
+/* GAPTOL (input) DOUBLE PRECISION */
+/* Tolerance that indicates when eigenvector entries are negligible */
+/* w.r.t. their contribution to the residual. */
+
+/* Z (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On input, all entries of Z must be set to 0. */
+/* On output, Z contains the (scaled) r-th column of the */
+/* inverse. The scaling is such that Z(R) equals 1. */
+
+/* WANTNC (input) LOGICAL */
+/* Specifies whether NEGCNT has to be computed. */
+
+/* NEGCNT (output) INTEGER */
+/* If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin */
+/* in the matrix factorization L D L^T, and NEGCNT = -1 otherwise. */
+
+/* ZTZ (output) DOUBLE PRECISION */
+/* The square of the 2-norm of Z. */
+
+/* MINGMA (output) DOUBLE PRECISION */
+/* The reciprocal of the largest (in magnitude) diagonal */
+/* element of the inverse of L D L^T - sigma I. */
+
+/* R (input/output) INTEGER */
+/* The twist index for the twisted factorization used to */
+/* compute Z. */
+/* On input, 0 <= R <= N. If R is input as 0, R is set to */
+/* the index where (L D L^T - sigma I)^{-1} is largest */
+/* in magnitude. If 1 <= R <= N, R is unchanged. */
+/* On output, R contains the twist index used to compute Z. */
+/* Ideally, R designates the position of the maximum entry in the */
+/* eigenvector. */
+
+/* ISUPPZ (output) INTEGER array, dimension (2) */
+/* The support of the vector in Z, i.e., the vector Z is */
+/* nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ). */
+
+/* NRMINV (output) DOUBLE PRECISION */
+/* NRMINV = 1/SQRT( ZTZ ) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The residual of the FP vector. */
+/* RESID = ABS( MINGMA )/SQRT( ZTZ ) */
+
+/* RQCORR (output) DOUBLE PRECISION */
+/* The Rayleigh Quotient correction to LAMBDA. */
+/* RQCORR = MINGMA*TMP */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --isuppz;
+ --z__;
+ --lld;
+ --ld;
+ --l;
+ --d__;
+
+ /* Function Body */
+ eps = dlamch_("Precision");
+ if (*r__ == 0) {
+ r1 = *b1;
+ r2 = *bn;
+ } else {
+ r1 = *r__;
+ r2 = *r__;
+ }
+/* Storage for LPLUS */
+ indlpl = 0;
+/* Storage for UMINUS */
+ indumn = *n;
+ inds = (*n << 1) + 1;
+ indp = *n * 3 + 1;
+ if (*b1 == 1) {
+ work[inds] = 0.;
+ } else {
+ work[inds + *b1 - 1] = lld[*b1 - 1];
+ }
+
+/* Compute the stationary transform (using the differential form) */
+/* until the index R2. */
+
+ sawnan1 = FALSE_;
+ neg1 = 0;
+ s = work[inds + *b1 - 1] - *lambda;
+ i__1 = r1 - 1;
+ for (i__ = *b1; i__ <= i__1; ++i__) {
+ dplus = d__[i__] + s;
+ work[indlpl + i__] = ld[i__] / dplus;
+ if (dplus < 0.) {
+ ++neg1;
+ }
+ work[inds + i__] = s * work[indlpl + i__] * l[i__];
+ s = work[inds + i__] - *lambda;
+/* L50: */
+ }
+ sawnan1 = disnan_(&s);
+ if (sawnan1) {
+ goto L60;
+ }
+ i__1 = r2 - 1;
+ for (i__ = r1; i__ <= i__1; ++i__) {
+ dplus = d__[i__] + s;
+ work[indlpl + i__] = ld[i__] / dplus;
+ work[inds + i__] = s * work[indlpl + i__] * l[i__];
+ s = work[inds + i__] - *lambda;
+/* L51: */
+ }
+ sawnan1 = disnan_(&s);
+
+L60:
+ if (sawnan1) {
+/* Runs a slower version of the above loop if a NaN is detected */
+ neg1 = 0;
+ s = work[inds + *b1 - 1] - *lambda;
+ i__1 = r1 - 1;
+ for (i__ = *b1; i__ <= i__1; ++i__) {
+ dplus = d__[i__] + s;
+ if (abs(dplus) < *pivmin) {
+ dplus = -(*pivmin);
+ }
+ work[indlpl + i__] = ld[i__] / dplus;
+ if (dplus < 0.) {
+ ++neg1;
+ }
+ work[inds + i__] = s * work[indlpl + i__] * l[i__];
+ if (work[indlpl + i__] == 0.) {
+ work[inds + i__] = lld[i__];
+ }
+ s = work[inds + i__] - *lambda;
+/* L70: */
+ }
+ i__1 = r2 - 1;
+ for (i__ = r1; i__ <= i__1; ++i__) {
+ dplus = d__[i__] + s;
+ if (abs(dplus) < *pivmin) {
+ dplus = -(*pivmin);
+ }
+ work[indlpl + i__] = ld[i__] / dplus;
+ work[inds + i__] = s * work[indlpl + i__] * l[i__];
+ if (work[indlpl + i__] == 0.) {
+ work[inds + i__] = lld[i__];
+ }
+ s = work[inds + i__] - *lambda;
+/* L71: */
+ }
+ }
+
+/* Compute the progressive transform (using the differential form) */
+/* until the index R1 */
+
+ sawnan2 = FALSE_;
+ neg2 = 0;
+ work[indp + *bn - 1] = d__[*bn] - *lambda;
+ i__1 = r1;
+ for (i__ = *bn - 1; i__ >= i__1; --i__) {
+ dminus = lld[i__] + work[indp + i__];
+ tmp = d__[i__] / dminus;
+ if (dminus < 0.) {
+ ++neg2;
+ }
+ work[indumn + i__] = l[i__] * tmp;
+ work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda;
+/* L80: */
+ }
+ tmp = work[indp + r1 - 1];
+ sawnan2 = disnan_(&tmp);
+ if (sawnan2) {
+/* Runs a slower version of the above loop if a NaN is detected */
+ neg2 = 0;
+ i__1 = r1;
+ for (i__ = *bn - 1; i__ >= i__1; --i__) {
+ dminus = lld[i__] + work[indp + i__];
+ if (abs(dminus) < *pivmin) {
+ dminus = -(*pivmin);
+ }
+ tmp = d__[i__] / dminus;
+ if (dminus < 0.) {
+ ++neg2;
+ }
+ work[indumn + i__] = l[i__] * tmp;
+ work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda;
+ if (tmp == 0.) {
+ work[indp + i__ - 1] = d__[i__] - *lambda;
+ }
+/* L100: */
+ }
+ }
+
+/* Find the index (from R1 to R2) of the largest (in magnitude) */
+/* diagonal element of the inverse */
+
+ *mingma = work[inds + r1 - 1] + work[indp + r1 - 1];
+ if (*mingma < 0.) {
+ ++neg1;
+ }
+ if (*wantnc) {
+ *negcnt = neg1 + neg2;
+ } else {
+ *negcnt = -1;
+ }
+ if (abs(*mingma) == 0.) {
+ *mingma = eps * work[inds + r1 - 1];
+ }
+ *r__ = r1;
+ i__1 = r2 - 1;
+ for (i__ = r1; i__ <= i__1; ++i__) {
+ tmp = work[inds + i__] + work[indp + i__];
+ if (tmp == 0.) {
+ tmp = eps * work[inds + i__];
+ }
+ if (abs(tmp) <= abs(*mingma)) {
+ *mingma = tmp;
+ *r__ = i__ + 1;
+ }
+/* L110: */
+ }
+
+/* Compute the FP vector: solve N^T v = e_r */
+
+ isuppz[1] = *b1;
+ isuppz[2] = *bn;
+ z__[*r__] = 1.;
+ *ztz = 1.;
+
+/* Compute the FP vector upwards from R */
+
+ if (! sawnan1 && ! sawnan2) {
+ i__1 = *b1;
+ for (i__ = *r__ - 1; i__ >= i__1; --i__) {
+ z__[i__] = -(work[indlpl + i__] * z__[i__ + 1]);
+ if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs(
+ d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) {
+ z__[i__] = 0.;
+ isuppz[1] = i__ + 1;
+ goto L220;
+ }
+ *ztz += z__[i__] * z__[i__];
+/* L210: */
+ }
+L220:
+ ;
+ } else {
+/* Run slower loop if NaN occurred. */
+ i__1 = *b1;
+ for (i__ = *r__ - 1; i__ >= i__1; --i__) {
+ if (z__[i__ + 1] == 0.) {
+ z__[i__] = -(ld[i__ + 1] / ld[i__]) * z__[i__ + 2];
+ } else {
+ z__[i__] = -(work[indlpl + i__] * z__[i__ + 1]);
+ }
+ if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs(
+ d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) {
+ z__[i__] = 0.;
+ isuppz[1] = i__ + 1;
+ goto L240;
+ }
+ *ztz += z__[i__] * z__[i__];
+/* L230: */
+ }
+L240:
+ ;
+ }
+/* Compute the FP vector downwards from R in blocks of size BLKSIZ */
+ if (! sawnan1 && ! sawnan2) {
+ i__1 = *bn - 1;
+ for (i__ = *r__; i__ <= i__1; ++i__) {
+ z__[i__ + 1] = -(work[indumn + i__] * z__[i__]);
+ if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs(
+ d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) {
+ z__[i__ + 1] = 0.;
+ isuppz[2] = i__;
+ goto L260;
+ }
+ *ztz += z__[i__ + 1] * z__[i__ + 1];
+/* L250: */
+ }
+L260:
+ ;
+ } else {
+/* Run slower loop if NaN occurred. */
+ i__1 = *bn - 1;
+ for (i__ = *r__; i__ <= i__1; ++i__) {
+ if (z__[i__] == 0.) {
+ z__[i__ + 1] = -(ld[i__ - 1] / ld[i__]) * z__[i__ - 1];
+ } else {
+ z__[i__ + 1] = -(work[indumn + i__] * z__[i__]);
+ }
+ if (((d__1 = z__[i__], abs(d__1)) + (d__2 = z__[i__ + 1], abs(
+ d__2))) * (d__3 = ld[i__], abs(d__3)) < *gaptol) {
+ z__[i__ + 1] = 0.;
+ isuppz[2] = i__;
+ goto L280;
+ }
+ *ztz += z__[i__ + 1] * z__[i__ + 1];
+/* L270: */
+ }
+L280:
+ ;
+ }
+
+/* Compute quantities for convergence test */
+
+ tmp = 1. / *ztz;
+ *nrminv = sqrt(tmp);
+ *resid = abs(*mingma) * *nrminv;
+ *rqcorr = *mingma * tmp;
+
+
+ return 0;
+
+/* End of DLAR1V */
+
+} /* dlar1v_ */
diff --git a/SRC/dlar2v.c b/SRC/dlar2v.c
new file mode 100644
index 0000000..cd343d0
--- /dev/null
+++ b/SRC/dlar2v.c
@@ -0,0 +1,121 @@
+/* dlar2v.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlar2v_(integer *n, doublereal *x, doublereal *y,
+ doublereal *z__, integer *incx, doublereal *c__, doublereal *s,
+ integer *incc)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__;
+ doublereal t1, t2, t3, t4, t5, t6;
+ integer ic;
+ doublereal ci, si;
+ integer ix;
+ doublereal xi, yi, zi;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAR2V applies a vector of real plane rotations from both sides to */
+/* a sequence of 2-by-2 real symmetric matrices, defined by the elements */
+/* of the vectors x, y and z. For i = 1,2,...,n */
+
+/* ( x(i) z(i) ) := ( c(i) s(i) ) ( x(i) z(i) ) ( c(i) -s(i) ) */
+/* ( z(i) y(i) ) ( -s(i) c(i) ) ( z(i) y(i) ) ( s(i) c(i) ) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of plane rotations to be applied. */
+
+/* X (input/output) DOUBLE PRECISION array, */
+/* dimension (1+(N-1)*INCX) */
+/* The vector x. */
+
+/* Y (input/output) DOUBLE PRECISION array, */
+/* dimension (1+(N-1)*INCX) */
+/* The vector y. */
+
+/* Z (input/output) DOUBLE PRECISION array, */
+/* dimension (1+(N-1)*INCX) */
+/* The vector z. */
+
+/* INCX (input) INTEGER */
+/* The increment between elements of X, Y and Z. INCX > 0. */
+
+/* C (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC) */
+/* The cosines of the plane rotations. */
+
+/* S (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC) */
+/* The sines of the plane rotations. */
+
+/* INCC (input) INTEGER */
+/* The increment between elements of C and S. INCC > 0. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --s;
+ --c__;
+ --z__;
+ --y;
+ --x;
+
+ /* Function Body */
+ ix = 1;
+ ic = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xi = x[ix];
+ yi = y[ix];
+ zi = z__[ix];
+ ci = c__[ic];
+ si = s[ic];
+ t1 = si * zi;
+ t2 = ci * zi;
+ t3 = t2 - si * xi;
+ t4 = t2 + si * yi;
+ t5 = ci * xi + t1;
+ t6 = ci * yi - t1;
+ x[ix] = ci * t5 + si * t4;
+ y[ix] = ci * t6 - si * t3;
+ z__[ix] = ci * t4 - si * t5;
+ ix += *incx;
+ ic += *incc;
+/* L10: */
+ }
+
+/* End of DLAR2V */
+
+ return 0;
+} /* dlar2v_ */
diff --git a/SRC/dlarf.c b/SRC/dlarf.c
new file mode 100644
index 0000000..aba8a59
--- /dev/null
+++ b/SRC/dlarf.c
@@ -0,0 +1,193 @@
+/* dlarf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b4 = 1.;
+static doublereal c_b5 = 0.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dlarf_(char *side, integer *m, integer *n, doublereal *v,
+ integer *incv, doublereal *tau, doublereal *c__, integer *ldc,
+ doublereal *work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__;
+ logical applyleft;
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ integer lastc, lastv;
+ extern integer iladlc_(integer *, integer *, doublereal *, integer *),
+ iladlr_(integer *, integer *, doublereal *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARF applies a real elementary reflector H to a real m by n matrix */
+/* C, from either the left or the right. H is represented in the form */
+
+/* H = I - tau * v * v' */
+
+/* where tau is a real scalar and v is a real vector. */
+
+/* If tau = 0, then H is taken to be the unit matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': form H * C */
+/* = 'R': form C * H */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* V (input) DOUBLE PRECISION array, dimension */
+/* (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
+/* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
+/* The vector v in the representation of H. V is not used if */
+/* TAU = 0. */
+
+/* INCV (input) INTEGER */
+/* The increment between elements of v. INCV <> 0. */
+
+/* TAU (input) DOUBLE PRECISION */
+/* The value tau in the representation of H. */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/* On entry, the m by n matrix C. */
+/* On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
+/* or C * H if SIDE = 'R'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (N) if SIDE = 'L' */
+/* or (M) if SIDE = 'R' */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ applyleft = lsame_(side, "L");
+ lastv = 0;
+ lastc = 0;
+ if (*tau != 0.) {
+/* Set up variables for scanning V. LASTV begins pointing to the end */
+/* of V. */
+ if (applyleft) {
+ lastv = *m;
+ } else {
+ lastv = *n;
+ }
+ if (*incv > 0) {
+ i__ = (lastv - 1) * *incv + 1;
+ } else {
+ i__ = 1;
+ }
+/* Look for the last non-zero row in V. */
+ while(lastv > 0 && v[i__] == 0.) {
+ --lastv;
+ i__ -= *incv;
+ }
+ if (applyleft) {
+/* Scan for the last non-zero column in C(1:lastv,:). */
+ lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
+ } else {
+/* Scan for the last non-zero row in C(:,1:lastv). */
+ lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
+ }
+ }
+/* Note that lastc.eq.0 renders the BLAS operations null; no special */
+/* case is needed at this level. */
+ if (applyleft) {
+
+/* Form H * C */
+
+ if (lastv > 0) {
+
+/* w(1:lastc,1) := C(1:lastv,1:lastc)' * v(1:lastv,1) */
+
+ dgemv_("Transpose", &lastv, &lastc, &c_b4, &c__[c_offset], ldc, &
+ v[1], incv, &c_b5, &work[1], &c__1);
+
+/* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)' */
+
+ d__1 = -(*tau);
+ dger_(&lastv, &lastc, &d__1, &v[1], incv, &work[1], &c__1, &c__[
+ c_offset], ldc);
+ }
+ } else {
+
+/* Form C * H */
+
+ if (lastv > 0) {
+
+/* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) */
+
+ dgemv_("No transpose", &lastc, &lastv, &c_b4, &c__[c_offset], ldc,
+ &v[1], incv, &c_b5, &work[1], &c__1);
+
+/* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)' */
+
+ d__1 = -(*tau);
+ dger_(&lastc, &lastv, &d__1, &work[1], &c__1, &v[1], incv, &c__[
+ c_offset], ldc);
+ }
+ }
+ return 0;
+
+/* End of DLARF */
+
+} /* dlarf_ */
diff --git a/SRC/dlarfb.c b/SRC/dlarfb.c
new file mode 100644
index 0000000..9833b69
--- /dev/null
+++ b/SRC/dlarfb.c
@@ -0,0 +1,774 @@
+/* dlarfb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b14 = 1.;
+static doublereal c_b25 = -1.;
+
+/* Subroutine */ int dlarfb_(char *side, char *trans, char *direct, char *
+ storev, integer *m, integer *n, integer *k, doublereal *v, integer *
+ ldv, doublereal *t, integer *ldt, doublereal *c__, integer *ldc,
+ doublereal *work, integer *ldwork)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1,
+ work_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ integer lastc;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dtrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer lastv;
+ extern integer iladlc_(integer *, integer *, doublereal *, integer *),
+ iladlr_(integer *, integer *, doublereal *, integer *);
+ char transt[1];
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARFB applies a real block reflector H or its transpose H' to a */
+/* real m by n matrix C, from either the left or the right. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply H or H' from the Left */
+/* = 'R': apply H or H' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply H (No transpose) */
+/* = 'T': apply H' (Transpose) */
+
+/* DIRECT (input) CHARACTER*1 */
+/* Indicates how H is formed from a product of elementary */
+/* reflectors */
+/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */
+/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
+
+/* STOREV (input) CHARACTER*1 */
+/* Indicates how the vectors which define the elementary */
+/* reflectors are stored: */
+/* = 'C': Columnwise */
+/* = 'R': Rowwise */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* K (input) INTEGER */
+/* The order of the matrix T (= the number of elementary */
+/* reflectors whose product defines the block reflector). */
+
+/* V (input) DOUBLE PRECISION array, dimension */
+/* (LDV,K) if STOREV = 'C' */
+/* (LDV,M) if STOREV = 'R' and SIDE = 'L' */
+/* (LDV,N) if STOREV = 'R' and SIDE = 'R' */
+/* The matrix V. See further details. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. */
+/* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); */
+/* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); */
+/* if STOREV = 'R', LDV >= K. */
+
+/* T (input) DOUBLE PRECISION array, dimension (LDT,K) */
+/* The triangular k by k matrix T in the representation of the */
+/* block reflector. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= K. */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/* On entry, the m by n matrix C. */
+/* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDA >= max(1,M). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. */
+/* If SIDE = 'L', LDWORK >= max(1,N); */
+/* if SIDE = 'R', LDWORK >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+ if (lsame_(trans, "N")) {
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+ if (lsame_(storev, "C")) {
+
+ if (lsame_(direct, "F")) {
+
+/* Let V = ( V1 ) (first K rows) */
+/* ( V2 ) */
+/* where V1 is unit lower triangular. */
+
+ if (lsame_(side, "L")) {
+
+/* Form H * C or H' * C where C = ( C1 ) */
+/* ( C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = iladlr_(m, k, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
+
+/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */
+
+/* W := C1' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1
+ + 1], &c__1);
+/* L10: */
+ }
+
+/* W := W * V1 */
+
+ dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
+ c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C2'*V2 */
+
+ i__1 = lastv - *k;
+ dgemm_("Transpose", "No transpose", &lastc, k, &i__1, &
+ c_b14, &c__[*k + 1 + c_dim1], ldc, &v[*k + 1 +
+ v_dim1], ldv, &c_b14, &work[work_offset], ldwork);
+ }
+
+/* W := W * T' or W * T */
+
+ dtrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &
+ c_b14, &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - V * W' */
+
+ if (lastv > *k) {
+
+/* C2 := C2 - V2 * W' */
+
+ i__1 = lastv - *k;
+ dgemm_("No transpose", "Transpose", &i__1, &lastc, k, &
+ c_b25, &v[*k + 1 + v_dim1], ldv, &work[
+ work_offset], ldwork, &c_b14, &c__[*k + 1 +
+ c_dim1], ldc);
+ }
+
+/* W := W * V1' */
+
+ dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &
+ c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+
+/* C1 := C1 - W' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1];
+/* L20: */
+ }
+/* L30: */
+ }
+
+ } else if (lsame_(side, "R")) {
+
+/* Form C * H or C * H' where C = ( C1 C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = iladlr_(n, k, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
+
+/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */
+
+/* W := C1 */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j *
+ work_dim1 + 1], &c__1);
+/* L40: */
+ }
+
+/* W := W * V1 */
+
+ dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
+ c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C2 * V2 */
+
+ i__1 = lastv - *k;
+ dgemm_("No transpose", "No transpose", &lastc, k, &i__1, &
+ c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k +
+ 1 + v_dim1], ldv, &c_b14, &work[work_offset],
+ ldwork);
+ }
+
+/* W := W * T or W * T' */
+
+ dtrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b14,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - W * V' */
+
+ if (lastv > *k) {
+
+/* C2 := C2 - W * V2' */
+
+ i__1 = lastv - *k;
+ dgemm_("No transpose", "Transpose", &lastc, &i__1, k, &
+ c_b25, &work[work_offset], ldwork, &v[*k + 1 +
+ v_dim1], ldv, &c_b14, &c__[(*k + 1) * c_dim1 + 1],
+ ldc);
+ }
+
+/* W := W * V1' */
+
+ dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &
+ c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+
+/* C1 := C1 - W */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+
+ } else {
+
+/* Let V = ( V1 ) */
+/* ( V2 ) (last K rows) */
+/* where V2 is unit upper triangular. */
+
+ if (lsame_(side, "L")) {
+
+/* Form H * C or H' * C where C = ( C1 ) */
+/* ( C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = iladlr_(m, k, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
+
+/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */
+
+/* W := C2' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[
+ j * work_dim1 + 1], &c__1);
+/* L70: */
+ }
+
+/* W := W * V2 */
+
+ dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
+ c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[
+ work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C1'*V1 */
+
+ i__1 = lastv - *k;
+ dgemm_("Transpose", "No transpose", &lastc, k, &i__1, &
+ c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &
+ c_b14, &work[work_offset], ldwork);
+ }
+
+/* W := W * T' or W * T */
+
+ dtrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &
+ c_b14, &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - V * W' */
+
+ if (lastv > *k) {
+
+/* C1 := C1 - V1 * W' */
+
+ i__1 = lastv - *k;
+ dgemm_("No transpose", "Transpose", &i__1, &lastc, k, &
+ c_b25, &v[v_offset], ldv, &work[work_offset],
+ ldwork, &c_b14, &c__[c_offset], ldc);
+ }
+
+/* W := W * V2' */
+
+ dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &
+ c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[
+ work_offset], ldwork);
+
+/* C2 := C2 - W' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[lastv - *k + j + i__ * c_dim1] -= work[i__ + j *
+ work_dim1];
+/* L80: */
+ }
+/* L90: */
+ }
+
+ } else if (lsame_(side, "R")) {
+
+/* Form C * H or C * H' where C = ( C1 C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = iladlr_(n, k, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
+
+/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */
+
+/* W := C2 */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(&lastc, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &
+ work[j * work_dim1 + 1], &c__1);
+/* L100: */
+ }
+
+/* W := W * V2 */
+
+ dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
+ c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[
+ work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C1 * V1 */
+
+ i__1 = lastv - *k;
+ dgemm_("No transpose", "No transpose", &lastc, k, &i__1, &
+ c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &
+ c_b14, &work[work_offset], ldwork);
+ }
+
+/* W := W * T or W * T' */
+
+ dtrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b14,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - W * V' */
+
+ if (lastv > *k) {
+
+/* C1 := C1 - W * V1' */
+
+ i__1 = lastv - *k;
+ dgemm_("No transpose", "Transpose", &lastc, &i__1, k, &
+ c_b25, &work[work_offset], ldwork, &v[v_offset],
+ ldv, &c_b14, &c__[c_offset], ldc);
+ }
+
+/* W := W * V2' */
+
+ dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &
+ c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[
+ work_offset], ldwork);
+
+/* C2 := C2 - W */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + (lastv - *k + j) * c_dim1] -= work[i__ + j *
+ work_dim1];
+/* L110: */
+ }
+/* L120: */
+ }
+ }
+ }
+
+ } else if (lsame_(storev, "R")) {
+
+ if (lsame_(direct, "F")) {
+
+/* Let V = ( V1 V2 ) (V1: first K columns) */
+/* where V1 is unit upper triangular. */
+
+ if (lsame_(side, "L")) {
+
+/* Form H * C or H' * C where C = ( C1 ) */
+/* ( C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = iladlc_(k, m, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
+
+/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */
+
+/* W := C1' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1
+ + 1], &c__1);
+/* L130: */
+ }
+
+/* W := W * V1' */
+
+ dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &
+ c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C2'*V2' */
+
+ i__1 = lastv - *k;
+ dgemm_("Transpose", "Transpose", &lastc, k, &i__1, &c_b14,
+ &c__[*k + 1 + c_dim1], ldc, &v[(*k + 1) * v_dim1
+ + 1], ldv, &c_b14, &work[work_offset], ldwork);
+ }
+
+/* W := W * T' or W * T */
+
+ dtrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &
+ c_b14, &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - V' * W' */
+
+ if (lastv > *k) {
+
+/* C2 := C2 - V2' * W' */
+
+ i__1 = lastv - *k;
+ dgemm_("Transpose", "Transpose", &i__1, &lastc, k, &c_b25,
+ &v[(*k + 1) * v_dim1 + 1], ldv, &work[
+ work_offset], ldwork, &c_b14, &c__[*k + 1 +
+ c_dim1], ldc);
+ }
+
+/* W := W * V1 */
+
+ dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
+ c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+
+/* C1 := C1 - W' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1];
+/* L140: */
+ }
+/* L150: */
+ }
+
+ } else if (lsame_(side, "R")) {
+
+/* Form C * H or C * H' where C = ( C1 C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = iladlc_(k, n, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
+
+/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */
+
+/* W := C1 */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j *
+ work_dim1 + 1], &c__1);
+/* L160: */
+ }
+
+/* W := W * V1' */
+
+ dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &
+ c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C2 * V2' */
+
+ i__1 = lastv - *k;
+ dgemm_("No transpose", "Transpose", &lastc, k, &i__1, &
+ c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k +
+ 1) * v_dim1 + 1], ldv, &c_b14, &work[work_offset],
+ ldwork);
+ }
+
+/* W := W * T or W * T' */
+
+ dtrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b14,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - W * V */
+
+ if (lastv > *k) {
+
+/* C2 := C2 - W * V2 */
+
+ i__1 = lastv - *k;
+ dgemm_("No transpose", "No transpose", &lastc, &i__1, k, &
+ c_b25, &work[work_offset], ldwork, &v[(*k + 1) *
+ v_dim1 + 1], ldv, &c_b14, &c__[(*k + 1) * c_dim1
+ + 1], ldc);
+ }
+
+/* W := W * V1 */
+
+ dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
+ c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+
+/* C1 := C1 - W */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1];
+/* L170: */
+ }
+/* L180: */
+ }
+
+ }
+
+ } else {
+
+/* Let V = ( V1 V2 ) (V2: last K columns) */
+/* where V2 is unit lower triangular. */
+
+ if (lsame_(side, "L")) {
+
+/* Form H * C or H' * C where C = ( C1 ) */
+/* ( C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = iladlc_(k, m, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
+
+/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */
+
+/* W := C2' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[
+ j * work_dim1 + 1], &c__1);
+/* L190: */
+ }
+
+/* W := W * V2' */
+
+ dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &
+ c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
+ work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C1'*V1' */
+
+ i__1 = lastv - *k;
+ dgemm_("Transpose", "Transpose", &lastc, k, &i__1, &c_b14,
+ &c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, &
+ work[work_offset], ldwork);
+ }
+
+/* W := W * T' or W * T */
+
+ dtrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &
+ c_b14, &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - V' * W' */
+
+ if (lastv > *k) {
+
+/* C1 := C1 - V1' * W' */
+
+ i__1 = lastv - *k;
+ dgemm_("Transpose", "Transpose", &i__1, &lastc, k, &c_b25,
+ &v[v_offset], ldv, &work[work_offset], ldwork, &
+ c_b14, &c__[c_offset], ldc);
+ }
+
+/* W := W * V2 */
+
+ dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
+ c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
+ work_offset], ldwork);
+
+/* C2 := C2 - W' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[lastv - *k + j + i__ * c_dim1] -= work[i__ + j *
+ work_dim1];
+/* L200: */
+ }
+/* L210: */
+ }
+
+ } else if (lsame_(side, "R")) {
+
+/* Form C * H or C * H' where C = ( C1 C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = iladlc_(k, n, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
+
+/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */
+
+/* W := C2 */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1,
+ &work[j * work_dim1 + 1], &c__1);
+/* L220: */
+ }
+
+/* W := W * V2' */
+
+ dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &
+ c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
+ work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C1 * V1' */
+
+ i__1 = lastv - *k;
+ dgemm_("No transpose", "Transpose", &lastc, k, &i__1, &
+ c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &
+ c_b14, &work[work_offset], ldwork);
+ }
+
+/* W := W * T or W * T' */
+
+ dtrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b14,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - W * V */
+
+ if (lastv > *k) {
+
+/* C1 := C1 - W * V1 */
+
+ i__1 = lastv - *k;
+ dgemm_("No transpose", "No transpose", &lastc, &i__1, k, &
+ c_b25, &work[work_offset], ldwork, &v[v_offset],
+ ldv, &c_b14, &c__[c_offset], ldc);
+ }
+
+/* W := W * V2 */
+
+ dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
+ c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
+ work_offset], ldwork);
+
+/* C1 := C1 - W */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + (lastv - *k + j) * c_dim1] -= work[i__ + j *
+ work_dim1];
+/* L230: */
+ }
+/* L240: */
+ }
+
+ }
+
+ }
+ }
+
+ return 0;
+
+/* End of DLARFB */
+
+} /* dlarfb_ */
diff --git a/SRC/dlarfg.c b/SRC/dlarfg.c
new file mode 100644
index 0000000..2a052ca
--- /dev/null
+++ b/SRC/dlarfg.c
@@ -0,0 +1,170 @@
+/* dlarfg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlarfg_(integer *n, doublereal *alpha, doublereal *x,
+ integer *incx, doublereal *tau)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer j, knt;
+ doublereal beta;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal xnorm;
+ extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
+ doublereal safmin, rsafmn;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARFG generates a real elementary reflector H of order n, such */
+/* that */
+
+/* H * ( alpha ) = ( beta ), H' * H = I. */
+/* ( x ) ( 0 ) */
+
+/* where alpha and beta are scalars, and x is an (n-1)-element real */
+/* vector. H is represented in the form */
+
+/* H = I - tau * ( 1 ) * ( 1 v' ) , */
+/* ( v ) */
+
+/* where tau is a real scalar and v is a real (n-1)-element */
+/* vector. */
+
+/* If the elements of x are all zero, then tau = 0 and H is taken to be */
+/* the unit matrix. */
+
+/* Otherwise 1 <= tau <= 2. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the elementary reflector. */
+
+/* ALPHA (input/output) DOUBLE PRECISION */
+/* On entry, the value alpha. */
+/* On exit, it is overwritten with the value beta. */
+
+/* X (input/output) DOUBLE PRECISION array, dimension */
+/* (1+(N-2)*abs(INCX)) */
+/* On entry, the vector x. */
+/* On exit, it is overwritten with the vector v. */
+
+/* INCX (input) INTEGER */
+/* The increment between elements of X. INCX > 0. */
+
+/* TAU (output) DOUBLE PRECISION */
+/* The value tau. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --x;
+
+ /* Function Body */
+ if (*n <= 1) {
+ *tau = 0.;
+ return 0;
+ }
+
+ i__1 = *n - 1;
+ xnorm = dnrm2_(&i__1, &x[1], incx);
+
+ if (xnorm == 0.) {
+
+/* H = I */
+
+ *tau = 0.;
+ } else {
+
+/* general case */
+
+ d__1 = dlapy2_(alpha, &xnorm);
+ beta = -d_sign(&d__1, alpha);
+ safmin = dlamch_("S") / dlamch_("E");
+ knt = 0;
+ if (abs(beta) < safmin) {
+
+/* XNORM, BETA may be inaccurate; scale X and recompute them */
+
+ rsafmn = 1. / safmin;
+L10:
+ ++knt;
+ i__1 = *n - 1;
+ dscal_(&i__1, &rsafmn, &x[1], incx);
+ beta *= rsafmn;
+ *alpha *= rsafmn;
+ if (abs(beta) < safmin) {
+ goto L10;
+ }
+
+/* New BETA is at most 1, at least SAFMIN */
+
+ i__1 = *n - 1;
+ xnorm = dnrm2_(&i__1, &x[1], incx);
+ d__1 = dlapy2_(alpha, &xnorm);
+ beta = -d_sign(&d__1, alpha);
+ }
+ *tau = (beta - *alpha) / beta;
+ i__1 = *n - 1;
+ d__1 = 1. / (*alpha - beta);
+ dscal_(&i__1, &d__1, &x[1], incx);
+
+/* If ALPHA is subnormal, it may lose relative accuracy */
+
+ i__1 = knt;
+ for (j = 1; j <= i__1; ++j) {
+ beta *= safmin;
+/* L20: */
+ }
+ *alpha = beta;
+ }
+
+ return 0;
+
+/* End of DLARFG */
+
+} /* dlarfg_ */
diff --git a/SRC/dlarfp.c b/SRC/dlarfp.c
new file mode 100644
index 0000000..234ee7a
--- /dev/null
+++ b/SRC/dlarfp.c
@@ -0,0 +1,192 @@
+/* dlarfp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlarfp_(integer *n, doublereal *alpha, doublereal *x,
+ integer *incx, doublereal *tau)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer j, knt;
+ doublereal beta;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal xnorm;
+ extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
+ doublereal safmin, rsafmn;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARFP generates a real elementary reflector H of order n, such */
+/* that */
+
+/* H * ( alpha ) = ( beta ), H' * H = I. */
+/* ( x ) ( 0 ) */
+
+/* where alpha and beta are scalars, beta is non-negative, and x is */
+/* an (n-1)-element real vector. H is represented in the form */
+
+/* H = I - tau * ( 1 ) * ( 1 v' ) , */
+/* ( v ) */
+
+/* where tau is a real scalar and v is a real (n-1)-element */
+/* vector. */
+
+/* If the elements of x are all zero, then tau = 0 and H is taken to be */
+/* the unit matrix. */
+
+/* Otherwise 1 <= tau <= 2. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the elementary reflector. */
+
+/* ALPHA (input/output) DOUBLE PRECISION */
+/* On entry, the value alpha. */
+/* On exit, it is overwritten with the value beta. */
+
+/* X (input/output) DOUBLE PRECISION array, dimension */
+/* (1+(N-2)*abs(INCX)) */
+/* On entry, the vector x. */
+/* On exit, it is overwritten with the vector v. */
+
+/* INCX (input) INTEGER */
+/* The increment between elements of X. INCX > 0. */
+
+/* TAU (output) DOUBLE PRECISION */
+/* The value tau. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --x;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *tau = 0.;
+ return 0;
+ }
+
+ i__1 = *n - 1;
+ xnorm = dnrm2_(&i__1, &x[1], incx);
+
+ if (xnorm == 0.) {
+
+/* H = [+/-1, 0; I], sign chosen so ALPHA >= 0 */
+
+ if (*alpha >= 0.) {
+/* When TAU.eq.ZERO, the vector is special-cased to be */
+/* all zeros in the application routines. We do not need */
+/* to clear it. */
+ *tau = 0.;
+ } else {
+/* However, the application routines rely on explicit */
+/* zero checks when TAU.ne.ZERO, and we must clear X. */
+ *tau = 2.;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ x[(j - 1) * *incx + 1] = 0.;
+ }
+ *alpha = -(*alpha);
+ }
+ } else {
+
+/* general case */
+
+ d__1 = dlapy2_(alpha, &xnorm);
+ beta = d_sign(&d__1, alpha);
+ safmin = dlamch_("S") / dlamch_("E");
+ knt = 0;
+ if (abs(beta) < safmin) {
+
+/* XNORM, BETA may be inaccurate; scale X and recompute them */
+
+ rsafmn = 1. / safmin;
+L10:
+ ++knt;
+ i__1 = *n - 1;
+ dscal_(&i__1, &rsafmn, &x[1], incx);
+ beta *= rsafmn;
+ *alpha *= rsafmn;
+ if (abs(beta) < safmin) {
+ goto L10;
+ }
+
+/* New BETA is at most 1, at least SAFMIN */
+
+ i__1 = *n - 1;
+ xnorm = dnrm2_(&i__1, &x[1], incx);
+ d__1 = dlapy2_(alpha, &xnorm);
+ beta = d_sign(&d__1, alpha);
+ }
+ *alpha += beta;
+ if (beta < 0.) {
+ beta = -beta;
+ *tau = -(*alpha) / beta;
+ } else {
+ *alpha = xnorm * (xnorm / *alpha);
+ *tau = *alpha / beta;
+ *alpha = -(*alpha);
+ }
+ i__1 = *n - 1;
+ d__1 = 1. / *alpha;
+ dscal_(&i__1, &d__1, &x[1], incx);
+
+/* If BETA is subnormal, it may lose relative accuracy */
+
+ i__1 = knt;
+ for (j = 1; j <= i__1; ++j) {
+ beta *= safmin;
+/* L20: */
+ }
+ *alpha = beta;
+ }
+
+ return 0;
+
+/* End of DLARFP */
+
+} /* dlarfp_ */
diff --git a/SRC/dlarft.c b/SRC/dlarft.c
new file mode 100644
index 0000000..0d4951c
--- /dev/null
+++ b/SRC/dlarft.c
@@ -0,0 +1,325 @@
+/* dlarft.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b8 = 0.;
+
+/* Subroutine */ int dlarft_(char *direct, char *storev, integer *n, integer *
+ k, doublereal *v, integer *ldv, doublereal *tau, doublereal *t,
+ integer *ldt)
+{
+ /* System generated locals */
+ integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, j, prevlastv;
+ doublereal vii;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ integer lastv;
+ extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARFT forms the triangular factor T of a real block reflector H */
+/* of order n, which is defined as a product of k elementary reflectors. */
+
+/* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */
+
+/* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */
+
+/* If STOREV = 'C', the vector which defines the elementary reflector */
+/* H(i) is stored in the i-th column of the array V, and */
+
+/* H = I - V * T * V' */
+
+/* If STOREV = 'R', the vector which defines the elementary reflector */
+/* H(i) is stored in the i-th row of the array V, and */
+
+/* H = I - V' * T * V */
+
+/* Arguments */
+/* ========= */
+
+/* DIRECT (input) CHARACTER*1 */
+/* Specifies the order in which the elementary reflectors are */
+/* multiplied to form the block reflector: */
+/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */
+/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
+
+/* STOREV (input) CHARACTER*1 */
+/* Specifies how the vectors which define the elementary */
+/* reflectors are stored (see also Further Details): */
+/* = 'C': columnwise */
+/* = 'R': rowwise */
+
+/* N (input) INTEGER */
+/* The order of the block reflector H. N >= 0. */
+
+/* K (input) INTEGER */
+/* The order of the triangular factor T (= the number of */
+/* elementary reflectors). K >= 1. */
+
+/* V (input/output) DOUBLE PRECISION array, dimension */
+/* (LDV,K) if STOREV = 'C' */
+/* (LDV,N) if STOREV = 'R' */
+/* The matrix V. See further details. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. */
+/* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i). */
+
+/* T (output) DOUBLE PRECISION array, dimension (LDT,K) */
+/* The k by k triangular factor T of the block reflector. */
+/* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */
+/* lower triangular. The rest of the array is not used. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= K. */
+
+/* Further Details */
+/* =============== */
+
+/* The shape of the matrix V and the storage of the vectors which define */
+/* the H(i) is best illustrated by the following example with n = 5 and */
+/* k = 3. The elements equal to 1 are not stored; the corresponding */
+/* array elements are modified but restored on exit. The rest of the */
+/* array is not used. */
+
+/* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */
+
+/* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */
+/* ( v1 1 ) ( 1 v2 v2 v2 ) */
+/* ( v1 v2 1 ) ( 1 v3 v3 ) */
+/* ( v1 v2 v3 ) */
+/* ( v1 v2 v3 ) */
+
+/* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */
+
+/* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */
+/* ( v1 v2 v3 ) ( v2 v2 v2 1 ) */
+/* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */
+/* ( 1 v3 ) */
+/* ( 1 ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --tau;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+
+ /* Function Body */
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (lsame_(direct, "F")) {
+ prevlastv = *n;
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ prevlastv = max(i__,prevlastv);
+ if (tau[i__] == 0.) {
+
+/* H(i) = I */
+
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ t[j + i__ * t_dim1] = 0.;
+/* L10: */
+ }
+ } else {
+
+/* general case */
+
+ vii = v[i__ + i__ * v_dim1];
+ v[i__ + i__ * v_dim1] = 1.;
+ if (lsame_(storev, "C")) {
+/* Skip any trailing zeros. */
+ i__2 = i__ + 1;
+ for (lastv = *n; lastv >= i__2; --lastv) {
+ if (v[lastv + i__ * v_dim1] != 0.) {
+ break;
+ }
+ }
+ j = min(lastv,prevlastv);
+
+/* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i) */
+
+ i__2 = j - i__ + 1;
+ i__3 = i__ - 1;
+ d__1 = -tau[i__];
+ dgemv_("Transpose", &i__2, &i__3, &d__1, &v[i__ + v_dim1],
+ ldv, &v[i__ + i__ * v_dim1], &c__1, &c_b8, &t[
+ i__ * t_dim1 + 1], &c__1);
+ } else {
+/* Skip any trailing zeros. */
+ i__2 = i__ + 1;
+ for (lastv = *n; lastv >= i__2; --lastv) {
+ if (v[i__ + lastv * v_dim1] != 0.) {
+ break;
+ }
+ }
+ j = min(lastv,prevlastv);
+
+/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)' */
+
+ i__2 = i__ - 1;
+ i__3 = j - i__ + 1;
+ d__1 = -tau[i__];
+ dgemv_("No transpose", &i__2, &i__3, &d__1, &v[i__ *
+ v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, &
+ c_b8, &t[i__ * t_dim1 + 1], &c__1);
+ }
+ v[i__ + i__ * v_dim1] = vii;
+
+/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */
+
+ i__2 = i__ - 1;
+ dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[
+ t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1);
+ t[i__ + i__ * t_dim1] = tau[i__];
+ if (i__ > 1) {
+ prevlastv = max(prevlastv,lastv);
+ } else {
+ prevlastv = lastv;
+ }
+ }
+/* L20: */
+ }
+ } else {
+ prevlastv = 1;
+ for (i__ = *k; i__ >= 1; --i__) {
+ if (tau[i__] == 0.) {
+
+/* H(i) = I */
+
+ i__1 = *k;
+ for (j = i__; j <= i__1; ++j) {
+ t[j + i__ * t_dim1] = 0.;
+/* L30: */
+ }
+ } else {
+
+/* general case */
+
+ if (i__ < *k) {
+ if (lsame_(storev, "C")) {
+ vii = v[*n - *k + i__ + i__ * v_dim1];
+ v[*n - *k + i__ + i__ * v_dim1] = 1.;
+/* Skip any leading zeros. */
+ i__1 = i__ - 1;
+ for (lastv = 1; lastv <= i__1; ++lastv) {
+ if (v[lastv + i__ * v_dim1] != 0.) {
+ break;
+ }
+ }
+ j = max(lastv,prevlastv);
+
+/* T(i+1:k,i) := */
+/* - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i) */
+
+ i__1 = *n - *k + i__ - j + 1;
+ i__2 = *k - i__;
+ d__1 = -tau[i__];
+ dgemv_("Transpose", &i__1, &i__2, &d__1, &v[j + (i__
+ + 1) * v_dim1], ldv, &v[j + i__ * v_dim1], &
+ c__1, &c_b8, &t[i__ + 1 + i__ * t_dim1], &
+ c__1);
+ v[*n - *k + i__ + i__ * v_dim1] = vii;
+ } else {
+ vii = v[i__ + (*n - *k + i__) * v_dim1];
+ v[i__ + (*n - *k + i__) * v_dim1] = 1.;
+/* Skip any leading zeros. */
+ i__1 = i__ - 1;
+ for (lastv = 1; lastv <= i__1; ++lastv) {
+ if (v[i__ + lastv * v_dim1] != 0.) {
+ break;
+ }
+ }
+ j = max(lastv,prevlastv);
+
+/* T(i+1:k,i) := */
+/* - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)' */
+
+ i__1 = *k - i__;
+ i__2 = *n - *k + i__ - j + 1;
+ d__1 = -tau[i__];
+ dgemv_("No transpose", &i__1, &i__2, &d__1, &v[i__ +
+ 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1],
+ ldv, &c_b8, &t[i__ + 1 + i__ * t_dim1], &c__1);
+ v[i__ + (*n - *k + i__) * v_dim1] = vii;
+ }
+
+/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */
+
+ i__1 = *k - i__;
+ dtrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__
+ + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ *
+ t_dim1], &c__1)
+ ;
+ if (i__ > 1) {
+ prevlastv = min(prevlastv,lastv);
+ } else {
+ prevlastv = lastv;
+ }
+ }
+ t[i__ + i__ * t_dim1] = tau[i__];
+ }
+/* L40: */
+ }
+ }
+ return 0;
+
+/* End of DLARFT */
+
+} /* dlarft_ */
diff --git a/SRC/dlarfx.c b/SRC/dlarfx.c
new file mode 100644
index 0000000..37a2023
--- /dev/null
+++ b/SRC/dlarfx.c
@@ -0,0 +1,730 @@
+/* dlarfx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dlarfx_(char *side, integer *m, integer *n, doublereal *
+ v, doublereal *tau, doublereal *c__, integer *ldc, doublereal *work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1;
+
+ /* Local variables */
+ integer j;
+ doublereal t1, t2, t3, t4, t5, t6, t7, t8, t9, v1, v2, v3, v4, v5, v6, v7,
+ v8, v9, t10, v10, sum;
+ extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *);
+ extern logical lsame_(char *, char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARFX applies a real elementary reflector H to a real m by n */
+/* matrix C, from either the left or the right. H is represented in the */
+/* form */
+
+/* H = I - tau * v * v' */
+
+/* where tau is a real scalar and v is a real vector. */
+
+/* If tau = 0, then H is taken to be the unit matrix */
+
+/* This version uses inline code if H has order < 11. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': form H * C */
+/* = 'R': form C * H */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* V (input) DOUBLE PRECISION array, dimension (M) if SIDE = 'L' */
+/* or (N) if SIDE = 'R' */
+/* The vector v in the representation of H. */
+
+/* TAU (input) DOUBLE PRECISION */
+/* The value tau in the representation of H. */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/* On entry, the m by n matrix C. */
+/* On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
+/* or C * H if SIDE = 'R'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDA >= (1,M). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (N) if SIDE = 'L' */
+/* or (M) if SIDE = 'R' */
+/* WORK is not referenced if H has order < 11. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ if (*tau == 0.) {
+ return 0;
+ }
+ if (lsame_(side, "L")) {
+
+/* Form H * C, where H has order m. */
+
+ switch (*m) {
+ case 1: goto L10;
+ case 2: goto L30;
+ case 3: goto L50;
+ case 4: goto L70;
+ case 5: goto L90;
+ case 6: goto L110;
+ case 7: goto L130;
+ case 8: goto L150;
+ case 9: goto L170;
+ case 10: goto L190;
+ }
+
+/* Code for general M */
+
+ dlarf_(side, m, n, &v[1], &c__1, tau, &c__[c_offset], ldc, &work[1]);
+ goto L410;
+L10:
+
+/* Special code for 1 x 1 Householder */
+
+ t1 = 1. - *tau * v[1] * v[1];
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j * c_dim1 + 1] = t1 * c__[j * c_dim1 + 1];
+/* L20: */
+ }
+ goto L410;
+L30:
+
+/* Special code for 2 x 2 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2];
+ c__[j * c_dim1 + 1] -= sum * t1;
+ c__[j * c_dim1 + 2] -= sum * t2;
+/* L40: */
+ }
+ goto L410;
+L50:
+
+/* Special code for 3 x 3 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
+ c__[j * c_dim1 + 3];
+ c__[j * c_dim1 + 1] -= sum * t1;
+ c__[j * c_dim1 + 2] -= sum * t2;
+ c__[j * c_dim1 + 3] -= sum * t3;
+/* L60: */
+ }
+ goto L410;
+L70:
+
+/* Special code for 4 x 4 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
+ c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4];
+ c__[j * c_dim1 + 1] -= sum * t1;
+ c__[j * c_dim1 + 2] -= sum * t2;
+ c__[j * c_dim1 + 3] -= sum * t3;
+ c__[j * c_dim1 + 4] -= sum * t4;
+/* L80: */
+ }
+ goto L410;
+L90:
+
+/* Special code for 5 x 5 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
+ c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
+ j * c_dim1 + 5];
+ c__[j * c_dim1 + 1] -= sum * t1;
+ c__[j * c_dim1 + 2] -= sum * t2;
+ c__[j * c_dim1 + 3] -= sum * t3;
+ c__[j * c_dim1 + 4] -= sum * t4;
+ c__[j * c_dim1 + 5] -= sum * t5;
+/* L100: */
+ }
+ goto L410;
+L110:
+
+/* Special code for 6 x 6 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ v6 = v[6];
+ t6 = *tau * v6;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
+ c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
+ j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6];
+ c__[j * c_dim1 + 1] -= sum * t1;
+ c__[j * c_dim1 + 2] -= sum * t2;
+ c__[j * c_dim1 + 3] -= sum * t3;
+ c__[j * c_dim1 + 4] -= sum * t4;
+ c__[j * c_dim1 + 5] -= sum * t5;
+ c__[j * c_dim1 + 6] -= sum * t6;
+/* L120: */
+ }
+ goto L410;
+L130:
+
+/* Special code for 7 x 7 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ v6 = v[6];
+ t6 = *tau * v6;
+ v7 = v[7];
+ t7 = *tau * v7;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
+ c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
+ j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j *
+ c_dim1 + 7];
+ c__[j * c_dim1 + 1] -= sum * t1;
+ c__[j * c_dim1 + 2] -= sum * t2;
+ c__[j * c_dim1 + 3] -= sum * t3;
+ c__[j * c_dim1 + 4] -= sum * t4;
+ c__[j * c_dim1 + 5] -= sum * t5;
+ c__[j * c_dim1 + 6] -= sum * t6;
+ c__[j * c_dim1 + 7] -= sum * t7;
+/* L140: */
+ }
+ goto L410;
+L150:
+
+/* Special code for 8 x 8 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ v6 = v[6];
+ t6 = *tau * v6;
+ v7 = v[7];
+ t7 = *tau * v7;
+ v8 = v[8];
+ t8 = *tau * v8;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
+ c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
+ j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j *
+ c_dim1 + 7] + v8 * c__[j * c_dim1 + 8];
+ c__[j * c_dim1 + 1] -= sum * t1;
+ c__[j * c_dim1 + 2] -= sum * t2;
+ c__[j * c_dim1 + 3] -= sum * t3;
+ c__[j * c_dim1 + 4] -= sum * t4;
+ c__[j * c_dim1 + 5] -= sum * t5;
+ c__[j * c_dim1 + 6] -= sum * t6;
+ c__[j * c_dim1 + 7] -= sum * t7;
+ c__[j * c_dim1 + 8] -= sum * t8;
+/* L160: */
+ }
+ goto L410;
+L170:
+
+/* Special code for 9 x 9 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ v6 = v[6];
+ t6 = *tau * v6;
+ v7 = v[7];
+ t7 = *tau * v7;
+ v8 = v[8];
+ t8 = *tau * v8;
+ v9 = v[9];
+ t9 = *tau * v9;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
+ c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
+ j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j *
+ c_dim1 + 7] + v8 * c__[j * c_dim1 + 8] + v9 * c__[j *
+ c_dim1 + 9];
+ c__[j * c_dim1 + 1] -= sum * t1;
+ c__[j * c_dim1 + 2] -= sum * t2;
+ c__[j * c_dim1 + 3] -= sum * t3;
+ c__[j * c_dim1 + 4] -= sum * t4;
+ c__[j * c_dim1 + 5] -= sum * t5;
+ c__[j * c_dim1 + 6] -= sum * t6;
+ c__[j * c_dim1 + 7] -= sum * t7;
+ c__[j * c_dim1 + 8] -= sum * t8;
+ c__[j * c_dim1 + 9] -= sum * t9;
+/* L180: */
+ }
+ goto L410;
+L190:
+
+/* Special code for 10 x 10 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ v6 = v[6];
+ t6 = *tau * v6;
+ v7 = v[7];
+ t7 = *tau * v7;
+ v8 = v[8];
+ t8 = *tau * v8;
+ v9 = v[9];
+ t9 = *tau * v9;
+ v10 = v[10];
+ t10 = *tau * v10;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
+ c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
+ j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j *
+ c_dim1 + 7] + v8 * c__[j * c_dim1 + 8] + v9 * c__[j *
+ c_dim1 + 9] + v10 * c__[j * c_dim1 + 10];
+ c__[j * c_dim1 + 1] -= sum * t1;
+ c__[j * c_dim1 + 2] -= sum * t2;
+ c__[j * c_dim1 + 3] -= sum * t3;
+ c__[j * c_dim1 + 4] -= sum * t4;
+ c__[j * c_dim1 + 5] -= sum * t5;
+ c__[j * c_dim1 + 6] -= sum * t6;
+ c__[j * c_dim1 + 7] -= sum * t7;
+ c__[j * c_dim1 + 8] -= sum * t8;
+ c__[j * c_dim1 + 9] -= sum * t9;
+ c__[j * c_dim1 + 10] -= sum * t10;
+/* L200: */
+ }
+ goto L410;
+ } else {
+
+/* Form C * H, where H has order n. */
+
+ switch (*n) {
+ case 1: goto L210;
+ case 2: goto L230;
+ case 3: goto L250;
+ case 4: goto L270;
+ case 5: goto L290;
+ case 6: goto L310;
+ case 7: goto L330;
+ case 8: goto L350;
+ case 9: goto L370;
+ case 10: goto L390;
+ }
+
+/* Code for general N */
+
+ dlarf_(side, m, n, &v[1], &c__1, tau, &c__[c_offset], ldc, &work[1]);
+ goto L410;
+L210:
+
+/* Special code for 1 x 1 Householder */
+
+ t1 = 1. - *tau * v[1] * v[1];
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j + c_dim1] = t1 * c__[j + c_dim1];
+/* L220: */
+ }
+ goto L410;
+L230:
+
+/* Special code for 2 x 2 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)];
+ c__[j + c_dim1] -= sum * t1;
+ c__[j + (c_dim1 << 1)] -= sum * t2;
+/* L240: */
+ }
+ goto L410;
+L250:
+
+/* Special code for 3 x 3 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
+ c__[j + c_dim1 * 3];
+ c__[j + c_dim1] -= sum * t1;
+ c__[j + (c_dim1 << 1)] -= sum * t2;
+ c__[j + c_dim1 * 3] -= sum * t3;
+/* L260: */
+ }
+ goto L410;
+L270:
+
+/* Special code for 4 x 4 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
+ c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)];
+ c__[j + c_dim1] -= sum * t1;
+ c__[j + (c_dim1 << 1)] -= sum * t2;
+ c__[j + c_dim1 * 3] -= sum * t3;
+ c__[j + (c_dim1 << 2)] -= sum * t4;
+/* L280: */
+ }
+ goto L410;
+L290:
+
+/* Special code for 5 x 5 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
+ c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
+ c__[j + c_dim1 * 5];
+ c__[j + c_dim1] -= sum * t1;
+ c__[j + (c_dim1 << 1)] -= sum * t2;
+ c__[j + c_dim1 * 3] -= sum * t3;
+ c__[j + (c_dim1 << 2)] -= sum * t4;
+ c__[j + c_dim1 * 5] -= sum * t5;
+/* L300: */
+ }
+ goto L410;
+L310:
+
+/* Special code for 6 x 6 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ v6 = v[6];
+ t6 = *tau * v6;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
+ c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
+ c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6];
+ c__[j + c_dim1] -= sum * t1;
+ c__[j + (c_dim1 << 1)] -= sum * t2;
+ c__[j + c_dim1 * 3] -= sum * t3;
+ c__[j + (c_dim1 << 2)] -= sum * t4;
+ c__[j + c_dim1 * 5] -= sum * t5;
+ c__[j + c_dim1 * 6] -= sum * t6;
+/* L320: */
+ }
+ goto L410;
+L330:
+
+/* Special code for 7 x 7 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ v6 = v[6];
+ t6 = *tau * v6;
+ v7 = v[7];
+ t7 = *tau * v7;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
+ c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
+ c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[
+ j + c_dim1 * 7];
+ c__[j + c_dim1] -= sum * t1;
+ c__[j + (c_dim1 << 1)] -= sum * t2;
+ c__[j + c_dim1 * 3] -= sum * t3;
+ c__[j + (c_dim1 << 2)] -= sum * t4;
+ c__[j + c_dim1 * 5] -= sum * t5;
+ c__[j + c_dim1 * 6] -= sum * t6;
+ c__[j + c_dim1 * 7] -= sum * t7;
+/* L340: */
+ }
+ goto L410;
+L350:
+
+/* Special code for 8 x 8 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ v6 = v[6];
+ t6 = *tau * v6;
+ v7 = v[7];
+ t7 = *tau * v7;
+ v8 = v[8];
+ t8 = *tau * v8;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
+ c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
+ c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[
+ j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)];
+ c__[j + c_dim1] -= sum * t1;
+ c__[j + (c_dim1 << 1)] -= sum * t2;
+ c__[j + c_dim1 * 3] -= sum * t3;
+ c__[j + (c_dim1 << 2)] -= sum * t4;
+ c__[j + c_dim1 * 5] -= sum * t5;
+ c__[j + c_dim1 * 6] -= sum * t6;
+ c__[j + c_dim1 * 7] -= sum * t7;
+ c__[j + (c_dim1 << 3)] -= sum * t8;
+/* L360: */
+ }
+ goto L410;
+L370:
+
+/* Special code for 9 x 9 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ v6 = v[6];
+ t6 = *tau * v6;
+ v7 = v[7];
+ t7 = *tau * v7;
+ v8 = v[8];
+ t8 = *tau * v8;
+ v9 = v[9];
+ t9 = *tau * v9;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
+ c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
+ c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[
+ j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)] + v9 * c__[
+ j + c_dim1 * 9];
+ c__[j + c_dim1] -= sum * t1;
+ c__[j + (c_dim1 << 1)] -= sum * t2;
+ c__[j + c_dim1 * 3] -= sum * t3;
+ c__[j + (c_dim1 << 2)] -= sum * t4;
+ c__[j + c_dim1 * 5] -= sum * t5;
+ c__[j + c_dim1 * 6] -= sum * t6;
+ c__[j + c_dim1 * 7] -= sum * t7;
+ c__[j + (c_dim1 << 3)] -= sum * t8;
+ c__[j + c_dim1 * 9] -= sum * t9;
+/* L380: */
+ }
+ goto L410;
+L390:
+
+/* Special code for 10 x 10 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ v6 = v[6];
+ t6 = *tau * v6;
+ v7 = v[7];
+ t7 = *tau * v7;
+ v8 = v[8];
+ t8 = *tau * v8;
+ v9 = v[9];
+ t9 = *tau * v9;
+ v10 = v[10];
+ t10 = *tau * v10;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
+ c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
+ c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[
+ j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)] + v9 * c__[
+ j + c_dim1 * 9] + v10 * c__[j + c_dim1 * 10];
+ c__[j + c_dim1] -= sum * t1;
+ c__[j + (c_dim1 << 1)] -= sum * t2;
+ c__[j + c_dim1 * 3] -= sum * t3;
+ c__[j + (c_dim1 << 2)] -= sum * t4;
+ c__[j + c_dim1 * 5] -= sum * t5;
+ c__[j + c_dim1 * 6] -= sum * t6;
+ c__[j + c_dim1 * 7] -= sum * t7;
+ c__[j + (c_dim1 << 3)] -= sum * t8;
+ c__[j + c_dim1 * 9] -= sum * t9;
+ c__[j + c_dim1 * 10] -= sum * t10;
+/* L400: */
+ }
+ goto L410;
+ }
+L410:
+ return 0;
+
+/* End of DLARFX */
+
+} /* dlarfx_ */
diff --git a/SRC/dlargv.c b/SRC/dlargv.c
new file mode 100644
index 0000000..dee0e67
--- /dev/null
+++ b/SRC/dlargv.c
@@ -0,0 +1,130 @@
+/* dlargv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlargv_(integer *n, doublereal *x, integer *incx,
+ doublereal *y, integer *incy, doublereal *c__, integer *incc)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal f, g;
+ integer i__;
+ doublereal t;
+ integer ic, ix, iy;
+ doublereal tt;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARGV generates a vector of real plane rotations, determined by */
+/* elements of the real vectors x and y. For i = 1,2,...,n */
+
+/* ( c(i) s(i) ) ( x(i) ) = ( a(i) ) */
+/* ( -s(i) c(i) ) ( y(i) ) = ( 0 ) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of plane rotations to be generated. */
+
+/* X (input/output) DOUBLE PRECISION array, */
+/* dimension (1+(N-1)*INCX) */
+/* On entry, the vector x. */
+/* On exit, x(i) is overwritten by a(i), for i = 1,...,n. */
+
+/* INCX (input) INTEGER */
+/* The increment between elements of X. INCX > 0. */
+
+/* Y (input/output) DOUBLE PRECISION array, */
+/* dimension (1+(N-1)*INCY) */
+/* On entry, the vector y. */
+/* On exit, the sines of the plane rotations. */
+
+/* INCY (input) INTEGER */
+/* The increment between elements of Y. INCY > 0. */
+
+/* C (output) DOUBLE PRECISION array, dimension (1+(N-1)*INCC) */
+/* The cosines of the plane rotations. */
+
+/* INCC (input) INTEGER */
+/* The increment between elements of C. INCC > 0. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --c__;
+ --y;
+ --x;
+
+ /* Function Body */
+ ix = 1;
+ iy = 1;
+ ic = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ f = x[ix];
+ g = y[iy];
+ if (g == 0.) {
+ c__[ic] = 1.;
+ } else if (f == 0.) {
+ c__[ic] = 0.;
+ y[iy] = 1.;
+ x[ix] = g;
+ } else if (abs(f) > abs(g)) {
+ t = g / f;
+ tt = sqrt(t * t + 1.);
+ c__[ic] = 1. / tt;
+ y[iy] = t * c__[ic];
+ x[ix] = f * tt;
+ } else {
+ t = f / g;
+ tt = sqrt(t * t + 1.);
+ y[iy] = 1. / tt;
+ c__[ic] = t * y[iy];
+ x[ix] = g * tt;
+ }
+ ic += *incc;
+ iy += *incy;
+ ix += *incx;
+/* L10: */
+ }
+ return 0;
+
+/* End of DLARGV */
+
+} /* dlargv_ */
diff --git a/SRC/dlarnv.c b/SRC/dlarnv.c
new file mode 100644
index 0000000..a911853
--- /dev/null
+++ b/SRC/dlarnv.c
@@ -0,0 +1,146 @@
+/* dlarnv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlarnv_(integer *idist, integer *iseed, integer *n,
+ doublereal *x)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+
+ /* Builtin functions */
+ double log(doublereal), sqrt(doublereal), cos(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal u[128];
+ integer il, iv, il2;
+ extern /* Subroutine */ int dlaruv_(integer *, integer *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARNV returns a vector of n random real numbers from a uniform or */
+/* normal distribution. */
+
+/* Arguments */
+/* ========= */
+
+/* IDIST (input) INTEGER */
+/* Specifies the distribution of the random numbers: */
+/* = 1: uniform (0,1) */
+/* = 2: uniform (-1,1) */
+/* = 3: normal (0,1) */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* N (input) INTEGER */
+/* The number of random numbers to be generated. */
+
+/* X (output) DOUBLE PRECISION array, dimension (N) */
+/* The generated random numbers. */
+
+/* Further Details */
+/* =============== */
+
+/* This routine calls the auxiliary routine DLARUV to generate random */
+/* real numbers from a uniform (0,1) distribution, in batches of up to */
+/* 128 using vectorisable code. The Box-Muller method is used to */
+/* transform numbers from a uniform to a normal distribution. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --x;
+ --iseed;
+
+ /* Function Body */
+ i__1 = *n;
+ for (iv = 1; iv <= i__1; iv += 64) {
+/* Computing MIN */
+ i__2 = 64, i__3 = *n - iv + 1;
+ il = min(i__2,i__3);
+ if (*idist == 3) {
+ il2 = il << 1;
+ } else {
+ il2 = il;
+ }
+
+/* Call DLARUV to generate IL2 numbers from a uniform (0,1) */
+/* distribution (IL2 <= LV) */
+
+ dlaruv_(&iseed[1], &il2, u);
+
+ if (*idist == 1) {
+
+/* Copy generated numbers */
+
+ i__2 = il;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[iv + i__ - 1] = u[i__ - 1];
+/* L10: */
+ }
+ } else if (*idist == 2) {
+
+/* Convert generated numbers to uniform (-1,1) distribution */
+
+ i__2 = il;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[iv + i__ - 1] = u[i__ - 1] * 2. - 1.;
+/* L20: */
+ }
+ } else if (*idist == 3) {
+
+/* Convert generated numbers to normal (0,1) distribution */
+
+ i__2 = il;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[iv + i__ - 1] = sqrt(log(u[(i__ << 1) - 2]) * -2.) * cos(u[(
+ i__ << 1) - 1] * 6.2831853071795864769252867663);
+/* L30: */
+ }
+ }
+/* L40: */
+ }
+ return 0;
+
+/* End of DLARNV */
+
+} /* dlarnv_ */
diff --git a/SRC/dlarra.c b/SRC/dlarra.c
new file mode 100644
index 0000000..4571662
--- /dev/null
+++ b/SRC/dlarra.c
@@ -0,0 +1,156 @@
+/* dlarra.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlarra_(integer *n, doublereal *d__, doublereal *e,
+ doublereal *e2, doublereal *spltol, doublereal *tnrm, integer *nsplit,
+ integer *isplit, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal tmp1, eabs;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Compute the splitting points with threshold SPLTOL. */
+/* DLARRA sets any "small" off-diagonal elements to zero. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N > 0. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the N diagonal elements of the tridiagonal */
+/* matrix T. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the first (N-1) entries contain the subdiagonal */
+/* elements of the tridiagonal matrix T; E(N) need not be set. */
+/* On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT, */
+/* are set to zero, the other entries of E are untouched. */
+
+/* E2 (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the first (N-1) entries contain the SQUARES of the */
+/* subdiagonal elements of the tridiagonal matrix T; */
+/* E2(N) need not be set. */
+/* On exit, the entries E2( ISPLIT( I ) ), */
+/* 1 <= I <= NSPLIT, have been set to zero */
+
+/* SPLTOL (input) DOUBLE PRECISION */
+/* The threshold for splitting. Two criteria can be used: */
+/* SPLTOL<0 : criterion based on absolute off-diagonal value */
+/* SPLTOL>0 : criterion that preserves relative accuracy */
+
+/* TNRM (input) DOUBLE PRECISION */
+/* The norm of the matrix. */
+
+/* NSPLIT (output) INTEGER */
+/* The number of blocks T splits into. 1 <= NSPLIT <= N. */
+
+/* ISPLIT (output) INTEGER array, dimension (N) */
+/* The splitting points, at which T breaks up into blocks. */
+/* The first block consists of rows/columns 1 to ISPLIT(1), */
+/* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */
+/* etc., and the NSPLIT-th consists of rows/columns */
+/* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */
+
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --isplit;
+ --e2;
+ --e;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+/* Compute splitting points */
+ *nsplit = 1;
+ if (*spltol < 0.) {
+/* Criterion based on absolute off-diagonal value */
+ tmp1 = abs(*spltol) * *tnrm;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ eabs = (d__1 = e[i__], abs(d__1));
+ if (eabs <= tmp1) {
+ e[i__] = 0.;
+ e2[i__] = 0.;
+ isplit[*nsplit] = i__;
+ ++(*nsplit);
+ }
+/* L9: */
+ }
+ } else {
+/* Criterion that guarantees relative accuracy */
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ eabs = (d__1 = e[i__], abs(d__1));
+ if (eabs <= *spltol * sqrt((d__1 = d__[i__], abs(d__1))) * sqrt((
+ d__2 = d__[i__ + 1], abs(d__2)))) {
+ e[i__] = 0.;
+ e2[i__] = 0.;
+ isplit[*nsplit] = i__;
+ ++(*nsplit);
+ }
+/* L10: */
+ }
+ }
+ isplit[*nsplit] = *n;
+ return 0;
+
+/* End of DLARRA */
+
+} /* dlarra_ */
diff --git a/SRC/dlarrb.c b/SRC/dlarrb.c
new file mode 100644
index 0000000..31077e3
--- /dev/null
+++ b/SRC/dlarrb.c
@@ -0,0 +1,350 @@
+/* dlarrb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlarrb_(integer *n, doublereal *d__, doublereal *lld,
+ integer *ifirst, integer *ilast, doublereal *rtol1, doublereal *rtol2,
+ integer *offset, doublereal *w, doublereal *wgap, doublereal *werr,
+ doublereal *work, integer *iwork, doublereal *pivmin, doublereal *
+ spdiam, integer *twist, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double log(doublereal);
+
+ /* Local variables */
+ integer i__, k, r__, i1, ii, ip;
+ doublereal gap, mid, tmp, back, lgap, rgap, left;
+ integer iter, nint, prev, next;
+ doublereal cvrgd, right, width;
+ extern integer dlaneg_(integer *, doublereal *, doublereal *, doublereal *
+, doublereal *, integer *);
+ integer negcnt;
+ doublereal mnwdth;
+ integer olnint, maxitr;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Given the relatively robust representation(RRR) L D L^T, DLARRB */
+/* does "limited" bisection to refine the eigenvalues of L D L^T, */
+/* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial */
+/* guesses for these eigenvalues are input in W, the corresponding estimate */
+/* of the error in these guesses and their gaps are input in WERR */
+/* and WGAP, respectively. During bisection, intervals */
+/* [left, right] are maintained by storing their mid-points and */
+/* semi-widths in the arrays W and WERR respectively. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The N diagonal elements of the diagonal matrix D. */
+
+/* LLD (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (N-1) elements L(i)*L(i)*D(i). */
+
+/* IFIRST (input) INTEGER */
+/* The index of the first eigenvalue to be computed. */
+
+/* ILAST (input) INTEGER */
+/* The index of the last eigenvalue to be computed. */
+
+/* RTOL1 (input) DOUBLE PRECISION */
+/* RTOL2 (input) DOUBLE PRECISION */
+/* Tolerance for the convergence of the bisection intervals. */
+/* An interval [LEFT,RIGHT] has converged if */
+/* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */
+/* where GAP is the (estimated) distance to the nearest */
+/* eigenvalue. */
+
+/* OFFSET (input) INTEGER */
+/* Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET */
+/* through ILAST-OFFSET elements of these arrays are to be used. */
+
+/* W (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are */
+/* estimates of the eigenvalues of L D L^T indexed IFIRST throug */
+/* ILAST. */
+/* On output, these estimates are refined. */
+
+/* WGAP (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* On input, the (estimated) gaps between consecutive */
+/* eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between */
+/* eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST */
+/* then WGAP(IFIRST-OFFSET) must be set to ZERO. */
+/* On output, these gaps are refined. */
+
+/* WERR (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are */
+/* the errors in the estimates of the corresponding elements in W. */
+/* On output, these errors are refined. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+/* Workspace. */
+
+/* IWORK (workspace) INTEGER array, dimension (2*N) */
+/* Workspace. */
+
+/* PIVMIN (input) DOUBLE PRECISION */
+/* The minimum pivot in the Sturm sequence. */
+
+/* SPDIAM (input) DOUBLE PRECISION */
+/* The spectral diameter of the matrix. */
+
+/* TWIST (input) INTEGER */
+/* The twist index for the twisted factorization that is used */
+/* for the negcount. */
+/* TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T */
+/* TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T */
+/* TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r) */
+
+/* INFO (output) INTEGER */
+/* Error flag. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --werr;
+ --wgap;
+ --w;
+ --lld;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+
+ maxitr = (integer) ((log(*spdiam + *pivmin) - log(*pivmin)) / log(2.)) +
+ 2;
+ mnwdth = *pivmin * 2.;
+
+ r__ = *twist;
+ if (r__ < 1 || r__ > *n) {
+ r__ = *n;
+ }
+
+/* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ]. */
+/* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while */
+/* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 ) */
+/* for an unconverged interval is set to the index of the next unconverged */
+/* interval, and is -1 or 0 for a converged interval. Thus a linked */
+/* list of unconverged intervals is set up. */
+
+ i1 = *ifirst;
+/* The number of unconverged intervals */
+ nint = 0;
+/* The last unconverged interval found */
+ prev = 0;
+ rgap = wgap[i1 - *offset];
+ i__1 = *ilast;
+ for (i__ = i1; i__ <= i__1; ++i__) {
+ k = i__ << 1;
+ ii = i__ - *offset;
+ left = w[ii] - werr[ii];
+ right = w[ii] + werr[ii];
+ lgap = rgap;
+ rgap = wgap[ii];
+ gap = min(lgap,rgap);
+/* Make sure that [LEFT,RIGHT] contains the desired eigenvalue */
+/* Compute negcount from dstqds facto L+D+L+^T = L D L^T - LEFT */
+
+/* Do while( NEGCNT(LEFT).GT.I-1 ) */
+
+ back = werr[ii];
+L20:
+ negcnt = dlaneg_(n, &d__[1], &lld[1], &left, pivmin, &r__);
+ if (negcnt > i__ - 1) {
+ left -= back;
+ back *= 2.;
+ goto L20;
+ }
+
+/* Do while( NEGCNT(RIGHT).LT.I ) */
+/* Compute negcount from dstqds facto L+D+L+^T = L D L^T - RIGHT */
+
+ back = werr[ii];
+L50:
+ negcnt = dlaneg_(n, &d__[1], &lld[1], &right, pivmin, &r__);
+ if (negcnt < i__) {
+ right += back;
+ back *= 2.;
+ goto L50;
+ }
+ width = (d__1 = left - right, abs(d__1)) * .5;
+/* Computing MAX */
+ d__1 = abs(left), d__2 = abs(right);
+ tmp = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = *rtol1 * gap, d__2 = *rtol2 * tmp;
+ cvrgd = max(d__1,d__2);
+ if (width <= cvrgd || width <= mnwdth) {
+/* This interval has already converged and does not need refinement. */
+/* (Note that the gaps might change through refining the */
+/* eigenvalues, however, they can only get bigger.) */
+/* Remove it from the list. */
+ iwork[k - 1] = -1;
+/* Make sure that I1 always points to the first unconverged interval */
+ if (i__ == i1 && i__ < *ilast) {
+ i1 = i__ + 1;
+ }
+ if (prev >= i1 && i__ <= *ilast) {
+ iwork[(prev << 1) - 1] = i__ + 1;
+ }
+ } else {
+/* unconverged interval found */
+ prev = i__;
+ ++nint;
+ iwork[k - 1] = i__ + 1;
+ iwork[k] = negcnt;
+ }
+ work[k - 1] = left;
+ work[k] = right;
+/* L75: */
+ }
+
+/* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals */
+/* and while (ITER.LT.MAXITR) */
+
+ iter = 0;
+L80:
+ prev = i1 - 1;
+ i__ = i1;
+ olnint = nint;
+ i__1 = olnint;
+ for (ip = 1; ip <= i__1; ++ip) {
+ k = i__ << 1;
+ ii = i__ - *offset;
+ rgap = wgap[ii];
+ lgap = rgap;
+ if (ii > 1) {
+ lgap = wgap[ii - 1];
+ }
+ gap = min(lgap,rgap);
+ next = iwork[k - 1];
+ left = work[k - 1];
+ right = work[k];
+ mid = (left + right) * .5;
+/* semiwidth of interval */
+ width = right - mid;
+/* Computing MAX */
+ d__1 = abs(left), d__2 = abs(right);
+ tmp = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = *rtol1 * gap, d__2 = *rtol2 * tmp;
+ cvrgd = max(d__1,d__2);
+ if (width <= cvrgd || width <= mnwdth || iter == maxitr) {
+/* reduce number of unconverged intervals */
+ --nint;
+/* Mark interval as converged. */
+ iwork[k - 1] = 0;
+ if (i1 == i__) {
+ i1 = next;
+ } else {
+/* Prev holds the last unconverged interval previously examined */
+ if (prev >= i1) {
+ iwork[(prev << 1) - 1] = next;
+ }
+ }
+ i__ = next;
+ goto L100;
+ }
+ prev = i__;
+
+/* Perform one bisection step */
+
+ negcnt = dlaneg_(n, &d__[1], &lld[1], &mid, pivmin, &r__);
+ if (negcnt <= i__ - 1) {
+ work[k - 1] = mid;
+ } else {
+ work[k] = mid;
+ }
+ i__ = next;
+L100:
+ ;
+ }
+ ++iter;
+/* do another loop if there are still unconverged intervals */
+/* However, in the last iteration, all intervals are accepted */
+/* since this is the best we can do. */
+ if (nint > 0 && iter <= maxitr) {
+ goto L80;
+ }
+
+
+/* At this point, all the intervals have converged */
+ i__1 = *ilast;
+ for (i__ = *ifirst; i__ <= i__1; ++i__) {
+ k = i__ << 1;
+ ii = i__ - *offset;
+/* All intervals marked by '0' have been refined. */
+ if (iwork[k - 1] == 0) {
+ w[ii] = (work[k - 1] + work[k]) * .5;
+ werr[ii] = work[k] - w[ii];
+ }
+/* L110: */
+ }
+
+ i__1 = *ilast;
+ for (i__ = *ifirst + 1; i__ <= i__1; ++i__) {
+ k = i__ << 1;
+ ii = i__ - *offset;
+/* Computing MAX */
+ d__1 = 0., d__2 = w[ii] - werr[ii] - w[ii - 1] - werr[ii - 1];
+ wgap[ii - 1] = max(d__1,d__2);
+/* L111: */
+ }
+ return 0;
+
+/* End of DLARRB */
+
+} /* dlarrb_ */
diff --git a/SRC/dlarrc.c b/SRC/dlarrc.c
new file mode 100644
index 0000000..ac08bff
--- /dev/null
+++ b/SRC/dlarrc.c
@@ -0,0 +1,183 @@
+/* dlarrc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlarrc_(char *jobt, integer *n, doublereal *vl,
+ doublereal *vu, doublereal *d__, doublereal *e, doublereal *pivmin,
+ integer *eigcnt, integer *lcnt, integer *rcnt, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__;
+ doublereal sl, su, tmp, tmp2;
+ logical matt;
+ extern logical lsame_(char *, char *);
+ doublereal lpivot, rpivot;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Find the number of eigenvalues of the symmetric tridiagonal matrix T */
+/* that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T */
+/* if JOBT = 'L'. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBT (input) CHARACTER*1 */
+/* = 'T': Compute Sturm count for matrix T. */
+/* = 'L': Compute Sturm count for matrix L D L^T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N > 0. */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* The lower and upper bounds for the eigenvalues. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* JOBT = 'T': The N diagonal elements of the tridiagonal matrix T. */
+/* JOBT = 'L': The N diagonal elements of the diagonal matrix D. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N) */
+/* JOBT = 'T': The N-1 offdiagonal elements of the matrix T. */
+/* JOBT = 'L': The N-1 offdiagonal elements of the matrix L. */
+
+/* PIVMIN (input) DOUBLE PRECISION */
+/* The minimum pivot in the Sturm sequence for T. */
+
+/* EIGCNT (output) INTEGER */
+/* The number of eigenvalues of the symmetric tridiagonal matrix T */
+/* that are in the interval (VL,VU] */
+
+/* LCNT (output) INTEGER */
+/* RCNT (output) INTEGER */
+/* The left and right negcounts of the interval. */
+
+/* INFO (output) INTEGER */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --e;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+ *lcnt = 0;
+ *rcnt = 0;
+ *eigcnt = 0;
+ matt = lsame_(jobt, "T");
+ if (matt) {
+/* Sturm sequence count on T */
+ lpivot = d__[1] - *vl;
+ rpivot = d__[1] - *vu;
+ if (lpivot <= 0.) {
+ ++(*lcnt);
+ }
+ if (rpivot <= 0.) {
+ ++(*rcnt);
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing 2nd power */
+ d__1 = e[i__];
+ tmp = d__1 * d__1;
+ lpivot = d__[i__ + 1] - *vl - tmp / lpivot;
+ rpivot = d__[i__ + 1] - *vu - tmp / rpivot;
+ if (lpivot <= 0.) {
+ ++(*lcnt);
+ }
+ if (rpivot <= 0.) {
+ ++(*rcnt);
+ }
+/* L10: */
+ }
+ } else {
+/* Sturm sequence count on L D L^T */
+ sl = -(*vl);
+ su = -(*vu);
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ lpivot = d__[i__] + sl;
+ rpivot = d__[i__] + su;
+ if (lpivot <= 0.) {
+ ++(*lcnt);
+ }
+ if (rpivot <= 0.) {
+ ++(*rcnt);
+ }
+ tmp = e[i__] * d__[i__] * e[i__];
+
+ tmp2 = tmp / lpivot;
+ if (tmp2 == 0.) {
+ sl = tmp - *vl;
+ } else {
+ sl = sl * tmp2 - *vl;
+ }
+
+ tmp2 = tmp / rpivot;
+ if (tmp2 == 0.) {
+ su = tmp - *vu;
+ } else {
+ su = su * tmp2 - *vu;
+ }
+/* L20: */
+ }
+ lpivot = d__[*n] + sl;
+ rpivot = d__[*n] + su;
+ if (lpivot <= 0.) {
+ ++(*lcnt);
+ }
+ if (rpivot <= 0.) {
+ ++(*rcnt);
+ }
+ }
+ *eigcnt = *rcnt - *lcnt;
+ return 0;
+
+/* end of DLARRC */
+
+} /* dlarrc_ */
diff --git a/SRC/dlarrd.c b/SRC/dlarrd.c
new file mode 100644
index 0000000..a265762
--- /dev/null
+++ b/SRC/dlarrd.c
@@ -0,0 +1,793 @@
+/* dlarrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+static integer c__0 = 0;
+
+/* Subroutine */ int dlarrd_(char *range, char *order, integer *n, doublereal
+ *vl, doublereal *vu, integer *il, integer *iu, doublereal *gers,
+ doublereal *reltol, doublereal *d__, doublereal *e, doublereal *e2,
+ doublereal *pivmin, integer *nsplit, integer *isplit, integer *m,
+ doublereal *w, doublereal *werr, doublereal *wl, doublereal *wu,
+ integer *iblock, integer *indexw, doublereal *work, integer *iwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double log(doublereal);
+
+ /* Local variables */
+ integer i__, j, ib, ie, je, nb;
+ doublereal gl;
+ integer im, in;
+ doublereal gu;
+ integer iw, jee;
+ doublereal eps;
+ integer nwl;
+ doublereal wlu, wul;
+ integer nwu;
+ doublereal tmp1, tmp2;
+ integer iend, jblk, ioff, iout, itmp1, itmp2, jdisc;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ doublereal atoli;
+ integer iwoff, itmax;
+ doublereal wkill, rtoli, uflow, tnorm;
+ extern doublereal dlamch_(char *);
+ integer ibegin;
+ extern /* Subroutine */ int dlaebz_(integer *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ integer irange, idiscl, idumma[1];
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer idiscu;
+ logical ncnvrg, toofew;
+
+
+/* -- LAPACK auxiliary routine (version 3.2.1) -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/* -- April 2009 -- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARRD computes the eigenvalues of a symmetric tridiagonal */
+/* matrix T to suitable accuracy. This is an auxiliary code to be */
+/* called from DSTEMR. */
+/* The user may ask for all eigenvalues, all eigenvalues */
+/* in the half-open interval (VL, VU], or the IL-th through IU-th */
+/* eigenvalues. */
+
+/* To avoid overflow, the matrix must be scaled so that its */
+/* largest element is no greater than overflow**(1/2) * */
+/* underflow**(1/4) in absolute value, and for greatest */
+/* accuracy, it should not be much smaller than that. */
+
+/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */
+/* Matrix", Report CS41, Computer Science Dept., Stanford */
+/* University, July 21, 1966. */
+
+/* Arguments */
+/* ========= */
+
+/* RANGE (input) CHARACTER */
+/* = 'A': ("All") all eigenvalues will be found. */
+/* = 'V': ("Value") all eigenvalues in the half-open interval */
+/* (VL, VU] will be found. */
+/* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the */
+/* entire matrix) will be found. */
+
+/* ORDER (input) CHARACTER */
+/* = 'B': ("By Block") the eigenvalues will be grouped by */
+/* split-off block (see IBLOCK, ISPLIT) and */
+/* ordered from smallest to largest within */
+/* the block. */
+/* = 'E': ("Entire matrix") */
+/* the eigenvalues for the entire matrix */
+/* will be ordered from smallest to */
+/* largest. */
+
+/* N (input) INTEGER */
+/* The order of the tridiagonal matrix T. N >= 0. */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. Eigenvalues less than or equal */
+/* to VL, or greater than VU, will not be returned. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* GERS (input) DOUBLE PRECISION array, dimension (2*N) */
+/* The N Gerschgorin intervals (the i-th Gerschgorin interval */
+/* is (GERS(2*i-1), GERS(2*i)). */
+
+/* RELTOL (input) DOUBLE PRECISION */
+/* The minimum relative width of an interval. When an interval */
+/* is narrower than RELTOL times the larger (in */
+/* magnitude) endpoint, then it is considered to be */
+/* sufficiently small, i.e., converged. Note: this should */
+/* always be at least radix*machine epsilon. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix T. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) off-diagonal elements of the tridiagonal matrix T. */
+
+/* E2 (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) squared off-diagonal elements of the tridiagonal matrix T. */
+
+/* PIVMIN (input) DOUBLE PRECISION */
+/* The minimum pivot allowed in the Sturm sequence for T. */
+
+/* NSPLIT (input) INTEGER */
+/* The number of diagonal blocks in the matrix T. */
+/* 1 <= NSPLIT <= N. */
+
+/* ISPLIT (input) INTEGER array, dimension (N) */
+/* The splitting points, at which T breaks up into submatrices. */
+/* The first submatrix consists of rows/columns 1 to ISPLIT(1), */
+/* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */
+/* etc., and the NSPLIT-th consists of rows/columns */
+/* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */
+/* (Only the first NSPLIT elements will actually be used, but */
+/* since the user cannot know a priori what value NSPLIT will */
+/* have, N words must be reserved for ISPLIT.) */
+
+/* M (output) INTEGER */
+/* The actual number of eigenvalues found. 0 <= M <= N. */
+/* (See also the description of INFO=2,3.) */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* On exit, the first M elements of W will contain the */
+/* eigenvalue approximations. DLARRD computes an interval */
+/* I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue */
+/* approximation is given as the interval midpoint */
+/* W(j)= ( a_j + b_j)/2. The corresponding error is bounded by */
+/* WERR(j) = abs( a_j - b_j)/2 */
+
+/* WERR (output) DOUBLE PRECISION array, dimension (N) */
+/* The error bound on the corresponding eigenvalue approximation */
+/* in W. */
+
+/* WL (output) DOUBLE PRECISION */
+/* WU (output) DOUBLE PRECISION */
+/* The interval (WL, WU] contains all the wanted eigenvalues. */
+/* If RANGE='V', then WL=VL and WU=VU. */
+/* If RANGE='A', then WL and WU are the global Gerschgorin bounds */
+/* on the spectrum. */
+/* If RANGE='I', then WL and WU are computed by DLAEBZ from the */
+/* index range specified. */
+
+/* IBLOCK (output) INTEGER array, dimension (N) */
+/* At each row/column j where E(j) is zero or small, the */
+/* matrix T is considered to split into a block diagonal */
+/* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which */
+/* block (from 1 to the number of blocks) the eigenvalue W(i) */
+/* belongs. (DLARRD may use the remaining N-M elements as */
+/* workspace.) */
+
+/* INDEXW (output) INTEGER array, dimension (N) */
+/* The indices of the eigenvalues within each block (submatrix); */
+/* for example, INDEXW(i)= j and IBLOCK(i)=k imply that the */
+/* i-th eigenvalue W(i) is the j-th eigenvalue in block k. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: some or all of the eigenvalues failed to converge or */
+/* were not computed: */
+/* =1 or 3: Bisection failed to converge for some */
+/* eigenvalues; these eigenvalues are flagged by a */
+/* negative block number. The effect is that the */
+/* eigenvalues may not be as accurate as the */
+/* absolute and relative tolerances. This is */
+/* generally caused by unexpectedly inaccurate */
+/* arithmetic. */
+/* =2 or 3: RANGE='I' only: Not all of the eigenvalues */
+/* IL:IU were found. */
+/* Effect: M < IU+1-IL */
+/* Cause: non-monotonic arithmetic, causing the */
+/* Sturm sequence to be non-monotonic. */
+/* Cure: recalculate, using RANGE='A', and pick */
+/* out eigenvalues IL:IU. In some cases, */
+/* increasing the PARAMETER "FUDGE" may */
+/* make things work. */
+/* = 4: RANGE='I', and the Gershgorin interval */
+/* initially used was too small. No eigenvalues */
+/* were computed. */
+/* Probable cause: your machine has sloppy */
+/* floating-point arithmetic. */
+/* Cure: Increase the PARAMETER "FUDGE", */
+/* recompile, and try again. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* FUDGE DOUBLE PRECISION, default = 2 */
+/* A "fudge factor" to widen the Gershgorin intervals. Ideally, */
+/* a value of 1 should work, but on machines with sloppy */
+/* arithmetic, this needs to be larger. The default for */
+/* publicly released versions should be large enough to handle */
+/* the worst machine around. Note that this has no effect */
+/* on accuracy of the solution. */
+
+/* Based on contributions by */
+/* W. Kahan, University of California, Berkeley, USA */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --indexw;
+ --iblock;
+ --werr;
+ --w;
+ --isplit;
+ --e2;
+ --e;
+ --d__;
+ --gers;
+
+ /* Function Body */
+ *info = 0;
+
+/* Decode RANGE */
+
+ if (lsame_(range, "A")) {
+ irange = 1;
+ } else if (lsame_(range, "V")) {
+ irange = 2;
+ } else if (lsame_(range, "I")) {
+ irange = 3;
+ } else {
+ irange = 0;
+ }
+
+/* Check for Errors */
+
+ if (irange <= 0) {
+ *info = -1;
+ } else if (! (lsame_(order, "B") || lsame_(order,
+ "E"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (irange == 2) {
+ if (*vl >= *vu) {
+ *info = -5;
+ }
+ } else if (irange == 3 && (*il < 1 || *il > max(1,*n))) {
+ *info = -6;
+ } else if (irange == 3 && (*iu < min(*n,*il) || *iu > *n)) {
+ *info = -7;
+ }
+
+ if (*info != 0) {
+ return 0;
+ }
+/* Initialize error flags */
+ *info = 0;
+ ncnvrg = FALSE_;
+ toofew = FALSE_;
+/* Quick return if possible */
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+/* Simplification: */
+ if (irange == 3 && *il == 1 && *iu == *n) {
+ irange = 1;
+ }
+/* Get machine constants */
+ eps = dlamch_("P");
+ uflow = dlamch_("U");
+/* Special Case when N=1 */
+/* Treat case of 1x1 matrix for quick return */
+ if (*n == 1) {
+ if (irange == 1 || irange == 2 && d__[1] > *vl && d__[1] <= *vu ||
+ irange == 3 && *il == 1 && *iu == 1) {
+ *m = 1;
+ w[1] = d__[1];
+/* The computation error of the eigenvalue is zero */
+ werr[1] = 0.;
+ iblock[1] = 1;
+ indexw[1] = 1;
+ }
+ return 0;
+ }
+/* NB is the minimum vector length for vector bisection, or 0 */
+/* if only scalar is to be done. */
+ nb = ilaenv_(&c__1, "DSTEBZ", " ", n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1) {
+ nb = 0;
+ }
+/* Find global spectral radius */
+ gl = d__[1];
+ gu = d__[1];
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MIN */
+ d__1 = gl, d__2 = gers[(i__ << 1) - 1];
+ gl = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = gu, d__2 = gers[i__ * 2];
+ gu = max(d__1,d__2);
+/* L5: */
+ }
+/* Compute global Gerschgorin bounds and spectral diameter */
+/* Computing MAX */
+ d__1 = abs(gl), d__2 = abs(gu);
+ tnorm = max(d__1,d__2);
+ gl = gl - tnorm * 2. * eps * *n - *pivmin * 4.;
+ gu = gu + tnorm * 2. * eps * *n + *pivmin * 4.;
+/* [JAN/28/2009] remove the line below since SPDIAM variable not use */
+/* SPDIAM = GU - GL */
+/* Input arguments for DLAEBZ: */
+/* The relative tolerance. An interval (a,b] lies within */
+/* "relative tolerance" if b-a < RELTOL*max(|a|,|b|), */
+ rtoli = *reltol;
+/* Set the absolute tolerance for interval convergence to zero to force */
+/* interval convergence based on relative size of the interval. */
+/* This is dangerous because intervals might not converge when RELTOL is */
+/* small. But at least a very small number should be selected so that for */
+/* strongly graded matrices, the code can get relatively accurate */
+/* eigenvalues. */
+ atoli = uflow * 4. + *pivmin * 4.;
+ if (irange == 3) {
+/* RANGE='I': Compute an interval containing eigenvalues */
+/* IL through IU. The initial interval [GL,GU] from the global */
+/* Gerschgorin bounds GL and GU is refined by DLAEBZ. */
+ itmax = (integer) ((log(tnorm + *pivmin) - log(*pivmin)) / log(2.)) +
+ 2;
+ work[*n + 1] = gl;
+ work[*n + 2] = gl;
+ work[*n + 3] = gu;
+ work[*n + 4] = gu;
+ work[*n + 5] = gl;
+ work[*n + 6] = gu;
+ iwork[1] = -1;
+ iwork[2] = -1;
+ iwork[3] = *n + 1;
+ iwork[4] = *n + 1;
+ iwork[5] = *il - 1;
+ iwork[6] = *iu;
+
+ dlaebz_(&c__3, &itmax, n, &c__2, &c__2, &nb, &atoli, &rtoli, pivmin, &
+ d__[1], &e[1], &e2[1], &iwork[5], &work[*n + 1], &work[*n + 5]
+, &iout, &iwork[1], &w[1], &iblock[1], &iinfo);
+ if (iinfo != 0) {
+ *info = iinfo;
+ return 0;
+ }
+/* On exit, output intervals may not be ordered by ascending negcount */
+ if (iwork[6] == *iu) {
+ *wl = work[*n + 1];
+ wlu = work[*n + 3];
+ nwl = iwork[1];
+ *wu = work[*n + 4];
+ wul = work[*n + 2];
+ nwu = iwork[4];
+ } else {
+ *wl = work[*n + 2];
+ wlu = work[*n + 4];
+ nwl = iwork[2];
+ *wu = work[*n + 3];
+ wul = work[*n + 1];
+ nwu = iwork[3];
+ }
+/* On exit, the interval [WL, WLU] contains a value with negcount NWL, */
+/* and [WUL, WU] contains a value with negcount NWU. */
+ if (nwl < 0 || nwl >= *n || nwu < 1 || nwu > *n) {
+ *info = 4;
+ return 0;
+ }
+ } else if (irange == 2) {
+ *wl = *vl;
+ *wu = *vu;
+ } else if (irange == 1) {
+ *wl = gl;
+ *wu = gu;
+ }
+/* Find Eigenvalues -- Loop Over blocks and recompute NWL and NWU. */
+/* NWL accumulates the number of eigenvalues .le. WL, */
+/* NWU accumulates the number of eigenvalues .le. WU */
+ *m = 0;
+ iend = 0;
+ *info = 0;
+ nwl = 0;
+ nwu = 0;
+
+ i__1 = *nsplit;
+ for (jblk = 1; jblk <= i__1; ++jblk) {
+ ioff = iend;
+ ibegin = ioff + 1;
+ iend = isplit[jblk];
+ in = iend - ioff;
+
+ if (in == 1) {
+/* 1x1 block */
+ if (*wl >= d__[ibegin] - *pivmin) {
+ ++nwl;
+ }
+ if (*wu >= d__[ibegin] - *pivmin) {
+ ++nwu;
+ }
+ if (irange == 1 || *wl < d__[ibegin] - *pivmin && *wu >= d__[
+ ibegin] - *pivmin) {
+ ++(*m);
+ w[*m] = d__[ibegin];
+ werr[*m] = 0.;
+/* The gap for a single block doesn't matter for the later */
+/* algorithm and is assigned an arbitrary large value */
+ iblock[*m] = jblk;
+ indexw[*m] = 1;
+ }
+/* Disabled 2x2 case because of a failure on the following matrix */
+/* RANGE = 'I', IL = IU = 4 */
+/* Original Tridiagonal, d = [ */
+/* -0.150102010615740E+00 */
+/* -0.849897989384260E+00 */
+/* -0.128208148052635E-15 */
+/* 0.128257718286320E-15 */
+/* ]; */
+/* e = [ */
+/* -0.357171383266986E+00 */
+/* -0.180411241501588E-15 */
+/* -0.175152352710251E-15 */
+/* ]; */
+
+/* ELSE IF( IN.EQ.2 ) THEN */
+/* * 2x2 block */
+/* DISC = SQRT( (HALF*(D(IBEGIN)-D(IEND)))**2 + E(IBEGIN)**2 ) */
+/* TMP1 = HALF*(D(IBEGIN)+D(IEND)) */
+/* L1 = TMP1 - DISC */
+/* IF( WL.GE. L1-PIVMIN ) */
+/* $ NWL = NWL + 1 */
+/* IF( WU.GE. L1-PIVMIN ) */
+/* $ NWU = NWU + 1 */
+/* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L1-PIVMIN .AND. WU.GE. */
+/* $ L1-PIVMIN ) ) THEN */
+/* M = M + 1 */
+/* W( M ) = L1 */
+/* * The uncertainty of eigenvalues of a 2x2 matrix is very small */
+/* WERR( M ) = EPS * ABS( W( M ) ) * TWO */
+/* IBLOCK( M ) = JBLK */
+/* INDEXW( M ) = 1 */
+/* ENDIF */
+/* L2 = TMP1 + DISC */
+/* IF( WL.GE. L2-PIVMIN ) */
+/* $ NWL = NWL + 1 */
+/* IF( WU.GE. L2-PIVMIN ) */
+/* $ NWU = NWU + 1 */
+/* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L2-PIVMIN .AND. WU.GE. */
+/* $ L2-PIVMIN ) ) THEN */
+/* M = M + 1 */
+/* W( M ) = L2 */
+/* * The uncertainty of eigenvalues of a 2x2 matrix is very small */
+/* WERR( M ) = EPS * ABS( W( M ) ) * TWO */
+/* IBLOCK( M ) = JBLK */
+/* INDEXW( M ) = 2 */
+/* ENDIF */
+ } else {
+/* General Case - block of size IN >= 2 */
+/* Compute local Gerschgorin interval and use it as the initial */
+/* interval for DLAEBZ */
+ gu = d__[ibegin];
+ gl = d__[ibegin];
+ tmp1 = 0.;
+ i__2 = iend;
+ for (j = ibegin; j <= i__2; ++j) {
+/* Computing MIN */
+ d__1 = gl, d__2 = gers[(j << 1) - 1];
+ gl = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = gu, d__2 = gers[j * 2];
+ gu = max(d__1,d__2);
+/* L40: */
+ }
+/* [JAN/28/2009] */
+/* change SPDIAM by TNORM in lines 2 and 3 thereafter */
+/* line 1: remove computation of SPDIAM (not useful anymore) */
+/* SPDIAM = GU - GL */
+/* GL = GL - FUDGE*SPDIAM*EPS*IN - FUDGE*PIVMIN */
+/* GU = GU + FUDGE*SPDIAM*EPS*IN + FUDGE*PIVMIN */
+ gl = gl - tnorm * 2. * eps * in - *pivmin * 2.;
+ gu = gu + tnorm * 2. * eps * in + *pivmin * 2.;
+
+ if (irange > 1) {
+ if (gu < *wl) {
+/* the local block contains none of the wanted eigenvalues */
+ nwl += in;
+ nwu += in;
+ goto L70;
+ }
+/* refine search interval if possible, only range (WL,WU] matters */
+ gl = max(gl,*wl);
+ gu = min(gu,*wu);
+ if (gl >= gu) {
+ goto L70;
+ }
+ }
+/* Find negcount of initial interval boundaries GL and GU */
+ work[*n + 1] = gl;
+ work[*n + in + 1] = gu;
+ dlaebz_(&c__1, &c__0, &in, &in, &c__1, &nb, &atoli, &rtoli,
+ pivmin, &d__[ibegin], &e[ibegin], &e2[ibegin], idumma, &
+ work[*n + 1], &work[*n + (in << 1) + 1], &im, &iwork[1], &
+ w[*m + 1], &iblock[*m + 1], &iinfo);
+ if (iinfo != 0) {
+ *info = iinfo;
+ return 0;
+ }
+
+ nwl += iwork[1];
+ nwu += iwork[in + 1];
+ iwoff = *m - iwork[1];
+/* Compute Eigenvalues */
+ itmax = (integer) ((log(gu - gl + *pivmin) - log(*pivmin)) / log(
+ 2.)) + 2;
+ dlaebz_(&c__2, &itmax, &in, &in, &c__1, &nb, &atoli, &rtoli,
+ pivmin, &d__[ibegin], &e[ibegin], &e2[ibegin], idumma, &
+ work[*n + 1], &work[*n + (in << 1) + 1], &iout, &iwork[1],
+ &w[*m + 1], &iblock[*m + 1], &iinfo);
+ if (iinfo != 0) {
+ *info = iinfo;
+ return 0;
+ }
+
+/* Copy eigenvalues into W and IBLOCK */
+/* Use -JBLK for block number for unconverged eigenvalues. */
+/* Loop over the number of output intervals from DLAEBZ */
+ i__2 = iout;
+ for (j = 1; j <= i__2; ++j) {
+/* eigenvalue approximation is middle point of interval */
+ tmp1 = (work[j + *n] + work[j + in + *n]) * .5;
+/* semi length of error interval */
+ tmp2 = (d__1 = work[j + *n] - work[j + in + *n], abs(d__1)) *
+ .5;
+ if (j > iout - iinfo) {
+/* Flag non-convergence. */
+ ncnvrg = TRUE_;
+ ib = -jblk;
+ } else {
+ ib = jblk;
+ }
+ i__3 = iwork[j + in] + iwoff;
+ for (je = iwork[j] + 1 + iwoff; je <= i__3; ++je) {
+ w[je] = tmp1;
+ werr[je] = tmp2;
+ indexw[je] = je - iwoff;
+ iblock[je] = ib;
+/* L50: */
+ }
+/* L60: */
+ }
+
+ *m += im;
+ }
+L70:
+ ;
+ }
+/* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU */
+/* If NWL+1 < IL or NWU > IU, discard extra eigenvalues. */
+ if (irange == 3) {
+ idiscl = *il - 1 - nwl;
+ idiscu = nwu - *iu;
+
+ if (idiscl > 0) {
+ im = 0;
+ i__1 = *m;
+ for (je = 1; je <= i__1; ++je) {
+/* Remove some of the smallest eigenvalues from the left so that */
+/* at the end IDISCL =0. Move all eigenvalues up to the left. */
+ if (w[je] <= wlu && idiscl > 0) {
+ --idiscl;
+ } else {
+ ++im;
+ w[im] = w[je];
+ werr[im] = werr[je];
+ indexw[im] = indexw[je];
+ iblock[im] = iblock[je];
+ }
+/* L80: */
+ }
+ *m = im;
+ }
+ if (idiscu > 0) {
+/* Remove some of the largest eigenvalues from the right so that */
+/* at the end IDISCU =0. Move all eigenvalues up to the left. */
+ im = *m + 1;
+ for (je = *m; je >= 1; --je) {
+ if (w[je] >= wul && idiscu > 0) {
+ --idiscu;
+ } else {
+ --im;
+ w[im] = w[je];
+ werr[im] = werr[je];
+ indexw[im] = indexw[je];
+ iblock[im] = iblock[je];
+ }
+/* L81: */
+ }
+ jee = 0;
+ i__1 = *m;
+ for (je = im; je <= i__1; ++je) {
+ ++jee;
+ w[jee] = w[je];
+ werr[jee] = werr[je];
+ indexw[jee] = indexw[je];
+ iblock[jee] = iblock[je];
+/* L82: */
+ }
+ *m = *m - im + 1;
+ }
+ if (idiscl > 0 || idiscu > 0) {
+/* Code to deal with effects of bad arithmetic. (If N(w) is */
+/* monotone non-decreasing, this should never happen.) */
+/* Some low eigenvalues to be discarded are not in (WL,WLU], */
+/* or high eigenvalues to be discarded are not in (WUL,WU] */
+/* so just kill off the smallest IDISCL/largest IDISCU */
+/* eigenvalues, by marking the corresponding IBLOCK = 0 */
+ if (idiscl > 0) {
+ wkill = *wu;
+ i__1 = idiscl;
+ for (jdisc = 1; jdisc <= i__1; ++jdisc) {
+ iw = 0;
+ i__2 = *m;
+ for (je = 1; je <= i__2; ++je) {
+ if (iblock[je] != 0 && (w[je] < wkill || iw == 0)) {
+ iw = je;
+ wkill = w[je];
+ }
+/* L90: */
+ }
+ iblock[iw] = 0;
+/* L100: */
+ }
+ }
+ if (idiscu > 0) {
+ wkill = *wl;
+ i__1 = idiscu;
+ for (jdisc = 1; jdisc <= i__1; ++jdisc) {
+ iw = 0;
+ i__2 = *m;
+ for (je = 1; je <= i__2; ++je) {
+ if (iblock[je] != 0 && (w[je] >= wkill || iw == 0)) {
+ iw = je;
+ wkill = w[je];
+ }
+/* L110: */
+ }
+ iblock[iw] = 0;
+/* L120: */
+ }
+ }
+/* Now erase all eigenvalues with IBLOCK set to zero */
+ im = 0;
+ i__1 = *m;
+ for (je = 1; je <= i__1; ++je) {
+ if (iblock[je] != 0) {
+ ++im;
+ w[im] = w[je];
+ werr[im] = werr[je];
+ indexw[im] = indexw[je];
+ iblock[im] = iblock[je];
+ }
+/* L130: */
+ }
+ *m = im;
+ }
+ if (idiscl < 0 || idiscu < 0) {
+ toofew = TRUE_;
+ }
+ }
+
+ if (irange == 1 && *m != *n || irange == 3 && *m != *iu - *il + 1) {
+ toofew = TRUE_;
+ }
+/* If ORDER='B', do nothing the eigenvalues are already sorted by */
+/* block. */
+/* If ORDER='E', sort the eigenvalues from smallest to largest */
+ if (lsame_(order, "E") && *nsplit > 1) {
+ i__1 = *m - 1;
+ for (je = 1; je <= i__1; ++je) {
+ ie = 0;
+ tmp1 = w[je];
+ i__2 = *m;
+ for (j = je + 1; j <= i__2; ++j) {
+ if (w[j] < tmp1) {
+ ie = j;
+ tmp1 = w[j];
+ }
+/* L140: */
+ }
+ if (ie != 0) {
+ tmp2 = werr[ie];
+ itmp1 = iblock[ie];
+ itmp2 = indexw[ie];
+ w[ie] = w[je];
+ werr[ie] = werr[je];
+ iblock[ie] = iblock[je];
+ indexw[ie] = indexw[je];
+ w[je] = tmp1;
+ werr[je] = tmp2;
+ iblock[je] = itmp1;
+ indexw[je] = itmp2;
+ }
+/* L150: */
+ }
+ }
+
+ *info = 0;
+ if (ncnvrg) {
+ ++(*info);
+ }
+ if (toofew) {
+ *info += 2;
+ }
+ return 0;
+
+/* End of DLARRD */
+
+} /* dlarrd_ */
diff --git a/SRC/dlarre.c b/SRC/dlarre.c
new file mode 100644
index 0000000..763c416
--- /dev/null
+++ b/SRC/dlarre.c
@@ -0,0 +1,861 @@
+/* dlarre.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int dlarre_(char *range, integer *n, doublereal *vl,
+ doublereal *vu, integer *il, integer *iu, doublereal *d__, doublereal
+ *e, doublereal *e2, doublereal *rtol1, doublereal *rtol2, doublereal *
+ spltol, integer *nsplit, integer *isplit, integer *m, doublereal *w,
+ doublereal *werr, doublereal *wgap, integer *iblock, integer *indexw,
+ doublereal *gers, doublereal *pivmin, doublereal *work, integer *
+ iwork, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal), log(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal s1, s2;
+ integer mb;
+ doublereal gl;
+ integer in, mm;
+ doublereal gu;
+ integer cnt;
+ doublereal eps, tau, tmp, rtl;
+ integer cnt1, cnt2;
+ doublereal tmp1, eabs;
+ integer iend, jblk;
+ doublereal eold;
+ integer indl;
+ doublereal dmax__, emax;
+ integer wend, idum, indu;
+ doublereal rtol;
+ integer iseed[4];
+ doublereal avgap, sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical norep;
+ extern /* Subroutine */ int dlasq2_(integer *, doublereal *, integer *);
+ extern doublereal dlamch_(char *);
+ integer ibegin;
+ logical forceb;
+ integer irange;
+ doublereal sgndef;
+ extern /* Subroutine */ int dlarra_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *,
+ integer *), dlarrb_(integer *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *), dlarrc_(char *
+, integer *, doublereal *, doublereal *, doublereal *, doublereal
+ *, doublereal *, integer *, integer *, integer *, integer *);
+ integer wbegin;
+ extern /* Subroutine */ int dlarrd_(char *, char *, integer *, doublereal
+ *, doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *
+, integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *);
+ doublereal safmin, spdiam;
+ extern /* Subroutine */ int dlarrk_(integer *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ logical usedqd;
+ doublereal clwdth, isleft;
+ extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *,
+ doublereal *);
+ doublereal isrght, bsrtol, dpivot;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* To find the desired eigenvalues of a given real symmetric */
+/* tridiagonal matrix T, DLARRE sets any "small" off-diagonal */
+/* elements to zero, and for each unreduced block T_i, it finds */
+/* (a) a suitable shift at one end of the block's spectrum, */
+/* (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and */
+/* (c) eigenvalues of each L_i D_i L_i^T. */
+/* The representations and eigenvalues found are then used by */
+/* DSTEMR to compute the eigenvectors of T. */
+/* The accuracy varies depending on whether bisection is used to */
+/* find a few eigenvalues or the dqds algorithm (subroutine DLASQ2) to */
+/* conpute all and then discard any unwanted one. */
+/* As an added benefit, DLARRE also outputs the n */
+/* Gerschgorin intervals for the matrices L_i D_i L_i^T. */
+
+/* Arguments */
+/* ========= */
+
+/* RANGE (input) CHARACTER */
+/* = 'A': ("All") all eigenvalues will be found. */
+/* = 'V': ("Value") all eigenvalues in the half-open interval */
+/* (VL, VU] will be found. */
+/* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the */
+/* entire matrix) will be found. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N > 0. */
+
+/* VL (input/output) DOUBLE PRECISION */
+/* VU (input/output) DOUBLE PRECISION */
+/* If RANGE='V', the lower and upper bounds for the eigenvalues. */
+/* Eigenvalues less than or equal to VL, or greater than VU, */
+/* will not be returned. VL < VU. */
+/* If RANGE='I' or ='A', DLARRE computes bounds on the desired */
+/* part of the spectrum. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the N diagonal elements of the tridiagonal */
+/* matrix T. */
+/* On exit, the N diagonal elements of the diagonal */
+/* matrices D_i. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the first (N-1) entries contain the subdiagonal */
+/* elements of the tridiagonal matrix T; E(N) need not be set. */
+/* On exit, E contains the subdiagonal elements of the unit */
+/* bidiagonal matrices L_i. The entries E( ISPLIT( I ) ), */
+/* 1 <= I <= NSPLIT, contain the base points sigma_i on output. */
+
+/* E2 (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the first (N-1) entries contain the SQUARES of the */
+/* subdiagonal elements of the tridiagonal matrix T; */
+/* E2(N) need not be set. */
+/* On exit, the entries E2( ISPLIT( I ) ), */
+/* 1 <= I <= NSPLIT, have been set to zero */
+
+/* RTOL1 (input) DOUBLE PRECISION */
+/* RTOL2 (input) DOUBLE PRECISION */
+/* Parameters for bisection. */
+/* An interval [LEFT,RIGHT] has converged if */
+/* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */
+
+/* SPLTOL (input) DOUBLE PRECISION */
+/* The threshold for splitting. */
+
+/* NSPLIT (output) INTEGER */
+/* The number of blocks T splits into. 1 <= NSPLIT <= N. */
+
+/* ISPLIT (output) INTEGER array, dimension (N) */
+/* The splitting points, at which T breaks up into blocks. */
+/* The first block consists of rows/columns 1 to ISPLIT(1), */
+/* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */
+/* etc., and the NSPLIT-th consists of rows/columns */
+/* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues (of all L_i D_i L_i^T) */
+/* found. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* The first M elements contain the eigenvalues. The */
+/* eigenvalues of each of the blocks, L_i D_i L_i^T, are */
+/* sorted in ascending order ( DLARRE may use the */
+/* remaining N-M elements as workspace). */
+
+/* WERR (output) DOUBLE PRECISION array, dimension (N) */
+/* The error bound on the corresponding eigenvalue in W. */
+
+/* WGAP (output) DOUBLE PRECISION array, dimension (N) */
+/* The separation from the right neighbor eigenvalue in W. */
+/* The gap is only with respect to the eigenvalues of the same block */
+/* as each block has its own representation tree. */
+/* Exception: at the right end of a block we store the left gap */
+
+/* IBLOCK (output) INTEGER array, dimension (N) */
+/* The indices of the blocks (submatrices) associated with the */
+/* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue */
+/* W(i) belongs to the first block from the top, =2 if W(i) */
+/* belongs to the second block, etc. */
+
+/* INDEXW (output) INTEGER array, dimension (N) */
+/* The indices of the eigenvalues within each block (submatrix); */
+/* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the */
+/* i-th eigenvalue W(i) is the 10-th eigenvalue in block 2 */
+
+/* GERS (output) DOUBLE PRECISION array, dimension (2*N) */
+/* The N Gerschgorin intervals (the i-th Gerschgorin interval */
+/* is (GERS(2*i-1), GERS(2*i)). */
+
+/* PIVMIN (output) DOUBLE PRECISION */
+/* The minimum pivot in the Sturm sequence for T. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (6*N) */
+/* Workspace. */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+/* Workspace. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* > 0: A problem occured in DLARRE. */
+/* < 0: One of the called subroutines signaled an internal problem. */
+/* Needs inspection of the corresponding parameter IINFO */
+/* for further information. */
+
+/* =-1: Problem in DLARRD. */
+/* = 2: No base representation could be found in MAXTRY iterations. */
+/* Increasing MAXTRY and recompilation might be a remedy. */
+/* =-3: Problem in DLARRB when computing the refined root */
+/* representation for DLASQ2. */
+/* =-4: Problem in DLARRB when preforming bisection on the */
+/* desired part of the spectrum. */
+/* =-5: Problem in DLASQ2. */
+/* =-6: Problem in DLASQ2. */
+
+/* Further Details */
+/* The base representations are required to suffer very little */
+/* element growth and consequently define all their eigenvalues to */
+/* high relative accuracy. */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --gers;
+ --indexw;
+ --iblock;
+ --wgap;
+ --werr;
+ --w;
+ --isplit;
+ --e2;
+ --e;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+
+/* Decode RANGE */
+
+ if (lsame_(range, "A")) {
+ irange = 1;
+ } else if (lsame_(range, "V")) {
+ irange = 3;
+ } else if (lsame_(range, "I")) {
+ irange = 2;
+ }
+ *m = 0;
+/* Get machine constants */
+ safmin = dlamch_("S");
+ eps = dlamch_("P");
+/* Set parameters */
+ rtl = sqrt(eps);
+ bsrtol = sqrt(eps);
+/* Treat case of 1x1 matrix for quick return */
+ if (*n == 1) {
+ if (irange == 1 || irange == 3 && d__[1] > *vl && d__[1] <= *vu ||
+ irange == 2 && *il == 1 && *iu == 1) {
+ *m = 1;
+ w[1] = d__[1];
+/* The computation error of the eigenvalue is zero */
+ werr[1] = 0.;
+ wgap[1] = 0.;
+ iblock[1] = 1;
+ indexw[1] = 1;
+ gers[1] = d__[1];
+ gers[2] = d__[1];
+ }
+/* store the shift for the initial RRR, which is zero in this case */
+ e[1] = 0.;
+ return 0;
+ }
+/* General case: tridiagonal matrix of order > 1 */
+
+/* Init WERR, WGAP. Compute Gerschgorin intervals and spectral diameter. */
+/* Compute maximum off-diagonal entry and pivmin. */
+ gl = d__[1];
+ gu = d__[1];
+ eold = 0.;
+ emax = 0.;
+ e[*n] = 0.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ werr[i__] = 0.;
+ wgap[i__] = 0.;
+ eabs = (d__1 = e[i__], abs(d__1));
+ if (eabs >= emax) {
+ emax = eabs;
+ }
+ tmp1 = eabs + eold;
+ gers[(i__ << 1) - 1] = d__[i__] - tmp1;
+/* Computing MIN */
+ d__1 = gl, d__2 = gers[(i__ << 1) - 1];
+ gl = min(d__1,d__2);
+ gers[i__ * 2] = d__[i__] + tmp1;
+/* Computing MAX */
+ d__1 = gu, d__2 = gers[i__ * 2];
+ gu = max(d__1,d__2);
+ eold = eabs;
+/* L5: */
+ }
+/* The minimum pivot allowed in the Sturm sequence for T */
+/* Computing MAX */
+/* Computing 2nd power */
+ d__3 = emax;
+ d__1 = 1., d__2 = d__3 * d__3;
+ *pivmin = safmin * max(d__1,d__2);
+/* Compute spectral diameter. The Gerschgorin bounds give an */
+/* estimate that is wrong by at most a factor of SQRT(2) */
+ spdiam = gu - gl;
+/* Compute splitting points */
+ dlarra_(n, &d__[1], &e[1], &e2[1], spltol, &spdiam, nsplit, &isplit[1], &
+ iinfo);
+/* Can force use of bisection instead of faster DQDS. */
+/* Option left in the code for future multisection work. */
+ forceb = FALSE_;
+/* Initialize USEDQD, DQDS should be used for ALLRNG unless someone */
+/* explicitly wants bisection. */
+ usedqd = irange == 1 && ! forceb;
+ if (irange == 1 && ! forceb) {
+/* Set interval [VL,VU] that contains all eigenvalues */
+ *vl = gl;
+ *vu = gu;
+ } else {
+/* We call DLARRD to find crude approximations to the eigenvalues */
+/* in the desired range. In case IRANGE = INDRNG, we also obtain the */
+/* interval (VL,VU] that contains all the wanted eigenvalues. */
+/* An interval [LEFT,RIGHT] has converged if */
+/* RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT)) */
+/* DLARRD needs a WORK of size 4*N, IWORK of size 3*N */
+ dlarrd_(range, "B", n, vl, vu, il, iu, &gers[1], &bsrtol, &d__[1], &e[
+ 1], &e2[1], pivmin, nsplit, &isplit[1], &mm, &w[1], &werr[1],
+ vl, vu, &iblock[1], &indexw[1], &work[1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ *info = -1;
+ return 0;
+ }
+/* Make sure that the entries M+1 to N in W, WERR, IBLOCK, INDEXW are 0 */
+ i__1 = *n;
+ for (i__ = mm + 1; i__ <= i__1; ++i__) {
+ w[i__] = 0.;
+ werr[i__] = 0.;
+ iblock[i__] = 0;
+ indexw[i__] = 0;
+/* L14: */
+ }
+ }
+/* ** */
+/* Loop over unreduced blocks */
+ ibegin = 1;
+ wbegin = 1;
+ i__1 = *nsplit;
+ for (jblk = 1; jblk <= i__1; ++jblk) {
+ iend = isplit[jblk];
+ in = iend - ibegin + 1;
+/* 1 X 1 block */
+ if (in == 1) {
+ if (irange == 1 || irange == 3 && d__[ibegin] > *vl && d__[ibegin]
+ <= *vu || irange == 2 && iblock[wbegin] == jblk) {
+ ++(*m);
+ w[*m] = d__[ibegin];
+ werr[*m] = 0.;
+/* The gap for a single block doesn't matter for the later */
+/* algorithm and is assigned an arbitrary large value */
+ wgap[*m] = 0.;
+ iblock[*m] = jblk;
+ indexw[*m] = 1;
+ ++wbegin;
+ }
+/* E( IEND ) holds the shift for the initial RRR */
+ e[iend] = 0.;
+ ibegin = iend + 1;
+ goto L170;
+ }
+
+/* Blocks of size larger than 1x1 */
+
+/* E( IEND ) will hold the shift for the initial RRR, for now set it =0 */
+ e[iend] = 0.;
+
+/* Find local outer bounds GL,GU for the block */
+ gl = d__[ibegin];
+ gu = d__[ibegin];
+ i__2 = iend;
+ for (i__ = ibegin; i__ <= i__2; ++i__) {
+/* Computing MIN */
+ d__1 = gers[(i__ << 1) - 1];
+ gl = min(d__1,gl);
+/* Computing MAX */
+ d__1 = gers[i__ * 2];
+ gu = max(d__1,gu);
+/* L15: */
+ }
+ spdiam = gu - gl;
+ if (! (irange == 1 && ! forceb)) {
+/* Count the number of eigenvalues in the current block. */
+ mb = 0;
+ i__2 = mm;
+ for (i__ = wbegin; i__ <= i__2; ++i__) {
+ if (iblock[i__] == jblk) {
+ ++mb;
+ } else {
+ goto L21;
+ }
+/* L20: */
+ }
+L21:
+ if (mb == 0) {
+/* No eigenvalue in the current block lies in the desired range */
+/* E( IEND ) holds the shift for the initial RRR */
+ e[iend] = 0.;
+ ibegin = iend + 1;
+ goto L170;
+ } else {
+/* Decide whether dqds or bisection is more efficient */
+ usedqd = (doublereal) mb > in * .5 && ! forceb;
+ wend = wbegin + mb - 1;
+/* Calculate gaps for the current block */
+/* In later stages, when representations for individual */
+/* eigenvalues are different, we use SIGMA = E( IEND ). */
+ sigma = 0.;
+ i__2 = wend - 1;
+ for (i__ = wbegin; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = 0., d__2 = w[i__ + 1] - werr[i__ + 1] - (w[i__] +
+ werr[i__]);
+ wgap[i__] = max(d__1,d__2);
+/* L30: */
+ }
+/* Computing MAX */
+ d__1 = 0., d__2 = *vu - sigma - (w[wend] + werr[wend]);
+ wgap[wend] = max(d__1,d__2);
+/* Find local index of the first and last desired evalue. */
+ indl = indexw[wbegin];
+ indu = indexw[wend];
+ }
+ }
+ if (irange == 1 && ! forceb || usedqd) {
+/* Case of DQDS */
+/* Find approximations to the extremal eigenvalues of the block */
+ dlarrk_(&in, &c__1, &gl, &gu, &d__[ibegin], &e2[ibegin], pivmin, &
+ rtl, &tmp, &tmp1, &iinfo);
+ if (iinfo != 0) {
+ *info = -1;
+ return 0;
+ }
+/* Computing MAX */
+ d__2 = gl, d__3 = tmp - tmp1 - eps * 100. * (d__1 = tmp - tmp1,
+ abs(d__1));
+ isleft = max(d__2,d__3);
+ dlarrk_(&in, &in, &gl, &gu, &d__[ibegin], &e2[ibegin], pivmin, &
+ rtl, &tmp, &tmp1, &iinfo);
+ if (iinfo != 0) {
+ *info = -1;
+ return 0;
+ }
+/* Computing MIN */
+ d__2 = gu, d__3 = tmp + tmp1 + eps * 100. * (d__1 = tmp + tmp1,
+ abs(d__1));
+ isrght = min(d__2,d__3);
+/* Improve the estimate of the spectral diameter */
+ spdiam = isrght - isleft;
+ } else {
+/* Case of bisection */
+/* Find approximations to the wanted extremal eigenvalues */
+/* Computing MAX */
+ d__2 = gl, d__3 = w[wbegin] - werr[wbegin] - eps * 100. * (d__1 =
+ w[wbegin] - werr[wbegin], abs(d__1));
+ isleft = max(d__2,d__3);
+/* Computing MIN */
+ d__2 = gu, d__3 = w[wend] + werr[wend] + eps * 100. * (d__1 = w[
+ wend] + werr[wend], abs(d__1));
+ isrght = min(d__2,d__3);
+ }
+/* Decide whether the base representation for the current block */
+/* L_JBLK D_JBLK L_JBLK^T = T_JBLK - sigma_JBLK I */
+/* should be on the left or the right end of the current block. */
+/* The strategy is to shift to the end which is "more populated" */
+/* Furthermore, decide whether to use DQDS for the computation of */
+/* the eigenvalue approximations at the end of DLARRE or bisection. */
+/* dqds is chosen if all eigenvalues are desired or the number of */
+/* eigenvalues to be computed is large compared to the blocksize. */
+ if (irange == 1 && ! forceb) {
+/* If all the eigenvalues have to be computed, we use dqd */
+ usedqd = TRUE_;
+/* INDL is the local index of the first eigenvalue to compute */
+ indl = 1;
+ indu = in;
+/* MB = number of eigenvalues to compute */
+ mb = in;
+ wend = wbegin + mb - 1;
+/* Define 1/4 and 3/4 points of the spectrum */
+ s1 = isleft + spdiam * .25;
+ s2 = isrght - spdiam * .25;
+ } else {
+/* DLARRD has computed IBLOCK and INDEXW for each eigenvalue */
+/* approximation. */
+/* choose sigma */
+ if (usedqd) {
+ s1 = isleft + spdiam * .25;
+ s2 = isrght - spdiam * .25;
+ } else {
+ tmp = min(isrght,*vu) - max(isleft,*vl);
+ s1 = max(isleft,*vl) + tmp * .25;
+ s2 = min(isrght,*vu) - tmp * .25;
+ }
+ }
+/* Compute the negcount at the 1/4 and 3/4 points */
+ if (mb > 1) {
+ dlarrc_("T", &in, &s1, &s2, &d__[ibegin], &e[ibegin], pivmin, &
+ cnt, &cnt1, &cnt2, &iinfo);
+ }
+ if (mb == 1) {
+ sigma = gl;
+ sgndef = 1.;
+ } else if (cnt1 - indl >= indu - cnt2) {
+ if (irange == 1 && ! forceb) {
+ sigma = max(isleft,gl);
+ } else if (usedqd) {
+/* use Gerschgorin bound as shift to get pos def matrix */
+/* for dqds */
+ sigma = isleft;
+ } else {
+/* use approximation of the first desired eigenvalue of the */
+/* block as shift */
+ sigma = max(isleft,*vl);
+ }
+ sgndef = 1.;
+ } else {
+ if (irange == 1 && ! forceb) {
+ sigma = min(isrght,gu);
+ } else if (usedqd) {
+/* use Gerschgorin bound as shift to get neg def matrix */
+/* for dqds */
+ sigma = isrght;
+ } else {
+/* use approximation of the first desired eigenvalue of the */
+/* block as shift */
+ sigma = min(isrght,*vu);
+ }
+ sgndef = -1.;
+ }
+/* An initial SIGMA has been chosen that will be used for computing */
+/* T - SIGMA I = L D L^T */
+/* Define the increment TAU of the shift in case the initial shift */
+/* needs to be refined to obtain a factorization with not too much */
+/* element growth. */
+ if (usedqd) {
+/* The initial SIGMA was to the outer end of the spectrum */
+/* the matrix is definite and we need not retreat. */
+ tau = spdiam * eps * *n + *pivmin * 2.;
+ } else {
+ if (mb > 1) {
+ clwdth = w[wend] + werr[wend] - w[wbegin] - werr[wbegin];
+ avgap = (d__1 = clwdth / (doublereal) (wend - wbegin), abs(
+ d__1));
+ if (sgndef == 1.) {
+/* Computing MAX */
+ d__1 = wgap[wbegin];
+ tau = max(d__1,avgap) * .5;
+/* Computing MAX */
+ d__1 = tau, d__2 = werr[wbegin];
+ tau = max(d__1,d__2);
+ } else {
+/* Computing MAX */
+ d__1 = wgap[wend - 1];
+ tau = max(d__1,avgap) * .5;
+/* Computing MAX */
+ d__1 = tau, d__2 = werr[wend];
+ tau = max(d__1,d__2);
+ }
+ } else {
+ tau = werr[wbegin];
+ }
+ }
+
+ for (idum = 1; idum <= 6; ++idum) {
+/* Compute L D L^T factorization of tridiagonal matrix T - sigma I. */
+/* Store D in WORK(1:IN), L in WORK(IN+1:2*IN), and reciprocals of */
+/* pivots in WORK(2*IN+1:3*IN) */
+ dpivot = d__[ibegin] - sigma;
+ work[1] = dpivot;
+ dmax__ = abs(work[1]);
+ j = ibegin;
+ i__2 = in - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[(in << 1) + i__] = 1. / work[i__];
+ tmp = e[j] * work[(in << 1) + i__];
+ work[in + i__] = tmp;
+ dpivot = d__[j + 1] - sigma - tmp * e[j];
+ work[i__ + 1] = dpivot;
+/* Computing MAX */
+ d__1 = dmax__, d__2 = abs(dpivot);
+ dmax__ = max(d__1,d__2);
+ ++j;
+/* L70: */
+ }
+/* check for element growth */
+ if (dmax__ > spdiam * 64.) {
+ norep = TRUE_;
+ } else {
+ norep = FALSE_;
+ }
+ if (usedqd && ! norep) {
+/* Ensure the definiteness of the representation */
+/* All entries of D (of L D L^T) must have the same sign */
+ i__2 = in;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ tmp = sgndef * work[i__];
+ if (tmp < 0.) {
+ norep = TRUE_;
+ }
+/* L71: */
+ }
+ }
+ if (norep) {
+/* Note that in the case of IRANGE=ALLRNG, we use the Gerschgorin */
+/* shift which makes the matrix definite. So we should end up */
+/* here really only in the case of IRANGE = VALRNG or INDRNG. */
+ if (idum == 5) {
+ if (sgndef == 1.) {
+/* The fudged Gerschgorin shift should succeed */
+ sigma = gl - spdiam * 2. * eps * *n - *pivmin * 4.;
+ } else {
+ sigma = gu + spdiam * 2. * eps * *n + *pivmin * 4.;
+ }
+ } else {
+ sigma -= sgndef * tau;
+ tau *= 2.;
+ }
+ } else {
+/* an initial RRR is found */
+ goto L83;
+ }
+/* L80: */
+ }
+/* if the program reaches this point, no base representation could be */
+/* found in MAXTRY iterations. */
+ *info = 2;
+ return 0;
+L83:
+/* At this point, we have found an initial base representation */
+/* T - SIGMA I = L D L^T with not too much element growth. */
+/* Store the shift. */
+ e[iend] = sigma;
+/* Store D and L. */
+ dcopy_(&in, &work[1], &c__1, &d__[ibegin], &c__1);
+ i__2 = in - 1;
+ dcopy_(&i__2, &work[in + 1], &c__1, &e[ibegin], &c__1);
+ if (mb > 1) {
+
+/* Perturb each entry of the base representation by a small */
+/* (but random) relative amount to overcome difficulties with */
+/* glued matrices. */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = 1;
+/* L122: */
+ }
+ i__2 = (in << 1) - 1;
+ dlarnv_(&c__2, iseed, &i__2, &work[1]);
+ i__2 = in - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ d__[ibegin + i__ - 1] *= eps * 8. * work[i__] + 1.;
+ e[ibegin + i__ - 1] *= eps * 8. * work[in + i__] + 1.;
+/* L125: */
+ }
+ d__[iend] *= eps * 4. * work[in] + 1.;
+
+ }
+
+/* Don't update the Gerschgorin intervals because keeping track */
+/* of the updates would be too much work in DLARRV. */
+/* We update W instead and use it to locate the proper Gerschgorin */
+/* intervals. */
+/* Compute the required eigenvalues of L D L' by bisection or dqds */
+ if (! usedqd) {
+/* If DLARRD has been used, shift the eigenvalue approximations */
+/* according to their representation. This is necessary for */
+/* a uniform DLARRV since dqds computes eigenvalues of the */
+/* shifted representation. In DLARRV, W will always hold the */
+/* UNshifted eigenvalue approximation. */
+ i__2 = wend;
+ for (j = wbegin; j <= i__2; ++j) {
+ w[j] -= sigma;
+ werr[j] += (d__1 = w[j], abs(d__1)) * eps;
+/* L134: */
+ }
+/* call DLARRB to reduce eigenvalue error of the approximations */
+/* from DLARRD */
+ i__2 = iend - 1;
+ for (i__ = ibegin; i__ <= i__2; ++i__) {
+/* Computing 2nd power */
+ d__1 = e[i__];
+ work[i__] = d__[i__] * (d__1 * d__1);
+/* L135: */
+ }
+/* use bisection to find EV from INDL to INDU */
+ i__2 = indl - 1;
+ dlarrb_(&in, &d__[ibegin], &work[ibegin], &indl, &indu, rtol1,
+ rtol2, &i__2, &w[wbegin], &wgap[wbegin], &werr[wbegin], &
+ work[(*n << 1) + 1], &iwork[1], pivmin, &spdiam, &in, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = -4;
+ return 0;
+ }
+/* DLARRB computes all gaps correctly except for the last one */
+/* Record distance to VU/GU */
+/* Computing MAX */
+ d__1 = 0., d__2 = *vu - sigma - (w[wend] + werr[wend]);
+ wgap[wend] = max(d__1,d__2);
+ i__2 = indu;
+ for (i__ = indl; i__ <= i__2; ++i__) {
+ ++(*m);
+ iblock[*m] = jblk;
+ indexw[*m] = i__;
+/* L138: */
+ }
+ } else {
+/* Call dqds to get all eigs (and then possibly delete unwanted */
+/* eigenvalues). */
+/* Note that dqds finds the eigenvalues of the L D L^T representation */
+/* of T to high relative accuracy. High relative accuracy */
+/* might be lost when the shift of the RRR is subtracted to obtain */
+/* the eigenvalues of T. However, T is not guaranteed to define its */
+/* eigenvalues to high relative accuracy anyway. */
+/* Set RTOL to the order of the tolerance used in DLASQ2 */
+/* This is an ESTIMATED error, the worst case bound is 4*N*EPS */
+/* which is usually too large and requires unnecessary work to be */
+/* done by bisection when computing the eigenvectors */
+ rtol = log((doublereal) in) * 4. * eps;
+ j = ibegin;
+ i__2 = in - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[(i__ << 1) - 1] = (d__1 = d__[j], abs(d__1));
+ work[i__ * 2] = e[j] * e[j] * work[(i__ << 1) - 1];
+ ++j;
+/* L140: */
+ }
+ work[(in << 1) - 1] = (d__1 = d__[iend], abs(d__1));
+ work[in * 2] = 0.;
+ dlasq2_(&in, &work[1], &iinfo);
+ if (iinfo != 0) {
+/* If IINFO = -5 then an index is part of a tight cluster */
+/* and should be changed. The index is in IWORK(1) and the */
+/* gap is in WORK(N+1) */
+ *info = -5;
+ return 0;
+ } else {
+/* Test that all eigenvalues are positive as expected */
+ i__2 = in;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] < 0.) {
+ *info = -6;
+ return 0;
+ }
+/* L149: */
+ }
+ }
+ if (sgndef > 0.) {
+ i__2 = indu;
+ for (i__ = indl; i__ <= i__2; ++i__) {
+ ++(*m);
+ w[*m] = work[in - i__ + 1];
+ iblock[*m] = jblk;
+ indexw[*m] = i__;
+/* L150: */
+ }
+ } else {
+ i__2 = indu;
+ for (i__ = indl; i__ <= i__2; ++i__) {
+ ++(*m);
+ w[*m] = -work[i__];
+ iblock[*m] = jblk;
+ indexw[*m] = i__;
+/* L160: */
+ }
+ }
+ i__2 = *m;
+ for (i__ = *m - mb + 1; i__ <= i__2; ++i__) {
+/* the value of RTOL below should be the tolerance in DLASQ2 */
+ werr[i__] = rtol * (d__1 = w[i__], abs(d__1));
+/* L165: */
+ }
+ i__2 = *m - 1;
+ for (i__ = *m - mb + 1; i__ <= i__2; ++i__) {
+/* compute the right gap between the intervals */
+/* Computing MAX */
+ d__1 = 0., d__2 = w[i__ + 1] - werr[i__ + 1] - (w[i__] + werr[
+ i__]);
+ wgap[i__] = max(d__1,d__2);
+/* L166: */
+ }
+/* Computing MAX */
+ d__1 = 0., d__2 = *vu - sigma - (w[*m] + werr[*m]);
+ wgap[*m] = max(d__1,d__2);
+ }
+/* proceed with next block */
+ ibegin = iend + 1;
+ wbegin = wend + 1;
+L170:
+ ;
+ }
+
+ return 0;
+
+/* end of DLARRE */
+
+} /* dlarre_ */
diff --git a/SRC/dlarrf.c b/SRC/dlarrf.c
new file mode 100644
index 0000000..1d42c88
--- /dev/null
+++ b/SRC/dlarrf.c
@@ -0,0 +1,423 @@
+/* dlarrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dlarrf_(integer *n, doublereal *d__, doublereal *l,
+ doublereal *ld, integer *clstrt, integer *clend, doublereal *w,
+ doublereal *wgap, doublereal *werr, doublereal *spdiam, doublereal *
+ clgapl, doublereal *clgapr, doublereal *pivmin, doublereal *sigma,
+ doublereal *dplus, doublereal *lplus, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal s, bestshift, smlgrowth, eps, tmp, max1, max2, rrr1, rrr2,
+ znm2, growthbound, fail, fact, oldp;
+ integer indx;
+ doublereal prod;
+ integer ktry;
+ doublereal fail2, avgap, ldmax, rdmax;
+ integer shift;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical dorrr1;
+ extern doublereal dlamch_(char *);
+ doublereal ldelta;
+ logical nofail;
+ doublereal mingap, lsigma, rdelta;
+ extern logical disnan_(doublereal *);
+ logical forcer;
+ doublereal rsigma, clwdth;
+ logical sawnan1, sawnan2, tryrrr1;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+/* * */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Given the initial representation L D L^T and its cluster of close */
+/* eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ... */
+/* W( CLEND ), DLARRF finds a new relatively robust representation */
+/* L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the */
+/* eigenvalues of L(+) D(+) L(+)^T is relatively isolated. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix (subblock, if the matrix splitted). */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The N diagonal elements of the diagonal matrix D. */
+
+/* L (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (N-1) subdiagonal elements of the unit bidiagonal */
+/* matrix L. */
+
+/* LD (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (N-1) elements L(i)*D(i). */
+
+/* CLSTRT (input) INTEGER */
+/* The index of the first eigenvalue in the cluster. */
+
+/* CLEND (input) INTEGER */
+/* The index of the last eigenvalue in the cluster. */
+
+/* W (input) DOUBLE PRECISION array, dimension >= (CLEND-CLSTRT+1) */
+/* The eigenvalue APPROXIMATIONS of L D L^T in ascending order. */
+/* W( CLSTRT ) through W( CLEND ) form the cluster of relatively */
+/* close eigenalues. */
+
+/* WGAP (input/output) DOUBLE PRECISION array, dimension >= (CLEND-CLSTRT+1) */
+/* The separation from the right neighbor eigenvalue in W. */
+
+/* WERR (input) DOUBLE PRECISION array, dimension >= (CLEND-CLSTRT+1) */
+/* WERR contain the semiwidth of the uncertainty */
+/* interval of the corresponding eigenvalue APPROXIMATION in W */
+
+/* SPDIAM (input) estimate of the spectral diameter obtained from the */
+/* Gerschgorin intervals */
+
+/* CLGAPL, CLGAPR (input) absolute gap on each end of the cluster. */
+/* Set by the calling routine to protect against shifts too close */
+/* to eigenvalues outside the cluster. */
+
+/* PIVMIN (input) DOUBLE PRECISION */
+/* The minimum pivot allowed in the Sturm sequence. */
+
+/* SIGMA (output) DOUBLE PRECISION */
+/* The shift used to form L(+) D(+) L(+)^T. */
+
+/* DPLUS (output) DOUBLE PRECISION array, dimension (N) */
+/* The N diagonal elements of the diagonal matrix D(+). */
+
+/* LPLUS (output) DOUBLE PRECISION array, dimension (N-1) */
+/* The first (N-1) elements of LPLUS contain the subdiagonal */
+/* elements of the unit bidiagonal matrix L(+). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+/* Workspace. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --lplus;
+ --dplus;
+ --werr;
+ --wgap;
+ --w;
+ --ld;
+ --l;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+ fact = 2.;
+ eps = dlamch_("Precision");
+ shift = 0;
+ forcer = FALSE_;
+/* Note that we cannot guarantee that for any of the shifts tried, */
+/* the factorization has a small or even moderate element growth. */
+/* There could be Ritz values at both ends of the cluster and despite */
+/* backing off, there are examples where all factorizations tried */
+/* (in IEEE mode, allowing zero pivots & infinities) have INFINITE */
+/* element growth. */
+/* For this reason, we should use PIVMIN in this subroutine so that at */
+/* least the L D L^T factorization exists. It can be checked afterwards */
+/* whether the element growth caused bad residuals/orthogonality. */
+/* Decide whether the code should accept the best among all */
+/* representations despite large element growth or signal INFO=1 */
+ nofail = TRUE_;
+
+/* Compute the average gap length of the cluster */
+ clwdth = (d__1 = w[*clend] - w[*clstrt], abs(d__1)) + werr[*clend] + werr[
+ *clstrt];
+ avgap = clwdth / (doublereal) (*clend - *clstrt);
+ mingap = min(*clgapl,*clgapr);
+/* Initial values for shifts to both ends of cluster */
+/* Computing MIN */
+ d__1 = w[*clstrt], d__2 = w[*clend];
+ lsigma = min(d__1,d__2) - werr[*clstrt];
+/* Computing MAX */
+ d__1 = w[*clstrt], d__2 = w[*clend];
+ rsigma = max(d__1,d__2) + werr[*clend];
+/* Use a small fudge to make sure that we really shift to the outside */
+ lsigma -= abs(lsigma) * 4. * eps;
+ rsigma += abs(rsigma) * 4. * eps;
+/* Compute upper bounds for how much to back off the initial shifts */
+ ldmax = mingap * .25 + *pivmin * 2.;
+ rdmax = mingap * .25 + *pivmin * 2.;
+/* Computing MAX */
+ d__1 = avgap, d__2 = wgap[*clstrt];
+ ldelta = max(d__1,d__2) / fact;
+/* Computing MAX */
+ d__1 = avgap, d__2 = wgap[*clend - 1];
+ rdelta = max(d__1,d__2) / fact;
+
+/* Initialize the record of the best representation found */
+
+ s = dlamch_("S");
+ smlgrowth = 1. / s;
+ fail = (doublereal) (*n - 1) * mingap / (*spdiam * eps);
+ fail2 = (doublereal) (*n - 1) * mingap / (*spdiam * sqrt(eps));
+ bestshift = lsigma;
+
+/* while (KTRY <= KTRYMAX) */
+ ktry = 0;
+ growthbound = *spdiam * 8.;
+L5:
+ sawnan1 = FALSE_;
+ sawnan2 = FALSE_;
+/* Ensure that we do not back off too much of the initial shifts */
+ ldelta = min(ldmax,ldelta);
+ rdelta = min(rdmax,rdelta);
+/* Compute the element growth when shifting to both ends of the cluster */
+/* accept the shift if there is no element growth at one of the two ends */
+/* Left end */
+ s = -lsigma;
+ dplus[1] = d__[1] + s;
+ if (abs(dplus[1]) < *pivmin) {
+ dplus[1] = -(*pivmin);
+/* Need to set SAWNAN1 because refined RRR test should not be used */
+/* in this case */
+ sawnan1 = TRUE_;
+ }
+ max1 = abs(dplus[1]);
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ lplus[i__] = ld[i__] / dplus[i__];
+ s = s * lplus[i__] * l[i__] - lsigma;
+ dplus[i__ + 1] = d__[i__ + 1] + s;
+ if ((d__1 = dplus[i__ + 1], abs(d__1)) < *pivmin) {
+ dplus[i__ + 1] = -(*pivmin);
+/* Need to set SAWNAN1 because refined RRR test should not be used */
+/* in this case */
+ sawnan1 = TRUE_;
+ }
+/* Computing MAX */
+ d__2 = max1, d__3 = (d__1 = dplus[i__ + 1], abs(d__1));
+ max1 = max(d__2,d__3);
+/* L6: */
+ }
+ sawnan1 = sawnan1 || disnan_(&max1);
+ if (forcer || max1 <= growthbound && ! sawnan1) {
+ *sigma = lsigma;
+ shift = 1;
+ goto L100;
+ }
+/* Right end */
+ s = -rsigma;
+ work[1] = d__[1] + s;
+ if (abs(work[1]) < *pivmin) {
+ work[1] = -(*pivmin);
+/* Need to set SAWNAN2 because refined RRR test should not be used */
+/* in this case */
+ sawnan2 = TRUE_;
+ }
+ max2 = abs(work[1]);
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[*n + i__] = ld[i__] / work[i__];
+ s = s * work[*n + i__] * l[i__] - rsigma;
+ work[i__ + 1] = d__[i__ + 1] + s;
+ if ((d__1 = work[i__ + 1], abs(d__1)) < *pivmin) {
+ work[i__ + 1] = -(*pivmin);
+/* Need to set SAWNAN2 because refined RRR test should not be used */
+/* in this case */
+ sawnan2 = TRUE_;
+ }
+/* Computing MAX */
+ d__2 = max2, d__3 = (d__1 = work[i__ + 1], abs(d__1));
+ max2 = max(d__2,d__3);
+/* L7: */
+ }
+ sawnan2 = sawnan2 || disnan_(&max2);
+ if (forcer || max2 <= growthbound && ! sawnan2) {
+ *sigma = rsigma;
+ shift = 2;
+ goto L100;
+ }
+/* If we are at this point, both shifts led to too much element growth */
+/* Record the better of the two shifts (provided it didn't lead to NaN) */
+ if (sawnan1 && sawnan2) {
+/* both MAX1 and MAX2 are NaN */
+ goto L50;
+ } else {
+ if (! sawnan1) {
+ indx = 1;
+ if (max1 <= smlgrowth) {
+ smlgrowth = max1;
+ bestshift = lsigma;
+ }
+ }
+ if (! sawnan2) {
+ if (sawnan1 || max2 <= max1) {
+ indx = 2;
+ }
+ if (max2 <= smlgrowth) {
+ smlgrowth = max2;
+ bestshift = rsigma;
+ }
+ }
+ }
+/* If we are here, both the left and the right shift led to */
+/* element growth. If the element growth is moderate, then */
+/* we may still accept the representation, if it passes a */
+/* refined test for RRR. This test supposes that no NaN occurred. */
+/* Moreover, we use the refined RRR test only for isolated clusters. */
+ if (clwdth < mingap / 128. && min(max1,max2) < fail2 && ! sawnan1 && !
+ sawnan2) {
+ dorrr1 = TRUE_;
+ } else {
+ dorrr1 = FALSE_;
+ }
+ tryrrr1 = TRUE_;
+ if (tryrrr1 && dorrr1) {
+ if (indx == 1) {
+ tmp = (d__1 = dplus[*n], abs(d__1));
+ znm2 = 1.;
+ prod = 1.;
+ oldp = 1.;
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ if (prod <= eps) {
+ prod = dplus[i__ + 1] * work[*n + i__ + 1] / (dplus[i__] *
+ work[*n + i__]) * oldp;
+ } else {
+ prod *= (d__1 = work[*n + i__], abs(d__1));
+ }
+ oldp = prod;
+/* Computing 2nd power */
+ d__1 = prod;
+ znm2 += d__1 * d__1;
+/* Computing MAX */
+ d__2 = tmp, d__3 = (d__1 = dplus[i__] * prod, abs(d__1));
+ tmp = max(d__2,d__3);
+/* L15: */
+ }
+ rrr1 = tmp / (*spdiam * sqrt(znm2));
+ if (rrr1 <= 8.) {
+ *sigma = lsigma;
+ shift = 1;
+ goto L100;
+ }
+ } else if (indx == 2) {
+ tmp = (d__1 = work[*n], abs(d__1));
+ znm2 = 1.;
+ prod = 1.;
+ oldp = 1.;
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ if (prod <= eps) {
+ prod = work[i__ + 1] * lplus[i__ + 1] / (work[i__] *
+ lplus[i__]) * oldp;
+ } else {
+ prod *= (d__1 = lplus[i__], abs(d__1));
+ }
+ oldp = prod;
+/* Computing 2nd power */
+ d__1 = prod;
+ znm2 += d__1 * d__1;
+/* Computing MAX */
+ d__2 = tmp, d__3 = (d__1 = work[i__] * prod, abs(d__1));
+ tmp = max(d__2,d__3);
+/* L16: */
+ }
+ rrr2 = tmp / (*spdiam * sqrt(znm2));
+ if (rrr2 <= 8.) {
+ *sigma = rsigma;
+ shift = 2;
+ goto L100;
+ }
+ }
+ }
+L50:
+ if (ktry < 1) {
+/* If we are here, both shifts failed also the RRR test. */
+/* Back off to the outside */
+/* Computing MAX */
+ d__1 = lsigma - ldelta, d__2 = lsigma - ldmax;
+ lsigma = max(d__1,d__2);
+/* Computing MIN */
+ d__1 = rsigma + rdelta, d__2 = rsigma + rdmax;
+ rsigma = min(d__1,d__2);
+ ldelta *= 2.;
+ rdelta *= 2.;
+ ++ktry;
+ goto L5;
+ } else {
+/* None of the representations investigated satisfied our */
+/* criteria. Take the best one we found. */
+ if (smlgrowth < fail || nofail) {
+ lsigma = bestshift;
+ rsigma = bestshift;
+ forcer = TRUE_;
+ goto L5;
+ } else {
+ *info = 1;
+ return 0;
+ }
+ }
+L100:
+ if (shift == 1) {
+ } else if (shift == 2) {
+/* store new L and D back into DPLUS, LPLUS */
+ dcopy_(n, &work[1], &c__1, &dplus[1], &c__1);
+ i__1 = *n - 1;
+ dcopy_(&i__1, &work[*n + 1], &c__1, &lplus[1], &c__1);
+ }
+ return 0;
+
+/* End of DLARRF */
+
+} /* dlarrf_ */
diff --git a/SRC/dlarrj.c b/SRC/dlarrj.c
new file mode 100644
index 0000000..306a500
--- /dev/null
+++ b/SRC/dlarrj.c
@@ -0,0 +1,338 @@
+/* dlarrj.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlarrj_(integer *n, doublereal *d__, doublereal *e2,
+ integer *ifirst, integer *ilast, doublereal *rtol, integer *offset,
+ doublereal *w, doublereal *werr, doublereal *work, integer *iwork,
+ doublereal *pivmin, doublereal *spdiam, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double log(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, p;
+ doublereal s;
+ integer i1, i2, ii;
+ doublereal fac, mid;
+ integer cnt;
+ doublereal tmp, left;
+ integer iter, nint, prev, next, savi1;
+ doublereal right, width, dplus;
+ integer olnint, maxitr;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Given the initial eigenvalue approximations of T, DLARRJ */
+/* does bisection to refine the eigenvalues of T, */
+/* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial */
+/* guesses for these eigenvalues are input in W, the corresponding estimate */
+/* of the error in these guesses in WERR. During bisection, intervals */
+/* [left, right] are maintained by storing their mid-points and */
+/* semi-widths in the arrays W and WERR respectively. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The N diagonal elements of T. */
+
+/* E2 (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The Squares of the (N-1) subdiagonal elements of T. */
+
+/* IFIRST (input) INTEGER */
+/* The index of the first eigenvalue to be computed. */
+
+/* ILAST (input) INTEGER */
+/* The index of the last eigenvalue to be computed. */
+
+/* RTOL (input) DOUBLE PRECISION */
+/* Tolerance for the convergence of the bisection intervals. */
+/* An interval [LEFT,RIGHT] has converged if */
+/* RIGHT-LEFT.LT.RTOL*MAX(|LEFT|,|RIGHT|). */
+
+/* OFFSET (input) INTEGER */
+/* Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET */
+/* through ILAST-OFFSET elements of these arrays are to be used. */
+
+/* W (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are */
+/* estimates of the eigenvalues of L D L^T indexed IFIRST through */
+/* ILAST. */
+/* On output, these estimates are refined. */
+
+/* WERR (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are */
+/* the errors in the estimates of the corresponding elements in W. */
+/* On output, these errors are refined. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+/* Workspace. */
+
+/* IWORK (workspace) INTEGER array, dimension (2*N) */
+/* Workspace. */
+
+/* PIVMIN (input) DOUBLE PRECISION */
+/* The minimum pivot in the Sturm sequence for T. */
+
+/* SPDIAM (input) DOUBLE PRECISION */
+/* The spectral diameter of T. */
+
+/* INFO (output) INTEGER */
+/* Error flag. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --werr;
+ --w;
+ --e2;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+
+ maxitr = (integer) ((log(*spdiam + *pivmin) - log(*pivmin)) / log(2.)) +
+ 2;
+
+/* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ]. */
+/* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while */
+/* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 ) */
+/* for an unconverged interval is set to the index of the next unconverged */
+/* interval, and is -1 or 0 for a converged interval. Thus a linked */
+/* list of unconverged intervals is set up. */
+
+ i1 = *ifirst;
+ i2 = *ilast;
+/* The number of unconverged intervals */
+ nint = 0;
+/* The last unconverged interval found */
+ prev = 0;
+ i__1 = i2;
+ for (i__ = i1; i__ <= i__1; ++i__) {
+ k = i__ << 1;
+ ii = i__ - *offset;
+ left = w[ii] - werr[ii];
+ mid = w[ii];
+ right = w[ii] + werr[ii];
+ width = right - mid;
+/* Computing MAX */
+ d__1 = abs(left), d__2 = abs(right);
+ tmp = max(d__1,d__2);
+/* The following test prevents the test of converged intervals */
+ if (width < *rtol * tmp) {
+/* This interval has already converged and does not need refinement. */
+/* (Note that the gaps might change through refining the */
+/* eigenvalues, however, they can only get bigger.) */
+/* Remove it from the list. */
+ iwork[k - 1] = -1;
+/* Make sure that I1 always points to the first unconverged interval */
+ if (i__ == i1 && i__ < i2) {
+ i1 = i__ + 1;
+ }
+ if (prev >= i1 && i__ <= i2) {
+ iwork[(prev << 1) - 1] = i__ + 1;
+ }
+ } else {
+/* unconverged interval found */
+ prev = i__;
+/* Make sure that [LEFT,RIGHT] contains the desired eigenvalue */
+
+/* Do while( CNT(LEFT).GT.I-1 ) */
+
+ fac = 1.;
+L20:
+ cnt = 0;
+ s = left;
+ dplus = d__[1] - s;
+ if (dplus < 0.) {
+ ++cnt;
+ }
+ i__2 = *n;
+ for (j = 2; j <= i__2; ++j) {
+ dplus = d__[j] - s - e2[j - 1] / dplus;
+ if (dplus < 0.) {
+ ++cnt;
+ }
+/* L30: */
+ }
+ if (cnt > i__ - 1) {
+ left -= werr[ii] * fac;
+ fac *= 2.;
+ goto L20;
+ }
+
+/* Do while( CNT(RIGHT).LT.I ) */
+
+ fac = 1.;
+L50:
+ cnt = 0;
+ s = right;
+ dplus = d__[1] - s;
+ if (dplus < 0.) {
+ ++cnt;
+ }
+ i__2 = *n;
+ for (j = 2; j <= i__2; ++j) {
+ dplus = d__[j] - s - e2[j - 1] / dplus;
+ if (dplus < 0.) {
+ ++cnt;
+ }
+/* L60: */
+ }
+ if (cnt < i__) {
+ right += werr[ii] * fac;
+ fac *= 2.;
+ goto L50;
+ }
+ ++nint;
+ iwork[k - 1] = i__ + 1;
+ iwork[k] = cnt;
+ }
+ work[k - 1] = left;
+ work[k] = right;
+/* L75: */
+ }
+ savi1 = i1;
+
+/* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals */
+/* and while (ITER.LT.MAXITR) */
+
+ iter = 0;
+L80:
+ prev = i1 - 1;
+ i__ = i1;
+ olnint = nint;
+ i__1 = olnint;
+ for (p = 1; p <= i__1; ++p) {
+ k = i__ << 1;
+ ii = i__ - *offset;
+ next = iwork[k - 1];
+ left = work[k - 1];
+ right = work[k];
+ mid = (left + right) * .5;
+/* semiwidth of interval */
+ width = right - mid;
+/* Computing MAX */
+ d__1 = abs(left), d__2 = abs(right);
+ tmp = max(d__1,d__2);
+ if (width < *rtol * tmp || iter == maxitr) {
+/* reduce number of unconverged intervals */
+ --nint;
+/* Mark interval as converged. */
+ iwork[k - 1] = 0;
+ if (i1 == i__) {
+ i1 = next;
+ } else {
+/* Prev holds the last unconverged interval previously examined */
+ if (prev >= i1) {
+ iwork[(prev << 1) - 1] = next;
+ }
+ }
+ i__ = next;
+ goto L100;
+ }
+ prev = i__;
+
+/* Perform one bisection step */
+
+ cnt = 0;
+ s = mid;
+ dplus = d__[1] - s;
+ if (dplus < 0.) {
+ ++cnt;
+ }
+ i__2 = *n;
+ for (j = 2; j <= i__2; ++j) {
+ dplus = d__[j] - s - e2[j - 1] / dplus;
+ if (dplus < 0.) {
+ ++cnt;
+ }
+/* L90: */
+ }
+ if (cnt <= i__ - 1) {
+ work[k - 1] = mid;
+ } else {
+ work[k] = mid;
+ }
+ i__ = next;
+L100:
+ ;
+ }
+ ++iter;
+/* do another loop if there are still unconverged intervals */
+/* However, in the last iteration, all intervals are accepted */
+/* since this is the best we can do. */
+ if (nint > 0 && iter <= maxitr) {
+ goto L80;
+ }
+
+
+/* At this point, all the intervals have converged */
+ i__1 = *ilast;
+ for (i__ = savi1; i__ <= i__1; ++i__) {
+ k = i__ << 1;
+ ii = i__ - *offset;
+/* All intervals marked by '0' have been refined. */
+ if (iwork[k - 1] == 0) {
+ w[ii] = (work[k - 1] + work[k]) * .5;
+ werr[ii] = work[k] - w[ii];
+ }
+/* L110: */
+ }
+
+ return 0;
+
+/* End of DLARRJ */
+
+} /* dlarrj_ */
diff --git a/SRC/dlarrk.c b/SRC/dlarrk.c
new file mode 100644
index 0000000..aab5fc3
--- /dev/null
+++ b/SRC/dlarrk.c
@@ -0,0 +1,193 @@
+/* dlarrk.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlarrk_(integer *n, integer *iw, doublereal *gl,
+ doublereal *gu, doublereal *d__, doublereal *e2, doublereal *pivmin,
+ doublereal *reltol, doublereal *w, doublereal *werr, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double log(doublereal);
+
+ /* Local variables */
+ integer i__, it;
+ doublereal mid, eps, tmp1, tmp2, left, atoli, right;
+ integer itmax;
+ doublereal rtoli, tnorm;
+ extern doublereal dlamch_(char *);
+ integer negcnt;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARRK computes one eigenvalue of a symmetric tridiagonal */
+/* matrix T to suitable accuracy. This is an auxiliary code to be */
+/* called from DSTEMR. */
+
+/* To avoid overflow, the matrix must be scaled so that its */
+/* largest element is no greater than overflow**(1/2) * */
+/* underflow**(1/4) in absolute value, and for greatest */
+/* accuracy, it should not be much smaller than that. */
+
+/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */
+/* Matrix", Report CS41, Computer Science Dept., Stanford */
+/* University, July 21, 1966. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the tridiagonal matrix T. N >= 0. */
+
+/* IW (input) INTEGER */
+/* The index of the eigenvalues to be returned. */
+
+/* GL (input) DOUBLE PRECISION */
+/* GU (input) DOUBLE PRECISION */
+/* An upper and a lower bound on the eigenvalue. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix T. */
+
+/* E2 (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) squared off-diagonal elements of the tridiagonal matrix T. */
+
+/* PIVMIN (input) DOUBLE PRECISION */
+/* The minimum pivot allowed in the Sturm sequence for T. */
+
+/* RELTOL (input) DOUBLE PRECISION */
+/* The minimum relative width of an interval. When an interval */
+/* is narrower than RELTOL times the larger (in */
+/* magnitude) endpoint, then it is considered to be */
+/* sufficiently small, i.e., converged. Note: this should */
+/* always be at least radix*machine epsilon. */
+
+/* W (output) DOUBLE PRECISION */
+
+/* WERR (output) DOUBLE PRECISION */
+/* The error bound on the corresponding eigenvalue approximation */
+/* in W. */
+
+/* INFO (output) INTEGER */
+/* = 0: Eigenvalue converged */
+/* = -1: Eigenvalue did NOT converge */
+
+/* Internal Parameters */
+/* =================== */
+
+/* FUDGE DOUBLE PRECISION, default = 2 */
+/* A "fudge factor" to widen the Gershgorin intervals. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Get machine constants */
+ /* Parameter adjustments */
+ --e2;
+ --d__;
+
+ /* Function Body */
+ eps = dlamch_("P");
+/* Computing MAX */
+ d__1 = abs(*gl), d__2 = abs(*gu);
+ tnorm = max(d__1,d__2);
+ rtoli = *reltol;
+ atoli = *pivmin * 4.;
+ itmax = (integer) ((log(tnorm + *pivmin) - log(*pivmin)) / log(2.)) + 2;
+ *info = -1;
+ left = *gl - tnorm * 2. * eps * *n - *pivmin * 4.;
+ right = *gu + tnorm * 2. * eps * *n + *pivmin * 4.;
+ it = 0;
+L10:
+
+/* Check if interval converged or maximum number of iterations reached */
+
+ tmp1 = (d__1 = right - left, abs(d__1));
+/* Computing MAX */
+ d__1 = abs(right), d__2 = abs(left);
+ tmp2 = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = max(atoli,*pivmin), d__2 = rtoli * tmp2;
+ if (tmp1 < max(d__1,d__2)) {
+ *info = 0;
+ goto L30;
+ }
+ if (it > itmax) {
+ goto L30;
+ }
+
+/* Count number of negative pivots for mid-point */
+
+ ++it;
+ mid = (left + right) * .5;
+ negcnt = 0;
+ tmp1 = d__[1] - mid;
+ if (abs(tmp1) < *pivmin) {
+ tmp1 = -(*pivmin);
+ }
+ if (tmp1 <= 0.) {
+ ++negcnt;
+ }
+
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ tmp1 = d__[i__] - e2[i__ - 1] / tmp1 - mid;
+ if (abs(tmp1) < *pivmin) {
+ tmp1 = -(*pivmin);
+ }
+ if (tmp1 <= 0.) {
+ ++negcnt;
+ }
+/* L20: */
+ }
+ if (negcnt >= *iw) {
+ right = mid;
+ } else {
+ left = mid;
+ }
+ goto L10;
+L30:
+
+/* Converged or maximum number of iterations reached */
+
+ *w = (left + right) * .5;
+ *werr = (d__1 = right - left, abs(d__1)) * .5;
+ return 0;
+
+/* End of DLARRK */
+
+} /* dlarrk_ */
diff --git a/SRC/dlarrr.c b/SRC/dlarrr.c
new file mode 100644
index 0000000..adb0133
--- /dev/null
+++ b/SRC/dlarrr.c
@@ -0,0 +1,176 @@
+/* dlarrr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlarrr_(integer *n, doublereal *d__, doublereal *e,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal eps, tmp, tmp2, rmin;
+ extern doublereal dlamch_(char *);
+ doublereal offdig, safmin;
+ logical yesrel;
+ doublereal smlnum, offdig2;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+
+/* Purpose */
+/* ======= */
+
+/* Perform tests to decide whether the symmetric tridiagonal matrix T */
+/* warrants expensive computations which guarantee high relative accuracy */
+/* in the eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N > 0. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The N diagonal elements of the tridiagonal matrix T. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the first (N-1) entries contain the subdiagonal */
+/* elements of the tridiagonal matrix T; E(N) is set to ZERO. */
+
+/* INFO (output) INTEGER */
+/* INFO = 0(default) : the matrix warrants computations preserving */
+/* relative accuracy. */
+/* INFO = 1 : the matrix warrants computations guaranteeing */
+/* only absolute accuracy. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* As a default, do NOT go for relative-accuracy preserving computations. */
+ /* Parameter adjustments */
+ --e;
+ --d__;
+
+ /* Function Body */
+ *info = 1;
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ rmin = sqrt(smlnum);
+/* Tests for relative accuracy */
+
+/* Test for scaled diagonal dominance */
+/* Scale the diagonal entries to one and check whether the sum of the */
+/* off-diagonals is less than one */
+
+/* The sdd relative error bounds have a 1/(1- 2*x) factor in them, */
+/* x = max(OFFDIG + OFFDIG2), so when x is close to 1/2, no relative */
+/* accuracy is promised. In the notation of the code fragment below, */
+/* 1/(1 - (OFFDIG + OFFDIG2)) is the condition number. */
+/* We don't think it is worth going into "sdd mode" unless the relative */
+/* condition number is reasonable, not 1/macheps. */
+/* The threshold should be compatible with other thresholds used in the */
+/* code. We set OFFDIG + OFFDIG2 <= .999 =: RELCOND, it corresponds */
+/* to losing at most 3 decimal digits: 1 / (1 - (OFFDIG + OFFDIG2)) <= 1000 */
+/* instead of the current OFFDIG + OFFDIG2 < 1 */
+
+ yesrel = TRUE_;
+ offdig = 0.;
+ tmp = sqrt((abs(d__[1])));
+ if (tmp < rmin) {
+ yesrel = FALSE_;
+ }
+ if (! yesrel) {
+ goto L11;
+ }
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ tmp2 = sqrt((d__1 = d__[i__], abs(d__1)));
+ if (tmp2 < rmin) {
+ yesrel = FALSE_;
+ }
+ if (! yesrel) {
+ goto L11;
+ }
+ offdig2 = (d__1 = e[i__ - 1], abs(d__1)) / (tmp * tmp2);
+ if (offdig + offdig2 >= .999) {
+ yesrel = FALSE_;
+ }
+ if (! yesrel) {
+ goto L11;
+ }
+ tmp = tmp2;
+ offdig = offdig2;
+/* L10: */
+ }
+L11:
+ if (yesrel) {
+ *info = 0;
+ return 0;
+ } else {
+ }
+
+
+/* *** MORE TO BE IMPLEMENTED *** */
+
+
+/* Test if the lower bidiagonal matrix L from T = L D L^T */
+/* (zero shift facto) is well conditioned */
+
+
+/* Test if the upper bidiagonal matrix U from T = U D U^T */
+/* (zero shift facto) is well conditioned. */
+/* In this case, the matrix needs to be flipped and, at the end */
+/* of the eigenvector computation, the flip needs to be applied */
+/* to the computed eigenvectors (and the support) */
+
+
+ return 0;
+
+/* END OF DLARRR */
+
+} /* dlarrr_ */
diff --git a/SRC/dlarrv.c b/SRC/dlarrv.c
new file mode 100644
index 0000000..4b80eec
--- /dev/null
+++ b/SRC/dlarrv.c
@@ -0,0 +1,988 @@
+/* dlarrv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b5 = 0.;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int dlarrv_(integer *n, doublereal *vl, doublereal *vu,
+ doublereal *d__, doublereal *l, doublereal *pivmin, integer *isplit,
+ integer *m, integer *dol, integer *dou, doublereal *minrgp,
+ doublereal *rtol1, doublereal *rtol2, doublereal *w, doublereal *werr,
+ doublereal *wgap, integer *iblock, integer *indexw, doublereal *gers,
+ doublereal *z__, integer *ldz, integer *isuppz, doublereal *work,
+ integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2;
+ logical L__1;
+
+ /* Builtin functions */
+ double log(doublereal);
+
+ /* Local variables */
+ integer minwsize, i__, j, k, p, q, miniwsize, ii;
+ doublereal gl;
+ integer im, in;
+ doublereal gu, gap, eps, tau, tol, tmp;
+ integer zto;
+ doublereal ztz;
+ integer iend, jblk;
+ doublereal lgap;
+ integer done;
+ doublereal rgap, left;
+ integer wend, iter;
+ doublereal bstw;
+ integer itmp1;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ integer indld;
+ doublereal fudge;
+ integer idone;
+ doublereal sigma;
+ integer iinfo, iindr;
+ doublereal resid;
+ logical eskip;
+ doublereal right;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer nclus, zfrom;
+ doublereal rqtol;
+ integer iindc1, iindc2;
+ extern /* Subroutine */ int dlar1v_(integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, logical *,
+ integer *, doublereal *, doublereal *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *);
+ logical stp2ii;
+ doublereal lambda;
+ extern doublereal dlamch_(char *);
+ integer ibegin, indeig;
+ logical needbs;
+ integer indlld;
+ doublereal sgndef, mingma;
+ extern /* Subroutine */ int dlarrb_(integer *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *);
+ integer oldien, oldncl, wbegin;
+ doublereal spdiam;
+ integer negcnt;
+ extern /* Subroutine */ int dlarrf_(integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *);
+ integer oldcls;
+ doublereal savgap;
+ integer ndepth;
+ doublereal ssigma;
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ logical usedbs;
+ integer iindwk, offset;
+ doublereal gaptol;
+ integer newcls, oldfst, indwrk, windex, oldlst;
+ logical usedrq;
+ integer newfst, newftt, parity, windmn, windpl, isupmn, newlst, zusedl;
+ doublereal bstres;
+ integer newsiz, zusedu, zusedw;
+ doublereal nrminv, rqcorr;
+ logical tryrqc;
+ integer isupmx;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARRV computes the eigenvectors of the tridiagonal matrix */
+/* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T. */
+/* The input eigenvalues should have been computed by DLARRE. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* Lower and upper bounds of the interval that contains the desired */
+/* eigenvalues. VL < VU. Needed to compute gaps on the left or right */
+/* end of the extremal eigenvalues in the desired RANGE. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the N diagonal elements of the diagonal matrix D. */
+/* On exit, D may be overwritten. */
+
+/* L (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the (N-1) subdiagonal elements of the unit */
+/* bidiagonal matrix L are in elements 1 to N-1 of L */
+/* (if the matrix is not splitted.) At the end of each block */
+/* is stored the corresponding shift as given by DLARRE. */
+/* On exit, L is overwritten. */
+
+/* PIVMIN (in) DOUBLE PRECISION */
+/* The minimum pivot allowed in the Sturm sequence. */
+
+/* ISPLIT (input) INTEGER array, dimension (N) */
+/* The splitting points, at which T breaks up into blocks. */
+/* The first block consists of rows/columns 1 to */
+/* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 */
+/* through ISPLIT( 2 ), etc. */
+
+/* M (input) INTEGER */
+/* The total number of input eigenvalues. 0 <= M <= N. */
+
+/* DOL (input) INTEGER */
+/* DOU (input) INTEGER */
+/* If the user wants to compute only selected eigenvectors from all */
+/* the eigenvalues supplied, he can specify an index range DOL:DOU. */
+/* Or else the setting DOL=1, DOU=M should be applied. */
+/* Note that DOL and DOU refer to the order in which the eigenvalues */
+/* are stored in W. */
+/* If the user wants to compute only selected eigenpairs, then */
+/* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the */
+/* computed eigenvectors. All other columns of Z are set to zero. */
+
+/* MINRGP (input) DOUBLE PRECISION */
+
+/* RTOL1 (input) DOUBLE PRECISION */
+/* RTOL2 (input) DOUBLE PRECISION */
+/* Parameters for bisection. */
+/* An interval [LEFT,RIGHT] has converged if */
+/* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */
+
+/* W (input/output) DOUBLE PRECISION array, dimension (N) */
+/* The first M elements of W contain the APPROXIMATE eigenvalues for */
+/* which eigenvectors are to be computed. The eigenvalues */
+/* should be grouped by split-off block and ordered from */
+/* smallest to largest within the block ( The output array */
+/* W from DLARRE is expected here ). Furthermore, they are with */
+/* respect to the shift of the corresponding root representation */
+/* for their block. On exit, W holds the eigenvalues of the */
+/* UNshifted matrix. */
+
+/* WERR (input/output) DOUBLE PRECISION array, dimension (N) */
+/* The first M elements contain the semiwidth of the uncertainty */
+/* interval of the corresponding eigenvalue in W */
+
+/* WGAP (input/output) DOUBLE PRECISION array, dimension (N) */
+/* The separation from the right neighbor eigenvalue in W. */
+
+/* IBLOCK (input) INTEGER array, dimension (N) */
+/* The indices of the blocks (submatrices) associated with the */
+/* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue */
+/* W(i) belongs to the first block from the top, =2 if W(i) */
+/* belongs to the second block, etc. */
+
+/* INDEXW (input) INTEGER array, dimension (N) */
+/* The indices of the eigenvalues within each block (submatrix); */
+/* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the */
+/* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block. */
+
+/* GERS (input) DOUBLE PRECISION array, dimension (2*N) */
+/* The N Gerschgorin intervals (the i-th Gerschgorin interval */
+/* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should */
+/* be computed from the original UNshifted matrix. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) */
+/* If INFO = 0, the first M columns of Z contain the */
+/* orthonormal eigenvectors of the matrix T */
+/* corresponding to the input eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */
+/* The support of the eigenvectors in Z, i.e., the indices */
+/* indicating the nonzero elements in Z. The I-th eigenvector */
+/* is nonzero only in elements ISUPPZ( 2*I-1 ) through */
+/* ISUPPZ( 2*I ). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (12*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (7*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+
+/* > 0: A problem occured in DLARRV. */
+/* < 0: One of the called subroutines signaled an internal problem. */
+/* Needs inspection of the corresponding parameter IINFO */
+/* for further information. */
+
+/* =-1: Problem in DLARRB when refining a child's eigenvalues. */
+/* =-2: Problem in DLARRF when computing the RRR of a child. */
+/* When a child is inside a tight cluster, it can be difficult */
+/* to find an RRR. A partial remedy from the user's point of */
+/* view is to make the parameter MINRGP smaller and recompile. */
+/* However, as the orthogonality of the computed vectors is */
+/* proportional to 1/MINRGP, the user should be aware that */
+/* he might be trading in precision when he decreases MINRGP. */
+/* =-3: Problem in DLARRB when refining a single eigenvalue */
+/* after the Rayleigh correction was rejected. */
+/* = 5: The Rayleigh Quotient Iteration failed to converge to */
+/* full accuracy in MAXITR steps. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+/* .. */
+/* The first N entries of WORK are reserved for the eigenvalues */
+ /* Parameter adjustments */
+ --d__;
+ --l;
+ --isplit;
+ --w;
+ --werr;
+ --wgap;
+ --iblock;
+ --indexw;
+ --gers;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --isuppz;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ indld = *n + 1;
+ indlld = (*n << 1) + 1;
+ indwrk = *n * 3 + 1;
+ minwsize = *n * 12;
+ i__1 = minwsize;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L5: */
+ }
+/* IWORK(IINDR+1:IINDR+N) hold the twist indices R for the */
+/* factorization used to compute the FP vector */
+ iindr = 0;
+/* IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current */
+/* layer and the one above. */
+ iindc1 = *n;
+ iindc2 = *n << 1;
+ iindwk = *n * 3 + 1;
+ miniwsize = *n * 7;
+ i__1 = miniwsize;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ iwork[i__] = 0;
+/* L10: */
+ }
+ zusedl = 1;
+ if (*dol > 1) {
+/* Set lower bound for use of Z */
+ zusedl = *dol - 1;
+ }
+ zusedu = *m;
+ if (*dou < *m) {
+/* Set lower bound for use of Z */
+ zusedu = *dou + 1;
+ }
+/* The width of the part of Z that is used */
+ zusedw = zusedu - zusedl + 1;
+ dlaset_("Full", n, &zusedw, &c_b5, &c_b5, &z__[zusedl * z_dim1 + 1], ldz);
+ eps = dlamch_("Precision");
+ rqtol = eps * 2.;
+
+/* Set expert flags for standard code. */
+ tryrqc = TRUE_;
+ if (*dol == 1 && *dou == *m) {
+ } else {
+/* Only selected eigenpairs are computed. Since the other evalues */
+/* are not refined by RQ iteration, bisection has to compute to full */
+/* accuracy. */
+ *rtol1 = eps * 4.;
+ *rtol2 = eps * 4.;
+ }
+/* The entries WBEGIN:WEND in W, WERR, WGAP correspond to the */
+/* desired eigenvalues. The support of the nonzero eigenvector */
+/* entries is contained in the interval IBEGIN:IEND. */
+/* Remark that if k eigenpairs are desired, then the eigenvectors */
+/* are stored in k contiguous columns of Z. */
+/* DONE is the number of eigenvectors already computed */
+ done = 0;
+ ibegin = 1;
+ wbegin = 1;
+ i__1 = iblock[*m];
+ for (jblk = 1; jblk <= i__1; ++jblk) {
+ iend = isplit[jblk];
+ sigma = l[iend];
+/* Find the eigenvectors of the submatrix indexed IBEGIN */
+/* through IEND. */
+ wend = wbegin - 1;
+L15:
+ if (wend < *m) {
+ if (iblock[wend + 1] == jblk) {
+ ++wend;
+ goto L15;
+ }
+ }
+ if (wend < wbegin) {
+ ibegin = iend + 1;
+ goto L170;
+ } else if (wend < *dol || wbegin > *dou) {
+ ibegin = iend + 1;
+ wbegin = wend + 1;
+ goto L170;
+ }
+/* Find local spectral diameter of the block */
+ gl = gers[(ibegin << 1) - 1];
+ gu = gers[ibegin * 2];
+ i__2 = iend;
+ for (i__ = ibegin + 1; i__ <= i__2; ++i__) {
+/* Computing MIN */
+ d__1 = gers[(i__ << 1) - 1];
+ gl = min(d__1,gl);
+/* Computing MAX */
+ d__1 = gers[i__ * 2];
+ gu = max(d__1,gu);
+/* L20: */
+ }
+ spdiam = gu - gl;
+/* OLDIEN is the last index of the previous block */
+ oldien = ibegin - 1;
+/* Calculate the size of the current block */
+ in = iend - ibegin + 1;
+/* The number of eigenvalues in the current block */
+ im = wend - wbegin + 1;
+/* This is for a 1x1 block */
+ if (ibegin == iend) {
+ ++done;
+ z__[ibegin + wbegin * z_dim1] = 1.;
+ isuppz[(wbegin << 1) - 1] = ibegin;
+ isuppz[wbegin * 2] = ibegin;
+ w[wbegin] += sigma;
+ work[wbegin] = w[wbegin];
+ ibegin = iend + 1;
+ ++wbegin;
+ goto L170;
+ }
+/* The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND) */
+/* Note that these can be approximations, in this case, the corresp. */
+/* entries of WERR give the size of the uncertainty interval. */
+/* The eigenvalue approximations will be refined when necessary as */
+/* high relative accuracy is required for the computation of the */
+/* corresponding eigenvectors. */
+ dcopy_(&im, &w[wbegin], &c__1, &work[wbegin], &c__1);
+/* We store in W the eigenvalue approximations w.r.t. the original */
+/* matrix T. */
+ i__2 = im;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ w[wbegin + i__ - 1] += sigma;
+/* L30: */
+ }
+/* NDEPTH is the current depth of the representation tree */
+ ndepth = 0;
+/* PARITY is either 1 or 0 */
+ parity = 1;
+/* NCLUS is the number of clusters for the next level of the */
+/* representation tree, we start with NCLUS = 1 for the root */
+ nclus = 1;
+ iwork[iindc1 + 1] = 1;
+ iwork[iindc1 + 2] = im;
+/* IDONE is the number of eigenvectors already computed in the current */
+/* block */
+ idone = 0;
+/* loop while( IDONE.LT.IM ) */
+/* generate the representation tree for the current block and */
+/* compute the eigenvectors */
+L40:
+ if (idone < im) {
+/* This is a crude protection against infinitely deep trees */
+ if (ndepth > *m) {
+ *info = -2;
+ return 0;
+ }
+/* breadth first processing of the current level of the representation */
+/* tree: OLDNCL = number of clusters on current level */
+ oldncl = nclus;
+/* reset NCLUS to count the number of child clusters */
+ nclus = 0;
+
+ parity = 1 - parity;
+ if (parity == 0) {
+ oldcls = iindc1;
+ newcls = iindc2;
+ } else {
+ oldcls = iindc2;
+ newcls = iindc1;
+ }
+/* Process the clusters on the current level */
+ i__2 = oldncl;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ j = oldcls + (i__ << 1);
+/* OLDFST, OLDLST = first, last index of current cluster. */
+/* cluster indices start with 1 and are relative */
+/* to WBEGIN when accessing W, WGAP, WERR, Z */
+ oldfst = iwork[j - 1];
+ oldlst = iwork[j];
+ if (ndepth > 0) {
+/* Retrieve relatively robust representation (RRR) of cluster */
+/* that has been computed at the previous level */
+/* The RRR is stored in Z and overwritten once the eigenvectors */
+/* have been computed or when the cluster is refined */
+ if (*dol == 1 && *dou == *m) {
+/* Get representation from location of the leftmost evalue */
+/* of the cluster */
+ j = wbegin + oldfst - 1;
+ } else {
+ if (wbegin + oldfst - 1 < *dol) {
+/* Get representation from the left end of Z array */
+ j = *dol - 1;
+ } else if (wbegin + oldfst - 1 > *dou) {
+/* Get representation from the right end of Z array */
+ j = *dou;
+ } else {
+ j = wbegin + oldfst - 1;
+ }
+ }
+ dcopy_(&in, &z__[ibegin + j * z_dim1], &c__1, &d__[ibegin]
+, &c__1);
+ i__3 = in - 1;
+ dcopy_(&i__3, &z__[ibegin + (j + 1) * z_dim1], &c__1, &l[
+ ibegin], &c__1);
+ sigma = z__[iend + (j + 1) * z_dim1];
+/* Set the corresponding entries in Z to zero */
+ dlaset_("Full", &in, &c__2, &c_b5, &c_b5, &z__[ibegin + j
+ * z_dim1], ldz);
+ }
+/* Compute DL and DLL of current RRR */
+ i__3 = iend - 1;
+ for (j = ibegin; j <= i__3; ++j) {
+ tmp = d__[j] * l[j];
+ work[indld - 1 + j] = tmp;
+ work[indlld - 1 + j] = tmp * l[j];
+/* L50: */
+ }
+ if (ndepth > 0) {
+/* P and Q are index of the first and last eigenvalue to compute */
+/* within the current block */
+ p = indexw[wbegin - 1 + oldfst];
+ q = indexw[wbegin - 1 + oldlst];
+/* Offset for the arrays WORK, WGAP and WERR, i.e., th P-OFFSET */
+/* thru' Q-OFFSET elements of these arrays are to be used. */
+/* OFFSET = P-OLDFST */
+ offset = indexw[wbegin] - 1;
+/* perform limited bisection (if necessary) to get approximate */
+/* eigenvalues to the precision needed. */
+ dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin - 1], &p,
+ &q, rtol1, rtol2, &offset, &work[wbegin], &wgap[
+ wbegin], &werr[wbegin], &work[indwrk], &iwork[
+ iindwk], pivmin, &spdiam, &in, &iinfo);
+ if (iinfo != 0) {
+ *info = -1;
+ return 0;
+ }
+/* We also recompute the extremal gaps. W holds all eigenvalues */
+/* of the unshifted matrix and must be used for computation */
+/* of WGAP, the entries of WORK might stem from RRRs with */
+/* different shifts. The gaps from WBEGIN-1+OLDFST to */
+/* WBEGIN-1+OLDLST are correctly computed in DLARRB. */
+/* However, we only allow the gaps to become greater since */
+/* this is what should happen when we decrease WERR */
+ if (oldfst > 1) {
+/* Computing MAX */
+ d__1 = wgap[wbegin + oldfst - 2], d__2 = w[wbegin +
+ oldfst - 1] - werr[wbegin + oldfst - 1] - w[
+ wbegin + oldfst - 2] - werr[wbegin + oldfst -
+ 2];
+ wgap[wbegin + oldfst - 2] = max(d__1,d__2);
+ }
+ if (wbegin + oldlst - 1 < wend) {
+/* Computing MAX */
+ d__1 = wgap[wbegin + oldlst - 1], d__2 = w[wbegin +
+ oldlst] - werr[wbegin + oldlst] - w[wbegin +
+ oldlst - 1] - werr[wbegin + oldlst - 1];
+ wgap[wbegin + oldlst - 1] = max(d__1,d__2);
+ }
+/* Each time the eigenvalues in WORK get refined, we store */
+/* the newly found approximation with all shifts applied in W */
+ i__3 = oldlst;
+ for (j = oldfst; j <= i__3; ++j) {
+ w[wbegin + j - 1] = work[wbegin + j - 1] + sigma;
+/* L53: */
+ }
+ }
+/* Process the current node. */
+ newfst = oldfst;
+ i__3 = oldlst;
+ for (j = oldfst; j <= i__3; ++j) {
+ if (j == oldlst) {
+/* we are at the right end of the cluster, this is also the */
+/* boundary of the child cluster */
+ newlst = j;
+ } else if (wgap[wbegin + j - 1] >= *minrgp * (d__1 = work[
+ wbegin + j - 1], abs(d__1))) {
+/* the right relative gap is big enough, the child cluster */
+/* (NEWFST,..,NEWLST) is well separated from the following */
+ newlst = j;
+ } else {
+/* inside a child cluster, the relative gap is not */
+/* big enough. */
+ goto L140;
+ }
+/* Compute size of child cluster found */
+ newsiz = newlst - newfst + 1;
+/* NEWFTT is the place in Z where the new RRR or the computed */
+/* eigenvector is to be stored */
+ if (*dol == 1 && *dou == *m) {
+/* Store representation at location of the leftmost evalue */
+/* of the cluster */
+ newftt = wbegin + newfst - 1;
+ } else {
+ if (wbegin + newfst - 1 < *dol) {
+/* Store representation at the left end of Z array */
+ newftt = *dol - 1;
+ } else if (wbegin + newfst - 1 > *dou) {
+/* Store representation at the right end of Z array */
+ newftt = *dou;
+ } else {
+ newftt = wbegin + newfst - 1;
+ }
+ }
+ if (newsiz > 1) {
+
+/* Current child is not a singleton but a cluster. */
+/* Compute and store new representation of child. */
+
+
+/* Compute left and right cluster gap. */
+
+/* LGAP and RGAP are not computed from WORK because */
+/* the eigenvalue approximations may stem from RRRs */
+/* different shifts. However, W hold all eigenvalues */
+/* of the unshifted matrix. Still, the entries in WGAP */
+/* have to be computed from WORK since the entries */
+/* in W might be of the same order so that gaps are not */
+/* exhibited correctly for very close eigenvalues. */
+ if (newfst == 1) {
+/* Computing MAX */
+ d__1 = 0., d__2 = w[wbegin] - werr[wbegin] - *vl;
+ lgap = max(d__1,d__2);
+ } else {
+ lgap = wgap[wbegin + newfst - 2];
+ }
+ rgap = wgap[wbegin + newlst - 1];
+
+/* Compute left- and rightmost eigenvalue of child */
+/* to high precision in order to shift as close */
+/* as possible and obtain as large relative gaps */
+/* as possible */
+
+ for (k = 1; k <= 2; ++k) {
+ if (k == 1) {
+ p = indexw[wbegin - 1 + newfst];
+ } else {
+ p = indexw[wbegin - 1 + newlst];
+ }
+ offset = indexw[wbegin] - 1;
+ dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin
+ - 1], &p, &p, &rqtol, &rqtol, &offset, &
+ work[wbegin], &wgap[wbegin], &werr[wbegin]
+, &work[indwrk], &iwork[iindwk], pivmin, &
+ spdiam, &in, &iinfo);
+/* L55: */
+ }
+
+ if (wbegin + newlst - 1 < *dol || wbegin + newfst - 1
+ > *dou) {
+/* if the cluster contains no desired eigenvalues */
+/* skip the computation of that branch of the rep. tree */
+
+/* We could skip before the refinement of the extremal */
+/* eigenvalues of the child, but then the representation */
+/* tree could be different from the one when nothing is */
+/* skipped. For this reason we skip at this place. */
+ idone = idone + newlst - newfst + 1;
+ goto L139;
+ }
+
+/* Compute RRR of child cluster. */
+/* Note that the new RRR is stored in Z */
+
+/* DLARRF needs LWORK = 2*N */
+ dlarrf_(&in, &d__[ibegin], &l[ibegin], &work[indld +
+ ibegin - 1], &newfst, &newlst, &work[wbegin],
+ &wgap[wbegin], &werr[wbegin], &spdiam, &lgap,
+ &rgap, pivmin, &tau, &z__[ibegin + newftt *
+ z_dim1], &z__[ibegin + (newftt + 1) * z_dim1],
+ &work[indwrk], &iinfo);
+ if (iinfo == 0) {
+/* a new RRR for the cluster was found by DLARRF */
+/* update shift and store it */
+ ssigma = sigma + tau;
+ z__[iend + (newftt + 1) * z_dim1] = ssigma;
+/* WORK() are the midpoints and WERR() the semi-width */
+/* Note that the entries in W are unchanged. */
+ i__4 = newlst;
+ for (k = newfst; k <= i__4; ++k) {
+ fudge = eps * 3. * (d__1 = work[wbegin + k -
+ 1], abs(d__1));
+ work[wbegin + k - 1] -= tau;
+ fudge += eps * 4. * (d__1 = work[wbegin + k -
+ 1], abs(d__1));
+/* Fudge errors */
+ werr[wbegin + k - 1] += fudge;
+/* Gaps are not fudged. Provided that WERR is small */
+/* when eigenvalues are close, a zero gap indicates */
+/* that a new representation is needed for resolving */
+/* the cluster. A fudge could lead to a wrong decision */
+/* of judging eigenvalues 'separated' which in */
+/* reality are not. This could have a negative impact */
+/* on the orthogonality of the computed eigenvectors. */
+/* L116: */
+ }
+ ++nclus;
+ k = newcls + (nclus << 1);
+ iwork[k - 1] = newfst;
+ iwork[k] = newlst;
+ } else {
+ *info = -2;
+ return 0;
+ }
+ } else {
+
+/* Compute eigenvector of singleton */
+
+ iter = 0;
+
+ tol = log((doublereal) in) * 4. * eps;
+
+ k = newfst;
+ windex = wbegin + k - 1;
+/* Computing MAX */
+ i__4 = windex - 1;
+ windmn = max(i__4,1);
+/* Computing MIN */
+ i__4 = windex + 1;
+ windpl = min(i__4,*m);
+ lambda = work[windex];
+ ++done;
+/* Check if eigenvector computation is to be skipped */
+ if (windex < *dol || windex > *dou) {
+ eskip = TRUE_;
+ goto L125;
+ } else {
+ eskip = FALSE_;
+ }
+ left = work[windex] - werr[windex];
+ right = work[windex] + werr[windex];
+ indeig = indexw[windex];
+/* Note that since we compute the eigenpairs for a child, */
+/* all eigenvalue approximations are w.r.t the same shift. */
+/* In this case, the entries in WORK should be used for */
+/* computing the gaps since they exhibit even very small */
+/* differences in the eigenvalues, as opposed to the */
+/* entries in W which might "look" the same. */
+ if (k == 1) {
+/* In the case RANGE='I' and with not much initial */
+/* accuracy in LAMBDA and VL, the formula */
+/* LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA ) */
+/* can lead to an overestimation of the left gap and */
+/* thus to inadequately early RQI 'convergence'. */
+/* Prevent this by forcing a small left gap. */
+/* Computing MAX */
+ d__1 = abs(left), d__2 = abs(right);
+ lgap = eps * max(d__1,d__2);
+ } else {
+ lgap = wgap[windmn];
+ }
+ if (k == im) {
+/* In the case RANGE='I' and with not much initial */
+/* accuracy in LAMBDA and VU, the formula */
+/* can lead to an overestimation of the right gap and */
+/* thus to inadequately early RQI 'convergence'. */
+/* Prevent this by forcing a small right gap. */
+/* Computing MAX */
+ d__1 = abs(left), d__2 = abs(right);
+ rgap = eps * max(d__1,d__2);
+ } else {
+ rgap = wgap[windex];
+ }
+ gap = min(lgap,rgap);
+ if (k == 1 || k == im) {
+/* The eigenvector support can become wrong */
+/* because significant entries could be cut off due to a */
+/* large GAPTOL parameter in LAR1V. Prevent this. */
+ gaptol = 0.;
+ } else {
+ gaptol = gap * eps;
+ }
+ isupmn = in;
+ isupmx = 1;
+/* Update WGAP so that it holds the minimum gap */
+/* to the left or the right. This is crucial in the */
+/* case where bisection is used to ensure that the */
+/* eigenvalue is refined up to the required precision. */
+/* The correct value is restored afterwards. */
+ savgap = wgap[windex];
+ wgap[windex] = gap;
+/* We want to use the Rayleigh Quotient Correction */
+/* as often as possible since it converges quadratically */
+/* when we are close enough to the desired eigenvalue. */
+/* However, the Rayleigh Quotient can have the wrong sign */
+/* and lead us away from the desired eigenvalue. In this */
+/* case, the best we can do is to use bisection. */
+ usedbs = FALSE_;
+ usedrq = FALSE_;
+/* Bisection is initially turned off unless it is forced */
+ needbs = ! tryrqc;
+L120:
+/* Check if bisection should be used to refine eigenvalue */
+ if (needbs) {
+/* Take the bisection as new iterate */
+ usedbs = TRUE_;
+ itmp1 = iwork[iindr + windex];
+ offset = indexw[wbegin] - 1;
+ d__1 = eps * 2.;
+ dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin
+ - 1], &indeig, &indeig, &c_b5, &d__1, &
+ offset, &work[wbegin], &wgap[wbegin], &
+ werr[wbegin], &work[indwrk], &iwork[
+ iindwk], pivmin, &spdiam, &itmp1, &iinfo);
+ if (iinfo != 0) {
+ *info = -3;
+ return 0;
+ }
+ lambda = work[windex];
+/* Reset twist index from inaccurate LAMBDA to */
+/* force computation of true MINGMA */
+ iwork[iindr + windex] = 0;
+ }
+/* Given LAMBDA, compute the eigenvector. */
+ L__1 = ! usedbs;
+ dlar1v_(&in, &c__1, &in, &lambda, &d__[ibegin], &l[
+ ibegin], &work[indld + ibegin - 1], &work[
+ indlld + ibegin - 1], pivmin, &gaptol, &z__[
+ ibegin + windex * z_dim1], &L__1, &negcnt, &
+ ztz, &mingma, &iwork[iindr + windex], &isuppz[
+ (windex << 1) - 1], &nrminv, &resid, &rqcorr,
+ &work[indwrk]);
+ if (iter == 0) {
+ bstres = resid;
+ bstw = lambda;
+ } else if (resid < bstres) {
+ bstres = resid;
+ bstw = lambda;
+ }
+/* Computing MIN */
+ i__4 = isupmn, i__5 = isuppz[(windex << 1) - 1];
+ isupmn = min(i__4,i__5);
+/* Computing MAX */
+ i__4 = isupmx, i__5 = isuppz[windex * 2];
+ isupmx = max(i__4,i__5);
+ ++iter;
+/* sin alpha <= |resid|/gap */
+/* Note that both the residual and the gap are */
+/* proportional to the matrix, so ||T|| doesn't play */
+/* a role in the quotient */
+
+/* Convergence test for Rayleigh-Quotient iteration */
+/* (omitted when Bisection has been used) */
+
+ if (resid > tol * gap && abs(rqcorr) > rqtol * abs(
+ lambda) && ! usedbs) {
+/* We need to check that the RQCORR update doesn't */
+/* move the eigenvalue away from the desired one and */
+/* towards a neighbor. -> protection with bisection */
+ if (indeig <= negcnt) {
+/* The wanted eigenvalue lies to the left */
+ sgndef = -1.;
+ } else {
+/* The wanted eigenvalue lies to the right */
+ sgndef = 1.;
+ }
+/* We only use the RQCORR if it improves the */
+/* the iterate reasonably. */
+ if (rqcorr * sgndef >= 0. && lambda + rqcorr <=
+ right && lambda + rqcorr >= left) {
+ usedrq = TRUE_;
+/* Store new midpoint of bisection interval in WORK */
+ if (sgndef == 1.) {
+/* The current LAMBDA is on the left of the true */
+/* eigenvalue */
+ left = lambda;
+/* We prefer to assume that the error estimate */
+/* is correct. We could make the interval not */
+/* as a bracket but to be modified if the RQCORR */
+/* chooses to. In this case, the RIGHT side should */
+/* be modified as follows: */
+/* RIGHT = MAX(RIGHT, LAMBDA + RQCORR) */
+ } else {
+/* The current LAMBDA is on the right of the true */
+/* eigenvalue */
+ right = lambda;
+/* See comment about assuming the error estimate is */
+/* correct above. */
+/* LEFT = MIN(LEFT, LAMBDA + RQCORR) */
+ }
+ work[windex] = (right + left) * .5;
+/* Take RQCORR since it has the correct sign and */
+/* improves the iterate reasonably */
+ lambda += rqcorr;
+/* Update width of error interval */
+ werr[windex] = (right - left) * .5;
+ } else {
+ needbs = TRUE_;
+ }
+ if (right - left < rqtol * abs(lambda)) {
+/* The eigenvalue is computed to bisection accuracy */
+/* compute eigenvector and stop */
+ usedbs = TRUE_;
+ goto L120;
+ } else if (iter < 10) {
+ goto L120;
+ } else if (iter == 10) {
+ needbs = TRUE_;
+ goto L120;
+ } else {
+ *info = 5;
+ return 0;
+ }
+ } else {
+ stp2ii = FALSE_;
+ if (usedrq && usedbs && bstres <= resid) {
+ lambda = bstw;
+ stp2ii = TRUE_;
+ }
+ if (stp2ii) {
+/* improve error angle by second step */
+ L__1 = ! usedbs;
+ dlar1v_(&in, &c__1, &in, &lambda, &d__[ibegin]
+, &l[ibegin], &work[indld + ibegin -
+ 1], &work[indlld + ibegin - 1],
+ pivmin, &gaptol, &z__[ibegin + windex
+ * z_dim1], &L__1, &negcnt, &ztz, &
+ mingma, &iwork[iindr + windex], &
+ isuppz[(windex << 1) - 1], &nrminv, &
+ resid, &rqcorr, &work[indwrk]);
+ }
+ work[windex] = lambda;
+ }
+
+/* Compute FP-vector support w.r.t. whole matrix */
+
+ isuppz[(windex << 1) - 1] += oldien;
+ isuppz[windex * 2] += oldien;
+ zfrom = isuppz[(windex << 1) - 1];
+ zto = isuppz[windex * 2];
+ isupmn += oldien;
+ isupmx += oldien;
+/* Ensure vector is ok if support in the RQI has changed */
+ if (isupmn < zfrom) {
+ i__4 = zfrom - 1;
+ for (ii = isupmn; ii <= i__4; ++ii) {
+ z__[ii + windex * z_dim1] = 0.;
+/* L122: */
+ }
+ }
+ if (isupmx > zto) {
+ i__4 = isupmx;
+ for (ii = zto + 1; ii <= i__4; ++ii) {
+ z__[ii + windex * z_dim1] = 0.;
+/* L123: */
+ }
+ }
+ i__4 = zto - zfrom + 1;
+ dscal_(&i__4, &nrminv, &z__[zfrom + windex * z_dim1],
+ &c__1);
+L125:
+/* Update W */
+ w[windex] = lambda + sigma;
+/* Recompute the gaps on the left and right */
+/* But only allow them to become larger and not */
+/* smaller (which can only happen through "bad" */
+/* cancellation and doesn't reflect the theory */
+/* where the initial gaps are underestimated due */
+/* to WERR being too crude.) */
+ if (! eskip) {
+ if (k > 1) {
+/* Computing MAX */
+ d__1 = wgap[windmn], d__2 = w[windex] - werr[
+ windex] - w[windmn] - werr[windmn];
+ wgap[windmn] = max(d__1,d__2);
+ }
+ if (windex < wend) {
+/* Computing MAX */
+ d__1 = savgap, d__2 = w[windpl] - werr[windpl]
+ - w[windex] - werr[windex];
+ wgap[windex] = max(d__1,d__2);
+ }
+ }
+ ++idone;
+ }
+/* here ends the code for the current child */
+
+L139:
+/* Proceed to any remaining child nodes */
+ newfst = j + 1;
+L140:
+ ;
+ }
+/* L150: */
+ }
+ ++ndepth;
+ goto L40;
+ }
+ ibegin = iend + 1;
+ wbegin = wend + 1;
+L170:
+ ;
+ }
+
+ return 0;
+
+/* End of DLARRV */
+
+} /* dlarrv_ */
diff --git a/SRC/dlarscl2.c b/SRC/dlarscl2.c
new file mode 100644
index 0000000..b676fb2
--- /dev/null
+++ b/SRC/dlarscl2.c
@@ -0,0 +1,90 @@
+/* dlarscl2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlarscl2_(integer *m, integer *n, doublereal *d__,
+ doublereal *x, integer *ldx)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARSCL2 performs a reciprocal diagonal scaling on an vector: */
+/* x <-- inv(D) * x */
+/* where the diagonal matrix D is stored as a vector. */
+
+/* Eventually to be replaced by BLAS_dge_diag_scale in the new BLAS */
+/* standard. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of D and X. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of D and X. N >= 0. */
+
+/* D (input) DOUBLE PRECISION array, length M */
+/* Diagonal matrix D, stored as a vector of length M. */
+
+/* X (input/output) DOUBLE PRECISION array, dimension (LDX,N) */
+/* On entry, the vector X to be scaled by D. */
+/* On exit, the scaled vector. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the vector X. LDX >= 0. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --d__;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+
+ /* Function Body */
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__ + j * x_dim1] /= d__[i__];
+ }
+ }
+ return 0;
+} /* dlarscl2_ */
diff --git a/SRC/dlartg.c b/SRC/dlartg.c
new file mode 100644
index 0000000..40179e5
--- /dev/null
+++ b/SRC/dlartg.c
@@ -0,0 +1,190 @@
+/* dlartg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlartg_(doublereal *f, doublereal *g, doublereal *cs,
+ doublereal *sn, doublereal *r__)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double log(doublereal), pow_di(doublereal *, integer *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal f1, g1, eps, scale;
+ integer count;
+ doublereal safmn2, safmx2;
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARTG generate a plane rotation so that */
+
+/* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. */
+/* [ -SN CS ] [ G ] [ 0 ] */
+
+/* This is a slower, more accurate version of the BLAS1 routine DROTG, */
+/* with the following other differences: */
+/* F and G are unchanged on return. */
+/* If G=0, then CS=1 and SN=0. */
+/* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any */
+/* floating point operations (saves work in DBDSQR when */
+/* there are zeros on the diagonal). */
+
+/* If F exceeds G in magnitude, CS will be positive. */
+
+/* Arguments */
+/* ========= */
+
+/* F (input) DOUBLE PRECISION */
+/* The first component of vector to be rotated. */
+
+/* G (input) DOUBLE PRECISION */
+/* The second component of vector to be rotated. */
+
+/* CS (output) DOUBLE PRECISION */
+/* The cosine of the rotation. */
+
+/* SN (output) DOUBLE PRECISION */
+/* The sine of the rotation. */
+
+/* R (output) DOUBLE PRECISION */
+/* The nonzero component of the rotated vector. */
+
+/* This version has a few statements commented out for thread safety */
+/* (machine parameters are computed on each entry). 10 feb 03, SJH. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* LOGICAL FIRST */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Save statement .. */
+/* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 */
+/* .. */
+/* .. Data statements .. */
+/* DATA FIRST / .TRUE. / */
+/* .. */
+/* .. Executable Statements .. */
+
+/* IF( FIRST ) THEN */
+ safmin = dlamch_("S");
+ eps = dlamch_("E");
+ d__1 = dlamch_("B");
+ i__1 = (integer) (log(safmin / eps) / log(dlamch_("B")) / 2.);
+ safmn2 = pow_di(&d__1, &i__1);
+ safmx2 = 1. / safmn2;
+/* FIRST = .FALSE. */
+/* END IF */
+ if (*g == 0.) {
+ *cs = 1.;
+ *sn = 0.;
+ *r__ = *f;
+ } else if (*f == 0.) {
+ *cs = 0.;
+ *sn = 1.;
+ *r__ = *g;
+ } else {
+ f1 = *f;
+ g1 = *g;
+/* Computing MAX */
+ d__1 = abs(f1), d__2 = abs(g1);
+ scale = max(d__1,d__2);
+ if (scale >= safmx2) {
+ count = 0;
+L10:
+ ++count;
+ f1 *= safmn2;
+ g1 *= safmn2;
+/* Computing MAX */
+ d__1 = abs(f1), d__2 = abs(g1);
+ scale = max(d__1,d__2);
+ if (scale >= safmx2) {
+ goto L10;
+ }
+/* Computing 2nd power */
+ d__1 = f1;
+/* Computing 2nd power */
+ d__2 = g1;
+ *r__ = sqrt(d__1 * d__1 + d__2 * d__2);
+ *cs = f1 / *r__;
+ *sn = g1 / *r__;
+ i__1 = count;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ *r__ *= safmx2;
+/* L20: */
+ }
+ } else if (scale <= safmn2) {
+ count = 0;
+L30:
+ ++count;
+ f1 *= safmx2;
+ g1 *= safmx2;
+/* Computing MAX */
+ d__1 = abs(f1), d__2 = abs(g1);
+ scale = max(d__1,d__2);
+ if (scale <= safmn2) {
+ goto L30;
+ }
+/* Computing 2nd power */
+ d__1 = f1;
+/* Computing 2nd power */
+ d__2 = g1;
+ *r__ = sqrt(d__1 * d__1 + d__2 * d__2);
+ *cs = f1 / *r__;
+ *sn = g1 / *r__;
+ i__1 = count;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ *r__ *= safmn2;
+/* L40: */
+ }
+ } else {
+/* Computing 2nd power */
+ d__1 = f1;
+/* Computing 2nd power */
+ d__2 = g1;
+ *r__ = sqrt(d__1 * d__1 + d__2 * d__2);
+ *cs = f1 / *r__;
+ *sn = g1 / *r__;
+ }
+ if (abs(*f) > abs(*g) && *cs < 0.) {
+ *cs = -(*cs);
+ *sn = -(*sn);
+ *r__ = -(*r__);
+ }
+ }
+ return 0;
+
+/* End of DLARTG */
+
+} /* dlartg_ */
diff --git a/SRC/dlartv.c b/SRC/dlartv.c
new file mode 100644
index 0000000..6519c55
--- /dev/null
+++ b/SRC/dlartv.c
@@ -0,0 +1,106 @@
+/* dlartv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlartv_(integer *n, doublereal *x, integer *incx,
+ doublereal *y, integer *incy, doublereal *c__, doublereal *s, integer
+ *incc)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, ic, ix, iy;
+ doublereal xi, yi;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARTV applies a vector of real plane rotations to elements of the */
+/* real vectors x and y. For i = 1,2,...,n */
+
+/* ( x(i) ) := ( c(i) s(i) ) ( x(i) ) */
+/* ( y(i) ) ( -s(i) c(i) ) ( y(i) ) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of plane rotations to be applied. */
+
+/* X (input/output) DOUBLE PRECISION array, */
+/* dimension (1+(N-1)*INCX) */
+/* The vector x. */
+
+/* INCX (input) INTEGER */
+/* The increment between elements of X. INCX > 0. */
+
+/* Y (input/output) DOUBLE PRECISION array, */
+/* dimension (1+(N-1)*INCY) */
+/* The vector y. */
+
+/* INCY (input) INTEGER */
+/* The increment between elements of Y. INCY > 0. */
+
+/* C (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC) */
+/* The cosines of the plane rotations. */
+
+/* S (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC) */
+/* The sines of the plane rotations. */
+
+/* INCC (input) INTEGER */
+/* The increment between elements of C and S. INCC > 0. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --s;
+ --c__;
+ --y;
+ --x;
+
+ /* Function Body */
+ ix = 1;
+ iy = 1;
+ ic = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xi = x[ix];
+ yi = y[iy];
+ x[ix] = c__[ic] * xi + s[ic] * yi;
+ y[iy] = c__[ic] * yi - s[ic] * xi;
+ ix += *incx;
+ iy += *incy;
+ ic += *incc;
+/* L10: */
+ }
+ return 0;
+
+/* End of DLARTV */
+
+} /* dlartv_ */
diff --git a/SRC/dlaruv.c b/SRC/dlaruv.c
new file mode 100644
index 0000000..fa9f96f
--- /dev/null
+++ b/SRC/dlaruv.c
@@ -0,0 +1,192 @@
+/* dlaruv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlaruv_(integer *iseed, integer *n, doublereal *x)
+{
+ /* Initialized data */
+
+ static integer mm[512] /* was [128][4] */ = { 494,2637,255,2008,1253,
+ 3344,4084,1739,3143,3468,688,1657,1238,3166,1292,3422,1270,2016,
+ 154,2862,697,1706,491,931,1444,444,3577,3944,2184,1661,3482,657,
+ 3023,3618,1267,1828,164,3798,3087,2400,2870,3876,1905,1593,1797,
+ 1234,3460,328,2861,1950,617,2070,3331,769,1558,2412,2800,189,287,
+ 2045,1227,2838,209,2770,3654,3993,192,2253,3491,2889,2857,2094,
+ 1818,688,1407,634,3231,815,3524,1914,516,164,303,2144,3480,119,
+ 3357,837,2826,2332,2089,3780,1700,3712,150,2000,3375,1621,3090,
+ 3765,1149,3146,33,3082,2741,359,3316,1749,185,2784,2202,2199,1364,
+ 1244,2020,3160,2785,2772,1217,1822,1245,2252,3904,2774,997,2573,
+ 1148,545,322,789,1440,752,2859,123,1848,643,2405,2638,2344,46,
+ 3814,913,3649,339,3808,822,2832,3078,3633,2970,637,2249,2081,4019,
+ 1478,242,481,2075,4058,622,3376,812,234,641,4005,1122,3135,2640,
+ 2302,40,1832,2247,2034,2637,1287,1691,496,1597,2394,2584,1843,336,
+ 1472,2407,433,2096,1761,2810,566,442,41,1238,1086,603,840,3168,
+ 1499,1084,3438,2408,1589,2391,288,26,512,1456,171,1677,2657,2270,
+ 2587,2961,1970,1817,676,1410,3723,2803,3185,184,663,499,3784,1631,
+ 1925,3912,1398,1349,1441,2224,2411,1907,3192,2786,382,37,759,2948,
+ 1862,3802,2423,2051,2295,1332,1832,2405,3638,3661,327,3660,716,
+ 1842,3987,1368,1848,2366,2508,3754,1766,3572,2893,307,1297,3966,
+ 758,2598,3406,2922,1038,2934,2091,2451,1580,1958,2055,1507,1078,
+ 3273,17,854,2916,3971,2889,3831,2621,1541,893,736,3992,787,2125,
+ 2364,2460,257,1574,3912,1216,3248,3401,2124,2762,149,2245,166,466,
+ 4018,1399,190,2879,153,2320,18,712,2159,2318,2091,3443,1510,449,
+ 1956,2201,3137,3399,1321,2271,3667,2703,629,2365,2431,1113,3922,
+ 2554,184,2099,3228,4012,1921,3452,3901,572,3309,3171,817,3039,
+ 1696,1256,3715,2077,3019,1497,1101,717,51,981,1978,1813,3881,76,
+ 3846,3694,1682,124,1660,3997,479,1141,886,3514,1301,3604,1888,
+ 1836,1990,2058,692,1194,20,3285,2046,2107,3508,3525,3801,2549,
+ 1145,2253,305,3301,1065,3133,2913,3285,1241,1197,3729,2501,1673,
+ 541,2753,949,2361,1165,4081,2725,3305,3069,3617,3733,409,2157,
+ 1361,3973,1865,2525,1409,3445,3577,77,3761,2149,1449,3005,225,85,
+ 3673,3117,3089,1349,2057,413,65,1845,697,3085,3441,1573,3689,2941,
+ 929,533,2841,4077,721,2821,2249,2397,2817,245,1913,1997,3121,997,
+ 1833,2877,1633,981,2009,941,2449,197,2441,285,1473,2741,3129,909,
+ 2801,421,4073,2813,2337,1429,1177,1901,81,1669,2633,2269,129,1141,
+ 249,3917,2481,3941,2217,2749,3041,1877,345,2861,1809,3141,2825,
+ 157,2881,3637,1465,2829,2161,3365,361,2685,3745,2325,3609,3821,
+ 3537,517,3017,2141,1537 };
+
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, i1, i2, i3, i4, it1, it2, it3, it4;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARUV returns a vector of n random real numbers from a uniform (0,1) */
+/* distribution (n <= 128). */
+
+/* This is an auxiliary routine called by DLARNV and ZLARNV. */
+
+/* Arguments */
+/* ========= */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* N (input) INTEGER */
+/* The number of random numbers to be generated. N <= 128. */
+
+/* X (output) DOUBLE PRECISION array, dimension (N) */
+/* The generated random numbers. */
+
+/* Further Details */
+/* =============== */
+
+/* This routine uses a multiplicative congruential method with modulus */
+/* 2**48 and multiplier 33952834046453 (see G.S.Fishman, */
+/* 'Multiplicative congruential random number generators with modulus */
+/* 2**b: an exhaustive analysis for b = 32 and a partial analysis for */
+/* b = 48', Math. Comp. 189, pp 331-344, 1990). */
+
+/* 48-bit integers are stored in 4 integer array elements with 12 bits */
+/* per element. Hence the routine is portable across machines with */
+/* integers of 32 bits or more. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iseed;
+ --x;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ i1 = iseed[1];
+ i2 = iseed[2];
+ i3 = iseed[3];
+ i4 = iseed[4];
+
+ i__1 = min(*n,128);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+L20:
+
+/* Multiply the seed by i-th power of the multiplier modulo 2**48 */
+
+ it4 = i4 * mm[i__ + 383];
+ it3 = it4 / 4096;
+ it4 -= it3 << 12;
+ it3 = it3 + i3 * mm[i__ + 383] + i4 * mm[i__ + 255];
+ it2 = it3 / 4096;
+ it3 -= it2 << 12;
+ it2 = it2 + i2 * mm[i__ + 383] + i3 * mm[i__ + 255] + i4 * mm[i__ +
+ 127];
+ it1 = it2 / 4096;
+ it2 -= it1 << 12;
+ it1 = it1 + i1 * mm[i__ + 383] + i2 * mm[i__ + 255] + i3 * mm[i__ +
+ 127] + i4 * mm[i__ - 1];
+ it1 %= 4096;
+
+/* Convert 48-bit integer to a real number in the interval (0,1) */
+
+ x[i__] = ((doublereal) it1 + ((doublereal) it2 + ((doublereal) it3 + (
+ doublereal) it4 * 2.44140625e-4) * 2.44140625e-4) *
+ 2.44140625e-4) * 2.44140625e-4;
+
+ if (x[i__] == 1.) {
+/* If a real number has n bits of precision, and the first */
+/* n bits of the 48-bit integer above happen to be all 1 (which */
+/* will occur about once every 2**n calls), then X( I ) will */
+/* be rounded to exactly 1.0. */
+/* Since X( I ) is not supposed to return exactly 0.0 or 1.0, */
+/* the statistically correct thing to do in this situation is */
+/* simply to iterate again. */
+/* N.B. the case X( I ) = 0.0 should not be possible. */
+ i1 += 2;
+ i2 += 2;
+ i3 += 2;
+ i4 += 2;
+ goto L20;
+ }
+
+/* L10: */
+ }
+
+/* Return final value of seed */
+
+ iseed[1] = it1;
+ iseed[2] = it2;
+ iseed[3] = it3;
+ iseed[4] = it4;
+ return 0;
+
+/* End of DLARUV */
+
+} /* dlaruv_ */
diff --git a/SRC/dlarz.c b/SRC/dlarz.c
new file mode 100644
index 0000000..5744878
--- /dev/null
+++ b/SRC/dlarz.c
@@ -0,0 +1,194 @@
+/* dlarz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b5 = 1.;
+
+/* Subroutine */ int dlarz_(char *side, integer *m, integer *n, integer *l,
+ doublereal *v, integer *incv, doublereal *tau, doublereal *c__,
+ integer *ldc, doublereal *work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset;
+ doublereal d__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dcopy_(integer *,
+ doublereal *, integer *, doublereal *, integer *), daxpy_(integer
+ *, doublereal *, doublereal *, integer *, doublereal *, integer *)
+ ;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARZ applies a real elementary reflector H to a real M-by-N */
+/* matrix C, from either the left or the right. H is represented in the */
+/* form */
+
+/* H = I - tau * v * v' */
+
+/* where tau is a real scalar and v is a real vector. */
+
+/* If tau = 0, then H is taken to be the unit matrix. */
+
+
+/* H is a product of k elementary reflectors as returned by DTZRZF. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': form H * C */
+/* = 'R': form C * H */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* L (input) INTEGER */
+/* The number of entries of the vector V containing */
+/* the meaningful part of the Householder vectors. */
+/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */
+
+/* V (input) DOUBLE PRECISION array, dimension (1+(L-1)*abs(INCV)) */
+/* The vector v in the representation of H as returned by */
+/* DTZRZF. V is not used if TAU = 0. */
+
+/* INCV (input) INTEGER */
+/* The increment between elements of v. INCV <> 0. */
+
+/* TAU (input) DOUBLE PRECISION */
+/* The value tau in the representation of H. */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
+/* or C * H if SIDE = 'R'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (N) if SIDE = 'L' */
+/* or (M) if SIDE = 'R' */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ if (lsame_(side, "L")) {
+
+/* Form H * C */
+
+ if (*tau != 0.) {
+
+/* w( 1:n ) = C( 1, 1:n ) */
+
+ dcopy_(n, &c__[c_offset], ldc, &work[1], &c__1);
+
+/* w( 1:n ) = w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l ) */
+
+ dgemv_("Transpose", l, n, &c_b5, &c__[*m - *l + 1 + c_dim1], ldc,
+ &v[1], incv, &c_b5, &work[1], &c__1);
+
+/* C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n ) */
+
+ d__1 = -(*tau);
+ daxpy_(n, &d__1, &work[1], &c__1, &c__[c_offset], ldc);
+
+/* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... */
+/* tau * v( 1:l ) * w( 1:n )' */
+
+ d__1 = -(*tau);
+ dger_(l, n, &d__1, &v[1], incv, &work[1], &c__1, &c__[*m - *l + 1
+ + c_dim1], ldc);
+ }
+
+ } else {
+
+/* Form C * H */
+
+ if (*tau != 0.) {
+
+/* w( 1:m ) = C( 1:m, 1 ) */
+
+ dcopy_(m, &c__[c_offset], &c__1, &work[1], &c__1);
+
+/* w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l ) */
+
+ dgemv_("No transpose", m, l, &c_b5, &c__[(*n - *l + 1) * c_dim1 +
+ 1], ldc, &v[1], incv, &c_b5, &work[1], &c__1);
+
+/* C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m ) */
+
+ d__1 = -(*tau);
+ daxpy_(m, &d__1, &work[1], &c__1, &c__[c_offset], &c__1);
+
+/* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... */
+/* tau * w( 1:m ) * v( 1:l )' */
+
+ d__1 = -(*tau);
+ dger_(m, l, &d__1, &work[1], &c__1, &v[1], incv, &c__[(*n - *l +
+ 1) * c_dim1 + 1], ldc);
+
+ }
+
+ }
+
+ return 0;
+
+/* End of DLARZ */
+
+} /* dlarz_ */
diff --git a/SRC/dlarzb.c b/SRC/dlarzb.c
new file mode 100644
index 0000000..2cf3e7f
--- /dev/null
+++ b/SRC/dlarzb.c
@@ -0,0 +1,288 @@
+/* dlarzb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b13 = 1.;
+static doublereal c_b23 = -1.;
+
+/* Subroutine */ int dlarzb_(char *side, char *trans, char *direct, char *
+ storev, integer *m, integer *n, integer *k, integer *l, doublereal *v,
+ integer *ldv, doublereal *t, integer *ldt, doublereal *c__, integer *
+ ldc, doublereal *work, integer *ldwork)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1,
+ work_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, info;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dtrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), xerbla_(
+ char *, integer *);
+ char transt[1];
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARZB applies a real block reflector H or its transpose H**T to */
+/* a real distributed M-by-N C from the left or the right. */
+
+/* Currently, only STOREV = 'R' and DIRECT = 'B' are supported. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply H or H' from the Left */
+/* = 'R': apply H or H' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply H (No transpose) */
+/* = 'C': apply H' (Transpose) */
+
+/* DIRECT (input) CHARACTER*1 */
+/* Indicates how H is formed from a product of elementary */
+/* reflectors */
+/* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet) */
+/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
+
+/* STOREV (input) CHARACTER*1 */
+/* Indicates how the vectors which define the elementary */
+/* reflectors are stored: */
+/* = 'C': Columnwise (not supported yet) */
+/* = 'R': Rowwise */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* K (input) INTEGER */
+/* The order of the matrix T (= the number of elementary */
+/* reflectors whose product defines the block reflector). */
+
+/* L (input) INTEGER */
+/* The number of columns of the matrix V containing the */
+/* meaningful part of the Householder reflectors. */
+/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */
+
+/* V (input) DOUBLE PRECISION array, dimension (LDV,NV). */
+/* If STOREV = 'C', NV = K; if STOREV = 'R', NV = L. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. */
+/* If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K. */
+
+/* T (input) DOUBLE PRECISION array, dimension (LDT,K) */
+/* The triangular K-by-K matrix T in the representation of the */
+/* block reflector. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= K. */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. */
+/* If SIDE = 'L', LDWORK >= max(1,N); */
+/* if SIDE = 'R', LDWORK >= max(1,M). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+/* Check for currently supported options */
+
+ info = 0;
+ if (! lsame_(direct, "B")) {
+ info = -3;
+ } else if (! lsame_(storev, "R")) {
+ info = -4;
+ }
+ if (info != 0) {
+ i__1 = -info;
+ xerbla_("DLARZB", &i__1);
+ return 0;
+ }
+
+ if (lsame_(trans, "N")) {
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+ if (lsame_(side, "L")) {
+
+/* Form H * C or H' * C */
+
+/* W( 1:n, 1:k ) = C( 1:k, 1:n )' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1);
+/* L10: */
+ }
+
+/* W( 1:n, 1:k ) = W( 1:n, 1:k ) + ... */
+/* C( m-l+1:m, 1:n )' * V( 1:k, 1:l )' */
+
+ if (*l > 0) {
+ dgemm_("Transpose", "Transpose", n, k, l, &c_b13, &c__[*m - *l +
+ 1 + c_dim1], ldc, &v[v_offset], ldv, &c_b13, &work[
+ work_offset], ldwork);
+ }
+
+/* W( 1:n, 1:k ) = W( 1:n, 1:k ) * T' or W( 1:m, 1:k ) * T */
+
+ dtrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b13, &t[
+ t_offset], ldt, &work[work_offset], ldwork);
+
+/* C( 1:k, 1:n ) = C( 1:k, 1:n ) - W( 1:n, 1:k )' */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *k;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] -= work[j + i__ * work_dim1];
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... */
+/* V( 1:k, 1:l )' * W( 1:n, 1:k )' */
+
+ if (*l > 0) {
+ dgemm_("Transpose", "Transpose", l, n, k, &c_b23, &v[v_offset],
+ ldv, &work[work_offset], ldwork, &c_b13, &c__[*m - *l + 1
+ + c_dim1], ldc);
+ }
+
+ } else if (lsame_(side, "R")) {
+
+/* Form C * H or C * H' */
+
+/* W( 1:m, 1:k ) = C( 1:m, 1:k ) */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &
+ c__1);
+/* L40: */
+ }
+
+/* W( 1:m, 1:k ) = W( 1:m, 1:k ) + ... */
+/* C( 1:m, n-l+1:n ) * V( 1:k, 1:l )' */
+
+ if (*l > 0) {
+ dgemm_("No transpose", "Transpose", m, k, l, &c_b13, &c__[(*n - *
+ l + 1) * c_dim1 + 1], ldc, &v[v_offset], ldv, &c_b13, &
+ work[work_offset], ldwork);
+ }
+
+/* W( 1:m, 1:k ) = W( 1:m, 1:k ) * T or W( 1:m, 1:k ) * T' */
+
+ dtrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b13, &t[t_offset]
+, ldt, &work[work_offset], ldwork);
+
+/* C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k ) */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... */
+/* W( 1:m, 1:k ) * V( 1:k, 1:l ) */
+
+ if (*l > 0) {
+ dgemm_("No transpose", "No transpose", m, l, k, &c_b23, &work[
+ work_offset], ldwork, &v[v_offset], ldv, &c_b13, &c__[(*n
+ - *l + 1) * c_dim1 + 1], ldc);
+ }
+
+ }
+
+ return 0;
+
+/* End of DLARZB */
+
+} /* dlarzb_ */
diff --git a/SRC/dlarzt.c b/SRC/dlarzt.c
new file mode 100644
index 0000000..8e8450a
--- /dev/null
+++ b/SRC/dlarzt.c
@@ -0,0 +1,229 @@
+/* dlarzt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b8 = 0.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dlarzt_(char *direct, char *storev, integer *n, integer *
+ k, doublereal *v, integer *ldv, doublereal *tau, doublereal *t,
+ integer *ldt)
+{
+ /* System generated locals */
+ integer t_dim1, t_offset, v_dim1, v_offset, i__1;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, j, info;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dtrmv_(char *,
+ char *, char *, integer *, doublereal *, integer *, doublereal *,
+ integer *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARZT forms the triangular factor T of a real block reflector */
+/* H of order > n, which is defined as a product of k elementary */
+/* reflectors. */
+
+/* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */
+
+/* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */
+
+/* If STOREV = 'C', the vector which defines the elementary reflector */
+/* H(i) is stored in the i-th column of the array V, and */
+
+/* H = I - V * T * V' */
+
+/* If STOREV = 'R', the vector which defines the elementary reflector */
+/* H(i) is stored in the i-th row of the array V, and */
+
+/* H = I - V' * T * V */
+
+/* Currently, only STOREV = 'R' and DIRECT = 'B' are supported. */
+
+/* Arguments */
+/* ========= */
+
+/* DIRECT (input) CHARACTER*1 */
+/* Specifies the order in which the elementary reflectors are */
+/* multiplied to form the block reflector: */
+/* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet) */
+/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
+
+/* STOREV (input) CHARACTER*1 */
+/* Specifies how the vectors which define the elementary */
+/* reflectors are stored (see also Further Details): */
+/* = 'C': columnwise (not supported yet) */
+/* = 'R': rowwise */
+
+/* N (input) INTEGER */
+/* The order of the block reflector H. N >= 0. */
+
+/* K (input) INTEGER */
+/* The order of the triangular factor T (= the number of */
+/* elementary reflectors). K >= 1. */
+
+/* V (input/output) DOUBLE PRECISION array, dimension */
+/* (LDV,K) if STOREV = 'C' */
+/* (LDV,N) if STOREV = 'R' */
+/* The matrix V. See further details. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. */
+/* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i). */
+
+/* T (output) DOUBLE PRECISION array, dimension (LDT,K) */
+/* The k by k triangular factor T of the block reflector. */
+/* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */
+/* lower triangular. The rest of the array is not used. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= K. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* The shape of the matrix V and the storage of the vectors which define */
+/* the H(i) is best illustrated by the following example with n = 5 and */
+/* k = 3. The elements equal to 1 are not stored; the corresponding */
+/* array elements are modified but restored on exit. The rest of the */
+/* array is not used. */
+
+/* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */
+
+/* ______V_____ */
+/* ( v1 v2 v3 ) / \ */
+/* ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 ) */
+/* V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 ) */
+/* ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 ) */
+/* ( v1 v2 v3 ) */
+/* . . . */
+/* . . . */
+/* 1 . . */
+/* 1 . */
+/* 1 */
+
+/* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */
+
+/* ______V_____ */
+/* 1 / \ */
+/* . 1 ( 1 . . . . v1 v1 v1 v1 v1 ) */
+/* . . 1 ( . 1 . . . v2 v2 v2 v2 v2 ) */
+/* . . . ( . . 1 . . v3 v3 v3 v3 v3 ) */
+/* . . . */
+/* ( v1 v2 v3 ) */
+/* ( v1 v2 v3 ) */
+/* V = ( v1 v2 v3 ) */
+/* ( v1 v2 v3 ) */
+/* ( v1 v2 v3 ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for currently supported options */
+
+ /* Parameter adjustments */
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --tau;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(direct, "B")) {
+ info = -1;
+ } else if (! lsame_(storev, "R")) {
+ info = -2;
+ }
+ if (info != 0) {
+ i__1 = -info;
+ xerbla_("DLARZT", &i__1);
+ return 0;
+ }
+
+ for (i__ = *k; i__ >= 1; --i__) {
+ if (tau[i__] == 0.) {
+
+/* H(i) = I */
+
+ i__1 = *k;
+ for (j = i__; j <= i__1; ++j) {
+ t[j + i__ * t_dim1] = 0.;
+/* L10: */
+ }
+ } else {
+
+/* general case */
+
+ if (i__ < *k) {
+
+/* T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)' */
+
+ i__1 = *k - i__;
+ d__1 = -tau[i__];
+ dgemv_("No transpose", &i__1, n, &d__1, &v[i__ + 1 + v_dim1],
+ ldv, &v[i__ + v_dim1], ldv, &c_b8, &t[i__ + 1 + i__ *
+ t_dim1], &c__1);
+
+/* T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i) */
+
+ i__1 = *k - i__;
+ dtrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ + 1
+ + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * t_dim1]
+, &c__1);
+ }
+ t[i__ + i__ * t_dim1] = tau[i__];
+ }
+/* L20: */
+ }
+ return 0;
+
+/* End of DLARZT */
+
+} /* dlarzt_ */
diff --git a/SRC/dlas2.c b/SRC/dlas2.c
new file mode 100644
index 0000000..1362a1a
--- /dev/null
+++ b/SRC/dlas2.c
@@ -0,0 +1,144 @@
+/* dlas2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlas2_(doublereal *f, doublereal *g, doublereal *h__,
+ doublereal *ssmin, doublereal *ssmax)
+{
+ /* System generated locals */
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal c__, fa, ga, ha, as, at, au, fhmn, fhmx;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAS2 computes the singular values of the 2-by-2 matrix */
+/* [ F G ] */
+/* [ 0 H ]. */
+/* On return, SSMIN is the smaller singular value and SSMAX is the */
+/* larger singular value. */
+
+/* Arguments */
+/* ========= */
+
+/* F (input) DOUBLE PRECISION */
+/* The (1,1) element of the 2-by-2 matrix. */
+
+/* G (input) DOUBLE PRECISION */
+/* The (1,2) element of the 2-by-2 matrix. */
+
+/* H (input) DOUBLE PRECISION */
+/* The (2,2) element of the 2-by-2 matrix. */
+
+/* SSMIN (output) DOUBLE PRECISION */
+/* The smaller singular value. */
+
+/* SSMAX (output) DOUBLE PRECISION */
+/* The larger singular value. */
+
+/* Further Details */
+/* =============== */
+
+/* Barring over/underflow, all output quantities are correct to within */
+/* a few units in the last place (ulps), even in the absence of a guard */
+/* digit in addition/subtraction. */
+
+/* In IEEE arithmetic, the code works correctly if one matrix element is */
+/* infinite. */
+
+/* Overflow will not occur unless the largest singular value itself */
+/* overflows, or is within a few ulps of overflow. (On machines with */
+/* partial overflow, like the Cray, overflow may occur if the largest */
+/* singular value is within a factor of 2 of overflow.) */
+
+/* Underflow is harmless if underflow is gradual. Otherwise, results */
+/* may correspond to a matrix modified by perturbations of size near */
+/* the underflow threshold. */
+
+/* ==================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ fa = abs(*f);
+ ga = abs(*g);
+ ha = abs(*h__);
+ fhmn = min(fa,ha);
+ fhmx = max(fa,ha);
+ if (fhmn == 0.) {
+ *ssmin = 0.;
+ if (fhmx == 0.) {
+ *ssmax = ga;
+ } else {
+/* Computing 2nd power */
+ d__1 = min(fhmx,ga) / max(fhmx,ga);
+ *ssmax = max(fhmx,ga) * sqrt(d__1 * d__1 + 1.);
+ }
+ } else {
+ if (ga < fhmx) {
+ as = fhmn / fhmx + 1.;
+ at = (fhmx - fhmn) / fhmx;
+/* Computing 2nd power */
+ d__1 = ga / fhmx;
+ au = d__1 * d__1;
+ c__ = 2. / (sqrt(as * as + au) + sqrt(at * at + au));
+ *ssmin = fhmn * c__;
+ *ssmax = fhmx / c__;
+ } else {
+ au = fhmx / ga;
+ if (au == 0.) {
+
+/* Avoid possible harmful underflow if exponent range */
+/* asymmetric (true SSMIN may not underflow even if */
+/* AU underflows) */
+
+ *ssmin = fhmn * fhmx / ga;
+ *ssmax = ga;
+ } else {
+ as = fhmn / fhmx + 1.;
+ at = (fhmx - fhmn) / fhmx;
+/* Computing 2nd power */
+ d__1 = as * au;
+/* Computing 2nd power */
+ d__2 = at * au;
+ c__ = 1. / (sqrt(d__1 * d__1 + 1.) + sqrt(d__2 * d__2 + 1.));
+ *ssmin = fhmn * c__ * au;
+ *ssmin += *ssmin;
+ *ssmax = ga / (c__ + c__);
+ }
+ }
+ }
+ return 0;
+
+/* End of DLAS2 */
+
+} /* dlas2_ */
diff --git a/SRC/dlascl.c b/SRC/dlascl.c
new file mode 100644
index 0000000..b39a68b
--- /dev/null
+++ b/SRC/dlascl.c
@@ -0,0 +1,354 @@
+/* dlascl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlascl_(char *type__, integer *kl, integer *ku,
+ doublereal *cfrom, doublereal *cto, integer *m, integer *n,
+ doublereal *a, integer *lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+
+ /* Local variables */
+ integer i__, j, k1, k2, k3, k4;
+ doublereal mul, cto1;
+ logical done;
+ doublereal ctoc;
+ extern logical lsame_(char *, char *);
+ integer itype;
+ doublereal cfrom1;
+ extern doublereal dlamch_(char *);
+ doublereal cfromc;
+ extern logical disnan_(doublereal *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum, smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASCL multiplies the M by N real matrix A by the real scalar */
+/* CTO/CFROM. This is done without over/underflow as long as the final */
+/* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that */
+/* A may be full, upper triangular, lower triangular, upper Hessenberg, */
+/* or banded. */
+
+/* Arguments */
+/* ========= */
+
+/* TYPE (input) CHARACTER*1 */
+/* TYPE indices the storage type of the input matrix. */
+/* = 'G': A is a full matrix. */
+/* = 'L': A is a lower triangular matrix. */
+/* = 'U': A is an upper triangular matrix. */
+/* = 'H': A is an upper Hessenberg matrix. */
+/* = 'B': A is a symmetric band matrix with lower bandwidth KL */
+/* and upper bandwidth KU and with the only the lower */
+/* half stored. */
+/* = 'Q': A is a symmetric band matrix with lower bandwidth KL */
+/* and upper bandwidth KU and with the only the upper */
+/* half stored. */
+/* = 'Z': A is a band matrix with lower bandwidth KL and upper */
+/* bandwidth KU. */
+
+/* KL (input) INTEGER */
+/* The lower bandwidth of A. Referenced only if TYPE = 'B', */
+/* 'Q' or 'Z'. */
+
+/* KU (input) INTEGER */
+/* The upper bandwidth of A. Referenced only if TYPE = 'B', */
+/* 'Q' or 'Z'. */
+
+/* CFROM (input) DOUBLE PRECISION */
+/* CTO (input) DOUBLE PRECISION */
+/* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed */
+/* without over/underflow if the final result CTO*A(I,J)/CFROM */
+/* can be represented without over/underflow. CFROM must be */
+/* nonzero. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The matrix to be multiplied by CTO/CFROM. See TYPE for the */
+/* storage type. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* INFO (output) INTEGER */
+/* 0 - successful exit */
+/* <0 - if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+
+ if (lsame_(type__, "G")) {
+ itype = 0;
+ } else if (lsame_(type__, "L")) {
+ itype = 1;
+ } else if (lsame_(type__, "U")) {
+ itype = 2;
+ } else if (lsame_(type__, "H")) {
+ itype = 3;
+ } else if (lsame_(type__, "B")) {
+ itype = 4;
+ } else if (lsame_(type__, "Q")) {
+ itype = 5;
+ } else if (lsame_(type__, "Z")) {
+ itype = 6;
+ } else {
+ itype = -1;
+ }
+
+ if (itype == -1) {
+ *info = -1;
+ } else if (*cfrom == 0. || disnan_(cfrom)) {
+ *info = -4;
+ } else if (disnan_(cto)) {
+ *info = -5;
+ } else if (*m < 0) {
+ *info = -6;
+ } else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) {
+ *info = -7;
+ } else if (itype <= 3 && *lda < max(1,*m)) {
+ *info = -9;
+ } else if (itype >= 4) {
+/* Computing MAX */
+ i__1 = *m - 1;
+ if (*kl < 0 || *kl > max(i__1,0)) {
+ *info = -2;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = *n - 1;
+ if (*ku < 0 || *ku > max(i__1,0) || (itype == 4 || itype == 5) &&
+ *kl != *ku) {
+ *info = -3;
+ } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < *
+ ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) {
+ *info = -9;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLASCL", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *m == 0) {
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+
+ cfromc = *cfrom;
+ ctoc = *cto;
+
+L10:
+ cfrom1 = cfromc * smlnum;
+ if (cfrom1 == cfromc) {
+/* CFROMC is an inf. Multiply by a correctly signed zero for */
+/* finite CTOC, or a NaN if CTOC is infinite. */
+ mul = ctoc / cfromc;
+ done = TRUE_;
+ cto1 = ctoc;
+ } else {
+ cto1 = ctoc / bignum;
+ if (cto1 == ctoc) {
+/* CTOC is either 0 or an inf. In both cases, CTOC itself */
+/* serves as the correct multiplication factor. */
+ mul = ctoc;
+ done = TRUE_;
+ cfromc = 1.;
+ } else if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) {
+ mul = smlnum;
+ done = FALSE_;
+ cfromc = cfrom1;
+ } else if (abs(cto1) > abs(cfromc)) {
+ mul = bignum;
+ done = FALSE_;
+ ctoc = cto1;
+ } else {
+ mul = ctoc / cfromc;
+ done = TRUE_;
+ }
+ }
+
+ if (itype == 0) {
+
+/* Full matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] *= mul;
+/* L20: */
+ }
+/* L30: */
+ }
+
+ } else if (itype == 1) {
+
+/* Lower triangular matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] *= mul;
+/* L40: */
+ }
+/* L50: */
+ }
+
+ } else if (itype == 2) {
+
+/* Upper triangular matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(j,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] *= mul;
+/* L60: */
+ }
+/* L70: */
+ }
+
+ } else if (itype == 3) {
+
+/* Upper Hessenberg matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j + 1;
+ i__2 = min(i__3,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] *= mul;
+/* L80: */
+ }
+/* L90: */
+ }
+
+ } else if (itype == 4) {
+
+/* Lower half of a symmetric band matrix */
+
+ k3 = *kl + 1;
+ k4 = *n + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = k3, i__4 = k4 - j;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] *= mul;
+/* L100: */
+ }
+/* L110: */
+ }
+
+ } else if (itype == 5) {
+
+/* Upper half of a symmetric band matrix */
+
+ k1 = *ku + 2;
+ k3 = *ku + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = k1 - j;
+ i__3 = k3;
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+ a[i__ + j * a_dim1] *= mul;
+/* L120: */
+ }
+/* L130: */
+ }
+
+ } else if (itype == 6) {
+
+/* Band matrix */
+
+ k1 = *kl + *ku + 2;
+ k2 = *kl + 1;
+ k3 = (*kl << 1) + *ku + 1;
+ k4 = *kl + *ku + 1 + *m;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__3 = k1 - j;
+/* Computing MIN */
+ i__4 = k3, i__5 = k4 - j;
+ i__2 = min(i__4,i__5);
+ for (i__ = max(i__3,k2); i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] *= mul;
+/* L140: */
+ }
+/* L150: */
+ }
+
+ }
+
+ if (! done) {
+ goto L10;
+ }
+
+ return 0;
+
+/* End of DLASCL */
+
+} /* dlascl_ */
diff --git a/SRC/dlascl2.c b/SRC/dlascl2.c
new file mode 100644
index 0000000..2e38b4e
--- /dev/null
+++ b/SRC/dlascl2.c
@@ -0,0 +1,90 @@
+/* dlascl2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlascl2_(integer *m, integer *n, doublereal *d__,
+ doublereal *x, integer *ldx)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASCL2 performs a diagonal scaling on a vector: */
+/* x <-- D * x */
+/* where the diagonal matrix D is stored as a vector. */
+
+/* Eventually to be replaced by BLAS_dge_diag_scale in the new BLAS */
+/* standard. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of D and X. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of D and X. N >= 0. */
+
+/* D (input) DOUBLE PRECISION array, length M */
+/* Diagonal matrix D, stored as a vector of length M. */
+
+/* X (input/output) DOUBLE PRECISION array, dimension (LDX,N) */
+/* On entry, the vector X to be scaled by D. */
+/* On exit, the scaled vector. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the vector X. LDX >= 0. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --d__;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+
+ /* Function Body */
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__ + j * x_dim1] *= d__[i__];
+ }
+ }
+ return 0;
+} /* dlascl2_ */
diff --git a/SRC/dlasd0.c b/SRC/dlasd0.c
new file mode 100644
index 0000000..a8b7197
--- /dev/null
+++ b/SRC/dlasd0.c
@@ -0,0 +1,291 @@
+/* dlasd0.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c__2 = 2;
+
+/* Subroutine */ int dlasd0_(integer *n, integer *sqre, doublereal *d__,
+ doublereal *e, doublereal *u, integer *ldu, doublereal *vt, integer *
+ ldvt, integer *smlsiz, integer *iwork, doublereal *work, integer *
+ info)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2;
+
+ /* Builtin functions */
+ integer pow_ii(integer *, integer *);
+
+ /* Local variables */
+ integer i__, j, m, i1, ic, lf, nd, ll, nl, nr, im1, ncc, nlf, nrf, iwk,
+ lvl, ndb1, nlp1, nrp1;
+ doublereal beta;
+ integer idxq, nlvl;
+ doublereal alpha;
+ integer inode, ndiml, idxqc, ndimr, itemp, sqrei;
+ extern /* Subroutine */ int dlasd1_(integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *, integer *, doublereal *,
+ integer *), dlasdq_(char *, integer *, integer *, integer *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *), dlasdt_(integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *), xerbla_(
+ char *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Using a divide and conquer approach, DLASD0 computes the singular */
+/* value decomposition (SVD) of a real upper bidiagonal N-by-M */
+/* matrix B with diagonal D and offdiagonal E, where M = N + SQRE. */
+/* The algorithm computes orthogonal matrices U and VT such that */
+/* B = U * S * VT. The singular values S are overwritten on D. */
+
+/* A related subroutine, DLASDA, computes only the singular values, */
+/* and optionally, the singular vectors in compact form. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* On entry, the row dimension of the upper bidiagonal matrix. */
+/* This is also the dimension of the main diagonal array D. */
+
+/* SQRE (input) INTEGER */
+/* Specifies the column dimension of the bidiagonal matrix. */
+/* = 0: The bidiagonal matrix has column dimension M = N; */
+/* = 1: The bidiagonal matrix has column dimension M = N+1; */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry D contains the main diagonal of the bidiagonal */
+/* matrix. */
+/* On exit D, if INFO = 0, contains its singular values. */
+
+/* E (input) DOUBLE PRECISION array, dimension (M-1) */
+/* Contains the subdiagonal entries of the bidiagonal matrix. */
+/* On exit, E has been destroyed. */
+
+/* U (output) DOUBLE PRECISION array, dimension at least (LDQ, N) */
+/* On exit, U contains the left singular vectors. */
+
+/* LDU (input) INTEGER */
+/* On entry, leading dimension of U. */
+
+/* VT (output) DOUBLE PRECISION array, dimension at least (LDVT, M) */
+/* On exit, VT' contains the right singular vectors. */
+
+/* LDVT (input) INTEGER */
+/* On entry, leading dimension of VT. */
+
+/* SMLSIZ (input) INTEGER */
+/* On entry, maximum size of the subproblems at the */
+/* bottom of the computation tree. */
+
+/* IWORK (workspace) INTEGER work array. */
+/* Dimension must be at least (8 * N) */
+
+/* WORK (workspace) DOUBLE PRECISION work array. */
+/* Dimension must be at least (3 * M**2 + 2 * M) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, an singular value did not converge */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --iwork;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*n < 0) {
+ *info = -1;
+ } else if (*sqre < 0 || *sqre > 1) {
+ *info = -2;
+ }
+
+ m = *n + *sqre;
+
+ if (*ldu < *n) {
+ *info = -6;
+ } else if (*ldvt < m) {
+ *info = -8;
+ } else if (*smlsiz < 3) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLASD0", &i__1);
+ return 0;
+ }
+
+/* If the input matrix is too small, call DLASDQ to find the SVD. */
+
+ if (*n <= *smlsiz) {
+ dlasdq_("U", sqre, n, &m, n, &c__0, &d__[1], &e[1], &vt[vt_offset],
+ ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[1], info);
+ return 0;
+ }
+
+/* Set up the computation tree. */
+
+ inode = 1;
+ ndiml = inode + *n;
+ ndimr = ndiml + *n;
+ idxq = ndimr + *n;
+ iwk = idxq + *n;
+ dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr],
+ smlsiz);
+
+/* For the nodes on bottom level of the tree, solve */
+/* their subproblems by DLASDQ. */
+
+ ndb1 = (nd + 1) / 2;
+ ncc = 0;
+ i__1 = nd;
+ for (i__ = ndb1; i__ <= i__1; ++i__) {
+
+/* IC : center row of each node */
+/* NL : number of rows of left subproblem */
+/* NR : number of rows of right subproblem */
+/* NLF: starting row of the left subproblem */
+/* NRF: starting row of the right subproblem */
+
+ i1 = i__ - 1;
+ ic = iwork[inode + i1];
+ nl = iwork[ndiml + i1];
+ nlp1 = nl + 1;
+ nr = iwork[ndimr + i1];
+ nrp1 = nr + 1;
+ nlf = ic - nl;
+ nrf = ic + 1;
+ sqrei = 1;
+ dlasdq_("U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], &vt[
+ nlf + nlf * vt_dim1], ldvt, &u[nlf + nlf * u_dim1], ldu, &u[
+ nlf + nlf * u_dim1], ldu, &work[1], info);
+ if (*info != 0) {
+ return 0;
+ }
+ itemp = idxq + nlf - 2;
+ i__2 = nl;
+ for (j = 1; j <= i__2; ++j) {
+ iwork[itemp + j] = j;
+/* L10: */
+ }
+ if (i__ == nd) {
+ sqrei = *sqre;
+ } else {
+ sqrei = 1;
+ }
+ nrp1 = nr + sqrei;
+ dlasdq_("U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], &vt[
+ nrf + nrf * vt_dim1], ldvt, &u[nrf + nrf * u_dim1], ldu, &u[
+ nrf + nrf * u_dim1], ldu, &work[1], info);
+ if (*info != 0) {
+ return 0;
+ }
+ itemp = idxq + ic;
+ i__2 = nr;
+ for (j = 1; j <= i__2; ++j) {
+ iwork[itemp + j - 1] = j;
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* Now conquer each subproblem bottom-up. */
+
+ for (lvl = nlvl; lvl >= 1; --lvl) {
+
+/* Find the first node LF and last node LL on the */
+/* current level LVL. */
+
+ if (lvl == 1) {
+ lf = 1;
+ ll = 1;
+ } else {
+ i__1 = lvl - 1;
+ lf = pow_ii(&c__2, &i__1);
+ ll = (lf << 1) - 1;
+ }
+ i__1 = ll;
+ for (i__ = lf; i__ <= i__1; ++i__) {
+ im1 = i__ - 1;
+ ic = iwork[inode + im1];
+ nl = iwork[ndiml + im1];
+ nr = iwork[ndimr + im1];
+ nlf = ic - nl;
+ if (*sqre == 0 && i__ == ll) {
+ sqrei = *sqre;
+ } else {
+ sqrei = 1;
+ }
+ idxqc = idxq + nlf - 1;
+ alpha = d__[ic];
+ beta = e[ic];
+ dlasd1_(&nl, &nr, &sqrei, &d__[nlf], &alpha, &beta, &u[nlf + nlf *
+ u_dim1], ldu, &vt[nlf + nlf * vt_dim1], ldvt, &iwork[
+ idxqc], &iwork[iwk], &work[1], info);
+ if (*info != 0) {
+ return 0;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+
+ return 0;
+
+/* End of DLASD0 */
+
+} /* dlasd0_ */
diff --git a/SRC/dlasd1.c b/SRC/dlasd1.c
new file mode 100644
index 0000000..84fb8e5
--- /dev/null
+++ b/SRC/dlasd1.c
@@ -0,0 +1,288 @@
+/* dlasd1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static doublereal c_b7 = 1.;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dlasd1_(integer *nl, integer *nr, integer *sqre,
+ doublereal *d__, doublereal *alpha, doublereal *beta, doublereal *u,
+ integer *ldu, doublereal *vt, integer *ldvt, integer *idxq, integer *
+ iwork, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, vt_dim1, vt_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer i__, k, m, n, n1, n2, iq, iz, iu2, ldq, idx, ldu2, ivt2, idxc,
+ idxp, ldvt2;
+ extern /* Subroutine */ int dlasd2_(integer *, integer *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *), dlasd3_(
+ integer *, integer *, integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *, integer *, doublereal *, integer *),
+ dlascl_(char *, integer *, integer *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, integer *, integer *),
+ dlamrg_(integer *, integer *, doublereal *, integer *, integer *,
+ integer *);
+ integer isigma;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal orgnrm;
+ integer coltyp;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B, */
+/* where N = NL + NR + 1 and M = N + SQRE. DLASD1 is called from DLASD0. */
+
+/* A related subroutine DLASD7 handles the case in which the singular */
+/* values (and the singular vectors in factored form) are desired. */
+
+/* DLASD1 computes the SVD as follows: */
+
+/* ( D1(in) 0 0 0 ) */
+/* B = U(in) * ( Z1' a Z2' b ) * VT(in) */
+/* ( 0 0 D2(in) 0 ) */
+
+/* = U(out) * ( D(out) 0) * VT(out) */
+
+/* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M */
+/* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros */
+/* elsewhere; and the entry b is empty if SQRE = 0. */
+
+/* The left singular vectors of the original matrix are stored in U, and */
+/* the transpose of the right singular vectors are stored in VT, and the */
+/* singular values are in D. The algorithm consists of three stages: */
+
+/* The first stage consists of deflating the size of the problem */
+/* when there are multiple singular values or when there are zeros in */
+/* the Z vector. For each such occurence the dimension of the */
+/* secular equation problem is reduced by one. This stage is */
+/* performed by the routine DLASD2. */
+
+/* The second stage consists of calculating the updated */
+/* singular values. This is done by finding the square roots of the */
+/* roots of the secular equation via the routine DLASD4 (as called */
+/* by DLASD3). This routine also calculates the singular vectors of */
+/* the current problem. */
+
+/* The final stage consists of computing the updated singular vectors */
+/* directly using the updated singular values. The singular vectors */
+/* for the current problem are multiplied with the singular vectors */
+/* from the overall problem. */
+
+/* Arguments */
+/* ========= */
+
+/* NL (input) INTEGER */
+/* The row dimension of the upper block. NL >= 1. */
+
+/* NR (input) INTEGER */
+/* The row dimension of the lower block. NR >= 1. */
+
+/* SQRE (input) INTEGER */
+/* = 0: the lower block is an NR-by-NR square matrix. */
+/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */
+
+/* The bidiagonal matrix has row dimension N = NL + NR + 1, */
+/* and column dimension M = N + SQRE. */
+
+/* D (input/output) DOUBLE PRECISION array, */
+/* dimension (N = NL+NR+1). */
+/* On entry D(1:NL,1:NL) contains the singular values of the */
+/* upper block; and D(NL+2:N) contains the singular values of */
+/* the lower block. On exit D(1:N) contains the singular values */
+/* of the modified matrix. */
+
+/* ALPHA (input/output) DOUBLE PRECISION */
+/* Contains the diagonal element associated with the added row. */
+
+/* BETA (input/output) DOUBLE PRECISION */
+/* Contains the off-diagonal element associated with the added */
+/* row. */
+
+/* U (input/output) DOUBLE PRECISION array, dimension(LDU,N) */
+/* On entry U(1:NL, 1:NL) contains the left singular vectors of */
+/* the upper block; U(NL+2:N, NL+2:N) contains the left singular */
+/* vectors of the lower block. On exit U contains the left */
+/* singular vectors of the bidiagonal matrix. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max( 1, N ). */
+
+/* VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M) */
+/* where M = N + SQRE. */
+/* On entry VT(1:NL+1, 1:NL+1)' contains the right singular */
+/* vectors of the upper block; VT(NL+2:M, NL+2:M)' contains */
+/* the right singular vectors of the lower block. On exit */
+/* VT' contains the right singular vectors of the */
+/* bidiagonal matrix. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. LDVT >= max( 1, M ). */
+
+/* IDXQ (output) INTEGER array, dimension(N) */
+/* This contains the permutation which will reintegrate the */
+/* subproblem just solved back into sorted order, i.e. */
+/* D( IDXQ( I = 1, N ) ) will be in ascending order. */
+
+/* IWORK (workspace) INTEGER array, dimension( 4 * N ) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension( 3*M**2 + 2*M ) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, an singular value did not converge */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --idxq;
+ --iwork;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*nl < 1) {
+ *info = -1;
+ } else if (*nr < 1) {
+ *info = -2;
+ } else if (*sqre < 0 || *sqre > 1) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLASD1", &i__1);
+ return 0;
+ }
+
+ n = *nl + *nr + 1;
+ m = n + *sqre;
+
+/* The following values are for bookkeeping purposes only. They are */
+/* integer pointers which indicate the portion of the workspace */
+/* used by a particular array in DLASD2 and DLASD3. */
+
+ ldu2 = n;
+ ldvt2 = m;
+
+ iz = 1;
+ isigma = iz + m;
+ iu2 = isigma + n;
+ ivt2 = iu2 + ldu2 * n;
+ iq = ivt2 + ldvt2 * m;
+
+ idx = 1;
+ idxc = idx + n;
+ coltyp = idxc + n;
+ idxp = coltyp + n;
+
+/* Scale. */
+
+/* Computing MAX */
+ d__1 = abs(*alpha), d__2 = abs(*beta);
+ orgnrm = max(d__1,d__2);
+ d__[*nl + 1] = 0.;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((d__1 = d__[i__], abs(d__1)) > orgnrm) {
+ orgnrm = (d__1 = d__[i__], abs(d__1));
+ }
+/* L10: */
+ }
+ dlascl_("G", &c__0, &c__0, &orgnrm, &c_b7, &n, &c__1, &d__[1], &n, info);
+ *alpha /= orgnrm;
+ *beta /= orgnrm;
+
+/* Deflate singular values. */
+
+ dlasd2_(nl, nr, sqre, &k, &d__[1], &work[iz], alpha, beta, &u[u_offset],
+ ldu, &vt[vt_offset], ldvt, &work[isigma], &work[iu2], &ldu2, &
+ work[ivt2], &ldvt2, &iwork[idxp], &iwork[idx], &iwork[idxc], &
+ idxq[1], &iwork[coltyp], info);
+
+/* Solve Secular Equation and update singular vectors. */
+
+ ldq = k;
+ dlasd3_(nl, nr, sqre, &k, &d__[1], &work[iq], &ldq, &work[isigma], &u[
+ u_offset], ldu, &work[iu2], &ldu2, &vt[vt_offset], ldvt, &work[
+ ivt2], &ldvt2, &iwork[idxc], &iwork[coltyp], &work[iz], info);
+ if (*info != 0) {
+ return 0;
+ }
+
+/* Unscale. */
+
+ dlascl_("G", &c__0, &c__0, &c_b7, &orgnrm, &n, &c__1, &d__[1], &n, info);
+
+/* Prepare the IDXQ sorting permutation. */
+
+ n1 = k;
+ n2 = n - k;
+ dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &idxq[1]);
+
+ return 0;
+
+/* End of DLASD1 */
+
+} /* dlasd1_ */
diff --git a/SRC/dlasd2.c b/SRC/dlasd2.c
new file mode 100644
index 0000000..441aa7d
--- /dev/null
+++ b/SRC/dlasd2.c
@@ -0,0 +1,609 @@
+/* dlasd2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b30 = 0.;
+
+/* Subroutine */ int dlasd2_(integer *nl, integer *nr, integer *sqre, integer
+ *k, doublereal *d__, doublereal *z__, doublereal *alpha, doublereal *
+ beta, doublereal *u, integer *ldu, doublereal *vt, integer *ldvt,
+ doublereal *dsigma, doublereal *u2, integer *ldu2, doublereal *vt2,
+ integer *ldvt2, integer *idxp, integer *idx, integer *idxc, integer *
+ idxq, integer *coltyp, integer *info)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, u2_dim1, u2_offset, vt_dim1, vt_offset,
+ vt2_dim1, vt2_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ doublereal c__;
+ integer i__, j, m, n;
+ doublereal s;
+ integer k2;
+ doublereal z1;
+ integer ct, jp;
+ doublereal eps, tau, tol;
+ integer psm[4], nlp1, nlp2, idxi, idxj;
+ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ integer ctot[4], idxjp;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer jprev;
+ extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
+ extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *,
+ integer *, integer *, integer *), dlacpy_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *), dlaset_(char *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *), xerbla_(char *,
+ integer *);
+ doublereal hlftol;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASD2 merges the two sets of singular values together into a single */
+/* sorted set. Then it tries to deflate the size of the problem. */
+/* There are two ways in which deflation can occur: when two or more */
+/* singular values are close together or if there is a tiny entry in the */
+/* Z vector. For each such occurrence the order of the related secular */
+/* equation problem is reduced by one. */
+
+/* DLASD2 is called from DLASD1. */
+
+/* Arguments */
+/* ========= */
+
+/* NL (input) INTEGER */
+/* The row dimension of the upper block. NL >= 1. */
+
+/* NR (input) INTEGER */
+/* The row dimension of the lower block. NR >= 1. */
+
+/* SQRE (input) INTEGER */
+/* = 0: the lower block is an NR-by-NR square matrix. */
+/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */
+
+/* The bidiagonal matrix has N = NL + NR + 1 rows and */
+/* M = N + SQRE >= N columns. */
+
+/* K (output) INTEGER */
+/* Contains the dimension of the non-deflated matrix, */
+/* This is the order of the related secular equation. 1 <= K <=N. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension(N) */
+/* On entry D contains the singular values of the two submatrices */
+/* to be combined. On exit D contains the trailing (N-K) updated */
+/* singular values (those which were deflated) sorted into */
+/* increasing order. */
+
+/* Z (output) DOUBLE PRECISION array, dimension(N) */
+/* On exit Z contains the updating row vector in the secular */
+/* equation. */
+
+/* ALPHA (input) DOUBLE PRECISION */
+/* Contains the diagonal element associated with the added row. */
+
+/* BETA (input) DOUBLE PRECISION */
+/* Contains the off-diagonal element associated with the added */
+/* row. */
+
+/* U (input/output) DOUBLE PRECISION array, dimension(LDU,N) */
+/* On entry U contains the left singular vectors of two */
+/* submatrices in the two square blocks with corners at (1,1), */
+/* (NL, NL), and (NL+2, NL+2), (N,N). */
+/* On exit U contains the trailing (N-K) updated left singular */
+/* vectors (those which were deflated) in its last N-K columns. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= N. */
+
+/* VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M) */
+/* On entry VT' contains the right singular vectors of two */
+/* submatrices in the two square blocks with corners at (1,1), */
+/* (NL+1, NL+1), and (NL+2, NL+2), (M,M). */
+/* On exit VT' contains the trailing (N-K) updated right singular */
+/* vectors (those which were deflated) in its last N-K columns. */
+/* In case SQRE =1, the last row of VT spans the right null */
+/* space. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. LDVT >= M. */
+
+/* DSIGMA (output) DOUBLE PRECISION array, dimension (N) */
+/* Contains a copy of the diagonal elements (K-1 singular values */
+/* and one zero) in the secular equation. */
+
+/* U2 (output) DOUBLE PRECISION array, dimension(LDU2,N) */
+/* Contains a copy of the first K-1 left singular vectors which */
+/* will be used by DLASD3 in a matrix multiply (DGEMM) to solve */
+/* for the new left singular vectors. U2 is arranged into four */
+/* blocks. The first block contains a column with 1 at NL+1 and */
+/* zero everywhere else; the second block contains non-zero */
+/* entries only at and above NL; the third contains non-zero */
+/* entries only below NL+1; and the fourth is dense. */
+
+/* LDU2 (input) INTEGER */
+/* The leading dimension of the array U2. LDU2 >= N. */
+
+/* VT2 (output) DOUBLE PRECISION array, dimension(LDVT2,N) */
+/* VT2' contains a copy of the first K right singular vectors */
+/* which will be used by DLASD3 in a matrix multiply (DGEMM) to */
+/* solve for the new right singular vectors. VT2 is arranged into */
+/* three blocks. The first block contains a row that corresponds */
+/* to the special 0 diagonal element in SIGMA; the second block */
+/* contains non-zeros only at and before NL +1; the third block */
+/* contains non-zeros only at and after NL +2. */
+
+/* LDVT2 (input) INTEGER */
+/* The leading dimension of the array VT2. LDVT2 >= M. */
+
+/* IDXP (workspace) INTEGER array dimension(N) */
+/* This will contain the permutation used to place deflated */
+/* values of D at the end of the array. On output IDXP(2:K) */
+/* points to the nondeflated D-values and IDXP(K+1:N) */
+/* points to the deflated singular values. */
+
+/* IDX (workspace) INTEGER array dimension(N) */
+/* This will contain the permutation used to sort the contents of */
+/* D into ascending order. */
+
+/* IDXC (output) INTEGER array dimension(N) */
+/* This will contain the permutation used to arrange the columns */
+/* of the deflated U matrix into three groups: the first group */
+/* contains non-zero entries only at and above NL, the second */
+/* contains non-zero entries only below NL+2, and the third is */
+/* dense. */
+
+/* IDXQ (input/output) INTEGER array dimension(N) */
+/* This contains the permutation which separately sorts the two */
+/* sub-problems in D into ascending order. Note that entries in */
+/* the first hlaf of this permutation must first be moved one */
+/* position backward; and entries in the second half */
+/* must first have NL+1 added to their values. */
+
+/* COLTYP (workspace/output) INTEGER array dimension(N) */
+/* As workspace, this will contain a label which will indicate */
+/* which of the following types a column in the U2 matrix or a */
+/* row in the VT2 matrix is: */
+/* 1 : non-zero in the upper half only */
+/* 2 : non-zero in the lower half only */
+/* 3 : dense */
+/* 4 : deflated */
+
+/* On exit, it is an array of dimension 4, with COLTYP(I) being */
+/* the dimension of the I-th type columns. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --z__;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --dsigma;
+ u2_dim1 = *ldu2;
+ u2_offset = 1 + u2_dim1;
+ u2 -= u2_offset;
+ vt2_dim1 = *ldvt2;
+ vt2_offset = 1 + vt2_dim1;
+ vt2 -= vt2_offset;
+ --idxp;
+ --idx;
+ --idxc;
+ --idxq;
+ --coltyp;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*nl < 1) {
+ *info = -1;
+ } else if (*nr < 1) {
+ *info = -2;
+ } else if (*sqre != 1 && *sqre != 0) {
+ *info = -3;
+ }
+
+ n = *nl + *nr + 1;
+ m = n + *sqre;
+
+ if (*ldu < n) {
+ *info = -10;
+ } else if (*ldvt < m) {
+ *info = -12;
+ } else if (*ldu2 < n) {
+ *info = -15;
+ } else if (*ldvt2 < m) {
+ *info = -17;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLASD2", &i__1);
+ return 0;
+ }
+
+ nlp1 = *nl + 1;
+ nlp2 = *nl + 2;
+
+/* Generate the first part of the vector Z; and move the singular */
+/* values in the first part of D one position backward. */
+
+ z1 = *alpha * vt[nlp1 + nlp1 * vt_dim1];
+ z__[1] = z1;
+ for (i__ = *nl; i__ >= 1; --i__) {
+ z__[i__ + 1] = *alpha * vt[i__ + nlp1 * vt_dim1];
+ d__[i__ + 1] = d__[i__];
+ idxq[i__ + 1] = idxq[i__] + 1;
+/* L10: */
+ }
+
+/* Generate the second part of the vector Z. */
+
+ i__1 = m;
+ for (i__ = nlp2; i__ <= i__1; ++i__) {
+ z__[i__] = *beta * vt[i__ + nlp2 * vt_dim1];
+/* L20: */
+ }
+
+/* Initialize some reference arrays. */
+
+ i__1 = nlp1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ coltyp[i__] = 1;
+/* L30: */
+ }
+ i__1 = n;
+ for (i__ = nlp2; i__ <= i__1; ++i__) {
+ coltyp[i__] = 2;
+/* L40: */
+ }
+
+/* Sort the singular values into increasing order */
+
+ i__1 = n;
+ for (i__ = nlp2; i__ <= i__1; ++i__) {
+ idxq[i__] += nlp1;
+/* L50: */
+ }
+
+/* DSIGMA, IDXC, IDXC, and the first column of U2 */
+/* are used as storage space. */
+
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ dsigma[i__] = d__[idxq[i__]];
+ u2[i__ + u2_dim1] = z__[idxq[i__]];
+ idxc[i__] = coltyp[idxq[i__]];
+/* L60: */
+ }
+
+ dlamrg_(nl, nr, &dsigma[2], &c__1, &c__1, &idx[2]);
+
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ idxi = idx[i__] + 1;
+ d__[i__] = dsigma[idxi];
+ z__[i__] = u2[idxi + u2_dim1];
+ coltyp[i__] = idxc[idxi];
+/* L70: */
+ }
+
+/* Calculate the allowable deflation tolerance */
+
+ eps = dlamch_("Epsilon");
+/* Computing MAX */
+ d__1 = abs(*alpha), d__2 = abs(*beta);
+ tol = max(d__1,d__2);
+/* Computing MAX */
+ d__2 = (d__1 = d__[n], abs(d__1));
+ tol = eps * 8. * max(d__2,tol);
+
+/* There are 2 kinds of deflation -- first a value in the z-vector */
+/* is small, second two (or more) singular values are very close */
+/* together (their difference is small). */
+
+/* If the value in the z-vector is small, we simply permute the */
+/* array so that the corresponding singular value is moved to the */
+/* end. */
+
+/* If two values in the D-vector are close, we perform a two-sided */
+/* rotation designed to make one of the corresponding z-vector */
+/* entries zero, and then permute the array so that the deflated */
+/* singular value is moved to the end. */
+
+/* If there are multiple singular values then the problem deflates. */
+/* Here the number of equal singular values are found. As each equal */
+/* singular value is found, an elementary reflector is computed to */
+/* rotate the corresponding singular subspace so that the */
+/* corresponding components of Z are zero in this new basis. */
+
+ *k = 1;
+ k2 = n + 1;
+ i__1 = n;
+ for (j = 2; j <= i__1; ++j) {
+ if ((d__1 = z__[j], abs(d__1)) <= tol) {
+
+/* Deflate due to small z component. */
+
+ --k2;
+ idxp[k2] = j;
+ coltyp[j] = 4;
+ if (j == n) {
+ goto L120;
+ }
+ } else {
+ jprev = j;
+ goto L90;
+ }
+/* L80: */
+ }
+L90:
+ j = jprev;
+L100:
+ ++j;
+ if (j > n) {
+ goto L110;
+ }
+ if ((d__1 = z__[j], abs(d__1)) <= tol) {
+
+/* Deflate due to small z component. */
+
+ --k2;
+ idxp[k2] = j;
+ coltyp[j] = 4;
+ } else {
+
+/* Check if singular values are close enough to allow deflation. */
+
+ if ((d__1 = d__[j] - d__[jprev], abs(d__1)) <= tol) {
+
+/* Deflation is possible. */
+
+ s = z__[jprev];
+ c__ = z__[j];
+
+/* Find sqrt(a**2+b**2) without overflow or */
+/* destructive underflow. */
+
+ tau = dlapy2_(&c__, &s);
+ c__ /= tau;
+ s = -s / tau;
+ z__[j] = tau;
+ z__[jprev] = 0.;
+
+/* Apply back the Givens rotation to the left and right */
+/* singular vector matrices. */
+
+ idxjp = idxq[idx[jprev] + 1];
+ idxj = idxq[idx[j] + 1];
+ if (idxjp <= nlp1) {
+ --idxjp;
+ }
+ if (idxj <= nlp1) {
+ --idxj;
+ }
+ drot_(&n, &u[idxjp * u_dim1 + 1], &c__1, &u[idxj * u_dim1 + 1], &
+ c__1, &c__, &s);
+ drot_(&m, &vt[idxjp + vt_dim1], ldvt, &vt[idxj + vt_dim1], ldvt, &
+ c__, &s);
+ if (coltyp[j] != coltyp[jprev]) {
+ coltyp[j] = 3;
+ }
+ coltyp[jprev] = 4;
+ --k2;
+ idxp[k2] = jprev;
+ jprev = j;
+ } else {
+ ++(*k);
+ u2[*k + u2_dim1] = z__[jprev];
+ dsigma[*k] = d__[jprev];
+ idxp[*k] = jprev;
+ jprev = j;
+ }
+ }
+ goto L100;
+L110:
+
+/* Record the last singular value. */
+
+ ++(*k);
+ u2[*k + u2_dim1] = z__[jprev];
+ dsigma[*k] = d__[jprev];
+ idxp[*k] = jprev;
+
+L120:
+
+/* Count up the total number of the various types of columns, then */
+/* form a permutation which positions the four column types into */
+/* four groups of uniform structure (although one or more of these */
+/* groups may be empty). */
+
+ for (j = 1; j <= 4; ++j) {
+ ctot[j - 1] = 0;
+/* L130: */
+ }
+ i__1 = n;
+ for (j = 2; j <= i__1; ++j) {
+ ct = coltyp[j];
+ ++ctot[ct - 1];
+/* L140: */
+ }
+
+/* PSM(*) = Position in SubMatrix (of types 1 through 4) */
+
+ psm[0] = 2;
+ psm[1] = ctot[0] + 2;
+ psm[2] = psm[1] + ctot[1];
+ psm[3] = psm[2] + ctot[2];
+
+/* Fill out the IDXC array so that the permutation which it induces */
+/* will place all type-1 columns first, all type-2 columns next, */
+/* then all type-3's, and finally all type-4's, starting from the */
+/* second column. This applies similarly to the rows of VT. */
+
+ i__1 = n;
+ for (j = 2; j <= i__1; ++j) {
+ jp = idxp[j];
+ ct = coltyp[jp];
+ idxc[psm[ct - 1]] = j;
+ ++psm[ct - 1];
+/* L150: */
+ }
+
+/* Sort the singular values and corresponding singular vectors into */
+/* DSIGMA, U2, and VT2 respectively. The singular values/vectors */
+/* which were not deflated go into the first K slots of DSIGMA, U2, */
+/* and VT2 respectively, while those which were deflated go into the */
+/* last N - K slots, except that the first column/row will be treated */
+/* separately. */
+
+ i__1 = n;
+ for (j = 2; j <= i__1; ++j) {
+ jp = idxp[j];
+ dsigma[j] = d__[jp];
+ idxj = idxq[idx[idxp[idxc[j]]] + 1];
+ if (idxj <= nlp1) {
+ --idxj;
+ }
+ dcopy_(&n, &u[idxj * u_dim1 + 1], &c__1, &u2[j * u2_dim1 + 1], &c__1);
+ dcopy_(&m, &vt[idxj + vt_dim1], ldvt, &vt2[j + vt2_dim1], ldvt2);
+/* L160: */
+ }
+
+/* Determine DSIGMA(1), DSIGMA(2) and Z(1) */
+
+ dsigma[1] = 0.;
+ hlftol = tol / 2.;
+ if (abs(dsigma[2]) <= hlftol) {
+ dsigma[2] = hlftol;
+ }
+ if (m > n) {
+ z__[1] = dlapy2_(&z1, &z__[m]);
+ if (z__[1] <= tol) {
+ c__ = 1.;
+ s = 0.;
+ z__[1] = tol;
+ } else {
+ c__ = z1 / z__[1];
+ s = z__[m] / z__[1];
+ }
+ } else {
+ if (abs(z1) <= tol) {
+ z__[1] = tol;
+ } else {
+ z__[1] = z1;
+ }
+ }
+
+/* Move the rest of the updating row to Z. */
+
+ i__1 = *k - 1;
+ dcopy_(&i__1, &u2[u2_dim1 + 2], &c__1, &z__[2], &c__1);
+
+/* Determine the first column of U2, the first row of VT2 and the */
+/* last row of VT. */
+
+ dlaset_("A", &n, &c__1, &c_b30, &c_b30, &u2[u2_offset], ldu2);
+ u2[nlp1 + u2_dim1] = 1.;
+ if (m > n) {
+ i__1 = nlp1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ vt[m + i__ * vt_dim1] = -s * vt[nlp1 + i__ * vt_dim1];
+ vt2[i__ * vt2_dim1 + 1] = c__ * vt[nlp1 + i__ * vt_dim1];
+/* L170: */
+ }
+ i__1 = m;
+ for (i__ = nlp2; i__ <= i__1; ++i__) {
+ vt2[i__ * vt2_dim1 + 1] = s * vt[m + i__ * vt_dim1];
+ vt[m + i__ * vt_dim1] = c__ * vt[m + i__ * vt_dim1];
+/* L180: */
+ }
+ } else {
+ dcopy_(&m, &vt[nlp1 + vt_dim1], ldvt, &vt2[vt2_dim1 + 1], ldvt2);
+ }
+ if (m > n) {
+ dcopy_(&m, &vt[m + vt_dim1], ldvt, &vt2[m + vt2_dim1], ldvt2);
+ }
+
+/* The deflated singular values and their corresponding vectors go */
+/* into the back of D, U, and V respectively. */
+
+ if (n > *k) {
+ i__1 = n - *k;
+ dcopy_(&i__1, &dsigma[*k + 1], &c__1, &d__[*k + 1], &c__1);
+ i__1 = n - *k;
+ dlacpy_("A", &n, &i__1, &u2[(*k + 1) * u2_dim1 + 1], ldu2, &u[(*k + 1)
+ * u_dim1 + 1], ldu);
+ i__1 = n - *k;
+ dlacpy_("A", &i__1, &m, &vt2[*k + 1 + vt2_dim1], ldvt2, &vt[*k + 1 +
+ vt_dim1], ldvt);
+ }
+
+/* Copy CTOT into COLTYP for referencing in DLASD3. */
+
+ for (j = 1; j <= 4; ++j) {
+ coltyp[j] = ctot[j - 1];
+/* L190: */
+ }
+
+ return 0;
+
+/* End of DLASD2 */
+
+} /* dlasd2_ */
diff --git a/SRC/dlasd3.c b/SRC/dlasd3.c
new file mode 100644
index 0000000..db8089b
--- /dev/null
+++ b/SRC/dlasd3.c
@@ -0,0 +1,452 @@
+/* dlasd3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static doublereal c_b13 = 1.;
+static doublereal c_b26 = 0.;
+
+/* Subroutine */ int dlasd3_(integer *nl, integer *nr, integer *sqre, integer
+ *k, doublereal *d__, doublereal *q, integer *ldq, doublereal *dsigma,
+ doublereal *u, integer *ldu, doublereal *u2, integer *ldu2,
+ doublereal *vt, integer *ldvt, doublereal *vt2, integer *ldvt2,
+ integer *idxc, integer *ctot, doublereal *z__, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, u_dim1, u_offset, u2_dim1, u2_offset, vt_dim1,
+ vt_offset, vt2_dim1, vt2_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer i__, j, m, n, jc;
+ doublereal rho;
+ integer nlp1, nlp2, nrp1;
+ doublereal temp;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ integer ctemp;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer ktemp;
+ extern doublereal dlamc3_(doublereal *, doublereal *);
+ extern /* Subroutine */ int dlasd4_(integer *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *), dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), dlacpy_(char *, integer *, integer
+ *, doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASD3 finds all the square roots of the roots of the secular */
+/* equation, as defined by the values in D and Z. It makes the */
+/* appropriate calls to DLASD4 and then updates the singular */
+/* vectors by matrix multiplication. */
+
+/* This code makes very mild assumptions about floating point */
+/* arithmetic. It will work on machines with a guard digit in */
+/* add/subtract, or on those binary machines without guard digits */
+/* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. */
+/* It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* DLASD3 is called from DLASD1. */
+
+/* Arguments */
+/* ========= */
+
+/* NL (input) INTEGER */
+/* The row dimension of the upper block. NL >= 1. */
+
+/* NR (input) INTEGER */
+/* The row dimension of the lower block. NR >= 1. */
+
+/* SQRE (input) INTEGER */
+/* = 0: the lower block is an NR-by-NR square matrix. */
+/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */
+
+/* The bidiagonal matrix has N = NL + NR + 1 rows and */
+/* M = N + SQRE >= N columns. */
+
+/* K (input) INTEGER */
+/* The size of the secular equation, 1 =< K = < N. */
+
+/* D (output) DOUBLE PRECISION array, dimension(K) */
+/* On exit the square roots of the roots of the secular equation, */
+/* in ascending order. */
+
+/* Q (workspace) DOUBLE PRECISION array, */
+/* dimension at least (LDQ,K). */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= K. */
+
+/* DSIGMA (input) DOUBLE PRECISION array, dimension(K) */
+/* The first K elements of this array contain the old roots */
+/* of the deflated updating problem. These are the poles */
+/* of the secular equation. */
+
+/* U (output) DOUBLE PRECISION array, dimension (LDU, N) */
+/* The last N - K columns of this matrix contain the deflated */
+/* left singular vectors. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= N. */
+
+/* U2 (input/output) DOUBLE PRECISION array, dimension (LDU2, N) */
+/* The first K columns of this matrix contain the non-deflated */
+/* left singular vectors for the split problem. */
+
+/* LDU2 (input) INTEGER */
+/* The leading dimension of the array U2. LDU2 >= N. */
+
+/* VT (output) DOUBLE PRECISION array, dimension (LDVT, M) */
+/* The last M - K columns of VT' contain the deflated */
+/* right singular vectors. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. LDVT >= N. */
+
+/* VT2 (input/output) DOUBLE PRECISION array, dimension (LDVT2, N) */
+/* The first K columns of VT2' contain the non-deflated */
+/* right singular vectors for the split problem. */
+
+/* LDVT2 (input) INTEGER */
+/* The leading dimension of the array VT2. LDVT2 >= N. */
+
+/* IDXC (input) INTEGER array, dimension ( N ) */
+/* The permutation used to arrange the columns of U (and rows of */
+/* VT) into three groups: the first group contains non-zero */
+/* entries only at and above (or before) NL +1; the second */
+/* contains non-zero entries only at and below (or after) NL+2; */
+/* and the third is dense. The first column of U and the row of */
+/* VT are treated separately, however. */
+
+/* The rows of the singular vectors found by DLASD4 */
+/* must be likewise permuted before the matrix multiplies can */
+/* take place. */
+
+/* CTOT (input) INTEGER array, dimension ( 4 ) */
+/* A count of the total number of the various types of columns */
+/* in U (or rows in VT), as described in IDXC. The fourth column */
+/* type is any column which has been deflated. */
+
+/* Z (input) DOUBLE PRECISION array, dimension (K) */
+/* The first K elements of this array contain the components */
+/* of the deflation-adjusted updating row vector. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, an singular value did not converge */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --dsigma;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ u2_dim1 = *ldu2;
+ u2_offset = 1 + u2_dim1;
+ u2 -= u2_offset;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ vt2_dim1 = *ldvt2;
+ vt2_offset = 1 + vt2_dim1;
+ vt2 -= vt2_offset;
+ --idxc;
+ --ctot;
+ --z__;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*nl < 1) {
+ *info = -1;
+ } else if (*nr < 1) {
+ *info = -2;
+ } else if (*sqre != 1 && *sqre != 0) {
+ *info = -3;
+ }
+
+ n = *nl + *nr + 1;
+ m = n + *sqre;
+ nlp1 = *nl + 1;
+ nlp2 = *nl + 2;
+
+ if (*k < 1 || *k > n) {
+ *info = -4;
+ } else if (*ldq < *k) {
+ *info = -7;
+ } else if (*ldu < n) {
+ *info = -10;
+ } else if (*ldu2 < n) {
+ *info = -12;
+ } else if (*ldvt < m) {
+ *info = -14;
+ } else if (*ldvt2 < m) {
+ *info = -16;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLASD3", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*k == 1) {
+ d__[1] = abs(z__[1]);
+ dcopy_(&m, &vt2[vt2_dim1 + 1], ldvt2, &vt[vt_dim1 + 1], ldvt);
+ if (z__[1] > 0.) {
+ dcopy_(&n, &u2[u2_dim1 + 1], &c__1, &u[u_dim1 + 1], &c__1);
+ } else {
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ u[i__ + u_dim1] = -u2[i__ + u2_dim1];
+/* L10: */
+ }
+ }
+ return 0;
+ }
+
+/* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can */
+/* be computed with high relative accuracy (barring over/underflow). */
+/* This is a problem on machines without a guard digit in */
+/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */
+/* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), */
+/* which on any of these machines zeros out the bottommost */
+/* bit of DSIGMA(I) if it is 1; this makes the subsequent */
+/* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation */
+/* occurs. On binary machines with a guard digit (almost all */
+/* machines) it does not change DSIGMA(I) at all. On hexadecimal */
+/* and decimal machines with a guard digit, it slightly */
+/* changes the bottommost bits of DSIGMA(I). It does not account */
+/* for hexadecimal or decimal machines without guard digits */
+/* (we know of none). We use a subroutine call to compute */
+/* 2*DSIGMA(I) to prevent optimizing compilers from eliminating */
+/* this code. */
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dsigma[i__] = dlamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__];
+/* L20: */
+ }
+
+/* Keep a copy of Z. */
+
+ dcopy_(k, &z__[1], &c__1, &q[q_offset], &c__1);
+
+/* Normalize Z. */
+
+ rho = dnrm2_(k, &z__[1], &c__1);
+ dlascl_("G", &c__0, &c__0, &rho, &c_b13, k, &c__1, &z__[1], k, info);
+ rho *= rho;
+
+/* Find the new singular values. */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ dlasd4_(k, &j, &dsigma[1], &z__[1], &u[j * u_dim1 + 1], &rho, &d__[j],
+ &vt[j * vt_dim1 + 1], info);
+
+/* If the zero finder fails, the computation is terminated. */
+
+ if (*info != 0) {
+ return 0;
+ }
+/* L30: */
+ }
+
+/* Compute updated Z. */
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ z__[i__] = u[i__ + *k * u_dim1] * vt[i__ + *k * vt_dim1];
+ i__2 = i__ - 1;
+ for (j = 1; j <= i__2; ++j) {
+ z__[i__] *= u[i__ + j * u_dim1] * vt[i__ + j * vt_dim1] / (dsigma[
+ i__] - dsigma[j]) / (dsigma[i__] + dsigma[j]);
+/* L40: */
+ }
+ i__2 = *k - 1;
+ for (j = i__; j <= i__2; ++j) {
+ z__[i__] *= u[i__ + j * u_dim1] * vt[i__ + j * vt_dim1] / (dsigma[
+ i__] - dsigma[j + 1]) / (dsigma[i__] + dsigma[j + 1]);
+/* L50: */
+ }
+ d__2 = sqrt((d__1 = z__[i__], abs(d__1)));
+ z__[i__] = d_sign(&d__2, &q[i__ + q_dim1]);
+/* L60: */
+ }
+
+/* Compute left singular vectors of the modified diagonal matrix, */
+/* and store related information for the right singular vectors. */
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ vt[i__ * vt_dim1 + 1] = z__[1] / u[i__ * u_dim1 + 1] / vt[i__ *
+ vt_dim1 + 1];
+ u[i__ * u_dim1 + 1] = -1.;
+ i__2 = *k;
+ for (j = 2; j <= i__2; ++j) {
+ vt[j + i__ * vt_dim1] = z__[j] / u[j + i__ * u_dim1] / vt[j + i__
+ * vt_dim1];
+ u[j + i__ * u_dim1] = dsigma[j] * vt[j + i__ * vt_dim1];
+/* L70: */
+ }
+ temp = dnrm2_(k, &u[i__ * u_dim1 + 1], &c__1);
+ q[i__ * q_dim1 + 1] = u[i__ * u_dim1 + 1] / temp;
+ i__2 = *k;
+ for (j = 2; j <= i__2; ++j) {
+ jc = idxc[j];
+ q[j + i__ * q_dim1] = u[jc + i__ * u_dim1] / temp;
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Update the left singular vector matrix. */
+
+ if (*k == 2) {
+ dgemm_("N", "N", &n, k, k, &c_b13, &u2[u2_offset], ldu2, &q[q_offset],
+ ldq, &c_b26, &u[u_offset], ldu);
+ goto L100;
+ }
+ if (ctot[1] > 0) {
+ dgemm_("N", "N", nl, k, &ctot[1], &c_b13, &u2[(u2_dim1 << 1) + 1],
+ ldu2, &q[q_dim1 + 2], ldq, &c_b26, &u[u_dim1 + 1], ldu);
+ if (ctot[3] > 0) {
+ ktemp = ctot[1] + 2 + ctot[2];
+ dgemm_("N", "N", nl, k, &ctot[3], &c_b13, &u2[ktemp * u2_dim1 + 1]
+, ldu2, &q[ktemp + q_dim1], ldq, &c_b13, &u[u_dim1 + 1],
+ ldu);
+ }
+ } else if (ctot[3] > 0) {
+ ktemp = ctot[1] + 2 + ctot[2];
+ dgemm_("N", "N", nl, k, &ctot[3], &c_b13, &u2[ktemp * u2_dim1 + 1],
+ ldu2, &q[ktemp + q_dim1], ldq, &c_b26, &u[u_dim1 + 1], ldu);
+ } else {
+ dlacpy_("F", nl, k, &u2[u2_offset], ldu2, &u[u_offset], ldu);
+ }
+ dcopy_(k, &q[q_dim1 + 1], ldq, &u[nlp1 + u_dim1], ldu);
+ ktemp = ctot[1] + 2;
+ ctemp = ctot[2] + ctot[3];
+ dgemm_("N", "N", nr, k, &ctemp, &c_b13, &u2[nlp2 + ktemp * u2_dim1], ldu2,
+ &q[ktemp + q_dim1], ldq, &c_b26, &u[nlp2 + u_dim1], ldu);
+
+/* Generate the right singular vectors. */
+
+L100:
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = dnrm2_(k, &vt[i__ * vt_dim1 + 1], &c__1);
+ q[i__ + q_dim1] = vt[i__ * vt_dim1 + 1] / temp;
+ i__2 = *k;
+ for (j = 2; j <= i__2; ++j) {
+ jc = idxc[j];
+ q[i__ + j * q_dim1] = vt[jc + i__ * vt_dim1] / temp;
+/* L110: */
+ }
+/* L120: */
+ }
+
+/* Update the right singular vector matrix. */
+
+ if (*k == 2) {
+ dgemm_("N", "N", k, &m, k, &c_b13, &q[q_offset], ldq, &vt2[vt2_offset]
+, ldvt2, &c_b26, &vt[vt_offset], ldvt);
+ return 0;
+ }
+ ktemp = ctot[1] + 1;
+ dgemm_("N", "N", k, &nlp1, &ktemp, &c_b13, &q[q_dim1 + 1], ldq, &vt2[
+ vt2_dim1 + 1], ldvt2, &c_b26, &vt[vt_dim1 + 1], ldvt);
+ ktemp = ctot[1] + 2 + ctot[2];
+ if (ktemp <= *ldvt2) {
+ dgemm_("N", "N", k, &nlp1, &ctot[3], &c_b13, &q[ktemp * q_dim1 + 1],
+ ldq, &vt2[ktemp + vt2_dim1], ldvt2, &c_b13, &vt[vt_dim1 + 1],
+ ldvt);
+ }
+
+ ktemp = ctot[1] + 1;
+ nrp1 = *nr + *sqre;
+ if (ktemp > 1) {
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ q[i__ + ktemp * q_dim1] = q[i__ + q_dim1];
+/* L130: */
+ }
+ i__1 = m;
+ for (i__ = nlp2; i__ <= i__1; ++i__) {
+ vt2[ktemp + i__ * vt2_dim1] = vt2[i__ * vt2_dim1 + 1];
+/* L140: */
+ }
+ }
+ ctemp = ctot[2] + 1 + ctot[3];
+ dgemm_("N", "N", k, &nrp1, &ctemp, &c_b13, &q[ktemp * q_dim1 + 1], ldq, &
+ vt2[ktemp + nlp2 * vt2_dim1], ldvt2, &c_b26, &vt[nlp2 * vt_dim1 +
+ 1], ldvt);
+
+ return 0;
+
+/* End of DLASD3 */
+
+} /* dlasd3_ */
diff --git a/SRC/dlasd4.c b/SRC/dlasd4.c
new file mode 100644
index 0000000..54455ed
--- /dev/null
+++ b/SRC/dlasd4.c
@@ -0,0 +1,1010 @@
+/* dlasd4.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlasd4_(integer *n, integer *i__, doublereal *d__,
+ doublereal *z__, doublereal *delta, doublereal *rho, doublereal *
+ sigma, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal a, b, c__;
+ integer j;
+ doublereal w, dd[3];
+ integer ii;
+ doublereal dw, zz[3];
+ integer ip1;
+ doublereal eta, phi, eps, tau, psi;
+ integer iim1, iip1;
+ doublereal dphi, dpsi;
+ integer iter;
+ doublereal temp, prew, sg2lb, sg2ub, temp1, temp2, dtiim, delsq, dtiip;
+ integer niter;
+ doublereal dtisq;
+ logical swtch;
+ doublereal dtnsq;
+ extern /* Subroutine */ int dlaed6_(integer *, logical *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *)
+ , dlasd5_(integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *);
+ doublereal delsq2, dtnsq1;
+ logical swtch3;
+ extern doublereal dlamch_(char *);
+ logical orgati;
+ doublereal erretm, dtipsq, rhoinv;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This subroutine computes the square root of the I-th updated */
+/* eigenvalue of a positive symmetric rank-one modification to */
+/* a positive diagonal matrix whose entries are given as the squares */
+/* of the corresponding entries in the array d, and that */
+
+/* 0 <= D(i) < D(j) for i < j */
+
+/* and that RHO > 0. This is arranged by the calling routine, and is */
+/* no loss in generality. The rank-one modified system is thus */
+
+/* diag( D ) * diag( D ) + RHO * Z * Z_transpose. */
+
+/* where we assume the Euclidean norm of Z is 1. */
+
+/* The method consists of approximating the rational functions in the */
+/* secular equation by simpler interpolating rational functions. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The length of all arrays. */
+
+/* I (input) INTEGER */
+/* The index of the eigenvalue to be computed. 1 <= I <= N. */
+
+/* D (input) DOUBLE PRECISION array, dimension ( N ) */
+/* The original eigenvalues. It is assumed that they are in */
+/* order, 0 <= D(I) < D(J) for I < J. */
+
+/* Z (input) DOUBLE PRECISION array, dimension ( N ) */
+/* The components of the updating vector. */
+
+/* DELTA (output) DOUBLE PRECISION array, dimension ( N ) */
+/* If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th */
+/* component. If N = 1, then DELTA(1) = 1. The vector DELTA */
+/* contains the information necessary to construct the */
+/* (singular) eigenvectors. */
+
+/* RHO (input) DOUBLE PRECISION */
+/* The scalar in the symmetric updating formula. */
+
+/* SIGMA (output) DOUBLE PRECISION */
+/* The computed sigma_I, the I-th updated eigenvalue. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension ( N ) */
+/* If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th */
+/* component. If N = 1, then WORK( 1 ) = 1. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* > 0: if INFO = 1, the updating process failed. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* Logical variable ORGATI (origin-at-i?) is used for distinguishing */
+/* whether D(i) or D(i+1) is treated as the origin. */
+
+/* ORGATI = .true. origin at i */
+/* ORGATI = .false. origin at i+1 */
+
+/* Logical variable SWTCH3 (switch-for-3-poles?) is for noting */
+/* if we are working with THREE poles! */
+
+/* MAXIT is the maximum number of iterations allowed for each */
+/* eigenvalue. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ren-Cang Li, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Since this routine is called in an inner loop, we do no argument */
+/* checking. */
+
+/* Quick return for N=1 and 2. */
+
+ /* Parameter adjustments */
+ --work;
+ --delta;
+ --z__;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+ if (*n == 1) {
+
+/* Presumably, I=1 upon entry */
+
+ *sigma = sqrt(d__[1] * d__[1] + *rho * z__[1] * z__[1]);
+ delta[1] = 1.;
+ work[1] = 1.;
+ return 0;
+ }
+ if (*n == 2) {
+ dlasd5_(i__, &d__[1], &z__[1], &delta[1], rho, sigma, &work[1]);
+ return 0;
+ }
+
+/* Compute machine epsilon */
+
+ eps = dlamch_("Epsilon");
+ rhoinv = 1. / *rho;
+
+/* The case I = N */
+
+ if (*i__ == *n) {
+
+/* Initialize some basic variables */
+
+ ii = *n - 1;
+ niter = 1;
+
+/* Calculate initial guess */
+
+ temp = *rho / 2.;
+
+/* If ||Z||_2 is not one, then TEMP should be set to */
+/* RHO * ||Z||_2^2 / TWO */
+
+ temp1 = temp / (d__[*n] + sqrt(d__[*n] * d__[*n] + temp));
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[j] = d__[j] + d__[*n] + temp1;
+ delta[j] = d__[j] - d__[*n] - temp1;
+/* L10: */
+ }
+
+ psi = 0.;
+ i__1 = *n - 2;
+ for (j = 1; j <= i__1; ++j) {
+ psi += z__[j] * z__[j] / (delta[j] * work[j]);
+/* L20: */
+ }
+
+ c__ = rhoinv + psi;
+ w = c__ + z__[ii] * z__[ii] / (delta[ii] * work[ii]) + z__[*n] * z__[*
+ n] / (delta[*n] * work[*n]);
+
+ if (w <= 0.) {
+ temp1 = sqrt(d__[*n] * d__[*n] + *rho);
+ temp = z__[*n - 1] * z__[*n - 1] / ((d__[*n - 1] + temp1) * (d__[*
+ n] - d__[*n - 1] + *rho / (d__[*n] + temp1))) + z__[*n] *
+ z__[*n] / *rho;
+
+/* The following TAU is to approximate */
+/* SIGMA_n^2 - D( N )*D( N ) */
+
+ if (c__ <= temp) {
+ tau = *rho;
+ } else {
+ delsq = (d__[*n] - d__[*n - 1]) * (d__[*n] + d__[*n - 1]);
+ a = -c__ * delsq + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*
+ n];
+ b = z__[*n] * z__[*n] * delsq;
+ if (a < 0.) {
+ tau = b * 2. / (sqrt(a * a + b * 4. * c__) - a);
+ } else {
+ tau = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.);
+ }
+ }
+
+/* It can be proved that */
+/* D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU <= D(N)^2+RHO */
+
+ } else {
+ delsq = (d__[*n] - d__[*n - 1]) * (d__[*n] + d__[*n - 1]);
+ a = -c__ * delsq + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n];
+ b = z__[*n] * z__[*n] * delsq;
+
+/* The following TAU is to approximate */
+/* SIGMA_n^2 - D( N )*D( N ) */
+
+ if (a < 0.) {
+ tau = b * 2. / (sqrt(a * a + b * 4. * c__) - a);
+ } else {
+ tau = (a + sqrt(a * a + b * 4. * c__)) / (c__ * 2.);
+ }
+
+/* It can be proved that */
+/* D(N)^2 < D(N)^2+TAU < SIGMA(N)^2 < D(N)^2+RHO/2 */
+
+ }
+
+/* The following ETA is to approximate SIGMA_n - D( N ) */
+
+ eta = tau / (d__[*n] + sqrt(d__[*n] * d__[*n] + tau));
+
+ *sigma = d__[*n] + eta;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] = d__[j] - d__[*i__] - eta;
+ work[j] = d__[j] + d__[*i__] + eta;
+/* L30: */
+ }
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.;
+ psi = 0.;
+ erretm = 0.;
+ i__1 = ii;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / (delta[j] * work[j]);
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L40: */
+ }
+ erretm = abs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ temp = z__[*n] / (delta[*n] * work[*n]);
+ phi = z__[*n] * temp;
+ dphi = temp * temp;
+ erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (dpsi
+ + dphi);
+
+ w = rhoinv + phi + psi;
+
+/* Test for convergence */
+
+ if (abs(w) <= eps * erretm) {
+ goto L240;
+ }
+
+/* Calculate the new step */
+
+ ++niter;
+ dtnsq1 = work[*n - 1] * delta[*n - 1];
+ dtnsq = work[*n] * delta[*n];
+ c__ = w - dtnsq1 * dpsi - dtnsq * dphi;
+ a = (dtnsq + dtnsq1) * w - dtnsq * dtnsq1 * (dpsi + dphi);
+ b = dtnsq * dtnsq1 * w;
+ if (c__ < 0.) {
+ c__ = abs(c__);
+ }
+ if (c__ == 0.) {
+ eta = *rho - *sigma * *sigma;
+ } else if (a >= 0.) {
+ eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (c__
+ * 2.);
+ } else {
+ eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))
+ );
+ }
+
+/* Note, eta should be positive if w is negative, and */
+/* eta should be negative otherwise. However, */
+/* if for some reason caused by roundoff, eta*w > 0, */
+/* we simply use one Newton step instead. This way */
+/* will guarantee eta*w < 0. */
+
+ if (w * eta > 0.) {
+ eta = -w / (dpsi + dphi);
+ }
+ temp = eta - dtnsq;
+ if (temp > *rho) {
+ eta = *rho + dtnsq;
+ }
+
+ tau += eta;
+ eta /= *sigma + sqrt(eta + *sigma * *sigma);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] -= eta;
+ work[j] += eta;
+/* L50: */
+ }
+
+ *sigma += eta;
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.;
+ psi = 0.;
+ erretm = 0.;
+ i__1 = ii;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / (work[j] * delta[j]);
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L60: */
+ }
+ erretm = abs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ temp = z__[*n] / (work[*n] * delta[*n]);
+ phi = z__[*n] * temp;
+ dphi = temp * temp;
+ erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (dpsi
+ + dphi);
+
+ w = rhoinv + phi + psi;
+
+/* Main loop to update the values of the array DELTA */
+
+ iter = niter + 1;
+
+ for (niter = iter; niter <= 20; ++niter) {
+
+/* Test for convergence */
+
+ if (abs(w) <= eps * erretm) {
+ goto L240;
+ }
+
+/* Calculate the new step */
+
+ dtnsq1 = work[*n - 1] * delta[*n - 1];
+ dtnsq = work[*n] * delta[*n];
+ c__ = w - dtnsq1 * dpsi - dtnsq * dphi;
+ a = (dtnsq + dtnsq1) * w - dtnsq1 * dtnsq * (dpsi + dphi);
+ b = dtnsq1 * dtnsq * w;
+ if (a >= 0.) {
+ eta = (a + sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (
+ c__ * 2.);
+ } else {
+ eta = b * 2. / (a - sqrt((d__1 = a * a - b * 4. * c__, abs(
+ d__1))));
+ }
+
+/* Note, eta should be positive if w is negative, and */
+/* eta should be negative otherwise. However, */
+/* if for some reason caused by roundoff, eta*w > 0, */
+/* we simply use one Newton step instead. This way */
+/* will guarantee eta*w < 0. */
+
+ if (w * eta > 0.) {
+ eta = -w / (dpsi + dphi);
+ }
+ temp = eta - dtnsq;
+ if (temp <= 0.) {
+ eta /= 2.;
+ }
+
+ tau += eta;
+ eta /= *sigma + sqrt(eta + *sigma * *sigma);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] -= eta;
+ work[j] += eta;
+/* L70: */
+ }
+
+ *sigma += eta;
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.;
+ psi = 0.;
+ erretm = 0.;
+ i__1 = ii;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / (work[j] * delta[j]);
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L80: */
+ }
+ erretm = abs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ temp = z__[*n] / (work[*n] * delta[*n]);
+ phi = z__[*n] * temp;
+ dphi = temp * temp;
+ erretm = (-phi - psi) * 8. + erretm - phi + rhoinv + abs(tau) * (
+ dpsi + dphi);
+
+ w = rhoinv + phi + psi;
+/* L90: */
+ }
+
+/* Return with INFO = 1, NITER = MAXIT and not converged */
+
+ *info = 1;
+ goto L240;
+
+/* End for the case I = N */
+
+ } else {
+
+/* The case for I < N */
+
+ niter = 1;
+ ip1 = *i__ + 1;
+
+/* Calculate initial guess */
+
+ delsq = (d__[ip1] - d__[*i__]) * (d__[ip1] + d__[*i__]);
+ delsq2 = delsq / 2.;
+ temp = delsq2 / (d__[*i__] + sqrt(d__[*i__] * d__[*i__] + delsq2));
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[j] = d__[j] + d__[*i__] + temp;
+ delta[j] = d__[j] - d__[*i__] - temp;
+/* L100: */
+ }
+
+ psi = 0.;
+ i__1 = *i__ - 1;
+ for (j = 1; j <= i__1; ++j) {
+ psi += z__[j] * z__[j] / (work[j] * delta[j]);
+/* L110: */
+ }
+
+ phi = 0.;
+ i__1 = *i__ + 2;
+ for (j = *n; j >= i__1; --j) {
+ phi += z__[j] * z__[j] / (work[j] * delta[j]);
+/* L120: */
+ }
+ c__ = rhoinv + psi + phi;
+ w = c__ + z__[*i__] * z__[*i__] / (work[*i__] * delta[*i__]) + z__[
+ ip1] * z__[ip1] / (work[ip1] * delta[ip1]);
+
+ if (w > 0.) {
+
+/* d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2 */
+
+/* We choose d(i) as origin. */
+
+ orgati = TRUE_;
+ sg2lb = 0.;
+ sg2ub = delsq2;
+ a = c__ * delsq + z__[*i__] * z__[*i__] + z__[ip1] * z__[ip1];
+ b = z__[*i__] * z__[*i__] * delsq;
+ if (a > 0.) {
+ tau = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(
+ d__1))));
+ } else {
+ tau = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (
+ c__ * 2.);
+ }
+
+/* TAU now is an estimation of SIGMA^2 - D( I )^2. The */
+/* following, however, is the corresponding estimation of */
+/* SIGMA - D( I ). */
+
+ eta = tau / (d__[*i__] + sqrt(d__[*i__] * d__[*i__] + tau));
+ } else {
+
+/* (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2 */
+
+/* We choose d(i+1) as origin. */
+
+ orgati = FALSE_;
+ sg2lb = -delsq2;
+ sg2ub = 0.;
+ a = c__ * delsq - z__[*i__] * z__[*i__] - z__[ip1] * z__[ip1];
+ b = z__[ip1] * z__[ip1] * delsq;
+ if (a < 0.) {
+ tau = b * 2. / (a - sqrt((d__1 = a * a + b * 4. * c__, abs(
+ d__1))));
+ } else {
+ tau = -(a + sqrt((d__1 = a * a + b * 4. * c__, abs(d__1)))) /
+ (c__ * 2.);
+ }
+
+/* TAU now is an estimation of SIGMA^2 - D( IP1 )^2. The */
+/* following, however, is the corresponding estimation of */
+/* SIGMA - D( IP1 ). */
+
+ eta = tau / (d__[ip1] + sqrt((d__1 = d__[ip1] * d__[ip1] + tau,
+ abs(d__1))));
+ }
+
+ if (orgati) {
+ ii = *i__;
+ *sigma = d__[*i__] + eta;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[j] = d__[j] + d__[*i__] + eta;
+ delta[j] = d__[j] - d__[*i__] - eta;
+/* L130: */
+ }
+ } else {
+ ii = *i__ + 1;
+ *sigma = d__[ip1] + eta;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[j] = d__[j] + d__[ip1] + eta;
+ delta[j] = d__[j] - d__[ip1] - eta;
+/* L140: */
+ }
+ }
+ iim1 = ii - 1;
+ iip1 = ii + 1;
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.;
+ psi = 0.;
+ erretm = 0.;
+ i__1 = iim1;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / (work[j] * delta[j]);
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L150: */
+ }
+ erretm = abs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ dphi = 0.;
+ phi = 0.;
+ i__1 = iip1;
+ for (j = *n; j >= i__1; --j) {
+ temp = z__[j] / (work[j] * delta[j]);
+ phi += z__[j] * temp;
+ dphi += temp * temp;
+ erretm += phi;
+/* L160: */
+ }
+
+ w = rhoinv + phi + psi;
+
+/* W is the value of the secular function with */
+/* its ii-th element removed. */
+
+ swtch3 = FALSE_;
+ if (orgati) {
+ if (w < 0.) {
+ swtch3 = TRUE_;
+ }
+ } else {
+ if (w > 0.) {
+ swtch3 = TRUE_;
+ }
+ }
+ if (ii == 1 || ii == *n) {
+ swtch3 = FALSE_;
+ }
+
+ temp = z__[ii] / (work[ii] * delta[ii]);
+ dw = dpsi + dphi + temp * temp;
+ temp = z__[ii] * temp;
+ w += temp;
+ erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. +
+ abs(tau) * dw;
+
+/* Test for convergence */
+
+ if (abs(w) <= eps * erretm) {
+ goto L240;
+ }
+
+ if (w <= 0.) {
+ sg2lb = max(sg2lb,tau);
+ } else {
+ sg2ub = min(sg2ub,tau);
+ }
+
+/* Calculate the new step */
+
+ ++niter;
+ if (! swtch3) {
+ dtipsq = work[ip1] * delta[ip1];
+ dtisq = work[*i__] * delta[*i__];
+ if (orgati) {
+/* Computing 2nd power */
+ d__1 = z__[*i__] / dtisq;
+ c__ = w - dtipsq * dw + delsq * (d__1 * d__1);
+ } else {
+/* Computing 2nd power */
+ d__1 = z__[ip1] / dtipsq;
+ c__ = w - dtisq * dw - delsq * (d__1 * d__1);
+ }
+ a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw;
+ b = dtipsq * dtisq * w;
+ if (c__ == 0.) {
+ if (a == 0.) {
+ if (orgati) {
+ a = z__[*i__] * z__[*i__] + dtipsq * dtipsq * (dpsi +
+ dphi);
+ } else {
+ a = z__[ip1] * z__[ip1] + dtisq * dtisq * (dpsi +
+ dphi);
+ }
+ }
+ eta = b / a;
+ } else if (a <= 0.) {
+ eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1)))) / (
+ c__ * 2.);
+ } else {
+ eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__, abs(
+ d__1))));
+ }
+ } else {
+
+/* Interpolation using THREE most relevant poles */
+
+ dtiim = work[iim1] * delta[iim1];
+ dtiip = work[iip1] * delta[iip1];
+ temp = rhoinv + psi + phi;
+ if (orgati) {
+ temp1 = z__[iim1] / dtiim;
+ temp1 *= temp1;
+ c__ = temp - dtiip * (dpsi + dphi) - (d__[iim1] - d__[iip1]) *
+ (d__[iim1] + d__[iip1]) * temp1;
+ zz[0] = z__[iim1] * z__[iim1];
+ if (dpsi < temp1) {
+ zz[2] = dtiip * dtiip * dphi;
+ } else {
+ zz[2] = dtiip * dtiip * (dpsi - temp1 + dphi);
+ }
+ } else {
+ temp1 = z__[iip1] / dtiip;
+ temp1 *= temp1;
+ c__ = temp - dtiim * (dpsi + dphi) - (d__[iip1] - d__[iim1]) *
+ (d__[iim1] + d__[iip1]) * temp1;
+ if (dphi < temp1) {
+ zz[0] = dtiim * dtiim * dpsi;
+ } else {
+ zz[0] = dtiim * dtiim * (dpsi + (dphi - temp1));
+ }
+ zz[2] = z__[iip1] * z__[iip1];
+ }
+ zz[1] = z__[ii] * z__[ii];
+ dd[0] = dtiim;
+ dd[1] = delta[ii] * work[ii];
+ dd[2] = dtiip;
+ dlaed6_(&niter, &orgati, &c__, dd, zz, &w, &eta, info);
+ if (*info != 0) {
+ goto L240;
+ }
+ }
+
+/* Note, eta should be positive if w is negative, and */
+/* eta should be negative otherwise. However, */
+/* if for some reason caused by roundoff, eta*w > 0, */
+/* we simply use one Newton step instead. This way */
+/* will guarantee eta*w < 0. */
+
+ if (w * eta >= 0.) {
+ eta = -w / dw;
+ }
+ if (orgati) {
+ temp1 = work[*i__] * delta[*i__];
+ temp = eta - temp1;
+ } else {
+ temp1 = work[ip1] * delta[ip1];
+ temp = eta - temp1;
+ }
+ if (temp > sg2ub || temp < sg2lb) {
+ if (w < 0.) {
+ eta = (sg2ub - tau) / 2.;
+ } else {
+ eta = (sg2lb - tau) / 2.;
+ }
+ }
+
+ tau += eta;
+ eta /= *sigma + sqrt(*sigma * *sigma + eta);
+
+ prew = w;
+
+ *sigma += eta;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[j] += eta;
+ delta[j] -= eta;
+/* L170: */
+ }
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.;
+ psi = 0.;
+ erretm = 0.;
+ i__1 = iim1;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / (work[j] * delta[j]);
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L180: */
+ }
+ erretm = abs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ dphi = 0.;
+ phi = 0.;
+ i__1 = iip1;
+ for (j = *n; j >= i__1; --j) {
+ temp = z__[j] / (work[j] * delta[j]);
+ phi += z__[j] * temp;
+ dphi += temp * temp;
+ erretm += phi;
+/* L190: */
+ }
+
+ temp = z__[ii] / (work[ii] * delta[ii]);
+ dw = dpsi + dphi + temp * temp;
+ temp = z__[ii] * temp;
+ w = rhoinv + phi + psi + temp;
+ erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3. +
+ abs(tau) * dw;
+
+ if (w <= 0.) {
+ sg2lb = max(sg2lb,tau);
+ } else {
+ sg2ub = min(sg2ub,tau);
+ }
+
+ swtch = FALSE_;
+ if (orgati) {
+ if (-w > abs(prew) / 10.) {
+ swtch = TRUE_;
+ }
+ } else {
+ if (w > abs(prew) / 10.) {
+ swtch = TRUE_;
+ }
+ }
+
+/* Main loop to update the values of the array DELTA and WORK */
+
+ iter = niter + 1;
+
+ for (niter = iter; niter <= 20; ++niter) {
+
+/* Test for convergence */
+
+ if (abs(w) <= eps * erretm) {
+ goto L240;
+ }
+
+/* Calculate the new step */
+
+ if (! swtch3) {
+ dtipsq = work[ip1] * delta[ip1];
+ dtisq = work[*i__] * delta[*i__];
+ if (! swtch) {
+ if (orgati) {
+/* Computing 2nd power */
+ d__1 = z__[*i__] / dtisq;
+ c__ = w - dtipsq * dw + delsq * (d__1 * d__1);
+ } else {
+/* Computing 2nd power */
+ d__1 = z__[ip1] / dtipsq;
+ c__ = w - dtisq * dw - delsq * (d__1 * d__1);
+ }
+ } else {
+ temp = z__[ii] / (work[ii] * delta[ii]);
+ if (orgati) {
+ dpsi += temp * temp;
+ } else {
+ dphi += temp * temp;
+ }
+ c__ = w - dtisq * dpsi - dtipsq * dphi;
+ }
+ a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw;
+ b = dtipsq * dtisq * w;
+ if (c__ == 0.) {
+ if (a == 0.) {
+ if (! swtch) {
+ if (orgati) {
+ a = z__[*i__] * z__[*i__] + dtipsq * dtipsq *
+ (dpsi + dphi);
+ } else {
+ a = z__[ip1] * z__[ip1] + dtisq * dtisq * (
+ dpsi + dphi);
+ }
+ } else {
+ a = dtisq * dtisq * dpsi + dtipsq * dtipsq * dphi;
+ }
+ }
+ eta = b / a;
+ } else if (a <= 0.) {
+ eta = (a - sqrt((d__1 = a * a - b * 4. * c__, abs(d__1))))
+ / (c__ * 2.);
+ } else {
+ eta = b * 2. / (a + sqrt((d__1 = a * a - b * 4. * c__,
+ abs(d__1))));
+ }
+ } else {
+
+/* Interpolation using THREE most relevant poles */
+
+ dtiim = work[iim1] * delta[iim1];
+ dtiip = work[iip1] * delta[iip1];
+ temp = rhoinv + psi + phi;
+ if (swtch) {
+ c__ = temp - dtiim * dpsi - dtiip * dphi;
+ zz[0] = dtiim * dtiim * dpsi;
+ zz[2] = dtiip * dtiip * dphi;
+ } else {
+ if (orgati) {
+ temp1 = z__[iim1] / dtiim;
+ temp1 *= temp1;
+ temp2 = (d__[iim1] - d__[iip1]) * (d__[iim1] + d__[
+ iip1]) * temp1;
+ c__ = temp - dtiip * (dpsi + dphi) - temp2;
+ zz[0] = z__[iim1] * z__[iim1];
+ if (dpsi < temp1) {
+ zz[2] = dtiip * dtiip * dphi;
+ } else {
+ zz[2] = dtiip * dtiip * (dpsi - temp1 + dphi);
+ }
+ } else {
+ temp1 = z__[iip1] / dtiip;
+ temp1 *= temp1;
+ temp2 = (d__[iip1] - d__[iim1]) * (d__[iim1] + d__[
+ iip1]) * temp1;
+ c__ = temp - dtiim * (dpsi + dphi) - temp2;
+ if (dphi < temp1) {
+ zz[0] = dtiim * dtiim * dpsi;
+ } else {
+ zz[0] = dtiim * dtiim * (dpsi + (dphi - temp1));
+ }
+ zz[2] = z__[iip1] * z__[iip1];
+ }
+ }
+ dd[0] = dtiim;
+ dd[1] = delta[ii] * work[ii];
+ dd[2] = dtiip;
+ dlaed6_(&niter, &orgati, &c__, dd, zz, &w, &eta, info);
+ if (*info != 0) {
+ goto L240;
+ }
+ }
+
+/* Note, eta should be positive if w is negative, and */
+/* eta should be negative otherwise. However, */
+/* if for some reason caused by roundoff, eta*w > 0, */
+/* we simply use one Newton step instead. This way */
+/* will guarantee eta*w < 0. */
+
+ if (w * eta >= 0.) {
+ eta = -w / dw;
+ }
+ if (orgati) {
+ temp1 = work[*i__] * delta[*i__];
+ temp = eta - temp1;
+ } else {
+ temp1 = work[ip1] * delta[ip1];
+ temp = eta - temp1;
+ }
+ if (temp > sg2ub || temp < sg2lb) {
+ if (w < 0.) {
+ eta = (sg2ub - tau) / 2.;
+ } else {
+ eta = (sg2lb - tau) / 2.;
+ }
+ }
+
+ tau += eta;
+ eta /= *sigma + sqrt(*sigma * *sigma + eta);
+
+ *sigma += eta;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[j] += eta;
+ delta[j] -= eta;
+/* L200: */
+ }
+
+ prew = w;
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.;
+ psi = 0.;
+ erretm = 0.;
+ i__1 = iim1;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / (work[j] * delta[j]);
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L210: */
+ }
+ erretm = abs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ dphi = 0.;
+ phi = 0.;
+ i__1 = iip1;
+ for (j = *n; j >= i__1; --j) {
+ temp = z__[j] / (work[j] * delta[j]);
+ phi += z__[j] * temp;
+ dphi += temp * temp;
+ erretm += phi;
+/* L220: */
+ }
+
+ temp = z__[ii] / (work[ii] * delta[ii]);
+ dw = dpsi + dphi + temp * temp;
+ temp = z__[ii] * temp;
+ w = rhoinv + phi + psi + temp;
+ erretm = (phi - psi) * 8. + erretm + rhoinv * 2. + abs(temp) * 3.
+ + abs(tau) * dw;
+ if (w * prew > 0. && abs(w) > abs(prew) / 10.) {
+ swtch = ! swtch;
+ }
+
+ if (w <= 0.) {
+ sg2lb = max(sg2lb,tau);
+ } else {
+ sg2ub = min(sg2ub,tau);
+ }
+
+/* L230: */
+ }
+
+/* Return with INFO = 1, NITER = MAXIT and not converged */
+
+ *info = 1;
+
+ }
+
+L240:
+ return 0;
+
+/* End of DLASD4 */
+
+} /* dlasd4_ */
diff --git a/SRC/dlasd5.c b/SRC/dlasd5.c
new file mode 100644
index 0000000..26fff26
--- /dev/null
+++ b/SRC/dlasd5.c
@@ -0,0 +1,189 @@
+/* dlasd5.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlasd5_(integer *i__, doublereal *d__, doublereal *z__,
+ doublereal *delta, doublereal *rho, doublereal *dsigma, doublereal *
+ work)
+{
+ /* System generated locals */
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal b, c__, w, del, tau, delsq;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This subroutine computes the square root of the I-th eigenvalue */
+/* of a positive symmetric rank-one modification of a 2-by-2 diagonal */
+/* matrix */
+
+/* diag( D ) * diag( D ) + RHO * Z * transpose(Z) . */
+
+/* The diagonal entries in the array D are assumed to satisfy */
+
+/* 0 <= D(i) < D(j) for i < j . */
+
+/* We also assume RHO > 0 and that the Euclidean norm of the vector */
+/* Z is one. */
+
+/* Arguments */
+/* ========= */
+
+/* I (input) INTEGER */
+/* The index of the eigenvalue to be computed. I = 1 or I = 2. */
+
+/* D (input) DOUBLE PRECISION array, dimension ( 2 ) */
+/* The original eigenvalues. We assume 0 <= D(1) < D(2). */
+
+/* Z (input) DOUBLE PRECISION array, dimension ( 2 ) */
+/* The components of the updating vector. */
+
+/* DELTA (output) DOUBLE PRECISION array, dimension ( 2 ) */
+/* Contains (D(j) - sigma_I) in its j-th component. */
+/* The vector DELTA contains the information necessary */
+/* to construct the eigenvectors. */
+
+/* RHO (input) DOUBLE PRECISION */
+/* The scalar in the symmetric updating formula. */
+
+/* DSIGMA (output) DOUBLE PRECISION */
+/* The computed sigma_I, the I-th updated eigenvalue. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension ( 2 ) */
+/* WORK contains (D(j) + sigma_I) in its j-th component. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ren-Cang Li, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --delta;
+ --z__;
+ --d__;
+
+ /* Function Body */
+ del = d__[2] - d__[1];
+ delsq = del * (d__[2] + d__[1]);
+ if (*i__ == 1) {
+ w = *rho * 4. * (z__[2] * z__[2] / (d__[1] + d__[2] * 3.) - z__[1] *
+ z__[1] / (d__[1] * 3. + d__[2])) / del + 1.;
+ if (w > 0.) {
+ b = delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
+ c__ = *rho * z__[1] * z__[1] * delsq;
+
+/* B > ZERO, always */
+
+/* The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 ) */
+
+ tau = c__ * 2. / (b + sqrt((d__1 = b * b - c__ * 4., abs(d__1))));
+
+/* The following TAU is DSIGMA - D( 1 ) */
+
+ tau /= d__[1] + sqrt(d__[1] * d__[1] + tau);
+ *dsigma = d__[1] + tau;
+ delta[1] = -tau;
+ delta[2] = del - tau;
+ work[1] = d__[1] * 2. + tau;
+ work[2] = d__[1] + tau + d__[2];
+/* DELTA( 1 ) = -Z( 1 ) / TAU */
+/* DELTA( 2 ) = Z( 2 ) / ( DEL-TAU ) */
+ } else {
+ b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
+ c__ = *rho * z__[2] * z__[2] * delsq;
+
+/* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) */
+
+ if (b > 0.) {
+ tau = c__ * -2. / (b + sqrt(b * b + c__ * 4.));
+ } else {
+ tau = (b - sqrt(b * b + c__ * 4.)) / 2.;
+ }
+
+/* The following TAU is DSIGMA - D( 2 ) */
+
+ tau /= d__[2] + sqrt((d__1 = d__[2] * d__[2] + tau, abs(d__1)));
+ *dsigma = d__[2] + tau;
+ delta[1] = -(del + tau);
+ delta[2] = -tau;
+ work[1] = d__[1] + tau + d__[2];
+ work[2] = d__[2] * 2. + tau;
+/* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) */
+/* DELTA( 2 ) = -Z( 2 ) / TAU */
+ }
+/* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) */
+/* DELTA( 1 ) = DELTA( 1 ) / TEMP */
+/* DELTA( 2 ) = DELTA( 2 ) / TEMP */
+ } else {
+
+/* Now I=2 */
+
+ b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
+ c__ = *rho * z__[2] * z__[2] * delsq;
+
+/* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) */
+
+ if (b > 0.) {
+ tau = (b + sqrt(b * b + c__ * 4.)) / 2.;
+ } else {
+ tau = c__ * 2. / (-b + sqrt(b * b + c__ * 4.));
+ }
+
+/* The following TAU is DSIGMA - D( 2 ) */
+
+ tau /= d__[2] + sqrt(d__[2] * d__[2] + tau);
+ *dsigma = d__[2] + tau;
+ delta[1] = -(del + tau);
+ delta[2] = -tau;
+ work[1] = d__[1] + tau + d__[2];
+ work[2] = d__[2] * 2. + tau;
+/* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) */
+/* DELTA( 2 ) = -Z( 2 ) / TAU */
+/* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) */
+/* DELTA( 1 ) = DELTA( 1 ) / TEMP */
+/* DELTA( 2 ) = DELTA( 2 ) / TEMP */
+ }
+ return 0;
+
+/* End of DLASD5 */
+
+} /* dlasd5_ */
diff --git a/SRC/dlasd6.c b/SRC/dlasd6.c
new file mode 100644
index 0000000..f1d0ec6
--- /dev/null
+++ b/SRC/dlasd6.c
@@ -0,0 +1,367 @@
+/* dlasd6.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static doublereal c_b7 = 1.;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dlasd6_(integer *icompq, integer *nl, integer *nr,
+ integer *sqre, doublereal *d__, doublereal *vf, doublereal *vl,
+ doublereal *alpha, doublereal *beta, integer *idxq, integer *perm,
+ integer *givptr, integer *givcol, integer *ldgcol, doublereal *givnum,
+ integer *ldgnum, doublereal *poles, doublereal *difl, doublereal *
+ difr, doublereal *z__, integer *k, doublereal *c__, doublereal *s,
+ doublereal *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset,
+ poles_dim1, poles_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer i__, m, n, n1, n2, iw, idx, idxc, idxp, ivfw, ivlw;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dlasd7_(integer *, integer *, integer *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, doublereal
+ *, integer *, doublereal *, doublereal *, integer *), dlasd8_(
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *), dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), dlamrg_(integer *, integer *,
+ doublereal *, integer *, integer *, integer *);
+ integer isigma;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal orgnrm;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASD6 computes the SVD of an updated upper bidiagonal matrix B */
+/* obtained by merging two smaller ones by appending a row. This */
+/* routine is used only for the problem which requires all singular */
+/* values and optionally singular vector matrices in factored form. */
+/* B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE. */
+/* A related subroutine, DLASD1, handles the case in which all singular */
+/* values and singular vectors of the bidiagonal matrix are desired. */
+
+/* DLASD6 computes the SVD as follows: */
+
+/* ( D1(in) 0 0 0 ) */
+/* B = U(in) * ( Z1' a Z2' b ) * VT(in) */
+/* ( 0 0 D2(in) 0 ) */
+
+/* = U(out) * ( D(out) 0) * VT(out) */
+
+/* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M */
+/* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros */
+/* elsewhere; and the entry b is empty if SQRE = 0. */
+
+/* The singular values of B can be computed using D1, D2, the first */
+/* components of all the right singular vectors of the lower block, and */
+/* the last components of all the right singular vectors of the upper */
+/* block. These components are stored and updated in VF and VL, */
+/* respectively, in DLASD6. Hence U and VT are not explicitly */
+/* referenced. */
+
+/* The singular values are stored in D. The algorithm consists of two */
+/* stages: */
+
+/* The first stage consists of deflating the size of the problem */
+/* when there are multiple singular values or if there is a zero */
+/* in the Z vector. For each such occurence the dimension of the */
+/* secular equation problem is reduced by one. This stage is */
+/* performed by the routine DLASD7. */
+
+/* The second stage consists of calculating the updated */
+/* singular values. This is done by finding the roots of the */
+/* secular equation via the routine DLASD4 (as called by DLASD8). */
+/* This routine also updates VF and VL and computes the distances */
+/* between the updated singular values and the old singular */
+/* values. */
+
+/* DLASD6 is called from DLASDA. */
+
+/* Arguments */
+/* ========= */
+
+/* ICOMPQ (input) INTEGER */
+/* Specifies whether singular vectors are to be computed in */
+/* factored form: */
+/* = 0: Compute singular values only. */
+/* = 1: Compute singular vectors in factored form as well. */
+
+/* NL (input) INTEGER */
+/* The row dimension of the upper block. NL >= 1. */
+
+/* NR (input) INTEGER */
+/* The row dimension of the lower block. NR >= 1. */
+
+/* SQRE (input) INTEGER */
+/* = 0: the lower block is an NR-by-NR square matrix. */
+/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */
+
+/* The bidiagonal matrix has row dimension N = NL + NR + 1, */
+/* and column dimension M = N + SQRE. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension ( NL+NR+1 ). */
+/* On entry D(1:NL,1:NL) contains the singular values of the */
+/* upper block, and D(NL+2:N) contains the singular values */
+/* of the lower block. On exit D(1:N) contains the singular */
+/* values of the modified matrix. */
+
+/* VF (input/output) DOUBLE PRECISION array, dimension ( M ) */
+/* On entry, VF(1:NL+1) contains the first components of all */
+/* right singular vectors of the upper block; and VF(NL+2:M) */
+/* contains the first components of all right singular vectors */
+/* of the lower block. On exit, VF contains the first components */
+/* of all right singular vectors of the bidiagonal matrix. */
+
+/* VL (input/output) DOUBLE PRECISION array, dimension ( M ) */
+/* On entry, VL(1:NL+1) contains the last components of all */
+/* right singular vectors of the upper block; and VL(NL+2:M) */
+/* contains the last components of all right singular vectors of */
+/* the lower block. On exit, VL contains the last components of */
+/* all right singular vectors of the bidiagonal matrix. */
+
+/* ALPHA (input/output) DOUBLE PRECISION */
+/* Contains the diagonal element associated with the added row. */
+
+/* BETA (input/output) DOUBLE PRECISION */
+/* Contains the off-diagonal element associated with the added */
+/* row. */
+
+/* IDXQ (output) INTEGER array, dimension ( N ) */
+/* This contains the permutation which will reintegrate the */
+/* subproblem just solved back into sorted order, i.e. */
+/* D( IDXQ( I = 1, N ) ) will be in ascending order. */
+
+/* PERM (output) INTEGER array, dimension ( N ) */
+/* The permutations (from deflation and sorting) to be applied */
+/* to each block. Not referenced if ICOMPQ = 0. */
+
+/* GIVPTR (output) INTEGER */
+/* The number of Givens rotations which took place in this */
+/* subproblem. Not referenced if ICOMPQ = 0. */
+
+/* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 ) */
+/* Each pair of numbers indicates a pair of columns to take place */
+/* in a Givens rotation. Not referenced if ICOMPQ = 0. */
+
+/* LDGCOL (input) INTEGER */
+/* leading dimension of GIVCOL, must be at least N. */
+
+/* GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */
+/* Each number indicates the C or S value to be used in the */
+/* corresponding Givens rotation. Not referenced if ICOMPQ = 0. */
+
+/* LDGNUM (input) INTEGER */
+/* The leading dimension of GIVNUM and POLES, must be at least N. */
+
+/* POLES (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */
+/* On exit, POLES(1,*) is an array containing the new singular */
+/* values obtained from solving the secular equation, and */
+/* POLES(2,*) is an array containing the poles in the secular */
+/* equation. Not referenced if ICOMPQ = 0. */
+
+/* DIFL (output) DOUBLE PRECISION array, dimension ( N ) */
+/* On exit, DIFL(I) is the distance between I-th updated */
+/* (undeflated) singular value and the I-th (undeflated) old */
+/* singular value. */
+
+/* DIFR (output) DOUBLE PRECISION array, */
+/* dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and */
+/* dimension ( N ) if ICOMPQ = 0. */
+/* On exit, DIFR(I, 1) is the distance between I-th updated */
+/* (undeflated) singular value and the I+1-th (undeflated) old */
+/* singular value. */
+
+/* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the */
+/* normalizing factors for the right singular vector matrix. */
+
+/* See DLASD8 for details on DIFL and DIFR. */
+
+/* Z (output) DOUBLE PRECISION array, dimension ( M ) */
+/* The first elements of this array contain the components */
+/* of the deflation-adjusted updating row vector. */
+
+/* K (output) INTEGER */
+/* Contains the dimension of the non-deflated matrix, */
+/* This is the order of the related secular equation. 1 <= K <=N. */
+
+/* C (output) DOUBLE PRECISION */
+/* C contains garbage if SQRE =0 and the C-value of a Givens */
+/* rotation related to the right null space if SQRE = 1. */
+
+/* S (output) DOUBLE PRECISION */
+/* S contains garbage if SQRE =0 and the S-value of a Givens */
+/* rotation related to the right null space if SQRE = 1. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension ( 4 * M ) */
+
+/* IWORK (workspace) INTEGER array, dimension ( 3 * N ) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, an singular value did not converge */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --vf;
+ --vl;
+ --idxq;
+ --perm;
+ givcol_dim1 = *ldgcol;
+ givcol_offset = 1 + givcol_dim1;
+ givcol -= givcol_offset;
+ poles_dim1 = *ldgnum;
+ poles_offset = 1 + poles_dim1;
+ poles -= poles_offset;
+ givnum_dim1 = *ldgnum;
+ givnum_offset = 1 + givnum_dim1;
+ givnum -= givnum_offset;
+ --difl;
+ --difr;
+ --z__;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ n = *nl + *nr + 1;
+ m = n + *sqre;
+
+ if (*icompq < 0 || *icompq > 1) {
+ *info = -1;
+ } else if (*nl < 1) {
+ *info = -2;
+ } else if (*nr < 1) {
+ *info = -3;
+ } else if (*sqre < 0 || *sqre > 1) {
+ *info = -4;
+ } else if (*ldgcol < n) {
+ *info = -14;
+ } else if (*ldgnum < n) {
+ *info = -16;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLASD6", &i__1);
+ return 0;
+ }
+
+/* The following values are for bookkeeping purposes only. They are */
+/* integer pointers which indicate the portion of the workspace */
+/* used by a particular array in DLASD7 and DLASD8. */
+
+ isigma = 1;
+ iw = isigma + n;
+ ivfw = iw + m;
+ ivlw = ivfw + m;
+
+ idx = 1;
+ idxc = idx + n;
+ idxp = idxc + n;
+
+/* Scale. */
+
+/* Computing MAX */
+ d__1 = abs(*alpha), d__2 = abs(*beta);
+ orgnrm = max(d__1,d__2);
+ d__[*nl + 1] = 0.;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((d__1 = d__[i__], abs(d__1)) > orgnrm) {
+ orgnrm = (d__1 = d__[i__], abs(d__1));
+ }
+/* L10: */
+ }
+ dlascl_("G", &c__0, &c__0, &orgnrm, &c_b7, &n, &c__1, &d__[1], &n, info);
+ *alpha /= orgnrm;
+ *beta /= orgnrm;
+
+/* Sort and Deflate singular values. */
+
+ dlasd7_(icompq, nl, nr, sqre, k, &d__[1], &z__[1], &work[iw], &vf[1], &
+ work[ivfw], &vl[1], &work[ivlw], alpha, beta, &work[isigma], &
+ iwork[idx], &iwork[idxp], &idxq[1], &perm[1], givptr, &givcol[
+ givcol_offset], ldgcol, &givnum[givnum_offset], ldgnum, c__, s,
+ info);
+
+/* Solve Secular Equation, compute DIFL, DIFR, and update VF, VL. */
+
+ dlasd8_(icompq, k, &d__[1], &z__[1], &vf[1], &vl[1], &difl[1], &difr[1],
+ ldgnum, &work[isigma], &work[iw], info);
+
+/* Save the poles if ICOMPQ = 1. */
+
+ if (*icompq == 1) {
+ dcopy_(k, &d__[1], &c__1, &poles[poles_dim1 + 1], &c__1);
+ dcopy_(k, &work[isigma], &c__1, &poles[(poles_dim1 << 1) + 1], &c__1);
+ }
+
+/* Unscale. */
+
+ dlascl_("G", &c__0, &c__0, &c_b7, &orgnrm, &n, &c__1, &d__[1], &n, info);
+
+/* Prepare the IDXQ sorting permutation. */
+
+ n1 = *k;
+ n2 = n - *k;
+ dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &idxq[1]);
+
+ return 0;
+
+/* End of DLASD6 */
+
+} /* dlasd6_ */
diff --git a/SRC/dlasd7.c b/SRC/dlasd7.c
new file mode 100644
index 0000000..ea4ca05
--- /dev/null
+++ b/SRC/dlasd7.c
@@ -0,0 +1,518 @@
+/* dlasd7.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dlasd7_(integer *icompq, integer *nl, integer *nr,
+ integer *sqre, integer *k, doublereal *d__, doublereal *z__,
+ doublereal *zw, doublereal *vf, doublereal *vfw, doublereal *vl,
+ doublereal *vlw, doublereal *alpha, doublereal *beta, doublereal *
+ dsigma, integer *idx, integer *idxp, integer *idxq, integer *perm,
+ integer *givptr, integer *givcol, integer *ldgcol, doublereal *givnum,
+ integer *ldgnum, doublereal *c__, doublereal *s, integer *info)
+{
+ /* System generated locals */
+ integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer i__, j, m, n, k2;
+ doublereal z1;
+ integer jp;
+ doublereal eps, tau, tol;
+ integer nlp1, nlp2, idxi, idxj;
+ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ integer idxjp;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer jprev;
+ extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
+ extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *,
+ integer *, integer *, integer *), xerbla_(char *, integer *);
+ doublereal hlftol;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASD7 merges the two sets of singular values together into a single */
+/* sorted set. Then it tries to deflate the size of the problem. There */
+/* are two ways in which deflation can occur: when two or more singular */
+/* values are close together or if there is a tiny entry in the Z */
+/* vector. For each such occurrence the order of the related */
+/* secular equation problem is reduced by one. */
+
+/* DLASD7 is called from DLASD6. */
+
+/* Arguments */
+/* ========= */
+
+/* ICOMPQ (input) INTEGER */
+/* Specifies whether singular vectors are to be computed */
+/* in compact form, as follows: */
+/* = 0: Compute singular values only. */
+/* = 1: Compute singular vectors of upper */
+/* bidiagonal matrix in compact form. */
+
+/* NL (input) INTEGER */
+/* The row dimension of the upper block. NL >= 1. */
+
+/* NR (input) INTEGER */
+/* The row dimension of the lower block. NR >= 1. */
+
+/* SQRE (input) INTEGER */
+/* = 0: the lower block is an NR-by-NR square matrix. */
+/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */
+
+/* The bidiagonal matrix has */
+/* N = NL + NR + 1 rows and */
+/* M = N + SQRE >= N columns. */
+
+/* K (output) INTEGER */
+/* Contains the dimension of the non-deflated matrix, this is */
+/* the order of the related secular equation. 1 <= K <=N. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension ( N ) */
+/* On entry D contains the singular values of the two submatrices */
+/* to be combined. On exit D contains the trailing (N-K) updated */
+/* singular values (those which were deflated) sorted into */
+/* increasing order. */
+
+/* Z (output) DOUBLE PRECISION array, dimension ( M ) */
+/* On exit Z contains the updating row vector in the secular */
+/* equation. */
+
+/* ZW (workspace) DOUBLE PRECISION array, dimension ( M ) */
+/* Workspace for Z. */
+
+/* VF (input/output) DOUBLE PRECISION array, dimension ( M ) */
+/* On entry, VF(1:NL+1) contains the first components of all */
+/* right singular vectors of the upper block; and VF(NL+2:M) */
+/* contains the first components of all right singular vectors */
+/* of the lower block. On exit, VF contains the first components */
+/* of all right singular vectors of the bidiagonal matrix. */
+
+/* VFW (workspace) DOUBLE PRECISION array, dimension ( M ) */
+/* Workspace for VF. */
+
+/* VL (input/output) DOUBLE PRECISION array, dimension ( M ) */
+/* On entry, VL(1:NL+1) contains the last components of all */
+/* right singular vectors of the upper block; and VL(NL+2:M) */
+/* contains the last components of all right singular vectors */
+/* of the lower block. On exit, VL contains the last components */
+/* of all right singular vectors of the bidiagonal matrix. */
+
+/* VLW (workspace) DOUBLE PRECISION array, dimension ( M ) */
+/* Workspace for VL. */
+
+/* ALPHA (input) DOUBLE PRECISION */
+/* Contains the diagonal element associated with the added row. */
+
+/* BETA (input) DOUBLE PRECISION */
+/* Contains the off-diagonal element associated with the added */
+/* row. */
+
+/* DSIGMA (output) DOUBLE PRECISION array, dimension ( N ) */
+/* Contains a copy of the diagonal elements (K-1 singular values */
+/* and one zero) in the secular equation. */
+
+/* IDX (workspace) INTEGER array, dimension ( N ) */
+/* This will contain the permutation used to sort the contents of */
+/* D into ascending order. */
+
+/* IDXP (workspace) INTEGER array, dimension ( N ) */
+/* This will contain the permutation used to place deflated */
+/* values of D at the end of the array. On output IDXP(2:K) */
+/* points to the nondeflated D-values and IDXP(K+1:N) */
+/* points to the deflated singular values. */
+
+/* IDXQ (input) INTEGER array, dimension ( N ) */
+/* This contains the permutation which separately sorts the two */
+/* sub-problems in D into ascending order. Note that entries in */
+/* the first half of this permutation must first be moved one */
+/* position backward; and entries in the second half */
+/* must first have NL+1 added to their values. */
+
+/* PERM (output) INTEGER array, dimension ( N ) */
+/* The permutations (from deflation and sorting) to be applied */
+/* to each singular block. Not referenced if ICOMPQ = 0. */
+
+/* GIVPTR (output) INTEGER */
+/* The number of Givens rotations which took place in this */
+/* subproblem. Not referenced if ICOMPQ = 0. */
+
+/* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 ) */
+/* Each pair of numbers indicates a pair of columns to take place */
+/* in a Givens rotation. Not referenced if ICOMPQ = 0. */
+
+/* LDGCOL (input) INTEGER */
+/* The leading dimension of GIVCOL, must be at least N. */
+
+/* GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */
+/* Each number indicates the C or S value to be used in the */
+/* corresponding Givens rotation. Not referenced if ICOMPQ = 0. */
+
+/* LDGNUM (input) INTEGER */
+/* The leading dimension of GIVNUM, must be at least N. */
+
+/* C (output) DOUBLE PRECISION */
+/* C contains garbage if SQRE =0 and the C-value of a Givens */
+/* rotation related to the right null space if SQRE = 1. */
+
+/* S (output) DOUBLE PRECISION */
+/* S contains garbage if SQRE =0 and the S-value of a Givens */
+/* rotation related to the right null space if SQRE = 1. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --z__;
+ --zw;
+ --vf;
+ --vfw;
+ --vl;
+ --vlw;
+ --dsigma;
+ --idx;
+ --idxp;
+ --idxq;
+ --perm;
+ givcol_dim1 = *ldgcol;
+ givcol_offset = 1 + givcol_dim1;
+ givcol -= givcol_offset;
+ givnum_dim1 = *ldgnum;
+ givnum_offset = 1 + givnum_dim1;
+ givnum -= givnum_offset;
+
+ /* Function Body */
+ *info = 0;
+ n = *nl + *nr + 1;
+ m = n + *sqre;
+
+ if (*icompq < 0 || *icompq > 1) {
+ *info = -1;
+ } else if (*nl < 1) {
+ *info = -2;
+ } else if (*nr < 1) {
+ *info = -3;
+ } else if (*sqre < 0 || *sqre > 1) {
+ *info = -4;
+ } else if (*ldgcol < n) {
+ *info = -22;
+ } else if (*ldgnum < n) {
+ *info = -24;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLASD7", &i__1);
+ return 0;
+ }
+
+ nlp1 = *nl + 1;
+ nlp2 = *nl + 2;
+ if (*icompq == 1) {
+ *givptr = 0;
+ }
+
+/* Generate the first part of the vector Z and move the singular */
+/* values in the first part of D one position backward. */
+
+ z1 = *alpha * vl[nlp1];
+ vl[nlp1] = 0.;
+ tau = vf[nlp1];
+ for (i__ = *nl; i__ >= 1; --i__) {
+ z__[i__ + 1] = *alpha * vl[i__];
+ vl[i__] = 0.;
+ vf[i__ + 1] = vf[i__];
+ d__[i__ + 1] = d__[i__];
+ idxq[i__ + 1] = idxq[i__] + 1;
+/* L10: */
+ }
+ vf[1] = tau;
+
+/* Generate the second part of the vector Z. */
+
+ i__1 = m;
+ for (i__ = nlp2; i__ <= i__1; ++i__) {
+ z__[i__] = *beta * vf[i__];
+ vf[i__] = 0.;
+/* L20: */
+ }
+
+/* Sort the singular values into increasing order */
+
+ i__1 = n;
+ for (i__ = nlp2; i__ <= i__1; ++i__) {
+ idxq[i__] += nlp1;
+/* L30: */
+ }
+
+/* DSIGMA, IDXC, IDXC, and ZW are used as storage space. */
+
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ dsigma[i__] = d__[idxq[i__]];
+ zw[i__] = z__[idxq[i__]];
+ vfw[i__] = vf[idxq[i__]];
+ vlw[i__] = vl[idxq[i__]];
+/* L40: */
+ }
+
+ dlamrg_(nl, nr, &dsigma[2], &c__1, &c__1, &idx[2]);
+
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ idxi = idx[i__] + 1;
+ d__[i__] = dsigma[idxi];
+ z__[i__] = zw[idxi];
+ vf[i__] = vfw[idxi];
+ vl[i__] = vlw[idxi];
+/* L50: */
+ }
+
+/* Calculate the allowable deflation tolerence */
+
+ eps = dlamch_("Epsilon");
+/* Computing MAX */
+ d__1 = abs(*alpha), d__2 = abs(*beta);
+ tol = max(d__1,d__2);
+/* Computing MAX */
+ d__2 = (d__1 = d__[n], abs(d__1));
+ tol = eps * 64. * max(d__2,tol);
+
+/* There are 2 kinds of deflation -- first a value in the z-vector */
+/* is small, second two (or more) singular values are very close */
+/* together (their difference is small). */
+
+/* If the value in the z-vector is small, we simply permute the */
+/* array so that the corresponding singular value is moved to the */
+/* end. */
+
+/* If two values in the D-vector are close, we perform a two-sided */
+/* rotation designed to make one of the corresponding z-vector */
+/* entries zero, and then permute the array so that the deflated */
+/* singular value is moved to the end. */
+
+/* If there are multiple singular values then the problem deflates. */
+/* Here the number of equal singular values are found. As each equal */
+/* singular value is found, an elementary reflector is computed to */
+/* rotate the corresponding singular subspace so that the */
+/* corresponding components of Z are zero in this new basis. */
+
+ *k = 1;
+ k2 = n + 1;
+ i__1 = n;
+ for (j = 2; j <= i__1; ++j) {
+ if ((d__1 = z__[j], abs(d__1)) <= tol) {
+
+/* Deflate due to small z component. */
+
+ --k2;
+ idxp[k2] = j;
+ if (j == n) {
+ goto L100;
+ }
+ } else {
+ jprev = j;
+ goto L70;
+ }
+/* L60: */
+ }
+L70:
+ j = jprev;
+L80:
+ ++j;
+ if (j > n) {
+ goto L90;
+ }
+ if ((d__1 = z__[j], abs(d__1)) <= tol) {
+
+/* Deflate due to small z component. */
+
+ --k2;
+ idxp[k2] = j;
+ } else {
+
+/* Check if singular values are close enough to allow deflation. */
+
+ if ((d__1 = d__[j] - d__[jprev], abs(d__1)) <= tol) {
+
+/* Deflation is possible. */
+
+ *s = z__[jprev];
+ *c__ = z__[j];
+
+/* Find sqrt(a**2+b**2) without overflow or */
+/* destructive underflow. */
+
+ tau = dlapy2_(c__, s);
+ z__[j] = tau;
+ z__[jprev] = 0.;
+ *c__ /= tau;
+ *s = -(*s) / tau;
+
+/* Record the appropriate Givens rotation */
+
+ if (*icompq == 1) {
+ ++(*givptr);
+ idxjp = idxq[idx[jprev] + 1];
+ idxj = idxq[idx[j] + 1];
+ if (idxjp <= nlp1) {
+ --idxjp;
+ }
+ if (idxj <= nlp1) {
+ --idxj;
+ }
+ givcol[*givptr + (givcol_dim1 << 1)] = idxjp;
+ givcol[*givptr + givcol_dim1] = idxj;
+ givnum[*givptr + (givnum_dim1 << 1)] = *c__;
+ givnum[*givptr + givnum_dim1] = *s;
+ }
+ drot_(&c__1, &vf[jprev], &c__1, &vf[j], &c__1, c__, s);
+ drot_(&c__1, &vl[jprev], &c__1, &vl[j], &c__1, c__, s);
+ --k2;
+ idxp[k2] = jprev;
+ jprev = j;
+ } else {
+ ++(*k);
+ zw[*k] = z__[jprev];
+ dsigma[*k] = d__[jprev];
+ idxp[*k] = jprev;
+ jprev = j;
+ }
+ }
+ goto L80;
+L90:
+
+/* Record the last singular value. */
+
+ ++(*k);
+ zw[*k] = z__[jprev];
+ dsigma[*k] = d__[jprev];
+ idxp[*k] = jprev;
+
+L100:
+
+/* Sort the singular values into DSIGMA. The singular values which */
+/* were not deflated go into the first K slots of DSIGMA, except */
+/* that DSIGMA(1) is treated separately. */
+
+ i__1 = n;
+ for (j = 2; j <= i__1; ++j) {
+ jp = idxp[j];
+ dsigma[j] = d__[jp];
+ vfw[j] = vf[jp];
+ vlw[j] = vl[jp];
+/* L110: */
+ }
+ if (*icompq == 1) {
+ i__1 = n;
+ for (j = 2; j <= i__1; ++j) {
+ jp = idxp[j];
+ perm[j] = idxq[idx[jp] + 1];
+ if (perm[j] <= nlp1) {
+ --perm[j];
+ }
+/* L120: */
+ }
+ }
+
+/* The deflated singular values go back into the last N - K slots of */
+/* D. */
+
+ i__1 = n - *k;
+ dcopy_(&i__1, &dsigma[*k + 1], &c__1, &d__[*k + 1], &c__1);
+
+/* Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and */
+/* VL(M). */
+
+ dsigma[1] = 0.;
+ hlftol = tol / 2.;
+ if (abs(dsigma[2]) <= hlftol) {
+ dsigma[2] = hlftol;
+ }
+ if (m > n) {
+ z__[1] = dlapy2_(&z1, &z__[m]);
+ if (z__[1] <= tol) {
+ *c__ = 1.;
+ *s = 0.;
+ z__[1] = tol;
+ } else {
+ *c__ = z1 / z__[1];
+ *s = -z__[m] / z__[1];
+ }
+ drot_(&c__1, &vf[m], &c__1, &vf[1], &c__1, c__, s);
+ drot_(&c__1, &vl[m], &c__1, &vl[1], &c__1, c__, s);
+ } else {
+ if (abs(z1) <= tol) {
+ z__[1] = tol;
+ } else {
+ z__[1] = z1;
+ }
+ }
+
+/* Restore Z, VF, and VL. */
+
+ i__1 = *k - 1;
+ dcopy_(&i__1, &zw[2], &c__1, &z__[2], &c__1);
+ i__1 = n - 1;
+ dcopy_(&i__1, &vfw[2], &c__1, &vf[2], &c__1);
+ i__1 = n - 1;
+ dcopy_(&i__1, &vlw[2], &c__1, &vl[2], &c__1);
+
+ return 0;
+
+/* End of DLASD7 */
+
+} /* dlasd7_ */
diff --git a/SRC/dlasd8.c b/SRC/dlasd8.c
new file mode 100644
index 0000000..ab1b6c2
--- /dev/null
+++ b/SRC/dlasd8.c
@@ -0,0 +1,326 @@
+/* dlasd8.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static doublereal c_b8 = 1.;
+
+/* Subroutine */ int dlasd8_(integer *icompq, integer *k, doublereal *d__,
+ doublereal *z__, doublereal *vf, doublereal *vl, doublereal *difl,
+ doublereal *difr, integer *lddifr, doublereal *dsigma, doublereal *
+ work, integer *info)
+{
+ /* System generated locals */
+ integer difr_dim1, difr_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal dj, rho;
+ integer iwk1, iwk2, iwk3;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal temp;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ integer iwk2i, iwk3i;
+ doublereal diflj, difrj, dsigj;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ extern doublereal dlamc3_(doublereal *, doublereal *);
+ extern /* Subroutine */ int dlasd4_(integer *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *), dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), dlaset_(char *, integer *, integer
+ *, doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ doublereal dsigjp;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* October 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASD8 finds the square roots of the roots of the secular equation, */
+/* as defined by the values in DSIGMA and Z. It makes the appropriate */
+/* calls to DLASD4, and stores, for each element in D, the distance */
+/* to its two nearest poles (elements in DSIGMA). It also updates */
+/* the arrays VF and VL, the first and last components of all the */
+/* right singular vectors of the original bidiagonal matrix. */
+
+/* DLASD8 is called from DLASD6. */
+
+/* Arguments */
+/* ========= */
+
+/* ICOMPQ (input) INTEGER */
+/* Specifies whether singular vectors are to be computed in */
+/* factored form in the calling routine: */
+/* = 0: Compute singular values only. */
+/* = 1: Compute singular vectors in factored form as well. */
+
+/* K (input) INTEGER */
+/* The number of terms in the rational function to be solved */
+/* by DLASD4. K >= 1. */
+
+/* D (output) DOUBLE PRECISION array, dimension ( K ) */
+/* On output, D contains the updated singular values. */
+
+/* Z (input/output) DOUBLE PRECISION array, dimension ( K ) */
+/* On entry, the first K elements of this array contain the */
+/* components of the deflation-adjusted updating row vector. */
+/* On exit, Z is updated. */
+
+/* VF (input/output) DOUBLE PRECISION array, dimension ( K ) */
+/* On entry, VF contains information passed through DBEDE8. */
+/* On exit, VF contains the first K components of the first */
+/* components of all right singular vectors of the bidiagonal */
+/* matrix. */
+
+/* VL (input/output) DOUBLE PRECISION array, dimension ( K ) */
+/* On entry, VL contains information passed through DBEDE8. */
+/* On exit, VL contains the first K components of the last */
+/* components of all right singular vectors of the bidiagonal */
+/* matrix. */
+
+/* DIFL (output) DOUBLE PRECISION array, dimension ( K ) */
+/* On exit, DIFL(I) = D(I) - DSIGMA(I). */
+
+/* DIFR (output) DOUBLE PRECISION array, */
+/* dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and */
+/* dimension ( K ) if ICOMPQ = 0. */
+/* On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not */
+/* defined and will not be referenced. */
+
+/* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the */
+/* normalizing factors for the right singular vector matrix. */
+
+/* LDDIFR (input) INTEGER */
+/* The leading dimension of DIFR, must be at least K. */
+
+/* DSIGMA (input/output) DOUBLE PRECISION array, dimension ( K ) */
+/* On entry, the first K elements of this array contain the old */
+/* roots of the deflated updating problem. These are the poles */
+/* of the secular equation. */
+/* On exit, the elements of DSIGMA may be very slightly altered */
+/* in value. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension at least 3 * K */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, an singular value did not converge */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --z__;
+ --vf;
+ --vl;
+ --difl;
+ difr_dim1 = *lddifr;
+ difr_offset = 1 + difr_dim1;
+ difr -= difr_offset;
+ --dsigma;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*icompq < 0 || *icompq > 1) {
+ *info = -1;
+ } else if (*k < 1) {
+ *info = -2;
+ } else if (*lddifr < *k) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLASD8", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*k == 1) {
+ d__[1] = abs(z__[1]);
+ difl[1] = d__[1];
+ if (*icompq == 1) {
+ difl[2] = 1.;
+ difr[(difr_dim1 << 1) + 1] = 1.;
+ }
+ return 0;
+ }
+
+/* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can */
+/* be computed with high relative accuracy (barring over/underflow). */
+/* This is a problem on machines without a guard digit in */
+/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */
+/* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), */
+/* which on any of these machines zeros out the bottommost */
+/* bit of DSIGMA(I) if it is 1; this makes the subsequent */
+/* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation */
+/* occurs. On binary machines with a guard digit (almost all */
+/* machines) it does not change DSIGMA(I) at all. On hexadecimal */
+/* and decimal machines with a guard digit, it slightly */
+/* changes the bottommost bits of DSIGMA(I). It does not account */
+/* for hexadecimal or decimal machines without guard digits */
+/* (we know of none). We use a subroutine call to compute */
+/* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating */
+/* this code. */
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dsigma[i__] = dlamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__];
+/* L10: */
+ }
+
+/* Book keeping. */
+
+ iwk1 = 1;
+ iwk2 = iwk1 + *k;
+ iwk3 = iwk2 + *k;
+ iwk2i = iwk2 - 1;
+ iwk3i = iwk3 - 1;
+
+/* Normalize Z. */
+
+ rho = dnrm2_(k, &z__[1], &c__1);
+ dlascl_("G", &c__0, &c__0, &rho, &c_b8, k, &c__1, &z__[1], k, info);
+ rho *= rho;
+
+/* Initialize WORK(IWK3). */
+
+ dlaset_("A", k, &c__1, &c_b8, &c_b8, &work[iwk3], k);
+
+/* Compute the updated singular values, the arrays DIFL, DIFR, */
+/* and the updated Z. */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ dlasd4_(k, &j, &dsigma[1], &z__[1], &work[iwk1], &rho, &d__[j], &work[
+ iwk2], info);
+
+/* If the root finder fails, the computation is terminated. */
+
+ if (*info != 0) {
+ return 0;
+ }
+ work[iwk3i + j] = work[iwk3i + j] * work[j] * work[iwk2i + j];
+ difl[j] = -work[j];
+ difr[j + difr_dim1] = -work[j + 1];
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i +
+ i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[
+ j]);
+/* L20: */
+ }
+ i__2 = *k;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i +
+ i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[
+ j]);
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Compute updated Z. */
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__2 = sqrt((d__1 = work[iwk3i + i__], abs(d__1)));
+ z__[i__] = d_sign(&d__2, &z__[i__]);
+/* L50: */
+ }
+
+/* Update VF and VL. */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ diflj = difl[j];
+ dj = d__[j];
+ dsigj = -dsigma[j];
+ if (j < *k) {
+ difrj = -difr[j + difr_dim1];
+ dsigjp = -dsigma[j + 1];
+ }
+ work[j] = -z__[j] / diflj / (dsigma[j] + dj);
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigj) - diflj) / (
+ dsigma[i__] + dj);
+/* L60: */
+ }
+ i__2 = *k;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ work[i__] = z__[i__] / (dlamc3_(&dsigma[i__], &dsigjp) + difrj) /
+ (dsigma[i__] + dj);
+/* L70: */
+ }
+ temp = dnrm2_(k, &work[1], &c__1);
+ work[iwk2i + j] = ddot_(k, &work[1], &c__1, &vf[1], &c__1) / temp;
+ work[iwk3i + j] = ddot_(k, &work[1], &c__1, &vl[1], &c__1) / temp;
+ if (*icompq == 1) {
+ difr[j + (difr_dim1 << 1)] = temp;
+ }
+/* L80: */
+ }
+
+ dcopy_(k, &work[iwk2], &c__1, &vf[1], &c__1);
+ dcopy_(k, &work[iwk3], &c__1, &vl[1], &c__1);
+
+ return 0;
+
+/* End of DLASD8 */
+
+} /* dlasd8_ */
diff --git a/SRC/dlasda.c b/SRC/dlasda.c
new file mode 100644
index 0000000..4a501d1
--- /dev/null
+++ b/SRC/dlasda.c
@@ -0,0 +1,488 @@
+/* dlasda.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static doublereal c_b11 = 0.;
+static doublereal c_b12 = 1.;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int dlasda_(integer *icompq, integer *smlsiz, integer *n,
+ integer *sqre, doublereal *d__, doublereal *e, doublereal *u, integer
+ *ldu, doublereal *vt, integer *k, doublereal *difl, doublereal *difr,
+ doublereal *z__, doublereal *poles, integer *givptr, integer *givcol,
+ integer *ldgcol, integer *perm, doublereal *givnum, doublereal *c__,
+ doublereal *s, doublereal *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, difl_dim1,
+ difl_offset, difr_dim1, difr_offset, givnum_dim1, givnum_offset,
+ poles_dim1, poles_offset, u_dim1, u_offset, vt_dim1, vt_offset,
+ z_dim1, z_offset, i__1, i__2;
+
+ /* Builtin functions */
+ integer pow_ii(integer *, integer *);
+
+ /* Local variables */
+ integer i__, j, m, i1, ic, lf, nd, ll, nl, vf, nr, vl, im1, ncc, nlf, nrf,
+ vfi, iwk, vli, lvl, nru, ndb1, nlp1, lvl2, nrp1;
+ doublereal beta;
+ integer idxq, nlvl;
+ doublereal alpha;
+ integer inode, ndiml, ndimr, idxqi, itemp;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer sqrei;
+ extern /* Subroutine */ int dlasd6_(integer *, integer *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *);
+ integer nwork1, nwork2;
+ extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer
+ *, integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *), dlasdt_(integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *), dlaset_(
+ char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), xerbla_(char *, integer *);
+ integer smlszp;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Using a divide and conquer approach, DLASDA computes the singular */
+/* value decomposition (SVD) of a real upper bidiagonal N-by-M matrix */
+/* B with diagonal D and offdiagonal E, where M = N + SQRE. The */
+/* algorithm computes the singular values in the SVD B = U * S * VT. */
+/* The orthogonal matrices U and VT are optionally computed in */
+/* compact form. */
+
+/* A related subroutine, DLASD0, computes the singular values and */
+/* the singular vectors in explicit form. */
+
+/* Arguments */
+/* ========= */
+
+/* ICOMPQ (input) INTEGER */
+/* Specifies whether singular vectors are to be computed */
+/* in compact form, as follows */
+/* = 0: Compute singular values only. */
+/* = 1: Compute singular vectors of upper bidiagonal */
+/* matrix in compact form. */
+
+/* SMLSIZ (input) INTEGER */
+/* The maximum size of the subproblems at the bottom of the */
+/* computation tree. */
+
+/* N (input) INTEGER */
+/* The row dimension of the upper bidiagonal matrix. This is */
+/* also the dimension of the main diagonal array D. */
+
+/* SQRE (input) INTEGER */
+/* Specifies the column dimension of the bidiagonal matrix. */
+/* = 0: The bidiagonal matrix has column dimension M = N; */
+/* = 1: The bidiagonal matrix has column dimension M = N + 1. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension ( N ) */
+/* On entry D contains the main diagonal of the bidiagonal */
+/* matrix. On exit D, if INFO = 0, contains its singular values. */
+
+/* E (input) DOUBLE PRECISION array, dimension ( M-1 ) */
+/* Contains the subdiagonal entries of the bidiagonal matrix. */
+/* On exit, E has been destroyed. */
+
+/* U (output) DOUBLE PRECISION array, */
+/* dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced */
+/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left */
+/* singular vector matrices of all subproblems at the bottom */
+/* level. */
+
+/* LDU (input) INTEGER, LDU = > N. */
+/* The leading dimension of arrays U, VT, DIFL, DIFR, POLES, */
+/* GIVNUM, and Z. */
+
+/* VT (output) DOUBLE PRECISION array, */
+/* dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced */
+/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right */
+/* singular vector matrices of all subproblems at the bottom */
+/* level. */
+
+/* K (output) INTEGER array, */
+/* dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0. */
+/* If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th */
+/* secular equation on the computation tree. */
+
+/* DIFL (output) DOUBLE PRECISION array, dimension ( LDU, NLVL ), */
+/* where NLVL = floor(log_2 (N/SMLSIZ))). */
+
+/* DIFR (output) DOUBLE PRECISION array, */
+/* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and */
+/* dimension ( N ) if ICOMPQ = 0. */
+/* If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1) */
+/* record distances between singular values on the I-th */
+/* level and singular values on the (I -1)-th level, and */
+/* DIFR(1:N, 2 * I ) contains the normalizing factors for */
+/* the right singular vector matrix. See DLASD8 for details. */
+
+/* Z (output) DOUBLE PRECISION array, */
+/* dimension ( LDU, NLVL ) if ICOMPQ = 1 and */
+/* dimension ( N ) if ICOMPQ = 0. */
+/* The first K elements of Z(1, I) contain the components of */
+/* the deflation-adjusted updating row vector for subproblems */
+/* on the I-th level. */
+
+/* POLES (output) DOUBLE PRECISION array, */
+/* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced */
+/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and */
+/* POLES(1, 2*I) contain the new and old singular values */
+/* involved in the secular equations on the I-th level. */
+
+/* GIVPTR (output) INTEGER array, */
+/* dimension ( N ) if ICOMPQ = 1, and not referenced if */
+/* ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records */
+/* the number of Givens rotations performed on the I-th */
+/* problem on the computation tree. */
+
+/* GIVCOL (output) INTEGER array, */
+/* dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not */
+/* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, */
+/* GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations */
+/* of Givens rotations performed on the I-th level on the */
+/* computation tree. */
+
+/* LDGCOL (input) INTEGER, LDGCOL = > N. */
+/* The leading dimension of arrays GIVCOL and PERM. */
+
+/* PERM (output) INTEGER array, */
+/* dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced */
+/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records */
+/* permutations done on the I-th level of the computation tree. */
+
+/* GIVNUM (output) DOUBLE PRECISION array, */
+/* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not */
+/* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, */
+/* GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S- */
+/* values of Givens rotations performed on the I-th level on */
+/* the computation tree. */
+
+/* C (output) DOUBLE PRECISION array, */
+/* dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. */
+/* If ICOMPQ = 1 and the I-th subproblem is not square, on exit, */
+/* C( I ) contains the C-value of a Givens rotation related to */
+/* the right null space of the I-th subproblem. */
+
+/* S (output) DOUBLE PRECISION array, dimension ( N ) if */
+/* ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1 */
+/* and the I-th subproblem is not square, on exit, S( I ) */
+/* contains the S-value of a Givens rotation related to */
+/* the right null space of the I-th subproblem. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)). */
+
+/* IWORK (workspace) INTEGER array. */
+/* Dimension must be at least (7 * N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, an singular value did not converge */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ givnum_dim1 = *ldu;
+ givnum_offset = 1 + givnum_dim1;
+ givnum -= givnum_offset;
+ poles_dim1 = *ldu;
+ poles_offset = 1 + poles_dim1;
+ poles -= poles_offset;
+ z_dim1 = *ldu;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ difr_dim1 = *ldu;
+ difr_offset = 1 + difr_dim1;
+ difr -= difr_offset;
+ difl_dim1 = *ldu;
+ difl_offset = 1 + difl_dim1;
+ difl -= difl_offset;
+ vt_dim1 = *ldu;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --k;
+ --givptr;
+ perm_dim1 = *ldgcol;
+ perm_offset = 1 + perm_dim1;
+ perm -= perm_offset;
+ givcol_dim1 = *ldgcol;
+ givcol_offset = 1 + givcol_dim1;
+ givcol -= givcol_offset;
+ --c__;
+ --s;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*icompq < 0 || *icompq > 1) {
+ *info = -1;
+ } else if (*smlsiz < 3) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*sqre < 0 || *sqre > 1) {
+ *info = -4;
+ } else if (*ldu < *n + *sqre) {
+ *info = -8;
+ } else if (*ldgcol < *n) {
+ *info = -17;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLASDA", &i__1);
+ return 0;
+ }
+
+ m = *n + *sqre;
+
+/* If the input matrix is too small, call DLASDQ to find the SVD. */
+
+ if (*n <= *smlsiz) {
+ if (*icompq == 0) {
+ dlasdq_("U", sqre, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[
+ vt_offset], ldu, &u[u_offset], ldu, &u[u_offset], ldu, &
+ work[1], info);
+ } else {
+ dlasdq_("U", sqre, n, &m, n, &c__0, &d__[1], &e[1], &vt[vt_offset]
+, ldu, &u[u_offset], ldu, &u[u_offset], ldu, &work[1],
+ info);
+ }
+ return 0;
+ }
+
+/* Book-keeping and set up the computation tree. */
+
+ inode = 1;
+ ndiml = inode + *n;
+ ndimr = ndiml + *n;
+ idxq = ndimr + *n;
+ iwk = idxq + *n;
+
+ ncc = 0;
+ nru = 0;
+
+ smlszp = *smlsiz + 1;
+ vf = 1;
+ vl = vf + m;
+ nwork1 = vl + m;
+ nwork2 = nwork1 + smlszp * smlszp;
+
+ dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr],
+ smlsiz);
+
+/* for the nodes on bottom level of the tree, solve */
+/* their subproblems by DLASDQ. */
+
+ ndb1 = (nd + 1) / 2;
+ i__1 = nd;
+ for (i__ = ndb1; i__ <= i__1; ++i__) {
+
+/* IC : center row of each node */
+/* NL : number of rows of left subproblem */
+/* NR : number of rows of right subproblem */
+/* NLF: starting row of the left subproblem */
+/* NRF: starting row of the right subproblem */
+
+ i1 = i__ - 1;
+ ic = iwork[inode + i1];
+ nl = iwork[ndiml + i1];
+ nlp1 = nl + 1;
+ nr = iwork[ndimr + i1];
+ nlf = ic - nl;
+ nrf = ic + 1;
+ idxqi = idxq + nlf - 2;
+ vfi = vf + nlf - 1;
+ vli = vl + nlf - 1;
+ sqrei = 1;
+ if (*icompq == 0) {
+ dlaset_("A", &nlp1, &nlp1, &c_b11, &c_b12, &work[nwork1], &smlszp);
+ dlasdq_("U", &sqrei, &nl, &nlp1, &nru, &ncc, &d__[nlf], &e[nlf], &
+ work[nwork1], &smlszp, &work[nwork2], &nl, &work[nwork2],
+ &nl, &work[nwork2], info);
+ itemp = nwork1 + nl * smlszp;
+ dcopy_(&nlp1, &work[nwork1], &c__1, &work[vfi], &c__1);
+ dcopy_(&nlp1, &work[itemp], &c__1, &work[vli], &c__1);
+ } else {
+ dlaset_("A", &nl, &nl, &c_b11, &c_b12, &u[nlf + u_dim1], ldu);
+ dlaset_("A", &nlp1, &nlp1, &c_b11, &c_b12, &vt[nlf + vt_dim1],
+ ldu);
+ dlasdq_("U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], &
+ vt[nlf + vt_dim1], ldu, &u[nlf + u_dim1], ldu, &u[nlf +
+ u_dim1], ldu, &work[nwork1], info);
+ dcopy_(&nlp1, &vt[nlf + vt_dim1], &c__1, &work[vfi], &c__1);
+ dcopy_(&nlp1, &vt[nlf + nlp1 * vt_dim1], &c__1, &work[vli], &c__1)
+ ;
+ }
+ if (*info != 0) {
+ return 0;
+ }
+ i__2 = nl;
+ for (j = 1; j <= i__2; ++j) {
+ iwork[idxqi + j] = j;
+/* L10: */
+ }
+ if (i__ == nd && *sqre == 0) {
+ sqrei = 0;
+ } else {
+ sqrei = 1;
+ }
+ idxqi += nlp1;
+ vfi += nlp1;
+ vli += nlp1;
+ nrp1 = nr + sqrei;
+ if (*icompq == 0) {
+ dlaset_("A", &nrp1, &nrp1, &c_b11, &c_b12, &work[nwork1], &smlszp);
+ dlasdq_("U", &sqrei, &nr, &nrp1, &nru, &ncc, &d__[nrf], &e[nrf], &
+ work[nwork1], &smlszp, &work[nwork2], &nr, &work[nwork2],
+ &nr, &work[nwork2], info);
+ itemp = nwork1 + (nrp1 - 1) * smlszp;
+ dcopy_(&nrp1, &work[nwork1], &c__1, &work[vfi], &c__1);
+ dcopy_(&nrp1, &work[itemp], &c__1, &work[vli], &c__1);
+ } else {
+ dlaset_("A", &nr, &nr, &c_b11, &c_b12, &u[nrf + u_dim1], ldu);
+ dlaset_("A", &nrp1, &nrp1, &c_b11, &c_b12, &vt[nrf + vt_dim1],
+ ldu);
+ dlasdq_("U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], &
+ vt[nrf + vt_dim1], ldu, &u[nrf + u_dim1], ldu, &u[nrf +
+ u_dim1], ldu, &work[nwork1], info);
+ dcopy_(&nrp1, &vt[nrf + vt_dim1], &c__1, &work[vfi], &c__1);
+ dcopy_(&nrp1, &vt[nrf + nrp1 * vt_dim1], &c__1, &work[vli], &c__1)
+ ;
+ }
+ if (*info != 0) {
+ return 0;
+ }
+ i__2 = nr;
+ for (j = 1; j <= i__2; ++j) {
+ iwork[idxqi + j] = j;
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* Now conquer each subproblem bottom-up. */
+
+ j = pow_ii(&c__2, &nlvl);
+ for (lvl = nlvl; lvl >= 1; --lvl) {
+ lvl2 = (lvl << 1) - 1;
+
+/* Find the first node LF and last node LL on */
+/* the current level LVL. */
+
+ if (lvl == 1) {
+ lf = 1;
+ ll = 1;
+ } else {
+ i__1 = lvl - 1;
+ lf = pow_ii(&c__2, &i__1);
+ ll = (lf << 1) - 1;
+ }
+ i__1 = ll;
+ for (i__ = lf; i__ <= i__1; ++i__) {
+ im1 = i__ - 1;
+ ic = iwork[inode + im1];
+ nl = iwork[ndiml + im1];
+ nr = iwork[ndimr + im1];
+ nlf = ic - nl;
+ nrf = ic + 1;
+ if (i__ == ll) {
+ sqrei = *sqre;
+ } else {
+ sqrei = 1;
+ }
+ vfi = vf + nlf - 1;
+ vli = vl + nlf - 1;
+ idxqi = idxq + nlf - 1;
+ alpha = d__[ic];
+ beta = e[ic];
+ if (*icompq == 0) {
+ dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], &
+ work[vli], &alpha, &beta, &iwork[idxqi], &perm[
+ perm_offset], &givptr[1], &givcol[givcol_offset],
+ ldgcol, &givnum[givnum_offset], ldu, &poles[
+ poles_offset], &difl[difl_offset], &difr[difr_offset],
+ &z__[z_offset], &k[1], &c__[1], &s[1], &work[nwork1],
+ &iwork[iwk], info);
+ } else {
+ --j;
+ dlasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], &
+ work[vli], &alpha, &beta, &iwork[idxqi], &perm[nlf +
+ lvl * perm_dim1], &givptr[j], &givcol[nlf + lvl2 *
+ givcol_dim1], ldgcol, &givnum[nlf + lvl2 *
+ givnum_dim1], ldu, &poles[nlf + lvl2 * poles_dim1], &
+ difl[nlf + lvl * difl_dim1], &difr[nlf + lvl2 *
+ difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[j],
+ &s[j], &work[nwork1], &iwork[iwk], info);
+ }
+ if (*info != 0) {
+ return 0;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+
+ return 0;
+
+/* End of DLASDA */
+
+} /* dlasda_ */
diff --git a/SRC/dlasdq.c b/SRC/dlasdq.c
new file mode 100644
index 0000000..581a872
--- /dev/null
+++ b/SRC/dlasdq.c
@@ -0,0 +1,380 @@
+/* dlasdq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dlasdq_(char *uplo, integer *sqre, integer *n, integer *
+ ncvt, integer *nru, integer *ncc, doublereal *d__, doublereal *e,
+ doublereal *vt, integer *ldvt, doublereal *u, integer *ldu,
+ doublereal *c__, integer *ldc, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
+ i__2;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal r__, cs, sn;
+ integer np1, isub;
+ doublereal smin;
+ integer sqre1;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *), dswap_(integer *, doublereal *, integer *
+, doublereal *, integer *);
+ integer iuplo;
+ extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *), xerbla_(char *,
+ integer *), dbdsqr_(char *, integer *, integer *, integer
+ *, integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ logical rotate;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASDQ computes the singular value decomposition (SVD) of a real */
+/* (upper or lower) bidiagonal matrix with diagonal D and offdiagonal */
+/* E, accumulating the transformations if desired. Letting B denote */
+/* the input bidiagonal matrix, the algorithm computes orthogonal */
+/* matrices Q and P such that B = Q * S * P' (P' denotes the transpose */
+/* of P). The singular values S are overwritten on D. */
+
+/* The input matrix U is changed to U * Q if desired. */
+/* The input matrix VT is changed to P' * VT if desired. */
+/* The input matrix C is changed to Q' * C if desired. */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices With */
+/* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, */
+/* LAPACK Working Note #3, for a detailed description of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* On entry, UPLO specifies whether the input bidiagonal matrix */
+/* is upper or lower bidiagonal, and wether it is square are */
+/* not. */
+/* UPLO = 'U' or 'u' B is upper bidiagonal. */
+/* UPLO = 'L' or 'l' B is lower bidiagonal. */
+
+/* SQRE (input) INTEGER */
+/* = 0: then the input matrix is N-by-N. */
+/* = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and */
+/* (N+1)-by-N if UPLU = 'L'. */
+
+/* The bidiagonal matrix has */
+/* N = NL + NR + 1 rows and */
+/* M = N + SQRE >= N columns. */
+
+/* N (input) INTEGER */
+/* On entry, N specifies the number of rows and columns */
+/* in the matrix. N must be at least 0. */
+
+/* NCVT (input) INTEGER */
+/* On entry, NCVT specifies the number of columns of */
+/* the matrix VT. NCVT must be at least 0. */
+
+/* NRU (input) INTEGER */
+/* On entry, NRU specifies the number of rows of */
+/* the matrix U. NRU must be at least 0. */
+
+/* NCC (input) INTEGER */
+/* On entry, NCC specifies the number of columns of */
+/* the matrix C. NCC must be at least 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, D contains the diagonal entries of the */
+/* bidiagonal matrix whose SVD is desired. On normal exit, */
+/* D contains the singular values in ascending order. */
+
+/* E (input/output) DOUBLE PRECISION array. */
+/* dimension is (N-1) if SQRE = 0 and N if SQRE = 1. */
+/* On entry, the entries of E contain the offdiagonal entries */
+/* of the bidiagonal matrix whose SVD is desired. On normal */
+/* exit, E will contain 0. If the algorithm does not converge, */
+/* D and E will contain the diagonal and superdiagonal entries */
+/* of a bidiagonal matrix orthogonally equivalent to the one */
+/* given as input. */
+
+/* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) */
+/* On entry, contains a matrix which on exit has been */
+/* premultiplied by P', dimension N-by-NCVT if SQRE = 0 */
+/* and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0). */
+
+/* LDVT (input) INTEGER */
+/* On entry, LDVT specifies the leading dimension of VT as */
+/* declared in the calling (sub) program. LDVT must be at */
+/* least 1. If NCVT is nonzero LDVT must also be at least N. */
+
+/* U (input/output) DOUBLE PRECISION array, dimension (LDU, N) */
+/* On entry, contains a matrix which on exit has been */
+/* postmultiplied by Q, dimension NRU-by-N if SQRE = 0 */
+/* and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0). */
+
+/* LDU (input) INTEGER */
+/* On entry, LDU specifies the leading dimension of U as */
+/* declared in the calling (sub) program. LDU must be at */
+/* least max( 1, NRU ) . */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) */
+/* On entry, contains an N-by-NCC matrix which on exit */
+/* has been premultiplied by Q' dimension N-by-NCC if SQRE = 0 */
+/* and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0). */
+
+/* LDC (input) INTEGER */
+/* On entry, LDC specifies the leading dimension of C as */
+/* declared in the calling (sub) program. LDC must be at */
+/* least 1. If NCC is nonzero, LDC must also be at least N. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */
+/* Workspace. Only referenced if one of NCVT, NRU, or NCC is */
+/* nonzero, and if N is at least 2. */
+
+/* INFO (output) INTEGER */
+/* On exit, a value of 0 indicates a successful exit. */
+/* If INFO < 0, argument number -INFO is illegal. */
+/* If INFO > 0, the algorithm did not converge, and INFO */
+/* specifies how many superdiagonals did not converge. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ iuplo = 0;
+ if (lsame_(uplo, "U")) {
+ iuplo = 1;
+ }
+ if (lsame_(uplo, "L")) {
+ iuplo = 2;
+ }
+ if (iuplo == 0) {
+ *info = -1;
+ } else if (*sqre < 0 || *sqre > 1) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ncvt < 0) {
+ *info = -4;
+ } else if (*nru < 0) {
+ *info = -5;
+ } else if (*ncc < 0) {
+ *info = -6;
+ } else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1,*n)) {
+ *info = -10;
+ } else if (*ldu < max(1,*nru)) {
+ *info = -12;
+ } else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1,*n)) {
+ *info = -14;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLASDQ", &i__1);
+ return 0;
+ }
+ if (*n == 0) {
+ return 0;
+ }
+
+/* ROTATE is true if any singular vectors desired, false otherwise */
+
+ rotate = *ncvt > 0 || *nru > 0 || *ncc > 0;
+ np1 = *n + 1;
+ sqre1 = *sqre;
+
+/* If matrix non-square upper bidiagonal, rotate to be lower */
+/* bidiagonal. The rotations are on the right. */
+
+ if (iuplo == 1 && sqre1 == 1) {
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
+ d__[i__] = r__;
+ e[i__] = sn * d__[i__ + 1];
+ d__[i__ + 1] = cs * d__[i__ + 1];
+ if (rotate) {
+ work[i__] = cs;
+ work[*n + i__] = sn;
+ }
+/* L10: */
+ }
+ dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__);
+ d__[*n] = r__;
+ e[*n] = 0.;
+ if (rotate) {
+ work[*n] = cs;
+ work[*n + *n] = sn;
+ }
+ iuplo = 2;
+ sqre1 = 0;
+
+/* Update singular vectors if desired. */
+
+ if (*ncvt > 0) {
+ dlasr_("L", "V", "F", &np1, ncvt, &work[1], &work[np1], &vt[
+ vt_offset], ldvt);
+ }
+ }
+
+/* If matrix lower bidiagonal, rotate to be upper bidiagonal */
+/* by applying Givens rotations on the left. */
+
+ if (iuplo == 2) {
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
+ d__[i__] = r__;
+ e[i__] = sn * d__[i__ + 1];
+ d__[i__ + 1] = cs * d__[i__ + 1];
+ if (rotate) {
+ work[i__] = cs;
+ work[*n + i__] = sn;
+ }
+/* L20: */
+ }
+
+/* If matrix (N+1)-by-N lower bidiagonal, one additional */
+/* rotation is needed. */
+
+ if (sqre1 == 1) {
+ dlartg_(&d__[*n], &e[*n], &cs, &sn, &r__);
+ d__[*n] = r__;
+ if (rotate) {
+ work[*n] = cs;
+ work[*n + *n] = sn;
+ }
+ }
+
+/* Update singular vectors if desired. */
+
+ if (*nru > 0) {
+ if (sqre1 == 0) {
+ dlasr_("R", "V", "F", nru, n, &work[1], &work[np1], &u[
+ u_offset], ldu);
+ } else {
+ dlasr_("R", "V", "F", nru, &np1, &work[1], &work[np1], &u[
+ u_offset], ldu);
+ }
+ }
+ if (*ncc > 0) {
+ if (sqre1 == 0) {
+ dlasr_("L", "V", "F", n, ncc, &work[1], &work[np1], &c__[
+ c_offset], ldc);
+ } else {
+ dlasr_("L", "V", "F", &np1, ncc, &work[1], &work[np1], &c__[
+ c_offset], ldc);
+ }
+ }
+ }
+
+/* Call DBDSQR to compute the SVD of the reduced real */
+/* N-by-N upper bidiagonal matrix. */
+
+ dbdsqr_("U", n, ncvt, nru, ncc, &d__[1], &e[1], &vt[vt_offset], ldvt, &u[
+ u_offset], ldu, &c__[c_offset], ldc, &work[1], info);
+
+/* Sort the singular values into ascending order (insertion sort on */
+/* singular values, but only one transposition per singular vector) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Scan for smallest D(I). */
+
+ isub = i__;
+ smin = d__[i__];
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (d__[j] < smin) {
+ isub = j;
+ smin = d__[j];
+ }
+/* L30: */
+ }
+ if (isub != i__) {
+
+/* Swap singular values and vectors. */
+
+ d__[isub] = d__[i__];
+ d__[i__] = smin;
+ if (*ncvt > 0) {
+ dswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[i__ + vt_dim1],
+ ldvt);
+ }
+ if (*nru > 0) {
+ dswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[i__ * u_dim1 + 1]
+, &c__1);
+ }
+ if (*ncc > 0) {
+ dswap_(ncc, &c__[isub + c_dim1], ldc, &c__[i__ + c_dim1], ldc)
+ ;
+ }
+ }
+/* L40: */
+ }
+
+ return 0;
+
+/* End of DLASDQ */
+
+} /* dlasdq_ */
diff --git a/SRC/dlasdt.c b/SRC/dlasdt.c
new file mode 100644
index 0000000..0f25bdd
--- /dev/null
+++ b/SRC/dlasdt.c
@@ -0,0 +1,136 @@
+/* dlasdt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlasdt_(integer *n, integer *lvl, integer *nd, integer *
+ inode, integer *ndiml, integer *ndimr, integer *msub)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Builtin functions */
+ double log(doublereal);
+
+ /* Local variables */
+ integer i__, il, ir, maxn;
+ doublereal temp;
+ integer nlvl, llst, ncrnt;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASDT creates a tree of subproblems for bidiagonal divide and */
+/* conquer. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* On entry, the number of diagonal elements of the */
+/* bidiagonal matrix. */
+
+/* LVL (output) INTEGER */
+/* On exit, the number of levels on the computation tree. */
+
+/* ND (output) INTEGER */
+/* On exit, the number of nodes on the tree. */
+
+/* INODE (output) INTEGER array, dimension ( N ) */
+/* On exit, centers of subproblems. */
+
+/* NDIML (output) INTEGER array, dimension ( N ) */
+/* On exit, row dimensions of left children. */
+
+/* NDIMR (output) INTEGER array, dimension ( N ) */
+/* On exit, row dimensions of right children. */
+
+/* MSUB (input) INTEGER. */
+/* On entry, the maximum row dimension each subproblem at the */
+/* bottom of the tree can be of. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Find the number of levels on the tree. */
+
+ /* Parameter adjustments */
+ --ndimr;
+ --ndiml;
+ --inode;
+
+ /* Function Body */
+ maxn = max(1,*n);
+ temp = log((doublereal) maxn / (doublereal) (*msub + 1)) / log(2.);
+ *lvl = (integer) temp + 1;
+
+ i__ = *n / 2;
+ inode[1] = i__ + 1;
+ ndiml[1] = i__;
+ ndimr[1] = *n - i__ - 1;
+ il = 0;
+ ir = 1;
+ llst = 1;
+ i__1 = *lvl - 1;
+ for (nlvl = 1; nlvl <= i__1; ++nlvl) {
+
+/* Constructing the tree at (NLVL+1)-st level. The number of */
+/* nodes created on this level is LLST * 2. */
+
+ i__2 = llst - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ il += 2;
+ ir += 2;
+ ncrnt = llst + i__;
+ ndiml[il] = ndiml[ncrnt] / 2;
+ ndimr[il] = ndiml[ncrnt] - ndiml[il] - 1;
+ inode[il] = inode[ncrnt] - ndimr[il] - 1;
+ ndiml[ir] = ndimr[ncrnt] / 2;
+ ndimr[ir] = ndimr[ncrnt] - ndiml[ir] - 1;
+ inode[ir] = inode[ncrnt] + ndiml[ir] + 1;
+/* L10: */
+ }
+ llst <<= 1;
+/* L20: */
+ }
+ *nd = (llst << 1) - 1;
+
+ return 0;
+
+/* End of DLASDT */
+
+} /* dlasdt_ */
diff --git a/SRC/dlaset.c b/SRC/dlaset.c
new file mode 100644
index 0000000..98d304e
--- /dev/null
+++ b/SRC/dlaset.c
@@ -0,0 +1,152 @@
+/* dlaset.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlaset_(char *uplo, integer *m, integer *n, doublereal *
+ alpha, doublereal *beta, doublereal *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j;
+ extern logical lsame_(char *, char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASET initializes an m-by-n matrix A to BETA on the diagonal and */
+/* ALPHA on the offdiagonals. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies the part of the matrix A to be set. */
+/* = 'U': Upper triangular part is set; the strictly lower */
+/* triangular part of A is not changed. */
+/* = 'L': Lower triangular part is set; the strictly upper */
+/* triangular part of A is not changed. */
+/* Otherwise: All of the matrix A is set. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* ALPHA (input) DOUBLE PRECISION */
+/* The constant to which the offdiagonal elements are to be set. */
+
+/* BETA (input) DOUBLE PRECISION */
+/* The constant to which the diagonal elements are to be set. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On exit, the leading m-by-n submatrix of A is set as follows: */
+
+/* if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, */
+/* if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, */
+/* otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, */
+
+/* and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ if (lsame_(uplo, "U")) {
+
+/* Set the strictly upper triangular or trapezoidal part of the */
+/* array to ALPHA. */
+
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j - 1;
+ i__2 = min(i__3,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = *alpha;
+/* L10: */
+ }
+/* L20: */
+ }
+
+ } else if (lsame_(uplo, "L")) {
+
+/* Set the strictly lower triangular or trapezoidal part of the */
+/* array to ALPHA. */
+
+ i__1 = min(*m,*n);
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = *alpha;
+/* L30: */
+ }
+/* L40: */
+ }
+
+ } else {
+
+/* Set the leading m-by-n submatrix to ALPHA. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = *alpha;
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+
+/* Set the first min(M,N) diagonal elements to BETA. */
+
+ i__1 = min(*m,*n);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ a[i__ + i__ * a_dim1] = *beta;
+/* L70: */
+ }
+
+ return 0;
+
+/* End of DLASET */
+
+} /* dlaset_ */
diff --git a/SRC/dlasq1.c b/SRC/dlasq1.c
new file mode 100644
index 0000000..7a6e8b7
--- /dev/null
+++ b/SRC/dlasq1.c
@@ -0,0 +1,219 @@
+/* dlasq1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+
+/* Subroutine */ int dlasq1_(integer *n, doublereal *d__, doublereal *e,
+ doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal eps;
+ extern /* Subroutine */ int dlas2_(doublereal *, doublereal *, doublereal
+ *, doublereal *, doublereal *);
+ doublereal scale;
+ integer iinfo;
+ doublereal sigmn;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ doublereal sigmx;
+ extern /* Subroutine */ int dlasq2_(integer *, doublereal *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *), dlasrt_(
+ char *, integer *, doublereal *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
+/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
+/* -- Berkeley -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASQ1 computes the singular values of a real N-by-N bidiagonal */
+/* matrix with diagonal D and off-diagonal E. The singular values */
+/* are computed to high relative accuracy, in the absence of */
+/* denormalization, underflow and overflow. The algorithm was first */
+/* presented in */
+
+/* "Accurate singular values and differential qd algorithms" by K. V. */
+/* Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230, */
+/* 1994, */
+
+/* and the present implementation is described in "An implementation of */
+/* the dqds Algorithm (Positive Case)", LAPACK Working Note. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows and columns in the matrix. N >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, D contains the diagonal elements of the */
+/* bidiagonal matrix whose SVD is desired. On normal exit, */
+/* D contains the singular values in decreasing order. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, elements E(1:N-1) contain the off-diagonal elements */
+/* of the bidiagonal matrix whose SVD is desired. */
+/* On exit, E is overwritten. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: the algorithm failed */
+/* = 1, a split was marked by a positive value in E */
+/* = 2, current block of Z not diagonalized after 30*N */
+/* iterations (in inner while loop) */
+/* = 3, termination criterion of outer while loop not met */
+/* (program created more than N unreduced blocks) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --e;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -2;
+ i__1 = -(*info);
+ xerbla_("DLASQ1", &i__1);
+ return 0;
+ } else if (*n == 0) {
+ return 0;
+ } else if (*n == 1) {
+ d__[1] = abs(d__[1]);
+ return 0;
+ } else if (*n == 2) {
+ dlas2_(&d__[1], &e[1], &d__[2], &sigmn, &sigmx);
+ d__[1] = sigmx;
+ d__[2] = sigmn;
+ return 0;
+ }
+
+/* Estimate the largest singular value. */
+
+ sigmx = 0.;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = (d__1 = d__[i__], abs(d__1));
+/* Computing MAX */
+ d__2 = sigmx, d__3 = (d__1 = e[i__], abs(d__1));
+ sigmx = max(d__2,d__3);
+/* L10: */
+ }
+ d__[*n] = (d__1 = d__[*n], abs(d__1));
+
+/* Early return if SIGMX is zero (matrix is already diagonal). */
+
+ if (sigmx == 0.) {
+ dlasrt_("D", n, &d__[1], &iinfo);
+ return 0;
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = sigmx, d__2 = d__[i__];
+ sigmx = max(d__1,d__2);
+/* L20: */
+ }
+
+/* Copy D and E into WORK (in the Z format) and scale (squaring the */
+/* input data makes scaling by a power of the radix pointless). */
+
+ eps = dlamch_("Precision");
+ safmin = dlamch_("Safe minimum");
+ scale = sqrt(eps / safmin);
+ dcopy_(n, &d__[1], &c__1, &work[1], &c__2);
+ i__1 = *n - 1;
+ dcopy_(&i__1, &e[1], &c__1, &work[2], &c__2);
+ i__1 = (*n << 1) - 1;
+ i__2 = (*n << 1) - 1;
+ dlascl_("G", &c__0, &c__0, &sigmx, &scale, &i__1, &c__1, &work[1], &i__2,
+ &iinfo);
+
+/* Compute the q's and e's. */
+
+ i__1 = (*n << 1) - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing 2nd power */
+ d__1 = work[i__];
+ work[i__] = d__1 * d__1;
+/* L30: */
+ }
+ work[*n * 2] = 0.;
+
+ dlasq2_(n, &work[1], info);
+
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = sqrt(work[i__]);
+/* L40: */
+ }
+ dlascl_("G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, &
+ iinfo);
+ }
+
+ return 0;
+
+/* End of DLASQ1 */
+
+} /* dlasq1_ */
diff --git a/SRC/dlasq2.c b/SRC/dlasq2.c
new file mode 100644
index 0000000..3b041a2
--- /dev/null
+++ b/SRC/dlasq2.c
@@ -0,0 +1,602 @@
+/* dlasq2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__10 = 10;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static integer c__11 = 11;
+
+/* Subroutine */ int dlasq2_(integer *n, doublereal *z__, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal d__, e, g;
+ integer k;
+ doublereal s, t;
+ integer i0, i4, n0;
+ doublereal dn;
+ integer pp;
+ doublereal dn1, dn2, dee, eps, tau, tol;
+ integer ipn4;
+ doublereal tol2;
+ logical ieee;
+ integer nbig;
+ doublereal dmin__, emin, emax;
+ integer kmin, ndiv, iter;
+ doublereal qmin, temp, qmax, zmax;
+ integer splt;
+ doublereal dmin1, dmin2;
+ integer nfail;
+ doublereal desig, trace, sigma;
+ integer iinfo, ttype;
+ extern /* Subroutine */ int dlasq3_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *, integer *, logical *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ doublereal deemin;
+ integer iwhila, iwhilb;
+ doublereal oldemn, safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
+/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
+/* -- Berkeley -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASQ2 computes all the eigenvalues of the symmetric positive */
+/* definite tridiagonal matrix associated with the qd array Z to high */
+/* relative accuracy are computed to high relative accuracy, in the */
+/* absence of denormalization, underflow and overflow. */
+
+/* To see the relation of Z to the tridiagonal matrix, let L be a */
+/* unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and */
+/* let U be an upper bidiagonal matrix with 1's above and diagonal */
+/* Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the */
+/* symmetric tridiagonal to which it is similar. */
+
+/* Note : DLASQ2 defines a logical variable, IEEE, which is true */
+/* on machines which follow ieee-754 floating-point standard in their */
+/* handling of infinities and NaNs, and false otherwise. This variable */
+/* is passed to DLASQ3. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows and columns in the matrix. N >= 0. */
+
+/* Z (input/output) DOUBLE PRECISION array, dimension ( 4*N ) */
+/* On entry Z holds the qd array. On exit, entries 1 to N hold */
+/* the eigenvalues in decreasing order, Z( 2*N+1 ) holds the */
+/* trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If */
+/* N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 ) */
+/* holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of */
+/* shifts that failed. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if the i-th argument is a scalar and had an illegal */
+/* value, then INFO = -i, if the i-th argument is an */
+/* array and the j-entry had an illegal value, then */
+/* INFO = -(i*100+j) */
+/* > 0: the algorithm failed */
+/* = 1, a split was marked by a positive value in E */
+/* = 2, current block of Z not diagonalized after 30*N */
+/* iterations (in inner while loop) */
+/* = 3, termination criterion of outer while loop not met */
+/* (program created more than N unreduced blocks) */
+
+/* Further Details */
+/* =============== */
+/* Local Variables: I0:N0 defines a current unreduced segment of Z. */
+/* The shifts are accumulated in SIGMA. Iteration count is in ITER. */
+/* Ping-pong is controlled by PP (alternates between 0 and 1). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+/* (in case DLASQ2 is not called by DLASQ1) */
+
+ /* Parameter adjustments */
+ --z__;
+
+ /* Function Body */
+ *info = 0;
+ eps = dlamch_("Precision");
+ safmin = dlamch_("Safe minimum");
+ tol = eps * 100.;
+/* Computing 2nd power */
+ d__1 = tol;
+ tol2 = d__1 * d__1;
+
+ if (*n < 0) {
+ *info = -1;
+ xerbla_("DLASQ2", &c__1);
+ return 0;
+ } else if (*n == 0) {
+ return 0;
+ } else if (*n == 1) {
+
+/* 1-by-1 case. */
+
+ if (z__[1] < 0.) {
+ *info = -201;
+ xerbla_("DLASQ2", &c__2);
+ }
+ return 0;
+ } else if (*n == 2) {
+
+/* 2-by-2 case. */
+
+ if (z__[2] < 0. || z__[3] < 0.) {
+ *info = -2;
+ xerbla_("DLASQ2", &c__2);
+ return 0;
+ } else if (z__[3] > z__[1]) {
+ d__ = z__[3];
+ z__[3] = z__[1];
+ z__[1] = d__;
+ }
+ z__[5] = z__[1] + z__[2] + z__[3];
+ if (z__[2] > z__[3] * tol2) {
+ t = (z__[1] - z__[3] + z__[2]) * .5;
+ s = z__[3] * (z__[2] / t);
+ if (s <= t) {
+ s = z__[3] * (z__[2] / (t * (sqrt(s / t + 1.) + 1.)));
+ } else {
+ s = z__[3] * (z__[2] / (t + sqrt(t) * sqrt(t + s)));
+ }
+ t = z__[1] + (s + z__[2]);
+ z__[3] *= z__[1] / t;
+ z__[1] = t;
+ }
+ z__[2] = z__[3];
+ z__[6] = z__[2] + z__[1];
+ return 0;
+ }
+
+/* Check for negative data and compute sums of q's and e's. */
+
+ z__[*n * 2] = 0.;
+ emin = z__[2];
+ qmax = 0.;
+ zmax = 0.;
+ d__ = 0.;
+ e = 0.;
+
+ i__1 = *n - 1 << 1;
+ for (k = 1; k <= i__1; k += 2) {
+ if (z__[k] < 0.) {
+ *info = -(k + 200);
+ xerbla_("DLASQ2", &c__2);
+ return 0;
+ } else if (z__[k + 1] < 0.) {
+ *info = -(k + 201);
+ xerbla_("DLASQ2", &c__2);
+ return 0;
+ }
+ d__ += z__[k];
+ e += z__[k + 1];
+/* Computing MAX */
+ d__1 = qmax, d__2 = z__[k];
+ qmax = max(d__1,d__2);
+/* Computing MIN */
+ d__1 = emin, d__2 = z__[k + 1];
+ emin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = max(qmax,zmax), d__2 = z__[k + 1];
+ zmax = max(d__1,d__2);
+/* L10: */
+ }
+ if (z__[(*n << 1) - 1] < 0.) {
+ *info = -((*n << 1) + 199);
+ xerbla_("DLASQ2", &c__2);
+ return 0;
+ }
+ d__ += z__[(*n << 1) - 1];
+/* Computing MAX */
+ d__1 = qmax, d__2 = z__[(*n << 1) - 1];
+ qmax = max(d__1,d__2);
+ zmax = max(qmax,zmax);
+
+/* Check for diagonality. */
+
+ if (e == 0.) {
+ i__1 = *n;
+ for (k = 2; k <= i__1; ++k) {
+ z__[k] = z__[(k << 1) - 1];
+/* L20: */
+ }
+ dlasrt_("D", n, &z__[1], &iinfo);
+ z__[(*n << 1) - 1] = d__;
+ return 0;
+ }
+
+ trace = d__ + e;
+
+/* Check for zero data. */
+
+ if (trace == 0.) {
+ z__[(*n << 1) - 1] = 0.;
+ return 0;
+ }
+
+/* Check whether the machine is IEEE conformable. */
+
+ ieee = ilaenv_(&c__10, "DLASQ2", "N", &c__1, &c__2, &c__3, &c__4) == 1 && ilaenv_(&c__11, "DLASQ2", "N", &c__1, &c__2,
+ &c__3, &c__4) == 1;
+
+/* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). */
+
+ for (k = *n << 1; k >= 2; k += -2) {
+ z__[k * 2] = 0.;
+ z__[(k << 1) - 1] = z__[k];
+ z__[(k << 1) - 2] = 0.;
+ z__[(k << 1) - 3] = z__[k - 1];
+/* L30: */
+ }
+
+ i0 = 1;
+ n0 = *n;
+
+/* Reverse the qd-array, if warranted. */
+
+ if (z__[(i0 << 2) - 3] * 1.5 < z__[(n0 << 2) - 3]) {
+ ipn4 = i0 + n0 << 2;
+ i__1 = i0 + n0 - 1 << 1;
+ for (i4 = i0 << 2; i4 <= i__1; i4 += 4) {
+ temp = z__[i4 - 3];
+ z__[i4 - 3] = z__[ipn4 - i4 - 3];
+ z__[ipn4 - i4 - 3] = temp;
+ temp = z__[i4 - 1];
+ z__[i4 - 1] = z__[ipn4 - i4 - 5];
+ z__[ipn4 - i4 - 5] = temp;
+/* L40: */
+ }
+ }
+
+/* Initial split checking via dqd and Li's test. */
+
+ pp = 0;
+
+ for (k = 1; k <= 2; ++k) {
+
+ d__ = z__[(n0 << 2) + pp - 3];
+ i__1 = (i0 << 2) + pp;
+ for (i4 = (n0 - 1 << 2) + pp; i4 >= i__1; i4 += -4) {
+ if (z__[i4 - 1] <= tol2 * d__) {
+ z__[i4 - 1] = -0.;
+ d__ = z__[i4 - 3];
+ } else {
+ d__ = z__[i4 - 3] * (d__ / (d__ + z__[i4 - 1]));
+ }
+/* L50: */
+ }
+
+/* dqd maps Z to ZZ plus Li's test. */
+
+ emin = z__[(i0 << 2) + pp + 1];
+ d__ = z__[(i0 << 2) + pp - 3];
+ i__1 = (n0 - 1 << 2) + pp;
+ for (i4 = (i0 << 2) + pp; i4 <= i__1; i4 += 4) {
+ z__[i4 - (pp << 1) - 2] = d__ + z__[i4 - 1];
+ if (z__[i4 - 1] <= tol2 * d__) {
+ z__[i4 - 1] = -0.;
+ z__[i4 - (pp << 1) - 2] = d__;
+ z__[i4 - (pp << 1)] = 0.;
+ d__ = z__[i4 + 1];
+ } else if (safmin * z__[i4 + 1] < z__[i4 - (pp << 1) - 2] &&
+ safmin * z__[i4 - (pp << 1) - 2] < z__[i4 + 1]) {
+ temp = z__[i4 + 1] / z__[i4 - (pp << 1) - 2];
+ z__[i4 - (pp << 1)] = z__[i4 - 1] * temp;
+ d__ *= temp;
+ } else {
+ z__[i4 - (pp << 1)] = z__[i4 + 1] * (z__[i4 - 1] / z__[i4 - (
+ pp << 1) - 2]);
+ d__ = z__[i4 + 1] * (d__ / z__[i4 - (pp << 1) - 2]);
+ }
+/* Computing MIN */
+ d__1 = emin, d__2 = z__[i4 - (pp << 1)];
+ emin = min(d__1,d__2);
+/* L60: */
+ }
+ z__[(n0 << 2) - pp - 2] = d__;
+
+/* Now find qmax. */
+
+ qmax = z__[(i0 << 2) - pp - 2];
+ i__1 = (n0 << 2) - pp - 2;
+ for (i4 = (i0 << 2) - pp + 2; i4 <= i__1; i4 += 4) {
+/* Computing MAX */
+ d__1 = qmax, d__2 = z__[i4];
+ qmax = max(d__1,d__2);
+/* L70: */
+ }
+
+/* Prepare for the next iteration on K. */
+
+ pp = 1 - pp;
+/* L80: */
+ }
+
+/* Initialise variables to pass to DLASQ3. */
+
+ ttype = 0;
+ dmin1 = 0.;
+ dmin2 = 0.;
+ dn = 0.;
+ dn1 = 0.;
+ dn2 = 0.;
+ g = 0.;
+ tau = 0.;
+
+ iter = 2;
+ nfail = 0;
+ ndiv = n0 - i0 << 1;
+
+ i__1 = *n + 1;
+ for (iwhila = 1; iwhila <= i__1; ++iwhila) {
+ if (n0 < 1) {
+ goto L170;
+ }
+
+/* While array unfinished do */
+
+/* E(N0) holds the value of SIGMA when submatrix in I0:N0 */
+/* splits from the rest of the array, but is negated. */
+
+ desig = 0.;
+ if (n0 == *n) {
+ sigma = 0.;
+ } else {
+ sigma = -z__[(n0 << 2) - 1];
+ }
+ if (sigma < 0.) {
+ *info = 1;
+ return 0;
+ }
+
+/* Find last unreduced submatrix's top index I0, find QMAX and */
+/* EMIN. Find Gershgorin-type bound if Q's much greater than E's. */
+
+ emax = 0.;
+ if (n0 > i0) {
+ emin = (d__1 = z__[(n0 << 2) - 5], abs(d__1));
+ } else {
+ emin = 0.;
+ }
+ qmin = z__[(n0 << 2) - 3];
+ qmax = qmin;
+ for (i4 = n0 << 2; i4 >= 8; i4 += -4) {
+ if (z__[i4 - 5] <= 0.) {
+ goto L100;
+ }
+ if (qmin >= emax * 4.) {
+/* Computing MIN */
+ d__1 = qmin, d__2 = z__[i4 - 3];
+ qmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = emax, d__2 = z__[i4 - 5];
+ emax = max(d__1,d__2);
+ }
+/* Computing MAX */
+ d__1 = qmax, d__2 = z__[i4 - 7] + z__[i4 - 5];
+ qmax = max(d__1,d__2);
+/* Computing MIN */
+ d__1 = emin, d__2 = z__[i4 - 5];
+ emin = min(d__1,d__2);
+/* L90: */
+ }
+ i4 = 4;
+
+L100:
+ i0 = i4 / 4;
+ pp = 0;
+
+ if (n0 - i0 > 1) {
+ dee = z__[(i0 << 2) - 3];
+ deemin = dee;
+ kmin = i0;
+ i__2 = (n0 << 2) - 3;
+ for (i4 = (i0 << 2) + 1; i4 <= i__2; i4 += 4) {
+ dee = z__[i4] * (dee / (dee + z__[i4 - 2]));
+ if (dee <= deemin) {
+ deemin = dee;
+ kmin = (i4 + 3) / 4;
+ }
+/* L110: */
+ }
+ if (kmin - i0 << 1 < n0 - kmin && deemin <= z__[(n0 << 2) - 3] *
+ .5) {
+ ipn4 = i0 + n0 << 2;
+ pp = 2;
+ i__2 = i0 + n0 - 1 << 1;
+ for (i4 = i0 << 2; i4 <= i__2; i4 += 4) {
+ temp = z__[i4 - 3];
+ z__[i4 - 3] = z__[ipn4 - i4 - 3];
+ z__[ipn4 - i4 - 3] = temp;
+ temp = z__[i4 - 2];
+ z__[i4 - 2] = z__[ipn4 - i4 - 2];
+ z__[ipn4 - i4 - 2] = temp;
+ temp = z__[i4 - 1];
+ z__[i4 - 1] = z__[ipn4 - i4 - 5];
+ z__[ipn4 - i4 - 5] = temp;
+ temp = z__[i4];
+ z__[i4] = z__[ipn4 - i4 - 4];
+ z__[ipn4 - i4 - 4] = temp;
+/* L120: */
+ }
+ }
+ }
+
+/* Put -(initial shift) into DMIN. */
+
+/* Computing MAX */
+ d__1 = 0., d__2 = qmin - sqrt(qmin) * 2. * sqrt(emax);
+ dmin__ = -max(d__1,d__2);
+
+/* Now I0:N0 is unreduced. */
+/* PP = 0 for ping, PP = 1 for pong. */
+/* PP = 2 indicates that flipping was applied to the Z array and */
+/* and that the tests for deflation upon entry in DLASQ3 */
+/* should not be performed. */
+
+ nbig = (n0 - i0 + 1) * 30;
+ i__2 = nbig;
+ for (iwhilb = 1; iwhilb <= i__2; ++iwhilb) {
+ if (i0 > n0) {
+ goto L150;
+ }
+
+/* While submatrix unfinished take a good dqds step. */
+
+ dlasq3_(&i0, &n0, &z__[1], &pp, &dmin__, &sigma, &desig, &qmax, &
+ nfail, &iter, &ndiv, &ieee, &ttype, &dmin1, &dmin2, &dn, &
+ dn1, &dn2, &g, &tau);
+
+ pp = 1 - pp;
+
+/* When EMIN is very small check for splits. */
+
+ if (pp == 0 && n0 - i0 >= 3) {
+ if (z__[n0 * 4] <= tol2 * qmax || z__[(n0 << 2) - 1] <= tol2 *
+ sigma) {
+ splt = i0 - 1;
+ qmax = z__[(i0 << 2) - 3];
+ emin = z__[(i0 << 2) - 1];
+ oldemn = z__[i0 * 4];
+ i__3 = n0 - 3 << 2;
+ for (i4 = i0 << 2; i4 <= i__3; i4 += 4) {
+ if (z__[i4] <= tol2 * z__[i4 - 3] || z__[i4 - 1] <=
+ tol2 * sigma) {
+ z__[i4 - 1] = -sigma;
+ splt = i4 / 4;
+ qmax = 0.;
+ emin = z__[i4 + 3];
+ oldemn = z__[i4 + 4];
+ } else {
+/* Computing MAX */
+ d__1 = qmax, d__2 = z__[i4 + 1];
+ qmax = max(d__1,d__2);
+/* Computing MIN */
+ d__1 = emin, d__2 = z__[i4 - 1];
+ emin = min(d__1,d__2);
+/* Computing MIN */
+ d__1 = oldemn, d__2 = z__[i4];
+ oldemn = min(d__1,d__2);
+ }
+/* L130: */
+ }
+ z__[(n0 << 2) - 1] = emin;
+ z__[n0 * 4] = oldemn;
+ i0 = splt + 1;
+ }
+ }
+
+/* L140: */
+ }
+
+ *info = 2;
+ return 0;
+
+/* end IWHILB */
+
+L150:
+
+/* L160: */
+ ;
+ }
+
+ *info = 3;
+ return 0;
+
+/* end IWHILA */
+
+L170:
+
+/* Move q's to the front. */
+
+ i__1 = *n;
+ for (k = 2; k <= i__1; ++k) {
+ z__[k] = z__[(k << 2) - 3];
+/* L180: */
+ }
+
+/* Sort and compute sum of eigenvalues. */
+
+ dlasrt_("D", n, &z__[1], &iinfo);
+
+ e = 0.;
+ for (k = *n; k >= 1; --k) {
+ e += z__[k];
+/* L190: */
+ }
+
+/* Store trace, sum(eigenvalues) and information on performance. */
+
+ z__[(*n << 1) + 1] = trace;
+ z__[(*n << 1) + 2] = e;
+ z__[(*n << 1) + 3] = (doublereal) iter;
+/* Computing 2nd power */
+ i__1 = *n;
+ z__[(*n << 1) + 4] = (doublereal) ndiv / (doublereal) (i__1 * i__1);
+ z__[(*n << 1) + 5] = nfail * 100. / (doublereal) iter;
+ return 0;
+
+/* End of DLASQ2 */
+
+} /* dlasq2_ */
diff --git a/SRC/dlasq3.c b/SRC/dlasq3.c
new file mode 100644
index 0000000..0e59c94
--- /dev/null
+++ b/SRC/dlasq3.c
@@ -0,0 +1,350 @@
+/* dlasq3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlasq3_(integer *i0, integer *n0, doublereal *z__,
+ integer *pp, doublereal *dmin__, doublereal *sigma, doublereal *desig,
+ doublereal *qmax, integer *nfail, integer *iter, integer *ndiv,
+ logical *ieee, integer *ttype, doublereal *dmin1, doublereal *dmin2,
+ doublereal *dn, doublereal *dn1, doublereal *dn2, doublereal *g,
+ doublereal *tau)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal s, t;
+ integer j4, nn;
+ doublereal eps, tol;
+ integer n0in, ipn4;
+ doublereal tol2, temp;
+ extern /* Subroutine */ int dlasq4_(integer *, integer *, doublereal *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *), dlasq5_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, logical *), dlasq6_(
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *);
+ extern doublereal dlamch_(char *);
+ extern logical disnan_(doublereal *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
+/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
+/* -- Berkeley -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds. */
+/* In case of failure it changes shifts, and tries again until output */
+/* is positive. */
+
+/* Arguments */
+/* ========= */
+
+/* I0 (input) INTEGER */
+/* First index. */
+
+/* N0 (input) INTEGER */
+/* Last index. */
+
+/* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) */
+/* Z holds the qd array. */
+
+/* PP (input/output) INTEGER */
+/* PP=0 for ping, PP=1 for pong. */
+/* PP=2 indicates that flipping was applied to the Z array */
+/* and that the initial tests for deflation should not be */
+/* performed. */
+
+/* DMIN (output) DOUBLE PRECISION */
+/* Minimum value of d. */
+
+/* SIGMA (output) DOUBLE PRECISION */
+/* Sum of shifts used in current segment. */
+
+/* DESIG (input/output) DOUBLE PRECISION */
+/* Lower order part of SIGMA */
+
+/* QMAX (input) DOUBLE PRECISION */
+/* Maximum value of q. */
+
+/* NFAIL (output) INTEGER */
+/* Number of times shift was too big. */
+
+/* ITER (output) INTEGER */
+/* Number of iterations. */
+
+/* NDIV (output) INTEGER */
+/* Number of divisions. */
+
+/* IEEE (input) LOGICAL */
+/* Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). */
+
+/* TTYPE (input/output) INTEGER */
+/* Shift type. */
+
+/* DMIN1, DMIN2, DN, DN1, DN2, G, TAU (input/output) DOUBLE PRECISION */
+/* These are passed as arguments in order to save their values */
+/* between calls to DLASQ3. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Function .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --z__;
+
+ /* Function Body */
+ n0in = *n0;
+ eps = dlamch_("Precision");
+ tol = eps * 100.;
+/* Computing 2nd power */
+ d__1 = tol;
+ tol2 = d__1 * d__1;
+
+/* Check for deflation. */
+
+L10:
+
+ if (*n0 < *i0) {
+ return 0;
+ }
+ if (*n0 == *i0) {
+ goto L20;
+ }
+ nn = (*n0 << 2) + *pp;
+ if (*n0 == *i0 + 1) {
+ goto L40;
+ }
+
+/* Check whether E(N0-1) is negligible, 1 eigenvalue. */
+
+ if (z__[nn - 5] > tol2 * (*sigma + z__[nn - 3]) && z__[nn - (*pp << 1) -
+ 4] > tol2 * z__[nn - 7]) {
+ goto L30;
+ }
+
+L20:
+
+ z__[(*n0 << 2) - 3] = z__[(*n0 << 2) + *pp - 3] + *sigma;
+ --(*n0);
+ goto L10;
+
+/* Check whether E(N0-2) is negligible, 2 eigenvalues. */
+
+L30:
+
+ if (z__[nn - 9] > tol2 * *sigma && z__[nn - (*pp << 1) - 8] > tol2 * z__[
+ nn - 11]) {
+ goto L50;
+ }
+
+L40:
+
+ if (z__[nn - 3] > z__[nn - 7]) {
+ s = z__[nn - 3];
+ z__[nn - 3] = z__[nn - 7];
+ z__[nn - 7] = s;
+ }
+ if (z__[nn - 5] > z__[nn - 3] * tol2) {
+ t = (z__[nn - 7] - z__[nn - 3] + z__[nn - 5]) * .5;
+ s = z__[nn - 3] * (z__[nn - 5] / t);
+ if (s <= t) {
+ s = z__[nn - 3] * (z__[nn - 5] / (t * (sqrt(s / t + 1.) + 1.)));
+ } else {
+ s = z__[nn - 3] * (z__[nn - 5] / (t + sqrt(t) * sqrt(t + s)));
+ }
+ t = z__[nn - 7] + (s + z__[nn - 5]);
+ z__[nn - 3] *= z__[nn - 7] / t;
+ z__[nn - 7] = t;
+ }
+ z__[(*n0 << 2) - 7] = z__[nn - 7] + *sigma;
+ z__[(*n0 << 2) - 3] = z__[nn - 3] + *sigma;
+ *n0 += -2;
+ goto L10;
+
+L50:
+ if (*pp == 2) {
+ *pp = 0;
+ }
+
+/* Reverse the qd-array, if warranted. */
+
+ if (*dmin__ <= 0. || *n0 < n0in) {
+ if (z__[(*i0 << 2) + *pp - 3] * 1.5 < z__[(*n0 << 2) + *pp - 3]) {
+ ipn4 = *i0 + *n0 << 2;
+ i__1 = *i0 + *n0 - 1 << 1;
+ for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
+ temp = z__[j4 - 3];
+ z__[j4 - 3] = z__[ipn4 - j4 - 3];
+ z__[ipn4 - j4 - 3] = temp;
+ temp = z__[j4 - 2];
+ z__[j4 - 2] = z__[ipn4 - j4 - 2];
+ z__[ipn4 - j4 - 2] = temp;
+ temp = z__[j4 - 1];
+ z__[j4 - 1] = z__[ipn4 - j4 - 5];
+ z__[ipn4 - j4 - 5] = temp;
+ temp = z__[j4];
+ z__[j4] = z__[ipn4 - j4 - 4];
+ z__[ipn4 - j4 - 4] = temp;
+/* L60: */
+ }
+ if (*n0 - *i0 <= 4) {
+ z__[(*n0 << 2) + *pp - 1] = z__[(*i0 << 2) + *pp - 1];
+ z__[(*n0 << 2) - *pp] = z__[(*i0 << 2) - *pp];
+ }
+/* Computing MIN */
+ d__1 = *dmin2, d__2 = z__[(*n0 << 2) + *pp - 1];
+ *dmin2 = min(d__1,d__2);
+/* Computing MIN */
+ d__1 = z__[(*n0 << 2) + *pp - 1], d__2 = z__[(*i0 << 2) + *pp - 1]
+ , d__1 = min(d__1,d__2), d__2 = z__[(*i0 << 2) + *pp + 3];
+ z__[(*n0 << 2) + *pp - 1] = min(d__1,d__2);
+/* Computing MIN */
+ d__1 = z__[(*n0 << 2) - *pp], d__2 = z__[(*i0 << 2) - *pp], d__1 =
+ min(d__1,d__2), d__2 = z__[(*i0 << 2) - *pp + 4];
+ z__[(*n0 << 2) - *pp] = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = *qmax, d__2 = z__[(*i0 << 2) + *pp - 3], d__1 = max(d__1,
+ d__2), d__2 = z__[(*i0 << 2) + *pp + 1];
+ *qmax = max(d__1,d__2);
+ *dmin__ = -0.;
+ }
+ }
+
+/* Choose a shift. */
+
+ dlasq4_(i0, n0, &z__[1], pp, &n0in, dmin__, dmin1, dmin2, dn, dn1, dn2,
+ tau, ttype, g);
+
+/* Call dqds until DMIN > 0. */
+
+L70:
+
+ dlasq5_(i0, n0, &z__[1], pp, tau, dmin__, dmin1, dmin2, dn, dn1, dn2,
+ ieee);
+
+ *ndiv += *n0 - *i0 + 2;
+ ++(*iter);
+
+/* Check status. */
+
+ if (*dmin__ >= 0. && *dmin1 > 0.) {
+
+/* Success. */
+
+ goto L90;
+
+ } else if (*dmin__ < 0. && *dmin1 > 0. && z__[(*n0 - 1 << 2) - *pp] < tol
+ * (*sigma + *dn1) && abs(*dn) < tol * *sigma) {
+
+/* Convergence hidden by negative DN. */
+
+ z__[(*n0 - 1 << 2) - *pp + 2] = 0.;
+ *dmin__ = 0.;
+ goto L90;
+ } else if (*dmin__ < 0.) {
+
+/* TAU too big. Select new TAU and try again. */
+
+ ++(*nfail);
+ if (*ttype < -22) {
+
+/* Failed twice. Play it safe. */
+
+ *tau = 0.;
+ } else if (*dmin1 > 0.) {
+
+/* Late failure. Gives excellent shift. */
+
+ *tau = (*tau + *dmin__) * (1. - eps * 2.);
+ *ttype += -11;
+ } else {
+
+/* Early failure. Divide by 4. */
+
+ *tau *= .25;
+ *ttype += -12;
+ }
+ goto L70;
+ } else if (disnan_(dmin__)) {
+
+/* NaN. */
+
+ if (*tau == 0.) {
+ goto L80;
+ } else {
+ *tau = 0.;
+ goto L70;
+ }
+ } else {
+
+/* Possible underflow. Play it safe. */
+
+ goto L80;
+ }
+
+/* Risk of underflow. */
+
+L80:
+ dlasq6_(i0, n0, &z__[1], pp, dmin__, dmin1, dmin2, dn, dn1, dn2);
+ *ndiv += *n0 - *i0 + 2;
+ ++(*iter);
+ *tau = 0.;
+
+L90:
+ if (*tau < *sigma) {
+ *desig += *tau;
+ t = *sigma + *desig;
+ *desig -= t - *sigma;
+ } else {
+ t = *sigma + *tau;
+ *desig = *sigma - (t - *tau) + *desig;
+ }
+ *sigma = t;
+
+ return 0;
+
+/* End of DLASQ3 */
+
+} /* dlasq3_ */
diff --git a/SRC/dlasq4.c b/SRC/dlasq4.c
new file mode 100644
index 0000000..333a1d2
--- /dev/null
+++ b/SRC/dlasq4.c
@@ -0,0 +1,403 @@
+/* dlasq4.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlasq4_(integer *i0, integer *n0, doublereal *z__,
+ integer *pp, integer *n0in, doublereal *dmin__, doublereal *dmin1,
+ doublereal *dmin2, doublereal *dn, doublereal *dn1, doublereal *dn2,
+ doublereal *tau, integer *ttype, doublereal *g)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal s, a2, b1, b2;
+ integer i4, nn, np;
+ doublereal gam, gap1, gap2;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
+/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
+/* -- Berkeley -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASQ4 computes an approximation TAU to the smallest eigenvalue */
+/* using values of d from the previous transform. */
+
+/* I0 (input) INTEGER */
+/* First index. */
+
+/* N0 (input) INTEGER */
+/* Last index. */
+
+/* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) */
+/* Z holds the qd array. */
+
+/* PP (input) INTEGER */
+/* PP=0 for ping, PP=1 for pong. */
+
+/* NOIN (input) INTEGER */
+/* The value of N0 at start of EIGTEST. */
+
+/* DMIN (input) DOUBLE PRECISION */
+/* Minimum value of d. */
+
+/* DMIN1 (input) DOUBLE PRECISION */
+/* Minimum value of d, excluding D( N0 ). */
+
+/* DMIN2 (input) DOUBLE PRECISION */
+/* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */
+
+/* DN (input) DOUBLE PRECISION */
+/* d(N) */
+
+/* DN1 (input) DOUBLE PRECISION */
+/* d(N-1) */
+
+/* DN2 (input) DOUBLE PRECISION */
+/* d(N-2) */
+
+/* TAU (output) DOUBLE PRECISION */
+/* This is the shift. */
+
+/* TTYPE (output) INTEGER */
+/* Shift type. */
+
+/* G (input/output) REAL */
+/* G is passed as an argument in order to save its value between */
+/* calls to DLASQ4. */
+
+/* Further Details */
+/* =============== */
+/* CNST1 = 9/16 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* A negative DMIN forces the shift to take that absolute value */
+/* TTYPE records the type of shift. */
+
+ /* Parameter adjustments */
+ --z__;
+
+ /* Function Body */
+ if (*dmin__ <= 0.) {
+ *tau = -(*dmin__);
+ *ttype = -1;
+ return 0;
+ }
+
+ nn = (*n0 << 2) + *pp;
+ if (*n0in == *n0) {
+
+/* No eigenvalues deflated. */
+
+ if (*dmin__ == *dn || *dmin__ == *dn1) {
+
+ b1 = sqrt(z__[nn - 3]) * sqrt(z__[nn - 5]);
+ b2 = sqrt(z__[nn - 7]) * sqrt(z__[nn - 9]);
+ a2 = z__[nn - 7] + z__[nn - 5];
+
+/* Cases 2 and 3. */
+
+ if (*dmin__ == *dn && *dmin1 == *dn1) {
+ gap2 = *dmin2 - a2 - *dmin2 * .25;
+ if (gap2 > 0. && gap2 > b2) {
+ gap1 = a2 - *dn - b2 / gap2 * b2;
+ } else {
+ gap1 = a2 - *dn - (b1 + b2);
+ }
+ if (gap1 > 0. && gap1 > b1) {
+/* Computing MAX */
+ d__1 = *dn - b1 / gap1 * b1, d__2 = *dmin__ * .5;
+ s = max(d__1,d__2);
+ *ttype = -2;
+ } else {
+ s = 0.;
+ if (*dn > b1) {
+ s = *dn - b1;
+ }
+ if (a2 > b1 + b2) {
+/* Computing MIN */
+ d__1 = s, d__2 = a2 - (b1 + b2);
+ s = min(d__1,d__2);
+ }
+/* Computing MAX */
+ d__1 = s, d__2 = *dmin__ * .333;
+ s = max(d__1,d__2);
+ *ttype = -3;
+ }
+ } else {
+
+/* Case 4. */
+
+ *ttype = -4;
+ s = *dmin__ * .25;
+ if (*dmin__ == *dn) {
+ gam = *dn;
+ a2 = 0.;
+ if (z__[nn - 5] > z__[nn - 7]) {
+ return 0;
+ }
+ b2 = z__[nn - 5] / z__[nn - 7];
+ np = nn - 9;
+ } else {
+ np = nn - (*pp << 1);
+ b2 = z__[np - 2];
+ gam = *dn1;
+ if (z__[np - 4] > z__[np - 2]) {
+ return 0;
+ }
+ a2 = z__[np - 4] / z__[np - 2];
+ if (z__[nn - 9] > z__[nn - 11]) {
+ return 0;
+ }
+ b2 = z__[nn - 9] / z__[nn - 11];
+ np = nn - 13;
+ }
+
+/* Approximate contribution to norm squared from I < NN-1. */
+
+ a2 += b2;
+ i__1 = (*i0 << 2) - 1 + *pp;
+ for (i4 = np; i4 >= i__1; i4 += -4) {
+ if (b2 == 0.) {
+ goto L20;
+ }
+ b1 = b2;
+ if (z__[i4] > z__[i4 - 2]) {
+ return 0;
+ }
+ b2 *= z__[i4] / z__[i4 - 2];
+ a2 += b2;
+ if (max(b2,b1) * 100. < a2 || .563 < a2) {
+ goto L20;
+ }
+/* L10: */
+ }
+L20:
+ a2 *= 1.05;
+
+/* Rayleigh quotient residual bound. */
+
+ if (a2 < .563) {
+ s = gam * (1. - sqrt(a2)) / (a2 + 1.);
+ }
+ }
+ } else if (*dmin__ == *dn2) {
+
+/* Case 5. */
+
+ *ttype = -5;
+ s = *dmin__ * .25;
+
+/* Compute contribution to norm squared from I > NN-2. */
+
+ np = nn - (*pp << 1);
+ b1 = z__[np - 2];
+ b2 = z__[np - 6];
+ gam = *dn2;
+ if (z__[np - 8] > b2 || z__[np - 4] > b1) {
+ return 0;
+ }
+ a2 = z__[np - 8] / b2 * (z__[np - 4] / b1 + 1.);
+
+/* Approximate contribution to norm squared from I < NN-2. */
+
+ if (*n0 - *i0 > 2) {
+ b2 = z__[nn - 13] / z__[nn - 15];
+ a2 += b2;
+ i__1 = (*i0 << 2) - 1 + *pp;
+ for (i4 = nn - 17; i4 >= i__1; i4 += -4) {
+ if (b2 == 0.) {
+ goto L40;
+ }
+ b1 = b2;
+ if (z__[i4] > z__[i4 - 2]) {
+ return 0;
+ }
+ b2 *= z__[i4] / z__[i4 - 2];
+ a2 += b2;
+ if (max(b2,b1) * 100. < a2 || .563 < a2) {
+ goto L40;
+ }
+/* L30: */
+ }
+L40:
+ a2 *= 1.05;
+ }
+
+ if (a2 < .563) {
+ s = gam * (1. - sqrt(a2)) / (a2 + 1.);
+ }
+ } else {
+
+/* Case 6, no information to guide us. */
+
+ if (*ttype == -6) {
+ *g += (1. - *g) * .333;
+ } else if (*ttype == -18) {
+ *g = .083250000000000005;
+ } else {
+ *g = .25;
+ }
+ s = *g * *dmin__;
+ *ttype = -6;
+ }
+
+ } else if (*n0in == *n0 + 1) {
+
+/* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. */
+
+ if (*dmin1 == *dn1 && *dmin2 == *dn2) {
+
+/* Cases 7 and 8. */
+
+ *ttype = -7;
+ s = *dmin1 * .333;
+ if (z__[nn - 5] > z__[nn - 7]) {
+ return 0;
+ }
+ b1 = z__[nn - 5] / z__[nn - 7];
+ b2 = b1;
+ if (b2 == 0.) {
+ goto L60;
+ }
+ i__1 = (*i0 << 2) - 1 + *pp;
+ for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) {
+ a2 = b1;
+ if (z__[i4] > z__[i4 - 2]) {
+ return 0;
+ }
+ b1 *= z__[i4] / z__[i4 - 2];
+ b2 += b1;
+ if (max(b1,a2) * 100. < b2) {
+ goto L60;
+ }
+/* L50: */
+ }
+L60:
+ b2 = sqrt(b2 * 1.05);
+/* Computing 2nd power */
+ d__1 = b2;
+ a2 = *dmin1 / (d__1 * d__1 + 1.);
+ gap2 = *dmin2 * .5 - a2;
+ if (gap2 > 0. && gap2 > b2 * a2) {
+/* Computing MAX */
+ d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2);
+ s = max(d__1,d__2);
+ } else {
+/* Computing MAX */
+ d__1 = s, d__2 = a2 * (1. - b2 * 1.01);
+ s = max(d__1,d__2);
+ *ttype = -8;
+ }
+ } else {
+
+/* Case 9. */
+
+ s = *dmin1 * .25;
+ if (*dmin1 == *dn1) {
+ s = *dmin1 * .5;
+ }
+ *ttype = -9;
+ }
+
+ } else if (*n0in == *n0 + 2) {
+
+/* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. */
+
+/* Cases 10 and 11. */
+
+ if (*dmin2 == *dn2 && z__[nn - 5] * 2. < z__[nn - 7]) {
+ *ttype = -10;
+ s = *dmin2 * .333;
+ if (z__[nn - 5] > z__[nn - 7]) {
+ return 0;
+ }
+ b1 = z__[nn - 5] / z__[nn - 7];
+ b2 = b1;
+ if (b2 == 0.) {
+ goto L80;
+ }
+ i__1 = (*i0 << 2) - 1 + *pp;
+ for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) {
+ if (z__[i4] > z__[i4 - 2]) {
+ return 0;
+ }
+ b1 *= z__[i4] / z__[i4 - 2];
+ b2 += b1;
+ if (b1 * 100. < b2) {
+ goto L80;
+ }
+/* L70: */
+ }
+L80:
+ b2 = sqrt(b2 * 1.05);
+/* Computing 2nd power */
+ d__1 = b2;
+ a2 = *dmin2 / (d__1 * d__1 + 1.);
+ gap2 = z__[nn - 7] + z__[nn - 9] - sqrt(z__[nn - 11]) * sqrt(z__[
+ nn - 9]) - a2;
+ if (gap2 > 0. && gap2 > b2 * a2) {
+/* Computing MAX */
+ d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2);
+ s = max(d__1,d__2);
+ } else {
+/* Computing MAX */
+ d__1 = s, d__2 = a2 * (1. - b2 * 1.01);
+ s = max(d__1,d__2);
+ }
+ } else {
+ s = *dmin2 * .25;
+ *ttype = -11;
+ }
+ } else if (*n0in > *n0 + 2) {
+
+/* Case 12, more than two eigenvalues deflated. No information. */
+
+ s = 0.;
+ *ttype = -12;
+ }
+
+ *tau = s;
+ return 0;
+
+/* End of DLASQ4 */
+
+} /* dlasq4_ */
diff --git a/SRC/dlasq5.c b/SRC/dlasq5.c
new file mode 100644
index 0000000..df306bd
--- /dev/null
+++ b/SRC/dlasq5.c
@@ -0,0 +1,240 @@
+/* dlasq5.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlasq5_(integer *i0, integer *n0, doublereal *z__,
+ integer *pp, doublereal *tau, doublereal *dmin__, doublereal *dmin1,
+ doublereal *dmin2, doublereal *dn, doublereal *dnm1, doublereal *dnm2,
+ logical *ieee)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ doublereal d__;
+ integer j4, j4p2;
+ doublereal emin, temp;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
+/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
+/* -- Berkeley -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASQ5 computes one dqds transform in ping-pong form, one */
+/* version for IEEE machines another for non IEEE machines. */
+
+/* Arguments */
+/* ========= */
+
+/* I0 (input) INTEGER */
+/* First index. */
+
+/* N0 (input) INTEGER */
+/* Last index. */
+
+/* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) */
+/* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid */
+/* an extra argument. */
+
+/* PP (input) INTEGER */
+/* PP=0 for ping, PP=1 for pong. */
+
+/* TAU (input) DOUBLE PRECISION */
+/* This is the shift. */
+
+/* DMIN (output) DOUBLE PRECISION */
+/* Minimum value of d. */
+
+/* DMIN1 (output) DOUBLE PRECISION */
+/* Minimum value of d, excluding D( N0 ). */
+
+/* DMIN2 (output) DOUBLE PRECISION */
+/* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */
+
+/* DN (output) DOUBLE PRECISION */
+/* d(N0), the last value of d. */
+
+/* DNM1 (output) DOUBLE PRECISION */
+/* d(N0-1). */
+
+/* DNM2 (output) DOUBLE PRECISION */
+/* d(N0-2). */
+
+/* IEEE (input) LOGICAL */
+/* Flag for IEEE or non IEEE arithmetic. */
+
+/* ===================================================================== */
+
+/* .. Parameter .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --z__;
+
+ /* Function Body */
+ if (*n0 - *i0 - 1 <= 0) {
+ return 0;
+ }
+
+ j4 = (*i0 << 2) + *pp - 3;
+ emin = z__[j4 + 4];
+ d__ = z__[j4] - *tau;
+ *dmin__ = d__;
+ *dmin1 = -z__[j4];
+
+ if (*ieee) {
+
+/* Code for IEEE arithmetic. */
+
+ if (*pp == 0) {
+ i__1 = *n0 - 3 << 2;
+ for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
+ z__[j4 - 2] = d__ + z__[j4 - 1];
+ temp = z__[j4 + 1] / z__[j4 - 2];
+ d__ = d__ * temp - *tau;
+ *dmin__ = min(*dmin__,d__);
+ z__[j4] = z__[j4 - 1] * temp;
+/* Computing MIN */
+ d__1 = z__[j4];
+ emin = min(d__1,emin);
+/* L10: */
+ }
+ } else {
+ i__1 = *n0 - 3 << 2;
+ for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
+ z__[j4 - 3] = d__ + z__[j4];
+ temp = z__[j4 + 2] / z__[j4 - 3];
+ d__ = d__ * temp - *tau;
+ *dmin__ = min(*dmin__,d__);
+ z__[j4 - 1] = z__[j4] * temp;
+/* Computing MIN */
+ d__1 = z__[j4 - 1];
+ emin = min(d__1,emin);
+/* L20: */
+ }
+ }
+
+/* Unroll last two steps. */
+
+ *dnm2 = d__;
+ *dmin2 = *dmin__;
+ j4 = (*n0 - 2 << 2) - *pp;
+ j4p2 = j4 + (*pp << 1) - 1;
+ z__[j4 - 2] = *dnm2 + z__[j4p2];
+ z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
+ *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau;
+ *dmin__ = min(*dmin__,*dnm1);
+
+ *dmin1 = *dmin__;
+ j4 += 4;
+ j4p2 = j4 + (*pp << 1) - 1;
+ z__[j4 - 2] = *dnm1 + z__[j4p2];
+ z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
+ *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau;
+ *dmin__ = min(*dmin__,*dn);
+
+ } else {
+
+/* Code for non IEEE arithmetic. */
+
+ if (*pp == 0) {
+ i__1 = *n0 - 3 << 2;
+ for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
+ z__[j4 - 2] = d__ + z__[j4 - 1];
+ if (d__ < 0.) {
+ return 0;
+ } else {
+ z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]);
+ d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]) - *tau;
+ }
+ *dmin__ = min(*dmin__,d__);
+/* Computing MIN */
+ d__1 = emin, d__2 = z__[j4];
+ emin = min(d__1,d__2);
+/* L30: */
+ }
+ } else {
+ i__1 = *n0 - 3 << 2;
+ for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
+ z__[j4 - 3] = d__ + z__[j4];
+ if (d__ < 0.) {
+ return 0;
+ } else {
+ z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]);
+ d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]) - *tau;
+ }
+ *dmin__ = min(*dmin__,d__);
+/* Computing MIN */
+ d__1 = emin, d__2 = z__[j4 - 1];
+ emin = min(d__1,d__2);
+/* L40: */
+ }
+ }
+
+/* Unroll last two steps. */
+
+ *dnm2 = d__;
+ *dmin2 = *dmin__;
+ j4 = (*n0 - 2 << 2) - *pp;
+ j4p2 = j4 + (*pp << 1) - 1;
+ z__[j4 - 2] = *dnm2 + z__[j4p2];
+ if (*dnm2 < 0.) {
+ return 0;
+ } else {
+ z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
+ *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau;
+ }
+ *dmin__ = min(*dmin__,*dnm1);
+
+ *dmin1 = *dmin__;
+ j4 += 4;
+ j4p2 = j4 + (*pp << 1) - 1;
+ z__[j4 - 2] = *dnm1 + z__[j4p2];
+ if (*dnm1 < 0.) {
+ return 0;
+ } else {
+ z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
+ *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau;
+ }
+ *dmin__ = min(*dmin__,*dn);
+
+ }
+
+ z__[j4 + 2] = *dn;
+ z__[(*n0 << 2) - *pp] = emin;
+ return 0;
+
+/* End of DLASQ5 */
+
+} /* dlasq5_ */
diff --git a/SRC/dlasq6.c b/SRC/dlasq6.c
new file mode 100644
index 0000000..22d809f
--- /dev/null
+++ b/SRC/dlasq6.c
@@ -0,0 +1,212 @@
+/* dlasq6.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlasq6_(integer *i0, integer *n0, doublereal *z__,
+ integer *pp, doublereal *dmin__, doublereal *dmin1, doublereal *dmin2,
+ doublereal *dn, doublereal *dnm1, doublereal *dnm2)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ doublereal d__;
+ integer j4, j4p2;
+ doublereal emin, temp;
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
+/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
+/* -- Berkeley -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASQ6 computes one dqd (shift equal to zero) transform in */
+/* ping-pong form, with protection against underflow and overflow. */
+
+/* Arguments */
+/* ========= */
+
+/* I0 (input) INTEGER */
+/* First index. */
+
+/* N0 (input) INTEGER */
+/* Last index. */
+
+/* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) */
+/* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid */
+/* an extra argument. */
+
+/* PP (input) INTEGER */
+/* PP=0 for ping, PP=1 for pong. */
+
+/* DMIN (output) DOUBLE PRECISION */
+/* Minimum value of d. */
+
+/* DMIN1 (output) DOUBLE PRECISION */
+/* Minimum value of d, excluding D( N0 ). */
+
+/* DMIN2 (output) DOUBLE PRECISION */
+/* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */
+
+/* DN (output) DOUBLE PRECISION */
+/* d(N0), the last value of d. */
+
+/* DNM1 (output) DOUBLE PRECISION */
+/* d(N0-1). */
+
+/* DNM2 (output) DOUBLE PRECISION */
+/* d(N0-2). */
+
+/* ===================================================================== */
+
+/* .. Parameter .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Function .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --z__;
+
+ /* Function Body */
+ if (*n0 - *i0 - 1 <= 0) {
+ return 0;
+ }
+
+ safmin = dlamch_("Safe minimum");
+ j4 = (*i0 << 2) + *pp - 3;
+ emin = z__[j4 + 4];
+ d__ = z__[j4];
+ *dmin__ = d__;
+
+ if (*pp == 0) {
+ i__1 = *n0 - 3 << 2;
+ for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
+ z__[j4 - 2] = d__ + z__[j4 - 1];
+ if (z__[j4 - 2] == 0.) {
+ z__[j4] = 0.;
+ d__ = z__[j4 + 1];
+ *dmin__ = d__;
+ emin = 0.;
+ } else if (safmin * z__[j4 + 1] < z__[j4 - 2] && safmin * z__[j4
+ - 2] < z__[j4 + 1]) {
+ temp = z__[j4 + 1] / z__[j4 - 2];
+ z__[j4] = z__[j4 - 1] * temp;
+ d__ *= temp;
+ } else {
+ z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]);
+ d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]);
+ }
+ *dmin__ = min(*dmin__,d__);
+/* Computing MIN */
+ d__1 = emin, d__2 = z__[j4];
+ emin = min(d__1,d__2);
+/* L10: */
+ }
+ } else {
+ i__1 = *n0 - 3 << 2;
+ for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
+ z__[j4 - 3] = d__ + z__[j4];
+ if (z__[j4 - 3] == 0.) {
+ z__[j4 - 1] = 0.;
+ d__ = z__[j4 + 2];
+ *dmin__ = d__;
+ emin = 0.;
+ } else if (safmin * z__[j4 + 2] < z__[j4 - 3] && safmin * z__[j4
+ - 3] < z__[j4 + 2]) {
+ temp = z__[j4 + 2] / z__[j4 - 3];
+ z__[j4 - 1] = z__[j4] * temp;
+ d__ *= temp;
+ } else {
+ z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]);
+ d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]);
+ }
+ *dmin__ = min(*dmin__,d__);
+/* Computing MIN */
+ d__1 = emin, d__2 = z__[j4 - 1];
+ emin = min(d__1,d__2);
+/* L20: */
+ }
+ }
+
+/* Unroll last two steps. */
+
+ *dnm2 = d__;
+ *dmin2 = *dmin__;
+ j4 = (*n0 - 2 << 2) - *pp;
+ j4p2 = j4 + (*pp << 1) - 1;
+ z__[j4 - 2] = *dnm2 + z__[j4p2];
+ if (z__[j4 - 2] == 0.) {
+ z__[j4] = 0.;
+ *dnm1 = z__[j4p2 + 2];
+ *dmin__ = *dnm1;
+ emin = 0.;
+ } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] <
+ z__[j4p2 + 2]) {
+ temp = z__[j4p2 + 2] / z__[j4 - 2];
+ z__[j4] = z__[j4p2] * temp;
+ *dnm1 = *dnm2 * temp;
+ } else {
+ z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
+ *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]);
+ }
+ *dmin__ = min(*dmin__,*dnm1);
+
+ *dmin1 = *dmin__;
+ j4 += 4;
+ j4p2 = j4 + (*pp << 1) - 1;
+ z__[j4 - 2] = *dnm1 + z__[j4p2];
+ if (z__[j4 - 2] == 0.) {
+ z__[j4] = 0.;
+ *dn = z__[j4p2 + 2];
+ *dmin__ = *dn;
+ emin = 0.;
+ } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] <
+ z__[j4p2 + 2]) {
+ temp = z__[j4p2 + 2] / z__[j4 - 2];
+ z__[j4] = z__[j4p2] * temp;
+ *dn = *dnm1 * temp;
+ } else {
+ z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
+ *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]);
+ }
+ *dmin__ = min(*dmin__,*dn);
+
+ z__[j4 + 2] = *dn;
+ z__[(*n0 << 2) - *pp] = emin;
+ return 0;
+
+/* End of DLASQ6 */
+
+} /* dlasq6_ */
diff --git a/SRC/dlasr.c b/SRC/dlasr.c
new file mode 100644
index 0000000..6abfa81
--- /dev/null
+++ b/SRC/dlasr.c
@@ -0,0 +1,453 @@
+/* dlasr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlasr_(char *side, char *pivot, char *direct, integer *m,
+ integer *n, doublereal *c__, doublereal *s, doublereal *a, integer *
+ lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, info;
+ doublereal temp;
+ extern logical lsame_(char *, char *);
+ doublereal ctemp, stemp;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASR applies a sequence of plane rotations to a real matrix A, */
+/* from either the left or the right. */
+
+/* When SIDE = 'L', the transformation takes the form */
+
+/* A := P*A */
+
+/* and when SIDE = 'R', the transformation takes the form */
+
+/* A := A*P**T */
+
+/* where P is an orthogonal matrix consisting of a sequence of z plane */
+/* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', */
+/* and P**T is the transpose of P. */
+
+/* When DIRECT = 'F' (Forward sequence), then */
+
+/* P = P(z-1) * ... * P(2) * P(1) */
+
+/* and when DIRECT = 'B' (Backward sequence), then */
+
+/* P = P(1) * P(2) * ... * P(z-1) */
+
+/* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation */
+
+/* R(k) = ( c(k) s(k) ) */
+/* = ( -s(k) c(k) ). */
+
+/* When PIVOT = 'V' (Variable pivot), the rotation is performed */
+/* for the plane (k,k+1), i.e., P(k) has the form */
+
+/* P(k) = ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+/* ( c(k) s(k) ) */
+/* ( -s(k) c(k) ) */
+/* ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+
+/* where R(k) appears as a rank-2 modification to the identity matrix in */
+/* rows and columns k and k+1. */
+
+/* When PIVOT = 'T' (Top pivot), the rotation is performed for the */
+/* plane (1,k+1), so P(k) has the form */
+
+/* P(k) = ( c(k) s(k) ) */
+/* ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+/* ( -s(k) c(k) ) */
+/* ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+
+/* where R(k) appears in rows and columns 1 and k+1. */
+
+/* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is */
+/* performed for the plane (k,z), giving P(k) the form */
+
+/* P(k) = ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+/* ( c(k) s(k) ) */
+/* ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+/* ( -s(k) c(k) ) */
+
+/* where R(k) appears in rows and columns k and z. The rotations are */
+/* performed without ever forming P(k) explicitly. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* Specifies whether the plane rotation matrix P is applied to */
+/* A on the left or the right. */
+/* = 'L': Left, compute A := P*A */
+/* = 'R': Right, compute A:= A*P**T */
+
+/* PIVOT (input) CHARACTER*1 */
+/* Specifies the plane for which P(k) is a plane rotation */
+/* matrix. */
+/* = 'V': Variable pivot, the plane (k,k+1) */
+/* = 'T': Top pivot, the plane (1,k+1) */
+/* = 'B': Bottom pivot, the plane (k,z) */
+
+/* DIRECT (input) CHARACTER*1 */
+/* Specifies whether P is a forward or backward sequence of */
+/* plane rotations. */
+/* = 'F': Forward, P = P(z-1)*...*P(2)*P(1) */
+/* = 'B': Backward, P = P(1)*P(2)*...*P(z-1) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. If m <= 1, an immediate */
+/* return is effected. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. If n <= 1, an */
+/* immediate return is effected. */
+
+/* C (input) DOUBLE PRECISION array, dimension */
+/* (M-1) if SIDE = 'L' */
+/* (N-1) if SIDE = 'R' */
+/* The cosines c(k) of the plane rotations. */
+
+/* S (input) DOUBLE PRECISION array, dimension */
+/* (M-1) if SIDE = 'L' */
+/* (N-1) if SIDE = 'R' */
+/* The sines s(k) of the plane rotations. The 2-by-2 plane */
+/* rotation part of the matrix P(k), R(k), has the form */
+/* R(k) = ( c(k) s(k) ) */
+/* ( -s(k) c(k) ). */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The M-by-N matrix A. On exit, A is overwritten by P*A if */
+/* SIDE = 'R' or by A*P**T if SIDE = 'L'. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ --c__;
+ --s;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ info = 0;
+ if (! (lsame_(side, "L") || lsame_(side, "R"))) {
+ info = 1;
+ } else if (! (lsame_(pivot, "V") || lsame_(pivot,
+ "T") || lsame_(pivot, "B"))) {
+ info = 2;
+ } else if (! (lsame_(direct, "F") || lsame_(direct,
+ "B"))) {
+ info = 3;
+ } else if (*m < 0) {
+ info = 4;
+ } else if (*n < 0) {
+ info = 5;
+ } else if (*lda < max(1,*m)) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("DLASR ", &info);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+ if (lsame_(side, "L")) {
+
+/* Form P * A */
+
+ if (lsame_(pivot, "V")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1. || stemp != 0.) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = a[j + 1 + i__ * a_dim1];
+ a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp *
+ a[j + i__ * a_dim1];
+ a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j
+ + i__ * a_dim1];
+/* L10: */
+ }
+ }
+/* L20: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *m - 1; j >= 1; --j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1. || stemp != 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = a[j + 1 + i__ * a_dim1];
+ a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp *
+ a[j + i__ * a_dim1];
+ a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j
+ + i__ * a_dim1];
+/* L30: */
+ }
+ }
+/* L40: */
+ }
+ }
+ } else if (lsame_(pivot, "T")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *m;
+ for (j = 2; j <= i__1; ++j) {
+ ctemp = c__[j - 1];
+ stemp = s[j - 1];
+ if (ctemp != 1. || stemp != 0.) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = a[j + i__ * a_dim1];
+ a[j + i__ * a_dim1] = ctemp * temp - stemp * a[
+ i__ * a_dim1 + 1];
+ a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[
+ i__ * a_dim1 + 1];
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *m; j >= 2; --j) {
+ ctemp = c__[j - 1];
+ stemp = s[j - 1];
+ if (ctemp != 1. || stemp != 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = a[j + i__ * a_dim1];
+ a[j + i__ * a_dim1] = ctemp * temp - stemp * a[
+ i__ * a_dim1 + 1];
+ a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[
+ i__ * a_dim1 + 1];
+/* L70: */
+ }
+ }
+/* L80: */
+ }
+ }
+ } else if (lsame_(pivot, "B")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1. || stemp != 0.) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = a[j + i__ * a_dim1];
+ a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1]
+ + ctemp * temp;
+ a[*m + i__ * a_dim1] = ctemp * a[*m + i__ *
+ a_dim1] - stemp * temp;
+/* L90: */
+ }
+ }
+/* L100: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *m - 1; j >= 1; --j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1. || stemp != 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = a[j + i__ * a_dim1];
+ a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1]
+ + ctemp * temp;
+ a[*m + i__ * a_dim1] = ctemp * a[*m + i__ *
+ a_dim1] - stemp * temp;
+/* L110: */
+ }
+ }
+/* L120: */
+ }
+ }
+ }
+ } else if (lsame_(side, "R")) {
+
+/* Form A * P' */
+
+ if (lsame_(pivot, "V")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1. || stemp != 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = a[i__ + (j + 1) * a_dim1];
+ a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp *
+ a[i__ + j * a_dim1];
+ a[i__ + j * a_dim1] = stemp * temp + ctemp * a[
+ i__ + j * a_dim1];
+/* L130: */
+ }
+ }
+/* L140: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *n - 1; j >= 1; --j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1. || stemp != 0.) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = a[i__ + (j + 1) * a_dim1];
+ a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp *
+ a[i__ + j * a_dim1];
+ a[i__ + j * a_dim1] = stemp * temp + ctemp * a[
+ i__ + j * a_dim1];
+/* L150: */
+ }
+ }
+/* L160: */
+ }
+ }
+ } else if (lsame_(pivot, "T")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ ctemp = c__[j - 1];
+ stemp = s[j - 1];
+ if (ctemp != 1. || stemp != 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = a[i__ + j * a_dim1];
+ a[i__ + j * a_dim1] = ctemp * temp - stemp * a[
+ i__ + a_dim1];
+ a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ +
+ a_dim1];
+/* L170: */
+ }
+ }
+/* L180: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *n; j >= 2; --j) {
+ ctemp = c__[j - 1];
+ stemp = s[j - 1];
+ if (ctemp != 1. || stemp != 0.) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = a[i__ + j * a_dim1];
+ a[i__ + j * a_dim1] = ctemp * temp - stemp * a[
+ i__ + a_dim1];
+ a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ +
+ a_dim1];
+/* L190: */
+ }
+ }
+/* L200: */
+ }
+ }
+ } else if (lsame_(pivot, "B")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1. || stemp != 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = a[i__ + j * a_dim1];
+ a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1]
+ + ctemp * temp;
+ a[i__ + *n * a_dim1] = ctemp * a[i__ + *n *
+ a_dim1] - stemp * temp;
+/* L210: */
+ }
+ }
+/* L220: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *n - 1; j >= 1; --j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1. || stemp != 0.) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = a[i__ + j * a_dim1];
+ a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1]
+ + ctemp * temp;
+ a[i__ + *n * a_dim1] = ctemp * a[i__ + *n *
+ a_dim1] - stemp * temp;
+/* L230: */
+ }
+ }
+/* L240: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DLASR */
+
+} /* dlasr_ */
diff --git a/SRC/dlasrt.c b/SRC/dlasrt.c
new file mode 100644
index 0000000..5df285c
--- /dev/null
+++ b/SRC/dlasrt.c
@@ -0,0 +1,286 @@
+/* dlasrt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlasrt_(char *id, integer *n, doublereal *d__, integer *
+ info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal d1, d2, d3;
+ integer dir;
+ doublereal tmp;
+ integer endd;
+ extern logical lsame_(char *, char *);
+ integer stack[64] /* was [2][32] */;
+ doublereal dmnmx;
+ integer start;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer stkpnt;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Sort the numbers in D in increasing order (if ID = 'I') or */
+/* in decreasing order (if ID = 'D' ). */
+
+/* Use Quick Sort, reverting to Insertion sort on arrays of */
+/* size <= 20. Dimension of STACK limits N to about 2**32. */
+
+/* Arguments */
+/* ========= */
+
+/* ID (input) CHARACTER*1 */
+/* = 'I': sort D in increasing order; */
+/* = 'D': sort D in decreasing order. */
+
+/* N (input) INTEGER */
+/* The length of the array D. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the array to be sorted. */
+/* On exit, D has been sorted into increasing order */
+/* (D(1) <= ... <= D(N) ) or into decreasing order */
+/* (D(1) >= ... >= D(N) ), depending on ID. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input paramters. */
+
+ /* Parameter adjustments */
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+ dir = -1;
+ if (lsame_(id, "D")) {
+ dir = 0;
+ } else if (lsame_(id, "I")) {
+ dir = 1;
+ }
+ if (dir == -1) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLASRT", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 1) {
+ return 0;
+ }
+
+ stkpnt = 1;
+ stack[0] = 1;
+ stack[1] = *n;
+L10:
+ start = stack[(stkpnt << 1) - 2];
+ endd = stack[(stkpnt << 1) - 1];
+ --stkpnt;
+ if (endd - start <= 20 && endd - start > 0) {
+
+/* Do Insertion sort on D( START:ENDD ) */
+
+ if (dir == 0) {
+
+/* Sort into decreasing order */
+
+ i__1 = endd;
+ for (i__ = start + 1; i__ <= i__1; ++i__) {
+ i__2 = start + 1;
+ for (j = i__; j >= i__2; --j) {
+ if (d__[j] > d__[j - 1]) {
+ dmnmx = d__[j];
+ d__[j] = d__[j - 1];
+ d__[j - 1] = dmnmx;
+ } else {
+ goto L30;
+ }
+/* L20: */
+ }
+L30:
+ ;
+ }
+
+ } else {
+
+/* Sort into increasing order */
+
+ i__1 = endd;
+ for (i__ = start + 1; i__ <= i__1; ++i__) {
+ i__2 = start + 1;
+ for (j = i__; j >= i__2; --j) {
+ if (d__[j] < d__[j - 1]) {
+ dmnmx = d__[j];
+ d__[j] = d__[j - 1];
+ d__[j - 1] = dmnmx;
+ } else {
+ goto L50;
+ }
+/* L40: */
+ }
+L50:
+ ;
+ }
+
+ }
+
+ } else if (endd - start > 20) {
+
+/* Partition D( START:ENDD ) and stack parts, largest one first */
+
+/* Choose partition entry as median of 3 */
+
+ d1 = d__[start];
+ d2 = d__[endd];
+ i__ = (start + endd) / 2;
+ d3 = d__[i__];
+ if (d1 < d2) {
+ if (d3 < d1) {
+ dmnmx = d1;
+ } else if (d3 < d2) {
+ dmnmx = d3;
+ } else {
+ dmnmx = d2;
+ }
+ } else {
+ if (d3 < d2) {
+ dmnmx = d2;
+ } else if (d3 < d1) {
+ dmnmx = d3;
+ } else {
+ dmnmx = d1;
+ }
+ }
+
+ if (dir == 0) {
+
+/* Sort into decreasing order */
+
+ i__ = start - 1;
+ j = endd + 1;
+L60:
+L70:
+ --j;
+ if (d__[j] < dmnmx) {
+ goto L70;
+ }
+L80:
+ ++i__;
+ if (d__[i__] > dmnmx) {
+ goto L80;
+ }
+ if (i__ < j) {
+ tmp = d__[i__];
+ d__[i__] = d__[j];
+ d__[j] = tmp;
+ goto L60;
+ }
+ if (j - start > endd - j - 1) {
+ ++stkpnt;
+ stack[(stkpnt << 1) - 2] = start;
+ stack[(stkpnt << 1) - 1] = j;
+ ++stkpnt;
+ stack[(stkpnt << 1) - 2] = j + 1;
+ stack[(stkpnt << 1) - 1] = endd;
+ } else {
+ ++stkpnt;
+ stack[(stkpnt << 1) - 2] = j + 1;
+ stack[(stkpnt << 1) - 1] = endd;
+ ++stkpnt;
+ stack[(stkpnt << 1) - 2] = start;
+ stack[(stkpnt << 1) - 1] = j;
+ }
+ } else {
+
+/* Sort into increasing order */
+
+ i__ = start - 1;
+ j = endd + 1;
+L90:
+L100:
+ --j;
+ if (d__[j] > dmnmx) {
+ goto L100;
+ }
+L110:
+ ++i__;
+ if (d__[i__] < dmnmx) {
+ goto L110;
+ }
+ if (i__ < j) {
+ tmp = d__[i__];
+ d__[i__] = d__[j];
+ d__[j] = tmp;
+ goto L90;
+ }
+ if (j - start > endd - j - 1) {
+ ++stkpnt;
+ stack[(stkpnt << 1) - 2] = start;
+ stack[(stkpnt << 1) - 1] = j;
+ ++stkpnt;
+ stack[(stkpnt << 1) - 2] = j + 1;
+ stack[(stkpnt << 1) - 1] = endd;
+ } else {
+ ++stkpnt;
+ stack[(stkpnt << 1) - 2] = j + 1;
+ stack[(stkpnt << 1) - 1] = endd;
+ ++stkpnt;
+ stack[(stkpnt << 1) - 2] = start;
+ stack[(stkpnt << 1) - 1] = j;
+ }
+ }
+ }
+ if (stkpnt > 0) {
+ goto L10;
+ }
+ return 0;
+
+/* End of DLASRT */
+
+} /* dlasrt_ */
diff --git a/SRC/dlassq.c b/SRC/dlassq.c
new file mode 100644
index 0000000..9b3aee5
--- /dev/null
+++ b/SRC/dlassq.c
@@ -0,0 +1,116 @@
+/* dlassq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlassq_(integer *n, doublereal *x, integer *incx,
+ doublereal *scale, doublereal *sumsq)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1;
+
+ /* Local variables */
+ integer ix;
+ doublereal absxi;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASSQ returns the values scl and smsq such that */
+
+/* ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, */
+
+/* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is */
+/* assumed to be non-negative and scl returns the value */
+
+/* scl = max( scale, abs( x( i ) ) ). */
+
+/* scale and sumsq must be supplied in SCALE and SUMSQ and */
+/* scl and smsq are overwritten on SCALE and SUMSQ respectively. */
+
+/* The routine makes only one pass through the vector x. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of elements to be used from the vector X. */
+
+/* X (input) DOUBLE PRECISION array, dimension (N) */
+/* The vector for which a scaled sum of squares is computed. */
+/* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. */
+
+/* INCX (input) INTEGER */
+/* The increment between successive values of the vector X. */
+/* INCX > 0. */
+
+/* SCALE (input/output) DOUBLE PRECISION */
+/* On entry, the value scale in the equation above. */
+/* On exit, SCALE is overwritten with scl , the scaling factor */
+/* for the sum of squares. */
+
+/* SUMSQ (input/output) DOUBLE PRECISION */
+/* On entry, the value sumsq in the equation above. */
+/* On exit, SUMSQ is overwritten with smsq , the basic sum of */
+/* squares from which scl has been factored out. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --x;
+
+ /* Function Body */
+ if (*n > 0) {
+ i__1 = (*n - 1) * *incx + 1;
+ i__2 = *incx;
+ for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
+ if (x[ix] != 0.) {
+ absxi = (d__1 = x[ix], abs(d__1));
+ if (*scale < absxi) {
+/* Computing 2nd power */
+ d__1 = *scale / absxi;
+ *sumsq = *sumsq * (d__1 * d__1) + 1;
+ *scale = absxi;
+ } else {
+/* Computing 2nd power */
+ d__1 = absxi / *scale;
+ *sumsq += d__1 * d__1;
+ }
+ }
+/* L10: */
+ }
+ }
+ return 0;
+
+/* End of DLASSQ */
+
+} /* dlassq_ */
diff --git a/SRC/dlasv2.c b/SRC/dlasv2.c
new file mode 100644
index 0000000..2418af3
--- /dev/null
+++ b/SRC/dlasv2.c
@@ -0,0 +1,274 @@
+/* dlasv2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b3 = 2.;
+static doublereal c_b4 = 1.;
+
+/* Subroutine */ int dlasv2_(doublereal *f, doublereal *g, doublereal *h__,
+ doublereal *ssmin, doublereal *ssmax, doublereal *snr, doublereal *
+ csr, doublereal *snl, doublereal *csl)
+{
+ /* System generated locals */
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ doublereal a, d__, l, m, r__, s, t, fa, ga, ha, ft, gt, ht, mm, tt, clt,
+ crt, slt, srt;
+ integer pmax;
+ doublereal temp;
+ logical swap;
+ doublereal tsign;
+ extern doublereal dlamch_(char *);
+ logical gasmal;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASV2 computes the singular value decomposition of a 2-by-2 */
+/* triangular matrix */
+/* [ F G ] */
+/* [ 0 H ]. */
+/* On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the */
+/* smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and */
+/* right singular vectors for abs(SSMAX), giving the decomposition */
+
+/* [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] */
+/* [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. */
+
+/* Arguments */
+/* ========= */
+
+/* F (input) DOUBLE PRECISION */
+/* The (1,1) element of the 2-by-2 matrix. */
+
+/* G (input) DOUBLE PRECISION */
+/* The (1,2) element of the 2-by-2 matrix. */
+
+/* H (input) DOUBLE PRECISION */
+/* The (2,2) element of the 2-by-2 matrix. */
+
+/* SSMIN (output) DOUBLE PRECISION */
+/* abs(SSMIN) is the smaller singular value. */
+
+/* SSMAX (output) DOUBLE PRECISION */
+/* abs(SSMAX) is the larger singular value. */
+
+/* SNL (output) DOUBLE PRECISION */
+/* CSL (output) DOUBLE PRECISION */
+/* The vector (CSL, SNL) is a unit left singular vector for the */
+/* singular value abs(SSMAX). */
+
+/* SNR (output) DOUBLE PRECISION */
+/* CSR (output) DOUBLE PRECISION */
+/* The vector (CSR, SNR) is a unit right singular vector for the */
+/* singular value abs(SSMAX). */
+
+/* Further Details */
+/* =============== */
+
+/* Any input parameter may be aliased with any output parameter. */
+
+/* Barring over/underflow and assuming a guard digit in subtraction, all */
+/* output quantities are correct to within a few units in the last */
+/* place (ulps). */
+
+/* In IEEE arithmetic, the code works correctly if one matrix element is */
+/* infinite. */
+
+/* Overflow will not occur unless the largest singular value itself */
+/* overflows or is within a few ulps of overflow. (On machines with */
+/* partial overflow, like the Cray, overflow may occur if the largest */
+/* singular value is within a factor of 2 of overflow.) */
+
+/* Underflow is harmless if underflow is gradual. Otherwise, results */
+/* may correspond to a matrix modified by perturbations of size near */
+/* the underflow threshold. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ ft = *f;
+ fa = abs(ft);
+ ht = *h__;
+ ha = abs(*h__);
+
+/* PMAX points to the maximum absolute element of matrix */
+/* PMAX = 1 if F largest in absolute values */
+/* PMAX = 2 if G largest in absolute values */
+/* PMAX = 3 if H largest in absolute values */
+
+ pmax = 1;
+ swap = ha > fa;
+ if (swap) {
+ pmax = 3;
+ temp = ft;
+ ft = ht;
+ ht = temp;
+ temp = fa;
+ fa = ha;
+ ha = temp;
+
+/* Now FA .ge. HA */
+
+ }
+ gt = *g;
+ ga = abs(gt);
+ if (ga == 0.) {
+
+/* Diagonal matrix */
+
+ *ssmin = ha;
+ *ssmax = fa;
+ clt = 1.;
+ crt = 1.;
+ slt = 0.;
+ srt = 0.;
+ } else {
+ gasmal = TRUE_;
+ if (ga > fa) {
+ pmax = 2;
+ if (fa / ga < dlamch_("EPS")) {
+
+/* Case of very large GA */
+
+ gasmal = FALSE_;
+ *ssmax = ga;
+ if (ha > 1.) {
+ *ssmin = fa / (ga / ha);
+ } else {
+ *ssmin = fa / ga * ha;
+ }
+ clt = 1.;
+ slt = ht / gt;
+ srt = 1.;
+ crt = ft / gt;
+ }
+ }
+ if (gasmal) {
+
+/* Normal case */
+
+ d__ = fa - ha;
+ if (d__ == fa) {
+
+/* Copes with infinite F or H */
+
+ l = 1.;
+ } else {
+ l = d__ / fa;
+ }
+
+/* Note that 0 .le. L .le. 1 */
+
+ m = gt / ft;
+
+/* Note that abs(M) .le. 1/macheps */
+
+ t = 2. - l;
+
+/* Note that T .ge. 1 */
+
+ mm = m * m;
+ tt = t * t;
+ s = sqrt(tt + mm);
+
+/* Note that 1 .le. S .le. 1 + 1/macheps */
+
+ if (l == 0.) {
+ r__ = abs(m);
+ } else {
+ r__ = sqrt(l * l + mm);
+ }
+
+/* Note that 0 .le. R .le. 1 + 1/macheps */
+
+ a = (s + r__) * .5;
+
+/* Note that 1 .le. A .le. 1 + abs(M) */
+
+ *ssmin = ha / a;
+ *ssmax = fa * a;
+ if (mm == 0.) {
+
+/* Note that M is very tiny */
+
+ if (l == 0.) {
+ t = d_sign(&c_b3, &ft) * d_sign(&c_b4, >);
+ } else {
+ t = gt / d_sign(&d__, &ft) + m / t;
+ }
+ } else {
+ t = (m / (s + t) + m / (r__ + l)) * (a + 1.);
+ }
+ l = sqrt(t * t + 4.);
+ crt = 2. / l;
+ srt = t / l;
+ clt = (crt + srt * m) / a;
+ slt = ht / ft * srt / a;
+ }
+ }
+ if (swap) {
+ *csl = srt;
+ *snl = crt;
+ *csr = slt;
+ *snr = clt;
+ } else {
+ *csl = clt;
+ *snl = slt;
+ *csr = crt;
+ *snr = srt;
+ }
+
+/* Correct signs of SSMAX and SSMIN */
+
+ if (pmax == 1) {
+ tsign = d_sign(&c_b4, csr) * d_sign(&c_b4, csl) * d_sign(&c_b4, f);
+ }
+ if (pmax == 2) {
+ tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, csl) * d_sign(&c_b4, g);
+ }
+ if (pmax == 3) {
+ tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, snl) * d_sign(&c_b4, h__);
+ }
+ *ssmax = d_sign(ssmax, &tsign);
+ d__1 = tsign * d_sign(&c_b4, f) * d_sign(&c_b4, h__);
+ *ssmin = d_sign(ssmin, &d__1);
+ return 0;
+
+/* End of DLASV2 */
+
+} /* dlasv2_ */
diff --git a/SRC/dlaswp.c b/SRC/dlaswp.c
new file mode 100644
index 0000000..862938b
--- /dev/null
+++ b/SRC/dlaswp.c
@@ -0,0 +1,158 @@
+/* dlaswp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlaswp_(integer *n, doublereal *a, integer *lda, integer
+ *k1, integer *k2, integer *ipiv, integer *incx)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, k, i1, i2, n32, ip, ix, ix0, inc;
+ doublereal temp;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASWP performs a series of row interchanges on the matrix A. */
+/* One row interchange is initiated for each of rows K1 through K2 of A. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the matrix of column dimension N to which the row */
+/* interchanges will be applied. */
+/* On exit, the permuted matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* K1 (input) INTEGER */
+/* The first element of IPIV for which a row interchange will */
+/* be done. */
+
+/* K2 (input) INTEGER */
+/* The last element of IPIV for which a row interchange will */
+/* be done. */
+
+/* IPIV (input) INTEGER array, dimension (K2*abs(INCX)) */
+/* The vector of pivot indices. Only the elements in positions */
+/* K1 through K2 of IPIV are accessed. */
+/* IPIV(K) = L implies rows K and L are to be interchanged. */
+
+/* INCX (input) INTEGER */
+/* The increment between successive values of IPIV. If IPIV */
+/* is negative, the pivots are applied in reverse order. */
+
+/* Further Details */
+/* =============== */
+
+/* Modified by */
+/* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Interchange row I with row IPIV(I) for each of rows K1 through K2. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ if (*incx > 0) {
+ ix0 = *k1;
+ i1 = *k1;
+ i2 = *k2;
+ inc = 1;
+ } else if (*incx < 0) {
+ ix0 = (1 - *k2) * *incx + 1;
+ i1 = *k2;
+ i2 = *k1;
+ inc = -1;
+ } else {
+ return 0;
+ }
+
+ n32 = *n / 32 << 5;
+ if (n32 != 0) {
+ i__1 = n32;
+ for (j = 1; j <= i__1; j += 32) {
+ ix = ix0;
+ i__2 = i2;
+ i__3 = inc;
+ for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3)
+ {
+ ip = ipiv[ix];
+ if (ip != i__) {
+ i__4 = j + 31;
+ for (k = j; k <= i__4; ++k) {
+ temp = a[i__ + k * a_dim1];
+ a[i__ + k * a_dim1] = a[ip + k * a_dim1];
+ a[ip + k * a_dim1] = temp;
+/* L10: */
+ }
+ }
+ ix += *incx;
+/* L20: */
+ }
+/* L30: */
+ }
+ }
+ if (n32 != *n) {
+ ++n32;
+ ix = ix0;
+ i__1 = i2;
+ i__3 = inc;
+ for (i__ = i1; i__3 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__3) {
+ ip = ipiv[ix];
+ if (ip != i__) {
+ i__2 = *n;
+ for (k = n32; k <= i__2; ++k) {
+ temp = a[i__ + k * a_dim1];
+ a[i__ + k * a_dim1] = a[ip + k * a_dim1];
+ a[ip + k * a_dim1] = temp;
+/* L40: */
+ }
+ }
+ ix += *incx;
+/* L50: */
+ }
+ }
+
+ return 0;
+
+/* End of DLASWP */
+
+} /* dlaswp_ */
diff --git a/SRC/dlasy2.c b/SRC/dlasy2.c
new file mode 100644
index 0000000..352463d
--- /dev/null
+++ b/SRC/dlasy2.c
@@ -0,0 +1,478 @@
+/* dlasy2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__4 = 4;
+static integer c__1 = 1;
+static integer c__16 = 16;
+static integer c__0 = 0;
+
+/* Subroutine */ int dlasy2_(logical *ltranl, logical *ltranr, integer *isgn,
+ integer *n1, integer *n2, doublereal *tl, integer *ldtl, doublereal *
+ tr, integer *ldtr, doublereal *b, integer *ldb, doublereal *scale,
+ doublereal *x, integer *ldx, doublereal *xnorm, integer *info)
+{
+ /* Initialized data */
+
+ static integer locu12[4] = { 3,4,1,2 };
+ static integer locl21[4] = { 2,1,4,3 };
+ static integer locu22[4] = { 4,3,2,1 };
+ static logical xswpiv[4] = { FALSE_,FALSE_,TRUE_,TRUE_ };
+ static logical bswpiv[4] = { FALSE_,TRUE_,FALSE_,TRUE_ };
+
+ /* System generated locals */
+ integer b_dim1, b_offset, tl_dim1, tl_offset, tr_dim1, tr_offset, x_dim1,
+ x_offset;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal x2[2], l21, u11, u12;
+ integer ip, jp;
+ doublereal u22, t16[16] /* was [4][4] */, gam, bet, eps, sgn, tmp[4],
+ tau1, btmp[4], smin;
+ integer ipiv;
+ doublereal temp;
+ integer jpiv[4];
+ doublereal xmax;
+ integer ipsv, jpsv;
+ logical bswap;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dswap_(integer *, doublereal *, integer
+ *, doublereal *, integer *);
+ logical xswap;
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in */
+
+/* op(TL)*X + ISGN*X*op(TR) = SCALE*B, */
+
+/* where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or */
+/* -1. op(T) = T or T', where T' denotes the transpose of T. */
+
+/* Arguments */
+/* ========= */
+
+/* LTRANL (input) LOGICAL */
+/* On entry, LTRANL specifies the op(TL): */
+/* = .FALSE., op(TL) = TL, */
+/* = .TRUE., op(TL) = TL'. */
+
+/* LTRANR (input) LOGICAL */
+/* On entry, LTRANR specifies the op(TR): */
+/* = .FALSE., op(TR) = TR, */
+/* = .TRUE., op(TR) = TR'. */
+
+/* ISGN (input) INTEGER */
+/* On entry, ISGN specifies the sign of the equation */
+/* as described before. ISGN may only be 1 or -1. */
+
+/* N1 (input) INTEGER */
+/* On entry, N1 specifies the order of matrix TL. */
+/* N1 may only be 0, 1 or 2. */
+
+/* N2 (input) INTEGER */
+/* On entry, N2 specifies the order of matrix TR. */
+/* N2 may only be 0, 1 or 2. */
+
+/* TL (input) DOUBLE PRECISION array, dimension (LDTL,2) */
+/* On entry, TL contains an N1 by N1 matrix. */
+
+/* LDTL (input) INTEGER */
+/* The leading dimension of the matrix TL. LDTL >= max(1,N1). */
+
+/* TR (input) DOUBLE PRECISION array, dimension (LDTR,2) */
+/* On entry, TR contains an N2 by N2 matrix. */
+
+/* LDTR (input) INTEGER */
+/* The leading dimension of the matrix TR. LDTR >= max(1,N2). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,2) */
+/* On entry, the N1 by N2 matrix B contains the right-hand */
+/* side of the equation. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the matrix B. LDB >= max(1,N1). */
+
+/* SCALE (output) DOUBLE PRECISION */
+/* On exit, SCALE contains the scale factor. SCALE is chosen */
+/* less than or equal to 1 to prevent the solution overflowing. */
+
+/* X (output) DOUBLE PRECISION array, dimension (LDX,2) */
+/* On exit, X contains the N1 by N2 solution. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the matrix X. LDX >= max(1,N1). */
+
+/* XNORM (output) DOUBLE PRECISION */
+/* On exit, XNORM is the infinity-norm of the solution. */
+
+/* INFO (output) INTEGER */
+/* On exit, INFO is set to */
+/* 0: successful exit. */
+/* 1: TL and TR have too close eigenvalues, so TL or */
+/* TR is perturbed to get a nonsingular equation. */
+/* NOTE: In the interests of speed, this routine does not */
+/* check the inputs for errors. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ tl_dim1 = *ldtl;
+ tl_offset = 1 + tl_dim1;
+ tl -= tl_offset;
+ tr_dim1 = *ldtr;
+ tr_offset = 1 + tr_dim1;
+ tr -= tr_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Do not check the input parameters for errors */
+
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n1 == 0 || *n2 == 0) {
+ return 0;
+ }
+
+/* Set constants to control overflow */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S") / eps;
+ sgn = (doublereal) (*isgn);
+
+ k = *n1 + *n1 + *n2 - 2;
+ switch (k) {
+ case 1: goto L10;
+ case 2: goto L20;
+ case 3: goto L30;
+ case 4: goto L50;
+ }
+
+/* 1 by 1: TL11*X + SGN*X*TR11 = B11 */
+
+L10:
+ tau1 = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1];
+ bet = abs(tau1);
+ if (bet <= smlnum) {
+ tau1 = smlnum;
+ bet = smlnum;
+ *info = 1;
+ }
+
+ *scale = 1.;
+ gam = (d__1 = b[b_dim1 + 1], abs(d__1));
+ if (smlnum * gam > bet) {
+ *scale = 1. / gam;
+ }
+
+ x[x_dim1 + 1] = b[b_dim1 + 1] * *scale / tau1;
+ *xnorm = (d__1 = x[x_dim1 + 1], abs(d__1));
+ return 0;
+
+/* 1 by 2: */
+/* TL11*[X11 X12] + ISGN*[X11 X12]*op[TR11 TR12] = [B11 B12] */
+/* [TR21 TR22] */
+
+L20:
+
+/* Computing MAX */
+/* Computing MAX */
+ d__7 = (d__1 = tl[tl_dim1 + 1], abs(d__1)), d__8 = (d__2 = tr[tr_dim1 + 1]
+ , abs(d__2)), d__7 = max(d__7,d__8), d__8 = (d__3 = tr[(tr_dim1 <<
+ 1) + 1], abs(d__3)), d__7 = max(d__7,d__8), d__8 = (d__4 = tr[
+ tr_dim1 + 2], abs(d__4)), d__7 = max(d__7,d__8), d__8 = (d__5 =
+ tr[(tr_dim1 << 1) + 2], abs(d__5));
+ d__6 = eps * max(d__7,d__8);
+ smin = max(d__6,smlnum);
+ tmp[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1];
+ tmp[3] = tl[tl_dim1 + 1] + sgn * tr[(tr_dim1 << 1) + 2];
+ if (*ltranr) {
+ tmp[1] = sgn * tr[tr_dim1 + 2];
+ tmp[2] = sgn * tr[(tr_dim1 << 1) + 1];
+ } else {
+ tmp[1] = sgn * tr[(tr_dim1 << 1) + 1];
+ tmp[2] = sgn * tr[tr_dim1 + 2];
+ }
+ btmp[0] = b[b_dim1 + 1];
+ btmp[1] = b[(b_dim1 << 1) + 1];
+ goto L40;
+
+/* 2 by 1: */
+/* op[TL11 TL12]*[X11] + ISGN* [X11]*TR11 = [B11] */
+/* [TL21 TL22] [X21] [X21] [B21] */
+
+L30:
+/* Computing MAX */
+/* Computing MAX */
+ d__7 = (d__1 = tr[tr_dim1 + 1], abs(d__1)), d__8 = (d__2 = tl[tl_dim1 + 1]
+ , abs(d__2)), d__7 = max(d__7,d__8), d__8 = (d__3 = tl[(tl_dim1 <<
+ 1) + 1], abs(d__3)), d__7 = max(d__7,d__8), d__8 = (d__4 = tl[
+ tl_dim1 + 2], abs(d__4)), d__7 = max(d__7,d__8), d__8 = (d__5 =
+ tl[(tl_dim1 << 1) + 2], abs(d__5));
+ d__6 = eps * max(d__7,d__8);
+ smin = max(d__6,smlnum);
+ tmp[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1];
+ tmp[3] = tl[(tl_dim1 << 1) + 2] + sgn * tr[tr_dim1 + 1];
+ if (*ltranl) {
+ tmp[1] = tl[(tl_dim1 << 1) + 1];
+ tmp[2] = tl[tl_dim1 + 2];
+ } else {
+ tmp[1] = tl[tl_dim1 + 2];
+ tmp[2] = tl[(tl_dim1 << 1) + 1];
+ }
+ btmp[0] = b[b_dim1 + 1];
+ btmp[1] = b[b_dim1 + 2];
+L40:
+
+/* Solve 2 by 2 system using complete pivoting. */
+/* Set pivots less than SMIN to SMIN. */
+
+ ipiv = idamax_(&c__4, tmp, &c__1);
+ u11 = tmp[ipiv - 1];
+ if (abs(u11) <= smin) {
+ *info = 1;
+ u11 = smin;
+ }
+ u12 = tmp[locu12[ipiv - 1] - 1];
+ l21 = tmp[locl21[ipiv - 1] - 1] / u11;
+ u22 = tmp[locu22[ipiv - 1] - 1] - u12 * l21;
+ xswap = xswpiv[ipiv - 1];
+ bswap = bswpiv[ipiv - 1];
+ if (abs(u22) <= smin) {
+ *info = 1;
+ u22 = smin;
+ }
+ if (bswap) {
+ temp = btmp[1];
+ btmp[1] = btmp[0] - l21 * temp;
+ btmp[0] = temp;
+ } else {
+ btmp[1] -= l21 * btmp[0];
+ }
+ *scale = 1.;
+ if (smlnum * 2. * abs(btmp[1]) > abs(u22) || smlnum * 2. * abs(btmp[0]) >
+ abs(u11)) {
+/* Computing MAX */
+ d__1 = abs(btmp[0]), d__2 = abs(btmp[1]);
+ *scale = .5 / max(d__1,d__2);
+ btmp[0] *= *scale;
+ btmp[1] *= *scale;
+ }
+ x2[1] = btmp[1] / u22;
+ x2[0] = btmp[0] / u11 - u12 / u11 * x2[1];
+ if (xswap) {
+ temp = x2[1];
+ x2[1] = x2[0];
+ x2[0] = temp;
+ }
+ x[x_dim1 + 1] = x2[0];
+ if (*n1 == 1) {
+ x[(x_dim1 << 1) + 1] = x2[1];
+ *xnorm = (d__1 = x[x_dim1 + 1], abs(d__1)) + (d__2 = x[(x_dim1 << 1)
+ + 1], abs(d__2));
+ } else {
+ x[x_dim1 + 2] = x2[1];
+/* Computing MAX */
+ d__3 = (d__1 = x[x_dim1 + 1], abs(d__1)), d__4 = (d__2 = x[x_dim1 + 2]
+ , abs(d__2));
+ *xnorm = max(d__3,d__4);
+ }
+ return 0;
+
+/* 2 by 2: */
+/* op[TL11 TL12]*[X11 X12] +ISGN* [X11 X12]*op[TR11 TR12] = [B11 B12] */
+/* [TL21 TL22] [X21 X22] [X21 X22] [TR21 TR22] [B21 B22] */
+
+/* Solve equivalent 4 by 4 system using complete pivoting. */
+/* Set pivots less than SMIN to SMIN. */
+
+L50:
+/* Computing MAX */
+ d__5 = (d__1 = tr[tr_dim1 + 1], abs(d__1)), d__6 = (d__2 = tr[(tr_dim1 <<
+ 1) + 1], abs(d__2)), d__5 = max(d__5,d__6), d__6 = (d__3 = tr[
+ tr_dim1 + 2], abs(d__3)), d__5 = max(d__5,d__6), d__6 = (d__4 =
+ tr[(tr_dim1 << 1) + 2], abs(d__4));
+ smin = max(d__5,d__6);
+/* Computing MAX */
+ d__5 = smin, d__6 = (d__1 = tl[tl_dim1 + 1], abs(d__1)), d__5 = max(d__5,
+ d__6), d__6 = (d__2 = tl[(tl_dim1 << 1) + 1], abs(d__2)), d__5 =
+ max(d__5,d__6), d__6 = (d__3 = tl[tl_dim1 + 2], abs(d__3)), d__5 =
+ max(d__5,d__6), d__6 = (d__4 = tl[(tl_dim1 << 1) + 2], abs(d__4))
+ ;
+ smin = max(d__5,d__6);
+/* Computing MAX */
+ d__1 = eps * smin;
+ smin = max(d__1,smlnum);
+ btmp[0] = 0.;
+ dcopy_(&c__16, btmp, &c__0, t16, &c__1);
+ t16[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1];
+ t16[5] = tl[(tl_dim1 << 1) + 2] + sgn * tr[tr_dim1 + 1];
+ t16[10] = tl[tl_dim1 + 1] + sgn * tr[(tr_dim1 << 1) + 2];
+ t16[15] = tl[(tl_dim1 << 1) + 2] + sgn * tr[(tr_dim1 << 1) + 2];
+ if (*ltranl) {
+ t16[4] = tl[tl_dim1 + 2];
+ t16[1] = tl[(tl_dim1 << 1) + 1];
+ t16[14] = tl[tl_dim1 + 2];
+ t16[11] = tl[(tl_dim1 << 1) + 1];
+ } else {
+ t16[4] = tl[(tl_dim1 << 1) + 1];
+ t16[1] = tl[tl_dim1 + 2];
+ t16[14] = tl[(tl_dim1 << 1) + 1];
+ t16[11] = tl[tl_dim1 + 2];
+ }
+ if (*ltranr) {
+ t16[8] = sgn * tr[(tr_dim1 << 1) + 1];
+ t16[13] = sgn * tr[(tr_dim1 << 1) + 1];
+ t16[2] = sgn * tr[tr_dim1 + 2];
+ t16[7] = sgn * tr[tr_dim1 + 2];
+ } else {
+ t16[8] = sgn * tr[tr_dim1 + 2];
+ t16[13] = sgn * tr[tr_dim1 + 2];
+ t16[2] = sgn * tr[(tr_dim1 << 1) + 1];
+ t16[7] = sgn * tr[(tr_dim1 << 1) + 1];
+ }
+ btmp[0] = b[b_dim1 + 1];
+ btmp[1] = b[b_dim1 + 2];
+ btmp[2] = b[(b_dim1 << 1) + 1];
+ btmp[3] = b[(b_dim1 << 1) + 2];
+
+/* Perform elimination */
+
+ for (i__ = 1; i__ <= 3; ++i__) {
+ xmax = 0.;
+ for (ip = i__; ip <= 4; ++ip) {
+ for (jp = i__; jp <= 4; ++jp) {
+ if ((d__1 = t16[ip + (jp << 2) - 5], abs(d__1)) >= xmax) {
+ xmax = (d__1 = t16[ip + (jp << 2) - 5], abs(d__1));
+ ipsv = ip;
+ jpsv = jp;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+ if (ipsv != i__) {
+ dswap_(&c__4, &t16[ipsv - 1], &c__4, &t16[i__ - 1], &c__4);
+ temp = btmp[i__ - 1];
+ btmp[i__ - 1] = btmp[ipsv - 1];
+ btmp[ipsv - 1] = temp;
+ }
+ if (jpsv != i__) {
+ dswap_(&c__4, &t16[(jpsv << 2) - 4], &c__1, &t16[(i__ << 2) - 4],
+ &c__1);
+ }
+ jpiv[i__ - 1] = jpsv;
+ if ((d__1 = t16[i__ + (i__ << 2) - 5], abs(d__1)) < smin) {
+ *info = 1;
+ t16[i__ + (i__ << 2) - 5] = smin;
+ }
+ for (j = i__ + 1; j <= 4; ++j) {
+ t16[j + (i__ << 2) - 5] /= t16[i__ + (i__ << 2) - 5];
+ btmp[j - 1] -= t16[j + (i__ << 2) - 5] * btmp[i__ - 1];
+ for (k = i__ + 1; k <= 4; ++k) {
+ t16[j + (k << 2) - 5] -= t16[j + (i__ << 2) - 5] * t16[i__ + (
+ k << 2) - 5];
+/* L80: */
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+ if (abs(t16[15]) < smin) {
+ t16[15] = smin;
+ }
+ *scale = 1.;
+ if (smlnum * 8. * abs(btmp[0]) > abs(t16[0]) || smlnum * 8. * abs(btmp[1])
+ > abs(t16[5]) || smlnum * 8. * abs(btmp[2]) > abs(t16[10]) ||
+ smlnum * 8. * abs(btmp[3]) > abs(t16[15])) {
+/* Computing MAX */
+ d__1 = abs(btmp[0]), d__2 = abs(btmp[1]), d__1 = max(d__1,d__2), d__2
+ = abs(btmp[2]), d__1 = max(d__1,d__2), d__2 = abs(btmp[3]);
+ *scale = .125 / max(d__1,d__2);
+ btmp[0] *= *scale;
+ btmp[1] *= *scale;
+ btmp[2] *= *scale;
+ btmp[3] *= *scale;
+ }
+ for (i__ = 1; i__ <= 4; ++i__) {
+ k = 5 - i__;
+ temp = 1. / t16[k + (k << 2) - 5];
+ tmp[k - 1] = btmp[k - 1] * temp;
+ for (j = k + 1; j <= 4; ++j) {
+ tmp[k - 1] -= temp * t16[k + (j << 2) - 5] * tmp[j - 1];
+/* L110: */
+ }
+/* L120: */
+ }
+ for (i__ = 1; i__ <= 3; ++i__) {
+ if (jpiv[4 - i__ - 1] != 4 - i__) {
+ temp = tmp[4 - i__ - 1];
+ tmp[4 - i__ - 1] = tmp[jpiv[4 - i__ - 1] - 1];
+ tmp[jpiv[4 - i__ - 1] - 1] = temp;
+ }
+/* L130: */
+ }
+ x[x_dim1 + 1] = tmp[0];
+ x[x_dim1 + 2] = tmp[1];
+ x[(x_dim1 << 1) + 1] = tmp[2];
+ x[(x_dim1 << 1) + 2] = tmp[3];
+/* Computing MAX */
+ d__1 = abs(tmp[0]) + abs(tmp[2]), d__2 = abs(tmp[1]) + abs(tmp[3]);
+ *xnorm = max(d__1,d__2);
+ return 0;
+
+/* End of DLASY2 */
+
+} /* dlasy2_ */
diff --git a/SRC/dlasyf.c b/SRC/dlasyf.c
new file mode 100644
index 0000000..c0d98e2
--- /dev/null
+++ b/SRC/dlasyf.c
@@ -0,0 +1,721 @@
+/* dlasyf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b8 = -1.;
+static doublereal c_b9 = 1.;
+
+/* Subroutine */ int dlasyf_(char *uplo, integer *n, integer *nb, integer *kb,
+ doublereal *a, integer *lda, integer *ipiv, doublereal *w, integer *
+ ldw, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer j, k;
+ doublereal t, r1, d11, d21, d22;
+ integer jb, jj, kk, jp, kp, kw, kkw, imax, jmax;
+ doublereal alpha;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *), dgemm_(char *, char *, integer *, integer *, integer *
+, doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dcopy_(integer *,
+ doublereal *, integer *, doublereal *, integer *), dswap_(integer
+ *, doublereal *, integer *, doublereal *, integer *);
+ integer kstep;
+ doublereal absakk;
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal colmax, rowmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASYF computes a partial factorization of a real symmetric matrix A */
+/* using the Bunch-Kaufman 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' U22' ) */
+
+/* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) 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 is an auxiliary routine called by DSYTRF. It uses blocked code */
+/* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or */
+/* A22 (if UPLO = 'L'). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NB (input) 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. */
+
+/* KB (output) INTEGER */
+/* The number of columns of A that were actually factored. */
+/* KB is either NB-1 or NB, or N if N <= NB. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n-by-n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n-by-n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+/* On exit, A contains details of the partial factorization. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If UPLO = 'U', only the last KB elements of IPIV are set; */
+/* if UPLO = 'L', only the first KB elements are set. */
+
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* W (workspace) DOUBLE PRECISION array, dimension (LDW,NB) */
+
+/* LDW (input) INTEGER */
+/* The leading dimension of the array W. LDW >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* > 0: if INFO = k, D(k,k) is exactly zero. The factorization */
+/* has been completed, but the block diagonal matrix D is */
+/* exactly singular. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ w_dim1 = *ldw;
+ w_offset = 1 + w_dim1;
+ w -= w_offset;
+
+ /* Function Body */
+ *info = 0;
+
+/* Initialize ALPHA for use in choosing pivot block size. */
+
+ alpha = (sqrt(17.) + 1.) / 8.;
+
+ if (lsame_(uplo, "U")) {
+
+/* 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 */
+
+/* K is the main loop index, decreasing from N in steps of 1 or 2 */
+
+/* KW is the column of W which corresponds to column K of A */
+
+ k = *n;
+L10:
+ kw = *nb + k - *n;
+
+/* Exit from loop */
+
+ if (k <= *n - *nb + 1 && *nb < *n || k < 1) {
+ goto L30;
+ }
+
+/* Copy column K of A to column KW of W and update it */
+
+ dcopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1);
+ if (k < *n) {
+ i__1 = *n - k;
+ dgemv_("No transpose", &k, &i__1, &c_b8, &a[(k + 1) * a_dim1 + 1],
+ lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b9, &w[kw *
+ w_dim1 + 1], &c__1);
+ }
+
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ absakk = (d__1 = w[k + kw * w_dim1], abs(d__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ imax = idamax_(&i__1, &w[kw * w_dim1 + 1], &c__1);
+ colmax = (d__1 = w[imax + kw * w_dim1], abs(d__1));
+ } else {
+ colmax = 0.;
+ }
+
+ if (max(absakk,colmax) == 0.) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* Copy column IMAX to column KW-1 of W and update it */
+
+ dcopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) *
+ w_dim1 + 1], &c__1);
+ i__1 = k - imax;
+ dcopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax +
+ 1 + (kw - 1) * w_dim1], &c__1);
+ if (k < *n) {
+ i__1 = *n - k;
+ dgemv_("No transpose", &k, &i__1, &c_b8, &a[(k + 1) *
+ a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1],
+ ldw, &c_b9, &w[(kw - 1) * w_dim1 + 1], &c__1);
+ }
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = k - imax;
+ jmax = imax + idamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1],
+ &c__1);
+ rowmax = (d__1 = w[jmax + (kw - 1) * w_dim1], abs(d__1));
+ if (imax > 1) {
+ i__1 = imax - 1;
+ jmax = idamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
+/* Computing MAX */
+ d__2 = rowmax, d__3 = (d__1 = w[jmax + (kw - 1) * w_dim1],
+ abs(d__1));
+ rowmax = max(d__2,d__3);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else if ((d__1 = w[imax + (kw - 1) * w_dim1], abs(d__1)) >=
+ alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+
+/* copy column KW-1 of W to column KW */
+
+ dcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw *
+ w_dim1 + 1], &c__1);
+ } else {
+
+/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+
+ kk = k - kstep + 1;
+ kkw = *nb + kk - *n;
+
+/* Updated column KP is already stored in column KKW of W */
+
+ if (kp != kk) {
+
+/* Copy non-updated column KK to column KP */
+
+ a[kp + k * a_dim1] = a[kk + k * a_dim1];
+ i__1 = k - 1 - kp;
+ dcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp +
+ 1) * a_dim1], lda);
+ dcopy_(&kp, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &
+ c__1);
+
+/* Interchange rows KK and KP in last KK columns of A and W */
+
+ i__1 = *n - kk + 1;
+ dswap_(&i__1, &a[kk + kk * a_dim1], lda, &a[kp + kk * a_dim1],
+ lda);
+ i__1 = *n - kk + 1;
+ dswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw *
+ w_dim1], ldw);
+ }
+
+ if (kstep == 1) {
+
+/* 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 */
+
+ dcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &
+ c__1);
+ r1 = 1. / a[k + k * a_dim1];
+ i__1 = k - 1;
+ dscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
+ } 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 > 2) {
+
+/* Store U(k) and U(k-1) in columns k and k-1 of A */
+
+ d21 = w[k - 1 + kw * w_dim1];
+ d11 = w[k + kw * w_dim1] / d21;
+ d22 = w[k - 1 + (kw - 1) * w_dim1] / d21;
+ t = 1. / (d11 * d22 - 1.);
+ d21 = t / d21;
+ i__1 = k - 2;
+ for (j = 1; j <= i__1; ++j) {
+ a[j + (k - 1) * a_dim1] = d21 * (d11 * w[j + (kw - 1)
+ * w_dim1] - w[j + kw * w_dim1]);
+ a[j + k * a_dim1] = d21 * (d22 * w[j + kw * w_dim1] -
+ w[j + (kw - 1) * w_dim1]);
+/* L20: */
+ }
+ }
+
+/* Copy D(k) to A */
+
+ a[k - 1 + (k - 1) * a_dim1] = w[k - 1 + (kw - 1) * w_dim1];
+ a[k - 1 + k * a_dim1] = w[k - 1 + kw * w_dim1];
+ a[k + k * a_dim1] = w[k + kw * w_dim1];
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k - 1] = -kp;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kstep;
+ goto L10;
+
+L30:
+
+/* Update the upper triangle of A11 (= A(1:k,1:k)) as */
+
+/* A11 := A11 - U12*D*U12' = A11 - U12*W' */
+
+/* computing blocks of NB columns at a time */
+
+ i__1 = -(*nb);
+ for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j +=
+ i__1) {
+/* Computing MIN */
+ i__2 = *nb, i__3 = k - j + 1;
+ jb = min(i__2,i__3);
+
+/* Update the upper triangle of the diagonal block */
+
+ i__2 = j + jb - 1;
+ for (jj = j; jj <= i__2; ++jj) {
+ i__3 = jj - j + 1;
+ i__4 = *n - k;
+ dgemv_("No transpose", &i__3, &i__4, &c_b8, &a[j + (k + 1) *
+ a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b9,
+ &a[j + jj * a_dim1], &c__1);
+/* L40: */
+ }
+
+/* Update the rectangular superdiagonal block */
+
+ i__2 = j - 1;
+ i__3 = *n - k;
+ dgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &c_b8, &a[(
+ k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * w_dim1], ldw,
+ &c_b9, &a[j * a_dim1 + 1], lda);
+/* L50: */
+ }
+
+/* Put U12 in standard form by partially undoing the interchanges */
+/* in columns k+1:n */
+
+ j = k + 1;
+L60:
+ jj = j;
+ jp = ipiv[j];
+ if (jp < 0) {
+ jp = -jp;
+ ++j;
+ }
+ ++j;
+ if (jp != jj && j <= *n) {
+ i__1 = *n - j + 1;
+ dswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda);
+ }
+ if (j <= *n) {
+ goto L60;
+ }
+
+/* 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 */
+
+/* K is the main loop index, increasing from 1 in steps of 1 or 2 */
+
+ k = 1;
+L70:
+
+/* Exit from loop */
+
+ if (k >= *nb && *nb < *n || k > *n) {
+ goto L90;
+ }
+
+/* Copy column K of A to column K of W and update it */
+
+ i__1 = *n - k + 1;
+ dcopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1);
+ i__1 = *n - k + 1;
+ i__2 = k - 1;
+ dgemv_("No transpose", &i__1, &i__2, &c_b8, &a[k + a_dim1], lda, &w[k
+ + w_dim1], ldw, &c_b9, &w[k + k * w_dim1], &c__1);
+
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ absakk = (d__1 = w[k + k * w_dim1], abs(d__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ imax = k + idamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1);
+ colmax = (d__1 = w[imax + k * w_dim1], abs(d__1));
+ } else {
+ colmax = 0.;
+ }
+
+ if (max(absakk,colmax) == 0.) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* Copy column IMAX to column K+1 of W and update it */
+
+ i__1 = imax - k;
+ dcopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) *
+ w_dim1], &c__1);
+ i__1 = *n - imax + 1;
+ dcopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k +
+ 1) * w_dim1], &c__1);
+ i__1 = *n - k + 1;
+ i__2 = k - 1;
+ dgemv_("No transpose", &i__1, &i__2, &c_b8, &a[k + a_dim1],
+ lda, &w[imax + w_dim1], ldw, &c_b9, &w[k + (k + 1) *
+ w_dim1], &c__1);
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = imax - k;
+ jmax = k - 1 + idamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1)
+ ;
+ rowmax = (d__1 = w[jmax + (k + 1) * w_dim1], abs(d__1));
+ if (imax < *n) {
+ i__1 = *n - imax;
+ jmax = imax + idamax_(&i__1, &w[imax + 1 + (k + 1) *
+ w_dim1], &c__1);
+/* Computing MAX */
+ d__2 = rowmax, d__3 = (d__1 = w[jmax + (k + 1) * w_dim1],
+ abs(d__1));
+ rowmax = max(d__2,d__3);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else if ((d__1 = w[imax + (k + 1) * w_dim1], abs(d__1)) >=
+ alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+
+/* copy column K+1 of W to column K */
+
+ i__1 = *n - k + 1;
+ dcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k *
+ w_dim1], &c__1);
+ } else {
+
+/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+
+ kk = k + kstep - 1;
+
+/* Updated column KP is already stored in column KK of W */
+
+ if (kp != kk) {
+
+/* Copy non-updated column KK to column KP */
+
+ a[kp + k * a_dim1] = a[kk + k * a_dim1];
+ i__1 = kp - k - 1;
+ dcopy_(&i__1, &a[k + 1 + kk * a_dim1], &c__1, &a[kp + (k + 1)
+ * a_dim1], lda);
+ i__1 = *n - kp + 1;
+ dcopy_(&i__1, &a[kp + kk * a_dim1], &c__1, &a[kp + kp *
+ a_dim1], &c__1);
+
+/* Interchange rows KK and KP in first KK columns of A and W */
+
+ dswap_(&kk, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda);
+ dswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw);
+ }
+
+ if (kstep == 1) {
+
+/* 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 */
+
+ i__1 = *n - k + 1;
+ dcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], &
+ c__1);
+ if (k < *n) {
+ r1 = 1. / a[k + k * a_dim1];
+ i__1 = *n - k;
+ dscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1);
+ }
+ } 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 < *n - 1) {
+
+/* Store L(k) and L(k+1) in columns k and k+1 of A */
+
+ d21 = w[k + 1 + k * w_dim1];
+ d11 = w[k + 1 + (k + 1) * w_dim1] / d21;
+ d22 = w[k + k * w_dim1] / d21;
+ t = 1. / (d11 * d22 - 1.);
+ d21 = t / d21;
+ i__1 = *n;
+ for (j = k + 2; j <= i__1; ++j) {
+ a[j + k * a_dim1] = d21 * (d11 * w[j + k * w_dim1] -
+ w[j + (k + 1) * w_dim1]);
+ a[j + (k + 1) * a_dim1] = d21 * (d22 * w[j + (k + 1) *
+ w_dim1] - w[j + k * w_dim1]);
+/* L80: */
+ }
+ }
+
+/* Copy D(k) to A */
+
+ a[k + k * a_dim1] = w[k + k * w_dim1];
+ a[k + 1 + k * a_dim1] = w[k + 1 + k * w_dim1];
+ a[k + 1 + (k + 1) * a_dim1] = w[k + 1 + (k + 1) * w_dim1];
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k + 1] = -kp;
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kstep;
+ goto L70;
+
+L90:
+
+/* Update the lower triangle of A22 (= A(k:n,k:n)) as */
+
+/* A22 := A22 - L21*D*L21' = A22 - L21*W' */
+
+/* computing blocks of NB columns at a time */
+
+ i__1 = *n;
+ i__2 = *nb;
+ for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = *nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+
+/* Update the lower triangle of the diagonal block */
+
+ i__3 = j + jb - 1;
+ for (jj = j; jj <= i__3; ++jj) {
+ i__4 = j + jb - jj;
+ i__5 = k - 1;
+ dgemv_("No transpose", &i__4, &i__5, &c_b8, &a[jj + a_dim1],
+ lda, &w[jj + w_dim1], ldw, &c_b9, &a[jj + jj * a_dim1]
+, &c__1);
+/* L100: */
+ }
+
+/* Update the rectangular subdiagonal block */
+
+ if (j + jb <= *n) {
+ i__3 = *n - j - jb + 1;
+ i__4 = k - 1;
+ dgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &c_b8,
+ &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b9,
+ &a[j + jb + j * a_dim1], lda);
+ }
+/* L110: */
+ }
+
+/* Put L21 in standard form by partially undoing the interchanges */
+/* in columns 1:k-1 */
+
+ j = k - 1;
+L120:
+ jj = j;
+ jp = ipiv[j];
+ if (jp < 0) {
+ jp = -jp;
+ --j;
+ }
+ --j;
+ if (jp != jj && j >= 1) {
+ dswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda);
+ }
+ if (j >= 1) {
+ goto L120;
+ }
+
+/* Set KB to the number of columns factorized */
+
+ *kb = k - 1;
+
+ }
+ return 0;
+
+/* End of DLASYF */
+
+} /* dlasyf_ */
diff --git a/SRC/dlat2s.c b/SRC/dlat2s.c
new file mode 100644
index 0000000..8c8479c
--- /dev/null
+++ b/SRC/dlat2s.c
@@ -0,0 +1,137 @@
+/* dlat2s.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlat2s_(char *uplo, integer *n, doublereal *a, integer *
+ lda, real *sa, integer *ldsa, integer *info)
+{
+ /* System generated locals */
+ integer sa_dim1, sa_offset, a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal rmax;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK PROTOTYPE auxiliary routine (version 3.1.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* May 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAT2S converts a DOUBLE PRECISION triangular matrix, SA, to a SINGLE */
+/* PRECISION triangular matrix, A. */
+
+/* RMAX is the overflow for the SINGLE PRECISION arithmetic */
+/* DLAS2S checks that all the entries of A are between -RMAX and */
+/* RMAX. If not the convertion is aborted and a flag is raised. */
+
+/* This is an auxiliary routine so there is no argument checking. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the N-by-N triangular coefficient matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* SA (output) REAL array, dimension (LDSA,N) */
+/* Only the UPLO part of SA is referenced. On exit, if INFO=0, */
+/* the N-by-N coefficient matrix SA; if INFO>0, the content of */
+/* the UPLO part of SA is unspecified. */
+
+/* LDSA (input) INTEGER */
+/* The leading dimension of the array SA. LDSA >= max(1,M). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* = 1: an entry of the matrix A is greater than the SINGLE */
+/* PRECISION overflow threshold, in this case, the content */
+/* of the UPLO part of SA in exit is unspecified. */
+
+/* ========= */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ sa_dim1 = *ldsa;
+ sa_offset = 1 + sa_dim1;
+ sa -= sa_offset;
+
+ /* Function Body */
+ rmax = slamch_("O");
+ upper = lsame_(uplo, "U");
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (a[i__ + j * a_dim1] < -rmax || a[i__ + j * a_dim1] > rmax)
+ {
+ *info = 1;
+ goto L50;
+ }
+ sa[i__ + j * sa_dim1] = a[i__ + j * a_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ if (a[i__ + j * a_dim1] < -rmax || a[i__ + j * a_dim1] > rmax)
+ {
+ *info = 1;
+ goto L50;
+ }
+ sa[i__ + j * sa_dim1] = a[i__ + j * a_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+L50:
+
+ return 0;
+
+/* End of DLAT2S */
+
+} /* dlat2s_ */
diff --git a/SRC/dlatbs.c b/SRC/dlatbs.c
new file mode 100644
index 0000000..cfd8566
--- /dev/null
+++ b/SRC/dlatbs.c
@@ -0,0 +1,850 @@
+/* dlatbs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b36 = .5;
+
+/* Subroutine */ int dlatbs_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, integer *kd, doublereal *ab, integer *ldab,
+ doublereal *x, doublereal *scale, doublereal *cnorm, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal xj, rec, tjj;
+ integer jinc, jlen;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal xbnd;
+ integer imax;
+ doublereal tmax, tjjs, xmax, grow, sumj;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ integer maind;
+ extern logical lsame_(char *, char *);
+ doublereal tscal, uscal;
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ integer jlast;
+ extern /* Subroutine */ int dtbsv_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *);
+ logical upper;
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ logical notran;
+ integer jfirst;
+ doublereal smlnum;
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLATBS solves one of the triangular systems */
+
+/* A *x = s*b or A'*x = s*b */
+
+/* with scaling to prevent overflow, where A is an upper or lower */
+/* triangular band matrix. Here A' denotes the transpose of A, x and b */
+/* are n-element vectors, and s is a scaling factor, usually less than */
+/* or equal to 1, chosen so that the components of x will be less than */
+/* the overflow threshold. If the unscaled problem will not cause */
+/* overflow, the Level 2 BLAS routine DTBSV is called. If the matrix A */
+/* is singular (A(j,j) = 0 for some j), then s is set to 0 and a */
+/* non-trivial solution to A*x = 0 is returned. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': Solve A * x = s*b (No transpose) */
+/* = 'T': Solve A'* x = s*b (Transpose) */
+/* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* NORMIN (input) CHARACTER*1 */
+/* Specifies whether CNORM has been set or not. */
+/* = 'Y': CNORM contains the column norms on entry */
+/* = 'N': CNORM is not set on entry. On exit, the norms will */
+/* be computed and stored in CNORM. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of subdiagonals or superdiagonals in the */
+/* triangular matrix A. KD >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first KD+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* X (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the right hand side b of the triangular system. */
+/* On exit, X is overwritten by the solution vector x. */
+
+/* SCALE (output) DOUBLE PRECISION */
+/* The scaling factor s for the triangular system */
+/* A * x = s*b or A'* x = s*b. */
+/* If SCALE = 0, the matrix A is singular or badly scaled, and */
+/* the vector x is an exact or approximate solution to A*x = 0. */
+
+/* CNORM (input or output) DOUBLE PRECISION array, dimension (N) */
+
+/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
+/* contains the norm of the off-diagonal part of the j-th column */
+/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */
+/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
+/* must be greater than or equal to the 1-norm. */
+
+/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
+/* returns the 1-norm of the offdiagonal part of the j-th column */
+/* of A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* Further Details */
+/* ======= ======= */
+
+/* A rough bound on x is computed; if that is less than overflow, DTBSV */
+/* is called, otherwise, specific code is used which checks for possible */
+/* overflow or divide-by-zero at every operation. */
+
+/* A columnwise scheme is used for solving A*x = b. The basic algorithm */
+/* if A is lower triangular is */
+
+/* x[1:n] := b[1:n] */
+/* for j = 1, ..., n */
+/* x(j) := x(j) / A(j,j) */
+/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
+/* end */
+
+/* Define bounds on the components of x after j iterations of the loop: */
+/* M(j) = bound on x[1:j] */
+/* G(j) = bound on x[j+1:n] */
+/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */
+
+/* Then for iteration j+1 we have */
+/* M(j+1) <= G(j) / | A(j+1,j+1) | */
+/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
+/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
+
+/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
+/* column j+1 of A, not counting the diagonal. Hence */
+
+/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
+/* 1<=i<=j */
+/* and */
+
+/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
+/* 1<=i< j */
+
+/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTBSV if the */
+/* reciprocal of the largest M(j), j=1,..,n, is larger than */
+/* max(underflow, 1/overflow). */
+
+/* The bound on x(j) is also used to determine when a step in the */
+/* columnwise method can be performed without fear of overflow. If */
+/* the computed bound is greater than a large constant, x is scaled to */
+/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
+/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
+
+/* Similarly, a row-wise scheme is used to solve A'*x = b. The basic */
+/* algorithm for A upper triangular is */
+
+/* for j = 1, ..., n */
+/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
+/* end */
+
+/* We simultaneously compute two bounds */
+/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
+/* M(j) = bound on x(i), 1<=i<=j */
+
+/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */
+/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
+/* Then the bound on x(j) is */
+
+/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
+
+/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
+/* 1<=i<=j */
+
+/* and we can safely call DTBSV if 1/M(n) and 1/G(n) are both greater */
+/* than max(underflow, 1/overflow). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --x;
+ --cnorm;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+/* Test the input parameters. */
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (! lsame_(normin, "Y") && ! lsame_(normin,
+ "N")) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*kd < 0) {
+ *info = -6;
+ } else if (*ldab < *kd + 1) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLATBS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine machine dependent parameters to control overflow. */
+
+ smlnum = dlamch_("Safe minimum") / dlamch_("Precision");
+ bignum = 1. / smlnum;
+ *scale = 1.;
+
+ if (lsame_(normin, "N")) {
+
+/* Compute the 1-norm of each column, not including the diagonal. */
+
+ if (upper) {
+
+/* A is upper triangular. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *kd, i__3 = j - 1;
+ jlen = min(i__2,i__3);
+ cnorm[j] = dasum_(&jlen, &ab[*kd + 1 - jlen + j * ab_dim1], &
+ c__1);
+/* L10: */
+ }
+ } else {
+
+/* A is lower triangular. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *kd, i__3 = *n - j;
+ jlen = min(i__2,i__3);
+ if (jlen > 0) {
+ cnorm[j] = dasum_(&jlen, &ab[j * ab_dim1 + 2], &c__1);
+ } else {
+ cnorm[j] = 0.;
+ }
+/* L20: */
+ }
+ }
+ }
+
+/* Scale the column norms by TSCAL if the maximum element in CNORM is */
+/* greater than BIGNUM. */
+
+ imax = idamax_(n, &cnorm[1], &c__1);
+ tmax = cnorm[imax];
+ if (tmax <= bignum) {
+ tscal = 1.;
+ } else {
+ tscal = 1. / (smlnum * tmax);
+ dscal_(n, &tscal, &cnorm[1], &c__1);
+ }
+
+/* Compute a bound on the computed solution vector to see if the */
+/* Level 2 BLAS routine DTBSV can be used. */
+
+ j = idamax_(n, &x[1], &c__1);
+ xmax = (d__1 = x[j], abs(d__1));
+ xbnd = xmax;
+ if (notran) {
+
+/* Compute the growth in A * x = b. */
+
+ if (upper) {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ maind = *kd + 1;
+ } else {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ maind = 1;
+ }
+
+ if (tscal != 1.) {
+ grow = 0.;
+ goto L50;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, G(0) = max{x(i), i=1,...,n}. */
+
+ grow = 1. / max(xbnd,smlnum);
+ xbnd = grow;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L50;
+ }
+
+/* M(j) = G(j-1) / abs(A(j,j)) */
+
+ tjj = (d__1 = ab[maind + j * ab_dim1], abs(d__1));
+/* Computing MIN */
+ d__1 = xbnd, d__2 = min(1.,tjj) * grow;
+ xbnd = min(d__1,d__2);
+ if (tjj + cnorm[j] >= smlnum) {
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
+
+ grow *= tjj / (tjj + cnorm[j]);
+ } else {
+
+/* G(j) could overflow, set GROW to 0. */
+
+ grow = 0.;
+ }
+/* L30: */
+ }
+ grow = xbnd;
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ d__1 = 1., d__2 = 1. / max(xbnd,smlnum);
+ grow = min(d__1,d__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L50;
+ }
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
+
+ grow *= 1. / (cnorm[j] + 1.);
+/* L40: */
+ }
+ }
+L50:
+
+ ;
+ } else {
+
+/* Compute the growth in A' * x = b. */
+
+ if (upper) {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ maind = *kd + 1;
+ } else {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ maind = 1;
+ }
+
+ if (tscal != 1.) {
+ grow = 0.;
+ goto L80;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, M(0) = max{x(i), i=1,...,n}. */
+
+ grow = 1. / max(xbnd,smlnum);
+ xbnd = grow;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L80;
+ }
+
+/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
+
+ xj = cnorm[j] + 1.;
+/* Computing MIN */
+ d__1 = grow, d__2 = xbnd / xj;
+ grow = min(d__1,d__2);
+
+/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
+
+ tjj = (d__1 = ab[maind + j * ab_dim1], abs(d__1));
+ if (xj > tjj) {
+ xbnd *= tjj / xj;
+ }
+/* L60: */
+ }
+ grow = min(grow,xbnd);
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ d__1 = 1., d__2 = 1. / max(xbnd,smlnum);
+ grow = min(d__1,d__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L80;
+ }
+
+/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
+
+ xj = cnorm[j] + 1.;
+ grow /= xj;
+/* L70: */
+ }
+ }
+L80:
+ ;
+ }
+
+ if (grow * tscal > smlnum) {
+
+/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
+/* elements of X is not too small. */
+
+ dtbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &x[1], &c__1);
+ } else {
+
+/* Use a Level 1 BLAS solve, scaling intermediate results. */
+
+ if (xmax > bignum) {
+
+/* Scale X so that its components are less than or equal to */
+/* BIGNUM in absolute value. */
+
+ *scale = bignum / xmax;
+ dscal_(n, scale, &x[1], &c__1);
+ xmax = bignum;
+ }
+
+ if (notran) {
+
+/* Solve A * x = b */
+
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
+
+ xj = (d__1 = x[j], abs(d__1));
+ if (nounit) {
+ tjjs = ab[maind + j * ab_dim1] * tscal;
+ } else {
+ tjjs = tscal;
+ if (tscal == 1.) {
+ goto L100;
+ }
+ }
+ tjj = abs(tjjs);
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.) {
+ if (xj > tjj * bignum) {
+
+/* Scale x by 1/b(j). */
+
+ rec = 1. / xj;
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ x[j] /= tjjs;
+ xj = (d__1 = x[j], abs(d__1));
+ } else if (tjj > 0.) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
+/* to avoid overflow when dividing by A(j,j). */
+
+ rec = tjj * bignum / xj;
+ if (cnorm[j] > 1.) {
+
+/* Scale by 1/CNORM(j) to avoid overflow when */
+/* multiplying x(j) times column j. */
+
+ rec /= cnorm[j];
+ }
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ x[j] /= tjjs;
+ xj = (d__1 = x[j], abs(d__1));
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0, and compute a solution to A*x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ x[i__] = 0.;
+/* L90: */
+ }
+ x[j] = 1.;
+ xj = 1.;
+ *scale = 0.;
+ xmax = 0.;
+ }
+L100:
+
+/* Scale x if necessary to avoid overflow when adding a */
+/* multiple of column j of A. */
+
+ if (xj > 1.) {
+ rec = 1. / xj;
+ if (cnorm[j] > (bignum - xmax) * rec) {
+
+/* Scale x by 1/(2*abs(x(j))). */
+
+ rec *= .5;
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ }
+ } else if (xj * cnorm[j] > bignum - xmax) {
+
+/* Scale x by 1/2. */
+
+ dscal_(n, &c_b36, &x[1], &c__1);
+ *scale *= .5;
+ }
+
+ if (upper) {
+ if (j > 1) {
+
+/* Compute the update */
+/* x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) - */
+/* x(j)* A(max(1,j-kd):j-1,j) */
+
+/* Computing MIN */
+ i__3 = *kd, i__4 = j - 1;
+ jlen = min(i__3,i__4);
+ d__1 = -x[j] * tscal;
+ daxpy_(&jlen, &d__1, &ab[*kd + 1 - jlen + j * ab_dim1]
+, &c__1, &x[j - jlen], &c__1);
+ i__3 = j - 1;
+ i__ = idamax_(&i__3, &x[1], &c__1);
+ xmax = (d__1 = x[i__], abs(d__1));
+ }
+ } else if (j < *n) {
+
+/* Compute the update */
+/* x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) - */
+/* x(j) * A(j+1:min(j+kd,n),j) */
+
+/* Computing MIN */
+ i__3 = *kd, i__4 = *n - j;
+ jlen = min(i__3,i__4);
+ if (jlen > 0) {
+ d__1 = -x[j] * tscal;
+ daxpy_(&jlen, &d__1, &ab[j * ab_dim1 + 2], &c__1, &x[
+ j + 1], &c__1);
+ }
+ i__3 = *n - j;
+ i__ = j + idamax_(&i__3, &x[j + 1], &c__1);
+ xmax = (d__1 = x[i__], abs(d__1));
+ }
+/* L110: */
+ }
+
+ } else {
+
+/* Solve A' * x = b */
+
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
+/* k<>j */
+
+ xj = (d__1 = x[j], abs(d__1));
+ uscal = tscal;
+ rec = 1. / max(xmax,1.);
+ if (cnorm[j] > (bignum - xj) * rec) {
+
+/* If x(j) could overflow, scale x by 1/(2*XMAX). */
+
+ rec *= .5;
+ if (nounit) {
+ tjjs = ab[maind + j * ab_dim1] * tscal;
+ } else {
+ tjjs = tscal;
+ }
+ tjj = abs(tjjs);
+ if (tjj > 1.) {
+
+/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
+
+/* Computing MIN */
+ d__1 = 1., d__2 = rec * tjj;
+ rec = min(d__1,d__2);
+ uscal /= tjjs;
+ }
+ if (rec < 1.) {
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ sumj = 0.;
+ if (uscal == 1.) {
+
+/* If the scaling needed for A in the dot product is 1, */
+/* call DDOT to perform the dot product. */
+
+ if (upper) {
+/* Computing MIN */
+ i__3 = *kd, i__4 = j - 1;
+ jlen = min(i__3,i__4);
+ sumj = ddot_(&jlen, &ab[*kd + 1 - jlen + j * ab_dim1],
+ &c__1, &x[j - jlen], &c__1);
+ } else {
+/* Computing MIN */
+ i__3 = *kd, i__4 = *n - j;
+ jlen = min(i__3,i__4);
+ if (jlen > 0) {
+ sumj = ddot_(&jlen, &ab[j * ab_dim1 + 2], &c__1, &
+ x[j + 1], &c__1);
+ }
+ }
+ } else {
+
+/* Otherwise, use in-line code for the dot product. */
+
+ if (upper) {
+/* Computing MIN */
+ i__3 = *kd, i__4 = j - 1;
+ jlen = min(i__3,i__4);
+ i__3 = jlen;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ sumj += ab[*kd + i__ - jlen + j * ab_dim1] *
+ uscal * x[j - jlen - 1 + i__];
+/* L120: */
+ }
+ } else {
+/* Computing MIN */
+ i__3 = *kd, i__4 = *n - j;
+ jlen = min(i__3,i__4);
+ i__3 = jlen;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ sumj += ab[i__ + 1 + j * ab_dim1] * uscal * x[j +
+ i__];
+/* L130: */
+ }
+ }
+ }
+
+ if (uscal == tscal) {
+
+/* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) */
+/* was not used to scale the dotproduct. */
+
+ x[j] -= sumj;
+ xj = (d__1 = x[j], abs(d__1));
+ if (nounit) {
+
+/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
+
+ tjjs = ab[maind + j * ab_dim1] * tscal;
+ } else {
+ tjjs = tscal;
+ if (tscal == 1.) {
+ goto L150;
+ }
+ }
+ tjj = abs(tjjs);
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.) {
+ if (xj > tjj * bignum) {
+
+/* Scale X by 1/abs(x(j)). */
+
+ rec = 1. / xj;
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ x[j] /= tjjs;
+ } else if (tjj > 0.) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
+
+ rec = tjj * bignum / xj;
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ x[j] /= tjjs;
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0, and compute a solution to A'*x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ x[i__] = 0.;
+/* L140: */
+ }
+ x[j] = 1.;
+ *scale = 0.;
+ xmax = 0.;
+ }
+L150:
+ ;
+ } else {
+
+/* Compute x(j) := x(j) / A(j,j) - sumj if the dot */
+/* product has already been divided by 1/A(j,j). */
+
+ x[j] = x[j] / tjjs - sumj;
+ }
+/* Computing MAX */
+ d__2 = xmax, d__3 = (d__1 = x[j], abs(d__1));
+ xmax = max(d__2,d__3);
+/* L160: */
+ }
+ }
+ *scale /= tscal;
+ }
+
+/* Scale the column norms by 1/TSCAL for return. */
+
+ if (tscal != 1.) {
+ d__1 = 1. / tscal;
+ dscal_(n, &d__1, &cnorm[1], &c__1);
+ }
+
+ return 0;
+
+/* End of DLATBS */
+
+} /* dlatbs_ */
diff --git a/SRC/dlatdf.c b/SRC/dlatdf.c
new file mode 100644
index 0000000..263fc87
--- /dev/null
+++ b/SRC/dlatdf.c
@@ -0,0 +1,303 @@
+/* dlatdf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b23 = 1.;
+static doublereal c_b37 = -1.;
+
+/* Subroutine */ int dlatdf_(integer *ijob, integer *n, doublereal *z__,
+ integer *ldz, doublereal *rhs, doublereal *rdsum, doublereal *rdscal,
+ integer *ipiv, integer *jpiv)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal bm, bp, xm[8], xp[8];
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer info;
+ doublereal temp, work[32];
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal pmone;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *);
+ doublereal sminu;
+ integer iwork[8];
+ doublereal splus;
+ extern /* Subroutine */ int dgesc2_(integer *, doublereal *, integer *,
+ doublereal *, integer *, integer *, doublereal *), dgecon_(char *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *), dlassq_(integer *,
+ doublereal *, integer *, doublereal *, doublereal *), dlaswp_(
+ integer *, doublereal *, integer *, integer *, integer *, integer
+ *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLATDF uses the LU factorization of the n-by-n matrix Z computed by */
+/* DGETC2 and computes a contribution to the reciprocal Dif-estimate */
+/* by solving Z * x = b for x, and choosing the r.h.s. b such that */
+/* the norm of x is as large as possible. On entry RHS = b holds the */
+/* contribution from earlier solved sub-systems, and on return RHS = x. */
+
+/* The factorization of Z returned by DGETC2 has the form Z = P*L*U*Q, */
+/* where P and Q are permutation matrices. L is lower triangular with */
+/* unit diagonal elements and U is upper triangular. */
+
+/* Arguments */
+/* ========= */
+
+/* IJOB (input) INTEGER */
+/* IJOB = 2: First compute an approximative null-vector e */
+/* of Z using DGECON, e is normalized and solve for */
+/* Zx = +-e - f with the sign giving the greater value */
+/* of 2-norm(x). About 5 times as expensive as Default. */
+/* IJOB .ne. 2: Local look ahead strategy where all entries of */
+/* the r.h.s. b is choosen as either +1 or -1 (Default). */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Z. */
+
+/* Z (input) DOUBLE PRECISION array, dimension (LDZ, N) */
+/* On entry, the LU part of the factorization of the n-by-n */
+/* matrix Z computed by DGETC2: Z = P * L * U * Q */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDA >= max(1, N). */
+
+/* RHS (input/output) DOUBLE PRECISION array, dimension N. */
+/* On entry, RHS contains contributions from other subsystems. */
+/* On exit, RHS contains the solution of the subsystem with */
+/* entries acoording to the value of IJOB (see above). */
+
+/* RDSUM (input/output) DOUBLE PRECISION */
+/* On entry, the sum of squares of computed contributions to */
+/* the Dif-estimate under computation by DTGSYL, where the */
+/* scaling factor RDSCAL (see below) has been factored out. */
+/* On exit, the corresponding sum of squares updated with the */
+/* contributions from the current sub-system. */
+/* If TRANS = 'T' RDSUM is not touched. */
+/* NOTE: RDSUM only makes sense when DTGSY2 is called by STGSYL. */
+
+/* RDSCAL (input/output) DOUBLE PRECISION */
+/* On entry, scaling factor used to prevent overflow in RDSUM. */
+/* On exit, RDSCAL is updated w.r.t. the current contributions */
+/* in RDSUM. */
+/* If TRANS = 'T', RDSCAL is not touched. */
+/* NOTE: RDSCAL only makes sense when DTGSY2 is called by */
+/* DTGSYL. */
+
+/* IPIV (input) INTEGER array, dimension (N). */
+/* The pivot indices; for 1 <= i <= N, row i of the */
+/* matrix has been interchanged with row IPIV(i). */
+
+/* JPIV (input) INTEGER array, dimension (N). */
+/* The pivot indices; for 1 <= j <= N, column j of the */
+/* matrix has been interchanged with column JPIV(j). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* This routine is a further developed implementation of algorithm */
+/* BSOLVE in [1] using complete pivoting in the LU factorization. */
+
+/* [1] Bo Kagstrom and Lars Westin, */
+/* Generalized Schur Methods with Condition Estimators for */
+/* Solving the Generalized Sylvester Equation, IEEE Transactions */
+/* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. */
+
+/* [2] Peter Poromaa, */
+/* On Efficient and Robust Estimators for the Separation */
+/* between two Regular Matrix Pairs with Applications in */
+/* Condition Estimation. Report IMINF-95.05, Departement of */
+/* Computing Science, Umea University, S-901 87 Umea, Sweden, 1995. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --rhs;
+ --ipiv;
+ --jpiv;
+
+ /* Function Body */
+ if (*ijob != 2) {
+
+/* Apply permutations IPIV to RHS */
+
+ i__1 = *n - 1;
+ dlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &ipiv[1], &c__1);
+
+/* Solve for L-part choosing RHS either to +1 or -1. */
+
+ pmone = -1.;
+
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ bp = rhs[j] + 1.;
+ bm = rhs[j] - 1.;
+ splus = 1.;
+
+/* Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and */
+/* SMIN computed more efficiently than in BSOLVE [1]. */
+
+ i__2 = *n - j;
+ splus += ddot_(&i__2, &z__[j + 1 + j * z_dim1], &c__1, &z__[j + 1
+ + j * z_dim1], &c__1);
+ i__2 = *n - j;
+ sminu = ddot_(&i__2, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1],
+ &c__1);
+ splus *= rhs[j];
+ if (splus > sminu) {
+ rhs[j] = bp;
+ } else if (sminu > splus) {
+ rhs[j] = bm;
+ } else {
+
+/* In this case the updating sums are equal and we can */
+/* choose RHS(J) +1 or -1. The first time this happens */
+/* we choose -1, thereafter +1. This is a simple way to */
+/* get good estimates of matrices like Byers well-known */
+/* example (see [1]). (Not done in BSOLVE.) */
+
+ rhs[j] += pmone;
+ pmone = 1.;
+ }
+
+/* Compute the remaining r.h.s. */
+
+ temp = -rhs[j];
+ i__2 = *n - j;
+ daxpy_(&i__2, &temp, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1],
+ &c__1);
+
+/* L10: */
+ }
+
+/* Solve for U-part, look-ahead for RHS(N) = +-1. This is not done */
+/* in BSOLVE and will hopefully give us a better estimate because */
+/* any ill-conditioning of the original matrix is transfered to U */
+/* and not to L. U(N, N) is an approximation to sigma_min(LU). */
+
+ i__1 = *n - 1;
+ dcopy_(&i__1, &rhs[1], &c__1, xp, &c__1);
+ xp[*n - 1] = rhs[*n] + 1.;
+ rhs[*n] += -1.;
+ splus = 0.;
+ sminu = 0.;
+ for (i__ = *n; i__ >= 1; --i__) {
+ temp = 1. / z__[i__ + i__ * z_dim1];
+ xp[i__ - 1] *= temp;
+ rhs[i__] *= temp;
+ i__1 = *n;
+ for (k = i__ + 1; k <= i__1; ++k) {
+ xp[i__ - 1] -= xp[k - 1] * (z__[i__ + k * z_dim1] * temp);
+ rhs[i__] -= rhs[k] * (z__[i__ + k * z_dim1] * temp);
+/* L20: */
+ }
+ splus += (d__1 = xp[i__ - 1], abs(d__1));
+ sminu += (d__1 = rhs[i__], abs(d__1));
+/* L30: */
+ }
+ if (splus > sminu) {
+ dcopy_(n, xp, &c__1, &rhs[1], &c__1);
+ }
+
+/* Apply the permutations JPIV to the computed solution (RHS) */
+
+ i__1 = *n - 1;
+ dlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &jpiv[1], &c_n1);
+
+/* Compute the sum of squares */
+
+ dlassq_(n, &rhs[1], &c__1, rdscal, rdsum);
+
+ } else {
+
+/* IJOB = 2, Compute approximate nullvector XM of Z */
+
+ dgecon_("I", n, &z__[z_offset], ldz, &c_b23, &temp, work, iwork, &
+ info);
+ dcopy_(n, &work[*n], &c__1, xm, &c__1);
+
+/* Compute RHS */
+
+ i__1 = *n - 1;
+ dlaswp_(&c__1, xm, ldz, &c__1, &i__1, &ipiv[1], &c_n1);
+ temp = 1. / sqrt(ddot_(n, xm, &c__1, xm, &c__1));
+ dscal_(n, &temp, xm, &c__1);
+ dcopy_(n, xm, &c__1, xp, &c__1);
+ daxpy_(n, &c_b23, &rhs[1], &c__1, xp, &c__1);
+ daxpy_(n, &c_b37, xm, &c__1, &rhs[1], &c__1);
+ dgesc2_(n, &z__[z_offset], ldz, &rhs[1], &ipiv[1], &jpiv[1], &temp);
+ dgesc2_(n, &z__[z_offset], ldz, xp, &ipiv[1], &jpiv[1], &temp);
+ if (dasum_(n, xp, &c__1) > dasum_(n, &rhs[1], &c__1)) {
+ dcopy_(n, xp, &c__1, &rhs[1], &c__1);
+ }
+
+/* Compute the sum of squares */
+
+ dlassq_(n, &rhs[1], &c__1, rdscal, rdsum);
+
+ }
+
+ return 0;
+
+/* End of DLATDF */
+
+} /* dlatdf_ */
diff --git a/SRC/dlatps.c b/SRC/dlatps.c
new file mode 100644
index 0000000..ebaa06c
--- /dev/null
+++ b/SRC/dlatps.c
@@ -0,0 +1,824 @@
+/* dlatps.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b36 = .5;
+
+/* Subroutine */ int dlatps_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, doublereal *ap, doublereal *x, doublereal *scale,
+ doublereal *cnorm, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, ip;
+ doublereal xj, rec, tjj;
+ integer jinc, jlen;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal xbnd;
+ integer imax;
+ doublereal tmax, tjjs, xmax, grow, sumj;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ doublereal tscal, uscal;
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ integer jlast;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int dtpsv_(char *, char *, char *, integer *,
+ doublereal *, doublereal *, integer *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ logical notran;
+ integer jfirst;
+ doublereal smlnum;
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLATPS solves one of the triangular systems */
+
+/* A *x = s*b or A'*x = s*b */
+
+/* with scaling to prevent overflow, where A is an upper or lower */
+/* triangular matrix stored in packed form. Here A' denotes the */
+/* transpose of A, x and b are n-element vectors, and s is a scaling */
+/* factor, usually less than or equal to 1, chosen so that the */
+/* components of x will be less than the overflow threshold. If the */
+/* unscaled problem will not cause overflow, the Level 2 BLAS routine */
+/* DTPSV is called. If the matrix A is singular (A(j,j) = 0 for some j), */
+/* then s is set to 0 and a non-trivial solution to A*x = 0 is returned. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': Solve A * x = s*b (No transpose) */
+/* = 'T': Solve A'* x = s*b (Transpose) */
+/* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* NORMIN (input) CHARACTER*1 */
+/* Specifies whether CNORM has been set or not. */
+/* = 'Y': CNORM contains the column norms on entry */
+/* = 'N': CNORM is not set on entry. On exit, the norms will */
+/* be computed and stored in CNORM. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* X (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the right hand side b of the triangular system. */
+/* On exit, X is overwritten by the solution vector x. */
+
+/* SCALE (output) DOUBLE PRECISION */
+/* The scaling factor s for the triangular system */
+/* A * x = s*b or A'* x = s*b. */
+/* If SCALE = 0, the matrix A is singular or badly scaled, and */
+/* the vector x is an exact or approximate solution to A*x = 0. */
+
+/* CNORM (input or output) DOUBLE PRECISION array, dimension (N) */
+
+/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
+/* contains the norm of the off-diagonal part of the j-th column */
+/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */
+/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
+/* must be greater than or equal to the 1-norm. */
+
+/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
+/* returns the 1-norm of the offdiagonal part of the j-th column */
+/* of A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* Further Details */
+/* ======= ======= */
+
+/* A rough bound on x is computed; if that is less than overflow, DTPSV */
+/* is called, otherwise, specific code is used which checks for possible */
+/* overflow or divide-by-zero at every operation. */
+
+/* A columnwise scheme is used for solving A*x = b. The basic algorithm */
+/* if A is lower triangular is */
+
+/* x[1:n] := b[1:n] */
+/* for j = 1, ..., n */
+/* x(j) := x(j) / A(j,j) */
+/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
+/* end */
+
+/* Define bounds on the components of x after j iterations of the loop: */
+/* M(j) = bound on x[1:j] */
+/* G(j) = bound on x[j+1:n] */
+/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */
+
+/* Then for iteration j+1 we have */
+/* M(j+1) <= G(j) / | A(j+1,j+1) | */
+/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
+/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
+
+/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
+/* column j+1 of A, not counting the diagonal. Hence */
+
+/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
+/* 1<=i<=j */
+/* and */
+
+/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
+/* 1<=i< j */
+
+/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTPSV if the */
+/* reciprocal of the largest M(j), j=1,..,n, is larger than */
+/* max(underflow, 1/overflow). */
+
+/* The bound on x(j) is also used to determine when a step in the */
+/* columnwise method can be performed without fear of overflow. If */
+/* the computed bound is greater than a large constant, x is scaled to */
+/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
+/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
+
+/* Similarly, a row-wise scheme is used to solve A'*x = b. The basic */
+/* algorithm for A upper triangular is */
+
+/* for j = 1, ..., n */
+/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
+/* end */
+
+/* We simultaneously compute two bounds */
+/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
+/* M(j) = bound on x(i), 1<=i<=j */
+
+/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */
+/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
+/* Then the bound on x(j) is */
+
+/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
+
+/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
+/* 1<=i<=j */
+
+/* and we can safely call DTPSV if 1/M(n) and 1/G(n) are both greater */
+/* than max(underflow, 1/overflow). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --cnorm;
+ --x;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+/* Test the input parameters. */
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (! lsame_(normin, "Y") && ! lsame_(normin,
+ "N")) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLATPS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine machine dependent parameters to control overflow. */
+
+ smlnum = dlamch_("Safe minimum") / dlamch_("Precision");
+ bignum = 1. / smlnum;
+ *scale = 1.;
+
+ if (lsame_(normin, "N")) {
+
+/* Compute the 1-norm of each column, not including the diagonal. */
+
+ if (upper) {
+
+/* A is upper triangular. */
+
+ ip = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ cnorm[j] = dasum_(&i__2, &ap[ip], &c__1);
+ ip += j;
+/* L10: */
+ }
+ } else {
+
+/* A is lower triangular. */
+
+ ip = 1;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ cnorm[j] = dasum_(&i__2, &ap[ip + 1], &c__1);
+ ip = ip + *n - j + 1;
+/* L20: */
+ }
+ cnorm[*n] = 0.;
+ }
+ }
+
+/* Scale the column norms by TSCAL if the maximum element in CNORM is */
+/* greater than BIGNUM. */
+
+ imax = idamax_(n, &cnorm[1], &c__1);
+ tmax = cnorm[imax];
+ if (tmax <= bignum) {
+ tscal = 1.;
+ } else {
+ tscal = 1. / (smlnum * tmax);
+ dscal_(n, &tscal, &cnorm[1], &c__1);
+ }
+
+/* Compute a bound on the computed solution vector to see if the */
+/* Level 2 BLAS routine DTPSV can be used. */
+
+ j = idamax_(n, &x[1], &c__1);
+ xmax = (d__1 = x[j], abs(d__1));
+ xbnd = xmax;
+ if (notran) {
+
+/* Compute the growth in A * x = b. */
+
+ if (upper) {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ } else {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ }
+
+ if (tscal != 1.) {
+ grow = 0.;
+ goto L50;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, G(0) = max{x(i), i=1,...,n}. */
+
+ grow = 1. / max(xbnd,smlnum);
+ xbnd = grow;
+ ip = jfirst * (jfirst + 1) / 2;
+ jlen = *n;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L50;
+ }
+
+/* M(j) = G(j-1) / abs(A(j,j)) */
+
+ tjj = (d__1 = ap[ip], abs(d__1));
+/* Computing MIN */
+ d__1 = xbnd, d__2 = min(1.,tjj) * grow;
+ xbnd = min(d__1,d__2);
+ if (tjj + cnorm[j] >= smlnum) {
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
+
+ grow *= tjj / (tjj + cnorm[j]);
+ } else {
+
+/* G(j) could overflow, set GROW to 0. */
+
+ grow = 0.;
+ }
+ ip += jinc * jlen;
+ --jlen;
+/* L30: */
+ }
+ grow = xbnd;
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ d__1 = 1., d__2 = 1. / max(xbnd,smlnum);
+ grow = min(d__1,d__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L50;
+ }
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
+
+ grow *= 1. / (cnorm[j] + 1.);
+/* L40: */
+ }
+ }
+L50:
+
+ ;
+ } else {
+
+/* Compute the growth in A' * x = b. */
+
+ if (upper) {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ } else {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ }
+
+ if (tscal != 1.) {
+ grow = 0.;
+ goto L80;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, M(0) = max{x(i), i=1,...,n}. */
+
+ grow = 1. / max(xbnd,smlnum);
+ xbnd = grow;
+ ip = jfirst * (jfirst + 1) / 2;
+ jlen = 1;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L80;
+ }
+
+/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
+
+ xj = cnorm[j] + 1.;
+/* Computing MIN */
+ d__1 = grow, d__2 = xbnd / xj;
+ grow = min(d__1,d__2);
+
+/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
+
+ tjj = (d__1 = ap[ip], abs(d__1));
+ if (xj > tjj) {
+ xbnd *= tjj / xj;
+ }
+ ++jlen;
+ ip += jinc * jlen;
+/* L60: */
+ }
+ grow = min(grow,xbnd);
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ d__1 = 1., d__2 = 1. / max(xbnd,smlnum);
+ grow = min(d__1,d__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L80;
+ }
+
+/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
+
+ xj = cnorm[j] + 1.;
+ grow /= xj;
+/* L70: */
+ }
+ }
+L80:
+ ;
+ }
+
+ if (grow * tscal > smlnum) {
+
+/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
+/* elements of X is not too small. */
+
+ dtpsv_(uplo, trans, diag, n, &ap[1], &x[1], &c__1);
+ } else {
+
+/* Use a Level 1 BLAS solve, scaling intermediate results. */
+
+ if (xmax > bignum) {
+
+/* Scale X so that its components are less than or equal to */
+/* BIGNUM in absolute value. */
+
+ *scale = bignum / xmax;
+ dscal_(n, scale, &x[1], &c__1);
+ xmax = bignum;
+ }
+
+ if (notran) {
+
+/* Solve A * x = b */
+
+ ip = jfirst * (jfirst + 1) / 2;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
+
+ xj = (d__1 = x[j], abs(d__1));
+ if (nounit) {
+ tjjs = ap[ip] * tscal;
+ } else {
+ tjjs = tscal;
+ if (tscal == 1.) {
+ goto L100;
+ }
+ }
+ tjj = abs(tjjs);
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.) {
+ if (xj > tjj * bignum) {
+
+/* Scale x by 1/b(j). */
+
+ rec = 1. / xj;
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ x[j] /= tjjs;
+ xj = (d__1 = x[j], abs(d__1));
+ } else if (tjj > 0.) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
+/* to avoid overflow when dividing by A(j,j). */
+
+ rec = tjj * bignum / xj;
+ if (cnorm[j] > 1.) {
+
+/* Scale by 1/CNORM(j) to avoid overflow when */
+/* multiplying x(j) times column j. */
+
+ rec /= cnorm[j];
+ }
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ x[j] /= tjjs;
+ xj = (d__1 = x[j], abs(d__1));
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0, and compute a solution to A*x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ x[i__] = 0.;
+/* L90: */
+ }
+ x[j] = 1.;
+ xj = 1.;
+ *scale = 0.;
+ xmax = 0.;
+ }
+L100:
+
+/* Scale x if necessary to avoid overflow when adding a */
+/* multiple of column j of A. */
+
+ if (xj > 1.) {
+ rec = 1. / xj;
+ if (cnorm[j] > (bignum - xmax) * rec) {
+
+/* Scale x by 1/(2*abs(x(j))). */
+
+ rec *= .5;
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ }
+ } else if (xj * cnorm[j] > bignum - xmax) {
+
+/* Scale x by 1/2. */
+
+ dscal_(n, &c_b36, &x[1], &c__1);
+ *scale *= .5;
+ }
+
+ if (upper) {
+ if (j > 1) {
+
+/* Compute the update */
+/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */
+
+ i__3 = j - 1;
+ d__1 = -x[j] * tscal;
+ daxpy_(&i__3, &d__1, &ap[ip - j + 1], &c__1, &x[1], &
+ c__1);
+ i__3 = j - 1;
+ i__ = idamax_(&i__3, &x[1], &c__1);
+ xmax = (d__1 = x[i__], abs(d__1));
+ }
+ ip -= j;
+ } else {
+ if (j < *n) {
+
+/* Compute the update */
+/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */
+
+ i__3 = *n - j;
+ d__1 = -x[j] * tscal;
+ daxpy_(&i__3, &d__1, &ap[ip + 1], &c__1, &x[j + 1], &
+ c__1);
+ i__3 = *n - j;
+ i__ = j + idamax_(&i__3, &x[j + 1], &c__1);
+ xmax = (d__1 = x[i__], abs(d__1));
+ }
+ ip = ip + *n - j + 1;
+ }
+/* L110: */
+ }
+
+ } else {
+
+/* Solve A' * x = b */
+
+ ip = jfirst * (jfirst + 1) / 2;
+ jlen = 1;
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
+/* k<>j */
+
+ xj = (d__1 = x[j], abs(d__1));
+ uscal = tscal;
+ rec = 1. / max(xmax,1.);
+ if (cnorm[j] > (bignum - xj) * rec) {
+
+/* If x(j) could overflow, scale x by 1/(2*XMAX). */
+
+ rec *= .5;
+ if (nounit) {
+ tjjs = ap[ip] * tscal;
+ } else {
+ tjjs = tscal;
+ }
+ tjj = abs(tjjs);
+ if (tjj > 1.) {
+
+/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
+
+/* Computing MIN */
+ d__1 = 1., d__2 = rec * tjj;
+ rec = min(d__1,d__2);
+ uscal /= tjjs;
+ }
+ if (rec < 1.) {
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ sumj = 0.;
+ if (uscal == 1.) {
+
+/* If the scaling needed for A in the dot product is 1, */
+/* call DDOT to perform the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ sumj = ddot_(&i__3, &ap[ip - j + 1], &c__1, &x[1], &
+ c__1);
+ } else if (j < *n) {
+ i__3 = *n - j;
+ sumj = ddot_(&i__3, &ap[ip + 1], &c__1, &x[j + 1], &
+ c__1);
+ }
+ } else {
+
+/* Otherwise, use in-line code for the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ sumj += ap[ip - j + i__] * uscal * x[i__];
+/* L120: */
+ }
+ } else if (j < *n) {
+ i__3 = *n - j;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ sumj += ap[ip + i__] * uscal * x[j + i__];
+/* L130: */
+ }
+ }
+ }
+
+ if (uscal == tscal) {
+
+/* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) */
+/* was not used to scale the dotproduct. */
+
+ x[j] -= sumj;
+ xj = (d__1 = x[j], abs(d__1));
+ if (nounit) {
+
+/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
+
+ tjjs = ap[ip] * tscal;
+ } else {
+ tjjs = tscal;
+ if (tscal == 1.) {
+ goto L150;
+ }
+ }
+ tjj = abs(tjjs);
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.) {
+ if (xj > tjj * bignum) {
+
+/* Scale X by 1/abs(x(j)). */
+
+ rec = 1. / xj;
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ x[j] /= tjjs;
+ } else if (tjj > 0.) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
+
+ rec = tjj * bignum / xj;
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ x[j] /= tjjs;
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0, and compute a solution to A'*x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ x[i__] = 0.;
+/* L140: */
+ }
+ x[j] = 1.;
+ *scale = 0.;
+ xmax = 0.;
+ }
+L150:
+ ;
+ } else {
+
+/* Compute x(j) := x(j) / A(j,j) - sumj if the dot */
+/* product has already been divided by 1/A(j,j). */
+
+ x[j] = x[j] / tjjs - sumj;
+ }
+/* Computing MAX */
+ d__2 = xmax, d__3 = (d__1 = x[j], abs(d__1));
+ xmax = max(d__2,d__3);
+ ++jlen;
+ ip += jinc * jlen;
+/* L160: */
+ }
+ }
+ *scale /= tscal;
+ }
+
+/* Scale the column norms by 1/TSCAL for return. */
+
+ if (tscal != 1.) {
+ d__1 = 1. / tscal;
+ dscal_(n, &d__1, &cnorm[1], &c__1);
+ }
+
+ return 0;
+
+/* End of DLATPS */
+
+} /* dlatps_ */
diff --git a/SRC/dlatrd.c b/SRC/dlatrd.c
new file mode 100644
index 0000000..6d07750
--- /dev/null
+++ b/SRC/dlatrd.c
@@ -0,0 +1,355 @@
+/* dlatrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b5 = -1.;
+static doublereal c_b6 = 1.;
+static integer c__1 = 1;
+static doublereal c_b16 = 0.;
+
+/* Subroutine */ int dlatrd_(char *uplo, integer *n, integer *nb, doublereal *
+ a, integer *lda, doublereal *e, doublereal *tau, doublereal *w,
+ integer *ldw)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, iw;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal alpha;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), daxpy_(integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *),
+ dsymv_(char *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *), dlarfg_(integer *, doublereal *, doublereal *, integer *,
+ doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLATRD reduces NB rows and columns of a real symmetric matrix A to */
+/* symmetric tridiagonal form by an orthogonal similarity */
+/* transformation Q' * A * Q, and returns the matrices V and W which are */
+/* needed to apply the transformation to the unreduced part of A. */
+
+/* If UPLO = 'U', DLATRD reduces the last NB rows and columns of a */
+/* matrix, of which the upper triangle is supplied; */
+/* if UPLO = 'L', DLATRD reduces the first NB rows and columns of a */
+/* matrix, of which the lower triangle is supplied. */
+
+/* This is an auxiliary routine called by DSYTRD. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* NB (input) INTEGER */
+/* The number of rows and columns to be reduced. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n-by-n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n-by-n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+/* On exit: */
+/* if UPLO = 'U', the last NB columns have been reduced to */
+/* tridiagonal form, with the diagonal elements overwriting */
+/* the diagonal elements of A; the elements above the diagonal */
+/* with the array TAU, represent the orthogonal matrix Q as a */
+/* product of elementary reflectors; */
+/* if UPLO = 'L', the first NB columns have been reduced to */
+/* tridiagonal form, with the diagonal elements overwriting */
+/* the diagonal elements of A; the elements below the diagonal */
+/* with the array TAU, represent the orthogonal matrix Q as a */
+/* product of elementary reflectors. */
+/* See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= (1,N). */
+
+/* E (output) DOUBLE PRECISION array, dimension (N-1) */
+/* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal */
+/* elements of the last NB columns of the reduced matrix; */
+/* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of */
+/* the first NB columns of the reduced matrix. */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors, stored in */
+/* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. */
+/* See Further Details. */
+
+/* W (output) DOUBLE PRECISION array, dimension (LDW,NB) */
+/* The n-by-nb matrix W required to update the unreduced part */
+/* of A. */
+
+/* LDW (input) INTEGER */
+/* The leading dimension of the array W. LDW >= max(1,N). */
+
+/* Further Details */
+/* =============== */
+
+/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(n) H(n-1) . . . H(n-nb+1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), */
+/* and tau in TAU(i-1). */
+
+/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(1) H(2) . . . H(nb). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */
+/* and tau in TAU(i). */
+
+/* The elements of the vectors v together form the n-by-nb matrix V */
+/* which is needed, with W, to apply the transformation to the unreduced */
+/* part of the matrix, using a symmetric rank-2k update of the form: */
+/* A := A - V*W' - W*V'. */
+
+/* The contents of A on exit are illustrated by the following examples */
+/* with n = 5 and nb = 2: */
+
+/* if UPLO = 'U': if UPLO = 'L': */
+
+/* ( a a a v4 v5 ) ( d ) */
+/* ( a a v4 v5 ) ( 1 d ) */
+/* ( a 1 v5 ) ( v1 1 a ) */
+/* ( d 1 ) ( v1 v2 a a ) */
+/* ( d ) ( v1 v2 a a a ) */
+
+/* where d denotes a diagonal element of the reduced matrix, a denotes */
+/* an element of the original matrix that is unchanged, and vi denotes */
+/* an element of the vector defining H(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --e;
+ --tau;
+ w_dim1 = *ldw;
+ w_offset = 1 + w_dim1;
+ w -= w_offset;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+
+ if (lsame_(uplo, "U")) {
+
+/* Reduce last NB columns of upper triangle */
+
+ i__1 = *n - *nb + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ iw = i__ - *n + *nb;
+ if (i__ < *n) {
+
+/* Update A(1:i,i) */
+
+ i__2 = *n - i__;
+ dgemv_("No transpose", &i__, &i__2, &c_b5, &a[(i__ + 1) *
+ a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, &
+ c_b6, &a[i__ * a_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ dgemv_("No transpose", &i__, &i__2, &c_b5, &w[(iw + 1) *
+ w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, &
+ c_b6, &a[i__ * a_dim1 + 1], &c__1);
+ }
+ if (i__ > 1) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* A(1:i-2,i) */
+
+ i__2 = i__ - 1;
+ dlarfg_(&i__2, &a[i__ - 1 + i__ * a_dim1], &a[i__ * a_dim1 +
+ 1], &c__1, &tau[i__ - 1]);
+ e[i__ - 1] = a[i__ - 1 + i__ * a_dim1];
+ a[i__ - 1 + i__ * a_dim1] = 1.;
+
+/* Compute W(1:i-1,i) */
+
+ i__2 = i__ - 1;
+ dsymv_("Upper", &i__2, &c_b6, &a[a_offset], lda, &a[i__ *
+ a_dim1 + 1], &c__1, &c_b16, &w[iw * w_dim1 + 1], &
+ c__1);
+ if (i__ < *n) {
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ dgemv_("Transpose", &i__2, &i__3, &c_b6, &w[(iw + 1) *
+ w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], &c__1, &
+ c_b16, &w[i__ + 1 + iw * w_dim1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) *
+ a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], &
+ c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ dgemv_("Transpose", &i__2, &i__3, &c_b6, &a[(i__ + 1) *
+ a_dim1 + 1], lda, &a[i__ * a_dim1 + 1], &c__1, &
+ c_b16, &w[i__ + 1 + iw * w_dim1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ dgemv_("No transpose", &i__2, &i__3, &c_b5, &w[(iw + 1) *
+ w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], &
+ c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1);
+ }
+ i__2 = i__ - 1;
+ dscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ alpha = tau[i__ - 1] * -.5 * ddot_(&i__2, &w[iw * w_dim1 + 1],
+ &c__1, &a[i__ * a_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ daxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw *
+ w_dim1 + 1], &c__1);
+ }
+
+/* L10: */
+ }
+ } else {
+
+/* Reduce first NB columns of lower triangle */
+
+ i__1 = *nb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Update A(i:n,i) */
+
+ i__2 = *n - i__ + 1;
+ i__3 = i__ - 1;
+ dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1], lda,
+ &w[i__ + w_dim1], ldw, &c_b6, &a[i__ + i__ * a_dim1], &
+ c__1);
+ i__2 = *n - i__ + 1;
+ i__3 = i__ - 1;
+ dgemv_("No transpose", &i__2, &i__3, &c_b5, &w[i__ + w_dim1], ldw,
+ &a[i__ + a_dim1], lda, &c_b6, &a[i__ + i__ * a_dim1], &
+ c__1);
+ if (i__ < *n) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* A(i+2:n,i) */
+
+ i__2 = *n - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *n)+
+ i__ * a_dim1], &c__1, &tau[i__]);
+ e[i__] = a[i__ + 1 + i__ * a_dim1];
+ a[i__ + 1 + i__ * a_dim1] = 1.;
+
+/* Compute W(i+1:n,i) */
+
+ i__2 = *n - i__;
+ dsymv_("Lower", &i__2, &c_b6, &a[i__ + 1 + (i__ + 1) * a_dim1]
+, lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[
+ i__ + 1 + i__ * w_dim1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ dgemv_("Transpose", &i__2, &i__3, &c_b6, &w[i__ + 1 + w_dim1],
+ ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[
+ i__ * w_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ dgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 +
+ a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[
+ i__ + 1 + i__ * w_dim1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ dgemv_("Transpose", &i__2, &i__3, &c_b6, &a[i__ + 1 + a_dim1],
+ lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[
+ i__ * w_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ dgemv_("No transpose", &i__2, &i__3, &c_b5, &w[i__ + 1 +
+ w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[
+ i__ + 1 + i__ * w_dim1], &c__1);
+ i__2 = *n - i__;
+ dscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1);
+ i__2 = *n - i__;
+ alpha = tau[i__] * -.5 * ddot_(&i__2, &w[i__ + 1 + i__ *
+ w_dim1], &c__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
+ i__2 = *n - i__;
+ daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[
+ i__ + 1 + i__ * w_dim1], &c__1);
+ }
+
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of DLATRD */
+
+} /* dlatrd_ */
diff --git a/SRC/dlatrs.c b/SRC/dlatrs.c
new file mode 100644
index 0000000..2bb2784
--- /dev/null
+++ b/SRC/dlatrs.c
@@ -0,0 +1,815 @@
+/* dlatrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b36 = .5;
+
+/* Subroutine */ int dlatrs_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, doublereal *a, integer *lda, doublereal *x,
+ doublereal *scale, doublereal *cnorm, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal xj, rec, tjj;
+ integer jinc;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal xbnd;
+ integer imax;
+ doublereal tmax, tjjs, xmax, grow, sumj;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ doublereal tscal, uscal;
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ integer jlast;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int dtrsv_(char *, char *, char *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ logical notran;
+ integer jfirst;
+ doublereal smlnum;
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLATRS solves one of the triangular systems */
+
+/* A *x = s*b or A'*x = s*b */
+
+/* with scaling to prevent overflow. Here A is an upper or lower */
+/* triangular matrix, A' denotes the transpose of A, x and b are */
+/* n-element vectors, and s is a scaling factor, usually less than */
+/* or equal to 1, chosen so that the components of x will be less than */
+/* the overflow threshold. If the unscaled problem will not cause */
+/* overflow, the Level 2 BLAS routine DTRSV is called. If the matrix A */
+/* is singular (A(j,j) = 0 for some j), then s is set to 0 and a */
+/* non-trivial solution to A*x = 0 is returned. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': Solve A * x = s*b (No transpose) */
+/* = 'T': Solve A'* x = s*b (Transpose) */
+/* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* NORMIN (input) CHARACTER*1 */
+/* Specifies whether CNORM has been set or not. */
+/* = 'Y': CNORM contains the column norms on entry */
+/* = 'N': CNORM is not set on entry. On exit, the norms will */
+/* be computed and stored in CNORM. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max (1,N). */
+
+/* X (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the right hand side b of the triangular system. */
+/* On exit, X is overwritten by the solution vector x. */
+
+/* SCALE (output) DOUBLE PRECISION */
+/* The scaling factor s for the triangular system */
+/* A * x = s*b or A'* x = s*b. */
+/* If SCALE = 0, the matrix A is singular or badly scaled, and */
+/* the vector x is an exact or approximate solution to A*x = 0. */
+
+/* CNORM (input or output) DOUBLE PRECISION array, dimension (N) */
+
+/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
+/* contains the norm of the off-diagonal part of the j-th column */
+/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */
+/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
+/* must be greater than or equal to the 1-norm. */
+
+/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
+/* returns the 1-norm of the offdiagonal part of the j-th column */
+/* of A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* Further Details */
+/* ======= ======= */
+
+/* A rough bound on x is computed; if that is less than overflow, DTRSV */
+/* is called, otherwise, specific code is used which checks for possible */
+/* overflow or divide-by-zero at every operation. */
+
+/* A columnwise scheme is used for solving A*x = b. The basic algorithm */
+/* if A is lower triangular is */
+
+/* x[1:n] := b[1:n] */
+/* for j = 1, ..., n */
+/* x(j) := x(j) / A(j,j) */
+/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
+/* end */
+
+/* Define bounds on the components of x after j iterations of the loop: */
+/* M(j) = bound on x[1:j] */
+/* G(j) = bound on x[j+1:n] */
+/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */
+
+/* Then for iteration j+1 we have */
+/* M(j+1) <= G(j) / | A(j+1,j+1) | */
+/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
+/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
+
+/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
+/* column j+1 of A, not counting the diagonal. Hence */
+
+/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
+/* 1<=i<=j */
+/* and */
+
+/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
+/* 1<=i< j */
+
+/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the */
+/* reciprocal of the largest M(j), j=1,..,n, is larger than */
+/* max(underflow, 1/overflow). */
+
+/* The bound on x(j) is also used to determine when a step in the */
+/* columnwise method can be performed without fear of overflow. If */
+/* the computed bound is greater than a large constant, x is scaled to */
+/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
+/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
+
+/* Similarly, a row-wise scheme is used to solve A'*x = b. The basic */
+/* algorithm for A upper triangular is */
+
+/* for j = 1, ..., n */
+/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
+/* end */
+
+/* We simultaneously compute two bounds */
+/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
+/* M(j) = bound on x(i), 1<=i<=j */
+
+/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */
+/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
+/* Then the bound on x(j) is */
+
+/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
+
+/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
+/* 1<=i<=j */
+
+/* and we can safely call DTRSV if 1/M(n) and 1/G(n) are both greater */
+/* than max(underflow, 1/overflow). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --cnorm;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+/* Test the input parameters. */
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (! lsame_(normin, "Y") && ! lsame_(normin,
+ "N")) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLATRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine machine dependent parameters to control overflow. */
+
+ smlnum = dlamch_("Safe minimum") / dlamch_("Precision");
+ bignum = 1. / smlnum;
+ *scale = 1.;
+
+ if (lsame_(normin, "N")) {
+
+/* Compute the 1-norm of each column, not including the diagonal. */
+
+ if (upper) {
+
+/* A is upper triangular. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ cnorm[j] = dasum_(&i__2, &a[j * a_dim1 + 1], &c__1);
+/* L10: */
+ }
+ } else {
+
+/* A is lower triangular. */
+
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ cnorm[j] = dasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1);
+/* L20: */
+ }
+ cnorm[*n] = 0.;
+ }
+ }
+
+/* Scale the column norms by TSCAL if the maximum element in CNORM is */
+/* greater than BIGNUM. */
+
+ imax = idamax_(n, &cnorm[1], &c__1);
+ tmax = cnorm[imax];
+ if (tmax <= bignum) {
+ tscal = 1.;
+ } else {
+ tscal = 1. / (smlnum * tmax);
+ dscal_(n, &tscal, &cnorm[1], &c__1);
+ }
+
+/* Compute a bound on the computed solution vector to see if the */
+/* Level 2 BLAS routine DTRSV can be used. */
+
+ j = idamax_(n, &x[1], &c__1);
+ xmax = (d__1 = x[j], abs(d__1));
+ xbnd = xmax;
+ if (notran) {
+
+/* Compute the growth in A * x = b. */
+
+ if (upper) {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ } else {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ }
+
+ if (tscal != 1.) {
+ grow = 0.;
+ goto L50;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, G(0) = max{x(i), i=1,...,n}. */
+
+ grow = 1. / max(xbnd,smlnum);
+ xbnd = grow;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L50;
+ }
+
+/* M(j) = G(j-1) / abs(A(j,j)) */
+
+ tjj = (d__1 = a[j + j * a_dim1], abs(d__1));
+/* Computing MIN */
+ d__1 = xbnd, d__2 = min(1.,tjj) * grow;
+ xbnd = min(d__1,d__2);
+ if (tjj + cnorm[j] >= smlnum) {
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
+
+ grow *= tjj / (tjj + cnorm[j]);
+ } else {
+
+/* G(j) could overflow, set GROW to 0. */
+
+ grow = 0.;
+ }
+/* L30: */
+ }
+ grow = xbnd;
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ d__1 = 1., d__2 = 1. / max(xbnd,smlnum);
+ grow = min(d__1,d__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L50;
+ }
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
+
+ grow *= 1. / (cnorm[j] + 1.);
+/* L40: */
+ }
+ }
+L50:
+
+ ;
+ } else {
+
+/* Compute the growth in A' * x = b. */
+
+ if (upper) {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ } else {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ }
+
+ if (tscal != 1.) {
+ grow = 0.;
+ goto L80;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, M(0) = max{x(i), i=1,...,n}. */
+
+ grow = 1. / max(xbnd,smlnum);
+ xbnd = grow;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L80;
+ }
+
+/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
+
+ xj = cnorm[j] + 1.;
+/* Computing MIN */
+ d__1 = grow, d__2 = xbnd / xj;
+ grow = min(d__1,d__2);
+
+/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
+
+ tjj = (d__1 = a[j + j * a_dim1], abs(d__1));
+ if (xj > tjj) {
+ xbnd *= tjj / xj;
+ }
+/* L60: */
+ }
+ grow = min(grow,xbnd);
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ d__1 = 1., d__2 = 1. / max(xbnd,smlnum);
+ grow = min(d__1,d__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L80;
+ }
+
+/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
+
+ xj = cnorm[j] + 1.;
+ grow /= xj;
+/* L70: */
+ }
+ }
+L80:
+ ;
+ }
+
+ if (grow * tscal > smlnum) {
+
+/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
+/* elements of X is not too small. */
+
+ dtrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1);
+ } else {
+
+/* Use a Level 1 BLAS solve, scaling intermediate results. */
+
+ if (xmax > bignum) {
+
+/* Scale X so that its components are less than or equal to */
+/* BIGNUM in absolute value. */
+
+ *scale = bignum / xmax;
+ dscal_(n, scale, &x[1], &c__1);
+ xmax = bignum;
+ }
+
+ if (notran) {
+
+/* Solve A * x = b */
+
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
+
+ xj = (d__1 = x[j], abs(d__1));
+ if (nounit) {
+ tjjs = a[j + j * a_dim1] * tscal;
+ } else {
+ tjjs = tscal;
+ if (tscal == 1.) {
+ goto L100;
+ }
+ }
+ tjj = abs(tjjs);
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.) {
+ if (xj > tjj * bignum) {
+
+/* Scale x by 1/b(j). */
+
+ rec = 1. / xj;
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ x[j] /= tjjs;
+ xj = (d__1 = x[j], abs(d__1));
+ } else if (tjj > 0.) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
+/* to avoid overflow when dividing by A(j,j). */
+
+ rec = tjj * bignum / xj;
+ if (cnorm[j] > 1.) {
+
+/* Scale by 1/CNORM(j) to avoid overflow when */
+/* multiplying x(j) times column j. */
+
+ rec /= cnorm[j];
+ }
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ x[j] /= tjjs;
+ xj = (d__1 = x[j], abs(d__1));
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0, and compute a solution to A*x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ x[i__] = 0.;
+/* L90: */
+ }
+ x[j] = 1.;
+ xj = 1.;
+ *scale = 0.;
+ xmax = 0.;
+ }
+L100:
+
+/* Scale x if necessary to avoid overflow when adding a */
+/* multiple of column j of A. */
+
+ if (xj > 1.) {
+ rec = 1. / xj;
+ if (cnorm[j] > (bignum - xmax) * rec) {
+
+/* Scale x by 1/(2*abs(x(j))). */
+
+ rec *= .5;
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ }
+ } else if (xj * cnorm[j] > bignum - xmax) {
+
+/* Scale x by 1/2. */
+
+ dscal_(n, &c_b36, &x[1], &c__1);
+ *scale *= .5;
+ }
+
+ if (upper) {
+ if (j > 1) {
+
+/* Compute the update */
+/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */
+
+ i__3 = j - 1;
+ d__1 = -x[j] * tscal;
+ daxpy_(&i__3, &d__1, &a[j * a_dim1 + 1], &c__1, &x[1],
+ &c__1);
+ i__3 = j - 1;
+ i__ = idamax_(&i__3, &x[1], &c__1);
+ xmax = (d__1 = x[i__], abs(d__1));
+ }
+ } else {
+ if (j < *n) {
+
+/* Compute the update */
+/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */
+
+ i__3 = *n - j;
+ d__1 = -x[j] * tscal;
+ daxpy_(&i__3, &d__1, &a[j + 1 + j * a_dim1], &c__1, &
+ x[j + 1], &c__1);
+ i__3 = *n - j;
+ i__ = j + idamax_(&i__3, &x[j + 1], &c__1);
+ xmax = (d__1 = x[i__], abs(d__1));
+ }
+ }
+/* L110: */
+ }
+
+ } else {
+
+/* Solve A' * x = b */
+
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
+/* k<>j */
+
+ xj = (d__1 = x[j], abs(d__1));
+ uscal = tscal;
+ rec = 1. / max(xmax,1.);
+ if (cnorm[j] > (bignum - xj) * rec) {
+
+/* If x(j) could overflow, scale x by 1/(2*XMAX). */
+
+ rec *= .5;
+ if (nounit) {
+ tjjs = a[j + j * a_dim1] * tscal;
+ } else {
+ tjjs = tscal;
+ }
+ tjj = abs(tjjs);
+ if (tjj > 1.) {
+
+/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
+
+/* Computing MIN */
+ d__1 = 1., d__2 = rec * tjj;
+ rec = min(d__1,d__2);
+ uscal /= tjjs;
+ }
+ if (rec < 1.) {
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ sumj = 0.;
+ if (uscal == 1.) {
+
+/* If the scaling needed for A in the dot product is 1, */
+/* call DDOT to perform the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ sumj = ddot_(&i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
+ &c__1);
+ } else if (j < *n) {
+ i__3 = *n - j;
+ sumj = ddot_(&i__3, &a[j + 1 + j * a_dim1], &c__1, &x[
+ j + 1], &c__1);
+ }
+ } else {
+
+/* Otherwise, use in-line code for the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ sumj += a[i__ + j * a_dim1] * uscal * x[i__];
+/* L120: */
+ }
+ } else if (j < *n) {
+ i__3 = *n;
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ sumj += a[i__ + j * a_dim1] * uscal * x[i__];
+/* L130: */
+ }
+ }
+ }
+
+ if (uscal == tscal) {
+
+/* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) */
+/* was not used to scale the dotproduct. */
+
+ x[j] -= sumj;
+ xj = (d__1 = x[j], abs(d__1));
+ if (nounit) {
+ tjjs = a[j + j * a_dim1] * tscal;
+ } else {
+ tjjs = tscal;
+ if (tscal == 1.) {
+ goto L150;
+ }
+ }
+
+/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
+
+ tjj = abs(tjjs);
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.) {
+ if (xj > tjj * bignum) {
+
+/* Scale X by 1/abs(x(j)). */
+
+ rec = 1. / xj;
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ x[j] /= tjjs;
+ } else if (tjj > 0.) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
+
+ rec = tjj * bignum / xj;
+ dscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ x[j] /= tjjs;
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0, and compute a solution to A'*x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ x[i__] = 0.;
+/* L140: */
+ }
+ x[j] = 1.;
+ *scale = 0.;
+ xmax = 0.;
+ }
+L150:
+ ;
+ } else {
+
+/* Compute x(j) := x(j) / A(j,j) - sumj if the dot */
+/* product has already been divided by 1/A(j,j). */
+
+ x[j] = x[j] / tjjs - sumj;
+ }
+/* Computing MAX */
+ d__2 = xmax, d__3 = (d__1 = x[j], abs(d__1));
+ xmax = max(d__2,d__3);
+/* L160: */
+ }
+ }
+ *scale /= tscal;
+ }
+
+/* Scale the column norms by 1/TSCAL for return. */
+
+ if (tscal != 1.) {
+ d__1 = 1. / tscal;
+ dscal_(n, &d__1, &cnorm[1], &c__1);
+ }
+
+ return 0;
+
+/* End of DLATRS */
+
+} /* dlatrs_ */
diff --git a/SRC/dlatrz.c b/SRC/dlatrz.c
new file mode 100644
index 0000000..9590da3
--- /dev/null
+++ b/SRC/dlatrz.c
@@ -0,0 +1,163 @@
+/* dlatrz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlatrz_(integer *m, integer *n, integer *l, doublereal *
+ a, integer *lda, doublereal *tau, doublereal *work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__;
+ extern /* Subroutine */ int dlarz_(char *, integer *, integer *, integer *
+, doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *), dlarfp_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLATRZ factors the M-by-(M+L) real upper trapezoidal matrix */
+/* [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z, by means */
+/* of orthogonal transformations. Z is an (M+L)-by-(M+L) orthogonal */
+/* matrix and, R and A1 are M-by-M upper triangular matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* L (input) INTEGER */
+/* The number of columns of the matrix A containing the */
+/* meaningful part of the Householder vectors. N-M >= L >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the leading M-by-N upper trapezoidal part of the */
+/* array A must contain the matrix to be factorized. */
+/* On exit, the leading M-by-M upper triangular part of A */
+/* contains the upper triangular matrix R, and elements N-L+1 to */
+/* N of the first M rows of A, with the array TAU, represent the */
+/* orthogonal matrix Z as a product of M elementary reflectors. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (M) */
+/* The scalar factors of the elementary reflectors. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* The factorization is obtained by Householder's method. The kth */
+/* transformation matrix, Z( k ), which is used to introduce zeros into */
+/* the ( m - k + 1 )th row of A, is given in the form */
+
+/* Z( k ) = ( I 0 ), */
+/* ( 0 T( k ) ) */
+
+/* where */
+
+/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */
+/* ( 0 ) */
+/* ( z( k ) ) */
+
+/* tau is a scalar and z( k ) is an l element vector. tau and z( k ) */
+/* are chosen to annihilate the elements of the kth row of A2. */
+
+/* The scalar tau is returned in the kth element of TAU and the vector */
+/* u( k ) in the kth row of A2, such that the elements of z( k ) are */
+/* in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in */
+/* the upper triangular part of A1. */
+
+/* Z is given by */
+
+/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ if (*m == 0) {
+ return 0;
+ } else if (*m == *n) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tau[i__] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+ for (i__ = *m; i__ >= 1; --i__) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* [ A(i,i) A(i,n-l+1:n) ] */
+
+ i__1 = *l + 1;
+ dlarfp_(&i__1, &a[i__ + i__ * a_dim1], &a[i__ + (*n - *l + 1) *
+ a_dim1], lda, &tau[i__]);
+
+/* Apply H(i) to A(1:i-1,i:n) from the right */
+
+ i__1 = i__ - 1;
+ i__2 = *n - i__ + 1;
+ dlarz_("Right", &i__1, &i__2, l, &a[i__ + (*n - *l + 1) * a_dim1],
+ lda, &tau[i__], &a[i__ * a_dim1 + 1], lda, &work[1]);
+
+/* L20: */
+ }
+
+ return 0;
+
+/* End of DLATRZ */
+
+} /* dlatrz_ */
diff --git a/SRC/dlatzm.c b/SRC/dlatzm.c
new file mode 100644
index 0000000..3ba8a8c
--- /dev/null
+++ b/SRC/dlatzm.c
@@ -0,0 +1,193 @@
+/* dlatzm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b5 = 1.;
+
+/* Subroutine */ int dlatzm_(char *side, integer *m, integer *n, doublereal *
+ v, integer *incv, doublereal *tau, doublereal *c1, doublereal *c2,
+ integer *ldc, doublereal *work)
+{
+ /* System generated locals */
+ integer c1_dim1, c1_offset, c2_dim1, c2_offset, i__1;
+ doublereal d__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dcopy_(integer *,
+ doublereal *, integer *, doublereal *, integer *), daxpy_(integer
+ *, doublereal *, doublereal *, integer *, doublereal *, integer *)
+ ;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine DORMRZ. */
+
+/* DLATZM applies a Householder matrix generated by DTZRQF to a matrix. */
+
+/* Let P = I - tau*u*u', u = ( 1 ), */
+/* ( v ) */
+/* where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if */
+/* SIDE = 'R'. */
+
+/* If SIDE equals 'L', let */
+/* C = [ C1 ] 1 */
+/* [ C2 ] m-1 */
+/* n */
+/* Then C is overwritten by P*C. */
+
+/* If SIDE equals 'R', let */
+/* C = [ C1, C2 ] m */
+/* 1 n-1 */
+/* Then C is overwritten by C*P. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': form P * C */
+/* = 'R': form C * P */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* V (input) DOUBLE PRECISION array, dimension */
+/* (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
+/* (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
+/* The vector v in the representation of P. V is not used */
+/* if TAU = 0. */
+
+/* INCV (input) INTEGER */
+/* The increment between elements of v. INCV <> 0 */
+
+/* TAU (input) DOUBLE PRECISION */
+/* The value tau in the representation of P. */
+
+/* C1 (input/output) DOUBLE PRECISION array, dimension */
+/* (LDC,N) if SIDE = 'L' */
+/* (M,1) if SIDE = 'R' */
+/* On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1 */
+/* if SIDE = 'R'. */
+
+/* On exit, the first row of P*C if SIDE = 'L', or the first */
+/* column of C*P if SIDE = 'R'. */
+
+/* C2 (input/output) DOUBLE PRECISION array, dimension */
+/* (LDC, N) if SIDE = 'L' */
+/* (LDC, N-1) if SIDE = 'R' */
+/* On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the */
+/* m x (n - 1) matrix C2 if SIDE = 'R'. */
+
+/* On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P */
+/* if SIDE = 'R'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the arrays C1 and C2. LDC >= (1,M). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (N) if SIDE = 'L' */
+/* (M) if SIDE = 'R' */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --v;
+ c2_dim1 = *ldc;
+ c2_offset = 1 + c2_dim1;
+ c2 -= c2_offset;
+ c1_dim1 = *ldc;
+ c1_offset = 1 + c1_dim1;
+ c1 -= c1_offset;
+ --work;
+
+ /* Function Body */
+ if (min(*m,*n) == 0 || *tau == 0.) {
+ return 0;
+ }
+
+ if (lsame_(side, "L")) {
+
+/* w := C1 + v' * C2 */
+
+ dcopy_(n, &c1[c1_offset], ldc, &work[1], &c__1);
+ i__1 = *m - 1;
+ dgemv_("Transpose", &i__1, n, &c_b5, &c2[c2_offset], ldc, &v[1], incv,
+ &c_b5, &work[1], &c__1);
+
+/* [ C1 ] := [ C1 ] - tau* [ 1 ] * w' */
+/* [ C2 ] [ C2 ] [ v ] */
+
+ d__1 = -(*tau);
+ daxpy_(n, &d__1, &work[1], &c__1, &c1[c1_offset], ldc);
+ i__1 = *m - 1;
+ d__1 = -(*tau);
+ dger_(&i__1, n, &d__1, &v[1], incv, &work[1], &c__1, &c2[c2_offset],
+ ldc);
+
+ } else if (lsame_(side, "R")) {
+
+/* w := C1 + C2 * v */
+
+ dcopy_(m, &c1[c1_offset], &c__1, &work[1], &c__1);
+ i__1 = *n - 1;
+ dgemv_("No transpose", m, &i__1, &c_b5, &c2[c2_offset], ldc, &v[1],
+ incv, &c_b5, &work[1], &c__1);
+
+/* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v'] */
+
+ d__1 = -(*tau);
+ daxpy_(m, &d__1, &work[1], &c__1, &c1[c1_offset], &c__1);
+ i__1 = *n - 1;
+ d__1 = -(*tau);
+ dger_(m, &i__1, &d__1, &work[1], &c__1, &v[1], incv, &c2[c2_offset],
+ ldc);
+ }
+
+ return 0;
+
+/* End of DLATZM */
+
+} /* dlatzm_ */
diff --git a/SRC/dlauu2.c b/SRC/dlauu2.c
new file mode 100644
index 0000000..1f8f03f
--- /dev/null
+++ b/SRC/dlauu2.c
@@ -0,0 +1,183 @@
+/* dlauu2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b7 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dlauu2_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__;
+ doublereal aii;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAUU2 computes the product U * U' or L' * L, where the triangular */
+/* factor U or L is stored in the upper or lower triangular part of */
+/* the array A. */
+
+/* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */
+/* overwriting the factor U in A. */
+/* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */
+/* overwriting the factor L in A. */
+
+/* This is the unblocked form of the algorithm, calling Level 2 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the triangular factor stored in the array A */
+/* is upper or lower triangular: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the triangular factor U or L. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the triangular factor U or L. */
+/* On exit, if UPLO = 'U', the upper triangle of A is */
+/* overwritten with the upper triangle of the product U * U'; */
+/* if UPLO = 'L', the lower triangle of A is overwritten with */
+/* the lower triangle of the product L' * L. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLAUU2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Compute the product U * U'. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ aii = a[i__ + i__ * a_dim1];
+ if (i__ < *n) {
+ i__2 = *n - i__ + 1;
+ a[i__ + i__ * a_dim1] = ddot_(&i__2, &a[i__ + i__ * a_dim1],
+ lda, &a[i__ + i__ * a_dim1], lda);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ dgemv_("No transpose", &i__2, &i__3, &c_b7, &a[(i__ + 1) *
+ a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, &
+ aii, &a[i__ * a_dim1 + 1], &c__1);
+ } else {
+ dscal_(&i__, &aii, &a[i__ * a_dim1 + 1], &c__1);
+ }
+/* L10: */
+ }
+
+ } else {
+
+/* Compute the product L' * L. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ aii = a[i__ + i__ * a_dim1];
+ if (i__ < *n) {
+ i__2 = *n - i__ + 1;
+ a[i__ + i__ * a_dim1] = ddot_(&i__2, &a[i__ + i__ * a_dim1], &
+ c__1, &a[i__ + i__ * a_dim1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ dgemv_("Transpose", &i__2, &i__3, &c_b7, &a[i__ + 1 + a_dim1],
+ lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &aii, &a[i__
+ + a_dim1], lda);
+ } else {
+ dscal_(&i__, &aii, &a[i__ + a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of DLAUU2 */
+
+} /* dlauu2_ */
diff --git a/SRC/dlauum.c b/SRC/dlauum.c
new file mode 100644
index 0000000..0d5d706
--- /dev/null
+++ b/SRC/dlauum.c
@@ -0,0 +1,217 @@
+/* dlauum.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b15 = 1.;
+
+/* Subroutine */ int dlauum_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, ib, nb;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *), dlauu2_(char *, integer *,
+ doublereal *, integer *, integer *), xerbla_(char *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAUUM computes the product U * U' or L' * L, where the triangular */
+/* factor U or L is stored in the upper or lower triangular part of */
+/* the array A. */
+
+/* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */
+/* overwriting the factor U in A. */
+/* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */
+/* overwriting the factor L in A. */
+
+/* This is the blocked form of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the triangular factor stored in the array A */
+/* is upper or lower triangular: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the triangular factor U or L. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the triangular factor U or L. */
+/* On exit, if UPLO = 'U', the upper triangle of A is */
+/* overwritten with the upper triangle of the product U * U'; */
+/* if UPLO = 'L', the lower triangle of A is overwritten with */
+/* the lower triangle of the product L' * L. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLAUUM", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "DLAUUM", uplo, n, &c_n1, &c_n1, &c_n1);
+
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code */
+
+ dlauu2_(uplo, n, &a[a_offset], lda, info);
+ } else {
+
+/* Use blocked code */
+
+ if (upper) {
+
+/* Compute the product U * U'. */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - i__ + 1;
+ ib = min(i__3,i__4);
+ i__3 = i__ - 1;
+ dtrmm_("Right", "Upper", "Transpose", "Non-unit", &i__3, &ib,
+ &c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ * a_dim1
+ + 1], lda)
+ ;
+ dlauu2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info);
+ if (i__ + ib <= *n) {
+ i__3 = i__ - 1;
+ i__4 = *n - i__ - ib + 1;
+ dgemm_("No transpose", "Transpose", &i__3, &ib, &i__4, &
+ c_b15, &a[(i__ + ib) * a_dim1 + 1], lda, &a[i__ +
+ (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ *
+ a_dim1 + 1], lda);
+ i__3 = *n - i__ - ib + 1;
+ dsyrk_("Upper", "No transpose", &ib, &i__3, &c_b15, &a[
+ i__ + (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ +
+ i__ * a_dim1], lda);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Compute the product L' * L. */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - i__ + 1;
+ ib = min(i__3,i__4);
+ i__3 = i__ - 1;
+ dtrmm_("Left", "Lower", "Transpose", "Non-unit", &ib, &i__3, &
+ c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ + a_dim1],
+ lda);
+ dlauu2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info);
+ if (i__ + ib <= *n) {
+ i__3 = i__ - 1;
+ i__4 = *n - i__ - ib + 1;
+ dgemm_("Transpose", "No transpose", &ib, &i__3, &i__4, &
+ c_b15, &a[i__ + ib + i__ * a_dim1], lda, &a[i__ +
+ ib + a_dim1], lda, &c_b15, &a[i__ + a_dim1], lda);
+ i__3 = *n - i__ - ib + 1;
+ dsyrk_("Lower", "Transpose", &ib, &i__3, &c_b15, &a[i__ +
+ ib + i__ * a_dim1], lda, &c_b15, &a[i__ + i__ *
+ a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DLAUUM */
+
+} /* dlauum_ */
diff --git a/SRC/dopgtr.c b/SRC/dopgtr.c
new file mode 100644
index 0000000..ea1541c
--- /dev/null
+++ b/SRC/dopgtr.c
@@ -0,0 +1,210 @@
+/* dopgtr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dopgtr_(char *uplo, integer *n, doublereal *ap,
+ doublereal *tau, doublereal *q, integer *ldq, doublereal *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, ij;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical upper;
+ extern /* Subroutine */ int dorg2l_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *),
+ dorg2r_(integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DOPGTR generates a real orthogonal matrix Q which is defined as the */
+/* product of n-1 elementary reflectors H(i) of order n, as returned by */
+/* DSPTRD using packed storage: */
+
+/* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), */
+
+/* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular packed storage used in previous */
+/* call to DSPTRD; */
+/* = 'L': Lower triangular packed storage used in previous */
+/* call to DSPTRD. */
+
+/* N (input) INTEGER */
+/* The order of the matrix Q. N >= 0. */
+
+/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The vectors which define the elementary reflectors, as */
+/* returned by DSPTRD. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (N-1) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DSPTRD. */
+
+/* Q (output) DOUBLE PRECISION array, dimension (LDQ,N) */
+/* The N-by-N orthogonal matrix Q. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N-1) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --ap;
+ --tau;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldq < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DOPGTR", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Q was determined by a call to DSPTRD with UPLO = 'U' */
+
+/* Unpack the vectors which define the elementary reflectors and */
+/* set the last row and column of Q equal to those of the unit */
+/* matrix */
+
+ ij = 2;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ q[i__ + j * q_dim1] = ap[ij];
+ ++ij;
+/* L10: */
+ }
+ ij += 2;
+ q[*n + j * q_dim1] = 0.;
+/* L20: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ q[i__ + *n * q_dim1] = 0.;
+/* L30: */
+ }
+ q[*n + *n * q_dim1] = 1.;
+
+/* Generate Q(1:n-1,1:n-1) */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ dorg2l_(&i__1, &i__2, &i__3, &q[q_offset], ldq, &tau[1], &work[1], &
+ iinfo);
+
+ } else {
+
+/* Q was determined by a call to DSPTRD with UPLO = 'L'. */
+
+/* Unpack the vectors which define the elementary reflectors and */
+/* set the first row and column of Q equal to those of the unit */
+/* matrix */
+
+ q[q_dim1 + 1] = 1.;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ q[i__ + q_dim1] = 0.;
+/* L40: */
+ }
+ ij = 3;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ q[j * q_dim1 + 1] = 0.;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ q[i__ + j * q_dim1] = ap[ij];
+ ++ij;
+/* L50: */
+ }
+ ij += 2;
+/* L60: */
+ }
+ if (*n > 1) {
+
+/* Generate Q(2:n,2:n) */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ dorg2r_(&i__1, &i__2, &i__3, &q[(q_dim1 << 1) + 2], ldq, &tau[1],
+ &work[1], &iinfo);
+ }
+ }
+ return 0;
+
+/* End of DOPGTR */
+
+} /* dopgtr_ */
diff --git a/SRC/dopmtr.c b/SRC/dopmtr.c
new file mode 100644
index 0000000..fda595a
--- /dev/null
+++ b/SRC/dopmtr.c
@@ -0,0 +1,296 @@
+/* dopmtr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dopmtr_(char *side, char *uplo, char *trans, integer *m,
+ integer *n, doublereal *ap, doublereal *tau, doublereal *c__, integer
+ *ldc, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, i1, i2, i3, ic, jc, ii, mi, ni, nq;
+ doublereal aii;
+ logical left;
+ extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *);
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran, forwrd;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DOPMTR overwrites the general real M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'T': Q**T * C C * Q**T */
+
+/* where Q is a real orthogonal matrix of order nq, with nq = m if */
+/* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */
+/* nq-1 elementary reflectors, as returned by DSPTRD using packed */
+/* storage: */
+
+/* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); */
+
+/* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**T from the Left; */
+/* = 'R': apply Q or Q**T from the Right. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular packed storage used in previous */
+/* call to DSPTRD; */
+/* = 'L': Lower triangular packed storage used in previous */
+/* call to DSPTRD. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'T': Transpose, apply Q**T. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* AP (input) DOUBLE PRECISION array, dimension */
+/* (M*(M+1)/2) if SIDE = 'L' */
+/* (N*(N+1)/2) if SIDE = 'R' */
+/* The vectors which define the elementary reflectors, as */
+/* returned by DSPTRD. AP is modified by the routine but */
+/* restored on exit. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (M-1) if SIDE = 'L' */
+/* or (N-1) if SIDE = 'R' */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DSPTRD. */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (N) if SIDE = 'L' */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --ap;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ upper = lsame_(uplo, "U");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*ldc < max(1,*m)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DOPMTR", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Q was determined by a call to DSPTRD with UPLO = 'U' */
+
+ forwrd = left && notran || ! left && ! notran;
+
+ if (forwrd) {
+ i1 = 1;
+ i2 = nq - 1;
+ i3 = 1;
+ ii = 2;
+ } else {
+ i1 = nq - 1;
+ i2 = 1;
+ i3 = -1;
+ ii = nq * (nq + 1) / 2 - 1;
+ }
+
+ if (left) {
+ ni = *n;
+ } else {
+ mi = *m;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) is applied to C(1:i,1:n) */
+
+ mi = i__;
+ } else {
+
+/* H(i) is applied to C(1:m,1:i) */
+
+ ni = i__;
+ }
+
+/* Apply H(i) */
+
+ aii = ap[ii];
+ ap[ii] = 1.;
+ dlarf_(side, &mi, &ni, &ap[ii - i__ + 1], &c__1, &tau[i__], &c__[
+ c_offset], ldc, &work[1]);
+ ap[ii] = aii;
+
+ if (forwrd) {
+ ii = ii + i__ + 2;
+ } else {
+ ii = ii - i__ - 1;
+ }
+/* L10: */
+ }
+ } else {
+
+/* Q was determined by a call to DSPTRD with UPLO = 'L'. */
+
+ forwrd = left && ! notran || ! left && notran;
+
+ if (forwrd) {
+ i1 = 1;
+ i2 = nq - 1;
+ i3 = 1;
+ ii = 2;
+ } else {
+ i1 = nq - 1;
+ i2 = 1;
+ i3 = -1;
+ ii = nq * (nq + 1) / 2 - 1;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ }
+
+ i__2 = i2;
+ i__1 = i3;
+ for (i__ = i1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
+ aii = ap[ii];
+ ap[ii] = 1.;
+ if (left) {
+
+/* H(i) is applied to C(i+1:m,1:n) */
+
+ mi = *m - i__;
+ ic = i__ + 1;
+ } else {
+
+/* H(i) is applied to C(1:m,i+1:n) */
+
+ ni = *n - i__;
+ jc = i__ + 1;
+ }
+
+/* Apply H(i) */
+
+ dlarf_(side, &mi, &ni, &ap[ii], &c__1, &tau[i__], &c__[ic + jc *
+ c_dim1], ldc, &work[1]);
+ ap[ii] = aii;
+
+ if (forwrd) {
+ ii = ii + nq - i__ + 1;
+ } else {
+ ii = ii - nq + i__ - 2;
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+/* End of DOPMTR */
+
+} /* dopmtr_ */
diff --git a/SRC/dorg2l.c b/SRC/dorg2l.c
new file mode 100644
index 0000000..0fa59f1
--- /dev/null
+++ b/SRC/dorg2l.c
@@ -0,0 +1,173 @@
+/* dorg2l.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dorg2l_(integer *m, integer *n, integer *k, doublereal *
+ a, integer *lda, doublereal *tau, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, j, l, ii;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *), dlarf_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORG2L generates an m by n real matrix Q with orthonormal columns, */
+/* which is defined as the last n columns of a product of k elementary */
+/* reflectors of order m */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by DGEQLF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the (n-k+i)-th column must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by DGEQLF in the last k columns of its array */
+/* argument A. */
+/* On exit, the m by n matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DGEQLF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DORG2L", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Initialise columns 1:n-k to columns of the unit matrix */
+
+ i__1 = *n - *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (l = 1; l <= i__2; ++l) {
+ a[l + j * a_dim1] = 0.;
+/* L10: */
+ }
+ a[*m - *n + j + j * a_dim1] = 1.;
+/* L20: */
+ }
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ii = *n - *k + i__;
+
+/* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left */
+
+ a[*m - *n + ii + ii * a_dim1] = 1.;
+ i__2 = *m - *n + ii;
+ i__3 = ii - 1;
+ dlarf_("Left", &i__2, &i__3, &a[ii * a_dim1 + 1], &c__1, &tau[i__], &
+ a[a_offset], lda, &work[1]);
+ i__2 = *m - *n + ii - 1;
+ d__1 = -tau[i__];
+ dscal_(&i__2, &d__1, &a[ii * a_dim1 + 1], &c__1);
+ a[*m - *n + ii + ii * a_dim1] = 1. - tau[i__];
+
+/* Set A(m-k+i+1:m,n-k+i) to zero */
+
+ i__2 = *m;
+ for (l = *m - *n + ii + 1; l <= i__2; ++l) {
+ a[l + ii * a_dim1] = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+ return 0;
+
+/* End of DORG2L */
+
+} /* dorg2l_ */
diff --git a/SRC/dorg2r.c b/SRC/dorg2r.c
new file mode 100644
index 0000000..892807c
--- /dev/null
+++ b/SRC/dorg2r.c
@@ -0,0 +1,175 @@
+/* dorg2r.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dorg2r_(integer *m, integer *n, integer *k, doublereal *
+ a, integer *lda, doublereal *tau, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, j, l;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *), dlarf_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORG2R generates an m by n real matrix Q with orthonormal columns, */
+/* which is defined as the first n columns of a product of k elementary */
+/* reflectors of order m */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by DGEQRF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the i-th column must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by DGEQRF in the first k columns of its array */
+/* argument A. */
+/* On exit, the m-by-n matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DGEQRF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DORG2R", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Initialise columns k+1:n to columns of the unit matrix */
+
+ i__1 = *n;
+ for (j = *k + 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (l = 1; l <= i__2; ++l) {
+ a[l + j * a_dim1] = 0.;
+/* L10: */
+ }
+ a[j + j * a_dim1] = 1.;
+/* L20: */
+ }
+
+ for (i__ = *k; i__ >= 1; --i__) {
+
+/* Apply H(i) to A(i:m,i:n) from the left */
+
+ if (i__ < *n) {
+ a[i__ + i__ * a_dim1] = 1.;
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__;
+ dlarf_("Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[
+ i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
+ }
+ if (i__ < *m) {
+ i__1 = *m - i__;
+ d__1 = -tau[i__];
+ dscal_(&i__1, &d__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
+ }
+ a[i__ + i__ * a_dim1] = 1. - tau[i__];
+
+/* Set A(1:i-1,i) to zero */
+
+ i__1 = i__ - 1;
+ for (l = 1; l <= i__1; ++l) {
+ a[l + i__ * a_dim1] = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+ return 0;
+
+/* End of DORG2R */
+
+} /* dorg2r_ */
diff --git a/SRC/dorgbr.c b/SRC/dorgbr.c
new file mode 100644
index 0000000..e649640
--- /dev/null
+++ b/SRC/dorgbr.c
@@ -0,0 +1,299 @@
+/* dorgbr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dorgbr_(char *vect, integer *m, integer *n, integer *k,
+ doublereal *a, integer *lda, doublereal *tau, doublereal *work,
+ integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, nb, mn;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical wantq;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dorglq_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dorgqr_(integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORGBR generates one of the real orthogonal matrices Q or P**T */
+/* determined by DGEBRD when reducing a real matrix A to bidiagonal */
+/* form: A = Q * B * P**T. Q and P**T are defined as products of */
+/* elementary reflectors H(i) or G(i) respectively. */
+
+/* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q */
+/* is of order M: */
+/* if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n */
+/* columns of Q, where m >= n >= k; */
+/* if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an */
+/* M-by-M matrix. */
+
+/* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T */
+/* is of order N: */
+/* if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m */
+/* rows of P**T, where n >= m >= k; */
+/* if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as */
+/* an N-by-N matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* VECT (input) CHARACTER*1 */
+/* Specifies whether the matrix Q or the matrix P**T is */
+/* required, as defined in the transformation applied by DGEBRD: */
+/* = 'Q': generate Q; */
+/* = 'P': generate P**T. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q or P**T to be returned. */
+/* M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q or P**T to be returned. */
+/* N >= 0. */
+/* If VECT = 'Q', M >= N >= min(M,K); */
+/* if VECT = 'P', N >= M >= min(N,K). */
+
+/* K (input) INTEGER */
+/* If VECT = 'Q', the number of columns in the original M-by-K */
+/* matrix reduced by DGEBRD. */
+/* If VECT = 'P', the number of rows in the original K-by-N */
+/* matrix reduced by DGEBRD. */
+/* K >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the vectors which define the elementary reflectors, */
+/* as returned by DGEBRD. */
+/* On exit, the M-by-N matrix Q or P**T. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) DOUBLE PRECISION array, dimension */
+/* (min(M,K)) if VECT = 'Q' */
+/* (min(N,K)) if VECT = 'P' */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i) or G(i), which determines Q or P**T, as */
+/* returned by DGEBRD in its array argument TAUQ or TAUP. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,min(M,N)). */
+/* For optimum performance LWORK >= min(M,N)*NB, where NB */
+/* is the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ wantq = lsame_(vect, "Q");
+ mn = min(*m,*n);
+ lquery = *lwork == -1;
+ if (! wantq && ! lsame_(vect, "P")) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*n < 0 || wantq && (*n > *m || *n < min(*m,*k)) || ! wantq && (
+ *m > *n || *m < min(*n,*k))) {
+ *info = -3;
+ } else if (*k < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -6;
+ } else if (*lwork < max(1,mn) && ! lquery) {
+ *info = -9;
+ }
+
+ if (*info == 0) {
+ if (wantq) {
+ nb = ilaenv_(&c__1, "DORGQR", " ", m, n, k, &c_n1);
+ } else {
+ nb = ilaenv_(&c__1, "DORGLQ", " ", m, n, k, &c_n1);
+ }
+ lwkopt = max(1,mn) * nb;
+ work[1] = (doublereal) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DORGBR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ work[1] = 1.;
+ return 0;
+ }
+
+ if (wantq) {
+
+/* Form Q, determined by a call to DGEBRD to reduce an m-by-k */
+/* matrix */
+
+ if (*m >= *k) {
+
+/* If m >= k, assume m >= n >= k */
+
+ dorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
+ iinfo);
+
+ } else {
+
+/* If m < k, assume m = n */
+
+/* Shift the vectors which define the elementary reflectors one */
+/* column to the right, and set the first row and column of Q */
+/* to those of the unit matrix */
+
+ for (j = *m; j >= 2; --j) {
+ a[j * a_dim1 + 1] = 0.;
+ i__1 = *m;
+ for (i__ = j + 1; i__ <= i__1; ++i__) {
+ a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+ a[a_dim1 + 1] = 1.;
+ i__1 = *m;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ a[i__ + a_dim1] = 0.;
+/* L30: */
+ }
+ if (*m > 1) {
+
+/* Form Q(2:m,2:m) */
+
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ dorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[
+ 1], &work[1], lwork, &iinfo);
+ }
+ }
+ } else {
+
+/* Form P', determined by a call to DGEBRD to reduce a k-by-n */
+/* matrix */
+
+ if (*k < *n) {
+
+/* If k < n, assume k <= m <= n */
+
+ dorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
+ iinfo);
+
+ } else {
+
+/* If k >= n, assume m = n */
+
+/* Shift the vectors which define the elementary reflectors one */
+/* row downward, and set the first row and column of P' to */
+/* those of the unit matrix */
+
+ a[a_dim1 + 1] = 1.;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ a[i__ + a_dim1] = 0.;
+/* L40: */
+ }
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ for (i__ = j - 1; i__ >= 2; --i__) {
+ a[i__ + j * a_dim1] = a[i__ - 1 + j * a_dim1];
+/* L50: */
+ }
+ a[j * a_dim1 + 1] = 0.;
+/* L60: */
+ }
+ if (*n > 1) {
+
+/* Form P'(2:n,2:n) */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ dorglq_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[
+ 1], &work[1], lwork, &iinfo);
+ }
+ }
+ }
+ work[1] = (doublereal) lwkopt;
+ return 0;
+
+/* End of DORGBR */
+
+} /* dorgbr_ */
diff --git a/SRC/dorghr.c b/SRC/dorghr.c
new file mode 100644
index 0000000..291825b
--- /dev/null
+++ b/SRC/dorghr.c
@@ -0,0 +1,216 @@
+/* dorghr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dorghr_(integer *n, integer *ilo, integer *ihi,
+ doublereal *a, integer *lda, doublereal *tau, doublereal *work,
+ integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, nb, nh, iinfo;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORGHR generates a real orthogonal matrix Q which is defined as the */
+/* product of IHI-ILO elementary reflectors of order N, as returned by */
+/* DGEHRD: */
+
+/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix Q. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* ILO and IHI must have the same values as in the previous call */
+/* of DGEHRD. Q is equal to the unit matrix except in the */
+/* submatrix Q(ilo+1:ihi,ilo+1:ihi). */
+/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the vectors which define the elementary reflectors, */
+/* as returned by DGEHRD. */
+/* On exit, the N-by-N orthogonal matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (N-1) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DGEHRD. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= IHI-ILO. */
+/* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nh = *ihi - *ilo;
+ lquery = *lwork == -1;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*ilo < 1 || *ilo > max(1,*n)) {
+ *info = -2;
+ } else if (*ihi < min(*ilo,*n) || *ihi > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*lwork < max(1,nh) && ! lquery) {
+ *info = -8;
+ }
+
+ if (*info == 0) {
+ nb = ilaenv_(&c__1, "DORGQR", " ", &nh, &nh, &nh, &c_n1);
+ lwkopt = max(1,nh) * nb;
+ work[1] = (doublereal) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DORGHR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ work[1] = 1.;
+ return 0;
+ }
+
+/* Shift the vectors which define the elementary reflectors one */
+/* column to the right, and set the first ilo and the last n-ihi */
+/* rows and columns to those of the unit matrix */
+
+ i__1 = *ilo + 1;
+ for (j = *ihi; j >= i__1; --j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L10: */
+ }
+ i__2 = *ihi;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1];
+/* L20: */
+ }
+ i__2 = *n;
+ for (i__ = *ihi + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+ i__1 = *ilo;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L50: */
+ }
+ a[j + j * a_dim1] = 1.;
+/* L60: */
+ }
+ i__1 = *n;
+ for (j = *ihi + 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L70: */
+ }
+ a[j + j * a_dim1] = 1.;
+/* L80: */
+ }
+
+ if (nh > 0) {
+
+/* Generate Q(ilo+1:ihi,ilo+1:ihi) */
+
+ dorgqr_(&nh, &nh, &nh, &a[*ilo + 1 + (*ilo + 1) * a_dim1], lda, &tau[*
+ ilo], &work[1], lwork, &iinfo);
+ }
+ work[1] = (doublereal) lwkopt;
+ return 0;
+
+/* End of DORGHR */
+
+} /* dorghr_ */
diff --git a/SRC/dorgl2.c b/SRC/dorgl2.c
new file mode 100644
index 0000000..f880992
--- /dev/null
+++ b/SRC/dorgl2.c
@@ -0,0 +1,175 @@
+/* dorgl2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dorgl2_(integer *m, integer *n, integer *k, doublereal *
+ a, integer *lda, doublereal *tau, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, j, l;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *), dlarf_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORGL2 generates an m by n real matrix Q with orthonormal rows, */
+/* which is defined as the first m rows of a product of k elementary */
+/* reflectors of order n */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by DGELQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. N >= M. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the i-th row must contain the vector which defines */
+/* the elementary reflector H(i), for i = 1,2,...,k, as returned */
+/* by DGELQF in the first k rows of its array argument A. */
+/* On exit, the m-by-n matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DGELQF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *m) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DORGL2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0) {
+ return 0;
+ }
+
+ if (*k < *m) {
+
+/* Initialise rows k+1:m to rows of the unit matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (l = *k + 1; l <= i__2; ++l) {
+ a[l + j * a_dim1] = 0.;
+/* L10: */
+ }
+ if (j > *k && j <= *m) {
+ a[j + j * a_dim1] = 1.;
+ }
+/* L20: */
+ }
+ }
+
+ for (i__ = *k; i__ >= 1; --i__) {
+
+/* Apply H(i) to A(i:m,i:n) from the right */
+
+ if (i__ < *n) {
+ if (i__ < *m) {
+ a[i__ + i__ * a_dim1] = 1.;
+ i__1 = *m - i__;
+ i__2 = *n - i__ + 1;
+ dlarf_("Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &
+ tau[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]);
+ }
+ i__1 = *n - i__;
+ d__1 = -tau[i__];
+ dscal_(&i__1, &d__1, &a[i__ + (i__ + 1) * a_dim1], lda);
+ }
+ a[i__ + i__ * a_dim1] = 1. - tau[i__];
+
+/* Set A(i,1:i-1) to zero */
+
+ i__1 = i__ - 1;
+ for (l = 1; l <= i__1; ++l) {
+ a[i__ + l * a_dim1] = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+ return 0;
+
+/* End of DORGL2 */
+
+} /* dorgl2_ */
diff --git a/SRC/dorglq.c b/SRC/dorglq.c
new file mode 100644
index 0000000..a5b9019
--- /dev/null
+++ b/SRC/dorglq.c
@@ -0,0 +1,280 @@
+/* dorglq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int dorglq_(integer *m, integer *n, integer *k, doublereal *
+ a, integer *lda, doublereal *tau, doublereal *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int dorgl2_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *),
+ dlarfb_(char *, char *, char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *), dlarft_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORGLQ generates an M-by-N real matrix Q with orthonormal rows, */
+/* which is defined as the first M rows of a product of K elementary */
+/* reflectors of order N */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by DGELQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. N >= M. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the i-th row must contain the vector which defines */
+/* the elementary reflector H(i), for i = 1,2,...,k, as returned */
+/* by DGELQF in the first k rows of its array argument A. */
+/* On exit, the M-by-N matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DGELQF. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M). */
+/* For optimum performance LWORK >= M*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb = ilaenv_(&c__1, "DORGLQ", " ", m, n, k, &c_n1);
+ lwkopt = max(1,*m) * nb;
+ work[1] = (doublereal) lwkopt;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *m) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*lwork < max(1,*m) && ! lquery) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DORGLQ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0) {
+ work[1] = 1.;
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *m;
+ if (nb > 1 && nb < *k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "DORGLQ", " ", m, n, k, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *m;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "DORGLQ", " ", m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < *k && nx < *k) {
+
+/* Use blocked code after the last block. */
+/* The first kk rows are handled by the block method. */
+
+ ki = (*k - nx - 1) / nb * nb;
+/* Computing MIN */
+ i__1 = *k, i__2 = ki + nb;
+ kk = min(i__1,i__2);
+
+/* Set A(kk+1:m,1:kk) to zero. */
+
+ i__1 = kk;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = kk + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ kk = 0;
+ }
+
+/* Use unblocked code for the last or only block. */
+
+ if (kk < *m) {
+ i__1 = *m - kk;
+ i__2 = *n - kk;
+ i__3 = *k - kk;
+ dorgl2_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, &
+ tau[kk + 1], &work[1], &iinfo);
+ }
+
+ if (kk > 0) {
+
+/* Use blocked code */
+
+ i__1 = -nb;
+ for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) {
+/* Computing MIN */
+ i__2 = nb, i__3 = *k - i__ + 1;
+ ib = min(i__2,i__3);
+ if (i__ + ib <= *m) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__2 = *n - i__ + 1;
+ dlarft_("Forward", "Rowwise", &i__2, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H' to A(i+ib:m,i:n) from the right */
+
+ i__2 = *m - i__ - ib + 1;
+ i__3 = *n - i__ + 1;
+ dlarfb_("Right", "Transpose", "Forward", "Rowwise", &i__2, &
+ i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
+ ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib +
+ 1], &ldwork);
+ }
+
+/* Apply H' to columns i:n of current block */
+
+ i__2 = *n - i__ + 1;
+ dorgl2_(&ib, &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
+ work[1], &iinfo);
+
+/* Set columns 1:i-1 of current block to zero */
+
+ i__2 = i__ - 1;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + ib - 1;
+ for (l = i__; l <= i__3; ++l) {
+ a[l + j * a_dim1] = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+ work[1] = (doublereal) iws;
+ return 0;
+
+/* End of DORGLQ */
+
+} /* dorglq_ */
diff --git a/SRC/dorgql.c b/SRC/dorgql.c
new file mode 100644
index 0000000..85d2f8a
--- /dev/null
+++ b/SRC/dorgql.c
@@ -0,0 +1,289 @@
+/* dorgql.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int dorgql_(integer *m, integer *n, integer *k, doublereal *
+ a, integer *lda, doublereal *tau, doublereal *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, l, ib, nb, kk, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int dorg2l_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *),
+ dlarfb_(char *, char *, char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *), dlarft_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORGQL generates an M-by-N real matrix Q with orthonormal columns, */
+/* which is defined as the last N columns of a product of K elementary */
+/* reflectors of order M */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by DGEQLF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the (n-k+i)-th column must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by DGEQLF in the last k columns of its array */
+/* argument A. */
+/* On exit, the M-by-N matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DGEQLF. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* For optimum performance LWORK >= N*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+
+ if (*info == 0) {
+ if (*n == 0) {
+ lwkopt = 1;
+ } else {
+ nb = ilaenv_(&c__1, "DORGQL", " ", m, n, k, &c_n1);
+ lwkopt = *n * nb;
+ }
+ work[1] = (doublereal) lwkopt;
+
+ if (*lwork < max(1,*n) && ! lquery) {
+ *info = -8;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DORGQL", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *n;
+ if (nb > 1 && nb < *k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "DORGQL", " ", m, n, k, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *n;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "DORGQL", " ", m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < *k && nx < *k) {
+
+/* Use blocked code after the first block. */
+/* The last kk columns are handled by the block method. */
+
+/* Computing MIN */
+ i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb;
+ kk = min(i__1,i__2);
+
+/* Set A(m-kk+1:m,1:n-kk) to zero. */
+
+ i__1 = *n - kk;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = *m - kk + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ kk = 0;
+ }
+
+/* Use unblocked code for the first or only block. */
+
+ i__1 = *m - kk;
+ i__2 = *n - kk;
+ i__3 = *k - kk;
+ dorg2l_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &iinfo)
+ ;
+
+ if (kk > 0) {
+
+/* Use blocked code */
+
+ i__1 = *k;
+ i__2 = nb;
+ for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *k - i__ + 1;
+ ib = min(i__3,i__4);
+ if (*n - *k + i__ > 1) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__3 = *m - *k + i__ + ib - 1;
+ dlarft_("Backward", "Columnwise", &i__3, &ib, &a[(*n - *k +
+ i__) * a_dim1 + 1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left */
+
+ i__3 = *m - *k + i__ + ib - 1;
+ i__4 = *n - *k + i__ - 1;
+ dlarfb_("Left", "No transpose", "Backward", "Columnwise", &
+ i__3, &i__4, &ib, &a[(*n - *k + i__) * a_dim1 + 1],
+ lda, &work[1], &ldwork, &a[a_offset], lda, &work[ib +
+ 1], &ldwork);
+ }
+
+/* Apply H to rows 1:m-k+i+ib-1 of current block */
+
+ i__3 = *m - *k + i__ + ib - 1;
+ dorg2l_(&i__3, &ib, &ib, &a[(*n - *k + i__) * a_dim1 + 1], lda, &
+ tau[i__], &work[1], &iinfo);
+
+/* Set rows m-k+i+ib:m of current block to zero */
+
+ i__3 = *n - *k + i__ + ib - 1;
+ for (j = *n - *k + i__; j <= i__3; ++j) {
+ i__4 = *m;
+ for (l = *m - *k + i__ + ib; l <= i__4; ++l) {
+ a[l + j * a_dim1] = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+ work[1] = (doublereal) iws;
+ return 0;
+
+/* End of DORGQL */
+
+} /* dorgql_ */
diff --git a/SRC/dorgqr.c b/SRC/dorgqr.c
new file mode 100644
index 0000000..3b72b73
--- /dev/null
+++ b/SRC/dorgqr.c
@@ -0,0 +1,281 @@
+/* dorgqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int dorgqr_(integer *m, integer *n, integer *k, doublereal *
+ a, integer *lda, doublereal *tau, doublereal *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int dorg2r_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *),
+ dlarfb_(char *, char *, char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *), dlarft_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORGQR generates an M-by-N real matrix Q with orthonormal columns, */
+/* which is defined as the first N columns of a product of K elementary */
+/* reflectors of order M */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by DGEQRF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the i-th column must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by DGEQRF in the first k columns of its array */
+/* argument A. */
+/* On exit, the M-by-N matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DGEQRF. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* For optimum performance LWORK >= N*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb = ilaenv_(&c__1, "DORGQR", " ", m, n, k, &c_n1);
+ lwkopt = max(1,*n) * nb;
+ work[1] = (doublereal) lwkopt;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DORGQR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ work[1] = 1.;
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *n;
+ if (nb > 1 && nb < *k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "DORGQR", " ", m, n, k, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *n;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "DORGQR", " ", m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < *k && nx < *k) {
+
+/* Use blocked code after the last block. */
+/* The first kk columns are handled by the block method. */
+
+ ki = (*k - nx - 1) / nb * nb;
+/* Computing MIN */
+ i__1 = *k, i__2 = ki + nb;
+ kk = min(i__1,i__2);
+
+/* Set A(1:kk,kk+1:n) to zero. */
+
+ i__1 = *n;
+ for (j = kk + 1; j <= i__1; ++j) {
+ i__2 = kk;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ kk = 0;
+ }
+
+/* Use unblocked code for the last or only block. */
+
+ if (kk < *n) {
+ i__1 = *m - kk;
+ i__2 = *n - kk;
+ i__3 = *k - kk;
+ dorg2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, &
+ tau[kk + 1], &work[1], &iinfo);
+ }
+
+ if (kk > 0) {
+
+/* Use blocked code */
+
+ i__1 = -nb;
+ for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) {
+/* Computing MIN */
+ i__2 = nb, i__3 = *k - i__ + 1;
+ ib = min(i__2,i__3);
+ if (i__ + ib <= *n) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__2 = *m - i__ + 1;
+ dlarft_("Forward", "Columnwise", &i__2, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H to A(i:m,i+ib:n) from the left */
+
+ i__2 = *m - i__ + 1;
+ i__3 = *n - i__ - ib + 1;
+ dlarfb_("Left", "No transpose", "Forward", "Columnwise", &
+ i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[
+ 1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &
+ work[ib + 1], &ldwork);
+ }
+
+/* Apply H to rows i:m of current block */
+
+ i__2 = *m - i__ + 1;
+ dorg2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
+ work[1], &iinfo);
+
+/* Set rows 1:i-1 of current block to zero */
+
+ i__2 = i__ + ib - 1;
+ for (j = i__; j <= i__2; ++j) {
+ i__3 = i__ - 1;
+ for (l = 1; l <= i__3; ++l) {
+ a[l + j * a_dim1] = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+ work[1] = (doublereal) iws;
+ return 0;
+
+/* End of DORGQR */
+
+} /* dorgqr_ */
diff --git a/SRC/dorgr2.c b/SRC/dorgr2.c
new file mode 100644
index 0000000..ab2ce59
--- /dev/null
+++ b/SRC/dorgr2.c
@@ -0,0 +1,174 @@
+/* dorgr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dorgr2_(integer *m, integer *n, integer *k, doublereal *
+ a, integer *lda, doublereal *tau, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, j, l, ii;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *), dlarf_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORGR2 generates an m by n real matrix Q with orthonormal rows, */
+/* which is defined as the last m rows of a product of k elementary */
+/* reflectors of order n */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by DGERQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. N >= M. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the (m-k+i)-th row must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by DGERQF in the last k rows of its array argument */
+/* A. */
+/* On exit, the m by n matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DGERQF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *m) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DORGR2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0) {
+ return 0;
+ }
+
+ if (*k < *m) {
+
+/* Initialise rows 1:m-k to rows of the unit matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m - *k;
+ for (l = 1; l <= i__2; ++l) {
+ a[l + j * a_dim1] = 0.;
+/* L10: */
+ }
+ if (j > *n - *m && j <= *n - *k) {
+ a[*m - *n + j + j * a_dim1] = 1.;
+ }
+/* L20: */
+ }
+ }
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ii = *m - *k + i__;
+
+/* Apply H(i) to A(1:m-k+i,1:n-k+i) from the right */
+
+ a[ii + (*n - *m + ii) * a_dim1] = 1.;
+ i__2 = ii - 1;
+ i__3 = *n - *m + ii;
+ dlarf_("Right", &i__2, &i__3, &a[ii + a_dim1], lda, &tau[i__], &a[
+ a_offset], lda, &work[1]);
+ i__2 = *n - *m + ii - 1;
+ d__1 = -tau[i__];
+ dscal_(&i__2, &d__1, &a[ii + a_dim1], lda);
+ a[ii + (*n - *m + ii) * a_dim1] = 1. - tau[i__];
+
+/* Set A(m-k+i,n-k+i+1:n) to zero */
+
+ i__2 = *n;
+ for (l = *n - *m + ii + 1; l <= i__2; ++l) {
+ a[ii + l * a_dim1] = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+ return 0;
+
+/* End of DORGR2 */
+
+} /* dorgr2_ */
diff --git a/SRC/dorgrq.c b/SRC/dorgrq.c
new file mode 100644
index 0000000..5927a41
--- /dev/null
+++ b/SRC/dorgrq.c
@@ -0,0 +1,289 @@
+/* dorgrq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int dorgrq_(integer *m, integer *n, integer *k, doublereal *
+ a, integer *lda, doublereal *tau, doublereal *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, l, ib, nb, ii, kk, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int dorgr2_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *),
+ dlarfb_(char *, char *, char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *), dlarft_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORGRQ generates an M-by-N real matrix Q with orthonormal rows, */
+/* which is defined as the last M rows of a product of K elementary */
+/* reflectors of order N */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by DGERQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. N >= M. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the (m-k+i)-th row must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by DGERQF in the last k rows of its array argument */
+/* A. */
+/* On exit, the M-by-N matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DGERQF. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M). */
+/* For optimum performance LWORK >= M*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *m) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+
+ if (*info == 0) {
+ if (*m <= 0) {
+ lwkopt = 1;
+ } else {
+ nb = ilaenv_(&c__1, "DORGRQ", " ", m, n, k, &c_n1);
+ lwkopt = *m * nb;
+ }
+ work[1] = (doublereal) lwkopt;
+
+ if (*lwork < max(1,*m) && ! lquery) {
+ *info = -8;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DORGRQ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *m;
+ if (nb > 1 && nb < *k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "DORGRQ", " ", m, n, k, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *m;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "DORGRQ", " ", m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < *k && nx < *k) {
+
+/* Use blocked code after the first block. */
+/* The last kk rows are handled by the block method. */
+
+/* Computing MIN */
+ i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb;
+ kk = min(i__1,i__2);
+
+/* Set A(1:m-kk,n-kk+1:n) to zero. */
+
+ i__1 = *n;
+ for (j = *n - kk + 1; j <= i__1; ++j) {
+ i__2 = *m - kk;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ kk = 0;
+ }
+
+/* Use unblocked code for the first or only block. */
+
+ i__1 = *m - kk;
+ i__2 = *n - kk;
+ i__3 = *k - kk;
+ dorgr2_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &iinfo)
+ ;
+
+ if (kk > 0) {
+
+/* Use blocked code */
+
+ i__1 = *k;
+ i__2 = nb;
+ for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *k - i__ + 1;
+ ib = min(i__3,i__4);
+ ii = *m - *k + i__;
+ if (ii > 1) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__3 = *n - *k + i__ + ib - 1;
+ dlarft_("Backward", "Rowwise", &i__3, &ib, &a[ii + a_dim1],
+ lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H' to A(1:m-k+i-1,1:n-k+i+ib-1) from the right */
+
+ i__3 = ii - 1;
+ i__4 = *n - *k + i__ + ib - 1;
+ dlarfb_("Right", "Transpose", "Backward", "Rowwise", &i__3, &
+ i__4, &ib, &a[ii + a_dim1], lda, &work[1], &ldwork, &
+ a[a_offset], lda, &work[ib + 1], &ldwork);
+ }
+
+/* Apply H' to columns 1:n-k+i+ib-1 of current block */
+
+ i__3 = *n - *k + i__ + ib - 1;
+ dorgr2_(&ib, &i__3, &ib, &a[ii + a_dim1], lda, &tau[i__], &work[1]
+, &iinfo);
+
+/* Set columns n-k+i+ib:n of current block to zero */
+
+ i__3 = *n;
+ for (l = *n - *k + i__ + ib; l <= i__3; ++l) {
+ i__4 = ii + ib - 1;
+ for (j = ii; j <= i__4; ++j) {
+ a[j + l * a_dim1] = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+ work[1] = (doublereal) iws;
+ return 0;
+
+/* End of DORGRQ */
+
+} /* dorgrq_ */
diff --git a/SRC/dorgtr.c b/SRC/dorgtr.c
new file mode 100644
index 0000000..c380681
--- /dev/null
+++ b/SRC/dorgtr.c
@@ -0,0 +1,250 @@
+/* dorgtr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dorgtr_(char *uplo, integer *n, doublereal *a, integer *
+ lda, doublereal *tau, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, nb;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dorgql_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dorgqr_(integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORGTR generates a real orthogonal matrix Q which is defined as the */
+/* product of n-1 elementary reflectors of order N, as returned by */
+/* DSYTRD: */
+
+/* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), */
+
+/* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A contains elementary reflectors */
+/* from DSYTRD; */
+/* = 'L': Lower triangle of A contains elementary reflectors */
+/* from DSYTRD. */
+
+/* N (input) INTEGER */
+/* The order of the matrix Q. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the vectors which define the elementary reflectors, */
+/* as returned by DSYTRD. */
+/* On exit, the N-by-N orthogonal matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (N-1) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DSYTRD. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N-1). */
+/* For optimum performance LWORK >= (N-1)*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n - 1;
+ if (*lwork < max(i__1,i__2) && ! lquery) {
+ *info = -7;
+ }
+ }
+
+ if (*info == 0) {
+ if (upper) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ nb = ilaenv_(&c__1, "DORGQL", " ", &i__1, &i__2, &i__3, &c_n1);
+ } else {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ nb = ilaenv_(&c__1, "DORGQR", " ", &i__1, &i__2, &i__3, &c_n1);
+ }
+/* Computing MAX */
+ i__1 = 1, i__2 = *n - 1;
+ lwkopt = max(i__1,i__2) * nb;
+ work[1] = (doublereal) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DORGTR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ work[1] = 1.;
+ return 0;
+ }
+
+ if (upper) {
+
+/* Q was determined by a call to DSYTRD with UPLO = 'U' */
+
+/* Shift the vectors which define the elementary reflectors one */
+/* column to the left, and set the last row and column of Q to */
+/* those of the unit matrix */
+
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = a[i__ + (j + 1) * a_dim1];
+/* L10: */
+ }
+ a[*n + j * a_dim1] = 0.;
+/* L20: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ a[i__ + *n * a_dim1] = 0.;
+/* L30: */
+ }
+ a[*n + *n * a_dim1] = 1.;
+
+/* Generate Q(1:n-1,1:n-1) */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ dorgql_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1],
+ lwork, &iinfo);
+
+ } else {
+
+/* Q was determined by a call to DSYTRD with UPLO = 'L'. */
+
+/* Shift the vectors which define the elementary reflectors one */
+/* column to the right, and set the first row and column of Q to */
+/* those of the unit matrix */
+
+ for (j = *n; j >= 2; --j) {
+ a[j * a_dim1 + 1] = 0.;
+ i__1 = *n;
+ for (i__ = j + 1; i__ <= i__1; ++i__) {
+ a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1];
+/* L40: */
+ }
+/* L50: */
+ }
+ a[a_dim1 + 1] = 1.;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ a[i__ + a_dim1] = 0.;
+/* L60: */
+ }
+ if (*n > 1) {
+
+/* Generate Q(2:n,2:n) */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ dorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[1],
+ &work[1], lwork, &iinfo);
+ }
+ }
+ work[1] = (doublereal) lwkopt;
+ return 0;
+
+/* End of DORGTR */
+
+} /* dorgtr_ */
diff --git a/SRC/dorm2l.c b/SRC/dorm2l.c
new file mode 100644
index 0000000..de18e08
--- /dev/null
+++ b/SRC/dorm2l.c
@@ -0,0 +1,231 @@
+/* dorm2l.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dorm2l_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
+ c__, integer *ldc, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, i1, i2, i3, mi, ni, nq;
+ doublereal aii;
+ logical left;
+ extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORM2L overwrites the general real m by n matrix C with */
+
+/* Q * C if SIDE = 'L' and TRANS = 'N', or */
+
+/* Q'* C if SIDE = 'L' and TRANS = 'T', or */
+
+/* C * Q if SIDE = 'R' and TRANS = 'N', or */
+
+/* C * Q' if SIDE = 'R' and TRANS = 'T', */
+
+/* where Q is a real orthogonal matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q' from the Left */
+/* = 'R': apply Q or Q' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply Q (No transpose) */
+/* = 'T': apply Q' (Transpose) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,K) */
+/* The i-th column must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* DGEQLF in the last k columns of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If SIDE = 'L', LDA >= max(1,M); */
+/* if SIDE = 'R', LDA >= max(1,N). */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DGEQLF. */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/* On entry, the m by n matrix C. */
+/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (N) if SIDE = 'L', */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,nq)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DORM2L", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ return 0;
+ }
+
+ if (left && notran || ! left && ! notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = 1;
+ } else {
+ i1 = *k;
+ i2 = 1;
+ i3 = -1;
+ }
+
+ if (left) {
+ ni = *n;
+ } else {
+ mi = *m;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) is applied to C(1:m-k+i,1:n) */
+
+ mi = *m - *k + i__;
+ } else {
+
+/* H(i) is applied to C(1:m,1:n-k+i) */
+
+ ni = *n - *k + i__;
+ }
+
+/* Apply H(i) */
+
+ aii = a[nq - *k + i__ + i__ * a_dim1];
+ a[nq - *k + i__ + i__ * a_dim1] = 1.;
+ dlarf_(side, &mi, &ni, &a[i__ * a_dim1 + 1], &c__1, &tau[i__], &c__[
+ c_offset], ldc, &work[1]);
+ a[nq - *k + i__ + i__ * a_dim1] = aii;
+/* L10: */
+ }
+ return 0;
+
+/* End of DORM2L */
+
+} /* dorm2l_ */
diff --git a/SRC/dorm2r.c b/SRC/dorm2r.c
new file mode 100644
index 0000000..3a71756
--- /dev/null
+++ b/SRC/dorm2r.c
@@ -0,0 +1,235 @@
+/* dorm2r.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dorm2r_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
+ c__, integer *ldc, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, i1, i2, i3, ic, jc, mi, ni, nq;
+ doublereal aii;
+ logical left;
+ extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORM2R overwrites the general real m by n matrix C with */
+
+/* Q * C if SIDE = 'L' and TRANS = 'N', or */
+
+/* Q'* C if SIDE = 'L' and TRANS = 'T', or */
+
+/* C * Q if SIDE = 'R' and TRANS = 'N', or */
+
+/* C * Q' if SIDE = 'R' and TRANS = 'T', */
+
+/* where Q is a real orthogonal matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q' from the Left */
+/* = 'R': apply Q or Q' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply Q (No transpose) */
+/* = 'T': apply Q' (Transpose) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,K) */
+/* The i-th column must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* DGEQRF in the first k columns of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If SIDE = 'L', LDA >= max(1,M); */
+/* if SIDE = 'R', LDA >= max(1,N). */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DGEQRF. */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/* On entry, the m by n matrix C. */
+/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (N) if SIDE = 'L', */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,nq)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DORM2R", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ return 0;
+ }
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = 1;
+ } else {
+ i1 = *k;
+ i2 = 1;
+ i3 = -1;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H(i) is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H(i) */
+
+ aii = a[i__ + i__ * a_dim1];
+ a[i__ + i__ * a_dim1] = 1.;
+ dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &tau[i__], &c__[
+ ic + jc * c_dim1], ldc, &work[1]);
+ a[i__ + i__ * a_dim1] = aii;
+/* L10: */
+ }
+ return 0;
+
+/* End of DORM2R */
+
+} /* dorm2r_ */
diff --git a/SRC/dormbr.c b/SRC/dormbr.c
new file mode 100644
index 0000000..ca7e42a
--- /dev/null
+++ b/SRC/dormbr.c
@@ -0,0 +1,360 @@
+/* dormbr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int dormbr_(char *vect, char *side, char *trans, integer *m,
+ integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau,
+ doublereal *c__, integer *ldc, doublereal *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i1, i2, nb, mi, ni, nq, nw;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ logical notran;
+ extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ logical applyq;
+ char transt[1];
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C */
+/* with */
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'T': Q**T * C C * Q**T */
+
+/* If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C */
+/* with */
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': P * C C * P */
+/* TRANS = 'T': P**T * C C * P**T */
+
+/* Here Q and P**T are the orthogonal matrices determined by DGEBRD when */
+/* reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and */
+/* P**T are defined as products of elementary reflectors H(i) and G(i) */
+/* respectively. */
+
+/* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the */
+/* order of the orthogonal matrix Q or P**T that is applied. */
+
+/* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: */
+/* if nq >= k, Q = H(1) H(2) . . . H(k); */
+/* if nq < k, Q = H(1) H(2) . . . H(nq-1). */
+
+/* If VECT = 'P', A is assumed to have been a K-by-NQ matrix: */
+/* if k < nq, P = G(1) G(2) . . . G(k); */
+/* if k >= nq, P = G(1) G(2) . . . G(nq-1). */
+
+/* Arguments */
+/* ========= */
+
+/* VECT (input) CHARACTER*1 */
+/* = 'Q': apply Q or Q**T; */
+/* = 'P': apply P or P**T. */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q, Q**T, P or P**T from the Left; */
+/* = 'R': apply Q, Q**T, P or P**T from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q or P; */
+/* = 'T': Transpose, apply Q**T or P**T. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* If VECT = 'Q', the number of columns in the original */
+/* matrix reduced by DGEBRD. */
+/* If VECT = 'P', the number of rows in the original */
+/* matrix reduced by DGEBRD. */
+/* K >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension */
+/* (LDA,min(nq,K)) if VECT = 'Q' */
+/* (LDA,nq) if VECT = 'P' */
+/* The vectors which define the elementary reflectors H(i) and */
+/* G(i), whose products determine the matrices Q and P, as */
+/* returned by DGEBRD. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If VECT = 'Q', LDA >= max(1,nq); */
+/* if VECT = 'P', LDA >= max(1,min(nq,K)). */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (min(nq,K)) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i) or G(i) which determines Q or P, as returned */
+/* by DGEBRD in the array argument TAUQ or TAUP. */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q */
+/* or P*C or P**T*C or C*P or C*P**T. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ applyq = lsame_(vect, "Q");
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q or P and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = *n;
+ } else {
+ nq = *n;
+ nw = *m;
+ }
+ if (! applyq && ! lsame_(vect, "P")) {
+ *info = -1;
+ } else if (! left && ! lsame_(side, "R")) {
+ *info = -2;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*k < 0) {
+ *info = -6;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = 1, i__2 = min(nq,*k);
+ if (applyq && *lda < max(1,nq) || ! applyq && *lda < max(i__1,i__2)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -11;
+ } else if (*lwork < max(1,nw) && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info == 0) {
+ if (applyq) {
+ if (left) {
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ nb = ilaenv_(&c__1, "DORMQR", ch__1, &i__1, n, &i__2, &c_n1);
+ } else {
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ nb = ilaenv_(&c__1, "DORMQR", ch__1, m, &i__1, &i__2, &c_n1);
+ }
+ } else {
+ if (left) {
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ nb = ilaenv_(&c__1, "DORMLQ", ch__1, &i__1, n, &i__2, &c_n1);
+ } else {
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ nb = ilaenv_(&c__1, "DORMLQ", ch__1, m, &i__1, &i__2, &c_n1);
+ }
+ }
+ lwkopt = max(1,nw) * nb;
+ work[1] = (doublereal) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DORMBR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ work[1] = 1.;
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ if (applyq) {
+
+/* Apply Q */
+
+ if (nq >= *k) {
+
+/* Q was determined by a call to DGEBRD with nq >= k */
+
+ dormqr_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], lwork, &iinfo);
+ } else if (nq > 1) {
+
+/* Q was determined by a call to DGEBRD with nq < k */
+
+ if (left) {
+ mi = *m - 1;
+ ni = *n;
+ i1 = 2;
+ i2 = 1;
+ } else {
+ mi = *m;
+ ni = *n - 1;
+ i1 = 1;
+ i2 = 2;
+ }
+ i__1 = nq - 1;
+ dormqr_(side, trans, &mi, &ni, &i__1, &a[a_dim1 + 2], lda, &tau[1]
+, &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo);
+ }
+ } else {
+
+/* Apply P */
+
+ if (notran) {
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+ if (nq > *k) {
+
+/* P was determined by a call to DGEBRD with nq > k */
+
+ dormlq_(side, transt, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], lwork, &iinfo);
+ } else if (nq > 1) {
+
+/* P was determined by a call to DGEBRD with nq <= k */
+
+ if (left) {
+ mi = *m - 1;
+ ni = *n;
+ i1 = 2;
+ i2 = 1;
+ } else {
+ mi = *m;
+ ni = *n - 1;
+ i1 = 1;
+ i2 = 2;
+ }
+ i__1 = nq - 1;
+ dormlq_(side, transt, &mi, &ni, &i__1, &a[(a_dim1 << 1) + 1], lda,
+ &tau[1], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &
+ iinfo);
+ }
+ }
+ work[1] = (doublereal) lwkopt;
+ return 0;
+
+/* End of DORMBR */
+
+} /* dormbr_ */
diff --git a/SRC/dormhr.c b/SRC/dormhr.c
new file mode 100644
index 0000000..aa47061
--- /dev/null
+++ b/SRC/dormhr.c
@@ -0,0 +1,257 @@
+/* dormhr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int dormhr_(char *side, char *trans, integer *m, integer *n,
+ integer *ilo, integer *ihi, doublereal *a, integer *lda, doublereal *
+ tau, doublereal *c__, integer *ldc, doublereal *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i1, i2, nb, mi, nh, ni, nq, nw;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORMHR overwrites the general real M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'T': Q**T * C C * Q**T */
+
+/* where Q is a real orthogonal matrix of order nq, with nq = m if */
+/* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */
+/* IHI-ILO elementary reflectors, as returned by DGEHRD: */
+
+/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**T from the Left; */
+/* = 'R': apply Q or Q**T from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'T': Transpose, apply Q**T. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* ILO and IHI must have the same values as in the previous call */
+/* of DGEHRD. Q is equal to the unit matrix except in the */
+/* submatrix Q(ilo+1:ihi,ilo+1:ihi). */
+/* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and */
+/* ILO = 1 and IHI = 0, if M = 0; */
+/* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and */
+/* ILO = 1 and IHI = 0, if N = 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension */
+/* (LDA,M) if SIDE = 'L' */
+/* (LDA,N) if SIDE = 'R' */
+/* The vectors which define the elementary reflectors, as */
+/* returned by DGEHRD. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension */
+/* (M-1) if SIDE = 'L' */
+/* (N-1) if SIDE = 'R' */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DGEHRD. */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nh = *ihi - *ilo;
+ left = lsame_(side, "L");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = *n;
+ } else {
+ nq = *n;
+ nw = *m;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ilo < 1 || *ilo > max(1,nq)) {
+ *info = -5;
+ } else if (*ihi < min(*ilo,nq) || *ihi > nq) {
+ *info = -6;
+ } else if (*lda < max(1,nq)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -11;
+ } else if (*lwork < max(1,nw) && ! lquery) {
+ *info = -13;
+ }
+
+ if (*info == 0) {
+ if (left) {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ nb = ilaenv_(&c__1, "DORMQR", ch__1, &nh, n, &nh, &c_n1);
+ } else {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ nb = ilaenv_(&c__1, "DORMQR", ch__1, m, &nh, &nh, &c_n1);
+ }
+ lwkopt = max(1,nw) * nb;
+ work[1] = (doublereal) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__2 = -(*info);
+ xerbla_("DORMHR", &i__2);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || nh == 0) {
+ work[1] = 1.;
+ return 0;
+ }
+
+ if (left) {
+ mi = nh;
+ ni = *n;
+ i1 = *ilo + 1;
+ i2 = 1;
+ } else {
+ mi = *m;
+ ni = nh;
+ i1 = 1;
+ i2 = *ilo + 1;
+ }
+
+ dormqr_(side, trans, &mi, &ni, &nh, &a[*ilo + 1 + *ilo * a_dim1], lda, &
+ tau[*ilo], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo);
+
+ work[1] = (doublereal) lwkopt;
+ return 0;
+
+/* End of DORMHR */
+
+} /* dormhr_ */
diff --git a/SRC/dorml2.c b/SRC/dorml2.c
new file mode 100644
index 0000000..d482168
--- /dev/null
+++ b/SRC/dorml2.c
@@ -0,0 +1,231 @@
+/* dorml2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dorml2_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
+ c__, integer *ldc, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, i1, i2, i3, ic, jc, mi, ni, nq;
+ doublereal aii;
+ logical left;
+ extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORML2 overwrites the general real m by n matrix C with */
+
+/* Q * C if SIDE = 'L' and TRANS = 'N', or */
+
+/* Q'* C if SIDE = 'L' and TRANS = 'T', or */
+
+/* C * Q if SIDE = 'R' and TRANS = 'N', or */
+
+/* C * Q' if SIDE = 'R' and TRANS = 'T', */
+
+/* where Q is a real orthogonal matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q' from the Left */
+/* = 'R': apply Q or Q' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply Q (No transpose) */
+/* = 'T': apply Q' (Transpose) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* DGELQF in the first k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DGELQF. */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/* On entry, the m by n matrix C. */
+/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (N) if SIDE = 'L', */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,*k)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DORML2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ return 0;
+ }
+
+ if (left && notran || ! left && ! notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = 1;
+ } else {
+ i1 = *k;
+ i2 = 1;
+ i3 = -1;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H(i) is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H(i) */
+
+ aii = a[i__ + i__ * a_dim1];
+ a[i__ + i__ * a_dim1] = 1.;
+ dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &tau[i__], &c__[
+ ic + jc * c_dim1], ldc, &work[1]);
+ a[i__ + i__ * a_dim1] = aii;
+/* L10: */
+ }
+ return 0;
+
+/* End of DORML2 */
+
+} /* dorml2_ */
diff --git a/SRC/dormlq.c b/SRC/dormlq.c
new file mode 100644
index 0000000..c0d4b7b
--- /dev/null
+++ b/SRC/dormlq.c
@@ -0,0 +1,334 @@
+/* dormlq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int dormlq_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
+ c__, integer *ldc, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
+ i__5;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ doublereal t[4160] /* was [65][64] */;
+ integer i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iws;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int dorml2_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *), dlarfb_(char
+ *, char *, char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *), dlarft_(char *, char *, integer *, integer *, doublereal
+ *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical notran;
+ integer ldwork;
+ char transt[1];
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORMLQ overwrites the general real M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'T': Q**T * C C * Q**T */
+
+/* where Q is a real orthogonal matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**T from the Left; */
+/* = 'R': apply Q or Q**T from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'T': Transpose, apply Q**T. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* DGELQF in the first k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DGELQF. */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = *n;
+ } else {
+ nq = *n;
+ nw = *m;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,*k)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ } else if (*lwork < max(1,nw) && ! lquery) {
+ *info = -12;
+ }
+
+ if (*info == 0) {
+
+/* Determine the block size. NB may be at most NBMAX, where NBMAX */
+/* is used to define the local array T. */
+
+/* Computing MIN */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 64, i__2 = ilaenv_(&c__1, "DORMLQ", ch__1, m, n, k, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = max(1,nw) * nb;
+ work[1] = (doublereal) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DORMLQ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ work[1] = 1.;
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = nw;
+ if (nb > 1 && nb < *k) {
+ iws = nw * nb;
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 2, i__2 = ilaenv_(&c__2, "DORMLQ", ch__1, m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = nw;
+ }
+
+ if (nb < nbmin || nb >= *k) {
+
+/* Use unblocked code */
+
+ dorml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], &iinfo);
+ } else {
+
+/* Use blocked code */
+
+ if (left && notran || ! left && ! notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = nb;
+ } else {
+ i1 = (*k - 1) / nb * nb + 1;
+ i2 = 1;
+ i3 = -nb;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ }
+
+ if (notran) {
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *k - i__ + 1;
+ ib = min(i__4,i__5);
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__4 = nq - i__ + 1;
+ dlarft_("Forward", "Rowwise", &i__4, &ib, &a[i__ + i__ * a_dim1],
+ lda, &tau[i__], t, &c__65);
+ if (left) {
+
+/* H or H' is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H or H' is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H or H' */
+
+ dlarfb_(side, transt, "Forward", "Rowwise", &mi, &ni, &ib, &a[i__
+ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1],
+ ldc, &work[1], &ldwork);
+/* L10: */
+ }
+ }
+ work[1] = (doublereal) lwkopt;
+ return 0;
+
+/* End of DORMLQ */
+
+} /* dormlq_ */
diff --git a/SRC/dormql.c b/SRC/dormql.c
new file mode 100644
index 0000000..c2de211
--- /dev/null
+++ b/SRC/dormql.c
@@ -0,0 +1,327 @@
+/* dormql.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int dormql_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
+ c__, integer *ldc, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
+ i__5;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ doublereal t[4160] /* was [65][64] */;
+ integer i1, i2, i3, ib, nb, mi, ni, nq, nw, iws;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int dorm2l_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *), dlarfb_(char
+ *, char *, char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *), dlarft_(char *, char *, integer *, integer *, doublereal
+ *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical notran;
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORMQL overwrites the general real M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'T': Q**T * C C * Q**T */
+
+/* where Q is a real orthogonal matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by DGEQLF. Q is of order M if SIDE = 'L' and of order N */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**T from the Left; */
+/* = 'R': apply Q or Q**T from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'T': Transpose, apply Q**T. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,K) */
+/* The i-th column must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* DGEQLF in the last k columns of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If SIDE = 'L', LDA >= max(1,M); */
+/* if SIDE = 'R', LDA >= max(1,N). */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DGEQLF. */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = max(1,*n);
+ } else {
+ nq = *n;
+ nw = max(1,*m);
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,nq)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+
+ if (*info == 0) {
+ if (*m == 0 || *n == 0) {
+ lwkopt = 1;
+ } else {
+
+/* Determine the block size. NB may be at most NBMAX, where */
+/* NBMAX is used to define the local array T. */
+
+/* Computing MIN */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 64, i__2 = ilaenv_(&c__1, "DORMQL", ch__1, m, n, k, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = nw * nb;
+ }
+ work[1] = (doublereal) lwkopt;
+
+ if (*lwork < nw && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DORMQL", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = nw;
+ if (nb > 1 && nb < *k) {
+ iws = nw * nb;
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 2, i__2 = ilaenv_(&c__2, "DORMQL", ch__1, m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = nw;
+ }
+
+ if (nb < nbmin || nb >= *k) {
+
+/* Use unblocked code */
+
+ dorm2l_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], &iinfo);
+ } else {
+
+/* Use blocked code */
+
+ if (left && notran || ! left && ! notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = nb;
+ } else {
+ i1 = (*k - 1) / nb * nb + 1;
+ i2 = 1;
+ i3 = -nb;
+ }
+
+ if (left) {
+ ni = *n;
+ } else {
+ mi = *m;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *k - i__ + 1;
+ ib = min(i__4,i__5);
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__4 = nq - *k + i__ + ib - 1;
+ dlarft_("Backward", "Columnwise", &i__4, &ib, &a[i__ * a_dim1 + 1]
+, lda, &tau[i__], t, &c__65);
+ if (left) {
+
+/* H or H' is applied to C(1:m-k+i+ib-1,1:n) */
+
+ mi = *m - *k + i__ + ib - 1;
+ } else {
+
+/* H or H' is applied to C(1:m,1:n-k+i+ib-1) */
+
+ ni = *n - *k + i__ + ib - 1;
+ }
+
+/* Apply H or H' */
+
+ dlarfb_(side, trans, "Backward", "Columnwise", &mi, &ni, &ib, &a[
+ i__ * a_dim1 + 1], lda, t, &c__65, &c__[c_offset], ldc, &
+ work[1], &ldwork);
+/* L10: */
+ }
+ }
+ work[1] = (doublereal) lwkopt;
+ return 0;
+
+/* End of DORMQL */
+
+} /* dormql_ */
diff --git a/SRC/dormqr.c b/SRC/dormqr.c
new file mode 100644
index 0000000..aed95f2
--- /dev/null
+++ b/SRC/dormqr.c
@@ -0,0 +1,327 @@
+/* dormqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int dormqr_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
+ c__, integer *ldc, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
+ i__5;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ doublereal t[4160] /* was [65][64] */;
+ integer i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iws;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int dorm2r_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *), dlarfb_(char
+ *, char *, char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *), dlarft_(char *, char *, integer *, integer *, doublereal
+ *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical notran;
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORMQR overwrites the general real M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'T': Q**T * C C * Q**T */
+
+/* where Q is a real orthogonal matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**T from the Left; */
+/* = 'R': apply Q or Q**T from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'T': Transpose, apply Q**T. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,K) */
+/* The i-th column must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* DGEQRF in the first k columns of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If SIDE = 'L', LDA >= max(1,M); */
+/* if SIDE = 'R', LDA >= max(1,N). */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DGEQRF. */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = *n;
+ } else {
+ nq = *n;
+ nw = *m;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,nq)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ } else if (*lwork < max(1,nw) && ! lquery) {
+ *info = -12;
+ }
+
+ if (*info == 0) {
+
+/* Determine the block size. NB may be at most NBMAX, where NBMAX */
+/* is used to define the local array T. */
+
+/* Computing MIN */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 64, i__2 = ilaenv_(&c__1, "DORMQR", ch__1, m, n, k, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = max(1,nw) * nb;
+ work[1] = (doublereal) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DORMQR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ work[1] = 1.;
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = nw;
+ if (nb > 1 && nb < *k) {
+ iws = nw * nb;
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 2, i__2 = ilaenv_(&c__2, "DORMQR", ch__1, m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = nw;
+ }
+
+ if (nb < nbmin || nb >= *k) {
+
+/* Use unblocked code */
+
+ dorm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], &iinfo);
+ } else {
+
+/* Use blocked code */
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = nb;
+ } else {
+ i1 = (*k - 1) / nb * nb + 1;
+ i2 = 1;
+ i3 = -nb;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *k - i__ + 1;
+ ib = min(i__4,i__5);
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__4 = nq - i__ + 1;
+ dlarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], t, &c__65)
+ ;
+ if (left) {
+
+/* H or H' is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H or H' is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H or H' */
+
+ dlarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &a[
+ i__ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc *
+ c_dim1], ldc, &work[1], &ldwork);
+/* L10: */
+ }
+ }
+ work[1] = (doublereal) lwkopt;
+ return 0;
+
+/* End of DORMQR */
+
+} /* dormqr_ */
diff --git a/SRC/dormr2.c b/SRC/dormr2.c
new file mode 100644
index 0000000..78f726b
--- /dev/null
+++ b/SRC/dormr2.c
@@ -0,0 +1,227 @@
+/* dormr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dormr2_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
+ c__, integer *ldc, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, i1, i2, i3, mi, ni, nq;
+ doublereal aii;
+ logical left;
+ extern /* Subroutine */ int dlarf_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORMR2 overwrites the general real m by n matrix C with */
+
+/* Q * C if SIDE = 'L' and TRANS = 'N', or */
+
+/* Q'* C if SIDE = 'L' and TRANS = 'T', or */
+
+/* C * Q if SIDE = 'R' and TRANS = 'N', or */
+
+/* C * Q' if SIDE = 'R' and TRANS = 'T', */
+
+/* where Q is a real orthogonal matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by DGERQF. Q is of order m if SIDE = 'L' and of order n */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q' from the Left */
+/* = 'R': apply Q or Q' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply Q (No transpose) */
+/* = 'T': apply Q' (Transpose) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* DGERQF in the last k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DGERQF. */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/* On entry, the m by n matrix C. */
+/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (N) if SIDE = 'L', */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,*k)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DORMR2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ return 0;
+ }
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = 1;
+ } else {
+ i1 = *k;
+ i2 = 1;
+ i3 = -1;
+ }
+
+ if (left) {
+ ni = *n;
+ } else {
+ mi = *m;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) is applied to C(1:m-k+i,1:n) */
+
+ mi = *m - *k + i__;
+ } else {
+
+/* H(i) is applied to C(1:m,1:n-k+i) */
+
+ ni = *n - *k + i__;
+ }
+
+/* Apply H(i) */
+
+ aii = a[i__ + (nq - *k + i__) * a_dim1];
+ a[i__ + (nq - *k + i__) * a_dim1] = 1.;
+ dlarf_(side, &mi, &ni, &a[i__ + a_dim1], lda, &tau[i__], &c__[
+ c_offset], ldc, &work[1]);
+ a[i__ + (nq - *k + i__) * a_dim1] = aii;
+/* L10: */
+ }
+ return 0;
+
+/* End of DORMR2 */
+
+} /* dormr2_ */
diff --git a/SRC/dormr3.c b/SRC/dormr3.c
new file mode 100644
index 0000000..5fb412a
--- /dev/null
+++ b/SRC/dormr3.c
@@ -0,0 +1,241 @@
+/* dormr3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dormr3_(char *side, char *trans, integer *m, integer *n,
+ integer *k, integer *l, doublereal *a, integer *lda, doublereal *tau,
+ doublereal *c__, integer *ldc, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, i1, i2, i3, ja, ic, jc, mi, ni, nq;
+ logical left;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dlarz_(char *, integer *, integer *, integer *
+, doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *), xerbla_(char *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORMR3 overwrites the general real m by n matrix C with */
+
+/* Q * C if SIDE = 'L' and TRANS = 'N', or */
+
+/* Q'* C if SIDE = 'L' and TRANS = 'T', or */
+
+/* C * Q if SIDE = 'R' and TRANS = 'N', or */
+
+/* C * Q' if SIDE = 'R' and TRANS = 'T', */
+
+/* where Q is a real orthogonal matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by DTZRZF. Q is of order m if SIDE = 'L' and of order n */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q' from the Left */
+/* = 'R': apply Q or Q' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply Q (No transpose) */
+/* = 'T': apply Q' (Transpose) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* L (input) INTEGER */
+/* The number of columns of the matrix A containing */
+/* the meaningful part of the Householder reflectors. */
+/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* DTZRZF in the last k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DTZRZF. */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/* On entry, the m-by-n matrix C. */
+/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (N) if SIDE = 'L', */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*l < 0 || left && *l > *m || ! left && *l > *n) {
+ *info = -6;
+ } else if (*lda < max(1,*k)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DORMR3", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ return 0;
+ }
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = 1;
+ } else {
+ i1 = *k;
+ i2 = 1;
+ i3 = -1;
+ }
+
+ if (left) {
+ ni = *n;
+ ja = *m - *l + 1;
+ jc = 1;
+ } else {
+ mi = *m;
+ ja = *n - *l + 1;
+ ic = 1;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) or H(i)' is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H(i) or H(i)' is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H(i) or H(i)' */
+
+ dlarz_(side, &mi, &ni, l, &a[i__ + ja * a_dim1], lda, &tau[i__], &c__[
+ ic + jc * c_dim1], ldc, &work[1]);
+
+/* L10: */
+ }
+
+ return 0;
+
+/* End of DORMR3 */
+
+} /* dormr3_ */
diff --git a/SRC/dormrq.c b/SRC/dormrq.c
new file mode 100644
index 0000000..d52843b
--- /dev/null
+++ b/SRC/dormrq.c
@@ -0,0 +1,335 @@
+/* dormrq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int dormrq_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
+ c__, integer *ldc, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
+ i__5;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ doublereal t[4160] /* was [65][64] */;
+ integer i1, i2, i3, ib, nb, mi, ni, nq, nw, iws;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int dormr2_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *), dlarfb_(char
+ *, char *, char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *), dlarft_(char *, char *, integer *, integer *, doublereal
+ *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical notran;
+ integer ldwork;
+ char transt[1];
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORMRQ overwrites the general real M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'T': Q**T * C C * Q**T */
+
+/* where Q is a real orthogonal matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by DGERQF. Q is of order M if SIDE = 'L' and of order N */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**T from the Left; */
+/* = 'R': apply Q or Q**T from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'T': Transpose, apply Q**T. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* DGERQF in the last k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DGERQF. */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = max(1,*n);
+ } else {
+ nq = *n;
+ nw = max(1,*m);
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,*k)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+
+ if (*info == 0) {
+ if (*m == 0 || *n == 0) {
+ lwkopt = 1;
+ } else {
+
+/* Determine the block size. NB may be at most NBMAX, where */
+/* NBMAX is used to define the local array T. */
+
+/* Computing MIN */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 64, i__2 = ilaenv_(&c__1, "DORMRQ", ch__1, m, n, k, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = nw * nb;
+ }
+ work[1] = (doublereal) lwkopt;
+
+ if (*lwork < nw && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DORMRQ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = nw;
+ if (nb > 1 && nb < *k) {
+ iws = nw * nb;
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 2, i__2 = ilaenv_(&c__2, "DORMRQ", ch__1, m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = nw;
+ }
+
+ if (nb < nbmin || nb >= *k) {
+
+/* Use unblocked code */
+
+ dormr2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], &iinfo);
+ } else {
+
+/* Use blocked code */
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = nb;
+ } else {
+ i1 = (*k - 1) / nb * nb + 1;
+ i2 = 1;
+ i3 = -nb;
+ }
+
+ if (left) {
+ ni = *n;
+ } else {
+ mi = *m;
+ }
+
+ if (notran) {
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *k - i__ + 1;
+ ib = min(i__4,i__5);
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__4 = nq - *k + i__ + ib - 1;
+ dlarft_("Backward", "Rowwise", &i__4, &ib, &a[i__ + a_dim1], lda,
+ &tau[i__], t, &c__65);
+ if (left) {
+
+/* H or H' is applied to C(1:m-k+i+ib-1,1:n) */
+
+ mi = *m - *k + i__ + ib - 1;
+ } else {
+
+/* H or H' is applied to C(1:m,1:n-k+i+ib-1) */
+
+ ni = *n - *k + i__ + ib - 1;
+ }
+
+/* Apply H or H' */
+
+ dlarfb_(side, transt, "Backward", "Rowwise", &mi, &ni, &ib, &a[
+ i__ + a_dim1], lda, t, &c__65, &c__[c_offset], ldc, &work[
+ 1], &ldwork);
+/* L10: */
+ }
+ }
+ work[1] = (doublereal) lwkopt;
+ return 0;
+
+/* End of DORMRQ */
+
+} /* dormrq_ */
diff --git a/SRC/dormrz.c b/SRC/dormrz.c
new file mode 100644
index 0000000..ec368fa
--- /dev/null
+++ b/SRC/dormrz.c
@@ -0,0 +1,362 @@
+/* dormrz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int dormrz_(char *side, char *trans, integer *m, integer *n,
+ integer *k, integer *l, doublereal *a, integer *lda, doublereal *tau,
+ doublereal *c__, integer *ldc, doublereal *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
+ i__5;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ doublereal t[4160] /* was [65][64] */;
+ integer i1, i2, i3, ib, ic, ja, jc, nb, mi, ni, nq, nw, iws;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int dormr3_(char *, char *, integer *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dlarzb_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, doublereal *, integer
+ *, doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dlarzt_(char *, char
+ *, integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *);
+ logical notran;
+ integer ldwork;
+ char transt[1];
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORMRZ overwrites the general real M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'T': Q**T * C C * Q**T */
+
+/* where Q is a real orthogonal matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by DTZRZF. Q is of order M if SIDE = 'L' and of order N */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**T from the Left; */
+/* = 'R': apply Q or Q**T from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'T': Transpose, apply Q**T. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* L (input) INTEGER */
+/* The number of columns of the matrix A containing */
+/* the meaningful part of the Householder reflectors. */
+/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* DTZRZF in the last k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DTZRZF. */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = max(1,*n);
+ } else {
+ nq = *n;
+ nw = max(1,*m);
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*l < 0 || left && *l > *m || ! left && *l > *n) {
+ *info = -6;
+ } else if (*lda < max(1,*k)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -11;
+ }
+
+ if (*info == 0) {
+ if (*m == 0 || *n == 0) {
+ lwkopt = 1;
+ } else {
+
+/* Determine the block size. NB may be at most NBMAX, where */
+/* NBMAX is used to define the local array T. */
+
+/* Computing MIN */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 64, i__2 = ilaenv_(&c__1, "DORMRQ", ch__1, m, n, k, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = nw * nb;
+ }
+ work[1] = (doublereal) lwkopt;
+
+ if (*lwork < max(1,nw) && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DORMRZ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ work[1] = 1.;
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = nw;
+ if (nb > 1 && nb < *k) {
+ iws = nw * nb;
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 2, i__2 = ilaenv_(&c__2, "DORMRQ", ch__1, m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = nw;
+ }
+
+ if (nb < nbmin || nb >= *k) {
+
+/* Use unblocked code */
+
+ dormr3_(side, trans, m, n, k, l, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], &iinfo);
+ } else {
+
+/* Use blocked code */
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = nb;
+ } else {
+ i1 = (*k - 1) / nb * nb + 1;
+ i2 = 1;
+ i3 = -nb;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ ja = *m - *l + 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ ja = *n - *l + 1;
+ }
+
+ if (notran) {
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *k - i__ + 1;
+ ib = min(i__4,i__5);
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ dlarzt_("Backward", "Rowwise", l, &ib, &a[i__ + ja * a_dim1], lda,
+ &tau[i__], t, &c__65);
+
+ if (left) {
+
+/* H or H' is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H or H' is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H or H' */
+
+ dlarzb_(side, transt, "Backward", "Rowwise", &mi, &ni, &ib, l, &a[
+ i__ + ja * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1]
+, ldc, &work[1], &ldwork);
+/* L10: */
+ }
+
+ }
+
+ work[1] = (doublereal) lwkopt;
+
+ return 0;
+
+/* End of DORMRZ */
+
+} /* dormrz_ */
diff --git a/SRC/dormtr.c b/SRC/dormtr.c
new file mode 100644
index 0000000..da2691f
--- /dev/null
+++ b/SRC/dormtr.c
@@ -0,0 +1,295 @@
+/* dormtr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int dormtr_(char *side, char *uplo, char *trans, integer *m,
+ integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *
+ c__, integer *ldc, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2, i__3;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i1, i2, nb, mi, ni, nq, nw;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dormql_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *),
+ dormqr_(char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORMTR overwrites the general real M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'T': Q**T * C C * Q**T */
+
+/* where Q is a real orthogonal matrix of order nq, with nq = m if */
+/* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */
+/* nq-1 elementary reflectors, as returned by DSYTRD: */
+
+/* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); */
+
+/* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**T from the Left; */
+/* = 'R': apply Q or Q**T from the Right. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A contains elementary reflectors */
+/* from DSYTRD; */
+/* = 'L': Lower triangle of A contains elementary reflectors */
+/* from DSYTRD. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'T': Transpose, apply Q**T. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension */
+/* (LDA,M) if SIDE = 'L' */
+/* (LDA,N) if SIDE = 'R' */
+/* The vectors which define the elementary reflectors, as */
+/* returned by DSYTRD. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension */
+/* (M-1) if SIDE = 'L' */
+/* (N-1) if SIDE = 'R' */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by DSYTRD. */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = *n;
+ } else {
+ nq = *n;
+ nw = *m;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T")) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,nq)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ } else if (*lwork < max(1,nw) && ! lquery) {
+ *info = -12;
+ }
+
+ if (*info == 0) {
+ if (upper) {
+ if (left) {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ nb = ilaenv_(&c__1, "DORMQL", ch__1, &i__2, n, &i__3, &c_n1);
+ } else {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ nb = ilaenv_(&c__1, "DORMQL", ch__1, m, &i__2, &i__3, &c_n1);
+ }
+ } else {
+ if (left) {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ nb = ilaenv_(&c__1, "DORMQR", ch__1, &i__2, n, &i__3, &c_n1);
+ } else {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ nb = ilaenv_(&c__1, "DORMQR", ch__1, m, &i__2, &i__3, &c_n1);
+ }
+ }
+ lwkopt = max(1,nw) * nb;
+ work[1] = (doublereal) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__2 = -(*info);
+ xerbla_("DORMTR", &i__2);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || nq == 1) {
+ work[1] = 1.;
+ return 0;
+ }
+
+ if (left) {
+ mi = *m - 1;
+ ni = *n;
+ } else {
+ mi = *m;
+ ni = *n - 1;
+ }
+
+ if (upper) {
+
+/* Q was determined by a call to DSYTRD with UPLO = 'U' */
+
+ i__2 = nq - 1;
+ dormql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, &
+ tau[1], &c__[c_offset], ldc, &work[1], lwork, &iinfo);
+ } else {
+
+/* Q was determined by a call to DSYTRD with UPLO = 'L' */
+
+ if (left) {
+ i1 = 2;
+ i2 = 1;
+ } else {
+ i1 = 1;
+ i2 = 2;
+ }
+ i__2 = nq - 1;
+ dormqr_(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], &
+ c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo);
+ }
+ work[1] = (doublereal) lwkopt;
+ return 0;
+
+/* End of DORMTR */
+
+} /* dormtr_ */
diff --git a/SRC/dpbcon.c b/SRC/dpbcon.c
new file mode 100644
index 0000000..0971a58
--- /dev/null
+++ b/SRC/dpbcon.c
@@ -0,0 +1,233 @@
+/* dpbcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dpbcon_(char *uplo, integer *n, integer *kd, doublereal *
+ ab, integer *ldab, doublereal *anorm, doublereal *rcond, doublereal *
+ work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1;
+ doublereal d__1;
+
+ /* Local variables */
+ integer ix, kase;
+ doublereal scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int drscl_(integer *, doublereal *, doublereal *,
+ integer *);
+ logical upper;
+ extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal scalel;
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dlatbs_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *);
+ doublereal scaleu;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal ainvnm;
+ char normin[1];
+ doublereal smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPBCON estimates the reciprocal of the condition number (in the */
+/* 1-norm) of a real symmetric positive definite band matrix using the */
+/* Cholesky factorization A = U**T*U or A = L*L**T computed by DPBTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular factor stored in AB; */
+/* = 'L': Lower triangular factor stored in AB. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T of the band matrix A, stored in the */
+/* first KD+1 rows of the array. The j-th column of U or L is */
+/* stored in the j-th column of the array AB as follows: */
+/* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* ANORM (input) DOUBLE PRECISION */
+/* The 1-norm (or infinity-norm) of the symmetric band matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*ldab < *kd + 1) {
+ *info = -5;
+ } else if (*anorm < 0.) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPBCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.;
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ } else if (*anorm == 0.) {
+ return 0;
+ }
+
+ smlnum = dlamch_("Safe minimum");
+
+/* Estimate the 1-norm of the inverse. */
+
+ kase = 0;
+ *(unsigned char *)normin = 'N';
+L10:
+ dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (upper) {
+
+/* Multiply by inv(U'). */
+
+ dlatbs_("Upper", "Transpose", "Non-unit", normin, n, kd, &ab[
+ ab_offset], ldab, &work[1], &scalel, &work[(*n << 1) + 1],
+ info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(U). */
+
+ dlatbs_("Upper", "No transpose", "Non-unit", normin, n, kd, &ab[
+ ab_offset], ldab, &work[1], &scaleu, &work[(*n << 1) + 1],
+ info);
+ } else {
+
+/* Multiply by inv(L). */
+
+ dlatbs_("Lower", "No transpose", "Non-unit", normin, n, kd, &ab[
+ ab_offset], ldab, &work[1], &scalel, &work[(*n << 1) + 1],
+ info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(L'). */
+
+ dlatbs_("Lower", "Transpose", "Non-unit", normin, n, kd, &ab[
+ ab_offset], ldab, &work[1], &scaleu, &work[(*n << 1) + 1],
+ info);
+ }
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ scale = scalel * scaleu;
+ if (scale != 1.) {
+ ix = idamax_(n, &work[1], &c__1);
+ if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.)
+ {
+ goto L20;
+ }
+ drscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / ainvnm / *anorm;
+ }
+
+L20:
+
+ return 0;
+
+/* End of DPBCON */
+
+} /* dpbcon_ */
diff --git a/SRC/dpbequ.c b/SRC/dpbequ.c
new file mode 100644
index 0000000..18baa51
--- /dev/null
+++ b/SRC/dpbequ.c
@@ -0,0 +1,203 @@
+/* dpbequ.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dpbequ_(char *uplo, integer *n, integer *kd, doublereal *
+ ab, integer *ldab, doublereal *s, doublereal *scond, doublereal *amax,
+ integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal smin;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPBEQU computes row and column scalings intended to equilibrate a */
+/* symmetric positive definite band matrix A and reduce its condition */
+/* number (with respect to the two-norm). S contains the scale factors, */
+/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
+/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
+/* choice of S puts the condition number of B within a factor N of the */
+/* smallest possible condition number over all possible diagonal */
+/* scalings. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular of A is stored; */
+/* = 'L': Lower triangular of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The upper or lower triangle of the symmetric band matrix A, */
+/* stored in the first KD+1 rows of the array. The j-th column */
+/* of A is stored in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array A. LDAB >= KD+1. */
+
+/* S (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, S contains the scale factors for A. */
+
+/* SCOND (output) DOUBLE PRECISION */
+/* If INFO = 0, S contains the ratio of the smallest S(i) to */
+/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
+/* large nor too small, it is not worth scaling by S. */
+
+/* AMAX (output) DOUBLE PRECISION */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --s;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*ldab < *kd + 1) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPBEQU", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *scond = 1.;
+ *amax = 0.;
+ return 0;
+ }
+
+ if (upper) {
+ j = *kd + 1;
+ } else {
+ j = 1;
+ }
+
+/* Initialize SMIN and AMAX. */
+
+ s[1] = ab[j + ab_dim1];
+ smin = s[1];
+ *amax = s[1];
+
+/* Find the minimum and maximum diagonal elements. */
+
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ s[i__] = ab[j + i__ * ab_dim1];
+/* Computing MIN */
+ d__1 = smin, d__2 = s[i__];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = *amax, d__2 = s[i__];
+ *amax = max(d__1,d__2);
+/* L10: */
+ }
+
+ if (smin <= 0.) {
+
+/* Find the first non-positive diagonal element and return. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] <= 0.) {
+ *info = i__;
+ return 0;
+ }
+/* L20: */
+ }
+ } else {
+
+/* Set the scale factors to the reciprocals */
+/* of the diagonal elements. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s[i__] = 1. / sqrt(s[i__]);
+/* L30: */
+ }
+
+/* Compute SCOND = min(S(I)) / max(S(I)) */
+
+ *scond = sqrt(smin) / sqrt(*amax);
+ }
+ return 0;
+
+/* End of DPBEQU */
+
+} /* dpbequ_ */
diff --git a/SRC/dpbrfs.c b/SRC/dpbrfs.c
new file mode 100644
index 0000000..9239551
--- /dev/null
+++ b/SRC/dpbrfs.c
@@ -0,0 +1,438 @@
+/* dpbrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b12 = -1.;
+static doublereal c_b14 = 1.;
+
+/* Subroutine */ int dpbrfs_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb,
+ doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
+ ferr, doublereal *berr, doublereal *work, integer *iwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, k, l;
+ doublereal s, xk;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int dsbmv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dcopy_(integer *,
+ doublereal *, integer *, doublereal *, integer *), daxpy_(integer
+ *, doublereal *, doublereal *, integer *, doublereal *, integer *)
+ ;
+ integer count;
+ logical upper;
+ extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *), dpbtrs_(
+ char *, integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, integer *);
+ doublereal lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPBRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric positive definite */
+/* and banded, and provides error bounds and backward error estimates */
+/* for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The upper or lower triangle of the symmetric band matrix A, */
+/* stored in the first KD+1 rows of the array. The j-th column */
+/* of A is stored in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T of the band matrix A as computed by */
+/* DPBTRF, in the same storage format as A (see AB). */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= KD+1. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by DPBTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldab < *kd + 1) {
+ *info = -6;
+ } else if (*ldafb < *kd + 1) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldx < max(1,*n)) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPBRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+/* Computing MIN */
+ i__1 = *n + 1, i__2 = (*kd << 1) + 2;
+ nz = min(i__1,i__2);
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+ dsbmv_(uplo, n, kd, &c_b12, &ab[ab_offset], ldab, &x[j * x_dim1 + 1],
+ &c__1, &c_b14, &work[*n + 1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+ l = *kd + 1 - k;
+/* Computing MAX */
+ i__3 = 1, i__4 = k - *kd;
+ i__5 = k - 1;
+ for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
+ work[i__] += (d__1 = ab[l + i__ + k * ab_dim1], abs(d__1))
+ * xk;
+ s += (d__1 = ab[l + i__ + k * ab_dim1], abs(d__1)) * (
+ d__2 = x[i__ + j * x_dim1], abs(d__2));
+/* L40: */
+ }
+ work[k] = work[k] + (d__1 = ab[*kd + 1 + k * ab_dim1], abs(
+ d__1)) * xk + s;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+ work[k] += (d__1 = ab[k * ab_dim1 + 1], abs(d__1)) * xk;
+ l = 1 - k;
+/* Computing MIN */
+ i__3 = *n, i__4 = k + *kd;
+ i__5 = min(i__3,i__4);
+ for (i__ = k + 1; i__ <= i__5; ++i__) {
+ work[i__] += (d__1 = ab[l + i__ + k * ab_dim1], abs(d__1))
+ * xk;
+ s += (d__1 = ab[l + i__ + k * ab_dim1], abs(d__1)) * (
+ d__2 = x[i__ + j * x_dim1], abs(d__2));
+/* L60: */
+ }
+ work[k] += s;
+/* L70: */
+ }
+ }
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[
+ i__];
+ s = max(d__2,d__3);
+ } else {
+/* Computing MAX */
+ d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1)
+ / (work[i__] + safe1);
+ s = max(d__2,d__3);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ dpbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[*n + 1]
+, n, info);
+ daxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
+ ;
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use DLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+ kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ dpbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[*n
+ + 1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] *= work[i__];
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] *= work[i__];
+/* L120: */
+ }
+ dpbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[*n
+ + 1], n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1));
+ lstres = max(d__2,d__3);
+/* L130: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of DPBRFS */
+
+} /* dpbrfs_ */
diff --git a/SRC/dpbstf.c b/SRC/dpbstf.c
new file mode 100644
index 0000000..83ae6c2
--- /dev/null
+++ b/SRC/dpbstf.c
@@ -0,0 +1,312 @@
+/* dpbstf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b9 = -1.;
+
+/* Subroutine */ int dpbstf_(char *uplo, integer *n, integer *kd, doublereal *
+ ab, integer *ldab, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer j, m, km;
+ doublereal ajj;
+ integer kld;
+ extern /* Subroutine */ int dsyr_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *), dscal_(
+ integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPBSTF computes a split Cholesky factorization of a real */
+/* symmetric positive definite band matrix A. */
+
+/* This routine is designed to be used in conjunction with DSBGST. */
+
+/* The factorization has the form A = S**T*S where S is a band matrix */
+/* of the same bandwidth as A and the following structure: */
+
+/* S = ( U ) */
+/* ( M L ) */
+
+/* where U is upper triangular of order m = (n+kd)/2, and L is lower */
+/* triangular of order n-m. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first kd+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, if INFO = 0, the factor S from the split Cholesky */
+/* factorization A = S**T*S. See Further Details. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the factorization could not be completed, */
+/* because the updated element a(i,i) was negative; the */
+/* matrix A is not positive definite. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* N = 7, KD = 2: */
+
+/* S = ( s11 s12 s13 ) */
+/* ( s22 s23 s24 ) */
+/* ( s33 s34 ) */
+/* ( s44 ) */
+/* ( s53 s54 s55 ) */
+/* ( s64 s65 s66 ) */
+/* ( s75 s76 s77 ) */
+
+/* If UPLO = 'U', the array AB holds: */
+
+/* on entry: on exit: */
+
+/* * * a13 a24 a35 a46 a57 * * s13 s24 s53 s64 s75 */
+/* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54 s65 s76 */
+/* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 */
+
+/* If UPLO = 'L', the array AB holds: */
+
+/* on entry: on exit: */
+
+/* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 */
+/* a21 a32 a43 a54 a65 a76 * s12 s23 s34 s54 s65 s76 * */
+/* a31 a42 a53 a64 a64 * * s13 s24 s53 s64 s75 * * */
+
+/* Array elements marked * are not used by the routine. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*ldab < *kd + 1) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPBSTF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *ldab - 1;
+ kld = max(i__1,i__2);
+
+/* Set the splitting point m. */
+
+ m = (*n + *kd) / 2;
+
+ if (upper) {
+
+/* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m). */
+
+ i__1 = m + 1;
+ for (j = *n; j >= i__1; --j) {
+
+/* Compute s(j,j) and test for non-positive-definiteness. */
+
+ ajj = ab[*kd + 1 + j * ab_dim1];
+ if (ajj <= 0.) {
+ goto L50;
+ }
+ ajj = sqrt(ajj);
+ ab[*kd + 1 + j * ab_dim1] = ajj;
+/* Computing MIN */
+ i__2 = j - 1;
+ km = min(i__2,*kd);
+
+/* Compute elements j-km:j-1 of the j-th column and update the */
+/* the leading submatrix within the band. */
+
+ d__1 = 1. / ajj;
+ dscal_(&km, &d__1, &ab[*kd + 1 - km + j * ab_dim1], &c__1);
+ dsyr_("Upper", &km, &c_b9, &ab[*kd + 1 - km + j * ab_dim1], &c__1,
+ &ab[*kd + 1 + (j - km) * ab_dim1], &kld);
+/* L10: */
+ }
+
+/* Factorize the updated submatrix A(1:m,1:m) as U**T*U. */
+
+ i__1 = m;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute s(j,j) and test for non-positive-definiteness. */
+
+ ajj = ab[*kd + 1 + j * ab_dim1];
+ if (ajj <= 0.) {
+ goto L50;
+ }
+ ajj = sqrt(ajj);
+ ab[*kd + 1 + j * ab_dim1] = ajj;
+/* Computing MIN */
+ i__2 = *kd, i__3 = m - j;
+ km = min(i__2,i__3);
+
+/* Compute elements j+1:j+km of the j-th row and update the */
+/* trailing submatrix within the band. */
+
+ if (km > 0) {
+ d__1 = 1. / ajj;
+ dscal_(&km, &d__1, &ab[*kd + (j + 1) * ab_dim1], &kld);
+ dsyr_("Upper", &km, &c_b9, &ab[*kd + (j + 1) * ab_dim1], &kld,
+ &ab[*kd + 1 + (j + 1) * ab_dim1], &kld);
+ }
+/* L20: */
+ }
+ } else {
+
+/* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m). */
+
+ i__1 = m + 1;
+ for (j = *n; j >= i__1; --j) {
+
+/* Compute s(j,j) and test for non-positive-definiteness. */
+
+ ajj = ab[j * ab_dim1 + 1];
+ if (ajj <= 0.) {
+ goto L50;
+ }
+ ajj = sqrt(ajj);
+ ab[j * ab_dim1 + 1] = ajj;
+/* Computing MIN */
+ i__2 = j - 1;
+ km = min(i__2,*kd);
+
+/* Compute elements j-km:j-1 of the j-th row and update the */
+/* trailing submatrix within the band. */
+
+ d__1 = 1. / ajj;
+ dscal_(&km, &d__1, &ab[km + 1 + (j - km) * ab_dim1], &kld);
+ dsyr_("Lower", &km, &c_b9, &ab[km + 1 + (j - km) * ab_dim1], &kld,
+ &ab[(j - km) * ab_dim1 + 1], &kld);
+/* L30: */
+ }
+
+/* Factorize the updated submatrix A(1:m,1:m) as U**T*U. */
+
+ i__1 = m;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute s(j,j) and test for non-positive-definiteness. */
+
+ ajj = ab[j * ab_dim1 + 1];
+ if (ajj <= 0.) {
+ goto L50;
+ }
+ ajj = sqrt(ajj);
+ ab[j * ab_dim1 + 1] = ajj;
+/* Computing MIN */
+ i__2 = *kd, i__3 = m - j;
+ km = min(i__2,i__3);
+
+/* Compute elements j+1:j+km of the j-th column and update the */
+/* trailing submatrix within the band. */
+
+ if (km > 0) {
+ d__1 = 1. / ajj;
+ dscal_(&km, &d__1, &ab[j * ab_dim1 + 2], &c__1);
+ dsyr_("Lower", &km, &c_b9, &ab[j * ab_dim1 + 2], &c__1, &ab[(
+ j + 1) * ab_dim1 + 1], &kld);
+ }
+/* L40: */
+ }
+ }
+ return 0;
+
+L50:
+ *info = j;
+ return 0;
+
+/* End of DPBSTF */
+
+} /* dpbstf_ */
diff --git a/SRC/dpbsv.c b/SRC/dpbsv.c
new file mode 100644
index 0000000..510dd25
--- /dev/null
+++ b/SRC/dpbsv.c
@@ -0,0 +1,182 @@
+/* dpbsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dpbsv_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, doublereal *ab, integer *ldab, doublereal *b, integer *ldb,
+ integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), dpbtrf_(
+ char *, integer *, integer *, doublereal *, integer *, integer *), dpbtrs_(char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPBSV computes the solution to a real system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N symmetric positive definite band matrix and X */
+/* and B are N-by-NRHS matrices. */
+
+/* The Cholesky decomposition is used to factor A as */
+/* A = U**T * U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular band matrix, and L is a lower */
+/* triangular band matrix, with the same number of superdiagonals or */
+/* subdiagonals as A. The factored form of A is then used to solve the */
+/* system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD). */
+/* See below for further details. */
+
+/* On exit, if INFO = 0, the triangular factor U or L from the */
+/* Cholesky factorization A = U**T*U or A = L*L**T of the band */
+/* matrix A, in the same storage format as A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i of A is not */
+/* positive definite, so the factorization could not be */
+/* completed, and the solution has not been computed. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* N = 6, KD = 2, and UPLO = 'U': */
+
+/* On entry: On exit: */
+
+/* * * a13 a24 a35 a46 * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+
+/* Similarly, if UPLO = 'L' the format of A is as follows: */
+
+/* On entry: On exit: */
+
+/* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */
+/* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */
+/* a31 a42 a53 a64 * * l31 l42 l53 l64 * * */
+
+/* Array elements marked * are not used by the routine. */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldab < *kd + 1) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPBSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ dpbtrf_(uplo, n, kd, &ab[ab_offset], ldab, info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ dpbtrs_(uplo, n, kd, nrhs, &ab[ab_offset], ldab, &b[b_offset], ldb,
+ info);
+
+ }
+ return 0;
+
+/* End of DPBSV */
+
+} /* dpbsv_ */
diff --git a/SRC/dpbsvx.c b/SRC/dpbsvx.c
new file mode 100644
index 0000000..5ba6e22
--- /dev/null
+++ b/SRC/dpbsvx.c
@@ -0,0 +1,515 @@
+/* dpbsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dpbsvx_(char *fact, char *uplo, integer *n, integer *kd,
+ integer *nrhs, doublereal *ab, integer *ldab, doublereal *afb,
+ integer *ldafb, char *equed, doublereal *s, doublereal *b, integer *
+ ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *ferr,
+ doublereal *berr, doublereal *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer i__, j, j1, j2;
+ doublereal amax, smin, smax;
+ extern logical lsame_(char *, char *);
+ doublereal scond, anorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical equil, rcequ, upper;
+ extern doublereal dlamch_(char *), dlansb_(char *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dpbcon_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *), dlaqsb_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, char *);
+ logical nofact;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *), dpbequ_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dpbrfs_(char *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *), dpbtrf_(char *,
+ integer *, integer *, doublereal *, integer *, integer *);
+ integer infequ;
+ extern /* Subroutine */ int dpbtrs_(char *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, integer *, integer *);
+ doublereal smlnum;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to */
+/* compute the solution to a real system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N symmetric positive definite band matrix and X */
+/* and B are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+/* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
+
+/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */
+/* factor the matrix A (after equilibration if FACT = 'E') as */
+/* A = U**T * U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular band matrix, and L is a lower */
+/* triangular band matrix. */
+
+/* 3. If the leading i-by-i principal minor is not positive definite, */
+/* then the routine returns with INFO = i. Otherwise, the factored */
+/* form of A is used to estimate the condition number of the matrix */
+/* A. If the reciprocal of the condition number is less than machine */
+/* precision, INFO = N+1 is returned as a warning, but the routine */
+/* still goes on to solve for X and compute error bounds as */
+/* described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(S) so that it solves the original system before */
+/* equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AFB contains the factored form of A. */
+/* If EQUED = 'Y', the matrix A has been equilibrated */
+/* with scaling factors given by S. AB and AFB will not */
+/* be modified. */
+/* = 'N': The matrix A will be copied to AFB and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AFB and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right-hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first KD+1 rows of the array, except */
+/* if FACT = 'F' and EQUED = 'Y', then A must contain the */
+/* equilibrated matrix diag(S)*A*diag(S). The j-th column of A */
+/* is stored in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD). */
+/* See below for further details. */
+
+/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
+/* diag(S)*A*diag(S). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array A. LDAB >= KD+1. */
+
+/* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N) */
+/* If FACT = 'F', then AFB is an input argument and on entry */
+/* contains the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T of the band matrix */
+/* A, in the same storage format as A (see AB). If EQUED = 'Y', */
+/* then AFB is the factored form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AFB is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T. */
+
+/* If FACT = 'E', then AFB is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T of the equilibrated */
+/* matrix A (see the description of A for the form of the */
+/* equilibrated matrix). */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= KD+1. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* S (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The scale factors for A; not accessed if EQUED = 'N'. S is */
+/* an input argument if FACT = 'F'; otherwise, S is an output */
+/* argument. If FACT = 'F' and EQUED = 'Y', each element of S */
+/* must be positive. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */
+/* B is overwritten by diag(S) * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */
+/* the original system of equations. Note that if EQUED = 'Y', */
+/* A and B are modified on exit, and the solution to the */
+/* equilibrated system is inv(diag(S))*X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A after equilibration (if done). If RCOND is less than the */
+/* machine precision (in particular, if RCOND = 0), the matrix */
+/* is singular to working precision. This condition is */
+/* indicated by a return code of INFO > 0. */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: the leading minor of order i of A is */
+/* not positive definite, so the factorization */
+/* could not be completed, and the solution has not */
+/* been computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* N = 6, KD = 2, and UPLO = 'U': */
+
+/* Two-dimensional storage of the symmetric matrix A: */
+
+/* a11 a12 a13 */
+/* a22 a23 a24 */
+/* a33 a34 a35 */
+/* a44 a45 a46 */
+/* a55 a56 */
+/* (aij=conjg(aji)) a66 */
+
+/* Band storage of the upper triangle of A: */
+
+/* * * a13 a24 a35 a46 */
+/* * a12 a23 a34 a45 a56 */
+/* a11 a22 a33 a44 a55 a66 */
+
+/* Similarly, if UPLO = 'L' the format of A is as follows: */
+
+/* a11 a22 a33 a44 a55 a66 */
+/* a21 a32 a43 a54 a65 * */
+/* a31 a42 a53 a64 * * */
+
+/* Array elements marked * are not used by the routine. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ upper = lsame_(uplo, "U");
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rcequ = FALSE_;
+ } else {
+ rcequ = lsame_(equed, "Y");
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ }
+
+/* Test the input parameters. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kd < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*ldab < *kd + 1) {
+ *info = -7;
+ } else if (*ldafb < *kd + 1) {
+ *info = -9;
+ } else if (lsame_(fact, "F") && ! (rcequ || lsame_(
+ equed, "N"))) {
+ *info = -10;
+ } else {
+ if (rcequ) {
+ smin = bignum;
+ smax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = smin, d__2 = s[j];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = smax, d__2 = s[j];
+ smax = max(d__1,d__2);
+/* L10: */
+ }
+ if (smin <= 0.) {
+ *info = -11;
+ } else if (*n > 0) {
+ scond = max(smin,smlnum) / min(smax,bignum);
+ } else {
+ scond = 1.;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -13;
+ } else if (*ldx < max(1,*n)) {
+ *info = -15;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPBSVX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ dpbequ_(uplo, n, kd, &ab[ab_offset], ldab, &s[1], &scond, &amax, &
+ infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ dlaqsb_(uplo, n, kd, &ab[ab_offset], ldab, &s[1], &scond, &amax,
+ equed);
+ rcequ = lsame_(equed, "Y");
+ }
+ }
+
+/* Scale the right-hand side. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = s[i__] * b[i__ + j * b_dim1];
+/* L20: */
+ }
+/* L30: */
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j - *kd;
+ j1 = max(i__2,1);
+ i__2 = j - j1 + 1;
+ dcopy_(&i__2, &ab[*kd + 1 - j + j1 + j * ab_dim1], &c__1, &
+ afb[*kd + 1 - j + j1 + j * afb_dim1], &c__1);
+/* L40: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = j + *kd;
+ j2 = min(i__2,*n);
+ i__2 = j2 - j + 1;
+ dcopy_(&i__2, &ab[j * ab_dim1 + 1], &c__1, &afb[j * afb_dim1
+ + 1], &c__1);
+/* L50: */
+ }
+ }
+
+ dpbtrf_(uplo, n, kd, &afb[afb_offset], ldafb, info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = dlansb_("1", uplo, n, kd, &ab[ab_offset], ldab, &work[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ dpbcon_(uplo, n, kd, &afb[afb_offset], ldafb, &anorm, rcond, &work[1], &
+ iwork[1], info);
+
+/* Compute the solution matrix X. */
+
+ dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ dpbtrs_(uplo, n, kd, nrhs, &afb[afb_offset], ldafb, &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ dpbrfs_(uplo, n, kd, nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb,
+ &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1]
+, &iwork[1], info);
+
+/* Transform the solution matrix X to a solution of the original */
+/* system. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__ + j * x_dim1] = s[i__] * x[i__ + j * x_dim1];
+/* L60: */
+ }
+/* L70: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= scond;
+/* L80: */
+ }
+ }
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < dlamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of DPBSVX */
+
+} /* dpbsvx_ */
diff --git a/SRC/dpbtf2.c b/SRC/dpbtf2.c
new file mode 100644
index 0000000..8937241
--- /dev/null
+++ b/SRC/dpbtf2.c
@@ -0,0 +1,244 @@
+/* dpbtf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b8 = -1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dpbtf2_(char *uplo, integer *n, integer *kd, doublereal *
+ ab, integer *ldab, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer j, kn;
+ doublereal ajj;
+ integer kld;
+ extern /* Subroutine */ int dsyr_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *), dscal_(
+ integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPBTF2 computes the Cholesky factorization of a real symmetric */
+/* positive definite band matrix A. */
+
+/* The factorization has the form */
+/* A = U' * U , if UPLO = 'U', or */
+/* A = L * L', if UPLO = 'L', */
+/* where U is an upper triangular matrix, U' is the transpose of U, and */
+/* L is lower triangular. */
+
+/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, if INFO = 0, the triangular factor U or L from the */
+/* Cholesky factorization A = U'*U or A = L*L' of the band */
+/* matrix A, in the same storage format as A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, the leading minor of order k is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* N = 6, KD = 2, and UPLO = 'U': */
+
+/* On entry: On exit: */
+
+/* * * a13 a24 a35 a46 * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+
+/* Similarly, if UPLO = 'L' the format of A is as follows: */
+
+/* On entry: On exit: */
+
+/* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */
+/* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */
+/* a31 a42 a53 a64 * * l31 l42 l53 l64 * * */
+
+/* Array elements marked * are not used by the routine. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*ldab < *kd + 1) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPBTF2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *ldab - 1;
+ kld = max(i__1,i__2);
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute U(J,J) and test for non-positive-definiteness. */
+
+ ajj = ab[*kd + 1 + j * ab_dim1];
+ if (ajj <= 0.) {
+ goto L30;
+ }
+ ajj = sqrt(ajj);
+ ab[*kd + 1 + j * ab_dim1] = ajj;
+
+/* Compute elements J+1:J+KN of row J and update the */
+/* trailing submatrix within the band. */
+
+/* Computing MIN */
+ i__2 = *kd, i__3 = *n - j;
+ kn = min(i__2,i__3);
+ if (kn > 0) {
+ d__1 = 1. / ajj;
+ dscal_(&kn, &d__1, &ab[*kd + (j + 1) * ab_dim1], &kld);
+ dsyr_("Upper", &kn, &c_b8, &ab[*kd + (j + 1) * ab_dim1], &kld,
+ &ab[*kd + 1 + (j + 1) * ab_dim1], &kld);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute L(J,J) and test for non-positive-definiteness. */
+
+ ajj = ab[j * ab_dim1 + 1];
+ if (ajj <= 0.) {
+ goto L30;
+ }
+ ajj = sqrt(ajj);
+ ab[j * ab_dim1 + 1] = ajj;
+
+/* Compute elements J+1:J+KN of column J and update the */
+/* trailing submatrix within the band. */
+
+/* Computing MIN */
+ i__2 = *kd, i__3 = *n - j;
+ kn = min(i__2,i__3);
+ if (kn > 0) {
+ d__1 = 1. / ajj;
+ dscal_(&kn, &d__1, &ab[j * ab_dim1 + 2], &c__1);
+ dsyr_("Lower", &kn, &c_b8, &ab[j * ab_dim1 + 2], &c__1, &ab[(
+ j + 1) * ab_dim1 + 1], &kld);
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+L30:
+ *info = j;
+ return 0;
+
+/* End of DPBTF2 */
+
+} /* dpbtf2_ */
diff --git a/SRC/dpbtrf.c b/SRC/dpbtrf.c
new file mode 100644
index 0000000..36a8a25
--- /dev/null
+++ b/SRC/dpbtrf.c
@@ -0,0 +1,471 @@
+/* dpbtrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b18 = 1.;
+static doublereal c_b21 = -1.;
+static integer c__33 = 33;
+
+/* Subroutine */ int dpbtrf_(char *uplo, integer *n, integer *kd, doublereal *
+ ab, integer *ldab, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, i2, i3, ib, nb, ii, jj;
+ doublereal work[1056] /* was [33][32] */;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), dsyrk_(
+ char *, char *, integer *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *),
+ dpbtf2_(char *, integer *, integer *, doublereal *, integer *,
+ integer *), dpotf2_(char *, integer *, doublereal *,
+ integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPBTRF computes the Cholesky factorization of a real symmetric */
+/* positive definite band matrix A. */
+
+/* The factorization has the form */
+/* A = U**T * U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, if INFO = 0, the triangular factor U or L from the */
+/* Cholesky factorization A = U**T*U or A = L*L**T of the band */
+/* matrix A, in the same storage format as A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* N = 6, KD = 2, and UPLO = 'U': */
+
+/* On entry: On exit: */
+
+/* * * a13 a24 a35 a46 * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+
+/* Similarly, if UPLO = 'L' the format of A is as follows: */
+
+/* On entry: On exit: */
+
+/* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */
+/* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */
+/* a31 a42 a53 a64 * * l31 l42 l53 l64 * * */
+
+/* Array elements marked * are not used by the routine. */
+
+/* Contributed by */
+/* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*ldab < *kd + 1) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPBTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment */
+
+ nb = ilaenv_(&c__1, "DPBTRF", uplo, n, kd, &c_n1, &c_n1);
+
+/* The block size must not exceed the semi-bandwidth KD, and must not */
+/* exceed the limit set by the size of the local array WORK. */
+
+ nb = min(nb,32);
+
+ if (nb <= 1 || nb > *kd) {
+
+/* Use unblocked code */
+
+ dpbtf2_(uplo, n, kd, &ab[ab_offset], ldab, info);
+ } else {
+
+/* Use blocked code */
+
+ if (lsame_(uplo, "U")) {
+
+/* Compute the Cholesky factorization of a symmetric band */
+/* matrix, given the upper triangle of the matrix in band */
+/* storage. */
+
+/* Zero the upper triangle of the work array. */
+
+ i__1 = nb;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__ + j * 33 - 34] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Process the band matrix one diagonal block at a time. */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - i__ + 1;
+ ib = min(i__3,i__4);
+
+/* Factorize the diagonal block */
+
+ i__3 = *ldab - 1;
+ dpotf2_(uplo, &ib, &ab[*kd + 1 + i__ * ab_dim1], &i__3, &ii);
+ if (ii != 0) {
+ *info = i__ + ii - 1;
+ goto L150;
+ }
+ if (i__ + ib <= *n) {
+
+/* Update the relevant part of the trailing submatrix. */
+/* If A11 denotes the diagonal block which has just been */
+/* factorized, then we need to update the remaining */
+/* blocks in the diagram: */
+
+/* A11 A12 A13 */
+/* A22 A23 */
+/* A33 */
+
+/* The numbers of rows and columns in the partitioning */
+/* are IB, I2, I3 respectively. The blocks A12, A22 and */
+/* A23 are empty if IB = KD. The upper triangle of A13 */
+/* lies outside the band. */
+
+/* Computing MIN */
+ i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
+ i2 = min(i__3,i__4);
+/* Computing MIN */
+ i__3 = ib, i__4 = *n - i__ - *kd + 1;
+ i3 = min(i__3,i__4);
+
+ if (i2 > 0) {
+
+/* Update A12 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ dtrsm_("Left", "Upper", "Transpose", "Non-unit", &ib,
+ &i2, &c_b18, &ab[*kd + 1 + i__ * ab_dim1], &
+ i__3, &ab[*kd + 1 - ib + (i__ + ib) * ab_dim1]
+, &i__4);
+
+/* Update A22 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ dsyrk_("Upper", "Transpose", &i2, &ib, &c_b21, &ab[*
+ kd + 1 - ib + (i__ + ib) * ab_dim1], &i__3, &
+ c_b18, &ab[*kd + 1 + (i__ + ib) * ab_dim1], &
+ i__4);
+ }
+
+ if (i3 > 0) {
+
+/* Copy the lower triangle of A13 into the work array. */
+
+ i__3 = i3;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = ib;
+ for (ii = jj; ii <= i__4; ++ii) {
+ work[ii + jj * 33 - 34] = ab[ii - jj + 1 + (
+ jj + i__ + *kd - 1) * ab_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Update A13 (in the work array). */
+
+ i__3 = *ldab - 1;
+ dtrsm_("Left", "Upper", "Transpose", "Non-unit", &ib,
+ &i3, &c_b18, &ab[*kd + 1 + i__ * ab_dim1], &
+ i__3, work, &c__33);
+
+/* Update A23 */
+
+ if (i2 > 0) {
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ dgemm_("Transpose", "No Transpose", &i2, &i3, &ib,
+ &c_b21, &ab[*kd + 1 - ib + (i__ + ib) *
+ ab_dim1], &i__3, work, &c__33, &c_b18, &
+ ab[ib + 1 + (i__ + *kd) * ab_dim1], &i__4);
+ }
+
+/* Update A33 */
+
+ i__3 = *ldab - 1;
+ dsyrk_("Upper", "Transpose", &i3, &ib, &c_b21, work, &
+ c__33, &c_b18, &ab[*kd + 1 + (i__ + *kd) *
+ ab_dim1], &i__3);
+
+/* Copy the lower triangle of A13 back into place. */
+
+ i__3 = i3;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = ib;
+ for (ii = jj; ii <= i__4; ++ii) {
+ ab[ii - jj + 1 + (jj + i__ + *kd - 1) *
+ ab_dim1] = work[ii + jj * 33 - 34];
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+ }
+/* L70: */
+ }
+ } else {
+
+/* Compute the Cholesky factorization of a symmetric band */
+/* matrix, given the lower triangle of the matrix in band */
+/* storage. */
+
+/* Zero the lower triangle of the work array. */
+
+ i__2 = nb;
+ for (j = 1; j <= i__2; ++j) {
+ i__1 = nb;
+ for (i__ = j + 1; i__ <= i__1; ++i__) {
+ work[i__ + j * 33 - 34] = 0.;
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Process the band matrix one diagonal block at a time. */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - i__ + 1;
+ ib = min(i__3,i__4);
+
+/* Factorize the diagonal block */
+
+ i__3 = *ldab - 1;
+ dpotf2_(uplo, &ib, &ab[i__ * ab_dim1 + 1], &i__3, &ii);
+ if (ii != 0) {
+ *info = i__ + ii - 1;
+ goto L150;
+ }
+ if (i__ + ib <= *n) {
+
+/* Update the relevant part of the trailing submatrix. */
+/* If A11 denotes the diagonal block which has just been */
+/* factorized, then we need to update the remaining */
+/* blocks in the diagram: */
+
+/* A11 */
+/* A21 A22 */
+/* A31 A32 A33 */
+
+/* The numbers of rows and columns in the partitioning */
+/* are IB, I2, I3 respectively. The blocks A21, A22 and */
+/* A32 are empty if IB = KD. The lower triangle of A31 */
+/* lies outside the band. */
+
+/* Computing MIN */
+ i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
+ i2 = min(i__3,i__4);
+/* Computing MIN */
+ i__3 = ib, i__4 = *n - i__ - *kd + 1;
+ i3 = min(i__3,i__4);
+
+ if (i2 > 0) {
+
+/* Update A21 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i2,
+ &ib, &c_b18, &ab[i__ * ab_dim1 + 1], &i__3, &
+ ab[ib + 1 + i__ * ab_dim1], &i__4);
+
+/* Update A22 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ dsyrk_("Lower", "No Transpose", &i2, &ib, &c_b21, &ab[
+ ib + 1 + i__ * ab_dim1], &i__3, &c_b18, &ab[(
+ i__ + ib) * ab_dim1 + 1], &i__4);
+ }
+
+ if (i3 > 0) {
+
+/* Copy the upper triangle of A31 into the work array. */
+
+ i__3 = ib;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = min(jj,i3);
+ for (ii = 1; ii <= i__4; ++ii) {
+ work[ii + jj * 33 - 34] = ab[*kd + 1 - jj +
+ ii + (jj + i__ - 1) * ab_dim1];
+/* L100: */
+ }
+/* L110: */
+ }
+
+/* Update A31 (in the work array). */
+
+ i__3 = *ldab - 1;
+ dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i3,
+ &ib, &c_b18, &ab[i__ * ab_dim1 + 1], &i__3,
+ work, &c__33);
+
+/* Update A32 */
+
+ if (i2 > 0) {
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ dgemm_("No transpose", "Transpose", &i3, &i2, &ib,
+ &c_b21, work, &c__33, &ab[ib + 1 + i__ *
+ ab_dim1], &i__3, &c_b18, &ab[*kd + 1 - ib
+ + (i__ + ib) * ab_dim1], &i__4);
+ }
+
+/* Update A33 */
+
+ i__3 = *ldab - 1;
+ dsyrk_("Lower", "No Transpose", &i3, &ib, &c_b21,
+ work, &c__33, &c_b18, &ab[(i__ + *kd) *
+ ab_dim1 + 1], &i__3);
+
+/* Copy the upper triangle of A31 back into place. */
+
+ i__3 = ib;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = min(jj,i3);
+ for (ii = 1; ii <= i__4; ++ii) {
+ ab[*kd + 1 - jj + ii + (jj + i__ - 1) *
+ ab_dim1] = work[ii + jj * 33 - 34];
+/* L120: */
+ }
+/* L130: */
+ }
+ }
+ }
+/* L140: */
+ }
+ }
+ }
+ return 0;
+
+L150:
+ return 0;
+
+/* End of DPBTRF */
+
+} /* dpbtrf_ */
diff --git a/SRC/dpbtrs.c b/SRC/dpbtrs.c
new file mode 100644
index 0000000..b850b9f
--- /dev/null
+++ b/SRC/dpbtrs.c
@@ -0,0 +1,184 @@
+/* dpbtrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dpbtrs_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, doublereal *ab, integer *ldab, doublereal *b, integer *ldb,
+ integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ integer j;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dtbsv_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPBTRS solves a system of linear equations A*X = B with a symmetric */
+/* positive definite band matrix A using the Cholesky factorization */
+/* A = U**T*U or A = L*L**T computed by DPBTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular factor stored in AB; */
+/* = 'L': Lower triangular factor stored in AB. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T of the band matrix A, stored in the */
+/* first KD+1 rows of the array. The j-th column of U or L is */
+/* stored in the j-th column of the array AB as follows: */
+/* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldab < *kd + 1) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPBTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B where A = U'*U. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve U'*X = B, overwriting B with X. */
+
+ dtbsv_("Upper", "Transpose", "Non-unit", n, kd, &ab[ab_offset],
+ ldab, &b[j * b_dim1 + 1], &c__1);
+
+/* Solve U*X = B, overwriting B with X. */
+
+ dtbsv_("Upper", "No transpose", "Non-unit", n, kd, &ab[ab_offset],
+ ldab, &b[j * b_dim1 + 1], &c__1);
+/* L10: */
+ }
+ } else {
+
+/* Solve A*X = B where A = L*L'. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve L*X = B, overwriting B with X. */
+
+ dtbsv_("Lower", "No transpose", "Non-unit", n, kd, &ab[ab_offset],
+ ldab, &b[j * b_dim1 + 1], &c__1);
+
+/* Solve L'*X = B, overwriting B with X. */
+
+ dtbsv_("Lower", "Transpose", "Non-unit", n, kd, &ab[ab_offset],
+ ldab, &b[j * b_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of DPBTRS */
+
+} /* dpbtrs_ */
diff --git a/SRC/dpftrf.c b/SRC/dpftrf.c
new file mode 100644
index 0000000..d7a5300
--- /dev/null
+++ b/SRC/dpftrf.c
@@ -0,0 +1,452 @@
+/* dpftrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b12 = 1.;
+static doublereal c_b15 = -1.;
+
+/* Subroutine */ int dpftrf_(char *transr, char *uplo, integer *n, doublereal
+ *a, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer k, n1, n2;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), dsyrk_(
+ char *, char *, integer *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ logical nisodd;
+ extern /* Subroutine */ int dpotrf_(char *, integer *, doublereal *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPFTRF computes the Cholesky factorization of a real symmetric */
+/* positive definite matrix A. */
+
+/* The factorization has the form */
+/* A = U**T * U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* This is the block version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': The Normal TRANSR of RFP A is stored; */
+/* = 'T': The Transpose TRANSR of RFP A is stored. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': Upper triangle of RFP A is stored; */
+/* = 'L': Lower triangle of RFP A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ); */
+/* On entry, the symmetric matrix A in RFP format. RFP format is */
+/* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' */
+/* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */
+/* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is */
+/* the transpose of RFP A as defined when */
+/* TRANSR = 'N'. The contents of RFP A are defined by UPLO as */
+/* follows: If UPLO = 'U' the RFP A contains the NT elements of */
+/* upper packed A. If UPLO = 'L' the RFP A contains the elements */
+/* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = */
+/* 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N */
+/* is odd. See the Note below for more details. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization RFP A = U**T*U or RFP A = L*L**T. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* Notes */
+/* ===== */
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* even. We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* the transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* the transpose of the last three columns of AP lower. */
+/* This covers the case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 03 04 05 33 43 53 */
+/* 13 14 15 00 44 54 */
+/* 23 24 25 10 11 55 */
+/* 33 34 35 20 21 22 */
+/* 00 44 45 30 31 32 */
+/* 01 11 55 40 41 42 */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* odd. We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* the transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* the transpose of the last two columns of AP lower. */
+/* This covers the case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 02 03 04 00 33 43 */
+/* 12 13 14 10 11 44 */
+/* 22 23 24 20 21 22 */
+/* 00 33 34 30 31 32 */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+/* RFP A RFP A */
+
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "T")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPFTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* If N is odd, set NISODD = .TRUE. */
+/* If N is even, set K = N/2 and NISODD = .FALSE. */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ } else {
+ nisodd = TRUE_;
+ }
+
+/* Set N1 and N2 depending on LOWER */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* start execution: there are eight cases */
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */
+/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */
+/* T1 -> a(0), T2 -> a(n), S -> a(n1) */
+
+ dpotrf_("L", &n1, a, n, info);
+ if (*info > 0) {
+ return 0;
+ }
+ dtrsm_("R", "L", "T", "N", &n2, &n1, &c_b12, a, n, &a[n1], n);
+ dsyrk_("U", "N", &n2, &n1, &c_b15, &a[n1], n, &c_b12, &a[*n],
+ n);
+ dpotrf_("U", &n2, &a[*n], n, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */
+/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */
+/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */
+
+ dpotrf_("L", &n1, &a[n2], n, info);
+ if (*info > 0) {
+ return 0;
+ }
+ dtrsm_("L", "L", "N", "N", &n1, &n2, &c_b12, &a[n2], n, a, n);
+ dsyrk_("U", "T", &n2, &n1, &c_b15, a, n, &c_b12, &a[n1], n);
+ dpotrf_("U", &n2, &a[n1], n, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is odd */
+/* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */
+/* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 */
+
+ dpotrf_("U", &n1, a, &n1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ dtrsm_("L", "U", "T", "N", &n1, &n2, &c_b12, a, &n1, &a[n1 *
+ n1], &n1);
+ dsyrk_("L", "T", &n2, &n1, &c_b15, &a[n1 * n1], &n1, &c_b12, &
+ a[1], &n1);
+ dpotrf_("L", &n2, &a[1], &n1, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is odd */
+/* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */
+/* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 */
+
+ dpotrf_("U", &n1, &a[n2 * n2], &n2, info);
+ if (*info > 0) {
+ return 0;
+ }
+ dtrsm_("R", "U", "N", "N", &n2, &n1, &c_b12, &a[n2 * n2], &n2,
+ a, &n2);
+ dsyrk_("L", "N", &n2, &n1, &c_b15, a, &n2, &c_b12, &a[n1 * n2]
+, &n2);
+ dpotrf_("L", &n2, &a[n1 * n2], &n2, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
+/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */
+
+ i__1 = *n + 1;
+ dpotrf_("L", &k, &a[1], &i__1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ dtrsm_("R", "L", "T", "N", &k, &k, &c_b12, &a[1], &i__1, &a[k
+ + 1], &i__2);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ dsyrk_("U", "N", &k, &k, &c_b15, &a[k + 1], &i__1, &c_b12, a,
+ &i__2);
+ i__1 = *n + 1;
+ dpotrf_("U", &k, a, &i__1, info);
+ if (*info > 0) {
+ *info += k;
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
+/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */
+
+ i__1 = *n + 1;
+ dpotrf_("L", &k, &a[k + 1], &i__1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ dtrsm_("L", "L", "N", "N", &k, &k, &c_b12, &a[k + 1], &i__1,
+ a, &i__2);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ dsyrk_("U", "T", &k, &k, &c_b15, a, &i__1, &c_b12, &a[k], &
+ i__2);
+ i__1 = *n + 1;
+ dpotrf_("U", &k, &a[k], &i__1, info);
+ if (*info > 0) {
+ *info += k;
+ }
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */
+/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */
+
+ dpotrf_("U", &k, &a[k], &k, info);
+ if (*info > 0) {
+ return 0;
+ }
+ dtrsm_("L", "U", "T", "N", &k, &k, &c_b12, &a[k], &n1, &a[k *
+ (k + 1)], &k);
+ dsyrk_("L", "T", &k, &k, &c_b15, &a[k * (k + 1)], &k, &c_b12,
+ a, &k);
+ dpotrf_("L", &k, a, &k, info);
+ if (*info > 0) {
+ *info += k;
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */
+/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */
+
+ dpotrf_("U", &k, &a[k * (k + 1)], &k, info);
+ if (*info > 0) {
+ return 0;
+ }
+ dtrsm_("R", "U", "N", "N", &k, &k, &c_b12, &a[k * (k + 1)], &
+ k, a, &k);
+ dsyrk_("L", "N", &k, &k, &c_b15, a, &k, &c_b12, &a[k * k], &k);
+ dpotrf_("L", &k, &a[k * k], &k, info);
+ if (*info > 0) {
+ *info += k;
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of DPFTRF */
+
+} /* dpftrf_ */
diff --git a/SRC/dpftri.c b/SRC/dpftri.c
new file mode 100644
index 0000000..c7331f6
--- /dev/null
+++ b/SRC/dpftri.c
@@ -0,0 +1,403 @@
+/* dpftri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b11 = 1.;
+
+/* Subroutine */ int dpftri_(char *transr, char *uplo, integer *n, doublereal
+ *a, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer k, n1, n2;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical lower;
+ extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *), xerbla_(char *, integer *);
+ logical nisodd;
+ extern /* Subroutine */ int dlauum_(char *, integer *, doublereal *,
+ integer *, integer *), dtftri_(char *, char *, char *,
+ integer *, doublereal *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPFTRI computes the inverse of a (real) symmetric positive definite */
+/* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T */
+/* computed by DPFTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': The Normal TRANSR of RFP A is stored; */
+/* = 'T': The Transpose TRANSR of RFP A is stored. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ) */
+/* On entry, the symmetric matrix A in RFP format. RFP format is */
+/* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' */
+/* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */
+/* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is */
+/* the transpose of RFP A as defined when */
+/* TRANSR = 'N'. The contents of RFP A are defined by UPLO as */
+/* follows: If UPLO = 'U' the RFP A contains the nt elements of */
+/* upper packed A. If UPLO = 'L' the RFP A contains the elements */
+/* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = */
+/* 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N */
+/* is odd. See the Note below for more details. */
+
+/* On exit, the symmetric inverse of the original matrix, in the */
+/* same storage format. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the (i,i) element of the factor U or L is */
+/* zero, and the inverse could not be computed. */
+
+/* Notes */
+/* ===== */
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* even. We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* the transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* the transpose of the last three columns of AP lower. */
+/* This covers the case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 03 04 05 33 43 53 */
+/* 13 14 15 00 44 54 */
+/* 23 24 25 10 11 55 */
+/* 33 34 35 20 21 22 */
+/* 00 44 45 30 31 32 */
+/* 01 11 55 40 41 42 */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* odd. We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* the transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* the transpose of the last two columns of AP lower. */
+/* This covers the case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 02 03 04 00 33 43 */
+/* 12 13 14 10 11 44 */
+/* 22 23 24 20 21 22 */
+/* 00 33 34 30 31 32 */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+/* RFP A RFP A */
+
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "T")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPFTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Invert the triangular Cholesky factor U or L. */
+
+ dtftri_(transr, uplo, "N", n, a, info);
+ if (*info > 0) {
+ return 0;
+ }
+
+/* If N is odd, set NISODD = .TRUE. */
+/* If N is even, set K = N/2 and NISODD = .FALSE. */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ } else {
+ nisodd = TRUE_;
+ }
+
+/* Set N1 and N2 depending on LOWER */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* Start execution of triangular matrix multiply: inv(U)*inv(U)^C or */
+/* inv(L)^C*inv(L). There are eight cases. */
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:N1-1) ) */
+/* T1 -> a(0,0), T2 -> a(0,1), S -> a(N1,0) */
+/* T1 -> a(0), T2 -> a(n), S -> a(N1) */
+
+ dlauum_("L", &n1, a, n, info);
+ dsyrk_("L", "T", &n1, &n2, &c_b11, &a[n1], n, &c_b11, a, n);
+ dtrmm_("L", "U", "N", "N", &n2, &n1, &c_b11, &a[*n], n, &a[n1]
+, n);
+ dlauum_("U", &n2, &a[*n], n, info);
+
+ } else {
+
+/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:N2-1) */
+/* T1 -> a(N1+1,0), T2 -> a(N1,0), S -> a(0,0) */
+/* T1 -> a(N2), T2 -> a(N1), S -> a(0) */
+
+ dlauum_("L", &n1, &a[n2], n, info);
+ dsyrk_("L", "N", &n1, &n2, &c_b11, a, n, &c_b11, &a[n2], n);
+ dtrmm_("R", "U", "T", "N", &n1, &n2, &c_b11, &a[n1], n, a, n);
+ dlauum_("U", &n2, &a[n1], n, info);
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE, and N is odd */
+/* T1 -> a(0), T2 -> a(1), S -> a(0+N1*N1) */
+
+ dlauum_("U", &n1, a, &n1, info);
+ dsyrk_("U", "N", &n1, &n2, &c_b11, &a[n1 * n1], &n1, &c_b11,
+ a, &n1);
+ dtrmm_("R", "L", "N", "N", &n1, &n2, &c_b11, &a[1], &n1, &a[
+ n1 * n1], &n1);
+ dlauum_("L", &n2, &a[1], &n1, info);
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE, and N is odd */
+/* T1 -> a(0+N2*N2), T2 -> a(0+N1*N2), S -> a(0) */
+
+ dlauum_("U", &n1, &a[n2 * n2], &n2, info);
+ dsyrk_("U", "T", &n1, &n2, &c_b11, a, &n2, &c_b11, &a[n2 * n2]
+, &n2);
+ dtrmm_("L", "L", "T", "N", &n2, &n1, &c_b11, &a[n1 * n2], &n2,
+ a, &n2);
+ dlauum_("L", &n2, &a[n1 * n2], &n2, info);
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
+/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */
+
+ i__1 = *n + 1;
+ dlauum_("L", &k, &a[1], &i__1, info);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ dsyrk_("L", "T", &k, &k, &c_b11, &a[k + 1], &i__1, &c_b11, &a[
+ 1], &i__2);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ dtrmm_("L", "U", "N", "N", &k, &k, &c_b11, a, &i__1, &a[k + 1]
+, &i__2);
+ i__1 = *n + 1;
+ dlauum_("U", &k, a, &i__1, info);
+
+ } else {
+
+/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
+/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */
+
+ i__1 = *n + 1;
+ dlauum_("L", &k, &a[k + 1], &i__1, info);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ dsyrk_("L", "N", &k, &k, &c_b11, a, &i__1, &c_b11, &a[k + 1],
+ &i__2);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ dtrmm_("R", "U", "T", "N", &k, &k, &c_b11, &a[k], &i__1, a, &
+ i__2);
+ i__1 = *n + 1;
+ dlauum_("U", &k, &a[k], &i__1, info);
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE, and N is even (see paper) */
+/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1), */
+/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */
+
+ dlauum_("U", &k, &a[k], &k, info);
+ dsyrk_("U", "N", &k, &k, &c_b11, &a[k * (k + 1)], &k, &c_b11,
+ &a[k], &k);
+ dtrmm_("R", "L", "N", "N", &k, &k, &c_b11, a, &k, &a[k * (k +
+ 1)], &k);
+ dlauum_("L", &k, a, &k, info);
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE, and N is even (see paper) */
+/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0), */
+/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */
+
+ dlauum_("U", &k, &a[k * (k + 1)], &k, info);
+ dsyrk_("U", "T", &k, &k, &c_b11, a, &k, &c_b11, &a[k * (k + 1)
+ ], &k);
+ dtrmm_("L", "L", "T", "N", &k, &k, &c_b11, &a[k * k], &k, a, &
+ k);
+ dlauum_("L", &k, &a[k * k], &k, info);
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of DPFTRI */
+
+} /* dpftri_ */
diff --git a/SRC/dpftrs.c b/SRC/dpftrs.c
new file mode 100644
index 0000000..c0da3c5
--- /dev/null
+++ b/SRC/dpftrs.c
@@ -0,0 +1,240 @@
+/* dpftrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b10 = 1.;
+
+/* Subroutine */ int dpftrs_(char *transr, char *uplo, integer *n, integer *
+ nrhs, doublereal *a, doublereal *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dtfsm_(char *, char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPFTRS solves a system of linear equations A*X = B with a symmetric */
+/* positive definite matrix A using the Cholesky factorization */
+/* A = U**T*U or A = L*L**T computed by DPFTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': The Normal TRANSR of RFP A is stored; */
+/* = 'T': The Transpose TRANSR of RFP A is stored. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': Upper triangle of RFP A is stored; */
+/* = 'L': Lower triangle of RFP A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ). */
+/* The triangular factor U or L from the Cholesky factorization */
+/* of RFP A = U**T*U or RFP A = L*L**T, as computed by DPFTRF. */
+/* See note below for more details about RFP A. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Notes */
+/* ===== */
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* even. We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* the transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* the transpose of the last three columns of AP lower. */
+/* This covers the case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 03 04 05 33 43 53 */
+/* 13 14 15 00 44 54 */
+/* 23 24 25 10 11 55 */
+/* 33 34 35 20 21 22 */
+/* 00 44 45 30 31 32 */
+/* 01 11 55 40 41 42 */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* odd. We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* the transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* the transpose of the last two columns of AP lower. */
+/* This covers the case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 02 03 04 00 33 43 */
+/* 12 13 14 10 11 44 */
+/* 22 23 24 20 21 22 */
+/* 00 33 34 30 31 32 */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+/* RFP A RFP A */
+
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "T")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPFTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+/* start execution: there are two triangular solves */
+
+ if (lower) {
+ dtfsm_(transr, "L", uplo, "N", "N", n, nrhs, &c_b10, a, &b[b_offset],
+ ldb);
+ dtfsm_(transr, "L", uplo, "T", "N", n, nrhs, &c_b10, a, &b[b_offset],
+ ldb);
+ } else {
+ dtfsm_(transr, "L", uplo, "T", "N", n, nrhs, &c_b10, a, &b[b_offset],
+ ldb);
+ dtfsm_(transr, "L", uplo, "N", "N", n, nrhs, &c_b10, a, &b[b_offset],
+ ldb);
+ }
+
+ return 0;
+
+/* End of DPFTRS */
+
+} /* dpftrs_ */
diff --git a/SRC/dpocon.c b/SRC/dpocon.c
new file mode 100644
index 0000000..3613498
--- /dev/null
+++ b/SRC/dpocon.c
@@ -0,0 +1,220 @@
+/* dpocon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dpocon_(char *uplo, integer *n, doublereal *a, integer *
+ lda, doublereal *anorm, doublereal *rcond, doublereal *work, integer *
+ iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ doublereal d__1;
+
+ /* Local variables */
+ integer ix, kase;
+ doublereal scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int drscl_(integer *, doublereal *, doublereal *,
+ integer *);
+ logical upper;
+ extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal scalel;
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal scaleu;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int dlatrs_(char *, char *, char *, char *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *);
+ char normin[1];
+ doublereal smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPOCON estimates the reciprocal of the condition number (in the */
+/* 1-norm) of a real symmetric positive definite matrix using the */
+/* Cholesky factorization A = U**T*U or A = L*L**T computed by DPOTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by DPOTRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* ANORM (input) DOUBLE PRECISION */
+/* The 1-norm (or infinity-norm) of the symmetric matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*anorm < 0.) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPOCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.;
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ } else if (*anorm == 0.) {
+ return 0;
+ }
+
+ smlnum = dlamch_("Safe minimum");
+
+/* Estimate the 1-norm of inv(A). */
+
+ kase = 0;
+ *(unsigned char *)normin = 'N';
+L10:
+ dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (upper) {
+
+/* Multiply by inv(U'). */
+
+ dlatrs_("Upper", "Transpose", "Non-unit", normin, n, &a[a_offset],
+ lda, &work[1], &scalel, &work[(*n << 1) + 1], info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(U). */
+
+ dlatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[
+ a_offset], lda, &work[1], &scaleu, &work[(*n << 1) + 1],
+ info);
+ } else {
+
+/* Multiply by inv(L). */
+
+ dlatrs_("Lower", "No transpose", "Non-unit", normin, n, &a[
+ a_offset], lda, &work[1], &scalel, &work[(*n << 1) + 1],
+ info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(L'). */
+
+ dlatrs_("Lower", "Transpose", "Non-unit", normin, n, &a[a_offset],
+ lda, &work[1], &scaleu, &work[(*n << 1) + 1], info);
+ }
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ scale = scalel * scaleu;
+ if (scale != 1.) {
+ ix = idamax_(n, &work[1], &c__1);
+ if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.)
+ {
+ goto L20;
+ }
+ drscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / ainvnm / *anorm;
+ }
+
+L20:
+ return 0;
+
+/* End of DPOCON */
+
+} /* dpocon_ */
diff --git a/SRC/dpoequ.c b/SRC/dpoequ.c
new file mode 100644
index 0000000..bde3798
--- /dev/null
+++ b/SRC/dpoequ.c
@@ -0,0 +1,174 @@
+/* dpoequ.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dpoequ_(integer *n, doublereal *a, integer *lda,
+ doublereal *s, doublereal *scond, doublereal *amax, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal smin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPOEQU computes row and column scalings intended to equilibrate a */
+/* symmetric positive definite matrix A and reduce its condition number */
+/* (with respect to the two-norm). S contains the scale factors, */
+/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
+/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
+/* choice of S puts the condition number of B within a factor N of the */
+/* smallest possible condition number over all possible diagonal */
+/* scalings. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The N-by-N symmetric positive definite matrix whose scaling */
+/* factors are to be computed. Only the diagonal elements of A */
+/* are referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* S (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, S contains the scale factors for A. */
+
+/* SCOND (output) DOUBLE PRECISION */
+/* If INFO = 0, S contains the ratio of the smallest S(i) to */
+/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
+/* large nor too small, it is not worth scaling by S. */
+
+/* AMAX (output) DOUBLE PRECISION */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*lda < max(1,*n)) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPOEQU", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *scond = 1.;
+ *amax = 0.;
+ return 0;
+ }
+
+/* Find the minimum and maximum diagonal elements. */
+
+ s[1] = a[a_dim1 + 1];
+ smin = s[1];
+ *amax = s[1];
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ s[i__] = a[i__ + i__ * a_dim1];
+/* Computing MIN */
+ d__1 = smin, d__2 = s[i__];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = *amax, d__2 = s[i__];
+ *amax = max(d__1,d__2);
+/* L10: */
+ }
+
+ if (smin <= 0.) {
+
+/* Find the first non-positive diagonal element and return. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] <= 0.) {
+ *info = i__;
+ return 0;
+ }
+/* L20: */
+ }
+ } else {
+
+/* Set the scale factors to the reciprocals */
+/* of the diagonal elements. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s[i__] = 1. / sqrt(s[i__]);
+/* L30: */
+ }
+
+/* Compute SCOND = min(S(I)) / max(S(I)) */
+
+ *scond = sqrt(smin) / sqrt(*amax);
+ }
+ return 0;
+
+/* End of DPOEQU */
+
+} /* dpoequ_ */
diff --git a/SRC/dpoequb.c b/SRC/dpoequb.c
new file mode 100644
index 0000000..a963fc3
--- /dev/null
+++ b/SRC/dpoequb.c
@@ -0,0 +1,188 @@
+/* dpoequb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dpoequb_(integer *n, doublereal *a, integer *lda,
+ doublereal *s, doublereal *scond, doublereal *amax, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double log(doublereal), pow_di(doublereal *, integer *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal tmp, base, smin;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPOEQU computes row and column scalings intended to equilibrate a */
+/* symmetric positive definite matrix A and reduce its condition number */
+/* (with respect to the two-norm). S contains the scale factors, */
+/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
+/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
+/* choice of S puts the condition number of B within a factor N of the */
+/* smallest possible condition number over all possible diagonal */
+/* scalings. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The N-by-N symmetric positive definite matrix whose scaling */
+/* factors are to be computed. Only the diagonal elements of A */
+/* are referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* S (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, S contains the scale factors for A. */
+
+/* SCOND (output) DOUBLE PRECISION */
+/* If INFO = 0, S contains the ratio of the smallest S(i) to */
+/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
+/* large nor too small, it is not worth scaling by S. */
+
+/* AMAX (output) DOUBLE PRECISION */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+/* Positive definite only performs 1 pass of equilibration. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*lda < max(1,*n)) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPOEQUB", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ *scond = 1.;
+ *amax = 0.;
+ return 0;
+ }
+ base = dlamch_("B");
+ tmp = -.5 / log(base);
+
+/* Find the minimum and maximum diagonal elements. */
+
+ s[1] = a[a_dim1 + 1];
+ smin = s[1];
+ *amax = s[1];
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ s[i__] = a[i__ + i__ * a_dim1];
+/* Computing MIN */
+ d__1 = smin, d__2 = s[i__];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = *amax, d__2 = s[i__];
+ *amax = max(d__1,d__2);
+/* L10: */
+ }
+
+ if (smin <= 0.) {
+
+/* Find the first non-positive diagonal element and return. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] <= 0.) {
+ *info = i__;
+ return 0;
+ }
+/* L20: */
+ }
+ } else {
+
+/* Set the scale factors to the reciprocals */
+/* of the diagonal elements. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = (integer) (tmp * log(s[i__]));
+ s[i__] = pow_di(&base, &i__2);
+/* L30: */
+ }
+
+/* Compute SCOND = min(S(I)) / max(S(I)). */
+
+ *scond = sqrt(smin) / sqrt(*amax);
+ }
+
+ return 0;
+
+/* End of DPOEQUB */
+
+} /* dpoequb_ */
diff --git a/SRC/dporfs.c b/SRC/dporfs.c
new file mode 100644
index 0000000..842f1a2
--- /dev/null
+++ b/SRC/dporfs.c
@@ -0,0 +1,422 @@
+/* dporfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b12 = -1.;
+static doublereal c_b14 = 1.;
+
+/* Subroutine */ int dporfs_(char *uplo, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *af, integer *ldaf,
+ doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
+ ferr, doublereal *berr, doublereal *work, integer *iwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal s, xk;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *);
+ integer count;
+ logical upper;
+ extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *), dlacn2_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *), dpotrs_(
+ char *, integer *, integer *, doublereal *, integer *, doublereal
+ *, integer *, integer *);
+ doublereal lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPORFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric positive definite, */
+/* and provides error bounds and backward error estimates for the */
+/* solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular part */
+/* of the matrix A, and the strictly lower triangular part of A */
+/* is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of A contains the lower triangular part of */
+/* the matrix A, and the strictly upper triangular part of A is */
+/* not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by DPOTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by DPOTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPORFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+ dsymv_(uplo, n, &c_b12, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1,
+ &c_b14, &work[*n + 1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ work[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * xk;
+ s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 = x[
+ i__ + j * x_dim1], abs(d__2));
+/* L40: */
+ }
+ work[k] = work[k] + (d__1 = a[k + k * a_dim1], abs(d__1)) *
+ xk + s;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+ work[k] += (d__1 = a[k + k * a_dim1], abs(d__1)) * xk;
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ work[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * xk;
+ s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 = x[
+ i__ + j * x_dim1], abs(d__2));
+/* L60: */
+ }
+ work[k] += s;
+/* L70: */
+ }
+ }
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[
+ i__];
+ s = max(d__2,d__3);
+ } else {
+/* Computing MAX */
+ d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1)
+ / (work[i__] + safe1);
+ s = max(d__2,d__3);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ dpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[*n + 1], n,
+ info);
+ daxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
+ ;
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use DLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+ kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ dpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[*n + 1],
+ n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L120: */
+ }
+ dpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[*n + 1],
+ n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1));
+ lstres = max(d__2,d__3);
+/* L130: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of DPORFS */
+
+} /* dporfs_ */
diff --git a/SRC/dporfsx.c b/SRC/dporfsx.c
new file mode 100644
index 0000000..c0c23cb
--- /dev/null
+++ b/SRC/dporfsx.c
@@ -0,0 +1,622 @@
+/* dporfsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int dporfsx_(char *uplo, char *equed, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
+ doublereal *s, doublereal *b, integer *ldb, doublereal *x, integer *
+ ldx, doublereal *rcond, doublereal *berr, integer *n_err_bnds__,
+ doublereal *err_bnds_norm__, doublereal *err_bnds_comp__, integer *
+ nparams, doublereal *params, doublereal *work, integer *iwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal illrcond_thresh__, unstable_thresh__, err_lbnd__;
+ integer ref_type__, j;
+ doublereal rcond_tmp__;
+ integer prec_type__;
+ extern doublereal dla_porcond__(char *, integer *, doublereal *, integer *
+ , doublereal *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, ftnlen);
+ doublereal cwise_wrong__;
+ extern /* Subroutine */ int dla_porfsx_extended__(integer *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, logical *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ logical *, integer *, ftnlen);
+ char norm[1];
+ logical ignore_cwise__;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ logical rcequ;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), dpocon_(
+ char *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern integer ilaprec_(char *);
+ integer ithresh, n_norms__;
+ doublereal rthresh;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPORFSX improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric positive */
+/* definite, and provides error bounds and backward error estimates */
+/* for the solution. In addition to normwise error bound, the code */
+/* provides maximum componentwise error bound if possible. See */
+/* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the */
+/* error bounds. */
+
+/* The original system of linear equations may have been equilibrated */
+/* before calling this routine, as described by arguments EQUED and S */
+/* below. In this case, the solution and error bounds returned are */
+/* for the original unequilibrated system. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* EQUED (input) CHARACTER*1 */
+/* Specifies the form of equilibration that was done to A */
+/* before calling this routine. This is needed to compute */
+/* the solution and error bounds correctly. */
+/* = 'N': No equilibration */
+/* = 'Y': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(S) * A * diag(S). */
+/* The right hand side B has been changed accordingly. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular part */
+/* of the matrix A, and the strictly lower triangular part of A */
+/* is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of A contains the lower triangular part of */
+/* the matrix A, and the strictly upper triangular part of A is */
+/* not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by DPOTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* S (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'Y', A is multiplied on */
+/* the left and right by diag(S). S is an input argument if FACT = */
+/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
+/* = 'Y', each element of S must be positive. If S is output, each */
+/* element of S is a power of the radix. If S is input, each element */
+/* of S should be a power of the radix to ensure a reliable solution */
+/* and error estimates. Scaling by powers of the radix does not cause */
+/* rounding errors unless the result underflows or overflows. */
+/* Rounding errors during scaling lead to refining with a matrix that */
+/* is not equivalent to the input matrix, producing error estimates */
+/* that may not be reliable. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by DGETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0D+0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check the input parameters. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ ref_type__ = 1;
+ if (*nparams >= 1) {
+ if (params[1] < 0.) {
+ params[1] = 1.;
+ } else {
+ ref_type__ = (integer) params[1];
+ }
+ }
+
+/* Set default parameters. */
+
+ illrcond_thresh__ = (doublereal) (*n) * dlamch_("Epsilon");
+ ithresh = 10;
+ rthresh = .5;
+ unstable_thresh__ = .25;
+ ignore_cwise__ = FALSE_;
+
+ if (*nparams >= 2) {
+ if (params[2] < 0.) {
+ params[2] = (doublereal) ithresh;
+ } else {
+ ithresh = (integer) params[2];
+ }
+ }
+ if (*nparams >= 3) {
+ if (params[3] < 0.) {
+ if (ignore_cwise__) {
+ params[3] = 0.;
+ } else {
+ params[3] = 1.;
+ }
+ } else {
+ ignore_cwise__ = params[3] == 0.;
+ }
+ }
+ if (ref_type__ == 0 || *n_err_bnds__ == 0) {
+ n_norms__ = 0;
+ } else if (ignore_cwise__) {
+ n_norms__ = 1;
+ } else {
+ n_norms__ = 2;
+ }
+
+ rcequ = lsame_(equed, "Y");
+
+/* Test input parameters. */
+
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! rcequ && ! lsame_(equed, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -11;
+ } else if (*ldx < max(1,*n)) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPORFSX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *nrhs == 0) {
+ *rcond = 1.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 0.;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.;
+ }
+ }
+ return 0;
+ }
+
+/* Default to failure. */
+
+ *rcond = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 1.;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.;
+ }
+ }
+
+/* Compute the norm of A and the reciprocal of the condition */
+/* number of A. */
+
+ *(unsigned char *)norm = 'I';
+ anorm = dlansy_(norm, uplo, n, &a[a_offset], lda, &work[1]);
+ dpocon_(uplo, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &iwork[1],
+ info);
+
+/* Perform refinement on each right-hand side */
+
+ if (ref_type__ != 0) {
+ prec_type__ = ilaprec_("E");
+ dla_porfsx_extended__(&prec_type__, uplo, n, nrhs, &a[a_offset], lda,
+ &af[af_offset], ldaf, &rcequ, &s[1], &b[b_offset], ldb, &x[
+ x_offset], ldx, &berr[1], &n_norms__, &err_bnds_norm__[
+ err_bnds_norm_offset], &err_bnds_comp__[err_bnds_comp_offset],
+ &work[*n + 1], &work[1], &work[(*n << 1) + 1], &work[1],
+ rcond, &ithresh, &rthresh, &unstable_thresh__, &
+ ignore_cwise__, info, (ftnlen)1);
+ }
+/* Computing MAX */
+ d__1 = 10., d__2 = sqrt((doublereal) (*n));
+ err_lbnd__ = max(d__1,d__2) * dlamch_("Epsilon");
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {
+
+/* Compute scaled normwise condition number cond(A*C). */
+
+ if (rcequ) {
+ rcond_tmp__ = dla_porcond__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &c_n1, &s[1], info, &work[1], &iwork[1],
+ (ftnlen)1);
+ } else {
+ rcond_tmp__ = dla_porcond__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &c__0, &s[1], info, &work[1], &iwork[1],
+ (ftnlen)1);
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1
+ << 1)] > 1.) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 0.;
+ if (*info <= *n) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {
+
+/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
+/* each right-hand side using the current solution as an estimate of */
+/* the true solution. If the componentwise error estimate is too */
+/* large, then the solution is a lousy estimate of truth and the */
+/* estimated RCOND may be too optimistic. To avoid misleading users, */
+/* the inverse condition number is set to 0.0 when the estimated */
+/* cwise error is at least CWISE_WRONG. */
+
+ cwise_wrong__ = sqrt(dlamch_("Epsilon"));
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ cwise_wrong__) {
+ rcond_tmp__ = dla_porcond__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &c__1, &x[j * x_dim1 + 1], info, &
+ work[1], &iwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = 0.;
+ }
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1
+ << 1)] > 1.) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 0.;
+ if (params[3] == 1. && *info < *n + j) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DPORFSX */
+
+} /* dporfsx_ */
diff --git a/SRC/dposv.c b/SRC/dposv.c
new file mode 100644
index 0000000..745ff73
--- /dev/null
+++ b/SRC/dposv.c
@@ -0,0 +1,151 @@
+/* dposv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dposv_(char *uplo, integer *n, integer *nrhs, doublereal
+ *a, integer *lda, doublereal *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), dpotrf_(
+ char *, integer *, doublereal *, integer *, integer *),
+ dpotrs_(char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPOSV computes the solution to a real system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N symmetric positive definite matrix and X and B */
+/* are N-by-NRHS matrices. */
+
+/* The Cholesky decomposition is used to factor A as */
+/* A = U**T* U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is a lower triangular */
+/* matrix. The factored form of A is then used to solve the system of */
+/* equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i of A is not */
+/* positive definite, so the factorization could not be */
+/* completed, and the solution has not been computed. */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPOSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ dpotrf_(uplo, n, &a[a_offset], lda, info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ dpotrs_(uplo, n, nrhs, &a[a_offset], lda, &b[b_offset], ldb, info);
+
+ }
+ return 0;
+
+/* End of DPOSV */
+
+} /* dposv_ */
diff --git a/SRC/dposvx.c b/SRC/dposvx.c
new file mode 100644
index 0000000..1304556
--- /dev/null
+++ b/SRC/dposvx.c
@@ -0,0 +1,450 @@
+/* dposvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dposvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
+ char *equed, doublereal *s, doublereal *b, integer *ldb, doublereal *
+ x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *
+ berr, doublereal *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal amax, smin, smax;
+ extern logical lsame_(char *, char *);
+ doublereal scond, anorm;
+ logical equil, rcequ;
+ extern doublereal dlamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dpocon_(char *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *);
+ integer infequ;
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dlaqsy_(char *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, char *), dpoequ_(integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *), dporfs_(
+ char *, integer *, integer *, doublereal *, integer *, doublereal
+ *, integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *), dpotrf_(char *, integer *, doublereal *, integer *,
+ integer *);
+ doublereal smlnum;
+ extern /* Subroutine */ int dpotrs_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to */
+/* compute the solution to a real system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N symmetric positive definite matrix and X and B */
+/* are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+/* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
+
+/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */
+/* factor the matrix A (after equilibration if FACT = 'E') as */
+/* A = U**T* U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is a lower triangular */
+/* matrix. */
+
+/* 3. If the leading i-by-i principal minor is not positive definite, */
+/* then the routine returns with INFO = i. Otherwise, the factored */
+/* form of A is used to estimate the condition number of the matrix */
+/* A. If the reciprocal of the condition number is less than machine */
+/* precision, INFO = N+1 is returned as a warning, but the routine */
+/* still goes on to solve for X and compute error bounds as */
+/* described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(S) so that it solves the original system before */
+/* equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF contains the factored form of A. */
+/* If EQUED = 'Y', the matrix A has been equilibrated */
+/* with scaling factors given by S. A and AF will not */
+/* be modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A, except if FACT = 'F' and */
+/* EQUED = 'Y', then A must contain the equilibrated matrix */
+/* diag(S)*A*diag(S). If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. A is not modified if */
+/* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
+
+/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
+/* diag(S)*A*diag(S). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T, in the same storage */
+/* format as A. If EQUED .ne. 'N', then AF is the factored form */
+/* of the equilibrated matrix diag(S)*A*diag(S). */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T of the original */
+/* matrix A. */
+
+/* If FACT = 'E', then AF is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T of the equilibrated */
+/* matrix A (see the description of A for the form of the */
+/* equilibrated matrix). */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* S (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The scale factors for A; not accessed if EQUED = 'N'. S is */
+/* an input argument if FACT = 'F'; otherwise, S is an output */
+/* argument. If FACT = 'F' and EQUED = 'Y', each element of S */
+/* must be positive. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */
+/* B is overwritten by diag(S) * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */
+/* the original system of equations. Note that if EQUED = 'Y', */
+/* A and B are modified on exit, and the solution to the */
+/* equilibrated system is inv(diag(S))*X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A after equilibration (if done). If RCOND is less than the */
+/* machine precision (in particular, if RCOND = 0), the matrix */
+/* is singular to working precision. This condition is */
+/* indicated by a return code of INFO > 0. */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: the leading minor of order i of A is */
+/* not positive definite, so the factorization */
+/* could not be completed, and the solution has not */
+/* been computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rcequ = FALSE_;
+ } else {
+ rcequ = lsame_(equed, "Y");
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ }
+
+/* Test the input parameters. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (lsame_(fact, "F") && ! (rcequ || lsame_(
+ equed, "N"))) {
+ *info = -9;
+ } else {
+ if (rcequ) {
+ smin = bignum;
+ smax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = smin, d__2 = s[j];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = smax, d__2 = s[j];
+ smax = max(d__1,d__2);
+/* L10: */
+ }
+ if (smin <= 0.) {
+ *info = -10;
+ } else if (*n > 0) {
+ scond = max(smin,smlnum) / min(smax,bignum);
+ } else {
+ scond = 1.;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -12;
+ } else if (*ldx < max(1,*n)) {
+ *info = -14;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPOSVX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ dpoequ_(n, &a[a_offset], lda, &s[1], &scond, &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ dlaqsy_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed);
+ rcequ = lsame_(equed, "Y");
+ }
+ }
+
+/* Scale the right hand side. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = s[i__] * b[i__ + j * b_dim1];
+/* L20: */
+ }
+/* L30: */
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ dlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ dpotrf_(uplo, n, &af[af_offset], ldaf, info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = dlansy_("1", uplo, n, &a[a_offset], lda, &work[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ dpocon_(uplo, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &iwork[1],
+ info);
+
+/* Compute the solution matrix X. */
+
+ dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ dpotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &x[x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ dporfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &b[
+ b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1], &
+ iwork[1], info);
+
+/* Transform the solution matrix X to a solution of the original */
+/* system. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__ + j * x_dim1] = s[i__] * x[i__ + j * x_dim1];
+/* L40: */
+ }
+/* L50: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= scond;
+/* L60: */
+ }
+ }
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < dlamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of DPOSVX */
+
+} /* dposvx_ */
diff --git a/SRC/dposvxx.c b/SRC/dposvxx.c
new file mode 100644
index 0000000..3613211
--- /dev/null
+++ b/SRC/dposvxx.c
@@ -0,0 +1,611 @@
+/* dposvxx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dposvxx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
+ char *equed, doublereal *s, doublereal *b, integer *ldb, doublereal *
+ x, integer *ldx, doublereal *rcond, doublereal *rpvgrw, doublereal *
+ berr, integer *n_err_bnds__, doublereal *err_bnds_norm__, doublereal *
+ err_bnds_comp__, integer *nparams, doublereal *params, doublereal *
+ work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ doublereal amax, smin, smax;
+ extern doublereal dla_porpvgrw__(char *, integer *, doublereal *, integer
+ *, doublereal *, integer *, doublereal *, ftnlen);
+ extern logical lsame_(char *, char *);
+ doublereal scond;
+ logical equil, rcequ;
+ extern doublereal dlamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ doublereal bignum;
+ integer infequ;
+ extern /* Subroutine */ int dlaqsy_(char *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, char *), dpotrf_(char *, integer *, doublereal *, integer
+ *, integer *);
+ doublereal smlnum;
+ extern /* Subroutine */ int dpotrs_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dlascl2_(integer *, integer *, doublereal *, doublereal *
+, integer *), dpoequb_(integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *), dporfsx_(
+ char *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T */
+/* to compute the solution to a double precision system of linear equations */
+/* A * X = B, where A is an N-by-N symmetric positive definite matrix */
+/* and X and B are N-by-NRHS matrices. */
+
+/* If requested, both normwise and maximum componentwise error bounds */
+/* are returned. DPOSVXX will return a solution with a tiny */
+/* guaranteed error (O(eps) where eps is the working machine */
+/* precision) unless the matrix is very ill-conditioned, in which */
+/* case a warning is returned. Relevant condition numbers also are */
+/* calculated and returned. */
+
+/* DPOSVXX accepts user-provided factorizations and equilibration */
+/* factors; see the definitions of the FACT and EQUED options. */
+/* Solving with refinement and using a factorization from a previous */
+/* DPOSVXX call will also produce a solution with either O(eps) */
+/* errors or warnings, but we cannot make that claim for general */
+/* user-provided factorizations and equilibration factors if they */
+/* differ from what DPOSVXX would itself produce. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate */
+/* the system: */
+
+/* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B */
+
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
+
+/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */
+/* factor the matrix A (after equilibration if FACT = 'E') as */
+/* A = U**T* U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is a lower triangular */
+/* matrix. */
+
+/* 3. If the leading i-by-i principal minor is not positive definite, */
+/* then the routine returns with INFO = i. Otherwise, the factored */
+/* form of A is used to estimate the condition number of the matrix */
+/* A (see argument RCOND). If the reciprocal of the condition number */
+/* is less than machine precision, the routine still goes on to solve */
+/* for X and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */
+/* the routine will use iterative refinement to try to get a small */
+/* error and error bounds. Refinement calculates the residual to at */
+/* least twice the working precision. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(S) so that it solves the original system before */
+/* equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF contains the factored form of A. */
+/* If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by S. */
+/* A and AF are not modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED = */
+/* 'Y', then A must contain the equilibrated matrix */
+/* diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper */
+/* triangular part of A contains the upper triangular part of the */
+/* matrix A, and the strictly lower triangular part of A is not */
+/* referenced. If UPLO = 'L', the leading N-by-N lower triangular */
+/* part of A contains the lower triangular part of the matrix A, and */
+/* the strictly upper triangular part of A is not referenced. A is */
+/* not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED = */
+/* 'N' on exit. */
+
+/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
+/* diag(S)*A*diag(S). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T, in the same storage */
+/* format as A. If EQUED .ne. 'N', then AF is the factored */
+/* form of the equilibrated matrix diag(S)*A*diag(S). */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T of the original */
+/* matrix A. */
+
+/* If FACT = 'E', then AF is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T of the equilibrated */
+/* matrix A (see the description of A for the form of the */
+/* equilibrated matrix). */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'Y': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(S) * A * diag(S). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* S (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'Y', A is multiplied on */
+/* the left and right by diag(S). S is an input argument if FACT = */
+/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
+/* = 'Y', each element of S must be positive. If S is output, each */
+/* element of S is a power of the radix. If S is input, each element */
+/* of S should be a power of the radix to ensure a reliable solution */
+/* and error estimates. Scaling by powers of the radix does not cause */
+/* rounding errors unless the result underflows or overflows. */
+/* Rounding errors during scaling lead to refining with a matrix that */
+/* is not equivalent to the input matrix, producing error estimates */
+/* that may not be reliable. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if EQUED = 'Y', B is overwritten by diag(S)*B; */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* If INFO = 0, the N-by-NRHS solution matrix X to the original */
+/* system of equations. Note that A and B are modified on exit if */
+/* EQUED .ne. 'N', and the solution to the equilibrated system is */
+/* inv(diag(S))*X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* RPVGRW (output) DOUBLE PRECISION */
+/* Reciprocal pivot growth. On exit, this contains the reciprocal */
+/* pivot growth factor norm(A)/norm(U). The "max absolute element" */
+/* norm is used. If this is much less than 1, then the stability of */
+/* the LU factorization of the (equilibrated) matrix A could be poor. */
+/* This also means that the solution X, estimated condition numbers, */
+/* and error bounds could be unreliable. If factorization fails with */
+/* 0<INFO<=N, then this contains the reciprocal pivot growth factor */
+/* for the leading INFO columns of A. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0D+0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the extra-precise refinement algorithm. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rcequ = FALSE_;
+ } else {
+ rcequ = lsame_(equed, "Y");
+ }
+
+/* Default is failure. If an input parameter is wrong or */
+/* factorization fails, make everything look horrible. Only the */
+/* pivot growth is set here, the rest is initialized in DPORFSX. */
+
+ *rpvgrw = 0.;
+
+/* Test the input parameters. PARAMS is not tested until DPORFSX. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (lsame_(fact, "F") && ! (rcequ || lsame_(
+ equed, "N"))) {
+ *info = -9;
+ } else {
+ if (rcequ) {
+ smin = bignum;
+ smax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = smin, d__2 = s[j];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = smax, d__2 = s[j];
+ smax = max(d__1,d__2);
+/* L10: */
+ }
+ if (smin <= 0.) {
+ *info = -10;
+ } else if (*n > 0) {
+ scond = max(smin,smlnum) / min(smax,bignum);
+ } else {
+ scond = 1.;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -12;
+ } else if (*ldx < max(1,*n)) {
+ *info = -14;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPOSVXX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ dpoequb_(n, &a[a_offset], lda, &s[1], &scond, &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ dlaqsy_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed);
+ rcequ = lsame_(equed, "Y");
+ }
+ }
+
+/* Scale the right-hand side. */
+
+ if (rcequ) {
+ dlascl2_(n, nrhs, &s[1], &b[b_offset], ldb);
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of A. */
+
+ dlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ dpotrf_(uplo, n, &af[af_offset], ldaf, info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info != 0) {
+
+/* Pivot in column INFO is exactly 0 */
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ *rpvgrw = dla_porpvgrw__(uplo, info, &a[a_offset], lda, &af[
+ af_offset], ldaf, &work[1], (ftnlen)1);
+ return 0;
+ }
+ }
+
+/* Compute the reciprocal growth factor RPVGRW. */
+
+ *rpvgrw = dla_porpvgrw__(uplo, n, &a[a_offset], lda, &af[af_offset], ldaf,
+ &work[1], (ftnlen)1);
+
+/* Compute the solution matrix X. */
+
+ dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ dpotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &x[x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ dporfsx_(uplo, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &
+ s[1], &b[b_offset], ldb, &x[x_offset], ldx, rcond, &berr[1],
+ n_err_bnds__, &err_bnds_norm__[err_bnds_norm_offset], &
+ err_bnds_comp__[err_bnds_comp_offset], nparams, ¶ms[1], &work[
+ 1], &iwork[1], info);
+
+/* Scale solutions. */
+
+ if (rcequ) {
+ dlascl2_(n, nrhs, &s[1], &x[x_offset], ldx);
+ }
+
+ return 0;
+
+/* End of DPOSVXX */
+
+} /* dposvxx_ */
diff --git a/SRC/dpotf2.c b/SRC/dpotf2.c
new file mode 100644
index 0000000..fb237c3
--- /dev/null
+++ b/SRC/dpotf2.c
@@ -0,0 +1,224 @@
+/* dpotf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b10 = -1.;
+static doublereal c_b12 = 1.;
+
+/* Subroutine */ int dpotf2_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer j;
+ doublereal ajj;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ logical upper;
+ extern logical disnan_(doublereal *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPOTF2 computes the Cholesky factorization of a real symmetric */
+/* positive definite matrix A. */
+
+/* The factorization has the form */
+/* A = U' * U , if UPLO = 'U', or */
+/* A = L * L', if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n by n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n by n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization A = U'*U or A = L*L'. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, the leading minor of order k is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPOTF2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute U(J,J) and test for non-positive-definiteness. */
+
+ i__2 = j - 1;
+ ajj = a[j + j * a_dim1] - ddot_(&i__2, &a[j * a_dim1 + 1], &c__1,
+ &a[j * a_dim1 + 1], &c__1);
+ if (ajj <= 0. || disnan_(&ajj)) {
+ a[j + j * a_dim1] = ajj;
+ goto L30;
+ }
+ ajj = sqrt(ajj);
+ a[j + j * a_dim1] = ajj;
+
+/* Compute elements J+1:N of row J. */
+
+ if (j < *n) {
+ i__2 = j - 1;
+ i__3 = *n - j;
+ dgemv_("Transpose", &i__2, &i__3, &c_b10, &a[(j + 1) * a_dim1
+ + 1], lda, &a[j * a_dim1 + 1], &c__1, &c_b12, &a[j + (
+ j + 1) * a_dim1], lda);
+ i__2 = *n - j;
+ d__1 = 1. / ajj;
+ dscal_(&i__2, &d__1, &a[j + (j + 1) * a_dim1], lda);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute L(J,J) and test for non-positive-definiteness. */
+
+ i__2 = j - 1;
+ ajj = a[j + j * a_dim1] - ddot_(&i__2, &a[j + a_dim1], lda, &a[j
+ + a_dim1], lda);
+ if (ajj <= 0. || disnan_(&ajj)) {
+ a[j + j * a_dim1] = ajj;
+ goto L30;
+ }
+ ajj = sqrt(ajj);
+ a[j + j * a_dim1] = ajj;
+
+/* Compute elements J+1:N of column J. */
+
+ if (j < *n) {
+ i__2 = *n - j;
+ i__3 = j - 1;
+ dgemv_("No transpose", &i__2, &i__3, &c_b10, &a[j + 1 +
+ a_dim1], lda, &a[j + a_dim1], lda, &c_b12, &a[j + 1 +
+ j * a_dim1], &c__1);
+ i__2 = *n - j;
+ d__1 = 1. / ajj;
+ dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1);
+ }
+/* L20: */
+ }
+ }
+ goto L40;
+
+L30:
+ *info = j;
+
+L40:
+ return 0;
+
+/* End of DPOTF2 */
+
+} /* dpotf2_ */
diff --git a/SRC/dpotrf.c b/SRC/dpotrf.c
new file mode 100644
index 0000000..5ebdcfc
--- /dev/null
+++ b/SRC/dpotrf.c
@@ -0,0 +1,245 @@
+/* dpotrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b13 = -1.;
+static doublereal c_b14 = 1.;
+
+/* Subroutine */ int dpotrf_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer j, jb, nb;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *), dpotf2_(char *, integer *,
+ doublereal *, integer *, integer *), xerbla_(char *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPOTRF computes the Cholesky factorization of a real symmetric */
+/* positive definite matrix A. */
+
+/* The factorization has the form */
+/* A = U**T * U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* This is the block version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPOTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "DPOTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code. */
+
+ dpotf2_(uplo, n, &a[a_offset], lda, info);
+ } else {
+
+/* Use blocked code. */
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+ i__3 = j - 1;
+ dsyrk_("Upper", "Transpose", &jb, &i__3, &c_b13, &a[j *
+ a_dim1 + 1], lda, &c_b14, &a[j + j * a_dim1], lda);
+ dpotf2_("Upper", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+ if (j + jb <= *n) {
+
+/* Compute the current block row. */
+
+ i__3 = *n - j - jb + 1;
+ i__4 = j - 1;
+ dgemm_("Transpose", "No transpose", &jb, &i__3, &i__4, &
+ c_b13, &a[j * a_dim1 + 1], lda, &a[(j + jb) *
+ a_dim1 + 1], lda, &c_b14, &a[j + (j + jb) *
+ a_dim1], lda);
+ i__3 = *n - j - jb + 1;
+ dtrsm_("Left", "Upper", "Transpose", "Non-unit", &jb, &
+ i__3, &c_b14, &a[j + j * a_dim1], lda, &a[j + (j
+ + jb) * a_dim1], lda);
+ }
+/* L10: */
+ }
+
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+ i__3 = j - 1;
+ dsyrk_("Lower", "No transpose", &jb, &i__3, &c_b13, &a[j +
+ a_dim1], lda, &c_b14, &a[j + j * a_dim1], lda);
+ dpotf2_("Lower", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+ if (j + jb <= *n) {
+
+/* Compute the current block column. */
+
+ i__3 = *n - j - jb + 1;
+ i__4 = j - 1;
+ dgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &
+ c_b13, &a[j + jb + a_dim1], lda, &a[j + a_dim1],
+ lda, &c_b14, &a[j + jb + j * a_dim1], lda);
+ i__3 = *n - j - jb + 1;
+ dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i__3, &
+ jb, &c_b14, &a[j + j * a_dim1], lda, &a[j + jb +
+ j * a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+ }
+ goto L40;
+
+L30:
+ *info = *info + j - 1;
+
+L40:
+ return 0;
+
+/* End of DPOTRF */
+
+} /* dpotrf_ */
diff --git a/SRC/dpotri.c b/SRC/dpotri.c
new file mode 100644
index 0000000..9141e4c
--- /dev/null
+++ b/SRC/dpotri.c
@@ -0,0 +1,125 @@
+/* dpotri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dpotri_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), dlauum_(
+ char *, integer *, doublereal *, integer *, integer *),
+ dtrtri_(char *, char *, integer *, doublereal *, integer *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPOTRI computes the inverse of a real symmetric positive definite */
+/* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T */
+/* computed by DPOTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T, as computed by */
+/* DPOTRF. */
+/* On exit, the upper or lower triangle of the (symmetric) */
+/* inverse of A, overwriting the input factor U or L. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the (i,i) element of the factor U or L is */
+/* zero, and the inverse could not be computed. */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPOTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Invert the triangular Cholesky factor U or L. */
+
+ dtrtri_(uplo, "Non-unit", n, &a[a_offset], lda, info);
+ if (*info > 0) {
+ return 0;
+ }
+
+/* Form inv(U)*inv(U)' or inv(L)'*inv(L). */
+
+ dlauum_(uplo, n, &a[a_offset], lda, info);
+
+ return 0;
+
+/* End of DPOTRI */
+
+} /* dpotri_ */
diff --git a/SRC/dpotrs.c b/SRC/dpotrs.c
new file mode 100644
index 0000000..888a96f
--- /dev/null
+++ b/SRC/dpotrs.c
@@ -0,0 +1,166 @@
+/* dpotrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b9 = 1.;
+
+/* Subroutine */ int dpotrs_(char *uplo, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPOTRS solves a system of linear equations A*X = B with a symmetric */
+/* positive definite matrix A using the Cholesky factorization */
+/* A = U**T*U or A = L*L**T computed by DPOTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by DPOTRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPOTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B where A = U'*U. */
+
+/* Solve U'*X = B, overwriting B with X. */
+
+ dtrsm_("Left", "Upper", "Transpose", "Non-unit", n, nrhs, &c_b9, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+/* Solve U*X = B, overwriting B with X. */
+
+ dtrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b9, &
+ a[a_offset], lda, &b[b_offset], ldb);
+ } else {
+
+/* Solve A*X = B where A = L*L'. */
+
+/* Solve L*X = B, overwriting B with X. */
+
+ dtrsm_("Left", "Lower", "No transpose", "Non-unit", n, nrhs, &c_b9, &
+ a[a_offset], lda, &b[b_offset], ldb);
+
+/* Solve L'*X = B, overwriting B with X. */
+
+ dtrsm_("Left", "Lower", "Transpose", "Non-unit", n, nrhs, &c_b9, &a[
+ a_offset], lda, &b[b_offset], ldb);
+ }
+
+ return 0;
+
+/* End of DPOTRS */
+
+} /* dpotrs_ */
diff --git a/SRC/dppcon.c b/SRC/dppcon.c
new file mode 100644
index 0000000..cfac4a1
--- /dev/null
+++ b/SRC/dppcon.c
@@ -0,0 +1,215 @@
+/* dppcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dppcon_(char *uplo, integer *n, doublereal *ap,
+ doublereal *anorm, doublereal *rcond, doublereal *work, integer *
+ iwork, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Local variables */
+ integer ix, kase;
+ doublereal scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int drscl_(integer *, doublereal *, doublereal *,
+ integer *);
+ logical upper;
+ extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal scalel;
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal scaleu;
+ extern /* Subroutine */ int xerbla_(char *, integer *), dlatps_(
+ char *, char *, char *, char *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ doublereal ainvnm;
+ char normin[1];
+ doublereal smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPPCON estimates the reciprocal of the condition number (in the */
+/* 1-norm) of a real symmetric positive definite packed matrix using */
+/* the Cholesky factorization A = U**T*U or A = L*L**T computed by */
+/* DPPTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, packed columnwise in a linear */
+/* array. The j-th column of U or L is stored in the array AP */
+/* as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */
+
+/* ANORM (input) DOUBLE PRECISION */
+/* The 1-norm (or infinity-norm) of the symmetric matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*anorm < 0.) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPPCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.;
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ } else if (*anorm == 0.) {
+ return 0;
+ }
+
+ smlnum = dlamch_("Safe minimum");
+
+/* Estimate the 1-norm of the inverse. */
+
+ kase = 0;
+ *(unsigned char *)normin = 'N';
+L10:
+ dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (upper) {
+
+/* Multiply by inv(U'). */
+
+ dlatps_("Upper", "Transpose", "Non-unit", normin, n, &ap[1], &
+ work[1], &scalel, &work[(*n << 1) + 1], info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(U). */
+
+ dlatps_("Upper", "No transpose", "Non-unit", normin, n, &ap[1], &
+ work[1], &scaleu, &work[(*n << 1) + 1], info);
+ } else {
+
+/* Multiply by inv(L). */
+
+ dlatps_("Lower", "No transpose", "Non-unit", normin, n, &ap[1], &
+ work[1], &scalel, &work[(*n << 1) + 1], info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(L'). */
+
+ dlatps_("Lower", "Transpose", "Non-unit", normin, n, &ap[1], &
+ work[1], &scaleu, &work[(*n << 1) + 1], info);
+ }
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ scale = scalel * scaleu;
+ if (scale != 1.) {
+ ix = idamax_(n, &work[1], &c__1);
+ if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.)
+ {
+ goto L20;
+ }
+ drscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / ainvnm / *anorm;
+ }
+
+L20:
+ return 0;
+
+/* End of DPPCON */
+
+} /* dppcon_ */
diff --git a/SRC/dppequ.c b/SRC/dppequ.c
new file mode 100644
index 0000000..d9eda2d
--- /dev/null
+++ b/SRC/dppequ.c
@@ -0,0 +1,208 @@
+/* dppequ.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dppequ_(char *uplo, integer *n, doublereal *ap,
+ doublereal *s, doublereal *scond, doublereal *amax, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, jj;
+ doublereal smin;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPPEQU computes row and column scalings intended to equilibrate a */
+/* symmetric positive definite matrix A in packed storage and reduce */
+/* its condition number (with respect to the two-norm). S contains the */
+/* scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix */
+/* B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal. */
+/* This choice of S puts the condition number of B within a factor N of */
+/* the smallest possible condition number over all possible diagonal */
+/* scalings. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the symmetric matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* S (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, S contains the scale factors for A. */
+
+/* SCOND (output) DOUBLE PRECISION */
+/* If INFO = 0, S contains the ratio of the smallest S(i) to */
+/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
+/* large nor too small, it is not worth scaling by S. */
+
+/* AMAX (output) DOUBLE PRECISION */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --s;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPPEQU", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *scond = 1.;
+ *amax = 0.;
+ return 0;
+ }
+
+/* Initialize SMIN and AMAX. */
+
+ s[1] = ap[1];
+ smin = s[1];
+ *amax = s[1];
+
+ if (upper) {
+
+/* UPLO = 'U': Upper triangle of A is stored. */
+/* Find the minimum and maximum diagonal elements. */
+
+ jj = 1;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ jj += i__;
+ s[i__] = ap[jj];
+/* Computing MIN */
+ d__1 = smin, d__2 = s[i__];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = *amax, d__2 = s[i__];
+ *amax = max(d__1,d__2);
+/* L10: */
+ }
+
+ } else {
+
+/* UPLO = 'L': Lower triangle of A is stored. */
+/* Find the minimum and maximum diagonal elements. */
+
+ jj = 1;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ jj = jj + *n - i__ + 2;
+ s[i__] = ap[jj];
+/* Computing MIN */
+ d__1 = smin, d__2 = s[i__];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = *amax, d__2 = s[i__];
+ *amax = max(d__1,d__2);
+/* L20: */
+ }
+ }
+
+ if (smin <= 0.) {
+
+/* Find the first non-positive diagonal element and return. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] <= 0.) {
+ *info = i__;
+ return 0;
+ }
+/* L30: */
+ }
+ } else {
+
+/* Set the scale factors to the reciprocals */
+/* of the diagonal elements. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s[i__] = 1. / sqrt(s[i__]);
+/* L40: */
+ }
+
+/* Compute SCOND = min(S(I)) / max(S(I)) */
+
+ *scond = sqrt(smin) / sqrt(*amax);
+ }
+ return 0;
+
+/* End of DPPEQU */
+
+} /* dppequ_ */
diff --git a/SRC/dpprfs.c b/SRC/dpprfs.c
new file mode 100644
index 0000000..2eef815
--- /dev/null
+++ b/SRC/dpprfs.c
@@ -0,0 +1,413 @@
+/* dpprfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b12 = -1.;
+static doublereal c_b14 = 1.;
+
+/* Subroutine */ int dpprfs_(char *uplo, integer *n, integer *nrhs,
+ doublereal *ap, doublereal *afp, doublereal *b, integer *ldb,
+ doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr,
+ doublereal *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal s;
+ integer ik, kk;
+ doublereal xk;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *);
+ integer count;
+ extern /* Subroutine */ int dspmv_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ logical upper;
+ extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal lstres;
+ extern /* Subroutine */ int dpptrs_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPPRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric positive definite */
+/* and packed, and provides error bounds and backward error estimates */
+/* for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the symmetric matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* AFP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by DPPTRF/ZPPTRF, */
+/* packed columnwise in a linear array in the same format as A */
+/* (see AP). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by DPPTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --afp;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldx < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPPRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+ dspmv_(uplo, n, &c_b12, &ap[1], &x[j * x_dim1 + 1], &c__1, &c_b14, &
+ work[*n + 1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ kk = 1;
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+ ik = kk;
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ work[i__] += (d__1 = ap[ik], abs(d__1)) * xk;
+ s += (d__1 = ap[ik], abs(d__1)) * (d__2 = x[i__ + j *
+ x_dim1], abs(d__2));
+ ++ik;
+/* L40: */
+ }
+ work[k] = work[k] + (d__1 = ap[kk + k - 1], abs(d__1)) * xk +
+ s;
+ kk += k;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+ work[k] += (d__1 = ap[kk], abs(d__1)) * xk;
+ ik = kk + 1;
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ work[i__] += (d__1 = ap[ik], abs(d__1)) * xk;
+ s += (d__1 = ap[ik], abs(d__1)) * (d__2 = x[i__ + j *
+ x_dim1], abs(d__2));
+ ++ik;
+/* L60: */
+ }
+ work[k] += s;
+ kk += *n - k + 1;
+/* L70: */
+ }
+ }
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[
+ i__];
+ s = max(d__2,d__3);
+ } else {
+/* Computing MAX */
+ d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1)
+ / (work[i__] + safe1);
+ s = max(d__2,d__3);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ dpptrs_(uplo, n, &c__1, &afp[1], &work[*n + 1], n, info);
+ daxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
+ ;
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use DLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+ kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ dpptrs_(uplo, n, &c__1, &afp[1], &work[*n + 1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L120: */
+ }
+ dpptrs_(uplo, n, &c__1, &afp[1], &work[*n + 1], n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1));
+ lstres = max(d__2,d__3);
+/* L130: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of DPPRFS */
+
+} /* dpprfs_ */
diff --git a/SRC/dppsv.c b/SRC/dppsv.c
new file mode 100644
index 0000000..924d429
--- /dev/null
+++ b/SRC/dppsv.c
@@ -0,0 +1,161 @@
+/* dppsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dppsv_(char *uplo, integer *n, integer *nrhs, doublereal
+ *ap, doublereal *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), dpptrf_(
+ char *, integer *, doublereal *, integer *), dpptrs_(char
+ *, integer *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPPSV computes the solution to a real system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N symmetric positive definite matrix stored in */
+/* packed format and X and B are N-by-NRHS matrices. */
+
+/* The Cholesky decomposition is used to factor A as */
+/* A = U**T* U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is a lower triangular */
+/* matrix. The factored form of A is then used to solve the system of */
+/* equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T, in the same storage */
+/* format as A. */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i of A is not */
+/* positive definite, so the factorization could not be */
+/* completed, and the solution has not been computed. */
+
+/* Further Details */
+/* =============== */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the symmetric matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = conjg(aji)) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPPSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ dpptrf_(uplo, n, &ap[1], info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ dpptrs_(uplo, n, nrhs, &ap[1], &b[b_offset], ldb, info);
+
+ }
+ return 0;
+
+/* End of DPPSV */
+
+} /* dppsv_ */
diff --git a/SRC/dppsvx.c b/SRC/dppsvx.c
new file mode 100644
index 0000000..d0db687
--- /dev/null
+++ b/SRC/dppsvx.c
@@ -0,0 +1,455 @@
+/* dppsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dppsvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublereal *ap, doublereal *afp, char *equed, doublereal *s,
+ doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
+ rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *
+ iwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal amax, smin, smax;
+ extern logical lsame_(char *, char *);
+ doublereal scond, anorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical equil, rcequ;
+ extern doublereal dlamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ doublereal bignum;
+ extern doublereal dlansp_(char *, char *, integer *, doublereal *,
+ doublereal *);
+ extern /* Subroutine */ int dppcon_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *), dlaqsp_(char *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, char *);
+ integer infequ;
+ extern /* Subroutine */ int dppequ_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ dpprfs_(char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *),
+ dpptrf_(char *, integer *, doublereal *, integer *);
+ doublereal smlnum;
+ extern /* Subroutine */ int dpptrs_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to */
+/* compute the solution to a real system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N symmetric positive definite matrix stored in */
+/* packed format and X and B are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+/* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
+
+/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */
+/* factor the matrix A (after equilibration if FACT = 'E') as */
+/* A = U**T* U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is a lower triangular */
+/* matrix. */
+
+/* 3. If the leading i-by-i principal minor is not positive definite, */
+/* then the routine returns with INFO = i. Otherwise, the factored */
+/* form of A is used to estimate the condition number of the matrix */
+/* A. If the reciprocal of the condition number is less than machine */
+/* precision, INFO = N+1 is returned as a warning, but the routine */
+/* still goes on to solve for X and compute error bounds as */
+/* described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(S) so that it solves the original system before */
+/* equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AFP contains the factored form of A. */
+/* If EQUED = 'Y', the matrix A has been equilibrated */
+/* with scaling factors given by S. AP and AFP will not */
+/* be modified. */
+/* = 'N': The matrix A will be copied to AFP and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AFP and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array, except if FACT = 'F' */
+/* and EQUED = 'Y', then A must contain the equilibrated matrix */
+/* diag(S)*A*diag(S). The j-th column of A is stored in the */
+/* array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. A is not modified if */
+/* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
+
+/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
+/* diag(S)*A*diag(S). */
+
+/* AFP (input or output) DOUBLE PRECISION array, dimension */
+/* (N*(N+1)/2) */
+/* If FACT = 'F', then AFP is an input argument and on entry */
+/* contains the triangular factor U or L from the Cholesky */
+/* factorization A = U'*U or A = L*L', in the same storage */
+/* format as A. If EQUED .ne. 'N', then AFP is the factored */
+/* form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AFP is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U'*U or A = L*L' of the original matrix A. */
+
+/* If FACT = 'E', then AFP is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U'*U or A = L*L' of the equilibrated */
+/* matrix A (see the description of AP for the form of the */
+/* equilibrated matrix). */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* S (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The scale factors for A; not accessed if EQUED = 'N'. S is */
+/* an input argument if FACT = 'F'; otherwise, S is an output */
+/* argument. If FACT = 'F' and EQUED = 'Y', each element of S */
+/* must be positive. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */
+/* B is overwritten by diag(S) * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */
+/* the original system of equations. Note that if EQUED = 'Y', */
+/* A and B are modified on exit, and the solution to the */
+/* equilibrated system is inv(diag(S))*X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A after equilibration (if done). If RCOND is less than the */
+/* machine precision (in particular, if RCOND = 0), the matrix */
+/* is singular to working precision. This condition is */
+/* indicated by a return code of INFO > 0. */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: the leading minor of order i of A is */
+/* not positive definite, so the factorization */
+/* could not be completed, and the solution has not */
+/* been computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* Further Details */
+/* =============== */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the symmetric matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = conjg(aji)) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ap;
+ --afp;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rcequ = FALSE_;
+ } else {
+ rcequ = lsame_(equed, "Y");
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ }
+
+/* Test the input parameters. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (lsame_(fact, "F") && ! (rcequ || lsame_(
+ equed, "N"))) {
+ *info = -7;
+ } else {
+ if (rcequ) {
+ smin = bignum;
+ smax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = smin, d__2 = s[j];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = smax, d__2 = s[j];
+ smax = max(d__1,d__2);
+/* L10: */
+ }
+ if (smin <= 0.) {
+ *info = -8;
+ } else if (*n > 0) {
+ scond = max(smin,smlnum) / min(smax,bignum);
+ } else {
+ scond = 1.;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldx < max(1,*n)) {
+ *info = -12;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPPSVX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ dppequ_(uplo, n, &ap[1], &s[1], &scond, &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ dlaqsp_(uplo, n, &ap[1], &s[1], &scond, &amax, equed);
+ rcequ = lsame_(equed, "Y");
+ }
+ }
+
+/* Scale the right-hand side. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = s[i__] * b[i__ + j * b_dim1];
+/* L20: */
+ }
+/* L30: */
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ i__1 = *n * (*n + 1) / 2;
+ dcopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1);
+ dpptrf_(uplo, n, &afp[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = dlansp_("I", uplo, n, &ap[1], &work[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ dppcon_(uplo, n, &afp[1], &anorm, rcond, &work[1], &iwork[1], info);
+
+/* Compute the solution matrix X. */
+
+ dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ dpptrs_(uplo, n, nrhs, &afp[1], &x[x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ dpprfs_(uplo, n, nrhs, &ap[1], &afp[1], &b[b_offset], ldb, &x[x_offset],
+ ldx, &ferr[1], &berr[1], &work[1], &iwork[1], info);
+
+/* Transform the solution matrix X to a solution of the original */
+/* system. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__ + j * x_dim1] = s[i__] * x[i__ + j * x_dim1];
+/* L40: */
+ }
+/* L50: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= scond;
+/* L60: */
+ }
+ }
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < dlamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of DPPSVX */
+
+} /* dppsvx_ */
diff --git a/SRC/dpptrf.c b/SRC/dpptrf.c
new file mode 100644
index 0000000..dff1a79
--- /dev/null
+++ b/SRC/dpptrf.c
@@ -0,0 +1,223 @@
+/* dpptrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b16 = -1.;
+
+/* Subroutine */ int dpptrf_(char *uplo, integer *n, doublereal *ap, integer *
+ info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer j, jc, jj;
+ doublereal ajj;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ extern /* Subroutine */ int dspr_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *), dscal_(integer *,
+ doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int dtpsv_(char *, char *, char *, integer *,
+ doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPPTRF computes the Cholesky factorization of a real symmetric */
+/* positive definite matrix A stored in packed format. */
+
+/* The factorization has the form */
+/* A = U**T * U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+
+/* On exit, if INFO = 0, the triangular factor U or L from the */
+/* Cholesky factorization A = U**T*U or A = L*L**T, in the same */
+/* storage format as A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* Further Details */
+/* ======= ======= */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the symmetric matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = aji) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPPTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ jj = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ jc = jj + 1;
+ jj += j;
+
+/* Compute elements 1:J-1 of column J. */
+
+ if (j > 1) {
+ i__2 = j - 1;
+ dtpsv_("Upper", "Transpose", "Non-unit", &i__2, &ap[1], &ap[
+ jc], &c__1);
+ }
+
+/* Compute U(J,J) and test for non-positive-definiteness. */
+
+ i__2 = j - 1;
+ ajj = ap[jj] - ddot_(&i__2, &ap[jc], &c__1, &ap[jc], &c__1);
+ if (ajj <= 0.) {
+ ap[jj] = ajj;
+ goto L30;
+ }
+ ap[jj] = sqrt(ajj);
+/* L10: */
+ }
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ jj = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute L(J,J) and test for non-positive-definiteness. */
+
+ ajj = ap[jj];
+ if (ajj <= 0.) {
+ ap[jj] = ajj;
+ goto L30;
+ }
+ ajj = sqrt(ajj);
+ ap[jj] = ajj;
+
+/* Compute elements J+1:N of column J and update the trailing */
+/* submatrix. */
+
+ if (j < *n) {
+ i__2 = *n - j;
+ d__1 = 1. / ajj;
+ dscal_(&i__2, &d__1, &ap[jj + 1], &c__1);
+ i__2 = *n - j;
+ dspr_("Lower", &i__2, &c_b16, &ap[jj + 1], &c__1, &ap[jj + *n
+ - j + 1]);
+ jj = jj + *n - j + 1;
+ }
+/* L20: */
+ }
+ }
+ goto L40;
+
+L30:
+ *info = j;
+
+L40:
+ return 0;
+
+/* End of DPPTRF */
+
+} /* dpptrf_ */
diff --git a/SRC/dpptri.c b/SRC/dpptri.c
new file mode 100644
index 0000000..5de72f0
--- /dev/null
+++ b/SRC/dpptri.c
@@ -0,0 +1,173 @@
+/* dpptri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b8 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dpptri_(char *uplo, integer *n, doublereal *ap, integer *
+ info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer j, jc, jj;
+ doublereal ajj;
+ integer jjn;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ extern /* Subroutine */ int dspr_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *), dscal_(integer *,
+ doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *,
+ doublereal *, doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *), dtptri_(
+ char *, char *, integer *, doublereal *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPPTRI computes the inverse of a real symmetric positive definite */
+/* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T */
+/* computed by DPPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular factor is stored in AP; */
+/* = 'L': Lower triangular factor is stored in AP. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* On entry, the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T, packed columnwise as */
+/* a linear array. The j-th column of U or L is stored in the */
+/* array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */
+
+/* On exit, the upper or lower triangle of the (symmetric) */
+/* inverse of A, overwriting the input factor U or L. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the (i,i) element of the factor U or L is */
+/* zero, and the inverse could not be computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPPTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Invert the triangular Cholesky factor U or L. */
+
+ dtptri_(uplo, "Non-unit", n, &ap[1], info);
+ if (*info > 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Compute the product inv(U) * inv(U)'. */
+
+ jj = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ jc = jj + 1;
+ jj += j;
+ if (j > 1) {
+ i__2 = j - 1;
+ dspr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1]);
+ }
+ ajj = ap[jj];
+ dscal_(&j, &ajj, &ap[jc], &c__1);
+/* L10: */
+ }
+
+ } else {
+
+/* Compute the product inv(L)' * inv(L). */
+
+ jj = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ jjn = jj + *n - j + 1;
+ i__2 = *n - j + 1;
+ ap[jj] = ddot_(&i__2, &ap[jj], &c__1, &ap[jj], &c__1);
+ if (j < *n) {
+ i__2 = *n - j;
+ dtpmv_("Lower", "Transpose", "Non-unit", &i__2, &ap[jjn], &ap[
+ jj + 1], &c__1);
+ }
+ jj = jjn;
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of DPPTRI */
+
+} /* dpptri_ */
diff --git a/SRC/dpptrs.c b/SRC/dpptrs.c
new file mode 100644
index 0000000..888bfef
--- /dev/null
+++ b/SRC/dpptrs.c
@@ -0,0 +1,170 @@
+/* dpptrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dpptrs_(char *uplo, integer *n, integer *nrhs,
+ doublereal *ap, doublereal *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ integer i__;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int dtpsv_(char *, char *, char *, integer *,
+ doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPPTRS solves a system of linear equations A*X = B with a symmetric */
+/* positive definite matrix A in packed storage using the Cholesky */
+/* factorization A = U**T*U or A = L*L**T computed by DPPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, packed columnwise in a linear */
+/* array. The j-th column of U or L is stored in the array AP */
+/* as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPPTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B where A = U'*U. */
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Solve U'*X = B, overwriting B with X. */
+
+ dtpsv_("Upper", "Transpose", "Non-unit", n, &ap[1], &b[i__ *
+ b_dim1 + 1], &c__1);
+
+/* Solve U*X = B, overwriting B with X. */
+
+ dtpsv_("Upper", "No transpose", "Non-unit", n, &ap[1], &b[i__ *
+ b_dim1 + 1], &c__1);
+/* L10: */
+ }
+ } else {
+
+/* Solve A*X = B where A = L*L'. */
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Solve L*Y = B, overwriting B with X. */
+
+ dtpsv_("Lower", "No transpose", "Non-unit", n, &ap[1], &b[i__ *
+ b_dim1 + 1], &c__1);
+
+/* Solve L'*X = Y, overwriting B with X. */
+
+ dtpsv_("Lower", "Transpose", "Non-unit", n, &ap[1], &b[i__ *
+ b_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of DPPTRS */
+
+} /* dpptrs_ */
diff --git a/SRC/dpstf2.c b/SRC/dpstf2.c
new file mode 100644
index 0000000..a66b614
--- /dev/null
+++ b/SRC/dpstf2.c
@@ -0,0 +1,395 @@
+/* dpstf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b16 = -1.;
+static doublereal c_b18 = 1.;
+
+/* Subroutine */ int dpstf2_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *piv, integer *rank, doublereal *tol, doublereal *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, maxlocval;
+ doublereal ajj;
+ integer pvt;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ doublereal dtemp;
+ integer itemp;
+ extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ doublereal dstop;
+ logical upper;
+ extern doublereal dlamch_(char *);
+ extern logical disnan_(doublereal *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer dmaxloc_(doublereal *, integer *);
+
+
+/* -- LAPACK PROTOTYPE routine (version 3.2) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPSTF2 computes the Cholesky factorization with complete */
+/* pivoting of a real symmetric positive semidefinite matrix A. */
+
+/* The factorization has the form */
+/* P' * A * P = U' * U , if UPLO = 'U', */
+/* P' * A * P = L * L', if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular, and */
+/* P is stored as vector PIV. */
+
+/* This algorithm does not attempt to check that A is positive */
+/* semidefinite. This version of the algorithm calls level 2 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n by n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n by n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization as above. */
+
+/* PIV (output) INTEGER array, dimension (N) */
+/* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. */
+
+/* RANK (output) INTEGER */
+/* The rank of A given by the number of steps the algorithm */
+/* completed. */
+
+/* TOL (input) DOUBLE PRECISION */
+/* User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) ) */
+/* will be used. The algorithm terminates at the (K-1)st step */
+/* if the pivot <= TOL. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* WORK DOUBLE PRECISION array, dimension (2*N) */
+/* Work space. */
+
+/* INFO (output) INTEGER */
+/* < 0: If INFO = -K, the K-th argument had an illegal value, */
+/* = 0: algorithm completed successfully, and */
+/* > 0: the matrix A is either rank deficient with computed rank */
+/* as returned in RANK, or is indefinite. See Section 7 of */
+/* LAPACK Working Note #161 for further information. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ --work;
+ --piv;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPSTF2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Initialize PIV */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ piv[i__] = i__;
+/* L100: */
+ }
+
+/* Compute stopping value */
+
+ pvt = 1;
+ ajj = a[pvt + pvt * a_dim1];
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ if (a[i__ + i__ * a_dim1] > ajj) {
+ pvt = i__;
+ ajj = a[pvt + pvt * a_dim1];
+ }
+ }
+ if (ajj == 0. || disnan_(&ajj)) {
+ *rank = 0;
+ *info = 1;
+ goto L170;
+ }
+
+/* Compute stopping value if not supplied */
+
+ if (*tol < 0.) {
+ dstop = *n * dlamch_("Epsilon") * ajj;
+ } else {
+ dstop = *tol;
+ }
+
+/* Set first half of WORK to zero, holds dot products */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L110: */
+ }
+
+ if (upper) {
+
+/* Compute the Cholesky factorization P' * A * P = U' * U */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Find pivot, test for exit, else swap rows and columns */
+/* Update dot products, compute possible pivots which are */
+/* stored in the second half of WORK */
+
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+
+ if (j > 1) {
+/* Computing 2nd power */
+ d__1 = a[j - 1 + i__ * a_dim1];
+ work[i__] += d__1 * d__1;
+ }
+ work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__];
+
+/* L120: */
+ }
+
+ if (j > 1) {
+ maxlocval = (*n << 1) - (*n + j) + 1;
+ itemp = dmaxloc_(&work[*n + j], &maxlocval);
+ pvt = itemp + j - 1;
+ ajj = work[*n + pvt];
+ if (ajj <= dstop || disnan_(&ajj)) {
+ a[j + j * a_dim1] = ajj;
+ goto L160;
+ }
+ }
+
+ if (j != pvt) {
+
+/* Pivot OK, so can now swap pivot rows and columns */
+
+ a[pvt + pvt * a_dim1] = a[j + j * a_dim1];
+ i__2 = j - 1;
+ dswap_(&i__2, &a[j * a_dim1 + 1], &c__1, &a[pvt * a_dim1 + 1],
+ &c__1);
+ if (pvt < *n) {
+ i__2 = *n - pvt;
+ dswap_(&i__2, &a[j + (pvt + 1) * a_dim1], lda, &a[pvt + (
+ pvt + 1) * a_dim1], lda);
+ }
+ i__2 = pvt - j - 1;
+ dswap_(&i__2, &a[j + (j + 1) * a_dim1], lda, &a[j + 1 + pvt *
+ a_dim1], &c__1);
+
+/* Swap dot products and PIV */
+
+ dtemp = work[j];
+ work[j] = work[pvt];
+ work[pvt] = dtemp;
+ itemp = piv[pvt];
+ piv[pvt] = piv[j];
+ piv[j] = itemp;
+ }
+
+ ajj = sqrt(ajj);
+ a[j + j * a_dim1] = ajj;
+
+/* Compute elements J+1:N of row J */
+
+ if (j < *n) {
+ i__2 = j - 1;
+ i__3 = *n - j;
+ dgemv_("Trans", &i__2, &i__3, &c_b16, &a[(j + 1) * a_dim1 + 1]
+, lda, &a[j * a_dim1 + 1], &c__1, &c_b18, &a[j + (j +
+ 1) * a_dim1], lda);
+ i__2 = *n - j;
+ d__1 = 1. / ajj;
+ dscal_(&i__2, &d__1, &a[j + (j + 1) * a_dim1], lda);
+ }
+
+/* L130: */
+ }
+
+ } else {
+
+/* Compute the Cholesky factorization P' * A * P = L * L' */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Find pivot, test for exit, else swap rows and columns */
+/* Update dot products, compute possible pivots which are */
+/* stored in the second half of WORK */
+
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+
+ if (j > 1) {
+/* Computing 2nd power */
+ d__1 = a[i__ + (j - 1) * a_dim1];
+ work[i__] += d__1 * d__1;
+ }
+ work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__];
+
+/* L140: */
+ }
+
+ if (j > 1) {
+ maxlocval = (*n << 1) - (*n + j) + 1;
+ itemp = dmaxloc_(&work[*n + j], &maxlocval);
+ pvt = itemp + j - 1;
+ ajj = work[*n + pvt];
+ if (ajj <= dstop || disnan_(&ajj)) {
+ a[j + j * a_dim1] = ajj;
+ goto L160;
+ }
+ }
+
+ if (j != pvt) {
+
+/* Pivot OK, so can now swap pivot rows and columns */
+
+ a[pvt + pvt * a_dim1] = a[j + j * a_dim1];
+ i__2 = j - 1;
+ dswap_(&i__2, &a[j + a_dim1], lda, &a[pvt + a_dim1], lda);
+ if (pvt < *n) {
+ i__2 = *n - pvt;
+ dswap_(&i__2, &a[pvt + 1 + j * a_dim1], &c__1, &a[pvt + 1
+ + pvt * a_dim1], &c__1);
+ }
+ i__2 = pvt - j - 1;
+ dswap_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &a[pvt + (j + 1)
+ * a_dim1], lda);
+
+/* Swap dot products and PIV */
+
+ dtemp = work[j];
+ work[j] = work[pvt];
+ work[pvt] = dtemp;
+ itemp = piv[pvt];
+ piv[pvt] = piv[j];
+ piv[j] = itemp;
+ }
+
+ ajj = sqrt(ajj);
+ a[j + j * a_dim1] = ajj;
+
+/* Compute elements J+1:N of column J */
+
+ if (j < *n) {
+ i__2 = *n - j;
+ i__3 = j - 1;
+ dgemv_("No Trans", &i__2, &i__3, &c_b16, &a[j + 1 + a_dim1],
+ lda, &a[j + a_dim1], lda, &c_b18, &a[j + 1 + j *
+ a_dim1], &c__1);
+ i__2 = *n - j;
+ d__1 = 1. / ajj;
+ dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1);
+ }
+
+/* L150: */
+ }
+
+ }
+
+/* Ran to completion, A has full rank */
+
+ *rank = *n;
+
+ goto L170;
+L160:
+
+/* Rank is number of steps completed. Set INFO = 1 to signal */
+/* that the factorization cannot be used to solve a system. */
+
+ *rank = j - 1;
+ *info = 1;
+
+L170:
+ return 0;
+
+/* End of DPSTF2 */
+
+} /* dpstf2_ */
diff --git a/SRC/dpstrf.c b/SRC/dpstrf.c
new file mode 100644
index 0000000..909c525
--- /dev/null
+++ b/SRC/dpstrf.c
@@ -0,0 +1,471 @@
+/* dpstrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b22 = -1.;
+static doublereal c_b24 = 1.;
+
+/* Subroutine */ int dpstrf_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *piv, integer *rank, doublereal *tol, doublereal *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, maxlocvar, jb, nb;
+ doublereal ajj;
+ integer pvt;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ doublereal dtemp;
+ integer itemp;
+ extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ doublereal dstop;
+ logical upper;
+ extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *), dpstf2_(char *, integer *,
+ doublereal *, integer *, integer *, integer *, doublereal *,
+ doublereal *, integer *);
+ extern doublereal dlamch_(char *);
+ extern logical disnan_(doublereal *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern integer dmaxloc_(doublereal *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPSTRF computes the Cholesky factorization with complete */
+/* pivoting of a real symmetric positive semidefinite matrix A. */
+
+/* The factorization has the form */
+/* P' * A * P = U' * U , if UPLO = 'U', */
+/* P' * A * P = L * L', if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular, and */
+/* P is stored as vector PIV. */
+
+/* This algorithm does not attempt to check that A is positive */
+/* semidefinite. This version of the algorithm calls level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n by n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n by n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization as above. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* PIV (output) INTEGER array, dimension (N) */
+/* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. */
+
+/* RANK (output) INTEGER */
+/* The rank of A given by the number of steps the algorithm */
+/* completed. */
+
+/* TOL (input) DOUBLE PRECISION */
+/* User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) ) */
+/* will be used. The algorithm terminates at the (K-1)st step */
+/* if the pivot <= TOL. */
+
+/* WORK DOUBLE PRECISION array, dimension (2*N) */
+/* Work space. */
+
+/* INFO (output) INTEGER */
+/* < 0: If INFO = -K, the K-th argument had an illegal value, */
+/* = 0: algorithm completed successfully, and */
+/* > 0: the matrix A is either rank deficient with computed rank */
+/* as returned in RANK, or is indefinite. See Section 7 of */
+/* LAPACK Working Note #161 for further information. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --work;
+ --piv;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPSTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get block size */
+
+ nb = ilaenv_(&c__1, "DPOTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code */
+
+ dpstf2_(uplo, n, &a[a_dim1 + 1], lda, &piv[1], rank, tol, &work[1],
+ info);
+ goto L200;
+
+ } else {
+
+/* Initialize PIV */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ piv[i__] = i__;
+/* L100: */
+ }
+
+/* Compute stopping value */
+
+ pvt = 1;
+ ajj = a[pvt + pvt * a_dim1];
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ if (a[i__ + i__ * a_dim1] > ajj) {
+ pvt = i__;
+ ajj = a[pvt + pvt * a_dim1];
+ }
+ }
+ if (ajj == 0. || disnan_(&ajj)) {
+ *rank = 0;
+ *info = 1;
+ goto L200;
+ }
+
+/* Compute stopping value if not supplied */
+
+ if (*tol < 0.) {
+ dstop = *n * dlamch_("Epsilon") * ajj;
+ } else {
+ dstop = *tol;
+ }
+
+
+ if (upper) {
+
+/* Compute the Cholesky factorization P' * A * P = U' * U */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+
+/* Account for last block not being NB wide */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - k + 1;
+ jb = min(i__3,i__4);
+
+/* Set relevant part of first half of WORK to zero, */
+/* holds dot products */
+
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ work[i__] = 0.;
+/* L110: */
+ }
+
+ i__3 = k + jb - 1;
+ for (j = k; j <= i__3; ++j) {
+
+/* Find pivot, test for exit, else swap rows and columns */
+/* Update dot products, compute possible pivots which are */
+/* stored in the second half of WORK */
+
+ i__4 = *n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+
+ if (j > k) {
+/* Computing 2nd power */
+ d__1 = a[j - 1 + i__ * a_dim1];
+ work[i__] += d__1 * d__1;
+ }
+ work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__];
+
+/* L120: */
+ }
+
+ if (j > 1) {
+ maxlocvar = (*n << 1) - (*n + j) + 1;
+ itemp = dmaxloc_(&work[*n + j], &maxlocvar);
+ pvt = itemp + j - 1;
+ ajj = work[*n + pvt];
+ if (ajj <= dstop || disnan_(&ajj)) {
+ a[j + j * a_dim1] = ajj;
+ goto L190;
+ }
+ }
+
+ if (j != pvt) {
+
+/* Pivot OK, so can now swap pivot rows and columns */
+
+ a[pvt + pvt * a_dim1] = a[j + j * a_dim1];
+ i__4 = j - 1;
+ dswap_(&i__4, &a[j * a_dim1 + 1], &c__1, &a[pvt *
+ a_dim1 + 1], &c__1);
+ if (pvt < *n) {
+ i__4 = *n - pvt;
+ dswap_(&i__4, &a[j + (pvt + 1) * a_dim1], lda, &a[
+ pvt + (pvt + 1) * a_dim1], lda);
+ }
+ i__4 = pvt - j - 1;
+ dswap_(&i__4, &a[j + (j + 1) * a_dim1], lda, &a[j + 1
+ + pvt * a_dim1], &c__1);
+
+/* Swap dot products and PIV */
+
+ dtemp = work[j];
+ work[j] = work[pvt];
+ work[pvt] = dtemp;
+ itemp = piv[pvt];
+ piv[pvt] = piv[j];
+ piv[j] = itemp;
+ }
+
+ ajj = sqrt(ajj);
+ a[j + j * a_dim1] = ajj;
+
+/* Compute elements J+1:N of row J. */
+
+ if (j < *n) {
+ i__4 = j - k;
+ i__5 = *n - j;
+ dgemv_("Trans", &i__4, &i__5, &c_b22, &a[k + (j + 1) *
+ a_dim1], lda, &a[k + j * a_dim1], &c__1, &
+ c_b24, &a[j + (j + 1) * a_dim1], lda);
+ i__4 = *n - j;
+ d__1 = 1. / ajj;
+ dscal_(&i__4, &d__1, &a[j + (j + 1) * a_dim1], lda);
+ }
+
+/* L130: */
+ }
+
+/* Update trailing matrix, J already incremented */
+
+ if (k + jb <= *n) {
+ i__3 = *n - j + 1;
+ dsyrk_("Upper", "Trans", &i__3, &jb, &c_b22, &a[k + j *
+ a_dim1], lda, &c_b24, &a[j + j * a_dim1], lda);
+ }
+
+/* L140: */
+ }
+
+ } else {
+
+/* Compute the Cholesky factorization P' * A * P = L * L' */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+
+/* Account for last block not being NB wide */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - k + 1;
+ jb = min(i__3,i__4);
+
+/* Set relevant part of first half of WORK to zero, */
+/* holds dot products */
+
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ work[i__] = 0.;
+/* L150: */
+ }
+
+ i__3 = k + jb - 1;
+ for (j = k; j <= i__3; ++j) {
+
+/* Find pivot, test for exit, else swap rows and columns */
+/* Update dot products, compute possible pivots which are */
+/* stored in the second half of WORK */
+
+ i__4 = *n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+
+ if (j > k) {
+/* Computing 2nd power */
+ d__1 = a[i__ + (j - 1) * a_dim1];
+ work[i__] += d__1 * d__1;
+ }
+ work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__];
+
+/* L160: */
+ }
+
+ if (j > 1) {
+ maxlocvar = (*n << 1) - (*n + j) + 1;
+ itemp = dmaxloc_(&work[*n + j], &maxlocvar);
+ pvt = itemp + j - 1;
+ ajj = work[*n + pvt];
+ if (ajj <= dstop || disnan_(&ajj)) {
+ a[j + j * a_dim1] = ajj;
+ goto L190;
+ }
+ }
+
+ if (j != pvt) {
+
+/* Pivot OK, so can now swap pivot rows and columns */
+
+ a[pvt + pvt * a_dim1] = a[j + j * a_dim1];
+ i__4 = j - 1;
+ dswap_(&i__4, &a[j + a_dim1], lda, &a[pvt + a_dim1],
+ lda);
+ if (pvt < *n) {
+ i__4 = *n - pvt;
+ dswap_(&i__4, &a[pvt + 1 + j * a_dim1], &c__1, &a[
+ pvt + 1 + pvt * a_dim1], &c__1);
+ }
+ i__4 = pvt - j - 1;
+ dswap_(&i__4, &a[j + 1 + j * a_dim1], &c__1, &a[pvt +
+ (j + 1) * a_dim1], lda);
+
+/* Swap dot products and PIV */
+
+ dtemp = work[j];
+ work[j] = work[pvt];
+ work[pvt] = dtemp;
+ itemp = piv[pvt];
+ piv[pvt] = piv[j];
+ piv[j] = itemp;
+ }
+
+ ajj = sqrt(ajj);
+ a[j + j * a_dim1] = ajj;
+
+/* Compute elements J+1:N of column J. */
+
+ if (j < *n) {
+ i__4 = *n - j;
+ i__5 = j - k;
+ dgemv_("No Trans", &i__4, &i__5, &c_b22, &a[j + 1 + k
+ * a_dim1], lda, &a[j + k * a_dim1], lda, &
+ c_b24, &a[j + 1 + j * a_dim1], &c__1);
+ i__4 = *n - j;
+ d__1 = 1. / ajj;
+ dscal_(&i__4, &d__1, &a[j + 1 + j * a_dim1], &c__1);
+ }
+
+/* L170: */
+ }
+
+/* Update trailing matrix, J already incremented */
+
+ if (k + jb <= *n) {
+ i__3 = *n - j + 1;
+ dsyrk_("Lower", "No Trans", &i__3, &jb, &c_b22, &a[j + k *
+ a_dim1], lda, &c_b24, &a[j + j * a_dim1], lda);
+ }
+
+/* L180: */
+ }
+
+ }
+ }
+
+/* Ran to completion, A has full rank */
+
+ *rank = *n;
+
+ goto L200;
+L190:
+
+/* Rank is the number of steps completed. Set INFO = 1 to signal */
+/* that the factorization cannot be used to solve a system. */
+
+ *rank = j - 1;
+ *info = 1;
+
+L200:
+ return 0;
+
+/* End of DPSTRF */
+
+} /* dpstrf_ */
diff --git a/SRC/dptcon.c b/SRC/dptcon.c
new file mode 100644
index 0000000..a2ffc13
--- /dev/null
+++ b/SRC/dptcon.c
@@ -0,0 +1,184 @@
+/* dptcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dptcon_(integer *n, doublereal *d__, doublereal *e,
+ doublereal *anorm, doublereal *rcond, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, ix;
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal ainvnm;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPTCON computes the reciprocal of the condition number (in the */
+/* 1-norm) of a real symmetric positive definite tridiagonal matrix */
+/* using the factorization A = L*D*L**T or A = U**T*D*U computed by */
+/* DPTTRF. */
+
+/* Norm(inv(A)) is computed by a direct method, and the reciprocal of */
+/* the condition number is computed as */
+/* RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the diagonal matrix D from the */
+/* factorization of A, as computed by DPTTRF. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) off-diagonal elements of the unit bidiagonal factor */
+/* U or L from the factorization of A, as computed by DPTTRF. */
+
+/* ANORM (input) DOUBLE PRECISION */
+/* The 1-norm of the original matrix A. */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the */
+/* 1-norm of inv(A) computed in this routine. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The method used is described in Nicholas J. Higham, "Efficient */
+/* Algorithms for Computing the Condition Number of a Tridiagonal */
+/* Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ --work;
+ --e;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*anorm < 0.) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPTCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.;
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ } else if (*anorm == 0.) {
+ return 0;
+ }
+
+/* Check that D(1:N) is positive. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (d__[i__] <= 0.) {
+ return 0;
+ }
+/* L10: */
+ }
+
+/* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by */
+
+/* m(i,j) = abs(A(i,j)), i = j, */
+/* m(i,j) = -abs(A(i,j)), i .ne. j, */
+
+/* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'. */
+
+/* Solve M(L) * x = e. */
+
+ work[1] = 1.;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ work[i__] = work[i__ - 1] * (d__1 = e[i__ - 1], abs(d__1)) + 1.;
+/* L20: */
+ }
+
+/* Solve D * M(L)' * x = b. */
+
+ work[*n] /= d__[*n];
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ work[i__] = work[i__] / d__[i__] + work[i__ + 1] * (d__1 = e[i__],
+ abs(d__1));
+/* L30: */
+ }
+
+/* Compute AINVNM = max(x(i)), 1<=i<=n. */
+
+ ix = idamax_(n, &work[1], &c__1);
+ ainvnm = (d__1 = work[ix], abs(d__1));
+
+/* Compute the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / ainvnm / *anorm;
+ }
+
+ return 0;
+
+/* End of DPTCON */
+
+} /* dptcon_ */
diff --git a/SRC/dpteqr.c b/SRC/dpteqr.c
new file mode 100644
index 0000000..1da0bea
--- /dev/null
+++ b/SRC/dpteqr.c
@@ -0,0 +1,244 @@
+/* dpteqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b7 = 0.;
+static doublereal c_b8 = 1.;
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int dpteqr_(char *compz, integer *n, doublereal *d__,
+ doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal c__[1] /* was [1][1] */;
+ integer i__;
+ doublereal vt[1] /* was [1][1] */;
+ integer nru;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *), dbdsqr_(char *, integer *,
+ integer *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *);
+ integer icompz;
+ extern /* Subroutine */ int dpttrf_(integer *, doublereal *, doublereal *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPTEQR computes all eigenvalues and, optionally, eigenvectors of a */
+/* symmetric positive definite tridiagonal matrix by first factoring the */
+/* matrix using DPTTRF, and then calling DBDSQR to compute the singular */
+/* values of the bidiagonal factor. */
+
+/* This routine computes the eigenvalues of the positive definite */
+/* tridiagonal matrix to high relative accuracy. This means that if the */
+/* eigenvalues range over many orders of magnitude in size, then the */
+/* small eigenvalues and corresponding eigenvectors will be computed */
+/* more accurately than, for example, with the standard QR method. */
+
+/* The eigenvectors of a full or band symmetric positive definite matrix */
+/* can also be found if DSYTRD, DSPTRD, or DSBTRD has been used to */
+/* reduce this matrix to tridiagonal form. (The reduction to tridiagonal */
+/* form, however, may preclude the possibility of obtaining high */
+/* relative accuracy in the small eigenvalues of the original matrix, if */
+/* these eigenvalues range over many orders of magnitude.) */
+
+/* Arguments */
+/* ========= */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only. */
+/* = 'V': Compute eigenvectors of original symmetric */
+/* matrix also. Array Z contains the orthogonal */
+/* matrix used to reduce the original matrix to */
+/* tridiagonal form. */
+/* = 'I': Compute eigenvectors of tridiagonal matrix also. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the n diagonal elements of the tridiagonal */
+/* matrix. */
+/* On normal exit, D contains the eigenvalues, in descending */
+/* order. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix. */
+/* On exit, E has been destroyed. */
+
+/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) */
+/* On entry, if COMPZ = 'V', the orthogonal matrix used in the */
+/* reduction to tridiagonal form. */
+/* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the */
+/* original symmetric matrix; */
+/* if COMPZ = 'I', the orthonormal eigenvectors of the */
+/* tridiagonal matrix. */
+/* If INFO > 0 on exit, Z contains the eigenvectors associated */
+/* with only the stored eigenvalues. */
+/* If COMPZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* COMPZ = 'V' or 'I', LDZ >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, and i is: */
+/* <= N the Cholesky factorization of the matrix could */
+/* not be performed because the i-th principal minor */
+/* was not positive definite. */
+/* > N the SVD algorithm failed to converge; */
+/* if INFO = N+i, i off-diagonal elements of the */
+/* bidiagonal factor did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+ if (lsame_(compz, "N")) {
+ icompz = 0;
+ } else if (lsame_(compz, "V")) {
+ icompz = 1;
+ } else if (lsame_(compz, "I")) {
+ icompz = 2;
+ } else {
+ icompz = -1;
+ }
+ if (icompz < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPTEQR", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (icompz > 0) {
+ z__[z_dim1 + 1] = 1.;
+ }
+ return 0;
+ }
+ if (icompz == 2) {
+ dlaset_("Full", n, n, &c_b7, &c_b8, &z__[z_offset], ldz);
+ }
+
+/* Call DPTTRF to factor the matrix. */
+
+ dpttrf_(n, &d__[1], &e[1], info);
+ if (*info != 0) {
+ return 0;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = sqrt(d__[i__]);
+/* L10: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ e[i__] *= d__[i__];
+/* L20: */
+ }
+
+/* Call DBDSQR to compute the singular values/vectors of the */
+/* bidiagonal factor. */
+
+ if (icompz > 0) {
+ nru = *n;
+ } else {
+ nru = 0;
+ }
+ dbdsqr_("Lower", n, &c__0, &nru, &c__0, &d__[1], &e[1], vt, &c__1, &z__[
+ z_offset], ldz, c__, &c__1, &work[1], info);
+
+/* Square the singular values. */
+
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] *= d__[i__];
+/* L30: */
+ }
+ } else {
+ *info = *n + *info;
+ }
+
+ return 0;
+
+/* End of DPTEQR */
+
+} /* dpteqr_ */
diff --git a/SRC/dptrfs.c b/SRC/dptrfs.c
new file mode 100644
index 0000000..2a0491c
--- /dev/null
+++ b/SRC/dptrfs.c
@@ -0,0 +1,365 @@
+/* dptrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b11 = 1.;
+
+/* Subroutine */ int dptrfs_(integer *n, integer *nrhs, doublereal *d__,
+ doublereal *e, doublereal *df, doublereal *ef, doublereal *b, integer
+ *ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr,
+ doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal s, bi, cx, dx, ex;
+ integer ix, nz;
+ doublereal eps, safe1, safe2;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *);
+ integer count;
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal lstres;
+ extern /* Subroutine */ int dpttrs_(integer *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPTRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric positive definite */
+/* and tridiagonal, and provides error bounds and backward error */
+/* estimates for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
+
+/* DF (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the diagonal matrix D from the */
+/* factorization computed by DPTTRF. */
+
+/* EF (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the unit bidiagonal factor */
+/* L from the factorization computed by DPTTRF. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by DPTTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --df;
+ --ef;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*ldx < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPTRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = 4;
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X. Also compute */
+/* abs(A)*abs(x) + abs(b) for use in the backward error bound. */
+
+ if (*n == 1) {
+ bi = b[j * b_dim1 + 1];
+ dx = d__[1] * x[j * x_dim1 + 1];
+ work[*n + 1] = bi - dx;
+ work[1] = abs(bi) + abs(dx);
+ } else {
+ bi = b[j * b_dim1 + 1];
+ dx = d__[1] * x[j * x_dim1 + 1];
+ ex = e[1] * x[j * x_dim1 + 2];
+ work[*n + 1] = bi - dx - ex;
+ work[1] = abs(bi) + abs(dx) + abs(ex);
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ bi = b[i__ + j * b_dim1];
+ cx = e[i__ - 1] * x[i__ - 1 + j * x_dim1];
+ dx = d__[i__] * x[i__ + j * x_dim1];
+ ex = e[i__] * x[i__ + 1 + j * x_dim1];
+ work[*n + i__] = bi - cx - dx - ex;
+ work[i__] = abs(bi) + abs(cx) + abs(dx) + abs(ex);
+/* L30: */
+ }
+ bi = b[*n + j * b_dim1];
+ cx = e[*n - 1] * x[*n - 1 + j * x_dim1];
+ dx = d__[*n] * x[*n + j * x_dim1];
+ work[*n + *n] = bi - cx - dx;
+ work[*n] = abs(bi) + abs(cx) + abs(dx);
+ }
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[
+ i__];
+ s = max(d__2,d__3);
+ } else {
+/* Computing MAX */
+ d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1)
+ / (work[i__] + safe1);
+ s = max(d__2,d__3);
+ }
+/* L40: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ dpttrs_(n, &c__1, &df[1], &ef[1], &work[*n + 1], n, info);
+ daxpy_(n, &c_b11, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
+ ;
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L50: */
+ }
+ ix = idamax_(n, &work[1], &c__1);
+ ferr[j] = work[ix];
+
+/* Estimate the norm of inv(A). */
+
+/* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by */
+
+/* m(i,j) = abs(A(i,j)), i = j, */
+/* m(i,j) = -abs(A(i,j)), i .ne. j, */
+
+/* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'. */
+
+/* Solve M(L) * x = e. */
+
+ work[1] = 1.;
+ i__2 = *n;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ work[i__] = work[i__ - 1] * (d__1 = ef[i__ - 1], abs(d__1)) + 1.;
+/* L60: */
+ }
+
+/* Solve D * M(L)' * x = b. */
+
+ work[*n] /= df[*n];
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ work[i__] = work[i__] / df[i__] + work[i__ + 1] * (d__1 = ef[i__],
+ abs(d__1));
+/* L70: */
+ }
+
+/* Compute norm(inv(A)) = max(x(i)), 1<=i<=n. */
+
+ ix = idamax_(n, &work[1], &c__1);
+ ferr[j] *= (d__1 = work[ix], abs(d__1));
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1));
+ lstres = max(d__2,d__3);
+/* L80: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L90: */
+ }
+
+ return 0;
+
+/* End of DPTRFS */
+
+} /* dptrfs_ */
diff --git a/SRC/dptsv.c b/SRC/dptsv.c
new file mode 100644
index 0000000..2c09ce9
--- /dev/null
+++ b/SRC/dptsv.c
@@ -0,0 +1,130 @@
+/* dptsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dptsv_(integer *n, integer *nrhs, doublereal *d__,
+ doublereal *e, doublereal *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int xerbla_(char *, integer *), dpttrf_(
+ integer *, doublereal *, doublereal *, integer *), dpttrs_(
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPTSV computes the solution to a real system of linear equations */
+/* A*X = B, where A is an N-by-N symmetric positive definite tridiagonal */
+/* matrix, and X and B are N-by-NRHS matrices. */
+
+/* A is factored as A = L*D*L**T, and the factored form of A is then */
+/* used to solve the system of equations. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the n diagonal elements of the tridiagonal matrix */
+/* A. On exit, the n diagonal elements of the diagonal matrix */
+/* D from the factorization A = L*D*L**T. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix A. On exit, the (n-1) subdiagonal elements of the */
+/* unit bidiagonal factor L from the L*D*L**T factorization of */
+/* A. (E can also be regarded as the superdiagonal of the unit */
+/* bidiagonal factor U from the U**T*D*U factorization of A.) */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the solution has not been */
+/* computed. The factorization has not been completed */
+/* unless i = N. */
+
+/* ===================================================================== */
+
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*ldb < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPTSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the L*D*L' (or U'*D*U) factorization of A. */
+
+ dpttrf_(n, &d__[1], &e[1], info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ dpttrs_(n, nrhs, &d__[1], &e[1], &b[b_offset], ldb, info);
+ }
+ return 0;
+
+/* End of DPTSV */
+
+} /* dptsv_ */
diff --git a/SRC/dptsvx.c b/SRC/dptsvx.c
new file mode 100644
index 0000000..ba37b18
--- /dev/null
+++ b/SRC/dptsvx.c
@@ -0,0 +1,283 @@
+/* dptsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dptsvx_(char *fact, integer *n, integer *nrhs,
+ doublereal *d__, doublereal *e, doublereal *df, doublereal *ef,
+ doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *
+ rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *
+ info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ extern doublereal dlamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
+ extern /* Subroutine */ int dptcon_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *), dptrfs_(
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *), dpttrf_(
+ integer *, doublereal *, doublereal *, integer *), dpttrs_(
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPTSVX uses the factorization A = L*D*L**T to compute the solution */
+/* to a real system of linear equations A*X = B, where A is an N-by-N */
+/* symmetric positive definite tridiagonal matrix and X and B are */
+/* N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L */
+/* is a unit lower bidiagonal matrix and D is diagonal. The */
+/* factorization can also be regarded as having the form */
+/* A = U**T*D*U. */
+
+/* 2. If the leading i-by-i principal minor is not positive definite, */
+/* then the routine returns with INFO = i. Otherwise, the factored */
+/* form of A is used to estimate the condition number of the matrix */
+/* A. If the reciprocal of the condition number is less than machine */
+/* precision, INFO = N+1 is returned as a warning, but the routine */
+/* still goes on to solve for X and compute error bounds as */
+/* described below. */
+
+/* 3. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 4. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of A has been */
+/* supplied on entry. */
+/* = 'F': On entry, DF and EF contain the factored form of A. */
+/* D, E, DF, and EF will not be modified. */
+/* = 'N': The matrix A will be copied to DF and EF and */
+/* factored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
+
+/* DF (input or output) DOUBLE PRECISION array, dimension (N) */
+/* If FACT = 'F', then DF is an input argument and on entry */
+/* contains the n diagonal elements of the diagonal matrix D */
+/* from the L*D*L**T factorization of A. */
+/* If FACT = 'N', then DF is an output argument and on exit */
+/* contains the n diagonal elements of the diagonal matrix D */
+/* from the L*D*L**T factorization of A. */
+
+/* EF (input or output) DOUBLE PRECISION array, dimension (N-1) */
+/* If FACT = 'F', then EF is an input argument and on entry */
+/* contains the (n-1) subdiagonal elements of the unit */
+/* bidiagonal factor L from the L*D*L**T factorization of A. */
+/* If FACT = 'N', then EF is an output argument and on exit */
+/* contains the (n-1) subdiagonal elements of the unit */
+/* bidiagonal factor L from the L*D*L**T factorization of A. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal condition number of the matrix A. If RCOND */
+/* is less than the machine precision (in particular, if */
+/* RCOND = 0), the matrix is singular to working precision. */
+/* This condition is indicated by a return code of INFO > 0. */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in any */
+/* element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: the leading minor of order i of A is */
+/* not positive definite, so the factorization */
+/* could not be completed, and the solution has not */
+/* been computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --df;
+ --ef;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ if (! nofact && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPTSVX", &i__1);
+ return 0;
+ }
+
+ if (nofact) {
+
+/* Compute the L*D*L' (or U'*D*U) factorization of A. */
+
+ dcopy_(n, &d__[1], &c__1, &df[1], &c__1);
+ if (*n > 1) {
+ i__1 = *n - 1;
+ dcopy_(&i__1, &e[1], &c__1, &ef[1], &c__1);
+ }
+ dpttrf_(n, &df[1], &ef[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = dlanst_("1", n, &d__[1], &e[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ dptcon_(n, &df[1], &ef[1], &anorm, rcond, &work[1], info);
+
+/* Compute the solution vectors X. */
+
+ dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ dpttrs_(n, nrhs, &df[1], &ef[1], &x[x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solutions and */
+/* compute error bounds and backward error estimates for them. */
+
+ dptrfs_(n, nrhs, &d__[1], &e[1], &df[1], &ef[1], &b[b_offset], ldb, &x[
+ x_offset], ldx, &ferr[1], &berr[1], &work[1], info);
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < dlamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of DPTSVX */
+
+} /* dptsvx_ */
diff --git a/SRC/dpttrf.c b/SRC/dpttrf.c
new file mode 100644
index 0000000..070ef34
--- /dev/null
+++ b/SRC/dpttrf.c
@@ -0,0 +1,181 @@
+/* dpttrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dpttrf_(integer *n, doublereal *d__, doublereal *e,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, i4;
+ doublereal ei;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPTTRF computes the L*D*L' factorization of a real symmetric */
+/* positive definite tridiagonal matrix A. The factorization may also */
+/* be regarded as having the form A = U'*D*U. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the n diagonal elements of the tridiagonal matrix */
+/* A. On exit, the n diagonal elements of the diagonal matrix */
+/* D from the L*D*L' factorization of A. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix A. On exit, the (n-1) subdiagonal elements of the */
+/* unit bidiagonal factor L from the L*D*L' factorization of A. */
+/* E can also be regarded as the superdiagonal of the unit */
+/* bidiagonal factor U from the U'*D*U factorization of A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, the leading minor of order k is not */
+/* positive definite; if k < N, the factorization could not */
+/* be completed, while if k = N, the factorization was */
+/* completed, but D(N) <= 0. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --e;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ i__1 = -(*info);
+ xerbla_("DPTTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Compute the L*D*L' (or U'*D*U) factorization of A. */
+
+ i4 = (*n - 1) % 4;
+ i__1 = i4;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (d__[i__] <= 0.) {
+ *info = i__;
+ goto L30;
+ }
+ ei = e[i__];
+ e[i__] = ei / d__[i__];
+ d__[i__ + 1] -= e[i__] * ei;
+/* L10: */
+ }
+
+ i__1 = *n - 4;
+ for (i__ = i4 + 1; i__ <= i__1; i__ += 4) {
+
+/* Drop out of the loop if d(i) <= 0: the matrix is not positive */
+/* definite. */
+
+ if (d__[i__] <= 0.) {
+ *info = i__;
+ goto L30;
+ }
+
+/* Solve for e(i) and d(i+1). */
+
+ ei = e[i__];
+ e[i__] = ei / d__[i__];
+ d__[i__ + 1] -= e[i__] * ei;
+
+ if (d__[i__ + 1] <= 0.) {
+ *info = i__ + 1;
+ goto L30;
+ }
+
+/* Solve for e(i+1) and d(i+2). */
+
+ ei = e[i__ + 1];
+ e[i__ + 1] = ei / d__[i__ + 1];
+ d__[i__ + 2] -= e[i__ + 1] * ei;
+
+ if (d__[i__ + 2] <= 0.) {
+ *info = i__ + 2;
+ goto L30;
+ }
+
+/* Solve for e(i+2) and d(i+3). */
+
+ ei = e[i__ + 2];
+ e[i__ + 2] = ei / d__[i__ + 2];
+ d__[i__ + 3] -= e[i__ + 2] * ei;
+
+ if (d__[i__ + 3] <= 0.) {
+ *info = i__ + 3;
+ goto L30;
+ }
+
+/* Solve for e(i+3) and d(i+4). */
+
+ ei = e[i__ + 3];
+ e[i__ + 3] = ei / d__[i__ + 3];
+ d__[i__ + 4] -= e[i__ + 3] * ei;
+/* L20: */
+ }
+
+/* Check d(n) for positive definiteness. */
+
+ if (d__[*n] <= 0.) {
+ *info = *n;
+ }
+
+L30:
+ return 0;
+
+/* End of DPTTRF */
+
+} /* dpttrf_ */
diff --git a/SRC/dpttrs.c b/SRC/dpttrs.c
new file mode 100644
index 0000000..52aaa90
--- /dev/null
+++ b/SRC/dpttrs.c
@@ -0,0 +1,156 @@
+/* dpttrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dpttrs_(integer *n, integer *nrhs, doublereal *d__,
+ doublereal *e, doublereal *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer j, jb, nb;
+ extern /* Subroutine */ int dptts2_(integer *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPTTRS solves a tridiagonal system of the form */
+/* A * X = B */
+/* using the L*D*L' factorization of A computed by DPTTRF. D is a */
+/* diagonal matrix specified in the vector D, L is a unit bidiagonal */
+/* matrix whose subdiagonal is specified in the vector E, and X and B */
+/* are N by NRHS matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the tridiagonal matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the diagonal matrix D from the */
+/* L*D*L' factorization of A. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the unit bidiagonal factor */
+/* L from the L*D*L' factorization of A. E can also be regarded */
+/* as the superdiagonal of the unit bidiagonal factor U from the */
+/* factorization A = U'*D*U. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors B for the system of */
+/* linear equations. */
+/* On exit, the solution vectors, X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*ldb < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DPTTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+/* Determine the number of right-hand sides to solve at a time. */
+
+ if (*nrhs == 1) {
+ nb = 1;
+ } else {
+/* Computing MAX */
+ i__1 = 1, i__2 = ilaenv_(&c__1, "DPTTRS", " ", n, nrhs, &c_n1, &c_n1);
+ nb = max(i__1,i__2);
+ }
+
+ if (nb >= *nrhs) {
+ dptts2_(n, nrhs, &d__[1], &e[1], &b[b_offset], ldb);
+ } else {
+ i__1 = *nrhs;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = *nrhs - j + 1;
+ jb = min(i__3,nb);
+ dptts2_(n, &jb, &d__[1], &e[1], &b[j * b_dim1 + 1], ldb);
+/* L10: */
+ }
+ }
+
+ return 0;
+
+/* End of DPTTRS */
+
+} /* dpttrs_ */
diff --git a/SRC/dptts2.c b/SRC/dptts2.c
new file mode 100644
index 0000000..fc246bb
--- /dev/null
+++ b/SRC/dptts2.c
@@ -0,0 +1,131 @@
+/* dptts2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dptts2_(integer *n, integer *nrhs, doublereal *d__,
+ doublereal *e, doublereal *b, integer *ldb)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, j;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPTTS2 solves a tridiagonal system of the form */
+/* A * X = B */
+/* using the L*D*L' factorization of A computed by DPTTRF. D is a */
+/* diagonal matrix specified in the vector D, L is a unit bidiagonal */
+/* matrix whose subdiagonal is specified in the vector E, and X and B */
+/* are N by NRHS matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the tridiagonal matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the diagonal matrix D from the */
+/* L*D*L' factorization of A. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the unit bidiagonal factor */
+/* L from the L*D*L' factorization of A. E can also be regarded */
+/* as the superdiagonal of the unit bidiagonal factor U from the */
+/* factorization A = U'*D*U. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors B for the system of */
+/* linear equations. */
+/* On exit, the solution vectors, X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*n <= 1) {
+ if (*n == 1) {
+ d__1 = 1. / d__[1];
+ dscal_(nrhs, &d__1, &b[b_offset], ldb);
+ }
+ return 0;
+ }
+
+/* Solve A * X = B using the factorization A = L*D*L', */
+/* overwriting each right hand side vector with its solution. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve L * x = b. */
+
+ i__2 = *n;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] -= b[i__ - 1 + j * b_dim1] * e[i__ - 1];
+/* L10: */
+ }
+
+/* Solve D * L' * x = b. */
+
+ b[*n + j * b_dim1] /= d__[*n];
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ b[i__ + j * b_dim1] = b[i__ + j * b_dim1] / d__[i__] - b[i__ + 1
+ + j * b_dim1] * e[i__];
+/* L20: */
+ }
+/* L30: */
+ }
+
+ return 0;
+
+/* End of DPTTS2 */
+
+} /* dptts2_ */
diff --git a/SRC/drscl.c b/SRC/drscl.c
new file mode 100644
index 0000000..03b09ce
--- /dev/null
+++ b/SRC/drscl.c
@@ -0,0 +1,134 @@
+/* drscl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int drscl_(integer *n, doublereal *sa, doublereal *sx,
+ integer *incx)
+{
+ doublereal mul, cden;
+ logical done;
+ doublereal cnum, cden1, cnum1;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *), dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ doublereal bignum, smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DRSCL multiplies an n-element real vector x by the real scalar 1/a. */
+/* This is done without overflow or underflow as long as */
+/* the final result x/a does not overflow or underflow. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of components of the vector x. */
+
+/* SA (input) DOUBLE PRECISION */
+/* The scalar a which is used to divide each component of x. */
+/* SA must be >= 0, or the subroutine will divide by zero. */
+
+/* SX (input/output) DOUBLE PRECISION array, dimension */
+/* (1+(N-1)*abs(INCX)) */
+/* The n-element vector x. */
+
+/* INCX (input) INTEGER */
+/* The increment between successive values of the vector SX. */
+/* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --sx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Initialize the denominator to SA and the numerator to 1. */
+
+ cden = *sa;
+ cnum = 1.;
+
+L10:
+ cden1 = cden * smlnum;
+ cnum1 = cnum / bignum;
+ if (abs(cden1) > abs(cnum) && cnum != 0.) {
+
+/* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. */
+
+ mul = smlnum;
+ done = FALSE_;
+ cden = cden1;
+ } else if (abs(cnum1) > abs(cden)) {
+
+/* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. */
+
+ mul = bignum;
+ done = FALSE_;
+ cnum = cnum1;
+ } else {
+
+/* Multiply X by CNUM / CDEN and return. */
+
+ mul = cnum / cden;
+ done = TRUE_;
+ }
+
+/* Scale the vector X by MUL */
+
+ dscal_(n, &mul, &sx[1], incx);
+
+ if (! done) {
+ goto L10;
+ }
+
+ return 0;
+
+/* End of DRSCL */
+
+} /* drscl_ */
diff --git a/SRC/dsbev.c b/SRC/dsbev.c
new file mode 100644
index 0000000..2d1efc5
--- /dev/null
+++ b/SRC/dsbev.c
@@ -0,0 +1,268 @@
+/* dsbev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b11 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dsbev_(char *jobz, char *uplo, integer *n, integer *kd,
+ doublereal *ab, integer *ldab, doublereal *w, doublereal *z__,
+ integer *ldz, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, z_dim1, z_offset, i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal eps;
+ integer inde;
+ doublereal anrm;
+ integer imax;
+ doublereal rmin, rmax;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical lower, wantz;
+ extern doublereal dlamch_(char *);
+ integer iscale;
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ extern doublereal dlansb_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dsbtrd_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *), dsterf_(
+ integer *, doublereal *, doublereal *, integer *);
+ integer indwrk;
+ extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *);
+ doublereal smlnum;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSBEV computes all the eigenvalues and, optionally, eigenvectors of */
+/* a real symmetric band matrix A. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, AB is overwritten by values generated during the */
+/* reduction to tridiagonal form. If UPLO = 'U', the first */
+/* superdiagonal and the diagonal of the tridiagonal matrix T */
+/* are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */
+/* the diagonal and first subdiagonal of T are returned in the */
+/* first two rows of AB. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD + 1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
+/* eigenvectors of the matrix A, with the i-th column of Z */
+/* holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,3*N-2)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of an intermediate tridiagonal */
+/* form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ lower = lsame_(uplo, "L");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kd < 0) {
+ *info = -4;
+ } else if (*ldab < *kd + 1) {
+ *info = -6;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -9;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSBEV ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (lower) {
+ w[1] = ab[ab_dim1 + 1];
+ } else {
+ w[1] = ab[*kd + 1 + ab_dim1];
+ }
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = dlansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1]);
+ iscale = 0;
+ if (anrm > 0. && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ if (lower) {
+ dlascl_("B", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ } else {
+ dlascl_("Q", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ }
+ }
+
+/* Call DSBTRD to reduce symmetric band matrix to tridiagonal form. */
+
+ inde = 1;
+ indwrk = inde + *n;
+ dsbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[
+ z_offset], ldz, &work[indwrk], &iinfo);
+
+/* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEQR. */
+
+ if (! wantz) {
+ dsterf_(n, &w[1], &work[inde], info);
+ } else {
+ dsteqr_(jobz, n, &w[1], &work[inde], &z__[z_offset], ldz, &work[
+ indwrk], info);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *n;
+ } else {
+ imax = *info - 1;
+ }
+ d__1 = 1. / sigma;
+ dscal_(&imax, &d__1, &w[1], &c__1);
+ }
+
+ return 0;
+
+/* End of DSBEV */
+
+} /* dsbev_ */
diff --git a/SRC/dsbevd.c b/SRC/dsbevd.c
new file mode 100644
index 0000000..e2717d0
--- /dev/null
+++ b/SRC/dsbevd.c
@@ -0,0 +1,338 @@
+/* dsbevd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b11 = 1.;
+static doublereal c_b18 = 0.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dsbevd_(char *jobz, char *uplo, integer *n, integer *kd,
+ doublereal *ab, integer *ldab, doublereal *w, doublereal *z__,
+ integer *ldz, doublereal *work, integer *lwork, integer *iwork,
+ integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, z_dim1, z_offset, i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal eps;
+ integer inde;
+ doublereal anrm, rmin, rmax;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *), dgemm_(char *, char *, integer *, integer *, integer *
+, doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo, lwmin;
+ logical lower, wantz;
+ integer indwk2, llwrk2;
+ extern doublereal dlamch_(char *);
+ integer iscale;
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ extern doublereal dlansb_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dstedc_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *, integer *), dlacpy_(char *, integer
+ *, integer *, doublereal *, integer *, doublereal *, integer *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dsbtrd_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *), dsterf_(
+ integer *, doublereal *, doublereal *, integer *);
+ integer indwrk, liwmin;
+ doublereal smlnum;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSBEVD computes all the eigenvalues and, optionally, eigenvectors of */
+/* a real symmetric band matrix A. If eigenvectors are desired, it uses */
+/* a divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, AB is overwritten by values generated during the */
+/* reduction to tridiagonal form. If UPLO = 'U', the first */
+/* superdiagonal and the diagonal of the tridiagonal matrix T */
+/* are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */
+/* the diagonal and first subdiagonal of T are returned in the */
+/* first two rows of AB. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD + 1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
+/* eigenvectors of the matrix A, with the i-th column of Z */
+/* holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, */
+/* dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* IF N <= 1, LWORK must be at least 1. */
+/* If JOBZ = 'N' and N > 2, LWORK must be at least 2*N. */
+/* If JOBZ = 'V' and N > 2, LWORK must be at least */
+/* ( 1 + 5*N + 2*N**2 ). */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK and IWORK */
+/* arrays, returns these values as the first entries of the WORK */
+/* and IWORK arrays, and no error message related to LWORK or */
+/* LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array LIWORK. */
+/* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. */
+/* If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK and IWORK arrays, and no error message related to */
+/* LWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of an intermediate tridiagonal */
+/* form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ lower = lsame_(uplo, "L");
+ lquery = *lwork == -1 || *liwork == -1;
+
+ *info = 0;
+ if (*n <= 1) {
+ liwmin = 1;
+ lwmin = 1;
+ } else {
+ if (wantz) {
+ liwmin = *n * 5 + 3;
+/* Computing 2nd power */
+ i__1 = *n;
+ lwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
+ } else {
+ liwmin = 1;
+ lwmin = *n << 1;
+ }
+ }
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kd < 0) {
+ *info = -4;
+ } else if (*ldab < *kd + 1) {
+ *info = -6;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -9;
+ }
+
+ if (*info == 0) {
+ work[1] = (doublereal) lwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -11;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSBEVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ w[1] = ab[ab_dim1 + 1];
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = dlansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1]);
+ iscale = 0;
+ if (anrm > 0. && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ if (lower) {
+ dlascl_("B", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ } else {
+ dlascl_("Q", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ }
+ }
+
+/* Call DSBTRD to reduce symmetric band matrix to tridiagonal form. */
+
+ inde = 1;
+ indwrk = inde + *n;
+ indwk2 = indwrk + *n * *n;
+ llwrk2 = *lwork - indwk2 + 1;
+ dsbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[
+ z_offset], ldz, &work[indwrk], &iinfo);
+
+/* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEDC. */
+
+ if (! wantz) {
+ dsterf_(n, &w[1], &work[inde], info);
+ } else {
+ dstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], &
+ llwrk2, &iwork[1], liwork, info);
+ dgemm_("N", "N", n, n, n, &c_b11, &z__[z_offset], ldz, &work[indwrk],
+ n, &c_b18, &work[indwk2], n);
+ dlacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ d__1 = 1. / sigma;
+ dscal_(n, &d__1, &w[1], &c__1);
+ }
+
+ work[1] = (doublereal) lwmin;
+ iwork[1] = liwmin;
+ return 0;
+
+/* End of DSBEVD */
+
+} /* dsbevd_ */
diff --git a/SRC/dsbevx.c b/SRC/dsbevx.c
new file mode 100644
index 0000000..29916a0
--- /dev/null
+++ b/SRC/dsbevx.c
@@ -0,0 +1,520 @@
+/* dsbevx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b14 = 1.;
+static integer c__1 = 1;
+static doublereal c_b34 = 0.;
+
+/* Subroutine */ int dsbevx_(char *jobz, char *range, char *uplo, integer *n,
+ integer *kd, doublereal *ab, integer *ldab, doublereal *q, integer *
+ ldq, doublereal *vl, doublereal *vu, integer *il, integer *iu,
+ doublereal *abstol, integer *m, doublereal *w, doublereal *z__,
+ integer *ldz, doublereal *work, integer *iwork, integer *ifail,
+ integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, q_dim1, q_offset, z_dim1, z_offset, i__1,
+ i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, jj;
+ doublereal eps, vll, vuu, tmp1;
+ integer indd, inde;
+ doublereal anrm;
+ integer imax;
+ doublereal rmin, rmax;
+ logical test;
+ integer itmp1, indee;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ integer iinfo;
+ char order[1];
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dswap_(integer *, doublereal *, integer
+ *, doublereal *, integer *);
+ logical lower, wantz;
+ extern doublereal dlamch_(char *);
+ logical alleig, indeig;
+ integer iscale, indibl;
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ extern doublereal dlansb_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *);
+ logical valeig;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal abstll, bignum;
+ extern /* Subroutine */ int dsbtrd_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *);
+ integer indisp;
+ extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, integer *),
+ dsterf_(integer *, doublereal *, doublereal *, integer *);
+ integer indiwo;
+ extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal
+ *, doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, integer *);
+ integer indwrk;
+ extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *);
+ integer nsplit;
+ doublereal smlnum;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSBEVX computes selected eigenvalues and, optionally, eigenvectors */
+/* of a real symmetric band matrix A. Eigenvalues and eigenvectors can */
+/* be selected by specifying either a range of values or a range of */
+/* indices for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found; */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found; */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, AB is overwritten by values generated during the */
+/* reduction to tridiagonal form. If UPLO = 'U', the first */
+/* superdiagonal and the diagonal of the tridiagonal matrix T */
+/* are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */
+/* the diagonal and first subdiagonal of T are returned in the */
+/* first two rows of AB. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD + 1. */
+
+/* Q (output) DOUBLE PRECISION array, dimension (LDQ, N) */
+/* If JOBZ = 'V', the N-by-N orthogonal matrix used in the */
+/* reduction to tridiagonal form. */
+/* If JOBZ = 'N', the array Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. If JOBZ = 'V', then */
+/* LDQ >= max(1,N). */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) DOUBLE PRECISION */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing AB to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*DLAMCH('S'). */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices */
+/* with Guaranteed High Relative Accuracy," by Demmel and */
+/* Kahan, LAPACK Working Note #3. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* The first M elements contain the selected eigenvalues in */
+/* ascending order. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If an eigenvector fails to converge, then that column of Z */
+/* contains the latest approximation to the eigenvector, and the */
+/* index of the eigenvector is returned in IFAIL. */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (7*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, then i eigenvectors failed to converge. */
+/* Their indices are stored in array IFAIL. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+ lower = lsame_(uplo, "L");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*kd < 0) {
+ *info = -5;
+ } else if (*ldab < *kd + 1) {
+ *info = -7;
+ } else if (wantz && *ldq < max(1,*n)) {
+ *info = -9;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -11;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -12;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -13;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -18;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSBEVX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ *m = 1;
+ if (lower) {
+ tmp1 = ab[ab_dim1 + 1];
+ } else {
+ tmp1 = ab[*kd + 1 + ab_dim1];
+ }
+ if (valeig) {
+ if (! (*vl < tmp1 && *vu >= tmp1)) {
+ *m = 0;
+ }
+ }
+ if (*m == 1) {
+ w[1] = tmp1;
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.;
+ }
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
+ rmax = min(d__1,d__2);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ abstll = *abstol;
+ if (valeig) {
+ vll = *vl;
+ vuu = *vu;
+ } else {
+ vll = 0.;
+ vuu = 0.;
+ }
+ anrm = dlansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1]);
+ if (anrm > 0. && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ if (lower) {
+ dlascl_("B", kd, kd, &c_b14, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ } else {
+ dlascl_("Q", kd, kd, &c_b14, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ }
+ if (*abstol > 0.) {
+ abstll = *abstol * sigma;
+ }
+ if (valeig) {
+ vll = *vl * sigma;
+ vuu = *vu * sigma;
+ }
+ }
+
+/* Call DSBTRD to reduce symmetric band matrix to tridiagonal form. */
+
+ indd = 1;
+ inde = indd + *n;
+ indwrk = inde + *n;
+ dsbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &work[indd], &work[inde],
+ &q[q_offset], ldq, &work[indwrk], &iinfo);
+
+/* If all eigenvalues are desired and ABSTOL is less than or equal */
+/* to zero, then call DSTERF or SSTEQR. If this fails for some */
+/* eigenvalue, then try DSTEBZ. */
+
+ test = FALSE_;
+ if (indeig) {
+ if (*il == 1 && *iu == *n) {
+ test = TRUE_;
+ }
+ }
+ if ((alleig || test) && *abstol <= 0.) {
+ dcopy_(n, &work[indd], &c__1, &w[1], &c__1);
+ indee = indwrk + (*n << 1);
+ if (! wantz) {
+ i__1 = *n - 1;
+ dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
+ dsterf_(n, &w[1], &work[indee], info);
+ } else {
+ dlacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz);
+ i__1 = *n - 1;
+ dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
+ dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[
+ indwrk], info);
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ifail[i__] = 0;
+/* L10: */
+ }
+ }
+ }
+ if (*info == 0) {
+ *m = *n;
+ goto L30;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ indibl = 1;
+ indisp = indibl + *n;
+ indiwo = indisp + *n;
+ dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[
+ inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[
+ indwrk], &iwork[indiwo], info);
+
+ if (wantz) {
+ dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
+ indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &
+ ifail[1], info);
+
+/* Apply orthogonal matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by DSTEIN. */
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1);
+ dgemv_("N", n, n, &c_b14, &q[q_offset], ldq, &work[1], &c__1, &
+ c_b34, &z__[j * z_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+L30:
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *m;
+ } else {
+ imax = *info - 1;
+ }
+ d__1 = 1. / sigma;
+ dscal_(&imax, &d__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L40: */
+ }
+
+ if (i__ != 0) {
+ itmp1 = iwork[indibl + i__ - 1];
+ w[i__] = w[j];
+ iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
+ w[j] = tmp1;
+ iwork[indibl + j - 1] = itmp1;
+ dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ if (*info != 0) {
+ itmp1 = ifail[i__];
+ ifail[i__] = ifail[j];
+ ifail[j] = itmp1;
+ }
+ }
+/* L50: */
+ }
+ }
+
+ return 0;
+
+/* End of DSBEVX */
+
+} /* dsbevx_ */
diff --git a/SRC/dsbgst.c b/SRC/dsbgst.c
new file mode 100644
index 0000000..24c9aad
--- /dev/null
+++ b/SRC/dsbgst.c
@@ -0,0 +1,1755 @@
+/* dsbgst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b8 = 0.;
+static doublereal c_b9 = 1.;
+static integer c__1 = 1;
+static doublereal c_b20 = -1.;
+
+/* Subroutine */ int dsbgst_(char *vect, char *uplo, integer *n, integer *ka,
+ integer *kb, doublereal *ab, integer *ldab, doublereal *bb, integer *
+ ldbb, doublereal *x, integer *ldx, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, bb_dim1, bb_offset, x_dim1, x_offset, i__1,
+ i__2, i__3, i__4;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, j, k, l, m;
+ doublereal t;
+ integer i0, i1, i2, j1, j2;
+ doublereal ra;
+ integer nr, nx, ka1, kb1;
+ doublereal ra1;
+ integer j1t, j2t;
+ doublereal bii;
+ integer kbt, nrt, inca;
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *), drot_(integer *, doublereal *, integer *, doublereal *
+, integer *, doublereal *, doublereal *), dscal_(integer *,
+ doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ logical upper, wantx;
+ extern /* Subroutine */ int dlar2v_(integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *),
+ dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), dlartg_(doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *), xerbla_(
+ char *, integer *), dlargv_(integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *);
+ logical update;
+ extern /* Subroutine */ int dlartv_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSBGST reduces a real symmetric-definite banded generalized */
+/* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y, */
+/* such that C has the same bandwidth as A. */
+
+/* B must have been previously factorized as S**T*S by DPBSTF, using a */
+/* split Cholesky factorization. A is overwritten by C = X**T*A*X, where */
+/* X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the */
+/* bandwidth of A. */
+
+/* Arguments */
+/* ========= */
+
+/* VECT (input) CHARACTER*1 */
+/* = 'N': do not form the transformation matrix X; */
+/* = 'V': form X. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* KA (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */
+
+/* KB (input) INTEGER */
+/* The number of superdiagonals of the matrix B if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0. */
+
+/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first ka+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */
+
+/* On exit, the transformed matrix X**T*A*X, stored in the same */
+/* format as A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KA+1. */
+
+/* BB (input) DOUBLE PRECISION array, dimension (LDBB,N) */
+/* The banded factor S from the split Cholesky factorization of */
+/* B, as returned by DPBSTF, stored in the first KB+1 rows of */
+/* the array. */
+
+/* LDBB (input) INTEGER */
+/* The leading dimension of the array BB. LDBB >= KB+1. */
+
+/* X (output) DOUBLE PRECISION array, dimension (LDX,N) */
+/* If VECT = 'V', the n-by-n matrix X. */
+/* If VECT = 'N', the array X is not referenced. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. */
+/* LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ bb_dim1 = *ldbb;
+ bb_offset = 1 + bb_dim1;
+ bb -= bb_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --work;
+
+ /* Function Body */
+ wantx = lsame_(vect, "V");
+ upper = lsame_(uplo, "U");
+ ka1 = *ka + 1;
+ kb1 = *kb + 1;
+ *info = 0;
+ if (! wantx && ! lsame_(vect, "N")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ka < 0) {
+ *info = -4;
+ } else if (*kb < 0 || *kb > *ka) {
+ *info = -5;
+ } else if (*ldab < *ka + 1) {
+ *info = -7;
+ } else if (*ldbb < *kb + 1) {
+ *info = -9;
+ } else if (*ldx < 1 || wantx && *ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSBGST", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ inca = *ldab * ka1;
+
+/* Initialize X to the unit matrix, if needed */
+
+ if (wantx) {
+ dlaset_("Full", n, n, &c_b8, &c_b9, &x[x_offset], ldx);
+ }
+
+/* Set M to the splitting point m. It must be the same value as is */
+/* used in DPBSTF. The chosen value allows the arrays WORK and RWORK */
+/* to be of dimension (N). */
+
+ m = (*n + *kb) / 2;
+
+/* The routine works in two phases, corresponding to the two halves */
+/* of the split Cholesky factorization of B as S**T*S where */
+
+/* S = ( U ) */
+/* ( M L ) */
+
+/* with U upper triangular of order m, and L lower triangular of */
+/* order n-m. S has the same bandwidth as B. */
+
+/* S is treated as a product of elementary matrices: */
+
+/* S = S(m)*S(m-1)*...*S(2)*S(1)*S(m+1)*S(m+2)*...*S(n-1)*S(n) */
+
+/* where S(i) is determined by the i-th row of S. */
+
+/* In phase 1, the index i takes the values n, n-1, ... , m+1; */
+/* in phase 2, it takes the values 1, 2, ... , m. */
+
+/* For each value of i, the current matrix A is updated by forming */
+/* inv(S(i))**T*A*inv(S(i)). This creates a triangular bulge outside */
+/* the band of A. The bulge is then pushed down toward the bottom of */
+/* A in phase 1, and up toward the top of A in phase 2, by applying */
+/* plane rotations. */
+
+/* There are kb*(kb+1)/2 elements in the bulge, but at most 2*kb-1 */
+/* of them are linearly independent, so annihilating a bulge requires */
+/* only 2*kb-1 plane rotations. The rotations are divided into a 1st */
+/* set of kb-1 rotations, and a 2nd set of kb rotations. */
+
+/* Wherever possible, rotations are generated and applied in vector */
+/* operations of length NR between the indices J1 and J2 (sometimes */
+/* replaced by modified values NRT, J1T or J2T). */
+
+/* The cosines and sines of the rotations are stored in the array */
+/* WORK. The cosines of the 1st set of rotations are stored in */
+/* elements n+2:n+m-kb-1 and the sines of the 1st set in elements */
+/* 2:m-kb-1; the cosines of the 2nd set are stored in elements */
+/* n+m-kb+1:2*n and the sines of the second set in elements m-kb+1:n. */
+
+/* The bulges are not formed explicitly; nonzero elements outside the */
+/* band are created only when they are required for generating new */
+/* rotations; they are stored in the array WORK, in positions where */
+/* they are later overwritten by the sines of the rotations which */
+/* annihilate them. */
+
+/* **************************** Phase 1 ***************************** */
+
+/* The logical structure of this phase is: */
+
+/* UPDATE = .TRUE. */
+/* DO I = N, M + 1, -1 */
+/* use S(i) to update A and create a new bulge */
+/* apply rotations to push all bulges KA positions downward */
+/* END DO */
+/* UPDATE = .FALSE. */
+/* DO I = M + KA + 1, N - 1 */
+/* apply rotations to push all bulges KA positions downward */
+/* END DO */
+
+/* To avoid duplicating code, the two loops are merged. */
+
+ update = TRUE_;
+ i__ = *n + 1;
+L10:
+ if (update) {
+ --i__;
+/* Computing MIN */
+ i__1 = *kb, i__2 = i__ - 1;
+ kbt = min(i__1,i__2);
+ i0 = i__ - 1;
+/* Computing MIN */
+ i__1 = *n, i__2 = i__ + *ka;
+ i1 = min(i__1,i__2);
+ i2 = i__ - kbt + ka1;
+ if (i__ < m + 1) {
+ update = FALSE_;
+ ++i__;
+ i0 = m;
+ if (*ka == 0) {
+ goto L480;
+ }
+ goto L10;
+ }
+ } else {
+ i__ += *ka;
+ if (i__ > *n - 1) {
+ goto L480;
+ }
+ }
+
+ if (upper) {
+
+/* Transform A, working with the upper triangle */
+
+ if (update) {
+
+/* Form inv(S(i))**T * A * inv(S(i)) */
+
+ bii = bb[kb1 + i__ * bb_dim1];
+ i__1 = i1;
+ for (j = i__; j <= i__1; ++j) {
+ ab[i__ - j + ka1 + j * ab_dim1] /= bii;
+/* L20: */
+ }
+/* Computing MAX */
+ i__1 = 1, i__2 = i__ - *ka;
+ i__3 = i__;
+ for (j = max(i__1,i__2); j <= i__3; ++j) {
+ ab[j - i__ + ka1 + i__ * ab_dim1] /= bii;
+/* L30: */
+ }
+ i__3 = i__ - 1;
+ for (k = i__ - kbt; k <= i__3; ++k) {
+ i__1 = k;
+ for (j = i__ - kbt; j <= i__1; ++j) {
+ ab[j - k + ka1 + k * ab_dim1] = ab[j - k + ka1 + k *
+ ab_dim1] - bb[j - i__ + kb1 + i__ * bb_dim1] * ab[
+ k - i__ + ka1 + i__ * ab_dim1] - bb[k - i__ + kb1
+ + i__ * bb_dim1] * ab[j - i__ + ka1 + i__ *
+ ab_dim1] + ab[ka1 + i__ * ab_dim1] * bb[j - i__ +
+ kb1 + i__ * bb_dim1] * bb[k - i__ + kb1 + i__ *
+ bb_dim1];
+/* L40: */
+ }
+/* Computing MAX */
+ i__1 = 1, i__2 = i__ - *ka;
+ i__4 = i__ - kbt - 1;
+ for (j = max(i__1,i__2); j <= i__4; ++j) {
+ ab[j - k + ka1 + k * ab_dim1] -= bb[k - i__ + kb1 + i__ *
+ bb_dim1] * ab[j - i__ + ka1 + i__ * ab_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+ i__3 = i1;
+ for (j = i__; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = j - *ka, i__1 = i__ - kbt;
+ i__2 = i__ - 1;
+ for (k = max(i__4,i__1); k <= i__2; ++k) {
+ ab[k - j + ka1 + j * ab_dim1] -= bb[k - i__ + kb1 + i__ *
+ bb_dim1] * ab[i__ - j + ka1 + j * ab_dim1];
+/* L70: */
+ }
+/* L80: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by inv(S(i)) */
+
+ i__3 = *n - m;
+ d__1 = 1. / bii;
+ dscal_(&i__3, &d__1, &x[m + 1 + i__ * x_dim1], &c__1);
+ if (kbt > 0) {
+ i__3 = *n - m;
+ dger_(&i__3, &kbt, &c_b20, &x[m + 1 + i__ * x_dim1], &
+ c__1, &bb[kb1 - kbt + i__ * bb_dim1], &c__1, &x[m
+ + 1 + (i__ - kbt) * x_dim1], ldx);
+ }
+ }
+
+/* store a(i,i1) in RA1 for use in next loop over K */
+
+ ra1 = ab[i__ - i1 + ka1 + i1 * ab_dim1];
+ }
+
+/* Generate and apply vectors of rotations to chase all the */
+/* existing bulges KA positions down toward the bottom of the */
+/* band */
+
+ i__3 = *kb - 1;
+ for (k = 1; k <= i__3; ++k) {
+ if (update) {
+
+/* Determine the rotations which would annihilate the bulge */
+/* which has in theory just been created */
+
+ if (i__ - k + *ka < *n && i__ - k > 1) {
+
+/* generate rotation to annihilate a(i,i-k+ka+1) */
+
+ dlartg_(&ab[k + 1 + (i__ - k + *ka) * ab_dim1], &ra1, &
+ work[*n + i__ - k + *ka - m], &work[i__ - k + *ka
+ - m], &ra);
+
+/* create nonzero element a(i-k,i-k+ka+1) outside the */
+/* band and store it in WORK(i-k) */
+
+ t = -bb[kb1 - k + i__ * bb_dim1] * ra1;
+ work[i__ - k] = work[*n + i__ - k + *ka - m] * t - work[
+ i__ - k + *ka - m] * ab[(i__ - k + *ka) * ab_dim1
+ + 1];
+ ab[(i__ - k + *ka) * ab_dim1 + 1] = work[i__ - k + *ka -
+ m] * t + work[*n + i__ - k + *ka - m] * ab[(i__ -
+ k + *ka) * ab_dim1 + 1];
+ ra1 = ra;
+ }
+ }
+/* Computing MAX */
+ i__2 = 1, i__4 = k - i0 + 2;
+ j2 = i__ - k - 1 + max(i__2,i__4) * ka1;
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ if (update) {
+/* Computing MAX */
+ i__2 = j2, i__4 = i__ + (*ka << 1) - k + 1;
+ j2t = max(i__2,i__4);
+ } else {
+ j2t = j2;
+ }
+ nrt = (*n - j2t + *ka) / ka1;
+ i__2 = j1;
+ i__4 = ka1;
+ for (j = j2t; i__4 < 0 ? j >= i__2 : j <= i__2; j += i__4) {
+
+/* create nonzero element a(j-ka,j+1) outside the band */
+/* and store it in WORK(j-m) */
+
+ work[j - m] *= ab[(j + 1) * ab_dim1 + 1];
+ ab[(j + 1) * ab_dim1 + 1] = work[*n + j - m] * ab[(j + 1) *
+ ab_dim1 + 1];
+/* L90: */
+ }
+
+/* generate rotations in 1st set to annihilate elements which */
+/* have been created outside the band */
+
+ if (nrt > 0) {
+ dlargv_(&nrt, &ab[j2t * ab_dim1 + 1], &inca, &work[j2t - m], &
+ ka1, &work[*n + j2t - m], &ka1);
+ }
+ if (nr > 0) {
+
+/* apply rotations in 1st set from the right */
+
+ i__4 = *ka - 1;
+ for (l = 1; l <= i__4; ++l) {
+ dlartv_(&nr, &ab[ka1 - l + j2 * ab_dim1], &inca, &ab[*ka
+ - l + (j2 + 1) * ab_dim1], &inca, &work[*n + j2 -
+ m], &work[j2 - m], &ka1);
+/* L100: */
+ }
+
+/* apply rotations in 1st set from both sides to diagonal */
+/* blocks */
+
+ dlar2v_(&nr, &ab[ka1 + j2 * ab_dim1], &ab[ka1 + (j2 + 1) *
+ ab_dim1], &ab[*ka + (j2 + 1) * ab_dim1], &inca, &work[
+ *n + j2 - m], &work[j2 - m], &ka1);
+
+ }
+
+/* start applying rotations in 1st set from the left */
+
+ i__4 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__4; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ dlartv_(&nrt, &ab[l + (j2 + ka1 - l) * ab_dim1], &inca, &
+ ab[l + 1 + (j2 + ka1 - l) * ab_dim1], &inca, &
+ work[*n + j2 - m], &work[j2 - m], &ka1);
+ }
+/* L110: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 1st set */
+
+ i__4 = j1;
+ i__2 = ka1;
+ for (j = j2; i__2 < 0 ? j >= i__4 : j <= i__4; j += i__2) {
+ i__1 = *n - m;
+ drot_(&i__1, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j
+ + 1) * x_dim1], &c__1, &work[*n + j - m], &work[j
+ - m]);
+/* L120: */
+ }
+ }
+/* L130: */
+ }
+
+ if (update) {
+ if (i2 <= *n && kbt > 0) {
+
+/* create nonzero element a(i-kbt,i-kbt+ka+1) outside the */
+/* band and store it in WORK(i-kbt) */
+
+ work[i__ - kbt] = -bb[kb1 - kbt + i__ * bb_dim1] * ra1;
+ }
+ }
+
+ for (k = *kb; k >= 1; --k) {
+ if (update) {
+/* Computing MAX */
+ i__3 = 2, i__2 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__3,i__2) * ka1;
+ } else {
+/* Computing MAX */
+ i__3 = 1, i__2 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__3,i__2) * ka1;
+ }
+
+/* finish applying rotations in 2nd set from the left */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (*n - j2 + *ka + l) / ka1;
+ if (nrt > 0) {
+ dlartv_(&nrt, &ab[l + (j2 - l + 1) * ab_dim1], &inca, &ab[
+ l + 1 + (j2 - l + 1) * ab_dim1], &inca, &work[*n
+ + j2 - *ka], &work[j2 - *ka], &ka1);
+ }
+/* L140: */
+ }
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ i__3 = j2;
+ i__2 = -ka1;
+ for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2) {
+ work[j] = work[j - *ka];
+ work[*n + j] = work[*n + j - *ka];
+/* L150: */
+ }
+ i__2 = j1;
+ i__3 = ka1;
+ for (j = j2; i__3 < 0 ? j >= i__2 : j <= i__2; j += i__3) {
+
+/* create nonzero element a(j-ka,j+1) outside the band */
+/* and store it in WORK(j) */
+
+ work[j] *= ab[(j + 1) * ab_dim1 + 1];
+ ab[(j + 1) * ab_dim1 + 1] = work[*n + j] * ab[(j + 1) *
+ ab_dim1 + 1];
+/* L160: */
+ }
+ if (update) {
+ if (i__ - k < *n - *ka && k <= kbt) {
+ work[i__ - k + *ka] = work[i__ - k];
+ }
+ }
+/* L170: */
+ }
+
+ for (k = *kb; k >= 1; --k) {
+/* Computing MAX */
+ i__3 = 1, i__2 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__3,i__2) * ka1;
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ if (nr > 0) {
+
+/* generate rotations in 2nd set to annihilate elements */
+/* which have been created outside the band */
+
+ dlargv_(&nr, &ab[j2 * ab_dim1 + 1], &inca, &work[j2], &ka1, &
+ work[*n + j2], &ka1);
+
+/* apply rotations in 2nd set from the right */
+
+ i__3 = *ka - 1;
+ for (l = 1; l <= i__3; ++l) {
+ dlartv_(&nr, &ab[ka1 - l + j2 * ab_dim1], &inca, &ab[*ka
+ - l + (j2 + 1) * ab_dim1], &inca, &work[*n + j2],
+ &work[j2], &ka1);
+/* L180: */
+ }
+
+/* apply rotations in 2nd set from both sides to diagonal */
+/* blocks */
+
+ dlar2v_(&nr, &ab[ka1 + j2 * ab_dim1], &ab[ka1 + (j2 + 1) *
+ ab_dim1], &ab[*ka + (j2 + 1) * ab_dim1], &inca, &work[
+ *n + j2], &work[j2], &ka1);
+
+ }
+
+/* start applying rotations in 2nd set from the left */
+
+ i__3 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__3; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ dlartv_(&nrt, &ab[l + (j2 + ka1 - l) * ab_dim1], &inca, &
+ ab[l + 1 + (j2 + ka1 - l) * ab_dim1], &inca, &
+ work[*n + j2], &work[j2], &ka1);
+ }
+/* L190: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 2nd set */
+
+ i__3 = j1;
+ i__2 = ka1;
+ for (j = j2; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2) {
+ i__4 = *n - m;
+ drot_(&i__4, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j
+ + 1) * x_dim1], &c__1, &work[*n + j], &work[j]);
+/* L200: */
+ }
+ }
+/* L210: */
+ }
+
+ i__2 = *kb - 1;
+ for (k = 1; k <= i__2; ++k) {
+/* Computing MAX */
+ i__3 = 1, i__4 = k - i0 + 2;
+ j2 = i__ - k - 1 + max(i__3,i__4) * ka1;
+
+/* finish applying rotations in 1st set from the left */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ dlartv_(&nrt, &ab[l + (j2 + ka1 - l) * ab_dim1], &inca, &
+ ab[l + 1 + (j2 + ka1 - l) * ab_dim1], &inca, &
+ work[*n + j2 - m], &work[j2 - m], &ka1);
+ }
+/* L220: */
+ }
+/* L230: */
+ }
+
+ if (*kb > 1) {
+ i__2 = i__ - *kb + (*ka << 1) + 1;
+ for (j = *n - 1; j >= i__2; --j) {
+ work[*n + j - m] = work[*n + j - *ka - m];
+ work[j - m] = work[j - *ka - m];
+/* L240: */
+ }
+ }
+
+ } else {
+
+/* Transform A, working with the lower triangle */
+
+ if (update) {
+
+/* Form inv(S(i))**T * A * inv(S(i)) */
+
+ bii = bb[i__ * bb_dim1 + 1];
+ i__2 = i1;
+ for (j = i__; j <= i__2; ++j) {
+ ab[j - i__ + 1 + i__ * ab_dim1] /= bii;
+/* L250: */
+ }
+/* Computing MAX */
+ i__2 = 1, i__3 = i__ - *ka;
+ i__4 = i__;
+ for (j = max(i__2,i__3); j <= i__4; ++j) {
+ ab[i__ - j + 1 + j * ab_dim1] /= bii;
+/* L260: */
+ }
+ i__4 = i__ - 1;
+ for (k = i__ - kbt; k <= i__4; ++k) {
+ i__2 = k;
+ for (j = i__ - kbt; j <= i__2; ++j) {
+ ab[k - j + 1 + j * ab_dim1] = ab[k - j + 1 + j * ab_dim1]
+ - bb[i__ - j + 1 + j * bb_dim1] * ab[i__ - k + 1
+ + k * ab_dim1] - bb[i__ - k + 1 + k * bb_dim1] *
+ ab[i__ - j + 1 + j * ab_dim1] + ab[i__ * ab_dim1
+ + 1] * bb[i__ - j + 1 + j * bb_dim1] * bb[i__ - k
+ + 1 + k * bb_dim1];
+/* L270: */
+ }
+/* Computing MAX */
+ i__2 = 1, i__3 = i__ - *ka;
+ i__1 = i__ - kbt - 1;
+ for (j = max(i__2,i__3); j <= i__1; ++j) {
+ ab[k - j + 1 + j * ab_dim1] -= bb[i__ - k + 1 + k *
+ bb_dim1] * ab[i__ - j + 1 + j * ab_dim1];
+/* L280: */
+ }
+/* L290: */
+ }
+ i__4 = i1;
+ for (j = i__; j <= i__4; ++j) {
+/* Computing MAX */
+ i__1 = j - *ka, i__2 = i__ - kbt;
+ i__3 = i__ - 1;
+ for (k = max(i__1,i__2); k <= i__3; ++k) {
+ ab[j - k + 1 + k * ab_dim1] -= bb[i__ - k + 1 + k *
+ bb_dim1] * ab[j - i__ + 1 + i__ * ab_dim1];
+/* L300: */
+ }
+/* L310: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by inv(S(i)) */
+
+ i__4 = *n - m;
+ d__1 = 1. / bii;
+ dscal_(&i__4, &d__1, &x[m + 1 + i__ * x_dim1], &c__1);
+ if (kbt > 0) {
+ i__4 = *n - m;
+ i__3 = *ldbb - 1;
+ dger_(&i__4, &kbt, &c_b20, &x[m + 1 + i__ * x_dim1], &
+ c__1, &bb[kbt + 1 + (i__ - kbt) * bb_dim1], &i__3,
+ &x[m + 1 + (i__ - kbt) * x_dim1], ldx);
+ }
+ }
+
+/* store a(i1,i) in RA1 for use in next loop over K */
+
+ ra1 = ab[i1 - i__ + 1 + i__ * ab_dim1];
+ }
+
+/* Generate and apply vectors of rotations to chase all the */
+/* existing bulges KA positions down toward the bottom of the */
+/* band */
+
+ i__4 = *kb - 1;
+ for (k = 1; k <= i__4; ++k) {
+ if (update) {
+
+/* Determine the rotations which would annihilate the bulge */
+/* which has in theory just been created */
+
+ if (i__ - k + *ka < *n && i__ - k > 1) {
+
+/* generate rotation to annihilate a(i-k+ka+1,i) */
+
+ dlartg_(&ab[ka1 - k + i__ * ab_dim1], &ra1, &work[*n +
+ i__ - k + *ka - m], &work[i__ - k + *ka - m], &ra)
+ ;
+
+/* create nonzero element a(i-k+ka+1,i-k) outside the */
+/* band and store it in WORK(i-k) */
+
+ t = -bb[k + 1 + (i__ - k) * bb_dim1] * ra1;
+ work[i__ - k] = work[*n + i__ - k + *ka - m] * t - work[
+ i__ - k + *ka - m] * ab[ka1 + (i__ - k) * ab_dim1]
+ ;
+ ab[ka1 + (i__ - k) * ab_dim1] = work[i__ - k + *ka - m] *
+ t + work[*n + i__ - k + *ka - m] * ab[ka1 + (i__
+ - k) * ab_dim1];
+ ra1 = ra;
+ }
+ }
+/* Computing MAX */
+ i__3 = 1, i__1 = k - i0 + 2;
+ j2 = i__ - k - 1 + max(i__3,i__1) * ka1;
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ if (update) {
+/* Computing MAX */
+ i__3 = j2, i__1 = i__ + (*ka << 1) - k + 1;
+ j2t = max(i__3,i__1);
+ } else {
+ j2t = j2;
+ }
+ nrt = (*n - j2t + *ka) / ka1;
+ i__3 = j1;
+ i__1 = ka1;
+ for (j = j2t; i__1 < 0 ? j >= i__3 : j <= i__3; j += i__1) {
+
+/* create nonzero element a(j+1,j-ka) outside the band */
+/* and store it in WORK(j-m) */
+
+ work[j - m] *= ab[ka1 + (j - *ka + 1) * ab_dim1];
+ ab[ka1 + (j - *ka + 1) * ab_dim1] = work[*n + j - m] * ab[ka1
+ + (j - *ka + 1) * ab_dim1];
+/* L320: */
+ }
+
+/* generate rotations in 1st set to annihilate elements which */
+/* have been created outside the band */
+
+ if (nrt > 0) {
+ dlargv_(&nrt, &ab[ka1 + (j2t - *ka) * ab_dim1], &inca, &work[
+ j2t - m], &ka1, &work[*n + j2t - m], &ka1);
+ }
+ if (nr > 0) {
+
+/* apply rotations in 1st set from the left */
+
+ i__1 = *ka - 1;
+ for (l = 1; l <= i__1; ++l) {
+ dlartv_(&nr, &ab[l + 1 + (j2 - l) * ab_dim1], &inca, &ab[
+ l + 2 + (j2 - l) * ab_dim1], &inca, &work[*n + j2
+ - m], &work[j2 - m], &ka1);
+/* L330: */
+ }
+
+/* apply rotations in 1st set from both sides to diagonal */
+/* blocks */
+
+ dlar2v_(&nr, &ab[j2 * ab_dim1 + 1], &ab[(j2 + 1) * ab_dim1 +
+ 1], &ab[j2 * ab_dim1 + 2], &inca, &work[*n + j2 - m],
+ &work[j2 - m], &ka1);
+
+ }
+
+/* start applying rotations in 1st set from the right */
+
+ i__1 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__1; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ dlartv_(&nrt, &ab[ka1 - l + 1 + j2 * ab_dim1], &inca, &ab[
+ ka1 - l + (j2 + 1) * ab_dim1], &inca, &work[*n +
+ j2 - m], &work[j2 - m], &ka1);
+ }
+/* L340: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 1st set */
+
+ i__1 = j1;
+ i__3 = ka1;
+ for (j = j2; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) {
+ i__2 = *n - m;
+ drot_(&i__2, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j
+ + 1) * x_dim1], &c__1, &work[*n + j - m], &work[j
+ - m]);
+/* L350: */
+ }
+ }
+/* L360: */
+ }
+
+ if (update) {
+ if (i2 <= *n && kbt > 0) {
+
+/* create nonzero element a(i-kbt+ka+1,i-kbt) outside the */
+/* band and store it in WORK(i-kbt) */
+
+ work[i__ - kbt] = -bb[kbt + 1 + (i__ - kbt) * bb_dim1] * ra1;
+ }
+ }
+
+ for (k = *kb; k >= 1; --k) {
+ if (update) {
+/* Computing MAX */
+ i__4 = 2, i__3 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__4,i__3) * ka1;
+ } else {
+/* Computing MAX */
+ i__4 = 1, i__3 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__4,i__3) * ka1;
+ }
+
+/* finish applying rotations in 2nd set from the right */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (*n - j2 + *ka + l) / ka1;
+ if (nrt > 0) {
+ dlartv_(&nrt, &ab[ka1 - l + 1 + (j2 - *ka) * ab_dim1], &
+ inca, &ab[ka1 - l + (j2 - *ka + 1) * ab_dim1], &
+ inca, &work[*n + j2 - *ka], &work[j2 - *ka], &ka1)
+ ;
+ }
+/* L370: */
+ }
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ i__4 = j2;
+ i__3 = -ka1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) {
+ work[j] = work[j - *ka];
+ work[*n + j] = work[*n + j - *ka];
+/* L380: */
+ }
+ i__3 = j1;
+ i__4 = ka1;
+ for (j = j2; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+
+/* create nonzero element a(j+1,j-ka) outside the band */
+/* and store it in WORK(j) */
+
+ work[j] *= ab[ka1 + (j - *ka + 1) * ab_dim1];
+ ab[ka1 + (j - *ka + 1) * ab_dim1] = work[*n + j] * ab[ka1 + (
+ j - *ka + 1) * ab_dim1];
+/* L390: */
+ }
+ if (update) {
+ if (i__ - k < *n - *ka && k <= kbt) {
+ work[i__ - k + *ka] = work[i__ - k];
+ }
+ }
+/* L400: */
+ }
+
+ for (k = *kb; k >= 1; --k) {
+/* Computing MAX */
+ i__4 = 1, i__3 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__4,i__3) * ka1;
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ if (nr > 0) {
+
+/* generate rotations in 2nd set to annihilate elements */
+/* which have been created outside the band */
+
+ dlargv_(&nr, &ab[ka1 + (j2 - *ka) * ab_dim1], &inca, &work[j2]
+, &ka1, &work[*n + j2], &ka1);
+
+/* apply rotations in 2nd set from the left */
+
+ i__4 = *ka - 1;
+ for (l = 1; l <= i__4; ++l) {
+ dlartv_(&nr, &ab[l + 1 + (j2 - l) * ab_dim1], &inca, &ab[
+ l + 2 + (j2 - l) * ab_dim1], &inca, &work[*n + j2]
+, &work[j2], &ka1);
+/* L410: */
+ }
+
+/* apply rotations in 2nd set from both sides to diagonal */
+/* blocks */
+
+ dlar2v_(&nr, &ab[j2 * ab_dim1 + 1], &ab[(j2 + 1) * ab_dim1 +
+ 1], &ab[j2 * ab_dim1 + 2], &inca, &work[*n + j2], &
+ work[j2], &ka1);
+
+ }
+
+/* start applying rotations in 2nd set from the right */
+
+ i__4 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__4; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ dlartv_(&nrt, &ab[ka1 - l + 1 + j2 * ab_dim1], &inca, &ab[
+ ka1 - l + (j2 + 1) * ab_dim1], &inca, &work[*n +
+ j2], &work[j2], &ka1);
+ }
+/* L420: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 2nd set */
+
+ i__4 = j1;
+ i__3 = ka1;
+ for (j = j2; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) {
+ i__1 = *n - m;
+ drot_(&i__1, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j
+ + 1) * x_dim1], &c__1, &work[*n + j], &work[j]);
+/* L430: */
+ }
+ }
+/* L440: */
+ }
+
+ i__3 = *kb - 1;
+ for (k = 1; k <= i__3; ++k) {
+/* Computing MAX */
+ i__4 = 1, i__1 = k - i0 + 2;
+ j2 = i__ - k - 1 + max(i__4,i__1) * ka1;
+
+/* finish applying rotations in 1st set from the right */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ dlartv_(&nrt, &ab[ka1 - l + 1 + j2 * ab_dim1], &inca, &ab[
+ ka1 - l + (j2 + 1) * ab_dim1], &inca, &work[*n +
+ j2 - m], &work[j2 - m], &ka1);
+ }
+/* L450: */
+ }
+/* L460: */
+ }
+
+ if (*kb > 1) {
+ i__3 = i__ - *kb + (*ka << 1) + 1;
+ for (j = *n - 1; j >= i__3; --j) {
+ work[*n + j - m] = work[*n + j - *ka - m];
+ work[j - m] = work[j - *ka - m];
+/* L470: */
+ }
+ }
+
+ }
+
+ goto L10;
+
+L480:
+
+/* **************************** Phase 2 ***************************** */
+
+/* The logical structure of this phase is: */
+
+/* UPDATE = .TRUE. */
+/* DO I = 1, M */
+/* use S(i) to update A and create a new bulge */
+/* apply rotations to push all bulges KA positions upward */
+/* END DO */
+/* UPDATE = .FALSE. */
+/* DO I = M - KA - 1, 2, -1 */
+/* apply rotations to push all bulges KA positions upward */
+/* END DO */
+
+/* To avoid duplicating code, the two loops are merged. */
+
+ update = TRUE_;
+ i__ = 0;
+L490:
+ if (update) {
+ ++i__;
+/* Computing MIN */
+ i__3 = *kb, i__4 = m - i__;
+ kbt = min(i__3,i__4);
+ i0 = i__ + 1;
+/* Computing MAX */
+ i__3 = 1, i__4 = i__ - *ka;
+ i1 = max(i__3,i__4);
+ i2 = i__ + kbt - ka1;
+ if (i__ > m) {
+ update = FALSE_;
+ --i__;
+ i0 = m + 1;
+ if (*ka == 0) {
+ return 0;
+ }
+ goto L490;
+ }
+ } else {
+ i__ -= *ka;
+ if (i__ < 2) {
+ return 0;
+ }
+ }
+
+ if (i__ < m - kbt) {
+ nx = m;
+ } else {
+ nx = *n;
+ }
+
+ if (upper) {
+
+/* Transform A, working with the upper triangle */
+
+ if (update) {
+
+/* Form inv(S(i))**T * A * inv(S(i)) */
+
+ bii = bb[kb1 + i__ * bb_dim1];
+ i__3 = i__;
+ for (j = i1; j <= i__3; ++j) {
+ ab[j - i__ + ka1 + i__ * ab_dim1] /= bii;
+/* L500: */
+ }
+/* Computing MIN */
+ i__4 = *n, i__1 = i__ + *ka;
+ i__3 = min(i__4,i__1);
+ for (j = i__; j <= i__3; ++j) {
+ ab[i__ - j + ka1 + j * ab_dim1] /= bii;
+/* L510: */
+ }
+ i__3 = i__ + kbt;
+ for (k = i__ + 1; k <= i__3; ++k) {
+ i__4 = i__ + kbt;
+ for (j = k; j <= i__4; ++j) {
+ ab[k - j + ka1 + j * ab_dim1] = ab[k - j + ka1 + j *
+ ab_dim1] - bb[i__ - j + kb1 + j * bb_dim1] * ab[
+ i__ - k + ka1 + k * ab_dim1] - bb[i__ - k + kb1 +
+ k * bb_dim1] * ab[i__ - j + ka1 + j * ab_dim1] +
+ ab[ka1 + i__ * ab_dim1] * bb[i__ - j + kb1 + j *
+ bb_dim1] * bb[i__ - k + kb1 + k * bb_dim1];
+/* L520: */
+ }
+/* Computing MIN */
+ i__1 = *n, i__2 = i__ + *ka;
+ i__4 = min(i__1,i__2);
+ for (j = i__ + kbt + 1; j <= i__4; ++j) {
+ ab[k - j + ka1 + j * ab_dim1] -= bb[i__ - k + kb1 + k *
+ bb_dim1] * ab[i__ - j + ka1 + j * ab_dim1];
+/* L530: */
+ }
+/* L540: */
+ }
+ i__3 = i__;
+ for (j = i1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__1 = j + *ka, i__2 = i__ + kbt;
+ i__4 = min(i__1,i__2);
+ for (k = i__ + 1; k <= i__4; ++k) {
+ ab[j - k + ka1 + k * ab_dim1] -= bb[i__ - k + kb1 + k *
+ bb_dim1] * ab[j - i__ + ka1 + i__ * ab_dim1];
+/* L550: */
+ }
+/* L560: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by inv(S(i)) */
+
+ d__1 = 1. / bii;
+ dscal_(&nx, &d__1, &x[i__ * x_dim1 + 1], &c__1);
+ if (kbt > 0) {
+ i__3 = *ldbb - 1;
+ dger_(&nx, &kbt, &c_b20, &x[i__ * x_dim1 + 1], &c__1, &bb[
+ *kb + (i__ + 1) * bb_dim1], &i__3, &x[(i__ + 1) *
+ x_dim1 + 1], ldx);
+ }
+ }
+
+/* store a(i1,i) in RA1 for use in next loop over K */
+
+ ra1 = ab[i1 - i__ + ka1 + i__ * ab_dim1];
+ }
+
+/* Generate and apply vectors of rotations to chase all the */
+/* existing bulges KA positions up toward the top of the band */
+
+ i__3 = *kb - 1;
+ for (k = 1; k <= i__3; ++k) {
+ if (update) {
+
+/* Determine the rotations which would annihilate the bulge */
+/* which has in theory just been created */
+
+ if (i__ + k - ka1 > 0 && i__ + k < m) {
+
+/* generate rotation to annihilate a(i+k-ka-1,i) */
+
+ dlartg_(&ab[k + 1 + i__ * ab_dim1], &ra1, &work[*n + i__
+ + k - *ka], &work[i__ + k - *ka], &ra);
+
+/* create nonzero element a(i+k-ka-1,i+k) outside the */
+/* band and store it in WORK(m-kb+i+k) */
+
+ t = -bb[kb1 - k + (i__ + k) * bb_dim1] * ra1;
+ work[m - *kb + i__ + k] = work[*n + i__ + k - *ka] * t -
+ work[i__ + k - *ka] * ab[(i__ + k) * ab_dim1 + 1];
+ ab[(i__ + k) * ab_dim1 + 1] = work[i__ + k - *ka] * t +
+ work[*n + i__ + k - *ka] * ab[(i__ + k) * ab_dim1
+ + 1];
+ ra1 = ra;
+ }
+ }
+/* Computing MAX */
+ i__4 = 1, i__1 = k + i0 - m + 1;
+ j2 = i__ + k + 1 - max(i__4,i__1) * ka1;
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ if (update) {
+/* Computing MIN */
+ i__4 = j2, i__1 = i__ - (*ka << 1) + k - 1;
+ j2t = min(i__4,i__1);
+ } else {
+ j2t = j2;
+ }
+ nrt = (j2t + *ka - 1) / ka1;
+ i__4 = j2t;
+ i__1 = ka1;
+ for (j = j1; i__1 < 0 ? j >= i__4 : j <= i__4; j += i__1) {
+
+/* create nonzero element a(j-1,j+ka) outside the band */
+/* and store it in WORK(j) */
+
+ work[j] *= ab[(j + *ka - 1) * ab_dim1 + 1];
+ ab[(j + *ka - 1) * ab_dim1 + 1] = work[*n + j] * ab[(j + *ka
+ - 1) * ab_dim1 + 1];
+/* L570: */
+ }
+
+/* generate rotations in 1st set to annihilate elements which */
+/* have been created outside the band */
+
+ if (nrt > 0) {
+ dlargv_(&nrt, &ab[(j1 + *ka) * ab_dim1 + 1], &inca, &work[j1],
+ &ka1, &work[*n + j1], &ka1);
+ }
+ if (nr > 0) {
+
+/* apply rotations in 1st set from the left */
+
+ i__1 = *ka - 1;
+ for (l = 1; l <= i__1; ++l) {
+ dlartv_(&nr, &ab[ka1 - l + (j1 + l) * ab_dim1], &inca, &
+ ab[*ka - l + (j1 + l) * ab_dim1], &inca, &work[*n
+ + j1], &work[j1], &ka1);
+/* L580: */
+ }
+
+/* apply rotations in 1st set from both sides to diagonal */
+/* blocks */
+
+ dlar2v_(&nr, &ab[ka1 + j1 * ab_dim1], &ab[ka1 + (j1 - 1) *
+ ab_dim1], &ab[*ka + j1 * ab_dim1], &inca, &work[*n +
+ j1], &work[j1], &ka1);
+
+ }
+
+/* start applying rotations in 1st set from the right */
+
+ i__1 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__1; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ dlartv_(&nrt, &ab[l + j1t * ab_dim1], &inca, &ab[l + 1 + (
+ j1t - 1) * ab_dim1], &inca, &work[*n + j1t], &
+ work[j1t], &ka1);
+ }
+/* L590: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 1st set */
+
+ i__1 = j2;
+ i__4 = ka1;
+ for (j = j1; i__4 < 0 ? j >= i__1 : j <= i__1; j += i__4) {
+ drot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1
+ + 1], &c__1, &work[*n + j], &work[j]);
+/* L600: */
+ }
+ }
+/* L610: */
+ }
+
+ if (update) {
+ if (i2 > 0 && kbt > 0) {
+
+/* create nonzero element a(i+kbt-ka-1,i+kbt) outside the */
+/* band and store it in WORK(m-kb+i+kbt) */
+
+ work[m - *kb + i__ + kbt] = -bb[kb1 - kbt + (i__ + kbt) *
+ bb_dim1] * ra1;
+ }
+ }
+
+ for (k = *kb; k >= 1; --k) {
+ if (update) {
+/* Computing MAX */
+ i__3 = 2, i__4 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__3,i__4) * ka1;
+ } else {
+/* Computing MAX */
+ i__3 = 1, i__4 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__3,i__4) * ka1;
+ }
+
+/* finish applying rotations in 2nd set from the right */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (j2 + *ka + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ dlartv_(&nrt, &ab[l + (j1t + *ka) * ab_dim1], &inca, &ab[
+ l + 1 + (j1t + *ka - 1) * ab_dim1], &inca, &work[*
+ n + m - *kb + j1t + *ka], &work[m - *kb + j1t + *
+ ka], &ka1);
+ }
+/* L620: */
+ }
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ i__3 = j2;
+ i__4 = ka1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+ work[m - *kb + j] = work[m - *kb + j + *ka];
+ work[*n + m - *kb + j] = work[*n + m - *kb + j + *ka];
+/* L630: */
+ }
+ i__4 = j2;
+ i__3 = ka1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) {
+
+/* create nonzero element a(j-1,j+ka) outside the band */
+/* and store it in WORK(m-kb+j) */
+
+ work[m - *kb + j] *= ab[(j + *ka - 1) * ab_dim1 + 1];
+ ab[(j + *ka - 1) * ab_dim1 + 1] = work[*n + m - *kb + j] * ab[
+ (j + *ka - 1) * ab_dim1 + 1];
+/* L640: */
+ }
+ if (update) {
+ if (i__ + k > ka1 && k <= kbt) {
+ work[m - *kb + i__ + k - *ka] = work[m - *kb + i__ + k];
+ }
+ }
+/* L650: */
+ }
+
+ for (k = *kb; k >= 1; --k) {
+/* Computing MAX */
+ i__3 = 1, i__4 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__3,i__4) * ka1;
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ if (nr > 0) {
+
+/* generate rotations in 2nd set to annihilate elements */
+/* which have been created outside the band */
+
+ dlargv_(&nr, &ab[(j1 + *ka) * ab_dim1 + 1], &inca, &work[m - *
+ kb + j1], &ka1, &work[*n + m - *kb + j1], &ka1);
+
+/* apply rotations in 2nd set from the left */
+
+ i__3 = *ka - 1;
+ for (l = 1; l <= i__3; ++l) {
+ dlartv_(&nr, &ab[ka1 - l + (j1 + l) * ab_dim1], &inca, &
+ ab[*ka - l + (j1 + l) * ab_dim1], &inca, &work[*n
+ + m - *kb + j1], &work[m - *kb + j1], &ka1);
+/* L660: */
+ }
+
+/* apply rotations in 2nd set from both sides to diagonal */
+/* blocks */
+
+ dlar2v_(&nr, &ab[ka1 + j1 * ab_dim1], &ab[ka1 + (j1 - 1) *
+ ab_dim1], &ab[*ka + j1 * ab_dim1], &inca, &work[*n +
+ m - *kb + j1], &work[m - *kb + j1], &ka1);
+
+ }
+
+/* start applying rotations in 2nd set from the right */
+
+ i__3 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__3; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ dlartv_(&nrt, &ab[l + j1t * ab_dim1], &inca, &ab[l + 1 + (
+ j1t - 1) * ab_dim1], &inca, &work[*n + m - *kb +
+ j1t], &work[m - *kb + j1t], &ka1);
+ }
+/* L670: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 2nd set */
+
+ i__3 = j2;
+ i__4 = ka1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+ drot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1
+ + 1], &c__1, &work[*n + m - *kb + j], &work[m - *
+ kb + j]);
+/* L680: */
+ }
+ }
+/* L690: */
+ }
+
+ i__4 = *kb - 1;
+ for (k = 1; k <= i__4; ++k) {
+/* Computing MAX */
+ i__3 = 1, i__1 = k + i0 - m + 1;
+ j2 = i__ + k + 1 - max(i__3,i__1) * ka1;
+
+/* finish applying rotations in 1st set from the right */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ dlartv_(&nrt, &ab[l + j1t * ab_dim1], &inca, &ab[l + 1 + (
+ j1t - 1) * ab_dim1], &inca, &work[*n + j1t], &
+ work[j1t], &ka1);
+ }
+/* L700: */
+ }
+/* L710: */
+ }
+
+ if (*kb > 1) {
+/* Computing MIN */
+ i__3 = i__ + *kb;
+ i__4 = min(i__3,m) - (*ka << 1) - 1;
+ for (j = 2; j <= i__4; ++j) {
+ work[*n + j] = work[*n + j + *ka];
+ work[j] = work[j + *ka];
+/* L720: */
+ }
+ }
+
+ } else {
+
+/* Transform A, working with the lower triangle */
+
+ if (update) {
+
+/* Form inv(S(i))**T * A * inv(S(i)) */
+
+ bii = bb[i__ * bb_dim1 + 1];
+ i__4 = i__;
+ for (j = i1; j <= i__4; ++j) {
+ ab[i__ - j + 1 + j * ab_dim1] /= bii;
+/* L730: */
+ }
+/* Computing MIN */
+ i__3 = *n, i__1 = i__ + *ka;
+ i__4 = min(i__3,i__1);
+ for (j = i__; j <= i__4; ++j) {
+ ab[j - i__ + 1 + i__ * ab_dim1] /= bii;
+/* L740: */
+ }
+ i__4 = i__ + kbt;
+ for (k = i__ + 1; k <= i__4; ++k) {
+ i__3 = i__ + kbt;
+ for (j = k; j <= i__3; ++j) {
+ ab[j - k + 1 + k * ab_dim1] = ab[j - k + 1 + k * ab_dim1]
+ - bb[j - i__ + 1 + i__ * bb_dim1] * ab[k - i__ +
+ 1 + i__ * ab_dim1] - bb[k - i__ + 1 + i__ *
+ bb_dim1] * ab[j - i__ + 1 + i__ * ab_dim1] + ab[
+ i__ * ab_dim1 + 1] * bb[j - i__ + 1 + i__ *
+ bb_dim1] * bb[k - i__ + 1 + i__ * bb_dim1];
+/* L750: */
+ }
+/* Computing MIN */
+ i__1 = *n, i__2 = i__ + *ka;
+ i__3 = min(i__1,i__2);
+ for (j = i__ + kbt + 1; j <= i__3; ++j) {
+ ab[j - k + 1 + k * ab_dim1] -= bb[k - i__ + 1 + i__ *
+ bb_dim1] * ab[j - i__ + 1 + i__ * ab_dim1];
+/* L760: */
+ }
+/* L770: */
+ }
+ i__4 = i__;
+ for (j = i1; j <= i__4; ++j) {
+/* Computing MIN */
+ i__1 = j + *ka, i__2 = i__ + kbt;
+ i__3 = min(i__1,i__2);
+ for (k = i__ + 1; k <= i__3; ++k) {
+ ab[k - j + 1 + j * ab_dim1] -= bb[k - i__ + 1 + i__ *
+ bb_dim1] * ab[i__ - j + 1 + j * ab_dim1];
+/* L780: */
+ }
+/* L790: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by inv(S(i)) */
+
+ d__1 = 1. / bii;
+ dscal_(&nx, &d__1, &x[i__ * x_dim1 + 1], &c__1);
+ if (kbt > 0) {
+ dger_(&nx, &kbt, &c_b20, &x[i__ * x_dim1 + 1], &c__1, &bb[
+ i__ * bb_dim1 + 2], &c__1, &x[(i__ + 1) * x_dim1
+ + 1], ldx);
+ }
+ }
+
+/* store a(i,i1) in RA1 for use in next loop over K */
+
+ ra1 = ab[i__ - i1 + 1 + i1 * ab_dim1];
+ }
+
+/* Generate and apply vectors of rotations to chase all the */
+/* existing bulges KA positions up toward the top of the band */
+
+ i__4 = *kb - 1;
+ for (k = 1; k <= i__4; ++k) {
+ if (update) {
+
+/* Determine the rotations which would annihilate the bulge */
+/* which has in theory just been created */
+
+ if (i__ + k - ka1 > 0 && i__ + k < m) {
+
+/* generate rotation to annihilate a(i,i+k-ka-1) */
+
+ dlartg_(&ab[ka1 - k + (i__ + k - *ka) * ab_dim1], &ra1, &
+ work[*n + i__ + k - *ka], &work[i__ + k - *ka], &
+ ra);
+
+/* create nonzero element a(i+k,i+k-ka-1) outside the */
+/* band and store it in WORK(m-kb+i+k) */
+
+ t = -bb[k + 1 + i__ * bb_dim1] * ra1;
+ work[m - *kb + i__ + k] = work[*n + i__ + k - *ka] * t -
+ work[i__ + k - *ka] * ab[ka1 + (i__ + k - *ka) *
+ ab_dim1];
+ ab[ka1 + (i__ + k - *ka) * ab_dim1] = work[i__ + k - *ka]
+ * t + work[*n + i__ + k - *ka] * ab[ka1 + (i__ +
+ k - *ka) * ab_dim1];
+ ra1 = ra;
+ }
+ }
+/* Computing MAX */
+ i__3 = 1, i__1 = k + i0 - m + 1;
+ j2 = i__ + k + 1 - max(i__3,i__1) * ka1;
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ if (update) {
+/* Computing MIN */
+ i__3 = j2, i__1 = i__ - (*ka << 1) + k - 1;
+ j2t = min(i__3,i__1);
+ } else {
+ j2t = j2;
+ }
+ nrt = (j2t + *ka - 1) / ka1;
+ i__3 = j2t;
+ i__1 = ka1;
+ for (j = j1; i__1 < 0 ? j >= i__3 : j <= i__3; j += i__1) {
+
+/* create nonzero element a(j+ka,j-1) outside the band */
+/* and store it in WORK(j) */
+
+ work[j] *= ab[ka1 + (j - 1) * ab_dim1];
+ ab[ka1 + (j - 1) * ab_dim1] = work[*n + j] * ab[ka1 + (j - 1)
+ * ab_dim1];
+/* L800: */
+ }
+
+/* generate rotations in 1st set to annihilate elements which */
+/* have been created outside the band */
+
+ if (nrt > 0) {
+ dlargv_(&nrt, &ab[ka1 + j1 * ab_dim1], &inca, &work[j1], &ka1,
+ &work[*n + j1], &ka1);
+ }
+ if (nr > 0) {
+
+/* apply rotations in 1st set from the right */
+
+ i__1 = *ka - 1;
+ for (l = 1; l <= i__1; ++l) {
+ dlartv_(&nr, &ab[l + 1 + j1 * ab_dim1], &inca, &ab[l + 2
+ + (j1 - 1) * ab_dim1], &inca, &work[*n + j1], &
+ work[j1], &ka1);
+/* L810: */
+ }
+
+/* apply rotations in 1st set from both sides to diagonal */
+/* blocks */
+
+ dlar2v_(&nr, &ab[j1 * ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 +
+ 1], &ab[(j1 - 1) * ab_dim1 + 2], &inca, &work[*n + j1]
+, &work[j1], &ka1);
+
+ }
+
+/* start applying rotations in 1st set from the left */
+
+ i__1 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__1; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ dlartv_(&nrt, &ab[ka1 - l + 1 + (j1t - ka1 + l) * ab_dim1]
+, &inca, &ab[ka1 - l + (j1t - ka1 + l) * ab_dim1],
+ &inca, &work[*n + j1t], &work[j1t], &ka1);
+ }
+/* L820: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 1st set */
+
+ i__1 = j2;
+ i__3 = ka1;
+ for (j = j1; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) {
+ drot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1
+ + 1], &c__1, &work[*n + j], &work[j]);
+/* L830: */
+ }
+ }
+/* L840: */
+ }
+
+ if (update) {
+ if (i2 > 0 && kbt > 0) {
+
+/* create nonzero element a(i+kbt,i+kbt-ka-1) outside the */
+/* band and store it in WORK(m-kb+i+kbt) */
+
+ work[m - *kb + i__ + kbt] = -bb[kbt + 1 + i__ * bb_dim1] *
+ ra1;
+ }
+ }
+
+ for (k = *kb; k >= 1; --k) {
+ if (update) {
+/* Computing MAX */
+ i__4 = 2, i__3 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__4,i__3) * ka1;
+ } else {
+/* Computing MAX */
+ i__4 = 1, i__3 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__4,i__3) * ka1;
+ }
+
+/* finish applying rotations in 2nd set from the left */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (j2 + *ka + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ dlartv_(&nrt, &ab[ka1 - l + 1 + (j1t + l - 1) * ab_dim1],
+ &inca, &ab[ka1 - l + (j1t + l - 1) * ab_dim1], &
+ inca, &work[*n + m - *kb + j1t + *ka], &work[m - *
+ kb + j1t + *ka], &ka1);
+ }
+/* L850: */
+ }
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ i__4 = j2;
+ i__3 = ka1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) {
+ work[m - *kb + j] = work[m - *kb + j + *ka];
+ work[*n + m - *kb + j] = work[*n + m - *kb + j + *ka];
+/* L860: */
+ }
+ i__3 = j2;
+ i__4 = ka1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+
+/* create nonzero element a(j+ka,j-1) outside the band */
+/* and store it in WORK(m-kb+j) */
+
+ work[m - *kb + j] *= ab[ka1 + (j - 1) * ab_dim1];
+ ab[ka1 + (j - 1) * ab_dim1] = work[*n + m - *kb + j] * ab[ka1
+ + (j - 1) * ab_dim1];
+/* L870: */
+ }
+ if (update) {
+ if (i__ + k > ka1 && k <= kbt) {
+ work[m - *kb + i__ + k - *ka] = work[m - *kb + i__ + k];
+ }
+ }
+/* L880: */
+ }
+
+ for (k = *kb; k >= 1; --k) {
+/* Computing MAX */
+ i__4 = 1, i__3 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__4,i__3) * ka1;
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ if (nr > 0) {
+
+/* generate rotations in 2nd set to annihilate elements */
+/* which have been created outside the band */
+
+ dlargv_(&nr, &ab[ka1 + j1 * ab_dim1], &inca, &work[m - *kb +
+ j1], &ka1, &work[*n + m - *kb + j1], &ka1);
+
+/* apply rotations in 2nd set from the right */
+
+ i__4 = *ka - 1;
+ for (l = 1; l <= i__4; ++l) {
+ dlartv_(&nr, &ab[l + 1 + j1 * ab_dim1], &inca, &ab[l + 2
+ + (j1 - 1) * ab_dim1], &inca, &work[*n + m - *kb
+ + j1], &work[m - *kb + j1], &ka1);
+/* L890: */
+ }
+
+/* apply rotations in 2nd set from both sides to diagonal */
+/* blocks */
+
+ dlar2v_(&nr, &ab[j1 * ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 +
+ 1], &ab[(j1 - 1) * ab_dim1 + 2], &inca, &work[*n + m
+ - *kb + j1], &work[m - *kb + j1], &ka1);
+
+ }
+
+/* start applying rotations in 2nd set from the left */
+
+ i__4 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__4; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ dlartv_(&nrt, &ab[ka1 - l + 1 + (j1t - ka1 + l) * ab_dim1]
+, &inca, &ab[ka1 - l + (j1t - ka1 + l) * ab_dim1],
+ &inca, &work[*n + m - *kb + j1t], &work[m - *kb
+ + j1t], &ka1);
+ }
+/* L900: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 2nd set */
+
+ i__4 = j2;
+ i__3 = ka1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) {
+ drot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1
+ + 1], &c__1, &work[*n + m - *kb + j], &work[m - *
+ kb + j]);
+/* L910: */
+ }
+ }
+/* L920: */
+ }
+
+ i__3 = *kb - 1;
+ for (k = 1; k <= i__3; ++k) {
+/* Computing MAX */
+ i__4 = 1, i__1 = k + i0 - m + 1;
+ j2 = i__ + k + 1 - max(i__4,i__1) * ka1;
+
+/* finish applying rotations in 1st set from the left */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ dlartv_(&nrt, &ab[ka1 - l + 1 + (j1t - ka1 + l) * ab_dim1]
+, &inca, &ab[ka1 - l + (j1t - ka1 + l) * ab_dim1],
+ &inca, &work[*n + j1t], &work[j1t], &ka1);
+ }
+/* L930: */
+ }
+/* L940: */
+ }
+
+ if (*kb > 1) {
+/* Computing MIN */
+ i__4 = i__ + *kb;
+ i__3 = min(i__4,m) - (*ka << 1) - 1;
+ for (j = 2; j <= i__3; ++j) {
+ work[*n + j] = work[*n + j + *ka];
+ work[j] = work[j + *ka];
+/* L950: */
+ }
+ }
+
+ }
+
+ goto L490;
+
+/* End of DSBGST */
+
+} /* dsbgst_ */
diff --git a/SRC/dsbgv.c b/SRC/dsbgv.c
new file mode 100644
index 0000000..0fcf767
--- /dev/null
+++ b/SRC/dsbgv.c
@@ -0,0 +1,234 @@
+/* dsbgv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dsbgv_(char *jobz, char *uplo, integer *n, integer *ka,
+ integer *kb, doublereal *ab, integer *ldab, doublereal *bb, integer *
+ ldbb, doublereal *w, doublereal *z__, integer *ldz, doublereal *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, bb_dim1, bb_offset, z_dim1, z_offset, i__1;
+
+ /* Local variables */
+ integer inde;
+ char vect[1];
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical upper, wantz;
+ extern /* Subroutine */ int xerbla_(char *, integer *), dpbstf_(
+ char *, integer *, integer *, doublereal *, integer *, integer *), dsbtrd_(char *, char *, integer *, integer *, doublereal
+ *, integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), dsbgst_(char *, char *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dsterf_(integer *, doublereal *,
+ doublereal *, integer *);
+ integer indwrk;
+ extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSBGV computes all the eigenvalues, and optionally, the eigenvectors */
+/* of a real generalized symmetric-definite banded eigenproblem, of */
+/* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric */
+/* and banded, and B is also positive definite. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* KA (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */
+
+/* KB (input) INTEGER */
+/* The number of superdiagonals of the matrix B if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KB >= 0. */
+
+/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first ka+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */
+
+/* On exit, the contents of AB are destroyed. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KA+1. */
+
+/* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix B, stored in the first kb+1 rows of the array. The */
+/* j-th column of B is stored in the j-th column of the array BB */
+/* as follows: */
+/* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; */
+/* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). */
+
+/* On exit, the factor S from the split Cholesky factorization */
+/* B = S**T*S, as returned by DPBSTF. */
+
+/* LDBB (input) INTEGER */
+/* The leading dimension of the array BB. LDBB >= KB+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
+/* eigenvectors, with the i-th column of Z holding the */
+/* eigenvector associated with W(i). The eigenvectors are */
+/* normalized so that Z**T*B*Z = I. */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= N. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is: */
+/* <= N: the algorithm failed to converge: */
+/* i off-diagonal elements of an intermediate */
+/* tridiagonal form did not converge to zero; */
+/* > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF */
+/* returned INFO = i: B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ bb_dim1 = *ldbb;
+ bb_offset = 1 + bb_dim1;
+ bb -= bb_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ka < 0) {
+ *info = -4;
+ } else if (*kb < 0 || *kb > *ka) {
+ *info = -5;
+ } else if (*ldab < *ka + 1) {
+ *info = -7;
+ } else if (*ldbb < *kb + 1) {
+ *info = -9;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSBGV ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a split Cholesky factorization of B. */
+
+ dpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem. */
+
+ inde = 1;
+ indwrk = inde + *n;
+ dsbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb,
+ &z__[z_offset], ldz, &work[indwrk], &iinfo)
+ ;
+
+/* Reduce to tridiagonal form. */
+
+ if (wantz) {
+ *(unsigned char *)vect = 'U';
+ } else {
+ *(unsigned char *)vect = 'N';
+ }
+ dsbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[
+ z_offset], ldz, &work[indwrk], &iinfo);
+
+/* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEQR. */
+
+ if (! wantz) {
+ dsterf_(n, &w[1], &work[inde], info);
+ } else {
+ dsteqr_(jobz, n, &w[1], &work[inde], &z__[z_offset], ldz, &work[
+ indwrk], info);
+ }
+ return 0;
+
+/* End of DSBGV */
+
+} /* dsbgv_ */
diff --git a/SRC/dsbgvd.c b/SRC/dsbgvd.c
new file mode 100644
index 0000000..28f87a0
--- /dev/null
+++ b/SRC/dsbgvd.c
@@ -0,0 +1,327 @@
+/* dsbgvd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b12 = 1.;
+static doublereal c_b13 = 0.;
+
+/* Subroutine */ int dsbgvd_(char *jobz, char *uplo, integer *n, integer *ka,
+ integer *kb, doublereal *ab, integer *ldab, doublereal *bb, integer *
+ ldbb, doublereal *w, doublereal *z__, integer *ldz, doublereal *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, bb_dim1, bb_offset, z_dim1, z_offset, i__1;
+
+ /* Local variables */
+ integer inde;
+ char vect[1];
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ integer iinfo, lwmin;
+ logical upper, wantz;
+ integer indwk2, llwrk2;
+ extern /* Subroutine */ int dstedc_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *, integer *), dlacpy_(char *, integer
+ *, integer *, doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *), dpbstf_(char *,
+ integer *, integer *, doublereal *, integer *, integer *),
+ dsbtrd_(char *, char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), dsbgst_(char *, char *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dsterf_(integer *, doublereal *,
+ doublereal *, integer *);
+ integer indwrk, liwmin;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSBGVD computes all the eigenvalues, and optionally, the eigenvectors */
+/* of a real generalized symmetric-definite banded eigenproblem, of the */
+/* form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and */
+/* banded, and B is also positive definite. If eigenvectors are */
+/* desired, it uses a divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* KA (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */
+
+/* KB (input) INTEGER */
+/* The number of superdiagonals of the matrix B if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KB >= 0. */
+
+/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first ka+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */
+
+/* On exit, the contents of AB are destroyed. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KA+1. */
+
+/* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix B, stored in the first kb+1 rows of the array. The */
+/* j-th column of B is stored in the j-th column of the array BB */
+/* as follows: */
+/* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; */
+/* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). */
+
+/* On exit, the factor S from the split Cholesky factorization */
+/* B = S**T*S, as returned by DPBSTF. */
+
+/* LDBB (input) INTEGER */
+/* The leading dimension of the array BB. LDBB >= KB+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
+/* eigenvectors, with the i-th column of Z holding the */
+/* eigenvector associated with W(i). The eigenvectors are */
+/* normalized so Z**T*B*Z = I. */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If N <= 1, LWORK >= 1. */
+/* If JOBZ = 'N' and N > 1, LWORK >= 3*N. */
+/* If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK and IWORK */
+/* arrays, returns these values as the first entries of the WORK */
+/* and IWORK arrays, and no error message related to LWORK or */
+/* LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If JOBZ = 'N' or N <= 1, LIWORK >= 1. */
+/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK and IWORK arrays, and no error message related to */
+/* LWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is: */
+/* <= N: the algorithm failed to converge: */
+/* i off-diagonal elements of an intermediate */
+/* tridiagonal form did not converge to zero; */
+/* > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF */
+/* returned INFO = i: B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ bb_dim1 = *ldbb;
+ bb_offset = 1 + bb_dim1;
+ bb -= bb_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1 || *liwork == -1;
+
+ *info = 0;
+ if (*n <= 1) {
+ liwmin = 1;
+ lwmin = 1;
+ } else if (wantz) {
+ liwmin = *n * 5 + 3;
+/* Computing 2nd power */
+ i__1 = *n;
+ lwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
+ } else {
+ liwmin = 1;
+ lwmin = *n << 1;
+ }
+
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ka < 0) {
+ *info = -4;
+ } else if (*kb < 0 || *kb > *ka) {
+ *info = -5;
+ } else if (*ldab < *ka + 1) {
+ *info = -7;
+ } else if (*ldbb < *kb + 1) {
+ *info = -9;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -12;
+ }
+
+ if (*info == 0) {
+ work[1] = (doublereal) lwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -14;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -16;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSBGVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a split Cholesky factorization of B. */
+
+ dpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem. */
+
+ inde = 1;
+ indwrk = inde + *n;
+ indwk2 = indwrk + *n * *n;
+ llwrk2 = *lwork - indwk2 + 1;
+ dsbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb,
+ &z__[z_offset], ldz, &work[indwrk], &iinfo)
+ ;
+
+/* Reduce to tridiagonal form. */
+
+ if (wantz) {
+ *(unsigned char *)vect = 'U';
+ } else {
+ *(unsigned char *)vect = 'N';
+ }
+ dsbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[
+ z_offset], ldz, &work[indwrk], &iinfo);
+
+/* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEDC. */
+
+ if (! wantz) {
+ dsterf_(n, &w[1], &work[inde], info);
+ } else {
+ dstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], &
+ llwrk2, &iwork[1], liwork, info);
+ dgemm_("N", "N", n, n, n, &c_b12, &z__[z_offset], ldz, &work[indwrk],
+ n, &c_b13, &work[indwk2], n);
+ dlacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz);
+ }
+
+ work[1] = (doublereal) lwmin;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of DSBGVD */
+
+} /* dsbgvd_ */
diff --git a/SRC/dsbgvx.c b/SRC/dsbgvx.c
new file mode 100644
index 0000000..b810b3a
--- /dev/null
+++ b/SRC/dsbgvx.c
@@ -0,0 +1,466 @@
+/* dsbgvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b25 = 1.;
+static doublereal c_b27 = 0.;
+
+/* Subroutine */ int dsbgvx_(char *jobz, char *range, char *uplo, integer *n,
+ integer *ka, integer *kb, doublereal *ab, integer *ldab, doublereal *
+ bb, integer *ldbb, doublereal *q, integer *ldq, doublereal *vl,
+ doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer
+ *m, doublereal *w, doublereal *z__, integer *ldz, doublereal *work,
+ integer *iwork, integer *ifail, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, bb_dim1, bb_offset, q_dim1, q_offset, z_dim1,
+ z_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, jj;
+ doublereal tmp1;
+ integer indd, inde;
+ char vect[1];
+ logical test;
+ integer itmp1, indee;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ integer iinfo;
+ char order[1];
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dswap_(integer *, doublereal *, integer
+ *, doublereal *, integer *);
+ logical upper, wantz, alleig, indeig;
+ integer indibl;
+ logical valeig;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *), dpbstf_(char *, integer *,
+ integer *, doublereal *, integer *, integer *), dsbtrd_(
+ char *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer indisp;
+ extern /* Subroutine */ int dsbgst_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dstein_(integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, integer *, integer *);
+ integer indiwo;
+ extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
+ integer *), dstebz_(char *, char *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, integer *);
+ integer indwrk;
+ extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *);
+ integer nsplit;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSBGVX computes selected eigenvalues, and optionally, eigenvectors */
+/* of a real generalized symmetric-definite banded eigenproblem, of */
+/* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric */
+/* and banded, and B is also positive definite. Eigenvalues and */
+/* eigenvectors can be selected by specifying either all eigenvalues, */
+/* a range of values or a range of indices for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* KA (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */
+
+/* KB (input) INTEGER */
+/* The number of superdiagonals of the matrix B if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KB >= 0. */
+
+/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first ka+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */
+
+/* On exit, the contents of AB are destroyed. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KA+1. */
+
+/* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix B, stored in the first kb+1 rows of the array. The */
+/* j-th column of B is stored in the j-th column of the array BB */
+/* as follows: */
+/* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; */
+/* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). */
+
+/* On exit, the factor S from the split Cholesky factorization */
+/* B = S**T*S, as returned by DPBSTF. */
+
+/* LDBB (input) INTEGER */
+/* The leading dimension of the array BB. LDBB >= KB+1. */
+
+/* Q (output) DOUBLE PRECISION array, dimension (LDQ, N) */
+/* If JOBZ = 'V', the n-by-n matrix used in the reduction of */
+/* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x, */
+/* and consequently C to tridiagonal form. */
+/* If JOBZ = 'N', the array Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. If JOBZ = 'N', */
+/* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N). */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) DOUBLE PRECISION */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing A to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*DLAMCH('S'). */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
+/* eigenvectors, with the i-th column of Z holding the */
+/* eigenvector associated with W(i). The eigenvectors are */
+/* normalized so Z**T*B*Z = I. */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (7*N) */
+
+/* IWORK (workspace/output) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (M) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvalues that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit */
+/* < 0 : if INFO = -i, the i-th argument had an illegal value */
+/* <= N: if INFO = i, then i eigenvectors failed to converge. */
+/* Their indices are stored in IFAIL. */
+/* > N : DPBSTF returned an error code; i.e., */
+/* if INFO = N + i, for 1 <= i <= N, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ bb_dim1 = *ldbb;
+ bb_offset = 1 + bb_dim1;
+ bb -= bb_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ka < 0) {
+ *info = -5;
+ } else if (*kb < 0 || *kb > *ka) {
+ *info = -6;
+ } else if (*ldab < *ka + 1) {
+ *info = -8;
+ } else if (*ldbb < *kb + 1) {
+ *info = -10;
+ } else if (*ldq < 1 || wantz && *ldq < *n) {
+ *info = -12;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -14;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -15;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -16;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -21;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSBGVX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a split Cholesky factorization of B. */
+
+ dpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem. */
+
+ dsbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb,
+ &q[q_offset], ldq, &work[1], &iinfo);
+
+/* Reduce symmetric band matrix to tridiagonal form. */
+
+ indd = 1;
+ inde = indd + *n;
+ indwrk = inde + *n;
+ if (wantz) {
+ *(unsigned char *)vect = 'U';
+ } else {
+ *(unsigned char *)vect = 'N';
+ }
+ dsbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &work[indd], &work[inde],
+ &q[q_offset], ldq, &work[indwrk], &iinfo);
+
+/* If all eigenvalues are desired and ABSTOL is less than or equal */
+/* to zero, then call DSTERF or SSTEQR. If this fails for some */
+/* eigenvalue, then try DSTEBZ. */
+
+ test = FALSE_;
+ if (indeig) {
+ if (*il == 1 && *iu == *n) {
+ test = TRUE_;
+ }
+ }
+ if ((alleig || test) && *abstol <= 0.) {
+ dcopy_(n, &work[indd], &c__1, &w[1], &c__1);
+ indee = indwrk + (*n << 1);
+ i__1 = *n - 1;
+ dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
+ if (! wantz) {
+ dsterf_(n, &w[1], &work[indee], info);
+ } else {
+ dlacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz);
+ dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[
+ indwrk], info);
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ifail[i__] = 0;
+/* L10: */
+ }
+ }
+ }
+ if (*info == 0) {
+ *m = *n;
+ goto L30;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call DSTEBZ and, if eigenvectors are desired, */
+/* call DSTEIN. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ indibl = 1;
+ indisp = indibl + *n;
+ indiwo = indisp + *n;
+ dstebz_(range, order, n, vl, vu, il, iu, abstol, &work[indd], &work[inde],
+ m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[indwrk],
+ &iwork[indiwo], info);
+
+ if (wantz) {
+ dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
+ indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &
+ ifail[1], info);
+
+/* Apply transformation matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by DSTEIN. */
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1);
+ dgemv_("N", n, n, &c_b25, &q[q_offset], ldq, &work[1], &c__1, &
+ c_b27, &z__[j * z_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+
+L30:
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L40: */
+ }
+
+ if (i__ != 0) {
+ itmp1 = iwork[indibl + i__ - 1];
+ w[i__] = w[j];
+ iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
+ w[j] = tmp1;
+ iwork[indibl + j - 1] = itmp1;
+ dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ if (*info != 0) {
+ itmp1 = ifail[i__];
+ ifail[i__] = ifail[j];
+ ifail[j] = itmp1;
+ }
+ }
+/* L50: */
+ }
+ }
+
+ return 0;
+
+/* End of DSBGVX */
+
+} /* dsbgvx_ */
diff --git a/SRC/dsbtrd.c b/SRC/dsbtrd.c
new file mode 100644
index 0000000..70bddbd
--- /dev/null
+++ b/SRC/dsbtrd.c
@@ -0,0 +1,713 @@
+/* dsbtrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b9 = 0.;
+static doublereal c_b10 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dsbtrd_(char *vect, char *uplo, integer *n, integer *kd,
+ doublereal *ab, integer *ldab, doublereal *d__, doublereal *e,
+ doublereal *q, integer *ldq, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, q_dim1, q_offset, i__1, i__2, i__3, i__4,
+ i__5;
+
+ /* Local variables */
+ integer i__, j, k, l, i2, j1, j2, nq, nr, kd1, ibl, iqb, kdn, jin, nrt,
+ kdm1, inca, jend, lend, jinc, incx, last;
+ doublereal temp;
+ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ integer j1end, j1inc, iqend;
+ extern logical lsame_(char *, char *);
+ logical initq, wantq, upper;
+ extern /* Subroutine */ int dlar2v_(integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *);
+ integer iqaend;
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ dlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *), xerbla_(char *, integer *), dlargv_(
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *), dlartv_(integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSBTRD reduces a real symmetric band matrix A to symmetric */
+/* tridiagonal form T by an orthogonal similarity transformation: */
+/* Q**T * A * Q = T. */
+
+/* Arguments */
+/* ========= */
+
+/* VECT (input) CHARACTER*1 */
+/* = 'N': do not form Q; */
+/* = 'V': form Q; */
+/* = 'U': update a matrix X, by forming X*Q. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+/* On exit, the diagonal elements of AB are overwritten by the */
+/* diagonal elements of the tridiagonal matrix T; if KD > 0, the */
+/* elements on the first superdiagonal (if UPLO = 'U') or the */
+/* first subdiagonal (if UPLO = 'L') are overwritten by the */
+/* off-diagonal elements of T; the rest of AB is overwritten by */
+/* values generated during the reduction. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* D (output) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal elements of the tridiagonal matrix T. */
+
+/* E (output) DOUBLE PRECISION array, dimension (N-1) */
+/* The off-diagonal elements of the tridiagonal matrix T: */
+/* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'. */
+
+/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */
+/* On entry, if VECT = 'U', then Q must contain an N-by-N */
+/* matrix X; if VECT = 'N' or 'V', then Q need not be set. */
+
+/* On exit: */
+/* if VECT = 'V', Q contains the N-by-N orthogonal matrix Q; */
+/* if VECT = 'U', Q contains the product X*Q; */
+/* if VECT = 'N', the array Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. */
+/* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* Modified by Linda Kaufman, Bell Labs. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --d__;
+ --e;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+
+ /* Function Body */
+ initq = lsame_(vect, "V");
+ wantq = initq || lsame_(vect, "U");
+ upper = lsame_(uplo, "U");
+ kd1 = *kd + 1;
+ kdm1 = *kd - 1;
+ incx = *ldab - 1;
+ iqend = 1;
+
+ *info = 0;
+ if (! wantq && ! lsame_(vect, "N")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kd < 0) {
+ *info = -4;
+ } else if (*ldab < kd1) {
+ *info = -6;
+ } else if (*ldq < max(1,*n) && wantq) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSBTRD", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Initialize Q to the unit matrix, if needed */
+
+ if (initq) {
+ dlaset_("Full", n, n, &c_b9, &c_b10, &q[q_offset], ldq);
+ }
+
+/* Wherever possible, plane rotations are generated and applied in */
+/* vector operations of length NR over the index set J1:J2:KD1. */
+
+/* The cosines and sines of the plane rotations are stored in the */
+/* arrays D and WORK. */
+
+ inca = kd1 * *ldab;
+/* Computing MIN */
+ i__1 = *n - 1;
+ kdn = min(i__1,*kd);
+ if (upper) {
+
+ if (*kd > 1) {
+
+/* Reduce to tridiagonal form, working with upper triangle */
+
+ nr = 0;
+ j1 = kdn + 2;
+ j2 = 1;
+
+ i__1 = *n - 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Reduce i-th row of matrix to tridiagonal form */
+
+ for (k = kdn + 1; k >= 2; --k) {
+ j1 += kdn;
+ j2 += kdn;
+
+ if (nr > 0) {
+
+/* generate plane rotations to annihilate nonzero */
+/* elements which have been created outside the band */
+
+ dlargv_(&nr, &ab[(j1 - 1) * ab_dim1 + 1], &inca, &
+ work[j1], &kd1, &d__[j1], &kd1);
+
+/* apply rotations from the right */
+
+
+/* Dependent on the the number of diagonals either */
+/* DLARTV or DROT is used */
+
+ if (nr >= (*kd << 1) - 1) {
+ i__2 = *kd - 1;
+ for (l = 1; l <= i__2; ++l) {
+ dlartv_(&nr, &ab[l + 1 + (j1 - 1) * ab_dim1],
+ &inca, &ab[l + j1 * ab_dim1], &inca, &
+ d__[j1], &work[j1], &kd1);
+/* L10: */
+ }
+
+ } else {
+ jend = j1 + (nr - 1) * kd1;
+ i__2 = jend;
+ i__3 = kd1;
+ for (jinc = j1; i__3 < 0 ? jinc >= i__2 : jinc <=
+ i__2; jinc += i__3) {
+ drot_(&kdm1, &ab[(jinc - 1) * ab_dim1 + 2], &
+ c__1, &ab[jinc * ab_dim1 + 1], &c__1,
+ &d__[jinc], &work[jinc]);
+/* L20: */
+ }
+ }
+ }
+
+
+ if (k > 2) {
+ if (k <= *n - i__ + 1) {
+
+/* generate plane rotation to annihilate a(i,i+k-1) */
+/* within the band */
+
+ dlartg_(&ab[*kd - k + 3 + (i__ + k - 2) * ab_dim1]
+, &ab[*kd - k + 2 + (i__ + k - 1) *
+ ab_dim1], &d__[i__ + k - 1], &work[i__ +
+ k - 1], &temp);
+ ab[*kd - k + 3 + (i__ + k - 2) * ab_dim1] = temp;
+
+/* apply rotation from the right */
+
+ i__3 = k - 3;
+ drot_(&i__3, &ab[*kd - k + 4 + (i__ + k - 2) *
+ ab_dim1], &c__1, &ab[*kd - k + 3 + (i__ +
+ k - 1) * ab_dim1], &c__1, &d__[i__ + k -
+ 1], &work[i__ + k - 1]);
+ }
+ ++nr;
+ j1 = j1 - kdn - 1;
+ }
+
+/* apply plane rotations from both sides to diagonal */
+/* blocks */
+
+ if (nr > 0) {
+ dlar2v_(&nr, &ab[kd1 + (j1 - 1) * ab_dim1], &ab[kd1 +
+ j1 * ab_dim1], &ab[*kd + j1 * ab_dim1], &inca,
+ &d__[j1], &work[j1], &kd1);
+ }
+
+/* apply plane rotations from the left */
+
+ if (nr > 0) {
+ if ((*kd << 1) - 1 < nr) {
+
+/* Dependent on the the number of diagonals either */
+/* DLARTV or DROT is used */
+
+ i__3 = *kd - 1;
+ for (l = 1; l <= i__3; ++l) {
+ if (j2 + l > *n) {
+ nrt = nr - 1;
+ } else {
+ nrt = nr;
+ }
+ if (nrt > 0) {
+ dlartv_(&nrt, &ab[*kd - l + (j1 + l) *
+ ab_dim1], &inca, &ab[*kd - l + 1
+ + (j1 + l) * ab_dim1], &inca, &
+ d__[j1], &work[j1], &kd1);
+ }
+/* L30: */
+ }
+ } else {
+ j1end = j1 + kd1 * (nr - 2);
+ if (j1end >= j1) {
+ i__3 = j1end;
+ i__2 = kd1;
+ for (jin = j1; i__2 < 0 ? jin >= i__3 : jin <=
+ i__3; jin += i__2) {
+ i__4 = *kd - 1;
+ drot_(&i__4, &ab[*kd - 1 + (jin + 1) *
+ ab_dim1], &incx, &ab[*kd + (jin +
+ 1) * ab_dim1], &incx, &d__[jin], &
+ work[jin]);
+/* L40: */
+ }
+ }
+/* Computing MIN */
+ i__2 = kdm1, i__3 = *n - j2;
+ lend = min(i__2,i__3);
+ last = j1end + kd1;
+ if (lend > 0) {
+ drot_(&lend, &ab[*kd - 1 + (last + 1) *
+ ab_dim1], &incx, &ab[*kd + (last + 1)
+ * ab_dim1], &incx, &d__[last], &work[
+ last]);
+ }
+ }
+ }
+
+ if (wantq) {
+
+/* accumulate product of plane rotations in Q */
+
+ if (initq) {
+
+/* take advantage of the fact that Q was */
+/* initially the Identity matrix */
+
+ iqend = max(iqend,j2);
+/* Computing MAX */
+ i__2 = 0, i__3 = k - 3;
+ i2 = max(i__2,i__3);
+ iqaend = i__ * *kd + 1;
+ if (k == 2) {
+ iqaend += *kd;
+ }
+ iqaend = min(iqaend,iqend);
+ i__2 = j2;
+ i__3 = kd1;
+ for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j
+ += i__3) {
+ ibl = i__ - i2 / kdm1;
+ ++i2;
+/* Computing MAX */
+ i__4 = 1, i__5 = j - ibl;
+ iqb = max(i__4,i__5);
+ nq = iqaend + 1 - iqb;
+/* Computing MIN */
+ i__4 = iqaend + *kd;
+ iqaend = min(i__4,iqend);
+ drot_(&nq, &q[iqb + (j - 1) * q_dim1], &c__1,
+ &q[iqb + j * q_dim1], &c__1, &d__[j],
+ &work[j]);
+/* L50: */
+ }
+ } else {
+
+ i__3 = j2;
+ i__2 = kd1;
+ for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j
+ += i__2) {
+ drot_(n, &q[(j - 1) * q_dim1 + 1], &c__1, &q[
+ j * q_dim1 + 1], &c__1, &d__[j], &
+ work[j]);
+/* L60: */
+ }
+ }
+
+ }
+
+ if (j2 + kdn > *n) {
+
+/* adjust J2 to keep within the bounds of the matrix */
+
+ --nr;
+ j2 = j2 - kdn - 1;
+ }
+
+ i__2 = j2;
+ i__3 = kd1;
+ for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j += i__3)
+ {
+
+/* create nonzero element a(j-1,j+kd) outside the band */
+/* and store it in WORK */
+
+ work[j + *kd] = work[j] * ab[(j + *kd) * ab_dim1 + 1];
+ ab[(j + *kd) * ab_dim1 + 1] = d__[j] * ab[(j + *kd) *
+ ab_dim1 + 1];
+/* L70: */
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+
+ if (*kd > 0) {
+
+/* copy off-diagonal elements to E */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ e[i__] = ab[*kd + (i__ + 1) * ab_dim1];
+/* L100: */
+ }
+ } else {
+
+/* set E to zero if original matrix was diagonal */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ e[i__] = 0.;
+/* L110: */
+ }
+ }
+
+/* copy diagonal elements to D */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = ab[kd1 + i__ * ab_dim1];
+/* L120: */
+ }
+
+ } else {
+
+ if (*kd > 1) {
+
+/* Reduce to tridiagonal form, working with lower triangle */
+
+ nr = 0;
+ j1 = kdn + 2;
+ j2 = 1;
+
+ i__1 = *n - 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Reduce i-th column of matrix to tridiagonal form */
+
+ for (k = kdn + 1; k >= 2; --k) {
+ j1 += kdn;
+ j2 += kdn;
+
+ if (nr > 0) {
+
+/* generate plane rotations to annihilate nonzero */
+/* elements which have been created outside the band */
+
+ dlargv_(&nr, &ab[kd1 + (j1 - kd1) * ab_dim1], &inca, &
+ work[j1], &kd1, &d__[j1], &kd1);
+
+/* apply plane rotations from one side */
+
+
+/* Dependent on the the number of diagonals either */
+/* DLARTV or DROT is used */
+
+ if (nr > (*kd << 1) - 1) {
+ i__3 = *kd - 1;
+ for (l = 1; l <= i__3; ++l) {
+ dlartv_(&nr, &ab[kd1 - l + (j1 - kd1 + l) *
+ ab_dim1], &inca, &ab[kd1 - l + 1 + (
+ j1 - kd1 + l) * ab_dim1], &inca, &d__[
+ j1], &work[j1], &kd1);
+/* L130: */
+ }
+ } else {
+ jend = j1 + kd1 * (nr - 1);
+ i__3 = jend;
+ i__2 = kd1;
+ for (jinc = j1; i__2 < 0 ? jinc >= i__3 : jinc <=
+ i__3; jinc += i__2) {
+ drot_(&kdm1, &ab[*kd + (jinc - *kd) * ab_dim1]
+, &incx, &ab[kd1 + (jinc - *kd) *
+ ab_dim1], &incx, &d__[jinc], &work[
+ jinc]);
+/* L140: */
+ }
+ }
+
+ }
+
+ if (k > 2) {
+ if (k <= *n - i__ + 1) {
+
+/* generate plane rotation to annihilate a(i+k-1,i) */
+/* within the band */
+
+ dlartg_(&ab[k - 1 + i__ * ab_dim1], &ab[k + i__ *
+ ab_dim1], &d__[i__ + k - 1], &work[i__ +
+ k - 1], &temp);
+ ab[k - 1 + i__ * ab_dim1] = temp;
+
+/* apply rotation from the left */
+
+ i__2 = k - 3;
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ drot_(&i__2, &ab[k - 2 + (i__ + 1) * ab_dim1], &
+ i__3, &ab[k - 1 + (i__ + 1) * ab_dim1], &
+ i__4, &d__[i__ + k - 1], &work[i__ + k -
+ 1]);
+ }
+ ++nr;
+ j1 = j1 - kdn - 1;
+ }
+
+/* apply plane rotations from both sides to diagonal */
+/* blocks */
+
+ if (nr > 0) {
+ dlar2v_(&nr, &ab[(j1 - 1) * ab_dim1 + 1], &ab[j1 *
+ ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 + 2], &
+ inca, &d__[j1], &work[j1], &kd1);
+ }
+
+/* apply plane rotations from the right */
+
+
+/* Dependent on the the number of diagonals either */
+/* DLARTV or DROT is used */
+
+ if (nr > 0) {
+ if (nr > (*kd << 1) - 1) {
+ i__2 = *kd - 1;
+ for (l = 1; l <= i__2; ++l) {
+ if (j2 + l > *n) {
+ nrt = nr - 1;
+ } else {
+ nrt = nr;
+ }
+ if (nrt > 0) {
+ dlartv_(&nrt, &ab[l + 2 + (j1 - 1) *
+ ab_dim1], &inca, &ab[l + 1 + j1 *
+ ab_dim1], &inca, &d__[j1], &work[
+ j1], &kd1);
+ }
+/* L150: */
+ }
+ } else {
+ j1end = j1 + kd1 * (nr - 2);
+ if (j1end >= j1) {
+ i__2 = j1end;
+ i__3 = kd1;
+ for (j1inc = j1; i__3 < 0 ? j1inc >= i__2 :
+ j1inc <= i__2; j1inc += i__3) {
+ drot_(&kdm1, &ab[(j1inc - 1) * ab_dim1 +
+ 3], &c__1, &ab[j1inc * ab_dim1 +
+ 2], &c__1, &d__[j1inc], &work[
+ j1inc]);
+/* L160: */
+ }
+ }
+/* Computing MIN */
+ i__3 = kdm1, i__2 = *n - j2;
+ lend = min(i__3,i__2);
+ last = j1end + kd1;
+ if (lend > 0) {
+ drot_(&lend, &ab[(last - 1) * ab_dim1 + 3], &
+ c__1, &ab[last * ab_dim1 + 2], &c__1,
+ &d__[last], &work[last]);
+ }
+ }
+ }
+
+
+
+ if (wantq) {
+
+/* accumulate product of plane rotations in Q */
+
+ if (initq) {
+
+/* take advantage of the fact that Q was */
+/* initially the Identity matrix */
+
+ iqend = max(iqend,j2);
+/* Computing MAX */
+ i__3 = 0, i__2 = k - 3;
+ i2 = max(i__3,i__2);
+ iqaend = i__ * *kd + 1;
+ if (k == 2) {
+ iqaend += *kd;
+ }
+ iqaend = min(iqaend,iqend);
+ i__3 = j2;
+ i__2 = kd1;
+ for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j
+ += i__2) {
+ ibl = i__ - i2 / kdm1;
+ ++i2;
+/* Computing MAX */
+ i__4 = 1, i__5 = j - ibl;
+ iqb = max(i__4,i__5);
+ nq = iqaend + 1 - iqb;
+/* Computing MIN */
+ i__4 = iqaend + *kd;
+ iqaend = min(i__4,iqend);
+ drot_(&nq, &q[iqb + (j - 1) * q_dim1], &c__1,
+ &q[iqb + j * q_dim1], &c__1, &d__[j],
+ &work[j]);
+/* L170: */
+ }
+ } else {
+
+ i__2 = j2;
+ i__3 = kd1;
+ for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j
+ += i__3) {
+ drot_(n, &q[(j - 1) * q_dim1 + 1], &c__1, &q[
+ j * q_dim1 + 1], &c__1, &d__[j], &
+ work[j]);
+/* L180: */
+ }
+ }
+ }
+
+ if (j2 + kdn > *n) {
+
+/* adjust J2 to keep within the bounds of the matrix */
+
+ --nr;
+ j2 = j2 - kdn - 1;
+ }
+
+ i__3 = j2;
+ i__2 = kd1;
+ for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2)
+ {
+
+/* create nonzero element a(j+kd,j-1) outside the */
+/* band and store it in WORK */
+
+ work[j + *kd] = work[j] * ab[kd1 + j * ab_dim1];
+ ab[kd1 + j * ab_dim1] = d__[j] * ab[kd1 + j * ab_dim1]
+ ;
+/* L190: */
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+ }
+
+ if (*kd > 0) {
+
+/* copy off-diagonal elements to E */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ e[i__] = ab[i__ * ab_dim1 + 2];
+/* L220: */
+ }
+ } else {
+
+/* set E to zero if original matrix was diagonal */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ e[i__] = 0.;
+/* L230: */
+ }
+ }
+
+/* copy diagonal elements to D */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = ab[i__ * ab_dim1 + 1];
+/* L240: */
+ }
+ }
+
+ return 0;
+
+/* End of DSBTRD */
+
+} /* dsbtrd_ */
diff --git a/SRC/dsfrk.c b/SRC/dsfrk.c
new file mode 100644
index 0000000..53c9268
--- /dev/null
+++ b/SRC/dsfrk.c
@@ -0,0 +1,517 @@
+/* dsfrk.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dsfrk_(char *transr, char *uplo, char *trans, integer *n,
+ integer *k, doublereal *alpha, doublereal *a, integer *lda,
+ doublereal *beta, doublereal *c__)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+
+ /* Local variables */
+ integer j, n1, n2, nk, info;
+ logical normaltransr;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ integer nrowa;
+ logical lower;
+ extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *), xerbla_(char *, integer *);
+ logical nisodd, notrans;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Level 3 BLAS like routine for C in RFP Format. */
+
+/* DSFRK performs one of the symmetric rank--k operations */
+
+/* C := alpha*A*A' + beta*C, */
+
+/* or */
+
+/* C := alpha*A'*A + beta*C, */
+
+/* where alpha and beta are real scalars, C is an n--by--n symmetric */
+/* matrix and A is an n--by--k matrix in the first case and a k--by--n */
+/* matrix in the second case. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': The Normal Form of RFP A is stored; */
+/* = 'T': The Transpose Form of RFP A is stored. */
+
+/* UPLO - (input) CHARACTER */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array C is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of C */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of C */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* TRANS - (input) CHARACTER */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. */
+
+/* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. */
+
+/* Unchanged on exit. */
+
+/* N - (input) INTEGER. */
+/* On entry, N specifies the order of the matrix C. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* K - (input) INTEGER. */
+/* On entry with TRANS = 'N' or 'n', K specifies the number */
+/* of columns of the matrix A, and on entry with TRANS = 'T' */
+/* or 't', K specifies the number of rows of the matrix A. K */
+/* must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - (input) DOUBLE PRECISION. */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - (input) DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where KA */
+/* is K when TRANS = 'N' or 'n', and is N otherwise. Before */
+/* entry with TRANS = 'N' or 'n', the leading N--by--K part of */
+/* the array A must contain the matrix A, otherwise the leading */
+/* K--by--N part of the array A must contain the matrix A. */
+/* Unchanged on exit. */
+
+/* LDA - (input) INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When TRANS = 'N' or 'n' */
+/* then LDA must be at least max( 1, n ), otherwise LDA must */
+/* be at least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* BETA - (input) DOUBLE PRECISION. */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+
+/* C - (input/output) DOUBLE PRECISION array, dimension ( NT ); */
+/* NT = N*(N+1)/2. On entry, the symmetric matrix C in RFP */
+/* Format. RFP Format is described by TRANSR, UPLO and N. */
+
+/* Arguments */
+/* ========== */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --c__;
+
+ /* Function Body */
+ info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ notrans = lsame_(trans, "N");
+
+ if (notrans) {
+ nrowa = *n;
+ } else {
+ nrowa = *k;
+ }
+
+ if (! normaltransr && ! lsame_(transr, "T")) {
+ info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ info = -2;
+ } else if (! notrans && ! lsame_(trans, "T")) {
+ info = -3;
+ } else if (*n < 0) {
+ info = -4;
+ } else if (*k < 0) {
+ info = -5;
+ } else if (*lda < max(1,nrowa)) {
+ info = -8;
+ }
+ if (info != 0) {
+ i__1 = -info;
+ xerbla_("DSFRK ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+/* The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not */
+/* done (it is in DSYRK for example) and left in the general case. */
+
+ if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
+ return 0;
+ }
+
+ if (*alpha == 0. && *beta == 0.) {
+ i__1 = *n * (*n + 1) / 2;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 0.;
+ }
+ return 0;
+ }
+
+/* C is N-by-N. */
+/* If N is odd, set NISODD = .TRUE., and N1 and N2. */
+/* If N is even, NISODD = .FALSE., and NK. */
+
+ if (*n % 2 == 0) {
+ nisodd = FALSE_;
+ nk = *n / 2;
+ } else {
+ nisodd = TRUE_;
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+ }
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* N is odd, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' */
+
+ dsyrk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[1], n);
+ dsyrk_("U", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda,
+ beta, &c__[*n + 1], n);
+ dgemm_("N", "T", &n2, &n1, k, alpha, &a[n1 + 1 + a_dim1],
+ lda, &a[a_dim1 + 1], lda, beta, &c__[n1 + 1], n);
+
+ } else {
+
+/* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'T' */
+
+ dsyrk_("L", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[1], n);
+ dsyrk_("U", "T", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1],
+ lda, beta, &c__[*n + 1], n)
+ ;
+ dgemm_("T", "N", &n2, &n1, k, alpha, &a[(n1 + 1) * a_dim1
+ + 1], lda, &a[a_dim1 + 1], lda, beta, &c__[n1 + 1]
+, n);
+
+ }
+
+ } else {
+
+/* N is odd, TRANSR = 'N', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' */
+
+ dsyrk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[n2 + 1], n);
+ dsyrk_("U", "N", &n2, k, alpha, &a[n2 + a_dim1], lda,
+ beta, &c__[n1 + 1], n);
+ dgemm_("N", "T", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda,
+ &a[n2 + a_dim1], lda, beta, &c__[1], n);
+
+ } else {
+
+/* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'T' */
+
+ dsyrk_("L", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[n2 + 1], n);
+ dsyrk_("U", "T", &n2, k, alpha, &a[n2 * a_dim1 + 1], lda,
+ beta, &c__[n1 + 1], n);
+ dgemm_("T", "N", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda,
+ &a[n2 * a_dim1 + 1], lda, beta, &c__[1], n);
+
+ }
+
+ }
+
+ } else {
+
+/* N is odd, and TRANSR = 'T' */
+
+ if (lower) {
+
+/* N is odd, TRANSR = 'T', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'N' */
+
+ dsyrk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[1], &n1);
+ dsyrk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda,
+ beta, &c__[2], &n1);
+ dgemm_("N", "T", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda,
+ &a[n1 + 1 + a_dim1], lda, beta, &c__[n1 * n1 + 1],
+ &n1);
+
+ } else {
+
+/* N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'T' */
+
+ dsyrk_("U", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[1], &n1);
+ dsyrk_("L", "T", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1],
+ lda, beta, &c__[2], &n1);
+ dgemm_("T", "N", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda,
+ &a[(n1 + 1) * a_dim1 + 1], lda, beta, &c__[n1 *
+ n1 + 1], &n1);
+
+ }
+
+ } else {
+
+/* N is odd, TRANSR = 'T', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'N' */
+
+ dsyrk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[n2 * n2 + 1], &n2);
+ dsyrk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda,
+ beta, &c__[n1 * n2 + 1], &n2);
+ dgemm_("N", "T", &n2, &n1, k, alpha, &a[n1 + 1 + a_dim1],
+ lda, &a[a_dim1 + 1], lda, beta, &c__[1], &n2);
+
+ } else {
+
+/* N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'T' */
+
+ dsyrk_("U", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[n2 * n2 + 1], &n2);
+ dsyrk_("L", "T", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1],
+ lda, beta, &c__[n1 * n2 + 1], &n2);
+ dgemm_("T", "N", &n2, &n1, k, alpha, &a[(n1 + 1) * a_dim1
+ + 1], lda, &a[a_dim1 + 1], lda, beta, &c__[1], &
+ n2);
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* N is even, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' */
+
+ i__1 = *n + 1;
+ dsyrk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[2], &i__1);
+ i__1 = *n + 1;
+ dsyrk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
+ beta, &c__[1], &i__1);
+ i__1 = *n + 1;
+ dgemm_("N", "T", &nk, &nk, k, alpha, &a[nk + 1 + a_dim1],
+ lda, &a[a_dim1 + 1], lda, beta, &c__[nk + 2], &
+ i__1);
+
+ } else {
+
+/* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'T' */
+
+ i__1 = *n + 1;
+ dsyrk_("L", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[2], &i__1);
+ i__1 = *n + 1;
+ dsyrk_("U", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
+ lda, beta, &c__[1], &i__1);
+ i__1 = *n + 1;
+ dgemm_("T", "N", &nk, &nk, k, alpha, &a[(nk + 1) * a_dim1
+ + 1], lda, &a[a_dim1 + 1], lda, beta, &c__[nk + 2]
+, &i__1);
+
+ }
+
+ } else {
+
+/* N is even, TRANSR = 'N', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' */
+
+ i__1 = *n + 1;
+ dsyrk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk + 2], &i__1);
+ i__1 = *n + 1;
+ dsyrk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
+ beta, &c__[nk + 1], &i__1);
+ i__1 = *n + 1;
+ dgemm_("N", "T", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda,
+ &a[nk + 1 + a_dim1], lda, beta, &c__[1], &i__1);
+
+ } else {
+
+/* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'T' */
+
+ i__1 = *n + 1;
+ dsyrk_("L", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk + 2], &i__1);
+ i__1 = *n + 1;
+ dsyrk_("U", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
+ lda, beta, &c__[nk + 1], &i__1);
+ i__1 = *n + 1;
+ dgemm_("T", "N", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda,
+ &a[(nk + 1) * a_dim1 + 1], lda, beta, &c__[1], &
+ i__1);
+
+ }
+
+ }
+
+ } else {
+
+/* N is even, and TRANSR = 'T' */
+
+ if (lower) {
+
+/* N is even, TRANSR = 'T', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'N' */
+
+ dsyrk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk + 1], &nk);
+ dsyrk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
+ beta, &c__[1], &nk);
+ dgemm_("N", "T", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda,
+ &a[nk + 1 + a_dim1], lda, beta, &c__[(nk + 1) *
+ nk + 1], &nk);
+
+ } else {
+
+/* N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'T' */
+
+ dsyrk_("U", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk + 1], &nk);
+ dsyrk_("L", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
+ lda, beta, &c__[1], &nk);
+ dgemm_("T", "N", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda,
+ &a[(nk + 1) * a_dim1 + 1], lda, beta, &c__[(nk +
+ 1) * nk + 1], &nk);
+
+ }
+
+ } else {
+
+/* N is even, TRANSR = 'T', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'N' */
+
+ dsyrk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk * (nk + 1) + 1], &nk);
+ dsyrk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
+ beta, &c__[nk * nk + 1], &nk);
+ dgemm_("N", "T", &nk, &nk, k, alpha, &a[nk + 1 + a_dim1],
+ lda, &a[a_dim1 + 1], lda, beta, &c__[1], &nk);
+
+ } else {
+
+/* N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'T' */
+
+ dsyrk_("U", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk * (nk + 1) + 1], &nk);
+ dsyrk_("L", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
+ lda, beta, &c__[nk * nk + 1], &nk);
+ dgemm_("T", "N", &nk, &nk, k, alpha, &a[(nk + 1) * a_dim1
+ + 1], lda, &a[a_dim1 + 1], lda, beta, &c__[1], &
+ nk);
+
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of DSFRK */
+
+} /* dsfrk_ */
diff --git a/SRC/dsgesv.c b/SRC/dsgesv.c
new file mode 100644
index 0000000..44252af
--- /dev/null
+++ b/SRC/dsgesv.c
@@ -0,0 +1,416 @@
+/* dsgesv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b10 = -1.;
+static doublereal c_b11 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dsgesv_(integer *n, integer *nrhs, doublereal *a,
+ integer *lda, integer *ipiv, doublereal *b, integer *ldb, doublereal *
+ x, integer *ldx, doublereal *work, real *swork, integer *iter,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, work_dim1, work_offset,
+ x_dim1, x_offset, i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal cte, eps, anrm;
+ integer ptsa;
+ doublereal rnrm, xnrm;
+ integer ptsx;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ integer iiter;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *), dlag2s_(integer *, integer *,
+ doublereal *, integer *, real *, integer *, integer *), slag2d_(
+ integer *, integer *, real *, integer *, doublereal *, integer *,
+ integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *), dgetrf_(integer *, integer *,
+ doublereal *, integer *, integer *, integer *), dgetrs_(char *,
+ integer *, integer *, doublereal *, integer *, integer *,
+ doublereal *, integer *, integer *), sgetrf_(integer *,
+ integer *, real *, integer *, integer *, integer *), sgetrs_(char
+ *, integer *, integer *, real *, integer *, integer *, real *,
+ integer *, integer *);
+
+
+/* -- LAPACK PROTOTYPE driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2007 */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSGESV computes the solution to a real system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */
+
+/* DSGESV first attempts to factorize the matrix in SINGLE PRECISION */
+/* and use this factorization within an iterative refinement procedure */
+/* to produce a solution with DOUBLE PRECISION normwise backward error */
+/* quality (see below). If the approach fails the method switches to a */
+/* DOUBLE PRECISION factorization and solve. */
+
+/* The iterative refinement is not going to be a winning strategy if */
+/* the ratio SINGLE PRECISION performance over DOUBLE PRECISION */
+/* performance is too small. A reasonable strategy should take the */
+/* number of right-hand sides and the size of the matrix into account. */
+/* This might be done with a call to ILAENV in the future. Up to now, we */
+/* always try iterative refinement. */
+
+/* The iterative refinement process is stopped if */
+/* ITER > ITERMAX */
+/* or for all the RHS we have: */
+/* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX */
+/* where */
+/* o ITER is the number of the current iteration in the iterative */
+/* refinement process */
+/* o RNRM is the infinity-norm of the residual */
+/* o XNRM is the infinity-norm of the solution */
+/* o ANRM is the infinity-operator-norm of the matrix A */
+/* o EPS is the machine epsilon returned by DLAMCH('Epsilon') */
+/* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 */
+/* respectively. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input or input/ouptut) DOUBLE PRECISION array, */
+/* dimension (LDA,N) */
+/* On entry, the N-by-N coefficient matrix A. */
+/* On exit, if iterative refinement has been successfully used */
+/* (INFO.EQ.0 and ITER.GE.0, see description below), then A is */
+/* unchanged, if double precision factorization has been used */
+/* (INFO.EQ.0 and ITER.LT.0, see description below), then the */
+/* array A contains the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* The pivot indices that define the permutation matrix P; */
+/* row i of the matrix was interchanged with row IPIV(i). */
+/* Corresponds either to the single precision factorization */
+/* (if INFO.EQ.0 and ITER.GE.0) or the double precision */
+/* factorization (if INFO.EQ.0 and ITER.LT.0). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* If INFO = 0, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N*NRHS) */
+/* This array is used to hold the residual vectors. */
+
+/* SWORK (workspace) REAL array, dimension (N*(N+NRHS)) */
+/* This array is used to use the single precision matrix and the */
+/* right-hand sides or solutions in single precision. */
+
+/* ITER (output) INTEGER */
+/* < 0: iterative refinement has failed, double precision */
+/* factorization has been performed */
+/* -1 : the routine fell back to full precision for */
+/* implementation- or machine-specific reasons */
+/* -2 : narrowing the precision induced an overflow, */
+/* the routine fell back to full precision */
+/* -3 : failure of SGETRF */
+/* -31: stop the iterative refinement after the 30th */
+/* iterations */
+/* > 0: iterative refinement has been sucessfully used. */
+/* Returns the number of iterations */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) computed in DOUBLE PRECISION is */
+/* exactly zero. The factorization has been completed, */
+/* but the factor U is exactly singular, so the solution */
+/* could not be computed. */
+
+/* ========= */
+
+/* .. Parameters .. */
+
+
+
+
+/* .. Local Scalars .. */
+
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ work_dim1 = *n;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --swork;
+
+ /* Function Body */
+ *info = 0;
+ *iter = 0;
+
+/* Test the input parameters. */
+
+ if (*n < 0) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldx < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSGESV", &i__1);
+ return 0;
+ }
+
+/* Quick return if (N.EQ.0). */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Skip single precision iterative refinement if a priori slower */
+/* than double precision factorization. */
+
+ if (FALSE_) {
+ *iter = -1;
+ goto L40;
+ }
+
+/* Compute some constants. */
+
+ anrm = dlange_("I", n, n, &a[a_offset], lda, &work[work_offset]);
+ eps = dlamch_("Epsilon");
+ cte = anrm * eps * sqrt((doublereal) (*n)) * 1.;
+
+/* Set the indices PTSA, PTSX for referencing SA and SX in SWORK. */
+
+ ptsa = 1;
+ ptsx = ptsa + *n * *n;
+
+/* Convert B from double precision to single precision and store the */
+/* result in SX. */
+
+ dlag2s_(n, nrhs, &b[b_offset], ldb, &swork[ptsx], n, info);
+
+ if (*info != 0) {
+ *iter = -2;
+ goto L40;
+ }
+
+/* Convert A from double precision to single precision and store the */
+/* result in SA. */
+
+ dlag2s_(n, n, &a[a_offset], lda, &swork[ptsa], n, info);
+
+ if (*info != 0) {
+ *iter = -2;
+ goto L40;
+ }
+
+/* Compute the LU factorization of SA. */
+
+ sgetrf_(n, n, &swork[ptsa], n, &ipiv[1], info);
+
+ if (*info != 0) {
+ *iter = -3;
+ goto L40;
+ }
+
+/* Solve the system SA*SX = SB. */
+
+ sgetrs_("No transpose", n, nrhs, &swork[ptsa], n, &ipiv[1], &swork[ptsx],
+ n, info);
+
+/* Convert SX back to double precision */
+
+ slag2d_(n, nrhs, &swork[ptsx], n, &x[x_offset], ldx, info);
+
+/* Compute R = B - AX (R is WORK). */
+
+ dlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n);
+
+ dgemm_("No Transpose", "No Transpose", n, nrhs, n, &c_b10, &a[a_offset],
+ lda, &x[x_offset], ldx, &c_b11, &work[work_offset], n);
+
+/* Check whether the NRHS normwise backward errors satisfy the */
+/* stopping criterion. If yes, set ITER=0 and return. */
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xnrm = (d__1 = x[idamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ *
+ x_dim1], abs(d__1));
+ rnrm = (d__1 = work[idamax_(n, &work[i__ * work_dim1 + 1], &c__1) +
+ i__ * work_dim1], abs(d__1));
+ if (rnrm > xnrm * cte) {
+ goto L10;
+ }
+ }
+
+/* If we are here, the NRHS normwise backward errors satisfy the */
+/* stopping criterion. We are good to exit. */
+
+ *iter = 0;
+ return 0;
+
+L10:
+
+ for (iiter = 1; iiter <= 30; ++iiter) {
+
+/* Convert R (in WORK) from double precision to single precision */
+/* and store the result in SX. */
+
+ dlag2s_(n, nrhs, &work[work_offset], n, &swork[ptsx], n, info);
+
+ if (*info != 0) {
+ *iter = -2;
+ goto L40;
+ }
+
+/* Solve the system SA*SX = SR. */
+
+ sgetrs_("No transpose", n, nrhs, &swork[ptsa], n, &ipiv[1], &swork[
+ ptsx], n, info);
+
+/* Convert SX back to double precision and update the current */
+/* iterate. */
+
+ slag2d_(n, nrhs, &swork[ptsx], n, &work[work_offset], n, info);
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ daxpy_(n, &c_b11, &work[i__ * work_dim1 + 1], &c__1, &x[i__ *
+ x_dim1 + 1], &c__1);
+ }
+
+/* Compute R = B - AX (R is WORK). */
+
+ dlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n);
+
+ dgemm_("No Transpose", "No Transpose", n, nrhs, n, &c_b10, &a[
+ a_offset], lda, &x[x_offset], ldx, &c_b11, &work[work_offset],
+ n);
+
+/* Check whether the NRHS normwise backward errors satisfy the */
+/* stopping criterion. If yes, set ITER=IITER>0 and return. */
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xnrm = (d__1 = x[idamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ *
+ x_dim1], abs(d__1));
+ rnrm = (d__1 = work[idamax_(n, &work[i__ * work_dim1 + 1], &c__1)
+ + i__ * work_dim1], abs(d__1));
+ if (rnrm > xnrm * cte) {
+ goto L20;
+ }
+ }
+
+/* If we are here, the NRHS normwise backward errors satisfy the */
+/* stopping criterion, we are good to exit. */
+
+ *iter = iiter;
+
+ return 0;
+
+L20:
+
+/* L30: */
+ ;
+ }
+
+/* If we are at this place of the code, this is because we have */
+/* performed ITER=ITERMAX iterations and never satisified the */
+/* stopping criterion, set up the ITER flag accordingly and follow up */
+/* on double precision routine. */
+
+ *iter = -31;
+
+L40:
+
+/* Single-precision iterative refinement failed to converge to a */
+/* satisfactory solution, so we resort to double precision. */
+
+ dgetrf_(n, n, &a[a_offset], lda, &ipiv[1], info);
+
+ if (*info != 0) {
+ return 0;
+ }
+
+ dlacpy_("All", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ dgetrs_("No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &x[x_offset]
+, ldx, info);
+
+ return 0;
+
+/* End of DSGESV. */
+
+} /* dsgesv_ */
diff --git a/SRC/dspcon.c b/SRC/dspcon.c
new file mode 100644
index 0000000..5a826cd
--- /dev/null
+++ b/SRC/dspcon.c
@@ -0,0 +1,198 @@
+/* dspcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dspcon_(char *uplo, integer *n, doublereal *ap, integer *
+ ipiv, doublereal *anorm, doublereal *rcond, doublereal *work, integer
+ *iwork, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, ip, kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *), xerbla_(char *,
+ integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int dsptrs_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSPCON estimates the reciprocal of the condition number (in the */
+/* 1-norm) of a real symmetric packed matrix A using the factorization */
+/* A = U*D*U**T or A = L*D*L**T computed by DSPTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by DSPTRF, stored as a */
+/* packed triangular matrix. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by DSPTRF. */
+
+/* ANORM (input) DOUBLE PRECISION */
+/* The 1-norm of the original matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --ipiv;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*anorm < 0.) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSPCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.;
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ } else if (*anorm <= 0.) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ ip = *n * (*n + 1) / 2;
+ for (i__ = *n; i__ >= 1; --i__) {
+ if (ipiv[i__] > 0 && ap[ip] == 0.) {
+ return 0;
+ }
+ ip -= i__;
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ ip = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (ipiv[i__] > 0 && ap[ip] == 0.) {
+ return 0;
+ }
+ ip = ip + *n - i__ + 1;
+/* L20: */
+ }
+ }
+
+/* Estimate the 1-norm of the inverse. */
+
+ kase = 0;
+L30:
+ dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+
+/* Multiply by inv(L*D*L') or inv(U*D*U'). */
+
+ dsptrs_(uplo, n, &c__1, &ap[1], &ipiv[1], &work[1], n, info);
+ goto L30;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / ainvnm / *anorm;
+ }
+
+ return 0;
+
+/* End of DSPCON */
+
+} /* dspcon_ */
diff --git a/SRC/dspev.c b/SRC/dspev.c
new file mode 100644
index 0000000..3e9d3c1
--- /dev/null
+++ b/SRC/dspev.c
@@ -0,0 +1,246 @@
+/* dspev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dspev_(char *jobz, char *uplo, integer *n, doublereal *
+ ap, doublereal *w, doublereal *z__, integer *ldz, doublereal *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal eps;
+ integer inde;
+ doublereal anrm;
+ integer imax;
+ doublereal rmin, rmax;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical wantz;
+ extern doublereal dlamch_(char *);
+ integer iscale;
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ extern doublereal dlansp_(char *, char *, integer *, doublereal *,
+ doublereal *);
+ integer indtau;
+ extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
+ integer *);
+ integer indwrk;
+ extern /* Subroutine */ int dopgtr_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *), dsptrd_(char *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *), dsteqr_(char *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+ doublereal smlnum;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSPEV computes all the eigenvalues and, optionally, eigenvectors of a */
+/* real symmetric matrix A in packed storage. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, AP is overwritten by values generated during the */
+/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */
+/* and first superdiagonal of the tridiagonal matrix T overwrite */
+/* the corresponding elements of A, and if UPLO = 'L', the */
+/* diagonal and first subdiagonal of T overwrite the */
+/* corresponding elements of A. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
+/* eigenvectors of the matrix A, with the i-th column of Z */
+/* holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of an intermediate tridiagonal */
+/* form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lsame_(uplo, "U") || lsame_(uplo,
+ "L"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -7;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSPEV ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ w[1] = ap[1];
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = dlansp_("M", uplo, n, &ap[1], &work[1]);
+ iscale = 0;
+ if (anrm > 0. && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ i__1 = *n * (*n + 1) / 2;
+ dscal_(&i__1, &sigma, &ap[1], &c__1);
+ }
+
+/* Call DSPTRD to reduce symmetric packed matrix to tridiagonal form. */
+
+ inde = 1;
+ indtau = inde + *n;
+ dsptrd_(uplo, n, &ap[1], &w[1], &work[inde], &work[indtau], &iinfo);
+
+/* For eigenvalues only, call DSTERF. For eigenvectors, first call */
+/* DOPGTR to generate the orthogonal matrix, then call DSTEQR. */
+
+ if (! wantz) {
+ dsterf_(n, &w[1], &work[inde], info);
+ } else {
+ indwrk = indtau + *n;
+ dopgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &work[
+ indwrk], &iinfo);
+ dsteqr_(jobz, n, &w[1], &work[inde], &z__[z_offset], ldz, &work[
+ indtau], info);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *n;
+ } else {
+ imax = *info - 1;
+ }
+ d__1 = 1. / sigma;
+ dscal_(&imax, &d__1, &w[1], &c__1);
+ }
+
+ return 0;
+
+/* End of DSPEV */
+
+} /* dspev_ */
diff --git a/SRC/dspevd.c b/SRC/dspevd.c
new file mode 100644
index 0000000..ff663f9
--- /dev/null
+++ b/SRC/dspevd.c
@@ -0,0 +1,314 @@
+/* dspevd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dspevd_(char *jobz, char *uplo, integer *n, doublereal *
+ ap, doublereal *w, doublereal *z__, integer *ldz, doublereal *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal eps;
+ integer inde;
+ doublereal anrm, rmin, rmax;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo, lwmin;
+ logical wantz;
+ extern doublereal dlamch_(char *);
+ integer iscale;
+ extern /* Subroutine */ int dstedc_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *, integer *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ extern doublereal dlansp_(char *, char *, integer *, doublereal *,
+ doublereal *);
+ integer indtau;
+ extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
+ integer *);
+ integer indwrk, liwmin;
+ extern /* Subroutine */ int dsptrd_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ dopmtr_(char *, char *, char *, integer *, integer *, doublereal *
+, doublereal *, doublereal *, integer *, doublereal *, integer *);
+ integer llwork;
+ doublereal smlnum;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSPEVD computes all the eigenvalues and, optionally, eigenvectors */
+/* of a real symmetric matrix A in packed storage. If eigenvectors are */
+/* desired, it uses a divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, AP is overwritten by values generated during the */
+/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */
+/* and first superdiagonal of the tridiagonal matrix T overwrite */
+/* the corresponding elements of A, and if UPLO = 'L', the */
+/* diagonal and first subdiagonal of T overwrite the */
+/* corresponding elements of A. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
+/* eigenvectors of the matrix A, with the i-th column of Z */
+/* holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, */
+/* dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns the required LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If N <= 1, LWORK must be at least 1. */
+/* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N. */
+/* If JOBZ = 'V' and N > 1, LWORK must be at least */
+/* 1 + 6*N + N**2. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the required sizes of the WORK and IWORK */
+/* arrays, returns these values as the first entries of the WORK */
+/* and IWORK arrays, and no error message related to LWORK or */
+/* LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the required LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. */
+/* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the required sizes of the WORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK and IWORK arrays, and no error message related to */
+/* LWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of an intermediate tridiagonal */
+/* form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ lquery = *lwork == -1 || *liwork == -1;
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lsame_(uplo, "U") || lsame_(uplo,
+ "L"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -7;
+ }
+
+ if (*info == 0) {
+ if (*n <= 1) {
+ liwmin = 1;
+ lwmin = 1;
+ } else {
+ if (wantz) {
+ liwmin = *n * 5 + 3;
+/* Computing 2nd power */
+ i__1 = *n;
+ lwmin = *n * 6 + 1 + i__1 * i__1;
+ } else {
+ liwmin = 1;
+ lwmin = *n << 1;
+ }
+ }
+ iwork[1] = liwmin;
+ work[1] = (doublereal) lwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -9;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -11;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSPEVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ w[1] = ap[1];
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = dlansp_("M", uplo, n, &ap[1], &work[1]);
+ iscale = 0;
+ if (anrm > 0. && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ i__1 = *n * (*n + 1) / 2;
+ dscal_(&i__1, &sigma, &ap[1], &c__1);
+ }
+
+/* Call DSPTRD to reduce symmetric packed matrix to tridiagonal form. */
+
+ inde = 1;
+ indtau = inde + *n;
+ dsptrd_(uplo, n, &ap[1], &w[1], &work[inde], &work[indtau], &iinfo);
+
+/* For eigenvalues only, call DSTERF. For eigenvectors, first call */
+/* DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the */
+/* tridiagonal matrix, then call DOPMTR to multiply it by the */
+/* Householder transformations represented in AP. */
+
+ if (! wantz) {
+ dsterf_(n, &w[1], &work[inde], info);
+ } else {
+ indwrk = indtau + *n;
+ llwork = *lwork - indwrk + 1;
+ dstedc_("I", n, &w[1], &work[inde], &z__[z_offset], ldz, &work[indwrk]
+, &llwork, &iwork[1], liwork, info);
+ dopmtr_("L", uplo, "N", n, n, &ap[1], &work[indtau], &z__[z_offset],
+ ldz, &work[indwrk], &iinfo);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ d__1 = 1. / sigma;
+ dscal_(n, &d__1, &w[1], &c__1);
+ }
+
+ work[1] = (doublereal) lwmin;
+ iwork[1] = liwmin;
+ return 0;
+
+/* End of DSPEVD */
+
+} /* dspevd_ */
diff --git a/SRC/dspevx.c b/SRC/dspevx.c
new file mode 100644
index 0000000..f1f6053
--- /dev/null
+++ b/SRC/dspevx.c
@@ -0,0 +1,467 @@
+/* dspevx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dspevx_(char *jobz, char *range, char *uplo, integer *n,
+ doublereal *ap, doublereal *vl, doublereal *vu, integer *il, integer *
+ iu, doublereal *abstol, integer *m, doublereal *w, doublereal *z__,
+ integer *ldz, doublereal *work, integer *iwork, integer *ifail,
+ integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, jj;
+ doublereal eps, vll, vuu, tmp1;
+ integer indd, inde;
+ doublereal anrm;
+ integer imax;
+ doublereal rmin, rmax;
+ logical test;
+ integer itmp1, indee;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ char order[1];
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dswap_(integer *, doublereal *, integer
+ *, doublereal *, integer *);
+ logical wantz;
+ extern doublereal dlamch_(char *);
+ logical alleig, indeig;
+ integer iscale, indibl;
+ logical valeig;
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal abstll, bignum;
+ extern doublereal dlansp_(char *, char *, integer *, doublereal *,
+ doublereal *);
+ integer indtau, indisp;
+ extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, integer *),
+ dsterf_(integer *, doublereal *, doublereal *, integer *);
+ integer indiwo;
+ extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal
+ *, doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, integer *);
+ integer indwrk;
+ extern /* Subroutine */ int dopgtr_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *), dsptrd_(char *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *), dsteqr_(char *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), dopmtr_(char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *);
+ integer nsplit;
+ doublereal smlnum;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSPEVX computes selected eigenvalues and, optionally, eigenvectors */
+/* of a real symmetric matrix A in packed storage. Eigenvalues/vectors */
+/* can be selected by specifying either a range of values or a range of */
+/* indices for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found; */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found; */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, AP is overwritten by values generated during the */
+/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */
+/* and first superdiagonal of the tridiagonal matrix T overwrite */
+/* the corresponding elements of A, and if UPLO = 'L', the */
+/* diagonal and first subdiagonal of T overwrite the */
+/* corresponding elements of A. */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) DOUBLE PRECISION */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing AP to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*DLAMCH('S'). */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices */
+/* with Guaranteed High Relative Accuracy," by Demmel and */
+/* Kahan, LAPACK Working Note #3. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the selected eigenvalues in ascending order. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If an eigenvector fails to converge, then that column of Z */
+/* contains the latest approximation to the eigenvector, and the */
+/* index of the eigenvector is returned in IFAIL. */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (8*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, then i eigenvectors failed to converge. */
+/* Their indices are stored in array IFAIL. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (! (lsame_(uplo, "L") || lsame_(uplo,
+ "U"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -7;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -8;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -9;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -14;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSPEVX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (alleig || indeig) {
+ *m = 1;
+ w[1] = ap[1];
+ } else {
+ if (*vl < ap[1] && *vu >= ap[1]) {
+ *m = 1;
+ w[1] = ap[1];
+ }
+ }
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
+ rmax = min(d__1,d__2);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ abstll = *abstol;
+ if (valeig) {
+ vll = *vl;
+ vuu = *vu;
+ } else {
+ vll = 0.;
+ vuu = 0.;
+ }
+ anrm = dlansp_("M", uplo, n, &ap[1], &work[1]);
+ if (anrm > 0. && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ i__1 = *n * (*n + 1) / 2;
+ dscal_(&i__1, &sigma, &ap[1], &c__1);
+ if (*abstol > 0.) {
+ abstll = *abstol * sigma;
+ }
+ if (valeig) {
+ vll = *vl * sigma;
+ vuu = *vu * sigma;
+ }
+ }
+
+/* Call DSPTRD to reduce symmetric packed matrix to tridiagonal form. */
+
+ indtau = 1;
+ inde = indtau + *n;
+ indd = inde + *n;
+ indwrk = indd + *n;
+ dsptrd_(uplo, n, &ap[1], &work[indd], &work[inde], &work[indtau], &iinfo);
+
+/* If all eigenvalues are desired and ABSTOL is less than or equal */
+/* to zero, then call DSTERF or DOPGTR and SSTEQR. If this fails */
+/* for some eigenvalue, then try DSTEBZ. */
+
+ test = FALSE_;
+ if (indeig) {
+ if (*il == 1 && *iu == *n) {
+ test = TRUE_;
+ }
+ }
+ if ((alleig || test) && *abstol <= 0.) {
+ dcopy_(n, &work[indd], &c__1, &w[1], &c__1);
+ indee = indwrk + (*n << 1);
+ if (! wantz) {
+ i__1 = *n - 1;
+ dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
+ dsterf_(n, &w[1], &work[indee], info);
+ } else {
+ dopgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &
+ work[indwrk], &iinfo);
+ i__1 = *n - 1;
+ dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
+ dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[
+ indwrk], info);
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ifail[i__] = 0;
+/* L10: */
+ }
+ }
+ }
+ if (*info == 0) {
+ *m = *n;
+ goto L20;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ indibl = 1;
+ indisp = indibl + *n;
+ indiwo = indisp + *n;
+ dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[
+ inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[
+ indwrk], &iwork[indiwo], info);
+
+ if (wantz) {
+ dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
+ indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &
+ ifail[1], info);
+
+/* Apply orthogonal matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by DSTEIN. */
+
+ dopmtr_("L", uplo, "N", n, m, &ap[1], &work[indtau], &z__[z_offset],
+ ldz, &work[indwrk], &iinfo);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+L20:
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *m;
+ } else {
+ imax = *info - 1;
+ }
+ d__1 = 1. / sigma;
+ dscal_(&imax, &d__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L30: */
+ }
+
+ if (i__ != 0) {
+ itmp1 = iwork[indibl + i__ - 1];
+ w[i__] = w[j];
+ iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
+ w[j] = tmp1;
+ iwork[indibl + j - 1] = itmp1;
+ dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ if (*info != 0) {
+ itmp1 = ifail[i__];
+ ifail[i__] = ifail[j];
+ ifail[j] = itmp1;
+ }
+ }
+/* L40: */
+ }
+ }
+
+ return 0;
+
+/* End of DSPEVX */
+
+} /* dspevx_ */
diff --git a/SRC/dspgst.c b/SRC/dspgst.c
new file mode 100644
index 0000000..f42db72
--- /dev/null
+++ b/SRC/dspgst.c
@@ -0,0 +1,284 @@
+/* dspgst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b9 = -1.;
+static doublereal c_b11 = 1.;
+
+/* Subroutine */ int dspgst_(integer *itype, char *uplo, integer *n,
+ doublereal *ap, doublereal *bp, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1;
+
+ /* Local variables */
+ integer j, k, j1, k1, jj, kk;
+ doublereal ct, ajj;
+ integer j1j1;
+ doublereal akk;
+ integer k1k1;
+ doublereal bjj, bkk;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ extern /* Subroutine */ int dspr2_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *), dscal_(integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *), dspmv_(char *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *,
+ doublereal *, doublereal *, integer *),
+ dtpsv_(char *, char *, char *, integer *, doublereal *,
+ doublereal *, integer *), xerbla_(char *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSPGST reduces a real symmetric-definite generalized eigenproblem */
+/* to standard form, using packed storage. */
+
+/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
+/* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) */
+
+/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
+/* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L. */
+
+/* B must have been previously factorized as U**T*U or L*L**T by DPPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); */
+/* = 2 or 3: compute U*A*U**T or L**T*A*L. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored and B is factored as */
+/* U**T*U; */
+/* = 'L': Lower triangle of A is stored and B is factored as */
+/* L*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, if INFO = 0, the transformed matrix, stored in the */
+/* same format as A. */
+
+/* BP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The triangular factor from the Cholesky factorization of B, */
+/* stored in the same format as A, as returned by DPPTRF. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --bp;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSPGST", &i__1);
+ return 0;
+ }
+
+ if (*itype == 1) {
+ if (upper) {
+
+/* Compute inv(U')*A*inv(U) */
+
+/* J1 and JJ are the indices of A(1,j) and A(j,j) */
+
+ jj = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ j1 = jj + 1;
+ jj += j;
+
+/* Compute the j-th column of the upper triangle of A */
+
+ bjj = bp[jj];
+ dtpsv_(uplo, "Transpose", "Nonunit", &j, &bp[1], &ap[j1], &
+ c__1);
+ i__2 = j - 1;
+ dspmv_(uplo, &i__2, &c_b9, &ap[1], &bp[j1], &c__1, &c_b11, &
+ ap[j1], &c__1);
+ i__2 = j - 1;
+ d__1 = 1. / bjj;
+ dscal_(&i__2, &d__1, &ap[j1], &c__1);
+ i__2 = j - 1;
+ ap[jj] = (ap[jj] - ddot_(&i__2, &ap[j1], &c__1, &bp[j1], &
+ c__1)) / bjj;
+/* L10: */
+ }
+ } else {
+
+/* Compute inv(L)*A*inv(L') */
+
+/* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */
+
+ kk = 1;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ k1k1 = kk + *n - k + 1;
+
+/* Update the lower triangle of A(k:n,k:n) */
+
+ akk = ap[kk];
+ bkk = bp[kk];
+/* Computing 2nd power */
+ d__1 = bkk;
+ akk /= d__1 * d__1;
+ ap[kk] = akk;
+ if (k < *n) {
+ i__2 = *n - k;
+ d__1 = 1. / bkk;
+ dscal_(&i__2, &d__1, &ap[kk + 1], &c__1);
+ ct = akk * -.5;
+ i__2 = *n - k;
+ daxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
+ ;
+ i__2 = *n - k;
+ dspr2_(uplo, &i__2, &c_b9, &ap[kk + 1], &c__1, &bp[kk + 1]
+, &c__1, &ap[k1k1]);
+ i__2 = *n - k;
+ daxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
+ ;
+ i__2 = *n - k;
+ dtpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1],
+ &ap[kk + 1], &c__1);
+ }
+ kk = k1k1;
+/* L20: */
+ }
+ }
+ } else {
+ if (upper) {
+
+/* Compute U*A*U' */
+
+/* K1 and KK are the indices of A(1,k) and A(k,k) */
+
+ kk = 0;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ k1 = kk + 1;
+ kk += k;
+
+/* Update the upper triangle of A(1:k,1:k) */
+
+ akk = ap[kk];
+ bkk = bp[kk];
+ i__2 = k - 1;
+ dtpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[
+ k1], &c__1);
+ ct = akk * .5;
+ i__2 = k - 1;
+ daxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
+ i__2 = k - 1;
+ dspr2_(uplo, &i__2, &c_b11, &ap[k1], &c__1, &bp[k1], &c__1, &
+ ap[1]);
+ i__2 = k - 1;
+ daxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
+ i__2 = k - 1;
+ dscal_(&i__2, &bkk, &ap[k1], &c__1);
+/* Computing 2nd power */
+ d__1 = bkk;
+ ap[kk] = akk * (d__1 * d__1);
+/* L30: */
+ }
+ } else {
+
+/* Compute L'*A*L */
+
+/* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */
+
+ jj = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ j1j1 = jj + *n - j + 1;
+
+/* Compute the j-th column of the lower triangle of A */
+
+ ajj = ap[jj];
+ bjj = bp[jj];
+ i__2 = *n - j;
+ ap[jj] = ajj * bjj + ddot_(&i__2, &ap[jj + 1], &c__1, &bp[jj
+ + 1], &c__1);
+ i__2 = *n - j;
+ dscal_(&i__2, &bjj, &ap[jj + 1], &c__1);
+ i__2 = *n - j;
+ dspmv_(uplo, &i__2, &c_b11, &ap[j1j1], &bp[jj + 1], &c__1, &
+ c_b11, &ap[jj + 1], &c__1);
+ i__2 = *n - j + 1;
+ dtpmv_(uplo, "Transpose", "Non-unit", &i__2, &bp[jj], &ap[jj],
+ &c__1);
+ jj = j1j1;
+/* L40: */
+ }
+ }
+ }
+ return 0;
+
+/* End of DSPGST */
+
+} /* dspgst_ */
diff --git a/SRC/dspgv.c b/SRC/dspgv.c
new file mode 100644
index 0000000..6b14de3
--- /dev/null
+++ b/SRC/dspgv.c
@@ -0,0 +1,243 @@
+/* dspgv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dspgv_(integer *itype, char *jobz, char *uplo, integer *
+ n, doublereal *ap, doublereal *bp, doublereal *w, doublereal *z__,
+ integer *ldz, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+
+ /* Local variables */
+ integer j, neig;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dspev_(char *, char *, integer *, doublereal *
+, doublereal *, doublereal *, integer *, doublereal *, integer *);
+ char trans[1];
+ logical upper;
+ extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *,
+ doublereal *, doublereal *, integer *),
+ dtpsv_(char *, char *, char *, integer *, doublereal *,
+ doublereal *, integer *);
+ logical wantz;
+ extern /* Subroutine */ int xerbla_(char *, integer *), dpptrf_(
+ char *, integer *, doublereal *, integer *), dspgst_(
+ integer *, char *, integer *, doublereal *, doublereal *, integer
+ *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSPGV computes all the eigenvalues and, optionally, the eigenvectors */
+/* of a real generalized symmetric-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. */
+/* Here A and B are assumed to be symmetric, stored in packed format, */
+/* and B is also positive definite. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* AP (input/output) DOUBLE PRECISION array, dimension */
+/* (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the contents of AP are destroyed. */
+
+/* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* B, packed columnwise in a linear array. The j-th column of B */
+/* is stored in the array BP as follows: */
+/* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */
+
+/* On exit, the triangular factor U or L from the Cholesky */
+/* factorization B = U**T*U or B = L*L**T, in the same storage */
+/* format as B. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
+/* eigenvectors. The eigenvectors are normalized as follows: */
+/* if ITYPE = 1 or 2, Z**T*B*Z = I; */
+/* if ITYPE = 3, Z**T*inv(B)*Z = I. */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: DPPTRF or DSPEV returned an error code: */
+/* <= N: if INFO = i, DSPEV failed to converge; */
+/* i off-diagonal elements of an intermediate */
+/* tridiagonal form did not converge to zero. */
+/* > N: if INFO = n + i, for 1 <= i <= n, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --bp;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+
+ *info = 0;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSPGV ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of B. */
+
+ dpptrf_(uplo, n, &bp[1], info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ dspgst_(itype, uplo, n, &ap[1], &bp[1], info);
+ dspev_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], info);
+
+ if (wantz) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ neig = *n;
+ if (*info > 0) {
+ neig = *info - 1;
+ }
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'T';
+ }
+
+ i__1 = neig;
+ for (j = 1; j <= i__1; ++j) {
+ dtpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L10: */
+ }
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'T';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ i__1 = neig;
+ for (j = 1; j <= i__1; ++j) {
+ dtpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L20: */
+ }
+ }
+ }
+ return 0;
+
+/* End of DSPGV */
+
+} /* dspgv_ */
diff --git a/SRC/dspgvd.c b/SRC/dspgvd.c
new file mode 100644
index 0000000..75ceb69
--- /dev/null
+++ b/SRC/dspgvd.c
@@ -0,0 +1,334 @@
+/* dspgvd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dspgvd_(integer *itype, char *jobz, char *uplo, integer *
+ n, doublereal *ap, doublereal *bp, doublereal *w, doublereal *z__,
+ integer *ldz, doublereal *work, integer *lwork, integer *iwork,
+ integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j, neig;
+ extern logical lsame_(char *, char *);
+ integer lwmin;
+ char trans[1];
+ logical upper;
+ extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *,
+ doublereal *, doublereal *, integer *),
+ dtpsv_(char *, char *, char *, integer *, doublereal *,
+ doublereal *, integer *);
+ logical wantz;
+ extern /* Subroutine */ int xerbla_(char *, integer *), dspevd_(
+ char *, char *, integer *, doublereal *, doublereal *, doublereal
+ *, integer *, doublereal *, integer *, integer *, integer *,
+ integer *);
+ integer liwmin;
+ extern /* Subroutine */ int dpptrf_(char *, integer *, doublereal *,
+ integer *), dspgst_(integer *, char *, integer *,
+ doublereal *, doublereal *, integer *);
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSPGVD computes all the eigenvalues, and optionally, the eigenvectors */
+/* of a real generalized symmetric-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */
+/* B are assumed to be symmetric, stored in packed format, and B is also */
+/* positive definite. */
+/* If eigenvectors are desired, it uses a divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the contents of AP are destroyed. */
+
+/* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* B, packed columnwise in a linear array. The j-th column of B */
+/* is stored in the array BP as follows: */
+/* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */
+
+/* On exit, the triangular factor U or L from the Cholesky */
+/* factorization B = U**T*U or B = L*L**T, in the same storage */
+/* format as B. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
+/* eigenvectors. The eigenvectors are normalized as follows: */
+/* if ITYPE = 1 or 2, Z**T*B*Z = I; */
+/* if ITYPE = 3, Z**T*inv(B)*Z = I. */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the required LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If N <= 1, LWORK >= 1. */
+/* If JOBZ = 'N' and N > 1, LWORK >= 2*N. */
+/* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the required sizes of the WORK and IWORK */
+/* arrays, returns these values as the first entries of the WORK */
+/* and IWORK arrays, and no error message related to LWORK or */
+/* LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the required LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If JOBZ = 'N' or N <= 1, LIWORK >= 1. */
+/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the required sizes of the WORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK and IWORK arrays, and no error message related to */
+/* LWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: DPPTRF or DSPEVD returned an error code: */
+/* <= N: if INFO = i, DSPEVD failed to converge; */
+/* i off-diagonal elements of an intermediate */
+/* tridiagonal form did not converge to zero; */
+/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --bp;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1 || *liwork == -1;
+
+ *info = 0;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -9;
+ }
+
+ if (*info == 0) {
+ if (*n <= 1) {
+ liwmin = 1;
+ lwmin = 1;
+ } else {
+ if (wantz) {
+ liwmin = *n * 5 + 3;
+/* Computing 2nd power */
+ i__1 = *n;
+ lwmin = *n * 6 + 1 + (i__1 * i__1 << 1);
+ } else {
+ liwmin = 1;
+ lwmin = *n << 1;
+ }
+ }
+ work[1] = (doublereal) lwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -11;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSPGVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of BP. */
+
+ dpptrf_(uplo, n, &bp[1], info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ dspgst_(itype, uplo, n, &ap[1], &bp[1], info);
+ dspevd_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1],
+ lwork, &iwork[1], liwork, info);
+/* Computing MAX */
+ d__1 = (doublereal) lwmin;
+ lwmin = (integer) max(d__1,work[1]);
+/* Computing MAX */
+ d__1 = (doublereal) liwmin, d__2 = (doublereal) iwork[1];
+ liwmin = (integer) max(d__1,d__2);
+
+ if (wantz) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ neig = *n;
+ if (*info > 0) {
+ neig = *info - 1;
+ }
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'T';
+ }
+
+ i__1 = neig;
+ for (j = 1; j <= i__1; ++j) {
+ dtpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L10: */
+ }
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'T';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ i__1 = neig;
+ for (j = 1; j <= i__1; ++j) {
+ dtpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L20: */
+ }
+ }
+ }
+
+ work[1] = (doublereal) lwmin;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of DSPGVD */
+
+} /* dspgvd_ */
diff --git a/SRC/dspgvx.c b/SRC/dspgvx.c
new file mode 100644
index 0000000..90c8aa5
--- /dev/null
+++ b/SRC/dspgvx.c
@@ -0,0 +1,341 @@
+/* dspgvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dspgvx_(integer *itype, char *jobz, char *range, char *
+ uplo, integer *n, doublereal *ap, doublereal *bp, doublereal *vl,
+ doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer
+ *m, doublereal *w, doublereal *z__, integer *ldz, doublereal *work,
+ integer *iwork, integer *ifail, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+
+ /* Local variables */
+ integer j;
+ extern logical lsame_(char *, char *);
+ char trans[1];
+ logical upper;
+ extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *,
+ doublereal *, doublereal *, integer *),
+ dtpsv_(char *, char *, char *, integer *, doublereal *,
+ doublereal *, integer *);
+ logical wantz, alleig, indeig, valeig;
+ extern /* Subroutine */ int xerbla_(char *, integer *), dpptrf_(
+ char *, integer *, doublereal *, integer *), dspgst_(
+ integer *, char *, integer *, doublereal *, doublereal *, integer
+ *), dspevx_(char *, char *, char *, integer *, doublereal
+ *, doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSPGVX computes selected eigenvalues, and optionally, eigenvectors */
+/* of a real generalized symmetric-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A */
+/* and B are assumed to be symmetric, stored in packed storage, and B */
+/* is also positive definite. Eigenvalues and eigenvectors can be */
+/* selected by specifying either a range of values or a range of indices */
+/* for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A and B are stored; */
+/* = 'L': Lower triangle of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix pencil (A,B). N >= 0. */
+
+/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the contents of AP are destroyed. */
+
+/* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* B, packed columnwise in a linear array. The j-th column of B */
+/* is stored in the array BP as follows: */
+/* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */
+
+/* On exit, the triangular factor U or L from the Cholesky */
+/* factorization B = U**T*U or B = L*L**T, in the same storage */
+/* format as B. */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) DOUBLE PRECISION */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing A to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*DLAMCH('S'). */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* On normal exit, the first M elements contain the selected */
+/* eigenvalues in ascending order. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* The eigenvectors are normalized as follows: */
+/* if ITYPE = 1 or 2, Z**T*B*Z = I; */
+/* if ITYPE = 3, Z**T*inv(B)*Z = I. */
+
+/* If an eigenvector fails to converge, then that column of Z */
+/* contains the latest approximation to the eigenvector, and the */
+/* index of the eigenvector is returned in IFAIL. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (8*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: DPPTRF or DSPEVX returned an error code: */
+/* <= N: if INFO = i, DSPEVX failed to converge; */
+/* i eigenvectors failed to converge. Their indices */
+/* are stored in array IFAIL. */
+/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --bp;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ upper = lsame_(uplo, "U");
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ *info = 0;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -3;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -9;
+ }
+ } else if (indeig) {
+ if (*il < 1) {
+ *info = -10;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -11;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -16;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSPGVX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of B. */
+
+ dpptrf_(uplo, n, &bp[1], info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ dspgst_(itype, uplo, n, &ap[1], &bp[1], info);
+ dspevx_(jobz, range, uplo, n, &ap[1], vl, vu, il, iu, abstol, m, &w[1], &
+ z__[z_offset], ldz, &work[1], &iwork[1], &ifail[1], info);
+
+ if (wantz) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ if (*info > 0) {
+ *m = *info - 1;
+ }
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'T';
+ }
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ dtpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L10: */
+ }
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'T';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ dtpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L20: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DSPGVX */
+
+} /* dspgvx_ */
diff --git a/SRC/dsposv.c b/SRC/dsposv.c
new file mode 100644
index 0000000..c7892b4
--- /dev/null
+++ b/SRC/dsposv.c
@@ -0,0 +1,418 @@
+/* dsposv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b10 = -1.;
+static doublereal c_b11 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dsposv_(char *uplo, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
+ x, integer *ldx, doublereal *work, real *swork, integer *iter,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, work_dim1, work_offset,
+ x_dim1, x_offset, i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal cte, eps, anrm;
+ integer ptsa;
+ doublereal rnrm, xnrm;
+ integer ptsx;
+ extern logical lsame_(char *, char *);
+ integer iiter;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *), dsymm_(char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *), dlag2s_(integer *, integer *, doublereal *,
+ integer *, real *, integer *, integer *), slag2d_(integer *,
+ integer *, real *, integer *, doublereal *, integer *, integer *),
+ dlat2s_(char *, integer *, doublereal *, integer *, real *,
+ integer *, integer *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dpotrf_(char *, integer *, doublereal *,
+ integer *, integer *), dpotrs_(char *, integer *, integer
+ *, doublereal *, integer *, doublereal *, integer *, integer *), spotrf_(char *, integer *, real *, integer *, integer *), spotrs_(char *, integer *, integer *, real *, integer *,
+ real *, integer *, integer *);
+
+
+/* -- LAPACK PROTOTYPE driver routine (version 3.1.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* May 2007 */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSPOSV computes the solution to a real system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N symmetric positive definite matrix and X and B */
+/* are N-by-NRHS matrices. */
+
+/* DSPOSV first attempts to factorize the matrix in SINGLE PRECISION */
+/* and use this factorization within an iterative refinement procedure */
+/* to produce a solution with DOUBLE PRECISION normwise backward error */
+/* quality (see below). If the approach fails the method switches to a */
+/* DOUBLE PRECISION factorization and solve. */
+
+/* The iterative refinement is not going to be a winning strategy if */
+/* the ratio SINGLE PRECISION performance over DOUBLE PRECISION */
+/* performance is too small. A reasonable strategy should take the */
+/* number of right-hand sides and the size of the matrix into account. */
+/* This might be done with a call to ILAENV in the future. Up to now, we */
+/* always try iterative refinement. */
+
+/* The iterative refinement process is stopped if */
+/* ITER > ITERMAX */
+/* or for all the RHS we have: */
+/* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX */
+/* where */
+/* o ITER is the number of the current iteration in the iterative */
+/* refinement process */
+/* o RNRM is the infinity-norm of the residual */
+/* o XNRM is the infinity-norm of the solution */
+/* o ANRM is the infinity-operator-norm of the matrix A */
+/* o EPS is the machine epsilon returned by DLAMCH('Epsilon') */
+/* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 */
+/* respectively. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input or input/ouptut) DOUBLE PRECISION array, */
+/* dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+/* On exit, if iterative refinement has been successfully used */
+/* (INFO.EQ.0 and ITER.GE.0, see description below), then A is */
+/* unchanged, if double precision factorization has been used */
+/* (INFO.EQ.0 and ITER.LT.0, see description below), then the */
+/* array A contains the factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T. */
+
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* If INFO = 0, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N*NRHS) */
+/* This array is used to hold the residual vectors. */
+
+/* SWORK (workspace) REAL array, dimension (N*(N+NRHS)) */
+/* This array is used to use the single precision matrix and the */
+/* right-hand sides or solutions in single precision. */
+
+/* ITER (output) INTEGER */
+/* < 0: iterative refinement has failed, double precision */
+/* factorization has been performed */
+/* -1 : the routine fell back to full precision for */
+/* implementation- or machine-specific reasons */
+/* -2 : narrowing the precision induced an overflow, */
+/* the routine fell back to full precision */
+/* -3 : failure of SPOTRF */
+/* -31: stop the iterative refinement after the 30th */
+/* iterations */
+/* > 0: iterative refinement has been sucessfully used. */
+/* Returns the number of iterations */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i of (DOUBLE */
+/* PRECISION) A is not positive definite, so the */
+/* factorization could not be completed, and the solution */
+/* has not been computed. */
+
+/* ========= */
+
+/* .. Parameters .. */
+
+
+
+
+/* .. Local Scalars .. */
+
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ work_dim1 = *n;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --swork;
+
+ /* Function Body */
+ *info = 0;
+ *iter = 0;
+
+/* Test the input parameters. */
+
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldx < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSPOSV", &i__1);
+ return 0;
+ }
+
+/* Quick return if (N.EQ.0). */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Skip single precision iterative refinement if a priori slower */
+/* than double precision factorization. */
+
+ if (FALSE_) {
+ *iter = -1;
+ goto L40;
+ }
+
+/* Compute some constants. */
+
+ anrm = dlansy_("I", uplo, n, &a[a_offset], lda, &work[work_offset]);
+ eps = dlamch_("Epsilon");
+ cte = anrm * eps * sqrt((doublereal) (*n)) * 1.;
+
+/* Set the indices PTSA, PTSX for referencing SA and SX in SWORK. */
+
+ ptsa = 1;
+ ptsx = ptsa + *n * *n;
+
+/* Convert B from double precision to single precision and store the */
+/* result in SX. */
+
+ dlag2s_(n, nrhs, &b[b_offset], ldb, &swork[ptsx], n, info);
+
+ if (*info != 0) {
+ *iter = -2;
+ goto L40;
+ }
+
+/* Convert A from double precision to single precision and store the */
+/* result in SA. */
+
+ dlat2s_(uplo, n, &a[a_offset], lda, &swork[ptsa], n, info);
+
+ if (*info != 0) {
+ *iter = -2;
+ goto L40;
+ }
+
+/* Compute the Cholesky factorization of SA. */
+
+ spotrf_(uplo, n, &swork[ptsa], n, info);
+
+ if (*info != 0) {
+ *iter = -3;
+ goto L40;
+ }
+
+/* Solve the system SA*SX = SB. */
+
+ spotrs_(uplo, n, nrhs, &swork[ptsa], n, &swork[ptsx], n, info);
+
+/* Convert SX back to double precision */
+
+ slag2d_(n, nrhs, &swork[ptsx], n, &x[x_offset], ldx, info);
+
+/* Compute R = B - AX (R is WORK). */
+
+ dlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n);
+
+ dsymm_("Left", uplo, n, nrhs, &c_b10, &a[a_offset], lda, &x[x_offset],
+ ldx, &c_b11, &work[work_offset], n);
+
+/* Check whether the NRHS normwise backward errors satisfy the */
+/* stopping criterion. If yes, set ITER=0 and return. */
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xnrm = (d__1 = x[idamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ *
+ x_dim1], abs(d__1));
+ rnrm = (d__1 = work[idamax_(n, &work[i__ * work_dim1 + 1], &c__1) +
+ i__ * work_dim1], abs(d__1));
+ if (rnrm > xnrm * cte) {
+ goto L10;
+ }
+ }
+
+/* If we are here, the NRHS normwise backward errors satisfy the */
+/* stopping criterion. We are good to exit. */
+
+ *iter = 0;
+ return 0;
+
+L10:
+
+ for (iiter = 1; iiter <= 30; ++iiter) {
+
+/* Convert R (in WORK) from double precision to single precision */
+/* and store the result in SX. */
+
+ dlag2s_(n, nrhs, &work[work_offset], n, &swork[ptsx], n, info);
+
+ if (*info != 0) {
+ *iter = -2;
+ goto L40;
+ }
+
+/* Solve the system SA*SX = SR. */
+
+ spotrs_(uplo, n, nrhs, &swork[ptsa], n, &swork[ptsx], n, info);
+
+/* Convert SX back to double precision and update the current */
+/* iterate. */
+
+ slag2d_(n, nrhs, &swork[ptsx], n, &work[work_offset], n, info);
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ daxpy_(n, &c_b11, &work[i__ * work_dim1 + 1], &c__1, &x[i__ *
+ x_dim1 + 1], &c__1);
+ }
+
+/* Compute R = B - AX (R is WORK). */
+
+ dlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n);
+
+ dsymm_("L", uplo, n, nrhs, &c_b10, &a[a_offset], lda, &x[x_offset],
+ ldx, &c_b11, &work[work_offset], n);
+
+/* Check whether the NRHS normwise backward errors satisfy the */
+/* stopping criterion. If yes, set ITER=IITER>0 and return. */
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xnrm = (d__1 = x[idamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ *
+ x_dim1], abs(d__1));
+ rnrm = (d__1 = work[idamax_(n, &work[i__ * work_dim1 + 1], &c__1)
+ + i__ * work_dim1], abs(d__1));
+ if (rnrm > xnrm * cte) {
+ goto L20;
+ }
+ }
+
+/* If we are here, the NRHS normwise backward errors satisfy the */
+/* stopping criterion, we are good to exit. */
+
+ *iter = iiter;
+
+ return 0;
+
+L20:
+
+/* L30: */
+ ;
+ }
+
+/* If we are at this place of the code, this is because we have */
+/* performed ITER=ITERMAX iterations and never satisified the */
+/* stopping criterion, set up the ITER flag accordingly and follow */
+/* up on double precision routine. */
+
+ *iter = -31;
+
+L40:
+
+/* Single-precision iterative refinement failed to converge to a */
+/* satisfactory solution, so we resort to double precision. */
+
+ dpotrf_(uplo, n, &a[a_offset], lda, info);
+
+ if (*info != 0) {
+ return 0;
+ }
+
+ dlacpy_("All", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ dpotrs_(uplo, n, nrhs, &a[a_offset], lda, &x[x_offset], ldx, info);
+
+ return 0;
+
+/* End of DSPOSV. */
+
+} /* dsposv_ */
diff --git a/SRC/dsprfs.c b/SRC/dsprfs.c
new file mode 100644
index 0000000..4b0bb0d
--- /dev/null
+++ b/SRC/dsprfs.c
@@ -0,0 +1,421 @@
+/* dsprfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b12 = -1.;
+static doublereal c_b14 = 1.;
+
+/* Subroutine */ int dsprfs_(char *uplo, integer *n, integer *nrhs,
+ doublereal *ap, doublereal *afp, integer *ipiv, doublereal *b,
+ integer *ldb, doublereal *x, integer *ldx, doublereal *ferr,
+ doublereal *berr, doublereal *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal s;
+ integer ik, kk;
+ doublereal xk;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *);
+ integer count;
+ extern /* Subroutine */ int dspmv_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ logical upper;
+ extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal lstres;
+ extern /* Subroutine */ int dsptrs_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSPRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric indefinite */
+/* and packed, and provides error bounds and backward error estimates */
+/* for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the symmetric matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* AFP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The factored form of the matrix A. AFP contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor U or L from the factorization A = U*D*U**T or */
+/* A = L*D*L**T as computed by DSPTRF, stored as a packed */
+/* triangular matrix. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by DSPTRF. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by DSPTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --afp;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*ldx < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSPRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+ dspmv_(uplo, n, &c_b12, &ap[1], &x[j * x_dim1 + 1], &c__1, &c_b14, &
+ work[*n + 1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ kk = 1;
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+ ik = kk;
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ work[i__] += (d__1 = ap[ik], abs(d__1)) * xk;
+ s += (d__1 = ap[ik], abs(d__1)) * (d__2 = x[i__ + j *
+ x_dim1], abs(d__2));
+ ++ik;
+/* L40: */
+ }
+ work[k] = work[k] + (d__1 = ap[kk + k - 1], abs(d__1)) * xk +
+ s;
+ kk += k;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+ work[k] += (d__1 = ap[kk], abs(d__1)) * xk;
+ ik = kk + 1;
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ work[i__] += (d__1 = ap[ik], abs(d__1)) * xk;
+ s += (d__1 = ap[ik], abs(d__1)) * (d__2 = x[i__ + j *
+ x_dim1], abs(d__2));
+ ++ik;
+/* L60: */
+ }
+ work[k] += s;
+ kk += *n - k + 1;
+/* L70: */
+ }
+ }
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[
+ i__];
+ s = max(d__2,d__3);
+ } else {
+/* Computing MAX */
+ d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1)
+ / (work[i__] + safe1);
+ s = max(d__2,d__3);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ dsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n, info);
+ daxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
+ ;
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use DLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+ kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ dsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n,
+ info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L120: */
+ }
+ dsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n,
+ info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1));
+ lstres = max(d__2,d__3);
+/* L130: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of DSPRFS */
+
+} /* dsprfs_ */
diff --git a/SRC/dspsv.c b/SRC/dspsv.c
new file mode 100644
index 0000000..ebf99a2
--- /dev/null
+++ b/SRC/dspsv.c
@@ -0,0 +1,176 @@
+/* dspsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dspsv_(char *uplo, integer *n, integer *nrhs, doublereal
+ *ap, integer *ipiv, doublereal *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), dsptrf_(
+ char *, integer *, doublereal *, integer *, integer *),
+ dsptrs_(char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSPSV computes the solution to a real system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N symmetric matrix stored in packed format and X */
+/* and B are N-by-NRHS matrices. */
+
+/* The diagonal pivoting method is used to factor A as */
+/* A = U * D * U**T, if UPLO = 'U', or */
+/* A = L * D * L**T, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, D is symmetric and block diagonal with 1-by-1 */
+/* and 2-by-2 diagonal blocks. The factored form of A is then used to */
+/* solve the system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+
+/* On exit, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as */
+/* a packed triangular matrix in the same storage format as A. */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D, as */
+/* determined by DSPTRF. If IPIV(k) > 0, then rows and columns */
+/* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 */
+/* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, */
+/* then rows and columns k-1 and -IPIV(k) were interchanged and */
+/* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and */
+/* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and */
+/* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 */
+/* diagonal block. */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */
+/* has been completed, but the block diagonal matrix D is */
+/* exactly singular, so the solution could not be */
+/* computed. */
+
+/* Further Details */
+/* =============== */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the symmetric matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = aji) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSPSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ dsptrf_(uplo, n, &ap[1], &ipiv[1], info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ dsptrs_(uplo, n, nrhs, &ap[1], &ipiv[1], &b[b_offset], ldb, info);
+
+ }
+ return 0;
+
+/* End of DSPSV */
+
+} /* dspsv_ */
diff --git a/SRC/dspsvx.c b/SRC/dspsvx.c
new file mode 100644
index 0000000..2737ef3
--- /dev/null
+++ b/SRC/dspsvx.c
@@ -0,0 +1,329 @@
+/* dspsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dspsvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublereal *ap, doublereal *afp, integer *ipiv, doublereal *b,
+ integer *ldb, doublereal *x, integer *ldx, doublereal *rcond,
+ doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ extern doublereal dlamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ extern doublereal dlansp_(char *, char *, integer *, doublereal *,
+ doublereal *);
+ extern /* Subroutine */ int dspcon_(char *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *), dsprfs_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *), dsptrf_(char *, integer *,
+ doublereal *, integer *, integer *), dsptrs_(char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSPSVX uses the diagonal pivoting factorization A = U*D*U**T or */
+/* A = L*D*L**T to compute the solution to a real system of linear */
+/* equations A * X = B, where A is an N-by-N symmetric matrix stored */
+/* in packed format and X and B are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as */
+/* A = U * D * U**T, if UPLO = 'U', or */
+/* A = L * D * L**T, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* 2. If some D(i,i)=0, so that D is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 3. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 4. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of A has been */
+/* supplied on entry. */
+/* = 'F': On entry, AFP and IPIV contain the factored form of */
+/* A. AP, AFP and IPIV will not be modified. */
+/* = 'N': The matrix A will be copied to AFP and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the symmetric matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+
+/* AFP (input or output) DOUBLE PRECISION array, dimension */
+/* (N*(N+1)/2) */
+/* If FACT = 'F', then AFP is an input argument and on entry */
+/* contains the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as */
+/* a packed triangular matrix in the same storage format as A. */
+
+/* If FACT = 'N', then AFP is an output argument and on exit */
+/* contains the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as */
+/* a packed triangular matrix in the same storage format as A. */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by DSPTRF. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by DSPTRF. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A. If RCOND is less than the machine precision (in */
+/* particular, if RCOND = 0), the matrix is singular to working */
+/* precision. This condition is indicated by a return code of */
+/* INFO > 0. */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: D(i,i) is exactly zero. The factorization */
+/* has been completed but the factor D is exactly */
+/* singular, so the solution and error bounds could */
+/* not be computed. RCOND = 0 is returned. */
+/* = N+1: D is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* Further Details */
+/* =============== */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the symmetric matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = aji) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --afp;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ if (! nofact && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSPSVX", &i__1);
+ return 0;
+ }
+
+ if (nofact) {
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ i__1 = *n * (*n + 1) / 2;
+ dcopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1);
+ dsptrf_(uplo, n, &afp[1], &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = dlansp_("I", uplo, n, &ap[1], &work[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ dspcon_(uplo, n, &afp[1], &ipiv[1], &anorm, rcond, &work[1], &iwork[1],
+ info);
+
+/* Compute the solution vectors X. */
+
+ dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ dsptrs_(uplo, n, nrhs, &afp[1], &ipiv[1], &x[x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solutions and */
+/* compute error bounds and backward error estimates for them. */
+
+ dsprfs_(uplo, n, nrhs, &ap[1], &afp[1], &ipiv[1], &b[b_offset], ldb, &x[
+ x_offset], ldx, &ferr[1], &berr[1], &work[1], &iwork[1], info);
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < dlamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of DSPSVX */
+
+} /* dspsvx_ */
diff --git a/SRC/dsptrd.c b/SRC/dsptrd.c
new file mode 100644
index 0000000..f5814b8
--- /dev/null
+++ b/SRC/dsptrd.c
@@ -0,0 +1,277 @@
+/* dsptrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b8 = 0.;
+static doublereal c_b14 = -1.;
+
+/* Subroutine */ int dsptrd_(char *uplo, integer *n, doublereal *ap,
+ doublereal *d__, doublereal *e, doublereal *tau, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, i1, ii, i1i1;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal taui;
+ extern /* Subroutine */ int dspr2_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *);
+ doublereal alpha;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *), dspmv_(char *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSPTRD reduces a real symmetric matrix A stored in packed form to */
+/* symmetric tridiagonal form T by an orthogonal similarity */
+/* transformation: Q**T * A * Q = T. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+/* On exit, if UPLO = 'U', the diagonal and first superdiagonal */
+/* of A are overwritten by the corresponding elements of the */
+/* tridiagonal matrix T, and the elements above the first */
+/* superdiagonal, with the array TAU, represent the orthogonal */
+/* matrix Q as a product of elementary reflectors; if UPLO */
+/* = 'L', the diagonal and first subdiagonal of A are over- */
+/* written by the corresponding elements of the tridiagonal */
+/* matrix T, and the elements below the first subdiagonal, with */
+/* the array TAU, represent the orthogonal matrix Q as a product */
+/* of elementary reflectors. See Further Details. */
+
+/* D (output) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal elements of the tridiagonal matrix T: */
+/* D(i) = A(i,i). */
+
+/* E (output) DOUBLE PRECISION array, dimension (N-1) */
+/* The off-diagonal elements of the tridiagonal matrix T: */
+/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(n-1) . . . H(2) H(1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP, */
+/* overwriting A(1:i-1,i+1), and tau is stored in TAU(i). */
+
+/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(1) H(2) . . . H(n-1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP, */
+/* overwriting A(i+2:n,i), and tau is stored in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ --tau;
+ --e;
+ --d__;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSPTRD", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Reduce the upper triangle of A. */
+/* I1 is the index in AP of A(1,I+1). */
+
+ i1 = *n * (*n - 1) / 2 + 1;
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+
+/* Generate elementary reflector H(i) = I - tau * v * v' */
+/* to annihilate A(1:i-1,i+1) */
+
+ dlarfg_(&i__, &ap[i1 + i__ - 1], &ap[i1], &c__1, &taui);
+ e[i__] = ap[i1 + i__ - 1];
+
+ if (taui != 0.) {
+
+/* Apply H(i) from both sides to A(1:i,1:i) */
+
+ ap[i1 + i__ - 1] = 1.;
+
+/* Compute y := tau * A * v storing y in TAU(1:i) */
+
+ dspmv_(uplo, &i__, &taui, &ap[1], &ap[i1], &c__1, &c_b8, &tau[
+ 1], &c__1);
+
+/* Compute w := y - 1/2 * tau * (y'*v) * v */
+
+ alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &ap[i1], &
+ c__1);
+ daxpy_(&i__, &alpha, &ap[i1], &c__1, &tau[1], &c__1);
+
+/* Apply the transformation as a rank-2 update: */
+/* A := A - v * w' - w * v' */
+
+ dspr2_(uplo, &i__, &c_b14, &ap[i1], &c__1, &tau[1], &c__1, &
+ ap[1]);
+
+ ap[i1 + i__ - 1] = e[i__];
+ }
+ d__[i__ + 1] = ap[i1 + i__];
+ tau[i__] = taui;
+ i1 -= i__;
+/* L10: */
+ }
+ d__[1] = ap[1];
+ } else {
+
+/* Reduce the lower triangle of A. II is the index in AP of */
+/* A(i,i) and I1I1 is the index of A(i+1,i+1). */
+
+ ii = 1;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i1i1 = ii + *n - i__ + 1;
+
+/* Generate elementary reflector H(i) = I - tau * v * v' */
+/* to annihilate A(i+2:n,i) */
+
+ i__2 = *n - i__;
+ dlarfg_(&i__2, &ap[ii + 1], &ap[ii + 2], &c__1, &taui);
+ e[i__] = ap[ii + 1];
+
+ if (taui != 0.) {
+
+/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
+
+ ap[ii + 1] = 1.;
+
+/* Compute y := tau * A * v storing y in TAU(i:n-1) */
+
+ i__2 = *n - i__;
+ dspmv_(uplo, &i__2, &taui, &ap[i1i1], &ap[ii + 1], &c__1, &
+ c_b8, &tau[i__], &c__1);
+
+/* Compute w := y - 1/2 * tau * (y'*v) * v */
+
+ i__2 = *n - i__;
+ alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &ap[ii +
+ 1], &c__1);
+ i__2 = *n - i__;
+ daxpy_(&i__2, &alpha, &ap[ii + 1], &c__1, &tau[i__], &c__1);
+
+/* Apply the transformation as a rank-2 update: */
+/* A := A - v * w' - w * v' */
+
+ i__2 = *n - i__;
+ dspr2_(uplo, &i__2, &c_b14, &ap[ii + 1], &c__1, &tau[i__], &
+ c__1, &ap[i1i1]);
+
+ ap[ii + 1] = e[i__];
+ }
+ d__[i__] = ap[ii];
+ tau[i__] = taui;
+ ii = i1i1;
+/* L20: */
+ }
+ d__[*n] = ap[ii];
+ }
+
+ return 0;
+
+/* End of DSPTRD */
+
+} /* dsptrd_ */
diff --git a/SRC/dsptrf.c b/SRC/dsptrf.c
new file mode 100644
index 0000000..35ad473
--- /dev/null
+++ b/SRC/dsptrf.c
@@ -0,0 +1,628 @@
+/* dsptrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dsptrf_(char *uplo, integer *n, doublereal *ap, integer *
+ ipiv, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal t, r1, d11, d12, d21, d22;
+ integer kc, kk, kp;
+ doublereal wk;
+ integer kx, knc, kpc, npp;
+ doublereal wkm1, wkp1;
+ integer imax, jmax;
+ extern /* Subroutine */ int dspr_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *);
+ doublereal alpha;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer kstep;
+ logical upper;
+ doublereal absakk;
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal colmax, rowmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSPTRF computes the factorization of a real symmetric matrix A stored */
+/* in packed format using the Bunch-Kaufman diagonal pivoting method: */
+
+/* A = U*D*U**T or A = L*D*L**T */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L, stored as a packed triangular */
+/* matrix overwriting A (see below for further details). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. 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. */
+
+/* Further Details */
+/* =============== */
+
+/* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services */
+/* Company */
+
+/* If UPLO = 'U', then A = U*D*U', where */
+/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
+/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
+/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I v 0 ) k-s */
+/* U(k) = ( 0 I 0 ) s */
+/* ( 0 0 I ) n-k */
+/* k-s s n-k */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
+/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
+/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
+
+/* If UPLO = 'L', then A = L*D*L', where */
+/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
+/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
+/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I 0 0 ) k-1 */
+/* L(k) = ( 0 I 0 ) s */
+/* ( 0 v I ) n-k-s+1 */
+/* k-1 s n-k-s+1 */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
+/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
+/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ipiv;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSPTRF", &i__1);
+ return 0;
+ }
+
+/* Initialize ALPHA for use in choosing pivot block size. */
+
+ alpha = (sqrt(17.) + 1.) / 8.;
+
+ if (upper) {
+
+/* Factorize A as U*D*U' using the upper triangle of A */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2 */
+
+ k = *n;
+ kc = (*n - 1) * *n / 2 + 1;
+L10:
+ knc = kc;
+
+/* If K < 1, exit from loop */
+
+ if (k < 1) {
+ goto L110;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ absakk = (d__1 = ap[kc + k - 1], abs(d__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ imax = idamax_(&i__1, &ap[kc], &c__1);
+ colmax = (d__1 = ap[kc + imax - 1], abs(d__1));
+ } else {
+ colmax = 0.;
+ }
+
+ if (max(absakk,colmax) == 0.) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ rowmax = 0.;
+ jmax = imax;
+ kx = imax * (imax + 1) / 2 + imax;
+ i__1 = k;
+ for (j = imax + 1; j <= i__1; ++j) {
+ if ((d__1 = ap[kx], abs(d__1)) > rowmax) {
+ rowmax = (d__1 = ap[kx], abs(d__1));
+ jmax = j;
+ }
+ kx += j;
+/* L20: */
+ }
+ kpc = (imax - 1) * imax / 2 + 1;
+ if (imax > 1) {
+ i__1 = imax - 1;
+ jmax = idamax_(&i__1, &ap[kpc], &c__1);
+/* Computing MAX */
+ d__2 = rowmax, d__3 = (d__1 = ap[kpc + jmax - 1], abs(
+ d__1));
+ rowmax = max(d__2,d__3);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else if ((d__1 = ap[kpc + imax - 1], abs(d__1)) >= alpha *
+ rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+
+ kk = k - kstep + 1;
+ if (kstep == 2) {
+ knc = knc - k + 1;
+ }
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the leading */
+/* submatrix A(1:k,1:k) */
+
+ i__1 = kp - 1;
+ dswap_(&i__1, &ap[knc], &c__1, &ap[kpc], &c__1);
+ kx = kpc + kp - 1;
+ i__1 = kk - 1;
+ for (j = kp + 1; j <= i__1; ++j) {
+ kx = kx + j - 1;
+ t = ap[knc + j - 1];
+ ap[knc + j - 1] = ap[kx];
+ ap[kx] = t;
+/* L30: */
+ }
+ t = ap[knc + kk - 1];
+ ap[knc + kk - 1] = ap[kpc + kp - 1];
+ ap[kpc + kp - 1] = t;
+ if (kstep == 2) {
+ t = ap[kc + k - 2];
+ ap[kc + k - 2] = ap[kc + kp - 1];
+ ap[kc + kp - 1] = t;
+ }
+ }
+
+/* Update the leading submatrix */
+
+ if (kstep == 1) {
+
+/* 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 */
+
+/* Perform a rank-1 update of A(1:k-1,1:k-1) as */
+
+/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */
+
+ r1 = 1. / ap[kc + k - 1];
+ i__1 = k - 1;
+ d__1 = -r1;
+ dspr_(uplo, &i__1, &d__1, &ap[kc], &c__1, &ap[1]);
+
+/* Store U(k) in column k */
+
+ i__1 = k - 1;
+ dscal_(&i__1, &r1, &ap[kc], &c__1);
+ } 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) )' */
+/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */
+
+ if (k > 2) {
+
+ d12 = ap[k - 1 + (k - 1) * k / 2];
+ d22 = ap[k - 1 + (k - 2) * (k - 1) / 2] / d12;
+ d11 = ap[k + (k - 1) * k / 2] / d12;
+ t = 1. / (d11 * d22 - 1.);
+ d12 = t / d12;
+
+ for (j = k - 2; j >= 1; --j) {
+ wkm1 = d12 * (d11 * ap[j + (k - 2) * (k - 1) / 2] -
+ ap[j + (k - 1) * k / 2]);
+ wk = d12 * (d22 * ap[j + (k - 1) * k / 2] - ap[j + (k
+ - 2) * (k - 1) / 2]);
+ for (i__ = j; i__ >= 1; --i__) {
+ ap[i__ + (j - 1) * j / 2] = ap[i__ + (j - 1) * j /
+ 2] - ap[i__ + (k - 1) * k / 2] * wk - ap[
+ i__ + (k - 2) * (k - 1) / 2] * wkm1;
+/* L40: */
+ }
+ ap[j + (k - 1) * k / 2] = wk;
+ ap[j + (k - 2) * (k - 1) / 2] = wkm1;
+/* L50: */
+ }
+
+ }
+
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k - 1] = -kp;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kstep;
+ kc = knc - k;
+ goto L10;
+
+ } else {
+
+/* Factorize A as L*D*L' using the lower triangle of A */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2 */
+
+ k = 1;
+ kc = 1;
+ npp = *n * (*n + 1) / 2;
+L60:
+ knc = kc;
+
+/* If K > N, exit from loop */
+
+ if (k > *n) {
+ goto L110;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ absakk = (d__1 = ap[kc], abs(d__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ imax = k + idamax_(&i__1, &ap[kc + 1], &c__1);
+ colmax = (d__1 = ap[kc + imax - k], abs(d__1));
+ } else {
+ colmax = 0.;
+ }
+
+ if (max(absakk,colmax) == 0.) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ rowmax = 0.;
+ kx = kc + imax - k;
+ i__1 = imax - 1;
+ for (j = k; j <= i__1; ++j) {
+ if ((d__1 = ap[kx], abs(d__1)) > rowmax) {
+ rowmax = (d__1 = ap[kx], abs(d__1));
+ jmax = j;
+ }
+ kx = kx + *n - j;
+/* L70: */
+ }
+ kpc = npp - (*n - imax + 1) * (*n - imax + 2) / 2 + 1;
+ if (imax < *n) {
+ i__1 = *n - imax;
+ jmax = imax + idamax_(&i__1, &ap[kpc + 1], &c__1);
+/* Computing MAX */
+ d__2 = rowmax, d__3 = (d__1 = ap[kpc + jmax - imax], abs(
+ d__1));
+ rowmax = max(d__2,d__3);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else if ((d__1 = ap[kpc], abs(d__1)) >= alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+
+ kk = k + kstep - 1;
+ if (kstep == 2) {
+ knc = knc + *n - k + 1;
+ }
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the trailing */
+/* submatrix A(k:n,k:n) */
+
+ if (kp < *n) {
+ i__1 = *n - kp;
+ dswap_(&i__1, &ap[knc + kp - kk + 1], &c__1, &ap[kpc + 1],
+ &c__1);
+ }
+ kx = knc + kp - kk;
+ i__1 = kp - 1;
+ for (j = kk + 1; j <= i__1; ++j) {
+ kx = kx + *n - j + 1;
+ t = ap[knc + j - kk];
+ ap[knc + j - kk] = ap[kx];
+ ap[kx] = t;
+/* L80: */
+ }
+ t = ap[knc];
+ ap[knc] = ap[kpc];
+ ap[kpc] = t;
+ if (kstep == 2) {
+ t = ap[kc + 1];
+ ap[kc + 1] = ap[kc + kp - k];
+ ap[kc + kp - k] = t;
+ }
+ }
+
+/* Update the trailing submatrix */
+
+ if (kstep == 1) {
+
+/* 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 < *n) {
+
+/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
+
+/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */
+
+ r1 = 1. / ap[kc];
+ i__1 = *n - k;
+ d__1 = -r1;
+ dspr_(uplo, &i__1, &d__1, &ap[kc + 1], &c__1, &ap[kc + *n
+ - k + 1]);
+
+/* Store L(k) in column K */
+
+ i__1 = *n - k;
+ dscal_(&i__1, &r1, &ap[kc + 1], &c__1);
+ }
+ } 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 */
+
+ if (k < *n - 1) {
+
+/* 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) )' */
+/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' */
+
+ d21 = ap[k + 1 + (k - 1) * ((*n << 1) - k) / 2];
+ d11 = ap[k + 1 + k * ((*n << 1) - k - 1) / 2] / d21;
+ d22 = ap[k + (k - 1) * ((*n << 1) - k) / 2] / d21;
+ t = 1. / (d11 * d22 - 1.);
+ d21 = t / d21;
+
+ i__1 = *n;
+ for (j = k + 2; j <= i__1; ++j) {
+ wk = d21 * (d11 * ap[j + (k - 1) * ((*n << 1) - k) /
+ 2] - ap[j + k * ((*n << 1) - k - 1) / 2]);
+ wkp1 = d21 * (d22 * ap[j + k * ((*n << 1) - k - 1) /
+ 2] - ap[j + (k - 1) * ((*n << 1) - k) / 2]);
+
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ap[i__ + (j - 1) * ((*n << 1) - j) / 2] = ap[i__
+ + (j - 1) * ((*n << 1) - j) / 2] - ap[i__
+ + (k - 1) * ((*n << 1) - k) / 2] * wk -
+ ap[i__ + k * ((*n << 1) - k - 1) / 2] *
+ wkp1;
+/* L90: */
+ }
+
+ ap[j + (k - 1) * ((*n << 1) - k) / 2] = wk;
+ ap[j + k * ((*n << 1) - k - 1) / 2] = wkp1;
+
+/* L100: */
+ }
+ }
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k + 1] = -kp;
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kstep;
+ kc = knc + *n - k + 2;
+ goto L60;
+
+ }
+
+L110:
+ return 0;
+
+/* End of DSPTRF */
+
+} /* dsptrf_ */
diff --git a/SRC/dsptri.c b/SRC/dsptri.c
new file mode 100644
index 0000000..962be35
--- /dev/null
+++ b/SRC/dsptri.c
@@ -0,0 +1,411 @@
+/* dsptri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b11 = -1.;
+static doublereal c_b13 = 0.;
+
+/* Subroutine */ int dsptri_(char *uplo, integer *n, doublereal *ap, integer *
+ ipiv, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Local variables */
+ doublereal d__;
+ integer j, k;
+ doublereal t, ak;
+ integer kc, kp, kx, kpc, npp;
+ doublereal akp1;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal temp, akkp1;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dswap_(integer *, doublereal *, integer
+ *, doublereal *, integer *);
+ integer kstep;
+ extern /* Subroutine */ int dspmv_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer kcnext;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSPTRI computes the inverse of a real symmetric indefinite matrix */
+/* A in packed storage using the factorization A = U*D*U**T or */
+/* A = L*D*L**T computed by DSPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* On entry, the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L as computed by DSPTRF, */
+/* stored as a packed triangular matrix. */
+
+/* On exit, if INFO = 0, the (symmetric) inverse of the original */
+/* matrix, stored as a packed triangular matrix. The j-th column */
+/* of inv(A) is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by DSPTRF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) 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. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --work;
+ --ipiv;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSPTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ kp = *n * (*n + 1) / 2;
+ for (*info = *n; *info >= 1; --(*info)) {
+ if (ipiv[*info] > 0 && ap[kp] == 0.) {
+ return 0;
+ }
+ kp -= *info;
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ kp = 1;
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ if (ipiv[*info] > 0 && ap[kp] == 0.) {
+ return 0;
+ }
+ kp = kp + *n - *info + 1;
+/* L20: */
+ }
+ }
+ *info = 0;
+
+ if (upper) {
+
+/* Compute inv(A) from the factorization A = U*D*U'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+ kc = 1;
+L30:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L50;
+ }
+
+ kcnext = kc + k;
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ ap[kc + k - 1] = 1. / ap[kc + k - 1];
+
+/* Compute column K of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ dcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ dspmv_(uplo, &i__1, &c_b11, &ap[1], &work[1], &c__1, &c_b13, &
+ ap[kc], &c__1);
+ i__1 = k - 1;
+ ap[kc + k - 1] -= ddot_(&i__1, &work[1], &c__1, &ap[kc], &
+ c__1);
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ t = (d__1 = ap[kcnext + k - 1], abs(d__1));
+ ak = ap[kc + k - 1] / t;
+ akp1 = ap[kcnext + k] / t;
+ akkp1 = ap[kcnext + k - 1] / t;
+ d__ = t * (ak * akp1 - 1.);
+ ap[kc + k - 1] = akp1 / d__;
+ ap[kcnext + k] = ak / d__;
+ ap[kcnext + k - 1] = -akkp1 / d__;
+
+/* Compute columns K and K+1 of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ dcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ dspmv_(uplo, &i__1, &c_b11, &ap[1], &work[1], &c__1, &c_b13, &
+ ap[kc], &c__1);
+ i__1 = k - 1;
+ ap[kc + k - 1] -= ddot_(&i__1, &work[1], &c__1, &ap[kc], &
+ c__1);
+ i__1 = k - 1;
+ ap[kcnext + k - 1] -= ddot_(&i__1, &ap[kc], &c__1, &ap[kcnext]
+, &c__1);
+ i__1 = k - 1;
+ dcopy_(&i__1, &ap[kcnext], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ dspmv_(uplo, &i__1, &c_b11, &ap[1], &work[1], &c__1, &c_b13, &
+ ap[kcnext], &c__1);
+ i__1 = k - 1;
+ ap[kcnext + k] -= ddot_(&i__1, &work[1], &c__1, &ap[kcnext], &
+ c__1);
+ }
+ kstep = 2;
+ kcnext = kcnext + k + 1;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the leading */
+/* submatrix A(1:k+1,1:k+1) */
+
+ kpc = (kp - 1) * kp / 2 + 1;
+ i__1 = kp - 1;
+ dswap_(&i__1, &ap[kc], &c__1, &ap[kpc], &c__1);
+ kx = kpc + kp - 1;
+ i__1 = k - 1;
+ for (j = kp + 1; j <= i__1; ++j) {
+ kx = kx + j - 1;
+ temp = ap[kc + j - 1];
+ ap[kc + j - 1] = ap[kx];
+ ap[kx] = temp;
+/* L40: */
+ }
+ temp = ap[kc + k - 1];
+ ap[kc + k - 1] = ap[kpc + kp - 1];
+ ap[kpc + kp - 1] = temp;
+ if (kstep == 2) {
+ temp = ap[kc + k + k - 1];
+ ap[kc + k + k - 1] = ap[kc + k + kp - 1];
+ ap[kc + k + kp - 1] = temp;
+ }
+ }
+
+ k += kstep;
+ kc = kcnext;
+ goto L30;
+L50:
+
+ ;
+ } else {
+
+/* Compute inv(A) from the factorization A = L*D*L'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ npp = *n * (*n + 1) / 2;
+ k = *n;
+ kc = npp;
+L60:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L80;
+ }
+
+ kcnext = kc - (*n - k + 2);
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ ap[kc] = 1. / ap[kc];
+
+/* Compute column K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ dcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ dspmv_(uplo, &i__1, &c_b11, &ap[kc + *n - k + 1], &work[1], &
+ c__1, &c_b13, &ap[kc + 1], &c__1);
+ i__1 = *n - k;
+ ap[kc] -= ddot_(&i__1, &work[1], &c__1, &ap[kc + 1], &c__1);
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ t = (d__1 = ap[kcnext + 1], abs(d__1));
+ ak = ap[kcnext] / t;
+ akp1 = ap[kc] / t;
+ akkp1 = ap[kcnext + 1] / t;
+ d__ = t * (ak * akp1 - 1.);
+ ap[kcnext] = akp1 / d__;
+ ap[kc] = ak / d__;
+ ap[kcnext + 1] = -akkp1 / d__;
+
+/* Compute columns K-1 and K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ dcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ dspmv_(uplo, &i__1, &c_b11, &ap[kc + (*n - k + 1)], &work[1],
+ &c__1, &c_b13, &ap[kc + 1], &c__1);
+ i__1 = *n - k;
+ ap[kc] -= ddot_(&i__1, &work[1], &c__1, &ap[kc + 1], &c__1);
+ i__1 = *n - k;
+ ap[kcnext + 1] -= ddot_(&i__1, &ap[kc + 1], &c__1, &ap[kcnext
+ + 2], &c__1);
+ i__1 = *n - k;
+ dcopy_(&i__1, &ap[kcnext + 2], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ dspmv_(uplo, &i__1, &c_b11, &ap[kc + (*n - k + 1)], &work[1],
+ &c__1, &c_b13, &ap[kcnext + 2], &c__1);
+ i__1 = *n - k;
+ ap[kcnext] -= ddot_(&i__1, &work[1], &c__1, &ap[kcnext + 2], &
+ c__1);
+ }
+ kstep = 2;
+ kcnext -= *n - k + 3;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the trailing */
+/* submatrix A(k-1:n,k-1:n) */
+
+ kpc = npp - (*n - kp + 1) * (*n - kp + 2) / 2 + 1;
+ if (kp < *n) {
+ i__1 = *n - kp;
+ dswap_(&i__1, &ap[kc + kp - k + 1], &c__1, &ap[kpc + 1], &
+ c__1);
+ }
+ kx = kc + kp - k;
+ i__1 = kp - 1;
+ for (j = k + 1; j <= i__1; ++j) {
+ kx = kx + *n - j + 1;
+ temp = ap[kc + j - k];
+ ap[kc + j - k] = ap[kx];
+ ap[kx] = temp;
+/* L70: */
+ }
+ temp = ap[kc];
+ ap[kc] = ap[kpc];
+ ap[kpc] = temp;
+ if (kstep == 2) {
+ temp = ap[kc - *n + k - 1];
+ ap[kc - *n + k - 1] = ap[kc - *n + kp - 1];
+ ap[kc - *n + kp - 1] = temp;
+ }
+ }
+
+ k -= kstep;
+ kc = kcnext;
+ goto L60;
+L80:
+ ;
+ }
+
+ return 0;
+
+/* End of DSPTRI */
+
+} /* dsptri_ */
diff --git a/SRC/dsptrs.c b/SRC/dsptrs.c
new file mode 100644
index 0000000..4dc105b
--- /dev/null
+++ b/SRC/dsptrs.c
@@ -0,0 +1,456 @@
+/* dsptrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b7 = -1.;
+static integer c__1 = 1;
+static doublereal c_b19 = 1.;
+
+/* Subroutine */ int dsptrs_(char *uplo, integer *n, integer *nrhs,
+ doublereal *ap, integer *ipiv, doublereal *b, integer *ldb, integer *
+ info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+ doublereal d__1;
+
+ /* Local variables */
+ integer j, k;
+ doublereal ak, bk;
+ integer kc, kp;
+ doublereal akm1, bkm1;
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal akm1k;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ doublereal denom;
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dswap_(integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSPTRS solves a system of linear equations A*X = B with a real */
+/* symmetric matrix A stored in packed format using the factorization */
+/* A = U*D*U**T or A = L*D*L**T computed by DSPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by DSPTRF, stored as a */
+/* packed triangular matrix. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by DSPTRF. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ap;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSPTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B, where A = U*D*U'. */
+
+/* First solve U*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L10:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L30;
+ }
+
+ kc -= k;
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ i__1 = k - 1;
+ dger_(&i__1, nrhs, &c_b7, &ap[kc], &c__1, &b[k + b_dim1], ldb, &b[
+ b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ d__1 = 1. / ap[kc + k - 1];
+ dscal_(nrhs, &d__1, &b[k + b_dim1], ldb);
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K-1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k - 1) {
+ dswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ i__1 = k - 2;
+ dger_(&i__1, nrhs, &c_b7, &ap[kc], &c__1, &b[k + b_dim1], ldb, &b[
+ b_dim1 + 1], ldb);
+ i__1 = k - 2;
+ dger_(&i__1, nrhs, &c_b7, &ap[kc - (k - 1)], &c__1, &b[k - 1 +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ akm1k = ap[kc + k - 2];
+ akm1 = ap[kc - 1] / akm1k;
+ ak = ap[kc + k - 1] / akm1k;
+ denom = akm1 * ak - 1.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bkm1 = b[k - 1 + j * b_dim1] / akm1k;
+ bk = b[k + j * b_dim1] / akm1k;
+ b[k - 1 + j * b_dim1] = (ak * bkm1 - bk) / denom;
+ b[k + j * b_dim1] = (akm1 * bk - bkm1) / denom;
+/* L20: */
+ }
+ kc = kc - k + 1;
+ k += -2;
+ }
+
+ goto L10;
+L30:
+
+/* Next solve U'*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+ kc = 1;
+L40:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L50;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(U'(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ i__1 = k - 1;
+ dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &ap[kc]
+, &c__1, &c_b19, &b[k + b_dim1], ldb);
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ kc += k;
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ i__1 = k - 1;
+ dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &ap[kc]
+, &c__1, &c_b19, &b[k + b_dim1], ldb);
+ i__1 = k - 1;
+ dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &ap[kc
+ + k], &c__1, &c_b19, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ kc = kc + (k << 1) + 1;
+ k += 2;
+ }
+
+ goto L40;
+L50:
+
+ ;
+ } else {
+
+/* Solve A*X = B, where A = L*D*L'. */
+
+/* First solve L*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+ kc = 1;
+L60:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L80;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ dger_(&i__1, nrhs, &c_b7, &ap[kc + 1], &c__1, &b[k + b_dim1],
+ ldb, &b[k + 1 + b_dim1], ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ d__1 = 1. / ap[kc];
+ dscal_(nrhs, &d__1, &b[k + b_dim1], ldb);
+ kc = kc + *n - k + 1;
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K+1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k + 1) {
+ dswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ if (k < *n - 1) {
+ i__1 = *n - k - 1;
+ dger_(&i__1, nrhs, &c_b7, &ap[kc + 2], &c__1, &b[k + b_dim1],
+ ldb, &b[k + 2 + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ dger_(&i__1, nrhs, &c_b7, &ap[kc + *n - k + 2], &c__1, &b[k +
+ 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ akm1k = ap[kc + 1];
+ akm1 = ap[kc] / akm1k;
+ ak = ap[kc + *n - k + 1] / akm1k;
+ denom = akm1 * ak - 1.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bkm1 = b[k + j * b_dim1] / akm1k;
+ bk = b[k + 1 + j * b_dim1] / akm1k;
+ b[k + j * b_dim1] = (ak * bkm1 - bk) / denom;
+ b[k + 1 + j * b_dim1] = (akm1 * bk - bkm1) / denom;
+/* L70: */
+ }
+ kc = kc + (*n - k << 1) + 1;
+ k += 2;
+ }
+
+ goto L60;
+L80:
+
+/* Next solve L'*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L90:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L100;
+ }
+
+ kc -= *n - k + 1;
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(L'(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1],
+ ldb, &ap[kc + 1], &c__1, &c_b19, &b[k + b_dim1], ldb);
+ }
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1],
+ ldb, &ap[kc + 1], &c__1, &c_b19, &b[k + b_dim1], ldb);
+ i__1 = *n - k;
+ dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1],
+ ldb, &ap[kc - (*n - k)], &c__1, &c_b19, &b[k - 1 +
+ b_dim1], ldb);
+ }
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ kc -= *n - k + 2;
+ k += -2;
+ }
+
+ goto L90;
+L100:
+ ;
+ }
+
+ return 0;
+
+/* End of DSPTRS */
+
+} /* dsptrs_ */
diff --git a/SRC/dstebz.c b/SRC/dstebz.c
new file mode 100644
index 0000000..c4c7521
--- /dev/null
+++ b/SRC/dstebz.c
@@ -0,0 +1,774 @@
+/* dstebz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+static integer c__0 = 0;
+
+/* Subroutine */ int dstebz_(char *range, char *order, integer *n, doublereal
+ *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol,
+ doublereal *d__, doublereal *e, integer *m, integer *nsplit,
+ doublereal *w, integer *iblock, integer *isplit, doublereal *work,
+ integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublereal d__1, d__2, d__3, d__4, d__5;
+
+ /* Builtin functions */
+ double sqrt(doublereal), log(doublereal);
+
+ /* Local variables */
+ integer j, ib, jb, ie, je, nb;
+ doublereal gl;
+ integer im, in;
+ doublereal gu;
+ integer iw;
+ doublereal wl, wu;
+ integer nwl;
+ doublereal ulp, wlu, wul;
+ integer nwu;
+ doublereal tmp1, tmp2;
+ integer iend, ioff, iout, itmp1, jdisc;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ doublereal atoli;
+ integer iwoff;
+ doublereal bnorm;
+ integer itmax;
+ doublereal wkill, rtoli, tnorm;
+ extern doublereal dlamch_(char *);
+ integer ibegin;
+ extern /* Subroutine */ int dlaebz_(integer *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ integer irange, idiscl;
+ doublereal safemn;
+ integer idumma[1];
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer idiscu, iorder;
+ logical ncnvrg;
+ doublereal pivmin;
+ logical toofew;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+/* 8-18-00: Increase FUDGE factor for T3E (eca) */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSTEBZ computes the eigenvalues of a symmetric tridiagonal */
+/* matrix T. The user may ask for all eigenvalues, all eigenvalues */
+/* in the half-open interval (VL, VU], or the IL-th through IU-th */
+/* eigenvalues. */
+
+/* To avoid overflow, the matrix must be scaled so that its */
+/* largest element is no greater than overflow**(1/2) * */
+/* underflow**(1/4) in absolute value, and for greatest */
+/* accuracy, it should not be much smaller than that. */
+
+/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */
+/* Matrix", Report CS41, Computer Science Dept., Stanford */
+/* University, July 21, 1966. */
+
+/* Arguments */
+/* ========= */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': ("All") all eigenvalues will be found. */
+/* = 'V': ("Value") all eigenvalues in the half-open interval */
+/* (VL, VU] will be found. */
+/* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the */
+/* entire matrix) will be found. */
+
+/* ORDER (input) CHARACTER*1 */
+/* = 'B': ("By Block") the eigenvalues will be grouped by */
+/* split-off block (see IBLOCK, ISPLIT) and */
+/* ordered from smallest to largest within */
+/* the block. */
+/* = 'E': ("Entire matrix") */
+/* the eigenvalues for the entire matrix */
+/* will be ordered from smallest to */
+/* largest. */
+
+/* N (input) INTEGER */
+/* The order of the tridiagonal matrix T. N >= 0. */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. Eigenvalues less than or equal */
+/* to VL, or greater than VU, will not be returned. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) DOUBLE PRECISION */
+/* The absolute tolerance for the eigenvalues. An eigenvalue */
+/* (or cluster) is considered to be located if it has been */
+/* determined to lie in an interval whose width is ABSTOL or */
+/* less. If ABSTOL is less than or equal to zero, then ULP*|T| */
+/* will be used, where |T| means the 1-norm of T. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix T. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) off-diagonal elements of the tridiagonal matrix T. */
+
+/* M (output) INTEGER */
+/* The actual number of eigenvalues found. 0 <= M <= N. */
+/* (See also the description of INFO=2,3.) */
+
+/* NSPLIT (output) INTEGER */
+/* The number of diagonal blocks in the matrix T. */
+/* 1 <= NSPLIT <= N. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* On exit, the first M elements of W will contain the */
+/* eigenvalues. (DSTEBZ may use the remaining N-M elements as */
+/* workspace.) */
+
+/* IBLOCK (output) INTEGER array, dimension (N) */
+/* At each row/column j where E(j) is zero or small, the */
+/* matrix T is considered to split into a block diagonal */
+/* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which */
+/* block (from 1 to the number of blocks) the eigenvalue W(i) */
+/* belongs. (DSTEBZ may use the remaining N-M elements as */
+/* workspace.) */
+
+/* ISPLIT (output) INTEGER array, dimension (N) */
+/* The splitting points, at which T breaks up into submatrices. */
+/* The first submatrix consists of rows/columns 1 to ISPLIT(1), */
+/* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */
+/* etc., and the NSPLIT-th consists of rows/columns */
+/* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */
+/* (Only the first NSPLIT elements will actually be used, but */
+/* since the user cannot know a priori what value NSPLIT will */
+/* have, N words must be reserved for ISPLIT.) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: some or all of the eigenvalues failed to converge or */
+/* were not computed: */
+/* =1 or 3: Bisection failed to converge for some */
+/* eigenvalues; these eigenvalues are flagged by a */
+/* negative block number. The effect is that the */
+/* eigenvalues may not be as accurate as the */
+/* absolute and relative tolerances. This is */
+/* generally caused by unexpectedly inaccurate */
+/* arithmetic. */
+/* =2 or 3: RANGE='I' only: Not all of the eigenvalues */
+/* IL:IU were found. */
+/* Effect: M < IU+1-IL */
+/* Cause: non-monotonic arithmetic, causing the */
+/* Sturm sequence to be non-monotonic. */
+/* Cure: recalculate, using RANGE='A', and pick */
+/* out eigenvalues IL:IU. In some cases, */
+/* increasing the PARAMETER "FUDGE" may */
+/* make things work. */
+/* = 4: RANGE='I', and the Gershgorin interval */
+/* initially used was too small. No eigenvalues */
+/* were computed. */
+/* Probable cause: your machine has sloppy */
+/* floating-point arithmetic. */
+/* Cure: Increase the PARAMETER "FUDGE", */
+/* recompile, and try again. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* RELFAC DOUBLE PRECISION, default = 2.0e0 */
+/* The relative tolerance. An interval (a,b] lies within */
+/* "relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|), */
+/* where "ulp" is the machine precision (distance from 1 to */
+/* the next larger floating point number.) */
+
+/* FUDGE DOUBLE PRECISION, default = 2 */
+/* A "fudge factor" to widen the Gershgorin intervals. Ideally, */
+/* a value of 1 should work, but on machines with sloppy */
+/* arithmetic, this needs to be larger. The default for */
+/* publicly released versions should be large enough to handle */
+/* the worst machine around. Note that this has no effect */
+/* on accuracy of the solution. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --isplit;
+ --iblock;
+ --w;
+ --e;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+
+/* Decode RANGE */
+
+ if (lsame_(range, "A")) {
+ irange = 1;
+ } else if (lsame_(range, "V")) {
+ irange = 2;
+ } else if (lsame_(range, "I")) {
+ irange = 3;
+ } else {
+ irange = 0;
+ }
+
+/* Decode ORDER */
+
+ if (lsame_(order, "B")) {
+ iorder = 2;
+ } else if (lsame_(order, "E")) {
+ iorder = 1;
+ } else {
+ iorder = 0;
+ }
+
+/* Check for Errors */
+
+ if (irange <= 0) {
+ *info = -1;
+ } else if (iorder <= 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (irange == 2) {
+ if (*vl >= *vu) {
+ *info = -5;
+ }
+ } else if (irange == 3 && (*il < 1 || *il > max(1,*n))) {
+ *info = -6;
+ } else if (irange == 3 && (*iu < min(*n,*il) || *iu > *n)) {
+ *info = -7;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSTEBZ", &i__1);
+ return 0;
+ }
+
+/* Initialize error flags */
+
+ *info = 0;
+ ncnvrg = FALSE_;
+ toofew = FALSE_;
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Simplifications: */
+
+ if (irange == 3 && *il == 1 && *iu == *n) {
+ irange = 1;
+ }
+
+/* Get machine constants */
+/* NB is the minimum vector length for vector bisection, or 0 */
+/* if only scalar is to be done. */
+
+ safemn = dlamch_("S");
+ ulp = dlamch_("P");
+ rtoli = ulp * 2.;
+ nb = ilaenv_(&c__1, "DSTEBZ", " ", n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1) {
+ nb = 0;
+ }
+
+/* Special Case when N=1 */
+
+ if (*n == 1) {
+ *nsplit = 1;
+ isplit[1] = 1;
+ if (irange == 2 && (*vl >= d__[1] || *vu < d__[1])) {
+ *m = 0;
+ } else {
+ w[1] = d__[1];
+ iblock[1] = 1;
+ *m = 1;
+ }
+ return 0;
+ }
+
+/* Compute Splitting Points */
+
+ *nsplit = 1;
+ work[*n] = 0.;
+ pivmin = 1.;
+
+/* DIR$ NOVECTOR */
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing 2nd power */
+ d__1 = e[j - 1];
+ tmp1 = d__1 * d__1;
+/* Computing 2nd power */
+ d__2 = ulp;
+ if ((d__1 = d__[j] * d__[j - 1], abs(d__1)) * (d__2 * d__2) + safemn
+ > tmp1) {
+ isplit[*nsplit] = j - 1;
+ ++(*nsplit);
+ work[j - 1] = 0.;
+ } else {
+ work[j - 1] = tmp1;
+ pivmin = max(pivmin,tmp1);
+ }
+/* L10: */
+ }
+ isplit[*nsplit] = *n;
+ pivmin *= safemn;
+
+/* Compute Interval and ATOLI */
+
+ if (irange == 3) {
+
+/* RANGE='I': Compute the interval containing eigenvalues */
+/* IL through IU. */
+
+/* Compute Gershgorin interval for entire (split) matrix */
+/* and use it as the initial interval */
+
+ gu = d__[1];
+ gl = d__[1];
+ tmp1 = 0.;
+
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ tmp2 = sqrt(work[j]);
+/* Computing MAX */
+ d__1 = gu, d__2 = d__[j] + tmp1 + tmp2;
+ gu = max(d__1,d__2);
+/* Computing MIN */
+ d__1 = gl, d__2 = d__[j] - tmp1 - tmp2;
+ gl = min(d__1,d__2);
+ tmp1 = tmp2;
+/* L20: */
+ }
+
+/* Computing MAX */
+ d__1 = gu, d__2 = d__[*n] + tmp1;
+ gu = max(d__1,d__2);
+/* Computing MIN */
+ d__1 = gl, d__2 = d__[*n] - tmp1;
+ gl = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = abs(gl), d__2 = abs(gu);
+ tnorm = max(d__1,d__2);
+ gl = gl - tnorm * 2.1 * ulp * *n - pivmin * 4.2000000000000002;
+ gu = gu + tnorm * 2.1 * ulp * *n + pivmin * 2.1;
+
+/* Compute Iteration parameters */
+
+ itmax = (integer) ((log(tnorm + pivmin) - log(pivmin)) / log(2.)) + 2;
+ if (*abstol <= 0.) {
+ atoli = ulp * tnorm;
+ } else {
+ atoli = *abstol;
+ }
+
+ work[*n + 1] = gl;
+ work[*n + 2] = gl;
+ work[*n + 3] = gu;
+ work[*n + 4] = gu;
+ work[*n + 5] = gl;
+ work[*n + 6] = gu;
+ iwork[1] = -1;
+ iwork[2] = -1;
+ iwork[3] = *n + 1;
+ iwork[4] = *n + 1;
+ iwork[5] = *il - 1;
+ iwork[6] = *iu;
+
+ dlaebz_(&c__3, &itmax, n, &c__2, &c__2, &nb, &atoli, &rtoli, &pivmin,
+ &d__[1], &e[1], &work[1], &iwork[5], &work[*n + 1], &work[*n
+ + 5], &iout, &iwork[1], &w[1], &iblock[1], &iinfo);
+
+ if (iwork[6] == *iu) {
+ wl = work[*n + 1];
+ wlu = work[*n + 3];
+ nwl = iwork[1];
+ wu = work[*n + 4];
+ wul = work[*n + 2];
+ nwu = iwork[4];
+ } else {
+ wl = work[*n + 2];
+ wlu = work[*n + 4];
+ nwl = iwork[2];
+ wu = work[*n + 3];
+ wul = work[*n + 1];
+ nwu = iwork[3];
+ }
+
+ if (nwl < 0 || nwl >= *n || nwu < 1 || nwu > *n) {
+ *info = 4;
+ return 0;
+ }
+ } else {
+
+/* RANGE='A' or 'V' -- Set ATOLI */
+
+/* Computing MAX */
+ d__3 = abs(d__[1]) + abs(e[1]), d__4 = (d__1 = d__[*n], abs(d__1)) + (
+ d__2 = e[*n - 1], abs(d__2));
+ tnorm = max(d__3,d__4);
+
+ i__1 = *n - 1;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MAX */
+ d__4 = tnorm, d__5 = (d__1 = d__[j], abs(d__1)) + (d__2 = e[j - 1]
+ , abs(d__2)) + (d__3 = e[j], abs(d__3));
+ tnorm = max(d__4,d__5);
+/* L30: */
+ }
+
+ if (*abstol <= 0.) {
+ atoli = ulp * tnorm;
+ } else {
+ atoli = *abstol;
+ }
+
+ if (irange == 2) {
+ wl = *vl;
+ wu = *vu;
+ } else {
+ wl = 0.;
+ wu = 0.;
+ }
+ }
+
+/* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU. */
+/* NWL accumulates the number of eigenvalues .le. WL, */
+/* NWU accumulates the number of eigenvalues .le. WU */
+
+ *m = 0;
+ iend = 0;
+ *info = 0;
+ nwl = 0;
+ nwu = 0;
+
+ i__1 = *nsplit;
+ for (jb = 1; jb <= i__1; ++jb) {
+ ioff = iend;
+ ibegin = ioff + 1;
+ iend = isplit[jb];
+ in = iend - ioff;
+
+ if (in == 1) {
+
+/* Special Case -- IN=1 */
+
+ if (irange == 1 || wl >= d__[ibegin] - pivmin) {
+ ++nwl;
+ }
+ if (irange == 1 || wu >= d__[ibegin] - pivmin) {
+ ++nwu;
+ }
+ if (irange == 1 || wl < d__[ibegin] - pivmin && wu >= d__[ibegin]
+ - pivmin) {
+ ++(*m);
+ w[*m] = d__[ibegin];
+ iblock[*m] = jb;
+ }
+ } else {
+
+/* General Case -- IN > 1 */
+
+/* Compute Gershgorin Interval */
+/* and use it as the initial interval */
+
+ gu = d__[ibegin];
+ gl = d__[ibegin];
+ tmp1 = 0.;
+
+ i__2 = iend - 1;
+ for (j = ibegin; j <= i__2; ++j) {
+ tmp2 = (d__1 = e[j], abs(d__1));
+/* Computing MAX */
+ d__1 = gu, d__2 = d__[j] + tmp1 + tmp2;
+ gu = max(d__1,d__2);
+/* Computing MIN */
+ d__1 = gl, d__2 = d__[j] - tmp1 - tmp2;
+ gl = min(d__1,d__2);
+ tmp1 = tmp2;
+/* L40: */
+ }
+
+/* Computing MAX */
+ d__1 = gu, d__2 = d__[iend] + tmp1;
+ gu = max(d__1,d__2);
+/* Computing MIN */
+ d__1 = gl, d__2 = d__[iend] - tmp1;
+ gl = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = abs(gl), d__2 = abs(gu);
+ bnorm = max(d__1,d__2);
+ gl = gl - bnorm * 2.1 * ulp * in - pivmin * 2.1;
+ gu = gu + bnorm * 2.1 * ulp * in + pivmin * 2.1;
+
+/* Compute ATOLI for the current submatrix */
+
+ if (*abstol <= 0.) {
+/* Computing MAX */
+ d__1 = abs(gl), d__2 = abs(gu);
+ atoli = ulp * max(d__1,d__2);
+ } else {
+ atoli = *abstol;
+ }
+
+ if (irange > 1) {
+ if (gu < wl) {
+ nwl += in;
+ nwu += in;
+ goto L70;
+ }
+ gl = max(gl,wl);
+ gu = min(gu,wu);
+ if (gl >= gu) {
+ goto L70;
+ }
+ }
+
+/* Set Up Initial Interval */
+
+ work[*n + 1] = gl;
+ work[*n + in + 1] = gu;
+ dlaebz_(&c__1, &c__0, &in, &in, &c__1, &nb, &atoli, &rtoli, &
+ pivmin, &d__[ibegin], &e[ibegin], &work[ibegin], idumma, &
+ work[*n + 1], &work[*n + (in << 1) + 1], &im, &iwork[1], &
+ w[*m + 1], &iblock[*m + 1], &iinfo);
+
+ nwl += iwork[1];
+ nwu += iwork[in + 1];
+ iwoff = *m - iwork[1];
+
+/* Compute Eigenvalues */
+
+ itmax = (integer) ((log(gu - gl + pivmin) - log(pivmin)) / log(2.)
+ ) + 2;
+ dlaebz_(&c__2, &itmax, &in, &in, &c__1, &nb, &atoli, &rtoli, &
+ pivmin, &d__[ibegin], &e[ibegin], &work[ibegin], idumma, &
+ work[*n + 1], &work[*n + (in << 1) + 1], &iout, &iwork[1],
+ &w[*m + 1], &iblock[*m + 1], &iinfo);
+
+/* Copy Eigenvalues Into W and IBLOCK */
+/* Use -JB for block number for unconverged eigenvalues. */
+
+ i__2 = iout;
+ for (j = 1; j <= i__2; ++j) {
+ tmp1 = (work[j + *n] + work[j + in + *n]) * .5;
+
+/* Flag non-convergence. */
+
+ if (j > iout - iinfo) {
+ ncnvrg = TRUE_;
+ ib = -jb;
+ } else {
+ ib = jb;
+ }
+ i__3 = iwork[j + in] + iwoff;
+ for (je = iwork[j] + 1 + iwoff; je <= i__3; ++je) {
+ w[je] = tmp1;
+ iblock[je] = ib;
+/* L50: */
+ }
+/* L60: */
+ }
+
+ *m += im;
+ }
+L70:
+ ;
+ }
+
+/* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU */
+/* If NWL+1 < IL or NWU > IU, discard extra eigenvalues. */
+
+ if (irange == 3) {
+ im = 0;
+ idiscl = *il - 1 - nwl;
+ idiscu = nwu - *iu;
+
+ if (idiscl > 0 || idiscu > 0) {
+ i__1 = *m;
+ for (je = 1; je <= i__1; ++je) {
+ if (w[je] <= wlu && idiscl > 0) {
+ --idiscl;
+ } else if (w[je] >= wul && idiscu > 0) {
+ --idiscu;
+ } else {
+ ++im;
+ w[im] = w[je];
+ iblock[im] = iblock[je];
+ }
+/* L80: */
+ }
+ *m = im;
+ }
+ if (idiscl > 0 || idiscu > 0) {
+
+/* Code to deal with effects of bad arithmetic: */
+/* Some low eigenvalues to be discarded are not in (WL,WLU], */
+/* or high eigenvalues to be discarded are not in (WUL,WU] */
+/* so just kill off the smallest IDISCL/largest IDISCU */
+/* eigenvalues, by simply finding the smallest/largest */
+/* eigenvalue(s). */
+
+/* (If N(w) is monotone non-decreasing, this should never */
+/* happen.) */
+
+ if (idiscl > 0) {
+ wkill = wu;
+ i__1 = idiscl;
+ for (jdisc = 1; jdisc <= i__1; ++jdisc) {
+ iw = 0;
+ i__2 = *m;
+ for (je = 1; je <= i__2; ++je) {
+ if (iblock[je] != 0 && (w[je] < wkill || iw == 0)) {
+ iw = je;
+ wkill = w[je];
+ }
+/* L90: */
+ }
+ iblock[iw] = 0;
+/* L100: */
+ }
+ }
+ if (idiscu > 0) {
+
+ wkill = wl;
+ i__1 = idiscu;
+ for (jdisc = 1; jdisc <= i__1; ++jdisc) {
+ iw = 0;
+ i__2 = *m;
+ for (je = 1; je <= i__2; ++je) {
+ if (iblock[je] != 0 && (w[je] > wkill || iw == 0)) {
+ iw = je;
+ wkill = w[je];
+ }
+/* L110: */
+ }
+ iblock[iw] = 0;
+/* L120: */
+ }
+ }
+ im = 0;
+ i__1 = *m;
+ for (je = 1; je <= i__1; ++je) {
+ if (iblock[je] != 0) {
+ ++im;
+ w[im] = w[je];
+ iblock[im] = iblock[je];
+ }
+/* L130: */
+ }
+ *m = im;
+ }
+ if (idiscl < 0 || idiscu < 0) {
+ toofew = TRUE_;
+ }
+ }
+
+/* If ORDER='B', do nothing -- the eigenvalues are already sorted */
+/* by block. */
+/* If ORDER='E', sort the eigenvalues from smallest to largest */
+
+ if (iorder == 1 && *nsplit > 1) {
+ i__1 = *m - 1;
+ for (je = 1; je <= i__1; ++je) {
+ ie = 0;
+ tmp1 = w[je];
+ i__2 = *m;
+ for (j = je + 1; j <= i__2; ++j) {
+ if (w[j] < tmp1) {
+ ie = j;
+ tmp1 = w[j];
+ }
+/* L140: */
+ }
+
+ if (ie != 0) {
+ itmp1 = iblock[ie];
+ w[ie] = w[je];
+ iblock[ie] = iblock[je];
+ w[je] = tmp1;
+ iblock[je] = itmp1;
+ }
+/* L150: */
+ }
+ }
+
+ *info = 0;
+ if (ncnvrg) {
+ ++(*info);
+ }
+ if (toofew) {
+ *info += 2;
+ }
+ return 0;
+
+/* End of DSTEBZ */
+
+} /* dstebz_ */
diff --git a/SRC/dstedc.c b/SRC/dstedc.c
new file mode 100644
index 0000000..6824ecc
--- /dev/null
+++ b/SRC/dstedc.c
@@ -0,0 +1,488 @@
+/* dstedc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__9 = 9;
+static integer c__0 = 0;
+static integer c__2 = 2;
+static doublereal c_b17 = 0.;
+static doublereal c_b18 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dstedc_(char *compz, integer *n, doublereal *d__,
+ doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double log(doublereal);
+ integer pow_ii(integer *, integer *);
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, m;
+ doublereal p;
+ integer ii, lgn;
+ doublereal eps, tiny;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer lwmin;
+ extern /* Subroutine */ int dlaed0_(integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ integer start;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), dlacpy_(char *, integer *, integer
+ *, doublereal *, integer *, doublereal *, integer *),
+ dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer finish;
+ extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
+ extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
+ integer *), dlasrt_(char *, integer *, doublereal *, integer *);
+ integer liwmin, icompz;
+ extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *);
+ doublereal orgnrm;
+ logical lquery;
+ integer smlsiz, storez, strtrw;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSTEDC computes all eigenvalues and, optionally, eigenvectors of a */
+/* symmetric tridiagonal matrix using the divide and conquer method. */
+/* The eigenvectors of a full or band real symmetric matrix can also be */
+/* found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this */
+/* matrix to tridiagonal form. */
+
+/* This code makes very mild assumptions about floating point */
+/* arithmetic. It will work on machines with a guard digit in */
+/* add/subtract, or on those binary machines without guard digits */
+/* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */
+/* It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. See DLAED3 for details. */
+
+/* Arguments */
+/* ========= */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only. */
+/* = 'I': Compute eigenvectors of tridiagonal matrix also. */
+/* = 'V': Compute eigenvectors of original dense symmetric */
+/* matrix also. On entry, Z contains the orthogonal */
+/* matrix used to reduce the original matrix to */
+/* tridiagonal form. */
+
+/* N (input) INTEGER */
+/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the diagonal elements of the tridiagonal matrix. */
+/* On exit, if INFO = 0, the eigenvalues in ascending order. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* On entry, the subdiagonal elements of the tridiagonal matrix. */
+/* On exit, E has been destroyed. */
+
+/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
+/* On entry, if COMPZ = 'V', then Z contains the orthogonal */
+/* matrix used in the reduction to tridiagonal form. */
+/* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */
+/* orthonormal eigenvectors of the original symmetric matrix, */
+/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */
+/* of the symmetric tridiagonal matrix. */
+/* If COMPZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1. */
+/* If eigenvectors are desired, then LDZ >= max(1,N). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, */
+/* dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If COMPZ = 'N' or N <= 1 then LWORK must be at least 1. */
+/* If COMPZ = 'V' and N > 1 then LWORK must be at least */
+/* ( 1 + 3*N + 2*N*lg N + 3*N**2 ), */
+/* where lg( N ) = smallest integer k such */
+/* that 2**k >= N. */
+/* If COMPZ = 'I' and N > 1 then LWORK must be at least */
+/* ( 1 + 4*N + N**2 ). */
+/* Note that for COMPZ = 'I' or 'V', then if N is less than or */
+/* equal to the minimum divide size, usually 25, then LWORK need */
+/* only be max(1,2*(N-1)). */
+
+/* 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. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1. */
+/* If COMPZ = 'V' and N > 1 then LIWORK must be at least */
+/* ( 6 + 6*N + 5*N*lg N ). */
+/* If COMPZ = 'I' and N > 1 then LIWORK must be at least */
+/* ( 3 + 5*N ). */
+/* Note that for COMPZ = 'I' or 'V', then if N is less than or */
+/* equal to the minimum divide size, usually 25, then LIWORK */
+/* need only be 1. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal size of the IWORK array, */
+/* returns this value as the first entry of the IWORK array, and */
+/* no error message related to LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: The algorithm failed to compute an eigenvalue while */
+/* working on the submatrix lying in rows and columns */
+/* INFO/(N+1) through mod(INFO,N+1). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+/* Modified by Francoise Tisseur, University of Tennessee. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1 || *liwork == -1;
+
+ if (lsame_(compz, "N")) {
+ icompz = 0;
+ } else if (lsame_(compz, "V")) {
+ icompz = 1;
+ } else if (lsame_(compz, "I")) {
+ icompz = 2;
+ } else {
+ icompz = -1;
+ }
+ if (icompz < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
+ *info = -6;
+ }
+
+ if (*info == 0) {
+
+/* Compute the workspace requirements */
+
+ smlsiz = ilaenv_(&c__9, "DSTEDC", " ", &c__0, &c__0, &c__0, &c__0);
+ if (*n <= 1 || icompz == 0) {
+ liwmin = 1;
+ lwmin = 1;
+ } else if (*n <= smlsiz) {
+ liwmin = 1;
+ lwmin = *n - 1 << 1;
+ } else {
+ lgn = (integer) (log((doublereal) (*n)) / log(2.));
+ if (pow_ii(&c__2, &lgn) < *n) {
+ ++lgn;
+ }
+ if (pow_ii(&c__2, &lgn) < *n) {
+ ++lgn;
+ }
+ if (icompz == 1) {
+/* Computing 2nd power */
+ i__1 = *n;
+ lwmin = *n * 3 + 1 + (*n << 1) * lgn + i__1 * i__1 * 3;
+ liwmin = *n * 6 + 6 + *n * 5 * lgn;
+ } else if (icompz == 2) {
+/* Computing 2nd power */
+ i__1 = *n;
+ lwmin = (*n << 2) + 1 + i__1 * i__1;
+ liwmin = *n * 5 + 3;
+ }
+ }
+ work[1] = (doublereal) lwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -8;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -10;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSTEDC", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+ if (*n == 1) {
+ if (icompz != 0) {
+ z__[z_dim1 + 1] = 1.;
+ }
+ return 0;
+ }
+
+/* If the following conditional clause is removed, then the routine */
+/* will use the Divide and Conquer routine to compute only the */
+/* eigenvalues, which requires (3N + 3N**2) real workspace and */
+/* (2 + 5N + 2N lg(N)) integer workspace. */
+/* Since on many architectures DSTERF is much faster than any other */
+/* algorithm for finding eigenvalues only, it is used here */
+/* as the default. If the conditional clause is removed, then */
+/* information on the size of workspace needs to be changed. */
+
+/* If COMPZ = 'N', use DSTERF to compute the eigenvalues. */
+
+ if (icompz == 0) {
+ dsterf_(n, &d__[1], &e[1], info);
+ goto L50;
+ }
+
+/* If N is smaller than the minimum divide size (SMLSIZ+1), then */
+/* solve the problem with another solver. */
+
+ if (*n <= smlsiz) {
+
+ dsteqr_(compz, n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], info);
+
+ } else {
+
+/* If COMPZ = 'V', the Z matrix must be stored elsewhere for later */
+/* use. */
+
+ if (icompz == 1) {
+ storez = *n * *n + 1;
+ } else {
+ storez = 1;
+ }
+
+ if (icompz == 2) {
+ dlaset_("Full", n, n, &c_b17, &c_b18, &z__[z_offset], ldz);
+ }
+
+/* Scale. */
+
+ orgnrm = dlanst_("M", n, &d__[1], &e[1]);
+ if (orgnrm == 0.) {
+ goto L50;
+ }
+
+ eps = dlamch_("Epsilon");
+
+ start = 1;
+
+/* while ( START <= N ) */
+
+L10:
+ if (start <= *n) {
+
+/* Let FINISH be the position of the next subdiagonal entry */
+/* such that E( FINISH ) <= TINY or FINISH = N if no such */
+/* subdiagonal exists. The matrix identified by the elements */
+/* between START and FINISH constitutes an independent */
+/* sub-problem. */
+
+ finish = start;
+L20:
+ if (finish < *n) {
+ tiny = eps * sqrt((d__1 = d__[finish], abs(d__1))) * sqrt((
+ d__2 = d__[finish + 1], abs(d__2)));
+ if ((d__1 = e[finish], abs(d__1)) > tiny) {
+ ++finish;
+ goto L20;
+ }
+ }
+
+/* (Sub) Problem determined. Compute its size and solve it. */
+
+ m = finish - start + 1;
+ if (m == 1) {
+ start = finish + 1;
+ goto L10;
+ }
+ if (m > smlsiz) {
+
+/* Scale. */
+
+ orgnrm = dlanst_("M", &m, &d__[start], &e[start]);
+ dlascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &m, &c__1, &d__[
+ start], &m, info);
+ i__1 = m - 1;
+ i__2 = m - 1;
+ dlascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &i__1, &c__1, &e[
+ start], &i__2, info);
+
+ if (icompz == 1) {
+ strtrw = 1;
+ } else {
+ strtrw = start;
+ }
+ dlaed0_(&icompz, n, &m, &d__[start], &e[start], &z__[strtrw +
+ start * z_dim1], ldz, &work[1], n, &work[storez], &
+ iwork[1], info);
+ if (*info != 0) {
+ *info = (*info / (m + 1) + start - 1) * (*n + 1) + *info %
+ (m + 1) + start - 1;
+ goto L50;
+ }
+
+/* Scale back. */
+
+ dlascl_("G", &c__0, &c__0, &c_b18, &orgnrm, &m, &c__1, &d__[
+ start], &m, info);
+
+ } else {
+ if (icompz == 1) {
+
+/* Since QR won't update a Z matrix which is larger than */
+/* the length of D, we must solve the sub-problem in a */
+/* workspace and then multiply back into Z. */
+
+ dsteqr_("I", &m, &d__[start], &e[start], &work[1], &m, &
+ work[m * m + 1], info);
+ dlacpy_("A", n, &m, &z__[start * z_dim1 + 1], ldz, &work[
+ storez], n);
+ dgemm_("N", "N", n, &m, &m, &c_b18, &work[storez], n, &
+ work[1], &m, &c_b17, &z__[start * z_dim1 + 1],
+ ldz);
+ } else if (icompz == 2) {
+ dsteqr_("I", &m, &d__[start], &e[start], &z__[start +
+ start * z_dim1], ldz, &work[1], info);
+ } else {
+ dsterf_(&m, &d__[start], &e[start], info);
+ }
+ if (*info != 0) {
+ *info = start * (*n + 1) + finish;
+ goto L50;
+ }
+ }
+
+ start = finish + 1;
+ goto L10;
+ }
+
+/* endwhile */
+
+/* If the problem split any number of times, then the eigenvalues */
+/* will not be properly ordered. Here we permute the eigenvalues */
+/* (and the associated eigenvectors) into ascending order. */
+
+ if (m != *n) {
+ if (icompz == 0) {
+
+/* Use Quick Sort */
+
+ dlasrt_("I", n, &d__[1], info);
+
+ } else {
+
+/* Use Selection Sort to minimize swaps of eigenvectors */
+
+ i__1 = *n;
+ for (ii = 2; ii <= i__1; ++ii) {
+ i__ = ii - 1;
+ k = i__;
+ p = d__[i__];
+ i__2 = *n;
+ for (j = ii; j <= i__2; ++j) {
+ if (d__[j] < p) {
+ k = j;
+ p = d__[j];
+ }
+/* L30: */
+ }
+ if (k != i__) {
+ d__[k] = d__[i__];
+ d__[i__] = p;
+ dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k *
+ z_dim1 + 1], &c__1);
+ }
+/* L40: */
+ }
+ }
+ }
+ }
+
+L50:
+ work[1] = (doublereal) lwmin;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of DSTEDC */
+
+} /* dstedc_ */
diff --git a/SRC/dstegr.c b/SRC/dstegr.c
new file mode 100644
index 0000000..257e368
--- /dev/null
+++ b/SRC/dstegr.c
@@ -0,0 +1,211 @@
+/* dstegr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dstegr_(char *jobz, char *range, integer *n, doublereal *
+ d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il,
+ integer *iu, doublereal *abstol, integer *m, doublereal *w,
+ doublereal *z__, integer *ldz, integer *isuppz, doublereal *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset;
+
+ /* Local variables */
+ extern /* Subroutine */ int dstemr_(char *, char *, integer *, doublereal
+ *, doublereal *, doublereal *, doublereal *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, integer *,
+ integer *, logical *, doublereal *, integer *, integer *, integer
+ *, integer *);
+ logical tryrac;
+
+
+
+/* -- LAPACK computational routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSTEGR computes selected eigenvalues and, optionally, eigenvectors */
+/* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */
+/* a well defined set of pairwise different real eigenvalues, the corresponding */
+/* real eigenvectors are pairwise orthogonal. */
+
+/* The spectrum may be computed either completely or partially by specifying */
+/* either an interval (VL,VU] or a range of indices IL:IU for the desired */
+/* eigenvalues. */
+
+/* DSTEGR is a compatability wrapper around the improved DSTEMR routine. */
+/* See DSTEMR for further details. */
+
+/* One important change is that the ABSTOL parameter no longer provides any */
+/* benefit and hence is no longer used. */
+
+/* Note : DSTEGR and DSTEMR work only on machines which follow */
+/* IEEE-754 floating-point standard in their handling of infinities and */
+/* NaNs. Normal execution may create these exceptiona values and hence */
+/* may abort due to a floating point exception in environments which */
+/* do not conform to the IEEE-754 standard. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the N diagonal elements of the tridiagonal matrix */
+/* T. On exit, D is overwritten. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the (N-1) subdiagonal elements of the tridiagonal */
+/* matrix T in elements 1 to N-1 of E. E(N) need not be set on */
+/* input, but is used internally as workspace. */
+/* On exit, E is overwritten. */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) DOUBLE PRECISION */
+/* Unused. Was the absolute error tolerance for the */
+/* eigenvalues/eigenvectors in previous versions. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* The first M elements contain the selected eigenvalues in */
+/* ascending order. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) */
+/* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix T */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+/* Supplying N columns is always safe. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', then LDZ >= max(1,N). */
+
+/* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) ) */
+/* The support of the eigenvectors in Z, i.e., the indices */
+/* indicating the nonzero elements in Z. The i-th computed eigenvector */
+/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */
+/* ISUPPZ( 2*i ). This is relevant in the case when the matrix */
+/* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal */
+/* (and minimal) LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,18*N) */
+/* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'. */
+/* 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. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (LIWORK) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. LIWORK >= max(1,10*N) */
+/* if the eigenvectors are desired, and LIWORK >= max(1,8*N) */
+/* if only the eigenvalues are to be computed. */
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal size of the IWORK array, */
+/* returns this value as the first entry of the IWORK array, and */
+/* no error message related to LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* On exit, INFO */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = 1X, internal error in DLARRE, */
+/* if INFO = 2X, internal error in DLARRV. */
+/* Here, the digit X = ABS( IINFO ) < 10, where IINFO is */
+/* the nonzero error code returned by DLARRE or */
+/* DLARRV, respectively. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Inderjit Dhillon, IBM Almaden, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, LBNL/NERSC, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --isuppz;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ tryrac = FALSE_;
+ dstemr_(jobz, range, n, &d__[1], &e[1], vl, vu, il, iu, m, &w[1], &z__[
+ z_offset], ldz, n, &isuppz[1], &tryrac, &work[1], lwork, &iwork[1]
+, liwork, info);
+
+/* End of DSTEGR */
+
+ return 0;
+} /* dstegr_ */
diff --git a/SRC/dstein.c b/SRC/dstein.c
new file mode 100644
index 0000000..1035c8c
--- /dev/null
+++ b/SRC/dstein.c
@@ -0,0 +1,452 @@
+/* dstein.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dstein_(integer *n, doublereal *d__, doublereal *e,
+ integer *m, doublereal *w, integer *iblock, integer *isplit,
+ doublereal *z__, integer *ldz, doublereal *work, integer *iwork,
+ integer *ifail, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2, d__3, d__4, d__5;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, b1, j1, bn;
+ doublereal xj, scl, eps, sep, nrm, tol;
+ integer its;
+ doublereal xjm, ztr, eps1;
+ integer jblk, nblk;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer jmax;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ integer iseed[4], gpind, iinfo;
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *);
+ doublereal ortol;
+ integer indrv1, indrv2, indrv3, indrv4, indrv5;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlagtf_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *
+, integer *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), dlagts_(
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *);
+ integer nrmchk;
+ extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *,
+ doublereal *);
+ integer blksiz;
+ doublereal onenrm, dtpcrt, pertol;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSTEIN computes the eigenvectors of a real symmetric tridiagonal */
+/* matrix T corresponding to specified eigenvalues, using inverse */
+/* iteration. */
+
+/* The maximum number of iterations allowed for each eigenvector is */
+/* specified by an internal parameter MAXITS (currently set to 5). */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix T. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the tridiagonal matrix */
+/* T, in elements 1 to N-1. */
+
+/* M (input) INTEGER */
+/* The number of eigenvectors to be found. 0 <= M <= N. */
+
+/* W (input) DOUBLE PRECISION array, dimension (N) */
+/* The first M elements of W contain the eigenvalues for */
+/* which eigenvectors are to be computed. The eigenvalues */
+/* should be grouped by split-off block and ordered from */
+/* smallest to largest within the block. ( The output array */
+/* W from DSTEBZ with ORDER = 'B' is expected here. ) */
+
+/* IBLOCK (input) INTEGER array, dimension (N) */
+/* The submatrix indices associated with the corresponding */
+/* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to */
+/* the first submatrix from the top, =2 if W(i) belongs to */
+/* the second submatrix, etc. ( The output array IBLOCK */
+/* from DSTEBZ is expected here. ) */
+
+/* ISPLIT (input) INTEGER array, dimension (N) */
+/* The splitting points, at which T breaks up into submatrices. */
+/* The first submatrix consists of rows/columns 1 to */
+/* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 */
+/* through ISPLIT( 2 ), etc. */
+/* ( The output array ISPLIT from DSTEBZ is expected here. ) */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDZ, M) */
+/* The computed eigenvectors. The eigenvector associated */
+/* with the eigenvalue W(i) is stored in the i-th column of */
+/* Z. Any vector which fails to converge is set to its current */
+/* iterate after MAXITS iterations. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (5*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* IFAIL (output) INTEGER array, dimension (M) */
+/* On normal exit, all elements of IFAIL are zero. */
+/* If one or more eigenvectors fail to converge after */
+/* MAXITS iterations, then their indices are stored in */
+/* array IFAIL. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, then i eigenvectors failed to converge */
+/* in MAXITS iterations. Their indices are stored in */
+/* array IFAIL. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* MAXITS INTEGER, default = 5 */
+/* The maximum number of iterations performed. */
+
+/* EXTRA INTEGER, default = 2 */
+/* The number of iterations performed after norm growth */
+/* criterion is satisfied, should be at least 1. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --w;
+ --iblock;
+ --isplit;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ *info = 0;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ifail[i__] = 0;
+/* L10: */
+ }
+
+ if (*n < 0) {
+ *info = -1;
+ } else if (*m < 0 || *m > *n) {
+ *info = -4;
+ } else if (*ldz < max(1,*n)) {
+ *info = -9;
+ } else {
+ i__1 = *m;
+ for (j = 2; j <= i__1; ++j) {
+ if (iblock[j] < iblock[j - 1]) {
+ *info = -6;
+ goto L30;
+ }
+ if (iblock[j] == iblock[j - 1] && w[j] < w[j - 1]) {
+ *info = -5;
+ goto L30;
+ }
+/* L20: */
+ }
+L30:
+ ;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSTEIN", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *m == 0) {
+ return 0;
+ } else if (*n == 1) {
+ z__[z_dim1 + 1] = 1.;
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ eps = dlamch_("Precision");
+
+/* Initialize seed for random number generator DLARNV. */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = 1;
+/* L40: */
+ }
+
+/* Initialize pointers. */
+
+ indrv1 = 0;
+ indrv2 = indrv1 + *n;
+ indrv3 = indrv2 + *n;
+ indrv4 = indrv3 + *n;
+ indrv5 = indrv4 + *n;
+
+/* Compute eigenvectors of matrix blocks. */
+
+ j1 = 1;
+ i__1 = iblock[*m];
+ for (nblk = 1; nblk <= i__1; ++nblk) {
+
+/* Find starting and ending indices of block nblk. */
+
+ if (nblk == 1) {
+ b1 = 1;
+ } else {
+ b1 = isplit[nblk - 1] + 1;
+ }
+ bn = isplit[nblk];
+ blksiz = bn - b1 + 1;
+ if (blksiz == 1) {
+ goto L60;
+ }
+ gpind = b1;
+
+/* Compute reorthogonalization criterion and stopping criterion. */
+
+ onenrm = (d__1 = d__[b1], abs(d__1)) + (d__2 = e[b1], abs(d__2));
+/* Computing MAX */
+ d__3 = onenrm, d__4 = (d__1 = d__[bn], abs(d__1)) + (d__2 = e[bn - 1],
+ abs(d__2));
+ onenrm = max(d__3,d__4);
+ i__2 = bn - 1;
+ for (i__ = b1 + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__4 = onenrm, d__5 = (d__1 = d__[i__], abs(d__1)) + (d__2 = e[
+ i__ - 1], abs(d__2)) + (d__3 = e[i__], abs(d__3));
+ onenrm = max(d__4,d__5);
+/* L50: */
+ }
+ ortol = onenrm * .001;
+
+ dtpcrt = sqrt(.1 / blksiz);
+
+/* Loop through eigenvalues of block nblk. */
+
+L60:
+ jblk = 0;
+ i__2 = *m;
+ for (j = j1; j <= i__2; ++j) {
+ if (iblock[j] != nblk) {
+ j1 = j;
+ goto L160;
+ }
+ ++jblk;
+ xj = w[j];
+
+/* Skip all the work if the block size is one. */
+
+ if (blksiz == 1) {
+ work[indrv1 + 1] = 1.;
+ goto L120;
+ }
+
+/* If eigenvalues j and j-1 are too close, add a relatively */
+/* small perturbation. */
+
+ if (jblk > 1) {
+ eps1 = (d__1 = eps * xj, abs(d__1));
+ pertol = eps1 * 10.;
+ sep = xj - xjm;
+ if (sep < pertol) {
+ xj = xjm + pertol;
+ }
+ }
+
+ its = 0;
+ nrmchk = 0;
+
+/* Get random starting vector. */
+
+ dlarnv_(&c__2, iseed, &blksiz, &work[indrv1 + 1]);
+
+/* Copy the matrix T so it won't be destroyed in factorization. */
+
+ dcopy_(&blksiz, &d__[b1], &c__1, &work[indrv4 + 1], &c__1);
+ i__3 = blksiz - 1;
+ dcopy_(&i__3, &e[b1], &c__1, &work[indrv2 + 2], &c__1);
+ i__3 = blksiz - 1;
+ dcopy_(&i__3, &e[b1], &c__1, &work[indrv3 + 1], &c__1);
+
+/* Compute LU factors with partial pivoting ( PT = LU ) */
+
+ tol = 0.;
+ dlagtf_(&blksiz, &work[indrv4 + 1], &xj, &work[indrv2 + 2], &work[
+ indrv3 + 1], &tol, &work[indrv5 + 1], &iwork[1], &iinfo);
+
+/* Update iteration count. */
+
+L70:
+ ++its;
+ if (its > 5) {
+ goto L100;
+ }
+
+/* Normalize and scale the righthand side vector Pb. */
+
+/* Computing MAX */
+ d__2 = eps, d__3 = (d__1 = work[indrv4 + blksiz], abs(d__1));
+ scl = blksiz * onenrm * max(d__2,d__3) / dasum_(&blksiz, &work[
+ indrv1 + 1], &c__1);
+ dscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1);
+
+/* Solve the system LU = Pb. */
+
+ dlagts_(&c_n1, &blksiz, &work[indrv4 + 1], &work[indrv2 + 2], &
+ work[indrv3 + 1], &work[indrv5 + 1], &iwork[1], &work[
+ indrv1 + 1], &tol, &iinfo);
+
+/* Reorthogonalize by modified Gram-Schmidt if eigenvalues are */
+/* close enough. */
+
+ if (jblk == 1) {
+ goto L90;
+ }
+ if ((d__1 = xj - xjm, abs(d__1)) > ortol) {
+ gpind = j;
+ }
+ if (gpind != j) {
+ i__3 = j - 1;
+ for (i__ = gpind; i__ <= i__3; ++i__) {
+ ztr = -ddot_(&blksiz, &work[indrv1 + 1], &c__1, &z__[b1 +
+ i__ * z_dim1], &c__1);
+ daxpy_(&blksiz, &ztr, &z__[b1 + i__ * z_dim1], &c__1, &
+ work[indrv1 + 1], &c__1);
+/* L80: */
+ }
+ }
+
+/* Check the infinity norm of the iterate. */
+
+L90:
+ jmax = idamax_(&blksiz, &work[indrv1 + 1], &c__1);
+ nrm = (d__1 = work[indrv1 + jmax], abs(d__1));
+
+/* Continue for additional iterations after norm reaches */
+/* stopping criterion. */
+
+ if (nrm < dtpcrt) {
+ goto L70;
+ }
+ ++nrmchk;
+ if (nrmchk < 3) {
+ goto L70;
+ }
+
+ goto L110;
+
+/* If stopping criterion was not satisfied, update info and */
+/* store eigenvector number in array ifail. */
+
+L100:
+ ++(*info);
+ ifail[*info] = j;
+
+/* Accept iterate as jth eigenvector. */
+
+L110:
+ scl = 1. / dnrm2_(&blksiz, &work[indrv1 + 1], &c__1);
+ jmax = idamax_(&blksiz, &work[indrv1 + 1], &c__1);
+ if (work[indrv1 + jmax] < 0.) {
+ scl = -scl;
+ }
+ dscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1);
+L120:
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ z__[i__ + j * z_dim1] = 0.;
+/* L130: */
+ }
+ i__3 = blksiz;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ z__[b1 + i__ - 1 + j * z_dim1] = work[indrv1 + i__];
+/* L140: */
+ }
+
+/* Save the shift to check eigenvalue spacing at next */
+/* iteration. */
+
+ xjm = xj;
+
+/* L150: */
+ }
+L160:
+ ;
+ }
+
+ return 0;
+
+/* End of DSTEIN */
+
+} /* dstein_ */
diff --git a/SRC/dstemr.c b/SRC/dstemr.c
new file mode 100644
index 0000000..abea3d6
--- /dev/null
+++ b/SRC/dstemr.c
@@ -0,0 +1,728 @@
+/* dstemr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b18 = .001;
+
+/* Subroutine */ int dstemr_(char *jobz, char *range, integer *n, doublereal *
+ d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il,
+ integer *iu, integer *m, doublereal *w, doublereal *z__, integer *ldz,
+ integer *nzc, integer *isuppz, logical *tryrac, doublereal *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal r1, r2;
+ integer jj;
+ doublereal cs;
+ integer in;
+ doublereal sn, wl, wu;
+ integer iil, iiu;
+ doublereal eps, tmp;
+ integer indd, iend, jblk, wend;
+ doublereal rmin, rmax;
+ integer itmp;
+ doublereal tnrm;
+ extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
+ *, doublereal *, doublereal *);
+ integer inde2, itmp2;
+ doublereal rtol1, rtol2;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal scale;
+ integer indgp;
+ extern logical lsame_(char *, char *);
+ integer iinfo, iindw, ilast;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dswap_(integer *, doublereal *, integer
+ *, doublereal *, integer *);
+ integer lwmin;
+ logical wantz;
+ extern /* Subroutine */ int dlaev2_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *);
+ extern doublereal dlamch_(char *);
+ logical alleig;
+ integer ibegin;
+ logical indeig;
+ integer iindbl;
+ logical valeig;
+ extern /* Subroutine */ int dlarrc_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *, integer *, integer *), dlarre_(char *,
+ integer *, doublereal *, doublereal *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *);
+ integer wbegin;
+ doublereal safmin;
+ extern /* Subroutine */ int dlarrj_(integer *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *), xerbla_(char *, integer *);
+ doublereal bignum;
+ integer inderr, iindwk, indgrs, offset;
+ extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
+ extern /* Subroutine */ int dlarrr_(integer *, doublereal *, doublereal *,
+ integer *), dlarrv_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), dlasrt_(char *, integer *, doublereal *,
+ integer *);
+ doublereal thresh;
+ integer iinspl, ifirst, indwrk, liwmin, nzcmin;
+ doublereal pivmin;
+ integer nsplit;
+ doublereal smlnum;
+ logical lquery, zquery;
+
+
+/* -- LAPACK computational routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSTEMR computes selected eigenvalues and, optionally, eigenvectors */
+/* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */
+/* a well defined set of pairwise different real eigenvalues, the corresponding */
+/* real eigenvectors are pairwise orthogonal. */
+
+/* The spectrum may be computed either completely or partially by specifying */
+/* either an interval (VL,VU] or a range of indices IL:IU for the desired */
+/* eigenvalues. */
+
+/* Depending on the number of desired eigenvalues, these are computed either */
+/* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are */
+/* computed by the use of various suitable L D L^T factorizations near clusters */
+/* of close eigenvalues (referred to as RRRs, Relatively Robust */
+/* Representations). An informal sketch of the algorithm follows. */
+
+/* For each unreduced block (submatrix) of T, */
+/* (a) Compute T - sigma I = L D L^T, so that L and D */
+/* define all the wanted eigenvalues to high relative accuracy. */
+/* This means that small relative changes in the entries of D and L */
+/* cause only small relative changes in the eigenvalues and */
+/* eigenvectors. The standard (unfactored) representation of the */
+/* tridiagonal matrix T does not have this property in general. */
+/* (b) Compute the eigenvalues to suitable accuracy. */
+/* If the eigenvectors are desired, the algorithm attains full */
+/* accuracy of the computed eigenvalues only right before */
+/* the corresponding vectors have to be computed, see steps c) and d). */
+/* (c) For each cluster of close eigenvalues, select a new */
+/* shift close to the cluster, find a new factorization, and refine */
+/* the shifted eigenvalues to suitable accuracy. */
+/* (d) For each eigenvalue with a large enough relative separation compute */
+/* the corresponding eigenvector by forming a rank revealing twisted */
+/* factorization. Go back to (c) for any clusters that remain. */
+
+/* For more details, see: */
+/* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */
+/* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */
+/* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */
+/* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */
+/* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */
+/* 2004. Also LAPACK Working Note 154. */
+/* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */
+/* tridiagonal eigenvalue/eigenvector problem", */
+/* Computer Science Division Technical Report No. UCB/CSD-97-971, */
+/* UC Berkeley, May 1997. */
+
+/* Notes: */
+/* 1.DSTEMR works only on machines which follow IEEE-754 */
+/* floating-point standard in their handling of infinities and NaNs. */
+/* This permits the use of efficient inner loops avoiding a check for */
+/* zero divisors. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the N diagonal elements of the tridiagonal matrix */
+/* T. On exit, D is overwritten. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the (N-1) subdiagonal elements of the tridiagonal */
+/* matrix T in elements 1 to N-1 of E. E(N) need not be set on */
+/* input, but is used internally as workspace. */
+/* On exit, E is overwritten. */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* The first M elements contain the selected eigenvalues in */
+/* ascending order. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) */
+/* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix T */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and can be computed with a workspace */
+/* query by setting NZC = -1, see below. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', then LDZ >= max(1,N). */
+
+/* NZC (input) INTEGER */
+/* The number of eigenvectors to be held in the array Z. */
+/* If RANGE = 'A', then NZC >= max(1,N). */
+/* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU]. */
+/* If RANGE = 'I', then NZC >= IU-IL+1. */
+/* If NZC = -1, then a workspace query is assumed; the */
+/* routine calculates the number of columns of the array Z that */
+/* are needed to hold the eigenvectors. */
+/* This value is returned as the first entry of the Z array, and */
+/* no error message related to NZC is issued by XERBLA. */
+
+/* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) ) */
+/* The support of the eigenvectors in Z, i.e., the indices */
+/* indicating the nonzero elements in Z. The i-th computed eigenvector */
+/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */
+/* ISUPPZ( 2*i ). This is relevant in the case when the matrix */
+/* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */
+
+/* TRYRAC (input/output) LOGICAL */
+/* If TRYRAC.EQ..TRUE., indicates that the code should check whether */
+/* the tridiagonal matrix defines its eigenvalues to high relative */
+/* accuracy. If so, the code uses relative-accuracy preserving */
+/* algorithms that might be (a bit) slower depending on the matrix. */
+/* If the matrix does not define its eigenvalues to high relative */
+/* accuracy, the code can uses possibly faster algorithms. */
+/* If TRYRAC.EQ..FALSE., the code is not required to guarantee */
+/* relatively accurate eigenvalues and can use the fastest possible */
+/* techniques. */
+/* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix */
+/* does not define its eigenvalues to high relative accuracy. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal */
+/* (and minimal) LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,18*N) */
+/* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'. */
+/* 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. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (LIWORK) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. LIWORK >= max(1,10*N) */
+/* if the eigenvectors are desired, and LIWORK >= max(1,8*N) */
+/* if only the eigenvalues are to be computed. */
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal size of the IWORK array, */
+/* returns this value as the first entry of the IWORK array, and */
+/* no error message related to LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* On exit, INFO */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = 1X, internal error in DLARRE, */
+/* if INFO = 2X, internal error in DLARRV. */
+/* Here, the digit X = ABS( IINFO ) < 10, where IINFO is */
+/* the nonzero error code returned by DLARRE or */
+/* DLARRV, respectively. */
+
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --isuppz;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ lquery = *lwork == -1 || *liwork == -1;
+ zquery = *nzc == -1;
+/* DSTEMR needs WORK of size 6*N, IWORK of size 3*N. */
+/* In addition, DLARRE needs WORK of size 6*N, IWORK of size 5*N. */
+/* Furthermore, DLARRV needs WORK of size 12*N, IWORK of size 7*N. */
+ if (wantz) {
+ lwmin = *n * 18;
+ liwmin = *n * 10;
+ } else {
+/* need less workspace if only the eigenvalues are wanted */
+ lwmin = *n * 12;
+ liwmin = *n << 3;
+ }
+ wl = 0.;
+ wu = 0.;
+ iil = 0;
+ iiu = 0;
+ if (valeig) {
+/* We do not reference VL, VU in the cases RANGE = 'I','A' */
+/* The interval (WL, WU] contains all the wanted eigenvalues. */
+/* It is either given by the user or computed in DLARRE. */
+ wl = *vl;
+ wu = *vu;
+ } else if (indeig) {
+/* We do not reference IL, IU in the cases RANGE = 'V','A' */
+ iil = *il;
+ iiu = *iu;
+ }
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (valeig && *n > 0 && wu <= wl) {
+ *info = -7;
+ } else if (indeig && (iil < 1 || iil > *n)) {
+ *info = -8;
+ } else if (indeig && (iiu < iil || iiu > *n)) {
+ *info = -9;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -13;
+ } else if (*lwork < lwmin && ! lquery) {
+ *info = -17;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -19;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
+ rmax = min(d__1,d__2);
+
+ if (*info == 0) {
+ work[1] = (doublereal) lwmin;
+ iwork[1] = liwmin;
+
+ if (wantz && alleig) {
+ nzcmin = *n;
+ } else if (wantz && valeig) {
+ dlarrc_("T", n, vl, vu, &d__[1], &e[1], &safmin, &nzcmin, &itmp, &
+ itmp2, info);
+ } else if (wantz && indeig) {
+ nzcmin = iiu - iil + 1;
+ } else {
+/* WANTZ .EQ. FALSE. */
+ nzcmin = 0;
+ }
+ if (zquery && *info == 0) {
+ z__[z_dim1 + 1] = (doublereal) nzcmin;
+ } else if (*nzc < nzcmin && ! zquery) {
+ *info = -14;
+ }
+ }
+ if (*info != 0) {
+
+ i__1 = -(*info);
+ xerbla_("DSTEMR", &i__1);
+
+ return 0;
+ } else if (lquery || zquery) {
+ return 0;
+ }
+
+/* Handle N = 0, 1, and 2 cases immediately */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (alleig || indeig) {
+ *m = 1;
+ w[1] = d__[1];
+ } else {
+ if (wl < d__[1] && wu >= d__[1]) {
+ *m = 1;
+ w[1] = d__[1];
+ }
+ }
+ if (wantz && ! zquery) {
+ z__[z_dim1 + 1] = 1.;
+ isuppz[1] = 1;
+ isuppz[2] = 1;
+ }
+ return 0;
+ }
+
+ if (*n == 2) {
+ if (! wantz) {
+ dlae2_(&d__[1], &e[1], &d__[2], &r1, &r2);
+ } else if (wantz && ! zquery) {
+ dlaev2_(&d__[1], &e[1], &d__[2], &r1, &r2, &cs, &sn);
+ }
+ if (alleig || valeig && r2 > wl && r2 <= wu || indeig && iil == 1) {
+ ++(*m);
+ w[*m] = r2;
+ if (wantz && ! zquery) {
+ z__[*m * z_dim1 + 1] = -sn;
+ z__[*m * z_dim1 + 2] = cs;
+/* Note: At most one of SN and CS can be zero. */
+ if (sn != 0.) {
+ if (cs != 0.) {
+ isuppz[(*m << 1) - 1] = 1;
+ isuppz[(*m << 1) - 1] = 2;
+ } else {
+ isuppz[(*m << 1) - 1] = 1;
+ isuppz[(*m << 1) - 1] = 1;
+ }
+ } else {
+ isuppz[(*m << 1) - 1] = 2;
+ isuppz[*m * 2] = 2;
+ }
+ }
+ }
+ if (alleig || valeig && r1 > wl && r1 <= wu || indeig && iiu == 2) {
+ ++(*m);
+ w[*m] = r1;
+ if (wantz && ! zquery) {
+ z__[*m * z_dim1 + 1] = cs;
+ z__[*m * z_dim1 + 2] = sn;
+/* Note: At most one of SN and CS can be zero. */
+ if (sn != 0.) {
+ if (cs != 0.) {
+ isuppz[(*m << 1) - 1] = 1;
+ isuppz[(*m << 1) - 1] = 2;
+ } else {
+ isuppz[(*m << 1) - 1] = 1;
+ isuppz[(*m << 1) - 1] = 1;
+ }
+ } else {
+ isuppz[(*m << 1) - 1] = 2;
+ isuppz[*m * 2] = 2;
+ }
+ }
+ }
+ return 0;
+ }
+/* Continue with general N */
+ indgrs = 1;
+ inderr = (*n << 1) + 1;
+ indgp = *n * 3 + 1;
+ indd = (*n << 2) + 1;
+ inde2 = *n * 5 + 1;
+ indwrk = *n * 6 + 1;
+
+ iinspl = 1;
+ iindbl = *n + 1;
+ iindw = (*n << 1) + 1;
+ iindwk = *n * 3 + 1;
+
+/* Scale matrix to allowable range, if necessary. */
+/* The allowable range is related to the PIVMIN parameter; see the */
+/* comments in DLARRD. The preference for scaling small values */
+/* up is heuristic; we expect users' matrices not to be close to the */
+/* RMAX threshold. */
+
+ scale = 1.;
+ tnrm = dlanst_("M", n, &d__[1], &e[1]);
+ if (tnrm > 0. && tnrm < rmin) {
+ scale = rmin / tnrm;
+ } else if (tnrm > rmax) {
+ scale = rmax / tnrm;
+ }
+ if (scale != 1.) {
+ dscal_(n, &scale, &d__[1], &c__1);
+ i__1 = *n - 1;
+ dscal_(&i__1, &scale, &e[1], &c__1);
+ tnrm *= scale;
+ if (valeig) {
+/* If eigenvalues in interval have to be found, */
+/* scale (WL, WU] accordingly */
+ wl *= scale;
+ wu *= scale;
+ }
+ }
+
+/* Compute the desired eigenvalues of the tridiagonal after splitting */
+/* into smaller subblocks if the corresponding off-diagonal elements */
+/* are small */
+/* THRESH is the splitting parameter for DLARRE */
+/* A negative THRESH forces the old splitting criterion based on the */
+/* size of the off-diagonal. A positive THRESH switches to splitting */
+/* which preserves relative accuracy. */
+
+ if (*tryrac) {
+/* Test whether the matrix warrants the more expensive relative approach. */
+ dlarrr_(n, &d__[1], &e[1], &iinfo);
+ } else {
+/* The user does not care about relative accurately eigenvalues */
+ iinfo = -1;
+ }
+/* Set the splitting criterion */
+ if (iinfo == 0) {
+ thresh = eps;
+ } else {
+ thresh = -eps;
+/* relative accuracy is desired but T does not guarantee it */
+ *tryrac = FALSE_;
+ }
+
+ if (*tryrac) {
+/* Copy original diagonal, needed to guarantee relative accuracy */
+ dcopy_(n, &d__[1], &c__1, &work[indd], &c__1);
+ }
+/* Store the squares of the offdiagonal values of T */
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing 2nd power */
+ d__1 = e[j];
+ work[inde2 + j - 1] = d__1 * d__1;
+/* L5: */
+ }
+/* Set the tolerance parameters for bisection */
+ if (! wantz) {
+/* DLARRE computes the eigenvalues to full precision. */
+ rtol1 = eps * 4.;
+ rtol2 = eps * 4.;
+ } else {
+/* DLARRE computes the eigenvalues to less than full precision. */
+/* DLARRV will refine the eigenvalue approximations, and we can */
+/* need less accurate initial bisection in DLARRE. */
+/* Note: these settings do only affect the subset case and DLARRE */
+ rtol1 = sqrt(eps);
+/* Computing MAX */
+ d__1 = sqrt(eps) * .005, d__2 = eps * 4.;
+ rtol2 = max(d__1,d__2);
+ }
+ dlarre_(range, n, &wl, &wu, &iil, &iiu, &d__[1], &e[1], &work[inde2], &
+ rtol1, &rtol2, &thresh, &nsplit, &iwork[iinspl], m, &w[1], &work[
+ inderr], &work[indgp], &iwork[iindbl], &iwork[iindw], &work[
+ indgrs], &pivmin, &work[indwrk], &iwork[iindwk], &iinfo);
+ if (iinfo != 0) {
+ *info = abs(iinfo) + 10;
+ return 0;
+ }
+/* Note that if RANGE .NE. 'V', DLARRE computes bounds on the desired */
+/* part of the spectrum. All desired eigenvalues are contained in */
+/* (WL,WU] */
+ if (wantz) {
+
+/* Compute the desired eigenvectors corresponding to the computed */
+/* eigenvalues */
+
+ dlarrv_(n, &wl, &wu, &d__[1], &e[1], &pivmin, &iwork[iinspl], m, &
+ c__1, m, &c_b18, &rtol1, &rtol2, &w[1], &work[inderr], &work[
+ indgp], &iwork[iindbl], &iwork[iindw], &work[indgrs], &z__[
+ z_offset], ldz, &isuppz[1], &work[indwrk], &iwork[iindwk], &
+ iinfo);
+ if (iinfo != 0) {
+ *info = abs(iinfo) + 20;
+ return 0;
+ }
+ } else {
+/* DLARRE computes eigenvalues of the (shifted) root representation */
+/* DLARRV returns the eigenvalues of the unshifted matrix. */
+/* However, if the eigenvectors are not desired by the user, we need */
+/* to apply the corresponding shifts from DLARRE to obtain the */
+/* eigenvalues of the original matrix. */
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ itmp = iwork[iindbl + j - 1];
+ w[j] += e[iwork[iinspl + itmp - 1]];
+/* L20: */
+ }
+ }
+
+ if (*tryrac) {
+/* Refine computed eigenvalues so that they are relatively accurate */
+/* with respect to the original matrix T. */
+ ibegin = 1;
+ wbegin = 1;
+ i__1 = iwork[iindbl + *m - 1];
+ for (jblk = 1; jblk <= i__1; ++jblk) {
+ iend = iwork[iinspl + jblk - 1];
+ in = iend - ibegin + 1;
+ wend = wbegin - 1;
+/* check if any eigenvalues have to be refined in this block */
+L36:
+ if (wend < *m) {
+ if (iwork[iindbl + wend] == jblk) {
+ ++wend;
+ goto L36;
+ }
+ }
+ if (wend < wbegin) {
+ ibegin = iend + 1;
+ goto L39;
+ }
+ offset = iwork[iindw + wbegin - 1] - 1;
+ ifirst = iwork[iindw + wbegin - 1];
+ ilast = iwork[iindw + wend - 1];
+ rtol2 = eps * 4.;
+ dlarrj_(&in, &work[indd + ibegin - 1], &work[inde2 + ibegin - 1],
+ &ifirst, &ilast, &rtol2, &offset, &w[wbegin], &work[
+ inderr + wbegin - 1], &work[indwrk], &iwork[iindwk], &
+ pivmin, &tnrm, &iinfo);
+ ibegin = iend + 1;
+ wbegin = wend + 1;
+L39:
+ ;
+ }
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (scale != 1.) {
+ d__1 = 1. / scale;
+ dscal_(m, &d__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in increasing order, then sort them, */
+/* possibly along with eigenvectors. */
+
+ if (nsplit > 1) {
+ if (! wantz) {
+ dlasrt_("I", m, &w[1], &iinfo);
+ if (iinfo != 0) {
+ *info = 3;
+ return 0;
+ }
+ } else {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp) {
+ i__ = jj;
+ tmp = w[jj];
+ }
+/* L50: */
+ }
+ if (i__ != 0) {
+ w[i__] = w[j];
+ w[j] = tmp;
+ if (wantz) {
+ dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j *
+ z_dim1 + 1], &c__1);
+ itmp = isuppz[(i__ << 1) - 1];
+ isuppz[(i__ << 1) - 1] = isuppz[(j << 1) - 1];
+ isuppz[(j << 1) - 1] = itmp;
+ itmp = isuppz[i__ * 2];
+ isuppz[i__ * 2] = isuppz[j * 2];
+ isuppz[j * 2] = itmp;
+ }
+ }
+/* L60: */
+ }
+ }
+ }
+
+
+ work[1] = (doublereal) lwmin;
+ iwork[1] = liwmin;
+ return 0;
+
+/* End of DSTEMR */
+
+} /* dstemr_ */
diff --git a/SRC/dsteqr.c b/SRC/dsteqr.c
new file mode 100644
index 0000000..2d57ebb
--- /dev/null
+++ b/SRC/dsteqr.c
@@ -0,0 +1,621 @@
+/* dsteqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b9 = 0.;
+static doublereal c_b10 = 1.;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int dsteqr_(char *compz, integer *n, doublereal *d__,
+ doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ doublereal b, c__, f, g;
+ integer i__, j, k, l, m;
+ doublereal p, r__, s;
+ integer l1, ii, mm, lm1, mm1, nm1;
+ doublereal rt1, rt2, eps;
+ integer lsv;
+ doublereal tst, eps2;
+ integer lend, jtot;
+ extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
+ *, doublereal *, doublereal *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *);
+ doublereal anorm;
+ extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dlaev2_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *);
+ integer lendm1, lendp1;
+ extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
+ integer iscale;
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), dlaset_(char *, integer *, integer
+ *, doublereal *, doublereal *, doublereal *, integer *);
+ doublereal safmin;
+ extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *);
+ doublereal safmax;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
+ extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
+ integer *);
+ integer lendsv;
+ doublereal ssfmin;
+ integer nmaxit, icompz;
+ doublereal ssfmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSTEQR computes all eigenvalues and, optionally, eigenvectors of a */
+/* symmetric tridiagonal matrix using the implicit QL or QR method. */
+/* The eigenvectors of a full or band symmetric matrix can also be found */
+/* if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to */
+/* tridiagonal form. */
+
+/* Arguments */
+/* ========= */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only. */
+/* = 'V': Compute eigenvalues and eigenvectors of the original */
+/* symmetric matrix. On entry, Z must contain the */
+/* orthogonal matrix used to reduce the original matrix */
+/* to tridiagonal form. */
+/* = 'I': Compute eigenvalues and eigenvectors of the */
+/* tridiagonal matrix. Z is initialized to the identity */
+/* matrix. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the diagonal elements of the tridiagonal matrix. */
+/* On exit, if INFO = 0, the eigenvalues in ascending order. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix. */
+/* On exit, E has been destroyed. */
+
+/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) */
+/* On entry, if COMPZ = 'V', then Z contains the orthogonal */
+/* matrix used in the reduction to tridiagonal form. */
+/* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */
+/* orthonormal eigenvectors of the original symmetric matrix, */
+/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */
+/* of the symmetric tridiagonal matrix. */
+/* If COMPZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* eigenvectors are desired, then LDZ >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) */
+/* If COMPZ = 'N', then WORK is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: the algorithm has failed to find all the eigenvalues in */
+/* a total of 30*N iterations; if INFO = i, then i */
+/* elements of E have not converged to zero; on exit, D */
+/* and E contain the elements of a symmetric tridiagonal */
+/* matrix which is orthogonally similar to the original */
+/* matrix. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+ if (lsame_(compz, "N")) {
+ icompz = 0;
+ } else if (lsame_(compz, "V")) {
+ icompz = 1;
+ } else if (lsame_(compz, "I")) {
+ icompz = 2;
+ } else {
+ icompz = -1;
+ }
+ if (icompz < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSTEQR", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (icompz == 2) {
+ z__[z_dim1 + 1] = 1.;
+ }
+ return 0;
+ }
+
+/* Determine the unit roundoff and over/underflow thresholds. */
+
+ eps = dlamch_("E");
+/* Computing 2nd power */
+ d__1 = eps;
+ eps2 = d__1 * d__1;
+ safmin = dlamch_("S");
+ safmax = 1. / safmin;
+ ssfmax = sqrt(safmax) / 3.;
+ ssfmin = sqrt(safmin) / eps2;
+
+/* Compute the eigenvalues and eigenvectors of the tridiagonal */
+/* matrix. */
+
+ if (icompz == 2) {
+ dlaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz);
+ }
+
+ nmaxit = *n * 30;
+ jtot = 0;
+
+/* Determine where the matrix splits and choose QL or QR iteration */
+/* for each block, according to whether top or bottom diagonal */
+/* element is smaller. */
+
+ l1 = 1;
+ nm1 = *n - 1;
+
+L10:
+ if (l1 > *n) {
+ goto L160;
+ }
+ if (l1 > 1) {
+ e[l1 - 1] = 0.;
+ }
+ if (l1 <= nm1) {
+ i__1 = nm1;
+ for (m = l1; m <= i__1; ++m) {
+ tst = (d__1 = e[m], abs(d__1));
+ if (tst == 0.) {
+ goto L30;
+ }
+ if (tst <= sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m
+ + 1], abs(d__2))) * eps) {
+ e[m] = 0.;
+ goto L30;
+ }
+/* L20: */
+ }
+ }
+ m = *n;
+
+L30:
+ l = l1;
+ lsv = l;
+ lend = m;
+ lendsv = lend;
+ l1 = m + 1;
+ if (lend == l) {
+ goto L10;
+ }
+
+/* Scale submatrix in rows and columns L to LEND */
+
+ i__1 = lend - l + 1;
+ anorm = dlanst_("I", &i__1, &d__[l], &e[l]);
+ iscale = 0;
+ if (anorm == 0.) {
+ goto L10;
+ }
+ if (anorm > ssfmax) {
+ iscale = 1;
+ i__1 = lend - l + 1;
+ dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
+ info);
+ i__1 = lend - l;
+ dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
+ info);
+ } else if (anorm < ssfmin) {
+ iscale = 2;
+ i__1 = lend - l + 1;
+ dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
+ info);
+ i__1 = lend - l;
+ dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
+ info);
+ }
+
+/* Choose between QL and QR iteration */
+
+ if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) {
+ lend = lsv;
+ l = lendsv;
+ }
+
+ if (lend > l) {
+
+/* QL Iteration */
+
+/* Look for small subdiagonal element. */
+
+L40:
+ if (l != lend) {
+ lendm1 = lend - 1;
+ i__1 = lendm1;
+ for (m = l; m <= i__1; ++m) {
+/* Computing 2nd power */
+ d__2 = (d__1 = e[m], abs(d__1));
+ tst = d__2 * d__2;
+ if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
+ + 1], abs(d__2)) + safmin) {
+ goto L60;
+ }
+/* L50: */
+ }
+ }
+
+ m = lend;
+
+L60:
+ if (m < lend) {
+ e[m] = 0.;
+ }
+ p = d__[l];
+ if (m == l) {
+ goto L80;
+ }
+
+/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */
+/* to compute its eigensystem. */
+
+ if (m == l + 1) {
+ if (icompz > 0) {
+ dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
+ work[l] = c__;
+ work[*n - 1 + l] = s;
+ dlasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], &
+ z__[l * z_dim1 + 1], ldz);
+ } else {
+ dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
+ }
+ d__[l] = rt1;
+ d__[l + 1] = rt2;
+ e[l] = 0.;
+ l += 2;
+ if (l <= lend) {
+ goto L40;
+ }
+ goto L140;
+ }
+
+ if (jtot == nmaxit) {
+ goto L140;
+ }
+ ++jtot;
+
+/* Form shift. */
+
+ g = (d__[l + 1] - p) / (e[l] * 2.);
+ r__ = dlapy2_(&g, &c_b10);
+ g = d__[m] - p + e[l] / (g + d_sign(&r__, &g));
+
+ s = 1.;
+ c__ = 1.;
+ p = 0.;
+
+/* Inner loop */
+
+ mm1 = m - 1;
+ i__1 = l;
+ for (i__ = mm1; i__ >= i__1; --i__) {
+ f = s * e[i__];
+ b = c__ * e[i__];
+ dlartg_(&g, &f, &c__, &s, &r__);
+ if (i__ != m - 1) {
+ e[i__ + 1] = r__;
+ }
+ g = d__[i__ + 1] - p;
+ r__ = (d__[i__] - g) * s + c__ * 2. * b;
+ p = s * r__;
+ d__[i__ + 1] = g + p;
+ g = c__ * r__ - b;
+
+/* If eigenvectors are desired, then save rotations. */
+
+ if (icompz > 0) {
+ work[i__] = c__;
+ work[*n - 1 + i__] = -s;
+ }
+
+/* L70: */
+ }
+
+/* If eigenvectors are desired, then apply saved rotations. */
+
+ if (icompz > 0) {
+ mm = m - l + 1;
+ dlasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l
+ * z_dim1 + 1], ldz);
+ }
+
+ d__[l] -= p;
+ e[l] = g;
+ goto L40;
+
+/* Eigenvalue found. */
+
+L80:
+ d__[l] = p;
+
+ ++l;
+ if (l <= lend) {
+ goto L40;
+ }
+ goto L140;
+
+ } else {
+
+/* QR Iteration */
+
+/* Look for small superdiagonal element. */
+
+L90:
+ if (l != lend) {
+ lendp1 = lend + 1;
+ i__1 = lendp1;
+ for (m = l; m >= i__1; --m) {
+/* Computing 2nd power */
+ d__2 = (d__1 = e[m - 1], abs(d__1));
+ tst = d__2 * d__2;
+ if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
+ - 1], abs(d__2)) + safmin) {
+ goto L110;
+ }
+/* L100: */
+ }
+ }
+
+ m = lend;
+
+L110:
+ if (m > lend) {
+ e[m - 1] = 0.;
+ }
+ p = d__[l];
+ if (m == l) {
+ goto L130;
+ }
+
+/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */
+/* to compute its eigensystem. */
+
+ if (m == l - 1) {
+ if (icompz > 0) {
+ dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s)
+ ;
+ work[m] = c__;
+ work[*n - 1 + m] = s;
+ dlasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], &
+ z__[(l - 1) * z_dim1 + 1], ldz);
+ } else {
+ dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
+ }
+ d__[l - 1] = rt1;
+ d__[l] = rt2;
+ e[l - 1] = 0.;
+ l += -2;
+ if (l >= lend) {
+ goto L90;
+ }
+ goto L140;
+ }
+
+ if (jtot == nmaxit) {
+ goto L140;
+ }
+ ++jtot;
+
+/* Form shift. */
+
+ g = (d__[l - 1] - p) / (e[l - 1] * 2.);
+ r__ = dlapy2_(&g, &c_b10);
+ g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g));
+
+ s = 1.;
+ c__ = 1.;
+ p = 0.;
+
+/* Inner loop */
+
+ lm1 = l - 1;
+ i__1 = lm1;
+ for (i__ = m; i__ <= i__1; ++i__) {
+ f = s * e[i__];
+ b = c__ * e[i__];
+ dlartg_(&g, &f, &c__, &s, &r__);
+ if (i__ != m) {
+ e[i__ - 1] = r__;
+ }
+ g = d__[i__] - p;
+ r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b;
+ p = s * r__;
+ d__[i__] = g + p;
+ g = c__ * r__ - b;
+
+/* If eigenvectors are desired, then save rotations. */
+
+ if (icompz > 0) {
+ work[i__] = c__;
+ work[*n - 1 + i__] = s;
+ }
+
+/* L120: */
+ }
+
+/* If eigenvectors are desired, then apply saved rotations. */
+
+ if (icompz > 0) {
+ mm = l - m + 1;
+ dlasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m
+ * z_dim1 + 1], ldz);
+ }
+
+ d__[l] -= p;
+ e[lm1] = g;
+ goto L90;
+
+/* Eigenvalue found. */
+
+L130:
+ d__[l] = p;
+
+ --l;
+ if (l >= lend) {
+ goto L90;
+ }
+ goto L140;
+
+ }
+
+/* Undo scaling if necessary */
+
+L140:
+ if (iscale == 1) {
+ i__1 = lendsv - lsv + 1;
+ dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
+ n, info);
+ i__1 = lendsv - lsv;
+ dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n,
+ info);
+ } else if (iscale == 2) {
+ i__1 = lendsv - lsv + 1;
+ dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
+ n, info);
+ i__1 = lendsv - lsv;
+ dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n,
+ info);
+ }
+
+/* Check for no convergence to an eigenvalue after a total */
+/* of N*MAXIT iterations. */
+
+ if (jtot < nmaxit) {
+ goto L10;
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (e[i__] != 0.) {
+ ++(*info);
+ }
+/* L150: */
+ }
+ goto L190;
+
+/* Order eigenvalues and eigenvectors. */
+
+L160:
+ if (icompz == 0) {
+
+/* Use Quick Sort */
+
+ dlasrt_("I", n, &d__[1], info);
+
+ } else {
+
+/* Use Selection Sort to minimize swaps of eigenvectors */
+
+ i__1 = *n;
+ for (ii = 2; ii <= i__1; ++ii) {
+ i__ = ii - 1;
+ k = i__;
+ p = d__[i__];
+ i__2 = *n;
+ for (j = ii; j <= i__2; ++j) {
+ if (d__[j] < p) {
+ k = j;
+ p = d__[j];
+ }
+/* L170: */
+ }
+ if (k != i__) {
+ d__[k] = d__[i__];
+ d__[i__] = p;
+ dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1],
+ &c__1);
+ }
+/* L180: */
+ }
+ }
+
+L190:
+ return 0;
+
+/* End of DSTEQR */
+
+} /* dsteqr_ */
diff --git a/SRC/dsterf.c b/SRC/dsterf.c
new file mode 100644
index 0000000..a950e5b
--- /dev/null
+++ b/SRC/dsterf.c
@@ -0,0 +1,461 @@
+/* dsterf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c__1 = 1;
+static doublereal c_b32 = 1.;
+
+/* Subroutine */ int dsterf_(integer *n, doublereal *d__, doublereal *e,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ doublereal c__;
+ integer i__, l, m;
+ doublereal p, r__, s;
+ integer l1;
+ doublereal bb, rt1, rt2, eps, rte;
+ integer lsv;
+ doublereal eps2, oldc;
+ integer lend, jtot;
+ extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
+ *, doublereal *, doublereal *);
+ doublereal gamma, alpha, sigma, anorm;
+ extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
+ integer iscale;
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ doublereal oldgam, safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal safmax;
+ extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
+ extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
+ integer *);
+ integer lendsv;
+ doublereal ssfmin;
+ integer nmaxit;
+ doublereal ssfmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSTERF computes all eigenvalues of a symmetric tridiagonal matrix */
+/* using the Pal-Walker-Kahan variant of the QL or QR algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the n diagonal elements of the tridiagonal matrix. */
+/* On exit, if INFO = 0, the eigenvalues in ascending order. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix. */
+/* On exit, E has been destroyed. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: the algorithm failed to find all of the eigenvalues in */
+/* a total of 30*N iterations; if INFO = i, then i */
+/* elements of E have not converged to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --e;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n < 0) {
+ *info = -1;
+ i__1 = -(*info);
+ xerbla_("DSTERF", &i__1);
+ return 0;
+ }
+ if (*n <= 1) {
+ return 0;
+ }
+
+/* Determine the unit roundoff for this environment. */
+
+ eps = dlamch_("E");
+/* Computing 2nd power */
+ d__1 = eps;
+ eps2 = d__1 * d__1;
+ safmin = dlamch_("S");
+ safmax = 1. / safmin;
+ ssfmax = sqrt(safmax) / 3.;
+ ssfmin = sqrt(safmin) / eps2;
+
+/* Compute the eigenvalues of the tridiagonal matrix. */
+
+ nmaxit = *n * 30;
+ sigma = 0.;
+ jtot = 0;
+
+/* Determine where the matrix splits and choose QL or QR iteration */
+/* for each block, according to whether top or bottom diagonal */
+/* element is smaller. */
+
+ l1 = 1;
+
+L10:
+ if (l1 > *n) {
+ goto L170;
+ }
+ if (l1 > 1) {
+ e[l1 - 1] = 0.;
+ }
+ i__1 = *n - 1;
+ for (m = l1; m <= i__1; ++m) {
+ if ((d__3 = e[m], abs(d__3)) <= sqrt((d__1 = d__[m], abs(d__1))) *
+ sqrt((d__2 = d__[m + 1], abs(d__2))) * eps) {
+ e[m] = 0.;
+ goto L30;
+ }
+/* L20: */
+ }
+ m = *n;
+
+L30:
+ l = l1;
+ lsv = l;
+ lend = m;
+ lendsv = lend;
+ l1 = m + 1;
+ if (lend == l) {
+ goto L10;
+ }
+
+/* Scale submatrix in rows and columns L to LEND */
+
+ i__1 = lend - l + 1;
+ anorm = dlanst_("I", &i__1, &d__[l], &e[l]);
+ iscale = 0;
+ if (anorm > ssfmax) {
+ iscale = 1;
+ i__1 = lend - l + 1;
+ dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
+ info);
+ i__1 = lend - l;
+ dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
+ info);
+ } else if (anorm < ssfmin) {
+ iscale = 2;
+ i__1 = lend - l + 1;
+ dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
+ info);
+ i__1 = lend - l;
+ dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
+ info);
+ }
+
+ i__1 = lend - 1;
+ for (i__ = l; i__ <= i__1; ++i__) {
+/* Computing 2nd power */
+ d__1 = e[i__];
+ e[i__] = d__1 * d__1;
+/* L40: */
+ }
+
+/* Choose between QL and QR iteration */
+
+ if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) {
+ lend = lsv;
+ l = lendsv;
+ }
+
+ if (lend >= l) {
+
+/* QL Iteration */
+
+/* Look for small subdiagonal element. */
+
+L50:
+ if (l != lend) {
+ i__1 = lend - 1;
+ for (m = l; m <= i__1; ++m) {
+ if ((d__2 = e[m], abs(d__2)) <= eps2 * (d__1 = d__[m] * d__[m
+ + 1], abs(d__1))) {
+ goto L70;
+ }
+/* L60: */
+ }
+ }
+ m = lend;
+
+L70:
+ if (m < lend) {
+ e[m] = 0.;
+ }
+ p = d__[l];
+ if (m == l) {
+ goto L90;
+ }
+
+/* If remaining matrix is 2 by 2, use DLAE2 to compute its */
+/* eigenvalues. */
+
+ if (m == l + 1) {
+ rte = sqrt(e[l]);
+ dlae2_(&d__[l], &rte, &d__[l + 1], &rt1, &rt2);
+ d__[l] = rt1;
+ d__[l + 1] = rt2;
+ e[l] = 0.;
+ l += 2;
+ if (l <= lend) {
+ goto L50;
+ }
+ goto L150;
+ }
+
+ if (jtot == nmaxit) {
+ goto L150;
+ }
+ ++jtot;
+
+/* Form shift. */
+
+ rte = sqrt(e[l]);
+ sigma = (d__[l + 1] - p) / (rte * 2.);
+ r__ = dlapy2_(&sigma, &c_b32);
+ sigma = p - rte / (sigma + d_sign(&r__, &sigma));
+
+ c__ = 1.;
+ s = 0.;
+ gamma = d__[m] - sigma;
+ p = gamma * gamma;
+
+/* Inner loop */
+
+ i__1 = l;
+ for (i__ = m - 1; i__ >= i__1; --i__) {
+ bb = e[i__];
+ r__ = p + bb;
+ if (i__ != m - 1) {
+ e[i__ + 1] = s * r__;
+ }
+ oldc = c__;
+ c__ = p / r__;
+ s = bb / r__;
+ oldgam = gamma;
+ alpha = d__[i__];
+ gamma = c__ * (alpha - sigma) - s * oldgam;
+ d__[i__ + 1] = oldgam + (alpha - gamma);
+ if (c__ != 0.) {
+ p = gamma * gamma / c__;
+ } else {
+ p = oldc * bb;
+ }
+/* L80: */
+ }
+
+ e[l] = s * p;
+ d__[l] = sigma + gamma;
+ goto L50;
+
+/* Eigenvalue found. */
+
+L90:
+ d__[l] = p;
+
+ ++l;
+ if (l <= lend) {
+ goto L50;
+ }
+ goto L150;
+
+ } else {
+
+/* QR Iteration */
+
+/* Look for small superdiagonal element. */
+
+L100:
+ i__1 = lend + 1;
+ for (m = l; m >= i__1; --m) {
+ if ((d__2 = e[m - 1], abs(d__2)) <= eps2 * (d__1 = d__[m] * d__[m
+ - 1], abs(d__1))) {
+ goto L120;
+ }
+/* L110: */
+ }
+ m = lend;
+
+L120:
+ if (m > lend) {
+ e[m - 1] = 0.;
+ }
+ p = d__[l];
+ if (m == l) {
+ goto L140;
+ }
+
+/* If remaining matrix is 2 by 2, use DLAE2 to compute its */
+/* eigenvalues. */
+
+ if (m == l - 1) {
+ rte = sqrt(e[l - 1]);
+ dlae2_(&d__[l], &rte, &d__[l - 1], &rt1, &rt2);
+ d__[l] = rt1;
+ d__[l - 1] = rt2;
+ e[l - 1] = 0.;
+ l += -2;
+ if (l >= lend) {
+ goto L100;
+ }
+ goto L150;
+ }
+
+ if (jtot == nmaxit) {
+ goto L150;
+ }
+ ++jtot;
+
+/* Form shift. */
+
+ rte = sqrt(e[l - 1]);
+ sigma = (d__[l - 1] - p) / (rte * 2.);
+ r__ = dlapy2_(&sigma, &c_b32);
+ sigma = p - rte / (sigma + d_sign(&r__, &sigma));
+
+ c__ = 1.;
+ s = 0.;
+ gamma = d__[m] - sigma;
+ p = gamma * gamma;
+
+/* Inner loop */
+
+ i__1 = l - 1;
+ for (i__ = m; i__ <= i__1; ++i__) {
+ bb = e[i__];
+ r__ = p + bb;
+ if (i__ != m) {
+ e[i__ - 1] = s * r__;
+ }
+ oldc = c__;
+ c__ = p / r__;
+ s = bb / r__;
+ oldgam = gamma;
+ alpha = d__[i__ + 1];
+ gamma = c__ * (alpha - sigma) - s * oldgam;
+ d__[i__] = oldgam + (alpha - gamma);
+ if (c__ != 0.) {
+ p = gamma * gamma / c__;
+ } else {
+ p = oldc * bb;
+ }
+/* L130: */
+ }
+
+ e[l - 1] = s * p;
+ d__[l] = sigma + gamma;
+ goto L100;
+
+/* Eigenvalue found. */
+
+L140:
+ d__[l] = p;
+
+ --l;
+ if (l >= lend) {
+ goto L100;
+ }
+ goto L150;
+
+ }
+
+/* Undo scaling if necessary */
+
+L150:
+ if (iscale == 1) {
+ i__1 = lendsv - lsv + 1;
+ dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
+ n, info);
+ }
+ if (iscale == 2) {
+ i__1 = lendsv - lsv + 1;
+ dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
+ n, info);
+ }
+
+/* Check for no convergence to an eigenvalue after a total */
+/* of N*MAXIT iterations. */
+
+ if (jtot < nmaxit) {
+ goto L10;
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (e[i__] != 0.) {
+ ++(*info);
+ }
+/* L160: */
+ }
+ goto L180;
+
+/* Sort eigenvalues in increasing order. */
+
+L170:
+ dlasrt_("I", n, &d__[1], info);
+
+L180:
+ return 0;
+
+/* End of DSTERF */
+
+} /* dsterf_ */
diff --git a/SRC/dstev.c b/SRC/dstev.c
new file mode 100644
index 0000000..db343ac
--- /dev/null
+++ b/SRC/dstev.c
@@ -0,0 +1,212 @@
+/* dstev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dstev_(char *jobz, integer *n, doublereal *d__,
+ doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal eps;
+ integer imax;
+ doublereal rmin, rmax, tnrm;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ logical wantz;
+ extern doublereal dlamch_(char *);
+ integer iscale;
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
+ extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
+ integer *), dsteqr_(char *, integer *, doublereal *, doublereal *
+, doublereal *, integer *, doublereal *, integer *);
+ doublereal smlnum;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSTEV computes all eigenvalues and, optionally, eigenvectors of a */
+/* real symmetric tridiagonal matrix A. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the n diagonal elements of the tridiagonal matrix */
+/* A. */
+/* On exit, if INFO = 0, the eigenvalues in ascending order. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix A, stored in elements 1 to N-1 of E. */
+/* On exit, the contents of E are destroyed. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
+/* eigenvectors of the matrix A, with the i-th column of Z */
+/* holding the eigenvector associated with D(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) */
+/* If JOBZ = 'N', WORK is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of E did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -6;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSTEV ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ tnrm = dlanst_("M", n, &d__[1], &e[1]);
+ if (tnrm > 0. && tnrm < rmin) {
+ iscale = 1;
+ sigma = rmin / tnrm;
+ } else if (tnrm > rmax) {
+ iscale = 1;
+ sigma = rmax / tnrm;
+ }
+ if (iscale == 1) {
+ dscal_(n, &sigma, &d__[1], &c__1);
+ i__1 = *n - 1;
+ dscal_(&i__1, &sigma, &e[1], &c__1);
+ }
+
+/* For eigenvalues only, call DSTERF. For eigenvalues and */
+/* eigenvectors, call DSTEQR. */
+
+ if (! wantz) {
+ dsterf_(n, &d__[1], &e[1], info);
+ } else {
+ dsteqr_("I", n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], info);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *n;
+ } else {
+ imax = *info - 1;
+ }
+ d__1 = 1. / sigma;
+ dscal_(&imax, &d__1, &d__[1], &c__1);
+ }
+
+ return 0;
+
+/* End of DSTEV */
+
+} /* dstev_ */
diff --git a/SRC/dstevd.c b/SRC/dstevd.c
new file mode 100644
index 0000000..ffd0167
--- /dev/null
+++ b/SRC/dstevd.c
@@ -0,0 +1,273 @@
+/* dstevd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dstevd_(char *jobz, integer *n, doublereal *d__,
+ doublereal *e, doublereal *z__, integer *ldz, doublereal *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal eps, rmin, rmax, tnrm;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ integer lwmin;
+ logical wantz;
+ extern doublereal dlamch_(char *);
+ integer iscale;
+ extern /* Subroutine */ int dstedc_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *, integer *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
+ extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
+ integer *);
+ integer liwmin;
+ doublereal smlnum;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSTEVD computes all eigenvalues and, optionally, eigenvectors of a */
+/* real symmetric tridiagonal matrix. If eigenvectors are desired, it */
+/* uses a divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the n diagonal elements of the tridiagonal matrix */
+/* A. */
+/* On exit, if INFO = 0, the eigenvalues in ascending order. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix A, stored in elements 1 to N-1 of E. */
+/* On exit, the contents of E are destroyed. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
+/* eigenvectors of the matrix A, with the i-th column of Z */
+/* holding the eigenvector associated with D(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, */
+/* dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If JOBZ = 'N' or N <= 1 then LWORK must be at least 1. */
+/* If JOBZ = 'V' and N > 1 then LWORK must be at least */
+/* ( 1 + 4*N + N**2 ). */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK and IWORK */
+/* arrays, returns these values as the first entries of the WORK */
+/* and IWORK arrays, and no error message related to LWORK or */
+/* LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If JOBZ = 'N' or N <= 1 then LIWORK must be at least 1. */
+/* If JOBZ = 'V' and N > 1 then LIWORK must be at least 3+5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK and IWORK arrays, and no error message related to */
+/* LWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of E did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ lquery = *lwork == -1 || *liwork == -1;
+
+ *info = 0;
+ liwmin = 1;
+ lwmin = 1;
+ if (*n > 1 && wantz) {
+/* Computing 2nd power */
+ i__1 = *n;
+ lwmin = (*n << 2) + 1 + i__1 * i__1;
+ liwmin = *n * 5 + 3;
+ }
+
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -6;
+ }
+
+ if (*info == 0) {
+ work[1] = (doublereal) lwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -8;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -10;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSTEVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ tnrm = dlanst_("M", n, &d__[1], &e[1]);
+ if (tnrm > 0. && tnrm < rmin) {
+ iscale = 1;
+ sigma = rmin / tnrm;
+ } else if (tnrm > rmax) {
+ iscale = 1;
+ sigma = rmax / tnrm;
+ }
+ if (iscale == 1) {
+ dscal_(n, &sigma, &d__[1], &c__1);
+ i__1 = *n - 1;
+ dscal_(&i__1, &sigma, &e[1], &c__1);
+ }
+
+/* For eigenvalues only, call DSTERF. For eigenvalues and */
+/* eigenvectors, call DSTEDC. */
+
+ if (! wantz) {
+ dsterf_(n, &d__[1], &e[1], info);
+ } else {
+ dstedc_("I", n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], lwork,
+ &iwork[1], liwork, info);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ d__1 = 1. / sigma;
+ dscal_(n, &d__1, &d__[1], &c__1);
+ }
+
+ work[1] = (doublereal) lwmin;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of DSTEVD */
+
+} /* dstevd_ */
diff --git a/SRC/dstevr.c b/SRC/dstevr.c
new file mode 100644
index 0000000..db78da6
--- /dev/null
+++ b/SRC/dstevr.c
@@ -0,0 +1,550 @@
+/* dstevr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__10 = 10;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__4 = 4;
+
+/* Subroutine */ int dstevr_(char *jobz, char *range, integer *n, doublereal *
+ d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il,
+ integer *iu, doublereal *abstol, integer *m, doublereal *w,
+ doublereal *z__, integer *ldz, integer *isuppz, doublereal *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, jj;
+ doublereal eps, vll, vuu, tmp1;
+ integer imax;
+ doublereal rmin, rmax;
+ logical test;
+ doublereal tnrm;
+ integer itmp1;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ char order[1];
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dswap_(integer *, doublereal *, integer
+ *, doublereal *, integer *);
+ integer lwmin;
+ logical wantz;
+ extern doublereal dlamch_(char *);
+ logical alleig, indeig;
+ integer iscale, ieeeok, indibl, indifl;
+ logical valeig;
+ doublereal safmin;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
+ integer indisp;
+ extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, integer *),
+ dsterf_(integer *, doublereal *, doublereal *, integer *);
+ integer indiwo;
+ extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal
+ *, doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, integer *),
+ dstemr_(char *, char *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, integer *,
+ logical *, doublereal *, integer *, integer *, integer *, integer
+ *);
+ integer liwmin;
+ logical tryrac;
+ integer nsplit;
+ doublereal smlnum;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSTEVR computes selected eigenvalues and, optionally, eigenvectors */
+/* of a real symmetric tridiagonal matrix T. Eigenvalues and */
+/* eigenvectors can be selected by specifying either a range of values */
+/* or a range of indices for the desired eigenvalues. */
+
+/* Whenever possible, DSTEVR calls DSTEMR to compute the */
+/* eigenspectrum using Relatively Robust Representations. DSTEMR */
+/* computes eigenvalues by the dqds algorithm, while orthogonal */
+/* eigenvectors are computed from various "good" L D L^T representations */
+/* (also known as Relatively Robust Representations). Gram-Schmidt */
+/* orthogonalization is avoided as far as possible. More specifically, */
+/* the various steps of the algorithm are as follows. For the i-th */
+/* unreduced block of T, */
+/* (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T */
+/* is a relatively robust representation, */
+/* (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high */
+/* relative accuracy by the dqds algorithm, */
+/* (c) If there is a cluster of close eigenvalues, "choose" sigma_i */
+/* close to the cluster, and go to step (a), */
+/* (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T, */
+/* compute the corresponding eigenvector by forming a */
+/* rank-revealing twisted factorization. */
+/* The desired accuracy of the output can be specified by the input */
+/* parameter ABSTOL. */
+
+/* For more details, see "A new O(n^2) algorithm for the symmetric */
+/* tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon, */
+/* Computer Science Division Technical Report No. UCB//CSD-97-971, */
+/* UC Berkeley, May 1997. */
+
+
+/* Note 1 : DSTEVR calls DSTEMR when the full spectrum is requested */
+/* on machines which conform to the ieee-754 floating point standard. */
+/* DSTEVR calls DSTEBZ and DSTEIN on non-ieee machines and */
+/* when partial spectrum requests are made. */
+
+/* Normal execution of DSTEMR may create NaNs and infinities and */
+/* hence may abort due to a floating point exception in environments */
+/* which do not handle NaNs and infinities in the ieee standard default */
+/* manner. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+/* ********* For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and */
+/* ********* DSTEIN are called */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the n diagonal elements of the tridiagonal matrix */
+/* A. */
+/* On exit, D may be multiplied by a constant factor chosen */
+/* to avoid over/underflow in computing the eigenvalues. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (max(1,N-1)) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix A in elements 1 to N-1 of E. */
+/* On exit, E may be multiplied by a constant factor chosen */
+/* to avoid over/underflow in computing the eigenvalues. */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) DOUBLE PRECISION */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing A to tridiagonal form. */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices */
+/* with Guaranteed High Relative Accuracy," by Demmel and */
+/* Kahan, LAPACK Working Note #3. */
+
+/* If high relative accuracy is important, set ABSTOL to */
+/* DLAMCH( 'Safe minimum' ). Doing so will guarantee that */
+/* eigenvalues are computed to high relative accuracy when */
+/* possible in future releases. The current code does not */
+/* make any guarantees about high relative accuracy, but */
+/* future releases will. See J. Barlow and J. Demmel, */
+/* "Computing Accurate Eigensystems of Scaled Diagonally */
+/* Dominant Matrices", LAPACK Working Note #7, for a discussion */
+/* of which matrices define their eigenvalues to high relative */
+/* accuracy. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* The first M elements contain the selected eigenvalues in */
+/* ascending order. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */
+/* The support of the eigenvectors in Z, i.e., the indices */
+/* indicating the nonzero elements in Z. The i-th eigenvector */
+/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */
+/* ISUPPZ( 2*i ). */
+/* ********* Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal (and */
+/* minimal) LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,20*N). */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK and IWORK */
+/* arrays, returns these values as the first entries of the WORK */
+/* and IWORK arrays, and no error message related to LWORK or */
+/* LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal (and */
+/* minimal) LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. LIWORK >= max(1,10*N). */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK and IWORK arrays, and no error message related to */
+/* LWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: Internal error */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Inderjit Dhillon, IBM Almaden, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Ken Stanley, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --isuppz;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ ieeeok = ilaenv_(&c__10, "DSTEVR", "N", &c__1, &c__2, &c__3, &c__4);
+
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ lquery = *lwork == -1 || *liwork == -1;
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * 20;
+ lwmin = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * 10;
+ liwmin = max(i__1,i__2);
+
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -7;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -8;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -9;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -14;
+ }
+ }
+
+ if (*info == 0) {
+ work[1] = (doublereal) lwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -17;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -19;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSTEVR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (alleig || indeig) {
+ *m = 1;
+ w[1] = d__[1];
+ } else {
+ if (*vl < d__[1] && *vu >= d__[1]) {
+ *m = 1;
+ w[1] = d__[1];
+ }
+ }
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
+ rmax = min(d__1,d__2);
+
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ vll = *vl;
+ vuu = *vu;
+
+ tnrm = dlanst_("M", n, &d__[1], &e[1]);
+ if (tnrm > 0. && tnrm < rmin) {
+ iscale = 1;
+ sigma = rmin / tnrm;
+ } else if (tnrm > rmax) {
+ iscale = 1;
+ sigma = rmax / tnrm;
+ }
+ if (iscale == 1) {
+ dscal_(n, &sigma, &d__[1], &c__1);
+ i__1 = *n - 1;
+ dscal_(&i__1, &sigma, &e[1], &c__1);
+ if (valeig) {
+ vll = *vl * sigma;
+ vuu = *vu * sigma;
+ }
+ }
+/* Initialize indices into workspaces. Note: These indices are used only */
+/* if DSTERF or DSTEMR fail. */
+/* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and */
+/* stores the block indices of each of the M<=N eigenvalues. */
+ indibl = 1;
+/* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and */
+/* stores the starting and finishing indices of each block. */
+ indisp = indibl + *n;
+/* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors */
+/* that corresponding to eigenvectors that fail to converge in */
+/* DSTEIN. This information is discarded; if any fail, the driver */
+/* returns INFO > 0. */
+ indifl = indisp + *n;
+/* INDIWO is the offset of the remaining integer workspace. */
+ indiwo = indisp + *n;
+
+/* If all eigenvalues are desired, then */
+/* call DSTERF or DSTEMR. If this fails for some eigenvalue, then */
+/* try DSTEBZ. */
+
+
+ test = FALSE_;
+ if (indeig) {
+ if (*il == 1 && *iu == *n) {
+ test = TRUE_;
+ }
+ }
+ if ((alleig || test) && ieeeok == 1) {
+ i__1 = *n - 1;
+ dcopy_(&i__1, &e[1], &c__1, &work[1], &c__1);
+ if (! wantz) {
+ dcopy_(n, &d__[1], &c__1, &w[1], &c__1);
+ dsterf_(n, &w[1], &work[1], info);
+ } else {
+ dcopy_(n, &d__[1], &c__1, &work[*n + 1], &c__1);
+ if (*abstol <= *n * 2. * eps) {
+ tryrac = TRUE_;
+ } else {
+ tryrac = FALSE_;
+ }
+ i__1 = *lwork - (*n << 1);
+ dstemr_(jobz, "A", n, &work[*n + 1], &work[1], vl, vu, il, iu, m,
+ &w[1], &z__[z_offset], ldz, n, &isuppz[1], &tryrac, &work[
+ (*n << 1) + 1], &i__1, &iwork[1], liwork, info);
+
+ }
+ if (*info == 0) {
+ *m = *n;
+ goto L10;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ dstebz_(range, order, n, &vll, &vuu, il, iu, abstol, &d__[1], &e[1], m, &
+ nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[1], &iwork[
+ indiwo], info);
+
+ if (wantz) {
+ dstein_(n, &d__[1], &e[1], m, &w[1], &iwork[indibl], &iwork[indisp], &
+ z__[z_offset], ldz, &work[1], &iwork[indiwo], &iwork[indifl],
+ info);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+L10:
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *m;
+ } else {
+ imax = *info - 1;
+ }
+ d__1 = 1. / sigma;
+ dscal_(&imax, &d__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L20: */
+ }
+
+ if (i__ != 0) {
+ itmp1 = iwork[i__];
+ w[i__] = w[j];
+ iwork[i__] = iwork[j];
+ w[j] = tmp1;
+ iwork[j] = itmp1;
+ dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ }
+/* L30: */
+ }
+ }
+
+/* Causes problems with tests 19 & 20: */
+/* IF (wantz .and. INDEIG ) Z( 1,1) = Z(1,1) / 1.002 + .002 */
+
+
+ work[1] = (doublereal) lwmin;
+ iwork[1] = liwmin;
+ return 0;
+
+/* End of DSTEVR */
+
+} /* dstevr_ */
diff --git a/SRC/dstevx.c b/SRC/dstevx.c
new file mode 100644
index 0000000..d9f1bb1
--- /dev/null
+++ b/SRC/dstevx.c
@@ -0,0 +1,432 @@
+/* dstevx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dstevx_(char *jobz, char *range, integer *n, doublereal *
+ d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il,
+ integer *iu, doublereal *abstol, integer *m, doublereal *w,
+ doublereal *z__, integer *ldz, doublereal *work, integer *iwork,
+ integer *ifail, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, jj;
+ doublereal eps, vll, vuu, tmp1;
+ integer imax;
+ doublereal rmin, rmax;
+ logical test;
+ doublereal tnrm;
+ integer itmp1;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ char order[1];
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dswap_(integer *, doublereal *, integer
+ *, doublereal *, integer *);
+ logical wantz;
+ extern doublereal dlamch_(char *);
+ logical alleig, indeig;
+ integer iscale, indibl;
+ logical valeig;
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
+ integer indisp;
+ extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, integer *),
+ dsterf_(integer *, doublereal *, doublereal *, integer *);
+ integer indiwo;
+ extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal
+ *, doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, integer *);
+ integer indwrk;
+ extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *);
+ integer nsplit;
+ doublereal smlnum;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSTEVX computes selected eigenvalues and, optionally, eigenvectors */
+/* of a real symmetric tridiagonal matrix A. Eigenvalues and */
+/* eigenvectors can be selected by specifying either a range of values */
+/* or a range of indices for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the n diagonal elements of the tridiagonal matrix */
+/* A. */
+/* On exit, D may be multiplied by a constant factor chosen */
+/* to avoid over/underflow in computing the eigenvalues. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (max(1,N-1)) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix A in elements 1 to N-1 of E. */
+/* On exit, E may be multiplied by a constant factor chosen */
+/* to avoid over/underflow in computing the eigenvalues. */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) DOUBLE PRECISION */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less */
+/* than or equal to zero, then EPS*|T| will be used in */
+/* its place, where |T| is the 1-norm of the tridiagonal */
+/* matrix. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*DLAMCH('S'). */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices */
+/* with Guaranteed High Relative Accuracy," by Demmel and */
+/* Kahan, LAPACK Working Note #3. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* The first M elements contain the selected eigenvalues in */
+/* ascending order. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) ) */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If an eigenvector fails to converge (INFO > 0), then that */
+/* column of Z contains the latest approximation to the */
+/* eigenvector, and the index of the eigenvector is returned */
+/* in IFAIL. If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (5*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, then i eigenvectors failed to converge. */
+/* Their indices are stored in array IFAIL. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -7;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -8;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -9;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -14;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSTEVX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (alleig || indeig) {
+ *m = 1;
+ w[1] = d__[1];
+ } else {
+ if (*vl < d__[1] && *vu >= d__[1]) {
+ *m = 1;
+ w[1] = d__[1];
+ }
+ }
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
+ rmax = min(d__1,d__2);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ if (valeig) {
+ vll = *vl;
+ vuu = *vu;
+ } else {
+ vll = 0.;
+ vuu = 0.;
+ }
+ tnrm = dlanst_("M", n, &d__[1], &e[1]);
+ if (tnrm > 0. && tnrm < rmin) {
+ iscale = 1;
+ sigma = rmin / tnrm;
+ } else if (tnrm > rmax) {
+ iscale = 1;
+ sigma = rmax / tnrm;
+ }
+ if (iscale == 1) {
+ dscal_(n, &sigma, &d__[1], &c__1);
+ i__1 = *n - 1;
+ dscal_(&i__1, &sigma, &e[1], &c__1);
+ if (valeig) {
+ vll = *vl * sigma;
+ vuu = *vu * sigma;
+ }
+ }
+
+/* If all eigenvalues are desired and ABSTOL is less than zero, then */
+/* call DSTERF or SSTEQR. If this fails for some eigenvalue, then */
+/* try DSTEBZ. */
+
+ test = FALSE_;
+ if (indeig) {
+ if (*il == 1 && *iu == *n) {
+ test = TRUE_;
+ }
+ }
+ if ((alleig || test) && *abstol <= 0.) {
+ dcopy_(n, &d__[1], &c__1, &w[1], &c__1);
+ i__1 = *n - 1;
+ dcopy_(&i__1, &e[1], &c__1, &work[1], &c__1);
+ indwrk = *n + 1;
+ if (! wantz) {
+ dsterf_(n, &w[1], &work[1], info);
+ } else {
+ dsteqr_("I", n, &w[1], &work[1], &z__[z_offset], ldz, &work[
+ indwrk], info);
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ifail[i__] = 0;
+/* L10: */
+ }
+ }
+ }
+ if (*info == 0) {
+ *m = *n;
+ goto L20;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ indwrk = 1;
+ indibl = 1;
+ indisp = indibl + *n;
+ indiwo = indisp + *n;
+ dstebz_(range, order, n, &vll, &vuu, il, iu, abstol, &d__[1], &e[1], m, &
+ nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[indwrk], &
+ iwork[indiwo], info);
+
+ if (wantz) {
+ dstein_(n, &d__[1], &e[1], m, &w[1], &iwork[indibl], &iwork[indisp], &
+ z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &ifail[1],
+ info);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+L20:
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *m;
+ } else {
+ imax = *info - 1;
+ }
+ d__1 = 1. / sigma;
+ dscal_(&imax, &d__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L30: */
+ }
+
+ if (i__ != 0) {
+ itmp1 = iwork[indibl + i__ - 1];
+ w[i__] = w[j];
+ iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
+ w[j] = tmp1;
+ iwork[indibl + j - 1] = itmp1;
+ dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ if (*info != 0) {
+ itmp1 = ifail[i__];
+ ifail[i__] = ifail[j];
+ ifail[j] = itmp1;
+ }
+ }
+/* L40: */
+ }
+ }
+
+ return 0;
+
+/* End of DSTEVX */
+
+} /* dstevx_ */
diff --git a/SRC/dsycon.c b/SRC/dsycon.c
new file mode 100644
index 0000000..c72e8ce
--- /dev/null
+++ b/SRC/dsycon.c
@@ -0,0 +1,204 @@
+/* dsycon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dsycon_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *ipiv, doublereal *anorm, doublereal *rcond, doublereal *
+ work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+
+ /* Local variables */
+ integer i__, kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *), xerbla_(char *,
+ integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int dsytrs_(char *, integer *, integer *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYCON estimates the reciprocal of the condition number (in the */
+/* 1-norm) of a real symmetric matrix A using the factorization */
+/* A = U*D*U**T or A = L*D*L**T computed by DSYTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by DSYTRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by DSYTRF. */
+
+/* ANORM (input) DOUBLE PRECISION */
+/* The 1-norm of the original matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*anorm < 0.) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSYCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.;
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ } else if (*anorm <= 0.) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ for (i__ = *n; i__ >= 1; --i__) {
+ if (ipiv[i__] > 0 && a[i__ + i__ * a_dim1] == 0.) {
+ return 0;
+ }
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (ipiv[i__] > 0 && a[i__ + i__ * a_dim1] == 0.) {
+ return 0;
+ }
+/* L20: */
+ }
+ }
+
+/* Estimate the 1-norm of the inverse. */
+
+ kase = 0;
+L30:
+ dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+
+/* Multiply by inv(L*D*L') or inv(U*D*U'). */
+
+ dsytrs_(uplo, n, &c__1, &a[a_offset], lda, &ipiv[1], &work[1], n,
+ info);
+ goto L30;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / ainvnm / *anorm;
+ }
+
+ return 0;
+
+/* End of DSYCON */
+
+} /* dsycon_ */
diff --git a/SRC/dsyequb.c b/SRC/dsyequb.c
new file mode 100644
index 0000000..4485427
--- /dev/null
+++ b/SRC/dsyequb.c
@@ -0,0 +1,333 @@
+/* dsyequb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dsyequb_(char *uplo, integer *n, doublereal *a, integer *
+ lda, doublereal *s, doublereal *scond, doublereal *amax, doublereal *
+ work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal), log(doublereal), pow_di(doublereal *, integer *);
+
+ /* Local variables */
+ doublereal d__;
+ integer i__, j;
+ doublereal t, u, c0, c1, c2, si;
+ logical up;
+ doublereal avg, std, tol, base;
+ integer iter;
+ doublereal smin, smax, scale;
+ extern logical lsame_(char *, char *);
+ doublereal sumsq;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
+ doublereal *, doublereal *);
+ doublereal smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYEQUB computes row and column scalings intended to equilibrate a */
+/* symmetric matrix A and reduce its condition number */
+/* (with respect to the two-norm). S contains the scale factors, */
+/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
+/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
+/* choice of S puts the condition number of B within a factor N of the */
+/* smallest possible condition number over all possible diagonal */
+/* scalings. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The N-by-N symmetric matrix whose scaling */
+/* factors are to be computed. Only the diagonal elements of A */
+/* are referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* S (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, S contains the scale factors for A. */
+
+/* SCOND (output) DOUBLE PRECISION */
+/* If INFO = 0, S contains the ratio of the smallest S(i) to */
+/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
+/* large nor too small, it is not worth scaling by S. */
+
+/* AMAX (output) DOUBLE PRECISION */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
+
+/* Further Details */
+/* ======= ======= */
+
+/* Reference: Livne, O.E. and Golub, G.H., "Scaling by Binormalization", */
+/* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. */
+/* DOI 10.1023/B:NUMA.0000016606.32820.69 */
+/* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (! (lsame_(uplo, "U") || lsame_(uplo, "L"))) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSYEQUB", &i__1);
+ return 0;
+ }
+ up = lsame_(uplo, "U");
+ *amax = 0.;
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ *scond = 1.;
+ return 0;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s[i__] = 0.;
+ }
+ *amax = 0.;
+ if (up) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = s[i__], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ s[i__] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = s[j], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ s[j] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = *amax, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ *amax = max(d__2,d__3);
+ }
+/* Computing MAX */
+ d__2 = s[j], d__3 = (d__1 = a[j + j * a_dim1], abs(d__1));
+ s[j] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = *amax, d__3 = (d__1 = a[j + j * a_dim1], abs(d__1));
+ *amax = max(d__2,d__3);
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ d__2 = s[j], d__3 = (d__1 = a[j + j * a_dim1], abs(d__1));
+ s[j] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = *amax, d__3 = (d__1 = a[j + j * a_dim1], abs(d__1));
+ *amax = max(d__2,d__3);
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = s[i__], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ s[i__] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = s[j], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ s[j] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = *amax, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ *amax = max(d__2,d__3);
+ }
+ }
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ s[j] = 1. / s[j];
+ }
+ tol = 1. / sqrt(*n * 2.);
+ for (iter = 1; iter <= 100; ++iter) {
+ scale = 0.;
+ sumsq = 0.;
+/* BETA = |A|S */
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+ }
+ if (up) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ t = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[
+ j];
+ work[j] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[
+ i__];
+ }
+ work[j] += (d__1 = a[j + j * a_dim1], abs(d__1)) * s[j];
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[j] += (d__1 = a[j + j * a_dim1], abs(d__1)) * s[j];
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ t = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[
+ j];
+ work[j] += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * s[
+ i__];
+ }
+ }
+ }
+/* avg = s^T beta / n */
+ avg = 0.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ avg += s[i__] * work[i__];
+ }
+ avg /= *n;
+ std = 0.;
+ i__1 = *n * 3;
+ for (i__ = (*n << 1) + 1; i__ <= i__1; ++i__) {
+ work[i__] = s[i__ - (*n << 1)] * work[i__ - (*n << 1)] - avg;
+ }
+ dlassq_(n, &work[(*n << 1) + 1], &c__1, &scale, &sumsq);
+ std = scale * sqrt(sumsq / *n);
+ if (std < tol * avg) {
+ goto L999;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ t = (d__1 = a[i__ + i__ * a_dim1], abs(d__1));
+ si = s[i__];
+ c2 = (*n - 1) * t;
+ c1 = (*n - 2) * (work[i__] - t * si);
+ c0 = -(t * si) * si + work[i__] * 2 * si - *n * avg;
+ d__ = c1 * c1 - c0 * 4 * c2;
+ if (d__ <= 0.) {
+ *info = -1;
+ return 0;
+ }
+ si = c0 * -2 / (c1 + sqrt(d__));
+ d__ = si - s[i__];
+ u = 0.;
+ if (up) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ t = (d__1 = a[j + i__ * a_dim1], abs(d__1));
+ u += s[j] * t;
+ work[j] += d__ * t;
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ t = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ u += s[j] * t;
+ work[j] += d__ * t;
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ t = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+ u += s[j] * t;
+ work[j] += d__ * t;
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ t = (d__1 = a[j + i__ * a_dim1], abs(d__1));
+ u += s[j] * t;
+ work[j] += d__ * t;
+ }
+ }
+ avg += (u + work[i__]) * d__ / *n;
+ s[i__] = si;
+ }
+ }
+L999:
+ smlnum = dlamch_("SAFEMIN");
+ bignum = 1. / smlnum;
+ smin = bignum;
+ smax = 0.;
+ t = 1. / sqrt(avg);
+ base = dlamch_("B");
+ u = 1. / log(base);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = (integer) (u * log(s[i__] * t));
+ s[i__] = pow_di(&base, &i__2);
+/* Computing MIN */
+ d__1 = smin, d__2 = s[i__];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = smax, d__2 = s[i__];
+ smax = max(d__1,d__2);
+ }
+ *scond = max(smin,smlnum) / min(smax,bignum);
+
+ return 0;
+} /* dsyequb_ */
diff --git a/SRC/dsyev.c b/SRC/dsyev.c
new file mode 100644
index 0000000..0fdcb3a
--- /dev/null
+++ b/SRC/dsyev.c
@@ -0,0 +1,283 @@
+/* dsyev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static doublereal c_b17 = 1.;
+
+/* Subroutine */ int dsyev_(char *jobz, char *uplo, integer *n, doublereal *a,
+ integer *lda, doublereal *w, doublereal *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer nb;
+ doublereal eps;
+ integer inde;
+ doublereal anrm;
+ integer imax;
+ doublereal rmin, rmax;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical lower, wantz;
+ extern doublereal dlamch_(char *);
+ integer iscale;
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ doublereal safmin;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ integer indtau;
+ extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ integer indwrk;
+ extern /* Subroutine */ int dorgtr_(char *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *), dsteqr_(char *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *),
+ dsytrd_(char *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *);
+ integer llwork;
+ doublereal smlnum;
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYEV computes all eigenvalues and, optionally, eigenvectors of a */
+/* real symmetric matrix A. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (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. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
+/* orthonormal eigenvectors of the matrix A. */
+/* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') */
+/* or the upper triangle (if UPLO='U') of A, including the */
+/* diagonal, is destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(1,3*N-1). */
+/* For optimal efficiency, LWORK >= (NB+2)*N, */
+/* where NB is the blocksize for DSYTRD 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of an intermediate tridiagonal */
+/* form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ --work;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ lower = lsame_(uplo, "L");
+ lquery = *lwork == -1;
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+
+ if (*info == 0) {
+ nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = 1, i__2 = (nb + 2) * *n;
+ lwkopt = max(i__1,i__2);
+ work[1] = (doublereal) lwkopt;
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * 3 - 1;
+ if (*lwork < max(i__1,i__2) && ! lquery) {
+ *info = -8;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSYEV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ w[1] = a[a_dim1 + 1];
+ work[1] = 2.;
+ if (wantz) {
+ a[a_dim1 + 1] = 1.;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1]);
+ iscale = 0;
+ if (anrm > 0. && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ dlascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda,
+ info);
+ }
+
+/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */
+
+ inde = 1;
+ indtau = inde + *n;
+ indwrk = indtau + *n;
+ llwork = *lwork - indwrk + 1;
+ dsytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], &
+ work[indwrk], &llwork, &iinfo);
+
+/* For eigenvalues only, call DSTERF. For eigenvectors, first call */
+/* DORGTR to generate the orthogonal matrix, then call DSTEQR. */
+
+ if (! wantz) {
+ dsterf_(n, &w[1], &work[inde], info);
+ } else {
+ dorgtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], &
+ llwork, &iinfo);
+ dsteqr_(jobz, n, &w[1], &work[inde], &a[a_offset], lda, &work[indtau],
+ info);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *n;
+ } else {
+ imax = *info - 1;
+ }
+ d__1 = 1. / sigma;
+ dscal_(&imax, &d__1, &w[1], &c__1);
+ }
+
+/* Set WORK(1) to optimal workspace size. */
+
+ work[1] = (doublereal) lwkopt;
+
+ return 0;
+
+/* End of DSYEV */
+
+} /* dsyev_ */
diff --git a/SRC/dsyevd.c b/SRC/dsyevd.c
new file mode 100644
index 0000000..cd7f6d3
--- /dev/null
+++ b/SRC/dsyevd.c
@@ -0,0 +1,353 @@
+/* dsyevd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static doublereal c_b17 = 1.;
+
+/* Subroutine */ int dsyevd_(char *jobz, char *uplo, integer *n, doublereal *
+ a, integer *lda, doublereal *w, doublereal *work, integer *lwork,
+ integer *iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal eps;
+ integer inde;
+ doublereal anrm, rmin, rmax;
+ integer lopt;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo, lwmin, liopt;
+ logical lower, wantz;
+ integer indwk2, llwrk2;
+ extern doublereal dlamch_(char *);
+ integer iscale;
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), dstedc_(char *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, integer *, integer *, integer *), dlacpy_(
+ char *, integer *, integer *, doublereal *, integer *, doublereal
+ *, integer *);
+ doublereal safmin;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ integer indtau;
+ extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ integer indwrk, liwmin;
+ extern /* Subroutine */ int dormtr_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *), dsytrd_(char *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *);
+ integer llwork;
+ doublereal smlnum;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYEVD computes all eigenvalues and, optionally, eigenvectors of a */
+/* real symmetric matrix A. If eigenvectors are desired, it uses a */
+/* divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Because of large use of BLAS of level 3, DSYEVD needs N**2 more */
+/* workspace than DSYEVX. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (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. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
+/* orthonormal eigenvectors of the matrix A. */
+/* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') */
+/* or the upper triangle (if UPLO='U') of A, including the */
+/* diagonal, is destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, */
+/* dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If N <= 1, LWORK must be at least 1. */
+/* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1. */
+/* If JOBZ = 'V' and N > 1, LWORK must be at least */
+/* 1 + 6*N + 2*N**2. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK and IWORK */
+/* arrays, returns these values as the first entries of the WORK */
+/* and IWORK arrays, and no error message related to LWORK or */
+/* LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If N <= 1, LIWORK must be at least 1. */
+/* If JOBZ = 'N' and N > 1, LIWORK must be at least 1. */
+/* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK and IWORK arrays, and no error message related to */
+/* LWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed */
+/* to converge; i off-diagonal elements of an intermediate */
+/* tridiagonal form did not converge to zero; */
+/* if INFO = i and JOBZ = 'V', then the algorithm failed */
+/* to compute an eigenvalue while working on the submatrix */
+/* lying in rows and columns INFO/(N+1) through */
+/* mod(INFO,N+1). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+/* Modified by Francoise Tisseur, University of Tennessee. */
+
+/* Modified description of INFO. Sven, 16 Feb 05. */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ lower = lsame_(uplo, "L");
+ lquery = *lwork == -1 || *liwork == -1;
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+
+ if (*info == 0) {
+ if (*n <= 1) {
+ liwmin = 1;
+ lwmin = 1;
+ lopt = lwmin;
+ liopt = liwmin;
+ } else {
+ if (wantz) {
+ liwmin = *n * 5 + 3;
+/* Computing 2nd power */
+ i__1 = *n;
+ lwmin = *n * 6 + 1 + (i__1 * i__1 << 1);
+ } else {
+ liwmin = 1;
+ lwmin = (*n << 1) + 1;
+ }
+/* Computing MAX */
+ i__1 = lwmin, i__2 = (*n << 1) + ilaenv_(&c__1, "DSYTRD", uplo, n,
+ &c_n1, &c_n1, &c_n1);
+ lopt = max(i__1,i__2);
+ liopt = liwmin;
+ }
+ work[1] = (doublereal) lopt;
+ iwork[1] = liopt;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -8;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -10;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSYEVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ w[1] = a[a_dim1 + 1];
+ if (wantz) {
+ a[a_dim1 + 1] = 1.;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1]);
+ iscale = 0;
+ if (anrm > 0. && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ dlascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda,
+ info);
+ }
+
+/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */
+
+ inde = 1;
+ indtau = inde + *n;
+ indwrk = indtau + *n;
+ llwork = *lwork - indwrk + 1;
+ indwk2 = indwrk + *n * *n;
+ llwrk2 = *lwork - indwk2 + 1;
+
+ dsytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], &
+ work[indwrk], &llwork, &iinfo);
+ lopt = (integer) ((*n << 1) + work[indwrk]);
+
+/* For eigenvalues only, call DSTERF. For eigenvectors, first call */
+/* DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the */
+/* tridiagonal matrix, then call DORMTR to multiply it by the */
+/* Householder transformations stored in A. */
+
+ if (! wantz) {
+ dsterf_(n, &w[1], &work[inde], info);
+ } else {
+ dstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], &
+ llwrk2, &iwork[1], liwork, info);
+ dormtr_("L", uplo, "N", n, n, &a[a_offset], lda, &work[indtau], &work[
+ indwrk], n, &work[indwk2], &llwrk2, &iinfo);
+ dlacpy_("A", n, n, &work[indwrk], n, &a[a_offset], lda);
+/* Computing MAX */
+/* Computing 2nd power */
+ i__3 = *n;
+ i__1 = lopt, i__2 = *n * 6 + 1 + (i__3 * i__3 << 1);
+ lopt = max(i__1,i__2);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ d__1 = 1. / sigma;
+ dscal_(n, &d__1, &w[1], &c__1);
+ }
+
+ work[1] = (doublereal) lopt;
+ iwork[1] = liopt;
+
+ return 0;
+
+/* End of DSYEVD */
+
+} /* dsyevd_ */
diff --git a/SRC/dsyevr.c b/SRC/dsyevr.c
new file mode 100644
index 0000000..4574299
--- /dev/null
+++ b/SRC/dsyevr.c
@@ -0,0 +1,652 @@
+/* dsyevr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__10 = 10;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dsyevr_(char *jobz, char *range, char *uplo, integer *n,
+ doublereal *a, integer *lda, doublereal *vl, doublereal *vu, integer *
+ il, integer *iu, doublereal *abstol, integer *m, doublereal *w,
+ doublereal *z__, integer *ldz, integer *isuppz, doublereal *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, nb, jj;
+ doublereal eps, vll, vuu, tmp1;
+ integer indd, inde;
+ doublereal anrm;
+ integer imax;
+ doublereal rmin, rmax;
+ integer inddd, indee;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ char order[1];
+ integer indwk;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dswap_(integer *, doublereal *, integer
+ *, doublereal *, integer *);
+ integer lwmin;
+ logical lower, wantz;
+ extern doublereal dlamch_(char *);
+ logical alleig, indeig;
+ integer iscale, ieeeok, indibl, indifl;
+ logical valeig;
+ doublereal safmin;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal abstll, bignum;
+ integer indtau, indisp;
+ extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, integer *),
+ dsterf_(integer *, doublereal *, doublereal *, integer *);
+ integer indiwo, indwkn;
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal
+ *, doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, integer *),
+ dstemr_(char *, char *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, integer *,
+ logical *, doublereal *, integer *, integer *, integer *, integer
+ *);
+ integer liwmin;
+ logical tryrac;
+ extern /* Subroutine */ int dormtr_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ integer llwrkn, llwork, nsplit;
+ doublereal smlnum;
+ extern /* Subroutine */ int dsytrd_(char *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYEVR computes selected eigenvalues and, optionally, eigenvectors */
+/* of a real symmetric matrix A. Eigenvalues and eigenvectors can be */
+/* selected by specifying either a range of values or a range of */
+/* indices for the desired eigenvalues. */
+
+/* DSYEVR first reduces the matrix A to tridiagonal form T with a call */
+/* to DSYTRD. Then, whenever possible, DSYEVR calls DSTEMR to compute */
+/* the eigenspectrum using Relatively Robust Representations. DSTEMR */
+/* computes eigenvalues by the dqds algorithm, while orthogonal */
+/* eigenvectors are computed from various "good" L D L^T representations */
+/* (also known as Relatively Robust Representations). Gram-Schmidt */
+/* orthogonalization is avoided as far as possible. More specifically, */
+/* the various steps of the algorithm are as follows. */
+
+/* For each unreduced block (submatrix) of T, */
+/* (a) Compute T - sigma I = L D L^T, so that L and D */
+/* define all the wanted eigenvalues to high relative accuracy. */
+/* This means that small relative changes in the entries of D and L */
+/* cause only small relative changes in the eigenvalues and */
+/* eigenvectors. The standard (unfactored) representation of the */
+/* tridiagonal matrix T does not have this property in general. */
+/* (b) Compute the eigenvalues to suitable accuracy. */
+/* If the eigenvectors are desired, the algorithm attains full */
+/* accuracy of the computed eigenvalues only right before */
+/* the corresponding vectors have to be computed, see steps c) and d). */
+/* (c) For each cluster of close eigenvalues, select a new */
+/* shift close to the cluster, find a new factorization, and refine */
+/* the shifted eigenvalues to suitable accuracy. */
+/* (d) For each eigenvalue with a large enough relative separation compute */
+/* the corresponding eigenvector by forming a rank revealing twisted */
+/* factorization. Go back to (c) for any clusters that remain. */
+
+/* The desired accuracy of the output can be specified by the input */
+/* parameter ABSTOL. */
+
+/* For more details, see DSTEMR's documentation and: */
+/* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */
+/* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */
+/* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */
+/* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */
+/* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */
+/* 2004. Also LAPACK Working Note 154. */
+/* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */
+/* tridiagonal eigenvalue/eigenvector problem", */
+/* Computer Science Division Technical Report No. UCB/CSD-97-971, */
+/* UC Berkeley, May 1997. */
+
+
+/* Note 1 : DSYEVR calls DSTEMR when the full spectrum is requested */
+/* on machines which conform to the ieee-754 floating point standard. */
+/* DSYEVR calls DSTEBZ and SSTEIN on non-ieee machines and */
+/* when partial spectrum requests are made. */
+
+/* Normal execution of DSTEMR may create NaNs and infinities and */
+/* hence may abort due to a floating point exception in environments */
+/* which do not handle NaNs and infinities in the ieee standard default */
+/* manner. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+/* ********* For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and */
+/* ********* DSTEIN are called */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (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. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+/* On exit, the lower triangle (if UPLO='L') or the upper */
+/* triangle (if UPLO='U') of A, including the diagonal, is */
+/* destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) DOUBLE PRECISION */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing A to tridiagonal form. */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices */
+/* with Guaranteed High Relative Accuracy," by Demmel and */
+/* Kahan, LAPACK Working Note #3. */
+
+/* If high relative accuracy is important, set ABSTOL to */
+/* DLAMCH( 'Safe minimum' ). Doing so will guarantee that */
+/* eigenvalues are computed to high relative accuracy when */
+/* possible in future releases. The current code does not */
+/* make any guarantees about high relative accuracy, but */
+/* future releases will. See J. Barlow and J. Demmel, */
+/* "Computing Accurate Eigensystems of Scaled Diagonally */
+/* Dominant Matrices", LAPACK Working Note #7, for a discussion */
+/* of which matrices define their eigenvalues to high relative */
+/* accuracy. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* The first M elements contain the selected eigenvalues in */
+/* ascending order. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+/* Supplying N columns is always safe. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */
+/* The support of the eigenvectors in Z, i.e., the indices */
+/* indicating the nonzero elements in Z. The i-th eigenvector */
+/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */
+/* ISUPPZ( 2*i ). */
+/* ********* Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,26*N). */
+/* For optimal efficiency, LWORK >= (NB+6)*N, */
+/* where NB is the max of the blocksize for DSYTRD and DORMTR */
+/* 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. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. LIWORK >= max(1,10*N). */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal size of the IWORK array, */
+/* returns this value as the first entry of the IWORK array, and */
+/* no error message related to LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: Internal error */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Inderjit Dhillon, IBM Almaden, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Ken Stanley, Computer Science Division, University of */
+/* California at Berkeley, USA */
+/* Jason Riedy, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --isuppz;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ ieeeok = ilaenv_(&c__10, "DSYEVR", "N", &c__1, &c__2, &c__3, &c__4);
+
+ lower = lsame_(uplo, "L");
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ lquery = *lwork == -1 || *liwork == -1;
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * 26;
+ lwmin = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * 10;
+ liwmin = max(i__1,i__2);
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -8;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -9;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -10;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -15;
+ } else if (*lwork < lwmin && ! lquery) {
+ *info = -18;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -20;
+ }
+ }
+
+ if (*info == 0) {
+ nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "DORMTR", uplo, n, &c_n1, &c_n1, &
+ c_n1);
+ nb = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = (nb + 1) * *n;
+ lwkopt = max(i__1,lwmin);
+ work[1] = (doublereal) lwkopt;
+ iwork[1] = liwmin;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSYEVR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ work[1] = 1.;
+ return 0;
+ }
+
+ if (*n == 1) {
+ work[1] = 7.;
+ if (alleig || indeig) {
+ *m = 1;
+ w[1] = a[a_dim1 + 1];
+ } else {
+ if (*vl < a[a_dim1 + 1] && *vu >= a[a_dim1 + 1]) {
+ *m = 1;
+ w[1] = a[a_dim1 + 1];
+ }
+ }
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
+ rmax = min(d__1,d__2);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ abstll = *abstol;
+ vll = *vl;
+ vuu = *vu;
+ anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1]);
+ if (anrm > 0. && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ if (lower) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ dscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+ if (*abstol > 0.) {
+ abstll = *abstol * sigma;
+ }
+ if (valeig) {
+ vll = *vl * sigma;
+ vuu = *vu * sigma;
+ }
+ }
+/* Initialize indices into workspaces. Note: The IWORK indices are */
+/* used only if DSTERF or DSTEMR fail. */
+/* WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the */
+/* elementary reflectors used in DSYTRD. */
+ indtau = 1;
+/* WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries. */
+ indd = indtau + *n;
+/* WORK(INDE:INDE+N-1) stores the off-diagonal entries of the */
+/* tridiagonal matrix from DSYTRD. */
+ inde = indd + *n;
+/* WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over */
+/* -written by DSTEMR (the DSTERF path copies the diagonal to W). */
+ inddd = inde + *n;
+/* WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over */
+/* -written while computing the eigenvalues in DSTERF and DSTEMR. */
+ indee = inddd + *n;
+/* INDWK is the starting offset of the left-over workspace, and */
+/* LLWORK is the remaining workspace size. */
+ indwk = indee + *n;
+ llwork = *lwork - indwk + 1;
+/* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and */
+/* stores the block indices of each of the M<=N eigenvalues. */
+ indibl = 1;
+/* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and */
+/* stores the starting and finishing indices of each block. */
+ indisp = indibl + *n;
+/* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors */
+/* that corresponding to eigenvectors that fail to converge in */
+/* DSTEIN. This information is discarded; if any fail, the driver */
+/* returns INFO > 0. */
+ indifl = indisp + *n;
+/* INDIWO is the offset of the remaining integer workspace. */
+ indiwo = indisp + *n;
+
+/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */
+
+ dsytrd_(uplo, n, &a[a_offset], lda, &work[indd], &work[inde], &work[
+ indtau], &work[indwk], &llwork, &iinfo);
+
+/* If all eigenvalues are desired */
+/* then call DSTERF or DSTEMR and DORMTR. */
+
+ if ((alleig || indeig && *il == 1 && *iu == *n) && ieeeok == 1) {
+ if (! wantz) {
+ dcopy_(n, &work[indd], &c__1, &w[1], &c__1);
+ i__1 = *n - 1;
+ dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
+ dsterf_(n, &w[1], &work[indee], info);
+ } else {
+ i__1 = *n - 1;
+ dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
+ dcopy_(n, &work[indd], &c__1, &work[inddd], &c__1);
+
+ if (*abstol <= *n * 2. * eps) {
+ tryrac = TRUE_;
+ } else {
+ tryrac = FALSE_;
+ }
+ dstemr_(jobz, "A", n, &work[inddd], &work[indee], vl, vu, il, iu,
+ m, &w[1], &z__[z_offset], ldz, n, &isuppz[1], &tryrac, &
+ work[indwk], lwork, &iwork[1], liwork, info);
+
+
+
+/* Apply orthogonal matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by DSTEIN. */
+
+ if (wantz && *info == 0) {
+ indwkn = inde;
+ llwrkn = *lwork - indwkn + 1;
+ dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau]
+, &z__[z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
+ }
+ }
+
+
+ if (*info == 0) {
+/* Everything worked. Skip DSTEBZ/DSTEIN. IWORK(:) are */
+/* undefined. */
+ *m = *n;
+ goto L30;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN. */
+/* Also call DSTEBZ and DSTEIN if DSTEMR fails. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[
+ inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[
+ indwk], &iwork[indiwo], info);
+
+ if (wantz) {
+ dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
+ indisp], &z__[z_offset], ldz, &work[indwk], &iwork[indiwo], &
+ iwork[indifl], info);
+
+/* Apply orthogonal matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by DSTEIN. */
+
+ indwkn = inde;
+ llwrkn = *lwork - indwkn + 1;
+ dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[
+ z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+/* Jump here if DSTEMR/DSTEIN succeeded. */
+L30:
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *m;
+ } else {
+ imax = *info - 1;
+ }
+ d__1 = 1. / sigma;
+ dscal_(&imax, &d__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. Note: We do not sort the IFAIL portion of IWORK. */
+/* It may not be initialized (if DSTEMR/DSTEIN succeeded), and we do */
+/* not return this detailed information to the user. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L40: */
+ }
+
+ if (i__ != 0) {
+ w[i__] = w[j];
+ w[j] = tmp1;
+ dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ }
+/* L50: */
+ }
+ }
+
+/* Set WORK(1) to optimal workspace size. */
+
+ work[1] = (doublereal) lwkopt;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of DSYEVR */
+
+} /* dsyevr_ */
diff --git a/SRC/dsyevx.c b/SRC/dsyevx.c
new file mode 100644
index 0000000..1b6a3c2
--- /dev/null
+++ b/SRC/dsyevx.c
@@ -0,0 +1,536 @@
+/* dsyevx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dsyevx_(char *jobz, char *range, char *uplo, integer *n,
+ doublereal *a, integer *lda, doublereal *vl, doublereal *vu, integer *
+ il, integer *iu, doublereal *abstol, integer *m, doublereal *w,
+ doublereal *z__, integer *ldz, doublereal *work, integer *lwork,
+ integer *iwork, integer *ifail, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, nb, jj;
+ doublereal eps, vll, vuu, tmp1;
+ integer indd, inde;
+ doublereal anrm;
+ integer imax;
+ doublereal rmin, rmax;
+ logical test;
+ integer itmp1, indee;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ char order[1];
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dswap_(integer *, doublereal *, integer
+ *, doublereal *, integer *);
+ logical lower, wantz;
+ extern doublereal dlamch_(char *);
+ logical alleig, indeig;
+ integer iscale, indibl;
+ logical valeig;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ doublereal safmin;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal abstll, bignum;
+ integer indtau, indisp;
+ extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, integer *),
+ dsterf_(integer *, doublereal *, doublereal *, integer *);
+ integer indiwo, indwkn;
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal
+ *, doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, integer *);
+ integer indwrk, lwkmin;
+ extern /* Subroutine */ int dorgtr_(char *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *), dsteqr_(char *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *),
+ dormtr_(char *, char *, char *, integer *, integer *, doublereal *
+, integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, integer *);
+ integer llwrkn, llwork, nsplit;
+ doublereal smlnum;
+ extern /* Subroutine */ int dsytrd_(char *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYEVX computes selected eigenvalues and, optionally, eigenvectors */
+/* of a real symmetric matrix A. Eigenvalues and eigenvectors can be */
+/* selected by specifying either a range of values or a range of indices */
+/* for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (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. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+/* On exit, the lower triangle (if UPLO='L') or the upper */
+/* triangle (if UPLO='U') of A, including the diagonal, is */
+/* destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) DOUBLE PRECISION */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing A to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*DLAMCH('S'). */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices */
+/* with Guaranteed High Relative Accuracy," by Demmel and */
+/* Kahan, LAPACK Working Note #3. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* On normal exit, the first M elements contain the selected */
+/* eigenvalues in ascending order. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If an eigenvector fails to converge, then that column of Z */
+/* contains the latest approximation to the eigenvector, and the */
+/* index of the eigenvector is returned in IFAIL. */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= 1, when N <= 1; */
+/* otherwise 8*N. */
+/* For optimal efficiency, LWORK >= (NB+3)*N, */
+/* where NB is the max of the blocksize for DSYTRD and DORMTR */
+/* 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. */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, then i eigenvectors failed to converge. */
+/* Their indices are stored in array IFAIL. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ lower = lsame_(uplo, "L");
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+ lquery = *lwork == -1;
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -8;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -9;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -10;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -15;
+ }
+ }
+
+ if (*info == 0) {
+ if (*n <= 1) {
+ lwkmin = 1;
+ work[1] = (doublereal) lwkmin;
+ } else {
+ lwkmin = *n << 3;
+ nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "DORMTR", uplo, n, &c_n1, &c_n1,
+ &c_n1);
+ nb = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = lwkmin, i__2 = (nb + 3) * *n;
+ lwkopt = max(i__1,i__2);
+ work[1] = (doublereal) lwkopt;
+ }
+
+ if (*lwork < lwkmin && ! lquery) {
+ *info = -17;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSYEVX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (alleig || indeig) {
+ *m = 1;
+ w[1] = a[a_dim1 + 1];
+ } else {
+ if (*vl < a[a_dim1 + 1] && *vu >= a[a_dim1 + 1]) {
+ *m = 1;
+ w[1] = a[a_dim1 + 1];
+ }
+ }
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
+ rmax = min(d__1,d__2);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ abstll = *abstol;
+ if (valeig) {
+ vll = *vl;
+ vuu = *vu;
+ }
+ anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1]);
+ if (anrm > 0. && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ if (lower) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ dscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+ if (*abstol > 0.) {
+ abstll = *abstol * sigma;
+ }
+ if (valeig) {
+ vll = *vl * sigma;
+ vuu = *vu * sigma;
+ }
+ }
+
+/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */
+
+ indtau = 1;
+ inde = indtau + *n;
+ indd = inde + *n;
+ indwrk = indd + *n;
+ llwork = *lwork - indwrk + 1;
+ dsytrd_(uplo, n, &a[a_offset], lda, &work[indd], &work[inde], &work[
+ indtau], &work[indwrk], &llwork, &iinfo);
+
+/* If all eigenvalues are desired and ABSTOL is less than or equal to */
+/* zero, then call DSTERF or DORGTR and SSTEQR. If this fails for */
+/* some eigenvalue, then try DSTEBZ. */
+
+ test = FALSE_;
+ if (indeig) {
+ if (*il == 1 && *iu == *n) {
+ test = TRUE_;
+ }
+ }
+ if ((alleig || test) && *abstol <= 0.) {
+ dcopy_(n, &work[indd], &c__1, &w[1], &c__1);
+ indee = indwrk + (*n << 1);
+ if (! wantz) {
+ i__1 = *n - 1;
+ dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
+ dsterf_(n, &w[1], &work[indee], info);
+ } else {
+ dlacpy_("A", n, n, &a[a_offset], lda, &z__[z_offset], ldz);
+ dorgtr_(uplo, n, &z__[z_offset], ldz, &work[indtau], &work[indwrk]
+, &llwork, &iinfo);
+ i__1 = *n - 1;
+ dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
+ dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[
+ indwrk], info);
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ifail[i__] = 0;
+/* L30: */
+ }
+ }
+ }
+ if (*info == 0) {
+ *m = *n;
+ goto L40;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ indibl = 1;
+ indisp = indibl + *n;
+ indiwo = indisp + *n;
+ dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[
+ inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[
+ indwrk], &iwork[indiwo], info);
+
+ if (wantz) {
+ dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
+ indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &
+ ifail[1], info);
+
+/* Apply orthogonal matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by DSTEIN. */
+
+ indwkn = inde;
+ llwrkn = *lwork - indwkn + 1;
+ dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[
+ z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+L40:
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *m;
+ } else {
+ imax = *info - 1;
+ }
+ d__1 = 1. / sigma;
+ dscal_(&imax, &d__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L50: */
+ }
+
+ if (i__ != 0) {
+ itmp1 = iwork[indibl + i__ - 1];
+ w[i__] = w[j];
+ iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
+ w[j] = tmp1;
+ iwork[indibl + j - 1] = itmp1;
+ dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ if (*info != 0) {
+ itmp1 = ifail[i__];
+ ifail[i__] = ifail[j];
+ ifail[j] = itmp1;
+ }
+ }
+/* L60: */
+ }
+ }
+
+/* Set WORK(1) to optimal workspace size. */
+
+ work[1] = (doublereal) lwkopt;
+
+ return 0;
+
+/* End of DSYEVX */
+
+} /* dsyevx_ */
diff --git a/SRC/dsygs2.c b/SRC/dsygs2.c
new file mode 100644
index 0000000..9a12cef
--- /dev/null
+++ b/SRC/dsygs2.c
@@ -0,0 +1,299 @@
+/* dsygs2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b6 = -1.;
+static integer c__1 = 1;
+static doublereal c_b27 = 1.;
+
+/* Subroutine */ int dsygs2_(integer *itype, char *uplo, integer *n,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Local variables */
+ integer k;
+ doublereal ct, akk, bkk;
+ extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *,
+ doublereal *, integer *, doublereal *, integer *), dtrsv_(char *, char *, char *, integer *, doublereal *,
+ integer *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYGS2 reduces a real symmetric-definite generalized eigenproblem */
+/* to standard form. */
+
+/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
+/* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L') */
+
+/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
+/* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L. */
+
+/* B must have been previously factorized as U'*U or L*L' by DPOTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L'); */
+/* = 2 or 3: compute U*A*U' or L'*A*L. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored, and how B has been factorized. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n by n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n by n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the transformed matrix, stored in the */
+/* same format as A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,N) */
+/* The triangular factor from the Cholesky factorization of B, */
+/* as returned by DPOTRF. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSYGS2", &i__1);
+ return 0;
+ }
+
+ if (*itype == 1) {
+ if (upper) {
+
+/* Compute inv(U')*A*inv(U) */
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+/* Update the upper triangle of A(k:n,k:n) */
+
+ akk = a[k + k * a_dim1];
+ bkk = b[k + k * b_dim1];
+/* Computing 2nd power */
+ d__1 = bkk;
+ akk /= d__1 * d__1;
+ a[k + k * a_dim1] = akk;
+ if (k < *n) {
+ i__2 = *n - k;
+ d__1 = 1. / bkk;
+ dscal_(&i__2, &d__1, &a[k + (k + 1) * a_dim1], lda);
+ ct = akk * -.5;
+ i__2 = *n - k;
+ daxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
+ k + 1) * a_dim1], lda);
+ i__2 = *n - k;
+ dsyr2_(uplo, &i__2, &c_b6, &a[k + (k + 1) * a_dim1], lda,
+ &b[k + (k + 1) * b_dim1], ldb, &a[k + 1 + (k + 1)
+ * a_dim1], lda);
+ i__2 = *n - k;
+ daxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
+ k + 1) * a_dim1], lda);
+ i__2 = *n - k;
+ dtrsv_(uplo, "Transpose", "Non-unit", &i__2, &b[k + 1 + (
+ k + 1) * b_dim1], ldb, &a[k + (k + 1) * a_dim1],
+ lda);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Compute inv(L)*A*inv(L') */
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+/* Update the lower triangle of A(k:n,k:n) */
+
+ akk = a[k + k * a_dim1];
+ bkk = b[k + k * b_dim1];
+/* Computing 2nd power */
+ d__1 = bkk;
+ akk /= d__1 * d__1;
+ a[k + k * a_dim1] = akk;
+ if (k < *n) {
+ i__2 = *n - k;
+ d__1 = 1. / bkk;
+ dscal_(&i__2, &d__1, &a[k + 1 + k * a_dim1], &c__1);
+ ct = akk * -.5;
+ i__2 = *n - k;
+ daxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
+ 1 + k * a_dim1], &c__1);
+ i__2 = *n - k;
+ dsyr2_(uplo, &i__2, &c_b6, &a[k + 1 + k * a_dim1], &c__1,
+ &b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + (k + 1)
+ * a_dim1], lda);
+ i__2 = *n - k;
+ daxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
+ 1 + k * a_dim1], &c__1);
+ i__2 = *n - k;
+ dtrsv_(uplo, "No transpose", "Non-unit", &i__2, &b[k + 1
+ + (k + 1) * b_dim1], ldb, &a[k + 1 + k * a_dim1],
+ &c__1);
+ }
+/* L20: */
+ }
+ }
+ } else {
+ if (upper) {
+
+/* Compute U*A*U' */
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+/* Update the upper triangle of A(1:k,1:k) */
+
+ akk = a[k + k * a_dim1];
+ bkk = b[k + k * b_dim1];
+ i__2 = k - 1;
+ dtrmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset],
+ ldb, &a[k * a_dim1 + 1], &c__1);
+ ct = akk * .5;
+ i__2 = k - 1;
+ daxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
+ 1], &c__1);
+ i__2 = k - 1;
+ dsyr2_(uplo, &i__2, &c_b27, &a[k * a_dim1 + 1], &c__1, &b[k *
+ b_dim1 + 1], &c__1, &a[a_offset], lda);
+ i__2 = k - 1;
+ daxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
+ 1], &c__1);
+ i__2 = k - 1;
+ dscal_(&i__2, &bkk, &a[k * a_dim1 + 1], &c__1);
+/* Computing 2nd power */
+ d__1 = bkk;
+ a[k + k * a_dim1] = akk * (d__1 * d__1);
+/* L30: */
+ }
+ } else {
+
+/* Compute L'*A*L */
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+/* Update the lower triangle of A(1:k,1:k) */
+
+ akk = a[k + k * a_dim1];
+ bkk = b[k + k * b_dim1];
+ i__2 = k - 1;
+ dtrmv_(uplo, "Transpose", "Non-unit", &i__2, &b[b_offset],
+ ldb, &a[k + a_dim1], lda);
+ ct = akk * .5;
+ i__2 = k - 1;
+ daxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
+ i__2 = k - 1;
+ dsyr2_(uplo, &i__2, &c_b27, &a[k + a_dim1], lda, &b[k +
+ b_dim1], ldb, &a[a_offset], lda);
+ i__2 = k - 1;
+ daxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
+ i__2 = k - 1;
+ dscal_(&i__2, &bkk, &a[k + a_dim1], lda);
+/* Computing 2nd power */
+ d__1 = bkk;
+ a[k + k * a_dim1] = akk * (d__1 * d__1);
+/* L40: */
+ }
+ }
+ }
+ return 0;
+
+/* End of DSYGS2 */
+
+} /* dsygs2_ */
diff --git a/SRC/dsygst.c b/SRC/dsygst.c
new file mode 100644
index 0000000..55635fe
--- /dev/null
+++ b/SRC/dsygst.c
@@ -0,0 +1,347 @@
+/* dsygst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b14 = 1.;
+static doublereal c_b16 = -.5;
+static doublereal c_b19 = -1.;
+static doublereal c_b52 = .5;
+
+/* Subroutine */ int dsygst_(integer *itype, char *uplo, integer *n,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer k, kb, nb;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), dsymm_(
+ char *, char *, integer *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ logical upper;
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), dsygs2_(
+ integer *, char *, integer *, doublereal *, integer *, doublereal
+ *, integer *, integer *), dsyr2k_(char *, char *, integer
+ *, integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *)
+ , xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYGST reduces a real symmetric-definite generalized eigenproblem */
+/* to standard form. */
+
+/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
+/* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) */
+
+/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
+/* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L. */
+
+/* B must have been previously factorized as U**T*U or L*L**T by DPOTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); */
+/* = 2 or 3: compute U*A*U**T or L**T*A*L. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored and B is factored as */
+/* U**T*U; */
+/* = 'L': Lower triangle of A is stored and B is factored as */
+/* L*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the transformed matrix, stored in the */
+/* same format as A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,N) */
+/* The triangular factor from the Cholesky factorization of B, */
+/* as returned by DPOTRF. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSYGST", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "DSYGST", uplo, n, &c_n1, &c_n1, &c_n1);
+
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code */
+
+ dsygs2_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
+ } else {
+
+/* Use blocked code */
+
+ if (*itype == 1) {
+ if (upper) {
+
+/* Compute inv(U')*A*inv(U) */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+/* Computing MIN */
+ i__3 = *n - k + 1;
+ kb = min(i__3,nb);
+
+/* Update the upper triangle of A(k:n,k:n) */
+
+ dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
+ k * b_dim1], ldb, info);
+ if (k + kb <= *n) {
+ i__3 = *n - k - kb + 1;
+ dtrsm_("Left", uplo, "Transpose", "Non-unit", &kb, &
+ i__3, &c_b14, &b[k + k * b_dim1], ldb, &a[k +
+ (k + kb) * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ dsymm_("Left", uplo, &kb, &i__3, &c_b16, &a[k + k *
+ a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb,
+ &c_b14, &a[k + (k + kb) * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ dsyr2k_(uplo, "Transpose", &i__3, &kb, &c_b19, &a[k +
+ (k + kb) * a_dim1], lda, &b[k + (k + kb) *
+ b_dim1], ldb, &c_b14, &a[k + kb + (k + kb) *
+ a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ dsymm_("Left", uplo, &kb, &i__3, &c_b16, &a[k + k *
+ a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb,
+ &c_b14, &a[k + (k + kb) * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ dtrsm_("Right", uplo, "No transpose", "Non-unit", &kb,
+ &i__3, &c_b14, &b[k + kb + (k + kb) * b_dim1]
+, ldb, &a[k + (k + kb) * a_dim1], lda);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Compute inv(L)*A*inv(L') */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+/* Computing MIN */
+ i__3 = *n - k + 1;
+ kb = min(i__3,nb);
+
+/* Update the lower triangle of A(k:n,k:n) */
+
+ dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
+ k * b_dim1], ldb, info);
+ if (k + kb <= *n) {
+ i__3 = *n - k - kb + 1;
+ dtrsm_("Right", uplo, "Transpose", "Non-unit", &i__3,
+ &kb, &c_b14, &b[k + k * b_dim1], ldb, &a[k +
+ kb + k * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ dsymm_("Right", uplo, &i__3, &kb, &c_b16, &a[k + k *
+ a_dim1], lda, &b[k + kb + k * b_dim1], ldb, &
+ c_b14, &a[k + kb + k * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ dsyr2k_(uplo, "No transpose", &i__3, &kb, &c_b19, &a[
+ k + kb + k * a_dim1], lda, &b[k + kb + k *
+ b_dim1], ldb, &c_b14, &a[k + kb + (k + kb) *
+ a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ dsymm_("Right", uplo, &i__3, &kb, &c_b16, &a[k + k *
+ a_dim1], lda, &b[k + kb + k * b_dim1], ldb, &
+ c_b14, &a[k + kb + k * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ dtrsm_("Left", uplo, "No transpose", "Non-unit", &
+ i__3, &kb, &c_b14, &b[k + kb + (k + kb) *
+ b_dim1], ldb, &a[k + kb + k * a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+ } else {
+ if (upper) {
+
+/* Compute U*A*U' */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+/* Computing MIN */
+ i__3 = *n - k + 1;
+ kb = min(i__3,nb);
+
+/* Update the upper triangle of A(1:k+kb-1,1:k+kb-1) */
+
+ i__3 = k - 1;
+ dtrmm_("Left", uplo, "No transpose", "Non-unit", &i__3, &
+ kb, &c_b14, &b[b_offset], ldb, &a[k * a_dim1 + 1],
+ lda)
+ ;
+ i__3 = k - 1;
+ dsymm_("Right", uplo, &i__3, &kb, &c_b52, &a[k + k *
+ a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, &a[
+ k * a_dim1 + 1], lda);
+ i__3 = k - 1;
+ dsyr2k_(uplo, "No transpose", &i__3, &kb, &c_b14, &a[k *
+ a_dim1 + 1], lda, &b[k * b_dim1 + 1], ldb, &c_b14,
+ &a[a_offset], lda);
+ i__3 = k - 1;
+ dsymm_("Right", uplo, &i__3, &kb, &c_b52, &a[k + k *
+ a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, &a[
+ k * a_dim1 + 1], lda);
+ i__3 = k - 1;
+ dtrmm_("Right", uplo, "Transpose", "Non-unit", &i__3, &kb,
+ &c_b14, &b[k + k * b_dim1], ldb, &a[k * a_dim1 +
+ 1], lda);
+ dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
+ k * b_dim1], ldb, info);
+/* L30: */
+ }
+ } else {
+
+/* Compute L'*A*L */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+/* Computing MIN */
+ i__3 = *n - k + 1;
+ kb = min(i__3,nb);
+
+/* Update the lower triangle of A(1:k+kb-1,1:k+kb-1) */
+
+ i__3 = k - 1;
+ dtrmm_("Right", uplo, "No transpose", "Non-unit", &kb, &
+ i__3, &c_b14, &b[b_offset], ldb, &a[k + a_dim1],
+ lda);
+ i__3 = k - 1;
+ dsymm_("Left", uplo, &kb, &i__3, &c_b52, &a[k + k *
+ a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[k +
+ a_dim1], lda);
+ i__3 = k - 1;
+ dsyr2k_(uplo, "Transpose", &i__3, &kb, &c_b14, &a[k +
+ a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[
+ a_offset], lda);
+ i__3 = k - 1;
+ dsymm_("Left", uplo, &kb, &i__3, &c_b52, &a[k + k *
+ a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[k +
+ a_dim1], lda);
+ i__3 = k - 1;
+ dtrmm_("Left", uplo, "Transpose", "Non-unit", &kb, &i__3,
+ &c_b14, &b[k + k * b_dim1], ldb, &a[k + a_dim1],
+ lda);
+ dsygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
+ k * b_dim1], ldb, info);
+/* L40: */
+ }
+ }
+ }
+ }
+ return 0;
+
+/* End of DSYGST */
+
+} /* dsygst_ */
diff --git a/SRC/dsygv.c b/SRC/dsygv.c
new file mode 100644
index 0000000..47a80c6
--- /dev/null
+++ b/SRC/dsygv.c
@@ -0,0 +1,285 @@
+/* dsygv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b16 = 1.;
+
+/* Subroutine */ int dsygv_(integer *itype, char *jobz, char *uplo, integer *
+ n, doublereal *a, integer *lda, doublereal *b, integer *ldb,
+ doublereal *w, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+
+ /* Local variables */
+ integer nb, neig;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+ char trans[1];
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int dsyev_(char *, char *, integer *, doublereal *
+, integer *, doublereal *, doublereal *, integer *, integer *);
+ logical wantz;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dpotrf_(char *, integer *, doublereal *,
+ integer *, integer *);
+ integer lwkmin;
+ extern /* Subroutine */ int dsygst_(integer *, char *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYGV computes all the eigenvalues, and optionally, the eigenvectors */
+/* of a real generalized symmetric-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. */
+/* Here A and B are assumed to be symmetric and B is also */
+/* positive definite. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of A contains the */
+/* upper triangular part of the matrix A. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+
+/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
+/* matrix Z of eigenvectors. The eigenvectors are normalized */
+/* as follows: */
+/* if ITYPE = 1 or 2, Z**T*B*Z = I; */
+/* if ITYPE = 3, Z**T*inv(B)*Z = I. */
+/* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') */
+/* or the lower triangle (if UPLO='L') of A, including the */
+/* diagonal, is destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */
+/* On entry, the symmetric positive definite matrix B. */
+/* If UPLO = 'U', the leading N-by-N upper triangular part of B */
+/* contains the upper triangular part of the matrix B. */
+/* If UPLO = 'L', the leading N-by-N lower triangular part of B */
+/* contains the lower triangular part of the matrix B. */
+
+/* On exit, if INFO <= N, the part of B containing the matrix is */
+/* overwritten by the triangular factor U or L from the Cholesky */
+/* factorization B = U**T*U or B = L*L**T. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(1,3*N-1). */
+/* For optimal efficiency, LWORK >= (NB+2)*N, */
+/* where NB is the blocksize for DSYTRD 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: DPOTRF or DSYEV returned an error code: */
+/* <= N: if INFO = i, DSYEV failed to converge; */
+/* i off-diagonal elements of an intermediate */
+/* tridiagonal form did not converge to zero; */
+/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --w;
+ --work;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1;
+
+ *info = 0;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+
+ if (*info == 0) {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * 3 - 1;
+ lwkmin = max(i__1,i__2);
+ nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = lwkmin, i__2 = (nb + 2) * *n;
+ lwkopt = max(i__1,i__2);
+ work[1] = (doublereal) lwkopt;
+
+ if (*lwork < lwkmin && ! lquery) {
+ *info = -11;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSYGV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of B. */
+
+ dpotrf_(uplo, n, &b[b_offset], ldb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ dsygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
+ dsyev_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, info);
+
+ if (wantz) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ neig = *n;
+ if (*info > 0) {
+ neig = *info - 1;
+ }
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'T';
+ }
+
+ dtrsm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b16, &b[
+ b_offset], ldb, &a[a_offset], lda);
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'T';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ dtrmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b16, &b[
+ b_offset], ldb, &a[a_offset], lda);
+ }
+ }
+
+ work[1] = (doublereal) lwkopt;
+ return 0;
+
+/* End of DSYGV */
+
+} /* dsygv_ */
diff --git a/SRC/dsygvd.c b/SRC/dsygvd.c
new file mode 100644
index 0000000..c7469cb
--- /dev/null
+++ b/SRC/dsygvd.c
@@ -0,0 +1,338 @@
+/* dsygvd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b11 = 1.;
+
+/* Subroutine */ int dsygvd_(integer *itype, char *jobz, char *uplo, integer *
+ n, doublereal *a, integer *lda, doublereal *b, integer *ldb,
+ doublereal *w, doublereal *work, integer *lwork, integer *iwork,
+ integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer lopt;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer lwmin;
+ char trans[1];
+ integer liopt;
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical upper, wantz;
+ extern /* Subroutine */ int xerbla_(char *, integer *), dpotrf_(
+ char *, integer *, doublereal *, integer *, integer *);
+ integer liwmin;
+ extern /* Subroutine */ int dsyevd_(char *, char *, integer *, doublereal
+ *, integer *, doublereal *, doublereal *, integer *, integer *,
+ integer *, integer *), dsygst_(integer *, char *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *);
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYGVD computes all the eigenvalues, and optionally, the eigenvectors */
+/* of a real generalized symmetric-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */
+/* B are assumed to be symmetric and B is also positive definite. */
+/* If eigenvectors are desired, it uses a divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of A contains the */
+/* upper triangular part of the matrix A. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+
+/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
+/* matrix Z of eigenvectors. The eigenvectors are normalized */
+/* as follows: */
+/* if ITYPE = 1 or 2, Z**T*B*Z = I; */
+/* if ITYPE = 3, Z**T*inv(B)*Z = I. */
+/* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') */
+/* or the lower triangle (if UPLO='L') of A, including the */
+/* diagonal, is destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB, N) */
+/* On entry, the symmetric matrix B. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of B contains the */
+/* upper triangular part of the matrix B. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of B contains */
+/* the lower triangular part of the matrix B. */
+
+/* On exit, if INFO <= N, the part of B containing the matrix is */
+/* overwritten by the triangular factor U or L from the Cholesky */
+/* factorization B = U**T*U or B = L*L**T. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If N <= 1, LWORK >= 1. */
+/* If JOBZ = 'N' and N > 1, LWORK >= 2*N+1. */
+/* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK and IWORK */
+/* arrays, returns these values as the first entries of the WORK */
+/* and IWORK arrays, and no error message related to LWORK or */
+/* LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If N <= 1, LIWORK >= 1. */
+/* If JOBZ = 'N' and N > 1, LIWORK >= 1. */
+/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK and IWORK arrays, and no error message related to */
+/* LWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: DPOTRF or DSYEVD returned an error code: */
+/* <= N: if INFO = i and JOBZ = 'N', then the algorithm */
+/* failed to converge; i off-diagonal elements of an */
+/* intermediate tridiagonal form did not converge to */
+/* zero; */
+/* if INFO = i and JOBZ = 'V', then the algorithm */
+/* failed to compute an eigenvalue while working on */
+/* the submatrix lying in rows and columns INFO/(N+1) */
+/* through mod(INFO,N+1); */
+/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* Modified so that no backsubstitution is performed if DSYEVD fails to */
+/* converge (NEIG in old code could be greater than N causing out of */
+/* bounds reference to A - reported by Ralf Meyer). Also corrected the */
+/* description of INFO and the test on ITYPE. Sven, 16 Feb 05. */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --w;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1 || *liwork == -1;
+
+ *info = 0;
+ if (*n <= 1) {
+ liwmin = 1;
+ lwmin = 1;
+ } else if (wantz) {
+ liwmin = *n * 5 + 3;
+/* Computing 2nd power */
+ i__1 = *n;
+ lwmin = *n * 6 + 1 + (i__1 * i__1 << 1);
+ } else {
+ liwmin = 1;
+ lwmin = (*n << 1) + 1;
+ }
+ lopt = lwmin;
+ liopt = liwmin;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+
+ if (*info == 0) {
+ work[1] = (doublereal) lopt;
+ iwork[1] = liopt;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -11;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSYGVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of B. */
+
+ dpotrf_(uplo, n, &b[b_offset], ldb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ dsygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
+ dsyevd_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &iwork[
+ 1], liwork, info);
+/* Computing MAX */
+ d__1 = (doublereal) lopt;
+ lopt = (integer) max(d__1,work[1]);
+/* Computing MAX */
+ d__1 = (doublereal) liopt, d__2 = (doublereal) iwork[1];
+ liopt = (integer) max(d__1,d__2);
+
+ if (wantz && *info == 0) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'T';
+ }
+
+ dtrsm_("Left", uplo, trans, "Non-unit", n, n, &c_b11, &b[b_offset]
+, ldb, &a[a_offset], lda);
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'T';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ dtrmm_("Left", uplo, trans, "Non-unit", n, n, &c_b11, &b[b_offset]
+, ldb, &a[a_offset], lda);
+ }
+ }
+
+ work[1] = (doublereal) lopt;
+ iwork[1] = liopt;
+
+ return 0;
+
+/* End of DSYGVD */
+
+} /* dsygvd_ */
diff --git a/SRC/dsygvx.c b/SRC/dsygvx.c
new file mode 100644
index 0000000..fa9756c
--- /dev/null
+++ b/SRC/dsygvx.c
@@ -0,0 +1,396 @@
+/* dsygvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b19 = 1.;
+
+/* Subroutine */ int dsygvx_(integer *itype, char *jobz, char *range, char *
+ uplo, integer *n, doublereal *a, integer *lda, doublereal *b, integer
+ *ldb, doublereal *vl, doublereal *vu, integer *il, integer *iu,
+ doublereal *abstol, integer *m, doublereal *w, doublereal *z__,
+ integer *ldz, doublereal *work, integer *lwork, integer *iwork,
+ integer *ifail, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1, i__2;
+
+ /* Local variables */
+ integer nb;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+ char trans[1];
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical upper, wantz, alleig, indeig, valeig;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dpotrf_(char *, integer *, doublereal *,
+ integer *, integer *);
+ integer lwkmin;
+ extern /* Subroutine */ int dsygst_(integer *, char *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int dsyevx_(char *, char *, char *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *, integer *, integer
+ *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYGVX computes selected eigenvalues, and optionally, eigenvectors */
+/* of a real generalized symmetric-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A */
+/* and B are assumed to be symmetric and B is also positive definite. */
+/* Eigenvalues and eigenvectors can be selected by specifying either a */
+/* range of values or a range of indices for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A and B are stored; */
+/* = 'L': Lower triangle of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix pencil (A,B). N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of A contains the */
+/* upper triangular part of the matrix A. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+
+/* On exit, the lower triangle (if UPLO='L') or the upper */
+/* triangle (if UPLO='U') of A, including the diagonal, is */
+/* destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
+/* On entry, the symmetric matrix B. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of B contains the */
+/* upper triangular part of the matrix B. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of B contains */
+/* the lower triangular part of the matrix B. */
+
+/* On exit, if INFO <= N, the part of B containing the matrix is */
+/* overwritten by the triangular factor U or L from the Cholesky */
+/* factorization B = U**T*U or B = L*L**T. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) DOUBLE PRECISION */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing A to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*DLAMCH('S'). */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* On normal exit, the first M elements contain the selected */
+/* eigenvalues in ascending order. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* The eigenvectors are normalized as follows: */
+/* if ITYPE = 1 or 2, Z**T*B*Z = I; */
+/* if ITYPE = 3, Z**T*inv(B)*Z = I. */
+
+/* If an eigenvector fails to converge, then that column of Z */
+/* contains the latest approximation to the eigenvector, and the */
+/* index of the eigenvector is returned in IFAIL. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(1,8*N). */
+/* For optimal efficiency, LWORK >= (NB+3)*N, */
+/* where NB is the blocksize for DSYTRD 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. */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: DPOTRF or DSYEVX returned an error code: */
+/* <= N: if INFO = i, DSYEVX failed to converge; */
+/* i eigenvectors failed to converge. Their indices */
+/* are stored in array IFAIL. */
+/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ upper = lsame_(uplo, "U");
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+ lquery = *lwork == -1;
+
+ *info = 0;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -3;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -11;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -12;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -13;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -18;
+ }
+ }
+
+ if (*info == 0) {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n << 3;
+ lwkmin = max(i__1,i__2);
+ nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = lwkmin, i__2 = (nb + 3) * *n;
+ lwkopt = max(i__1,i__2);
+ work[1] = (doublereal) lwkopt;
+
+ if (*lwork < lwkmin && ! lquery) {
+ *info = -20;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSYGVX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of B. */
+
+ dpotrf_(uplo, n, &b[b_offset], ldb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ dsygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
+ dsyevx_(jobz, range, uplo, n, &a[a_offset], lda, vl, vu, il, iu, abstol,
+ m, &w[1], &z__[z_offset], ldz, &work[1], lwork, &iwork[1], &ifail[
+ 1], info);
+
+ if (wantz) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ if (*info > 0) {
+ *m = *info - 1;
+ }
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'T';
+ }
+
+ dtrsm_("Left", uplo, trans, "Non-unit", n, m, &c_b19, &b[b_offset]
+, ldb, &z__[z_offset], ldz);
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'T';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ dtrmm_("Left", uplo, trans, "Non-unit", n, m, &c_b19, &b[b_offset]
+, ldb, &z__[z_offset], ldz);
+ }
+ }
+
+/* Set WORK(1) to optimal workspace size. */
+
+ work[1] = (doublereal) lwkopt;
+
+ return 0;
+
+/* End of DSYGVX */
+
+} /* dsygvx_ */
diff --git a/SRC/dsyrfs.c b/SRC/dsyrfs.c
new file mode 100644
index 0000000..399d2f5
--- /dev/null
+++ b/SRC/dsyrfs.c
@@ -0,0 +1,429 @@
+/* dsyrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b12 = -1.;
+static doublereal c_b14 = 1.;
+
+/* Subroutine */ int dsyrfs_(char *uplo, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *
+ ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx,
+ doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal s, xk;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *);
+ integer count;
+ logical upper;
+ extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *), dlacn2_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal lstres;
+ extern /* Subroutine */ int dsytrs_(char *, integer *, integer *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric indefinite, and */
+/* provides error bounds and backward error estimates for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular part */
+/* of the matrix A, and the strictly lower triangular part of A */
+/* is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of A contains the lower triangular part of */
+/* the matrix A, and the strictly upper triangular part of A is */
+/* not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
+/* The factored form of the matrix A. AF contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor U or L from the factorization A = U*D*U**T or */
+/* A = L*D*L**T as computed by DSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by DSYTRF. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by DSYTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldx < max(1,*n)) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSYRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+ dsymv_(uplo, n, &c_b12, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1,
+ &c_b14, &work[*n + 1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ work[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * xk;
+ s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 = x[
+ i__ + j * x_dim1], abs(d__2));
+/* L40: */
+ }
+ work[k] = work[k] + (d__1 = a[k + k * a_dim1], abs(d__1)) *
+ xk + s;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+ work[k] += (d__1 = a[k + k * a_dim1], abs(d__1)) * xk;
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ work[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * xk;
+ s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 = x[
+ i__ + j * x_dim1], abs(d__2));
+/* L60: */
+ }
+ work[k] += s;
+/* L70: */
+ }
+ }
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[
+ i__];
+ s = max(d__2,d__3);
+ } else {
+/* Computing MAX */
+ d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1)
+ / (work[i__] + safe1);
+ s = max(d__2,d__3);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ dsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[*n
+ + 1], n, info);
+ daxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
+ ;
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use DLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+ kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ dsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ *n + 1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L120: */
+ }
+ dsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ *n + 1], n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1));
+ lstres = max(d__2,d__3);
+/* L130: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of DSYRFS */
+
+} /* dsyrfs_ */
diff --git a/SRC/dsyrfsx.c b/SRC/dsyrfsx.c
new file mode 100644
index 0000000..98f69a7
--- /dev/null
+++ b/SRC/dsyrfsx.c
@@ -0,0 +1,629 @@
+/* dsyrfsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int dsyrfsx_(char *uplo, char *equed, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
+ integer *ipiv, doublereal *s, doublereal *b, integer *ldb, doublereal
+ *x, integer *ldx, doublereal *rcond, doublereal *berr, integer *
+ n_err_bnds__, doublereal *err_bnds_norm__, doublereal *
+ err_bnds_comp__, integer *nparams, doublereal *params, doublereal *
+ work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal illrcond_thresh__, unstable_thresh__, err_lbnd__;
+ integer ref_type__, j;
+ doublereal rcond_tmp__;
+ integer prec_type__;
+ extern doublereal dla_syrcond__(char *, integer *, doublereal *, integer *
+ , doublereal *, integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, ftnlen);
+ doublereal cwise_wrong__;
+ extern /* Subroutine */ int dla_syrfsx_extended__(integer *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *, logical *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, logical *, integer *, ftnlen);
+ char norm[1];
+ logical ignore_cwise__;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ logical rcequ;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dsycon_(char *, integer *, doublereal *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *);
+ extern integer ilaprec_(char *);
+ integer ithresh, n_norms__;
+ doublereal rthresh;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYRFSX improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric indefinite, and */
+/* provides error bounds and backward error estimates for the */
+/* solution. In addition to normwise error bound, the code provides */
+/* maximum componentwise error bound if possible. See comments for */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds. */
+
+/* The original system of linear equations may have been equilibrated */
+/* before calling this routine, as described by arguments EQUED and S */
+/* below. In this case, the solution and error bounds returned are */
+/* for the original unequilibrated system. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* EQUED (input) CHARACTER*1 */
+/* Specifies the form of equilibration that was done to A */
+/* before calling this routine. This is needed to compute */
+/* the solution and error bounds correctly. */
+/* = 'N': No equilibration */
+/* = 'Y': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(S) * A * diag(S). */
+/* The right hand side B has been changed accordingly. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular */
+/* part of the matrix A, and the strictly lower triangular */
+/* part of A is not referenced. If UPLO = 'L', the leading */
+/* N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
+/* The factored form of the matrix A. AF contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor U or L from the factorization A = U*D*U**T or A = */
+/* L*D*L**T as computed by DSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by DSYTRF. */
+
+/* S (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The scale factors for A. If EQUED = 'Y', A is multiplied on */
+/* the left and right by diag(S). S is an input argument if FACT = */
+/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
+/* = 'Y', each element of S must be positive. If S is output, each */
+/* element of S is a power of the radix. If S is input, each element */
+/* of S should be a power of the radix to ensure a reliable solution */
+/* and error estimates. Scaling by powers of the radix does not cause */
+/* rounding errors unless the result underflows or overflows. */
+/* Rounding errors during scaling lead to refining with a matrix that */
+/* is not equivalent to the input matrix, producing error estimates */
+/* that may not be reliable. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by DGETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0D+0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check the input parameters. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ ref_type__ = 1;
+ if (*nparams >= 1) {
+ if (params[1] < 0.) {
+ params[1] = 1.;
+ } else {
+ ref_type__ = (integer) params[1];
+ }
+ }
+
+/* Set default parameters. */
+
+ illrcond_thresh__ = (doublereal) (*n) * dlamch_("Epsilon");
+ ithresh = 10;
+ rthresh = .5;
+ unstable_thresh__ = .25;
+ ignore_cwise__ = FALSE_;
+
+ if (*nparams >= 2) {
+ if (params[2] < 0.) {
+ params[2] = (doublereal) ithresh;
+ } else {
+ ithresh = (integer) params[2];
+ }
+ }
+ if (*nparams >= 3) {
+ if (params[3] < 0.) {
+ if (ignore_cwise__) {
+ params[3] = 0.;
+ } else {
+ params[3] = 1.;
+ }
+ } else {
+ ignore_cwise__ = params[3] == 0.;
+ }
+ }
+ if (ref_type__ == 0 || *n_err_bnds__ == 0) {
+ n_norms__ = 0;
+ } else if (ignore_cwise__) {
+ n_norms__ = 1;
+ } else {
+ n_norms__ = 2;
+ }
+
+ rcequ = lsame_(equed, "Y");
+
+/* Test input parameters. */
+
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! rcequ && ! lsame_(equed, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -11;
+ } else if (*ldx < max(1,*n)) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSYRFSX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *nrhs == 0) {
+ *rcond = 1.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 0.;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.;
+ }
+ }
+ return 0;
+ }
+
+/* Default to failure. */
+
+ *rcond = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 1.;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.;
+ }
+ }
+
+/* Compute the norm of A and the reciprocal of the condition */
+/* number of A. */
+
+ *(unsigned char *)norm = 'I';
+ anorm = dlansy_(norm, uplo, n, &a[a_offset], lda, &work[1]);
+ dsycon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1],
+ &iwork[1], info);
+
+/* Perform refinement on each right-hand side */
+
+ if (ref_type__ != 0) {
+ prec_type__ = ilaprec_("E");
+ dla_syrfsx_extended__(&prec_type__, uplo, n, nrhs, &a[a_offset], lda,
+ &af[af_offset], ldaf, &ipiv[1], &rcequ, &s[1], &b[b_offset],
+ ldb, &x[x_offset], ldx, &berr[1], &n_norms__, &
+ err_bnds_norm__[err_bnds_norm_offset], &err_bnds_comp__[
+ err_bnds_comp_offset], &work[*n + 1], &work[1], &work[(*n <<
+ 1) + 1], &work[1], rcond, &ithresh, &rthresh, &
+ unstable_thresh__, &ignore_cwise__, info, (ftnlen)1);
+ }
+/* Computing MAX */
+ d__1 = 10., d__2 = sqrt((doublereal) (*n));
+ err_lbnd__ = max(d__1,d__2) * dlamch_("Epsilon");
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {
+
+/* Compute scaled normwise condition number cond(A*C). */
+
+ if (rcequ) {
+ rcond_tmp__ = dla_syrcond__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &c_n1, &s[1], info, &work[1],
+ &iwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = dla_syrcond__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &c__0, &s[1], info, &work[1],
+ &iwork[1], (ftnlen)1);
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1
+ << 1)] > 1.) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 0.;
+ if (*info <= *n) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {
+
+/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
+/* each right-hand side using the current solution as an estimate of */
+/* the true solution. If the componentwise error estimate is too */
+/* large, then the solution is a lousy estimate of truth and the */
+/* estimated RCOND may be too optimistic. To avoid misleading users, */
+/* the inverse condition number is set to 0.0 when the estimated */
+/* cwise error is at least CWISE_WRONG. */
+
+ cwise_wrong__ = sqrt(dlamch_("Epsilon"));
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ cwise_wrong__) {
+ rcond_tmp__ = dla_syrcond__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &c__1, &x[j * x_dim1 + 1],
+ info, &work[1], &iwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = 0.;
+ }
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1
+ << 1)] > 1.) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 0.;
+ if (params[3] == 1. && *info < *n + j) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DSYRFSX */
+
+} /* dsyrfsx_ */
diff --git a/SRC/dsysv.c b/SRC/dsysv.c
new file mode 100644
index 0000000..e53c638
--- /dev/null
+++ b/SRC/dsysv.c
@@ -0,0 +1,215 @@
+/* dsysv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dsysv_(char *uplo, integer *n, integer *nrhs, doublereal
+ *a, integer *lda, integer *ipiv, doublereal *b, integer *ldb,
+ doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ integer nb;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dsytrf_(char *, integer *, doublereal *,
+ integer *, integer *, doublereal *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int dsytrs_(char *, integer *, integer *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYSV 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 diagonal pivoting method is used to factor A as */
+/* A = U * D * U**T, if UPLO = 'U', or */
+/* A = L * D * L**T, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then */
+/* used to solve the system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the block diagonal matrix D and the */
+/* multipliers used to obtain the factor U or L from the */
+/* factorization A = U*D*U**T or A = L*D*L**T as computed by */
+/* DSYTRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D, as */
+/* determined by DSYTRF. If IPIV(k) > 0, then rows and columns */
+/* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 */
+/* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, */
+/* then rows and columns k-1 and -IPIV(k) were interchanged and */
+/* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and */
+/* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and */
+/* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 */
+/* diagonal block. */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK >= 1, and for best performance */
+/* LWORK >= max(1,N*NB), where NB is the optimal blocksize for */
+/* DSYTRF. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */
+/* has been completed, but the block diagonal matrix D is */
+/* exactly singular, so the solution could not be computed. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*lwork < 1 && ! lquery) {
+ *info = -10;
+ }
+
+ if (*info == 0) {
+ if (*n == 0) {
+ lwkopt = 1;
+ } else {
+ nb = ilaenv_(&c__1, "DSYTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ }
+ work[1] = (doublereal) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSYSV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ dsytrf_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], lwork, info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ dsytrs_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], ldb,
+ info);
+
+ }
+
+ work[1] = (doublereal) lwkopt;
+
+ return 0;
+
+/* End of DSYSV */
+
+} /* dsysv_ */
diff --git a/SRC/dsysvx.c b/SRC/dsysvx.c
new file mode 100644
index 0000000..0877279
--- /dev/null
+++ b/SRC/dsysvx.c
@@ -0,0 +1,370 @@
+/* dsysvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dsysvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
+ integer *ipiv, doublereal *b, integer *ldb, doublereal *x, integer *
+ ldx, doublereal *rcond, doublereal *ferr, doublereal *berr,
+ doublereal *work, integer *lwork, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2;
+
+ /* Local variables */
+ integer nb;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern doublereal dlamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dsycon_(char *, integer *, doublereal *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *), dsyrfs_(char *, integer *, integer
+ *, doublereal *, integer *, doublereal *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *),
+ dsytrf_(char *, integer *, doublereal *, integer *, integer *,
+ doublereal *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int dsytrs_(char *, integer *, integer *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYSVX uses the diagonal pivoting factorization to compute the */
+/* solution to a real system of linear equations A * X = B, */
+/* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */
+/* matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'N', the diagonal pivoting method is used to factor A. */
+/* The form of the factorization is */
+/* A = U * D * U**T, if UPLO = 'U', or */
+/* A = L * D * L**T, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* 2. If some D(i,i)=0, so that D is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 3. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 4. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of A has been */
+/* supplied on entry. */
+/* = 'F': On entry, AF and IPIV contain the factored form of */
+/* A. AF and IPIV will not be modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular part */
+/* of the matrix A, and the strictly lower triangular part of A */
+/* is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of A contains the lower triangular part of */
+/* the matrix A, and the strictly upper triangular part of A is */
+/* not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**T or A = L*D*L**T as computed by DSYTRF. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**T or A = L*D*L**T. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by DSYTRF. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by DSYTRF. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A. If RCOND is less than the machine precision (in */
+/* particular, if RCOND = 0), the matrix is singular to working */
+/* precision. This condition is indicated by a return code of */
+/* INFO > 0. */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK >= max(1,3*N), and for best */
+/* performance, when FACT = 'N', LWORK >= max(1,3*N,N*NB), where */
+/* NB is the optimal blocksize for DSYTRF. */
+
+/* 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. */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: D(i,i) is exactly zero. The factorization */
+/* has been completed but the factor D is exactly */
+/* singular, so the solution and error bounds could */
+/* not be computed. RCOND = 0 is returned. */
+/* = N+1: D is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ lquery = *lwork == -1;
+ if (! nofact && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -11;
+ } else if (*ldx < max(1,*n)) {
+ *info = -13;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * 3;
+ if (*lwork < max(i__1,i__2) && ! lquery) {
+ *info = -18;
+ }
+ }
+
+ if (*info == 0) {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * 3;
+ lwkopt = max(i__1,i__2);
+ if (nofact) {
+ nb = ilaenv_(&c__1, "DSYTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = *n * nb;
+ lwkopt = max(i__1,i__2);
+ }
+ work[1] = (doublereal) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSYSVX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+ if (nofact) {
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ dlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ dsytrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], lwork,
+ info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = dlansy_("I", uplo, n, &a[a_offset], lda, &work[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ dsycon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1],
+ &iwork[1], info);
+
+/* Compute the solution vectors X. */
+
+ dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ dsytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solutions and */
+/* compute error bounds and backward error estimates for them. */
+
+ dsyrfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1],
+ &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1]
+, &iwork[1], info);
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < dlamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ work[1] = (doublereal) lwkopt;
+
+ return 0;
+
+/* End of DSYSVX */
+
+} /* dsysvx_ */
diff --git a/SRC/dsysvxx.c b/SRC/dsysvxx.c
new file mode 100644
index 0000000..abe75da
--- /dev/null
+++ b/SRC/dsysvxx.c
@@ -0,0 +1,631 @@
+/* dsysvxx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dsysvxx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
+ integer *ipiv, char *equed, doublereal *s, doublereal *b, integer *
+ ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *
+ rpvgrw, doublereal *berr, integer *n_err_bnds__, doublereal *
+ err_bnds_norm__, doublereal *err_bnds_comp__, integer *nparams,
+ doublereal *params, doublereal *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ doublereal amax, smin, smax;
+ extern doublereal dla_syrpvgrw__(char *, integer *, integer *, doublereal
+ *, integer *, doublereal *, integer *, integer *, doublereal *,
+ ftnlen);
+ extern logical lsame_(char *, char *);
+ doublereal scond;
+ logical equil, rcequ;
+ extern doublereal dlamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ doublereal bignum;
+ integer infequ;
+ extern /* Subroutine */ int dlaqsy_(char *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, char *);
+ doublereal smlnum;
+ extern /* Subroutine */ int dsytrf_(char *, integer *, doublereal *,
+ integer *, integer *, doublereal *, integer *, integer *),
+ dlascl2_(integer *, integer *, doublereal *, doublereal *,
+ integer *), dsytrs_(char *, integer *, integer *, doublereal *,
+ integer *, integer *, doublereal *, integer *, integer *),
+ dsyequb_(char *, integer *, doublereal *, integer *, doublereal *
+, doublereal *, doublereal *, doublereal *, integer *),
+ dsyrfsx_(char *, char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYSVXX uses the diagonal pivoting factorization to compute the */
+/* solution to a double precision system of linear equations A * X = B, where A */
+/* is an N-by-N symmetric matrix and X and B are N-by-NRHS matrices. */
+
+/* If requested, both normwise and maximum componentwise error bounds */
+/* are returned. DSYSVXX will return a solution with a tiny */
+/* guaranteed error (O(eps) where eps is the working machine */
+/* precision) unless the matrix is very ill-conditioned, in which */
+/* case a warning is returned. Relevant condition numbers also are */
+/* calculated and returned. */
+
+/* DSYSVXX accepts user-provided factorizations and equilibration */
+/* factors; see the definitions of the FACT and EQUED options. */
+/* Solving with refinement and using a factorization from a previous */
+/* DSYSVXX call will also produce a solution with either O(eps) */
+/* errors or warnings, but we cannot make that claim for general */
+/* user-provided factorizations and equilibration factors if they */
+/* differ from what DSYSVXX would itself produce. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate */
+/* the system: */
+
+/* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B */
+
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
+
+/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */
+/* the matrix A (after equilibration if FACT = 'E') as */
+
+/* A = U * D * U**T, if UPLO = 'U', or */
+/* A = L * D * L**T, if UPLO = 'L', */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* 3. If some D(i,i)=0, so that D is exactly singular, then the */
+/* routine returns with INFO = i. Otherwise, the factored form of A */
+/* is used to estimate the condition number of the matrix A (see */
+/* argument RCOND). If the reciprocal of the condition number is */
+/* less than machine precision, the routine still goes on to solve */
+/* for X and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */
+/* the routine will use iterative refinement to try to get a small */
+/* error and error bounds. Refinement calculates the residual to at */
+/* least twice the working precision. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(R) so that it solves the original system before */
+/* equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF and IPIV contain the factored form of A. */
+/* If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by S. */
+/* A, AF, and IPIV are not modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular */
+/* part of the matrix A, and the strictly lower triangular */
+/* part of A is not referenced. If UPLO = 'L', the leading */
+/* N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
+/* diag(S)*A*diag(S). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L from the factorization A = */
+/* U*D*U**T or A = L*D*L**T as computed by DSYTRF. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L from the factorization A = */
+/* U*D*U**T or A = L*D*L**T. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains details of the interchanges and the block */
+/* structure of D, as determined by DSYTRF. If IPIV(k) > 0, */
+/* then rows and columns k and IPIV(k) were interchanged and */
+/* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and */
+/* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and */
+/* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 */
+/* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0, */
+/* then rows and columns k+1 and -IPIV(k) were interchanged */
+/* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains details of the interchanges and the block */
+/* structure of D, as determined by DSYTRF. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'Y': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(S) * A * diag(S). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* S (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The scale factors for A. If EQUED = 'Y', A is multiplied on */
+/* the left and right by diag(S). S is an input argument if FACT = */
+/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
+/* = 'Y', each element of S must be positive. If S is output, each */
+/* element of S is a power of the radix. If S is input, each element */
+/* of S should be a power of the radix to ensure a reliable solution */
+/* and error estimates. Scaling by powers of the radix does not cause */
+/* rounding errors unless the result underflows or overflows. */
+/* Rounding errors during scaling lead to refining with a matrix that */
+/* is not equivalent to the input matrix, producing error estimates */
+/* that may not be reliable. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if EQUED = 'Y', B is overwritten by diag(S)*B; */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* If INFO = 0, the N-by-NRHS solution matrix X to the original */
+/* system of equations. Note that A and B are modified on exit if */
+/* EQUED .ne. 'N', and the solution to the equilibrated system is */
+/* inv(diag(S))*X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* RPVGRW (output) DOUBLE PRECISION */
+/* Reciprocal pivot growth. On exit, this contains the reciprocal */
+/* pivot growth factor norm(A)/norm(U). The "max absolute element" */
+/* norm is used. If this is much less than 1, then the stability of */
+/* the LU factorization of the (equilibrated) matrix A could be poor. */
+/* This also means that the solution X, estimated condition numbers, */
+/* and error bounds could be unreliable. If factorization fails with */
+/* 0<INFO<=N, then this contains the reciprocal pivot growth factor */
+/* for the leading INFO columns of A. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0D+0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the extra-precise refinement algorithm. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rcequ = FALSE_;
+ } else {
+ rcequ = lsame_(equed, "Y");
+ }
+
+/* Default is failure. If an input parameter is wrong or */
+/* factorization fails, make everything look horrible. Only the */
+/* pivot growth is set here, the rest is initialized in DSYRFSX. */
+
+ *rpvgrw = 0.;
+
+/* Test the input parameters. PARAMS is not tested until DSYRFSX. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (lsame_(fact, "F") && ! (rcequ || lsame_(
+ equed, "N"))) {
+ *info = -9;
+ } else {
+ if (rcequ) {
+ smin = bignum;
+ smax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = smin, d__2 = s[j];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = smax, d__2 = s[j];
+ smax = max(d__1,d__2);
+/* L10: */
+ }
+ if (smin <= 0.) {
+ *info = -10;
+ } else if (*n > 0) {
+ scond = max(smin,smlnum) / min(smax,bignum);
+ } else {
+ scond = 1.;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -12;
+ } else if (*ldx < max(1,*n)) {
+ *info = -14;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSYSVXX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ dsyequb_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, &work[1], &
+ infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ dlaqsy_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed);
+ rcequ = lsame_(equed, "Y");
+ }
+ }
+
+/* Scale the right-hand side. */
+
+ if (rcequ) {
+ dlascl2_(n, nrhs, &s[1], &b[b_offset], ldb);
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of A. */
+
+ dlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ i__1 = max(1,*n) * 5;
+ dsytrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], &i__1,
+ info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Pivot in column INFO is exactly 0 */
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ if (*n > 0) {
+ *rpvgrw = dla_syrpvgrw__(uplo, n, info, &a[a_offset], lda, &
+ af[af_offset], ldaf, &ipiv[1], &work[1], (ftnlen)1);
+ }
+ return 0;
+ }
+ }
+
+/* Compute the reciprocal pivot growth factor RPVGRW. */
+
+ if (*n > 0) {
+ *rpvgrw = dla_syrpvgrw__(uplo, n, info, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &work[1], (ftnlen)1);
+ }
+
+/* Compute the solution matrix X. */
+
+ dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ dsytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ dsyrfsx_(uplo, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &
+ ipiv[1], &s[1], &b[b_offset], ldb, &x[x_offset], ldx, rcond, &
+ berr[1], n_err_bnds__, &err_bnds_norm__[err_bnds_norm_offset], &
+ err_bnds_comp__[err_bnds_comp_offset], nparams, ¶ms[1], &work[
+ 1], &iwork[1], info);
+
+/* Scale solutions. */
+
+ if (rcequ) {
+ dlascl2_(n, nrhs, &s[1], &x[x_offset], ldx);
+ }
+
+ return 0;
+
+/* End of DSYSVXX */
+
+} /* dsysvxx_ */
diff --git a/SRC/dsytd2.c b/SRC/dsytd2.c
new file mode 100644
index 0000000..2f98901
--- /dev/null
+++ b/SRC/dsytd2.c
@@ -0,0 +1,306 @@
+/* dsytd2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b8 = 0.;
+static doublereal c_b14 = -1.;
+
+/* Subroutine */ int dsytd2_(char *uplo, integer *n, doublereal *a, integer *
+ lda, doublereal *d__, doublereal *e, doublereal *tau, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal taui;
+ extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal alpha;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *), dlarfg_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *), xerbla_(char *, integer *
+);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal */
+/* form T by an orthogonal similarity transformation: Q' * A * Q = T. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n-by-n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n-by-n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+/* On exit, if UPLO = 'U', the diagonal and first superdiagonal */
+/* of A are overwritten by the corresponding elements of the */
+/* tridiagonal matrix T, and the elements above the first */
+/* superdiagonal, with the array TAU, represent the orthogonal */
+/* matrix Q as a product of elementary reflectors; if UPLO */
+/* = 'L', the diagonal and first subdiagonal of A are over- */
+/* written by the corresponding elements of the tridiagonal */
+/* matrix T, and the elements below the first subdiagonal, with */
+/* the array TAU, represent the orthogonal matrix Q as a product */
+/* of elementary reflectors. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* D (output) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal elements of the tridiagonal matrix T: */
+/* D(i) = A(i,i). */
+
+/* E (output) DOUBLE PRECISION array, dimension (N-1) */
+/* The off-diagonal elements of the tridiagonal matrix T: */
+/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(n-1) . . . H(2) H(1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */
+/* A(1:i-1,i+1), and tau in TAU(i). */
+
+/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(1) H(2) . . . H(n-1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */
+/* and tau in TAU(i). */
+
+/* The contents of A on exit are illustrated by the following examples */
+/* with n = 5: */
+
+/* if UPLO = 'U': if UPLO = 'L': */
+
+/* ( d e v2 v3 v4 ) ( d ) */
+/* ( d e v3 v4 ) ( e d ) */
+/* ( d e v4 ) ( v1 e d ) */
+/* ( d e ) ( v1 v2 e d ) */
+/* ( d ) ( v1 v2 v3 e d ) */
+
+/* where d and e denote diagonal and off-diagonal elements of T, and vi */
+/* denotes an element of the vector defining H(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ --tau;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSYTD2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Reduce the upper triangle of A */
+
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+
+/* Generate elementary reflector H(i) = I - tau * v * v' */
+/* to annihilate A(1:i-1,i+1) */
+
+ dlarfg_(&i__, &a[i__ + (i__ + 1) * a_dim1], &a[(i__ + 1) * a_dim1
+ + 1], &c__1, &taui);
+ e[i__] = a[i__ + (i__ + 1) * a_dim1];
+
+ if (taui != 0.) {
+
+/* Apply H(i) from both sides to A(1:i,1:i) */
+
+ a[i__ + (i__ + 1) * a_dim1] = 1.;
+
+/* Compute x := tau * A * v storing x in TAU(1:i) */
+
+ dsymv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) *
+ a_dim1 + 1], &c__1, &c_b8, &tau[1], &c__1);
+
+/* Compute w := x - 1/2 * tau * (x'*v) * v */
+
+ alpha = taui * -.5 * ddot_(&i__, &tau[1], &c__1, &a[(i__ + 1)
+ * a_dim1 + 1], &c__1);
+ daxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[
+ 1], &c__1);
+
+/* Apply the transformation as a rank-2 update: */
+/* A := A - v * w' - w * v' */
+
+ dsyr2_(uplo, &i__, &c_b14, &a[(i__ + 1) * a_dim1 + 1], &c__1,
+ &tau[1], &c__1, &a[a_offset], lda);
+
+ a[i__ + (i__ + 1) * a_dim1] = e[i__];
+ }
+ d__[i__ + 1] = a[i__ + 1 + (i__ + 1) * a_dim1];
+ tau[i__] = taui;
+/* L10: */
+ }
+ d__[1] = a[a_dim1 + 1];
+ } else {
+
+/* Reduce the lower triangle of A */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Generate elementary reflector H(i) = I - tau * v * v' */
+/* to annihilate A(i+2:n,i) */
+
+ i__2 = *n - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ dlarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *n)+ i__ *
+ a_dim1], &c__1, &taui);
+ e[i__] = a[i__ + 1 + i__ * a_dim1];
+
+ if (taui != 0.) {
+
+/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
+
+ a[i__ + 1 + i__ * a_dim1] = 1.;
+
+/* Compute x := tau * A * v storing y in TAU(i:n-1) */
+
+ i__2 = *n - i__;
+ dsymv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1],
+ lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b8, &tau[
+ i__], &c__1);
+
+/* Compute w := x - 1/2 * tau * (x'*v) * v */
+
+ i__2 = *n - i__;
+ alpha = taui * -.5 * ddot_(&i__2, &tau[i__], &c__1, &a[i__ +
+ 1 + i__ * a_dim1], &c__1);
+ i__2 = *n - i__;
+ daxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
+ i__], &c__1);
+
+/* Apply the transformation as a rank-2 update: */
+/* A := A - v * w' - w * v' */
+
+ i__2 = *n - i__;
+ dsyr2_(uplo, &i__2, &c_b14, &a[i__ + 1 + i__ * a_dim1], &c__1,
+ &tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1],
+ lda);
+
+ a[i__ + 1 + i__ * a_dim1] = e[i__];
+ }
+ d__[i__] = a[i__ + i__ * a_dim1];
+ tau[i__] = taui;
+/* L20: */
+ }
+ d__[*n] = a[*n + *n * a_dim1];
+ }
+
+ return 0;
+
+/* End of DSYTD2 */
+
+} /* dsytd2_ */
diff --git a/SRC/dsytf2.c b/SRC/dsytf2.c
new file mode 100644
index 0000000..11d3947
--- /dev/null
+++ b/SRC/dsytf2.c
@@ -0,0 +1,608 @@
+/* dsytf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dsytf2_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal t, r1, d11, d12, d21, d22;
+ integer kk, kp;
+ doublereal wk, wkm1, wkp1;
+ integer imax, jmax;
+ extern /* Subroutine */ int dsyr_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *);
+ doublereal alpha;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer kstep;
+ logical upper;
+ doublereal absakk;
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern logical disnan_(doublereal *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal colmax, rowmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYTF2 computes the factorization of a real symmetric matrix A using */
+/* the Bunch-Kaufman diagonal pivoting method: */
+
+/* A = U*D*U' or A = L*D*L' */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, U' is the transpose of U, 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. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n-by-n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n-by-n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L (see below for further details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, D(k,k) is exactly zero. 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. */
+
+/* Further Details */
+/* =============== */
+
+/* 09-29-06 - patch from */
+/* Bobby Cheng, MathWorks */
+
+/* Replace l.204 and l.372 */
+/* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN */
+/* by */
+/* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN */
+
+/* 01-01-96 - Based on modifications by */
+/* J. Lewis, Boeing Computer Services Company */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+/* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services */
+/* Company */
+
+/* If UPLO = 'U', then A = U*D*U', where */
+/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
+/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
+/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I v 0 ) k-s */
+/* U(k) = ( 0 I 0 ) s */
+/* ( 0 0 I ) n-k */
+/* k-s s n-k */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
+/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
+/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
+
+/* If UPLO = 'L', then A = L*D*L', where */
+/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
+/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
+/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I 0 0 ) k-1 */
+/* L(k) = ( 0 I 0 ) s */
+/* ( 0 v I ) n-k-s+1 */
+/* k-1 s n-k-s+1 */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
+/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
+/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSYTF2", &i__1);
+ return 0;
+ }
+
+/* Initialize ALPHA for use in choosing pivot block size. */
+
+ alpha = (sqrt(17.) + 1.) / 8.;
+
+ if (upper) {
+
+/* Factorize A as U*D*U' using the upper triangle of A */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2 */
+
+ k = *n;
+L10:
+
+/* If K < 1, exit from loop */
+
+ if (k < 1) {
+ goto L70;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ absakk = (d__1 = a[k + k * a_dim1], abs(d__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ imax = idamax_(&i__1, &a[k * a_dim1 + 1], &c__1);
+ colmax = (d__1 = a[imax + k * a_dim1], abs(d__1));
+ } else {
+ colmax = 0.;
+ }
+
+ if (max(absakk,colmax) == 0. || disnan_(&absakk)) {
+
+/* Column K is zero or contains a NaN: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = k - imax;
+ jmax = imax + idamax_(&i__1, &a[imax + (imax + 1) * a_dim1],
+ lda);
+ rowmax = (d__1 = a[imax + jmax * a_dim1], abs(d__1));
+ if (imax > 1) {
+ i__1 = imax - 1;
+ jmax = idamax_(&i__1, &a[imax * a_dim1 + 1], &c__1);
+/* Computing MAX */
+ d__2 = rowmax, d__3 = (d__1 = a[jmax + imax * a_dim1],
+ abs(d__1));
+ rowmax = max(d__2,d__3);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else if ((d__1 = a[imax + imax * a_dim1], abs(d__1)) >=
+ alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+
+ kk = k - kstep + 1;
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the leading */
+/* submatrix A(1:k,1:k) */
+
+ i__1 = kp - 1;
+ dswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1],
+ &c__1);
+ i__1 = kk - kp - 1;
+ dswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp +
+ 1) * a_dim1], lda);
+ t = a[kk + kk * a_dim1];
+ a[kk + kk * a_dim1] = a[kp + kp * a_dim1];
+ a[kp + kp * a_dim1] = t;
+ if (kstep == 2) {
+ t = a[k - 1 + k * a_dim1];
+ a[k - 1 + k * a_dim1] = a[kp + k * a_dim1];
+ a[kp + k * a_dim1] = t;
+ }
+ }
+
+/* Update the leading submatrix */
+
+ if (kstep == 1) {
+
+/* 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 */
+
+/* Perform a rank-1 update of A(1:k-1,1:k-1) as */
+
+/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */
+
+ r1 = 1. / a[k + k * a_dim1];
+ i__1 = k - 1;
+ d__1 = -r1;
+ dsyr_(uplo, &i__1, &d__1, &a[k * a_dim1 + 1], &c__1, &a[
+ a_offset], lda);
+
+/* Store U(k) in column k */
+
+ i__1 = k - 1;
+ dscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
+ } 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) )' */
+/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */
+
+ if (k > 2) {
+
+ d12 = a[k - 1 + k * a_dim1];
+ d22 = a[k - 1 + (k - 1) * a_dim1] / d12;
+ d11 = a[k + k * a_dim1] / d12;
+ t = 1. / (d11 * d22 - 1.);
+ d12 = t / d12;
+
+ for (j = k - 2; j >= 1; --j) {
+ wkm1 = d12 * (d11 * a[j + (k - 1) * a_dim1] - a[j + k
+ * a_dim1]);
+ wk = d12 * (d22 * a[j + k * a_dim1] - a[j + (k - 1) *
+ a_dim1]);
+ for (i__ = j; i__ >= 1; --i__) {
+ a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__
+ + k * a_dim1] * wk - a[i__ + (k - 1) *
+ a_dim1] * wkm1;
+/* L20: */
+ }
+ a[j + k * a_dim1] = wk;
+ a[j + (k - 1) * a_dim1] = wkm1;
+/* L30: */
+ }
+
+ }
+
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k - 1] = -kp;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kstep;
+ goto L10;
+
+ } else {
+
+/* Factorize A as L*D*L' using the lower triangle of A */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2 */
+
+ k = 1;
+L40:
+
+/* If K > N, exit from loop */
+
+ if (k > *n) {
+ goto L70;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ absakk = (d__1 = a[k + k * a_dim1], abs(d__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ imax = k + idamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1);
+ colmax = (d__1 = a[imax + k * a_dim1], abs(d__1));
+ } else {
+ colmax = 0.;
+ }
+
+ if (max(absakk,colmax) == 0. || disnan_(&absakk)) {
+
+/* Column K is zero or contains a NaN: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = imax - k;
+ jmax = k - 1 + idamax_(&i__1, &a[imax + k * a_dim1], lda);
+ rowmax = (d__1 = a[imax + jmax * a_dim1], abs(d__1));
+ if (imax < *n) {
+ i__1 = *n - imax;
+ jmax = imax + idamax_(&i__1, &a[imax + 1 + imax * a_dim1],
+ &c__1);
+/* Computing MAX */
+ d__2 = rowmax, d__3 = (d__1 = a[jmax + imax * a_dim1],
+ abs(d__1));
+ rowmax = max(d__2,d__3);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else if ((d__1 = a[imax + imax * a_dim1], abs(d__1)) >=
+ alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+
+ kk = k + kstep - 1;
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the trailing */
+/* submatrix A(k:n,k:n) */
+
+ if (kp < *n) {
+ i__1 = *n - kp;
+ dswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1
+ + kp * a_dim1], &c__1);
+ }
+ i__1 = kp - kk - 1;
+ dswap_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk +
+ 1) * a_dim1], lda);
+ t = a[kk + kk * a_dim1];
+ a[kk + kk * a_dim1] = a[kp + kp * a_dim1];
+ a[kp + kp * a_dim1] = t;
+ if (kstep == 2) {
+ t = a[k + 1 + k * a_dim1];
+ a[k + 1 + k * a_dim1] = a[kp + k * a_dim1];
+ a[kp + k * a_dim1] = t;
+ }
+ }
+
+/* Update the trailing submatrix */
+
+ if (kstep == 1) {
+
+/* 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 < *n) {
+
+/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
+
+/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */
+
+ d11 = 1. / a[k + k * a_dim1];
+ i__1 = *n - k;
+ d__1 = -d11;
+ dsyr_(uplo, &i__1, &d__1, &a[k + 1 + k * a_dim1], &c__1, &
+ a[k + 1 + (k + 1) * a_dim1], lda);
+
+/* Store L(k) in column K */
+
+ i__1 = *n - k;
+ dscal_(&i__1, &d11, &a[k + 1 + k * a_dim1], &c__1);
+ }
+ } else {
+
+/* 2-by-2 pivot block D(k) */
+
+ if (k < *n - 1) {
+
+/* Perform a rank-2 update of A(k+2:n,k+2:n) as */
+
+/* A := A - ( (A(k) A(k+1))*D(k)**(-1) ) * (A(k) A(k+1))' */
+
+/* where L(k) and L(k+1) are the k-th and (k+1)-th */
+/* columns of L */
+
+ d21 = a[k + 1 + k * a_dim1];
+ d11 = a[k + 1 + (k + 1) * a_dim1] / d21;
+ d22 = a[k + k * a_dim1] / d21;
+ t = 1. / (d11 * d22 - 1.);
+ d21 = t / d21;
+
+ i__1 = *n;
+ for (j = k + 2; j <= i__1; ++j) {
+
+ wk = d21 * (d11 * a[j + k * a_dim1] - a[j + (k + 1) *
+ a_dim1]);
+ wkp1 = d21 * (d22 * a[j + (k + 1) * a_dim1] - a[j + k
+ * a_dim1]);
+
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__
+ + k * a_dim1] * wk - a[i__ + (k + 1) *
+ a_dim1] * wkp1;
+/* L50: */
+ }
+
+ a[j + k * a_dim1] = wk;
+ a[j + (k + 1) * a_dim1] = wkp1;
+
+/* L60: */
+ }
+ }
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k + 1] = -kp;
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kstep;
+ goto L40;
+
+ }
+
+L70:
+
+ return 0;
+
+/* End of DSYTF2 */
+
+} /* dsytf2_ */
diff --git a/SRC/dsytrd.c b/SRC/dsytrd.c
new file mode 100644
index 0000000..f0f9ded
--- /dev/null
+++ b/SRC/dsytrd.c
@@ -0,0 +1,360 @@
+/* dsytrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+static doublereal c_b22 = -1.;
+static doublereal c_b23 = 1.;
+
+/* Subroutine */ int dsytrd_(char *uplo, integer *n, doublereal *a, integer *
+ lda, doublereal *d__, doublereal *e, doublereal *tau, doublereal *
+ work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, nb, kk, nx, iws;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ logical upper;
+ extern /* Subroutine */ int dsytd2_(char *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *), dsyr2k_(char *, char *, integer *, integer *, doublereal
+ *, doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *), dlatrd_(char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *), xerbla_(char *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYTRD reduces a real symmetric matrix A to real symmetric */
+/* tridiagonal form T by an orthogonal similarity transformation: */
+/* Q**T * A * Q = T. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (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 UPLO = 'U', the diagonal and first superdiagonal */
+/* of A are overwritten by the corresponding elements of the */
+/* tridiagonal matrix T, and the elements above the first */
+/* superdiagonal, with the array TAU, represent the orthogonal */
+/* matrix Q as a product of elementary reflectors; if UPLO */
+/* = 'L', the diagonal and first subdiagonal of A are over- */
+/* written by the corresponding elements of the tridiagonal */
+/* matrix T, and the elements below the first subdiagonal, with */
+/* the array TAU, represent the orthogonal matrix Q as a product */
+/* of elementary reflectors. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* D (output) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal elements of the tridiagonal matrix T: */
+/* D(i) = A(i,i). */
+
+/* E (output) DOUBLE PRECISION array, dimension (N-1) */
+/* The off-diagonal elements of the tridiagonal matrix T: */
+/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= 1. */
+/* For optimum performance LWORK >= N*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(n-1) . . . H(2) H(1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */
+/* A(1:i-1,i+1), and tau in TAU(i). */
+
+/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(1) H(2) . . . H(n-1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */
+/* and tau in TAU(i). */
+
+/* The contents of A on exit are illustrated by the following examples */
+/* with n = 5: */
+
+/* if UPLO = 'U': if UPLO = 'L': */
+
+/* ( d e v2 v3 v4 ) ( d ) */
+/* ( d e v3 v4 ) ( e d ) */
+/* ( d e v4 ) ( v1 e d ) */
+/* ( d e ) ( v1 v2 e d ) */
+/* ( d ) ( v1 v2 v3 e d ) */
+
+/* where d and e denote diagonal and off-diagonal elements of T, and vi */
+/* denotes an element of the vector defining H(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1;
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*lwork < 1 && ! lquery) {
+ *info = -9;
+ }
+
+ if (*info == 0) {
+
+/* Determine the block size. */
+
+ nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ work[1] = (doublereal) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSYTRD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ work[1] = 1.;
+ return 0;
+ }
+
+ nx = *n;
+ iws = 1;
+ if (nb > 1 && nb < *n) {
+
+/* Determine when to cross over from blocked to unblocked code */
+/* (last block is always handled by unblocked code). */
+
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__3, "DSYTRD", uplo, n, &c_n1, &c_n1, &
+ c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *n) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *n;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: determine the */
+/* minimum value of NB, and reduce NB or force use of */
+/* unblocked code by setting NX = N. */
+
+/* Computing MAX */
+ i__1 = *lwork / ldwork;
+ nb = max(i__1,1);
+ nbmin = ilaenv_(&c__2, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
+ if (nb < nbmin) {
+ nx = *n;
+ }
+ }
+ } else {
+ nx = *n;
+ }
+ } else {
+ nb = 1;
+ }
+
+ if (upper) {
+
+/* Reduce the upper triangle of A. */
+/* Columns 1:kk are handled by the unblocked method. */
+
+ kk = *n - (*n - nx + nb - 1) / nb * nb;
+ i__1 = kk + 1;
+ i__2 = -nb;
+ for (i__ = *n - nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+
+/* Reduce columns i:i+nb-1 to tridiagonal form and form the */
+/* matrix W which is needed to update the unreduced part of */
+/* the matrix */
+
+ i__3 = i__ + nb - 1;
+ dlatrd_(uplo, &i__3, &nb, &a[a_offset], lda, &e[1], &tau[1], &
+ work[1], &ldwork);
+
+/* Update the unreduced submatrix A(1:i-1,1:i-1), using an */
+/* update of the form: A := A - V*W' - W*V' */
+
+ i__3 = i__ - 1;
+ dsyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a[i__ * a_dim1
+ + 1], lda, &work[1], &ldwork, &c_b23, &a[a_offset], lda);
+
+/* Copy superdiagonal elements back into A, and diagonal */
+/* elements into D */
+
+ i__3 = i__ + nb - 1;
+ for (j = i__; j <= i__3; ++j) {
+ a[j - 1 + j * a_dim1] = e[j - 1];
+ d__[j] = a[j + j * a_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Use unblocked code to reduce the last or only block */
+
+ dsytd2_(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo);
+ } else {
+
+/* Reduce the lower triangle of A */
+
+ i__2 = *n - nx;
+ i__1 = nb;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
+
+/* Reduce columns i:i+nb-1 to tridiagonal form and form the */
+/* matrix W which is needed to update the unreduced part of */
+/* the matrix */
+
+ i__3 = *n - i__ + 1;
+ dlatrd_(uplo, &i__3, &nb, &a[i__ + i__ * a_dim1], lda, &e[i__], &
+ tau[i__], &work[1], &ldwork);
+
+/* Update the unreduced submatrix A(i+ib:n,i+ib:n), using */
+/* an update of the form: A := A - V*W' - W*V' */
+
+ i__3 = *n - i__ - nb + 1;
+ dsyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a[i__ + nb +
+ i__ * a_dim1], lda, &work[nb + 1], &ldwork, &c_b23, &a[
+ i__ + nb + (i__ + nb) * a_dim1], lda);
+
+/* Copy subdiagonal elements back into A, and diagonal */
+/* elements into D */
+
+ i__3 = i__ + nb - 1;
+ for (j = i__; j <= i__3; ++j) {
+ a[j + 1 + j * a_dim1] = e[j];
+ d__[j] = a[j + j * a_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Use unblocked code to reduce the last or only block */
+
+ i__1 = *n - i__ + 1;
+ dsytd2_(uplo, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__],
+ &tau[i__], &iinfo);
+ }
+
+ work[1] = (doublereal) lwkopt;
+ return 0;
+
+/* End of DSYTRD */
+
+} /* dsytrd_ */
diff --git a/SRC/dsytrf.c b/SRC/dsytrf.c
new file mode 100644
index 0000000..8492793
--- /dev/null
+++ b/SRC/dsytrf.c
@@ -0,0 +1,341 @@
+/* dsytrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int dsytrf_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *ipiv, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer j, k, kb, nb, iws;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ logical upper;
+ extern /* Subroutine */ int dsytf2_(char *, integer *, doublereal *,
+ integer *, integer *, integer *), xerbla_(char *, integer
+ *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dlasyf_(char *, integer *, integer *, integer
+ *, doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYTRF computes the factorization of a real symmetric matrix A using */
+/* the Bunch-Kaufman diagonal pivoting method. The form of the */
+/* factorization is */
+
+/* A = U*D*U**T or A = L*D*L**T */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* This is the blocked version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (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, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L (see below for further details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. 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. */
+
+/* Further Details */
+/* =============== */
+
+/* If UPLO = 'U', then A = U*D*U', where */
+/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
+/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
+/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I v 0 ) k-s */
+/* U(k) = ( 0 I 0 ) s */
+/* ( 0 0 I ) n-k */
+/* k-s s n-k */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
+/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
+/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
+
+/* If UPLO = 'L', then A = L*D*L', where */
+/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
+/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
+/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I 0 0 ) k-1 */
+/* L(k) = ( 0 I 0 ) s */
+/* ( 0 v I ) n-k-s+1 */
+/* k-1 s n-k-s+1 */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
+/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
+/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1;
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*lwork < 1 && ! lquery) {
+ *info = -7;
+ }
+
+ if (*info == 0) {
+
+/* Determine the block size */
+
+ nb = ilaenv_(&c__1, "DSYTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ work[1] = (doublereal) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSYTRF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = *n;
+ if (nb > 1 && nb < *n) {
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+/* Computing MAX */
+ i__1 = *lwork / ldwork;
+ nb = max(i__1,1);
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "DSYTRF", uplo, n, &c_n1, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = 1;
+ }
+ if (nb < nbmin) {
+ nb = *n;
+ }
+
+ if (upper) {
+
+/* Factorize A as U*D*U' 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; */
+/* KB is either NB or NB-1, or K for the last block */
+
+ k = *n;
+L10:
+
+/* If K < 1, exit from loop */
+
+ if (k < 1) {
+ goto L40;
+ }
+
+ if (k > nb) {
+
+/* Factorize columns k-kb+1:k of A and use blocked code to */
+/* update columns 1:k-kb */
+
+ dlasyf_(uplo, &k, &nb, &kb, &a[a_offset], lda, &ipiv[1], &work[1],
+ &ldwork, &iinfo);
+ } else {
+
+/* Use unblocked code to factorize columns 1:k of A */
+
+ dsytf2_(uplo, &k, &a[a_offset], lda, &ipiv[1], &iinfo);
+ kb = k;
+ }
+
+/* Set INFO on the first occurrence of a zero pivot */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kb;
+ goto L10;
+
+ } else {
+
+/* Factorize A as L*D*L' 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; */
+/* KB is either NB or NB-1, or N-K+1 for the last block */
+
+ k = 1;
+L20:
+
+/* If K > N, exit from loop */
+
+ if (k > *n) {
+ goto L40;
+ }
+
+ if (k <= *n - nb) {
+
+/* Factorize columns k:k+kb-1 of A and use blocked code to */
+/* update columns k+kb:n */
+
+ i__1 = *n - k + 1;
+ dlasyf_(uplo, &i__1, &nb, &kb, &a[k + k * a_dim1], lda, &ipiv[k],
+ &work[1], &ldwork, &iinfo);
+ } else {
+
+/* Use unblocked code to factorize columns k:n of A */
+
+ i__1 = *n - k + 1;
+ dsytf2_(uplo, &i__1, &a[k + k * a_dim1], lda, &ipiv[k], &iinfo);
+ kb = *n - k + 1;
+ }
+
+/* Set INFO on the first occurrence of a zero pivot */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo + k - 1;
+ }
+
+/* Adjust IPIV */
+
+ i__1 = k + kb - 1;
+ for (j = k; j <= i__1; ++j) {
+ if (ipiv[j] > 0) {
+ ipiv[j] = ipiv[j] + k - 1;
+ } else {
+ ipiv[j] = ipiv[j] - k + 1;
+ }
+/* L30: */
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kb;
+ goto L20;
+
+ }
+
+L40:
+ work[1] = (doublereal) lwkopt;
+ return 0;
+
+/* End of DSYTRF */
+
+} /* dsytrf_ */
diff --git a/SRC/dsytri.c b/SRC/dsytri.c
new file mode 100644
index 0000000..3ed3d7c
--- /dev/null
+++ b/SRC/dsytri.c
@@ -0,0 +1,396 @@
+/* dsytri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b11 = -1.;
+static doublereal c_b13 = 0.;
+
+/* Subroutine */ int dsytri_(char *uplo, integer *n, doublereal *a, integer *
+ lda, integer *ipiv, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ doublereal d__1;
+
+ /* Local variables */
+ doublereal d__;
+ integer k;
+ doublereal t, ak;
+ integer kp;
+ doublereal akp1;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal temp, akkp1;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dswap_(integer *, doublereal *, integer
+ *, doublereal *, integer *);
+ integer kstep;
+ logical upper;
+ extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYTRI computes the inverse of a real symmetric indefinite matrix */
+/* A using the factorization A = U*D*U**T or A = L*D*L**T computed by */
+/* DSYTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L as computed by DSYTRF. */
+
+/* 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. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by DSYTRF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) 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. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSYTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ for (*info = *n; *info >= 1; --(*info)) {
+ if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.) {
+ return 0;
+ }
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.) {
+ return 0;
+ }
+/* L20: */
+ }
+ }
+ *info = 0;
+
+ if (upper) {
+
+/* Compute inv(A) from the factorization A = U*D*U'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+L30:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L40;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ a[k + k * a_dim1] = 1. / a[k + k * a_dim1];
+
+/* Compute column K of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
+ c__1, &c_b13, &a[k * a_dim1 + 1], &c__1);
+ i__1 = k - 1;
+ a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k *
+ a_dim1 + 1], &c__1);
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ t = (d__1 = a[k + (k + 1) * a_dim1], abs(d__1));
+ ak = a[k + k * a_dim1] / t;
+ akp1 = a[k + 1 + (k + 1) * a_dim1] / t;
+ akkp1 = a[k + (k + 1) * a_dim1] / t;
+ d__ = t * (ak * akp1 - 1.);
+ a[k + k * a_dim1] = akp1 / d__;
+ a[k + 1 + (k + 1) * a_dim1] = ak / d__;
+ a[k + (k + 1) * a_dim1] = -akkp1 / d__;
+
+/* Compute columns K and K+1 of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
+ c__1, &c_b13, &a[k * a_dim1 + 1], &c__1);
+ i__1 = k - 1;
+ a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k *
+ a_dim1 + 1], &c__1);
+ i__1 = k - 1;
+ a[k + (k + 1) * a_dim1] -= ddot_(&i__1, &a[k * a_dim1 + 1], &
+ c__1, &a[(k + 1) * a_dim1 + 1], &c__1);
+ i__1 = k - 1;
+ dcopy_(&i__1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], &
+ c__1);
+ i__1 = k - 1;
+ dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
+ c__1, &c_b13, &a[(k + 1) * a_dim1 + 1], &c__1);
+ i__1 = k - 1;
+ a[k + 1 + (k + 1) * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &
+ a[(k + 1) * a_dim1 + 1], &c__1);
+ }
+ kstep = 2;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the leading */
+/* submatrix A(1:k+1,1:k+1) */
+
+ i__1 = kp - 1;
+ dswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &
+ c__1);
+ i__1 = k - kp - 1;
+ dswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1) *
+ a_dim1], lda);
+ temp = a[k + k * a_dim1];
+ a[k + k * a_dim1] = a[kp + kp * a_dim1];
+ a[kp + kp * a_dim1] = temp;
+ if (kstep == 2) {
+ temp = a[k + (k + 1) * a_dim1];
+ a[k + (k + 1) * a_dim1] = a[kp + (k + 1) * a_dim1];
+ a[kp + (k + 1) * a_dim1] = temp;
+ }
+ }
+
+ k += kstep;
+ goto L30;
+L40:
+
+ ;
+ } else {
+
+/* Compute inv(A) from the factorization A = L*D*L'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+L50:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L60;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ a[k + k * a_dim1] = 1. / a[k + k * a_dim1];
+
+/* Compute column K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ dcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda,
+ &work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], &
+ c__1);
+ i__1 = *n - k;
+ a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k + 1 +
+ k * a_dim1], &c__1);
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ t = (d__1 = a[k + (k - 1) * a_dim1], abs(d__1));
+ ak = a[k - 1 + (k - 1) * a_dim1] / t;
+ akp1 = a[k + k * a_dim1] / t;
+ akkp1 = a[k + (k - 1) * a_dim1] / t;
+ d__ = t * (ak * akp1 - 1.);
+ a[k - 1 + (k - 1) * a_dim1] = akp1 / d__;
+ a[k + k * a_dim1] = ak / d__;
+ a[k + (k - 1) * a_dim1] = -akkp1 / d__;
+
+/* Compute columns K-1 and K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ dcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda,
+ &work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], &
+ c__1);
+ i__1 = *n - k;
+ a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k + 1 +
+ k * a_dim1], &c__1);
+ i__1 = *n - k;
+ a[k + (k - 1) * a_dim1] -= ddot_(&i__1, &a[k + 1 + k * a_dim1]
+, &c__1, &a[k + 1 + (k - 1) * a_dim1], &c__1);
+ i__1 = *n - k;
+ dcopy_(&i__1, &a[k + 1 + (k - 1) * a_dim1], &c__1, &work[1], &
+ c__1);
+ i__1 = *n - k;
+ dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda,
+ &work[1], &c__1, &c_b13, &a[k + 1 + (k - 1) * a_dim1]
+, &c__1);
+ i__1 = *n - k;
+ a[k - 1 + (k - 1) * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &
+ a[k + 1 + (k - 1) * a_dim1], &c__1);
+ }
+ kstep = 2;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the trailing */
+/* submatrix A(k-1:n,k-1:n) */
+
+ if (kp < *n) {
+ i__1 = *n - kp;
+ dswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + kp *
+ a_dim1], &c__1);
+ }
+ i__1 = kp - k - 1;
+ dswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) *
+ a_dim1], lda);
+ temp = a[k + k * a_dim1];
+ a[k + k * a_dim1] = a[kp + kp * a_dim1];
+ a[kp + kp * a_dim1] = temp;
+ if (kstep == 2) {
+ temp = a[k + (k - 1) * a_dim1];
+ a[k + (k - 1) * a_dim1] = a[kp + (k - 1) * a_dim1];
+ a[kp + (k - 1) * a_dim1] = temp;
+ }
+ }
+
+ k -= kstep;
+ goto L50;
+L60:
+ ;
+ }
+
+ return 0;
+
+/* End of DSYTRI */
+
+} /* dsytri_ */
diff --git a/SRC/dsytrs.c b/SRC/dsytrs.c
new file mode 100644
index 0000000..26db5a7
--- /dev/null
+++ b/SRC/dsytrs.c
@@ -0,0 +1,453 @@
+/* dsytrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b7 = -1.;
+static integer c__1 = 1;
+static doublereal c_b19 = 1.;
+
+/* Subroutine */ int dsytrs_(char *uplo, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer *
+ ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+ doublereal d__1;
+
+ /* Local variables */
+ integer j, k;
+ doublereal ak, bk;
+ integer kp;
+ doublereal akm1, bkm1;
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal akm1k;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ doublereal denom;
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dswap_(integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYTRS solves a system of linear equations A*X = B with a real */
+/* symmetric matrix A using the factorization A = U*D*U**T or */
+/* A = L*D*L**T computed by DSYTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by DSYTRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by DSYTRF. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DSYTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B, where A = U*D*U'. */
+
+/* First solve U*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+L10:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L30;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ i__1 = k - 1;
+ dger_(&i__1, nrhs, &c_b7, &a[k * a_dim1 + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ d__1 = 1. / a[k + k * a_dim1];
+ dscal_(nrhs, &d__1, &b[k + b_dim1], ldb);
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K-1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k - 1) {
+ dswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ i__1 = k - 2;
+ dger_(&i__1, nrhs, &c_b7, &a[k * a_dim1 + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+ i__1 = k - 2;
+ dger_(&i__1, nrhs, &c_b7, &a[(k - 1) * a_dim1 + 1], &c__1, &b[k -
+ 1 + b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ akm1k = a[k - 1 + k * a_dim1];
+ akm1 = a[k - 1 + (k - 1) * a_dim1] / akm1k;
+ ak = a[k + k * a_dim1] / akm1k;
+ denom = akm1 * ak - 1.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bkm1 = b[k - 1 + j * b_dim1] / akm1k;
+ bk = b[k + j * b_dim1] / akm1k;
+ b[k - 1 + j * b_dim1] = (ak * bkm1 - bk) / denom;
+ b[k + j * b_dim1] = (akm1 * bk - bkm1) / denom;
+/* L20: */
+ }
+ k += -2;
+ }
+
+ goto L10;
+L30:
+
+/* Next solve U'*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+L40:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L50;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(U'(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ i__1 = k - 1;
+ dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[k *
+ a_dim1 + 1], &c__1, &c_b19, &b[k + b_dim1], ldb);
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ i__1 = k - 1;
+ dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[k *
+ a_dim1 + 1], &c__1, &c_b19, &b[k + b_dim1], ldb);
+ i__1 = k - 1;
+ dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[(k
+ + 1) * a_dim1 + 1], &c__1, &c_b19, &b[k + 1 + b_dim1],
+ ldb);
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ k += 2;
+ }
+
+ goto L40;
+L50:
+
+ ;
+ } else {
+
+/* Solve A*X = B, where A = L*D*L'. */
+
+/* First solve L*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+L60:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L80;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ dger_(&i__1, nrhs, &c_b7, &a[k + 1 + k * a_dim1], &c__1, &b[k
+ + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ d__1 = 1. / a[k + k * a_dim1];
+ dscal_(nrhs, &d__1, &b[k + b_dim1], ldb);
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K+1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k + 1) {
+ dswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ if (k < *n - 1) {
+ i__1 = *n - k - 1;
+ dger_(&i__1, nrhs, &c_b7, &a[k + 2 + k * a_dim1], &c__1, &b[k
+ + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ dger_(&i__1, nrhs, &c_b7, &a[k + 2 + (k + 1) * a_dim1], &c__1,
+ &b[k + 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ akm1k = a[k + 1 + k * a_dim1];
+ akm1 = a[k + k * a_dim1] / akm1k;
+ ak = a[k + 1 + (k + 1) * a_dim1] / akm1k;
+ denom = akm1 * ak - 1.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bkm1 = b[k + j * b_dim1] / akm1k;
+ bk = b[k + 1 + j * b_dim1] / akm1k;
+ b[k + j * b_dim1] = (ak * bkm1 - bk) / denom;
+ b[k + 1 + j * b_dim1] = (akm1 * bk - bkm1) / denom;
+/* L70: */
+ }
+ k += 2;
+ }
+
+ goto L60;
+L80:
+
+/* Next solve L'*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+L90:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L100;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(L'(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1],
+ ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b19, &b[k +
+ b_dim1], ldb);
+ }
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1],
+ ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b19, &b[k +
+ b_dim1], ldb);
+ i__1 = *n - k;
+ dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1],
+ ldb, &a[k + 1 + (k - 1) * a_dim1], &c__1, &c_b19, &b[
+ k - 1 + b_dim1], ldb);
+ }
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ k += -2;
+ }
+
+ goto L90;
+L100:
+ ;
+ }
+
+ return 0;
+
+/* End of DSYTRS */
+
+} /* dsytrs_ */
diff --git a/SRC/dtbcon.c b/SRC/dtbcon.c
new file mode 100644
index 0000000..1c4e89c
--- /dev/null
+++ b/SRC/dtbcon.c
@@ -0,0 +1,247 @@
+/* dtbcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dtbcon_(char *norm, char *uplo, char *diag, integer *n,
+ integer *kd, doublereal *ab, integer *ldab, doublereal *rcond,
+ doublereal *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1;
+ doublereal d__1;
+
+ /* Local variables */
+ integer ix, kase, kase1;
+ doublereal scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int drscl_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal anorm;
+ logical upper;
+ doublereal xnorm;
+ extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern doublereal dlantb_(char *, char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlatbs_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
+ doublereal ainvnm;
+ logical onenrm;
+ char normin[1];
+ doublereal smlnum;
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTBCON estimates the reciprocal of the condition number of a */
+/* triangular band matrix A, in either the 1-norm or the infinity-norm. */
+
+/* The norm of A is computed and an estimate is obtained for */
+/* norm(inv(A)), then the reciprocal of the condition number is */
+/* computed as */
+/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ nounit = lsame_(diag, "N");
+
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*kd < 0) {
+ *info = -5;
+ } else if (*ldab < *kd + 1) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTBCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ }
+
+ *rcond = 0.;
+ smlnum = dlamch_("Safe minimum") * (doublereal) max(1,*n);
+
+/* Compute the norm of the triangular matrix A. */
+
+ anorm = dlantb_(norm, uplo, diag, n, kd, &ab[ab_offset], ldab, &work[1]);
+
+/* Continue only if ANORM > 0. */
+
+ if (anorm > 0.) {
+
+/* Estimate the norm of the inverse of A. */
+
+ ainvnm = 0.;
+ *(unsigned char *)normin = 'N';
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kase = 0;
+L10:
+ dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(A). */
+
+ dlatbs_(uplo, "No transpose", diag, normin, n, kd, &ab[
+ ab_offset], ldab, &work[1], &scale, &work[(*n << 1) +
+ 1], info)
+ ;
+ } else {
+
+/* Multiply by inv(A'). */
+
+ dlatbs_(uplo, "Transpose", diag, normin, n, kd, &ab[ab_offset]
+, ldab, &work[1], &scale, &work[(*n << 1) + 1], info);
+ }
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ if (scale != 1.) {
+ ix = idamax_(n, &work[1], &c__1);
+ xnorm = (d__1 = work[ix], abs(d__1));
+ if (scale < xnorm * smlnum || scale == 0.) {
+ goto L20;
+ }
+ drscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / anorm / ainvnm;
+ }
+ }
+
+L20:
+ return 0;
+
+/* End of DTBCON */
+
+} /* dtbcon_ */
diff --git a/SRC/dtbrfs.c b/SRC/dtbrfs.c
new file mode 100644
index 0000000..e1e50c8
--- /dev/null
+++ b/SRC/dtbrfs.c
@@ -0,0 +1,519 @@
+/* dtbrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b19 = -1.;
+
+/* Subroutine */ int dtbrfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, doublereal *ab, integer *ldab, doublereal
+ *b, integer *ldb, doublereal *x, integer *ldx, doublereal *ferr,
+ doublereal *berr, doublereal *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1,
+ i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal s, xk;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int dtbmv_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *), dcopy_(integer *, doublereal *, integer *
+, doublereal *, integer *), dtbsv_(char *, char *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *), daxpy_(integer *, doublereal *
+, doublereal *, integer *, doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+ char transt[1];
+ logical nounit;
+ doublereal lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTBRFS provides error bounds and backward error estimates for the */
+/* solution to a system of linear equations with a triangular band */
+/* coefficient matrix. */
+
+/* The solution matrix X must be computed by DTBTRS or some other */
+/* means before entering this routine. DTBRFS does not do iterative */
+/* refinement because doing so cannot improve the backward error. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*kd < 0) {
+ *info = -5;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*ldab < *kd + 1) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldx < max(1,*n)) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTBRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *kd + 2;
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A or A', depending on TRANS. */
+
+ dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+ dtbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[*n + 1],
+ &c__1);
+ daxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1));
+/* L20: */
+ }
+
+ if (notran) {
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+/* Computing MAX */
+ i__3 = 1, i__4 = k - *kd;
+ i__5 = k;
+ for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
+ work[i__] += (d__1 = ab[*kd + 1 + i__ - k + k *
+ ab_dim1], abs(d__1)) * xk;
+/* L30: */
+ }
+/* L40: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+/* Computing MAX */
+ i__5 = 1, i__3 = k - *kd;
+ i__4 = k - 1;
+ for (i__ = max(i__5,i__3); i__ <= i__4; ++i__) {
+ work[i__] += (d__1 = ab[*kd + 1 + i__ - k + k *
+ ab_dim1], abs(d__1)) * xk;
+/* L50: */
+ }
+ work[k] += xk;
+/* L60: */
+ }
+ }
+ } else {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+/* Computing MIN */
+ i__5 = *n, i__3 = k + *kd;
+ i__4 = min(i__5,i__3);
+ for (i__ = k; i__ <= i__4; ++i__) {
+ work[i__] += (d__1 = ab[i__ + 1 - k + k * ab_dim1]
+ , abs(d__1)) * xk;
+/* L70: */
+ }
+/* L80: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+/* Computing MIN */
+ i__5 = *n, i__3 = k + *kd;
+ i__4 = min(i__5,i__3);
+ for (i__ = k + 1; i__ <= i__4; ++i__) {
+ work[i__] += (d__1 = ab[i__ + 1 - k + k * ab_dim1]
+ , abs(d__1)) * xk;
+/* L90: */
+ }
+ work[k] += xk;
+/* L100: */
+ }
+ }
+ }
+ } else {
+
+/* Compute abs(A')*abs(X) + abs(B). */
+
+ if (upper) {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+/* Computing MAX */
+ i__4 = 1, i__5 = k - *kd;
+ i__3 = k;
+ for (i__ = max(i__4,i__5); i__ <= i__3; ++i__) {
+ s += (d__1 = ab[*kd + 1 + i__ - k + k * ab_dim1],
+ abs(d__1)) * (d__2 = x[i__ + j * x_dim1],
+ abs(d__2));
+/* L110: */
+ }
+ work[k] += s;
+/* L120: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = (d__1 = x[k + j * x_dim1], abs(d__1));
+/* Computing MAX */
+ i__3 = 1, i__4 = k - *kd;
+ i__5 = k - 1;
+ for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
+ s += (d__1 = ab[*kd + 1 + i__ - k + k * ab_dim1],
+ abs(d__1)) * (d__2 = x[i__ + j * x_dim1],
+ abs(d__2));
+/* L130: */
+ }
+ work[k] += s;
+/* L140: */
+ }
+ }
+ } else {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+/* Computing MIN */
+ i__3 = *n, i__4 = k + *kd;
+ i__5 = min(i__3,i__4);
+ for (i__ = k; i__ <= i__5; ++i__) {
+ s += (d__1 = ab[i__ + 1 - k + k * ab_dim1], abs(
+ d__1)) * (d__2 = x[i__ + j * x_dim1], abs(
+ d__2));
+/* L150: */
+ }
+ work[k] += s;
+/* L160: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = (d__1 = x[k + j * x_dim1], abs(d__1));
+/* Computing MIN */
+ i__3 = *n, i__4 = k + *kd;
+ i__5 = min(i__3,i__4);
+ for (i__ = k + 1; i__ <= i__5; ++i__) {
+ s += (d__1 = ab[i__ + 1 - k + k * ab_dim1], abs(
+ d__1)) * (d__2 = x[i__ + j * x_dim1], abs(
+ d__2));
+/* L170: */
+ }
+ work[k] += s;
+/* L180: */
+ }
+ }
+ }
+ }
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[
+ i__];
+ s = max(d__2,d__3);
+ } else {
+/* Computing MAX */
+ d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1)
+ / (work[i__] + safe1);
+ s = max(d__2,d__3);
+ }
+/* L190: */
+ }
+ berr[j] = s;
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use DLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L200: */
+ }
+
+ kase = 0;
+L210:
+ dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+ kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)'). */
+
+ dtbsv_(uplo, transt, diag, n, kd, &ab[ab_offset], ldab, &work[
+ *n + 1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L220: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L230: */
+ }
+ dtbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[*
+ n + 1], &c__1);
+ }
+ goto L210;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1));
+ lstres = max(d__2,d__3);
+/* L240: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L250: */
+ }
+
+ return 0;
+
+/* End of DTBRFS */
+
+} /* dtbrfs_ */
diff --git a/SRC/dtbtrs.c b/SRC/dtbtrs.c
new file mode 100644
index 0000000..aee820c
--- /dev/null
+++ b/SRC/dtbtrs.c
@@ -0,0 +1,204 @@
+/* dtbtrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dtbtrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, doublereal *ab, integer *ldab, doublereal
+ *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ integer j;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dtbsv_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTBTRS solves a triangular system of the form */
+
+/* A * X = B or A**T * X = B, */
+
+/* where A is a triangular band matrix of order N, and B is an */
+/* N-by NRHS matrix. A check is made to verify that A is nonsingular. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of AB. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, if INFO = 0, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element of A is zero, */
+/* indicating that the matrix is singular and the */
+/* solutions X have not been computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ nounit = lsame_(diag, "N");
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*kd < 0) {
+ *info = -5;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*ldab < *kd + 1) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTBTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check for singularity. */
+
+ if (nounit) {
+ if (upper) {
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ if (ab[*kd + 1 + *info * ab_dim1] == 0.) {
+ return 0;
+ }
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ if (ab[*info * ab_dim1 + 1] == 0.) {
+ return 0;
+ }
+/* L20: */
+ }
+ }
+ }
+ *info = 0;
+
+/* Solve A * X = B or A' * X = B. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ dtbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &b[j * b_dim1
+ + 1], &c__1);
+/* L30: */
+ }
+
+ return 0;
+
+/* End of DTBTRS */
+
+} /* dtbtrs_ */
diff --git a/SRC/dtfsm.c b/SRC/dtfsm.c
new file mode 100644
index 0000000..0b28fc5
--- /dev/null
+++ b/SRC/dtfsm.c
@@ -0,0 +1,976 @@
+/* dtfsm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b23 = -1.;
+static doublereal c_b27 = 1.;
+
+/* Subroutine */ int dtfsm_(char *transr, char *side, char *uplo, char *trans,
+ char *diag, integer *m, integer *n, doublereal *alpha, doublereal *a,
+ doublereal *b, integer *ldb)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k, m1, m2, n1, n2, info;
+ logical normaltransr;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ logical lside;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), xerbla_(
+ char *, integer *);
+ logical misodd, nisodd, notrans;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Level 3 BLAS like routine for A in RFP Format. */
+
+/* DTFSM solves the matrix equation */
+
+/* op( A )*X = alpha*B or X*op( A ) = alpha*B */
+
+/* where alpha is a scalar, X and B are m by n matrices, A is a unit, or */
+/* non-unit, upper or lower triangular matrix and op( A ) is one of */
+
+/* op( A ) = A or op( A ) = A'. */
+
+/* A is in Rectangular Full Packed (RFP) Format. */
+
+/* The matrix X is overwritten on B. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANSR - (input) CHARACTER */
+/* = 'N': The Normal Form of RFP A is stored; */
+/* = 'T': The Transpose Form of RFP A is stored. */
+
+/* SIDE - (input) CHARACTER */
+/* On entry, SIDE specifies whether op( A ) appears on the left */
+/* or right of X as follows: */
+
+/* SIDE = 'L' or 'l' op( A )*X = alpha*B. */
+
+/* SIDE = 'R' or 'r' X*op( A ) = alpha*B. */
+
+/* Unchanged on exit. */
+
+/* UPLO - (input) CHARACTER */
+/* On entry, UPLO specifies whether the RFP matrix A came from */
+/* an upper or lower triangular matrix as follows: */
+/* UPLO = 'U' or 'u' RFP A came from an upper triangular matrix */
+/* UPLO = 'L' or 'l' RFP A came from a lower triangular matrix */
+
+/* Unchanged on exit. */
+
+/* TRANS - (input) CHARACTER */
+/* On entry, TRANS specifies the form of op( A ) to be used */
+/* in the matrix multiplication as follows: */
+
+/* TRANS = 'N' or 'n' op( A ) = A. */
+
+/* TRANS = 'T' or 't' op( A ) = A'. */
+
+/* Unchanged on exit. */
+
+/* DIAG - (input) CHARACTER */
+/* On entry, DIAG specifies whether or not RFP A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* M - (input) INTEGER. */
+/* On entry, M specifies the number of rows of B. M must be at */
+/* least zero. */
+/* Unchanged on exit. */
+
+/* N - (input) INTEGER. */
+/* On entry, N specifies the number of columns of B. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - (input) DOUBLE PRECISION. */
+/* On entry, ALPHA specifies the scalar alpha. When alpha is */
+/* zero then A is not referenced and B need not be set before */
+/* entry. */
+/* Unchanged on exit. */
+
+/* A - (input) DOUBLE PRECISION array, dimension (NT); */
+/* NT = N*(N+1)/2. On entry, the matrix A in RFP Format. */
+/* RFP Format is described by TRANSR, UPLO and N as follows: */
+/* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even; */
+/* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If */
+/* TRANSR = 'T' then RFP is the transpose of RFP A as */
+/* defined when TRANSR = 'N'. The contents of RFP A are defined */
+/* by UPLO as follows: If UPLO = 'U' the RFP A contains the NT */
+/* elements of upper packed A either in normal or */
+/* transpose Format. If UPLO = 'L' the RFP A contains */
+/* the NT elements of lower packed A either in normal or */
+/* transpose Format. The LDA of RFP A is (N+1)/2 when */
+/* TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is */
+/* even and is N when is odd. */
+/* See the Note below for more details. Unchanged on exit. */
+
+/* B - (input/ouptut) DOUBLE PRECISION array, DIMENSION (LDB,N) */
+/* Before entry, the leading m by n part of the array B must */
+/* contain the right-hand side matrix B, and on exit is */
+/* overwritten by the solution matrix X. */
+
+/* LDB - (input) INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. LDB must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+/* Further Details */
+/* =============== */
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* even. We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* the transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* the transpose of the last three columns of AP lower. */
+/* This covers the case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 03 04 05 33 43 53 */
+/* 13 14 15 00 44 54 */
+/* 23 24 25 10 11 55 */
+/* 33 34 35 20 21 22 */
+/* 00 44 45 30 31 32 */
+/* 01 11 55 40 41 42 */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* odd. We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* the transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* the transpose of the last two columns of AP lower. */
+/* This covers the case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 02 03 04 00 33 43 */
+/* 12 13 14 10 11 44 */
+/* 22 23 24 20 21 22 */
+/* 00 33 34 30 31 32 */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+/* RFP A RFP A */
+
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* Reference */
+/* ========= */
+
+/* ===================================================================== */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ b_dim1 = *ldb - 1 - 0 + 1;
+ b_offset = 0 + b_dim1 * 0;
+ b -= b_offset;
+
+ /* Function Body */
+ info = 0;
+ normaltransr = lsame_(transr, "N");
+ lside = lsame_(side, "L");
+ lower = lsame_(uplo, "L");
+ notrans = lsame_(trans, "N");
+ if (! normaltransr && ! lsame_(transr, "T")) {
+ info = -1;
+ } else if (! lside && ! lsame_(side, "R")) {
+ info = -2;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ info = -3;
+ } else if (! notrans && ! lsame_(trans, "T")) {
+ info = -4;
+ } else if (! lsame_(diag, "N") && ! lsame_(diag,
+ "U")) {
+ info = -5;
+ } else if (*m < 0) {
+ info = -6;
+ } else if (*n < 0) {
+ info = -7;
+ } else if (*ldb < max(1,*m)) {
+ info = -11;
+ }
+ if (info != 0) {
+ i__1 = -info;
+ xerbla_("DTFSM ", &i__1);
+ return 0;
+ }
+
+/* Quick return when ( (N.EQ.0).OR.(M.EQ.0) ) */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Quick return when ALPHA.EQ.(0D+0) */
+
+ if (*alpha == 0.) {
+ i__1 = *n - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *m - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ return 0;
+ }
+
+ if (lside) {
+
+/* SIDE = 'L' */
+
+/* A is M-by-M. */
+/* If M is odd, set NISODD = .TRUE., and M1 and M2. */
+/* If M is even, NISODD = .FALSE., and M. */
+
+ if (*m % 2 == 0) {
+ misodd = FALSE_;
+ k = *m / 2;
+ } else {
+ misodd = TRUE_;
+ if (lower) {
+ m2 = *m / 2;
+ m1 = *m - m2;
+ } else {
+ m1 = *m / 2;
+ m2 = *m - m1;
+ }
+ }
+
+
+ if (misodd) {
+
+/* SIDE = 'L' and N is odd */
+
+ if (normaltransr) {
+
+/* SIDE = 'L', N is odd, and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and */
+/* TRANS = 'N' */
+
+ if (*m == 1) {
+ dtrsm_("L", "L", "N", diag, &m1, n, alpha, a, m, &
+ b[b_offset], ldb);
+ } else {
+ dtrsm_("L", "L", "N", diag, &m1, n, alpha, a, m, &
+ b[b_offset], ldb);
+ dgemm_("N", "N", &m2, n, &m1, &c_b23, &a[m1], m, &
+ b[b_offset], ldb, alpha, &b[m1], ldb);
+ dtrsm_("L", "U", "T", diag, &m2, n, &c_b27, &a[*m]
+, m, &b[m1], ldb);
+ }
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and */
+/* TRANS = 'T' */
+
+ if (*m == 1) {
+ dtrsm_("L", "L", "T", diag, &m1, n, alpha, a, m, &
+ b[b_offset], ldb);
+ } else {
+ dtrsm_("L", "U", "N", diag, &m2, n, alpha, &a[*m],
+ m, &b[m1], ldb);
+ dgemm_("T", "N", &m1, n, &m2, &c_b23, &a[m1], m, &
+ b[m1], ldb, alpha, &b[b_offset], ldb);
+ dtrsm_("L", "L", "T", diag, &m1, n, &c_b27, a, m,
+ &b[b_offset], ldb);
+ }
+
+ }
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'U' */
+
+ if (! notrans) {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and */
+/* TRANS = 'N' */
+
+ dtrsm_("L", "L", "N", diag, &m1, n, alpha, &a[m2], m,
+ &b[b_offset], ldb);
+ dgemm_("T", "N", &m2, n, &m1, &c_b23, a, m, &b[
+ b_offset], ldb, alpha, &b[m1], ldb);
+ dtrsm_("L", "U", "T", diag, &m2, n, &c_b27, &a[m1], m,
+ &b[m1], ldb);
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and */
+/* TRANS = 'T' */
+
+ dtrsm_("L", "U", "N", diag, &m2, n, alpha, &a[m1], m,
+ &b[m1], ldb);
+ dgemm_("N", "N", &m1, n, &m2, &c_b23, a, m, &b[m1],
+ ldb, alpha, &b[b_offset], ldb);
+ dtrsm_("L", "L", "T", diag, &m1, n, &c_b27, &a[m2], m,
+ &b[b_offset], ldb);
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'L', N is odd, and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and */
+/* TRANS = 'N' */
+
+ if (*m == 1) {
+ dtrsm_("L", "U", "T", diag, &m1, n, alpha, a, &m1,
+ &b[b_offset], ldb);
+ } else {
+ dtrsm_("L", "U", "T", diag, &m1, n, alpha, a, &m1,
+ &b[b_offset], ldb);
+ dgemm_("T", "N", &m2, n, &m1, &c_b23, &a[m1 * m1],
+ &m1, &b[b_offset], ldb, alpha, &b[m1],
+ ldb);
+ dtrsm_("L", "L", "N", diag, &m2, n, &c_b27, &a[1],
+ &m1, &b[m1], ldb);
+ }
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and */
+/* TRANS = 'T' */
+
+ if (*m == 1) {
+ dtrsm_("L", "U", "N", diag, &m1, n, alpha, a, &m1,
+ &b[b_offset], ldb);
+ } else {
+ dtrsm_("L", "L", "T", diag, &m2, n, alpha, &a[1],
+ &m1, &b[m1], ldb);
+ dgemm_("N", "N", &m1, n, &m2, &c_b23, &a[m1 * m1],
+ &m1, &b[m1], ldb, alpha, &b[b_offset],
+ ldb);
+ dtrsm_("L", "U", "N", diag, &m1, n, &c_b27, a, &
+ m1, &b[b_offset], ldb);
+ }
+
+ }
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'U' */
+
+ if (! notrans) {
+
+/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and */
+/* TRANS = 'N' */
+
+ dtrsm_("L", "U", "T", diag, &m1, n, alpha, &a[m2 * m2]
+, &m2, &b[b_offset], ldb);
+ dgemm_("N", "N", &m2, n, &m1, &c_b23, a, &m2, &b[
+ b_offset], ldb, alpha, &b[m1], ldb);
+ dtrsm_("L", "L", "N", diag, &m2, n, &c_b27, &a[m1 *
+ m2], &m2, &b[m1], ldb);
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and */
+/* TRANS = 'T' */
+
+ dtrsm_("L", "L", "T", diag, &m2, n, alpha, &a[m1 * m2]
+, &m2, &b[m1], ldb);
+ dgemm_("T", "N", &m1, n, &m2, &c_b23, a, &m2, &b[m1],
+ ldb, alpha, &b[b_offset], ldb);
+ dtrsm_("L", "U", "N", diag, &m1, n, &c_b27, &a[m2 *
+ m2], &m2, &b[b_offset], ldb);
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'L' and N is even */
+
+ if (normaltransr) {
+
+/* SIDE = 'L', N is even, and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', */
+/* and TRANS = 'N' */
+
+ i__1 = *m + 1;
+ dtrsm_("L", "L", "N", diag, &k, n, alpha, &a[1], &
+ i__1, &b[b_offset], ldb);
+ i__1 = *m + 1;
+ dgemm_("N", "N", &k, n, &k, &c_b23, &a[k + 1], &i__1,
+ &b[b_offset], ldb, alpha, &b[k], ldb);
+ i__1 = *m + 1;
+ dtrsm_("L", "U", "T", diag, &k, n, &c_b27, a, &i__1, &
+ b[k], ldb);
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', */
+/* and TRANS = 'T' */
+
+ i__1 = *m + 1;
+ dtrsm_("L", "U", "N", diag, &k, n, alpha, a, &i__1, &
+ b[k], ldb);
+ i__1 = *m + 1;
+ dgemm_("T", "N", &k, n, &k, &c_b23, &a[k + 1], &i__1,
+ &b[k], ldb, alpha, &b[b_offset], ldb);
+ i__1 = *m + 1;
+ dtrsm_("L", "L", "T", diag, &k, n, &c_b27, &a[1], &
+ i__1, &b[b_offset], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'U' */
+
+ if (! notrans) {
+
+/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', */
+/* and TRANS = 'N' */
+
+ i__1 = *m + 1;
+ dtrsm_("L", "L", "N", diag, &k, n, alpha, &a[k + 1], &
+ i__1, &b[b_offset], ldb);
+ i__1 = *m + 1;
+ dgemm_("T", "N", &k, n, &k, &c_b23, a, &i__1, &b[
+ b_offset], ldb, alpha, &b[k], ldb);
+ i__1 = *m + 1;
+ dtrsm_("L", "U", "T", diag, &k, n, &c_b27, &a[k], &
+ i__1, &b[k], ldb);
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', */
+/* and TRANS = 'T' */
+ i__1 = *m + 1;
+ dtrsm_("L", "U", "N", diag, &k, n, alpha, &a[k], &
+ i__1, &b[k], ldb);
+ i__1 = *m + 1;
+ dgemm_("N", "N", &k, n, &k, &c_b23, a, &i__1, &b[k],
+ ldb, alpha, &b[b_offset], ldb);
+ i__1 = *m + 1;
+ dtrsm_("L", "L", "T", diag, &k, n, &c_b27, &a[k + 1],
+ &i__1, &b[b_offset], ldb);
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'L', N is even, and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', */
+/* and TRANS = 'N' */
+
+ dtrsm_("L", "U", "T", diag, &k, n, alpha, &a[k], &k, &
+ b[b_offset], ldb);
+ dgemm_("T", "N", &k, n, &k, &c_b23, &a[k * (k + 1)], &
+ k, &b[b_offset], ldb, alpha, &b[k], ldb);
+ dtrsm_("L", "L", "N", diag, &k, n, &c_b27, a, &k, &b[
+ k], ldb);
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', */
+/* and TRANS = 'T' */
+
+ dtrsm_("L", "L", "T", diag, &k, n, alpha, a, &k, &b[k]
+, ldb);
+ dgemm_("N", "N", &k, n, &k, &c_b23, &a[k * (k + 1)], &
+ k, &b[k], ldb, alpha, &b[b_offset], ldb);
+ dtrsm_("L", "U", "N", diag, &k, n, &c_b27, &a[k], &k,
+ &b[b_offset], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'U' */
+
+ if (! notrans) {
+
+/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', */
+/* and TRANS = 'N' */
+
+ dtrsm_("L", "U", "T", diag, &k, n, alpha, &a[k * (k +
+ 1)], &k, &b[b_offset], ldb);
+ dgemm_("N", "N", &k, n, &k, &c_b23, a, &k, &b[
+ b_offset], ldb, alpha, &b[k], ldb);
+ dtrsm_("L", "L", "N", diag, &k, n, &c_b27, &a[k * k],
+ &k, &b[k], ldb);
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', */
+/* and TRANS = 'T' */
+
+ dtrsm_("L", "L", "T", diag, &k, n, alpha, &a[k * k], &
+ k, &b[k], ldb);
+ dgemm_("T", "N", &k, n, &k, &c_b23, a, &k, &b[k], ldb,
+ alpha, &b[b_offset], ldb);
+ dtrsm_("L", "U", "N", diag, &k, n, &c_b27, &a[k * (k
+ + 1)], &k, &b[b_offset], ldb);
+
+ }
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'R' */
+
+/* A is N-by-N. */
+/* If N is odd, set NISODD = .TRUE., and N1 and N2. */
+/* If N is even, NISODD = .FALSE., and K. */
+
+ if (*n % 2 == 0) {
+ nisodd = FALSE_;
+ k = *n / 2;
+ } else {
+ nisodd = TRUE_;
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+ }
+
+ if (nisodd) {
+
+/* SIDE = 'R' and N is odd */
+
+ if (normaltransr) {
+
+/* SIDE = 'R', N is odd, and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and */
+/* TRANS = 'N' */
+
+ dtrsm_("R", "U", "T", diag, m, &n2, alpha, &a[*n], n,
+ &b[n1 * b_dim1], ldb);
+ dgemm_("N", "N", m, &n1, &n2, &c_b23, &b[n1 * b_dim1],
+ ldb, &a[n1], n, alpha, b, ldb);
+ dtrsm_("R", "L", "N", diag, m, &n1, &c_b27, a, n, b,
+ ldb);
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and */
+/* TRANS = 'T' */
+
+ dtrsm_("R", "L", "T", diag, m, &n1, alpha, a, n, b,
+ ldb);
+ dgemm_("N", "T", m, &n2, &n1, &c_b23, b, ldb, &a[n1],
+ n, alpha, &b[n1 * b_dim1], ldb);
+ dtrsm_("R", "U", "N", diag, m, &n2, &c_b27, &a[*n], n,
+ &b[n1 * b_dim1], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and */
+/* TRANS = 'N' */
+
+ dtrsm_("R", "L", "T", diag, m, &n1, alpha, &a[n2], n,
+ b, ldb);
+ dgemm_("N", "N", m, &n2, &n1, &c_b23, b, ldb, a, n,
+ alpha, &b[n1 * b_dim1], ldb);
+ dtrsm_("R", "U", "N", diag, m, &n2, &c_b27, &a[n1], n,
+ &b[n1 * b_dim1], ldb);
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and */
+/* TRANS = 'T' */
+
+ dtrsm_("R", "U", "T", diag, m, &n2, alpha, &a[n1], n,
+ &b[n1 * b_dim1], ldb);
+ dgemm_("N", "T", m, &n1, &n2, &c_b23, &b[n1 * b_dim1],
+ ldb, a, n, alpha, b, ldb);
+ dtrsm_("R", "L", "N", diag, m, &n1, &c_b27, &a[n2], n,
+ b, ldb);
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'R', N is odd, and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and */
+/* TRANS = 'N' */
+
+ dtrsm_("R", "L", "N", diag, m, &n2, alpha, &a[1], &n1,
+ &b[n1 * b_dim1], ldb);
+ dgemm_("N", "T", m, &n1, &n2, &c_b23, &b[n1 * b_dim1],
+ ldb, &a[n1 * n1], &n1, alpha, b, ldb);
+ dtrsm_("R", "U", "T", diag, m, &n1, &c_b27, a, &n1, b,
+ ldb);
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and */
+/* TRANS = 'T' */
+
+ dtrsm_("R", "U", "N", diag, m, &n1, alpha, a, &n1, b,
+ ldb);
+ dgemm_("N", "N", m, &n2, &n1, &c_b23, b, ldb, &a[n1 *
+ n1], &n1, alpha, &b[n1 * b_dim1], ldb);
+ dtrsm_("R", "L", "T", diag, m, &n2, &c_b27, &a[1], &
+ n1, &b[n1 * b_dim1], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and */
+/* TRANS = 'N' */
+
+ dtrsm_("R", "U", "N", diag, m, &n1, alpha, &a[n2 * n2]
+, &n2, b, ldb);
+ dgemm_("N", "T", m, &n2, &n1, &c_b23, b, ldb, a, &n2,
+ alpha, &b[n1 * b_dim1], ldb);
+ dtrsm_("R", "L", "T", diag, m, &n2, &c_b27, &a[n1 *
+ n2], &n2, &b[n1 * b_dim1], ldb);
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and */
+/* TRANS = 'T' */
+
+ dtrsm_("R", "L", "N", diag, m, &n2, alpha, &a[n1 * n2]
+, &n2, &b[n1 * b_dim1], ldb);
+ dgemm_("N", "N", m, &n1, &n2, &c_b23, &b[n1 * b_dim1],
+ ldb, a, &n2, alpha, b, ldb);
+ dtrsm_("R", "U", "T", diag, m, &n1, &c_b27, &a[n2 *
+ n2], &n2, b, ldb);
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'R' and N is even */
+
+ if (normaltransr) {
+
+/* SIDE = 'R', N is even, and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', */
+/* and TRANS = 'N' */
+
+ i__1 = *n + 1;
+ dtrsm_("R", "U", "T", diag, m, &k, alpha, a, &i__1, &
+ b[k * b_dim1], ldb);
+ i__1 = *n + 1;
+ dgemm_("N", "N", m, &k, &k, &c_b23, &b[k * b_dim1],
+ ldb, &a[k + 1], &i__1, alpha, b, ldb);
+ i__1 = *n + 1;
+ dtrsm_("R", "L", "N", diag, m, &k, &c_b27, &a[1], &
+ i__1, b, ldb);
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', */
+/* and TRANS = 'T' */
+
+ i__1 = *n + 1;
+ dtrsm_("R", "L", "T", diag, m, &k, alpha, &a[1], &
+ i__1, b, ldb);
+ i__1 = *n + 1;
+ dgemm_("N", "T", m, &k, &k, &c_b23, b, ldb, &a[k + 1],
+ &i__1, alpha, &b[k * b_dim1], ldb);
+ i__1 = *n + 1;
+ dtrsm_("R", "U", "N", diag, m, &k, &c_b27, a, &i__1, &
+ b[k * b_dim1], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', */
+/* and TRANS = 'N' */
+
+ i__1 = *n + 1;
+ dtrsm_("R", "L", "T", diag, m, &k, alpha, &a[k + 1], &
+ i__1, b, ldb);
+ i__1 = *n + 1;
+ dgemm_("N", "N", m, &k, &k, &c_b23, b, ldb, a, &i__1,
+ alpha, &b[k * b_dim1], ldb);
+ i__1 = *n + 1;
+ dtrsm_("R", "U", "N", diag, m, &k, &c_b27, &a[k], &
+ i__1, &b[k * b_dim1], ldb);
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', */
+/* and TRANS = 'T' */
+
+ i__1 = *n + 1;
+ dtrsm_("R", "U", "T", diag, m, &k, alpha, &a[k], &
+ i__1, &b[k * b_dim1], ldb);
+ i__1 = *n + 1;
+ dgemm_("N", "T", m, &k, &k, &c_b23, &b[k * b_dim1],
+ ldb, a, &i__1, alpha, b, ldb);
+ i__1 = *n + 1;
+ dtrsm_("R", "L", "N", diag, m, &k, &c_b27, &a[k + 1],
+ &i__1, b, ldb);
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'R', N is even, and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', */
+/* and TRANS = 'N' */
+
+ dtrsm_("R", "L", "N", diag, m, &k, alpha, a, &k, &b[k
+ * b_dim1], ldb);
+ dgemm_("N", "T", m, &k, &k, &c_b23, &b[k * b_dim1],
+ ldb, &a[(k + 1) * k], &k, alpha, b, ldb);
+ dtrsm_("R", "U", "T", diag, m, &k, &c_b27, &a[k], &k,
+ b, ldb);
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', */
+/* and TRANS = 'T' */
+
+ dtrsm_("R", "U", "N", diag, m, &k, alpha, &a[k], &k,
+ b, ldb);
+ dgemm_("N", "N", m, &k, &k, &c_b23, b, ldb, &a[(k + 1)
+ * k], &k, alpha, &b[k * b_dim1], ldb);
+ dtrsm_("R", "L", "T", diag, m, &k, &c_b27, a, &k, &b[
+ k * b_dim1], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', */
+/* and TRANS = 'N' */
+
+ dtrsm_("R", "U", "N", diag, m, &k, alpha, &a[(k + 1) *
+ k], &k, b, ldb);
+ dgemm_("N", "T", m, &k, &k, &c_b23, b, ldb, a, &k,
+ alpha, &b[k * b_dim1], ldb);
+ dtrsm_("R", "L", "T", diag, m, &k, &c_b27, &a[k * k],
+ &k, &b[k * b_dim1], ldb);
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', */
+/* and TRANS = 'T' */
+
+ dtrsm_("R", "L", "N", diag, m, &k, alpha, &a[k * k], &
+ k, &b[k * b_dim1], ldb);
+ dgemm_("N", "N", m, &k, &k, &c_b23, &b[k * b_dim1],
+ ldb, a, &k, alpha, b, ldb);
+ dtrsm_("R", "U", "T", diag, m, &k, &c_b27, &a[(k + 1)
+ * k], &k, b, ldb);
+
+ }
+
+ }
+
+ }
+
+ }
+ }
+
+ return 0;
+
+/* End of DTFSM */
+
+} /* dtfsm_ */
diff --git a/SRC/dtftri.c b/SRC/dtftri.c
new file mode 100644
index 0000000..1f9edc1
--- /dev/null
+++ b/SRC/dtftri.c
@@ -0,0 +1,474 @@
+/* dtftri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b13 = -1.;
+static doublereal c_b18 = 1.;
+
+/* Subroutine */ int dtftri_(char *transr, char *uplo, char *diag, integer *n,
+ doublereal *a, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer k, n1, n2;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nisodd;
+ extern /* Subroutine */ int dtrtri_(char *, char *, integer *, doublereal
+ *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTFTRI computes the inverse of a triangular matrix A stored in RFP */
+/* format. */
+
+/* This is a Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': The Normal TRANSR of RFP A is stored; */
+/* = 'T': The Transpose TRANSR of RFP A is stored. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (0:nt-1); */
+/* nt=N*(N+1)/2. On entry, the triangular factor of a Hermitian */
+/* Positive Definite matrix A in RFP format. RFP format is */
+/* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' */
+/* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */
+/* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is */
+/* the transpose of RFP A as defined when */
+/* TRANSR = 'N'. The contents of RFP A are defined by UPLO as */
+/* follows: If UPLO = 'U' the RFP A contains the nt elements of */
+/* upper packed A; If UPLO = 'L' the RFP A contains the nt */
+/* elements of lower packed A. The LDA of RFP A is (N+1)/2 when */
+/* TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is */
+/* even and N is odd. See the Note below for more details. */
+
+/* On exit, the (triangular) inverse of the original matrix, in */
+/* the same storage format. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */
+/* matrix is singular and its inverse can not be computed. */
+
+/* Notes */
+/* ===== */
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* even. We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* the transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* the transpose of the last three columns of AP lower. */
+/* This covers the case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 03 04 05 33 43 53 */
+/* 13 14 15 00 44 54 */
+/* 23 24 25 10 11 55 */
+/* 33 34 35 20 21 22 */
+/* 00 44 45 30 31 32 */
+/* 01 11 55 40 41 42 */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* odd. We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* the transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* the transpose of the last two columns of AP lower. */
+/* This covers the case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 02 03 04 00 33 43 */
+/* 12 13 14 10 11 44 */
+/* 22 23 24 20 21 22 */
+/* 00 33 34 30 31 32 */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+/* RFP A RFP A */
+
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "T")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (! lsame_(diag, "N") && ! lsame_(diag,
+ "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTFTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* If N is odd, set NISODD = .TRUE. */
+/* If N is even, set K = N/2 and NISODD = .FALSE. */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ } else {
+ nisodd = TRUE_;
+ }
+
+/* Set N1 and N2 depending on LOWER */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+
+/* start execution: there are eight cases */
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */
+/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */
+/* T1 -> a(0), T2 -> a(n), S -> a(n1) */
+
+ dtrtri_("L", diag, &n1, a, n, info);
+ if (*info > 0) {
+ return 0;
+ }
+ dtrmm_("R", "L", "N", diag, &n2, &n1, &c_b13, a, n, &a[n1], n);
+ dtrtri_("U", diag, &n2, &a[*n], n, info)
+ ;
+ if (*info > 0) {
+ *info += n1;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ dtrmm_("L", "U", "T", diag, &n2, &n1, &c_b18, &a[*n], n, &a[
+ n1], n);
+
+ } else {
+
+/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */
+/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */
+/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */
+
+ dtrtri_("L", diag, &n1, &a[n2], n, info)
+ ;
+ if (*info > 0) {
+ return 0;
+ }
+ dtrmm_("L", "L", "T", diag, &n1, &n2, &c_b13, &a[n2], n, a, n);
+ dtrtri_("U", diag, &n2, &a[n1], n, info)
+ ;
+ if (*info > 0) {
+ *info += n1;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ dtrmm_("R", "U", "N", diag, &n1, &n2, &c_b18, &a[n1], n, a, n);
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is odd */
+/* T1 -> a(0), T2 -> a(1), S -> a(0+n1*n1) */
+
+ dtrtri_("U", diag, &n1, a, &n1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ dtrmm_("L", "U", "N", diag, &n1, &n2, &c_b13, a, &n1, &a[n1 *
+ n1], &n1);
+ dtrtri_("L", diag, &n2, &a[1], &n1, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ dtrmm_("R", "L", "T", diag, &n1, &n2, &c_b18, &a[1], &n1, &a[
+ n1 * n1], &n1);
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is odd */
+/* T1 -> a(0+n2*n2), T2 -> a(0+n1*n2), S -> a(0) */
+
+ dtrtri_("U", diag, &n1, &a[n2 * n2], &n2, info);
+ if (*info > 0) {
+ return 0;
+ }
+ dtrmm_("R", "U", "T", diag, &n2, &n1, &c_b13, &a[n2 * n2], &
+ n2, a, &n2);
+ dtrtri_("L", diag, &n2, &a[n1 * n2], &n2, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ dtrmm_("L", "L", "N", diag, &n2, &n1, &c_b18, &a[n1 * n2], &
+ n2, a, &n2);
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
+/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */
+
+ i__1 = *n + 1;
+ dtrtri_("L", diag, &k, &a[1], &i__1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ dtrmm_("R", "L", "N", diag, &k, &k, &c_b13, &a[1], &i__1, &a[
+ k + 1], &i__2);
+ i__1 = *n + 1;
+ dtrtri_("U", diag, &k, a, &i__1, info);
+ if (*info > 0) {
+ *info += k;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ dtrmm_("L", "U", "T", diag, &k, &k, &c_b18, a, &i__1, &a[k +
+ 1], &i__2)
+ ;
+
+ } else {
+
+/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
+/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */
+
+ i__1 = *n + 1;
+ dtrtri_("L", diag, &k, &a[k + 1], &i__1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ dtrmm_("L", "L", "T", diag, &k, &k, &c_b13, &a[k + 1], &i__1,
+ a, &i__2);
+ i__1 = *n + 1;
+ dtrtri_("U", diag, &k, &a[k], &i__1, info);
+ if (*info > 0) {
+ *info += k;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ dtrmm_("R", "U", "N", diag, &k, &k, &c_b18, &a[k], &i__1, a, &
+ i__2);
+ }
+ } else {
+
+/* N is even and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */
+/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */
+
+ dtrtri_("U", diag, &k, &a[k], &k, info);
+ if (*info > 0) {
+ return 0;
+ }
+ dtrmm_("L", "U", "N", diag, &k, &k, &c_b13, &a[k], &k, &a[k *
+ (k + 1)], &k);
+ dtrtri_("L", diag, &k, a, &k, info);
+ if (*info > 0) {
+ *info += k;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ dtrmm_("R", "L", "T", diag, &k, &k, &c_b18, a, &k, &a[k * (k
+ + 1)], &k)
+ ;
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */
+/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */
+
+ dtrtri_("U", diag, &k, &a[k * (k + 1)], &k, info);
+ if (*info > 0) {
+ return 0;
+ }
+ dtrmm_("R", "U", "T", diag, &k, &k, &c_b13, &a[k * (k + 1)], &
+ k, a, &k);
+ dtrtri_("L", diag, &k, &a[k * k], &k, info);
+ if (*info > 0) {
+ *info += k;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ dtrmm_("L", "L", "N", diag, &k, &k, &c_b18, &a[k * k], &k, a,
+ &k);
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DTFTRI */
+
+} /* dtftri_ */
diff --git a/SRC/dtfttp.c b/SRC/dtfttp.c
new file mode 100644
index 0000000..3322618
--- /dev/null
+++ b/SRC/dtfttp.c
@@ -0,0 +1,514 @@
+/* dtfttp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtfttp_(char *transr, char *uplo, integer *n, doublereal
+ *arf, doublereal *ap, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, k, n1, n2, ij, jp, js, nt, lda, ijp;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nisodd;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTFTTP copies a triangular matrix A from rectangular full packed */
+/* format (TF) to standard packed format (TP). */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': ARF is in Normal format; */
+/* = 'T': ARF is in Transpose format; */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* ARF (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */
+/* On entry, the upper or lower triangular matrix A stored in */
+/* RFP format. For a further discussion see Notes below. */
+
+/* AP (output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */
+/* On exit, the upper or lower triangular matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Notes */
+/* ===== */
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* even. We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* the transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* the transpose of the last three columns of AP lower. */
+/* This covers the case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 03 04 05 33 43 53 */
+/* 13 14 15 00 44 54 */
+/* 23 24 25 10 11 55 */
+/* 33 34 35 20 21 22 */
+/* 00 44 45 30 31 32 */
+/* 01 11 55 40 41 42 */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* odd. We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* the transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* the transpose of the last two columns of AP lower. */
+/* This covers the case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 02 03 04 00 33 43 */
+/* 12 13 14 10 11 44 */
+/* 22 23 24 20 21 22 */
+/* 00 33 34 30 31 32 */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+/* RFP A RFP A */
+
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "T")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTFTTP", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (normaltransr) {
+ ap[0] = arf[0];
+ } else {
+ ap[0] = arf[0];
+ }
+ return 0;
+ }
+
+/* Size of array ARF(0:NT-1) */
+
+ nt = *n * (*n + 1) / 2;
+
+/* Set N1 and N2 depending on LOWER */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* If N is odd, set NISODD = .TRUE. */
+/* If N is even, set K = N/2 and NISODD = .FALSE. */
+
+/* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) */
+/* where noe = 0 if n is even, noe = 1 if n is odd */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ lda = *n + 1;
+ } else {
+ nisodd = TRUE_;
+ lda = *n;
+ }
+
+/* ARF^C has lda rows and n+1-noe cols */
+
+ if (! normaltransr) {
+ lda = (*n + 1) / 2;
+ }
+
+/* start execution: there are eight cases */
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */
+/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */
+/* T1 -> a(0), T2 -> a(n), S -> a(n1); lda = n */
+
+ ijp = 0;
+ jp = 0;
+ i__1 = n2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ij = i__ + jp;
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ jp += lda;
+ }
+ i__1 = n2 - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = n2;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ ij = i__ + j * lda;
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */
+/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */
+/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */
+
+ ijp = 0;
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ ij = n2 + j;
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ ij += lda;
+ }
+ }
+ js = 0;
+ i__1 = *n - 1;
+ for (j = n1; j <= i__1; ++j) {
+ ij = js;
+ i__2 = js + j;
+ for (ij = js; ij <= i__2; ++ij) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ js += lda;
+ }
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is odd */
+/* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */
+/* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 */
+
+ ijp = 0;
+ i__1 = n2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = *n * lda - 1;
+ i__3 = lda;
+ for (ij = i__ * (lda + 1); i__3 < 0 ? ij >= i__2 : ij <=
+ i__2; ij += i__3) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ }
+ js = 1;
+ i__1 = n2 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + n2 - j - 1;
+ for (ij = js; ij <= i__3; ++ij) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ js = js + lda + 1;
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is odd */
+/* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */
+/* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 */
+
+ ijp = 0;
+ js = n2 * lda;
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + j;
+ for (ij = js; ij <= i__3; ++ij) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ js += lda;
+ }
+ i__1 = n1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__3 = i__ + (n1 + i__) * lda;
+ i__2 = lda;
+ for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij +=
+ i__2) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
+/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */
+
+ ijp = 0;
+ jp = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ij = i__ + 1 + jp;
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ jp += lda;
+ }
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = k - 1;
+ for (j = i__; j <= i__2; ++j) {
+ ij = i__ + j * lda;
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
+/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */
+
+ ijp = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ ij = k + 1 + j;
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ ij += lda;
+ }
+ }
+ js = 0;
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+ ij = js;
+ i__2 = js + j;
+ for (ij = js; ij <= i__2; ++ij) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ js += lda;
+ }
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */
+/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */
+
+ ijp = 0;
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = (*n + 1) * lda - 1;
+ i__3 = lda;
+ for (ij = i__ + (i__ + 1) * lda; i__3 < 0 ? ij >= i__2 :
+ ij <= i__2; ij += i__3) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ }
+ js = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + k - j - 1;
+ for (ij = js; ij <= i__3; ++ij) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ js = js + lda + 1;
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */
+/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */
+
+ ijp = 0;
+ js = (k + 1) * lda;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + j;
+ for (ij = js; ij <= i__3; ++ij) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ js += lda;
+ }
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__3 = i__ + (k + i__) * lda;
+ i__2 = lda;
+ for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij +=
+ i__2) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of DTFTTP */
+
+} /* dtfttp_ */
diff --git a/SRC/dtfttr.c b/SRC/dtfttr.c
new file mode 100644
index 0000000..4f02d0c
--- /dev/null
+++ b/SRC/dtfttr.c
@@ -0,0 +1,491 @@
+/* dtfttr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtfttr_(char *transr, char *uplo, integer *n, doublereal
+ *arf, doublereal *a, integer *lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k, l, n1, n2, ij, nt, nx2, np1x2;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nisodd;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTFTTR copies a triangular matrix A from rectangular full packed */
+/* format (TF) to standard full format (TR). */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': ARF is in Normal format; */
+/* = 'T': ARF is in Transpose format. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrices ARF and A. N >= 0. */
+
+/* ARF (input) DOUBLE PRECISION array, dimension (N*(N+1)/2). */
+/* On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L') */
+/* matrix A in RFP format. See the "Notes" below for more */
+/* details. */
+
+/* A (output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On exit, the triangular matrix A. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of the array A contains */
+/* the upper triangular matrix, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of the array A contains */
+/* the lower triangular matrix, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Notes */
+/* ===== */
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* even. We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* the transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* the transpose of the last three columns of AP lower. */
+/* This covers the case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 03 04 05 33 43 53 */
+/* 13 14 15 00 44 54 */
+/* 23 24 25 10 11 55 */
+/* 33 34 35 20 21 22 */
+/* 00 44 45 30 31 32 */
+/* 01 11 55 40 41 42 */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* odd. We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* the transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* the transpose of the last two columns of AP lower. */
+/* This covers the case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 02 03 04 00 33 43 */
+/* 12 13 14 10 11 44 */
+/* 22 23 24 20 21 22 */
+/* 00 33 34 30 31 32 */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+/* RFP A RFP A */
+
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* Reference */
+/* ========= */
+
+/* ===================================================================== */
+
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda - 1 - 0 + 1;
+ a_offset = 0 + a_dim1 * 0;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "T")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTFTTR", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 1) {
+ if (*n == 1) {
+ a[0] = arf[0];
+ }
+ return 0;
+ }
+
+/* Size of array ARF(0:nt-1) */
+
+ nt = *n * (*n + 1) / 2;
+
+/* set N1 and N2 depending on LOWER: for N even N1=N2=K */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. */
+/* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is */
+/* N--by--(N+1)/2. */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ if (! lower) {
+ np1x2 = *n + *n + 2;
+ }
+ } else {
+ nisodd = TRUE_;
+ if (! lower) {
+ nx2 = *n + *n;
+ }
+ }
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* N is odd, TRANSR = 'N', and UPLO = 'L' */
+
+ ij = 0;
+ i__1 = n2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = n2 + j;
+ for (i__ = n1; i__ <= i__2; ++i__) {
+ a[n2 + j + i__ * a_dim1] = arf[ij];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = arf[ij];
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* N is odd, TRANSR = 'N', and UPLO = 'U' */
+
+ ij = nt - *n;
+ i__1 = n1;
+ for (j = *n - 1; j >= i__1; --j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = arf[ij];
+ ++ij;
+ }
+ i__2 = n1 - 1;
+ for (l = j - n1; l <= i__2; ++l) {
+ a[j - n1 + l * a_dim1] = arf[ij];
+ ++ij;
+ }
+ ij -= nx2;
+ }
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'T' */
+
+ if (lower) {
+
+/* N is odd, TRANSR = 'T', and UPLO = 'L' */
+
+ ij = 0;
+ i__1 = n2 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ a[j + i__ * a_dim1] = arf[ij];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = n1 + j; i__ <= i__2; ++i__) {
+ a[i__ + (n1 + j) * a_dim1] = arf[ij];
+ ++ij;
+ }
+ }
+ i__1 = *n - 1;
+ for (j = n2; j <= i__1; ++j) {
+ i__2 = n1 - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ a[j + i__ * a_dim1] = arf[ij];
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* N is odd, TRANSR = 'T', and UPLO = 'U' */
+
+ ij = 0;
+ i__1 = n1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = n1; i__ <= i__2; ++i__) {
+ a[j + i__ * a_dim1] = arf[ij];
+ ++ij;
+ }
+ }
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = arf[ij];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (l = n2 + j; l <= i__2; ++l) {
+ a[n2 + j + l * a_dim1] = arf[ij];
+ ++ij;
+ }
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* N is even, TRANSR = 'N', and UPLO = 'L' */
+
+ ij = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k + j;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ a[k + j + i__ * a_dim1] = arf[ij];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = arf[ij];
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* N is even, TRANSR = 'N', and UPLO = 'U' */
+
+ ij = nt - *n - 1;
+ i__1 = k;
+ for (j = *n - 1; j >= i__1; --j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = arf[ij];
+ ++ij;
+ }
+ i__2 = k - 1;
+ for (l = j - k; l <= i__2; ++l) {
+ a[j - k + l * a_dim1] = arf[ij];
+ ++ij;
+ }
+ ij -= np1x2;
+ }
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'T' */
+
+ if (lower) {
+
+/* N is even, TRANSR = 'T', and UPLO = 'L' */
+
+ ij = 0;
+ j = k;
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ a[i__ + j * a_dim1] = arf[ij];
+ ++ij;
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ a[j + i__ * a_dim1] = arf[ij];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = k + 1 + j; i__ <= i__2; ++i__) {
+ a[i__ + (k + 1 + j) * a_dim1] = arf[ij];
+ ++ij;
+ }
+ }
+ i__1 = *n - 1;
+ for (j = k - 1; j <= i__1; ++j) {
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ a[j + i__ * a_dim1] = arf[ij];
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* N is even, TRANSR = 'T', and UPLO = 'U' */
+
+ ij = 0;
+ i__1 = k;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ a[j + i__ * a_dim1] = arf[ij];
+ ++ij;
+ }
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = arf[ij];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (l = k + 1 + j; l <= i__2; ++l) {
+ a[k + 1 + j + l * a_dim1] = arf[ij];
+ ++ij;
+ }
+ }
+/* Note that here, on exit of the loop, J = K-1 */
+ i__1 = j;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ a[i__ + j * a_dim1] = arf[ij];
+ ++ij;
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of DTFTTR */
+
+} /* dtfttr_ */
diff --git a/SRC/dtgevc.c b/SRC/dtgevc.c
new file mode 100644
index 0000000..e411ffc
--- /dev/null
+++ b/SRC/dtgevc.c
@@ -0,0 +1,1418 @@
+/* dtgevc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static logical c_true = TRUE_;
+static integer c__2 = 2;
+static doublereal c_b34 = 1.;
+static integer c__1 = 1;
+static doublereal c_b36 = 0.;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int dtgevc_(char *side, char *howmny, logical *select,
+ integer *n, doublereal *s, integer *lds, doublereal *p, integer *ldp,
+ doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, integer
+ *mm, integer *m, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer p_dim1, p_offset, s_dim1, s_offset, vl_dim1, vl_offset, vr_dim1,
+ vr_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6;
+
+ /* Local variables */
+ integer i__, j, ja, jc, je, na, im, jr, jw, nw;
+ doublereal big;
+ logical lsa, lsb;
+ doublereal ulp, sum[4] /* was [2][2] */;
+ integer ibeg, ieig, iend;
+ doublereal dmin__, temp, xmax, sump[4] /* was [2][2] */, sums[4]
+ /* was [2][2] */;
+ extern /* Subroutine */ int dlag2_(doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *);
+ doublereal cim2a, cim2b, cre2a, cre2b, temp2, bdiag[2], acoef, scale;
+ logical ilall;
+ integer iside;
+ doublereal sbeta;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ logical il2by2;
+ integer iinfo;
+ doublereal small;
+ logical compl;
+ doublereal anorm, bnorm;
+ logical compr;
+ extern /* Subroutine */ int dlaln2_(logical *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *
+, doublereal *, integer *, doublereal *, doublereal *, integer *);
+ doublereal temp2i;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ doublereal temp2r;
+ logical ilabad, ilbbad;
+ doublereal acoefa, bcoefa, cimaga, cimagb;
+ logical ilback;
+ doublereal bcoefi, ascale, bscale, creala, crealb;
+ extern doublereal dlamch_(char *);
+ doublereal bcoefr, salfar, safmin;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ doublereal xscale, bignum;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical ilcomp, ilcplx;
+ integer ihwmny;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+
+/* Purpose */
+/* ======= */
+
+/* DTGEVC computes some or all of the right and/or left eigenvectors of */
+/* a pair of real matrices (S,P), where S is a quasi-triangular matrix */
+/* and P is upper triangular. Matrix pairs of this type are produced by */
+/* the generalized Schur factorization of a matrix pair (A,B): */
+
+/* A = Q*S*Z**T, B = Q*P*Z**T */
+
+/* as computed by DGGHRD + DHGEQZ. */
+
+/* The right eigenvector x and the left eigenvector y of (S,P) */
+/* corresponding to an eigenvalue w are defined by: */
+
+/* S*x = w*P*x, (y**H)*S = w*(y**H)*P, */
+
+/* where y**H denotes the conjugate tranpose of y. */
+/* The eigenvalues are not input to this routine, but are computed */
+/* directly from the diagonal blocks of S and P. */
+
+/* This routine returns the matrices X and/or Y of right and left */
+/* eigenvectors of (S,P), or the products Z*X and/or Q*Y, */
+/* where Z and Q are input matrices. */
+/* If Q and Z are the orthogonal factors from the generalized Schur */
+/* factorization of a matrix pair (A,B), then Z*X and Q*Y */
+/* are the matrices of right and left eigenvectors of (A,B). */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'R': compute right eigenvectors only; */
+/* = 'L': compute left eigenvectors only; */
+/* = 'B': compute both right and left eigenvectors. */
+
+/* HOWMNY (input) CHARACTER*1 */
+/* = 'A': compute all right and/or left eigenvectors; */
+/* = 'B': compute all right and/or left eigenvectors, */
+/* backtransformed by the matrices in VR and/or VL; */
+/* = 'S': compute selected right and/or left eigenvectors, */
+/* specified by the logical array SELECT. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* If HOWMNY='S', SELECT specifies the eigenvectors to be */
+/* computed. If w(j) is a real eigenvalue, the corresponding */
+/* real eigenvector is computed if SELECT(j) is .TRUE.. */
+/* If w(j) and w(j+1) are the real and imaginary parts of a */
+/* complex eigenvalue, the corresponding complex eigenvector */
+/* is computed if either SELECT(j) or SELECT(j+1) is .TRUE., */
+/* and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is */
+/* set to .FALSE.. */
+/* Not referenced if HOWMNY = 'A' or 'B'. */
+
+/* N (input) INTEGER */
+/* The order of the matrices S and P. N >= 0. */
+
+/* S (input) DOUBLE PRECISION array, dimension (LDS,N) */
+/* The upper quasi-triangular matrix S from a generalized Schur */
+/* factorization, as computed by DHGEQZ. */
+
+/* LDS (input) INTEGER */
+/* The leading dimension of array S. LDS >= max(1,N). */
+
+/* P (input) DOUBLE PRECISION array, dimension (LDP,N) */
+/* The upper triangular matrix P from a generalized Schur */
+/* factorization, as computed by DHGEQZ. */
+/* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks */
+/* of S must be in positive diagonal form. */
+
+/* LDP (input) INTEGER */
+/* The leading dimension of array P. LDP >= max(1,N). */
+
+/* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM) */
+/* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */
+/* contain an N-by-N matrix Q (usually the orthogonal matrix Q */
+/* of left Schur vectors returned by DHGEQZ). */
+/* On exit, if SIDE = 'L' or 'B', VL contains: */
+/* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); */
+/* if HOWMNY = 'B', the matrix Q*Y; */
+/* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by */
+/* SELECT, stored consecutively in the columns of */
+/* VL, in the same order as their eigenvalues. */
+
+/* A complex eigenvector corresponding to a complex eigenvalue */
+/* is stored in two consecutive columns, the first holding the */
+/* real part, and the second the imaginary part. */
+
+/* Not referenced if SIDE = 'R'. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of array VL. LDVL >= 1, and if */
+/* SIDE = 'L' or 'B', LDVL >= N. */
+
+/* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) */
+/* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */
+/* contain an N-by-N matrix Z (usually the orthogonal matrix Z */
+/* of right Schur vectors returned by DHGEQZ). */
+
+/* On exit, if SIDE = 'R' or 'B', VR contains: */
+/* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); */
+/* if HOWMNY = 'B' or 'b', the matrix Z*X; */
+/* if HOWMNY = 'S' or 's', the right eigenvectors of (S,P) */
+/* specified by SELECT, stored consecutively in the */
+/* columns of VR, in the same order as their */
+/* eigenvalues. */
+
+/* A complex eigenvector corresponding to a complex eigenvalue */
+/* is stored in two consecutive columns, the first holding the */
+/* real part and the second the imaginary part. */
+
+/* Not referenced if SIDE = 'L'. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. LDVR >= 1, and if */
+/* SIDE = 'R' or 'B', LDVR >= N. */
+
+/* MM (input) INTEGER */
+/* The number of columns in the arrays VL and/or VR. MM >= M. */
+
+/* M (output) INTEGER */
+/* The number of columns in the arrays VL and/or VR actually */
+/* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M */
+/* is set to N. Each selected real eigenvector occupies one */
+/* column and each selected complex eigenvector occupies two */
+/* columns. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (6*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex */
+/* eigenvalue. */
+
+/* Further Details */
+/* =============== */
+
+/* Allocation of workspace: */
+/* ---------- -- --------- */
+
+/* WORK( j ) = 1-norm of j-th column of A, above the diagonal */
+/* WORK( N+j ) = 1-norm of j-th column of B, above the diagonal */
+/* WORK( 2*N+1:3*N ) = real part of eigenvector */
+/* WORK( 3*N+1:4*N ) = imaginary part of eigenvector */
+/* WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector */
+/* WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector */
+
+/* Rowwise vs. columnwise solution methods: */
+/* ------- -- ---------- -------- ------- */
+
+/* Finding a generalized eigenvector consists basically of solving the */
+/* singular triangular system */
+
+/* (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left) */
+
+/* Consider finding the i-th right eigenvector (assume all eigenvalues */
+/* are real). The equation to be solved is: */
+/* n i */
+/* 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1 */
+/* k=j k=j */
+
+/* where C = (A - w B) (The components v(i+1:n) are 0.) */
+
+/* The "rowwise" method is: */
+
+/* (1) v(i) := 1 */
+/* for j = i-1,. . .,1: */
+/* i */
+/* (2) compute s = - sum C(j,k) v(k) and */
+/* k=j+1 */
+
+/* (3) v(j) := s / C(j,j) */
+
+/* Step 2 is sometimes called the "dot product" step, since it is an */
+/* inner product between the j-th row and the portion of the eigenvector */
+/* that has been computed so far. */
+
+/* The "columnwise" method consists basically in doing the sums */
+/* for all the rows in parallel. As each v(j) is computed, the */
+/* contribution of v(j) times the j-th column of C is added to the */
+/* partial sums. Since FORTRAN arrays are stored columnwise, this has */
+/* the advantage that at each step, the elements of C that are accessed */
+/* are adjacent to one another, whereas with the rowwise method, the */
+/* elements accessed at a step are spaced LDS (and LDP) words apart. */
+
+/* When finding left eigenvectors, the matrix in question is the */
+/* transpose of the one in storage, so the rowwise method then */
+/* actually accesses columns of A and B at each step, and so is the */
+/* preferred method. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and Test the input parameters */
+
+ /* Parameter adjustments */
+ --select;
+ s_dim1 = *lds;
+ s_offset = 1 + s_dim1;
+ s -= s_offset;
+ p_dim1 = *ldp;
+ p_offset = 1 + p_dim1;
+ p -= p_offset;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+
+ /* Function Body */
+ if (lsame_(howmny, "A")) {
+ ihwmny = 1;
+ ilall = TRUE_;
+ ilback = FALSE_;
+ } else if (lsame_(howmny, "S")) {
+ ihwmny = 2;
+ ilall = FALSE_;
+ ilback = FALSE_;
+ } else if (lsame_(howmny, "B")) {
+ ihwmny = 3;
+ ilall = TRUE_;
+ ilback = TRUE_;
+ } else {
+ ihwmny = -1;
+ ilall = TRUE_;
+ }
+
+ if (lsame_(side, "R")) {
+ iside = 1;
+ compl = FALSE_;
+ compr = TRUE_;
+ } else if (lsame_(side, "L")) {
+ iside = 2;
+ compl = TRUE_;
+ compr = FALSE_;
+ } else if (lsame_(side, "B")) {
+ iside = 3;
+ compl = TRUE_;
+ compr = TRUE_;
+ } else {
+ iside = -1;
+ }
+
+ *info = 0;
+ if (iside < 0) {
+ *info = -1;
+ } else if (ihwmny < 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lds < max(1,*n)) {
+ *info = -6;
+ } else if (*ldp < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTGEVC", &i__1);
+ return 0;
+ }
+
+/* Count the number of eigenvectors to be computed */
+
+ if (! ilall) {
+ im = 0;
+ ilcplx = FALSE_;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (ilcplx) {
+ ilcplx = FALSE_;
+ goto L10;
+ }
+ if (j < *n) {
+ if (s[j + 1 + j * s_dim1] != 0.) {
+ ilcplx = TRUE_;
+ }
+ }
+ if (ilcplx) {
+ if (select[j] || select[j + 1]) {
+ im += 2;
+ }
+ } else {
+ if (select[j]) {
+ ++im;
+ }
+ }
+L10:
+ ;
+ }
+ } else {
+ im = *n;
+ }
+
+/* Check 2-by-2 diagonal blocks of A, B */
+
+ ilabad = FALSE_;
+ ilbbad = FALSE_;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ if (s[j + 1 + j * s_dim1] != 0.) {
+ if (p[j + j * p_dim1] == 0. || p[j + 1 + (j + 1) * p_dim1] == 0.
+ || p[j + (j + 1) * p_dim1] != 0.) {
+ ilbbad = TRUE_;
+ }
+ if (j < *n - 1) {
+ if (s[j + 2 + (j + 1) * s_dim1] != 0.) {
+ ilabad = TRUE_;
+ }
+ }
+ }
+/* L20: */
+ }
+
+ if (ilabad) {
+ *info = -5;
+ } else if (ilbbad) {
+ *info = -7;
+ } else if (compl && *ldvl < *n || *ldvl < 1) {
+ *info = -10;
+ } else if (compr && *ldvr < *n || *ldvr < 1) {
+ *info = -12;
+ } else if (*mm < im) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTGEVC", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = im;
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Machine Constants */
+
+ safmin = dlamch_("Safe minimum");
+ big = 1. / safmin;
+ dlabad_(&safmin, &big);
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ small = safmin * *n / ulp;
+ big = 1. / small;
+ bignum = 1. / (safmin * *n);
+
+/* Compute the 1-norm of each column of the strictly upper triangular */
+/* part (i.e., excluding all elements belonging to the diagonal */
+/* blocks) of A and B to check for possible overflow in the */
+/* triangular solver. */
+
+ anorm = (d__1 = s[s_dim1 + 1], abs(d__1));
+ if (*n > 1) {
+ anorm += (d__1 = s[s_dim1 + 2], abs(d__1));
+ }
+ bnorm = (d__1 = p[p_dim1 + 1], abs(d__1));
+ work[1] = 0.;
+ work[*n + 1] = 0.;
+
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ temp = 0.;
+ temp2 = 0.;
+ if (s[j + (j - 1) * s_dim1] == 0.) {
+ iend = j - 1;
+ } else {
+ iend = j - 2;
+ }
+ i__2 = iend;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp += (d__1 = s[i__ + j * s_dim1], abs(d__1));
+ temp2 += (d__1 = p[i__ + j * p_dim1], abs(d__1));
+/* L30: */
+ }
+ work[j] = temp;
+ work[*n + j] = temp2;
+/* Computing MIN */
+ i__3 = j + 1;
+ i__2 = min(i__3,*n);
+ for (i__ = iend + 1; i__ <= i__2; ++i__) {
+ temp += (d__1 = s[i__ + j * s_dim1], abs(d__1));
+ temp2 += (d__1 = p[i__ + j * p_dim1], abs(d__1));
+/* L40: */
+ }
+ anorm = max(anorm,temp);
+ bnorm = max(bnorm,temp2);
+/* L50: */
+ }
+
+ ascale = 1. / max(anorm,safmin);
+ bscale = 1. / max(bnorm,safmin);
+
+/* Left eigenvectors */
+
+ if (compl) {
+ ieig = 0;
+
+/* Main loop over eigenvalues */
+
+ ilcplx = FALSE_;
+ i__1 = *n;
+ for (je = 1; je <= i__1; ++je) {
+
+/* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or */
+/* (b) this would be the second of a complex pair. */
+/* Check for complex eigenvalue, so as to be sure of which */
+/* entry(-ies) of SELECT to look at. */
+
+ if (ilcplx) {
+ ilcplx = FALSE_;
+ goto L220;
+ }
+ nw = 1;
+ if (je < *n) {
+ if (s[je + 1 + je * s_dim1] != 0.) {
+ ilcplx = TRUE_;
+ nw = 2;
+ }
+ }
+ if (ilall) {
+ ilcomp = TRUE_;
+ } else if (ilcplx) {
+ ilcomp = select[je] || select[je + 1];
+ } else {
+ ilcomp = select[je];
+ }
+ if (! ilcomp) {
+ goto L220;
+ }
+
+/* Decide if (a) singular pencil, (b) real eigenvalue, or */
+/* (c) complex eigenvalue. */
+
+ if (! ilcplx) {
+ if ((d__1 = s[je + je * s_dim1], abs(d__1)) <= safmin && (
+ d__2 = p[je + je * p_dim1], abs(d__2)) <= safmin) {
+
+/* Singular matrix pencil -- return unit eigenvector */
+
+ ++ieig;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vl[jr + ieig * vl_dim1] = 0.;
+/* L60: */
+ }
+ vl[ieig + ieig * vl_dim1] = 1.;
+ goto L220;
+ }
+ }
+
+/* Clear vector */
+
+ i__2 = nw * *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ work[(*n << 1) + jr] = 0.;
+/* L70: */
+ }
+/* T */
+/* Compute coefficients in ( a A - b B ) y = 0 */
+/* a is ACOEF */
+/* b is BCOEFR + i*BCOEFI */
+
+ if (! ilcplx) {
+
+/* Real eigenvalue */
+
+/* Computing MAX */
+ d__3 = (d__1 = s[je + je * s_dim1], abs(d__1)) * ascale, d__4
+ = (d__2 = p[je + je * p_dim1], abs(d__2)) * bscale,
+ d__3 = max(d__3,d__4);
+ temp = 1. / max(d__3,safmin);
+ salfar = temp * s[je + je * s_dim1] * ascale;
+ sbeta = temp * p[je + je * p_dim1] * bscale;
+ acoef = sbeta * ascale;
+ bcoefr = salfar * bscale;
+ bcoefi = 0.;
+
+/* Scale to avoid underflow */
+
+ scale = 1.;
+ lsa = abs(sbeta) >= safmin && abs(acoef) < small;
+ lsb = abs(salfar) >= safmin && abs(bcoefr) < small;
+ if (lsa) {
+ scale = small / abs(sbeta) * min(anorm,big);
+ }
+ if (lsb) {
+/* Computing MAX */
+ d__1 = scale, d__2 = small / abs(salfar) * min(bnorm,big);
+ scale = max(d__1,d__2);
+ }
+ if (lsa || lsb) {
+/* Computing MIN */
+/* Computing MAX */
+ d__3 = 1., d__4 = abs(acoef), d__3 = max(d__3,d__4), d__4
+ = abs(bcoefr);
+ d__1 = scale, d__2 = 1. / (safmin * max(d__3,d__4));
+ scale = min(d__1,d__2);
+ if (lsa) {
+ acoef = ascale * (scale * sbeta);
+ } else {
+ acoef = scale * acoef;
+ }
+ if (lsb) {
+ bcoefr = bscale * (scale * salfar);
+ } else {
+ bcoefr = scale * bcoefr;
+ }
+ }
+ acoefa = abs(acoef);
+ bcoefa = abs(bcoefr);
+
+/* First component is 1 */
+
+ work[(*n << 1) + je] = 1.;
+ xmax = 1.;
+ } else {
+
+/* Complex eigenvalue */
+
+ d__1 = safmin * 100.;
+ dlag2_(&s[je + je * s_dim1], lds, &p[je + je * p_dim1], ldp, &
+ d__1, &acoef, &temp, &bcoefr, &temp2, &bcoefi);
+ bcoefi = -bcoefi;
+ if (bcoefi == 0.) {
+ *info = je;
+ return 0;
+ }
+
+/* Scale to avoid over/underflow */
+
+ acoefa = abs(acoef);
+ bcoefa = abs(bcoefr) + abs(bcoefi);
+ scale = 1.;
+ if (acoefa * ulp < safmin && acoefa >= safmin) {
+ scale = safmin / ulp / acoefa;
+ }
+ if (bcoefa * ulp < safmin && bcoefa >= safmin) {
+/* Computing MAX */
+ d__1 = scale, d__2 = safmin / ulp / bcoefa;
+ scale = max(d__1,d__2);
+ }
+ if (safmin * acoefa > ascale) {
+ scale = ascale / (safmin * acoefa);
+ }
+ if (safmin * bcoefa > bscale) {
+/* Computing MIN */
+ d__1 = scale, d__2 = bscale / (safmin * bcoefa);
+ scale = min(d__1,d__2);
+ }
+ if (scale != 1.) {
+ acoef = scale * acoef;
+ acoefa = abs(acoef);
+ bcoefr = scale * bcoefr;
+ bcoefi = scale * bcoefi;
+ bcoefa = abs(bcoefr) + abs(bcoefi);
+ }
+
+/* Compute first two components of eigenvector */
+
+ temp = acoef * s[je + 1 + je * s_dim1];
+ temp2r = acoef * s[je + je * s_dim1] - bcoefr * p[je + je *
+ p_dim1];
+ temp2i = -bcoefi * p[je + je * p_dim1];
+ if (abs(temp) > abs(temp2r) + abs(temp2i)) {
+ work[(*n << 1) + je] = 1.;
+ work[*n * 3 + je] = 0.;
+ work[(*n << 1) + je + 1] = -temp2r / temp;
+ work[*n * 3 + je + 1] = -temp2i / temp;
+ } else {
+ work[(*n << 1) + je + 1] = 1.;
+ work[*n * 3 + je + 1] = 0.;
+ temp = acoef * s[je + (je + 1) * s_dim1];
+ work[(*n << 1) + je] = (bcoefr * p[je + 1 + (je + 1) *
+ p_dim1] - acoef * s[je + 1 + (je + 1) * s_dim1]) /
+ temp;
+ work[*n * 3 + je] = bcoefi * p[je + 1 + (je + 1) * p_dim1]
+ / temp;
+ }
+/* Computing MAX */
+ d__5 = (d__1 = work[(*n << 1) + je], abs(d__1)) + (d__2 =
+ work[*n * 3 + je], abs(d__2)), d__6 = (d__3 = work[(*
+ n << 1) + je + 1], abs(d__3)) + (d__4 = work[*n * 3 +
+ je + 1], abs(d__4));
+ xmax = max(d__5,d__6);
+ }
+
+/* Computing MAX */
+ d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm, d__1 =
+ max(d__1,d__2);
+ dmin__ = max(d__1,safmin);
+
+/* T */
+/* Triangular solve of (a A - b B) y = 0 */
+
+/* T */
+/* (rowwise in (a A - b B) , or columnwise in (a A - b B) ) */
+
+ il2by2 = FALSE_;
+
+ i__2 = *n;
+ for (j = je + nw; j <= i__2; ++j) {
+ if (il2by2) {
+ il2by2 = FALSE_;
+ goto L160;
+ }
+
+ na = 1;
+ bdiag[0] = p[j + j * p_dim1];
+ if (j < *n) {
+ if (s[j + 1 + j * s_dim1] != 0.) {
+ il2by2 = TRUE_;
+ bdiag[1] = p[j + 1 + (j + 1) * p_dim1];
+ na = 2;
+ }
+ }
+
+/* Check whether scaling is necessary for dot products */
+
+ xscale = 1. / max(1.,xmax);
+/* Computing MAX */
+ d__1 = work[j], d__2 = work[*n + j], d__1 = max(d__1,d__2),
+ d__2 = acoefa * work[j] + bcoefa * work[*n + j];
+ temp = max(d__1,d__2);
+ if (il2by2) {
+/* Computing MAX */
+ d__1 = temp, d__2 = work[j + 1], d__1 = max(d__1,d__2),
+ d__2 = work[*n + j + 1], d__1 = max(d__1,d__2),
+ d__2 = acoefa * work[j + 1] + bcoefa * work[*n +
+ j + 1];
+ temp = max(d__1,d__2);
+ }
+ if (temp > bignum * xscale) {
+ i__3 = nw - 1;
+ for (jw = 0; jw <= i__3; ++jw) {
+ i__4 = j - 1;
+ for (jr = je; jr <= i__4; ++jr) {
+ work[(jw + 2) * *n + jr] = xscale * work[(jw + 2)
+ * *n + jr];
+/* L80: */
+ }
+/* L90: */
+ }
+ xmax *= xscale;
+ }
+
+/* Compute dot products */
+
+/* j-1 */
+/* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) */
+/* k=je */
+
+/* To reduce the op count, this is done as */
+
+/* _ j-1 _ j-1 */
+/* a*conjg( sum S(k,j)*x(k) ) - b*conjg( sum P(k,j)*x(k) ) */
+/* k=je k=je */
+
+/* which may cause underflow problems if A or B are close */
+/* to underflow. (E.g., less than SMALL.) */
+
+
+/* A series of compiler directives to defeat vectorization */
+/* for the next loop */
+
+/* $PL$ CMCHAR=' ' */
+/* DIR$ NEXTSCALAR */
+/* $DIR SCALAR */
+/* DIR$ NEXT SCALAR */
+/* VD$L NOVECTOR */
+/* DEC$ NOVECTOR */
+/* VD$ NOVECTOR */
+/* VDIR NOVECTOR */
+/* VOCL LOOP,SCALAR */
+/* IBM PREFER SCALAR */
+/* $PL$ CMCHAR='*' */
+
+ i__3 = nw;
+ for (jw = 1; jw <= i__3; ++jw) {
+
+/* $PL$ CMCHAR=' ' */
+/* DIR$ NEXTSCALAR */
+/* $DIR SCALAR */
+/* DIR$ NEXT SCALAR */
+/* VD$L NOVECTOR */
+/* DEC$ NOVECTOR */
+/* VD$ NOVECTOR */
+/* VDIR NOVECTOR */
+/* VOCL LOOP,SCALAR */
+/* IBM PREFER SCALAR */
+/* $PL$ CMCHAR='*' */
+
+ i__4 = na;
+ for (ja = 1; ja <= i__4; ++ja) {
+ sums[ja + (jw << 1) - 3] = 0.;
+ sump[ja + (jw << 1) - 3] = 0.;
+
+ i__5 = j - 1;
+ for (jr = je; jr <= i__5; ++jr) {
+ sums[ja + (jw << 1) - 3] += s[jr + (j + ja - 1) *
+ s_dim1] * work[(jw + 1) * *n + jr];
+ sump[ja + (jw << 1) - 3] += p[jr + (j + ja - 1) *
+ p_dim1] * work[(jw + 1) * *n + jr];
+/* L100: */
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+
+/* $PL$ CMCHAR=' ' */
+/* DIR$ NEXTSCALAR */
+/* $DIR SCALAR */
+/* DIR$ NEXT SCALAR */
+/* VD$L NOVECTOR */
+/* DEC$ NOVECTOR */
+/* VD$ NOVECTOR */
+/* VDIR NOVECTOR */
+/* VOCL LOOP,SCALAR */
+/* IBM PREFER SCALAR */
+/* $PL$ CMCHAR='*' */
+
+ i__3 = na;
+ for (ja = 1; ja <= i__3; ++ja) {
+ if (ilcplx) {
+ sum[ja - 1] = -acoef * sums[ja - 1] + bcoefr * sump[
+ ja - 1] - bcoefi * sump[ja + 1];
+ sum[ja + 1] = -acoef * sums[ja + 1] + bcoefr * sump[
+ ja + 1] + bcoefi * sump[ja - 1];
+ } else {
+ sum[ja - 1] = -acoef * sums[ja - 1] + bcoefr * sump[
+ ja - 1];
+ }
+/* L130: */
+ }
+
+/* T */
+/* Solve ( a A - b B ) y = SUM(,) */
+/* with scaling and perturbation of the denominator */
+
+ dlaln2_(&c_true, &na, &nw, &dmin__, &acoef, &s[j + j * s_dim1]
+, lds, bdiag, &bdiag[1], sum, &c__2, &bcoefr, &bcoefi,
+ &work[(*n << 1) + j], n, &scale, &temp, &iinfo);
+ if (scale < 1.) {
+ i__3 = nw - 1;
+ for (jw = 0; jw <= i__3; ++jw) {
+ i__4 = j - 1;
+ for (jr = je; jr <= i__4; ++jr) {
+ work[(jw + 2) * *n + jr] = scale * work[(jw + 2) *
+ *n + jr];
+/* L140: */
+ }
+/* L150: */
+ }
+ xmax = scale * xmax;
+ }
+ xmax = max(xmax,temp);
+L160:
+ ;
+ }
+
+/* Copy eigenvector to VL, back transforming if */
+/* HOWMNY='B'. */
+
+ ++ieig;
+ if (ilback) {
+ i__2 = nw - 1;
+ for (jw = 0; jw <= i__2; ++jw) {
+ i__3 = *n + 1 - je;
+ dgemv_("N", n, &i__3, &c_b34, &vl[je * vl_dim1 + 1], ldvl,
+ &work[(jw + 2) * *n + je], &c__1, &c_b36, &work[(
+ jw + 4) * *n + 1], &c__1);
+/* L170: */
+ }
+ dlacpy_(" ", n, &nw, &work[(*n << 2) + 1], n, &vl[je *
+ vl_dim1 + 1], ldvl);
+ ibeg = 1;
+ } else {
+ dlacpy_(" ", n, &nw, &work[(*n << 1) + 1], n, &vl[ieig *
+ vl_dim1 + 1], ldvl);
+ ibeg = je;
+ }
+
+/* Scale eigenvector */
+
+ xmax = 0.;
+ if (ilcplx) {
+ i__2 = *n;
+ for (j = ibeg; j <= i__2; ++j) {
+/* Computing MAX */
+ d__3 = xmax, d__4 = (d__1 = vl[j + ieig * vl_dim1], abs(
+ d__1)) + (d__2 = vl[j + (ieig + 1) * vl_dim1],
+ abs(d__2));
+ xmax = max(d__3,d__4);
+/* L180: */
+ }
+ } else {
+ i__2 = *n;
+ for (j = ibeg; j <= i__2; ++j) {
+/* Computing MAX */
+ d__2 = xmax, d__3 = (d__1 = vl[j + ieig * vl_dim1], abs(
+ d__1));
+ xmax = max(d__2,d__3);
+/* L190: */
+ }
+ }
+
+ if (xmax > safmin) {
+ xscale = 1. / xmax;
+
+ i__2 = nw - 1;
+ for (jw = 0; jw <= i__2; ++jw) {
+ i__3 = *n;
+ for (jr = ibeg; jr <= i__3; ++jr) {
+ vl[jr + (ieig + jw) * vl_dim1] = xscale * vl[jr + (
+ ieig + jw) * vl_dim1];
+/* L200: */
+ }
+/* L210: */
+ }
+ }
+ ieig = ieig + nw - 1;
+
+L220:
+ ;
+ }
+ }
+
+/* Right eigenvectors */
+
+ if (compr) {
+ ieig = im + 1;
+
+/* Main loop over eigenvalues */
+
+ ilcplx = FALSE_;
+ for (je = *n; je >= 1; --je) {
+
+/* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or */
+/* (b) this would be the second of a complex pair. */
+/* Check for complex eigenvalue, so as to be sure of which */
+/* entry(-ies) of SELECT to look at -- if complex, SELECT(JE) */
+/* or SELECT(JE-1). */
+/* If this is a complex pair, the 2-by-2 diagonal block */
+/* corresponding to the eigenvalue is in rows/columns JE-1:JE */
+
+ if (ilcplx) {
+ ilcplx = FALSE_;
+ goto L500;
+ }
+ nw = 1;
+ if (je > 1) {
+ if (s[je + (je - 1) * s_dim1] != 0.) {
+ ilcplx = TRUE_;
+ nw = 2;
+ }
+ }
+ if (ilall) {
+ ilcomp = TRUE_;
+ } else if (ilcplx) {
+ ilcomp = select[je] || select[je - 1];
+ } else {
+ ilcomp = select[je];
+ }
+ if (! ilcomp) {
+ goto L500;
+ }
+
+/* Decide if (a) singular pencil, (b) real eigenvalue, or */
+/* (c) complex eigenvalue. */
+
+ if (! ilcplx) {
+ if ((d__1 = s[je + je * s_dim1], abs(d__1)) <= safmin && (
+ d__2 = p[je + je * p_dim1], abs(d__2)) <= safmin) {
+
+/* Singular matrix pencil -- unit eigenvector */
+
+ --ieig;
+ i__1 = *n;
+ for (jr = 1; jr <= i__1; ++jr) {
+ vr[jr + ieig * vr_dim1] = 0.;
+/* L230: */
+ }
+ vr[ieig + ieig * vr_dim1] = 1.;
+ goto L500;
+ }
+ }
+
+/* Clear vector */
+
+ i__1 = nw - 1;
+ for (jw = 0; jw <= i__1; ++jw) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ work[(jw + 2) * *n + jr] = 0.;
+/* L240: */
+ }
+/* L250: */
+ }
+
+/* Compute coefficients in ( a A - b B ) x = 0 */
+/* a is ACOEF */
+/* b is BCOEFR + i*BCOEFI */
+
+ if (! ilcplx) {
+
+/* Real eigenvalue */
+
+/* Computing MAX */
+ d__3 = (d__1 = s[je + je * s_dim1], abs(d__1)) * ascale, d__4
+ = (d__2 = p[je + je * p_dim1], abs(d__2)) * bscale,
+ d__3 = max(d__3,d__4);
+ temp = 1. / max(d__3,safmin);
+ salfar = temp * s[je + je * s_dim1] * ascale;
+ sbeta = temp * p[je + je * p_dim1] * bscale;
+ acoef = sbeta * ascale;
+ bcoefr = salfar * bscale;
+ bcoefi = 0.;
+
+/* Scale to avoid underflow */
+
+ scale = 1.;
+ lsa = abs(sbeta) >= safmin && abs(acoef) < small;
+ lsb = abs(salfar) >= safmin && abs(bcoefr) < small;
+ if (lsa) {
+ scale = small / abs(sbeta) * min(anorm,big);
+ }
+ if (lsb) {
+/* Computing MAX */
+ d__1 = scale, d__2 = small / abs(salfar) * min(bnorm,big);
+ scale = max(d__1,d__2);
+ }
+ if (lsa || lsb) {
+/* Computing MIN */
+/* Computing MAX */
+ d__3 = 1., d__4 = abs(acoef), d__3 = max(d__3,d__4), d__4
+ = abs(bcoefr);
+ d__1 = scale, d__2 = 1. / (safmin * max(d__3,d__4));
+ scale = min(d__1,d__2);
+ if (lsa) {
+ acoef = ascale * (scale * sbeta);
+ } else {
+ acoef = scale * acoef;
+ }
+ if (lsb) {
+ bcoefr = bscale * (scale * salfar);
+ } else {
+ bcoefr = scale * bcoefr;
+ }
+ }
+ acoefa = abs(acoef);
+ bcoefa = abs(bcoefr);
+
+/* First component is 1 */
+
+ work[(*n << 1) + je] = 1.;
+ xmax = 1.;
+
+/* Compute contribution from column JE of A and B to sum */
+/* (See "Further Details", above.) */
+
+ i__1 = je - 1;
+ for (jr = 1; jr <= i__1; ++jr) {
+ work[(*n << 1) + jr] = bcoefr * p[jr + je * p_dim1] -
+ acoef * s[jr + je * s_dim1];
+/* L260: */
+ }
+ } else {
+
+/* Complex eigenvalue */
+
+ d__1 = safmin * 100.;
+ dlag2_(&s[je - 1 + (je - 1) * s_dim1], lds, &p[je - 1 + (je -
+ 1) * p_dim1], ldp, &d__1, &acoef, &temp, &bcoefr, &
+ temp2, &bcoefi);
+ if (bcoefi == 0.) {
+ *info = je - 1;
+ return 0;
+ }
+
+/* Scale to avoid over/underflow */
+
+ acoefa = abs(acoef);
+ bcoefa = abs(bcoefr) + abs(bcoefi);
+ scale = 1.;
+ if (acoefa * ulp < safmin && acoefa >= safmin) {
+ scale = safmin / ulp / acoefa;
+ }
+ if (bcoefa * ulp < safmin && bcoefa >= safmin) {
+/* Computing MAX */
+ d__1 = scale, d__2 = safmin / ulp / bcoefa;
+ scale = max(d__1,d__2);
+ }
+ if (safmin * acoefa > ascale) {
+ scale = ascale / (safmin * acoefa);
+ }
+ if (safmin * bcoefa > bscale) {
+/* Computing MIN */
+ d__1 = scale, d__2 = bscale / (safmin * bcoefa);
+ scale = min(d__1,d__2);
+ }
+ if (scale != 1.) {
+ acoef = scale * acoef;
+ acoefa = abs(acoef);
+ bcoefr = scale * bcoefr;
+ bcoefi = scale * bcoefi;
+ bcoefa = abs(bcoefr) + abs(bcoefi);
+ }
+
+/* Compute first two components of eigenvector */
+/* and contribution to sums */
+
+ temp = acoef * s[je + (je - 1) * s_dim1];
+ temp2r = acoef * s[je + je * s_dim1] - bcoefr * p[je + je *
+ p_dim1];
+ temp2i = -bcoefi * p[je + je * p_dim1];
+ if (abs(temp) >= abs(temp2r) + abs(temp2i)) {
+ work[(*n << 1) + je] = 1.;
+ work[*n * 3 + je] = 0.;
+ work[(*n << 1) + je - 1] = -temp2r / temp;
+ work[*n * 3 + je - 1] = -temp2i / temp;
+ } else {
+ work[(*n << 1) + je - 1] = 1.;
+ work[*n * 3 + je - 1] = 0.;
+ temp = acoef * s[je - 1 + je * s_dim1];
+ work[(*n << 1) + je] = (bcoefr * p[je - 1 + (je - 1) *
+ p_dim1] - acoef * s[je - 1 + (je - 1) * s_dim1]) /
+ temp;
+ work[*n * 3 + je] = bcoefi * p[je - 1 + (je - 1) * p_dim1]
+ / temp;
+ }
+
+/* Computing MAX */
+ d__5 = (d__1 = work[(*n << 1) + je], abs(d__1)) + (d__2 =
+ work[*n * 3 + je], abs(d__2)), d__6 = (d__3 = work[(*
+ n << 1) + je - 1], abs(d__3)) + (d__4 = work[*n * 3 +
+ je - 1], abs(d__4));
+ xmax = max(d__5,d__6);
+
+/* Compute contribution from columns JE and JE-1 */
+/* of A and B to the sums. */
+
+ creala = acoef * work[(*n << 1) + je - 1];
+ cimaga = acoef * work[*n * 3 + je - 1];
+ crealb = bcoefr * work[(*n << 1) + je - 1] - bcoefi * work[*n
+ * 3 + je - 1];
+ cimagb = bcoefi * work[(*n << 1) + je - 1] + bcoefr * work[*n
+ * 3 + je - 1];
+ cre2a = acoef * work[(*n << 1) + je];
+ cim2a = acoef * work[*n * 3 + je];
+ cre2b = bcoefr * work[(*n << 1) + je] - bcoefi * work[*n * 3
+ + je];
+ cim2b = bcoefi * work[(*n << 1) + je] + bcoefr * work[*n * 3
+ + je];
+ i__1 = je - 2;
+ for (jr = 1; jr <= i__1; ++jr) {
+ work[(*n << 1) + jr] = -creala * s[jr + (je - 1) * s_dim1]
+ + crealb * p[jr + (je - 1) * p_dim1] - cre2a * s[
+ jr + je * s_dim1] + cre2b * p[jr + je * p_dim1];
+ work[*n * 3 + jr] = -cimaga * s[jr + (je - 1) * s_dim1] +
+ cimagb * p[jr + (je - 1) * p_dim1] - cim2a * s[jr
+ + je * s_dim1] + cim2b * p[jr + je * p_dim1];
+/* L270: */
+ }
+ }
+
+/* Computing MAX */
+ d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm, d__1 =
+ max(d__1,d__2);
+ dmin__ = max(d__1,safmin);
+
+/* Columnwise triangular solve of (a A - b B) x = 0 */
+
+ il2by2 = FALSE_;
+ for (j = je - nw; j >= 1; --j) {
+
+/* If a 2-by-2 block, is in position j-1:j, wait until */
+/* next iteration to process it (when it will be j:j+1) */
+
+ if (! il2by2 && j > 1) {
+ if (s[j + (j - 1) * s_dim1] != 0.) {
+ il2by2 = TRUE_;
+ goto L370;
+ }
+ }
+ bdiag[0] = p[j + j * p_dim1];
+ if (il2by2) {
+ na = 2;
+ bdiag[1] = p[j + 1 + (j + 1) * p_dim1];
+ } else {
+ na = 1;
+ }
+
+/* Compute x(j) (and x(j+1), if 2-by-2 block) */
+
+ dlaln2_(&c_false, &na, &nw, &dmin__, &acoef, &s[j + j *
+ s_dim1], lds, bdiag, &bdiag[1], &work[(*n << 1) + j],
+ n, &bcoefr, &bcoefi, sum, &c__2, &scale, &temp, &
+ iinfo);
+ if (scale < 1.) {
+
+ i__1 = nw - 1;
+ for (jw = 0; jw <= i__1; ++jw) {
+ i__2 = je;
+ for (jr = 1; jr <= i__2; ++jr) {
+ work[(jw + 2) * *n + jr] = scale * work[(jw + 2) *
+ *n + jr];
+/* L280: */
+ }
+/* L290: */
+ }
+ }
+/* Computing MAX */
+ d__1 = scale * xmax;
+ xmax = max(d__1,temp);
+
+ i__1 = nw;
+ for (jw = 1; jw <= i__1; ++jw) {
+ i__2 = na;
+ for (ja = 1; ja <= i__2; ++ja) {
+ work[(jw + 1) * *n + j + ja - 1] = sum[ja + (jw << 1)
+ - 3];
+/* L300: */
+ }
+/* L310: */
+ }
+
+/* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling */
+
+ if (j > 1) {
+
+/* Check whether scaling is necessary for sum. */
+
+ xscale = 1. / max(1.,xmax);
+ temp = acoefa * work[j] + bcoefa * work[*n + j];
+ if (il2by2) {
+/* Computing MAX */
+ d__1 = temp, d__2 = acoefa * work[j + 1] + bcoefa *
+ work[*n + j + 1];
+ temp = max(d__1,d__2);
+ }
+/* Computing MAX */
+ d__1 = max(temp,acoefa);
+ temp = max(d__1,bcoefa);
+ if (temp > bignum * xscale) {
+
+ i__1 = nw - 1;
+ for (jw = 0; jw <= i__1; ++jw) {
+ i__2 = je;
+ for (jr = 1; jr <= i__2; ++jr) {
+ work[(jw + 2) * *n + jr] = xscale * work[(jw
+ + 2) * *n + jr];
+/* L320: */
+ }
+/* L330: */
+ }
+ xmax *= xscale;
+ }
+
+/* Compute the contributions of the off-diagonals of */
+/* column j (and j+1, if 2-by-2 block) of A and B to the */
+/* sums. */
+
+
+ i__1 = na;
+ for (ja = 1; ja <= i__1; ++ja) {
+ if (ilcplx) {
+ creala = acoef * work[(*n << 1) + j + ja - 1];
+ cimaga = acoef * work[*n * 3 + j + ja - 1];
+ crealb = bcoefr * work[(*n << 1) + j + ja - 1] -
+ bcoefi * work[*n * 3 + j + ja - 1];
+ cimagb = bcoefi * work[(*n << 1) + j + ja - 1] +
+ bcoefr * work[*n * 3 + j + ja - 1];
+ i__2 = j - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ work[(*n << 1) + jr] = work[(*n << 1) + jr] -
+ creala * s[jr + (j + ja - 1) * s_dim1]
+ + crealb * p[jr + (j + ja - 1) *
+ p_dim1];
+ work[*n * 3 + jr] = work[*n * 3 + jr] -
+ cimaga * s[jr + (j + ja - 1) * s_dim1]
+ + cimagb * p[jr + (j + ja - 1) *
+ p_dim1];
+/* L340: */
+ }
+ } else {
+ creala = acoef * work[(*n << 1) + j + ja - 1];
+ crealb = bcoefr * work[(*n << 1) + j + ja - 1];
+ i__2 = j - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ work[(*n << 1) + jr] = work[(*n << 1) + jr] -
+ creala * s[jr + (j + ja - 1) * s_dim1]
+ + crealb * p[jr + (j + ja - 1) *
+ p_dim1];
+/* L350: */
+ }
+ }
+/* L360: */
+ }
+ }
+
+ il2by2 = FALSE_;
+L370:
+ ;
+ }
+
+/* Copy eigenvector to VR, back transforming if */
+/* HOWMNY='B'. */
+
+ ieig -= nw;
+ if (ilback) {
+
+ i__1 = nw - 1;
+ for (jw = 0; jw <= i__1; ++jw) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ work[(jw + 4) * *n + jr] = work[(jw + 2) * *n + 1] *
+ vr[jr + vr_dim1];
+/* L380: */
+ }
+
+/* A series of compiler directives to defeat */
+/* vectorization for the next loop */
+
+
+ i__2 = je;
+ for (jc = 2; jc <= i__2; ++jc) {
+ i__3 = *n;
+ for (jr = 1; jr <= i__3; ++jr) {
+ work[(jw + 4) * *n + jr] += work[(jw + 2) * *n +
+ jc] * vr[jr + jc * vr_dim1];
+/* L390: */
+ }
+/* L400: */
+ }
+/* L410: */
+ }
+
+ i__1 = nw - 1;
+ for (jw = 0; jw <= i__1; ++jw) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vr[jr + (ieig + jw) * vr_dim1] = work[(jw + 4) * *n +
+ jr];
+/* L420: */
+ }
+/* L430: */
+ }
+
+ iend = *n;
+ } else {
+ i__1 = nw - 1;
+ for (jw = 0; jw <= i__1; ++jw) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vr[jr + (ieig + jw) * vr_dim1] = work[(jw + 2) * *n +
+ jr];
+/* L440: */
+ }
+/* L450: */
+ }
+
+ iend = je;
+ }
+
+/* Scale eigenvector */
+
+ xmax = 0.;
+ if (ilcplx) {
+ i__1 = iend;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ d__3 = xmax, d__4 = (d__1 = vr[j + ieig * vr_dim1], abs(
+ d__1)) + (d__2 = vr[j + (ieig + 1) * vr_dim1],
+ abs(d__2));
+ xmax = max(d__3,d__4);
+/* L460: */
+ }
+ } else {
+ i__1 = iend;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ d__2 = xmax, d__3 = (d__1 = vr[j + ieig * vr_dim1], abs(
+ d__1));
+ xmax = max(d__2,d__3);
+/* L470: */
+ }
+ }
+
+ if (xmax > safmin) {
+ xscale = 1. / xmax;
+ i__1 = nw - 1;
+ for (jw = 0; jw <= i__1; ++jw) {
+ i__2 = iend;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vr[jr + (ieig + jw) * vr_dim1] = xscale * vr[jr + (
+ ieig + jw) * vr_dim1];
+/* L480: */
+ }
+/* L490: */
+ }
+ }
+L500:
+ ;
+ }
+ }
+
+ return 0;
+
+/* End of DTGEVC */
+
+} /* dtgevc_ */
diff --git a/SRC/dtgex2.c b/SRC/dtgex2.c
new file mode 100644
index 0000000..52d2b9f
--- /dev/null
+++ b/SRC/dtgex2.c
@@ -0,0 +1,711 @@
+/* dtgex2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__4 = 4;
+static doublereal c_b5 = 0.;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static doublereal c_b42 = 1.;
+static doublereal c_b48 = -1.;
+static integer c__0 = 0;
+
+/* Subroutine */ int dtgex2_(logical *wantq, logical *wantz, integer *n,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
+ q, integer *ldq, doublereal *z__, integer *ldz, integer *j1, integer *
+ n1, integer *n2, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
+ z_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal f, g;
+ integer i__, m;
+ doublereal s[16] /* was [4][4] */, t[16] /* was [4][4] */, be[2], ai[2]
+ , ar[2], sa, sb, li[16] /* was [4][4] */, ir[16] /*
+ was [4][4] */, ss, ws, eps;
+ logical weak;
+ doublereal ddum;
+ integer idum;
+ doublereal taul[4], dsum;
+ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ doublereal taur[4], scpy[16] /* was [4][4] */, tcpy[16] /*
+ was [4][4] */;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal scale, bqra21, brqa21;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ doublereal licop[16] /* was [4][4] */;
+ integer linfo;
+ doublereal ircop[16] /* was [4][4] */, dnorm;
+ integer iwork[4];
+ extern /* Subroutine */ int dlagv2_(doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *
+, doublereal *, doublereal *, doublereal *), dgeqr2_(integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *), dgerq2_(integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dorg2r_(integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *), dorgr2_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *),
+ dorm2r_(char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), dormr2_(char *, char *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *), dtgsy2_(char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal dscale;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *), dlaset_(char *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *), dlassq_(integer *
+, doublereal *, integer *, doublereal *, doublereal *);
+ logical dtrong;
+ doublereal thresh, smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22) */
+/* of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair */
+/* (A, B) by an orthogonal equivalence transformation. */
+
+/* (A, B) must be in generalized real Schur canonical form (as returned */
+/* by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 */
+/* diagonal blocks. B is upper triangular. */
+
+/* Optionally, the matrices Q and Z of generalized Schur vectors are */
+/* updated. */
+
+/* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' */
+/* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' */
+
+
+/* Arguments */
+/* ========= */
+
+/* WANTQ (input) LOGICAL */
+/* .TRUE. : update the left transformation matrix Q; */
+/* .FALSE.: do not update Q. */
+
+/* WANTZ (input) LOGICAL */
+/* .TRUE. : update the right transformation matrix Z; */
+/* .FALSE.: do not update Z. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION arrays, dimensions (LDA,N) */
+/* On entry, the matrix A in the pair (A, B). */
+/* On exit, the updated matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) DOUBLE PRECISION arrays, dimensions (LDB,N) */
+/* On entry, the matrix B in the pair (A, B). */
+/* On exit, the updated matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Q (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
+/* On entry, if WANTQ = .TRUE., the orthogonal matrix Q. */
+/* On exit, the updated matrix Q. */
+/* Not referenced if WANTQ = .FALSE.. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= 1. */
+/* If WANTQ = .TRUE., LDQ >= N. */
+
+/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
+/* On entry, if WANTZ =.TRUE., the orthogonal matrix Z. */
+/* On exit, the updated matrix Z. */
+/* Not referenced if WANTZ = .FALSE.. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1. */
+/* If WANTZ = .TRUE., LDZ >= N. */
+
+/* J1 (input) INTEGER */
+/* The index to the first block (A11, B11). 1 <= J1 <= N. */
+
+/* N1 (input) INTEGER */
+/* The order of the first block (A11, B11). N1 = 0, 1 or 2. */
+
+/* N2 (input) INTEGER */
+/* The order of the second block (A22, B22). N2 = 0, 1 or 2. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)). */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* LWORK >= MAX( 1, N*(N2+N1), (N2+N1)*(N2+N1)*2 ) */
+
+/* INFO (output) INTEGER */
+/* =0: Successful exit */
+/* >0: If INFO = 1, the transformed matrix (A, B) would be */
+/* too far from generalized Schur form; the blocks are */
+/* not swapped and (A, B) and (Q, Z) are unchanged. */
+/* The problem of swapping is too ill-conditioned. */
+/* <0: If INFO = -16: LWORK is too small. Appropriate value */
+/* for LWORK is returned in WORK(1). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* In the current code both weak and strong stability tests are */
+/* performed. The user can omit the strong stability test by changing */
+/* the internal logical parameter WANDS to .FALSE.. See ref. [2] for */
+/* details. */
+
+/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
+/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
+/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
+/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
+
+/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
+/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
+/* Estimation: Theory, Algorithms and Software, */
+/* Report UMINF - 94.04, Department of Computing Science, Umea */
+/* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */
+/* Note 87. To appear in Numerical Algorithms, 1996. */
+
+/* ===================================================================== */
+/* Replaced various illegal calls to DCOPY by calls to DLASET, or by DO */
+/* loops. Sven Hammarling, 1/5/02. */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n <= 1 || *n1 <= 0 || *n2 <= 0) {
+ return 0;
+ }
+ if (*n1 > *n || *j1 + *n1 > *n) {
+ return 0;
+ }
+ m = *n1 + *n2;
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * m, i__1 = max(i__1,i__2), i__2 = m * m << 1;
+ if (*lwork < max(i__1,i__2)) {
+ *info = -16;
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * m, i__1 = max(i__1,i__2), i__2 = m * m << 1;
+ work[1] = (doublereal) max(i__1,i__2);
+ return 0;
+ }
+
+ weak = FALSE_;
+ dtrong = FALSE_;
+
+/* Make a local copy of selected block */
+
+ dlaset_("Full", &c__4, &c__4, &c_b5, &c_b5, li, &c__4);
+ dlaset_("Full", &c__4, &c__4, &c_b5, &c_b5, ir, &c__4);
+ dlacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, s, &c__4);
+ dlacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, t, &c__4);
+
+/* Compute threshold for testing acceptance of swapping. */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S") / eps;
+ dscale = 0.;
+ dsum = 1.;
+ dlacpy_("Full", &m, &m, s, &c__4, &work[1], &m);
+ i__1 = m * m;
+ dlassq_(&i__1, &work[1], &c__1, &dscale, &dsum);
+ dlacpy_("Full", &m, &m, t, &c__4, &work[1], &m);
+ i__1 = m * m;
+ dlassq_(&i__1, &work[1], &c__1, &dscale, &dsum);
+ dnorm = dscale * sqrt(dsum);
+/* Computing MAX */
+ d__1 = eps * 10. * dnorm;
+ thresh = max(d__1,smlnum);
+
+ if (m == 2) {
+
+/* CASE 1: Swap 1-by-1 and 1-by-1 blocks. */
+
+/* Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks */
+/* using Givens rotations and perform the swap tentatively. */
+
+ f = s[5] * t[0] - t[5] * s[0];
+ g = s[5] * t[4] - t[5] * s[4];
+ sb = abs(t[5]);
+ sa = abs(s[5]);
+ dlartg_(&f, &g, &ir[4], ir, &ddum);
+ ir[1] = -ir[4];
+ ir[5] = ir[0];
+ drot_(&c__2, s, &c__1, &s[4], &c__1, ir, &ir[1]);
+ drot_(&c__2, t, &c__1, &t[4], &c__1, ir, &ir[1]);
+ if (sa >= sb) {
+ dlartg_(s, &s[1], li, &li[1], &ddum);
+ } else {
+ dlartg_(t, &t[1], li, &li[1], &ddum);
+ }
+ drot_(&c__2, s, &c__4, &s[1], &c__4, li, &li[1]);
+ drot_(&c__2, t, &c__4, &t[1], &c__4, li, &li[1]);
+ li[5] = li[0];
+ li[4] = -li[1];
+
+/* Weak stability test: */
+/* |S21| + |T21| <= O(EPS * F-norm((S, T))) */
+
+ ws = abs(s[1]) + abs(t[1]);
+ weak = ws <= thresh;
+ if (! weak) {
+ goto L70;
+ }
+
+ if (TRUE_) {
+
+/* Strong stability test: */
+/* F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A,B))) */
+
+ dlacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, &work[m * m
+ + 1], &m);
+ dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, &
+ work[1], &m);
+ dgemm_("N", "T", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
+ c_b42, &work[m * m + 1], &m);
+ dscale = 0.;
+ dsum = 1.;
+ i__1 = m * m;
+ dlassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
+
+ dlacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, &work[m * m
+ + 1], &m);
+ dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, &
+ work[1], &m);
+ dgemm_("N", "T", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
+ c_b42, &work[m * m + 1], &m);
+ i__1 = m * m;
+ dlassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
+ ss = dscale * sqrt(dsum);
+ dtrong = ss <= thresh;
+ if (! dtrong) {
+ goto L70;
+ }
+ }
+
+/* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and */
+/* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */
+
+ i__1 = *j1 + 1;
+ drot_(&i__1, &a[*j1 * a_dim1 + 1], &c__1, &a[(*j1 + 1) * a_dim1 + 1],
+ &c__1, ir, &ir[1]);
+ i__1 = *j1 + 1;
+ drot_(&i__1, &b[*j1 * b_dim1 + 1], &c__1, &b[(*j1 + 1) * b_dim1 + 1],
+ &c__1, ir, &ir[1]);
+ i__1 = *n - *j1 + 1;
+ drot_(&i__1, &a[*j1 + *j1 * a_dim1], lda, &a[*j1 + 1 + *j1 * a_dim1],
+ lda, li, &li[1]);
+ i__1 = *n - *j1 + 1;
+ drot_(&i__1, &b[*j1 + *j1 * b_dim1], ldb, &b[*j1 + 1 + *j1 * b_dim1],
+ ldb, li, &li[1]);
+
+/* Set N1-by-N2 (2,1) - blocks to ZERO. */
+
+ a[*j1 + 1 + *j1 * a_dim1] = 0.;
+ b[*j1 + 1 + *j1 * b_dim1] = 0.;
+
+/* Accumulate transformations into Q and Z if requested. */
+
+ if (*wantz) {
+ drot_(n, &z__[*j1 * z_dim1 + 1], &c__1, &z__[(*j1 + 1) * z_dim1 +
+ 1], &c__1, ir, &ir[1]);
+ }
+ if (*wantq) {
+ drot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[(*j1 + 1) * q_dim1 + 1],
+ &c__1, li, &li[1]);
+ }
+
+/* Exit with INFO = 0 if swap was successfully performed. */
+
+ return 0;
+
+ } else {
+
+/* CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2 */
+/* and 2-by-2 blocks. */
+
+/* Solve the generalized Sylvester equation */
+/* S11 * R - L * S22 = SCALE * S12 */
+/* T11 * R - L * T22 = SCALE * T12 */
+/* for R and L. Solutions in LI and IR. */
+
+ dlacpy_("Full", n1, n2, &t[(*n1 + 1 << 2) - 4], &c__4, li, &c__4);
+ dlacpy_("Full", n1, n2, &s[(*n1 + 1 << 2) - 4], &c__4, &ir[*n2 + 1 + (
+ *n1 + 1 << 2) - 5], &c__4);
+ dtgsy2_("N", &c__0, n1, n2, s, &c__4, &s[*n1 + 1 + (*n1 + 1 << 2) - 5]
+, &c__4, &ir[*n2 + 1 + (*n1 + 1 << 2) - 5], &c__4, t, &c__4, &
+ t[*n1 + 1 + (*n1 + 1 << 2) - 5], &c__4, li, &c__4, &scale, &
+ dsum, &dscale, iwork, &idum, &linfo);
+
+/* Compute orthogonal matrix QL: */
+
+/* QL' * LI = [ TL ] */
+/* [ 0 ] */
+/* where */
+/* LI = [ -L ] */
+/* [ SCALE * identity(N2) ] */
+
+ i__1 = *n2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dscal_(n1, &c_b48, &li[(i__ << 2) - 4], &c__1);
+ li[*n1 + i__ + (i__ << 2) - 5] = scale;
+/* L10: */
+ }
+ dgeqr2_(&m, n2, li, &c__4, taul, &work[1], &linfo);
+ if (linfo != 0) {
+ goto L70;
+ }
+ dorg2r_(&m, &m, n2, li, &c__4, taul, &work[1], &linfo);
+ if (linfo != 0) {
+ goto L70;
+ }
+
+/* Compute orthogonal matrix RQ: */
+
+/* IR * RQ' = [ 0 TR], */
+
+/* where IR = [ SCALE * identity(N1), R ] */
+
+ i__1 = *n1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ir[*n2 + i__ + (i__ << 2) - 5] = scale;
+/* L20: */
+ }
+ dgerq2_(n1, &m, &ir[*n2], &c__4, taur, &work[1], &linfo);
+ if (linfo != 0) {
+ goto L70;
+ }
+ dorgr2_(&m, &m, n1, ir, &c__4, taur, &work[1], &linfo);
+ if (linfo != 0) {
+ goto L70;
+ }
+
+/* Perform the swapping tentatively: */
+
+ dgemm_("T", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, &
+ work[1], &m);
+ dgemm_("N", "T", &m, &m, &m, &c_b42, &work[1], &m, ir, &c__4, &c_b5,
+ s, &c__4);
+ dgemm_("T", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, &
+ work[1], &m);
+ dgemm_("N", "T", &m, &m, &m, &c_b42, &work[1], &m, ir, &c__4, &c_b5,
+ t, &c__4);
+ dlacpy_("F", &m, &m, s, &c__4, scpy, &c__4);
+ dlacpy_("F", &m, &m, t, &c__4, tcpy, &c__4);
+ dlacpy_("F", &m, &m, ir, &c__4, ircop, &c__4);
+ dlacpy_("F", &m, &m, li, &c__4, licop, &c__4);
+
+/* Triangularize the B-part by an RQ factorization. */
+/* Apply transformation (from left) to A-part, giving S. */
+
+ dgerq2_(&m, &m, t, &c__4, taur, &work[1], &linfo);
+ if (linfo != 0) {
+ goto L70;
+ }
+ dormr2_("R", "T", &m, &m, &m, t, &c__4, taur, s, &c__4, &work[1], &
+ linfo);
+ if (linfo != 0) {
+ goto L70;
+ }
+ dormr2_("L", "N", &m, &m, &m, t, &c__4, taur, ir, &c__4, &work[1], &
+ linfo);
+ if (linfo != 0) {
+ goto L70;
+ }
+
+/* Compute F-norm(S21) in BRQA21. (T21 is 0.) */
+
+ dscale = 0.;
+ dsum = 1.;
+ i__1 = *n2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dlassq_(n1, &s[*n2 + 1 + (i__ << 2) - 5], &c__1, &dscale, &dsum);
+/* L30: */
+ }
+ brqa21 = dscale * sqrt(dsum);
+
+/* Triangularize the B-part by a QR factorization. */
+/* Apply transformation (from right) to A-part, giving S. */
+
+ dgeqr2_(&m, &m, tcpy, &c__4, taul, &work[1], &linfo);
+ if (linfo != 0) {
+ goto L70;
+ }
+ dorm2r_("L", "T", &m, &m, &m, tcpy, &c__4, taul, scpy, &c__4, &work[1]
+, info);
+ dorm2r_("R", "N", &m, &m, &m, tcpy, &c__4, taul, licop, &c__4, &work[
+ 1], info);
+ if (linfo != 0) {
+ goto L70;
+ }
+
+/* Compute F-norm(S21) in BQRA21. (T21 is 0.) */
+
+ dscale = 0.;
+ dsum = 1.;
+ i__1 = *n2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dlassq_(n1, &scpy[*n2 + 1 + (i__ << 2) - 5], &c__1, &dscale, &
+ dsum);
+/* L40: */
+ }
+ bqra21 = dscale * sqrt(dsum);
+
+/* Decide which method to use. */
+/* Weak stability test: */
+/* F-norm(S21) <= O(EPS * F-norm((S, T))) */
+
+ if (bqra21 <= brqa21 && bqra21 <= thresh) {
+ dlacpy_("F", &m, &m, scpy, &c__4, s, &c__4);
+ dlacpy_("F", &m, &m, tcpy, &c__4, t, &c__4);
+ dlacpy_("F", &m, &m, ircop, &c__4, ir, &c__4);
+ dlacpy_("F", &m, &m, licop, &c__4, li, &c__4);
+ } else if (brqa21 >= thresh) {
+ goto L70;
+ }
+
+/* Set lower triangle of B-part to zero */
+
+ i__1 = m - 1;
+ i__2 = m - 1;
+ dlaset_("Lower", &i__1, &i__2, &c_b5, &c_b5, &t[1], &c__4);
+
+ if (TRUE_) {
+
+/* Strong stability test: */
+/* F-norm((A-QL*S*QR', B-QL*T*QR')) <= O(EPS*F-norm((A,B))) */
+
+ dlacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, &work[m * m
+ + 1], &m);
+ dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, &
+ work[1], &m);
+ dgemm_("N", "N", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
+ c_b42, &work[m * m + 1], &m);
+ dscale = 0.;
+ dsum = 1.;
+ i__1 = m * m;
+ dlassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
+
+ dlacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, &work[m * m
+ + 1], &m);
+ dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, &
+ work[1], &m);
+ dgemm_("N", "N", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
+ c_b42, &work[m * m + 1], &m);
+ i__1 = m * m;
+ dlassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
+ ss = dscale * sqrt(dsum);
+ dtrong = ss <= thresh;
+ if (! dtrong) {
+ goto L70;
+ }
+
+ }
+
+/* If the swap is accepted ("weakly" and "strongly"), apply the */
+/* transformations and set N1-by-N2 (2,1)-block to zero. */
+
+ dlaset_("Full", n1, n2, &c_b5, &c_b5, &s[*n2], &c__4);
+
+/* copy back M-by-M diagonal block starting at index J1 of (A, B) */
+
+ dlacpy_("F", &m, &m, s, &c__4, &a[*j1 + *j1 * a_dim1], lda)
+ ;
+ dlacpy_("F", &m, &m, t, &c__4, &b[*j1 + *j1 * b_dim1], ldb)
+ ;
+ dlaset_("Full", &c__4, &c__4, &c_b5, &c_b5, t, &c__4);
+
+/* Standardize existing 2-by-2 blocks. */
+
+ i__1 = m * m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L50: */
+ }
+ work[1] = 1.;
+ t[0] = 1.;
+ idum = *lwork - m * m - 2;
+ if (*n2 > 1) {
+ dlagv2_(&a[*j1 + *j1 * a_dim1], lda, &b[*j1 + *j1 * b_dim1], ldb,
+ ar, ai, be, &work[1], &work[2], t, &t[1]);
+ work[m + 1] = -work[2];
+ work[m + 2] = work[1];
+ t[*n2 + (*n2 << 2) - 5] = t[0];
+ t[4] = -t[1];
+ }
+ work[m * m] = 1.;
+ t[m + (m << 2) - 5] = 1.;
+
+ if (*n1 > 1) {
+ dlagv2_(&a[*j1 + *n2 + (*j1 + *n2) * a_dim1], lda, &b[*j1 + *n2 +
+ (*j1 + *n2) * b_dim1], ldb, taur, taul, &work[m * m + 1],
+ &work[*n2 * m + *n2 + 1], &work[*n2 * m + *n2 + 2], &t[*
+ n2 + 1 + (*n2 + 1 << 2) - 5], &t[m + (m - 1 << 2) - 5]);
+ work[m * m] = work[*n2 * m + *n2 + 1];
+ work[m * m - 1] = -work[*n2 * m + *n2 + 2];
+ t[m + (m << 2) - 5] = t[*n2 + 1 + (*n2 + 1 << 2) - 5];
+ t[m - 1 + (m << 2) - 5] = -t[m + (m - 1 << 2) - 5];
+ }
+ dgemm_("T", "N", n2, n1, n2, &c_b42, &work[1], &m, &a[*j1 + (*j1 + *
+ n2) * a_dim1], lda, &c_b5, &work[m * m + 1], n2);
+ dlacpy_("Full", n2, n1, &work[m * m + 1], n2, &a[*j1 + (*j1 + *n2) *
+ a_dim1], lda);
+ dgemm_("T", "N", n2, n1, n2, &c_b42, &work[1], &m, &b[*j1 + (*j1 + *
+ n2) * b_dim1], ldb, &c_b5, &work[m * m + 1], n2);
+ dlacpy_("Full", n2, n1, &work[m * m + 1], n2, &b[*j1 + (*j1 + *n2) *
+ b_dim1], ldb);
+ dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, &work[1], &m, &c_b5, &
+ work[m * m + 1], &m);
+ dlacpy_("Full", &m, &m, &work[m * m + 1], &m, li, &c__4);
+ dgemm_("N", "N", n2, n1, n1, &c_b42, &a[*j1 + (*j1 + *n2) * a_dim1],
+ lda, &t[*n2 + 1 + (*n2 + 1 << 2) - 5], &c__4, &c_b5, &work[1],
+ n2);
+ dlacpy_("Full", n2, n1, &work[1], n2, &a[*j1 + (*j1 + *n2) * a_dim1],
+ lda);
+ dgemm_("N", "N", n2, n1, n1, &c_b42, &b[*j1 + (*j1 + *n2) * b_dim1],
+ ldb, &t[*n2 + 1 + (*n2 + 1 << 2) - 5], &c__4, &c_b5, &work[1],
+ n2);
+ dlacpy_("Full", n2, n1, &work[1], n2, &b[*j1 + (*j1 + *n2) * b_dim1],
+ ldb);
+ dgemm_("T", "N", &m, &m, &m, &c_b42, ir, &c__4, t, &c__4, &c_b5, &
+ work[1], &m);
+ dlacpy_("Full", &m, &m, &work[1], &m, ir, &c__4);
+
+/* Accumulate transformations into Q and Z if requested. */
+
+ if (*wantq) {
+ dgemm_("N", "N", n, &m, &m, &c_b42, &q[*j1 * q_dim1 + 1], ldq, li,
+ &c__4, &c_b5, &work[1], n);
+ dlacpy_("Full", n, &m, &work[1], n, &q[*j1 * q_dim1 + 1], ldq);
+
+ }
+
+ if (*wantz) {
+ dgemm_("N", "N", n, &m, &m, &c_b42, &z__[*j1 * z_dim1 + 1], ldz,
+ ir, &c__4, &c_b5, &work[1], n);
+ dlacpy_("Full", n, &m, &work[1], n, &z__[*j1 * z_dim1 + 1], ldz);
+
+ }
+
+/* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and */
+/* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */
+
+ i__ = *j1 + m;
+ if (i__ <= *n) {
+ i__1 = *n - i__ + 1;
+ dgemm_("T", "N", &m, &i__1, &m, &c_b42, li, &c__4, &a[*j1 + i__ *
+ a_dim1], lda, &c_b5, &work[1], &m);
+ i__1 = *n - i__ + 1;
+ dlacpy_("Full", &m, &i__1, &work[1], &m, &a[*j1 + i__ * a_dim1],
+ lda);
+ i__1 = *n - i__ + 1;
+ dgemm_("T", "N", &m, &i__1, &m, &c_b42, li, &c__4, &b[*j1 + i__ *
+ b_dim1], lda, &c_b5, &work[1], &m);
+ i__1 = *n - i__ + 1;
+ dlacpy_("Full", &m, &i__1, &work[1], &m, &b[*j1 + i__ * b_dim1],
+ ldb);
+ }
+ i__ = *j1 - 1;
+ if (i__ > 0) {
+ dgemm_("N", "N", &i__, &m, &m, &c_b42, &a[*j1 * a_dim1 + 1], lda,
+ ir, &c__4, &c_b5, &work[1], &i__);
+ dlacpy_("Full", &i__, &m, &work[1], &i__, &a[*j1 * a_dim1 + 1],
+ lda);
+ dgemm_("N", "N", &i__, &m, &m, &c_b42, &b[*j1 * b_dim1 + 1], ldb,
+ ir, &c__4, &c_b5, &work[1], &i__);
+ dlacpy_("Full", &i__, &m, &work[1], &i__, &b[*j1 * b_dim1 + 1],
+ ldb);
+ }
+
+/* Exit with INFO = 0 if swap was successfully performed. */
+
+ return 0;
+
+ }
+
+/* Exit with INFO = 1 if swap was rejected. */
+
+L70:
+
+ *info = 1;
+ return 0;
+
+/* End of DTGEX2 */
+
+} /* dtgex2_ */
diff --git a/SRC/dtgexc.c b/SRC/dtgexc.c
new file mode 100644
index 0000000..d816a06
--- /dev/null
+++ b/SRC/dtgexc.c
@@ -0,0 +1,514 @@
+/* dtgexc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int dtgexc_(logical *wantq, logical *wantz, integer *n,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
+ q, integer *ldq, doublereal *z__, integer *ldz, integer *ifst,
+ integer *ilst, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
+ z_offset, i__1;
+
+ /* Local variables */
+ integer nbf, nbl, here, lwmin;
+ extern /* Subroutine */ int dtgex2_(logical *, logical *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, integer *, integer
+ *, doublereal *, integer *, integer *), xerbla_(char *, integer *);
+ integer nbnext;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTGEXC reorders the generalized real Schur decomposition of a real */
+/* matrix pair (A,B) using an orthogonal equivalence transformation */
+
+/* (A, B) = Q * (A, B) * Z', */
+
+/* so that the diagonal block of (A, B) with row index IFST is moved */
+/* to row ILST. */
+
+/* (A, B) must be in generalized real Schur canonical form (as returned */
+/* by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 */
+/* diagonal blocks. B is upper triangular. */
+
+/* Optionally, the matrices Q and Z of generalized Schur vectors are */
+/* updated. */
+
+/* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' */
+/* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' */
+
+
+/* Arguments */
+/* ========= */
+
+/* WANTQ (input) LOGICAL */
+/* .TRUE. : update the left transformation matrix Q; */
+/* .FALSE.: do not update Q. */
+
+/* WANTZ (input) LOGICAL */
+/* .TRUE. : update the right transformation matrix Z; */
+/* .FALSE.: do not update Z. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the matrix A in generalized real Schur canonical */
+/* form. */
+/* On exit, the updated matrix A, again in generalized */
+/* real Schur canonical form. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */
+/* On entry, the matrix B in generalized real Schur canonical */
+/* form (A,B). */
+/* On exit, the updated matrix B, again in generalized */
+/* real Schur canonical form (A,B). */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Q (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
+/* On entry, if WANTQ = .TRUE., the orthogonal matrix Q. */
+/* On exit, the updated matrix Q. */
+/* If WANTQ = .FALSE., Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= 1. */
+/* If WANTQ = .TRUE., LDQ >= N. */
+
+/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
+/* On entry, if WANTZ = .TRUE., the orthogonal matrix Z. */
+/* On exit, the updated matrix Z. */
+/* If WANTZ = .FALSE., Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1. */
+/* If WANTZ = .TRUE., LDZ >= N. */
+
+/* IFST (input/output) INTEGER */
+/* ILST (input/output) INTEGER */
+/* Specify the reordering of the diagonal blocks of (A, B). */
+/* The block with row index IFST is moved to row ILST, by a */
+/* sequence of swapping between adjacent blocks. */
+/* On exit, if IFST pointed on entry to the second row of */
+/* a 2-by-2 block, it is changed to point to the first row; */
+/* ILST always points to the first row of the block in its */
+/* final position (which may differ from its input value by */
+/* +1 or -1). 1 <= IFST, ILST <= N. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* LWORK >= 1 when N <= 1, otherwise LWORK >= 4*N + 16. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* =0: successful exit. */
+/* <0: if INFO = -i, the i-th argument had an illegal value. */
+/* =1: The transformed matrix pair (A, B) would be too far */
+/* from generalized Schur form; the problem is ill- */
+/* conditioned. (A, B) may have been partially reordered, */
+/* and ILST points to the first row of the current */
+/* position of the block being moved. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
+/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
+/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
+/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test input arguments. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldq < 1 || *wantq && *ldq < max(1,*n)) {
+ *info = -9;
+ } else if (*ldz < 1 || *wantz && *ldz < max(1,*n)) {
+ *info = -11;
+ } else if (*ifst < 1 || *ifst > *n) {
+ *info = -12;
+ } else if (*ilst < 1 || *ilst > *n) {
+ *info = -13;
+ }
+
+ if (*info == 0) {
+ if (*n <= 1) {
+ lwmin = 1;
+ } else {
+ lwmin = (*n << 2) + 16;
+ }
+ work[1] = (doublereal) lwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -15;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTGEXC", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 1) {
+ return 0;
+ }
+
+/* Determine the first row of the specified block and find out */
+/* if it is 1-by-1 or 2-by-2. */
+
+ if (*ifst > 1) {
+ if (a[*ifst + (*ifst - 1) * a_dim1] != 0.) {
+ --(*ifst);
+ }
+ }
+ nbf = 1;
+ if (*ifst < *n) {
+ if (a[*ifst + 1 + *ifst * a_dim1] != 0.) {
+ nbf = 2;
+ }
+ }
+
+/* Determine the first row of the final block */
+/* and find out if it is 1-by-1 or 2-by-2. */
+
+ if (*ilst > 1) {
+ if (a[*ilst + (*ilst - 1) * a_dim1] != 0.) {
+ --(*ilst);
+ }
+ }
+ nbl = 1;
+ if (*ilst < *n) {
+ if (a[*ilst + 1 + *ilst * a_dim1] != 0.) {
+ nbl = 2;
+ }
+ }
+ if (*ifst == *ilst) {
+ return 0;
+ }
+
+ if (*ifst < *ilst) {
+
+/* Update ILST. */
+
+ if (nbf == 2 && nbl == 1) {
+ --(*ilst);
+ }
+ if (nbf == 1 && nbl == 2) {
+ ++(*ilst);
+ }
+
+ here = *ifst;
+
+L10:
+
+/* Swap with next one below. */
+
+ if (nbf == 1 || nbf == 2) {
+
+/* Current block either 1-by-1 or 2-by-2. */
+
+ nbnext = 1;
+ if (here + nbf + 1 <= *n) {
+ if (a[here + nbf + 1 + (here + nbf) * a_dim1] != 0.) {
+ nbnext = 2;
+ }
+ }
+ dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[
+ q_offset], ldq, &z__[z_offset], ldz, &here, &nbf, &nbnext,
+ &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ here += nbnext;
+
+/* Test if 2-by-2 block breaks into two 1-by-1 blocks. */
+
+ if (nbf == 2) {
+ if (a[here + 1 + here * a_dim1] == 0.) {
+ nbf = 3;
+ }
+ }
+
+ } else {
+
+/* Current block consists of two 1-by-1 blocks, each of which */
+/* must be swapped individually. */
+
+ nbnext = 1;
+ if (here + 3 <= *n) {
+ if (a[here + 3 + (here + 2) * a_dim1] != 0.) {
+ nbnext = 2;
+ }
+ }
+ i__1 = here + 1;
+ dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[
+ q_offset], ldq, &z__[z_offset], ldz, &i__1, &c__1, &
+ nbnext, &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ if (nbnext == 1) {
+
+/* Swap two 1-by-1 blocks. */
+
+ dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb,
+ &q[q_offset], ldq, &z__[z_offset], ldz, &here, &c__1,
+ &c__1, &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ ++here;
+
+ } else {
+
+/* Recompute NBNEXT in case of 2-by-2 split. */
+
+ if (a[here + 2 + (here + 1) * a_dim1] == 0.) {
+ nbnext = 1;
+ }
+ if (nbnext == 2) {
+
+/* 2-by-2 block did not split. */
+
+ dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
+ ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &
+ here, &c__1, &nbnext, &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ here += 2;
+ } else {
+
+/* 2-by-2 block did split. */
+
+ dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
+ ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &
+ here, &c__1, &c__1, &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ ++here;
+ dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
+ ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &
+ here, &c__1, &c__1, &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ ++here;
+ }
+
+ }
+ }
+ if (here < *ilst) {
+ goto L10;
+ }
+ } else {
+ here = *ifst;
+
+L20:
+
+/* Swap with next one below. */
+
+ if (nbf == 1 || nbf == 2) {
+
+/* Current block either 1-by-1 or 2-by-2. */
+
+ nbnext = 1;
+ if (here >= 3) {
+ if (a[here - 1 + (here - 2) * a_dim1] != 0.) {
+ nbnext = 2;
+ }
+ }
+ i__1 = here - nbnext;
+ dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[
+ q_offset], ldq, &z__[z_offset], ldz, &i__1, &nbnext, &nbf,
+ &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ here -= nbnext;
+
+/* Test if 2-by-2 block breaks into two 1-by-1 blocks. */
+
+ if (nbf == 2) {
+ if (a[here + 1 + here * a_dim1] == 0.) {
+ nbf = 3;
+ }
+ }
+
+ } else {
+
+/* Current block consists of two 1-by-1 blocks, each of which */
+/* must be swapped individually. */
+
+ nbnext = 1;
+ if (here >= 3) {
+ if (a[here - 1 + (here - 2) * a_dim1] != 0.) {
+ nbnext = 2;
+ }
+ }
+ i__1 = here - nbnext;
+ dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[
+ q_offset], ldq, &z__[z_offset], ldz, &i__1, &nbnext, &
+ c__1, &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ if (nbnext == 1) {
+
+/* Swap two 1-by-1 blocks. */
+
+ dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb,
+ &q[q_offset], ldq, &z__[z_offset], ldz, &here, &
+ nbnext, &c__1, &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ --here;
+ } else {
+
+/* Recompute NBNEXT in case of 2-by-2 split. */
+
+ if (a[here + (here - 1) * a_dim1] == 0.) {
+ nbnext = 1;
+ }
+ if (nbnext == 2) {
+
+/* 2-by-2 block did not split. */
+
+ i__1 = here - 1;
+ dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
+ ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &
+ i__1, &c__2, &c__1, &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ here += -2;
+ } else {
+
+/* 2-by-2 block did split. */
+
+ dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
+ ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &
+ here, &c__1, &c__1, &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ --here;
+ dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
+ ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &
+ here, &c__1, &c__1, &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ --here;
+ }
+ }
+ }
+ if (here > *ilst) {
+ goto L20;
+ }
+ }
+ *ilst = here;
+ work[1] = (doublereal) lwmin;
+ return 0;
+
+/* End of DTGEXC */
+
+} /* dtgexc_ */
diff --git a/SRC/dtgsen.c b/SRC/dtgsen.c
new file mode 100644
index 0000000..053390b
--- /dev/null
+++ b/SRC/dtgsen.c
@@ -0,0 +1,836 @@
+/* dtgsen.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static doublereal c_b28 = 1.;
+
+/* Subroutine */ int dtgsen_(integer *ijob, logical *wantq, logical *wantz,
+ logical *select, integer *n, doublereal *a, integer *lda, doublereal *
+ b, integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *
+ beta, doublereal *q, integer *ldq, doublereal *z__, integer *ldz,
+ integer *m, doublereal *pl, doublereal *pr, doublereal *dif,
+ doublereal *work, integer *lwork, integer *iwork, integer *liwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
+ z_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer i__, k, n1, n2, kk, ks, mn2, ijb;
+ doublereal eps;
+ integer kase;
+ logical pair;
+ integer ierr;
+ doublereal dsum;
+ logical swap;
+ extern /* Subroutine */ int dlag2_(doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *);
+ integer isave[3];
+ logical wantd;
+ integer lwmin;
+ logical wantp;
+ extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ logical wantd1, wantd2;
+ extern doublereal dlamch_(char *);
+ doublereal dscale, rdscal;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *), dtgexc_(logical *, logical *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *, doublereal *, integer *, integer *), dlassq_(integer *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ integer liwmin;
+ extern /* Subroutine */ int dtgsyl_(char *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *, integer *);
+ doublereal smlnum;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/* January 2007 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTGSEN reorders the generalized real Schur decomposition of a real */
+/* matrix pair (A, B) (in terms of an orthonormal equivalence trans- */
+/* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues */
+/* appears in the leading diagonal blocks of the upper quasi-triangular */
+/* matrix A and the upper triangular B. The leading columns of Q and */
+/* Z form orthonormal bases of the corresponding left and right eigen- */
+/* spaces (deflating subspaces). (A, B) must be in generalized real */
+/* Schur canonical form (as returned by DGGES), i.e. A is block upper */
+/* triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper */
+/* triangular. */
+
+/* DTGSEN also computes the generalized eigenvalues */
+
+/* w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j) */
+
+/* of the reordered matrix pair (A, B). */
+
+/* Optionally, DTGSEN computes the estimates of reciprocal condition */
+/* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), */
+/* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) */
+/* between the matrix pairs (A11, B11) and (A22,B22) that correspond to */
+/* the selected cluster and the eigenvalues outside the cluster, resp., */
+/* and norms of "projections" onto left and right eigenspaces w.r.t. */
+/* the selected cluster in the (1,1)-block. */
+
+/* Arguments */
+/* ========= */
+
+/* IJOB (input) INTEGER */
+/* Specifies whether condition numbers are required for the */
+/* cluster of eigenvalues (PL and PR) or the deflating subspaces */
+/* (Difu and Difl): */
+/* =0: Only reorder w.r.t. SELECT. No extras. */
+/* =1: Reciprocal of norms of "projections" onto left and right */
+/* eigenspaces w.r.t. the selected cluster (PL and PR). */
+/* =2: Upper bounds on Difu and Difl. F-norm-based estimate */
+/* (DIF(1:2)). */
+/* =3: Estimate of Difu and Difl. 1-norm-based estimate */
+/* (DIF(1:2)). */
+/* About 5 times as expensive as IJOB = 2. */
+/* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic */
+/* version to get it all. */
+/* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) */
+
+/* WANTQ (input) LOGICAL */
+/* .TRUE. : update the left transformation matrix Q; */
+/* .FALSE.: do not update Q. */
+
+/* WANTZ (input) LOGICAL */
+/* .TRUE. : update the right transformation matrix Z; */
+/* .FALSE.: do not update Z. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* SELECT specifies the eigenvalues in the selected cluster. */
+/* To select a real eigenvalue w(j), SELECT(j) must be set to */
+/* .TRUE.. To select a complex conjugate pair of eigenvalues */
+/* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, */
+/* either SELECT(j) or SELECT(j+1) or both must be set to */
+/* .TRUE.; a complex conjugate pair of eigenvalues must be */
+/* either both included in the cluster or both excluded. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension(LDA,N) */
+/* On entry, the upper quasi-triangular matrix A, with (A, B) in */
+/* generalized real Schur canonical form. */
+/* On exit, A is overwritten by the reordered matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension(LDB,N) */
+/* On entry, the upper triangular matrix B, with (A, B) in */
+/* generalized real Schur canonical form. */
+/* On exit, B is overwritten by the reordered matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* ALPHAR (output) DOUBLE PRECISION array, dimension (N) */
+/* ALPHAI (output) DOUBLE PRECISION array, dimension (N) */
+/* BETA (output) DOUBLE PRECISION array, dimension (N) */
+/* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */
+/* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i */
+/* and BETA(j),j=1,...,N are the diagonals of the complex Schur */
+/* form (S,T) that would result if the 2-by-2 diagonal blocks of */
+/* the real generalized Schur form of (A,B) were further reduced */
+/* to triangular form using complex unitary transformations. */
+/* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */
+/* positive, then the j-th and (j+1)-st eigenvalues are a */
+/* complex conjugate pair, with ALPHAI(j+1) negative. */
+
+/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */
+/* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. */
+/* On exit, Q has been postmultiplied by the left orthogonal */
+/* transformation matrix which reorder (A, B); The leading M */
+/* columns of Q form orthonormal bases for the specified pair of */
+/* left eigenspaces (deflating subspaces). */
+/* If WANTQ = .FALSE., Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= 1; */
+/* and if WANTQ = .TRUE., LDQ >= N. */
+
+/* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) */
+/* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. */
+/* On exit, Z has been postmultiplied by the left orthogonal */
+/* transformation matrix which reorder (A, B); The leading M */
+/* columns of Z form orthonormal bases for the specified pair of */
+/* left eigenspaces (deflating subspaces). */
+/* If WANTZ = .FALSE., Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1; */
+/* If WANTZ = .TRUE., LDZ >= N. */
+
+/* M (output) INTEGER */
+/* The dimension of the specified pair of left and right eigen- */
+/* spaces (deflating subspaces). 0 <= M <= N. */
+
+/* PL (output) DOUBLE PRECISION */
+/* PR (output) DOUBLE PRECISION */
+/* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the */
+/* reciprocal of the norm of "projections" onto left and right */
+/* eigenspaces with respect to the selected cluster. */
+/* 0 < PL, PR <= 1. */
+/* If M = 0 or M = N, PL = PR = 1. */
+/* If IJOB = 0, 2 or 3, PL and PR are not referenced. */
+
+/* DIF (output) DOUBLE PRECISION array, dimension (2). */
+/* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. */
+/* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on */
+/* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based */
+/* estimates of Difu and Difl. */
+/* If M = 0 or N, DIF(1:2) = F-norm([A, B]). */
+/* If IJOB = 0 or 1, DIF is not referenced. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, */
+/* dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= 4*N+16. */
+/* If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)). */
+/* If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)). */
+
+/* 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. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* IF IJOB = 0, IWORK is not referenced. Otherwise, */
+/* on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. LIWORK >= 1. */
+/* If IJOB = 1, 2 or 4, LIWORK >= N+6. */
+/* If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6). */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal size of the IWORK array, */
+/* returns this value as the first entry of the IWORK array, and */
+/* no error message related to LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* =0: Successful exit. */
+/* <0: If INFO = -i, the i-th argument had an illegal value. */
+/* =1: Reordering of (A, B) failed because the transformed */
+/* matrix pair (A, B) would be too far from generalized */
+/* Schur form; the problem is very ill-conditioned. */
+/* (A, B) may have been partially reordered. */
+/* If requested, 0 is returned in DIF(*), PL and PR. */
+
+/* Further Details */
+/* =============== */
+
+/* DTGSEN first collects the selected eigenvalues by computing */
+/* orthogonal U and W that move them to the top left corner of (A, B). */
+/* In other words, the selected eigenvalues are the eigenvalues of */
+/* (A11, B11) in: */
+
+/* U'*(A, B)*W = (A11 A12) (B11 B12) n1 */
+/* ( 0 A22),( 0 B22) n2 */
+/* n1 n2 n1 n2 */
+
+/* where N = n1+n2 and U' means the transpose of U. The first n1 columns */
+/* of U and W span the specified pair of left and right eigenspaces */
+/* (deflating subspaces) of (A, B). */
+
+/* If (A, B) has been obtained from the generalized real Schur */
+/* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the */
+/* reordered generalized real Schur form of (C, D) is given by */
+
+/* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)', */
+
+/* and the first n1 columns of Q*U and Z*W span the corresponding */
+/* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). */
+
+/* Note that if the selected eigenvalue is sufficiently ill-conditioned, */
+/* then its value may differ significantly from its value before */
+/* reordering. */
+
+/* The reciprocal condition numbers of the left and right eigenspaces */
+/* spanned by the first n1 columns of U and W (or Q*U and Z*W) may */
+/* be returned in DIF(1:2), corresponding to Difu and Difl, resp. */
+
+/* The Difu and Difl are defined as: */
+
+/* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu ) */
+/* and */
+/* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], */
+
+/* where sigma-min(Zu) is the smallest singular value of the */
+/* (2*n1*n2)-by-(2*n1*n2) matrix */
+
+/* Zu = [ kron(In2, A11) -kron(A22', In1) ] */
+/* [ kron(In2, B11) -kron(B22', In1) ]. */
+
+/* Here, Inx is the identity matrix of size nx and A22' is the */
+/* transpose of A22. kron(X, Y) is the Kronecker product between */
+/* the matrices X and Y. */
+
+/* When DIF(2) is small, small changes in (A, B) can cause large changes */
+/* in the deflating subspace. An approximate (asymptotic) bound on the */
+/* maximum angular error in the computed deflating subspaces is */
+
+/* EPS * norm((A, B)) / DIF(2), */
+
+/* where EPS is the machine precision. */
+
+/* The reciprocal norm of the projectors on the left and right */
+/* eigenspaces associated with (A11, B11) may be returned in PL and PR. */
+/* They are computed as follows. First we compute L and R so that */
+/* P*(A, B)*Q is block diagonal, where */
+
+/* P = ( I -L ) n1 Q = ( I R ) n1 */
+/* ( 0 I ) n2 and ( 0 I ) n2 */
+/* n1 n2 n1 n2 */
+
+/* and (L, R) is the solution to the generalized Sylvester equation */
+
+/* A11*R - L*A22 = -A12 */
+/* B11*R - L*B22 = -B12 */
+
+/* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). */
+/* An approximate (asymptotic) bound on the average absolute error of */
+/* the selected eigenvalues is */
+
+/* EPS * norm((A, B)) / PL. */
+
+/* There are also global error bounds which valid for perturbations up */
+/* to a certain restriction: A lower bound (x) on the smallest */
+/* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and */
+/* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), */
+/* (i.e. (A + E, B + F), is */
+
+/* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)). */
+
+/* An approximate bound on x can be computed from DIF(1:2), PL and PR. */
+
+/* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed */
+/* (L', R') and unperturbed (L, R) left and right deflating subspaces */
+/* associated with the selected cluster in the (1,1)-blocks can be */
+/* bounded as */
+
+/* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) */
+/* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) */
+
+/* See LAPACK User's Guide section 4.11 or the following references */
+/* for more information. */
+
+/* Note that if the default method for computing the Frobenius-norm- */
+/* based estimate DIF is not wanted (see DLATDF), then the parameter */
+/* IDIFJB (see below) should be changed from 3 to 4 (routine DLATDF */
+/* (IJOB = 2 will be used)). See DTGSYL for more details. */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* References */
+/* ========== */
+
+/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
+/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
+/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
+/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
+
+/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
+/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
+/* Estimation: Theory, Algorithms and Software, */
+/* Report UMINF - 94.04, Department of Computing Science, Umea */
+/* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */
+/* Note 87. To appear in Numerical Algorithms, 1996. */
+
+/* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
+/* for Solving the Generalized Sylvester Equation and Estimating the */
+/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
+/* Department of Computing Science, Umea University, S-901 87 Umea, */
+/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */
+/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, */
+/* 1996. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ --select;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --dif;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1 || *liwork == -1;
+
+ if (*ijob < 0 || *ijob > 5) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldq < 1 || *wantq && *ldq < *n) {
+ *info = -14;
+ } else if (*ldz < 1 || *wantz && *ldz < *n) {
+ *info = -16;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTGSEN", &i__1);
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S") / eps;
+ ierr = 0;
+
+ wantp = *ijob == 1 || *ijob >= 4;
+ wantd1 = *ijob == 2 || *ijob == 4;
+ wantd2 = *ijob == 3 || *ijob == 5;
+ wantd = wantd1 || wantd2;
+
+/* Set M to the dimension of the specified pair of deflating */
+/* subspaces. */
+
+ *m = 0;
+ pair = FALSE_;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (pair) {
+ pair = FALSE_;
+ } else {
+ if (k < *n) {
+ if (a[k + 1 + k * a_dim1] == 0.) {
+ if (select[k]) {
+ ++(*m);
+ }
+ } else {
+ pair = TRUE_;
+ if (select[k] || select[k + 1]) {
+ *m += 2;
+ }
+ }
+ } else {
+ if (select[*n]) {
+ ++(*m);
+ }
+ }
+ }
+/* L10: */
+ }
+
+ if (*ijob == 1 || *ijob == 2 || *ijob == 4) {
+/* Computing MAX */
+ i__1 = 1, i__2 = (*n << 2) + 16, i__1 = max(i__1,i__2), i__2 = (*m <<
+ 1) * (*n - *m);
+ lwmin = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = *n + 6;
+ liwmin = max(i__1,i__2);
+ } else if (*ijob == 3 || *ijob == 5) {
+/* Computing MAX */
+ i__1 = 1, i__2 = (*n << 2) + 16, i__1 = max(i__1,i__2), i__2 = (*m <<
+ 2) * (*n - *m);
+ lwmin = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = (*m << 1) * (*n - *m), i__1 = max(i__1,i__2), i__2 =
+ *n + 6;
+ liwmin = max(i__1,i__2);
+ } else {
+/* Computing MAX */
+ i__1 = 1, i__2 = (*n << 2) + 16;
+ lwmin = max(i__1,i__2);
+ liwmin = 1;
+ }
+
+ work[1] = (doublereal) lwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -22;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -24;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTGSEN", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == *n || *m == 0) {
+ if (wantp) {
+ *pl = 1.;
+ *pr = 1.;
+ }
+ if (wantd) {
+ dscale = 0.;
+ dsum = 1.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dlassq_(n, &a[i__ * a_dim1 + 1], &c__1, &dscale, &dsum);
+ dlassq_(n, &b[i__ * b_dim1 + 1], &c__1, &dscale, &dsum);
+/* L20: */
+ }
+ dif[1] = dscale * sqrt(dsum);
+ dif[2] = dif[1];
+ }
+ goto L60;
+ }
+
+/* Collect the selected blocks at the top-left corner of (A, B). */
+
+ ks = 0;
+ pair = FALSE_;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (pair) {
+ pair = FALSE_;
+ } else {
+
+ swap = select[k];
+ if (k < *n) {
+ if (a[k + 1 + k * a_dim1] != 0.) {
+ pair = TRUE_;
+ swap = swap || select[k + 1];
+ }
+ }
+
+ if (swap) {
+ ++ks;
+
+/* Swap the K-th block to position KS. */
+/* Perform the reordering of diagonal blocks in (A, B) */
+/* by orthogonal transformation matrices and update */
+/* Q and Z accordingly (if requested): */
+
+ kk = k;
+ if (k != ks) {
+ dtgexc_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
+ ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &kk,
+ &ks, &work[1], lwork, &ierr);
+ }
+
+ if (ierr > 0) {
+
+/* Swap is rejected: exit. */
+
+ *info = 1;
+ if (wantp) {
+ *pl = 0.;
+ *pr = 0.;
+ }
+ if (wantd) {
+ dif[1] = 0.;
+ dif[2] = 0.;
+ }
+ goto L60;
+ }
+
+ if (pair) {
+ ++ks;
+ }
+ }
+ }
+/* L30: */
+ }
+ if (wantp) {
+
+/* Solve generalized Sylvester equation for R and L */
+/* and compute PL and PR. */
+
+ n1 = *m;
+ n2 = *n - *m;
+ i__ = n1 + 1;
+ ijb = 0;
+ dlacpy_("Full", &n1, &n2, &a[i__ * a_dim1 + 1], lda, &work[1], &n1);
+ dlacpy_("Full", &n1, &n2, &b[i__ * b_dim1 + 1], ldb, &work[n1 * n2 +
+ 1], &n1);
+ i__1 = *lwork - (n1 << 1) * n2;
+ dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ * a_dim1]
+, lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ + i__ *
+ b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &dif[1], &
+ work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &ierr);
+
+/* Estimate the reciprocal of norms of "projections" onto left */
+/* and right eigenspaces. */
+
+ rdscal = 0.;
+ dsum = 1.;
+ i__1 = n1 * n2;
+ dlassq_(&i__1, &work[1], &c__1, &rdscal, &dsum);
+ *pl = rdscal * sqrt(dsum);
+ if (*pl == 0.) {
+ *pl = 1.;
+ } else {
+ *pl = dscale / (sqrt(dscale * dscale / *pl + *pl) * sqrt(*pl));
+ }
+ rdscal = 0.;
+ dsum = 1.;
+ i__1 = n1 * n2;
+ dlassq_(&i__1, &work[n1 * n2 + 1], &c__1, &rdscal, &dsum);
+ *pr = rdscal * sqrt(dsum);
+ if (*pr == 0.) {
+ *pr = 1.;
+ } else {
+ *pr = dscale / (sqrt(dscale * dscale / *pr + *pr) * sqrt(*pr));
+ }
+ }
+
+ if (wantd) {
+
+/* Compute estimates of Difu and Difl. */
+
+ if (wantd1) {
+ n1 = *m;
+ n2 = *n - *m;
+ i__ = n1 + 1;
+ ijb = 3;
+
+/* Frobenius norm-based Difu-estimate. */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ *
+ a_dim1], lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ +
+ i__ * b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &
+ dif[1], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], &
+ ierr);
+
+/* Frobenius norm-based Difl-estimate. */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ dtgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, &a[
+ a_offset], lda, &work[1], &n2, &b[i__ + i__ * b_dim1],
+ ldb, &b[b_offset], ldb, &work[n1 * n2 + 1], &n2, &dscale,
+ &dif[2], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], &
+ ierr);
+ } else {
+
+
+/* Compute 1-norm-based estimates of Difu and Difl using */
+/* reversed communication with DLACN2. In each step a */
+/* generalized Sylvester equation or a transposed variant */
+/* is solved. */
+
+ kase = 0;
+ n1 = *m;
+ n2 = *n - *m;
+ i__ = n1 + 1;
+ ijb = 0;
+ mn2 = (n1 << 1) * n2;
+
+/* 1-norm-based estimate of Difu. */
+
+L40:
+ dlacn2_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[1], &kase,
+ isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Solve generalized Sylvester equation. */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ +
+ i__ * a_dim1], lda, &work[1], &n1, &b[b_offset],
+ ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
+ 1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 +
+ 1], &i__1, &iwork[1], &ierr);
+ } else {
+
+/* Solve the transposed variant. */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ dtgsyl_("T", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ +
+ i__ * a_dim1], lda, &work[1], &n1, &b[b_offset],
+ ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
+ 1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 +
+ 1], &i__1, &iwork[1], &ierr);
+ }
+ goto L40;
+ }
+ dif[1] = dscale / dif[1];
+
+/* 1-norm-based estimate of Difl. */
+
+L50:
+ dlacn2_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[2], &kase,
+ isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Solve generalized Sylvester equation. */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ dtgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda,
+ &a[a_offset], lda, &work[1], &n2, &b[i__ + i__ *
+ b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 +
+ 1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 +
+ 1], &i__1, &iwork[1], &ierr);
+ } else {
+
+/* Solve the transposed variant. */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ dtgsyl_("T", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda,
+ &a[a_offset], lda, &work[1], &n2, &b[i__ + i__ *
+ b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 +
+ 1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 +
+ 1], &i__1, &iwork[1], &ierr);
+ }
+ goto L50;
+ }
+ dif[2] = dscale / dif[2];
+
+ }
+ }
+
+L60:
+
+/* Compute generalized eigenvalues of reordered pair (A, B) and */
+/* normalize the generalized Schur form. */
+
+ pair = FALSE_;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (pair) {
+ pair = FALSE_;
+ } else {
+
+ if (k < *n) {
+ if (a[k + 1 + k * a_dim1] != 0.) {
+ pair = TRUE_;
+ }
+ }
+
+ if (pair) {
+
+/* Compute the eigenvalue(s) at position K. */
+
+ work[1] = a[k + k * a_dim1];
+ work[2] = a[k + 1 + k * a_dim1];
+ work[3] = a[k + (k + 1) * a_dim1];
+ work[4] = a[k + 1 + (k + 1) * a_dim1];
+ work[5] = b[k + k * b_dim1];
+ work[6] = b[k + 1 + k * b_dim1];
+ work[7] = b[k + (k + 1) * b_dim1];
+ work[8] = b[k + 1 + (k + 1) * b_dim1];
+ d__1 = smlnum * eps;
+ dlag2_(&work[1], &c__2, &work[5], &c__2, &d__1, &beta[k], &
+ beta[k + 1], &alphar[k], &alphar[k + 1], &alphai[k]);
+ alphai[k + 1] = -alphai[k];
+
+ } else {
+
+ if (d_sign(&c_b28, &b[k + k * b_dim1]) < 0.) {
+
+/* If B(K,K) is negative, make it positive */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[k + i__ * a_dim1] = -a[k + i__ * a_dim1];
+ b[k + i__ * b_dim1] = -b[k + i__ * b_dim1];
+ if (*wantq) {
+ q[i__ + k * q_dim1] = -q[i__ + k * q_dim1];
+ }
+/* L70: */
+ }
+ }
+
+ alphar[k] = a[k + k * a_dim1];
+ alphai[k] = 0.;
+ beta[k] = b[k + k * b_dim1];
+
+ }
+ }
+/* L80: */
+ }
+
+ work[1] = (doublereal) lwmin;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of DTGSEN */
+
+} /* dtgsen_ */
diff --git a/SRC/dtgsja.c b/SRC/dtgsja.c
new file mode 100644
index 0000000..5b295b9
--- /dev/null
+++ b/SRC/dtgsja.c
@@ -0,0 +1,625 @@
+/* dtgsja.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b13 = 0.;
+static doublereal c_b14 = 1.;
+static integer c__1 = 1;
+static doublereal c_b43 = -1.;
+
+/* Subroutine */ int dtgsja_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *p, integer *n, integer *k, integer *l, doublereal *a,
+ integer *lda, doublereal *b, integer *ldb, doublereal *tola,
+ doublereal *tolb, doublereal *alpha, doublereal *beta, doublereal *u,
+ integer *ldu, doublereal *v, integer *ldv, doublereal *q, integer *
+ ldq, doublereal *work, integer *ncycle, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1,
+ u_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal a1, a2, a3, b1, b2, b3, csq, csu, csv, snq, rwk, snu, snv;
+ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ doublereal gamma;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical initq, initu, initv, wantq, upper;
+ doublereal error, ssmin;
+ logical wantu, wantv;
+ extern /* Subroutine */ int dlags2_(logical *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *), dlapll_(integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *);
+ integer kcycle;
+ extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *), dlaset_(char *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTGSJA computes the generalized singular value decomposition (GSVD) */
+/* of two real upper triangular (or trapezoidal) matrices A and B. */
+
+/* On entry, it is assumed that matrices A and B have the following */
+/* forms, which may be obtained by the preprocessing subroutine DGGSVP */
+/* from a general M-by-N matrix A and P-by-N matrix B: */
+
+/* N-K-L K L */
+/* A = K ( 0 A12 A13 ) if M-K-L >= 0; */
+/* L ( 0 0 A23 ) */
+/* M-K-L ( 0 0 0 ) */
+
+/* N-K-L K L */
+/* A = K ( 0 A12 A13 ) if M-K-L < 0; */
+/* M-K ( 0 0 A23 ) */
+
+/* N-K-L K L */
+/* B = L ( 0 0 B13 ) */
+/* P-L ( 0 0 0 ) */
+
+/* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */
+/* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */
+/* otherwise A23 is (M-K)-by-L upper trapezoidal. */
+
+/* On exit, */
+
+/* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ), */
+
+/* where U, V and Q are orthogonal matrices, Z' denotes the transpose */
+/* of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are */
+/* ``diagonal'' matrices, which are of the following structures: */
+
+/* If M-K-L >= 0, */
+
+/* K L */
+/* D1 = K ( I 0 ) */
+/* L ( 0 C ) */
+/* M-K-L ( 0 0 ) */
+
+/* K L */
+/* D2 = L ( 0 S ) */
+/* P-L ( 0 0 ) */
+
+/* N-K-L K L */
+/* ( 0 R ) = K ( 0 R11 R12 ) K */
+/* L ( 0 0 R22 ) L */
+
+/* where */
+
+/* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */
+/* S = diag( BETA(K+1), ... , BETA(K+L) ), */
+/* C**2 + S**2 = I. */
+
+/* R is stored in A(1:K+L,N-K-L+1:N) on exit. */
+
+/* If M-K-L < 0, */
+
+/* K M-K K+L-M */
+/* D1 = K ( I 0 0 ) */
+/* M-K ( 0 C 0 ) */
+
+/* K M-K K+L-M */
+/* D2 = M-K ( 0 S 0 ) */
+/* K+L-M ( 0 0 I ) */
+/* P-L ( 0 0 0 ) */
+
+/* N-K-L K M-K K+L-M */
+/* ( 0 R ) = K ( 0 R11 R12 R13 ) */
+/* M-K ( 0 0 R22 R23 ) */
+/* K+L-M ( 0 0 0 R33 ) */
+
+/* where */
+/* C = diag( ALPHA(K+1), ... , ALPHA(M) ), */
+/* S = diag( BETA(K+1), ... , BETA(M) ), */
+/* C**2 + S**2 = I. */
+
+/* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored */
+/* ( 0 R22 R23 ) */
+/* in B(M-K+1:L,N+M-K-L+1:N) on exit. */
+
+/* The computation of the orthogonal transformation matrices U, V or Q */
+/* is optional. These matrices may either be formed explicitly, or they */
+/* may be postmultiplied into input matrices U1, V1, or Q1. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBU (input) CHARACTER*1 */
+/* = 'U': U must contain an orthogonal matrix U1 on entry, and */
+/* the product U1*U is returned; */
+/* = 'I': U is initialized to the unit matrix, and the */
+/* orthogonal matrix U is returned; */
+/* = 'N': U is not computed. */
+
+/* JOBV (input) CHARACTER*1 */
+/* = 'V': V must contain an orthogonal matrix V1 on entry, and */
+/* the product V1*V is returned; */
+/* = 'I': V is initialized to the unit matrix, and the */
+/* orthogonal matrix V is returned; */
+/* = 'N': V is not computed. */
+
+/* JOBQ (input) CHARACTER*1 */
+/* = 'Q': Q must contain an orthogonal matrix Q1 on entry, and */
+/* the product Q1*Q is returned; */
+/* = 'I': Q is initialized to the unit matrix, and the */
+/* orthogonal matrix Q is returned; */
+/* = 'N': Q is not computed. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* K (input) INTEGER */
+/* L (input) INTEGER */
+/* K and L specify the subblocks in the input matrices A and B: */
+/* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N) */
+/* of A and B, whose GSVD is going to be computed by DTGSJA. */
+/* See Further details. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular */
+/* matrix R or part of R. See Purpose for details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix B. */
+/* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains */
+/* a part of R. See Purpose for details. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,P). */
+
+/* TOLA (input) DOUBLE PRECISION */
+/* TOLB (input) DOUBLE PRECISION */
+/* TOLA and TOLB are the convergence criteria for the Jacobi- */
+/* Kogbetliantz iteration procedure. Generally, they are the */
+/* same as used in the preprocessing step, say */
+/* TOLA = max(M,N)*norm(A)*MAZHEPS, */
+/* TOLB = max(P,N)*norm(B)*MAZHEPS. */
+
+/* ALPHA (output) DOUBLE PRECISION array, dimension (N) */
+/* BETA (output) DOUBLE PRECISION array, dimension (N) */
+/* On exit, ALPHA and BETA contain the generalized singular */
+/* value pairs of A and B; */
+/* ALPHA(1:K) = 1, */
+/* BETA(1:K) = 0, */
+/* and if M-K-L >= 0, */
+/* ALPHA(K+1:K+L) = diag(C), */
+/* BETA(K+1:K+L) = diag(S), */
+/* or if M-K-L < 0, */
+/* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0 */
+/* BETA(K+1:M) = S, BETA(M+1:K+L) = 1. */
+/* Furthermore, if K+L < N, */
+/* ALPHA(K+L+1:N) = 0 and */
+/* BETA(K+L+1:N) = 0. */
+
+/* U (input/output) DOUBLE PRECISION array, dimension (LDU,M) */
+/* On entry, if JOBU = 'U', U must contain a matrix U1 (usually */
+/* the orthogonal matrix returned by DGGSVP). */
+/* On exit, */
+/* if JOBU = 'I', U contains the orthogonal matrix U; */
+/* if JOBU = 'U', U contains the product U1*U. */
+/* If JOBU = 'N', U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M) if */
+/* JOBU = 'U'; LDU >= 1 otherwise. */
+
+/* V (input/output) DOUBLE PRECISION array, dimension (LDV,P) */
+/* On entry, if JOBV = 'V', V must contain a matrix V1 (usually */
+/* the orthogonal matrix returned by DGGSVP). */
+/* On exit, */
+/* if JOBV = 'I', V contains the orthogonal matrix V; */
+/* if JOBV = 'V', V contains the product V1*V. */
+/* If JOBV = 'N', V is not referenced. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. LDV >= max(1,P) if */
+/* JOBV = 'V'; LDV >= 1 otherwise. */
+
+/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */
+/* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually */
+/* the orthogonal matrix returned by DGGSVP). */
+/* On exit, */
+/* if JOBQ = 'I', Q contains the orthogonal matrix Q; */
+/* if JOBQ = 'Q', Q contains the product Q1*Q. */
+/* If JOBQ = 'N', Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N) if */
+/* JOBQ = 'Q'; LDQ >= 1 otherwise. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* NCYCLE (output) INTEGER */
+/* The number of cycles required for convergence. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1: the procedure does not converge after MAXIT cycles. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* MAXIT INTEGER */
+/* MAXIT specifies the total loops that the iterative procedure */
+/* may take. If after MAXIT cycles, the routine fails to */
+/* converge, we return INFO = 1. */
+
+/* Further Details */
+/* =============== */
+
+/* DTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce */
+/* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L */
+/* matrix B13 to the form: */
+
+/* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1, */
+
+/* where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose */
+/* of Z. C1 and S1 are diagonal matrices satisfying */
+
+/* C1**2 + S1**2 = I, */
+
+/* and R1 is an L-by-L nonsingular upper triangular matrix. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alpha;
+ --beta;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+
+ /* Function Body */
+ initu = lsame_(jobu, "I");
+ wantu = initu || lsame_(jobu, "U");
+
+ initv = lsame_(jobv, "I");
+ wantv = initv || lsame_(jobv, "V");
+
+ initq = lsame_(jobq, "I");
+ wantq = initq || lsame_(jobq, "Q");
+
+ *info = 0;
+ if (! (initu || wantu || lsame_(jobu, "N"))) {
+ *info = -1;
+ } else if (! (initv || wantv || lsame_(jobv, "N")))
+ {
+ *info = -2;
+ } else if (! (initq || wantq || lsame_(jobq, "N")))
+ {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*p < 0) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (*lda < max(1,*m)) {
+ *info = -10;
+ } else if (*ldb < max(1,*p)) {
+ *info = -12;
+ } else if (*ldu < 1 || wantu && *ldu < *m) {
+ *info = -18;
+ } else if (*ldv < 1 || wantv && *ldv < *p) {
+ *info = -20;
+ } else if (*ldq < 1 || wantq && *ldq < *n) {
+ *info = -22;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTGSJA", &i__1);
+ return 0;
+ }
+
+/* Initialize U, V and Q, if necessary */
+
+ if (initu) {
+ dlaset_("Full", m, m, &c_b13, &c_b14, &u[u_offset], ldu);
+ }
+ if (initv) {
+ dlaset_("Full", p, p, &c_b13, &c_b14, &v[v_offset], ldv);
+ }
+ if (initq) {
+ dlaset_("Full", n, n, &c_b13, &c_b14, &q[q_offset], ldq);
+ }
+
+/* Loop until convergence */
+
+ upper = FALSE_;
+ for (kcycle = 1; kcycle <= 40; ++kcycle) {
+
+ upper = ! upper;
+
+ i__1 = *l - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *l;
+ for (j = i__ + 1; j <= i__2; ++j) {
+
+ a1 = 0.;
+ a2 = 0.;
+ a3 = 0.;
+ if (*k + i__ <= *m) {
+ a1 = a[*k + i__ + (*n - *l + i__) * a_dim1];
+ }
+ if (*k + j <= *m) {
+ a3 = a[*k + j + (*n - *l + j) * a_dim1];
+ }
+
+ b1 = b[i__ + (*n - *l + i__) * b_dim1];
+ b3 = b[j + (*n - *l + j) * b_dim1];
+
+ if (upper) {
+ if (*k + i__ <= *m) {
+ a2 = a[*k + i__ + (*n - *l + j) * a_dim1];
+ }
+ b2 = b[i__ + (*n - *l + j) * b_dim1];
+ } else {
+ if (*k + j <= *m) {
+ a2 = a[*k + j + (*n - *l + i__) * a_dim1];
+ }
+ b2 = b[j + (*n - *l + i__) * b_dim1];
+ }
+
+ dlags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &
+ csv, &snv, &csq, &snq);
+
+/* Update (K+I)-th and (K+J)-th rows of matrix A: U'*A */
+
+ if (*k + j <= *m) {
+ drot_(l, &a[*k + j + (*n - *l + 1) * a_dim1], lda, &a[*k
+ + i__ + (*n - *l + 1) * a_dim1], lda, &csu, &snu);
+ }
+
+/* Update I-th and J-th rows of matrix B: V'*B */
+
+ drot_(l, &b[j + (*n - *l + 1) * b_dim1], ldb, &b[i__ + (*n - *
+ l + 1) * b_dim1], ldb, &csv, &snv);
+
+/* Update (N-L+I)-th and (N-L+J)-th columns of matrices */
+/* A and B: A*Q and B*Q */
+
+/* Computing MIN */
+ i__4 = *k + *l;
+ i__3 = min(i__4,*m);
+ drot_(&i__3, &a[(*n - *l + j) * a_dim1 + 1], &c__1, &a[(*n - *
+ l + i__) * a_dim1 + 1], &c__1, &csq, &snq);
+
+ drot_(l, &b[(*n - *l + j) * b_dim1 + 1], &c__1, &b[(*n - *l +
+ i__) * b_dim1 + 1], &c__1, &csq, &snq);
+
+ if (upper) {
+ if (*k + i__ <= *m) {
+ a[*k + i__ + (*n - *l + j) * a_dim1] = 0.;
+ }
+ b[i__ + (*n - *l + j) * b_dim1] = 0.;
+ } else {
+ if (*k + j <= *m) {
+ a[*k + j + (*n - *l + i__) * a_dim1] = 0.;
+ }
+ b[j + (*n - *l + i__) * b_dim1] = 0.;
+ }
+
+/* Update orthogonal matrices U, V, Q, if desired. */
+
+ if (wantu && *k + j <= *m) {
+ drot_(m, &u[(*k + j) * u_dim1 + 1], &c__1, &u[(*k + i__) *
+ u_dim1 + 1], &c__1, &csu, &snu);
+ }
+
+ if (wantv) {
+ drot_(p, &v[j * v_dim1 + 1], &c__1, &v[i__ * v_dim1 + 1],
+ &c__1, &csv, &snv);
+ }
+
+ if (wantq) {
+ drot_(n, &q[(*n - *l + j) * q_dim1 + 1], &c__1, &q[(*n - *
+ l + i__) * q_dim1 + 1], &c__1, &csq, &snq);
+ }
+
+/* L10: */
+ }
+/* L20: */
+ }
+
+ if (! upper) {
+
+/* The matrices A13 and B13 were lower triangular at the start */
+/* of the cycle, and are now upper triangular. */
+
+/* Convergence test: test the parallelism of the corresponding */
+/* rows of A and B. */
+
+ error = 0.;
+/* Computing MIN */
+ i__2 = *l, i__3 = *m - *k;
+ i__1 = min(i__2,i__3);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *l - i__ + 1;
+ dcopy_(&i__2, &a[*k + i__ + (*n - *l + i__) * a_dim1], lda, &
+ work[1], &c__1);
+ i__2 = *l - i__ + 1;
+ dcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &work[*
+ l + 1], &c__1);
+ i__2 = *l - i__ + 1;
+ dlapll_(&i__2, &work[1], &c__1, &work[*l + 1], &c__1, &ssmin);
+ error = max(error,ssmin);
+/* L30: */
+ }
+
+ if (abs(error) <= min(*tola,*tolb)) {
+ goto L50;
+ }
+ }
+
+/* End of cycle loop */
+
+/* L40: */
+ }
+
+/* The algorithm has not converged after MAXIT cycles. */
+
+ *info = 1;
+ goto L100;
+
+L50:
+
+/* If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged. */
+/* Compute the generalized singular value pairs (ALPHA, BETA), and */
+/* set the triangular matrix R to array A. */
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ alpha[i__] = 1.;
+ beta[i__] = 0.;
+/* L60: */
+ }
+
+/* Computing MIN */
+ i__2 = *l, i__3 = *m - *k;
+ i__1 = min(i__2,i__3);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+ a1 = a[*k + i__ + (*n - *l + i__) * a_dim1];
+ b1 = b[i__ + (*n - *l + i__) * b_dim1];
+
+ if (a1 != 0.) {
+ gamma = b1 / a1;
+
+/* change sign if necessary */
+
+ if (gamma < 0.) {
+ i__2 = *l - i__ + 1;
+ dscal_(&i__2, &c_b43, &b[i__ + (*n - *l + i__) * b_dim1], ldb)
+ ;
+ if (wantv) {
+ dscal_(p, &c_b43, &v[i__ * v_dim1 + 1], &c__1);
+ }
+ }
+
+ d__1 = abs(gamma);
+ dlartg_(&d__1, &c_b14, &beta[*k + i__], &alpha[*k + i__], &rwk);
+
+ if (alpha[*k + i__] >= beta[*k + i__]) {
+ i__2 = *l - i__ + 1;
+ d__1 = 1. / alpha[*k + i__];
+ dscal_(&i__2, &d__1, &a[*k + i__ + (*n - *l + i__) * a_dim1],
+ lda);
+ } else {
+ i__2 = *l - i__ + 1;
+ d__1 = 1. / beta[*k + i__];
+ dscal_(&i__2, &d__1, &b[i__ + (*n - *l + i__) * b_dim1], ldb);
+ i__2 = *l - i__ + 1;
+ dcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k
+ + i__ + (*n - *l + i__) * a_dim1], lda);
+ }
+
+ } else {
+
+ alpha[*k + i__] = 0.;
+ beta[*k + i__] = 1.;
+ i__2 = *l - i__ + 1;
+ dcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k +
+ i__ + (*n - *l + i__) * a_dim1], lda);
+
+ }
+
+/* L70: */
+ }
+
+/* Post-assignment */
+
+ i__1 = *k + *l;
+ for (i__ = *m + 1; i__ <= i__1; ++i__) {
+ alpha[i__] = 0.;
+ beta[i__] = 1.;
+/* L80: */
+ }
+
+ if (*k + *l < *n) {
+ i__1 = *n;
+ for (i__ = *k + *l + 1; i__ <= i__1; ++i__) {
+ alpha[i__] = 0.;
+ beta[i__] = 0.;
+/* L90: */
+ }
+ }
+
+L100:
+ *ncycle = kcycle;
+ return 0;
+
+/* End of DTGSJA */
+
+} /* dtgsja_ */
diff --git a/SRC/dtgsna.c b/SRC/dtgsna.c
new file mode 100644
index 0000000..0dc3509
--- /dev/null
+++ b/SRC/dtgsna.c
@@ -0,0 +1,695 @@
+/* dtgsna.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b19 = 1.;
+static doublereal c_b21 = 0.;
+static integer c__2 = 2;
+static logical c_false = FALSE_;
+static integer c__3 = 3;
+
+/* Subroutine */ int dtgsna_(char *job, char *howmny, logical *select,
+ integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb,
+ doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr,
+ doublereal *s, doublereal *dif, integer *mm, integer *m, doublereal *
+ work, integer *lwork, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
+ vr_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, k;
+ doublereal c1, c2;
+ integer n1, n2, ks, iz;
+ doublereal eps, beta, cond;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ logical pair;
+ integer ierr;
+ doublereal uhav, uhbv;
+ integer ifst;
+ doublereal lnrm;
+ integer ilst;
+ doublereal rnrm;
+ extern /* Subroutine */ int dlag2_(doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *);
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ doublereal root1, root2, scale;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ doublereal uhavi, uhbvi, tmpii;
+ integer lwmin;
+ logical wants;
+ doublereal tmpir, tmpri, dummy[1], tmprr;
+ extern doublereal dlapy2_(doublereal *, doublereal *);
+ doublereal dummy1[1];
+ extern doublereal dlamch_(char *);
+ doublereal alphai, alphar;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *), dtgexc_(logical *, logical *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *, doublereal *, integer *, integer *);
+ logical wantbh, wantdf, somcon;
+ doublereal alprqt;
+ extern /* Subroutine */ int dtgsyl_(char *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *, integer *);
+ doublereal smlnum;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTGSNA estimates reciprocal condition numbers for specified */
+/* eigenvalues and/or eigenvectors of a matrix pair (A, B) in */
+/* generalized real Schur canonical form (or of any matrix pair */
+/* (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where */
+/* Z' denotes the transpose of Z. */
+
+/* (A, B) must be in generalized real Schur form (as returned by DGGES), */
+/* i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal */
+/* blocks. B is upper triangular. */
+
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies whether condition numbers are required for */
+/* eigenvalues (S) or eigenvectors (DIF): */
+/* = 'E': for eigenvalues only (S); */
+/* = 'V': for eigenvectors only (DIF); */
+/* = 'B': for both eigenvalues and eigenvectors (S and DIF). */
+
+/* HOWMNY (input) CHARACTER*1 */
+/* = 'A': compute condition numbers for all eigenpairs; */
+/* = 'S': compute condition numbers for selected eigenpairs */
+/* specified by the array SELECT. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* If HOWMNY = 'S', SELECT specifies the eigenpairs for which */
+/* condition numbers are required. To select condition numbers */
+/* for the eigenpair corresponding to a real eigenvalue w(j), */
+/* SELECT(j) must be set to .TRUE.. To select condition numbers */
+/* corresponding to a complex conjugate pair of eigenvalues w(j) */
+/* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be */
+/* set to .TRUE.. */
+/* If HOWMNY = 'A', SELECT is not referenced. */
+
+/* N (input) INTEGER */
+/* The order of the square matrix pair (A, B). N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The upper quasi-triangular matrix A in the pair (A,B). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,N) */
+/* The upper triangular matrix B in the pair (A,B). */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* VL (input) DOUBLE PRECISION array, dimension (LDVL,M) */
+/* If JOB = 'E' or 'B', VL must contain left eigenvectors of */
+/* (A, B), corresponding to the eigenpairs specified by HOWMNY */
+/* and SELECT. The eigenvectors must be stored in consecutive */
+/* columns of VL, as returned by DTGEVC. */
+/* If JOB = 'V', VL is not referenced. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. LDVL >= 1. */
+/* If JOB = 'E' or 'B', LDVL >= N. */
+
+/* VR (input) DOUBLE PRECISION array, dimension (LDVR,M) */
+/* If JOB = 'E' or 'B', VR must contain right eigenvectors of */
+/* (A, B), corresponding to the eigenpairs specified by HOWMNY */
+/* and SELECT. The eigenvectors must be stored in consecutive */
+/* columns ov VR, as returned by DTGEVC. */
+/* If JOB = 'V', VR is not referenced. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. LDVR >= 1. */
+/* If JOB = 'E' or 'B', LDVR >= N. */
+
+/* S (output) DOUBLE PRECISION array, dimension (MM) */
+/* If JOB = 'E' or 'B', the reciprocal condition numbers of the */
+/* selected eigenvalues, stored in consecutive elements of the */
+/* array. For a complex conjugate pair of eigenvalues two */
+/* consecutive elements of S are set to the same value. Thus */
+/* S(j), DIF(j), and the j-th columns of VL and VR all */
+/* correspond to the same eigenpair (but not in general the */
+/* j-th eigenpair, unless all eigenpairs are selected). */
+/* If JOB = 'V', S is not referenced. */
+
+/* DIF (output) DOUBLE PRECISION array, dimension (MM) */
+/* If JOB = 'V' or 'B', the estimated reciprocal condition */
+/* numbers of the selected eigenvectors, stored in consecutive */
+/* elements of the array. For a complex eigenvector two */
+/* consecutive elements of DIF are set to the same value. If */
+/* the eigenvalues cannot be reordered to compute DIF(j), DIF(j) */
+/* is set to 0; this can only occur when the true value would be */
+/* very small anyway. */
+/* If JOB = 'E', DIF is not referenced. */
+
+/* MM (input) INTEGER */
+/* The number of elements in the arrays S and DIF. MM >= M. */
+
+/* M (output) INTEGER */
+/* The number of elements of the arrays S and DIF used to store */
+/* the specified condition numbers; for each selected real */
+/* eigenvalue one element is used, and for each selected complex */
+/* conjugate pair of eigenvalues, two elements are used. */
+/* If HOWMNY = 'A', M is set to N. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16. */
+
+/* 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. */
+
+/* IWORK (workspace) INTEGER array, dimension (N + 6) */
+/* If JOB = 'E', IWORK is not referenced. */
+
+/* INFO (output) INTEGER */
+/* =0: Successful exit */
+/* <0: If INFO = -i, the i-th argument had an illegal value */
+
+
+/* Further Details */
+/* =============== */
+
+/* The reciprocal of the condition number of a generalized eigenvalue */
+/* w = (a, b) is defined as */
+
+/* S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v)) */
+
+/* where u and v are the left and right eigenvectors of (A, B) */
+/* corresponding to w; |z| denotes the absolute value of the complex */
+/* number, and norm(u) denotes the 2-norm of the vector u. */
+/* The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv) */
+/* of the matrix pair (A, B). If both a and b equal zero, then (A B) is */
+/* singular and S(I) = -1 is returned. */
+
+/* An approximate error bound on the chordal distance between the i-th */
+/* computed generalized eigenvalue w and the corresponding exact */
+/* eigenvalue lambda is */
+
+/* chord(w, lambda) <= EPS * norm(A, B) / S(I) */
+
+/* where EPS is the machine precision. */
+
+/* The reciprocal of the condition number DIF(i) of right eigenvector u */
+/* and left eigenvector v corresponding to the generalized eigenvalue w */
+/* is defined as follows: */
+
+/* a) If the i-th eigenvalue w = (a,b) is real */
+
+/* Suppose U and V are orthogonal transformations such that */
+
+/* U'*(A, B)*V = (S, T) = ( a * ) ( b * ) 1 */
+/* ( 0 S22 ),( 0 T22 ) n-1 */
+/* 1 n-1 1 n-1 */
+
+/* Then the reciprocal condition number DIF(i) is */
+
+/* Difl((a, b), (S22, T22)) = sigma-min( Zl ), */
+
+/* where sigma-min(Zl) denotes the smallest singular value of the */
+/* 2(n-1)-by-2(n-1) matrix */
+
+/* Zl = [ kron(a, In-1) -kron(1, S22) ] */
+/* [ kron(b, In-1) -kron(1, T22) ] . */
+
+/* Here In-1 is the identity matrix of size n-1. kron(X, Y) is the */
+/* Kronecker product between the matrices X and Y. */
+
+/* Note that if the default method for computing DIF(i) is wanted */
+/* (see DLATDF), then the parameter DIFDRI (see below) should be */
+/* changed from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). */
+/* See DTGSYL for more details. */
+
+/* b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair, */
+
+/* Suppose U and V are orthogonal transformations such that */
+
+/* U'*(A, B)*V = (S, T) = ( S11 * ) ( T11 * ) 2 */
+/* ( 0 S22 ),( 0 T22) n-2 */
+/* 2 n-2 2 n-2 */
+
+/* and (S11, T11) corresponds to the complex conjugate eigenvalue */
+/* pair (w, conjg(w)). There exist unitary matrices U1 and V1 such */
+/* that */
+
+/* U1'*S11*V1 = ( s11 s12 ) and U1'*T11*V1 = ( t11 t12 ) */
+/* ( 0 s22 ) ( 0 t22 ) */
+
+/* where the generalized eigenvalues w = s11/t11 and */
+/* conjg(w) = s22/t22. */
+
+/* Then the reciprocal condition number DIF(i) is bounded by */
+
+/* min( d1, max( 1, |real(s11)/real(s22)| )*d2 ) */
+
+/* where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where */
+/* Z1 is the complex 2-by-2 matrix */
+
+/* Z1 = [ s11 -s22 ] */
+/* [ t11 -t22 ], */
+
+/* This is done by computing (using real arithmetic) the */
+/* roots of the characteristical polynomial det(Z1' * Z1 - lambda I), */
+/* where Z1' denotes the conjugate transpose of Z1 and det(X) denotes */
+/* the determinant of X. */
+
+/* and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an */
+/* upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2) */
+
+/* Z2 = [ kron(S11', In-2) -kron(I2, S22) ] */
+/* [ kron(T11', In-2) -kron(I2, T22) ] */
+
+/* Note that if the default method for computing DIF is wanted (see */
+/* DLATDF), then the parameter DIFDRI (see below) should be changed */
+/* from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). See DTGSYL */
+/* for more details. */
+
+/* For each eigenvalue/vector specified by SELECT, DIF stores a */
+/* Frobenius norm-based estimate of Difl. */
+
+/* An approximate error bound for the i-th computed eigenvector VL(i) or */
+/* VR(i) is given by */
+
+/* EPS * norm(A, B) / DIF(i). */
+
+/* See ref. [2-3] for more details and further references. */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* References */
+/* ========== */
+
+/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
+/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
+/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
+/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
+
+/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
+/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
+/* Estimation: Theory, Algorithms and Software, */
+/* Report UMINF - 94.04, Department of Computing Science, Umea */
+/* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */
+/* Note 87. To appear in Numerical Algorithms, 1996. */
+
+/* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
+/* for Solving the Generalized Sylvester Equation and Estimating the */
+/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
+/* Department of Computing Science, Umea University, S-901 87 Umea, */
+/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */
+/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, */
+/* No 1, 1996. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ --select;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --s;
+ --dif;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantbh = lsame_(job, "B");
+ wants = lsame_(job, "E") || wantbh;
+ wantdf = lsame_(job, "V") || wantbh;
+
+ somcon = lsame_(howmny, "S");
+
+ *info = 0;
+ lquery = *lwork == -1;
+
+ if (! wants && ! wantdf) {
+ *info = -1;
+ } else if (! lsame_(howmny, "A") && ! somcon) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (wants && *ldvl < *n) {
+ *info = -10;
+ } else if (wants && *ldvr < *n) {
+ *info = -12;
+ } else {
+
+/* Set M to the number of eigenpairs for which condition numbers */
+/* are required, and test MM. */
+
+ if (somcon) {
+ *m = 0;
+ pair = FALSE_;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (pair) {
+ pair = FALSE_;
+ } else {
+ if (k < *n) {
+ if (a[k + 1 + k * a_dim1] == 0.) {
+ if (select[k]) {
+ ++(*m);
+ }
+ } else {
+ pair = TRUE_;
+ if (select[k] || select[k + 1]) {
+ *m += 2;
+ }
+ }
+ } else {
+ if (select[*n]) {
+ ++(*m);
+ }
+ }
+ }
+/* L10: */
+ }
+ } else {
+ *m = *n;
+ }
+
+ if (*n == 0) {
+ lwmin = 1;
+ } else if (lsame_(job, "V") || lsame_(job,
+ "B")) {
+ lwmin = (*n << 1) * (*n + 2) + 16;
+ } else {
+ lwmin = *n;
+ }
+ work[1] = (doublereal) lwmin;
+
+ if (*mm < *m) {
+ *info = -15;
+ } else if (*lwork < lwmin && ! lquery) {
+ *info = -18;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTGSNA", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S") / eps;
+ ks = 0;
+ pair = FALSE_;
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+/* Determine whether A(k,k) begins a 1-by-1 or 2-by-2 block. */
+
+ if (pair) {
+ pair = FALSE_;
+ goto L20;
+ } else {
+ if (k < *n) {
+ pair = a[k + 1 + k * a_dim1] != 0.;
+ }
+ }
+
+/* Determine whether condition numbers are required for the k-th */
+/* eigenpair. */
+
+ if (somcon) {
+ if (pair) {
+ if (! select[k] && ! select[k + 1]) {
+ goto L20;
+ }
+ } else {
+ if (! select[k]) {
+ goto L20;
+ }
+ }
+ }
+
+ ++ks;
+
+ if (wants) {
+
+/* Compute the reciprocal condition number of the k-th */
+/* eigenvalue. */
+
+ if (pair) {
+
+/* Complex eigenvalue pair. */
+
+ d__1 = dnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
+ d__2 = dnrm2_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1);
+ rnrm = dlapy2_(&d__1, &d__2);
+ d__1 = dnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
+ d__2 = dnrm2_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1);
+ lnrm = dlapy2_(&d__1, &d__2);
+ dgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[ks * vr_dim1
+ + 1], &c__1, &c_b21, &work[1], &c__1);
+ tmprr = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &
+ c__1);
+ tmpri = ddot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1],
+ &c__1);
+ dgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[(ks + 1) *
+ vr_dim1 + 1], &c__1, &c_b21, &work[1], &c__1);
+ tmpii = ddot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1],
+ &c__1);
+ tmpir = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &
+ c__1);
+ uhav = tmprr + tmpii;
+ uhavi = tmpir - tmpri;
+ dgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[ks * vr_dim1
+ + 1], &c__1, &c_b21, &work[1], &c__1);
+ tmprr = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &
+ c__1);
+ tmpri = ddot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1],
+ &c__1);
+ dgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[(ks + 1) *
+ vr_dim1 + 1], &c__1, &c_b21, &work[1], &c__1);
+ tmpii = ddot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1],
+ &c__1);
+ tmpir = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &
+ c__1);
+ uhbv = tmprr + tmpii;
+ uhbvi = tmpir - tmpri;
+ uhav = dlapy2_(&uhav, &uhavi);
+ uhbv = dlapy2_(&uhbv, &uhbvi);
+ cond = dlapy2_(&uhav, &uhbv);
+ s[ks] = cond / (rnrm * lnrm);
+ s[ks + 1] = s[ks];
+
+ } else {
+
+/* Real eigenvalue. */
+
+ rnrm = dnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
+ lnrm = dnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
+ dgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[ks * vr_dim1
+ + 1], &c__1, &c_b21, &work[1], &c__1);
+ uhav = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1)
+ ;
+ dgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[ks * vr_dim1
+ + 1], &c__1, &c_b21, &work[1], &c__1);
+ uhbv = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1)
+ ;
+ cond = dlapy2_(&uhav, &uhbv);
+ if (cond == 0.) {
+ s[ks] = -1.;
+ } else {
+ s[ks] = cond / (rnrm * lnrm);
+ }
+ }
+ }
+
+ if (wantdf) {
+ if (*n == 1) {
+ dif[ks] = dlapy2_(&a[a_dim1 + 1], &b[b_dim1 + 1]);
+ goto L20;
+ }
+
+/* Estimate the reciprocal condition number of the k-th */
+/* eigenvectors. */
+ if (pair) {
+
+/* Copy the 2-by 2 pencil beginning at (A(k,k), B(k, k)). */
+/* Compute the eigenvalue(s) at position K. */
+
+ work[1] = a[k + k * a_dim1];
+ work[2] = a[k + 1 + k * a_dim1];
+ work[3] = a[k + (k + 1) * a_dim1];
+ work[4] = a[k + 1 + (k + 1) * a_dim1];
+ work[5] = b[k + k * b_dim1];
+ work[6] = b[k + 1 + k * b_dim1];
+ work[7] = b[k + (k + 1) * b_dim1];
+ work[8] = b[k + 1 + (k + 1) * b_dim1];
+ d__1 = smlnum * eps;
+ dlag2_(&work[1], &c__2, &work[5], &c__2, &d__1, &beta, dummy1,
+ &alphar, dummy, &alphai);
+ alprqt = 1.;
+ c1 = (alphar * alphar + alphai * alphai + beta * beta) * 2.;
+ c2 = beta * 4. * beta * alphai * alphai;
+ root1 = c1 + sqrt(c1 * c1 - c2 * 4.);
+ root2 = c2 / root1;
+ root1 /= 2.;
+/* Computing MIN */
+ d__1 = sqrt(root1), d__2 = sqrt(root2);
+ cond = min(d__1,d__2);
+ }
+
+/* Copy the matrix (A, B) to the array WORK and swap the */
+/* diagonal block beginning at A(k,k) to the (1,1) position. */
+
+ dlacpy_("Full", n, n, &a[a_offset], lda, &work[1], n);
+ dlacpy_("Full", n, n, &b[b_offset], ldb, &work[*n * *n + 1], n);
+ ifst = k;
+ ilst = 1;
+
+ i__2 = *lwork - (*n << 1) * *n;
+ dtgexc_(&c_false, &c_false, n, &work[1], n, &work[*n * *n + 1], n,
+ dummy, &c__1, dummy1, &c__1, &ifst, &ilst, &work[(*n * *
+ n << 1) + 1], &i__2, &ierr);
+
+ if (ierr > 0) {
+
+/* Ill-conditioned problem - swap rejected. */
+
+ dif[ks] = 0.;
+ } else {
+
+/* Reordering successful, solve generalized Sylvester */
+/* equation for R and L, */
+/* A22 * R - L * A11 = A12 */
+/* B22 * R - L * B11 = B12, */
+/* and compute estimate of Difl((A11,B11), (A22, B22)). */
+
+ n1 = 1;
+ if (work[2] != 0.) {
+ n1 = 2;
+ }
+ n2 = *n - n1;
+ if (n2 == 0) {
+ dif[ks] = cond;
+ } else {
+ i__ = *n * *n + 1;
+ iz = (*n << 1) * *n + 1;
+ i__2 = *lwork - (*n << 1) * *n;
+ dtgsyl_("N", &c__3, &n2, &n1, &work[*n * n1 + n1 + 1], n,
+ &work[1], n, &work[n1 + 1], n, &work[*n * n1 + n1
+ + i__], n, &work[i__], n, &work[n1 + i__], n, &
+ scale, &dif[ks], &work[iz + 1], &i__2, &iwork[1],
+ &ierr);
+
+ if (pair) {
+/* Computing MIN */
+ d__1 = max(1.,alprqt) * dif[ks];
+ dif[ks] = min(d__1,cond);
+ }
+ }
+ }
+ if (pair) {
+ dif[ks + 1] = dif[ks];
+ }
+ }
+ if (pair) {
+ ++ks;
+ }
+
+L20:
+ ;
+ }
+ work[1] = (doublereal) lwmin;
+ return 0;
+
+/* End of DTGSNA */
+
+} /* dtgsna_ */
diff --git a/SRC/dtgsy2.c b/SRC/dtgsy2.c
new file mode 100644
index 0000000..ed0a92d
--- /dev/null
+++ b/SRC/dtgsy2.c
@@ -0,0 +1,1113 @@
+/* dtgsy2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static integer c__1 = 1;
+static doublereal c_b27 = -1.;
+static doublereal c_b42 = 1.;
+static doublereal c_b56 = 0.;
+
+/* Subroutine */ int dtgsy2_(char *trans, integer *ijob, integer *m, integer *
+ n, doublereal *a, integer *lda, doublereal *b, integer *ldb,
+ doublereal *c__, integer *ldc, doublereal *d__, integer *ldd,
+ doublereal *e, integer *lde, doublereal *f, integer *ldf, doublereal *
+ scale, doublereal *rdsum, doublereal *rdscal, integer *iwork, integer
+ *pq, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
+ d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, k, p, q;
+ doublereal z__[64] /* was [8][8] */;
+ integer ie, je, mb, nb, ii, jj, is, js;
+ doublereal rhs[8];
+ integer isp1, jsp1;
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer ierr, zdim, ipiv[8], jpiv[8];
+ doublereal alpha;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *), dgemm_(char *, char *, integer *, integer *, integer *
+, doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dcopy_(integer *,
+ doublereal *, integer *, doublereal *, integer *), daxpy_(integer
+ *, doublereal *, doublereal *, integer *, doublereal *, integer *)
+ , dgesc2_(integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *, doublereal *), dgetc2_(integer *,
+ doublereal *, integer *, integer *, integer *, integer *),
+ dlatdf_(integer *, integer *, doublereal *, integer *, doublereal
+ *, doublereal *, doublereal *, integer *, integer *);
+ doublereal scaloc;
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ logical notran;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTGSY2 solves the generalized Sylvester equation: */
+
+/* A * R - L * B = scale * C (1) */
+/* D * R - L * E = scale * F, */
+
+/* using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices, */
+/* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M, */
+/* N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E) */
+/* must be in generalized Schur canonical form, i.e. A, B are upper */
+/* quasi triangular and D, E are upper triangular. The solution (R, L) */
+/* overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor */
+/* chosen to avoid overflow. */
+
+/* In matrix notation solving equation (1) corresponds to solve */
+/* Z*x = scale*b, where Z is defined as */
+
+/* Z = [ kron(In, A) -kron(B', Im) ] (2) */
+/* [ kron(In, D) -kron(E', Im) ], */
+
+/* Ik is the identity matrix of size k and X' is the transpose of X. */
+/* kron(X, Y) is the Kronecker product between the matrices X and Y. */
+/* In the process of solving (1), we solve a number of such systems */
+/* where Dim(In), Dim(In) = 1 or 2. */
+
+/* If TRANS = 'T', solve the transposed system Z'*y = scale*b for y, */
+/* which is equivalent to solve for R and L in */
+
+/* A' * R + D' * L = scale * C (3) */
+/* R * B' + L * E' = scale * -F */
+
+/* This case is used to compute an estimate of Dif[(A, D), (B, E)] = */
+/* sigma_min(Z) using reverse communicaton with DLACON. */
+
+/* DTGSY2 also (IJOB >= 1) contributes to the computation in DTGSYL */
+/* of an upper bound on the separation between to matrix pairs. Then */
+/* the input (A, D), (B, E) are sub-pencils of the matrix pair in */
+/* DTGSYL. See DTGSYL for details. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N', solve the generalized Sylvester equation (1). */
+/* = 'T': solve the 'transposed' system (3). */
+
+/* IJOB (input) INTEGER */
+/* Specifies what kind of functionality to be performed. */
+/* = 0: solve (1) only. */
+/* = 1: A contribution from this subsystem to a Frobenius */
+/* norm-based estimate of the separation between two matrix */
+/* pairs is computed. (look ahead strategy is used). */
+/* = 2: A contribution from this subsystem to a Frobenius */
+/* norm-based estimate of the separation between two matrix */
+/* pairs is computed. (DGECON on sub-systems is used.) */
+/* Not referenced if TRANS = 'T'. */
+
+/* M (input) INTEGER */
+/* On entry, M specifies the order of A and D, and the row */
+/* dimension of C, F, R and L. */
+
+/* N (input) INTEGER */
+/* On entry, N specifies the order of B and E, and the column */
+/* dimension of C, F, R and L. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA, M) */
+/* On entry, A contains an upper quasi triangular matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the matrix A. LDA >= max(1, M). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB, N) */
+/* On entry, B contains an upper quasi triangular matrix. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the matrix B. LDB >= max(1, N). */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC, N) */
+/* On entry, C contains the right-hand-side of the first matrix */
+/* equation in (1). */
+/* On exit, if IJOB = 0, C has been overwritten by the */
+/* solution R. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the matrix C. LDC >= max(1, M). */
+
+/* D (input) DOUBLE PRECISION array, dimension (LDD, M) */
+/* On entry, D contains an upper triangular matrix. */
+
+/* LDD (input) INTEGER */
+/* The leading dimension of the matrix D. LDD >= max(1, M). */
+
+/* E (input) DOUBLE PRECISION array, dimension (LDE, N) */
+/* On entry, E contains an upper triangular matrix. */
+
+/* LDE (input) INTEGER */
+/* The leading dimension of the matrix E. LDE >= max(1, N). */
+
+/* F (input/output) DOUBLE PRECISION array, dimension (LDF, N) */
+/* On entry, F contains the right-hand-side of the second matrix */
+/* equation in (1). */
+/* On exit, if IJOB = 0, F has been overwritten by the */
+/* solution L. */
+
+/* LDF (input) INTEGER */
+/* The leading dimension of the matrix F. LDF >= max(1, M). */
+
+/* SCALE (output) DOUBLE PRECISION */
+/* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions */
+/* R and L (C and F on entry) will hold the solutions to a */
+/* slightly perturbed system but the input matrices A, B, D and */
+/* E have not been changed. If SCALE = 0, R and L will hold the */
+/* solutions to the homogeneous system with C = F = 0. Normally, */
+/* SCALE = 1. */
+
+/* RDSUM (input/output) DOUBLE PRECISION */
+/* On entry, the sum of squares of computed contributions to */
+/* the Dif-estimate under computation by DTGSYL, where the */
+/* scaling factor RDSCAL (see below) has been factored out. */
+/* On exit, the corresponding sum of squares updated with the */
+/* contributions from the current sub-system. */
+/* If TRANS = 'T' RDSUM is not touched. */
+/* NOTE: RDSUM only makes sense when DTGSY2 is called by DTGSYL. */
+
+/* RDSCAL (input/output) DOUBLE PRECISION */
+/* On entry, scaling factor used to prevent overflow in RDSUM. */
+/* On exit, RDSCAL is updated w.r.t. the current contributions */
+/* in RDSUM. */
+/* If TRANS = 'T', RDSCAL is not touched. */
+/* NOTE: RDSCAL only makes sense when DTGSY2 is called by */
+/* DTGSYL. */
+
+/* IWORK (workspace) INTEGER array, dimension (M+N+2) */
+
+/* PQ (output) INTEGER */
+/* On exit, the number of subsystems (of size 2-by-2, 4-by-4 and */
+/* 8-by-8) solved by this routine. */
+
+/* INFO (output) INTEGER */
+/* On exit, if INFO is set to */
+/* =0: Successful exit */
+/* <0: If INFO = -i, the i-th argument had an illegal value. */
+/* >0: The matrix pairs (A, D) and (B, E) have common or very */
+/* close eigenvalues. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* ===================================================================== */
+/* Replaced various illegal calls to DCOPY by calls to DLASET. */
+/* Sven Hammarling, 27/5/02. */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ d_dim1 = *ldd;
+ d_offset = 1 + d_dim1;
+ d__ -= d_offset;
+ e_dim1 = *lde;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ f_dim1 = *ldf;
+ f_offset = 1 + f_dim1;
+ f -= f_offset;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ ierr = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "T")) {
+ *info = -1;
+ } else if (notran) {
+ if (*ijob < 0 || *ijob > 2) {
+ *info = -2;
+ }
+ }
+ if (*info == 0) {
+ if (*m <= 0) {
+ *info = -3;
+ } else if (*n <= 0) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ } else if (*ldd < max(1,*m)) {
+ *info = -12;
+ } else if (*lde < max(1,*n)) {
+ *info = -14;
+ } else if (*ldf < max(1,*m)) {
+ *info = -16;
+ }
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTGSY2", &i__1);
+ return 0;
+ }
+
+/* Determine block structure of A */
+
+ *pq = 0;
+ p = 0;
+ i__ = 1;
+L10:
+ if (i__ > *m) {
+ goto L20;
+ }
+ ++p;
+ iwork[p] = i__;
+ if (i__ == *m) {
+ goto L20;
+ }
+ if (a[i__ + 1 + i__ * a_dim1] != 0.) {
+ i__ += 2;
+ } else {
+ ++i__;
+ }
+ goto L10;
+L20:
+ iwork[p + 1] = *m + 1;
+
+/* Determine block structure of B */
+
+ q = p + 1;
+ j = 1;
+L30:
+ if (j > *n) {
+ goto L40;
+ }
+ ++q;
+ iwork[q] = j;
+ if (j == *n) {
+ goto L40;
+ }
+ if (b[j + 1 + j * b_dim1] != 0.) {
+ j += 2;
+ } else {
+ ++j;
+ }
+ goto L30;
+L40:
+ iwork[q + 1] = *n + 1;
+ *pq = p * (q - p - 1);
+
+ if (notran) {
+
+/* Solve (I, J) - subsystem */
+/* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) */
+/* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) */
+/* for I = P, P - 1, ..., 1; J = 1, 2, ..., Q */
+
+ *scale = 1.;
+ scaloc = 1.;
+ i__1 = q;
+ for (j = p + 2; j <= i__1; ++j) {
+ js = iwork[j];
+ jsp1 = js + 1;
+ je = iwork[j + 1] - 1;
+ nb = je - js + 1;
+ for (i__ = p; i__ >= 1; --i__) {
+
+ is = iwork[i__];
+ isp1 = is + 1;
+ ie = iwork[i__ + 1] - 1;
+ mb = ie - is + 1;
+ zdim = mb * nb << 1;
+
+ if (mb == 1 && nb == 1) {
+
+/* Build a 2-by-2 system Z * x = RHS */
+
+ z__[0] = a[is + is * a_dim1];
+ z__[1] = d__[is + is * d_dim1];
+ z__[8] = -b[js + js * b_dim1];
+ z__[9] = -e[js + js * e_dim1];
+
+/* Set up right hand side(s) */
+
+ rhs[0] = c__[is + js * c_dim1];
+ rhs[1] = f[is + js * f_dim1];
+
+/* Solve Z * x = RHS */
+
+ dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
+ if (ierr > 0) {
+ *info = ierr;
+ }
+
+ if (*ijob == 0) {
+ dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
+ if (scaloc != 1.) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &
+ c__1);
+ dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L50: */
+ }
+ *scale *= scaloc;
+ }
+ } else {
+ dlatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal,
+ ipiv, jpiv);
+ }
+
+/* Unpack solution vector(s) */
+
+ c__[is + js * c_dim1] = rhs[0];
+ f[is + js * f_dim1] = rhs[1];
+
+/* Substitute R(I, J) and L(I, J) into remaining */
+/* equation. */
+
+ if (i__ > 1) {
+ alpha = -rhs[0];
+ i__2 = is - 1;
+ daxpy_(&i__2, &alpha, &a[is * a_dim1 + 1], &c__1, &
+ c__[js * c_dim1 + 1], &c__1);
+ i__2 = is - 1;
+ daxpy_(&i__2, &alpha, &d__[is * d_dim1 + 1], &c__1, &
+ f[js * f_dim1 + 1], &c__1);
+ }
+ if (j < q) {
+ i__2 = *n - je;
+ daxpy_(&i__2, &rhs[1], &b[js + (je + 1) * b_dim1],
+ ldb, &c__[is + (je + 1) * c_dim1], ldc);
+ i__2 = *n - je;
+ daxpy_(&i__2, &rhs[1], &e[js + (je + 1) * e_dim1],
+ lde, &f[is + (je + 1) * f_dim1], ldf);
+ }
+
+ } else if (mb == 1 && nb == 2) {
+
+/* Build a 4-by-4 system Z * x = RHS */
+
+ z__[0] = a[is + is * a_dim1];
+ z__[1] = 0.;
+ z__[2] = d__[is + is * d_dim1];
+ z__[3] = 0.;
+
+ z__[8] = 0.;
+ z__[9] = a[is + is * a_dim1];
+ z__[10] = 0.;
+ z__[11] = d__[is + is * d_dim1];
+
+ z__[16] = -b[js + js * b_dim1];
+ z__[17] = -b[js + jsp1 * b_dim1];
+ z__[18] = -e[js + js * e_dim1];
+ z__[19] = -e[js + jsp1 * e_dim1];
+
+ z__[24] = -b[jsp1 + js * b_dim1];
+ z__[25] = -b[jsp1 + jsp1 * b_dim1];
+ z__[26] = 0.;
+ z__[27] = -e[jsp1 + jsp1 * e_dim1];
+
+/* Set up right hand side(s) */
+
+ rhs[0] = c__[is + js * c_dim1];
+ rhs[1] = c__[is + jsp1 * c_dim1];
+ rhs[2] = f[is + js * f_dim1];
+ rhs[3] = f[is + jsp1 * f_dim1];
+
+/* Solve Z * x = RHS */
+
+ dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
+ if (ierr > 0) {
+ *info = ierr;
+ }
+
+ if (*ijob == 0) {
+ dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
+ if (scaloc != 1.) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &
+ c__1);
+ dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L60: */
+ }
+ *scale *= scaloc;
+ }
+ } else {
+ dlatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal,
+ ipiv, jpiv);
+ }
+
+/* Unpack solution vector(s) */
+
+ c__[is + js * c_dim1] = rhs[0];
+ c__[is + jsp1 * c_dim1] = rhs[1];
+ f[is + js * f_dim1] = rhs[2];
+ f[is + jsp1 * f_dim1] = rhs[3];
+
+/* Substitute R(I, J) and L(I, J) into remaining */
+/* equation. */
+
+ if (i__ > 1) {
+ i__2 = is - 1;
+ dger_(&i__2, &nb, &c_b27, &a[is * a_dim1 + 1], &c__1,
+ rhs, &c__1, &c__[js * c_dim1 + 1], ldc);
+ i__2 = is - 1;
+ dger_(&i__2, &nb, &c_b27, &d__[is * d_dim1 + 1], &
+ c__1, rhs, &c__1, &f[js * f_dim1 + 1], ldf);
+ }
+ if (j < q) {
+ i__2 = *n - je;
+ daxpy_(&i__2, &rhs[2], &b[js + (je + 1) * b_dim1],
+ ldb, &c__[is + (je + 1) * c_dim1], ldc);
+ i__2 = *n - je;
+ daxpy_(&i__2, &rhs[2], &e[js + (je + 1) * e_dim1],
+ lde, &f[is + (je + 1) * f_dim1], ldf);
+ i__2 = *n - je;
+ daxpy_(&i__2, &rhs[3], &b[jsp1 + (je + 1) * b_dim1],
+ ldb, &c__[is + (je + 1) * c_dim1], ldc);
+ i__2 = *n - je;
+ daxpy_(&i__2, &rhs[3], &e[jsp1 + (je + 1) * e_dim1],
+ lde, &f[is + (je + 1) * f_dim1], ldf);
+ }
+
+ } else if (mb == 2 && nb == 1) {
+
+/* Build a 4-by-4 system Z * x = RHS */
+
+ z__[0] = a[is + is * a_dim1];
+ z__[1] = a[isp1 + is * a_dim1];
+ z__[2] = d__[is + is * d_dim1];
+ z__[3] = 0.;
+
+ z__[8] = a[is + isp1 * a_dim1];
+ z__[9] = a[isp1 + isp1 * a_dim1];
+ z__[10] = d__[is + isp1 * d_dim1];
+ z__[11] = d__[isp1 + isp1 * d_dim1];
+
+ z__[16] = -b[js + js * b_dim1];
+ z__[17] = 0.;
+ z__[18] = -e[js + js * e_dim1];
+ z__[19] = 0.;
+
+ z__[24] = 0.;
+ z__[25] = -b[js + js * b_dim1];
+ z__[26] = 0.;
+ z__[27] = -e[js + js * e_dim1];
+
+/* Set up right hand side(s) */
+
+ rhs[0] = c__[is + js * c_dim1];
+ rhs[1] = c__[isp1 + js * c_dim1];
+ rhs[2] = f[is + js * f_dim1];
+ rhs[3] = f[isp1 + js * f_dim1];
+
+/* Solve Z * x = RHS */
+
+ dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
+ if (ierr > 0) {
+ *info = ierr;
+ }
+ if (*ijob == 0) {
+ dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
+ if (scaloc != 1.) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &
+ c__1);
+ dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L70: */
+ }
+ *scale *= scaloc;
+ }
+ } else {
+ dlatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal,
+ ipiv, jpiv);
+ }
+
+/* Unpack solution vector(s) */
+
+ c__[is + js * c_dim1] = rhs[0];
+ c__[isp1 + js * c_dim1] = rhs[1];
+ f[is + js * f_dim1] = rhs[2];
+ f[isp1 + js * f_dim1] = rhs[3];
+
+/* Substitute R(I, J) and L(I, J) into remaining */
+/* equation. */
+
+ if (i__ > 1) {
+ i__2 = is - 1;
+ dgemv_("N", &i__2, &mb, &c_b27, &a[is * a_dim1 + 1],
+ lda, rhs, &c__1, &c_b42, &c__[js * c_dim1 + 1]
+, &c__1);
+ i__2 = is - 1;
+ dgemv_("N", &i__2, &mb, &c_b27, &d__[is * d_dim1 + 1],
+ ldd, rhs, &c__1, &c_b42, &f[js * f_dim1 + 1],
+ &c__1);
+ }
+ if (j < q) {
+ i__2 = *n - je;
+ dger_(&mb, &i__2, &c_b42, &rhs[2], &c__1, &b[js + (je
+ + 1) * b_dim1], ldb, &c__[is + (je + 1) *
+ c_dim1], ldc);
+ i__2 = *n - je;
+ dger_(&mb, &i__2, &c_b42, &rhs[2], &c__1, &e[js + (je
+ + 1) * e_dim1], lde, &f[is + (je + 1) *
+ f_dim1], ldf);
+ }
+
+ } else if (mb == 2 && nb == 2) {
+
+/* Build an 8-by-8 system Z * x = RHS */
+
+ dlaset_("F", &c__8, &c__8, &c_b56, &c_b56, z__, &c__8);
+
+ z__[0] = a[is + is * a_dim1];
+ z__[1] = a[isp1 + is * a_dim1];
+ z__[4] = d__[is + is * d_dim1];
+
+ z__[8] = a[is + isp1 * a_dim1];
+ z__[9] = a[isp1 + isp1 * a_dim1];
+ z__[12] = d__[is + isp1 * d_dim1];
+ z__[13] = d__[isp1 + isp1 * d_dim1];
+
+ z__[18] = a[is + is * a_dim1];
+ z__[19] = a[isp1 + is * a_dim1];
+ z__[22] = d__[is + is * d_dim1];
+
+ z__[26] = a[is + isp1 * a_dim1];
+ z__[27] = a[isp1 + isp1 * a_dim1];
+ z__[30] = d__[is + isp1 * d_dim1];
+ z__[31] = d__[isp1 + isp1 * d_dim1];
+
+ z__[32] = -b[js + js * b_dim1];
+ z__[34] = -b[js + jsp1 * b_dim1];
+ z__[36] = -e[js + js * e_dim1];
+ z__[38] = -e[js + jsp1 * e_dim1];
+
+ z__[41] = -b[js + js * b_dim1];
+ z__[43] = -b[js + jsp1 * b_dim1];
+ z__[45] = -e[js + js * e_dim1];
+ z__[47] = -e[js + jsp1 * e_dim1];
+
+ z__[48] = -b[jsp1 + js * b_dim1];
+ z__[50] = -b[jsp1 + jsp1 * b_dim1];
+ z__[54] = -e[jsp1 + jsp1 * e_dim1];
+
+ z__[57] = -b[jsp1 + js * b_dim1];
+ z__[59] = -b[jsp1 + jsp1 * b_dim1];
+ z__[63] = -e[jsp1 + jsp1 * e_dim1];
+
+/* Set up right hand side(s) */
+
+ k = 1;
+ ii = mb * nb + 1;
+ i__2 = nb - 1;
+ for (jj = 0; jj <= i__2; ++jj) {
+ dcopy_(&mb, &c__[is + (js + jj) * c_dim1], &c__1, &
+ rhs[k - 1], &c__1);
+ dcopy_(&mb, &f[is + (js + jj) * f_dim1], &c__1, &rhs[
+ ii - 1], &c__1);
+ k += mb;
+ ii += mb;
+/* L80: */
+ }
+
+/* Solve Z * x = RHS */
+
+ dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
+ if (ierr > 0) {
+ *info = ierr;
+ }
+ if (*ijob == 0) {
+ dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
+ if (scaloc != 1.) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &
+ c__1);
+ dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L90: */
+ }
+ *scale *= scaloc;
+ }
+ } else {
+ dlatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal,
+ ipiv, jpiv);
+ }
+
+/* Unpack solution vector(s) */
+
+ k = 1;
+ ii = mb * nb + 1;
+ i__2 = nb - 1;
+ for (jj = 0; jj <= i__2; ++jj) {
+ dcopy_(&mb, &rhs[k - 1], &c__1, &c__[is + (js + jj) *
+ c_dim1], &c__1);
+ dcopy_(&mb, &rhs[ii - 1], &c__1, &f[is + (js + jj) *
+ f_dim1], &c__1);
+ k += mb;
+ ii += mb;
+/* L100: */
+ }
+
+/* Substitute R(I, J) and L(I, J) into remaining */
+/* equation. */
+
+ if (i__ > 1) {
+ i__2 = is - 1;
+ dgemm_("N", "N", &i__2, &nb, &mb, &c_b27, &a[is *
+ a_dim1 + 1], lda, rhs, &mb, &c_b42, &c__[js *
+ c_dim1 + 1], ldc);
+ i__2 = is - 1;
+ dgemm_("N", "N", &i__2, &nb, &mb, &c_b27, &d__[is *
+ d_dim1 + 1], ldd, rhs, &mb, &c_b42, &f[js *
+ f_dim1 + 1], ldf);
+ }
+ if (j < q) {
+ k = mb * nb + 1;
+ i__2 = *n - je;
+ dgemm_("N", "N", &mb, &i__2, &nb, &c_b42, &rhs[k - 1],
+ &mb, &b[js + (je + 1) * b_dim1], ldb, &c_b42,
+ &c__[is + (je + 1) * c_dim1], ldc);
+ i__2 = *n - je;
+ dgemm_("N", "N", &mb, &i__2, &nb, &c_b42, &rhs[k - 1],
+ &mb, &e[js + (je + 1) * e_dim1], lde, &c_b42,
+ &f[is + (je + 1) * f_dim1], ldf);
+ }
+
+ }
+
+/* L110: */
+ }
+/* L120: */
+ }
+ } else {
+
+/* Solve (I, J) - subsystem */
+/* A(I, I)' * R(I, J) + D(I, I)' * L(J, J) = C(I, J) */
+/* R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) */
+/* for I = 1, 2, ..., P, J = Q, Q - 1, ..., 1 */
+
+ *scale = 1.;
+ scaloc = 1.;
+ i__1 = p;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+ is = iwork[i__];
+ isp1 = is + 1;
+ ie = i__;
+ mb = ie - is + 1;
+ i__2 = p + 2;
+ for (j = q; j >= i__2; --j) {
+
+ js = iwork[j];
+ jsp1 = js + 1;
+ je = iwork[j + 1] - 1;
+ nb = je - js + 1;
+ zdim = mb * nb << 1;
+ if (mb == 1 && nb == 1) {
+
+/* Build a 2-by-2 system Z' * x = RHS */
+
+ z__[0] = a[is + is * a_dim1];
+ z__[1] = -b[js + js * b_dim1];
+ z__[8] = d__[is + is * d_dim1];
+ z__[9] = -e[js + js * e_dim1];
+
+/* Set up right hand side(s) */
+
+ rhs[0] = c__[is + js * c_dim1];
+ rhs[1] = f[is + js * f_dim1];
+
+/* Solve Z' * x = RHS */
+
+ dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
+ if (ierr > 0) {
+ *info = ierr;
+ }
+
+ dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
+ if (scaloc != 1.) {
+ i__3 = *n;
+ for (k = 1; k <= i__3; ++k) {
+ dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
+ dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L130: */
+ }
+ *scale *= scaloc;
+ }
+
+/* Unpack solution vector(s) */
+
+ c__[is + js * c_dim1] = rhs[0];
+ f[is + js * f_dim1] = rhs[1];
+
+/* Substitute R(I, J) and L(I, J) into remaining */
+/* equation. */
+
+ if (j > p + 2) {
+ alpha = rhs[0];
+ i__3 = js - 1;
+ daxpy_(&i__3, &alpha, &b[js * b_dim1 + 1], &c__1, &f[
+ is + f_dim1], ldf);
+ alpha = rhs[1];
+ i__3 = js - 1;
+ daxpy_(&i__3, &alpha, &e[js * e_dim1 + 1], &c__1, &f[
+ is + f_dim1], ldf);
+ }
+ if (i__ < p) {
+ alpha = -rhs[0];
+ i__3 = *m - ie;
+ daxpy_(&i__3, &alpha, &a[is + (ie + 1) * a_dim1], lda,
+ &c__[ie + 1 + js * c_dim1], &c__1);
+ alpha = -rhs[1];
+ i__3 = *m - ie;
+ daxpy_(&i__3, &alpha, &d__[is + (ie + 1) * d_dim1],
+ ldd, &c__[ie + 1 + js * c_dim1], &c__1);
+ }
+
+ } else if (mb == 1 && nb == 2) {
+
+/* Build a 4-by-4 system Z' * x = RHS */
+
+ z__[0] = a[is + is * a_dim1];
+ z__[1] = 0.;
+ z__[2] = -b[js + js * b_dim1];
+ z__[3] = -b[jsp1 + js * b_dim1];
+
+ z__[8] = 0.;
+ z__[9] = a[is + is * a_dim1];
+ z__[10] = -b[js + jsp1 * b_dim1];
+ z__[11] = -b[jsp1 + jsp1 * b_dim1];
+
+ z__[16] = d__[is + is * d_dim1];
+ z__[17] = 0.;
+ z__[18] = -e[js + js * e_dim1];
+ z__[19] = 0.;
+
+ z__[24] = 0.;
+ z__[25] = d__[is + is * d_dim1];
+ z__[26] = -e[js + jsp1 * e_dim1];
+ z__[27] = -e[jsp1 + jsp1 * e_dim1];
+
+/* Set up right hand side(s) */
+
+ rhs[0] = c__[is + js * c_dim1];
+ rhs[1] = c__[is + jsp1 * c_dim1];
+ rhs[2] = f[is + js * f_dim1];
+ rhs[3] = f[is + jsp1 * f_dim1];
+
+/* Solve Z' * x = RHS */
+
+ dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
+ if (ierr > 0) {
+ *info = ierr;
+ }
+ dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
+ if (scaloc != 1.) {
+ i__3 = *n;
+ for (k = 1; k <= i__3; ++k) {
+ dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
+ dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L140: */
+ }
+ *scale *= scaloc;
+ }
+
+/* Unpack solution vector(s) */
+
+ c__[is + js * c_dim1] = rhs[0];
+ c__[is + jsp1 * c_dim1] = rhs[1];
+ f[is + js * f_dim1] = rhs[2];
+ f[is + jsp1 * f_dim1] = rhs[3];
+
+/* Substitute R(I, J) and L(I, J) into remaining */
+/* equation. */
+
+ if (j > p + 2) {
+ i__3 = js - 1;
+ daxpy_(&i__3, rhs, &b[js * b_dim1 + 1], &c__1, &f[is
+ + f_dim1], ldf);
+ i__3 = js - 1;
+ daxpy_(&i__3, &rhs[1], &b[jsp1 * b_dim1 + 1], &c__1, &
+ f[is + f_dim1], ldf);
+ i__3 = js - 1;
+ daxpy_(&i__3, &rhs[2], &e[js * e_dim1 + 1], &c__1, &f[
+ is + f_dim1], ldf);
+ i__3 = js - 1;
+ daxpy_(&i__3, &rhs[3], &e[jsp1 * e_dim1 + 1], &c__1, &
+ f[is + f_dim1], ldf);
+ }
+ if (i__ < p) {
+ i__3 = *m - ie;
+ dger_(&i__3, &nb, &c_b27, &a[is + (ie + 1) * a_dim1],
+ lda, rhs, &c__1, &c__[ie + 1 + js * c_dim1],
+ ldc);
+ i__3 = *m - ie;
+ dger_(&i__3, &nb, &c_b27, &d__[is + (ie + 1) * d_dim1]
+, ldd, &rhs[2], &c__1, &c__[ie + 1 + js *
+ c_dim1], ldc);
+ }
+
+ } else if (mb == 2 && nb == 1) {
+
+/* Build a 4-by-4 system Z' * x = RHS */
+
+ z__[0] = a[is + is * a_dim1];
+ z__[1] = a[is + isp1 * a_dim1];
+ z__[2] = -b[js + js * b_dim1];
+ z__[3] = 0.;
+
+ z__[8] = a[isp1 + is * a_dim1];
+ z__[9] = a[isp1 + isp1 * a_dim1];
+ z__[10] = 0.;
+ z__[11] = -b[js + js * b_dim1];
+
+ z__[16] = d__[is + is * d_dim1];
+ z__[17] = d__[is + isp1 * d_dim1];
+ z__[18] = -e[js + js * e_dim1];
+ z__[19] = 0.;
+
+ z__[24] = 0.;
+ z__[25] = d__[isp1 + isp1 * d_dim1];
+ z__[26] = 0.;
+ z__[27] = -e[js + js * e_dim1];
+
+/* Set up right hand side(s) */
+
+ rhs[0] = c__[is + js * c_dim1];
+ rhs[1] = c__[isp1 + js * c_dim1];
+ rhs[2] = f[is + js * f_dim1];
+ rhs[3] = f[isp1 + js * f_dim1];
+
+/* Solve Z' * x = RHS */
+
+ dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
+ if (ierr > 0) {
+ *info = ierr;
+ }
+
+ dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
+ if (scaloc != 1.) {
+ i__3 = *n;
+ for (k = 1; k <= i__3; ++k) {
+ dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
+ dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L150: */
+ }
+ *scale *= scaloc;
+ }
+
+/* Unpack solution vector(s) */
+
+ c__[is + js * c_dim1] = rhs[0];
+ c__[isp1 + js * c_dim1] = rhs[1];
+ f[is + js * f_dim1] = rhs[2];
+ f[isp1 + js * f_dim1] = rhs[3];
+
+/* Substitute R(I, J) and L(I, J) into remaining */
+/* equation. */
+
+ if (j > p + 2) {
+ i__3 = js - 1;
+ dger_(&mb, &i__3, &c_b42, rhs, &c__1, &b[js * b_dim1
+ + 1], &c__1, &f[is + f_dim1], ldf);
+ i__3 = js - 1;
+ dger_(&mb, &i__3, &c_b42, &rhs[2], &c__1, &e[js *
+ e_dim1 + 1], &c__1, &f[is + f_dim1], ldf);
+ }
+ if (i__ < p) {
+ i__3 = *m - ie;
+ dgemv_("T", &mb, &i__3, &c_b27, &a[is + (ie + 1) *
+ a_dim1], lda, rhs, &c__1, &c_b42, &c__[ie + 1
+ + js * c_dim1], &c__1);
+ i__3 = *m - ie;
+ dgemv_("T", &mb, &i__3, &c_b27, &d__[is + (ie + 1) *
+ d_dim1], ldd, &rhs[2], &c__1, &c_b42, &c__[ie
+ + 1 + js * c_dim1], &c__1);
+ }
+
+ } else if (mb == 2 && nb == 2) {
+
+/* Build an 8-by-8 system Z' * x = RHS */
+
+ dlaset_("F", &c__8, &c__8, &c_b56, &c_b56, z__, &c__8);
+
+ z__[0] = a[is + is * a_dim1];
+ z__[1] = a[is + isp1 * a_dim1];
+ z__[4] = -b[js + js * b_dim1];
+ z__[6] = -b[jsp1 + js * b_dim1];
+
+ z__[8] = a[isp1 + is * a_dim1];
+ z__[9] = a[isp1 + isp1 * a_dim1];
+ z__[13] = -b[js + js * b_dim1];
+ z__[15] = -b[jsp1 + js * b_dim1];
+
+ z__[18] = a[is + is * a_dim1];
+ z__[19] = a[is + isp1 * a_dim1];
+ z__[20] = -b[js + jsp1 * b_dim1];
+ z__[22] = -b[jsp1 + jsp1 * b_dim1];
+
+ z__[26] = a[isp1 + is * a_dim1];
+ z__[27] = a[isp1 + isp1 * a_dim1];
+ z__[29] = -b[js + jsp1 * b_dim1];
+ z__[31] = -b[jsp1 + jsp1 * b_dim1];
+
+ z__[32] = d__[is + is * d_dim1];
+ z__[33] = d__[is + isp1 * d_dim1];
+ z__[36] = -e[js + js * e_dim1];
+
+ z__[41] = d__[isp1 + isp1 * d_dim1];
+ z__[45] = -e[js + js * e_dim1];
+
+ z__[50] = d__[is + is * d_dim1];
+ z__[51] = d__[is + isp1 * d_dim1];
+ z__[52] = -e[js + jsp1 * e_dim1];
+ z__[54] = -e[jsp1 + jsp1 * e_dim1];
+
+ z__[59] = d__[isp1 + isp1 * d_dim1];
+ z__[61] = -e[js + jsp1 * e_dim1];
+ z__[63] = -e[jsp1 + jsp1 * e_dim1];
+
+/* Set up right hand side(s) */
+
+ k = 1;
+ ii = mb * nb + 1;
+ i__3 = nb - 1;
+ for (jj = 0; jj <= i__3; ++jj) {
+ dcopy_(&mb, &c__[is + (js + jj) * c_dim1], &c__1, &
+ rhs[k - 1], &c__1);
+ dcopy_(&mb, &f[is + (js + jj) * f_dim1], &c__1, &rhs[
+ ii - 1], &c__1);
+ k += mb;
+ ii += mb;
+/* L160: */
+ }
+
+
+/* Solve Z' * x = RHS */
+
+ dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
+ if (ierr > 0) {
+ *info = ierr;
+ }
+
+ dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
+ if (scaloc != 1.) {
+ i__3 = *n;
+ for (k = 1; k <= i__3; ++k) {
+ dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
+ dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L170: */
+ }
+ *scale *= scaloc;
+ }
+
+/* Unpack solution vector(s) */
+
+ k = 1;
+ ii = mb * nb + 1;
+ i__3 = nb - 1;
+ for (jj = 0; jj <= i__3; ++jj) {
+ dcopy_(&mb, &rhs[k - 1], &c__1, &c__[is + (js + jj) *
+ c_dim1], &c__1);
+ dcopy_(&mb, &rhs[ii - 1], &c__1, &f[is + (js + jj) *
+ f_dim1], &c__1);
+ k += mb;
+ ii += mb;
+/* L180: */
+ }
+
+/* Substitute R(I, J) and L(I, J) into remaining */
+/* equation. */
+
+ if (j > p + 2) {
+ i__3 = js - 1;
+ dgemm_("N", "T", &mb, &i__3, &nb, &c_b42, &c__[is +
+ js * c_dim1], ldc, &b[js * b_dim1 + 1], ldb, &
+ c_b42, &f[is + f_dim1], ldf);
+ i__3 = js - 1;
+ dgemm_("N", "T", &mb, &i__3, &nb, &c_b42, &f[is + js *
+ f_dim1], ldf, &e[js * e_dim1 + 1], lde, &
+ c_b42, &f[is + f_dim1], ldf);
+ }
+ if (i__ < p) {
+ i__3 = *m - ie;
+ dgemm_("T", "N", &i__3, &nb, &mb, &c_b27, &a[is + (ie
+ + 1) * a_dim1], lda, &c__[is + js * c_dim1],
+ ldc, &c_b42, &c__[ie + 1 + js * c_dim1], ldc);
+ i__3 = *m - ie;
+ dgemm_("T", "N", &i__3, &nb, &mb, &c_b27, &d__[is + (
+ ie + 1) * d_dim1], ldd, &f[is + js * f_dim1],
+ ldf, &c_b42, &c__[ie + 1 + js * c_dim1], ldc);
+ }
+
+ }
+
+/* L190: */
+ }
+/* L200: */
+ }
+
+ }
+ return 0;
+
+/* End of DTGSY2 */
+
+} /* dtgsy2_ */
diff --git a/SRC/dtgsyl.c b/SRC/dtgsyl.c
new file mode 100644
index 0000000..5c44e8a
--- /dev/null
+++ b/SRC/dtgsyl.c
@@ -0,0 +1,692 @@
+/* dtgsyl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__5 = 5;
+static doublereal c_b14 = 0.;
+static integer c__1 = 1;
+static doublereal c_b51 = -1.;
+static doublereal c_b52 = 1.;
+
+/* Subroutine */ int dtgsyl_(char *trans, integer *ijob, integer *m, integer *
+ n, doublereal *a, integer *lda, doublereal *b, integer *ldb,
+ doublereal *c__, integer *ldc, doublereal *d__, integer *ldd,
+ doublereal *e, integer *lde, doublereal *f, integer *ldf, doublereal *
+ scale, doublereal *dif, doublereal *work, integer *lwork, integer *
+ iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
+ d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3,
+ i__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, p, q, ie, je, mb, nb, is, js, pq;
+ doublereal dsum;
+ integer ppqq;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *), dgemm_(char *, char *, integer *, integer *, integer *
+, doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ integer ifunc, linfo, lwmin;
+ doublereal scale2;
+ extern /* Subroutine */ int dtgsy2_(char *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *, integer *);
+ doublereal dscale, scaloc;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer iround;
+ logical notran;
+ integer isolve;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTGSYL solves the generalized Sylvester equation: */
+
+/* A * R - L * B = scale * C (1) */
+/* D * R - L * E = scale * F */
+
+/* where R and L are unknown m-by-n matrices, (A, D), (B, E) and */
+/* (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n, */
+/* respectively, with real entries. (A, D) and (B, E) must be in */
+/* generalized (real) Schur canonical form, i.e. A, B are upper quasi */
+/* triangular and D, E are upper triangular. */
+
+/* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output */
+/* scaling factor chosen to avoid overflow. */
+
+/* In matrix notation (1) is equivalent to solve Zx = scale b, where */
+/* Z is defined as */
+
+/* Z = [ kron(In, A) -kron(B', Im) ] (2) */
+/* [ kron(In, D) -kron(E', Im) ]. */
+
+/* Here Ik is the identity matrix of size k and X' is the transpose of */
+/* X. kron(X, Y) is the Kronecker product between the matrices X and Y. */
+
+/* If TRANS = 'T', DTGSYL solves the transposed system Z'*y = scale*b, */
+/* which is equivalent to solve for R and L in */
+
+/* A' * R + D' * L = scale * C (3) */
+/* R * B' + L * E' = scale * (-F) */
+
+/* This case (TRANS = 'T') is used to compute an one-norm-based estimate */
+/* of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D) */
+/* and (B,E), using DLACON. */
+
+/* If IJOB >= 1, DTGSYL computes a Frobenius norm-based estimate */
+/* of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the */
+/* reciprocal of the smallest singular value of Z. See [1-2] for more */
+/* information. */
+
+/* This is a level 3 BLAS algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N', solve the generalized Sylvester equation (1). */
+/* = 'T', solve the 'transposed' system (3). */
+
+/* IJOB (input) INTEGER */
+/* Specifies what kind of functionality to be performed. */
+/* =0: solve (1) only. */
+/* =1: The functionality of 0 and 3. */
+/* =2: The functionality of 0 and 4. */
+/* =3: Only an estimate of Dif[(A,D), (B,E)] is computed. */
+/* (look ahead strategy IJOB = 1 is used). */
+/* =4: Only an estimate of Dif[(A,D), (B,E)] is computed. */
+/* ( DGECON on sub-systems is used ). */
+/* Not referenced if TRANS = 'T'. */
+
+/* M (input) INTEGER */
+/* The order of the matrices A and D, and the row dimension of */
+/* the matrices C, F, R and L. */
+
+/* N (input) INTEGER */
+/* The order of the matrices B and E, and the column dimension */
+/* of the matrices C, F, R and L. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA, M) */
+/* The upper quasi triangular matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1, M). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB, N) */
+/* The upper quasi triangular matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1, N). */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC, N) */
+/* On entry, C contains the right-hand-side of the first matrix */
+/* equation in (1) or (3). */
+/* On exit, if IJOB = 0, 1 or 2, C has been overwritten by */
+/* the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R, */
+/* the solution achieved during the computation of the */
+/* Dif-estimate. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1, M). */
+
+/* D (input) DOUBLE PRECISION array, dimension (LDD, M) */
+/* The upper triangular matrix D. */
+
+/* LDD (input) INTEGER */
+/* The leading dimension of the array D. LDD >= max(1, M). */
+
+/* E (input) DOUBLE PRECISION array, dimension (LDE, N) */
+/* The upper triangular matrix E. */
+
+/* LDE (input) INTEGER */
+/* The leading dimension of the array E. LDE >= max(1, N). */
+
+/* F (input/output) DOUBLE PRECISION array, dimension (LDF, N) */
+/* On entry, F contains the right-hand-side of the second matrix */
+/* equation in (1) or (3). */
+/* On exit, if IJOB = 0, 1 or 2, F has been overwritten by */
+/* the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L, */
+/* the solution achieved during the computation of the */
+/* Dif-estimate. */
+
+/* LDF (input) INTEGER */
+/* The leading dimension of the array F. LDF >= max(1, M). */
+
+/* DIF (output) DOUBLE PRECISION */
+/* On exit DIF is the reciprocal of a lower bound of the */
+/* reciprocal of the Dif-function, i.e. DIF is an upper bound of */
+/* Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2). */
+/* IF IJOB = 0 or TRANS = 'T', DIF is not touched. */
+
+/* SCALE (output) DOUBLE PRECISION */
+/* On exit SCALE is the scaling factor in (1) or (3). */
+/* If 0 < SCALE < 1, C and F hold the solutions R and L, resp., */
+/* to a slightly perturbed system but the input matrices A, B, D */
+/* and E have not been changed. If SCALE = 0, C and F hold the */
+/* solutions R and L, respectively, to the homogeneous system */
+/* with C = F = 0. Normally, SCALE = 1. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK > = 1. */
+/* If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N). */
+
+/* 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. */
+
+/* IWORK (workspace) INTEGER array, dimension (M+N+6) */
+
+/* INFO (output) INTEGER */
+/* =0: successful exit */
+/* <0: If INFO = -i, the i-th argument had an illegal value. */
+/* >0: (A, D) and (B, E) have common or close eigenvalues. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
+/* for Solving the Generalized Sylvester Equation and Estimating the */
+/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
+/* Department of Computing Science, Umea University, S-901 87 Umea, */
+/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */
+/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, */
+/* No 1, 1996. */
+
+/* [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester */
+/* Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal. */
+/* Appl., 15(4):1045-1060, 1994 */
+
+/* [3] B. Kagstrom and L. Westin, Generalized Schur Methods with */
+/* Condition Estimators for Solving the Generalized Sylvester */
+/* Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7, */
+/* July 1989, pp 745-751. */
+
+/* ===================================================================== */
+/* Replaced various illegal calls to DCOPY by calls to DLASET. */
+/* Sven Hammarling, 1/5/02. */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ d_dim1 = *ldd;
+ d_offset = 1 + d_dim1;
+ d__ -= d_offset;
+ e_dim1 = *lde;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ f_dim1 = *ldf;
+ f_offset = 1 + f_dim1;
+ f -= f_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+ if (! notran && ! lsame_(trans, "T")) {
+ *info = -1;
+ } else if (notran) {
+ if (*ijob < 0 || *ijob > 4) {
+ *info = -2;
+ }
+ }
+ if (*info == 0) {
+ if (*m <= 0) {
+ *info = -3;
+ } else if (*n <= 0) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ } else if (*ldd < max(1,*m)) {
+ *info = -12;
+ } else if (*lde < max(1,*n)) {
+ *info = -14;
+ } else if (*ldf < max(1,*m)) {
+ *info = -16;
+ }
+ }
+
+ if (*info == 0) {
+ if (notran) {
+ if (*ijob == 1 || *ijob == 2) {
+/* Computing MAX */
+ i__1 = 1, i__2 = (*m << 1) * *n;
+ lwmin = max(i__1,i__2);
+ } else {
+ lwmin = 1;
+ }
+ } else {
+ lwmin = 1;
+ }
+ work[1] = (doublereal) lwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -20;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTGSYL", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ *scale = 1.;
+ if (notran) {
+ if (*ijob != 0) {
+ *dif = 0.;
+ }
+ }
+ return 0;
+ }
+
+/* Determine optimal block sizes MB and NB */
+
+ mb = ilaenv_(&c__2, "DTGSYL", trans, m, n, &c_n1, &c_n1);
+ nb = ilaenv_(&c__5, "DTGSYL", trans, m, n, &c_n1, &c_n1);
+
+ isolve = 1;
+ ifunc = 0;
+ if (notran) {
+ if (*ijob >= 3) {
+ ifunc = *ijob - 2;
+ dlaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc)
+ ;
+ dlaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf);
+ } else if (*ijob >= 1) {
+ isolve = 2;
+ }
+ }
+
+ if (mb <= 1 && nb <= 1 || mb >= *m && nb >= *n) {
+
+ i__1 = isolve;
+ for (iround = 1; iround <= i__1; ++iround) {
+
+/* Use unblocked Level 2 solver */
+
+ dscale = 0.;
+ dsum = 1.;
+ pq = 0;
+ dtgsy2_(trans, &ifunc, m, n, &a[a_offset], lda, &b[b_offset], ldb,
+ &c__[c_offset], ldc, &d__[d_offset], ldd, &e[e_offset],
+ lde, &f[f_offset], ldf, scale, &dsum, &dscale, &iwork[1],
+ &pq, info);
+ if (dscale != 0.) {
+ if (*ijob == 1 || *ijob == 3) {
+ *dif = sqrt((doublereal) ((*m << 1) * *n)) / (dscale *
+ sqrt(dsum));
+ } else {
+ *dif = sqrt((doublereal) pq) / (dscale * sqrt(dsum));
+ }
+ }
+
+ if (isolve == 2 && iround == 1) {
+ if (notran) {
+ ifunc = *ijob;
+ }
+ scale2 = *scale;
+ dlacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m);
+ dlacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m);
+ dlaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc);
+ dlaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf);
+ } else if (isolve == 2 && iround == 2) {
+ dlacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc);
+ dlacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf);
+ *scale = scale2;
+ }
+/* L30: */
+ }
+
+ return 0;
+ }
+
+/* Determine block structure of A */
+
+ p = 0;
+ i__ = 1;
+L40:
+ if (i__ > *m) {
+ goto L50;
+ }
+ ++p;
+ iwork[p] = i__;
+ i__ += mb;
+ if (i__ >= *m) {
+ goto L50;
+ }
+ if (a[i__ + (i__ - 1) * a_dim1] != 0.) {
+ ++i__;
+ }
+ goto L40;
+L50:
+
+ iwork[p + 1] = *m + 1;
+ if (iwork[p] == iwork[p + 1]) {
+ --p;
+ }
+
+/* Determine block structure of B */
+
+ q = p + 1;
+ j = 1;
+L60:
+ if (j > *n) {
+ goto L70;
+ }
+ ++q;
+ iwork[q] = j;
+ j += nb;
+ if (j >= *n) {
+ goto L70;
+ }
+ if (b[j + (j - 1) * b_dim1] != 0.) {
+ ++j;
+ }
+ goto L60;
+L70:
+
+ iwork[q + 1] = *n + 1;
+ if (iwork[q] == iwork[q + 1]) {
+ --q;
+ }
+
+ if (notran) {
+
+ i__1 = isolve;
+ for (iround = 1; iround <= i__1; ++iround) {
+
+/* Solve (I, J)-subsystem */
+/* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) */
+/* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) */
+/* for I = P, P - 1,..., 1; J = 1, 2,..., Q */
+
+ dscale = 0.;
+ dsum = 1.;
+ pq = 0;
+ *scale = 1.;
+ i__2 = q;
+ for (j = p + 2; j <= i__2; ++j) {
+ js = iwork[j];
+ je = iwork[j + 1] - 1;
+ nb = je - js + 1;
+ for (i__ = p; i__ >= 1; --i__) {
+ is = iwork[i__];
+ ie = iwork[i__ + 1] - 1;
+ mb = ie - is + 1;
+ ppqq = 0;
+ dtgsy2_(trans, &ifunc, &mb, &nb, &a[is + is * a_dim1],
+ lda, &b[js + js * b_dim1], ldb, &c__[is + js *
+ c_dim1], ldc, &d__[is + is * d_dim1], ldd, &e[js
+ + js * e_dim1], lde, &f[is + js * f_dim1], ldf, &
+ scaloc, &dsum, &dscale, &iwork[q + 2], &ppqq, &
+ linfo);
+ if (linfo > 0) {
+ *info = linfo;
+ }
+
+ pq += ppqq;
+ if (scaloc != 1.) {
+ i__3 = js - 1;
+ for (k = 1; k <= i__3; ++k) {
+ dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
+ dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L80: */
+ }
+ i__3 = je;
+ for (k = js; k <= i__3; ++k) {
+ i__4 = is - 1;
+ dscal_(&i__4, &scaloc, &c__[k * c_dim1 + 1], &
+ c__1);
+ i__4 = is - 1;
+ dscal_(&i__4, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L90: */
+ }
+ i__3 = je;
+ for (k = js; k <= i__3; ++k) {
+ i__4 = *m - ie;
+ dscal_(&i__4, &scaloc, &c__[ie + 1 + k * c_dim1],
+ &c__1);
+ i__4 = *m - ie;
+ dscal_(&i__4, &scaloc, &f[ie + 1 + k * f_dim1], &
+ c__1);
+/* L100: */
+ }
+ i__3 = *n;
+ for (k = je + 1; k <= i__3; ++k) {
+ dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
+ dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L110: */
+ }
+ *scale *= scaloc;
+ }
+
+/* Substitute R(I, J) and L(I, J) into remaining */
+/* equation. */
+
+ if (i__ > 1) {
+ i__3 = is - 1;
+ dgemm_("N", "N", &i__3, &nb, &mb, &c_b51, &a[is *
+ a_dim1 + 1], lda, &c__[is + js * c_dim1], ldc,
+ &c_b52, &c__[js * c_dim1 + 1], ldc);
+ i__3 = is - 1;
+ dgemm_("N", "N", &i__3, &nb, &mb, &c_b51, &d__[is *
+ d_dim1 + 1], ldd, &c__[is + js * c_dim1], ldc,
+ &c_b52, &f[js * f_dim1 + 1], ldf);
+ }
+ if (j < q) {
+ i__3 = *n - je;
+ dgemm_("N", "N", &mb, &i__3, &nb, &c_b52, &f[is + js *
+ f_dim1], ldf, &b[js + (je + 1) * b_dim1],
+ ldb, &c_b52, &c__[is + (je + 1) * c_dim1],
+ ldc);
+ i__3 = *n - je;
+ dgemm_("N", "N", &mb, &i__3, &nb, &c_b52, &f[is + js *
+ f_dim1], ldf, &e[js + (je + 1) * e_dim1],
+ lde, &c_b52, &f[is + (je + 1) * f_dim1], ldf);
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+ if (dscale != 0.) {
+ if (*ijob == 1 || *ijob == 3) {
+ *dif = sqrt((doublereal) ((*m << 1) * *n)) / (dscale *
+ sqrt(dsum));
+ } else {
+ *dif = sqrt((doublereal) pq) / (dscale * sqrt(dsum));
+ }
+ }
+ if (isolve == 2 && iround == 1) {
+ if (notran) {
+ ifunc = *ijob;
+ }
+ scale2 = *scale;
+ dlacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m);
+ dlacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m);
+ dlaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc);
+ dlaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf);
+ } else if (isolve == 2 && iround == 2) {
+ dlacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc);
+ dlacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf);
+ *scale = scale2;
+ }
+/* L150: */
+ }
+
+ } else {
+
+/* Solve transposed (I, J)-subsystem */
+/* A(I, I)' * R(I, J) + D(I, I)' * L(I, J) = C(I, J) */
+/* R(I, J) * B(J, J)' + L(I, J) * E(J, J)' = -F(I, J) */
+/* for I = 1,2,..., P; J = Q, Q-1,..., 1 */
+
+ *scale = 1.;
+ i__1 = p;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ is = iwork[i__];
+ ie = iwork[i__ + 1] - 1;
+ mb = ie - is + 1;
+ i__2 = p + 2;
+ for (j = q; j >= i__2; --j) {
+ js = iwork[j];
+ je = iwork[j + 1] - 1;
+ nb = je - js + 1;
+ dtgsy2_(trans, &ifunc, &mb, &nb, &a[is + is * a_dim1], lda, &
+ b[js + js * b_dim1], ldb, &c__[is + js * c_dim1], ldc,
+ &d__[is + is * d_dim1], ldd, &e[js + js * e_dim1],
+ lde, &f[is + js * f_dim1], ldf, &scaloc, &dsum, &
+ dscale, &iwork[q + 2], &ppqq, &linfo);
+ if (linfo > 0) {
+ *info = linfo;
+ }
+ if (scaloc != 1.) {
+ i__3 = js - 1;
+ for (k = 1; k <= i__3; ++k) {
+ dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
+ dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L160: */
+ }
+ i__3 = je;
+ for (k = js; k <= i__3; ++k) {
+ i__4 = is - 1;
+ dscal_(&i__4, &scaloc, &c__[k * c_dim1 + 1], &c__1);
+ i__4 = is - 1;
+ dscal_(&i__4, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L170: */
+ }
+ i__3 = je;
+ for (k = js; k <= i__3; ++k) {
+ i__4 = *m - ie;
+ dscal_(&i__4, &scaloc, &c__[ie + 1 + k * c_dim1], &
+ c__1);
+ i__4 = *m - ie;
+ dscal_(&i__4, &scaloc, &f[ie + 1 + k * f_dim1], &c__1)
+ ;
+/* L180: */
+ }
+ i__3 = *n;
+ for (k = je + 1; k <= i__3; ++k) {
+ dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
+ dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L190: */
+ }
+ *scale *= scaloc;
+ }
+
+/* Substitute R(I, J) and L(I, J) into remaining equation. */
+
+ if (j > p + 2) {
+ i__3 = js - 1;
+ dgemm_("N", "T", &mb, &i__3, &nb, &c_b52, &c__[is + js *
+ c_dim1], ldc, &b[js * b_dim1 + 1], ldb, &c_b52, &
+ f[is + f_dim1], ldf);
+ i__3 = js - 1;
+ dgemm_("N", "T", &mb, &i__3, &nb, &c_b52, &f[is + js *
+ f_dim1], ldf, &e[js * e_dim1 + 1], lde, &c_b52, &
+ f[is + f_dim1], ldf);
+ }
+ if (i__ < p) {
+ i__3 = *m - ie;
+ dgemm_("T", "N", &i__3, &nb, &mb, &c_b51, &a[is + (ie + 1)
+ * a_dim1], lda, &c__[is + js * c_dim1], ldc, &
+ c_b52, &c__[ie + 1 + js * c_dim1], ldc);
+ i__3 = *m - ie;
+ dgemm_("T", "N", &i__3, &nb, &mb, &c_b51, &d__[is + (ie +
+ 1) * d_dim1], ldd, &f[is + js * f_dim1], ldf, &
+ c_b52, &c__[ie + 1 + js * c_dim1], ldc);
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+
+ }
+
+ work[1] = (doublereal) lwmin;
+
+ return 0;
+
+/* End of DTGSYL */
+
+} /* dtgsyl_ */
diff --git a/SRC/dtpcon.c b/SRC/dtpcon.c
new file mode 100644
index 0000000..b789722
--- /dev/null
+++ b/SRC/dtpcon.c
@@ -0,0 +1,233 @@
+/* dtpcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dtpcon_(char *norm, char *uplo, char *diag, integer *n,
+ doublereal *ap, doublereal *rcond, doublereal *work, integer *iwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Local variables */
+ integer ix, kase, kase1;
+ doublereal scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int drscl_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal anorm;
+ logical upper;
+ doublereal xnorm;
+ extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal dlantp_(char *, char *, char *, integer *, doublereal *,
+ doublereal *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int dlatps_(char *, char *, char *, char *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *);
+ logical onenrm;
+ char normin[1];
+ doublereal smlnum;
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTPCON estimates the reciprocal of the condition number of a packed */
+/* triangular matrix A, in either the 1-norm or the infinity-norm. */
+
+/* The norm of A is computed and an estimate is obtained for */
+/* norm(inv(A)), then the reciprocal of the condition number is */
+/* computed as */
+/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ nounit = lsame_(diag, "N");
+
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTPCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ }
+
+ *rcond = 0.;
+ smlnum = dlamch_("Safe minimum") * (doublereal) max(1,*n);
+
+/* Compute the norm of the triangular matrix A. */
+
+ anorm = dlantp_(norm, uplo, diag, n, &ap[1], &work[1]);
+
+/* Continue only if ANORM > 0. */
+
+ if (anorm > 0.) {
+
+/* Estimate the norm of the inverse of A. */
+
+ ainvnm = 0.;
+ *(unsigned char *)normin = 'N';
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kase = 0;
+L10:
+ dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(A). */
+
+ dlatps_(uplo, "No transpose", diag, normin, n, &ap[1], &work[
+ 1], &scale, &work[(*n << 1) + 1], info);
+ } else {
+
+/* Multiply by inv(A'). */
+
+ dlatps_(uplo, "Transpose", diag, normin, n, &ap[1], &work[1],
+ &scale, &work[(*n << 1) + 1], info);
+ }
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ if (scale != 1.) {
+ ix = idamax_(n, &work[1], &c__1);
+ xnorm = (d__1 = work[ix], abs(d__1));
+ if (scale < xnorm * smlnum || scale == 0.) {
+ goto L20;
+ }
+ drscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / anorm / ainvnm;
+ }
+ }
+
+L20:
+ return 0;
+
+/* End of DTPCON */
+
+} /* dtpcon_ */
diff --git a/SRC/dtprfs.c b/SRC/dtprfs.c
new file mode 100644
index 0000000..8226412
--- /dev/null
+++ b/SRC/dtprfs.c
@@ -0,0 +1,496 @@
+/* dtprfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b19 = -1.;
+
+/* Subroutine */ int dtprfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublereal *ap, doublereal *b, integer *ldb,
+ doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr,
+ doublereal *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal s;
+ integer kc;
+ doublereal xk;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *), dtpmv_(char *,
+ char *, char *, integer *, doublereal *, doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int dtpsv_(char *, char *, char *, integer *,
+ doublereal *, doublereal *, integer *),
+ dlacn2_(integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+ char transt[1];
+ logical nounit;
+ doublereal lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTPRFS provides error bounds and backward error estimates for the */
+/* solution to a system of linear equations with a triangular packed */
+/* coefficient matrix. */
+
+/* The solution matrix X must be computed by DTPTRS or some other */
+/* means before entering this routine. DTPRFS does not do iterative */
+/* refinement because doing so cannot improve the backward error. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*ldx < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTPRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A or A', depending on TRANS. */
+
+ dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+ dtpmv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1);
+ daxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1));
+/* L20: */
+ }
+
+ if (notran) {
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ kc = 1;
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+ i__3 = k;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ work[i__] += (d__1 = ap[kc + i__ - 1], abs(d__1))
+ * xk;
+/* L30: */
+ }
+ kc += k;
+/* L40: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ work[i__] += (d__1 = ap[kc + i__ - 1], abs(d__1))
+ * xk;
+/* L50: */
+ }
+ work[k] += xk;
+ kc += k;
+/* L60: */
+ }
+ }
+ } else {
+ kc = 1;
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ work[i__] += (d__1 = ap[kc + i__ - k], abs(d__1))
+ * xk;
+/* L70: */
+ }
+ kc = kc + *n - k + 1;
+/* L80: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ work[i__] += (d__1 = ap[kc + i__ - k], abs(d__1))
+ * xk;
+/* L90: */
+ }
+ work[k] += xk;
+ kc = kc + *n - k + 1;
+/* L100: */
+ }
+ }
+ }
+ } else {
+
+/* Compute abs(A')*abs(X) + abs(B). */
+
+ if (upper) {
+ kc = 1;
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__3 = k;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ s += (d__1 = ap[kc + i__ - 1], abs(d__1)) * (d__2
+ = x[i__ + j * x_dim1], abs(d__2));
+/* L110: */
+ }
+ work[k] += s;
+ kc += k;
+/* L120: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = (d__1 = x[k + j * x_dim1], abs(d__1));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ s += (d__1 = ap[kc + i__ - 1], abs(d__1)) * (d__2
+ = x[i__ + j * x_dim1], abs(d__2));
+/* L130: */
+ }
+ work[k] += s;
+ kc += k;
+/* L140: */
+ }
+ }
+ } else {
+ kc = 1;
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ s += (d__1 = ap[kc + i__ - k], abs(d__1)) * (d__2
+ = x[i__ + j * x_dim1], abs(d__2));
+/* L150: */
+ }
+ work[k] += s;
+ kc = kc + *n - k + 1;
+/* L160: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = (d__1 = x[k + j * x_dim1], abs(d__1));
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ s += (d__1 = ap[kc + i__ - k], abs(d__1)) * (d__2
+ = x[i__ + j * x_dim1], abs(d__2));
+/* L170: */
+ }
+ work[k] += s;
+ kc = kc + *n - k + 1;
+/* L180: */
+ }
+ }
+ }
+ }
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[
+ i__];
+ s = max(d__2,d__3);
+ } else {
+/* Computing MAX */
+ d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1)
+ / (work[i__] + safe1);
+ s = max(d__2,d__3);
+ }
+/* L190: */
+ }
+ berr[j] = s;
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use DLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L200: */
+ }
+
+ kase = 0;
+L210:
+ dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+ kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)'). */
+
+ dtpsv_(uplo, transt, diag, n, &ap[1], &work[*n + 1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L220: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L230: */
+ }
+ dtpsv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1);
+ }
+ goto L210;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1));
+ lstres = max(d__2,d__3);
+/* L240: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L250: */
+ }
+
+ return 0;
+
+/* End of DTPRFS */
+
+} /* dtprfs_ */
diff --git a/SRC/dtptri.c b/SRC/dtptri.c
new file mode 100644
index 0000000..a6ce4b4
--- /dev/null
+++ b/SRC/dtptri.c
@@ -0,0 +1,219 @@
+/* dtptri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dtptri_(char *uplo, char *diag, integer *n, doublereal *
+ ap, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer j, jc, jj;
+ doublereal ajj;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *,
+ doublereal *, doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer jclast;
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTPTRI computes the inverse of a real upper or lower triangular */
+/* matrix A stored in packed format. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangular matrix A, stored */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+/* On exit, the (triangular) inverse of the original matrix, in */
+/* the same packed storage format. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */
+/* matrix is singular and its inverse can not be computed. */
+
+/* Further Details */
+/* =============== */
+
+/* A triangular matrix A can be transferred to packed storage using one */
+/* of the following program segments: */
+
+/* UPLO = 'U': UPLO = 'L': */
+
+/* JC = 1 JC = 1 */
+/* DO 2 J = 1, N DO 2 J = 1, N */
+/* DO 1 I = 1, J DO 1 I = J, N */
+/* AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J) */
+/* 1 CONTINUE 1 CONTINUE */
+/* JC = JC + J JC = JC + N - J + 1 */
+/* 2 CONTINUE 2 CONTINUE */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ nounit = lsame_(diag, "N");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTPTRI", &i__1);
+ return 0;
+ }
+
+/* Check for singularity if non-unit. */
+
+ if (nounit) {
+ if (upper) {
+ jj = 0;
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ jj += *info;
+ if (ap[jj] == 0.) {
+ return 0;
+ }
+/* L10: */
+ }
+ } else {
+ jj = 1;
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ if (ap[jj] == 0.) {
+ return 0;
+ }
+ jj = jj + *n - *info + 1;
+/* L20: */
+ }
+ }
+ *info = 0;
+ }
+
+ if (upper) {
+
+/* Compute inverse of upper triangular matrix. */
+
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (nounit) {
+ ap[jc + j - 1] = 1. / ap[jc + j - 1];
+ ajj = -ap[jc + j - 1];
+ } else {
+ ajj = -1.;
+ }
+
+/* Compute elements 1:j-1 of j-th column. */
+
+ i__2 = j - 1;
+ dtpmv_("Upper", "No transpose", diag, &i__2, &ap[1], &ap[jc], &
+ c__1);
+ i__2 = j - 1;
+ dscal_(&i__2, &ajj, &ap[jc], &c__1);
+ jc += j;
+/* L30: */
+ }
+
+ } else {
+
+/* Compute inverse of lower triangular matrix. */
+
+ jc = *n * (*n + 1) / 2;
+ for (j = *n; j >= 1; --j) {
+ if (nounit) {
+ ap[jc] = 1. / ap[jc];
+ ajj = -ap[jc];
+ } else {
+ ajj = -1.;
+ }
+ if (j < *n) {
+
+/* Compute elements j+1:n of j-th column. */
+
+ i__1 = *n - j;
+ dtpmv_("Lower", "No transpose", diag, &i__1, &ap[jclast], &ap[
+ jc + 1], &c__1);
+ i__1 = *n - j;
+ dscal_(&i__1, &ajj, &ap[jc + 1], &c__1);
+ }
+ jclast = jc;
+ jc = jc - *n + j - 2;
+/* L40: */
+ }
+ }
+
+ return 0;
+
+/* End of DTPTRI */
+
+} /* dtptri_ */
diff --git a/SRC/dtptrs.c b/SRC/dtptrs.c
new file mode 100644
index 0000000..e180254
--- /dev/null
+++ b/SRC/dtptrs.c
@@ -0,0 +1,193 @@
+/* dtptrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dtptrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublereal *ap, doublereal *b, integer *ldb, integer *
+ info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ integer j, jc;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int dtpsv_(char *, char *, char *, integer *,
+ doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTPTRS solves a triangular system of the form */
+
+/* A * X = B or A**T * X = B, */
+
+/* where A is a triangular matrix of order N stored in packed format, */
+/* and B is an N-by-NRHS matrix. A check is made to verify that A is */
+/* nonsingular. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, if INFO = 0, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element of A is zero, */
+/* indicating that the matrix is singular and the */
+/* solutions X have not been computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ nounit = lsame_(diag, "N");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTPTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check for singularity. */
+
+ if (nounit) {
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ if (ap[jc + *info - 1] == 0.) {
+ return 0;
+ }
+ jc += *info;
+/* L10: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ if (ap[jc] == 0.) {
+ return 0;
+ }
+ jc = jc + *n - *info + 1;
+/* L20: */
+ }
+ }
+ }
+ *info = 0;
+
+/* Solve A * x = b or A' * x = b. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ dtpsv_(uplo, trans, diag, n, &ap[1], &b[j * b_dim1 + 1], &c__1);
+/* L30: */
+ }
+
+ return 0;
+
+/* End of DTPTRS */
+
+} /* dtptrs_ */
diff --git a/SRC/dtpttf.c b/SRC/dtpttf.c
new file mode 100644
index 0000000..86a7ba0
--- /dev/null
+++ b/SRC/dtpttf.c
@@ -0,0 +1,499 @@
+/* dtpttf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtpttf_(char *transr, char *uplo, integer *n, doublereal
+ *ap, doublereal *arf, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, k, n1, n2, ij, jp, js, nt, lda, ijp;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nisodd;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTPTTF copies a triangular matrix A from standard packed format (TP) */
+/* to rectangular full packed format (TF). */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': ARF in Normal format is wanted; */
+/* = 'T': ARF in Conjugate-transpose format is wanted. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */
+/* On entry, the upper or lower triangular matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* ARF (output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */
+/* On exit, the upper or lower triangular matrix A stored in */
+/* RFP format. For a further discussion see Notes below. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Notes */
+/* ===== */
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* even. We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* the transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* the transpose of the last three columns of AP lower. */
+/* This covers the case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 03 04 05 33 43 53 */
+/* 13 14 15 00 44 54 */
+/* 23 24 25 10 11 55 */
+/* 33 34 35 20 21 22 */
+/* 00 44 45 30 31 32 */
+/* 01 11 55 40 41 42 */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* odd. We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* the transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* the transpose of the last two columns of AP lower. */
+/* This covers the case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 02 03 04 00 33 43 */
+/* 12 13 14 10 11 44 */
+/* 22 23 24 20 21 22 */
+/* 00 33 34 30 31 32 */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+/* RFP A RFP A */
+
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "T")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTPTTF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (normaltransr) {
+ arf[0] = ap[0];
+ } else {
+ arf[0] = ap[0];
+ }
+ return 0;
+ }
+
+/* Size of array ARF(0:NT-1) */
+
+ nt = *n * (*n + 1) / 2;
+
+/* Set N1 and N2 depending on LOWER */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* If N is odd, set NISODD = .TRUE. */
+/* If N is even, set K = N/2 and NISODD = .FALSE. */
+
+/* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) */
+/* where noe = 0 if n is even, noe = 1 if n is odd */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ lda = *n + 1;
+ } else {
+ nisodd = TRUE_;
+ lda = *n;
+ }
+
+/* ARF^C has lda rows and n+1-noe cols */
+
+ if (! normaltransr) {
+ lda = (*n + 1) / 2;
+ }
+
+/* start execution: there are eight cases */
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* N is odd, TRANSR = 'N', and UPLO = 'L' */
+
+ ijp = 0;
+ jp = 0;
+ i__1 = n2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ij = i__ + jp;
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ jp += lda;
+ }
+ i__1 = n2 - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = n2;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ ij = i__ + j * lda;
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ }
+
+ } else {
+
+/* N is odd, TRANSR = 'N', and UPLO = 'U' */
+
+ ijp = 0;
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ ij = n2 + j;
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ ij += lda;
+ }
+ }
+ js = 0;
+ i__1 = *n - 1;
+ for (j = n1; j <= i__1; ++j) {
+ ij = js;
+ i__2 = js + j;
+ for (ij = js; ij <= i__2; ++ij) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ js += lda;
+ }
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'T' */
+
+ if (lower) {
+
+/* N is odd, TRANSR = 'T', and UPLO = 'L' */
+
+ ijp = 0;
+ i__1 = n2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = *n * lda - 1;
+ i__3 = lda;
+ for (ij = i__ * (lda + 1); i__3 < 0 ? ij >= i__2 : ij <=
+ i__2; ij += i__3) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ }
+ js = 1;
+ i__1 = n2 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + n2 - j - 1;
+ for (ij = js; ij <= i__3; ++ij) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ js = js + lda + 1;
+ }
+
+ } else {
+
+/* N is odd, TRANSR = 'T', and UPLO = 'U' */
+
+ ijp = 0;
+ js = n2 * lda;
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + j;
+ for (ij = js; ij <= i__3; ++ij) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ js += lda;
+ }
+ i__1 = n1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__3 = i__ + (n1 + i__) * lda;
+ i__2 = lda;
+ for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij +=
+ i__2) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* N is even, TRANSR = 'N', and UPLO = 'L' */
+
+ ijp = 0;
+ jp = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ij = i__ + 1 + jp;
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ jp += lda;
+ }
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = k - 1;
+ for (j = i__; j <= i__2; ++j) {
+ ij = i__ + j * lda;
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ }
+
+ } else {
+
+/* N is even, TRANSR = 'N', and UPLO = 'U' */
+
+ ijp = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ ij = k + 1 + j;
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ ij += lda;
+ }
+ }
+ js = 0;
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+ ij = js;
+ i__2 = js + j;
+ for (ij = js; ij <= i__2; ++ij) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ js += lda;
+ }
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'T' */
+
+ if (lower) {
+
+/* N is even, TRANSR = 'T', and UPLO = 'L' */
+
+ ijp = 0;
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = (*n + 1) * lda - 1;
+ i__3 = lda;
+ for (ij = i__ + (i__ + 1) * lda; i__3 < 0 ? ij >= i__2 :
+ ij <= i__2; ij += i__3) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ }
+ js = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + k - j - 1;
+ for (ij = js; ij <= i__3; ++ij) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ js = js + lda + 1;
+ }
+
+ } else {
+
+/* N is even, TRANSR = 'T', and UPLO = 'U' */
+
+ ijp = 0;
+ js = (k + 1) * lda;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + j;
+ for (ij = js; ij <= i__3; ++ij) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ js += lda;
+ }
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__3 = i__ + (k + i__) * lda;
+ i__2 = lda;
+ for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij +=
+ i__2) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of DTPTTF */
+
+} /* dtpttf_ */
diff --git a/SRC/dtpttr.c b/SRC/dtpttr.c
new file mode 100644
index 0000000..d08841b
--- /dev/null
+++ b/SRC/dtpttr.c
@@ -0,0 +1,144 @@
+/* dtpttr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtpttr_(char *uplo, integer *n, doublereal *ap,
+ doublereal *a, integer *lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTPTTR copies a triangular matrix A from standard packed format (TP) */
+/* to standard full format (TR). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular. */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */
+/* On entry, the upper or lower triangular matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* A (output) DOUBLE PRECISION array, dimension ( LDA, N ) */
+/* On exit, the triangular matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ lower = lsame_(uplo, "L");
+ if (! lower && ! lsame_(uplo, "U")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTPTTR", &i__1);
+ return 0;
+ }
+
+ if (lower) {
+ k = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ++k;
+ a[i__ + j * a_dim1] = ap[k];
+ }
+ }
+ } else {
+ k = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ++k;
+ a[i__ + j * a_dim1] = ap[k];
+ }
+ }
+ }
+
+
+ return 0;
+
+/* End of DTPTTR */
+
+} /* dtpttr_ */
diff --git a/SRC/dtrcon.c b/SRC/dtrcon.c
new file mode 100644
index 0000000..aa424e9
--- /dev/null
+++ b/SRC/dtrcon.c
@@ -0,0 +1,241 @@
+/* dtrcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dtrcon_(char *norm, char *uplo, char *diag, integer *n,
+ doublereal *a, integer *lda, doublereal *rcond, doublereal *work,
+ integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ doublereal d__1;
+
+ /* Local variables */
+ integer ix, kase, kase1;
+ doublereal scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int drscl_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal anorm;
+ logical upper;
+ doublereal xnorm;
+ extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal dlantr_(char *, char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int dlatrs_(char *, char *, char *, char *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *);
+ logical onenrm;
+ char normin[1];
+ doublereal smlnum;
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTRCON estimates the reciprocal of the condition number of a */
+/* triangular matrix A, in either the 1-norm or the infinity-norm. */
+
+/* The norm of A is computed and an estimate is obtained for */
+/* norm(inv(A)), then the reciprocal of the condition number is */
+/* computed as */
+/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ nounit = lsame_(diag, "N");
+
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTRCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ }
+
+ *rcond = 0.;
+ smlnum = dlamch_("Safe minimum") * (doublereal) max(1,*n);
+
+/* Compute the norm of the triangular matrix A. */
+
+ anorm = dlantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &work[1]);
+
+/* Continue only if ANORM > 0. */
+
+ if (anorm > 0.) {
+
+/* Estimate the norm of the inverse of A. */
+
+ ainvnm = 0.;
+ *(unsigned char *)normin = 'N';
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kase = 0;
+L10:
+ dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(A). */
+
+ dlatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset],
+ lda, &work[1], &scale, &work[(*n << 1) + 1], info);
+ } else {
+
+/* Multiply by inv(A'). */
+
+ dlatrs_(uplo, "Transpose", diag, normin, n, &a[a_offset], lda,
+ &work[1], &scale, &work[(*n << 1) + 1], info);
+ }
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ if (scale != 1.) {
+ ix = idamax_(n, &work[1], &c__1);
+ xnorm = (d__1 = work[ix], abs(d__1));
+ if (scale < xnorm * smlnum || scale == 0.) {
+ goto L20;
+ }
+ drscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / anorm / ainvnm;
+ }
+ }
+
+L20:
+ return 0;
+
+/* End of DTRCON */
+
+} /* dtrcon_ */
diff --git a/SRC/dtrevc.c b/SRC/dtrevc.c
new file mode 100644
index 0000000..84dc510
--- /dev/null
+++ b/SRC/dtrevc.c
@@ -0,0 +1,1228 @@
+/* dtrevc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static logical c_false = FALSE_;
+static integer c__1 = 1;
+static doublereal c_b22 = 1.;
+static doublereal c_b25 = 0.;
+static integer c__2 = 2;
+static logical c_true = TRUE_;
+
+/* Subroutine */ int dtrevc_(char *side, char *howmny, logical *select,
+ integer *n, doublereal *t, integer *ldt, doublereal *vl, integer *
+ ldvl, doublereal *vr, integer *ldvr, integer *mm, integer *m,
+ doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
+ i__2, i__3;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal x[4] /* was [2][2] */;
+ integer j1, j2, n2, ii, ki, ip, is;
+ doublereal wi, wr, rec, ulp, beta, emax;
+ logical pair;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ logical allv;
+ integer ierr;
+ doublereal unfl, ovfl, smin;
+ logical over;
+ doublereal vmax;
+ integer jnxt;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal scale;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ doublereal remax;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical leftv, bothv;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *);
+ doublereal vcrit;
+ logical somev;
+ doublereal xnorm;
+ extern /* Subroutine */ int dlaln2_(logical *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *
+, doublereal *, integer *, doublereal *, doublereal *, integer *),
+ dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ logical rightv;
+ doublereal smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTREVC computes some or all of the right and/or left eigenvectors of */
+/* a real upper quasi-triangular matrix T. */
+/* Matrices of this type are produced by the Schur factorization of */
+/* a real general matrix: A = Q*T*Q**T, as computed by DHSEQR. */
+
+/* The right eigenvector x and the left eigenvector y of T corresponding */
+/* to an eigenvalue w are defined by: */
+
+/* T*x = w*x, (y**H)*T = w*(y**H) */
+
+/* where y**H denotes the conjugate transpose of y. */
+/* The eigenvalues are not input to this routine, but are read directly */
+/* from the diagonal blocks of T. */
+
+/* This routine returns the matrices X and/or Y of right and left */
+/* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an */
+/* input matrix. If Q is the orthogonal factor that reduces a matrix */
+/* A to Schur form T, then Q*X and Q*Y are the matrices of right and */
+/* left eigenvectors of A. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'R': compute right eigenvectors only; */
+/* = 'L': compute left eigenvectors only; */
+/* = 'B': compute both right and left eigenvectors. */
+
+/* HOWMNY (input) CHARACTER*1 */
+/* = 'A': compute all right and/or left eigenvectors; */
+/* = 'B': compute all right and/or left eigenvectors, */
+/* backtransformed by the matrices in VR and/or VL; */
+/* = 'S': compute selected right and/or left eigenvectors, */
+/* as indicated by the logical array SELECT. */
+
+/* SELECT (input/output) LOGICAL array, dimension (N) */
+/* If HOWMNY = 'S', SELECT specifies the eigenvectors to be */
+/* computed. */
+/* If w(j) is a real eigenvalue, the corresponding real */
+/* eigenvector is computed if SELECT(j) is .TRUE.. */
+/* If w(j) and w(j+1) are the real and imaginary parts of a */
+/* complex eigenvalue, the corresponding complex eigenvector is */
+/* computed if either SELECT(j) or SELECT(j+1) is .TRUE., and */
+/* on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to */
+/* .FALSE.. */
+/* Not referenced if HOWMNY = 'A' or 'B'. */
+
+/* N (input) INTEGER */
+/* The order of the matrix T. N >= 0. */
+
+/* T (input) DOUBLE PRECISION array, dimension (LDT,N) */
+/* The upper quasi-triangular matrix T in Schur canonical form. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= max(1,N). */
+
+/* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM) */
+/* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */
+/* contain an N-by-N matrix Q (usually the orthogonal matrix Q */
+/* of Schur vectors returned by DHSEQR). */
+/* On exit, if SIDE = 'L' or 'B', VL contains: */
+/* if HOWMNY = 'A', the matrix Y of left eigenvectors of T; */
+/* if HOWMNY = 'B', the matrix Q*Y; */
+/* if HOWMNY = 'S', the left eigenvectors of T specified by */
+/* SELECT, stored consecutively in the columns */
+/* of VL, in the same order as their */
+/* eigenvalues. */
+/* A complex eigenvector corresponding to a complex eigenvalue */
+/* is stored in two consecutive columns, the first holding the */
+/* real part, and the second the imaginary part. */
+/* Not referenced if SIDE = 'R'. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. LDVL >= 1, and if */
+/* SIDE = 'L' or 'B', LDVL >= N. */
+
+/* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) */
+/* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */
+/* contain an N-by-N matrix Q (usually the orthogonal matrix Q */
+/* of Schur vectors returned by DHSEQR). */
+/* On exit, if SIDE = 'R' or 'B', VR contains: */
+/* if HOWMNY = 'A', the matrix X of right eigenvectors of T; */
+/* if HOWMNY = 'B', the matrix Q*X; */
+/* if HOWMNY = 'S', the right eigenvectors of T specified by */
+/* SELECT, stored consecutively in the columns */
+/* of VR, in the same order as their */
+/* eigenvalues. */
+/* A complex eigenvector corresponding to a complex eigenvalue */
+/* is stored in two consecutive columns, the first holding the */
+/* real part and the second the imaginary part. */
+/* Not referenced if SIDE = 'L'. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. LDVR >= 1, and if */
+/* SIDE = 'R' or 'B', LDVR >= N. */
+
+/* MM (input) INTEGER */
+/* The number of columns in the arrays VL and/or VR. MM >= M. */
+
+/* M (output) INTEGER */
+/* The number of columns in the arrays VL and/or VR actually */
+/* used to store the eigenvectors. */
+/* If HOWMNY = 'A' or 'B', M is set to N. */
+/* Each selected real eigenvector occupies one column and each */
+/* selected complex eigenvector occupies two columns. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The algorithm used in this program is basically backward (forward) */
+/* substitution, with scaling to make the the code robust against */
+/* possible overflow. */
+
+/* Each eigenvector is normalized so that the element of largest */
+/* magnitude has magnitude 1; here the magnitude of a complex number */
+/* (x,y) is taken to be |x| + |y|. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ --select;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+
+ /* Function Body */
+ bothv = lsame_(side, "B");
+ rightv = lsame_(side, "R") || bothv;
+ leftv = lsame_(side, "L") || bothv;
+
+ allv = lsame_(howmny, "A");
+ over = lsame_(howmny, "B");
+ somev = lsame_(howmny, "S");
+
+ *info = 0;
+ if (! rightv && ! leftv) {
+ *info = -1;
+ } else if (! allv && ! over && ! somev) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldt < max(1,*n)) {
+ *info = -6;
+ } else if (*ldvl < 1 || leftv && *ldvl < *n) {
+ *info = -8;
+ } else if (*ldvr < 1 || rightv && *ldvr < *n) {
+ *info = -10;
+ } else {
+
+/* Set M to the number of columns required to store the selected */
+/* eigenvectors, standardize the array SELECT if necessary, and */
+/* test MM. */
+
+ if (somev) {
+ *m = 0;
+ pair = FALSE_;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (pair) {
+ pair = FALSE_;
+ select[j] = FALSE_;
+ } else {
+ if (j < *n) {
+ if (t[j + 1 + j * t_dim1] == 0.) {
+ if (select[j]) {
+ ++(*m);
+ }
+ } else {
+ pair = TRUE_;
+ if (select[j] || select[j + 1]) {
+ select[j] = TRUE_;
+ *m += 2;
+ }
+ }
+ } else {
+ if (select[*n]) {
+ ++(*m);
+ }
+ }
+ }
+/* L10: */
+ }
+ } else {
+ *m = *n;
+ }
+
+ if (*mm < *m) {
+ *info = -11;
+ }
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTREVC", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Set the constants to control overflow. */
+
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ dlabad_(&unfl, &ovfl);
+ ulp = dlamch_("Precision");
+ smlnum = unfl * (*n / ulp);
+ bignum = (1. - ulp) / smlnum;
+
+/* Compute 1-norm of each column of strictly upper triangular */
+/* part of T to control overflow in triangular solver. */
+
+ work[1] = 0.;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ work[j] = 0.;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[j] += (d__1 = t[i__ + j * t_dim1], abs(d__1));
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* Index IP is used to specify the real or complex eigenvalue: */
+/* IP = 0, real eigenvalue, */
+/* 1, first of conjugate complex pair: (wr,wi) */
+/* -1, second of conjugate complex pair: (wr,wi) */
+
+ n2 = *n << 1;
+
+ if (rightv) {
+
+/* Compute right eigenvectors. */
+
+ ip = 0;
+ is = *m;
+ for (ki = *n; ki >= 1; --ki) {
+
+ if (ip == 1) {
+ goto L130;
+ }
+ if (ki == 1) {
+ goto L40;
+ }
+ if (t[ki + (ki - 1) * t_dim1] == 0.) {
+ goto L40;
+ }
+ ip = -1;
+
+L40:
+ if (somev) {
+ if (ip == 0) {
+ if (! select[ki]) {
+ goto L130;
+ }
+ } else {
+ if (! select[ki - 1]) {
+ goto L130;
+ }
+ }
+ }
+
+/* Compute the KI-th eigenvalue (WR,WI). */
+
+ wr = t[ki + ki * t_dim1];
+ wi = 0.;
+ if (ip != 0) {
+ wi = sqrt((d__1 = t[ki + (ki - 1) * t_dim1], abs(d__1))) *
+ sqrt((d__2 = t[ki - 1 + ki * t_dim1], abs(d__2)));
+ }
+/* Computing MAX */
+ d__1 = ulp * (abs(wr) + abs(wi));
+ smin = max(d__1,smlnum);
+
+ if (ip == 0) {
+
+/* Real right eigenvector */
+
+ work[ki + *n] = 1.;
+
+/* Form right-hand side */
+
+ i__1 = ki - 1;
+ for (k = 1; k <= i__1; ++k) {
+ work[k + *n] = -t[k + ki * t_dim1];
+/* L50: */
+ }
+
+/* Solve the upper quasi-triangular system: */
+/* (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK. */
+
+ jnxt = ki - 1;
+ for (j = ki - 1; j >= 1; --j) {
+ if (j > jnxt) {
+ goto L60;
+ }
+ j1 = j;
+ j2 = j;
+ jnxt = j - 1;
+ if (j > 1) {
+ if (t[j + (j - 1) * t_dim1] != 0.) {
+ j1 = j - 1;
+ jnxt = j - 2;
+ }
+ }
+
+ if (j1 == j2) {
+
+/* 1-by-1 diagonal block */
+
+ dlaln2_(&c_false, &c__1, &c__1, &smin, &c_b22, &t[j +
+ j * t_dim1], ldt, &c_b22, &c_b22, &work[j + *
+ n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm,
+ &ierr);
+
+/* Scale X(1,1) to avoid overflow when updating */
+/* the right-hand side. */
+
+ if (xnorm > 1.) {
+ if (work[j] > bignum / xnorm) {
+ x[0] /= xnorm;
+ scale /= xnorm;
+ }
+ }
+
+/* Scale if necessary */
+
+ if (scale != 1.) {
+ dscal_(&ki, &scale, &work[*n + 1], &c__1);
+ }
+ work[j + *n] = x[0];
+
+/* Update right-hand side */
+
+ i__1 = j - 1;
+ d__1 = -x[0];
+ daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[
+ *n + 1], &c__1);
+
+ } else {
+
+/* 2-by-2 diagonal block */
+
+ dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b22, &t[j -
+ 1 + (j - 1) * t_dim1], ldt, &c_b22, &c_b22, &
+ work[j - 1 + *n], n, &wr, &c_b25, x, &c__2, &
+ scale, &xnorm, &ierr);
+
+/* Scale X(1,1) and X(2,1) to avoid overflow when */
+/* updating the right-hand side. */
+
+ if (xnorm > 1.) {
+/* Computing MAX */
+ d__1 = work[j - 1], d__2 = work[j];
+ beta = max(d__1,d__2);
+ if (beta > bignum / xnorm) {
+ x[0] /= xnorm;
+ x[1] /= xnorm;
+ scale /= xnorm;
+ }
+ }
+
+/* Scale if necessary */
+
+ if (scale != 1.) {
+ dscal_(&ki, &scale, &work[*n + 1], &c__1);
+ }
+ work[j - 1 + *n] = x[0];
+ work[j + *n] = x[1];
+
+/* Update right-hand side */
+
+ i__1 = j - 2;
+ d__1 = -x[0];
+ daxpy_(&i__1, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1,
+ &work[*n + 1], &c__1);
+ i__1 = j - 2;
+ d__1 = -x[1];
+ daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[
+ *n + 1], &c__1);
+ }
+L60:
+ ;
+ }
+
+/* Copy the vector x or Q*x to VR and normalize. */
+
+ if (! over) {
+ dcopy_(&ki, &work[*n + 1], &c__1, &vr[is * vr_dim1 + 1], &
+ c__1);
+
+ ii = idamax_(&ki, &vr[is * vr_dim1 + 1], &c__1);
+ remax = 1. / (d__1 = vr[ii + is * vr_dim1], abs(d__1));
+ dscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1);
+
+ i__1 = *n;
+ for (k = ki + 1; k <= i__1; ++k) {
+ vr[k + is * vr_dim1] = 0.;
+/* L70: */
+ }
+ } else {
+ if (ki > 1) {
+ i__1 = ki - 1;
+ dgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, &
+ work[*n + 1], &c__1, &work[ki + *n], &vr[ki *
+ vr_dim1 + 1], &c__1);
+ }
+
+ ii = idamax_(n, &vr[ki * vr_dim1 + 1], &c__1);
+ remax = 1. / (d__1 = vr[ii + ki * vr_dim1], abs(d__1));
+ dscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1);
+ }
+
+ } else {
+
+/* Complex right eigenvector. */
+
+/* Initial solve */
+/* [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0. */
+/* [ (T(KI,KI-1) T(KI,KI) ) ] */
+
+ if ((d__1 = t[ki - 1 + ki * t_dim1], abs(d__1)) >= (d__2 = t[
+ ki + (ki - 1) * t_dim1], abs(d__2))) {
+ work[ki - 1 + *n] = 1.;
+ work[ki + n2] = wi / t[ki - 1 + ki * t_dim1];
+ } else {
+ work[ki - 1 + *n] = -wi / t[ki + (ki - 1) * t_dim1];
+ work[ki + n2] = 1.;
+ }
+ work[ki + *n] = 0.;
+ work[ki - 1 + n2] = 0.;
+
+/* Form right-hand side */
+
+ i__1 = ki - 2;
+ for (k = 1; k <= i__1; ++k) {
+ work[k + *n] = -work[ki - 1 + *n] * t[k + (ki - 1) *
+ t_dim1];
+ work[k + n2] = -work[ki + n2] * t[k + ki * t_dim1];
+/* L80: */
+ }
+
+/* Solve upper quasi-triangular system: */
+/* (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2) */
+
+ jnxt = ki - 2;
+ for (j = ki - 2; j >= 1; --j) {
+ if (j > jnxt) {
+ goto L90;
+ }
+ j1 = j;
+ j2 = j;
+ jnxt = j - 1;
+ if (j > 1) {
+ if (t[j + (j - 1) * t_dim1] != 0.) {
+ j1 = j - 1;
+ jnxt = j - 2;
+ }
+ }
+
+ if (j1 == j2) {
+
+/* 1-by-1 diagonal block */
+
+ dlaln2_(&c_false, &c__1, &c__2, &smin, &c_b22, &t[j +
+ j * t_dim1], ldt, &c_b22, &c_b22, &work[j + *
+ n], n, &wr, &wi, x, &c__2, &scale, &xnorm, &
+ ierr);
+
+/* Scale X(1,1) and X(1,2) to avoid overflow when */
+/* updating the right-hand side. */
+
+ if (xnorm > 1.) {
+ if (work[j] > bignum / xnorm) {
+ x[0] /= xnorm;
+ x[2] /= xnorm;
+ scale /= xnorm;
+ }
+ }
+
+/* Scale if necessary */
+
+ if (scale != 1.) {
+ dscal_(&ki, &scale, &work[*n + 1], &c__1);
+ dscal_(&ki, &scale, &work[n2 + 1], &c__1);
+ }
+ work[j + *n] = x[0];
+ work[j + n2] = x[2];
+
+/* Update the right-hand side */
+
+ i__1 = j - 1;
+ d__1 = -x[0];
+ daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[
+ *n + 1], &c__1);
+ i__1 = j - 1;
+ d__1 = -x[2];
+ daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[
+ n2 + 1], &c__1);
+
+ } else {
+
+/* 2-by-2 diagonal block */
+
+ dlaln2_(&c_false, &c__2, &c__2, &smin, &c_b22, &t[j -
+ 1 + (j - 1) * t_dim1], ldt, &c_b22, &c_b22, &
+ work[j - 1 + *n], n, &wr, &wi, x, &c__2, &
+ scale, &xnorm, &ierr);
+
+/* Scale X to avoid overflow when updating */
+/* the right-hand side. */
+
+ if (xnorm > 1.) {
+/* Computing MAX */
+ d__1 = work[j - 1], d__2 = work[j];
+ beta = max(d__1,d__2);
+ if (beta > bignum / xnorm) {
+ rec = 1. / xnorm;
+ x[0] *= rec;
+ x[2] *= rec;
+ x[1] *= rec;
+ x[3] *= rec;
+ scale *= rec;
+ }
+ }
+
+/* Scale if necessary */
+
+ if (scale != 1.) {
+ dscal_(&ki, &scale, &work[*n + 1], &c__1);
+ dscal_(&ki, &scale, &work[n2 + 1], &c__1);
+ }
+ work[j - 1 + *n] = x[0];
+ work[j + *n] = x[1];
+ work[j - 1 + n2] = x[2];
+ work[j + n2] = x[3];
+
+/* Update the right-hand side */
+
+ i__1 = j - 2;
+ d__1 = -x[0];
+ daxpy_(&i__1, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1,
+ &work[*n + 1], &c__1);
+ i__1 = j - 2;
+ d__1 = -x[1];
+ daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[
+ *n + 1], &c__1);
+ i__1 = j - 2;
+ d__1 = -x[2];
+ daxpy_(&i__1, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1,
+ &work[n2 + 1], &c__1);
+ i__1 = j - 2;
+ d__1 = -x[3];
+ daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[
+ n2 + 1], &c__1);
+ }
+L90:
+ ;
+ }
+
+/* Copy the vector x or Q*x to VR and normalize. */
+
+ if (! over) {
+ dcopy_(&ki, &work[*n + 1], &c__1, &vr[(is - 1) * vr_dim1
+ + 1], &c__1);
+ dcopy_(&ki, &work[n2 + 1], &c__1, &vr[is * vr_dim1 + 1], &
+ c__1);
+
+ emax = 0.;
+ i__1 = ki;
+ for (k = 1; k <= i__1; ++k) {
+/* Computing MAX */
+ d__3 = emax, d__4 = (d__1 = vr[k + (is - 1) * vr_dim1]
+ , abs(d__1)) + (d__2 = vr[k + is * vr_dim1],
+ abs(d__2));
+ emax = max(d__3,d__4);
+/* L100: */
+ }
+
+ remax = 1. / emax;
+ dscal_(&ki, &remax, &vr[(is - 1) * vr_dim1 + 1], &c__1);
+ dscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1);
+
+ i__1 = *n;
+ for (k = ki + 1; k <= i__1; ++k) {
+ vr[k + (is - 1) * vr_dim1] = 0.;
+ vr[k + is * vr_dim1] = 0.;
+/* L110: */
+ }
+
+ } else {
+
+ if (ki > 2) {
+ i__1 = ki - 2;
+ dgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, &
+ work[*n + 1], &c__1, &work[ki - 1 + *n], &vr[(
+ ki - 1) * vr_dim1 + 1], &c__1);
+ i__1 = ki - 2;
+ dgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, &
+ work[n2 + 1], &c__1, &work[ki + n2], &vr[ki *
+ vr_dim1 + 1], &c__1);
+ } else {
+ dscal_(n, &work[ki - 1 + *n], &vr[(ki - 1) * vr_dim1
+ + 1], &c__1);
+ dscal_(n, &work[ki + n2], &vr[ki * vr_dim1 + 1], &
+ c__1);
+ }
+
+ emax = 0.;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+/* Computing MAX */
+ d__3 = emax, d__4 = (d__1 = vr[k + (ki - 1) * vr_dim1]
+ , abs(d__1)) + (d__2 = vr[k + ki * vr_dim1],
+ abs(d__2));
+ emax = max(d__3,d__4);
+/* L120: */
+ }
+ remax = 1. / emax;
+ dscal_(n, &remax, &vr[(ki - 1) * vr_dim1 + 1], &c__1);
+ dscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1);
+ }
+ }
+
+ --is;
+ if (ip != 0) {
+ --is;
+ }
+L130:
+ if (ip == 1) {
+ ip = 0;
+ }
+ if (ip == -1) {
+ ip = 1;
+ }
+/* L140: */
+ }
+ }
+
+ if (leftv) {
+
+/* Compute left eigenvectors. */
+
+ ip = 0;
+ is = 1;
+ i__1 = *n;
+ for (ki = 1; ki <= i__1; ++ki) {
+
+ if (ip == -1) {
+ goto L250;
+ }
+ if (ki == *n) {
+ goto L150;
+ }
+ if (t[ki + 1 + ki * t_dim1] == 0.) {
+ goto L150;
+ }
+ ip = 1;
+
+L150:
+ if (somev) {
+ if (! select[ki]) {
+ goto L250;
+ }
+ }
+
+/* Compute the KI-th eigenvalue (WR,WI). */
+
+ wr = t[ki + ki * t_dim1];
+ wi = 0.;
+ if (ip != 0) {
+ wi = sqrt((d__1 = t[ki + (ki + 1) * t_dim1], abs(d__1))) *
+ sqrt((d__2 = t[ki + 1 + ki * t_dim1], abs(d__2)));
+ }
+/* Computing MAX */
+ d__1 = ulp * (abs(wr) + abs(wi));
+ smin = max(d__1,smlnum);
+
+ if (ip == 0) {
+
+/* Real left eigenvector. */
+
+ work[ki + *n] = 1.;
+
+/* Form right-hand side */
+
+ i__2 = *n;
+ for (k = ki + 1; k <= i__2; ++k) {
+ work[k + *n] = -t[ki + k * t_dim1];
+/* L160: */
+ }
+
+/* Solve the quasi-triangular system: */
+/* (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK */
+
+ vmax = 1.;
+ vcrit = bignum;
+
+ jnxt = ki + 1;
+ i__2 = *n;
+ for (j = ki + 1; j <= i__2; ++j) {
+ if (j < jnxt) {
+ goto L170;
+ }
+ j1 = j;
+ j2 = j;
+ jnxt = j + 1;
+ if (j < *n) {
+ if (t[j + 1 + j * t_dim1] != 0.) {
+ j2 = j + 1;
+ jnxt = j + 2;
+ }
+ }
+
+ if (j1 == j2) {
+
+/* 1-by-1 diagonal block */
+
+/* Scale if necessary to avoid overflow when forming */
+/* the right-hand side. */
+
+ if (work[j] > vcrit) {
+ rec = 1. / vmax;
+ i__3 = *n - ki + 1;
+ dscal_(&i__3, &rec, &work[ki + *n], &c__1);
+ vmax = 1.;
+ vcrit = bignum;
+ }
+
+ i__3 = j - ki - 1;
+ work[j + *n] -= ddot_(&i__3, &t[ki + 1 + j * t_dim1],
+ &c__1, &work[ki + 1 + *n], &c__1);
+
+/* Solve (T(J,J)-WR)'*X = WORK */
+
+ dlaln2_(&c_false, &c__1, &c__1, &smin, &c_b22, &t[j +
+ j * t_dim1], ldt, &c_b22, &c_b22, &work[j + *
+ n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm,
+ &ierr);
+
+/* Scale if necessary */
+
+ if (scale != 1.) {
+ i__3 = *n - ki + 1;
+ dscal_(&i__3, &scale, &work[ki + *n], &c__1);
+ }
+ work[j + *n] = x[0];
+/* Computing MAX */
+ d__2 = (d__1 = work[j + *n], abs(d__1));
+ vmax = max(d__2,vmax);
+ vcrit = bignum / vmax;
+
+ } else {
+
+/* 2-by-2 diagonal block */
+
+/* Scale if necessary to avoid overflow when forming */
+/* the right-hand side. */
+
+/* Computing MAX */
+ d__1 = work[j], d__2 = work[j + 1];
+ beta = max(d__1,d__2);
+ if (beta > vcrit) {
+ rec = 1. / vmax;
+ i__3 = *n - ki + 1;
+ dscal_(&i__3, &rec, &work[ki + *n], &c__1);
+ vmax = 1.;
+ vcrit = bignum;
+ }
+
+ i__3 = j - ki - 1;
+ work[j + *n] -= ddot_(&i__3, &t[ki + 1 + j * t_dim1],
+ &c__1, &work[ki + 1 + *n], &c__1);
+
+ i__3 = j - ki - 1;
+ work[j + 1 + *n] -= ddot_(&i__3, &t[ki + 1 + (j + 1) *
+ t_dim1], &c__1, &work[ki + 1 + *n], &c__1);
+
+/* Solve */
+/* [T(J,J)-WR T(J,J+1) ]'* X = SCALE*( WORK1 ) */
+/* [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 ) */
+
+ dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b22, &t[j +
+ j * t_dim1], ldt, &c_b22, &c_b22, &work[j + *
+ n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm,
+ &ierr);
+
+/* Scale if necessary */
+
+ if (scale != 1.) {
+ i__3 = *n - ki + 1;
+ dscal_(&i__3, &scale, &work[ki + *n], &c__1);
+ }
+ work[j + *n] = x[0];
+ work[j + 1 + *n] = x[1];
+
+/* Computing MAX */
+ d__3 = (d__1 = work[j + *n], abs(d__1)), d__4 = (d__2
+ = work[j + 1 + *n], abs(d__2)), d__3 = max(
+ d__3,d__4);
+ vmax = max(d__3,vmax);
+ vcrit = bignum / vmax;
+
+ }
+L170:
+ ;
+ }
+
+/* Copy the vector x or Q*x to VL and normalize. */
+
+ if (! over) {
+ i__2 = *n - ki + 1;
+ dcopy_(&i__2, &work[ki + *n], &c__1, &vl[ki + is *
+ vl_dim1], &c__1);
+
+ i__2 = *n - ki + 1;
+ ii = idamax_(&i__2, &vl[ki + is * vl_dim1], &c__1) + ki -
+ 1;
+ remax = 1. / (d__1 = vl[ii + is * vl_dim1], abs(d__1));
+ i__2 = *n - ki + 1;
+ dscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1);
+
+ i__2 = ki - 1;
+ for (k = 1; k <= i__2; ++k) {
+ vl[k + is * vl_dim1] = 0.;
+/* L180: */
+ }
+
+ } else {
+
+ if (ki < *n) {
+ i__2 = *n - ki;
+ dgemv_("N", n, &i__2, &c_b22, &vl[(ki + 1) * vl_dim1
+ + 1], ldvl, &work[ki + 1 + *n], &c__1, &work[
+ ki + *n], &vl[ki * vl_dim1 + 1], &c__1);
+ }
+
+ ii = idamax_(n, &vl[ki * vl_dim1 + 1], &c__1);
+ remax = 1. / (d__1 = vl[ii + ki * vl_dim1], abs(d__1));
+ dscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1);
+
+ }
+
+ } else {
+
+/* Complex left eigenvector. */
+
+/* Initial solve: */
+/* ((T(KI,KI) T(KI,KI+1) )' - (WR - I* WI))*X = 0. */
+/* ((T(KI+1,KI) T(KI+1,KI+1)) ) */
+
+ if ((d__1 = t[ki + (ki + 1) * t_dim1], abs(d__1)) >= (d__2 =
+ t[ki + 1 + ki * t_dim1], abs(d__2))) {
+ work[ki + *n] = wi / t[ki + (ki + 1) * t_dim1];
+ work[ki + 1 + n2] = 1.;
+ } else {
+ work[ki + *n] = 1.;
+ work[ki + 1 + n2] = -wi / t[ki + 1 + ki * t_dim1];
+ }
+ work[ki + 1 + *n] = 0.;
+ work[ki + n2] = 0.;
+
+/* Form right-hand side */
+
+ i__2 = *n;
+ for (k = ki + 2; k <= i__2; ++k) {
+ work[k + *n] = -work[ki + *n] * t[ki + k * t_dim1];
+ work[k + n2] = -work[ki + 1 + n2] * t[ki + 1 + k * t_dim1]
+ ;
+/* L190: */
+ }
+
+/* Solve complex quasi-triangular system: */
+/* ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2 */
+
+ vmax = 1.;
+ vcrit = bignum;
+
+ jnxt = ki + 2;
+ i__2 = *n;
+ for (j = ki + 2; j <= i__2; ++j) {
+ if (j < jnxt) {
+ goto L200;
+ }
+ j1 = j;
+ j2 = j;
+ jnxt = j + 1;
+ if (j < *n) {
+ if (t[j + 1 + j * t_dim1] != 0.) {
+ j2 = j + 1;
+ jnxt = j + 2;
+ }
+ }
+
+ if (j1 == j2) {
+
+/* 1-by-1 diagonal block */
+
+/* Scale if necessary to avoid overflow when */
+/* forming the right-hand side elements. */
+
+ if (work[j] > vcrit) {
+ rec = 1. / vmax;
+ i__3 = *n - ki + 1;
+ dscal_(&i__3, &rec, &work[ki + *n], &c__1);
+ i__3 = *n - ki + 1;
+ dscal_(&i__3, &rec, &work[ki + n2], &c__1);
+ vmax = 1.;
+ vcrit = bignum;
+ }
+
+ i__3 = j - ki - 2;
+ work[j + *n] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1],
+ &c__1, &work[ki + 2 + *n], &c__1);
+ i__3 = j - ki - 2;
+ work[j + n2] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1],
+ &c__1, &work[ki + 2 + n2], &c__1);
+
+/* Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2 */
+
+ d__1 = -wi;
+ dlaln2_(&c_false, &c__1, &c__2, &smin, &c_b22, &t[j +
+ j * t_dim1], ldt, &c_b22, &c_b22, &work[j + *
+ n], n, &wr, &d__1, x, &c__2, &scale, &xnorm, &
+ ierr);
+
+/* Scale if necessary */
+
+ if (scale != 1.) {
+ i__3 = *n - ki + 1;
+ dscal_(&i__3, &scale, &work[ki + *n], &c__1);
+ i__3 = *n - ki + 1;
+ dscal_(&i__3, &scale, &work[ki + n2], &c__1);
+ }
+ work[j + *n] = x[0];
+ work[j + n2] = x[2];
+/* Computing MAX */
+ d__3 = (d__1 = work[j + *n], abs(d__1)), d__4 = (d__2
+ = work[j + n2], abs(d__2)), d__3 = max(d__3,
+ d__4);
+ vmax = max(d__3,vmax);
+ vcrit = bignum / vmax;
+
+ } else {
+
+/* 2-by-2 diagonal block */
+
+/* Scale if necessary to avoid overflow when forming */
+/* the right-hand side elements. */
+
+/* Computing MAX */
+ d__1 = work[j], d__2 = work[j + 1];
+ beta = max(d__1,d__2);
+ if (beta > vcrit) {
+ rec = 1. / vmax;
+ i__3 = *n - ki + 1;
+ dscal_(&i__3, &rec, &work[ki + *n], &c__1);
+ i__3 = *n - ki + 1;
+ dscal_(&i__3, &rec, &work[ki + n2], &c__1);
+ vmax = 1.;
+ vcrit = bignum;
+ }
+
+ i__3 = j - ki - 2;
+ work[j + *n] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1],
+ &c__1, &work[ki + 2 + *n], &c__1);
+
+ i__3 = j - ki - 2;
+ work[j + n2] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1],
+ &c__1, &work[ki + 2 + n2], &c__1);
+
+ i__3 = j - ki - 2;
+ work[j + 1 + *n] -= ddot_(&i__3, &t[ki + 2 + (j + 1) *
+ t_dim1], &c__1, &work[ki + 2 + *n], &c__1);
+
+ i__3 = j - ki - 2;
+ work[j + 1 + n2] -= ddot_(&i__3, &t[ki + 2 + (j + 1) *
+ t_dim1], &c__1, &work[ki + 2 + n2], &c__1);
+
+/* Solve 2-by-2 complex linear equation */
+/* ([T(j,j) T(j,j+1) ]'-(wr-i*wi)*I)*X = SCALE*B */
+/* ([T(j+1,j) T(j+1,j+1)] ) */
+
+ d__1 = -wi;
+ dlaln2_(&c_true, &c__2, &c__2, &smin, &c_b22, &t[j +
+ j * t_dim1], ldt, &c_b22, &c_b22, &work[j + *
+ n], n, &wr, &d__1, x, &c__2, &scale, &xnorm, &
+ ierr);
+
+/* Scale if necessary */
+
+ if (scale != 1.) {
+ i__3 = *n - ki + 1;
+ dscal_(&i__3, &scale, &work[ki + *n], &c__1);
+ i__3 = *n - ki + 1;
+ dscal_(&i__3, &scale, &work[ki + n2], &c__1);
+ }
+ work[j + *n] = x[0];
+ work[j + n2] = x[2];
+ work[j + 1 + *n] = x[1];
+ work[j + 1 + n2] = x[3];
+/* Computing MAX */
+ d__1 = abs(x[0]), d__2 = abs(x[2]), d__1 = max(d__1,
+ d__2), d__2 = abs(x[1]), d__1 = max(d__1,d__2)
+ , d__2 = abs(x[3]), d__1 = max(d__1,d__2);
+ vmax = max(d__1,vmax);
+ vcrit = bignum / vmax;
+
+ }
+L200:
+ ;
+ }
+
+/* Copy the vector x or Q*x to VL and normalize. */
+
+ if (! over) {
+ i__2 = *n - ki + 1;
+ dcopy_(&i__2, &work[ki + *n], &c__1, &vl[ki + is *
+ vl_dim1], &c__1);
+ i__2 = *n - ki + 1;
+ dcopy_(&i__2, &work[ki + n2], &c__1, &vl[ki + (is + 1) *
+ vl_dim1], &c__1);
+
+ emax = 0.;
+ i__2 = *n;
+ for (k = ki; k <= i__2; ++k) {
+/* Computing MAX */
+ d__3 = emax, d__4 = (d__1 = vl[k + is * vl_dim1], abs(
+ d__1)) + (d__2 = vl[k + (is + 1) * vl_dim1],
+ abs(d__2));
+ emax = max(d__3,d__4);
+/* L220: */
+ }
+ remax = 1. / emax;
+ i__2 = *n - ki + 1;
+ dscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1);
+ i__2 = *n - ki + 1;
+ dscal_(&i__2, &remax, &vl[ki + (is + 1) * vl_dim1], &c__1)
+ ;
+
+ i__2 = ki - 1;
+ for (k = 1; k <= i__2; ++k) {
+ vl[k + is * vl_dim1] = 0.;
+ vl[k + (is + 1) * vl_dim1] = 0.;
+/* L230: */
+ }
+ } else {
+ if (ki < *n - 1) {
+ i__2 = *n - ki - 1;
+ dgemv_("N", n, &i__2, &c_b22, &vl[(ki + 2) * vl_dim1
+ + 1], ldvl, &work[ki + 2 + *n], &c__1, &work[
+ ki + *n], &vl[ki * vl_dim1 + 1], &c__1);
+ i__2 = *n - ki - 1;
+ dgemv_("N", n, &i__2, &c_b22, &vl[(ki + 2) * vl_dim1
+ + 1], ldvl, &work[ki + 2 + n2], &c__1, &work[
+ ki + 1 + n2], &vl[(ki + 1) * vl_dim1 + 1], &
+ c__1);
+ } else {
+ dscal_(n, &work[ki + *n], &vl[ki * vl_dim1 + 1], &
+ c__1);
+ dscal_(n, &work[ki + 1 + n2], &vl[(ki + 1) * vl_dim1
+ + 1], &c__1);
+ }
+
+ emax = 0.;
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+/* Computing MAX */
+ d__3 = emax, d__4 = (d__1 = vl[k + ki * vl_dim1], abs(
+ d__1)) + (d__2 = vl[k + (ki + 1) * vl_dim1],
+ abs(d__2));
+ emax = max(d__3,d__4);
+/* L240: */
+ }
+ remax = 1. / emax;
+ dscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1);
+ dscal_(n, &remax, &vl[(ki + 1) * vl_dim1 + 1], &c__1);
+
+ }
+
+ }
+
+ ++is;
+ if (ip != 0) {
+ ++is;
+ }
+L250:
+ if (ip == -1) {
+ ip = 0;
+ }
+ if (ip == 1) {
+ ip = -1;
+ }
+
+/* L260: */
+ }
+
+ }
+
+ return 0;
+
+/* End of DTREVC */
+
+} /* dtrevc_ */
diff --git a/SRC/dtrexc.c b/SRC/dtrexc.c
new file mode 100644
index 0000000..9d77fbe
--- /dev/null
+++ b/SRC/dtrexc.c
@@ -0,0 +1,403 @@
+/* dtrexc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int dtrexc_(char *compq, integer *n, doublereal *t, integer *
+ ldt, doublereal *q, integer *ldq, integer *ifst, integer *ilst,
+ doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, t_dim1, t_offset, i__1;
+
+ /* Local variables */
+ integer nbf, nbl, here;
+ extern logical lsame_(char *, char *);
+ logical wantq;
+ extern /* Subroutine */ int dlaexc_(logical *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, integer *, integer
+ *, doublereal *, integer *), xerbla_(char *, integer *);
+ integer nbnext;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTREXC reorders the real Schur factorization of a real matrix */
+/* A = Q*T*Q**T, so that the diagonal block of T with row index IFST is */
+/* moved to row ILST. */
+
+/* The real Schur form T is reordered by an orthogonal similarity */
+/* transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors */
+/* is updated by postmultiplying it with Z. */
+
+/* T must be in Schur canonical form (as returned by DHSEQR), that is, */
+/* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */
+/* 2-by-2 diagonal block has its diagonal elements equal and its */
+/* off-diagonal elements of opposite sign. */
+
+/* Arguments */
+/* ========= */
+
+/* COMPQ (input) CHARACTER*1 */
+/* = 'V': update the matrix Q of Schur vectors; */
+/* = 'N': do not update Q. */
+
+/* N (input) INTEGER */
+/* The order of the matrix T. N >= 0. */
+
+/* T (input/output) DOUBLE PRECISION array, dimension (LDT,N) */
+/* On entry, the upper quasi-triangular matrix T, in Schur */
+/* Schur canonical form. */
+/* On exit, the reordered upper quasi-triangular matrix, again */
+/* in Schur canonical form. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= max(1,N). */
+
+/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */
+/* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */
+/* On exit, if COMPQ = 'V', Q has been postmultiplied by the */
+/* orthogonal transformation matrix Z which reorders T. */
+/* If COMPQ = 'N', Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* IFST (input/output) INTEGER */
+/* ILST (input/output) INTEGER */
+/* Specify the reordering of the diagonal blocks of T. */
+/* The block with row index IFST is moved to row ILST, by a */
+/* sequence of transpositions between adjacent blocks. */
+/* On exit, if IFST pointed on entry to the second row of a */
+/* 2-by-2 block, it is changed to point to the first row; ILST */
+/* always points to the first row of the block in its final */
+/* position (which may differ from its input value by +1 or -1). */
+/* 1 <= IFST <= N; 1 <= ILST <= N. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* = 1: two adjacent blocks were too close to swap (the problem */
+/* is very ill-conditioned); T may have been partially */
+/* reordered, and ILST points to the first row of the */
+/* current position of the block being moved. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input arguments. */
+
+ /* Parameter adjustments */
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ wantq = lsame_(compq, "V");
+ if (! wantq && ! lsame_(compq, "N")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldt < max(1,*n)) {
+ *info = -4;
+ } else if (*ldq < 1 || wantq && *ldq < max(1,*n)) {
+ *info = -6;
+ } else if (*ifst < 1 || *ifst > *n) {
+ *info = -7;
+ } else if (*ilst < 1 || *ilst > *n) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTREXC", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 1) {
+ return 0;
+ }
+
+/* Determine the first row of specified block */
+/* and find out it is 1 by 1 or 2 by 2. */
+
+ if (*ifst > 1) {
+ if (t[*ifst + (*ifst - 1) * t_dim1] != 0.) {
+ --(*ifst);
+ }
+ }
+ nbf = 1;
+ if (*ifst < *n) {
+ if (t[*ifst + 1 + *ifst * t_dim1] != 0.) {
+ nbf = 2;
+ }
+ }
+
+/* Determine the first row of the final block */
+/* and find out it is 1 by 1 or 2 by 2. */
+
+ if (*ilst > 1) {
+ if (t[*ilst + (*ilst - 1) * t_dim1] != 0.) {
+ --(*ilst);
+ }
+ }
+ nbl = 1;
+ if (*ilst < *n) {
+ if (t[*ilst + 1 + *ilst * t_dim1] != 0.) {
+ nbl = 2;
+ }
+ }
+
+ if (*ifst == *ilst) {
+ return 0;
+ }
+
+ if (*ifst < *ilst) {
+
+/* Update ILST */
+
+ if (nbf == 2 && nbl == 1) {
+ --(*ilst);
+ }
+ if (nbf == 1 && nbl == 2) {
+ ++(*ilst);
+ }
+
+ here = *ifst;
+
+L10:
+
+/* Swap block with next one below */
+
+ if (nbf == 1 || nbf == 2) {
+
+/* Current block either 1 by 1 or 2 by 2 */
+
+ nbnext = 1;
+ if (here + nbf + 1 <= *n) {
+ if (t[here + nbf + 1 + (here + nbf) * t_dim1] != 0.) {
+ nbnext = 2;
+ }
+ }
+ dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &here, &
+ nbf, &nbnext, &work[1], info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ here += nbnext;
+
+/* Test if 2 by 2 block breaks into two 1 by 1 blocks */
+
+ if (nbf == 2) {
+ if (t[here + 1 + here * t_dim1] == 0.) {
+ nbf = 3;
+ }
+ }
+
+ } else {
+
+/* Current block consists of two 1 by 1 blocks each of which */
+/* must be swapped individually */
+
+ nbnext = 1;
+ if (here + 3 <= *n) {
+ if (t[here + 3 + (here + 2) * t_dim1] != 0.) {
+ nbnext = 2;
+ }
+ }
+ i__1 = here + 1;
+ dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, &
+ c__1, &nbnext, &work[1], info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ if (nbnext == 1) {
+
+/* Swap two 1 by 1 blocks, no problems possible */
+
+ dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
+ here, &c__1, &nbnext, &work[1], info);
+ ++here;
+ } else {
+
+/* Recompute NBNEXT in case 2 by 2 split */
+
+ if (t[here + 2 + (here + 1) * t_dim1] == 0.) {
+ nbnext = 1;
+ }
+ if (nbnext == 2) {
+
+/* 2 by 2 Block did not split */
+
+ dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
+ here, &c__1, &nbnext, &work[1], info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ here += 2;
+ } else {
+
+/* 2 by 2 Block did split */
+
+ dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
+ here, &c__1, &c__1, &work[1], info);
+ i__1 = here + 1;
+ dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
+ i__1, &c__1, &c__1, &work[1], info);
+ here += 2;
+ }
+ }
+ }
+ if (here < *ilst) {
+ goto L10;
+ }
+
+ } else {
+
+ here = *ifst;
+L20:
+
+/* Swap block with next one above */
+
+ if (nbf == 1 || nbf == 2) {
+
+/* Current block either 1 by 1 or 2 by 2 */
+
+ nbnext = 1;
+ if (here >= 3) {
+ if (t[here - 1 + (here - 2) * t_dim1] != 0.) {
+ nbnext = 2;
+ }
+ }
+ i__1 = here - nbnext;
+ dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, &
+ nbnext, &nbf, &work[1], info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ here -= nbnext;
+
+/* Test if 2 by 2 block breaks into two 1 by 1 blocks */
+
+ if (nbf == 2) {
+ if (t[here + 1 + here * t_dim1] == 0.) {
+ nbf = 3;
+ }
+ }
+
+ } else {
+
+/* Current block consists of two 1 by 1 blocks each of which */
+/* must be swapped individually */
+
+ nbnext = 1;
+ if (here >= 3) {
+ if (t[here - 1 + (here - 2) * t_dim1] != 0.) {
+ nbnext = 2;
+ }
+ }
+ i__1 = here - nbnext;
+ dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, &
+ nbnext, &c__1, &work[1], info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ if (nbnext == 1) {
+
+/* Swap two 1 by 1 blocks, no problems possible */
+
+ dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
+ here, &nbnext, &c__1, &work[1], info);
+ --here;
+ } else {
+
+/* Recompute NBNEXT in case 2 by 2 split */
+
+ if (t[here + (here - 1) * t_dim1] == 0.) {
+ nbnext = 1;
+ }
+ if (nbnext == 2) {
+
+/* 2 by 2 Block did not split */
+
+ i__1 = here - 1;
+ dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
+ i__1, &c__2, &c__1, &work[1], info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ here += -2;
+ } else {
+
+/* 2 by 2 Block did split */
+
+ dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
+ here, &c__1, &c__1, &work[1], info);
+ i__1 = here - 1;
+ dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
+ i__1, &c__1, &c__1, &work[1], info);
+ here += -2;
+ }
+ }
+ }
+ if (here > *ilst) {
+ goto L20;
+ }
+ }
+ *ilst = here;
+
+ return 0;
+
+/* End of DTREXC */
+
+} /* dtrexc_ */
diff --git a/SRC/dtrrfs.c b/SRC/dtrrfs.c
new file mode 100644
index 0000000..d07a7df
--- /dev/null
+++ b/SRC/dtrrfs.c
@@ -0,0 +1,493 @@
+/* dtrrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b19 = -1.;
+
+/* Subroutine */ int dtrrfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *
+ ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr,
+ doublereal *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2,
+ i__3;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal s, xk;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *,
+ doublereal *, integer *, doublereal *, integer *), dtrsv_(char *, char *, char *, integer *, doublereal *,
+ integer *, doublereal *, integer *),
+ dlacn2_(integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+ char transt[1];
+ logical nounit;
+ doublereal lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTRRFS provides error bounds and backward error estimates for the */
+/* solution to a system of linear equations with a triangular */
+/* coefficient matrix. */
+
+/* The solution matrix X must be computed by DTRTRS or some other */
+/* means before entering this routine. DTRRFS does not do iterative */
+/* refinement because doing so cannot improve the backward error. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTRRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A or A', depending on TRANS. */
+
+ dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+ dtrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1], &c__1);
+ daxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1));
+/* L20: */
+ }
+
+ if (notran) {
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+ i__3 = k;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ work[i__] += (d__1 = a[i__ + k * a_dim1], abs(
+ d__1)) * xk;
+/* L30: */
+ }
+/* L40: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ work[i__] += (d__1 = a[i__ + k * a_dim1], abs(
+ d__1)) * xk;
+/* L50: */
+ }
+ work[k] += xk;
+/* L60: */
+ }
+ }
+ } else {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ work[i__] += (d__1 = a[i__ + k * a_dim1], abs(
+ d__1)) * xk;
+/* L70: */
+ }
+/* L80: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (d__1 = x[k + j * x_dim1], abs(d__1));
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ work[i__] += (d__1 = a[i__ + k * a_dim1], abs(
+ d__1)) * xk;
+/* L90: */
+ }
+ work[k] += xk;
+/* L100: */
+ }
+ }
+ }
+ } else {
+
+/* Compute abs(A')*abs(X) + abs(B). */
+
+ if (upper) {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__3 = k;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (
+ d__2 = x[i__ + j * x_dim1], abs(d__2));
+/* L110: */
+ }
+ work[k] += s;
+/* L120: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = (d__1 = x[k + j * x_dim1], abs(d__1));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (
+ d__2 = x[i__ + j * x_dim1], abs(d__2));
+/* L130: */
+ }
+ work[k] += s;
+/* L140: */
+ }
+ }
+ } else {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (
+ d__2 = x[i__ + j * x_dim1], abs(d__2));
+/* L150: */
+ }
+ work[k] += s;
+/* L160: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = (d__1 = x[k + j * x_dim1], abs(d__1));
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (
+ d__2 = x[i__ + j * x_dim1], abs(d__2));
+/* L170: */
+ }
+ work[k] += s;
+/* L180: */
+ }
+ }
+ }
+ }
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[
+ i__];
+ s = max(d__2,d__3);
+ } else {
+/* Computing MAX */
+ d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1)
+ / (work[i__] + safe1);
+ s = max(d__2,d__3);
+ }
+/* L190: */
+ }
+ berr[j] = s;
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use DLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L200: */
+ }
+
+ kase = 0;
+L210:
+ dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+ kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)'). */
+
+ dtrsv_(uplo, transt, diag, n, &a[a_offset], lda, &work[*n + 1]
+, &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L220: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L230: */
+ }
+ dtrsv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1],
+ &c__1);
+ }
+ goto L210;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1));
+ lstres = max(d__2,d__3);
+/* L240: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L250: */
+ }
+
+ return 0;
+
+/* End of DTRRFS */
+
+} /* dtrrfs_ */
diff --git a/SRC/dtrsen.c b/SRC/dtrsen.c
new file mode 100644
index 0000000..193ed02
--- /dev/null
+++ b/SRC/dtrsen.c
@@ -0,0 +1,530 @@
+/* dtrsen.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+
+/* Subroutine */ int dtrsen_(char *job, char *compq, logical *select, integer
+ *n, doublereal *t, integer *ldt, doublereal *q, integer *ldq,
+ doublereal *wr, doublereal *wi, integer *m, doublereal *s, doublereal
+ *sep, doublereal *work, integer *lwork, integer *iwork, integer *
+ liwork, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, t_dim1, t_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer k, n1, n2, kk, nn, ks;
+ doublereal est;
+ integer kase;
+ logical pair;
+ integer ierr;
+ logical swap;
+ doublereal scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3], lwmin;
+ logical wantq, wants;
+ doublereal rnorm;
+ extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ extern doublereal dlange_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ logical wantbh;
+ extern /* Subroutine */ int dtrexc_(char *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, integer *,
+ doublereal *, integer *);
+ integer liwmin;
+ logical wantsp, lquery;
+ extern /* Subroutine */ int dtrsyl_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTRSEN reorders the real Schur factorization of a real matrix */
+/* A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in */
+/* the leading diagonal blocks of the upper quasi-triangular matrix T, */
+/* and the leading columns of Q form an orthonormal basis of the */
+/* corresponding right invariant subspace. */
+
+/* Optionally the routine computes the reciprocal condition numbers of */
+/* the cluster of eigenvalues and/or the invariant subspace. */
+
+/* T must be in Schur canonical form (as returned by DHSEQR), that is, */
+/* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */
+/* 2-by-2 diagonal block has its diagonal elemnts equal and its */
+/* off-diagonal elements of opposite sign. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies whether condition numbers are required for the */
+/* cluster of eigenvalues (S) or the invariant subspace (SEP): */
+/* = 'N': none; */
+/* = 'E': for eigenvalues only (S); */
+/* = 'V': for invariant subspace only (SEP); */
+/* = 'B': for both eigenvalues and invariant subspace (S and */
+/* SEP). */
+
+/* COMPQ (input) CHARACTER*1 */
+/* = 'V': update the matrix Q of Schur vectors; */
+/* = 'N': do not update Q. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* SELECT specifies the eigenvalues in the selected cluster. To */
+/* select a real eigenvalue w(j), SELECT(j) must be set to */
+/* .TRUE.. To select a complex conjugate pair of eigenvalues */
+/* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, */
+/* either SELECT(j) or SELECT(j+1) or both must be set to */
+/* .TRUE.; a complex conjugate pair of eigenvalues must be */
+/* either both included in the cluster or both excluded. */
+
+/* N (input) INTEGER */
+/* The order of the matrix T. N >= 0. */
+
+/* T (input/output) DOUBLE PRECISION array, dimension (LDT,N) */
+/* On entry, the upper quasi-triangular matrix T, in Schur */
+/* canonical form. */
+/* On exit, T is overwritten by the reordered matrix T, again in */
+/* Schur canonical form, with the selected eigenvalues in the */
+/* leading diagonal blocks. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= max(1,N). */
+
+/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) */
+/* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */
+/* On exit, if COMPQ = 'V', Q has been postmultiplied by the */
+/* orthogonal transformation matrix which reorders T; the */
+/* leading M columns of Q form an orthonormal basis for the */
+/* specified invariant subspace. */
+/* If COMPQ = 'N', Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. */
+/* LDQ >= 1; and if COMPQ = 'V', LDQ >= N. */
+
+/* WR (output) DOUBLE PRECISION array, dimension (N) */
+/* WI (output) DOUBLE PRECISION array, dimension (N) */
+/* The real and imaginary parts, respectively, of the reordered */
+/* eigenvalues of T. The eigenvalues are stored in the same */
+/* order as on the diagonal of T, with WR(i) = T(i,i) and, if */
+/* T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and */
+/* WI(i+1) = -WI(i). Note that if a complex eigenvalue is */
+/* sufficiently ill-conditioned, then its value may differ */
+/* significantly from its value before reordering. */
+
+/* M (output) INTEGER */
+/* The dimension of the specified invariant subspace. */
+/* 0 < = M <= N. */
+
+/* S (output) DOUBLE PRECISION */
+/* If JOB = 'E' or 'B', S is a lower bound on the reciprocal */
+/* condition number for the selected cluster of eigenvalues. */
+/* S cannot underestimate the true reciprocal condition number */
+/* by more than a factor of sqrt(N). If M = 0 or N, S = 1. */
+/* If JOB = 'N' or 'V', S is not referenced. */
+
+/* SEP (output) DOUBLE PRECISION */
+/* If JOB = 'V' or 'B', SEP is the estimated reciprocal */
+/* condition number of the specified invariant subspace. If */
+/* M = 0 or N, SEP = norm(T). */
+/* If JOB = 'N' or 'E', SEP is not referenced. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If JOB = 'N', LWORK >= max(1,N); */
+/* if JOB = 'E', LWORK >= max(1,M*(N-M)); */
+/* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)). */
+
+/* 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. */
+
+/* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If JOB = 'N' or 'E', LIWORK >= 1; */
+/* if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)). */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal size of the IWORK array, */
+/* returns this value as the first entry of the IWORK array, and */
+/* no error message related to LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* = 1: reordering of T failed because some eigenvalues are too */
+/* close to separate (the problem is very ill-conditioned); */
+/* T may have been partially reordered, and WR and WI */
+/* contain the eigenvalues in the same order as in T; S and */
+/* SEP (if requested) are set to zero. */
+
+/* Further Details */
+/* =============== */
+
+/* DTRSEN first collects the selected eigenvalues by computing an */
+/* orthogonal transformation Z to move them to the top left corner of T. */
+/* In other words, the selected eigenvalues are the eigenvalues of T11 */
+/* in: */
+
+/* Z'*T*Z = ( T11 T12 ) n1 */
+/* ( 0 T22 ) n2 */
+/* n1 n2 */
+
+/* where N = n1+n2 and Z' means the transpose of Z. The first n1 columns */
+/* of Z span the specified invariant subspace of T. */
+
+/* If T has been obtained from the real Schur factorization of a matrix */
+/* A = Q*T*Q', then the reordered real Schur factorization of A is given */
+/* by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span */
+/* the corresponding invariant subspace of A. */
+
+/* The reciprocal condition number of the average of the eigenvalues of */
+/* T11 may be returned in S. S lies between 0 (very badly conditioned) */
+/* and 1 (very well conditioned). It is computed as follows. First we */
+/* compute R so that */
+
+/* P = ( I R ) n1 */
+/* ( 0 0 ) n2 */
+/* n1 n2 */
+
+/* is the projector on the invariant subspace associated with T11. */
+/* R is the solution of the Sylvester equation: */
+
+/* T11*R - R*T22 = T12. */
+
+/* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote */
+/* the two-norm of M. Then S is computed as the lower bound */
+
+/* (1 + F-norm(R)**2)**(-1/2) */
+
+/* on the reciprocal of 2-norm(P), the true reciprocal condition number. */
+/* S cannot underestimate 1 / 2-norm(P) by more than a factor of */
+/* sqrt(N). */
+
+/* An approximate error bound for the computed average of the */
+/* eigenvalues of T11 is */
+
+/* EPS * norm(T) / S */
+
+/* where EPS is the machine precision. */
+
+/* The reciprocal condition number of the right invariant subspace */
+/* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. */
+/* SEP is defined as the separation of T11 and T22: */
+
+/* sep( T11, T22 ) = sigma-min( C ) */
+
+/* where sigma-min(C) is the smallest singular value of the */
+/* n1*n2-by-n1*n2 matrix */
+
+/* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) */
+
+/* I(m) is an m by m identity matrix, and kprod denotes the Kronecker */
+/* product. We estimate sigma-min(C) by the reciprocal of an estimate of */
+/* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) */
+/* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2). */
+
+/* When SEP is small, small changes in T can cause large changes in */
+/* the invariant subspace. An approximate bound on the maximum angular */
+/* error in the computed right invariant subspace is */
+
+/* EPS * norm(T) / SEP */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ --select;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --wr;
+ --wi;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantbh = lsame_(job, "B");
+ wants = lsame_(job, "E") || wantbh;
+ wantsp = lsame_(job, "V") || wantbh;
+ wantq = lsame_(compq, "V");
+
+ *info = 0;
+ lquery = *lwork == -1;
+ if (! lsame_(job, "N") && ! wants && ! wantsp) {
+ *info = -1;
+ } else if (! lsame_(compq, "N") && ! wantq) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldt < max(1,*n)) {
+ *info = -6;
+ } else if (*ldq < 1 || wantq && *ldq < *n) {
+ *info = -8;
+ } else {
+
+/* Set M to the dimension of the specified invariant subspace, */
+/* and test LWORK and LIWORK. */
+
+ *m = 0;
+ pair = FALSE_;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (pair) {
+ pair = FALSE_;
+ } else {
+ if (k < *n) {
+ if (t[k + 1 + k * t_dim1] == 0.) {
+ if (select[k]) {
+ ++(*m);
+ }
+ } else {
+ pair = TRUE_;
+ if (select[k] || select[k + 1]) {
+ *m += 2;
+ }
+ }
+ } else {
+ if (select[*n]) {
+ ++(*m);
+ }
+ }
+ }
+/* L10: */
+ }
+
+ n1 = *m;
+ n2 = *n - *m;
+ nn = n1 * n2;
+
+ if (wantsp) {
+/* Computing MAX */
+ i__1 = 1, i__2 = nn << 1;
+ lwmin = max(i__1,i__2);
+ liwmin = max(1,nn);
+ } else if (lsame_(job, "N")) {
+ lwmin = max(1,*n);
+ liwmin = 1;
+ } else if (lsame_(job, "E")) {
+ lwmin = max(1,nn);
+ liwmin = 1;
+ }
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -15;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -17;
+ }
+ }
+
+ if (*info == 0) {
+ work[1] = (doublereal) lwmin;
+ iwork[1] = liwmin;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTRSEN", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == *n || *m == 0) {
+ if (wants) {
+ *s = 1.;
+ }
+ if (wantsp) {
+ *sep = dlange_("1", n, n, &t[t_offset], ldt, &work[1]);
+ }
+ goto L40;
+ }
+
+/* Collect the selected blocks at the top-left corner of T. */
+
+ ks = 0;
+ pair = FALSE_;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (pair) {
+ pair = FALSE_;
+ } else {
+ swap = select[k];
+ if (k < *n) {
+ if (t[k + 1 + k * t_dim1] != 0.) {
+ pair = TRUE_;
+ swap = swap || select[k + 1];
+ }
+ }
+ if (swap) {
+ ++ks;
+
+/* Swap the K-th block to position KS. */
+
+ ierr = 0;
+ kk = k;
+ if (k != ks) {
+ dtrexc_(compq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
+ kk, &ks, &work[1], &ierr);
+ }
+ if (ierr == 1 || ierr == 2) {
+
+/* Blocks too close to swap: exit. */
+
+ *info = 1;
+ if (wants) {
+ *s = 0.;
+ }
+ if (wantsp) {
+ *sep = 0.;
+ }
+ goto L40;
+ }
+ if (pair) {
+ ++ks;
+ }
+ }
+ }
+/* L20: */
+ }
+
+ if (wants) {
+
+/* Solve Sylvester equation for R: */
+
+/* T11*R - R*T22 = scale*T12 */
+
+ dlacpy_("F", &n1, &n2, &t[(n1 + 1) * t_dim1 + 1], ldt, &work[1], &n1);
+ dtrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1
+ + 1) * t_dim1], ldt, &work[1], &n1, &scale, &ierr);
+
+/* Estimate the reciprocal of the condition number of the cluster */
+/* of eigenvalues. */
+
+ rnorm = dlange_("F", &n1, &n2, &work[1], &n1, &work[1]);
+ if (rnorm == 0.) {
+ *s = 1.;
+ } else {
+ *s = scale / (sqrt(scale * scale / rnorm + rnorm) * sqrt(rnorm));
+ }
+ }
+
+ if (wantsp) {
+
+/* Estimate sep(T11,T22). */
+
+ est = 0.;
+ kase = 0;
+L30:
+ dlacn2_(&nn, &work[nn + 1], &work[1], &iwork[1], &est, &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Solve T11*R - R*T22 = scale*X. */
+
+ dtrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 +
+ 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &
+ ierr);
+ } else {
+
+/* Solve T11'*R - R*T22' = scale*X. */
+
+ dtrsyl_("T", "T", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 +
+ 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &
+ ierr);
+ }
+ goto L30;
+ }
+
+ *sep = scale / est;
+ }
+
+L40:
+
+/* Store the output eigenvalues in WR and WI. */
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ wr[k] = t[k + k * t_dim1];
+ wi[k] = 0.;
+/* L50: */
+ }
+ i__1 = *n - 1;
+ for (k = 1; k <= i__1; ++k) {
+ if (t[k + 1 + k * t_dim1] != 0.) {
+ wi[k] = sqrt((d__1 = t[k + (k + 1) * t_dim1], abs(d__1))) * sqrt((
+ d__2 = t[k + 1 + k * t_dim1], abs(d__2)));
+ wi[k + 1] = -wi[k];
+ }
+/* L60: */
+ }
+
+ work[1] = (doublereal) lwmin;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of DTRSEN */
+
+} /* dtrsen_ */
diff --git a/SRC/dtrsna.c b/SRC/dtrsna.c
new file mode 100644
index 0000000..d0f26f1
--- /dev/null
+++ b/SRC/dtrsna.c
@@ -0,0 +1,606 @@
+/* dtrsna.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int dtrsna_(char *job, char *howmny, logical *select,
+ integer *n, doublereal *t, integer *ldt, doublereal *vl, integer *
+ ldvl, doublereal *vr, integer *ldvr, doublereal *s, doublereal *sep,
+ integer *mm, integer *m, doublereal *work, integer *ldwork, integer *
+ iwork, integer *info)
+{
+ /* System generated locals */
+ integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset,
+ work_dim1, work_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, n2;
+ doublereal cs;
+ integer nn, ks;
+ doublereal sn, mu, eps, est;
+ integer kase;
+ doublereal cond;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ logical pair;
+ integer ierr;
+ doublereal dumm, prod;
+ integer ifst;
+ doublereal lnrm;
+ integer ilst;
+ doublereal rnrm;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ doublereal prod1, prod2, scale, delta;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical wants;
+ doublereal dummy[1];
+ extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ extern doublereal dlapy2_(doublereal *, doublereal *);
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ doublereal bignum;
+ logical wantbh;
+ extern /* Subroutine */ int dlaqtr_(logical *, logical *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *), dtrexc_(char *, integer *
+, doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *, doublereal *, integer *);
+ logical somcon;
+ doublereal smlnum;
+ logical wantsp;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTRSNA estimates reciprocal condition numbers for specified */
+/* eigenvalues and/or right eigenvectors of a real upper */
+/* quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q */
+/* orthogonal). */
+
+/* T must be in Schur canonical form (as returned by DHSEQR), that is, */
+/* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */
+/* 2-by-2 diagonal block has its diagonal elements equal and its */
+/* off-diagonal elements of opposite sign. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies whether condition numbers are required for */
+/* eigenvalues (S) or eigenvectors (SEP): */
+/* = 'E': for eigenvalues only (S); */
+/* = 'V': for eigenvectors only (SEP); */
+/* = 'B': for both eigenvalues and eigenvectors (S and SEP). */
+
+/* HOWMNY (input) CHARACTER*1 */
+/* = 'A': compute condition numbers for all eigenpairs; */
+/* = 'S': compute condition numbers for selected eigenpairs */
+/* specified by the array SELECT. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* If HOWMNY = 'S', SELECT specifies the eigenpairs for which */
+/* condition numbers are required. To select condition numbers */
+/* for the eigenpair corresponding to a real eigenvalue w(j), */
+/* SELECT(j) must be set to .TRUE.. To select condition numbers */
+/* corresponding to a complex conjugate pair of eigenvalues w(j) */
+/* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be */
+/* set to .TRUE.. */
+/* If HOWMNY = 'A', SELECT is not referenced. */
+
+/* N (input) INTEGER */
+/* The order of the matrix T. N >= 0. */
+
+/* T (input) DOUBLE PRECISION array, dimension (LDT,N) */
+/* The upper quasi-triangular matrix T, in Schur canonical form. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= max(1,N). */
+
+/* VL (input) DOUBLE PRECISION array, dimension (LDVL,M) */
+/* If JOB = 'E' or 'B', VL must contain left eigenvectors of T */
+/* (or of any Q*T*Q**T with Q orthogonal), corresponding to the */
+/* eigenpairs specified by HOWMNY and SELECT. The eigenvectors */
+/* must be stored in consecutive columns of VL, as returned by */
+/* DHSEIN or DTREVC. */
+/* If JOB = 'V', VL is not referenced. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. */
+/* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N. */
+
+/* VR (input) DOUBLE PRECISION array, dimension (LDVR,M) */
+/* If JOB = 'E' or 'B', VR must contain right eigenvectors of T */
+/* (or of any Q*T*Q**T with Q orthogonal), corresponding to the */
+/* eigenpairs specified by HOWMNY and SELECT. The eigenvectors */
+/* must be stored in consecutive columns of VR, as returned by */
+/* DHSEIN or DTREVC. */
+/* If JOB = 'V', VR is not referenced. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. */
+/* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N. */
+
+/* S (output) DOUBLE PRECISION array, dimension (MM) */
+/* If JOB = 'E' or 'B', the reciprocal condition numbers of the */
+/* selected eigenvalues, stored in consecutive elements of the */
+/* array. For a complex conjugate pair of eigenvalues two */
+/* consecutive elements of S are set to the same value. Thus */
+/* S(j), SEP(j), and the j-th columns of VL and VR all */
+/* correspond to the same eigenpair (but not in general the */
+/* j-th eigenpair, unless all eigenpairs are selected). */
+/* If JOB = 'V', S is not referenced. */
+
+/* SEP (output) DOUBLE PRECISION array, dimension (MM) */
+/* If JOB = 'V' or 'B', the estimated reciprocal condition */
+/* numbers of the selected eigenvectors, stored in consecutive */
+/* elements of the array. For a complex eigenvector two */
+/* consecutive elements of SEP are set to the same value. If */
+/* the eigenvalues cannot be reordered to compute SEP(j), SEP(j) */
+/* is set to 0; this can only occur when the true value would be */
+/* very small anyway. */
+/* If JOB = 'E', SEP is not referenced. */
+
+/* MM (input) INTEGER */
+/* The number of elements in the arrays S (if JOB = 'E' or 'B') */
+/* and/or SEP (if JOB = 'V' or 'B'). MM >= M. */
+
+/* M (output) INTEGER */
+/* The number of elements of the arrays S and/or SEP actually */
+/* used to store the estimated condition numbers. */
+/* If HOWMNY = 'A', M is set to N. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N+6) */
+/* If JOB = 'E', WORK is not referenced. */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. */
+/* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N. */
+
+/* IWORK (workspace) INTEGER array, dimension (2*(N-1)) */
+/* If JOB = 'E', IWORK is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The reciprocal of the condition number of an eigenvalue lambda is */
+/* defined as */
+
+/* S(lambda) = |v'*u| / (norm(u)*norm(v)) */
+
+/* where u and v are the right and left eigenvectors of T corresponding */
+/* to lambda; v' denotes the conjugate-transpose of v, and norm(u) */
+/* denotes the Euclidean norm. These reciprocal condition numbers always */
+/* lie between zero (very badly conditioned) and one (very well */
+/* conditioned). If n = 1, S(lambda) is defined to be 1. */
+
+/* An approximate error bound for a computed eigenvalue W(i) is given by */
+
+/* EPS * norm(T) / S(i) */
+
+/* where EPS is the machine precision. */
+
+/* The reciprocal of the condition number of the right eigenvector u */
+/* corresponding to lambda is defined as follows. Suppose */
+
+/* T = ( lambda c ) */
+/* ( 0 T22 ) */
+
+/* Then the reciprocal condition number is */
+
+/* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I ) */
+
+/* where sigma-min denotes the smallest singular value. We approximate */
+/* the smallest singular value by the reciprocal of an estimate of the */
+/* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is */
+/* defined to be abs(T(1,1)). */
+
+/* An approximate error bound for a computed right eigenvector VR(i) */
+/* is given by */
+
+/* EPS * norm(T) / SEP(i) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ --select;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --s;
+ --sep;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --iwork;
+
+ /* Function Body */
+ wantbh = lsame_(job, "B");
+ wants = lsame_(job, "E") || wantbh;
+ wantsp = lsame_(job, "V") || wantbh;
+
+ somcon = lsame_(howmny, "S");
+
+ *info = 0;
+ if (! wants && ! wantsp) {
+ *info = -1;
+ } else if (! lsame_(howmny, "A") && ! somcon) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldt < max(1,*n)) {
+ *info = -6;
+ } else if (*ldvl < 1 || wants && *ldvl < *n) {
+ *info = -8;
+ } else if (*ldvr < 1 || wants && *ldvr < *n) {
+ *info = -10;
+ } else {
+
+/* Set M to the number of eigenpairs for which condition numbers */
+/* are required, and test MM. */
+
+ if (somcon) {
+ *m = 0;
+ pair = FALSE_;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (pair) {
+ pair = FALSE_;
+ } else {
+ if (k < *n) {
+ if (t[k + 1 + k * t_dim1] == 0.) {
+ if (select[k]) {
+ ++(*m);
+ }
+ } else {
+ pair = TRUE_;
+ if (select[k] || select[k + 1]) {
+ *m += 2;
+ }
+ }
+ } else {
+ if (select[*n]) {
+ ++(*m);
+ }
+ }
+ }
+/* L10: */
+ }
+ } else {
+ *m = *n;
+ }
+
+ if (*mm < *m) {
+ *info = -13;
+ } else if (*ldwork < 1 || wantsp && *ldwork < *n) {
+ *info = -16;
+ }
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTRSNA", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (somcon) {
+ if (! select[1]) {
+ return 0;
+ }
+ }
+ if (wants) {
+ s[1] = 1.;
+ }
+ if (wantsp) {
+ sep[1] = (d__1 = t[t_dim1 + 1], abs(d__1));
+ }
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S") / eps;
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+ ks = 0;
+ pair = FALSE_;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+/* Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block. */
+
+ if (pair) {
+ pair = FALSE_;
+ goto L60;
+ } else {
+ if (k < *n) {
+ pair = t[k + 1 + k * t_dim1] != 0.;
+ }
+ }
+
+/* Determine whether condition numbers are required for the k-th */
+/* eigenpair. */
+
+ if (somcon) {
+ if (pair) {
+ if (! select[k] && ! select[k + 1]) {
+ goto L60;
+ }
+ } else {
+ if (! select[k]) {
+ goto L60;
+ }
+ }
+ }
+
+ ++ks;
+
+ if (wants) {
+
+/* Compute the reciprocal condition number of the k-th */
+/* eigenvalue. */
+
+ if (! pair) {
+
+/* Real eigenvalue. */
+
+ prod = ddot_(n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks *
+ vl_dim1 + 1], &c__1);
+ rnrm = dnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
+ lnrm = dnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
+ s[ks] = abs(prod) / (rnrm * lnrm);
+ } else {
+
+/* Complex eigenvalue. */
+
+ prod1 = ddot_(n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks *
+ vl_dim1 + 1], &c__1);
+ prod1 += ddot_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1, &vl[(ks
+ + 1) * vl_dim1 + 1], &c__1);
+ prod2 = ddot_(n, &vl[ks * vl_dim1 + 1], &c__1, &vr[(ks + 1) *
+ vr_dim1 + 1], &c__1);
+ prod2 -= ddot_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1, &vr[ks *
+ vr_dim1 + 1], &c__1);
+ d__1 = dnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
+ d__2 = dnrm2_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1);
+ rnrm = dlapy2_(&d__1, &d__2);
+ d__1 = dnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
+ d__2 = dnrm2_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1);
+ lnrm = dlapy2_(&d__1, &d__2);
+ cond = dlapy2_(&prod1, &prod2) / (rnrm * lnrm);
+ s[ks] = cond;
+ s[ks + 1] = cond;
+ }
+ }
+
+ if (wantsp) {
+
+/* Estimate the reciprocal condition number of the k-th */
+/* eigenvector. */
+
+/* Copy the matrix T to the array WORK and swap the diagonal */
+/* block beginning at T(k,k) to the (1,1) position. */
+
+ dlacpy_("Full", n, n, &t[t_offset], ldt, &work[work_offset],
+ ldwork);
+ ifst = k;
+ ilst = 1;
+ dtrexc_("No Q", n, &work[work_offset], ldwork, dummy, &c__1, &
+ ifst, &ilst, &work[(*n + 1) * work_dim1 + 1], &ierr);
+
+ if (ierr == 1 || ierr == 2) {
+
+/* Could not swap because blocks not well separated */
+
+ scale = 1.;
+ est = bignum;
+ } else {
+
+/* Reordering successful */
+
+ if (work[work_dim1 + 2] == 0.) {
+
+/* Form C = T22 - lambda*I in WORK(2:N,2:N). */
+
+ i__2 = *n;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ work[i__ + i__ * work_dim1] -= work[work_dim1 + 1];
+/* L20: */
+ }
+ n2 = 1;
+ nn = *n - 1;
+ } else {
+
+/* Triangularize the 2 by 2 block by unitary */
+/* transformation U = [ cs i*ss ] */
+/* [ i*ss cs ]. */
+/* such that the (1,1) position of WORK is complex */
+/* eigenvalue lambda with positive imaginary part. (2,2) */
+/* position of WORK is the complex eigenvalue lambda */
+/* with negative imaginary part. */
+
+ mu = sqrt((d__1 = work[(work_dim1 << 1) + 1], abs(d__1)))
+ * sqrt((d__2 = work[work_dim1 + 2], abs(d__2)));
+ delta = dlapy2_(&mu, &work[work_dim1 + 2]);
+ cs = mu / delta;
+ sn = -work[work_dim1 + 2] / delta;
+
+/* Form */
+
+/* C' = WORK(2:N,2:N) + i*[rwork(1) ..... rwork(n-1) ] */
+/* [ mu ] */
+/* [ .. ] */
+/* [ .. ] */
+/* [ mu ] */
+/* where C' is conjugate transpose of complex matrix C, */
+/* and RWORK is stored starting in the N+1-st column of */
+/* WORK. */
+
+ i__2 = *n;
+ for (j = 3; j <= i__2; ++j) {
+ work[j * work_dim1 + 2] = cs * work[j * work_dim1 + 2]
+ ;
+ work[j + j * work_dim1] -= work[work_dim1 + 1];
+/* L30: */
+ }
+ work[(work_dim1 << 1) + 2] = 0.;
+
+ work[(*n + 1) * work_dim1 + 1] = mu * 2.;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ work[i__ + (*n + 1) * work_dim1] = sn * work[(i__ + 1)
+ * work_dim1 + 1];
+/* L40: */
+ }
+ n2 = 2;
+ nn = *n - 1 << 1;
+ }
+
+/* Estimate norm(inv(C')) */
+
+ est = 0.;
+ kase = 0;
+L50:
+ dlacn2_(&nn, &work[(*n + 2) * work_dim1 + 1], &work[(*n + 4) *
+ work_dim1 + 1], &iwork[1], &est, &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+ if (n2 == 1) {
+
+/* Real eigenvalue: solve C'*x = scale*c. */
+
+ i__2 = *n - 1;
+ dlaqtr_(&c_true, &c_true, &i__2, &work[(work_dim1
+ << 1) + 2], ldwork, dummy, &dumm, &scale,
+ &work[(*n + 4) * work_dim1 + 1], &work[(*
+ n + 6) * work_dim1 + 1], &ierr);
+ } else {
+
+/* Complex eigenvalue: solve */
+/* C'*(p+iq) = scale*(c+id) in real arithmetic. */
+
+ i__2 = *n - 1;
+ dlaqtr_(&c_true, &c_false, &i__2, &work[(
+ work_dim1 << 1) + 2], ldwork, &work[(*n +
+ 1) * work_dim1 + 1], &mu, &scale, &work[(*
+ n + 4) * work_dim1 + 1], &work[(*n + 6) *
+ work_dim1 + 1], &ierr);
+ }
+ } else {
+ if (n2 == 1) {
+
+/* Real eigenvalue: solve C*x = scale*c. */
+
+ i__2 = *n - 1;
+ dlaqtr_(&c_false, &c_true, &i__2, &work[(
+ work_dim1 << 1) + 2], ldwork, dummy, &
+ dumm, &scale, &work[(*n + 4) * work_dim1
+ + 1], &work[(*n + 6) * work_dim1 + 1], &
+ ierr);
+ } else {
+
+/* Complex eigenvalue: solve */
+/* C*(p+iq) = scale*(c+id) in real arithmetic. */
+
+ i__2 = *n - 1;
+ dlaqtr_(&c_false, &c_false, &i__2, &work[(
+ work_dim1 << 1) + 2], ldwork, &work[(*n +
+ 1) * work_dim1 + 1], &mu, &scale, &work[(*
+ n + 4) * work_dim1 + 1], &work[(*n + 6) *
+ work_dim1 + 1], &ierr);
+
+ }
+ }
+
+ goto L50;
+ }
+ }
+
+ sep[ks] = scale / max(est,smlnum);
+ if (pair) {
+ sep[ks + 1] = sep[ks];
+ }
+ }
+
+ if (pair) {
+ ++ks;
+ }
+
+L60:
+ ;
+ }
+ return 0;
+
+/* End of DTRSNA */
+
+} /* dtrsna_ */
diff --git a/SRC/dtrsyl.c b/SRC/dtrsyl.c
new file mode 100644
index 0000000..a23f564
--- /dev/null
+++ b/SRC/dtrsyl.c
@@ -0,0 +1,1319 @@
+/* dtrsyl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static logical c_false = FALSE_;
+static integer c__2 = 2;
+static doublereal c_b26 = 1.;
+static doublereal c_b30 = 0.;
+static logical c_true = TRUE_;
+
+/* Subroutine */ int dtrsyl_(char *trana, char *tranb, integer *isgn, integer
+ *m, integer *n, doublereal *a, integer *lda, doublereal *b, integer *
+ ldb, doublereal *c__, integer *ldc, doublereal *scale, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j, k, l;
+ doublereal x[4] /* was [2][2] */;
+ integer k1, k2, l1, l2;
+ doublereal a11, db, da11, vec[4] /* was [2][2] */, dum[1], eps, sgn;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer ierr;
+ doublereal smin, suml, sumr;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ integer knext, lnext;
+ doublereal xnorm;
+ extern /* Subroutine */ int dlaln2_(logical *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *
+, doublereal *, integer *, doublereal *, doublereal *, integer *),
+ dlasy2_(logical *, logical *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *), dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ doublereal scaloc;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ logical notrna, notrnb;
+ doublereal smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTRSYL solves the real Sylvester matrix equation: */
+
+/* op(A)*X + X*op(B) = scale*C or */
+/* op(A)*X - X*op(B) = scale*C, */
+
+/* where op(A) = A or A**T, and A and B are both upper quasi- */
+/* triangular. A is M-by-M and B is N-by-N; the right hand side C and */
+/* the solution X are M-by-N; and scale is an output scale factor, set */
+/* <= 1 to avoid overflow in X. */
+
+/* A and B must be in Schur canonical form (as returned by DHSEQR), that */
+/* is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; */
+/* each 2-by-2 diagonal block has its diagonal elements equal and its */
+/* off-diagonal elements of opposite sign. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANA (input) CHARACTER*1 */
+/* Specifies the option op(A): */
+/* = 'N': op(A) = A (No transpose) */
+/* = 'T': op(A) = A**T (Transpose) */
+/* = 'C': op(A) = A**H (Conjugate transpose = Transpose) */
+
+/* TRANB (input) CHARACTER*1 */
+/* Specifies the option op(B): */
+/* = 'N': op(B) = B (No transpose) */
+/* = 'T': op(B) = B**T (Transpose) */
+/* = 'C': op(B) = B**H (Conjugate transpose = Transpose) */
+
+/* ISGN (input) INTEGER */
+/* Specifies the sign in the equation: */
+/* = +1: solve op(A)*X + X*op(B) = scale*C */
+/* = -1: solve op(A)*X - X*op(B) = scale*C */
+
+/* M (input) INTEGER */
+/* The order of the matrix A, and the number of rows in the */
+/* matrices X and C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The order of the matrix B, and the number of columns in the */
+/* matrices X and C. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,M) */
+/* The upper quasi-triangular matrix A, in Schur canonical form. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,N) */
+/* The upper quasi-triangular matrix B, in Schur canonical form. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/* On entry, the M-by-N right hand side matrix C. */
+/* On exit, C is overwritten by the solution matrix X. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M) */
+
+/* SCALE (output) DOUBLE PRECISION */
+/* The scale factor, scale, set <= 1 to avoid overflow in X. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* = 1: A and B have common or very close eigenvalues; perturbed */
+/* values were used to solve the equation (but the matrices */
+/* A and B are unchanged). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and Test input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ notrna = lsame_(trana, "N");
+ notrnb = lsame_(tranb, "N");
+
+ *info = 0;
+ if (! notrna && ! lsame_(trana, "T") && ! lsame_(
+ trana, "C")) {
+ *info = -1;
+ } else if (! notrnb && ! lsame_(tranb, "T") && !
+ lsame_(tranb, "C")) {
+ *info = -2;
+ } else if (*isgn != 1 && *isgn != -1) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*m)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldc < max(1,*m)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTRSYL", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *scale = 1.;
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Set constants to control overflow */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ smlnum = smlnum * (doublereal) (*m * *n) / eps;
+ bignum = 1. / smlnum;
+
+/* Computing MAX */
+ d__1 = smlnum, d__2 = eps * dlange_("M", m, m, &a[a_offset], lda, dum), d__1 = max(d__1,d__2), d__2 = eps * dlange_("M", n, n,
+ &b[b_offset], ldb, dum);
+ smin = max(d__1,d__2);
+
+ sgn = (doublereal) (*isgn);
+
+ if (notrna && notrnb) {
+
+/* Solve A*X + ISGN*X*B = scale*C. */
+
+/* The (K,L)th block of X is determined starting from */
+/* bottom-left corner column by column by */
+
+/* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */
+
+/* Where */
+/* M L-1 */
+/* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]. */
+/* I=K+1 J=1 */
+
+/* Start column loop (index = L) */
+/* L1 (L2) : column index of the first (first) row of X(K,L). */
+
+ lnext = 1;
+ i__1 = *n;
+ for (l = 1; l <= i__1; ++l) {
+ if (l < lnext) {
+ goto L60;
+ }
+ if (l == *n) {
+ l1 = l;
+ l2 = l;
+ } else {
+ if (b[l + 1 + l * b_dim1] != 0.) {
+ l1 = l;
+ l2 = l + 1;
+ lnext = l + 2;
+ } else {
+ l1 = l;
+ l2 = l;
+ lnext = l + 1;
+ }
+ }
+
+/* Start row loop (index = K) */
+/* K1 (K2): row index of the first (last) row of X(K,L). */
+
+ knext = *m;
+ for (k = *m; k >= 1; --k) {
+ if (k > knext) {
+ goto L50;
+ }
+ if (k == 1) {
+ k1 = k;
+ k2 = k;
+ } else {
+ if (a[k + (k - 1) * a_dim1] != 0.) {
+ k1 = k - 1;
+ k2 = k;
+ knext = k - 2;
+ } else {
+ k1 = k;
+ k2 = k;
+ knext = k - 1;
+ }
+ }
+
+ if (l1 == l2 && k1 == k2) {
+ i__2 = *m - k1;
+/* Computing MIN */
+ i__3 = k1 + 1;
+/* Computing MIN */
+ i__4 = k1 + 1;
+ suml = ddot_(&i__2, &a[k1 + min(i__3, *m)* a_dim1], lda, &
+ c__[min(i__4, *m)+ l1 * c_dim1], &c__1);
+ i__2 = l1 - 1;
+ sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+ scaloc = 1.;
+
+ a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1];
+ da11 = abs(a11);
+ if (da11 <= smin) {
+ a11 = smin;
+ da11 = smin;
+ *info = 1;
+ }
+ db = abs(vec[0]);
+ if (da11 < 1. && db > 1.) {
+ if (db > bignum * da11) {
+ scaloc = 1. / db;
+ }
+ }
+ x[0] = vec[0] * scaloc / a11;
+
+ if (scaloc != 1.) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L10: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+
+ } else if (l1 == l2 && k1 != k2) {
+
+ i__2 = *m - k2;
+/* Computing MIN */
+ i__3 = k2 + 1;
+/* Computing MIN */
+ i__4 = k2 + 1;
+ suml = ddot_(&i__2, &a[k1 + min(i__3, *m)* a_dim1], lda, &
+ c__[min(i__4, *m)+ l1 * c_dim1], &c__1);
+ i__2 = l1 - 1;
+ sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__2 = *m - k2;
+/* Computing MIN */
+ i__3 = k2 + 1;
+/* Computing MIN */
+ i__4 = k2 + 1;
+ suml = ddot_(&i__2, &a[k2 + min(i__3, *m)* a_dim1], lda, &
+ c__[min(i__4, *m)+ l1 * c_dim1], &c__1);
+ i__2 = l1 - 1;
+ sumr = ddot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ d__1 = -sgn * b[l1 + l1 * b_dim1];
+ dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1
+ * a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1,
+ &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L20: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k2 + l1 * c_dim1] = x[1];
+
+ } else if (l1 != l2 && k1 == k2) {
+
+ i__2 = *m - k1;
+/* Computing MIN */
+ i__3 = k1 + 1;
+/* Computing MIN */
+ i__4 = k1 + 1;
+ suml = ddot_(&i__2, &a[k1 + min(i__3, *m)* a_dim1], lda, &
+ c__[min(i__4, *m)+ l1 * c_dim1], &c__1);
+ i__2 = l1 - 1;
+ sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn *
+ sumr));
+
+ i__2 = *m - k1;
+/* Computing MIN */
+ i__3 = k1 + 1;
+/* Computing MIN */
+ i__4 = k1 + 1;
+ suml = ddot_(&i__2, &a[k1 + min(i__3, *m)* a_dim1], lda, &
+ c__[min(i__4, *m)+ l2 * c_dim1], &c__1);
+ i__2 = l1 - 1;
+ sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l2 *
+ b_dim1 + 1], &c__1);
+ vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn *
+ sumr));
+
+ d__1 = -sgn * a[k1 + k1 * a_dim1];
+ dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 *
+ b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1,
+ &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L30: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k1 + l2 * c_dim1] = x[1];
+
+ } else if (l1 != l2 && k1 != k2) {
+
+ i__2 = *m - k2;
+/* Computing MIN */
+ i__3 = k2 + 1;
+/* Computing MIN */
+ i__4 = k2 + 1;
+ suml = ddot_(&i__2, &a[k1 + min(i__3, *m)* a_dim1], lda, &
+ c__[min(i__4, *m)+ l1 * c_dim1], &c__1);
+ i__2 = l1 - 1;
+ sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__2 = *m - k2;
+/* Computing MIN */
+ i__3 = k2 + 1;
+/* Computing MIN */
+ i__4 = k2 + 1;
+ suml = ddot_(&i__2, &a[k1 + min(i__3, *m)* a_dim1], lda, &
+ c__[min(i__4, *m)+ l2 * c_dim1], &c__1);
+ i__2 = l1 - 1;
+ sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l2 *
+ b_dim1 + 1], &c__1);
+ vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr);
+
+ i__2 = *m - k2;
+/* Computing MIN */
+ i__3 = k2 + 1;
+/* Computing MIN */
+ i__4 = k2 + 1;
+ suml = ddot_(&i__2, &a[k2 + min(i__3, *m)* a_dim1], lda, &
+ c__[min(i__4, *m)+ l1 * c_dim1], &c__1);
+ i__2 = l1 - 1;
+ sumr = ddot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__2 = *m - k2;
+/* Computing MIN */
+ i__3 = k2 + 1;
+/* Computing MIN */
+ i__4 = k2 + 1;
+ suml = ddot_(&i__2, &a[k2 + min(i__3, *m)* a_dim1], lda, &
+ c__[min(i__4, *m)+ l2 * c_dim1], &c__1);
+ i__2 = l1 - 1;
+ sumr = ddot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l2 *
+ b_dim1 + 1], &c__1);
+ vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr);
+
+ dlasy2_(&c_false, &c_false, isgn, &c__2, &c__2, &a[k1 +
+ k1 * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec,
+ &c__2, &scaloc, x, &c__2, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L40: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k1 + l2 * c_dim1] = x[2];
+ c__[k2 + l1 * c_dim1] = x[1];
+ c__[k2 + l2 * c_dim1] = x[3];
+ }
+
+L50:
+ ;
+ }
+
+L60:
+ ;
+ }
+
+ } else if (! notrna && notrnb) {
+
+/* Solve A' *X + ISGN*X*B = scale*C. */
+
+/* The (K,L)th block of X is determined starting from */
+/* upper-left corner column by column by */
+
+/* A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */
+
+/* Where */
+/* K-1 L-1 */
+/* R(K,L) = SUM [A(I,K)'*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)] */
+/* I=1 J=1 */
+
+/* Start column loop (index = L) */
+/* L1 (L2): column index of the first (last) row of X(K,L) */
+
+ lnext = 1;
+ i__1 = *n;
+ for (l = 1; l <= i__1; ++l) {
+ if (l < lnext) {
+ goto L120;
+ }
+ if (l == *n) {
+ l1 = l;
+ l2 = l;
+ } else {
+ if (b[l + 1 + l * b_dim1] != 0.) {
+ l1 = l;
+ l2 = l + 1;
+ lnext = l + 2;
+ } else {
+ l1 = l;
+ l2 = l;
+ lnext = l + 1;
+ }
+ }
+
+/* Start row loop (index = K) */
+/* K1 (K2): row index of the first (last) row of X(K,L) */
+
+ knext = 1;
+ i__2 = *m;
+ for (k = 1; k <= i__2; ++k) {
+ if (k < knext) {
+ goto L110;
+ }
+ if (k == *m) {
+ k1 = k;
+ k2 = k;
+ } else {
+ if (a[k + 1 + k * a_dim1] != 0.) {
+ k1 = k;
+ k2 = k + 1;
+ knext = k + 2;
+ } else {
+ k1 = k;
+ k2 = k;
+ knext = k + 1;
+ }
+ }
+
+ if (l1 == l2 && k1 == k2) {
+ i__3 = k1 - 1;
+ suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__3 = l1 - 1;
+ sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+ scaloc = 1.;
+
+ a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1];
+ da11 = abs(a11);
+ if (da11 <= smin) {
+ a11 = smin;
+ da11 = smin;
+ *info = 1;
+ }
+ db = abs(vec[0]);
+ if (da11 < 1. && db > 1.) {
+ if (db > bignum * da11) {
+ scaloc = 1. / db;
+ }
+ }
+ x[0] = vec[0] * scaloc / a11;
+
+ if (scaloc != 1.) {
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L70: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+
+ } else if (l1 == l2 && k1 != k2) {
+
+ i__3 = k1 - 1;
+ suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__3 = l1 - 1;
+ sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__3 = k1 - 1;
+ suml = ddot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__3 = l1 - 1;
+ sumr = ddot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ d__1 = -sgn * b[l1 + l1 * b_dim1];
+ dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 *
+ a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1,
+ &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.) {
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L80: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k2 + l1 * c_dim1] = x[1];
+
+ } else if (l1 != l2 && k1 == k2) {
+
+ i__3 = k1 - 1;
+ suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__3 = l1 - 1;
+ sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn *
+ sumr));
+
+ i__3 = k1 - 1;
+ suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 *
+ c_dim1 + 1], &c__1);
+ i__3 = l1 - 1;
+ sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l2 *
+ b_dim1 + 1], &c__1);
+ vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn *
+ sumr));
+
+ d__1 = -sgn * a[k1 + k1 * a_dim1];
+ dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 *
+ b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1,
+ &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.) {
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L90: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k1 + l2 * c_dim1] = x[1];
+
+ } else if (l1 != l2 && k1 != k2) {
+
+ i__3 = k1 - 1;
+ suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__3 = l1 - 1;
+ sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__3 = k1 - 1;
+ suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 *
+ c_dim1 + 1], &c__1);
+ i__3 = l1 - 1;
+ sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l2 *
+ b_dim1 + 1], &c__1);
+ vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr);
+
+ i__3 = k1 - 1;
+ suml = ddot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__3 = l1 - 1;
+ sumr = ddot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__3 = k1 - 1;
+ suml = ddot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l2 *
+ c_dim1 + 1], &c__1);
+ i__3 = l1 - 1;
+ sumr = ddot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l2 *
+ b_dim1 + 1], &c__1);
+ vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr);
+
+ dlasy2_(&c_true, &c_false, isgn, &c__2, &c__2, &a[k1 + k1
+ * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, &
+ c__2, &scaloc, x, &c__2, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.) {
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L100: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k1 + l2 * c_dim1] = x[2];
+ c__[k2 + l1 * c_dim1] = x[1];
+ c__[k2 + l2 * c_dim1] = x[3];
+ }
+
+L110:
+ ;
+ }
+L120:
+ ;
+ }
+
+ } else if (! notrna && ! notrnb) {
+
+/* Solve A'*X + ISGN*X*B' = scale*C. */
+
+/* The (K,L)th block of X is determined starting from */
+/* top-right corner column by column by */
+
+/* A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L) */
+
+/* Where */
+/* K-1 N */
+/* R(K,L) = SUM [A(I,K)'*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)']. */
+/* I=1 J=L+1 */
+
+/* Start column loop (index = L) */
+/* L1 (L2): column index of the first (last) row of X(K,L) */
+
+ lnext = *n;
+ for (l = *n; l >= 1; --l) {
+ if (l > lnext) {
+ goto L180;
+ }
+ if (l == 1) {
+ l1 = l;
+ l2 = l;
+ } else {
+ if (b[l + (l - 1) * b_dim1] != 0.) {
+ l1 = l - 1;
+ l2 = l;
+ lnext = l - 2;
+ } else {
+ l1 = l;
+ l2 = l;
+ lnext = l - 1;
+ }
+ }
+
+/* Start row loop (index = K) */
+/* K1 (K2): row index of the first (last) row of X(K,L) */
+
+ knext = 1;
+ i__1 = *m;
+ for (k = 1; k <= i__1; ++k) {
+ if (k < knext) {
+ goto L170;
+ }
+ if (k == *m) {
+ k1 = k;
+ k2 = k;
+ } else {
+ if (a[k + 1 + k * a_dim1] != 0.) {
+ k1 = k;
+ k2 = k + 1;
+ knext = k + 2;
+ } else {
+ k1 = k;
+ k2 = k;
+ knext = k + 1;
+ }
+ }
+
+ if (l1 == l2 && k1 == k2) {
+ i__2 = k1 - 1;
+ suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__2 = *n - l1;
+/* Computing MIN */
+ i__3 = l1 + 1;
+/* Computing MIN */
+ i__4 = l1 + 1;
+ sumr = ddot_(&i__2, &c__[k1 + min(i__3, *n)* c_dim1], ldc,
+ &b[l1 + min(i__4, *n)* b_dim1], ldb);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+ scaloc = 1.;
+
+ a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1];
+ da11 = abs(a11);
+ if (da11 <= smin) {
+ a11 = smin;
+ da11 = smin;
+ *info = 1;
+ }
+ db = abs(vec[0]);
+ if (da11 < 1. && db > 1.) {
+ if (db > bignum * da11) {
+ scaloc = 1. / db;
+ }
+ }
+ x[0] = vec[0] * scaloc / a11;
+
+ if (scaloc != 1.) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L130: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+
+ } else if (l1 == l2 && k1 != k2) {
+
+ i__2 = k1 - 1;
+ suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__2 = *n - l2;
+/* Computing MIN */
+ i__3 = l2 + 1;
+/* Computing MIN */
+ i__4 = l2 + 1;
+ sumr = ddot_(&i__2, &c__[k1 + min(i__3, *n)* c_dim1], ldc,
+ &b[l1 + min(i__4, *n)* b_dim1], ldb);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__2 = k1 - 1;
+ suml = ddot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__2 = *n - l2;
+/* Computing MIN */
+ i__3 = l2 + 1;
+/* Computing MIN */
+ i__4 = l2 + 1;
+ sumr = ddot_(&i__2, &c__[k2 + min(i__3, *n)* c_dim1], ldc,
+ &b[l1 + min(i__4, *n)* b_dim1], ldb);
+ vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ d__1 = -sgn * b[l1 + l1 * b_dim1];
+ dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 *
+ a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1,
+ &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L140: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k2 + l1 * c_dim1] = x[1];
+
+ } else if (l1 != l2 && k1 == k2) {
+
+ i__2 = k1 - 1;
+ suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__2 = *n - l2;
+/* Computing MIN */
+ i__3 = l2 + 1;
+/* Computing MIN */
+ i__4 = l2 + 1;
+ sumr = ddot_(&i__2, &c__[k1 + min(i__3, *n)* c_dim1], ldc,
+ &b[l1 + min(i__4, *n)* b_dim1], ldb);
+ vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn *
+ sumr));
+
+ i__2 = k1 - 1;
+ suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 *
+ c_dim1 + 1], &c__1);
+ i__2 = *n - l2;
+/* Computing MIN */
+ i__3 = l2 + 1;
+/* Computing MIN */
+ i__4 = l2 + 1;
+ sumr = ddot_(&i__2, &c__[k1 + min(i__3, *n)* c_dim1], ldc,
+ &b[l2 + min(i__4, *n)* b_dim1], ldb);
+ vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn *
+ sumr));
+
+ d__1 = -sgn * a[k1 + k1 * a_dim1];
+ dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1
+ * b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1,
+ &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L150: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k1 + l2 * c_dim1] = x[1];
+
+ } else if (l1 != l2 && k1 != k2) {
+
+ i__2 = k1 - 1;
+ suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__2 = *n - l2;
+/* Computing MIN */
+ i__3 = l2 + 1;
+/* Computing MIN */
+ i__4 = l2 + 1;
+ sumr = ddot_(&i__2, &c__[k1 + min(i__3, *n)* c_dim1], ldc,
+ &b[l1 + min(i__4, *n)* b_dim1], ldb);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__2 = k1 - 1;
+ suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 *
+ c_dim1 + 1], &c__1);
+ i__2 = *n - l2;
+/* Computing MIN */
+ i__3 = l2 + 1;
+/* Computing MIN */
+ i__4 = l2 + 1;
+ sumr = ddot_(&i__2, &c__[k1 + min(i__3, *n)* c_dim1], ldc,
+ &b[l2 + min(i__4, *n)* b_dim1], ldb);
+ vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr);
+
+ i__2 = k1 - 1;
+ suml = ddot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__2 = *n - l2;
+/* Computing MIN */
+ i__3 = l2 + 1;
+/* Computing MIN */
+ i__4 = l2 + 1;
+ sumr = ddot_(&i__2, &c__[k2 + min(i__3, *n)* c_dim1], ldc,
+ &b[l1 + min(i__4, *n)* b_dim1], ldb);
+ vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__2 = k1 - 1;
+ suml = ddot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l2 *
+ c_dim1 + 1], &c__1);
+ i__2 = *n - l2;
+/* Computing MIN */
+ i__3 = l2 + 1;
+/* Computing MIN */
+ i__4 = l2 + 1;
+ sumr = ddot_(&i__2, &c__[k2 + min(i__3, *n)* c_dim1], ldc,
+ &b[l2 + min(i__4, *n)* b_dim1], ldb);
+ vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr);
+
+ dlasy2_(&c_true, &c_true, isgn, &c__2, &c__2, &a[k1 + k1 *
+ a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, &
+ c__2, &scaloc, x, &c__2, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L160: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k1 + l2 * c_dim1] = x[2];
+ c__[k2 + l1 * c_dim1] = x[1];
+ c__[k2 + l2 * c_dim1] = x[3];
+ }
+
+L170:
+ ;
+ }
+L180:
+ ;
+ }
+
+ } else if (notrna && ! notrnb) {
+
+/* Solve A*X + ISGN*X*B' = scale*C. */
+
+/* The (K,L)th block of X is determined starting from */
+/* bottom-right corner column by column by */
+
+/* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L) */
+
+/* Where */
+/* M N */
+/* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)']. */
+/* I=K+1 J=L+1 */
+
+/* Start column loop (index = L) */
+/* L1 (L2): column index of the first (last) row of X(K,L) */
+
+ lnext = *n;
+ for (l = *n; l >= 1; --l) {
+ if (l > lnext) {
+ goto L240;
+ }
+ if (l == 1) {
+ l1 = l;
+ l2 = l;
+ } else {
+ if (b[l + (l - 1) * b_dim1] != 0.) {
+ l1 = l - 1;
+ l2 = l;
+ lnext = l - 2;
+ } else {
+ l1 = l;
+ l2 = l;
+ lnext = l - 1;
+ }
+ }
+
+/* Start row loop (index = K) */
+/* K1 (K2): row index of the first (last) row of X(K,L) */
+
+ knext = *m;
+ for (k = *m; k >= 1; --k) {
+ if (k > knext) {
+ goto L230;
+ }
+ if (k == 1) {
+ k1 = k;
+ k2 = k;
+ } else {
+ if (a[k + (k - 1) * a_dim1] != 0.) {
+ k1 = k - 1;
+ k2 = k;
+ knext = k - 2;
+ } else {
+ k1 = k;
+ k2 = k;
+ knext = k - 1;
+ }
+ }
+
+ if (l1 == l2 && k1 == k2) {
+ i__1 = *m - k1;
+/* Computing MIN */
+ i__2 = k1 + 1;
+/* Computing MIN */
+ i__3 = k1 + 1;
+ suml = ddot_(&i__1, &a[k1 + min(i__2, *m)* a_dim1], lda, &
+ c__[min(i__3, *m)+ l1 * c_dim1], &c__1);
+ i__1 = *n - l1;
+/* Computing MIN */
+ i__2 = l1 + 1;
+/* Computing MIN */
+ i__3 = l1 + 1;
+ sumr = ddot_(&i__1, &c__[k1 + min(i__2, *n)* c_dim1], ldc,
+ &b[l1 + min(i__3, *n)* b_dim1], ldb);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+ scaloc = 1.;
+
+ a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1];
+ da11 = abs(a11);
+ if (da11 <= smin) {
+ a11 = smin;
+ da11 = smin;
+ *info = 1;
+ }
+ db = abs(vec[0]);
+ if (da11 < 1. && db > 1.) {
+ if (db > bignum * da11) {
+ scaloc = 1. / db;
+ }
+ }
+ x[0] = vec[0] * scaloc / a11;
+
+ if (scaloc != 1.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L190: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+
+ } else if (l1 == l2 && k1 != k2) {
+
+ i__1 = *m - k2;
+/* Computing MIN */
+ i__2 = k2 + 1;
+/* Computing MIN */
+ i__3 = k2 + 1;
+ suml = ddot_(&i__1, &a[k1 + min(i__2, *m)* a_dim1], lda, &
+ c__[min(i__3, *m)+ l1 * c_dim1], &c__1);
+ i__1 = *n - l2;
+/* Computing MIN */
+ i__2 = l2 + 1;
+/* Computing MIN */
+ i__3 = l2 + 1;
+ sumr = ddot_(&i__1, &c__[k1 + min(i__2, *n)* c_dim1], ldc,
+ &b[l1 + min(i__3, *n)* b_dim1], ldb);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__1 = *m - k2;
+/* Computing MIN */
+ i__2 = k2 + 1;
+/* Computing MIN */
+ i__3 = k2 + 1;
+ suml = ddot_(&i__1, &a[k2 + min(i__2, *m)* a_dim1], lda, &
+ c__[min(i__3, *m)+ l1 * c_dim1], &c__1);
+ i__1 = *n - l2;
+/* Computing MIN */
+ i__2 = l2 + 1;
+/* Computing MIN */
+ i__3 = l2 + 1;
+ sumr = ddot_(&i__1, &c__[k2 + min(i__2, *n)* c_dim1], ldc,
+ &b[l1 + min(i__3, *n)* b_dim1], ldb);
+ vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ d__1 = -sgn * b[l1 + l1 * b_dim1];
+ dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1
+ * a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1,
+ &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L200: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k2 + l1 * c_dim1] = x[1];
+
+ } else if (l1 != l2 && k1 == k2) {
+
+ i__1 = *m - k1;
+/* Computing MIN */
+ i__2 = k1 + 1;
+/* Computing MIN */
+ i__3 = k1 + 1;
+ suml = ddot_(&i__1, &a[k1 + min(i__2, *m)* a_dim1], lda, &
+ c__[min(i__3, *m)+ l1 * c_dim1], &c__1);
+ i__1 = *n - l2;
+/* Computing MIN */
+ i__2 = l2 + 1;
+/* Computing MIN */
+ i__3 = l2 + 1;
+ sumr = ddot_(&i__1, &c__[k1 + min(i__2, *n)* c_dim1], ldc,
+ &b[l1 + min(i__3, *n)* b_dim1], ldb);
+ vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn *
+ sumr));
+
+ i__1 = *m - k1;
+/* Computing MIN */
+ i__2 = k1 + 1;
+/* Computing MIN */
+ i__3 = k1 + 1;
+ suml = ddot_(&i__1, &a[k1 + min(i__2, *m)* a_dim1], lda, &
+ c__[min(i__3, *m)+ l2 * c_dim1], &c__1);
+ i__1 = *n - l2;
+/* Computing MIN */
+ i__2 = l2 + 1;
+/* Computing MIN */
+ i__3 = l2 + 1;
+ sumr = ddot_(&i__1, &c__[k1 + min(i__2, *n)* c_dim1], ldc,
+ &b[l2 + min(i__3, *n)* b_dim1], ldb);
+ vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn *
+ sumr));
+
+ d__1 = -sgn * a[k1 + k1 * a_dim1];
+ dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1
+ * b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1,
+ &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L210: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k1 + l2 * c_dim1] = x[1];
+
+ } else if (l1 != l2 && k1 != k2) {
+
+ i__1 = *m - k2;
+/* Computing MIN */
+ i__2 = k2 + 1;
+/* Computing MIN */
+ i__3 = k2 + 1;
+ suml = ddot_(&i__1, &a[k1 + min(i__2, *m)* a_dim1], lda, &
+ c__[min(i__3, *m)+ l1 * c_dim1], &c__1);
+ i__1 = *n - l2;
+/* Computing MIN */
+ i__2 = l2 + 1;
+/* Computing MIN */
+ i__3 = l2 + 1;
+ sumr = ddot_(&i__1, &c__[k1 + min(i__2, *n)* c_dim1], ldc,
+ &b[l1 + min(i__3, *n)* b_dim1], ldb);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__1 = *m - k2;
+/* Computing MIN */
+ i__2 = k2 + 1;
+/* Computing MIN */
+ i__3 = k2 + 1;
+ suml = ddot_(&i__1, &a[k1 + min(i__2, *m)* a_dim1], lda, &
+ c__[min(i__3, *m)+ l2 * c_dim1], &c__1);
+ i__1 = *n - l2;
+/* Computing MIN */
+ i__2 = l2 + 1;
+/* Computing MIN */
+ i__3 = l2 + 1;
+ sumr = ddot_(&i__1, &c__[k1 + min(i__2, *n)* c_dim1], ldc,
+ &b[l2 + min(i__3, *n)* b_dim1], ldb);
+ vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr);
+
+ i__1 = *m - k2;
+/* Computing MIN */
+ i__2 = k2 + 1;
+/* Computing MIN */
+ i__3 = k2 + 1;
+ suml = ddot_(&i__1, &a[k2 + min(i__2, *m)* a_dim1], lda, &
+ c__[min(i__3, *m)+ l1 * c_dim1], &c__1);
+ i__1 = *n - l2;
+/* Computing MIN */
+ i__2 = l2 + 1;
+/* Computing MIN */
+ i__3 = l2 + 1;
+ sumr = ddot_(&i__1, &c__[k2 + min(i__2, *n)* c_dim1], ldc,
+ &b[l1 + min(i__3, *n)* b_dim1], ldb);
+ vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__1 = *m - k2;
+/* Computing MIN */
+ i__2 = k2 + 1;
+/* Computing MIN */
+ i__3 = k2 + 1;
+ suml = ddot_(&i__1, &a[k2 + min(i__2, *m)* a_dim1], lda, &
+ c__[min(i__3, *m)+ l2 * c_dim1], &c__1);
+ i__1 = *n - l2;
+/* Computing MIN */
+ i__2 = l2 + 1;
+/* Computing MIN */
+ i__3 = l2 + 1;
+ sumr = ddot_(&i__1, &c__[k2 + min(i__2, *n)* c_dim1], ldc,
+ &b[l2 + min(i__3, *n)* b_dim1], ldb);
+ vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr);
+
+ dlasy2_(&c_false, &c_true, isgn, &c__2, &c__2, &a[k1 + k1
+ * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, &
+ c__2, &scaloc, x, &c__2, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L220: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k1 + l2 * c_dim1] = x[2];
+ c__[k2 + l1 * c_dim1] = x[1];
+ c__[k2 + l2 * c_dim1] = x[3];
+ }
+
+L230:
+ ;
+ }
+L240:
+ ;
+ }
+
+ }
+
+ return 0;
+
+/* End of DTRSYL */
+
+} /* dtrsyl_ */
diff --git a/SRC/dtrti2.c b/SRC/dtrti2.c
new file mode 100644
index 0000000..2631b19
--- /dev/null
+++ b/SRC/dtrti2.c
@@ -0,0 +1,183 @@
+/* dtrti2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dtrti2_(char *uplo, char *diag, integer *n, doublereal *
+ a, integer *lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer j;
+ doublereal ajj;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *,
+ doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *);
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTRTI2 computes the inverse of a real upper or lower triangular */
+/* matrix. */
+
+/* This is the Level 2 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the triangular matrix A. If UPLO = 'U', the */
+/* leading n by n upper triangular part of the array A contains */
+/* the upper triangular matrix, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n by n lower triangular part of the array A contains */
+/* the lower triangular matrix, and the strictly upper */
+/* triangular part of A is not referenced. If DIAG = 'U', the */
+/* diagonal elements of A are also not referenced and are */
+/* assumed to be 1. */
+
+/* On exit, the (triangular) inverse of the original matrix, in */
+/* the same storage format. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ nounit = lsame_(diag, "N");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTRTI2", &i__1);
+ return 0;
+ }
+
+ if (upper) {
+
+/* Compute inverse of upper triangular matrix. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (nounit) {
+ a[j + j * a_dim1] = 1. / a[j + j * a_dim1];
+ ajj = -a[j + j * a_dim1];
+ } else {
+ ajj = -1.;
+ }
+
+/* Compute elements 1:j-1 of j-th column. */
+
+ i__2 = j - 1;
+ dtrmv_("Upper", "No transpose", diag, &i__2, &a[a_offset], lda, &
+ a[j * a_dim1 + 1], &c__1);
+ i__2 = j - 1;
+ dscal_(&i__2, &ajj, &a[j * a_dim1 + 1], &c__1);
+/* L10: */
+ }
+ } else {
+
+/* Compute inverse of lower triangular matrix. */
+
+ for (j = *n; j >= 1; --j) {
+ if (nounit) {
+ a[j + j * a_dim1] = 1. / a[j + j * a_dim1];
+ ajj = -a[j + j * a_dim1];
+ } else {
+ ajj = -1.;
+ }
+ if (j < *n) {
+
+/* Compute elements j+1:n of j-th column. */
+
+ i__1 = *n - j;
+ dtrmv_("Lower", "No transpose", diag, &i__1, &a[j + 1 + (j +
+ 1) * a_dim1], lda, &a[j + 1 + j * a_dim1], &c__1);
+ i__1 = *n - j;
+ dscal_(&i__1, &ajj, &a[j + 1 + j * a_dim1], &c__1);
+ }
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of DTRTI2 */
+
+} /* dtrti2_ */
diff --git a/SRC/dtrtri.c b/SRC/dtrtri.c
new file mode 100644
index 0000000..cbc2264
--- /dev/null
+++ b/SRC/dtrtri.c
@@ -0,0 +1,242 @@
+/* dtrtri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static doublereal c_b18 = 1.;
+static doublereal c_b22 = -1.;
+
+/* Subroutine */ int dtrtri_(char *uplo, char *diag, integer *n, doublereal *
+ a, integer *lda, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, i__1, i__2[2], i__3, i__4, i__5;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer j, jb, nb, nn;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), dtrsm_(
+ char *, char *, char *, char *, integer *, integer *, doublereal *
+, doublereal *, integer *, doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int dtrti2_(char *, char *, integer *, doublereal
+ *, integer *, integer *), xerbla_(char *, integer
+ *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTRTRI computes the inverse of a real upper or lower triangular */
+/* matrix A. */
+
+/* This is the Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the triangular matrix A. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of the array A contains */
+/* the upper triangular matrix, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of the array A contains */
+/* the lower triangular matrix, and the strictly upper */
+/* triangular part of A is not referenced. If DIAG = 'U', the */
+/* diagonal elements of A are also not referenced and are */
+/* assumed to be 1. */
+/* On exit, the (triangular) inverse of the original matrix, in */
+/* the same storage format. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */
+/* matrix is singular and its inverse can not be computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ nounit = lsame_(diag, "N");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTRTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check for singularity if non-unit. */
+
+ if (nounit) {
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ if (a[*info + *info * a_dim1] == 0.) {
+ return 0;
+ }
+/* L10: */
+ }
+ *info = 0;
+ }
+
+/* Determine the block size for this environment. */
+
+/* Writing concatenation */
+ i__2[0] = 1, a__1[0] = uplo;
+ i__2[1] = 1, a__1[1] = diag;
+ s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2);
+ nb = ilaenv_(&c__1, "DTRTRI", ch__1, n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code */
+
+ dtrti2_(uplo, diag, n, &a[a_offset], lda, info);
+ } else {
+
+/* Use blocked code */
+
+ if (upper) {
+
+/* Compute inverse of upper triangular matrix */
+
+ i__1 = *n;
+ i__3 = nb;
+ for (j = 1; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *n - j + 1;
+ jb = min(i__4,i__5);
+
+/* Compute rows 1:j-1 of current block column */
+
+ i__4 = j - 1;
+ dtrmm_("Left", "Upper", "No transpose", diag, &i__4, &jb, &
+ c_b18, &a[a_offset], lda, &a[j * a_dim1 + 1], lda);
+ i__4 = j - 1;
+ dtrsm_("Right", "Upper", "No transpose", diag, &i__4, &jb, &
+ c_b22, &a[j + j * a_dim1], lda, &a[j * a_dim1 + 1],
+ lda);
+
+/* Compute inverse of current diagonal block */
+
+ dtrti2_("Upper", diag, &jb, &a[j + j * a_dim1], lda, info);
+/* L20: */
+ }
+ } else {
+
+/* Compute inverse of lower triangular matrix */
+
+ nn = (*n - 1) / nb * nb + 1;
+ i__3 = -nb;
+ for (j = nn; i__3 < 0 ? j >= 1 : j <= 1; j += i__3) {
+/* Computing MIN */
+ i__1 = nb, i__4 = *n - j + 1;
+ jb = min(i__1,i__4);
+ if (j + jb <= *n) {
+
+/* Compute rows j+jb:n of current block column */
+
+ i__1 = *n - j - jb + 1;
+ dtrmm_("Left", "Lower", "No transpose", diag, &i__1, &jb,
+ &c_b18, &a[j + jb + (j + jb) * a_dim1], lda, &a[j
+ + jb + j * a_dim1], lda);
+ i__1 = *n - j - jb + 1;
+ dtrsm_("Right", "Lower", "No transpose", diag, &i__1, &jb,
+ &c_b22, &a[j + j * a_dim1], lda, &a[j + jb + j *
+ a_dim1], lda);
+ }
+
+/* Compute inverse of current diagonal block */
+
+ dtrti2_("Lower", diag, &jb, &a[j + j * a_dim1], lda, info);
+/* L30: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DTRTRI */
+
+} /* dtrtri_ */
diff --git a/SRC/dtrtrs.c b/SRC/dtrtrs.c
new file mode 100644
index 0000000..da458c5
--- /dev/null
+++ b/SRC/dtrtrs.c
@@ -0,0 +1,183 @@
+/* dtrtrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b12 = 1.;
+
+/* Subroutine */ int dtrtrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *
+ ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), xerbla_(
+ char *, integer *);
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTRTRS solves a triangular system of the form */
+
+/* A * X = B or A**T * X = B, */
+
+/* where A is a triangular matrix of order N, and B is an N-by-NRHS */
+/* matrix. A check is made to verify that A is nonsingular. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, if INFO = 0, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element of A is zero, */
+/* indicating that the matrix is singular and the solutions */
+/* X have not been computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ nounit = lsame_(diag, "N");
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTRTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check for singularity. */
+
+ if (nounit) {
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ if (a[*info + *info * a_dim1] == 0.) {
+ return 0;
+ }
+/* L10: */
+ }
+ }
+ *info = 0;
+
+/* Solve A * x = b or A' * x = b. */
+
+ dtrsm_("Left", uplo, trans, diag, n, nrhs, &c_b12, &a[a_offset], lda, &b[
+ b_offset], ldb);
+
+ return 0;
+
+/* End of DTRTRS */
+
+} /* dtrtrs_ */
diff --git a/SRC/dtrttf.c b/SRC/dtrttf.c
new file mode 100644
index 0000000..0e1746e
--- /dev/null
+++ b/SRC/dtrttf.c
@@ -0,0 +1,489 @@
+/* dtrttf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtrttf_(char *transr, char *uplo, integer *n, doublereal
+ *a, integer *lda, doublereal *arf, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k, l, n1, n2, ij, nt, nx2, np1x2;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nisodd;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTRTTF copies a triangular matrix A from standard full format (TR) */
+/* to rectangular full packed format (TF) . */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': ARF in Normal form is wanted; */
+/* = 'T': ARF in Transpose form is wanted. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N). */
+/* On entry, the triangular matrix A. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of the array A contains */
+/* the upper triangular matrix, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of the array A contains */
+/* the lower triangular matrix, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the matrix A. LDA >= max(1,N). */
+
+/* ARF (output) DOUBLE PRECISION array, dimension (NT). */
+/* NT=N*(N+1)/2. On exit, the triangular matrix A in RFP format. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Notes */
+/* ===== */
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* even. We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* the transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* the transpose of the last three columns of AP lower. */
+/* This covers the case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 03 04 05 33 43 53 */
+/* 13 14 15 00 44 54 */
+/* 23 24 25 10 11 55 */
+/* 33 34 35 20 21 22 */
+/* 00 44 45 30 31 32 */
+/* 01 11 55 40 41 42 */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* odd. We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* the transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* the transpose of the last two columns of AP lower. */
+/* This covers the case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 02 03 04 00 33 43 */
+/* 12 13 14 10 11 44 */
+/* 22 23 24 20 21 22 */
+/* 00 33 34 30 31 32 */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+/* RFP A RFP A */
+
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* Reference */
+/* ========= */
+
+/* ===================================================================== */
+
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda - 1 - 0 + 1;
+ a_offset = 0 + a_dim1 * 0;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "T")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTRTTF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 1) {
+ if (*n == 1) {
+ arf[0] = a[0];
+ }
+ return 0;
+ }
+
+/* Size of array ARF(0:nt-1) */
+
+ nt = *n * (*n + 1) / 2;
+
+/* Set N1 and N2 depending on LOWER: for N even N1=N2=K */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. */
+/* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is */
+/* N--by--(N+1)/2. */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ if (! lower) {
+ np1x2 = *n + *n + 2;
+ }
+ } else {
+ nisodd = TRUE_;
+ if (! lower) {
+ nx2 = *n + *n;
+ }
+ }
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* N is odd, TRANSR = 'N', and UPLO = 'L' */
+
+ ij = 0;
+ i__1 = n2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = n2 + j;
+ for (i__ = n1; i__ <= i__2; ++i__) {
+ arf[ij] = a[n2 + j + i__ * a_dim1];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ arf[ij] = a[i__ + j * a_dim1];
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* N is odd, TRANSR = 'N', and UPLO = 'U' */
+
+ ij = nt - *n;
+ i__1 = n1;
+ for (j = *n - 1; j >= i__1; --j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ arf[ij] = a[i__ + j * a_dim1];
+ ++ij;
+ }
+ i__2 = n1 - 1;
+ for (l = j - n1; l <= i__2; ++l) {
+ arf[ij] = a[j - n1 + l * a_dim1];
+ ++ij;
+ }
+ ij -= nx2;
+ }
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'T' */
+
+ if (lower) {
+
+/* N is odd, TRANSR = 'T', and UPLO = 'L' */
+
+ ij = 0;
+ i__1 = n2 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ arf[ij] = a[j + i__ * a_dim1];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = n1 + j; i__ <= i__2; ++i__) {
+ arf[ij] = a[i__ + (n1 + j) * a_dim1];
+ ++ij;
+ }
+ }
+ i__1 = *n - 1;
+ for (j = n2; j <= i__1; ++j) {
+ i__2 = n1 - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ arf[ij] = a[j + i__ * a_dim1];
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* N is odd, TRANSR = 'T', and UPLO = 'U' */
+
+ ij = 0;
+ i__1 = n1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = n1; i__ <= i__2; ++i__) {
+ arf[ij] = a[j + i__ * a_dim1];
+ ++ij;
+ }
+ }
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ arf[ij] = a[i__ + j * a_dim1];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (l = n2 + j; l <= i__2; ++l) {
+ arf[ij] = a[n2 + j + l * a_dim1];
+ ++ij;
+ }
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* N is even, TRANSR = 'N', and UPLO = 'L' */
+
+ ij = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k + j;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ arf[ij] = a[k + j + i__ * a_dim1];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ arf[ij] = a[i__ + j * a_dim1];
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* N is even, TRANSR = 'N', and UPLO = 'U' */
+
+ ij = nt - *n - 1;
+ i__1 = k;
+ for (j = *n - 1; j >= i__1; --j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ arf[ij] = a[i__ + j * a_dim1];
+ ++ij;
+ }
+ i__2 = k - 1;
+ for (l = j - k; l <= i__2; ++l) {
+ arf[ij] = a[j - k + l * a_dim1];
+ ++ij;
+ }
+ ij -= np1x2;
+ }
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'T' */
+
+ if (lower) {
+
+/* N is even, TRANSR = 'T', and UPLO = 'L' */
+
+ ij = 0;
+ j = k;
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ arf[ij] = a[i__ + j * a_dim1];
+ ++ij;
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ arf[ij] = a[j + i__ * a_dim1];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = k + 1 + j; i__ <= i__2; ++i__) {
+ arf[ij] = a[i__ + (k + 1 + j) * a_dim1];
+ ++ij;
+ }
+ }
+ i__1 = *n - 1;
+ for (j = k - 1; j <= i__1; ++j) {
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ arf[ij] = a[j + i__ * a_dim1];
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* N is even, TRANSR = 'T', and UPLO = 'U' */
+
+ ij = 0;
+ i__1 = k;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ arf[ij] = a[j + i__ * a_dim1];
+ ++ij;
+ }
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ arf[ij] = a[i__ + j * a_dim1];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (l = k + 1 + j; l <= i__2; ++l) {
+ arf[ij] = a[k + 1 + j + l * a_dim1];
+ ++ij;
+ }
+ }
+/* Note that here, on exit of the loop, J = K-1 */
+ i__1 = j;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ arf[ij] = a[i__ + j * a_dim1];
+ ++ij;
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of DTRTTF */
+
+} /* dtrttf_ */
diff --git a/SRC/dtrttp.c b/SRC/dtrttp.c
new file mode 100644
index 0000000..1af49f1
--- /dev/null
+++ b/SRC/dtrttp.c
@@ -0,0 +1,144 @@
+/* dtrttp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtrttp_(char *uplo, integer *n, doublereal *a, integer *
+ lda, doublereal *ap, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- and Julien Langou of the Univ. of Colorado Denver -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTRTTP copies a triangular matrix A from full format (TR) to standard */
+/* packed format (TP). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular. */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrices AP and A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On exit, the triangular matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AP (output) DOUBLE PRECISION array, dimension (N*(N+1)/2 */
+/* On exit, the upper or lower triangular matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ lower = lsame_(uplo, "L");
+ if (! lower && ! lsame_(uplo, "U")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTRTTP", &i__1);
+ return 0;
+ }
+
+ if (lower) {
+ k = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ++k;
+ ap[k] = a[i__ + j * a_dim1];
+ }
+ }
+ } else {
+ k = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ++k;
+ ap[k] = a[i__ + j * a_dim1];
+ }
+ }
+ }
+
+
+ return 0;
+
+/* End of DTRTTP */
+
+} /* dtrttp_ */
diff --git a/SRC/dtzrqf.c b/SRC/dtzrqf.c
new file mode 100644
index 0000000..08a3e71
--- /dev/null
+++ b/SRC/dtzrqf.c
@@ -0,0 +1,221 @@
+/* dtzrqf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b8 = 1.;
+
+/* Subroutine */ int dtzrqf_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *tau, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, k, m1;
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dgemv_(char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *), dcopy_(integer *, doublereal *,
+ integer *, doublereal *, integer *), daxpy_(integer *, doublereal
+ *, doublereal *, integer *, doublereal *, integer *), dlarfp_(
+ integer *, doublereal *, doublereal *, integer *, doublereal *),
+ xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine DTZRZF. */
+
+/* DTZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A */
+/* to upper triangular form by means of orthogonal transformations. */
+
+/* The upper trapezoidal matrix A is factored as */
+
+/* A = ( R 0 ) * Z, */
+
+/* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper */
+/* triangular matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= M. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the leading M-by-N upper trapezoidal part of the */
+/* array A must contain the matrix to be factorized. */
+/* On exit, the leading M-by-M upper triangular part of A */
+/* contains the upper triangular matrix R, and elements M+1 to */
+/* N of the first M rows of A, with the array TAU, represent the */
+/* orthogonal matrix Z as a product of M elementary reflectors. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (M) */
+/* The scalar factors of the elementary reflectors. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The factorization is obtained by Householder's method. The kth */
+/* transformation matrix, Z( k ), which is used to introduce zeros into */
+/* the ( m - k + 1 )th row of A, is given in the form */
+
+/* Z( k ) = ( I 0 ), */
+/* ( 0 T( k ) ) */
+
+/* where */
+
+/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */
+/* ( 0 ) */
+/* ( z( k ) ) */
+
+/* tau is a scalar and z( k ) is an ( n - m ) element vector. */
+/* tau and z( k ) are chosen to annihilate the elements of the kth row */
+/* of X. */
+
+/* The scalar tau is returned in the kth element of TAU and the vector */
+/* u( k ) in the kth row of A, such that the elements of z( k ) are */
+/* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */
+/* the upper triangular part of A. */
+
+/* Z is given by */
+
+/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTZRQF", &i__1);
+ return 0;
+ }
+
+/* Perform the factorization. */
+
+ if (*m == 0) {
+ return 0;
+ }
+ if (*m == *n) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tau[i__] = 0.;
+/* L10: */
+ }
+ } else {
+/* Computing MIN */
+ i__1 = *m + 1;
+ m1 = min(i__1,*n);
+ for (k = *m; k >= 1; --k) {
+
+/* Use a Householder reflection to zero the kth row of A. */
+/* First set up the reflection. */
+
+ i__1 = *n - *m + 1;
+ dlarfp_(&i__1, &a[k + k * a_dim1], &a[k + m1 * a_dim1], lda, &tau[
+ k]);
+
+ if (tau[k] != 0. && k > 1) {
+
+/* We now perform the operation A := A*P( k ). */
+
+/* Use the first ( k - 1 ) elements of TAU to store a( k ), */
+/* where a( k ) consists of the first ( k - 1 ) elements of */
+/* the kth column of A. Also let B denote the first */
+/* ( k - 1 ) rows of the last ( n - m ) columns of A. */
+
+ i__1 = k - 1;
+ dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &tau[1], &c__1);
+
+/* Form w = a( k ) + B*z( k ) in TAU. */
+
+ i__1 = k - 1;
+ i__2 = *n - *m;
+ dgemv_("No transpose", &i__1, &i__2, &c_b8, &a[m1 * a_dim1 +
+ 1], lda, &a[k + m1 * a_dim1], lda, &c_b8, &tau[1], &
+ c__1);
+
+/* Now form a( k ) := a( k ) - tau*w */
+/* and B := B - tau*w*z( k )'. */
+
+ i__1 = k - 1;
+ d__1 = -tau[k];
+ daxpy_(&i__1, &d__1, &tau[1], &c__1, &a[k * a_dim1 + 1], &
+ c__1);
+ i__1 = k - 1;
+ i__2 = *n - *m;
+ d__1 = -tau[k];
+ dger_(&i__1, &i__2, &d__1, &tau[1], &c__1, &a[k + m1 * a_dim1]
+, lda, &a[m1 * a_dim1 + 1], lda);
+ }
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of DTZRQF */
+
+} /* dtzrqf_ */
diff --git a/SRC/dtzrzf.c b/SRC/dtzrzf.c
new file mode 100644
index 0000000..ee5e09e
--- /dev/null
+++ b/SRC/dtzrzf.c
@@ -0,0 +1,308 @@
+/* dtzrzf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int dtzrzf_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *tau, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+
+ /* Local variables */
+ integer i__, m1, ib, nb, ki, kk, mu, nx, iws, nbmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *), dlarzb_(
+ char *, char *, char *, char *, integer *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dlarzt_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *), dlatrz_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A */
+/* to upper triangular form by means of orthogonal transformations. */
+
+/* The upper trapezoidal matrix A is factored as */
+
+/* A = ( R 0 ) * Z, */
+
+/* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper */
+/* triangular matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= M. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the leading M-by-N upper trapezoidal part of the */
+/* array A must contain the matrix to be factorized. */
+/* On exit, the leading M-by-M upper triangular part of A */
+/* contains the upper triangular matrix R, and elements M+1 to */
+/* N of the first M rows of A, with the array TAU, represent the */
+/* orthogonal matrix Z as a product of M elementary reflectors. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (M) */
+/* The scalar factors of the elementary reflectors. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M). */
+/* For optimum performance LWORK >= M*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* The factorization is obtained by Householder's method. The kth */
+/* transformation matrix, Z( k ), which is used to introduce zeros into */
+/* the ( m - k + 1 )th row of A, is given in the form */
+
+/* Z( k ) = ( I 0 ), */
+/* ( 0 T( k ) ) */
+
+/* where */
+
+/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */
+/* ( 0 ) */
+/* ( z( k ) ) */
+
+/* tau is a scalar and z( k ) is an ( n - m ) element vector. */
+/* tau and z( k ) are chosen to annihilate the elements of the kth row */
+/* of X. */
+
+/* The scalar tau is returned in the kth element of TAU and the vector */
+/* u( k ) in the kth row of A, such that the elements of z( k ) are */
+/* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */
+/* the upper triangular part of A. */
+
+/* Z is given by */
+
+/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+
+ if (*info == 0) {
+ if (*m == 0 || *m == *n) {
+ lwkopt = 1;
+ } else {
+
+/* Determine the block size. */
+
+ nb = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = *m * nb;
+ }
+ work[1] = (doublereal) lwkopt;
+
+ if (*lwork < max(1,*m) && ! lquery) {
+ *info = -7;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DTZRZF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0) {
+ return 0;
+ } else if (*m == *n) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tau[i__] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 1;
+ iws = *m;
+ if (nb > 1 && nb < *m) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "DGERQF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *m) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *m;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "DGERQF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < *m && nx < *m) {
+
+/* Use blocked code initially. */
+/* The last kk rows are handled by the block method. */
+
+/* Computing MIN */
+ i__1 = *m + 1;
+ m1 = min(i__1,*n);
+ ki = (*m - nx - 1) / nb * nb;
+/* Computing MIN */
+ i__1 = *m, i__2 = ki + nb;
+ kk = min(i__1,i__2);
+
+ i__1 = *m - kk + 1;
+ i__2 = -nb;
+ for (i__ = *m - kk + ki + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1;
+ i__ += i__2) {
+/* Computing MIN */
+ i__3 = *m - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Compute the TZ factorization of the current block */
+/* A(i:i+ib-1,i:n) */
+
+ i__3 = *n - i__ + 1;
+ i__4 = *n - *m;
+ dlatrz_(&ib, &i__3, &i__4, &a[i__ + i__ * a_dim1], lda, &tau[i__],
+ &work[1]);
+ if (i__ > 1) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__3 = *n - *m;
+ dlarzt_("Backward", "Rowwise", &i__3, &ib, &a[i__ + m1 *
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H to A(1:i-1,i:n) from the right */
+
+ i__3 = i__ - 1;
+ i__4 = *n - i__ + 1;
+ i__5 = *n - *m;
+ dlarzb_("Right", "No transpose", "Backward", "Rowwise", &i__3,
+ &i__4, &ib, &i__5, &a[i__ + m1 * a_dim1], lda, &work[
+ 1], &ldwork, &a[i__ * a_dim1 + 1], lda, &work[ib + 1],
+ &ldwork)
+ ;
+ }
+/* L20: */
+ }
+ mu = i__ + nb - 1;
+ } else {
+ mu = *m;
+ }
+
+/* Use unblocked code to factor the last or only block */
+
+ if (mu > 0) {
+ i__2 = *n - *m;
+ dlatrz_(&mu, n, &i__2, &a[a_offset], lda, &tau[1], &work[1]);
+ }
+
+ work[1] = (doublereal) lwkopt;
+
+ return 0;
+
+/* End of DTZRZF */
+
+} /* dtzrzf_ */
diff --git a/SRC/dzsum1.c b/SRC/dzsum1.c
new file mode 100644
index 0000000..9f455e9
--- /dev/null
+++ b/SRC/dzsum1.c
@@ -0,0 +1,114 @@
+/* dzsum1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dzsum1_(integer *n, doublecomplex *cx, integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal ret_val;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+
+ /* Local variables */
+ integer i__, nincx;
+ doublereal stemp;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DZSUM1 takes the sum of the absolute values of a complex */
+/* vector and returns a double precision result. */
+
+/* Based on DZASUM from the Level 1 BLAS. */
+/* The change is to use the 'genuine' absolute value. */
+
+/* Contributed by Nick Higham for use with ZLACON. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of elements in the vector CX. */
+
+/* CX (input) COMPLEX*16 array, dimension (N) */
+/* The vector whose elements will be summed. */
+
+/* INCX (input) INTEGER */
+/* The spacing between successive values of CX. INCX > 0. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --cx;
+
+ /* Function Body */
+ ret_val = 0.;
+ stemp = 0.;
+ if (*n <= 0) {
+ return ret_val;
+ }
+ if (*incx == 1) {
+ goto L20;
+ }
+
+/* CODE FOR INCREMENT NOT EQUAL TO 1 */
+
+ nincx = *n * *incx;
+ i__1 = nincx;
+ i__2 = *incx;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+
+/* NEXT LINE MODIFIED. */
+
+ stemp += z_abs(&cx[i__]);
+/* L10: */
+ }
+ ret_val = stemp;
+ return ret_val;
+
+/* CODE FOR INCREMENT EQUAL TO 1 */
+
+L20:
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+
+/* NEXT LINE MODIFIED. */
+
+ stemp += z_abs(&cx[i__]);
+/* L30: */
+ }
+ ret_val = stemp;
+ return ret_val;
+
+/* End of DZSUM1 */
+
+} /* dzsum1_ */
diff --git a/SRC/icmax1.c b/SRC/icmax1.c
new file mode 100644
index 0000000..98f589b
--- /dev/null
+++ b/SRC/icmax1.c
@@ -0,0 +1,127 @@
+/* icmax1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer icmax1_(integer *n, complex *cx, integer *incx)
+{
+ /* System generated locals */
+ integer ret_val, i__1;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+
+ /* Local variables */
+ integer i__, ix;
+ real smax;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ICMAX1 finds the index of the element whose real part has maximum */
+/* absolute value. */
+
+/* Based on ICAMAX from Level 1 BLAS. */
+/* The change is to use the 'genuine' absolute value. */
+
+/* Contributed by Nick Higham for use with CLACON. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of elements in the vector CX. */
+
+/* CX (input) COMPLEX array, dimension (N) */
+/* The vector whose elements will be summed. */
+
+/* INCX (input) INTEGER */
+/* The spacing between successive values of CX. INCX >= 1. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+
+/* NEXT LINE IS THE ONLY MODIFICATION. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --cx;
+
+ /* Function Body */
+ ret_val = 0;
+ if (*n < 1) {
+ return ret_val;
+ }
+ ret_val = 1;
+ if (*n == 1) {
+ return ret_val;
+ }
+ if (*incx == 1) {
+ goto L30;
+ }
+
+/* CODE FOR INCREMENT NOT EQUAL TO 1 */
+
+ ix = 1;
+ smax = c_abs(&cx[1]);
+ ix += *incx;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ if (c_abs(&cx[ix]) <= smax) {
+ goto L10;
+ }
+ ret_val = i__;
+ smax = c_abs(&cx[ix]);
+L10:
+ ix += *incx;
+/* L20: */
+ }
+ return ret_val;
+
+/* CODE FOR INCREMENT EQUAL TO 1 */
+
+L30:
+ smax = c_abs(&cx[1]);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ if (c_abs(&cx[i__]) <= smax) {
+ goto L40;
+ }
+ ret_val = i__;
+ smax = c_abs(&cx[i__]);
+L40:
+ ;
+ }
+ return ret_val;
+
+/* End of ICMAX1 */
+
+} /* icmax1_ */
diff --git a/SRC/ieeeck.c b/SRC/ieeeck.c
new file mode 100644
index 0000000..3d6f0b5
--- /dev/null
+++ b/SRC/ieeeck.c
@@ -0,0 +1,166 @@
+/* ieeeck.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer ieeeck_(integer *ispec, real *zero, real *one)
+{
+ /* System generated locals */
+ integer ret_val;
+
+ /* Local variables */
+ real nan1, nan2, nan3, nan4, nan5, nan6, neginf, posinf, negzro, newzro;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* IEEECK is called from the ILAENV to verify that Infinity and */
+/* possibly NaN arithmetic is safe (i.e. will not trap). */
+
+/* Arguments */
+/* ========= */
+
+/* ISPEC (input) INTEGER */
+/* Specifies whether to test just for inifinity arithmetic */
+/* or whether to test for infinity and NaN arithmetic. */
+/* = 0: Verify infinity arithmetic only. */
+/* = 1: Verify infinity and NaN arithmetic. */
+
+/* ZERO (input) REAL */
+/* Must contain the value 0.0 */
+/* This is passed to prevent the compiler from optimizing */
+/* away this code. */
+
+/* ONE (input) REAL */
+/* Must contain the value 1.0 */
+/* This is passed to prevent the compiler from optimizing */
+/* away this code. */
+
+/* RETURN VALUE: INTEGER */
+/* = 0: Arithmetic failed to produce the correct answers */
+/* = 1: Arithmetic produced the correct answers */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+ ret_val = 1;
+
+ posinf = *one / *zero;
+ if (posinf <= *one) {
+ ret_val = 0;
+ return ret_val;
+ }
+
+ neginf = -(*one) / *zero;
+ if (neginf >= *zero) {
+ ret_val = 0;
+ return ret_val;
+ }
+
+ negzro = *one / (neginf + *one);
+ if (negzro != *zero) {
+ ret_val = 0;
+ return ret_val;
+ }
+
+ neginf = *one / negzro;
+ if (neginf >= *zero) {
+ ret_val = 0;
+ return ret_val;
+ }
+
+ newzro = negzro + *zero;
+ if (newzro != *zero) {
+ ret_val = 0;
+ return ret_val;
+ }
+
+ posinf = *one / newzro;
+ if (posinf <= *one) {
+ ret_val = 0;
+ return ret_val;
+ }
+
+ neginf *= posinf;
+ if (neginf >= *zero) {
+ ret_val = 0;
+ return ret_val;
+ }
+
+ posinf *= posinf;
+ if (posinf <= *one) {
+ ret_val = 0;
+ return ret_val;
+ }
+
+
+
+
+/* Return if we were only asked to check infinity arithmetic */
+
+ if (*ispec == 0) {
+ return ret_val;
+ }
+
+ nan1 = posinf + neginf;
+
+ nan2 = posinf / neginf;
+
+ nan3 = posinf / posinf;
+
+ nan4 = posinf * *zero;
+
+ nan5 = neginf * negzro;
+
+ nan6 = nan5 * 0.f;
+
+ if (nan1 == nan1) {
+ ret_val = 0;
+ return ret_val;
+ }
+
+ if (nan2 == nan2) {
+ ret_val = 0;
+ return ret_val;
+ }
+
+ if (nan3 == nan3) {
+ ret_val = 0;
+ return ret_val;
+ }
+
+ if (nan4 == nan4) {
+ ret_val = 0;
+ return ret_val;
+ }
+
+ if (nan5 == nan5) {
+ ret_val = 0;
+ return ret_val;
+ }
+
+ if (nan6 == nan6) {
+ ret_val = 0;
+ return ret_val;
+ }
+
+ return ret_val;
+} /* ieeeck_ */
diff --git a/SRC/ilaclc.c b/SRC/ilaclc.c
new file mode 100644
index 0000000..98a0519
--- /dev/null
+++ b/SRC/ilaclc.c
@@ -0,0 +1,94 @@
+/* ilaclc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer ilaclc_(integer *m, integer *n, complex *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, ret_val, i__1, i__2;
+
+ /* Local variables */
+ integer i__;
+
+
+/* -- LAPACK auxiliary routine (version 3.2.1) -- */
+
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ILACLC scans A for its last non-zero column. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick test for the common case where one corner is non-zero. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ if (*n == 0) {
+ ret_val = *n;
+ } else /* if(complicated condition) */ {
+ i__1 = *n * a_dim1 + 1;
+ i__2 = *m + *n * a_dim1;
+ if (a[i__1].r != 0.f || a[i__1].i != 0.f || (a[i__2].r != 0.f || a[
+ i__2].i != 0.f)) {
+ ret_val = *n;
+ } else {
+/* Now scan each column from the end, returning with the first non-zero. */
+ for (ret_val = *n; ret_val >= 1; --ret_val) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + ret_val * a_dim1;
+ if (a[i__2].r != 0.f || a[i__2].i != 0.f) {
+ return ret_val;
+ }
+ }
+ }
+ }
+ }
+ return ret_val;
+} /* ilaclc_ */
diff --git a/SRC/ilaclr.c b/SRC/ilaclr.c
new file mode 100644
index 0000000..b28e22e
--- /dev/null
+++ b/SRC/ilaclr.c
@@ -0,0 +1,96 @@
+/* ilaclr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer ilaclr_(integer *m, integer *n, complex *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, ret_val, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+
+
+/* -- LAPACK auxiliary routine (version 3.2.1) -- */
+
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ILACLR scans A for its last non-zero row. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick test for the common case where one corner is non-zero. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ if (*m == 0) {
+ ret_val = *m;
+ } else /* if(complicated condition) */ {
+ i__1 = *m + a_dim1;
+ i__2 = *m + *n * a_dim1;
+ if (a[i__1].r != 0.f || a[i__1].i != 0.f || (a[i__2].r != 0.f || a[
+ i__2].i != 0.f)) {
+ ret_val = *m;
+ } else {
+/* Scan up each column tracking the last zero row seen. */
+ ret_val = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (i__ = *m; i__ >= 1; --i__) {
+ i__2 = i__ + j * a_dim1;
+ if (a[i__2].r != 0.f || a[i__2].i != 0.f) {
+ break;
+ }
+ }
+ ret_val = max(ret_val,i__);
+ }
+ }
+ }
+ return ret_val;
+} /* ilaclr_ */
diff --git a/SRC/iladiag.c b/SRC/iladiag.c
new file mode 100644
index 0000000..07cfe63
--- /dev/null
+++ b/SRC/iladiag.c
@@ -0,0 +1,65 @@
+/* iladiag.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer iladiag_(char *diag)
+{
+ /* System generated locals */
+ integer ret_val;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* October 2008 */
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This subroutine translated from a character string specifying if a */
+/* matrix has unit diagonal or not to the relevant BLAST-specified */
+/* integer constant. */
+
+/* ILADIAG returns an INTEGER. If ILADIAG < 0, then the input is not a */
+/* character indicating a unit or non-unit diagonal. Otherwise ILADIAG */
+/* returns the constant value corresponding to DIAG. */
+
+/* Arguments */
+/* ========= */
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ if (lsame_(diag, "N")) {
+ ret_val = 131;
+ } else if (lsame_(diag, "U")) {
+ ret_val = 132;
+ } else {
+ ret_val = -1;
+ }
+ return ret_val;
+
+/* End of ILADIAG */
+
+} /* iladiag_ */
diff --git a/SRC/iladlc.c b/SRC/iladlc.c
new file mode 100644
index 0000000..a18f02e
--- /dev/null
+++ b/SRC/iladlc.c
@@ -0,0 +1,88 @@
+/* iladlc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer iladlc_(integer *m, integer *n, doublereal *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, ret_val, i__1;
+
+ /* Local variables */
+ integer i__;
+
+
+/* -- LAPACK auxiliary routine (version 3.2.1) -- */
+
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ILADLC scans A for its last non-zero column. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick test for the common case where one corner is non-zero. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ if (*n == 0) {
+ ret_val = *n;
+ } else if (a[*n * a_dim1 + 1] != 0. || a[*m + *n * a_dim1] != 0.) {
+ ret_val = *n;
+ } else {
+/* Now scan each column from the end, returning with the first non-zero. */
+ for (ret_val = *n; ret_val >= 1; --ret_val) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (a[i__ + ret_val * a_dim1] != 0.) {
+ return ret_val;
+ }
+ }
+ }
+ }
+ return ret_val;
+} /* iladlc_ */
diff --git a/SRC/iladlr.c b/SRC/iladlr.c
new file mode 100644
index 0000000..f1626e4
--- /dev/null
+++ b/SRC/iladlr.c
@@ -0,0 +1,90 @@
+/* iladlr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer iladlr_(integer *m, integer *n, doublereal *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, ret_val, i__1;
+
+ /* Local variables */
+ integer i__, j;
+
+
+/* -- LAPACK auxiliary routine (version 3.2.1) -- */
+
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ILADLR scans A for its last non-zero row. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick test for the common case where one corner is non-zero. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ if (*m == 0) {
+ ret_val = *m;
+ } else if (a[*m + a_dim1] != 0. || a[*m + *n * a_dim1] != 0.) {
+ ret_val = *m;
+ } else {
+/* Scan up each column tracking the last zero row seen. */
+ ret_val = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (i__ = *m; i__ >= 1; --i__) {
+ if (a[i__ + j * a_dim1] != 0.) {
+ break;
+ }
+ }
+ ret_val = max(ret_val,i__);
+ }
+ }
+ return ret_val;
+} /* iladlr_ */
diff --git a/SRC/ilaenv.c b/SRC/ilaenv.c
new file mode 100644
index 0000000..9565433
--- /dev/null
+++ b/SRC/ilaenv.c
@@ -0,0 +1,654 @@
+/* ilaenv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+#include "string.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b163 = 0.f;
+static real c_b164 = 1.f;
+static integer c__0 = 0;
+
+integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1,
+ integer *n2, integer *n3, integer *n4)
+{
+ /* System generated locals */
+ integer ret_val;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_cmp(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ char c1[1], c2[2], c3[3], c4[2];
+ integer ic, nb, iz, nx;
+ logical cname;
+ integer nbmin;
+ logical sname;
+ extern integer ieeeck_(integer *, real *, real *);
+ char subnam[6];
+ extern integer iparmq_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+ ftnlen name_len, opts_len;
+
+ name_len = strlen (name__);
+ opts_len = strlen (opts);
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ILAENV is called from the LAPACK routines to choose problem-dependent */
+/* parameters for the local environment. See ISPEC for a description of */
+/* the parameters. */
+
+/* ILAENV returns an INTEGER */
+/* if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC */
+/* if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value. */
+
+/* This version provides a set of parameters which should give good, */
+/* but not optimal, performance on many of the currently available */
+/* computers. Users are encouraged to modify this subroutine to set */
+/* the tuning parameters for their particular machine using the option */
+/* and problem size information in the arguments. */
+
+/* This routine will not function correctly if it is converted to all */
+/* lower case. Converting it to all upper case is allowed. */
+
+/* Arguments */
+/* ========= */
+
+/* ISPEC (input) INTEGER */
+/* Specifies the parameter to be returned as the value of */
+/* ILAENV. */
+/* = 1: the optimal blocksize; if this value is 1, an unblocked */
+/* algorithm will give the best performance. */
+/* = 2: the minimum block size for which the block routine */
+/* should be used; if the usable block size is less than */
+/* this value, an unblocked routine should be used. */
+/* = 3: the crossover point (in a block routine, for N less */
+/* than this value, an unblocked routine should be used) */
+/* = 4: the number of shifts, used in the nonsymmetric */
+/* eigenvalue routines (DEPRECATED) */
+/* = 5: the minimum column dimension for blocking to be used; */
+/* rectangular blocks must have dimension at least k by m, */
+/* where k is given by ILAENV(2,...) and m by ILAENV(5,...) */
+/* = 6: the crossover point for the SVD (when reducing an m by n */
+/* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds */
+/* this value, a QR factorization is used first to reduce */
+/* the matrix to a triangular form.) */
+/* = 7: the number of processors */
+/* = 8: the crossover point for the multishift QR method */
+/* for nonsymmetric eigenvalue problems (DEPRECATED) */
+/* = 9: maximum size of the subproblems at the bottom of the */
+/* computation tree in the divide-and-conquer algorithm */
+/* (used by xGELSD and xGESDD) */
+/* =10: ieee NaN arithmetic can be trusted not to trap */
+/* =11: infinity arithmetic can be trusted not to trap */
+/* 12 <= ISPEC <= 16: */
+/* xHSEQR or one of its subroutines, */
+/* see IPARMQ for detailed explanation */
+
+/* NAME (input) CHARACTER*(*) */
+/* The name of the calling subroutine, in either upper case or */
+/* lower case. */
+
+/* OPTS (input) CHARACTER*(*) */
+/* The character options to the subroutine NAME, concatenated */
+/* into a single character string. For example, UPLO = 'U', */
+/* TRANS = 'T', and DIAG = 'N' for a triangular routine would */
+/* be specified as OPTS = 'UTN'. */
+
+/* N1 (input) INTEGER */
+/* N2 (input) INTEGER */
+/* N3 (input) INTEGER */
+/* N4 (input) INTEGER */
+/* Problem dimensions for the subroutine NAME; these may not all */
+/* be required. */
+
+/* Further Details */
+/* =============== */
+
+/* The following conventions have been used when calling ILAENV from the */
+/* LAPACK routines: */
+/* 1) OPTS is a concatenation of all of the character options to */
+/* subroutine NAME, in the same order that they appear in the */
+/* argument list for NAME, even if they are not used in determining */
+/* the value of the parameter specified by ISPEC. */
+/* 2) The problem dimensions N1, N2, N3, N4 are specified in the order */
+/* that they appear in the argument list for NAME. N1 is used */
+/* first, N2 second, and so on, and unused problem dimensions are */
+/* passed a value of -1. */
+/* 3) The parameter value returned by ILAENV is checked for validity in */
+/* the calling subroutine. For example, ILAENV is used to retrieve */
+/* the optimal blocksize for STRTRI as follows: */
+
+/* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) */
+/* IF( NB.LE.1 ) NB = MAX( 1, N ) */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ switch (*ispec) {
+ case 1: goto L10;
+ case 2: goto L10;
+ case 3: goto L10;
+ case 4: goto L80;
+ case 5: goto L90;
+ case 6: goto L100;
+ case 7: goto L110;
+ case 8: goto L120;
+ case 9: goto L130;
+ case 10: goto L140;
+ case 11: goto L150;
+ case 12: goto L160;
+ case 13: goto L160;
+ case 14: goto L160;
+ case 15: goto L160;
+ case 16: goto L160;
+ }
+
+/* Invalid value for ISPEC */
+
+ ret_val = -1;
+ return ret_val;
+
+L10:
+
+/* Convert NAME to upper case if the first character is lower case. */
+
+ ret_val = 1;
+ s_copy(subnam, name__, (ftnlen)1, name_len);
+ ic = *(unsigned char *)subnam;
+ iz = 'Z';
+ if (iz == 90 || iz == 122) {
+
+/* ASCII character set */
+
+ if (ic >= 97 && ic <= 122) {
+ *(unsigned char *)subnam = (char) (ic - 32);
+ for (i__ = 2; i__ <= 6; ++i__) {
+ ic = *(unsigned char *)&subnam[i__ - 1];
+ if (ic >= 97 && ic <= 122) {
+ *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32);
+ }
+/* L20: */
+ }
+ }
+
+ } else if (iz == 233 || iz == 169) {
+
+/* EBCDIC character set */
+
+ if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 &&
+ ic <= 169) {
+ *(unsigned char *)subnam = (char) (ic + 64);
+ for (i__ = 2; i__ <= 6; ++i__) {
+ ic = *(unsigned char *)&subnam[i__ - 1];
+ if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >=
+ 162 && ic <= 169) {
+ *(unsigned char *)&subnam[i__ - 1] = (char) (ic + 64);
+ }
+/* L30: */
+ }
+ }
+
+ } else if (iz == 218 || iz == 250) {
+
+/* Prime machines: ASCII+128 */
+
+ if (ic >= 225 && ic <= 250) {
+ *(unsigned char *)subnam = (char) (ic - 32);
+ for (i__ = 2; i__ <= 6; ++i__) {
+ ic = *(unsigned char *)&subnam[i__ - 1];
+ if (ic >= 225 && ic <= 250) {
+ *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32);
+ }
+/* L40: */
+ }
+ }
+ }
+
+ *(unsigned char *)c1 = *(unsigned char *)subnam;
+ sname = *(unsigned char *)c1 == 'S' || *(unsigned char *)c1 == 'D';
+ cname = *(unsigned char *)c1 == 'C' || *(unsigned char *)c1 == 'Z';
+ if (! (cname || sname)) {
+ return ret_val;
+ }
+ s_copy(c2, subnam + 1, (ftnlen)1, (ftnlen)2);
+ s_copy(c3, subnam + 3, (ftnlen)1, (ftnlen)3);
+ s_copy(c4, c3 + 1, (ftnlen)1, (ftnlen)2);
+
+ switch (*ispec) {
+ case 1: goto L50;
+ case 2: goto L60;
+ case 3: goto L70;
+ }
+
+L50:
+
+/* ISPEC = 1: block size */
+
+/* In these examples, separate code is provided for setting NB for */
+/* real and complex. We assume that NB will take the same value in */
+/* single or double precision. */
+
+ nb = 1;
+
+ if (s_cmp(c2, "GE", (ftnlen)1, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "TRF", (ftnlen)1, (ftnlen)3) == 0) {
+ if (sname) {
+ nb = 64;
+ } else {
+ nb = 64;
+ }
+ } else if (s_cmp(c3, "QRF", (ftnlen)1, (ftnlen)3) == 0 || s_cmp(c3,
+ "RQF", (ftnlen)1, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)
+ 1, (ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)1, (ftnlen)3)
+ == 0) {
+ if (sname) {
+ nb = 32;
+ } else {
+ nb = 32;
+ }
+ } else if (s_cmp(c3, "HRD", (ftnlen)1, (ftnlen)3) == 0) {
+ if (sname) {
+ nb = 32;
+ } else {
+ nb = 32;
+ }
+ } else if (s_cmp(c3, "BRD", (ftnlen)1, (ftnlen)3) == 0) {
+ if (sname) {
+ nb = 32;
+ } else {
+ nb = 32;
+ }
+ } else if (s_cmp(c3, "TRI", (ftnlen)1, (ftnlen)3) == 0) {
+ if (sname) {
+ nb = 64;
+ } else {
+ nb = 64;
+ }
+ }
+ } else if (s_cmp(c2, "PO", (ftnlen)1, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "TRF", (ftnlen)1, (ftnlen)3) == 0) {
+ if (sname) {
+ nb = 64;
+ } else {
+ nb = 64;
+ }
+ }
+ } else if (s_cmp(c2, "SY", (ftnlen)1, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "TRF", (ftnlen)1, (ftnlen)3) == 0) {
+ if (sname) {
+ nb = 64;
+ } else {
+ nb = 64;
+ }
+ } else if (sname && s_cmp(c3, "TRD", (ftnlen)1, (ftnlen)3) == 0) {
+ nb = 32;
+ } else if (sname && s_cmp(c3, "GST", (ftnlen)1, (ftnlen)3) == 0) {
+ nb = 64;
+ }
+ } else if (cname && s_cmp(c2, "HE", (ftnlen)1, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "TRF", (ftnlen)1, (ftnlen)3) == 0) {
+ nb = 64;
+ } else if (s_cmp(c3, "TRD", (ftnlen)1, (ftnlen)3) == 0) {
+ nb = 32;
+ } else if (s_cmp(c3, "GST", (ftnlen)1, (ftnlen)3) == 0) {
+ nb = 64;
+ }
+ } else if (sname && s_cmp(c2, "OR", (ftnlen)1, (ftnlen)2) == 0) {
+ if (*(unsigned char *)c3 == 'G') {
+ if (s_cmp(c4, "QR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
+ (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)1, (
+ ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)1, (ftnlen)2) ==
+ 0 || s_cmp(c4, "HR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(
+ c4, "TR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+ ftnlen)1, (ftnlen)2) == 0) {
+ nb = 32;
+ }
+ } else if (*(unsigned char *)c3 == 'M') {
+ if (s_cmp(c4, "QR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
+ (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)1, (
+ ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)1, (ftnlen)2) ==
+ 0 || s_cmp(c4, "HR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(
+ c4, "TR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+ ftnlen)1, (ftnlen)2) == 0) {
+ nb = 32;
+ }
+ }
+ } else if (cname && s_cmp(c2, "UN", (ftnlen)1, (ftnlen)2) == 0) {
+ if (*(unsigned char *)c3 == 'G') {
+ if (s_cmp(c4, "QR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
+ (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)1, (
+ ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)1, (ftnlen)2) ==
+ 0 || s_cmp(c4, "HR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(
+ c4, "TR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+ ftnlen)1, (ftnlen)2) == 0) {
+ nb = 32;
+ }
+ } else if (*(unsigned char *)c3 == 'M') {
+ if (s_cmp(c4, "QR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
+ (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)1, (
+ ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)1, (ftnlen)2) ==
+ 0 || s_cmp(c4, "HR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(
+ c4, "TR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+ ftnlen)1, (ftnlen)2) == 0) {
+ nb = 32;
+ }
+ }
+ } else if (s_cmp(c2, "GB", (ftnlen)1, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "TRF", (ftnlen)1, (ftnlen)3) == 0) {
+ if (sname) {
+ if (*n4 <= 64) {
+ nb = 1;
+ } else {
+ nb = 32;
+ }
+ } else {
+ if (*n4 <= 64) {
+ nb = 1;
+ } else {
+ nb = 32;
+ }
+ }
+ }
+ } else if (s_cmp(c2, "PB", (ftnlen)1, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "TRF", (ftnlen)1, (ftnlen)3) == 0) {
+ if (sname) {
+ if (*n2 <= 64) {
+ nb = 1;
+ } else {
+ nb = 32;
+ }
+ } else {
+ if (*n2 <= 64) {
+ nb = 1;
+ } else {
+ nb = 32;
+ }
+ }
+ }
+ } else if (s_cmp(c2, "TR", (ftnlen)1, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "TRI", (ftnlen)1, (ftnlen)3) == 0) {
+ if (sname) {
+ nb = 64;
+ } else {
+ nb = 64;
+ }
+ }
+ } else if (s_cmp(c2, "LA", (ftnlen)1, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "UUM", (ftnlen)1, (ftnlen)3) == 0) {
+ if (sname) {
+ nb = 64;
+ } else {
+ nb = 64;
+ }
+ }
+ } else if (sname && s_cmp(c2, "ST", (ftnlen)1, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "EBZ", (ftnlen)1, (ftnlen)3) == 0) {
+ nb = 1;
+ }
+ }
+ ret_val = nb;
+ return ret_val;
+
+L60:
+
+/* ISPEC = 2: minimum block size */
+
+ nbmin = 2;
+ if (s_cmp(c2, "GE", (ftnlen)1, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "QRF", (ftnlen)1, (ftnlen)3) == 0 || s_cmp(c3, "RQF", (
+ ftnlen)1, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)1, (
+ ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)1, (ftnlen)3) == 0)
+ {
+ if (sname) {
+ nbmin = 2;
+ } else {
+ nbmin = 2;
+ }
+ } else if (s_cmp(c3, "HRD", (ftnlen)1, (ftnlen)3) == 0) {
+ if (sname) {
+ nbmin = 2;
+ } else {
+ nbmin = 2;
+ }
+ } else if (s_cmp(c3, "BRD", (ftnlen)1, (ftnlen)3) == 0) {
+ if (sname) {
+ nbmin = 2;
+ } else {
+ nbmin = 2;
+ }
+ } else if (s_cmp(c3, "TRI", (ftnlen)1, (ftnlen)3) == 0) {
+ if (sname) {
+ nbmin = 2;
+ } else {
+ nbmin = 2;
+ }
+ }
+ } else if (s_cmp(c2, "SY", (ftnlen)1, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "TRF", (ftnlen)1, (ftnlen)3) == 0) {
+ if (sname) {
+ nbmin = 8;
+ } else {
+ nbmin = 8;
+ }
+ } else if (sname && s_cmp(c3, "TRD", (ftnlen)1, (ftnlen)3) == 0) {
+ nbmin = 2;
+ }
+ } else if (cname && s_cmp(c2, "HE", (ftnlen)1, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "TRD", (ftnlen)1, (ftnlen)3) == 0) {
+ nbmin = 2;
+ }
+ } else if (sname && s_cmp(c2, "OR", (ftnlen)1, (ftnlen)2) == 0) {
+ if (*(unsigned char *)c3 == 'G') {
+ if (s_cmp(c4, "QR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
+ (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)1, (
+ ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)1, (ftnlen)2) ==
+ 0 || s_cmp(c4, "HR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(
+ c4, "TR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+ ftnlen)1, (ftnlen)2) == 0) {
+ nbmin = 2;
+ }
+ } else if (*(unsigned char *)c3 == 'M') {
+ if (s_cmp(c4, "QR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
+ (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)1, (
+ ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)1, (ftnlen)2) ==
+ 0 || s_cmp(c4, "HR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(
+ c4, "TR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+ ftnlen)1, (ftnlen)2) == 0) {
+ nbmin = 2;
+ }
+ }
+ } else if (cname && s_cmp(c2, "UN", (ftnlen)1, (ftnlen)2) == 0) {
+ if (*(unsigned char *)c3 == 'G') {
+ if (s_cmp(c4, "QR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
+ (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)1, (
+ ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)1, (ftnlen)2) ==
+ 0 || s_cmp(c4, "HR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(
+ c4, "TR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+ ftnlen)1, (ftnlen)2) == 0) {
+ nbmin = 2;
+ }
+ } else if (*(unsigned char *)c3 == 'M') {
+ if (s_cmp(c4, "QR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
+ (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)1, (
+ ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)1, (ftnlen)2) ==
+ 0 || s_cmp(c4, "HR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(
+ c4, "TR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+ ftnlen)1, (ftnlen)2) == 0) {
+ nbmin = 2;
+ }
+ }
+ }
+ ret_val = nbmin;
+ return ret_val;
+
+L70:
+
+/* ISPEC = 3: crossover point */
+
+ nx = 0;
+ if (s_cmp(c2, "GE", (ftnlen)1, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "QRF", (ftnlen)1, (ftnlen)3) == 0 || s_cmp(c3, "RQF", (
+ ftnlen)1, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)1, (
+ ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)1, (ftnlen)3) == 0)
+ {
+ if (sname) {
+ nx = 128;
+ } else {
+ nx = 128;
+ }
+ } else if (s_cmp(c3, "HRD", (ftnlen)1, (ftnlen)3) == 0) {
+ if (sname) {
+ nx = 128;
+ } else {
+ nx = 128;
+ }
+ } else if (s_cmp(c3, "BRD", (ftnlen)1, (ftnlen)3) == 0) {
+ if (sname) {
+ nx = 128;
+ } else {
+ nx = 128;
+ }
+ }
+ } else if (s_cmp(c2, "SY", (ftnlen)1, (ftnlen)2) == 0) {
+ if (sname && s_cmp(c3, "TRD", (ftnlen)1, (ftnlen)3) == 0) {
+ nx = 32;
+ }
+ } else if (cname && s_cmp(c2, "HE", (ftnlen)1, (ftnlen)2) == 0) {
+ if (s_cmp(c3, "TRD", (ftnlen)1, (ftnlen)3) == 0) {
+ nx = 32;
+ }
+ } else if (sname && s_cmp(c2, "OR", (ftnlen)1, (ftnlen)2) == 0) {
+ if (*(unsigned char *)c3 == 'G') {
+ if (s_cmp(c4, "QR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
+ (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)1, (
+ ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)1, (ftnlen)2) ==
+ 0 || s_cmp(c4, "HR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(
+ c4, "TR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+ ftnlen)1, (ftnlen)2) == 0) {
+ nx = 128;
+ }
+ }
+ } else if (cname && s_cmp(c2, "UN", (ftnlen)1, (ftnlen)2) == 0) {
+ if (*(unsigned char *)c3 == 'G') {
+ if (s_cmp(c4, "QR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "RQ",
+ (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)1, (
+ ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)1, (ftnlen)2) ==
+ 0 || s_cmp(c4, "HR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(
+ c4, "TR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+ ftnlen)1, (ftnlen)2) == 0) {
+ nx = 128;
+ }
+ }
+ }
+ ret_val = nx;
+ return ret_val;
+
+L80:
+
+/* ISPEC = 4: number of shifts (used by xHSEQR) */
+
+ ret_val = 6;
+ return ret_val;
+
+L90:
+
+/* ISPEC = 5: minimum column dimension (not used) */
+
+ ret_val = 2;
+ return ret_val;
+
+L100:
+
+/* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) */
+
+ ret_val = (integer) ((real) min(*n1,*n2) * 1.6f);
+ return ret_val;
+
+L110:
+
+/* ISPEC = 7: number of processors (not used) */
+
+ ret_val = 1;
+ return ret_val;
+
+L120:
+
+/* ISPEC = 8: crossover point for multishift (used by xHSEQR) */
+
+ ret_val = 50;
+ return ret_val;
+
+L130:
+
+/* ISPEC = 9: maximum size of the subproblems at the bottom of the */
+/* computation tree in the divide-and-conquer algorithm */
+/* (used by xGELSD and xGESDD) */
+
+ ret_val = 25;
+ return ret_val;
+
+L140:
+
+/* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap */
+
+/* ILAENV = 0 */
+ ret_val = 1;
+ if (ret_val == 1) {
+ ret_val = ieeeck_(&c__1, &c_b163, &c_b164);
+ }
+ return ret_val;
+
+L150:
+
+/* ISPEC = 11: infinity arithmetic can be trusted not to trap */
+
+/* ILAENV = 0 */
+ ret_val = 1;
+ if (ret_val == 1) {
+ ret_val = ieeeck_(&c__0, &c_b163, &c_b164);
+ }
+ return ret_val;
+
+L160:
+
+/* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines. */
+
+ ret_val = iparmq_(ispec, name__, opts, n1, n2, n3, n4)
+ ;
+ return ret_val;
+
+/* End of ILAENV */
+
+} /* ilaenv_ */
diff --git a/SRC/ilaprec.c b/SRC/ilaprec.c
new file mode 100644
index 0000000..62b46a1
--- /dev/null
+++ b/SRC/ilaprec.c
@@ -0,0 +1,72 @@
+/* ilaprec.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer ilaprec_(char *prec)
+{
+ /* System generated locals */
+ integer ret_val;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* October 2008 */
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This subroutine translated from a character string specifying an */
+/* intermediate precision to the relevant BLAST-specified integer */
+/* constant. */
+
+/* ILAPREC returns an INTEGER. If ILAPREC < 0, then the input is not a */
+/* character indicating a supported intermediate precision. Otherwise */
+/* ILAPREC returns the constant value corresponding to PREC. */
+
+/* Arguments */
+/* ========= */
+/* PREC (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'S': Single */
+/* = 'D': Double */
+/* = 'I': Indigenous */
+/* = 'X', 'E': Extra */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ if (lsame_(prec, "S")) {
+ ret_val = 211;
+ } else if (lsame_(prec, "D")) {
+ ret_val = 212;
+ } else if (lsame_(prec, "I")) {
+ ret_val = 213;
+ } else if (lsame_(prec, "X") || lsame_(prec, "E")) {
+ ret_val = 214;
+ } else {
+ ret_val = -1;
+ }
+ return ret_val;
+
+/* End of ILAPREC */
+
+} /* ilaprec_ */
diff --git a/SRC/ilaslc.c b/SRC/ilaslc.c
new file mode 100644
index 0000000..c877084
--- /dev/null
+++ b/SRC/ilaslc.c
@@ -0,0 +1,88 @@
+/* ilaslc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer ilaslc_(integer *m, integer *n, real *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, ret_val, i__1;
+
+ /* Local variables */
+ integer i__;
+
+
+/* -- LAPACK auxiliary routine (version 3.2.1) -- */
+
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ILASLC scans A for its last non-zero column. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick test for the common case where one corner is non-zero. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ if (*n == 0) {
+ ret_val = *n;
+ } else if (a[*n * a_dim1 + 1] != 0.f || a[*m + *n * a_dim1] != 0.f) {
+ ret_val = *n;
+ } else {
+/* Now scan each column from the end, returning with the first non-zero. */
+ for (ret_val = *n; ret_val >= 1; --ret_val) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (a[i__ + ret_val * a_dim1] != 0.f) {
+ return ret_val;
+ }
+ }
+ }
+ }
+ return ret_val;
+} /* ilaslc_ */
diff --git a/SRC/ilaslr.c b/SRC/ilaslr.c
new file mode 100644
index 0000000..0aaa4a0
--- /dev/null
+++ b/SRC/ilaslr.c
@@ -0,0 +1,90 @@
+/* ilaslr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer ilaslr_(integer *m, integer *n, real *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, ret_val, i__1;
+
+ /* Local variables */
+ integer i__, j;
+
+
+/* -- LAPACK auxiliary routine (version 3.2.1) -- */
+
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ILASLR scans A for its last non-zero row. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick test for the common case where one corner is non-zero. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ if (*m == 0) {
+ ret_val = *m;
+ } else if (a[*m + a_dim1] != 0.f || a[*m + *n * a_dim1] != 0.f) {
+ ret_val = *m;
+ } else {
+/* Scan up each column tracking the last zero row seen. */
+ ret_val = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (i__ = *m; i__ >= 1; --i__) {
+ if (a[i__ + j * a_dim1] != 0.f) {
+ break;
+ }
+ }
+ ret_val = max(ret_val,i__);
+ }
+ }
+ return ret_val;
+} /* ilaslr_ */
diff --git a/SRC/ilatrans.c b/SRC/ilatrans.c
new file mode 100644
index 0000000..afad201
--- /dev/null
+++ b/SRC/ilatrans.c
@@ -0,0 +1,69 @@
+/* ilatrans.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer ilatrans_(char *trans)
+{
+ /* System generated locals */
+ integer ret_val;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* October 2008 */
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This subroutine translates from a character string specifying a */
+/* transposition operation to the relevant BLAST-specified integer */
+/* constant. */
+
+/* ILATRANS returns an INTEGER. If ILATRANS < 0, then the input is not */
+/* a character indicating a transposition operator. Otherwise ILATRANS */
+/* returns the constant value corresponding to TRANS. */
+
+/* Arguments */
+/* ========= */
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ if (lsame_(trans, "N")) {
+ ret_val = 111;
+ } else if (lsame_(trans, "T")) {
+ ret_val = 112;
+ } else if (lsame_(trans, "C")) {
+ ret_val = 113;
+ } else {
+ ret_val = -1;
+ }
+ return ret_val;
+
+/* End of ILATRANS */
+
+} /* ilatrans_ */
diff --git a/SRC/ilauplo.c b/SRC/ilauplo.c
new file mode 100644
index 0000000..3469f24
--- /dev/null
+++ b/SRC/ilauplo.c
@@ -0,0 +1,65 @@
+/* ilauplo.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer ilauplo_(char *uplo)
+{
+ /* System generated locals */
+ integer ret_val;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* October 2008 */
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This subroutine translated from a character string specifying a */
+/* upper- or lower-triangular matrix to the relevant BLAST-specified */
+/* integer constant. */
+
+/* ILAUPLO returns an INTEGER. If ILAUPLO < 0, then the input is not */
+/* a character indicating an upper- or lower-triangular matrix. */
+/* Otherwise ILAUPLO returns the constant value corresponding to UPLO. */
+
+/* Arguments */
+/* ========= */
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ if (lsame_(uplo, "U")) {
+ ret_val = 121;
+ } else if (lsame_(uplo, "L")) {
+ ret_val = 122;
+ } else {
+ ret_val = -1;
+ }
+ return ret_val;
+
+/* End of ILAUPLO */
+
+} /* ilauplo_ */
diff --git a/SRC/ilaver.c b/SRC/ilaver.c
new file mode 100644
index 0000000..50abcd2
--- /dev/null
+++ b/SRC/ilaver.c
@@ -0,0 +1,47 @@
+/* ilaver.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ilaver_(integer *vers_major__, integer *vers_minor__,
+ integer *vers_patch__)
+{
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This subroutine return the Lapack version */
+
+/* Arguments */
+/* ========= */
+/* VERS_MAJOR (output) INTEGER */
+/* return the lapack major version */
+/* VERS_MINOR (output) INTEGER */
+/* return the lapack minor version from the major version */
+/* VERS_PATCH (output) INTEGER */
+/* return the lapack patch version from the minor version */
+/* ===================================================================== */
+
+/* ===================================================================== */
+ *vers_major__ = 3;
+ *vers_minor__ = 1;
+ *vers_patch__ = 1;
+/* ===================================================================== */
+
+ return 0;
+} /* ilaver_ */
diff --git a/SRC/ilazlc.c b/SRC/ilazlc.c
new file mode 100644
index 0000000..2b20f40
--- /dev/null
+++ b/SRC/ilazlc.c
@@ -0,0 +1,94 @@
+/* ilazlc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer ilazlc_(integer *m, integer *n, doublecomplex *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, ret_val, i__1, i__2;
+
+ /* Local variables */
+ integer i__;
+
+
+/* -- LAPACK auxiliary routine (version 3.2.1) -- */
+
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ILAZLC scans A for its last non-zero column. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick test for the common case where one corner is non-zero. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ if (*n == 0) {
+ ret_val = *n;
+ } else /* if(complicated condition) */ {
+ i__1 = *n * a_dim1 + 1;
+ i__2 = *m + *n * a_dim1;
+ if (a[i__1].r != 0. || a[i__1].i != 0. || (a[i__2].r != 0. || a[i__2]
+ .i != 0.)) {
+ ret_val = *n;
+ } else {
+/* Now scan each column from the end, returning with the first non-zero. */
+ for (ret_val = *n; ret_val >= 1; --ret_val) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + ret_val * a_dim1;
+ if (a[i__2].r != 0. || a[i__2].i != 0.) {
+ return ret_val;
+ }
+ }
+ }
+ }
+ }
+ return ret_val;
+} /* ilazlc_ */
diff --git a/SRC/ilazlr.c b/SRC/ilazlr.c
new file mode 100644
index 0000000..373d077
--- /dev/null
+++ b/SRC/ilazlr.c
@@ -0,0 +1,96 @@
+/* ilazlr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer ilazlr_(integer *m, integer *n, doublecomplex *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, ret_val, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+
+
+/* -- LAPACK auxiliary routine (version 3.2.1) -- */
+
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ILAZLR scans A for its last non-zero row. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick test for the common case where one corner is non-zero. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ if (*m == 0) {
+ ret_val = *m;
+ } else /* if(complicated condition) */ {
+ i__1 = *m + a_dim1;
+ i__2 = *m + *n * a_dim1;
+ if (a[i__1].r != 0. || a[i__1].i != 0. || (a[i__2].r != 0. || a[i__2]
+ .i != 0.)) {
+ ret_val = *m;
+ } else {
+/* Scan up each column tracking the last zero row seen. */
+ ret_val = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (i__ = *m; i__ >= 1; --i__) {
+ i__2 = i__ + j * a_dim1;
+ if (a[i__2].r != 0. || a[i__2].i != 0.) {
+ break;
+ }
+ }
+ ret_val = max(ret_val,i__);
+ }
+ }
+ }
+ return ret_val;
+} /* ilazlr_ */
diff --git a/SRC/iparmq.c b/SRC/iparmq.c
new file mode 100644
index 0000000..13fb9aa
--- /dev/null
+++ b/SRC/iparmq.c
@@ -0,0 +1,282 @@
+/* iparmq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer iparmq_(integer *ispec, char *name__, char *opts, integer *n, integer
+ *ilo, integer *ihi, integer *lwork)
+{
+ /* System generated locals */
+ integer ret_val, i__1, i__2;
+ real r__1;
+
+ /* Builtin functions */
+ double log(doublereal);
+ integer i_nint(real *);
+
+ /* Local variables */
+ integer nh, ns;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+
+/* Purpose */
+/* ======= */
+
+/* This program sets problem and machine dependent parameters */
+/* useful for xHSEQR and its subroutines. It is called whenever */
+/* ILAENV is called with 12 <= ISPEC <= 16 */
+
+/* Arguments */
+/* ========= */
+
+/* ISPEC (input) integer scalar */
+/* ISPEC specifies which tunable parameter IPARMQ should */
+/* return. */
+
+/* ISPEC=12: (INMIN) Matrices of order nmin or less */
+/* are sent directly to xLAHQR, the implicit */
+/* double shift QR algorithm. NMIN must be */
+/* at least 11. */
+
+/* ISPEC=13: (INWIN) Size of the deflation window. */
+/* This is best set greater than or equal to */
+/* the number of simultaneous shifts NS. */
+/* Larger matrices benefit from larger deflation */
+/* windows. */
+
+/* ISPEC=14: (INIBL) Determines when to stop nibbling and */
+/* invest in an (expensive) multi-shift QR sweep. */
+/* If the aggressive early deflation subroutine */
+/* finds LD converged eigenvalues from an order */
+/* NW deflation window and LD.GT.(NW*NIBBLE)/100, */
+/* then the next QR sweep is skipped and early */
+/* deflation is applied immediately to the */
+/* remaining active diagonal block. Setting */
+/* IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a */
+/* multi-shift QR sweep whenever early deflation */
+/* finds a converged eigenvalue. Setting */
+/* IPARMQ(ISPEC=14) greater than or equal to 100 */
+/* prevents TTQRE from skipping a multi-shift */
+/* QR sweep. */
+
+/* ISPEC=15: (NSHFTS) The number of simultaneous shifts in */
+/* a multi-shift QR iteration. */
+
+/* ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the */
+/* following meanings. */
+/* 0: During the multi-shift QR sweep, */
+/* xLAQR5 does not accumulate reflections and */
+/* does not use matrix-matrix multiply to */
+/* update the far-from-diagonal matrix */
+/* entries. */
+/* 1: During the multi-shift QR sweep, */
+/* xLAQR5 and/or xLAQRaccumulates reflections and uses */
+/* matrix-matrix multiply to update the */
+/* far-from-diagonal matrix entries. */
+/* 2: During the multi-shift QR sweep. */
+/* xLAQR5 accumulates reflections and takes */
+/* advantage of 2-by-2 block structure during */
+/* matrix-matrix multiplies. */
+/* (If xTRMM is slower than xGEMM, then */
+/* IPARMQ(ISPEC=16)=1 may be more efficient than */
+/* IPARMQ(ISPEC=16)=2 despite the greater level of */
+/* arithmetic work implied by the latter choice.) */
+
+/* NAME (input) character string */
+/* Name of the calling subroutine */
+
+/* OPTS (input) character string */
+/* This is a concatenation of the string arguments to */
+/* TTQRE. */
+
+/* N (input) integer scalar */
+/* N is the order of the Hessenberg matrix H. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that H is already upper triangular */
+/* in rows and columns 1:ILO-1 and IHI+1:N. */
+
+/* LWORK (input) integer scalar */
+/* The amount of workspace available. */
+
+/* Further Details */
+/* =============== */
+
+/* Little is known about how best to choose these parameters. */
+/* It is possible to use different values of the parameters */
+/* for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. */
+
+/* It is probably best to choose different parameters for */
+/* different matrices and different parameters at different */
+/* times during the iteration, but this has not been */
+/* implemented --- yet. */
+
+
+/* The best choices of most of the parameters depend */
+/* in an ill-understood way on the relative execution */
+/* rate of xLAQR3 and xLAQR5 and on the nature of each */
+/* particular eigenvalue problem. Experiment may be the */
+/* only practical way to determine which choices are most */
+/* effective. */
+
+/* Following is a list of default values supplied by IPARMQ. */
+/* These defaults may be adjusted in order to attain better */
+/* performance in any particular computational environment. */
+
+/* IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. */
+/* Default: 75. (Must be at least 11.) */
+
+/* IPARMQ(ISPEC=13) Recommended deflation window size. */
+/* This depends on ILO, IHI and NS, the */
+/* number of simultaneous shifts returned */
+/* by IPARMQ(ISPEC=15). The default for */
+/* (IHI-ILO+1).LE.500 is NS. The default */
+/* for (IHI-ILO+1).GT.500 is 3*NS/2. */
+
+/* IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. */
+
+/* IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. */
+/* a multi-shift QR iteration. */
+
+/* If IHI-ILO+1 is ... */
+
+/* greater than ...but less ... the */
+/* or equal to ... than default is */
+
+/* 0 30 NS = 2+ */
+/* 30 60 NS = 4+ */
+/* 60 150 NS = 10 */
+/* 150 590 NS = ** */
+/* 590 3000 NS = 64 */
+/* 3000 6000 NS = 128 */
+/* 6000 infinity NS = 256 */
+
+/* (+) By default matrices of this order are */
+/* passed to the implicit double shift routine */
+/* xLAHQR. See IPARMQ(ISPEC=12) above. These */
+/* values of NS are used only in case of a rare */
+/* xLAHQR failure. */
+
+/* (**) The asterisks (**) indicate an ad-hoc */
+/* function increasing from 10 to 64. */
+
+/* IPARMQ(ISPEC=16) Select structured matrix multiply. */
+/* (See ISPEC=16 above for details.) */
+/* Default: 3. */
+
+/* ================================================================ */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ if (*ispec == 15 || *ispec == 13 || *ispec == 16) {
+
+/* ==== Set the number simultaneous shifts ==== */
+
+ nh = *ihi - *ilo + 1;
+ ns = 2;
+ if (nh >= 30) {
+ ns = 4;
+ }
+ if (nh >= 60) {
+ ns = 10;
+ }
+ if (nh >= 150) {
+/* Computing MAX */
+ r__1 = log((real) nh) / log(2.f);
+ i__1 = 10, i__2 = nh / i_nint(&r__1);
+ ns = max(i__1,i__2);
+ }
+ if (nh >= 590) {
+ ns = 64;
+ }
+ if (nh >= 3000) {
+ ns = 128;
+ }
+ if (nh >= 6000) {
+ ns = 256;
+ }
+/* Computing MAX */
+ i__1 = 2, i__2 = ns - ns % 2;
+ ns = max(i__1,i__2);
+ }
+
+ if (*ispec == 12) {
+
+
+/* ===== Matrices of order smaller than NMIN get sent */
+/* . to xLAHQR, the classic double shift algorithm. */
+/* . This must be at least 11. ==== */
+
+ ret_val = 75;
+
+ } else if (*ispec == 14) {
+
+/* ==== INIBL: skip a multi-shift qr iteration and */
+/* . whenever aggressive early deflation finds */
+/* . at least (NIBBLE*(window size)/100) deflations. ==== */
+
+ ret_val = 14;
+
+ } else if (*ispec == 15) {
+
+/* ==== NSHFTS: The number of simultaneous shifts ===== */
+
+ ret_val = ns;
+
+ } else if (*ispec == 13) {
+
+/* ==== NW: deflation window size. ==== */
+
+ if (nh <= 500) {
+ ret_val = ns;
+ } else {
+ ret_val = ns * 3 / 2;
+ }
+
+ } else if (*ispec == 16) {
+
+/* ==== IACC22: Whether to accumulate reflections */
+/* . before updating the far-from-diagonal elements */
+/* . and whether to use 2-by-2 block structure while */
+/* . doing it. A small amount of work could be saved */
+/* . by making this choice dependent also upon the */
+/* . NH=IHI-ILO+1. */
+
+ ret_val = 0;
+ if (ns >= 14) {
+ ret_val = 1;
+ }
+ if (ns >= 14) {
+ ret_val = 2;
+ }
+
+ } else {
+/* ===== invalid value of ispec ===== */
+ ret_val = -1;
+
+ }
+
+/* ==== End of IPARMQ ==== */
+
+ return ret_val;
+} /* iparmq_ */
diff --git a/SRC/izmax1.c b/SRC/izmax1.c
new file mode 100644
index 0000000..5545069
--- /dev/null
+++ b/SRC/izmax1.c
@@ -0,0 +1,127 @@
+/* izmax1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer izmax1_(integer *n, doublecomplex *cx, integer *incx)
+{
+ /* System generated locals */
+ integer ret_val, i__1;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+
+ /* Local variables */
+ integer i__, ix;
+ doublereal smax;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* IZMAX1 finds the index of the element whose real part has maximum */
+/* absolute value. */
+
+/* Based on IZAMAX from Level 1 BLAS. */
+/* The change is to use the 'genuine' absolute value. */
+
+/* Contributed by Nick Higham for use with ZLACON. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of elements in the vector CX. */
+
+/* CX (input) COMPLEX*16 array, dimension (N) */
+/* The vector whose elements will be summed. */
+
+/* INCX (input) INTEGER */
+/* The spacing between successive values of CX. INCX >= 1. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+
+/* NEXT LINE IS THE ONLY MODIFICATION. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --cx;
+
+ /* Function Body */
+ ret_val = 0;
+ if (*n < 1) {
+ return ret_val;
+ }
+ ret_val = 1;
+ if (*n == 1) {
+ return ret_val;
+ }
+ if (*incx == 1) {
+ goto L30;
+ }
+
+/* CODE FOR INCREMENT NOT EQUAL TO 1 */
+
+ ix = 1;
+ smax = z_abs(&cx[1]);
+ ix += *incx;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ if (z_abs(&cx[ix]) <= smax) {
+ goto L10;
+ }
+ ret_val = i__;
+ smax = z_abs(&cx[ix]);
+L10:
+ ix += *incx;
+/* L20: */
+ }
+ return ret_val;
+
+/* CODE FOR INCREMENT EQUAL TO 1 */
+
+L30:
+ smax = z_abs(&cx[1]);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ if (z_abs(&cx[i__]) <= smax) {
+ goto L40;
+ }
+ ret_val = i__;
+ smax = z_abs(&cx[i__]);
+L40:
+ ;
+ }
+ return ret_val;
+
+/* End of IZMAX1 */
+
+} /* izmax1_ */
diff --git a/SRC/lsamen.c b/SRC/lsamen.c
new file mode 100644
index 0000000..7411199
--- /dev/null
+++ b/SRC/lsamen.c
@@ -0,0 +1,98 @@
+/* lsamen.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+#include "string.h"
+
+logical lsamen_(integer *n, char *ca, char *cb)
+{
+ /* System generated locals */
+ integer i__1;
+ logical ret_val;
+
+ /* Builtin functions */
+ integer i_len(char *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ extern logical lsame_(char *, char *);
+
+ ftnlen ca_len, cb_len;
+
+ ca_len = strlen (ca);
+ cb_len = strlen (cb);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* LSAMEN tests if the first N letters of CA are the same as the */
+/* first N letters of CB, regardless of case. */
+/* LSAMEN returns .TRUE. if CA and CB are equivalent except for case */
+/* and .FALSE. otherwise. LSAMEN also returns .FALSE. if LEN( CA ) */
+/* or LEN( CB ) is less than N. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of characters in CA and CB to be compared. */
+
+/* CA (input) CHARACTER*(*) */
+/* CB (input) CHARACTER*(*) */
+/* CA and CB specify two character strings of length at least N. */
+/* Only the first N characters of each string will be accessed. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ ret_val = FALSE_;
+ if (i_len(ca, ca_len) < *n || i_len(cb, cb_len) < *n) {
+ goto L20;
+ }
+
+/* Do for each character in the two strings. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Test if the characters are equal using LSAME. */
+
+ if (! lsame_(ca + (i__ - 1), cb + (i__ - 1))) {
+ goto L20;
+ }
+
+/* L10: */
+ }
+ ret_val = TRUE_;
+
+L20:
+ return ret_val;
+
+/* End of LSAMEN */
+
+} /* lsamen_ */
diff --git a/SRC/maxloc.c b/SRC/maxloc.c
new file mode 100644
index 0000000..7f21d9c
--- /dev/null
+++ b/SRC/maxloc.c
@@ -0,0 +1,71 @@
+/* maxloc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+
+/* ********************************************************************************** */
+integer smaxloc_(real *a, integer *dimm)
+{
+ /* System generated locals */
+ integer ret_val, i__1;
+
+ /* Local variables */
+ integer i__;
+ real smax;
+
+
+
+ /* Parameter adjustments */
+ --a;
+
+ /* Function Body */
+ ret_val = 1;
+ smax = a[1];
+ i__1 = *dimm;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ if (smax < a[i__]) {
+ smax = a[i__];
+ ret_val = i__;
+ }
+/* L10: */
+ }
+ return ret_val;
+} /* smaxloc_ */
+
+/* ********************************************************************************** */
+integer dmaxloc_(doublereal *a, integer *dimm)
+{
+ /* System generated locals */
+ integer ret_val, i__1;
+
+ /* Local variables */
+ integer i__;
+ doublereal dmax__;
+
+
+
+ /* Parameter adjustments */
+ --a;
+
+ /* Function Body */
+ ret_val = 1;
+ dmax__ = a[1];
+ i__1 = *dimm;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ if (dmax__ < a[i__]) {
+ dmax__ = a[i__];
+ ret_val = i__;
+ }
+/* L20: */
+ }
+ return ret_val;
+} /* dmaxloc_ */
diff --git a/SRC/sbdsdc.c b/SRC/sbdsdc.c
new file mode 100644
index 0000000..0794f6d
--- /dev/null
+++ b/SRC/sbdsdc.c
@@ -0,0 +1,511 @@
+/* sbdsdc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__9 = 9;
+static integer c__0 = 0;
+static real c_b15 = 1.f;
+static integer c__1 = 1;
+static real c_b29 = 0.f;
+
+/* Subroutine */ int sbdsdc_(char *uplo, char *compq, integer *n, real *d__,
+ real *e, real *u, integer *ldu, real *vt, integer *ldvt, real *q,
+ integer *iq, real *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2;
+ real r__1;
+
+ /* Builtin functions */
+ double r_sign(real *, real *), log(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ real p, r__;
+ integer z__, ic, ii, kk;
+ real cs;
+ integer is, iu;
+ real sn;
+ integer nm1;
+ real eps;
+ integer ivt, difl, difr, ierr, perm, mlvl, sqre;
+ extern logical lsame_(char *, char *);
+ integer poles;
+ extern /* Subroutine */ int slasr_(char *, char *, char *, integer *,
+ integer *, real *, real *, real *, integer *);
+ integer iuplo, nsize, start;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), sswap_(integer *, real *, integer *, real *, integer *
+), slasd0_(integer *, integer *, real *, real *, real *, integer *
+, real *, integer *, integer *, integer *, real *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int slasda_(integer *, integer *, integer *,
+ integer *, real *, real *, real *, integer *, real *, integer *,
+ real *, real *, real *, real *, integer *, integer *, integer *,
+ integer *, real *, real *, real *, real *, integer *, integer *),
+ xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *);
+ integer givcol;
+ extern /* Subroutine */ int slasdq_(char *, integer *, integer *, integer
+ *, integer *, integer *, real *, real *, real *, integer *, real *
+, integer *, real *, integer *, real *, integer *);
+ integer icompq;
+ extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *), slartg_(real *, real *, real *
+, real *, real *);
+ real orgnrm;
+ integer givnum;
+ extern doublereal slanst_(char *, integer *, real *, real *);
+ integer givptr, qstart, smlsiz, wstart, smlszp;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SBDSDC computes the singular value decomposition (SVD) of a real */
+/* N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT, */
+/* using a divide and conquer method, where S is a diagonal matrix */
+/* with non-negative diagonal elements (the singular values of B), and */
+/* U and VT are orthogonal matrices of left and right singular vectors, */
+/* respectively. SBDSDC can be used to compute all singular values, */
+/* and optionally, singular vectors or singular vectors in compact form. */
+
+/* This code makes very mild assumptions about floating point */
+/* arithmetic. It will work on machines with a guard digit in */
+/* add/subtract, or on those binary machines without guard digits */
+/* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */
+/* It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. See SLASD3 for details. */
+
+/* The code currently calls SLASDQ if singular values only are desired. */
+/* However, it can be slightly modified to compute singular values */
+/* using the divide and conquer method. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': B is upper bidiagonal. */
+/* = 'L': B is lower bidiagonal. */
+
+/* COMPQ (input) CHARACTER*1 */
+/* Specifies whether singular vectors are to be computed */
+/* as follows: */
+/* = 'N': Compute singular values only; */
+/* = 'P': Compute singular values and compute singular */
+/* vectors in compact form; */
+/* = 'I': Compute singular values and singular vectors. */
+
+/* N (input) INTEGER */
+/* The order of the matrix B. N >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the n diagonal elements of the bidiagonal matrix B. */
+/* On exit, if INFO=0, the singular values of B. */
+
+/* E (input/output) REAL array, dimension (N-1) */
+/* On entry, the elements of E contain the offdiagonal */
+/* elements of the bidiagonal matrix whose SVD is desired. */
+/* On exit, E has been destroyed. */
+
+/* U (output) REAL array, dimension (LDU,N) */
+/* If COMPQ = 'I', then: */
+/* On exit, if INFO = 0, U contains the left singular vectors */
+/* of the bidiagonal matrix. */
+/* For other values of COMPQ, U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= 1. */
+/* If singular vectors are desired, then LDU >= max( 1, N ). */
+
+/* VT (output) REAL array, dimension (LDVT,N) */
+/* If COMPQ = 'I', then: */
+/* On exit, if INFO = 0, VT' contains the right singular */
+/* vectors of the bidiagonal matrix. */
+/* For other values of COMPQ, VT is not referenced. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. LDVT >= 1. */
+/* If singular vectors are desired, then LDVT >= max( 1, N ). */
+
+/* Q (output) REAL array, dimension (LDQ) */
+/* If COMPQ = 'P', then: */
+/* On exit, if INFO = 0, Q and IQ contain the left */
+/* and right singular vectors in a compact form, */
+/* requiring O(N log N) space instead of 2*N**2. */
+/* In particular, Q contains all the REAL data in */
+/* LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1)))) */
+/* words of memory, where SMLSIZ is returned by ILAENV and */
+/* is equal to the maximum size of the subproblems at the */
+/* bottom of the computation tree (usually about 25). */
+/* For other values of COMPQ, Q is not referenced. */
+
+/* IQ (output) INTEGER array, dimension (LDIQ) */
+/* If COMPQ = 'P', then: */
+/* On exit, if INFO = 0, Q and IQ contain the left */
+/* and right singular vectors in a compact form, */
+/* requiring O(N log N) space instead of 2*N**2. */
+/* In particular, IQ contains all INTEGER data in */
+/* LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1)))) */
+/* words of memory, where SMLSIZ is returned by ILAENV and */
+/* is equal to the maximum size of the subproblems at the */
+/* bottom of the computation tree (usually about 25). */
+/* For other values of COMPQ, IQ is not referenced. */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)) */
+/* If COMPQ = 'N' then LWORK >= (4 * N). */
+/* If COMPQ = 'P' then LWORK >= (6 * N). */
+/* If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N). */
+
+/* IWORK (workspace) INTEGER array, dimension (8*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: The algorithm failed to compute an singular value. */
+/* The update process of divide and conquer failed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+/* ===================================================================== */
+/* Changed dimension statement in comment describing E from (N) to */
+/* (N-1). Sven, 17 Feb 05. */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --q;
+ --iq;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+ iuplo = 0;
+ if (lsame_(uplo, "U")) {
+ iuplo = 1;
+ }
+ if (lsame_(uplo, "L")) {
+ iuplo = 2;
+ }
+ if (lsame_(compq, "N")) {
+ icompq = 0;
+ } else if (lsame_(compq, "P")) {
+ icompq = 1;
+ } else if (lsame_(compq, "I")) {
+ icompq = 2;
+ } else {
+ icompq = -1;
+ }
+ if (iuplo == 0) {
+ *info = -1;
+ } else if (icompq < 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ldu < 1 || icompq == 2 && *ldu < *n) {
+ *info = -7;
+ } else if (*ldvt < 1 || icompq == 2 && *ldvt < *n) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SBDSDC", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+ smlsiz = ilaenv_(&c__9, "SBDSDC", " ", &c__0, &c__0, &c__0, &c__0);
+ if (*n == 1) {
+ if (icompq == 1) {
+ q[1] = r_sign(&c_b15, &d__[1]);
+ q[smlsiz * *n + 1] = 1.f;
+ } else if (icompq == 2) {
+ u[u_dim1 + 1] = r_sign(&c_b15, &d__[1]);
+ vt[vt_dim1 + 1] = 1.f;
+ }
+ d__[1] = dabs(d__[1]);
+ return 0;
+ }
+ nm1 = *n - 1;
+
+/* If matrix lower bidiagonal, rotate to be upper bidiagonal */
+/* by applying Givens rotations on the left */
+
+ wstart = 1;
+ qstart = 3;
+ if (icompq == 1) {
+ scopy_(n, &d__[1], &c__1, &q[1], &c__1);
+ i__1 = *n - 1;
+ scopy_(&i__1, &e[1], &c__1, &q[*n + 1], &c__1);
+ }
+ if (iuplo == 2) {
+ qstart = 5;
+ wstart = (*n << 1) - 1;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ slartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
+ d__[i__] = r__;
+ e[i__] = sn * d__[i__ + 1];
+ d__[i__ + 1] = cs * d__[i__ + 1];
+ if (icompq == 1) {
+ q[i__ + (*n << 1)] = cs;
+ q[i__ + *n * 3] = sn;
+ } else if (icompq == 2) {
+ work[i__] = cs;
+ work[nm1 + i__] = -sn;
+ }
+/* L10: */
+ }
+ }
+
+/* If ICOMPQ = 0, use SLASDQ to compute the singular values. */
+
+ if (icompq == 0) {
+ slasdq_("U", &c__0, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[
+ wstart], info);
+ goto L40;
+ }
+
+/* If N is smaller than the minimum divide size SMLSIZ, then solve */
+/* the problem with another solver. */
+
+ if (*n <= smlsiz) {
+ if (icompq == 2) {
+ slaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu);
+ slaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt);
+ slasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &vt[vt_offset]
+, ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[
+ wstart], info);
+ } else if (icompq == 1) {
+ iu = 1;
+ ivt = iu + *n;
+ slaset_("A", n, n, &c_b29, &c_b15, &q[iu + (qstart - 1) * *n], n);
+ slaset_("A", n, n, &c_b29, &c_b15, &q[ivt + (qstart - 1) * *n], n);
+ slasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &q[ivt + (
+ qstart - 1) * *n], n, &q[iu + (qstart - 1) * *n], n, &q[
+ iu + (qstart - 1) * *n], n, &work[wstart], info);
+ }
+ goto L40;
+ }
+
+ if (icompq == 2) {
+ slaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu);
+ slaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt);
+ }
+
+/* Scale. */
+
+ orgnrm = slanst_("M", n, &d__[1], &e[1]);
+ if (orgnrm == 0.f) {
+ return 0;
+ }
+ slascl_("G", &c__0, &c__0, &orgnrm, &c_b15, n, &c__1, &d__[1], n, &ierr);
+ slascl_("G", &c__0, &c__0, &orgnrm, &c_b15, &nm1, &c__1, &e[1], &nm1, &
+ ierr);
+
+ eps = slamch_("Epsilon");
+
+ mlvl = (integer) (log((real) (*n) / (real) (smlsiz + 1)) / log(2.f)) + 1;
+ smlszp = smlsiz + 1;
+
+ if (icompq == 1) {
+ iu = 1;
+ ivt = smlsiz + 1;
+ difl = ivt + smlszp;
+ difr = difl + mlvl;
+ z__ = difr + (mlvl << 1);
+ ic = z__ + mlvl;
+ is = ic + 1;
+ poles = is + 1;
+ givnum = poles + (mlvl << 1);
+
+ k = 1;
+ givptr = 2;
+ perm = 3;
+ givcol = perm + mlvl;
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((r__1 = d__[i__], dabs(r__1)) < eps) {
+ d__[i__] = r_sign(&eps, &d__[i__]);
+ }
+/* L20: */
+ }
+
+ start = 1;
+ sqre = 0;
+
+ i__1 = nm1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((r__1 = e[i__], dabs(r__1)) < eps || i__ == nm1) {
+
+/* Subproblem found. First determine its size and then */
+/* apply divide and conquer on it. */
+
+ if (i__ < nm1) {
+
+/* A subproblem with E(I) small for I < NM1. */
+
+ nsize = i__ - start + 1;
+ } else if ((r__1 = e[i__], dabs(r__1)) >= eps) {
+
+/* A subproblem with E(NM1) not too small but I = NM1. */
+
+ nsize = *n - start + 1;
+ } else {
+
+/* A subproblem with E(NM1) small. This implies an */
+/* 1-by-1 subproblem at D(N). Solve this 1-by-1 problem */
+/* first. */
+
+ nsize = i__ - start + 1;
+ if (icompq == 2) {
+ u[*n + *n * u_dim1] = r_sign(&c_b15, &d__[*n]);
+ vt[*n + *n * vt_dim1] = 1.f;
+ } else if (icompq == 1) {
+ q[*n + (qstart - 1) * *n] = r_sign(&c_b15, &d__[*n]);
+ q[*n + (smlsiz + qstart - 1) * *n] = 1.f;
+ }
+ d__[*n] = (r__1 = d__[*n], dabs(r__1));
+ }
+ if (icompq == 2) {
+ slasd0_(&nsize, &sqre, &d__[start], &e[start], &u[start +
+ start * u_dim1], ldu, &vt[start + start * vt_dim1],
+ ldvt, &smlsiz, &iwork[1], &work[wstart], info);
+ } else {
+ slasda_(&icompq, &smlsiz, &nsize, &sqre, &d__[start], &e[
+ start], &q[start + (iu + qstart - 2) * *n], n, &q[
+ start + (ivt + qstart - 2) * *n], &iq[start + k * *n],
+ &q[start + (difl + qstart - 2) * *n], &q[start + (
+ difr + qstart - 2) * *n], &q[start + (z__ + qstart -
+ 2) * *n], &q[start + (poles + qstart - 2) * *n], &iq[
+ start + givptr * *n], &iq[start + givcol * *n], n, &
+ iq[start + perm * *n], &q[start + (givnum + qstart -
+ 2) * *n], &q[start + (ic + qstart - 2) * *n], &q[
+ start + (is + qstart - 2) * *n], &work[wstart], &
+ iwork[1], info);
+ if (*info != 0) {
+ return 0;
+ }
+ }
+ start = i__ + 1;
+ }
+/* L30: */
+ }
+
+/* Unscale */
+
+ slascl_("G", &c__0, &c__0, &c_b15, &orgnrm, n, &c__1, &d__[1], n, &ierr);
+L40:
+
+/* Use Selection Sort to minimize swaps of singular vectors */
+
+ i__1 = *n;
+ for (ii = 2; ii <= i__1; ++ii) {
+ i__ = ii - 1;
+ kk = i__;
+ p = d__[i__];
+ i__2 = *n;
+ for (j = ii; j <= i__2; ++j) {
+ if (d__[j] > p) {
+ kk = j;
+ p = d__[j];
+ }
+/* L50: */
+ }
+ if (kk != i__) {
+ d__[kk] = d__[i__];
+ d__[i__] = p;
+ if (icompq == 1) {
+ iq[i__] = kk;
+ } else if (icompq == 2) {
+ sswap_(n, &u[i__ * u_dim1 + 1], &c__1, &u[kk * u_dim1 + 1], &
+ c__1);
+ sswap_(n, &vt[i__ + vt_dim1], ldvt, &vt[kk + vt_dim1], ldvt);
+ }
+ } else if (icompq == 1) {
+ iq[i__] = i__;
+ }
+/* L60: */
+ }
+
+/* If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO */
+
+ if (icompq == 1) {
+ if (iuplo == 1) {
+ iq[*n] = 1;
+ } else {
+ iq[*n] = 0;
+ }
+ }
+
+/* If B is lower bidiagonal, update U by those Givens rotations */
+/* which rotated B to be upper bidiagonal */
+
+ if (iuplo == 2 && icompq == 2) {
+ slasr_("L", "V", "B", n, n, &work[1], &work[*n], &u[u_offset], ldu);
+ }
+
+ return 0;
+
+/* End of SBDSDC */
+
+} /* sbdsdc_ */
diff --git a/SRC/sbdsqr.c b/SRC/sbdsqr.c
new file mode 100644
index 0000000..954f88c
--- /dev/null
+++ b/SRC/sbdsqr.c
@@ -0,0 +1,918 @@
+/* sbdsqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b15 = -.125;
+static integer c__1 = 1;
+static real c_b49 = 1.f;
+static real c_b72 = -1.f;
+
+/* Subroutine */ int sbdsqr_(char *uplo, integer *n, integer *ncvt, integer *
+ nru, integer *ncc, real *d__, real *e, real *vt, integer *ldvt, real *
+ u, integer *ldu, real *c__, integer *ldc, real *work, integer *info)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
+ i__2;
+ real r__1, r__2, r__3, r__4;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double pow_dd(doublereal *, doublereal *), sqrt(doublereal), r_sign(real *
+ , real *);
+
+ /* Local variables */
+ real f, g, h__;
+ integer i__, j, m;
+ real r__, cs;
+ integer ll;
+ real sn, mu;
+ integer nm1, nm12, nm13, lll;
+ real eps, sll, tol, abse;
+ integer idir;
+ real abss;
+ integer oldm;
+ real cosl;
+ integer isub, iter;
+ real unfl, sinl, cosr, smin, smax, sinr;
+ extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
+ integer *, real *, real *), slas2_(real *, real *, real *, real *,
+ real *);
+ extern logical lsame_(char *, char *);
+ real oldcs;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ integer oldll;
+ real shift, sigmn, oldsn;
+ integer maxit;
+ real sminl;
+ extern /* Subroutine */ int slasr_(char *, char *, char *, integer *,
+ integer *, real *, real *, real *, integer *);
+ real sigmx;
+ logical lower;
+ extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
+ integer *), slasq1_(integer *, real *, real *, real *, integer *),
+ slasv2_(real *, real *, real *, real *, real *, real *, real *,
+ real *, real *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real sminoa;
+ extern /* Subroutine */ int slartg_(real *, real *, real *, real *, real *
+);
+ real thresh;
+ logical rotate;
+ real tolmul;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SBDSQR computes the singular values and, optionally, the right and/or */
+/* left singular vectors from the singular value decomposition (SVD) of */
+/* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit */
+/* zero-shift QR algorithm. The SVD of B has the form */
+
+/* B = Q * S * P**T */
+
+/* where S is the diagonal matrix of singular values, Q is an orthogonal */
+/* matrix of left singular vectors, and P is an orthogonal matrix of */
+/* right singular vectors. If left singular vectors are requested, this */
+/* subroutine actually returns U*Q instead of Q, and, if right singular */
+/* vectors are requested, this subroutine returns P**T*VT instead of */
+/* P**T, for given real input matrices U and VT. When U and VT are the */
+/* orthogonal matrices that reduce a general matrix A to bidiagonal */
+/* form: A = U*B*VT, as computed by SGEBRD, then */
+
+/* A = (U*Q) * S * (P**T*VT) */
+
+/* is the SVD of A. Optionally, the subroutine may also compute Q**T*C */
+/* for a given real input matrix C. */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices With */
+/* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, */
+/* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, */
+/* no. 5, pp. 873-912, Sept 1990) and */
+/* "Accurate singular values and differential qd algorithms," by */
+/* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics */
+/* Department, University of California at Berkeley, July 1992 */
+/* for a detailed description of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': B is upper bidiagonal; */
+/* = 'L': B is lower bidiagonal. */
+
+/* N (input) INTEGER */
+/* The order of the matrix B. N >= 0. */
+
+/* NCVT (input) INTEGER */
+/* The number of columns of the matrix VT. NCVT >= 0. */
+
+/* NRU (input) INTEGER */
+/* The number of rows of the matrix U. NRU >= 0. */
+
+/* NCC (input) INTEGER */
+/* The number of columns of the matrix C. NCC >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the n diagonal elements of the bidiagonal matrix B. */
+/* On exit, if INFO=0, the singular values of B in decreasing */
+/* order. */
+
+/* E (input/output) REAL array, dimension (N-1) */
+/* On entry, the N-1 offdiagonal elements of the bidiagonal */
+/* matrix B. */
+/* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E */
+/* will contain the diagonal and superdiagonal elements of a */
+/* bidiagonal matrix orthogonally equivalent to the one given */
+/* as input. */
+
+/* VT (input/output) REAL array, dimension (LDVT, NCVT) */
+/* On entry, an N-by-NCVT matrix VT. */
+/* On exit, VT is overwritten by P**T * VT. */
+/* Not referenced if NCVT = 0. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. */
+/* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. */
+
+/* U (input/output) REAL array, dimension (LDU, N) */
+/* On entry, an NRU-by-N matrix U. */
+/* On exit, U is overwritten by U * Q. */
+/* Not referenced if NRU = 0. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,NRU). */
+
+/* C (input/output) REAL array, dimension (LDC, NCC) */
+/* On entry, an N-by-NCC matrix C. */
+/* On exit, C is overwritten by Q**T * C. */
+/* Not referenced if NCC = 0. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. */
+/* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. */
+
+/* WORK (workspace) REAL array, dimension (4*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0: */
+/* if NCVT = NRU = NCC = 0, */
+/* = 1, a split was marked by a positive value in E */
+/* = 2, current block of Z not diagonalized after 30*N */
+/* iterations (in inner while loop) */
+/* = 3, termination criterion of outer while loop not met */
+/* (program created more than N unreduced blocks) */
+/* else NCVT = NRU = NCC = 0, */
+/* the algorithm did not converge; D and E contain the */
+/* elements of a bidiagonal matrix which is orthogonally */
+/* similar to the input matrix B; if INFO = i, i */
+/* elements of E have not converged to zero. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* TOLMUL REAL, default = max(10,min(100,EPS**(-1/8))) */
+/* TOLMUL controls the convergence criterion of the QR loop. */
+/* If it is positive, TOLMUL*EPS is the desired relative */
+/* precision in the computed singular values. */
+/* If it is negative, abs(TOLMUL*EPS*sigma_max) is the */
+/* desired absolute accuracy in the computed singular */
+/* values (corresponds to relative accuracy */
+/* abs(TOLMUL*EPS) in the largest singular value. */
+/* abs(TOLMUL) should be between 1 and 1/EPS, and preferably */
+/* between 10 (for fast convergence) and .1/EPS */
+/* (for there to be some accuracy in the results). */
+/* Default is to lose at either one eighth or 2 of the */
+/* available decimal digits in each computed singular value */
+/* (whichever is smaller). */
+
+/* MAXITR INTEGER, default = 6 */
+/* MAXITR controls the maximum number of passes of the */
+/* algorithm through its inner loop. The algorithms stops */
+/* (and so fails to converge) if the number of passes */
+/* through the inner loop exceeds MAXITR*N**2. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lower = lsame_(uplo, "L");
+ if (! lsame_(uplo, "U") && ! lower) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ncvt < 0) {
+ *info = -3;
+ } else if (*nru < 0) {
+ *info = -4;
+ } else if (*ncc < 0) {
+ *info = -5;
+ } else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1,*n)) {
+ *info = -9;
+ } else if (*ldu < max(1,*nru)) {
+ *info = -11;
+ } else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1,*n)) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SBDSQR", &i__1);
+ return 0;
+ }
+ if (*n == 0) {
+ return 0;
+ }
+ if (*n == 1) {
+ goto L160;
+ }
+
+/* ROTATE is true if any singular vectors desired, false otherwise */
+
+ rotate = *ncvt > 0 || *nru > 0 || *ncc > 0;
+
+/* If no singular vectors desired, use qd algorithm */
+
+ if (! rotate) {
+ slasq1_(n, &d__[1], &e[1], &work[1], info);
+ return 0;
+ }
+
+ nm1 = *n - 1;
+ nm12 = nm1 + nm1;
+ nm13 = nm12 + nm1;
+ idir = 0;
+
+/* Get machine constants */
+
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+
+/* If matrix lower bidiagonal, rotate to be upper bidiagonal */
+/* by applying Givens rotations on the left */
+
+ if (lower) {
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ slartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
+ d__[i__] = r__;
+ e[i__] = sn * d__[i__ + 1];
+ d__[i__ + 1] = cs * d__[i__ + 1];
+ work[i__] = cs;
+ work[nm1 + i__] = sn;
+/* L10: */
+ }
+
+/* Update singular vectors if desired */
+
+ if (*nru > 0) {
+ slasr_("R", "V", "F", nru, n, &work[1], &work[*n], &u[u_offset],
+ ldu);
+ }
+ if (*ncc > 0) {
+ slasr_("L", "V", "F", n, ncc, &work[1], &work[*n], &c__[c_offset],
+ ldc);
+ }
+ }
+
+/* Compute singular values to relative accuracy TOL */
+/* (By setting TOL to be negative, algorithm will compute */
+/* singular values to absolute accuracy ABS(TOL)*norm(input matrix)) */
+
+/* Computing MAX */
+/* Computing MIN */
+ d__1 = (doublereal) eps;
+ r__3 = 100.f, r__4 = pow_dd(&d__1, &c_b15);
+ r__1 = 10.f, r__2 = dmin(r__3,r__4);
+ tolmul = dmax(r__1,r__2);
+ tol = tolmul * eps;
+
+/* Compute approximate maximum, minimum singular values */
+
+ smax = 0.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = smax, r__3 = (r__1 = d__[i__], dabs(r__1));
+ smax = dmax(r__2,r__3);
+/* L20: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = smax, r__3 = (r__1 = e[i__], dabs(r__1));
+ smax = dmax(r__2,r__3);
+/* L30: */
+ }
+ sminl = 0.f;
+ if (tol >= 0.f) {
+
+/* Relative accuracy desired */
+
+ sminoa = dabs(d__[1]);
+ if (sminoa == 0.f) {
+ goto L50;
+ }
+ mu = sminoa;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ mu = (r__2 = d__[i__], dabs(r__2)) * (mu / (mu + (r__1 = e[i__ -
+ 1], dabs(r__1))));
+ sminoa = dmin(sminoa,mu);
+ if (sminoa == 0.f) {
+ goto L50;
+ }
+/* L40: */
+ }
+L50:
+ sminoa /= sqrt((real) (*n));
+/* Computing MAX */
+ r__1 = tol * sminoa, r__2 = *n * 6 * *n * unfl;
+ thresh = dmax(r__1,r__2);
+ } else {
+
+/* Absolute accuracy desired */
+
+/* Computing MAX */
+ r__1 = dabs(tol) * smax, r__2 = *n * 6 * *n * unfl;
+ thresh = dmax(r__1,r__2);
+ }
+
+/* Prepare for main iteration loop for the singular values */
+/* (MAXIT is the maximum number of passes through the inner */
+/* loop permitted before nonconvergence signalled.) */
+
+ maxit = *n * 6 * *n;
+ iter = 0;
+ oldll = -1;
+ oldm = -1;
+
+/* M points to last element of unconverged part of matrix */
+
+ m = *n;
+
+/* Begin main iteration loop */
+
+L60:
+
+/* Check for convergence or exceeding iteration count */
+
+ if (m <= 1) {
+ goto L160;
+ }
+ if (iter > maxit) {
+ goto L200;
+ }
+
+/* Find diagonal block of matrix to work on */
+
+ if (tol < 0.f && (r__1 = d__[m], dabs(r__1)) <= thresh) {
+ d__[m] = 0.f;
+ }
+ smax = (r__1 = d__[m], dabs(r__1));
+ smin = smax;
+ i__1 = m - 1;
+ for (lll = 1; lll <= i__1; ++lll) {
+ ll = m - lll;
+ abss = (r__1 = d__[ll], dabs(r__1));
+ abse = (r__1 = e[ll], dabs(r__1));
+ if (tol < 0.f && abss <= thresh) {
+ d__[ll] = 0.f;
+ }
+ if (abse <= thresh) {
+ goto L80;
+ }
+ smin = dmin(smin,abss);
+/* Computing MAX */
+ r__1 = max(smax,abss);
+ smax = dmax(r__1,abse);
+/* L70: */
+ }
+ ll = 0;
+ goto L90;
+L80:
+ e[ll] = 0.f;
+
+/* Matrix splits since E(LL) = 0 */
+
+ if (ll == m - 1) {
+
+/* Convergence of bottom singular value, return to top of loop */
+
+ --m;
+ goto L60;
+ }
+L90:
+ ++ll;
+
+/* E(LL) through E(M-1) are nonzero, E(LL-1) is zero */
+
+ if (ll == m - 1) {
+
+/* 2 by 2 block, handle separately */
+
+ slasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr,
+ &sinl, &cosl);
+ d__[m - 1] = sigmx;
+ e[m - 1] = 0.f;
+ d__[m] = sigmn;
+
+/* Compute singular vectors, if desired */
+
+ if (*ncvt > 0) {
+ srot_(ncvt, &vt[m - 1 + vt_dim1], ldvt, &vt[m + vt_dim1], ldvt, &
+ cosr, &sinr);
+ }
+ if (*nru > 0) {
+ srot_(nru, &u[(m - 1) * u_dim1 + 1], &c__1, &u[m * u_dim1 + 1], &
+ c__1, &cosl, &sinl);
+ }
+ if (*ncc > 0) {
+ srot_(ncc, &c__[m - 1 + c_dim1], ldc, &c__[m + c_dim1], ldc, &
+ cosl, &sinl);
+ }
+ m += -2;
+ goto L60;
+ }
+
+/* If working on new submatrix, choose shift direction */
+/* (from larger end diagonal element towards smaller) */
+
+ if (ll > oldm || m < oldll) {
+ if ((r__1 = d__[ll], dabs(r__1)) >= (r__2 = d__[m], dabs(r__2))) {
+
+/* Chase bulge from top (big end) to bottom (small end) */
+
+ idir = 1;
+ } else {
+
+/* Chase bulge from bottom (big end) to top (small end) */
+
+ idir = 2;
+ }
+ }
+
+/* Apply convergence tests */
+
+ if (idir == 1) {
+
+/* Run convergence test in forward direction */
+/* First apply standard test to bottom of matrix */
+
+ if ((r__2 = e[m - 1], dabs(r__2)) <= dabs(tol) * (r__1 = d__[m], dabs(
+ r__1)) || tol < 0.f && (r__3 = e[m - 1], dabs(r__3)) <=
+ thresh) {
+ e[m - 1] = 0.f;
+ goto L60;
+ }
+
+ if (tol >= 0.f) {
+
+/* If relative accuracy desired, */
+/* apply convergence criterion forward */
+
+ mu = (r__1 = d__[ll], dabs(r__1));
+ sminl = mu;
+ i__1 = m - 1;
+ for (lll = ll; lll <= i__1; ++lll) {
+ if ((r__1 = e[lll], dabs(r__1)) <= tol * mu) {
+ e[lll] = 0.f;
+ goto L60;
+ }
+ mu = (r__2 = d__[lll + 1], dabs(r__2)) * (mu / (mu + (r__1 =
+ e[lll], dabs(r__1))));
+ sminl = dmin(sminl,mu);
+/* L100: */
+ }
+ }
+
+ } else {
+
+/* Run convergence test in backward direction */
+/* First apply standard test to top of matrix */
+
+ if ((r__2 = e[ll], dabs(r__2)) <= dabs(tol) * (r__1 = d__[ll], dabs(
+ r__1)) || tol < 0.f && (r__3 = e[ll], dabs(r__3)) <= thresh) {
+ e[ll] = 0.f;
+ goto L60;
+ }
+
+ if (tol >= 0.f) {
+
+/* If relative accuracy desired, */
+/* apply convergence criterion backward */
+
+ mu = (r__1 = d__[m], dabs(r__1));
+ sminl = mu;
+ i__1 = ll;
+ for (lll = m - 1; lll >= i__1; --lll) {
+ if ((r__1 = e[lll], dabs(r__1)) <= tol * mu) {
+ e[lll] = 0.f;
+ goto L60;
+ }
+ mu = (r__2 = d__[lll], dabs(r__2)) * (mu / (mu + (r__1 = e[
+ lll], dabs(r__1))));
+ sminl = dmin(sminl,mu);
+/* L110: */
+ }
+ }
+ }
+ oldll = ll;
+ oldm = m;
+
+/* Compute shift. First, test if shifting would ruin relative */
+/* accuracy, and if so set the shift to zero. */
+
+/* Computing MAX */
+ r__1 = eps, r__2 = tol * .01f;
+ if (tol >= 0.f && *n * tol * (sminl / smax) <= dmax(r__1,r__2)) {
+
+/* Use a zero shift to avoid loss of relative accuracy */
+
+ shift = 0.f;
+ } else {
+
+/* Compute the shift from 2-by-2 block at end of matrix */
+
+ if (idir == 1) {
+ sll = (r__1 = d__[ll], dabs(r__1));
+ slas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__);
+ } else {
+ sll = (r__1 = d__[m], dabs(r__1));
+ slas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__);
+ }
+
+/* Test if shift negligible, and if so set to zero */
+
+ if (sll > 0.f) {
+/* Computing 2nd power */
+ r__1 = shift / sll;
+ if (r__1 * r__1 < eps) {
+ shift = 0.f;
+ }
+ }
+ }
+
+/* Increment iteration count */
+
+ iter = iter + m - ll;
+
+/* If SHIFT = 0, do simplified QR iteration */
+
+ if (shift == 0.f) {
+ if (idir == 1) {
+
+/* Chase bulge from top to bottom */
+/* Save cosines and sines for later singular vector updates */
+
+ cs = 1.f;
+ oldcs = 1.f;
+ i__1 = m - 1;
+ for (i__ = ll; i__ <= i__1; ++i__) {
+ r__1 = d__[i__] * cs;
+ slartg_(&r__1, &e[i__], &cs, &sn, &r__);
+ if (i__ > ll) {
+ e[i__ - 1] = oldsn * r__;
+ }
+ r__1 = oldcs * r__;
+ r__2 = d__[i__ + 1] * sn;
+ slartg_(&r__1, &r__2, &oldcs, &oldsn, &d__[i__]);
+ work[i__ - ll + 1] = cs;
+ work[i__ - ll + 1 + nm1] = sn;
+ work[i__ - ll + 1 + nm12] = oldcs;
+ work[i__ - ll + 1 + nm13] = oldsn;
+/* L120: */
+ }
+ h__ = d__[m] * cs;
+ d__[m] = h__ * oldcs;
+ e[m - 1] = h__ * oldsn;
+
+/* Update singular vectors */
+
+ if (*ncvt > 0) {
+ i__1 = m - ll + 1;
+ slasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[
+ ll + vt_dim1], ldvt);
+ }
+ if (*nru > 0) {
+ i__1 = m - ll + 1;
+ slasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13
+ + 1], &u[ll * u_dim1 + 1], ldu);
+ }
+ if (*ncc > 0) {
+ i__1 = m - ll + 1;
+ slasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13
+ + 1], &c__[ll + c_dim1], ldc);
+ }
+
+/* Test convergence */
+
+ if ((r__1 = e[m - 1], dabs(r__1)) <= thresh) {
+ e[m - 1] = 0.f;
+ }
+
+ } else {
+
+/* Chase bulge from bottom to top */
+/* Save cosines and sines for later singular vector updates */
+
+ cs = 1.f;
+ oldcs = 1.f;
+ i__1 = ll + 1;
+ for (i__ = m; i__ >= i__1; --i__) {
+ r__1 = d__[i__] * cs;
+ slartg_(&r__1, &e[i__ - 1], &cs, &sn, &r__);
+ if (i__ < m) {
+ e[i__] = oldsn * r__;
+ }
+ r__1 = oldcs * r__;
+ r__2 = d__[i__ - 1] * sn;
+ slartg_(&r__1, &r__2, &oldcs, &oldsn, &d__[i__]);
+ work[i__ - ll] = cs;
+ work[i__ - ll + nm1] = -sn;
+ work[i__ - ll + nm12] = oldcs;
+ work[i__ - ll + nm13] = -oldsn;
+/* L130: */
+ }
+ h__ = d__[ll] * cs;
+ d__[ll] = h__ * oldcs;
+ e[ll] = h__ * oldsn;
+
+/* Update singular vectors */
+
+ if (*ncvt > 0) {
+ i__1 = m - ll + 1;
+ slasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[
+ nm13 + 1], &vt[ll + vt_dim1], ldvt);
+ }
+ if (*nru > 0) {
+ i__1 = m - ll + 1;
+ slasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll *
+ u_dim1 + 1], ldu);
+ }
+ if (*ncc > 0) {
+ i__1 = m - ll + 1;
+ slasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &c__[
+ ll + c_dim1], ldc);
+ }
+
+/* Test convergence */
+
+ if ((r__1 = e[ll], dabs(r__1)) <= thresh) {
+ e[ll] = 0.f;
+ }
+ }
+ } else {
+
+/* Use nonzero shift */
+
+ if (idir == 1) {
+
+/* Chase bulge from top to bottom */
+/* Save cosines and sines for later singular vector updates */
+
+ f = ((r__1 = d__[ll], dabs(r__1)) - shift) * (r_sign(&c_b49, &d__[
+ ll]) + shift / d__[ll]);
+ g = e[ll];
+ i__1 = m - 1;
+ for (i__ = ll; i__ <= i__1; ++i__) {
+ slartg_(&f, &g, &cosr, &sinr, &r__);
+ if (i__ > ll) {
+ e[i__ - 1] = r__;
+ }
+ f = cosr * d__[i__] + sinr * e[i__];
+ e[i__] = cosr * e[i__] - sinr * d__[i__];
+ g = sinr * d__[i__ + 1];
+ d__[i__ + 1] = cosr * d__[i__ + 1];
+ slartg_(&f, &g, &cosl, &sinl, &r__);
+ d__[i__] = r__;
+ f = cosl * e[i__] + sinl * d__[i__ + 1];
+ d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__];
+ if (i__ < m - 1) {
+ g = sinl * e[i__ + 1];
+ e[i__ + 1] = cosl * e[i__ + 1];
+ }
+ work[i__ - ll + 1] = cosr;
+ work[i__ - ll + 1 + nm1] = sinr;
+ work[i__ - ll + 1 + nm12] = cosl;
+ work[i__ - ll + 1 + nm13] = sinl;
+/* L140: */
+ }
+ e[m - 1] = f;
+
+/* Update singular vectors */
+
+ if (*ncvt > 0) {
+ i__1 = m - ll + 1;
+ slasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[
+ ll + vt_dim1], ldvt);
+ }
+ if (*nru > 0) {
+ i__1 = m - ll + 1;
+ slasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13
+ + 1], &u[ll * u_dim1 + 1], ldu);
+ }
+ if (*ncc > 0) {
+ i__1 = m - ll + 1;
+ slasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13
+ + 1], &c__[ll + c_dim1], ldc);
+ }
+
+/* Test convergence */
+
+ if ((r__1 = e[m - 1], dabs(r__1)) <= thresh) {
+ e[m - 1] = 0.f;
+ }
+
+ } else {
+
+/* Chase bulge from bottom to top */
+/* Save cosines and sines for later singular vector updates */
+
+ f = ((r__1 = d__[m], dabs(r__1)) - shift) * (r_sign(&c_b49, &d__[
+ m]) + shift / d__[m]);
+ g = e[m - 1];
+ i__1 = ll + 1;
+ for (i__ = m; i__ >= i__1; --i__) {
+ slartg_(&f, &g, &cosr, &sinr, &r__);
+ if (i__ < m) {
+ e[i__] = r__;
+ }
+ f = cosr * d__[i__] + sinr * e[i__ - 1];
+ e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__];
+ g = sinr * d__[i__ - 1];
+ d__[i__ - 1] = cosr * d__[i__ - 1];
+ slartg_(&f, &g, &cosl, &sinl, &r__);
+ d__[i__] = r__;
+ f = cosl * e[i__ - 1] + sinl * d__[i__ - 1];
+ d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1];
+ if (i__ > ll + 1) {
+ g = sinl * e[i__ - 2];
+ e[i__ - 2] = cosl * e[i__ - 2];
+ }
+ work[i__ - ll] = cosr;
+ work[i__ - ll + nm1] = -sinr;
+ work[i__ - ll + nm12] = cosl;
+ work[i__ - ll + nm13] = -sinl;
+/* L150: */
+ }
+ e[ll] = f;
+
+/* Test convergence */
+
+ if ((r__1 = e[ll], dabs(r__1)) <= thresh) {
+ e[ll] = 0.f;
+ }
+
+/* Update singular vectors if desired */
+
+ if (*ncvt > 0) {
+ i__1 = m - ll + 1;
+ slasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[
+ nm13 + 1], &vt[ll + vt_dim1], ldvt);
+ }
+ if (*nru > 0) {
+ i__1 = m - ll + 1;
+ slasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll *
+ u_dim1 + 1], ldu);
+ }
+ if (*ncc > 0) {
+ i__1 = m - ll + 1;
+ slasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &c__[
+ ll + c_dim1], ldc);
+ }
+ }
+ }
+
+/* QR iteration finished, go back and check convergence */
+
+ goto L60;
+
+/* All singular values converged, so make them positive */
+
+L160:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (d__[i__] < 0.f) {
+ d__[i__] = -d__[i__];
+
+/* Change sign of singular vectors, if desired */
+
+ if (*ncvt > 0) {
+ sscal_(ncvt, &c_b72, &vt[i__ + vt_dim1], ldvt);
+ }
+ }
+/* L170: */
+ }
+
+/* Sort the singular values into decreasing order (insertion sort on */
+/* singular values, but only one transposition per singular vector) */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Scan for smallest D(I) */
+
+ isub = 1;
+ smin = d__[1];
+ i__2 = *n + 1 - i__;
+ for (j = 2; j <= i__2; ++j) {
+ if (d__[j] <= smin) {
+ isub = j;
+ smin = d__[j];
+ }
+/* L180: */
+ }
+ if (isub != *n + 1 - i__) {
+
+/* Swap singular values and vectors */
+
+ d__[isub] = d__[*n + 1 - i__];
+ d__[*n + 1 - i__] = smin;
+ if (*ncvt > 0) {
+ sswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[*n + 1 - i__ +
+ vt_dim1], ldvt);
+ }
+ if (*nru > 0) {
+ sswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[(*n + 1 - i__) *
+ u_dim1 + 1], &c__1);
+ }
+ if (*ncc > 0) {
+ sswap_(ncc, &c__[isub + c_dim1], ldc, &c__[*n + 1 - i__ +
+ c_dim1], ldc);
+ }
+ }
+/* L190: */
+ }
+ goto L220;
+
+/* Maximum number of iterations exceeded, failure to converge */
+
+L200:
+ *info = 0;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (e[i__] != 0.f) {
+ ++(*info);
+ }
+/* L210: */
+ }
+L220:
+ return 0;
+
+/* End of SBDSQR */
+
+} /* sbdsqr_ */
diff --git a/SRC/scsum1.c b/SRC/scsum1.c
new file mode 100644
index 0000000..6fd8f1f
--- /dev/null
+++ b/SRC/scsum1.c
@@ -0,0 +1,114 @@
+/* scsum1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal scsum1_(integer *n, complex *cx, integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real ret_val;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+
+ /* Local variables */
+ integer i__, nincx;
+ real stemp;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCSUM1 takes the sum of the absolute values of a complex */
+/* vector and returns a single precision result. */
+
+/* Based on SCASUM from the Level 1 BLAS. */
+/* The change is to use the 'genuine' absolute value. */
+
+/* Contributed by Nick Higham for use with CLACON. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of elements in the vector CX. */
+
+/* CX (input) COMPLEX array, dimension (N) */
+/* The vector whose elements will be summed. */
+
+/* INCX (input) INTEGER */
+/* The spacing between successive values of CX. INCX > 0. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --cx;
+
+ /* Function Body */
+ ret_val = 0.f;
+ stemp = 0.f;
+ if (*n <= 0) {
+ return ret_val;
+ }
+ if (*incx == 1) {
+ goto L20;
+ }
+
+/* CODE FOR INCREMENT NOT EQUAL TO 1 */
+
+ nincx = *n * *incx;
+ i__1 = nincx;
+ i__2 = *incx;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+
+/* NEXT LINE MODIFIED. */
+
+ stemp += c_abs(&cx[i__]);
+/* L10: */
+ }
+ ret_val = stemp;
+ return ret_val;
+
+/* CODE FOR INCREMENT EQUAL TO 1 */
+
+L20:
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+
+/* NEXT LINE MODIFIED. */
+
+ stemp += c_abs(&cx[i__]);
+/* L30: */
+ }
+ ret_val = stemp;
+ return ret_val;
+
+/* End of SCSUM1 */
+
+} /* scsum1_ */
diff --git a/SRC/sdisna.c b/SRC/sdisna.c
new file mode 100644
index 0000000..a47cb17
--- /dev/null
+++ b/SRC/sdisna.c
@@ -0,0 +1,228 @@
+/* sdisna.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sdisna_(char *job, integer *m, integer *n, real *d__,
+ real *sep, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, k;
+ real eps;
+ logical decr, left, incr, sing, eigen;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ logical right;
+ real oldgap;
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real newgap, thresh;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDISNA computes the reciprocal condition numbers for the eigenvectors */
+/* of a real symmetric or complex Hermitian matrix or for the left or */
+/* right singular vectors of a general m-by-n matrix. The reciprocal */
+/* condition number is the 'gap' between the corresponding eigenvalue or */
+/* singular value and the nearest other one. */
+
+/* The bound on the error, measured by angle in radians, in the I-th */
+/* computed vector is given by */
+
+/* SLAMCH( 'E' ) * ( ANORM / SEP( I ) ) */
+
+/* where ANORM = 2-norm(A) = max( abs( D(j) ) ). SEP(I) is not allowed */
+/* to be smaller than SLAMCH( 'E' )*ANORM in order to limit the size of */
+/* the error bound. */
+
+/* SDISNA may also be used to compute error bounds for eigenvectors of */
+/* the generalized symmetric definite eigenproblem. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies for which problem the reciprocal condition numbers */
+/* should be computed: */
+/* = 'E': the eigenvectors of a symmetric/Hermitian matrix; */
+/* = 'L': the left singular vectors of a general matrix; */
+/* = 'R': the right singular vectors of a general matrix. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix. M >= 0. */
+
+/* N (input) INTEGER */
+/* If JOB = 'L' or 'R', the number of columns of the matrix, */
+/* in which case N >= 0. Ignored if JOB = 'E'. */
+
+/* D (input) REAL array, dimension (M) if JOB = 'E' */
+/* dimension (min(M,N)) if JOB = 'L' or 'R' */
+/* The eigenvalues (if JOB = 'E') or singular values (if JOB = */
+/* 'L' or 'R') of the matrix, in either increasing or decreasing */
+/* order. If singular values, they must be non-negative. */
+
+/* SEP (output) REAL array, dimension (M) if JOB = 'E' */
+/* dimension (min(M,N)) if JOB = 'L' or 'R' */
+/* The reciprocal condition numbers of the vectors. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --sep;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+ eigen = lsame_(job, "E");
+ left = lsame_(job, "L");
+ right = lsame_(job, "R");
+ sing = left || right;
+ if (eigen) {
+ k = *m;
+ } else if (sing) {
+ k = min(*m,*n);
+ }
+ if (! eigen && ! sing) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (k < 0) {
+ *info = -3;
+ } else {
+ incr = TRUE_;
+ decr = TRUE_;
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (incr) {
+ incr = incr && d__[i__] <= d__[i__ + 1];
+ }
+ if (decr) {
+ decr = decr && d__[i__] >= d__[i__ + 1];
+ }
+/* L10: */
+ }
+ if (sing && k > 0) {
+ if (incr) {
+ incr = incr && 0.f <= d__[1];
+ }
+ if (decr) {
+ decr = decr && d__[k] >= 0.f;
+ }
+ }
+ if (! (incr || decr)) {
+ *info = -4;
+ }
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SDISNA", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (k == 0) {
+ return 0;
+ }
+
+/* Compute reciprocal condition numbers */
+
+ if (k == 1) {
+ sep[1] = slamch_("O");
+ } else {
+ oldgap = (r__1 = d__[2] - d__[1], dabs(r__1));
+ sep[1] = oldgap;
+ i__1 = k - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ newgap = (r__1 = d__[i__ + 1] - d__[i__], dabs(r__1));
+ sep[i__] = dmin(oldgap,newgap);
+ oldgap = newgap;
+/* L20: */
+ }
+ sep[k] = oldgap;
+ }
+ if (sing) {
+ if (left && *m > *n || right && *m < *n) {
+ if (incr) {
+ sep[1] = dmin(sep[1],d__[1]);
+ }
+ if (decr) {
+/* Computing MIN */
+ r__1 = sep[k], r__2 = d__[k];
+ sep[k] = dmin(r__1,r__2);
+ }
+ }
+ }
+
+/* Ensure that reciprocal condition numbers are not less than */
+/* threshold, in order to limit the size of the error bound */
+
+ eps = slamch_("E");
+ safmin = slamch_("S");
+/* Computing MAX */
+ r__2 = dabs(d__[1]), r__3 = (r__1 = d__[k], dabs(r__1));
+ anorm = dmax(r__2,r__3);
+ if (anorm == 0.f) {
+ thresh = eps;
+ } else {
+/* Computing MAX */
+ r__1 = eps * anorm;
+ thresh = dmax(r__1,safmin);
+ }
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = sep[i__];
+ sep[i__] = dmax(r__1,thresh);
+/* L30: */
+ }
+
+ return 0;
+
+/* End of SDISNA */
+
+} /* sdisna_ */
diff --git a/SRC/sgbbrd.c b/SRC/sgbbrd.c
new file mode 100644
index 0000000..451b1be
--- /dev/null
+++ b/SRC/sgbbrd.c
@@ -0,0 +1,562 @@
+/* sgbbrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b8 = 0.f;
+static real c_b9 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int sgbbrd_(char *vect, integer *m, integer *n, integer *ncc,
+ integer *kl, integer *ku, real *ab, integer *ldab, real *d__, real *
+ e, real *q, integer *ldq, real *pt, integer *ldpt, real *c__, integer
+ *ldc, real *work, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, c_dim1, c_offset, pt_dim1, pt_offset, q_dim1,
+ q_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+
+ /* Local variables */
+ integer i__, j, l, j1, j2, kb;
+ real ra, rb, rc;
+ integer kk, ml, mn, nr, mu;
+ real rs;
+ integer kb1, ml0, mu0, klm, kun, nrt, klu1, inca;
+ extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
+ integer *, real *, real *);
+ extern logical lsame_(char *, char *);
+ logical wantb, wantc;
+ integer minmn;
+ logical wantq;
+ extern /* Subroutine */ int xerbla_(char *, integer *), slaset_(
+ char *, integer *, integer *, real *, real *, real *, integer *), slartg_(real *, real *, real *, real *, real *), slargv_(
+ integer *, real *, integer *, real *, integer *, real *, integer *
+), slartv_(integer *, real *, integer *, real *, integer *, real *
+, real *, integer *);
+ logical wantpt;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGBBRD reduces a real general m-by-n band matrix A to upper */
+/* bidiagonal form B by an orthogonal transformation: Q' * A * P = B. */
+
+/* The routine computes B, and optionally forms Q or P', or computes */
+/* Q'*C for a given matrix C. */
+
+/* Arguments */
+/* ========= */
+
+/* VECT (input) CHARACTER*1 */
+/* Specifies whether or not the matrices Q and P' are to be */
+/* formed. */
+/* = 'N': do not form Q or P'; */
+/* = 'Q': form Q only; */
+/* = 'P': form P' only; */
+/* = 'B': form both. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NCC (input) INTEGER */
+/* The number of columns of the matrix C. NCC >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals of the matrix A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals of the matrix A. KU >= 0. */
+
+/* AB (input/output) REAL array, dimension (LDAB,N) */
+/* On entry, the m-by-n band matrix A, stored in rows 1 to */
+/* KL+KU+1. The j-th column of A is stored in the j-th column of */
+/* the array AB as follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). */
+/* On exit, A is overwritten by values generated during the */
+/* reduction. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array A. LDAB >= KL+KU+1. */
+
+/* D (output) REAL array, dimension (min(M,N)) */
+/* The diagonal elements of the bidiagonal matrix B. */
+
+/* E (output) REAL array, dimension (min(M,N)-1) */
+/* The superdiagonal elements of the bidiagonal matrix B. */
+
+/* Q (output) REAL array, dimension (LDQ,M) */
+/* If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q. */
+/* If VECT = 'N' or 'P', the array Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. */
+/* LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise. */
+
+/* PT (output) REAL array, dimension (LDPT,N) */
+/* If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'. */
+/* If VECT = 'N' or 'Q', the array PT is not referenced. */
+
+/* LDPT (input) INTEGER */
+/* The leading dimension of the array PT. */
+/* LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise. */
+
+/* C (input/output) REAL array, dimension (LDC,NCC) */
+/* On entry, an m-by-ncc matrix C. */
+/* On exit, C is overwritten by Q'*C. */
+/* C is not referenced if NCC = 0. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. */
+/* LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0. */
+
+/* WORK (workspace) REAL array, dimension (2*max(M,N)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --d__;
+ --e;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ pt_dim1 = *ldpt;
+ pt_offset = 1 + pt_dim1;
+ pt -= pt_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ wantb = lsame_(vect, "B");
+ wantq = lsame_(vect, "Q") || wantb;
+ wantpt = lsame_(vect, "P") || wantb;
+ wantc = *ncc > 0;
+ klu1 = *kl + *ku + 1;
+ *info = 0;
+ if (! wantq && ! wantpt && ! lsame_(vect, "N")) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ncc < 0) {
+ *info = -4;
+ } else if (*kl < 0) {
+ *info = -5;
+ } else if (*ku < 0) {
+ *info = -6;
+ } else if (*ldab < klu1) {
+ *info = -8;
+ } else if (*ldq < 1 || wantq && *ldq < max(1,*m)) {
+ *info = -12;
+ } else if (*ldpt < 1 || wantpt && *ldpt < max(1,*n)) {
+ *info = -14;
+ } else if (*ldc < 1 || wantc && *ldc < max(1,*m)) {
+ *info = -16;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGBBRD", &i__1);
+ return 0;
+ }
+
+/* Initialize Q and P' to the unit matrix, if needed */
+
+ if (wantq) {
+ slaset_("Full", m, m, &c_b8, &c_b9, &q[q_offset], ldq);
+ }
+ if (wantpt) {
+ slaset_("Full", n, n, &c_b8, &c_b9, &pt[pt_offset], ldpt);
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ minmn = min(*m,*n);
+
+ if (*kl + *ku > 1) {
+
+/* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce */
+/* first to lower bidiagonal form and then transform to upper */
+/* bidiagonal */
+
+ if (*ku > 0) {
+ ml0 = 1;
+ mu0 = 2;
+ } else {
+ ml0 = 2;
+ mu0 = 1;
+ }
+
+/* Wherever possible, plane rotations are generated and applied in */
+/* vector operations of length NR over the index set J1:J2:KLU1. */
+
+/* The sines of the plane rotations are stored in WORK(1:max(m,n)) */
+/* and the cosines in WORK(max(m,n)+1:2*max(m,n)). */
+
+ mn = max(*m,*n);
+/* Computing MIN */
+ i__1 = *m - 1;
+ klm = min(i__1,*kl);
+/* Computing MIN */
+ i__1 = *n - 1;
+ kun = min(i__1,*ku);
+ kb = klm + kun;
+ kb1 = kb + 1;
+ inca = kb1 * *ldab;
+ nr = 0;
+ j1 = klm + 2;
+ j2 = 1 - kun;
+
+ i__1 = minmn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Reduce i-th column and i-th row of matrix to bidiagonal form */
+
+ ml = klm + 1;
+ mu = kun + 1;
+ i__2 = kb;
+ for (kk = 1; kk <= i__2; ++kk) {
+ j1 += kb;
+ j2 += kb;
+
+/* generate plane rotations to annihilate nonzero elements */
+/* which have been created below the band */
+
+ if (nr > 0) {
+ slargv_(&nr, &ab[klu1 + (j1 - klm - 1) * ab_dim1], &inca,
+ &work[j1], &kb1, &work[mn + j1], &kb1);
+ }
+
+/* apply plane rotations from the left */
+
+ i__3 = kb;
+ for (l = 1; l <= i__3; ++l) {
+ if (j2 - klm + l - 1 > *n) {
+ nrt = nr - 1;
+ } else {
+ nrt = nr;
+ }
+ if (nrt > 0) {
+ slartv_(&nrt, &ab[klu1 - l + (j1 - klm + l - 1) *
+ ab_dim1], &inca, &ab[klu1 - l + 1 + (j1 - klm
+ + l - 1) * ab_dim1], &inca, &work[mn + j1], &
+ work[j1], &kb1);
+ }
+/* L10: */
+ }
+
+ if (ml > ml0) {
+ if (ml <= *m - i__ + 1) {
+
+/* generate plane rotation to annihilate a(i+ml-1,i) */
+/* within the band, and apply rotation from the left */
+
+ slartg_(&ab[*ku + ml - 1 + i__ * ab_dim1], &ab[*ku +
+ ml + i__ * ab_dim1], &work[mn + i__ + ml - 1],
+ &work[i__ + ml - 1], &ra);
+ ab[*ku + ml - 1 + i__ * ab_dim1] = ra;
+ if (i__ < *n) {
+/* Computing MIN */
+ i__4 = *ku + ml - 2, i__5 = *n - i__;
+ i__3 = min(i__4,i__5);
+ i__6 = *ldab - 1;
+ i__7 = *ldab - 1;
+ srot_(&i__3, &ab[*ku + ml - 2 + (i__ + 1) *
+ ab_dim1], &i__6, &ab[*ku + ml - 1 + (i__
+ + 1) * ab_dim1], &i__7, &work[mn + i__ +
+ ml - 1], &work[i__ + ml - 1]);
+ }
+ }
+ ++nr;
+ j1 -= kb1;
+ }
+
+ if (wantq) {
+
+/* accumulate product of plane rotations in Q */
+
+ i__3 = j2;
+ i__4 = kb1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4)
+ {
+ srot_(m, &q[(j - 1) * q_dim1 + 1], &c__1, &q[j *
+ q_dim1 + 1], &c__1, &work[mn + j], &work[j]);
+/* L20: */
+ }
+ }
+
+ if (wantc) {
+
+/* apply plane rotations to C */
+
+ i__4 = j2;
+ i__3 = kb1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3)
+ {
+ srot_(ncc, &c__[j - 1 + c_dim1], ldc, &c__[j + c_dim1]
+, ldc, &work[mn + j], &work[j]);
+/* L30: */
+ }
+ }
+
+ if (j2 + kun > *n) {
+
+/* adjust J2 to keep within the bounds of the matrix */
+
+ --nr;
+ j2 -= kb1;
+ }
+
+ i__3 = j2;
+ i__4 = kb1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+
+/* create nonzero element a(j-1,j+ku) above the band */
+/* and store it in WORK(n+1:2*n) */
+
+ work[j + kun] = work[j] * ab[(j + kun) * ab_dim1 + 1];
+ ab[(j + kun) * ab_dim1 + 1] = work[mn + j] * ab[(j + kun)
+ * ab_dim1 + 1];
+/* L40: */
+ }
+
+/* generate plane rotations to annihilate nonzero elements */
+/* which have been generated above the band */
+
+ if (nr > 0) {
+ slargv_(&nr, &ab[(j1 + kun - 1) * ab_dim1 + 1], &inca, &
+ work[j1 + kun], &kb1, &work[mn + j1 + kun], &kb1);
+ }
+
+/* apply plane rotations from the right */
+
+ i__4 = kb;
+ for (l = 1; l <= i__4; ++l) {
+ if (j2 + l - 1 > *m) {
+ nrt = nr - 1;
+ } else {
+ nrt = nr;
+ }
+ if (nrt > 0) {
+ slartv_(&nrt, &ab[l + 1 + (j1 + kun - 1) * ab_dim1], &
+ inca, &ab[l + (j1 + kun) * ab_dim1], &inca, &
+ work[mn + j1 + kun], &work[j1 + kun], &kb1);
+ }
+/* L50: */
+ }
+
+ if (ml == ml0 && mu > mu0) {
+ if (mu <= *n - i__ + 1) {
+
+/* generate plane rotation to annihilate a(i,i+mu-1) */
+/* within the band, and apply rotation from the right */
+
+ slartg_(&ab[*ku - mu + 3 + (i__ + mu - 2) * ab_dim1],
+ &ab[*ku - mu + 2 + (i__ + mu - 1) * ab_dim1],
+ &work[mn + i__ + mu - 1], &work[i__ + mu - 1],
+ &ra);
+ ab[*ku - mu + 3 + (i__ + mu - 2) * ab_dim1] = ra;
+/* Computing MIN */
+ i__3 = *kl + mu - 2, i__5 = *m - i__;
+ i__4 = min(i__3,i__5);
+ srot_(&i__4, &ab[*ku - mu + 4 + (i__ + mu - 2) *
+ ab_dim1], &c__1, &ab[*ku - mu + 3 + (i__ + mu
+ - 1) * ab_dim1], &c__1, &work[mn + i__ + mu -
+ 1], &work[i__ + mu - 1]);
+ }
+ ++nr;
+ j1 -= kb1;
+ }
+
+ if (wantpt) {
+
+/* accumulate product of plane rotations in P' */
+
+ i__4 = j2;
+ i__3 = kb1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3)
+ {
+ srot_(n, &pt[j + kun - 1 + pt_dim1], ldpt, &pt[j +
+ kun + pt_dim1], ldpt, &work[mn + j + kun], &
+ work[j + kun]);
+/* L60: */
+ }
+ }
+
+ if (j2 + kb > *m) {
+
+/* adjust J2 to keep within the bounds of the matrix */
+
+ --nr;
+ j2 -= kb1;
+ }
+
+ i__3 = j2;
+ i__4 = kb1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+
+/* create nonzero element a(j+kl+ku,j+ku-1) below the */
+/* band and store it in WORK(1:n) */
+
+ work[j + kb] = work[j + kun] * ab[klu1 + (j + kun) *
+ ab_dim1];
+ ab[klu1 + (j + kun) * ab_dim1] = work[mn + j + kun] * ab[
+ klu1 + (j + kun) * ab_dim1];
+/* L70: */
+ }
+
+ if (ml > ml0) {
+ --ml;
+ } else {
+ --mu;
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+
+ if (*ku == 0 && *kl > 0) {
+
+/* A has been reduced to lower bidiagonal form */
+
+/* Transform lower bidiagonal form to upper bidiagonal by applying */
+/* plane rotations from the left, storing diagonal elements in D */
+/* and off-diagonal elements in E */
+
+/* Computing MIN */
+ i__2 = *m - 1;
+ i__1 = min(i__2,*n);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ slartg_(&ab[i__ * ab_dim1 + 1], &ab[i__ * ab_dim1 + 2], &rc, &rs,
+ &ra);
+ d__[i__] = ra;
+ if (i__ < *n) {
+ e[i__] = rs * ab[(i__ + 1) * ab_dim1 + 1];
+ ab[(i__ + 1) * ab_dim1 + 1] = rc * ab[(i__ + 1) * ab_dim1 + 1]
+ ;
+ }
+ if (wantq) {
+ srot_(m, &q[i__ * q_dim1 + 1], &c__1, &q[(i__ + 1) * q_dim1 +
+ 1], &c__1, &rc, &rs);
+ }
+ if (wantc) {
+ srot_(ncc, &c__[i__ + c_dim1], ldc, &c__[i__ + 1 + c_dim1],
+ ldc, &rc, &rs);
+ }
+/* L100: */
+ }
+ if (*m <= *n) {
+ d__[*m] = ab[*m * ab_dim1 + 1];
+ }
+ } else if (*ku > 0) {
+
+/* A has been reduced to upper bidiagonal form */
+
+ if (*m < *n) {
+
+/* Annihilate a(m,m+1) by applying plane rotations from the */
+/* right, storing diagonal elements in D and off-diagonal */
+/* elements in E */
+
+ rb = ab[*ku + (*m + 1) * ab_dim1];
+ for (i__ = *m; i__ >= 1; --i__) {
+ slartg_(&ab[*ku + 1 + i__ * ab_dim1], &rb, &rc, &rs, &ra);
+ d__[i__] = ra;
+ if (i__ > 1) {
+ rb = -rs * ab[*ku + i__ * ab_dim1];
+ e[i__ - 1] = rc * ab[*ku + i__ * ab_dim1];
+ }
+ if (wantpt) {
+ srot_(n, &pt[i__ + pt_dim1], ldpt, &pt[*m + 1 + pt_dim1],
+ ldpt, &rc, &rs);
+ }
+/* L110: */
+ }
+ } else {
+
+/* Copy off-diagonal elements to E and diagonal elements to D */
+
+ i__1 = minmn - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ e[i__] = ab[*ku + (i__ + 1) * ab_dim1];
+/* L120: */
+ }
+ i__1 = minmn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = ab[*ku + 1 + i__ * ab_dim1];
+/* L130: */
+ }
+ }
+ } else {
+
+/* A is diagonal. Set elements of E to zero and copy diagonal */
+/* elements to D. */
+
+ i__1 = minmn - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ e[i__] = 0.f;
+/* L140: */
+ }
+ i__1 = minmn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = ab[i__ * ab_dim1 + 1];
+/* L150: */
+ }
+ }
+ return 0;
+
+/* End of SGBBRD */
+
+} /* sgbbrd_ */
diff --git a/SRC/sgbcon.c b/SRC/sgbcon.c
new file mode 100644
index 0000000..78fd7c1
--- /dev/null
+++ b/SRC/sgbcon.c
@@ -0,0 +1,282 @@
+/* sgbcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sgbcon_(char *norm, integer *n, integer *kl, integer *ku,
+ real *ab, integer *ldab, integer *ipiv, real *anorm, real *rcond,
+ real *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3;
+ real r__1;
+
+ /* Local variables */
+ integer j;
+ real t;
+ integer kd, lm, jp, ix, kase;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ integer kase1;
+ real scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical lnoti;
+ extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *),
+ saxpy_(integer *, real *, real *, integer *, real *, integer *),
+ slacn2_(integer *, real *, real *, integer *, real *, integer *,
+ integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int slatbs_(char *, char *, char *, char *,
+ integer *, integer *, real *, integer *, real *, real *, real *,
+ integer *);
+ logical onenrm;
+ char normin[1];
+ real smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGBCON estimates the reciprocal of the condition number of a real */
+/* general band matrix A, in either the 1-norm or the infinity-norm, */
+/* using the LU factorization computed by SGBTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as */
+/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input) REAL array, dimension (LDAB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by SGBTRF. U is stored as an upper triangular band */
+/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
+/* the multipliers used during the factorization are stored in */
+/* rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= N, row i of the matrix was */
+/* interchanged with row IPIV(i). */
+
+/* ANORM (input) REAL */
+/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */
+/* If NORM = 'I', the infinity-norm of the original matrix A. */
+
+/* RCOND (output) REAL */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --ipiv;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*ldab < (*kl << 1) + *ku + 1) {
+ *info = -6;
+ } else if (*anorm < 0.f) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGBCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.f;
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ } else if (*anorm == 0.f) {
+ return 0;
+ }
+
+ smlnum = slamch_("Safe minimum");
+
+/* Estimate the norm of inv(A). */
+
+ ainvnm = 0.f;
+ *(unsigned char *)normin = 'N';
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kd = *kl + *ku + 1;
+ lnoti = *kl > 0;
+ kase = 0;
+L10:
+ slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(L). */
+
+ if (lnoti) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *kl, i__3 = *n - j;
+ lm = min(i__2,i__3);
+ jp = ipiv[j];
+ t = work[jp];
+ if (jp != j) {
+ work[jp] = work[j];
+ work[j] = t;
+ }
+ r__1 = -t;
+ saxpy_(&lm, &r__1, &ab[kd + 1 + j * ab_dim1], &c__1, &
+ work[j + 1], &c__1);
+/* L20: */
+ }
+ }
+
+/* Multiply by inv(U). */
+
+ i__1 = *kl + *ku;
+ slatbs_("Upper", "No transpose", "Non-unit", normin, n, &i__1, &
+ ab[ab_offset], ldab, &work[1], &scale, &work[(*n << 1) +
+ 1], info);
+ } else {
+
+/* Multiply by inv(U'). */
+
+ i__1 = *kl + *ku;
+ slatbs_("Upper", "Transpose", "Non-unit", normin, n, &i__1, &ab[
+ ab_offset], ldab, &work[1], &scale, &work[(*n << 1) + 1],
+ info);
+
+/* Multiply by inv(L'). */
+
+ if (lnoti) {
+ for (j = *n - 1; j >= 1; --j) {
+/* Computing MIN */
+ i__1 = *kl, i__2 = *n - j;
+ lm = min(i__1,i__2);
+ work[j] -= sdot_(&lm, &ab[kd + 1 + j * ab_dim1], &c__1, &
+ work[j + 1], &c__1);
+ jp = ipiv[j];
+ if (jp != j) {
+ t = work[jp];
+ work[jp] = work[j];
+ work[j] = t;
+ }
+/* L30: */
+ }
+ }
+ }
+
+/* Divide X by 1/SCALE if doing so will not cause overflow. */
+
+ *(unsigned char *)normin = 'Y';
+ if (scale != 1.f) {
+ ix = isamax_(n, &work[1], &c__1);
+ if (scale < (r__1 = work[ix], dabs(r__1)) * smlnum || scale ==
+ 0.f) {
+ goto L40;
+ }
+ srscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / ainvnm / *anorm;
+ }
+
+L40:
+ return 0;
+
+/* End of SGBCON */
+
+} /* sgbcon_ */
diff --git a/SRC/sgbequ.c b/SRC/sgbequ.c
new file mode 100644
index 0000000..1f04493
--- /dev/null
+++ b/SRC/sgbequ.c
@@ -0,0 +1,319 @@
+/* sgbequ.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sgbequ_(integer *m, integer *n, integer *kl, integer *ku,
+ real *ab, integer *ldab, real *r__, real *c__, real *rowcnd, real *
+ colcnd, real *amax, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, kd;
+ real rcmin, rcmax;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum, smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGBEQU computes row and column scalings intended to equilibrate an */
+/* M-by-N band matrix A and reduce its condition number. R returns the */
+/* row scale factors and C the column scale factors, chosen to try to */
+/* make the largest element in each row and column of the matrix B with */
+/* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. */
+
+/* R(i) and C(j) are restricted to be between SMLNUM = smallest safe */
+/* number and BIGNUM = largest safe number. Use of these scaling */
+/* factors is not guaranteed to reduce the condition number of A but */
+/* works well in practice. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input) REAL array, dimension (LDAB,N) */
+/* The band matrix A, stored in rows 1 to KL+KU+1. The j-th */
+/* column of A is stored in the j-th column of the array AB as */
+/* follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* R (output) REAL array, dimension (M) */
+/* If INFO = 0, or INFO > M, R contains the row scale factors */
+/* for A. */
+
+/* C (output) REAL array, dimension (N) */
+/* If INFO = 0, C contains the column scale factors for A. */
+
+/* ROWCND (output) REAL */
+/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */
+/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */
+/* AMAX is neither too large nor too small, it is not worth */
+/* scaling by R. */
+
+/* COLCND (output) REAL */
+/* If INFO = 0, COLCND contains the ratio of the smallest */
+/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */
+/* worth scaling by C. */
+
+/* AMAX (output) REAL */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= M: the i-th row of A is exactly zero */
+/* > M: the (i-M)-th column of A is exactly zero */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGBEQU", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ *rowcnd = 1.f;
+ *colcnd = 1.f;
+ *amax = 0.f;
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+
+/* Compute row scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__[i__] = 0.f;
+/* L10: */
+ }
+
+/* Find the maximum element in each row. */
+
+ kd = *ku + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j - *ku;
+/* Computing MIN */
+ i__4 = j + *kl;
+ i__3 = min(i__4,*m);
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ r__2 = r__[i__], r__3 = (r__1 = ab[kd + i__ - j + j * ab_dim1],
+ dabs(r__1));
+ r__[i__] = dmax(r__2,r__3);
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = rcmax, r__2 = r__[i__];
+ rcmax = dmax(r__1,r__2);
+/* Computing MIN */
+ r__1 = rcmin, r__2 = r__[i__];
+ rcmin = dmin(r__1,r__2);
+/* L40: */
+ }
+ *amax = rcmax;
+
+ if (rcmin == 0.f) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] == 0.f) {
+ *info = i__;
+ return 0;
+ }
+/* L50: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MIN */
+/* Computing MAX */
+ r__2 = r__[i__];
+ r__1 = dmax(r__2,smlnum);
+ r__[i__] = 1.f / dmin(r__1,bignum);
+/* L60: */
+ }
+
+/* Compute ROWCND = min(R(I)) / max(R(I)) */
+
+ *rowcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ }
+
+/* Compute column scale factors */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 0.f;
+/* L70: */
+ }
+
+/* Find the maximum element in each column, */
+/* assuming the row scaling computed above. */
+
+ kd = *ku + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__3 = j - *ku;
+/* Computing MIN */
+ i__4 = j + *kl;
+ i__2 = min(i__4,*m);
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = c__[j], r__3 = (r__1 = ab[kd + i__ - j + j * ab_dim1],
+ dabs(r__1)) * r__[i__];
+ c__[j] = dmax(r__2,r__3);
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = c__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = c__[j];
+ rcmax = dmax(r__1,r__2);
+/* L100: */
+ }
+
+ if (rcmin == 0.f) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (c__[j] == 0.f) {
+ *info = *m + j;
+ return 0;
+ }
+/* L110: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+/* Computing MAX */
+ r__2 = c__[j];
+ r__1 = dmax(r__2,smlnum);
+ c__[j] = 1.f / dmin(r__1,bignum);
+/* L120: */
+ }
+
+/* Compute COLCND = min(C(J)) / max(C(J)) */
+
+ *colcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ }
+
+ return 0;
+
+/* End of SGBEQU */
+
+} /* sgbequ_ */
diff --git a/SRC/sgbequb.c b/SRC/sgbequb.c
new file mode 100644
index 0000000..062eb8b
--- /dev/null
+++ b/SRC/sgbequb.c
@@ -0,0 +1,346 @@
+/* sgbequb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sgbequb_(integer *m, integer *n, integer *kl, integer *
+ ku, real *ab, integer *ldab, real *r__, real *c__, real *rowcnd, real
+ *colcnd, real *amax, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double log(doublereal), pow_ri(real *, integer *);
+
+ /* Local variables */
+ integer i__, j, kd;
+ real radix, rcmin, rcmax;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum, logrdx, smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGBEQUB computes row and column scalings intended to equilibrate an */
+/* M-by-N matrix A and reduce its condition number. R returns the row */
+/* scale factors and C the column scale factors, chosen to try to make */
+/* the largest element in each row and column of the matrix B with */
+/* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most */
+/* the radix. */
+
+/* R(i) and C(j) are restricted to be a power of the radix between */
+/* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use */
+/* of these scaling factors is not guaranteed to reduce the condition */
+/* number of A but works well in practice. */
+
+/* This routine differs from SGEEQU by restricting the scaling factors */
+/* to a power of the radix. Baring over- and underflow, scaling by */
+/* these factors introduces no additional rounding errors. However, the */
+/* scaled entries' magnitured are no longer approximately 1 but lie */
+/* between sqrt(radix) and 1/sqrt(radix). */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array A. LDAB >= max(1,M). */
+
+/* R (output) REAL array, dimension (M) */
+/* If INFO = 0 or INFO > M, R contains the row scale factors */
+/* for A. */
+
+/* C (output) REAL array, dimension (N) */
+/* If INFO = 0, C contains the column scale factors for A. */
+
+/* ROWCND (output) REAL */
+/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */
+/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */
+/* AMAX is neither too large nor too small, it is not worth */
+/* scaling by R. */
+
+/* COLCND (output) REAL */
+/* If INFO = 0, COLCND contains the ratio of the smallest */
+/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */
+/* worth scaling by C. */
+
+/* AMAX (output) REAL */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= M: the i-th row of A is exactly zero */
+/* > M: the (i-M)-th column of A is exactly zero */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGBEQUB", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ *rowcnd = 1.f;
+ *colcnd = 1.f;
+ *amax = 0.f;
+ return 0;
+ }
+
+/* Get machine constants. Assume SMLNUM is a power of the radix. */
+
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+ radix = slamch_("B");
+ logrdx = log(radix);
+
+/* Compute row scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__[i__] = 0.f;
+/* L10: */
+ }
+
+/* Find the maximum element in each row. */
+
+ kd = *ku + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j - *ku;
+/* Computing MIN */
+ i__4 = j + *kl;
+ i__3 = min(i__4,*m);
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ r__2 = r__[i__], r__3 = (r__1 = ab[kd + i__ - j + j * ab_dim1],
+ dabs(r__1));
+ r__[i__] = dmax(r__2,r__3);
+/* L20: */
+ }
+/* L30: */
+ }
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] > 0.f) {
+ i__3 = (integer) (log(r__[i__]) / logrdx);
+ r__[i__] = pow_ri(&radix, &i__3);
+ }
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = rcmax, r__2 = r__[i__];
+ rcmax = dmax(r__1,r__2);
+/* Computing MIN */
+ r__1 = rcmin, r__2 = r__[i__];
+ rcmin = dmin(r__1,r__2);
+/* L40: */
+ }
+ *amax = rcmax;
+
+ if (rcmin == 0.f) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] == 0.f) {
+ *info = i__;
+ return 0;
+ }
+/* L50: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MIN */
+/* Computing MAX */
+ r__2 = r__[i__];
+ r__1 = dmax(r__2,smlnum);
+ r__[i__] = 1.f / dmin(r__1,bignum);
+/* L60: */
+ }
+
+/* Compute ROWCND = min(R(I)) / max(R(I)). */
+
+ *rowcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ }
+
+/* Compute column scale factors. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 0.f;
+/* L70: */
+ }
+
+/* Find the maximum element in each column, */
+/* assuming the row scaling computed above. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__3 = j - *ku;
+/* Computing MIN */
+ i__4 = j + *kl;
+ i__2 = min(i__4,*m);
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = c__[j], r__3 = (r__1 = ab[kd + i__ - j + j * ab_dim1],
+ dabs(r__1)) * r__[i__];
+ c__[j] = dmax(r__2,r__3);
+/* L80: */
+ }
+ if (c__[j] > 0.f) {
+ i__2 = (integer) (log(c__[j]) / logrdx);
+ c__[j] = pow_ri(&radix, &i__2);
+ }
+/* L90: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = c__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = c__[j];
+ rcmax = dmax(r__1,r__2);
+/* L100: */
+ }
+
+ if (rcmin == 0.f) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (c__[j] == 0.f) {
+ *info = *m + j;
+ return 0;
+ }
+/* L110: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+/* Computing MAX */
+ r__2 = c__[j];
+ r__1 = dmax(r__2,smlnum);
+ c__[j] = 1.f / dmin(r__1,bignum);
+/* L120: */
+ }
+
+/* Compute COLCND = min(C(J)) / max(C(J)). */
+
+ *colcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ }
+
+ return 0;
+
+/* End of SGBEQUB */
+
+} /* sgbequb_ */
diff --git a/SRC/sgbrfs.c b/SRC/sgbrfs.c
new file mode 100644
index 0000000..d5e5d7e
--- /dev/null
+++ b/SRC/sgbrfs.c
@@ -0,0 +1,454 @@
+/* sgbrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b15 = -1.f;
+static real c_b17 = 1.f;
+
+/* Subroutine */ int sgbrfs_(char *trans, integer *n, integer *kl, integer *
+ ku, integer *nrhs, real *ab, integer *ldab, real *afb, integer *ldafb,
+ integer *ipiv, real *b, integer *ldb, real *x, integer *ldx, real *
+ ferr, real *berr, real *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ real s;
+ integer kk;
+ real xk;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int sgbmv_(char *, integer *, integer *, integer *
+, integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ integer count;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), saxpy_(integer *, real *, real *, integer *, real *,
+ integer *), slacn2_(integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+ extern /* Subroutine */ int sgbtrs_(char *, integer *, integer *, integer
+ *, integer *, real *, integer *, integer *, real *, integer *,
+ integer *);
+ char transt[1];
+ real lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGBRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is banded, and provides */
+/* error bounds and backward error estimates for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input) REAL array, dimension (LDAB,N) */
+/* The original band matrix A, stored in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input) REAL array, dimension (LDAFB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by SGBTRF. U is stored as an upper triangular band */
+/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
+/* the multipliers used during the factorization are stored in */
+/* rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from SGBTRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) REAL array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by SGBTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -7;
+ } else if (*ldafb < (*kl << 1) + *ku + 1) {
+ *info = -9;
+ } else if (*ldb < max(1,*n)) {
+ *info = -12;
+ } else if (*ldx < max(1,*n)) {
+ *info = -14;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGBRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+/* Computing MIN */
+ i__1 = *kl + *ku + 2, i__2 = *n + 1;
+ nz = min(i__1,i__2);
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.f;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A, A**T, or A**H, depending on TRANS. */
+
+ scopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+ sgbmv_(trans, n, n, kl, ku, &c_b15, &ab[ab_offset], ldab, &x[j *
+ x_dim1 + 1], &c__1, &c_b17, &work[*n + 1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] = (r__1 = b[i__ + j * b_dim1], dabs(r__1));
+/* L30: */
+ }
+
+/* Compute abs(op(A))*abs(X) + abs(B). */
+
+ if (notran) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ kk = *ku + 1 - k;
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+/* Computing MAX */
+ i__3 = 1, i__4 = k - *ku;
+/* Computing MIN */
+ i__6 = *n, i__7 = k + *kl;
+ i__5 = min(i__6,i__7);
+ for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
+ work[i__] += (r__1 = ab[kk + i__ + k * ab_dim1], dabs(
+ r__1)) * xk;
+/* L40: */
+ }
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ kk = *ku + 1 - k;
+/* Computing MAX */
+ i__5 = 1, i__3 = k - *ku;
+/* Computing MIN */
+ i__6 = *n, i__7 = k + *kl;
+ i__4 = min(i__6,i__7);
+ for (i__ = max(i__5,i__3); i__ <= i__4; ++i__) {
+ s += (r__1 = ab[kk + i__ + k * ab_dim1], dabs(r__1)) * (
+ r__2 = x[i__ + j * x_dim1], dabs(r__2));
+/* L60: */
+ }
+ work[k] += s;
+/* L70: */
+ }
+ }
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[
+ i__];
+ s = dmax(r__2,r__3);
+ } else {
+/* Computing MAX */
+ r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1)
+ / (work[i__] + safe1);
+ s = dmax(r__2,r__3);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ sgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1]
+, &work[*n + 1], n, info);
+ saxpy_(n, &c_b17, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
+ ;
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use SLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ slacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+ kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)**T). */
+
+ sgbtrs_(transt, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &
+ ipiv[1], &work[*n + 1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] *= work[i__];
+/* L110: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] *= work[i__];
+/* L120: */
+ }
+ sgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &
+ ipiv[1], &work[*n + 1], n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], dabs(r__1));
+ lstres = dmax(r__2,r__3);
+/* L130: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of SGBRFS */
+
+} /* sgbrfs_ */
diff --git a/SRC/sgbrfsx.c b/SRC/sgbrfsx.c
new file mode 100644
index 0000000..b0e96ab
--- /dev/null
+++ b/SRC/sgbrfsx.c
@@ -0,0 +1,682 @@
+/* sgbrfsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int sgbrfsx_(char *trans, char *equed, integer *n, integer *
+ kl, integer *ku, integer *nrhs, real *ab, integer *ldab, real *afb,
+ integer *ldafb, integer *ipiv, real *r__, real *c__, real *b, integer
+ *ldb, real *x, integer *ldx, real *rcond, real *berr, integer *
+ n_err_bnds__, real *err_bnds_norm__, real *err_bnds_comp__, integer *
+ nparams, real *params, real *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real illrcond_thresh__, unstable_thresh__, err_lbnd__;
+ integer ref_type__;
+ extern integer ilatrans_(char *);
+ integer j;
+ real rcond_tmp__;
+ integer prec_type__, trans_type__;
+ extern doublereal sla_gbrcond__(char *, integer *, integer *, integer *,
+ real *, integer *, real *, integer *, integer *, integer *, real *
+ , integer *, real *, integer *, ftnlen);
+ real cwise_wrong__;
+ extern /* Subroutine */ int sla_gbrfsx_extended__(integer *, integer *,
+ integer *, integer *, integer *, integer *, real *, integer *,
+ real *, integer *, integer *, logical *, real *, real *, integer *
+ , real *, integer *, real *, integer *, real *, real *, real *,
+ real *, real *, real *, real *, integer *, real *, real *,
+ logical *, integer *);
+ char norm[1];
+ logical ignore_cwise__;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern doublereal slangb_(char *, integer *, integer *, integer *, real *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int sgbcon_(char *, integer *, integer *, integer
+ *, real *, integer *, integer *, real *, real *, real *, integer *
+, integer *), xerbla_(char *, integer *);
+ logical colequ, notran, rowequ;
+ extern integer ilaprec_(char *);
+ integer ithresh, n_norms__;
+ real rthresh;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGBRFSX improves the computed solution to a system of linear */
+/* equations and provides error bounds and backward error estimates */
+/* for the solution. In addition to normwise error bound, the code */
+/* provides maximum componentwise error bound if possible. See */
+/* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the */
+/* error bounds. */
+
+/* The original system of linear equations may have been equilibrated */
+/* before calling this routine, as described by arguments EQUED, R */
+/* and C below. In this case, the solution and error bounds returned */
+/* are for the original unequilibrated system. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* EQUED (input) CHARACTER*1 */
+/* Specifies the form of equilibration that was done to A */
+/* before calling this routine. This is needed to compute */
+/* the solution and error bounds correctly. */
+/* = 'N': No equilibration */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* The right hand side B has been changed accordingly. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The original band matrix A, stored in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by DGBTRF. U is stored as an upper triangular band */
+/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
+/* the multipliers used during the factorization are stored in */
+/* rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from SGETRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* R (input or output) REAL array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+/* If R is output, each element of R is a power of the radix. */
+/* If R is input, each element of R should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* C (input or output) REAL array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+/* If C is output, each element of C is a power of the radix. */
+/* If C is input, each element of C should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) REAL array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by SGETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) REAL array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) REAL array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check the input parameters. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ trans_type__ = ilatrans_(trans);
+ ref_type__ = 1;
+ if (*nparams >= 1) {
+ if (params[1] < 0.f) {
+ params[1] = 1.f;
+ } else {
+ ref_type__ = params[1];
+ }
+ }
+
+/* Set default parameters. */
+
+ illrcond_thresh__ = (real) (*n) * slamch_("Epsilon");
+ ithresh = 10;
+ rthresh = .5f;
+ unstable_thresh__ = .25f;
+ ignore_cwise__ = FALSE_;
+
+ if (*nparams >= 2) {
+ if (params[2] < 0.f) {
+ params[2] = (real) ithresh;
+ } else {
+ ithresh = (integer) params[2];
+ }
+ }
+ if (*nparams >= 3) {
+ if (params[3] < 0.f) {
+ if (ignore_cwise__) {
+ params[3] = 0.f;
+ } else {
+ params[3] = 1.f;
+ }
+ } else {
+ ignore_cwise__ = params[3] == 0.f;
+ }
+ }
+ if (ref_type__ == 0 || *n_err_bnds__ == 0) {
+ n_norms__ = 0;
+ } else if (ignore_cwise__) {
+ n_norms__ = 1;
+ } else {
+ n_norms__ = 2;
+ }
+
+ notran = lsame_(trans, "N");
+ rowequ = lsame_(equed, "R") || lsame_(equed, "B");
+ colequ = lsame_(equed, "C") || lsame_(equed, "B");
+
+/* Test input parameters. */
+
+ if (trans_type__ == -1) {
+ *info = -1;
+ } else if (! rowequ && ! colequ && ! lsame_(equed, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kl < 0) {
+ *info = -4;
+ } else if (*ku < 0) {
+ *info = -5;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -8;
+ } else if (*ldafb < (*kl << 1) + *ku + 1) {
+ *info = -10;
+ } else if (*ldb < max(1,*n)) {
+ *info = -13;
+ } else if (*ldx < max(1,*n)) {
+ *info = -15;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGBRFSX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *nrhs == 0) {
+ *rcond = 1.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 0.f;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.f;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.f;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.f;
+ }
+ }
+ return 0;
+ }
+
+/* Default to failure. */
+
+ *rcond = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 1.f;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.f;
+ }
+ }
+
+/* Compute the norm of A and the reciprocal of the condition */
+/* number of A. */
+
+ if (notran) {
+ *(unsigned char *)norm = 'I';
+ } else {
+ *(unsigned char *)norm = '1';
+ }
+ anorm = slangb_(norm, n, kl, ku, &ab[ab_offset], ldab, &work[1]);
+ sgbcon_(norm, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], &anorm, rcond,
+ &work[1], &iwork[1], info);
+
+/* Perform refinement on each right-hand side */
+
+ if (ref_type__ != 0) {
+ prec_type__ = ilaprec_("D");
+ if (notran) {
+ sla_gbrfsx_extended__(&prec_type__, &trans_type__, n, kl, ku,
+ nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, &
+ ipiv[1], &colequ, &c__[1], &b[b_offset], ldb, &x[x_offset]
+ , ldx, &berr[1], &n_norms__, &err_bnds_norm__[
+ err_bnds_norm_offset], &err_bnds_comp__[
+ err_bnds_comp_offset], &work[*n + 1], &work[1], &work[(*n
+ << 1) + 1], &work[1], rcond, &ithresh, &rthresh, &
+ unstable_thresh__, &ignore_cwise__, info);
+ } else {
+ sla_gbrfsx_extended__(&prec_type__, &trans_type__, n, kl, ku,
+ nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, &
+ ipiv[1], &rowequ, &r__[1], &b[b_offset], ldb, &x[x_offset]
+ , ldx, &berr[1], &n_norms__, &err_bnds_norm__[
+ err_bnds_norm_offset], &err_bnds_comp__[
+ err_bnds_comp_offset], &work[*n + 1], &work[1], &work[(*n
+ << 1) + 1], &work[1], rcond, &ithresh, &rthresh, &
+ unstable_thresh__, &ignore_cwise__, info);
+ }
+ }
+/* Computing MAX */
+ r__1 = 10.f, r__2 = sqrt((real) (*n));
+ err_lbnd__ = dmax(r__1,r__2) * slamch_("Epsilon");
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {
+
+/* Compute scaled normwise condition number cond(A*C). */
+
+ if (colequ && notran) {
+ rcond_tmp__ = sla_gbrcond__(trans, n, kl, ku, &ab[ab_offset],
+ ldab, &afb[afb_offset], ldafb, &ipiv[1], &c_n1, &c__[1],
+ info, &work[1], &iwork[1], (ftnlen)1);
+ } else if (rowequ && ! notran) {
+ rcond_tmp__ = sla_gbrcond__(trans, n, kl, ku, &ab[ab_offset],
+ ldab, &afb[afb_offset], ldafb, &ipiv[1], &c_n1, &r__[1],
+ info, &work[1], &iwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = sla_gbrcond__(trans, n, kl, ku, &ab[ab_offset],
+ ldab, &afb[afb_offset], ldafb, &ipiv[1], &c__0, &r__[1],
+ info, &work[1], &iwork[1], (ftnlen)1);
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1
+ << 1)] > 1.f) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 0.f;
+ if (*info <= *n) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {
+
+/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
+/* each right-hand side using the current solution as an estimate of */
+/* the true solution. If the componentwise error estimate is too */
+/* large, then the solution is a lousy estimate of truth and the */
+/* estimated RCOND may be too optimistic. To avoid misleading users, */
+/* the inverse condition number is set to 0.0 when the estimated */
+/* cwise error is at least CWISE_WRONG. */
+
+ cwise_wrong__ = sqrt(slamch_("Epsilon"));
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ cwise_wrong__) {
+ rcond_tmp__ = sla_gbrcond__(trans, n, kl, ku, &ab[ab_offset],
+ ldab, &afb[afb_offset], ldafb, &ipiv[1], &c__1, &x[j *
+ x_dim1 + 1], info, &work[1], &iwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = 0.f;
+ }
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1
+ << 1)] > 1.f) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 0.f;
+ if (params[3] == 1.f && *info < *n + j) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SGBRFSX */
+
+} /* sgbrfsx_ */
diff --git a/SRC/sgbsv.c b/SRC/sgbsv.c
new file mode 100644
index 0000000..ee6db5e
--- /dev/null
+++ b/SRC/sgbsv.c
@@ -0,0 +1,176 @@
+/* sgbsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sgbsv_(integer *n, integer *kl, integer *ku, integer *
+ nrhs, real *ab, integer *ldab, integer *ipiv, real *b, integer *ldb,
+ integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int xerbla_(char *, integer *), sgbtrf_(
+ integer *, integer *, integer *, integer *, real *, integer *,
+ integer *, integer *), sgbtrs_(char *, integer *, integer *,
+ integer *, integer *, real *, integer *, integer *, real *,
+ integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGBSV computes the solution to a real system of linear equations */
+/* A * X = B, where A is a band matrix of order N with KL subdiagonals */
+/* and KU superdiagonals, and X and B are N-by-NRHS matrices. */
+
+/* The LU decomposition with partial pivoting and row interchanges is */
+/* used to factor A as A = L * U, where L is a product of permutation */
+/* and unit lower triangular matrices with KL subdiagonals, and U is */
+/* upper triangular with KL+KU superdiagonals. The factored form of A */
+/* is then used to solve the system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AB (input/output) REAL array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows KL+1 to */
+/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL) */
+/* On exit, details of the factorization: U is stored as an */
+/* upper triangular band matrix with KL+KU superdiagonals in */
+/* rows 1 to KL+KU+1, and the multipliers used during the */
+/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */
+/* See below for further details. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* The pivot indices that define the permutation matrix P; */
+/* row i of the matrix was interchanged with row IPIV(i). */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and the solution has not been computed. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* M = N = 6, KL = 2, KU = 1: */
+
+/* On entry: On exit: */
+
+/* * * * + + + * * * u14 u25 u36 */
+/* * * + + + + * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */
+/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */
+
+/* Array elements marked * are not used by the routine; elements marked */
+/* + need not be set on entry, but are required by the routine to store */
+/* elements of U because of fill-in resulting from the row interchanges. */
+
+/* ===================================================================== */
+
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*kl < 0) {
+ *info = -2;
+ } else if (*ku < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldab < (*kl << 1) + *ku + 1) {
+ *info = -6;
+ } else if (*ldb < max(*n,1)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGBSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the LU factorization of the band matrix A. */
+
+ sgbtrf_(n, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ sgbtrs_("No transpose", n, kl, ku, nrhs, &ab[ab_offset], ldab, &ipiv[
+ 1], &b[b_offset], ldb, info);
+ }
+ return 0;
+
+/* End of SGBSV */
+
+} /* sgbsv_ */
diff --git a/SRC/sgbsvx.c b/SRC/sgbsvx.c
new file mode 100644
index 0000000..69346f4
--- /dev/null
+++ b/SRC/sgbsvx.c
@@ -0,0 +1,650 @@
+/* sgbsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sgbsvx_(char *fact, char *trans, integer *n, integer *kl,
+ integer *ku, integer *nrhs, real *ab, integer *ldab, real *afb,
+ integer *ldafb, integer *ipiv, char *equed, real *r__, real *c__,
+ real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *ferr,
+ real *berr, real *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, j1, j2;
+ real amax;
+ char norm[1];
+ extern logical lsame_(char *, char *);
+ real rcmin, rcmax, anorm;
+ logical equil;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ real colcnd;
+ extern doublereal slangb_(char *, integer *, integer *, integer *, real *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int slaqgb_(integer *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ real *, char *);
+ logical nofact;
+ extern /* Subroutine */ int sgbcon_(char *, integer *, integer *, integer
+ *, real *, integer *, integer *, real *, real *, real *, integer *
+, integer *), xerbla_(char *, integer *);
+ real bignum;
+ extern doublereal slantb_(char *, char *, char *, integer *, integer *,
+ real *, integer *, real *);
+ extern /* Subroutine */ int sgbequ_(integer *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ real *, integer *);
+ integer infequ;
+ logical colequ;
+ extern /* Subroutine */ int sgbrfs_(char *, integer *, integer *, integer
+ *, integer *, real *, integer *, real *, integer *, integer *,
+ real *, integer *, real *, integer *, real *, real *, real *,
+ integer *, integer *), sgbtrf_(integer *, integer *,
+ integer *, integer *, real *, integer *, integer *, integer *),
+ slacpy_(char *, integer *, integer *, real *, integer *, real *,
+ integer *);
+ real rowcnd;
+ logical notran;
+ extern /* Subroutine */ int sgbtrs_(char *, integer *, integer *, integer
+ *, integer *, real *, integer *, integer *, real *, integer *,
+ integer *);
+ real smlnum;
+ logical rowequ;
+ real rpvgrw;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGBSVX uses the LU factorization to compute the solution to a real */
+/* system of linear equations A * X = B, A**T * X = B, or A**H * X = B, */
+/* where A is a band matrix of order N with KL subdiagonals and KU */
+/* superdiagonals, and X and B are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed by this subroutine: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */
+/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */
+/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */
+/* or diag(C)*B (if TRANS = 'T' or 'C'). */
+
+/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the */
+/* matrix A (after equilibration if FACT = 'E') as */
+/* A = L * U, */
+/* where L is a product of permutation and unit lower triangular */
+/* matrices with KL subdiagonals, and U is upper triangular with */
+/* KL+KU superdiagonals. */
+
+/* 3. If some U(i,i)=0, so that U is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */
+/* that it solves the original system before equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AFB and IPIV contain the factored form of */
+/* A. If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by R and C. */
+/* AB, AFB, and IPIV are not modified. */
+/* = 'N': The matrix A will be copied to AFB and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AFB and factored. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input/output) REAL array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
+
+/* If FACT = 'F' and EQUED is not 'N', then A must have been */
+/* equilibrated by the scaling factors in R and/or C. AB is not */
+/* modified if FACT = 'F' or 'N', or if FACT = 'E' and */
+/* EQUED = 'N' on exit. */
+
+/* On exit, if EQUED .ne. 'N', A is scaled as follows: */
+/* EQUED = 'R': A := diag(R) * A */
+/* EQUED = 'C': A := A * diag(C) */
+/* EQUED = 'B': A := diag(R) * A * diag(C). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input or output) REAL array, dimension (LDAFB,N) */
+/* If FACT = 'F', then AFB is an input argument and on entry */
+/* contains details of the LU factorization of the band matrix */
+/* A, as computed by SGBTRF. U is stored as an upper triangular */
+/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */
+/* and the multipliers used during the factorization are stored */
+/* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is */
+/* the factored form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AFB is an output argument and on exit */
+/* returns details of the LU factorization of A. */
+
+/* If FACT = 'E', then AFB is an output argument and on exit */
+/* returns details of the LU factorization of the equilibrated */
+/* matrix A (see the description of AB for the form of the */
+/* equilibrated matrix). */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains the pivot indices from the factorization A = L*U */
+/* as computed by SGBTRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = L*U */
+/* of the equilibrated matrix A. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* R (input or output) REAL array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+
+/* C (input or output) REAL array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */
+/* diag(R)*B; */
+/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */
+/* overwritten by diag(C)*B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) REAL array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X */
+/* to the original system of equations. Note that A and B are */
+/* modified on exit if EQUED .ne. 'N', and the solution to the */
+/* equilibrated system is inv(diag(C))*X if TRANS = 'N' and */
+/* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' */
+/* and EQUED = 'R' or 'B'. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A after equilibration (if done). If RCOND is less than the */
+/* machine precision (in particular, if RCOND = 0), the matrix */
+/* is singular to working precision. This condition is */
+/* indicated by a return code of INFO > 0. */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace/output) REAL array, dimension (3*N) */
+/* On exit, WORK(1) contains the reciprocal pivot growth */
+/* factor norm(A)/norm(U). The "max absolute element" norm is */
+/* used. If WORK(1) is much less than 1, then the stability */
+/* of the LU factorization of the (equilibrated) matrix A */
+/* could be poor. This also means that the solution X, condition */
+/* estimator RCOND, and forward error bound FERR could be */
+/* unreliable. If factorization fails with 0<INFO<=N, then */
+/* WORK(1) contains the reciprocal pivot growth factor for the */
+/* leading INFO columns of A. */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, so the solution and error bounds */
+/* could not be computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+
+/* value of RCOND would suggest. */
+/* ===================================================================== */
+/* Moved setting of INFO = N+1 so INFO does not subsequently get */
+/* overwritten. Sven, 17 Mar 05. */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ notran = lsame_(trans, "N");
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rowequ = FALSE_;
+ colequ = FALSE_;
+ } else {
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ }
+
+/* Test the input parameters. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kl < 0) {
+ *info = -4;
+ } else if (*ku < 0) {
+ *info = -5;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -8;
+ } else if (*ldafb < (*kl << 1) + *ku + 1) {
+ *info = -10;
+ } else if (lsame_(fact, "F") && ! (rowequ || colequ
+ || lsame_(equed, "N"))) {
+ *info = -12;
+ } else {
+ if (rowequ) {
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = r__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = r__[j];
+ rcmax = dmax(r__1,r__2);
+/* L10: */
+ }
+ if (rcmin <= 0.f) {
+ *info = -13;
+ } else if (*n > 0) {
+ rowcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ } else {
+ rowcnd = 1.f;
+ }
+ }
+ if (colequ && *info == 0) {
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = c__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = c__[j];
+ rcmax = dmax(r__1,r__2);
+/* L20: */
+ }
+ if (rcmin <= 0.f) {
+ *info = -14;
+ } else if (*n > 0) {
+ colcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ } else {
+ colcnd = 1.f;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -16;
+ } else if (*ldx < max(1,*n)) {
+ *info = -18;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGBSVX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ sgbequ_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &rowcnd,
+ &colcnd, &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ slaqgb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &
+ rowcnd, &colcnd, &amax, equed);
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+ }
+
+/* Scale the right hand side. */
+
+ if (notran) {
+ if (rowequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = r__[i__] * b[i__ + j * b_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else if (colequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = c__[i__] * b[i__ + j * b_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of the band matrix A. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j - *ku;
+ j1 = max(i__2,1);
+/* Computing MIN */
+ i__2 = j + *kl;
+ j2 = min(i__2,*n);
+ i__2 = j2 - j1 + 1;
+ scopy_(&i__2, &ab[*ku + 1 - j + j1 + j * ab_dim1], &c__1, &afb[*
+ kl + *ku + 1 - j + j1 + j * afb_dim1], &c__1);
+/* L70: */
+ }
+
+ sgbtrf_(n, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ anorm = 0.f;
+ i__1 = *info;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = *ku + 2 - j;
+/* Computing MIN */
+ i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1;
+ i__3 = min(i__4,i__5);
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ r__2 = anorm, r__3 = (r__1 = ab[i__ + j * ab_dim1], dabs(
+ r__1));
+ anorm = dmax(r__2,r__3);
+/* L80: */
+ }
+/* L90: */
+ }
+/* Computing MIN */
+ i__3 = *info - 1, i__2 = *kl + *ku;
+ i__1 = min(i__3,i__2);
+/* Computing MAX */
+ i__4 = 1, i__5 = *kl + *ku + 2 - *info;
+ rpvgrw = slantb_("M", "U", "N", info, &i__1, &afb[max(i__4, i__5)
+ + afb_dim1], ldafb, &work[1]);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = anorm / rpvgrw;
+ }
+ work[1] = rpvgrw;
+ *rcond = 0.f;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A and the */
+/* reciprocal pivot growth factor RPVGRW. */
+
+ if (notran) {
+ *(unsigned char *)norm = '1';
+ } else {
+ *(unsigned char *)norm = 'I';
+ }
+ anorm = slangb_(norm, n, kl, ku, &ab[ab_offset], ldab, &work[1]);
+ i__1 = *kl + *ku;
+ rpvgrw = slantb_("M", "U", "N", n, &i__1, &afb[afb_offset], ldafb, &work[
+ 1]);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = slangb_("M", n, kl, ku, &ab[ab_offset], ldab, &work[1]) / rpvgrw;
+ }
+
+/* Compute the reciprocal of the condition number of A. */
+
+ sgbcon_(norm, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], &anorm, rcond,
+ &work[1], &iwork[1], info);
+
+/* Compute the solution matrix X. */
+
+ slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ sgbtrs_(trans, n, kl, ku, nrhs, &afb[afb_offset], ldafb, &ipiv[1], &x[
+ x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ sgbrfs_(trans, n, kl, ku, nrhs, &ab[ab_offset], ldab, &afb[afb_offset],
+ ldafb, &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &
+ berr[1], &work[1], &iwork[1], info);
+
+/* Transform the solution matrix X to a solution of the original */
+/* system. */
+
+ if (notran) {
+ if (colequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ x[i__ + j * x_dim1] = c__[i__] * x[i__ + j * x_dim1];
+/* L100: */
+ }
+/* L110: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= colcnd;
+/* L120: */
+ }
+ }
+ } else if (rowequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ x[i__ + j * x_dim1] = r__[i__] * x[i__ + j * x_dim1];
+/* L130: */
+ }
+/* L140: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= rowcnd;
+/* L150: */
+ }
+ }
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < slamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ work[1] = rpvgrw;
+ return 0;
+
+/* End of SGBSVX */
+
+} /* sgbsvx_ */
diff --git a/SRC/sgbsvxx.c b/SRC/sgbsvxx.c
new file mode 100644
index 0000000..0d5e113
--- /dev/null
+++ b/SRC/sgbsvxx.c
@@ -0,0 +1,744 @@
+/* sgbsvxx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sgbsvxx_(char *fact, char *trans, integer *n, integer *
+ kl, integer *ku, integer *nrhs, real *ab, integer *ldab, real *afb,
+ integer *ldafb, integer *ipiv, char *equed, real *r__, real *c__,
+ real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *
+ rpvgrw, real *berr, integer *n_err_bnds__, real *err_bnds_norm__,
+ real *err_bnds_comp__, integer *nparams, real *params, real *work,
+ integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer i__, j;
+ real amax;
+ extern doublereal sla_gbrpvgrw__(integer *, integer *, integer *, integer
+ *, real *, integer *, real *, integer *);
+ extern logical lsame_(char *, char *);
+ real rcmin, rcmax;
+ logical equil;
+ real colcnd;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int slaqgb_(integer *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ real *, char *);
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ integer infequ;
+ logical colequ;
+ extern /* Subroutine */ int sgbtrf_(integer *, integer *, integer *,
+ integer *, real *, integer *, integer *, integer *), slacpy_(char
+ *, integer *, integer *, real *, integer *, real *, integer *);
+ real rowcnd;
+ logical notran;
+ extern /* Subroutine */ int sgbtrs_(char *, integer *, integer *, integer
+ *, integer *, real *, integer *, integer *, real *, integer *,
+ integer *);
+ real smlnum;
+ logical rowequ;
+ extern /* Subroutine */ int slascl2_(integer *, integer *, real *, real *,
+ integer *), sgbequb_(integer *, integer *, integer *, integer *,
+ real *, integer *, real *, real *, real *, real *, real *,
+ integer *), sgbrfsx_(char *, char *, integer *, integer *,
+ integer *, integer *, real *, integer *, real *, integer *,
+ integer *, real *, real *, real *, integer *, real *, integer *,
+ real *, real *, integer *, real *, real *, integer *, real *,
+ real *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGBSVXX uses the LU factorization to compute the solution to a */
+/* real system of linear equations A * X = B, where A is an */
+/* N-by-N matrix and X and B are N-by-NRHS matrices. */
+
+/* If requested, both normwise and maximum componentwise error bounds */
+/* are returned. SGBSVXX will return a solution with a tiny */
+/* guaranteed error (O(eps) where eps is the working machine */
+/* precision) unless the matrix is very ill-conditioned, in which */
+/* case a warning is returned. Relevant condition numbers also are */
+/* calculated and returned. */
+
+/* SGBSVXX accepts user-provided factorizations and equilibration */
+/* factors; see the definitions of the FACT and EQUED options. */
+/* Solving with refinement and using a factorization from a previous */
+/* SGBSVXX call will also produce a solution with either O(eps) */
+/* errors or warnings, but we cannot make that claim for general */
+/* user-provided factorizations and equilibration factors if they */
+/* differ from what SGBSVXX would itself produce. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+
+/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */
+/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */
+/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */
+
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */
+/* or diag(C)*B (if TRANS = 'T' or 'C'). */
+
+/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */
+/* the matrix A (after equilibration if FACT = 'E') as */
+
+/* A = P * L * U, */
+
+/* where P is a permutation matrix, L is a unit lower triangular */
+/* matrix, and U is upper triangular. */
+
+/* 3. If some U(i,i)=0, so that U is exactly singular, then the */
+/* routine returns with INFO = i. Otherwise, the factored form of A */
+/* is used to estimate the condition number of the matrix A (see */
+/* argument RCOND). If the reciprocal of the condition number is less */
+/* than machine precision, the routine still goes on to solve for X */
+/* and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */
+/* the routine will use iterative refinement to try to get a small */
+/* error and error bounds. Refinement calculates the residual to at */
+/* least twice the working precision. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */
+/* that it solves the original system before equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF and IPIV contain the factored form of A. */
+/* If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by R and C. */
+/* A, AF, and IPIV are not modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input/output) REAL array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
+
+/* If FACT = 'F' and EQUED is not 'N', then AB must have been */
+/* equilibrated by the scaling factors in R and/or C. AB is not */
+/* modified if FACT = 'F' or 'N', or if FACT = 'E' and */
+/* EQUED = 'N' on exit. */
+
+/* On exit, if EQUED .ne. 'N', A is scaled as follows: */
+/* EQUED = 'R': A := diag(R) * A */
+/* EQUED = 'C': A := A * diag(C) */
+/* EQUED = 'B': A := diag(R) * A * diag(C). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input or output) REAL array, dimension (LDAFB,N) */
+/* If FACT = 'F', then AFB is an input argument and on entry */
+/* contains details of the LU factorization of the band matrix */
+/* A, as computed by SGBTRF. U is stored as an upper triangular */
+/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */
+/* and the multipliers used during the factorization are stored */
+/* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is */
+/* the factored form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the equilibrated matrix A (see the description of A for */
+/* the form of the equilibrated matrix). */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* as computed by SGETRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the equilibrated matrix A. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* R (input or output) REAL array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+/* If R is output, each element of R is a power of the radix. */
+/* If R is input, each element of R should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* C (input or output) REAL array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+/* If C is output, each element of C is a power of the radix. */
+/* If C is input, each element of C should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */
+/* diag(R)*B; */
+/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */
+/* overwritten by diag(C)*B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) REAL array, dimension (LDX,NRHS) */
+/* If INFO = 0, the N-by-NRHS solution matrix X to the original */
+/* system of equations. Note that A and B are modified on exit */
+/* if EQUED .ne. 'N', and the solution to the equilibrated system is */
+/* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or */
+/* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* RPVGRW (output) REAL */
+/* Reciprocal pivot growth. On exit, this contains the reciprocal */
+/* pivot growth factor norm(A)/norm(U). The "max absolute element" */
+/* norm is used. If this is much less than 1, then the stability of */
+/* the LU factorization of the (equilibrated) matrix A could be poor. */
+/* This also means that the solution X, estimated condition numbers, */
+/* and error bounds could be unreliable. If factorization fails with */
+/* 0<INFO<=N, then this contains the reciprocal pivot growth factor */
+/* for the leading INFO columns of A. In SGESVX, this quantity is */
+/* returned in WORK(1). */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) REAL array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) REAL array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ notran = lsame_(trans, "N");
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rowequ = FALSE_;
+ colequ = FALSE_;
+ } else {
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+
+/* Default is failure. If an input parameter is wrong or */
+/* factorization fails, make everything look horrible. Only the */
+/* pivot growth is set here, the rest is initialized in SGBRFSX. */
+
+ *rpvgrw = 0.f;
+
+/* Test the input parameters. PARAMS is not tested until SGBRFSX. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kl < 0) {
+ *info = -4;
+ } else if (*ku < 0) {
+ *info = -5;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -8;
+ } else if (*ldafb < (*kl << 1) + *ku + 1) {
+ *info = -10;
+ } else if (lsame_(fact, "F") && ! (rowequ || colequ
+ || lsame_(equed, "N"))) {
+ *info = -12;
+ } else {
+ if (rowequ) {
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = r__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = r__[j];
+ rcmax = dmax(r__1,r__2);
+/* L10: */
+ }
+ if (rcmin <= 0.f) {
+ *info = -13;
+ } else if (*n > 0) {
+ rowcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ } else {
+ rowcnd = 1.f;
+ }
+ }
+ if (colequ && *info == 0) {
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = c__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = c__[j];
+ rcmax = dmax(r__1,r__2);
+/* L20: */
+ }
+ if (rcmin <= 0.f) {
+ *info = -14;
+ } else if (*n > 0) {
+ colcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ } else {
+ colcnd = 1.f;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -15;
+ } else if (*ldx < max(1,*n)) {
+ *info = -16;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGBSVXX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ sgbequb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &
+ rowcnd, &colcnd, &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ slaqgb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &
+ rowcnd, &colcnd, &amax, equed);
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+
+/* If the scaling factors are not applied, set them to 1.0. */
+
+ if (! rowequ) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ r__[j] = 1.f;
+ }
+ }
+ if (! colequ) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 1.f;
+ }
+ }
+ }
+
+/* Scale the right hand side. */
+
+ if (notran) {
+ if (rowequ) {
+ slascl2_(n, nrhs, &r__[1], &b[b_offset], ldb);
+ }
+ } else {
+ if (colequ) {
+ slascl2_(n, nrhs, &c__[1], &b[b_offset], ldb);
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of A. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (*kl << 1) + *ku + 1;
+ for (i__ = *kl + 1; i__ <= i__2; ++i__) {
+ afb[i__ + j * afb_dim1] = ab[i__ - *kl + j * ab_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ sgbtrf_(n, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Pivot in column INFO is exactly 0 */
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ *rpvgrw = sla_gbrpvgrw__(n, kl, ku, info, &ab[ab_offset], ldab, &
+ afb[afb_offset], ldafb);
+ return 0;
+ }
+ }
+
+/* Compute the reciprocal pivot growth factor RPVGRW. */
+
+ *rpvgrw = sla_gbrpvgrw__(n, kl, ku, n, &ab[ab_offset], ldab, &afb[
+ afb_offset], ldafb);
+
+/* Compute the solution matrix X. */
+
+ slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ sgbtrs_(trans, n, kl, ku, nrhs, &afb[afb_offset], ldafb, &ipiv[1], &x[
+ x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ sgbrfsx_(trans, equed, n, kl, ku, nrhs, &ab[ab_offset], ldab, &afb[
+ afb_offset], ldafb, &ipiv[1], &r__[1], &c__[1], &b[b_offset], ldb,
+ &x[x_offset], ldx, rcond, &berr[1], n_err_bnds__, &
+ err_bnds_norm__[err_bnds_norm_offset], &err_bnds_comp__[
+ err_bnds_comp_offset], nparams, ¶ms[1], &work[1], &iwork[1],
+ info);
+
+/* Scale solutions. */
+
+ if (colequ && notran) {
+ slascl2_(n, nrhs, &c__[1], &x[x_offset], ldx);
+ } else if (rowequ && ! notran) {
+ slascl2_(n, nrhs, &r__[1], &x[x_offset], ldx);
+ }
+
+ return 0;
+
+/* End of SGBSVXX */
+
+} /* sgbsvxx_ */
diff --git a/SRC/sgbtf2.c b/SRC/sgbtf2.c
new file mode 100644
index 0000000..0d0fbfb
--- /dev/null
+++ b/SRC/sgbtf2.c
@@ -0,0 +1,260 @@
+/* sgbtf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b9 = -1.f;
+
+/* Subroutine */ int sgbtf2_(integer *m, integer *n, integer *kl, integer *ku,
+ real *ab, integer *ldab, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j, km, jp, ju, kv;
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *), sscal_(integer *
+, real *, real *, integer *), sswap_(integer *, real *, integer *,
+ real *, integer *), xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGBTF2 computes an LU factorization of a real m-by-n band matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input/output) REAL array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows KL+1 to */
+/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */
+
+/* On exit, details of the factorization: U is stored as an */
+/* upper triangular band matrix with KL+KU superdiagonals in */
+/* rows 1 to KL+KU+1, and the multipliers used during the */
+/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */
+/* See below for further details. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* M = N = 6, KL = 2, KU = 1: */
+
+/* On entry: On exit: */
+
+/* * * * + + + * * * u14 u25 u36 */
+/* * * + + + + * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */
+/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */
+
+/* Array elements marked * are not used by the routine; elements marked */
+/* + need not be set on entry, but are required by the routine to store */
+/* elements of U, because of fill-in resulting from the row */
+/* interchanges. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* KV is the number of superdiagonals in the factor U, allowing for */
+/* fill-in. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --ipiv;
+
+ /* Function Body */
+ kv = *ku + *kl;
+
+/* Test the input parameters. */
+
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*ldab < *kl + kv + 1) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGBTF2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Gaussian elimination with partial pivoting */
+
+/* Set fill-in elements in columns KU+2 to KV to zero. */
+
+ i__1 = min(kv,*n);
+ for (j = *ku + 2; j <= i__1; ++j) {
+ i__2 = *kl;
+ for (i__ = kv - j + 2; i__ <= i__2; ++i__) {
+ ab[i__ + j * ab_dim1] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* JU is the index of the last column affected by the current stage */
+/* of the factorization. */
+
+ ju = 1;
+
+ i__1 = min(*m,*n);
+ for (j = 1; j <= i__1; ++j) {
+
+/* Set fill-in elements in column J+KV to zero. */
+
+ if (j + kv <= *n) {
+ i__2 = *kl;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ab[i__ + (j + kv) * ab_dim1] = 0.f;
+/* L30: */
+ }
+ }
+
+/* Find pivot and test for singularity. KM is the number of */
+/* subdiagonal elements in the current column. */
+
+/* Computing MIN */
+ i__2 = *kl, i__3 = *m - j;
+ km = min(i__2,i__3);
+ i__2 = km + 1;
+ jp = isamax_(&i__2, &ab[kv + 1 + j * ab_dim1], &c__1);
+ ipiv[j] = jp + j - 1;
+ if (ab[kv + jp + j * ab_dim1] != 0.f) {
+/* Computing MAX */
+/* Computing MIN */
+ i__4 = j + *ku + jp - 1;
+ i__2 = ju, i__3 = min(i__4,*n);
+ ju = max(i__2,i__3);
+
+/* Apply interchange to columns J to JU. */
+
+ if (jp != 1) {
+ i__2 = ju - j + 1;
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ sswap_(&i__2, &ab[kv + jp + j * ab_dim1], &i__3, &ab[kv + 1 +
+ j * ab_dim1], &i__4);
+ }
+
+ if (km > 0) {
+
+/* Compute multipliers. */
+
+ r__1 = 1.f / ab[kv + 1 + j * ab_dim1];
+ sscal_(&km, &r__1, &ab[kv + 2 + j * ab_dim1], &c__1);
+
+/* Update trailing submatrix within the band. */
+
+ if (ju > j) {
+ i__2 = ju - j;
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ sger_(&km, &i__2, &c_b9, &ab[kv + 2 + j * ab_dim1], &c__1,
+ &ab[kv + (j + 1) * ab_dim1], &i__3, &ab[kv + 1 +
+ (j + 1) * ab_dim1], &i__4);
+ }
+ }
+ } else {
+
+/* If pivot is zero, set INFO to the index of the pivot */
+/* unless a zero pivot has already been found. */
+
+ if (*info == 0) {
+ *info = j;
+ }
+ }
+/* L40: */
+ }
+ return 0;
+
+/* End of SGBTF2 */
+
+} /* sgbtf2_ */
diff --git a/SRC/sgbtrf.c b/SRC/sgbtrf.c
new file mode 100644
index 0000000..fead045
--- /dev/null
+++ b/SRC/sgbtrf.c
@@ -0,0 +1,583 @@
+/* sgbtrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__65 = 65;
+static real c_b18 = -1.f;
+static real c_b31 = 1.f;
+
+/* Subroutine */ int sgbtrf_(integer *m, integer *n, integer *kl, integer *ku,
+ real *ab, integer *ldab, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j, i2, i3, j2, j3, k2, jb, nb, ii, jj, jm, ip, jp, km, ju,
+ kv, nw;
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ real temp;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ sgemm_(char *, char *, integer *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ real work13[4160] /* was [65][64] */, work31[4160] /* was [65][
+ 64] */;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), sswap_(integer *, real *, integer *, real *, integer *
+), strsm_(char *, char *, char *, char *, integer *, integer *,
+ real *, real *, integer *, real *, integer *), sgbtf2_(integer *, integer *, integer *, integer
+ *, real *, integer *, integer *, integer *), xerbla_(char *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *), isamax_(integer *, real *,
+ integer *);
+ extern /* Subroutine */ int slaswp_(integer *, real *, integer *, integer
+ *, integer *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGBTRF computes an LU factorization of a real m-by-n band matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* This is the blocked version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input/output) REAL array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows KL+1 to */
+/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */
+
+/* On exit, details of the factorization: U is stored as an */
+/* upper triangular band matrix with KL+KU superdiagonals in */
+/* rows 1 to KL+KU+1, and the multipliers used during the */
+/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */
+/* See below for further details. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* M = N = 6, KL = 2, KU = 1: */
+
+/* On entry: On exit: */
+
+/* * * * + + + * * * u14 u25 u36 */
+/* * * + + + + * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */
+/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */
+
+/* Array elements marked * are not used by the routine; elements marked */
+/* + need not be set on entry, but are required by the routine to store */
+/* elements of U because of fill-in resulting from the row interchanges. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* KV is the number of superdiagonals in the factor U, allowing for */
+/* fill-in */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --ipiv;
+
+ /* Function Body */
+ kv = *ku + *kl;
+
+/* Test the input parameters. */
+
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*ldab < *kl + kv + 1) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGBTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment */
+
+ nb = ilaenv_(&c__1, "SGBTRF", " ", m, n, kl, ku);
+
+/* The block size must not exceed the limit set by the size of the */
+/* local arrays WORK13 and WORK31. */
+
+ nb = min(nb,64);
+
+ if (nb <= 1 || nb > *kl) {
+
+/* Use unblocked code */
+
+ sgbtf2_(m, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info);
+ } else {
+
+/* Use blocked code */
+
+/* Zero the superdiagonal elements of the work array WORK13 */
+
+ i__1 = nb;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work13[i__ + j * 65 - 66] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Zero the subdiagonal elements of the work array WORK31 */
+
+ i__1 = nb;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = nb;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ work31[i__ + j * 65 - 66] = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Gaussian elimination with partial pivoting */
+
+/* Set fill-in elements in columns KU+2 to KV to zero */
+
+ i__1 = min(kv,*n);
+ for (j = *ku + 2; j <= i__1; ++j) {
+ i__2 = *kl;
+ for (i__ = kv - j + 2; i__ <= i__2; ++i__) {
+ ab[i__ + j * ab_dim1] = 0.f;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* JU is the index of the last column affected by the current */
+/* stage of the factorization */
+
+ ju = 1;
+
+ i__1 = min(*m,*n);
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = min(*m,*n) - j + 1;
+ jb = min(i__3,i__4);
+
+/* The active part of the matrix is partitioned */
+
+/* A11 A12 A13 */
+/* A21 A22 A23 */
+/* A31 A32 A33 */
+
+/* Here A11, A21 and A31 denote the current block of JB columns */
+/* which is about to be factorized. The number of rows in the */
+/* partitioning are JB, I2, I3 respectively, and the numbers */
+/* of columns are JB, J2, J3. The superdiagonal elements of A13 */
+/* and the subdiagonal elements of A31 lie outside the band. */
+
+/* Computing MIN */
+ i__3 = *kl - jb, i__4 = *m - j - jb + 1;
+ i2 = min(i__3,i__4);
+/* Computing MIN */
+ i__3 = jb, i__4 = *m - j - *kl + 1;
+ i3 = min(i__3,i__4);
+
+/* J2 and J3 are computed after JU has been updated. */
+
+/* Factorize the current block of JB columns */
+
+ i__3 = j + jb - 1;
+ for (jj = j; jj <= i__3; ++jj) {
+
+/* Set fill-in elements in column JJ+KV to zero */
+
+ if (jj + kv <= *n) {
+ i__4 = *kl;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ ab[i__ + (jj + kv) * ab_dim1] = 0.f;
+/* L70: */
+ }
+ }
+
+/* Find pivot and test for singularity. KM is the number of */
+/* subdiagonal elements in the current column. */
+
+/* Computing MIN */
+ i__4 = *kl, i__5 = *m - jj;
+ km = min(i__4,i__5);
+ i__4 = km + 1;
+ jp = isamax_(&i__4, &ab[kv + 1 + jj * ab_dim1], &c__1);
+ ipiv[jj] = jp + jj - j;
+ if (ab[kv + jp + jj * ab_dim1] != 0.f) {
+/* Computing MAX */
+/* Computing MIN */
+ i__6 = jj + *ku + jp - 1;
+ i__4 = ju, i__5 = min(i__6,*n);
+ ju = max(i__4,i__5);
+ if (jp != 1) {
+
+/* Apply interchange to columns J to J+JB-1 */
+
+ if (jp + jj - 1 < j + *kl) {
+
+ i__4 = *ldab - 1;
+ i__5 = *ldab - 1;
+ sswap_(&jb, &ab[kv + 1 + jj - j + j * ab_dim1], &
+ i__4, &ab[kv + jp + jj - j + j * ab_dim1],
+ &i__5);
+ } else {
+
+/* The interchange affects columns J to JJ-1 of A31 */
+/* which are stored in the work array WORK31 */
+
+ i__4 = jj - j;
+ i__5 = *ldab - 1;
+ sswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1],
+ &i__5, &work31[jp + jj - j - *kl - 1], &
+ c__65);
+ i__4 = j + jb - jj;
+ i__5 = *ldab - 1;
+ i__6 = *ldab - 1;
+ sswap_(&i__4, &ab[kv + 1 + jj * ab_dim1], &i__5, &
+ ab[kv + jp + jj * ab_dim1], &i__6);
+ }
+ }
+
+/* Compute multipliers */
+
+ r__1 = 1.f / ab[kv + 1 + jj * ab_dim1];
+ sscal_(&km, &r__1, &ab[kv + 2 + jj * ab_dim1], &c__1);
+
+/* Update trailing submatrix within the band and within */
+/* the current block. JM is the index of the last column */
+/* which needs to be updated. */
+
+/* Computing MIN */
+ i__4 = ju, i__5 = j + jb - 1;
+ jm = min(i__4,i__5);
+ if (jm > jj) {
+ i__4 = jm - jj;
+ i__5 = *ldab - 1;
+ i__6 = *ldab - 1;
+ sger_(&km, &i__4, &c_b18, &ab[kv + 2 + jj * ab_dim1],
+ &c__1, &ab[kv + (jj + 1) * ab_dim1], &i__5, &
+ ab[kv + 1 + (jj + 1) * ab_dim1], &i__6);
+ }
+ } else {
+
+/* If pivot is zero, set INFO to the index of the pivot */
+/* unless a zero pivot has already been found. */
+
+ if (*info == 0) {
+ *info = jj;
+ }
+ }
+
+/* Copy current column of A31 into the work array WORK31 */
+
+/* Computing MIN */
+ i__4 = jj - j + 1;
+ nw = min(i__4,i3);
+ if (nw > 0) {
+ scopy_(&nw, &ab[kv + *kl + 1 - jj + j + jj * ab_dim1], &
+ c__1, &work31[(jj - j + 1) * 65 - 65], &c__1);
+ }
+/* L80: */
+ }
+ if (j + jb <= *n) {
+
+/* Apply the row interchanges to the other blocks. */
+
+/* Computing MIN */
+ i__3 = ju - j + 1;
+ j2 = min(i__3,kv) - jb;
+/* Computing MAX */
+ i__3 = 0, i__4 = ju - j - kv + 1;
+ j3 = max(i__3,i__4);
+
+/* Use SLASWP to apply the row interchanges to A12, A22, and */
+/* A32. */
+
+ i__3 = *ldab - 1;
+ slaswp_(&j2, &ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__3, &
+ c__1, &jb, &ipiv[j], &c__1);
+
+/* Adjust the pivot indices. */
+
+ i__3 = j + jb - 1;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ ipiv[i__] = ipiv[i__] + j - 1;
+/* L90: */
+ }
+
+/* Apply the row interchanges to A13, A23, and A33 */
+/* columnwise. */
+
+ k2 = j - 1 + jb + j2;
+ i__3 = j3;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ jj = k2 + i__;
+ i__4 = j + jb - 1;
+ for (ii = j + i__ - 1; ii <= i__4; ++ii) {
+ ip = ipiv[ii];
+ if (ip != ii) {
+ temp = ab[kv + 1 + ii - jj + jj * ab_dim1];
+ ab[kv + 1 + ii - jj + jj * ab_dim1] = ab[kv + 1 +
+ ip - jj + jj * ab_dim1];
+ ab[kv + 1 + ip - jj + jj * ab_dim1] = temp;
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+
+/* Update the relevant part of the trailing submatrix */
+
+ if (j2 > 0) {
+
+/* Update A12 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ strsm_("Left", "Lower", "No transpose", "Unit", &jb, &j2,
+ &c_b31, &ab[kv + 1 + j * ab_dim1], &i__3, &ab[kv
+ + 1 - jb + (j + jb) * ab_dim1], &i__4);
+
+ if (i2 > 0) {
+
+/* Update A22 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ i__5 = *ldab - 1;
+ sgemm_("No transpose", "No transpose", &i2, &j2, &jb,
+ &c_b18, &ab[kv + 1 + jb + j * ab_dim1], &i__3,
+ &ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__4,
+ &c_b31, &ab[kv + 1 + (j + jb) * ab_dim1], &
+ i__5);
+ }
+
+ if (i3 > 0) {
+
+/* Update A32 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ sgemm_("No transpose", "No transpose", &i3, &j2, &jb,
+ &c_b18, work31, &c__65, &ab[kv + 1 - jb + (j
+ + jb) * ab_dim1], &i__3, &c_b31, &ab[kv + *kl
+ + 1 - jb + (j + jb) * ab_dim1], &i__4);
+ }
+ }
+
+ if (j3 > 0) {
+
+/* Copy the lower triangle of A13 into the work array */
+/* WORK13 */
+
+ i__3 = j3;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = jb;
+ for (ii = jj; ii <= i__4; ++ii) {
+ work13[ii + jj * 65 - 66] = ab[ii - jj + 1 + (jj
+ + j + kv - 1) * ab_dim1];
+/* L120: */
+ }
+/* L130: */
+ }
+
+/* Update A13 in the work array */
+
+ i__3 = *ldab - 1;
+ strsm_("Left", "Lower", "No transpose", "Unit", &jb, &j3,
+ &c_b31, &ab[kv + 1 + j * ab_dim1], &i__3, work13,
+ &c__65);
+
+ if (i2 > 0) {
+
+/* Update A23 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ sgemm_("No transpose", "No transpose", &i2, &j3, &jb,
+ &c_b18, &ab[kv + 1 + jb + j * ab_dim1], &i__3,
+ work13, &c__65, &c_b31, &ab[jb + 1 + (j + kv)
+ * ab_dim1], &i__4);
+ }
+
+ if (i3 > 0) {
+
+/* Update A33 */
+
+ i__3 = *ldab - 1;
+ sgemm_("No transpose", "No transpose", &i3, &j3, &jb,
+ &c_b18, work31, &c__65, work13, &c__65, &
+ c_b31, &ab[*kl + 1 + (j + kv) * ab_dim1], &
+ i__3);
+ }
+
+/* Copy the lower triangle of A13 back into place */
+
+ i__3 = j3;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = jb;
+ for (ii = jj; ii <= i__4; ++ii) {
+ ab[ii - jj + 1 + (jj + j + kv - 1) * ab_dim1] =
+ work13[ii + jj * 65 - 66];
+/* L140: */
+ }
+/* L150: */
+ }
+ }
+ } else {
+
+/* Adjust the pivot indices. */
+
+ i__3 = j + jb - 1;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ ipiv[i__] = ipiv[i__] + j - 1;
+/* L160: */
+ }
+ }
+
+/* Partially undo the interchanges in the current block to */
+/* restore the upper triangular form of A31 and copy the upper */
+/* triangle of A31 back into place */
+
+ i__3 = j;
+ for (jj = j + jb - 1; jj >= i__3; --jj) {
+ jp = ipiv[jj] - jj + 1;
+ if (jp != 1) {
+
+/* Apply interchange to columns J to JJ-1 */
+
+ if (jp + jj - 1 < j + *kl) {
+
+/* The interchange does not affect A31 */
+
+ i__4 = jj - j;
+ i__5 = *ldab - 1;
+ i__6 = *ldab - 1;
+ sswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], &
+ i__5, &ab[kv + jp + jj - j + j * ab_dim1], &
+ i__6);
+ } else {
+
+/* The interchange does affect A31 */
+
+ i__4 = jj - j;
+ i__5 = *ldab - 1;
+ sswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], &
+ i__5, &work31[jp + jj - j - *kl - 1], &c__65);
+ }
+ }
+
+/* Copy the current column of A31 back into place */
+
+/* Computing MIN */
+ i__4 = i3, i__5 = jj - j + 1;
+ nw = min(i__4,i__5);
+ if (nw > 0) {
+ scopy_(&nw, &work31[(jj - j + 1) * 65 - 65], &c__1, &ab[
+ kv + *kl + 1 - jj + j + jj * ab_dim1], &c__1);
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+
+ return 0;
+
+/* End of SGBTRF */
+
+} /* sgbtrf_ */
diff --git a/SRC/sgbtrs.c b/SRC/sgbtrs.c
new file mode 100644
index 0000000..b99d3d2
--- /dev/null
+++ b/SRC/sgbtrs.c
@@ -0,0 +1,242 @@
+/* sgbtrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b7 = -1.f;
+static integer c__1 = 1;
+static real c_b23 = 1.f;
+
+/* Subroutine */ int sgbtrs_(char *trans, integer *n, integer *kl, integer *
+ ku, integer *nrhs, real *ab, integer *ldab, integer *ipiv, real *b,
+ integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, l, kd, lm;
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ logical lnoti;
+ extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
+ integer *), stbsv_(char *, char *, char *, integer *, integer *,
+ real *, integer *, real *, integer *),
+ xerbla_(char *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGBTRS solves a system of linear equations */
+/* A * X = B or A' * X = B */
+/* with a general band matrix A using the LU factorization computed */
+/* by SGBTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A'* X = B (Transpose) */
+/* = 'C': A'* X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AB (input) REAL array, dimension (LDAB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by SGBTRF. U is stored as an upper triangular band */
+/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
+/* the multipliers used during the factorization are stored in */
+/* rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= N, row i of the matrix was */
+/* interchanged with row IPIV(i). */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*ldab < (*kl << 1) + *ku + 1) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGBTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ kd = *ku + *kl + 1;
+ lnoti = *kl > 0;
+
+ if (notran) {
+
+/* Solve A*X = B. */
+
+/* Solve L*X = B, overwriting B with X. */
+
+/* L is represented as a product of permutations and unit lower */
+/* triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), */
+/* where each transformation L(i) is a rank-one modification of */
+/* the identity matrix. */
+
+ if (lnoti) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *kl, i__3 = *n - j;
+ lm = min(i__2,i__3);
+ l = ipiv[j];
+ if (l != j) {
+ sswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb);
+ }
+ sger_(&lm, nrhs, &c_b7, &ab[kd + 1 + j * ab_dim1], &c__1, &b[
+ j + b_dim1], ldb, &b[j + 1 + b_dim1], ldb);
+/* L10: */
+ }
+ }
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Solve U*X = B, overwriting B with X. */
+
+ i__2 = *kl + *ku;
+ stbsv_("Upper", "No transpose", "Non-unit", n, &i__2, &ab[
+ ab_offset], ldab, &b[i__ * b_dim1 + 1], &c__1);
+/* L20: */
+ }
+
+ } else {
+
+/* Solve A'*X = B. */
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Solve U'*X = B, overwriting B with X. */
+
+ i__2 = *kl + *ku;
+ stbsv_("Upper", "Transpose", "Non-unit", n, &i__2, &ab[ab_offset],
+ ldab, &b[i__ * b_dim1 + 1], &c__1);
+/* L30: */
+ }
+
+/* Solve L'*X = B, overwriting B with X. */
+
+ if (lnoti) {
+ for (j = *n - 1; j >= 1; --j) {
+/* Computing MIN */
+ i__1 = *kl, i__2 = *n - j;
+ lm = min(i__1,i__2);
+ sgemv_("Transpose", &lm, nrhs, &c_b7, &b[j + 1 + b_dim1], ldb,
+ &ab[kd + 1 + j * ab_dim1], &c__1, &c_b23, &b[j +
+ b_dim1], ldb);
+ l = ipiv[j];
+ if (l != j) {
+ sswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb);
+ }
+/* L40: */
+ }
+ }
+ }
+ return 0;
+
+/* End of SGBTRS */
+
+} /* sgbtrs_ */
diff --git a/SRC/sgebak.c b/SRC/sgebak.c
new file mode 100644
index 0000000..349055f
--- /dev/null
+++ b/SRC/sgebak.c
@@ -0,0 +1,235 @@
+/* sgebak.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sgebak_(char *job, char *side, integer *n, integer *ilo,
+ integer *ihi, real *scale, integer *m, real *v, integer *ldv, integer
+ *info)
+{
+ /* System generated locals */
+ integer v_dim1, v_offset, i__1;
+
+ /* Local variables */
+ integer i__, k;
+ real s;
+ integer ii;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ logical leftv;
+ extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
+ integer *), xerbla_(char *, integer *);
+ logical rightv;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGEBAK forms the right or left eigenvectors of a real general matrix */
+/* by backward transformation on the computed eigenvectors of the */
+/* balanced matrix output by SGEBAL. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies the type of backward transformation required: */
+/* = 'N', do nothing, return immediately; */
+/* = 'P', do backward transformation for permutation only; */
+/* = 'S', do backward transformation for scaling only; */
+/* = 'B', do backward transformations for both permutation and */
+/* scaling. */
+/* JOB must be the same as the argument JOB supplied to SGEBAL. */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'R': V contains right eigenvectors; */
+/* = 'L': V contains left eigenvectors. */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrix V. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* The integers ILO and IHI determined by SGEBAL. */
+/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
+
+/* SCALE (input) REAL array, dimension (N) */
+/* Details of the permutation and scaling factors, as returned */
+/* by SGEBAL. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix V. M >= 0. */
+
+/* V (input/output) REAL array, dimension (LDV,M) */
+/* On entry, the matrix of right or left eigenvectors to be */
+/* transformed, as returned by SHSEIN or STREVC. */
+/* On exit, V is overwritten by the transformed eigenvectors. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. LDV >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and Test the input parameters */
+
+ /* Parameter adjustments */
+ --scale;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+
+ /* Function Body */
+ rightv = lsame_(side, "R");
+ leftv = lsame_(side, "L");
+
+ *info = 0;
+ if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
+ && ! lsame_(job, "B")) {
+ *info = -1;
+ } else if (! rightv && ! leftv) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ilo < 1 || *ilo > max(1,*n)) {
+ *info = -4;
+ } else if (*ihi < min(*ilo,*n) || *ihi > *n) {
+ *info = -5;
+ } else if (*m < 0) {
+ *info = -7;
+ } else if (*ldv < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGEBAK", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+ if (*m == 0) {
+ return 0;
+ }
+ if (lsame_(job, "N")) {
+ return 0;
+ }
+
+ if (*ilo == *ihi) {
+ goto L30;
+ }
+
+/* Backward balance */
+
+ if (lsame_(job, "S") || lsame_(job, "B")) {
+
+ if (rightv) {
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ s = scale[i__];
+ sscal_(m, &s, &v[i__ + v_dim1], ldv);
+/* L10: */
+ }
+ }
+
+ if (leftv) {
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ s = 1.f / scale[i__];
+ sscal_(m, &s, &v[i__ + v_dim1], ldv);
+/* L20: */
+ }
+ }
+
+ }
+
+/* Backward permutation */
+
+/* For I = ILO-1 step -1 until 1, */
+/* IHI+1 step 1 until N do -- */
+
+L30:
+ if (lsame_(job, "P") || lsame_(job, "B")) {
+ if (rightv) {
+ i__1 = *n;
+ for (ii = 1; ii <= i__1; ++ii) {
+ i__ = ii;
+ if (i__ >= *ilo && i__ <= *ihi) {
+ goto L40;
+ }
+ if (i__ < *ilo) {
+ i__ = *ilo - ii;
+ }
+ k = scale[i__];
+ if (k == i__) {
+ goto L40;
+ }
+ sswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L40:
+ ;
+ }
+ }
+
+ if (leftv) {
+ i__1 = *n;
+ for (ii = 1; ii <= i__1; ++ii) {
+ i__ = ii;
+ if (i__ >= *ilo && i__ <= *ihi) {
+ goto L50;
+ }
+ if (i__ < *ilo) {
+ i__ = *ilo - ii;
+ }
+ k = scale[i__];
+ if (k == i__) {
+ goto L50;
+ }
+ sswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L50:
+ ;
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SGEBAK */
+
+} /* sgebak_ */
diff --git a/SRC/sgebal.c b/SRC/sgebal.c
new file mode 100644
index 0000000..4c8c9b5
--- /dev/null
+++ b/SRC/sgebal.c
@@ -0,0 +1,400 @@
+/* sgebal.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sgebal_(char *job, integer *n, real *a, integer *lda,
+ integer *ilo, integer *ihi, real *scale, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Local variables */
+ real c__, f, g;
+ integer i__, j, k, l, m;
+ real r__, s, ca, ra;
+ integer ica, ira, iexc;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ sswap_(integer *, real *, integer *, real *, integer *);
+ real sfmin1, sfmin2, sfmax1, sfmax2;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ logical noconv;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGEBAL balances a general real matrix A. This involves, first, */
+/* permuting A by a similarity transformation to isolate eigenvalues */
+/* in the first 1 to ILO-1 and last IHI+1 to N elements on the */
+/* diagonal; and second, applying a diagonal similarity transformation */
+/* to rows and columns ILO to IHI to make the rows and columns as */
+/* close in norm as possible. Both steps are optional. */
+
+/* Balancing may reduce the 1-norm of the matrix, and improve the */
+/* accuracy of the computed eigenvalues and/or eigenvectors. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies the operations to be performed on A: */
+/* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 */
+/* for i = 1,...,N; */
+/* = 'P': permute only; */
+/* = 'S': scale only; */
+/* = 'B': both permute and scale. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the input matrix A. */
+/* On exit, A is overwritten by the balanced matrix. */
+/* If JOB = 'N', A is not referenced. */
+/* See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* ILO (output) INTEGER */
+/* IHI (output) INTEGER */
+/* ILO and IHI are set to integers such that on exit */
+/* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. */
+/* If JOB = 'N' or 'S', ILO = 1 and IHI = N. */
+
+/* SCALE (output) REAL array, dimension (N) */
+/* Details of the permutations and scaling factors applied to */
+/* A. If P(j) is the index of the row and column interchanged */
+/* with row and column j and D(j) is the scaling factor */
+/* applied to row and column j, then */
+/* SCALE(j) = P(j) for j = 1,...,ILO-1 */
+/* = D(j) for j = ILO,...,IHI */
+/* = P(j) for j = IHI+1,...,N. */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The permutations consist of row and column interchanges which put */
+/* the matrix in the form */
+
+/* ( T1 X Y ) */
+/* P A P = ( 0 B Z ) */
+/* ( 0 0 T2 ) */
+
+/* where T1 and T2 are upper triangular matrices whose eigenvalues lie */
+/* along the diagonal. The column indices ILO and IHI mark the starting */
+/* and ending columns of the submatrix B. Balancing consists of applying */
+/* a diagonal similarity transformation inv(D) * B * D to make the */
+/* 1-norms of each row of B and its corresponding column nearly equal. */
+/* The output matrix is */
+
+/* ( T1 X*D Y ) */
+/* ( 0 inv(D)*B*D inv(D)*Z ). */
+/* ( 0 0 T2 ) */
+
+/* Information about the permutations P and the diagonal matrix D is */
+/* returned in the vector SCALE. */
+
+/* This subroutine is based on the EISPACK routine BALANC. */
+
+/* Modified by Tzu-Yi Chen, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --scale;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
+ && ! lsame_(job, "B")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGEBAL", &i__1);
+ return 0;
+ }
+
+ k = 1;
+ l = *n;
+
+ if (*n == 0) {
+ goto L210;
+ }
+
+ if (lsame_(job, "N")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ scale[i__] = 1.f;
+/* L10: */
+ }
+ goto L210;
+ }
+
+ if (lsame_(job, "S")) {
+ goto L120;
+ }
+
+/* Permutation to isolate eigenvalues if possible */
+
+ goto L50;
+
+/* Row and column exchange. */
+
+L20:
+ scale[m] = (real) j;
+ if (j == m) {
+ goto L30;
+ }
+
+ sswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
+ i__1 = *n - k + 1;
+ sswap_(&i__1, &a[j + k * a_dim1], lda, &a[m + k * a_dim1], lda);
+
+L30:
+ switch (iexc) {
+ case 1: goto L40;
+ case 2: goto L80;
+ }
+
+/* Search for rows isolating an eigenvalue and push them down. */
+
+L40:
+ if (l == 1) {
+ goto L210;
+ }
+ --l;
+
+L50:
+ for (j = l; j >= 1; --j) {
+
+ i__1 = l;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (i__ == j) {
+ goto L60;
+ }
+ if (a[j + i__ * a_dim1] != 0.f) {
+ goto L70;
+ }
+L60:
+ ;
+ }
+
+ m = l;
+ iexc = 1;
+ goto L20;
+L70:
+ ;
+ }
+
+ goto L90;
+
+/* Search for columns isolating an eigenvalue and push them left. */
+
+L80:
+ ++k;
+
+L90:
+ i__1 = l;
+ for (j = k; j <= i__1; ++j) {
+
+ i__2 = l;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ if (i__ == j) {
+ goto L100;
+ }
+ if (a[i__ + j * a_dim1] != 0.f) {
+ goto L110;
+ }
+L100:
+ ;
+ }
+
+ m = k;
+ iexc = 2;
+ goto L20;
+L110:
+ ;
+ }
+
+L120:
+ i__1 = l;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ scale[i__] = 1.f;
+/* L130: */
+ }
+
+ if (lsame_(job, "P")) {
+ goto L210;
+ }
+
+/* Balance the submatrix in rows K to L. */
+
+/* Iterative loop for norm reduction */
+
+ sfmin1 = slamch_("S") / slamch_("P");
+ sfmax1 = 1.f / sfmin1;
+ sfmin2 = sfmin1 * 2.f;
+ sfmax2 = 1.f / sfmin2;
+L140:
+ noconv = FALSE_;
+
+ i__1 = l;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ c__ = 0.f;
+ r__ = 0.f;
+
+ i__2 = l;
+ for (j = k; j <= i__2; ++j) {
+ if (j == i__) {
+ goto L150;
+ }
+ c__ += (r__1 = a[j + i__ * a_dim1], dabs(r__1));
+ r__ += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+L150:
+ ;
+ }
+ ica = isamax_(&l, &a[i__ * a_dim1 + 1], &c__1);
+ ca = (r__1 = a[ica + i__ * a_dim1], dabs(r__1));
+ i__2 = *n - k + 1;
+ ira = isamax_(&i__2, &a[i__ + k * a_dim1], lda);
+ ra = (r__1 = a[i__ + (ira + k - 1) * a_dim1], dabs(r__1));
+
+/* Guard against zero C or R due to underflow. */
+
+ if (c__ == 0.f || r__ == 0.f) {
+ goto L200;
+ }
+ g = r__ / 2.f;
+ f = 1.f;
+ s = c__ + r__;
+L160:
+/* Computing MAX */
+ r__1 = max(f,c__);
+/* Computing MIN */
+ r__2 = min(r__,g);
+ if (c__ >= g || dmax(r__1,ca) >= sfmax2 || dmin(r__2,ra) <= sfmin2) {
+ goto L170;
+ }
+ f *= 2.f;
+ c__ *= 2.f;
+ ca *= 2.f;
+ r__ /= 2.f;
+ g /= 2.f;
+ ra /= 2.f;
+ goto L160;
+
+L170:
+ g = c__ / 2.f;
+L180:
+/* Computing MIN */
+ r__1 = min(f,c__), r__1 = min(r__1,g);
+ if (g < r__ || dmax(r__,ra) >= sfmax2 || dmin(r__1,ca) <= sfmin2) {
+ goto L190;
+ }
+ f /= 2.f;
+ c__ /= 2.f;
+ g /= 2.f;
+ ca /= 2.f;
+ r__ *= 2.f;
+ ra *= 2.f;
+ goto L180;
+
+/* Now balance. */
+
+L190:
+ if (c__ + r__ >= s * .95f) {
+ goto L200;
+ }
+ if (f < 1.f && scale[i__] < 1.f) {
+ if (f * scale[i__] <= sfmin1) {
+ goto L200;
+ }
+ }
+ if (f > 1.f && scale[i__] > 1.f) {
+ if (scale[i__] >= sfmax1 / f) {
+ goto L200;
+ }
+ }
+ g = 1.f / f;
+ scale[i__] *= f;
+ noconv = TRUE_;
+
+ i__2 = *n - k + 1;
+ sscal_(&i__2, &g, &a[i__ + k * a_dim1], lda);
+ sscal_(&l, &f, &a[i__ * a_dim1 + 1], &c__1);
+
+L200:
+ ;
+ }
+
+ if (noconv) {
+ goto L140;
+ }
+
+L210:
+ *ilo = k;
+ *ihi = l;
+
+ return 0;
+
+/* End of SGEBAL */
+
+} /* sgebal_ */
diff --git a/SRC/sgebd2.c b/SRC/sgebd2.c
new file mode 100644
index 0000000..a5855ac
--- /dev/null
+++ b/SRC/sgebd2.c
@@ -0,0 +1,303 @@
+/* sgebd2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sgebd2_(integer *m, integer *n, real *a, integer *lda,
+ real *d__, real *e, real *tauq, real *taup, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__;
+ extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *), xerbla_(
+ char *, integer *), slarfg_(integer *, real *, real *,
+ integer *, real *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGEBD2 reduces a real general m by n matrix A to upper or lower */
+/* bidiagonal form B by an orthogonal transformation: Q' * A * P = B. */
+
+/* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows in the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns in the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the m by n general matrix to be reduced. */
+/* On exit, */
+/* if m >= n, the diagonal and the first superdiagonal are */
+/* overwritten with the upper bidiagonal matrix B; the */
+/* elements below the diagonal, with the array TAUQ, represent */
+/* the orthogonal matrix Q as a product of elementary */
+/* reflectors, and the elements above the first superdiagonal, */
+/* with the array TAUP, represent the orthogonal matrix P as */
+/* a product of elementary reflectors; */
+/* if m < n, the diagonal and the first subdiagonal are */
+/* overwritten with the lower bidiagonal matrix B; the */
+/* elements below the first subdiagonal, with the array TAUQ, */
+/* represent the orthogonal matrix Q as a product of */
+/* elementary reflectors, and the elements above the diagonal, */
+/* with the array TAUP, represent the orthogonal matrix P as */
+/* a product of elementary reflectors. */
+/* See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* D (output) REAL array, dimension (min(M,N)) */
+/* The diagonal elements of the bidiagonal matrix B: */
+/* D(i) = A(i,i). */
+
+/* E (output) REAL array, dimension (min(M,N)-1) */
+/* The off-diagonal elements of the bidiagonal matrix B: */
+/* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */
+/* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */
+
+/* TAUQ (output) REAL array dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the orthogonal matrix Q. See Further Details. */
+
+/* TAUP (output) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the orthogonal matrix P. See Further Details. */
+
+/* WORK (workspace) REAL array, dimension (max(M,N)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrices Q and P are represented as products of elementary */
+/* reflectors: */
+
+/* If m >= n, */
+
+/* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) */
+
+/* Each H(i) and G(i) has the form: */
+
+/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
+
+/* where tauq and taup are real scalars, and v and u are real vectors; */
+/* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); */
+/* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); */
+/* tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* If m < n, */
+
+/* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) */
+
+/* Each H(i) and G(i) has the form: */
+
+/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
+
+/* where tauq and taup are real scalars, and v and u are real vectors; */
+/* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); */
+/* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); */
+/* tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* The contents of A on exit are illustrated by the following examples: */
+
+/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
+
+/* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) */
+/* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) */
+/* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) */
+/* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) */
+/* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) */
+/* ( v1 v2 v3 v4 v5 ) */
+
+/* where d and e denote diagonal and off-diagonal elements of B, vi */
+/* denotes an element of the vector defining H(i), and ui an element of */
+/* the vector defining G(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ --tauq;
+ --taup;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("SGEBD2", &i__1);
+ return 0;
+ }
+
+ if (*m >= *n) {
+
+/* Reduce to upper bidiagonal form */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
+
+ i__2 = *m - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ slarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3, *m)+ i__ *
+ a_dim1], &c__1, &tauq[i__]);
+ d__[i__] = a[i__ + i__ * a_dim1];
+ a[i__ + i__ * a_dim1] = 1.f;
+
+/* Apply H(i) to A(i:m,i+1:n) from the left */
+
+ if (i__ < *n) {
+ i__2 = *m - i__ + 1;
+ i__3 = *n - i__;
+ slarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
+ tauq[i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]
+);
+ }
+ a[i__ + i__ * a_dim1] = d__[i__];
+
+ if (i__ < *n) {
+
+/* Generate elementary reflector G(i) to annihilate */
+/* A(i,i+2:n) */
+
+ i__2 = *n - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ slarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + min(
+ i__3, *n)* a_dim1], lda, &taup[i__]);
+ e[i__] = a[i__ + (i__ + 1) * a_dim1];
+ a[i__ + (i__ + 1) * a_dim1] = 1.f;
+
+/* Apply G(i) to A(i+1:m,i+1:n) from the right */
+
+ i__2 = *m - i__;
+ i__3 = *n - i__;
+ slarf_("Right", &i__2, &i__3, &a[i__ + (i__ + 1) * a_dim1],
+ lda, &taup[i__], &a[i__ + 1 + (i__ + 1) * a_dim1],
+ lda, &work[1]);
+ a[i__ + (i__ + 1) * a_dim1] = e[i__];
+ } else {
+ taup[i__] = 0.f;
+ }
+/* L10: */
+ }
+ } else {
+
+/* Reduce to lower bidiagonal form */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Generate elementary reflector G(i) to annihilate A(i,i+1:n) */
+
+ i__2 = *n - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ slarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3, *n)*
+ a_dim1], lda, &taup[i__]);
+ d__[i__] = a[i__ + i__ * a_dim1];
+ a[i__ + i__ * a_dim1] = 1.f;
+
+/* Apply G(i) to A(i+1:m,i:n) from the right */
+
+ if (i__ < *m) {
+ i__2 = *m - i__;
+ i__3 = *n - i__ + 1;
+ slarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &
+ taup[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]);
+ }
+ a[i__ + i__ * a_dim1] = d__[i__];
+
+ if (i__ < *m) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* A(i+2:m,i) */
+
+ i__2 = *m - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ slarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *m)+
+ i__ * a_dim1], &c__1, &tauq[i__]);
+ e[i__] = a[i__ + 1 + i__ * a_dim1];
+ a[i__ + 1 + i__ * a_dim1] = 1.f;
+
+/* Apply H(i) to A(i+1:m,i+1:n) from the left */
+
+ i__2 = *m - i__;
+ i__3 = *n - i__;
+ slarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &
+ c__1, &tauq[i__], &a[i__ + 1 + (i__ + 1) * a_dim1],
+ lda, &work[1]);
+ a[i__ + 1 + i__ * a_dim1] = e[i__];
+ } else {
+ tauq[i__] = 0.f;
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+/* End of SGEBD2 */
+
+} /* sgebd2_ */
diff --git a/SRC/sgebrd.c b/SRC/sgebrd.c
new file mode 100644
index 0000000..d0a0cef
--- /dev/null
+++ b/SRC/sgebrd.c
@@ -0,0 +1,336 @@
+/* sgebrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+static real c_b21 = -1.f;
+static real c_b22 = 1.f;
+
+/* Subroutine */ int sgebrd_(integer *m, integer *n, real *a, integer *lda,
+ real *d__, real *e, real *tauq, real *taup, real *work, integer *
+ lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, nb, nx;
+ real ws;
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ integer minmn;
+ extern /* Subroutine */ int sgebd2_(integer *, integer *, real *, integer
+ *, real *, real *, real *, real *, real *, integer *), slabrd_(
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, real *, real *, real *, integer *, real *, integer *), xerbla_(
+ char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwrkx, ldwrky, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGEBRD reduces a general real M-by-N matrix A to upper or lower */
+/* bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. */
+
+/* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows in the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns in the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N general matrix to be reduced. */
+/* On exit, */
+/* if m >= n, the diagonal and the first superdiagonal are */
+/* overwritten with the upper bidiagonal matrix B; the */
+/* elements below the diagonal, with the array TAUQ, represent */
+/* the orthogonal matrix Q as a product of elementary */
+/* reflectors, and the elements above the first superdiagonal, */
+/* with the array TAUP, represent the orthogonal matrix P as */
+/* a product of elementary reflectors; */
+/* if m < n, the diagonal and the first subdiagonal are */
+/* overwritten with the lower bidiagonal matrix B; the */
+/* elements below the first subdiagonal, with the array TAUQ, */
+/* represent the orthogonal matrix Q as a product of */
+/* elementary reflectors, and the elements above the diagonal, */
+/* with the array TAUP, represent the orthogonal matrix P as */
+/* a product of elementary reflectors. */
+/* See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* D (output) REAL array, dimension (min(M,N)) */
+/* The diagonal elements of the bidiagonal matrix B: */
+/* D(i) = A(i,i). */
+
+/* E (output) REAL array, dimension (min(M,N)-1) */
+/* The off-diagonal elements of the bidiagonal matrix B: */
+/* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */
+/* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */
+
+/* TAUQ (output) REAL array dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the orthogonal matrix Q. See Further Details. */
+
+/* TAUP (output) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the orthogonal matrix P. See Further Details. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(1,M,N). */
+/* For optimum performance LWORK >= (M+N)*NB, where NB */
+/* is the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrices Q and P are represented as products of elementary */
+/* reflectors: */
+
+/* If m >= n, */
+
+/* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) */
+
+/* Each H(i) and G(i) has the form: */
+
+/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
+
+/* where tauq and taup are real scalars, and v and u are real vectors; */
+/* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); */
+/* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); */
+/* tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* If m < n, */
+
+/* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) */
+
+/* Each H(i) and G(i) has the form: */
+
+/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
+
+/* where tauq and taup are real scalars, and v and u are real vectors; */
+/* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); */
+/* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); */
+/* tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* The contents of A on exit are illustrated by the following examples: */
+
+/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
+
+/* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) */
+/* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) */
+/* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) */
+/* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) */
+/* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) */
+/* ( v1 v2 v3 v4 v5 ) */
+
+/* where d and e denote diagonal and off-diagonal elements of B, vi */
+/* denotes an element of the vector defining H(i), and ui an element of */
+/* the vector defining G(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ --tauq;
+ --taup;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+/* Computing MAX */
+ i__1 = 1, i__2 = ilaenv_(&c__1, "SGEBRD", " ", m, n, &c_n1, &c_n1);
+ nb = max(i__1,i__2);
+ lwkopt = (*m + *n) * nb;
+ work[1] = (real) lwkopt;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ if (*lwork < max(i__1,*n) && ! lquery) {
+ *info = -10;
+ }
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("SGEBRD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ minmn = min(*m,*n);
+ if (minmn == 0) {
+ work[1] = 1.f;
+ return 0;
+ }
+
+ ws = (real) max(*m,*n);
+ ldwrkx = *m;
+ ldwrky = *n;
+
+ if (nb > 1 && nb < minmn) {
+
+/* Set the crossover point NX. */
+
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__3, "SGEBRD", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+
+/* Determine when to switch from blocked to unblocked code. */
+
+ if (nx < minmn) {
+ ws = (real) ((*m + *n) * nb);
+ if ((real) (*lwork) < ws) {
+
+/* Not enough work space for the optimal NB, consider using */
+/* a smaller block size. */
+
+ nbmin = ilaenv_(&c__2, "SGEBRD", " ", m, n, &c_n1, &c_n1);
+ if (*lwork >= (*m + *n) * nbmin) {
+ nb = *lwork / (*m + *n);
+ } else {
+ nb = 1;
+ nx = minmn;
+ }
+ }
+ }
+ } else {
+ nx = minmn;
+ }
+
+ i__1 = minmn - nx;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+
+/* Reduce rows and columns i:i+nb-1 to bidiagonal form and return */
+/* the matrices X and Y which are needed to update the unreduced */
+/* part of the matrix */
+
+ i__3 = *m - i__ + 1;
+ i__4 = *n - i__ + 1;
+ slabrd_(&i__3, &i__4, &nb, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[
+ i__], &tauq[i__], &taup[i__], &work[1], &ldwrkx, &work[ldwrkx
+ * nb + 1], &ldwrky);
+
+/* Update the trailing submatrix A(i+nb:m,i+nb:n), using an update */
+/* of the form A := A - V*Y' - X*U' */
+
+ i__3 = *m - i__ - nb + 1;
+ i__4 = *n - i__ - nb + 1;
+ sgemm_("No transpose", "Transpose", &i__3, &i__4, &nb, &c_b21, &a[i__
+ + nb + i__ * a_dim1], lda, &work[ldwrkx * nb + nb + 1], &
+ ldwrky, &c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda);
+ i__3 = *m - i__ - nb + 1;
+ i__4 = *n - i__ - nb + 1;
+ sgemm_("No transpose", "No transpose", &i__3, &i__4, &nb, &c_b21, &
+ work[nb + 1], &ldwrkx, &a[i__ + (i__ + nb) * a_dim1], lda, &
+ c_b22, &a[i__ + nb + (i__ + nb) * a_dim1], lda);
+
+/* Copy diagonal and off-diagonal elements of B back into A */
+
+ if (*m >= *n) {
+ i__3 = i__ + nb - 1;
+ for (j = i__; j <= i__3; ++j) {
+ a[j + j * a_dim1] = d__[j];
+ a[j + (j + 1) * a_dim1] = e[j];
+/* L10: */
+ }
+ } else {
+ i__3 = i__ + nb - 1;
+ for (j = i__; j <= i__3; ++j) {
+ a[j + j * a_dim1] = d__[j];
+ a[j + 1 + j * a_dim1] = e[j];
+/* L20: */
+ }
+ }
+/* L30: */
+ }
+
+/* Use unblocked code to reduce the remainder of the matrix */
+
+ i__2 = *m - i__ + 1;
+ i__1 = *n - i__ + 1;
+ sgebd2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], &
+ tauq[i__], &taup[i__], &work[1], &iinfo);
+ work[1] = ws;
+ return 0;
+
+/* End of SGEBRD */
+
+} /* sgebrd_ */
diff --git a/SRC/sgecon.c b/SRC/sgecon.c
new file mode 100644
index 0000000..83a6655
--- /dev/null
+++ b/SRC/sgecon.c
@@ -0,0 +1,224 @@
+/* sgecon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sgecon_(char *norm, integer *n, real *a, integer *lda,
+ real *anorm, real *rcond, real *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ real r__1;
+
+ /* Local variables */
+ real sl;
+ integer ix;
+ real su;
+ integer kase, kase1;
+ real scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *),
+ slacn2_(integer *, real *, real *, integer *, real *, integer *,
+ integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ real ainvnm;
+ logical onenrm;
+ char normin[1];
+ extern /* Subroutine */ int slatrs_(char *, char *, char *, char *,
+ integer *, real *, integer *, real *, real *, real *, integer *);
+ real smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGECON estimates the reciprocal of the condition number of a general */
+/* real matrix A, in either the 1-norm or the infinity-norm, using */
+/* the LU factorization computed by SGETRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as */
+/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The factors L and U from the factorization A = P*L*U */
+/* as computed by SGETRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* ANORM (input) REAL */
+/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */
+/* If NORM = 'I', the infinity-norm of the original matrix A. */
+
+/* RCOND (output) REAL */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
+
+/* WORK (workspace) REAL array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*anorm < 0.f) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGECON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.f;
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ } else if (*anorm == 0.f) {
+ return 0;
+ }
+
+ smlnum = slamch_("Safe minimum");
+
+/* Estimate the norm of inv(A). */
+
+ ainvnm = 0.f;
+ *(unsigned char *)normin = 'N';
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kase = 0;
+L10:
+ slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(L). */
+
+ slatrs_("Lower", "No transpose", "Unit", normin, n, &a[a_offset],
+ lda, &work[1], &sl, &work[(*n << 1) + 1], info);
+
+/* Multiply by inv(U). */
+
+ slatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[
+ a_offset], lda, &work[1], &su, &work[*n * 3 + 1], info);
+ } else {
+
+/* Multiply by inv(U'). */
+
+ slatrs_("Upper", "Transpose", "Non-unit", normin, n, &a[a_offset],
+ lda, &work[1], &su, &work[*n * 3 + 1], info);
+
+/* Multiply by inv(L'). */
+
+ slatrs_("Lower", "Transpose", "Unit", normin, n, &a[a_offset],
+ lda, &work[1], &sl, &work[(*n << 1) + 1], info);
+ }
+
+/* Divide X by 1/(SL*SU) if doing so will not cause overflow. */
+
+ scale = sl * su;
+ *(unsigned char *)normin = 'Y';
+ if (scale != 1.f) {
+ ix = isamax_(n, &work[1], &c__1);
+ if (scale < (r__1 = work[ix], dabs(r__1)) * smlnum || scale ==
+ 0.f) {
+ goto L20;
+ }
+ srscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / ainvnm / *anorm;
+ }
+
+L20:
+ return 0;
+
+/* End of SGECON */
+
+} /* sgecon_ */
diff --git a/SRC/sgeequ.c b/SRC/sgeequ.c
new file mode 100644
index 0000000..baa44c9
--- /dev/null
+++ b/SRC/sgeequ.c
@@ -0,0 +1,296 @@
+/* sgeequ.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sgeequ_(integer *m, integer *n, real *a, integer *lda,
+ real *r__, real *c__, real *rowcnd, real *colcnd, real *amax, integer
+ *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j;
+ real rcmin, rcmax;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum, smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGEEQU computes row and column scalings intended to equilibrate an */
+/* M-by-N matrix A and reduce its condition number. R returns the row */
+/* scale factors and C the column scale factors, chosen to try to make */
+/* the largest element in each row and column of the matrix B with */
+/* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. */
+
+/* R(i) and C(j) are restricted to be between SMLNUM = smallest safe */
+/* number and BIGNUM = largest safe number. Use of these scaling */
+/* factors is not guaranteed to reduce the condition number of A but */
+/* works well in practice. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The M-by-N matrix whose equilibration factors are */
+/* to be computed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* R (output) REAL array, dimension (M) */
+/* If INFO = 0 or INFO > M, R contains the row scale factors */
+/* for A. */
+
+/* C (output) REAL array, dimension (N) */
+/* If INFO = 0, C contains the column scale factors for A. */
+
+/* ROWCND (output) REAL */
+/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */
+/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */
+/* AMAX is neither too large nor too small, it is not worth */
+/* scaling by R. */
+
+/* COLCND (output) REAL */
+/* If INFO = 0, COLCND contains the ratio of the smallest */
+/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */
+/* worth scaling by C. */
+
+/* AMAX (output) REAL */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= M: the i-th row of A is exactly zero */
+/* > M: the (i-M)-th column of A is exactly zero */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGEEQU", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ *rowcnd = 1.f;
+ *colcnd = 1.f;
+ *amax = 0.f;
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+
+/* Compute row scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__[i__] = 0.f;
+/* L10: */
+ }
+
+/* Find the maximum element in each row. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = r__[i__], r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ r__[i__] = dmax(r__2,r__3);
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = rcmax, r__2 = r__[i__];
+ rcmax = dmax(r__1,r__2);
+/* Computing MIN */
+ r__1 = rcmin, r__2 = r__[i__];
+ rcmin = dmin(r__1,r__2);
+/* L40: */
+ }
+ *amax = rcmax;
+
+ if (rcmin == 0.f) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] == 0.f) {
+ *info = i__;
+ return 0;
+ }
+/* L50: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MIN */
+/* Computing MAX */
+ r__2 = r__[i__];
+ r__1 = dmax(r__2,smlnum);
+ r__[i__] = 1.f / dmin(r__1,bignum);
+/* L60: */
+ }
+
+/* Compute ROWCND = min(R(I)) / max(R(I)) */
+
+ *rowcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ }
+
+/* Compute column scale factors */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 0.f;
+/* L70: */
+ }
+
+/* Find the maximum element in each column, */
+/* assuming the row scaling computed above. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = c__[j], r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1)) *
+ r__[i__];
+ c__[j] = dmax(r__2,r__3);
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = c__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = c__[j];
+ rcmax = dmax(r__1,r__2);
+/* L100: */
+ }
+
+ if (rcmin == 0.f) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (c__[j] == 0.f) {
+ *info = *m + j;
+ return 0;
+ }
+/* L110: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+/* Computing MAX */
+ r__2 = c__[j];
+ r__1 = dmax(r__2,smlnum);
+ c__[j] = 1.f / dmin(r__1,bignum);
+/* L120: */
+ }
+
+/* Compute COLCND = min(C(J)) / max(C(J)) */
+
+ *colcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ }
+
+ return 0;
+
+/* End of SGEEQU */
+
+} /* sgeequ_ */
diff --git a/SRC/sgeequb.c b/SRC/sgeequb.c
new file mode 100644
index 0000000..607f5be
--- /dev/null
+++ b/SRC/sgeequb.c
@@ -0,0 +1,324 @@
+/* sgeequb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sgeequb_(integer *m, integer *n, real *a, integer *lda,
+ real *r__, real *c__, real *rowcnd, real *colcnd, real *amax, integer
+ *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double log(doublereal), pow_ri(real *, integer *);
+
+ /* Local variables */
+ integer i__, j;
+ real radix, rcmin, rcmax;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum, logrdx, smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGEEQUB computes row and column scalings intended to equilibrate an */
+/* M-by-N matrix A and reduce its condition number. R returns the row */
+/* scale factors and C the column scale factors, chosen to try to make */
+/* the largest element in each row and column of the matrix B with */
+/* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most */
+/* the radix. */
+
+/* R(i) and C(j) are restricted to be a power of the radix between */
+/* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use */
+/* of these scaling factors is not guaranteed to reduce the condition */
+/* number of A but works well in practice. */
+
+/* This routine differs from SGEEQU by restricting the scaling factors */
+/* to a power of the radix. Baring over- and underflow, scaling by */
+/* these factors introduces no additional rounding errors. However, the */
+/* scaled entries' magnitured are no longer approximately 1 but lie */
+/* between sqrt(radix) and 1/sqrt(radix). */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The M-by-N matrix whose equilibration factors are */
+/* to be computed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* R (output) REAL array, dimension (M) */
+/* If INFO = 0 or INFO > M, R contains the row scale factors */
+/* for A. */
+
+/* C (output) REAL array, dimension (N) */
+/* If INFO = 0, C contains the column scale factors for A. */
+
+/* ROWCND (output) REAL */
+/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */
+/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */
+/* AMAX is neither too large nor too small, it is not worth */
+/* scaling by R. */
+
+/* COLCND (output) REAL */
+/* If INFO = 0, COLCND contains the ratio of the smallest */
+/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */
+/* worth scaling by C. */
+
+/* AMAX (output) REAL */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= M: the i-th row of A is exactly zero */
+/* > M: the (i-M)-th column of A is exactly zero */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGEEQUB", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ *rowcnd = 1.f;
+ *colcnd = 1.f;
+ *amax = 0.f;
+ return 0;
+ }
+
+/* Get machine constants. Assume SMLNUM is a power of the radix. */
+
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+ radix = slamch_("B");
+ logrdx = log(radix);
+
+/* Compute row scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__[i__] = 0.f;
+/* L10: */
+ }
+
+/* Find the maximum element in each row. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = r__[i__], r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ r__[i__] = dmax(r__2,r__3);
+/* L20: */
+ }
+/* L30: */
+ }
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] > 0.f) {
+ i__2 = (integer) (log(r__[i__]) / logrdx);
+ r__[i__] = pow_ri(&radix, &i__2);
+ }
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = rcmax, r__2 = r__[i__];
+ rcmax = dmax(r__1,r__2);
+/* Computing MIN */
+ r__1 = rcmin, r__2 = r__[i__];
+ rcmin = dmin(r__1,r__2);
+/* L40: */
+ }
+ *amax = rcmax;
+
+ if (rcmin == 0.f) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] == 0.f) {
+ *info = i__;
+ return 0;
+ }
+/* L50: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MIN */
+/* Computing MAX */
+ r__2 = r__[i__];
+ r__1 = dmax(r__2,smlnum);
+ r__[i__] = 1.f / dmin(r__1,bignum);
+/* L60: */
+ }
+
+/* Compute ROWCND = min(R(I)) / max(R(I)). */
+
+ *rowcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ }
+
+/* Compute column scale factors */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 0.f;
+/* L70: */
+ }
+
+/* Find the maximum element in each column, */
+/* assuming the row scaling computed above. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = c__[j], r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1)) *
+ r__[i__];
+ c__[j] = dmax(r__2,r__3);
+/* L80: */
+ }
+ if (c__[j] > 0.f) {
+ i__2 = (integer) (log(c__[j]) / logrdx);
+ c__[j] = pow_ri(&radix, &i__2);
+ }
+/* L90: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = c__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = c__[j];
+ rcmax = dmax(r__1,r__2);
+/* L100: */
+ }
+
+ if (rcmin == 0.f) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (c__[j] == 0.f) {
+ *info = *m + j;
+ return 0;
+ }
+/* L110: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+/* Computing MAX */
+ r__2 = c__[j];
+ r__1 = dmax(r__2,smlnum);
+ c__[j] = 1.f / dmin(r__1,bignum);
+/* L120: */
+ }
+
+/* Compute COLCND = min(C(J)) / max(C(J)). */
+
+ *colcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ }
+
+ return 0;
+
+/* End of SGEEQUB */
+
+} /* sgeequb_ */
diff --git a/SRC/sgees.c b/SRC/sgees.c
new file mode 100644
index 0000000..be6b052
--- /dev/null
+++ b/SRC/sgees.c
@@ -0,0 +1,547 @@
+/* sgees.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int sgees_(char *jobvs, char *sort, L_fp select, integer *n,
+ real *a, integer *lda, integer *sdim, real *wr, real *wi, real *vs,
+ integer *ldvs, real *work, integer *lwork, logical *bwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2, i__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real s;
+ integer i1, i2, ip, ihi, ilo;
+ real dum[1], eps, sep;
+ integer ibal;
+ real anrm;
+ integer idum[1], ierr, itau, iwrk, inxt, icond, ieval;
+ extern logical lsame_(char *, char *);
+ logical cursl;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), sswap_(integer *, real *, integer *, real *, integer *
+);
+ logical lst2sl;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ logical scalea;
+ real cscale;
+ extern /* Subroutine */ int sgebak_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *), sgebal_(char *, integer *, real *, integer *,
+ integer *, integer *, real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *), xerbla_(char
+ *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ real bignum;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *,
+ real *, integer *);
+ logical lastsl;
+ extern /* Subroutine */ int sorghr_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *), shseqr_(char
+ *, char *, integer *, integer *, integer *, real *, integer *,
+ real *, real *, real *, integer *, real *, integer *, integer *);
+ integer minwrk, maxwrk;
+ real smlnum;
+ integer hswork;
+ extern /* Subroutine */ int strsen_(char *, char *, logical *, integer *,
+ real *, integer *, real *, integer *, real *, real *, integer *,
+ real *, real *, real *, integer *, integer *, integer *, integer *
+);
+ logical wantst, lquery, wantvs;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+/* .. Function Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGEES computes for an N-by-N real nonsymmetric matrix A, the */
+/* eigenvalues, the real Schur form T, and, optionally, the matrix of */
+/* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). */
+
+/* Optionally, it also orders the eigenvalues on the diagonal of the */
+/* real Schur form so that selected eigenvalues are at the top left. */
+/* The leading columns of Z then form an orthonormal basis for the */
+/* invariant subspace corresponding to the selected eigenvalues. */
+
+/* A matrix is in real Schur form if it is upper quasi-triangular with */
+/* 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the */
+/* form */
+/* [ a b ] */
+/* [ c a ] */
+
+/* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVS (input) CHARACTER*1 */
+/* = 'N': Schur vectors are not computed; */
+/* = 'V': Schur vectors are computed. */
+
+/* SORT (input) CHARACTER*1 */
+/* Specifies whether or not to order the eigenvalues on the */
+/* diagonal of the Schur form. */
+/* = 'N': Eigenvalues are not ordered; */
+/* = 'S': Eigenvalues are ordered (see SELECT). */
+
+/* SELECT (external procedure) LOGICAL FUNCTION of two REAL arguments */
+/* SELECT must be declared EXTERNAL in the calling subroutine. */
+/* If SORT = 'S', SELECT is used to select eigenvalues to sort */
+/* to the top left of the Schur form. */
+/* If SORT = 'N', SELECT is not referenced. */
+/* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if */
+/* SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex */
+/* conjugate pair of eigenvalues is selected, then both complex */
+/* eigenvalues are selected. */
+/* Note that a selected complex eigenvalue may no longer */
+/* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since */
+/* ordering may change the value of complex eigenvalues */
+/* (especially if the eigenvalue is ill-conditioned); in this */
+/* case INFO is set to N+2 (see INFO below). */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+/* On exit, A has been overwritten by its real Schur form T. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* SDIM (output) INTEGER */
+/* If SORT = 'N', SDIM = 0. */
+/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */
+/* for which SELECT is true. (Complex conjugate */
+/* pairs for which SELECT is true for either */
+/* eigenvalue count as 2.) */
+
+/* WR (output) REAL array, dimension (N) */
+/* WI (output) REAL array, dimension (N) */
+/* WR and WI contain the real and imaginary parts, */
+/* respectively, of the computed eigenvalues in the same order */
+/* that they appear on the diagonal of the output Schur form T. */
+/* Complex conjugate pairs of eigenvalues will appear */
+/* consecutively with the eigenvalue having the positive */
+/* imaginary part first. */
+
+/* VS (output) REAL array, dimension (LDVS,N) */
+/* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur */
+/* vectors. */
+/* If JOBVS = 'N', VS is not referenced. */
+
+/* LDVS (input) INTEGER */
+/* The leading dimension of the array VS. LDVS >= 1; if */
+/* JOBVS = 'V', LDVS >= N. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) contains the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,3*N). */
+/* For good performance, LWORK must generally be larger. */
+
+/* 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. */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+/* Not referenced if SORT = 'N'. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, and i is */
+/* <= N: the QR algorithm failed to compute all the */
+/* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI */
+/* contain those eigenvalues which have converged; if */
+/* JOBVS = 'V', VS contains the matrix which reduces A */
+/* to its partially converged Schur form. */
+/* = N+1: the eigenvalues could not be reordered because some */
+/* eigenvalues were too close to separate (the problem */
+/* is very ill-conditioned); */
+/* = N+2: after reordering, roundoff changed values of some */
+/* complex eigenvalues so that leading eigenvalues in */
+/* the Schur form no longer satisfy SELECT=.TRUE. This */
+/* could also be caused by underflow due to scaling. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --wr;
+ --wi;
+ vs_dim1 = *ldvs;
+ vs_offset = 1 + vs_dim1;
+ vs -= vs_offset;
+ --work;
+ --bwork;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ wantvs = lsame_(jobvs, "V");
+ wantst = lsame_(sort, "S");
+ if (! wantvs && ! lsame_(jobvs, "N")) {
+ *info = -1;
+ } else if (! wantst && ! lsame_(sort, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldvs < 1 || wantvs && *ldvs < *n) {
+ *info = -11;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. */
+/* HSWORK refers to the workspace preferred by SHSEQR, as */
+/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
+/* the worst case.) */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ } else {
+ maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "SGEHRD", " ", n, &c__1,
+ n, &c__0);
+ minwrk = *n * 3;
+
+ shseqr_("S", jobvs, n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[1]
+, &vs[vs_offset], ldvs, &work[1], &c_n1, &ieval);
+ hswork = work[1];
+
+ if (! wantvs) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + hswork;
+ maxwrk = max(i__1,i__2);
+ } else {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
+ "SORGHR", " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + hswork;
+ maxwrk = max(i__1,i__2);
+ }
+ }
+ work[1] = (real) maxwrk;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGEES ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *sdim = 0;
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1.f / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = slange_("M", n, n, &a[a_offset], lda, dum);
+ scalea = FALSE_;
+ if (anrm > 0.f && anrm < smlnum) {
+ scalea = TRUE_;
+ cscale = smlnum;
+ } else if (anrm > bignum) {
+ scalea = TRUE_;
+ cscale = bignum;
+ }
+ if (scalea) {
+ slascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Permute the matrix to make it more nearly triangular */
+/* (Workspace: need N) */
+
+ ibal = 1;
+ sgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr);
+
+/* Reduce to upper Hessenberg form */
+/* (Workspace: need 3*N, prefer 2*N+N*NB) */
+
+ itau = *n + ibal;
+ iwrk = *n + itau;
+ i__1 = *lwork - iwrk + 1;
+ sgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
+ &ierr);
+
+ if (wantvs) {
+
+/* Copy Householder vectors to VS */
+
+ slacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs)
+ ;
+
+/* Generate orthogonal matrix in VS */
+/* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+
+ i__1 = *lwork - iwrk + 1;
+ sorghr_(n, &ilo, &ihi, &vs[vs_offset], ldvs, &work[itau], &work[iwrk],
+ &i__1, &ierr);
+ }
+
+ *sdim = 0;
+
+/* Perform QR iteration, accumulating Schur vectors in VS if desired */
+/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ shseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &vs[
+ vs_offset], ldvs, &work[iwrk], &i__1, &ieval);
+ if (ieval > 0) {
+ *info = ieval;
+ }
+
+/* Sort eigenvalues if desired */
+
+ if (wantst && *info == 0) {
+ if (scalea) {
+ slascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wr[1], n, &
+ ierr);
+ slascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wi[1], n, &
+ ierr);
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ bwork[i__] = (*select)(&wr[i__], &wi[i__]);
+/* L10: */
+ }
+
+/* Reorder eigenvalues and transform Schur vectors */
+/* (Workspace: none needed) */
+
+ i__1 = *lwork - iwrk + 1;
+ strsen_("N", jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset],
+ ldvs, &wr[1], &wi[1], sdim, &s, &sep, &work[iwrk], &i__1,
+ idum, &c__1, &icond);
+ if (icond > 0) {
+ *info = *n + icond;
+ }
+ }
+
+ if (wantvs) {
+
+/* Undo balancing */
+/* (Workspace: need N) */
+
+ sgebak_("P", "R", n, &ilo, &ihi, &work[ibal], n, &vs[vs_offset], ldvs,
+ &ierr);
+ }
+
+ if (scalea) {
+
+/* Undo scaling for the Schur form of A */
+
+ slascl_("H", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, &
+ ierr);
+ i__1 = *lda + 1;
+ scopy_(n, &a[a_offset], &i__1, &wr[1], &c__1);
+ if (cscale == smlnum) {
+
+/* If scaling back towards underflow, adjust WI if an */
+/* offdiagonal element of a 2-by-2 block in the Schur form */
+/* underflows. */
+
+ if (ieval > 0) {
+ i1 = ieval + 1;
+ i2 = ihi - 1;
+ i__1 = ilo - 1;
+/* Computing MAX */
+ i__3 = ilo - 1;
+ i__2 = max(i__3,1);
+ slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[
+ 1], &i__2, &ierr);
+ } else if (wantst) {
+ i1 = 1;
+ i2 = *n - 1;
+ } else {
+ i1 = ilo;
+ i2 = ihi - 1;
+ }
+ inxt = i1 - 1;
+ i__1 = i2;
+ for (i__ = i1; i__ <= i__1; ++i__) {
+ if (i__ < inxt) {
+ goto L20;
+ }
+ if (wi[i__] == 0.f) {
+ inxt = i__ + 1;
+ } else {
+ if (a[i__ + 1 + i__ * a_dim1] == 0.f) {
+ wi[i__] = 0.f;
+ wi[i__ + 1] = 0.f;
+ } else if (a[i__ + 1 + i__ * a_dim1] != 0.f && a[i__ + (
+ i__ + 1) * a_dim1] == 0.f) {
+ wi[i__] = 0.f;
+ wi[i__ + 1] = 0.f;
+ if (i__ > 1) {
+ i__2 = i__ - 1;
+ sswap_(&i__2, &a[i__ * a_dim1 + 1], &c__1, &a[(
+ i__ + 1) * a_dim1 + 1], &c__1);
+ }
+ if (*n > i__ + 1) {
+ i__2 = *n - i__ - 1;
+ sswap_(&i__2, &a[i__ + (i__ + 2) * a_dim1], lda, &
+ a[i__ + 1 + (i__ + 2) * a_dim1], lda);
+ }
+ if (wantvs) {
+ sswap_(n, &vs[i__ * vs_dim1 + 1], &c__1, &vs[(i__
+ + 1) * vs_dim1 + 1], &c__1);
+ }
+ a[i__ + (i__ + 1) * a_dim1] = a[i__ + 1 + i__ *
+ a_dim1];
+ a[i__ + 1 + i__ * a_dim1] = 0.f;
+ }
+ inxt = i__ + 2;
+ }
+L20:
+ ;
+ }
+ }
+
+/* Undo scaling for the imaginary part of the eigenvalues */
+
+ i__1 = *n - ieval;
+/* Computing MAX */
+ i__3 = *n - ieval;
+ i__2 = max(i__3,1);
+ slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[ieval +
+ 1], &i__2, &ierr);
+ }
+
+ if (wantst && *info == 0) {
+
+/* Check if reordering successful */
+
+ lastsl = TRUE_;
+ lst2sl = TRUE_;
+ *sdim = 0;
+ ip = 0;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ cursl = (*select)(&wr[i__], &wi[i__]);
+ if (wi[i__] == 0.f) {
+ if (cursl) {
+ ++(*sdim);
+ }
+ ip = 0;
+ if (cursl && ! lastsl) {
+ *info = *n + 2;
+ }
+ } else {
+ if (ip == 1) {
+
+/* Last eigenvalue of conjugate pair */
+
+ cursl = cursl || lastsl;
+ lastsl = cursl;
+ if (cursl) {
+ *sdim += 2;
+ }
+ ip = -1;
+ if (cursl && ! lst2sl) {
+ *info = *n + 2;
+ }
+ } else {
+
+/* First eigenvalue of conjugate pair */
+
+ ip = 1;
+ }
+ }
+ lst2sl = lastsl;
+ lastsl = cursl;
+/* L30: */
+ }
+ }
+
+ work[1] = (real) maxwrk;
+ return 0;
+
+/* End of SGEES */
+
+} /* sgees_ */
diff --git a/SRC/sgeesx.c b/SRC/sgeesx.c
new file mode 100644
index 0000000..8f9cafa
--- /dev/null
+++ b/SRC/sgeesx.c
@@ -0,0 +1,643 @@
+/* sgeesx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int sgeesx_(char *jobvs, char *sort, L_fp select, char *
+ sense, integer *n, real *a, integer *lda, integer *sdim, real *wr,
+ real *wi, real *vs, integer *ldvs, real *rconde, real *rcondv, real *
+ work, integer *lwork, integer *iwork, integer *liwork, logical *bwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2, i__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, i1, i2, ip, ihi, ilo;
+ real dum[1], eps;
+ integer ibal;
+ real anrm;
+ integer ierr, itau, iwrk, lwrk, inxt, icond, ieval;
+ extern logical lsame_(char *, char *);
+ logical cursl;
+ integer liwrk;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), sswap_(integer *, real *, integer *, real *, integer *
+);
+ logical lst2sl;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ logical scalea;
+ real cscale;
+ extern /* Subroutine */ int sgebak_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *), sgebal_(char *, integer *, real *, integer *,
+ integer *, integer *, real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *), xerbla_(char
+ *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ real bignum;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *,
+ real *, integer *);
+ logical wantsb, wantse, lastsl;
+ extern /* Subroutine */ int sorghr_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *), shseqr_(char
+ *, char *, integer *, integer *, integer *, real *, integer *,
+ real *, real *, real *, integer *, real *, integer *, integer *);
+ integer minwrk, maxwrk;
+ logical wantsn;
+ real smlnum;
+ integer hswork;
+ extern /* Subroutine */ int strsen_(char *, char *, logical *, integer *,
+ real *, integer *, real *, integer *, real *, real *, integer *,
+ real *, real *, real *, integer *, integer *, integer *, integer *
+);
+ logical wantst, lquery, wantsv, wantvs;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+/* .. Function Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGEESX computes for an N-by-N real nonsymmetric matrix A, the */
+/* eigenvalues, the real Schur form T, and, optionally, the matrix of */
+/* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). */
+
+/* Optionally, it also orders the eigenvalues on the diagonal of the */
+/* real Schur form so that selected eigenvalues are at the top left; */
+/* computes a reciprocal condition number for the average of the */
+/* selected eigenvalues (RCONDE); and computes a reciprocal condition */
+/* number for the right invariant subspace corresponding to the */
+/* selected eigenvalues (RCONDV). The leading columns of Z form an */
+/* orthonormal basis for this invariant subspace. */
+
+/* For further explanation of the reciprocal condition numbers RCONDE */
+/* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where */
+/* these quantities are called s and sep respectively). */
+
+/* A real matrix is in real Schur form if it is upper quasi-triangular */
+/* with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in */
+/* the form */
+/* [ a b ] */
+/* [ c a ] */
+
+/* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVS (input) CHARACTER*1 */
+/* = 'N': Schur vectors are not computed; */
+/* = 'V': Schur vectors are computed. */
+
+/* SORT (input) CHARACTER*1 */
+/* Specifies whether or not to order the eigenvalues on the */
+/* diagonal of the Schur form. */
+/* = 'N': Eigenvalues are not ordered; */
+/* = 'S': Eigenvalues are ordered (see SELECT). */
+
+/* SELECT (external procedure) LOGICAL FUNCTION of two REAL arguments */
+/* SELECT must be declared EXTERNAL in the calling subroutine. */
+/* If SORT = 'S', SELECT is used to select eigenvalues to sort */
+/* to the top left of the Schur form. */
+/* If SORT = 'N', SELECT is not referenced. */
+/* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if */
+/* SELECT(WR(j),WI(j)) is true; i.e., if either one of a */
+/* complex conjugate pair of eigenvalues is selected, then both */
+/* are. Note that a selected complex eigenvalue may no longer */
+/* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since */
+/* ordering may change the value of complex eigenvalues */
+/* (especially if the eigenvalue is ill-conditioned); in this */
+/* case INFO may be set to N+3 (see INFO below). */
+
+/* SENSE (input) CHARACTER*1 */
+/* Determines which reciprocal condition numbers are computed. */
+/* = 'N': None are computed; */
+/* = 'E': Computed for average of selected eigenvalues only; */
+/* = 'V': Computed for selected right invariant subspace only; */
+/* = 'B': Computed for both. */
+/* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA, N) */
+/* On entry, the N-by-N matrix A. */
+/* On exit, A is overwritten by its real Schur form T. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* SDIM (output) INTEGER */
+/* If SORT = 'N', SDIM = 0. */
+/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */
+/* for which SELECT is true. (Complex conjugate */
+/* pairs for which SELECT is true for either */
+/* eigenvalue count as 2.) */
+
+/* WR (output) REAL array, dimension (N) */
+/* WI (output) REAL array, dimension (N) */
+/* WR and WI contain the real and imaginary parts, respectively, */
+/* of the computed eigenvalues, in the same order that they */
+/* appear on the diagonal of the output Schur form T. Complex */
+/* conjugate pairs of eigenvalues appear consecutively with the */
+/* eigenvalue having the positive imaginary part first. */
+
+/* VS (output) REAL array, dimension (LDVS,N) */
+/* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur */
+/* vectors. */
+/* If JOBVS = 'N', VS is not referenced. */
+
+/* LDVS (input) INTEGER */
+/* The leading dimension of the array VS. LDVS >= 1, and if */
+/* JOBVS = 'V', LDVS >= N. */
+
+/* RCONDE (output) REAL */
+/* If SENSE = 'E' or 'B', RCONDE contains the reciprocal */
+/* condition number for the average of the selected eigenvalues. */
+/* Not referenced if SENSE = 'N' or 'V'. */
+
+/* RCONDV (output) REAL */
+/* If SENSE = 'V' or 'B', RCONDV contains the reciprocal */
+/* condition number for the selected right invariant subspace. */
+/* Not referenced if SENSE = 'N' or 'E'. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,3*N). */
+/* Also, if SENSE = 'E' or 'V' or 'B', */
+/* LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of */
+/* selected eigenvalues computed by this routine. Note that */
+/* N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only */
+/* returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or */
+/* 'B' this may not be large enough. */
+/* For good performance, LWORK must generally be larger. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates upper bounds on the optimal sizes of the */
+/* arrays WORK and IWORK, returns these values as the first */
+/* entries of the WORK and IWORK arrays, and no error messages */
+/* related to LWORK or LIWORK are issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM). */
+/* Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is */
+/* only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this */
+/* may not be large enough. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates upper bounds on the optimal sizes of */
+/* the arrays WORK and IWORK, returns these values as the first */
+/* entries of the WORK and IWORK arrays, and no error messages */
+/* related to LWORK or LIWORK are issued by XERBLA. */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+/* Not referenced if SORT = 'N'. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, and i is */
+/* <= N: the QR algorithm failed to compute all the */
+/* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI */
+/* contain those eigenvalues which have converged; if */
+/* JOBVS = 'V', VS contains the transformation which */
+/* reduces A to its partially converged Schur form. */
+/* = N+1: the eigenvalues could not be reordered because some */
+/* eigenvalues were too close to separate (the problem */
+/* is very ill-conditioned); */
+/* = N+2: after reordering, roundoff changed values of some */
+/* complex eigenvalues so that leading eigenvalues in */
+/* the Schur form no longer satisfy SELECT=.TRUE. This */
+/* could also be caused by underflow due to scaling. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --wr;
+ --wi;
+ vs_dim1 = *ldvs;
+ vs_offset = 1 + vs_dim1;
+ vs -= vs_offset;
+ --work;
+ --iwork;
+ --bwork;
+
+ /* Function Body */
+ *info = 0;
+ wantvs = lsame_(jobvs, "V");
+ wantst = lsame_(sort, "S");
+ wantsn = lsame_(sense, "N");
+ wantse = lsame_(sense, "E");
+ wantsv = lsame_(sense, "V");
+ wantsb = lsame_(sense, "B");
+ lquery = *lwork == -1 || *liwork == -1;
+ if (! wantvs && ! lsame_(jobvs, "N")) {
+ *info = -1;
+ } else if (! wantst && ! lsame_(sort, "N")) {
+ *info = -2;
+ } else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && !
+ wantsn) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvs < 1 || wantvs && *ldvs < *n) {
+ *info = -12;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "RWorkspace:" describe the */
+/* minimal amount of real workspace needed at that point in the */
+/* code, as well as the preferred amount for good performance. */
+/* IWorkspace refers to integer workspace. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. */
+/* HSWORK refers to the workspace preferred by SHSEQR, as */
+/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
+/* the worst case. */
+/* If SENSE = 'E', 'V' or 'B', then the amount of workspace needed */
+/* depends on SDIM, which is computed by the routine STRSEN later */
+/* in the code.) */
+
+ if (*info == 0) {
+ liwrk = 1;
+ if (*n == 0) {
+ minwrk = 1;
+ lwrk = 1;
+ } else {
+ maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "SGEHRD", " ", n, &c__1,
+ n, &c__0);
+ minwrk = *n * 3;
+
+ shseqr_("S", jobvs, n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[1]
+, &vs[vs_offset], ldvs, &work[1], &c_n1, &ieval);
+ hswork = work[1];
+
+ if (! wantvs) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + hswork;
+ maxwrk = max(i__1,i__2);
+ } else {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
+ "SORGHR", " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + hswork;
+ maxwrk = max(i__1,i__2);
+ }
+ lwrk = maxwrk;
+ if (! wantsn) {
+/* Computing MAX */
+ i__1 = lwrk, i__2 = *n + *n * *n / 2;
+ lwrk = max(i__1,i__2);
+ }
+ if (wantsv || wantsb) {
+ liwrk = *n * *n / 4;
+ }
+ }
+ iwork[1] = liwrk;
+ work[1] = (real) lwrk;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -16;
+ } else if (*liwork < 1 && ! lquery) {
+ *info = -18;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGEESX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *sdim = 0;
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1.f / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = slange_("M", n, n, &a[a_offset], lda, dum);
+ scalea = FALSE_;
+ if (anrm > 0.f && anrm < smlnum) {
+ scalea = TRUE_;
+ cscale = smlnum;
+ } else if (anrm > bignum) {
+ scalea = TRUE_;
+ cscale = bignum;
+ }
+ if (scalea) {
+ slascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Permute the matrix to make it more nearly triangular */
+/* (RWorkspace: need N) */
+
+ ibal = 1;
+ sgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr);
+
+/* Reduce to upper Hessenberg form */
+/* (RWorkspace: need 3*N, prefer 2*N+N*NB) */
+
+ itau = *n + ibal;
+ iwrk = *n + itau;
+ i__1 = *lwork - iwrk + 1;
+ sgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
+ &ierr);
+
+ if (wantvs) {
+
+/* Copy Householder vectors to VS */
+
+ slacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs)
+ ;
+
+/* Generate orthogonal matrix in VS */
+/* (RWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+
+ i__1 = *lwork - iwrk + 1;
+ sorghr_(n, &ilo, &ihi, &vs[vs_offset], ldvs, &work[itau], &work[iwrk],
+ &i__1, &ierr);
+ }
+
+ *sdim = 0;
+
+/* Perform QR iteration, accumulating Schur vectors in VS if desired */
+/* (RWorkspace: need N+1, prefer N+HSWORK (see comments) ) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ shseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &vs[
+ vs_offset], ldvs, &work[iwrk], &i__1, &ieval);
+ if (ieval > 0) {
+ *info = ieval;
+ }
+
+/* Sort eigenvalues if desired */
+
+ if (wantst && *info == 0) {
+ if (scalea) {
+ slascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wr[1], n, &
+ ierr);
+ slascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &wi[1], n, &
+ ierr);
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ bwork[i__] = (*select)(&wr[i__], &wi[i__]);
+/* L10: */
+ }
+
+/* Reorder eigenvalues, transform Schur vectors, and compute */
+/* reciprocal condition numbers */
+/* (RWorkspace: if SENSE is not 'N', need N+2*SDIM*(N-SDIM) */
+/* otherwise, need N ) */
+/* (IWorkspace: if SENSE is 'V' or 'B', need SDIM*(N-SDIM) */
+/* otherwise, need 0 ) */
+
+ i__1 = *lwork - iwrk + 1;
+ strsen_(sense, jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset],
+ ldvs, &wr[1], &wi[1], sdim, rconde, rcondv, &work[iwrk], &
+ i__1, &iwork[1], liwork, &icond);
+ if (! wantsn) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + (*sdim << 1) * (*n - *sdim);
+ maxwrk = max(i__1,i__2);
+ }
+ if (icond == -15) {
+
+/* Not enough real workspace */
+
+ *info = -16;
+ } else if (icond == -17) {
+
+/* Not enough integer workspace */
+
+ *info = -18;
+ } else if (icond > 0) {
+
+/* STRSEN failed to reorder or to restore standard Schur form */
+
+ *info = icond + *n;
+ }
+ }
+
+ if (wantvs) {
+
+/* Undo balancing */
+/* (RWorkspace: need N) */
+
+ sgebak_("P", "R", n, &ilo, &ihi, &work[ibal], n, &vs[vs_offset], ldvs,
+ &ierr);
+ }
+
+ if (scalea) {
+
+/* Undo scaling for the Schur form of A */
+
+ slascl_("H", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, &
+ ierr);
+ i__1 = *lda + 1;
+ scopy_(n, &a[a_offset], &i__1, &wr[1], &c__1);
+ if ((wantsv || wantsb) && *info == 0) {
+ dum[0] = *rcondv;
+ slascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &
+ c__1, &ierr);
+ *rcondv = dum[0];
+ }
+ if (cscale == smlnum) {
+
+/* If scaling back towards underflow, adjust WI if an */
+/* offdiagonal element of a 2-by-2 block in the Schur form */
+/* underflows. */
+
+ if (ieval > 0) {
+ i1 = ieval + 1;
+ i2 = ihi - 1;
+ i__1 = ilo - 1;
+ slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[
+ 1], n, &ierr);
+ } else if (wantst) {
+ i1 = 1;
+ i2 = *n - 1;
+ } else {
+ i1 = ilo;
+ i2 = ihi - 1;
+ }
+ inxt = i1 - 1;
+ i__1 = i2;
+ for (i__ = i1; i__ <= i__1; ++i__) {
+ if (i__ < inxt) {
+ goto L20;
+ }
+ if (wi[i__] == 0.f) {
+ inxt = i__ + 1;
+ } else {
+ if (a[i__ + 1 + i__ * a_dim1] == 0.f) {
+ wi[i__] = 0.f;
+ wi[i__ + 1] = 0.f;
+ } else if (a[i__ + 1 + i__ * a_dim1] != 0.f && a[i__ + (
+ i__ + 1) * a_dim1] == 0.f) {
+ wi[i__] = 0.f;
+ wi[i__ + 1] = 0.f;
+ if (i__ > 1) {
+ i__2 = i__ - 1;
+ sswap_(&i__2, &a[i__ * a_dim1 + 1], &c__1, &a[(
+ i__ + 1) * a_dim1 + 1], &c__1);
+ }
+ if (*n > i__ + 1) {
+ i__2 = *n - i__ - 1;
+ sswap_(&i__2, &a[i__ + (i__ + 2) * a_dim1], lda, &
+ a[i__ + 1 + (i__ + 2) * a_dim1], lda);
+ }
+ sswap_(n, &vs[i__ * vs_dim1 + 1], &c__1, &vs[(i__ + 1)
+ * vs_dim1 + 1], &c__1);
+ a[i__ + (i__ + 1) * a_dim1] = a[i__ + 1 + i__ *
+ a_dim1];
+ a[i__ + 1 + i__ * a_dim1] = 0.f;
+ }
+ inxt = i__ + 2;
+ }
+L20:
+ ;
+ }
+ }
+ i__1 = *n - ieval;
+/* Computing MAX */
+ i__3 = *n - ieval;
+ i__2 = max(i__3,1);
+ slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[ieval +
+ 1], &i__2, &ierr);
+ }
+
+ if (wantst && *info == 0) {
+
+/* Check if reordering successful */
+
+ lastsl = TRUE_;
+ lst2sl = TRUE_;
+ *sdim = 0;
+ ip = 0;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ cursl = (*select)(&wr[i__], &wi[i__]);
+ if (wi[i__] == 0.f) {
+ if (cursl) {
+ ++(*sdim);
+ }
+ ip = 0;
+ if (cursl && ! lastsl) {
+ *info = *n + 2;
+ }
+ } else {
+ if (ip == 1) {
+
+/* Last eigenvalue of conjugate pair */
+
+ cursl = cursl || lastsl;
+ lastsl = cursl;
+ if (cursl) {
+ *sdim += 2;
+ }
+ ip = -1;
+ if (cursl && ! lst2sl) {
+ *info = *n + 2;
+ }
+ } else {
+
+/* First eigenvalue of conjugate pair */
+
+ ip = 1;
+ }
+ }
+ lst2sl = lastsl;
+ lastsl = cursl;
+/* L30: */
+ }
+ }
+
+ work[1] = (real) maxwrk;
+ if (wantsv || wantsb) {
+ iwork[1] = *sdim * (*n - *sdim);
+ } else {
+ iwork[1] = 1;
+ }
+
+ return 0;
+
+/* End of SGEESX */
+
+} /* sgeesx_ */
diff --git a/SRC/sgeev.c b/SRC/sgeev.c
new file mode 100644
index 0000000..e4d639f
--- /dev/null
+++ b/SRC/sgeev.c
@@ -0,0 +1,558 @@
+/* sgeev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int sgeev_(char *jobvl, char *jobvr, integer *n, real *a,
+ integer *lda, real *wr, real *wi, real *vl, integer *ldvl, real *vr,
+ integer *ldvr, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
+ i__2, i__3;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, k;
+ real r__, cs, sn;
+ integer ihi;
+ real scl;
+ integer ilo;
+ real dum[1], eps;
+ integer ibal;
+ char side[1];
+ real anrm;
+ integer ierr, itau, iwrk, nout;
+ extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
+ integer *, real *, real *);
+ extern doublereal snrm2_(integer *, real *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ extern doublereal slapy2_(real *, real *);
+ extern /* Subroutine */ int slabad_(real *, real *);
+ logical scalea;
+ real cscale;
+ extern /* Subroutine */ int sgebak_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *), sgebal_(char *, integer *, real *, integer *,
+ integer *, integer *, real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *), xerbla_(char
+ *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical select[1];
+ real bignum;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slartg_(real *, real *,
+ real *, real *, real *), sorghr_(integer *, integer *, integer *,
+ real *, integer *, real *, real *, integer *, integer *), shseqr_(
+ char *, char *, integer *, integer *, integer *, real *, integer *
+, real *, real *, real *, integer *, real *, integer *, integer *), strevc_(char *, char *, logical *, integer *,
+ real *, integer *, real *, integer *, real *, integer *, integer *
+, integer *, real *, integer *);
+ integer minwrk, maxwrk;
+ logical wantvl;
+ real smlnum;
+ integer hswork;
+ logical lquery, wantvr;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGEEV computes for an N-by-N real nonsymmetric matrix A, the */
+/* eigenvalues and, optionally, the left and/or right eigenvectors. */
+
+/* The right eigenvector v(j) of A satisfies */
+/* A * v(j) = lambda(j) * v(j) */
+/* where lambda(j) is its eigenvalue. */
+/* The left eigenvector u(j) of A satisfies */
+/* u(j)**H * A = lambda(j) * u(j)**H */
+/* where u(j)**H denotes the conjugate transpose of u(j). */
+
+/* The computed eigenvectors are normalized to have Euclidean norm */
+/* equal to 1 and largest component real. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVL (input) CHARACTER*1 */
+/* = 'N': left eigenvectors of A are not computed; */
+/* = 'V': left eigenvectors of A are computed. */
+
+/* JOBVR (input) CHARACTER*1 */
+/* = 'N': right eigenvectors of A are not computed; */
+/* = 'V': right eigenvectors of A are computed. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+/* On exit, A has been overwritten. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* WR (output) REAL array, dimension (N) */
+/* WI (output) REAL array, dimension (N) */
+/* WR and WI contain the real and imaginary parts, */
+/* respectively, of the computed eigenvalues. Complex */
+/* conjugate pairs of eigenvalues appear consecutively */
+/* with the eigenvalue having the positive imaginary part */
+/* first. */
+
+/* VL (output) REAL array, dimension (LDVL,N) */
+/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
+/* after another in the columns of VL, in the same order */
+/* as their eigenvalues. */
+/* If JOBVL = 'N', VL is not referenced. */
+/* If the j-th eigenvalue is real, then u(j) = VL(:,j), */
+/* the j-th column of VL. */
+/* If the j-th and (j+1)-st eigenvalues form a complex */
+/* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and */
+/* u(j+1) = VL(:,j) - i*VL(:,j+1). */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. LDVL >= 1; if */
+/* JOBVL = 'V', LDVL >= N. */
+
+/* VR (output) REAL array, dimension (LDVR,N) */
+/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
+/* after another in the columns of VR, in the same order */
+/* as their eigenvalues. */
+/* If JOBVR = 'N', VR is not referenced. */
+/* If the j-th eigenvalue is real, then v(j) = VR(:,j), */
+/* the j-th column of VR. */
+/* If the j-th and (j+1)-st eigenvalues form a complex */
+/* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and */
+/* v(j+1) = VR(:,j) - i*VR(:,j+1). */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. LDVR >= 1; if */
+/* JOBVR = 'V', LDVR >= N. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,3*N), and */
+/* if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good */
+/* performance, LWORK must generally be larger. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the QR algorithm failed to compute all the */
+/* eigenvalues, and no eigenvectors have been computed; */
+/* elements i+1:N of WR and WI contain eigenvalues which */
+/* have converged. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --wr;
+ --wi;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ wantvl = lsame_(jobvl, "V");
+ wantvr = lsame_(jobvr, "V");
+ if (! wantvl && ! lsame_(jobvl, "N")) {
+ *info = -1;
+ } else if (! wantvr && ! lsame_(jobvr, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldvl < 1 || wantvl && *ldvl < *n) {
+ *info = -9;
+ } else if (*ldvr < 1 || wantvr && *ldvr < *n) {
+ *info = -11;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. */
+/* HSWORK refers to the workspace preferred by SHSEQR, as */
+/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
+/* the worst case.) */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ } else {
+ maxwrk = (*n << 1) + *n * ilaenv_(&c__1, "SGEHRD", " ", n, &c__1,
+ n, &c__0);
+ if (wantvl) {
+ minwrk = *n << 2;
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
+ "SORGHR", " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ shseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
+ 1], &vl[vl_offset], ldvl, &work[1], &c_n1, info);
+ hswork = work[1];
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = *
+ n + hswork;
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n << 2;
+ maxwrk = max(i__1,i__2);
+ } else if (wantvr) {
+ minwrk = *n << 2;
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
+ "SORGHR", " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ shseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
+ 1], &vr[vr_offset], ldvr, &work[1], &c_n1, info);
+ hswork = work[1];
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = *
+ n + hswork;
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n << 2;
+ maxwrk = max(i__1,i__2);
+ } else {
+ minwrk = *n * 3;
+ shseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
+ 1], &vr[vr_offset], ldvr, &work[1], &c_n1, info);
+ hswork = work[1];
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = *
+ n + hswork;
+ maxwrk = max(i__1,i__2);
+ }
+ maxwrk = max(maxwrk,minwrk);
+ }
+ work[1] = (real) maxwrk;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGEEV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1.f / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = slange_("M", n, n, &a[a_offset], lda, dum);
+ scalea = FALSE_;
+ if (anrm > 0.f && anrm < smlnum) {
+ scalea = TRUE_;
+ cscale = smlnum;
+ } else if (anrm > bignum) {
+ scalea = TRUE_;
+ cscale = bignum;
+ }
+ if (scalea) {
+ slascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Balance the matrix */
+/* (Workspace: need N) */
+
+ ibal = 1;
+ sgebal_("B", n, &a[a_offset], lda, &ilo, &ihi, &work[ibal], &ierr);
+
+/* Reduce to upper Hessenberg form */
+/* (Workspace: need 3*N, prefer 2*N+N*NB) */
+
+ itau = ibal + *n;
+ iwrk = itau + *n;
+ i__1 = *lwork - iwrk + 1;
+ sgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
+ &ierr);
+
+ if (wantvl) {
+
+/* Want left eigenvectors */
+/* Copy Householder vectors to VL */
+
+ *(unsigned char *)side = 'L';
+ slacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
+ ;
+
+/* Generate orthogonal matrix in VL */
+/* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+
+ i__1 = *lwork - iwrk + 1;
+ sorghr_(n, &ilo, &ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk],
+ &i__1, &ierr);
+
+/* Perform QR iteration, accumulating Schur vectors in VL */
+/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ shseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &
+ vl[vl_offset], ldvl, &work[iwrk], &i__1, info);
+
+ if (wantvr) {
+
+/* Want left and right eigenvectors */
+/* Copy Schur vectors to VR */
+
+ *(unsigned char *)side = 'B';
+ slacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
+ }
+
+ } else if (wantvr) {
+
+/* Want right eigenvectors */
+/* Copy Householder vectors to VR */
+
+ *(unsigned char *)side = 'R';
+ slacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
+ ;
+
+/* Generate orthogonal matrix in VR */
+/* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+
+ i__1 = *lwork - iwrk + 1;
+ sorghr_(n, &ilo, &ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk],
+ &i__1, &ierr);
+
+/* Perform QR iteration, accumulating Schur vectors in VR */
+/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ shseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &
+ vr[vr_offset], ldvr, &work[iwrk], &i__1, info);
+
+ } else {
+
+/* Compute eigenvalues only */
+/* (Workspace: need N+1, prefer N+HSWORK (see comments) ) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ shseqr_("E", "N", n, &ilo, &ihi, &a[a_offset], lda, &wr[1], &wi[1], &
+ vr[vr_offset], ldvr, &work[iwrk], &i__1, info);
+ }
+
+/* If INFO > 0 from SHSEQR, then quit */
+
+ if (*info > 0) {
+ goto L50;
+ }
+
+ if (wantvl || wantvr) {
+
+/* Compute left and/or right eigenvectors */
+/* (Workspace: need 4*N) */
+
+ strevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
+ &vr[vr_offset], ldvr, n, &nout, &work[iwrk], &ierr);
+ }
+
+ if (wantvl) {
+
+/* Undo balancing of left eigenvectors */
+/* (Workspace: need N) */
+
+ sgebak_("B", "L", n, &ilo, &ihi, &work[ibal], n, &vl[vl_offset], ldvl,
+ &ierr);
+
+/* Normalize left eigenvectors and make largest component real */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (wi[i__] == 0.f) {
+ scl = 1.f / snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
+ sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
+ } else if (wi[i__] > 0.f) {
+ r__1 = snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
+ r__2 = snrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
+ scl = 1.f / slapy2_(&r__1, &r__2);
+ sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
+ sscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+/* Computing 2nd power */
+ r__1 = vl[k + i__ * vl_dim1];
+/* Computing 2nd power */
+ r__2 = vl[k + (i__ + 1) * vl_dim1];
+ work[iwrk + k - 1] = r__1 * r__1 + r__2 * r__2;
+/* L10: */
+ }
+ k = isamax_(n, &work[iwrk], &c__1);
+ slartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1],
+ &cs, &sn, &r__);
+ srot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) *
+ vl_dim1 + 1], &c__1, &cs, &sn);
+ vl[k + (i__ + 1) * vl_dim1] = 0.f;
+ }
+/* L20: */
+ }
+ }
+
+ if (wantvr) {
+
+/* Undo balancing of right eigenvectors */
+/* (Workspace: need N) */
+
+ sgebak_("B", "R", n, &ilo, &ihi, &work[ibal], n, &vr[vr_offset], ldvr,
+ &ierr);
+
+/* Normalize right eigenvectors and make largest component real */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (wi[i__] == 0.f) {
+ scl = 1.f / snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
+ sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
+ } else if (wi[i__] > 0.f) {
+ r__1 = snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
+ r__2 = snrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
+ scl = 1.f / slapy2_(&r__1, &r__2);
+ sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
+ sscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+/* Computing 2nd power */
+ r__1 = vr[k + i__ * vr_dim1];
+/* Computing 2nd power */
+ r__2 = vr[k + (i__ + 1) * vr_dim1];
+ work[iwrk + k - 1] = r__1 * r__1 + r__2 * r__2;
+/* L30: */
+ }
+ k = isamax_(n, &work[iwrk], &c__1);
+ slartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1],
+ &cs, &sn, &r__);
+ srot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) *
+ vr_dim1 + 1], &c__1, &cs, &sn);
+ vr[k + (i__ + 1) * vr_dim1] = 0.f;
+ }
+/* L40: */
+ }
+ }
+
+/* Undo scaling if necessary */
+
+L50:
+ if (scalea) {
+ i__1 = *n - *info;
+/* Computing MAX */
+ i__3 = *n - *info;
+ i__2 = max(i__3,1);
+ slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info +
+ 1], &i__2, &ierr);
+ i__1 = *n - *info;
+/* Computing MAX */
+ i__3 = *n - *info;
+ i__2 = max(i__3,1);
+ slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info +
+ 1], &i__2, &ierr);
+ if (*info > 0) {
+ i__1 = ilo - 1;
+ slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1],
+ n, &ierr);
+ i__1 = ilo - 1;
+ slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1],
+ n, &ierr);
+ }
+ }
+
+ work[1] = (real) maxwrk;
+ return 0;
+
+/* End of SGEEV */
+
+} /* sgeev_ */
diff --git a/SRC/sgeevx.c b/SRC/sgeevx.c
new file mode 100644
index 0000000..2e94a12
--- /dev/null
+++ b/SRC/sgeevx.c
@@ -0,0 +1,696 @@
+/* sgeevx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int sgeevx_(char *balanc, char *jobvl, char *jobvr, char *
+ sense, integer *n, real *a, integer *lda, real *wr, real *wi, real *
+ vl, integer *ldvl, real *vr, integer *ldvr, integer *ilo, integer *
+ ihi, real *scale, real *abnrm, real *rconde, real *rcondv, real *work,
+ integer *lwork, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
+ i__2, i__3;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, k;
+ real r__, cs, sn;
+ char job[1];
+ real scl, dum[1], eps;
+ char side[1];
+ real anrm;
+ integer ierr, itau, iwrk, nout;
+ extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
+ integer *, real *, real *);
+ extern doublereal snrm2_(integer *, real *, integer *);
+ integer icond;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ extern doublereal slapy2_(real *, real *);
+ extern /* Subroutine */ int slabad_(real *, real *);
+ logical scalea;
+ real cscale;
+ extern /* Subroutine */ int sgebak_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *), sgebal_(char *, integer *, real *, integer *,
+ integer *, integer *, real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *), xerbla_(char
+ *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical select[1];
+ real bignum;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slartg_(real *, real *,
+ real *, real *, real *), sorghr_(integer *, integer *, integer *,
+ real *, integer *, real *, real *, integer *, integer *), shseqr_(
+ char *, char *, integer *, integer *, integer *, real *, integer *
+, real *, real *, real *, integer *, real *, integer *, integer *), strevc_(char *, char *, logical *, integer *,
+ real *, integer *, real *, integer *, real *, integer *, integer *
+, integer *, real *, integer *);
+ integer minwrk, maxwrk;
+ extern /* Subroutine */ int strsna_(char *, char *, logical *, integer *,
+ real *, integer *, real *, integer *, real *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *,
+ integer *);
+ logical wantvl, wntsnb;
+ integer hswork;
+ logical wntsne;
+ real smlnum;
+ logical lquery, wantvr, wntsnn, wntsnv;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGEEVX computes for an N-by-N real nonsymmetric matrix A, the */
+/* eigenvalues and, optionally, the left and/or right eigenvectors. */
+
+/* Optionally also, it computes a balancing transformation to improve */
+/* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */
+/* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues */
+/* (RCONDE), and reciprocal condition numbers for the right */
+/* eigenvectors (RCONDV). */
+
+/* The right eigenvector v(j) of A satisfies */
+/* A * v(j) = lambda(j) * v(j) */
+/* where lambda(j) is its eigenvalue. */
+/* The left eigenvector u(j) of A satisfies */
+/* u(j)**H * A = lambda(j) * u(j)**H */
+/* where u(j)**H denotes the conjugate transpose of u(j). */
+
+/* The computed eigenvectors are normalized to have Euclidean norm */
+/* equal to 1 and largest component real. */
+
+/* Balancing a matrix means permuting the rows and columns to make it */
+/* more nearly upper triangular, and applying a diagonal similarity */
+/* transformation D * A * D**(-1), where D is a diagonal matrix, to */
+/* make its rows and columns closer in norm and the condition numbers */
+/* of its eigenvalues and eigenvectors smaller. The computed */
+/* reciprocal condition numbers correspond to the balanced matrix. */
+/* Permuting rows and columns will not change the condition numbers */
+/* (in exact arithmetic) but diagonal scaling will. For further */
+/* explanation of balancing, see section 4.10.2 of the LAPACK */
+/* Users' Guide. */
+
+/* Arguments */
+/* ========= */
+
+/* BALANC (input) CHARACTER*1 */
+/* Indicates how the input matrix should be diagonally scaled */
+/* and/or permuted to improve the conditioning of its */
+/* eigenvalues. */
+/* = 'N': Do not diagonally scale or permute; */
+/* = 'P': Perform permutations to make the matrix more nearly */
+/* upper triangular. Do not diagonally scale; */
+/* = 'S': Diagonally scale the matrix, i.e. replace A by */
+/* D*A*D**(-1), where D is a diagonal matrix chosen */
+/* to make the rows and columns of A more equal in */
+/* norm. Do not permute; */
+/* = 'B': Both diagonally scale and permute A. */
+
+/* Computed reciprocal condition numbers will be for the matrix */
+/* after balancing and/or permuting. Permuting does not change */
+/* condition numbers (in exact arithmetic), but balancing does. */
+
+/* JOBVL (input) CHARACTER*1 */
+/* = 'N': left eigenvectors of A are not computed; */
+/* = 'V': left eigenvectors of A are computed. */
+/* If SENSE = 'E' or 'B', JOBVL must = 'V'. */
+
+/* JOBVR (input) CHARACTER*1 */
+/* = 'N': right eigenvectors of A are not computed; */
+/* = 'V': right eigenvectors of A are computed. */
+/* If SENSE = 'E' or 'B', JOBVR must = 'V'. */
+
+/* SENSE (input) CHARACTER*1 */
+/* Determines which reciprocal condition numbers are computed. */
+/* = 'N': None are computed; */
+/* = 'E': Computed for eigenvalues only; */
+/* = 'V': Computed for right eigenvectors only; */
+/* = 'B': Computed for eigenvalues and right eigenvectors. */
+
+/* If SENSE = 'E' or 'B', both left and right eigenvectors */
+/* must also be computed (JOBVL = 'V' and JOBVR = 'V'). */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+/* On exit, A has been overwritten. If JOBVL = 'V' or */
+/* JOBVR = 'V', A contains the real Schur form of the balanced */
+/* version of the input matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* WR (output) REAL array, dimension (N) */
+/* WI (output) REAL array, dimension (N) */
+/* WR and WI contain the real and imaginary parts, */
+/* respectively, of the computed eigenvalues. Complex */
+/* conjugate pairs of eigenvalues will appear consecutively */
+/* with the eigenvalue having the positive imaginary part */
+/* first. */
+
+/* VL (output) REAL array, dimension (LDVL,N) */
+/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
+/* after another in the columns of VL, in the same order */
+/* as their eigenvalues. */
+/* If JOBVL = 'N', VL is not referenced. */
+/* If the j-th eigenvalue is real, then u(j) = VL(:,j), */
+/* the j-th column of VL. */
+/* If the j-th and (j+1)-st eigenvalues form a complex */
+/* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and */
+/* u(j+1) = VL(:,j) - i*VL(:,j+1). */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. LDVL >= 1; if */
+/* JOBVL = 'V', LDVL >= N. */
+
+/* VR (output) REAL array, dimension (LDVR,N) */
+/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
+/* after another in the columns of VR, in the same order */
+/* as their eigenvalues. */
+/* If JOBVR = 'N', VR is not referenced. */
+/* If the j-th eigenvalue is real, then v(j) = VR(:,j), */
+/* the j-th column of VR. */
+/* If the j-th and (j+1)-st eigenvalues form a complex */
+/* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and */
+/* v(j+1) = VR(:,j) - i*VR(:,j+1). */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. LDVR >= 1, and if */
+/* JOBVR = 'V', LDVR >= N. */
+
+/* ILO (output) INTEGER */
+/* IHI (output) INTEGER */
+/* ILO and IHI are integer values determined when A was */
+/* balanced. The balanced A(i,j) = 0 if I > J and */
+/* J = 1,...,ILO-1 or I = IHI+1,...,N. */
+
+/* SCALE (output) REAL array, dimension (N) */
+/* Details of the permutations and scaling factors applied */
+/* when balancing A. If P(j) is the index of the row and column */
+/* interchanged with row and column j, and D(j) is the scaling */
+/* factor applied to row and column j, then */
+/* SCALE(J) = P(J), for J = 1,...,ILO-1 */
+/* = D(J), for J = ILO,...,IHI */
+/* = P(J) for J = IHI+1,...,N. */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* ABNRM (output) REAL */
+/* The one-norm of the balanced matrix (the maximum */
+/* of the sum of absolute values of elements of any column). */
+
+/* RCONDE (output) REAL array, dimension (N) */
+/* RCONDE(j) is the reciprocal condition number of the j-th */
+/* eigenvalue. */
+
+/* RCONDV (output) REAL array, dimension (N) */
+/* RCONDV(j) is the reciprocal condition number of the j-th */
+/* right eigenvector. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. If SENSE = 'N' or 'E', */
+/* LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V', */
+/* LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6). */
+/* For good performance, LWORK must generally be larger. */
+
+/* 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. */
+
+/* IWORK (workspace) INTEGER array, dimension (2*N-2) */
+/* If SENSE = 'N' or 'E', not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the QR algorithm failed to compute all the */
+/* eigenvalues, and no eigenvectors or condition numbers */
+/* have been computed; elements 1:ILO-1 and i+1:N of WR */
+/* and WI contain eigenvalues which have converged. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --wr;
+ --wi;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --scale;
+ --rconde;
+ --rcondv;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ wantvl = lsame_(jobvl, "V");
+ wantvr = lsame_(jobvr, "V");
+ wntsnn = lsame_(sense, "N");
+ wntsne = lsame_(sense, "E");
+ wntsnv = lsame_(sense, "V");
+ wntsnb = lsame_(sense, "B");
+ if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P")
+ || lsame_(balanc, "B"))) {
+ *info = -1;
+ } else if (! wantvl && ! lsame_(jobvl, "N")) {
+ *info = -2;
+ } else if (! wantvr && ! lsame_(jobvr, "N")) {
+ *info = -3;
+ } else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb)
+ && ! (wantvl && wantvr)) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvl < 1 || wantvl && *ldvl < *n) {
+ *info = -11;
+ } else if (*ldvr < 1 || wantvr && *ldvr < *n) {
+ *info = -13;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. */
+/* HSWORK refers to the workspace preferred by SHSEQR, as */
+/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
+/* the worst case.) */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ } else {
+ maxwrk = *n + *n * ilaenv_(&c__1, "SGEHRD", " ", n, &c__1, n, &
+ c__0);
+
+ if (wantvl) {
+ shseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
+ 1], &vl[vl_offset], ldvl, &work[1], &c_n1, info);
+ } else if (wantvr) {
+ shseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &wr[1], &wi[
+ 1], &vr[vr_offset], ldvr, &work[1], &c_n1, info);
+ } else {
+ if (wntsnn) {
+ shseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &wr[1],
+ &wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1,
+ info);
+ } else {
+ shseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &wr[1],
+ &wi[1], &vr[vr_offset], ldvr, &work[1], &c_n1,
+ info);
+ }
+ }
+ hswork = work[1];
+
+ if (! wantvl && ! wantvr) {
+ minwrk = *n << 1;
+ if (! wntsnn) {
+/* Computing MAX */
+ i__1 = minwrk, i__2 = *n * *n + *n * 6;
+ minwrk = max(i__1,i__2);
+ }
+ maxwrk = max(maxwrk,hswork);
+ if (! wntsnn) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * *n + *n * 6;
+ maxwrk = max(i__1,i__2);
+ }
+ } else {
+ minwrk = *n * 3;
+ if (! wntsnn && ! wntsne) {
+/* Computing MAX */
+ i__1 = minwrk, i__2 = *n * *n + *n * 6;
+ minwrk = max(i__1,i__2);
+ }
+ maxwrk = max(maxwrk,hswork);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "SORGHR",
+ " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ if (! wntsnn && ! wntsne) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * *n + *n * 6;
+ maxwrk = max(i__1,i__2);
+ }
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * 3;
+ maxwrk = max(i__1,i__2);
+ }
+ maxwrk = max(maxwrk,minwrk);
+ }
+ work[1] = (real) maxwrk;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -21;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGEEVX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1.f / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ icond = 0;
+ anrm = slange_("M", n, n, &a[a_offset], lda, dum);
+ scalea = FALSE_;
+ if (anrm > 0.f && anrm < smlnum) {
+ scalea = TRUE_;
+ cscale = smlnum;
+ } else if (anrm > bignum) {
+ scalea = TRUE_;
+ cscale = bignum;
+ }
+ if (scalea) {
+ slascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Balance the matrix and compute ABNRM */
+
+ sgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr);
+ *abnrm = slange_("1", n, n, &a[a_offset], lda, dum);
+ if (scalea) {
+ dum[0] = *abnrm;
+ slascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, &
+ ierr);
+ *abnrm = dum[0];
+ }
+
+/* Reduce to upper Hessenberg form */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ itau = 1;
+ iwrk = itau + *n;
+ i__1 = *lwork - iwrk + 1;
+ sgehrd_(n, ilo, ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, &
+ ierr);
+
+ if (wantvl) {
+
+/* Want left eigenvectors */
+/* Copy Householder vectors to VL */
+
+ *(unsigned char *)side = 'L';
+ slacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
+ ;
+
+/* Generate orthogonal matrix in VL */
+/* (Workspace: need 2*N-1, prefer N+(N-1)*NB) */
+
+ i__1 = *lwork - iwrk + 1;
+ sorghr_(n, ilo, ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], &
+ i__1, &ierr);
+
+/* Perform QR iteration, accumulating Schur vectors in VL */
+/* (Workspace: need 1, prefer HSWORK (see comments) ) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ shseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vl[
+ vl_offset], ldvl, &work[iwrk], &i__1, info);
+
+ if (wantvr) {
+
+/* Want left and right eigenvectors */
+/* Copy Schur vectors to VR */
+
+ *(unsigned char *)side = 'B';
+ slacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
+ }
+
+ } else if (wantvr) {
+
+/* Want right eigenvectors */
+/* Copy Householder vectors to VR */
+
+ *(unsigned char *)side = 'R';
+ slacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
+ ;
+
+/* Generate orthogonal matrix in VR */
+/* (Workspace: need 2*N-1, prefer N+(N-1)*NB) */
+
+ i__1 = *lwork - iwrk + 1;
+ sorghr_(n, ilo, ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], &
+ i__1, &ierr);
+
+/* Perform QR iteration, accumulating Schur vectors in VR */
+/* (Workspace: need 1, prefer HSWORK (see comments) ) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ shseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[
+ vr_offset], ldvr, &work[iwrk], &i__1, info);
+
+ } else {
+
+/* Compute eigenvalues only */
+/* If condition numbers desired, compute Schur form */
+
+ if (wntsnn) {
+ *(unsigned char *)job = 'E';
+ } else {
+ *(unsigned char *)job = 'S';
+ }
+
+/* (Workspace: need 1, prefer HSWORK (see comments) ) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ shseqr_(job, "N", n, ilo, ihi, &a[a_offset], lda, &wr[1], &wi[1], &vr[
+ vr_offset], ldvr, &work[iwrk], &i__1, info);
+ }
+
+/* If INFO > 0 from SHSEQR, then quit */
+
+ if (*info > 0) {
+ goto L50;
+ }
+
+ if (wantvl || wantvr) {
+
+/* Compute left and/or right eigenvectors */
+/* (Workspace: need 3*N) */
+
+ strevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
+ &vr[vr_offset], ldvr, n, &nout, &work[iwrk], &ierr);
+ }
+
+/* Compute condition numbers if desired */
+/* (Workspace: need N*N+6*N unless SENSE = 'E') */
+
+ if (! wntsnn) {
+ strsna_(sense, "A", select, n, &a[a_offset], lda, &vl[vl_offset],
+ ldvl, &vr[vr_offset], ldvr, &rconde[1], &rcondv[1], n, &nout,
+ &work[iwrk], n, &iwork[1], &icond);
+ }
+
+ if (wantvl) {
+
+/* Undo balancing of left eigenvectors */
+
+ sgebak_(balanc, "L", n, ilo, ihi, &scale[1], n, &vl[vl_offset], ldvl,
+ &ierr);
+
+/* Normalize left eigenvectors and make largest component real */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (wi[i__] == 0.f) {
+ scl = 1.f / snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
+ sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
+ } else if (wi[i__] > 0.f) {
+ r__1 = snrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
+ r__2 = snrm2_(n, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
+ scl = 1.f / slapy2_(&r__1, &r__2);
+ sscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
+ sscal_(n, &scl, &vl[(i__ + 1) * vl_dim1 + 1], &c__1);
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+/* Computing 2nd power */
+ r__1 = vl[k + i__ * vl_dim1];
+/* Computing 2nd power */
+ r__2 = vl[k + (i__ + 1) * vl_dim1];
+ work[k] = r__1 * r__1 + r__2 * r__2;
+/* L10: */
+ }
+ k = isamax_(n, &work[1], &c__1);
+ slartg_(&vl[k + i__ * vl_dim1], &vl[k + (i__ + 1) * vl_dim1],
+ &cs, &sn, &r__);
+ srot_(n, &vl[i__ * vl_dim1 + 1], &c__1, &vl[(i__ + 1) *
+ vl_dim1 + 1], &c__1, &cs, &sn);
+ vl[k + (i__ + 1) * vl_dim1] = 0.f;
+ }
+/* L20: */
+ }
+ }
+
+ if (wantvr) {
+
+/* Undo balancing of right eigenvectors */
+
+ sgebak_(balanc, "R", n, ilo, ihi, &scale[1], n, &vr[vr_offset], ldvr,
+ &ierr);
+
+/* Normalize right eigenvectors and make largest component real */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (wi[i__] == 0.f) {
+ scl = 1.f / snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
+ sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
+ } else if (wi[i__] > 0.f) {
+ r__1 = snrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
+ r__2 = snrm2_(n, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
+ scl = 1.f / slapy2_(&r__1, &r__2);
+ sscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
+ sscal_(n, &scl, &vr[(i__ + 1) * vr_dim1 + 1], &c__1);
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+/* Computing 2nd power */
+ r__1 = vr[k + i__ * vr_dim1];
+/* Computing 2nd power */
+ r__2 = vr[k + (i__ + 1) * vr_dim1];
+ work[k] = r__1 * r__1 + r__2 * r__2;
+/* L30: */
+ }
+ k = isamax_(n, &work[1], &c__1);
+ slartg_(&vr[k + i__ * vr_dim1], &vr[k + (i__ + 1) * vr_dim1],
+ &cs, &sn, &r__);
+ srot_(n, &vr[i__ * vr_dim1 + 1], &c__1, &vr[(i__ + 1) *
+ vr_dim1 + 1], &c__1, &cs, &sn);
+ vr[k + (i__ + 1) * vr_dim1] = 0.f;
+ }
+/* L40: */
+ }
+ }
+
+/* Undo scaling if necessary */
+
+L50:
+ if (scalea) {
+ i__1 = *n - *info;
+/* Computing MAX */
+ i__3 = *n - *info;
+ i__2 = max(i__3,1);
+ slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[*info +
+ 1], &i__2, &ierr);
+ i__1 = *n - *info;
+/* Computing MAX */
+ i__3 = *n - *info;
+ i__2 = max(i__3,1);
+ slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[*info +
+ 1], &i__2, &ierr);
+ if (*info == 0) {
+ if ((wntsnv || wntsnb) && icond == 0) {
+ slascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &rcondv[
+ 1], n, &ierr);
+ }
+ } else {
+ i__1 = *ilo - 1;
+ slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wr[1],
+ n, &ierr);
+ i__1 = *ilo - 1;
+ slascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &wi[1],
+ n, &ierr);
+ }
+ }
+
+ work[1] = (real) maxwrk;
+ return 0;
+
+/* End of SGEEVX */
+
+} /* sgeevx_ */
diff --git a/SRC/sgegs.c b/SRC/sgegs.c
new file mode 100644
index 0000000..8671962
--- /dev/null
+++ b/SRC/sgegs.c
@@ -0,0 +1,545 @@
+/* sgegs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b36 = 0.f;
+static real c_b37 = 1.f;
+
+/* Subroutine */ int sgegs_(char *jobvsl, char *jobvsr, integer *n, real *a,
+ integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real
+ *beta, real *vsl, integer *ldvsl, real *vsr, integer *ldvsr, real *
+ work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
+ vsr_dim1, vsr_offset, i__1, i__2;
+
+ /* Local variables */
+ integer nb, nb1, nb2, nb3, ihi, ilo;
+ real eps, anrm, bnrm;
+ integer itau, lopt;
+ extern logical lsame_(char *, char *);
+ integer ileft, iinfo, icols;
+ logical ilvsl;
+ integer iwork;
+ logical ilvsr;
+ integer irows;
+ extern /* Subroutine */ int sggbak_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, integer *
+), sggbal_(char *, integer *, real *, integer *,
+ real *, integer *, integer *, integer *, real *, real *, real *,
+ integer *);
+ logical ilascl, ilbscl;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ real safmin;
+ extern /* Subroutine */ int sgghrd_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, integer *, integer *), xerbla_(char *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ real bignum;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *);
+ integer ijobvl, iright;
+ extern /* Subroutine */ int sgeqrf_(integer *, integer *, real *, integer
+ *, real *, real *, integer *, integer *);
+ integer ijobvr;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *);
+ real anrmto;
+ integer lwkmin;
+ real bnrmto;
+ extern /* Subroutine */ int shgeqz_(char *, char *, char *, integer *,
+ integer *, integer *, real *, integer *, real *, integer *, real *
+, real *, real *, real *, integer *, real *, integer *, real *,
+ integer *, integer *);
+ real smlnum;
+ extern /* Subroutine */ int sorgqr_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine SGGES. */
+
+/* SGEGS computes the eigenvalues, real Schur form, and, optionally, */
+/* left and or/right Schur vectors of a real matrix pair (A,B). */
+/* Given two square matrices A and B, the generalized real Schur */
+/* factorization has the form */
+
+/* A = Q*S*Z**T, B = Q*T*Z**T */
+
+/* where Q and Z are orthogonal matrices, T is upper triangular, and S */
+/* is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal */
+/* blocks, the 2-by-2 blocks corresponding to complex conjugate pairs */
+/* of eigenvalues of (A,B). The columns of Q are the left Schur vectors */
+/* and the columns of Z are the right Schur vectors. */
+
+/* If only the eigenvalues of (A,B) are needed, the driver routine */
+/* SGEGV should be used instead. See SGEGV for a description of the */
+/* eigenvalues of the generalized nonsymmetric eigenvalue problem */
+/* (GNEP). */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVSL (input) CHARACTER*1 */
+/* = 'N': do not compute the left Schur vectors; */
+/* = 'V': compute the left Schur vectors (returned in VSL). */
+
+/* JOBVSR (input) CHARACTER*1 */
+/* = 'N': do not compute the right Schur vectors; */
+/* = 'V': compute the right Schur vectors (returned in VSR). */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VSL, and VSR. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA, N) */
+/* On entry, the matrix A. */
+/* On exit, the upper quasi-triangular matrix S from the */
+/* generalized real Schur factorization. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) REAL array, dimension (LDB, N) */
+/* On entry, the matrix B. */
+/* On exit, the upper triangular matrix T from the generalized */
+/* real Schur factorization. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* ALPHAR (output) REAL array, dimension (N) */
+/* The real parts of each scalar alpha defining an eigenvalue */
+/* of GNEP. */
+
+/* ALPHAI (output) REAL array, dimension (N) */
+/* The imaginary parts of each scalar alpha defining an */
+/* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th */
+/* eigenvalue is real; if positive, then the j-th and (j+1)-st */
+/* eigenvalues are a complex conjugate pair, with */
+/* ALPHAI(j+1) = -ALPHAI(j). */
+
+/* BETA (output) REAL array, dimension (N) */
+/* The scalars beta that define the eigenvalues of GNEP. */
+/* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and */
+/* beta = BETA(j) represent the j-th eigenvalue of the matrix */
+/* pair (A,B), in one of the forms lambda = alpha/beta or */
+/* mu = beta/alpha. Since either lambda or mu may overflow, */
+/* they should not, in general, be computed. */
+
+/* VSL (output) REAL array, dimension (LDVSL,N) */
+/* If JOBVSL = 'V', the matrix of left Schur vectors Q. */
+/* Not referenced if JOBVSL = 'N'. */
+
+/* LDVSL (input) INTEGER */
+/* The leading dimension of the matrix VSL. LDVSL >=1, and */
+/* if JOBVSL = 'V', LDVSL >= N. */
+
+/* VSR (output) REAL array, dimension (LDVSR,N) */
+/* If JOBVSR = 'V', the matrix of right Schur vectors Z. */
+/* Not referenced if JOBVSR = 'N'. */
+
+/* LDVSR (input) INTEGER */
+/* The leading dimension of the matrix VSR. LDVSR >= 1, and */
+/* if JOBVSR = 'V', LDVSR >= N. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,4*N). */
+/* For good performance, LWORK must generally be larger. */
+/* To compute the optimal value of LWORK, call ILAENV to get */
+/* blocksizes (for SGEQRF, SORMQR, and SORGQR.) Then compute: */
+/* NB -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR */
+/* The optimal LWORK is 2*N + N*(NB+1). */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1,...,N: */
+/* The QZ iteration failed. (A,B) are not in Schur */
+/* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should */
+/* be correct for j=INFO+1,...,N. */
+/* > N: errors that usually indicate LAPACK problems: */
+/* =N+1: error return from SGGBAL */
+/* =N+2: error return from SGEQRF */
+/* =N+3: error return from SORMQR */
+/* =N+4: error return from SORGQR */
+/* =N+5: error return from SGGHRD */
+/* =N+6: error return from SHGEQZ (other than failed */
+/* iteration) */
+/* =N+7: error return from SGGBAK (computing VSL) */
+/* =N+8: error return from SGGBAK (computing VSR) */
+/* =N+9: error return from SLASCL (various places) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ vsl_dim1 = *ldvsl;
+ vsl_offset = 1 + vsl_dim1;
+ vsl -= vsl_offset;
+ vsr_dim1 = *ldvsr;
+ vsr_offset = 1 + vsr_dim1;
+ vsr -= vsr_offset;
+ --work;
+
+ /* Function Body */
+ if (lsame_(jobvsl, "N")) {
+ ijobvl = 1;
+ ilvsl = FALSE_;
+ } else if (lsame_(jobvsl, "V")) {
+ ijobvl = 2;
+ ilvsl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvsl = FALSE_;
+ }
+
+ if (lsame_(jobvsr, "N")) {
+ ijobvr = 1;
+ ilvsr = FALSE_;
+ } else if (lsame_(jobvsr, "V")) {
+ ijobvr = 2;
+ ilvsr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvsr = FALSE_;
+ }
+
+/* Test the input arguments */
+
+/* Computing MAX */
+ i__1 = *n << 2;
+ lwkmin = max(i__1,1);
+ lwkopt = lwkmin;
+ work[1] = (real) lwkopt;
+ lquery = *lwork == -1;
+ *info = 0;
+ if (ijobvl <= 0) {
+ *info = -1;
+ } else if (ijobvr <= 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
+ *info = -12;
+ } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
+ *info = -14;
+ } else if (*lwork < lwkmin && ! lquery) {
+ *info = -16;
+ }
+
+ if (*info == 0) {
+ nb1 = ilaenv_(&c__1, "SGEQRF", " ", n, n, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "SORMQR", " ", n, n, n, &c_n1);
+ nb3 = ilaenv_(&c__1, "SORGQR", " ", n, n, n, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2);
+ nb = max(i__1,nb3);
+ lopt = (*n << 1) + *n * (nb + 1);
+ work[1] = (real) lopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGEGS ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("E") * slamch_("B");
+ safmin = slamch_("S");
+ smlnum = *n * safmin / eps;
+ bignum = 1.f / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = slange_("M", n, n, &a[a_offset], lda, &work[1]);
+ ilascl = FALSE_;
+ if (anrm > 0.f && anrm < smlnum) {
+ anrmto = smlnum;
+ ilascl = TRUE_;
+ } else if (anrm > bignum) {
+ anrmto = bignum;
+ ilascl = TRUE_;
+ }
+
+ if (ilascl) {
+ slascl_("G", &c_n1, &c_n1, &anrm, &anrmto, n, n, &a[a_offset], lda, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = slange_("M", n, n, &b[b_offset], ldb, &work[1]);
+ ilbscl = FALSE_;
+ if (bnrm > 0.f && bnrm < smlnum) {
+ bnrmto = smlnum;
+ ilbscl = TRUE_;
+ } else if (bnrm > bignum) {
+ bnrmto = bignum;
+ ilbscl = TRUE_;
+ }
+
+ if (ilbscl) {
+ slascl_("G", &c_n1, &c_n1, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ }
+
+/* Permute the matrix to make it more nearly triangular */
+/* Workspace layout: (2*N words -- "work..." not actually used) */
+/* left_permutation, right_permutation, work... */
+
+ ileft = 1;
+ iright = *n + 1;
+ iwork = iright + *n;
+ sggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[
+ ileft], &work[iright], &work[iwork], &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 1;
+ goto L10;
+ }
+
+/* Reduce B to triangular form, and initialize VSL and/or VSR */
+/* Workspace layout: ("work..." must have at least N words) */
+/* left_permutation, right_permutation, tau, work... */
+
+ irows = ihi + 1 - ilo;
+ icols = *n + 1 - ilo;
+ itau = iwork;
+ iwork = itau + irows;
+ i__1 = *lwork + 1 - iwork;
+ sgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
+ iwork], &i__1, &iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 2;
+ goto L10;
+ }
+
+ i__1 = *lwork + 1 - iwork;
+ sormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
+ work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, &
+ iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 3;
+ goto L10;
+ }
+
+ if (ilvsl) {
+ slaset_("Full", n, n, &c_b36, &c_b37, &vsl[vsl_offset], ldvsl);
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ slacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[ilo
+ + 1 + ilo * vsl_dim1], ldvsl);
+ i__1 = *lwork + 1 - iwork;
+ sorgqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, &
+ work[itau], &work[iwork], &i__1, &iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 4;
+ goto L10;
+ }
+ }
+
+ if (ilvsr) {
+ slaset_("Full", n, n, &c_b36, &c_b37, &vsr[vsr_offset], ldvsr);
+ }
+
+/* Reduce to generalized Hessenberg form */
+
+ sgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 5;
+ goto L10;
+ }
+
+/* Perform QZ algorithm, computing Schur vectors if desired */
+/* Workspace layout: ("work..." must have at least 1 word) */
+/* left_permutation, right_permutation, work... */
+
+ iwork = itau;
+ i__1 = *lwork + 1 - iwork;
+ shgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[
+ b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset]
+, ldvsl, &vsr[vsr_offset], ldvsr, &work[iwork], &i__1, &iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ if (iinfo > 0 && iinfo <= *n) {
+ *info = iinfo;
+ } else if (iinfo > *n && iinfo <= *n << 1) {
+ *info = iinfo - *n;
+ } else {
+ *info = *n + 6;
+ }
+ goto L10;
+ }
+
+/* Apply permutation to VSL and VSR */
+
+ if (ilvsl) {
+ sggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[
+ vsl_offset], ldvsl, &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 7;
+ goto L10;
+ }
+ }
+ if (ilvsr) {
+ sggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[
+ vsr_offset], ldvsr, &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 8;
+ goto L10;
+ }
+ }
+
+/* Undo scaling */
+
+ if (ilascl) {
+ slascl_("H", &c_n1, &c_n1, &anrmto, &anrm, n, n, &a[a_offset], lda, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ slascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alphar[1], n, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ slascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alphai[1], n, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ }
+
+ if (ilbscl) {
+ slascl_("U", &c_n1, &c_n1, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ slascl_("G", &c_n1, &c_n1, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ }
+
+L10:
+ work[1] = (real) lwkopt;
+
+ return 0;
+
+/* End of SGEGS */
+
+} /* sgegs_ */
diff --git a/SRC/sgegv.c b/SRC/sgegv.c
new file mode 100644
index 0000000..34704c6
--- /dev/null
+++ b/SRC/sgegv.c
@@ -0,0 +1,837 @@
+/* sgegv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b27 = 1.f;
+static real c_b38 = 0.f;
+
+/* Subroutine */ int sgegv_(char *jobvl, char *jobvr, integer *n, real *a,
+ integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real
+ *beta, real *vl, integer *ldvl, real *vr, integer *ldvr, real *work,
+ integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
+ vr_offset, i__1, i__2;
+ real r__1, r__2, r__3, r__4;
+
+ /* Local variables */
+ integer jc, nb, in, jr, nb1, nb2, nb3, ihi, ilo;
+ real eps;
+ logical ilv;
+ real absb, anrm, bnrm;
+ integer itau;
+ real temp;
+ logical ilvl, ilvr;
+ integer lopt;
+ real anrm1, anrm2, bnrm1, bnrm2, absai, scale, absar, sbeta;
+ extern logical lsame_(char *, char *);
+ integer ileft, iinfo, icols, iwork, irows;
+ real salfai;
+ extern /* Subroutine */ int sggbak_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, integer *
+), sggbal_(char *, integer *, real *, integer *,
+ real *, integer *, integer *, integer *, real *, real *, real *,
+ integer *);
+ real salfar;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ real safmin;
+ extern /* Subroutine */ int sgghrd_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, integer *, integer *);
+ real safmax;
+ char chtemp[1];
+ logical ldumma[1];
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ijobvl, iright;
+ logical ilimit;
+ extern /* Subroutine */ int sgeqrf_(integer *, integer *, real *, integer
+ *, real *, real *, integer *, integer *);
+ integer ijobvr;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *), stgevc_(
+ char *, char *, logical *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, integer *,
+ integer *, real *, integer *);
+ real onepls;
+ integer lwkmin;
+ extern /* Subroutine */ int shgeqz_(char *, char *, char *, integer *,
+ integer *, integer *, real *, integer *, real *, integer *, real *
+, real *, real *, real *, integer *, real *, integer *, real *,
+ integer *, integer *), sorgqr_(integer *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine SGGEV. */
+
+/* SGEGV computes the eigenvalues and, optionally, the left and/or right */
+/* eigenvectors of a real matrix pair (A,B). */
+/* Given two square matrices A and B, */
+/* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the */
+/* eigenvalues lambda and corresponding (non-zero) eigenvectors x such */
+/* that */
+
+/* A*x = lambda*B*x. */
+
+/* An alternate form is to find the eigenvalues mu and corresponding */
+/* eigenvectors y such that */
+
+/* mu*A*y = B*y. */
+
+/* These two forms are equivalent with mu = 1/lambda and x = y if */
+/* neither lambda nor mu is zero. In order to deal with the case that */
+/* lambda or mu is zero or small, two values alpha and beta are returned */
+/* for each eigenvalue, such that lambda = alpha/beta and */
+/* mu = beta/alpha. */
+
+/* The vectors x and y in the above equations are right eigenvectors of */
+/* the matrix pair (A,B). Vectors u and v satisfying */
+
+/* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B */
+
+/* are left eigenvectors of (A,B). */
+
+/* Note: this routine performs "full balancing" on A and B -- see */
+/* "Further Details", below. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVL (input) CHARACTER*1 */
+/* = 'N': do not compute the left generalized eigenvectors; */
+/* = 'V': compute the left generalized eigenvectors (returned */
+/* in VL). */
+
+/* JOBVR (input) CHARACTER*1 */
+/* = 'N': do not compute the right generalized eigenvectors; */
+/* = 'V': compute the right generalized eigenvectors (returned */
+/* in VR). */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VL, and VR. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA, N) */
+/* On entry, the matrix A. */
+/* If JOBVL = 'V' or JOBVR = 'V', then on exit A */
+/* contains the real Schur form of A from the generalized Schur */
+/* factorization of the pair (A,B) after balancing. */
+/* If no eigenvectors were computed, then only the diagonal */
+/* blocks from the Schur form will be correct. See SGGHRD and */
+/* SHGEQZ for details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) REAL array, dimension (LDB, N) */
+/* On entry, the matrix B. */
+/* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the */
+/* upper triangular matrix obtained from B in the generalized */
+/* Schur factorization of the pair (A,B) after balancing. */
+/* If no eigenvectors were computed, then only those elements of */
+/* B corresponding to the diagonal blocks from the Schur form of */
+/* A will be correct. See SGGHRD and SHGEQZ for details. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* ALPHAR (output) REAL array, dimension (N) */
+/* The real parts of each scalar alpha defining an eigenvalue of */
+/* GNEP. */
+
+/* ALPHAI (output) REAL array, dimension (N) */
+/* The imaginary parts of each scalar alpha defining an */
+/* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th */
+/* eigenvalue is real; if positive, then the j-th and */
+/* (j+1)-st eigenvalues are a complex conjugate pair, with */
+/* ALPHAI(j+1) = -ALPHAI(j). */
+
+/* BETA (output) REAL array, dimension (N) */
+/* The scalars beta that define the eigenvalues of GNEP. */
+
+/* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and */
+/* beta = BETA(j) represent the j-th eigenvalue of the matrix */
+/* pair (A,B), in one of the forms lambda = alpha/beta or */
+/* mu = beta/alpha. Since either lambda or mu may overflow, */
+/* they should not, in general, be computed. */
+
+/* VL (output) REAL array, dimension (LDVL,N) */
+/* If JOBVL = 'V', the left eigenvectors u(j) are stored */
+/* in the columns of VL, in the same order as their eigenvalues. */
+/* If the j-th eigenvalue is real, then u(j) = VL(:,j). */
+/* If the j-th and (j+1)-st eigenvalues form a complex conjugate */
+/* pair, then */
+/* u(j) = VL(:,j) + i*VL(:,j+1) */
+/* and */
+/* u(j+1) = VL(:,j) - i*VL(:,j+1). */
+
+/* Each eigenvector is scaled so that its largest component has */
+/* abs(real part) + abs(imag. part) = 1, except for eigenvectors */
+/* corresponding to an eigenvalue with alpha = beta = 0, which */
+/* are set to zero. */
+/* Not referenced if JOBVL = 'N'. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the matrix VL. LDVL >= 1, and */
+/* if JOBVL = 'V', LDVL >= N. */
+
+/* VR (output) REAL array, dimension (LDVR,N) */
+/* If JOBVR = 'V', the right eigenvectors x(j) are stored */
+/* in the columns of VR, in the same order as their eigenvalues. */
+/* If the j-th eigenvalue is real, then x(j) = VR(:,j). */
+/* If the j-th and (j+1)-st eigenvalues form a complex conjugate */
+/* pair, then */
+/* x(j) = VR(:,j) + i*VR(:,j+1) */
+/* and */
+/* x(j+1) = VR(:,j) - i*VR(:,j+1). */
+
+/* Each eigenvector is scaled so that its largest component has */
+/* abs(real part) + abs(imag. part) = 1, except for eigenvalues */
+/* corresponding to an eigenvalue with alpha = beta = 0, which */
+/* are set to zero. */
+/* Not referenced if JOBVR = 'N'. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the matrix VR. LDVR >= 1, and */
+/* if JOBVR = 'V', LDVR >= N. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,8*N). */
+/* For good performance, LWORK must generally be larger. */
+/* To compute the optimal value of LWORK, call ILAENV to get */
+/* blocksizes (for SGEQRF, SORMQR, and SORGQR.) Then compute: */
+/* NB -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR; */
+/* The optimal LWORK is: */
+/* 2*N + MAX( 6*N, N*(NB+1) ). */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1,...,N: */
+/* The QZ iteration failed. No eigenvectors have been */
+/* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) */
+/* should be correct for j=INFO+1,...,N. */
+/* > N: errors that usually indicate LAPACK problems: */
+/* =N+1: error return from SGGBAL */
+/* =N+2: error return from SGEQRF */
+/* =N+3: error return from SORMQR */
+/* =N+4: error return from SORGQR */
+/* =N+5: error return from SGGHRD */
+/* =N+6: error return from SHGEQZ (other than failed */
+/* iteration) */
+/* =N+7: error return from STGEVC */
+/* =N+8: error return from SGGBAK (computing VL) */
+/* =N+9: error return from SGGBAK (computing VR) */
+/* =N+10: error return from SLASCL (various calls) */
+
+/* Further Details */
+/* =============== */
+
+/* Balancing */
+/* --------- */
+
+/* This driver calls SGGBAL to both permute and scale rows and columns */
+/* of A and B. The permutations PL and PR are chosen so that PL*A*PR */
+/* and PL*B*R will be upper triangular except for the diagonal blocks */
+/* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as */
+/* possible. The diagonal scaling matrices DL and DR are chosen so */
+/* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to */
+/* one (except for the elements that start out zero.) */
+
+/* After the eigenvalues and eigenvectors of the balanced matrices */
+/* have been computed, SGGBAK transforms the eigenvectors back to what */
+/* they would have been (in perfect arithmetic) if they had not been */
+/* balanced. */
+
+/* Contents of A and B on Exit */
+/* -------- -- - --- - -- ---- */
+
+/* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or */
+/* both), then on exit the arrays A and B will contain the real Schur */
+/* form[*] of the "balanced" versions of A and B. If no eigenvectors */
+/* are computed, then only the diagonal blocks will be correct. */
+
+/* [*] See SHGEQZ, SGEGS, or read the book "Matrix Computations", */
+/* by Golub & van Loan, pub. by Johns Hopkins U. Press. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+
+ /* Function Body */
+ if (lsame_(jobvl, "N")) {
+ ijobvl = 1;
+ ilvl = FALSE_;
+ } else if (lsame_(jobvl, "V")) {
+ ijobvl = 2;
+ ilvl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvl = FALSE_;
+ }
+
+ if (lsame_(jobvr, "N")) {
+ ijobvr = 1;
+ ilvr = FALSE_;
+ } else if (lsame_(jobvr, "V")) {
+ ijobvr = 2;
+ ilvr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvr = FALSE_;
+ }
+ ilv = ilvl || ilvr;
+
+/* Test the input arguments */
+
+/* Computing MAX */
+ i__1 = *n << 3;
+ lwkmin = max(i__1,1);
+ lwkopt = lwkmin;
+ work[1] = (real) lwkopt;
+ lquery = *lwork == -1;
+ *info = 0;
+ if (ijobvl <= 0) {
+ *info = -1;
+ } else if (ijobvr <= 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvl < 1 || ilvl && *ldvl < *n) {
+ *info = -12;
+ } else if (*ldvr < 1 || ilvr && *ldvr < *n) {
+ *info = -14;
+ } else if (*lwork < lwkmin && ! lquery) {
+ *info = -16;
+ }
+
+ if (*info == 0) {
+ nb1 = ilaenv_(&c__1, "SGEQRF", " ", n, n, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "SORMQR", " ", n, n, n, &c_n1);
+ nb3 = ilaenv_(&c__1, "SORGQR", " ", n, n, n, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2);
+ nb = max(i__1,nb3);
+/* Computing MAX */
+ i__1 = *n * 6, i__2 = *n * (nb + 1);
+ lopt = (*n << 1) + max(i__1,i__2);
+ work[1] = (real) lopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGEGV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("E") * slamch_("B");
+ safmin = slamch_("S");
+ safmin += safmin;
+ safmax = 1.f / safmin;
+ onepls = eps * 4 + 1.f;
+
+/* Scale A */
+
+ anrm = slange_("M", n, n, &a[a_offset], lda, &work[1]);
+ anrm1 = anrm;
+ anrm2 = 1.f;
+ if (anrm < 1.f) {
+ if (safmax * anrm < 1.f) {
+ anrm1 = safmin;
+ anrm2 = safmax * anrm;
+ }
+ }
+
+ if (anrm > 0.f) {
+ slascl_("G", &c_n1, &c_n1, &anrm, &c_b27, n, n, &a[a_offset], lda, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 10;
+ return 0;
+ }
+ }
+
+/* Scale B */
+
+ bnrm = slange_("M", n, n, &b[b_offset], ldb, &work[1]);
+ bnrm1 = bnrm;
+ bnrm2 = 1.f;
+ if (bnrm < 1.f) {
+ if (safmax * bnrm < 1.f) {
+ bnrm1 = safmin;
+ bnrm2 = safmax * bnrm;
+ }
+ }
+
+ if (bnrm > 0.f) {
+ slascl_("G", &c_n1, &c_n1, &bnrm, &c_b27, n, n, &b[b_offset], ldb, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 10;
+ return 0;
+ }
+ }
+
+/* Permute the matrix to make it more nearly triangular */
+/* Workspace layout: (8*N words -- "work" requires 6*N words) */
+/* left_permutation, right_permutation, work... */
+
+ ileft = 1;
+ iright = *n + 1;
+ iwork = iright + *n;
+ sggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[
+ ileft], &work[iright], &work[iwork], &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 1;
+ goto L120;
+ }
+
+/* Reduce B to triangular form, and initialize VL and/or VR */
+/* Workspace layout: ("work..." must have at least N words) */
+/* left_permutation, right_permutation, tau, work... */
+
+ irows = ihi + 1 - ilo;
+ if (ilv) {
+ icols = *n + 1 - ilo;
+ } else {
+ icols = irows;
+ }
+ itau = iwork;
+ iwork = itau + irows;
+ i__1 = *lwork + 1 - iwork;
+ sgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
+ iwork], &i__1, &iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 2;
+ goto L120;
+ }
+
+ i__1 = *lwork + 1 - iwork;
+ sormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
+ work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, &
+ iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 3;
+ goto L120;
+ }
+
+ if (ilvl) {
+ slaset_("Full", n, n, &c_b38, &c_b27, &vl[vl_offset], ldvl)
+ ;
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ slacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vl[ilo +
+ 1 + ilo * vl_dim1], ldvl);
+ i__1 = *lwork + 1 - iwork;
+ sorgqr_(&irows, &irows, &irows, &vl[ilo + ilo * vl_dim1], ldvl, &work[
+ itau], &work[iwork], &i__1, &iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 4;
+ goto L120;
+ }
+ }
+
+ if (ilvr) {
+ slaset_("Full", n, n, &c_b38, &c_b27, &vr[vr_offset], ldvr)
+ ;
+ }
+
+/* Reduce to generalized Hessenberg form */
+
+ if (ilv) {
+
+/* Eigenvectors requested -- work on whole matrix. */
+
+ sgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &iinfo);
+ } else {
+ sgghrd_("N", "N", &irows, &c__1, &irows, &a[ilo + ilo * a_dim1], lda,
+ &b[ilo + ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[
+ vr_offset], ldvr, &iinfo);
+ }
+ if (iinfo != 0) {
+ *info = *n + 5;
+ goto L120;
+ }
+
+/* Perform QZ algorithm */
+/* Workspace layout: ("work..." must have at least 1 word) */
+/* left_permutation, right_permutation, work... */
+
+ iwork = itau;
+ if (ilv) {
+ *(unsigned char *)chtemp = 'S';
+ } else {
+ *(unsigned char *)chtemp = 'E';
+ }
+ i__1 = *lwork + 1 - iwork;
+ shgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[
+ b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset],
+ ldvl, &vr[vr_offset], ldvr, &work[iwork], &i__1, &iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = (integer) work[iwork] + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ if (iinfo > 0 && iinfo <= *n) {
+ *info = iinfo;
+ } else if (iinfo > *n && iinfo <= *n << 1) {
+ *info = iinfo - *n;
+ } else {
+ *info = *n + 6;
+ }
+ goto L120;
+ }
+
+ if (ilv) {
+
+/* Compute Eigenvectors (STGEVC requires 6*N words of workspace) */
+
+ if (ilvl) {
+ if (ilvr) {
+ *(unsigned char *)chtemp = 'B';
+ } else {
+ *(unsigned char *)chtemp = 'L';
+ }
+ } else {
+ *(unsigned char *)chtemp = 'R';
+ }
+
+ stgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb,
+ &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[
+ iwork], &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 7;
+ goto L120;
+ }
+
+/* Undo balancing on VL and VR, rescale */
+
+ if (ilvl) {
+ sggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &
+ vl[vl_offset], ldvl, &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 8;
+ goto L120;
+ }
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ if (alphai[jc] < 0.f) {
+ goto L50;
+ }
+ temp = 0.f;
+ if (alphai[jc] == 0.f) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ r__2 = temp, r__3 = (r__1 = vl[jr + jc * vl_dim1],
+ dabs(r__1));
+ temp = dmax(r__2,r__3);
+/* L10: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ r__3 = temp, r__4 = (r__1 = vl[jr + jc * vl_dim1],
+ dabs(r__1)) + (r__2 = vl[jr + (jc + 1) *
+ vl_dim1], dabs(r__2));
+ temp = dmax(r__3,r__4);
+/* L20: */
+ }
+ }
+ if (temp < safmin) {
+ goto L50;
+ }
+ temp = 1.f / temp;
+ if (alphai[jc] == 0.f) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vl[jr + jc * vl_dim1] *= temp;
+/* L30: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vl[jr + jc * vl_dim1] *= temp;
+ vl[jr + (jc + 1) * vl_dim1] *= temp;
+/* L40: */
+ }
+ }
+L50:
+ ;
+ }
+ }
+ if (ilvr) {
+ sggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &
+ vr[vr_offset], ldvr, &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ goto L120;
+ }
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ if (alphai[jc] < 0.f) {
+ goto L100;
+ }
+ temp = 0.f;
+ if (alphai[jc] == 0.f) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ r__2 = temp, r__3 = (r__1 = vr[jr + jc * vr_dim1],
+ dabs(r__1));
+ temp = dmax(r__2,r__3);
+/* L60: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ r__3 = temp, r__4 = (r__1 = vr[jr + jc * vr_dim1],
+ dabs(r__1)) + (r__2 = vr[jr + (jc + 1) *
+ vr_dim1], dabs(r__2));
+ temp = dmax(r__3,r__4);
+/* L70: */
+ }
+ }
+ if (temp < safmin) {
+ goto L100;
+ }
+ temp = 1.f / temp;
+ if (alphai[jc] == 0.f) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vr[jr + jc * vr_dim1] *= temp;
+/* L80: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vr[jr + jc * vr_dim1] *= temp;
+ vr[jr + (jc + 1) * vr_dim1] *= temp;
+/* L90: */
+ }
+ }
+L100:
+ ;
+ }
+ }
+
+/* End of eigenvector calculation */
+
+ }
+
+/* Undo scaling in alpha, beta */
+
+/* Note: this does not give the alpha and beta for the unscaled */
+/* problem. */
+
+/* Un-scaling is limited to avoid underflow in alpha and beta */
+/* if they are significant. */
+
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ absar = (r__1 = alphar[jc], dabs(r__1));
+ absai = (r__1 = alphai[jc], dabs(r__1));
+ absb = (r__1 = beta[jc], dabs(r__1));
+ salfar = anrm * alphar[jc];
+ salfai = anrm * alphai[jc];
+ sbeta = bnrm * beta[jc];
+ ilimit = FALSE_;
+ scale = 1.f;
+
+/* Check for significant underflow in ALPHAI */
+
+/* Computing MAX */
+ r__1 = safmin, r__2 = eps * absar, r__1 = max(r__1,r__2), r__2 = eps *
+ absb;
+ if (dabs(salfai) < safmin && absai >= dmax(r__1,r__2)) {
+ ilimit = TRUE_;
+/* Computing MAX */
+ r__1 = onepls * safmin, r__2 = anrm2 * absai;
+ scale = onepls * safmin / anrm1 / dmax(r__1,r__2);
+
+ } else if (salfai == 0.f) {
+
+/* If insignificant underflow in ALPHAI, then make the */
+/* conjugate eigenvalue real. */
+
+ if (alphai[jc] < 0.f && jc > 1) {
+ alphai[jc - 1] = 0.f;
+ } else if (alphai[jc] > 0.f && jc < *n) {
+ alphai[jc + 1] = 0.f;
+ }
+ }
+
+/* Check for significant underflow in ALPHAR */
+
+/* Computing MAX */
+ r__1 = safmin, r__2 = eps * absai, r__1 = max(r__1,r__2), r__2 = eps *
+ absb;
+ if (dabs(salfar) < safmin && absar >= dmax(r__1,r__2)) {
+ ilimit = TRUE_;
+/* Computing MAX */
+/* Computing MAX */
+ r__3 = onepls * safmin, r__4 = anrm2 * absar;
+ r__1 = scale, r__2 = onepls * safmin / anrm1 / dmax(r__3,r__4);
+ scale = dmax(r__1,r__2);
+ }
+
+/* Check for significant underflow in BETA */
+
+/* Computing MAX */
+ r__1 = safmin, r__2 = eps * absar, r__1 = max(r__1,r__2), r__2 = eps *
+ absai;
+ if (dabs(sbeta) < safmin && absb >= dmax(r__1,r__2)) {
+ ilimit = TRUE_;
+/* Computing MAX */
+/* Computing MAX */
+ r__3 = onepls * safmin, r__4 = bnrm2 * absb;
+ r__1 = scale, r__2 = onepls * safmin / bnrm1 / dmax(r__3,r__4);
+ scale = dmax(r__1,r__2);
+ }
+
+/* Check for possible overflow when limiting scaling */
+
+ if (ilimit) {
+/* Computing MAX */
+ r__1 = dabs(salfar), r__2 = dabs(salfai), r__1 = max(r__1,r__2),
+ r__2 = dabs(sbeta);
+ temp = scale * safmin * dmax(r__1,r__2);
+ if (temp > 1.f) {
+ scale /= temp;
+ }
+ if (scale < 1.f) {
+ ilimit = FALSE_;
+ }
+ }
+
+/* Recompute un-scaled ALPHAR, ALPHAI, BETA if necessary. */
+
+ if (ilimit) {
+ salfar = scale * alphar[jc] * anrm;
+ salfai = scale * alphai[jc] * anrm;
+ sbeta = scale * beta[jc] * bnrm;
+ }
+ alphar[jc] = salfar;
+ alphai[jc] = salfai;
+ beta[jc] = sbeta;
+/* L110: */
+ }
+
+L120:
+ work[1] = (real) lwkopt;
+
+ return 0;
+
+/* End of SGEGV */
+
+} /* sgegv_ */
diff --git a/SRC/sgehd2.c b/SRC/sgehd2.c
new file mode 100644
index 0000000..e7ba694
--- /dev/null
+++ b/SRC/sgehd2.c
@@ -0,0 +1,190 @@
+/* sgehd2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sgehd2_(integer *n, integer *ilo, integer *ihi, real *a,
+ integer *lda, real *tau, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__;
+ real aii;
+ extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *), xerbla_(
+ char *, integer *), slarfg_(integer *, real *, real *,
+ integer *, real *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGEHD2 reduces a real general matrix A to upper Hessenberg form H by */
+/* an orthogonal similarity transformation: Q' * A * Q = H . */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that A is already upper triangular in rows */
+/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
+/* set by a previous call to SGEBAL; otherwise they should be */
+/* set to 1 and N respectively. See Further Details. */
+/* 1 <= ILO <= IHI <= max(1,N). */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the n by n general matrix to be reduced. */
+/* On exit, the upper triangle and the first subdiagonal of A */
+/* are overwritten with the upper Hessenberg matrix H, and the */
+/* elements below the first subdiagonal, with the array TAU, */
+/* represent the orthogonal matrix Q as a product of elementary */
+/* reflectors. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAU (output) REAL array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of (ihi-ilo) elementary */
+/* reflectors */
+
+/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */
+/* exit in A(i+2:ihi,i), and tau in TAU(i). */
+
+/* The contents of A are illustrated by the following example, with */
+/* n = 7, ilo = 2 and ihi = 6: */
+
+/* on entry, on exit, */
+
+/* ( a a a a a a a ) ( a a h h h h a ) */
+/* ( a a a a a a ) ( a h h h h a ) */
+/* ( a a a a a a ) ( h h h h h h ) */
+/* ( a a a a a a ) ( v2 h h h h h ) */
+/* ( a a a a a a ) ( v2 v3 h h h h ) */
+/* ( a a a a a a ) ( v2 v3 v4 h h h ) */
+/* ( a ) ( a ) */
+
+/* where a denotes an element of the original matrix A, h denotes a */
+/* modified element of the upper Hessenberg matrix H, and vi denotes an */
+/* element of the vector defining H(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*ilo < 1 || *ilo > max(1,*n)) {
+ *info = -2;
+ } else if (*ihi < min(*ilo,*n) || *ihi > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGEHD2", &i__1);
+ return 0;
+ }
+
+ i__1 = *ihi - 1;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+
+/* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) */
+
+ i__2 = *ihi - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ slarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *n)+ i__ *
+ a_dim1], &c__1, &tau[i__]);
+ aii = a[i__ + 1 + i__ * a_dim1];
+ a[i__ + 1 + i__ * a_dim1] = 1.f;
+
+/* Apply H(i) to A(1:ihi,i+1:ihi) from the right */
+
+ i__2 = *ihi - i__;
+ slarf_("Right", ihi, &i__2, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
+ i__], &a[(i__ + 1) * a_dim1 + 1], lda, &work[1]);
+
+/* Apply H(i) to A(i+1:ihi,i+1:n) from the left */
+
+ i__2 = *ihi - i__;
+ i__3 = *n - i__;
+ slarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
+ i__], &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1]);
+
+ a[i__ + 1 + i__ * a_dim1] = aii;
+/* L10: */
+ }
+
+ return 0;
+
+/* End of SGEHD2 */
+
+} /* sgehd2_ */
diff --git a/SRC/sgehrd.c b/SRC/sgehrd.c
new file mode 100644
index 0000000..7d6e3cd
--- /dev/null
+++ b/SRC/sgehrd.c
@@ -0,0 +1,338 @@
+/* sgehrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+static integer c__65 = 65;
+static real c_b25 = -1.f;
+static real c_b26 = 1.f;
+
+/* Subroutine */ int sgehrd_(integer *n, integer *ilo, integer *ihi, real *a,
+ integer *lda, real *tau, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j;
+ real t[4160] /* was [65][64] */;
+ integer ib;
+ real ei;
+ integer nb, nh, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *), strmm_(char *, char *, char *,
+ char *, integer *, integer *, real *, real *, integer *, real *,
+ integer *), saxpy_(integer *,
+ real *, real *, integer *, real *, integer *), sgehd2_(integer *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+), slahr2_(integer *, integer *, integer *, real *, integer *,
+ real *, real *, integer *, real *, integer *), slarfb_(char *,
+ char *, char *, char *, integer *, integer *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGEHRD reduces a real general matrix A to upper Hessenberg form H by */
+/* an orthogonal similarity transformation: Q' * A * Q = H . */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that A is already upper triangular in rows */
+/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
+/* set by a previous call to SGEBAL; otherwise they should be */
+/* set to 1 and N respectively. See Further Details. */
+/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the N-by-N general matrix to be reduced. */
+/* On exit, the upper triangle and the first subdiagonal of A */
+/* are overwritten with the upper Hessenberg matrix H, and the */
+/* elements below the first subdiagonal, with the array TAU, */
+/* represent the orthogonal matrix Q as a product of elementary */
+/* reflectors. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAU (output) REAL array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to */
+/* zero. */
+
+/* WORK (workspace/output) REAL array, dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(1,N). */
+/* For optimum performance LWORK >= N*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of (ihi-ilo) elementary */
+/* reflectors */
+
+/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */
+/* exit in A(i+2:ihi,i), and tau in TAU(i). */
+
+/* The contents of A are illustrated by the following example, with */
+/* n = 7, ilo = 2 and ihi = 6: */
+
+/* on entry, on exit, */
+
+/* ( a a a a a a a ) ( a a h h h h a ) */
+/* ( a a a a a a ) ( a h h h h a ) */
+/* ( a a a a a a ) ( h h h h h h ) */
+/* ( a a a a a a ) ( v2 h h h h h ) */
+/* ( a a a a a a ) ( v2 v3 h h h h ) */
+/* ( a a a a a a ) ( v2 v3 v4 h h h ) */
+/* ( a ) ( a ) */
+
+/* where a denotes an element of the original matrix A, h denotes a */
+/* modified element of the upper Hessenberg matrix H, and vi denotes an */
+/* element of the vector defining H(i). */
+
+/* This file is a slight modification of LAPACK-3.0's SGEHRD */
+/* subroutine incorporating improvements proposed by Quintana-Orti and */
+/* Van de Geijn (2005). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+/* Computing MIN */
+ i__1 = 64, i__2 = ilaenv_(&c__1, "SGEHRD", " ", n, ilo, ihi, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = *n * nb;
+ work[1] = (real) lwkopt;
+ lquery = *lwork == -1;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*ilo < 1 || *ilo > max(1,*n)) {
+ *info = -2;
+ } else if (*ihi < min(*ilo,*n) || *ihi > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGEHRD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero */
+
+ i__1 = *ilo - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tau[i__] = 0.f;
+/* L10: */
+ }
+ i__1 = *n - 1;
+ for (i__ = max(1,*ihi); i__ <= i__1; ++i__) {
+ tau[i__] = 0.f;
+/* L20: */
+ }
+
+/* Quick return if possible */
+
+ nh = *ihi - *ilo + 1;
+ if (nh <= 1) {
+ work[1] = 1.f;
+ return 0;
+ }
+
+/* Determine the block size */
+
+/* Computing MIN */
+ i__1 = 64, i__2 = ilaenv_(&c__1, "SGEHRD", " ", n, ilo, ihi, &c_n1);
+ nb = min(i__1,i__2);
+ nbmin = 2;
+ iws = 1;
+ if (nb > 1 && nb < nh) {
+
+/* Determine when to cross over from blocked to unblocked code */
+/* (last block is always handled by unblocked code) */
+
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__3, "SGEHRD", " ", n, ilo, ihi, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < nh) {
+
+/* Determine if workspace is large enough for blocked code */
+
+ iws = *n * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: determine the */
+/* minimum value of NB, and reduce NB or force use of */
+/* unblocked code */
+
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "SGEHRD", " ", n, ilo, ihi, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ if (*lwork >= *n * nbmin) {
+ nb = *lwork / *n;
+ } else {
+ nb = 1;
+ }
+ }
+ }
+ }
+ ldwork = *n;
+
+ if (nb < nbmin || nb >= nh) {
+
+/* Use unblocked code below */
+
+ i__ = *ilo;
+
+ } else {
+
+/* Use blocked code */
+
+ i__1 = *ihi - 1 - nx;
+ i__2 = nb;
+ for (i__ = *ilo; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *ihi - i__;
+ ib = min(i__3,i__4);
+
+/* Reduce columns i:i+ib-1 to Hessenberg form, returning the */
+/* matrices V and T of the block reflector H = I - V*T*V' */
+/* which performs the reduction, and also the matrix Y = A*V*T */
+
+ slahr2_(ihi, &i__, &ib, &a[i__ * a_dim1 + 1], lda, &tau[i__], t, &
+ c__65, &work[1], &ldwork);
+
+/* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the */
+/* right, computing A := A - Y * V'. V(i+ib,ib-1) must be set */
+/* to 1 */
+
+ ei = a[i__ + ib + (i__ + ib - 1) * a_dim1];
+ a[i__ + ib + (i__ + ib - 1) * a_dim1] = 1.f;
+ i__3 = *ihi - i__ - ib + 1;
+ sgemm_("No transpose", "Transpose", ihi, &i__3, &ib, &c_b25, &
+ work[1], &ldwork, &a[i__ + ib + i__ * a_dim1], lda, &
+ c_b26, &a[(i__ + ib) * a_dim1 + 1], lda);
+ a[i__ + ib + (i__ + ib - 1) * a_dim1] = ei;
+
+/* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the */
+/* right */
+
+ i__3 = ib - 1;
+ strmm_("Right", "Lower", "Transpose", "Unit", &i__, &i__3, &c_b26,
+ &a[i__ + 1 + i__ * a_dim1], lda, &work[1], &ldwork);
+ i__3 = ib - 2;
+ for (j = 0; j <= i__3; ++j) {
+ saxpy_(&i__, &c_b25, &work[ldwork * j + 1], &c__1, &a[(i__ +
+ j + 1) * a_dim1 + 1], &c__1);
+/* L30: */
+ }
+
+/* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the */
+/* left */
+
+ i__3 = *ihi - i__;
+ i__4 = *n - i__ - ib + 1;
+ slarfb_("Left", "Transpose", "Forward", "Columnwise", &i__3, &
+ i__4, &ib, &a[i__ + 1 + i__ * a_dim1], lda, t, &c__65, &a[
+ i__ + 1 + (i__ + ib) * a_dim1], lda, &work[1], &ldwork);
+/* L40: */
+ }
+ }
+
+/* Use unblocked code to reduce the rest of the matrix */
+
+ sgehd2_(n, &i__, ihi, &a[a_offset], lda, &tau[1], &work[1], &iinfo);
+ work[1] = (real) iws;
+
+ return 0;
+
+/* End of SGEHRD */
+
+} /* sgehrd_ */
diff --git a/SRC/sgejsv.c b/SRC/sgejsv.c
new file mode 100644
index 0000000..57fe148
--- /dev/null
+++ b/SRC/sgejsv.c
@@ -0,0 +1,2210 @@
+/* sgejsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b34 = 0.f;
+static real c_b35 = 1.f;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int sgejsv_(char *joba, char *jobu, char *jobv, char *jobr,
+ char *jobt, char *jobp, integer *m, integer *n, real *a, integer *lda,
+ real *sva, real *u, integer *ldu, real *v, integer *ldv, real *work,
+ integer *lwork, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10;
+ real r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal), log(doublereal), r_sign(real *, real *);
+ integer i_nint(real *);
+
+ /* Local variables */
+ integer p, q, n1, nr;
+ real big, xsc, big1;
+ logical defr;
+ real aapp, aaqq;
+ logical kill;
+ integer ierr;
+ real temp1;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ logical jracc;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real small, entra, sfmin;
+ logical lsvec;
+ real epsln;
+ logical rsvec;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), sswap_(integer *, real *, integer *, real *, integer *
+);
+ logical l2aber;
+ extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+);
+ real condr1, condr2, uscal1, uscal2;
+ logical l2kill, l2rank, l2tran;
+ extern /* Subroutine */ int sgeqp3_(integer *, integer *, real *, integer
+ *, integer *, real *, real *, integer *, integer *);
+ logical l2pert;
+ real scalem, sconda;
+ logical goscal;
+ real aatmin;
+ extern doublereal slamch_(char *);
+ real aatmax;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical noscal;
+ extern /* Subroutine */ int sgelqf_(integer *, integer *, real *, integer
+ *, real *, real *, integer *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *), sgeqrf_(integer *, integer *, real *, integer *, real *,
+ real *, integer *, integer *), slacpy_(char *, integer *, integer
+ *, real *, integer *, real *, integer *), slaset_(char *,
+ integer *, integer *, real *, real *, real *, integer *);
+ real entrat;
+ logical almort;
+ real maxprj;
+ extern /* Subroutine */ int spocon_(char *, integer *, real *, integer *,
+ real *, real *, real *, integer *, integer *);
+ logical errest;
+ extern /* Subroutine */ int sgesvj_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, integer *, integer *), slassq_(
+ integer *, real *, integer *, real *, real *);
+ logical transp;
+ extern /* Subroutine */ int slaswp_(integer *, real *, integer *, integer
+ *, integer *, integer *, integer *), sorgqr_(integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, integer
+ *), sormlq_(char *, char *, integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, real *, integer *,
+ integer *), sormqr_(char *, char *, integer *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, real *, integer *, integer *);
+ logical rowpiv;
+ real cond_ok__;
+ integer warning, numrank;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Zlatko Drmac of the University of Zagreb and -- */
+/* -- Kresimir Veselic of the Fernuniversitaet Hagen -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* This routine is also part of SIGMA (version 1.23, October 23. 2008.) */
+/* SIGMA is a library of algorithms for highly accurate algorithms for */
+/* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the */
+/* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0. */
+
+/* -#- Scalar Arguments -#- */
+
+
+/* -#- Array Arguments -#- */
+
+/* .. */
+
+/* Purpose */
+/* ~~~~~~~ */
+/* SGEJSV computes the singular value decomposition (SVD) of a real M-by-N */
+/* matrix [A], where M >= N. The SVD of [A] is written as */
+
+/* [A] = [U] * [SIGMA] * [V]^t, */
+
+/* where [SIGMA] is an N-by-N (M-by-N) matrix which is zero except for its N */
+/* diagonal elements, [U] is an M-by-N (or M-by-M) orthonormal matrix, and */
+/* [V] is an N-by-N orthogonal matrix. The diagonal elements of [SIGMA] are */
+/* the singular values of [A]. The columns of [U] and [V] are the left and */
+/* the right singular vectors of [A], respectively. The matrices [U] and [V] */
+/* are computed and stored in the arrays U and V, respectively. The diagonal */
+/* of [SIGMA] is computed and stored in the array SVA. */
+
+/* Further details */
+/* ~~~~~~~~~~~~~~~ */
+/* SGEJSV implements a preconditioned Jacobi SVD algorithm. It uses SGEQP3, */
+/* SGEQRF, and SGELQF as preprocessors and preconditioners. Optionally, an */
+/* additional row pivoting can be used as a preprocessor, which in some */
+/* cases results in much higher accuracy. An example is matrix A with the */
+/* structure A = D1 * C * D2, where D1, D2 are arbitrarily ill-conditioned */
+/* diagonal matrices and C is well-conditioned matrix. In that case, complete */
+/* pivoting in the first QR factorizations provides accuracy dependent on the */
+/* condition number of C, and independent of D1, D2. Such higher accuracy is */
+/* not completely understood theoretically, but it works well in practice. */
+/* Further, if A can be written as A = B*D, with well-conditioned B and some */
+/* diagonal D, then the high accuracy is guaranteed, both theoretically and */
+/* in software, independent of D. For more details see [1], [2]. */
+/* The computational range for the singular values can be the full range */
+/* ( UNDERFLOW,OVERFLOW ), provided that the machine arithmetic and the BLAS */
+/* & LAPACK routines called by SGEJSV are implemented to work in that range. */
+/* If that is not the case, then the restriction for safe computation with */
+/* the singular values in the range of normalized IEEE numbers is that the */
+/* spectral condition number kappa(A)=sigma_max(A)/sigma_min(A) does not */
+/* overflow. This code (SGEJSV) is best used in this restricted range, */
+/* meaning that singular values of magnitude below ||A||_2 / SLAMCH('O') are */
+/* returned as zeros. See JOBR for details on this. */
+/* Further, this implementation is somewhat slower than the one described */
+/* in [1,2] due to replacement of some non-LAPACK components, and because */
+/* the choice of some tuning parameters in the iterative part (SGESVJ) is */
+/* left to the implementer on a particular machine. */
+/* The rank revealing QR factorization (in this code: SGEQP3) should be */
+/* implemented as in [3]. We have a new version of SGEQP3 under development */
+/* that is more robust than the current one in LAPACK, with a cleaner cut in */
+/* rank defficient cases. It will be available in the SIGMA library [4]. */
+/* If M is much larger than N, it is obvious that the inital QRF with */
+/* column pivoting can be preprocessed by the QRF without pivoting. That */
+/* well known trick is not used in SGEJSV because in some cases heavy row */
+/* weighting can be treated with complete pivoting. The overhead in cases */
+/* M much larger than N is then only due to pivoting, but the benefits in */
+/* terms of accuracy have prevailed. The implementer/user can incorporate */
+/* this extra QRF step easily. The implementer can also improve data movement */
+/* (matrix transpose, matrix copy, matrix transposed copy) - this */
+/* implementation of SGEJSV uses only the simplest, naive data movement. */
+
+/* Contributors */
+/* ~~~~~~~~~~~~ */
+/* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) */
+
+/* References */
+/* ~~~~~~~~~~ */
+/* [1] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I. */
+/* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342. */
+/* LAPACK Working note 169. */
+/* [2] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II. */
+/* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362. */
+/* LAPACK Working note 170. */
+/* [3] Z. Drmac and Z. Bujanovic: On the failure of rank-revealing QR */
+/* factorization software - a case study. */
+/* ACM Trans. math. Softw. Vol. 35, No 2 (2008), pp. 1-28. */
+/* LAPACK Working note 176. */
+/* [4] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV, */
+/* QSVD, (H,K)-SVD computations. */
+/* Department of Mathematics, University of Zagreb, 2008. */
+
+/* Bugs, examples and comments */
+/* ~~~~~~~~~~~~~~~~~~~~~~~~~~~ */
+/* Please report all bugs and send interesting examples and/or comments to */
+/* drmac at math.hr. Thank you. */
+
+/* Arguments */
+/* ~~~~~~~~~ */
+/* ............................................................................ */
+/* . JOBA (input) CHARACTER*1 */
+/* . Specifies the level of accuracy: */
+/* . = 'C': This option works well (high relative accuracy) if A = B * D, */
+/* . with well-conditioned B and arbitrary diagonal matrix D. */
+/* . The accuracy cannot be spoiled by COLUMN scaling. The */
+/* . accuracy of the computed output depends on the condition of */
+/* . B, and the procedure aims at the best theoretical accuracy. */
+/* . The relative error max_{i=1:N}|d sigma_i| / sigma_i is */
+/* . bounded by f(M,N)*epsilon* cond(B), independent of D. */
+/* . The input matrix is preprocessed with the QRF with column */
+/* . pivoting. This initial preprocessing and preconditioning by */
+/* . a rank revealing QR factorization is common for all values of */
+/* . JOBA. Additional actions are specified as follows: */
+/* . = 'E': Computation as with 'C' with an additional estimate of the */
+/* . condition number of B. It provides a realistic error bound. */
+/* . = 'F': If A = D1 * C * D2 with ill-conditioned diagonal scalings */
+/* . D1, D2, and well-conditioned matrix C, this option gives */
+/* . higher accuracy than the 'C' option. If the structure of the */
+/* . input matrix is not known, and relative accuracy is */
+/* . desirable, then this option is advisable. The input matrix A */
+/* . is preprocessed with QR factorization with FULL (row and */
+/* . column) pivoting. */
+/* . = 'G' Computation as with 'F' with an additional estimate of the */
+/* . condition number of B, where A=D*B. If A has heavily weighted */
+/* . rows, then using this condition number gives too pessimistic */
+/* . error bound. */
+/* . = 'A': Small singular values are the noise and the matrix is treated */
+/* . as numerically rank defficient. The error in the computed */
+/* . singular values is bounded by f(m,n)*epsilon*||A||. */
+/* . The computed SVD A = U * S * V^t restores A up to */
+/* . f(m,n)*epsilon*||A||. */
+/* . This gives the procedure the licence to discard (set to zero) */
+/* . all singular values below N*epsilon*||A||. */
+/* . = 'R': Similar as in 'A'. Rank revealing property of the initial */
+/* . QR factorization is used do reveal (using triangular factor) */
+/* . a gap sigma_{r+1} < epsilon * sigma_r in which case the */
+/* . numerical RANK is declared to be r. The SVD is computed with */
+/* . absolute error bounds, but more accurately than with 'A'. */
+/* . */
+/* . JOBU (input) CHARACTER*1 */
+/* . Specifies whether to compute the columns of U: */
+/* . = 'U': N columns of U are returned in the array U. */
+/* . = 'F': full set of M left sing. vectors is returned in the array U. */
+/* . = 'W': U may be used as workspace of length M*N. See the description */
+/* . of U. */
+/* . = 'N': U is not computed. */
+/* . */
+/* . JOBV (input) CHARACTER*1 */
+/* . Specifies whether to compute the matrix V: */
+/* . = 'V': N columns of V are returned in the array V; Jacobi rotations */
+/* . are not explicitly accumulated. */
+/* . = 'J': N columns of V are returned in the array V, but they are */
+/* . computed as the product of Jacobi rotations. This option is */
+/* . allowed only if JOBU .NE. 'N', i.e. in computing the full SVD. */
+/* . = 'W': V may be used as workspace of length N*N. See the description */
+/* . of V. */
+/* . = 'N': V is not computed. */
+/* . */
+/* . JOBR (input) CHARACTER*1 */
+/* . Specifies the RANGE for the singular values. Issues the licence to */
+/* . set to zero small positive singular values if they are outside */
+/* . specified range. If A .NE. 0 is scaled so that the largest singular */
+/* . value of c*A is around SQRT(BIG), BIG=SLAMCH('O'), then JOBR issues */
+/* . the licence to kill columns of A whose norm in c*A is less than */
+/* . SQRT(SFMIN) (for JOBR.EQ.'R'), or less than SMALL=SFMIN/EPSLN, */
+/* . where SFMIN=SLAMCH('S'), EPSLN=SLAMCH('E'). */
+/* . = 'N': Do not kill small columns of c*A. This option assumes that */
+/* . BLAS and QR factorizations and triangular solvers are */
+/* . implemented to work in that range. If the condition of A */
+/* . is greater than BIG, use SGESVJ. */
+/* . = 'R': RESTRICTED range for sigma(c*A) is [SQRT(SFMIN), SQRT(BIG)] */
+/* . (roughly, as described above). This option is recommended. */
+/* . ~~~~~~~~~~~~~~~~~~~~~~~~~~~ */
+/* . For computing the singular values in the FULL range [SFMIN,BIG] */
+/* . use SGESVJ. */
+/* . */
+/* . JOBT (input) CHARACTER*1 */
+/* . If the matrix is square then the procedure may determine to use */
+/* . transposed A if A^t seems to be better with respect to convergence. */
+/* . If the matrix is not square, JOBT is ignored. This is subject to */
+/* . changes in the future. */
+/* . The decision is based on two values of entropy over the adjoint */
+/* . orbit of A^t * A. See the descriptions of WORK(6) and WORK(7). */
+/* . = 'T': transpose if entropy test indicates possibly faster */
+/* . convergence of Jacobi process if A^t is taken as input. If A is */
+/* . replaced with A^t, then the row pivoting is included automatically. */
+/* . = 'N': do not speculate. */
+/* . This option can be used to compute only the singular values, or the */
+/* . full SVD (U, SIGMA and V). For only one set of singular vectors */
+/* . (U or V), the caller should provide both U and V, as one of the */
+/* . matrices is used as workspace if the matrix A is transposed. */
+/* . The implementer can easily remove this constraint and make the */
+/* . code more complicated. See the descriptions of U and V. */
+/* . */
+/* . JOBP (input) CHARACTER*1 */
+/* . Issues the licence to introduce structured perturbations to drown */
+/* . denormalized numbers. This licence should be active if the */
+/* . denormals are poorly implemented, causing slow computation, */
+/* . especially in cases of fast convergence (!). For details see [1,2]. */
+/* . For the sake of simplicity, this perturbations are included only */
+/* . when the full SVD or only the singular values are requested. The */
+/* . implementer/user can easily add the perturbation for the cases of */
+/* . computing one set of singular vectors. */
+/* . = 'P': introduce perturbation */
+/* . = 'N': do not perturb */
+/* ............................................................................ */
+
+/* M (input) INTEGER */
+/* The number of rows of the input matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the input matrix A. M >= N >= 0. */
+
+/* A (input/workspace) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* SVA (workspace/output) REAL array, dimension (N) */
+/* On exit, */
+/* - For WORK(1)/WORK(2) = ONE: The singular values of A. During the */
+/* computation SVA contains Euclidean column norms of the */
+/* iterated matrices in the array A. */
+/* - For WORK(1) .NE. WORK(2): The singular values of A are */
+/* (WORK(1)/WORK(2)) * SVA(1:N). This factored form is used if */
+/* sigma_max(A) overflows or if small singular values have been */
+/* saved from underflow by scaling the input matrix A. */
+/* - If JOBR='R' then some of the singular values may be returned */
+/* as exact zeros obtained by "set to zero" because they are */
+/* below the numerical rank threshold or are denormalized numbers. */
+
+/* U (workspace/output) REAL array, dimension ( LDU, N ) */
+/* If JOBU = 'U', then U contains on exit the M-by-N matrix of */
+/* the left singular vectors. */
+/* If JOBU = 'F', then U contains on exit the M-by-M matrix of */
+/* the left singular vectors, including an ONB */
+/* of the orthogonal complement of the Range(A). */
+/* If JOBU = 'W' .AND. (JOBV.EQ.'V' .AND. JOBT.EQ.'T' .AND. M.EQ.N), */
+/* then U is used as workspace if the procedure */
+/* replaces A with A^t. In that case, [V] is computed */
+/* in U as left singular vectors of A^t and then */
+/* copied back to the V array. This 'W' option is just */
+/* a reminder to the caller that in this case U is */
+/* reserved as workspace of length N*N. */
+/* If JOBU = 'N' U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U, LDU >= 1. */
+/* IF JOBU = 'U' or 'F' or 'W', then LDU >= M. */
+
+/* V (workspace/output) REAL array, dimension ( LDV, N ) */
+/* If JOBV = 'V', 'J' then V contains on exit the N-by-N matrix of */
+/* the right singular vectors; */
+/* If JOBV = 'W', AND (JOBU.EQ.'U' AND JOBT.EQ.'T' AND M.EQ.N), */
+/* then V is used as workspace if the pprocedure */
+/* replaces A with A^t. In that case, [U] is computed */
+/* in V as right singular vectors of A^t and then */
+/* copied back to the U array. This 'W' option is just */
+/* a reminder to the caller that in this case V is */
+/* reserved as workspace of length N*N. */
+/* If JOBV = 'N' V is not referenced. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V, LDV >= 1. */
+/* If JOBV = 'V' or 'J' or 'W', then LDV >= N. */
+
+/* WORK (workspace/output) REAL array, dimension at least LWORK. */
+/* On exit, */
+/* WORK(1) = SCALE = WORK(2) / WORK(1) is the scaling factor such */
+/* that SCALE*SVA(1:N) are the computed singular values */
+/* of A. (See the description of SVA().) */
+/* WORK(2) = See the description of WORK(1). */
+/* WORK(3) = SCONDA is an estimate for the condition number of */
+/* column equilibrated A. (If JOBA .EQ. 'E' or 'G') */
+/* SCONDA is an estimate of SQRT(||(R^t * R)^(-1)||_1). */
+/* It is computed using SPOCON. It holds */
+/* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA */
+/* where R is the triangular factor from the QRF of A. */
+/* However, if R is truncated and the numerical rank is */
+/* determined to be strictly smaller than N, SCONDA is */
+/* returned as -1, thus indicating that the smallest */
+/* singular values might be lost. */
+
+/* If full SVD is needed, the following two condition numbers are */
+/* useful for the analysis of the algorithm. They are provied for */
+/* a developer/implementer who is familiar with the details of */
+/* the method. */
+
+/* WORK(4) = an estimate of the scaled condition number of the */
+/* triangular factor in the first QR factorization. */
+/* WORK(5) = an estimate of the scaled condition number of the */
+/* triangular factor in the second QR factorization. */
+/* The following two parameters are computed if JOBT .EQ. 'T'. */
+/* They are provided for a developer/implementer who is familiar */
+/* with the details of the method. */
+
+/* WORK(6) = the entropy of A^t*A :: this is the Shannon entropy */
+/* of diag(A^t*A) / Trace(A^t*A) taken as point in the */
+/* probability simplex. */
+/* WORK(7) = the entropy of A*A^t. */
+
+/* LWORK (input) INTEGER */
+/* Length of WORK to confirm proper allocation of work space. */
+/* LWORK depends on the job: */
+
+/* If only SIGMA is needed ( JOBU.EQ.'N', JOBV.EQ.'N' ) and */
+/* -> .. no scaled condition estimate required ( JOBE.EQ.'N'): */
+/* LWORK >= max(2*M+N,4*N+1,7). This is the minimal requirement. */
+/* For optimal performance (blocked code) the optimal value */
+/* is LWORK >= max(2*M+N,3*N+(N+1)*NB,7). Here NB is the optimal */
+/* block size for xGEQP3/xGEQRF. */
+/* -> .. an estimate of the scaled condition number of A is */
+/* required (JOBA='E', 'G'). In this case, LWORK is the maximum */
+/* of the above and N*N+4*N, i.e. LWORK >= max(2*M+N,N*N+4N,7). */
+
+/* If SIGMA and the right singular vectors are needed (JOBV.EQ.'V'), */
+/* -> the minimal requirement is LWORK >= max(2*N+M,7). */
+/* -> For optimal performance, LWORK >= max(2*N+M,2*N+N*NB,7), */
+/* where NB is the optimal block size. */
+
+/* If SIGMA and the left singular vectors are needed */
+/* -> the minimal requirement is LWORK >= max(2*N+M,7). */
+/* -> For optimal performance, LWORK >= max(2*N+M,2*N+N*NB,7), */
+/* where NB is the optimal block size. */
+
+/* If full SVD is needed ( JOBU.EQ.'U' or 'F', JOBV.EQ.'V' ) and */
+/* -> .. the singular vectors are computed without explicit */
+/* accumulation of the Jacobi rotations, LWORK >= 6*N+2*N*N */
+/* -> .. in the iterative part, the Jacobi rotations are */
+/* explicitly accumulated (option, see the description of JOBV), */
+/* then the minimal requirement is LWORK >= max(M+3*N+N*N,7). */
+/* For better performance, if NB is the optimal block size, */
+/* LWORK >= max(3*N+N*N+M,3*N+N*N+N*NB,7). */
+
+/* IWORK (workspace/output) INTEGER array, dimension M+3*N. */
+/* On exit, */
+/* IWORK(1) = the numerical rank determined after the initial */
+/* QR factorization with pivoting. See the descriptions */
+/* of JOBA and JOBR. */
+/* IWORK(2) = the number of the computed nonzero singular values */
+/* IWORK(3) = if nonzero, a warning message: */
+/* If IWORK(3).EQ.1 then some of the column norms of A */
+/* were denormalized floats. The requested high accuracy */
+/* is not warranted by the data. */
+
+/* INFO (output) INTEGER */
+/* < 0 : if INFO = -i, then the i-th argument had an illegal value. */
+/* = 0 : successfull exit; */
+/* > 0 : SGEJSV did not converge in the maximal allowed number */
+/* of sweeps. The computed values may be inaccurate. */
+
+/* ............................................................................ */
+
+/* Local Parameters: */
+
+
+/* Local Scalars: */
+
+
+/* Intrinsic Functions: */
+
+
+/* External Functions: */
+
+
+/* External Subroutines ( BLAS, LAPACK ): */
+
+
+
+/* ............................................................................ */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --sva;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ lsvec = lsame_(jobu, "U") || lsame_(jobu, "F");
+ jracc = lsame_(jobv, "J");
+ rsvec = lsame_(jobv, "V") || jracc;
+ rowpiv = lsame_(joba, "F") || lsame_(joba, "G");
+ l2rank = lsame_(joba, "R");
+ l2aber = lsame_(joba, "A");
+ errest = lsame_(joba, "E") || lsame_(joba, "G");
+ l2tran = lsame_(jobt, "T");
+ l2kill = lsame_(jobr, "R");
+ defr = lsame_(jobr, "N");
+ l2pert = lsame_(jobp, "P");
+
+ if (! (rowpiv || l2rank || l2aber || errest || lsame_(joba, "C"))) {
+ *info = -1;
+ } else if (! (lsvec || lsame_(jobu, "N") || lsame_(
+ jobu, "W"))) {
+ *info = -2;
+ } else if (! (rsvec || lsame_(jobv, "N") || lsame_(
+ jobv, "W")) || jracc && ! lsvec) {
+ *info = -3;
+ } else if (! (l2kill || defr)) {
+ *info = -4;
+ } else if (! (l2tran || lsame_(jobt, "N"))) {
+ *info = -5;
+ } else if (! (l2pert || lsame_(jobp, "N"))) {
+ *info = -6;
+ } else if (*m < 0) {
+ *info = -7;
+ } else if (*n < 0 || *n > *m) {
+ *info = -8;
+ } else if (*lda < *m) {
+ *info = -10;
+ } else if (lsvec && *ldu < *m) {
+ *info = -13;
+ } else if (rsvec && *ldv < *n) {
+ *info = -14;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = 7, i__2 = (*n << 2) + 1, i__1 = max(i__1,i__2), i__2 = (*m <<
+ 1) + *n;
+/* Computing MAX */
+ i__3 = 7, i__4 = (*n << 2) + *n * *n, i__3 = max(i__3,i__4), i__4 = (*
+ m << 1) + *n;
+/* Computing MAX */
+ i__5 = 7, i__6 = (*n << 1) + *m;
+/* Computing MAX */
+ i__7 = 7, i__8 = (*n << 1) + *m;
+/* Computing MAX */
+ i__9 = 7, i__10 = *m + *n * 3 + *n * *n;
+ if (! (lsvec || rsvec || errest) && *lwork < max(i__1,i__2) || ! (
+ lsvec || lsvec) && errest && *lwork < max(i__3,i__4) || lsvec
+ && ! rsvec && *lwork < max(i__5,i__6) || rsvec && ! lsvec && *
+ lwork < max(i__7,i__8) || lsvec && rsvec && ! jracc && *lwork
+ < *n * 6 + (*n << 1) * *n || lsvec && rsvec && jracc && *
+ lwork < max(i__9,i__10)) {
+ *info = -17;
+ } else {
+/* #:) */
+ *info = 0;
+ }
+ }
+
+ if (*info != 0) {
+/* #:( */
+ i__1 = -(*info);
+ xerbla_("SGEJSV", &i__1);
+ }
+
+/* Quick return for void matrix (Y3K safe) */
+/* #:) */
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Determine whether the matrix U should be M x N or M x M */
+
+ if (lsvec) {
+ n1 = *n;
+ if (lsame_(jobu, "F")) {
+ n1 = *m;
+ }
+ }
+
+/* Set numerical parameters */
+
+/* ! NOTE: Make sure SLAMCH() does not fail on the target architecture. */
+
+ epsln = slamch_("Epsilon");
+ sfmin = slamch_("SafeMinimum");
+ small = sfmin / epsln;
+ big = slamch_("O");
+
+/* Initialize SVA(1:N) = diag( ||A e_i||_2 )_1^N */
+
+/* (!) If necessary, scale SVA() to protect the largest norm from */
+/* overflow. It is possible that this scaling pushes the smallest */
+/* column norm left from the underflow threshold (extreme case). */
+
+ scalem = 1.f / sqrt((real) (*m) * (real) (*n));
+ noscal = TRUE_;
+ goscal = TRUE_;
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ aapp = 0.f;
+ aaqq = 0.f;
+ slassq_(m, &a[p * a_dim1 + 1], &c__1, &aapp, &aaqq);
+ if (aapp > big) {
+ *info = -9;
+ i__2 = -(*info);
+ xerbla_("SGEJSV", &i__2);
+ return 0;
+ }
+ aaqq = sqrt(aaqq);
+ if (aapp < big / aaqq && noscal) {
+ sva[p] = aapp * aaqq;
+ } else {
+ noscal = FALSE_;
+ sva[p] = aapp * (aaqq * scalem);
+ if (goscal) {
+ goscal = FALSE_;
+ i__2 = p - 1;
+ sscal_(&i__2, &scalem, &sva[1], &c__1);
+ }
+ }
+/* L1874: */
+ }
+
+ if (noscal) {
+ scalem = 1.f;
+ }
+
+ aapp = 0.f;
+ aaqq = big;
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+/* Computing MAX */
+ r__1 = aapp, r__2 = sva[p];
+ aapp = dmax(r__1,r__2);
+ if (sva[p] != 0.f) {
+/* Computing MIN */
+ r__1 = aaqq, r__2 = sva[p];
+ aaqq = dmin(r__1,r__2);
+ }
+/* L4781: */
+ }
+
+/* Quick return for zero M x N matrix */
+/* #:) */
+ if (aapp == 0.f) {
+ if (lsvec) {
+ slaset_("G", m, &n1, &c_b34, &c_b35, &u[u_offset], ldu)
+ ;
+ }
+ if (rsvec) {
+ slaset_("G", n, n, &c_b34, &c_b35, &v[v_offset], ldv);
+ }
+ work[1] = 1.f;
+ work[2] = 1.f;
+ if (errest) {
+ work[3] = 1.f;
+ }
+ if (lsvec && rsvec) {
+ work[4] = 1.f;
+ work[5] = 1.f;
+ }
+ if (l2tran) {
+ work[6] = 0.f;
+ work[7] = 0.f;
+ }
+ iwork[1] = 0;
+ iwork[2] = 0;
+ return 0;
+ }
+
+/* Issue warning if denormalized column norms detected. Override the */
+/* high relative accuracy request. Issue licence to kill columns */
+/* (set them to zero) whose norm is less than sigma_max / BIG (roughly). */
+/* #:( */
+ warning = 0;
+ if (aaqq <= sfmin) {
+ l2rank = TRUE_;
+ l2kill = TRUE_;
+ warning = 1;
+ }
+
+/* Quick return for one-column matrix */
+/* #:) */
+ if (*n == 1) {
+
+ if (lsvec) {
+ slascl_("G", &c__0, &c__0, &sva[1], &scalem, m, &c__1, &a[a_dim1
+ + 1], lda, &ierr);
+ slacpy_("A", m, &c__1, &a[a_offset], lda, &u[u_offset], ldu);
+/* computing all M left singular vectors of the M x 1 matrix */
+ if (n1 != *n) {
+ i__1 = *lwork - *n;
+ sgeqrf_(m, n, &u[u_offset], ldu, &work[1], &work[*n + 1], &
+ i__1, &ierr);
+ i__1 = *lwork - *n;
+ sorgqr_(m, &n1, &c__1, &u[u_offset], ldu, &work[1], &work[*n
+ + 1], &i__1, &ierr);
+ scopy_(m, &a[a_dim1 + 1], &c__1, &u[u_dim1 + 1], &c__1);
+ }
+ }
+ if (rsvec) {
+ v[v_dim1 + 1] = 1.f;
+ }
+ if (sva[1] < big * scalem) {
+ sva[1] /= scalem;
+ scalem = 1.f;
+ }
+ work[1] = 1.f / scalem;
+ work[2] = 1.f;
+ if (sva[1] != 0.f) {
+ iwork[1] = 1;
+ if (sva[1] / scalem >= sfmin) {
+ iwork[2] = 1;
+ } else {
+ iwork[2] = 0;
+ }
+ } else {
+ iwork[1] = 0;
+ iwork[2] = 0;
+ }
+ if (errest) {
+ work[3] = 1.f;
+ }
+ if (lsvec && rsvec) {
+ work[4] = 1.f;
+ work[5] = 1.f;
+ }
+ if (l2tran) {
+ work[6] = 0.f;
+ work[7] = 0.f;
+ }
+ return 0;
+
+ }
+
+ transp = FALSE_;
+ l2tran = l2tran && *m == *n;
+
+ aatmax = -1.f;
+ aatmin = big;
+ if (rowpiv || l2tran) {
+
+/* Compute the row norms, needed to determine row pivoting sequence */
+/* (in the case of heavily row weighted A, row pivoting is strongly */
+/* advised) and to collect information needed to compare the */
+/* structures of A * A^t and A^t * A (in the case L2TRAN.EQ..TRUE.). */
+
+ if (l2tran) {
+ i__1 = *m;
+ for (p = 1; p <= i__1; ++p) {
+ xsc = 0.f;
+ temp1 = 0.f;
+ slassq_(n, &a[p + a_dim1], lda, &xsc, &temp1);
+/* SLASSQ gets both the ell_2 and the ell_infinity norm */
+/* in one pass through the vector */
+ work[*m + *n + p] = xsc * scalem;
+ work[*n + p] = xsc * (scalem * sqrt(temp1));
+/* Computing MAX */
+ r__1 = aatmax, r__2 = work[*n + p];
+ aatmax = dmax(r__1,r__2);
+ if (work[*n + p] != 0.f) {
+/* Computing MIN */
+ r__1 = aatmin, r__2 = work[*n + p];
+ aatmin = dmin(r__1,r__2);
+ }
+/* L1950: */
+ }
+ } else {
+ i__1 = *m;
+ for (p = 1; p <= i__1; ++p) {
+ work[*m + *n + p] = scalem * (r__1 = a[p + isamax_(n, &a[p +
+ a_dim1], lda) * a_dim1], dabs(r__1));
+/* Computing MAX */
+ r__1 = aatmax, r__2 = work[*m + *n + p];
+ aatmax = dmax(r__1,r__2);
+/* Computing MIN */
+ r__1 = aatmin, r__2 = work[*m + *n + p];
+ aatmin = dmin(r__1,r__2);
+/* L1904: */
+ }
+ }
+
+ }
+
+/* For square matrix A try to determine whether A^t would be better */
+/* input for the preconditioned Jacobi SVD, with faster convergence. */
+/* The decision is based on an O(N) function of the vector of column */
+/* and row norms of A, based on the Shannon entropy. This should give */
+/* the right choice in most cases when the difference actually matters. */
+/* It may fail and pick the slower converging side. */
+
+ entra = 0.f;
+ entrat = 0.f;
+ if (l2tran) {
+
+ xsc = 0.f;
+ temp1 = 0.f;
+ slassq_(n, &sva[1], &c__1, &xsc, &temp1);
+ temp1 = 1.f / temp1;
+
+ entra = 0.f;
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+/* Computing 2nd power */
+ r__1 = sva[p] / xsc;
+ big1 = r__1 * r__1 * temp1;
+ if (big1 != 0.f) {
+ entra += big1 * log(big1);
+ }
+/* L1113: */
+ }
+ entra = -entra / log((real) (*n));
+
+/* Now, SVA().^2/Trace(A^t * A) is a point in the probability simplex. */
+/* It is derived from the diagonal of A^t * A. Do the same with the */
+/* diagonal of A * A^t, compute the entropy of the corresponding */
+/* probability distribution. Note that A * A^t and A^t * A have the */
+/* same trace. */
+
+ entrat = 0.f;
+ i__1 = *n + *m;
+ for (p = *n + 1; p <= i__1; ++p) {
+/* Computing 2nd power */
+ r__1 = work[p] / xsc;
+ big1 = r__1 * r__1 * temp1;
+ if (big1 != 0.f) {
+ entrat += big1 * log(big1);
+ }
+/* L1114: */
+ }
+ entrat = -entrat / log((real) (*m));
+
+/* Analyze the entropies and decide A or A^t. Smaller entropy */
+/* usually means better input for the algorithm. */
+
+ transp = entrat < entra;
+
+/* If A^t is better than A, transpose A. */
+
+ if (transp) {
+/* In an optimal implementation, this trivial transpose */
+/* should be replaced with faster transpose. */
+ i__1 = *n - 1;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = *n;
+ for (q = p + 1; q <= i__2; ++q) {
+ temp1 = a[q + p * a_dim1];
+ a[q + p * a_dim1] = a[p + q * a_dim1];
+ a[p + q * a_dim1] = temp1;
+/* L1116: */
+ }
+/* L1115: */
+ }
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ work[*m + *n + p] = sva[p];
+ sva[p] = work[*n + p];
+/* L1117: */
+ }
+ temp1 = aapp;
+ aapp = aatmax;
+ aatmax = temp1;
+ temp1 = aaqq;
+ aaqq = aatmin;
+ aatmin = temp1;
+ kill = lsvec;
+ lsvec = rsvec;
+ rsvec = kill;
+
+ rowpiv = TRUE_;
+ }
+
+ }
+/* END IF L2TRAN */
+
+/* Scale the matrix so that its maximal singular value remains less */
+/* than SQRT(BIG) -- the matrix is scaled so that its maximal column */
+/* has Euclidean norm equal to SQRT(BIG/N). The only reason to keep */
+/* SQRT(BIG) instead of BIG is the fact that SGEJSV uses LAPACK and */
+/* BLAS routines that, in some implementations, are not capable of */
+/* working in the full interval [SFMIN,BIG] and that they may provoke */
+/* overflows in the intermediate results. If the singular values spread */
+/* from SFMIN to BIG, then SGESVJ will compute them. So, in that case, */
+/* one should use SGESVJ instead of SGEJSV. */
+
+ big1 = sqrt(big);
+ temp1 = sqrt(big / (real) (*n));
+
+ slascl_("G", &c__0, &c__0, &aapp, &temp1, n, &c__1, &sva[1], n, &ierr);
+ if (aaqq > aapp * sfmin) {
+ aaqq = aaqq / aapp * temp1;
+ } else {
+ aaqq = aaqq * temp1 / aapp;
+ }
+ temp1 *= scalem;
+ slascl_("G", &c__0, &c__0, &aapp, &temp1, m, n, &a[a_offset], lda, &ierr);
+
+/* To undo scaling at the end of this procedure, multiply the */
+/* computed singular values with USCAL2 / USCAL1. */
+
+ uscal1 = temp1;
+ uscal2 = aapp;
+
+ if (l2kill) {
+/* L2KILL enforces computation of nonzero singular values in */
+/* the restricted range of condition number of the initial A, */
+/* sigma_max(A) / sigma_min(A) approx. SQRT(BIG)/SQRT(SFMIN). */
+ xsc = sqrt(sfmin);
+ } else {
+ xsc = small;
+
+/* Now, if the condition number of A is too big, */
+/* sigma_max(A) / sigma_min(A) .GT. SQRT(BIG/N) * EPSLN / SFMIN, */
+/* as a precaution measure, the full SVD is computed using SGESVJ */
+/* with accumulated Jacobi rotations. This provides numerically */
+/* more robust computation, at the cost of slightly increased run */
+/* time. Depending on the concrete implementation of BLAS and LAPACK */
+/* (i.e. how they behave in presence of extreme ill-conditioning) the */
+/* implementor may decide to remove this switch. */
+ if (aaqq < sqrt(sfmin) && lsvec && rsvec) {
+ jracc = TRUE_;
+ }
+
+ }
+ if (aaqq < xsc) {
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ if (sva[p] < xsc) {
+ slaset_("A", m, &c__1, &c_b34, &c_b34, &a[p * a_dim1 + 1],
+ lda);
+ sva[p] = 0.f;
+ }
+/* L700: */
+ }
+ }
+
+/* Preconditioning using QR factorization with pivoting */
+
+ if (rowpiv) {
+/* Optional row permutation (Bjoerck row pivoting): */
+/* A result by Cox and Higham shows that the Bjoerck's */
+/* row pivoting combined with standard column pivoting */
+/* has similar effect as Powell-Reid complete pivoting. */
+/* The ell-infinity norms of A are made nonincreasing. */
+ i__1 = *m - 1;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = *m - p + 1;
+ q = isamax_(&i__2, &work[*m + *n + p], &c__1) + p - 1;
+ iwork[(*n << 1) + p] = q;
+ if (p != q) {
+ temp1 = work[*m + *n + p];
+ work[*m + *n + p] = work[*m + *n + q];
+ work[*m + *n + q] = temp1;
+ }
+/* L1952: */
+ }
+ i__1 = *m - 1;
+ slaswp_(n, &a[a_offset], lda, &c__1, &i__1, &iwork[(*n << 1) + 1], &
+ c__1);
+ }
+
+/* End of the preparation phase (scaling, optional sorting and */
+/* transposing, optional flushing of small columns). */
+
+/* Preconditioning */
+
+/* If the full SVD is needed, the right singular vectors are computed */
+/* from a matrix equation, and for that we need theoretical analysis */
+/* of the Businger-Golub pivoting. So we use SGEQP3 as the first RR QRF. */
+/* In all other cases the first RR QRF can be chosen by other criteria */
+/* (eg speed by replacing global with restricted window pivoting, such */
+/* as in SGEQPX from TOMS # 782). Good results will be obtained using */
+/* SGEQPX with properly (!) chosen numerical parameters. */
+/* Any improvement of SGEQP3 improves overal performance of SGEJSV. */
+
+/* A * P1 = Q1 * [ R1^t 0]^t: */
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+/* .. all columns are free columns */
+ iwork[p] = 0;
+/* L1963: */
+ }
+ i__1 = *lwork - *n;
+ sgeqp3_(m, n, &a[a_offset], lda, &iwork[1], &work[1], &work[*n + 1], &
+ i__1, &ierr);
+
+/* The upper triangular matrix R1 from the first QRF is inspected for */
+/* rank deficiency and possibilities for deflation, or possible */
+/* ill-conditioning. Depending on the user specified flag L2RANK, */
+/* the procedure explores possibilities to reduce the numerical */
+/* rank by inspecting the computed upper triangular factor. If */
+/* L2RANK or L2ABER are up, then SGEJSV will compute the SVD of */
+/* A + dA, where ||dA|| <= f(M,N)*EPSLN. */
+
+ nr = 1;
+ if (l2aber) {
+/* Standard absolute error bound suffices. All sigma_i with */
+/* sigma_i < N*EPSLN*||A|| are flushed to zero. This is an */
+/* agressive enforcement of lower numerical rank by introducing a */
+/* backward error of the order of N*EPSLN*||A||. */
+ temp1 = sqrt((real) (*n)) * epsln;
+ i__1 = *n;
+ for (p = 2; p <= i__1; ++p) {
+ if ((r__2 = a[p + p * a_dim1], dabs(r__2)) >= temp1 * (r__1 = a[
+ a_dim1 + 1], dabs(r__1))) {
+ ++nr;
+ } else {
+ goto L3002;
+ }
+/* L3001: */
+ }
+L3002:
+ ;
+ } else if (l2rank) {
+/* .. similarly as above, only slightly more gentle (less agressive). */
+/* Sudden drop on the diagonal of R1 is used as the criterion for */
+/* close-to-rank-defficient. */
+ temp1 = sqrt(sfmin);
+ i__1 = *n;
+ for (p = 2; p <= i__1; ++p) {
+ if ((r__2 = a[p + p * a_dim1], dabs(r__2)) < epsln * (r__1 = a[p
+ - 1 + (p - 1) * a_dim1], dabs(r__1)) || (r__3 = a[p + p *
+ a_dim1], dabs(r__3)) < small || l2kill && (r__4 = a[p + p
+ * a_dim1], dabs(r__4)) < temp1) {
+ goto L3402;
+ }
+ ++nr;
+/* L3401: */
+ }
+L3402:
+
+ ;
+ } else {
+/* The goal is high relative accuracy. However, if the matrix */
+/* has high scaled condition number the relative accuracy is in */
+/* general not feasible. Later on, a condition number estimator */
+/* will be deployed to estimate the scaled condition number. */
+/* Here we just remove the underflowed part of the triangular */
+/* factor. This prevents the situation in which the code is */
+/* working hard to get the accuracy not warranted by the data. */
+ temp1 = sqrt(sfmin);
+ i__1 = *n;
+ for (p = 2; p <= i__1; ++p) {
+ if ((r__1 = a[p + p * a_dim1], dabs(r__1)) < small || l2kill && (
+ r__2 = a[p + p * a_dim1], dabs(r__2)) < temp1) {
+ goto L3302;
+ }
+ ++nr;
+/* L3301: */
+ }
+L3302:
+
+ ;
+ }
+
+ almort = FALSE_;
+ if (nr == *n) {
+ maxprj = 1.f;
+ i__1 = *n;
+ for (p = 2; p <= i__1; ++p) {
+ temp1 = (r__1 = a[p + p * a_dim1], dabs(r__1)) / sva[iwork[p]];
+ maxprj = dmin(maxprj,temp1);
+/* L3051: */
+ }
+/* Computing 2nd power */
+ r__1 = maxprj;
+ if (r__1 * r__1 >= 1.f - (real) (*n) * epsln) {
+ almort = TRUE_;
+ }
+ }
+
+
+ sconda = -1.f;
+ condr1 = -1.f;
+ condr2 = -1.f;
+
+ if (errest) {
+ if (*n == nr) {
+ if (rsvec) {
+/* .. V is available as workspace */
+ slacpy_("U", n, n, &a[a_offset], lda, &v[v_offset], ldv);
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ temp1 = sva[iwork[p]];
+ r__1 = 1.f / temp1;
+ sscal_(&p, &r__1, &v[p * v_dim1 + 1], &c__1);
+/* L3053: */
+ }
+ spocon_("U", n, &v[v_offset], ldv, &c_b35, &temp1, &work[*n +
+ 1], &iwork[(*n << 1) + *m + 1], &ierr);
+ } else if (lsvec) {
+/* .. U is available as workspace */
+ slacpy_("U", n, n, &a[a_offset], lda, &u[u_offset], ldu);
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ temp1 = sva[iwork[p]];
+ r__1 = 1.f / temp1;
+ sscal_(&p, &r__1, &u[p * u_dim1 + 1], &c__1);
+/* L3054: */
+ }
+ spocon_("U", n, &u[u_offset], ldu, &c_b35, &temp1, &work[*n +
+ 1], &iwork[(*n << 1) + *m + 1], &ierr);
+ } else {
+ slacpy_("U", n, n, &a[a_offset], lda, &work[*n + 1], n);
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ temp1 = sva[iwork[p]];
+ r__1 = 1.f / temp1;
+ sscal_(&p, &r__1, &work[*n + (p - 1) * *n + 1], &c__1);
+/* L3052: */
+ }
+/* .. the columns of R are scaled to have unit Euclidean lengths. */
+ spocon_("U", n, &work[*n + 1], n, &c_b35, &temp1, &work[*n + *
+ n * *n + 1], &iwork[(*n << 1) + *m + 1], &ierr);
+ }
+ sconda = 1.f / sqrt(temp1);
+/* SCONDA is an estimate of SQRT(||(R^t * R)^(-1)||_1). */
+/* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA */
+ } else {
+ sconda = -1.f;
+ }
+ }
+
+ l2pert = l2pert && (r__1 = a[a_dim1 + 1] / a[nr + nr * a_dim1], dabs(r__1)
+ ) > sqrt(big1);
+/* If there is no violent scaling, artificial perturbation is not needed. */
+
+/* Phase 3: */
+
+ if (! (rsvec || lsvec)) {
+
+/* Singular Values only */
+
+/* .. transpose A(1:NR,1:N) */
+/* Computing MIN */
+ i__2 = *n - 1;
+ i__1 = min(i__2,nr);
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = *n - p;
+ scopy_(&i__2, &a[p + (p + 1) * a_dim1], lda, &a[p + 1 + p *
+ a_dim1], &c__1);
+/* L1946: */
+ }
+
+/* The following two DO-loops introduce small relative perturbation */
+/* into the strict upper triangle of the lower triangular matrix. */
+/* Small entries below the main diagonal are also changed. */
+/* This modification is useful if the computing environment does not */
+/* provide/allow FLUSH TO ZERO underflow, for it prevents many */
+/* annoying denormalized numbers in case of strongly scaled matrices. */
+/* The perturbation is structured so that it does not introduce any */
+/* new perturbation of the singular values, and it does not destroy */
+/* the job done by the preconditioner. */
+/* The licence for this perturbation is in the variable L2PERT, which */
+/* should be .FALSE. if FLUSH TO ZERO underflow is active. */
+
+ if (! almort) {
+
+ if (l2pert) {
+/* XSC = SQRT(SMALL) */
+ xsc = epsln / (real) (*n);
+ i__1 = nr;
+ for (q = 1; q <= i__1; ++q) {
+ temp1 = xsc * (r__1 = a[q + q * a_dim1], dabs(r__1));
+ i__2 = *n;
+ for (p = 1; p <= i__2; ++p) {
+ if (p > q && (r__1 = a[p + q * a_dim1], dabs(r__1)) <=
+ temp1 || p < q) {
+ a[p + q * a_dim1] = r_sign(&temp1, &a[p + q *
+ a_dim1]);
+ }
+/* L4949: */
+ }
+/* L4947: */
+ }
+ } else {
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ slaset_("U", &i__1, &i__2, &c_b34, &c_b34, &a[(a_dim1 << 1) +
+ 1], lda);
+ }
+
+/* .. second preconditioning using the QR factorization */
+
+ i__1 = *lwork - *n;
+ sgeqrf_(n, &nr, &a[a_offset], lda, &work[1], &work[*n + 1], &i__1,
+ &ierr);
+
+/* .. and transpose upper to lower triangular */
+ i__1 = nr - 1;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = nr - p;
+ scopy_(&i__2, &a[p + (p + 1) * a_dim1], lda, &a[p + 1 + p *
+ a_dim1], &c__1);
+/* L1948: */
+ }
+
+ }
+
+/* Row-cyclic Jacobi SVD algorithm with column pivoting */
+
+/* .. again some perturbation (a "background noise") is added */
+/* to drown denormals */
+ if (l2pert) {
+/* XSC = SQRT(SMALL) */
+ xsc = epsln / (real) (*n);
+ i__1 = nr;
+ for (q = 1; q <= i__1; ++q) {
+ temp1 = xsc * (r__1 = a[q + q * a_dim1], dabs(r__1));
+ i__2 = nr;
+ for (p = 1; p <= i__2; ++p) {
+ if (p > q && (r__1 = a[p + q * a_dim1], dabs(r__1)) <=
+ temp1 || p < q) {
+ a[p + q * a_dim1] = r_sign(&temp1, &a[p + q * a_dim1])
+ ;
+ }
+/* L1949: */
+ }
+/* L1947: */
+ }
+ } else {
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ slaset_("U", &i__1, &i__2, &c_b34, &c_b34, &a[(a_dim1 << 1) + 1],
+ lda);
+ }
+
+/* .. and one-sided Jacobi rotations are started on a lower */
+/* triangular matrix (plus perturbation which is ignored in */
+/* the part which destroys triangular form (confusing?!)) */
+
+ sgesvj_("L", "NoU", "NoV", &nr, &nr, &a[a_offset], lda, &sva[1], n, &
+ v[v_offset], ldv, &work[1], lwork, info);
+
+ scalem = work[1];
+ numrank = i_nint(&work[2]);
+
+
+ } else if (rsvec && ! lsvec) {
+
+/* -> Singular Values and Right Singular Vectors <- */
+
+ if (almort) {
+
+/* .. in this case NR equals N */
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = *n - p + 1;
+ scopy_(&i__2, &a[p + p * a_dim1], lda, &v[p + p * v_dim1], &
+ c__1);
+/* L1998: */
+ }
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ slaset_("Upper", &i__1, &i__2, &c_b34, &c_b34, &v[(v_dim1 << 1) +
+ 1], ldv);
+
+ sgesvj_("L", "U", "N", n, &nr, &v[v_offset], ldv, &sva[1], &nr, &
+ a[a_offset], lda, &work[1], lwork, info);
+ scalem = work[1];
+ numrank = i_nint(&work[2]);
+ } else {
+
+/* .. two more QR factorizations ( one QRF is not enough, two require */
+/* accumulated product of Jacobi rotations, three are perfect ) */
+
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ slaset_("Lower", &i__1, &i__2, &c_b34, &c_b34, &a[a_dim1 + 2],
+ lda);
+ i__1 = *lwork - *n;
+ sgelqf_(&nr, n, &a[a_offset], lda, &work[1], &work[*n + 1], &i__1,
+ &ierr);
+ slacpy_("Lower", &nr, &nr, &a[a_offset], lda, &v[v_offset], ldv);
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ slaset_("Upper", &i__1, &i__2, &c_b34, &c_b34, &v[(v_dim1 << 1) +
+ 1], ldv);
+ i__1 = *lwork - (*n << 1);
+ sgeqrf_(&nr, &nr, &v[v_offset], ldv, &work[*n + 1], &work[(*n <<
+ 1) + 1], &i__1, &ierr);
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = nr - p + 1;
+ scopy_(&i__2, &v[p + p * v_dim1], ldv, &v[p + p * v_dim1], &
+ c__1);
+/* L8998: */
+ }
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ slaset_("Upper", &i__1, &i__2, &c_b34, &c_b34, &v[(v_dim1 << 1) +
+ 1], ldv);
+
+ sgesvj_("Lower", "U", "N", &nr, &nr, &v[v_offset], ldv, &sva[1], &
+ nr, &u[u_offset], ldu, &work[*n + 1], lwork, info);
+ scalem = work[*n + 1];
+ numrank = i_nint(&work[*n + 2]);
+ if (nr < *n) {
+ i__1 = *n - nr;
+ slaset_("A", &i__1, &nr, &c_b34, &c_b34, &v[nr + 1 + v_dim1],
+ ldv);
+ i__1 = *n - nr;
+ slaset_("A", &nr, &i__1, &c_b34, &c_b34, &v[(nr + 1) * v_dim1
+ + 1], ldv);
+ i__1 = *n - nr;
+ i__2 = *n - nr;
+ slaset_("A", &i__1, &i__2, &c_b34, &c_b35, &v[nr + 1 + (nr +
+ 1) * v_dim1], ldv);
+ }
+
+ i__1 = *lwork - *n;
+ sormlq_("Left", "Transpose", n, n, &nr, &a[a_offset], lda, &work[
+ 1], &v[v_offset], ldv, &work[*n + 1], &i__1, &ierr);
+
+ }
+
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ scopy_(n, &v[p + v_dim1], ldv, &a[iwork[p] + a_dim1], lda);
+/* L8991: */
+ }
+ slacpy_("All", n, n, &a[a_offset], lda, &v[v_offset], ldv);
+
+ if (transp) {
+ slacpy_("All", n, n, &v[v_offset], ldv, &u[u_offset], ldu);
+ }
+
+ } else if (lsvec && ! rsvec) {
+
+/* -#- Singular Values and Left Singular Vectors -#- */
+
+/* .. second preconditioning step to avoid need to accumulate */
+/* Jacobi rotations in the Jacobi iterations. */
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = *n - p + 1;
+ scopy_(&i__2, &a[p + p * a_dim1], lda, &u[p + p * u_dim1], &c__1);
+/* L1965: */
+ }
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ slaset_("Upper", &i__1, &i__2, &c_b34, &c_b34, &u[(u_dim1 << 1) + 1],
+ ldu);
+
+ i__1 = *lwork - (*n << 1);
+ sgeqrf_(n, &nr, &u[u_offset], ldu, &work[*n + 1], &work[(*n << 1) + 1]
+, &i__1, &ierr);
+
+ i__1 = nr - 1;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = nr - p;
+ scopy_(&i__2, &u[p + (p + 1) * u_dim1], ldu, &u[p + 1 + p *
+ u_dim1], &c__1);
+/* L1967: */
+ }
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ slaset_("Upper", &i__1, &i__2, &c_b34, &c_b34, &u[(u_dim1 << 1) + 1],
+ ldu);
+
+ i__1 = *lwork - *n;
+ sgesvj_("Lower", "U", "N", &nr, &nr, &u[u_offset], ldu, &sva[1], &nr,
+ &a[a_offset], lda, &work[*n + 1], &i__1, info);
+ scalem = work[*n + 1];
+ numrank = i_nint(&work[*n + 2]);
+
+ if (nr < *m) {
+ i__1 = *m - nr;
+ slaset_("A", &i__1, &nr, &c_b34, &c_b34, &u[nr + 1 + u_dim1], ldu);
+ if (nr < n1) {
+ i__1 = n1 - nr;
+ slaset_("A", &nr, &i__1, &c_b34, &c_b34, &u[(nr + 1) * u_dim1
+ + 1], ldu);
+ i__1 = *m - nr;
+ i__2 = n1 - nr;
+ slaset_("A", &i__1, &i__2, &c_b34, &c_b35, &u[nr + 1 + (nr +
+ 1) * u_dim1], ldu);
+ }
+ }
+
+ i__1 = *lwork - *n;
+ sormqr_("Left", "No Tr", m, &n1, n, &a[a_offset], lda, &work[1], &u[
+ u_offset], ldu, &work[*n + 1], &i__1, &ierr);
+
+ if (rowpiv) {
+ i__1 = *m - 1;
+ slaswp_(&n1, &u[u_offset], ldu, &c__1, &i__1, &iwork[(*n << 1) +
+ 1], &c_n1);
+ }
+
+ i__1 = n1;
+ for (p = 1; p <= i__1; ++p) {
+ xsc = 1.f / snrm2_(m, &u[p * u_dim1 + 1], &c__1);
+ sscal_(m, &xsc, &u[p * u_dim1 + 1], &c__1);
+/* L1974: */
+ }
+
+ if (transp) {
+ slacpy_("All", n, n, &u[u_offset], ldu, &v[v_offset], ldv);
+ }
+
+ } else {
+
+/* -#- Full SVD -#- */
+
+ if (! jracc) {
+
+ if (! almort) {
+
+/* Second Preconditioning Step (QRF [with pivoting]) */
+/* Note that the composition of TRANSPOSE, QRF and TRANSPOSE is */
+/* equivalent to an LQF CALL. Since in many libraries the QRF */
+/* seems to be better optimized than the LQF, we do explicit */
+/* transpose and use the QRF. This is subject to changes in an */
+/* optimized implementation of SGEJSV. */
+
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = *n - p + 1;
+ scopy_(&i__2, &a[p + p * a_dim1], lda, &v[p + p * v_dim1],
+ &c__1);
+/* L1968: */
+ }
+
+/* .. the following two loops perturb small entries to avoid */
+/* denormals in the second QR factorization, where they are */
+/* as good as zeros. This is done to avoid painfully slow */
+/* computation with denormals. The relative size of the perturbation */
+/* is a parameter that can be changed by the implementer. */
+/* This perturbation device will be obsolete on machines with */
+/* properly implemented arithmetic. */
+/* To switch it off, set L2PERT=.FALSE. To remove it from the */
+/* code, remove the action under L2PERT=.TRUE., leave the ELSE part. */
+/* The following two loops should be blocked and fused with the */
+/* transposed copy above. */
+
+ if (l2pert) {
+ xsc = sqrt(small);
+ i__1 = nr;
+ for (q = 1; q <= i__1; ++q) {
+ temp1 = xsc * (r__1 = v[q + q * v_dim1], dabs(r__1));
+ i__2 = *n;
+ for (p = 1; p <= i__2; ++p) {
+ if (p > q && (r__1 = v[p + q * v_dim1], dabs(r__1)
+ ) <= temp1 || p < q) {
+ v[p + q * v_dim1] = r_sign(&temp1, &v[p + q *
+ v_dim1]);
+ }
+ if (p < q) {
+ v[p + q * v_dim1] = -v[p + q * v_dim1];
+ }
+/* L2968: */
+ }
+/* L2969: */
+ }
+ } else {
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ slaset_("U", &i__1, &i__2, &c_b34, &c_b34, &v[(v_dim1 <<
+ 1) + 1], ldv);
+ }
+
+/* Estimate the row scaled condition number of R1 */
+/* (If R1 is rectangular, N > NR, then the condition number */
+/* of the leading NR x NR submatrix is estimated.) */
+
+ slacpy_("L", &nr, &nr, &v[v_offset], ldv, &work[(*n << 1) + 1]
+, &nr);
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = nr - p + 1;
+ temp1 = snrm2_(&i__2, &work[(*n << 1) + (p - 1) * nr + p],
+ &c__1);
+ i__2 = nr - p + 1;
+ r__1 = 1.f / temp1;
+ sscal_(&i__2, &r__1, &work[(*n << 1) + (p - 1) * nr + p],
+ &c__1);
+/* L3950: */
+ }
+ spocon_("Lower", &nr, &work[(*n << 1) + 1], &nr, &c_b35, &
+ temp1, &work[(*n << 1) + nr * nr + 1], &iwork[*m + (*
+ n << 1) + 1], &ierr);
+ condr1 = 1.f / sqrt(temp1);
+/* .. here need a second oppinion on the condition number */
+/* .. then assume worst case scenario */
+/* R1 is OK for inverse <=> CONDR1 .LT. FLOAT(N) */
+/* more conservative <=> CONDR1 .LT. SQRT(FLOAT(N)) */
+
+ cond_ok__ = sqrt((real) nr);
+/* [TP] COND_OK is a tuning parameter. */
+ if (condr1 < cond_ok__) {
+/* .. the second QRF without pivoting. Note: in an optimized */
+/* implementation, this QRF should be implemented as the QRF */
+/* of a lower triangular matrix. */
+/* R1^t = Q2 * R2 */
+ i__1 = *lwork - (*n << 1);
+ sgeqrf_(n, &nr, &v[v_offset], ldv, &work[*n + 1], &work[(*
+ n << 1) + 1], &i__1, &ierr);
+
+ if (l2pert) {
+ xsc = sqrt(small) / epsln;
+ i__1 = nr;
+ for (p = 2; p <= i__1; ++p) {
+ i__2 = p - 1;
+ for (q = 1; q <= i__2; ++q) {
+/* Computing MIN */
+ r__3 = (r__1 = v[p + p * v_dim1], dabs(r__1)),
+ r__4 = (r__2 = v[q + q * v_dim1],
+ dabs(r__2));
+ temp1 = xsc * dmin(r__3,r__4);
+ if ((r__1 = v[q + p * v_dim1], dabs(r__1)) <=
+ temp1) {
+ v[q + p * v_dim1] = r_sign(&temp1, &v[q +
+ p * v_dim1]);
+ }
+/* L3958: */
+ }
+/* L3959: */
+ }
+ }
+
+ if (nr != *n) {
+ slacpy_("A", n, &nr, &v[v_offset], ldv, &work[(*n <<
+ 1) + 1], n);
+ }
+/* .. save ... */
+
+/* .. this transposed copy should be better than naive */
+ i__1 = nr - 1;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = nr - p;
+ scopy_(&i__2, &v[p + (p + 1) * v_dim1], ldv, &v[p + 1
+ + p * v_dim1], &c__1);
+/* L1969: */
+ }
+
+ condr2 = condr1;
+
+ } else {
+
+/* .. ill-conditioned case: second QRF with pivoting */
+/* Note that windowed pivoting would be equaly good */
+/* numerically, and more run-time efficient. So, in */
+/* an optimal implementation, the next call to SGEQP3 */
+/* should be replaced with eg. CALL SGEQPX (ACM TOMS #782) */
+/* with properly (carefully) chosen parameters. */
+
+/* R1^t * P2 = Q2 * R2 */
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ iwork[*n + p] = 0;
+/* L3003: */
+ }
+ i__1 = *lwork - (*n << 1);
+ sgeqp3_(n, &nr, &v[v_offset], ldv, &iwork[*n + 1], &work[*
+ n + 1], &work[(*n << 1) + 1], &i__1, &ierr);
+/* * CALL SGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1), */
+/* * & LWORK-2*N, IERR ) */
+ if (l2pert) {
+ xsc = sqrt(small);
+ i__1 = nr;
+ for (p = 2; p <= i__1; ++p) {
+ i__2 = p - 1;
+ for (q = 1; q <= i__2; ++q) {
+/* Computing MIN */
+ r__3 = (r__1 = v[p + p * v_dim1], dabs(r__1)),
+ r__4 = (r__2 = v[q + q * v_dim1],
+ dabs(r__2));
+ temp1 = xsc * dmin(r__3,r__4);
+ if ((r__1 = v[q + p * v_dim1], dabs(r__1)) <=
+ temp1) {
+ v[q + p * v_dim1] = r_sign(&temp1, &v[q +
+ p * v_dim1]);
+ }
+/* L3968: */
+ }
+/* L3969: */
+ }
+ }
+
+ slacpy_("A", n, &nr, &v[v_offset], ldv, &work[(*n << 1) +
+ 1], n);
+
+ if (l2pert) {
+ xsc = sqrt(small);
+ i__1 = nr;
+ for (p = 2; p <= i__1; ++p) {
+ i__2 = p - 1;
+ for (q = 1; q <= i__2; ++q) {
+/* Computing MIN */
+ r__3 = (r__1 = v[p + p * v_dim1], dabs(r__1)),
+ r__4 = (r__2 = v[q + q * v_dim1],
+ dabs(r__2));
+ temp1 = xsc * dmin(r__3,r__4);
+ v[p + q * v_dim1] = -r_sign(&temp1, &v[q + p *
+ v_dim1]);
+/* L8971: */
+ }
+/* L8970: */
+ }
+ } else {
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ slaset_("L", &i__1, &i__2, &c_b34, &c_b34, &v[v_dim1
+ + 2], ldv);
+ }
+/* Now, compute R2 = L3 * Q3, the LQ factorization. */
+ i__1 = *lwork - (*n << 1) - *n * nr - nr;
+ sgelqf_(&nr, &nr, &v[v_offset], ldv, &work[(*n << 1) + *n
+ * nr + 1], &work[(*n << 1) + *n * nr + nr + 1], &
+ i__1, &ierr);
+/* .. and estimate the condition number */
+ slacpy_("L", &nr, &nr, &v[v_offset], ldv, &work[(*n << 1)
+ + *n * nr + nr + 1], &nr);
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ temp1 = snrm2_(&p, &work[(*n << 1) + *n * nr + nr + p]
+, &nr);
+ r__1 = 1.f / temp1;
+ sscal_(&p, &r__1, &work[(*n << 1) + *n * nr + nr + p],
+ &nr);
+/* L4950: */
+ }
+ spocon_("L", &nr, &work[(*n << 1) + *n * nr + nr + 1], &
+ nr, &c_b35, &temp1, &work[(*n << 1) + *n * nr +
+ nr + nr * nr + 1], &iwork[*m + (*n << 1) + 1], &
+ ierr);
+ condr2 = 1.f / sqrt(temp1);
+
+ if (condr2 >= cond_ok__) {
+/* .. save the Householder vectors used for Q3 */
+/* (this overwrittes the copy of R2, as it will not be */
+/* needed in this branch, but it does not overwritte the */
+/* Huseholder vectors of Q2.). */
+ slacpy_("U", &nr, &nr, &v[v_offset], ldv, &work[(*n <<
+ 1) + 1], n);
+/* .. and the rest of the information on Q3 is in */
+/* WORK(2*N+N*NR+1:2*N+N*NR+N) */
+ }
+
+ }
+
+ if (l2pert) {
+ xsc = sqrt(small);
+ i__1 = nr;
+ for (q = 2; q <= i__1; ++q) {
+ temp1 = xsc * v[q + q * v_dim1];
+ i__2 = q - 1;
+ for (p = 1; p <= i__2; ++p) {
+/* V(p,q) = - SIGN( TEMP1, V(q,p) ) */
+ v[p + q * v_dim1] = -r_sign(&temp1, &v[p + q *
+ v_dim1]);
+/* L4969: */
+ }
+/* L4968: */
+ }
+ } else {
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ slaset_("U", &i__1, &i__2, &c_b34, &c_b34, &v[(v_dim1 <<
+ 1) + 1], ldv);
+ }
+
+/* Second preconditioning finished; continue with Jacobi SVD */
+/* The input matrix is lower trinagular. */
+
+/* Recover the right singular vectors as solution of a well */
+/* conditioned triangular matrix equation. */
+
+ if (condr1 < cond_ok__) {
+
+ i__1 = *lwork - (*n << 1) - *n * nr - nr;
+ sgesvj_("L", "U", "N", &nr, &nr, &v[v_offset], ldv, &sva[
+ 1], &nr, &u[u_offset], ldu, &work[(*n << 1) + *n *
+ nr + nr + 1], &i__1, info);
+ scalem = work[(*n << 1) + *n * nr + nr + 1];
+ numrank = i_nint(&work[(*n << 1) + *n * nr + nr + 2]);
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ scopy_(&nr, &v[p * v_dim1 + 1], &c__1, &u[p * u_dim1
+ + 1], &c__1);
+ sscal_(&nr, &sva[p], &v[p * v_dim1 + 1], &c__1);
+/* L3970: */
+ }
+/* .. pick the right matrix equation and solve it */
+
+ if (nr == *n) {
+/* :)) .. best case, R1 is inverted. The solution of this matrix */
+/* equation is Q2*V2 = the product of the Jacobi rotations */
+/* used in SGESVJ, premultiplied with the orthogonal matrix */
+/* from the second QR factorization. */
+ strsm_("L", "U", "N", "N", &nr, &nr, &c_b35, &a[
+ a_offset], lda, &v[v_offset], ldv);
+ } else {
+/* .. R1 is well conditioned, but non-square. Transpose(R2) */
+/* is inverted to get the product of the Jacobi rotations */
+/* used in SGESVJ. The Q-factor from the second QR */
+/* factorization is then built in explicitly. */
+ strsm_("L", "U", "T", "N", &nr, &nr, &c_b35, &work[(*
+ n << 1) + 1], n, &v[v_offset], ldv);
+ if (nr < *n) {
+ i__1 = *n - nr;
+ slaset_("A", &i__1, &nr, &c_b34, &c_b34, &v[nr +
+ 1 + v_dim1], ldv);
+ i__1 = *n - nr;
+ slaset_("A", &nr, &i__1, &c_b34, &c_b34, &v[(nr +
+ 1) * v_dim1 + 1], ldv);
+ i__1 = *n - nr;
+ i__2 = *n - nr;
+ slaset_("A", &i__1, &i__2, &c_b34, &c_b35, &v[nr
+ + 1 + (nr + 1) * v_dim1], ldv);
+ }
+ i__1 = *lwork - (*n << 1) - *n * nr - nr;
+ sormqr_("L", "N", n, n, &nr, &work[(*n << 1) + 1], n,
+ &work[*n + 1], &v[v_offset], ldv, &work[(*n <<
+ 1) + *n * nr + nr + 1], &i__1, &ierr);
+ }
+
+ } else if (condr2 < cond_ok__) {
+
+/* :) .. the input matrix A is very likely a relative of */
+/* the Kahan matrix :) */
+/* The matrix R2 is inverted. The solution of the matrix equation */
+/* is Q3^T*V3 = the product of the Jacobi rotations (appplied to */
+/* the lower triangular L3 from the LQ factorization of */
+/* R2=L3*Q3), pre-multiplied with the transposed Q3. */
+ i__1 = *lwork - (*n << 1) - *n * nr - nr;
+ sgesvj_("L", "U", "N", &nr, &nr, &v[v_offset], ldv, &sva[
+ 1], &nr, &u[u_offset], ldu, &work[(*n << 1) + *n *
+ nr + nr + 1], &i__1, info);
+ scalem = work[(*n << 1) + *n * nr + nr + 1];
+ numrank = i_nint(&work[(*n << 1) + *n * nr + nr + 2]);
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ scopy_(&nr, &v[p * v_dim1 + 1], &c__1, &u[p * u_dim1
+ + 1], &c__1);
+ sscal_(&nr, &sva[p], &u[p * u_dim1 + 1], &c__1);
+/* L3870: */
+ }
+ strsm_("L", "U", "N", "N", &nr, &nr, &c_b35, &work[(*n <<
+ 1) + 1], n, &u[u_offset], ldu);
+/* .. apply the permutation from the second QR factorization */
+ i__1 = nr;
+ for (q = 1; q <= i__1; ++q) {
+ i__2 = nr;
+ for (p = 1; p <= i__2; ++p) {
+ work[(*n << 1) + *n * nr + nr + iwork[*n + p]] =
+ u[p + q * u_dim1];
+/* L872: */
+ }
+ i__2 = nr;
+ for (p = 1; p <= i__2; ++p) {
+ u[p + q * u_dim1] = work[(*n << 1) + *n * nr + nr
+ + p];
+/* L874: */
+ }
+/* L873: */
+ }
+ if (nr < *n) {
+ i__1 = *n - nr;
+ slaset_("A", &i__1, &nr, &c_b34, &c_b34, &v[nr + 1 +
+ v_dim1], ldv);
+ i__1 = *n - nr;
+ slaset_("A", &nr, &i__1, &c_b34, &c_b34, &v[(nr + 1) *
+ v_dim1 + 1], ldv);
+ i__1 = *n - nr;
+ i__2 = *n - nr;
+ slaset_("A", &i__1, &i__2, &c_b34, &c_b35, &v[nr + 1
+ + (nr + 1) * v_dim1], ldv);
+ }
+ i__1 = *lwork - (*n << 1) - *n * nr - nr;
+ sormqr_("L", "N", n, n, &nr, &work[(*n << 1) + 1], n, &
+ work[*n + 1], &v[v_offset], ldv, &work[(*n << 1)
+ + *n * nr + nr + 1], &i__1, &ierr);
+ } else {
+/* Last line of defense. */
+/* #:( This is a rather pathological case: no scaled condition */
+/* improvement after two pivoted QR factorizations. Other */
+/* possibility is that the rank revealing QR factorization */
+/* or the condition estimator has failed, or the COND_OK */
+/* is set very close to ONE (which is unnecessary). Normally, */
+/* this branch should never be executed, but in rare cases of */
+/* failure of the RRQR or condition estimator, the last line of */
+/* defense ensures that SGEJSV completes the task. */
+/* Compute the full SVD of L3 using SGESVJ with explicit */
+/* accumulation of Jacobi rotations. */
+ i__1 = *lwork - (*n << 1) - *n * nr - nr;
+ sgesvj_("L", "U", "V", &nr, &nr, &v[v_offset], ldv, &sva[
+ 1], &nr, &u[u_offset], ldu, &work[(*n << 1) + *n *
+ nr + nr + 1], &i__1, info);
+ scalem = work[(*n << 1) + *n * nr + nr + 1];
+ numrank = i_nint(&work[(*n << 1) + *n * nr + nr + 2]);
+ if (nr < *n) {
+ i__1 = *n - nr;
+ slaset_("A", &i__1, &nr, &c_b34, &c_b34, &v[nr + 1 +
+ v_dim1], ldv);
+ i__1 = *n - nr;
+ slaset_("A", &nr, &i__1, &c_b34, &c_b34, &v[(nr + 1) *
+ v_dim1 + 1], ldv);
+ i__1 = *n - nr;
+ i__2 = *n - nr;
+ slaset_("A", &i__1, &i__2, &c_b34, &c_b35, &v[nr + 1
+ + (nr + 1) * v_dim1], ldv);
+ }
+ i__1 = *lwork - (*n << 1) - *n * nr - nr;
+ sormqr_("L", "N", n, n, &nr, &work[(*n << 1) + 1], n, &
+ work[*n + 1], &v[v_offset], ldv, &work[(*n << 1)
+ + *n * nr + nr + 1], &i__1, &ierr);
+
+ i__1 = *lwork - (*n << 1) - *n * nr - nr;
+ sormlq_("L", "T", &nr, &nr, &nr, &work[(*n << 1) + 1], n,
+ &work[(*n << 1) + *n * nr + 1], &u[u_offset], ldu,
+ &work[(*n << 1) + *n * nr + nr + 1], &i__1, &
+ ierr);
+ i__1 = nr;
+ for (q = 1; q <= i__1; ++q) {
+ i__2 = nr;
+ for (p = 1; p <= i__2; ++p) {
+ work[(*n << 1) + *n * nr + nr + iwork[*n + p]] =
+ u[p + q * u_dim1];
+/* L772: */
+ }
+ i__2 = nr;
+ for (p = 1; p <= i__2; ++p) {
+ u[p + q * u_dim1] = work[(*n << 1) + *n * nr + nr
+ + p];
+/* L774: */
+ }
+/* L773: */
+ }
+
+ }
+
+/* Permute the rows of V using the (column) permutation from the */
+/* first QRF. Also, scale the columns to make them unit in */
+/* Euclidean norm. This applies to all cases. */
+
+ temp1 = sqrt((real) (*n)) * epsln;
+ i__1 = *n;
+ for (q = 1; q <= i__1; ++q) {
+ i__2 = *n;
+ for (p = 1; p <= i__2; ++p) {
+ work[(*n << 1) + *n * nr + nr + iwork[p]] = v[p + q *
+ v_dim1];
+/* L972: */
+ }
+ i__2 = *n;
+ for (p = 1; p <= i__2; ++p) {
+ v[p + q * v_dim1] = work[(*n << 1) + *n * nr + nr + p]
+ ;
+/* L973: */
+ }
+ xsc = 1.f / snrm2_(n, &v[q * v_dim1 + 1], &c__1);
+ if (xsc < 1.f - temp1 || xsc > temp1 + 1.f) {
+ sscal_(n, &xsc, &v[q * v_dim1 + 1], &c__1);
+ }
+/* L1972: */
+ }
+/* At this moment, V contains the right singular vectors of A. */
+/* Next, assemble the left singular vector matrix U (M x N). */
+ if (nr < *m) {
+ i__1 = *m - nr;
+ slaset_("A", &i__1, &nr, &c_b34, &c_b34, &u[nr + 1 +
+ u_dim1], ldu);
+ if (nr < n1) {
+ i__1 = n1 - nr;
+ slaset_("A", &nr, &i__1, &c_b34, &c_b34, &u[(nr + 1) *
+ u_dim1 + 1], ldu);
+ i__1 = *m - nr;
+ i__2 = n1 - nr;
+ slaset_("A", &i__1, &i__2, &c_b34, &c_b35, &u[nr + 1
+ + (nr + 1) * u_dim1], ldu);
+ }
+ }
+
+/* The Q matrix from the first QRF is built into the left singular */
+/* matrix U. This applies to all cases. */
+
+ i__1 = *lwork - *n;
+ sormqr_("Left", "No_Tr", m, &n1, n, &a[a_offset], lda, &work[
+ 1], &u[u_offset], ldu, &work[*n + 1], &i__1, &ierr);
+/* The columns of U are normalized. The cost is O(M*N) flops. */
+ temp1 = sqrt((real) (*m)) * epsln;
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ xsc = 1.f / snrm2_(m, &u[p * u_dim1 + 1], &c__1);
+ if (xsc < 1.f - temp1 || xsc > temp1 + 1.f) {
+ sscal_(m, &xsc, &u[p * u_dim1 + 1], &c__1);
+ }
+/* L1973: */
+ }
+
+/* If the initial QRF is computed with row pivoting, the left */
+/* singular vectors must be adjusted. */
+
+ if (rowpiv) {
+ i__1 = *m - 1;
+ slaswp_(&n1, &u[u_offset], ldu, &c__1, &i__1, &iwork[(*n
+ << 1) + 1], &c_n1);
+ }
+
+ } else {
+
+/* .. the initial matrix A has almost orthogonal columns and */
+/* the second QRF is not needed */
+
+ slacpy_("Upper", n, n, &a[a_offset], lda, &work[*n + 1], n);
+ if (l2pert) {
+ xsc = sqrt(small);
+ i__1 = *n;
+ for (p = 2; p <= i__1; ++p) {
+ temp1 = xsc * work[*n + (p - 1) * *n + p];
+ i__2 = p - 1;
+ for (q = 1; q <= i__2; ++q) {
+ work[*n + (q - 1) * *n + p] = -r_sign(&temp1, &
+ work[*n + (p - 1) * *n + q]);
+/* L5971: */
+ }
+/* L5970: */
+ }
+ } else {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ slaset_("Lower", &i__1, &i__2, &c_b34, &c_b34, &work[*n +
+ 2], n);
+ }
+
+ i__1 = *lwork - *n - *n * *n;
+ sgesvj_("Upper", "U", "N", n, n, &work[*n + 1], n, &sva[1], n,
+ &u[u_offset], ldu, &work[*n + *n * *n + 1], &i__1,
+ info);
+
+ scalem = work[*n + *n * *n + 1];
+ numrank = i_nint(&work[*n + *n * *n + 2]);
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ scopy_(n, &work[*n + (p - 1) * *n + 1], &c__1, &u[p *
+ u_dim1 + 1], &c__1);
+ sscal_(n, &sva[p], &work[*n + (p - 1) * *n + 1], &c__1);
+/* L6970: */
+ }
+
+ strsm_("Left", "Upper", "NoTrans", "No UD", n, n, &c_b35, &a[
+ a_offset], lda, &work[*n + 1], n);
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ scopy_(n, &work[*n + p], n, &v[iwork[p] + v_dim1], ldv);
+/* L6972: */
+ }
+ temp1 = sqrt((real) (*n)) * epsln;
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ xsc = 1.f / snrm2_(n, &v[p * v_dim1 + 1], &c__1);
+ if (xsc < 1.f - temp1 || xsc > temp1 + 1.f) {
+ sscal_(n, &xsc, &v[p * v_dim1 + 1], &c__1);
+ }
+/* L6971: */
+ }
+
+/* Assemble the left singular vector matrix U (M x N). */
+
+ if (*n < *m) {
+ i__1 = *m - *n;
+ slaset_("A", &i__1, n, &c_b34, &c_b34, &u[nr + 1 + u_dim1]
+, ldu);
+ if (*n < n1) {
+ i__1 = n1 - *n;
+ slaset_("A", n, &i__1, &c_b34, &c_b34, &u[(*n + 1) *
+ u_dim1 + 1], ldu);
+ i__1 = *m - *n;
+ i__2 = n1 - *n;
+ slaset_("A", &i__1, &i__2, &c_b34, &c_b35, &u[nr + 1
+ + (*n + 1) * u_dim1], ldu);
+ }
+ }
+ i__1 = *lwork - *n;
+ sormqr_("Left", "No Tr", m, &n1, n, &a[a_offset], lda, &work[
+ 1], &u[u_offset], ldu, &work[*n + 1], &i__1, &ierr);
+ temp1 = sqrt((real) (*m)) * epsln;
+ i__1 = n1;
+ for (p = 1; p <= i__1; ++p) {
+ xsc = 1.f / snrm2_(m, &u[p * u_dim1 + 1], &c__1);
+ if (xsc < 1.f - temp1 || xsc > temp1 + 1.f) {
+ sscal_(m, &xsc, &u[p * u_dim1 + 1], &c__1);
+ }
+/* L6973: */
+ }
+
+ if (rowpiv) {
+ i__1 = *m - 1;
+ slaswp_(&n1, &u[u_offset], ldu, &c__1, &i__1, &iwork[(*n
+ << 1) + 1], &c_n1);
+ }
+
+ }
+
+/* end of the >> almost orthogonal case << in the full SVD */
+
+ } else {
+
+/* This branch deploys a preconditioned Jacobi SVD with explicitly */
+/* accumulated rotations. It is included as optional, mainly for */
+/* experimental purposes. It does perfom well, and can also be used. */
+/* In this implementation, this branch will be automatically activated */
+/* if the condition number sigma_max(A) / sigma_min(A) is predicted */
+/* to be greater than the overflow threshold. This is because the */
+/* a posteriori computation of the singular vectors assumes robust */
+/* implementation of BLAS and some LAPACK procedures, capable of working */
+/* in presence of extreme values. Since that is not always the case, ... */
+
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = *n - p + 1;
+ scopy_(&i__2, &a[p + p * a_dim1], lda, &v[p + p * v_dim1], &
+ c__1);
+/* L7968: */
+ }
+
+ if (l2pert) {
+ xsc = sqrt(small / epsln);
+ i__1 = nr;
+ for (q = 1; q <= i__1; ++q) {
+ temp1 = xsc * (r__1 = v[q + q * v_dim1], dabs(r__1));
+ i__2 = *n;
+ for (p = 1; p <= i__2; ++p) {
+ if (p > q && (r__1 = v[p + q * v_dim1], dabs(r__1)) <=
+ temp1 || p < q) {
+ v[p + q * v_dim1] = r_sign(&temp1, &v[p + q *
+ v_dim1]);
+ }
+ if (p < q) {
+ v[p + q * v_dim1] = -v[p + q * v_dim1];
+ }
+/* L5968: */
+ }
+/* L5969: */
+ }
+ } else {
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ slaset_("U", &i__1, &i__2, &c_b34, &c_b34, &v[(v_dim1 << 1) +
+ 1], ldv);
+ }
+ i__1 = *lwork - (*n << 1);
+ sgeqrf_(n, &nr, &v[v_offset], ldv, &work[*n + 1], &work[(*n << 1)
+ + 1], &i__1, &ierr);
+ slacpy_("L", n, &nr, &v[v_offset], ldv, &work[(*n << 1) + 1], n);
+
+ i__1 = nr;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = nr - p + 1;
+ scopy_(&i__2, &v[p + p * v_dim1], ldv, &u[p + p * u_dim1], &
+ c__1);
+/* L7969: */
+ }
+ if (l2pert) {
+ xsc = sqrt(small / epsln);
+ i__1 = nr;
+ for (q = 2; q <= i__1; ++q) {
+ i__2 = q - 1;
+ for (p = 1; p <= i__2; ++p) {
+/* Computing MIN */
+ r__3 = (r__1 = u[p + p * u_dim1], dabs(r__1)), r__4 =
+ (r__2 = u[q + q * u_dim1], dabs(r__2));
+ temp1 = xsc * dmin(r__3,r__4);
+ u[p + q * u_dim1] = -r_sign(&temp1, &u[q + p * u_dim1]
+ );
+/* L9971: */
+ }
+/* L9970: */
+ }
+ } else {
+ i__1 = nr - 1;
+ i__2 = nr - 1;
+ slaset_("U", &i__1, &i__2, &c_b34, &c_b34, &u[(u_dim1 << 1) +
+ 1], ldu);
+ }
+ i__1 = *lwork - (*n << 1) - *n * nr;
+ sgesvj_("L", "U", "V", &nr, &nr, &u[u_offset], ldu, &sva[1], n, &
+ v[v_offset], ldv, &work[(*n << 1) + *n * nr + 1], &i__1,
+ info);
+ scalem = work[(*n << 1) + *n * nr + 1];
+ numrank = i_nint(&work[(*n << 1) + *n * nr + 2]);
+ if (nr < *n) {
+ i__1 = *n - nr;
+ slaset_("A", &i__1, &nr, &c_b34, &c_b34, &v[nr + 1 + v_dim1],
+ ldv);
+ i__1 = *n - nr;
+ slaset_("A", &nr, &i__1, &c_b34, &c_b34, &v[(nr + 1) * v_dim1
+ + 1], ldv);
+ i__1 = *n - nr;
+ i__2 = *n - nr;
+ slaset_("A", &i__1, &i__2, &c_b34, &c_b35, &v[nr + 1 + (nr +
+ 1) * v_dim1], ldv);
+ }
+ i__1 = *lwork - (*n << 1) - *n * nr - nr;
+ sormqr_("L", "N", n, n, &nr, &work[(*n << 1) + 1], n, &work[*n +
+ 1], &v[v_offset], ldv, &work[(*n << 1) + *n * nr + nr + 1]
+, &i__1, &ierr);
+
+/* Permute the rows of V using the (column) permutation from the */
+/* first QRF. Also, scale the columns to make them unit in */
+/* Euclidean norm. This applies to all cases. */
+
+ temp1 = sqrt((real) (*n)) * epsln;
+ i__1 = *n;
+ for (q = 1; q <= i__1; ++q) {
+ i__2 = *n;
+ for (p = 1; p <= i__2; ++p) {
+ work[(*n << 1) + *n * nr + nr + iwork[p]] = v[p + q *
+ v_dim1];
+/* L8972: */
+ }
+ i__2 = *n;
+ for (p = 1; p <= i__2; ++p) {
+ v[p + q * v_dim1] = work[(*n << 1) + *n * nr + nr + p];
+/* L8973: */
+ }
+ xsc = 1.f / snrm2_(n, &v[q * v_dim1 + 1], &c__1);
+ if (xsc < 1.f - temp1 || xsc > temp1 + 1.f) {
+ sscal_(n, &xsc, &v[q * v_dim1 + 1], &c__1);
+ }
+/* L7972: */
+ }
+
+/* At this moment, V contains the right singular vectors of A. */
+/* Next, assemble the left singular vector matrix U (M x N). */
+
+ if (*n < *m) {
+ i__1 = *m - *n;
+ slaset_("A", &i__1, n, &c_b34, &c_b34, &u[nr + 1 + u_dim1],
+ ldu);
+ if (*n < n1) {
+ i__1 = n1 - *n;
+ slaset_("A", n, &i__1, &c_b34, &c_b34, &u[(*n + 1) *
+ u_dim1 + 1], ldu);
+ i__1 = *m - *n;
+ i__2 = n1 - *n;
+ slaset_("A", &i__1, &i__2, &c_b34, &c_b35, &u[nr + 1 + (*
+ n + 1) * u_dim1], ldu);
+ }
+ }
+
+ i__1 = *lwork - *n;
+ sormqr_("Left", "No Tr", m, &n1, n, &a[a_offset], lda, &work[1], &
+ u[u_offset], ldu, &work[*n + 1], &i__1, &ierr);
+
+ if (rowpiv) {
+ i__1 = *m - 1;
+ slaswp_(&n1, &u[u_offset], ldu, &c__1, &i__1, &iwork[(*n << 1)
+ + 1], &c_n1);
+ }
+
+
+ }
+ if (transp) {
+/* .. swap U and V because the procedure worked on A^t */
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ sswap_(n, &u[p * u_dim1 + 1], &c__1, &v[p * v_dim1 + 1], &
+ c__1);
+/* L6974: */
+ }
+ }
+
+ }
+/* end of the full SVD */
+
+/* Undo scaling, if necessary (and possible) */
+
+ if (uscal2 <= big / sva[1] * uscal1) {
+ slascl_("G", &c__0, &c__0, &uscal1, &uscal2, &nr, &c__1, &sva[1], n, &
+ ierr);
+ uscal1 = 1.f;
+ uscal2 = 1.f;
+ }
+
+ if (nr < *n) {
+ i__1 = *n;
+ for (p = nr + 1; p <= i__1; ++p) {
+ sva[p] = 0.f;
+/* L3004: */
+ }
+ }
+
+ work[1] = uscal2 * scalem;
+ work[2] = uscal1;
+ if (errest) {
+ work[3] = sconda;
+ }
+ if (lsvec && rsvec) {
+ work[4] = condr1;
+ work[5] = condr2;
+ }
+ if (l2tran) {
+ work[6] = entra;
+ work[7] = entrat;
+ }
+
+ iwork[1] = nr;
+ iwork[2] = numrank;
+ iwork[3] = warning;
+
+ return 0;
+/* .. */
+/* .. END OF SGEJSV */
+/* .. */
+} /* sgejsv_ */
diff --git a/SRC/sgelq2.c b/SRC/sgelq2.c
new file mode 100644
index 0000000..a4082b4
--- /dev/null
+++ b/SRC/sgelq2.c
@@ -0,0 +1,157 @@
+/* sgelq2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sgelq2_(integer *m, integer *n, real *a, integer *lda,
+ real *tau, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, k;
+ real aii;
+ extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *), xerbla_(
+ char *, integer *), slarfp_(integer *, real *, real *,
+ integer *, real *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGELQ2 computes an LQ factorization of a real m by n matrix A: */
+/* A = L * Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the m by n matrix A. */
+/* On exit, the elements on and below the diagonal of the array */
+/* contain the m by min(m,n) lower trapezoidal matrix L (L is */
+/* lower triangular if m <= n); the elements above the diagonal, */
+/* with the array TAU, represent the orthogonal matrix Q as a */
+/* product of elementary reflectors (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace) REAL array, dimension (M) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), */
+/* and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGELQ2", &i__1);
+ return 0;
+ }
+
+ k = min(*m,*n);
+
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Generate elementary reflector H(i) to annihilate A(i,i+1:n) */
+
+ i__2 = *n - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ slarfp_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3, *n)* a_dim1]
+, lda, &tau[i__]);
+ if (i__ < *m) {
+
+/* Apply H(i) to A(i+1:m,i:n) from the right */
+
+ aii = a[i__ + i__ * a_dim1];
+ a[i__ + i__ * a_dim1] = 1.f;
+ i__2 = *m - i__;
+ i__3 = *n - i__ + 1;
+ slarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[
+ i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]);
+ a[i__ + i__ * a_dim1] = aii;
+ }
+/* L10: */
+ }
+ return 0;
+
+/* End of SGELQ2 */
+
+} /* sgelq2_ */
diff --git a/SRC/sgelqf.c b/SRC/sgelqf.c
new file mode 100644
index 0000000..a3eb98f
--- /dev/null
+++ b/SRC/sgelqf.c
@@ -0,0 +1,251 @@
+/* sgelqf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int sgelqf_(integer *m, integer *n, real *a, integer *lda,
+ real *tau, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, k, ib, nb, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int sgelq2_(integer *, integer *, real *, integer
+ *, real *, real *, integer *), slarfb_(char *, char *, char *,
+ char *, integer *, integer *, integer *, real *, integer *, real *
+, integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slarft_(char *, char *, integer *, integer *,
+ real *, integer *, real *, real *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGELQF computes an LQ factorization of a real M-by-N matrix A: */
+/* A = L * Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the elements on and below the diagonal of the array */
+/* contain the m-by-min(m,n) lower trapezoidal matrix L (L is */
+/* lower triangular if m <= n); the elements above the diagonal, */
+/* with the array TAU, represent the orthogonal matrix Q as a */
+/* product of elementary reflectors (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M). */
+/* For optimum performance LWORK >= M*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), */
+/* and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb = ilaenv_(&c__1, "SGELQF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = *m * nb;
+ work[1] = (real) lwkopt;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ } else if (*lwork < max(1,*m) && ! lquery) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGELQF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ k = min(*m,*n);
+ if (k == 0) {
+ work[1] = 1.f;
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *m;
+ if (nb > 1 && nb < k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "SGELQF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *m;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "SGELQF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < k && nx < k) {
+
+/* Use blocked code initially */
+
+ i__1 = k - nx;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = k - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Compute the LQ factorization of the current block */
+/* A(i:i+ib-1,i:n) */
+
+ i__3 = *n - i__ + 1;
+ sgelq2_(&ib, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
+ 1], &iinfo);
+ if (i__ + ib <= *m) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__3 = *n - i__ + 1;
+ slarft_("Forward", "Rowwise", &i__3, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H to A(i+ib:m,i:n) from the right */
+
+ i__3 = *m - i__ - ib + 1;
+ i__4 = *n - i__ + 1;
+ slarfb_("Right", "No transpose", "Forward", "Rowwise", &i__3,
+ &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
+ ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib +
+ 1], &ldwork);
+ }
+/* L10: */
+ }
+ } else {
+ i__ = 1;
+ }
+
+/* Use unblocked code to factor the last or only block. */
+
+ if (i__ <= k) {
+ i__2 = *m - i__ + 1;
+ i__1 = *n - i__ + 1;
+ sgelq2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
+, &iinfo);
+ }
+
+ work[1] = (real) iws;
+ return 0;
+
+/* End of SGELQF */
+
+} /* sgelqf_ */
diff --git a/SRC/sgels.c b/SRC/sgels.c
new file mode 100644
index 0000000..2cb9e73
--- /dev/null
+++ b/SRC/sgels.c
@@ -0,0 +1,513 @@
+/* sgels.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b33 = 0.f;
+static integer c__0 = 0;
+
+/* Subroutine */ int sgels_(char *trans, integer *m, integer *n, integer *
+ nrhs, real *a, integer *lda, real *b, integer *ldb, real *work,
+ integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, nb, mn;
+ real anrm, bnrm;
+ integer brow;
+ logical tpsd;
+ integer iascl, ibscl;
+ extern logical lsame_(char *, char *);
+ integer wsize;
+ real rwork[1];
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer scllen;
+ real bignum;
+ extern /* Subroutine */ int sgelqf_(integer *, integer *, real *, integer
+ *, real *, real *, integer *, integer *), slascl_(char *, integer
+ *, integer *, real *, real *, integer *, integer *, real *,
+ integer *, integer *), sgeqrf_(integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *), slaset_(char
+ *, integer *, integer *, real *, real *, real *, integer *);
+ real smlnum;
+ extern /* Subroutine */ int sormlq_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+ logical lquery;
+ extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *), strtrs_(char *, char *,
+ char *, integer *, integer *, real *, integer *, real *, integer *
+, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGELS solves overdetermined or underdetermined real linear systems */
+/* involving an M-by-N matrix A, or its transpose, using a QR or LQ */
+/* factorization of A. It is assumed that A has full rank. */
+
+/* The following options are provided: */
+
+/* 1. If TRANS = 'N' and m >= n: find the least squares solution of */
+/* an overdetermined system, i.e., solve the least squares problem */
+/* minimize || B - A*X ||. */
+
+/* 2. If TRANS = 'N' and m < n: find the minimum norm solution of */
+/* an underdetermined system A * X = B. */
+
+/* 3. If TRANS = 'T' and m >= n: find the minimum norm solution of */
+/* an undetermined system A**T * X = B. */
+
+/* 4. If TRANS = 'T' and m < n: find the least squares solution of */
+/* an overdetermined system, i.e., solve the least squares problem */
+/* minimize || B - A**T * X ||. */
+
+/* Several right hand side vectors b and solution vectors x can be */
+/* handled in a single call; they are stored as the columns of the */
+/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
+/* matrix X. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': the linear system involves A; */
+/* = 'T': the linear system involves A**T. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of */
+/* columns of the matrices B and X. NRHS >=0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, */
+/* if M >= N, A is overwritten by details of its QR */
+/* factorization as returned by SGEQRF; */
+/* if M < N, A is overwritten by details of its LQ */
+/* factorization as returned by SGELQF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the matrix B of right hand side vectors, stored */
+/* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS */
+/* if TRANS = 'T'. */
+/* On exit, if INFO = 0, B is overwritten by the solution */
+/* vectors, stored columnwise: */
+/* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least */
+/* squares solution vectors; the residual sum of squares for the */
+/* solution in each column is given by the sum of squares of */
+/* elements N+1 to M in that column; */
+/* if TRANS = 'N' and m < n, rows 1 to N of B contain the */
+/* minimum norm solution vectors; */
+/* if TRANS = 'T' and m >= n, rows 1 to M of B contain the */
+/* minimum norm solution vectors; */
+/* if TRANS = 'T' and m < n, rows 1 to M of B contain the */
+/* least squares solution vectors; the residual sum of squares */
+/* for the solution in each column is given by the sum of */
+/* squares of elements M+1 to N in that column. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= MAX(1,M,N). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* LWORK >= max( 1, MN + max( MN, NRHS ) ). */
+/* For optimal performance, */
+/* LWORK >= max( 1, MN + max( MN, NRHS )*NB ). */
+/* where MN = min(M,N) and NB is the optimum block size. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element of the */
+/* triangular factor of A is zero, so that A does not have */
+/* full rank; the least squares solution could not be */
+/* computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ mn = min(*m,*n);
+ lquery = *lwork == -1;
+ if (! (lsame_(trans, "N") || lsame_(trans, "T"))) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -6;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ if (*ldb < max(i__1,*n)) {
+ *info = -8;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = 1, i__2 = mn + max(mn,*nrhs);
+ if (*lwork < max(i__1,i__2) && ! lquery) {
+ *info = -10;
+ }
+ }
+ }
+
+/* Figure out optimal block size */
+
+ if (*info == 0 || *info == -10) {
+
+ tpsd = TRUE_;
+ if (lsame_(trans, "N")) {
+ tpsd = FALSE_;
+ }
+
+ if (*m >= *n) {
+ nb = ilaenv_(&c__1, "SGEQRF", " ", m, n, &c_n1, &c_n1);
+ if (tpsd) {
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "SORMQR", "LN", m, nrhs, n, &
+ c_n1);
+ nb = max(i__1,i__2);
+ } else {
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "SORMQR", "LT", m, nrhs, n, &
+ c_n1);
+ nb = max(i__1,i__2);
+ }
+ } else {
+ nb = ilaenv_(&c__1, "SGELQF", " ", m, n, &c_n1, &c_n1);
+ if (tpsd) {
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "SORMLQ", "LT", n, nrhs, m, &
+ c_n1);
+ nb = max(i__1,i__2);
+ } else {
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "SORMLQ", "LN", n, nrhs, m, &
+ c_n1);
+ nb = max(i__1,i__2);
+ }
+ }
+
+/* Computing MAX */
+ i__1 = 1, i__2 = mn + max(mn,*nrhs) * nb;
+ wsize = max(i__1,i__2);
+ work[1] = (real) wsize;
+
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGELS ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+/* Computing MIN */
+ i__1 = min(*m,*n);
+ if (min(i__1,*nrhs) == 0) {
+ i__1 = max(*m,*n);
+ slaset_("Full", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb);
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ smlnum = slamch_("S") / slamch_("P");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Scale A, B if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = slange_("M", m, n, &a[a_offset], lda, rwork);
+ iascl = 0;
+ if (anrm > 0.f && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ slascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ slascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 2;
+ } else if (anrm == 0.f) {
+
+/* Matrix all zero. Return zero solution. */
+
+ i__1 = max(*m,*n);
+ slaset_("F", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb);
+ goto L50;
+ }
+
+ brow = *m;
+ if (tpsd) {
+ brow = *n;
+ }
+ bnrm = slange_("M", &brow, nrhs, &b[b_offset], ldb, rwork);
+ ibscl = 0;
+ if (bnrm > 0.f && bnrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ slascl_("G", &c__0, &c__0, &bnrm, &smlnum, &brow, nrhs, &b[b_offset],
+ ldb, info);
+ ibscl = 1;
+ } else if (bnrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ slascl_("G", &c__0, &c__0, &bnrm, &bignum, &brow, nrhs, &b[b_offset],
+ ldb, info);
+ ibscl = 2;
+ }
+
+ if (*m >= *n) {
+
+/* compute QR factorization of A */
+
+ i__1 = *lwork - mn;
+ sgeqrf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
+ ;
+
+/* workspace at least N, optimally N*NB */
+
+ if (! tpsd) {
+
+/* Least-Squares Problem min || A * X - B || */
+
+/* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */
+
+ i__1 = *lwork - mn;
+ sormqr_("Left", "Transpose", m, nrhs, n, &a[a_offset], lda, &work[
+ 1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
+
+/* workspace at least NRHS, optimally NRHS*NB */
+
+/* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) */
+
+ strtrs_("Upper", "No transpose", "Non-unit", n, nrhs, &a[a_offset]
+, lda, &b[b_offset], ldb, info);
+
+ if (*info > 0) {
+ return 0;
+ }
+
+ scllen = *n;
+
+ } else {
+
+/* Overdetermined system of equations A' * X = B */
+
+/* B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS) */
+
+ strtrs_("Upper", "Transpose", "Non-unit", n, nrhs, &a[a_offset],
+ lda, &b[b_offset], ldb, info);
+
+ if (*info > 0) {
+ return 0;
+ }
+
+/* B(N+1:M,1:NRHS) = ZERO */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = *n + 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) */
+
+ i__1 = *lwork - mn;
+ sormqr_("Left", "No transpose", m, nrhs, n, &a[a_offset], lda, &
+ work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
+
+/* workspace at least NRHS, optimally NRHS*NB */
+
+ scllen = *m;
+
+ }
+
+ } else {
+
+/* Compute LQ factorization of A */
+
+ i__1 = *lwork - mn;
+ sgelqf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
+ ;
+
+/* workspace at least M, optimally M*NB. */
+
+ if (! tpsd) {
+
+/* underdetermined system of equations A * X = B */
+
+/* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) */
+
+ strtrs_("Lower", "No transpose", "Non-unit", m, nrhs, &a[a_offset]
+, lda, &b[b_offset], ldb, info);
+
+ if (*info > 0) {
+ return 0;
+ }
+
+/* B(M+1:N,1:NRHS) = 0 */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = *m + 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS) */
+
+ i__1 = *lwork - mn;
+ sormlq_("Left", "Transpose", n, nrhs, m, &a[a_offset], lda, &work[
+ 1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
+
+/* workspace at least NRHS, optimally NRHS*NB */
+
+ scllen = *n;
+
+ } else {
+
+/* overdetermined system min || A' * X - B || */
+
+/* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) */
+
+ i__1 = *lwork - mn;
+ sormlq_("Left", "No transpose", n, nrhs, m, &a[a_offset], lda, &
+ work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
+
+/* workspace at least NRHS, optimally NRHS*NB */
+
+/* B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS) */
+
+ strtrs_("Lower", "Transpose", "Non-unit", m, nrhs, &a[a_offset],
+ lda, &b[b_offset], ldb, info);
+
+ if (*info > 0) {
+ return 0;
+ }
+
+ scllen = *m;
+
+ }
+
+ }
+
+/* Undo scaling */
+
+ if (iascl == 1) {
+ slascl_("G", &c__0, &c__0, &anrm, &smlnum, &scllen, nrhs, &b[b_offset]
+, ldb, info);
+ } else if (iascl == 2) {
+ slascl_("G", &c__0, &c__0, &anrm, &bignum, &scllen, nrhs, &b[b_offset]
+, ldb, info);
+ }
+ if (ibscl == 1) {
+ slascl_("G", &c__0, &c__0, &smlnum, &bnrm, &scllen, nrhs, &b[b_offset]
+, ldb, info);
+ } else if (ibscl == 2) {
+ slascl_("G", &c__0, &c__0, &bignum, &bnrm, &scllen, nrhs, &b[b_offset]
+, ldb, info);
+ }
+
+L50:
+ work[1] = (real) wsize;
+
+ return 0;
+
+/* End of SGELS */
+
+} /* sgels_ */
diff --git a/SRC/sgelsd.c b/SRC/sgelsd.c
new file mode 100644
index 0000000..8d2b911
--- /dev/null
+++ b/SRC/sgelsd.c
@@ -0,0 +1,699 @@
+/* sgelsd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__9 = 9;
+static integer c__0 = 0;
+static integer c__6 = 6;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static real c_b81 = 0.f;
+
+/* Subroutine */ int sgelsd_(integer *m, integer *n, integer *nrhs, real *a,
+ integer *lda, real *b, integer *ldb, real *s, real *rcond, integer *
+ rank, real *work, integer *lwork, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ double log(doublereal);
+
+ /* Local variables */
+ integer ie, il, mm;
+ real eps, anrm, bnrm;
+ integer itau, nlvl, iascl, ibscl;
+ real sfmin;
+ integer minmn, maxmn, itaup, itauq, mnthr, nwork;
+ extern /* Subroutine */ int slabad_(real *, real *), sgebrd_(integer *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ real *, integer *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ real bignum;
+ extern /* Subroutine */ int sgelqf_(integer *, integer *, real *, integer
+ *, real *, real *, integer *, integer *), slalsd_(char *, integer
+ *, integer *, integer *, real *, real *, real *, integer *, real *
+, integer *, real *, integer *, integer *), slascl_(char *
+, integer *, integer *, real *, real *, integer *, integer *,
+ real *, integer *, integer *);
+ integer wlalsd;
+ extern /* Subroutine */ int sgeqrf_(integer *, integer *, real *, integer
+ *, real *, real *, integer *, integer *), slacpy_(char *, integer
+ *, integer *, real *, integer *, real *, integer *),
+ slaset_(char *, integer *, integer *, real *, real *, real *,
+ integer *);
+ integer ldwork;
+ extern /* Subroutine */ int sormbr_(char *, char *, char *, integer *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, real *, integer *, integer *);
+ integer liwork, minwrk, maxwrk;
+ real smlnum;
+ extern /* Subroutine */ int sormlq_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+ logical lquery;
+ integer smlsiz;
+ extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGELSD computes the minimum-norm solution to a real linear least */
+/* squares problem: */
+/* minimize 2-norm(| b - A*x |) */
+/* using the singular value decomposition (SVD) of A. A is an M-by-N */
+/* matrix which may be rank-deficient. */
+
+/* Several right hand side vectors b and solution vectors x can be */
+/* handled in a single call; they are stored as the columns of the */
+/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
+/* matrix X. */
+
+/* The problem is solved in three steps: */
+/* (1) Reduce the coefficient matrix A to bidiagonal form with */
+/* Householder transformations, reducing the original problem */
+/* into a "bidiagonal least squares problem" (BLS) */
+/* (2) Solve the BLS using a divide and conquer approach. */
+/* (3) Apply back all the Householder tranformations to solve */
+/* the original least squares problem. */
+
+/* The effective rank of A is determined by treating as zero those */
+/* singular values which are less than RCOND times the largest singular */
+/* value. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A has been destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the M-by-NRHS right hand side matrix B. */
+/* On exit, B is overwritten by the N-by-NRHS solution */
+/* matrix X. If m >= n and RANK = n, the residual */
+/* sum-of-squares for the solution in the i-th column is given */
+/* by the sum of squares of elements n+1:m in that column. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,max(M,N)). */
+
+/* S (output) REAL array, dimension (min(M,N)) */
+/* The singular values of A in decreasing order. */
+/* The condition number of A in the 2-norm = S(1)/S(min(m,n)). */
+
+/* RCOND (input) REAL */
+/* RCOND is used to determine the effective rank of A. */
+/* Singular values S(i) <= RCOND*S(1) are treated as zero. */
+/* If RCOND < 0, machine precision is used instead. */
+
+/* RANK (output) INTEGER */
+/* The effective rank of A, i.e., the number of singular values */
+/* which are greater than RCOND*S(1). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK must be at least 1. */
+/* The exact minimum amount of workspace needed depends on M, */
+/* N and NRHS. As long as LWORK is at least */
+/* 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2, */
+/* if M is greater than or equal to N or */
+/* 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2, */
+/* if M is less than N, the code will execute correctly. */
+/* SMLSIZ is returned by ILAENV and is equal to the maximum */
+/* size of the subproblems at the bottom of the computation */
+/* tree (usually about 25), and */
+/* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) */
+/* For good performance, LWORK should generally be larger. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal size of the array WORK and the */
+/* minimum size of the array IWORK, and returns these values as */
+/* the first entries of the WORK and IWORK arrays, and no error */
+/* message related to LWORK is issued by XERBLA. */
+
+/* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN), */
+/* where MINMN = MIN( M,N ). */
+/* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: the algorithm for computing the SVD failed to converge; */
+/* if INFO = i, i off-diagonal elements of an intermediate */
+/* bidiagonal form did not converge to zero. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */
+/* California at Berkeley, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --s;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ minmn = min(*m,*n);
+ maxmn = max(*m,*n);
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,maxmn)) {
+ *info = -7;
+ }
+
+/* Compute workspace. */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ if (*info == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ liwork = 1;
+ if (minmn > 0) {
+ smlsiz = ilaenv_(&c__9, "SGELSD", " ", &c__0, &c__0, &c__0, &c__0);
+ mnthr = ilaenv_(&c__6, "SGELSD", " ", m, n, nrhs, &c_n1);
+/* Computing MAX */
+ i__1 = (integer) (log((real) minmn / (real) (smlsiz + 1)) / log(
+ 2.f)) + 1;
+ nlvl = max(i__1,0);
+ liwork = minmn * 3 * nlvl + minmn * 11;
+ mm = *m;
+ if (*m >= *n && *m >= mnthr) {
+
+/* Path 1a - overdetermined, with many more rows than */
+/* columns. */
+
+ mm = *n;
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "SGEQRF",
+ " ", m, n, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "SORMQR",
+ "LT", m, nrhs, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ }
+ if (*m >= *n) {
+
+/* Path 1 - overdetermined or exactly determined. */
+
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * 3 + (mm + *n) * ilaenv_(&c__1,
+ "SGEBRD", " ", &mm, n, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, "SORMBR"
+, "QLT", &mm, nrhs, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
+ "SORMBR", "PLN", n, nrhs, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing 2nd power */
+ i__1 = smlsiz + 1;
+ wlalsd = *n * 9 + (*n << 1) * smlsiz + (*n << 3) * nlvl + *n *
+ *nrhs + i__1 * i__1;
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * 3 + wlalsd;
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = max(i__1,
+ i__2), i__2 = *n * 3 + wlalsd;
+ minwrk = max(i__1,i__2);
+ }
+ if (*n > *m) {
+/* Computing 2nd power */
+ i__1 = smlsiz + 1;
+ wlalsd = *m * 9 + (*m << 1) * smlsiz + (*m << 3) * nlvl + *m *
+ *nrhs + i__1 * i__1;
+ if (*n >= mnthr) {
+
+/* Path 2a - underdetermined, with many more columns */
+/* than rows. */
+
+ maxwrk = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) *
+ ilaenv_(&c__1, "SGEBRD", " ", m, m, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs *
+ ilaenv_(&c__1, "SORMBR", "QLT", m, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) *
+ ilaenv_(&c__1, "SORMBR", "PLN", m, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+ if (*nrhs > 1) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs;
+ maxwrk = max(i__1,i__2);
+ } else {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 1);
+ maxwrk = max(i__1,i__2);
+ }
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, "SORMLQ"
+, "LT", n, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + wlalsd;
+ maxwrk = max(i__1,i__2);
+/* XXX: Ensure the Path 2a case below is triggered. The workspace */
+/* calculation should use queries for all routines eventually. */
+/* Computing MAX */
+/* Computing MAX */
+ i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4),
+ i__3 = max(i__3,*nrhs), i__4 = *n - *m * 3;
+ i__1 = maxwrk, i__2 = (*m << 2) + *m * *m + max(i__3,i__4)
+ ;
+ maxwrk = max(i__1,i__2);
+ } else {
+
+/* Path 2 - remaining underdetermined cases. */
+
+ maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, "SGEBRD",
+ " ", m, n, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1,
+ "SORMBR", "QLT", m, nrhs, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORM"
+ "BR", "PLN", n, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * 3 + wlalsd;
+ maxwrk = max(i__1,i__2);
+ }
+/* Computing MAX */
+ i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *m, i__1 = max(i__1,
+ i__2), i__2 = *m * 3 + wlalsd;
+ minwrk = max(i__1,i__2);
+ }
+ }
+ minwrk = min(minwrk,maxwrk);
+ work[1] = (real) maxwrk;
+ iwork[1] = liwork;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGELSD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ *rank = 0;
+ return 0;
+ }
+
+/* Get machine parameters. */
+
+ eps = slamch_("P");
+ sfmin = slamch_("S");
+ smlnum = sfmin / eps;
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Scale A if max entry outside range [SMLNUM,BIGNUM]. */
+
+ anrm = slange_("M", m, n, &a[a_offset], lda, &work[1]);
+ iascl = 0;
+ if (anrm > 0.f && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM. */
+
+ slascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM. */
+
+ slascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 2;
+ } else if (anrm == 0.f) {
+
+/* Matrix all zero. Return zero solution. */
+
+ i__1 = max(*m,*n);
+ slaset_("F", &i__1, nrhs, &c_b81, &c_b81, &b[b_offset], ldb);
+ slaset_("F", &minmn, &c__1, &c_b81, &c_b81, &s[1], &c__1);
+ *rank = 0;
+ goto L10;
+ }
+
+/* Scale B if max entry outside range [SMLNUM,BIGNUM]. */
+
+ bnrm = slange_("M", m, nrhs, &b[b_offset], ldb, &work[1]);
+ ibscl = 0;
+ if (bnrm > 0.f && bnrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM. */
+
+ slascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 1;
+ } else if (bnrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM. */
+
+ slascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 2;
+ }
+
+/* If M < N make sure certain entries of B are zero. */
+
+ if (*m < *n) {
+ i__1 = *n - *m;
+ slaset_("F", &i__1, nrhs, &c_b81, &c_b81, &b[*m + 1 + b_dim1], ldb);
+ }
+
+/* Overdetermined case. */
+
+ if (*m >= *n) {
+
+/* Path 1 - overdetermined or exactly determined. */
+
+ mm = *m;
+ if (*m >= mnthr) {
+
+/* Path 1a - overdetermined, with many more rows than columns. */
+
+ mm = *n;
+ itau = 1;
+ nwork = itau + *n;
+
+/* Compute A=Q*R. */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1,
+ info);
+
+/* Multiply B by transpose(Q). */
+/* (Workspace: need N+NRHS, prefer N+NRHS*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sormqr_("L", "T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[
+ b_offset], ldb, &work[nwork], &i__1, info);
+
+/* Zero out below R. */
+
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ slaset_("L", &i__1, &i__2, &c_b81, &c_b81, &a[a_dim1 + 2],
+ lda);
+ }
+ }
+
+ ie = 1;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize R in A. */
+/* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
+ work[itaup], &work[nwork], &i__1, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors of R. */
+/* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sormbr_("Q", "L", "T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq],
+ &b[b_offset], ldb, &work[nwork], &i__1, info);
+
+/* Solve the bidiagonal least squares problem. */
+
+ slalsd_("U", &smlsiz, n, nrhs, &s[1], &work[ie], &b[b_offset], ldb,
+ rcond, rank, &work[nwork], &iwork[1], info);
+ if (*info != 0) {
+ goto L10;
+ }
+
+/* Multiply B by right bidiagonalizing vectors of R. */
+
+ i__1 = *lwork - nwork + 1;
+ sormbr_("P", "L", "N", n, nrhs, n, &a[a_offset], lda, &work[itaup], &
+ b[b_offset], ldb, &work[nwork], &i__1, info);
+
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = *m, i__2 = (*m << 1) - 4, i__1 = max(i__1,i__2), i__1 = max(
+ i__1,*nrhs), i__2 = *n - *m * 3, i__1 = max(i__1,i__2);
+ if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__1,wlalsd)) {
+
+/* Path 2a - underdetermined, with many more columns than rows */
+/* and sufficient workspace for an efficient algorithm. */
+
+ ldwork = *m;
+/* Computing MAX */
+/* Computing MAX */
+ i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 =
+ max(i__3,*nrhs), i__4 = *n - *m * 3;
+ i__1 = (*m << 2) + *m * *lda + max(i__3,i__4), i__2 = *m * *lda +
+ *m + *m * *nrhs, i__1 = max(i__1,i__2), i__2 = (*m << 2)
+ + *m * *lda + wlalsd;
+ if (*lwork >= max(i__1,i__2)) {
+ ldwork = *lda;
+ }
+ itau = 1;
+ nwork = *m + 1;
+
+/* Compute A=L*Q. */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1,
+ info);
+ il = nwork;
+
+/* Copy L to WORK(IL), zeroing out above its diagonal. */
+
+ slacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork);
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ slaset_("U", &i__1, &i__2, &c_b81, &c_b81, &work[il + ldwork], &
+ ldwork);
+ ie = il + ldwork * *m;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IL). */
+/* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq],
+ &work[itaup], &work[nwork], &i__1, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors of L. */
+/* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sormbr_("Q", "L", "T", m, nrhs, m, &work[il], &ldwork, &work[
+ itauq], &b[b_offset], ldb, &work[nwork], &i__1, info);
+
+/* Solve the bidiagonal least squares problem. */
+
+ slalsd_("U", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset],
+ ldb, rcond, rank, &work[nwork], &iwork[1], info);
+ if (*info != 0) {
+ goto L10;
+ }
+
+/* Multiply B by right bidiagonalizing vectors of L. */
+
+ i__1 = *lwork - nwork + 1;
+ sormbr_("P", "L", "N", m, nrhs, m, &work[il], &ldwork, &work[
+ itaup], &b[b_offset], ldb, &work[nwork], &i__1, info);
+
+/* Zero out below first M rows of B. */
+
+ i__1 = *n - *m;
+ slaset_("F", &i__1, nrhs, &c_b81, &c_b81, &b[*m + 1 + b_dim1],
+ ldb);
+ nwork = itau + *m;
+
+/* Multiply transpose(Q) by B. */
+/* (Workspace: need M+NRHS, prefer M+NRHS*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sormlq_("L", "T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[
+ b_offset], ldb, &work[nwork], &i__1, info);
+
+ } else {
+
+/* Path 2 - remaining underdetermined cases. */
+
+ ie = 1;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize A. */
+/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
+ work[itaup], &work[nwork], &i__1, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors. */
+/* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sormbr_("Q", "L", "T", m, nrhs, n, &a[a_offset], lda, &work[itauq]
+, &b[b_offset], ldb, &work[nwork], &i__1, info);
+
+/* Solve the bidiagonal least squares problem. */
+
+ slalsd_("L", &smlsiz, m, nrhs, &s[1], &work[ie], &b[b_offset],
+ ldb, rcond, rank, &work[nwork], &iwork[1], info);
+ if (*info != 0) {
+ goto L10;
+ }
+
+/* Multiply B by right bidiagonalizing vectors of A. */
+
+ i__1 = *lwork - nwork + 1;
+ sormbr_("P", "L", "N", n, nrhs, m, &a[a_offset], lda, &work[itaup]
+, &b[b_offset], ldb, &work[nwork], &i__1, info);
+
+ }
+ }
+
+/* Undo scaling. */
+
+ if (iascl == 1) {
+ slascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
+ info);
+ slascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, info);
+ } else if (iascl == 2) {
+ slascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
+ info);
+ slascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, info);
+ }
+ if (ibscl == 1) {
+ slascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ } else if (ibscl == 2) {
+ slascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ }
+
+L10:
+ work[1] = (real) maxwrk;
+ iwork[1] = liwork;
+ return 0;
+
+/* End of SGELSD */
+
+} /* sgelsd_ */
diff --git a/SRC/sgelss.c b/SRC/sgelss.c
new file mode 100644
index 0000000..6de4676
--- /dev/null
+++ b/SRC/sgelss.c
@@ -0,0 +1,822 @@
+/* sgelss.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__6 = 6;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__0 = 0;
+static real c_b74 = 0.f;
+static real c_b108 = 1.f;
+
+/* Subroutine */ int sgelss_(integer *m, integer *n, integer *nrhs, real *a,
+ integer *lda, real *b, integer *ldb, real *s, real *rcond, integer *
+ rank, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
+ real r__1;
+
+ /* Local variables */
+ integer i__, bl, ie, il, mm;
+ real eps, thr, anrm, bnrm;
+ integer itau;
+ real vdum[1];
+ integer iascl, ibscl, chunk;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real sfmin;
+ integer minmn, maxmn;
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ integer itaup, itauq;
+ extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *);
+ integer mnthr, iwork;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), slabad_(real *, real *);
+ integer bdspac;
+ extern /* Subroutine */ int sgebrd_(integer *, integer *, real *, integer
+ *, real *, real *, real *, real *, real *, integer *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ real bignum;
+ extern /* Subroutine */ int sgelqf_(integer *, integer *, real *, integer
+ *, real *, real *, integer *, integer *), slascl_(char *, integer
+ *, integer *, real *, real *, integer *, integer *, real *,
+ integer *, integer *), sgeqrf_(integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *), slacpy_(char
+ *, integer *, integer *, real *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *,
+ real *, integer *), sbdsqr_(char *, integer *, integer *,
+ integer *, integer *, real *, real *, real *, integer *, real *,
+ integer *, real *, integer *, real *, integer *), sorgbr_(
+ char *, integer *, integer *, integer *, real *, integer *, real *
+, real *, integer *, integer *);
+ integer ldwork;
+ extern /* Subroutine */ int sormbr_(char *, char *, char *, integer *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, real *, integer *, integer *);
+ integer minwrk, maxwrk;
+ real smlnum;
+ extern /* Subroutine */ int sormlq_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+ logical lquery;
+ extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGELSS computes the minimum norm solution to a real linear least */
+/* squares problem: */
+
+/* Minimize 2-norm(| b - A*x |). */
+
+/* using the singular value decomposition (SVD) of A. A is an M-by-N */
+/* matrix which may be rank-deficient. */
+
+/* Several right hand side vectors b and solution vectors x can be */
+/* handled in a single call; they are stored as the columns of the */
+/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix */
+/* X. */
+
+/* The effective rank of A is determined by treating as zero those */
+/* singular values which are less than RCOND times the largest singular */
+/* value. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the first min(m,n) rows of A are overwritten with */
+/* its right singular vectors, stored rowwise. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the M-by-NRHS right hand side matrix B. */
+/* On exit, B is overwritten by the N-by-NRHS solution */
+/* matrix X. If m >= n and RANK = n, the residual */
+/* sum-of-squares for the solution in the i-th column is given */
+/* by the sum of squares of elements n+1:m in that column. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,max(M,N)). */
+
+/* S (output) REAL array, dimension (min(M,N)) */
+/* The singular values of A in decreasing order. */
+/* The condition number of A in the 2-norm = S(1)/S(min(m,n)). */
+
+/* RCOND (input) REAL */
+/* RCOND is used to determine the effective rank of A. */
+/* Singular values S(i) <= RCOND*S(1) are treated as zero. */
+/* If RCOND < 0, machine precision is used instead. */
+
+/* RANK (output) INTEGER */
+/* The effective rank of A, i.e., the number of singular values */
+/* which are greater than RCOND*S(1). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= 1, and also: */
+/* LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS ) */
+/* For good performance, LWORK should generally be larger. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: the algorithm for computing the SVD failed to converge; */
+/* if INFO = i, i off-diagonal elements of an intermediate */
+/* bidiagonal form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --s;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ minmn = min(*m,*n);
+ maxmn = max(*m,*n);
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,maxmn)) {
+ *info = -7;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ if (*info == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ if (minmn > 0) {
+ mm = *m;
+ mnthr = ilaenv_(&c__6, "SGELSS", " ", m, n, nrhs, &c_n1);
+ if (*m >= *n && *m >= mnthr) {
+
+/* Path 1a - overdetermined, with many more rows than */
+/* columns */
+
+ mm = *n;
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "SGEQRF",
+ " ", m, n, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "SORMQR",
+ "LT", m, nrhs, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ }
+ if (*m >= *n) {
+
+/* Path 1 - overdetermined or exactly determined */
+
+/* Compute workspace needed for SBDSQR */
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * 5;
+ bdspac = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * 3 + (mm + *n) * ilaenv_(&c__1,
+ "SGEBRD", " ", &mm, n, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, "SORMBR"
+, "QLT", &mm, nrhs, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
+ "SORGBR", "P", n, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ maxwrk = max(maxwrk,bdspac);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * *nrhs;
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = max(i__1,
+ i__2);
+ minwrk = max(i__1,bdspac);
+ maxwrk = max(minwrk,maxwrk);
+ }
+ if (*n > *m) {
+
+/* Compute workspace needed for SBDSQR */
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *m * 5;
+ bdspac = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *n, i__1 = max(i__1,
+ i__2);
+ minwrk = max(i__1,bdspac);
+ if (*n >= mnthr) {
+
+/* Path 2a - underdetermined, with many more columns */
+/* than rows */
+
+ maxwrk = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) *
+ ilaenv_(&c__1, "SGEBRD", " ", m, m, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs *
+ ilaenv_(&c__1, "SORMBR", "QLT", m, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) *
+ ilaenv_(&c__1, "SORGBR", "P", m, m, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + *m + bdspac;
+ maxwrk = max(i__1,i__2);
+ if (*nrhs > 1) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs;
+ maxwrk = max(i__1,i__2);
+ } else {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 1);
+ maxwrk = max(i__1,i__2);
+ }
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, "SORMLQ"
+, "LT", n, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+ } else {
+
+/* Path 2 - underdetermined */
+
+ maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, "SGEBRD",
+ " ", m, n, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1,
+ "SORMBR", "QLT", m, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORG"
+ "BR", "P", m, n, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+ maxwrk = max(maxwrk,bdspac);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * *nrhs;
+ maxwrk = max(i__1,i__2);
+ }
+ }
+ maxwrk = max(minwrk,maxwrk);
+ }
+ work[1] = (real) maxwrk;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGELSS", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ *rank = 0;
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ eps = slamch_("P");
+ sfmin = slamch_("S");
+ smlnum = sfmin / eps;
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = slange_("M", m, n, &a[a_offset], lda, &work[1]);
+ iascl = 0;
+ if (anrm > 0.f && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ slascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ slascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 2;
+ } else if (anrm == 0.f) {
+
+/* Matrix all zero. Return zero solution. */
+
+ i__1 = max(*m,*n);
+ slaset_("F", &i__1, nrhs, &c_b74, &c_b74, &b[b_offset], ldb);
+ slaset_("F", &minmn, &c__1, &c_b74, &c_b74, &s[1], &c__1);
+ *rank = 0;
+ goto L70;
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = slange_("M", m, nrhs, &b[b_offset], ldb, &work[1]);
+ ibscl = 0;
+ if (bnrm > 0.f && bnrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ slascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 1;
+ } else if (bnrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ slascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 2;
+ }
+
+/* Overdetermined case */
+
+ if (*m >= *n) {
+
+/* Path 1 - overdetermined or exactly determined */
+
+ mm = *m;
+ if (*m >= mnthr) {
+
+/* Path 1a - overdetermined, with many more rows than columns */
+
+ mm = *n;
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__1 = *lwork - iwork + 1;
+ sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__1,
+ info);
+
+/* Multiply B by transpose(Q) */
+/* (Workspace: need N+NRHS, prefer N+NRHS*NB) */
+
+ i__1 = *lwork - iwork + 1;
+ sormqr_("L", "T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[
+ b_offset], ldb, &work[iwork], &i__1, info);
+
+/* Zero out below R */
+
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ slaset_("L", &i__1, &i__2, &c_b74, &c_b74, &a[a_dim1 + 2],
+ lda);
+ }
+ }
+
+ ie = 1;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in A */
+/* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) */
+
+ i__1 = *lwork - iwork + 1;
+ sgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
+ work[itaup], &work[iwork], &i__1, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors of R */
+/* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) */
+
+ i__1 = *lwork - iwork + 1;
+ sormbr_("Q", "L", "T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq],
+ &b[b_offset], ldb, &work[iwork], &i__1, info);
+
+/* Generate right bidiagonalizing vectors of R in A */
+/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */
+
+ i__1 = *lwork - iwork + 1;
+ sorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[iwork], &
+ i__1, info);
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration */
+/* multiply B by transpose of left singular vectors */
+/* compute right singular vectors in A */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("U", n, n, &c__0, nrhs, &s[1], &work[ie], &a[a_offset], lda,
+ vdum, &c__1, &b[b_offset], ldb, &work[iwork], info)
+ ;
+ if (*info != 0) {
+ goto L70;
+ }
+
+/* Multiply B by reciprocals of singular values */
+
+/* Computing MAX */
+ r__1 = *rcond * s[1];
+ thr = dmax(r__1,sfmin);
+ if (*rcond < 0.f) {
+/* Computing MAX */
+ r__1 = eps * s[1];
+ thr = dmax(r__1,sfmin);
+ }
+ *rank = 0;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] > thr) {
+ srscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb);
+ ++(*rank);
+ } else {
+ slaset_("F", &c__1, nrhs, &c_b74, &c_b74, &b[i__ + b_dim1],
+ ldb);
+ }
+/* L10: */
+ }
+
+/* Multiply B by right singular vectors */
+/* (Workspace: need N, prefer N*NRHS) */
+
+ if (*lwork >= *ldb * *nrhs && *nrhs > 1) {
+ sgemm_("T", "N", n, nrhs, n, &c_b108, &a[a_offset], lda, &b[
+ b_offset], ldb, &c_b74, &work[1], ldb);
+ slacpy_("G", n, nrhs, &work[1], ldb, &b[b_offset], ldb)
+ ;
+ } else if (*nrhs > 1) {
+ chunk = *lwork / *n;
+ i__1 = *nrhs;
+ i__2 = chunk;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = *nrhs - i__ + 1;
+ bl = min(i__3,chunk);
+ sgemm_("T", "N", n, &bl, n, &c_b108, &a[a_offset], lda, &b[
+ i__ * b_dim1 + 1], ldb, &c_b74, &work[1], n);
+ slacpy_("G", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1], ldb);
+/* L20: */
+ }
+ } else {
+ sgemv_("T", n, n, &c_b108, &a[a_offset], lda, &b[b_offset], &c__1,
+ &c_b74, &work[1], &c__1);
+ scopy_(n, &work[1], &c__1, &b[b_offset], &c__1);
+ }
+
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__2 = *m, i__1 = (*m << 1) - 4, i__2 = max(i__2,i__1), i__2 = max(
+ i__2,*nrhs), i__1 = *n - *m * 3;
+ if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__2,i__1)) {
+
+/* Path 2a - underdetermined, with many more columns than rows */
+/* and sufficient workspace for an efficient algorithm */
+
+ ldwork = *m;
+/* Computing MAX */
+/* Computing MAX */
+ i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 =
+ max(i__3,*nrhs), i__4 = *n - *m * 3;
+ i__2 = (*m << 2) + *m * *lda + max(i__3,i__4), i__1 = *m * *lda +
+ *m + *m * *nrhs;
+ if (*lwork >= max(i__2,i__1)) {
+ ldwork = *lda;
+ }
+ itau = 1;
+ iwork = *m + 1;
+
+/* Compute A=L*Q */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2,
+ info);
+ il = iwork;
+
+/* Copy L to WORK(IL), zeroing out above it */
+
+ slacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork);
+ i__2 = *m - 1;
+ i__1 = *m - 1;
+ slaset_("U", &i__2, &i__1, &c_b74, &c_b74, &work[il + ldwork], &
+ ldwork);
+ ie = il + ldwork * *m;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IL) */
+/* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq],
+ &work[itaup], &work[iwork], &i__2, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors of L */
+/* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sormbr_("Q", "L", "T", m, nrhs, m, &work[il], &ldwork, &work[
+ itauq], &b[b_offset], ldb, &work[iwork], &i__2, info);
+
+/* Generate right bidiagonalizing vectors of R in WORK(IL) */
+/* (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("P", m, m, m, &work[il], &ldwork, &work[itaup], &work[
+ iwork], &i__2, info);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, */
+/* computing right singular vectors of L in WORK(IL) and */
+/* multiplying B by transpose of left singular vectors */
+/* (Workspace: need M*M+M+BDSPAC) */
+
+ sbdsqr_("U", m, m, &c__0, nrhs, &s[1], &work[ie], &work[il], &
+ ldwork, &a[a_offset], lda, &b[b_offset], ldb, &work[iwork]
+, info);
+ if (*info != 0) {
+ goto L70;
+ }
+
+/* Multiply B by reciprocals of singular values */
+
+/* Computing MAX */
+ r__1 = *rcond * s[1];
+ thr = dmax(r__1,sfmin);
+ if (*rcond < 0.f) {
+/* Computing MAX */
+ r__1 = eps * s[1];
+ thr = dmax(r__1,sfmin);
+ }
+ *rank = 0;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (s[i__] > thr) {
+ srscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb);
+ ++(*rank);
+ } else {
+ slaset_("F", &c__1, nrhs, &c_b74, &c_b74, &b[i__ + b_dim1]
+, ldb);
+ }
+/* L30: */
+ }
+ iwork = ie;
+
+/* Multiply B by right singular vectors of L in WORK(IL) */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS) */
+
+ if (*lwork >= *ldb * *nrhs + iwork - 1 && *nrhs > 1) {
+ sgemm_("T", "N", m, nrhs, m, &c_b108, &work[il], &ldwork, &b[
+ b_offset], ldb, &c_b74, &work[iwork], ldb);
+ slacpy_("G", m, nrhs, &work[iwork], ldb, &b[b_offset], ldb);
+ } else if (*nrhs > 1) {
+ chunk = (*lwork - iwork + 1) / *m;
+ i__2 = *nrhs;
+ i__1 = chunk;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
+ i__1) {
+/* Computing MIN */
+ i__3 = *nrhs - i__ + 1;
+ bl = min(i__3,chunk);
+ sgemm_("T", "N", m, &bl, m, &c_b108, &work[il], &ldwork, &
+ b[i__ * b_dim1 + 1], ldb, &c_b74, &work[iwork], m);
+ slacpy_("G", m, &bl, &work[iwork], m, &b[i__ * b_dim1 + 1]
+, ldb);
+/* L40: */
+ }
+ } else {
+ sgemv_("T", m, m, &c_b108, &work[il], &ldwork, &b[b_dim1 + 1],
+ &c__1, &c_b74, &work[iwork], &c__1);
+ scopy_(m, &work[iwork], &c__1, &b[b_dim1 + 1], &c__1);
+ }
+
+/* Zero out below first M rows of B */
+
+ i__1 = *n - *m;
+ slaset_("F", &i__1, nrhs, &c_b74, &c_b74, &b[*m + 1 + b_dim1],
+ ldb);
+ iwork = itau + *m;
+
+/* Multiply transpose(Q) by B */
+/* (Workspace: need M+NRHS, prefer M+NRHS*NB) */
+
+ i__1 = *lwork - iwork + 1;
+ sormlq_("L", "T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[
+ b_offset], ldb, &work[iwork], &i__1, info);
+
+ } else {
+
+/* Path 2 - remaining underdetermined cases */
+
+ ie = 1;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize A */
+/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */
+
+ i__1 = *lwork - iwork + 1;
+ sgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
+ work[itaup], &work[iwork], &i__1, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors */
+/* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) */
+
+ i__1 = *lwork - iwork + 1;
+ sormbr_("Q", "L", "T", m, nrhs, n, &a[a_offset], lda, &work[itauq]
+, &b[b_offset], ldb, &work[iwork], &i__1, info);
+
+/* Generate right bidiagonalizing vectors in A */
+/* (Workspace: need 4*M, prefer 3*M+M*NB) */
+
+ i__1 = *lwork - iwork + 1;
+ sorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[
+ iwork], &i__1, info);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, */
+/* computing right singular vectors of A in A and */
+/* multiplying B by transpose of left singular vectors */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("L", m, n, &c__0, nrhs, &s[1], &work[ie], &a[a_offset],
+ lda, vdum, &c__1, &b[b_offset], ldb, &work[iwork], info);
+ if (*info != 0) {
+ goto L70;
+ }
+
+/* Multiply B by reciprocals of singular values */
+
+/* Computing MAX */
+ r__1 = *rcond * s[1];
+ thr = dmax(r__1,sfmin);
+ if (*rcond < 0.f) {
+/* Computing MAX */
+ r__1 = eps * s[1];
+ thr = dmax(r__1,sfmin);
+ }
+ *rank = 0;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] > thr) {
+ srscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb);
+ ++(*rank);
+ } else {
+ slaset_("F", &c__1, nrhs, &c_b74, &c_b74, &b[i__ + b_dim1]
+, ldb);
+ }
+/* L50: */
+ }
+
+/* Multiply B by right singular vectors of A */
+/* (Workspace: need N, prefer N*NRHS) */
+
+ if (*lwork >= *ldb * *nrhs && *nrhs > 1) {
+ sgemm_("T", "N", n, nrhs, m, &c_b108, &a[a_offset], lda, &b[
+ b_offset], ldb, &c_b74, &work[1], ldb);
+ slacpy_("F", n, nrhs, &work[1], ldb, &b[b_offset], ldb);
+ } else if (*nrhs > 1) {
+ chunk = *lwork / *n;
+ i__1 = *nrhs;
+ i__2 = chunk;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *nrhs - i__ + 1;
+ bl = min(i__3,chunk);
+ sgemm_("T", "N", n, &bl, m, &c_b108, &a[a_offset], lda, &
+ b[i__ * b_dim1 + 1], ldb, &c_b74, &work[1], n);
+ slacpy_("F", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1],
+ ldb);
+/* L60: */
+ }
+ } else {
+ sgemv_("T", m, n, &c_b108, &a[a_offset], lda, &b[b_offset], &
+ c__1, &c_b74, &work[1], &c__1);
+ scopy_(n, &work[1], &c__1, &b[b_offset], &c__1);
+ }
+ }
+ }
+
+/* Undo scaling */
+
+ if (iascl == 1) {
+ slascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
+ info);
+ slascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, info);
+ } else if (iascl == 2) {
+ slascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
+ info);
+ slascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, info);
+ }
+ if (ibscl == 1) {
+ slascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ } else if (ibscl == 2) {
+ slascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ }
+
+L70:
+ work[1] = (real) maxwrk;
+ return 0;
+
+/* End of SGELSS */
+
+} /* sgelss_ */
diff --git a/SRC/sgelsx.c b/SRC/sgelsx.c
new file mode 100644
index 0000000..d678656
--- /dev/null
+++ b/SRC/sgelsx.c
@@ -0,0 +1,433 @@
+/* sgelsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static real c_b13 = 0.f;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static real c_b36 = 1.f;
+
+/* Subroutine */ int sgelsx_(integer *m, integer *n, integer *nrhs, real *a,
+ integer *lda, real *b, integer *ldb, integer *jpvt, real *rcond,
+ integer *rank, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j, k;
+ real c1, c2, s1, s2, t1, t2;
+ integer mn;
+ real anrm, bnrm, smin, smax;
+ integer iascl, ibscl, ismin, ismax;
+ extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), slaic1_(integer *, integer *,
+ real *, real *, real *, real *, real *, real *, real *), sorm2r_(
+ char *, char *, integer *, integer *, integer *, real *, integer *
+, real *, real *, integer *, real *, integer *),
+ slabad_(real *, real *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *), sgeqpf_(integer *, integer *, real *, integer *, integer
+ *, real *, real *, integer *), slaset_(char *, integer *, integer
+ *, real *, real *, real *, integer *);
+ real sminpr, smaxpr, smlnum;
+ extern /* Subroutine */ int slatzm_(char *, integer *, integer *, real *,
+ integer *, real *, real *, real *, integer *, real *),
+ stzrqf_(integer *, integer *, real *, integer *, real *, integer *
+);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine SGELSY. */
+
+/* SGELSX computes the minimum-norm solution to a real linear least */
+/* squares problem: */
+/* minimize || A * X - B || */
+/* using a complete orthogonal factorization of A. A is an M-by-N */
+/* matrix which may be rank-deficient. */
+
+/* Several right hand side vectors b and solution vectors x can be */
+/* handled in a single call; they are stored as the columns of the */
+/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
+/* matrix X. */
+
+/* The routine first computes a QR factorization with column pivoting: */
+/* A * P = Q * [ R11 R12 ] */
+/* [ 0 R22 ] */
+/* with R11 defined as the largest leading submatrix whose estimated */
+/* condition number is less than 1/RCOND. The order of R11, RANK, */
+/* is the effective rank of A. */
+
+/* Then, R22 is considered to be negligible, and R12 is annihilated */
+/* by orthogonal transformations from the right, arriving at the */
+/* complete orthogonal factorization: */
+/* A * P = Q * [ T11 0 ] * Z */
+/* [ 0 0 ] */
+/* The minimum-norm solution is then */
+/* X = P * Z' [ inv(T11)*Q1'*B ] */
+/* [ 0 ] */
+/* where Q1 consists of the first RANK columns of Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of */
+/* columns of matrices B and X. NRHS >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A has been overwritten by details of its */
+/* complete orthogonal factorization. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the M-by-NRHS right hand side matrix B. */
+/* On exit, the N-by-NRHS solution matrix X. */
+/* If m >= n and RANK = n, the residual sum-of-squares for */
+/* the solution in the i-th column is given by the sum of */
+/* squares of elements N+1:M in that column. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M,N). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* On entry, if JPVT(i) .ne. 0, the i-th column of A is an */
+/* initial column, otherwise it is a free column. Before */
+/* the QR factorization of A, all initial columns are */
+/* permuted to the leading positions; only the remaining */
+/* free columns are moved as a result of column pivoting */
+/* during the factorization. */
+/* On exit, if JPVT(i) = k, then the i-th column of A*P */
+/* was the k-th column of A. */
+
+/* RCOND (input) REAL */
+/* RCOND is used to determine the effective rank of A, which */
+/* is defined as the order of the largest leading triangular */
+/* submatrix R11 in the QR factorization with pivoting of A, */
+/* whose estimated condition number < 1/RCOND. */
+
+/* RANK (output) INTEGER */
+/* The effective rank of A, i.e., the order of the submatrix */
+/* R11. This is the same as the order of the submatrix T11 */
+/* in the complete orthogonal factorization of A. */
+
+/* WORK (workspace) REAL array, dimension */
+/* (max( min(M,N)+3*N, 2*min(M,N)+NRHS )), */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --jpvt;
+ --work;
+
+ /* Function Body */
+ mn = min(*m,*n);
+ ismin = mn + 1;
+ ismax = (mn << 1) + 1;
+
+/* Test the input arguments. */
+
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ if (*ldb < max(i__1,*n)) {
+ *info = -7;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGELSX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+/* Computing MIN */
+ i__1 = min(*m,*n);
+ if (min(i__1,*nrhs) == 0) {
+ *rank = 0;
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ smlnum = slamch_("S") / slamch_("P");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Scale A, B if max elements outside range [SMLNUM,BIGNUM] */
+
+ anrm = slange_("M", m, n, &a[a_offset], lda, &work[1]);
+ iascl = 0;
+ if (anrm > 0.f && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ slascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ slascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 2;
+ } else if (anrm == 0.f) {
+
+/* Matrix all zero. Return zero solution. */
+
+ i__1 = max(*m,*n);
+ slaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb);
+ *rank = 0;
+ goto L100;
+ }
+
+ bnrm = slange_("M", m, nrhs, &b[b_offset], ldb, &work[1]);
+ ibscl = 0;
+ if (bnrm > 0.f && bnrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ slascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 1;
+ } else if (bnrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ slascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 2;
+ }
+
+/* Compute QR factorization with column pivoting of A: */
+/* A * P = Q * R */
+
+ sgeqpf_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], info);
+
+/* workspace 3*N. Details of Householder rotations stored */
+/* in WORK(1:MN). */
+
+/* Determine RANK using incremental condition estimation */
+
+ work[ismin] = 1.f;
+ work[ismax] = 1.f;
+ smax = (r__1 = a[a_dim1 + 1], dabs(r__1));
+ smin = smax;
+ if ((r__1 = a[a_dim1 + 1], dabs(r__1)) == 0.f) {
+ *rank = 0;
+ i__1 = max(*m,*n);
+ slaset_("F", &i__1, nrhs, &c_b13, &c_b13, &b[b_offset], ldb);
+ goto L100;
+ } else {
+ *rank = 1;
+ }
+
+L10:
+ if (*rank < mn) {
+ i__ = *rank + 1;
+ slaic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[
+ i__ + i__ * a_dim1], &sminpr, &s1, &c1);
+ slaic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[
+ i__ + i__ * a_dim1], &smaxpr, &s2, &c2);
+
+ if (smaxpr * *rcond <= sminpr) {
+ i__1 = *rank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[ismin + i__ - 1] = s1 * work[ismin + i__ - 1];
+ work[ismax + i__ - 1] = s2 * work[ismax + i__ - 1];
+/* L20: */
+ }
+ work[ismin + *rank] = c1;
+ work[ismax + *rank] = c2;
+ smin = sminpr;
+ smax = smaxpr;
+ ++(*rank);
+ goto L10;
+ }
+ }
+
+/* Logically partition R = [ R11 R12 ] */
+/* [ 0 R22 ] */
+/* where R11 = R(1:RANK,1:RANK) */
+
+/* [R11,R12] = [ T11, 0 ] * Y */
+
+ if (*rank < *n) {
+ stzrqf_(rank, n, &a[a_offset], lda, &work[mn + 1], info);
+ }
+
+/* Details of Householder rotations stored in WORK(MN+1:2*MN) */
+
+/* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */
+
+ sorm2r_("Left", "Transpose", m, nrhs, &mn, &a[a_offset], lda, &work[1], &
+ b[b_offset], ldb, &work[(mn << 1) + 1], info);
+
+/* workspace NRHS */
+
+/* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */
+
+ strsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b36, &
+ a[a_offset], lda, &b[b_offset], ldb);
+
+ i__1 = *n;
+ for (i__ = *rank + 1; i__ <= i__1; ++i__) {
+ i__2 = *nrhs;
+ for (j = 1; j <= i__2; ++j) {
+ b[i__ + j * b_dim1] = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) */
+
+ if (*rank < *n) {
+ i__1 = *rank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n - *rank + 1;
+ slatzm_("Left", &i__2, nrhs, &a[i__ + (*rank + 1) * a_dim1], lda,
+ &work[mn + i__], &b[i__ + b_dim1], &b[*rank + 1 + b_dim1],
+ ldb, &work[(mn << 1) + 1]);
+/* L50: */
+ }
+ }
+
+/* workspace NRHS */
+
+/* B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[(mn << 1) + i__] = 1.f;
+/* L60: */
+ }
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[(mn << 1) + i__] == 1.f) {
+ if (jpvt[i__] != i__) {
+ k = i__;
+ t1 = b[k + j * b_dim1];
+ t2 = b[jpvt[k] + j * b_dim1];
+L70:
+ b[jpvt[k] + j * b_dim1] = t1;
+ work[(mn << 1) + k] = 0.f;
+ t1 = t2;
+ k = jpvt[k];
+ t2 = b[jpvt[k] + j * b_dim1];
+ if (jpvt[k] != i__) {
+ goto L70;
+ }
+ b[i__ + j * b_dim1] = t1;
+ work[(mn << 1) + k] = 0.f;
+ }
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Undo scaling */
+
+ if (iascl == 1) {
+ slascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
+ info);
+ slascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset],
+ lda, info);
+ } else if (iascl == 2) {
+ slascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
+ info);
+ slascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset],
+ lda, info);
+ }
+ if (ibscl == 1) {
+ slascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ } else if (ibscl == 2) {
+ slascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ }
+
+L100:
+
+ return 0;
+
+/* End of SGELSX */
+
+} /* sgelsx_ */
diff --git a/SRC/sgelsy.c b/SRC/sgelsy.c
new file mode 100644
index 0000000..c910c23
--- /dev/null
+++ b/SRC/sgelsy.c
@@ -0,0 +1,488 @@
+/* sgelsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static real c_b31 = 0.f;
+static integer c__2 = 2;
+static real c_b54 = 1.f;
+
+/* Subroutine */ int sgelsy_(integer *m, integer *n, integer *nrhs, real *a,
+ integer *lda, real *b, integer *ldb, integer *jpvt, real *rcond,
+ integer *rank, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer i__, j;
+ real c1, c2, s1, s2;
+ integer nb, mn, nb1, nb2, nb3, nb4;
+ real anrm, bnrm, smin, smax;
+ integer iascl, ibscl, ismin, ismax;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ real wsize;
+ extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), slaic1_(integer *, integer *,
+ real *, real *, real *, real *, real *, real *, real *), sgeqp3_(
+ integer *, integer *, real *, integer *, integer *, real *, real *
+, integer *, integer *), slabad_(real *, real *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ real bignum;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *), slaset_(char *, integer *, integer *, real *, real *,
+ real *, integer *);
+ integer lwkmin;
+ real sminpr, smaxpr, smlnum;
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *), sormrz_(char *, char *,
+ integer *, integer *, integer *, integer *, real *, integer *,
+ real *, real *, integer *, real *, integer *, integer *), stzrzf_(integer *, integer *, real *, integer *, real *,
+ real *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGELSY computes the minimum-norm solution to a real linear least */
+/* squares problem: */
+/* minimize || A * X - B || */
+/* using a complete orthogonal factorization of A. A is an M-by-N */
+/* matrix which may be rank-deficient. */
+
+/* Several right hand side vectors b and solution vectors x can be */
+/* handled in a single call; they are stored as the columns of the */
+/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
+/* matrix X. */
+
+/* The routine first computes a QR factorization with column pivoting: */
+/* A * P = Q * [ R11 R12 ] */
+/* [ 0 R22 ] */
+/* with R11 defined as the largest leading submatrix whose estimated */
+/* condition number is less than 1/RCOND. The order of R11, RANK, */
+/* is the effective rank of A. */
+
+/* Then, R22 is considered to be negligible, and R12 is annihilated */
+/* by orthogonal transformations from the right, arriving at the */
+/* complete orthogonal factorization: */
+/* A * P = Q * [ T11 0 ] * Z */
+/* [ 0 0 ] */
+/* The minimum-norm solution is then */
+/* X = P * Z' [ inv(T11)*Q1'*B ] */
+/* [ 0 ] */
+/* where Q1 consists of the first RANK columns of Q. */
+
+/* This routine is basically identical to the original xGELSX except */
+/* three differences: */
+/* o The call to the subroutine xGEQPF has been substituted by the */
+/* the call to the subroutine xGEQP3. This subroutine is a Blas-3 */
+/* version of the QR factorization with column pivoting. */
+/* o Matrix B (the right hand side) is updated with Blas-3. */
+/* o The permutation of matrix B (the right hand side) is faster and */
+/* more simple. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of */
+/* columns of matrices B and X. NRHS >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A has been overwritten by details of its */
+/* complete orthogonal factorization. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the M-by-NRHS right hand side matrix B. */
+/* On exit, the N-by-NRHS solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M,N). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
+/* to the front of AP, otherwise column i is a free column. */
+/* On exit, if JPVT(i) = k, then the i-th column of AP */
+/* was the k-th column of A. */
+
+/* RCOND (input) REAL */
+/* RCOND is used to determine the effective rank of A, which */
+/* is defined as the order of the largest leading triangular */
+/* submatrix R11 in the QR factorization with pivoting of A, */
+/* whose estimated condition number < 1/RCOND. */
+
+/* RANK (output) INTEGER */
+/* The effective rank of A, i.e., the order of the submatrix */
+/* R11. This is the same as the order of the submatrix T11 */
+/* in the complete orthogonal factorization of A. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* The unblocked strategy requires that: */
+/* LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ), */
+/* where MN = min( M, N ). */
+/* The block algorithm requires that: */
+/* LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ), */
+/* where NB is an upper bound on the blocksize returned */
+/* by ILAENV for the routines SGEQP3, STZRZF, STZRQF, SORMQR, */
+/* and SORMRZ. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: If INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+/* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
+/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --jpvt;
+ --work;
+
+ /* Function Body */
+ mn = min(*m,*n);
+ ismin = mn + 1;
+ ismax = (mn << 1) + 1;
+
+/* Test the input arguments. */
+
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ if (*ldb < max(i__1,*n)) {
+ *info = -7;
+ }
+ }
+
+/* Figure out optimal block size */
+
+ if (*info == 0) {
+ if (mn == 0 || *nrhs == 0) {
+ lwkmin = 1;
+ lwkopt = 1;
+ } else {
+ nb1 = ilaenv_(&c__1, "SGEQRF", " ", m, n, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "SGERQF", " ", m, n, &c_n1, &c_n1);
+ nb3 = ilaenv_(&c__1, "SORMQR", " ", m, n, nrhs, &c_n1);
+ nb4 = ilaenv_(&c__1, "SORMRQ", " ", m, n, nrhs, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2), i__1 = max(i__1,nb3);
+ nb = max(i__1,nb4);
+/* Computing MAX */
+ i__1 = mn << 1, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = mn +
+ *nrhs;
+ lwkmin = mn + max(i__1,i__2);
+/* Computing MAX */
+ i__1 = lwkmin, i__2 = mn + (*n << 1) + nb * (*n + 1), i__1 = max(
+ i__1,i__2), i__2 = (mn << 1) + nb * *nrhs;
+ lwkopt = max(i__1,i__2);
+ }
+ work[1] = (real) lwkopt;
+
+ if (*lwork < lwkmin && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGELSY", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (mn == 0 || *nrhs == 0) {
+ *rank = 0;
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ smlnum = slamch_("S") / slamch_("P");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Scale A, B if max entries outside range [SMLNUM,BIGNUM] */
+
+ anrm = slange_("M", m, n, &a[a_offset], lda, &work[1]);
+ iascl = 0;
+ if (anrm > 0.f && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ slascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ slascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 2;
+ } else if (anrm == 0.f) {
+
+/* Matrix all zero. Return zero solution. */
+
+ i__1 = max(*m,*n);
+ slaset_("F", &i__1, nrhs, &c_b31, &c_b31, &b[b_offset], ldb);
+ *rank = 0;
+ goto L70;
+ }
+
+ bnrm = slange_("M", m, nrhs, &b[b_offset], ldb, &work[1]);
+ ibscl = 0;
+ if (bnrm > 0.f && bnrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ slascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 1;
+ } else if (bnrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ slascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 2;
+ }
+
+/* Compute QR factorization with column pivoting of A: */
+/* A * P = Q * R */
+
+ i__1 = *lwork - mn;
+ sgeqp3_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], &i__1,
+ info);
+ wsize = mn + work[mn + 1];
+
+/* workspace: MN+2*N+NB*(N+1). */
+/* Details of Householder rotations stored in WORK(1:MN). */
+
+/* Determine RANK using incremental condition estimation */
+
+ work[ismin] = 1.f;
+ work[ismax] = 1.f;
+ smax = (r__1 = a[a_dim1 + 1], dabs(r__1));
+ smin = smax;
+ if ((r__1 = a[a_dim1 + 1], dabs(r__1)) == 0.f) {
+ *rank = 0;
+ i__1 = max(*m,*n);
+ slaset_("F", &i__1, nrhs, &c_b31, &c_b31, &b[b_offset], ldb);
+ goto L70;
+ } else {
+ *rank = 1;
+ }
+
+L10:
+ if (*rank < mn) {
+ i__ = *rank + 1;
+ slaic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[
+ i__ + i__ * a_dim1], &sminpr, &s1, &c1);
+ slaic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[
+ i__ + i__ * a_dim1], &smaxpr, &s2, &c2);
+
+ if (smaxpr * *rcond <= sminpr) {
+ i__1 = *rank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[ismin + i__ - 1] = s1 * work[ismin + i__ - 1];
+ work[ismax + i__ - 1] = s2 * work[ismax + i__ - 1];
+/* L20: */
+ }
+ work[ismin + *rank] = c1;
+ work[ismax + *rank] = c2;
+ smin = sminpr;
+ smax = smaxpr;
+ ++(*rank);
+ goto L10;
+ }
+ }
+
+/* workspace: 3*MN. */
+
+/* Logically partition R = [ R11 R12 ] */
+/* [ 0 R22 ] */
+/* where R11 = R(1:RANK,1:RANK) */
+
+/* [R11,R12] = [ T11, 0 ] * Y */
+
+ if (*rank < *n) {
+ i__1 = *lwork - (mn << 1);
+ stzrzf_(rank, n, &a[a_offset], lda, &work[mn + 1], &work[(mn << 1) +
+ 1], &i__1, info);
+ }
+
+/* workspace: 2*MN. */
+/* Details of Householder rotations stored in WORK(MN+1:2*MN) */
+
+/* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */
+
+ i__1 = *lwork - (mn << 1);
+ sormqr_("Left", "Transpose", m, nrhs, &mn, &a[a_offset], lda, &work[1], &
+ b[b_offset], ldb, &work[(mn << 1) + 1], &i__1, info);
+/* Computing MAX */
+ r__1 = wsize, r__2 = (mn << 1) + work[(mn << 1) + 1];
+ wsize = dmax(r__1,r__2);
+
+/* workspace: 2*MN+NB*NRHS. */
+
+/* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */
+
+ strsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b54, &
+ a[a_offset], lda, &b[b_offset], ldb);
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = *rank + 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) */
+
+ if (*rank < *n) {
+ i__1 = *n - *rank;
+ i__2 = *lwork - (mn << 1);
+ sormrz_("Left", "Transpose", n, nrhs, rank, &i__1, &a[a_offset], lda,
+ &work[mn + 1], &b[b_offset], ldb, &work[(mn << 1) + 1], &i__2,
+ info);
+ }
+
+/* workspace: 2*MN+NRHS. */
+
+/* B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[jpvt[i__]] = b[i__ + j * b_dim1];
+/* L50: */
+ }
+ scopy_(n, &work[1], &c__1, &b[j * b_dim1 + 1], &c__1);
+/* L60: */
+ }
+
+/* workspace: N. */
+
+/* Undo scaling */
+
+ if (iascl == 1) {
+ slascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
+ info);
+ slascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset],
+ lda, info);
+ } else if (iascl == 2) {
+ slascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
+ info);
+ slascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset],
+ lda, info);
+ }
+ if (ibscl == 1) {
+ slascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ } else if (ibscl == 2) {
+ slascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ }
+
+L70:
+ work[1] = (real) lwkopt;
+
+ return 0;
+
+/* End of SGELSY */
+
+} /* sgelsy_ */
diff --git a/SRC/sgeql2.c b/SRC/sgeql2.c
new file mode 100644
index 0000000..13e292c
--- /dev/null
+++ b/SRC/sgeql2.c
@@ -0,0 +1,159 @@
+/* sgeql2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sgeql2_(integer *m, integer *n, real *a, integer *lda,
+ real *tau, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, k;
+ real aii;
+ extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *), xerbla_(
+ char *, integer *), slarfp_(integer *, real *, real *,
+ integer *, real *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGEQL2 computes a QL factorization of a real m by n matrix A: */
+/* A = Q * L. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the m by n matrix A. */
+/* On exit, if m >= n, the lower triangle of the subarray */
+/* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L; */
+/* if m <= n, the elements on and below the (n-m)-th */
+/* superdiagonal contain the m by n lower trapezoidal matrix L; */
+/* the remaining elements, with the array TAU, represent the */
+/* orthogonal matrix Q as a product of elementary reflectors */
+/* (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in */
+/* A(1:m-k+i-1,n-k+i), and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGEQL2", &i__1);
+ return 0;
+ }
+
+ k = min(*m,*n);
+
+ for (i__ = k; i__ >= 1; --i__) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* A(1:m-k+i-1,n-k+i) */
+
+ i__1 = *m - k + i__;
+ slarfp_(&i__1, &a[*m - k + i__ + (*n - k + i__) * a_dim1], &a[(*n - k
+ + i__) * a_dim1 + 1], &c__1, &tau[i__]);
+
+/* Apply H(i) to A(1:m-k+i,1:n-k+i-1) from the left */
+
+ aii = a[*m - k + i__ + (*n - k + i__) * a_dim1];
+ a[*m - k + i__ + (*n - k + i__) * a_dim1] = 1.f;
+ i__1 = *m - k + i__;
+ i__2 = *n - k + i__ - 1;
+ slarf_("Left", &i__1, &i__2, &a[(*n - k + i__) * a_dim1 + 1], &c__1, &
+ tau[i__], &a[a_offset], lda, &work[1]);
+ a[*m - k + i__ + (*n - k + i__) * a_dim1] = aii;
+/* L10: */
+ }
+ return 0;
+
+/* End of SGEQL2 */
+
+} /* sgeql2_ */
diff --git a/SRC/sgeqlf.c b/SRC/sgeqlf.c
new file mode 100644
index 0000000..3d2b2e6
--- /dev/null
+++ b/SRC/sgeqlf.c
@@ -0,0 +1,270 @@
+/* sgeqlf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int sgeqlf_(integer *m, integer *n, real *a, integer *lda,
+ real *tau, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, k, ib, nb, ki, kk, mu, nu, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int sgeql2_(integer *, integer *, real *, integer
+ *, real *, real *, integer *), slarfb_(char *, char *, char *,
+ char *, integer *, integer *, integer *, real *, integer *, real *
+, integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slarft_(char *, char *, integer *, integer *,
+ real *, integer *, real *, real *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGEQLF computes a QL factorization of a real M-by-N matrix A: */
+/* A = Q * L. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, */
+/* if m >= n, the lower triangle of the subarray */
+/* A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L; */
+/* if m <= n, the elements on and below the (n-m)-th */
+/* superdiagonal contain the M-by-N lower trapezoidal matrix L; */
+/* the remaining elements, with the array TAU, represent the */
+/* orthogonal matrix Q as a product of elementary reflectors */
+/* (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* For optimum performance LWORK >= N*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in */
+/* A(1:m-k+i-1,n-k+i), and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+
+ if (*info == 0) {
+ k = min(*m,*n);
+ if (k == 0) {
+ lwkopt = 1;
+ } else {
+ nb = ilaenv_(&c__1, "SGEQLF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ }
+ work[1] = (real) lwkopt;
+
+ if (*lwork < max(1,*n) && ! lquery) {
+ *info = -7;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGEQLF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (k == 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 1;
+ iws = *n;
+ if (nb > 1 && nb < k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "SGEQLF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *n;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "SGEQLF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < k && nx < k) {
+
+/* Use blocked code initially. */
+/* The last kk columns are handled by the block method. */
+
+ ki = (k - nx - 1) / nb * nb;
+/* Computing MIN */
+ i__1 = k, i__2 = ki + nb;
+ kk = min(i__1,i__2);
+
+ i__1 = k - kk + 1;
+ i__2 = -nb;
+ for (i__ = k - kk + ki + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__
+ += i__2) {
+/* Computing MIN */
+ i__3 = k - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Compute the QL factorization of the current block */
+/* A(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1) */
+
+ i__3 = *m - k + i__ + ib - 1;
+ sgeql2_(&i__3, &ib, &a[(*n - k + i__) * a_dim1 + 1], lda, &tau[
+ i__], &work[1], &iinfo);
+ if (*n - k + i__ > 1) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__3 = *m - k + i__ + ib - 1;
+ slarft_("Backward", "Columnwise", &i__3, &ib, &a[(*n - k +
+ i__) * a_dim1 + 1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H' to A(1:m-k+i+ib-1,1:n-k+i-1) from the left */
+
+ i__3 = *m - k + i__ + ib - 1;
+ i__4 = *n - k + i__ - 1;
+ slarfb_("Left", "Transpose", "Backward", "Columnwise", &i__3,
+ &i__4, &ib, &a[(*n - k + i__) * a_dim1 + 1], lda, &
+ work[1], &ldwork, &a[a_offset], lda, &work[ib + 1], &
+ ldwork);
+ }
+/* L10: */
+ }
+ mu = *m - k + i__ + nb - 1;
+ nu = *n - k + i__ + nb - 1;
+ } else {
+ mu = *m;
+ nu = *n;
+ }
+
+/* Use unblocked code to factor the last or only block */
+
+ if (mu > 0 && nu > 0) {
+ sgeql2_(&mu, &nu, &a[a_offset], lda, &tau[1], &work[1], &iinfo);
+ }
+
+ work[1] = (real) iws;
+ return 0;
+
+/* End of SGEQLF */
+
+} /* sgeqlf_ */
diff --git a/SRC/sgeqp3.c b/SRC/sgeqp3.c
new file mode 100644
index 0000000..b9c8817
--- /dev/null
+++ b/SRC/sgeqp3.c
@@ -0,0 +1,351 @@
+/* sgeqp3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int sgeqp3_(integer *m, integer *n, real *a, integer *lda,
+ integer *jpvt, real *tau, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer j, jb, na, nb, sm, sn, nx, fjb, iws, nfxd;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ integer nbmin, minmn, minws;
+ extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
+ integer *), slaqp2_(integer *, integer *, integer *, real *,
+ integer *, integer *, real *, real *, real *, real *), xerbla_(
+ char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int sgeqrf_(integer *, integer *, real *, integer
+ *, real *, real *, integer *, integer *);
+ integer topbmn, sminmn;
+ extern /* Subroutine */ int slaqps_(integer *, integer *, integer *,
+ integer *, integer *, real *, integer *, integer *, real *, real *
+, real *, real *, real *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGEQP3 computes a QR factorization with column pivoting of a */
+/* matrix A: A*P = Q*R using Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the upper triangle of the array contains the */
+/* min(M,N)-by-N upper trapezoidal matrix R; the elements below */
+/* the diagonal, together with the array TAU, represent the */
+/* orthogonal matrix Q as a product of min(M,N) elementary */
+/* reflectors. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* On entry, if JPVT(J).ne.0, the J-th column of A is permuted */
+/* to the front of A*P (a leading column); if JPVT(J)=0, */
+/* the J-th column of A is a free column. */
+/* On exit, if JPVT(J)=K, then the J-th column of A*P was the */
+/* the K-th column of A. */
+
+/* TAU (output) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO=0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= 3*N+1. */
+/* For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB */
+/* is the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real/complex scalar, and v is a real/complex vector */
+/* with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in */
+/* A(i+1:m,i), and tau in TAU(i). */
+
+/* Based on contributions by */
+/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
+/* X. Sun, Computer Science Dept., Duke University, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --jpvt;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+
+ if (*info == 0) {
+ minmn = min(*m,*n);
+ if (minmn == 0) {
+ iws = 1;
+ lwkopt = 1;
+ } else {
+ iws = *n * 3 + 1;
+ nb = ilaenv_(&c__1, "SGEQRF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = (*n << 1) + (*n + 1) * nb;
+ }
+ work[1] = (real) lwkopt;
+
+ if (*lwork < iws && ! lquery) {
+ *info = -8;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGEQP3", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (minmn == 0) {
+ return 0;
+ }
+
+/* Move initial columns up front. */
+
+ nfxd = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (jpvt[j] != 0) {
+ if (j != nfxd) {
+ sswap_(m, &a[j * a_dim1 + 1], &c__1, &a[nfxd * a_dim1 + 1], &
+ c__1);
+ jpvt[j] = jpvt[nfxd];
+ jpvt[nfxd] = j;
+ } else {
+ jpvt[j] = j;
+ }
+ ++nfxd;
+ } else {
+ jpvt[j] = j;
+ }
+/* L10: */
+ }
+ --nfxd;
+
+/* Factorize fixed columns */
+/* ======================= */
+
+/* Compute the QR factorization of fixed columns and update */
+/* remaining columns. */
+
+ if (nfxd > 0) {
+ na = min(*m,nfxd);
+/* CC CALL SGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) */
+ sgeqrf_(m, &na, &a[a_offset], lda, &tau[1], &work[1], lwork, info);
+/* Computing MAX */
+ i__1 = iws, i__2 = (integer) work[1];
+ iws = max(i__1,i__2);
+ if (na < *n) {
+/* CC CALL SORM2R( 'Left', 'Transpose', M, N-NA, NA, A, LDA, */
+/* CC $ TAU, A( 1, NA+1 ), LDA, WORK, INFO ) */
+ i__1 = *n - na;
+ sormqr_("Left", "Transpose", m, &i__1, &na, &a[a_offset], lda, &
+ tau[1], &a[(na + 1) * a_dim1 + 1], lda, &work[1], lwork,
+ info);
+/* Computing MAX */
+ i__1 = iws, i__2 = (integer) work[1];
+ iws = max(i__1,i__2);
+ }
+ }
+
+/* Factorize free columns */
+/* ====================== */
+
+ if (nfxd < minmn) {
+
+ sm = *m - nfxd;
+ sn = *n - nfxd;
+ sminmn = minmn - nfxd;
+
+/* Determine the block size. */
+
+ nb = ilaenv_(&c__1, "SGEQRF", " ", &sm, &sn, &c_n1, &c_n1);
+ nbmin = 2;
+ nx = 0;
+
+ if (nb > 1 && nb < sminmn) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "SGEQRF", " ", &sm, &sn, &c_n1, &
+ c_n1);
+ nx = max(i__1,i__2);
+
+
+ if (nx < sminmn) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ minws = (sn << 1) + (sn + 1) * nb;
+ iws = max(iws,minws);
+ if (*lwork < minws) {
+
+/* Not enough workspace to use optimal NB: Reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = (*lwork - (sn << 1)) / (sn + 1);
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "SGEQRF", " ", &sm, &sn, &
+ c_n1, &c_n1);
+ nbmin = max(i__1,i__2);
+
+
+ }
+ }
+ }
+
+/* Initialize partial column norms. The first N elements of work */
+/* store the exact column norms. */
+
+ i__1 = *n;
+ for (j = nfxd + 1; j <= i__1; ++j) {
+ work[j] = snrm2_(&sm, &a[nfxd + 1 + j * a_dim1], &c__1);
+ work[*n + j] = work[j];
+/* L20: */
+ }
+
+ if (nb >= nbmin && nb < sminmn && nx < sminmn) {
+
+/* Use blocked code initially. */
+
+ j = nfxd + 1;
+
+/* Compute factorization: while loop. */
+
+
+ topbmn = minmn - nx;
+L30:
+ if (j <= topbmn) {
+/* Computing MIN */
+ i__1 = nb, i__2 = topbmn - j + 1;
+ jb = min(i__1,i__2);
+
+/* Factorize JB columns among columns J:N. */
+
+ i__1 = *n - j + 1;
+ i__2 = j - 1;
+ i__3 = *n - j + 1;
+ slaqps_(m, &i__1, &i__2, &jb, &fjb, &a[j * a_dim1 + 1], lda, &
+ jpvt[j], &tau[j], &work[j], &work[*n + j], &work[(*n
+ << 1) + 1], &work[(*n << 1) + jb + 1], &i__3);
+
+ j += fjb;
+ goto L30;
+ }
+ } else {
+ j = nfxd + 1;
+ }
+
+/* Use unblocked code to factor the last or only block. */
+
+
+ if (j <= minmn) {
+ i__1 = *n - j + 1;
+ i__2 = j - 1;
+ slaqp2_(m, &i__1, &i__2, &a[j * a_dim1 + 1], lda, &jpvt[j], &tau[
+ j], &work[j], &work[*n + j], &work[(*n << 1) + 1]);
+ }
+
+ }
+
+ work[1] = (real) iws;
+ return 0;
+
+/* End of SGEQP3 */
+
+} /* sgeqp3_ */
diff --git a/SRC/sgeqpf.c b/SRC/sgeqpf.c
new file mode 100644
index 0000000..1610cfd
--- /dev/null
+++ b/SRC/sgeqpf.c
@@ -0,0 +1,303 @@
+/* sgeqpf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sgeqpf_(integer *m, integer *n, real *a, integer *lda,
+ integer *jpvt, real *tau, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, ma, mn;
+ real aii;
+ integer pvt;
+ real temp, temp2;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ real tol3z;
+ extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *);
+ integer itemp;
+ extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
+ integer *), sgeqr2_(integer *, integer *, real *, integer *, real
+ *, real *, integer *), sorm2r_(char *, char *, integer *, integer
+ *, integer *, real *, integer *, real *, real *, integer *, real *
+, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ extern /* Subroutine */ int slarfp_(integer *, real *, real *, integer *,
+ real *);
+
+
+/* -- LAPACK deprecated driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine SGEQP3. */
+
+/* SGEQPF computes a QR factorization with column pivoting of a */
+/* real M-by-N matrix A: A*P = Q*R. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0 */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the upper triangle of the array contains the */
+/* min(M,N)-by-N upper triangular matrix R; the elements */
+/* below the diagonal, together with the array TAU, */
+/* represent the orthogonal matrix Q as a product of */
+/* min(m,n) elementary reflectors. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
+/* to the front of A*P (a leading column); if JPVT(i) = 0, */
+/* the i-th column of A is a free column. */
+/* On exit, if JPVT(i) = k, then the i-th column of A*P */
+/* was the k-th column of A. */
+
+/* TAU (output) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors. */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(n) */
+
+/* Each H(i) has the form */
+
+/* H = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). */
+
+/* The matrix P is represented in jpvt as follows: If */
+/* jpvt(j) = i */
+/* then the jth column of P is the ith canonical unit vector. */
+
+/* Partial column norm updating strategy modified by */
+/* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */
+/* University of Zagreb, Croatia. */
+/* June 2006. */
+/* For more details see LAPACK Working Note 176. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --jpvt;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGEQPF", &i__1);
+ return 0;
+ }
+
+ mn = min(*m,*n);
+ tol3z = sqrt(slamch_("Epsilon"));
+
+/* Move initial columns up front */
+
+ itemp = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (jpvt[i__] != 0) {
+ if (i__ != itemp) {
+ sswap_(m, &a[i__ * a_dim1 + 1], &c__1, &a[itemp * a_dim1 + 1],
+ &c__1);
+ jpvt[i__] = jpvt[itemp];
+ jpvt[itemp] = i__;
+ } else {
+ jpvt[i__] = i__;
+ }
+ ++itemp;
+ } else {
+ jpvt[i__] = i__;
+ }
+/* L10: */
+ }
+ --itemp;
+
+/* Compute the QR factorization and update remaining columns */
+
+ if (itemp > 0) {
+ ma = min(itemp,*m);
+ sgeqr2_(m, &ma, &a[a_offset], lda, &tau[1], &work[1], info);
+ if (ma < *n) {
+ i__1 = *n - ma;
+ sorm2r_("Left", "Transpose", m, &i__1, &ma, &a[a_offset], lda, &
+ tau[1], &a[(ma + 1) * a_dim1 + 1], lda, &work[1], info);
+ }
+ }
+
+ if (itemp < mn) {
+
+/* Initialize partial column norms. The first n elements of */
+/* work store the exact column norms. */
+
+ i__1 = *n;
+ for (i__ = itemp + 1; i__ <= i__1; ++i__) {
+ i__2 = *m - itemp;
+ work[i__] = snrm2_(&i__2, &a[itemp + 1 + i__ * a_dim1], &c__1);
+ work[*n + i__] = work[i__];
+/* L20: */
+ }
+
+/* Compute factorization */
+
+ i__1 = mn;
+ for (i__ = itemp + 1; i__ <= i__1; ++i__) {
+
+/* Determine ith pivot column and swap if necessary */
+
+ i__2 = *n - i__ + 1;
+ pvt = i__ - 1 + isamax_(&i__2, &work[i__], &c__1);
+
+ if (pvt != i__) {
+ sswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
+ c__1);
+ itemp = jpvt[pvt];
+ jpvt[pvt] = jpvt[i__];
+ jpvt[i__] = itemp;
+ work[pvt] = work[i__];
+ work[*n + pvt] = work[*n + i__];
+ }
+
+/* Generate elementary reflector H(i) */
+
+ if (i__ < *m) {
+ i__2 = *m - i__ + 1;
+ slarfp_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + 1 + i__ *
+ a_dim1], &c__1, &tau[i__]);
+ } else {
+ slarfp_(&c__1, &a[*m + *m * a_dim1], &a[*m + *m * a_dim1], &
+ c__1, &tau[*m]);
+ }
+
+ if (i__ < *n) {
+
+/* Apply H(i) to A(i:m,i+1:n) from the left */
+
+ aii = a[i__ + i__ * a_dim1];
+ a[i__ + i__ * a_dim1] = 1.f;
+ i__2 = *m - i__ + 1;
+ i__3 = *n - i__;
+ slarf_("LEFT", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
+ tau[i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[(*
+ n << 1) + 1]);
+ a[i__ + i__ * a_dim1] = aii;
+ }
+
+/* Update partial column norms */
+
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (work[j] != 0.f) {
+
+/* NOTE: The following 4 lines follow from the analysis in */
+/* Lapack Working Note 176. */
+
+ temp = (r__1 = a[i__ + j * a_dim1], dabs(r__1)) / work[j];
+/* Computing MAX */
+ r__1 = 0.f, r__2 = (temp + 1.f) * (1.f - temp);
+ temp = dmax(r__1,r__2);
+/* Computing 2nd power */
+ r__1 = work[j] / work[*n + j];
+ temp2 = temp * (r__1 * r__1);
+ if (temp2 <= tol3z) {
+ if (*m - i__ > 0) {
+ i__3 = *m - i__;
+ work[j] = snrm2_(&i__3, &a[i__ + 1 + j * a_dim1],
+ &c__1);
+ work[*n + j] = work[j];
+ } else {
+ work[j] = 0.f;
+ work[*n + j] = 0.f;
+ }
+ } else {
+ work[j] *= sqrt(temp);
+ }
+ }
+/* L30: */
+ }
+
+/* L40: */
+ }
+ }
+ return 0;
+
+/* End of SGEQPF */
+
+} /* sgeqpf_ */
diff --git a/SRC/sgeqr2.c b/SRC/sgeqr2.c
new file mode 100644
index 0000000..7698d16
--- /dev/null
+++ b/SRC/sgeqr2.c
@@ -0,0 +1,161 @@
+/* sgeqr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sgeqr2_(integer *m, integer *n, real *a, integer *lda,
+ real *tau, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, k;
+ real aii;
+ extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *), xerbla_(
+ char *, integer *), slarfp_(integer *, real *, real *,
+ integer *, real *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGEQR2 computes a QR factorization of a real m by n matrix A: */
+/* A = Q * R. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the m by n matrix A. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(m,n) by n upper trapezoidal matrix R (R is */
+/* upper triangular if m >= n); the elements below the diagonal, */
+/* with the array TAU, represent the orthogonal matrix Q as a */
+/* product of elementary reflectors (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */
+/* and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGEQR2", &i__1);
+ return 0;
+ }
+
+ k = min(*m,*n);
+
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
+
+ i__2 = *m - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ slarfp_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3, *m)+ i__ * a_dim1]
+, &c__1, &tau[i__]);
+ if (i__ < *n) {
+
+/* Apply H(i) to A(i:m,i+1:n) from the left */
+
+ aii = a[i__ + i__ * a_dim1];
+ a[i__ + i__ * a_dim1] = 1.f;
+ i__2 = *m - i__ + 1;
+ i__3 = *n - i__;
+ slarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &tau[
+ i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
+ a[i__ + i__ * a_dim1] = aii;
+ }
+/* L10: */
+ }
+ return 0;
+
+/* End of SGEQR2 */
+
+} /* sgeqr2_ */
diff --git a/SRC/sgeqrf.c b/SRC/sgeqrf.c
new file mode 100644
index 0000000..64c165b
--- /dev/null
+++ b/SRC/sgeqrf.c
@@ -0,0 +1,252 @@
+/* sgeqrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int sgeqrf_(integer *m, integer *n, real *a, integer *lda,
+ real *tau, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, k, ib, nb, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int sgeqr2_(integer *, integer *, real *, integer
+ *, real *, real *, integer *), slarfb_(char *, char *, char *,
+ char *, integer *, integer *, integer *, real *, integer *, real *
+, integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slarft_(char *, char *, integer *, integer *,
+ real *, integer *, real *, real *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGEQRF computes a QR factorization of a real M-by-N matrix A: */
+/* A = Q * R. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(M,N)-by-N upper trapezoidal matrix R (R is */
+/* upper triangular if m >= n); the elements below the diagonal, */
+/* with the array TAU, represent the orthogonal matrix Q as a */
+/* product of min(m,n) elementary reflectors (see Further */
+/* Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* For optimum performance LWORK >= N*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */
+/* and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb = ilaenv_(&c__1, "SGEQRF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ work[1] = (real) lwkopt;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGEQRF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ k = min(*m,*n);
+ if (k == 0) {
+ work[1] = 1.f;
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *n;
+ if (nb > 1 && nb < k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "SGEQRF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *n;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "SGEQRF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < k && nx < k) {
+
+/* Use blocked code initially */
+
+ i__1 = k - nx;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = k - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Compute the QR factorization of the current block */
+/* A(i:m,i:i+ib-1) */
+
+ i__3 = *m - i__ + 1;
+ sgeqr2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
+ 1], &iinfo);
+ if (i__ + ib <= *n) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__3 = *m - i__ + 1;
+ slarft_("Forward", "Columnwise", &i__3, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H' to A(i:m,i+ib:n) from the left */
+
+ i__3 = *m - i__ + 1;
+ i__4 = *n - i__ - ib + 1;
+ slarfb_("Left", "Transpose", "Forward", "Columnwise", &i__3, &
+ i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
+ ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &work[ib
+ + 1], &ldwork);
+ }
+/* L10: */
+ }
+ } else {
+ i__ = 1;
+ }
+
+/* Use unblocked code to factor the last or only block. */
+
+ if (i__ <= k) {
+ i__2 = *m - i__ + 1;
+ i__1 = *n - i__ + 1;
+ sgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
+, &iinfo);
+ }
+
+ work[1] = (real) iws;
+ return 0;
+
+/* End of SGEQRF */
+
+} /* sgeqrf_ */
diff --git a/SRC/sgerfs.c b/SRC/sgerfs.c
new file mode 100644
index 0000000..d053026
--- /dev/null
+++ b/SRC/sgerfs.c
@@ -0,0 +1,422 @@
+/* sgerfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b15 = -1.f;
+static real c_b17 = 1.f;
+
+/* Subroutine */ int sgerfs_(char *trans, integer *n, integer *nrhs, real *a,
+ integer *lda, real *af, integer *ldaf, integer *ipiv, real *b,
+ integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *
+ work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2, i__3;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ real s, xk;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ integer count;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), saxpy_(integer *, real *, real *, integer *, real *,
+ integer *), slacn2_(integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+ extern /* Subroutine */ int sgetrs_(char *, integer *, integer *, real *,
+ integer *, integer *, real *, integer *, integer *);
+ char transt[1];
+ real lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGERFS improves the computed solution to a system of linear */
+/* equations and provides error bounds and backward error estimates for */
+/* the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The original N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) REAL array, dimension (LDAF,N) */
+/* The factors L and U from the factorization A = P*L*U */
+/* as computed by SGETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from SGETRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) REAL array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by SGETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldx < max(1,*n)) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGERFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.f;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A, A**T, or A**H, depending on TRANS. */
+
+ scopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+ sgemv_(trans, n, n, &c_b15, &a[a_offset], lda, &x[j * x_dim1 + 1], &
+ c__1, &c_b17, &work[*n + 1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] = (r__1 = b[i__ + j * b_dim1], dabs(r__1));
+/* L30: */
+ }
+
+/* Compute abs(op(A))*abs(X) + abs(B). */
+
+ if (notran) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ work[i__] += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) *
+ xk;
+/* L40: */
+ }
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ s += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * (r__2 = x[
+ i__ + j * x_dim1], dabs(r__2));
+/* L60: */
+ }
+ work[k] += s;
+/* L70: */
+ }
+ }
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[
+ i__];
+ s = dmax(r__2,r__3);
+ } else {
+/* Computing MAX */
+ r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1)
+ / (work[i__] + safe1);
+ s = dmax(r__2,r__3);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ sgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[*n
+ + 1], n, info);
+ saxpy_(n, &c_b17, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
+ ;
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use SLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ slacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+ kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)**T). */
+
+ sgetrs_(transt, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &
+ work[*n + 1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L110: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L120: */
+ }
+ sgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &
+ work[*n + 1], n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], dabs(r__1));
+ lstres = dmax(r__2,r__3);
+/* L130: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of SGERFS */
+
+} /* sgerfs_ */
diff --git a/SRC/sgerfsx.c b/SRC/sgerfsx.c
new file mode 100644
index 0000000..5d10054
--- /dev/null
+++ b/SRC/sgerfsx.c
@@ -0,0 +1,663 @@
+/* sgerfsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int sgerfsx_(char *trans, char *equed, integer *n, integer *
+ nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv,
+ real *r__, real *c__, real *b, integer *ldb, real *x, integer *ldx,
+ real *rcond, real *berr, integer *n_err_bnds__, real *err_bnds_norm__,
+ real *err_bnds_comp__, integer *nparams, real *params, real *work,
+ integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real illrcond_thresh__, unstable_thresh__, err_lbnd__;
+ integer ref_type__;
+ extern integer ilatrans_(char *);
+ integer j;
+ real rcond_tmp__;
+ integer prec_type__, trans_type__;
+ extern doublereal sla_gercond__(char *, integer *, real *, integer *,
+ real *, integer *, integer *, integer *, real *, integer *, real *
+ , integer *, ftnlen);
+ real cwise_wrong__;
+ extern /* Subroutine */ int sla_gerfsx_extended__(integer *, integer *,
+ integer *, integer *, real *, integer *, real *, integer *,
+ integer *, logical *, real *, real *, integer *, real *, integer *
+ , real *, integer *, real *, real *, real *, real *, real *, real
+ *, real *, integer *, real *, real *, logical *, integer *);
+ char norm[1];
+ logical ignore_cwise__;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), sgecon_(
+ char *, integer *, real *, integer *, real *, real *, real *,
+ integer *, integer *);
+ logical colequ, notran, rowequ;
+ extern integer ilaprec_(char *);
+ integer ithresh, n_norms__;
+ real rthresh;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGERFSX improves the computed solution to a system of linear */
+/* equations and provides error bounds and backward error estimates */
+/* for the solution. In addition to normwise error bound, the code */
+/* provides maximum componentwise error bound if possible. See */
+/* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the */
+/* error bounds. */
+
+/* The original system of linear equations may have been equilibrated */
+/* before calling this routine, as described by arguments EQUED, R */
+/* and C below. In this case, the solution and error bounds returned */
+/* are for the original unequilibrated system. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* EQUED (input) CHARACTER*1 */
+/* Specifies the form of equilibration that was done to A */
+/* before calling this routine. This is needed to compute */
+/* the solution and error bounds correctly. */
+/* = 'N': No equilibration */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* The right hand side B has been changed accordingly. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The original N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) REAL array, dimension (LDAF,N) */
+/* The factors L and U from the factorization A = P*L*U */
+/* as computed by SGETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from SGETRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* R (input or output) REAL array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+/* If R is output, each element of R is a power of the radix. */
+/* If R is input, each element of R should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* C (input or output) REAL array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+/* If C is output, each element of C is a power of the radix. */
+/* If C is input, each element of C should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) REAL array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by SGETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) REAL array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) REAL array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check the input parameters. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ trans_type__ = ilatrans_(trans);
+ ref_type__ = 1;
+ if (*nparams >= 1) {
+ if (params[1] < 0.f) {
+ params[1] = 1.f;
+ } else {
+ ref_type__ = params[1];
+ }
+ }
+
+/* Set default parameters. */
+
+ illrcond_thresh__ = (real) (*n) * slamch_("Epsilon");
+ ithresh = 10;
+ rthresh = .5f;
+ unstable_thresh__ = .25f;
+ ignore_cwise__ = FALSE_;
+
+ if (*nparams >= 2) {
+ if (params[2] < 0.f) {
+ params[2] = (real) ithresh;
+ } else {
+ ithresh = (integer) params[2];
+ }
+ }
+ if (*nparams >= 3) {
+ if (params[3] < 0.f) {
+ if (ignore_cwise__) {
+ params[3] = 0.f;
+ } else {
+ params[3] = 1.f;
+ }
+ } else {
+ ignore_cwise__ = params[3] == 0.f;
+ }
+ }
+ if (ref_type__ == 0 || *n_err_bnds__ == 0) {
+ n_norms__ = 0;
+ } else if (ignore_cwise__) {
+ n_norms__ = 1;
+ } else {
+ n_norms__ = 2;
+ }
+
+ notran = lsame_(trans, "N");
+ rowequ = lsame_(equed, "R") || lsame_(equed, "B");
+ colequ = lsame_(equed, "C") || lsame_(equed, "B");
+
+/* Test input parameters. */
+
+ if (trans_type__ == -1) {
+ *info = -1;
+ } else if (! rowequ && ! colequ && ! lsame_(equed, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -13;
+ } else if (*ldx < max(1,*n)) {
+ *info = -15;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGERFSX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *nrhs == 0) {
+ *rcond = 1.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 0.f;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.f;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.f;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.f;
+ }
+ }
+ return 0;
+ }
+
+/* Default to failure. */
+
+ *rcond = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 1.f;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.f;
+ }
+ }
+
+/* Compute the norm of A and the reciprocal of the condition */
+/* number of A. */
+
+ if (notran) {
+ *(unsigned char *)norm = 'I';
+ } else {
+ *(unsigned char *)norm = '1';
+ }
+ anorm = slange_(norm, n, n, &a[a_offset], lda, &work[1]);
+ sgecon_(norm, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &iwork[1],
+ info);
+
+/* Perform refinement on each right-hand side */
+
+ if (ref_type__ != 0) {
+ prec_type__ = ilaprec_("D");
+ if (notran) {
+ sla_gerfsx_extended__(&prec_type__, &trans_type__, n, nrhs, &a[
+ a_offset], lda, &af[af_offset], ldaf, &ipiv[1], &colequ, &
+ c__[1], &b[b_offset], ldb, &x[x_offset], ldx, &berr[1], &
+ n_norms__, &err_bnds_norm__[err_bnds_norm_offset], &
+ err_bnds_comp__[err_bnds_comp_offset], &work[*n + 1], &
+ work[1], &work[(*n << 1) + 1], &work[1], rcond, &ithresh,
+ &rthresh, &unstable_thresh__, &ignore_cwise__, info);
+ } else {
+ sla_gerfsx_extended__(&prec_type__, &trans_type__, n, nrhs, &a[
+ a_offset], lda, &af[af_offset], ldaf, &ipiv[1], &rowequ, &
+ r__[1], &b[b_offset], ldb, &x[x_offset], ldx, &berr[1], &
+ n_norms__, &err_bnds_norm__[err_bnds_norm_offset], &
+ err_bnds_comp__[err_bnds_comp_offset], &work[*n + 1], &
+ work[1], &work[(*n << 1) + 1], &work[1], rcond, &ithresh,
+ &rthresh, &unstable_thresh__, &ignore_cwise__, info);
+ }
+ }
+/* Computing MAX */
+ r__1 = 10.f, r__2 = sqrt((real) (*n));
+ err_lbnd__ = dmax(r__1,r__2) * slamch_("Epsilon");
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {
+
+/* Compute scaled normwise condition number cond(A*C). */
+
+ if (colequ && notran) {
+ rcond_tmp__ = sla_gercond__(trans, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &c_n1, &c__[1], info, &work[1]
+ , &iwork[1], (ftnlen)1);
+ } else if (rowequ && ! notran) {
+ rcond_tmp__ = sla_gercond__(trans, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &c_n1, &r__[1], info, &work[1]
+ , &iwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = sla_gercond__(trans, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &c__0, &r__[1], info, &work[1]
+ , &iwork[1], (ftnlen)1);
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1
+ << 1)] > 1.f) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 0.f;
+ if (*info <= *n) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {
+
+/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
+/* each right-hand side using the current solution as an estimate of */
+/* the true solution. If the componentwise error estimate is too */
+/* large, then the solution is a lousy estimate of truth and the */
+/* estimated RCOND may be too optimistic. To avoid misleading users, */
+/* the inverse condition number is set to 0.0 when the estimated */
+/* cwise error is at least CWISE_WRONG. */
+
+ cwise_wrong__ = sqrt(slamch_("Epsilon"));
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ cwise_wrong__) {
+ rcond_tmp__ = sla_gercond__(trans, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &c__1, &x[j * x_dim1 + 1],
+ info, &work[1], &iwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = 0.f;
+ }
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1
+ << 1)] > 1.f) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 0.f;
+ if (params[3] == 1.f && *info < *n + j) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SGERFSX */
+
+} /* sgerfsx_ */
diff --git a/SRC/sgerq2.c b/SRC/sgerq2.c
new file mode 100644
index 0000000..9a902f0
--- /dev/null
+++ b/SRC/sgerq2.c
@@ -0,0 +1,155 @@
+/* sgerq2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sgerq2_(integer *m, integer *n, real *a, integer *lda,
+ real *tau, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, k;
+ real aii;
+ extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *), xerbla_(
+ char *, integer *), slarfp_(integer *, real *, real *,
+ integer *, real *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGERQ2 computes an RQ factorization of a real m by n matrix A: */
+/* A = R * Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the m by n matrix A. */
+/* On exit, if m <= n, the upper triangle of the subarray */
+/* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R; */
+/* if m >= n, the elements on and above the (m-n)-th subdiagonal */
+/* contain the m by n upper trapezoidal matrix R; the remaining */
+/* elements, with the array TAU, represent the orthogonal matrix */
+/* Q as a product of elementary reflectors (see Further */
+/* Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace) REAL array, dimension (M) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in */
+/* A(m-k+i,1:n-k+i-1), and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGERQ2", &i__1);
+ return 0;
+ }
+
+ k = min(*m,*n);
+
+ for (i__ = k; i__ >= 1; --i__) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* A(m-k+i,1:n-k+i-1) */
+
+ i__1 = *n - k + i__;
+ slarfp_(&i__1, &a[*m - k + i__ + (*n - k + i__) * a_dim1], &a[*m - k
+ + i__ + a_dim1], lda, &tau[i__]);
+
+/* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right */
+
+ aii = a[*m - k + i__ + (*n - k + i__) * a_dim1];
+ a[*m - k + i__ + (*n - k + i__) * a_dim1] = 1.f;
+ i__1 = *m - k + i__ - 1;
+ i__2 = *n - k + i__;
+ slarf_("Right", &i__1, &i__2, &a[*m - k + i__ + a_dim1], lda, &tau[
+ i__], &a[a_offset], lda, &work[1]);
+ a[*m - k + i__ + (*n - k + i__) * a_dim1] = aii;
+/* L10: */
+ }
+ return 0;
+
+/* End of SGERQ2 */
+
+} /* sgerq2_ */
diff --git a/SRC/sgerqf.c b/SRC/sgerqf.c
new file mode 100644
index 0000000..749609e
--- /dev/null
+++ b/SRC/sgerqf.c
@@ -0,0 +1,272 @@
+/* sgerqf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int sgerqf_(integer *m, integer *n, real *a, integer *lda,
+ real *tau, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, k, ib, nb, ki, kk, mu, nu, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int sgerq2_(integer *, integer *, real *, integer
+ *, real *, real *, integer *), slarfb_(char *, char *, char *,
+ char *, integer *, integer *, integer *, real *, integer *, real *
+, integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slarft_(char *, char *, integer *, integer *,
+ real *, integer *, real *, real *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGERQF computes an RQ factorization of a real M-by-N matrix A: */
+/* A = R * Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, */
+/* if m <= n, the upper triangle of the subarray */
+/* A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R; */
+/* if m >= n, the elements on and above the (m-n)-th subdiagonal */
+/* contain the M-by-N upper trapezoidal matrix R; */
+/* the remaining elements, with the array TAU, represent the */
+/* orthogonal matrix Q as a product of min(m,n) elementary */
+/* reflectors (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M). */
+/* For optimum performance LWORK >= M*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in */
+/* A(m-k+i,1:n-k+i-1), and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ } else if (*lwork < max(1,*m) && ! lquery) {
+ *info = -7;
+ }
+
+ if (*info == 0) {
+ k = min(*m,*n);
+ if (k == 0) {
+ lwkopt = 1;
+ } else {
+ nb = ilaenv_(&c__1, "SGERQF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = *m * nb;
+ work[1] = (real) lwkopt;
+ }
+ work[1] = (real) lwkopt;
+
+ if (*lwork < max(1,*m) && ! lquery) {
+ *info = -7;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGERQF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (k == 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 1;
+ iws = *m;
+ if (nb > 1 && nb < k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "SGERQF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *m;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "SGERQF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < k && nx < k) {
+
+/* Use blocked code initially. */
+/* The last kk rows are handled by the block method. */
+
+ ki = (k - nx - 1) / nb * nb;
+/* Computing MIN */
+ i__1 = k, i__2 = ki + nb;
+ kk = min(i__1,i__2);
+
+ i__1 = k - kk + 1;
+ i__2 = -nb;
+ for (i__ = k - kk + ki + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__
+ += i__2) {
+/* Computing MIN */
+ i__3 = k - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Compute the RQ factorization of the current block */
+/* A(m-k+i:m-k+i+ib-1,1:n-k+i+ib-1) */
+
+ i__3 = *n - k + i__ + ib - 1;
+ sgerq2_(&ib, &i__3, &a[*m - k + i__ + a_dim1], lda, &tau[i__], &
+ work[1], &iinfo);
+ if (*m - k + i__ > 1) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__3 = *n - k + i__ + ib - 1;
+ slarft_("Backward", "Rowwise", &i__3, &ib, &a[*m - k + i__ +
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H to A(1:m-k+i-1,1:n-k+i+ib-1) from the right */
+
+ i__3 = *m - k + i__ - 1;
+ i__4 = *n - k + i__ + ib - 1;
+ slarfb_("Right", "No transpose", "Backward", "Rowwise", &i__3,
+ &i__4, &ib, &a[*m - k + i__ + a_dim1], lda, &work[1],
+ &ldwork, &a[a_offset], lda, &work[ib + 1], &ldwork);
+ }
+/* L10: */
+ }
+ mu = *m - k + i__ + nb - 1;
+ nu = *n - k + i__ + nb - 1;
+ } else {
+ mu = *m;
+ nu = *n;
+ }
+
+/* Use unblocked code to factor the last or only block */
+
+ if (mu > 0 && nu > 0) {
+ sgerq2_(&mu, &nu, &a[a_offset], lda, &tau[1], &work[1], &iinfo);
+ }
+
+ work[1] = (real) iws;
+ return 0;
+
+/* End of SGERQF */
+
+} /* sgerqf_ */
diff --git a/SRC/sgesc2.c b/SRC/sgesc2.c
new file mode 100644
index 0000000..4afd793
--- /dev/null
+++ b/SRC/sgesc2.c
@@ -0,0 +1,176 @@
+/* sgesc2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int sgesc2_(integer *n, real *a, integer *lda, real *rhs,
+ integer *ipiv, integer *jpiv, real *scale)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer i__, j;
+ real eps, temp;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ real bignum;
+ extern integer isamax_(integer *, real *, integer *);
+ extern /* Subroutine */ int slaswp_(integer *, real *, integer *, integer
+ *, integer *, integer *, integer *);
+ real smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGESC2 solves a system of linear equations */
+
+/* A * X = scale* RHS */
+
+/* with a general N-by-N matrix A using the LU factorization with */
+/* complete pivoting computed by SGETC2. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* On entry, the LU part of the factorization of the n-by-n */
+/* matrix A computed by SGETC2: A = P * L * U * Q */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1, N). */
+
+/* RHS (input/output) REAL array, dimension (N). */
+/* On entry, the right hand side vector b. */
+/* On exit, the solution vector X. */
+
+/* IPIV (input) INTEGER array, dimension (N). */
+/* The pivot indices; for 1 <= i <= N, row i of the */
+/* matrix has been interchanged with row IPIV(i). */
+
+/* JPIV (input) INTEGER array, dimension (N). */
+/* The pivot indices; for 1 <= j <= N, column j of the */
+/* matrix has been interchanged with column JPIV(j). */
+
+/* SCALE (output) REAL */
+/* On exit, SCALE contains the scale factor. SCALE is chosen */
+/* 0 <= SCALE <= 1 to prevent owerflow in the solution. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Set constant to control owerflow */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --rhs;
+ --ipiv;
+ --jpiv;
+
+ /* Function Body */
+ eps = slamch_("P");
+ smlnum = slamch_("S") / eps;
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Apply permutations IPIV to RHS */
+
+ i__1 = *n - 1;
+ slaswp_(&c__1, &rhs[1], lda, &c__1, &i__1, &ipiv[1], &c__1);
+
+/* Solve for L part */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ rhs[j] -= a[j + i__ * a_dim1] * rhs[i__];
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Solve for U part */
+
+ *scale = 1.f;
+
+/* Check for scaling */
+
+ i__ = isamax_(n, &rhs[1], &c__1);
+ if (smlnum * 2.f * (r__1 = rhs[i__], dabs(r__1)) > (r__2 = a[*n + *n *
+ a_dim1], dabs(r__2))) {
+ temp = .5f / (r__1 = rhs[i__], dabs(r__1));
+ sscal_(n, &temp, &rhs[1], &c__1);
+ *scale *= temp;
+ }
+
+ for (i__ = *n; i__ >= 1; --i__) {
+ temp = 1.f / a[i__ + i__ * a_dim1];
+ rhs[i__] *= temp;
+ i__1 = *n;
+ for (j = i__ + 1; j <= i__1; ++j) {
+ rhs[i__] -= rhs[j] * (a[i__ + j * a_dim1] * temp);
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Apply permutations JPIV to the solution (RHS) */
+
+ i__1 = *n - 1;
+ slaswp_(&c__1, &rhs[1], lda, &c__1, &i__1, &jpiv[1], &c_n1);
+ return 0;
+
+/* End of SGESC2 */
+
+} /* sgesc2_ */
diff --git a/SRC/sgesdd.c b/SRC/sgesdd.c
new file mode 100644
index 0000000..b9680da
--- /dev/null
+++ b/SRC/sgesdd.c
@@ -0,0 +1,1611 @@
+/* sgesdd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static real c_b227 = 0.f;
+static real c_b248 = 1.f;
+
+/* Subroutine */ int sgesdd_(char *jobz, integer *m, integer *n, real *a,
+ integer *lda, real *s, real *u, integer *ldu, real *vt, integer *ldvt,
+ real *work, integer *lwork, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
+ i__2, i__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, ie, il, ir, iu, blk;
+ real dum[1], eps;
+ integer ivt, iscl;
+ real anrm;
+ integer idum[1], ierr, itau;
+ extern logical lsame_(char *, char *);
+ integer chunk;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ integer minmn, wrkbl, itaup, itauq, mnthr;
+ logical wntqa;
+ integer nwork;
+ logical wntqn, wntqo, wntqs;
+ integer bdspac;
+ extern /* Subroutine */ int sbdsdc_(char *, char *, integer *, real *,
+ real *, real *, integer *, real *, integer *, real *, integer *,
+ real *, integer *, integer *), sgebrd_(integer *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ real *, integer *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ real bignum;
+ extern /* Subroutine */ int sgelqf_(integer *, integer *, real *, integer
+ *, real *, real *, integer *, integer *), slascl_(char *, integer
+ *, integer *, real *, real *, integer *, integer *, real *,
+ integer *, integer *), sgeqrf_(integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *), slacpy_(char
+ *, integer *, integer *, real *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *,
+ real *, integer *), sorgbr_(char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, integer *
+);
+ integer ldwrkl;
+ extern /* Subroutine */ int sormbr_(char *, char *, char *, integer *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, real *, integer *, integer *);
+ integer ldwrkr, minwrk, ldwrku, maxwrk;
+ extern /* Subroutine */ int sorglq_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *);
+ integer ldwkvt;
+ real smlnum;
+ logical wntqas;
+ extern /* Subroutine */ int sorgqr_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *);
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2.1) -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/* March 2009 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGESDD computes the singular value decomposition (SVD) of a real */
+/* M-by-N matrix A, optionally computing the left and right singular */
+/* vectors. If singular vectors are desired, it uses a */
+/* divide-and-conquer algorithm. */
+
+/* The SVD is written */
+
+/* A = U * SIGMA * transpose(V) */
+
+/* where SIGMA is an M-by-N matrix which is zero except for its */
+/* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and */
+/* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA */
+/* are the singular values of A; they are real and non-negative, and */
+/* are returned in descending order. The first min(m,n) columns of */
+/* U and V are the left and right singular vectors of A. */
+
+/* Note that the routine returns VT = V**T, not V. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* Specifies options for computing all or part of the matrix U: */
+/* = 'A': all M columns of U and all N rows of V**T are */
+/* returned in the arrays U and VT; */
+/* = 'S': the first min(M,N) columns of U and the first */
+/* min(M,N) rows of V**T are returned in the arrays U */
+/* and VT; */
+/* = 'O': If M >= N, the first N columns of U are overwritten */
+/* on the array A and all rows of V**T are returned in */
+/* the array VT; */
+/* otherwise, all columns of U are returned in the */
+/* array U and the first M rows of V**T are overwritten */
+/* in the array A; */
+/* = 'N': no columns of U or rows of V**T are computed. */
+
+/* M (input) INTEGER */
+/* The number of rows of the input matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the input matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, */
+/* if JOBZ = 'O', A is overwritten with the first N columns */
+/* of U (the left singular vectors, stored */
+/* columnwise) if M >= N; */
+/* A is overwritten with the first M rows */
+/* of V**T (the right singular vectors, stored */
+/* rowwise) otherwise. */
+/* if JOBZ .ne. 'O', the contents of A are destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* S (output) REAL array, dimension (min(M,N)) */
+/* The singular values of A, sorted so that S(i) >= S(i+1). */
+
+/* U (output) REAL array, dimension (LDU,UCOL) */
+/* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N; */
+/* UCOL = min(M,N) if JOBZ = 'S'. */
+/* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M */
+/* orthogonal matrix U; */
+/* if JOBZ = 'S', U contains the first min(M,N) columns of U */
+/* (the left singular vectors, stored columnwise); */
+/* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= 1; if */
+/* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M. */
+
+/* VT (output) REAL array, dimension (LDVT,N) */
+/* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the */
+/* N-by-N orthogonal matrix V**T; */
+/* if JOBZ = 'S', VT contains the first min(M,N) rows of */
+/* V**T (the right singular vectors, stored rowwise); */
+/* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. LDVT >= 1; if */
+/* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N; */
+/* if JOBZ = 'S', LDVT >= min(M,N). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK; */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= 1. */
+/* If JOBZ = 'N', */
+/* LWORK >= 3*min(M,N) + max(max(M,N),6*min(M,N)). */
+/* If JOBZ = 'O', */
+/* LWORK >= 3*min(M,N) + */
+/* max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)). */
+/* If JOBZ = 'S' or 'A' */
+/* LWORK >= 3*min(M,N) + */
+/* max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)). */
+/* For good performance, LWORK should generally be larger. */
+/* If LWORK = -1 but other input arguments are legal, WORK(1) */
+/* returns the optimal LWORK. */
+
+/* IWORK (workspace) INTEGER array, dimension (8*min(M,N)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: SBDSDC did not converge, updating process failed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ minmn = min(*m,*n);
+ wntqa = lsame_(jobz, "A");
+ wntqs = lsame_(jobz, "S");
+ wntqas = wntqa || wntqs;
+ wntqo = lsame_(jobz, "O");
+ wntqn = lsame_(jobz, "N");
+ lquery = *lwork == -1;
+
+ if (! (wntqa || wntqs || wntqo || wntqn)) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldu < 1 || wntqas && *ldu < *m || wntqo && *m < *n && *ldu < *
+ m) {
+ *info = -8;
+ } else if (*ldvt < 1 || wntqa && *ldvt < *n || wntqs && *ldvt < minmn ||
+ wntqo && *m >= *n && *ldvt < *n) {
+ *info = -10;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ if (*info == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ if (*m >= *n && minmn > 0) {
+
+/* Compute space needed for SBDSDC */
+
+ mnthr = (integer) (minmn * 11.f / 6.f);
+ if (wntqn) {
+ bdspac = *n * 7;
+ } else {
+ bdspac = *n * 3 * *n + (*n << 2);
+ }
+ if (*m >= mnthr) {
+ if (wntqn) {
+
+/* Path 1 (M much larger than N, JOBZ='N') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *n;
+ maxwrk = max(i__1,i__2);
+ minwrk = bdspac + *n;
+ } else if (wntqo) {
+
+/* Path 2 (M much larger than N, JOBZ='O') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n + *n * ilaenv_(&c__1, "SORGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "SORMBR"
+, "QLN", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "SORMBR"
+, "PRT", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *n * 3;
+ wrkbl = max(i__1,i__2);
+ maxwrk = wrkbl + (*n << 1) * *n;
+ minwrk = bdspac + (*n << 1) * *n + *n * 3;
+ } else if (wntqs) {
+
+/* Path 3 (M much larger than N, JOBZ='S') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n + *n * ilaenv_(&c__1, "SORGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "SORMBR"
+, "QLN", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "SORMBR"
+, "PRT", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *n * 3;
+ wrkbl = max(i__1,i__2);
+ maxwrk = wrkbl + *n * *n;
+ minwrk = bdspac + *n * *n + *n * 3;
+ } else if (wntqa) {
+
+/* Path 4 (M much larger than N, JOBZ='A') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n + *m * ilaenv_(&c__1, "SORGQR",
+ " ", m, m, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "SORMBR"
+, "QLN", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "SORMBR"
+, "PRT", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *n * 3;
+ wrkbl = max(i__1,i__2);
+ maxwrk = wrkbl + *n * *n;
+ minwrk = bdspac + *n * *n + *n * 3;
+ }
+ } else {
+
+/* Path 5 (M at least N, but not much larger) */
+
+ wrkbl = *n * 3 + (*m + *n) * ilaenv_(&c__1, "SGEBRD", " ", m,
+ n, &c_n1, &c_n1);
+ if (wntqn) {
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *n * 3;
+ maxwrk = max(i__1,i__2);
+ minwrk = *n * 3 + max(*m,bdspac);
+ } else if (wntqo) {
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "SORMBR"
+, "QLN", m, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "SORMBR"
+, "PRT", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *n * 3;
+ wrkbl = max(i__1,i__2);
+ maxwrk = wrkbl + *m * *n;
+/* Computing MAX */
+ i__1 = *m, i__2 = *n * *n + bdspac;
+ minwrk = *n * 3 + max(i__1,i__2);
+ } else if (wntqs) {
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "SORMBR"
+, "QLN", m, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "SORMBR"
+, "PRT", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *n * 3;
+ maxwrk = max(i__1,i__2);
+ minwrk = *n * 3 + max(*m,bdspac);
+ } else if (wntqa) {
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *m * ilaenv_(&c__1, "SORMBR"
+, "QLN", m, m, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n * 3 + *n * ilaenv_(&c__1, "SORMBR"
+, "PRT", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = bdspac + *n * 3;
+ maxwrk = max(i__1,i__2);
+ minwrk = *n * 3 + max(*m,bdspac);
+ }
+ }
+ } else if (minmn > 0) {
+
+/* Compute space needed for SBDSDC */
+
+ mnthr = (integer) (minmn * 11.f / 6.f);
+ if (wntqn) {
+ bdspac = *m * 7;
+ } else {
+ bdspac = *m * 3 * *m + (*m << 2);
+ }
+ if (*n >= mnthr) {
+ if (wntqn) {
+
+/* Path 1t (N much larger than M, JOBZ='N') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *m;
+ maxwrk = max(i__1,i__2);
+ minwrk = bdspac + *m;
+ } else if (wntqo) {
+
+/* Path 2t (N much larger than M, JOBZ='O') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m + *m * ilaenv_(&c__1, "SORGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR"
+, "QLN", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR"
+, "PRT", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *m * 3;
+ wrkbl = max(i__1,i__2);
+ maxwrk = wrkbl + (*m << 1) * *m;
+ minwrk = bdspac + (*m << 1) * *m + *m * 3;
+ } else if (wntqs) {
+
+/* Path 3t (N much larger than M, JOBZ='S') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m + *m * ilaenv_(&c__1, "SORGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR"
+, "QLN", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR"
+, "PRT", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *m * 3;
+ wrkbl = max(i__1,i__2);
+ maxwrk = wrkbl + *m * *m;
+ minwrk = bdspac + *m * *m + *m * 3;
+ } else if (wntqa) {
+
+/* Path 4t (N much larger than M, JOBZ='A') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m + *n * ilaenv_(&c__1, "SORGLQ",
+ " ", n, n, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR"
+, "QLN", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR"
+, "PRT", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *m * 3;
+ wrkbl = max(i__1,i__2);
+ maxwrk = wrkbl + *m * *m;
+ minwrk = bdspac + *m * *m + *m * 3;
+ }
+ } else {
+
+/* Path 5t (N greater than M, but not much larger) */
+
+ wrkbl = *m * 3 + (*m + *n) * ilaenv_(&c__1, "SGEBRD", " ", m,
+ n, &c_n1, &c_n1);
+ if (wntqn) {
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *m * 3;
+ maxwrk = max(i__1,i__2);
+ minwrk = *m * 3 + max(*n,bdspac);
+ } else if (wntqo) {
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR"
+, "QLN", m, m, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR"
+, "PRT", m, n, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *m * 3;
+ wrkbl = max(i__1,i__2);
+ maxwrk = wrkbl + *m * *n;
+/* Computing MAX */
+ i__1 = *n, i__2 = *m * *m + bdspac;
+ minwrk = *m * 3 + max(i__1,i__2);
+ } else if (wntqs) {
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR"
+, "QLN", m, m, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR"
+, "PRT", m, n, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *m * 3;
+ maxwrk = max(i__1,i__2);
+ minwrk = *m * 3 + max(*n,bdspac);
+ } else if (wntqa) {
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR"
+, "QLN", m, m, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m * 3 + *m * ilaenv_(&c__1, "SORMBR"
+, "PRT", n, n, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = bdspac + *m * 3;
+ maxwrk = max(i__1,i__2);
+ minwrk = *m * 3 + max(*n,bdspac);
+ }
+ }
+ }
+ maxwrk = max(maxwrk,minwrk);
+ work[1] = (real) maxwrk;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGESDD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ smlnum = sqrt(slamch_("S")) / eps;
+ bignum = 1.f / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = slange_("M", m, n, &a[a_offset], lda, dum);
+ iscl = 0;
+ if (anrm > 0.f && anrm < smlnum) {
+ iscl = 1;
+ slascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, &
+ ierr);
+ } else if (anrm > bignum) {
+ iscl = 1;
+ slascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+ if (*m >= *n) {
+
+/* A has at least as many rows as columns. If A has sufficiently */
+/* more rows than columns, first reduce using the QR */
+/* decomposition (if sufficient workspace available) */
+
+ if (*m >= mnthr) {
+
+ if (wntqn) {
+
+/* Path 1 (M much larger than N, JOBZ='N') */
+/* No singular vectors to be computed */
+
+ itau = 1;
+ nwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__1, &ierr);
+
+/* Zero out below R */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ slaset_("L", &i__1, &i__2, &c_b227, &c_b227, &a[a_dim1 + 2],
+ lda);
+ ie = 1;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize R in A */
+/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__1, &ierr);
+ nwork = ie + *n;
+
+/* Perform bidiagonal SVD, computing singular values only */
+/* (Workspace: need N+BDSPAC) */
+
+ sbdsdc_("U", "N", n, &s[1], &work[ie], dum, &c__1, dum, &c__1,
+ dum, idum, &work[nwork], &iwork[1], info);
+
+ } else if (wntqo) {
+
+/* Path 2 (M much larger than N, JOBZ = 'O') */
+/* N left singular vectors to be overwritten on A and */
+/* N right singular vectors to be computed in VT */
+
+ ir = 1;
+
+/* WORK(IR) is LDWRKR by N */
+
+ if (*lwork >= *lda * *n + *n * *n + *n * 3 + bdspac) {
+ ldwrkr = *lda;
+ } else {
+ ldwrkr = (*lwork - *n * *n - *n * 3 - bdspac) / *n;
+ }
+ itau = ir + ldwrkr * *n;
+ nwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__1, &ierr);
+
+/* Copy R to WORK(IR), zeroing out below it */
+
+ slacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr);
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ slaset_("L", &i__1, &i__2, &c_b227, &c_b227, &work[ir + 1], &
+ ldwrkr);
+
+/* Generate Q in A */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[nwork],
+ &i__1, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize R in VT, copying result to WORK(IR) */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__1, &ierr);
+
+/* WORK(IU) is N by N */
+
+ iu = nwork;
+ nwork = iu + *n * *n;
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in WORK(IU) and computing right */
+/* singular vectors of bidiagonal matrix in VT */
+/* (Workspace: need N+N*N+BDSPAC) */
+
+ sbdsdc_("U", "I", n, &s[1], &work[ie], &work[iu], n, &vt[
+ vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1],
+ info);
+
+/* Overwrite WORK(IU) by left singular vectors of R */
+/* and VT by right singular vectors of R */
+/* (Workspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sormbr_("Q", "L", "N", n, n, n, &work[ir], &ldwrkr, &work[
+ itauq], &work[iu], n, &work[nwork], &i__1, &ierr);
+ i__1 = *lwork - nwork + 1;
+ sormbr_("P", "R", "T", n, n, n, &work[ir], &ldwrkr, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, &
+ ierr);
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IU), storing result in WORK(IR) and copying to A */
+/* (Workspace: need 2*N*N, prefer N*N+M*N) */
+
+ i__1 = *m;
+ i__2 = ldwrkr;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *m - i__ + 1;
+ chunk = min(i__3,ldwrkr);
+ sgemm_("N", "N", &chunk, n, n, &c_b248, &a[i__ + a_dim1],
+ lda, &work[iu], n, &c_b227, &work[ir], &ldwrkr);
+ slacpy_("F", &chunk, n, &work[ir], &ldwrkr, &a[i__ +
+ a_dim1], lda);
+/* L10: */
+ }
+
+ } else if (wntqs) {
+
+/* Path 3 (M much larger than N, JOBZ='S') */
+/* N left singular vectors to be computed in U and */
+/* N right singular vectors to be computed in VT */
+
+ ir = 1;
+
+/* WORK(IR) is N by N */
+
+ ldwrkr = *n;
+ itau = ir + ldwrkr * *n;
+ nwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__2, &ierr);
+
+/* Copy R to WORK(IR), zeroing out below it */
+
+ slacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr);
+ i__2 = *n - 1;
+ i__1 = *n - 1;
+ slaset_("L", &i__2, &i__1, &c_b227, &c_b227, &work[ir + 1], &
+ ldwrkr);
+
+/* Generate Q in A */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ sorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[nwork],
+ &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IR) */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ sgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__2, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagoal matrix in U and computing right singular */
+/* vectors of bidiagonal matrix in VT */
+/* (Workspace: need N+BDSPAC) */
+
+ sbdsdc_("U", "I", n, &s[1], &work[ie], &u[u_offset], ldu, &vt[
+ vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1],
+ info);
+
+/* Overwrite U by left singular vectors of R and VT */
+/* by right singular vectors of R */
+/* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ sormbr_("Q", "L", "N", n, n, n, &work[ir], &ldwrkr, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr);
+
+ i__2 = *lwork - nwork + 1;
+ sormbr_("P", "R", "T", n, n, n, &work[ir], &ldwrkr, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, &
+ ierr);
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IR), storing result in U */
+/* (Workspace: need N*N) */
+
+ slacpy_("F", n, n, &u[u_offset], ldu, &work[ir], &ldwrkr);
+ sgemm_("N", "N", m, n, n, &c_b248, &a[a_offset], lda, &work[
+ ir], &ldwrkr, &c_b227, &u[u_offset], ldu);
+
+ } else if (wntqa) {
+
+/* Path 4 (M much larger than N, JOBZ='A') */
+/* M left singular vectors to be computed in U and */
+/* N right singular vectors to be computed in VT */
+
+ iu = 1;
+
+/* WORK(IU) is N by N */
+
+ ldwrku = *n;
+ itau = iu + ldwrku * *n;
+ nwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__2, &ierr);
+ slacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu);
+
+/* Generate Q in U */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+ i__2 = *lwork - nwork + 1;
+ sorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &work[nwork],
+ &i__2, &ierr);
+
+/* Produce R in A, zeroing out other entries */
+
+ i__2 = *n - 1;
+ i__1 = *n - 1;
+ slaset_("L", &i__2, &i__1, &c_b227, &c_b227, &a[a_dim1 + 2],
+ lda);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize R in A */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ sgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__2, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in WORK(IU) and computing right */
+/* singular vectors of bidiagonal matrix in VT */
+/* (Workspace: need N+N*N+BDSPAC) */
+
+ sbdsdc_("U", "I", n, &s[1], &work[ie], &work[iu], n, &vt[
+ vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1],
+ info);
+
+/* Overwrite WORK(IU) by left singular vectors of R and VT */
+/* by right singular vectors of R */
+/* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ sormbr_("Q", "L", "N", n, n, n, &a[a_offset], lda, &work[
+ itauq], &work[iu], &ldwrku, &work[nwork], &i__2, &
+ ierr);
+ i__2 = *lwork - nwork + 1;
+ sormbr_("P", "R", "T", n, n, n, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, &
+ ierr);
+
+/* Multiply Q in U by left singular vectors of R in */
+/* WORK(IU), storing result in A */
+/* (Workspace: need N*N) */
+
+ sgemm_("N", "N", m, n, n, &c_b248, &u[u_offset], ldu, &work[
+ iu], &ldwrku, &c_b227, &a[a_offset], lda);
+
+/* Copy left singular vectors of A from A to U */
+
+ slacpy_("F", m, n, &a[a_offset], lda, &u[u_offset], ldu);
+
+ }
+
+ } else {
+
+/* M .LT. MNTHR */
+
+/* Path 5 (M at least N, but not much larger) */
+/* Reduce to bidiagonal form without QR decomposition */
+
+ ie = 1;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize A */
+/* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ sgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
+ work[itaup], &work[nwork], &i__2, &ierr);
+ if (wntqn) {
+
+/* Perform bidiagonal SVD, only computing singular values */
+/* (Workspace: need N+BDSPAC) */
+
+ sbdsdc_("U", "N", n, &s[1], &work[ie], dum, &c__1, dum, &c__1,
+ dum, idum, &work[nwork], &iwork[1], info);
+ } else if (wntqo) {
+ iu = nwork;
+ if (*lwork >= *m * *n + *n * 3 + bdspac) {
+
+/* WORK( IU ) is M by N */
+
+ ldwrku = *m;
+ nwork = iu + ldwrku * *n;
+ slaset_("F", m, n, &c_b227, &c_b227, &work[iu], &ldwrku);
+ } else {
+
+/* WORK( IU ) is N by N */
+
+ ldwrku = *n;
+ nwork = iu + ldwrku * *n;
+
+/* WORK(IR) is LDWRKR by N */
+
+ ir = nwork;
+ ldwrkr = (*lwork - *n * *n - *n * 3) / *n;
+ }
+ nwork = iu + ldwrku * *n;
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in WORK(IU) and computing right */
+/* singular vectors of bidiagonal matrix in VT */
+/* (Workspace: need N+N*N+BDSPAC) */
+
+ sbdsdc_("U", "I", n, &s[1], &work[ie], &work[iu], &ldwrku, &
+ vt[vt_offset], ldvt, dum, idum, &work[nwork], &iwork[
+ 1], info);
+
+/* Overwrite VT by right singular vectors of A */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ sormbr_("P", "R", "T", n, n, n, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, &
+ ierr);
+
+ if (*lwork >= *m * *n + *n * 3 + bdspac) {
+
+/* Overwrite WORK(IU) by left singular vectors of A */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ sormbr_("Q", "L", "N", m, n, n, &a[a_offset], lda, &work[
+ itauq], &work[iu], &ldwrku, &work[nwork], &i__2, &
+ ierr);
+
+/* Copy left singular vectors of A from WORK(IU) to A */
+
+ slacpy_("F", m, n, &work[iu], &ldwrku, &a[a_offset], lda);
+ } else {
+
+/* Generate Q in A */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ sorgbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], &
+ work[nwork], &i__2, &ierr);
+
+/* Multiply Q in A by left singular vectors of */
+/* bidiagonal matrix in WORK(IU), storing result in */
+/* WORK(IR) and copying to A */
+/* (Workspace: need 2*N*N, prefer N*N+M*N) */
+
+ i__2 = *m;
+ i__1 = ldwrkr;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
+ i__1) {
+/* Computing MIN */
+ i__3 = *m - i__ + 1;
+ chunk = min(i__3,ldwrkr);
+ sgemm_("N", "N", &chunk, n, n, &c_b248, &a[i__ +
+ a_dim1], lda, &work[iu], &ldwrku, &c_b227, &
+ work[ir], &ldwrkr);
+ slacpy_("F", &chunk, n, &work[ir], &ldwrkr, &a[i__ +
+ a_dim1], lda);
+/* L20: */
+ }
+ }
+
+ } else if (wntqs) {
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in U and computing right singular */
+/* vectors of bidiagonal matrix in VT */
+/* (Workspace: need N+BDSPAC) */
+
+ slaset_("F", m, n, &c_b227, &c_b227, &u[u_offset], ldu);
+ sbdsdc_("U", "I", n, &s[1], &work[ie], &u[u_offset], ldu, &vt[
+ vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1],
+ info);
+
+/* Overwrite U by left singular vectors of A and VT */
+/* by right singular vectors of A */
+/* (Workspace: need 3*N, prefer 2*N+N*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sormbr_("Q", "L", "N", m, n, n, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr);
+ i__1 = *lwork - nwork + 1;
+ sormbr_("P", "R", "T", n, n, n, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, &
+ ierr);
+ } else if (wntqa) {
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in U and computing right singular */
+/* vectors of bidiagonal matrix in VT */
+/* (Workspace: need N+BDSPAC) */
+
+ slaset_("F", m, m, &c_b227, &c_b227, &u[u_offset], ldu);
+ sbdsdc_("U", "I", n, &s[1], &work[ie], &u[u_offset], ldu, &vt[
+ vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1],
+ info);
+
+/* Set the right corner of U to identity matrix */
+
+ if (*m > *n) {
+ i__1 = *m - *n;
+ i__2 = *m - *n;
+ slaset_("F", &i__1, &i__2, &c_b227, &c_b248, &u[*n + 1 + (
+ *n + 1) * u_dim1], ldu);
+ }
+
+/* Overwrite U by left singular vectors of A and VT */
+/* by right singular vectors of A */
+/* (Workspace: need N*N+2*N+M, prefer N*N+2*N+M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr);
+ i__1 = *lwork - nwork + 1;
+ sormbr_("P", "R", "T", n, n, m, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, &
+ ierr);
+ }
+
+ }
+
+ } else {
+
+/* A has more columns than rows. If A has sufficiently more */
+/* columns than rows, first reduce using the LQ decomposition (if */
+/* sufficient workspace available) */
+
+ if (*n >= mnthr) {
+
+ if (wntqn) {
+
+/* Path 1t (N much larger than M, JOBZ='N') */
+/* No singular vectors to be computed */
+
+ itau = 1;
+ nwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__1, &ierr);
+
+/* Zero out above L */
+
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ slaset_("U", &i__1, &i__2, &c_b227, &c_b227, &a[(a_dim1 << 1)
+ + 1], lda);
+ ie = 1;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize L in A */
+/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__1, &ierr);
+ nwork = ie + *m;
+
+/* Perform bidiagonal SVD, computing singular values only */
+/* (Workspace: need M+BDSPAC) */
+
+ sbdsdc_("U", "N", m, &s[1], &work[ie], dum, &c__1, dum, &c__1,
+ dum, idum, &work[nwork], &iwork[1], info);
+
+ } else if (wntqo) {
+
+/* Path 2t (N much larger than M, JOBZ='O') */
+/* M right singular vectors to be overwritten on A and */
+/* M left singular vectors to be computed in U */
+
+ ivt = 1;
+
+/* IVT is M by M */
+
+ il = ivt + *m * *m;
+ if (*lwork >= *m * *n + *m * *m + *m * 3 + bdspac) {
+
+/* WORK(IL) is M by N */
+
+ ldwrkl = *m;
+ chunk = *n;
+ } else {
+ ldwrkl = *m;
+ chunk = (*lwork - *m * *m) / *m;
+ }
+ itau = il + ldwrkl * *m;
+ nwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__1, &ierr);
+
+/* Copy L to WORK(IL), zeroing about above it */
+
+ slacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwrkl);
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ slaset_("U", &i__1, &i__2, &c_b227, &c_b227, &work[il +
+ ldwrkl], &ldwrkl);
+
+/* Generate Q in A */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[nwork],
+ &i__1, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IL) */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sgebrd_(m, m, &work[il], &ldwrkl, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__1, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in U, and computing right singular */
+/* vectors of bidiagonal matrix in WORK(IVT) */
+/* (Workspace: need M+M*M+BDSPAC) */
+
+ sbdsdc_("U", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &
+ work[ivt], m, dum, idum, &work[nwork], &iwork[1],
+ info);
+
+/* Overwrite U by left singular vectors of L and WORK(IVT) */
+/* by right singular vectors of L */
+/* (Workspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sormbr_("Q", "L", "N", m, m, m, &work[il], &ldwrkl, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr);
+ i__1 = *lwork - nwork + 1;
+ sormbr_("P", "R", "T", m, m, m, &work[il], &ldwrkl, &work[
+ itaup], &work[ivt], m, &work[nwork], &i__1, &ierr);
+
+/* Multiply right singular vectors of L in WORK(IVT) by Q */
+/* in A, storing result in WORK(IL) and copying to A */
+/* (Workspace: need 2*M*M, prefer M*M+M*N) */
+
+ i__1 = *n;
+ i__2 = chunk;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *n - i__ + 1;
+ blk = min(i__3,chunk);
+ sgemm_("N", "N", m, &blk, m, &c_b248, &work[ivt], m, &a[
+ i__ * a_dim1 + 1], lda, &c_b227, &work[il], &
+ ldwrkl);
+ slacpy_("F", m, &blk, &work[il], &ldwrkl, &a[i__ * a_dim1
+ + 1], lda);
+/* L30: */
+ }
+
+ } else if (wntqs) {
+
+/* Path 3t (N much larger than M, JOBZ='S') */
+/* M right singular vectors to be computed in VT and */
+/* M left singular vectors to be computed in U */
+
+ il = 1;
+
+/* WORK(IL) is M by M */
+
+ ldwrkl = *m;
+ itau = il + ldwrkl * *m;
+ nwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__2, &ierr);
+
+/* Copy L to WORK(IL), zeroing out above it */
+
+ slacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwrkl);
+ i__2 = *m - 1;
+ i__1 = *m - 1;
+ slaset_("U", &i__2, &i__1, &c_b227, &c_b227, &work[il +
+ ldwrkl], &ldwrkl);
+
+/* Generate Q in A */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ sorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[nwork],
+ &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IU), copying result to U */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ sgebrd_(m, m, &work[il], &ldwrkl, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__2, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in U and computing right singular */
+/* vectors of bidiagonal matrix in VT */
+/* (Workspace: need M+BDSPAC) */
+
+ sbdsdc_("U", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &vt[
+ vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1],
+ info);
+
+/* Overwrite U by left singular vectors of L and VT */
+/* by right singular vectors of L */
+/* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ sormbr_("Q", "L", "N", m, m, m, &work[il], &ldwrkl, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr);
+ i__2 = *lwork - nwork + 1;
+ sormbr_("P", "R", "T", m, m, m, &work[il], &ldwrkl, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, &
+ ierr);
+
+/* Multiply right singular vectors of L in WORK(IL) by */
+/* Q in A, storing result in VT */
+/* (Workspace: need M*M) */
+
+ slacpy_("F", m, m, &vt[vt_offset], ldvt, &work[il], &ldwrkl);
+ sgemm_("N", "N", m, n, m, &c_b248, &work[il], &ldwrkl, &a[
+ a_offset], lda, &c_b227, &vt[vt_offset], ldvt);
+
+ } else if (wntqa) {
+
+/* Path 4t (N much larger than M, JOBZ='A') */
+/* N right singular vectors to be computed in VT and */
+/* M left singular vectors to be computed in U */
+
+ ivt = 1;
+
+/* WORK(IVT) is M by M */
+
+ ldwkvt = *m;
+ itau = ivt + ldwkvt * *m;
+ nwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__2, &ierr);
+ slacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+
+/* Generate Q in VT */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ sorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &work[
+ nwork], &i__2, &ierr);
+
+/* Produce L in A, zeroing out other entries */
+
+ i__2 = *m - 1;
+ i__1 = *m - 1;
+ slaset_("U", &i__2, &i__1, &c_b227, &c_b227, &a[(a_dim1 << 1)
+ + 1], lda);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize L in A */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ sgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__2, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in U and computing right singular */
+/* vectors of bidiagonal matrix in WORK(IVT) */
+/* (Workspace: need M+M*M+BDSPAC) */
+
+ sbdsdc_("U", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &
+ work[ivt], &ldwkvt, dum, idum, &work[nwork], &iwork[1]
+, info);
+
+/* Overwrite U by left singular vectors of L and WORK(IVT) */
+/* by right singular vectors of L */
+/* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ sormbr_("Q", "L", "N", m, m, m, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr);
+ i__2 = *lwork - nwork + 1;
+ sormbr_("P", "R", "T", m, m, m, &a[a_offset], lda, &work[
+ itaup], &work[ivt], &ldwkvt, &work[nwork], &i__2, &
+ ierr);
+
+/* Multiply right singular vectors of L in WORK(IVT) by */
+/* Q in VT, storing result in A */
+/* (Workspace: need M*M) */
+
+ sgemm_("N", "N", m, n, m, &c_b248, &work[ivt], &ldwkvt, &vt[
+ vt_offset], ldvt, &c_b227, &a[a_offset], lda);
+
+/* Copy right singular vectors of A from A to VT */
+
+ slacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+
+ }
+
+ } else {
+
+/* N .LT. MNTHR */
+
+/* Path 5t (N greater than M, but not much larger) */
+/* Reduce to bidiagonal form without LQ decomposition */
+
+ ie = 1;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize A */
+/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ sgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
+ work[itaup], &work[nwork], &i__2, &ierr);
+ if (wntqn) {
+
+/* Perform bidiagonal SVD, only computing singular values */
+/* (Workspace: need M+BDSPAC) */
+
+ sbdsdc_("L", "N", m, &s[1], &work[ie], dum, &c__1, dum, &c__1,
+ dum, idum, &work[nwork], &iwork[1], info);
+ } else if (wntqo) {
+ ldwkvt = *m;
+ ivt = nwork;
+ if (*lwork >= *m * *n + *m * 3 + bdspac) {
+
+/* WORK( IVT ) is M by N */
+
+ slaset_("F", m, n, &c_b227, &c_b227, &work[ivt], &ldwkvt);
+ nwork = ivt + ldwkvt * *n;
+ } else {
+
+/* WORK( IVT ) is M by M */
+
+ nwork = ivt + ldwkvt * *m;
+ il = nwork;
+
+/* WORK(IL) is M by CHUNK */
+
+ chunk = (*lwork - *m * *m - *m * 3) / *m;
+ }
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in U and computing right singular */
+/* vectors of bidiagonal matrix in WORK(IVT) */
+/* (Workspace: need M*M+BDSPAC) */
+
+ sbdsdc_("L", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &
+ work[ivt], &ldwkvt, dum, idum, &work[nwork], &iwork[1]
+, info);
+
+/* Overwrite U by left singular vectors of A */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ sormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr);
+
+ if (*lwork >= *m * *n + *m * 3 + bdspac) {
+
+/* Overwrite WORK(IVT) by left singular vectors of A */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ sormbr_("P", "R", "T", m, n, m, &a[a_offset], lda, &work[
+ itaup], &work[ivt], &ldwkvt, &work[nwork], &i__2,
+ &ierr);
+
+/* Copy right singular vectors of A from WORK(IVT) to A */
+
+ slacpy_("F", m, n, &work[ivt], &ldwkvt, &a[a_offset], lda);
+ } else {
+
+/* Generate P**T in A */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - nwork + 1;
+ sorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &
+ work[nwork], &i__2, &ierr);
+
+/* Multiply Q in A by right singular vectors of */
+/* bidiagonal matrix in WORK(IVT), storing result in */
+/* WORK(IL) and copying to A */
+/* (Workspace: need 2*M*M, prefer M*M+M*N) */
+
+ i__2 = *n;
+ i__1 = chunk;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
+ i__1) {
+/* Computing MIN */
+ i__3 = *n - i__ + 1;
+ blk = min(i__3,chunk);
+ sgemm_("N", "N", m, &blk, m, &c_b248, &work[ivt], &
+ ldwkvt, &a[i__ * a_dim1 + 1], lda, &c_b227, &
+ work[il], m);
+ slacpy_("F", m, &blk, &work[il], m, &a[i__ * a_dim1 +
+ 1], lda);
+/* L40: */
+ }
+ }
+ } else if (wntqs) {
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in U and computing right singular */
+/* vectors of bidiagonal matrix in VT */
+/* (Workspace: need M+BDSPAC) */
+
+ slaset_("F", m, n, &c_b227, &c_b227, &vt[vt_offset], ldvt);
+ sbdsdc_("L", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &vt[
+ vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1],
+ info);
+
+/* Overwrite U by left singular vectors of A and VT */
+/* by right singular vectors of A */
+/* (Workspace: need 3*M, prefer 2*M+M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr);
+ i__1 = *lwork - nwork + 1;
+ sormbr_("P", "R", "T", m, n, m, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, &
+ ierr);
+ } else if (wntqa) {
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in U and computing right singular */
+/* vectors of bidiagonal matrix in VT */
+/* (Workspace: need M+BDSPAC) */
+
+ slaset_("F", n, n, &c_b227, &c_b227, &vt[vt_offset], ldvt);
+ sbdsdc_("L", "I", m, &s[1], &work[ie], &u[u_offset], ldu, &vt[
+ vt_offset], ldvt, dum, idum, &work[nwork], &iwork[1],
+ info);
+
+/* Set the right corner of VT to identity matrix */
+
+ if (*n > *m) {
+ i__1 = *n - *m;
+ i__2 = *n - *m;
+ slaset_("F", &i__1, &i__2, &c_b227, &c_b248, &vt[*m + 1 +
+ (*m + 1) * vt_dim1], ldvt);
+ }
+
+/* Overwrite U by left singular vectors of A and VT */
+/* by right singular vectors of A */
+/* (Workspace: need 2*M+N, prefer 2*M+N*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ sormbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr);
+ i__1 = *lwork - nwork + 1;
+ sormbr_("P", "R", "T", n, n, m, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, &
+ ierr);
+ }
+
+ }
+
+ }
+
+/* Undo scaling if necessary */
+
+ if (iscl == 1) {
+ if (anrm > bignum) {
+ slascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, &ierr);
+ }
+ if (anrm < smlnum) {
+ slascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, &ierr);
+ }
+ }
+
+/* Return optimal workspace in WORK(1) */
+
+ work[1] = (real) maxwrk;
+
+ return 0;
+
+/* End of SGESDD */
+
+} /* sgesdd_ */
diff --git a/SRC/sgesv.c b/SRC/sgesv.c
new file mode 100644
index 0000000..ae114ce
--- /dev/null
+++ b/SRC/sgesv.c
@@ -0,0 +1,139 @@
+/* sgesv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sgesv_(integer *n, integer *nrhs, real *a, integer *lda,
+ integer *ipiv, real *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int xerbla_(char *, integer *), sgetrf_(
+ integer *, integer *, real *, integer *, integer *, integer *),
+ sgetrs_(char *, integer *, integer *, real *, integer *, integer *
+, real *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGESV computes the solution to a real system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */
+
+/* The LU decomposition with partial pivoting and row interchanges is */
+/* used to factor A as */
+/* A = P * L * U, */
+/* where P is a permutation matrix, L is unit lower triangular, and U is */
+/* upper triangular. The factored form of A is then used to solve the */
+/* system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the N-by-N coefficient matrix A. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* The pivot indices that define the permutation matrix P; */
+/* row i of the matrix was interchanged with row IPIV(i). */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS matrix of right hand side matrix B. */
+/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, so the solution could not be computed. */
+
+/* ===================================================================== */
+
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGESV ", &i__1);
+ return 0;
+ }
+
+/* Compute the LU factorization of A. */
+
+ sgetrf_(n, n, &a[a_offset], lda, &ipiv[1], info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ sgetrs_("No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &b[
+ b_offset], ldb, info);
+ }
+ return 0;
+
+/* End of SGESV */
+
+} /* sgesv_ */
diff --git a/SRC/sgesvd.c b/SRC/sgesvd.c
new file mode 100644
index 0000000..358cbd6
--- /dev/null
+++ b/SRC/sgesvd.c
@@ -0,0 +1,4047 @@
+/* sgesvd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__6 = 6;
+static integer c__0 = 0;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b421 = 0.f;
+static real c_b443 = 1.f;
+
+/* Subroutine */ int sgesvd_(char *jobu, char *jobvt, integer *m, integer *n,
+ real *a, integer *lda, real *s, real *u, integer *ldu, real *vt,
+ integer *ldvt, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1[2],
+ i__2, i__3, i__4;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, ie, ir, iu, blk, ncu;
+ real dum[1], eps;
+ integer nru, iscl;
+ real anrm;
+ integer ierr, itau, ncvt, nrvt;
+ extern logical lsame_(char *, char *);
+ integer chunk;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ integer minmn, wrkbl, itaup, itauq, mnthr, iwork;
+ logical wntua, wntva, wntun, wntuo, wntvn, wntvo, wntus, wntvs;
+ integer bdspac;
+ extern /* Subroutine */ int sgebrd_(integer *, integer *, real *, integer
+ *, real *, real *, real *, real *, real *, integer *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ real bignum;
+ extern /* Subroutine */ int sgelqf_(integer *, integer *, real *, integer
+ *, real *, real *, integer *, integer *), slascl_(char *, integer
+ *, integer *, real *, real *, integer *, integer *, real *,
+ integer *, integer *), sgeqrf_(integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *), slacpy_(char
+ *, integer *, integer *, real *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *,
+ real *, integer *), sbdsqr_(char *, integer *, integer *,
+ integer *, integer *, real *, real *, real *, integer *, real *,
+ integer *, real *, integer *, real *, integer *), sorgbr_(
+ char *, integer *, integer *, integer *, real *, integer *, real *
+, real *, integer *, integer *), sormbr_(char *, char *,
+ char *, integer *, integer *, integer *, real *, integer *, real *
+, real *, integer *, real *, integer *, integer *);
+ integer ldwrkr, minwrk, ldwrku, maxwrk;
+ extern /* Subroutine */ int sorglq_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *);
+ real smlnum;
+ extern /* Subroutine */ int sorgqr_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *);
+ logical lquery, wntuas, wntvas;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGESVD computes the singular value decomposition (SVD) of a real */
+/* M-by-N matrix A, optionally computing the left and/or right singular */
+/* vectors. The SVD is written */
+
+/* A = U * SIGMA * transpose(V) */
+
+/* where SIGMA is an M-by-N matrix which is zero except for its */
+/* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and */
+/* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA */
+/* are the singular values of A; they are real and non-negative, and */
+/* are returned in descending order. The first min(m,n) columns of */
+/* U and V are the left and right singular vectors of A. */
+
+/* Note that the routine returns V**T, not V. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBU (input) CHARACTER*1 */
+/* Specifies options for computing all or part of the matrix U: */
+/* = 'A': all M columns of U are returned in array U: */
+/* = 'S': the first min(m,n) columns of U (the left singular */
+/* vectors) are returned in the array U; */
+/* = 'O': the first min(m,n) columns of U (the left singular */
+/* vectors) are overwritten on the array A; */
+/* = 'N': no columns of U (no left singular vectors) are */
+/* computed. */
+
+/* JOBVT (input) CHARACTER*1 */
+/* Specifies options for computing all or part of the matrix */
+/* V**T: */
+/* = 'A': all N rows of V**T are returned in the array VT; */
+/* = 'S': the first min(m,n) rows of V**T (the right singular */
+/* vectors) are returned in the array VT; */
+/* = 'O': the first min(m,n) rows of V**T (the right singular */
+/* vectors) are overwritten on the array A; */
+/* = 'N': no rows of V**T (no right singular vectors) are */
+/* computed. */
+
+/* JOBVT and JOBU cannot both be 'O'. */
+
+/* M (input) INTEGER */
+/* The number of rows of the input matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the input matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, */
+/* if JOBU = 'O', A is overwritten with the first min(m,n) */
+/* columns of U (the left singular vectors, */
+/* stored columnwise); */
+/* if JOBVT = 'O', A is overwritten with the first min(m,n) */
+/* rows of V**T (the right singular vectors, */
+/* stored rowwise); */
+/* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A */
+/* are destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* S (output) REAL array, dimension (min(M,N)) */
+/* The singular values of A, sorted so that S(i) >= S(i+1). */
+
+/* U (output) REAL array, dimension (LDU,UCOL) */
+/* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'. */
+/* If JOBU = 'A', U contains the M-by-M orthogonal matrix U; */
+/* if JOBU = 'S', U contains the first min(m,n) columns of U */
+/* (the left singular vectors, stored columnwise); */
+/* if JOBU = 'N' or 'O', U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= 1; if */
+/* JOBU = 'S' or 'A', LDU >= M. */
+
+/* VT (output) REAL array, dimension (LDVT,N) */
+/* If JOBVT = 'A', VT contains the N-by-N orthogonal matrix */
+/* V**T; */
+/* if JOBVT = 'S', VT contains the first min(m,n) rows of */
+/* V**T (the right singular vectors, stored rowwise); */
+/* if JOBVT = 'N' or 'O', VT is not referenced. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. LDVT >= 1; if */
+/* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK; */
+/* if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged */
+/* superdiagonal elements of an upper bidiagonal matrix B */
+/* whose diagonal is in S (not necessarily sorted). B */
+/* satisfies A = U * B * VT, so it has the same singular values */
+/* as A, and singular vectors related by U and VT. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)). */
+/* For good performance, LWORK should generally be larger. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if SBDSQR did not converge, INFO specifies how many */
+/* superdiagonals of an intermediate bidiagonal form B */
+/* did not converge to zero. See the description of WORK */
+/* above for details. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ minmn = min(*m,*n);
+ wntua = lsame_(jobu, "A");
+ wntus = lsame_(jobu, "S");
+ wntuas = wntua || wntus;
+ wntuo = lsame_(jobu, "O");
+ wntun = lsame_(jobu, "N");
+ wntva = lsame_(jobvt, "A");
+ wntvs = lsame_(jobvt, "S");
+ wntvas = wntva || wntvs;
+ wntvo = lsame_(jobvt, "O");
+ wntvn = lsame_(jobvt, "N");
+ lquery = *lwork == -1;
+
+ if (! (wntua || wntus || wntuo || wntun)) {
+ *info = -1;
+ } else if (! (wntva || wntvs || wntvo || wntvn) || wntvo && wntuo) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -6;
+ } else if (*ldu < 1 || wntuas && *ldu < *m) {
+ *info = -9;
+ } else if (*ldvt < 1 || wntva && *ldvt < *n || wntvs && *ldvt < minmn) {
+ *info = -11;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ if (*info == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ if (*m >= *n && minmn > 0) {
+
+/* Compute space needed for SBDSQR */
+
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = jobu;
+ i__1[1] = 1, a__1[1] = jobvt;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ mnthr = ilaenv_(&c__6, "SGESVD", ch__1, m, n, &c__0, &c__0);
+ bdspac = *n * 5;
+ if (*m >= mnthr) {
+ if (wntun) {
+
+/* Path 1 (M much larger than N, JOBU='N') */
+
+ maxwrk = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", n, n, &c_n1, &c_n1);
+ maxwrk = max(i__2,i__3);
+ if (wntvo || wntvas) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = *n * 3 + (*n - 1) * ilaenv_(&
+ c__1, "SORGBR", "P", n, n, n, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ maxwrk = max(maxwrk,bdspac);
+/* Computing MAX */
+ i__2 = *n << 2;
+ minwrk = max(i__2,bdspac);
+ } else if (wntuo && wntvn) {
+
+/* Path 2 (M much larger than N, JOBU='O', JOBVT='N') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "SORGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "SORGBR"
+, "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+/* Computing MAX */
+ i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n + *n;
+ maxwrk = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = *n * 3 + *m;
+ minwrk = max(i__2,bdspac);
+ } else if (wntuo && wntvas) {
+
+/* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or */
+/* 'A') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "SORGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "SORGBR"
+, "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
+ "SORGBR", "P", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+/* Computing MAX */
+ i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n + *n;
+ maxwrk = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = *n * 3 + *m;
+ minwrk = max(i__2,bdspac);
+ } else if (wntus && wntvn) {
+
+/* Path 4 (M much larger than N, JOBU='S', JOBVT='N') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "SORGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "SORGBR"
+, "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = *n * *n + wrkbl;
+/* Computing MAX */
+ i__2 = *n * 3 + *m;
+ minwrk = max(i__2,bdspac);
+ } else if (wntus && wntvo) {
+
+/* Path 5 (M much larger than N, JOBU='S', JOBVT='O') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "SORGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "SORGBR"
+, "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
+ "SORGBR", "P", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = (*n << 1) * *n + wrkbl;
+/* Computing MAX */
+ i__2 = *n * 3 + *m;
+ minwrk = max(i__2,bdspac);
+ } else if (wntus && wntvas) {
+
+/* Path 6 (M much larger than N, JOBU='S', JOBVT='S' or */
+/* 'A') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "SORGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "SORGBR"
+, "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
+ "SORGBR", "P", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = *n * *n + wrkbl;
+/* Computing MAX */
+ i__2 = *n * 3 + *m;
+ minwrk = max(i__2,bdspac);
+ } else if (wntua && wntvn) {
+
+/* Path 7 (M much larger than N, JOBU='A', JOBVT='N') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "SORGQR",
+ " ", m, m, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "SORGBR"
+, "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = *n * *n + wrkbl;
+/* Computing MAX */
+ i__2 = *n * 3 + *m;
+ minwrk = max(i__2,bdspac);
+ } else if (wntua && wntvo) {
+
+/* Path 8 (M much larger than N, JOBU='A', JOBVT='O') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "SORGQR",
+ " ", m, m, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "SORGBR"
+, "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
+ "SORGBR", "P", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = (*n << 1) * *n + wrkbl;
+/* Computing MAX */
+ i__2 = *n * 3 + *m;
+ minwrk = max(i__2,bdspac);
+ } else if (wntua && wntvas) {
+
+/* Path 9 (M much larger than N, JOBU='A', JOBVT='S' or */
+/* 'A') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "SORGQR",
+ " ", m, m, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + *n * ilaenv_(&c__1, "SORGBR"
+, "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
+ "SORGBR", "P", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = *n * *n + wrkbl;
+/* Computing MAX */
+ i__2 = *n * 3 + *m;
+ minwrk = max(i__2,bdspac);
+ }
+ } else {
+
+/* Path 10 (M at least N, but not much larger) */
+
+ maxwrk = *n * 3 + (*m + *n) * ilaenv_(&c__1, "SGEBRD", " ", m,
+ n, &c_n1, &c_n1);
+ if (wntus || wntuo) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = *n * 3 + *n * ilaenv_(&c__1, "SORG"
+ "BR", "Q", m, n, n, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ if (wntua) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = *n * 3 + *m * ilaenv_(&c__1, "SORG"
+ "BR", "Q", m, m, n, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ if (! wntvn) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = *n * 3 + (*n - 1) * ilaenv_(&c__1,
+ "SORGBR", "P", n, n, n, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ maxwrk = max(maxwrk,bdspac);
+/* Computing MAX */
+ i__2 = *n * 3 + *m;
+ minwrk = max(i__2,bdspac);
+ }
+ } else if (minmn > 0) {
+
+/* Compute space needed for SBDSQR */
+
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = jobu;
+ i__1[1] = 1, a__1[1] = jobvt;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ mnthr = ilaenv_(&c__6, "SGESVD", ch__1, m, n, &c__0, &c__0);
+ bdspac = *m * 5;
+ if (*n >= mnthr) {
+ if (wntvn) {
+
+/* Path 1t(N much larger than M, JOBVT='N') */
+
+ maxwrk = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", m, m, &c_n1, &c_n1);
+ maxwrk = max(i__2,i__3);
+ if (wntuo || wntuas) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = *m * 3 + *m * ilaenv_(&c__1,
+ "SORGBR", "Q", m, m, m, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ maxwrk = max(maxwrk,bdspac);
+/* Computing MAX */
+ i__2 = *m << 2;
+ minwrk = max(i__2,bdspac);
+ } else if (wntvo && wntun) {
+
+/* Path 2t(N much larger than M, JOBU='N', JOBVT='O') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "SORGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
+ "SORGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+/* Computing MAX */
+ i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n + *m;
+ maxwrk = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = *m * 3 + *n;
+ minwrk = max(i__2,bdspac);
+ } else if (wntvo && wntuas) {
+
+/* Path 3t(N much larger than M, JOBU='S' or 'A', */
+/* JOBVT='O') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "SORGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
+ "SORGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "SORGBR"
+, "Q", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+/* Computing MAX */
+ i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n + *m;
+ maxwrk = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = *m * 3 + *n;
+ minwrk = max(i__2,bdspac);
+ } else if (wntvs && wntun) {
+
+/* Path 4t(N much larger than M, JOBU='N', JOBVT='S') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "SORGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
+ "SORGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = *m * *m + wrkbl;
+/* Computing MAX */
+ i__2 = *m * 3 + *n;
+ minwrk = max(i__2,bdspac);
+ } else if (wntvs && wntuo) {
+
+/* Path 5t(N much larger than M, JOBU='O', JOBVT='S') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "SORGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
+ "SORGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "SORGBR"
+, "Q", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = (*m << 1) * *m + wrkbl;
+/* Computing MAX */
+ i__2 = *m * 3 + *n;
+ minwrk = max(i__2,bdspac);
+ maxwrk = max(maxwrk,minwrk);
+ } else if (wntvs && wntuas) {
+
+/* Path 6t(N much larger than M, JOBU='S' or 'A', */
+/* JOBVT='S') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "SORGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
+ "SORGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "SORGBR"
+, "Q", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = *m * *m + wrkbl;
+/* Computing MAX */
+ i__2 = *m * 3 + *n;
+ minwrk = max(i__2,bdspac);
+ } else if (wntva && wntun) {
+
+/* Path 7t(N much larger than M, JOBU='N', JOBVT='A') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "SORGLQ",
+ " ", n, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
+ "SORGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = *m * *m + wrkbl;
+/* Computing MAX */
+ i__2 = *m * 3 + *n;
+ minwrk = max(i__2,bdspac);
+ } else if (wntva && wntuo) {
+
+/* Path 8t(N much larger than M, JOBU='O', JOBVT='A') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "SORGLQ",
+ " ", n, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
+ "SORGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "SORGBR"
+, "Q", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = (*m << 1) * *m + wrkbl;
+/* Computing MAX */
+ i__2 = *m * 3 + *n;
+ minwrk = max(i__2,bdspac);
+ } else if (wntva && wntuas) {
+
+/* Path 9t(N much larger than M, JOBU='S' or 'A', */
+/* JOBVT='A') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "SGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "SORGLQ",
+ " ", n, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m << 1) * ilaenv_(&c__1,
+ "SGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
+ "SORGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m * 3 + *m * ilaenv_(&c__1, "SORGBR"
+, "Q", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ wrkbl = max(wrkbl,bdspac);
+ maxwrk = *m * *m + wrkbl;
+/* Computing MAX */
+ i__2 = *m * 3 + *n;
+ minwrk = max(i__2,bdspac);
+ }
+ } else {
+
+/* Path 10t(N greater than M, but not much larger) */
+
+ maxwrk = *m * 3 + (*m + *n) * ilaenv_(&c__1, "SGEBRD", " ", m,
+ n, &c_n1, &c_n1);
+ if (wntvs || wntvo) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = *m * 3 + *m * ilaenv_(&c__1, "SORG"
+ "BR", "P", m, n, m, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ if (wntva) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = *m * 3 + *n * ilaenv_(&c__1, "SORG"
+ "BR", "P", n, n, m, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ if (! wntun) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = *m * 3 + (*m - 1) * ilaenv_(&c__1,
+ "SORGBR", "Q", m, m, m, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ maxwrk = max(maxwrk,bdspac);
+/* Computing MAX */
+ i__2 = *m * 3 + *n;
+ minwrk = max(i__2,bdspac);
+ }
+ }
+ maxwrk = max(maxwrk,minwrk);
+ work[1] = (real) maxwrk;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info != 0) {
+ i__2 = -(*info);
+ xerbla_("SGESVD", &i__2);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ smlnum = sqrt(slamch_("S")) / eps;
+ bignum = 1.f / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = slange_("M", m, n, &a[a_offset], lda, dum);
+ iscl = 0;
+ if (anrm > 0.f && anrm < smlnum) {
+ iscl = 1;
+ slascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, &
+ ierr);
+ } else if (anrm > bignum) {
+ iscl = 1;
+ slascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+ if (*m >= *n) {
+
+/* A has at least as many rows as columns. If A has sufficiently */
+/* more rows than columns, first reduce using the QR */
+/* decomposition (if sufficient workspace available) */
+
+ if (*m >= mnthr) {
+
+ if (wntun) {
+
+/* Path 1 (M much larger than N, JOBU='N') */
+/* No left singular vectors to be computed */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &
+ i__2, &ierr);
+
+/* Zero out below R */
+
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ slaset_("L", &i__2, &i__3, &c_b421, &c_b421, &a[a_dim1 + 2],
+ lda);
+ ie = 1;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in A */
+/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__2, &ierr);
+ ncvt = 0;
+ if (wntvo || wntvas) {
+
+/* If right singular vectors desired, generate P'. */
+/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &
+ work[iwork], &i__2, &ierr);
+ ncvt = *n;
+ }
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of A in A if desired */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("U", n, &ncvt, &c__0, &c__0, &s[1], &work[ie], &a[
+ a_offset], lda, dum, &c__1, dum, &c__1, &work[iwork],
+ info);
+
+/* If right singular vectors desired in VT, copy them there */
+
+ if (wntvas) {
+ slacpy_("F", n, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+ }
+
+ } else if (wntuo && wntvn) {
+
+/* Path 2 (M much larger than N, JOBU='O', JOBVT='N') */
+/* N left singular vectors to be overwritten on A and */
+/* no right singular vectors to be computed */
+
+/* Computing MAX */
+ i__2 = *n << 2;
+ if (*lwork >= *n * *n + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *lda * *n + *n;
+ if (*lwork >= max(i__2,i__3) + *lda * *n) {
+
+/* WORK(IU) is LDA by N, WORK(IR) is LDA by N */
+
+ ldwrku = *lda;
+ ldwrkr = *lda;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *lda * *n + *n;
+ if (*lwork >= max(i__2,i__3) + *n * *n) {
+
+/* WORK(IU) is LDA by N, WORK(IR) is N by N */
+
+ ldwrku = *lda;
+ ldwrkr = *n;
+ } else {
+
+/* WORK(IU) is LDWRKU by N, WORK(IR) is N by N */
+
+ ldwrku = (*lwork - *n * *n - *n) / *n;
+ ldwrkr = *n;
+ }
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__2, &ierr);
+
+/* Copy R to WORK(IR) and zero out below it */
+
+ slacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ slaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[ir + 1]
+, &ldwrkr);
+
+/* Generate Q in A */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IR) */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__2, &ierr);
+
+/* Generate left vectors bidiagonalizing R */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], &
+ work[iwork], &i__2, &ierr);
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IR) */
+/* (Workspace: need N*N+BDSPAC) */
+
+ sbdsqr_("U", n, &c__0, n, &c__0, &s[1], &work[ie], dum, &
+ c__1, &work[ir], &ldwrkr, dum, &c__1, &work[iwork]
+, info);
+ iu = ie + *n;
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IR), storing result in WORK(IU) and copying to A */
+/* (Workspace: need N*N+2*N, prefer N*N+M*N+N) */
+
+ i__2 = *m;
+ i__3 = ldwrku;
+ for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
+ i__3) {
+/* Computing MIN */
+ i__4 = *m - i__ + 1;
+ chunk = min(i__4,ldwrku);
+ sgemm_("N", "N", &chunk, n, n, &c_b443, &a[i__ +
+ a_dim1], lda, &work[ir], &ldwrkr, &c_b421, &
+ work[iu], &ldwrku);
+ slacpy_("F", &chunk, n, &work[iu], &ldwrku, &a[i__ +
+ a_dim1], lda);
+/* L10: */
+ }
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ ie = 1;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize A */
+/* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ sgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__3, &ierr);
+
+/* Generate left vectors bidiagonalizing A */
+/* (Workspace: need 4*N, prefer 3*N+N*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ sorgbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], &
+ work[iwork], &i__3, &ierr);
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in A */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("U", n, &c__0, m, &c__0, &s[1], &work[ie], dum, &
+ c__1, &a[a_offset], lda, dum, &c__1, &work[iwork],
+ info);
+
+ }
+
+ } else if (wntuo && wntvas) {
+
+/* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A') */
+/* N left singular vectors to be overwritten on A and */
+/* N right singular vectors to be computed in VT */
+
+/* Computing MAX */
+ i__3 = *n << 2;
+ if (*lwork >= *n * *n + max(i__3,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+/* Computing MAX */
+ i__3 = wrkbl, i__2 = *lda * *n + *n;
+ if (*lwork >= max(i__3,i__2) + *lda * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is LDA by N */
+
+ ldwrku = *lda;
+ ldwrkr = *lda;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__3 = wrkbl, i__2 = *lda * *n + *n;
+ if (*lwork >= max(i__3,i__2) + *n * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is N by N */
+
+ ldwrku = *lda;
+ ldwrkr = *n;
+ } else {
+
+/* WORK(IU) is LDWRKU by N and WORK(IR) is N by N */
+
+ ldwrku = (*lwork - *n * *n - *n) / *n;
+ ldwrkr = *n;
+ }
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__3, &ierr);
+
+/* Copy R to VT, zeroing out below it */
+
+ slacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+ if (*n > 1) {
+ i__3 = *n - 1;
+ i__2 = *n - 1;
+ slaset_("L", &i__3, &i__2, &c_b421, &c_b421, &vt[
+ vt_dim1 + 2], ldvt);
+ }
+
+/* Generate Q in A */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ sorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__3, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in VT, copying result to WORK(IR) */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ sgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &i__3, &
+ ierr);
+ slacpy_("L", n, n, &vt[vt_offset], ldvt, &work[ir], &
+ ldwrkr);
+
+/* Generate left vectors bidiagonalizing R in WORK(IR) */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ sorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], &
+ work[iwork], &i__3, &ierr);
+
+/* Generate right vectors bidiagonalizing R in VT */
+/* (Workspace: need N*N+4*N-1, prefer N*N+3*N+(N-1)*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ sorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup],
+ &work[iwork], &i__3, &ierr);
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IR) and computing right */
+/* singular vectors of R in VT */
+/* (Workspace: need N*N+BDSPAC) */
+
+ sbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &work[ir], &ldwrkr, dum, &c__1,
+ &work[iwork], info);
+ iu = ie + *n;
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IR), storing result in WORK(IU) and copying to A */
+/* (Workspace: need N*N+2*N, prefer N*N+M*N+N) */
+
+ i__3 = *m;
+ i__2 = ldwrku;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__4 = *m - i__ + 1;
+ chunk = min(i__4,ldwrku);
+ sgemm_("N", "N", &chunk, n, n, &c_b443, &a[i__ +
+ a_dim1], lda, &work[ir], &ldwrkr, &c_b421, &
+ work[iu], &ldwrku);
+ slacpy_("F", &chunk, n, &work[iu], &ldwrku, &a[i__ +
+ a_dim1], lda);
+/* L20: */
+ }
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__2, &ierr);
+
+/* Copy R to VT, zeroing out below it */
+
+ slacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+ if (*n > 1) {
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ slaset_("L", &i__2, &i__3, &c_b421, &c_b421, &vt[
+ vt_dim1 + 2], ldvt);
+ }
+
+/* Generate Q in A */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in VT */
+/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &i__2, &
+ ierr);
+
+/* Multiply Q in A by left vectors bidiagonalizing R */
+/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sormbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt, &
+ work[itauq], &a[a_offset], lda, &work[iwork], &
+ i__2, &ierr);
+
+/* Generate right vectors bidiagonalizing R in VT */
+/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup],
+ &work[iwork], &i__2, &ierr);
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in A and computing right */
+/* singular vectors of A in VT */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, &
+ work[iwork], info);
+
+ }
+
+ } else if (wntus) {
+
+ if (wntvn) {
+
+/* Path 4 (M much larger than N, JOBU='S', JOBVT='N') */
+/* N left singular vectors to be computed in U and */
+/* no right singular vectors to be computed */
+
+/* Computing MAX */
+ i__2 = *n << 2;
+ if (*lwork >= *n * *n + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+ if (*lwork >= wrkbl + *lda * *n) {
+
+/* WORK(IR) is LDA by N */
+
+ ldwrkr = *lda;
+ } else {
+
+/* WORK(IR) is N by N */
+
+ ldwrkr = *n;
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy R to WORK(IR), zeroing out below it */
+
+ slacpy_("U", n, n, &a[a_offset], lda, &work[ir], &
+ ldwrkr);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ slaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[ir
+ + 1], &ldwrkr);
+
+/* Generate Q in A */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IR) */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Generate left vectors bidiagonalizing R in WORK(IR) */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IR) */
+/* (Workspace: need N*N+BDSPAC) */
+
+ sbdsqr_("U", n, &c__0, n, &c__0, &s[1], &work[ie],
+ dum, &c__1, &work[ir], &ldwrkr, dum, &c__1, &
+ work[iwork], info);
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IR), storing result in U */
+/* (Workspace: need N*N) */
+
+ sgemm_("N", "N", m, n, n, &c_b443, &a[a_offset], lda,
+ &work[ir], &ldwrkr, &c_b421, &u[u_offset],
+ ldu);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ slacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Zero out below R in A */
+
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ slaset_("L", &i__2, &i__3, &c_b421, &c_b421, &a[
+ a_dim1 + 2], lda);
+
+/* Bidiagonalize R in A */
+/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left vectors bidiagonalizing R */
+/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
+ work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr)
+ ;
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("U", n, &c__0, m, &c__0, &s[1], &work[ie],
+ dum, &c__1, &u[u_offset], ldu, dum, &c__1, &
+ work[iwork], info);
+
+ }
+
+ } else if (wntvo) {
+
+/* Path 5 (M much larger than N, JOBU='S', JOBVT='O') */
+/* N left singular vectors to be computed in U and */
+/* N right singular vectors to be overwritten on A */
+
+/* Computing MAX */
+ i__2 = *n << 2;
+ if (*lwork >= (*n << 1) * *n + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + (*lda << 1) * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is LDA by N */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *lda;
+ } else if (*lwork >= wrkbl + (*lda + *n) * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is N by N */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *n;
+ } else {
+
+/* WORK(IU) is N by N and WORK(IR) is N by N */
+
+ ldwrku = *n;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *n;
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy R to WORK(IU), zeroing out below it */
+
+ slacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ slaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[iu
+ + 1], &ldwrku);
+
+/* Generate Q in A */
+/* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IU), copying result to */
+/* WORK(IR) */
+/* (Workspace: need 2*N*N+4*N, */
+/* prefer 2*N*N+3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ slacpy_("U", n, n, &work[iu], &ldwrku, &work[ir], &
+ ldwrkr);
+
+/* Generate left bidiagonalizing vectors in WORK(IU) */
+/* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in WORK(IR) */
+/* (Workspace: need 2*N*N+4*N-1, */
+/* prefer 2*N*N+3*N+(N-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("P", n, n, n, &work[ir], &ldwrkr, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IU) and computing */
+/* right singular vectors of R in WORK(IR) */
+/* (Workspace: need 2*N*N+BDSPAC) */
+
+ sbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &work[
+ ir], &ldwrkr, &work[iu], &ldwrku, dum, &c__1,
+ &work[iwork], info);
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IU), storing result in U */
+/* (Workspace: need N*N) */
+
+ sgemm_("N", "N", m, n, n, &c_b443, &a[a_offset], lda,
+ &work[iu], &ldwrku, &c_b421, &u[u_offset],
+ ldu);
+
+/* Copy right singular vectors of R to A */
+/* (Workspace: need N*N) */
+
+ slacpy_("F", n, n, &work[ir], &ldwrkr, &a[a_offset],
+ lda);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ slacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Zero out below R in A */
+
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ slaset_("L", &i__2, &i__3, &c_b421, &c_b421, &a[
+ a_dim1 + 2], lda);
+
+/* Bidiagonalize R in A */
+/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left vectors bidiagonalizing R */
+/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
+ work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr)
+ ;
+
+/* Generate right vectors bidiagonalizing R in A */
+/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup],
+ &work[iwork], &i__2, &ierr);
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in A */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &a[
+ a_offset], lda, &u[u_offset], ldu, dum, &c__1,
+ &work[iwork], info);
+
+ }
+
+ } else if (wntvas) {
+
+/* Path 6 (M much larger than N, JOBU='S', JOBVT='S' */
+/* or 'A') */
+/* N left singular vectors to be computed in U and */
+/* N right singular vectors to be computed in VT */
+
+/* Computing MAX */
+ i__2 = *n << 2;
+ if (*lwork >= *n * *n + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + *lda * *n) {
+
+/* WORK(IU) is LDA by N */
+
+ ldwrku = *lda;
+ } else {
+
+/* WORK(IU) is N by N */
+
+ ldwrku = *n;
+ }
+ itau = iu + ldwrku * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy R to WORK(IU), zeroing out below it */
+
+ slacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ slaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[iu
+ + 1], &ldwrku);
+
+/* Generate Q in A */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgqr_(m, n, n, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IU), copying result to VT */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ slacpy_("U", n, n, &work[iu], &ldwrku, &vt[vt_offset],
+ ldvt);
+
+/* Generate left bidiagonalizing vectors in WORK(IU) */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in VT */
+/* (Workspace: need N*N+4*N-1, */
+/* prefer N*N+3*N+(N-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
+ itaup], &work[iwork], &i__2, &ierr)
+ ;
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IU) and computing */
+/* right singular vectors of R in VT */
+/* (Workspace: need N*N+BDSPAC) */
+
+ sbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &work[iu], &ldwrku, dum, &
+ c__1, &work[iwork], info);
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IU), storing result in U */
+/* (Workspace: need N*N) */
+
+ sgemm_("N", "N", m, n, n, &c_b443, &a[a_offset], lda,
+ &work[iu], &ldwrku, &c_b421, &u[u_offset],
+ ldu);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ slacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgqr_(m, n, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy R to VT, zeroing out below it */
+
+ slacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+ if (*n > 1) {
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ slaset_("L", &i__2, &i__3, &c_b421, &c_b421, &vt[
+ vt_dim1 + 2], ldvt);
+ }
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in VT */
+/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie],
+ &work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left bidiagonalizing vectors */
+/* in VT */
+/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sormbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt,
+ &work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in VT */
+/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
+ itaup], &work[iwork], &i__2, &ierr)
+ ;
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in VT */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, dum, &
+ c__1, &work[iwork], info);
+
+ }
+
+ }
+
+ } else if (wntua) {
+
+ if (wntvn) {
+
+/* Path 7 (M much larger than N, JOBU='A', JOBVT='N') */
+/* M left singular vectors to be computed in U and */
+/* no right singular vectors to be computed */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *n << 2, i__2 = max(i__2,i__3);
+ if (*lwork >= *n * *n + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+ if (*lwork >= wrkbl + *lda * *n) {
+
+/* WORK(IR) is LDA by N */
+
+ ldwrkr = *lda;
+ } else {
+
+/* WORK(IR) is N by N */
+
+ ldwrkr = *n;
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ slacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Copy R to WORK(IR), zeroing out below it */
+
+ slacpy_("U", n, n, &a[a_offset], lda, &work[ir], &
+ ldwrkr);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ slaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[ir
+ + 1], &ldwrkr);
+
+/* Generate Q in U */
+/* (Workspace: need N*N+N+M, prefer N*N+N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IR) */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in WORK(IR) */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IR) */
+/* (Workspace: need N*N+BDSPAC) */
+
+ sbdsqr_("U", n, &c__0, n, &c__0, &s[1], &work[ie],
+ dum, &c__1, &work[ir], &ldwrkr, dum, &c__1, &
+ work[iwork], info);
+
+/* Multiply Q in U by left singular vectors of R in */
+/* WORK(IR), storing result in A */
+/* (Workspace: need N*N) */
+
+ sgemm_("N", "N", m, n, n, &c_b443, &u[u_offset], ldu,
+ &work[ir], &ldwrkr, &c_b421, &a[a_offset],
+ lda);
+
+/* Copy left singular vectors of A from A to U */
+
+ slacpy_("F", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ slacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (Workspace: need N+M, prefer N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Zero out below R in A */
+
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ slaset_("L", &i__2, &i__3, &c_b421, &c_b421, &a[
+ a_dim1 + 2], lda);
+
+/* Bidiagonalize R in A */
+/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left bidiagonalizing vectors */
+/* in A */
+/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
+ work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr)
+ ;
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("U", n, &c__0, m, &c__0, &s[1], &work[ie],
+ dum, &c__1, &u[u_offset], ldu, dum, &c__1, &
+ work[iwork], info);
+
+ }
+
+ } else if (wntvo) {
+
+/* Path 8 (M much larger than N, JOBU='A', JOBVT='O') */
+/* M left singular vectors to be computed in U and */
+/* N right singular vectors to be overwritten on A */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *n << 2, i__2 = max(i__2,i__3);
+ if (*lwork >= (*n << 1) * *n + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + (*lda << 1) * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is LDA by N */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *lda;
+ } else if (*lwork >= wrkbl + (*lda + *n) * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is N by N */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *n;
+ } else {
+
+/* WORK(IU) is N by N and WORK(IR) is N by N */
+
+ ldwrku = *n;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *n;
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ slacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (Workspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy R to WORK(IU), zeroing out below it */
+
+ slacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ slaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[iu
+ + 1], &ldwrku);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IU), copying result to */
+/* WORK(IR) */
+/* (Workspace: need 2*N*N+4*N, */
+/* prefer 2*N*N+3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ slacpy_("U", n, n, &work[iu], &ldwrku, &work[ir], &
+ ldwrkr);
+
+/* Generate left bidiagonalizing vectors in WORK(IU) */
+/* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in WORK(IR) */
+/* (Workspace: need 2*N*N+4*N-1, */
+/* prefer 2*N*N+3*N+(N-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("P", n, n, n, &work[ir], &ldwrkr, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IU) and computing */
+/* right singular vectors of R in WORK(IR) */
+/* (Workspace: need 2*N*N+BDSPAC) */
+
+ sbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &work[
+ ir], &ldwrkr, &work[iu], &ldwrku, dum, &c__1,
+ &work[iwork], info);
+
+/* Multiply Q in U by left singular vectors of R in */
+/* WORK(IU), storing result in A */
+/* (Workspace: need N*N) */
+
+ sgemm_("N", "N", m, n, n, &c_b443, &u[u_offset], ldu,
+ &work[iu], &ldwrku, &c_b421, &a[a_offset],
+ lda);
+
+/* Copy left singular vectors of A from A to U */
+
+ slacpy_("F", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Copy right singular vectors of R from WORK(IR) to A */
+
+ slacpy_("F", n, n, &work[ir], &ldwrkr, &a[a_offset],
+ lda);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ slacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (Workspace: need N+M, prefer N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Zero out below R in A */
+
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ slaset_("L", &i__2, &i__3, &c_b421, &c_b421, &a[
+ a_dim1 + 2], lda);
+
+/* Bidiagonalize R in A */
+/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(n, n, &a[a_offset], lda, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left bidiagonalizing vectors */
+/* in A */
+/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sormbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
+ work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr)
+ ;
+
+/* Generate right bidiagonalizing vectors in A */
+/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup],
+ &work[iwork], &i__2, &ierr);
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in A */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &a[
+ a_offset], lda, &u[u_offset], ldu, dum, &c__1,
+ &work[iwork], info);
+
+ }
+
+ } else if (wntvas) {
+
+/* Path 9 (M much larger than N, JOBU='A', JOBVT='S' */
+/* or 'A') */
+/* M left singular vectors to be computed in U and */
+/* N right singular vectors to be computed in VT */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *n << 2, i__2 = max(i__2,i__3);
+ if (*lwork >= *n * *n + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + *lda * *n) {
+
+/* WORK(IU) is LDA by N */
+
+ ldwrku = *lda;
+ } else {
+
+/* WORK(IU) is N by N */
+
+ ldwrku = *n;
+ }
+ itau = iu + ldwrku * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (Workspace: need N*N+2*N, prefer N*N+N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ slacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (Workspace: need N*N+N+M, prefer N*N+N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy R to WORK(IU), zeroing out below it */
+
+ slacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ slaset_("L", &i__2, &i__3, &c_b421, &c_b421, &work[iu
+ + 1], &ldwrku);
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IU), copying result to VT */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(n, n, &work[iu], &ldwrku, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ slacpy_("U", n, n, &work[iu], &ldwrku, &vt[vt_offset],
+ ldvt);
+
+/* Generate left bidiagonalizing vectors in WORK(IU) */
+/* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in VT */
+/* (Workspace: need N*N+4*N-1, */
+/* prefer N*N+3*N+(N-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
+ itaup], &work[iwork], &i__2, &ierr)
+ ;
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IU) and computing */
+/* right singular vectors of R in VT */
+/* (Workspace: need N*N+BDSPAC) */
+
+ sbdsqr_("U", n, n, n, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &work[iu], &ldwrku, dum, &
+ c__1, &work[iwork], info);
+
+/* Multiply Q in U by left singular vectors of R in */
+/* WORK(IU), storing result in A */
+/* (Workspace: need N*N) */
+
+ sgemm_("N", "N", m, n, n, &c_b443, &u[u_offset], ldu,
+ &work[iu], &ldwrku, &c_b421, &a[a_offset],
+ lda);
+
+/* Copy left singular vectors of A from A to U */
+
+ slacpy_("F", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (Workspace: need 2*N, prefer N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ slacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (Workspace: need N+M, prefer N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy R from A to VT, zeroing out below it */
+
+ slacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+ if (*n > 1) {
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ slaset_("L", &i__2, &i__3, &c_b421, &c_b421, &vt[
+ vt_dim1 + 2], ldvt);
+ }
+ ie = itau;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in VT */
+/* (Workspace: need 4*N, prefer 3*N+2*N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &work[ie],
+ &work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left bidiagonalizing vectors */
+/* in VT */
+/* (Workspace: need 3*N+M, prefer 3*N+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sormbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt,
+ &work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in VT */
+/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
+ itaup], &work[iwork], &i__2, &ierr)
+ ;
+ iwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in VT */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("U", n, n, m, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, dum, &
+ c__1, &work[iwork], info);
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* M .LT. MNTHR */
+
+/* Path 10 (M at least N, but not much larger) */
+/* Reduce to bidiagonal form without QR decomposition */
+
+ ie = 1;
+ itauq = ie + *n;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize A */
+/* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
+ work[itaup], &work[iwork], &i__2, &ierr);
+ if (wntuas) {
+
+/* If left singular vectors desired in U, copy result to U */
+/* and generate left bidiagonalizing vectors in U */
+/* (Workspace: need 3*N+NCU, prefer 3*N+NCU*NB) */
+
+ slacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu);
+ if (wntus) {
+ ncu = *n;
+ }
+ if (wntua) {
+ ncu = *m;
+ }
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("Q", m, &ncu, n, &u[u_offset], ldu, &work[itauq], &
+ work[iwork], &i__2, &ierr);
+ }
+ if (wntvas) {
+
+/* If right singular vectors desired in VT, copy result to */
+/* VT and generate right bidiagonalizing vectors in VT */
+/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */
+
+ slacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], &
+ work[iwork], &i__2, &ierr);
+ }
+ if (wntuo) {
+
+/* If left singular vectors desired in A, generate left */
+/* bidiagonalizing vectors in A */
+/* (Workspace: need 4*N, prefer 3*N+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], &work[
+ iwork], &i__2, &ierr);
+ }
+ if (wntvo) {
+
+/* If right singular vectors desired in A, generate right */
+/* bidiagonalizing vectors in A */
+/* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[
+ iwork], &i__2, &ierr);
+ }
+ iwork = ie + *n;
+ if (wntuas || wntuo) {
+ nru = *m;
+ }
+ if (wntun) {
+ nru = 0;
+ }
+ if (wntvas || wntvo) {
+ ncvt = *n;
+ }
+ if (wntvn) {
+ ncvt = 0;
+ }
+ if (! wntuo && ! wntvo) {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in U and computing right singular */
+/* vectors in VT */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, dum, &c__1, &
+ work[iwork], info);
+ } else if (! wntuo && wntvo) {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in U and computing right singular */
+/* vectors in A */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &a[
+ a_offset], lda, &u[u_offset], ldu, dum, &c__1, &work[
+ iwork], info);
+ } else {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in A and computing right singular */
+/* vectors in VT */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, &
+ work[iwork], info);
+ }
+
+ }
+
+ } else {
+
+/* A has more columns than rows. If A has sufficiently more */
+/* columns than rows, first reduce using the LQ decomposition (if */
+/* sufficient workspace available) */
+
+ if (*n >= mnthr) {
+
+ if (wntvn) {
+
+/* Path 1t(N much larger than M, JOBVT='N') */
+/* No right singular vectors to be computed */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &
+ i__2, &ierr);
+
+/* Zero out above L */
+
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ slaset_("U", &i__2, &i__3, &c_b421, &c_b421, &a[(a_dim1 << 1)
+ + 1], lda);
+ ie = 1;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in A */
+/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__2, &ierr);
+ if (wntuo || wntuas) {
+
+/* If left singular vectors desired, generate Q */
+/* (Workspace: need 4*M, prefer 3*M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq], &
+ work[iwork], &i__2, &ierr);
+ }
+ iwork = ie + *m;
+ nru = 0;
+ if (wntuo || wntuas) {
+ nru = *m;
+ }
+
+/* Perform bidiagonal QR iteration, computing left singular */
+/* vectors of A in A if desired */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("U", m, &c__0, &nru, &c__0, &s[1], &work[ie], dum, &
+ c__1, &a[a_offset], lda, dum, &c__1, &work[iwork],
+ info);
+
+/* If left singular vectors desired in U, copy them there */
+
+ if (wntuas) {
+ slacpy_("F", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+ }
+
+ } else if (wntvo && wntun) {
+
+/* Path 2t(N much larger than M, JOBU='N', JOBVT='O') */
+/* M right singular vectors to be overwritten on A and */
+/* no left singular vectors to be computed */
+
+/* Computing MAX */
+ i__2 = *m << 2;
+ if (*lwork >= *m * *m + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *lda * *n + *m;
+ if (*lwork >= max(i__2,i__3) + *lda * *m) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is LDA by M */
+
+ ldwrku = *lda;
+ chunk = *n;
+ ldwrkr = *lda;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *lda * *n + *m;
+ if (*lwork >= max(i__2,i__3) + *m * *m) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is M by M */
+
+ ldwrku = *lda;
+ chunk = *n;
+ ldwrkr = *m;
+ } else {
+
+/* WORK(IU) is M by CHUNK and WORK(IR) is M by M */
+
+ ldwrku = *m;
+ chunk = (*lwork - *m * *m - *m) / *m;
+ ldwrkr = *m;
+ }
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__2, &ierr);
+
+/* Copy L to WORK(IR) and zero out above it */
+
+ slacpy_("L", m, m, &a[a_offset], lda, &work[ir], &ldwrkr);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ slaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[ir +
+ ldwrkr], &ldwrkr);
+
+/* Generate Q in A */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IR) */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__2, &ierr);
+
+/* Generate right vectors bidiagonalizing L */
+/* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup], &
+ work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of L in WORK(IR) */
+/* (Workspace: need M*M+BDSPAC) */
+
+ sbdsqr_("U", m, m, &c__0, &c__0, &s[1], &work[ie], &work[
+ ir], &ldwrkr, dum, &c__1, dum, &c__1, &work[iwork]
+, info);
+ iu = ie + *m;
+
+/* Multiply right singular vectors of L in WORK(IR) by Q */
+/* in A, storing result in WORK(IU) and copying to A */
+/* (Workspace: need M*M+2*M, prefer M*M+M*N+M) */
+
+ i__2 = *n;
+ i__3 = chunk;
+ for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
+ i__3) {
+/* Computing MIN */
+ i__4 = *n - i__ + 1;
+ blk = min(i__4,chunk);
+ sgemm_("N", "N", m, &blk, m, &c_b443, &work[ir], &
+ ldwrkr, &a[i__ * a_dim1 + 1], lda, &c_b421, &
+ work[iu], &ldwrku);
+ slacpy_("F", m, &blk, &work[iu], &ldwrku, &a[i__ *
+ a_dim1 + 1], lda);
+/* L30: */
+ }
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ ie = 1;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize A */
+/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ sgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__3, &ierr);
+
+/* Generate right vectors bidiagonalizing A */
+/* (Workspace: need 4*M, prefer 3*M+M*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ sorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &
+ work[iwork], &i__3, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of A in A */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("L", m, n, &c__0, &c__0, &s[1], &work[ie], &a[
+ a_offset], lda, dum, &c__1, dum, &c__1, &work[
+ iwork], info);
+
+ }
+
+ } else if (wntvo && wntuas) {
+
+/* Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O') */
+/* M right singular vectors to be overwritten on A and */
+/* M left singular vectors to be computed in U */
+
+/* Computing MAX */
+ i__3 = *m << 2;
+ if (*lwork >= *m * *m + max(i__3,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+/* Computing MAX */
+ i__3 = wrkbl, i__2 = *lda * *n + *m;
+ if (*lwork >= max(i__3,i__2) + *lda * *m) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is LDA by M */
+
+ ldwrku = *lda;
+ chunk = *n;
+ ldwrkr = *lda;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__3 = wrkbl, i__2 = *lda * *n + *m;
+ if (*lwork >= max(i__3,i__2) + *m * *m) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is M by M */
+
+ ldwrku = *lda;
+ chunk = *n;
+ ldwrkr = *m;
+ } else {
+
+/* WORK(IU) is M by CHUNK and WORK(IR) is M by M */
+
+ ldwrku = *m;
+ chunk = (*lwork - *m * *m - *m) / *m;
+ ldwrkr = *m;
+ }
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__3, &ierr);
+
+/* Copy L to U, zeroing about above it */
+
+ slacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+ i__3 = *m - 1;
+ i__2 = *m - 1;
+ slaset_("U", &i__3, &i__2, &c_b421, &c_b421, &u[(u_dim1 <<
+ 1) + 1], ldu);
+
+/* Generate Q in A */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ sorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__3, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in U, copying result to WORK(IR) */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ sgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__3, &ierr);
+ slacpy_("U", m, m, &u[u_offset], ldu, &work[ir], &ldwrkr);
+
+/* Generate right vectors bidiagonalizing L in WORK(IR) */
+/* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ sorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup], &
+ work[iwork], &i__3, &ierr);
+
+/* Generate left vectors bidiagonalizing L in U */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) */
+
+ i__3 = *lwork - iwork + 1;
+ sorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], &
+ work[iwork], &i__3, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of L in U, and computing right */
+/* singular vectors of L in WORK(IR) */
+/* (Workspace: need M*M+BDSPAC) */
+
+ sbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[ir],
+ &ldwrkr, &u[u_offset], ldu, dum, &c__1, &work[
+ iwork], info);
+ iu = ie + *m;
+
+/* Multiply right singular vectors of L in WORK(IR) by Q */
+/* in A, storing result in WORK(IU) and copying to A */
+/* (Workspace: need M*M+2*M, prefer M*M+M*N+M)) */
+
+ i__3 = *n;
+ i__2 = chunk;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__4 = *n - i__ + 1;
+ blk = min(i__4,chunk);
+ sgemm_("N", "N", m, &blk, m, &c_b443, &work[ir], &
+ ldwrkr, &a[i__ * a_dim1 + 1], lda, &c_b421, &
+ work[iu], &ldwrku);
+ slacpy_("F", m, &blk, &work[iu], &ldwrku, &a[i__ *
+ a_dim1 + 1], lda);
+/* L40: */
+ }
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__2, &ierr);
+
+/* Copy L to U, zeroing out above it */
+
+ slacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ slaset_("U", &i__2, &i__3, &c_b421, &c_b421, &u[(u_dim1 <<
+ 1) + 1], ldu);
+
+/* Generate Q in A */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in U */
+/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__2, &ierr);
+
+/* Multiply right vectors bidiagonalizing L by Q in A */
+/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sormbr_("P", "L", "T", m, n, m, &u[u_offset], ldu, &work[
+ itaup], &a[a_offset], lda, &work[iwork], &i__2, &
+ ierr);
+
+/* Generate left vectors bidiagonalizing L in U */
+/* (Workspace: need 4*M, prefer 3*M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], &
+ work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in A */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &a[
+ a_offset], lda, &u[u_offset], ldu, dum, &c__1, &
+ work[iwork], info);
+
+ }
+
+ } else if (wntvs) {
+
+ if (wntun) {
+
+/* Path 4t(N much larger than M, JOBU='N', JOBVT='S') */
+/* M right singular vectors to be computed in VT and */
+/* no left singular vectors to be computed */
+
+/* Computing MAX */
+ i__2 = *m << 2;
+ if (*lwork >= *m * *m + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+ if (*lwork >= wrkbl + *lda * *m) {
+
+/* WORK(IR) is LDA by M */
+
+ ldwrkr = *lda;
+ } else {
+
+/* WORK(IR) is M by M */
+
+ ldwrkr = *m;
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy L to WORK(IR), zeroing out above it */
+
+ slacpy_("L", m, m, &a[a_offset], lda, &work[ir], &
+ ldwrkr);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ slaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[ir
+ + ldwrkr], &ldwrkr);
+
+/* Generate Q in A */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorglq_(m, n, m, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IR) */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Generate right vectors bidiagonalizing L in */
+/* WORK(IR) */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of L in WORK(IR) */
+/* (Workspace: need M*M+BDSPAC) */
+
+ sbdsqr_("U", m, m, &c__0, &c__0, &s[1], &work[ie], &
+ work[ir], &ldwrkr, dum, &c__1, dum, &c__1, &
+ work[iwork], info);
+
+/* Multiply right singular vectors of L in WORK(IR) by */
+/* Q in A, storing result in VT */
+/* (Workspace: need M*M) */
+
+ sgemm_("N", "N", m, n, m, &c_b443, &work[ir], &ldwrkr,
+ &a[a_offset], lda, &c_b421, &vt[vt_offset],
+ ldvt);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy result to VT */
+
+ slacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Zero out above L in A */
+
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ slaset_("U", &i__2, &i__3, &c_b421, &c_b421, &a[(
+ a_dim1 << 1) + 1], lda);
+
+/* Bidiagonalize L in A */
+/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right vectors bidiagonalizing L by Q in VT */
+/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of A in VT */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("U", m, n, &c__0, &c__0, &s[1], &work[ie], &
+ vt[vt_offset], ldvt, dum, &c__1, dum, &c__1, &
+ work[iwork], info);
+
+ }
+
+ } else if (wntuo) {
+
+/* Path 5t(N much larger than M, JOBU='O', JOBVT='S') */
+/* M right singular vectors to be computed in VT and */
+/* M left singular vectors to be overwritten on A */
+
+/* Computing MAX */
+ i__2 = *m << 2;
+ if (*lwork >= (*m << 1) * *m + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + (*lda << 1) * *m) {
+
+/* WORK(IU) is LDA by M and WORK(IR) is LDA by M */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *lda;
+ } else if (*lwork >= wrkbl + (*lda + *m) * *m) {
+
+/* WORK(IU) is LDA by M and WORK(IR) is M by M */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *m;
+ } else {
+
+/* WORK(IU) is M by M and WORK(IR) is M by M */
+
+ ldwrku = *m;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *m;
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy L to WORK(IU), zeroing out below it */
+
+ slacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ slaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[iu
+ + ldwrku], &ldwrku);
+
+/* Generate Q in A */
+/* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorglq_(m, n, m, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IU), copying result to */
+/* WORK(IR) */
+/* (Workspace: need 2*M*M+4*M, */
+/* prefer 2*M*M+3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ slacpy_("L", m, m, &work[iu], &ldwrku, &work[ir], &
+ ldwrkr);
+
+/* Generate right bidiagonalizing vectors in WORK(IU) */
+/* (Workspace: need 2*M*M+4*M-1, */
+/* prefer 2*M*M+3*M+(M-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in WORK(IR) */
+/* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("Q", m, m, m, &work[ir], &ldwrkr, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of L in WORK(IR) and computing */
+/* right singular vectors of L in WORK(IU) */
+/* (Workspace: need 2*M*M+BDSPAC) */
+
+ sbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[
+ iu], &ldwrku, &work[ir], &ldwrkr, dum, &c__1,
+ &work[iwork], info);
+
+/* Multiply right singular vectors of L in WORK(IU) by */
+/* Q in A, storing result in VT */
+/* (Workspace: need M*M) */
+
+ sgemm_("N", "N", m, n, m, &c_b443, &work[iu], &ldwrku,
+ &a[a_offset], lda, &c_b421, &vt[vt_offset],
+ ldvt);
+
+/* Copy left singular vectors of L to A */
+/* (Workspace: need M*M) */
+
+ slacpy_("F", m, m, &work[ir], &ldwrkr, &a[a_offset],
+ lda);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ slacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Zero out above L in A */
+
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ slaset_("U", &i__2, &i__3, &c_b421, &c_b421, &a[(
+ a_dim1 << 1) + 1], lda);
+
+/* Bidiagonalize L in A */
+/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right vectors bidiagonalizing L by Q in VT */
+/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors of L in A */
+/* (Workspace: need 4*M, prefer 3*M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, compute left */
+/* singular vectors of A in A and compute right */
+/* singular vectors of A in VT */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &a[a_offset], lda, dum, &
+ c__1, &work[iwork], info);
+
+ }
+
+ } else if (wntuas) {
+
+/* Path 6t(N much larger than M, JOBU='S' or 'A', */
+/* JOBVT='S') */
+/* M right singular vectors to be computed in VT and */
+/* M left singular vectors to be computed in U */
+
+/* Computing MAX */
+ i__2 = *m << 2;
+ if (*lwork >= *m * *m + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + *lda * *m) {
+
+/* WORK(IU) is LDA by N */
+
+ ldwrku = *lda;
+ } else {
+
+/* WORK(IU) is LDA by M */
+
+ ldwrku = *m;
+ }
+ itau = iu + ldwrku * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy L to WORK(IU), zeroing out above it */
+
+ slacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ slaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[iu
+ + ldwrku], &ldwrku);
+
+/* Generate Q in A */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorglq_(m, n, m, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IU), copying result to U */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ slacpy_("L", m, m, &work[iu], &ldwrku, &u[u_offset],
+ ldu);
+
+/* Generate right bidiagonalizing vectors in WORK(IU) */
+/* (Workspace: need M*M+4*M-1, */
+/* prefer M*M+3*M+(M-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in U */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of L in U and computing right */
+/* singular vectors of L in WORK(IU) */
+/* (Workspace: need M*M+BDSPAC) */
+
+ sbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[
+ iu], &ldwrku, &u[u_offset], ldu, dum, &c__1, &
+ work[iwork], info);
+
+/* Multiply right singular vectors of L in WORK(IU) by */
+/* Q in A, storing result in VT */
+/* (Workspace: need M*M) */
+
+ sgemm_("N", "N", m, n, m, &c_b443, &work[iu], &ldwrku,
+ &a[a_offset], lda, &c_b421, &vt[vt_offset],
+ ldvt);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ slacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy L to U, zeroing out above it */
+
+ slacpy_("L", m, m, &a[a_offset], lda, &u[u_offset],
+ ldu);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ slaset_("U", &i__2, &i__3, &c_b421, &c_b421, &u[(
+ u_dim1 << 1) + 1], ldu);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in U */
+/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right bidiagonalizing vectors in U by Q */
+/* in VT */
+/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sormbr_("P", "L", "T", m, n, m, &u[u_offset], ldu, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in U */
+/* (Workspace: need 4*M, prefer 3*M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in VT */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, dum, &
+ c__1, &work[iwork], info);
+
+ }
+
+ }
+
+ } else if (wntva) {
+
+ if (wntun) {
+
+/* Path 7t(N much larger than M, JOBU='N', JOBVT='A') */
+/* N right singular vectors to be computed in VT and */
+/* no left singular vectors to be computed */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *m << 2, i__2 = max(i__2,i__3);
+ if (*lwork >= *m * *m + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+ if (*lwork >= wrkbl + *lda * *m) {
+
+/* WORK(IR) is LDA by M */
+
+ ldwrkr = *lda;
+ } else {
+
+/* WORK(IR) is M by M */
+
+ ldwrkr = *m;
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ slacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Copy L to WORK(IR), zeroing out above it */
+
+ slacpy_("L", m, m, &a[a_offset], lda, &work[ir], &
+ ldwrkr);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ slaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[ir
+ + ldwrkr], &ldwrkr);
+
+/* Generate Q in VT */
+/* (Workspace: need M*M+M+N, prefer M*M+M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IR) */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in WORK(IR) */
+/* (Workspace: need M*M+4*M-1, */
+/* prefer M*M+3*M+(M-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of L in WORK(IR) */
+/* (Workspace: need M*M+BDSPAC) */
+
+ sbdsqr_("U", m, m, &c__0, &c__0, &s[1], &work[ie], &
+ work[ir], &ldwrkr, dum, &c__1, dum, &c__1, &
+ work[iwork], info);
+
+/* Multiply right singular vectors of L in WORK(IR) by */
+/* Q in VT, storing result in A */
+/* (Workspace: need M*M) */
+
+ sgemm_("N", "N", m, n, m, &c_b443, &work[ir], &ldwrkr,
+ &vt[vt_offset], ldvt, &c_b421, &a[a_offset],
+ lda);
+
+/* Copy right singular vectors of A from A to VT */
+
+ slacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ slacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (Workspace: need M+N, prefer M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Zero out above L in A */
+
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ slaset_("U", &i__2, &i__3, &c_b421, &c_b421, &a[(
+ a_dim1 << 1) + 1], lda);
+
+/* Bidiagonalize L in A */
+/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right bidiagonalizing vectors in A by Q */
+/* in VT */
+/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of A in VT */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("U", m, n, &c__0, &c__0, &s[1], &work[ie], &
+ vt[vt_offset], ldvt, dum, &c__1, dum, &c__1, &
+ work[iwork], info);
+
+ }
+
+ } else if (wntuo) {
+
+/* Path 8t(N much larger than M, JOBU='O', JOBVT='A') */
+/* N right singular vectors to be computed in VT and */
+/* M left singular vectors to be overwritten on A */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *m << 2, i__2 = max(i__2,i__3);
+ if (*lwork >= (*m << 1) * *m + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + (*lda << 1) * *m) {
+
+/* WORK(IU) is LDA by M and WORK(IR) is LDA by M */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *lda;
+ } else if (*lwork >= wrkbl + (*lda + *m) * *m) {
+
+/* WORK(IU) is LDA by M and WORK(IR) is M by M */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *m;
+ } else {
+
+/* WORK(IU) is M by M and WORK(IR) is M by M */
+
+ ldwrku = *m;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *m;
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ slacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (Workspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy L to WORK(IU), zeroing out above it */
+
+ slacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ slaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[iu
+ + ldwrku], &ldwrku);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IU), copying result to */
+/* WORK(IR) */
+/* (Workspace: need 2*M*M+4*M, */
+/* prefer 2*M*M+3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ slacpy_("L", m, m, &work[iu], &ldwrku, &work[ir], &
+ ldwrkr);
+
+/* Generate right bidiagonalizing vectors in WORK(IU) */
+/* (Workspace: need 2*M*M+4*M-1, */
+/* prefer 2*M*M+3*M+(M-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in WORK(IR) */
+/* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("Q", m, m, m, &work[ir], &ldwrkr, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of L in WORK(IR) and computing */
+/* right singular vectors of L in WORK(IU) */
+/* (Workspace: need 2*M*M+BDSPAC) */
+
+ sbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[
+ iu], &ldwrku, &work[ir], &ldwrkr, dum, &c__1,
+ &work[iwork], info);
+
+/* Multiply right singular vectors of L in WORK(IU) by */
+/* Q in VT, storing result in A */
+/* (Workspace: need M*M) */
+
+ sgemm_("N", "N", m, n, m, &c_b443, &work[iu], &ldwrku,
+ &vt[vt_offset], ldvt, &c_b421, &a[a_offset],
+ lda);
+
+/* Copy right singular vectors of A from A to VT */
+
+ slacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Copy left singular vectors of A from WORK(IR) to A */
+
+ slacpy_("F", m, m, &work[ir], &ldwrkr, &a[a_offset],
+ lda);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ slacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (Workspace: need M+N, prefer M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Zero out above L in A */
+
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ slaset_("U", &i__2, &i__3, &c_b421, &c_b421, &a[(
+ a_dim1 << 1) + 1], lda);
+
+/* Bidiagonalize L in A */
+/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(m, m, &a[a_offset], lda, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right bidiagonalizing vectors in A by Q */
+/* in VT */
+/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sormbr_("P", "L", "T", m, n, m, &a[a_offset], lda, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in A */
+/* (Workspace: need 4*M, prefer 3*M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in A and computing right */
+/* singular vectors of A in VT */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &a[a_offset], lda, dum, &
+ c__1, &work[iwork], info);
+
+ }
+
+ } else if (wntuas) {
+
+/* Path 9t(N much larger than M, JOBU='S' or 'A', */
+/* JOBVT='A') */
+/* N right singular vectors to be computed in VT and */
+/* M left singular vectors to be computed in U */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *m << 2, i__2 = max(i__2,i__3);
+ if (*lwork >= *m * *m + max(i__2,bdspac)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + *lda * *m) {
+
+/* WORK(IU) is LDA by M */
+
+ ldwrku = *lda;
+ } else {
+
+/* WORK(IU) is M by M */
+
+ ldwrku = *m;
+ }
+ itau = iu + ldwrku * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (Workspace: need M*M+2*M, prefer M*M+M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ slacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (Workspace: need M*M+M+N, prefer M*M+M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy L to WORK(IU), zeroing out above it */
+
+ slacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ slaset_("U", &i__2, &i__3, &c_b421, &c_b421, &work[iu
+ + ldwrku], &ldwrku);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IU), copying result to U */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(m, m, &work[iu], &ldwrku, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ slacpy_("L", m, m, &work[iu], &ldwrku, &u[u_offset],
+ ldu);
+
+/* Generate right bidiagonalizing vectors in WORK(IU) */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in U */
+/* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of L in U and computing right */
+/* singular vectors of L in WORK(IU) */
+/* (Workspace: need M*M+BDSPAC) */
+
+ sbdsqr_("U", m, m, m, &c__0, &s[1], &work[ie], &work[
+ iu], &ldwrku, &u[u_offset], ldu, dum, &c__1, &
+ work[iwork], info);
+
+/* Multiply right singular vectors of L in WORK(IU) by */
+/* Q in VT, storing result in A */
+/* (Workspace: need M*M) */
+
+ sgemm_("N", "N", m, n, m, &c_b443, &work[iu], &ldwrku,
+ &vt[vt_offset], ldvt, &c_b421, &a[a_offset],
+ lda);
+
+/* Copy right singular vectors of A from A to VT */
+
+ slacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (Workspace: need 2*M, prefer M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ slacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (Workspace: need M+N, prefer M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy L to U, zeroing out above it */
+
+ slacpy_("L", m, m, &a[a_offset], lda, &u[u_offset],
+ ldu);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ slaset_("U", &i__2, &i__3, &c_b421, &c_b421, &u[(
+ u_dim1 << 1) + 1], ldu);
+ ie = itau;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in U */
+/* (Workspace: need 4*M, prefer 3*M+2*M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(m, m, &u[u_offset], ldu, &s[1], &work[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right bidiagonalizing vectors in U by Q */
+/* in VT */
+/* (Workspace: need 3*M+N, prefer 3*M+N*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sormbr_("P", "L", "T", m, n, m, &u[u_offset], ldu, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in U */
+/* (Workspace: need 4*M, prefer 3*M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ iwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in VT */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("U", m, n, m, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, dum, &
+ c__1, &work[iwork], info);
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N .LT. MNTHR */
+
+/* Path 10t(N greater than M, but not much larger) */
+/* Reduce to bidiagonal form without LQ decomposition */
+
+ ie = 1;
+ itauq = ie + *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize A */
+/* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], &
+ work[itaup], &work[iwork], &i__2, &ierr);
+ if (wntuas) {
+
+/* If left singular vectors desired in U, copy result to U */
+/* and generate left bidiagonalizing vectors in U */
+/* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB) */
+
+ slacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("Q", m, m, n, &u[u_offset], ldu, &work[itauq], &work[
+ iwork], &i__2, &ierr);
+ }
+ if (wntvas) {
+
+/* If right singular vectors desired in VT, copy result to */
+/* VT and generate right bidiagonalizing vectors in VT */
+/* (Workspace: need 3*M+NRVT, prefer 3*M+NRVT*NB) */
+
+ slacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+ if (wntva) {
+ nrvt = *n;
+ }
+ if (wntvs) {
+ nrvt = *m;
+ }
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("P", &nrvt, n, m, &vt[vt_offset], ldvt, &work[itaup],
+ &work[iwork], &i__2, &ierr);
+ }
+ if (wntuo) {
+
+/* If left singular vectors desired in A, generate left */
+/* bidiagonalizing vectors in A */
+/* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("Q", m, m, n, &a[a_offset], lda, &work[itauq], &work[
+ iwork], &i__2, &ierr);
+ }
+ if (wntvo) {
+
+/* If right singular vectors desired in A, generate right */
+/* bidiagonalizing vectors in A */
+/* (Workspace: need 4*M, prefer 3*M+M*NB) */
+
+ i__2 = *lwork - iwork + 1;
+ sorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[
+ iwork], &i__2, &ierr);
+ }
+ iwork = ie + *m;
+ if (wntuas || wntuo) {
+ nru = *m;
+ }
+ if (wntun) {
+ nru = 0;
+ }
+ if (wntvas || wntvo) {
+ ncvt = *n;
+ }
+ if (wntvn) {
+ ncvt = 0;
+ }
+ if (! wntuo && ! wntvo) {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in U and computing right singular */
+/* vectors in VT */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, dum, &c__1, &
+ work[iwork], info);
+ } else if (! wntuo && wntvo) {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in U and computing right singular */
+/* vectors in A */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &a[
+ a_offset], lda, &u[u_offset], ldu, dum, &c__1, &work[
+ iwork], info);
+ } else {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in A and computing right singular */
+/* vectors in VT */
+/* (Workspace: need BDSPAC) */
+
+ sbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &work[ie], &vt[
+ vt_offset], ldvt, &a[a_offset], lda, dum, &c__1, &
+ work[iwork], info);
+ }
+
+ }
+
+ }
+
+/* If SBDSQR failed to converge, copy unconverged superdiagonals */
+/* to WORK( 2:MINMN ) */
+
+ if (*info != 0) {
+ if (ie > 2) {
+ i__2 = minmn - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__ + 1] = work[i__ + ie - 1];
+/* L50: */
+ }
+ }
+ if (ie < 2) {
+ for (i__ = minmn - 1; i__ >= 1; --i__) {
+ work[i__ + 1] = work[i__ + ie - 1];
+/* L60: */
+ }
+ }
+ }
+
+/* Undo scaling if necessary */
+
+ if (iscl == 1) {
+ if (anrm > bignum) {
+ slascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, &ierr);
+ }
+ if (*info != 0 && anrm > bignum) {
+ i__2 = minmn - 1;
+ slascl_("G", &c__0, &c__0, &bignum, &anrm, &i__2, &c__1, &work[2],
+ &minmn, &ierr);
+ }
+ if (anrm < smlnum) {
+ slascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, &ierr);
+ }
+ if (*info != 0 && anrm < smlnum) {
+ i__2 = minmn - 1;
+ slascl_("G", &c__0, &c__0, &smlnum, &anrm, &i__2, &c__1, &work[2],
+ &minmn, &ierr);
+ }
+ }
+
+/* Return optimal workspace in WORK(1) */
+
+ work[1] = (real) maxwrk;
+
+ return 0;
+
+/* End of SGESVD */
+
+} /* sgesvd_ */
diff --git a/SRC/sgesvj.c b/SRC/sgesvj.c
new file mode 100644
index 0000000..0510c99
--- /dev/null
+++ b/SRC/sgesvj.c
@@ -0,0 +1,1785 @@
+/* sgesvj.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b17 = 0.f;
+static real c_b18 = 1.f;
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c__2 = 2;
+
+/* Subroutine */ int sgesvj_(char *joba, char *jobu, char *jobv, integer *m,
+ integer *n, real *a, integer *lda, real *sva, integer *mv, real *v,
+ integer *ldv, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_sign(real *, real *);
+
+ /* Local variables */
+ real bigtheta;
+ integer pskipped, i__, p, q;
+ real t;
+ integer n2, n4;
+ real rootsfmin;
+ integer n34;
+ real cs, sn;
+ integer ir1, jbc;
+ real big;
+ integer kbl, igl, ibr, jgl, nbl;
+ real tol;
+ integer mvl;
+ real aapp, aapq, aaqq, ctol;
+ integer ierr;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ real aapp0, temp1;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ real scale, large, apoaq, aqoap;
+ extern logical lsame_(char *, char *);
+ real theta;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real small, sfmin;
+ logical lsvec;
+ real fastr[5];
+ logical applv, rsvec, uctol, lower, upper;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ logical rotok;
+ extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
+ integer *), saxpy_(integer *, real *, real *, integer *, real *,
+ integer *), srotm_(integer *, real *, integer *, real *, integer *
+, real *), sgsvj0_(char *, integer *, integer *, real *, integer *
+, real *, real *, integer *, real *, integer *, real *, real *,
+ real *, integer *, real *, integer *, integer *), sgsvj1_(
+ char *, integer *, integer *, integer *, real *, integer *, real *
+, real *, integer *, real *, integer *, real *, real *, real *,
+ integer *, real *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer ijblsk, swband;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ integer blskip;
+ real mxaapq;
+ extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *);
+ real thsign;
+ extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
+ real *);
+ real mxsinj;
+ integer emptsw, notrot, iswrot, lkahead;
+ logical goscale, noscale;
+ real rootbig, epsilon, rooteps;
+ integer rowskip;
+ real roottol;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Zlatko Drmac of the University of Zagreb and -- */
+/* -- Kresimir Veselic of the Fernuniversitaet Hagen -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* This routine is also part of SIGMA (version 1.23, October 23. 2008.) */
+/* SIGMA is a library of algorithms for highly accurate algorithms for */
+/* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the */
+/* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0. */
+
+/* -#- Scalar Arguments -#- */
+
+
+/* -#- Array Arguments -#- */
+
+/* .. */
+
+/* Purpose */
+/* ~~~~~~~ */
+/* SGESVJ computes the singular value decomposition (SVD) of a real */
+/* M-by-N matrix A, where M >= N. The SVD of A is written as */
+/* [++] [xx] [x0] [xx] */
+/* A = U * SIGMA * V^t, [++] = [xx] * [ox] * [xx] */
+/* [++] [xx] */
+/* where SIGMA is an N-by-N diagonal matrix, U is an M-by-N orthonormal */
+/* matrix, and V is an N-by-N orthogonal matrix. The diagonal elements */
+/* of SIGMA are the singular values of A. The columns of U and V are the */
+/* left and the right singular vectors of A, respectively. */
+
+/* Further Details */
+/* ~~~~~~~~~~~~~~~ */
+/* The orthogonal N-by-N matrix V is obtained as a product of Jacobi plane */
+/* rotations. The rotations are implemented as fast scaled rotations of */
+/* Anda and Park [1]. In the case of underflow of the Jacobi angle, a */
+/* modified Jacobi transformation of Drmac [4] is used. Pivot strategy uses */
+/* column interchanges of de Rijk [2]. The relative accuracy of the computed */
+/* singular values and the accuracy of the computed singular vectors (in */
+/* angle metric) is as guaranteed by the theory of Demmel and Veselic [3]. */
+/* The condition number that determines the accuracy in the full rank case */
+/* is essentially min_{D=diag} kappa(A*D), where kappa(.) is the */
+/* spectral condition number. The best performance of this Jacobi SVD */
+/* procedure is achieved if used in an accelerated version of Drmac and */
+/* Veselic [5,6], and it is the kernel routine in the SIGMA library [7]. */
+/* Some tunning parameters (marked with [TP]) are available for the */
+/* implementer. */
+/* The computational range for the nonzero singular values is the machine */
+/* number interval ( UNDERFLOW , OVERFLOW ). In extreme cases, even */
+/* denormalized singular values can be computed with the corresponding */
+/* gradual loss of accurate digits. */
+
+/* Contributors */
+/* ~~~~~~~~~~~~ */
+/* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) */
+
+/* References */
+/* ~~~~~~~~~~ */
+/* [1] A. A. Anda and H. Park: Fast plane rotations with dynamic scaling. */
+/* SIAM J. matrix Anal. Appl., Vol. 15 (1994), pp. 162-174. */
+/* [2] P. P. M. De Rijk: A one-sided Jacobi algorithm for computing the */
+/* singular value decomposition on a vector computer. */
+/* SIAM J. Sci. Stat. Comp., Vol. 10 (1998), pp. 359-371. */
+/* [3] J. Demmel and K. Veselic: Jacobi method is more accurate than QR. */
+/* [4] Z. Drmac: Implementation of Jacobi rotations for accurate singular */
+/* value computation in floating point arithmetic. */
+/* SIAM J. Sci. Comp., Vol. 18 (1997), pp. 1200-1222. */
+/* [5] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I. */
+/* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342. */
+/* LAPACK Working note 169. */
+/* [6] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II. */
+/* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362. */
+/* LAPACK Working note 170. */
+/* [7] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV, */
+/* QSVD, (H,K)-SVD computations. */
+/* Department of Mathematics, University of Zagreb, 2008. */
+
+/* Bugs, Examples and Comments */
+/* ~~~~~~~~~~~~~~~~~~~~~~~~~~~ */
+/* Please report all bugs and send interesting test examples and comments to */
+/* drmac at math.hr. Thank you. */
+
+/* Arguments */
+/* ~~~~~~~~~ */
+
+/* JOBA (input) CHARACTER* 1 */
+/* Specifies the structure of A. */
+/* = 'L': The input matrix A is lower triangular; */
+/* = 'U': The input matrix A is upper triangular; */
+/* = 'G': The input matrix A is general M-by-N matrix, M >= N. */
+
+/* JOBU (input) CHARACTER*1 */
+/* Specifies whether to compute the left singular vectors */
+/* (columns of U): */
+
+/* = 'U': The left singular vectors corresponding to the nonzero */
+/* singular values are computed and returned in the leading */
+/* columns of A. See more details in the description of A. */
+/* The default numerical orthogonality threshold is set to */
+/* approximately TOL=CTOL*EPS, CTOL=SQRT(M), EPS=SLAMCH('E'). */
+/* = 'C': Analogous to JOBU='U', except that user can control the */
+/* level of numerical orthogonality of the computed left */
+/* singular vectors. TOL can be set to TOL = CTOL*EPS, where */
+/* CTOL is given on input in the array WORK. */
+/* No CTOL smaller than ONE is allowed. CTOL greater */
+/* than 1 / EPS is meaningless. The option 'C' */
+/* can be used if M*EPS is satisfactory orthogonality */
+/* of the computed left singular vectors, so CTOL=M could */
+/* save few sweeps of Jacobi rotations. */
+/* See the descriptions of A and WORK(1). */
+/* = 'N': The matrix U is not computed. However, see the */
+/* description of A. */
+
+/* JOBV (input) CHARACTER*1 */
+/* Specifies whether to compute the right singular vectors, that */
+/* is, the matrix V: */
+/* = 'V' : the matrix V is computed and returned in the array V */
+/* = 'A' : the Jacobi rotations are applied to the MV-by-N */
+/* array V. In other words, the right singular vector */
+/* matrix V is not computed explicitly; instead it is */
+/* applied to an MV-by-N matrix initially stored in the */
+/* first MV rows of V. */
+/* = 'N' : the matrix V is not computed and the array V is not */
+/* referenced */
+
+/* M (input) INTEGER */
+/* The number of rows of the input matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the input matrix A. */
+/* M >= N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, */
+/* If JOBU .EQ. 'U' .OR. JOBU .EQ. 'C': */
+/* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ */
+/* If INFO .EQ. 0, */
+/* ~~~~~~~~~~~~~~~ */
+/* RANKA orthonormal columns of U are returned in the */
+/* leading RANKA columns of the array A. Here RANKA <= N */
+/* is the number of computed singular values of A that are */
+/* above the underflow threshold SLAMCH('S'). The singular */
+/* vectors corresponding to underflowed or zero singular */
+/* values are not computed. The value of RANKA is returned */
+/* in the array WORK as RANKA=NINT(WORK(2)). Also see the */
+/* descriptions of SVA and WORK. The computed columns of U */
+/* are mutually numerically orthogonal up to approximately */
+/* TOL=SQRT(M)*EPS (default); or TOL=CTOL*EPS (JOBU.EQ.'C'), */
+/* see the description of JOBU. */
+/* If INFO .GT. 0, */
+/* ~~~~~~~~~~~~~~~ */
+/* the procedure SGESVJ did not converge in the given number */
+/* of iterations (sweeps). In that case, the computed */
+/* columns of U may not be orthogonal up to TOL. The output */
+/* U (stored in A), SIGMA (given by the computed singular */
+/* values in SVA(1:N)) and V is still a decomposition of the */
+/* input matrix A in the sense that the residual */
+/* ||A-SCALE*U*SIGMA*V^T||_2 / ||A||_2 is small. */
+
+/* If JOBU .EQ. 'N': */
+/* ~~~~~~~~~~~~~~~~~ */
+/* If INFO .EQ. 0 */
+/* ~~~~~~~~~~~~~~ */
+/* Note that the left singular vectors are 'for free' in the */
+/* one-sided Jacobi SVD algorithm. However, if only the */
+/* singular values are needed, the level of numerical */
+/* orthogonality of U is not an issue and iterations are */
+/* stopped when the columns of the iterated matrix are */
+/* numerically orthogonal up to approximately M*EPS. Thus, */
+/* on exit, A contains the columns of U scaled with the */
+/* corresponding singular values. */
+/* If INFO .GT. 0, */
+/* ~~~~~~~~~~~~~~~ */
+/* the procedure SGESVJ did not converge in the given number */
+/* of iterations (sweeps). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* SVA (workspace/output) REAL array, dimension (N) */
+/* On exit, */
+/* If INFO .EQ. 0, */
+/* ~~~~~~~~~~~~~~~ */
+/* depending on the value SCALE = WORK(1), we have: */
+/* If SCALE .EQ. ONE: */
+/* ~~~~~~~~~~~~~~~~~~ */
+/* SVA(1:N) contains the computed singular values of A. */
+/* During the computation SVA contains the Euclidean column */
+/* norms of the iterated matrices in the array A. */
+/* If SCALE .NE. ONE: */
+/* ~~~~~~~~~~~~~~~~~~ */
+/* The singular values of A are SCALE*SVA(1:N), and this */
+/* factored representation is due to the fact that some of the */
+/* singular values of A might underflow or overflow. */
+
+/* If INFO .GT. 0, */
+/* ~~~~~~~~~~~~~~~ */
+/* the procedure SGESVJ did not converge in the given number of */
+/* iterations (sweeps) and SCALE*SVA(1:N) may not be accurate. */
+
+/* MV (input) INTEGER */
+/* If JOBV .EQ. 'A', then the product of Jacobi rotations in SGESVJ */
+/* is applied to the first MV rows of V. See the description of JOBV. */
+
+/* V (input/output) REAL array, dimension (LDV,N) */
+/* If JOBV = 'V', then V contains on exit the N-by-N matrix of */
+/* the right singular vectors; */
+/* If JOBV = 'A', then V contains the product of the computed right */
+/* singular vector matrix and the initial matrix in */
+/* the array V. */
+/* If JOBV = 'N', then V is not referenced. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V, LDV .GE. 1. */
+/* If JOBV .EQ. 'V', then LDV .GE. max(1,N). */
+/* If JOBV .EQ. 'A', then LDV .GE. max(1,MV) . */
+
+/* WORK (input/workspace/output) REAL array, dimension max(4,M+N). */
+/* On entry, */
+/* If JOBU .EQ. 'C', */
+/* ~~~~~~~~~~~~~~~~~ */
+/* WORK(1) = CTOL, where CTOL defines the threshold for convergence. */
+/* The process stops if all columns of A are mutually */
+/* orthogonal up to CTOL*EPS, EPS=SLAMCH('E'). */
+/* It is required that CTOL >= ONE, i.e. it is not */
+/* allowed to force the routine to obtain orthogonality */
+/* below EPSILON. */
+/* On exit, */
+/* WORK(1) = SCALE is the scaling factor such that SCALE*SVA(1:N) */
+/* are the computed singular vcalues of A. */
+/* (See description of SVA().) */
+/* WORK(2) = NINT(WORK(2)) is the number of the computed nonzero */
+/* singular values. */
+/* WORK(3) = NINT(WORK(3)) is the number of the computed singular */
+/* values that are larger than the underflow threshold. */
+/* WORK(4) = NINT(WORK(4)) is the number of sweeps of Jacobi */
+/* rotations needed for numerical convergence. */
+/* WORK(5) = max_{i.NE.j} |COS(A(:,i),A(:,j))| in the last sweep. */
+/* This is useful information in cases when SGESVJ did */
+/* not converge, as it can be used to estimate whether */
+/* the output is stil useful and for post festum analysis. */
+/* WORK(6) = the largest absolute value over all sines of the */
+/* Jacobi rotation angles in the last sweep. It can be */
+/* useful for a post festum analysis. */
+
+/* LWORK length of WORK, WORK >= MAX(6,M+N) */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit. */
+/* < 0 : if INFO = -i, then the i-th argument had an illegal value */
+/* > 0 : SGESVJ did not converge in the maximal allowed number (30) */
+/* of sweeps. The output may still be useful. See the */
+/* description of WORK. */
+
+/* Local Parameters */
+
+
+/* Local Scalars */
+
+
+/* Local Arrays */
+
+
+/* Intrinsic Functions */
+
+
+/* External Functions */
+/* .. from BLAS */
+/* .. from LAPACK */
+
+/* External Subroutines */
+/* .. from BLAS */
+/* .. from LAPACK */
+
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --sva;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --work;
+
+ /* Function Body */
+ lsvec = lsame_(jobu, "U");
+ uctol = lsame_(jobu, "C");
+ rsvec = lsame_(jobv, "V");
+ applv = lsame_(jobv, "A");
+ upper = lsame_(joba, "U");
+ lower = lsame_(joba, "L");
+
+ if (! (upper || lower || lsame_(joba, "G"))) {
+ *info = -1;
+ } else if (! (lsvec || uctol || lsame_(jobu, "N")))
+ {
+ *info = -2;
+ } else if (! (rsvec || applv || lsame_(jobv, "N")))
+ {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*n < 0 || *n > *m) {
+ *info = -5;
+ } else if (*lda < *m) {
+ *info = -7;
+ } else if (*mv < 0) {
+ *info = -9;
+ } else if (rsvec && *ldv < *n || applv && *ldv < *mv) {
+ *info = -11;
+ } else if (uctol && work[1] <= 1.f) {
+ *info = -12;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = *m + *n;
+ if (*lwork < max(i__1,6)) {
+ *info = -13;
+ } else {
+ *info = 0;
+ }
+ }
+
+/* #:( */
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGESVJ", &i__1);
+ return 0;
+ }
+
+/* #:) Quick return for void matrix */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Set numerical parameters */
+/* The stopping criterion for Jacobi rotations is */
+
+/* max_{i<>j}|A(:,i)^T * A(:,j)|/(||A(:,i)||*||A(:,j)||) < CTOL*EPS */
+
+/* where EPS is the round-off and CTOL is defined as follows: */
+
+ if (uctol) {
+/* ... user controlled */
+ ctol = work[1];
+ } else {
+/* ... default */
+ if (lsvec || rsvec || applv) {
+ ctol = sqrt((real) (*m));
+ } else {
+ ctol = (real) (*m);
+ }
+ }
+/* ... and the machine dependent parameters are */
+/* [!] (Make sure that SLAMCH() works properly on the target machine.) */
+
+ epsilon = slamch_("Epsilon");
+ rooteps = sqrt(epsilon);
+ sfmin = slamch_("SafeMinimum");
+ rootsfmin = sqrt(sfmin);
+ small = sfmin / epsilon;
+ big = slamch_("Overflow");
+ rootbig = 1.f / rootsfmin;
+ large = big / sqrt((real) (*m * *n));
+ bigtheta = 1.f / rooteps;
+
+ tol = ctol * epsilon;
+ roottol = sqrt(tol);
+
+ if ((real) (*m) * epsilon >= 1.f) {
+ *info = -5;
+ i__1 = -(*info);
+ xerbla_("SGESVJ", &i__1);
+ return 0;
+ }
+
+/* Initialize the right singular vector matrix. */
+
+ if (rsvec) {
+ mvl = *n;
+ slaset_("A", &mvl, n, &c_b17, &c_b18, &v[v_offset], ldv);
+ } else if (applv) {
+ mvl = *mv;
+ }
+ rsvec = rsvec || applv;
+
+/* Initialize SVA( 1:N ) = ( ||A e_i||_2, i = 1:N ) */
+/* (!) If necessary, scale A to protect the largest singular value */
+/* from overflow. It is possible that saving the largest singular */
+/* value destroys the information about the small ones. */
+/* This initial scaling is almost minimal in the sense that the */
+/* goal is to make sure that no column norm overflows, and that */
+/* SQRT(N)*max_i SVA(i) does not overflow. If INFinite entries */
+/* in A are detected, the procedure returns with INFO=-6. */
+
+ scale = 1.f / sqrt((real) (*m) * (real) (*n));
+ noscale = TRUE_;
+ goscale = TRUE_;
+
+ if (lower) {
+/* the input matrix is M-by-N lower triangular (trapezoidal) */
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ aapp = 0.f;
+ aaqq = 0.f;
+ i__2 = *m - p + 1;
+ slassq_(&i__2, &a[p + p * a_dim1], &c__1, &aapp, &aaqq);
+ if (aapp > big) {
+ *info = -6;
+ i__2 = -(*info);
+ xerbla_("SGESVJ", &i__2);
+ return 0;
+ }
+ aaqq = sqrt(aaqq);
+ if (aapp < big / aaqq && noscale) {
+ sva[p] = aapp * aaqq;
+ } else {
+ noscale = FALSE_;
+ sva[p] = aapp * (aaqq * scale);
+ if (goscale) {
+ goscale = FALSE_;
+ i__2 = p - 1;
+ for (q = 1; q <= i__2; ++q) {
+ sva[q] *= scale;
+/* L1873: */
+ }
+ }
+ }
+/* L1874: */
+ }
+ } else if (upper) {
+/* the input matrix is M-by-N upper triangular (trapezoidal) */
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ aapp = 0.f;
+ aaqq = 0.f;
+ slassq_(&p, &a[p * a_dim1 + 1], &c__1, &aapp, &aaqq);
+ if (aapp > big) {
+ *info = -6;
+ i__2 = -(*info);
+ xerbla_("SGESVJ", &i__2);
+ return 0;
+ }
+ aaqq = sqrt(aaqq);
+ if (aapp < big / aaqq && noscale) {
+ sva[p] = aapp * aaqq;
+ } else {
+ noscale = FALSE_;
+ sva[p] = aapp * (aaqq * scale);
+ if (goscale) {
+ goscale = FALSE_;
+ i__2 = p - 1;
+ for (q = 1; q <= i__2; ++q) {
+ sva[q] *= scale;
+/* L2873: */
+ }
+ }
+ }
+/* L2874: */
+ }
+ } else {
+/* the input matrix is M-by-N general dense */
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ aapp = 0.f;
+ aaqq = 0.f;
+ slassq_(m, &a[p * a_dim1 + 1], &c__1, &aapp, &aaqq);
+ if (aapp > big) {
+ *info = -6;
+ i__2 = -(*info);
+ xerbla_("SGESVJ", &i__2);
+ return 0;
+ }
+ aaqq = sqrt(aaqq);
+ if (aapp < big / aaqq && noscale) {
+ sva[p] = aapp * aaqq;
+ } else {
+ noscale = FALSE_;
+ sva[p] = aapp * (aaqq * scale);
+ if (goscale) {
+ goscale = FALSE_;
+ i__2 = p - 1;
+ for (q = 1; q <= i__2; ++q) {
+ sva[q] *= scale;
+/* L3873: */
+ }
+ }
+ }
+/* L3874: */
+ }
+ }
+
+ if (noscale) {
+ scale = 1.f;
+ }
+
+/* Move the smaller part of the spectrum from the underflow threshold */
+/* (!) Start by determining the position of the nonzero entries of the */
+/* array SVA() relative to ( SFMIN, BIG ). */
+
+ aapp = 0.f;
+ aaqq = big;
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ if (sva[p] != 0.f) {
+/* Computing MIN */
+ r__1 = aaqq, r__2 = sva[p];
+ aaqq = dmin(r__1,r__2);
+ }
+/* Computing MAX */
+ r__1 = aapp, r__2 = sva[p];
+ aapp = dmax(r__1,r__2);
+/* L4781: */
+ }
+
+/* #:) Quick return for zero matrix */
+
+ if (aapp == 0.f) {
+ if (lsvec) {
+ slaset_("G", m, n, &c_b17, &c_b18, &a[a_offset], lda);
+ }
+ work[1] = 1.f;
+ work[2] = 0.f;
+ work[3] = 0.f;
+ work[4] = 0.f;
+ work[5] = 0.f;
+ work[6] = 0.f;
+ return 0;
+ }
+
+/* #:) Quick return for one-column matrix */
+
+ if (*n == 1) {
+ if (lsvec) {
+ slascl_("G", &c__0, &c__0, &sva[1], &scale, m, &c__1, &a[a_dim1 +
+ 1], lda, &ierr);
+ }
+ work[1] = 1.f / scale;
+ if (sva[1] >= sfmin) {
+ work[2] = 1.f;
+ } else {
+ work[2] = 0.f;
+ }
+ work[3] = 0.f;
+ work[4] = 0.f;
+ work[5] = 0.f;
+ work[6] = 0.f;
+ return 0;
+ }
+
+/* Protect small singular values from underflow, and try to */
+/* avoid underflows/overflows in computing Jacobi rotations. */
+
+ sn = sqrt(sfmin / epsilon);
+ temp1 = sqrt(big / (real) (*n));
+ if (aapp <= sn || aaqq >= temp1 || sn <= aaqq && aapp <= temp1) {
+/* Computing MIN */
+ r__1 = big, r__2 = temp1 / aapp;
+ temp1 = dmin(r__1,r__2);
+/* AAQQ = AAQQ*TEMP1 */
+/* AAPP = AAPP*TEMP1 */
+ } else if (aaqq <= sn && aapp <= temp1) {
+/* Computing MIN */
+ r__1 = sn / aaqq, r__2 = big / (aapp * sqrt((real) (*n)));
+ temp1 = dmin(r__1,r__2);
+/* AAQQ = AAQQ*TEMP1 */
+/* AAPP = AAPP*TEMP1 */
+ } else if (aaqq >= sn && aapp >= temp1) {
+/* Computing MAX */
+ r__1 = sn / aaqq, r__2 = temp1 / aapp;
+ temp1 = dmax(r__1,r__2);
+/* AAQQ = AAQQ*TEMP1 */
+/* AAPP = AAPP*TEMP1 */
+ } else if (aaqq <= sn && aapp >= temp1) {
+/* Computing MIN */
+ r__1 = sn / aaqq, r__2 = big / (sqrt((real) (*n)) * aapp);
+ temp1 = dmin(r__1,r__2);
+/* AAQQ = AAQQ*TEMP1 */
+/* AAPP = AAPP*TEMP1 */
+ } else {
+ temp1 = 1.f;
+ }
+
+/* Scale, if necessary */
+
+ if (temp1 != 1.f) {
+ slascl_("G", &c__0, &c__0, &c_b18, &temp1, n, &c__1, &sva[1], n, &
+ ierr);
+ }
+ scale = temp1 * scale;
+ if (scale != 1.f) {
+ slascl_(joba, &c__0, &c__0, &c_b18, &scale, m, n, &a[a_offset], lda, &
+ ierr);
+ scale = 1.f / scale;
+ }
+
+/* Row-cyclic Jacobi SVD algorithm with column pivoting */
+
+ emptsw = *n * (*n - 1) / 2;
+ notrot = 0;
+ fastr[0] = 0.f;
+
+/* A is represented in factored form A = A * diag(WORK), where diag(WORK) */
+/* is initialized to identity. WORK is updated during fast scaled */
+/* rotations. */
+
+ i__1 = *n;
+ for (q = 1; q <= i__1; ++q) {
+ work[q] = 1.f;
+/* L1868: */
+ }
+
+
+ swband = 3;
+/* [TP] SWBAND is a tuning parameter [TP]. It is meaningful and effective */
+/* if SGESVJ is used as a computational routine in the preconditioned */
+/* Jacobi SVD algorithm SGESVJ. For sweeps i=1:SWBAND the procedure */
+/* works on pivots inside a band-like region around the diagonal. */
+/* The boundaries are determined dynamically, based on the number of */
+/* pivots above a threshold. */
+
+ kbl = min(8,*n);
+/* [TP] KBL is a tuning parameter that defines the tile size in the */
+/* tiling of the p-q loops of pivot pairs. In general, an optimal */
+/* value of KBL depends on the matrix dimensions and on the */
+/* parameters of the computer's memory. */
+
+ nbl = *n / kbl;
+ if (nbl * kbl != *n) {
+ ++nbl;
+ }
+
+/* Computing 2nd power */
+ i__1 = kbl;
+ blskip = i__1 * i__1;
+/* [TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. */
+
+ rowskip = min(5,kbl);
+/* [TP] ROWSKIP is a tuning parameter. */
+
+ lkahead = 1;
+/* [TP] LKAHEAD is a tuning parameter. */
+
+/* Quasi block transformations, using the lower (upper) triangular */
+/* structure of the input matrix. The quasi-block-cycling usually */
+/* invokes cubic convergence. Big part of this cycle is done inside */
+/* canonical subspaces of dimensions less than M. */
+
+/* Computing MAX */
+ i__1 = 64, i__2 = kbl << 2;
+ if ((lower || upper) && *n > max(i__1,i__2)) {
+/* [TP] The number of partition levels and the actual partition are */
+/* tuning parameters. */
+ n4 = *n / 4;
+ n2 = *n / 2;
+ n34 = n4 * 3;
+ if (applv) {
+ q = 0;
+ } else {
+ q = 1;
+ }
+
+ if (lower) {
+
+/* This works very well on lower triangular matrices, in particular */
+/* in the framework of the preconditioned Jacobi SVD (xGEJSV). */
+/* The idea is simple: */
+/* [+ 0 0 0] Note that Jacobi transformations of [0 0] */
+/* [+ + 0 0] [0 0] */
+/* [+ + x 0] actually work on [x 0] [x 0] */
+/* [+ + x x] [x x]. [x x] */
+
+ i__1 = *m - n34;
+ i__2 = *n - n34;
+ i__3 = *lwork - *n;
+ sgsvj0_(jobv, &i__1, &i__2, &a[n34 + 1 + (n34 + 1) * a_dim1], lda,
+ &work[n34 + 1], &sva[n34 + 1], &mvl, &v[n34 * q + 1 + (
+ n34 + 1) * v_dim1], ldv, &epsilon, &sfmin, &tol, &c__2, &
+ work[*n + 1], &i__3, &ierr);
+
+ i__1 = *m - n2;
+ i__2 = n34 - n2;
+ i__3 = *lwork - *n;
+ sgsvj0_(jobv, &i__1, &i__2, &a[n2 + 1 + (n2 + 1) * a_dim1], lda, &
+ work[n2 + 1], &sva[n2 + 1], &mvl, &v[n2 * q + 1 + (n2 + 1)
+ * v_dim1], ldv, &epsilon, &sfmin, &tol, &c__2, &work[*n
+ + 1], &i__3, &ierr);
+
+ i__1 = *m - n2;
+ i__2 = *n - n2;
+ i__3 = *lwork - *n;
+ sgsvj1_(jobv, &i__1, &i__2, &n4, &a[n2 + 1 + (n2 + 1) * a_dim1],
+ lda, &work[n2 + 1], &sva[n2 + 1], &mvl, &v[n2 * q + 1 + (
+ n2 + 1) * v_dim1], ldv, &epsilon, &sfmin, &tol, &c__1, &
+ work[*n + 1], &i__3, &ierr);
+
+ i__1 = *m - n4;
+ i__2 = n2 - n4;
+ i__3 = *lwork - *n;
+ sgsvj0_(jobv, &i__1, &i__2, &a[n4 + 1 + (n4 + 1) * a_dim1], lda, &
+ work[n4 + 1], &sva[n4 + 1], &mvl, &v[n4 * q + 1 + (n4 + 1)
+ * v_dim1], ldv, &epsilon, &sfmin, &tol, &c__1, &work[*n
+ + 1], &i__3, &ierr);
+
+ i__1 = *lwork - *n;
+ sgsvj0_(jobv, m, &n4, &a[a_offset], lda, &work[1], &sva[1], &mvl,
+ &v[v_offset], ldv, &epsilon, &sfmin, &tol, &c__1, &work[*
+ n + 1], &i__1, &ierr);
+
+ i__1 = *lwork - *n;
+ sgsvj1_(jobv, m, &n2, &n4, &a[a_offset], lda, &work[1], &sva[1], &
+ mvl, &v[v_offset], ldv, &epsilon, &sfmin, &tol, &c__1, &
+ work[*n + 1], &i__1, &ierr);
+
+
+ } else if (upper) {
+
+
+ i__1 = *lwork - *n;
+ sgsvj0_(jobv, &n4, &n4, &a[a_offset], lda, &work[1], &sva[1], &
+ mvl, &v[v_offset], ldv, &epsilon, &sfmin, &tol, &c__2, &
+ work[*n + 1], &i__1, &ierr);
+
+ i__1 = *lwork - *n;
+ sgsvj0_(jobv, &n2, &n4, &a[(n4 + 1) * a_dim1 + 1], lda, &work[n4
+ + 1], &sva[n4 + 1], &mvl, &v[n4 * q + 1 + (n4 + 1) *
+ v_dim1], ldv, &epsilon, &sfmin, &tol, &c__1, &work[*n + 1]
+, &i__1, &ierr);
+
+ i__1 = *lwork - *n;
+ sgsvj1_(jobv, &n2, &n2, &n4, &a[a_offset], lda, &work[1], &sva[1],
+ &mvl, &v[v_offset], ldv, &epsilon, &sfmin, &tol, &c__1, &
+ work[*n + 1], &i__1, &ierr);
+
+ i__1 = n2 + n4;
+ i__2 = *lwork - *n;
+ sgsvj0_(jobv, &i__1, &n4, &a[(n2 + 1) * a_dim1 + 1], lda, &work[
+ n2 + 1], &sva[n2 + 1], &mvl, &v[n2 * q + 1 + (n2 + 1) *
+ v_dim1], ldv, &epsilon, &sfmin, &tol, &c__1, &work[*n + 1]
+, &i__2, &ierr);
+ }
+
+ }
+
+/* -#- Row-cyclic pivot strategy with de Rijk's pivoting -#- */
+
+ for (i__ = 1; i__ <= 30; ++i__) {
+/* .. go go go ... */
+
+ mxaapq = 0.f;
+ mxsinj = 0.f;
+ iswrot = 0;
+
+ notrot = 0;
+ pskipped = 0;
+
+/* Each sweep is unrolled using KBL-by-KBL tiles over the pivot pairs */
+/* 1 <= p < q <= N. This is the first step toward a blocked implementation */
+/* of the rotations. New implementation, based on block transformations, */
+/* is under development. */
+
+ i__1 = nbl;
+ for (ibr = 1; ibr <= i__1; ++ibr) {
+
+ igl = (ibr - 1) * kbl + 1;
+
+/* Computing MIN */
+ i__3 = lkahead, i__4 = nbl - ibr;
+ i__2 = min(i__3,i__4);
+ for (ir1 = 0; ir1 <= i__2; ++ir1) {
+
+ igl += ir1 * kbl;
+
+/* Computing MIN */
+ i__4 = igl + kbl - 1, i__5 = *n - 1;
+ i__3 = min(i__4,i__5);
+ for (p = igl; p <= i__3; ++p) {
+
+/* .. de Rijk's pivoting */
+
+ i__4 = *n - p + 1;
+ q = isamax_(&i__4, &sva[p], &c__1) + p - 1;
+ if (p != q) {
+ sswap_(m, &a[p * a_dim1 + 1], &c__1, &a[q * a_dim1 +
+ 1], &c__1);
+ if (rsvec) {
+ sswap_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q *
+ v_dim1 + 1], &c__1);
+ }
+ temp1 = sva[p];
+ sva[p] = sva[q];
+ sva[q] = temp1;
+ temp1 = work[p];
+ work[p] = work[q];
+ work[q] = temp1;
+ }
+
+ if (ir1 == 0) {
+
+/* Column norms are periodically updated by explicit */
+/* norm computation. */
+/* Caveat: */
+/* Unfortunately, some BLAS implementations compute SNRM2(M,A(1,p),1) */
+/* as SQRT(SDOT(M,A(1,p),1,A(1,p),1)), which may cause the result to */
+/* overflow for ||A(:,p)||_2 > SQRT(overflow_threshold), and to */
+/* underflow for ||A(:,p)||_2 < SQRT(underflow_threshold). */
+/* Hence, SNRM2 cannot be trusted, not even in the case when */
+/* the true norm is far from the under(over)flow boundaries. */
+/* If properly implemented SNRM2 is available, the IF-THEN-ELSE */
+/* below should read "AAPP = SNRM2( M, A(1,p), 1 ) * WORK(p)". */
+
+ if (sva[p] < rootbig && sva[p] > rootsfmin) {
+ sva[p] = snrm2_(m, &a[p * a_dim1 + 1], &c__1) *
+ work[p];
+ } else {
+ temp1 = 0.f;
+ aapp = 0.f;
+ slassq_(m, &a[p * a_dim1 + 1], &c__1, &temp1, &
+ aapp);
+ sva[p] = temp1 * sqrt(aapp) * work[p];
+ }
+ aapp = sva[p];
+ } else {
+ aapp = sva[p];
+ }
+
+ if (aapp > 0.f) {
+
+ pskipped = 0;
+
+/* Computing MIN */
+ i__5 = igl + kbl - 1;
+ i__4 = min(i__5,*n);
+ for (q = p + 1; q <= i__4; ++q) {
+
+ aaqq = sva[q];
+
+ if (aaqq > 0.f) {
+
+ aapp0 = aapp;
+ if (aaqq >= 1.f) {
+ rotok = small * aapp <= aaqq;
+ if (aapp < big / aaqq) {
+ aapq = sdot_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1], &
+ c__1) * work[p] * work[q] /
+ aaqq / aapp;
+ } else {
+ scopy_(m, &a[p * a_dim1 + 1], &c__1, &
+ work[*n + 1], &c__1);
+ slascl_("G", &c__0, &c__0, &aapp, &
+ work[p], m, &c__1, &work[*n +
+ 1], lda, &ierr);
+ aapq = sdot_(m, &work[*n + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1) *
+ work[q] / aaqq;
+ }
+ } else {
+ rotok = aapp <= aaqq / small;
+ if (aapp > small / aaqq) {
+ aapq = sdot_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1], &
+ c__1) * work[p] * work[q] /
+ aaqq / aapp;
+ } else {
+ scopy_(m, &a[q * a_dim1 + 1], &c__1, &
+ work[*n + 1], &c__1);
+ slascl_("G", &c__0, &c__0, &aaqq, &
+ work[q], m, &c__1, &work[*n +
+ 1], lda, &ierr);
+ aapq = sdot_(m, &work[*n + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1) *
+ work[p] / aapp;
+ }
+ }
+
+/* Computing MAX */
+ r__1 = mxaapq, r__2 = dabs(aapq);
+ mxaapq = dmax(r__1,r__2);
+
+/* TO rotate or NOT to rotate, THAT is the question ... */
+
+ if (dabs(aapq) > tol) {
+
+/* .. rotate */
+/* [RTD] ROTATED = ROTATED + ONE */
+
+ if (ir1 == 0) {
+ notrot = 0;
+ pskipped = 0;
+ ++iswrot;
+ }
+
+ if (rotok) {
+
+ aqoap = aaqq / aapp;
+ apoaq = aapp / aaqq;
+ theta = (r__1 = aqoap - apoaq, dabs(
+ r__1)) * -.5f / aapq;
+
+ if (dabs(theta) > bigtheta) {
+
+ t = .5f / theta;
+ fastr[2] = t * work[p] / work[q];
+ fastr[3] = -t * work[q] / work[p];
+ srotm_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1],
+ &c__1, fastr);
+ if (rsvec) {
+ srotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q *
+ v_dim1 + 1], &c__1, fastr);
+ }
+/* Computing MAX */
+ r__1 = 0.f, r__2 = t * apoaq *
+ aapq + 1.f;
+ sva[q] = aaqq * sqrt((dmax(r__1,
+ r__2)));
+ aapp *= sqrt(1.f - t * aqoap *
+ aapq);
+/* Computing MAX */
+ r__1 = mxsinj, r__2 = dabs(t);
+ mxsinj = dmax(r__1,r__2);
+
+ } else {
+
+/* .. choose correct signum for THETA and rotate */
+
+ thsign = -r_sign(&c_b18, &aapq);
+ t = 1.f / (theta + thsign * sqrt(
+ theta * theta + 1.f));
+ cs = sqrt(1.f / (t * t + 1.f));
+ sn = t * cs;
+
+/* Computing MAX */
+ r__1 = mxsinj, r__2 = dabs(sn);
+ mxsinj = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = 0.f, r__2 = t * apoaq *
+ aapq + 1.f;
+ sva[q] = aaqq * sqrt((dmax(r__1,
+ r__2)));
+/* Computing MAX */
+ r__1 = 0.f, r__2 = 1.f - t *
+ aqoap * aapq;
+ aapp *= sqrt((dmax(r__1,r__2)));
+
+ apoaq = work[p] / work[q];
+ aqoap = work[q] / work[p];
+ if (work[p] >= 1.f) {
+ if (work[q] >= 1.f) {
+ fastr[2] = t * apoaq;
+ fastr[3] = -t * aqoap;
+ work[p] *= cs;
+ work[q] *= cs;
+ srotm_(m, &a[p * a_dim1 + 1], &c__1, &a[q *
+ a_dim1 + 1], &c__1, fastr);
+ if (rsvec) {
+ srotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[
+ q * v_dim1 + 1], &c__1, fastr);
+ }
+ } else {
+ r__1 = -t * aqoap;
+ saxpy_(m, &r__1, &a[q * a_dim1 + 1], &c__1, &a[
+ p * a_dim1 + 1], &c__1);
+ r__1 = cs * sn * apoaq;
+ saxpy_(m, &r__1, &a[p * a_dim1 + 1], &c__1, &a[
+ q * a_dim1 + 1], &c__1);
+ work[p] *= cs;
+ work[q] /= cs;
+ if (rsvec) {
+ r__1 = -t * aqoap;
+ saxpy_(&mvl, &r__1, &v[q * v_dim1 + 1], &
+ c__1, &v[p * v_dim1 + 1], &c__1);
+ r__1 = cs * sn * apoaq;
+ saxpy_(&mvl, &r__1, &v[p * v_dim1 + 1], &
+ c__1, &v[q * v_dim1 + 1], &c__1);
+ }
+ }
+ } else {
+ if (work[q] >= 1.f) {
+ r__1 = t * apoaq;
+ saxpy_(m, &r__1, &a[p * a_dim1 + 1], &c__1, &a[
+ q * a_dim1 + 1], &c__1);
+ r__1 = -cs * sn * aqoap;
+ saxpy_(m, &r__1, &a[q * a_dim1 + 1], &c__1, &a[
+ p * a_dim1 + 1], &c__1);
+ work[p] /= cs;
+ work[q] *= cs;
+ if (rsvec) {
+ r__1 = t * apoaq;
+ saxpy_(&mvl, &r__1, &v[p * v_dim1 + 1], &
+ c__1, &v[q * v_dim1 + 1], &c__1);
+ r__1 = -cs * sn * aqoap;
+ saxpy_(&mvl, &r__1, &v[q * v_dim1 + 1], &
+ c__1, &v[p * v_dim1 + 1], &c__1);
+ }
+ } else {
+ if (work[p] >= work[q]) {
+ r__1 = -t * aqoap;
+ saxpy_(m, &r__1, &a[q * a_dim1 + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1);
+ r__1 = cs * sn * apoaq;
+ saxpy_(m, &r__1, &a[p * a_dim1 + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1);
+ work[p] *= cs;
+ work[q] /= cs;
+ if (rsvec) {
+ r__1 = -t * aqoap;
+ saxpy_(&mvl, &r__1, &v[q * v_dim1 + 1],
+ &c__1, &v[p * v_dim1 + 1], &
+ c__1);
+ r__1 = cs * sn * apoaq;
+ saxpy_(&mvl, &r__1, &v[p * v_dim1 + 1],
+ &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ }
+ } else {
+ r__1 = t * apoaq;
+ saxpy_(m, &r__1, &a[p * a_dim1 + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1);
+ r__1 = -cs * sn * aqoap;
+ saxpy_(m, &r__1, &a[q * a_dim1 + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1);
+ work[p] /= cs;
+ work[q] *= cs;
+ if (rsvec) {
+ r__1 = t * apoaq;
+ saxpy_(&mvl, &r__1, &v[p * v_dim1 + 1],
+ &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ r__1 = -cs * sn * aqoap;
+ saxpy_(&mvl, &r__1, &v[q * v_dim1 + 1],
+ &c__1, &v[p * v_dim1 + 1], &
+ c__1);
+ }
+ }
+ }
+ }
+ }
+
+ } else {
+/* .. have to use modified Gram-Schmidt like transformation */
+ scopy_(m, &a[p * a_dim1 + 1], &c__1, &
+ work[*n + 1], &c__1);
+ slascl_("G", &c__0, &c__0, &aapp, &
+ c_b18, m, &c__1, &work[*n + 1]
+, lda, &ierr);
+ slascl_("G", &c__0, &c__0, &aaqq, &
+ c_b18, m, &c__1, &a[q *
+ a_dim1 + 1], lda, &ierr);
+ temp1 = -aapq * work[p] / work[q];
+ saxpy_(m, &temp1, &work[*n + 1], &
+ c__1, &a[q * a_dim1 + 1], &
+ c__1);
+ slascl_("G", &c__0, &c__0, &c_b18, &
+ aaqq, m, &c__1, &a[q * a_dim1
+ + 1], lda, &ierr);
+/* Computing MAX */
+ r__1 = 0.f, r__2 = 1.f - aapq * aapq;
+ sva[q] = aaqq * sqrt((dmax(r__1,r__2))
+ );
+ mxsinj = dmax(mxsinj,sfmin);
+ }
+/* END IF ROTOK THEN ... ELSE */
+
+/* In the case of cancellation in updating SVA(q), SVA(p) */
+/* recompute SVA(q), SVA(p). */
+
+/* Computing 2nd power */
+ r__1 = sva[q] / aaqq;
+ if (r__1 * r__1 <= rooteps) {
+ if (aaqq < rootbig && aaqq >
+ rootsfmin) {
+ sva[q] = snrm2_(m, &a[q * a_dim1
+ + 1], &c__1) * work[q];
+ } else {
+ t = 0.f;
+ aaqq = 0.f;
+ slassq_(m, &a[q * a_dim1 + 1], &
+ c__1, &t, &aaqq);
+ sva[q] = t * sqrt(aaqq) * work[q];
+ }
+ }
+ if (aapp / aapp0 <= rooteps) {
+ if (aapp < rootbig && aapp >
+ rootsfmin) {
+ aapp = snrm2_(m, &a[p * a_dim1 +
+ 1], &c__1) * work[p];
+ } else {
+ t = 0.f;
+ aapp = 0.f;
+ slassq_(m, &a[p * a_dim1 + 1], &
+ c__1, &t, &aapp);
+ aapp = t * sqrt(aapp) * work[p];
+ }
+ sva[p] = aapp;
+ }
+
+ } else {
+/* A(:,p) and A(:,q) already numerically orthogonal */
+ if (ir1 == 0) {
+ ++notrot;
+ }
+/* [RTD] SKIPPED = SKIPPED + 1 */
+ ++pskipped;
+ }
+ } else {
+/* A(:,q) is zero column */
+ if (ir1 == 0) {
+ ++notrot;
+ }
+ ++pskipped;
+ }
+
+ if (i__ <= swband && pskipped > rowskip) {
+ if (ir1 == 0) {
+ aapp = -aapp;
+ }
+ notrot = 0;
+ goto L2103;
+ }
+
+/* L2002: */
+ }
+/* END q-LOOP */
+
+L2103:
+/* bailed out of q-loop */
+
+ sva[p] = aapp;
+
+ } else {
+ sva[p] = aapp;
+ if (ir1 == 0 && aapp == 0.f) {
+/* Computing MIN */
+ i__4 = igl + kbl - 1;
+ notrot = notrot + min(i__4,*n) - p;
+ }
+ }
+
+/* L2001: */
+ }
+/* end of the p-loop */
+/* end of doing the block ( ibr, ibr ) */
+/* L1002: */
+ }
+/* end of ir1-loop */
+
+/* ... go to the off diagonal blocks */
+
+ igl = (ibr - 1) * kbl + 1;
+
+ i__2 = nbl;
+ for (jbc = ibr + 1; jbc <= i__2; ++jbc) {
+
+ jgl = (jbc - 1) * kbl + 1;
+
+/* doing the block at ( ibr, jbc ) */
+
+ ijblsk = 0;
+/* Computing MIN */
+ i__4 = igl + kbl - 1;
+ i__3 = min(i__4,*n);
+ for (p = igl; p <= i__3; ++p) {
+
+ aapp = sva[p];
+ if (aapp > 0.f) {
+
+ pskipped = 0;
+
+/* Computing MIN */
+ i__5 = jgl + kbl - 1;
+ i__4 = min(i__5,*n);
+ for (q = jgl; q <= i__4; ++q) {
+
+ aaqq = sva[q];
+ if (aaqq > 0.f) {
+ aapp0 = aapp;
+
+/* -#- M x 2 Jacobi SVD -#- */
+
+/* Safe Gram matrix computation */
+
+ if (aaqq >= 1.f) {
+ if (aapp >= aaqq) {
+ rotok = small * aapp <= aaqq;
+ } else {
+ rotok = small * aaqq <= aapp;
+ }
+ if (aapp < big / aaqq) {
+ aapq = sdot_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1], &
+ c__1) * work[p] * work[q] /
+ aaqq / aapp;
+ } else {
+ scopy_(m, &a[p * a_dim1 + 1], &c__1, &
+ work[*n + 1], &c__1);
+ slascl_("G", &c__0, &c__0, &aapp, &
+ work[p], m, &c__1, &work[*n +
+ 1], lda, &ierr);
+ aapq = sdot_(m, &work[*n + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1) *
+ work[q] / aaqq;
+ }
+ } else {
+ if (aapp >= aaqq) {
+ rotok = aapp <= aaqq / small;
+ } else {
+ rotok = aaqq <= aapp / small;
+ }
+ if (aapp > small / aaqq) {
+ aapq = sdot_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1], &
+ c__1) * work[p] * work[q] /
+ aaqq / aapp;
+ } else {
+ scopy_(m, &a[q * a_dim1 + 1], &c__1, &
+ work[*n + 1], &c__1);
+ slascl_("G", &c__0, &c__0, &aaqq, &
+ work[q], m, &c__1, &work[*n +
+ 1], lda, &ierr);
+ aapq = sdot_(m, &work[*n + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1) *
+ work[p] / aapp;
+ }
+ }
+
+/* Computing MAX */
+ r__1 = mxaapq, r__2 = dabs(aapq);
+ mxaapq = dmax(r__1,r__2);
+
+/* TO rotate or NOT to rotate, THAT is the question ... */
+
+ if (dabs(aapq) > tol) {
+ notrot = 0;
+/* [RTD] ROTATED = ROTATED + 1 */
+ pskipped = 0;
+ ++iswrot;
+
+ if (rotok) {
+
+ aqoap = aaqq / aapp;
+ apoaq = aapp / aaqq;
+ theta = (r__1 = aqoap - apoaq, dabs(
+ r__1)) * -.5f / aapq;
+ if (aaqq > aapp0) {
+ theta = -theta;
+ }
+
+ if (dabs(theta) > bigtheta) {
+ t = .5f / theta;
+ fastr[2] = t * work[p] / work[q];
+ fastr[3] = -t * work[q] / work[p];
+ srotm_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1],
+ &c__1, fastr);
+ if (rsvec) {
+ srotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q *
+ v_dim1 + 1], &c__1, fastr);
+ }
+/* Computing MAX */
+ r__1 = 0.f, r__2 = t * apoaq *
+ aapq + 1.f;
+ sva[q] = aaqq * sqrt((dmax(r__1,
+ r__2)));
+/* Computing MAX */
+ r__1 = 0.f, r__2 = 1.f - t *
+ aqoap * aapq;
+ aapp *= sqrt((dmax(r__1,r__2)));
+/* Computing MAX */
+ r__1 = mxsinj, r__2 = dabs(t);
+ mxsinj = dmax(r__1,r__2);
+ } else {
+
+/* .. choose correct signum for THETA and rotate */
+
+ thsign = -r_sign(&c_b18, &aapq);
+ if (aaqq > aapp0) {
+ thsign = -thsign;
+ }
+ t = 1.f / (theta + thsign * sqrt(
+ theta * theta + 1.f));
+ cs = sqrt(1.f / (t * t + 1.f));
+ sn = t * cs;
+/* Computing MAX */
+ r__1 = mxsinj, r__2 = dabs(sn);
+ mxsinj = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = 0.f, r__2 = t * apoaq *
+ aapq + 1.f;
+ sva[q] = aaqq * sqrt((dmax(r__1,
+ r__2)));
+ aapp *= sqrt(1.f - t * aqoap *
+ aapq);
+
+ apoaq = work[p] / work[q];
+ aqoap = work[q] / work[p];
+ if (work[p] >= 1.f) {
+
+ if (work[q] >= 1.f) {
+ fastr[2] = t * apoaq;
+ fastr[3] = -t * aqoap;
+ work[p] *= cs;
+ work[q] *= cs;
+ srotm_(m, &a[p * a_dim1 + 1], &c__1, &a[q *
+ a_dim1 + 1], &c__1, fastr);
+ if (rsvec) {
+ srotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[
+ q * v_dim1 + 1], &c__1, fastr);
+ }
+ } else {
+ r__1 = -t * aqoap;
+ saxpy_(m, &r__1, &a[q * a_dim1 + 1], &c__1, &a[
+ p * a_dim1 + 1], &c__1);
+ r__1 = cs * sn * apoaq;
+ saxpy_(m, &r__1, &a[p * a_dim1 + 1], &c__1, &a[
+ q * a_dim1 + 1], &c__1);
+ if (rsvec) {
+ r__1 = -t * aqoap;
+ saxpy_(&mvl, &r__1, &v[q * v_dim1 + 1], &
+ c__1, &v[p * v_dim1 + 1], &c__1);
+ r__1 = cs * sn * apoaq;
+ saxpy_(&mvl, &r__1, &v[p * v_dim1 + 1], &
+ c__1, &v[q * v_dim1 + 1], &c__1);
+ }
+ work[p] *= cs;
+ work[q] /= cs;
+ }
+ } else {
+ if (work[q] >= 1.f) {
+ r__1 = t * apoaq;
+ saxpy_(m, &r__1, &a[p * a_dim1 + 1], &c__1, &a[
+ q * a_dim1 + 1], &c__1);
+ r__1 = -cs * sn * aqoap;
+ saxpy_(m, &r__1, &a[q * a_dim1 + 1], &c__1, &a[
+ p * a_dim1 + 1], &c__1);
+ if (rsvec) {
+ r__1 = t * apoaq;
+ saxpy_(&mvl, &r__1, &v[p * v_dim1 + 1], &
+ c__1, &v[q * v_dim1 + 1], &c__1);
+ r__1 = -cs * sn * aqoap;
+ saxpy_(&mvl, &r__1, &v[q * v_dim1 + 1], &
+ c__1, &v[p * v_dim1 + 1], &c__1);
+ }
+ work[p] /= cs;
+ work[q] *= cs;
+ } else {
+ if (work[p] >= work[q]) {
+ r__1 = -t * aqoap;
+ saxpy_(m, &r__1, &a[q * a_dim1 + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1);
+ r__1 = cs * sn * apoaq;
+ saxpy_(m, &r__1, &a[p * a_dim1 + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1);
+ work[p] *= cs;
+ work[q] /= cs;
+ if (rsvec) {
+ r__1 = -t * aqoap;
+ saxpy_(&mvl, &r__1, &v[q * v_dim1 + 1],
+ &c__1, &v[p * v_dim1 + 1], &
+ c__1);
+ r__1 = cs * sn * apoaq;
+ saxpy_(&mvl, &r__1, &v[p * v_dim1 + 1],
+ &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ }
+ } else {
+ r__1 = t * apoaq;
+ saxpy_(m, &r__1, &a[p * a_dim1 + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1);
+ r__1 = -cs * sn * aqoap;
+ saxpy_(m, &r__1, &a[q * a_dim1 + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1);
+ work[p] /= cs;
+ work[q] *= cs;
+ if (rsvec) {
+ r__1 = t * apoaq;
+ saxpy_(&mvl, &r__1, &v[p * v_dim1 + 1],
+ &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ r__1 = -cs * sn * aqoap;
+ saxpy_(&mvl, &r__1, &v[q * v_dim1 + 1],
+ &c__1, &v[p * v_dim1 + 1], &
+ c__1);
+ }
+ }
+ }
+ }
+ }
+
+ } else {
+ if (aapp > aaqq) {
+ scopy_(m, &a[p * a_dim1 + 1], &
+ c__1, &work[*n + 1], &
+ c__1);
+ slascl_("G", &c__0, &c__0, &aapp,
+ &c_b18, m, &c__1, &work[*
+ n + 1], lda, &ierr);
+ slascl_("G", &c__0, &c__0, &aaqq,
+ &c_b18, m, &c__1, &a[q *
+ a_dim1 + 1], lda, &ierr);
+ temp1 = -aapq * work[p] / work[q];
+ saxpy_(m, &temp1, &work[*n + 1], &
+ c__1, &a[q * a_dim1 + 1],
+ &c__1);
+ slascl_("G", &c__0, &c__0, &c_b18,
+ &aaqq, m, &c__1, &a[q *
+ a_dim1 + 1], lda, &ierr);
+/* Computing MAX */
+ r__1 = 0.f, r__2 = 1.f - aapq *
+ aapq;
+ sva[q] = aaqq * sqrt((dmax(r__1,
+ r__2)));
+ mxsinj = dmax(mxsinj,sfmin);
+ } else {
+ scopy_(m, &a[q * a_dim1 + 1], &
+ c__1, &work[*n + 1], &
+ c__1);
+ slascl_("G", &c__0, &c__0, &aaqq,
+ &c_b18, m, &c__1, &work[*
+ n + 1], lda, &ierr);
+ slascl_("G", &c__0, &c__0, &aapp,
+ &c_b18, m, &c__1, &a[p *
+ a_dim1 + 1], lda, &ierr);
+ temp1 = -aapq * work[q] / work[p];
+ saxpy_(m, &temp1, &work[*n + 1], &
+ c__1, &a[p * a_dim1 + 1],
+ &c__1);
+ slascl_("G", &c__0, &c__0, &c_b18,
+ &aapp, m, &c__1, &a[p *
+ a_dim1 + 1], lda, &ierr);
+/* Computing MAX */
+ r__1 = 0.f, r__2 = 1.f - aapq *
+ aapq;
+ sva[p] = aapp * sqrt((dmax(r__1,
+ r__2)));
+ mxsinj = dmax(mxsinj,sfmin);
+ }
+ }
+/* END IF ROTOK THEN ... ELSE */
+
+/* In the case of cancellation in updating SVA(q) */
+/* .. recompute SVA(q) */
+/* Computing 2nd power */
+ r__1 = sva[q] / aaqq;
+ if (r__1 * r__1 <= rooteps) {
+ if (aaqq < rootbig && aaqq >
+ rootsfmin) {
+ sva[q] = snrm2_(m, &a[q * a_dim1
+ + 1], &c__1) * work[q];
+ } else {
+ t = 0.f;
+ aaqq = 0.f;
+ slassq_(m, &a[q * a_dim1 + 1], &
+ c__1, &t, &aaqq);
+ sva[q] = t * sqrt(aaqq) * work[q];
+ }
+ }
+/* Computing 2nd power */
+ r__1 = aapp / aapp0;
+ if (r__1 * r__1 <= rooteps) {
+ if (aapp < rootbig && aapp >
+ rootsfmin) {
+ aapp = snrm2_(m, &a[p * a_dim1 +
+ 1], &c__1) * work[p];
+ } else {
+ t = 0.f;
+ aapp = 0.f;
+ slassq_(m, &a[p * a_dim1 + 1], &
+ c__1, &t, &aapp);
+ aapp = t * sqrt(aapp) * work[p];
+ }
+ sva[p] = aapp;
+ }
+/* end of OK rotation */
+ } else {
+ ++notrot;
+/* [RTD] SKIPPED = SKIPPED + 1 */
+ ++pskipped;
+ ++ijblsk;
+ }
+ } else {
+ ++notrot;
+ ++pskipped;
+ ++ijblsk;
+ }
+
+ if (i__ <= swband && ijblsk >= blskip) {
+ sva[p] = aapp;
+ notrot = 0;
+ goto L2011;
+ }
+ if (i__ <= swband && pskipped > rowskip) {
+ aapp = -aapp;
+ notrot = 0;
+ goto L2203;
+ }
+
+/* L2200: */
+ }
+/* end of the q-loop */
+L2203:
+
+ sva[p] = aapp;
+
+ } else {
+
+ if (aapp == 0.f) {
+/* Computing MIN */
+ i__4 = jgl + kbl - 1;
+ notrot = notrot + min(i__4,*n) - jgl + 1;
+ }
+ if (aapp < 0.f) {
+ notrot = 0;
+ }
+
+ }
+
+/* L2100: */
+ }
+/* end of the p-loop */
+/* L2010: */
+ }
+/* end of the jbc-loop */
+L2011:
+/* 2011 bailed out of the jbc-loop */
+/* Computing MIN */
+ i__3 = igl + kbl - 1;
+ i__2 = min(i__3,*n);
+ for (p = igl; p <= i__2; ++p) {
+ sva[p] = (r__1 = sva[p], dabs(r__1));
+/* L2012: */
+ }
+/* ** */
+/* L2000: */
+ }
+/* 2000 :: end of the ibr-loop */
+
+/* .. update SVA(N) */
+ if (sva[*n] < rootbig && sva[*n] > rootsfmin) {
+ sva[*n] = snrm2_(m, &a[*n * a_dim1 + 1], &c__1) * work[*n];
+ } else {
+ t = 0.f;
+ aapp = 0.f;
+ slassq_(m, &a[*n * a_dim1 + 1], &c__1, &t, &aapp);
+ sva[*n] = t * sqrt(aapp) * work[*n];
+ }
+
+/* Additional steering devices */
+
+ if (i__ < swband && (mxaapq <= roottol || iswrot <= *n)) {
+ swband = i__;
+ }
+
+ if (i__ > swband + 1 && mxaapq < sqrt((real) (*n)) * tol && (real) (*
+ n) * mxaapq * mxsinj < tol) {
+ goto L1994;
+ }
+
+ if (notrot >= emptsw) {
+ goto L1994;
+ }
+
+/* L1993: */
+ }
+/* end i=1:NSWEEP loop */
+
+/* #:( Reaching this point means that the procedure has not converged. */
+ *info = 29;
+ goto L1995;
+
+L1994:
+/* #:) Reaching this point means numerical convergence after the i-th */
+/* sweep. */
+
+ *info = 0;
+/* #:) INFO = 0 confirms successful iterations. */
+L1995:
+
+/* Sort the singular values and find how many are above */
+/* the underflow threshold. */
+
+ n2 = 0;
+ n4 = 0;
+ i__1 = *n - 1;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = *n - p + 1;
+ q = isamax_(&i__2, &sva[p], &c__1) + p - 1;
+ if (p != q) {
+ temp1 = sva[p];
+ sva[p] = sva[q];
+ sva[q] = temp1;
+ temp1 = work[p];
+ work[p] = work[q];
+ work[q] = temp1;
+ sswap_(m, &a[p * a_dim1 + 1], &c__1, &a[q * a_dim1 + 1], &c__1);
+ if (rsvec) {
+ sswap_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ }
+ }
+ if (sva[p] != 0.f) {
+ ++n4;
+ if (sva[p] * scale > sfmin) {
+ ++n2;
+ }
+ }
+/* L5991: */
+ }
+ if (sva[*n] != 0.f) {
+ ++n4;
+ if (sva[*n] * scale > sfmin) {
+ ++n2;
+ }
+ }
+
+/* Normalize the left singular vectors. */
+
+ if (lsvec || uctol) {
+ i__1 = n2;
+ for (p = 1; p <= i__1; ++p) {
+ r__1 = work[p] / sva[p];
+ sscal_(m, &r__1, &a[p * a_dim1 + 1], &c__1);
+/* L1998: */
+ }
+ }
+
+/* Scale the product of Jacobi rotations (assemble the fast rotations). */
+
+ if (rsvec) {
+ if (applv) {
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ sscal_(&mvl, &work[p], &v[p * v_dim1 + 1], &c__1);
+/* L2398: */
+ }
+ } else {
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ temp1 = 1.f / snrm2_(&mvl, &v[p * v_dim1 + 1], &c__1);
+ sscal_(&mvl, &temp1, &v[p * v_dim1 + 1], &c__1);
+/* L2399: */
+ }
+ }
+ }
+
+/* Undo scaling, if necessary (and possible). */
+ if (scale > 1.f && sva[1] < big / scale || scale < 1.f && sva[n2] > sfmin
+ / scale) {
+ i__1 = *n;
+ for (p = 1; p <= i__1; ++p) {
+ sva[p] = scale * sva[p];
+/* L2400: */
+ }
+ scale = 1.f;
+ }
+
+ work[1] = scale;
+/* The singular values of A are SCALE*SVA(1:N). If SCALE.NE.ONE */
+/* then some of the singular values may overflow or underflow and */
+/* the spectrum is given in this factored representation. */
+
+ work[2] = (real) n4;
+/* N4 is the number of computed nonzero singular values of A. */
+
+ work[3] = (real) n2;
+/* N2 is the number of singular values of A greater than SFMIN. */
+/* If N2<N, SVA(N2:N) contains ZEROS and/or denormalized numbers */
+/* that may carry some information. */
+
+ work[4] = (real) i__;
+/* i is the index of the last sweep before declaring convergence. */
+
+ work[5] = mxaapq;
+/* MXAAPQ is the largest absolute value of scaled pivots in the */
+/* last sweep */
+
+ work[6] = mxsinj;
+/* MXSINJ is the largest absolute value of the sines of Jacobi angles */
+/* in the last sweep */
+
+ return 0;
+/* .. */
+/* .. END OF SGESVJ */
+/* .. */
+} /* sgesvj_ */
diff --git a/SRC/sgesvx.c b/SRC/sgesvx.c
new file mode 100644
index 0000000..932cccf
--- /dev/null
+++ b/SRC/sgesvx.c
@@ -0,0 +1,582 @@
+/* sgesvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sgesvx_(char *fact, char *trans, integer *n, integer *
+ nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv,
+ char *equed, real *r__, real *c__, real *b, integer *ldb, real *x,
+ integer *ldx, real *rcond, real *ferr, real *berr, real *work,
+ integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer i__, j;
+ real amax;
+ char norm[1];
+ extern logical lsame_(char *, char *);
+ real rcmin, rcmax, anorm;
+ logical equil;
+ real colcnd;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ logical nofact;
+ extern /* Subroutine */ int slaqge_(integer *, integer *, real *, integer
+ *, real *, real *, real *, real *, real *, char *),
+ xerbla_(char *, integer *), sgecon_(char *, integer *,
+ real *, integer *, real *, real *, real *, integer *, integer *);
+ real bignum;
+ integer infequ;
+ logical colequ;
+ extern /* Subroutine */ int sgeequ_(integer *, integer *, real *, integer
+ *, real *, real *, real *, real *, real *, integer *), sgerfs_(
+ char *, integer *, integer *, real *, integer *, real *, integer *
+, integer *, real *, integer *, real *, integer *, real *, real *,
+ real *, integer *, integer *), sgetrf_(integer *,
+ integer *, real *, integer *, integer *, integer *);
+ real rowcnd;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+ logical notran;
+ extern doublereal slantr_(char *, char *, char *, integer *, integer *,
+ real *, integer *, real *);
+ extern /* Subroutine */ int sgetrs_(char *, integer *, integer *, real *,
+ integer *, integer *, real *, integer *, integer *);
+ real smlnum;
+ logical rowequ;
+ real rpvgrw;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGESVX uses the LU factorization to compute the solution to a real */
+/* system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */
+/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */
+/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */
+/* or diag(C)*B (if TRANS = 'T' or 'C'). */
+
+/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the */
+/* matrix A (after equilibration if FACT = 'E') as */
+/* A = P * L * U, */
+/* where P is a permutation matrix, L is a unit lower triangular */
+/* matrix, and U is upper triangular. */
+
+/* 3. If some U(i,i)=0, so that U is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */
+/* that it solves the original system before equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF and IPIV contain the factored form of A. */
+/* If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by R and C. */
+/* A, AF, and IPIV are not modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is */
+/* not 'N', then A must have been equilibrated by the scaling */
+/* factors in R and/or C. A is not modified if FACT = 'F' or */
+/* 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
+
+/* On exit, if EQUED .ne. 'N', A is scaled as follows: */
+/* EQUED = 'R': A := diag(R) * A */
+/* EQUED = 'C': A := A * diag(C) */
+/* EQUED = 'B': A := diag(R) * A * diag(C). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) REAL array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the factors L and U from the factorization */
+/* A = P*L*U as computed by SGETRF. If EQUED .ne. 'N', then */
+/* AF is the factored form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the equilibrated matrix A (see the description of A for */
+/* the form of the equilibrated matrix). */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* as computed by SGETRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the equilibrated matrix A. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* R (input or output) REAL array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+
+/* C (input or output) REAL array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */
+/* diag(R)*B; */
+/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */
+/* overwritten by diag(C)*B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) REAL array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X */
+/* to the original system of equations. Note that A and B are */
+/* modified on exit if EQUED .ne. 'N', and the solution to the */
+/* equilibrated system is inv(diag(C))*X if TRANS = 'N' and */
+/* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' */
+/* and EQUED = 'R' or 'B'. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A after equilibration (if done). If RCOND is less than the */
+/* machine precision (in particular, if RCOND = 0), the matrix */
+/* is singular to working precision. This condition is */
+/* indicated by a return code of INFO > 0. */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace/output) REAL array, dimension (4*N) */
+/* On exit, WORK(1) contains the reciprocal pivot growth */
+/* factor norm(A)/norm(U). The "max absolute element" norm is */
+/* used. If WORK(1) is much less than 1, then the stability */
+/* of the LU factorization of the (equilibrated) matrix A */
+/* could be poor. This also means that the solution X, condition */
+/* estimator RCOND, and forward error bound FERR could be */
+/* unreliable. If factorization fails with 0<INFO<=N, then */
+/* WORK(1) contains the reciprocal pivot growth factor for the */
+/* leading INFO columns of A. */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: U(i,i) is exactly zero. The factorization has */
+/* been completed, but the factor U is exactly */
+/* singular, so the solution and error bounds */
+/* could not be computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ notran = lsame_(trans, "N");
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rowequ = FALSE_;
+ colequ = FALSE_;
+ } else {
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ }
+
+/* Test the input parameters. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (lsame_(fact, "F") && ! (rowequ || colequ
+ || lsame_(equed, "N"))) {
+ *info = -10;
+ } else {
+ if (rowequ) {
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = r__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = r__[j];
+ rcmax = dmax(r__1,r__2);
+/* L10: */
+ }
+ if (rcmin <= 0.f) {
+ *info = -11;
+ } else if (*n > 0) {
+ rowcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ } else {
+ rowcnd = 1.f;
+ }
+ }
+ if (colequ && *info == 0) {
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = c__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = c__[j];
+ rcmax = dmax(r__1,r__2);
+/* L20: */
+ }
+ if (rcmin <= 0.f) {
+ *info = -12;
+ } else if (*n > 0) {
+ colcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ } else {
+ colcnd = 1.f;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -14;
+ } else if (*ldx < max(1,*n)) {
+ *info = -16;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGESVX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ sgeequ_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &colcnd, &
+ amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ slaqge_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &
+ colcnd, &amax, equed);
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+ }
+
+/* Scale the right hand side. */
+
+ if (notran) {
+ if (rowequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = r__[i__] * b[i__ + j * b_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else if (colequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = c__[i__] * b[i__ + j * b_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of A. */
+
+ slacpy_("Full", n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ sgetrf_(n, n, &af[af_offset], ldaf, &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ rpvgrw = slantr_("M", "U", "N", info, info, &af[af_offset], ldaf,
+ &work[1]);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = slange_("M", n, info, &a[a_offset], lda, &work[1]) / rpvgrw;
+ }
+ work[1] = rpvgrw;
+ *rcond = 0.f;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A and the */
+/* reciprocal pivot growth factor RPVGRW. */
+
+ if (notran) {
+ *(unsigned char *)norm = '1';
+ } else {
+ *(unsigned char *)norm = 'I';
+ }
+ anorm = slange_(norm, n, n, &a[a_offset], lda, &work[1]);
+ rpvgrw = slantr_("M", "U", "N", n, n, &af[af_offset], ldaf, &work[1]);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = slange_("M", n, n, &a[a_offset], lda, &work[1]) /
+ rpvgrw;
+ }
+
+/* Compute the reciprocal of the condition number of A. */
+
+ sgecon_(norm, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &iwork[1],
+ info);
+
+/* Compute the solution matrix X. */
+
+ slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ sgetrs_(trans, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ sgerfs_(trans, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1],
+ &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[
+ 1], &iwork[1], info);
+
+/* Transform the solution matrix X to a solution of the original */
+/* system. */
+
+ if (notran) {
+ if (colequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__ + j * x_dim1] = c__[i__] * x[i__ + j * x_dim1];
+/* L70: */
+ }
+/* L80: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= colcnd;
+/* L90: */
+ }
+ }
+ } else if (rowequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__ + j * x_dim1] = r__[i__] * x[i__ + j * x_dim1];
+/* L100: */
+ }
+/* L110: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= rowcnd;
+/* L120: */
+ }
+ }
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < slamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ work[1] = rpvgrw;
+ return 0;
+
+/* End of SGESVX */
+
+} /* sgesvx_ */
diff --git a/SRC/sgesvxx.c b/SRC/sgesvxx.c
new file mode 100644
index 0000000..eef0b9a
--- /dev/null
+++ b/SRC/sgesvxx.c
@@ -0,0 +1,711 @@
+/* sgesvxx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sgesvxx_(char *fact, char *trans, integer *n, integer *
+ nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv,
+ char *equed, real *r__, real *c__, real *b, integer *ldb, real *x,
+ integer *ldx, real *rcond, real *rpvgrw, real *berr, integer *
+ n_err_bnds__, real *err_bnds_norm__, real *err_bnds_comp__, integer *
+ nparams, real *params, real *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j;
+ extern doublereal sla_rpvgrw__(integer *, integer *, real *, integer *,
+ real *, integer *);
+ real amax;
+ extern logical lsame_(char *, char *);
+ real rcmin, rcmax;
+ logical equil;
+ real colcnd;
+ extern doublereal slamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int slaqge_(integer *, integer *, real *, integer
+ *, real *, real *, real *, real *, real *, char *),
+ xerbla_(char *, integer *);
+ real bignum;
+ integer infequ;
+ logical colequ;
+ extern /* Subroutine */ int sgetrf_(integer *, integer *, real *, integer
+ *, integer *, integer *), slacpy_(char *, integer *, integer *,
+ real *, integer *, real *, integer *);
+ real rowcnd;
+ logical notran;
+ extern /* Subroutine */ int sgetrs_(char *, integer *, integer *, real *,
+ integer *, integer *, real *, integer *, integer *);
+ real smlnum;
+ logical rowequ;
+ extern /* Subroutine */ int slascl2_(integer *, integer *, real *, real *,
+ integer *), sgeequb_(integer *, integer *, real *, integer *,
+ real *, real *, real *, real *, real *, integer *), sgerfsx_(char
+ *, char *, integer *, integer *, real *, integer *, real *,
+ integer *, integer *, real *, real *, real *, integer *, real *,
+ integer *, real *, real *, integer *, real *, real *, integer *,
+ real *, real *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGESVXX uses the LU factorization to compute the solution to a */
+/* real system of linear equations A * X = B, where A is an */
+/* N-by-N matrix and X and B are N-by-NRHS matrices. */
+
+/* If requested, both normwise and maximum componentwise error bounds */
+/* are returned. SGESVXX will return a solution with a tiny */
+/* guaranteed error (O(eps) where eps is the working machine */
+/* precision) unless the matrix is very ill-conditioned, in which */
+/* case a warning is returned. Relevant condition numbers also are */
+/* calculated and returned. */
+
+/* SGESVXX accepts user-provided factorizations and equilibration */
+/* factors; see the definitions of the FACT and EQUED options. */
+/* Solving with refinement and using a factorization from a previous */
+/* SGESVXX call will also produce a solution with either O(eps) */
+/* errors or warnings, but we cannot make that claim for general */
+/* user-provided factorizations and equilibration factors if they */
+/* differ from what SGESVXX would itself produce. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+
+/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */
+/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */
+/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */
+
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */
+/* or diag(C)*B (if TRANS = 'T' or 'C'). */
+
+/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */
+/* the matrix A (after equilibration if FACT = 'E') as */
+
+/* A = P * L * U, */
+
+/* where P is a permutation matrix, L is a unit lower triangular */
+/* matrix, and U is upper triangular. */
+
+/* 3. If some U(i,i)=0, so that U is exactly singular, then the */
+/* routine returns with INFO = i. Otherwise, the factored form of A */
+/* is used to estimate the condition number of the matrix A (see */
+/* argument RCOND). If the reciprocal of the condition number is less */
+/* than machine precision, the routine still goes on to solve for X */
+/* and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */
+/* the routine will use iterative refinement to try to get a small */
+/* error and error bounds. Refinement calculates the residual to at */
+/* least twice the working precision. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */
+/* that it solves the original system before equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF and IPIV contain the factored form of A. */
+/* If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by R and C. */
+/* A, AF, and IPIV are not modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is */
+/* not 'N', then A must have been equilibrated by the scaling */
+/* factors in R and/or C. A is not modified if FACT = 'F' or */
+/* 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
+
+/* On exit, if EQUED .ne. 'N', A is scaled as follows: */
+/* EQUED = 'R': A := diag(R) * A */
+/* EQUED = 'C': A := A * diag(C) */
+/* EQUED = 'B': A := diag(R) * A * diag(C). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) REAL array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the factors L and U from the factorization */
+/* A = P*L*U as computed by SGETRF. If EQUED .ne. 'N', then */
+/* AF is the factored form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the equilibrated matrix A (see the description of A for */
+/* the form of the equilibrated matrix). */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* as computed by SGETRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the equilibrated matrix A. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* R (input or output) REAL array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+/* If R is output, each element of R is a power of the radix. */
+/* If R is input, each element of R should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* C (input or output) REAL array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+/* If C is output, each element of C is a power of the radix. */
+/* If C is input, each element of C should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */
+/* diag(R)*B; */
+/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */
+/* overwritten by diag(C)*B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) REAL array, dimension (LDX,NRHS) */
+/* If INFO = 0, the N-by-NRHS solution matrix X to the original */
+/* system of equations. Note that A and B are modified on exit */
+/* if EQUED .ne. 'N', and the solution to the equilibrated system is */
+/* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or */
+/* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* RPVGRW (output) REAL */
+/* Reciprocal pivot growth. On exit, this contains the reciprocal */
+/* pivot growth factor norm(A)/norm(U). The "max absolute element" */
+/* norm is used. If this is much less than 1, then the stability of */
+/* the LU factorization of the (equilibrated) matrix A could be poor. */
+/* This also means that the solution X, estimated condition numbers, */
+/* and error bounds could be unreliable. If factorization fails with */
+/* 0<INFO<=N, then this contains the reciprocal pivot growth factor */
+/* for the leading INFO columns of A. In SGESVX, this quantity is */
+/* returned in WORK(1). */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) REAL array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) REAL array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ notran = lsame_(trans, "N");
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rowequ = FALSE_;
+ colequ = FALSE_;
+ } else {
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+
+/* Default is failure. If an input parameter is wrong or */
+/* factorization fails, make everything look horrible. Only the */
+/* pivot growth is set here, the rest is initialized in SGERFSX. */
+
+ *rpvgrw = 0.f;
+
+/* Test the input parameters. PARAMS is not tested until SGERFSX. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (lsame_(fact, "F") && ! (rowequ || colequ
+ || lsame_(equed, "N"))) {
+ *info = -10;
+ } else {
+ if (rowequ) {
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = r__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = r__[j];
+ rcmax = dmax(r__1,r__2);
+/* L10: */
+ }
+ if (rcmin <= 0.f) {
+ *info = -11;
+ } else if (*n > 0) {
+ rowcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ } else {
+ rowcnd = 1.f;
+ }
+ }
+ if (colequ && *info == 0) {
+ rcmin = bignum;
+ rcmax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = c__[j];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = c__[j];
+ rcmax = dmax(r__1,r__2);
+/* L20: */
+ }
+ if (rcmin <= 0.f) {
+ *info = -12;
+ } else if (*n > 0) {
+ colcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
+ } else {
+ colcnd = 1.f;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -14;
+ } else if (*ldx < max(1,*n)) {
+ *info = -16;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGESVXX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ sgeequb_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &colcnd,
+ &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ slaqge_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &
+ colcnd, &amax, equed);
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+
+/* If the scaling factors are not applied, set them to 1.0. */
+
+ if (! rowequ) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ r__[j] = 1.f;
+ }
+ }
+ if (! colequ) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 1.f;
+ }
+ }
+ }
+
+/* Scale the right-hand side. */
+
+ if (notran) {
+ if (rowequ) {
+ slascl2_(n, nrhs, &r__[1], &b[b_offset], ldb);
+ }
+ } else {
+ if (colequ) {
+ slascl2_(n, nrhs, &c__[1], &b[b_offset], ldb);
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of A. */
+
+ slacpy_("Full", n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ sgetrf_(n, n, &af[af_offset], ldaf, &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Pivot in column INFO is exactly 0 */
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ *rpvgrw = sla_rpvgrw__(n, info, &a[a_offset], lda, &af[af_offset],
+ ldaf);
+ return 0;
+ }
+ }
+
+/* Compute the reciprocal pivot growth factor RPVGRW. */
+
+ *rpvgrw = sla_rpvgrw__(n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+
+/* Compute the solution matrix X. */
+
+ slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ sgetrs_(trans, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ sgerfsx_(trans, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &
+ ipiv[1], &r__[1], &c__[1], &b[b_offset], ldb, &x[x_offset], ldx,
+ rcond, &berr[1], n_err_bnds__, &err_bnds_norm__[
+ err_bnds_norm_offset], &err_bnds_comp__[err_bnds_comp_offset],
+ nparams, ¶ms[1], &work[1], &iwork[1], info);
+
+/* Scale solutions. */
+
+ if (colequ && notran) {
+ slascl2_(n, nrhs, &c__[1], &x[x_offset], ldx);
+ } else if (rowequ && ! notran) {
+ slascl2_(n, nrhs, &r__[1], &x[x_offset], ldx);
+ }
+
+ return 0;
+
+/* End of SGESVXX */
+} /* sgesvxx_ */
diff --git a/SRC/sgetc2.c b/SRC/sgetc2.c
new file mode 100644
index 0000000..5c375cb
--- /dev/null
+++ b/SRC/sgetc2.c
@@ -0,0 +1,198 @@
+/* sgetc2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b10 = -1.f;
+
+/* Subroutine */ int sgetc2_(integer *n, real *a, integer *lda, integer *ipiv,
+ integer *jpiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j, ip, jp;
+ real eps;
+ integer ipv, jpv;
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ real smin, xmax;
+ extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
+ integer *), slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ real bignum, smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGETC2 computes an LU factorization with complete pivoting of the */
+/* n-by-n matrix A. The factorization has the form A = P * L * U * Q, */
+/* where P and Q are permutation matrices, L is lower triangular with */
+/* unit diagonal elements and U is upper triangular. */
+
+/* This is the Level 2 BLAS algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA, N) */
+/* On entry, the n-by-n matrix A to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U*Q; the unit diagonal elements of L are not stored. */
+/* If U(k, k) appears to be less than SMIN, U(k, k) is given the */
+/* value of SMIN, i.e., giving a nonsingular perturbed system. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension(N). */
+/* The pivot indices; for 1 <= i <= N, row i of the */
+/* matrix has been interchanged with row IPIV(i). */
+
+/* JPIV (output) INTEGER array, dimension(N). */
+/* The pivot indices; for 1 <= j <= N, column j of the */
+/* matrix has been interchanged with column JPIV(j). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* > 0: if INFO = k, U(k, k) is likely to produce owerflow if */
+/* we try to solve for x in Ax = b. So U is perturbed to */
+/* avoid the overflow. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Set constants to control overflow */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --jpiv;
+
+ /* Function Body */
+ *info = 0;
+ eps = slamch_("P");
+ smlnum = slamch_("S") / eps;
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Factorize A using complete pivoting. */
+/* Set pivots less than SMIN to SMIN. */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Find max element in matrix A */
+
+ xmax = 0.f;
+ i__2 = *n;
+ for (ip = i__; ip <= i__2; ++ip) {
+ i__3 = *n;
+ for (jp = i__; jp <= i__3; ++jp) {
+ if ((r__1 = a[ip + jp * a_dim1], dabs(r__1)) >= xmax) {
+ xmax = (r__1 = a[ip + jp * a_dim1], dabs(r__1));
+ ipv = ip;
+ jpv = jp;
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+ if (i__ == 1) {
+/* Computing MAX */
+ r__1 = eps * xmax;
+ smin = dmax(r__1,smlnum);
+ }
+
+/* Swap rows */
+
+ if (ipv != i__) {
+ sswap_(n, &a[ipv + a_dim1], lda, &a[i__ + a_dim1], lda);
+ }
+ ipiv[i__] = ipv;
+
+/* Swap columns */
+
+ if (jpv != i__) {
+ sswap_(n, &a[jpv * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
+ c__1);
+ }
+ jpiv[i__] = jpv;
+
+/* Check for singularity */
+
+ if ((r__1 = a[i__ + i__ * a_dim1], dabs(r__1)) < smin) {
+ *info = i__;
+ a[i__ + i__ * a_dim1] = smin;
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ a[j + i__ * a_dim1] /= a[i__ + i__ * a_dim1];
+/* L30: */
+ }
+ i__2 = *n - i__;
+ i__3 = *n - i__;
+ sger_(&i__2, &i__3, &c_b10, &a[i__ + 1 + i__ * a_dim1], &c__1, &a[i__
+ + (i__ + 1) * a_dim1], lda, &a[i__ + 1 + (i__ + 1) * a_dim1],
+ lda);
+/* L40: */
+ }
+
+ if ((r__1 = a[*n + *n * a_dim1], dabs(r__1)) < smin) {
+ *info = *n;
+ a[*n + *n * a_dim1] = smin;
+ }
+
+ return 0;
+
+/* End of SGETC2 */
+
+} /* sgetc2_ */
diff --git a/SRC/sgetf2.c b/SRC/sgetf2.c
new file mode 100644
index 0000000..a8393fb
--- /dev/null
+++ b/SRC/sgetf2.c
@@ -0,0 +1,192 @@
+/* sgetf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b8 = -1.f;
+
+/* Subroutine */ int sgetf2_(integer *m, integer *n, real *a, integer *lda,
+ integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j, jp;
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *), sscal_(integer *
+, real *, real *, integer *);
+ real sfmin;
+ extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
+ integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGETF2 computes an LU factorization of a general m-by-n matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* The factorization has the form */
+/* A = P * L * U */
+/* where P is a permutation matrix, L is lower triangular with unit */
+/* diagonal elements (lower trapezoidal if m > n), and U is upper */
+/* triangular (upper trapezoidal if m < n). */
+
+/* This is the right-looking Level 2 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the m by n matrix to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, U(k,k) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGETF2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Compute machine safe minimum */
+
+ sfmin = slamch_("S");
+
+ i__1 = min(*m,*n);
+ for (j = 1; j <= i__1; ++j) {
+
+/* Find pivot and test for singularity. */
+
+ i__2 = *m - j + 1;
+ jp = j - 1 + isamax_(&i__2, &a[j + j * a_dim1], &c__1);
+ ipiv[j] = jp;
+ if (a[jp + j * a_dim1] != 0.f) {
+
+/* Apply the interchange to columns 1:N. */
+
+ if (jp != j) {
+ sswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda);
+ }
+
+/* Compute elements J+1:M of J-th column. */
+
+ if (j < *m) {
+ if ((r__1 = a[j + j * a_dim1], dabs(r__1)) >= sfmin) {
+ i__2 = *m - j;
+ r__1 = 1.f / a[j + j * a_dim1];
+ sscal_(&i__2, &r__1, &a[j + 1 + j * a_dim1], &c__1);
+ } else {
+ i__2 = *m - j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[j + i__ + j * a_dim1] /= a[j + j * a_dim1];
+/* L20: */
+ }
+ }
+ }
+
+ } else if (*info == 0) {
+
+ *info = j;
+ }
+
+ if (j < min(*m,*n)) {
+
+/* Update trailing submatrix. */
+
+ i__2 = *m - j;
+ i__3 = *n - j;
+ sger_(&i__2, &i__3, &c_b8, &a[j + 1 + j * a_dim1], &c__1, &a[j + (
+ j + 1) * a_dim1], lda, &a[j + 1 + (j + 1) * a_dim1], lda);
+ }
+/* L10: */
+ }
+ return 0;
+
+/* End of SGETF2 */
+
+} /* sgetf2_ */
diff --git a/SRC/sgetrf.c b/SRC/sgetrf.c
new file mode 100644
index 0000000..fc9e564
--- /dev/null
+++ b/SRC/sgetrf.c
@@ -0,0 +1,217 @@
+/* sgetrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b16 = 1.f;
+static real c_b19 = -1.f;
+
+/* Subroutine */ int sgetrf_(integer *m, integer *n, real *a, integer *lda,
+ integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+
+ /* Local variables */
+ integer i__, j, jb, nb, iinfo;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *), strsm_(char *, char *, char *,
+ char *, integer *, integer *, real *, real *, integer *, real *,
+ integer *), sgetf2_(integer *,
+ integer *, real *, integer *, integer *, integer *), xerbla_(char
+ *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slaswp_(integer *, real *, integer *, integer
+ *, integer *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGETRF computes an LU factorization of a general M-by-N matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* The factorization has the form */
+/* A = P * L * U */
+/* where P is a permutation matrix, L is lower triangular with unit */
+/* diagonal elements (lower trapezoidal if m > n), and U is upper */
+/* triangular (upper trapezoidal if m < n). */
+
+/* This is the right-looking Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGETRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "SGETRF", " ", m, n, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= min(*m,*n)) {
+
+/* Use unblocked code. */
+
+ sgetf2_(m, n, &a[a_offset], lda, &ipiv[1], info);
+ } else {
+
+/* Use blocked code. */
+
+ i__1 = min(*m,*n);
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = min(*m,*n) - j + 1;
+ jb = min(i__3,nb);
+
+/* Factor diagonal and subdiagonal blocks and test for exact */
+/* singularity. */
+
+ i__3 = *m - j + 1;
+ sgetf2_(&i__3, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo);
+
+/* Adjust INFO and the pivot indices. */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo + j - 1;
+ }
+/* Computing MIN */
+ i__4 = *m, i__5 = j + jb - 1;
+ i__3 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__3; ++i__) {
+ ipiv[i__] = j - 1 + ipiv[i__];
+/* L10: */
+ }
+
+/* Apply interchanges to columns 1:J-1. */
+
+ i__3 = j - 1;
+ i__4 = j + jb - 1;
+ slaswp_(&i__3, &a[a_offset], lda, &j, &i__4, &ipiv[1], &c__1);
+
+ if (j + jb <= *n) {
+
+/* Apply interchanges to columns J+JB:N. */
+
+ i__3 = *n - j - jb + 1;
+ i__4 = j + jb - 1;
+ slaswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, &
+ ipiv[1], &c__1);
+
+/* Compute block row of U. */
+
+ i__3 = *n - j - jb + 1;
+ strsm_("Left", "Lower", "No transpose", "Unit", &jb, &i__3, &
+ c_b16, &a[j + j * a_dim1], lda, &a[j + (j + jb) *
+ a_dim1], lda);
+ if (j + jb <= *m) {
+
+/* Update trailing submatrix. */
+
+ i__3 = *m - j - jb + 1;
+ i__4 = *n - j - jb + 1;
+ sgemm_("No transpose", "No transpose", &i__3, &i__4, &jb,
+ &c_b19, &a[j + jb + j * a_dim1], lda, &a[j + (j +
+ jb) * a_dim1], lda, &c_b16, &a[j + jb + (j + jb) *
+ a_dim1], lda);
+ }
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+/* End of SGETRF */
+
+} /* sgetrf_ */
diff --git a/SRC/sgetri.c b/SRC/sgetri.c
new file mode 100644
index 0000000..af5156b
--- /dev/null
+++ b/SRC/sgetri.c
@@ -0,0 +1,259 @@
+/* sgetri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static real c_b20 = -1.f;
+static real c_b22 = 1.f;
+
+/* Subroutine */ int sgetri_(integer *n, real *a, integer *lda, integer *ipiv,
+ real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, jb, nb, jj, jp, nn, iws, nbmin;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *), sgemv_(char *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *), sswap_(integer *, real *, integer *,
+ real *, integer *), strsm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int strtri_(char *, char *, integer *, real *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGETRI computes the inverse of a matrix using the LU factorization */
+/* computed by SGETRF. */
+
+/* This method inverts U and then computes inv(A) by solving the system */
+/* inv(A)*L = inv(U) for inv(A). */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the factors L and U from the factorization */
+/* A = P*L*U as computed by SGETRF. */
+/* On exit, if INFO = 0, the inverse of the original matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from SGETRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO=0, then WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* For optimal performance LWORK >= N*NB, where NB is */
+/* the optimal blocksize 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is */
+/* singular and its inverse could not be computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb = ilaenv_(&c__1, "SGETRI", " ", n, &c_n1, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ work[1] = (real) lwkopt;
+ lquery = *lwork == -1;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*lda < max(1,*n)) {
+ *info = -3;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGETRI", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form inv(U). If INFO > 0 from STRTRI, then U is singular, */
+/* and the inverse is not computed. */
+
+ strtri_("Upper", "Non-unit", n, &a[a_offset], lda, info);
+ if (*info > 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = *n;
+ if (nb > 1 && nb < *n) {
+/* Computing MAX */
+ i__1 = ldwork * nb;
+ iws = max(i__1,1);
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "SGETRI", " ", n, &c_n1, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = *n;
+ }
+
+/* Solve the equation inv(A)*L = inv(U) for inv(A). */
+
+ if (nb < nbmin || nb >= *n) {
+
+/* Use unblocked code. */
+
+ for (j = *n; j >= 1; --j) {
+
+/* Copy current column of L to WORK and replace with zeros. */
+
+ i__1 = *n;
+ for (i__ = j + 1; i__ <= i__1; ++i__) {
+ work[i__] = a[i__ + j * a_dim1];
+ a[i__ + j * a_dim1] = 0.f;
+/* L10: */
+ }
+
+/* Compute current column of inv(A). */
+
+ if (j < *n) {
+ i__1 = *n - j;
+ sgemv_("No transpose", n, &i__1, &c_b20, &a[(j + 1) * a_dim1
+ + 1], lda, &work[j + 1], &c__1, &c_b22, &a[j * a_dim1
+ + 1], &c__1);
+ }
+/* L20: */
+ }
+ } else {
+
+/* Use blocked code. */
+
+ nn = (*n - 1) / nb * nb + 1;
+ i__1 = -nb;
+ for (j = nn; i__1 < 0 ? j >= 1 : j <= 1; j += i__1) {
+/* Computing MIN */
+ i__2 = nb, i__3 = *n - j + 1;
+ jb = min(i__2,i__3);
+
+/* Copy current block column of L to WORK and replace with */
+/* zeros. */
+
+ i__2 = j + jb - 1;
+ for (jj = j; jj <= i__2; ++jj) {
+ i__3 = *n;
+ for (i__ = jj + 1; i__ <= i__3; ++i__) {
+ work[i__ + (jj - j) * ldwork] = a[i__ + jj * a_dim1];
+ a[i__ + jj * a_dim1] = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Compute current block column of inv(A). */
+
+ if (j + jb <= *n) {
+ i__2 = *n - j - jb + 1;
+ sgemm_("No transpose", "No transpose", n, &jb, &i__2, &c_b20,
+ &a[(j + jb) * a_dim1 + 1], lda, &work[j + jb], &
+ ldwork, &c_b22, &a[j * a_dim1 + 1], lda);
+ }
+ strsm_("Right", "Lower", "No transpose", "Unit", n, &jb, &c_b22, &
+ work[j], &ldwork, &a[j * a_dim1 + 1], lda);
+/* L50: */
+ }
+ }
+
+/* Apply column interchanges. */
+
+ for (j = *n - 1; j >= 1; --j) {
+ jp = ipiv[j];
+ if (jp != j) {
+ sswap_(n, &a[j * a_dim1 + 1], &c__1, &a[jp * a_dim1 + 1], &c__1);
+ }
+/* L60: */
+ }
+
+ work[1] = (real) iws;
+ return 0;
+
+/* End of SGETRI */
+
+} /* sgetri_ */
diff --git a/SRC/sgetrs.c b/SRC/sgetrs.c
new file mode 100644
index 0000000..2ab2c4d
--- /dev/null
+++ b/SRC/sgetrs.c
@@ -0,0 +1,185 @@
+/* sgetrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b12 = 1.f;
+static integer c_n1 = -1;
+
+/* Subroutine */ int sgetrs_(char *trans, integer *n, integer *nrhs, real *a,
+ integer *lda, integer *ipiv, real *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), xerbla_(char *, integer *);
+ logical notran;
+ extern /* Subroutine */ int slaswp_(integer *, real *, integer *, integer
+ *, integer *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGETRS solves a system of linear equations */
+/* A * X = B or A' * X = B */
+/* with a general N-by-N matrix A using the LU factorization computed */
+/* by SGETRF. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A'* X = B (Transpose) */
+/* = 'C': A'* X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The factors L and U from the factorization A = P*L*U */
+/* as computed by SGETRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from SGETRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGETRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (notran) {
+
+/* Solve A * X = B. */
+
+/* Apply row interchanges to the right hand sides. */
+
+ slaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c__1);
+
+/* Solve L*X = B, overwriting B with X. */
+
+ strsm_("Left", "Lower", "No transpose", "Unit", n, nrhs, &c_b12, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+/* Solve U*X = B, overwriting B with X. */
+
+ strsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b12, &
+ a[a_offset], lda, &b[b_offset], ldb);
+ } else {
+
+/* Solve A' * X = B. */
+
+/* Solve U'*X = B, overwriting B with X. */
+
+ strsm_("Left", "Upper", "Transpose", "Non-unit", n, nrhs, &c_b12, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+/* Solve L'*X = B, overwriting B with X. */
+
+ strsm_("Left", "Lower", "Transpose", "Unit", n, nrhs, &c_b12, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+/* Apply row interchanges to the solution vectors. */
+
+ slaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c_n1);
+ }
+
+ return 0;
+
+/* End of SGETRS */
+
+} /* sgetrs_ */
diff --git a/SRC/sggbak.c b/SRC/sggbak.c
new file mode 100644
index 0000000..30460ae
--- /dev/null
+++ b/SRC/sggbak.c
@@ -0,0 +1,274 @@
+/* sggbak.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sggbak_(char *job, char *side, integer *n, integer *ilo,
+ integer *ihi, real *lscale, real *rscale, integer *m, real *v,
+ integer *ldv, integer *info)
+{
+ /* System generated locals */
+ integer v_dim1, v_offset, i__1;
+
+ /* Local variables */
+ integer i__, k;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ logical leftv;
+ extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
+ integer *), xerbla_(char *, integer *);
+ logical rightv;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGGBAK forms the right or left eigenvectors of a real generalized */
+/* eigenvalue problem A*x = lambda*B*x, by backward transformation on */
+/* the computed eigenvectors of the balanced pair of matrices output by */
+/* SGGBAL. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies the type of backward transformation required: */
+/* = 'N': do nothing, return immediately; */
+/* = 'P': do backward transformation for permutation only; */
+/* = 'S': do backward transformation for scaling only; */
+/* = 'B': do backward transformations for both permutation and */
+/* scaling. */
+/* JOB must be the same as the argument JOB supplied to SGGBAL. */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'R': V contains right eigenvectors; */
+/* = 'L': V contains left eigenvectors. */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrix V. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* The integers ILO and IHI determined by SGGBAL. */
+/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
+
+/* LSCALE (input) REAL array, dimension (N) */
+/* Details of the permutations and/or scaling factors applied */
+/* to the left side of A and B, as returned by SGGBAL. */
+
+/* RSCALE (input) REAL array, dimension (N) */
+/* Details of the permutations and/or scaling factors applied */
+/* to the right side of A and B, as returned by SGGBAL. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix V. M >= 0. */
+
+/* V (input/output) REAL array, dimension (LDV,M) */
+/* On entry, the matrix of right or left eigenvectors to be */
+/* transformed, as returned by STGEVC. */
+/* On exit, V is overwritten by the transformed eigenvectors. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the matrix V. LDV >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* See R.C. Ward, Balancing the generalized eigenvalue problem, */
+/* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ --lscale;
+ --rscale;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+
+ /* Function Body */
+ rightv = lsame_(side, "R");
+ leftv = lsame_(side, "L");
+
+ *info = 0;
+ if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
+ && ! lsame_(job, "B")) {
+ *info = -1;
+ } else if (! rightv && ! leftv) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ilo < 1) {
+ *info = -4;
+ } else if (*n == 0 && *ihi == 0 && *ilo != 1) {
+ *info = -4;
+ } else if (*n > 0 && (*ihi < *ilo || *ihi > max(1,*n))) {
+ *info = -5;
+ } else if (*n == 0 && *ilo == 1 && *ihi != 0) {
+ *info = -5;
+ } else if (*m < 0) {
+ *info = -8;
+ } else if (*ldv < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGGBAK", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+ if (*m == 0) {
+ return 0;
+ }
+ if (lsame_(job, "N")) {
+ return 0;
+ }
+
+ if (*ilo == *ihi) {
+ goto L30;
+ }
+
+/* Backward balance */
+
+ if (lsame_(job, "S") || lsame_(job, "B")) {
+
+/* Backward transformation on right eigenvectors */
+
+ if (rightv) {
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ sscal_(m, &rscale[i__], &v[i__ + v_dim1], ldv);
+/* L10: */
+ }
+ }
+
+/* Backward transformation on left eigenvectors */
+
+ if (leftv) {
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ sscal_(m, &lscale[i__], &v[i__ + v_dim1], ldv);
+/* L20: */
+ }
+ }
+ }
+
+/* Backward permutation */
+
+L30:
+ if (lsame_(job, "P") || lsame_(job, "B")) {
+
+/* Backward permutation on right eigenvectors */
+
+ if (rightv) {
+ if (*ilo == 1) {
+ goto L50;
+ }
+
+ for (i__ = *ilo - 1; i__ >= 1; --i__) {
+ k = rscale[i__];
+ if (k == i__) {
+ goto L40;
+ }
+ sswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L40:
+ ;
+ }
+
+L50:
+ if (*ihi == *n) {
+ goto L70;
+ }
+ i__1 = *n;
+ for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
+ k = rscale[i__];
+ if (k == i__) {
+ goto L60;
+ }
+ sswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L60:
+ ;
+ }
+ }
+
+/* Backward permutation on left eigenvectors */
+
+L70:
+ if (leftv) {
+ if (*ilo == 1) {
+ goto L90;
+ }
+ for (i__ = *ilo - 1; i__ >= 1; --i__) {
+ k = lscale[i__];
+ if (k == i__) {
+ goto L80;
+ }
+ sswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L80:
+ ;
+ }
+
+L90:
+ if (*ihi == *n) {
+ goto L110;
+ }
+ i__1 = *n;
+ for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
+ k = lscale[i__];
+ if (k == i__) {
+ goto L100;
+ }
+ sswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L100:
+ ;
+ }
+ }
+ }
+
+L110:
+
+ return 0;
+
+/* End of SGGBAK */
+
+} /* sggbak_ */
diff --git a/SRC/sggbal.c b/SRC/sggbal.c
new file mode 100644
index 0000000..c2df1fe
--- /dev/null
+++ b/SRC/sggbal.c
@@ -0,0 +1,623 @@
+/* sggbal.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b35 = 10.f;
+static real c_b71 = .5f;
+
+/* Subroutine */ int sggbal_(char *job, integer *n, real *a, integer *lda,
+ real *b, integer *ldb, integer *ilo, integer *ihi, real *lscale, real
+ *rscale, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double r_lg10(real *), r_sign(real *, real *), pow_ri(real *, integer *);
+
+ /* Local variables */
+ integer i__, j, k, l, m;
+ real t;
+ integer jc;
+ real ta, tb, tc;
+ integer ir;
+ real ew;
+ integer it, nr, ip1, jp1, lm1;
+ real cab, rab, ewc, cor, sum;
+ integer nrp2, icab, lcab;
+ real beta, coef;
+ integer irab, lrab;
+ real basl, cmax;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ real coef2, coef5, gamma, alpha;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real sfmin, sfmax;
+ integer iflow;
+ extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
+ integer *);
+ integer kount;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *);
+ real pgamma;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ integer lsfmin, lsfmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGGBAL balances a pair of general real matrices (A,B). This */
+/* involves, first, permuting A and B by similarity transformations to */
+/* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N */
+/* elements on the diagonal; and second, applying a diagonal similarity */
+/* transformation to rows and columns ILO to IHI to make the rows */
+/* and columns as close in norm as possible. Both steps are optional. */
+
+/* Balancing may reduce the 1-norm of the matrices, and improve the */
+/* accuracy of the computed eigenvalues and/or eigenvectors in the */
+/* generalized eigenvalue problem A*x = lambda*B*x. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies the operations to be performed on A and B: */
+/* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0 */
+/* and RSCALE(I) = 1.0 for i = 1,...,N. */
+/* = 'P': permute only; */
+/* = 'S': scale only; */
+/* = 'B': both permute and scale. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the input matrix A. */
+/* On exit, A is overwritten by the balanced matrix. */
+/* If JOB = 'N', A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) REAL array, dimension (LDB,N) */
+/* On entry, the input matrix B. */
+/* On exit, B is overwritten by the balanced matrix. */
+/* If JOB = 'N', B is not referenced. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* ILO (output) INTEGER */
+/* IHI (output) INTEGER */
+/* ILO and IHI are set to integers such that on exit */
+/* A(i,j) = 0 and B(i,j) = 0 if i > j and */
+/* j = 1,...,ILO-1 or i = IHI+1,...,N. */
+/* If JOB = 'N' or 'S', ILO = 1 and IHI = N. */
+
+/* LSCALE (output) REAL array, dimension (N) */
+/* Details of the permutations and scaling factors applied */
+/* to the left side of A and B. If P(j) is the index of the */
+/* row interchanged with row j, and D(j) */
+/* is the scaling factor applied to row j, then */
+/* LSCALE(j) = P(j) for J = 1,...,ILO-1 */
+/* = D(j) for J = ILO,...,IHI */
+/* = P(j) for J = IHI+1,...,N. */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* RSCALE (output) REAL array, dimension (N) */
+/* Details of the permutations and scaling factors applied */
+/* to the right side of A and B. If P(j) is the index of the */
+/* column interchanged with column j, and D(j) */
+/* is the scaling factor applied to column j, then */
+/* LSCALE(j) = P(j) for J = 1,...,ILO-1 */
+/* = D(j) for J = ILO,...,IHI */
+/* = P(j) for J = IHI+1,...,N. */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* WORK (workspace) REAL array, dimension (lwork) */
+/* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and */
+/* at least 1 when JOB = 'N' or 'P'. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* See R.C. WARD, Balancing the generalized eigenvalue problem, */
+/* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --lscale;
+ --rscale;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
+ && ! lsame_(job, "B")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGGBAL", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *ilo = 1;
+ *ihi = *n;
+ return 0;
+ }
+
+ if (*n == 1) {
+ *ilo = 1;
+ *ihi = *n;
+ lscale[1] = 1.f;
+ rscale[1] = 1.f;
+ return 0;
+ }
+
+ if (lsame_(job, "N")) {
+ *ilo = 1;
+ *ihi = *n;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ lscale[i__] = 1.f;
+ rscale[i__] = 1.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+ k = 1;
+ l = *n;
+ if (lsame_(job, "S")) {
+ goto L190;
+ }
+
+ goto L30;
+
+/* Permute the matrices A and B to isolate the eigenvalues. */
+
+/* Find row with one nonzero in columns 1 through L */
+
+L20:
+ l = lm1;
+ if (l != 1) {
+ goto L30;
+ }
+
+ rscale[1] = 1.f;
+ lscale[1] = 1.f;
+ goto L190;
+
+L30:
+ lm1 = l - 1;
+ for (i__ = l; i__ >= 1; --i__) {
+ i__1 = lm1;
+ for (j = 1; j <= i__1; ++j) {
+ jp1 = j + 1;
+ if (a[i__ + j * a_dim1] != 0.f || b[i__ + j * b_dim1] != 0.f) {
+ goto L50;
+ }
+/* L40: */
+ }
+ j = l;
+ goto L70;
+
+L50:
+ i__1 = l;
+ for (j = jp1; j <= i__1; ++j) {
+ if (a[i__ + j * a_dim1] != 0.f || b[i__ + j * b_dim1] != 0.f) {
+ goto L80;
+ }
+/* L60: */
+ }
+ j = jp1 - 1;
+
+L70:
+ m = l;
+ iflow = 1;
+ goto L160;
+L80:
+ ;
+ }
+ goto L100;
+
+/* Find column with one nonzero in rows K through N */
+
+L90:
+ ++k;
+
+L100:
+ i__1 = l;
+ for (j = k; j <= i__1; ++j) {
+ i__2 = lm1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ ip1 = i__ + 1;
+ if (a[i__ + j * a_dim1] != 0.f || b[i__ + j * b_dim1] != 0.f) {
+ goto L120;
+ }
+/* L110: */
+ }
+ i__ = l;
+ goto L140;
+L120:
+ i__2 = l;
+ for (i__ = ip1; i__ <= i__2; ++i__) {
+ if (a[i__ + j * a_dim1] != 0.f || b[i__ + j * b_dim1] != 0.f) {
+ goto L150;
+ }
+/* L130: */
+ }
+ i__ = ip1 - 1;
+L140:
+ m = k;
+ iflow = 2;
+ goto L160;
+L150:
+ ;
+ }
+ goto L190;
+
+/* Permute rows M and I */
+
+L160:
+ lscale[m] = (real) i__;
+ if (i__ == m) {
+ goto L170;
+ }
+ i__1 = *n - k + 1;
+ sswap_(&i__1, &a[i__ + k * a_dim1], lda, &a[m + k * a_dim1], lda);
+ i__1 = *n - k + 1;
+ sswap_(&i__1, &b[i__ + k * b_dim1], ldb, &b[m + k * b_dim1], ldb);
+
+/* Permute columns M and J */
+
+L170:
+ rscale[m] = (real) j;
+ if (j == m) {
+ goto L180;
+ }
+ sswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
+ sswap_(&l, &b[j * b_dim1 + 1], &c__1, &b[m * b_dim1 + 1], &c__1);
+
+L180:
+ switch (iflow) {
+ case 1: goto L20;
+ case 2: goto L90;
+ }
+
+L190:
+ *ilo = k;
+ *ihi = l;
+
+ if (lsame_(job, "P")) {
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ lscale[i__] = 1.f;
+ rscale[i__] = 1.f;
+/* L195: */
+ }
+ return 0;
+ }
+
+ if (*ilo == *ihi) {
+ return 0;
+ }
+
+/* Balance the submatrix in rows ILO to IHI. */
+
+ nr = *ihi - *ilo + 1;
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ rscale[i__] = 0.f;
+ lscale[i__] = 0.f;
+
+ work[i__] = 0.f;
+ work[i__ + *n] = 0.f;
+ work[i__ + (*n << 1)] = 0.f;
+ work[i__ + *n * 3] = 0.f;
+ work[i__ + (*n << 2)] = 0.f;
+ work[i__ + *n * 5] = 0.f;
+/* L200: */
+ }
+
+/* Compute right side vector in resulting linear equations */
+
+ basl = r_lg10(&c_b35);
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ i__2 = *ihi;
+ for (j = *ilo; j <= i__2; ++j) {
+ tb = b[i__ + j * b_dim1];
+ ta = a[i__ + j * a_dim1];
+ if (ta == 0.f) {
+ goto L210;
+ }
+ r__1 = dabs(ta);
+ ta = r_lg10(&r__1) / basl;
+L210:
+ if (tb == 0.f) {
+ goto L220;
+ }
+ r__1 = dabs(tb);
+ tb = r_lg10(&r__1) / basl;
+L220:
+ work[i__ + (*n << 2)] = work[i__ + (*n << 2)] - ta - tb;
+ work[j + *n * 5] = work[j + *n * 5] - ta - tb;
+/* L230: */
+ }
+/* L240: */
+ }
+
+ coef = 1.f / (real) (nr << 1);
+ coef2 = coef * coef;
+ coef5 = coef2 * .5f;
+ nrp2 = nr + 2;
+ beta = 0.f;
+ it = 1;
+
+/* Start generalized conjugate gradient iteration */
+
+L250:
+
+ gamma = sdot_(&nr, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + (*n << 2)]
+, &c__1) + sdot_(&nr, &work[*ilo + *n * 5], &c__1, &work[*ilo + *
+ n * 5], &c__1);
+
+ ew = 0.f;
+ ewc = 0.f;
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ ew += work[i__ + (*n << 2)];
+ ewc += work[i__ + *n * 5];
+/* L260: */
+ }
+
+/* Computing 2nd power */
+ r__1 = ew;
+/* Computing 2nd power */
+ r__2 = ewc;
+/* Computing 2nd power */
+ r__3 = ew - ewc;
+ gamma = coef * gamma - coef2 * (r__1 * r__1 + r__2 * r__2) - coef5 * (
+ r__3 * r__3);
+ if (gamma == 0.f) {
+ goto L350;
+ }
+ if (it != 1) {
+ beta = gamma / pgamma;
+ }
+ t = coef5 * (ewc - ew * 3.f);
+ tc = coef5 * (ew - ewc * 3.f);
+
+ sscal_(&nr, &beta, &work[*ilo], &c__1);
+ sscal_(&nr, &beta, &work[*ilo + *n], &c__1);
+
+ saxpy_(&nr, &coef, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + *n], &
+ c__1);
+ saxpy_(&nr, &coef, &work[*ilo + *n * 5], &c__1, &work[*ilo], &c__1);
+
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ work[i__] += tc;
+ work[i__ + *n] += t;
+/* L270: */
+ }
+
+/* Apply matrix to vector */
+
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ kount = 0;
+ sum = 0.f;
+ i__2 = *ihi;
+ for (j = *ilo; j <= i__2; ++j) {
+ if (a[i__ + j * a_dim1] == 0.f) {
+ goto L280;
+ }
+ ++kount;
+ sum += work[j];
+L280:
+ if (b[i__ + j * b_dim1] == 0.f) {
+ goto L290;
+ }
+ ++kount;
+ sum += work[j];
+L290:
+ ;
+ }
+ work[i__ + (*n << 1)] = (real) kount * work[i__ + *n] + sum;
+/* L300: */
+ }
+
+ i__1 = *ihi;
+ for (j = *ilo; j <= i__1; ++j) {
+ kount = 0;
+ sum = 0.f;
+ i__2 = *ihi;
+ for (i__ = *ilo; i__ <= i__2; ++i__) {
+ if (a[i__ + j * a_dim1] == 0.f) {
+ goto L310;
+ }
+ ++kount;
+ sum += work[i__ + *n];
+L310:
+ if (b[i__ + j * b_dim1] == 0.f) {
+ goto L320;
+ }
+ ++kount;
+ sum += work[i__ + *n];
+L320:
+ ;
+ }
+ work[j + *n * 3] = (real) kount * work[j] + sum;
+/* L330: */
+ }
+
+ sum = sdot_(&nr, &work[*ilo + *n], &c__1, &work[*ilo + (*n << 1)], &c__1)
+ + sdot_(&nr, &work[*ilo], &c__1, &work[*ilo + *n * 3], &c__1);
+ alpha = gamma / sum;
+
+/* Determine correction to current iteration */
+
+ cmax = 0.f;
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ cor = alpha * work[i__ + *n];
+ if (dabs(cor) > cmax) {
+ cmax = dabs(cor);
+ }
+ lscale[i__] += cor;
+ cor = alpha * work[i__];
+ if (dabs(cor) > cmax) {
+ cmax = dabs(cor);
+ }
+ rscale[i__] += cor;
+/* L340: */
+ }
+ if (cmax < .5f) {
+ goto L350;
+ }
+
+ r__1 = -alpha;
+ saxpy_(&nr, &r__1, &work[*ilo + (*n << 1)], &c__1, &work[*ilo + (*n << 2)]
+, &c__1);
+ r__1 = -alpha;
+ saxpy_(&nr, &r__1, &work[*ilo + *n * 3], &c__1, &work[*ilo + *n * 5], &
+ c__1);
+
+ pgamma = gamma;
+ ++it;
+ if (it <= nrp2) {
+ goto L250;
+ }
+
+/* End generalized conjugate gradient iteration */
+
+L350:
+ sfmin = slamch_("S");
+ sfmax = 1.f / sfmin;
+ lsfmin = (integer) (r_lg10(&sfmin) / basl + 1.f);
+ lsfmax = (integer) (r_lg10(&sfmax) / basl);
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ i__2 = *n - *ilo + 1;
+ irab = isamax_(&i__2, &a[i__ + *ilo * a_dim1], lda);
+ rab = (r__1 = a[i__ + (irab + *ilo - 1) * a_dim1], dabs(r__1));
+ i__2 = *n - *ilo + 1;
+ irab = isamax_(&i__2, &b[i__ + *ilo * b_dim1], ldb);
+/* Computing MAX */
+ r__2 = rab, r__3 = (r__1 = b[i__ + (irab + *ilo - 1) * b_dim1], dabs(
+ r__1));
+ rab = dmax(r__2,r__3);
+ r__1 = rab + sfmin;
+ lrab = (integer) (r_lg10(&r__1) / basl + 1.f);
+ ir = lscale[i__] + r_sign(&c_b71, &lscale[i__]);
+/* Computing MIN */
+ i__2 = max(ir,lsfmin), i__2 = min(i__2,lsfmax), i__3 = lsfmax - lrab;
+ ir = min(i__2,i__3);
+ lscale[i__] = pow_ri(&c_b35, &ir);
+ icab = isamax_(ihi, &a[i__ * a_dim1 + 1], &c__1);
+ cab = (r__1 = a[icab + i__ * a_dim1], dabs(r__1));
+ icab = isamax_(ihi, &b[i__ * b_dim1 + 1], &c__1);
+/* Computing MAX */
+ r__2 = cab, r__3 = (r__1 = b[icab + i__ * b_dim1], dabs(r__1));
+ cab = dmax(r__2,r__3);
+ r__1 = cab + sfmin;
+ lcab = (integer) (r_lg10(&r__1) / basl + 1.f);
+ jc = rscale[i__] + r_sign(&c_b71, &rscale[i__]);
+/* Computing MIN */
+ i__2 = max(jc,lsfmin), i__2 = min(i__2,lsfmax), i__3 = lsfmax - lcab;
+ jc = min(i__2,i__3);
+ rscale[i__] = pow_ri(&c_b35, &jc);
+/* L360: */
+ }
+
+/* Row scaling of matrices A and B */
+
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ i__2 = *n - *ilo + 1;
+ sscal_(&i__2, &lscale[i__], &a[i__ + *ilo * a_dim1], lda);
+ i__2 = *n - *ilo + 1;
+ sscal_(&i__2, &lscale[i__], &b[i__ + *ilo * b_dim1], ldb);
+/* L370: */
+ }
+
+/* Column scaling of matrices A and B */
+
+ i__1 = *ihi;
+ for (j = *ilo; j <= i__1; ++j) {
+ sscal_(ihi, &rscale[j], &a[j * a_dim1 + 1], &c__1);
+ sscal_(ihi, &rscale[j], &b[j * b_dim1 + 1], &c__1);
+/* L380: */
+ }
+
+ return 0;
+
+/* End of SGGBAL */
+
+} /* sggbal_ */
diff --git a/SRC/sgges.c b/SRC/sgges.c
new file mode 100644
index 0000000..925f150
--- /dev/null
+++ b/SRC/sgges.c
@@ -0,0 +1,687 @@
+/* sgges.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static real c_b38 = 0.f;
+static real c_b39 = 1.f;
+
+/* Subroutine */ int sgges_(char *jobvsl, char *jobvsr, char *sort, L_fp
+ selctg, integer *n, real *a, integer *lda, real *b, integer *ldb,
+ integer *sdim, real *alphar, real *alphai, real *beta, real *vsl,
+ integer *ldvsl, real *vsr, integer *ldvsr, real *work, integer *lwork,
+ logical *bwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
+ vsr_dim1, vsr_offset, i__1, i__2;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, ip;
+ real dif[2];
+ integer ihi, ilo;
+ real eps, anrm, bnrm;
+ integer idum[1], ierr, itau, iwrk;
+ real pvsl, pvsr;
+ extern logical lsame_(char *, char *);
+ integer ileft, icols;
+ logical cursl, ilvsl, ilvsr;
+ integer irows;
+ logical lst2sl;
+ extern /* Subroutine */ int slabad_(real *, real *), sggbak_(char *, char
+ *, integer *, integer *, integer *, real *, real *, integer *,
+ real *, integer *, integer *), sggbal_(char *,
+ integer *, real *, integer *, real *, integer *, integer *,
+ integer *, real *, real *, real *, integer *);
+ logical ilascl, ilbscl;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ real safmin;
+ extern /* Subroutine */ int sgghrd_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, integer *, integer *);
+ real safmax;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ijobvl, iright;
+ extern /* Subroutine */ int sgeqrf_(integer *, integer *, real *, integer
+ *, real *, real *, integer *, integer *);
+ integer ijobvr;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *);
+ real anrmto, bnrmto;
+ logical lastsl;
+ extern /* Subroutine */ int shgeqz_(char *, char *, char *, integer *,
+ integer *, integer *, real *, integer *, real *, integer *, real *
+, real *, real *, real *, integer *, real *, integer *, real *,
+ integer *, integer *), stgsen_(integer *,
+ logical *, logical *, logical *, integer *, real *, integer *,
+ real *, integer *, real *, real *, real *, real *, integer *,
+ real *, integer *, integer *, real *, real *, real *, real *,
+ integer *, integer *, integer *, integer *);
+ integer minwrk, maxwrk;
+ real smlnum;
+ extern /* Subroutine */ int sorgqr_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *);
+ logical wantst, lquery;
+ extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+/* .. Function Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B), */
+/* the generalized eigenvalues, the generalized real Schur form (S,T), */
+/* optionally, the left and/or right matrices of Schur vectors (VSL and */
+/* VSR). This gives the generalized Schur factorization */
+
+/* (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T ) */
+
+/* Optionally, it also orders the eigenvalues so that a selected cluster */
+/* of eigenvalues appears in the leading diagonal blocks of the upper */
+/* quasi-triangular matrix S and the upper triangular matrix T.The */
+/* leading columns of VSL and VSR then form an orthonormal basis for the */
+/* corresponding left and right eigenspaces (deflating subspaces). */
+
+/* (If only the generalized eigenvalues are needed, use the driver */
+/* SGGEV instead, which is faster.) */
+
+/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w */
+/* or a ratio alpha/beta = w, such that A - w*B is singular. It is */
+/* usually represented as the pair (alpha,beta), as there is a */
+/* reasonable interpretation for beta=0 or both being zero. */
+
+/* A pair of matrices (S,T) is in generalized real Schur form if T is */
+/* upper triangular with non-negative diagonal and S is block upper */
+/* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond */
+/* to real generalized eigenvalues, while 2-by-2 blocks of S will be */
+/* "standardized" by making the corresponding elements of T have the */
+/* form: */
+/* [ a 0 ] */
+/* [ 0 b ] */
+
+/* and the pair of corresponding 2-by-2 blocks in S and T will have a */
+/* complex conjugate pair of generalized eigenvalues. */
+
+
+/* Arguments */
+/* ========= */
+
+/* JOBVSL (input) CHARACTER*1 */
+/* = 'N': do not compute the left Schur vectors; */
+/* = 'V': compute the left Schur vectors. */
+
+/* JOBVSR (input) CHARACTER*1 */
+/* = 'N': do not compute the right Schur vectors; */
+/* = 'V': compute the right Schur vectors. */
+
+/* SORT (input) CHARACTER*1 */
+/* Specifies whether or not to order the eigenvalues on the */
+/* diagonal of the generalized Schur form. */
+/* = 'N': Eigenvalues are not ordered; */
+/* = 'S': Eigenvalues are ordered (see SELCTG); */
+
+/* SELCTG (external procedure) LOGICAL FUNCTION of three REAL arguments */
+/* SELCTG must be declared EXTERNAL in the calling subroutine. */
+/* If SORT = 'N', SELCTG is not referenced. */
+/* If SORT = 'S', SELCTG is used to select eigenvalues to sort */
+/* to the top left of the Schur form. */
+/* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if */
+/* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either */
+/* one of a complex conjugate pair of eigenvalues is selected, */
+/* then both complex eigenvalues are selected. */
+
+/* Note that in the ill-conditioned case, a selected complex */
+/* eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j), */
+/* BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2 */
+/* in this case. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VSL, and VSR. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA, N) */
+/* On entry, the first of the pair of matrices. */
+/* On exit, A has been overwritten by its generalized Schur */
+/* form S. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) REAL array, dimension (LDB, N) */
+/* On entry, the second of the pair of matrices. */
+/* On exit, B has been overwritten by its generalized Schur */
+/* form T. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* SDIM (output) INTEGER */
+/* If SORT = 'N', SDIM = 0. */
+/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */
+/* for which SELCTG is true. (Complex conjugate pairs for which */
+/* SELCTG is true for either eigenvalue count as 2.) */
+
+/* ALPHAR (output) REAL array, dimension (N) */
+/* ALPHAI (output) REAL array, dimension (N) */
+/* BETA (output) REAL array, dimension (N) */
+/* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */
+/* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i, */
+/* and BETA(j),j=1,...,N are the diagonals of the complex Schur */
+/* form (S,T) that would result if the 2-by-2 diagonal blocks of */
+/* the real Schur form of (A,B) were further reduced to */
+/* triangular form using 2-by-2 complex unitary transformations. */
+/* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */
+/* positive, then the j-th and (j+1)-st eigenvalues are a */
+/* complex conjugate pair, with ALPHAI(j+1) negative. */
+
+/* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */
+/* may easily over- or underflow, and BETA(j) may even be zero. */
+/* Thus, the user should avoid naively computing the ratio. */
+/* However, ALPHAR and ALPHAI will be always less than and */
+/* usually comparable with norm(A) in magnitude, and BETA always */
+/* less than and usually comparable with norm(B). */
+
+/* VSL (output) REAL array, dimension (LDVSL,N) */
+/* If JOBVSL = 'V', VSL will contain the left Schur vectors. */
+/* Not referenced if JOBVSL = 'N'. */
+
+/* LDVSL (input) INTEGER */
+/* The leading dimension of the matrix VSL. LDVSL >=1, and */
+/* if JOBVSL = 'V', LDVSL >= N. */
+
+/* VSR (output) REAL array, dimension (LDVSR,N) */
+/* If JOBVSR = 'V', VSR will contain the right Schur vectors. */
+/* Not referenced if JOBVSR = 'N'. */
+
+/* LDVSR (input) INTEGER */
+/* The leading dimension of the matrix VSR. LDVSR >= 1, and */
+/* if JOBVSR = 'V', LDVSR >= N. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If N = 0, LWORK >= 1, else LWORK >= max(8*N,6*N+16). */
+/* For good performance , LWORK must generally be larger. */
+
+/* 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. */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+/* Not referenced if SORT = 'N'. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1,...,N: */
+/* The QZ iteration failed. (A,B) are not in Schur */
+/* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should */
+/* be correct for j=INFO+1,...,N. */
+/* > N: =N+1: other than QZ iteration failed in SHGEQZ. */
+/* =N+2: after reordering, roundoff changed values of */
+/* some complex eigenvalues so that leading */
+/* eigenvalues in the Generalized Schur form no */
+/* longer satisfy SELCTG=.TRUE. This could also */
+/* be caused due to scaling. */
+/* =N+3: reordering failed in STGSEN. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ vsl_dim1 = *ldvsl;
+ vsl_offset = 1 + vsl_dim1;
+ vsl -= vsl_offset;
+ vsr_dim1 = *ldvsr;
+ vsr_offset = 1 + vsr_dim1;
+ vsr -= vsr_offset;
+ --work;
+ --bwork;
+
+ /* Function Body */
+ if (lsame_(jobvsl, "N")) {
+ ijobvl = 1;
+ ilvsl = FALSE_;
+ } else if (lsame_(jobvsl, "V")) {
+ ijobvl = 2;
+ ilvsl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvsl = FALSE_;
+ }
+
+ if (lsame_(jobvsr, "N")) {
+ ijobvr = 1;
+ ilvsr = FALSE_;
+ } else if (lsame_(jobvsr, "V")) {
+ ijobvr = 2;
+ ilvsr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvsr = FALSE_;
+ }
+
+ wantst = lsame_(sort, "S");
+
+/* Test the input arguments */
+
+ *info = 0;
+ lquery = *lwork == -1;
+ if (ijobvl <= 0) {
+ *info = -1;
+ } else if (ijobvr <= 0) {
+ *info = -2;
+ } else if (! wantst && ! lsame_(sort, "N")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
+ *info = -15;
+ } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
+ *info = -17;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ if (*info == 0) {
+ if (*n > 0) {
+/* Computing MAX */
+ i__1 = *n << 3, i__2 = *n * 6 + 16;
+ minwrk = max(i__1,i__2);
+ maxwrk = minwrk - *n + *n * ilaenv_(&c__1, "SGEQRF", " ", n, &
+ c__1, n, &c__0);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = minwrk - *n + *n * ilaenv_(&c__1, "SORMQR",
+ " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ if (ilvsl) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = minwrk - *n + *n * ilaenv_(&c__1, "SOR"
+ "GQR", " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ }
+ } else {
+ minwrk = 1;
+ maxwrk = 1;
+ }
+ work[1] = (real) maxwrk;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -19;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGGES ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *sdim = 0;
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ safmin = slamch_("S");
+ safmax = 1.f / safmin;
+ slabad_(&safmin, &safmax);
+ smlnum = sqrt(safmin) / eps;
+ bignum = 1.f / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = slange_("M", n, n, &a[a_offset], lda, &work[1]);
+ ilascl = FALSE_;
+ if (anrm > 0.f && anrm < smlnum) {
+ anrmto = smlnum;
+ ilascl = TRUE_;
+ } else if (anrm > bignum) {
+ anrmto = bignum;
+ ilascl = TRUE_;
+ }
+ if (ilascl) {
+ slascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = slange_("M", n, n, &b[b_offset], ldb, &work[1]);
+ ilbscl = FALSE_;
+ if (bnrm > 0.f && bnrm < smlnum) {
+ bnrmto = smlnum;
+ ilbscl = TRUE_;
+ } else if (bnrm > bignum) {
+ bnrmto = bignum;
+ ilbscl = TRUE_;
+ }
+ if (ilbscl) {
+ slascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
+ ierr);
+ }
+
+/* Permute the matrix to make it more nearly triangular */
+/* (Workspace: need 6*N + 2*N space for storing balancing factors) */
+
+ ileft = 1;
+ iright = *n + 1;
+ iwrk = iright + *n;
+ sggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[
+ ileft], &work[iright], &work[iwrk], &ierr);
+
+/* Reduce B to triangular form (QR decomposition of B) */
+/* (Workspace: need N, prefer N*NB) */
+
+ irows = ihi + 1 - ilo;
+ icols = *n + 1 - ilo;
+ itau = iwrk;
+ iwrk = itau + irows;
+ i__1 = *lwork + 1 - iwrk;
+ sgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
+ iwrk], &i__1, &ierr);
+
+/* Apply the orthogonal transformation to matrix A */
+/* (Workspace: need N, prefer N*NB) */
+
+ i__1 = *lwork + 1 - iwrk;
+ sormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
+ work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, &
+ ierr);
+
+/* Initialize VSL */
+/* (Workspace: need N, prefer N*NB) */
+
+ if (ilvsl) {
+ slaset_("Full", n, n, &c_b38, &c_b39, &vsl[vsl_offset], ldvsl);
+ if (irows > 1) {
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ slacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[
+ ilo + 1 + ilo * vsl_dim1], ldvsl);
+ }
+ i__1 = *lwork + 1 - iwrk;
+ sorgqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, &
+ work[itau], &work[iwrk], &i__1, &ierr);
+ }
+
+/* Initialize VSR */
+
+ if (ilvsr) {
+ slaset_("Full", n, n, &c_b38, &c_b39, &vsr[vsr_offset], ldvsr);
+ }
+
+/* Reduce to generalized Hessenberg form */
+/* (Workspace: none needed) */
+
+ sgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &ierr);
+
+/* Perform QZ algorithm, computing Schur vectors if desired */
+/* (Workspace: need N) */
+
+ iwrk = itau;
+ i__1 = *lwork + 1 - iwrk;
+ shgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[
+ b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset]
+, ldvsl, &vsr[vsr_offset], ldvsr, &work[iwrk], &i__1, &ierr);
+ if (ierr != 0) {
+ if (ierr > 0 && ierr <= *n) {
+ *info = ierr;
+ } else if (ierr > *n && ierr <= *n << 1) {
+ *info = ierr - *n;
+ } else {
+ *info = *n + 1;
+ }
+ goto L40;
+ }
+
+/* Sort eigenvalues ALPHA/BETA if desired */
+/* (Workspace: need 4*N+16 ) */
+
+ *sdim = 0;
+ if (wantst) {
+
+/* Undo scaling on eigenvalues before SELCTGing */
+
+ if (ilascl) {
+ slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1],
+ n, &ierr);
+ slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1],
+ n, &ierr);
+ }
+ if (ilbscl) {
+ slascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n,
+ &ierr);
+ }
+
+/* Select eigenvalues */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ bwork[i__] = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]);
+/* L10: */
+ }
+
+ i__1 = *lwork - iwrk + 1;
+ stgsen_(&c__0, &ilvsl, &ilvsr, &bwork[1], n, &a[a_offset], lda, &b[
+ b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[
+ vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, sdim, &pvsl, &
+ pvsr, dif, &work[iwrk], &i__1, idum, &c__1, &ierr);
+ if (ierr == 1) {
+ *info = *n + 3;
+ }
+
+ }
+
+/* Apply back-permutation to VSL and VSR */
+/* (Workspace: none needed) */
+
+ if (ilvsl) {
+ sggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[
+ vsl_offset], ldvsl, &ierr);
+ }
+
+ if (ilvsr) {
+ sggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[
+ vsr_offset], ldvsr, &ierr);
+ }
+
+/* Check if unscaling would cause over/underflow, if so, rescale */
+/* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of */
+/* B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I) */
+
+ if (ilascl) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (alphai[i__] != 0.f) {
+ if (alphar[i__] / safmax > anrmto / anrm || safmin / alphar[
+ i__] > anrm / anrmto) {
+ work[1] = (r__1 = a[i__ + i__ * a_dim1] / alphar[i__],
+ dabs(r__1));
+ beta[i__] *= work[1];
+ alphar[i__] *= work[1];
+ alphai[i__] *= work[1];
+ } else if (alphai[i__] / safmax > anrmto / anrm || safmin /
+ alphai[i__] > anrm / anrmto) {
+ work[1] = (r__1 = a[i__ + (i__ + 1) * a_dim1] / alphai[
+ i__], dabs(r__1));
+ beta[i__] *= work[1];
+ alphar[i__] *= work[1];
+ alphai[i__] *= work[1];
+ }
+ }
+/* L50: */
+ }
+ }
+
+ if (ilbscl) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (alphai[i__] != 0.f) {
+ if (beta[i__] / safmax > bnrmto / bnrm || safmin / beta[i__]
+ > bnrm / bnrmto) {
+ work[1] = (r__1 = b[i__ + i__ * b_dim1] / beta[i__], dabs(
+ r__1));
+ beta[i__] *= work[1];
+ alphar[i__] *= work[1];
+ alphai[i__] *= work[1];
+ }
+ }
+/* L60: */
+ }
+ }
+
+/* Undo scaling */
+
+ if (ilascl) {
+ slascl_("H", &c__0, &c__0, &anrmto, &anrm, n, n, &a[a_offset], lda, &
+ ierr);
+ slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, &
+ ierr);
+ slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, &
+ ierr);
+ }
+
+ if (ilbscl) {
+ slascl_("U", &c__0, &c__0, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, &
+ ierr);
+ slascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
+ ierr);
+ }
+
+ if (wantst) {
+
+/* Check if reordering is correct */
+
+ lastsl = TRUE_;
+ lst2sl = TRUE_;
+ *sdim = 0;
+ ip = 0;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ cursl = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]);
+ if (alphai[i__] == 0.f) {
+ if (cursl) {
+ ++(*sdim);
+ }
+ ip = 0;
+ if (cursl && ! lastsl) {
+ *info = *n + 2;
+ }
+ } else {
+ if (ip == 1) {
+
+/* Last eigenvalue of conjugate pair */
+
+ cursl = cursl || lastsl;
+ lastsl = cursl;
+ if (cursl) {
+ *sdim += 2;
+ }
+ ip = -1;
+ if (cursl && ! lst2sl) {
+ *info = *n + 2;
+ }
+ } else {
+
+/* First eigenvalue of conjugate pair */
+
+ ip = 1;
+ }
+ }
+ lst2sl = lastsl;
+ lastsl = cursl;
+/* L30: */
+ }
+
+ }
+
+L40:
+
+ work[1] = (real) maxwrk;
+
+ return 0;
+
+/* End of SGGES */
+
+} /* sgges_ */
diff --git a/SRC/sggesx.c b/SRC/sggesx.c
new file mode 100644
index 0000000..9128e03
--- /dev/null
+++ b/SRC/sggesx.c
@@ -0,0 +1,811 @@
+/* sggesx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static real c_b42 = 0.f;
+static real c_b43 = 1.f;
+
+/* Subroutine */ int sggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp
+ selctg, char *sense, integer *n, real *a, integer *lda, real *b,
+ integer *ldb, integer *sdim, real *alphar, real *alphai, real *beta,
+ real *vsl, integer *ldvsl, real *vsr, integer *ldvsr, real *rconde,
+ real *rcondv, real *work, integer *lwork, integer *iwork, integer *
+ liwork, logical *bwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
+ vsr_dim1, vsr_offset, i__1, i__2;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, ip;
+ real pl, pr, dif[2];
+ integer ihi, ilo;
+ real eps;
+ integer ijob;
+ real anrm, bnrm;
+ integer ierr, itau, iwrk, lwrk;
+ extern logical lsame_(char *, char *);
+ integer ileft, icols;
+ logical cursl, ilvsl, ilvsr;
+ integer irows;
+ logical lst2sl;
+ extern /* Subroutine */ int slabad_(real *, real *), sggbak_(char *, char
+ *, integer *, integer *, integer *, real *, real *, integer *,
+ real *, integer *, integer *), sggbal_(char *,
+ integer *, real *, integer *, real *, integer *, integer *,
+ integer *, real *, real *, real *, integer *);
+ logical ilascl, ilbscl;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ real safmin;
+ extern /* Subroutine */ int sgghrd_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, integer *, integer *);
+ real safmax;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ijobvl, iright;
+ extern /* Subroutine */ int sgeqrf_(integer *, integer *, real *, integer
+ *, real *, real *, integer *, integer *);
+ integer ijobvr;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+ logical wantsb, wantse, lastsl;
+ integer liwmin;
+ real anrmto, bnrmto;
+ integer minwrk, maxwrk;
+ logical wantsn;
+ real smlnum;
+ extern /* Subroutine */ int shgeqz_(char *, char *, char *, integer *,
+ integer *, integer *, real *, integer *, real *, integer *, real *
+, real *, real *, real *, integer *, real *, integer *, real *,
+ integer *, integer *), slaset_(char *,
+ integer *, integer *, real *, real *, real *, integer *),
+ sorgqr_(integer *, integer *, integer *, real *, integer *, real *
+, real *, integer *, integer *), stgsen_(integer *, logical *,
+ logical *, logical *, integer *, real *, integer *, real *,
+ integer *, real *, real *, real *, real *, integer *, real *,
+ integer *, integer *, real *, real *, real *, real *, integer *,
+ integer *, integer *, integer *);
+ logical wantst, lquery, wantsv;
+ extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+/* .. Function Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGGESX computes for a pair of N-by-N real nonsymmetric matrices */
+/* (A,B), the generalized eigenvalues, the real Schur form (S,T), and, */
+/* optionally, the left and/or right matrices of Schur vectors (VSL and */
+/* VSR). This gives the generalized Schur factorization */
+
+/* (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T ) */
+
+/* Optionally, it also orders the eigenvalues so that a selected cluster */
+/* of eigenvalues appears in the leading diagonal blocks of the upper */
+/* quasi-triangular matrix S and the upper triangular matrix T; computes */
+/* a reciprocal condition number for the average of the selected */
+/* eigenvalues (RCONDE); and computes a reciprocal condition number for */
+/* the right and left deflating subspaces corresponding to the selected */
+/* eigenvalues (RCONDV). The leading columns of VSL and VSR then form */
+/* an orthonormal basis for the corresponding left and right eigenspaces */
+/* (deflating subspaces). */
+
+/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w */
+/* or a ratio alpha/beta = w, such that A - w*B is singular. It is */
+/* usually represented as the pair (alpha,beta), as there is a */
+/* reasonable interpretation for beta=0 or for both being zero. */
+
+/* A pair of matrices (S,T) is in generalized real Schur form if T is */
+/* upper triangular with non-negative diagonal and S is block upper */
+/* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond */
+/* to real generalized eigenvalues, while 2-by-2 blocks of S will be */
+/* "standardized" by making the corresponding elements of T have the */
+/* form: */
+/* [ a 0 ] */
+/* [ 0 b ] */
+
+/* and the pair of corresponding 2-by-2 blocks in S and T will have a */
+/* complex conjugate pair of generalized eigenvalues. */
+
+
+/* Arguments */
+/* ========= */
+
+/* JOBVSL (input) CHARACTER*1 */
+/* = 'N': do not compute the left Schur vectors; */
+/* = 'V': compute the left Schur vectors. */
+
+/* JOBVSR (input) CHARACTER*1 */
+/* = 'N': do not compute the right Schur vectors; */
+/* = 'V': compute the right Schur vectors. */
+
+/* SORT (input) CHARACTER*1 */
+/* Specifies whether or not to order the eigenvalues on the */
+/* diagonal of the generalized Schur form. */
+/* = 'N': Eigenvalues are not ordered; */
+/* = 'S': Eigenvalues are ordered (see SELCTG). */
+
+/* SELCTG (external procedure) LOGICAL FUNCTION of three REAL arguments */
+/* SELCTG must be declared EXTERNAL in the calling subroutine. */
+/* If SORT = 'N', SELCTG is not referenced. */
+/* If SORT = 'S', SELCTG is used to select eigenvalues to sort */
+/* to the top left of the Schur form. */
+/* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if */
+/* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either */
+/* one of a complex conjugate pair of eigenvalues is selected, */
+/* then both complex eigenvalues are selected. */
+/* Note that a selected complex eigenvalue may no longer satisfy */
+/* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering, */
+/* since ordering may change the value of complex eigenvalues */
+/* (especially if the eigenvalue is ill-conditioned), in this */
+/* case INFO is set to N+3. */
+
+/* SENSE (input) CHARACTER*1 */
+/* Determines which reciprocal condition numbers are computed. */
+/* = 'N' : None are computed; */
+/* = 'E' : Computed for average of selected eigenvalues only; */
+/* = 'V' : Computed for selected deflating subspaces only; */
+/* = 'B' : Computed for both. */
+/* If SENSE = 'E', 'V', or 'B', SORT must equal 'S'. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VSL, and VSR. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA, N) */
+/* On entry, the first of the pair of matrices. */
+/* On exit, A has been overwritten by its generalized Schur */
+/* form S. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) REAL array, dimension (LDB, N) */
+/* On entry, the second of the pair of matrices. */
+/* On exit, B has been overwritten by its generalized Schur */
+/* form T. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* SDIM (output) INTEGER */
+/* If SORT = 'N', SDIM = 0. */
+/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */
+/* for which SELCTG is true. (Complex conjugate pairs for which */
+/* SELCTG is true for either eigenvalue count as 2.) */
+
+/* ALPHAR (output) REAL array, dimension (N) */
+/* ALPHAI (output) REAL array, dimension (N) */
+/* BETA (output) REAL array, dimension (N) */
+/* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */
+/* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i */
+/* and BETA(j),j=1,...,N are the diagonals of the complex Schur */
+/* form (S,T) that would result if the 2-by-2 diagonal blocks of */
+/* the real Schur form of (A,B) were further reduced to */
+/* triangular form using 2-by-2 complex unitary transformations. */
+/* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */
+/* positive, then the j-th and (j+1)-st eigenvalues are a */
+/* complex conjugate pair, with ALPHAI(j+1) negative. */
+
+/* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */
+/* may easily over- or underflow, and BETA(j) may even be zero. */
+/* Thus, the user should avoid naively computing the ratio. */
+/* However, ALPHAR and ALPHAI will be always less than and */
+/* usually comparable with norm(A) in magnitude, and BETA always */
+/* less than and usually comparable with norm(B). */
+
+/* VSL (output) REAL array, dimension (LDVSL,N) */
+/* If JOBVSL = 'V', VSL will contain the left Schur vectors. */
+/* Not referenced if JOBVSL = 'N'. */
+
+/* LDVSL (input) INTEGER */
+/* The leading dimension of the matrix VSL. LDVSL >=1, and */
+/* if JOBVSL = 'V', LDVSL >= N. */
+
+/* VSR (output) REAL array, dimension (LDVSR,N) */
+/* If JOBVSR = 'V', VSR will contain the right Schur vectors. */
+/* Not referenced if JOBVSR = 'N'. */
+
+/* LDVSR (input) INTEGER */
+/* The leading dimension of the matrix VSR. LDVSR >= 1, and */
+/* if JOBVSR = 'V', LDVSR >= N. */
+
+/* RCONDE (output) REAL array, dimension ( 2 ) */
+/* If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the */
+/* reciprocal condition numbers for the average of the selected */
+/* eigenvalues. */
+/* Not referenced if SENSE = 'N' or 'V'. */
+
+/* RCONDV (output) REAL array, dimension ( 2 ) */
+/* If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the */
+/* reciprocal condition numbers for the selected deflating */
+/* subspaces. */
+/* Not referenced if SENSE = 'N' or 'E'. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B', */
+/* LWORK >= max( 8*N, 6*N+16, 2*SDIM*(N-SDIM) ), else */
+/* LWORK >= max( 8*N, 6*N+16 ). */
+/* Note that 2*SDIM*(N-SDIM) <= N*N/2. */
+/* Note also that an error is only returned if */
+/* LWORK < max( 8*N, 6*N+16), but if SENSE = 'E' or 'V' or 'B' */
+/* this may not be large enough. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the bound on the optimal size of the WORK */
+/* array and the minimum size of the IWORK array, returns these */
+/* values as the first entries of the WORK and IWORK arrays, and */
+/* no error message related to LWORK or LIWORK is issued by */
+/* XERBLA. */
+
+/* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise */
+/* LIWORK >= N+6. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the bound on the optimal size of the */
+/* WORK array and the minimum size of the IWORK array, returns */
+/* these values as the first entries of the WORK and IWORK */
+/* arrays, and no error message related to LWORK or LIWORK is */
+/* issued by XERBLA. */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+/* Not referenced if SORT = 'N'. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1,...,N: */
+/* The QZ iteration failed. (A,B) are not in Schur */
+/* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should */
+/* be correct for j=INFO+1,...,N. */
+/* > N: =N+1: other than QZ iteration failed in SHGEQZ */
+/* =N+2: after reordering, roundoff changed values of */
+/* some complex eigenvalues so that leading */
+/* eigenvalues in the Generalized Schur form no */
+/* longer satisfy SELCTG=.TRUE. This could also */
+/* be caused due to scaling. */
+/* =N+3: reordering failed in STGSEN. */
+
+/* Further details */
+/* =============== */
+
+/* An approximate (asymptotic) bound on the average absolute error of */
+/* the selected eigenvalues is */
+
+/* EPS * norm((A, B)) / RCONDE( 1 ). */
+
+/* An approximate (asymptotic) bound on the maximum angular error in */
+/* the computed deflating subspaces is */
+
+/* EPS * norm((A, B)) / RCONDV( 2 ). */
+
+/* See LAPACK User's Guide, section 4.11 for more information. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ vsl_dim1 = *ldvsl;
+ vsl_offset = 1 + vsl_dim1;
+ vsl -= vsl_offset;
+ vsr_dim1 = *ldvsr;
+ vsr_offset = 1 + vsr_dim1;
+ vsr -= vsr_offset;
+ --rconde;
+ --rcondv;
+ --work;
+ --iwork;
+ --bwork;
+
+ /* Function Body */
+ if (lsame_(jobvsl, "N")) {
+ ijobvl = 1;
+ ilvsl = FALSE_;
+ } else if (lsame_(jobvsl, "V")) {
+ ijobvl = 2;
+ ilvsl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvsl = FALSE_;
+ }
+
+ if (lsame_(jobvsr, "N")) {
+ ijobvr = 1;
+ ilvsr = FALSE_;
+ } else if (lsame_(jobvsr, "V")) {
+ ijobvr = 2;
+ ilvsr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvsr = FALSE_;
+ }
+
+ wantst = lsame_(sort, "S");
+ wantsn = lsame_(sense, "N");
+ wantse = lsame_(sense, "E");
+ wantsv = lsame_(sense, "V");
+ wantsb = lsame_(sense, "B");
+ lquery = *lwork == -1 || *liwork == -1;
+ if (wantsn) {
+ ijob = 0;
+ } else if (wantse) {
+ ijob = 1;
+ } else if (wantsv) {
+ ijob = 2;
+ } else if (wantsb) {
+ ijob = 4;
+ }
+
+/* Test the input arguments */
+
+ *info = 0;
+ if (ijobvl <= 0) {
+ *info = -1;
+ } else if (ijobvr <= 0) {
+ *info = -2;
+ } else if (! wantst && ! lsame_(sort, "N")) {
+ *info = -3;
+ } else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && !
+ wantsn) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (*lda < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
+ *info = -16;
+ } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
+ *info = -18;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ if (*info == 0) {
+ if (*n > 0) {
+/* Computing MAX */
+ i__1 = *n << 3, i__2 = *n * 6 + 16;
+ minwrk = max(i__1,i__2);
+ maxwrk = minwrk - *n + *n * ilaenv_(&c__1, "SGEQRF", " ", n, &
+ c__1, n, &c__0);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = minwrk - *n + *n * ilaenv_(&c__1, "SORMQR",
+ " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ if (ilvsl) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = minwrk - *n + *n * ilaenv_(&c__1, "SOR"
+ "GQR", " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ }
+ lwrk = maxwrk;
+ if (ijob >= 1) {
+/* Computing MAX */
+ i__1 = lwrk, i__2 = *n * *n / 2;
+ lwrk = max(i__1,i__2);
+ }
+ } else {
+ minwrk = 1;
+ maxwrk = 1;
+ lwrk = 1;
+ }
+ work[1] = (real) lwrk;
+ if (wantsn || *n == 0) {
+ liwmin = 1;
+ } else {
+ liwmin = *n + 6;
+ }
+ iwork[1] = liwmin;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -22;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -24;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGGESX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *sdim = 0;
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ safmin = slamch_("S");
+ safmax = 1.f / safmin;
+ slabad_(&safmin, &safmax);
+ smlnum = sqrt(safmin) / eps;
+ bignum = 1.f / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = slange_("M", n, n, &a[a_offset], lda, &work[1]);
+ ilascl = FALSE_;
+ if (anrm > 0.f && anrm < smlnum) {
+ anrmto = smlnum;
+ ilascl = TRUE_;
+ } else if (anrm > bignum) {
+ anrmto = bignum;
+ ilascl = TRUE_;
+ }
+ if (ilascl) {
+ slascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = slange_("M", n, n, &b[b_offset], ldb, &work[1]);
+ ilbscl = FALSE_;
+ if (bnrm > 0.f && bnrm < smlnum) {
+ bnrmto = smlnum;
+ ilbscl = TRUE_;
+ } else if (bnrm > bignum) {
+ bnrmto = bignum;
+ ilbscl = TRUE_;
+ }
+ if (ilbscl) {
+ slascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
+ ierr);
+ }
+
+/* Permute the matrix to make it more nearly triangular */
+/* (Workspace: need 6*N + 2*N for permutation parameters) */
+
+ ileft = 1;
+ iright = *n + 1;
+ iwrk = iright + *n;
+ sggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[
+ ileft], &work[iright], &work[iwrk], &ierr);
+
+/* Reduce B to triangular form (QR decomposition of B) */
+/* (Workspace: need N, prefer N*NB) */
+
+ irows = ihi + 1 - ilo;
+ icols = *n + 1 - ilo;
+ itau = iwrk;
+ iwrk = itau + irows;
+ i__1 = *lwork + 1 - iwrk;
+ sgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
+ iwrk], &i__1, &ierr);
+
+/* Apply the orthogonal transformation to matrix A */
+/* (Workspace: need N, prefer N*NB) */
+
+ i__1 = *lwork + 1 - iwrk;
+ sormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
+ work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, &
+ ierr);
+
+/* Initialize VSL */
+/* (Workspace: need N, prefer N*NB) */
+
+ if (ilvsl) {
+ slaset_("Full", n, n, &c_b42, &c_b43, &vsl[vsl_offset], ldvsl);
+ if (irows > 1) {
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ slacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[
+ ilo + 1 + ilo * vsl_dim1], ldvsl);
+ }
+ i__1 = *lwork + 1 - iwrk;
+ sorgqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, &
+ work[itau], &work[iwrk], &i__1, &ierr);
+ }
+
+/* Initialize VSR */
+
+ if (ilvsr) {
+ slaset_("Full", n, n, &c_b42, &c_b43, &vsr[vsr_offset], ldvsr);
+ }
+
+/* Reduce to generalized Hessenberg form */
+/* (Workspace: none needed) */
+
+ sgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &ierr);
+
+ *sdim = 0;
+
+/* Perform QZ algorithm, computing Schur vectors if desired */
+/* (Workspace: need N) */
+
+ iwrk = itau;
+ i__1 = *lwork + 1 - iwrk;
+ shgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[
+ b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[vsl_offset]
+, ldvsl, &vsr[vsr_offset], ldvsr, &work[iwrk], &i__1, &ierr);
+ if (ierr != 0) {
+ if (ierr > 0 && ierr <= *n) {
+ *info = ierr;
+ } else if (ierr > *n && ierr <= *n << 1) {
+ *info = ierr - *n;
+ } else {
+ *info = *n + 1;
+ }
+ goto L50;
+ }
+
+/* Sort eigenvalues ALPHA/BETA and compute the reciprocal of */
+/* condition number(s) */
+/* (Workspace: If IJOB >= 1, need MAX( 8*(N+1), 2*SDIM*(N-SDIM) ) */
+/* otherwise, need 8*(N+1) ) */
+
+ if (wantst) {
+
+/* Undo scaling on eigenvalues before SELCTGing */
+
+ if (ilascl) {
+ slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1],
+ n, &ierr);
+ slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1],
+ n, &ierr);
+ }
+ if (ilbscl) {
+ slascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n,
+ &ierr);
+ }
+
+/* Select eigenvalues */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ bwork[i__] = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]);
+/* L10: */
+ }
+
+/* Reorder eigenvalues, transform Generalized Schur vectors, and */
+/* compute reciprocal condition numbers */
+
+ i__1 = *lwork - iwrk + 1;
+ stgsen_(&ijob, &ilvsl, &ilvsr, &bwork[1], n, &a[a_offset], lda, &b[
+ b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vsl[
+ vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, sdim, &pl, &pr,
+ dif, &work[iwrk], &i__1, &iwork[1], liwork, &ierr);
+
+ if (ijob >= 1) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*sdim << 1) * (*n - *sdim);
+ maxwrk = max(i__1,i__2);
+ }
+ if (ierr == -22) {
+
+/* not enough real workspace */
+
+ *info = -22;
+ } else {
+ if (ijob == 1 || ijob == 4) {
+ rconde[1] = pl;
+ rconde[2] = pr;
+ }
+ if (ijob == 2 || ijob == 4) {
+ rcondv[1] = dif[0];
+ rcondv[2] = dif[1];
+ }
+ if (ierr == 1) {
+ *info = *n + 3;
+ }
+ }
+
+ }
+
+/* Apply permutation to VSL and VSR */
+/* (Workspace: none needed) */
+
+ if (ilvsl) {
+ sggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsl[
+ vsl_offset], ldvsl, &ierr);
+ }
+
+ if (ilvsr) {
+ sggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &vsr[
+ vsr_offset], ldvsr, &ierr);
+ }
+
+/* Check if unscaling would cause over/underflow, if so, rescale */
+/* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of */
+/* B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I) */
+
+ if (ilascl) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (alphai[i__] != 0.f) {
+ if (alphar[i__] / safmax > anrmto / anrm || safmin / alphar[
+ i__] > anrm / anrmto) {
+ work[1] = (r__1 = a[i__ + i__ * a_dim1] / alphar[i__],
+ dabs(r__1));
+ beta[i__] *= work[1];
+ alphar[i__] *= work[1];
+ alphai[i__] *= work[1];
+ } else if (alphai[i__] / safmax > anrmto / anrm || safmin /
+ alphai[i__] > anrm / anrmto) {
+ work[1] = (r__1 = a[i__ + (i__ + 1) * a_dim1] / alphai[
+ i__], dabs(r__1));
+ beta[i__] *= work[1];
+ alphar[i__] *= work[1];
+ alphai[i__] *= work[1];
+ }
+ }
+/* L20: */
+ }
+ }
+
+ if (ilbscl) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (alphai[i__] != 0.f) {
+ if (beta[i__] / safmax > bnrmto / bnrm || safmin / beta[i__]
+ > bnrm / bnrmto) {
+ work[1] = (r__1 = b[i__ + i__ * b_dim1] / beta[i__], dabs(
+ r__1));
+ beta[i__] *= work[1];
+ alphar[i__] *= work[1];
+ alphai[i__] *= work[1];
+ }
+ }
+/* L25: */
+ }
+ }
+
+/* Undo scaling */
+
+ if (ilascl) {
+ slascl_("H", &c__0, &c__0, &anrmto, &anrm, n, n, &a[a_offset], lda, &
+ ierr);
+ slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, &
+ ierr);
+ slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, &
+ ierr);
+ }
+
+ if (ilbscl) {
+ slascl_("U", &c__0, &c__0, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, &
+ ierr);
+ slascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
+ ierr);
+ }
+
+ if (wantst) {
+
+/* Check if reordering is correct */
+
+ lastsl = TRUE_;
+ lst2sl = TRUE_;
+ *sdim = 0;
+ ip = 0;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ cursl = (*selctg)(&alphar[i__], &alphai[i__], &beta[i__]);
+ if (alphai[i__] == 0.f) {
+ if (cursl) {
+ ++(*sdim);
+ }
+ ip = 0;
+ if (cursl && ! lastsl) {
+ *info = *n + 2;
+ }
+ } else {
+ if (ip == 1) {
+
+/* Last eigenvalue of conjugate pair */
+
+ cursl = cursl || lastsl;
+ lastsl = cursl;
+ if (cursl) {
+ *sdim += 2;
+ }
+ ip = -1;
+ if (cursl && ! lst2sl) {
+ *info = *n + 2;
+ }
+ } else {
+
+/* First eigenvalue of conjugate pair */
+
+ ip = 1;
+ }
+ }
+ lst2sl = lastsl;
+ lastsl = cursl;
+/* L40: */
+ }
+
+ }
+
+L50:
+
+ work[1] = (real) maxwrk;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of SGGESX */
+
+} /* sggesx_ */
diff --git a/SRC/sggev.c b/SRC/sggev.c
new file mode 100644
index 0000000..7c3537e
--- /dev/null
+++ b/SRC/sggev.c
@@ -0,0 +1,640 @@
+/* sggev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static real c_b36 = 0.f;
+static real c_b37 = 1.f;
+
+/* Subroutine */ int sggev_(char *jobvl, char *jobvr, integer *n, real *a,
+ integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real
+ *beta, real *vl, integer *ldvl, real *vr, integer *ldvr, real *work,
+ integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
+ vr_offset, i__1, i__2;
+ real r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer jc, in, jr, ihi, ilo;
+ real eps;
+ logical ilv;
+ real anrm, bnrm;
+ integer ierr, itau;
+ real temp;
+ logical ilvl, ilvr;
+ integer iwrk;
+ extern logical lsame_(char *, char *);
+ integer ileft, icols, irows;
+ extern /* Subroutine */ int slabad_(real *, real *), sggbak_(char *, char
+ *, integer *, integer *, integer *, real *, real *, integer *,
+ real *, integer *, integer *), sggbal_(char *,
+ integer *, real *, integer *, real *, integer *, integer *,
+ integer *, real *, real *, real *, integer *);
+ logical ilascl, ilbscl;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), sgghrd_(
+ char *, char *, integer *, integer *, integer *, real *, integer *
+, real *, integer *, real *, integer *, real *, integer *,
+ integer *);
+ logical ldumma[1];
+ char chtemp[1];
+ real bignum;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ijobvl, iright;
+ extern /* Subroutine */ int sgeqrf_(integer *, integer *, real *, integer
+ *, real *, real *, integer *, integer *);
+ integer ijobvr;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *), stgevc_(
+ char *, char *, logical *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, integer *,
+ integer *, real *, integer *);
+ real anrmto, bnrmto;
+ extern /* Subroutine */ int shgeqz_(char *, char *, char *, integer *,
+ integer *, integer *, real *, integer *, real *, integer *, real *
+, real *, real *, real *, integer *, real *, integer *, real *,
+ integer *, integer *);
+ integer minwrk, maxwrk;
+ real smlnum;
+ extern /* Subroutine */ int sorgqr_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *);
+ logical lquery;
+ extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B) */
+/* the generalized eigenvalues, and optionally, the left and/or right */
+/* generalized eigenvectors. */
+
+/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar */
+/* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is */
+/* singular. It is usually represented as the pair (alpha,beta), as */
+/* there is a reasonable interpretation for beta=0, and even for both */
+/* being zero. */
+
+/* The right eigenvector v(j) corresponding to the eigenvalue lambda(j) */
+/* of (A,B) satisfies */
+
+/* A * v(j) = lambda(j) * B * v(j). */
+
+/* The left eigenvector u(j) corresponding to the eigenvalue lambda(j) */
+/* of (A,B) satisfies */
+
+/* u(j)**H * A = lambda(j) * u(j)**H * B . */
+
+/* where u(j)**H is the conjugate-transpose of u(j). */
+
+
+/* Arguments */
+/* ========= */
+
+/* JOBVL (input) CHARACTER*1 */
+/* = 'N': do not compute the left generalized eigenvectors; */
+/* = 'V': compute the left generalized eigenvectors. */
+
+/* JOBVR (input) CHARACTER*1 */
+/* = 'N': do not compute the right generalized eigenvectors; */
+/* = 'V': compute the right generalized eigenvectors. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VL, and VR. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA, N) */
+/* On entry, the matrix A in the pair (A,B). */
+/* On exit, A has been overwritten. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) REAL array, dimension (LDB, N) */
+/* On entry, the matrix B in the pair (A,B). */
+/* On exit, B has been overwritten. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* ALPHAR (output) REAL array, dimension (N) */
+/* ALPHAI (output) REAL array, dimension (N) */
+/* BETA (output) REAL array, dimension (N) */
+/* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */
+/* be the generalized eigenvalues. If ALPHAI(j) is zero, then */
+/* the j-th eigenvalue is real; if positive, then the j-th and */
+/* (j+1)-st eigenvalues are a complex conjugate pair, with */
+/* ALPHAI(j+1) negative. */
+
+/* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */
+/* may easily over- or underflow, and BETA(j) may even be zero. */
+/* Thus, the user should avoid naively computing the ratio */
+/* alpha/beta. However, ALPHAR and ALPHAI will be always less */
+/* than and usually comparable with norm(A) in magnitude, and */
+/* BETA always less than and usually comparable with norm(B). */
+
+/* VL (output) REAL array, dimension (LDVL,N) */
+/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
+/* after another in the columns of VL, in the same order as */
+/* their eigenvalues. If the j-th eigenvalue is real, then */
+/* u(j) = VL(:,j), the j-th column of VL. If the j-th and */
+/* (j+1)-th eigenvalues form a complex conjugate pair, then */
+/* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1). */
+/* Each eigenvector is scaled so the largest component has */
+/* abs(real part)+abs(imag. part)=1. */
+/* Not referenced if JOBVL = 'N'. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the matrix VL. LDVL >= 1, and */
+/* if JOBVL = 'V', LDVL >= N. */
+
+/* VR (output) REAL array, dimension (LDVR,N) */
+/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
+/* after another in the columns of VR, in the same order as */
+/* their eigenvalues. If the j-th eigenvalue is real, then */
+/* v(j) = VR(:,j), the j-th column of VR. If the j-th and */
+/* (j+1)-th eigenvalues form a complex conjugate pair, then */
+/* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1). */
+/* Each eigenvector is scaled so the largest component has */
+/* abs(real part)+abs(imag. part)=1. */
+/* Not referenced if JOBVR = 'N'. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the matrix VR. LDVR >= 1, and */
+/* if JOBVR = 'V', LDVR >= N. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,8*N). */
+/* For good performance, LWORK must generally be larger. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1,...,N: */
+/* The QZ iteration failed. No eigenvectors have been */
+/* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) */
+/* should be correct for j=INFO+1,...,N. */
+/* > N: =N+1: other than QZ iteration failed in SHGEQZ. */
+/* =N+2: error return from STGEVC. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+
+ /* Function Body */
+ if (lsame_(jobvl, "N")) {
+ ijobvl = 1;
+ ilvl = FALSE_;
+ } else if (lsame_(jobvl, "V")) {
+ ijobvl = 2;
+ ilvl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvl = FALSE_;
+ }
+
+ if (lsame_(jobvr, "N")) {
+ ijobvr = 1;
+ ilvr = FALSE_;
+ } else if (lsame_(jobvr, "V")) {
+ ijobvr = 2;
+ ilvr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvr = FALSE_;
+ }
+ ilv = ilvl || ilvr;
+
+/* Test the input arguments */
+
+ *info = 0;
+ lquery = *lwork == -1;
+ if (ijobvl <= 0) {
+ *info = -1;
+ } else if (ijobvr <= 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvl < 1 || ilvl && *ldvl < *n) {
+ *info = -12;
+ } else if (*ldvr < 1 || ilvr && *ldvr < *n) {
+ *info = -14;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. The workspace is */
+/* computed assuming ILO = 1 and IHI = N, the worst case.) */
+
+ if (*info == 0) {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n << 3;
+ minwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * (ilaenv_(&c__1, "SGEQRF", " ", n, &c__1, n, &
+ c__0) + 7);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * (ilaenv_(&c__1, "SORMQR", " ", n, &c__1, n,
+ &c__0) + 7);
+ maxwrk = max(i__1,i__2);
+ if (ilvl) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * (ilaenv_(&c__1, "SORGQR", " ", n, &
+ c__1, n, &c_n1) + 7);
+ maxwrk = max(i__1,i__2);
+ }
+ work[1] = (real) maxwrk;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -16;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGGEV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1.f / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = slange_("M", n, n, &a[a_offset], lda, &work[1]);
+ ilascl = FALSE_;
+ if (anrm > 0.f && anrm < smlnum) {
+ anrmto = smlnum;
+ ilascl = TRUE_;
+ } else if (anrm > bignum) {
+ anrmto = bignum;
+ ilascl = TRUE_;
+ }
+ if (ilascl) {
+ slascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = slange_("M", n, n, &b[b_offset], ldb, &work[1]);
+ ilbscl = FALSE_;
+ if (bnrm > 0.f && bnrm < smlnum) {
+ bnrmto = smlnum;
+ ilbscl = TRUE_;
+ } else if (bnrm > bignum) {
+ bnrmto = bignum;
+ ilbscl = TRUE_;
+ }
+ if (ilbscl) {
+ slascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
+ ierr);
+ }
+
+/* Permute the matrices A, B to isolate eigenvalues if possible */
+/* (Workspace: need 6*N) */
+
+ ileft = 1;
+ iright = *n + 1;
+ iwrk = iright + *n;
+ sggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &work[
+ ileft], &work[iright], &work[iwrk], &ierr);
+
+/* Reduce B to triangular form (QR decomposition of B) */
+/* (Workspace: need N, prefer N*NB) */
+
+ irows = ihi + 1 - ilo;
+ if (ilv) {
+ icols = *n + 1 - ilo;
+ } else {
+ icols = irows;
+ }
+ itau = iwrk;
+ iwrk = itau + irows;
+ i__1 = *lwork + 1 - iwrk;
+ sgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
+ iwrk], &i__1, &ierr);
+
+/* Apply the orthogonal transformation to matrix A */
+/* (Workspace: need N, prefer N*NB) */
+
+ i__1 = *lwork + 1 - iwrk;
+ sormqr_("L", "T", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
+ work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, &
+ ierr);
+
+/* Initialize VL */
+/* (Workspace: need N, prefer N*NB) */
+
+ if (ilvl) {
+ slaset_("Full", n, n, &c_b36, &c_b37, &vl[vl_offset], ldvl)
+ ;
+ if (irows > 1) {
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ slacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vl[
+ ilo + 1 + ilo * vl_dim1], ldvl);
+ }
+ i__1 = *lwork + 1 - iwrk;
+ sorgqr_(&irows, &irows, &irows, &vl[ilo + ilo * vl_dim1], ldvl, &work[
+ itau], &work[iwrk], &i__1, &ierr);
+ }
+
+/* Initialize VR */
+
+ if (ilvr) {
+ slaset_("Full", n, n, &c_b36, &c_b37, &vr[vr_offset], ldvr)
+ ;
+ }
+
+/* Reduce to generalized Hessenberg form */
+/* (Workspace: none needed) */
+
+ if (ilv) {
+
+/* Eigenvectors requested -- work on whole matrix. */
+
+ sgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr);
+ } else {
+ sgghrd_("N", "N", &irows, &c__1, &irows, &a[ilo + ilo * a_dim1], lda,
+ &b[ilo + ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[
+ vr_offset], ldvr, &ierr);
+ }
+
+/* Perform QZ algorithm (Compute eigenvalues, and optionally, the */
+/* Schur forms and Schur vectors) */
+/* (Workspace: need N) */
+
+ iwrk = itau;
+ if (ilv) {
+ *(unsigned char *)chtemp = 'S';
+ } else {
+ *(unsigned char *)chtemp = 'E';
+ }
+ i__1 = *lwork + 1 - iwrk;
+ shgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[
+ b_offset], ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset],
+ ldvl, &vr[vr_offset], ldvr, &work[iwrk], &i__1, &ierr);
+ if (ierr != 0) {
+ if (ierr > 0 && ierr <= *n) {
+ *info = ierr;
+ } else if (ierr > *n && ierr <= *n << 1) {
+ *info = ierr - *n;
+ } else {
+ *info = *n + 1;
+ }
+ goto L110;
+ }
+
+/* Compute Eigenvectors */
+/* (Workspace: need 6*N) */
+
+ if (ilv) {
+ if (ilvl) {
+ if (ilvr) {
+ *(unsigned char *)chtemp = 'B';
+ } else {
+ *(unsigned char *)chtemp = 'L';
+ }
+ } else {
+ *(unsigned char *)chtemp = 'R';
+ }
+ stgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb,
+ &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[
+ iwrk], &ierr);
+ if (ierr != 0) {
+ *info = *n + 2;
+ goto L110;
+ }
+
+/* Undo balancing on VL and VR and normalization */
+/* (Workspace: none needed) */
+
+ if (ilvl) {
+ sggbak_("P", "L", n, &ilo, &ihi, &work[ileft], &work[iright], n, &
+ vl[vl_offset], ldvl, &ierr);
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ if (alphai[jc] < 0.f) {
+ goto L50;
+ }
+ temp = 0.f;
+ if (alphai[jc] == 0.f) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ r__2 = temp, r__3 = (r__1 = vl[jr + jc * vl_dim1],
+ dabs(r__1));
+ temp = dmax(r__2,r__3);
+/* L10: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ r__3 = temp, r__4 = (r__1 = vl[jr + jc * vl_dim1],
+ dabs(r__1)) + (r__2 = vl[jr + (jc + 1) *
+ vl_dim1], dabs(r__2));
+ temp = dmax(r__3,r__4);
+/* L20: */
+ }
+ }
+ if (temp < smlnum) {
+ goto L50;
+ }
+ temp = 1.f / temp;
+ if (alphai[jc] == 0.f) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vl[jr + jc * vl_dim1] *= temp;
+/* L30: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vl[jr + jc * vl_dim1] *= temp;
+ vl[jr + (jc + 1) * vl_dim1] *= temp;
+/* L40: */
+ }
+ }
+L50:
+ ;
+ }
+ }
+ if (ilvr) {
+ sggbak_("P", "R", n, &ilo, &ihi, &work[ileft], &work[iright], n, &
+ vr[vr_offset], ldvr, &ierr);
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ if (alphai[jc] < 0.f) {
+ goto L100;
+ }
+ temp = 0.f;
+ if (alphai[jc] == 0.f) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ r__2 = temp, r__3 = (r__1 = vr[jr + jc * vr_dim1],
+ dabs(r__1));
+ temp = dmax(r__2,r__3);
+/* L60: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ r__3 = temp, r__4 = (r__1 = vr[jr + jc * vr_dim1],
+ dabs(r__1)) + (r__2 = vr[jr + (jc + 1) *
+ vr_dim1], dabs(r__2));
+ temp = dmax(r__3,r__4);
+/* L70: */
+ }
+ }
+ if (temp < smlnum) {
+ goto L100;
+ }
+ temp = 1.f / temp;
+ if (alphai[jc] == 0.f) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vr[jr + jc * vr_dim1] *= temp;
+/* L80: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vr[jr + jc * vr_dim1] *= temp;
+ vr[jr + (jc + 1) * vr_dim1] *= temp;
+/* L90: */
+ }
+ }
+L100:
+ ;
+ }
+ }
+
+/* End of eigenvector calculation */
+
+ }
+
+/* Undo scaling if necessary */
+
+ if (ilascl) {
+ slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, &
+ ierr);
+ slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, &
+ ierr);
+ }
+
+ if (ilbscl) {
+ slascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
+ ierr);
+ }
+
+L110:
+
+ work[1] = (real) maxwrk;
+
+ return 0;
+
+/* End of SGGEV */
+
+} /* sggev_ */
diff --git a/SRC/sggevx.c b/SRC/sggevx.c
new file mode 100644
index 0000000..7130d3a
--- /dev/null
+++ b/SRC/sggevx.c
@@ -0,0 +1,879 @@
+/* sggevx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static real c_b57 = 0.f;
+static real c_b58 = 1.f;
+
+/* Subroutine */ int sggevx_(char *balanc, char *jobvl, char *jobvr, char *
+ sense, integer *n, real *a, integer *lda, real *b, integer *ldb, real
+ *alphar, real *alphai, real *beta, real *vl, integer *ldvl, real *vr,
+ integer *ldvr, integer *ilo, integer *ihi, real *lscale, real *rscale,
+ real *abnrm, real *bbnrm, real *rconde, real *rcondv, real *work,
+ integer *lwork, integer *iwork, logical *bwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
+ vr_offset, i__1, i__2;
+ real r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, m, jc, in, mm, jr;
+ real eps;
+ logical ilv, pair;
+ real anrm, bnrm;
+ integer ierr, itau;
+ real temp;
+ logical ilvl, ilvr;
+ integer iwrk, iwrk1;
+ extern logical lsame_(char *, char *);
+ integer icols;
+ logical noscl;
+ integer irows;
+ extern /* Subroutine */ int slabad_(real *, real *), sggbak_(char *, char
+ *, integer *, integer *, integer *, real *, real *, integer *,
+ real *, integer *, integer *), sggbal_(char *,
+ integer *, real *, integer *, real *, integer *, integer *,
+ integer *, real *, real *, real *, integer *);
+ logical ilascl, ilbscl;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), sgghrd_(
+ char *, char *, integer *, integer *, integer *, real *, integer *
+, real *, integer *, real *, integer *, real *, integer *,
+ integer *);
+ logical ldumma[1];
+ char chtemp[1];
+ real bignum;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern doublereal slange_(char *, integer *, integer *, real *, integer *,
+ real *);
+ integer ijobvl;
+ extern /* Subroutine */ int sgeqrf_(integer *, integer *, real *, integer
+ *, real *, real *, integer *, integer *);
+ integer ijobvr;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+ logical wantsb;
+ extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *);
+ real anrmto;
+ logical wantse;
+ real bnrmto;
+ extern /* Subroutine */ int shgeqz_(char *, char *, char *, integer *,
+ integer *, integer *, real *, integer *, real *, integer *, real *
+, real *, real *, real *, integer *, real *, integer *, real *,
+ integer *, integer *), stgevc_(char *,
+ char *, logical *, integer *, real *, integer *, real *, integer *
+, real *, integer *, real *, integer *, integer *, integer *,
+ real *, integer *), stgsna_(char *, char *,
+ logical *, integer *, real *, integer *, real *, integer *, real *
+, integer *, real *, integer *, real *, real *, integer *,
+ integer *, real *, integer *, integer *, integer *);
+ integer minwrk, maxwrk;
+ logical wantsn;
+ real smlnum;
+ extern /* Subroutine */ int sorgqr_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *);
+ logical lquery, wantsv;
+ extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B) */
+/* the generalized eigenvalues, and optionally, the left and/or right */
+/* generalized eigenvectors. */
+
+/* Optionally also, it computes a balancing transformation to improve */
+/* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */
+/* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for */
+/* the eigenvalues (RCONDE), and reciprocal condition numbers for the */
+/* right eigenvectors (RCONDV). */
+
+/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar */
+/* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is */
+/* singular. It is usually represented as the pair (alpha,beta), as */
+/* there is a reasonable interpretation for beta=0, and even for both */
+/* being zero. */
+
+/* The right eigenvector v(j) corresponding to the eigenvalue lambda(j) */
+/* of (A,B) satisfies */
+
+/* A * v(j) = lambda(j) * B * v(j) . */
+
+/* The left eigenvector u(j) corresponding to the eigenvalue lambda(j) */
+/* of (A,B) satisfies */
+
+/* u(j)**H * A = lambda(j) * u(j)**H * B. */
+
+/* where u(j)**H is the conjugate-transpose of u(j). */
+
+
+/* Arguments */
+/* ========= */
+
+/* BALANC (input) CHARACTER*1 */
+/* Specifies the balance option to be performed. */
+/* = 'N': do not diagonally scale or permute; */
+/* = 'P': permute only; */
+/* = 'S': scale only; */
+/* = 'B': both permute and scale. */
+/* Computed reciprocal condition numbers will be for the */
+/* matrices after permuting and/or balancing. Permuting does */
+/* not change condition numbers (in exact arithmetic), but */
+/* balancing does. */
+
+/* JOBVL (input) CHARACTER*1 */
+/* = 'N': do not compute the left generalized eigenvectors; */
+/* = 'V': compute the left generalized eigenvectors. */
+
+/* JOBVR (input) CHARACTER*1 */
+/* = 'N': do not compute the right generalized eigenvectors; */
+/* = 'V': compute the right generalized eigenvectors. */
+
+/* SENSE (input) CHARACTER*1 */
+/* Determines which reciprocal condition numbers are computed. */
+/* = 'N': none are computed; */
+/* = 'E': computed for eigenvalues only; */
+/* = 'V': computed for eigenvectors only; */
+/* = 'B': computed for eigenvalues and eigenvectors. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VL, and VR. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA, N) */
+/* On entry, the matrix A in the pair (A,B). */
+/* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V' */
+/* or both, then A contains the first part of the real Schur */
+/* form of the "balanced" versions of the input A and B. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) REAL array, dimension (LDB, N) */
+/* On entry, the matrix B in the pair (A,B). */
+/* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V' */
+/* or both, then B contains the second part of the real Schur */
+/* form of the "balanced" versions of the input A and B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* ALPHAR (output) REAL array, dimension (N) */
+/* ALPHAI (output) REAL array, dimension (N) */
+/* BETA (output) REAL array, dimension (N) */
+/* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */
+/* be the generalized eigenvalues. If ALPHAI(j) is zero, then */
+/* the j-th eigenvalue is real; if positive, then the j-th and */
+/* (j+1)-st eigenvalues are a complex conjugate pair, with */
+/* ALPHAI(j+1) negative. */
+
+/* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) */
+/* may easily over- or underflow, and BETA(j) may even be zero. */
+/* Thus, the user should avoid naively computing the ratio */
+/* ALPHA/BETA. However, ALPHAR and ALPHAI will be always less */
+/* than and usually comparable with norm(A) in magnitude, and */
+/* BETA always less than and usually comparable with norm(B). */
+
+/* VL (output) REAL array, dimension (LDVL,N) */
+/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
+/* after another in the columns of VL, in the same order as */
+/* their eigenvalues. If the j-th eigenvalue is real, then */
+/* u(j) = VL(:,j), the j-th column of VL. If the j-th and */
+/* (j+1)-th eigenvalues form a complex conjugate pair, then */
+/* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1). */
+/* Each eigenvector will be scaled so the largest component have */
+/* abs(real part) + abs(imag. part) = 1. */
+/* Not referenced if JOBVL = 'N'. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the matrix VL. LDVL >= 1, and */
+/* if JOBVL = 'V', LDVL >= N. */
+
+/* VR (output) REAL array, dimension (LDVR,N) */
+/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
+/* after another in the columns of VR, in the same order as */
+/* their eigenvalues. If the j-th eigenvalue is real, then */
+/* v(j) = VR(:,j), the j-th column of VR. If the j-th and */
+/* (j+1)-th eigenvalues form a complex conjugate pair, then */
+/* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1). */
+/* Each eigenvector will be scaled so the largest component have */
+/* abs(real part) + abs(imag. part) = 1. */
+/* Not referenced if JOBVR = 'N'. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the matrix VR. LDVR >= 1, and */
+/* if JOBVR = 'V', LDVR >= N. */
+
+/* ILO (output) INTEGER */
+/* IHI (output) INTEGER */
+/* ILO and IHI are integer values such that on exit */
+/* A(i,j) = 0 and B(i,j) = 0 if i > j and */
+/* j = 1,...,ILO-1 or i = IHI+1,...,N. */
+/* If BALANC = 'N' or 'S', ILO = 1 and IHI = N. */
+
+/* LSCALE (output) REAL array, dimension (N) */
+/* Details of the permutations and scaling factors applied */
+/* to the left side of A and B. If PL(j) is the index of the */
+/* row interchanged with row j, and DL(j) is the scaling */
+/* factor applied to row j, then */
+/* LSCALE(j) = PL(j) for j = 1,...,ILO-1 */
+/* = DL(j) for j = ILO,...,IHI */
+/* = PL(j) for j = IHI+1,...,N. */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* RSCALE (output) REAL array, dimension (N) */
+/* Details of the permutations and scaling factors applied */
+/* to the right side of A and B. If PR(j) is the index of the */
+/* column interchanged with column j, and DR(j) is the scaling */
+/* factor applied to column j, then */
+/* RSCALE(j) = PR(j) for j = 1,...,ILO-1 */
+/* = DR(j) for j = ILO,...,IHI */
+/* = PR(j) for j = IHI+1,...,N */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* ABNRM (output) REAL */
+/* The one-norm of the balanced matrix A. */
+
+/* BBNRM (output) REAL */
+/* The one-norm of the balanced matrix B. */
+
+/* RCONDE (output) REAL array, dimension (N) */
+/* If SENSE = 'E' or 'B', the reciprocal condition numbers of */
+/* the eigenvalues, stored in consecutive elements of the array. */
+/* For a complex conjugate pair of eigenvalues two consecutive */
+/* elements of RCONDE are set to the same value. Thus RCONDE(j), */
+/* RCONDV(j), and the j-th columns of VL and VR all correspond */
+/* to the j-th eigenpair. */
+/* If SENSE = 'N' or 'V', RCONDE is not referenced. */
+
+/* RCONDV (output) REAL array, dimension (N) */
+/* If SENSE = 'V' or 'B', the estimated reciprocal condition */
+/* numbers of the eigenvectors, stored in consecutive elements */
+/* of the array. For a complex eigenvector two consecutive */
+/* elements of RCONDV are set to the same value. If the */
+/* eigenvalues cannot be reordered to compute RCONDV(j), */
+/* RCONDV(j) is set to 0; this can only occur when the true */
+/* value would be very small anyway. */
+/* If SENSE = 'N' or 'E', RCONDV is not referenced. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,2*N). */
+/* If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V', */
+/* LWORK >= max(1,6*N). */
+/* If SENSE = 'E', LWORK >= max(1,10*N). */
+/* If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16. */
+
+/* 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. */
+
+/* IWORK (workspace) INTEGER array, dimension (N+6) */
+/* If SENSE = 'E', IWORK is not referenced. */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+/* If SENSE = 'N', BWORK is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1,...,N: */
+/* The QZ iteration failed. No eigenvectors have been */
+/* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) */
+/* should be correct for j=INFO+1,...,N. */
+/* > N: =N+1: other than QZ iteration failed in SHGEQZ. */
+/* =N+2: error return from STGEVC. */
+
+/* Further Details */
+/* =============== */
+
+/* Balancing a matrix pair (A,B) includes, first, permuting rows and */
+/* columns to isolate eigenvalues, second, applying diagonal similarity */
+/* transformation to the rows and columns to make the rows and columns */
+/* as close in norm as possible. The computed reciprocal condition */
+/* numbers correspond to the balanced matrix. Permuting rows and columns */
+/* will not change the condition numbers (in exact arithmetic) but */
+/* diagonal scaling will. For further explanation of balancing, see */
+/* section 4.11.1.2 of LAPACK Users' Guide. */
+
+/* An approximate error bound on the chordal distance between the i-th */
+/* computed generalized eigenvalue w and the corresponding exact */
+/* eigenvalue lambda is */
+
+/* chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I) */
+
+/* An approximate error bound for the angle between the i-th computed */
+/* eigenvector VL(i) or VR(i) is given by */
+
+/* EPS * norm(ABNRM, BBNRM) / DIF(i). */
+
+/* For further explanation of the reciprocal condition numbers RCONDE */
+/* and RCONDV, see section 4.11 of LAPACK User's Guide. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --lscale;
+ --rscale;
+ --rconde;
+ --rcondv;
+ --work;
+ --iwork;
+ --bwork;
+
+ /* Function Body */
+ if (lsame_(jobvl, "N")) {
+ ijobvl = 1;
+ ilvl = FALSE_;
+ } else if (lsame_(jobvl, "V")) {
+ ijobvl = 2;
+ ilvl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvl = FALSE_;
+ }
+
+ if (lsame_(jobvr, "N")) {
+ ijobvr = 1;
+ ilvr = FALSE_;
+ } else if (lsame_(jobvr, "V")) {
+ ijobvr = 2;
+ ilvr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvr = FALSE_;
+ }
+ ilv = ilvl || ilvr;
+
+ noscl = lsame_(balanc, "N") || lsame_(balanc, "P");
+ wantsn = lsame_(sense, "N");
+ wantse = lsame_(sense, "E");
+ wantsv = lsame_(sense, "V");
+ wantsb = lsame_(sense, "B");
+
+/* Test the input arguments */
+
+ *info = 0;
+ lquery = *lwork == -1;
+ if (! (noscl || lsame_(balanc, "S") || lsame_(
+ balanc, "B"))) {
+ *info = -1;
+ } else if (ijobvl <= 0) {
+ *info = -2;
+ } else if (ijobvr <= 0) {
+ *info = -3;
+ } else if (! (wantsn || wantse || wantsb || wantsv)) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldvl < 1 || ilvl && *ldvl < *n) {
+ *info = -14;
+ } else if (*ldvr < 1 || ilvr && *ldvr < *n) {
+ *info = -16;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. The workspace is */
+/* computed assuming ILO = 1 and IHI = N, the worst case.) */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ } else {
+ if (noscl && ! ilv) {
+ minwrk = *n << 1;
+ } else {
+ minwrk = *n * 6;
+ }
+ if (wantse) {
+ minwrk = *n * 10;
+ } else if (wantsv || wantsb) {
+ minwrk = (*n << 1) * (*n + 4) + 16;
+ }
+ maxwrk = minwrk;
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "SGEQRF", " ", n, &
+ c__1, n, &c__0);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "SORMQR", " ", n, &
+ c__1, n, &c__0);
+ maxwrk = max(i__1,i__2);
+ if (ilvl) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "SORGQR",
+ " ", n, &c__1, n, &c__0);
+ maxwrk = max(i__1,i__2);
+ }
+ }
+ work[1] = (real) maxwrk;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -26;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGGEVX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1.f / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = slange_("M", n, n, &a[a_offset], lda, &work[1]);
+ ilascl = FALSE_;
+ if (anrm > 0.f && anrm < smlnum) {
+ anrmto = smlnum;
+ ilascl = TRUE_;
+ } else if (anrm > bignum) {
+ anrmto = bignum;
+ ilascl = TRUE_;
+ }
+ if (ilascl) {
+ slascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = slange_("M", n, n, &b[b_offset], ldb, &work[1]);
+ ilbscl = FALSE_;
+ if (bnrm > 0.f && bnrm < smlnum) {
+ bnrmto = smlnum;
+ ilbscl = TRUE_;
+ } else if (bnrm > bignum) {
+ bnrmto = bignum;
+ ilbscl = TRUE_;
+ }
+ if (ilbscl) {
+ slascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
+ ierr);
+ }
+
+/* Permute and/or balance the matrix pair (A,B) */
+/* (Workspace: need 6*N if BALANC = 'S' or 'B', 1 otherwise) */
+
+ sggbal_(balanc, n, &a[a_offset], lda, &b[b_offset], ldb, ilo, ihi, &
+ lscale[1], &rscale[1], &work[1], &ierr);
+
+/* Compute ABNRM and BBNRM */
+
+ *abnrm = slange_("1", n, n, &a[a_offset], lda, &work[1]);
+ if (ilascl) {
+ work[1] = *abnrm;
+ slascl_("G", &c__0, &c__0, &anrmto, &anrm, &c__1, &c__1, &work[1], &
+ c__1, &ierr);
+ *abnrm = work[1];
+ }
+
+ *bbnrm = slange_("1", n, n, &b[b_offset], ldb, &work[1]);
+ if (ilbscl) {
+ work[1] = *bbnrm;
+ slascl_("G", &c__0, &c__0, &bnrmto, &bnrm, &c__1, &c__1, &work[1], &
+ c__1, &ierr);
+ *bbnrm = work[1];
+ }
+
+/* Reduce B to triangular form (QR decomposition of B) */
+/* (Workspace: need N, prefer N*NB ) */
+
+ irows = *ihi + 1 - *ilo;
+ if (ilv || ! wantsn) {
+ icols = *n + 1 - *ilo;
+ } else {
+ icols = irows;
+ }
+ itau = 1;
+ iwrk = itau + irows;
+ i__1 = *lwork + 1 - iwrk;
+ sgeqrf_(&irows, &icols, &b[*ilo + *ilo * b_dim1], ldb, &work[itau], &work[
+ iwrk], &i__1, &ierr);
+
+/* Apply the orthogonal transformation to A */
+/* (Workspace: need N, prefer N*NB) */
+
+ i__1 = *lwork + 1 - iwrk;
+ sormqr_("L", "T", &irows, &icols, &irows, &b[*ilo + *ilo * b_dim1], ldb, &
+ work[itau], &a[*ilo + *ilo * a_dim1], lda, &work[iwrk], &i__1, &
+ ierr);
+
+/* Initialize VL and/or VR */
+/* (Workspace: need N, prefer N*NB) */
+
+ if (ilvl) {
+ slaset_("Full", n, n, &c_b57, &c_b58, &vl[vl_offset], ldvl)
+ ;
+ if (irows > 1) {
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ slacpy_("L", &i__1, &i__2, &b[*ilo + 1 + *ilo * b_dim1], ldb, &vl[
+ *ilo + 1 + *ilo * vl_dim1], ldvl);
+ }
+ i__1 = *lwork + 1 - iwrk;
+ sorgqr_(&irows, &irows, &irows, &vl[*ilo + *ilo * vl_dim1], ldvl, &
+ work[itau], &work[iwrk], &i__1, &ierr);
+ }
+
+ if (ilvr) {
+ slaset_("Full", n, n, &c_b57, &c_b58, &vr[vr_offset], ldvr)
+ ;
+ }
+
+/* Reduce to generalized Hessenberg form */
+/* (Workspace: none needed) */
+
+ if (ilv || ! wantsn) {
+
+/* Eigenvectors requested -- work on whole matrix. */
+
+ sgghrd_(jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr);
+ } else {
+ sgghrd_("N", "N", &irows, &c__1, &irows, &a[*ilo + *ilo * a_dim1],
+ lda, &b[*ilo + *ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[
+ vr_offset], ldvr, &ierr);
+ }
+
+/* Perform QZ algorithm (Compute eigenvalues, and optionally, the */
+/* Schur forms and Schur vectors) */
+/* (Workspace: need N) */
+
+ if (ilv || ! wantsn) {
+ *(unsigned char *)chtemp = 'S';
+ } else {
+ *(unsigned char *)chtemp = 'E';
+ }
+
+ shgeqz_(chtemp, jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset]
+, ldb, &alphar[1], &alphai[1], &beta[1], &vl[vl_offset], ldvl, &
+ vr[vr_offset], ldvr, &work[1], lwork, &ierr);
+ if (ierr != 0) {
+ if (ierr > 0 && ierr <= *n) {
+ *info = ierr;
+ } else if (ierr > *n && ierr <= *n << 1) {
+ *info = ierr - *n;
+ } else {
+ *info = *n + 1;
+ }
+ goto L130;
+ }
+
+/* Compute Eigenvectors and estimate condition numbers if desired */
+/* (Workspace: STGEVC: need 6*N */
+/* STGSNA: need 2*N*(N+2)+16 if SENSE = 'V' or 'B', */
+/* need N otherwise ) */
+
+ if (ilv || ! wantsn) {
+ if (ilv) {
+ if (ilvl) {
+ if (ilvr) {
+ *(unsigned char *)chtemp = 'B';
+ } else {
+ *(unsigned char *)chtemp = 'L';
+ }
+ } else {
+ *(unsigned char *)chtemp = 'R';
+ }
+
+ stgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset],
+ ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &
+ work[1], &ierr);
+ if (ierr != 0) {
+ *info = *n + 2;
+ goto L130;
+ }
+ }
+
+ if (! wantsn) {
+
+/* compute eigenvectors (STGEVC) and estimate condition */
+/* numbers (STGSNA). Note that the definition of the condition */
+/* number is not invariant under transformation (u,v) to */
+/* (Q*u, Z*v), where (u,v) are eigenvectors of the generalized */
+/* Schur form (S,T), Q and Z are orthogonal matrices. In order */
+/* to avoid using extra 2*N*N workspace, we have to recalculate */
+/* eigenvectors and estimate one condition numbers at a time. */
+
+ pair = FALSE_;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+ if (pair) {
+ pair = FALSE_;
+ goto L20;
+ }
+ mm = 1;
+ if (i__ < *n) {
+ if (a[i__ + 1 + i__ * a_dim1] != 0.f) {
+ pair = TRUE_;
+ mm = 2;
+ }
+ }
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ bwork[j] = FALSE_;
+/* L10: */
+ }
+ if (mm == 1) {
+ bwork[i__] = TRUE_;
+ } else if (mm == 2) {
+ bwork[i__] = TRUE_;
+ bwork[i__ + 1] = TRUE_;
+ }
+
+ iwrk = mm * *n + 1;
+ iwrk1 = iwrk + mm * *n;
+
+/* Compute a pair of left and right eigenvectors. */
+/* (compute workspace: need up to 4*N + 6*N) */
+
+ if (wantse || wantsb) {
+ stgevc_("B", "S", &bwork[1], n, &a[a_offset], lda, &b[
+ b_offset], ldb, &work[1], n, &work[iwrk], n, &mm,
+ &m, &work[iwrk1], &ierr);
+ if (ierr != 0) {
+ *info = *n + 2;
+ goto L130;
+ }
+ }
+
+ i__2 = *lwork - iwrk1 + 1;
+ stgsna_(sense, "S", &bwork[1], n, &a[a_offset], lda, &b[
+ b_offset], ldb, &work[1], n, &work[iwrk], n, &rconde[
+ i__], &rcondv[i__], &mm, &m, &work[iwrk1], &i__2, &
+ iwork[1], &ierr);
+
+L20:
+ ;
+ }
+ }
+ }
+
+/* Undo balancing on VL and VR and normalization */
+/* (Workspace: none needed) */
+
+ if (ilvl) {
+ sggbak_(balanc, "L", n, ilo, ihi, &lscale[1], &rscale[1], n, &vl[
+ vl_offset], ldvl, &ierr);
+
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ if (alphai[jc] < 0.f) {
+ goto L70;
+ }
+ temp = 0.f;
+ if (alphai[jc] == 0.f) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ r__2 = temp, r__3 = (r__1 = vl[jr + jc * vl_dim1], dabs(
+ r__1));
+ temp = dmax(r__2,r__3);
+/* L30: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ r__3 = temp, r__4 = (r__1 = vl[jr + jc * vl_dim1], dabs(
+ r__1)) + (r__2 = vl[jr + (jc + 1) * vl_dim1],
+ dabs(r__2));
+ temp = dmax(r__3,r__4);
+/* L40: */
+ }
+ }
+ if (temp < smlnum) {
+ goto L70;
+ }
+ temp = 1.f / temp;
+ if (alphai[jc] == 0.f) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vl[jr + jc * vl_dim1] *= temp;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vl[jr + jc * vl_dim1] *= temp;
+ vl[jr + (jc + 1) * vl_dim1] *= temp;
+/* L60: */
+ }
+ }
+L70:
+ ;
+ }
+ }
+ if (ilvr) {
+ sggbak_(balanc, "R", n, ilo, ihi, &lscale[1], &rscale[1], n, &vr[
+ vr_offset], ldvr, &ierr);
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ if (alphai[jc] < 0.f) {
+ goto L120;
+ }
+ temp = 0.f;
+ if (alphai[jc] == 0.f) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ r__2 = temp, r__3 = (r__1 = vr[jr + jc * vr_dim1], dabs(
+ r__1));
+ temp = dmax(r__2,r__3);
+/* L80: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ r__3 = temp, r__4 = (r__1 = vr[jr + jc * vr_dim1], dabs(
+ r__1)) + (r__2 = vr[jr + (jc + 1) * vr_dim1],
+ dabs(r__2));
+ temp = dmax(r__3,r__4);
+/* L90: */
+ }
+ }
+ if (temp < smlnum) {
+ goto L120;
+ }
+ temp = 1.f / temp;
+ if (alphai[jc] == 0.f) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vr[jr + jc * vr_dim1] *= temp;
+/* L100: */
+ }
+ } else {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vr[jr + jc * vr_dim1] *= temp;
+ vr[jr + (jc + 1) * vr_dim1] *= temp;
+/* L110: */
+ }
+ }
+L120:
+ ;
+ }
+ }
+
+/* Undo scaling if necessary */
+
+ if (ilascl) {
+ slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphar[1], n, &
+ ierr);
+ slascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alphai[1], n, &
+ ierr);
+ }
+
+ if (ilbscl) {
+ slascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
+ ierr);
+ }
+
+L130:
+ work[1] = (real) maxwrk;
+
+ return 0;
+
+/* End of SGGEVX */
+
+} /* sggevx_ */
diff --git a/SRC/sggglm.c b/SRC/sggglm.c
new file mode 100644
index 0000000..254ea8c
--- /dev/null
+++ b/SRC/sggglm.c
@@ -0,0 +1,326 @@
+/* sggglm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b32 = -1.f;
+static real c_b34 = 1.f;
+
+/* Subroutine */ int sggglm_(integer *n, integer *m, integer *p, real *a,
+ integer *lda, real *b, integer *ldb, real *d__, real *x, real *y,
+ real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, nb, np, nb1, nb2, nb3, nb4, lopt;
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *),
+ xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int sggqrf_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, real *, real *, integer *
+, integer *);
+ integer lwkmin, lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *), sormrq_(char *, char *,
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, integer *, real *, integer *, integer *),
+ strtrs_(char *, char *, char *, integer *, integer *, real *,
+ integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGGGLM solves a general Gauss-Markov linear model (GLM) problem: */
+
+/* minimize || y ||_2 subject to d = A*x + B*y */
+/* x */
+
+/* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a */
+/* given N-vector. It is assumed that M <= N <= M+P, and */
+
+/* rank(A) = M and rank( A B ) = N. */
+
+/* Under these assumptions, the constrained equation is always */
+/* consistent, and there is a unique solution x and a minimal 2-norm */
+/* solution y, which is obtained using a generalized QR factorization */
+/* of the matrices (A, B) given by */
+
+/* A = Q*(R), B = Q*T*Z. */
+/* (0) */
+
+/* In particular, if matrix B is square nonsingular, then the problem */
+/* GLM is equivalent to the following weighted linear least squares */
+/* problem */
+
+/* minimize || inv(B)*(d-A*x) ||_2 */
+/* x */
+
+/* where inv(B) denotes the inverse of B. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices A and B. N >= 0. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix A. 0 <= M <= N. */
+
+/* P (input) INTEGER */
+/* The number of columns of the matrix B. P >= N-M. */
+
+/* A (input/output) REAL array, dimension (LDA,M) */
+/* On entry, the N-by-M matrix A. */
+/* On exit, the upper triangular part of the array A contains */
+/* the M-by-M upper triangular matrix R. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) REAL array, dimension (LDB,P) */
+/* On entry, the N-by-P matrix B. */
+/* On exit, if N <= P, the upper triangle of the subarray */
+/* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T; */
+/* if N > P, the elements on and above the (N-P)th subdiagonal */
+/* contain the N-by-P upper trapezoidal matrix T. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, D is the left hand side of the GLM equation. */
+/* On exit, D is destroyed. */
+
+/* X (output) REAL array, dimension (M) */
+/* Y (output) REAL array, dimension (P) */
+/* On exit, X and Y are the solutions of the GLM problem. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N+M+P). */
+/* For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB, */
+/* where NB is an upper bound for the optimal blocksizes for */
+/* SGEQRF, SGERQF, SORMQR and SORMRQ. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1: the upper triangular factor R associated with A in the */
+/* generalized QR factorization of the pair (A, B) is */
+/* singular, so that rank(A) < M; the least squares */
+/* solution could not be computed. */
+/* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal */
+/* factor T associated with B in the generalized QR */
+/* factorization of the pair (A, B) is singular, so that */
+/* rank( A B ) < N; the least squares solution could not */
+/* be computed. */
+
+/* =================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --d__;
+ --x;
+ --y;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ np = min(*n,*p);
+ lquery = *lwork == -1;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*m < 0 || *m > *n) {
+ *info = -2;
+ } else if (*p < 0 || *p < *n - *m) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+
+/* Calculate workspace */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ lwkmin = 1;
+ lwkopt = 1;
+ } else {
+ nb1 = ilaenv_(&c__1, "SGEQRF", " ", n, m, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "SGERQF", " ", n, m, &c_n1, &c_n1);
+ nb3 = ilaenv_(&c__1, "SORMQR", " ", n, m, p, &c_n1);
+ nb4 = ilaenv_(&c__1, "SORMRQ", " ", n, m, p, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2), i__1 = max(i__1,nb3);
+ nb = max(i__1,nb4);
+ lwkmin = *m + *n + *p;
+ lwkopt = *m + np + max(*n,*p) * nb;
+ }
+ work[1] = (real) lwkopt;
+
+ if (*lwork < lwkmin && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGGGLM", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Compute the GQR factorization of matrices A and B: */
+
+/* Q'*A = ( R11 ) M, Q'*B*Z' = ( T11 T12 ) M */
+/* ( 0 ) N-M ( 0 T22 ) N-M */
+/* M M+P-N N-M */
+
+/* where R11 and T22 are upper triangular, and Q and Z are */
+/* orthogonal. */
+
+ i__1 = *lwork - *m - np;
+ sggqrf_(n, m, p, &a[a_offset], lda, &work[1], &b[b_offset], ldb, &work[*m
+ + 1], &work[*m + np + 1], &i__1, info);
+ lopt = work[*m + np + 1];
+
+/* Update left-hand-side vector d = Q'*d = ( d1 ) M */
+/* ( d2 ) N-M */
+
+ i__1 = max(1,*n);
+ i__2 = *lwork - *m - np;
+ sormqr_("Left", "Transpose", n, &c__1, m, &a[a_offset], lda, &work[1], &
+ d__[1], &i__1, &work[*m + np + 1], &i__2, info);
+/* Computing MAX */
+ i__1 = lopt, i__2 = (integer) work[*m + np + 1];
+ lopt = max(i__1,i__2);
+
+/* Solve T22*y2 = d2 for y2 */
+
+ if (*n > *m) {
+ i__1 = *n - *m;
+ i__2 = *n - *m;
+ strtrs_("Upper", "No transpose", "Non unit", &i__1, &c__1, &b[*m + 1
+ + (*m + *p - *n + 1) * b_dim1], ldb, &d__[*m + 1], &i__2,
+ info);
+
+ if (*info > 0) {
+ *info = 1;
+ return 0;
+ }
+
+ i__1 = *n - *m;
+ scopy_(&i__1, &d__[*m + 1], &c__1, &y[*m + *p - *n + 1], &c__1);
+ }
+
+/* Set y1 = 0 */
+
+ i__1 = *m + *p - *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ y[i__] = 0.f;
+/* L10: */
+ }
+
+/* Update d1 = d1 - T12*y2 */
+
+ i__1 = *n - *m;
+ sgemv_("No transpose", m, &i__1, &c_b32, &b[(*m + *p - *n + 1) * b_dim1 +
+ 1], ldb, &y[*m + *p - *n + 1], &c__1, &c_b34, &d__[1], &c__1);
+
+/* Solve triangular system: R11*x = d1 */
+
+ if (*m > 0) {
+ strtrs_("Upper", "No Transpose", "Non unit", m, &c__1, &a[a_offset],
+ lda, &d__[1], m, info);
+
+ if (*info > 0) {
+ *info = 2;
+ return 0;
+ }
+
+/* Copy D to X */
+
+ scopy_(m, &d__[1], &c__1, &x[1], &c__1);
+ }
+
+/* Backward transformation y = Z'*y */
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *n - *p + 1;
+ i__3 = max(1,*p);
+ i__4 = *lwork - *m - np;
+ sormrq_("Left", "Transpose", p, &c__1, &np, &b[max(i__1, i__2)+ b_dim1],
+ ldb, &work[*m + 1], &y[1], &i__3, &work[*m + np + 1], &i__4, info);
+/* Computing MAX */
+ i__1 = lopt, i__2 = (integer) work[*m + np + 1];
+ work[1] = (real) (*m + np + max(i__1,i__2));
+
+ return 0;
+
+/* End of SGGGLM */
+
+} /* sggglm_ */
diff --git a/SRC/sgghrd.c b/SRC/sgghrd.c
new file mode 100644
index 0000000..c78893c
--- /dev/null
+++ b/SRC/sgghrd.c
@@ -0,0 +1,329 @@
+/* sgghrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b10 = 0.f;
+static real c_b11 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int sgghrd_(char *compq, char *compz, integer *n, integer *
+ ilo, integer *ihi, real *a, integer *lda, real *b, integer *ldb, real
+ *q, integer *ldq, real *z__, integer *ldz, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
+ z_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ real c__, s;
+ logical ilq, ilz;
+ integer jcol;
+ real temp;
+ integer jrow;
+ extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
+ integer *, real *, real *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer icompq;
+ extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *), slartg_(real *, real *, real *
+, real *, real *);
+ integer icompz;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGGHRD reduces a pair of real matrices (A,B) to generalized upper */
+/* Hessenberg form using orthogonal transformations, where A is a */
+/* general matrix and B is upper triangular. The form of the */
+/* generalized eigenvalue problem is */
+/* A*x = lambda*B*x, */
+/* and B is typically made upper triangular by computing its QR */
+/* factorization and moving the orthogonal matrix Q to the left side */
+/* of the equation. */
+
+/* This subroutine simultaneously reduces A to a Hessenberg matrix H: */
+/* Q**T*A*Z = H */
+/* and transforms B to another upper triangular matrix T: */
+/* Q**T*B*Z = T */
+/* in order to reduce the problem to its standard form */
+/* H*y = lambda*T*y */
+/* where y = Z**T*x. */
+
+/* The orthogonal matrices Q and Z are determined as products of Givens */
+/* rotations. They may either be formed explicitly, or they may be */
+/* postmultiplied into input matrices Q1 and Z1, so that */
+
+/* Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T */
+
+/* Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T */
+
+/* If Q1 is the orthogonal matrix from the QR factorization of B in the */
+/* original equation A*x = lambda*B*x, then SGGHRD reduces the original */
+/* problem to generalized Hessenberg form. */
+
+/* Arguments */
+/* ========= */
+
+/* COMPQ (input) CHARACTER*1 */
+/* = 'N': do not compute Q; */
+/* = 'I': Q is initialized to the unit matrix, and the */
+/* orthogonal matrix Q is returned; */
+/* = 'V': Q must contain an orthogonal matrix Q1 on entry, */
+/* and the product Q1*Q is returned. */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': do not compute Z; */
+/* = 'I': Z is initialized to the unit matrix, and the */
+/* orthogonal matrix Z is returned; */
+/* = 'V': Z must contain an orthogonal matrix Z1 on entry, */
+/* and the product Z1*Z is returned. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* ILO and IHI mark the rows and columns of A which are to be */
+/* reduced. It is assumed that A is already upper triangular */
+/* in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are */
+/* normally set by a previous call to SGGBAL; otherwise they */
+/* should be set to 1 and N respectively. */
+/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
+
+/* A (input/output) REAL array, dimension (LDA, N) */
+/* On entry, the N-by-N general matrix to be reduced. */
+/* On exit, the upper triangle and the first subdiagonal of A */
+/* are overwritten with the upper Hessenberg matrix H, and the */
+/* rest is set to zero. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) REAL array, dimension (LDB, N) */
+/* On entry, the N-by-N upper triangular matrix B. */
+/* On exit, the upper triangular matrix T = Q**T B Z. The */
+/* elements below the diagonal are set to zero. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Q (input/output) REAL array, dimension (LDQ, N) */
+/* On entry, if COMPQ = 'V', the orthogonal matrix Q1, */
+/* typically from the QR factorization of B. */
+/* On exit, if COMPQ='I', the orthogonal matrix Q, and if */
+/* COMPQ = 'V', the product Q1*Q. */
+/* Not referenced if COMPQ='N'. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. */
+/* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. */
+
+/* Z (input/output) REAL array, dimension (LDZ, N) */
+/* On entry, if COMPZ = 'V', the orthogonal matrix Z1. */
+/* On exit, if COMPZ='I', the orthogonal matrix Z, and if */
+/* COMPZ = 'V', the product Z1*Z. */
+/* Not referenced if COMPZ='N'. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. */
+/* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* This routine reduces A to Hessenberg and B to triangular form by */
+/* an unblocked reduction, as described in _Matrix_Computations_, */
+/* by Golub and Van Loan (Johns Hopkins Press.) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode COMPQ */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+
+ /* Function Body */
+ if (lsame_(compq, "N")) {
+ ilq = FALSE_;
+ icompq = 1;
+ } else if (lsame_(compq, "V")) {
+ ilq = TRUE_;
+ icompq = 2;
+ } else if (lsame_(compq, "I")) {
+ ilq = TRUE_;
+ icompq = 3;
+ } else {
+ icompq = 0;
+ }
+
+/* Decode COMPZ */
+
+ if (lsame_(compz, "N")) {
+ ilz = FALSE_;
+ icompz = 1;
+ } else if (lsame_(compz, "V")) {
+ ilz = TRUE_;
+ icompz = 2;
+ } else if (lsame_(compz, "I")) {
+ ilz = TRUE_;
+ icompz = 3;
+ } else {
+ icompz = 0;
+ }
+
+/* Test the input parameters. */
+
+ *info = 0;
+ if (icompq <= 0) {
+ *info = -1;
+ } else if (icompz <= 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ilo < 1) {
+ *info = -4;
+ } else if (*ihi > *n || *ihi < *ilo - 1) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (ilq && *ldq < *n || *ldq < 1) {
+ *info = -11;
+ } else if (ilz && *ldz < *n || *ldz < 1) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGGHRD", &i__1);
+ return 0;
+ }
+
+/* Initialize Q and Z if desired. */
+
+ if (icompq == 3) {
+ slaset_("Full", n, n, &c_b10, &c_b11, &q[q_offset], ldq);
+ }
+ if (icompz == 3) {
+ slaset_("Full", n, n, &c_b10, &c_b11, &z__[z_offset], ldz);
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 1) {
+ return 0;
+ }
+
+/* Zero out lower triangle of B */
+
+ i__1 = *n - 1;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ i__2 = *n;
+ for (jrow = jcol + 1; jrow <= i__2; ++jrow) {
+ b[jrow + jcol * b_dim1] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Reduce A and B */
+
+ i__1 = *ihi - 2;
+ for (jcol = *ilo; jcol <= i__1; ++jcol) {
+
+ i__2 = jcol + 2;
+ for (jrow = *ihi; jrow >= i__2; --jrow) {
+
+/* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL) */
+
+ temp = a[jrow - 1 + jcol * a_dim1];
+ slartg_(&temp, &a[jrow + jcol * a_dim1], &c__, &s, &a[jrow - 1 +
+ jcol * a_dim1]);
+ a[jrow + jcol * a_dim1] = 0.f;
+ i__3 = *n - jcol;
+ srot_(&i__3, &a[jrow - 1 + (jcol + 1) * a_dim1], lda, &a[jrow + (
+ jcol + 1) * a_dim1], lda, &c__, &s);
+ i__3 = *n + 2 - jrow;
+ srot_(&i__3, &b[jrow - 1 + (jrow - 1) * b_dim1], ldb, &b[jrow + (
+ jrow - 1) * b_dim1], ldb, &c__, &s);
+ if (ilq) {
+ srot_(n, &q[(jrow - 1) * q_dim1 + 1], &c__1, &q[jrow * q_dim1
+ + 1], &c__1, &c__, &s);
+ }
+
+/* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1) */
+
+ temp = b[jrow + jrow * b_dim1];
+ slartg_(&temp, &b[jrow + (jrow - 1) * b_dim1], &c__, &s, &b[jrow
+ + jrow * b_dim1]);
+ b[jrow + (jrow - 1) * b_dim1] = 0.f;
+ srot_(ihi, &a[jrow * a_dim1 + 1], &c__1, &a[(jrow - 1) * a_dim1 +
+ 1], &c__1, &c__, &s);
+ i__3 = jrow - 1;
+ srot_(&i__3, &b[jrow * b_dim1 + 1], &c__1, &b[(jrow - 1) * b_dim1
+ + 1], &c__1, &c__, &s);
+ if (ilz) {
+ srot_(n, &z__[jrow * z_dim1 + 1], &c__1, &z__[(jrow - 1) *
+ z_dim1 + 1], &c__1, &c__, &s);
+ }
+/* L30: */
+ }
+/* L40: */
+ }
+
+ return 0;
+
+/* End of SGGHRD */
+
+} /* sgghrd_ */
diff --git a/SRC/sgglse.c b/SRC/sgglse.c
new file mode 100644
index 0000000..fb87eb9
--- /dev/null
+++ b/SRC/sgglse.c
@@ -0,0 +1,334 @@
+/* sgglse.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b31 = -1.f;
+static real c_b33 = 1.f;
+
+/* Subroutine */ int sgglse_(integer *m, integer *n, integer *p, real *a,
+ integer *lda, real *b, integer *ldb, real *c__, real *d__, real *x,
+ real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+
+ /* Local variables */
+ integer nb, mn, nr, nb1, nb2, nb3, nb4, lopt;
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *),
+ saxpy_(integer *, real *, real *, integer *, real *, integer *),
+ strmv_(char *, char *, char *, integer *, real *, integer *, real
+ *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int sggrqf_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, real *, real *, integer *
+, integer *);
+ integer lwkmin, lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *), sormrq_(char *, char *,
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, integer *, real *, integer *, integer *),
+ strtrs_(char *, char *, char *, integer *, integer *, real *,
+ integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGGLSE solves the linear equality-constrained least squares (LSE) */
+/* problem: */
+
+/* minimize || c - A*x ||_2 subject to B*x = d */
+
+/* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given */
+/* M-vector, and d is a given P-vector. It is assumed that */
+/* P <= N <= M+P, and */
+
+/* rank(B) = P and rank( (A) ) = N. */
+/* ( (B) ) */
+
+/* These conditions ensure that the LSE problem has a unique solution, */
+/* which is obtained using a generalized RQ factorization of the */
+/* matrices (B, A) given by */
+
+/* B = (0 R)*Q, A = Z*T*Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. 0 <= P <= N <= M+P. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(M,N)-by-N upper trapezoidal matrix T. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) REAL array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix B. */
+/* On exit, the upper triangle of the subarray B(1:P,N-P+1:N) */
+/* contains the P-by-P upper triangular matrix R. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,P). */
+
+/* C (input/output) REAL array, dimension (M) */
+/* On entry, C contains the right hand side vector for the */
+/* least squares part of the LSE problem. */
+/* On exit, the residual sum of squares for the solution */
+/* is given by the sum of squares of elements N-P+1 to M of */
+/* vector C. */
+
+/* D (input/output) REAL array, dimension (P) */
+/* On entry, D contains the right hand side vector for the */
+/* constrained equation. */
+/* On exit, D is destroyed. */
+
+/* X (output) REAL array, dimension (N) */
+/* On exit, X is the solution of the LSE problem. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M+N+P). */
+/* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB, */
+/* where NB is an upper bound for the optimal blocksizes for */
+/* SGEQRF, SGERQF, SORMQR and SORMRQ. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1: the upper triangular factor R associated with B in the */
+/* generalized RQ factorization of the pair (B, A) is */
+/* singular, so that rank(B) < P; the least squares */
+/* solution could not be computed. */
+/* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor */
+/* T associated with A in the generalized RQ factorization */
+/* of the pair (B, A) is singular, so that */
+/* rank( (A) ) < N; the least squares solution could not */
+/* ( (B) ) */
+/* be computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --c__;
+ --d__;
+ --x;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ mn = min(*m,*n);
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*p < 0 || *p > *n || *p < *n - *m) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*p)) {
+ *info = -7;
+ }
+
+/* Calculate workspace */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ lwkmin = 1;
+ lwkopt = 1;
+ } else {
+ nb1 = ilaenv_(&c__1, "SGEQRF", " ", m, n, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "SGERQF", " ", m, n, &c_n1, &c_n1);
+ nb3 = ilaenv_(&c__1, "SORMQR", " ", m, n, p, &c_n1);
+ nb4 = ilaenv_(&c__1, "SORMRQ", " ", m, n, p, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2), i__1 = max(i__1,nb3);
+ nb = max(i__1,nb4);
+ lwkmin = *m + *n + *p;
+ lwkopt = *p + mn + max(*m,*n) * nb;
+ }
+ work[1] = (real) lwkopt;
+
+ if (*lwork < lwkmin && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGGLSE", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Compute the GRQ factorization of matrices B and A: */
+
+/* B*Q' = ( 0 T12 ) P Z'*A*Q' = ( R11 R12 ) N-P */
+/* N-P P ( 0 R22 ) M+P-N */
+/* N-P P */
+
+/* where T12 and R11 are upper triangular, and Q and Z are */
+/* orthogonal. */
+
+ i__1 = *lwork - *p - mn;
+ sggrqf_(p, m, n, &b[b_offset], ldb, &work[1], &a[a_offset], lda, &work[*p
+ + 1], &work[*p + mn + 1], &i__1, info);
+ lopt = work[*p + mn + 1];
+
+/* Update c = Z'*c = ( c1 ) N-P */
+/* ( c2 ) M+P-N */
+
+ i__1 = max(1,*m);
+ i__2 = *lwork - *p - mn;
+ sormqr_("Left", "Transpose", m, &c__1, &mn, &a[a_offset], lda, &work[*p +
+ 1], &c__[1], &i__1, &work[*p + mn + 1], &i__2, info);
+/* Computing MAX */
+ i__1 = lopt, i__2 = (integer) work[*p + mn + 1];
+ lopt = max(i__1,i__2);
+
+/* Solve T12*x2 = d for x2 */
+
+ if (*p > 0) {
+ strtrs_("Upper", "No transpose", "Non-unit", p, &c__1, &b[(*n - *p +
+ 1) * b_dim1 + 1], ldb, &d__[1], p, info);
+
+ if (*info > 0) {
+ *info = 1;
+ return 0;
+ }
+
+/* Put the solution in X */
+
+ scopy_(p, &d__[1], &c__1, &x[*n - *p + 1], &c__1);
+
+/* Update c1 */
+
+ i__1 = *n - *p;
+ sgemv_("No transpose", &i__1, p, &c_b31, &a[(*n - *p + 1) * a_dim1 +
+ 1], lda, &d__[1], &c__1, &c_b33, &c__[1], &c__1);
+ }
+
+/* Solve R11*x1 = c1 for x1 */
+
+ if (*n > *p) {
+ i__1 = *n - *p;
+ i__2 = *n - *p;
+ strtrs_("Upper", "No transpose", "Non-unit", &i__1, &c__1, &a[
+ a_offset], lda, &c__[1], &i__2, info);
+
+ if (*info > 0) {
+ *info = 2;
+ return 0;
+ }
+
+/* Put the solution in X */
+
+ i__1 = *n - *p;
+ scopy_(&i__1, &c__[1], &c__1, &x[1], &c__1);
+ }
+
+/* Compute the residual vector: */
+
+ if (*m < *n) {
+ nr = *m + *p - *n;
+ if (nr > 0) {
+ i__1 = *n - *m;
+ sgemv_("No transpose", &nr, &i__1, &c_b31, &a[*n - *p + 1 + (*m +
+ 1) * a_dim1], lda, &d__[nr + 1], &c__1, &c_b33, &c__[*n -
+ *p + 1], &c__1);
+ }
+ } else {
+ nr = *p;
+ }
+ if (nr > 0) {
+ strmv_("Upper", "No transpose", "Non unit", &nr, &a[*n - *p + 1 + (*n
+ - *p + 1) * a_dim1], lda, &d__[1], &c__1);
+ saxpy_(&nr, &c_b31, &d__[1], &c__1, &c__[*n - *p + 1], &c__1);
+ }
+
+/* Backward transformation x = Q'*x */
+
+ i__1 = *lwork - *p - mn;
+ sormrq_("Left", "Transpose", n, &c__1, p, &b[b_offset], ldb, &work[1], &x[
+ 1], n, &work[*p + mn + 1], &i__1, info);
+/* Computing MAX */
+ i__1 = lopt, i__2 = (integer) work[*p + mn + 1];
+ work[1] = (real) (*p + mn + max(i__1,i__2));
+
+ return 0;
+
+/* End of SGGLSE */
+
+} /* sgglse_ */
diff --git a/SRC/sggqrf.c b/SRC/sggqrf.c
new file mode 100644
index 0000000..c8ba376
--- /dev/null
+++ b/SRC/sggqrf.c
@@ -0,0 +1,268 @@
+/* sggqrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int sggqrf_(integer *n, integer *m, integer *p, real *a,
+ integer *lda, real *taua, real *b, integer *ldb, real *taub, real *
+ work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+
+ /* Local variables */
+ integer nb, nb1, nb2, nb3, lopt;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int sgeqrf_(integer *, integer *, real *, integer
+ *, real *, real *, integer *, integer *), sgerqf_(integer *,
+ integer *, real *, integer *, real *, real *, integer *, integer *
+);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGGQRF computes a generalized QR factorization of an N-by-M matrix A */
+/* and an N-by-P matrix B: */
+
+/* A = Q*R, B = Q*T*Z, */
+
+/* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal */
+/* matrix, and R and T assume one of the forms: */
+
+/* if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N, */
+/* ( 0 ) N-M N M-N */
+/* M */
+
+/* where R11 is upper triangular, and */
+
+/* if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P, */
+/* P-N N ( T21 ) P */
+/* P */
+
+/* where T12 or T21 is upper triangular. */
+
+/* In particular, if B is square and nonsingular, the GQR factorization */
+/* of A and B implicitly gives the QR factorization of inv(B)*A: */
+
+/* inv(B)*A = Z'*(inv(T)*R) */
+
+/* where inv(B) denotes the inverse of the matrix B, and Z' denotes the */
+/* transpose of the matrix Z. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices A and B. N >= 0. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of columns of the matrix B. P >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,M) */
+/* On entry, the N-by-M matrix A. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(N,M)-by-M upper trapezoidal matrix R (R is */
+/* upper triangular if N >= M); the elements below the diagonal, */
+/* with the array TAUA, represent the orthogonal matrix Q as a */
+/* product of min(N,M) elementary reflectors (see Further */
+/* Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAUA (output) REAL array, dimension (min(N,M)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the orthogonal matrix Q (see Further Details). */
+
+/* B (input/output) REAL array, dimension (LDB,P) */
+/* On entry, the N-by-P matrix B. */
+/* On exit, if N <= P, the upper triangle of the subarray */
+/* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T; */
+/* if N > P, the elements on and above the (N-P)-th subdiagonal */
+/* contain the N-by-P upper trapezoidal matrix T; the remaining */
+/* elements, with the array TAUB, represent the orthogonal */
+/* matrix Z as a product of elementary reflectors (see Further */
+/* Details). */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* TAUB (output) REAL array, dimension (min(N,P)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the orthogonal matrix Z (see Further Details). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N,M,P). */
+/* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3), */
+/* where NB1 is the optimal blocksize for the QR factorization */
+/* of an N-by-M matrix, NB2 is the optimal blocksize for the */
+/* RQ factorization of an N-by-P matrix, and NB3 is the optimal */
+/* blocksize for a call of SORMQR. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(n,m). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - taua * v * v' */
+
+/* where taua is a real scalar, and v is a real vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */
+/* and taua in TAUA(i). */
+/* To form Q explicitly, use LAPACK subroutine SORGQR. */
+/* To use Q to update another matrix, use LAPACK subroutine SORMQR. */
+
+/* The matrix Z is represented as a product of elementary reflectors */
+
+/* Z = H(1) H(2) . . . H(k), where k = min(n,p). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - taub * v * v' */
+
+/* where taub is a real scalar, and v is a real vector with */
+/* v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in */
+/* B(n-k+i,1:p-k+i-1), and taub in TAUB(i). */
+/* To form Z explicitly, use LAPACK subroutine SORGRQ. */
+/* To use Z to update another matrix, use LAPACK subroutine SORMRQ. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --taua;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --taub;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb1 = ilaenv_(&c__1, "SGEQRF", " ", n, m, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "SGERQF", " ", n, p, &c_n1, &c_n1);
+ nb3 = ilaenv_(&c__1, "SORMQR", " ", n, m, p, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2);
+ nb = max(i__1,nb3);
+/* Computing MAX */
+ i__1 = max(*n,*m);
+ lwkopt = max(i__1,*p) * nb;
+ work[1] = (real) lwkopt;
+ lquery = *lwork == -1;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*p < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*n), i__1 = max(i__1,*m);
+ if (*lwork < max(i__1,*p) && ! lquery) {
+ *info = -11;
+ }
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGGQRF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* QR factorization of N-by-M matrix A: A = Q*R */
+
+ sgeqrf_(n, m, &a[a_offset], lda, &taua[1], &work[1], lwork, info);
+ lopt = work[1];
+
+/* Update B := Q'*B. */
+
+ i__1 = min(*n,*m);
+ sormqr_("Left", "Transpose", n, p, &i__1, &a[a_offset], lda, &taua[1], &b[
+ b_offset], ldb, &work[1], lwork, info);
+/* Computing MAX */
+ i__1 = lopt, i__2 = (integer) work[1];
+ lopt = max(i__1,i__2);
+
+/* RQ factorization of N-by-P matrix B: B = T*Z. */
+
+ sgerqf_(n, p, &b[b_offset], ldb, &taub[1], &work[1], lwork, info);
+/* Computing MAX */
+ i__1 = lopt, i__2 = (integer) work[1];
+ work[1] = (real) max(i__1,i__2);
+
+ return 0;
+
+/* End of SGGQRF */
+
+} /* sggqrf_ */
diff --git a/SRC/sggrqf.c b/SRC/sggrqf.c
new file mode 100644
index 0000000..2979920
--- /dev/null
+++ b/SRC/sggrqf.c
@@ -0,0 +1,269 @@
+/* sggrqf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int sggrqf_(integer *m, integer *p, integer *n, real *a,
+ integer *lda, real *taua, real *b, integer *ldb, real *taub, real *
+ work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer nb, nb1, nb2, nb3, lopt;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int sgeqrf_(integer *, integer *, real *, integer
+ *, real *, real *, integer *, integer *), sgerqf_(integer *,
+ integer *, real *, integer *, real *, real *, integer *, integer *
+);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int sormrq_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGGRQF computes a generalized RQ factorization of an M-by-N matrix A */
+/* and a P-by-N matrix B: */
+
+/* A = R*Q, B = Z*T*Q, */
+
+/* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal */
+/* matrix, and R and T assume one of the forms: */
+
+/* if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N, */
+/* N-M M ( R21 ) N */
+/* N */
+
+/* where R12 or R21 is upper triangular, and */
+
+/* if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P, */
+/* ( 0 ) P-N P N-P */
+/* N */
+
+/* where T11 is upper triangular. */
+
+/* In particular, if B is square and nonsingular, the GRQ factorization */
+/* of A and B implicitly gives the RQ factorization of A*inv(B): */
+
+/* A*inv(B) = (R*inv(T))*Z' */
+
+/* where inv(B) denotes the inverse of the matrix B, and Z' denotes the */
+/* transpose of the matrix Z. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, if M <= N, the upper triangle of the subarray */
+/* A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R; */
+/* if M > N, the elements on and above the (M-N)-th subdiagonal */
+/* contain the M-by-N upper trapezoidal matrix R; the remaining */
+/* elements, with the array TAUA, represent the orthogonal */
+/* matrix Q as a product of elementary reflectors (see Further */
+/* Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAUA (output) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the orthogonal matrix Q (see Further Details). */
+
+/* B (input/output) REAL array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix B. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(P,N)-by-N upper trapezoidal matrix T (T is */
+/* upper triangular if P >= N); the elements below the diagonal, */
+/* with the array TAUB, represent the orthogonal matrix Z as a */
+/* product of elementary reflectors (see Further Details). */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,P). */
+
+/* TAUB (output) REAL array, dimension (min(P,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the orthogonal matrix Z (see Further Details). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N,M,P). */
+/* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3), */
+/* where NB1 is the optimal blocksize for the RQ factorization */
+/* of an M-by-N matrix, NB2 is the optimal blocksize for the */
+/* QR factorization of a P-by-N matrix, and NB3 is the optimal */
+/* blocksize for a call of SORMRQ. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INF0= -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - taua * v * v' */
+
+/* where taua is a real scalar, and v is a real vector with */
+/* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in */
+/* A(m-k+i,1:n-k+i-1), and taua in TAUA(i). */
+/* To form Q explicitly, use LAPACK subroutine SORGRQ. */
+/* To use Q to update another matrix, use LAPACK subroutine SORMRQ. */
+
+/* The matrix Z is represented as a product of elementary reflectors */
+
+/* Z = H(1) H(2) . . . H(k), where k = min(p,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - taub * v * v' */
+
+/* where taub is a real scalar, and v is a real vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i), */
+/* and taub in TAUB(i). */
+/* To form Z explicitly, use LAPACK subroutine SORGQR. */
+/* To use Z to update another matrix, use LAPACK subroutine SORMQR. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --taua;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --taub;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb1 = ilaenv_(&c__1, "SGERQF", " ", m, n, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "SGEQRF", " ", p, n, &c_n1, &c_n1);
+ nb3 = ilaenv_(&c__1, "SORMRQ", " ", m, n, p, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2);
+ nb = max(i__1,nb3);
+/* Computing MAX */
+ i__1 = max(*n,*m);
+ lwkopt = max(i__1,*p) * nb;
+ work[1] = (real) lwkopt;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*p < 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*p)) {
+ *info = -8;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*m), i__1 = max(i__1,*p);
+ if (*lwork < max(i__1,*n) && ! lquery) {
+ *info = -11;
+ }
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGGRQF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* RQ factorization of M-by-N matrix A: A = R*Q */
+
+ sgerqf_(m, n, &a[a_offset], lda, &taua[1], &work[1], lwork, info);
+ lopt = work[1];
+
+/* Update B := B*Q' */
+
+ i__1 = min(*m,*n);
+/* Computing MAX */
+ i__2 = 1, i__3 = *m - *n + 1;
+ sormrq_("Right", "Transpose", p, n, &i__1, &a[max(i__2, i__3)+ a_dim1],
+ lda, &taua[1], &b[b_offset], ldb, &work[1], lwork, info);
+/* Computing MAX */
+ i__1 = lopt, i__2 = (integer) work[1];
+ lopt = max(i__1,i__2);
+
+/* QR factorization of P-by-N matrix B: B = Z*T */
+
+ sgeqrf_(p, n, &b[b_offset], ldb, &taub[1], &work[1], lwork, info);
+/* Computing MAX */
+ i__1 = lopt, i__2 = (integer) work[1];
+ work[1] = (real) max(i__1,i__2);
+
+ return 0;
+
+/* End of SGGRQF */
+
+} /* sggrqf_ */
diff --git a/SRC/sggsvd.c b/SRC/sggsvd.c
new file mode 100644
index 0000000..48ad249
--- /dev/null
+++ b/SRC/sggsvd.c
@@ -0,0 +1,402 @@
+/* sggsvd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sggsvd_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *n, integer *p, integer *k, integer *l, real *a, integer *lda,
+ real *b, integer *ldb, real *alpha, real *beta, real *u, integer *
+ ldu, real *v, integer *ldv, real *q, integer *ldq, real *work,
+ integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1,
+ u_offset, v_dim1, v_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ real ulp;
+ integer ibnd;
+ real tola;
+ integer isub;
+ real tolb, unfl, temp, smax;
+ extern logical lsame_(char *, char *);
+ real anorm, bnorm;
+ logical wantq;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ logical wantu, wantv;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ integer ncycle;
+ extern /* Subroutine */ int xerbla_(char *, integer *), stgsja_(
+ char *, char *, char *, integer *, integer *, integer *, integer *
+, integer *, real *, integer *, real *, integer *, real *, real *,
+ real *, real *, real *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, integer *),
+ sggsvp_(char *, char *, char *, integer *, integer *, integer *,
+ real *, integer *, real *, integer *, real *, real *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, integer *, real *, real *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGGSVD computes the generalized singular value decomposition (GSVD) */
+/* of an M-by-N real matrix A and P-by-N real matrix B: */
+
+/* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ) */
+
+/* where U, V and Q are orthogonal matrices, and Z' is the transpose */
+/* of Z. Let K+L = the effective numerical rank of the matrix (A',B')', */
+/* then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and */
+/* D2 are M-by-(K+L) and P-by-(K+L) "diagonal" matrices and of the */
+/* following structures, respectively: */
+
+/* If M-K-L >= 0, */
+
+/* K L */
+/* D1 = K ( I 0 ) */
+/* L ( 0 C ) */
+/* M-K-L ( 0 0 ) */
+
+/* K L */
+/* D2 = L ( 0 S ) */
+/* P-L ( 0 0 ) */
+
+/* N-K-L K L */
+/* ( 0 R ) = K ( 0 R11 R12 ) */
+/* L ( 0 0 R22 ) */
+
+/* where */
+
+/* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */
+/* S = diag( BETA(K+1), ... , BETA(K+L) ), */
+/* C**2 + S**2 = I. */
+
+/* R is stored in A(1:K+L,N-K-L+1:N) on exit. */
+
+/* If M-K-L < 0, */
+
+/* K M-K K+L-M */
+/* D1 = K ( I 0 0 ) */
+/* M-K ( 0 C 0 ) */
+
+/* K M-K K+L-M */
+/* D2 = M-K ( 0 S 0 ) */
+/* K+L-M ( 0 0 I ) */
+/* P-L ( 0 0 0 ) */
+
+/* N-K-L K M-K K+L-M */
+/* ( 0 R ) = K ( 0 R11 R12 R13 ) */
+/* M-K ( 0 0 R22 R23 ) */
+/* K+L-M ( 0 0 0 R33 ) */
+
+/* where */
+
+/* C = diag( ALPHA(K+1), ... , ALPHA(M) ), */
+/* S = diag( BETA(K+1), ... , BETA(M) ), */
+/* C**2 + S**2 = I. */
+
+/* (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored */
+/* ( 0 R22 R23 ) */
+/* in B(M-K+1:L,N+M-K-L+1:N) on exit. */
+
+/* The routine computes C, S, R, and optionally the orthogonal */
+/* transformation matrices U, V and Q. */
+
+/* In particular, if B is an N-by-N nonsingular matrix, then the GSVD of */
+/* A and B implicitly gives the SVD of A*inv(B): */
+/* A*inv(B) = U*(D1*inv(D2))*V'. */
+/* If ( A',B')' has orthonormal columns, then the GSVD of A and B is */
+/* also equal to the CS decomposition of A and B. Furthermore, the GSVD */
+/* can be used to derive the solution of the eigenvalue problem: */
+/* A'*A x = lambda* B'*B x. */
+/* In some literature, the GSVD of A and B is presented in the form */
+/* U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 ) */
+/* where U and V are orthogonal and X is nonsingular, D1 and D2 are */
+/* ``diagonal''. The former GSVD form can be converted to the latter */
+/* form by taking the nonsingular matrix X as */
+
+/* X = Q*( I 0 ) */
+/* ( 0 inv(R) ). */
+
+/* Arguments */
+/* ========= */
+
+/* JOBU (input) CHARACTER*1 */
+/* = 'U': Orthogonal matrix U is computed; */
+/* = 'N': U is not computed. */
+
+/* JOBV (input) CHARACTER*1 */
+/* = 'V': Orthogonal matrix V is computed; */
+/* = 'N': V is not computed. */
+
+/* JOBQ (input) CHARACTER*1 */
+/* = 'Q': Orthogonal matrix Q is computed; */
+/* = 'N': Q is not computed. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* K (output) INTEGER */
+/* L (output) INTEGER */
+/* On exit, K and L specify the dimension of the subblocks */
+/* described in the Purpose section. */
+/* K + L = effective numerical rank of (A',B')'. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A contains the triangular matrix R, or part of R. */
+/* See Purpose for details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) REAL array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix B. */
+/* On exit, B contains the triangular matrix R if M-K-L < 0. */
+/* See Purpose for details. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,P). */
+
+/* ALPHA (output) REAL array, dimension (N) */
+/* BETA (output) REAL array, dimension (N) */
+/* On exit, ALPHA and BETA contain the generalized singular */
+/* value pairs of A and B; */
+/* ALPHA(1:K) = 1, */
+/* BETA(1:K) = 0, */
+/* and if M-K-L >= 0, */
+/* ALPHA(K+1:K+L) = C, */
+/* BETA(K+1:K+L) = S, */
+/* or if M-K-L < 0, */
+/* ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0 */
+/* BETA(K+1:M) =S, BETA(M+1:K+L) =1 */
+/* and */
+/* ALPHA(K+L+1:N) = 0 */
+/* BETA(K+L+1:N) = 0 */
+
+/* U (output) REAL array, dimension (LDU,M) */
+/* If JOBU = 'U', U contains the M-by-M orthogonal matrix U. */
+/* If JOBU = 'N', U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M) if */
+/* JOBU = 'U'; LDU >= 1 otherwise. */
+
+/* V (output) REAL array, dimension (LDV,P) */
+/* If JOBV = 'V', V contains the P-by-P orthogonal matrix V. */
+/* If JOBV = 'N', V is not referenced. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. LDV >= max(1,P) if */
+/* JOBV = 'V'; LDV >= 1 otherwise. */
+
+/* Q (output) REAL array, dimension (LDQ,N) */
+/* If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q. */
+/* If JOBQ = 'N', Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N) if */
+/* JOBQ = 'Q'; LDQ >= 1 otherwise. */
+
+/* WORK (workspace) REAL array, */
+/* dimension (max(3*N,M,P)+N) */
+
+/* IWORK (workspace/output) INTEGER array, dimension (N) */
+/* On exit, IWORK stores the sorting information. More */
+/* precisely, the following loop will sort ALPHA */
+/* for I = K+1, min(M,K+L) */
+/* swap ALPHA(I) and ALPHA(IWORK(I)) */
+/* endfor */
+/* such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, the Jacobi-type procedure failed to */
+/* converge. For further details, see subroutine STGSJA. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* TOLA REAL */
+/* TOLB REAL */
+/* TOLA and TOLB are the thresholds to determine the effective */
+/* rank of (A',B')'. Generally, they are set to */
+/* TOLA = MAX(M,N)*norm(A)*MACHEPS, */
+/* TOLB = MAX(P,N)*norm(B)*MACHEPS. */
+/* The size of TOLA and TOLB may affect the size of backward */
+/* errors of the decomposition. */
+
+/* Further Details */
+/* =============== */
+
+/* 2-96 Based on modifications by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alpha;
+ --beta;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantu = lsame_(jobu, "U");
+ wantv = lsame_(jobv, "V");
+ wantq = lsame_(jobq, "Q");
+
+ *info = 0;
+ if (! (wantu || lsame_(jobu, "N"))) {
+ *info = -1;
+ } else if (! (wantv || lsame_(jobv, "N"))) {
+ *info = -2;
+ } else if (! (wantq || lsame_(jobq, "N"))) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*p < 0) {
+ *info = -6;
+ } else if (*lda < max(1,*m)) {
+ *info = -10;
+ } else if (*ldb < max(1,*p)) {
+ *info = -12;
+ } else if (*ldu < 1 || wantu && *ldu < *m) {
+ *info = -16;
+ } else if (*ldv < 1 || wantv && *ldv < *p) {
+ *info = -18;
+ } else if (*ldq < 1 || wantq && *ldq < *n) {
+ *info = -20;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGGSVD", &i__1);
+ return 0;
+ }
+
+/* Compute the Frobenius norm of matrices A and B */
+
+ anorm = slange_("1", m, n, &a[a_offset], lda, &work[1]);
+ bnorm = slange_("1", p, n, &b[b_offset], ldb, &work[1]);
+
+/* Get machine precision and set up threshold for determining */
+/* the effective numerical rank of the matrices A and B. */
+
+ ulp = slamch_("Precision");
+ unfl = slamch_("Safe Minimum");
+ tola = max(*m,*n) * dmax(anorm,unfl) * ulp;
+ tolb = max(*p,*n) * dmax(bnorm,unfl) * ulp;
+
+/* Preprocessing */
+
+ sggsvp_(jobu, jobv, jobq, m, p, n, &a[a_offset], lda, &b[b_offset], ldb, &
+ tola, &tolb, k, l, &u[u_offset], ldu, &v[v_offset], ldv, &q[
+ q_offset], ldq, &iwork[1], &work[1], &work[*n + 1], info);
+
+/* Compute the GSVD of two upper "triangular" matrices */
+
+ stgsja_(jobu, jobv, jobq, m, p, n, k, l, &a[a_offset], lda, &b[b_offset],
+ ldb, &tola, &tolb, &alpha[1], &beta[1], &u[u_offset], ldu, &v[
+ v_offset], ldv, &q[q_offset], ldq, &work[1], &ncycle, info);
+
+/* Sort the singular values and store the pivot indices in IWORK */
+/* Copy ALPHA to WORK, then sort ALPHA in WORK */
+
+ scopy_(n, &alpha[1], &c__1, &work[1], &c__1);
+/* Computing MIN */
+ i__1 = *l, i__2 = *m - *k;
+ ibnd = min(i__1,i__2);
+ i__1 = ibnd;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Scan for largest ALPHA(K+I) */
+
+ isub = i__;
+ smax = work[*k + i__];
+ i__2 = ibnd;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ temp = work[*k + j];
+ if (temp > smax) {
+ isub = j;
+ smax = temp;
+ }
+/* L10: */
+ }
+ if (isub != i__) {
+ work[*k + isub] = work[*k + i__];
+ work[*k + i__] = smax;
+ iwork[*k + i__] = *k + isub;
+ } else {
+ iwork[*k + i__] = *k + i__;
+ }
+/* L20: */
+ }
+
+ return 0;
+
+/* End of SGGSVD */
+
+} /* sggsvd_ */
diff --git a/SRC/sggsvp.c b/SRC/sggsvp.c
new file mode 100644
index 0000000..97fa0de
--- /dev/null
+++ b/SRC/sggsvp.c
@@ -0,0 +1,508 @@
+/* sggsvp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b12 = 0.f;
+static real c_b22 = 1.f;
+
+/* Subroutine */ int sggsvp_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *p, integer *n, real *a, integer *lda, real *b, integer *ldb,
+ real *tola, real *tolb, integer *k, integer *l, real *u, integer *ldu,
+ real *v, integer *ldv, real *q, integer *ldq, integer *iwork, real *
+ tau, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1,
+ u_offset, v_dim1, v_offset, i__1, i__2, i__3;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j;
+ extern logical lsame_(char *, char *);
+ logical wantq, wantu, wantv;
+ extern /* Subroutine */ int sgeqr2_(integer *, integer *, real *, integer
+ *, real *, real *, integer *), sgerq2_(integer *, integer *, real
+ *, integer *, real *, real *, integer *), sorg2r_(integer *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+), sorm2r_(char *, char *, integer *, integer *, integer *, real *
+, integer *, real *, real *, integer *, real *, integer *), sormr2_(char *, char *, integer *, integer *, integer *,
+ real *, integer *, real *, real *, integer *, real *, integer *), xerbla_(char *, integer *), sgeqpf_(
+ integer *, integer *, real *, integer *, integer *, real *, real *
+, integer *), slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *), slapmt_(
+ logical *, integer *, integer *, real *, integer *, integer *);
+ logical forwrd;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGGSVP computes orthogonal matrices U, V and Q such that */
+
+/* N-K-L K L */
+/* U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0; */
+/* L ( 0 0 A23 ) */
+/* M-K-L ( 0 0 0 ) */
+
+/* N-K-L K L */
+/* = K ( 0 A12 A13 ) if M-K-L < 0; */
+/* M-K ( 0 0 A23 ) */
+
+/* N-K-L K L */
+/* V'*B*Q = L ( 0 0 B13 ) */
+/* P-L ( 0 0 0 ) */
+
+/* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */
+/* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */
+/* otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective */
+/* numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the */
+/* transpose of Z. */
+
+/* This decomposition is the preprocessing step for computing the */
+/* Generalized Singular Value Decomposition (GSVD), see subroutine */
+/* SGGSVD. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBU (input) CHARACTER*1 */
+/* = 'U': Orthogonal matrix U is computed; */
+/* = 'N': U is not computed. */
+
+/* JOBV (input) CHARACTER*1 */
+/* = 'V': Orthogonal matrix V is computed; */
+/* = 'N': V is not computed. */
+
+/* JOBQ (input) CHARACTER*1 */
+/* = 'Q': Orthogonal matrix Q is computed; */
+/* = 'N': Q is not computed. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A contains the triangular (or trapezoidal) matrix */
+/* described in the Purpose section. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) REAL array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix B. */
+/* On exit, B contains the triangular matrix described in */
+/* the Purpose section. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,P). */
+
+/* TOLA (input) REAL */
+/* TOLB (input) REAL */
+/* TOLA and TOLB are the thresholds to determine the effective */
+/* numerical rank of matrix B and a subblock of A. Generally, */
+/* they are set to */
+/* TOLA = MAX(M,N)*norm(A)*MACHEPS, */
+/* TOLB = MAX(P,N)*norm(B)*MACHEPS. */
+/* The size of TOLA and TOLB may affect the size of backward */
+/* errors of the decomposition. */
+
+/* K (output) INTEGER */
+/* L (output) INTEGER */
+/* On exit, K and L specify the dimension of the subblocks */
+/* described in Purpose. */
+/* K + L = effective numerical rank of (A',B')'. */
+
+/* U (output) REAL array, dimension (LDU,M) */
+/* If JOBU = 'U', U contains the orthogonal matrix U. */
+/* If JOBU = 'N', U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M) if */
+/* JOBU = 'U'; LDU >= 1 otherwise. */
+
+/* V (output) REAL array, dimension (LDV,P) */
+/* If JOBV = 'V', V contains the orthogonal matrix V. */
+/* If JOBV = 'N', V is not referenced. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. LDV >= max(1,P) if */
+/* JOBV = 'V'; LDV >= 1 otherwise. */
+
+/* Q (output) REAL array, dimension (LDQ,N) */
+/* If JOBQ = 'Q', Q contains the orthogonal matrix Q. */
+/* If JOBQ = 'N', Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N) if */
+/* JOBQ = 'Q'; LDQ >= 1 otherwise. */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* TAU (workspace) REAL array, dimension (N) */
+
+/* WORK (workspace) REAL array, dimension (max(3*N,M,P)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+
+/* Further Details */
+/* =============== */
+
+/* The subroutine uses LAPACK subroutine SGEQPF for the QR factorization */
+/* with column pivoting to detect the effective numerical rank of the */
+/* a matrix. It may be replaced by a better rank determination strategy. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --iwork;
+ --tau;
+ --work;
+
+ /* Function Body */
+ wantu = lsame_(jobu, "U");
+ wantv = lsame_(jobv, "V");
+ wantq = lsame_(jobq, "Q");
+ forwrd = TRUE_;
+
+ *info = 0;
+ if (! (wantu || lsame_(jobu, "N"))) {
+ *info = -1;
+ } else if (! (wantv || lsame_(jobv, "N"))) {
+ *info = -2;
+ } else if (! (wantq || lsame_(jobq, "N"))) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*p < 0) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (*lda < max(1,*m)) {
+ *info = -8;
+ } else if (*ldb < max(1,*p)) {
+ *info = -10;
+ } else if (*ldu < 1 || wantu && *ldu < *m) {
+ *info = -16;
+ } else if (*ldv < 1 || wantv && *ldv < *p) {
+ *info = -18;
+ } else if (*ldq < 1 || wantq && *ldq < *n) {
+ *info = -20;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGGSVP", &i__1);
+ return 0;
+ }
+
+/* QR with column pivoting of B: B*P = V*( S11 S12 ) */
+/* ( 0 0 ) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ iwork[i__] = 0;
+/* L10: */
+ }
+ sgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], info);
+
+/* Update A := A*P */
+
+ slapmt_(&forwrd, m, n, &a[a_offset], lda, &iwork[1]);
+
+/* Determine the effective rank of matrix B. */
+
+ *l = 0;
+ i__1 = min(*p,*n);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((r__1 = b[i__ + i__ * b_dim1], dabs(r__1)) > *tolb) {
+ ++(*l);
+ }
+/* L20: */
+ }
+
+ if (wantv) {
+
+/* Copy the details of V, and form V. */
+
+ slaset_("Full", p, p, &c_b12, &c_b12, &v[v_offset], ldv);
+ if (*p > 1) {
+ i__1 = *p - 1;
+ slacpy_("Lower", &i__1, n, &b[b_dim1 + 2], ldb, &v[v_dim1 + 2],
+ ldv);
+ }
+ i__1 = min(*p,*n);
+ sorg2r_(p, p, &i__1, &v[v_offset], ldv, &tau[1], &work[1], info);
+ }
+
+/* Clean up B */
+
+ i__1 = *l - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *l;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+ if (*p > *l) {
+ i__1 = *p - *l;
+ slaset_("Full", &i__1, n, &c_b12, &c_b12, &b[*l + 1 + b_dim1], ldb);
+ }
+
+ if (wantq) {
+
+/* Set Q = I and Update Q := Q*P */
+
+ slaset_("Full", n, n, &c_b12, &c_b22, &q[q_offset], ldq);
+ slapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]);
+ }
+
+ if (*p >= *l && *n != *l) {
+
+/* RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z */
+
+ sgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info);
+
+/* Update A := A*Z' */
+
+ sormr2_("Right", "Transpose", m, n, l, &b[b_offset], ldb, &tau[1], &a[
+ a_offset], lda, &work[1], info);
+
+ if (wantq) {
+
+/* Update Q := Q*Z' */
+
+ sormr2_("Right", "Transpose", n, n, l, &b[b_offset], ldb, &tau[1],
+ &q[q_offset], ldq, &work[1], info);
+ }
+
+/* Clean up B */
+
+ i__1 = *n - *l;
+ slaset_("Full", l, &i__1, &c_b12, &c_b12, &b[b_offset], ldb);
+ i__1 = *n;
+ for (j = *n - *l + 1; j <= i__1; ++j) {
+ i__2 = *l;
+ for (i__ = j - *n + *l + 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = 0.f;
+/* L50: */
+ }
+/* L60: */
+ }
+
+ }
+
+/* Let N-L L */
+/* A = ( A11 A12 ) M, */
+
+/* then the following does the complete QR decomposition of A11: */
+
+/* A11 = U*( 0 T12 )*P1' */
+/* ( 0 0 ) */
+
+ i__1 = *n - *l;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ iwork[i__] = 0;
+/* L70: */
+ }
+ i__1 = *n - *l;
+ sgeqpf_(m, &i__1, &a[a_offset], lda, &iwork[1], &tau[1], &work[1], info);
+
+/* Determine the effective rank of A11 */
+
+ *k = 0;
+/* Computing MIN */
+ i__2 = *m, i__3 = *n - *l;
+ i__1 = min(i__2,i__3);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((r__1 = a[i__ + i__ * a_dim1], dabs(r__1)) > *tola) {
+ ++(*k);
+ }
+/* L80: */
+ }
+
+/* Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N ) */
+
+/* Computing MIN */
+ i__2 = *m, i__3 = *n - *l;
+ i__1 = min(i__2,i__3);
+ sorm2r_("Left", "Transpose", m, l, &i__1, &a[a_offset], lda, &tau[1], &a[(
+ *n - *l + 1) * a_dim1 + 1], lda, &work[1], info);
+
+ if (wantu) {
+
+/* Copy the details of U, and form U */
+
+ slaset_("Full", m, m, &c_b12, &c_b12, &u[u_offset], ldu);
+ if (*m > 1) {
+ i__1 = *m - 1;
+ i__2 = *n - *l;
+ slacpy_("Lower", &i__1, &i__2, &a[a_dim1 + 2], lda, &u[u_dim1 + 2]
+, ldu);
+ }
+/* Computing MIN */
+ i__2 = *m, i__3 = *n - *l;
+ i__1 = min(i__2,i__3);
+ sorg2r_(m, m, &i__1, &u[u_offset], ldu, &tau[1], &work[1], info);
+ }
+
+ if (wantq) {
+
+/* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 */
+
+ i__1 = *n - *l;
+ slapmt_(&forwrd, n, &i__1, &q[q_offset], ldq, &iwork[1]);
+ }
+
+/* Clean up A: set the strictly lower triangular part of */
+/* A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. */
+
+ i__1 = *k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *k;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L90: */
+ }
+/* L100: */
+ }
+ if (*m > *k) {
+ i__1 = *m - *k;
+ i__2 = *n - *l;
+ slaset_("Full", &i__1, &i__2, &c_b12, &c_b12, &a[*k + 1 + a_dim1],
+ lda);
+ }
+
+ if (*n - *l > *k) {
+
+/* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */
+
+ i__1 = *n - *l;
+ sgerq2_(k, &i__1, &a[a_offset], lda, &tau[1], &work[1], info);
+
+ if (wantq) {
+
+/* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1' */
+
+ i__1 = *n - *l;
+ sormr2_("Right", "Transpose", n, &i__1, k, &a[a_offset], lda, &
+ tau[1], &q[q_offset], ldq, &work[1], info);
+ }
+
+/* Clean up A */
+
+ i__1 = *n - *l - *k;
+ slaset_("Full", k, &i__1, &c_b12, &c_b12, &a[a_offset], lda);
+ i__1 = *n - *l;
+ for (j = *n - *l - *k + 1; j <= i__1; ++j) {
+ i__2 = *k;
+ for (i__ = j - *n + *l + *k + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L110: */
+ }
+/* L120: */
+ }
+
+ }
+
+ if (*m > *k) {
+
+/* QR factorization of A( K+1:M,N-L+1:N ) */
+
+ i__1 = *m - *k;
+ sgeqr2_(&i__1, l, &a[*k + 1 + (*n - *l + 1) * a_dim1], lda, &tau[1], &
+ work[1], info);
+
+ if (wantu) {
+
+/* Update U(:,K+1:M) := U(:,K+1:M)*U1 */
+
+ i__1 = *m - *k;
+/* Computing MIN */
+ i__3 = *m - *k;
+ i__2 = min(i__3,*l);
+ sorm2r_("Right", "No transpose", m, &i__1, &i__2, &a[*k + 1 + (*n
+ - *l + 1) * a_dim1], lda, &tau[1], &u[(*k + 1) * u_dim1 +
+ 1], ldu, &work[1], info);
+ }
+
+/* Clean up */
+
+ i__1 = *n;
+ for (j = *n - *l + 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j - *n + *k + *l + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L130: */
+ }
+/* L140: */
+ }
+
+ }
+
+ return 0;
+
+/* End of SGGSVP */
+
+} /* sggsvp_ */
diff --git a/SRC/sgsvj0.c b/SRC/sgsvj0.c
new file mode 100644
index 0000000..b254b5b
--- /dev/null
+++ b/SRC/sgsvj0.c
@@ -0,0 +1,1150 @@
+/* sgsvj0.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static real c_b42 = 1.f;
+
+/* Subroutine */ int sgsvj0_(char *jobv, integer *m, integer *n, real *a,
+ integer *lda, real *d__, real *sva, integer *mv, real *v, integer *
+ ldv, real *eps, real *sfmin, real *tol, integer *nsweep, real *work,
+ integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_sign(real *, real *);
+
+ /* Local variables */
+ real bigtheta;
+ integer pskipped, i__, p, q;
+ real t, rootsfmin, cs, sn;
+ integer ir1, jbc;
+ real big;
+ integer kbl, igl, ibr, jgl, nbl, mvl;
+ real aapp, aapq, aaqq;
+ integer ierr;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ real aapp0, temp1;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ real apoaq, aqoap;
+ extern logical lsame_(char *, char *);
+ real theta, small, fastr[5];
+ logical applv, rsvec;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ logical rotok;
+ extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
+ integer *), saxpy_(integer *, real *, real *, integer *, real *,
+ integer *), srotm_(integer *, real *, integer *, real *, integer *
+, real *), xerbla_(char *, integer *);
+ integer ijblsk, swband;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ integer blskip;
+ real mxaapq, thsign;
+ extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
+ real *);
+ real mxsinj;
+ integer emptsw, notrot, iswrot, lkahead;
+ real rootbig, rooteps;
+ integer rowskip;
+ real roottol;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Zlatko Drmac of the University of Zagreb and -- */
+/* -- Kresimir Veselic of the Fernuniversitaet Hagen -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* This routine is also part of SIGMA (version 1.23, October 23. 2008.) */
+/* SIGMA is a library of algorithms for highly accurate algorithms for */
+/* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the */
+/* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0. */
+
+/* Scalar Arguments */
+
+
+/* Array Arguments */
+
+/* .. */
+
+/* Purpose */
+/* ~~~~~~~ */
+/* SGSVJ0 is called from SGESVJ as a pre-processor and that is its main */
+/* purpose. It applies Jacobi rotations in the same way as SGESVJ does, but */
+/* it does not check convergence (stopping criterion). Few tuning */
+/* parameters (marked by [TP]) are available for the implementer. */
+
+/* Further details */
+/* ~~~~~~~~~~~~~~~ */
+/* SGSVJ0 is used just to enable SGESVJ to call a simplified version of */
+/* itself to work on a submatrix of the original matrix. */
+
+/* Contributors */
+/* ~~~~~~~~~~~~ */
+/* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) */
+
+/* Bugs, Examples and Comments */
+/* ~~~~~~~~~~~~~~~~~~~~~~~~~~~ */
+/* Please report all bugs and send interesting test examples and comments to */
+/* drmac at math.hr. Thank you. */
+
+/* Arguments */
+/* ~~~~~~~~~ */
+
+/* JOBV (input) CHARACTER*1 */
+/* Specifies whether the output from this procedure is used */
+/* to compute the matrix V: */
+/* = 'V': the product of the Jacobi rotations is accumulated */
+/* by postmulyiplying the N-by-N array V. */
+/* (See the description of V.) */
+/* = 'A': the product of the Jacobi rotations is accumulated */
+/* by postmulyiplying the MV-by-N array V. */
+/* (See the descriptions of MV and V.) */
+/* = 'N': the Jacobi rotations are not accumulated. */
+
+/* M (input) INTEGER */
+/* The number of rows of the input matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the input matrix A. */
+/* M >= N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, M-by-N matrix A, such that A*diag(D) represents */
+/* the input matrix. */
+/* On exit, */
+/* A_onexit * D_onexit represents the input matrix A*diag(D) */
+/* post-multiplied by a sequence of Jacobi rotations, where the */
+/* rotation threshold and the total number of sweeps are given in */
+/* TOL and NSWEEP, respectively. */
+/* (See the descriptions of D, TOL and NSWEEP.) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* D (input/workspace/output) REAL array, dimension (N) */
+/* The array D accumulates the scaling factors from the fast scaled */
+/* Jacobi rotations. */
+/* On entry, A*diag(D) represents the input matrix. */
+/* On exit, A_onexit*diag(D_onexit) represents the input matrix */
+/* post-multiplied by a sequence of Jacobi rotations, where the */
+/* rotation threshold and the total number of sweeps are given in */
+/* TOL and NSWEEP, respectively. */
+/* (See the descriptions of A, TOL and NSWEEP.) */
+
+/* SVA (input/workspace/output) REAL array, dimension (N) */
+/* On entry, SVA contains the Euclidean norms of the columns of */
+/* the matrix A*diag(D). */
+/* On exit, SVA contains the Euclidean norms of the columns of */
+/* the matrix onexit*diag(D_onexit). */
+
+/* MV (input) INTEGER */
+/* If JOBV .EQ. 'A', then MV rows of V are post-multipled by a */
+/* sequence of Jacobi rotations. */
+/* If JOBV = 'N', then MV is not referenced. */
+
+/* V (input/output) REAL array, dimension (LDV,N) */
+/* If JOBV .EQ. 'V' then N rows of V are post-multipled by a */
+/* sequence of Jacobi rotations. */
+/* If JOBV .EQ. 'A' then MV rows of V are post-multipled by a */
+/* sequence of Jacobi rotations. */
+/* If JOBV = 'N', then V is not referenced. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V, LDV >= 1. */
+/* If JOBV = 'V', LDV .GE. N. */
+/* If JOBV = 'A', LDV .GE. MV. */
+
+/* EPS (input) INTEGER */
+/* EPS = SLAMCH('Epsilon') */
+
+/* SFMIN (input) INTEGER */
+/* SFMIN = SLAMCH('Safe Minimum') */
+
+/* TOL (input) REAL */
+/* TOL is the threshold for Jacobi rotations. For a pair */
+/* A(:,p), A(:,q) of pivot columns, the Jacobi rotation is */
+/* applied only if ABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL. */
+
+/* NSWEEP (input) INTEGER */
+/* NSWEEP is the number of sweeps of Jacobi rotations to be */
+/* performed. */
+
+/* WORK (workspace) REAL array, dimension LWORK. */
+
+/* LWORK (input) INTEGER */
+/* LWORK is the dimension of WORK. LWORK .GE. M. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit. */
+/* < 0 : if INFO = -i, then the i-th argument had an illegal value */
+
+/* Local Parameters */
+/* Local Scalars */
+/* Local Arrays */
+
+/* Intrinsic Functions */
+
+/* External Functions */
+
+/* External Subroutines */
+
+/* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| */
+
+ /* Parameter adjustments */
+ --sva;
+ --d__;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --work;
+
+ /* Function Body */
+ applv = lsame_(jobv, "A");
+ rsvec = lsame_(jobv, "V");
+ if (! (rsvec || applv || lsame_(jobv, "N"))) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*n < 0 || *n > *m) {
+ *info = -3;
+ } else if (*lda < *m) {
+ *info = -5;
+ } else if (*mv < 0) {
+ *info = -8;
+ } else if (*ldv < *m) {
+ *info = -10;
+ } else if (*tol <= *eps) {
+ *info = -13;
+ } else if (*nsweep < 0) {
+ *info = -14;
+ } else if (*lwork < *m) {
+ *info = -16;
+ } else {
+ *info = 0;
+ }
+
+/* #:( */
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGSVJ0", &i__1);
+ return 0;
+ }
+
+ if (rsvec) {
+ mvl = *n;
+ } else if (applv) {
+ mvl = *mv;
+ }
+ rsvec = rsvec || applv;
+ rooteps = sqrt(*eps);
+ rootsfmin = sqrt(*sfmin);
+ small = *sfmin / *eps;
+ big = 1.f / *sfmin;
+ rootbig = 1.f / rootsfmin;
+ bigtheta = 1.f / rooteps;
+ roottol = sqrt(*tol);
+
+
+/* -#- Row-cyclic Jacobi SVD algorithm with column pivoting -#- */
+
+ emptsw = *n * (*n - 1) / 2;
+ notrot = 0;
+ fastr[0] = 0.f;
+
+/* -#- Row-cyclic pivot strategy with de Rijk's pivoting -#- */
+
+ swband = 0;
+/* [TP] SWBAND is a tuning parameter. It is meaningful and effective */
+/* if SGESVJ is used as a computational routine in the preconditioned */
+/* Jacobi SVD algorithm SGESVJ. For sweeps i=1:SWBAND the procedure */
+/* ...... */
+ kbl = min(8,*n);
+/* [TP] KBL is a tuning parameter that defines the tile size in the */
+/* tiling of the p-q loops of pivot pairs. In general, an optimal */
+/* value of KBL depends on the matrix dimensions and on the */
+/* parameters of the computer's memory. */
+
+ nbl = *n / kbl;
+ if (nbl * kbl != *n) {
+ ++nbl;
+ }
+/* Computing 2nd power */
+ i__1 = kbl;
+ blskip = i__1 * i__1 + 1;
+/* [TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. */
+ rowskip = min(5,kbl);
+/* [TP] ROWSKIP is a tuning parameter. */
+ lkahead = 1;
+/* [TP] LKAHEAD is a tuning parameter. */
+ swband = 0;
+ pskipped = 0;
+
+ i__1 = *nsweep;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* .. go go go ... */
+
+ mxaapq = 0.f;
+ mxsinj = 0.f;
+ iswrot = 0;
+
+ notrot = 0;
+ pskipped = 0;
+
+ i__2 = nbl;
+ for (ibr = 1; ibr <= i__2; ++ibr) {
+ igl = (ibr - 1) * kbl + 1;
+
+/* Computing MIN */
+ i__4 = lkahead, i__5 = nbl - ibr;
+ i__3 = min(i__4,i__5);
+ for (ir1 = 0; ir1 <= i__3; ++ir1) {
+
+ igl += ir1 * kbl;
+
+/* Computing MIN */
+ i__5 = igl + kbl - 1, i__6 = *n - 1;
+ i__4 = min(i__5,i__6);
+ for (p = igl; p <= i__4; ++p) {
+/* .. de Rijk's pivoting */
+ i__5 = *n - p + 1;
+ q = isamax_(&i__5, &sva[p], &c__1) + p - 1;
+ if (p != q) {
+ sswap_(m, &a[p * a_dim1 + 1], &c__1, &a[q * a_dim1 +
+ 1], &c__1);
+ if (rsvec) {
+ sswap_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q *
+ v_dim1 + 1], &c__1);
+ }
+ temp1 = sva[p];
+ sva[p] = sva[q];
+ sva[q] = temp1;
+ temp1 = d__[p];
+ d__[p] = d__[q];
+ d__[q] = temp1;
+ }
+
+ if (ir1 == 0) {
+
+/* Column norms are periodically updated by explicit */
+/* norm computation. */
+/* Caveat: */
+/* Some BLAS implementations compute SNRM2(M,A(1,p),1) */
+/* as SQRT(SDOT(M,A(1,p),1,A(1,p),1)), which may result in */
+/* overflow for ||A(:,p)||_2 > SQRT(overflow_threshold), and */
+/* undeflow for ||A(:,p)||_2 < SQRT(underflow_threshold). */
+/* Hence, SNRM2 cannot be trusted, not even in the case when */
+/* the true norm is far from the under(over)flow boundaries. */
+/* If properly implemented SNRM2 is available, the IF-THEN-ELSE */
+/* below should read "AAPP = SNRM2( M, A(1,p), 1 ) * D(p)". */
+
+ if (sva[p] < rootbig && sva[p] > rootsfmin) {
+ sva[p] = snrm2_(m, &a[p * a_dim1 + 1], &c__1) *
+ d__[p];
+ } else {
+ temp1 = 0.f;
+ aapp = 0.f;
+ slassq_(m, &a[p * a_dim1 + 1], &c__1, &temp1, &
+ aapp);
+ sva[p] = temp1 * sqrt(aapp) * d__[p];
+ }
+ aapp = sva[p];
+ } else {
+ aapp = sva[p];
+ }
+
+ if (aapp > 0.f) {
+
+ pskipped = 0;
+
+/* Computing MIN */
+ i__6 = igl + kbl - 1;
+ i__5 = min(i__6,*n);
+ for (q = p + 1; q <= i__5; ++q) {
+
+ aaqq = sva[q];
+ if (aaqq > 0.f) {
+
+ aapp0 = aapp;
+ if (aaqq >= 1.f) {
+ rotok = small * aapp <= aaqq;
+ if (aapp < big / aaqq) {
+ aapq = sdot_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1], &
+ c__1) * d__[p] * d__[q] /
+ aaqq / aapp;
+ } else {
+ scopy_(m, &a[p * a_dim1 + 1], &c__1, &
+ work[1], &c__1);
+ slascl_("G", &c__0, &c__0, &aapp, &
+ d__[p], m, &c__1, &work[1],
+ lda, &ierr);
+ aapq = sdot_(m, &work[1], &c__1, &a[q
+ * a_dim1 + 1], &c__1) * d__[q]
+ / aaqq;
+ }
+ } else {
+ rotok = aapp <= aaqq / small;
+ if (aapp > small / aaqq) {
+ aapq = sdot_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1], &
+ c__1) * d__[p] * d__[q] /
+ aaqq / aapp;
+ } else {
+ scopy_(m, &a[q * a_dim1 + 1], &c__1, &
+ work[1], &c__1);
+ slascl_("G", &c__0, &c__0, &aaqq, &
+ d__[q], m, &c__1, &work[1],
+ lda, &ierr);
+ aapq = sdot_(m, &work[1], &c__1, &a[p
+ * a_dim1 + 1], &c__1) * d__[p]
+ / aapp;
+ }
+ }
+
+/* Computing MAX */
+ r__1 = mxaapq, r__2 = dabs(aapq);
+ mxaapq = dmax(r__1,r__2);
+
+/* TO rotate or NOT to rotate, THAT is the question ... */
+
+ if (dabs(aapq) > *tol) {
+
+/* .. rotate */
+/* ROTATED = ROTATED + ONE */
+
+ if (ir1 == 0) {
+ notrot = 0;
+ pskipped = 0;
+ ++iswrot;
+ }
+
+ if (rotok) {
+
+ aqoap = aaqq / aapp;
+ apoaq = aapp / aaqq;
+ theta = (r__1 = aqoap - apoaq, dabs(
+ r__1)) * -.5f / aapq;
+
+ if (dabs(theta) > bigtheta) {
+
+ t = .5f / theta;
+ fastr[2] = t * d__[p] / d__[q];
+ fastr[3] = -t * d__[q] / d__[p];
+ srotm_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1],
+ &c__1, fastr);
+ if (rsvec) {
+ srotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q *
+ v_dim1 + 1], &c__1, fastr);
+ }
+/* Computing MAX */
+ r__1 = 0.f, r__2 = t * apoaq *
+ aapq + 1.f;
+ sva[q] = aaqq * sqrt((dmax(r__1,
+ r__2)));
+ aapp *= sqrt(1.f - t * aqoap *
+ aapq);
+/* Computing MAX */
+ r__1 = mxsinj, r__2 = dabs(t);
+ mxsinj = dmax(r__1,r__2);
+
+ } else {
+
+/* .. choose correct signum for THETA and rotate */
+
+ thsign = -r_sign(&c_b42, &aapq);
+ t = 1.f / (theta + thsign * sqrt(
+ theta * theta + 1.f));
+ cs = sqrt(1.f / (t * t + 1.f));
+ sn = t * cs;
+
+/* Computing MAX */
+ r__1 = mxsinj, r__2 = dabs(sn);
+ mxsinj = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = 0.f, r__2 = t * apoaq *
+ aapq + 1.f;
+ sva[q] = aaqq * sqrt((dmax(r__1,
+ r__2)));
+/* Computing MAX */
+ r__1 = 0.f, r__2 = 1.f - t *
+ aqoap * aapq;
+ aapp *= sqrt((dmax(r__1,r__2)));
+
+ apoaq = d__[p] / d__[q];
+ aqoap = d__[q] / d__[p];
+ if (d__[p] >= 1.f) {
+ if (d__[q] >= 1.f) {
+ fastr[2] = t * apoaq;
+ fastr[3] = -t * aqoap;
+ d__[p] *= cs;
+ d__[q] *= cs;
+ srotm_(m, &a[p * a_dim1 + 1], &c__1, &a[q *
+ a_dim1 + 1], &c__1, fastr);
+ if (rsvec) {
+ srotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[
+ q * v_dim1 + 1], &c__1, fastr);
+ }
+ } else {
+ r__1 = -t * aqoap;
+ saxpy_(m, &r__1, &a[q * a_dim1 + 1], &c__1, &a[
+ p * a_dim1 + 1], &c__1);
+ r__1 = cs * sn * apoaq;
+ saxpy_(m, &r__1, &a[p * a_dim1 + 1], &c__1, &a[
+ q * a_dim1 + 1], &c__1);
+ d__[p] *= cs;
+ d__[q] /= cs;
+ if (rsvec) {
+ r__1 = -t * aqoap;
+ saxpy_(&mvl, &r__1, &v[q * v_dim1 + 1], &
+ c__1, &v[p * v_dim1 + 1], &c__1);
+ r__1 = cs * sn * apoaq;
+ saxpy_(&mvl, &r__1, &v[p * v_dim1 + 1], &
+ c__1, &v[q * v_dim1 + 1], &c__1);
+ }
+ }
+ } else {
+ if (d__[q] >= 1.f) {
+ r__1 = t * apoaq;
+ saxpy_(m, &r__1, &a[p * a_dim1 + 1], &c__1, &a[
+ q * a_dim1 + 1], &c__1);
+ r__1 = -cs * sn * aqoap;
+ saxpy_(m, &r__1, &a[q * a_dim1 + 1], &c__1, &a[
+ p * a_dim1 + 1], &c__1);
+ d__[p] /= cs;
+ d__[q] *= cs;
+ if (rsvec) {
+ r__1 = t * apoaq;
+ saxpy_(&mvl, &r__1, &v[p * v_dim1 + 1], &
+ c__1, &v[q * v_dim1 + 1], &c__1);
+ r__1 = -cs * sn * aqoap;
+ saxpy_(&mvl, &r__1, &v[q * v_dim1 + 1], &
+ c__1, &v[p * v_dim1 + 1], &c__1);
+ }
+ } else {
+ if (d__[p] >= d__[q]) {
+ r__1 = -t * aqoap;
+ saxpy_(m, &r__1, &a[q * a_dim1 + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1);
+ r__1 = cs * sn * apoaq;
+ saxpy_(m, &r__1, &a[p * a_dim1 + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1);
+ d__[p] *= cs;
+ d__[q] /= cs;
+ if (rsvec) {
+ r__1 = -t * aqoap;
+ saxpy_(&mvl, &r__1, &v[q * v_dim1 + 1],
+ &c__1, &v[p * v_dim1 + 1], &
+ c__1);
+ r__1 = cs * sn * apoaq;
+ saxpy_(&mvl, &r__1, &v[p * v_dim1 + 1],
+ &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ }
+ } else {
+ r__1 = t * apoaq;
+ saxpy_(m, &r__1, &a[p * a_dim1 + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1);
+ r__1 = -cs * sn * aqoap;
+ saxpy_(m, &r__1, &a[q * a_dim1 + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1);
+ d__[p] /= cs;
+ d__[q] *= cs;
+ if (rsvec) {
+ r__1 = t * apoaq;
+ saxpy_(&mvl, &r__1, &v[p * v_dim1 + 1],
+ &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ r__1 = -cs * sn * aqoap;
+ saxpy_(&mvl, &r__1, &v[q * v_dim1 + 1],
+ &c__1, &v[p * v_dim1 + 1], &
+ c__1);
+ }
+ }
+ }
+ }
+ }
+
+ } else {
+/* .. have to use modified Gram-Schmidt like transformation */
+ scopy_(m, &a[p * a_dim1 + 1], &c__1, &
+ work[1], &c__1);
+ slascl_("G", &c__0, &c__0, &aapp, &
+ c_b42, m, &c__1, &work[1],
+ lda, &ierr);
+ slascl_("G", &c__0, &c__0, &aaqq, &
+ c_b42, m, &c__1, &a[q *
+ a_dim1 + 1], lda, &ierr);
+ temp1 = -aapq * d__[p] / d__[q];
+ saxpy_(m, &temp1, &work[1], &c__1, &a[
+ q * a_dim1 + 1], &c__1);
+ slascl_("G", &c__0, &c__0, &c_b42, &
+ aaqq, m, &c__1, &a[q * a_dim1
+ + 1], lda, &ierr);
+/* Computing MAX */
+ r__1 = 0.f, r__2 = 1.f - aapq * aapq;
+ sva[q] = aaqq * sqrt((dmax(r__1,r__2))
+ );
+ mxsinj = dmax(mxsinj,*sfmin);
+ }
+/* END IF ROTOK THEN ... ELSE */
+
+/* In the case of cancellation in updating SVA(q), SVA(p) */
+/* recompute SVA(q), SVA(p). */
+/* Computing 2nd power */
+ r__1 = sva[q] / aaqq;
+ if (r__1 * r__1 <= rooteps) {
+ if (aaqq < rootbig && aaqq >
+ rootsfmin) {
+ sva[q] = snrm2_(m, &a[q * a_dim1
+ + 1], &c__1) * d__[q];
+ } else {
+ t = 0.f;
+ aaqq = 0.f;
+ slassq_(m, &a[q * a_dim1 + 1], &
+ c__1, &t, &aaqq);
+ sva[q] = t * sqrt(aaqq) * d__[q];
+ }
+ }
+ if (aapp / aapp0 <= rooteps) {
+ if (aapp < rootbig && aapp >
+ rootsfmin) {
+ aapp = snrm2_(m, &a[p * a_dim1 +
+ 1], &c__1) * d__[p];
+ } else {
+ t = 0.f;
+ aapp = 0.f;
+ slassq_(m, &a[p * a_dim1 + 1], &
+ c__1, &t, &aapp);
+ aapp = t * sqrt(aapp) * d__[p];
+ }
+ sva[p] = aapp;
+ }
+
+ } else {
+/* A(:,p) and A(:,q) already numerically orthogonal */
+ if (ir1 == 0) {
+ ++notrot;
+ }
+ ++pskipped;
+ }
+ } else {
+/* A(:,q) is zero column */
+ if (ir1 == 0) {
+ ++notrot;
+ }
+ ++pskipped;
+ }
+
+ if (i__ <= swband && pskipped > rowskip) {
+ if (ir1 == 0) {
+ aapp = -aapp;
+ }
+ notrot = 0;
+ goto L2103;
+ }
+
+/* L2002: */
+ }
+/* END q-LOOP */
+
+L2103:
+/* bailed out of q-loop */
+ sva[p] = aapp;
+ } else {
+ sva[p] = aapp;
+ if (ir1 == 0 && aapp == 0.f) {
+/* Computing MIN */
+ i__5 = igl + kbl - 1;
+ notrot = notrot + min(i__5,*n) - p;
+ }
+ }
+
+/* L2001: */
+ }
+/* end of the p-loop */
+/* end of doing the block ( ibr, ibr ) */
+/* L1002: */
+ }
+/* end of ir1-loop */
+
+/* ........................................................ */
+/* ... go to the off diagonal blocks */
+
+ igl = (ibr - 1) * kbl + 1;
+
+ i__3 = nbl;
+ for (jbc = ibr + 1; jbc <= i__3; ++jbc) {
+
+ jgl = (jbc - 1) * kbl + 1;
+
+/* doing the block at ( ibr, jbc ) */
+
+ ijblsk = 0;
+/* Computing MIN */
+ i__5 = igl + kbl - 1;
+ i__4 = min(i__5,*n);
+ for (p = igl; p <= i__4; ++p) {
+
+ aapp = sva[p];
+
+ if (aapp > 0.f) {
+
+ pskipped = 0;
+
+/* Computing MIN */
+ i__6 = jgl + kbl - 1;
+ i__5 = min(i__6,*n);
+ for (q = jgl; q <= i__5; ++q) {
+
+ aaqq = sva[q];
+
+ if (aaqq > 0.f) {
+ aapp0 = aapp;
+
+/* -#- M x 2 Jacobi SVD -#- */
+
+/* -#- Safe Gram matrix computation -#- */
+
+ if (aaqq >= 1.f) {
+ if (aapp >= aaqq) {
+ rotok = small * aapp <= aaqq;
+ } else {
+ rotok = small * aaqq <= aapp;
+ }
+ if (aapp < big / aaqq) {
+ aapq = sdot_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1], &
+ c__1) * d__[p] * d__[q] /
+ aaqq / aapp;
+ } else {
+ scopy_(m, &a[p * a_dim1 + 1], &c__1, &
+ work[1], &c__1);
+ slascl_("G", &c__0, &c__0, &aapp, &
+ d__[p], m, &c__1, &work[1],
+ lda, &ierr);
+ aapq = sdot_(m, &work[1], &c__1, &a[q
+ * a_dim1 + 1], &c__1) * d__[q]
+ / aaqq;
+ }
+ } else {
+ if (aapp >= aaqq) {
+ rotok = aapp <= aaqq / small;
+ } else {
+ rotok = aaqq <= aapp / small;
+ }
+ if (aapp > small / aaqq) {
+ aapq = sdot_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1], &
+ c__1) * d__[p] * d__[q] /
+ aaqq / aapp;
+ } else {
+ scopy_(m, &a[q * a_dim1 + 1], &c__1, &
+ work[1], &c__1);
+ slascl_("G", &c__0, &c__0, &aaqq, &
+ d__[q], m, &c__1, &work[1],
+ lda, &ierr);
+ aapq = sdot_(m, &work[1], &c__1, &a[p
+ * a_dim1 + 1], &c__1) * d__[p]
+ / aapp;
+ }
+ }
+
+/* Computing MAX */
+ r__1 = mxaapq, r__2 = dabs(aapq);
+ mxaapq = dmax(r__1,r__2);
+
+/* TO rotate or NOT to rotate, THAT is the question ... */
+
+ if (dabs(aapq) > *tol) {
+ notrot = 0;
+/* ROTATED = ROTATED + 1 */
+ pskipped = 0;
+ ++iswrot;
+
+ if (rotok) {
+
+ aqoap = aaqq / aapp;
+ apoaq = aapp / aaqq;
+ theta = (r__1 = aqoap - apoaq, dabs(
+ r__1)) * -.5f / aapq;
+ if (aaqq > aapp0) {
+ theta = -theta;
+ }
+
+ if (dabs(theta) > bigtheta) {
+ t = .5f / theta;
+ fastr[2] = t * d__[p] / d__[q];
+ fastr[3] = -t * d__[q] / d__[p];
+ srotm_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1],
+ &c__1, fastr);
+ if (rsvec) {
+ srotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q *
+ v_dim1 + 1], &c__1, fastr);
+ }
+/* Computing MAX */
+ r__1 = 0.f, r__2 = t * apoaq *
+ aapq + 1.f;
+ sva[q] = aaqq * sqrt((dmax(r__1,
+ r__2)));
+/* Computing MAX */
+ r__1 = 0.f, r__2 = 1.f - t *
+ aqoap * aapq;
+ aapp *= sqrt((dmax(r__1,r__2)));
+/* Computing MAX */
+ r__1 = mxsinj, r__2 = dabs(t);
+ mxsinj = dmax(r__1,r__2);
+ } else {
+
+/* .. choose correct signum for THETA and rotate */
+
+ thsign = -r_sign(&c_b42, &aapq);
+ if (aaqq > aapp0) {
+ thsign = -thsign;
+ }
+ t = 1.f / (theta + thsign * sqrt(
+ theta * theta + 1.f));
+ cs = sqrt(1.f / (t * t + 1.f));
+ sn = t * cs;
+/* Computing MAX */
+ r__1 = mxsinj, r__2 = dabs(sn);
+ mxsinj = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = 0.f, r__2 = t * apoaq *
+ aapq + 1.f;
+ sva[q] = aaqq * sqrt((dmax(r__1,
+ r__2)));
+ aapp *= sqrt(1.f - t * aqoap *
+ aapq);
+
+ apoaq = d__[p] / d__[q];
+ aqoap = d__[q] / d__[p];
+ if (d__[p] >= 1.f) {
+
+ if (d__[q] >= 1.f) {
+ fastr[2] = t * apoaq;
+ fastr[3] = -t * aqoap;
+ d__[p] *= cs;
+ d__[q] *= cs;
+ srotm_(m, &a[p * a_dim1 + 1], &c__1, &a[q *
+ a_dim1 + 1], &c__1, fastr);
+ if (rsvec) {
+ srotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[
+ q * v_dim1 + 1], &c__1, fastr);
+ }
+ } else {
+ r__1 = -t * aqoap;
+ saxpy_(m, &r__1, &a[q * a_dim1 + 1], &c__1, &a[
+ p * a_dim1 + 1], &c__1);
+ r__1 = cs * sn * apoaq;
+ saxpy_(m, &r__1, &a[p * a_dim1 + 1], &c__1, &a[
+ q * a_dim1 + 1], &c__1);
+ if (rsvec) {
+ r__1 = -t * aqoap;
+ saxpy_(&mvl, &r__1, &v[q * v_dim1 + 1], &
+ c__1, &v[p * v_dim1 + 1], &c__1);
+ r__1 = cs * sn * apoaq;
+ saxpy_(&mvl, &r__1, &v[p * v_dim1 + 1], &
+ c__1, &v[q * v_dim1 + 1], &c__1);
+ }
+ d__[p] *= cs;
+ d__[q] /= cs;
+ }
+ } else {
+ if (d__[q] >= 1.f) {
+ r__1 = t * apoaq;
+ saxpy_(m, &r__1, &a[p * a_dim1 + 1], &c__1, &a[
+ q * a_dim1 + 1], &c__1);
+ r__1 = -cs * sn * aqoap;
+ saxpy_(m, &r__1, &a[q * a_dim1 + 1], &c__1, &a[
+ p * a_dim1 + 1], &c__1);
+ if (rsvec) {
+ r__1 = t * apoaq;
+ saxpy_(&mvl, &r__1, &v[p * v_dim1 + 1], &
+ c__1, &v[q * v_dim1 + 1], &c__1);
+ r__1 = -cs * sn * aqoap;
+ saxpy_(&mvl, &r__1, &v[q * v_dim1 + 1], &
+ c__1, &v[p * v_dim1 + 1], &c__1);
+ }
+ d__[p] /= cs;
+ d__[q] *= cs;
+ } else {
+ if (d__[p] >= d__[q]) {
+ r__1 = -t * aqoap;
+ saxpy_(m, &r__1, &a[q * a_dim1 + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1);
+ r__1 = cs * sn * apoaq;
+ saxpy_(m, &r__1, &a[p * a_dim1 + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1);
+ d__[p] *= cs;
+ d__[q] /= cs;
+ if (rsvec) {
+ r__1 = -t * aqoap;
+ saxpy_(&mvl, &r__1, &v[q * v_dim1 + 1],
+ &c__1, &v[p * v_dim1 + 1], &
+ c__1);
+ r__1 = cs * sn * apoaq;
+ saxpy_(&mvl, &r__1, &v[p * v_dim1 + 1],
+ &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ }
+ } else {
+ r__1 = t * apoaq;
+ saxpy_(m, &r__1, &a[p * a_dim1 + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1);
+ r__1 = -cs * sn * aqoap;
+ saxpy_(m, &r__1, &a[q * a_dim1 + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1);
+ d__[p] /= cs;
+ d__[q] *= cs;
+ if (rsvec) {
+ r__1 = t * apoaq;
+ saxpy_(&mvl, &r__1, &v[p * v_dim1 + 1],
+ &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ r__1 = -cs * sn * aqoap;
+ saxpy_(&mvl, &r__1, &v[q * v_dim1 + 1],
+ &c__1, &v[p * v_dim1 + 1], &
+ c__1);
+ }
+ }
+ }
+ }
+ }
+
+ } else {
+ if (aapp > aaqq) {
+ scopy_(m, &a[p * a_dim1 + 1], &
+ c__1, &work[1], &c__1);
+ slascl_("G", &c__0, &c__0, &aapp,
+ &c_b42, m, &c__1, &work[1]
+, lda, &ierr);
+ slascl_("G", &c__0, &c__0, &aaqq,
+ &c_b42, m, &c__1, &a[q *
+ a_dim1 + 1], lda, &ierr);
+ temp1 = -aapq * d__[p] / d__[q];
+ saxpy_(m, &temp1, &work[1], &c__1,
+ &a[q * a_dim1 + 1], &
+ c__1);
+ slascl_("G", &c__0, &c__0, &c_b42,
+ &aaqq, m, &c__1, &a[q *
+ a_dim1 + 1], lda, &ierr);
+/* Computing MAX */
+ r__1 = 0.f, r__2 = 1.f - aapq *
+ aapq;
+ sva[q] = aaqq * sqrt((dmax(r__1,
+ r__2)));
+ mxsinj = dmax(mxsinj,*sfmin);
+ } else {
+ scopy_(m, &a[q * a_dim1 + 1], &
+ c__1, &work[1], &c__1);
+ slascl_("G", &c__0, &c__0, &aaqq,
+ &c_b42, m, &c__1, &work[1]
+, lda, &ierr);
+ slascl_("G", &c__0, &c__0, &aapp,
+ &c_b42, m, &c__1, &a[p *
+ a_dim1 + 1], lda, &ierr);
+ temp1 = -aapq * d__[q] / d__[p];
+ saxpy_(m, &temp1, &work[1], &c__1,
+ &a[p * a_dim1 + 1], &
+ c__1);
+ slascl_("G", &c__0, &c__0, &c_b42,
+ &aapp, m, &c__1, &a[p *
+ a_dim1 + 1], lda, &ierr);
+/* Computing MAX */
+ r__1 = 0.f, r__2 = 1.f - aapq *
+ aapq;
+ sva[p] = aapp * sqrt((dmax(r__1,
+ r__2)));
+ mxsinj = dmax(mxsinj,*sfmin);
+ }
+ }
+/* END IF ROTOK THEN ... ELSE */
+
+/* In the case of cancellation in updating SVA(q) */
+/* .. recompute SVA(q) */
+/* Computing 2nd power */
+ r__1 = sva[q] / aaqq;
+ if (r__1 * r__1 <= rooteps) {
+ if (aaqq < rootbig && aaqq >
+ rootsfmin) {
+ sva[q] = snrm2_(m, &a[q * a_dim1
+ + 1], &c__1) * d__[q];
+ } else {
+ t = 0.f;
+ aaqq = 0.f;
+ slassq_(m, &a[q * a_dim1 + 1], &
+ c__1, &t, &aaqq);
+ sva[q] = t * sqrt(aaqq) * d__[q];
+ }
+ }
+/* Computing 2nd power */
+ r__1 = aapp / aapp0;
+ if (r__1 * r__1 <= rooteps) {
+ if (aapp < rootbig && aapp >
+ rootsfmin) {
+ aapp = snrm2_(m, &a[p * a_dim1 +
+ 1], &c__1) * d__[p];
+ } else {
+ t = 0.f;
+ aapp = 0.f;
+ slassq_(m, &a[p * a_dim1 + 1], &
+ c__1, &t, &aapp);
+ aapp = t * sqrt(aapp) * d__[p];
+ }
+ sva[p] = aapp;
+ }
+/* end of OK rotation */
+ } else {
+ ++notrot;
+ ++pskipped;
+ ++ijblsk;
+ }
+ } else {
+ ++notrot;
+ ++pskipped;
+ ++ijblsk;
+ }
+
+ if (i__ <= swband && ijblsk >= blskip) {
+ sva[p] = aapp;
+ notrot = 0;
+ goto L2011;
+ }
+ if (i__ <= swband && pskipped > rowskip) {
+ aapp = -aapp;
+ notrot = 0;
+ goto L2203;
+ }
+
+/* L2200: */
+ }
+/* end of the q-loop */
+L2203:
+
+ sva[p] = aapp;
+
+ } else {
+ if (aapp == 0.f) {
+/* Computing MIN */
+ i__5 = jgl + kbl - 1;
+ notrot = notrot + min(i__5,*n) - jgl + 1;
+ }
+ if (aapp < 0.f) {
+ notrot = 0;
+ }
+ }
+/* L2100: */
+ }
+/* end of the p-loop */
+/* L2010: */
+ }
+/* end of the jbc-loop */
+L2011:
+/* 2011 bailed out of the jbc-loop */
+/* Computing MIN */
+ i__4 = igl + kbl - 1;
+ i__3 = min(i__4,*n);
+ for (p = igl; p <= i__3; ++p) {
+ sva[p] = (r__1 = sva[p], dabs(r__1));
+/* L2012: */
+ }
+
+/* L2000: */
+ }
+/* 2000 :: end of the ibr-loop */
+
+/* .. update SVA(N) */
+ if (sva[*n] < rootbig && sva[*n] > rootsfmin) {
+ sva[*n] = snrm2_(m, &a[*n * a_dim1 + 1], &c__1) * d__[*n];
+ } else {
+ t = 0.f;
+ aapp = 0.f;
+ slassq_(m, &a[*n * a_dim1 + 1], &c__1, &t, &aapp);
+ sva[*n] = t * sqrt(aapp) * d__[*n];
+ }
+
+/* Additional steering devices */
+
+ if (i__ < swband && (mxaapq <= roottol || iswrot <= *n)) {
+ swband = i__;
+ }
+
+ if (i__ > swband + 1 && mxaapq < (real) (*n) * *tol && (real) (*n) *
+ mxaapq * mxsinj < *tol) {
+ goto L1994;
+ }
+
+ if (notrot >= emptsw) {
+ goto L1994;
+ }
+/* L1993: */
+ }
+/* end i=1:NSWEEP loop */
+/* #:) Reaching this point means that the procedure has comleted the given */
+/* number of iterations. */
+ *info = *nsweep - 1;
+ goto L1995;
+L1994:
+/* #:) Reaching this point means that during the i-th sweep all pivots were */
+/* below the given tolerance, causing early exit. */
+
+ *info = 0;
+/* #:) INFO = 0 confirms successful iterations. */
+L1995:
+
+/* Sort the vector D. */
+ i__1 = *n - 1;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = *n - p + 1;
+ q = isamax_(&i__2, &sva[p], &c__1) + p - 1;
+ if (p != q) {
+ temp1 = sva[p];
+ sva[p] = sva[q];
+ sva[q] = temp1;
+ temp1 = d__[p];
+ d__[p] = d__[q];
+ d__[q] = temp1;
+ sswap_(m, &a[p * a_dim1 + 1], &c__1, &a[q * a_dim1 + 1], &c__1);
+ if (rsvec) {
+ sswap_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ }
+ }
+/* L5991: */
+ }
+
+ return 0;
+/* .. */
+/* .. END OF SGSVJ0 */
+/* .. */
+} /* sgsvj0_ */
diff --git a/SRC/sgsvj1.c b/SRC/sgsvj1.c
new file mode 100644
index 0000000..584b7f5
--- /dev/null
+++ b/SRC/sgsvj1.c
@@ -0,0 +1,789 @@
+/* sgsvj1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static real c_b35 = 1.f;
+
+/* Subroutine */ int sgsvj1_(char *jobv, integer *m, integer *n, integer *n1,
+ real *a, integer *lda, real *d__, real *sva, integer *mv, real *v,
+ integer *ldv, real *eps, real *sfmin, real *tol, integer *nsweep,
+ real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_sign(real *, real *);
+
+ /* Local variables */
+ real bigtheta;
+ integer pskipped, i__, p, q;
+ real t, rootsfmin, cs, sn;
+ integer jbc;
+ real big;
+ integer kbl, igl, ibr, jgl, mvl, nblc;
+ real aapp, aapq, aaqq;
+ integer nblr, ierr;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ real aapp0, temp1;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ real large, apoaq, aqoap;
+ extern logical lsame_(char *, char *);
+ real theta, small, fastr[5];
+ logical applv, rsvec;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ logical rotok;
+ extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
+ integer *), saxpy_(integer *, real *, real *, integer *, real *,
+ integer *), srotm_(integer *, real *, integer *, real *, integer *
+, real *), xerbla_(char *, integer *);
+ integer ijblsk, swband;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ integer blskip;
+ real mxaapq, thsign;
+ extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
+ real *);
+ real mxsinj;
+ integer emptsw, notrot, iswrot;
+ real rootbig, rooteps;
+ integer rowskip;
+ real roottol;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Zlatko Drmac of the University of Zagreb and -- */
+/* -- Kresimir Veselic of the Fernuniversitaet Hagen -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* This routine is also part of SIGMA (version 1.23, October 23. 2008.) */
+/* SIGMA is a library of algorithms for highly accurate algorithms for */
+/* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the */
+/* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0. */
+
+/* -#- Scalar Arguments -#- */
+
+
+/* -#- Array Arguments -#- */
+
+/* .. */
+
+/* Purpose */
+/* ~~~~~~~ */
+/* SGSVJ1 is called from SGESVJ as a pre-processor and that is its main */
+/* purpose. It applies Jacobi rotations in the same way as SGESVJ does, but */
+/* it targets only particular pivots and it does not check convergence */
+/* (stopping criterion). Few tunning parameters (marked by [TP]) are */
+/* available for the implementer. */
+
+/* Further details */
+/* ~~~~~~~~~~~~~~~ */
+/* SGSVJ1 applies few sweeps of Jacobi rotations in the column space of */
+/* the input M-by-N matrix A. The pivot pairs are taken from the (1,2) */
+/* off-diagonal block in the corresponding N-by-N Gram matrix A^T * A. The */
+/* block-entries (tiles) of the (1,2) off-diagonal block are marked by the */
+/* [x]'s in the following scheme: */
+
+/* | * * * [x] [x] [x]| */
+/* | * * * [x] [x] [x]| Row-cycling in the nblr-by-nblc [x] blocks. */
+/* | * * * [x] [x] [x]| Row-cyclic pivoting inside each [x] block. */
+/* |[x] [x] [x] * * * | */
+/* |[x] [x] [x] * * * | */
+/* |[x] [x] [x] * * * | */
+
+/* In terms of the columns of A, the first N1 columns are rotated 'against' */
+/* the remaining N-N1 columns, trying to increase the angle between the */
+/* corresponding subspaces. The off-diagonal block is N1-by(N-N1) and it is */
+/* tiled using quadratic tiles of side KBL. Here, KBL is a tunning parmeter. */
+/* The number of sweeps is given in NSWEEP and the orthogonality threshold */
+/* is given in TOL. */
+
+/* Contributors */
+/* ~~~~~~~~~~~~ */
+/* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) */
+
+/* Arguments */
+/* ~~~~~~~~~ */
+
+/* JOBV (input) CHARACTER*1 */
+/* Specifies whether the output from this procedure is used */
+/* to compute the matrix V: */
+/* = 'V': the product of the Jacobi rotations is accumulated */
+/* by postmulyiplying the N-by-N array V. */
+/* (See the description of V.) */
+/* = 'A': the product of the Jacobi rotations is accumulated */
+/* by postmulyiplying the MV-by-N array V. */
+/* (See the descriptions of MV and V.) */
+/* = 'N': the Jacobi rotations are not accumulated. */
+
+/* M (input) INTEGER */
+/* The number of rows of the input matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the input matrix A. */
+/* M >= N >= 0. */
+
+/* N1 (input) INTEGER */
+/* N1 specifies the 2 x 2 block partition, the first N1 columns are */
+/* rotated 'against' the remaining N-N1 columns of A. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, M-by-N matrix A, such that A*diag(D) represents */
+/* the input matrix. */
+/* On exit, */
+/* A_onexit * D_onexit represents the input matrix A*diag(D) */
+/* post-multiplied by a sequence of Jacobi rotations, where the */
+/* rotation threshold and the total number of sweeps are given in */
+/* TOL and NSWEEP, respectively. */
+/* (See the descriptions of N1, D, TOL and NSWEEP.) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* D (input/workspace/output) REAL array, dimension (N) */
+/* The array D accumulates the scaling factors from the fast scaled */
+/* Jacobi rotations. */
+/* On entry, A*diag(D) represents the input matrix. */
+/* On exit, A_onexit*diag(D_onexit) represents the input matrix */
+/* post-multiplied by a sequence of Jacobi rotations, where the */
+/* rotation threshold and the total number of sweeps are given in */
+/* TOL and NSWEEP, respectively. */
+/* (See the descriptions of N1, A, TOL and NSWEEP.) */
+
+/* SVA (input/workspace/output) REAL array, dimension (N) */
+/* On entry, SVA contains the Euclidean norms of the columns of */
+/* the matrix A*diag(D). */
+/* On exit, SVA contains the Euclidean norms of the columns of */
+/* the matrix onexit*diag(D_onexit). */
+
+/* MV (input) INTEGER */
+/* If JOBV .EQ. 'A', then MV rows of V are post-multipled by a */
+/* sequence of Jacobi rotations. */
+/* If JOBV = 'N', then MV is not referenced. */
+
+/* V (input/output) REAL array, dimension (LDV,N) */
+/* If JOBV .EQ. 'V' then N rows of V are post-multipled by a */
+/* sequence of Jacobi rotations. */
+/* If JOBV .EQ. 'A' then MV rows of V are post-multipled by a */
+/* sequence of Jacobi rotations. */
+/* If JOBV = 'N', then V is not referenced. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V, LDV >= 1. */
+/* If JOBV = 'V', LDV .GE. N. */
+/* If JOBV = 'A', LDV .GE. MV. */
+
+/* EPS (input) INTEGER */
+/* EPS = SLAMCH('Epsilon') */
+
+/* SFMIN (input) INTEGER */
+/* SFMIN = SLAMCH('Safe Minimum') */
+
+/* TOL (input) REAL */
+/* TOL is the threshold for Jacobi rotations. For a pair */
+/* A(:,p), A(:,q) of pivot columns, the Jacobi rotation is */
+/* applied only if ABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL. */
+
+/* NSWEEP (input) INTEGER */
+/* NSWEEP is the number of sweeps of Jacobi rotations to be */
+/* performed. */
+
+/* WORK (workspace) REAL array, dimension LWORK. */
+
+/* LWORK (input) INTEGER */
+/* LWORK is the dimension of WORK. LWORK .GE. M. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit. */
+/* < 0 : if INFO = -i, then the i-th argument had an illegal value */
+
+/* -#- Local Parameters -#- */
+
+/* -#- Local Scalars -#- */
+
+
+/* Local Arrays */
+
+/* Intrinsic Functions */
+
+/* External Functions */
+
+/* External Subroutines */
+
+
+ /* Parameter adjustments */
+ --sva;
+ --d__;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --work;
+
+ /* Function Body */
+ applv = lsame_(jobv, "A");
+ rsvec = lsame_(jobv, "V");
+ if (! (rsvec || applv || lsame_(jobv, "N"))) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*n < 0 || *n > *m) {
+ *info = -3;
+ } else if (*n1 < 0) {
+ *info = -4;
+ } else if (*lda < *m) {
+ *info = -6;
+ } else if (*mv < 0) {
+ *info = -9;
+ } else if (*ldv < *m) {
+ *info = -11;
+ } else if (*tol <= *eps) {
+ *info = -14;
+ } else if (*nsweep < 0) {
+ *info = -15;
+ } else if (*lwork < *m) {
+ *info = -17;
+ } else {
+ *info = 0;
+ }
+
+/* #:( */
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGSVJ1", &i__1);
+ return 0;
+ }
+
+ if (rsvec) {
+ mvl = *n;
+ } else if (applv) {
+ mvl = *mv;
+ }
+ rsvec = rsvec || applv;
+ rooteps = sqrt(*eps);
+ rootsfmin = sqrt(*sfmin);
+ small = *sfmin / *eps;
+ big = 1.f / *sfmin;
+ rootbig = 1.f / rootsfmin;
+ large = big / sqrt((real) (*m * *n));
+ bigtheta = 1.f / rooteps;
+ roottol = sqrt(*tol);
+
+/* -#- Initialize the right singular vector matrix -#- */
+
+/* RSVEC = LSAME( JOBV, 'Y' ) */
+
+ emptsw = *n1 * (*n - *n1);
+ notrot = 0;
+ fastr[0] = 0.f;
+
+/* -#- Row-cyclic pivot strategy with de Rijk's pivoting -#- */
+
+ kbl = min(8,*n);
+ nblr = *n1 / kbl;
+ if (nblr * kbl != *n1) {
+ ++nblr;
+ }
+/* .. the tiling is nblr-by-nblc [tiles] */
+ nblc = (*n - *n1) / kbl;
+ if (nblc * kbl != *n - *n1) {
+ ++nblc;
+ }
+/* Computing 2nd power */
+ i__1 = kbl;
+ blskip = i__1 * i__1 + 1;
+/* [TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. */
+ rowskip = min(5,kbl);
+/* [TP] ROWSKIP is a tuning parameter. */
+ swband = 0;
+/* [TP] SWBAND is a tuning parameter. It is meaningful and effective */
+/* if SGESVJ is used as a computational routine in the preconditioned */
+/* Jacobi SVD algorithm SGESVJ. */
+
+
+/* | * * * [x] [x] [x]| */
+/* | * * * [x] [x] [x]| Row-cycling in the nblr-by-nblc [x] blocks. */
+/* | * * * [x] [x] [x]| Row-cyclic pivoting inside each [x] block. */
+/* |[x] [x] [x] * * * | */
+/* |[x] [x] [x] * * * | */
+/* |[x] [x] [x] * * * | */
+
+
+ i__1 = *nsweep;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* .. go go go ... */
+
+ mxaapq = 0.f;
+ mxsinj = 0.f;
+ iswrot = 0;
+
+ notrot = 0;
+ pskipped = 0;
+
+ i__2 = nblr;
+ for (ibr = 1; ibr <= i__2; ++ibr) {
+ igl = (ibr - 1) * kbl + 1;
+
+
+/* ........................................................ */
+/* ... go to the off diagonal blocks */
+ igl = (ibr - 1) * kbl + 1;
+ i__3 = nblc;
+ for (jbc = 1; jbc <= i__3; ++jbc) {
+ jgl = *n1 + (jbc - 1) * kbl + 1;
+/* doing the block at ( ibr, jbc ) */
+ ijblsk = 0;
+/* Computing MIN */
+ i__5 = igl + kbl - 1;
+ i__4 = min(i__5,*n1);
+ for (p = igl; p <= i__4; ++p) {
+ aapp = sva[p];
+ if (aapp > 0.f) {
+ pskipped = 0;
+/* Computing MIN */
+ i__6 = jgl + kbl - 1;
+ i__5 = min(i__6,*n);
+ for (q = jgl; q <= i__5; ++q) {
+
+ aaqq = sva[q];
+ if (aaqq > 0.f) {
+ aapp0 = aapp;
+
+/* -#- M x 2 Jacobi SVD -#- */
+
+/* -#- Safe Gram matrix computation -#- */
+
+ if (aaqq >= 1.f) {
+ if (aapp >= aaqq) {
+ rotok = small * aapp <= aaqq;
+ } else {
+ rotok = small * aaqq <= aapp;
+ }
+ if (aapp < big / aaqq) {
+ aapq = sdot_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1], &
+ c__1) * d__[p] * d__[q] /
+ aaqq / aapp;
+ } else {
+ scopy_(m, &a[p * a_dim1 + 1], &c__1, &
+ work[1], &c__1);
+ slascl_("G", &c__0, &c__0, &aapp, &
+ d__[p], m, &c__1, &work[1],
+ lda, &ierr);
+ aapq = sdot_(m, &work[1], &c__1, &a[q
+ * a_dim1 + 1], &c__1) * d__[q]
+ / aaqq;
+ }
+ } else {
+ if (aapp >= aaqq) {
+ rotok = aapp <= aaqq / small;
+ } else {
+ rotok = aaqq <= aapp / small;
+ }
+ if (aapp > small / aaqq) {
+ aapq = sdot_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1], &
+ c__1) * d__[p] * d__[q] /
+ aaqq / aapp;
+ } else {
+ scopy_(m, &a[q * a_dim1 + 1], &c__1, &
+ work[1], &c__1);
+ slascl_("G", &c__0, &c__0, &aaqq, &
+ d__[q], m, &c__1, &work[1],
+ lda, &ierr);
+ aapq = sdot_(m, &work[1], &c__1, &a[p
+ * a_dim1 + 1], &c__1) * d__[p]
+ / aapp;
+ }
+ }
+/* Computing MAX */
+ r__1 = mxaapq, r__2 = dabs(aapq);
+ mxaapq = dmax(r__1,r__2);
+/* TO rotate or NOT to rotate, THAT is the question ... */
+
+ if (dabs(aapq) > *tol) {
+ notrot = 0;
+/* ROTATED = ROTATED + 1 */
+ pskipped = 0;
+ ++iswrot;
+
+ if (rotok) {
+
+ aqoap = aaqq / aapp;
+ apoaq = aapp / aaqq;
+ theta = (r__1 = aqoap - apoaq, dabs(
+ r__1)) * -.5f / aapq;
+ if (aaqq > aapp0) {
+ theta = -theta;
+ }
+ if (dabs(theta) > bigtheta) {
+ t = .5f / theta;
+ fastr[2] = t * d__[p] / d__[q];
+ fastr[3] = -t * d__[q] / d__[p];
+ srotm_(m, &a[p * a_dim1 + 1], &
+ c__1, &a[q * a_dim1 + 1],
+ &c__1, fastr);
+ if (rsvec) {
+ srotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q *
+ v_dim1 + 1], &c__1, fastr);
+ }
+/* Computing MAX */
+ r__1 = 0.f, r__2 = t * apoaq *
+ aapq + 1.f;
+ sva[q] = aaqq * sqrt((dmax(r__1,
+ r__2)));
+/* Computing MAX */
+ r__1 = 0.f, r__2 = 1.f - t *
+ aqoap * aapq;
+ aapp *= sqrt((dmax(r__1,r__2)));
+/* Computing MAX */
+ r__1 = mxsinj, r__2 = dabs(t);
+ mxsinj = dmax(r__1,r__2);
+ } else {
+
+/* .. choose correct signum for THETA and rotate */
+
+ thsign = -r_sign(&c_b35, &aapq);
+ if (aaqq > aapp0) {
+ thsign = -thsign;
+ }
+ t = 1.f / (theta + thsign * sqrt(
+ theta * theta + 1.f));
+ cs = sqrt(1.f / (t * t + 1.f));
+ sn = t * cs;
+/* Computing MAX */
+ r__1 = mxsinj, r__2 = dabs(sn);
+ mxsinj = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = 0.f, r__2 = t * apoaq *
+ aapq + 1.f;
+ sva[q] = aaqq * sqrt((dmax(r__1,
+ r__2)));
+ aapp *= sqrt(1.f - t * aqoap *
+ aapq);
+ apoaq = d__[p] / d__[q];
+ aqoap = d__[q] / d__[p];
+ if (d__[p] >= 1.f) {
+
+ if (d__[q] >= 1.f) {
+ fastr[2] = t * apoaq;
+ fastr[3] = -t * aqoap;
+ d__[p] *= cs;
+ d__[q] *= cs;
+ srotm_(m, &a[p * a_dim1 + 1], &c__1, &a[q *
+ a_dim1 + 1], &c__1, fastr);
+ if (rsvec) {
+ srotm_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[
+ q * v_dim1 + 1], &c__1, fastr);
+ }
+ } else {
+ r__1 = -t * aqoap;
+ saxpy_(m, &r__1, &a[q * a_dim1 + 1], &c__1, &a[
+ p * a_dim1 + 1], &c__1);
+ r__1 = cs * sn * apoaq;
+ saxpy_(m, &r__1, &a[p * a_dim1 + 1], &c__1, &a[
+ q * a_dim1 + 1], &c__1);
+ if (rsvec) {
+ r__1 = -t * aqoap;
+ saxpy_(&mvl, &r__1, &v[q * v_dim1 + 1], &
+ c__1, &v[p * v_dim1 + 1], &c__1);
+ r__1 = cs * sn * apoaq;
+ saxpy_(&mvl, &r__1, &v[p * v_dim1 + 1], &
+ c__1, &v[q * v_dim1 + 1], &c__1);
+ }
+ d__[p] *= cs;
+ d__[q] /= cs;
+ }
+ } else {
+ if (d__[q] >= 1.f) {
+ r__1 = t * apoaq;
+ saxpy_(m, &r__1, &a[p * a_dim1 + 1], &c__1, &a[
+ q * a_dim1 + 1], &c__1);
+ r__1 = -cs * sn * aqoap;
+ saxpy_(m, &r__1, &a[q * a_dim1 + 1], &c__1, &a[
+ p * a_dim1 + 1], &c__1);
+ if (rsvec) {
+ r__1 = t * apoaq;
+ saxpy_(&mvl, &r__1, &v[p * v_dim1 + 1], &
+ c__1, &v[q * v_dim1 + 1], &c__1);
+ r__1 = -cs * sn * aqoap;
+ saxpy_(&mvl, &r__1, &v[q * v_dim1 + 1], &
+ c__1, &v[p * v_dim1 + 1], &c__1);
+ }
+ d__[p] /= cs;
+ d__[q] *= cs;
+ } else {
+ if (d__[p] >= d__[q]) {
+ r__1 = -t * aqoap;
+ saxpy_(m, &r__1, &a[q * a_dim1 + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1);
+ r__1 = cs * sn * apoaq;
+ saxpy_(m, &r__1, &a[p * a_dim1 + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1);
+ d__[p] *= cs;
+ d__[q] /= cs;
+ if (rsvec) {
+ r__1 = -t * aqoap;
+ saxpy_(&mvl, &r__1, &v[q * v_dim1 + 1],
+ &c__1, &v[p * v_dim1 + 1], &
+ c__1);
+ r__1 = cs * sn * apoaq;
+ saxpy_(&mvl, &r__1, &v[p * v_dim1 + 1],
+ &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ }
+ } else {
+ r__1 = t * apoaq;
+ saxpy_(m, &r__1, &a[p * a_dim1 + 1], &c__1,
+ &a[q * a_dim1 + 1], &c__1);
+ r__1 = -cs * sn * aqoap;
+ saxpy_(m, &r__1, &a[q * a_dim1 + 1], &c__1,
+ &a[p * a_dim1 + 1], &c__1);
+ d__[p] /= cs;
+ d__[q] *= cs;
+ if (rsvec) {
+ r__1 = t * apoaq;
+ saxpy_(&mvl, &r__1, &v[p * v_dim1 + 1],
+ &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ r__1 = -cs * sn * aqoap;
+ saxpy_(&mvl, &r__1, &v[q * v_dim1 + 1],
+ &c__1, &v[p * v_dim1 + 1], &
+ c__1);
+ }
+ }
+ }
+ }
+ }
+ } else {
+ if (aapp > aaqq) {
+ scopy_(m, &a[p * a_dim1 + 1], &
+ c__1, &work[1], &c__1);
+ slascl_("G", &c__0, &c__0, &aapp,
+ &c_b35, m, &c__1, &work[1]
+, lda, &ierr);
+ slascl_("G", &c__0, &c__0, &aaqq,
+ &c_b35, m, &c__1, &a[q *
+ a_dim1 + 1], lda, &ierr);
+ temp1 = -aapq * d__[p] / d__[q];
+ saxpy_(m, &temp1, &work[1], &c__1,
+ &a[q * a_dim1 + 1], &
+ c__1);
+ slascl_("G", &c__0, &c__0, &c_b35,
+ &aaqq, m, &c__1, &a[q *
+ a_dim1 + 1], lda, &ierr);
+/* Computing MAX */
+ r__1 = 0.f, r__2 = 1.f - aapq *
+ aapq;
+ sva[q] = aaqq * sqrt((dmax(r__1,
+ r__2)));
+ mxsinj = dmax(mxsinj,*sfmin);
+ } else {
+ scopy_(m, &a[q * a_dim1 + 1], &
+ c__1, &work[1], &c__1);
+ slascl_("G", &c__0, &c__0, &aaqq,
+ &c_b35, m, &c__1, &work[1]
+, lda, &ierr);
+ slascl_("G", &c__0, &c__0, &aapp,
+ &c_b35, m, &c__1, &a[p *
+ a_dim1 + 1], lda, &ierr);
+ temp1 = -aapq * d__[q] / d__[p];
+ saxpy_(m, &temp1, &work[1], &c__1,
+ &a[p * a_dim1 + 1], &
+ c__1);
+ slascl_("G", &c__0, &c__0, &c_b35,
+ &aapp, m, &c__1, &a[p *
+ a_dim1 + 1], lda, &ierr);
+/* Computing MAX */
+ r__1 = 0.f, r__2 = 1.f - aapq *
+ aapq;
+ sva[p] = aapp * sqrt((dmax(r__1,
+ r__2)));
+ mxsinj = dmax(mxsinj,*sfmin);
+ }
+ }
+/* END IF ROTOK THEN ... ELSE */
+
+/* In the case of cancellation in updating SVA(q) */
+/* .. recompute SVA(q) */
+/* Computing 2nd power */
+ r__1 = sva[q] / aaqq;
+ if (r__1 * r__1 <= rooteps) {
+ if (aaqq < rootbig && aaqq >
+ rootsfmin) {
+ sva[q] = snrm2_(m, &a[q * a_dim1
+ + 1], &c__1) * d__[q];
+ } else {
+ t = 0.f;
+ aaqq = 0.f;
+ slassq_(m, &a[q * a_dim1 + 1], &
+ c__1, &t, &aaqq);
+ sva[q] = t * sqrt(aaqq) * d__[q];
+ }
+ }
+/* Computing 2nd power */
+ r__1 = aapp / aapp0;
+ if (r__1 * r__1 <= rooteps) {
+ if (aapp < rootbig && aapp >
+ rootsfmin) {
+ aapp = snrm2_(m, &a[p * a_dim1 +
+ 1], &c__1) * d__[p];
+ } else {
+ t = 0.f;
+ aapp = 0.f;
+ slassq_(m, &a[p * a_dim1 + 1], &
+ c__1, &t, &aapp);
+ aapp = t * sqrt(aapp) * d__[p];
+ }
+ sva[p] = aapp;
+ }
+/* end of OK rotation */
+ } else {
+ ++notrot;
+/* SKIPPED = SKIPPED + 1 */
+ ++pskipped;
+ ++ijblsk;
+ }
+ } else {
+ ++notrot;
+ ++pskipped;
+ ++ijblsk;
+ }
+/* IF ( NOTROT .GE. EMPTSW ) GO TO 2011 */
+ if (i__ <= swband && ijblsk >= blskip) {
+ sva[p] = aapp;
+ notrot = 0;
+ goto L2011;
+ }
+ if (i__ <= swband && pskipped > rowskip) {
+ aapp = -aapp;
+ notrot = 0;
+ goto L2203;
+ }
+
+/* L2200: */
+ }
+/* end of the q-loop */
+L2203:
+ sva[p] = aapp;
+
+ } else {
+ if (aapp == 0.f) {
+/* Computing MIN */
+ i__5 = jgl + kbl - 1;
+ notrot = notrot + min(i__5,*n) - jgl + 1;
+ }
+ if (aapp < 0.f) {
+ notrot = 0;
+ }
+/* ** IF ( NOTROT .GE. EMPTSW ) GO TO 2011 */
+ }
+/* L2100: */
+ }
+/* end of the p-loop */
+/* L2010: */
+ }
+/* end of the jbc-loop */
+L2011:
+/* 2011 bailed out of the jbc-loop */
+/* Computing MIN */
+ i__4 = igl + kbl - 1;
+ i__3 = min(i__4,*n);
+ for (p = igl; p <= i__3; ++p) {
+ sva[p] = (r__1 = sva[p], dabs(r__1));
+/* L2012: */
+ }
+/* ** IF ( NOTROT .GE. EMPTSW ) GO TO 1994 */
+/* L2000: */
+ }
+/* 2000 :: end of the ibr-loop */
+
+/* .. update SVA(N) */
+ if (sva[*n] < rootbig && sva[*n] > rootsfmin) {
+ sva[*n] = snrm2_(m, &a[*n * a_dim1 + 1], &c__1) * d__[*n];
+ } else {
+ t = 0.f;
+ aapp = 0.f;
+ slassq_(m, &a[*n * a_dim1 + 1], &c__1, &t, &aapp);
+ sva[*n] = t * sqrt(aapp) * d__[*n];
+ }
+
+/* Additional steering devices */
+
+ if (i__ < swband && (mxaapq <= roottol || iswrot <= *n)) {
+ swband = i__;
+ }
+ if (i__ > swband + 1 && mxaapq < (real) (*n) * *tol && (real) (*n) *
+ mxaapq * mxsinj < *tol) {
+ goto L1994;
+ }
+
+ if (notrot >= emptsw) {
+ goto L1994;
+ }
+/* L1993: */
+ }
+/* end i=1:NSWEEP loop */
+/* #:) Reaching this point means that the procedure has completed the given */
+/* number of sweeps. */
+ *info = *nsweep - 1;
+ goto L1995;
+L1994:
+/* #:) Reaching this point means that during the i-th sweep all pivots were */
+/* below the given threshold, causing early exit. */
+ *info = 0;
+/* #:) INFO = 0 confirms successful iterations. */
+L1995:
+
+/* Sort the vector D */
+
+ i__1 = *n - 1;
+ for (p = 1; p <= i__1; ++p) {
+ i__2 = *n - p + 1;
+ q = isamax_(&i__2, &sva[p], &c__1) + p - 1;
+ if (p != q) {
+ temp1 = sva[p];
+ sva[p] = sva[q];
+ sva[q] = temp1;
+ temp1 = d__[p];
+ d__[p] = d__[q];
+ d__[q] = temp1;
+ sswap_(m, &a[p * a_dim1 + 1], &c__1, &a[q * a_dim1 + 1], &c__1);
+ if (rsvec) {
+ sswap_(&mvl, &v[p * v_dim1 + 1], &c__1, &v[q * v_dim1 + 1], &
+ c__1);
+ }
+ }
+/* L5991: */
+ }
+
+ return 0;
+/* .. */
+/* .. END OF SGSVJ1 */
+/* .. */
+} /* sgsvj1_ */
diff --git a/SRC/sgtcon.c b/SRC/sgtcon.c
new file mode 100644
index 0000000..2410e50
--- /dev/null
+++ b/SRC/sgtcon.c
@@ -0,0 +1,206 @@
+/* sgtcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sgtcon_(char *norm, integer *n, real *dl, real *d__,
+ real *du, real *du2, integer *ipiv, real *anorm, real *rcond, real *
+ work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, kase, kase1;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *,
+ real *, integer *, integer *), xerbla_(char *, integer *);
+ real ainvnm;
+ logical onenrm;
+ extern /* Subroutine */ int sgttrs_(char *, integer *, integer *, real *,
+ real *, real *, real *, integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGTCON estimates the reciprocal of the condition number of a real */
+/* tridiagonal matrix A using the LU factorization as computed by */
+/* SGTTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* DL (input) REAL array, dimension (N-1) */
+/* The (n-1) multipliers that define the matrix L from the */
+/* LU factorization of A as computed by SGTTRF. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the upper triangular matrix U from */
+/* the LU factorization of A. */
+
+/* DU (input) REAL array, dimension (N-1) */
+/* The (n-1) elements of the first superdiagonal of U. */
+
+/* DU2 (input) REAL array, dimension (N-2) */
+/* The (n-2) elements of the second superdiagonal of U. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* ANORM (input) REAL */
+/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */
+/* If NORM = 'I', the infinity-norm of the original matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) REAL array, dimension (2*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --ipiv;
+ --du2;
+ --du;
+ --d__;
+ --dl;
+
+ /* Function Body */
+ *info = 0;
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*anorm < 0.f) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGTCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.f;
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ } else if (*anorm == 0.f) {
+ return 0;
+ }
+
+/* Check that D(1:N) is non-zero. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (d__[i__] == 0.f) {
+ return 0;
+ }
+/* L10: */
+ }
+
+ ainvnm = 0.f;
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kase = 0;
+L20:
+ slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(U)*inv(L). */
+
+ sgttrs_("No transpose", n, &c__1, &dl[1], &d__[1], &du[1], &du2[1]
+, &ipiv[1], &work[1], n, info);
+ } else {
+
+/* Multiply by inv(L')*inv(U'). */
+
+ sgttrs_("Transpose", n, &c__1, &dl[1], &d__[1], &du[1], &du2[1], &
+ ipiv[1], &work[1], n, info);
+ }
+ goto L20;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / ainvnm / *anorm;
+ }
+
+ return 0;
+
+/* End of SGTCON */
+
+} /* sgtcon_ */
diff --git a/SRC/sgtrfs.c b/SRC/sgtrfs.c
new file mode 100644
index 0000000..0168d1d
--- /dev/null
+++ b/SRC/sgtrfs.c
@@ -0,0 +1,444 @@
+/* sgtrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b18 = -1.f;
+static real c_b19 = 1.f;
+
+/* Subroutine */ int sgtrfs_(char *trans, integer *n, integer *nrhs, real *dl,
+ real *d__, real *du, real *dlf, real *df, real *duf, real *du2,
+ integer *ipiv, real *b, integer *ldb, real *x, integer *ldx, real *
+ ferr, real *berr, real *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
+ real r__1, r__2, r__3, r__4;
+
+ /* Local variables */
+ integer i__, j;
+ real s;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3], count;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), saxpy_(integer *, real *, real *, integer *, real *,
+ integer *), slacn2_(integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *), slagtm_(
+ char *, integer *, integer *, real *, real *, real *, real *,
+ real *, integer *, real *, real *, integer *);
+ logical notran;
+ char transn[1], transt[1];
+ real lstres;
+ extern /* Subroutine */ int sgttrs_(char *, integer *, integer *, real *,
+ real *, real *, real *, integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGTRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is tridiagonal, and provides */
+/* error bounds and backward error estimates for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* DL (input) REAL array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of A. */
+
+/* D (input) REAL array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* DU (input) REAL array, dimension (N-1) */
+/* The (n-1) superdiagonal elements of A. */
+
+/* DLF (input) REAL array, dimension (N-1) */
+/* The (n-1) multipliers that define the matrix L from the */
+/* LU factorization of A as computed by SGTTRF. */
+
+/* DF (input) REAL array, dimension (N) */
+/* The n diagonal elements of the upper triangular matrix U from */
+/* the LU factorization of A. */
+
+/* DUF (input) REAL array, dimension (N-1) */
+/* The (n-1) elements of the first superdiagonal of U. */
+
+/* DU2 (input) REAL array, dimension (N-2) */
+/* The (n-2) elements of the second superdiagonal of U. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) REAL array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by SGTTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ --dlf;
+ --df;
+ --duf;
+ --du2;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -13;
+ } else if (*ldx < max(1,*n)) {
+ *info = -15;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGTRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transn = 'N';
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transn = 'T';
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = 4;
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.f;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A, A**T, or A**H, depending on TRANS. */
+
+ scopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+ slagtm_(trans, n, &c__1, &c_b18, &dl[1], &d__[1], &du[1], &x[j *
+ x_dim1 + 1], ldx, &c_b19, &work[*n + 1], n);
+
+/* Compute abs(op(A))*abs(x) + abs(b) for use in the backward */
+/* error bound. */
+
+ if (notran) {
+ if (*n == 1) {
+ work[1] = (r__1 = b[j * b_dim1 + 1], dabs(r__1)) + (r__2 =
+ d__[1] * x[j * x_dim1 + 1], dabs(r__2));
+ } else {
+ work[1] = (r__1 = b[j * b_dim1 + 1], dabs(r__1)) + (r__2 =
+ d__[1] * x[j * x_dim1 + 1], dabs(r__2)) + (r__3 = du[
+ 1] * x[j * x_dim1 + 2], dabs(r__3));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ work[i__] = (r__1 = b[i__ + j * b_dim1], dabs(r__1)) + (
+ r__2 = dl[i__ - 1] * x[i__ - 1 + j * x_dim1],
+ dabs(r__2)) + (r__3 = d__[i__] * x[i__ + j *
+ x_dim1], dabs(r__3)) + (r__4 = du[i__] * x[i__ +
+ 1 + j * x_dim1], dabs(r__4));
+/* L30: */
+ }
+ work[*n] = (r__1 = b[*n + j * b_dim1], dabs(r__1)) + (r__2 =
+ dl[*n - 1] * x[*n - 1 + j * x_dim1], dabs(r__2)) + (
+ r__3 = d__[*n] * x[*n + j * x_dim1], dabs(r__3));
+ }
+ } else {
+ if (*n == 1) {
+ work[1] = (r__1 = b[j * b_dim1 + 1], dabs(r__1)) + (r__2 =
+ d__[1] * x[j * x_dim1 + 1], dabs(r__2));
+ } else {
+ work[1] = (r__1 = b[j * b_dim1 + 1], dabs(r__1)) + (r__2 =
+ d__[1] * x[j * x_dim1 + 1], dabs(r__2)) + (r__3 = dl[
+ 1] * x[j * x_dim1 + 2], dabs(r__3));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ work[i__] = (r__1 = b[i__ + j * b_dim1], dabs(r__1)) + (
+ r__2 = du[i__ - 1] * x[i__ - 1 + j * x_dim1],
+ dabs(r__2)) + (r__3 = d__[i__] * x[i__ + j *
+ x_dim1], dabs(r__3)) + (r__4 = dl[i__] * x[i__ +
+ 1 + j * x_dim1], dabs(r__4));
+/* L40: */
+ }
+ work[*n] = (r__1 = b[*n + j * b_dim1], dabs(r__1)) + (r__2 =
+ du[*n - 1] * x[*n - 1 + j * x_dim1], dabs(r__2)) + (
+ r__3 = d__[*n] * x[*n + j * x_dim1], dabs(r__3));
+ }
+ }
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[
+ i__];
+ s = dmax(r__2,r__3);
+ } else {
+/* Computing MAX */
+ r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1)
+ / (work[i__] + safe1);
+ s = dmax(r__2,r__3);
+ }
+/* L50: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ sgttrs_(trans, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[
+ 1], &work[*n + 1], n, info);
+ saxpy_(n, &c_b19, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
+ ;
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use SLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L60: */
+ }
+
+ kase = 0;
+L70:
+ slacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+ kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)**T). */
+
+ sgttrs_(transt, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &
+ ipiv[1], &work[*n + 1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L80: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L90: */
+ }
+ sgttrs_(transn, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &
+ ipiv[1], &work[*n + 1], n, info);
+ }
+ goto L70;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], dabs(r__1));
+ lstres = dmax(r__2,r__3);
+/* L100: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L110: */
+ }
+
+ return 0;
+
+/* End of SGTRFS */
+
+} /* sgtrfs_ */
diff --git a/SRC/sgtsv.c b/SRC/sgtsv.c
new file mode 100644
index 0000000..1fff65d
--- /dev/null
+++ b/SRC/sgtsv.c
@@ -0,0 +1,318 @@
+/* sgtsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sgtsv_(integer *n, integer *nrhs, real *dl, real *d__,
+ real *du, real *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer i__, j;
+ real fact, temp;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGTSV solves the equation */
+
+/* A*X = B, */
+
+/* where A is an n by n tridiagonal matrix, by Gaussian elimination with */
+/* partial pivoting. */
+
+/* Note that the equation A'*X = B may be solved by interchanging the */
+/* order of the arguments DU and DL. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* DL (input/output) REAL array, dimension (N-1) */
+/* On entry, DL must contain the (n-1) sub-diagonal elements of */
+/* A. */
+
+/* On exit, DL is overwritten by the (n-2) elements of the */
+/* second super-diagonal of the upper triangular matrix U from */
+/* the LU factorization of A, in DL(1), ..., DL(n-2). */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, D must contain the diagonal elements of A. */
+
+/* On exit, D is overwritten by the n diagonal elements of U. */
+
+/* DU (input/output) REAL array, dimension (N-1) */
+/* On entry, DU must contain the (n-1) super-diagonal elements */
+/* of A. */
+
+/* On exit, DU is overwritten by the (n-1) elements of the first */
+/* super-diagonal of U. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the N by NRHS matrix of right hand side matrix B. */
+/* On exit, if INFO = 0, the N by NRHS solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero, and the solution */
+/* has not been computed. The factorization has not been */
+/* completed unless i = N. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGTSV ", &i__1);
+ return 0;
+ }
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*nrhs == 1) {
+ i__1 = *n - 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((r__1 = d__[i__], dabs(r__1)) >= (r__2 = dl[i__], dabs(r__2)))
+ {
+
+/* No row interchange required */
+
+ if (d__[i__] != 0.f) {
+ fact = dl[i__] / d__[i__];
+ d__[i__ + 1] -= fact * du[i__];
+ b[i__ + 1 + b_dim1] -= fact * b[i__ + b_dim1];
+ } else {
+ *info = i__;
+ return 0;
+ }
+ dl[i__] = 0.f;
+ } else {
+
+/* Interchange rows I and I+1 */
+
+ fact = d__[i__] / dl[i__];
+ d__[i__] = dl[i__];
+ temp = d__[i__ + 1];
+ d__[i__ + 1] = du[i__] - fact * temp;
+ dl[i__] = du[i__ + 1];
+ du[i__ + 1] = -fact * dl[i__];
+ du[i__] = temp;
+ temp = b[i__ + b_dim1];
+ b[i__ + b_dim1] = b[i__ + 1 + b_dim1];
+ b[i__ + 1 + b_dim1] = temp - fact * b[i__ + 1 + b_dim1];
+ }
+/* L10: */
+ }
+ if (*n > 1) {
+ i__ = *n - 1;
+ if ((r__1 = d__[i__], dabs(r__1)) >= (r__2 = dl[i__], dabs(r__2)))
+ {
+ if (d__[i__] != 0.f) {
+ fact = dl[i__] / d__[i__];
+ d__[i__ + 1] -= fact * du[i__];
+ b[i__ + 1 + b_dim1] -= fact * b[i__ + b_dim1];
+ } else {
+ *info = i__;
+ return 0;
+ }
+ } else {
+ fact = d__[i__] / dl[i__];
+ d__[i__] = dl[i__];
+ temp = d__[i__ + 1];
+ d__[i__ + 1] = du[i__] - fact * temp;
+ du[i__] = temp;
+ temp = b[i__ + b_dim1];
+ b[i__ + b_dim1] = b[i__ + 1 + b_dim1];
+ b[i__ + 1 + b_dim1] = temp - fact * b[i__ + 1 + b_dim1];
+ }
+ }
+ if (d__[*n] == 0.f) {
+ *info = *n;
+ return 0;
+ }
+ } else {
+ i__1 = *n - 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((r__1 = d__[i__], dabs(r__1)) >= (r__2 = dl[i__], dabs(r__2)))
+ {
+
+/* No row interchange required */
+
+ if (d__[i__] != 0.f) {
+ fact = dl[i__] / d__[i__];
+ d__[i__ + 1] -= fact * du[i__];
+ i__2 = *nrhs;
+ for (j = 1; j <= i__2; ++j) {
+ b[i__ + 1 + j * b_dim1] -= fact * b[i__ + j * b_dim1];
+/* L20: */
+ }
+ } else {
+ *info = i__;
+ return 0;
+ }
+ dl[i__] = 0.f;
+ } else {
+
+/* Interchange rows I and I+1 */
+
+ fact = d__[i__] / dl[i__];
+ d__[i__] = dl[i__];
+ temp = d__[i__ + 1];
+ d__[i__ + 1] = du[i__] - fact * temp;
+ dl[i__] = du[i__ + 1];
+ du[i__ + 1] = -fact * dl[i__];
+ du[i__] = temp;
+ i__2 = *nrhs;
+ for (j = 1; j <= i__2; ++j) {
+ temp = b[i__ + j * b_dim1];
+ b[i__ + j * b_dim1] = b[i__ + 1 + j * b_dim1];
+ b[i__ + 1 + j * b_dim1] = temp - fact * b[i__ + 1 + j *
+ b_dim1];
+/* L30: */
+ }
+ }
+/* L40: */
+ }
+ if (*n > 1) {
+ i__ = *n - 1;
+ if ((r__1 = d__[i__], dabs(r__1)) >= (r__2 = dl[i__], dabs(r__2)))
+ {
+ if (d__[i__] != 0.f) {
+ fact = dl[i__] / d__[i__];
+ d__[i__ + 1] -= fact * du[i__];
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ b[i__ + 1 + j * b_dim1] -= fact * b[i__ + j * b_dim1];
+/* L50: */
+ }
+ } else {
+ *info = i__;
+ return 0;
+ }
+ } else {
+ fact = d__[i__] / dl[i__];
+ d__[i__] = dl[i__];
+ temp = d__[i__ + 1];
+ d__[i__ + 1] = du[i__] - fact * temp;
+ du[i__] = temp;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ temp = b[i__ + j * b_dim1];
+ b[i__ + j * b_dim1] = b[i__ + 1 + j * b_dim1];
+ b[i__ + 1 + j * b_dim1] = temp - fact * b[i__ + 1 + j *
+ b_dim1];
+/* L60: */
+ }
+ }
+ }
+ if (d__[*n] == 0.f) {
+ *info = *n;
+ return 0;
+ }
+ }
+
+/* Back solve with the matrix U from the factorization. */
+
+ if (*nrhs <= 2) {
+ j = 1;
+L70:
+ b[*n + j * b_dim1] /= d__[*n];
+ if (*n > 1) {
+ b[*n - 1 + j * b_dim1] = (b[*n - 1 + j * b_dim1] - du[*n - 1] * b[
+ *n + j * b_dim1]) / d__[*n - 1];
+ }
+ for (i__ = *n - 2; i__ >= 1; --i__) {
+ b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__] * b[i__ + 1
+ + j * b_dim1] - dl[i__] * b[i__ + 2 + j * b_dim1]) / d__[
+ i__];
+/* L80: */
+ }
+ if (j < *nrhs) {
+ ++j;
+ goto L70;
+ }
+ } else {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ b[*n + j * b_dim1] /= d__[*n];
+ if (*n > 1) {
+ b[*n - 1 + j * b_dim1] = (b[*n - 1 + j * b_dim1] - du[*n - 1]
+ * b[*n + j * b_dim1]) / d__[*n - 1];
+ }
+ for (i__ = *n - 2; i__ >= 1; --i__) {
+ b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__] * b[i__
+ + 1 + j * b_dim1] - dl[i__] * b[i__ + 2 + j * b_dim1])
+ / d__[i__];
+/* L90: */
+ }
+/* L100: */
+ }
+ }
+
+ return 0;
+
+/* End of SGTSV */
+
+} /* sgtsv_ */
diff --git a/SRC/sgtsvx.c b/SRC/sgtsvx.c
new file mode 100644
index 0000000..e3ca06a
--- /dev/null
+++ b/SRC/sgtsvx.c
@@ -0,0 +1,347 @@
+/* sgtsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sgtsvx_(char *fact, char *trans, integer *n, integer *
+ nrhs, real *dl, real *d__, real *du, real *dlf, real *df, real *duf,
+ real *du2, integer *ipiv, real *b, integer *ldb, real *x, integer *
+ ldx, real *rcond, real *ferr, real *berr, real *work, integer *iwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+
+ /* Local variables */
+ char norm[1];
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ extern doublereal slamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal slangt_(char *, integer *, real *, real *, real *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), sgtcon_(char *, integer *,
+ real *, real *, real *, real *, integer *, real *, real *, real *,
+ integer *, integer *);
+ logical notran;
+ extern /* Subroutine */ int sgtrfs_(char *, integer *, integer *, real *,
+ real *, real *, real *, real *, real *, real *, integer *, real *,
+ integer *, real *, integer *, real *, real *, real *, integer *,
+ integer *), sgttrf_(integer *, real *, real *, real *,
+ real *, integer *, integer *), sgttrs_(char *, integer *, integer
+ *, real *, real *, real *, real *, integer *, real *, integer *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGTSVX uses the LU factorization to compute the solution to a real */
+/* system of linear equations A * X = B or A**T * X = B, */
+/* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS */
+/* matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A */
+/* as A = L * U, where L is a product of permutation and unit lower */
+/* bidiagonal matrices and U is upper triangular with nonzeros in */
+/* only the main diagonal and first two superdiagonals. */
+
+/* 2. If some U(i,i)=0, so that U is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 3. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 4. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of A has been */
+/* supplied on entry. */
+/* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored */
+/* form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV */
+/* will not be modified. */
+/* = 'N': The matrix will be copied to DLF, DF, and DUF */
+/* and factored. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* DL (input) REAL array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of A. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of A. */
+
+/* DU (input) REAL array, dimension (N-1) */
+/* The (n-1) superdiagonal elements of A. */
+
+/* DLF (input or output) REAL array, dimension (N-1) */
+/* If FACT = 'F', then DLF is an input argument and on entry */
+/* contains the (n-1) multipliers that define the matrix L from */
+/* the LU factorization of A as computed by SGTTRF. */
+
+/* If FACT = 'N', then DLF is an output argument and on exit */
+/* contains the (n-1) multipliers that define the matrix L from */
+/* the LU factorization of A. */
+
+/* DF (input or output) REAL array, dimension (N) */
+/* If FACT = 'F', then DF is an input argument and on entry */
+/* contains the n diagonal elements of the upper triangular */
+/* matrix U from the LU factorization of A. */
+
+/* If FACT = 'N', then DF is an output argument and on exit */
+/* contains the n diagonal elements of the upper triangular */
+/* matrix U from the LU factorization of A. */
+
+/* DUF (input or output) REAL array, dimension (N-1) */
+/* If FACT = 'F', then DUF is an input argument and on entry */
+/* contains the (n-1) elements of the first superdiagonal of U. */
+
+/* If FACT = 'N', then DUF is an output argument and on exit */
+/* contains the (n-1) elements of the first superdiagonal of U. */
+
+/* DU2 (input or output) REAL array, dimension (N-2) */
+/* If FACT = 'F', then DU2 is an input argument and on entry */
+/* contains the (n-2) elements of the second superdiagonal of */
+/* U. */
+
+/* If FACT = 'N', then DU2 is an output argument and on exit */
+/* contains the (n-2) elements of the second superdiagonal of */
+/* U. */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains the pivot indices from the LU factorization of A as */
+/* computed by SGTTRF. */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the LU factorization of A; */
+/* row i of the matrix was interchanged with row IPIV(i). */
+/* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates */
+/* a row interchange was not required. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) REAL array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A. If RCOND is less than the machine precision (in */
+/* particular, if RCOND = 0), the matrix is singular to working */
+/* precision. This condition is indicated by a return code of */
+/* INFO > 0. */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: U(i,i) is exactly zero. The factorization */
+/* has not been completed unless i = N, but the */
+/* factor U is exactly singular, so the solution */
+/* and error bounds could not be computed. */
+/* RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ --dlf;
+ --df;
+ --duf;
+ --du2;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ notran = lsame_(trans, "N");
+ if (! nofact && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -14;
+ } else if (*ldx < max(1,*n)) {
+ *info = -16;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGTSVX", &i__1);
+ return 0;
+ }
+
+ if (nofact) {
+
+/* Compute the LU factorization of A. */
+
+ scopy_(n, &d__[1], &c__1, &df[1], &c__1);
+ if (*n > 1) {
+ i__1 = *n - 1;
+ scopy_(&i__1, &dl[1], &c__1, &dlf[1], &c__1);
+ i__1 = *n - 1;
+ scopy_(&i__1, &du[1], &c__1, &duf[1], &c__1);
+ }
+ sgttrf_(n, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.f;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ if (notran) {
+ *(unsigned char *)norm = '1';
+ } else {
+ *(unsigned char *)norm = 'I';
+ }
+ anorm = slangt_(norm, n, &dl[1], &d__[1], &du[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ sgtcon_(norm, n, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], &anorm,
+ rcond, &work[1], &iwork[1], info);
+
+/* Compute the solution vectors X. */
+
+ slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ sgttrs_(trans, n, nrhs, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], &x[
+ x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solutions and */
+/* compute error bounds and backward error estimates for them. */
+
+ sgtrfs_(trans, n, nrhs, &dl[1], &d__[1], &du[1], &dlf[1], &df[1], &duf[1],
+ &du2[1], &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1]
+, &berr[1], &work[1], &iwork[1], info);
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < slamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of SGTSVX */
+
+} /* sgtsvx_ */
diff --git a/SRC/sgttrf.c b/SRC/sgttrf.c
new file mode 100644
index 0000000..16f18a9
--- /dev/null
+++ b/SRC/sgttrf.c
@@ -0,0 +1,203 @@
+/* sgttrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sgttrf_(integer *n, real *dl, real *d__, real *du, real *
+ du2, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer i__;
+ real fact, temp;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGTTRF computes an LU factorization of a real tridiagonal matrix A */
+/* using elimination with partial pivoting and row interchanges. */
+
+/* The factorization has the form */
+/* A = L * U */
+/* where L is a product of permutation and unit lower bidiagonal */
+/* matrices and U is upper triangular with nonzeros in only the main */
+/* diagonal and first two superdiagonals. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* DL (input/output) REAL array, dimension (N-1) */
+/* On entry, DL must contain the (n-1) sub-diagonal elements of */
+/* A. */
+
+/* On exit, DL is overwritten by the (n-1) multipliers that */
+/* define the matrix L from the LU factorization of A. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, D must contain the diagonal elements of A. */
+
+/* On exit, D is overwritten by the n diagonal elements of the */
+/* upper triangular matrix U from the LU factorization of A. */
+
+/* DU (input/output) REAL array, dimension (N-1) */
+/* On entry, DU must contain the (n-1) super-diagonal elements */
+/* of A. */
+
+/* On exit, DU is overwritten by the (n-1) elements of the first */
+/* super-diagonal of U. */
+
+/* DU2 (output) REAL array, dimension (N-2) */
+/* On exit, DU2 is overwritten by the (n-2) elements of the */
+/* second super-diagonal of U. */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, U(k,k) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ipiv;
+ --du2;
+ --du;
+ --d__;
+ --dl;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ i__1 = -(*info);
+ xerbla_("SGTTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Initialize IPIV(i) = i and DU2(I) = 0 */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ipiv[i__] = i__;
+/* L10: */
+ }
+ i__1 = *n - 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ du2[i__] = 0.f;
+/* L20: */
+ }
+
+ i__1 = *n - 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((r__1 = d__[i__], dabs(r__1)) >= (r__2 = dl[i__], dabs(r__2))) {
+
+/* No row interchange required, eliminate DL(I) */
+
+ if (d__[i__] != 0.f) {
+ fact = dl[i__] / d__[i__];
+ dl[i__] = fact;
+ d__[i__ + 1] -= fact * du[i__];
+ }
+ } else {
+
+/* Interchange rows I and I+1, eliminate DL(I) */
+
+ fact = d__[i__] / dl[i__];
+ d__[i__] = dl[i__];
+ dl[i__] = fact;
+ temp = du[i__];
+ du[i__] = d__[i__ + 1];
+ d__[i__ + 1] = temp - fact * d__[i__ + 1];
+ du2[i__] = du[i__ + 1];
+ du[i__ + 1] = -fact * du[i__ + 1];
+ ipiv[i__] = i__ + 1;
+ }
+/* L30: */
+ }
+ if (*n > 1) {
+ i__ = *n - 1;
+ if ((r__1 = d__[i__], dabs(r__1)) >= (r__2 = dl[i__], dabs(r__2))) {
+ if (d__[i__] != 0.f) {
+ fact = dl[i__] / d__[i__];
+ dl[i__] = fact;
+ d__[i__ + 1] -= fact * du[i__];
+ }
+ } else {
+ fact = d__[i__] / dl[i__];
+ d__[i__] = dl[i__];
+ dl[i__] = fact;
+ temp = du[i__];
+ du[i__] = d__[i__ + 1];
+ d__[i__ + 1] = temp - fact * d__[i__ + 1];
+ ipiv[i__] = i__ + 1;
+ }
+ }
+
+/* Check for a zero on the diagonal of U. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (d__[i__] == 0.f) {
+ *info = i__;
+ goto L50;
+ }
+/* L40: */
+ }
+L50:
+
+ return 0;
+
+/* End of SGTTRF */
+
+} /* sgttrf_ */
diff --git a/SRC/sgttrs.c b/SRC/sgttrs.c
new file mode 100644
index 0000000..0b41a13
--- /dev/null
+++ b/SRC/sgttrs.c
@@ -0,0 +1,189 @@
+/* sgttrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int sgttrs_(char *trans, integer *n, integer *nrhs, real *dl,
+ real *d__, real *du, real *du2, integer *ipiv, real *b, integer *ldb,
+ integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer j, jb, nb;
+ extern /* Subroutine */ int sgtts2_(integer *, integer *, integer *, real
+ *, real *, real *, real *, integer *, real *, integer *), xerbla_(
+ char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer itrans;
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGTTRS solves one of the systems of equations */
+/* A*X = B or A'*X = B, */
+/* with a tridiagonal matrix A using the LU factorization computed */
+/* by SGTTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A'* X = B (Transpose) */
+/* = 'C': A'* X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* DL (input) REAL array, dimension (N-1) */
+/* The (n-1) multipliers that define the matrix L from the */
+/* LU factorization of A. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the upper triangular matrix U from */
+/* the LU factorization of A. */
+
+/* DU (input) REAL array, dimension (N-1) */
+/* The (n-1) elements of the first super-diagonal of U. */
+
+/* DU2 (input) REAL array, dimension (N-2) */
+/* The (n-2) elements of the second super-diagonal of U. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the matrix of right hand side vectors B. */
+/* On exit, B is overwritten by the solution vectors X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ --du2;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ notran = *(unsigned char *)trans == 'N' || *(unsigned char *)trans == 'n';
+ if (! notran && ! (*(unsigned char *)trans == 'T' || *(unsigned char *)
+ trans == 't') && ! (*(unsigned char *)trans == 'C' || *(unsigned
+ char *)trans == 'c')) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(*n,1)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGTTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+/* Decode TRANS */
+
+ if (notran) {
+ itrans = 0;
+ } else {
+ itrans = 1;
+ }
+
+/* Determine the number of right-hand sides to solve at a time. */
+
+ if (*nrhs == 1) {
+ nb = 1;
+ } else {
+/* Computing MAX */
+ i__1 = 1, i__2 = ilaenv_(&c__1, "SGTTRS", trans, n, nrhs, &c_n1, &
+ c_n1);
+ nb = max(i__1,i__2);
+ }
+
+ if (nb >= *nrhs) {
+ sgtts2_(&itrans, n, nrhs, &dl[1], &d__[1], &du[1], &du2[1], &ipiv[1],
+ &b[b_offset], ldb);
+ } else {
+ i__1 = *nrhs;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = *nrhs - j + 1;
+ jb = min(i__3,nb);
+ sgtts2_(&itrans, n, &jb, &dl[1], &d__[1], &du[1], &du2[1], &ipiv[
+ 1], &b[j * b_dim1 + 1], ldb);
+/* L10: */
+ }
+ }
+
+/* End of SGTTRS */
+
+ return 0;
+} /* sgttrs_ */
diff --git a/SRC/sgtts2.c b/SRC/sgtts2.c
new file mode 100644
index 0000000..afbe47b
--- /dev/null
+++ b/SRC/sgtts2.c
@@ -0,0 +1,261 @@
+/* sgtts2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sgtts2_(integer *itrans, integer *n, integer *nrhs, real
+ *dl, real *d__, real *du, real *du2, integer *ipiv, real *b, integer *
+ ldb)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, ip;
+ real temp;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGTTS2 solves one of the systems of equations */
+/* A*X = B or A'*X = B, */
+/* with a tridiagonal matrix A using the LU factorization computed */
+/* by SGTTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* ITRANS (input) INTEGER */
+/* Specifies the form of the system of equations. */
+/* = 0: A * X = B (No transpose) */
+/* = 1: A'* X = B (Transpose) */
+/* = 2: A'* X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* DL (input) REAL array, dimension (N-1) */
+/* The (n-1) multipliers that define the matrix L from the */
+/* LU factorization of A. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the upper triangular matrix U from */
+/* the LU factorization of A. */
+
+/* DU (input) REAL array, dimension (N-1) */
+/* The (n-1) elements of the first super-diagonal of U. */
+
+/* DU2 (input) REAL array, dimension (N-2) */
+/* The (n-2) elements of the second super-diagonal of U. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the matrix of right hand side vectors B. */
+/* On exit, B is overwritten by the solution vectors X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ --du2;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (*itrans == 0) {
+
+/* Solve A*X = B using the LU factorization of A, */
+/* overwriting each right hand side vector with its solution. */
+
+ if (*nrhs <= 1) {
+ j = 1;
+L10:
+
+/* Solve L*x = b. */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ip = ipiv[i__];
+ temp = b[i__ + 1 - ip + i__ + j * b_dim1] - dl[i__] * b[ip +
+ j * b_dim1];
+ b[i__ + j * b_dim1] = b[ip + j * b_dim1];
+ b[i__ + 1 + j * b_dim1] = temp;
+/* L20: */
+ }
+
+/* Solve U*x = b. */
+
+ b[*n + j * b_dim1] /= d__[*n];
+ if (*n > 1) {
+ b[*n - 1 + j * b_dim1] = (b[*n - 1 + j * b_dim1] - du[*n - 1]
+ * b[*n + j * b_dim1]) / d__[*n - 1];
+ }
+ for (i__ = *n - 2; i__ >= 1; --i__) {
+ b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__] * b[i__
+ + 1 + j * b_dim1] - du2[i__] * b[i__ + 2 + j * b_dim1]
+ ) / d__[i__];
+/* L30: */
+ }
+ if (j < *nrhs) {
+ ++j;
+ goto L10;
+ }
+ } else {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve L*x = b. */
+
+ i__2 = *n - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (ipiv[i__] == i__) {
+ b[i__ + 1 + j * b_dim1] -= dl[i__] * b[i__ + j *
+ b_dim1];
+ } else {
+ temp = b[i__ + j * b_dim1];
+ b[i__ + j * b_dim1] = b[i__ + 1 + j * b_dim1];
+ b[i__ + 1 + j * b_dim1] = temp - dl[i__] * b[i__ + j *
+ b_dim1];
+ }
+/* L40: */
+ }
+
+/* Solve U*x = b. */
+
+ b[*n + j * b_dim1] /= d__[*n];
+ if (*n > 1) {
+ b[*n - 1 + j * b_dim1] = (b[*n - 1 + j * b_dim1] - du[*n
+ - 1] * b[*n + j * b_dim1]) / d__[*n - 1];
+ }
+ for (i__ = *n - 2; i__ >= 1; --i__) {
+ b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__] * b[
+ i__ + 1 + j * b_dim1] - du2[i__] * b[i__ + 2 + j *
+ b_dim1]) / d__[i__];
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+ } else {
+
+/* Solve A' * X = B. */
+
+ if (*nrhs <= 1) {
+
+/* Solve U'*x = b. */
+
+ j = 1;
+L70:
+ b[j * b_dim1 + 1] /= d__[1];
+ if (*n > 1) {
+ b[j * b_dim1 + 2] = (b[j * b_dim1 + 2] - du[1] * b[j * b_dim1
+ + 1]) / d__[2];
+ }
+ i__1 = *n;
+ for (i__ = 3; i__ <= i__1; ++i__) {
+ b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__ - 1] * b[
+ i__ - 1 + j * b_dim1] - du2[i__ - 2] * b[i__ - 2 + j *
+ b_dim1]) / d__[i__];
+/* L80: */
+ }
+
+/* Solve L'*x = b. */
+
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ ip = ipiv[i__];
+ temp = b[i__ + j * b_dim1] - dl[i__] * b[i__ + 1 + j * b_dim1]
+ ;
+ b[i__ + j * b_dim1] = b[ip + j * b_dim1];
+ b[ip + j * b_dim1] = temp;
+/* L90: */
+ }
+ if (j < *nrhs) {
+ ++j;
+ goto L70;
+ }
+
+ } else {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve U'*x = b. */
+
+ b[j * b_dim1 + 1] /= d__[1];
+ if (*n > 1) {
+ b[j * b_dim1 + 2] = (b[j * b_dim1 + 2] - du[1] * b[j *
+ b_dim1 + 1]) / d__[2];
+ }
+ i__2 = *n;
+ for (i__ = 3; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = (b[i__ + j * b_dim1] - du[i__ - 1] *
+ b[i__ - 1 + j * b_dim1] - du2[i__ - 2] * b[i__ -
+ 2 + j * b_dim1]) / d__[i__];
+/* L100: */
+ }
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ if (ipiv[i__] == i__) {
+ b[i__ + j * b_dim1] -= dl[i__] * b[i__ + 1 + j *
+ b_dim1];
+ } else {
+ temp = b[i__ + 1 + j * b_dim1];
+ b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - dl[
+ i__] * temp;
+ b[i__ + j * b_dim1] = temp;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+ }
+ }
+
+/* End of SGTTS2 */
+
+ return 0;
+} /* sgtts2_ */
diff --git a/SRC/shgeqz.c b/SRC/shgeqz.c
new file mode 100644
index 0000000..32951fb
--- /dev/null
+++ b/SRC/shgeqz.c
@@ -0,0 +1,1494 @@
+/* shgeqz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b12 = 0.f;
+static real c_b13 = 1.f;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int shgeqz_(char *job, char *compq, char *compz, integer *n,
+ integer *ilo, integer *ihi, real *h__, integer *ldh, real *t, integer
+ *ldt, real *alphar, real *alphai, real *beta, real *q, integer *ldq,
+ real *z__, integer *ldz, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, q_dim1, q_offset, t_dim1, t_offset, z_dim1,
+ z_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real c__;
+ integer j;
+ real s, v[3], s1, s2, t1, u1, u2, a11, a12, a21, a22, b11, b22, c12, c21;
+ integer jc;
+ real an, bn, cl, cq, cr;
+ integer in;
+ real u12, w11, w12, w21;
+ integer jr;
+ real cz, w22, sl, wi, sr, vs, wr, b1a, b2a, a1i, a2i, b1i, b2i, a1r, a2r,
+ b1r, b2r, wr2, ad11, ad12, ad21, ad22, c11i, c22i;
+ integer jch;
+ real c11r, c22r;
+ logical ilq;
+ real u12l, tau, sqi;
+ logical ilz;
+ real ulp, sqr, szi, szr, ad11l, ad12l, ad21l, ad22l, ad32l, wabs, atol,
+ btol, temp;
+ extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
+ integer *, real *, real *), slag2_(real *, integer *, real *,
+ integer *, real *, real *, real *, real *, real *, real *);
+ real temp2, s1inv, scale;
+ extern logical lsame_(char *, char *);
+ integer iiter, ilast, jiter;
+ real anorm, bnorm;
+ integer maxit;
+ real tempi, tempr;
+ logical ilazr2;
+ extern doublereal slapy2_(real *, real *), slapy3_(real *, real *, real *)
+ ;
+ extern /* Subroutine */ int slasv2_(real *, real *, real *, real *, real *
+, real *, real *, real *, real *);
+ real ascale, bscale;
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
+ real *);
+ real safmax;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real eshift;
+ logical ilschr;
+ integer icompq, ilastm;
+ extern doublereal slanhs_(char *, integer *, real *, integer *, real *);
+ extern /* Subroutine */ int slartg_(real *, real *, real *, real *, real *
+);
+ integer ischur;
+ extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *);
+ logical ilazro;
+ integer icompz, ifirst, ifrstm, istart;
+ logical ilpivt, lquery;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/* -- April 2009 -- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SHGEQZ computes the eigenvalues of a real matrix pair (H,T), */
+/* where H is an upper Hessenberg matrix and T is upper triangular, */
+/* using the double-shift QZ method. */
+/* Matrix pairs of this type are produced by the reduction to */
+/* generalized upper Hessenberg form of a real matrix pair (A,B): */
+
+/* A = Q1*H*Z1**T, B = Q1*T*Z1**T, */
+
+/* as computed by SGGHRD. */
+
+/* If JOB='S', then the Hessenberg-triangular pair (H,T) is */
+/* also reduced to generalized Schur form, */
+
+/* H = Q*S*Z**T, T = Q*P*Z**T, */
+
+/* where Q and Z are orthogonal matrices, P is an upper triangular */
+/* matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2 */
+/* diagonal blocks. */
+
+/* The 1-by-1 blocks correspond to real eigenvalues of the matrix pair */
+/* (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of */
+/* eigenvalues. */
+
+/* Additionally, the 2-by-2 upper triangular diagonal blocks of P */
+/* corresponding to 2-by-2 blocks of S are reduced to positive diagonal */
+/* form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0, */
+/* P(j,j) > 0, and P(j+1,j+1) > 0. */
+
+/* Optionally, the orthogonal matrix Q from the generalized Schur */
+/* factorization may be postmultiplied into an input matrix Q1, and the */
+/* orthogonal matrix Z may be postmultiplied into an input matrix Z1. */
+/* If Q1 and Z1 are the orthogonal matrices from SGGHRD that reduced */
+/* the matrix pair (A,B) to generalized upper Hessenberg form, then the */
+/* output matrices Q1*Q and Z1*Z are the orthogonal factors from the */
+/* generalized Schur factorization of (A,B): */
+
+/* A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T. */
+
+/* To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently, */
+/* of (A,B)) are computed as a pair of values (alpha,beta), where alpha is */
+/* complex and beta real. */
+/* If beta is nonzero, lambda = alpha / beta is an eigenvalue of the */
+/* generalized nonsymmetric eigenvalue problem (GNEP) */
+/* A*x = lambda*B*x */
+/* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the */
+/* alternate form of the GNEP */
+/* mu*A*y = B*y. */
+/* Real eigenvalues can be read directly from the generalized Schur */
+/* form: */
+/* alpha = S(i,i), beta = P(i,i). */
+
+/* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix */
+/* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), */
+/* pp. 241--256. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* = 'E': Compute eigenvalues only; */
+/* = 'S': Compute eigenvalues and the Schur form. */
+
+/* COMPQ (input) CHARACTER*1 */
+/* = 'N': Left Schur vectors (Q) are not computed; */
+/* = 'I': Q is initialized to the unit matrix and the matrix Q */
+/* of left Schur vectors of (H,T) is returned; */
+/* = 'V': Q must contain an orthogonal matrix Q1 on entry and */
+/* the product Q1*Q is returned. */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': Right Schur vectors (Z) are not computed; */
+/* = 'I': Z is initialized to the unit matrix and the matrix Z */
+/* of right Schur vectors of (H,T) is returned; */
+/* = 'V': Z must contain an orthogonal matrix Z1 on entry and */
+/* the product Z1*Z is returned. */
+
+/* N (input) INTEGER */
+/* The order of the matrices H, T, Q, and Z. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* ILO and IHI mark the rows and columns of H which are in */
+/* Hessenberg form. It is assumed that A is already upper */
+/* triangular in rows and columns 1:ILO-1 and IHI+1:N. */
+/* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. */
+
+/* H (input/output) REAL array, dimension (LDH, N) */
+/* On entry, the N-by-N upper Hessenberg matrix H. */
+/* On exit, if JOB = 'S', H contains the upper quasi-triangular */
+/* matrix S from the generalized Schur factorization; */
+/* 2-by-2 diagonal blocks (corresponding to complex conjugate */
+/* pairs of eigenvalues) are returned in standard form, with */
+/* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. */
+/* If JOB = 'E', the diagonal blocks of H match those of S, but */
+/* the rest of H is unspecified. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH >= max( 1, N ). */
+
+/* T (input/output) REAL array, dimension (LDT, N) */
+/* On entry, the N-by-N upper triangular matrix T. */
+/* On exit, if JOB = 'S', T contains the upper triangular */
+/* matrix P from the generalized Schur factorization; */
+/* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S */
+/* are reduced to positive diagonal form, i.e., if H(j+1,j) is */
+/* non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and */
+/* T(j+1,j+1) > 0. */
+/* If JOB = 'E', the diagonal blocks of T match those of P, but */
+/* the rest of T is unspecified. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= max( 1, N ). */
+
+/* ALPHAR (output) REAL array, dimension (N) */
+/* The real parts of each scalar alpha defining an eigenvalue */
+/* of GNEP. */
+
+/* ALPHAI (output) REAL array, dimension (N) */
+/* The imaginary parts of each scalar alpha defining an */
+/* eigenvalue of GNEP. */
+/* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */
+/* positive, then the j-th and (j+1)-st eigenvalues are a */
+/* complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j). */
+
+/* BETA (output) REAL array, dimension (N) */
+/* The scalars beta that define the eigenvalues of GNEP. */
+/* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and */
+/* beta = BETA(j) represent the j-th eigenvalue of the matrix */
+/* pair (A,B), in one of the forms lambda = alpha/beta or */
+/* mu = beta/alpha. Since either lambda or mu may overflow, */
+/* they should not, in general, be computed. */
+
+/* Q (input/output) REAL array, dimension (LDQ, N) */
+/* On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in */
+/* the reduction of (A,B) to generalized Hessenberg form. */
+/* On exit, if COMPZ = 'I', the orthogonal matrix of left Schur */
+/* vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix */
+/* of left Schur vectors of (A,B). */
+/* Not referenced if COMPZ = 'N'. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= 1. */
+/* If COMPQ='V' or 'I', then LDQ >= N. */
+
+/* Z (input/output) REAL array, dimension (LDZ, N) */
+/* On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in */
+/* the reduction of (A,B) to generalized Hessenberg form. */
+/* On exit, if COMPZ = 'I', the orthogonal matrix of */
+/* right Schur vectors of (H,T), and if COMPZ = 'V', the */
+/* orthogonal matrix of right Schur vectors of (A,B). */
+/* Not referenced if COMPZ = 'N'. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1. */
+/* If COMPZ='V' or 'I', then LDZ >= N. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* = 1,...,N: the QZ iteration did not converge. (H,T) is not */
+/* in Schur form, but ALPHAR(i), ALPHAI(i), and */
+/* BETA(i), i=INFO+1,...,N should be correct. */
+/* = N+1,...,2*N: the shift calculation failed. (H,T) is not */
+/* in Schur form, but ALPHAR(i), ALPHAI(i), and */
+/* BETA(i), i=INFO-N+1,...,N should be correct. */
+
+/* Further Details */
+/* =============== */
+
+/* Iteration counters: */
+
+/* JITER -- counts iterations. */
+/* IITER -- counts iterations run since ILAST was last */
+/* changed. This is therefore reset only when a 1-by-1 or */
+/* 2-by-2 block deflates off the bottom. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* $ SAFETY = 1.0E+0 ) */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode JOB, COMPQ, COMPZ */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ if (lsame_(job, "E")) {
+ ilschr = FALSE_;
+ ischur = 1;
+ } else if (lsame_(job, "S")) {
+ ilschr = TRUE_;
+ ischur = 2;
+ } else {
+ ischur = 0;
+ }
+
+ if (lsame_(compq, "N")) {
+ ilq = FALSE_;
+ icompq = 1;
+ } else if (lsame_(compq, "V")) {
+ ilq = TRUE_;
+ icompq = 2;
+ } else if (lsame_(compq, "I")) {
+ ilq = TRUE_;
+ icompq = 3;
+ } else {
+ icompq = 0;
+ }
+
+ if (lsame_(compz, "N")) {
+ ilz = FALSE_;
+ icompz = 1;
+ } else if (lsame_(compz, "V")) {
+ ilz = TRUE_;
+ icompz = 2;
+ } else if (lsame_(compz, "I")) {
+ ilz = TRUE_;
+ icompz = 3;
+ } else {
+ icompz = 0;
+ }
+
+/* Check Argument Values */
+
+ *info = 0;
+ work[1] = (real) max(1,*n);
+ lquery = *lwork == -1;
+ if (ischur == 0) {
+ *info = -1;
+ } else if (icompq == 0) {
+ *info = -2;
+ } else if (icompz == 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ilo < 1) {
+ *info = -5;
+ } else if (*ihi > *n || *ihi < *ilo - 1) {
+ *info = -6;
+ } else if (*ldh < *n) {
+ *info = -8;
+ } else if (*ldt < *n) {
+ *info = -10;
+ } else if (*ldq < 1 || ilq && *ldq < *n) {
+ *info = -15;
+ } else if (*ldz < 1 || ilz && *ldz < *n) {
+ *info = -17;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -19;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SHGEQZ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ work[1] = 1.f;
+ return 0;
+ }
+
+/* Initialize Q and Z */
+
+ if (icompq == 3) {
+ slaset_("Full", n, n, &c_b12, &c_b13, &q[q_offset], ldq);
+ }
+ if (icompz == 3) {
+ slaset_("Full", n, n, &c_b12, &c_b13, &z__[z_offset], ldz);
+ }
+
+/* Machine Constants */
+
+ in = *ihi + 1 - *ilo;
+ safmin = slamch_("S");
+ safmax = 1.f / safmin;
+ ulp = slamch_("E") * slamch_("B");
+ anorm = slanhs_("F", &in, &h__[*ilo + *ilo * h_dim1], ldh, &work[1]);
+ bnorm = slanhs_("F", &in, &t[*ilo + *ilo * t_dim1], ldt, &work[1]);
+/* Computing MAX */
+ r__1 = safmin, r__2 = ulp * anorm;
+ atol = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = safmin, r__2 = ulp * bnorm;
+ btol = dmax(r__1,r__2);
+ ascale = 1.f / dmax(safmin,anorm);
+ bscale = 1.f / dmax(safmin,bnorm);
+
+/* Set Eigenvalues IHI+1:N */
+
+ i__1 = *n;
+ for (j = *ihi + 1; j <= i__1; ++j) {
+ if (t[j + j * t_dim1] < 0.f) {
+ if (ilschr) {
+ i__2 = j;
+ for (jr = 1; jr <= i__2; ++jr) {
+ h__[jr + j * h_dim1] = -h__[jr + j * h_dim1];
+ t[jr + j * t_dim1] = -t[jr + j * t_dim1];
+/* L10: */
+ }
+ } else {
+ h__[j + j * h_dim1] = -h__[j + j * h_dim1];
+ t[j + j * t_dim1] = -t[j + j * t_dim1];
+ }
+ if (ilz) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ z__[jr + j * z_dim1] = -z__[jr + j * z_dim1];
+/* L20: */
+ }
+ }
+ }
+ alphar[j] = h__[j + j * h_dim1];
+ alphai[j] = 0.f;
+ beta[j] = t[j + j * t_dim1];
+/* L30: */
+ }
+
+/* If IHI < ILO, skip QZ steps */
+
+ if (*ihi < *ilo) {
+ goto L380;
+ }
+
+/* MAIN QZ ITERATION LOOP */
+
+/* Initialize dynamic indices */
+
+/* Eigenvalues ILAST+1:N have been found. */
+/* Column operations modify rows IFRSTM:whatever. */
+/* Row operations modify columns whatever:ILASTM. */
+
+/* If only eigenvalues are being computed, then */
+/* IFRSTM is the row of the last splitting row above row ILAST; */
+/* this is always at least ILO. */
+/* IITER counts iterations since the last eigenvalue was found, */
+/* to tell when to use an extraordinary shift. */
+/* MAXIT is the maximum number of QZ sweeps allowed. */
+
+ ilast = *ihi;
+ if (ilschr) {
+ ifrstm = 1;
+ ilastm = *n;
+ } else {
+ ifrstm = *ilo;
+ ilastm = *ihi;
+ }
+ iiter = 0;
+ eshift = 0.f;
+ maxit = (*ihi - *ilo + 1) * 30;
+
+ i__1 = maxit;
+ for (jiter = 1; jiter <= i__1; ++jiter) {
+
+/* Split the matrix if possible. */
+
+/* Two tests: */
+/* 1: H(j,j-1)=0 or j=ILO */
+/* 2: T(j,j)=0 */
+
+ if (ilast == *ilo) {
+
+/* Special case: j=ILAST */
+
+ goto L80;
+ } else {
+ if ((r__1 = h__[ilast + (ilast - 1) * h_dim1], dabs(r__1)) <=
+ atol) {
+ h__[ilast + (ilast - 1) * h_dim1] = 0.f;
+ goto L80;
+ }
+ }
+
+ if ((r__1 = t[ilast + ilast * t_dim1], dabs(r__1)) <= btol) {
+ t[ilast + ilast * t_dim1] = 0.f;
+ goto L70;
+ }
+
+/* General case: j<ILAST */
+
+ i__2 = *ilo;
+ for (j = ilast - 1; j >= i__2; --j) {
+
+/* Test 1: for H(j,j-1)=0 or j=ILO */
+
+ if (j == *ilo) {
+ ilazro = TRUE_;
+ } else {
+ if ((r__1 = h__[j + (j - 1) * h_dim1], dabs(r__1)) <= atol) {
+ h__[j + (j - 1) * h_dim1] = 0.f;
+ ilazro = TRUE_;
+ } else {
+ ilazro = FALSE_;
+ }
+ }
+
+/* Test 2: for T(j,j)=0 */
+
+ if ((r__1 = t[j + j * t_dim1], dabs(r__1)) < btol) {
+ t[j + j * t_dim1] = 0.f;
+
+/* Test 1a: Check for 2 consecutive small subdiagonals in A */
+
+ ilazr2 = FALSE_;
+ if (! ilazro) {
+ temp = (r__1 = h__[j + (j - 1) * h_dim1], dabs(r__1));
+ temp2 = (r__1 = h__[j + j * h_dim1], dabs(r__1));
+ tempr = dmax(temp,temp2);
+ if (tempr < 1.f && tempr != 0.f) {
+ temp /= tempr;
+ temp2 /= tempr;
+ }
+ if (temp * (ascale * (r__1 = h__[j + 1 + j * h_dim1],
+ dabs(r__1))) <= temp2 * (ascale * atol)) {
+ ilazr2 = TRUE_;
+ }
+ }
+
+/* If both tests pass (1 & 2), i.e., the leading diagonal */
+/* element of B in the block is zero, split a 1x1 block off */
+/* at the top. (I.e., at the J-th row/column) The leading */
+/* diagonal element of the remainder can also be zero, so */
+/* this may have to be done repeatedly. */
+
+ if (ilazro || ilazr2) {
+ i__3 = ilast - 1;
+ for (jch = j; jch <= i__3; ++jch) {
+ temp = h__[jch + jch * h_dim1];
+ slartg_(&temp, &h__[jch + 1 + jch * h_dim1], &c__, &s,
+ &h__[jch + jch * h_dim1]);
+ h__[jch + 1 + jch * h_dim1] = 0.f;
+ i__4 = ilastm - jch;
+ srot_(&i__4, &h__[jch + (jch + 1) * h_dim1], ldh, &
+ h__[jch + 1 + (jch + 1) * h_dim1], ldh, &c__,
+ &s);
+ i__4 = ilastm - jch;
+ srot_(&i__4, &t[jch + (jch + 1) * t_dim1], ldt, &t[
+ jch + 1 + (jch + 1) * t_dim1], ldt, &c__, &s);
+ if (ilq) {
+ srot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1)
+ * q_dim1 + 1], &c__1, &c__, &s);
+ }
+ if (ilazr2) {
+ h__[jch + (jch - 1) * h_dim1] *= c__;
+ }
+ ilazr2 = FALSE_;
+ if ((r__1 = t[jch + 1 + (jch + 1) * t_dim1], dabs(
+ r__1)) >= btol) {
+ if (jch + 1 >= ilast) {
+ goto L80;
+ } else {
+ ifirst = jch + 1;
+ goto L110;
+ }
+ }
+ t[jch + 1 + (jch + 1) * t_dim1] = 0.f;
+/* L40: */
+ }
+ goto L70;
+ } else {
+
+/* Only test 2 passed -- chase the zero to T(ILAST,ILAST) */
+/* Then process as in the case T(ILAST,ILAST)=0 */
+
+ i__3 = ilast - 1;
+ for (jch = j; jch <= i__3; ++jch) {
+ temp = t[jch + (jch + 1) * t_dim1];
+ slartg_(&temp, &t[jch + 1 + (jch + 1) * t_dim1], &c__,
+ &s, &t[jch + (jch + 1) * t_dim1]);
+ t[jch + 1 + (jch + 1) * t_dim1] = 0.f;
+ if (jch < ilastm - 1) {
+ i__4 = ilastm - jch - 1;
+ srot_(&i__4, &t[jch + (jch + 2) * t_dim1], ldt, &
+ t[jch + 1 + (jch + 2) * t_dim1], ldt, &
+ c__, &s);
+ }
+ i__4 = ilastm - jch + 2;
+ srot_(&i__4, &h__[jch + (jch - 1) * h_dim1], ldh, &
+ h__[jch + 1 + (jch - 1) * h_dim1], ldh, &c__,
+ &s);
+ if (ilq) {
+ srot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1)
+ * q_dim1 + 1], &c__1, &c__, &s);
+ }
+ temp = h__[jch + 1 + jch * h_dim1];
+ slartg_(&temp, &h__[jch + 1 + (jch - 1) * h_dim1], &
+ c__, &s, &h__[jch + 1 + jch * h_dim1]);
+ h__[jch + 1 + (jch - 1) * h_dim1] = 0.f;
+ i__4 = jch + 1 - ifrstm;
+ srot_(&i__4, &h__[ifrstm + jch * h_dim1], &c__1, &h__[
+ ifrstm + (jch - 1) * h_dim1], &c__1, &c__, &s)
+ ;
+ i__4 = jch - ifrstm;
+ srot_(&i__4, &t[ifrstm + jch * t_dim1], &c__1, &t[
+ ifrstm + (jch - 1) * t_dim1], &c__1, &c__, &s)
+ ;
+ if (ilz) {
+ srot_(n, &z__[jch * z_dim1 + 1], &c__1, &z__[(jch
+ - 1) * z_dim1 + 1], &c__1, &c__, &s);
+ }
+/* L50: */
+ }
+ goto L70;
+ }
+ } else if (ilazro) {
+
+/* Only test 1 passed -- work on J:ILAST */
+
+ ifirst = j;
+ goto L110;
+ }
+
+/* Neither test passed -- try next J */
+
+/* L60: */
+ }
+
+/* (Drop-through is "impossible") */
+
+ *info = *n + 1;
+ goto L420;
+
+/* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a */
+/* 1x1 block. */
+
+L70:
+ temp = h__[ilast + ilast * h_dim1];
+ slartg_(&temp, &h__[ilast + (ilast - 1) * h_dim1], &c__, &s, &h__[
+ ilast + ilast * h_dim1]);
+ h__[ilast + (ilast - 1) * h_dim1] = 0.f;
+ i__2 = ilast - ifrstm;
+ srot_(&i__2, &h__[ifrstm + ilast * h_dim1], &c__1, &h__[ifrstm + (
+ ilast - 1) * h_dim1], &c__1, &c__, &s);
+ i__2 = ilast - ifrstm;
+ srot_(&i__2, &t[ifrstm + ilast * t_dim1], &c__1, &t[ifrstm + (ilast -
+ 1) * t_dim1], &c__1, &c__, &s);
+ if (ilz) {
+ srot_(n, &z__[ilast * z_dim1 + 1], &c__1, &z__[(ilast - 1) *
+ z_dim1 + 1], &c__1, &c__, &s);
+ }
+
+/* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI, */
+/* and BETA */
+
+L80:
+ if (t[ilast + ilast * t_dim1] < 0.f) {
+ if (ilschr) {
+ i__2 = ilast;
+ for (j = ifrstm; j <= i__2; ++j) {
+ h__[j + ilast * h_dim1] = -h__[j + ilast * h_dim1];
+ t[j + ilast * t_dim1] = -t[j + ilast * t_dim1];
+/* L90: */
+ }
+ } else {
+ h__[ilast + ilast * h_dim1] = -h__[ilast + ilast * h_dim1];
+ t[ilast + ilast * t_dim1] = -t[ilast + ilast * t_dim1];
+ }
+ if (ilz) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ z__[j + ilast * z_dim1] = -z__[j + ilast * z_dim1];
+/* L100: */
+ }
+ }
+ }
+ alphar[ilast] = h__[ilast + ilast * h_dim1];
+ alphai[ilast] = 0.f;
+ beta[ilast] = t[ilast + ilast * t_dim1];
+
+/* Go to next block -- exit if finished. */
+
+ --ilast;
+ if (ilast < *ilo) {
+ goto L380;
+ }
+
+/* Reset counters */
+
+ iiter = 0;
+ eshift = 0.f;
+ if (! ilschr) {
+ ilastm = ilast;
+ if (ifrstm > ilast) {
+ ifrstm = *ilo;
+ }
+ }
+ goto L350;
+
+/* QZ step */
+
+/* This iteration only involves rows/columns IFIRST:ILAST. We */
+/* assume IFIRST < ILAST, and that the diagonal of B is non-zero. */
+
+L110:
+ ++iiter;
+ if (! ilschr) {
+ ifrstm = ifirst;
+ }
+
+/* Compute single shifts. */
+
+/* At this point, IFIRST < ILAST, and the diagonal elements of */
+/* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in */
+/* magnitude) */
+
+ if (iiter / 10 * 10 == iiter) {
+
+/* Exceptional shift. Chosen for no particularly good reason. */
+/* (Single shift only.) */
+
+ if ((real) maxit * safmin * (r__1 = h__[ilast - 1 + ilast *
+ h_dim1], dabs(r__1)) < (r__2 = t[ilast - 1 + (ilast - 1) *
+ t_dim1], dabs(r__2))) {
+ eshift += h__[ilast - 1 + ilast * h_dim1] / t[ilast - 1 + (
+ ilast - 1) * t_dim1];
+ } else {
+ eshift += 1.f / (safmin * (real) maxit);
+ }
+ s1 = 1.f;
+ wr = eshift;
+
+ } else {
+
+/* Shifts based on the generalized eigenvalues of the */
+/* bottom-right 2x2 block of A and B. The first eigenvalue */
+/* returned by SLAG2 is the Wilkinson shift (AEP p.512), */
+
+ r__1 = safmin * 100.f;
+ slag2_(&h__[ilast - 1 + (ilast - 1) * h_dim1], ldh, &t[ilast - 1
+ + (ilast - 1) * t_dim1], ldt, &r__1, &s1, &s2, &wr, &wr2,
+ &wi);
+
+/* Computing MAX */
+/* Computing MAX */
+ r__3 = 1.f, r__4 = dabs(wr), r__3 = max(r__3,r__4), r__4 = dabs(
+ wi);
+ r__1 = s1, r__2 = safmin * dmax(r__3,r__4);
+ temp = dmax(r__1,r__2);
+ if (wi != 0.f) {
+ goto L200;
+ }
+ }
+
+/* Fiddle with shift to avoid overflow */
+
+ temp = dmin(ascale,1.f) * (safmax * .5f);
+ if (s1 > temp) {
+ scale = temp / s1;
+ } else {
+ scale = 1.f;
+ }
+
+ temp = dmin(bscale,1.f) * (safmax * .5f);
+ if (dabs(wr) > temp) {
+/* Computing MIN */
+ r__1 = scale, r__2 = temp / dabs(wr);
+ scale = dmin(r__1,r__2);
+ }
+ s1 = scale * s1;
+ wr = scale * wr;
+
+/* Now check for two consecutive small subdiagonals. */
+
+ i__2 = ifirst + 1;
+ for (j = ilast - 1; j >= i__2; --j) {
+ istart = j;
+ temp = (r__1 = s1 * h__[j + (j - 1) * h_dim1], dabs(r__1));
+ temp2 = (r__1 = s1 * h__[j + j * h_dim1] - wr * t[j + j * t_dim1],
+ dabs(r__1));
+ tempr = dmax(temp,temp2);
+ if (tempr < 1.f && tempr != 0.f) {
+ temp /= tempr;
+ temp2 /= tempr;
+ }
+ if ((r__1 = ascale * h__[j + 1 + j * h_dim1] * temp, dabs(r__1))
+ <= ascale * atol * temp2) {
+ goto L130;
+ }
+/* L120: */
+ }
+
+ istart = ifirst;
+L130:
+
+/* Do an implicit single-shift QZ sweep. */
+
+/* Initial Q */
+
+ temp = s1 * h__[istart + istart * h_dim1] - wr * t[istart + istart *
+ t_dim1];
+ temp2 = s1 * h__[istart + 1 + istart * h_dim1];
+ slartg_(&temp, &temp2, &c__, &s, &tempr);
+
+/* Sweep */
+
+ i__2 = ilast - 1;
+ for (j = istart; j <= i__2; ++j) {
+ if (j > istart) {
+ temp = h__[j + (j - 1) * h_dim1];
+ slartg_(&temp, &h__[j + 1 + (j - 1) * h_dim1], &c__, &s, &h__[
+ j + (j - 1) * h_dim1]);
+ h__[j + 1 + (j - 1) * h_dim1] = 0.f;
+ }
+
+ i__3 = ilastm;
+ for (jc = j; jc <= i__3; ++jc) {
+ temp = c__ * h__[j + jc * h_dim1] + s * h__[j + 1 + jc *
+ h_dim1];
+ h__[j + 1 + jc * h_dim1] = -s * h__[j + jc * h_dim1] + c__ *
+ h__[j + 1 + jc * h_dim1];
+ h__[j + jc * h_dim1] = temp;
+ temp2 = c__ * t[j + jc * t_dim1] + s * t[j + 1 + jc * t_dim1];
+ t[j + 1 + jc * t_dim1] = -s * t[j + jc * t_dim1] + c__ * t[j
+ + 1 + jc * t_dim1];
+ t[j + jc * t_dim1] = temp2;
+/* L140: */
+ }
+ if (ilq) {
+ i__3 = *n;
+ for (jr = 1; jr <= i__3; ++jr) {
+ temp = c__ * q[jr + j * q_dim1] + s * q[jr + (j + 1) *
+ q_dim1];
+ q[jr + (j + 1) * q_dim1] = -s * q[jr + j * q_dim1] + c__ *
+ q[jr + (j + 1) * q_dim1];
+ q[jr + j * q_dim1] = temp;
+/* L150: */
+ }
+ }
+
+ temp = t[j + 1 + (j + 1) * t_dim1];
+ slartg_(&temp, &t[j + 1 + j * t_dim1], &c__, &s, &t[j + 1 + (j +
+ 1) * t_dim1]);
+ t[j + 1 + j * t_dim1] = 0.f;
+
+/* Computing MIN */
+ i__4 = j + 2;
+ i__3 = min(i__4,ilast);
+ for (jr = ifrstm; jr <= i__3; ++jr) {
+ temp = c__ * h__[jr + (j + 1) * h_dim1] + s * h__[jr + j *
+ h_dim1];
+ h__[jr + j * h_dim1] = -s * h__[jr + (j + 1) * h_dim1] + c__ *
+ h__[jr + j * h_dim1];
+ h__[jr + (j + 1) * h_dim1] = temp;
+/* L160: */
+ }
+ i__3 = j;
+ for (jr = ifrstm; jr <= i__3; ++jr) {
+ temp = c__ * t[jr + (j + 1) * t_dim1] + s * t[jr + j * t_dim1]
+ ;
+ t[jr + j * t_dim1] = -s * t[jr + (j + 1) * t_dim1] + c__ * t[
+ jr + j * t_dim1];
+ t[jr + (j + 1) * t_dim1] = temp;
+/* L170: */
+ }
+ if (ilz) {
+ i__3 = *n;
+ for (jr = 1; jr <= i__3; ++jr) {
+ temp = c__ * z__[jr + (j + 1) * z_dim1] + s * z__[jr + j *
+ z_dim1];
+ z__[jr + j * z_dim1] = -s * z__[jr + (j + 1) * z_dim1] +
+ c__ * z__[jr + j * z_dim1];
+ z__[jr + (j + 1) * z_dim1] = temp;
+/* L180: */
+ }
+ }
+/* L190: */
+ }
+
+ goto L350;
+
+/* Use Francis double-shift */
+
+/* Note: the Francis double-shift should work with real shifts, */
+/* but only if the block is at least 3x3. */
+/* This code may break if this point is reached with */
+/* a 2x2 block with real eigenvalues. */
+
+L200:
+ if (ifirst + 1 == ilast) {
+
+/* Special case -- 2x2 block with complex eigenvectors */
+
+/* Step 1: Standardize, that is, rotate so that */
+
+/* ( B11 0 ) */
+/* B = ( ) with B11 non-negative. */
+/* ( 0 B22 ) */
+
+ slasv2_(&t[ilast - 1 + (ilast - 1) * t_dim1], &t[ilast - 1 +
+ ilast * t_dim1], &t[ilast + ilast * t_dim1], &b22, &b11, &
+ sr, &cr, &sl, &cl);
+
+ if (b11 < 0.f) {
+ cr = -cr;
+ sr = -sr;
+ b11 = -b11;
+ b22 = -b22;
+ }
+
+ i__2 = ilastm + 1 - ifirst;
+ srot_(&i__2, &h__[ilast - 1 + (ilast - 1) * h_dim1], ldh, &h__[
+ ilast + (ilast - 1) * h_dim1], ldh, &cl, &sl);
+ i__2 = ilast + 1 - ifrstm;
+ srot_(&i__2, &h__[ifrstm + (ilast - 1) * h_dim1], &c__1, &h__[
+ ifrstm + ilast * h_dim1], &c__1, &cr, &sr);
+
+ if (ilast < ilastm) {
+ i__2 = ilastm - ilast;
+ srot_(&i__2, &t[ilast - 1 + (ilast + 1) * t_dim1], ldt, &t[
+ ilast + (ilast + 1) * t_dim1], ldt, &cl, &sl);
+ }
+ if (ifrstm < ilast - 1) {
+ i__2 = ifirst - ifrstm;
+ srot_(&i__2, &t[ifrstm + (ilast - 1) * t_dim1], &c__1, &t[
+ ifrstm + ilast * t_dim1], &c__1, &cr, &sr);
+ }
+
+ if (ilq) {
+ srot_(n, &q[(ilast - 1) * q_dim1 + 1], &c__1, &q[ilast *
+ q_dim1 + 1], &c__1, &cl, &sl);
+ }
+ if (ilz) {
+ srot_(n, &z__[(ilast - 1) * z_dim1 + 1], &c__1, &z__[ilast *
+ z_dim1 + 1], &c__1, &cr, &sr);
+ }
+
+ t[ilast - 1 + (ilast - 1) * t_dim1] = b11;
+ t[ilast - 1 + ilast * t_dim1] = 0.f;
+ t[ilast + (ilast - 1) * t_dim1] = 0.f;
+ t[ilast + ilast * t_dim1] = b22;
+
+/* If B22 is negative, negate column ILAST */
+
+ if (b22 < 0.f) {
+ i__2 = ilast;
+ for (j = ifrstm; j <= i__2; ++j) {
+ h__[j + ilast * h_dim1] = -h__[j + ilast * h_dim1];
+ t[j + ilast * t_dim1] = -t[j + ilast * t_dim1];
+/* L210: */
+ }
+
+ if (ilz) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ z__[j + ilast * z_dim1] = -z__[j + ilast * z_dim1];
+/* L220: */
+ }
+ }
+ }
+
+/* Step 2: Compute ALPHAR, ALPHAI, and BETA (see refs.) */
+
+/* Recompute shift */
+
+ r__1 = safmin * 100.f;
+ slag2_(&h__[ilast - 1 + (ilast - 1) * h_dim1], ldh, &t[ilast - 1
+ + (ilast - 1) * t_dim1], ldt, &r__1, &s1, &temp, &wr, &
+ temp2, &wi);
+
+/* If standardization has perturbed the shift onto real line, */
+/* do another (real single-shift) QR step. */
+
+ if (wi == 0.f) {
+ goto L350;
+ }
+ s1inv = 1.f / s1;
+
+/* Do EISPACK (QZVAL) computation of alpha and beta */
+
+ a11 = h__[ilast - 1 + (ilast - 1) * h_dim1];
+ a21 = h__[ilast + (ilast - 1) * h_dim1];
+ a12 = h__[ilast - 1 + ilast * h_dim1];
+ a22 = h__[ilast + ilast * h_dim1];
+
+/* Compute complex Givens rotation on right */
+/* (Assume some element of C = (sA - wB) > unfl ) */
+/* __ */
+/* (sA - wB) ( CZ -SZ ) */
+/* ( SZ CZ ) */
+
+ c11r = s1 * a11 - wr * b11;
+ c11i = -wi * b11;
+ c12 = s1 * a12;
+ c21 = s1 * a21;
+ c22r = s1 * a22 - wr * b22;
+ c22i = -wi * b22;
+
+ if (dabs(c11r) + dabs(c11i) + dabs(c12) > dabs(c21) + dabs(c22r)
+ + dabs(c22i)) {
+ t1 = slapy3_(&c12, &c11r, &c11i);
+ cz = c12 / t1;
+ szr = -c11r / t1;
+ szi = -c11i / t1;
+ } else {
+ cz = slapy2_(&c22r, &c22i);
+ if (cz <= safmin) {
+ cz = 0.f;
+ szr = 1.f;
+ szi = 0.f;
+ } else {
+ tempr = c22r / cz;
+ tempi = c22i / cz;
+ t1 = slapy2_(&cz, &c21);
+ cz /= t1;
+ szr = -c21 * tempr / t1;
+ szi = c21 * tempi / t1;
+ }
+ }
+
+/* Compute Givens rotation on left */
+
+/* ( CQ SQ ) */
+/* ( __ ) A or B */
+/* ( -SQ CQ ) */
+
+ an = dabs(a11) + dabs(a12) + dabs(a21) + dabs(a22);
+ bn = dabs(b11) + dabs(b22);
+ wabs = dabs(wr) + dabs(wi);
+ if (s1 * an > wabs * bn) {
+ cq = cz * b11;
+ sqr = szr * b22;
+ sqi = -szi * b22;
+ } else {
+ a1r = cz * a11 + szr * a12;
+ a1i = szi * a12;
+ a2r = cz * a21 + szr * a22;
+ a2i = szi * a22;
+ cq = slapy2_(&a1r, &a1i);
+ if (cq <= safmin) {
+ cq = 0.f;
+ sqr = 1.f;
+ sqi = 0.f;
+ } else {
+ tempr = a1r / cq;
+ tempi = a1i / cq;
+ sqr = tempr * a2r + tempi * a2i;
+ sqi = tempi * a2r - tempr * a2i;
+ }
+ }
+ t1 = slapy3_(&cq, &sqr, &sqi);
+ cq /= t1;
+ sqr /= t1;
+ sqi /= t1;
+
+/* Compute diagonal elements of QBZ */
+
+ tempr = sqr * szr - sqi * szi;
+ tempi = sqr * szi + sqi * szr;
+ b1r = cq * cz * b11 + tempr * b22;
+ b1i = tempi * b22;
+ b1a = slapy2_(&b1r, &b1i);
+ b2r = cq * cz * b22 + tempr * b11;
+ b2i = -tempi * b11;
+ b2a = slapy2_(&b2r, &b2i);
+
+/* Normalize so beta > 0, and Im( alpha1 ) > 0 */
+
+ beta[ilast - 1] = b1a;
+ beta[ilast] = b2a;
+ alphar[ilast - 1] = wr * b1a * s1inv;
+ alphai[ilast - 1] = wi * b1a * s1inv;
+ alphar[ilast] = wr * b2a * s1inv;
+ alphai[ilast] = -(wi * b2a) * s1inv;
+
+/* Step 3: Go to next block -- exit if finished. */
+
+ ilast = ifirst - 1;
+ if (ilast < *ilo) {
+ goto L380;
+ }
+
+/* Reset counters */
+
+ iiter = 0;
+ eshift = 0.f;
+ if (! ilschr) {
+ ilastm = ilast;
+ if (ifrstm > ilast) {
+ ifrstm = *ilo;
+ }
+ }
+ goto L350;
+ } else {
+
+/* Usual case: 3x3 or larger block, using Francis implicit */
+/* double-shift */
+
+/* 2 */
+/* Eigenvalue equation is w - c w + d = 0, */
+
+/* -1 2 -1 */
+/* so compute 1st column of (A B ) - c A B + d */
+/* using the formula in QZIT (from EISPACK) */
+
+/* We assume that the block is at least 3x3 */
+
+ ad11 = ascale * h__[ilast - 1 + (ilast - 1) * h_dim1] / (bscale *
+ t[ilast - 1 + (ilast - 1) * t_dim1]);
+ ad21 = ascale * h__[ilast + (ilast - 1) * h_dim1] / (bscale * t[
+ ilast - 1 + (ilast - 1) * t_dim1]);
+ ad12 = ascale * h__[ilast - 1 + ilast * h_dim1] / (bscale * t[
+ ilast + ilast * t_dim1]);
+ ad22 = ascale * h__[ilast + ilast * h_dim1] / (bscale * t[ilast +
+ ilast * t_dim1]);
+ u12 = t[ilast - 1 + ilast * t_dim1] / t[ilast + ilast * t_dim1];
+ ad11l = ascale * h__[ifirst + ifirst * h_dim1] / (bscale * t[
+ ifirst + ifirst * t_dim1]);
+ ad21l = ascale * h__[ifirst + 1 + ifirst * h_dim1] / (bscale * t[
+ ifirst + ifirst * t_dim1]);
+ ad12l = ascale * h__[ifirst + (ifirst + 1) * h_dim1] / (bscale *
+ t[ifirst + 1 + (ifirst + 1) * t_dim1]);
+ ad22l = ascale * h__[ifirst + 1 + (ifirst + 1) * h_dim1] / (
+ bscale * t[ifirst + 1 + (ifirst + 1) * t_dim1]);
+ ad32l = ascale * h__[ifirst + 2 + (ifirst + 1) * h_dim1] / (
+ bscale * t[ifirst + 1 + (ifirst + 1) * t_dim1]);
+ u12l = t[ifirst + (ifirst + 1) * t_dim1] / t[ifirst + 1 + (ifirst
+ + 1) * t_dim1];
+
+ v[0] = (ad11 - ad11l) * (ad22 - ad11l) - ad12 * ad21 + ad21 * u12
+ * ad11l + (ad12l - ad11l * u12l) * ad21l;
+ v[1] = (ad22l - ad11l - ad21l * u12l - (ad11 - ad11l) - (ad22 -
+ ad11l) + ad21 * u12) * ad21l;
+ v[2] = ad32l * ad21l;
+
+ istart = ifirst;
+
+ slarfg_(&c__3, v, &v[1], &c__1, &tau);
+ v[0] = 1.f;
+
+/* Sweep */
+
+ i__2 = ilast - 2;
+ for (j = istart; j <= i__2; ++j) {
+
+/* All but last elements: use 3x3 Householder transforms. */
+
+/* Zero (j-1)st column of A */
+
+ if (j > istart) {
+ v[0] = h__[j + (j - 1) * h_dim1];
+ v[1] = h__[j + 1 + (j - 1) * h_dim1];
+ v[2] = h__[j + 2 + (j - 1) * h_dim1];
+
+ slarfg_(&c__3, &h__[j + (j - 1) * h_dim1], &v[1], &c__1, &
+ tau);
+ v[0] = 1.f;
+ h__[j + 1 + (j - 1) * h_dim1] = 0.f;
+ h__[j + 2 + (j - 1) * h_dim1] = 0.f;
+ }
+
+ i__3 = ilastm;
+ for (jc = j; jc <= i__3; ++jc) {
+ temp = tau * (h__[j + jc * h_dim1] + v[1] * h__[j + 1 +
+ jc * h_dim1] + v[2] * h__[j + 2 + jc * h_dim1]);
+ h__[j + jc * h_dim1] -= temp;
+ h__[j + 1 + jc * h_dim1] -= temp * v[1];
+ h__[j + 2 + jc * h_dim1] -= temp * v[2];
+ temp2 = tau * (t[j + jc * t_dim1] + v[1] * t[j + 1 + jc *
+ t_dim1] + v[2] * t[j + 2 + jc * t_dim1]);
+ t[j + jc * t_dim1] -= temp2;
+ t[j + 1 + jc * t_dim1] -= temp2 * v[1];
+ t[j + 2 + jc * t_dim1] -= temp2 * v[2];
+/* L230: */
+ }
+ if (ilq) {
+ i__3 = *n;
+ for (jr = 1; jr <= i__3; ++jr) {
+ temp = tau * (q[jr + j * q_dim1] + v[1] * q[jr + (j +
+ 1) * q_dim1] + v[2] * q[jr + (j + 2) * q_dim1]
+ );
+ q[jr + j * q_dim1] -= temp;
+ q[jr + (j + 1) * q_dim1] -= temp * v[1];
+ q[jr + (j + 2) * q_dim1] -= temp * v[2];
+/* L240: */
+ }
+ }
+
+/* Zero j-th column of B (see SLAGBC for details) */
+
+/* Swap rows to pivot */
+
+ ilpivt = FALSE_;
+/* Computing MAX */
+ r__3 = (r__1 = t[j + 1 + (j + 1) * t_dim1], dabs(r__1)), r__4
+ = (r__2 = t[j + 1 + (j + 2) * t_dim1], dabs(r__2));
+ temp = dmax(r__3,r__4);
+/* Computing MAX */
+ r__3 = (r__1 = t[j + 2 + (j + 1) * t_dim1], dabs(r__1)), r__4
+ = (r__2 = t[j + 2 + (j + 2) * t_dim1], dabs(r__2));
+ temp2 = dmax(r__3,r__4);
+ if (dmax(temp,temp2) < safmin) {
+ scale = 0.f;
+ u1 = 1.f;
+ u2 = 0.f;
+ goto L250;
+ } else if (temp >= temp2) {
+ w11 = t[j + 1 + (j + 1) * t_dim1];
+ w21 = t[j + 2 + (j + 1) * t_dim1];
+ w12 = t[j + 1 + (j + 2) * t_dim1];
+ w22 = t[j + 2 + (j + 2) * t_dim1];
+ u1 = t[j + 1 + j * t_dim1];
+ u2 = t[j + 2 + j * t_dim1];
+ } else {
+ w21 = t[j + 1 + (j + 1) * t_dim1];
+ w11 = t[j + 2 + (j + 1) * t_dim1];
+ w22 = t[j + 1 + (j + 2) * t_dim1];
+ w12 = t[j + 2 + (j + 2) * t_dim1];
+ u2 = t[j + 1 + j * t_dim1];
+ u1 = t[j + 2 + j * t_dim1];
+ }
+
+/* Swap columns if nec. */
+
+ if (dabs(w12) > dabs(w11)) {
+ ilpivt = TRUE_;
+ temp = w12;
+ temp2 = w22;
+ w12 = w11;
+ w22 = w21;
+ w11 = temp;
+ w21 = temp2;
+ }
+
+/* LU-factor */
+
+ temp = w21 / w11;
+ u2 -= temp * u1;
+ w22 -= temp * w12;
+ w21 = 0.f;
+
+/* Compute SCALE */
+
+ scale = 1.f;
+ if (dabs(w22) < safmin) {
+ scale = 0.f;
+ u2 = 1.f;
+ u1 = -w12 / w11;
+ goto L250;
+ }
+ if (dabs(w22) < dabs(u2)) {
+ scale = (r__1 = w22 / u2, dabs(r__1));
+ }
+ if (dabs(w11) < dabs(u1)) {
+/* Computing MIN */
+ r__2 = scale, r__3 = (r__1 = w11 / u1, dabs(r__1));
+ scale = dmin(r__2,r__3);
+ }
+
+/* Solve */
+
+ u2 = scale * u2 / w22;
+ u1 = (scale * u1 - w12 * u2) / w11;
+
+L250:
+ if (ilpivt) {
+ temp = u2;
+ u2 = u1;
+ u1 = temp;
+ }
+
+/* Compute Householder Vector */
+
+/* Computing 2nd power */
+ r__1 = scale;
+/* Computing 2nd power */
+ r__2 = u1;
+/* Computing 2nd power */
+ r__3 = u2;
+ t1 = sqrt(r__1 * r__1 + r__2 * r__2 + r__3 * r__3);
+ tau = scale / t1 + 1.f;
+ vs = -1.f / (scale + t1);
+ v[0] = 1.f;
+ v[1] = vs * u1;
+ v[2] = vs * u2;
+
+/* Apply transformations from the right. */
+
+/* Computing MIN */
+ i__4 = j + 3;
+ i__3 = min(i__4,ilast);
+ for (jr = ifrstm; jr <= i__3; ++jr) {
+ temp = tau * (h__[jr + j * h_dim1] + v[1] * h__[jr + (j +
+ 1) * h_dim1] + v[2] * h__[jr + (j + 2) * h_dim1]);
+ h__[jr + j * h_dim1] -= temp;
+ h__[jr + (j + 1) * h_dim1] -= temp * v[1];
+ h__[jr + (j + 2) * h_dim1] -= temp * v[2];
+/* L260: */
+ }
+ i__3 = j + 2;
+ for (jr = ifrstm; jr <= i__3; ++jr) {
+ temp = tau * (t[jr + j * t_dim1] + v[1] * t[jr + (j + 1) *
+ t_dim1] + v[2] * t[jr + (j + 2) * t_dim1]);
+ t[jr + j * t_dim1] -= temp;
+ t[jr + (j + 1) * t_dim1] -= temp * v[1];
+ t[jr + (j + 2) * t_dim1] -= temp * v[2];
+/* L270: */
+ }
+ if (ilz) {
+ i__3 = *n;
+ for (jr = 1; jr <= i__3; ++jr) {
+ temp = tau * (z__[jr + j * z_dim1] + v[1] * z__[jr + (
+ j + 1) * z_dim1] + v[2] * z__[jr + (j + 2) *
+ z_dim1]);
+ z__[jr + j * z_dim1] -= temp;
+ z__[jr + (j + 1) * z_dim1] -= temp * v[1];
+ z__[jr + (j + 2) * z_dim1] -= temp * v[2];
+/* L280: */
+ }
+ }
+ t[j + 1 + j * t_dim1] = 0.f;
+ t[j + 2 + j * t_dim1] = 0.f;
+/* L290: */
+ }
+
+/* Last elements: Use Givens rotations */
+
+/* Rotations from the left */
+
+ j = ilast - 1;
+ temp = h__[j + (j - 1) * h_dim1];
+ slartg_(&temp, &h__[j + 1 + (j - 1) * h_dim1], &c__, &s, &h__[j +
+ (j - 1) * h_dim1]);
+ h__[j + 1 + (j - 1) * h_dim1] = 0.f;
+
+ i__2 = ilastm;
+ for (jc = j; jc <= i__2; ++jc) {
+ temp = c__ * h__[j + jc * h_dim1] + s * h__[j + 1 + jc *
+ h_dim1];
+ h__[j + 1 + jc * h_dim1] = -s * h__[j + jc * h_dim1] + c__ *
+ h__[j + 1 + jc * h_dim1];
+ h__[j + jc * h_dim1] = temp;
+ temp2 = c__ * t[j + jc * t_dim1] + s * t[j + 1 + jc * t_dim1];
+ t[j + 1 + jc * t_dim1] = -s * t[j + jc * t_dim1] + c__ * t[j
+ + 1 + jc * t_dim1];
+ t[j + jc * t_dim1] = temp2;
+/* L300: */
+ }
+ if (ilq) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ temp = c__ * q[jr + j * q_dim1] + s * q[jr + (j + 1) *
+ q_dim1];
+ q[jr + (j + 1) * q_dim1] = -s * q[jr + j * q_dim1] + c__ *
+ q[jr + (j + 1) * q_dim1];
+ q[jr + j * q_dim1] = temp;
+/* L310: */
+ }
+ }
+
+/* Rotations from the right. */
+
+ temp = t[j + 1 + (j + 1) * t_dim1];
+ slartg_(&temp, &t[j + 1 + j * t_dim1], &c__, &s, &t[j + 1 + (j +
+ 1) * t_dim1]);
+ t[j + 1 + j * t_dim1] = 0.f;
+
+ i__2 = ilast;
+ for (jr = ifrstm; jr <= i__2; ++jr) {
+ temp = c__ * h__[jr + (j + 1) * h_dim1] + s * h__[jr + j *
+ h_dim1];
+ h__[jr + j * h_dim1] = -s * h__[jr + (j + 1) * h_dim1] + c__ *
+ h__[jr + j * h_dim1];
+ h__[jr + (j + 1) * h_dim1] = temp;
+/* L320: */
+ }
+ i__2 = ilast - 1;
+ for (jr = ifrstm; jr <= i__2; ++jr) {
+ temp = c__ * t[jr + (j + 1) * t_dim1] + s * t[jr + j * t_dim1]
+ ;
+ t[jr + j * t_dim1] = -s * t[jr + (j + 1) * t_dim1] + c__ * t[
+ jr + j * t_dim1];
+ t[jr + (j + 1) * t_dim1] = temp;
+/* L330: */
+ }
+ if (ilz) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ temp = c__ * z__[jr + (j + 1) * z_dim1] + s * z__[jr + j *
+ z_dim1];
+ z__[jr + j * z_dim1] = -s * z__[jr + (j + 1) * z_dim1] +
+ c__ * z__[jr + j * z_dim1];
+ z__[jr + (j + 1) * z_dim1] = temp;
+/* L340: */
+ }
+ }
+
+/* End of Double-Shift code */
+
+ }
+
+ goto L350;
+
+/* End of iteration loop */
+
+L350:
+/* L360: */
+ ;
+ }
+
+/* Drop-through = non-convergence */
+
+ *info = ilast;
+ goto L420;
+
+/* Successful completion of all QZ steps */
+
+L380:
+
+/* Set Eigenvalues 1:ILO-1 */
+
+ i__1 = *ilo - 1;
+ for (j = 1; j <= i__1; ++j) {
+ if (t[j + j * t_dim1] < 0.f) {
+ if (ilschr) {
+ i__2 = j;
+ for (jr = 1; jr <= i__2; ++jr) {
+ h__[jr + j * h_dim1] = -h__[jr + j * h_dim1];
+ t[jr + j * t_dim1] = -t[jr + j * t_dim1];
+/* L390: */
+ }
+ } else {
+ h__[j + j * h_dim1] = -h__[j + j * h_dim1];
+ t[j + j * t_dim1] = -t[j + j * t_dim1];
+ }
+ if (ilz) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ z__[jr + j * z_dim1] = -z__[jr + j * z_dim1];
+/* L400: */
+ }
+ }
+ }
+ alphar[j] = h__[j + j * h_dim1];
+ alphai[j] = 0.f;
+ beta[j] = t[j + j * t_dim1];
+/* L410: */
+ }
+
+/* Normal Termination */
+
+ *info = 0;
+
+/* Exit (other than argument error) -- return optimal workspace size */
+
+L420:
+ work[1] = (real) (*n);
+ return 0;
+
+/* End of SHGEQZ */
+
+} /* shgeqz_ */
diff --git a/SRC/shsein.c b/SRC/shsein.c
new file mode 100644
index 0000000..51e1d36
--- /dev/null
+++ b/SRC/shsein.c
@@ -0,0 +1,488 @@
+/* shsein.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static logical c_false = FALSE_;
+static logical c_true = TRUE_;
+
+/* Subroutine */ int shsein_(char *side, char *eigsrc, char *initv, logical *
+ select, integer *n, real *h__, integer *ldh, real *wr, real *wi, real
+ *vl, integer *ldvl, real *vr, integer *ldvr, integer *mm, integer *m,
+ real *work, integer *ifaill, integer *ifailr, integer *info)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
+ i__2;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer i__, k, kl, kr, kln, ksi;
+ real wki;
+ integer ksr;
+ real ulp, wkr, eps3;
+ logical pair;
+ real unfl;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical leftv, bothv;
+ real hnorm;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int slaein_(logical *, logical *, integer *, real
+ *, integer *, real *, real *, real *, real *, real *, integer *,
+ real *, real *, real *, real *, integer *), xerbla_(char *,
+ integer *);
+ real bignum;
+ extern doublereal slanhs_(char *, integer *, real *, integer *, real *);
+ logical noinit;
+ integer ldwork;
+ logical rightv, fromqr;
+ real smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SHSEIN uses inverse iteration to find specified right and/or left */
+/* eigenvectors of a real upper Hessenberg matrix H. */
+
+/* The right eigenvector x and the left eigenvector y of the matrix H */
+/* corresponding to an eigenvalue w are defined by: */
+
+/* H * x = w * x, y**h * H = w * y**h */
+
+/* where y**h denotes the conjugate transpose of the vector y. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'R': compute right eigenvectors only; */
+/* = 'L': compute left eigenvectors only; */
+/* = 'B': compute both right and left eigenvectors. */
+
+/* EIGSRC (input) CHARACTER*1 */
+/* Specifies the source of eigenvalues supplied in (WR,WI): */
+/* = 'Q': the eigenvalues were found using SHSEQR; thus, if */
+/* H has zero subdiagonal elements, and so is */
+/* block-triangular, then the j-th eigenvalue can be */
+/* assumed to be an eigenvalue of the block containing */
+/* the j-th row/column. This property allows SHSEIN to */
+/* perform inverse iteration on just one diagonal block. */
+/* = 'N': no assumptions are made on the correspondence */
+/* between eigenvalues and diagonal blocks. In this */
+/* case, SHSEIN must always perform inverse iteration */
+/* using the whole matrix H. */
+
+/* INITV (input) CHARACTER*1 */
+/* = 'N': no initial vectors are supplied; */
+/* = 'U': user-supplied initial vectors are stored in the arrays */
+/* VL and/or VR. */
+
+/* SELECT (input/output) LOGICAL array, dimension (N) */
+/* Specifies the eigenvectors to be computed. To select the */
+/* real eigenvector corresponding to a real eigenvalue WR(j), */
+/* SELECT(j) must be set to .TRUE.. To select the complex */
+/* eigenvector corresponding to a complex eigenvalue */
+/* (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)), */
+/* either SELECT(j) or SELECT(j+1) or both must be set to */
+/* .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is */
+/* .FALSE.. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N >= 0. */
+
+/* H (input) REAL array, dimension (LDH,N) */
+/* The upper Hessenberg matrix H. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH >= max(1,N). */
+
+/* WR (input/output) REAL array, dimension (N) */
+/* WI (input) REAL array, dimension (N) */
+/* On entry, the real and imaginary parts of the eigenvalues of */
+/* H; a complex conjugate pair of eigenvalues must be stored in */
+/* consecutive elements of WR and WI. */
+/* On exit, WR may have been altered since close eigenvalues */
+/* are perturbed slightly in searching for independent */
+/* eigenvectors. */
+
+/* VL (input/output) REAL array, dimension (LDVL,MM) */
+/* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must */
+/* contain starting vectors for the inverse iteration for the */
+/* left eigenvectors; the starting vector for each eigenvector */
+/* must be in the same column(s) in which the eigenvector will */
+/* be stored. */
+/* On exit, if SIDE = 'L' or 'B', the left eigenvectors */
+/* specified by SELECT will be stored consecutively in the */
+/* columns of VL, in the same order as their eigenvalues. A */
+/* complex eigenvector corresponding to a complex eigenvalue is */
+/* stored in two consecutive columns, the first holding the real */
+/* part and the second the imaginary part. */
+/* If SIDE = 'R', VL is not referenced. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. */
+/* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. */
+
+/* VR (input/output) REAL array, dimension (LDVR,MM) */
+/* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must */
+/* contain starting vectors for the inverse iteration for the */
+/* right eigenvectors; the starting vector for each eigenvector */
+/* must be in the same column(s) in which the eigenvector will */
+/* be stored. */
+/* On exit, if SIDE = 'R' or 'B', the right eigenvectors */
+/* specified by SELECT will be stored consecutively in the */
+/* columns of VR, in the same order as their eigenvalues. A */
+/* complex eigenvector corresponding to a complex eigenvalue is */
+/* stored in two consecutive columns, the first holding the real */
+/* part and the second the imaginary part. */
+/* If SIDE = 'L', VR is not referenced. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. */
+/* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. */
+
+/* MM (input) INTEGER */
+/* The number of columns in the arrays VL and/or VR. MM >= M. */
+
+/* M (output) INTEGER */
+/* The number of columns in the arrays VL and/or VR required to */
+/* store the eigenvectors; each selected real eigenvector */
+/* occupies one column and each selected complex eigenvector */
+/* occupies two columns. */
+
+/* WORK (workspace) REAL array, dimension ((N+2)*N) */
+
+/* IFAILL (output) INTEGER array, dimension (MM) */
+/* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left */
+/* eigenvector in the i-th column of VL (corresponding to the */
+/* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the */
+/* eigenvector converged satisfactorily. If the i-th and (i+1)th */
+/* columns of VL hold a complex eigenvector, then IFAILL(i) and */
+/* IFAILL(i+1) are set to the same value. */
+/* If SIDE = 'R', IFAILL is not referenced. */
+
+/* IFAILR (output) INTEGER array, dimension (MM) */
+/* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right */
+/* eigenvector in the i-th column of VR (corresponding to the */
+/* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the */
+/* eigenvector converged satisfactorily. If the i-th and (i+1)th */
+/* columns of VR hold a complex eigenvector, then IFAILR(i) and */
+/* IFAILR(i+1) are set to the same value. */
+/* If SIDE = 'L', IFAILR is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, i is the number of eigenvectors which */
+/* failed to converge; see IFAILL and IFAILR for further */
+/* details. */
+
+/* Further Details */
+/* =============== */
+
+/* Each eigenvector is normalized so that the element of largest */
+/* magnitude has magnitude 1; here the magnitude of a complex number */
+/* (x,y) is taken to be |x|+|y|. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters. */
+
+ /* Parameter adjustments */
+ --select;
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --wr;
+ --wi;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+ --ifaill;
+ --ifailr;
+
+ /* Function Body */
+ bothv = lsame_(side, "B");
+ rightv = lsame_(side, "R") || bothv;
+ leftv = lsame_(side, "L") || bothv;
+
+ fromqr = lsame_(eigsrc, "Q");
+
+ noinit = lsame_(initv, "N");
+
+/* Set M to the number of columns required to store the selected */
+/* eigenvectors, and standardize the array SELECT. */
+
+ *m = 0;
+ pair = FALSE_;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (pair) {
+ pair = FALSE_;
+ select[k] = FALSE_;
+ } else {
+ if (wi[k] == 0.f) {
+ if (select[k]) {
+ ++(*m);
+ }
+ } else {
+ pair = TRUE_;
+ if (select[k] || select[k + 1]) {
+ select[k] = TRUE_;
+ *m += 2;
+ }
+ }
+ }
+/* L10: */
+ }
+
+ *info = 0;
+ if (! rightv && ! leftv) {
+ *info = -1;
+ } else if (! fromqr && ! lsame_(eigsrc, "N")) {
+ *info = -2;
+ } else if (! noinit && ! lsame_(initv, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*ldh < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvl < 1 || leftv && *ldvl < *n) {
+ *info = -11;
+ } else if (*ldvr < 1 || rightv && *ldvr < *n) {
+ *info = -13;
+ } else if (*mm < *m) {
+ *info = -14;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SHSEIN", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Set machine-dependent constants. */
+
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Precision");
+ smlnum = unfl * (*n / ulp);
+ bignum = (1.f - ulp) / smlnum;
+
+ ldwork = *n + 1;
+
+ kl = 1;
+ kln = 0;
+ if (fromqr) {
+ kr = 0;
+ } else {
+ kr = *n;
+ }
+ ksr = 1;
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (select[k]) {
+
+/* Compute eigenvector(s) corresponding to W(K). */
+
+ if (fromqr) {
+
+/* If affiliation of eigenvalues is known, check whether */
+/* the matrix splits. */
+
+/* Determine KL and KR such that 1 <= KL <= K <= KR <= N */
+/* and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or */
+/* KR = N). */
+
+/* Then inverse iteration can be performed with the */
+/* submatrix H(KL:N,KL:N) for a left eigenvector, and with */
+/* the submatrix H(1:KR,1:KR) for a right eigenvector. */
+
+ i__2 = kl + 1;
+ for (i__ = k; i__ >= i__2; --i__) {
+ if (h__[i__ + (i__ - 1) * h_dim1] == 0.f) {
+ goto L30;
+ }
+/* L20: */
+ }
+L30:
+ kl = i__;
+ if (k > kr) {
+ i__2 = *n - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ if (h__[i__ + 1 + i__ * h_dim1] == 0.f) {
+ goto L50;
+ }
+/* L40: */
+ }
+L50:
+ kr = i__;
+ }
+ }
+
+ if (kl != kln) {
+ kln = kl;
+
+/* Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it */
+/* has not ben computed before. */
+
+ i__2 = kr - kl + 1;
+ hnorm = slanhs_("I", &i__2, &h__[kl + kl * h_dim1], ldh, &
+ work[1]);
+ if (hnorm > 0.f) {
+ eps3 = hnorm * ulp;
+ } else {
+ eps3 = smlnum;
+ }
+ }
+
+/* Perturb eigenvalue if it is close to any previous */
+/* selected eigenvalues affiliated to the submatrix */
+/* H(KL:KR,KL:KR). Close roots are modified by EPS3. */
+
+ wkr = wr[k];
+ wki = wi[k];
+L60:
+ i__2 = kl;
+ for (i__ = k - 1; i__ >= i__2; --i__) {
+ if (select[i__] && (r__1 = wr[i__] - wkr, dabs(r__1)) + (r__2
+ = wi[i__] - wki, dabs(r__2)) < eps3) {
+ wkr += eps3;
+ goto L60;
+ }
+/* L70: */
+ }
+ wr[k] = wkr;
+
+ pair = wki != 0.f;
+ if (pair) {
+ ksi = ksr + 1;
+ } else {
+ ksi = ksr;
+ }
+ if (leftv) {
+
+/* Compute left eigenvector. */
+
+ i__2 = *n - kl + 1;
+ slaein_(&c_false, &noinit, &i__2, &h__[kl + kl * h_dim1], ldh,
+ &wkr, &wki, &vl[kl + ksr * vl_dim1], &vl[kl + ksi *
+ vl_dim1], &work[1], &ldwork, &work[*n * *n + *n + 1],
+ &eps3, &smlnum, &bignum, &iinfo);
+ if (iinfo > 0) {
+ if (pair) {
+ *info += 2;
+ } else {
+ ++(*info);
+ }
+ ifaill[ksr] = k;
+ ifaill[ksi] = k;
+ } else {
+ ifaill[ksr] = 0;
+ ifaill[ksi] = 0;
+ }
+ i__2 = kl - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ vl[i__ + ksr * vl_dim1] = 0.f;
+/* L80: */
+ }
+ if (pair) {
+ i__2 = kl - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ vl[i__ + ksi * vl_dim1] = 0.f;
+/* L90: */
+ }
+ }
+ }
+ if (rightv) {
+
+/* Compute right eigenvector. */
+
+ slaein_(&c_true, &noinit, &kr, &h__[h_offset], ldh, &wkr, &
+ wki, &vr[ksr * vr_dim1 + 1], &vr[ksi * vr_dim1 + 1], &
+ work[1], &ldwork, &work[*n * *n + *n + 1], &eps3, &
+ smlnum, &bignum, &iinfo);
+ if (iinfo > 0) {
+ if (pair) {
+ *info += 2;
+ } else {
+ ++(*info);
+ }
+ ifailr[ksr] = k;
+ ifailr[ksi] = k;
+ } else {
+ ifailr[ksr] = 0;
+ ifailr[ksi] = 0;
+ }
+ i__2 = *n;
+ for (i__ = kr + 1; i__ <= i__2; ++i__) {
+ vr[i__ + ksr * vr_dim1] = 0.f;
+/* L100: */
+ }
+ if (pair) {
+ i__2 = *n;
+ for (i__ = kr + 1; i__ <= i__2; ++i__) {
+ vr[i__ + ksi * vr_dim1] = 0.f;
+/* L110: */
+ }
+ }
+ }
+
+ if (pair) {
+ ksr += 2;
+ } else {
+ ++ksr;
+ }
+ }
+/* L120: */
+ }
+
+ return 0;
+
+/* End of SHSEIN */
+
+} /* shsein_ */
diff --git a/SRC/shseqr.c b/SRC/shseqr.c
new file mode 100644
index 0000000..533949d
--- /dev/null
+++ b/SRC/shseqr.c
@@ -0,0 +1,484 @@
+/* shseqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b11 = 0.f;
+static real c_b12 = 1.f;
+static integer c__12 = 12;
+static integer c__2 = 2;
+static integer c__49 = 49;
+
+/* Subroutine */ int shseqr_(char *job, char *compz, integer *n, integer *ilo,
+ integer *ihi, real *h__, integer *ldh, real *wr, real *wi, real *z__,
+ integer *ldz, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2[2], i__3;
+ real r__1;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ real hl[2401] /* was [49][49] */;
+ integer kbot, nmin;
+ extern logical lsame_(char *, char *);
+ logical initz;
+ real workl[49];
+ logical wantt, wantz;
+ extern /* Subroutine */ int slaqr0_(logical *, logical *, integer *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, integer *, real *, integer *, real *, integer *, integer *),
+ xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slahqr_(logical *, logical *, integer *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, integer *, real *, integer *, integer *), slacpy_(char *,
+ integer *, integer *, real *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *,
+ real *, integer *);
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+/* Purpose */
+/* ======= */
+
+/* SHSEQR computes the eigenvalues of a Hessenberg matrix H */
+/* and, optionally, the matrices T and Z from the Schur decomposition */
+/* H = Z T Z**T, where T is an upper quasi-triangular matrix (the */
+/* Schur form), and Z is the orthogonal matrix of Schur vectors. */
+
+/* Optionally Z may be postmultiplied into an input orthogonal */
+/* matrix Q so that this routine can give the Schur factorization */
+/* of a matrix A which has been reduced to the Hessenberg form H */
+/* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* = 'E': compute eigenvalues only; */
+/* = 'S': compute eigenvalues and the Schur form T. */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': no Schur vectors are computed; */
+/* = 'I': Z is initialized to the unit matrix and the matrix Z */
+/* of Schur vectors of H is returned; */
+/* = 'V': Z must contain an orthogonal matrix Q on entry, and */
+/* the product Q*Z is returned. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N .GE. 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that H is already upper triangular in rows */
+/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
+/* set by a previous call to SGEBAL, and then passed to SGEHRD */
+/* when the matrix output by SGEBAL is reduced to Hessenberg */
+/* form. Otherwise ILO and IHI should be set to 1 and N */
+/* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */
+/* If N = 0, then ILO = 1 and IHI = 0. */
+
+/* H (input/output) REAL array, dimension (LDH,N) */
+/* On entry, the upper Hessenberg matrix H. */
+/* On exit, if INFO = 0 and JOB = 'S', then H contains the */
+/* upper quasi-triangular matrix T from the Schur decomposition */
+/* (the Schur form); 2-by-2 diagonal blocks (corresponding to */
+/* complex conjugate pairs of eigenvalues) are returned in */
+/* standard form, with H(i,i) = H(i+1,i+1) and */
+/* H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the */
+/* contents of H are unspecified on exit. (The output value of */
+/* H when INFO.GT.0 is given under the description of INFO */
+/* below.) */
+
+/* Unlike earlier versions of SHSEQR, this subroutine may */
+/* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 */
+/* or j = IHI+1, IHI+2, ... N. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH .GE. max(1,N). */
+
+/* WR (output) REAL array, dimension (N) */
+/* WI (output) REAL array, dimension (N) */
+/* The real and imaginary parts, respectively, of the computed */
+/* eigenvalues. If two eigenvalues are computed as a complex */
+/* conjugate pair, they are stored in consecutive elements of */
+/* WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and */
+/* WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in */
+/* the same order as on the diagonal of the Schur form returned */
+/* in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 */
+/* diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and */
+/* WI(i+1) = -WI(i). */
+
+/* Z (input/output) REAL array, dimension (LDZ,N) */
+/* If COMPZ = 'N', Z is not referenced. */
+/* If COMPZ = 'I', on entry Z need not be set and on exit, */
+/* if INFO = 0, Z contains the orthogonal matrix Z of the Schur */
+/* vectors of H. If COMPZ = 'V', on entry Z must contain an */
+/* N-by-N matrix Q, which is assumed to be equal to the unit */
+/* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, */
+/* if INFO = 0, Z contains Q*Z. */
+/* Normally Q is the orthogonal matrix generated by SORGHR */
+/* after the call to SGEHRD which formed the Hessenberg matrix */
+/* H. (The output value of Z when INFO.GT.0 is given under */
+/* the description of INFO below.) */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. if COMPZ = 'I' or */
+/* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. */
+
+/* WORK (workspace/output) REAL array, dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns an estimate of */
+/* the optimal value for LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK .GE. max(1,N) */
+/* is sufficient and delivers very good and sometimes */
+/* optimal performance. However, LWORK as large as 11*N */
+/* may be required for optimal performance. A workspace */
+/* query is recommended to determine the optimal workspace */
+/* size. */
+
+/* If LWORK = -1, then SHSEQR does a workspace query. */
+/* In this case, SHSEQR checks the input parameters and */
+/* estimates the optimal workspace size for the given */
+/* values of N, ILO and IHI. The estimate is returned */
+/* in WORK(1). No error message related to LWORK is */
+/* issued by XERBLA. Neither H nor Z are accessed. */
+
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* .LT. 0: if INFO = -i, the i-th argument had an illegal */
+/* value */
+/* .GT. 0: if INFO = i, SHSEQR failed to compute all of */
+/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */
+/* and WI contain those eigenvalues which have been */
+/* successfully computed. (Failures are rare.) */
+
+/* If INFO .GT. 0 and JOB = 'E', then on exit, the */
+/* remaining unconverged eigenvalues are the eigen- */
+/* values of the upper Hessenberg matrix rows and */
+/* columns ILO through INFO of the final, output */
+/* value of H. */
+
+/* If INFO .GT. 0 and JOB = 'S', then on exit */
+
+/* (*) (initial value of H)*U = U*(final value of H) */
+
+/* where U is an orthogonal matrix. The final */
+/* value of H is upper Hessenberg and quasi-triangular */
+/* in rows and columns INFO+1 through IHI. */
+
+/* If INFO .GT. 0 and COMPZ = 'V', then on exit */
+
+/* (final value of Z) = (initial value of Z)*U */
+
+/* where U is the orthogonal matrix in (*) (regard- */
+/* less of the value of JOB.) */
+
+/* If INFO .GT. 0 and COMPZ = 'I', then on exit */
+/* (final value of Z) = U */
+/* where U is the orthogonal matrix in (*) (regard- */
+/* less of the value of JOB.) */
+
+/* If INFO .GT. 0 and COMPZ = 'N', then Z is not */
+/* accessed. */
+
+/* ================================================================ */
+/* Default values supplied by */
+/* ILAENV(ISPEC,'SHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). */
+/* It is suggested that these defaults be adjusted in order */
+/* to attain best performance in each particular */
+/* computational environment. */
+
+/* ISPEC=12: The SLAHQR vs SLAQR0 crossover point. */
+/* Default: 75. (Must be at least 11.) */
+
+/* ISPEC=13: Recommended deflation window size. */
+/* This depends on ILO, IHI and NS. NS is the */
+/* number of simultaneous shifts returned */
+/* by ILAENV(ISPEC=15). (See ISPEC=15 below.) */
+/* The default for (IHI-ILO+1).LE.500 is NS. */
+/* The default for (IHI-ILO+1).GT.500 is 3*NS/2. */
+
+/* ISPEC=14: Nibble crossover point. (See IPARMQ for */
+/* details.) Default: 14% of deflation window */
+/* size. */
+
+/* ISPEC=15: Number of simultaneous shifts in a multishift */
+/* QR iteration. */
+
+/* If IHI-ILO+1 is ... */
+
+/* greater than ...but less ... the */
+/* or equal to ... than default is */
+
+/* 1 30 NS = 2(+) */
+/* 30 60 NS = 4(+) */
+/* 60 150 NS = 10(+) */
+/* 150 590 NS = ** */
+/* 590 3000 NS = 64 */
+/* 3000 6000 NS = 128 */
+/* 6000 infinity NS = 256 */
+
+/* (+) By default some or all matrices of this order */
+/* are passed to the implicit double shift routine */
+/* SLAHQR and this parameter is ignored. See */
+/* ISPEC=12 above and comments in IPARMQ for */
+/* details. */
+
+/* (**) The asterisks (**) indicate an ad-hoc */
+/* function of N increasing from 10 to 64. */
+
+/* ISPEC=16: Select structured matrix multiply. */
+/* If the number of simultaneous shifts (specified */
+/* by ISPEC=15) is less than 14, then the default */
+/* for ISPEC=16 is 0. Otherwise the default for */
+/* ISPEC=16 is 2. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* References: */
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */
+/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */
+/* 929--947, 2002. */
+
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */
+/* of Matrix Analysis, volume 23, pages 948--973, 2002. */
+
+/* ================================================================ */
+/* .. Parameters .. */
+
+/* ==== Matrices of order NTINY or smaller must be processed by */
+/* . SLAHQR because of insufficient subdiagonal scratch space. */
+/* . (This is a hard limit.) ==== */
+
+/* ==== NL allocates some local workspace to help small matrices */
+/* . through a rare SLAHQR failure. NL .GT. NTINY = 11 is */
+/* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- */
+/* . mended. (The default value of NMIN is 75.) Using NL = 49 */
+/* . allows up to six simultaneous shifts and a 16-by-16 */
+/* . deflation window. ==== */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* ==== Decode and check the input parameters. ==== */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --wr;
+ --wi;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ wantt = lsame_(job, "S");
+ initz = lsame_(compz, "I");
+ wantz = initz || lsame_(compz, "V");
+ work[1] = (real) max(1,*n);
+ lquery = *lwork == -1;
+
+ *info = 0;
+ if (! lsame_(job, "E") && ! wantt) {
+ *info = -1;
+ } else if (! lsame_(compz, "N") && ! wantz) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ilo < 1 || *ilo > max(1,*n)) {
+ *info = -4;
+ } else if (*ihi < min(*ilo,*n) || *ihi > *n) {
+ *info = -5;
+ } else if (*ldh < max(1,*n)) {
+ *info = -7;
+ } else if (*ldz < 1 || wantz && *ldz < max(1,*n)) {
+ *info = -11;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -13;
+ }
+
+ if (*info != 0) {
+
+/* ==== Quick return in case of invalid argument. ==== */
+
+ i__1 = -(*info);
+ xerbla_("SHSEQR", &i__1);
+ return 0;
+
+ } else if (*n == 0) {
+
+/* ==== Quick return in case N = 0; nothing to do. ==== */
+
+ return 0;
+
+ } else if (lquery) {
+
+/* ==== Quick return in case of a workspace query ==== */
+
+ slaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &wi[
+ 1], ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, info);
+/* ==== Ensure reported workspace size is backward-compatible with */
+/* . previous LAPACK versions. ==== */
+/* Computing MAX */
+ r__1 = (real) max(1,*n);
+ work[1] = dmax(r__1,work[1]);
+ return 0;
+
+ } else {
+
+/* ==== copy eigenvalues isolated by SGEBAL ==== */
+
+ i__1 = *ilo - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ wr[i__] = h__[i__ + i__ * h_dim1];
+ wi[i__] = 0.f;
+/* L10: */
+ }
+ i__1 = *n;
+ for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
+ wr[i__] = h__[i__ + i__ * h_dim1];
+ wi[i__] = 0.f;
+/* L20: */
+ }
+
+/* ==== Initialize Z, if requested ==== */
+
+ if (initz) {
+ slaset_("A", n, n, &c_b11, &c_b12, &z__[z_offset], ldz)
+ ;
+ }
+
+/* ==== Quick return if possible ==== */
+
+ if (*ilo == *ihi) {
+ wr[*ilo] = h__[*ilo + *ilo * h_dim1];
+ wi[*ilo] = 0.f;
+ return 0;
+ }
+
+/* ==== SLAHQR/SLAQR0 crossover point ==== */
+
+/* Writing concatenation */
+ i__2[0] = 1, a__1[0] = job;
+ i__2[1] = 1, a__1[1] = compz;
+ s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2);
+ nmin = ilaenv_(&c__12, "SHSEQR", ch__1, n, ilo, ihi, lwork);
+ nmin = max(11,nmin);
+
+/* ==== SLAQR0 for big matrices; SLAHQR for small ones ==== */
+
+ if (*n > nmin) {
+ slaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1],
+ &wi[1], ilo, ihi, &z__[z_offset], ldz, &work[1], lwork,
+ info);
+ } else {
+
+/* ==== Small matrix ==== */
+
+ slahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1],
+ &wi[1], ilo, ihi, &z__[z_offset], ldz, info);
+
+ if (*info > 0) {
+
+/* ==== A rare SLAHQR failure! SLAQR0 sometimes succeeds */
+/* . when SLAHQR fails. ==== */
+
+ kbot = *info;
+
+ if (*n >= 49) {
+
+/* ==== Larger matrices have enough subdiagonal scratch */
+/* . space to call SLAQR0 directly. ==== */
+
+ slaqr0_(&wantt, &wantz, n, ilo, &kbot, &h__[h_offset],
+ ldh, &wr[1], &wi[1], ilo, ihi, &z__[z_offset],
+ ldz, &work[1], lwork, info);
+
+ } else {
+
+/* ==== Tiny matrices don't have enough subdiagonal */
+/* . scratch space to benefit from SLAQR0. Hence, */
+/* . tiny matrices must be copied into a larger */
+/* . array before calling SLAQR0. ==== */
+
+ slacpy_("A", n, n, &h__[h_offset], ldh, hl, &c__49);
+ hl[*n + 1 + *n * 49 - 50] = 0.f;
+ i__1 = 49 - *n;
+ slaset_("A", &c__49, &i__1, &c_b11, &c_b11, &hl[(*n + 1) *
+ 49 - 49], &c__49);
+ slaqr0_(&wantt, &wantz, &c__49, ilo, &kbot, hl, &c__49, &
+ wr[1], &wi[1], ilo, ihi, &z__[z_offset], ldz,
+ workl, &c__49, info);
+ if (wantt || *info != 0) {
+ slacpy_("A", n, n, hl, &c__49, &h__[h_offset], ldh);
+ }
+ }
+ }
+ }
+
+/* ==== Clear out the trash, if necessary. ==== */
+
+ if ((wantt || *info != 0) && *n > 2) {
+ i__1 = *n - 2;
+ i__3 = *n - 2;
+ slaset_("L", &i__1, &i__3, &c_b11, &c_b11, &h__[h_dim1 + 3], ldh);
+ }
+
+/* ==== Ensure reported workspace size is backward-compatible with */
+/* . previous LAPACK versions. ==== */
+
+/* Computing MAX */
+ r__1 = (real) max(1,*n);
+ work[1] = dmax(r__1,work[1]);
+ }
+
+/* ==== End of SHSEQR ==== */
+
+ return 0;
+} /* shseqr_ */
diff --git a/SRC/sisnan.c b/SRC/sisnan.c
new file mode 100644
index 0000000..9634bd2
--- /dev/null
+++ b/SRC/sisnan.c
@@ -0,0 +1,52 @@
+/* sisnan.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+logical sisnan_(real *sin__)
+{
+ /* System generated locals */
+ logical ret_val;
+
+ /* Local variables */
+ extern logical slaisnan_(real *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SISNAN returns .TRUE. if its argument is NaN, and .FALSE. */
+/* otherwise. To be replaced by the Fortran 2003 intrinsic in the */
+/* future. */
+
+/* Arguments */
+/* ========= */
+
+/* SIN (input) REAL */
+/* Input to test for NaN. */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ ret_val = slaisnan_(sin__, sin__);
+ return ret_val;
+} /* sisnan_ */
diff --git a/SRC/sla_gbamv.c b/SRC/sla_gbamv.c
new file mode 100644
index 0000000..39e6adc
--- /dev/null
+++ b/SRC/sla_gbamv.c
@@ -0,0 +1,316 @@
+/* sla_gbamv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sla_gbamv__(integer *trans, integer *m, integer *n,
+ integer *kl, integer *ku, real *alpha, real *ab, integer *ldab, real *
+ x, integer *incx, real *beta, real *y, integer *incy)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ real r__1;
+
+ /* Builtin functions */
+ double r_sign(real *, real *);
+
+ /* Local variables */
+ extern integer ilatrans_(char *);
+ integer i__, j;
+ logical symb_zero__;
+ integer kd, iy, jx, kx, ky, info;
+ real temp;
+ integer lenx, leny;
+ real safe1;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLA_GEAMV performs one of the matrix-vector operations */
+
+/* y := alpha*abs(A)*abs(x) + beta*abs(y), */
+/* or y := alpha*abs(A)'*abs(x) + beta*abs(y), */
+
+/* where alpha and beta are scalars, x and y are vectors and A is an */
+/* m by n matrix. */
+
+/* This function is primarily used in calculating error bounds. */
+/* To protect against underflow during evaluation, components in */
+/* the resulting vector are perturbed away from zero by (N+1) */
+/* times the underflow threshold. To prevent unnecessarily large */
+/* errors for block-structure embedded in general matrices, */
+/* "symbolically" zero components are not perturbed. A zero */
+/* entry is considered "symbolic" if all multiplications involved */
+/* in computing that entry have at least one zero multiplicand. */
+
+/* Parameters */
+/* ========== */
+
+/* TRANS - INTEGER */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) */
+/* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) */
+/* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER */
+/* On entry, M specifies the number of rows of the matrix A. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* KL - INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU - INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* ALPHA - REAL */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - REAL array of DIMENSION ( LDA, n ) */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+/* X - REAL array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - REAL */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - REAL array of DIMENSION at least */
+/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
+/* Before entry with BETA non-zero, the incremented array Y */
+/* must contain the vector y. On exit, Y is overwritten by the */
+/* updated vector y. */
+
+/* INCY - INTEGER */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! (*trans == ilatrans_("N") || *trans == ilatrans_("T") || *trans == ilatrans_("C"))) {
+ info = 1;
+ } else if (*m < 0) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*kl < 0) {
+ info = 4;
+ } else if (*ku < 0) {
+ info = 5;
+ } else if (*ldab < *kl + *ku + 1) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ } else if (*incy == 0) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("SLA_GBAMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || *alpha == 0.f && *beta == 1.f) {
+ return 0;
+ }
+
+/* Set LENX and LENY, the lengths of the vectors x and y, and set */
+/* up the start points in X and Y. */
+
+ if (*trans == ilatrans_("N")) {
+ lenx = *n;
+ leny = *m;
+ } else {
+ lenx = *m;
+ leny = *n;
+ }
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (lenx - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (leny - 1) * *incy;
+ }
+
+/* Set SAFE1 essentially to be the underflow threshold times the */
+/* number of additions in each row. */
+
+ safe1 = slamch_("Safe minimum");
+ safe1 = (*n + 1) * safe1;
+
+/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */
+
+/* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to */
+/* the inexact flag. Still doesn't help change the iteration order */
+/* to per-column. */
+
+ kd = *ku + 1;
+ iy = ky;
+ if (*incx == 1) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.f) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.f;
+ } else if (y[iy] == 0.f) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (r__1 = y[iy], dabs(r__1));
+ }
+ if (*alpha != 0.f) {
+/* Computing MAX */
+ i__2 = i__ - *ku;
+/* Computing MIN */
+ i__4 = i__ + *kl;
+ i__3 = min(i__4,lenx);
+ for (j = max(i__2,1); j <= i__3; ++j) {
+ if (*trans == ilatrans_("N")) {
+ temp = (r__1 = ab[kd + i__ - j + j * ab_dim1], dabs(
+ r__1));
+ } else {
+ temp = (r__1 = ab[j + (kd + i__ - j) * ab_dim1], dabs(
+ r__1));
+ }
+ symb_zero__ = symb_zero__ && (x[j] == 0.f || temp == 0.f);
+ y[iy] += *alpha * (r__1 = x[j], dabs(r__1)) * temp;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += r_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.f) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.f;
+ } else if (y[iy] == 0.f) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (r__1 = y[iy], dabs(r__1));
+ }
+ if (*alpha != 0.f) {
+ jx = kx;
+/* Computing MAX */
+ i__3 = i__ - *ku;
+/* Computing MIN */
+ i__4 = i__ + *kl;
+ i__2 = min(i__4,lenx);
+ for (j = max(i__3,1); j <= i__2; ++j) {
+ if (*trans == ilatrans_("N")) {
+ temp = (r__1 = ab[kd + i__ - j + j * ab_dim1], dabs(
+ r__1));
+ } else {
+ temp = (r__1 = ab[j + (kd + i__ - j) * ab_dim1], dabs(
+ r__1));
+ }
+ symb_zero__ = symb_zero__ && (x[jx] == 0.f || temp == 0.f)
+ ;
+ y[iy] += *alpha * (r__1 = x[jx], dabs(r__1)) * temp;
+ jx += *incx;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += r_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ }
+
+ return 0;
+
+/* End of SLA_GBAMV */
+
+} /* sla_gbamv__ */
diff --git a/SRC/sla_gbrcond.c b/SRC/sla_gbrcond.c
new file mode 100644
index 0000000..e5e50b6
--- /dev/null
+++ b/SRC/sla_gbrcond.c
@@ -0,0 +1,346 @@
+/* sla_gbrcond.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal sla_gbrcond__(char *trans, integer *n, integer *kl, integer *ku,
+ real *ab, integer *ldab, real *afb, integer *ldafb, integer *ipiv,
+ integer *cmode, real *c__, integer *info, real *work, integer *iwork,
+ ftnlen trans_len)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, i__1, i__2, i__3, i__4;
+ real ret_val, r__1;
+
+ /* Local variables */
+ integer i__, j, kd, ke;
+ real tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *,
+ real *, integer *, integer *), xerbla_(char *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int sgbtrs_(char *, integer *, integer *, integer
+ *, integer *, real *, integer *, integer *, real *, integer *,
+ integer *);
+ logical notrans;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLA_GERCOND Estimates the Skeel condition number of op(A) * op2(C) */
+/* where op2 is determined by CMODE as follows */
+/* CMODE = 1 op2(C) = C */
+/* CMODE = 0 op2(C) = I */
+/* CMODE = -1 op2(C) = inv(C) */
+/* The Skeel condition number cond(A) = norminf( |inv(A)||A| ) */
+/* is computed by computing scaling factors R such that */
+/* diag(R)*A*op2(C) is row equilibrated and computing the standard */
+/* infinity-norm condition number. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input) REAL array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input) REAL array, dimension (LDAFB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by SGBTRF. U is stored as an upper triangular */
+/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */
+/* and the multipliers used during the factorization are stored */
+/* in rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from the factorization A = P*L*U */
+/* as computed by SGBTRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* CMODE (input) INTEGER */
+/* Determines op2(C) in the formula op(A) * op2(C) as follows: */
+/* CMODE = 1 op2(C) = C */
+/* CMODE = 0 op2(C) = I */
+/* CMODE = -1 op2(C) = inv(C) */
+
+/* C (input) REAL array, dimension (N) */
+/* The vector C in the formula op(A) * op2(C). */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) REAL array, dimension (5*N). */
+/* Workspace. */
+
+/* IWORK (input) INTEGER array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ --c__;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ *info = 0;
+ notrans = lsame_(trans, "N");
+ if (! notrans && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0 || *kl > *n - 1) {
+ *info = -3;
+ } else if (*ku < 0 || *ku > *n - 1) {
+ *info = -4;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -6;
+ } else if (*ldafb < (*kl << 1) + *ku + 1) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLA_GBRCOND", &i__1);
+ return ret_val;
+ }
+ if (*n == 0) {
+ ret_val = 1.f;
+ return ret_val;
+ }
+
+/* Compute the equilibration matrix R such that */
+/* inv(R)*A*C has unit 1-norm. */
+
+ kd = *ku + 1;
+ ke = *kl + 1;
+ if (notrans) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ if (*cmode == 1) {
+/* Computing MAX */
+ i__2 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__3 = min(i__4,*n);
+ for (j = max(i__2,1); j <= i__3; ++j) {
+ tmp += (r__1 = ab[kd + i__ - j + j * ab_dim1] * c__[j],
+ dabs(r__1));
+ }
+ } else if (*cmode == 0) {
+/* Computing MAX */
+ i__3 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__2 = min(i__4,*n);
+ for (j = max(i__3,1); j <= i__2; ++j) {
+ tmp += (r__1 = ab[kd + i__ - j + j * ab_dim1], dabs(r__1))
+ ;
+ }
+ } else {
+/* Computing MAX */
+ i__2 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__3 = min(i__4,*n);
+ for (j = max(i__2,1); j <= i__3; ++j) {
+ tmp += (r__1 = ab[kd + i__ - j + j * ab_dim1] / c__[j],
+ dabs(r__1));
+ }
+ }
+ work[(*n << 1) + i__] = tmp;
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ if (*cmode == 1) {
+/* Computing MAX */
+ i__3 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__2 = min(i__4,*n);
+ for (j = max(i__3,1); j <= i__2; ++j) {
+ tmp += (r__1 = ab[ke - i__ + j + i__ * ab_dim1] * c__[j],
+ dabs(r__1));
+ }
+ } else if (*cmode == 0) {
+/* Computing MAX */
+ i__2 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__3 = min(i__4,*n);
+ for (j = max(i__2,1); j <= i__3; ++j) {
+ tmp += (r__1 = ab[ke - i__ + j + i__ * ab_dim1], dabs(
+ r__1));
+ }
+ } else {
+/* Computing MAX */
+ i__3 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__2 = min(i__4,*n);
+ for (j = max(i__3,1); j <= i__2; ++j) {
+ tmp += (r__1 = ab[ke - i__ + j + i__ * ab_dim1] / c__[j],
+ dabs(r__1));
+ }
+ }
+ work[(*n << 1) + i__] = tmp;
+ }
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.f;
+ kase = 0;
+L10:
+ slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= work[(*n << 1) + i__];
+ }
+ if (notrans) {
+ sgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset],
+ ldafb, &ipiv[1], &work[1], n, info);
+ } else {
+ sgbtrs_("Transpose", n, kl, ku, &c__1, &afb[afb_offset],
+ ldafb, &ipiv[1], &work[1], n, info);
+ }
+
+/* Multiply by inv(C). */
+
+ if (*cmode == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] /= c__[i__];
+ }
+ } else if (*cmode == -1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= c__[i__];
+ }
+ }
+ } else {
+
+/* Multiply by inv(C'). */
+
+ if (*cmode == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] /= c__[i__];
+ }
+ } else if (*cmode == -1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= c__[i__];
+ }
+ }
+ if (notrans) {
+ sgbtrs_("Transpose", n, kl, ku, &c__1, &afb[afb_offset],
+ ldafb, &ipiv[1], &work[1], n, info);
+ } else {
+ sgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset],
+ ldafb, &ipiv[1], &work[1], n, info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= work[(*n << 1) + i__];
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ ret_val = 1.f / ainvnm;
+ }
+
+ return ret_val;
+
+} /* sla_gbrcond__ */
diff --git a/SRC/sla_gbrfsx_extended.c b/SRC/sla_gbrfsx_extended.c
new file mode 100644
index 0000000..890255e
--- /dev/null
+++ b/SRC/sla_gbrfsx_extended.c
@@ -0,0 +1,625 @@
+/* sla_gbrfsx_extended.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b6 = -1.f;
+static real c_b8 = 1.f;
+
+/* Subroutine */ int sla_gbrfsx_extended__(integer *prec_type__, integer *
+ trans_type__, integer *n, integer *kl, integer *ku, integer *nrhs,
+ real *ab, integer *ldab, real *afb, integer *ldafb, integer *ipiv,
+ logical *colequ, real *c__, real *b, integer *ldb, real *y, integer *
+ ldy, real *berr_out__, integer *n_norms__, real *err_bnds_norm__,
+ real *err_bnds_comp__, real *res, real *ayb, real *dy, real *y_tail__,
+ real *rcond, integer *ithresh, real *rthresh, real *dz_ub__, logical
+ *ignore_cwise__, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ y_dim1, y_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3;
+ real r__1, r__2;
+ char ch__1[1];
+
+ /* Local variables */
+ real dxratmax, dzratmax;
+ integer i__, j, m;
+ extern /* Subroutine */ int sla_gbamv__(integer *, integer *, integer *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+ , real *, real *, integer *);
+ logical incr_prec__;
+ real prev_dz_z__, yk, final_dx_x__, final_dz_z__;
+ extern /* Subroutine */ int sla_wwaddw__(integer *, real *, real *, real *
+ );
+ real prevnormdx;
+ integer cnt;
+ real dyk, eps, incr_thresh__, dx_x__, dz_z__, ymin;
+ extern /* Subroutine */ int sla_lin_berr__(integer *, integer *, integer *
+ , real *, real *, real *), blas_sgbmv_x__(integer *, integer *,
+ integer *, integer *, integer *, real *, real *, integer *, real *
+ , integer *, real *, real *, integer *, integer *);
+ integer y_prec_state__;
+ extern /* Subroutine */ int blas_sgbmv2_x__(integer *, integer *, integer
+ *, integer *, integer *, real *, real *, integer *, real *, real *
+ , integer *, real *, real *, integer *, integer *), sgbmv_(char *,
+ integer *, integer *, integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, real *, integer *);
+ real dxrat, dzrat;
+ char trans[1];
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ real normx, normy;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int sgbtrs_(char *, integer *, integer *, integer
+ *, integer *, real *, integer *, integer *, real *, integer *,
+ integer *);
+ real normdx;
+ extern /* Character */ VOID chla_transtype__(char *, ftnlen, integer *);
+ real hugeval;
+ integer x_state__, z_state__;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLA_GBRFSX_EXTENDED improves the computed solution to a system of */
+/* linear equations by performing extra-precise iterative refinement */
+/* and provides error bounds and backward error estimates for the solution. */
+/* This subroutine is called by SGBRFSX to perform iterative refinement. */
+/* In addition to normwise error bound, the code provides maximum */
+/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP for details of the error bounds. Note that this */
+/* subroutine is only resonsible for setting the second fields of */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP. */
+
+/* Arguments */
+/* ========= */
+
+/* PREC_TYPE (input) INTEGER */
+/* Specifies the intermediate precision to be used in refinement. */
+/* The value is defined by ILAPREC(P) where P is a CHARACTER and */
+/* P = 'S': Single */
+/* = 'D': Double */
+/* = 'I': Indigenous */
+/* = 'X', 'E': Extra */
+
+/* TRANS_TYPE (input) INTEGER */
+/* Specifies the transposition operation on A. */
+/* The value is defined by ILATRANS(T) where T is a CHARACTER and */
+/* T = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0 */
+
+/* NRHS (input) INTEGER */
+/* The number of right-hand-sides, i.e., the number of columns of the */
+/* matrix B. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) REAL array, dimension (LDAF,N) */
+/* The factors L and U from the factorization */
+/* A = P*L*U as computed by SGBTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from the factorization A = P*L*U */
+/* as computed by SGBTRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* COLEQU (input) LOGICAL */
+/* If .TRUE. then column equilibration was done to A before calling */
+/* this routine. This is needed to compute the solution and error */
+/* bounds correctly. */
+
+/* C (input) REAL array, dimension (N) */
+/* The column scale factors for A. If COLEQU = .FALSE., C */
+/* is not accessed. If C is input, each element of C should be a power */
+/* of the radix to ensure a reliable solution and error estimates. */
+/* Scaling by powers of the radix does not cause rounding errors unless */
+/* the result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right-hand-side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Y (input/output) REAL array, dimension (LDY,NRHS) */
+/* On entry, the solution matrix X, as computed by SGBTRS. */
+/* On exit, the improved solution matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= max(1,N). */
+
+/* BERR_OUT (output) REAL array, dimension (NRHS) */
+/* On exit, BERR_OUT(j) contains the componentwise relative backward */
+/* error for right-hand-side j from the formula */
+/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. This is computed by SLA_LIN_BERR. */
+
+/* N_NORMS (input) INTEGER */
+/* Determines which error bounds to return (see ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP). */
+/* If N_NORMS >= 1 return normwise error bounds. */
+/* If N_NORMS >= 2 return componentwise error bounds. */
+
+/* ERR_BNDS_NORM (input/output) REAL array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (input/output) REAL array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* RES (input) REAL array, dimension (N) */
+/* Workspace to hold the intermediate residual. */
+
+/* AYB (input) REAL array, dimension (N) */
+/* Workspace. This can be the same workspace passed for Y_TAIL. */
+
+/* DY (input) REAL array, dimension (N) */
+/* Workspace to hold the intermediate solution. */
+
+/* Y_TAIL (input) REAL array, dimension (N) */
+/* Workspace to hold the trailing bits of the intermediate solution. */
+
+/* RCOND (input) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* ITHRESH (input) INTEGER */
+/* The maximum number of residual computations allowed for */
+/* refinement. The default is 10. For 'aggressive' set to 100 to */
+/* permit convergence using approximate factorizations or */
+/* factorizations other than LU. If the factorization uses a */
+/* technique other than Gaussian elimination, the guarantees in */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */
+
+/* RTHRESH (input) REAL */
+/* Determines when to stop refinement if the error estimate stops */
+/* decreasing. Refinement will stop when the next solution no longer */
+/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */
+/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */
+/* default value is 0.5. For 'aggressive' set to 0.9 to permit */
+/* convergence on extremely ill-conditioned matrices. See LAWN 165 */
+/* for more details. */
+
+/* DZ_UB (input) REAL */
+/* Determines when to start considering componentwise convergence. */
+/* Componentwise convergence is only considered after each component */
+/* of the solution Y is stable, which we definte as the relative */
+/* change in each component being less than DZ_UB. The default value */
+/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */
+/* more details. */
+
+/* IGNORE_CWISE (input) LOGICAL */
+/* If .TRUE. then ignore componentwise convergence. Default value */
+/* is .FALSE.. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* < 0: if INFO = -i, the ith argument to SGBTRS had an illegal */
+/* value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ --berr_out__;
+ --res;
+ --ayb;
+ --dy;
+ --y_tail__;
+
+ /* Function Body */
+ if (*info != 0) {
+ return 0;
+ }
+ chla_transtype__(ch__1, (ftnlen)1, trans_type__);
+ *(unsigned char *)trans = *(unsigned char *)&ch__1[0];
+ eps = slamch_("Epsilon");
+ hugeval = slamch_("Overflow");
+/* Force HUGEVAL to Inf */
+ hugeval *= hugeval;
+/* Using HUGEVAL may lead to spurious underflows. */
+ incr_thresh__ = (real) (*n) * eps;
+ m = *kl + *ku + 1;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ y_prec_state__ = 1;
+ if (y_prec_state__ == 2) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ y_tail__[i__] = 0.f;
+ }
+ }
+ dxrat = 0.f;
+ dxratmax = 0.f;
+ dzrat = 0.f;
+ dzratmax = 0.f;
+ final_dx_x__ = hugeval;
+ final_dz_z__ = hugeval;
+ prevnormdx = hugeval;
+ prev_dz_z__ = hugeval;
+ dz_z__ = hugeval;
+ dx_x__ = hugeval;
+ x_state__ = 1;
+ z_state__ = 0;
+ incr_prec__ = FALSE_;
+ i__2 = *ithresh;
+ for (cnt = 1; cnt <= i__2; ++cnt) {
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ scopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ if (y_prec_state__ == 0) {
+ sgbmv_(trans, &m, n, kl, ku, &c_b6, &ab[ab_offset], ldab, &y[
+ j * y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1);
+ } else if (y_prec_state__ == 1) {
+ blas_sgbmv_x__(trans_type__, n, n, kl, ku, &c_b6, &ab[
+ ab_offset], ldab, &y[j * y_dim1 + 1], &c__1, &c_b8, &
+ res[1], &c__1, prec_type__);
+ } else {
+ blas_sgbmv2_x__(trans_type__, n, n, kl, ku, &c_b6, &ab[
+ ab_offset], ldab, &y[j * y_dim1 + 1], &y_tail__[1], &
+ c__1, &c_b8, &res[1], &c__1, prec_type__);
+ }
+/* XXX: RES is no longer needed. */
+ scopy_(n, &res[1], &c__1, &dy[1], &c__1);
+ sgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1]
+, &dy[1], n, info);
+
+/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
+
+ normx = 0.f;
+ normy = 0.f;
+ normdx = 0.f;
+ dz_z__ = 0.f;
+ ymin = hugeval;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ yk = (r__1 = y[i__ + j * y_dim1], dabs(r__1));
+ dyk = (r__1 = dy[i__], dabs(r__1));
+ if (yk != 0.f) {
+/* Computing MAX */
+ r__1 = dz_z__, r__2 = dyk / yk;
+ dz_z__ = dmax(r__1,r__2);
+ } else if (dyk != 0.f) {
+ dz_z__ = hugeval;
+ }
+ ymin = dmin(ymin,yk);
+ normy = dmax(normy,yk);
+ if (*colequ) {
+/* Computing MAX */
+ r__1 = normx, r__2 = yk * c__[i__];
+ normx = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = normdx, r__2 = dyk * c__[i__];
+ normdx = dmax(r__1,r__2);
+ } else {
+ normx = normy;
+ normdx = dmax(normdx,dyk);
+ }
+ }
+ if (normx != 0.f) {
+ dx_x__ = normdx / normx;
+ } else if (normdx == 0.f) {
+ dx_x__ = 0.f;
+ } else {
+ dx_x__ = hugeval;
+ }
+ dxrat = normdx / prevnormdx;
+ dzrat = dz_z__ / prev_dz_z__;
+
+/* Check termination criteria. */
+
+ if (! (*ignore_cwise__) && ymin * *rcond < incr_thresh__ * normy
+ && y_prec_state__ < 2) {
+ incr_prec__ = TRUE_;
+ }
+ if (x_state__ == 3 && dxrat <= *rthresh) {
+ x_state__ = 1;
+ }
+ if (x_state__ == 1) {
+ if (dx_x__ <= eps) {
+ x_state__ = 2;
+ } else if (dxrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ x_state__ = 3;
+ }
+ } else {
+ if (dxrat > dxratmax) {
+ dxratmax = dxrat;
+ }
+ }
+ if (x_state__ > 1) {
+ final_dx_x__ = dx_x__;
+ }
+ }
+ if (z_state__ == 0 && dz_z__ <= *dz_ub__) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 3 && dzrat <= *rthresh) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 1) {
+ if (dz_z__ <= eps) {
+ z_state__ = 2;
+ } else if (dz_z__ > *dz_ub__) {
+ z_state__ = 0;
+ dzratmax = 0.f;
+ final_dz_z__ = hugeval;
+ } else if (dzrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ z_state__ = 3;
+ }
+ } else {
+ if (dzrat > dzratmax) {
+ dzratmax = dzrat;
+ }
+ }
+ if (z_state__ > 1) {
+ final_dz_z__ = dz_z__;
+ }
+ }
+
+/* Exit if both normwise and componentwise stopped working, */
+/* but if componentwise is unstable, let it go at least two */
+/* iterations. */
+
+ if (x_state__ != 1) {
+ if (*ignore_cwise__) {
+ goto L666;
+ }
+ if (z_state__ == 3 || z_state__ == 2) {
+ goto L666;
+ }
+ if (z_state__ == 0 && cnt > 1) {
+ goto L666;
+ }
+ }
+ if (incr_prec__) {
+ incr_prec__ = FALSE_;
+ ++y_prec_state__;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ y_tail__[i__] = 0.f;
+ }
+ }
+ prevnormdx = normdx;
+ prev_dz_z__ = dz_z__;
+
+/* Update soluton. */
+
+ if (y_prec_state__ < 2) {
+ saxpy_(n, &c_b8, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
+ } else {
+ sla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
+ }
+ }
+/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */
+L666:
+
+/* Set final_* when cnt hits ithresh. */
+
+ if (x_state__ == 1) {
+ final_dx_x__ = dx_x__;
+ }
+ if (z_state__ == 1) {
+ final_dz_z__ = dz_z__;
+ }
+
+/* Compute error bounds. */
+
+ if (*n_norms__ >= 1) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / (
+ 1 - dxratmax);
+ }
+ if (*n_norms__ >= 2) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / (
+ 1 - dzratmax);
+ }
+
+/* Compute componentwise relative backward error from formula */
+/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. */
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ scopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ sgbmv_(trans, n, n, kl, ku, &c_b6, &ab[ab_offset], ldab, &y[j *
+ y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ayb[i__] = (r__1 = b[i__ + j * b_dim1], dabs(r__1));
+ }
+
+/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */
+
+ sla_gbamv__(trans_type__, n, n, kl, ku, &c_b8, &ab[ab_offset], ldab, &
+ y[j * y_dim1 + 1], &c__1, &c_b8, &ayb[1], &c__1);
+ sla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
+
+/* End of loop for each RHS */
+
+ }
+
+ return 0;
+} /* sla_gbrfsx_extended__ */
diff --git a/SRC/sla_gbrpvgrw.c b/SRC/sla_gbrpvgrw.c
new file mode 100644
index 0000000..f76fb79
--- /dev/null
+++ b/SRC/sla_gbrpvgrw.c
@@ -0,0 +1,136 @@
+/* sla_gbrpvgrw.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal sla_gbrpvgrw__(integer *n, integer *kl, integer *ku, integer *
+ ncols, real *ab, integer *ldab, real *afb, integer *ldafb)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, i__1, i__2, i__3, i__4;
+ real ret_val, r__1, r__2;
+
+ /* Local variables */
+ integer i__, j, kd;
+ real amax, umax, rpvgrw;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLA_GBRPVGRW computes the reciprocal pivot growth factor */
+/* norm(A)/norm(U). The "max absolute element" norm is used. If this is */
+/* much less than 1, the stability of the LU factorization of the */
+/* (equilibrated) matrix A could be poor. This also means that the */
+/* solution X, estimated condition numbers, and error bounds could be */
+/* unreliable. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NCOLS (input) INTEGER */
+/* The number of columns of the matrix A. NCOLS >= 0. */
+
+/* AB (input) REAL array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input) REAL array, dimension (LDAFB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by SGBTRF. U is stored as an upper triangular */
+/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */
+/* and the multipliers used during the factorization are stored */
+/* in rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+
+ /* Function Body */
+ rpvgrw = 1.f;
+ kd = *ku + 1;
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ amax = 0.f;
+ umax = 0.f;
+/* Computing MAX */
+ i__2 = j - *ku;
+/* Computing MIN */
+ i__4 = j + *kl;
+ i__3 = min(i__4,*n);
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ r__2 = (r__1 = ab[kd + i__ - j + j * ab_dim1], dabs(r__1));
+ amax = dmax(r__2,amax);
+ }
+/* Computing MAX */
+ i__3 = j - *ku;
+ i__2 = j;
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = (r__1 = afb[kd + i__ - j + j * afb_dim1], dabs(r__1));
+ umax = dmax(r__2,umax);
+ }
+ if (umax != 0.f) {
+/* Computing MIN */
+ r__1 = amax / umax;
+ rpvgrw = dmin(r__1,rpvgrw);
+ }
+ }
+ ret_val = rpvgrw;
+ return ret_val;
+} /* sla_gbrpvgrw__ */
diff --git a/SRC/sla_geamv.c b/SRC/sla_geamv.c
new file mode 100644
index 0000000..cfb2951
--- /dev/null
+++ b/SRC/sla_geamv.c
@@ -0,0 +1,294 @@
+/* sla_geamv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sla_geamv__(integer *trans, integer *m, integer *n, real
+ *alpha, real *a, integer *lda, real *x, integer *incx, real *beta,
+ real *y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real r__1;
+
+ /* Builtin functions */
+ double r_sign(real *, real *);
+
+ /* Local variables */
+ extern integer ilatrans_(char *);
+ integer i__, j;
+ logical symb_zero__;
+ integer iy, jx, kx, ky, info;
+ real temp;
+ integer lenx, leny;
+ real safe1;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLA_GEAMV performs one of the matrix-vector operations */
+
+/* y := alpha*abs(A)*abs(x) + beta*abs(y), */
+/* or y := alpha*abs(A)'*abs(x) + beta*abs(y), */
+
+/* where alpha and beta are scalars, x and y are vectors and A is an */
+/* m by n matrix. */
+
+/* This function is primarily used in calculating error bounds. */
+/* To protect against underflow during evaluation, components in */
+/* the resulting vector are perturbed away from zero by (N+1) */
+/* times the underflow threshold. To prevent unnecessarily large */
+/* errors for block-structure embedded in general matrices, */
+/* "symbolically" zero components are not perturbed. A zero */
+/* entry is considered "symbolic" if all multiplications involved */
+/* in computing that entry have at least one zero multiplicand. */
+
+/* Parameters */
+/* ========== */
+
+/* TRANS - INTEGER */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) */
+/* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) */
+/* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER */
+/* On entry, M specifies the number of rows of the matrix A. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - REAL array of DIMENSION ( LDA, n ) */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+/* X - REAL array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - REAL */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - REAL */
+/* Array of DIMENSION at least */
+/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
+/* Before entry with BETA non-zero, the incremented array Y */
+/* must contain the vector y. On exit, Y is overwritten by the */
+/* updated vector y. */
+
+/* INCY - INTEGER */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* Level 2 Blas routine. */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! (*trans == ilatrans_("N") || *trans == ilatrans_("T") || *trans == ilatrans_("C"))) {
+ info = 1;
+ } else if (*m < 0) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*lda < max(1,*m)) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ } else if (*incy == 0) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("SLA_GEAMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || *alpha == 0.f && *beta == 1.f) {
+ return 0;
+ }
+
+/* Set LENX and LENY, the lengths of the vectors x and y, and set */
+/* up the start points in X and Y. */
+
+ if (*trans == ilatrans_("N")) {
+ lenx = *n;
+ leny = *m;
+ } else {
+ lenx = *m;
+ leny = *n;
+ }
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (lenx - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (leny - 1) * *incy;
+ }
+
+/* Set SAFE1 essentially to be the underflow threshold times the */
+/* number of additions in each row. */
+
+ safe1 = slamch_("Safe minimum");
+ safe1 = (*n + 1) * safe1;
+
+/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */
+
+/* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to */
+/* the inexact flag. Still doesn't help change the iteration order */
+/* to per-column. */
+
+ iy = ky;
+ if (*incx == 1) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.f) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.f;
+ } else if (y[iy] == 0.f) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (r__1 = y[iy], dabs(r__1));
+ }
+ if (*alpha != 0.f) {
+ i__2 = lenx;
+ for (j = 1; j <= i__2; ++j) {
+ if (*trans == ilatrans_("N")) {
+ temp = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ } else {
+ temp = (r__1 = a[j + i__ * a_dim1], dabs(r__1));
+ }
+ symb_zero__ = symb_zero__ && (x[j] == 0.f || temp == 0.f);
+ y[iy] += *alpha * (r__1 = x[j], dabs(r__1)) * temp;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += r_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.f) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.f;
+ } else if (y[iy] == 0.f) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (r__1 = y[iy], dabs(r__1));
+ }
+ if (*alpha != 0.f) {
+ jx = kx;
+ i__2 = lenx;
+ for (j = 1; j <= i__2; ++j) {
+ if (*trans == ilatrans_("N")) {
+ temp = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ } else {
+ temp = (r__1 = a[j + i__ * a_dim1], dabs(r__1));
+ }
+ symb_zero__ = symb_zero__ && (x[jx] == 0.f || temp == 0.f)
+ ;
+ y[iy] += *alpha * (r__1 = x[jx], dabs(r__1)) * temp;
+ jx += *incx;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += r_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ }
+
+ return 0;
+
+/* End of SLA_GEAMV */
+
+} /* sla_geamv__ */
diff --git a/SRC/sla_gercond.c b/SRC/sla_gercond.c
new file mode 100644
index 0000000..031ee7a
--- /dev/null
+++ b/SRC/sla_gercond.c
@@ -0,0 +1,296 @@
+/* sla_gercond.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal sla_gercond__(char *trans, integer *n, real *a, integer *lda, real
+ *af, integer *ldaf, integer *ipiv, integer *cmode, real *c__, integer
+ *info, real *work, integer *iwork, ftnlen trans_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2;
+ real ret_val, r__1;
+
+ /* Local variables */
+ integer i__, j;
+ real tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *,
+ real *, integer *, integer *), xerbla_(char *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int sgetrs_(char *, integer *, integer *, real *,
+ integer *, integer *, real *, integer *, integer *);
+ logical notrans;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLA_GERCOND estimates the Skeel condition number of op(A) * op2(C) */
+/* where op2 is determined by CMODE as follows */
+/* CMODE = 1 op2(C) = C */
+/* CMODE = 0 op2(C) = I */
+/* CMODE = -1 op2(C) = inv(C) */
+/* The Skeel condition number cond(A) = norminf( |inv(A)||A| ) */
+/* is computed by computing scaling factors R such that */
+/* diag(R)*A*op2(C) is row equilibrated and computing the standard */
+/* infinity-norm condition number. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) REAL array, dimension (LDAF,N) */
+/* The factors L and U from the factorization */
+/* A = P*L*U as computed by SGETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from the factorization A = P*L*U */
+/* as computed by SGETRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* CMODE (input) INTEGER */
+/* Determines op2(C) in the formula op(A) * op2(C) as follows: */
+/* CMODE = 1 op2(C) = C */
+/* CMODE = 0 op2(C) = I */
+/* CMODE = -1 op2(C) = inv(C) */
+
+/* C (input) REAL array, dimension (N) */
+/* The vector C in the formula op(A) * op2(C). */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) REAL array, dimension (3*N). */
+/* Workspace. */
+
+/* IWORK (input) INTEGER array, dimension (N). */
+/* Workspace.2 */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --c__;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ *info = 0;
+ notrans = lsame_(trans, "N");
+ if (! notrans && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLA_GERCOND", &i__1);
+ return ret_val;
+ }
+ if (*n == 0) {
+ ret_val = 1.f;
+ return ret_val;
+ }
+
+/* Compute the equilibration matrix R such that */
+/* inv(R)*A*C has unit 1-norm. */
+
+ if (notrans) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ if (*cmode == 1) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[i__ + j * a_dim1] * c__[j], dabs(r__1));
+ }
+ } else if (*cmode == 0) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ }
+ } else {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[i__ + j * a_dim1] / c__[j], dabs(r__1));
+ }
+ }
+ work[(*n << 1) + i__] = tmp;
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ if (*cmode == 1) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[j + i__ * a_dim1] * c__[j], dabs(r__1));
+ }
+ } else if (*cmode == 0) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[j + i__ * a_dim1], dabs(r__1));
+ }
+ } else {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[j + i__ * a_dim1] / c__[j], dabs(r__1));
+ }
+ }
+ work[(*n << 1) + i__] = tmp;
+ }
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.f;
+ kase = 0;
+L10:
+ slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= work[(*n << 1) + i__];
+ }
+ if (notrans) {
+ sgetrs_("No transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[
+ 1], &work[1], n, info);
+ } else {
+ sgetrs_("Transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[1],
+ &work[1], n, info);
+ }
+
+/* Multiply by inv(C). */
+
+ if (*cmode == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] /= c__[i__];
+ }
+ } else if (*cmode == -1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= c__[i__];
+ }
+ }
+ } else {
+
+/* Multiply by inv(C'). */
+
+ if (*cmode == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] /= c__[i__];
+ }
+ } else if (*cmode == -1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= c__[i__];
+ }
+ }
+ if (notrans) {
+ sgetrs_("Transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[1],
+ &work[1], n, info);
+ } else {
+ sgetrs_("No transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[
+ 1], &work[1], n, info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= work[(*n << 1) + i__];
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ ret_val = 1.f / ainvnm;
+ }
+
+ return ret_val;
+
+} /* sla_gercond__ */
diff --git a/SRC/sla_gerfsx_extended.c b/SRC/sla_gerfsx_extended.c
new file mode 100644
index 0000000..c7b67d8
--- /dev/null
+++ b/SRC/sla_gerfsx_extended.c
@@ -0,0 +1,616 @@
+/* sla_gerfsx_extended.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b6 = -1.f;
+static real c_b8 = 1.f;
+
+/* Subroutine */ int sla_gerfsx_extended__(integer *prec_type__, integer *
+ trans_type__, integer *n, integer *nrhs, real *a, integer *lda, real *
+ af, integer *ldaf, integer *ipiv, logical *colequ, real *c__, real *b,
+ integer *ldb, real *y, integer *ldy, real *berr_out__, integer *
+ n_norms__, real *err_bnds_norm__, real *err_bnds_comp__, real *res,
+ real *ayb, real *dy, real *y_tail__, real *rcond, integer *ithresh,
+ real *rthresh, real *dz_ub__, logical *ignore_cwise__, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1,
+ y_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3;
+ real r__1, r__2;
+ char ch__1[1];
+
+ /* Local variables */
+ real dxratmax, dzratmax;
+ integer i__, j;
+ extern /* Subroutine */ int sla_geamv__(integer *, integer *, integer *,
+ real *, real *, integer *, real *, integer *, real *, real *,
+ integer *);
+ logical incr_prec__;
+ real prev_dz_z__, yk, final_dx_x__, final_dz_z__;
+ extern /* Subroutine */ int sla_wwaddw__(integer *, real *, real *, real *
+ );
+ real prevnormdx;
+ integer cnt;
+ real dyk, eps, incr_thresh__, dx_x__, dz_z__, ymin;
+ extern /* Subroutine */ int sla_lin_berr__(integer *, integer *, integer *
+ , real *, real *, real *), blas_sgemv_x__(integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *, integer *);
+ integer y_prec_state__;
+ extern /* Subroutine */ int blas_sgemv2_x__(integer *, integer *, integer
+ *, real *, real *, integer *, real *, real *, integer *, real *,
+ real *, integer *, integer *), sgemv_(char *, integer *, integer *
+, real *, real *, integer *, real *, integer *, real *, real *,
+ integer *);
+ real dxrat, dzrat;
+ char trans[1];
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ real normx, normy;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *);
+ extern doublereal slamch_(char *);
+ real normdx;
+ extern /* Subroutine */ int sgetrs_(char *, integer *, integer *, real *,
+ integer *, integer *, real *, integer *, integer *);
+ extern /* Character */ VOID chla_transtype__(char *, ftnlen, integer *);
+ real hugeval;
+ integer x_state__, z_state__;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLA_GERFSX_EXTENDED improves the computed solution to a system of */
+/* linear equations by performing extra-precise iterative refinement */
+/* and provides error bounds and backward error estimates for the solution. */
+/* This subroutine is called by SGERFSX to perform iterative refinement. */
+/* In addition to normwise error bound, the code provides maximum */
+/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP for details of the error bounds. Note that this */
+/* subroutine is only resonsible for setting the second fields of */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP. */
+
+/* Arguments */
+/* ========= */
+
+/* PREC_TYPE (input) INTEGER */
+/* Specifies the intermediate precision to be used in refinement. */
+/* The value is defined by ILAPREC(P) where P is a CHARACTER and */
+/* P = 'S': Single */
+/* = 'D': Double */
+/* = 'I': Indigenous */
+/* = 'X', 'E': Extra */
+
+/* TRANS_TYPE (input) INTEGER */
+/* Specifies the transposition operation on A. */
+/* The value is defined by ILATRANS(T) where T is a CHARACTER and */
+/* T = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right-hand-sides, i.e., the number of columns of the */
+/* matrix B. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) REAL array, dimension (LDAF,N) */
+/* The factors L and U from the factorization */
+/* A = P*L*U as computed by SGETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from the factorization A = P*L*U */
+/* as computed by SGETRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* COLEQU (input) LOGICAL */
+/* If .TRUE. then column equilibration was done to A before calling */
+/* this routine. This is needed to compute the solution and error */
+/* bounds correctly. */
+
+/* C (input) REAL array, dimension (N) */
+/* The column scale factors for A. If COLEQU = .FALSE., C */
+/* is not accessed. If C is input, each element of C should be a power */
+/* of the radix to ensure a reliable solution and error estimates. */
+/* Scaling by powers of the radix does not cause rounding errors unless */
+/* the result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right-hand-side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Y (input/output) REAL array, dimension (LDY,NRHS) */
+/* On entry, the solution matrix X, as computed by SGETRS. */
+/* On exit, the improved solution matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= max(1,N). */
+
+/* BERR_OUT (output) REAL array, dimension (NRHS) */
+/* On exit, BERR_OUT(j) contains the componentwise relative backward */
+/* error for right-hand-side j from the formula */
+/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. This is computed by SLA_LIN_BERR. */
+
+/* N_NORMS (input) INTEGER */
+/* Determines which error bounds to return (see ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP). */
+/* If N_NORMS >= 1 return normwise error bounds. */
+/* If N_NORMS >= 2 return componentwise error bounds. */
+
+/* ERR_BNDS_NORM (input/output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (input/output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* RES (input) REAL array, dimension (N) */
+/* Workspace to hold the intermediate residual. */
+
+/* AYB (input) REAL array, dimension (N) */
+/* Workspace. This can be the same workspace passed for Y_TAIL. */
+
+/* DY (input) REAL array, dimension (N) */
+/* Workspace to hold the intermediate solution. */
+
+/* Y_TAIL (input) REAL array, dimension (N) */
+/* Workspace to hold the trailing bits of the intermediate solution. */
+
+/* RCOND (input) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* ITHRESH (input) INTEGER */
+/* The maximum number of residual computations allowed for */
+/* refinement. The default is 10. For 'aggressive' set to 100 to */
+/* permit convergence using approximate factorizations or */
+/* factorizations other than LU. If the factorization uses a */
+/* technique other than Gaussian elimination, the guarantees in */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */
+
+/* RTHRESH (input) REAL */
+/* Determines when to stop refinement if the error estimate stops */
+/* decreasing. Refinement will stop when the next solution no longer */
+/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */
+/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */
+/* default value is 0.5. For 'aggressive' set to 0.9 to permit */
+/* convergence on extremely ill-conditioned matrices. See LAWN 165 */
+/* for more details. */
+
+/* DZ_UB (input) REAL */
+/* Determines when to start considering componentwise convergence. */
+/* Componentwise convergence is only considered after each component */
+/* of the solution Y is stable, which we definte as the relative */
+/* change in each component being less than DZ_UB. The default value */
+/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */
+/* more details. */
+
+/* IGNORE_CWISE (input) LOGICAL */
+/* If .TRUE. then ignore componentwise convergence. Default value */
+/* is .FALSE.. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* < 0: if INFO = -i, the ith argument to SGETRS had an illegal */
+/* value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ --berr_out__;
+ --res;
+ --ayb;
+ --dy;
+ --y_tail__;
+
+ /* Function Body */
+ if (*info != 0) {
+ return 0;
+ }
+ chla_transtype__(ch__1, (ftnlen)1, trans_type__);
+ *(unsigned char *)trans = *(unsigned char *)&ch__1[0];
+ eps = slamch_("Epsilon");
+ hugeval = slamch_("Overflow");
+/* Force HUGEVAL to Inf */
+ hugeval *= hugeval;
+/* Using HUGEVAL may lead to spurious underflows. */
+ incr_thresh__ = (real) (*n) * eps;
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ y_prec_state__ = 1;
+ if (y_prec_state__ == 2) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ y_tail__[i__] = 0.f;
+ }
+ }
+ dxrat = 0.f;
+ dxratmax = 0.f;
+ dzrat = 0.f;
+ dzratmax = 0.f;
+ final_dx_x__ = hugeval;
+ final_dz_z__ = hugeval;
+ prevnormdx = hugeval;
+ prev_dz_z__ = hugeval;
+ dz_z__ = hugeval;
+ dx_x__ = hugeval;
+ x_state__ = 1;
+ z_state__ = 0;
+ incr_prec__ = FALSE_;
+ i__2 = *ithresh;
+ for (cnt = 1; cnt <= i__2; ++cnt) {
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ scopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ if (y_prec_state__ == 0) {
+ sgemv_(trans, n, n, &c_b6, &a[a_offset], lda, &y[j * y_dim1 +
+ 1], &c__1, &c_b8, &res[1], &c__1);
+ } else if (y_prec_state__ == 1) {
+ blas_sgemv_x__(trans_type__, n, n, &c_b6, &a[a_offset], lda, &
+ y[j * y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1,
+ prec_type__);
+ } else {
+ blas_sgemv2_x__(trans_type__, n, n, &c_b6, &a[a_offset], lda,
+ &y[j * y_dim1 + 1], &y_tail__[1], &c__1, &c_b8, &res[
+ 1], &c__1, prec_type__);
+ }
+/* XXX: RES is no longer needed. */
+ scopy_(n, &res[1], &c__1, &dy[1], &c__1);
+ sgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &dy[1],
+ n, info);
+
+/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
+
+ normx = 0.f;
+ normy = 0.f;
+ normdx = 0.f;
+ dz_z__ = 0.f;
+ ymin = hugeval;
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ yk = (r__1 = y[i__ + j * y_dim1], dabs(r__1));
+ dyk = (r__1 = dy[i__], dabs(r__1));
+ if (yk != 0.f) {
+/* Computing MAX */
+ r__1 = dz_z__, r__2 = dyk / yk;
+ dz_z__ = dmax(r__1,r__2);
+ } else if (dyk != 0.f) {
+ dz_z__ = hugeval;
+ }
+ ymin = dmin(ymin,yk);
+ normy = dmax(normy,yk);
+ if (*colequ) {
+/* Computing MAX */
+ r__1 = normx, r__2 = yk * c__[i__];
+ normx = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = normdx, r__2 = dyk * c__[i__];
+ normdx = dmax(r__1,r__2);
+ } else {
+ normx = normy;
+ normdx = dmax(normdx,dyk);
+ }
+ }
+ if (normx != 0.f) {
+ dx_x__ = normdx / normx;
+ } else if (normdx == 0.f) {
+ dx_x__ = 0.f;
+ } else {
+ dx_x__ = hugeval;
+ }
+ dxrat = normdx / prevnormdx;
+ dzrat = dz_z__ / prev_dz_z__;
+
+/* Check termination criteria */
+
+ if (! (*ignore_cwise__) && ymin * *rcond < incr_thresh__ * normy
+ && y_prec_state__ < 2) {
+ incr_prec__ = TRUE_;
+ }
+ if (x_state__ == 3 && dxrat <= *rthresh) {
+ x_state__ = 1;
+ }
+ if (x_state__ == 1) {
+ if (dx_x__ <= eps) {
+ x_state__ = 2;
+ } else if (dxrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ x_state__ = 3;
+ }
+ } else {
+ if (dxrat > dxratmax) {
+ dxratmax = dxrat;
+ }
+ }
+ if (x_state__ > 1) {
+ final_dx_x__ = dx_x__;
+ }
+ }
+ if (z_state__ == 0 && dz_z__ <= *dz_ub__) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 3 && dzrat <= *rthresh) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 1) {
+ if (dz_z__ <= eps) {
+ z_state__ = 2;
+ } else if (dz_z__ > *dz_ub__) {
+ z_state__ = 0;
+ dzratmax = 0.f;
+ final_dz_z__ = hugeval;
+ } else if (dzrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ z_state__ = 3;
+ }
+ } else {
+ if (dzrat > dzratmax) {
+ dzratmax = dzrat;
+ }
+ }
+ if (z_state__ > 1) {
+ final_dz_z__ = dz_z__;
+ }
+ }
+
+/* Exit if both normwise and componentwise stopped working, */
+/* but if componentwise is unstable, let it go at least two */
+/* iterations. */
+
+ if (x_state__ != 1) {
+ if (*ignore_cwise__) {
+ goto L666;
+ }
+ if (z_state__ == 3 || z_state__ == 2) {
+ goto L666;
+ }
+ if (z_state__ == 0 && cnt > 1) {
+ goto L666;
+ }
+ }
+ if (incr_prec__) {
+ incr_prec__ = FALSE_;
+ ++y_prec_state__;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ y_tail__[i__] = 0.f;
+ }
+ }
+ prevnormdx = normdx;
+ prev_dz_z__ = dz_z__;
+
+/* Update soluton. */
+
+ if (y_prec_state__ < 2) {
+ saxpy_(n, &c_b8, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
+ } else {
+ sla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
+ }
+ }
+/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */
+L666:
+
+/* Set final_* when cnt hits ithresh. */
+
+ if (x_state__ == 1) {
+ final_dx_x__ = dx_x__;
+ }
+ if (z_state__ == 1) {
+ final_dz_z__ = dz_z__;
+ }
+
+/* Compute error bounds */
+
+ if (*n_norms__ >= 1) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / (
+ 1 - dxratmax);
+ }
+ if (*n_norms__ >= 2) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / (
+ 1 - dzratmax);
+ }
+
+/* Compute componentwise relative backward error from formula */
+/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. */
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ scopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ sgemv_(trans, n, n, &c_b6, &a[a_offset], lda, &y[j * y_dim1 + 1], &
+ c__1, &c_b8, &res[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ayb[i__] = (r__1 = b[i__ + j * b_dim1], dabs(r__1));
+ }
+
+/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */
+
+ sla_geamv__(trans_type__, n, n, &c_b8, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &c__1, &c_b8, &ayb[1], &c__1);
+ sla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
+
+/* End of loop for each RHS. */
+
+ }
+
+ return 0;
+} /* sla_gerfsx_extended__ */
diff --git a/SRC/sla_lin_berr.c b/SRC/sla_lin_berr.c
new file mode 100644
index 0000000..088859f
--- /dev/null
+++ b/SRC/sla_lin_berr.c
@@ -0,0 +1,124 @@
+/* sla_lin_berr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sla_lin_berr__(integer *n, integer *nz, integer *nrhs,
+ real *res, real *ayb, real *berr)
+{
+ /* System generated locals */
+ integer ayb_dim1, ayb_offset, res_dim1, res_offset, i__1, i__2;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j;
+ real tmp, safe1;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLA_LIN_BERR computes componentwise relative backward error from */
+/* the formula */
+/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. */
+
+/* Arguments */
+/* ========== */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NZ (input) INTEGER */
+/* We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to */
+/* guard against spuriously zero residuals. Default value is N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices AYB, RES, and BERR. NRHS >= 0. */
+
+/* RES (input) REAL array, dimension (N,NRHS) */
+/* The residual matrix, i.e., the matrix R in the relative backward */
+/* error formula above. */
+
+/* AYB (input) REAL array, dimension (N, NRHS) */
+/* The denominator in the relative backward error formula above, i.e., */
+/* the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B */
+/* are from iterative refinement (see sla_gerfsx_extended.f). */
+
+/* RES (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error from the formula above. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Adding SAFE1 to the numerator guards against spuriously zero */
+/* residuals. A similar safeguard is in the SLA_yyAMV routine used */
+/* to compute AYB. */
+
+ /* Parameter adjustments */
+ --berr;
+ ayb_dim1 = *n;
+ ayb_offset = 1 + ayb_dim1;
+ ayb -= ayb_offset;
+ res_dim1 = *n;
+ res_offset = 1 + res_dim1;
+ res -= res_offset;
+
+ /* Function Body */
+ safe1 = slamch_("Safe minimum");
+ safe1 = (*nz + 1) * safe1;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (ayb[i__ + j * ayb_dim1] != 0.f) {
+ tmp = (safe1 + (r__1 = res[i__ + j * res_dim1], dabs(r__1))) /
+ ayb[i__ + j * ayb_dim1];
+/* Computing MAX */
+ r__1 = berr[j];
+ berr[j] = dmax(r__1,tmp);
+ }
+
+/* If AYB is exactly 0.0 (and if computed by SLA_yyAMV), then we know */
+/* the true residual also must be exactly 0.0. */
+
+ }
+ }
+ return 0;
+} /* sla_lin_berr__ */
diff --git a/SRC/sla_porcond.c b/SRC/sla_porcond.c
new file mode 100644
index 0000000..6c844ff
--- /dev/null
+++ b/SRC/sla_porcond.c
@@ -0,0 +1,308 @@
+/* sla_porcond.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal sla_porcond__(char *uplo, integer *n, real *a, integer *lda, real *
+ af, integer *ldaf, integer *cmode, real *c__, integer *info, real *
+ work, integer *iwork, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2;
+ real ret_val, r__1;
+
+ /* Local variables */
+ integer i__, j;
+ logical up;
+ real tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *,
+ real *, integer *, integer *), xerbla_(char *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int spotrs_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLA_PORCOND Estimates the Skeel condition number of op(A) * op2(C) */
+/* where op2 is determined by CMODE as follows */
+/* CMODE = 1 op2(C) = C */
+/* CMODE = 0 op2(C) = I */
+/* CMODE = -1 op2(C) = inv(C) */
+/* The Skeel condition number cond(A) = norminf( |inv(A)||A| ) */
+/* is computed by computing scaling factors R such that */
+/* diag(R)*A*op2(C) is row equilibrated and computing the standard */
+/* infinity-norm condition number. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) REAL array, dimension (LDAF,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by SPOTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* CMODE (input) INTEGER */
+/* Determines op2(C) in the formula op(A) * op2(C) as follows: */
+/* CMODE = 1 op2(C) = C */
+/* CMODE = 0 op2(C) = I */
+/* CMODE = -1 op2(C) = inv(C) */
+
+/* C (input) REAL array, dimension (N) */
+/* The vector C in the formula op(A) * op2(C). */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) REAL array, dimension (3*N). */
+/* Workspace. */
+
+/* IWORK (input) INTEGER array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --c__;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ *info = 0;
+ if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLA_PORCOND", &i__1);
+ return ret_val;
+ }
+ if (*n == 0) {
+ ret_val = 1.f;
+ return ret_val;
+ }
+ up = FALSE_;
+ if (lsame_(uplo, "U")) {
+ up = TRUE_;
+ }
+
+/* Compute the equilibration matrix R such that */
+/* inv(R)*A*C has unit 1-norm. */
+
+ if (up) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ if (*cmode == 1) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[j + i__ * a_dim1] * c__[j], dabs(r__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[i__ + j * a_dim1] * c__[j], dabs(r__1));
+ }
+ } else if (*cmode == 0) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[j + i__ * a_dim1], dabs(r__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[j + i__ * a_dim1] / c__[j], dabs(r__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[i__ + j * a_dim1] / c__[j], dabs(r__1));
+ }
+ }
+ work[(*n << 1) + i__] = tmp;
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ if (*cmode == 1) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[i__ + j * a_dim1] * c__[j], dabs(r__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[j + i__ * a_dim1] * c__[j], dabs(r__1));
+ }
+ } else if (*cmode == 0) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[j + i__ * a_dim1], dabs(r__1));
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[i__ + j * a_dim1] / c__[j], dabs(r__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[j + i__ * a_dim1] / c__[j], dabs(r__1));
+ }
+ }
+ work[(*n << 1) + i__] = tmp;
+ }
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.f;
+ kase = 0;
+L10:
+ slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= work[(*n << 1) + i__];
+ }
+ if (up) {
+ spotrs_("Upper", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ } else {
+ spotrs_("Lower", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ }
+
+/* Multiply by inv(C). */
+
+ if (*cmode == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] /= c__[i__];
+ }
+ } else if (*cmode == -1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= c__[i__];
+ }
+ }
+ } else {
+
+/* Multiply by inv(C'). */
+
+ if (*cmode == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] /= c__[i__];
+ }
+ } else if (*cmode == -1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= c__[i__];
+ }
+ }
+ if (up) {
+ spotrs_("Upper", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ } else {
+ spotrs_("Lower", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= work[(*n << 1) + i__];
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ ret_val = 1.f / ainvnm;
+ }
+
+ return ret_val;
+
+} /* sla_porcond__ */
diff --git a/SRC/sla_porfsx_extended.c b/SRC/sla_porfsx_extended.c
new file mode 100644
index 0000000..7e9ba4e
--- /dev/null
+++ b/SRC/sla_porfsx_extended.c
@@ -0,0 +1,593 @@
+/* sla_porfsx_extended.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b9 = -1.f;
+static real c_b11 = 1.f;
+
+/* Subroutine */ int sla_porfsx_extended__(integer *prec_type__, char *uplo,
+ integer *n, integer *nrhs, real *a, integer *lda, real *af, integer *
+ ldaf, logical *colequ, real *c__, real *b, integer *ldb, real *y,
+ integer *ldy, real *berr_out__, integer *n_norms__, real *
+ err_bnds_norm__, real *err_bnds_comp__, real *res, real *ayb, real *
+ dy, real *y_tail__, real *rcond, integer *ithresh, real *rthresh,
+ real *dz_ub__, logical *ignore_cwise__, integer *info, ftnlen
+ uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1,
+ y_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3;
+ real r__1, r__2;
+
+ /* Local variables */
+ real dxratmax, dzratmax;
+ integer i__, j;
+ logical incr_prec__;
+ extern /* Subroutine */ int sla_syamv__(integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ real prev_dz_z__, yk, final_dx_x__, final_dz_z__;
+ extern /* Subroutine */ int sla_wwaddw__(integer *, real *, real *, real *
+ );
+ real prevnormdx;
+ integer cnt;
+ real dyk, eps, incr_thresh__, dx_x__, dz_z__, ymin;
+ extern /* Subroutine */ int sla_lin_berr__(integer *, integer *, integer *
+ , real *, real *, real *);
+ integer y_prec_state__, uplo2;
+ extern /* Subroutine */ int blas_ssymv_x__(integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ real dxrat, dzrat;
+ extern /* Subroutine */ int blas_ssymv2_x__(integer *, integer *, real *,
+ real *, integer *, real *, real *, integer *, real *, real *,
+ integer *, integer *), scopy_(integer *, real *, integer *, real *
+, integer *);
+ real normx, normy;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *), ssymv_(char *, integer *, real *, real *,
+ integer *, real *, integer *, real *, real *, integer *);
+ extern doublereal slamch_(char *);
+ real normdx;
+ extern /* Subroutine */ int spotrs_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, integer *);
+ real hugeval;
+ extern integer ilauplo_(char *);
+ integer x_state__, z_state__;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLA_PORFSX_EXTENDED improves the computed solution to a system of */
+/* linear equations by performing extra-precise iterative refinement */
+/* and provides error bounds and backward error estimates for the solution. */
+/* This subroutine is called by SPORFSX to perform iterative refinement. */
+/* In addition to normwise error bound, the code provides maximum */
+/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP for details of the error bounds. Note that this */
+/* subroutine is only resonsible for setting the second fields of */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP. */
+
+/* Arguments */
+/* ========= */
+
+/* PREC_TYPE (input) INTEGER */
+/* Specifies the intermediate precision to be used in refinement. */
+/* The value is defined by ILAPREC(P) where P is a CHARACTER and */
+/* P = 'S': Single */
+/* = 'D': Double */
+/* = 'I': Indigenous */
+/* = 'X', 'E': Extra */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right-hand-sides, i.e., the number of columns of the */
+/* matrix B. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) REAL array, dimension (LDAF,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by SPOTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* COLEQU (input) LOGICAL */
+/* If .TRUE. then column equilibration was done to A before calling */
+/* this routine. This is needed to compute the solution and error */
+/* bounds correctly. */
+
+/* C (input) REAL array, dimension (N) */
+/* The column scale factors for A. If COLEQU = .FALSE., C */
+/* is not accessed. If C is input, each element of C should be a power */
+/* of the radix to ensure a reliable solution and error estimates. */
+/* Scaling by powers of the radix does not cause rounding errors unless */
+/* the result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right-hand-side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Y (input/output) REAL array, dimension (LDY,NRHS) */
+/* On entry, the solution matrix X, as computed by SPOTRS. */
+/* On exit, the improved solution matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= max(1,N). */
+
+/* BERR_OUT (output) REAL array, dimension (NRHS) */
+/* On exit, BERR_OUT(j) contains the componentwise relative backward */
+/* error for right-hand-side j from the formula */
+/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. This is computed by SLA_LIN_BERR. */
+
+/* N_NORMS (input) INTEGER */
+/* Determines which error bounds to return (see ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP). */
+/* If N_NORMS >= 1 return normwise error bounds. */
+/* If N_NORMS >= 2 return componentwise error bounds. */
+
+/* ERR_BNDS_NORM (input/output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (input/output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* RES (input) REAL array, dimension (N) */
+/* Workspace to hold the intermediate residual. */
+
+/* AYB (input) REAL array, dimension (N) */
+/* Workspace. This can be the same workspace passed for Y_TAIL. */
+
+/* DY (input) REAL array, dimension (N) */
+/* Workspace to hold the intermediate solution. */
+
+/* Y_TAIL (input) REAL array, dimension (N) */
+/* Workspace to hold the trailing bits of the intermediate solution. */
+
+/* RCOND (input) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* ITHRESH (input) INTEGER */
+/* The maximum number of residual computations allowed for */
+/* refinement. The default is 10. For 'aggressive' set to 100 to */
+/* permit convergence using approximate factorizations or */
+/* factorizations other than LU. If the factorization uses a */
+/* technique other than Gaussian elimination, the guarantees in */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */
+
+/* RTHRESH (input) REAL */
+/* Determines when to stop refinement if the error estimate stops */
+/* decreasing. Refinement will stop when the next solution no longer */
+/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */
+/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */
+/* default value is 0.5. For 'aggressive' set to 0.9 to permit */
+/* convergence on extremely ill-conditioned matrices. See LAWN 165 */
+/* for more details. */
+
+/* DZ_UB (input) REAL */
+/* Determines when to start considering componentwise convergence. */
+/* Componentwise convergence is only considered after each component */
+/* of the solution Y is stable, which we definte as the relative */
+/* change in each component being less than DZ_UB. The default value */
+/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */
+/* more details. */
+
+/* IGNORE_CWISE (input) LOGICAL */
+/* If .TRUE. then ignore componentwise convergence. Default value */
+/* is .FALSE.. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* < 0: if INFO = -i, the ith argument to SPOTRS had an illegal */
+/* value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ --berr_out__;
+ --res;
+ --ayb;
+ --dy;
+ --y_tail__;
+
+ /* Function Body */
+ if (*info != 0) {
+ return 0;
+ }
+ eps = slamch_("Epsilon");
+ hugeval = slamch_("Overflow");
+/* Force HUGEVAL to Inf */
+ hugeval *= hugeval;
+/* Using HUGEVAL may lead to spurious underflows. */
+ incr_thresh__ = (real) (*n) * eps;
+ if (lsame_(uplo, "L")) {
+ uplo2 = ilauplo_("L");
+ } else {
+ uplo2 = ilauplo_("U");
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ y_prec_state__ = 1;
+ if (y_prec_state__ == 2) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ y_tail__[i__] = 0.f;
+ }
+ }
+ dxrat = 0.f;
+ dxratmax = 0.f;
+ dzrat = 0.f;
+ dzratmax = 0.f;
+ final_dx_x__ = hugeval;
+ final_dz_z__ = hugeval;
+ prevnormdx = hugeval;
+ prev_dz_z__ = hugeval;
+ dz_z__ = hugeval;
+ dx_x__ = hugeval;
+ x_state__ = 1;
+ z_state__ = 0;
+ incr_prec__ = FALSE_;
+ i__2 = *ithresh;
+ for (cnt = 1; cnt <= i__2; ++cnt) {
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ scopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ if (y_prec_state__ == 0) {
+ ssymv_(uplo, n, &c_b9, &a[a_offset], lda, &y[j * y_dim1 + 1],
+ &c__1, &c_b11, &res[1], &c__1);
+ } else if (y_prec_state__ == 1) {
+ blas_ssymv_x__(&uplo2, n, &c_b9, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &c__1, &c_b11, &res[1], &c__1,
+ prec_type__);
+ } else {
+ blas_ssymv2_x__(&uplo2, n, &c_b9, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &y_tail__[1], &c__1, &c_b11, &res[1], &
+ c__1, prec_type__);
+ }
+/* XXX: RES is no longer needed. */
+ scopy_(n, &res[1], &c__1, &dy[1], &c__1);
+ spotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &dy[1], n, info);
+
+/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
+
+ normx = 0.f;
+ normy = 0.f;
+ normdx = 0.f;
+ dz_z__ = 0.f;
+ ymin = hugeval;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ yk = (r__1 = y[i__ + j * y_dim1], dabs(r__1));
+ dyk = (r__1 = dy[i__], dabs(r__1));
+ if (yk != 0.f) {
+/* Computing MAX */
+ r__1 = dz_z__, r__2 = dyk / yk;
+ dz_z__ = dmax(r__1,r__2);
+ } else if (dyk != 0.f) {
+ dz_z__ = hugeval;
+ }
+ ymin = dmin(ymin,yk);
+ normy = dmax(normy,yk);
+ if (*colequ) {
+/* Computing MAX */
+ r__1 = normx, r__2 = yk * c__[i__];
+ normx = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = normdx, r__2 = dyk * c__[i__];
+ normdx = dmax(r__1,r__2);
+ } else {
+ normx = normy;
+ normdx = dmax(normdx,dyk);
+ }
+ }
+ if (normx != 0.f) {
+ dx_x__ = normdx / normx;
+ } else if (normdx == 0.f) {
+ dx_x__ = 0.f;
+ } else {
+ dx_x__ = hugeval;
+ }
+ dxrat = normdx / prevnormdx;
+ dzrat = dz_z__ / prev_dz_z__;
+
+/* Check termination criteria. */
+
+ if (ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2) {
+ incr_prec__ = TRUE_;
+ }
+ if (x_state__ == 3 && dxrat <= *rthresh) {
+ x_state__ = 1;
+ }
+ if (x_state__ == 1) {
+ if (dx_x__ <= eps) {
+ x_state__ = 2;
+ } else if (dxrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ x_state__ = 3;
+ }
+ } else {
+ if (dxrat > dxratmax) {
+ dxratmax = dxrat;
+ }
+ }
+ if (x_state__ > 1) {
+ final_dx_x__ = dx_x__;
+ }
+ }
+ if (z_state__ == 0 && dz_z__ <= *dz_ub__) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 3 && dzrat <= *rthresh) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 1) {
+ if (dz_z__ <= eps) {
+ z_state__ = 2;
+ } else if (dz_z__ > *dz_ub__) {
+ z_state__ = 0;
+ dzratmax = 0.f;
+ final_dz_z__ = hugeval;
+ } else if (dzrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ z_state__ = 3;
+ }
+ } else {
+ if (dzrat > dzratmax) {
+ dzratmax = dzrat;
+ }
+ }
+ if (z_state__ > 1) {
+ final_dz_z__ = dz_z__;
+ }
+ }
+ if (x_state__ != 1 && (*ignore_cwise__ || z_state__ != 1)) {
+ goto L666;
+ }
+ if (incr_prec__) {
+ incr_prec__ = FALSE_;
+ ++y_prec_state__;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ y_tail__[i__] = 0.f;
+ }
+ }
+ prevnormdx = normdx;
+ prev_dz_z__ = dz_z__;
+
+/* Update soluton. */
+
+ if (y_prec_state__ < 2) {
+ saxpy_(n, &c_b11, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
+ } else {
+ sla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
+ }
+ }
+/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */
+L666:
+
+/* Set final_* when cnt hits ithresh. */
+
+ if (x_state__ == 1) {
+ final_dx_x__ = dx_x__;
+ }
+ if (z_state__ == 1) {
+ final_dz_z__ = dz_z__;
+ }
+
+/* Compute error bounds. */
+
+ if (*n_norms__ >= 1) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / (
+ 1 - dxratmax);
+ }
+ if (*n_norms__ >= 2) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / (
+ 1 - dzratmax);
+ }
+
+/* Compute componentwise relative backward error from formula */
+/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. */
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ scopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ ssymv_(uplo, n, &c_b9, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1, &
+ c_b11, &res[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ayb[i__] = (r__1 = b[i__ + j * b_dim1], dabs(r__1));
+ }
+
+/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */
+
+ sla_syamv__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1],
+ &c__1, &c_b11, &ayb[1], &c__1);
+ sla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
+
+/* End of loop for each RHS. */
+
+ }
+
+ return 0;
+} /* sla_porfsx_extended__ */
diff --git a/SRC/sla_porpvgrw.c b/SRC/sla_porpvgrw.c
new file mode 100644
index 0000000..7a2a81a
--- /dev/null
+++ b/SRC/sla_porpvgrw.c
@@ -0,0 +1,197 @@
+/* sla_porpvgrw.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal sla_porpvgrw__(char *uplo, integer *ncols, real *a, integer *lda,
+ real *af, integer *ldaf, real *work, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2;
+ real ret_val, r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j;
+ real amax, umax;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ real rpvgrw;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLA_PORPVGRW computes the reciprocal pivot growth factor */
+/* norm(A)/norm(U). The "max absolute element" norm is used. If this is */
+/* much less than 1, the stability of the LU factorization of the */
+/* (equilibrated) matrix A could be poor. This also means that the */
+/* solution X, estimated condition numbers, and error bounds could be */
+/* unreliable. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* NCOLS (input) INTEGER */
+/* The number of columns of the matrix A. NCOLS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) REAL array, dimension (LDAF,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by SPOTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* WORK (input) REAL array, dimension (2*N) */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --work;
+
+ /* Function Body */
+ upper = lsame_("Upper", uplo);
+
+/* SPOTRF will have factored only the NCOLSxNCOLS leading minor, so */
+/* we restrict the growth search to that minor and use only the first */
+/* 2*NCOLS workspace entries. */
+
+ rpvgrw = 1.f;
+ i__1 = *ncols << 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+ }
+
+/* Find the max magnitude entry of each column. */
+
+ if (upper) {
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = (r__1 = a[i__ + j * a_dim1], dabs(r__1)), r__3 = work[*
+ ncols + j];
+ work[*ncols + j] = dmax(r__2,r__3);
+ }
+ }
+ } else {
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *ncols;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = (r__1 = a[i__ + j * a_dim1], dabs(r__1)), r__3 = work[*
+ ncols + j];
+ work[*ncols + j] = dmax(r__2,r__3);
+ }
+ }
+ }
+
+/* Now find the max magnitude entry of each column of the factor in */
+/* AF. No pivoting, so no permutations. */
+
+ if (lsame_("Upper", uplo)) {
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = (r__1 = af[i__ + j * af_dim1], dabs(r__1)), r__3 =
+ work[j];
+ work[j] = dmax(r__2,r__3);
+ }
+ }
+ } else {
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *ncols;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = (r__1 = af[i__ + j * af_dim1], dabs(r__1)), r__3 =
+ work[j];
+ work[j] = dmax(r__2,r__3);
+ }
+ }
+ }
+
+/* Compute the *inverse* of the max element growth factor. Dividing */
+/* by zero would imply the largest entry of the factor's column is */
+/* zero. Than can happen when either the column of A is zero or */
+/* massive pivots made the factor underflow to zero. Neither counts */
+/* as growth in itself, so simply ignore terms with zero */
+/* denominators. */
+
+ if (lsame_("Upper", uplo)) {
+ i__1 = *ncols;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ umax = work[i__];
+ amax = work[*ncols + i__];
+ if (umax != 0.f) {
+/* Computing MIN */
+ r__1 = amax / umax;
+ rpvgrw = dmin(r__1,rpvgrw);
+ }
+ }
+ } else {
+ i__1 = *ncols;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ umax = work[i__];
+ amax = work[*ncols + i__];
+ if (umax != 0.f) {
+/* Computing MIN */
+ r__1 = amax / umax;
+ rpvgrw = dmin(r__1,rpvgrw);
+ }
+ }
+ }
+ ret_val = rpvgrw;
+ return ret_val;
+} /* sla_porpvgrw__ */
diff --git a/SRC/sla_rpvgrw.c b/SRC/sla_rpvgrw.c
new file mode 100644
index 0000000..0fefb2c
--- /dev/null
+++ b/SRC/sla_rpvgrw.c
@@ -0,0 +1,117 @@
+/* sla_rpvgrw.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal sla_rpvgrw__(integer *n, integer *ncols, real *a, integer *lda,
+ real *af, integer *ldaf)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2;
+ real ret_val, r__1, r__2;
+
+ /* Local variables */
+ integer i__, j;
+ real amax, umax, rpvgrw;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLA_RPVGRW computes the reciprocal pivot growth factor */
+/* norm(A)/norm(U). The "max absolute element" norm is used. If this is */
+/* much less than 1, the stability of the LU factorization of the */
+/* (equilibrated) matrix A could be poor. This also means that the */
+/* solution X, estimated condition numbers, and error bounds could be */
+/* unreliable. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NCOLS (input) INTEGER */
+/* The number of columns of the matrix A. NCOLS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) REAL array, dimension (LDAF,N) */
+/* The factors L and U from the factorization */
+/* A = P*L*U as computed by SGETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+
+ /* Function Body */
+ rpvgrw = 1.f;
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ amax = 0.f;
+ umax = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ amax = dmax(r__2,amax);
+ }
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = (r__1 = af[i__ + j * af_dim1], dabs(r__1));
+ umax = dmax(r__2,umax);
+ }
+ if (umax != 0.f) {
+/* Computing MIN */
+ r__1 = amax / umax;
+ rpvgrw = dmin(r__1,rpvgrw);
+ }
+ }
+ ret_val = rpvgrw;
+ return ret_val;
+} /* sla_rpvgrw__ */
diff --git a/SRC/sla_syamv.c b/SRC/sla_syamv.c
new file mode 100644
index 0000000..6822b8a
--- /dev/null
+++ b/SRC/sla_syamv.c
@@ -0,0 +1,299 @@
+/* sla_syamv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sla_syamv__(integer *uplo, integer *n, real *alpha, real
+ *a, integer *lda, real *x, integer *incx, real *beta, real *y,
+ integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real r__1;
+
+ /* Builtin functions */
+ double r_sign(real *, real *);
+
+ /* Local variables */
+ integer i__, j;
+ logical symb_zero__;
+ integer iy, jx, kx, ky, info;
+ real temp, safe1;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilauplo_(char *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLA_SYAMV performs the matrix-vector operation */
+
+/* y := alpha*abs(A)*abs(x) + beta*abs(y), */
+
+/* where alpha and beta are scalars, x and y are vectors and A is an */
+/* n by n symmetric matrix. */
+
+/* This function is primarily used in calculating error bounds. */
+/* To protect against underflow during evaluation, components in */
+/* the resulting vector are perturbed away from zero by (N+1) */
+/* times the underflow threshold. To prevent unnecessarily large */
+/* errors for block-structure embedded in general matrices, */
+/* "symbolically" zero components are not perturbed. A zero */
+/* entry is considered "symbolic" if all multiplications involved */
+/* in computing that entry have at least one zero multiplicand. */
+
+/* Parameters */
+/* ========== */
+
+/* UPLO - INTEGER */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array A is to be referenced as */
+/* follows: */
+
+/* UPLO = BLAS_UPPER Only the upper triangular part of A */
+/* is to be referenced. */
+
+/* UPLO = BLAS_LOWER Only the lower triangular part of A */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - REAL . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - REAL array of DIMENSION ( LDA, n ). */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+/* X - REAL array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ) */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - REAL . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - REAL array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ) */
+/* Before entry with BETA non-zero, the incremented array Y */
+/* must contain the vector y. On exit, Y is overwritten by the */
+/* updated vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+/* -- Modified for the absolute-value product, April 2006 */
+/* Jason Riedy, UC Berkeley */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (*uplo != ilauplo_("U") && *uplo != ilauplo_("L")
+ ) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*lda < max(1,*n)) {
+ info = 5;
+ } else if (*incx == 0) {
+ info = 7;
+ } else if (*incy == 0) {
+ info = 10;
+ }
+ if (info != 0) {
+ xerbla_("SSYMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0.f && *beta == 1.f) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Set SAFE1 essentially to be the underflow threshold times the */
+/* number of additions in each row. */
+
+ safe1 = slamch_("Safe minimum");
+ safe1 = (*n + 1) * safe1;
+
+/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */
+
+/* The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to */
+/* the inexact flag. Still doesn't help change the iteration order */
+/* to per-column. */
+
+ iy = ky;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.f) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.f;
+ } else if (y[iy] == 0.f) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (r__1 = y[iy], dabs(r__1));
+ }
+ if (*alpha != 0.f) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (*uplo == ilauplo_("U")) {
+ if (i__ <= j) {
+ temp = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ } else {
+ temp = (r__1 = a[j + i__ * a_dim1], dabs(r__1));
+ }
+ } else {
+ if (i__ >= j) {
+ temp = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ } else {
+ temp = (r__1 = a[j + i__ * a_dim1], dabs(r__1));
+ }
+ }
+ symb_zero__ = symb_zero__ && (x[j] == 0.f || temp == 0.f);
+ y[iy] += *alpha * (r__1 = x[j], dabs(r__1)) * temp;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += r_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.f) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.f;
+ } else if (y[iy] == 0.f) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (r__1 = y[iy], dabs(r__1));
+ }
+ jx = kx;
+ if (*alpha != 0.f) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (*uplo == ilauplo_("U")) {
+ if (i__ <= j) {
+ temp = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ } else {
+ temp = (r__1 = a[j + i__ * a_dim1], dabs(r__1));
+ }
+ } else {
+ if (i__ >= j) {
+ temp = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ } else {
+ temp = (r__1 = a[j + i__ * a_dim1], dabs(r__1));
+ }
+ }
+ symb_zero__ = symb_zero__ && (x[j] == 0.f || temp == 0.f);
+ y[iy] += *alpha * (r__1 = x[jx], dabs(r__1)) * temp;
+ jx += *incx;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += r_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ }
+
+ return 0;
+
+/* End of SLA_SYAMV */
+
+} /* sla_syamv__ */
diff --git a/SRC/sla_syrcond.c b/SRC/sla_syrcond.c
new file mode 100644
index 0000000..d2f2f79
--- /dev/null
+++ b/SRC/sla_syrcond.c
@@ -0,0 +1,320 @@
+/* sla_syrcond.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal sla_syrcond__(char *uplo, integer *n, real *a, integer *lda, real *
+ af, integer *ldaf, integer *ipiv, integer *cmode, real *c__, integer *
+ info, real *work, integer *iwork, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2;
+ real ret_val, r__1;
+
+ /* Local variables */
+ integer i__, j;
+ logical up;
+ real tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *,
+ real *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real ainvnm;
+ char normin[1];
+ real smlnum;
+ extern /* Subroutine */ int ssytrs_(char *, integer *, integer *, real *,
+ integer *, integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLA_SYRCOND estimates the Skeel condition number of op(A) * op2(C) */
+/* where op2 is determined by CMODE as follows */
+/* CMODE = 1 op2(C) = C */
+/* CMODE = 0 op2(C) = I */
+/* CMODE = -1 op2(C) = inv(C) */
+/* The Skeel condition number cond(A) = norminf( |inv(A)||A| ) */
+/* is computed by computing scaling factors R such that */
+/* diag(R)*A*op2(C) is row equilibrated and computing the standard */
+/* infinity-norm condition number. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) REAL array, dimension (LDAF,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by SSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by SSYTRF. */
+
+/* CMODE (input) INTEGER */
+/* Determines op2(C) in the formula op(A) * op2(C) as follows: */
+/* CMODE = 1 op2(C) = C */
+/* CMODE = 0 op2(C) = I */
+/* CMODE = -1 op2(C) = inv(C) */
+
+/* C (input) REAL array, dimension (N) */
+/* The vector C in the formula op(A) * op2(C). */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) REAL array, dimension (3*N). */
+/* Workspace. */
+
+/* IWORK (input) INTEGER array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --c__;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ *info = 0;
+ if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLA_SYRCOND", &i__1);
+ return ret_val;
+ }
+ if (*n == 0) {
+ ret_val = 1.f;
+ return ret_val;
+ }
+ up = FALSE_;
+ if (lsame_(uplo, "U")) {
+ up = TRUE_;
+ }
+
+/* Compute the equilibration matrix R such that */
+/* inv(R)*A*C has unit 1-norm. */
+
+ if (up) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ if (*cmode == 1) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[j + i__ * a_dim1] * c__[j], dabs(r__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[i__ + j * a_dim1] * c__[j], dabs(r__1));
+ }
+ } else if (*cmode == 0) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[j + i__ * a_dim1], dabs(r__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[j + i__ * a_dim1] / c__[j], dabs(r__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[i__ + j * a_dim1] / c__[j], dabs(r__1));
+ }
+ }
+ work[(*n << 1) + i__] = tmp;
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.f;
+ if (*cmode == 1) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[i__ + j * a_dim1] * c__[j], dabs(r__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[j + i__ * a_dim1] * c__[j], dabs(r__1));
+ }
+ } else if (*cmode == 0) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[j + i__ * a_dim1], dabs(r__1));
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[i__ + j * a_dim1] / c__[j], dabs(r__1));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ tmp += (r__1 = a[j + i__ * a_dim1] / c__[j], dabs(r__1));
+ }
+ }
+ work[(*n << 1) + i__] = tmp;
+ }
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ smlnum = slamch_("Safe minimum");
+ ainvnm = 0.f;
+ *(unsigned char *)normin = 'N';
+ kase = 0;
+L10:
+ slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= work[(*n << 1) + i__];
+ }
+ if (up) {
+ ssytrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ } else {
+ ssytrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+
+/* Multiply by inv(C). */
+
+ if (*cmode == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] /= c__[i__];
+ }
+ } else if (*cmode == -1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= c__[i__];
+ }
+ }
+ } else {
+
+/* Multiply by inv(C'). */
+
+ if (*cmode == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] /= c__[i__];
+ }
+ } else if (*cmode == -1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= c__[i__];
+ }
+ }
+ if (up) {
+ ssytrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ } else {
+ ssytrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] *= work[(*n << 1) + i__];
+ }
+ }
+
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ ret_val = 1.f / ainvnm;
+ }
+
+ return ret_val;
+
+} /* sla_syrcond__ */
diff --git a/SRC/sla_syrfsx_extended.c b/SRC/sla_syrfsx_extended.c
new file mode 100644
index 0000000..e036c7d
--- /dev/null
+++ b/SRC/sla_syrfsx_extended.c
@@ -0,0 +1,598 @@
+/* sla_syrfsx_extended.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b9 = -1.f;
+static real c_b11 = 1.f;
+
+/* Subroutine */ int sla_syrfsx_extended__(integer *prec_type__, char *uplo,
+ integer *n, integer *nrhs, real *a, integer *lda, real *af, integer *
+ ldaf, integer *ipiv, logical *colequ, real *c__, real *b, integer *
+ ldb, real *y, integer *ldy, real *berr_out__, integer *n_norms__,
+ real *err_bnds_norm__, real *err_bnds_comp__, real *res, real *ayb,
+ real *dy, real *y_tail__, real *rcond, integer *ithresh, real *
+ rthresh, real *dz_ub__, logical *ignore_cwise__, integer *info,
+ ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1,
+ y_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3;
+ real r__1, r__2;
+
+ /* Local variables */
+ real dxratmax, dzratmax;
+ integer i__, j;
+ logical incr_prec__;
+ extern /* Subroutine */ int sla_syamv__(integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ real prev_dz_z__, yk, final_dx_x__, final_dz_z__;
+ extern /* Subroutine */ int sla_wwaddw__(integer *, real *, real *, real *
+ );
+ real prevnormdx;
+ integer cnt;
+ real dyk, eps, incr_thresh__, dx_x__, dz_z__, ymin;
+ extern /* Subroutine */ int sla_lin_berr__(integer *, integer *, integer *
+ , real *, real *, real *);
+ integer y_prec_state__, uplo2;
+ extern /* Subroutine */ int blas_ssymv_x__(integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ real dxrat, dzrat;
+ extern /* Subroutine */ int blas_ssymv2_x__(integer *, integer *, real *,
+ real *, integer *, real *, real *, integer *, real *, real *,
+ integer *, integer *), scopy_(integer *, real *, integer *, real *
+, integer *);
+ real normx, normy;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *), ssymv_(char *, integer *, real *, real *,
+ integer *, real *, integer *, real *, real *, integer *);
+ extern doublereal slamch_(char *);
+ real normdx;
+ extern /* Subroutine */ int ssytrs_(char *, integer *, integer *, real *,
+ integer *, integer *, real *, integer *, integer *);
+ real hugeval;
+ extern integer ilauplo_(char *);
+ integer x_state__, z_state__;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLA_SYRFSX_EXTENDED improves the computed solution to a system of */
+/* linear equations by performing extra-precise iterative refinement */
+/* and provides error bounds and backward error estimates for the solution. */
+/* This subroutine is called by SSYRFSX to perform iterative refinement. */
+/* In addition to normwise error bound, the code provides maximum */
+/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP for details of the error bounds. Note that this */
+/* subroutine is only resonsible for setting the second fields of */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP. */
+
+/* Arguments */
+/* ========= */
+
+/* PREC_TYPE (input) INTEGER */
+/* Specifies the intermediate precision to be used in refinement. */
+/* The value is defined by ILAPREC(P) where P is a CHARACTER and */
+/* P = 'S': Single */
+/* = 'D': Double */
+/* = 'I': Indigenous */
+/* = 'X', 'E': Extra */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right-hand-sides, i.e., the number of columns of the */
+/* matrix B. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) REAL array, dimension (LDAF,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by SSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by SSYTRF. */
+
+/* COLEQU (input) LOGICAL */
+/* If .TRUE. then column equilibration was done to A before calling */
+/* this routine. This is needed to compute the solution and error */
+/* bounds correctly. */
+
+/* C (input) REAL array, dimension (N) */
+/* The column scale factors for A. If COLEQU = .FALSE., C */
+/* is not accessed. If C is input, each element of C should be a power */
+/* of the radix to ensure a reliable solution and error estimates. */
+/* Scaling by powers of the radix does not cause rounding errors unless */
+/* the result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right-hand-side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Y (input/output) REAL array, dimension (LDY,NRHS) */
+/* On entry, the solution matrix X, as computed by SSYTRS. */
+/* On exit, the improved solution matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= max(1,N). */
+
+/* BERR_OUT (output) REAL array, dimension (NRHS) */
+/* On exit, BERR_OUT(j) contains the componentwise relative backward */
+/* error for right-hand-side j from the formula */
+/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. This is computed by SLA_LIN_BERR. */
+
+/* N_NORMS (input) INTEGER */
+/* Determines which error bounds to return (see ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP). */
+/* If N_NORMS >= 1 return normwise error bounds. */
+/* If N_NORMS >= 2 return componentwise error bounds. */
+
+/* ERR_BNDS_NORM (input/output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (input/output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* RES (input) REAL array, dimension (N) */
+/* Workspace to hold the intermediate residual. */
+
+/* AYB (input) REAL array, dimension (N) */
+/* Workspace. This can be the same workspace passed for Y_TAIL. */
+
+/* DY (input) REAL array, dimension (N) */
+/* Workspace to hold the intermediate solution. */
+
+/* Y_TAIL (input) REAL array, dimension (N) */
+/* Workspace to hold the trailing bits of the intermediate solution. */
+
+/* RCOND (input) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* ITHRESH (input) INTEGER */
+/* The maximum number of residual computations allowed for */
+/* refinement. The default is 10. For 'aggressive' set to 100 to */
+/* permit convergence using approximate factorizations or */
+/* factorizations other than LU. If the factorization uses a */
+/* technique other than Gaussian elimination, the guarantees in */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */
+
+/* RTHRESH (input) REAL */
+/* Determines when to stop refinement if the error estimate stops */
+/* decreasing. Refinement will stop when the next solution no longer */
+/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */
+/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */
+/* default value is 0.5. For 'aggressive' set to 0.9 to permit */
+/* convergence on extremely ill-conditioned matrices. See LAWN 165 */
+/* for more details. */
+
+/* DZ_UB (input) REAL */
+/* Determines when to start considering componentwise convergence. */
+/* Componentwise convergence is only considered after each component */
+/* of the solution Y is stable, which we definte as the relative */
+/* change in each component being less than DZ_UB. The default value */
+/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */
+/* more details. */
+
+/* IGNORE_CWISE (input) LOGICAL */
+/* If .TRUE. then ignore componentwise convergence. Default value */
+/* is .FALSE.. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* < 0: if INFO = -i, the ith argument to SSYTRS had an illegal */
+/* value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ --berr_out__;
+ --res;
+ --ayb;
+ --dy;
+ --y_tail__;
+
+ /* Function Body */
+ if (*info != 0) {
+ return 0;
+ }
+ eps = slamch_("Epsilon");
+ hugeval = slamch_("Overflow");
+/* Force HUGEVAL to Inf */
+ hugeval *= hugeval;
+/* Using HUGEVAL may lead to spurious underflows. */
+ incr_thresh__ = (real) (*n) * eps;
+ if (lsame_(uplo, "L")) {
+ uplo2 = ilauplo_("L");
+ } else {
+ uplo2 = ilauplo_("U");
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ y_prec_state__ = 1;
+ if (y_prec_state__ == 2) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ y_tail__[i__] = 0.f;
+ }
+ }
+ dxrat = 0.f;
+ dxratmax = 0.f;
+ dzrat = 0.f;
+ dzratmax = 0.f;
+ final_dx_x__ = hugeval;
+ final_dz_z__ = hugeval;
+ prevnormdx = hugeval;
+ prev_dz_z__ = hugeval;
+ dz_z__ = hugeval;
+ dx_x__ = hugeval;
+ x_state__ = 1;
+ z_state__ = 0;
+ incr_prec__ = FALSE_;
+ i__2 = *ithresh;
+ for (cnt = 1; cnt <= i__2; ++cnt) {
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ scopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ if (y_prec_state__ == 0) {
+ ssymv_(uplo, n, &c_b9, &a[a_offset], lda, &y[j * y_dim1 + 1],
+ &c__1, &c_b11, &res[1], &c__1);
+ } else if (y_prec_state__ == 1) {
+ blas_ssymv_x__(&uplo2, n, &c_b9, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &c__1, &c_b11, &res[1], &c__1,
+ prec_type__);
+ } else {
+ blas_ssymv2_x__(&uplo2, n, &c_b9, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &y_tail__[1], &c__1, &c_b11, &res[1], &
+ c__1, prec_type__);
+ }
+/* XXX: RES is no longer needed. */
+ scopy_(n, &res[1], &c__1, &dy[1], &c__1);
+ ssytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &dy[1], n,
+ info);
+
+/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
+
+ normx = 0.f;
+ normy = 0.f;
+ normdx = 0.f;
+ dz_z__ = 0.f;
+ ymin = hugeval;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ yk = (r__1 = y[i__ + j * y_dim1], dabs(r__1));
+ dyk = (r__1 = dy[i__], dabs(r__1));
+ if (yk != 0.f) {
+/* Computing MAX */
+ r__1 = dz_z__, r__2 = dyk / yk;
+ dz_z__ = dmax(r__1,r__2);
+ } else if (dyk != 0.f) {
+ dz_z__ = hugeval;
+ }
+ ymin = dmin(ymin,yk);
+ normy = dmax(normy,yk);
+ if (*colequ) {
+/* Computing MAX */
+ r__1 = normx, r__2 = yk * c__[i__];
+ normx = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = normdx, r__2 = dyk * c__[i__];
+ normdx = dmax(r__1,r__2);
+ } else {
+ normx = normy;
+ normdx = dmax(normdx,dyk);
+ }
+ }
+ if (normx != 0.f) {
+ dx_x__ = normdx / normx;
+ } else if (normdx == 0.f) {
+ dx_x__ = 0.f;
+ } else {
+ dx_x__ = hugeval;
+ }
+ dxrat = normdx / prevnormdx;
+ dzrat = dz_z__ / prev_dz_z__;
+
+/* Check termination criteria. */
+
+ if (ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2) {
+ incr_prec__ = TRUE_;
+ }
+ if (x_state__ == 3 && dxrat <= *rthresh) {
+ x_state__ = 1;
+ }
+ if (x_state__ == 1) {
+ if (dx_x__ <= eps) {
+ x_state__ = 2;
+ } else if (dxrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ x_state__ = 3;
+ }
+ } else {
+ if (dxrat > dxratmax) {
+ dxratmax = dxrat;
+ }
+ }
+ if (x_state__ > 1) {
+ final_dx_x__ = dx_x__;
+ }
+ }
+ if (z_state__ == 0 && dz_z__ <= *dz_ub__) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 3 && dzrat <= *rthresh) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 1) {
+ if (dz_z__ <= eps) {
+ z_state__ = 2;
+ } else if (dz_z__ > *dz_ub__) {
+ z_state__ = 0;
+ dzratmax = 0.f;
+ final_dz_z__ = hugeval;
+ } else if (dzrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ z_state__ = 3;
+ }
+ } else {
+ if (dzrat > dzratmax) {
+ dzratmax = dzrat;
+ }
+ }
+ if (z_state__ > 1) {
+ final_dz_z__ = dz_z__;
+ }
+ }
+ if (x_state__ != 1 && (*ignore_cwise__ || z_state__ != 1)) {
+ goto L666;
+ }
+ if (incr_prec__) {
+ incr_prec__ = FALSE_;
+ ++y_prec_state__;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ y_tail__[i__] = 0.f;
+ }
+ }
+ prevnormdx = normdx;
+ prev_dz_z__ = dz_z__;
+
+/* Update soluton. */
+
+ if (y_prec_state__ < 2) {
+ saxpy_(n, &c_b11, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
+ } else {
+ sla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
+ }
+ }
+/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */
+L666:
+
+/* Set final_* when cnt hits ithresh. */
+
+ if (x_state__ == 1) {
+ final_dx_x__ = dx_x__;
+ }
+ if (z_state__ == 1) {
+ final_dz_z__ = dz_z__;
+ }
+
+/* Compute error bounds. */
+
+ if (*n_norms__ >= 1) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / (
+ 1 - dxratmax);
+ }
+ if (*n_norms__ >= 2) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / (
+ 1 - dzratmax);
+ }
+
+/* Compute componentwise relative backward error from formula */
+/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. */
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+ scopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ ssymv_(uplo, n, &c_b9, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1, &
+ c_b11, &res[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ayb[i__] = (r__1 = b[i__ + j * b_dim1], dabs(r__1));
+ }
+
+/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */
+
+ sla_syamv__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1],
+ &c__1, &c_b11, &ayb[1], &c__1);
+ sla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
+
+/* End of loop for each RHS. */
+
+ }
+
+ return 0;
+} /* sla_syrfsx_extended__ */
diff --git a/SRC/sla_syrpvgrw.c b/SRC/sla_syrpvgrw.c
new file mode 100644
index 0000000..9be3688
--- /dev/null
+++ b/SRC/sla_syrpvgrw.c
@@ -0,0 +1,330 @@
+/* sla_syrpvgrw.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal sla_syrpvgrw__(char *uplo, integer *n, integer *info, real *a,
+ integer *lda, real *af, integer *ldaf, integer *ipiv, real *work,
+ ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2;
+ real ret_val, r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, k, kp;
+ real tmp, amax, umax;
+ extern logical lsame_(char *, char *);
+ integer ncols;
+ logical upper;
+ real rpvgrw;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLA_SYRPVGRW computes the reciprocal pivot growth factor */
+/* norm(A)/norm(U). The "max absolute element" norm is used. If this is */
+/* much less than 1, the stability of the LU factorization of the */
+/* (equilibrated) matrix A could be poor. This also means that the */
+/* solution X, estimated condition numbers, and error bounds could be */
+/* unreliable. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* INFO (input) INTEGER */
+/* The value of INFO returned from SSYTRF, .i.e., the pivot in */
+/* column INFO is exactly 0. */
+
+/* NCOLS (input) INTEGER */
+/* The number of columns of the matrix A. NCOLS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) REAL array, dimension (LDAF,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by SSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by SSYTRF. */
+
+/* WORK (input) REAL array, dimension (2*N) */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ upper = lsame_("Upper", uplo);
+ if (*info == 0) {
+ if (upper) {
+ ncols = 1;
+ } else {
+ ncols = *n;
+ }
+ } else {
+ ncols = *info;
+ }
+ rpvgrw = 1.f;
+ i__1 = *n << 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+ }
+
+/* Find the max magnitude entry of each column of A. Compute the max */
+/* for all N columns so we can apply the pivot permutation while */
+/* looping below. Assume a full factorization is the common case. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = (r__1 = a[i__ + j * a_dim1], dabs(r__1)), r__3 = work[*
+ n + i__];
+ work[*n + i__] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = (r__1 = a[i__ + j * a_dim1], dabs(r__1)), r__3 = work[*
+ n + j];
+ work[*n + j] = dmax(r__2,r__3);
+ }
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = (r__1 = a[i__ + j * a_dim1], dabs(r__1)), r__3 = work[*
+ n + i__];
+ work[*n + i__] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = (r__1 = a[i__ + j * a_dim1], dabs(r__1)), r__3 = work[*
+ n + j];
+ work[*n + j] = dmax(r__2,r__3);
+ }
+ }
+ }
+
+/* Now find the max magnitude entry of each column of U or L. Also */
+/* permute the magnitudes of A above so they're in the same order as */
+/* the factor. */
+
+/* The iteration orders and permutations were copied from ssytrs. */
+/* Calls to SSWAP would be severe overkill. */
+
+ if (upper) {
+ k = *n;
+ while(k < ncols && k > 0) {
+ if (ipiv[k] > 0) {
+/* 1x1 pivot */
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = (r__1 = af[i__ + k * af_dim1], dabs(r__1)), r__3 =
+ work[k];
+ work[k] = dmax(r__2,r__3);
+ }
+ --k;
+ } else {
+/* 2x2 pivot */
+ kp = -ipiv[k];
+ tmp = work[*n + k - 1];
+ work[*n + k - 1] = work[*n + kp];
+ work[*n + kp] = tmp;
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = (r__1 = af[i__ + k * af_dim1], dabs(r__1)), r__3 =
+ work[k];
+ work[k] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = (r__1 = af[i__ + (k - 1) * af_dim1], dabs(r__1)),
+ r__3 = work[k - 1];
+ work[k - 1] = dmax(r__2,r__3);
+ }
+/* Computing MAX */
+ r__2 = (r__1 = af[k + k * af_dim1], dabs(r__1)), r__3 = work[
+ k];
+ work[k] = dmax(r__2,r__3);
+ k += -2;
+ }
+ }
+ k = ncols;
+ while(k <= *n) {
+ if (ipiv[k] > 0) {
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ ++k;
+ } else {
+ kp = -ipiv[k];
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ k += 2;
+ }
+ }
+ } else {
+ k = 1;
+ while(k <= ncols) {
+ if (ipiv[k] > 0) {
+/* 1x1 pivot */
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ i__1 = *n;
+ for (i__ = k; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = (r__1 = af[i__ + k * af_dim1], dabs(r__1)), r__3 =
+ work[k];
+ work[k] = dmax(r__2,r__3);
+ }
+ ++k;
+ } else {
+/* 2x2 pivot */
+ kp = -ipiv[k];
+ tmp = work[*n + k + 1];
+ work[*n + k + 1] = work[*n + kp];
+ work[*n + kp] = tmp;
+ i__1 = *n;
+ for (i__ = k + 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = (r__1 = af[i__ + k * af_dim1], dabs(r__1)), r__3 =
+ work[k];
+ work[k] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = (r__1 = af[i__ + (k + 1) * af_dim1], dabs(r__1)),
+ r__3 = work[k + 1];
+ work[k + 1] = dmax(r__2,r__3);
+ }
+/* Computing MAX */
+ r__2 = (r__1 = af[k + k * af_dim1], dabs(r__1)), r__3 = work[
+ k];
+ work[k] = dmax(r__2,r__3);
+ k += 2;
+ }
+ }
+ k = ncols;
+ while(k >= 1) {
+ if (ipiv[k] > 0) {
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ --k;
+ } else {
+ kp = -ipiv[k];
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ k += -2;
+ }
+ }
+ }
+
+/* Compute the *inverse* of the max element growth factor. Dividing */
+/* by zero would imply the largest entry of the factor's column is */
+/* zero. Than can happen when either the column of A is zero or */
+/* massive pivots made the factor underflow to zero. Neither counts */
+/* as growth in itself, so simply ignore terms with zero */
+/* denominators. */
+
+ if (upper) {
+ i__1 = *n;
+ for (i__ = ncols; i__ <= i__1; ++i__) {
+ umax = work[i__];
+ amax = work[*n + i__];
+ if (umax != 0.f) {
+/* Computing MIN */
+ r__1 = amax / umax;
+ rpvgrw = dmin(r__1,rpvgrw);
+ }
+ }
+ } else {
+ i__1 = ncols;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ umax = work[i__];
+ amax = work[*n + i__];
+ if (umax != 0.f) {
+/* Computing MIN */
+ r__1 = amax / umax;
+ rpvgrw = dmin(r__1,rpvgrw);
+ }
+ }
+ }
+ ret_val = rpvgrw;
+ return ret_val;
+} /* sla_syrpvgrw__ */
diff --git a/SRC/sla_wwaddw.c b/SRC/sla_wwaddw.c
new file mode 100644
index 0000000..94eff15
--- /dev/null
+++ b/SRC/sla_wwaddw.c
@@ -0,0 +1,79 @@
+/* sla_wwaddw.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sla_wwaddw__(integer *n, real *x, real *y, real *w)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__;
+ real s;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLA_WWADDW adds a vector W into a doubled-single vector (X, Y). */
+
+/* This works for all extant IBM's hex and binary floating point */
+/* arithmetics, but not for decimal. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The length of vectors X, Y, and W. */
+
+/* X, Y (input/output) REAL array, length N */
+/* The doubled-single accumulation vector. */
+
+/* W (input) REAL array, length N */
+/* The vector to be added. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --w;
+ --y;
+ --x;
+
+ /* Function Body */
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s = x[i__] + w[i__];
+ s = s + s - s;
+ y[i__] = x[i__] - s + w[i__] + y[i__];
+ x[i__] = s;
+/* L10: */
+ }
+ return 0;
+} /* sla_wwaddw__ */
diff --git a/SRC/slabad.c b/SRC/slabad.c
new file mode 100644
index 0000000..ed9a836
--- /dev/null
+++ b/SRC/slabad.c
@@ -0,0 +1,72 @@
+/* slabad.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slabad_(real *small, real *large)
+{
+ /* Builtin functions */
+ double r_lg10(real *), sqrt(doublereal);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLABAD takes as input the values computed by SLAMCH for underflow and */
+/* overflow, and returns the square root of each of these values if the */
+/* log of LARGE is sufficiently large. This subroutine is intended to */
+/* identify machines with a large exponent range, such as the Crays, and */
+/* redefine the underflow and overflow limits to be the square roots of */
+/* the values computed by SLAMCH. This subroutine is needed because */
+/* SLAMCH does not compensate for poor arithmetic in the upper half of */
+/* the exponent range, as is found on a Cray. */
+
+/* Arguments */
+/* ========= */
+
+/* SMALL (input/output) REAL */
+/* On entry, the underflow threshold as computed by SLAMCH. */
+/* On exit, if LOG10(LARGE) is sufficiently large, the square */
+/* root of SMALL, otherwise unchanged. */
+
+/* LARGE (input/output) REAL */
+/* On entry, the overflow threshold as computed by SLAMCH. */
+/* On exit, if LOG10(LARGE) is sufficiently large, the square */
+/* root of LARGE, otherwise unchanged. */
+
+/* ===================================================================== */
+
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* If it looks like we're on a Cray, take the square root of */
+/* SMALL and LARGE to avoid overflow and underflow problems. */
+
+ if (r_lg10(large) > 2e3f) {
+ *small = sqrt(*small);
+ *large = sqrt(*large);
+ }
+
+ return 0;
+
+/* End of SLABAD */
+
+} /* slabad_ */
diff --git a/SRC/slabrd.c b/SRC/slabrd.c
new file mode 100644
index 0000000..1f24819
--- /dev/null
+++ b/SRC/slabrd.c
@@ -0,0 +1,432 @@
+/* slabrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b4 = -1.f;
+static real c_b5 = 1.f;
+static integer c__1 = 1;
+static real c_b16 = 0.f;
+
+/* Subroutine */ int slabrd_(integer *m, integer *n, integer *nb, real *a,
+ integer *lda, real *d__, real *e, real *tauq, real *taup, real *x,
+ integer *ldx, real *y, integer *ldy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2,
+ i__3;
+
+ /* Local variables */
+ integer i__;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ sgemv_(char *, integer *, integer *, real *, real *, integer *,
+ real *, integer *, real *, real *, integer *), slarfg_(
+ integer *, real *, real *, integer *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLABRD reduces the first NB rows and columns of a real general */
+/* m by n matrix A to upper or lower bidiagonal form by an orthogonal */
+/* transformation Q' * A * P, and returns the matrices X and Y which */
+/* are needed to apply the transformation to the unreduced part of A. */
+
+/* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower */
+/* bidiagonal form. */
+
+/* This is an auxiliary routine called by SGEBRD */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows in the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns in the matrix A. */
+
+/* NB (input) INTEGER */
+/* The number of leading rows and columns of A to be reduced. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the m by n general matrix to be reduced. */
+/* On exit, the first NB rows and columns of the matrix are */
+/* overwritten; the rest of the array is unchanged. */
+/* If m >= n, elements on and below the diagonal in the first NB */
+/* columns, with the array TAUQ, represent the orthogonal */
+/* matrix Q as a product of elementary reflectors; and */
+/* elements above the diagonal in the first NB rows, with the */
+/* array TAUP, represent the orthogonal matrix P as a product */
+/* of elementary reflectors. */
+/* If m < n, elements below the diagonal in the first NB */
+/* columns, with the array TAUQ, represent the orthogonal */
+/* matrix Q as a product of elementary reflectors, and */
+/* elements on and above the diagonal in the first NB rows, */
+/* with the array TAUP, represent the orthogonal matrix P as */
+/* a product of elementary reflectors. */
+/* See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* D (output) REAL array, dimension (NB) */
+/* The diagonal elements of the first NB rows and columns of */
+/* the reduced matrix. D(i) = A(i,i). */
+
+/* E (output) REAL array, dimension (NB) */
+/* The off-diagonal elements of the first NB rows and columns of */
+/* the reduced matrix. */
+
+/* TAUQ (output) REAL array dimension (NB) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the orthogonal matrix Q. See Further Details. */
+
+/* TAUP (output) REAL array, dimension (NB) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the orthogonal matrix P. See Further Details. */
+
+/* X (output) REAL array, dimension (LDX,NB) */
+/* The m-by-nb matrix X required to update the unreduced part */
+/* of A. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= M. */
+
+/* Y (output) REAL array, dimension (LDY,NB) */
+/* The n-by-nb matrix Y required to update the unreduced part */
+/* of A. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= N. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrices Q and P are represented as products of elementary */
+/* reflectors: */
+
+/* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) */
+
+/* Each H(i) and G(i) has the form: */
+
+/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
+
+/* where tauq and taup are real scalars, and v and u are real vectors. */
+
+/* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in */
+/* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in */
+/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in */
+/* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in */
+/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* The elements of the vectors v and u together form the m-by-nb matrix */
+/* V and the nb-by-n matrix U' which are needed, with X and Y, to apply */
+/* the transformation to the unreduced part of the matrix, using a block */
+/* update of the form: A := A - V*Y' - X*U'. */
+
+/* The contents of A on exit are illustrated by the following examples */
+/* with nb = 2: */
+
+/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
+
+/* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) */
+/* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) */
+/* ( v1 v2 a a a ) ( v1 1 a a a a ) */
+/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */
+/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */
+/* ( v1 v2 a a a ) */
+
+/* where a denotes an element of the original matrix which is unchanged, */
+/* vi denotes an element of the vector defining H(i), and ui an element */
+/* of the vector defining G(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ --tauq;
+ --taup;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+ if (*m >= *n) {
+
+/* Reduce to upper bidiagonal form */
+
+ i__1 = *nb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Update A(i:m,i) */
+
+ i__2 = *m - i__ + 1;
+ i__3 = i__ - 1;
+ sgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + a_dim1], lda,
+ &y[i__ + y_dim1], ldy, &c_b5, &a[i__ + i__ * a_dim1], &
+ c__1);
+ i__2 = *m - i__ + 1;
+ i__3 = i__ - 1;
+ sgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + x_dim1], ldx,
+ &a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[i__ + i__ *
+ a_dim1], &c__1);
+
+/* Generate reflection Q(i) to annihilate A(i+1:m,i) */
+
+ i__2 = *m - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ slarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3, *m)+ i__ *
+ a_dim1], &c__1, &tauq[i__]);
+ d__[i__] = a[i__ + i__ * a_dim1];
+ if (i__ < *n) {
+ a[i__ + i__ * a_dim1] = 1.f;
+
+/* Compute Y(i+1:n,i) */
+
+ i__2 = *m - i__ + 1;
+ i__3 = *n - i__;
+ sgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + (i__ + 1) *
+ a_dim1], lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &
+ y[i__ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *m - i__ + 1;
+ i__3 = i__ - 1;
+ sgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1],
+ lda, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ *
+ y_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ sgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 +
+ y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[
+ i__ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *m - i__ + 1;
+ i__3 = i__ - 1;
+ sgemv_("Transpose", &i__2, &i__3, &c_b5, &x[i__ + x_dim1],
+ ldx, &a[i__ + i__ * a_dim1], &c__1, &c_b16, &y[i__ *
+ y_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ sgemv_("Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) *
+ a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5,
+ &y[i__ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *n - i__;
+ sscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
+
+/* Update A(i,i+1:n) */
+
+ i__2 = *n - i__;
+ sgemv_("No transpose", &i__2, &i__, &c_b4, &y[i__ + 1 +
+ y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b5, &a[i__ + (
+ i__ + 1) * a_dim1], lda);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ sgemv_("Transpose", &i__2, &i__3, &c_b4, &a[(i__ + 1) *
+ a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b5, &a[
+ i__ + (i__ + 1) * a_dim1], lda);
+
+/* Generate reflection P(i) to annihilate A(i,i+2:n) */
+
+ i__2 = *n - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ slarfg_(&i__2, &a[i__ + (i__ + 1) * a_dim1], &a[i__ + min(
+ i__3, *n)* a_dim1], lda, &taup[i__]);
+ e[i__] = a[i__ + (i__ + 1) * a_dim1];
+ a[i__ + (i__ + 1) * a_dim1] = 1.f;
+
+/* Compute X(i+1:m,i) */
+
+ i__2 = *m - i__;
+ i__3 = *n - i__;
+ sgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__
+ + 1) * a_dim1], lda, &a[i__ + (i__ + 1) * a_dim1],
+ lda, &c_b16, &x[i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = *n - i__;
+ sgemv_("Transpose", &i__2, &i__, &c_b5, &y[i__ + 1 + y_dim1],
+ ldy, &a[i__ + (i__ + 1) * a_dim1], lda, &c_b16, &x[
+ i__ * x_dim1 + 1], &c__1);
+ i__2 = *m - i__;
+ sgemv_("No transpose", &i__2, &i__, &c_b4, &a[i__ + 1 +
+ a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
+ i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ sgemv_("No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) *
+ a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, &
+ c_b16, &x[i__ * x_dim1 + 1], &c__1);
+ i__2 = *m - i__;
+ i__3 = i__ - 1;
+ sgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 +
+ x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
+ i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = *m - i__;
+ sscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Reduce to lower bidiagonal form */
+
+ i__1 = *nb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Update A(i,i:n) */
+
+ i__2 = *n - i__ + 1;
+ i__3 = i__ - 1;
+ sgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + y_dim1], ldy,
+ &a[i__ + a_dim1], lda, &c_b5, &a[i__ + i__ * a_dim1],
+ lda);
+ i__2 = i__ - 1;
+ i__3 = *n - i__ + 1;
+ sgemv_("Transpose", &i__2, &i__3, &c_b4, &a[i__ * a_dim1 + 1],
+ lda, &x[i__ + x_dim1], ldx, &c_b5, &a[i__ + i__ * a_dim1],
+ lda);
+
+/* Generate reflection P(i) to annihilate A(i,i+1:n) */
+
+ i__2 = *n - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ slarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3, *n)*
+ a_dim1], lda, &taup[i__]);
+ d__[i__] = a[i__ + i__ * a_dim1];
+ if (i__ < *m) {
+ a[i__ + i__ * a_dim1] = 1.f;
+
+/* Compute X(i+1:m,i) */
+
+ i__2 = *m - i__;
+ i__3 = *n - i__ + 1;
+ sgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + i__ *
+ a_dim1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, &
+ x[i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = *n - i__ + 1;
+ i__3 = i__ - 1;
+ sgemv_("Transpose", &i__2, &i__3, &c_b5, &y[i__ + y_dim1],
+ ldy, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ *
+ x_dim1 + 1], &c__1);
+ i__2 = *m - i__;
+ i__3 = i__ - 1;
+ sgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 +
+ a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
+ i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__ + 1;
+ sgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ * a_dim1 +
+ 1], lda, &a[i__ + i__ * a_dim1], lda, &c_b16, &x[i__ *
+ x_dim1 + 1], &c__1);
+ i__2 = *m - i__;
+ i__3 = i__ - 1;
+ sgemv_("No transpose", &i__2, &i__3, &c_b4, &x[i__ + 1 +
+ x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b5, &x[
+ i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = *m - i__;
+ sscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
+
+/* Update A(i+1:m,i) */
+
+ i__2 = *m - i__;
+ i__3 = i__ - 1;
+ sgemv_("No transpose", &i__2, &i__3, &c_b4, &a[i__ + 1 +
+ a_dim1], lda, &y[i__ + y_dim1], ldy, &c_b5, &a[i__ +
+ 1 + i__ * a_dim1], &c__1);
+ i__2 = *m - i__;
+ sgemv_("No transpose", &i__2, &i__, &c_b4, &x[i__ + 1 +
+ x_dim1], ldx, &a[i__ * a_dim1 + 1], &c__1, &c_b5, &a[
+ i__ + 1 + i__ * a_dim1], &c__1);
+
+/* Generate reflection Q(i) to annihilate A(i+2:m,i) */
+
+ i__2 = *m - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ slarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *m)+
+ i__ * a_dim1], &c__1, &tauq[i__]);
+ e[i__] = a[i__ + 1 + i__ * a_dim1];
+ a[i__ + 1 + i__ * a_dim1] = 1.f;
+
+/* Compute Y(i+1:n,i) */
+
+ i__2 = *m - i__;
+ i__3 = *n - i__;
+ sgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + (i__ +
+ 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1,
+ &c_b16, &y[i__ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *m - i__;
+ i__3 = i__ - 1;
+ sgemv_("Transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + a_dim1],
+ lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[
+ i__ * y_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ sgemv_("No transpose", &i__2, &i__3, &c_b4, &y[i__ + 1 +
+ y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[
+ i__ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *m - i__;
+ sgemv_("Transpose", &i__2, &i__, &c_b5, &x[i__ + 1 + x_dim1],
+ ldx, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &y[
+ i__ * y_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ sgemv_("Transpose", &i__, &i__2, &c_b4, &a[(i__ + 1) * a_dim1
+ + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &c_b5, &y[i__
+ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *n - i__;
+ sscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+/* End of SLABRD */
+
+} /* slabrd_ */
diff --git a/SRC/slacn2.c b/SRC/slacn2.c
new file mode 100644
index 0000000..9626eca
--- /dev/null
+++ b/SRC/slacn2.c
@@ -0,0 +1,266 @@
+/* slacn2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b11 = 1.f;
+
+/* Subroutine */ int slacn2_(integer *n, real *v, real *x, integer *isgn,
+ real *est, integer *kase, integer *isave)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1;
+
+ /* Builtin functions */
+ double r_sign(real *, real *);
+ integer i_nint(real *);
+
+ /* Local variables */
+ integer i__;
+ real temp;
+ integer jlast;
+ extern doublereal sasum_(integer *, real *, integer *);
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ real altsgn, estold;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLACN2 estimates the 1-norm of a square, real matrix A. */
+/* Reverse communication is used for evaluating matrix-vector products. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 1. */
+
+/* V (workspace) REAL array, dimension (N) */
+/* On the final return, V = A*W, where EST = norm(V)/norm(W) */
+/* (W is not returned). */
+
+/* X (input/output) REAL array, dimension (N) */
+/* On an intermediate return, X should be overwritten by */
+/* A * X, if KASE=1, */
+/* A' * X, if KASE=2, */
+/* and SLACN2 must be re-called with all the other parameters */
+/* unchanged. */
+
+/* ISGN (workspace) INTEGER array, dimension (N) */
+
+/* EST (input/output) REAL */
+/* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be */
+/* unchanged from the previous call to SLACN2. */
+/* On exit, EST is an estimate (a lower bound) for norm(A). */
+
+/* KASE (input/output) INTEGER */
+/* On the initial call to SLACN2, KASE should be 0. */
+/* On an intermediate return, KASE will be 1 or 2, indicating */
+/* whether X should be overwritten by A * X or A' * X. */
+/* On the final return from SLACN2, KASE will again be 0. */
+
+/* ISAVE (input/output) INTEGER array, dimension (3) */
+/* ISAVE is used to save variables between calls to SLACN2 */
+
+/* Further Details */
+/* ======= ======= */
+
+/* Contributed by Nick Higham, University of Manchester. */
+/* Originally named SONEST, dated March 16, 1988. */
+
+/* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */
+/* a real or complex matrix, with applications to condition estimation", */
+/* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */
+
+/* This is a thread safe version of SLACON, which uses the array ISAVE */
+/* in place of a SAVE statement, as follows: */
+
+/* SLACON SLACN2 */
+/* JUMP ISAVE(1) */
+/* J ISAVE(2) */
+/* ITER ISAVE(3) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --isave;
+ --isgn;
+ --x;
+ --v;
+
+ /* Function Body */
+ if (*kase == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ x[i__] = 1.f / (real) (*n);
+/* L10: */
+ }
+ *kase = 1;
+ isave[1] = 1;
+ return 0;
+ }
+
+ switch (isave[1]) {
+ case 1: goto L20;
+ case 2: goto L40;
+ case 3: goto L70;
+ case 4: goto L110;
+ case 5: goto L140;
+ }
+
+/* ................ ENTRY (ISAVE( 1 ) = 1) */
+/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */
+
+L20:
+ if (*n == 1) {
+ v[1] = x[1];
+ *est = dabs(v[1]);
+/* ... QUIT */
+ goto L150;
+ }
+ *est = sasum_(n, &x[1], &c__1);
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ x[i__] = r_sign(&c_b11, &x[i__]);
+ isgn[i__] = i_nint(&x[i__]);
+/* L30: */
+ }
+ *kase = 2;
+ isave[1] = 2;
+ return 0;
+
+/* ................ ENTRY (ISAVE( 1 ) = 2) */
+/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
+
+L40:
+ isave[2] = isamax_(n, &x[1], &c__1);
+ isave[3] = 2;
+
+/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */
+
+L50:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ x[i__] = 0.f;
+/* L60: */
+ }
+ x[isave[2]] = 1.f;
+ *kase = 1;
+ isave[1] = 3;
+ return 0;
+
+/* ................ ENTRY (ISAVE( 1 ) = 3) */
+/* X HAS BEEN OVERWRITTEN BY A*X. */
+
+L70:
+ scopy_(n, &x[1], &c__1, &v[1], &c__1);
+ estold = *est;
+ *est = sasum_(n, &v[1], &c__1);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__1 = r_sign(&c_b11, &x[i__]);
+ if (i_nint(&r__1) != isgn[i__]) {
+ goto L90;
+ }
+/* L80: */
+ }
+/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
+ goto L120;
+
+L90:
+/* TEST FOR CYCLING. */
+ if (*est <= estold) {
+ goto L120;
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ x[i__] = r_sign(&c_b11, &x[i__]);
+ isgn[i__] = i_nint(&x[i__]);
+/* L100: */
+ }
+ *kase = 2;
+ isave[1] = 4;
+ return 0;
+
+/* ................ ENTRY (ISAVE( 1 ) = 4) */
+/* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
+
+L110:
+ jlast = isave[2];
+ isave[2] = isamax_(n, &x[1], &c__1);
+ if (x[jlast] != (r__1 = x[isave[2]], dabs(r__1)) && isave[3] < 5) {
+ ++isave[3];
+ goto L50;
+ }
+
+/* ITERATION COMPLETE. FINAL STAGE. */
+
+L120:
+ altsgn = 1.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ x[i__] = altsgn * ((real) (i__ - 1) / (real) (*n - 1) + 1.f);
+ altsgn = -altsgn;
+/* L130: */
+ }
+ *kase = 1;
+ isave[1] = 5;
+ return 0;
+
+/* ................ ENTRY (ISAVE( 1 ) = 5) */
+/* X HAS BEEN OVERWRITTEN BY A*X. */
+
+L140:
+ temp = sasum_(n, &x[1], &c__1) / (real) (*n * 3) * 2.f;
+ if (temp > *est) {
+ scopy_(n, &x[1], &c__1, &v[1], &c__1);
+ *est = temp;
+ }
+
+L150:
+ *kase = 0;
+ return 0;
+
+/* End of SLACN2 */
+
+} /* slacn2_ */
diff --git a/SRC/slacon.c b/SRC/slacon.c
new file mode 100644
index 0000000..ece86a3
--- /dev/null
+++ b/SRC/slacon.c
@@ -0,0 +1,256 @@
+/* slacon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b11 = 1.f;
+
+/* Subroutine */ int slacon_(integer *n, real *v, real *x, integer *isgn,
+ real *est, integer *kase)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1;
+
+ /* Builtin functions */
+ double r_sign(real *, real *);
+ integer i_nint(real *);
+
+ /* Local variables */
+ static integer i__, j, iter;
+ static real temp;
+ static integer jump, jlast;
+ extern doublereal sasum_(integer *, real *, integer *);
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ static real altsgn, estold;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLACON estimates the 1-norm of a square, real matrix A. */
+/* Reverse communication is used for evaluating matrix-vector products. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 1. */
+
+/* V (workspace) REAL array, dimension (N) */
+/* On the final return, V = A*W, where EST = norm(V)/norm(W) */
+/* (W is not returned). */
+
+/* X (input/output) REAL array, dimension (N) */
+/* On an intermediate return, X should be overwritten by */
+/* A * X, if KASE=1, */
+/* A' * X, if KASE=2, */
+/* and SLACON must be re-called with all the other parameters */
+/* unchanged. */
+
+/* ISGN (workspace) INTEGER array, dimension (N) */
+
+/* EST (input/output) REAL */
+/* On entry with KASE = 1 or 2 and JUMP = 3, EST should be */
+/* unchanged from the previous call to SLACON. */
+/* On exit, EST is an estimate (a lower bound) for norm(A). */
+
+/* KASE (input/output) INTEGER */
+/* On the initial call to SLACON, KASE should be 0. */
+/* On an intermediate return, KASE will be 1 or 2, indicating */
+/* whether X should be overwritten by A * X or A' * X. */
+/* On the final return from SLACON, KASE will again be 0. */
+
+/* Further Details */
+/* ======= ======= */
+
+/* Contributed by Nick Higham, University of Manchester. */
+/* Originally named SONEST, dated March 16, 1988. */
+
+/* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */
+/* a real or complex matrix, with applications to condition estimation", */
+/* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --isgn;
+ --x;
+ --v;
+
+ /* Function Body */
+ if (*kase == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ x[i__] = 1.f / (real) (*n);
+/* L10: */
+ }
+ *kase = 1;
+ jump = 1;
+ return 0;
+ }
+
+ switch (jump) {
+ case 1: goto L20;
+ case 2: goto L40;
+ case 3: goto L70;
+ case 4: goto L110;
+ case 5: goto L140;
+ }
+
+/* ................ ENTRY (JUMP = 1) */
+/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */
+
+L20:
+ if (*n == 1) {
+ v[1] = x[1];
+ *est = dabs(v[1]);
+/* ... QUIT */
+ goto L150;
+ }
+ *est = sasum_(n, &x[1], &c__1);
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ x[i__] = r_sign(&c_b11, &x[i__]);
+ isgn[i__] = i_nint(&x[i__]);
+/* L30: */
+ }
+ *kase = 2;
+ jump = 2;
+ return 0;
+
+/* ................ ENTRY (JUMP = 2) */
+/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
+
+L40:
+ j = isamax_(n, &x[1], &c__1);
+ iter = 2;
+
+/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */
+
+L50:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ x[i__] = 0.f;
+/* L60: */
+ }
+ x[j] = 1.f;
+ *kase = 1;
+ jump = 3;
+ return 0;
+
+/* ................ ENTRY (JUMP = 3) */
+/* X HAS BEEN OVERWRITTEN BY A*X. */
+
+L70:
+ scopy_(n, &x[1], &c__1, &v[1], &c__1);
+ estold = *est;
+ *est = sasum_(n, &v[1], &c__1);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__1 = r_sign(&c_b11, &x[i__]);
+ if (i_nint(&r__1) != isgn[i__]) {
+ goto L90;
+ }
+/* L80: */
+ }
+/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
+ goto L120;
+
+L90:
+/* TEST FOR CYCLING. */
+ if (*est <= estold) {
+ goto L120;
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ x[i__] = r_sign(&c_b11, &x[i__]);
+ isgn[i__] = i_nint(&x[i__]);
+/* L100: */
+ }
+ *kase = 2;
+ jump = 4;
+ return 0;
+
+/* ................ ENTRY (JUMP = 4) */
+/* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
+
+L110:
+ jlast = j;
+ j = isamax_(n, &x[1], &c__1);
+ if (x[jlast] != (r__1 = x[j], dabs(r__1)) && iter < 5) {
+ ++iter;
+ goto L50;
+ }
+
+/* ITERATION COMPLETE. FINAL STAGE. */
+
+L120:
+ altsgn = 1.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ x[i__] = altsgn * ((real) (i__ - 1) / (real) (*n - 1) + 1.f);
+ altsgn = -altsgn;
+/* L130: */
+ }
+ *kase = 1;
+ jump = 5;
+ return 0;
+
+/* ................ ENTRY (JUMP = 5) */
+/* X HAS BEEN OVERWRITTEN BY A*X. */
+
+L140:
+ temp = sasum_(n, &x[1], &c__1) / (real) (*n * 3) * 2.f;
+ if (temp > *est) {
+ scopy_(n, &x[1], &c__1, &v[1], &c__1);
+ *est = temp;
+ }
+
+L150:
+ *kase = 0;
+ return 0;
+
+/* End of SLACON */
+
+} /* slacon_ */
diff --git a/SRC/slacpy.c b/SRC/slacpy.c
new file mode 100644
index 0000000..5dcb2fc
--- /dev/null
+++ b/SRC/slacpy.c
@@ -0,0 +1,125 @@
+/* slacpy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slacpy_(char *uplo, integer *m, integer *n, real *a,
+ integer *lda, real *b, integer *ldb)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ extern logical lsame_(char *, char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLACPY copies all or part of a two-dimensional matrix A to another */
+/* matrix B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies the part of the matrix A to be copied to B. */
+/* = 'U': Upper triangular part */
+/* = 'L': Lower triangular part */
+/* Otherwise: All of the matrix A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The m by n matrix A. If UPLO = 'U', only the upper triangle */
+/* or trapezoid is accessed; if UPLO = 'L', only the lower */
+/* triangle or trapezoid is accessed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (output) REAL array, dimension (LDB,N) */
+/* On exit, B = A in the locations specified by UPLO. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(j,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = a[i__ + j * a_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (lsame_(uplo, "L")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = a[i__ + j * a_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = a[i__ + j * a_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+ return 0;
+
+/* End of SLACPY */
+
+} /* slacpy_ */
diff --git a/SRC/sladiv.c b/SRC/sladiv.c
new file mode 100644
index 0000000..af4e0c5
--- /dev/null
+++ b/SRC/sladiv.c
@@ -0,0 +1,78 @@
+/* sladiv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sladiv_(real *a, real *b, real *c__, real *d__, real *p,
+ real *q)
+{
+ real e, f;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLADIV performs complex division in real arithmetic */
+
+/* a + i*b */
+/* p + i*q = --------- */
+/* c + i*d */
+
+/* The algorithm is due to Robert L. Smith and can be found */
+/* in D. Knuth, The art of Computer Programming, Vol.2, p.195 */
+
+/* Arguments */
+/* ========= */
+
+/* A (input) REAL */
+/* B (input) REAL */
+/* C (input) REAL */
+/* D (input) REAL */
+/* The scalars a, b, c, and d in the above expression. */
+
+/* P (output) REAL */
+/* Q (output) REAL */
+/* The scalars p and q in the above expression. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (dabs(*d__) < dabs(*c__)) {
+ e = *d__ / *c__;
+ f = *c__ + *d__ * e;
+ *p = (*a + *b * e) / f;
+ *q = (*b - *a * e) / f;
+ } else {
+ e = *c__ / *d__;
+ f = *d__ + *c__ * e;
+ *p = (*b + *a * e) / f;
+ *q = (-(*a) + *b * e) / f;
+ }
+
+ return 0;
+
+/* End of SLADIV */
+
+} /* sladiv_ */
diff --git a/SRC/slae2.c b/SRC/slae2.c
new file mode 100644
index 0000000..c82234c
--- /dev/null
+++ b/SRC/slae2.c
@@ -0,0 +1,141 @@
+/* slae2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slae2_(real *a, real *b, real *c__, real *rt1, real *rt2)
+{
+ /* System generated locals */
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real ab, df, tb, sm, rt, adf, acmn, acmx;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix */
+/* [ A B ] */
+/* [ B C ]. */
+/* On return, RT1 is the eigenvalue of larger absolute value, and RT2 */
+/* is the eigenvalue of smaller absolute value. */
+
+/* Arguments */
+/* ========= */
+
+/* A (input) REAL */
+/* The (1,1) element of the 2-by-2 matrix. */
+
+/* B (input) REAL */
+/* The (1,2) and (2,1) elements of the 2-by-2 matrix. */
+
+/* C (input) REAL */
+/* The (2,2) element of the 2-by-2 matrix. */
+
+/* RT1 (output) REAL */
+/* The eigenvalue of larger absolute value. */
+
+/* RT2 (output) REAL */
+/* The eigenvalue of smaller absolute value. */
+
+/* Further Details */
+/* =============== */
+
+/* RT1 is accurate to a few ulps barring over/underflow. */
+
+/* RT2 may be inaccurate if there is massive cancellation in the */
+/* determinant A*C-B*B; higher precision or correctly rounded or */
+/* correctly truncated arithmetic would be needed to compute RT2 */
+/* accurately in all cases. */
+
+/* Overflow is possible only if RT1 is within a factor of 5 of overflow. */
+/* Underflow is harmless if the input data is 0 or exceeds */
+/* underflow_threshold / macheps. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Compute the eigenvalues */
+
+ sm = *a + *c__;
+ df = *a - *c__;
+ adf = dabs(df);
+ tb = *b + *b;
+ ab = dabs(tb);
+ if (dabs(*a) > dabs(*c__)) {
+ acmx = *a;
+ acmn = *c__;
+ } else {
+ acmx = *c__;
+ acmn = *a;
+ }
+ if (adf > ab) {
+/* Computing 2nd power */
+ r__1 = ab / adf;
+ rt = adf * sqrt(r__1 * r__1 + 1.f);
+ } else if (adf < ab) {
+/* Computing 2nd power */
+ r__1 = adf / ab;
+ rt = ab * sqrt(r__1 * r__1 + 1.f);
+ } else {
+
+/* Includes case AB=ADF=0 */
+
+ rt = ab * sqrt(2.f);
+ }
+ if (sm < 0.f) {
+ *rt1 = (sm - rt) * .5f;
+
+/* Order of execution important. */
+/* To get fully accurate smaller eigenvalue, */
+/* next line needs to be executed in higher precision. */
+
+ *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
+ } else if (sm > 0.f) {
+ *rt1 = (sm + rt) * .5f;
+
+/* Order of execution important. */
+/* To get fully accurate smaller eigenvalue, */
+/* next line needs to be executed in higher precision. */
+
+ *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
+ } else {
+
+/* Includes case RT1 = RT2 = 0 */
+
+ *rt1 = rt * .5f;
+ *rt2 = rt * -.5f;
+ }
+ return 0;
+
+/* End of SLAE2 */
+
+} /* slae2_ */
diff --git a/SRC/slaebz.c b/SRC/slaebz.c
new file mode 100644
index 0000000..e7aaac0
--- /dev/null
+++ b/SRC/slaebz.c
@@ -0,0 +1,639 @@
+/* slaebz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slaebz_(integer *ijob, integer *nitmax, integer *n,
+ integer *mmax, integer *minp, integer *nbmin, real *abstol, real *
+ reltol, real *pivmin, real *d__, real *e, real *e2, integer *nval,
+ real *ab, real *c__, integer *mout, integer *nab, real *work, integer
+ *iwork, integer *info)
+{
+ /* System generated locals */
+ integer nab_dim1, nab_offset, ab_dim1, ab_offset, i__1, i__2, i__3, i__4,
+ i__5, i__6;
+ real r__1, r__2, r__3, r__4;
+
+ /* Local variables */
+ integer j, kf, ji, kl, jp, jit;
+ real tmp1, tmp2;
+ integer itmp1, itmp2, kfnew, klnew;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAEBZ contains the iteration loops which compute and use the */
+/* function N(w), which is the count of eigenvalues of a symmetric */
+/* tridiagonal matrix T less than or equal to its argument w. It */
+/* performs a choice of two types of loops: */
+
+/* IJOB=1, followed by */
+/* IJOB=2: It takes as input a list of intervals and returns a list of */
+/* sufficiently small intervals whose union contains the same */
+/* eigenvalues as the union of the original intervals. */
+/* The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP. */
+/* The output interval (AB(j,1),AB(j,2)] will contain */
+/* eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT. */
+
+/* IJOB=3: It performs a binary search in each input interval */
+/* (AB(j,1),AB(j,2)] for a point w(j) such that */
+/* N(w(j))=NVAL(j), and uses C(j) as the starting point of */
+/* the search. If such a w(j) is found, then on output */
+/* AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output */
+/* (AB(j,1),AB(j,2)] will be a small interval containing the */
+/* point where N(w) jumps through NVAL(j), unless that point */
+/* lies outside the initial interval. */
+
+/* Note that the intervals are in all cases half-open intervals, */
+/* i.e., of the form (a,b] , which includes b but not a . */
+
+/* To avoid underflow, the matrix should be scaled so that its largest */
+/* element is no greater than overflow**(1/2) * underflow**(1/4) */
+/* in absolute value. To assure the most accurate computation */
+/* of small eigenvalues, the matrix should be scaled to be */
+/* not much smaller than that, either. */
+
+/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */
+/* Matrix", Report CS41, Computer Science Dept., Stanford */
+/* University, July 21, 1966 */
+
+/* Note: the arguments are, in general, *not* checked for unreasonable */
+/* values. */
+
+/* Arguments */
+/* ========= */
+
+/* IJOB (input) INTEGER */
+/* Specifies what is to be done: */
+/* = 1: Compute NAB for the initial intervals. */
+/* = 2: Perform bisection iteration to find eigenvalues of T. */
+/* = 3: Perform bisection iteration to invert N(w), i.e., */
+/* to find a point which has a specified number of */
+/* eigenvalues of T to its left. */
+/* Other values will cause SLAEBZ to return with INFO=-1. */
+
+/* NITMAX (input) INTEGER */
+/* The maximum number of "levels" of bisection to be */
+/* performed, i.e., an interval of width W will not be made */
+/* smaller than 2^(-NITMAX) * W. If not all intervals */
+/* have converged after NITMAX iterations, then INFO is set */
+/* to the number of non-converged intervals. */
+
+/* N (input) INTEGER */
+/* The dimension n of the tridiagonal matrix T. It must be at */
+/* least 1. */
+
+/* MMAX (input) INTEGER */
+/* The maximum number of intervals. If more than MMAX intervals */
+/* are generated, then SLAEBZ will quit with INFO=MMAX+1. */
+
+/* MINP (input) INTEGER */
+/* The initial number of intervals. It may not be greater than */
+/* MMAX. */
+
+/* NBMIN (input) INTEGER */
+/* The smallest number of intervals that should be processed */
+/* using a vector loop. If zero, then only the scalar loop */
+/* will be used. */
+
+/* ABSTOL (input) REAL */
+/* The minimum (absolute) width of an interval. When an */
+/* interval is narrower than ABSTOL, or than RELTOL times the */
+/* larger (in magnitude) endpoint, then it is considered to be */
+/* sufficiently small, i.e., converged. This must be at least */
+/* zero. */
+
+/* RELTOL (input) REAL */
+/* The minimum relative width of an interval. When an interval */
+/* is narrower than ABSTOL, or than RELTOL times the larger (in */
+/* magnitude) endpoint, then it is considered to be */
+/* sufficiently small, i.e., converged. Note: this should */
+/* always be at least radix*machine epsilon. */
+
+/* PIVMIN (input) REAL */
+/* The minimum absolute value of a "pivot" in the Sturm */
+/* sequence loop. This *must* be at least max |e(j)**2| * */
+/* safe_min and at least safe_min, where safe_min is at least */
+/* the smallest number that can divide one without overflow. */
+
+/* D (input) REAL array, dimension (N) */
+/* The diagonal elements of the tridiagonal matrix T. */
+
+/* E (input) REAL array, dimension (N) */
+/* The offdiagonal elements of the tridiagonal matrix T in */
+/* positions 1 through N-1. E(N) is arbitrary. */
+
+/* E2 (input) REAL array, dimension (N) */
+/* The squares of the offdiagonal elements of the tridiagonal */
+/* matrix T. E2(N) is ignored. */
+
+/* NVAL (input/output) INTEGER array, dimension (MINP) */
+/* If IJOB=1 or 2, not referenced. */
+/* If IJOB=3, the desired values of N(w). The elements of NVAL */
+/* will be reordered to correspond with the intervals in AB. */
+/* Thus, NVAL(j) on output will not, in general be the same as */
+/* NVAL(j) on input, but it will correspond with the interval */
+/* (AB(j,1),AB(j,2)] on output. */
+
+/* AB (input/output) REAL array, dimension (MMAX,2) */
+/* The endpoints of the intervals. AB(j,1) is a(j), the left */
+/* endpoint of the j-th interval, and AB(j,2) is b(j), the */
+/* right endpoint of the j-th interval. The input intervals */
+/* will, in general, be modified, split, and reordered by the */
+/* calculation. */
+
+/* C (input/output) REAL array, dimension (MMAX) */
+/* If IJOB=1, ignored. */
+/* If IJOB=2, workspace. */
+/* If IJOB=3, then on input C(j) should be initialized to the */
+/* first search point in the binary search. */
+
+/* MOUT (output) INTEGER */
+/* If IJOB=1, the number of eigenvalues in the intervals. */
+/* If IJOB=2 or 3, the number of intervals output. */
+/* If IJOB=3, MOUT will equal MINP. */
+
+/* NAB (input/output) INTEGER array, dimension (MMAX,2) */
+/* If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)). */
+/* If IJOB=2, then on input, NAB(i,j) should be set. It must */
+/* satisfy the condition: */
+/* N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)), */
+/* which means that in interval i only eigenvalues */
+/* NAB(i,1)+1,...,NAB(i,2) will be considered. Usually, */
+/* NAB(i,j)=N(AB(i,j)), from a previous call to SLAEBZ with */
+/* IJOB=1. */
+/* On output, NAB(i,j) will contain */
+/* max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of */
+/* the input interval that the output interval */
+/* (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the */
+/* the input values of NAB(k,1) and NAB(k,2). */
+/* If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)), */
+/* unless N(w) > NVAL(i) for all search points w , in which */
+/* case NAB(i,1) will not be modified, i.e., the output */
+/* value will be the same as the input value (modulo */
+/* reorderings -- see NVAL and AB), or unless N(w) < NVAL(i) */
+/* for all search points w , in which case NAB(i,2) will */
+/* not be modified. Normally, NAB should be set to some */
+/* distinctive value(s) before SLAEBZ is called. */
+
+/* WORK (workspace) REAL array, dimension (MMAX) */
+/* Workspace. */
+
+/* IWORK (workspace) INTEGER array, dimension (MMAX) */
+/* Workspace. */
+
+/* INFO (output) INTEGER */
+/* = 0: All intervals converged. */
+/* = 1--MMAX: The last INFO intervals did not converge. */
+/* = MMAX+1: More than MMAX intervals were generated. */
+
+/* Further Details */
+/* =============== */
+
+/* This routine is intended to be called only by other LAPACK */
+/* routines, thus the interface is less user-friendly. It is intended */
+/* for two purposes: */
+
+/* (a) finding eigenvalues. In this case, SLAEBZ should have one or */
+/* more initial intervals set up in AB, and SLAEBZ should be called */
+/* with IJOB=1. This sets up NAB, and also counts the eigenvalues. */
+/* Intervals with no eigenvalues would usually be thrown out at */
+/* this point. Also, if not all the eigenvalues in an interval i */
+/* are desired, NAB(i,1) can be increased or NAB(i,2) decreased. */
+/* For example, set NAB(i,1)=NAB(i,2)-1 to get the largest */
+/* eigenvalue. SLAEBZ is then called with IJOB=2 and MMAX */
+/* no smaller than the value of MOUT returned by the call with */
+/* IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1 */
+/* through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the */
+/* tolerance specified by ABSTOL and RELTOL. */
+
+/* (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l). */
+/* In this case, start with a Gershgorin interval (a,b). Set up */
+/* AB to contain 2 search intervals, both initially (a,b). One */
+/* NVAL element should contain f-1 and the other should contain l */
+/* , while C should contain a and b, resp. NAB(i,1) should be -1 */
+/* and NAB(i,2) should be N+1, to flag an error if the desired */
+/* interval does not lie in (a,b). SLAEBZ is then called with */
+/* IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals -- */
+/* j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while */
+/* if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r */
+/* >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and */
+/* N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and */
+/* w(l-r)=...=w(l+k) are handled similarly. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for Errors */
+
+ /* Parameter adjustments */
+ nab_dim1 = *mmax;
+ nab_offset = 1 + nab_dim1;
+ nab -= nab_offset;
+ ab_dim1 = *mmax;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --d__;
+ --e;
+ --e2;
+ --nval;
+ --c__;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ if (*ijob < 1 || *ijob > 3) {
+ *info = -1;
+ return 0;
+ }
+
+/* Initialize NAB */
+
+ if (*ijob == 1) {
+
+/* Compute the number of eigenvalues in the initial intervals. */
+
+ *mout = 0;
+/* DIR$ NOVECTOR */
+ i__1 = *minp;
+ for (ji = 1; ji <= i__1; ++ji) {
+ for (jp = 1; jp <= 2; ++jp) {
+ tmp1 = d__[1] - ab[ji + jp * ab_dim1];
+ if (dabs(tmp1) < *pivmin) {
+ tmp1 = -(*pivmin);
+ }
+ nab[ji + jp * nab_dim1] = 0;
+ if (tmp1 <= 0.f) {
+ nab[ji + jp * nab_dim1] = 1;
+ }
+
+ i__2 = *n;
+ for (j = 2; j <= i__2; ++j) {
+ tmp1 = d__[j] - e2[j - 1] / tmp1 - ab[ji + jp * ab_dim1];
+ if (dabs(tmp1) < *pivmin) {
+ tmp1 = -(*pivmin);
+ }
+ if (tmp1 <= 0.f) {
+ ++nab[ji + jp * nab_dim1];
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+ *mout = *mout + nab[ji + (nab_dim1 << 1)] - nab[ji + nab_dim1];
+/* L30: */
+ }
+ return 0;
+ }
+
+/* Initialize for loop */
+
+/* KF and KL have the following meaning: */
+/* Intervals 1,...,KF-1 have converged. */
+/* Intervals KF,...,KL still need to be refined. */
+
+ kf = 1;
+ kl = *minp;
+
+/* If IJOB=2, initialize C. */
+/* If IJOB=3, use the user-supplied starting point. */
+
+ if (*ijob == 2) {
+ i__1 = *minp;
+ for (ji = 1; ji <= i__1; ++ji) {
+ c__[ji] = (ab[ji + ab_dim1] + ab[ji + (ab_dim1 << 1)]) * .5f;
+/* L40: */
+ }
+ }
+
+/* Iteration loop */
+
+ i__1 = *nitmax;
+ for (jit = 1; jit <= i__1; ++jit) {
+
+/* Loop over intervals */
+
+ if (kl - kf + 1 >= *nbmin && *nbmin > 0) {
+
+/* Begin of Parallel Version of the loop */
+
+ i__2 = kl;
+ for (ji = kf; ji <= i__2; ++ji) {
+
+/* Compute N(c), the number of eigenvalues less than c */
+
+ work[ji] = d__[1] - c__[ji];
+ iwork[ji] = 0;
+ if (work[ji] <= *pivmin) {
+ iwork[ji] = 1;
+/* Computing MIN */
+ r__1 = work[ji], r__2 = -(*pivmin);
+ work[ji] = dmin(r__1,r__2);
+ }
+
+ i__3 = *n;
+ for (j = 2; j <= i__3; ++j) {
+ work[ji] = d__[j] - e2[j - 1] / work[ji] - c__[ji];
+ if (work[ji] <= *pivmin) {
+ ++iwork[ji];
+/* Computing MIN */
+ r__1 = work[ji], r__2 = -(*pivmin);
+ work[ji] = dmin(r__1,r__2);
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+
+ if (*ijob <= 2) {
+
+/* IJOB=2: Choose all intervals containing eigenvalues. */
+
+ klnew = kl;
+ i__2 = kl;
+ for (ji = kf; ji <= i__2; ++ji) {
+
+/* Insure that N(w) is monotone */
+
+/* Computing MIN */
+/* Computing MAX */
+ i__5 = nab[ji + nab_dim1], i__6 = iwork[ji];
+ i__3 = nab[ji + (nab_dim1 << 1)], i__4 = max(i__5,i__6);
+ iwork[ji] = min(i__3,i__4);
+
+/* Update the Queue -- add intervals if both halves */
+/* contain eigenvalues. */
+
+ if (iwork[ji] == nab[ji + (nab_dim1 << 1)]) {
+
+/* No eigenvalue in the upper interval: */
+/* just use the lower interval. */
+
+ ab[ji + (ab_dim1 << 1)] = c__[ji];
+
+ } else if (iwork[ji] == nab[ji + nab_dim1]) {
+
+/* No eigenvalue in the lower interval: */
+/* just use the upper interval. */
+
+ ab[ji + ab_dim1] = c__[ji];
+ } else {
+ ++klnew;
+ if (klnew <= *mmax) {
+
+/* Eigenvalue in both intervals -- add upper to */
+/* queue. */
+
+ ab[klnew + (ab_dim1 << 1)] = ab[ji + (ab_dim1 <<
+ 1)];
+ nab[klnew + (nab_dim1 << 1)] = nab[ji + (nab_dim1
+ << 1)];
+ ab[klnew + ab_dim1] = c__[ji];
+ nab[klnew + nab_dim1] = iwork[ji];
+ ab[ji + (ab_dim1 << 1)] = c__[ji];
+ nab[ji + (nab_dim1 << 1)] = iwork[ji];
+ } else {
+ *info = *mmax + 1;
+ }
+ }
+/* L70: */
+ }
+ if (*info != 0) {
+ return 0;
+ }
+ kl = klnew;
+ } else {
+
+/* IJOB=3: Binary search. Keep only the interval containing */
+/* w s.t. N(w) = NVAL */
+
+ i__2 = kl;
+ for (ji = kf; ji <= i__2; ++ji) {
+ if (iwork[ji] <= nval[ji]) {
+ ab[ji + ab_dim1] = c__[ji];
+ nab[ji + nab_dim1] = iwork[ji];
+ }
+ if (iwork[ji] >= nval[ji]) {
+ ab[ji + (ab_dim1 << 1)] = c__[ji];
+ nab[ji + (nab_dim1 << 1)] = iwork[ji];
+ }
+/* L80: */
+ }
+ }
+
+ } else {
+
+/* End of Parallel Version of the loop */
+
+/* Begin of Serial Version of the loop */
+
+ klnew = kl;
+ i__2 = kl;
+ for (ji = kf; ji <= i__2; ++ji) {
+
+/* Compute N(w), the number of eigenvalues less than w */
+
+ tmp1 = c__[ji];
+ tmp2 = d__[1] - tmp1;
+ itmp1 = 0;
+ if (tmp2 <= *pivmin) {
+ itmp1 = 1;
+/* Computing MIN */
+ r__1 = tmp2, r__2 = -(*pivmin);
+ tmp2 = dmin(r__1,r__2);
+ }
+
+/* A series of compiler directives to defeat vectorization */
+/* for the next loop */
+
+/* $PL$ CMCHAR=' ' */
+/* DIR$ NEXTSCALAR */
+/* $DIR SCALAR */
+/* DIR$ NEXT SCALAR */
+/* VD$L NOVECTOR */
+/* DEC$ NOVECTOR */
+/* VD$ NOVECTOR */
+/* VDIR NOVECTOR */
+/* VOCL LOOP,SCALAR */
+/* IBM PREFER SCALAR */
+/* $PL$ CMCHAR='*' */
+
+ i__3 = *n;
+ for (j = 2; j <= i__3; ++j) {
+ tmp2 = d__[j] - e2[j - 1] / tmp2 - tmp1;
+ if (tmp2 <= *pivmin) {
+ ++itmp1;
+/* Computing MIN */
+ r__1 = tmp2, r__2 = -(*pivmin);
+ tmp2 = dmin(r__1,r__2);
+ }
+/* L90: */
+ }
+
+ if (*ijob <= 2) {
+
+/* IJOB=2: Choose all intervals containing eigenvalues. */
+
+/* Insure that N(w) is monotone */
+
+/* Computing MIN */
+/* Computing MAX */
+ i__5 = nab[ji + nab_dim1];
+ i__3 = nab[ji + (nab_dim1 << 1)], i__4 = max(i__5,itmp1);
+ itmp1 = min(i__3,i__4);
+
+/* Update the Queue -- add intervals if both halves */
+/* contain eigenvalues. */
+
+ if (itmp1 == nab[ji + (nab_dim1 << 1)]) {
+
+/* No eigenvalue in the upper interval: */
+/* just use the lower interval. */
+
+ ab[ji + (ab_dim1 << 1)] = tmp1;
+
+ } else if (itmp1 == nab[ji + nab_dim1]) {
+
+/* No eigenvalue in the lower interval: */
+/* just use the upper interval. */
+
+ ab[ji + ab_dim1] = tmp1;
+ } else if (klnew < *mmax) {
+
+/* Eigenvalue in both intervals -- add upper to queue. */
+
+ ++klnew;
+ ab[klnew + (ab_dim1 << 1)] = ab[ji + (ab_dim1 << 1)];
+ nab[klnew + (nab_dim1 << 1)] = nab[ji + (nab_dim1 <<
+ 1)];
+ ab[klnew + ab_dim1] = tmp1;
+ nab[klnew + nab_dim1] = itmp1;
+ ab[ji + (ab_dim1 << 1)] = tmp1;
+ nab[ji + (nab_dim1 << 1)] = itmp1;
+ } else {
+ *info = *mmax + 1;
+ return 0;
+ }
+ } else {
+
+/* IJOB=3: Binary search. Keep only the interval */
+/* containing w s.t. N(w) = NVAL */
+
+ if (itmp1 <= nval[ji]) {
+ ab[ji + ab_dim1] = tmp1;
+ nab[ji + nab_dim1] = itmp1;
+ }
+ if (itmp1 >= nval[ji]) {
+ ab[ji + (ab_dim1 << 1)] = tmp1;
+ nab[ji + (nab_dim1 << 1)] = itmp1;
+ }
+ }
+/* L100: */
+ }
+ kl = klnew;
+
+/* End of Serial Version of the loop */
+
+ }
+
+/* Check for convergence */
+
+ kfnew = kf;
+ i__2 = kl;
+ for (ji = kf; ji <= i__2; ++ji) {
+ tmp1 = (r__1 = ab[ji + (ab_dim1 << 1)] - ab[ji + ab_dim1], dabs(
+ r__1));
+/* Computing MAX */
+ r__3 = (r__1 = ab[ji + (ab_dim1 << 1)], dabs(r__1)), r__4 = (r__2
+ = ab[ji + ab_dim1], dabs(r__2));
+ tmp2 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__1 = max(*abstol,*pivmin), r__2 = *reltol * tmp2;
+ if (tmp1 < dmax(r__1,r__2) || nab[ji + nab_dim1] >= nab[ji + (
+ nab_dim1 << 1)]) {
+
+/* Converged -- Swap with position KFNEW, */
+/* then increment KFNEW */
+
+ if (ji > kfnew) {
+ tmp1 = ab[ji + ab_dim1];
+ tmp2 = ab[ji + (ab_dim1 << 1)];
+ itmp1 = nab[ji + nab_dim1];
+ itmp2 = nab[ji + (nab_dim1 << 1)];
+ ab[ji + ab_dim1] = ab[kfnew + ab_dim1];
+ ab[ji + (ab_dim1 << 1)] = ab[kfnew + (ab_dim1 << 1)];
+ nab[ji + nab_dim1] = nab[kfnew + nab_dim1];
+ nab[ji + (nab_dim1 << 1)] = nab[kfnew + (nab_dim1 << 1)];
+ ab[kfnew + ab_dim1] = tmp1;
+ ab[kfnew + (ab_dim1 << 1)] = tmp2;
+ nab[kfnew + nab_dim1] = itmp1;
+ nab[kfnew + (nab_dim1 << 1)] = itmp2;
+ if (*ijob == 3) {
+ itmp1 = nval[ji];
+ nval[ji] = nval[kfnew];
+ nval[kfnew] = itmp1;
+ }
+ }
+ ++kfnew;
+ }
+/* L110: */
+ }
+ kf = kfnew;
+
+/* Choose Midpoints */
+
+ i__2 = kl;
+ for (ji = kf; ji <= i__2; ++ji) {
+ c__[ji] = (ab[ji + ab_dim1] + ab[ji + (ab_dim1 << 1)]) * .5f;
+/* L120: */
+ }
+
+/* If no more intervals to refine, quit. */
+
+ if (kf > kl) {
+ goto L140;
+ }
+/* L130: */
+ }
+
+/* Converged */
+
+L140:
+/* Computing MAX */
+ i__1 = kl + 1 - kf;
+ *info = max(i__1,0);
+ *mout = kl;
+
+ return 0;
+
+/* End of SLAEBZ */
+
+} /* slaebz_ */
diff --git a/SRC/slaed0.c b/SRC/slaed0.c
new file mode 100644
index 0000000..589956a
--- /dev/null
+++ b/SRC/slaed0.c
@@ -0,0 +1,435 @@
+/* slaed0.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__9 = 9;
+static integer c__0 = 0;
+static integer c__2 = 2;
+static real c_b23 = 1.f;
+static real c_b24 = 0.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int slaed0_(integer *icompq, integer *qsiz, integer *n, real
+ *d__, real *e, real *q, integer *ldq, real *qstore, integer *ldqs,
+ real *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2;
+ real r__1;
+
+ /* Builtin functions */
+ double log(doublereal);
+ integer pow_ii(integer *, integer *);
+
+ /* Local variables */
+ integer i__, j, k, iq, lgn, msd2, smm1, spm1, spm2;
+ real temp;
+ integer curr;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ integer iperm, indxq, iwrem;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ integer iqptr, tlvls;
+ extern /* Subroutine */ int slaed1_(integer *, real *, real *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *),
+ slaed7_(integer *, integer *, integer *, integer *, integer *,
+ integer *, real *, real *, integer *, integer *, real *, integer *
+, real *, integer *, integer *, integer *, integer *, integer *,
+ real *, real *, integer *, integer *);
+ integer igivcl;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer igivnm, submat;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+ integer curprb, subpbs, igivpt, curlvl, matsiz, iprmpt, smlsiz;
+ extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *,
+ real *, integer *, real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAED0 computes all eigenvalues and corresponding eigenvectors of a */
+/* symmetric tridiagonal matrix using the divide and conquer method. */
+
+/* Arguments */
+/* ========= */
+
+/* ICOMPQ (input) INTEGER */
+/* = 0: Compute eigenvalues only. */
+/* = 1: Compute eigenvectors of original dense symmetric matrix */
+/* also. On entry, Q contains the orthogonal matrix used */
+/* to reduce the original matrix to tridiagonal form. */
+/* = 2: Compute eigenvalues and eigenvectors of tridiagonal */
+/* matrix. */
+
+/* QSIZ (input) INTEGER */
+/* The dimension of the orthogonal matrix used to reduce */
+/* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. */
+
+/* N (input) INTEGER */
+/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the main diagonal of the tridiagonal matrix. */
+/* On exit, its eigenvalues. */
+
+/* E (input) REAL array, dimension (N-1) */
+/* The off-diagonal elements of the tridiagonal matrix. */
+/* On exit, E has been destroyed. */
+
+/* Q (input/output) REAL array, dimension (LDQ, N) */
+/* On entry, Q must contain an N-by-N orthogonal matrix. */
+/* If ICOMPQ = 0 Q is not referenced. */
+/* If ICOMPQ = 1 On entry, Q is a subset of the columns of the */
+/* orthogonal matrix used to reduce the full */
+/* matrix to tridiagonal form corresponding to */
+/* the subset of the full matrix which is being */
+/* decomposed at this time. */
+/* If ICOMPQ = 2 On entry, Q will be the identity matrix. */
+/* On exit, Q contains the eigenvectors of the */
+/* tridiagonal matrix. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. If eigenvectors are */
+/* desired, then LDQ >= max(1,N). In any case, LDQ >= 1. */
+
+/* QSTORE (workspace) REAL array, dimension (LDQS, N) */
+/* Referenced only when ICOMPQ = 1. Used to store parts of */
+/* the eigenvector matrix when the updating matrix multiplies */
+/* take place. */
+
+/* LDQS (input) INTEGER */
+/* The leading dimension of the array QSTORE. If ICOMPQ = 1, */
+/* then LDQS >= max(1,N). In any case, LDQS >= 1. */
+
+/* WORK (workspace) REAL array, */
+/* If ICOMPQ = 0 or 1, the dimension of WORK must be at least */
+/* 1 + 3*N + 2*N*lg N + 2*N**2 */
+/* ( lg( N ) = smallest integer k */
+/* such that 2^k >= N ) */
+/* If ICOMPQ = 2, the dimension of WORK must be at least */
+/* 4*N + N**2. */
+
+/* IWORK (workspace) INTEGER array, */
+/* If ICOMPQ = 0 or 1, the dimension of IWORK must be at least */
+/* 6 + 6*N + 5*N*lg N. */
+/* ( lg( N ) = smallest integer k */
+/* such that 2^k >= N ) */
+/* If ICOMPQ = 2, the dimension of IWORK must be at least */
+/* 3 + 5*N. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: The algorithm failed to compute an eigenvalue while */
+/* working on the submatrix lying in rows and columns */
+/* INFO/(N+1) through mod(INFO,N+1). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ qstore_dim1 = *ldqs;
+ qstore_offset = 1 + qstore_dim1;
+ qstore -= qstore_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*icompq < 0 || *icompq > 2) {
+ *info = -1;
+ } else if (*icompq == 1 && *qsiz < max(0,*n)) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ldq < max(1,*n)) {
+ *info = -7;
+ } else if (*ldqs < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLAED0", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ smlsiz = ilaenv_(&c__9, "SLAED0", " ", &c__0, &c__0, &c__0, &c__0);
+
+/* Determine the size and placement of the submatrices, and save in */
+/* the leading elements of IWORK. */
+
+ iwork[1] = *n;
+ subpbs = 1;
+ tlvls = 0;
+L10:
+ if (iwork[subpbs] > smlsiz) {
+ for (j = subpbs; j >= 1; --j) {
+ iwork[j * 2] = (iwork[j] + 1) / 2;
+ iwork[(j << 1) - 1] = iwork[j] / 2;
+/* L20: */
+ }
+ ++tlvls;
+ subpbs <<= 1;
+ goto L10;
+ }
+ i__1 = subpbs;
+ for (j = 2; j <= i__1; ++j) {
+ iwork[j] += iwork[j - 1];
+/* L30: */
+ }
+
+/* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 */
+/* using rank-1 modifications (cuts). */
+
+ spm1 = subpbs - 1;
+ i__1 = spm1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ submat = iwork[i__] + 1;
+ smm1 = submat - 1;
+ d__[smm1] -= (r__1 = e[smm1], dabs(r__1));
+ d__[submat] -= (r__1 = e[smm1], dabs(r__1));
+/* L40: */
+ }
+
+ indxq = (*n << 2) + 3;
+ if (*icompq != 2) {
+
+/* Set up workspaces for eigenvalues only/accumulate new vectors */
+/* routine */
+
+ temp = log((real) (*n)) / log(2.f);
+ lgn = (integer) temp;
+ if (pow_ii(&c__2, &lgn) < *n) {
+ ++lgn;
+ }
+ if (pow_ii(&c__2, &lgn) < *n) {
+ ++lgn;
+ }
+ iprmpt = indxq + *n + 1;
+ iperm = iprmpt + *n * lgn;
+ iqptr = iperm + *n * lgn;
+ igivpt = iqptr + *n + 2;
+ igivcl = igivpt + *n * lgn;
+
+ igivnm = 1;
+ iq = igivnm + (*n << 1) * lgn;
+/* Computing 2nd power */
+ i__1 = *n;
+ iwrem = iq + i__1 * i__1 + 1;
+
+/* Initialize pointers */
+
+ i__1 = subpbs;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ iwork[iprmpt + i__] = 1;
+ iwork[igivpt + i__] = 1;
+/* L50: */
+ }
+ iwork[iqptr] = 1;
+ }
+
+/* Solve each submatrix eigenproblem at the bottom of the divide and */
+/* conquer tree. */
+
+ curr = 0;
+ i__1 = spm1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ if (i__ == 0) {
+ submat = 1;
+ matsiz = iwork[1];
+ } else {
+ submat = iwork[i__] + 1;
+ matsiz = iwork[i__ + 1] - iwork[i__];
+ }
+ if (*icompq == 2) {
+ ssteqr_("I", &matsiz, &d__[submat], &e[submat], &q[submat +
+ submat * q_dim1], ldq, &work[1], info);
+ if (*info != 0) {
+ goto L130;
+ }
+ } else {
+ ssteqr_("I", &matsiz, &d__[submat], &e[submat], &work[iq - 1 +
+ iwork[iqptr + curr]], &matsiz, &work[1], info);
+ if (*info != 0) {
+ goto L130;
+ }
+ if (*icompq == 1) {
+ sgemm_("N", "N", qsiz, &matsiz, &matsiz, &c_b23, &q[submat *
+ q_dim1 + 1], ldq, &work[iq - 1 + iwork[iqptr + curr]],
+ &matsiz, &c_b24, &qstore[submat * qstore_dim1 + 1],
+ ldqs);
+ }
+/* Computing 2nd power */
+ i__2 = matsiz;
+ iwork[iqptr + curr + 1] = iwork[iqptr + curr] + i__2 * i__2;
+ ++curr;
+ }
+ k = 1;
+ i__2 = iwork[i__ + 1];
+ for (j = submat; j <= i__2; ++j) {
+ iwork[indxq + j] = k;
+ ++k;
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Successively merge eigensystems of adjacent submatrices */
+/* into eigensystem for the corresponding larger matrix. */
+
+/* while ( SUBPBS > 1 ) */
+
+ curlvl = 1;
+L80:
+ if (subpbs > 1) {
+ spm2 = subpbs - 2;
+ i__1 = spm2;
+ for (i__ = 0; i__ <= i__1; i__ += 2) {
+ if (i__ == 0) {
+ submat = 1;
+ matsiz = iwork[2];
+ msd2 = iwork[1];
+ curprb = 0;
+ } else {
+ submat = iwork[i__] + 1;
+ matsiz = iwork[i__ + 2] - iwork[i__];
+ msd2 = matsiz / 2;
+ ++curprb;
+ }
+
+/* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) */
+/* into an eigensystem of size MATSIZ. */
+/* SLAED1 is used only for the full eigensystem of a tridiagonal */
+/* matrix. */
+/* SLAED7 handles the cases in which eigenvalues only or eigenvalues */
+/* and eigenvectors of a full symmetric matrix (which was reduced to */
+/* tridiagonal form) are desired. */
+
+ if (*icompq == 2) {
+ slaed1_(&matsiz, &d__[submat], &q[submat + submat * q_dim1],
+ ldq, &iwork[indxq + submat], &e[submat + msd2 - 1], &
+ msd2, &work[1], &iwork[subpbs + 1], info);
+ } else {
+ slaed7_(icompq, &matsiz, qsiz, &tlvls, &curlvl, &curprb, &d__[
+ submat], &qstore[submat * qstore_dim1 + 1], ldqs, &
+ iwork[indxq + submat], &e[submat + msd2 - 1], &msd2, &
+ work[iq], &iwork[iqptr], &iwork[iprmpt], &iwork[iperm]
+, &iwork[igivpt], &iwork[igivcl], &work[igivnm], &
+ work[iwrem], &iwork[subpbs + 1], info);
+ }
+ if (*info != 0) {
+ goto L130;
+ }
+ iwork[i__ / 2 + 1] = iwork[i__ + 2];
+/* L90: */
+ }
+ subpbs /= 2;
+ ++curlvl;
+ goto L80;
+ }
+
+/* end while */
+
+/* Re-merge the eigenvalues/vectors which were deflated at the final */
+/* merge step. */
+
+ if (*icompq == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ j = iwork[indxq + i__];
+ work[i__] = d__[j];
+ scopy_(qsiz, &qstore[j * qstore_dim1 + 1], &c__1, &q[i__ * q_dim1
+ + 1], &c__1);
+/* L100: */
+ }
+ scopy_(n, &work[1], &c__1, &d__[1], &c__1);
+ } else if (*icompq == 2) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ j = iwork[indxq + i__];
+ work[i__] = d__[j];
+ scopy_(n, &q[j * q_dim1 + 1], &c__1, &work[*n * i__ + 1], &c__1);
+/* L110: */
+ }
+ scopy_(n, &work[1], &c__1, &d__[1], &c__1);
+ slacpy_("A", n, n, &work[*n + 1], n, &q[q_offset], ldq);
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ j = iwork[indxq + i__];
+ work[i__] = d__[j];
+/* L120: */
+ }
+ scopy_(n, &work[1], &c__1, &d__[1], &c__1);
+ }
+ goto L140;
+
+L130:
+ *info = submat * (*n + 1) + submat + matsiz - 1;
+
+L140:
+ return 0;
+
+/* End of SLAED0 */
+
+} /* slaed0_ */
diff --git a/SRC/slaed1.c b/SRC/slaed1.c
new file mode 100644
index 0000000..3c95598
--- /dev/null
+++ b/SRC/slaed1.c
@@ -0,0 +1,246 @@
+/* slaed1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int slaed1_(integer *n, real *d__, real *q, integer *ldq,
+ integer *indxq, real *rho, integer *cutpnt, real *work, integer *
+ iwork, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, k, n1, n2, is, iw, iz, iq2, cpp1, indx, indxc, indxp;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), slaed2_(integer *, integer *, integer *, real *, real
+ *, integer *, integer *, real *, real *, real *, real *, real *,
+ integer *, integer *, integer *, integer *, integer *), slaed3_(
+ integer *, integer *, integer *, real *, real *, integer *, real *
+, real *, real *, integer *, integer *, real *, real *, integer *)
+ ;
+ integer idlmda;
+ extern /* Subroutine */ int xerbla_(char *, integer *), slamrg_(
+ integer *, integer *, real *, integer *, integer *, integer *);
+ integer coltyp;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAED1 computes the updated eigensystem of a diagonal */
+/* matrix after modification by a rank-one symmetric matrix. This */
+/* routine is used only for the eigenproblem which requires all */
+/* eigenvalues and eigenvectors of a tridiagonal matrix. SLAED7 handles */
+/* the case in which eigenvalues only or eigenvalues and eigenvectors */
+/* of a full symmetric matrix (which was reduced to tridiagonal form) */
+/* are desired. */
+
+/* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out) */
+
+/* where Z = Q'u, u is a vector of length N with ones in the */
+/* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. */
+
+/* The eigenvectors of the original matrix are stored in Q, and the */
+/* eigenvalues are in D. The algorithm consists of three stages: */
+
+/* The first stage consists of deflating the size of the problem */
+/* when there are multiple eigenvalues or if there is a zero in */
+/* the Z vector. For each such occurence the dimension of the */
+/* secular equation problem is reduced by one. This stage is */
+/* performed by the routine SLAED2. */
+
+/* The second stage consists of calculating the updated */
+/* eigenvalues. This is done by finding the roots of the secular */
+/* equation via the routine SLAED4 (as called by SLAED3). */
+/* This routine also calculates the eigenvectors of the current */
+/* problem. */
+
+/* The final stage consists of computing the updated eigenvectors */
+/* directly using the updated eigenvalues. The eigenvectors for */
+/* the current problem are multiplied with the eigenvectors from */
+/* the overall problem. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the eigenvalues of the rank-1-perturbed matrix. */
+/* On exit, the eigenvalues of the repaired matrix. */
+
+/* Q (input/output) REAL array, dimension (LDQ,N) */
+/* On entry, the eigenvectors of the rank-1-perturbed matrix. */
+/* On exit, the eigenvectors of the repaired tridiagonal matrix. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* INDXQ (input/output) INTEGER array, dimension (N) */
+/* On entry, the permutation which separately sorts the two */
+/* subproblems in D into ascending order. */
+/* On exit, the permutation which will reintegrate the */
+/* subproblems back into sorted order, */
+/* i.e. D( INDXQ( I = 1, N ) ) will be in ascending order. */
+
+/* RHO (input) REAL */
+/* The subdiagonal entry used to create the rank-1 modification. */
+
+/* CUTPNT (input) INTEGER */
+/* The location of the last eigenvalue in the leading sub-matrix. */
+/* min(1,N) <= CUTPNT <= N/2. */
+
+/* WORK (workspace) REAL array, dimension (4*N + N**2) */
+
+/* IWORK (workspace) INTEGER array, dimension (4*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, an eigenvalue did not converge */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+/* Modified by Francoise Tisseur, University of Tennessee. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --indxq;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*n < 0) {
+ *info = -1;
+ } else if (*ldq < max(1,*n)) {
+ *info = -4;
+ } else /* if(complicated condition) */ {
+/* Computing MIN */
+ i__1 = 1, i__2 = *n / 2;
+ if (min(i__1,i__2) > *cutpnt || *n / 2 < *cutpnt) {
+ *info = -7;
+ }
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLAED1", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* The following values are integer pointers which indicate */
+/* the portion of the workspace */
+/* used by a particular array in SLAED2 and SLAED3. */
+
+ iz = 1;
+ idlmda = iz + *n;
+ iw = idlmda + *n;
+ iq2 = iw + *n;
+
+ indx = 1;
+ indxc = indx + *n;
+ coltyp = indxc + *n;
+ indxp = coltyp + *n;
+
+
+/* Form the z-vector which consists of the last row of Q_1 and the */
+/* first row of Q_2. */
+
+ scopy_(cutpnt, &q[*cutpnt + q_dim1], ldq, &work[iz], &c__1);
+ cpp1 = *cutpnt + 1;
+ i__1 = *n - *cutpnt;
+ scopy_(&i__1, &q[cpp1 + cpp1 * q_dim1], ldq, &work[iz + *cutpnt], &c__1);
+
+/* Deflate eigenvalues. */
+
+ slaed2_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, &indxq[1], rho, &work[
+ iz], &work[idlmda], &work[iw], &work[iq2], &iwork[indx], &iwork[
+ indxc], &iwork[indxp], &iwork[coltyp], info);
+
+ if (*info != 0) {
+ goto L20;
+ }
+
+/* Solve Secular Equation. */
+
+ if (k != 0) {
+ is = (iwork[coltyp] + iwork[coltyp + 1]) * *cutpnt + (iwork[coltyp +
+ 1] + iwork[coltyp + 2]) * (*n - *cutpnt) + iq2;
+ slaed3_(&k, n, cutpnt, &d__[1], &q[q_offset], ldq, rho, &work[idlmda],
+ &work[iq2], &iwork[indxc], &iwork[coltyp], &work[iw], &work[
+ is], info);
+ if (*info != 0) {
+ goto L20;
+ }
+
+/* Prepare the INDXQ sorting permutation. */
+
+ n1 = k;
+ n2 = *n - k;
+ slamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]);
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ indxq[i__] = i__;
+/* L10: */
+ }
+ }
+
+L20:
+ return 0;
+
+/* End of SLAED1 */
+
+} /* slaed1_ */
diff --git a/SRC/slaed2.c b/SRC/slaed2.c
new file mode 100644
index 0000000..ad04cf5
--- /dev/null
+++ b/SRC/slaed2.c
@@ -0,0 +1,530 @@
+/* slaed2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b3 = -1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int slaed2_(integer *k, integer *n, integer *n1, real *d__,
+ real *q, integer *ldq, integer *indxq, real *rho, real *z__, real *
+ dlamda, real *w, real *q2, integer *indx, integer *indxc, integer *
+ indxp, integer *coltyp, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, i__1, i__2;
+ real r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real c__;
+ integer i__, j;
+ real s, t;
+ integer k2, n2, ct, nj, pj, js, iq1, iq2, n1p1;
+ real eps, tau, tol;
+ integer psm[4], imax, jmax, ctot[4];
+ extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
+ integer *, real *, real *), sscal_(integer *, real *, real *,
+ integer *), scopy_(integer *, real *, integer *, real *, integer *
+);
+ extern doublereal slapy2_(real *, real *), slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ extern /* Subroutine */ int slamrg_(integer *, integer *, real *, integer
+ *, integer *, integer *), slacpy_(char *, integer *, integer *,
+ real *, integer *, real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAED2 merges the two sets of eigenvalues together into a single */
+/* sorted set. Then it tries to deflate the size of the problem. */
+/* There are two ways in which deflation can occur: when two or more */
+/* eigenvalues are close together or if there is a tiny entry in the */
+/* Z vector. For each such occurrence the order of the related secular */
+/* equation problem is reduced by one. */
+
+/* Arguments */
+/* ========= */
+
+/* K (output) INTEGER */
+/* The number of non-deflated eigenvalues, and the order of the */
+/* related secular equation. 0 <= K <=N. */
+
+/* N (input) INTEGER */
+/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
+
+/* N1 (input) INTEGER */
+/* The location of the last eigenvalue in the leading sub-matrix. */
+/* min(1,N) <= N1 <= N/2. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, D contains the eigenvalues of the two submatrices to */
+/* be combined. */
+/* On exit, D contains the trailing (N-K) updated eigenvalues */
+/* (those which were deflated) sorted into increasing order. */
+
+/* Q (input/output) REAL array, dimension (LDQ, N) */
+/* On entry, Q contains the eigenvectors of two submatrices in */
+/* the two square blocks with corners at (1,1), (N1,N1) */
+/* and (N1+1, N1+1), (N,N). */
+/* On exit, Q contains the trailing (N-K) updated eigenvectors */
+/* (those which were deflated) in its last N-K columns. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* INDXQ (input/output) INTEGER array, dimension (N) */
+/* The permutation which separately sorts the two sub-problems */
+/* in D into ascending order. Note that elements in the second */
+/* half of this permutation must first have N1 added to their */
+/* values. Destroyed on exit. */
+
+/* RHO (input/output) REAL */
+/* On entry, the off-diagonal element associated with the rank-1 */
+/* cut which originally split the two submatrices which are now */
+/* being recombined. */
+/* On exit, RHO has been modified to the value required by */
+/* SLAED3. */
+
+/* Z (input) REAL array, dimension (N) */
+/* On entry, Z contains the updating vector (the last */
+/* row of the first sub-eigenvector matrix and the first row of */
+/* the second sub-eigenvector matrix). */
+/* On exit, the contents of Z have been destroyed by the updating */
+/* process. */
+
+/* DLAMDA (output) REAL array, dimension (N) */
+/* A copy of the first K eigenvalues which will be used by */
+/* SLAED3 to form the secular equation. */
+
+/* W (output) REAL array, dimension (N) */
+/* The first k values of the final deflation-altered z-vector */
+/* which will be passed to SLAED3. */
+
+/* Q2 (output) REAL array, dimension (N1**2+(N-N1)**2) */
+/* A copy of the first K eigenvectors which will be used by */
+/* SLAED3 in a matrix multiply (SGEMM) to solve for the new */
+/* eigenvectors. */
+
+/* INDX (workspace) INTEGER array, dimension (N) */
+/* The permutation used to sort the contents of DLAMDA into */
+/* ascending order. */
+
+/* INDXC (output) INTEGER array, dimension (N) */
+/* The permutation used to arrange the columns of the deflated */
+/* Q matrix into three groups: the first group contains non-zero */
+/* elements only at and above N1, the second contains */
+/* non-zero elements only below N1, and the third is dense. */
+
+/* INDXP (workspace) INTEGER array, dimension (N) */
+/* The permutation used to place deflated values of D at the end */
+/* of the array. INDXP(1:K) points to the nondeflated D-values */
+/* and INDXP(K+1:N) points to the deflated eigenvalues. */
+
+/* COLTYP (workspace/output) INTEGER array, dimension (N) */
+/* During execution, a label which will indicate which of the */
+/* following types a column in the Q2 matrix is: */
+/* 1 : non-zero in the upper half only; */
+/* 2 : dense; */
+/* 3 : non-zero in the lower half only; */
+/* 4 : deflated. */
+/* On exit, COLTYP(i) is the number of columns of type i, */
+/* for i=1 to 4 only. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+/* Modified by Francoise Tisseur, University of Tennessee. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --indxq;
+ --z__;
+ --dlamda;
+ --w;
+ --q2;
+ --indx;
+ --indxc;
+ --indxp;
+ --coltyp;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*n < 0) {
+ *info = -2;
+ } else if (*ldq < max(1,*n)) {
+ *info = -6;
+ } else /* if(complicated condition) */ {
+/* Computing MIN */
+ i__1 = 1, i__2 = *n / 2;
+ if (min(i__1,i__2) > *n1 || *n / 2 < *n1) {
+ *info = -3;
+ }
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLAED2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ n2 = *n - *n1;
+ n1p1 = *n1 + 1;
+
+ if (*rho < 0.f) {
+ sscal_(&n2, &c_b3, &z__[n1p1], &c__1);
+ }
+
+/* Normalize z so that norm(z) = 1. Since z is the concatenation of */
+/* two normalized vectors, norm2(z) = sqrt(2). */
+
+ t = 1.f / sqrt(2.f);
+ sscal_(n, &t, &z__[1], &c__1);
+
+/* RHO = ABS( norm(z)**2 * RHO ) */
+
+ *rho = (r__1 = *rho * 2.f, dabs(r__1));
+
+/* Sort the eigenvalues into increasing order */
+
+ i__1 = *n;
+ for (i__ = n1p1; i__ <= i__1; ++i__) {
+ indxq[i__] += *n1;
+/* L10: */
+ }
+
+/* re-integrate the deflated parts from the last pass */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dlamda[i__] = d__[indxq[i__]];
+/* L20: */
+ }
+ slamrg_(n1, &n2, &dlamda[1], &c__1, &c__1, &indxc[1]);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ indx[i__] = indxq[indxc[i__]];
+/* L30: */
+ }
+
+/* Calculate the allowable deflation tolerance */
+
+ imax = isamax_(n, &z__[1], &c__1);
+ jmax = isamax_(n, &d__[1], &c__1);
+ eps = slamch_("Epsilon");
+/* Computing MAX */
+ r__3 = (r__1 = d__[jmax], dabs(r__1)), r__4 = (r__2 = z__[imax], dabs(
+ r__2));
+ tol = eps * 8.f * dmax(r__3,r__4);
+
+/* If the rank-1 modifier is small enough, no more needs to be done */
+/* except to reorganize Q so that its columns correspond with the */
+/* elements in D. */
+
+ if (*rho * (r__1 = z__[imax], dabs(r__1)) <= tol) {
+ *k = 0;
+ iq2 = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = indx[j];
+ scopy_(n, &q[i__ * q_dim1 + 1], &c__1, &q2[iq2], &c__1);
+ dlamda[j] = d__[i__];
+ iq2 += *n;
+/* L40: */
+ }
+ slacpy_("A", n, n, &q2[1], n, &q[q_offset], ldq);
+ scopy_(n, &dlamda[1], &c__1, &d__[1], &c__1);
+ goto L190;
+ }
+
+/* If there are multiple eigenvalues then the problem deflates. Here */
+/* the number of equal eigenvalues are found. As each equal */
+/* eigenvalue is found, an elementary reflector is computed to rotate */
+/* the corresponding eigensubspace so that the corresponding */
+/* components of Z are zero in this new basis. */
+
+ i__1 = *n1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ coltyp[i__] = 1;
+/* L50: */
+ }
+ i__1 = *n;
+ for (i__ = n1p1; i__ <= i__1; ++i__) {
+ coltyp[i__] = 3;
+/* L60: */
+ }
+
+
+ *k = 0;
+ k2 = *n + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ nj = indx[j];
+ if (*rho * (r__1 = z__[nj], dabs(r__1)) <= tol) {
+
+/* Deflate due to small z component. */
+
+ --k2;
+ coltyp[nj] = 4;
+ indxp[k2] = nj;
+ if (j == *n) {
+ goto L100;
+ }
+ } else {
+ pj = nj;
+ goto L80;
+ }
+/* L70: */
+ }
+L80:
+ ++j;
+ nj = indx[j];
+ if (j > *n) {
+ goto L100;
+ }
+ if (*rho * (r__1 = z__[nj], dabs(r__1)) <= tol) {
+
+/* Deflate due to small z component. */
+
+ --k2;
+ coltyp[nj] = 4;
+ indxp[k2] = nj;
+ } else {
+
+/* Check if eigenvalues are close enough to allow deflation. */
+
+ s = z__[pj];
+ c__ = z__[nj];
+
+/* Find sqrt(a**2+b**2) without overflow or */
+/* destructive underflow. */
+
+ tau = slapy2_(&c__, &s);
+ t = d__[nj] - d__[pj];
+ c__ /= tau;
+ s = -s / tau;
+ if ((r__1 = t * c__ * s, dabs(r__1)) <= tol) {
+
+/* Deflation is possible. */
+
+ z__[nj] = tau;
+ z__[pj] = 0.f;
+ if (coltyp[nj] != coltyp[pj]) {
+ coltyp[nj] = 2;
+ }
+ coltyp[pj] = 4;
+ srot_(n, &q[pj * q_dim1 + 1], &c__1, &q[nj * q_dim1 + 1], &c__1, &
+ c__, &s);
+/* Computing 2nd power */
+ r__1 = c__;
+/* Computing 2nd power */
+ r__2 = s;
+ t = d__[pj] * (r__1 * r__1) + d__[nj] * (r__2 * r__2);
+/* Computing 2nd power */
+ r__1 = s;
+/* Computing 2nd power */
+ r__2 = c__;
+ d__[nj] = d__[pj] * (r__1 * r__1) + d__[nj] * (r__2 * r__2);
+ d__[pj] = t;
+ --k2;
+ i__ = 1;
+L90:
+ if (k2 + i__ <= *n) {
+ if (d__[pj] < d__[indxp[k2 + i__]]) {
+ indxp[k2 + i__ - 1] = indxp[k2 + i__];
+ indxp[k2 + i__] = pj;
+ ++i__;
+ goto L90;
+ } else {
+ indxp[k2 + i__ - 1] = pj;
+ }
+ } else {
+ indxp[k2 + i__ - 1] = pj;
+ }
+ pj = nj;
+ } else {
+ ++(*k);
+ dlamda[*k] = d__[pj];
+ w[*k] = z__[pj];
+ indxp[*k] = pj;
+ pj = nj;
+ }
+ }
+ goto L80;
+L100:
+
+/* Record the last eigenvalue. */
+
+ ++(*k);
+ dlamda[*k] = d__[pj];
+ w[*k] = z__[pj];
+ indxp[*k] = pj;
+
+/* Count up the total number of the various types of columns, then */
+/* form a permutation which positions the four column types into */
+/* four uniform groups (although one or more of these groups may be */
+/* empty). */
+
+ for (j = 1; j <= 4; ++j) {
+ ctot[j - 1] = 0;
+/* L110: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ct = coltyp[j];
+ ++ctot[ct - 1];
+/* L120: */
+ }
+
+/* PSM(*) = Position in SubMatrix (of types 1 through 4) */
+
+ psm[0] = 1;
+ psm[1] = ctot[0] + 1;
+ psm[2] = psm[1] + ctot[1];
+ psm[3] = psm[2] + ctot[2];
+ *k = *n - ctot[3];
+
+/* Fill out the INDXC array so that the permutation which it induces */
+/* will place all type-1 columns first, all type-2 columns next, */
+/* then all type-3's, and finally all type-4's. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ js = indxp[j];
+ ct = coltyp[js];
+ indx[psm[ct - 1]] = js;
+ indxc[psm[ct - 1]] = j;
+ ++psm[ct - 1];
+/* L130: */
+ }
+
+/* Sort the eigenvalues and corresponding eigenvectors into DLAMDA */
+/* and Q2 respectively. The eigenvalues/vectors which were not */
+/* deflated go into the first K slots of DLAMDA and Q2 respectively, */
+/* while those which were deflated go into the last N - K slots. */
+
+ i__ = 1;
+ iq1 = 1;
+ iq2 = (ctot[0] + ctot[1]) * *n1 + 1;
+ i__1 = ctot[0];
+ for (j = 1; j <= i__1; ++j) {
+ js = indx[i__];
+ scopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1);
+ z__[i__] = d__[js];
+ ++i__;
+ iq1 += *n1;
+/* L140: */
+ }
+
+ i__1 = ctot[1];
+ for (j = 1; j <= i__1; ++j) {
+ js = indx[i__];
+ scopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1);
+ scopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1);
+ z__[i__] = d__[js];
+ ++i__;
+ iq1 += *n1;
+ iq2 += n2;
+/* L150: */
+ }
+
+ i__1 = ctot[2];
+ for (j = 1; j <= i__1; ++j) {
+ js = indx[i__];
+ scopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1);
+ z__[i__] = d__[js];
+ ++i__;
+ iq2 += n2;
+/* L160: */
+ }
+
+ iq1 = iq2;
+ i__1 = ctot[3];
+ for (j = 1; j <= i__1; ++j) {
+ js = indx[i__];
+ scopy_(n, &q[js * q_dim1 + 1], &c__1, &q2[iq2], &c__1);
+ iq2 += *n;
+ z__[i__] = d__[js];
+ ++i__;
+/* L170: */
+ }
+
+/* The deflated eigenvalues and their corresponding vectors go back */
+/* into the last N - K slots of D and Q respectively. */
+
+ slacpy_("A", n, &ctot[3], &q2[iq1], n, &q[(*k + 1) * q_dim1 + 1], ldq);
+ i__1 = *n - *k;
+ scopy_(&i__1, &z__[*k + 1], &c__1, &d__[*k + 1], &c__1);
+
+/* Copy CTOT into COLTYP for referencing in SLAED3. */
+
+ for (j = 1; j <= 4; ++j) {
+ coltyp[j] = ctot[j - 1];
+/* L180: */
+ }
+
+L190:
+ return 0;
+
+/* End of SLAED2 */
+
+} /* slaed2_ */
diff --git a/SRC/slaed3.c b/SRC/slaed3.c
new file mode 100644
index 0000000..f95a5cc
--- /dev/null
+++ b/SRC/slaed3.c
@@ -0,0 +1,336 @@
+/* slaed3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b22 = 1.f;
+static real c_b23 = 0.f;
+
+/* Subroutine */ int slaed3_(integer *k, integer *n, integer *n1, real *d__,
+ real *q, integer *ldq, real *rho, real *dlamda, real *q2, integer *
+ indx, integer *ctot, real *w, real *s, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, i__1, i__2;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_sign(real *, real *);
+
+ /* Local variables */
+ integer i__, j, n2, n12, ii, n23, iq2;
+ real temp;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *), scopy_(integer *, real *,
+ integer *, real *, integer *), slaed4_(integer *, integer *, real
+ *, real *, real *, real *, real *, integer *);
+ extern doublereal slamc3_(real *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), slacpy_(
+ char *, integer *, integer *, real *, integer *, real *, integer *
+), slaset_(char *, integer *, integer *, real *, real *,
+ real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAED3 finds the roots of the secular equation, as defined by the */
+/* values in D, W, and RHO, between 1 and K. It makes the */
+/* appropriate calls to SLAED4 and then updates the eigenvectors by */
+/* multiplying the matrix of eigenvectors of the pair of eigensystems */
+/* being combined by the matrix of eigenvectors of the K-by-K system */
+/* which is solved here. */
+
+/* This code makes very mild assumptions about floating point */
+/* arithmetic. It will work on machines with a guard digit in */
+/* add/subtract, or on those binary machines without guard digits */
+/* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */
+/* It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* K (input) INTEGER */
+/* The number of terms in the rational function to be solved by */
+/* SLAED4. K >= 0. */
+
+/* N (input) INTEGER */
+/* The number of rows and columns in the Q matrix. */
+/* N >= K (deflation may result in N>K). */
+
+/* N1 (input) INTEGER */
+/* The location of the last eigenvalue in the leading submatrix. */
+/* min(1,N) <= N1 <= N/2. */
+
+/* D (output) REAL array, dimension (N) */
+/* D(I) contains the updated eigenvalues for */
+/* 1 <= I <= K. */
+
+/* Q (output) REAL array, dimension (LDQ,N) */
+/* Initially the first K columns are used as workspace. */
+/* On output the columns 1 to K contain */
+/* the updated eigenvectors. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* RHO (input) REAL */
+/* The value of the parameter in the rank one update equation. */
+/* RHO >= 0 required. */
+
+/* DLAMDA (input/output) REAL array, dimension (K) */
+/* The first K elements of this array contain the old roots */
+/* of the deflated updating problem. These are the poles */
+/* of the secular equation. May be changed on output by */
+/* having lowest order bit set to zero on Cray X-MP, Cray Y-MP, */
+/* Cray-2, or Cray C-90, as described above. */
+
+/* Q2 (input) REAL array, dimension (LDQ2, N) */
+/* The first K columns of this matrix contain the non-deflated */
+/* eigenvectors for the split problem. */
+
+/* INDX (input) INTEGER array, dimension (N) */
+/* The permutation used to arrange the columns of the deflated */
+/* Q matrix into three groups (see SLAED2). */
+/* The rows of the eigenvectors found by SLAED4 must be likewise */
+/* permuted before the matrix multiply can take place. */
+
+/* CTOT (input) INTEGER array, dimension (4) */
+/* A count of the total number of the various types of columns */
+/* in Q, as described in INDX. The fourth column type is any */
+/* column which has been deflated. */
+
+/* W (input/output) REAL array, dimension (K) */
+/* The first K elements of this array contain the components */
+/* of the deflation-adjusted updating vector. Destroyed on */
+/* output. */
+
+/* S (workspace) REAL array, dimension (N1 + 1)*K */
+/* Will contain the eigenvectors of the repaired matrix which */
+/* will be multiplied by the previously accumulated eigenvectors */
+/* to update the system. */
+
+/* LDS (input) INTEGER */
+/* The leading dimension of S. LDS >= max(1,K). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, an eigenvalue did not converge */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+/* Modified by Francoise Tisseur, University of Tennessee. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --dlamda;
+ --q2;
+ --indx;
+ --ctot;
+ --w;
+ --s;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*k < 0) {
+ *info = -1;
+ } else if (*n < *k) {
+ *info = -2;
+ } else if (*ldq < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLAED3", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*k == 0) {
+ return 0;
+ }
+
+/* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */
+/* be computed with high relative accuracy (barring over/underflow). */
+/* This is a problem on machines without a guard digit in */
+/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */
+/* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), */
+/* which on any of these machines zeros out the bottommost */
+/* bit of DLAMDA(I) if it is 1; this makes the subsequent */
+/* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation */
+/* occurs. On binary machines with a guard digit (almost all */
+/* machines) it does not change DLAMDA(I) at all. On hexadecimal */
+/* and decimal machines with a guard digit, it slightly */
+/* changes the bottommost bits of DLAMDA(I). It does not account */
+/* for hexadecimal or decimal machines without guard digits */
+/* (we know of none). We use a subroutine call to compute */
+/* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating */
+/* this code. */
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dlamda[i__] = slamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__];
+/* L10: */
+ }
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ slaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j],
+ info);
+
+/* If the zero finder fails, the computation is terminated. */
+
+ if (*info != 0) {
+ goto L120;
+ }
+/* L20: */
+ }
+
+ if (*k == 1) {
+ goto L110;
+ }
+ if (*k == 2) {
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ w[1] = q[j * q_dim1 + 1];
+ w[2] = q[j * q_dim1 + 2];
+ ii = indx[1];
+ q[j * q_dim1 + 1] = w[ii];
+ ii = indx[2];
+ q[j * q_dim1 + 2] = w[ii];
+/* L30: */
+ }
+ goto L110;
+ }
+
+/* Compute updated W. */
+
+ scopy_(k, &w[1], &c__1, &s[1], &c__1);
+
+/* Initialize W(I) = Q(I,I) */
+
+ i__1 = *ldq + 1;
+ scopy_(k, &q[q_offset], &i__1, &w[1], &c__1);
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
+/* L40: */
+ }
+ i__2 = *k;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
+/* L50: */
+ }
+/* L60: */
+ }
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__1 = sqrt(-w[i__]);
+ w[i__] = r_sign(&r__1, &s[i__]);
+/* L70: */
+ }
+
+/* Compute eigenvectors of the modified rank-1 modification. */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *k;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ s[i__] = w[i__] / q[i__ + j * q_dim1];
+/* L80: */
+ }
+ temp = snrm2_(k, &s[1], &c__1);
+ i__2 = *k;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ii = indx[i__];
+ q[i__ + j * q_dim1] = s[ii] / temp;
+/* L90: */
+ }
+/* L100: */
+ }
+
+/* Compute the updated eigenvectors. */
+
+L110:
+
+ n2 = *n - *n1;
+ n12 = ctot[1] + ctot[2];
+ n23 = ctot[2] + ctot[3];
+
+ slacpy_("A", &n23, k, &q[ctot[1] + 1 + q_dim1], ldq, &s[1], &n23);
+ iq2 = *n1 * n12 + 1;
+ if (n23 != 0) {
+ sgemm_("N", "N", &n2, k, &n23, &c_b22, &q2[iq2], &n2, &s[1], &n23, &
+ c_b23, &q[*n1 + 1 + q_dim1], ldq);
+ } else {
+ slaset_("A", &n2, k, &c_b23, &c_b23, &q[*n1 + 1 + q_dim1], ldq);
+ }
+
+ slacpy_("A", &n12, k, &q[q_offset], ldq, &s[1], &n12);
+ if (n12 != 0) {
+ sgemm_("N", "N", n1, k, &n12, &c_b22, &q2[1], n1, &s[1], &n12, &c_b23,
+ &q[q_offset], ldq);
+ } else {
+ slaset_("A", n1, k, &c_b23, &c_b23, &q[q_dim1 + 1], ldq);
+ }
+
+
+L120:
+ return 0;
+
+/* End of SLAED3 */
+
+} /* slaed3_ */
diff --git a/SRC/slaed4.c b/SRC/slaed4.c
new file mode 100644
index 0000000..f661f87
--- /dev/null
+++ b/SRC/slaed4.c
@@ -0,0 +1,952 @@
+/* slaed4.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slaed4_(integer *n, integer *i__, real *d__, real *z__,
+ real *delta, real *rho, real *dlam, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real a, b, c__;
+ integer j;
+ real w;
+ integer ii;
+ real dw, zz[3];
+ integer ip1;
+ real del, eta, phi, eps, tau, psi;
+ integer iim1, iip1;
+ real dphi, dpsi;
+ integer iter;
+ real temp, prew, temp1, dltlb, dltub, midpt;
+ integer niter;
+ logical swtch;
+ extern /* Subroutine */ int slaed5_(integer *, real *, real *, real *,
+ real *, real *), slaed6_(integer *, logical *, real *, real *,
+ real *, real *, real *, integer *);
+ logical swtch3;
+ extern doublereal slamch_(char *);
+ logical orgati;
+ real erretm, rhoinv;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This subroutine computes the I-th updated eigenvalue of a symmetric */
+/* rank-one modification to a diagonal matrix whose elements are */
+/* given in the array d, and that */
+
+/* D(i) < D(j) for i < j */
+
+/* and that RHO > 0. This is arranged by the calling routine, and is */
+/* no loss in generality. The rank-one modified system is thus */
+
+/* diag( D ) + RHO * Z * Z_transpose. */
+
+/* where we assume the Euclidean norm of Z is 1. */
+
+/* The method consists of approximating the rational functions in the */
+/* secular equation by simpler interpolating rational functions. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The length of all arrays. */
+
+/* I (input) INTEGER */
+/* The index of the eigenvalue to be computed. 1 <= I <= N. */
+
+/* D (input) REAL array, dimension (N) */
+/* The original eigenvalues. It is assumed that they are in */
+/* order, D(I) < D(J) for I < J. */
+
+/* Z (input) REAL array, dimension (N) */
+/* The components of the updating vector. */
+
+/* DELTA (output) REAL array, dimension (N) */
+/* If N .GT. 2, DELTA contains (D(j) - lambda_I) in its j-th */
+/* component. If N = 1, then DELTA(1) = 1. If N = 2, see SLAED5 */
+/* for detail. The vector DELTA contains the information necessary */
+/* to construct the eigenvectors by SLAED3 and SLAED9. */
+
+/* RHO (input) REAL */
+/* The scalar in the symmetric updating formula. */
+
+/* DLAM (output) REAL */
+/* The computed lambda_I, the I-th updated eigenvalue. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* > 0: if INFO = 1, the updating process failed. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* Logical variable ORGATI (origin-at-i?) is used for distinguishing */
+/* whether D(i) or D(i+1) is treated as the origin. */
+
+/* ORGATI = .true. origin at i */
+/* ORGATI = .false. origin at i+1 */
+
+/* Logical variable SWTCH3 (switch-for-3-poles?) is for noting */
+/* if we are working with THREE poles! */
+
+/* MAXIT is the maximum number of iterations allowed for each */
+/* eigenvalue. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ren-Cang Li, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Since this routine is called in an inner loop, we do no argument */
+/* checking. */
+
+/* Quick return for N=1 and 2. */
+
+ /* Parameter adjustments */
+ --delta;
+ --z__;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+ if (*n == 1) {
+
+/* Presumably, I=1 upon entry */
+
+ *dlam = d__[1] + *rho * z__[1] * z__[1];
+ delta[1] = 1.f;
+ return 0;
+ }
+ if (*n == 2) {
+ slaed5_(i__, &d__[1], &z__[1], &delta[1], rho, dlam);
+ return 0;
+ }
+
+/* Compute machine epsilon */
+
+ eps = slamch_("Epsilon");
+ rhoinv = 1.f / *rho;
+
+/* The case I = N */
+
+ if (*i__ == *n) {
+
+/* Initialize some basic variables */
+
+ ii = *n - 1;
+ niter = 1;
+
+/* Calculate initial guess */
+
+ midpt = *rho / 2.f;
+
+/* If ||Z||_2 is not one, then TEMP should be set to */
+/* RHO * ||Z||_2^2 / TWO */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] = d__[j] - d__[*i__] - midpt;
+/* L10: */
+ }
+
+ psi = 0.f;
+ i__1 = *n - 2;
+ for (j = 1; j <= i__1; ++j) {
+ psi += z__[j] * z__[j] / delta[j];
+/* L20: */
+ }
+
+ c__ = rhoinv + psi;
+ w = c__ + z__[ii] * z__[ii] / delta[ii] + z__[*n] * z__[*n] / delta[*
+ n];
+
+ if (w <= 0.f) {
+ temp = z__[*n - 1] * z__[*n - 1] / (d__[*n] - d__[*n - 1] + *rho)
+ + z__[*n] * z__[*n] / *rho;
+ if (c__ <= temp) {
+ tau = *rho;
+ } else {
+ del = d__[*n] - d__[*n - 1];
+ a = -c__ * del + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n]
+ ;
+ b = z__[*n] * z__[*n] * del;
+ if (a < 0.f) {
+ tau = b * 2.f / (sqrt(a * a + b * 4.f * c__) - a);
+ } else {
+ tau = (a + sqrt(a * a + b * 4.f * c__)) / (c__ * 2.f);
+ }
+ }
+
+/* It can be proved that */
+/* D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO */
+
+ dltlb = midpt;
+ dltub = *rho;
+ } else {
+ del = d__[*n] - d__[*n - 1];
+ a = -c__ * del + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n];
+ b = z__[*n] * z__[*n] * del;
+ if (a < 0.f) {
+ tau = b * 2.f / (sqrt(a * a + b * 4.f * c__) - a);
+ } else {
+ tau = (a + sqrt(a * a + b * 4.f * c__)) / (c__ * 2.f);
+ }
+
+/* It can be proved that */
+/* D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2 */
+
+ dltlb = 0.f;
+ dltub = midpt;
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] = d__[j] - d__[*i__] - tau;
+/* L30: */
+ }
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.f;
+ psi = 0.f;
+ erretm = 0.f;
+ i__1 = ii;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / delta[j];
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L40: */
+ }
+ erretm = dabs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ temp = z__[*n] / delta[*n];
+ phi = z__[*n] * temp;
+ dphi = temp * temp;
+ erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv + dabs(tau) * (
+ dpsi + dphi);
+
+ w = rhoinv + phi + psi;
+
+/* Test for convergence */
+
+ if (dabs(w) <= eps * erretm) {
+ *dlam = d__[*i__] + tau;
+ goto L250;
+ }
+
+ if (w <= 0.f) {
+ dltlb = dmax(dltlb,tau);
+ } else {
+ dltub = dmin(dltub,tau);
+ }
+
+/* Calculate the new step */
+
+ ++niter;
+ c__ = w - delta[*n - 1] * dpsi - delta[*n] * dphi;
+ a = (delta[*n - 1] + delta[*n]) * w - delta[*n - 1] * delta[*n] * (
+ dpsi + dphi);
+ b = delta[*n - 1] * delta[*n] * w;
+ if (c__ < 0.f) {
+ c__ = dabs(c__);
+ }
+ if (c__ == 0.f) {
+/* ETA = B/A */
+/* ETA = RHO - TAU */
+ eta = dltub - tau;
+ } else if (a >= 0.f) {
+ eta = (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) / (
+ c__ * 2.f);
+ } else {
+ eta = b * 2.f / (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(
+ r__1))));
+ }
+
+/* Note, eta should be positive if w is negative, and */
+/* eta should be negative otherwise. However, */
+/* if for some reason caused by roundoff, eta*w > 0, */
+/* we simply use one Newton step instead. This way */
+/* will guarantee eta*w < 0. */
+
+ if (w * eta > 0.f) {
+ eta = -w / (dpsi + dphi);
+ }
+ temp = tau + eta;
+ if (temp > dltub || temp < dltlb) {
+ if (w < 0.f) {
+ eta = (dltub - tau) / 2.f;
+ } else {
+ eta = (dltlb - tau) / 2.f;
+ }
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] -= eta;
+/* L50: */
+ }
+
+ tau += eta;
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.f;
+ psi = 0.f;
+ erretm = 0.f;
+ i__1 = ii;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / delta[j];
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L60: */
+ }
+ erretm = dabs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ temp = z__[*n] / delta[*n];
+ phi = z__[*n] * temp;
+ dphi = temp * temp;
+ erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv + dabs(tau) * (
+ dpsi + dphi);
+
+ w = rhoinv + phi + psi;
+
+/* Main loop to update the values of the array DELTA */
+
+ iter = niter + 1;
+
+ for (niter = iter; niter <= 30; ++niter) {
+
+/* Test for convergence */
+
+ if (dabs(w) <= eps * erretm) {
+ *dlam = d__[*i__] + tau;
+ goto L250;
+ }
+
+ if (w <= 0.f) {
+ dltlb = dmax(dltlb,tau);
+ } else {
+ dltub = dmin(dltub,tau);
+ }
+
+/* Calculate the new step */
+
+ c__ = w - delta[*n - 1] * dpsi - delta[*n] * dphi;
+ a = (delta[*n - 1] + delta[*n]) * w - delta[*n - 1] * delta[*n] *
+ (dpsi + dphi);
+ b = delta[*n - 1] * delta[*n] * w;
+ if (a >= 0.f) {
+ eta = (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) /
+ (c__ * 2.f);
+ } else {
+ eta = b * 2.f / (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(
+ r__1))));
+ }
+
+/* Note, eta should be positive if w is negative, and */
+/* eta should be negative otherwise. However, */
+/* if for some reason caused by roundoff, eta*w > 0, */
+/* we simply use one Newton step instead. This way */
+/* will guarantee eta*w < 0. */
+
+ if (w * eta > 0.f) {
+ eta = -w / (dpsi + dphi);
+ }
+ temp = tau + eta;
+ if (temp > dltub || temp < dltlb) {
+ if (w < 0.f) {
+ eta = (dltub - tau) / 2.f;
+ } else {
+ eta = (dltlb - tau) / 2.f;
+ }
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] -= eta;
+/* L70: */
+ }
+
+ tau += eta;
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.f;
+ psi = 0.f;
+ erretm = 0.f;
+ i__1 = ii;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / delta[j];
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L80: */
+ }
+ erretm = dabs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ temp = z__[*n] / delta[*n];
+ phi = z__[*n] * temp;
+ dphi = temp * temp;
+ erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv + dabs(tau) *
+ (dpsi + dphi);
+
+ w = rhoinv + phi + psi;
+/* L90: */
+ }
+
+/* Return with INFO = 1, NITER = MAXIT and not converged */
+
+ *info = 1;
+ *dlam = d__[*i__] + tau;
+ goto L250;
+
+/* End for the case I = N */
+
+ } else {
+
+/* The case for I < N */
+
+ niter = 1;
+ ip1 = *i__ + 1;
+
+/* Calculate initial guess */
+
+ del = d__[ip1] - d__[*i__];
+ midpt = del / 2.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] = d__[j] - d__[*i__] - midpt;
+/* L100: */
+ }
+
+ psi = 0.f;
+ i__1 = *i__ - 1;
+ for (j = 1; j <= i__1; ++j) {
+ psi += z__[j] * z__[j] / delta[j];
+/* L110: */
+ }
+
+ phi = 0.f;
+ i__1 = *i__ + 2;
+ for (j = *n; j >= i__1; --j) {
+ phi += z__[j] * z__[j] / delta[j];
+/* L120: */
+ }
+ c__ = rhoinv + psi + phi;
+ w = c__ + z__[*i__] * z__[*i__] / delta[*i__] + z__[ip1] * z__[ip1] /
+ delta[ip1];
+
+ if (w > 0.f) {
+
+/* d(i)< the ith eigenvalue < (d(i)+d(i+1))/2 */
+
+/* We choose d(i) as origin. */
+
+ orgati = TRUE_;
+ a = c__ * del + z__[*i__] * z__[*i__] + z__[ip1] * z__[ip1];
+ b = z__[*i__] * z__[*i__] * del;
+ if (a > 0.f) {
+ tau = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(
+ r__1))));
+ } else {
+ tau = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) /
+ (c__ * 2.f);
+ }
+ dltlb = 0.f;
+ dltub = midpt;
+ } else {
+
+/* (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1) */
+
+/* We choose d(i+1) as origin. */
+
+ orgati = FALSE_;
+ a = c__ * del - z__[*i__] * z__[*i__] - z__[ip1] * z__[ip1];
+ b = z__[ip1] * z__[ip1] * del;
+ if (a < 0.f) {
+ tau = b * 2.f / (a - sqrt((r__1 = a * a + b * 4.f * c__, dabs(
+ r__1))));
+ } else {
+ tau = -(a + sqrt((r__1 = a * a + b * 4.f * c__, dabs(r__1))))
+ / (c__ * 2.f);
+ }
+ dltlb = -midpt;
+ dltub = 0.f;
+ }
+
+ if (orgati) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] = d__[j] - d__[*i__] - tau;
+/* L130: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] = d__[j] - d__[ip1] - tau;
+/* L140: */
+ }
+ }
+ if (orgati) {
+ ii = *i__;
+ } else {
+ ii = *i__ + 1;
+ }
+ iim1 = ii - 1;
+ iip1 = ii + 1;
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.f;
+ psi = 0.f;
+ erretm = 0.f;
+ i__1 = iim1;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / delta[j];
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L150: */
+ }
+ erretm = dabs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ dphi = 0.f;
+ phi = 0.f;
+ i__1 = iip1;
+ for (j = *n; j >= i__1; --j) {
+ temp = z__[j] / delta[j];
+ phi += z__[j] * temp;
+ dphi += temp * temp;
+ erretm += phi;
+/* L160: */
+ }
+
+ w = rhoinv + phi + psi;
+
+/* W is the value of the secular function with */
+/* its ii-th element removed. */
+
+ swtch3 = FALSE_;
+ if (orgati) {
+ if (w < 0.f) {
+ swtch3 = TRUE_;
+ }
+ } else {
+ if (w > 0.f) {
+ swtch3 = TRUE_;
+ }
+ }
+ if (ii == 1 || ii == *n) {
+ swtch3 = FALSE_;
+ }
+
+ temp = z__[ii] / delta[ii];
+ dw = dpsi + dphi + temp * temp;
+ temp = z__[ii] * temp;
+ w += temp;
+ erretm = (phi - psi) * 8.f + erretm + rhoinv * 2.f + dabs(temp) * 3.f
+ + dabs(tau) * dw;
+
+/* Test for convergence */
+
+ if (dabs(w) <= eps * erretm) {
+ if (orgati) {
+ *dlam = d__[*i__] + tau;
+ } else {
+ *dlam = d__[ip1] + tau;
+ }
+ goto L250;
+ }
+
+ if (w <= 0.f) {
+ dltlb = dmax(dltlb,tau);
+ } else {
+ dltub = dmin(dltub,tau);
+ }
+
+/* Calculate the new step */
+
+ ++niter;
+ if (! swtch3) {
+ if (orgati) {
+/* Computing 2nd power */
+ r__1 = z__[*i__] / delta[*i__];
+ c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * (r__1 *
+ r__1);
+ } else {
+/* Computing 2nd power */
+ r__1 = z__[ip1] / delta[ip1];
+ c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) * (r__1 *
+ r__1);
+ }
+ a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1] *
+ dw;
+ b = delta[*i__] * delta[ip1] * w;
+ if (c__ == 0.f) {
+ if (a == 0.f) {
+ if (orgati) {
+ a = z__[*i__] * z__[*i__] + delta[ip1] * delta[ip1] *
+ (dpsi + dphi);
+ } else {
+ a = z__[ip1] * z__[ip1] + delta[*i__] * delta[*i__] *
+ (dpsi + dphi);
+ }
+ }
+ eta = b / a;
+ } else if (a <= 0.f) {
+ eta = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) /
+ (c__ * 2.f);
+ } else {
+ eta = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(
+ r__1))));
+ }
+ } else {
+
+/* Interpolation using THREE most relevant poles */
+
+ temp = rhoinv + psi + phi;
+ if (orgati) {
+ temp1 = z__[iim1] / delta[iim1];
+ temp1 *= temp1;
+ c__ = temp - delta[iip1] * (dpsi + dphi) - (d__[iim1] - d__[
+ iip1]) * temp1;
+ zz[0] = z__[iim1] * z__[iim1];
+ zz[2] = delta[iip1] * delta[iip1] * (dpsi - temp1 + dphi);
+ } else {
+ temp1 = z__[iip1] / delta[iip1];
+ temp1 *= temp1;
+ c__ = temp - delta[iim1] * (dpsi + dphi) - (d__[iip1] - d__[
+ iim1]) * temp1;
+ zz[0] = delta[iim1] * delta[iim1] * (dpsi + (dphi - temp1));
+ zz[2] = z__[iip1] * z__[iip1];
+ }
+ zz[1] = z__[ii] * z__[ii];
+ slaed6_(&niter, &orgati, &c__, &delta[iim1], zz, &w, &eta, info);
+ if (*info != 0) {
+ goto L250;
+ }
+ }
+
+/* Note, eta should be positive if w is negative, and */
+/* eta should be negative otherwise. However, */
+/* if for some reason caused by roundoff, eta*w > 0, */
+/* we simply use one Newton step instead. This way */
+/* will guarantee eta*w < 0. */
+
+ if (w * eta >= 0.f) {
+ eta = -w / dw;
+ }
+ temp = tau + eta;
+ if (temp > dltub || temp < dltlb) {
+ if (w < 0.f) {
+ eta = (dltub - tau) / 2.f;
+ } else {
+ eta = (dltlb - tau) / 2.f;
+ }
+ }
+
+ prew = w;
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] -= eta;
+/* L180: */
+ }
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.f;
+ psi = 0.f;
+ erretm = 0.f;
+ i__1 = iim1;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / delta[j];
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L190: */
+ }
+ erretm = dabs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ dphi = 0.f;
+ phi = 0.f;
+ i__1 = iip1;
+ for (j = *n; j >= i__1; --j) {
+ temp = z__[j] / delta[j];
+ phi += z__[j] * temp;
+ dphi += temp * temp;
+ erretm += phi;
+/* L200: */
+ }
+
+ temp = z__[ii] / delta[ii];
+ dw = dpsi + dphi + temp * temp;
+ temp = z__[ii] * temp;
+ w = rhoinv + phi + psi + temp;
+ erretm = (phi - psi) * 8.f + erretm + rhoinv * 2.f + dabs(temp) * 3.f
+ + (r__1 = tau + eta, dabs(r__1)) * dw;
+
+ swtch = FALSE_;
+ if (orgati) {
+ if (-w > dabs(prew) / 10.f) {
+ swtch = TRUE_;
+ }
+ } else {
+ if (w > dabs(prew) / 10.f) {
+ swtch = TRUE_;
+ }
+ }
+
+ tau += eta;
+
+/* Main loop to update the values of the array DELTA */
+
+ iter = niter + 1;
+
+ for (niter = iter; niter <= 30; ++niter) {
+
+/* Test for convergence */
+
+ if (dabs(w) <= eps * erretm) {
+ if (orgati) {
+ *dlam = d__[*i__] + tau;
+ } else {
+ *dlam = d__[ip1] + tau;
+ }
+ goto L250;
+ }
+
+ if (w <= 0.f) {
+ dltlb = dmax(dltlb,tau);
+ } else {
+ dltub = dmin(dltub,tau);
+ }
+
+/* Calculate the new step */
+
+ if (! swtch3) {
+ if (! swtch) {
+ if (orgati) {
+/* Computing 2nd power */
+ r__1 = z__[*i__] / delta[*i__];
+ c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * (
+ r__1 * r__1);
+ } else {
+/* Computing 2nd power */
+ r__1 = z__[ip1] / delta[ip1];
+ c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) *
+ (r__1 * r__1);
+ }
+ } else {
+ temp = z__[ii] / delta[ii];
+ if (orgati) {
+ dpsi += temp * temp;
+ } else {
+ dphi += temp * temp;
+ }
+ c__ = w - delta[*i__] * dpsi - delta[ip1] * dphi;
+ }
+ a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1]
+ * dw;
+ b = delta[*i__] * delta[ip1] * w;
+ if (c__ == 0.f) {
+ if (a == 0.f) {
+ if (! swtch) {
+ if (orgati) {
+ a = z__[*i__] * z__[*i__] + delta[ip1] *
+ delta[ip1] * (dpsi + dphi);
+ } else {
+ a = z__[ip1] * z__[ip1] + delta[*i__] * delta[
+ *i__] * (dpsi + dphi);
+ }
+ } else {
+ a = delta[*i__] * delta[*i__] * dpsi + delta[ip1]
+ * delta[ip1] * dphi;
+ }
+ }
+ eta = b / a;
+ } else if (a <= 0.f) {
+ eta = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1))
+ )) / (c__ * 2.f);
+ } else {
+ eta = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__,
+ dabs(r__1))));
+ }
+ } else {
+
+/* Interpolation using THREE most relevant poles */
+
+ temp = rhoinv + psi + phi;
+ if (swtch) {
+ c__ = temp - delta[iim1] * dpsi - delta[iip1] * dphi;
+ zz[0] = delta[iim1] * delta[iim1] * dpsi;
+ zz[2] = delta[iip1] * delta[iip1] * dphi;
+ } else {
+ if (orgati) {
+ temp1 = z__[iim1] / delta[iim1];
+ temp1 *= temp1;
+ c__ = temp - delta[iip1] * (dpsi + dphi) - (d__[iim1]
+ - d__[iip1]) * temp1;
+ zz[0] = z__[iim1] * z__[iim1];
+ zz[2] = delta[iip1] * delta[iip1] * (dpsi - temp1 +
+ dphi);
+ } else {
+ temp1 = z__[iip1] / delta[iip1];
+ temp1 *= temp1;
+ c__ = temp - delta[iim1] * (dpsi + dphi) - (d__[iip1]
+ - d__[iim1]) * temp1;
+ zz[0] = delta[iim1] * delta[iim1] * (dpsi + (dphi -
+ temp1));
+ zz[2] = z__[iip1] * z__[iip1];
+ }
+ }
+ slaed6_(&niter, &orgati, &c__, &delta[iim1], zz, &w, &eta,
+ info);
+ if (*info != 0) {
+ goto L250;
+ }
+ }
+
+/* Note, eta should be positive if w is negative, and */
+/* eta should be negative otherwise. However, */
+/* if for some reason caused by roundoff, eta*w > 0, */
+/* we simply use one Newton step instead. This way */
+/* will guarantee eta*w < 0. */
+
+ if (w * eta >= 0.f) {
+ eta = -w / dw;
+ }
+ temp = tau + eta;
+ if (temp > dltub || temp < dltlb) {
+ if (w < 0.f) {
+ eta = (dltub - tau) / 2.f;
+ } else {
+ eta = (dltlb - tau) / 2.f;
+ }
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] -= eta;
+/* L210: */
+ }
+
+ tau += eta;
+ prew = w;
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.f;
+ psi = 0.f;
+ erretm = 0.f;
+ i__1 = iim1;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / delta[j];
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L220: */
+ }
+ erretm = dabs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ dphi = 0.f;
+ phi = 0.f;
+ i__1 = iip1;
+ for (j = *n; j >= i__1; --j) {
+ temp = z__[j] / delta[j];
+ phi += z__[j] * temp;
+ dphi += temp * temp;
+ erretm += phi;
+/* L230: */
+ }
+
+ temp = z__[ii] / delta[ii];
+ dw = dpsi + dphi + temp * temp;
+ temp = z__[ii] * temp;
+ w = rhoinv + phi + psi + temp;
+ erretm = (phi - psi) * 8.f + erretm + rhoinv * 2.f + dabs(temp) *
+ 3.f + dabs(tau) * dw;
+ if (w * prew > 0.f && dabs(w) > dabs(prew) / 10.f) {
+ swtch = ! swtch;
+ }
+
+/* L240: */
+ }
+
+/* Return with INFO = 1, NITER = MAXIT and not converged */
+
+ *info = 1;
+ if (orgati) {
+ *dlam = d__[*i__] + tau;
+ } else {
+ *dlam = d__[ip1] + tau;
+ }
+
+ }
+
+L250:
+
+ return 0;
+
+/* End of SLAED4 */
+
+} /* slaed4_ */
diff --git a/SRC/slaed5.c b/SRC/slaed5.c
new file mode 100644
index 0000000..756fdd8
--- /dev/null
+++ b/SRC/slaed5.c
@@ -0,0 +1,149 @@
+/* slaed5.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slaed5_(integer *i__, real *d__, real *z__, real *delta,
+ real *rho, real *dlam)
+{
+ /* System generated locals */
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real b, c__, w, del, tau, temp;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This subroutine computes the I-th eigenvalue of a symmetric rank-one */
+/* modification of a 2-by-2 diagonal matrix */
+
+/* diag( D ) + RHO * Z * transpose(Z) . */
+
+/* The diagonal elements in the array D are assumed to satisfy */
+
+/* D(i) < D(j) for i < j . */
+
+/* We also assume RHO > 0 and that the Euclidean norm of the vector */
+/* Z is one. */
+
+/* Arguments */
+/* ========= */
+
+/* I (input) INTEGER */
+/* The index of the eigenvalue to be computed. I = 1 or I = 2. */
+
+/* D (input) REAL array, dimension (2) */
+/* The original eigenvalues. We assume D(1) < D(2). */
+
+/* Z (input) REAL array, dimension (2) */
+/* The components of the updating vector. */
+
+/* DELTA (output) REAL array, dimension (2) */
+/* The vector DELTA contains the information necessary */
+/* to construct the eigenvectors. */
+
+/* RHO (input) REAL */
+/* The scalar in the symmetric updating formula. */
+
+/* DLAM (output) REAL */
+/* The computed lambda_I, the I-th updated eigenvalue. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ren-Cang Li, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --delta;
+ --z__;
+ --d__;
+
+ /* Function Body */
+ del = d__[2] - d__[1];
+ if (*i__ == 1) {
+ w = *rho * 2.f * (z__[2] * z__[2] - z__[1] * z__[1]) / del + 1.f;
+ if (w > 0.f) {
+ b = del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
+ c__ = *rho * z__[1] * z__[1] * del;
+
+/* B > ZERO, always */
+
+ tau = c__ * 2.f / (b + sqrt((r__1 = b * b - c__ * 4.f, dabs(r__1))
+ ));
+ *dlam = d__[1] + tau;
+ delta[1] = -z__[1] / tau;
+ delta[2] = z__[2] / (del - tau);
+ } else {
+ b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
+ c__ = *rho * z__[2] * z__[2] * del;
+ if (b > 0.f) {
+ tau = c__ * -2.f / (b + sqrt(b * b + c__ * 4.f));
+ } else {
+ tau = (b - sqrt(b * b + c__ * 4.f)) / 2.f;
+ }
+ *dlam = d__[2] + tau;
+ delta[1] = -z__[1] / (del + tau);
+ delta[2] = -z__[2] / tau;
+ }
+ temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]);
+ delta[1] /= temp;
+ delta[2] /= temp;
+ } else {
+
+/* Now I=2 */
+
+ b = -del + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
+ c__ = *rho * z__[2] * z__[2] * del;
+ if (b > 0.f) {
+ tau = (b + sqrt(b * b + c__ * 4.f)) / 2.f;
+ } else {
+ tau = c__ * 2.f / (-b + sqrt(b * b + c__ * 4.f));
+ }
+ *dlam = d__[2] + tau;
+ delta[1] = -z__[1] / (del + tau);
+ delta[2] = -z__[2] / tau;
+ temp = sqrt(delta[1] * delta[1] + delta[2] * delta[2]);
+ delta[1] /= temp;
+ delta[2] /= temp;
+ }
+ return 0;
+
+/* End OF SLAED5 */
+
+} /* slaed5_ */
diff --git a/SRC/slaed6.c b/SRC/slaed6.c
new file mode 100644
index 0000000..07e353e
--- /dev/null
+++ b/SRC/slaed6.c
@@ -0,0 +1,375 @@
+/* slaed6.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slaed6_(integer *kniter, logical *orgati, real *rho,
+ real *d__, real *z__, real *finit, real *tau, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal), log(doublereal), pow_ri(real *, integer *);
+
+ /* Local variables */
+ real a, b, c__, f;
+ integer i__;
+ real fc, df, ddf, lbd, eta, ubd, eps, base;
+ integer iter;
+ real temp, temp1, temp2, temp3, temp4;
+ logical scale;
+ integer niter;
+ real small1, small2, sminv1, sminv2, dscale[3], sclfac;
+ extern doublereal slamch_(char *);
+ real zscale[3], erretm, sclinv;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAED6 computes the positive or negative root (closest to the origin) */
+/* of */
+/* z(1) z(2) z(3) */
+/* f(x) = rho + --------- + ---------- + --------- */
+/* d(1)-x d(2)-x d(3)-x */
+
+/* It is assumed that */
+
+/* if ORGATI = .true. the root is between d(2) and d(3); */
+/* otherwise it is between d(1) and d(2) */
+
+/* This routine will be called by SLAED4 when necessary. In most cases, */
+/* the root sought is the smallest in magnitude, though it might not be */
+/* in some extremely rare situations. */
+
+/* Arguments */
+/* ========= */
+
+/* KNITER (input) INTEGER */
+/* Refer to SLAED4 for its significance. */
+
+/* ORGATI (input) LOGICAL */
+/* If ORGATI is true, the needed root is between d(2) and */
+/* d(3); otherwise it is between d(1) and d(2). See */
+/* SLAED4 for further details. */
+
+/* RHO (input) REAL */
+/* Refer to the equation f(x) above. */
+
+/* D (input) REAL array, dimension (3) */
+/* D satisfies d(1) < d(2) < d(3). */
+
+/* Z (input) REAL array, dimension (3) */
+/* Each of the elements in z must be positive. */
+
+/* FINIT (input) REAL */
+/* The value of f at 0. It is more accurate than the one */
+/* evaluated inside this routine (if someone wants to do */
+/* so). */
+
+/* TAU (output) REAL */
+/* The root of the equation f(x). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* > 0: if INFO = 1, failure to converge */
+
+/* Further Details */
+/* =============== */
+
+/* 30/06/99: Based on contributions by */
+/* Ren-Cang Li, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* 10/02/03: This version has a few statements commented out for thread safety */
+/* (machine parameters are computed on each entry). SJH. */
+
+/* 05/10/06: Modified from a new version of Ren-Cang Li, use */
+/* Gragg-Thornton-Warner cubic convergent scheme for better stability. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --z__;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*orgati) {
+ lbd = d__[2];
+ ubd = d__[3];
+ } else {
+ lbd = d__[1];
+ ubd = d__[2];
+ }
+ if (*finit < 0.f) {
+ lbd = 0.f;
+ } else {
+ ubd = 0.f;
+ }
+
+ niter = 1;
+ *tau = 0.f;
+ if (*kniter == 2) {
+ if (*orgati) {
+ temp = (d__[3] - d__[2]) / 2.f;
+ c__ = *rho + z__[1] / (d__[1] - d__[2] - temp);
+ a = c__ * (d__[2] + d__[3]) + z__[2] + z__[3];
+ b = c__ * d__[2] * d__[3] + z__[2] * d__[3] + z__[3] * d__[2];
+ } else {
+ temp = (d__[1] - d__[2]) / 2.f;
+ c__ = *rho + z__[3] / (d__[3] - d__[2] - temp);
+ a = c__ * (d__[1] + d__[2]) + z__[1] + z__[2];
+ b = c__ * d__[1] * d__[2] + z__[1] * d__[2] + z__[2] * d__[1];
+ }
+/* Computing MAX */
+ r__1 = dabs(a), r__2 = dabs(b), r__1 = max(r__1,r__2), r__2 = dabs(
+ c__);
+ temp = dmax(r__1,r__2);
+ a /= temp;
+ b /= temp;
+ c__ /= temp;
+ if (c__ == 0.f) {
+ *tau = b / a;
+ } else if (a <= 0.f) {
+ *tau = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) / (
+ c__ * 2.f);
+ } else {
+ *tau = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(
+ r__1))));
+ }
+ if (*tau < lbd || *tau > ubd) {
+ *tau = (lbd + ubd) / 2.f;
+ }
+ if (d__[1] == *tau || d__[2] == *tau || d__[3] == *tau) {
+ *tau = 0.f;
+ } else {
+ temp = *finit + *tau * z__[1] / (d__[1] * (d__[1] - *tau)) + *tau
+ * z__[2] / (d__[2] * (d__[2] - *tau)) + *tau * z__[3] / (
+ d__[3] * (d__[3] - *tau));
+ if (temp <= 0.f) {
+ lbd = *tau;
+ } else {
+ ubd = *tau;
+ }
+ if (dabs(*finit) <= dabs(temp)) {
+ *tau = 0.f;
+ }
+ }
+ }
+
+/* get machine parameters for possible scaling to avoid overflow */
+
+/* modified by Sven: parameters SMALL1, SMINV1, SMALL2, */
+/* SMINV2, EPS are not SAVEd anymore between one call to the */
+/* others but recomputed at each call */
+
+ eps = slamch_("Epsilon");
+ base = slamch_("Base");
+ i__1 = (integer) (log(slamch_("SafMin")) / log(base) / 3.f);
+ small1 = pow_ri(&base, &i__1);
+ sminv1 = 1.f / small1;
+ small2 = small1 * small1;
+ sminv2 = sminv1 * sminv1;
+
+/* Determine if scaling of inputs necessary to avoid overflow */
+/* when computing 1/TEMP**3 */
+
+ if (*orgati) {
+/* Computing MIN */
+ r__3 = (r__1 = d__[2] - *tau, dabs(r__1)), r__4 = (r__2 = d__[3] - *
+ tau, dabs(r__2));
+ temp = dmin(r__3,r__4);
+ } else {
+/* Computing MIN */
+ r__3 = (r__1 = d__[1] - *tau, dabs(r__1)), r__4 = (r__2 = d__[2] - *
+ tau, dabs(r__2));
+ temp = dmin(r__3,r__4);
+ }
+ scale = FALSE_;
+ if (temp <= small1) {
+ scale = TRUE_;
+ if (temp <= small2) {
+
+/* Scale up by power of radix nearest 1/SAFMIN**(2/3) */
+
+ sclfac = sminv2;
+ sclinv = small2;
+ } else {
+
+/* Scale up by power of radix nearest 1/SAFMIN**(1/3) */
+
+ sclfac = sminv1;
+ sclinv = small1;
+ }
+
+/* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1) */
+
+ for (i__ = 1; i__ <= 3; ++i__) {
+ dscale[i__ - 1] = d__[i__] * sclfac;
+ zscale[i__ - 1] = z__[i__] * sclfac;
+/* L10: */
+ }
+ *tau *= sclfac;
+ lbd *= sclfac;
+ ubd *= sclfac;
+ } else {
+
+/* Copy D and Z to DSCALE and ZSCALE */
+
+ for (i__ = 1; i__ <= 3; ++i__) {
+ dscale[i__ - 1] = d__[i__];
+ zscale[i__ - 1] = z__[i__];
+/* L20: */
+ }
+ }
+
+ fc = 0.f;
+ df = 0.f;
+ ddf = 0.f;
+ for (i__ = 1; i__ <= 3; ++i__) {
+ temp = 1.f / (dscale[i__ - 1] - *tau);
+ temp1 = zscale[i__ - 1] * temp;
+ temp2 = temp1 * temp;
+ temp3 = temp2 * temp;
+ fc += temp1 / dscale[i__ - 1];
+ df += temp2;
+ ddf += temp3;
+/* L30: */
+ }
+ f = *finit + *tau * fc;
+
+ if (dabs(f) <= 0.f) {
+ goto L60;
+ }
+ if (f <= 0.f) {
+ lbd = *tau;
+ } else {
+ ubd = *tau;
+ }
+
+/* Iteration begins -- Use Gragg-Thornton-Warner cubic convergent */
+/* scheme */
+
+/* It is not hard to see that */
+
+/* 1) Iterations will go up monotonically */
+/* if FINIT < 0; */
+
+/* 2) Iterations will go down monotonically */
+/* if FINIT > 0. */
+
+ iter = niter + 1;
+
+ for (niter = iter; niter <= 40; ++niter) {
+
+ if (*orgati) {
+ temp1 = dscale[1] - *tau;
+ temp2 = dscale[2] - *tau;
+ } else {
+ temp1 = dscale[0] - *tau;
+ temp2 = dscale[1] - *tau;
+ }
+ a = (temp1 + temp2) * f - temp1 * temp2 * df;
+ b = temp1 * temp2 * f;
+ c__ = f - (temp1 + temp2) * df + temp1 * temp2 * ddf;
+/* Computing MAX */
+ r__1 = dabs(a), r__2 = dabs(b), r__1 = max(r__1,r__2), r__2 = dabs(
+ c__);
+ temp = dmax(r__1,r__2);
+ a /= temp;
+ b /= temp;
+ c__ /= temp;
+ if (c__ == 0.f) {
+ eta = b / a;
+ } else if (a <= 0.f) {
+ eta = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) / (
+ c__ * 2.f);
+ } else {
+ eta = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(
+ r__1))));
+ }
+ if (f * eta >= 0.f) {
+ eta = -f / df;
+ }
+
+ *tau += eta;
+ if (*tau < lbd || *tau > ubd) {
+ *tau = (lbd + ubd) / 2.f;
+ }
+
+ fc = 0.f;
+ erretm = 0.f;
+ df = 0.f;
+ ddf = 0.f;
+ for (i__ = 1; i__ <= 3; ++i__) {
+ temp = 1.f / (dscale[i__ - 1] - *tau);
+ temp1 = zscale[i__ - 1] * temp;
+ temp2 = temp1 * temp;
+ temp3 = temp2 * temp;
+ temp4 = temp1 / dscale[i__ - 1];
+ fc += temp4;
+ erretm += dabs(temp4);
+ df += temp2;
+ ddf += temp3;
+/* L40: */
+ }
+ f = *finit + *tau * fc;
+ erretm = (dabs(*finit) + dabs(*tau) * erretm) * 8.f + dabs(*tau) * df;
+ if (dabs(f) <= eps * erretm) {
+ goto L60;
+ }
+ if (f <= 0.f) {
+ lbd = *tau;
+ } else {
+ ubd = *tau;
+ }
+/* L50: */
+ }
+ *info = 1;
+L60:
+
+/* Undo scaling */
+
+ if (scale) {
+ *tau *= sclinv;
+ }
+ return 0;
+
+/* End of SLAED6 */
+
+} /* slaed6_ */
diff --git a/SRC/slaed7.c b/SRC/slaed7.c
new file mode 100644
index 0000000..d263193
--- /dev/null
+++ b/SRC/slaed7.c
@@ -0,0 +1,352 @@
+/* slaed7.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static real c_b10 = 1.f;
+static real c_b11 = 0.f;
+static integer c_n1 = -1;
+
+/* Subroutine */ int slaed7_(integer *icompq, integer *n, integer *qsiz,
+ integer *tlvls, integer *curlvl, integer *curpbm, real *d__, real *q,
+ integer *ldq, integer *indxq, real *rho, integer *cutpnt, real *
+ qstore, integer *qptr, integer *prmptr, integer *perm, integer *
+ givptr, integer *givcol, real *givnum, real *work, integer *iwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, i__1, i__2;
+
+ /* Builtin functions */
+ integer pow_ii(integer *, integer *);
+
+ /* Local variables */
+ integer i__, k, n1, n2, is, iw, iz, iq2, ptr, ldq2, indx, curr, indxc;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ integer indxp;
+ extern /* Subroutine */ int slaed8_(integer *, integer *, integer *,
+ integer *, real *, real *, integer *, integer *, real *, integer *
+, real *, real *, real *, integer *, real *, integer *, integer *,
+ integer *, real *, integer *, integer *, integer *), slaed9_(
+ integer *, integer *, integer *, integer *, real *, real *,
+ integer *, real *, real *, real *, real *, integer *, integer *),
+ slaeda_(integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, real *, real *, integer *, real *
+, real *, integer *);
+ integer idlmda;
+ extern /* Subroutine */ int xerbla_(char *, integer *), slamrg_(
+ integer *, integer *, real *, integer *, integer *, integer *);
+ integer coltyp;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAED7 computes the updated eigensystem of a diagonal */
+/* matrix after modification by a rank-one symmetric matrix. This */
+/* routine is used only for the eigenproblem which requires all */
+/* eigenvalues and optionally eigenvectors of a dense symmetric matrix */
+/* that has been reduced to tridiagonal form. SLAED1 handles */
+/* the case in which all eigenvalues and eigenvectors of a symmetric */
+/* tridiagonal matrix are desired. */
+
+/* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out) */
+
+/* where Z = Q'u, u is a vector of length N with ones in the */
+/* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. */
+
+/* The eigenvectors of the original matrix are stored in Q, and the */
+/* eigenvalues are in D. The algorithm consists of three stages: */
+
+/* The first stage consists of deflating the size of the problem */
+/* when there are multiple eigenvalues or if there is a zero in */
+/* the Z vector. For each such occurence the dimension of the */
+/* secular equation problem is reduced by one. This stage is */
+/* performed by the routine SLAED8. */
+
+/* The second stage consists of calculating the updated */
+/* eigenvalues. This is done by finding the roots of the secular */
+/* equation via the routine SLAED4 (as called by SLAED9). */
+/* This routine also calculates the eigenvectors of the current */
+/* problem. */
+
+/* The final stage consists of computing the updated eigenvectors */
+/* directly using the updated eigenvalues. The eigenvectors for */
+/* the current problem are multiplied with the eigenvectors from */
+/* the overall problem. */
+
+/* Arguments */
+/* ========= */
+
+/* ICOMPQ (input) INTEGER */
+/* = 0: Compute eigenvalues only. */
+/* = 1: Compute eigenvectors of original dense symmetric matrix */
+/* also. On entry, Q contains the orthogonal matrix used */
+/* to reduce the original matrix to tridiagonal form. */
+
+/* N (input) INTEGER */
+/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
+
+/* QSIZ (input) INTEGER */
+/* The dimension of the orthogonal matrix used to reduce */
+/* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. */
+
+/* TLVLS (input) INTEGER */
+/* The total number of merging levels in the overall divide and */
+/* conquer tree. */
+
+/* CURLVL (input) INTEGER */
+/* The current level in the overall merge routine, */
+/* 0 <= CURLVL <= TLVLS. */
+
+/* CURPBM (input) INTEGER */
+/* The current problem in the current level in the overall */
+/* merge routine (counting from upper left to lower right). */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the eigenvalues of the rank-1-perturbed matrix. */
+/* On exit, the eigenvalues of the repaired matrix. */
+
+/* Q (input/output) REAL array, dimension (LDQ, N) */
+/* On entry, the eigenvectors of the rank-1-perturbed matrix. */
+/* On exit, the eigenvectors of the repaired tridiagonal matrix. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* INDXQ (output) INTEGER array, dimension (N) */
+/* The permutation which will reintegrate the subproblem just */
+/* solved back into sorted order, i.e., D( INDXQ( I = 1, N ) ) */
+/* will be in ascending order. */
+
+/* RHO (input) REAL */
+/* The subdiagonal element used to create the rank-1 */
+/* modification. */
+
+/* CUTPNT (input) INTEGER */
+/* Contains the location of the last eigenvalue in the leading */
+/* sub-matrix. min(1,N) <= CUTPNT <= N. */
+
+/* QSTORE (input/output) REAL array, dimension (N**2+1) */
+/* Stores eigenvectors of submatrices encountered during */
+/* divide and conquer, packed together. QPTR points to */
+/* beginning of the submatrices. */
+
+/* QPTR (input/output) INTEGER array, dimension (N+2) */
+/* List of indices pointing to beginning of submatrices stored */
+/* in QSTORE. The submatrices are numbered starting at the */
+/* bottom left of the divide and conquer tree, from left to */
+/* right and bottom to top. */
+
+/* PRMPTR (input) INTEGER array, dimension (N lg N) */
+/* Contains a list of pointers which indicate where in PERM a */
+/* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) */
+/* indicates the size of the permutation and also the size of */
+/* the full, non-deflated problem. */
+
+/* PERM (input) INTEGER array, dimension (N lg N) */
+/* Contains the permutations (from deflation and sorting) to be */
+/* applied to each eigenblock. */
+
+/* GIVPTR (input) INTEGER array, dimension (N lg N) */
+/* Contains a list of pointers which indicate where in GIVCOL a */
+/* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) */
+/* indicates the number of Givens rotations. */
+
+/* GIVCOL (input) INTEGER array, dimension (2, N lg N) */
+/* Each pair of numbers indicates a pair of columns to take place */
+/* in a Givens rotation. */
+
+/* GIVNUM (input) REAL array, dimension (2, N lg N) */
+/* Each number indicates the S value to be used in the */
+/* corresponding Givens rotation. */
+
+/* WORK (workspace) REAL array, dimension (3*N+QSIZ*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (4*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, an eigenvalue did not converge */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --indxq;
+ --qstore;
+ --qptr;
+ --prmptr;
+ --perm;
+ --givptr;
+ givcol -= 3;
+ givnum -= 3;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*icompq < 0 || *icompq > 1) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*icompq == 1 && *qsiz < *n) {
+ *info = -4;
+ } else if (*ldq < max(1,*n)) {
+ *info = -9;
+ } else if (min(1,*n) > *cutpnt || *n < *cutpnt) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLAED7", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* The following values are for bookkeeping purposes only. They are */
+/* integer pointers which indicate the portion of the workspace */
+/* used by a particular array in SLAED8 and SLAED9. */
+
+ if (*icompq == 1) {
+ ldq2 = *qsiz;
+ } else {
+ ldq2 = *n;
+ }
+
+ iz = 1;
+ idlmda = iz + *n;
+ iw = idlmda + *n;
+ iq2 = iw + *n;
+ is = iq2 + *n * ldq2;
+
+ indx = 1;
+ indxc = indx + *n;
+ coltyp = indxc + *n;
+ indxp = coltyp + *n;
+
+/* Form the z-vector which consists of the last row of Q_1 and the */
+/* first row of Q_2. */
+
+ ptr = pow_ii(&c__2, tlvls) + 1;
+ i__1 = *curlvl - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *tlvls - i__;
+ ptr += pow_ii(&c__2, &i__2);
+/* L10: */
+ }
+ curr = ptr + *curpbm;
+ slaeda_(n, tlvls, curlvl, curpbm, &prmptr[1], &perm[1], &givptr[1], &
+ givcol[3], &givnum[3], &qstore[1], &qptr[1], &work[iz], &work[iz
+ + *n], info);
+
+/* When solving the final problem, we no longer need the stored data, */
+/* so we will overwrite the data from this level onto the previously */
+/* used storage space. */
+
+ if (*curlvl == *tlvls) {
+ qptr[curr] = 1;
+ prmptr[curr] = 1;
+ givptr[curr] = 1;
+ }
+
+/* Sort and Deflate eigenvalues. */
+
+ slaed8_(icompq, &k, n, qsiz, &d__[1], &q[q_offset], ldq, &indxq[1], rho,
+ cutpnt, &work[iz], &work[idlmda], &work[iq2], &ldq2, &work[iw], &
+ perm[prmptr[curr]], &givptr[curr + 1], &givcol[(givptr[curr] << 1)
+ + 1], &givnum[(givptr[curr] << 1) + 1], &iwork[indxp], &iwork[
+ indx], info);
+ prmptr[curr + 1] = prmptr[curr] + *n;
+ givptr[curr + 1] += givptr[curr];
+
+/* Solve Secular Equation. */
+
+ if (k != 0) {
+ slaed9_(&k, &c__1, &k, n, &d__[1], &work[is], &k, rho, &work[idlmda],
+ &work[iw], &qstore[qptr[curr]], &k, info);
+ if (*info != 0) {
+ goto L30;
+ }
+ if (*icompq == 1) {
+ sgemm_("N", "N", qsiz, &k, &k, &c_b10, &work[iq2], &ldq2, &qstore[
+ qptr[curr]], &k, &c_b11, &q[q_offset], ldq);
+ }
+/* Computing 2nd power */
+ i__1 = k;
+ qptr[curr + 1] = qptr[curr] + i__1 * i__1;
+
+/* Prepare the INDXQ sorting permutation. */
+
+ n1 = k;
+ n2 = *n - k;
+ slamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]);
+ } else {
+ qptr[curr + 1] = qptr[curr];
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ indxq[i__] = i__;
+/* L20: */
+ }
+ }
+
+L30:
+ return 0;
+
+/* End of SLAED7 */
+
+} /* slaed7_ */
diff --git a/SRC/slaed8.c b/SRC/slaed8.c
new file mode 100644
index 0000000..25776f8
--- /dev/null
+++ b/SRC/slaed8.c
@@ -0,0 +1,475 @@
+/* slaed8.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b3 = -1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int slaed8_(integer *icompq, integer *k, integer *n, integer
+ *qsiz, real *d__, real *q, integer *ldq, integer *indxq, real *rho,
+ integer *cutpnt, real *z__, real *dlamda, real *q2, integer *ldq2,
+ real *w, integer *perm, integer *givptr, integer *givcol, real *
+ givnum, integer *indxp, integer *indx, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, q2_dim1, q2_offset, i__1;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real c__;
+ integer i__, j;
+ real s, t;
+ integer k2, n1, n2, jp, n1p1;
+ real eps, tau, tol;
+ integer jlam, imax, jmax;
+ extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
+ integer *, real *, real *), sscal_(integer *, real *, real *,
+ integer *), scopy_(integer *, real *, integer *, real *, integer *
+);
+ extern doublereal slapy2_(real *, real *), slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ extern /* Subroutine */ int slamrg_(integer *, integer *, real *, integer
+ *, integer *, integer *), slacpy_(char *, integer *, integer *,
+ real *, integer *, real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAED8 merges the two sets of eigenvalues together into a single */
+/* sorted set. Then it tries to deflate the size of the problem. */
+/* There are two ways in which deflation can occur: when two or more */
+/* eigenvalues are close together or if there is a tiny element in the */
+/* Z vector. For each such occurrence the order of the related secular */
+/* equation problem is reduced by one. */
+
+/* Arguments */
+/* ========= */
+
+/* ICOMPQ (input) INTEGER */
+/* = 0: Compute eigenvalues only. */
+/* = 1: Compute eigenvectors of original dense symmetric matrix */
+/* also. On entry, Q contains the orthogonal matrix used */
+/* to reduce the original matrix to tridiagonal form. */
+
+/* K (output) INTEGER */
+/* The number of non-deflated eigenvalues, and the order of the */
+/* related secular equation. */
+
+/* N (input) INTEGER */
+/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
+
+/* QSIZ (input) INTEGER */
+/* The dimension of the orthogonal matrix used to reduce */
+/* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the eigenvalues of the two submatrices to be */
+/* combined. On exit, the trailing (N-K) updated eigenvalues */
+/* (those which were deflated) sorted into increasing order. */
+
+/* Q (input/output) REAL array, dimension (LDQ,N) */
+/* If ICOMPQ = 0, Q is not referenced. Otherwise, */
+/* on entry, Q contains the eigenvectors of the partially solved */
+/* system which has been previously updated in matrix */
+/* multiplies with other partially solved eigensystems. */
+/* On exit, Q contains the trailing (N-K) updated eigenvectors */
+/* (those which were deflated) in its last N-K columns. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* INDXQ (input) INTEGER array, dimension (N) */
+/* The permutation which separately sorts the two sub-problems */
+/* in D into ascending order. Note that elements in the second */
+/* half of this permutation must first have CUTPNT added to */
+/* their values in order to be accurate. */
+
+/* RHO (input/output) REAL */
+/* On entry, the off-diagonal element associated with the rank-1 */
+/* cut which originally split the two submatrices which are now */
+/* being recombined. */
+/* On exit, RHO has been modified to the value required by */
+/* SLAED3. */
+
+/* CUTPNT (input) INTEGER */
+/* The location of the last eigenvalue in the leading */
+/* sub-matrix. min(1,N) <= CUTPNT <= N. */
+
+/* Z (input) REAL array, dimension (N) */
+/* On entry, Z contains the updating vector (the last row of */
+/* the first sub-eigenvector matrix and the first row of the */
+/* second sub-eigenvector matrix). */
+/* On exit, the contents of Z are destroyed by the updating */
+/* process. */
+
+/* DLAMDA (output) REAL array, dimension (N) */
+/* A copy of the first K eigenvalues which will be used by */
+/* SLAED3 to form the secular equation. */
+
+/* Q2 (output) REAL array, dimension (LDQ2,N) */
+/* If ICOMPQ = 0, Q2 is not referenced. Otherwise, */
+/* a copy of the first K eigenvectors which will be used by */
+/* SLAED7 in a matrix multiply (SGEMM) to update the new */
+/* eigenvectors. */
+
+/* LDQ2 (input) INTEGER */
+/* The leading dimension of the array Q2. LDQ2 >= max(1,N). */
+
+/* W (output) REAL array, dimension (N) */
+/* The first k values of the final deflation-altered z-vector and */
+/* will be passed to SLAED3. */
+
+/* PERM (output) INTEGER array, dimension (N) */
+/* The permutations (from deflation and sorting) to be applied */
+/* to each eigenblock. */
+
+/* GIVPTR (output) INTEGER */
+/* The number of Givens rotations which took place in this */
+/* subproblem. */
+
+/* GIVCOL (output) INTEGER array, dimension (2, N) */
+/* Each pair of numbers indicates a pair of columns to take place */
+/* in a Givens rotation. */
+
+/* GIVNUM (output) REAL array, dimension (2, N) */
+/* Each number indicates the S value to be used in the */
+/* corresponding Givens rotation. */
+
+/* INDXP (workspace) INTEGER array, dimension (N) */
+/* The permutation used to place deflated values of D at the end */
+/* of the array. INDXP(1:K) points to the nondeflated D-values */
+/* and INDXP(K+1:N) points to the deflated eigenvalues. */
+
+/* INDX (workspace) INTEGER array, dimension (N) */
+/* The permutation used to sort the contents of D into ascending */
+/* order. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --indxq;
+ --z__;
+ --dlamda;
+ q2_dim1 = *ldq2;
+ q2_offset = 1 + q2_dim1;
+ q2 -= q2_offset;
+ --w;
+ --perm;
+ givcol -= 3;
+ givnum -= 3;
+ --indxp;
+ --indx;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*icompq < 0 || *icompq > 1) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*icompq == 1 && *qsiz < *n) {
+ *info = -4;
+ } else if (*ldq < max(1,*n)) {
+ *info = -7;
+ } else if (*cutpnt < min(1,*n) || *cutpnt > *n) {
+ *info = -10;
+ } else if (*ldq2 < max(1,*n)) {
+ *info = -14;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLAED8", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ n1 = *cutpnt;
+ n2 = *n - n1;
+ n1p1 = n1 + 1;
+
+ if (*rho < 0.f) {
+ sscal_(&n2, &c_b3, &z__[n1p1], &c__1);
+ }
+
+/* Normalize z so that norm(z) = 1 */
+
+ t = 1.f / sqrt(2.f);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ indx[j] = j;
+/* L10: */
+ }
+ sscal_(n, &t, &z__[1], &c__1);
+ *rho = (r__1 = *rho * 2.f, dabs(r__1));
+
+/* Sort the eigenvalues into increasing order */
+
+ i__1 = *n;
+ for (i__ = *cutpnt + 1; i__ <= i__1; ++i__) {
+ indxq[i__] += *cutpnt;
+/* L20: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dlamda[i__] = d__[indxq[i__]];
+ w[i__] = z__[indxq[i__]];
+/* L30: */
+ }
+ i__ = 1;
+ j = *cutpnt + 1;
+ slamrg_(&n1, &n2, &dlamda[1], &c__1, &c__1, &indx[1]);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = dlamda[indx[i__]];
+ z__[i__] = w[indx[i__]];
+/* L40: */
+ }
+
+/* Calculate the allowable deflation tolerence */
+
+ imax = isamax_(n, &z__[1], &c__1);
+ jmax = isamax_(n, &d__[1], &c__1);
+ eps = slamch_("Epsilon");
+ tol = eps * 8.f * (r__1 = d__[jmax], dabs(r__1));
+
+/* If the rank-1 modifier is small enough, no more needs to be done */
+/* except to reorganize Q so that its columns correspond with the */
+/* elements in D. */
+
+ if (*rho * (r__1 = z__[imax], dabs(r__1)) <= tol) {
+ *k = 0;
+ if (*icompq == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ perm[j] = indxq[indx[j]];
+/* L50: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ perm[j] = indxq[indx[j]];
+ scopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1
+ + 1], &c__1);
+/* L60: */
+ }
+ slacpy_("A", qsiz, n, &q2[q2_dim1 + 1], ldq2, &q[q_dim1 + 1], ldq);
+ }
+ return 0;
+ }
+
+/* If there are multiple eigenvalues then the problem deflates. Here */
+/* the number of equal eigenvalues are found. As each equal */
+/* eigenvalue is found, an elementary reflector is computed to rotate */
+/* the corresponding eigensubspace so that the corresponding */
+/* components of Z are zero in this new basis. */
+
+ *k = 0;
+ *givptr = 0;
+ k2 = *n + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*rho * (r__1 = z__[j], dabs(r__1)) <= tol) {
+
+/* Deflate due to small z component. */
+
+ --k2;
+ indxp[k2] = j;
+ if (j == *n) {
+ goto L110;
+ }
+ } else {
+ jlam = j;
+ goto L80;
+ }
+/* L70: */
+ }
+L80:
+ ++j;
+ if (j > *n) {
+ goto L100;
+ }
+ if (*rho * (r__1 = z__[j], dabs(r__1)) <= tol) {
+
+/* Deflate due to small z component. */
+
+ --k2;
+ indxp[k2] = j;
+ } else {
+
+/* Check if eigenvalues are close enough to allow deflation. */
+
+ s = z__[jlam];
+ c__ = z__[j];
+
+/* Find sqrt(a**2+b**2) without overflow or */
+/* destructive underflow. */
+
+ tau = slapy2_(&c__, &s);
+ t = d__[j] - d__[jlam];
+ c__ /= tau;
+ s = -s / tau;
+ if ((r__1 = t * c__ * s, dabs(r__1)) <= tol) {
+
+/* Deflation is possible. */
+
+ z__[j] = tau;
+ z__[jlam] = 0.f;
+
+/* Record the appropriate Givens rotation */
+
+ ++(*givptr);
+ givcol[(*givptr << 1) + 1] = indxq[indx[jlam]];
+ givcol[(*givptr << 1) + 2] = indxq[indx[j]];
+ givnum[(*givptr << 1) + 1] = c__;
+ givnum[(*givptr << 1) + 2] = s;
+ if (*icompq == 1) {
+ srot_(qsiz, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, &q[
+ indxq[indx[j]] * q_dim1 + 1], &c__1, &c__, &s);
+ }
+ t = d__[jlam] * c__ * c__ + d__[j] * s * s;
+ d__[j] = d__[jlam] * s * s + d__[j] * c__ * c__;
+ d__[jlam] = t;
+ --k2;
+ i__ = 1;
+L90:
+ if (k2 + i__ <= *n) {
+ if (d__[jlam] < d__[indxp[k2 + i__]]) {
+ indxp[k2 + i__ - 1] = indxp[k2 + i__];
+ indxp[k2 + i__] = jlam;
+ ++i__;
+ goto L90;
+ } else {
+ indxp[k2 + i__ - 1] = jlam;
+ }
+ } else {
+ indxp[k2 + i__ - 1] = jlam;
+ }
+ jlam = j;
+ } else {
+ ++(*k);
+ w[*k] = z__[jlam];
+ dlamda[*k] = d__[jlam];
+ indxp[*k] = jlam;
+ jlam = j;
+ }
+ }
+ goto L80;
+L100:
+
+/* Record the last eigenvalue. */
+
+ ++(*k);
+ w[*k] = z__[jlam];
+ dlamda[*k] = d__[jlam];
+ indxp[*k] = jlam;
+
+L110:
+
+/* Sort the eigenvalues and corresponding eigenvectors into DLAMDA */
+/* and Q2 respectively. The eigenvalues/vectors which were not */
+/* deflated go into the first K slots of DLAMDA and Q2 respectively, */
+/* while those which were deflated go into the last N - K slots. */
+
+ if (*icompq == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ jp = indxp[j];
+ dlamda[j] = d__[jp];
+ perm[j] = indxq[indx[jp]];
+/* L120: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ jp = indxp[j];
+ dlamda[j] = d__[jp];
+ perm[j] = indxq[indx[jp]];
+ scopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1]
+, &c__1);
+/* L130: */
+ }
+ }
+
+/* The deflated eigenvalues and their corresponding vectors go back */
+/* into the last N - K slots of D and Q respectively. */
+
+ if (*k < *n) {
+ if (*icompq == 0) {
+ i__1 = *n - *k;
+ scopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1);
+ } else {
+ i__1 = *n - *k;
+ scopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1);
+ i__1 = *n - *k;
+ slacpy_("A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(*
+ k + 1) * q_dim1 + 1], ldq);
+ }
+ }
+
+ return 0;
+
+/* End of SLAED8 */
+
+} /* slaed8_ */
diff --git a/SRC/slaed9.c b/SRC/slaed9.c
new file mode 100644
index 0000000..df4c0bd
--- /dev/null
+++ b/SRC/slaed9.c
@@ -0,0 +1,272 @@
+/* slaed9.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int slaed9_(integer *k, integer *kstart, integer *kstop,
+ integer *n, real *d__, real *q, integer *ldq, real *rho, real *dlamda,
+ real *w, real *s, integer *lds, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, s_dim1, s_offset, i__1, i__2;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_sign(real *, real *);
+
+ /* Local variables */
+ integer i__, j;
+ real temp;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), slaed4_(integer *, integer *, real *, real *, real *,
+ real *, real *, integer *);
+ extern doublereal slamc3_(real *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAED9 finds the roots of the secular equation, as defined by the */
+/* values in D, Z, and RHO, between KSTART and KSTOP. It makes the */
+/* appropriate calls to SLAED4 and then stores the new matrix of */
+/* eigenvectors for use in calculating the next level of Z vectors. */
+
+/* Arguments */
+/* ========= */
+
+/* K (input) INTEGER */
+/* The number of terms in the rational function to be solved by */
+/* SLAED4. K >= 0. */
+
+/* KSTART (input) INTEGER */
+/* KSTOP (input) INTEGER */
+/* The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP */
+/* are to be computed. 1 <= KSTART <= KSTOP <= K. */
+
+/* N (input) INTEGER */
+/* The number of rows and columns in the Q matrix. */
+/* N >= K (delation may result in N > K). */
+
+/* D (output) REAL array, dimension (N) */
+/* D(I) contains the updated eigenvalues */
+/* for KSTART <= I <= KSTOP. */
+
+/* Q (workspace) REAL array, dimension (LDQ,N) */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max( 1, N ). */
+
+/* RHO (input) REAL */
+/* The value of the parameter in the rank one update equation. */
+/* RHO >= 0 required. */
+
+/* DLAMDA (input) REAL array, dimension (K) */
+/* The first K elements of this array contain the old roots */
+/* of the deflated updating problem. These are the poles */
+/* of the secular equation. */
+
+/* W (input) REAL array, dimension (K) */
+/* The first K elements of this array contain the components */
+/* of the deflation-adjusted updating vector. */
+
+/* S (output) REAL array, dimension (LDS, K) */
+/* Will contain the eigenvectors of the repaired matrix which */
+/* will be stored for subsequent Z vector calculation and */
+/* multiplied by the previously accumulated eigenvectors */
+/* to update the system. */
+
+/* LDS (input) INTEGER */
+/* The leading dimension of S. LDS >= max( 1, K ). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, an eigenvalue did not converge */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --dlamda;
+ --w;
+ s_dim1 = *lds;
+ s_offset = 1 + s_dim1;
+ s -= s_offset;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*k < 0) {
+ *info = -1;
+ } else if (*kstart < 1 || *kstart > max(1,*k)) {
+ *info = -2;
+ } else if (max(1,*kstop) < *kstart || *kstop > max(1,*k)) {
+ *info = -3;
+ } else if (*n < *k) {
+ *info = -4;
+ } else if (*ldq < max(1,*k)) {
+ *info = -7;
+ } else if (*lds < max(1,*k)) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLAED9", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*k == 0) {
+ return 0;
+ }
+
+/* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can */
+/* be computed with high relative accuracy (barring over/underflow). */
+/* This is a problem on machines without a guard digit in */
+/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */
+/* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), */
+/* which on any of these machines zeros out the bottommost */
+/* bit of DLAMDA(I) if it is 1; this makes the subsequent */
+/* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation */
+/* occurs. On binary machines with a guard digit (almost all */
+/* machines) it does not change DLAMDA(I) at all. On hexadecimal */
+/* and decimal machines with a guard digit, it slightly */
+/* changes the bottommost bits of DLAMDA(I). It does not account */
+/* for hexadecimal or decimal machines without guard digits */
+/* (we know of none). We use a subroutine call to compute */
+/* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating */
+/* this code. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dlamda[i__] = slamc3_(&dlamda[i__], &dlamda[i__]) - dlamda[i__];
+/* L10: */
+ }
+
+ i__1 = *kstop;
+ for (j = *kstart; j <= i__1; ++j) {
+ slaed4_(k, &j, &dlamda[1], &w[1], &q[j * q_dim1 + 1], rho, &d__[j],
+ info);
+
+/* If the zero finder fails, the computation is terminated. */
+
+ if (*info != 0) {
+ goto L120;
+ }
+/* L20: */
+ }
+
+ if (*k == 1 || *k == 2) {
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *k;
+ for (j = 1; j <= i__2; ++j) {
+ s[j + i__ * s_dim1] = q[j + i__ * q_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ goto L120;
+ }
+
+/* Compute updated W. */
+
+ scopy_(k, &w[1], &c__1, &s[s_offset], &c__1);
+
+/* Initialize W(I) = Q(I,I) */
+
+ i__1 = *ldq + 1;
+ scopy_(k, &q[q_offset], &i__1, &w[1], &c__1);
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
+/* L50: */
+ }
+ i__2 = *k;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ w[i__] *= q[i__ + j * q_dim1] / (dlamda[i__] - dlamda[j]);
+/* L60: */
+ }
+/* L70: */
+ }
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__1 = sqrt(-w[i__]);
+ w[i__] = r_sign(&r__1, &s[i__ + s_dim1]);
+/* L80: */
+ }
+
+/* Compute eigenvectors of the modified rank-1 modification. */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *k;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ q[i__ + j * q_dim1] = w[i__] / q[i__ + j * q_dim1];
+/* L90: */
+ }
+ temp = snrm2_(k, &q[j * q_dim1 + 1], &c__1);
+ i__2 = *k;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ s[i__ + j * s_dim1] = q[i__ + j * q_dim1] / temp;
+/* L100: */
+ }
+/* L110: */
+ }
+
+L120:
+ return 0;
+
+/* End of SLAED9 */
+
+} /* slaed9_ */
diff --git a/SRC/slaeda.c b/SRC/slaeda.c
new file mode 100644
index 0000000..f9ffbd3
--- /dev/null
+++ b/SRC/slaeda.c
@@ -0,0 +1,283 @@
+/* slaeda.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static real c_b24 = 1.f;
+static real c_b26 = 0.f;
+
+/* Subroutine */ int slaeda_(integer *n, integer *tlvls, integer *curlvl,
+ integer *curpbm, integer *prmptr, integer *perm, integer *givptr,
+ integer *givcol, real *givnum, real *q, integer *qptr, real *z__,
+ real *ztemp, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+
+ /* Builtin functions */
+ integer pow_ii(integer *, integer *);
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, k, mid, ptr, curr;
+ extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
+ integer *, real *, real *);
+ integer bsiz1, bsiz2, psiz1, psiz2, zptr1;
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *),
+ xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAEDA computes the Z vector corresponding to the merge step in the */
+/* CURLVLth step of the merge process with TLVLS steps for the CURPBMth */
+/* problem. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
+
+/* TLVLS (input) INTEGER */
+/* The total number of merging levels in the overall divide and */
+/* conquer tree. */
+
+/* CURLVL (input) INTEGER */
+/* The current level in the overall merge routine, */
+/* 0 <= curlvl <= tlvls. */
+
+/* CURPBM (input) INTEGER */
+/* The current problem in the current level in the overall */
+/* merge routine (counting from upper left to lower right). */
+
+/* PRMPTR (input) INTEGER array, dimension (N lg N) */
+/* Contains a list of pointers which indicate where in PERM a */
+/* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) */
+/* indicates the size of the permutation and incidentally the */
+/* size of the full, non-deflated problem. */
+
+/* PERM (input) INTEGER array, dimension (N lg N) */
+/* Contains the permutations (from deflation and sorting) to be */
+/* applied to each eigenblock. */
+
+/* GIVPTR (input) INTEGER array, dimension (N lg N) */
+/* Contains a list of pointers which indicate where in GIVCOL a */
+/* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) */
+/* indicates the number of Givens rotations. */
+
+/* GIVCOL (input) INTEGER array, dimension (2, N lg N) */
+/* Each pair of numbers indicates a pair of columns to take place */
+/* in a Givens rotation. */
+
+/* GIVNUM (input) REAL array, dimension (2, N lg N) */
+/* Each number indicates the S value to be used in the */
+/* corresponding Givens rotation. */
+
+/* Q (input) REAL array, dimension (N**2) */
+/* Contains the square eigenblocks from previous levels, the */
+/* starting positions for blocks are given by QPTR. */
+
+/* QPTR (input) INTEGER array, dimension (N+2) */
+/* Contains a list of pointers which indicate where in Q an */
+/* eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates */
+/* the size of the block. */
+
+/* Z (output) REAL array, dimension (N) */
+/* On output this vector contains the updating vector (the last */
+/* row of the first sub-eigenvector matrix and the first row of */
+/* the second sub-eigenvector matrix). */
+
+/* ZTEMP (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ztemp;
+ --z__;
+ --qptr;
+ --q;
+ givnum -= 3;
+ givcol -= 3;
+ --givptr;
+ --perm;
+ --prmptr;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*n < 0) {
+ *info = -1;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLAEDA", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine location of first number in second half. */
+
+ mid = *n / 2 + 1;
+
+/* Gather last/first rows of appropriate eigenblocks into center of Z */
+
+ ptr = 1;
+
+/* Determine location of lowest level subproblem in the full storage */
+/* scheme */
+
+ i__1 = *curlvl - 1;
+ curr = ptr + *curpbm * pow_ii(&c__2, curlvl) + pow_ii(&c__2, &i__1) - 1;
+
+/* Determine size of these matrices. We add HALF to the value of */
+/* the SQRT in case the machine underestimates one of these square */
+/* roots. */
+
+ bsiz1 = (integer) (sqrt((real) (qptr[curr + 1] - qptr[curr])) + .5f);
+ bsiz2 = (integer) (sqrt((real) (qptr[curr + 2] - qptr[curr + 1])) + .5f);
+ i__1 = mid - bsiz1 - 1;
+ for (k = 1; k <= i__1; ++k) {
+ z__[k] = 0.f;
+/* L10: */
+ }
+ scopy_(&bsiz1, &q[qptr[curr] + bsiz1 - 1], &bsiz1, &z__[mid - bsiz1], &
+ c__1);
+ scopy_(&bsiz2, &q[qptr[curr + 1]], &bsiz2, &z__[mid], &c__1);
+ i__1 = *n;
+ for (k = mid + bsiz2; k <= i__1; ++k) {
+ z__[k] = 0.f;
+/* L20: */
+ }
+
+/* Loop thru remaining levels 1 -> CURLVL applying the Givens */
+/* rotations and permutation and then multiplying the center matrices */
+/* against the current Z. */
+
+ ptr = pow_ii(&c__2, tlvls) + 1;
+ i__1 = *curlvl - 1;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *curlvl - k;
+ i__3 = *curlvl - k - 1;
+ curr = ptr + *curpbm * pow_ii(&c__2, &i__2) + pow_ii(&c__2, &i__3) -
+ 1;
+ psiz1 = prmptr[curr + 1] - prmptr[curr];
+ psiz2 = prmptr[curr + 2] - prmptr[curr + 1];
+ zptr1 = mid - psiz1;
+
+/* Apply Givens at CURR and CURR+1 */
+
+ i__2 = givptr[curr + 1] - 1;
+ for (i__ = givptr[curr]; i__ <= i__2; ++i__) {
+ srot_(&c__1, &z__[zptr1 + givcol[(i__ << 1) + 1] - 1], &c__1, &
+ z__[zptr1 + givcol[(i__ << 1) + 2] - 1], &c__1, &givnum[(
+ i__ << 1) + 1], &givnum[(i__ << 1) + 2]);
+/* L30: */
+ }
+ i__2 = givptr[curr + 2] - 1;
+ for (i__ = givptr[curr + 1]; i__ <= i__2; ++i__) {
+ srot_(&c__1, &z__[mid - 1 + givcol[(i__ << 1) + 1]], &c__1, &z__[
+ mid - 1 + givcol[(i__ << 1) + 2]], &c__1, &givnum[(i__ <<
+ 1) + 1], &givnum[(i__ << 1) + 2]);
+/* L40: */
+ }
+ psiz1 = prmptr[curr + 1] - prmptr[curr];
+ psiz2 = prmptr[curr + 2] - prmptr[curr + 1];
+ i__2 = psiz1 - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ ztemp[i__ + 1] = z__[zptr1 + perm[prmptr[curr] + i__] - 1];
+/* L50: */
+ }
+ i__2 = psiz2 - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ ztemp[psiz1 + i__ + 1] = z__[mid + perm[prmptr[curr + 1] + i__] -
+ 1];
+/* L60: */
+ }
+
+/* Multiply Blocks at CURR and CURR+1 */
+
+/* Determine size of these matrices. We add HALF to the value of */
+/* the SQRT in case the machine underestimates one of these */
+/* square roots. */
+
+ bsiz1 = (integer) (sqrt((real) (qptr[curr + 1] - qptr[curr])) + .5f);
+ bsiz2 = (integer) (sqrt((real) (qptr[curr + 2] - qptr[curr + 1])) +
+ .5f);
+ if (bsiz1 > 0) {
+ sgemv_("T", &bsiz1, &bsiz1, &c_b24, &q[qptr[curr]], &bsiz1, &
+ ztemp[1], &c__1, &c_b26, &z__[zptr1], &c__1);
+ }
+ i__2 = psiz1 - bsiz1;
+ scopy_(&i__2, &ztemp[bsiz1 + 1], &c__1, &z__[zptr1 + bsiz1], &c__1);
+ if (bsiz2 > 0) {
+ sgemv_("T", &bsiz2, &bsiz2, &c_b24, &q[qptr[curr + 1]], &bsiz2, &
+ ztemp[psiz1 + 1], &c__1, &c_b26, &z__[mid], &c__1);
+ }
+ i__2 = psiz2 - bsiz2;
+ scopy_(&i__2, &ztemp[psiz1 + bsiz2 + 1], &c__1, &z__[mid + bsiz2], &
+ c__1);
+
+ i__2 = *tlvls - k;
+ ptr += pow_ii(&c__2, &i__2);
+/* L70: */
+ }
+
+ return 0;
+
+/* End of SLAEDA */
+
+} /* slaeda_ */
diff --git a/SRC/slaein.c b/SRC/slaein.c
new file mode 100644
index 0000000..5cec131
--- /dev/null
+++ b/SRC/slaein.c
@@ -0,0 +1,678 @@
+/* slaein.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int slaein_(logical *rightv, logical *noinit, integer *n,
+ real *h__, integer *ldh, real *wr, real *wi, real *vr, real *vi, real
+ *b, integer *ldb, real *work, real *eps3, real *smlnum, real *bignum,
+ integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ real w, x, y;
+ integer i1, i2, i3;
+ real w1, ei, ej, xi, xr, rec;
+ integer its, ierr;
+ real temp, norm, vmax;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ real scale;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ char trans[1];
+ real vcrit;
+ extern doublereal sasum_(integer *, real *, integer *);
+ real rootn, vnorm;
+ extern doublereal slapy2_(real *, real *);
+ real absbii, absbjj;
+ extern integer isamax_(integer *, real *, integer *);
+ extern /* Subroutine */ int sladiv_(real *, real *, real *, real *, real *
+, real *);
+ char normin[1];
+ real nrmsml;
+ extern /* Subroutine */ int slatrs_(char *, char *, char *, char *,
+ integer *, real *, integer *, real *, real *, real *, integer *);
+ real growto;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAEIN uses inverse iteration to find a right or left eigenvector */
+/* corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg */
+/* matrix H. */
+
+/* Arguments */
+/* ========= */
+
+/* RIGHTV (input) LOGICAL */
+/* = .TRUE. : compute right eigenvector; */
+/* = .FALSE.: compute left eigenvector. */
+
+/* NOINIT (input) LOGICAL */
+/* = .TRUE. : no initial vector supplied in (VR,VI). */
+/* = .FALSE.: initial vector supplied in (VR,VI). */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N >= 0. */
+
+/* H (input) REAL array, dimension (LDH,N) */
+/* The upper Hessenberg matrix H. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH >= max(1,N). */
+
+/* WR (input) REAL */
+/* WI (input) REAL */
+/* The real and imaginary parts of the eigenvalue of H whose */
+/* corresponding right or left eigenvector is to be computed. */
+
+/* VR (input/output) REAL array, dimension (N) */
+/* VI (input/output) REAL array, dimension (N) */
+/* On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain */
+/* a real starting vector for inverse iteration using the real */
+/* eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI */
+/* must contain the real and imaginary parts of a complex */
+/* starting vector for inverse iteration using the complex */
+/* eigenvalue (WR,WI); otherwise VR and VI need not be set. */
+/* On exit, if WI = 0.0 (real eigenvalue), VR contains the */
+/* computed real eigenvector; if WI.ne.0.0 (complex eigenvalue), */
+/* VR and VI contain the real and imaginary parts of the */
+/* computed complex eigenvector. The eigenvector is normalized */
+/* so that the component of largest magnitude has magnitude 1; */
+/* here the magnitude of a complex number (x,y) is taken to be */
+/* |x| + |y|. */
+/* VI is not referenced if WI = 0.0. */
+
+/* B (workspace) REAL array, dimension (LDB,N) */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= N+1. */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* EPS3 (input) REAL */
+/* A small machine-dependent value which is used to perturb */
+/* close eigenvalues, and to replace zero pivots. */
+
+/* SMLNUM (input) REAL */
+/* A machine-dependent value close to the underflow threshold. */
+
+/* BIGNUM (input) REAL */
+/* A machine-dependent value close to the overflow threshold. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* = 1: inverse iteration did not converge; VR is set to the */
+/* last iterate, and so is VI if WI.ne.0.0. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --vr;
+ --vi;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* GROWTO is the threshold used in the acceptance test for an */
+/* eigenvector. */
+
+ rootn = sqrt((real) (*n));
+ growto = .1f / rootn;
+/* Computing MAX */
+ r__1 = 1.f, r__2 = *eps3 * rootn;
+ nrmsml = dmax(r__1,r__2) * *smlnum;
+
+/* Form B = H - (WR,WI)*I (except that the subdiagonal elements and */
+/* the imaginary parts of the diagonal elements are not stored). */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = h__[i__ + j * h_dim1];
+/* L10: */
+ }
+ b[j + j * b_dim1] = h__[j + j * h_dim1] - *wr;
+/* L20: */
+ }
+
+ if (*wi == 0.f) {
+
+/* Real eigenvalue. */
+
+ if (*noinit) {
+
+/* Set initial vector. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ vr[i__] = *eps3;
+/* L30: */
+ }
+ } else {
+
+/* Scale supplied initial vector. */
+
+ vnorm = snrm2_(n, &vr[1], &c__1);
+ r__1 = *eps3 * rootn / dmax(vnorm,nrmsml);
+ sscal_(n, &r__1, &vr[1], &c__1);
+ }
+
+ if (*rightv) {
+
+/* LU decomposition with partial pivoting of B, replacing zero */
+/* pivots by EPS3. */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ei = h__[i__ + 1 + i__ * h_dim1];
+ if ((r__1 = b[i__ + i__ * b_dim1], dabs(r__1)) < dabs(ei)) {
+
+/* Interchange rows and eliminate. */
+
+ x = b[i__ + i__ * b_dim1] / ei;
+ b[i__ + i__ * b_dim1] = ei;
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ temp = b[i__ + 1 + j * b_dim1];
+ b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - x *
+ temp;
+ b[i__ + j * b_dim1] = temp;
+/* L40: */
+ }
+ } else {
+
+/* Eliminate without interchange. */
+
+ if (b[i__ + i__ * b_dim1] == 0.f) {
+ b[i__ + i__ * b_dim1] = *eps3;
+ }
+ x = ei / b[i__ + i__ * b_dim1];
+ if (x != 0.f) {
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ b[i__ + 1 + j * b_dim1] -= x * b[i__ + j * b_dim1]
+ ;
+/* L50: */
+ }
+ }
+ }
+/* L60: */
+ }
+ if (b[*n + *n * b_dim1] == 0.f) {
+ b[*n + *n * b_dim1] = *eps3;
+ }
+
+ *(unsigned char *)trans = 'N';
+
+ } else {
+
+/* UL decomposition with partial pivoting of B, replacing zero */
+/* pivots by EPS3. */
+
+ for (j = *n; j >= 2; --j) {
+ ej = h__[j + (j - 1) * h_dim1];
+ if ((r__1 = b[j + j * b_dim1], dabs(r__1)) < dabs(ej)) {
+
+/* Interchange columns and eliminate. */
+
+ x = b[j + j * b_dim1] / ej;
+ b[j + j * b_dim1] = ej;
+ i__1 = j - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = b[i__ + (j - 1) * b_dim1];
+ b[i__ + (j - 1) * b_dim1] = b[i__ + j * b_dim1] - x *
+ temp;
+ b[i__ + j * b_dim1] = temp;
+/* L70: */
+ }
+ } else {
+
+/* Eliminate without interchange. */
+
+ if (b[j + j * b_dim1] == 0.f) {
+ b[j + j * b_dim1] = *eps3;
+ }
+ x = ej / b[j + j * b_dim1];
+ if (x != 0.f) {
+ i__1 = j - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ b[i__ + (j - 1) * b_dim1] -= x * b[i__ + j *
+ b_dim1];
+/* L80: */
+ }
+ }
+ }
+/* L90: */
+ }
+ if (b[b_dim1 + 1] == 0.f) {
+ b[b_dim1 + 1] = *eps3;
+ }
+
+ *(unsigned char *)trans = 'T';
+
+ }
+
+ *(unsigned char *)normin = 'N';
+ i__1 = *n;
+ for (its = 1; its <= i__1; ++its) {
+
+/* Solve U*x = scale*v for a right eigenvector */
+/* or U'*x = scale*v for a left eigenvector, */
+/* overwriting x on v. */
+
+ slatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, &
+ vr[1], &scale, &work[1], &ierr);
+ *(unsigned char *)normin = 'Y';
+
+/* Test for sufficient growth in the norm of v. */
+
+ vnorm = sasum_(n, &vr[1], &c__1);
+ if (vnorm >= growto * scale) {
+ goto L120;
+ }
+
+/* Choose new orthogonal starting vector and try again. */
+
+ temp = *eps3 / (rootn + 1.f);
+ vr[1] = *eps3;
+ i__2 = *n;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ vr[i__] = temp;
+/* L100: */
+ }
+ vr[*n - its + 1] -= *eps3 * rootn;
+/* L110: */
+ }
+
+/* Failure to find eigenvector in N iterations. */
+
+ *info = 1;
+
+L120:
+
+/* Normalize eigenvector. */
+
+ i__ = isamax_(n, &vr[1], &c__1);
+ r__2 = 1.f / (r__1 = vr[i__], dabs(r__1));
+ sscal_(n, &r__2, &vr[1], &c__1);
+ } else {
+
+/* Complex eigenvalue. */
+
+ if (*noinit) {
+
+/* Set initial vector. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ vr[i__] = *eps3;
+ vi[i__] = 0.f;
+/* L130: */
+ }
+ } else {
+
+/* Scale supplied initial vector. */
+
+ r__1 = snrm2_(n, &vr[1], &c__1);
+ r__2 = snrm2_(n, &vi[1], &c__1);
+ norm = slapy2_(&r__1, &r__2);
+ rec = *eps3 * rootn / dmax(norm,nrmsml);
+ sscal_(n, &rec, &vr[1], &c__1);
+ sscal_(n, &rec, &vi[1], &c__1);
+ }
+
+ if (*rightv) {
+
+/* LU decomposition with partial pivoting of B, replacing zero */
+/* pivots by EPS3. */
+
+/* The imaginary part of the (i,j)-th element of U is stored in */
+/* B(j+1,i). */
+
+ b[b_dim1 + 2] = -(*wi);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ b[i__ + 1 + b_dim1] = 0.f;
+/* L140: */
+ }
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ absbii = slapy2_(&b[i__ + i__ * b_dim1], &b[i__ + 1 + i__ *
+ b_dim1]);
+ ei = h__[i__ + 1 + i__ * h_dim1];
+ if (absbii < dabs(ei)) {
+
+/* Interchange rows and eliminate. */
+
+ xr = b[i__ + i__ * b_dim1] / ei;
+ xi = b[i__ + 1 + i__ * b_dim1] / ei;
+ b[i__ + i__ * b_dim1] = ei;
+ b[i__ + 1 + i__ * b_dim1] = 0.f;
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ temp = b[i__ + 1 + j * b_dim1];
+ b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - xr *
+ temp;
+ b[j + 1 + (i__ + 1) * b_dim1] = b[j + 1 + i__ *
+ b_dim1] - xi * temp;
+ b[i__ + j * b_dim1] = temp;
+ b[j + 1 + i__ * b_dim1] = 0.f;
+/* L150: */
+ }
+ b[i__ + 2 + i__ * b_dim1] = -(*wi);
+ b[i__ + 1 + (i__ + 1) * b_dim1] -= xi * *wi;
+ b[i__ + 2 + (i__ + 1) * b_dim1] += xr * *wi;
+ } else {
+
+/* Eliminate without interchanging rows. */
+
+ if (absbii == 0.f) {
+ b[i__ + i__ * b_dim1] = *eps3;
+ b[i__ + 1 + i__ * b_dim1] = 0.f;
+ absbii = *eps3;
+ }
+ ei = ei / absbii / absbii;
+ xr = b[i__ + i__ * b_dim1] * ei;
+ xi = -b[i__ + 1 + i__ * b_dim1] * ei;
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ b[i__ + 1 + j * b_dim1] = b[i__ + 1 + j * b_dim1] -
+ xr * b[i__ + j * b_dim1] + xi * b[j + 1 + i__
+ * b_dim1];
+ b[j + 1 + (i__ + 1) * b_dim1] = -xr * b[j + 1 + i__ *
+ b_dim1] - xi * b[i__ + j * b_dim1];
+/* L160: */
+ }
+ b[i__ + 2 + (i__ + 1) * b_dim1] -= *wi;
+ }
+
+/* Compute 1-norm of offdiagonal elements of i-th row. */
+
+ i__2 = *n - i__;
+ i__3 = *n - i__;
+ work[i__] = sasum_(&i__2, &b[i__ + (i__ + 1) * b_dim1], ldb)
+ + sasum_(&i__3, &b[i__ + 2 + i__ * b_dim1], &c__1);
+/* L170: */
+ }
+ if (b[*n + *n * b_dim1] == 0.f && b[*n + 1 + *n * b_dim1] == 0.f)
+ {
+ b[*n + *n * b_dim1] = *eps3;
+ }
+ work[*n] = 0.f;
+
+ i1 = *n;
+ i2 = 1;
+ i3 = -1;
+ } else {
+
+/* UL decomposition with partial pivoting of conjg(B), */
+/* replacing zero pivots by EPS3. */
+
+/* The imaginary part of the (i,j)-th element of U is stored in */
+/* B(j+1,i). */
+
+ b[*n + 1 + *n * b_dim1] = *wi;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ b[*n + 1 + j * b_dim1] = 0.f;
+/* L180: */
+ }
+
+ for (j = *n; j >= 2; --j) {
+ ej = h__[j + (j - 1) * h_dim1];
+ absbjj = slapy2_(&b[j + j * b_dim1], &b[j + 1 + j * b_dim1]);
+ if (absbjj < dabs(ej)) {
+
+/* Interchange columns and eliminate */
+
+ xr = b[j + j * b_dim1] / ej;
+ xi = b[j + 1 + j * b_dim1] / ej;
+ b[j + j * b_dim1] = ej;
+ b[j + 1 + j * b_dim1] = 0.f;
+ i__1 = j - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = b[i__ + (j - 1) * b_dim1];
+ b[i__ + (j - 1) * b_dim1] = b[i__ + j * b_dim1] - xr *
+ temp;
+ b[j + i__ * b_dim1] = b[j + 1 + i__ * b_dim1] - xi *
+ temp;
+ b[i__ + j * b_dim1] = temp;
+ b[j + 1 + i__ * b_dim1] = 0.f;
+/* L190: */
+ }
+ b[j + 1 + (j - 1) * b_dim1] = *wi;
+ b[j - 1 + (j - 1) * b_dim1] += xi * *wi;
+ b[j + (j - 1) * b_dim1] -= xr * *wi;
+ } else {
+
+/* Eliminate without interchange. */
+
+ if (absbjj == 0.f) {
+ b[j + j * b_dim1] = *eps3;
+ b[j + 1 + j * b_dim1] = 0.f;
+ absbjj = *eps3;
+ }
+ ej = ej / absbjj / absbjj;
+ xr = b[j + j * b_dim1] * ej;
+ xi = -b[j + 1 + j * b_dim1] * ej;
+ i__1 = j - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ b[i__ + (j - 1) * b_dim1] = b[i__ + (j - 1) * b_dim1]
+ - xr * b[i__ + j * b_dim1] + xi * b[j + 1 +
+ i__ * b_dim1];
+ b[j + i__ * b_dim1] = -xr * b[j + 1 + i__ * b_dim1] -
+ xi * b[i__ + j * b_dim1];
+/* L200: */
+ }
+ b[j + (j - 1) * b_dim1] += *wi;
+ }
+
+/* Compute 1-norm of offdiagonal elements of j-th column. */
+
+ i__1 = j - 1;
+ i__2 = j - 1;
+ work[j] = sasum_(&i__1, &b[j * b_dim1 + 1], &c__1) + sasum_(&
+ i__2, &b[j + 1 + b_dim1], ldb);
+/* L210: */
+ }
+ if (b[b_dim1 + 1] == 0.f && b[b_dim1 + 2] == 0.f) {
+ b[b_dim1 + 1] = *eps3;
+ }
+ work[1] = 0.f;
+
+ i1 = 1;
+ i2 = *n;
+ i3 = 1;
+ }
+
+ i__1 = *n;
+ for (its = 1; its <= i__1; ++its) {
+ scale = 1.f;
+ vmax = 1.f;
+ vcrit = *bignum;
+
+/* Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector, */
+/* or U'*(xr,xi) = scale*(vr,vi) for a left eigenvector, */
+/* overwriting (xr,xi) on (vr,vi). */
+
+ i__2 = i2;
+ i__3 = i3;
+ for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3)
+ {
+
+ if (work[i__] > vcrit) {
+ rec = 1.f / vmax;
+ sscal_(n, &rec, &vr[1], &c__1);
+ sscal_(n, &rec, &vi[1], &c__1);
+ scale *= rec;
+ vmax = 1.f;
+ vcrit = *bignum;
+ }
+
+ xr = vr[i__];
+ xi = vi[i__];
+ if (*rightv) {
+ i__4 = *n;
+ for (j = i__ + 1; j <= i__4; ++j) {
+ xr = xr - b[i__ + j * b_dim1] * vr[j] + b[j + 1 + i__
+ * b_dim1] * vi[j];
+ xi = xi - b[i__ + j * b_dim1] * vi[j] - b[j + 1 + i__
+ * b_dim1] * vr[j];
+/* L220: */
+ }
+ } else {
+ i__4 = i__ - 1;
+ for (j = 1; j <= i__4; ++j) {
+ xr = xr - b[j + i__ * b_dim1] * vr[j] + b[i__ + 1 + j
+ * b_dim1] * vi[j];
+ xi = xi - b[j + i__ * b_dim1] * vi[j] - b[i__ + 1 + j
+ * b_dim1] * vr[j];
+/* L230: */
+ }
+ }
+
+ w = (r__1 = b[i__ + i__ * b_dim1], dabs(r__1)) + (r__2 = b[
+ i__ + 1 + i__ * b_dim1], dabs(r__2));
+ if (w > *smlnum) {
+ if (w < 1.f) {
+ w1 = dabs(xr) + dabs(xi);
+ if (w1 > w * *bignum) {
+ rec = 1.f / w1;
+ sscal_(n, &rec, &vr[1], &c__1);
+ sscal_(n, &rec, &vi[1], &c__1);
+ xr = vr[i__];
+ xi = vi[i__];
+ scale *= rec;
+ vmax *= rec;
+ }
+ }
+
+/* Divide by diagonal element of B. */
+
+ sladiv_(&xr, &xi, &b[i__ + i__ * b_dim1], &b[i__ + 1 +
+ i__ * b_dim1], &vr[i__], &vi[i__]);
+/* Computing MAX */
+ r__3 = (r__1 = vr[i__], dabs(r__1)) + (r__2 = vi[i__],
+ dabs(r__2));
+ vmax = dmax(r__3,vmax);
+ vcrit = *bignum / vmax;
+ } else {
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+ vr[j] = 0.f;
+ vi[j] = 0.f;
+/* L240: */
+ }
+ vr[i__] = 1.f;
+ vi[i__] = 1.f;
+ scale = 0.f;
+ vmax = 1.f;
+ vcrit = *bignum;
+ }
+/* L250: */
+ }
+
+/* Test for sufficient growth in the norm of (VR,VI). */
+
+ vnorm = sasum_(n, &vr[1], &c__1) + sasum_(n, &vi[1], &c__1);
+ if (vnorm >= growto * scale) {
+ goto L280;
+ }
+
+/* Choose a new orthogonal starting vector and try again. */
+
+ y = *eps3 / (rootn + 1.f);
+ vr[1] = *eps3;
+ vi[1] = 0.f;
+
+ i__3 = *n;
+ for (i__ = 2; i__ <= i__3; ++i__) {
+ vr[i__] = y;
+ vi[i__] = 0.f;
+/* L260: */
+ }
+ vr[*n - its + 1] -= *eps3 * rootn;
+/* L270: */
+ }
+
+/* Failure to find eigenvector in N iterations */
+
+ *info = 1;
+
+L280:
+
+/* Normalize eigenvector. */
+
+ vnorm = 0.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__3 = vnorm, r__4 = (r__1 = vr[i__], dabs(r__1)) + (r__2 = vi[
+ i__], dabs(r__2));
+ vnorm = dmax(r__3,r__4);
+/* L290: */
+ }
+ r__1 = 1.f / vnorm;
+ sscal_(n, &r__1, &vr[1], &c__1);
+ r__1 = 1.f / vnorm;
+ sscal_(n, &r__1, &vi[1], &c__1);
+
+ }
+
+ return 0;
+
+/* End of SLAEIN */
+
+} /* slaein_ */
diff --git a/SRC/slaev2.c b/SRC/slaev2.c
new file mode 100644
index 0000000..290fc6e
--- /dev/null
+++ b/SRC/slaev2.c
@@ -0,0 +1,188 @@
+/* slaev2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slaev2_(real *a, real *b, real *c__, real *rt1, real *
+ rt2, real *cs1, real *sn1)
+{
+ /* System generated locals */
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real ab, df, cs, ct, tb, sm, tn, rt, adf, acs;
+ integer sgn1, sgn2;
+ real acmn, acmx;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix */
+/* [ A B ] */
+/* [ B C ]. */
+/* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the */
+/* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right */
+/* eigenvector for RT1, giving the decomposition */
+
+/* [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] */
+/* [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. */
+
+/* Arguments */
+/* ========= */
+
+/* A (input) REAL */
+/* The (1,1) element of the 2-by-2 matrix. */
+
+/* B (input) REAL */
+/* The (1,2) element and the conjugate of the (2,1) element of */
+/* the 2-by-2 matrix. */
+
+/* C (input) REAL */
+/* The (2,2) element of the 2-by-2 matrix. */
+
+/* RT1 (output) REAL */
+/* The eigenvalue of larger absolute value. */
+
+/* RT2 (output) REAL */
+/* The eigenvalue of smaller absolute value. */
+
+/* CS1 (output) REAL */
+/* SN1 (output) REAL */
+/* The vector (CS1, SN1) is a unit right eigenvector for RT1. */
+
+/* Further Details */
+/* =============== */
+
+/* RT1 is accurate to a few ulps barring over/underflow. */
+
+/* RT2 may be inaccurate if there is massive cancellation in the */
+/* determinant A*C-B*B; higher precision or correctly rounded or */
+/* correctly truncated arithmetic would be needed to compute RT2 */
+/* accurately in all cases. */
+
+/* CS1 and SN1 are accurate to a few ulps barring over/underflow. */
+
+/* Overflow is possible only if RT1 is within a factor of 5 of overflow. */
+/* Underflow is harmless if the input data is 0 or exceeds */
+/* underflow_threshold / macheps. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Compute the eigenvalues */
+
+ sm = *a + *c__;
+ df = *a - *c__;
+ adf = dabs(df);
+ tb = *b + *b;
+ ab = dabs(tb);
+ if (dabs(*a) > dabs(*c__)) {
+ acmx = *a;
+ acmn = *c__;
+ } else {
+ acmx = *c__;
+ acmn = *a;
+ }
+ if (adf > ab) {
+/* Computing 2nd power */
+ r__1 = ab / adf;
+ rt = adf * sqrt(r__1 * r__1 + 1.f);
+ } else if (adf < ab) {
+/* Computing 2nd power */
+ r__1 = adf / ab;
+ rt = ab * sqrt(r__1 * r__1 + 1.f);
+ } else {
+
+/* Includes case AB=ADF=0 */
+
+ rt = ab * sqrt(2.f);
+ }
+ if (sm < 0.f) {
+ *rt1 = (sm - rt) * .5f;
+ sgn1 = -1;
+
+/* Order of execution important. */
+/* To get fully accurate smaller eigenvalue, */
+/* next line needs to be executed in higher precision. */
+
+ *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
+ } else if (sm > 0.f) {
+ *rt1 = (sm + rt) * .5f;
+ sgn1 = 1;
+
+/* Order of execution important. */
+/* To get fully accurate smaller eigenvalue, */
+/* next line needs to be executed in higher precision. */
+
+ *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
+ } else {
+
+/* Includes case RT1 = RT2 = 0 */
+
+ *rt1 = rt * .5f;
+ *rt2 = rt * -.5f;
+ sgn1 = 1;
+ }
+
+/* Compute the eigenvector */
+
+ if (df >= 0.f) {
+ cs = df + rt;
+ sgn2 = 1;
+ } else {
+ cs = df - rt;
+ sgn2 = -1;
+ }
+ acs = dabs(cs);
+ if (acs > ab) {
+ ct = -tb / cs;
+ *sn1 = 1.f / sqrt(ct * ct + 1.f);
+ *cs1 = ct * *sn1;
+ } else {
+ if (ab == 0.f) {
+ *cs1 = 1.f;
+ *sn1 = 0.f;
+ } else {
+ tn = -cs / tb;
+ *cs1 = 1.f / sqrt(tn * tn + 1.f);
+ *sn1 = tn * *cs1;
+ }
+ }
+ if (sgn1 == sgn2) {
+ tn = *cs1;
+ *cs1 = -(*sn1);
+ *sn1 = tn;
+ }
+ return 0;
+
+/* End of SLAEV2 */
+
+} /* slaev2_ */
diff --git a/SRC/slaexc.c b/SRC/slaexc.c
new file mode 100644
index 0000000..99f6d35
--- /dev/null
+++ b/SRC/slaexc.c
@@ -0,0 +1,458 @@
+/* slaexc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__4 = 4;
+static logical c_false = FALSE_;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+
+/* Subroutine */ int slaexc_(logical *wantq, integer *n, real *t, integer *
+ ldt, real *q, integer *ldq, integer *j1, integer *n1, integer *n2,
+ real *work, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, t_dim1, t_offset, i__1;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ real d__[16] /* was [4][4] */;
+ integer k;
+ real u[3], x[4] /* was [2][2] */;
+ integer j2, j3, j4;
+ real u1[3], u2[3];
+ integer nd;
+ real cs, t11, t22, t33, sn, wi1, wi2, wr1, wr2, eps, tau, tau1, tau2;
+ integer ierr;
+ real temp;
+ extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
+ integer *, real *, real *);
+ real scale, dnorm, xnorm;
+ extern /* Subroutine */ int slanv2_(real *, real *, real *, real *, real *
+, real *, real *, real *, real *, real *), slasy2_(logical *,
+ logical *, integer *, integer *, integer *, real *, integer *,
+ real *, integer *, real *, integer *, real *, real *, integer *,
+ real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
+ real *), slacpy_(char *, integer *, integer *, real *, integer *,
+ real *, integer *), slartg_(real *, real *, real *, real *
+, real *);
+ real thresh;
+ extern /* Subroutine */ int slarfx_(char *, integer *, integer *, real *,
+ real *, real *, integer *, real *);
+ real smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in */
+/* an upper quasi-triangular matrix T by an orthogonal similarity */
+/* transformation. */
+
+/* T must be in Schur canonical form, that is, block upper triangular */
+/* with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block */
+/* has its diagonal elemnts equal and its off-diagonal elements of */
+/* opposite sign. */
+
+/* Arguments */
+/* ========= */
+
+/* WANTQ (input) LOGICAL */
+/* = .TRUE. : accumulate the transformation in the matrix Q; */
+/* = .FALSE.: do not accumulate the transformation. */
+
+/* N (input) INTEGER */
+/* The order of the matrix T. N >= 0. */
+
+/* T (input/output) REAL array, dimension (LDT,N) */
+/* On entry, the upper quasi-triangular matrix T, in Schur */
+/* canonical form. */
+/* On exit, the updated matrix T, again in Schur canonical form. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= max(1,N). */
+
+/* Q (input/output) REAL array, dimension (LDQ,N) */
+/* On entry, if WANTQ is .TRUE., the orthogonal matrix Q. */
+/* On exit, if WANTQ is .TRUE., the updated matrix Q. */
+/* If WANTQ is .FALSE., Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. */
+/* LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N. */
+
+/* J1 (input) INTEGER */
+/* The index of the first row of the first block T11. */
+
+/* N1 (input) INTEGER */
+/* The order of the first block T11. N1 = 0, 1 or 2. */
+
+/* N2 (input) INTEGER */
+/* The order of the second block T22. N2 = 0, 1 or 2. */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* = 1: the transformed matrix T would be too far from Schur */
+/* form; the blocks are not swapped and T and Q are */
+/* unchanged. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n == 0 || *n1 == 0 || *n2 == 0) {
+ return 0;
+ }
+ if (*j1 + *n1 > *n) {
+ return 0;
+ }
+
+ j2 = *j1 + 1;
+ j3 = *j1 + 2;
+ j4 = *j1 + 3;
+
+ if (*n1 == 1 && *n2 == 1) {
+
+/* Swap two 1-by-1 blocks. */
+
+ t11 = t[*j1 + *j1 * t_dim1];
+ t22 = t[j2 + j2 * t_dim1];
+
+/* Determine the transformation to perform the interchange. */
+
+ r__1 = t22 - t11;
+ slartg_(&t[*j1 + j2 * t_dim1], &r__1, &cs, &sn, &temp);
+
+/* Apply transformation to the matrix T. */
+
+ if (j3 <= *n) {
+ i__1 = *n - *j1 - 1;
+ srot_(&i__1, &t[*j1 + j3 * t_dim1], ldt, &t[j2 + j3 * t_dim1],
+ ldt, &cs, &sn);
+ }
+ i__1 = *j1 - 1;
+ srot_(&i__1, &t[*j1 * t_dim1 + 1], &c__1, &t[j2 * t_dim1 + 1], &c__1,
+ &cs, &sn);
+
+ t[*j1 + *j1 * t_dim1] = t22;
+ t[j2 + j2 * t_dim1] = t11;
+
+ if (*wantq) {
+
+/* Accumulate transformation in the matrix Q. */
+
+ srot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[j2 * q_dim1 + 1], &c__1,
+ &cs, &sn);
+ }
+
+ } else {
+
+/* Swapping involves at least one 2-by-2 block. */
+
+/* Copy the diagonal block of order N1+N2 to the local array D */
+/* and compute its norm. */
+
+ nd = *n1 + *n2;
+ slacpy_("Full", &nd, &nd, &t[*j1 + *j1 * t_dim1], ldt, d__, &c__4);
+ dnorm = slange_("Max", &nd, &nd, d__, &c__4, &work[1]);
+
+/* Compute machine-dependent threshold for test for accepting */
+/* swap. */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S") / eps;
+/* Computing MAX */
+ r__1 = eps * 10.f * dnorm;
+ thresh = dmax(r__1,smlnum);
+
+/* Solve T11*X - X*T22 = scale*T12 for X. */
+
+ slasy2_(&c_false, &c_false, &c_n1, n1, n2, d__, &c__4, &d__[*n1 + 1 +
+ (*n1 + 1 << 2) - 5], &c__4, &d__[(*n1 + 1 << 2) - 4], &c__4, &
+ scale, x, &c__2, &xnorm, &ierr);
+
+/* Swap the adjacent diagonal blocks. */
+
+ k = *n1 + *n1 + *n2 - 3;
+ switch (k) {
+ case 1: goto L10;
+ case 2: goto L20;
+ case 3: goto L30;
+ }
+
+L10:
+
+/* N1 = 1, N2 = 2: generate elementary reflector H so that: */
+
+/* ( scale, X11, X12 ) H = ( 0, 0, * ) */
+
+ u[0] = scale;
+ u[1] = x[0];
+ u[2] = x[2];
+ slarfg_(&c__3, &u[2], u, &c__1, &tau);
+ u[2] = 1.f;
+ t11 = t[*j1 + *j1 * t_dim1];
+
+/* Perform swap provisionally on diagonal block in D. */
+
+ slarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
+ slarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
+
+/* Test whether to reject swap. */
+
+/* Computing MAX */
+ r__2 = dabs(d__[2]), r__3 = dabs(d__[6]), r__2 = max(r__2,r__3), r__3
+ = (r__1 = d__[10] - t11, dabs(r__1));
+ if (dmax(r__2,r__3) > thresh) {
+ goto L50;
+ }
+
+/* Accept swap: apply transformation to the entire matrix T. */
+
+ i__1 = *n - *j1 + 1;
+ slarfx_("L", &c__3, &i__1, u, &tau, &t[*j1 + *j1 * t_dim1], ldt, &
+ work[1]);
+ slarfx_("R", &j2, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1]);
+
+ t[j3 + *j1 * t_dim1] = 0.f;
+ t[j3 + j2 * t_dim1] = 0.f;
+ t[j3 + j3 * t_dim1] = t11;
+
+ if (*wantq) {
+
+/* Accumulate transformation in the matrix Q. */
+
+ slarfx_("R", n, &c__3, u, &tau, &q[*j1 * q_dim1 + 1], ldq, &work[
+ 1]);
+ }
+ goto L40;
+
+L20:
+
+/* N1 = 2, N2 = 1: generate elementary reflector H so that: */
+
+/* H ( -X11 ) = ( * ) */
+/* ( -X21 ) = ( 0 ) */
+/* ( scale ) = ( 0 ) */
+
+ u[0] = -x[0];
+ u[1] = -x[1];
+ u[2] = scale;
+ slarfg_(&c__3, u, &u[1], &c__1, &tau);
+ u[0] = 1.f;
+ t33 = t[j3 + j3 * t_dim1];
+
+/* Perform swap provisionally on diagonal block in D. */
+
+ slarfx_("L", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
+ slarfx_("R", &c__3, &c__3, u, &tau, d__, &c__4, &work[1]);
+
+/* Test whether to reject swap. */
+
+/* Computing MAX */
+ r__2 = dabs(d__[1]), r__3 = dabs(d__[2]), r__2 = max(r__2,r__3), r__3
+ = (r__1 = d__[0] - t33, dabs(r__1));
+ if (dmax(r__2,r__3) > thresh) {
+ goto L50;
+ }
+
+/* Accept swap: apply transformation to the entire matrix T. */
+
+ slarfx_("R", &j3, &c__3, u, &tau, &t[*j1 * t_dim1 + 1], ldt, &work[1]);
+ i__1 = *n - *j1;
+ slarfx_("L", &c__3, &i__1, u, &tau, &t[*j1 + j2 * t_dim1], ldt, &work[
+ 1]);
+
+ t[*j1 + *j1 * t_dim1] = t33;
+ t[j2 + *j1 * t_dim1] = 0.f;
+ t[j3 + *j1 * t_dim1] = 0.f;
+
+ if (*wantq) {
+
+/* Accumulate transformation in the matrix Q. */
+
+ slarfx_("R", n, &c__3, u, &tau, &q[*j1 * q_dim1 + 1], ldq, &work[
+ 1]);
+ }
+ goto L40;
+
+L30:
+
+/* N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so */
+/* that: */
+
+/* H(2) H(1) ( -X11 -X12 ) = ( * * ) */
+/* ( -X21 -X22 ) ( 0 * ) */
+/* ( scale 0 ) ( 0 0 ) */
+/* ( 0 scale ) ( 0 0 ) */
+
+ u1[0] = -x[0];
+ u1[1] = -x[1];
+ u1[2] = scale;
+ slarfg_(&c__3, u1, &u1[1], &c__1, &tau1);
+ u1[0] = 1.f;
+
+ temp = -tau1 * (x[2] + u1[1] * x[3]);
+ u2[0] = -temp * u1[1] - x[3];
+ u2[1] = -temp * u1[2];
+ u2[2] = scale;
+ slarfg_(&c__3, u2, &u2[1], &c__1, &tau2);
+ u2[0] = 1.f;
+
+/* Perform swap provisionally on diagonal block in D. */
+
+ slarfx_("L", &c__3, &c__4, u1, &tau1, d__, &c__4, &work[1])
+ ;
+ slarfx_("R", &c__4, &c__3, u1, &tau1, d__, &c__4, &work[1])
+ ;
+ slarfx_("L", &c__3, &c__4, u2, &tau2, &d__[1], &c__4, &work[1]);
+ slarfx_("R", &c__4, &c__3, u2, &tau2, &d__[4], &c__4, &work[1]);
+
+/* Test whether to reject swap. */
+
+/* Computing MAX */
+ r__1 = dabs(d__[2]), r__2 = dabs(d__[6]), r__1 = max(r__1,r__2), r__2
+ = dabs(d__[3]), r__1 = max(r__1,r__2), r__2 = dabs(d__[7]);
+ if (dmax(r__1,r__2) > thresh) {
+ goto L50;
+ }
+
+/* Accept swap: apply transformation to the entire matrix T. */
+
+ i__1 = *n - *j1 + 1;
+ slarfx_("L", &c__3, &i__1, u1, &tau1, &t[*j1 + *j1 * t_dim1], ldt, &
+ work[1]);
+ slarfx_("R", &j4, &c__3, u1, &tau1, &t[*j1 * t_dim1 + 1], ldt, &work[
+ 1]);
+ i__1 = *n - *j1 + 1;
+ slarfx_("L", &c__3, &i__1, u2, &tau2, &t[j2 + *j1 * t_dim1], ldt, &
+ work[1]);
+ slarfx_("R", &j4, &c__3, u2, &tau2, &t[j2 * t_dim1 + 1], ldt, &work[1]
+);
+
+ t[j3 + *j1 * t_dim1] = 0.f;
+ t[j3 + j2 * t_dim1] = 0.f;
+ t[j4 + *j1 * t_dim1] = 0.f;
+ t[j4 + j2 * t_dim1] = 0.f;
+
+ if (*wantq) {
+
+/* Accumulate transformation in the matrix Q. */
+
+ slarfx_("R", n, &c__3, u1, &tau1, &q[*j1 * q_dim1 + 1], ldq, &
+ work[1]);
+ slarfx_("R", n, &c__3, u2, &tau2, &q[j2 * q_dim1 + 1], ldq, &work[
+ 1]);
+ }
+
+L40:
+
+ if (*n2 == 2) {
+
+/* Standardize new 2-by-2 block T11 */
+
+ slanv2_(&t[*j1 + *j1 * t_dim1], &t[*j1 + j2 * t_dim1], &t[j2 + *
+ j1 * t_dim1], &t[j2 + j2 * t_dim1], &wr1, &wi1, &wr2, &
+ wi2, &cs, &sn);
+ i__1 = *n - *j1 - 1;
+ srot_(&i__1, &t[*j1 + (*j1 + 2) * t_dim1], ldt, &t[j2 + (*j1 + 2)
+ * t_dim1], ldt, &cs, &sn);
+ i__1 = *j1 - 1;
+ srot_(&i__1, &t[*j1 * t_dim1 + 1], &c__1, &t[j2 * t_dim1 + 1], &
+ c__1, &cs, &sn);
+ if (*wantq) {
+ srot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[j2 * q_dim1 + 1], &
+ c__1, &cs, &sn);
+ }
+ }
+
+ if (*n1 == 2) {
+
+/* Standardize new 2-by-2 block T22 */
+
+ j3 = *j1 + *n2;
+ j4 = j3 + 1;
+ slanv2_(&t[j3 + j3 * t_dim1], &t[j3 + j4 * t_dim1], &t[j4 + j3 *
+ t_dim1], &t[j4 + j4 * t_dim1], &wr1, &wi1, &wr2, &wi2, &
+ cs, &sn);
+ if (j3 + 2 <= *n) {
+ i__1 = *n - j3 - 1;
+ srot_(&i__1, &t[j3 + (j3 + 2) * t_dim1], ldt, &t[j4 + (j3 + 2)
+ * t_dim1], ldt, &cs, &sn);
+ }
+ i__1 = j3 - 1;
+ srot_(&i__1, &t[j3 * t_dim1 + 1], &c__1, &t[j4 * t_dim1 + 1], &
+ c__1, &cs, &sn);
+ if (*wantq) {
+ srot_(n, &q[j3 * q_dim1 + 1], &c__1, &q[j4 * q_dim1 + 1], &
+ c__1, &cs, &sn);
+ }
+ }
+
+ }
+ return 0;
+
+/* Exit with INFO = 1 if swap was rejected. */
+
+L50:
+ *info = 1;
+ return 0;
+
+/* End of SLAEXC */
+
+} /* slaexc_ */
diff --git a/SRC/slag2.c b/SRC/slag2.c
new file mode 100644
index 0000000..02ce782
--- /dev/null
+++ b/SRC/slag2.c
@@ -0,0 +1,356 @@
+/* slag2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slag2_(real *a, integer *lda, real *b, integer *ldb,
+ real *safmin, real *scale1, real *scale2, real *wr1, real *wr2, real *
+ wi)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset;
+ real r__1, r__2, r__3, r__4, r__5, r__6;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_sign(real *, real *);
+
+ /* Local variables */
+ real r__, c1, c2, c3, c4, c5, s1, s2, a11, a12, a21, a22, b11, b12, b22,
+ pp, qq, ss, as11, as12, as22, sum, abi22, diff, bmin, wbig, wabs,
+ wdet, binv11, binv22, discr, anorm, bnorm, bsize, shift, rtmin,
+ rtmax, wsize, ascale, bscale, wscale, safmax, wsmall;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue */
+/* problem A - w B, with scaling as necessary to avoid over-/underflow. */
+
+/* The scaling factor "s" results in a modified eigenvalue equation */
+
+/* s A - w B */
+
+/* where s is a non-negative scaling factor chosen so that w, w B, */
+/* and s A do not overflow and, if possible, do not underflow, either. */
+
+/* Arguments */
+/* ========= */
+
+/* A (input) REAL array, dimension (LDA, 2) */
+/* On entry, the 2 x 2 matrix A. It is assumed that its 1-norm */
+/* is less than 1/SAFMIN. Entries less than */
+/* sqrt(SAFMIN)*norm(A) are subject to being treated as zero. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= 2. */
+
+/* B (input) REAL array, dimension (LDB, 2) */
+/* On entry, the 2 x 2 upper triangular matrix B. It is */
+/* assumed that the one-norm of B is less than 1/SAFMIN. The */
+/* diagonals should be at least sqrt(SAFMIN) times the largest */
+/* element of B (in absolute value); if a diagonal is smaller */
+/* than that, then +/- sqrt(SAFMIN) will be used instead of */
+/* that diagonal. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= 2. */
+
+/* SAFMIN (input) REAL */
+/* The smallest positive number s.t. 1/SAFMIN does not */
+/* overflow. (This should always be SLAMCH('S') -- it is an */
+/* argument in order to avoid having to call SLAMCH frequently.) */
+
+/* SCALE1 (output) REAL */
+/* A scaling factor used to avoid over-/underflow in the */
+/* eigenvalue equation which defines the first eigenvalue. If */
+/* the eigenvalues are complex, then the eigenvalues are */
+/* ( WR1 +/- WI i ) / SCALE1 (which may lie outside the */
+/* exponent range of the machine), SCALE1=SCALE2, and SCALE1 */
+/* will always be positive. If the eigenvalues are real, then */
+/* the first (real) eigenvalue is WR1 / SCALE1 , but this may */
+/* overflow or underflow, and in fact, SCALE1 may be zero or */
+/* less than the underflow threshhold if the exact eigenvalue */
+/* is sufficiently large. */
+
+/* SCALE2 (output) REAL */
+/* A scaling factor used to avoid over-/underflow in the */
+/* eigenvalue equation which defines the second eigenvalue. If */
+/* the eigenvalues are complex, then SCALE2=SCALE1. If the */
+/* eigenvalues are real, then the second (real) eigenvalue is */
+/* WR2 / SCALE2 , but this may overflow or underflow, and in */
+/* fact, SCALE2 may be zero or less than the underflow */
+/* threshhold if the exact eigenvalue is sufficiently large. */
+
+/* WR1 (output) REAL */
+/* If the eigenvalue is real, then WR1 is SCALE1 times the */
+/* eigenvalue closest to the (2,2) element of A B**(-1). If the */
+/* eigenvalue is complex, then WR1=WR2 is SCALE1 times the real */
+/* part of the eigenvalues. */
+
+/* WR2 (output) REAL */
+/* If the eigenvalue is real, then WR2 is SCALE2 times the */
+/* other eigenvalue. If the eigenvalue is complex, then */
+/* WR1=WR2 is SCALE1 times the real part of the eigenvalues. */
+
+/* WI (output) REAL */
+/* If the eigenvalue is real, then WI is zero. If the */
+/* eigenvalue is complex, then WI is SCALE1 times the imaginary */
+/* part of the eigenvalues. WI will always be non-negative. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ rtmin = sqrt(*safmin);
+ rtmax = 1.f / rtmin;
+ safmax = 1.f / *safmin;
+
+/* Scale A */
+
+/* Computing MAX */
+ r__5 = (r__1 = a[a_dim1 + 1], dabs(r__1)) + (r__2 = a[a_dim1 + 2], dabs(
+ r__2)), r__6 = (r__3 = a[(a_dim1 << 1) + 1], dabs(r__3)) + (r__4 =
+ a[(a_dim1 << 1) + 2], dabs(r__4)), r__5 = max(r__5,r__6);
+ anorm = dmax(r__5,*safmin);
+ ascale = 1.f / anorm;
+ a11 = ascale * a[a_dim1 + 1];
+ a21 = ascale * a[a_dim1 + 2];
+ a12 = ascale * a[(a_dim1 << 1) + 1];
+ a22 = ascale * a[(a_dim1 << 1) + 2];
+
+/* Perturb B if necessary to insure non-singularity */
+
+ b11 = b[b_dim1 + 1];
+ b12 = b[(b_dim1 << 1) + 1];
+ b22 = b[(b_dim1 << 1) + 2];
+/* Computing MAX */
+ r__1 = dabs(b11), r__2 = dabs(b12), r__1 = max(r__1,r__2), r__2 = dabs(
+ b22), r__1 = max(r__1,r__2);
+ bmin = rtmin * dmax(r__1,rtmin);
+ if (dabs(b11) < bmin) {
+ b11 = r_sign(&bmin, &b11);
+ }
+ if (dabs(b22) < bmin) {
+ b22 = r_sign(&bmin, &b22);
+ }
+
+/* Scale B */
+
+/* Computing MAX */
+ r__1 = dabs(b11), r__2 = dabs(b12) + dabs(b22), r__1 = max(r__1,r__2);
+ bnorm = dmax(r__1,*safmin);
+/* Computing MAX */
+ r__1 = dabs(b11), r__2 = dabs(b22);
+ bsize = dmax(r__1,r__2);
+ bscale = 1.f / bsize;
+ b11 *= bscale;
+ b12 *= bscale;
+ b22 *= bscale;
+
+/* Compute larger eigenvalue by method described by C. van Loan */
+
+/* ( AS is A shifted by -SHIFT*B ) */
+
+ binv11 = 1.f / b11;
+ binv22 = 1.f / b22;
+ s1 = a11 * binv11;
+ s2 = a22 * binv22;
+ if (dabs(s1) <= dabs(s2)) {
+ as12 = a12 - s1 * b12;
+ as22 = a22 - s1 * b22;
+ ss = a21 * (binv11 * binv22);
+ abi22 = as22 * binv22 - ss * b12;
+ pp = abi22 * .5f;
+ shift = s1;
+ } else {
+ as12 = a12 - s2 * b12;
+ as11 = a11 - s2 * b11;
+ ss = a21 * (binv11 * binv22);
+ abi22 = -ss * b12;
+ pp = (as11 * binv11 + abi22) * .5f;
+ shift = s2;
+ }
+ qq = ss * as12;
+ if ((r__1 = pp * rtmin, dabs(r__1)) >= 1.f) {
+/* Computing 2nd power */
+ r__1 = rtmin * pp;
+ discr = r__1 * r__1 + qq * *safmin;
+ r__ = sqrt((dabs(discr))) * rtmax;
+ } else {
+/* Computing 2nd power */
+ r__1 = pp;
+ if (r__1 * r__1 + dabs(qq) <= *safmin) {
+/* Computing 2nd power */
+ r__1 = rtmax * pp;
+ discr = r__1 * r__1 + qq * safmax;
+ r__ = sqrt((dabs(discr))) * rtmin;
+ } else {
+/* Computing 2nd power */
+ r__1 = pp;
+ discr = r__1 * r__1 + qq;
+ r__ = sqrt((dabs(discr)));
+ }
+ }
+
+/* Note: the test of R in the following IF is to cover the case when */
+/* DISCR is small and negative and is flushed to zero during */
+/* the calculation of R. On machines which have a consistent */
+/* flush-to-zero threshhold and handle numbers above that */
+/* threshhold correctly, it would not be necessary. */
+
+ if (discr >= 0.f || r__ == 0.f) {
+ sum = pp + r_sign(&r__, &pp);
+ diff = pp - r_sign(&r__, &pp);
+ wbig = shift + sum;
+
+/* Compute smaller eigenvalue */
+
+ wsmall = shift + diff;
+/* Computing MAX */
+ r__1 = dabs(wsmall);
+ if (dabs(wbig) * .5f > dmax(r__1,*safmin)) {
+ wdet = (a11 * a22 - a12 * a21) * (binv11 * binv22);
+ wsmall = wdet / wbig;
+ }
+
+/* Choose (real) eigenvalue closest to 2,2 element of A*B**(-1) */
+/* for WR1. */
+
+ if (pp > abi22) {
+ *wr1 = dmin(wbig,wsmall);
+ *wr2 = dmax(wbig,wsmall);
+ } else {
+ *wr1 = dmax(wbig,wsmall);
+ *wr2 = dmin(wbig,wsmall);
+ }
+ *wi = 0.f;
+ } else {
+
+/* Complex eigenvalues */
+
+ *wr1 = shift + pp;
+ *wr2 = *wr1;
+ *wi = r__;
+ }
+
+/* Further scaling to avoid underflow and overflow in computing */
+/* SCALE1 and overflow in computing w*B. */
+
+/* This scale factor (WSCALE) is bounded from above using C1 and C2, */
+/* and from below using C3 and C4. */
+/* C1 implements the condition s A must never overflow. */
+/* C2 implements the condition w B must never overflow. */
+/* C3, with C2, */
+/* implement the condition that s A - w B must never overflow. */
+/* C4 implements the condition s should not underflow. */
+/* C5 implements the condition max(s,|w|) should be at least 2. */
+
+ c1 = bsize * (*safmin * dmax(1.f,ascale));
+ c2 = *safmin * dmax(1.f,bnorm);
+ c3 = bsize * *safmin;
+ if (ascale <= 1.f && bsize <= 1.f) {
+/* Computing MIN */
+ r__1 = 1.f, r__2 = ascale / *safmin * bsize;
+ c4 = dmin(r__1,r__2);
+ } else {
+ c4 = 1.f;
+ }
+ if (ascale <= 1.f || bsize <= 1.f) {
+/* Computing MIN */
+ r__1 = 1.f, r__2 = ascale * bsize;
+ c5 = dmin(r__1,r__2);
+ } else {
+ c5 = 1.f;
+ }
+
+/* Scale first eigenvalue */
+
+ wabs = dabs(*wr1) + dabs(*wi);
+/* Computing MAX */
+/* Computing MIN */
+ r__3 = c4, r__4 = dmax(wabs,c5) * .5f;
+ r__1 = max(*safmin,c1), r__2 = (wabs * c2 + c3) * 1.0000100000000001f,
+ r__1 = max(r__1,r__2), r__2 = dmin(r__3,r__4);
+ wsize = dmax(r__1,r__2);
+ if (wsize != 1.f) {
+ wscale = 1.f / wsize;
+ if (wsize > 1.f) {
+ *scale1 = dmax(ascale,bsize) * wscale * dmin(ascale,bsize);
+ } else {
+ *scale1 = dmin(ascale,bsize) * wscale * dmax(ascale,bsize);
+ }
+ *wr1 *= wscale;
+ if (*wi != 0.f) {
+ *wi *= wscale;
+ *wr2 = *wr1;
+ *scale2 = *scale1;
+ }
+ } else {
+ *scale1 = ascale * bsize;
+ *scale2 = *scale1;
+ }
+
+/* Scale second eigenvalue (if real) */
+
+ if (*wi == 0.f) {
+/* Computing MAX */
+/* Computing MIN */
+/* Computing MAX */
+ r__5 = dabs(*wr2);
+ r__3 = c4, r__4 = dmax(r__5,c5) * .5f;
+ r__1 = max(*safmin,c1), r__2 = (dabs(*wr2) * c2 + c3) *
+ 1.0000100000000001f, r__1 = max(r__1,r__2), r__2 = dmin(r__3,
+ r__4);
+ wsize = dmax(r__1,r__2);
+ if (wsize != 1.f) {
+ wscale = 1.f / wsize;
+ if (wsize > 1.f) {
+ *scale2 = dmax(ascale,bsize) * wscale * dmin(ascale,bsize);
+ } else {
+ *scale2 = dmin(ascale,bsize) * wscale * dmax(ascale,bsize);
+ }
+ *wr2 *= wscale;
+ } else {
+ *scale2 = ascale * bsize;
+ }
+ }
+
+/* End of SLAG2 */
+
+ return 0;
+} /* slag2_ */
diff --git a/SRC/slag2d.c b/SRC/slag2d.c
new file mode 100644
index 0000000..81ae9c3
--- /dev/null
+++ b/SRC/slag2d.c
@@ -0,0 +1,100 @@
+/* slag2d.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slag2d_(integer *m, integer *n, real *sa, integer *ldsa,
+ doublereal *a, integer *lda, integer *info)
+{
+ /* System generated locals */
+ integer sa_dim1, sa_offset, a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+
+
+/* -- LAPACK PROTOTYPE auxiliary routine (version 3.1.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* August 2007 */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAG2D converts a SINGLE PRECISION matrix, SA, to a DOUBLE */
+/* PRECISION matrix, A. */
+
+/* Note that while it is possible to overflow while converting */
+/* from double to single, it is not possible to overflow when */
+/* converting from single to double. */
+
+/* This is an auxiliary routine so there is no argument checking. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of lines of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* SA (input) REAL array, dimension (LDSA,N) */
+/* On entry, the M-by-N coefficient matrix SA. */
+
+/* LDSA (input) INTEGER */
+/* The leading dimension of the array SA. LDSA >= max(1,M). */
+
+/* A (output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On exit, the M-by-N coefficient matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* ========= */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ sa_dim1 = *ldsa;
+ sa_offset = 1 + sa_dim1;
+ sa -= sa_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = sa[i__ + j * sa_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+ return 0;
+
+/* End of SLAG2D */
+
+} /* slag2d_ */
diff --git a/SRC/slags2.c b/SRC/slags2.c
new file mode 100644
index 0000000..bcd0c91
--- /dev/null
+++ b/SRC/slags2.c
@@ -0,0 +1,290 @@
+/* slags2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slags2_(logical *upper, real *a1, real *a2, real *a3,
+ real *b1, real *b2, real *b3, real *csu, real *snu, real *csv, real *
+ snv, real *csq, real *snq)
+{
+ /* System generated locals */
+ real r__1;
+
+ /* Local variables */
+ real a, b, c__, d__, r__, s1, s2, ua11, ua12, ua21, ua22, vb11, vb12,
+ vb21, vb22, csl, csr, snl, snr, aua11, aua12, aua21, aua22, avb11,
+ avb12, avb21, avb22, ua11r, ua22r, vb11r, vb22r;
+ extern /* Subroutine */ int slasv2_(real *, real *, real *, real *, real *
+, real *, real *, real *, real *), slartg_(real *, real *, real *,
+ real *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such */
+/* that if ( UPPER ) then */
+
+/* U'*A*Q = U'*( A1 A2 )*Q = ( x 0 ) */
+/* ( 0 A3 ) ( x x ) */
+/* and */
+/* V'*B*Q = V'*( B1 B2 )*Q = ( x 0 ) */
+/* ( 0 B3 ) ( x x ) */
+
+/* or if ( .NOT.UPPER ) then */
+
+/* U'*A*Q = U'*( A1 0 )*Q = ( x x ) */
+/* ( A2 A3 ) ( 0 x ) */
+/* and */
+/* V'*B*Q = V'*( B1 0 )*Q = ( x x ) */
+/* ( B2 B3 ) ( 0 x ) */
+
+/* The rows of the transformed A and B are parallel, where */
+
+/* U = ( CSU SNU ), V = ( CSV SNV ), Q = ( CSQ SNQ ) */
+/* ( -SNU CSU ) ( -SNV CSV ) ( -SNQ CSQ ) */
+
+/* Z' denotes the transpose of Z. */
+
+
+/* Arguments */
+/* ========= */
+
+/* UPPER (input) LOGICAL */
+/* = .TRUE.: the input matrices A and B are upper triangular. */
+/* = .FALSE.: the input matrices A and B are lower triangular. */
+
+/* A1 (input) REAL */
+/* A2 (input) REAL */
+/* A3 (input) REAL */
+/* On entry, A1, A2 and A3 are elements of the input 2-by-2 */
+/* upper (lower) triangular matrix A. */
+
+/* B1 (input) REAL */
+/* B2 (input) REAL */
+/* B3 (input) REAL */
+/* On entry, B1, B2 and B3 are elements of the input 2-by-2 */
+/* upper (lower) triangular matrix B. */
+
+/* CSU (output) REAL */
+/* SNU (output) REAL */
+/* The desired orthogonal matrix U. */
+
+/* CSV (output) REAL */
+/* SNV (output) REAL */
+/* The desired orthogonal matrix V. */
+
+/* CSQ (output) REAL */
+/* SNQ (output) REAL */
+/* The desired orthogonal matrix Q. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (*upper) {
+
+/* Input matrices A and B are upper triangular matrices */
+
+/* Form matrix C = A*adj(B) = ( a b ) */
+/* ( 0 d ) */
+
+ a = *a1 * *b3;
+ d__ = *a3 * *b1;
+ b = *a2 * *b1 - *a1 * *b2;
+
+/* The SVD of real 2-by-2 triangular C */
+
+/* ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 ) */
+/* ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T ) */
+
+ slasv2_(&a, &b, &d__, &s1, &s2, &snr, &csr, &snl, &csl);
+
+ if (dabs(csl) >= dabs(snl) || dabs(csr) >= dabs(snr)) {
+
+/* Compute the (1,1) and (1,2) elements of U'*A and V'*B, */
+/* and (1,2) element of |U|'*|A| and |V|'*|B|. */
+
+ ua11r = csl * *a1;
+ ua12 = csl * *a2 + snl * *a3;
+
+ vb11r = csr * *b1;
+ vb12 = csr * *b2 + snr * *b3;
+
+ aua12 = dabs(csl) * dabs(*a2) + dabs(snl) * dabs(*a3);
+ avb12 = dabs(csr) * dabs(*b2) + dabs(snr) * dabs(*b3);
+
+/* zero (1,2) elements of U'*A and V'*B */
+
+ if (dabs(ua11r) + dabs(ua12) != 0.f) {
+ if (aua12 / (dabs(ua11r) + dabs(ua12)) <= avb12 / (dabs(vb11r)
+ + dabs(vb12))) {
+ r__1 = -ua11r;
+ slartg_(&r__1, &ua12, csq, snq, &r__);
+ } else {
+ r__1 = -vb11r;
+ slartg_(&r__1, &vb12, csq, snq, &r__);
+ }
+ } else {
+ r__1 = -vb11r;
+ slartg_(&r__1, &vb12, csq, snq, &r__);
+ }
+
+ *csu = csl;
+ *snu = -snl;
+ *csv = csr;
+ *snv = -snr;
+
+ } else {
+
+/* Compute the (2,1) and (2,2) elements of U'*A and V'*B, */
+/* and (2,2) element of |U|'*|A| and |V|'*|B|. */
+
+ ua21 = -snl * *a1;
+ ua22 = -snl * *a2 + csl * *a3;
+
+ vb21 = -snr * *b1;
+ vb22 = -snr * *b2 + csr * *b3;
+
+ aua22 = dabs(snl) * dabs(*a2) + dabs(csl) * dabs(*a3);
+ avb22 = dabs(snr) * dabs(*b2) + dabs(csr) * dabs(*b3);
+
+/* zero (2,2) elements of U'*A and V'*B, and then swap. */
+
+ if (dabs(ua21) + dabs(ua22) != 0.f) {
+ if (aua22 / (dabs(ua21) + dabs(ua22)) <= avb22 / (dabs(vb21)
+ + dabs(vb22))) {
+ r__1 = -ua21;
+ slartg_(&r__1, &ua22, csq, snq, &r__);
+ } else {
+ r__1 = -vb21;
+ slartg_(&r__1, &vb22, csq, snq, &r__);
+ }
+ } else {
+ r__1 = -vb21;
+ slartg_(&r__1, &vb22, csq, snq, &r__);
+ }
+
+ *csu = snl;
+ *snu = csl;
+ *csv = snr;
+ *snv = csr;
+
+ }
+
+ } else {
+
+/* Input matrices A and B are lower triangular matrices */
+
+/* Form matrix C = A*adj(B) = ( a 0 ) */
+/* ( c d ) */
+
+ a = *a1 * *b3;
+ d__ = *a3 * *b1;
+ c__ = *a2 * *b3 - *a3 * *b2;
+
+/* The SVD of real 2-by-2 triangular C */
+
+/* ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 ) */
+/* ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T ) */
+
+ slasv2_(&a, &c__, &d__, &s1, &s2, &snr, &csr, &snl, &csl);
+
+ if (dabs(csr) >= dabs(snr) || dabs(csl) >= dabs(snl)) {
+
+/* Compute the (2,1) and (2,2) elements of U'*A and V'*B, */
+/* and (2,1) element of |U|'*|A| and |V|'*|B|. */
+
+ ua21 = -snr * *a1 + csr * *a2;
+ ua22r = csr * *a3;
+
+ vb21 = -snl * *b1 + csl * *b2;
+ vb22r = csl * *b3;
+
+ aua21 = dabs(snr) * dabs(*a1) + dabs(csr) * dabs(*a2);
+ avb21 = dabs(snl) * dabs(*b1) + dabs(csl) * dabs(*b2);
+
+/* zero (2,1) elements of U'*A and V'*B. */
+
+ if (dabs(ua21) + dabs(ua22r) != 0.f) {
+ if (aua21 / (dabs(ua21) + dabs(ua22r)) <= avb21 / (dabs(vb21)
+ + dabs(vb22r))) {
+ slartg_(&ua22r, &ua21, csq, snq, &r__);
+ } else {
+ slartg_(&vb22r, &vb21, csq, snq, &r__);
+ }
+ } else {
+ slartg_(&vb22r, &vb21, csq, snq, &r__);
+ }
+
+ *csu = csr;
+ *snu = -snr;
+ *csv = csl;
+ *snv = -snl;
+
+ } else {
+
+/* Compute the (1,1) and (1,2) elements of U'*A and V'*B, */
+/* and (1,1) element of |U|'*|A| and |V|'*|B|. */
+
+ ua11 = csr * *a1 + snr * *a2;
+ ua12 = snr * *a3;
+
+ vb11 = csl * *b1 + snl * *b2;
+ vb12 = snl * *b3;
+
+ aua11 = dabs(csr) * dabs(*a1) + dabs(snr) * dabs(*a2);
+ avb11 = dabs(csl) * dabs(*b1) + dabs(snl) * dabs(*b2);
+
+/* zero (1,1) elements of U'*A and V'*B, and then swap. */
+
+ if (dabs(ua11) + dabs(ua12) != 0.f) {
+ if (aua11 / (dabs(ua11) + dabs(ua12)) <= avb11 / (dabs(vb11)
+ + dabs(vb12))) {
+ slartg_(&ua12, &ua11, csq, snq, &r__);
+ } else {
+ slartg_(&vb12, &vb11, csq, snq, &r__);
+ }
+ } else {
+ slartg_(&vb12, &vb11, csq, snq, &r__);
+ }
+
+ *csu = snr;
+ *snu = csr;
+ *csv = snl;
+ *snv = csl;
+
+ }
+
+ }
+
+ return 0;
+
+/* End of SLAGS2 */
+
+} /* slags2_ */
diff --git a/SRC/slagtf.c b/SRC/slagtf.c
new file mode 100644
index 0000000..9046c23
--- /dev/null
+++ b/SRC/slagtf.c
@@ -0,0 +1,223 @@
+/* slagtf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slagtf_(integer *n, real *a, real *lambda, real *b, real
+ *c__, real *tol, real *d__, integer *in, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer k;
+ real tl, eps, piv1, piv2, temp, mult, scale1, scale2;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAGTF factorizes the matrix (T - lambda*I), where T is an n by n */
+/* tridiagonal matrix and lambda is a scalar, as */
+
+/* T - lambda*I = PLU, */
+
+/* where P is a permutation matrix, L is a unit lower tridiagonal matrix */
+/* with at most one non-zero sub-diagonal elements per column and U is */
+/* an upper triangular matrix with at most two non-zero super-diagonal */
+/* elements per column. */
+
+/* The factorization is obtained by Gaussian elimination with partial */
+/* pivoting and implicit row scaling. */
+
+/* The parameter LAMBDA is included in the routine so that SLAGTF may */
+/* be used, in conjunction with SLAGTS, to obtain eigenvectors of T by */
+/* inverse iteration. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix T. */
+
+/* A (input/output) REAL array, dimension (N) */
+/* On entry, A must contain the diagonal elements of T. */
+
+/* On exit, A is overwritten by the n diagonal elements of the */
+/* upper triangular matrix U of the factorization of T. */
+
+/* LAMBDA (input) REAL */
+/* On entry, the scalar lambda. */
+
+/* B (input/output) REAL array, dimension (N-1) */
+/* On entry, B must contain the (n-1) super-diagonal elements of */
+/* T. */
+
+/* On exit, B is overwritten by the (n-1) super-diagonal */
+/* elements of the matrix U of the factorization of T. */
+
+/* C (input/output) REAL array, dimension (N-1) */
+/* On entry, C must contain the (n-1) sub-diagonal elements of */
+/* T. */
+
+/* On exit, C is overwritten by the (n-1) sub-diagonal elements */
+/* of the matrix L of the factorization of T. */
+
+/* TOL (input) REAL */
+/* On entry, a relative tolerance used to indicate whether or */
+/* not the matrix (T - lambda*I) is nearly singular. TOL should */
+/* normally be chose as approximately the largest relative error */
+/* in the elements of T. For example, if the elements of T are */
+/* correct to about 4 significant figures, then TOL should be */
+/* set to about 5*10**(-4). If TOL is supplied as less than eps, */
+/* where eps is the relative machine precision, then the value */
+/* eps is used in place of TOL. */
+
+/* D (output) REAL array, dimension (N-2) */
+/* On exit, D is overwritten by the (n-2) second super-diagonal */
+/* elements of the matrix U of the factorization of T. */
+
+/* IN (output) INTEGER array, dimension (N) */
+/* On exit, IN contains details of the permutation matrix P. If */
+/* an interchange occurred at the kth step of the elimination, */
+/* then IN(k) = 1, otherwise IN(k) = 0. The element IN(n) */
+/* returns the smallest positive integer j such that */
+
+/* abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL, */
+
+/* where norm( A(j) ) denotes the sum of the absolute values of */
+/* the jth row of the matrix A. If no such j exists then IN(n) */
+/* is returned as zero. If IN(n) is returned as positive, then a */
+/* diagonal element of U is small, indicating that */
+/* (T - lambda*I) is singular or nearly singular, */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit */
+/* .lt. 0: if INFO = -k, the kth argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --in;
+ --d__;
+ --c__;
+ --b;
+ --a;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ i__1 = -(*info);
+ xerbla_("SLAGTF", &i__1);
+ return 0;
+ }
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ a[1] -= *lambda;
+ in[*n] = 0;
+ if (*n == 1) {
+ if (a[1] == 0.f) {
+ in[1] = 1;
+ }
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+
+ tl = dmax(*tol,eps);
+ scale1 = dabs(a[1]) + dabs(b[1]);
+ i__1 = *n - 1;
+ for (k = 1; k <= i__1; ++k) {
+ a[k + 1] -= *lambda;
+ scale2 = (r__1 = c__[k], dabs(r__1)) + (r__2 = a[k + 1], dabs(r__2));
+ if (k < *n - 1) {
+ scale2 += (r__1 = b[k + 1], dabs(r__1));
+ }
+ if (a[k] == 0.f) {
+ piv1 = 0.f;
+ } else {
+ piv1 = (r__1 = a[k], dabs(r__1)) / scale1;
+ }
+ if (c__[k] == 0.f) {
+ in[k] = 0;
+ piv2 = 0.f;
+ scale1 = scale2;
+ if (k < *n - 1) {
+ d__[k] = 0.f;
+ }
+ } else {
+ piv2 = (r__1 = c__[k], dabs(r__1)) / scale2;
+ if (piv2 <= piv1) {
+ in[k] = 0;
+ scale1 = scale2;
+ c__[k] /= a[k];
+ a[k + 1] -= c__[k] * b[k];
+ if (k < *n - 1) {
+ d__[k] = 0.f;
+ }
+ } else {
+ in[k] = 1;
+ mult = a[k] / c__[k];
+ a[k] = c__[k];
+ temp = a[k + 1];
+ a[k + 1] = b[k] - mult * temp;
+ if (k < *n - 1) {
+ d__[k] = b[k + 1];
+ b[k + 1] = -mult * d__[k];
+ }
+ b[k] = temp;
+ c__[k] = mult;
+ }
+ }
+ if (dmax(piv1,piv2) <= tl && in[*n] == 0) {
+ in[*n] = k;
+ }
+/* L10: */
+ }
+ if ((r__1 = a[*n], dabs(r__1)) <= scale1 * tl && in[*n] == 0) {
+ in[*n] = *n;
+ }
+
+ return 0;
+
+/* End of SLAGTF */
+
+} /* slagtf_ */
diff --git a/SRC/slagtm.c b/SRC/slagtm.c
new file mode 100644
index 0000000..8018ebc
--- /dev/null
+++ b/SRC/slagtm.c
@@ -0,0 +1,253 @@
+/* slagtm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slagtm_(char *trans, integer *n, integer *nrhs, real *
+ alpha, real *dl, real *d__, real *du, real *x, integer *ldx, real *
+ beta, real *b, integer *ldb)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ extern logical lsame_(char *, char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAGTM performs a matrix-vector product of the form */
+
+/* B := alpha * A * X + beta * B */
+
+/* where A is a tridiagonal matrix of order N, B and X are N by NRHS */
+/* matrices, and alpha and beta are real scalars, each of which may be */
+/* 0., 1., or -1. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': No transpose, B := alpha * A * X + beta * B */
+/* = 'T': Transpose, B := alpha * A'* X + beta * B */
+/* = 'C': Conjugate transpose = Transpose */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. */
+
+/* ALPHA (input) REAL */
+/* The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise, */
+/* it is assumed to be 0. */
+
+/* DL (input) REAL array, dimension (N-1) */
+/* The (n-1) sub-diagonal elements of T. */
+
+/* D (input) REAL array, dimension (N) */
+/* The diagonal elements of T. */
+
+/* DU (input) REAL array, dimension (N-1) */
+/* The (n-1) super-diagonal elements of T. */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The N by NRHS matrix X. */
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(N,1). */
+
+/* BETA (input) REAL */
+/* The scalar beta. BETA must be 0., 1., or -1.; otherwise, */
+/* it is assumed to be 1. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the N by NRHS matrix B. */
+/* On exit, B is overwritten by the matrix expression */
+/* B := alpha * A * X + beta * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(N,1). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Multiply B by BETA if BETA.NE.1. */
+
+ if (*beta == 0.f) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (*beta == -1.f) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = -b[i__ + j * b_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+ if (*alpha == 1.f) {
+ if (lsame_(trans, "N")) {
+
+/* Compute B := B + A*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ b[j * b_dim1 + 1] += d__[1] * x[j * x_dim1 + 1];
+ } else {
+ b[j * b_dim1 + 1] = b[j * b_dim1 + 1] + d__[1] * x[j *
+ x_dim1 + 1] + du[1] * x[j * x_dim1 + 2];
+ b[*n + j * b_dim1] = b[*n + j * b_dim1] + dl[*n - 1] * x[*
+ n - 1 + j * x_dim1] + d__[*n] * x[*n + j * x_dim1]
+ ;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = b[i__ + j * b_dim1] + dl[i__ -
+ 1] * x[i__ - 1 + j * x_dim1] + d__[i__] * x[
+ i__ + j * x_dim1] + du[i__] * x[i__ + 1 + j *
+ x_dim1];
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else {
+
+/* Compute B := B + A'*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ b[j * b_dim1 + 1] += d__[1] * x[j * x_dim1 + 1];
+ } else {
+ b[j * b_dim1 + 1] = b[j * b_dim1 + 1] + d__[1] * x[j *
+ x_dim1 + 1] + dl[1] * x[j * x_dim1 + 2];
+ b[*n + j * b_dim1] = b[*n + j * b_dim1] + du[*n - 1] * x[*
+ n - 1 + j * x_dim1] + d__[*n] * x[*n + j * x_dim1]
+ ;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = b[i__ + j * b_dim1] + du[i__ -
+ 1] * x[i__ - 1 + j * x_dim1] + d__[i__] * x[
+ i__ + j * x_dim1] + dl[i__] * x[i__ + 1 + j *
+ x_dim1];
+/* L70: */
+ }
+ }
+/* L80: */
+ }
+ }
+ } else if (*alpha == -1.f) {
+ if (lsame_(trans, "N")) {
+
+/* Compute B := B - A*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ b[j * b_dim1 + 1] -= d__[1] * x[j * x_dim1 + 1];
+ } else {
+ b[j * b_dim1 + 1] = b[j * b_dim1 + 1] - d__[1] * x[j *
+ x_dim1 + 1] - du[1] * x[j * x_dim1 + 2];
+ b[*n + j * b_dim1] = b[*n + j * b_dim1] - dl[*n - 1] * x[*
+ n - 1 + j * x_dim1] - d__[*n] * x[*n + j * x_dim1]
+ ;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = b[i__ + j * b_dim1] - dl[i__ -
+ 1] * x[i__ - 1 + j * x_dim1] - d__[i__] * x[
+ i__ + j * x_dim1] - du[i__] * x[i__ + 1 + j *
+ x_dim1];
+/* L90: */
+ }
+ }
+/* L100: */
+ }
+ } else {
+
+/* Compute B := B - A'*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ b[j * b_dim1 + 1] -= d__[1] * x[j * x_dim1 + 1];
+ } else {
+ b[j * b_dim1 + 1] = b[j * b_dim1 + 1] - d__[1] * x[j *
+ x_dim1 + 1] - dl[1] * x[j * x_dim1 + 2];
+ b[*n + j * b_dim1] = b[*n + j * b_dim1] - du[*n - 1] * x[*
+ n - 1 + j * x_dim1] - d__[*n] * x[*n + j * x_dim1]
+ ;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = b[i__ + j * b_dim1] - du[i__ -
+ 1] * x[i__ - 1 + j * x_dim1] - d__[i__] * x[
+ i__ + j * x_dim1] - dl[i__] * x[i__ + 1 + j *
+ x_dim1];
+/* L110: */
+ }
+ }
+/* L120: */
+ }
+ }
+ }
+ return 0;
+
+/* End of SLAGTM */
+
+} /* slagtm_ */
diff --git a/SRC/slagts.c b/SRC/slagts.c
new file mode 100644
index 0000000..dc828f8
--- /dev/null
+++ b/SRC/slagts.c
@@ -0,0 +1,351 @@
+/* slagts.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slagts_(integer *job, integer *n, real *a, real *b, real
+ *c__, real *d__, integer *in, real *y, real *tol, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2, r__3, r__4, r__5;
+
+ /* Builtin functions */
+ double r_sign(real *, real *);
+
+ /* Local variables */
+ integer k;
+ real ak, eps, temp, pert, absak, sfmin;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAGTS may be used to solve one of the systems of equations */
+
+/* (T - lambda*I)*x = y or (T - lambda*I)'*x = y, */
+
+/* where T is an n by n tridiagonal matrix, for x, following the */
+/* factorization of (T - lambda*I) as */
+
+/* (T - lambda*I) = P*L*U , */
+
+/* by routine SLAGTF. The choice of equation to be solved is */
+/* controlled by the argument JOB, and in each case there is an option */
+/* to perturb zero or very small diagonal elements of U, this option */
+/* being intended for use in applications such as inverse iteration. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) INTEGER */
+/* Specifies the job to be performed by SLAGTS as follows: */
+/* = 1: The equations (T - lambda*I)x = y are to be solved, */
+/* but diagonal elements of U are not to be perturbed. */
+/* = -1: The equations (T - lambda*I)x = y are to be solved */
+/* and, if overflow would otherwise occur, the diagonal */
+/* elements of U are to be perturbed. See argument TOL */
+/* below. */
+/* = 2: The equations (T - lambda*I)'x = y are to be solved, */
+/* but diagonal elements of U are not to be perturbed. */
+/* = -2: The equations (T - lambda*I)'x = y are to be solved */
+/* and, if overflow would otherwise occur, the diagonal */
+/* elements of U are to be perturbed. See argument TOL */
+/* below. */
+
+/* N (input) INTEGER */
+/* The order of the matrix T. */
+
+/* A (input) REAL array, dimension (N) */
+/* On entry, A must contain the diagonal elements of U as */
+/* returned from SLAGTF. */
+
+/* B (input) REAL array, dimension (N-1) */
+/* On entry, B must contain the first super-diagonal elements of */
+/* U as returned from SLAGTF. */
+
+/* C (input) REAL array, dimension (N-1) */
+/* On entry, C must contain the sub-diagonal elements of L as */
+/* returned from SLAGTF. */
+
+/* D (input) REAL array, dimension (N-2) */
+/* On entry, D must contain the second super-diagonal elements */
+/* of U as returned from SLAGTF. */
+
+/* IN (input) INTEGER array, dimension (N) */
+/* On entry, IN must contain details of the matrix P as returned */
+/* from SLAGTF. */
+
+/* Y (input/output) REAL array, dimension (N) */
+/* On entry, the right hand side vector y. */
+/* On exit, Y is overwritten by the solution vector x. */
+
+/* TOL (input/output) REAL */
+/* On entry, with JOB .lt. 0, TOL should be the minimum */
+/* perturbation to be made to very small diagonal elements of U. */
+/* TOL should normally be chosen as about eps*norm(U), where eps */
+/* is the relative machine precision, but if TOL is supplied as */
+/* non-positive, then it is reset to eps*max( abs( u(i,j) ) ). */
+/* If JOB .gt. 0 then TOL is not referenced. */
+
+/* On exit, TOL is changed as described above, only if TOL is */
+/* non-positive on entry. Otherwise TOL is unchanged. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit */
+/* .lt. 0: if INFO = -i, the i-th argument had an illegal value */
+/* .gt. 0: overflow would occur when computing the INFO(th) */
+/* element of the solution vector x. This can only occur */
+/* when JOB is supplied as positive and either means */
+/* that a diagonal element of U is very small, or that */
+/* the elements of the right-hand side vector y are very */
+/* large. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --y;
+ --in;
+ --d__;
+ --c__;
+ --b;
+ --a;
+
+ /* Function Body */
+ *info = 0;
+ if (abs(*job) > 2 || *job == 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLAGTS", &i__1);
+ return 0;
+ }
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+ sfmin = slamch_("Safe minimum");
+ bignum = 1.f / sfmin;
+
+ if (*job < 0) {
+ if (*tol <= 0.f) {
+ *tol = dabs(a[1]);
+ if (*n > 1) {
+/* Computing MAX */
+ r__1 = *tol, r__2 = dabs(a[2]), r__1 = max(r__1,r__2), r__2 =
+ dabs(b[1]);
+ *tol = dmax(r__1,r__2);
+ }
+ i__1 = *n;
+ for (k = 3; k <= i__1; ++k) {
+/* Computing MAX */
+ r__4 = *tol, r__5 = (r__1 = a[k], dabs(r__1)), r__4 = max(
+ r__4,r__5), r__5 = (r__2 = b[k - 1], dabs(r__2)),
+ r__4 = max(r__4,r__5), r__5 = (r__3 = d__[k - 2],
+ dabs(r__3));
+ *tol = dmax(r__4,r__5);
+/* L10: */
+ }
+ *tol *= eps;
+ if (*tol == 0.f) {
+ *tol = eps;
+ }
+ }
+ }
+
+ if (abs(*job) == 1) {
+ i__1 = *n;
+ for (k = 2; k <= i__1; ++k) {
+ if (in[k - 1] == 0) {
+ y[k] -= c__[k - 1] * y[k - 1];
+ } else {
+ temp = y[k - 1];
+ y[k - 1] = y[k];
+ y[k] = temp - c__[k - 1] * y[k];
+ }
+/* L20: */
+ }
+ if (*job == 1) {
+ for (k = *n; k >= 1; --k) {
+ if (k <= *n - 2) {
+ temp = y[k] - b[k] * y[k + 1] - d__[k] * y[k + 2];
+ } else if (k == *n - 1) {
+ temp = y[k] - b[k] * y[k + 1];
+ } else {
+ temp = y[k];
+ }
+ ak = a[k];
+ absak = dabs(ak);
+ if (absak < 1.f) {
+ if (absak < sfmin) {
+ if (absak == 0.f || dabs(temp) * sfmin > absak) {
+ *info = k;
+ return 0;
+ } else {
+ temp *= bignum;
+ ak *= bignum;
+ }
+ } else if (dabs(temp) > absak * bignum) {
+ *info = k;
+ return 0;
+ }
+ }
+ y[k] = temp / ak;
+/* L30: */
+ }
+ } else {
+ for (k = *n; k >= 1; --k) {
+ if (k <= *n - 2) {
+ temp = y[k] - b[k] * y[k + 1] - d__[k] * y[k + 2];
+ } else if (k == *n - 1) {
+ temp = y[k] - b[k] * y[k + 1];
+ } else {
+ temp = y[k];
+ }
+ ak = a[k];
+ pert = r_sign(tol, &ak);
+L40:
+ absak = dabs(ak);
+ if (absak < 1.f) {
+ if (absak < sfmin) {
+ if (absak == 0.f || dabs(temp) * sfmin > absak) {
+ ak += pert;
+ pert *= 2;
+ goto L40;
+ } else {
+ temp *= bignum;
+ ak *= bignum;
+ }
+ } else if (dabs(temp) > absak * bignum) {
+ ak += pert;
+ pert *= 2;
+ goto L40;
+ }
+ }
+ y[k] = temp / ak;
+/* L50: */
+ }
+ }
+ } else {
+
+/* Come to here if JOB = 2 or -2 */
+
+ if (*job == 2) {
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (k >= 3) {
+ temp = y[k] - b[k - 1] * y[k - 1] - d__[k - 2] * y[k - 2];
+ } else if (k == 2) {
+ temp = y[k] - b[k - 1] * y[k - 1];
+ } else {
+ temp = y[k];
+ }
+ ak = a[k];
+ absak = dabs(ak);
+ if (absak < 1.f) {
+ if (absak < sfmin) {
+ if (absak == 0.f || dabs(temp) * sfmin > absak) {
+ *info = k;
+ return 0;
+ } else {
+ temp *= bignum;
+ ak *= bignum;
+ }
+ } else if (dabs(temp) > absak * bignum) {
+ *info = k;
+ return 0;
+ }
+ }
+ y[k] = temp / ak;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (k >= 3) {
+ temp = y[k] - b[k - 1] * y[k - 1] - d__[k - 2] * y[k - 2];
+ } else if (k == 2) {
+ temp = y[k] - b[k - 1] * y[k - 1];
+ } else {
+ temp = y[k];
+ }
+ ak = a[k];
+ pert = r_sign(tol, &ak);
+L70:
+ absak = dabs(ak);
+ if (absak < 1.f) {
+ if (absak < sfmin) {
+ if (absak == 0.f || dabs(temp) * sfmin > absak) {
+ ak += pert;
+ pert *= 2;
+ goto L70;
+ } else {
+ temp *= bignum;
+ ak *= bignum;
+ }
+ } else if (dabs(temp) > absak * bignum) {
+ ak += pert;
+ pert *= 2;
+ goto L70;
+ }
+ }
+ y[k] = temp / ak;
+/* L80: */
+ }
+ }
+
+ for (k = *n; k >= 2; --k) {
+ if (in[k - 1] == 0) {
+ y[k - 1] -= c__[k - 1] * y[k];
+ } else {
+ temp = y[k - 1];
+ y[k - 1] = y[k];
+ y[k] = temp - c__[k - 1] * y[k];
+ }
+/* L90: */
+ }
+ }
+
+/* End of SLAGTS */
+
+ return 0;
+} /* slagts_ */
diff --git a/SRC/slagv2.c b/SRC/slagv2.c
new file mode 100644
index 0000000..03efb8c
--- /dev/null
+++ b/SRC/slagv2.c
@@ -0,0 +1,347 @@
+/* slagv2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* Subroutine */ int slagv2_(real *a, integer *lda, real *b, integer *ldb,
+ real *alphar, real *alphai, real *beta, real *csl, real *snl, real *
+ csr, real *snr)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset;
+ real r__1, r__2, r__3, r__4, r__5, r__6;
+
+ /* Local variables */
+ real r__, t, h1, h2, h3, wi, qq, rr, wr1, wr2, ulp;
+ extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
+ integer *, real *, real *), slag2_(real *, integer *, real *,
+ integer *, real *, real *, real *, real *, real *, real *);
+ real anorm, bnorm, scale1, scale2;
+ extern /* Subroutine */ int slasv2_(real *, real *, real *, real *, real *
+, real *, real *, real *, real *);
+ extern doublereal slapy2_(real *, real *);
+ real ascale, bscale;
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int slartg_(real *, real *, real *, real *, real *
+);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAGV2 computes the Generalized Schur factorization of a real 2-by-2 */
+/* matrix pencil (A,B) where B is upper triangular. This routine */
+/* computes orthogonal (rotation) matrices given by CSL, SNL and CSR, */
+/* SNR such that */
+
+/* 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0 */
+/* types), then */
+
+/* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] */
+/* [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] */
+
+/* [ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ] */
+/* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ], */
+
+/* 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues, */
+/* then */
+
+/* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] */
+/* [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] */
+
+/* [ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ] */
+/* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ] */
+
+/* where b11 >= b22 > 0. */
+
+
+/* Arguments */
+/* ========= */
+
+/* A (input/output) REAL array, dimension (LDA, 2) */
+/* On entry, the 2 x 2 matrix A. */
+/* On exit, A is overwritten by the ``A-part'' of the */
+/* generalized Schur form. */
+
+/* LDA (input) INTEGER */
+/* THe leading dimension of the array A. LDA >= 2. */
+
+/* B (input/output) REAL array, dimension (LDB, 2) */
+/* On entry, the upper triangular 2 x 2 matrix B. */
+/* On exit, B is overwritten by the ``B-part'' of the */
+/* generalized Schur form. */
+
+/* LDB (input) INTEGER */
+/* THe leading dimension of the array B. LDB >= 2. */
+
+/* ALPHAR (output) REAL array, dimension (2) */
+/* ALPHAI (output) REAL array, dimension (2) */
+/* BETA (output) REAL array, dimension (2) */
+/* (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the */
+/* pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may */
+/* be zero. */
+
+/* CSL (output) REAL */
+/* The cosine of the left rotation matrix. */
+
+/* SNL (output) REAL */
+/* The sine of the left rotation matrix. */
+
+/* CSR (output) REAL */
+/* The cosine of the right rotation matrix. */
+
+/* SNR (output) REAL */
+/* The sine of the right rotation matrix. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alphar;
+ --alphai;
+ --beta;
+
+ /* Function Body */
+ safmin = slamch_("S");
+ ulp = slamch_("P");
+
+/* Scale A */
+
+/* Computing MAX */
+ r__5 = (r__1 = a[a_dim1 + 1], dabs(r__1)) + (r__2 = a[a_dim1 + 2], dabs(
+ r__2)), r__6 = (r__3 = a[(a_dim1 << 1) + 1], dabs(r__3)) + (r__4 =
+ a[(a_dim1 << 1) + 2], dabs(r__4)), r__5 = max(r__5,r__6);
+ anorm = dmax(r__5,safmin);
+ ascale = 1.f / anorm;
+ a[a_dim1 + 1] = ascale * a[a_dim1 + 1];
+ a[(a_dim1 << 1) + 1] = ascale * a[(a_dim1 << 1) + 1];
+ a[a_dim1 + 2] = ascale * a[a_dim1 + 2];
+ a[(a_dim1 << 1) + 2] = ascale * a[(a_dim1 << 1) + 2];
+
+/* Scale B */
+
+/* Computing MAX */
+ r__4 = (r__3 = b[b_dim1 + 1], dabs(r__3)), r__5 = (r__1 = b[(b_dim1 << 1)
+ + 1], dabs(r__1)) + (r__2 = b[(b_dim1 << 1) + 2], dabs(r__2)),
+ r__4 = max(r__4,r__5);
+ bnorm = dmax(r__4,safmin);
+ bscale = 1.f / bnorm;
+ b[b_dim1 + 1] = bscale * b[b_dim1 + 1];
+ b[(b_dim1 << 1) + 1] = bscale * b[(b_dim1 << 1) + 1];
+ b[(b_dim1 << 1) + 2] = bscale * b[(b_dim1 << 1) + 2];
+
+/* Check if A can be deflated */
+
+ if ((r__1 = a[a_dim1 + 2], dabs(r__1)) <= ulp) {
+ *csl = 1.f;
+ *snl = 0.f;
+ *csr = 1.f;
+ *snr = 0.f;
+ a[a_dim1 + 2] = 0.f;
+ b[b_dim1 + 2] = 0.f;
+
+/* Check if B is singular */
+
+ } else if ((r__1 = b[b_dim1 + 1], dabs(r__1)) <= ulp) {
+ slartg_(&a[a_dim1 + 1], &a[a_dim1 + 2], csl, snl, &r__);
+ *csr = 1.f;
+ *snr = 0.f;
+ srot_(&c__2, &a[a_dim1 + 1], lda, &a[a_dim1 + 2], lda, csl, snl);
+ srot_(&c__2, &b[b_dim1 + 1], ldb, &b[b_dim1 + 2], ldb, csl, snl);
+ a[a_dim1 + 2] = 0.f;
+ b[b_dim1 + 1] = 0.f;
+ b[b_dim1 + 2] = 0.f;
+
+ } else if ((r__1 = b[(b_dim1 << 1) + 2], dabs(r__1)) <= ulp) {
+ slartg_(&a[(a_dim1 << 1) + 2], &a[a_dim1 + 2], csr, snr, &t);
+ *snr = -(*snr);
+ srot_(&c__2, &a[a_dim1 + 1], &c__1, &a[(a_dim1 << 1) + 1], &c__1, csr,
+ snr);
+ srot_(&c__2, &b[b_dim1 + 1], &c__1, &b[(b_dim1 << 1) + 1], &c__1, csr,
+ snr);
+ *csl = 1.f;
+ *snl = 0.f;
+ a[a_dim1 + 2] = 0.f;
+ b[b_dim1 + 2] = 0.f;
+ b[(b_dim1 << 1) + 2] = 0.f;
+
+ } else {
+
+/* B is nonsingular, first compute the eigenvalues of (A,B) */
+
+ slag2_(&a[a_offset], lda, &b[b_offset], ldb, &safmin, &scale1, &
+ scale2, &wr1, &wr2, &wi);
+
+ if (wi == 0.f) {
+
+/* two real eigenvalues, compute s*A-w*B */
+
+ h1 = scale1 * a[a_dim1 + 1] - wr1 * b[b_dim1 + 1];
+ h2 = scale1 * a[(a_dim1 << 1) + 1] - wr1 * b[(b_dim1 << 1) + 1];
+ h3 = scale1 * a[(a_dim1 << 1) + 2] - wr1 * b[(b_dim1 << 1) + 2];
+
+ rr = slapy2_(&h1, &h2);
+ r__1 = scale1 * a[a_dim1 + 2];
+ qq = slapy2_(&r__1, &h3);
+
+ if (rr > qq) {
+
+/* find right rotation matrix to zero 1,1 element of */
+/* (sA - wB) */
+
+ slartg_(&h2, &h1, csr, snr, &t);
+
+ } else {
+
+/* find right rotation matrix to zero 2,1 element of */
+/* (sA - wB) */
+
+ r__1 = scale1 * a[a_dim1 + 2];
+ slartg_(&h3, &r__1, csr, snr, &t);
+
+ }
+
+ *snr = -(*snr);
+ srot_(&c__2, &a[a_dim1 + 1], &c__1, &a[(a_dim1 << 1) + 1], &c__1,
+ csr, snr);
+ srot_(&c__2, &b[b_dim1 + 1], &c__1, &b[(b_dim1 << 1) + 1], &c__1,
+ csr, snr);
+
+/* compute inf norms of A and B */
+
+/* Computing MAX */
+ r__5 = (r__1 = a[a_dim1 + 1], dabs(r__1)) + (r__2 = a[(a_dim1 <<
+ 1) + 1], dabs(r__2)), r__6 = (r__3 = a[a_dim1 + 2], dabs(
+ r__3)) + (r__4 = a[(a_dim1 << 1) + 2], dabs(r__4));
+ h1 = dmax(r__5,r__6);
+/* Computing MAX */
+ r__5 = (r__1 = b[b_dim1 + 1], dabs(r__1)) + (r__2 = b[(b_dim1 <<
+ 1) + 1], dabs(r__2)), r__6 = (r__3 = b[b_dim1 + 2], dabs(
+ r__3)) + (r__4 = b[(b_dim1 << 1) + 2], dabs(r__4));
+ h2 = dmax(r__5,r__6);
+
+ if (scale1 * h1 >= dabs(wr1) * h2) {
+
+/* find left rotation matrix Q to zero out B(2,1) */
+
+ slartg_(&b[b_dim1 + 1], &b[b_dim1 + 2], csl, snl, &r__);
+
+ } else {
+
+/* find left rotation matrix Q to zero out A(2,1) */
+
+ slartg_(&a[a_dim1 + 1], &a[a_dim1 + 2], csl, snl, &r__);
+
+ }
+
+ srot_(&c__2, &a[a_dim1 + 1], lda, &a[a_dim1 + 2], lda, csl, snl);
+ srot_(&c__2, &b[b_dim1 + 1], ldb, &b[b_dim1 + 2], ldb, csl, snl);
+
+ a[a_dim1 + 2] = 0.f;
+ b[b_dim1 + 2] = 0.f;
+
+ } else {
+
+/* a pair of complex conjugate eigenvalues */
+/* first compute the SVD of the matrix B */
+
+ slasv2_(&b[b_dim1 + 1], &b[(b_dim1 << 1) + 1], &b[(b_dim1 << 1) +
+ 2], &r__, &t, snr, csr, snl, csl);
+
+/* Form (A,B) := Q(A,B)Z' where Q is left rotation matrix and */
+/* Z is right rotation matrix computed from SLASV2 */
+
+ srot_(&c__2, &a[a_dim1 + 1], lda, &a[a_dim1 + 2], lda, csl, snl);
+ srot_(&c__2, &b[b_dim1 + 1], ldb, &b[b_dim1 + 2], ldb, csl, snl);
+ srot_(&c__2, &a[a_dim1 + 1], &c__1, &a[(a_dim1 << 1) + 1], &c__1,
+ csr, snr);
+ srot_(&c__2, &b[b_dim1 + 1], &c__1, &b[(b_dim1 << 1) + 1], &c__1,
+ csr, snr);
+
+ b[b_dim1 + 2] = 0.f;
+ b[(b_dim1 << 1) + 1] = 0.f;
+
+ }
+
+ }
+
+/* Unscaling */
+
+ a[a_dim1 + 1] = anorm * a[a_dim1 + 1];
+ a[a_dim1 + 2] = anorm * a[a_dim1 + 2];
+ a[(a_dim1 << 1) + 1] = anorm * a[(a_dim1 << 1) + 1];
+ a[(a_dim1 << 1) + 2] = anorm * a[(a_dim1 << 1) + 2];
+ b[b_dim1 + 1] = bnorm * b[b_dim1 + 1];
+ b[b_dim1 + 2] = bnorm * b[b_dim1 + 2];
+ b[(b_dim1 << 1) + 1] = bnorm * b[(b_dim1 << 1) + 1];
+ b[(b_dim1 << 1) + 2] = bnorm * b[(b_dim1 << 1) + 2];
+
+ if (wi == 0.f) {
+ alphar[1] = a[a_dim1 + 1];
+ alphar[2] = a[(a_dim1 << 1) + 2];
+ alphai[1] = 0.f;
+ alphai[2] = 0.f;
+ beta[1] = b[b_dim1 + 1];
+ beta[2] = b[(b_dim1 << 1) + 2];
+ } else {
+ alphar[1] = anorm * wr1 / scale1 / bnorm;
+ alphai[1] = anorm * wi / scale1 / bnorm;
+ alphar[2] = alphar[1];
+ alphai[2] = -alphai[1];
+ beta[1] = 1.f;
+ beta[2] = 1.f;
+ }
+
+ return 0;
+
+/* End of SLAGV2 */
+
+} /* slagv2_ */
diff --git a/SRC/slahqr.c b/SRC/slahqr.c
new file mode 100644
index 0000000..fa5a298
--- /dev/null
+++ b/SRC/slahqr.c
@@ -0,0 +1,631 @@
+/* slahqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int slahqr_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, real *h__, integer *ldh, real *wr, real *
+ wi, integer *iloz, integer *ihiz, real *z__, integer *ldz, integer *
+ info)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3;
+ real r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, l, m;
+ real s, v[3];
+ integer i1, i2;
+ real t1, t2, t3, v2, v3, aa, ab, ba, bb, h11, h12, h21, h22, cs;
+ integer nh;
+ real sn;
+ integer nr;
+ real tr;
+ integer nz;
+ real det, h21s;
+ integer its;
+ real ulp, sum, tst, rt1i, rt2i, rt1r, rt2r;
+ extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
+ integer *, real *, real *), scopy_(integer *, real *, integer *,
+ real *, integer *), slanv2_(real *, real *, real *, real *, real *
+, real *, real *, real *, real *, real *), slabad_(real *, real *)
+ ;
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
+ real *);
+ real safmax, rtdisc, smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAHQR is an auxiliary routine called by SHSEQR to update the */
+/* eigenvalues and Schur decomposition already computed by SHSEQR, by */
+/* dealing with the Hessenberg submatrix in rows and columns ILO to */
+/* IHI. */
+
+/* Arguments */
+/* ========= */
+
+/* WANTT (input) LOGICAL */
+/* = .TRUE. : the full Schur form T is required; */
+/* = .FALSE.: only eigenvalues are required. */
+
+/* WANTZ (input) LOGICAL */
+/* = .TRUE. : the matrix of Schur vectors Z is required; */
+/* = .FALSE.: Schur vectors are not required. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that H is already upper quasi-triangular in */
+/* rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless */
+/* ILO = 1). SLAHQR works primarily with the Hessenberg */
+/* submatrix in rows and columns ILO to IHI, but applies */
+/* transformations to all of H if WANTT is .TRUE.. */
+/* 1 <= ILO <= max(1,IHI); IHI <= N. */
+
+/* H (input/output) REAL array, dimension (LDH,N) */
+/* On entry, the upper Hessenberg matrix H. */
+/* On exit, if INFO is zero and if WANTT is .TRUE., H is upper */
+/* quasi-triangular in rows and columns ILO:IHI, with any */
+/* 2-by-2 diagonal blocks in standard form. If INFO is zero */
+/* and WANTT is .FALSE., the contents of H are unspecified on */
+/* exit. The output state of H if INFO is nonzero is given */
+/* below under the description of INFO. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH >= max(1,N). */
+
+/* WR (output) REAL array, dimension (N) */
+/* WI (output) REAL array, dimension (N) */
+/* The real and imaginary parts, respectively, of the computed */
+/* eigenvalues ILO to IHI are stored in the corresponding */
+/* elements of WR and WI. If two eigenvalues are computed as a */
+/* complex conjugate pair, they are stored in consecutive */
+/* elements of WR and WI, say the i-th and (i+1)th, with */
+/* WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the */
+/* eigenvalues are stored in the same order as on the diagonal */
+/* of the Schur form returned in H, with WR(i) = H(i,i), and, if */
+/* H(i:i+1,i:i+1) is a 2-by-2 diagonal block, */
+/* WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). */
+
+/* ILOZ (input) INTEGER */
+/* IHIZ (input) INTEGER */
+/* Specify the rows of Z to which transformations must be */
+/* applied if WANTZ is .TRUE.. */
+/* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */
+
+/* Z (input/output) REAL array, dimension (LDZ,N) */
+/* If WANTZ is .TRUE., on entry Z must contain the current */
+/* matrix Z of transformations accumulated by SHSEQR, and on */
+/* exit Z has been updated; transformations are applied only to */
+/* the submatrix Z(ILOZ:IHIZ,ILO:IHI). */
+/* If WANTZ is .FALSE., Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* .GT. 0: If INFO = i, SLAHQR failed to compute all the */
+/* eigenvalues ILO to IHI in a total of 30 iterations */
+/* per eigenvalue; elements i+1:ihi of WR and WI */
+/* contain those eigenvalues which have been */
+/* successfully computed. */
+
+/* If INFO .GT. 0 and WANTT is .FALSE., then on exit, */
+/* the remaining unconverged eigenvalues are the */
+/* eigenvalues of the upper Hessenberg matrix rows */
+/* and columns ILO thorugh INFO of the final, output */
+/* value of H. */
+
+/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */
+/* (*) (initial value of H)*U = U*(final value of H) */
+/* where U is an orthognal matrix. The final */
+/* value of H is upper Hessenberg and triangular in */
+/* rows and columns INFO+1 through IHI. */
+
+/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
+/* (final value of Z) = (initial value of Z)*U */
+/* where U is the orthogonal matrix in (*) */
+/* (regardless of the value of WANTT.) */
+
+/* Further Details */
+/* =============== */
+
+/* 02-96 Based on modifications by */
+/* David Day, Sandia National Laboratory, USA */
+
+/* 12-04 Further modifications by */
+/* Ralph Byers, University of Kansas, USA */
+/* This is a modified version of SLAHQR from LAPACK version 3.0. */
+/* It is (1) more robust against overflow and underflow and */
+/* (2) adopts the more conservative Ahues & Tisseur stopping */
+/* criterion (LAWN 122, 1997). */
+
+/* ========================================================= */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --wr;
+ --wi;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+ if (*ilo == *ihi) {
+ wr[*ilo] = h__[*ilo + *ilo * h_dim1];
+ wi[*ilo] = 0.f;
+ return 0;
+ }
+
+/* ==== clear out the trash ==== */
+ i__1 = *ihi - 3;
+ for (j = *ilo; j <= i__1; ++j) {
+ h__[j + 2 + j * h_dim1] = 0.f;
+ h__[j + 3 + j * h_dim1] = 0.f;
+/* L10: */
+ }
+ if (*ilo <= *ihi - 2) {
+ h__[*ihi + (*ihi - 2) * h_dim1] = 0.f;
+ }
+
+ nh = *ihi - *ilo + 1;
+ nz = *ihiz - *iloz + 1;
+
+/* Set machine-dependent constants for the stopping criterion. */
+
+ safmin = slamch_("SAFE MINIMUM");
+ safmax = 1.f / safmin;
+ slabad_(&safmin, &safmax);
+ ulp = slamch_("PRECISION");
+ smlnum = safmin * ((real) nh / ulp);
+
+/* I1 and I2 are the indices of the first row and last column of H */
+/* to which transformations must be applied. If eigenvalues only are */
+/* being computed, I1 and I2 are set inside the main loop. */
+
+ if (*wantt) {
+ i1 = 1;
+ i2 = *n;
+ }
+
+/* The main loop begins here. I is the loop index and decreases from */
+/* IHI to ILO in steps of 1 or 2. Each iteration of the loop works */
+/* with the active submatrix in rows and columns L to I. */
+/* Eigenvalues I+1 to IHI have already converged. Either L = ILO or */
+/* H(L,L-1) is negligible so that the matrix splits. */
+
+ i__ = *ihi;
+L20:
+ l = *ilo;
+ if (i__ < *ilo) {
+ goto L160;
+ }
+
+/* Perform QR iterations on rows and columns ILO to I until a */
+/* submatrix of order 1 or 2 splits off at the bottom because a */
+/* subdiagonal element has become negligible. */
+
+ for (its = 0; its <= 30; ++its) {
+
+/* Look for a single small subdiagonal element. */
+
+ i__1 = l + 1;
+ for (k = i__; k >= i__1; --k) {
+ if ((r__1 = h__[k + (k - 1) * h_dim1], dabs(r__1)) <= smlnum) {
+ goto L40;
+ }
+ tst = (r__1 = h__[k - 1 + (k - 1) * h_dim1], dabs(r__1)) + (r__2 =
+ h__[k + k * h_dim1], dabs(r__2));
+ if (tst == 0.f) {
+ if (k - 2 >= *ilo) {
+ tst += (r__1 = h__[k - 1 + (k - 2) * h_dim1], dabs(r__1));
+ }
+ if (k + 1 <= *ihi) {
+ tst += (r__1 = h__[k + 1 + k * h_dim1], dabs(r__1));
+ }
+ }
+/* ==== The following is a conservative small subdiagonal */
+/* . deflation criterion due to Ahues & Tisseur (LAWN 122, */
+/* . 1997). It has better mathematical foundation and */
+/* . improves accuracy in some cases. ==== */
+ if ((r__1 = h__[k + (k - 1) * h_dim1], dabs(r__1)) <= ulp * tst) {
+/* Computing MAX */
+ r__3 = (r__1 = h__[k + (k - 1) * h_dim1], dabs(r__1)), r__4 =
+ (r__2 = h__[k - 1 + k * h_dim1], dabs(r__2));
+ ab = dmax(r__3,r__4);
+/* Computing MIN */
+ r__3 = (r__1 = h__[k + (k - 1) * h_dim1], dabs(r__1)), r__4 =
+ (r__2 = h__[k - 1 + k * h_dim1], dabs(r__2));
+ ba = dmin(r__3,r__4);
+/* Computing MAX */
+ r__3 = (r__1 = h__[k + k * h_dim1], dabs(r__1)), r__4 = (r__2
+ = h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1],
+ dabs(r__2));
+ aa = dmax(r__3,r__4);
+/* Computing MIN */
+ r__3 = (r__1 = h__[k + k * h_dim1], dabs(r__1)), r__4 = (r__2
+ = h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1],
+ dabs(r__2));
+ bb = dmin(r__3,r__4);
+ s = aa + ab;
+/* Computing MAX */
+ r__1 = smlnum, r__2 = ulp * (bb * (aa / s));
+ if (ba * (ab / s) <= dmax(r__1,r__2)) {
+ goto L40;
+ }
+ }
+/* L30: */
+ }
+L40:
+ l = k;
+ if (l > *ilo) {
+
+/* H(L,L-1) is negligible */
+
+ h__[l + (l - 1) * h_dim1] = 0.f;
+ }
+
+/* Exit from loop if a submatrix of order 1 or 2 has split off. */
+
+ if (l >= i__ - 1) {
+ goto L150;
+ }
+
+/* Now the active submatrix is in rows and columns L to I. If */
+/* eigenvalues only are being computed, only the active submatrix */
+/* need be transformed. */
+
+ if (! (*wantt)) {
+ i1 = l;
+ i2 = i__;
+ }
+
+ if (its == 10) {
+
+/* Exceptional shift. */
+
+ s = (r__1 = h__[l + 1 + l * h_dim1], dabs(r__1)) + (r__2 = h__[l
+ + 2 + (l + 1) * h_dim1], dabs(r__2));
+ h11 = s * .75f + h__[l + l * h_dim1];
+ h12 = s * -.4375f;
+ h21 = s;
+ h22 = h11;
+ } else if (its == 20) {
+
+/* Exceptional shift. */
+
+ s = (r__1 = h__[i__ + (i__ - 1) * h_dim1], dabs(r__1)) + (r__2 =
+ h__[i__ - 1 + (i__ - 2) * h_dim1], dabs(r__2));
+ h11 = s * .75f + h__[i__ + i__ * h_dim1];
+ h12 = s * -.4375f;
+ h21 = s;
+ h22 = h11;
+ } else {
+
+/* Prepare to use Francis' double shift */
+/* (i.e. 2nd degree generalized Rayleigh quotient) */
+
+ h11 = h__[i__ - 1 + (i__ - 1) * h_dim1];
+ h21 = h__[i__ + (i__ - 1) * h_dim1];
+ h12 = h__[i__ - 1 + i__ * h_dim1];
+ h22 = h__[i__ + i__ * h_dim1];
+ }
+ s = dabs(h11) + dabs(h12) + dabs(h21) + dabs(h22);
+ if (s == 0.f) {
+ rt1r = 0.f;
+ rt1i = 0.f;
+ rt2r = 0.f;
+ rt2i = 0.f;
+ } else {
+ h11 /= s;
+ h21 /= s;
+ h12 /= s;
+ h22 /= s;
+ tr = (h11 + h22) / 2.f;
+ det = (h11 - tr) * (h22 - tr) - h12 * h21;
+ rtdisc = sqrt((dabs(det)));
+ if (det >= 0.f) {
+
+/* ==== complex conjugate shifts ==== */
+
+ rt1r = tr * s;
+ rt2r = rt1r;
+ rt1i = rtdisc * s;
+ rt2i = -rt1i;
+ } else {
+
+/* ==== real shifts (use only one of them) ==== */
+
+ rt1r = tr + rtdisc;
+ rt2r = tr - rtdisc;
+ if ((r__1 = rt1r - h22, dabs(r__1)) <= (r__2 = rt2r - h22,
+ dabs(r__2))) {
+ rt1r *= s;
+ rt2r = rt1r;
+ } else {
+ rt2r *= s;
+ rt1r = rt2r;
+ }
+ rt1i = 0.f;
+ rt2i = 0.f;
+ }
+ }
+
+/* Look for two consecutive small subdiagonal elements. */
+
+ i__1 = l;
+ for (m = i__ - 2; m >= i__1; --m) {
+/* Determine the effect of starting the double-shift QR */
+/* iteration at row M, and see if this would make H(M,M-1) */
+/* negligible. (The following uses scaling to avoid */
+/* overflows and most underflows.) */
+
+ h21s = h__[m + 1 + m * h_dim1];
+ s = (r__1 = h__[m + m * h_dim1] - rt2r, dabs(r__1)) + dabs(rt2i)
+ + dabs(h21s);
+ h21s = h__[m + 1 + m * h_dim1] / s;
+ v[0] = h21s * h__[m + (m + 1) * h_dim1] + (h__[m + m * h_dim1] -
+ rt1r) * ((h__[m + m * h_dim1] - rt2r) / s) - rt1i * (rt2i
+ / s);
+ v[1] = h21s * (h__[m + m * h_dim1] + h__[m + 1 + (m + 1) * h_dim1]
+ - rt1r - rt2r);
+ v[2] = h21s * h__[m + 2 + (m + 1) * h_dim1];
+ s = dabs(v[0]) + dabs(v[1]) + dabs(v[2]);
+ v[0] /= s;
+ v[1] /= s;
+ v[2] /= s;
+ if (m == l) {
+ goto L60;
+ }
+ if ((r__1 = h__[m + (m - 1) * h_dim1], dabs(r__1)) * (dabs(v[1])
+ + dabs(v[2])) <= ulp * dabs(v[0]) * ((r__2 = h__[m - 1 + (
+ m - 1) * h_dim1], dabs(r__2)) + (r__3 = h__[m + m *
+ h_dim1], dabs(r__3)) + (r__4 = h__[m + 1 + (m + 1) *
+ h_dim1], dabs(r__4)))) {
+ goto L60;
+ }
+/* L50: */
+ }
+L60:
+
+/* Double-shift QR step */
+
+ i__1 = i__ - 1;
+ for (k = m; k <= i__1; ++k) {
+
+/* The first iteration of this loop determines a reflection G */
+/* from the vector V and applies it from left and right to H, */
+/* thus creating a nonzero bulge below the subdiagonal. */
+
+/* Each subsequent iteration determines a reflection G to */
+/* restore the Hessenberg form in the (K-1)th column, and thus */
+/* chases the bulge one step toward the bottom of the active */
+/* submatrix. NR is the order of G. */
+
+/* Computing MIN */
+ i__2 = 3, i__3 = i__ - k + 1;
+ nr = min(i__2,i__3);
+ if (k > m) {
+ scopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
+ }
+ slarfg_(&nr, v, &v[1], &c__1, &t1);
+ if (k > m) {
+ h__[k + (k - 1) * h_dim1] = v[0];
+ h__[k + 1 + (k - 1) * h_dim1] = 0.f;
+ if (k < i__ - 1) {
+ h__[k + 2 + (k - 1) * h_dim1] = 0.f;
+ }
+ } else if (m > l) {
+/* ==== Use the following instead of */
+/* . H( K, K-1 ) = -H( K, K-1 ) to */
+/* . avoid a bug when v(2) and v(3) */
+/* . underflow. ==== */
+ h__[k + (k - 1) * h_dim1] *= 1.f - t1;
+ }
+ v2 = v[1];
+ t2 = t1 * v2;
+ if (nr == 3) {
+ v3 = v[2];
+ t3 = t1 * v3;
+
+/* Apply G from the left to transform the rows of the matrix */
+/* in columns K to I2. */
+
+ i__2 = i2;
+ for (j = k; j <= i__2; ++j) {
+ sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1]
+ + v3 * h__[k + 2 + j * h_dim1];
+ h__[k + j * h_dim1] -= sum * t1;
+ h__[k + 1 + j * h_dim1] -= sum * t2;
+ h__[k + 2 + j * h_dim1] -= sum * t3;
+/* L70: */
+ }
+
+/* Apply G from the right to transform the columns of the */
+/* matrix in rows I1 to min(K+3,I). */
+
+/* Computing MIN */
+ i__3 = k + 3;
+ i__2 = min(i__3,i__);
+ for (j = i1; j <= i__2; ++j) {
+ sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
+ + v3 * h__[j + (k + 2) * h_dim1];
+ h__[j + k * h_dim1] -= sum * t1;
+ h__[j + (k + 1) * h_dim1] -= sum * t2;
+ h__[j + (k + 2) * h_dim1] -= sum * t3;
+/* L80: */
+ }
+
+ if (*wantz) {
+
+/* Accumulate transformations in the matrix Z */
+
+ i__2 = *ihiz;
+ for (j = *iloz; j <= i__2; ++j) {
+ sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) *
+ z_dim1] + v3 * z__[j + (k + 2) * z_dim1];
+ z__[j + k * z_dim1] -= sum * t1;
+ z__[j + (k + 1) * z_dim1] -= sum * t2;
+ z__[j + (k + 2) * z_dim1] -= sum * t3;
+/* L90: */
+ }
+ }
+ } else if (nr == 2) {
+
+/* Apply G from the left to transform the rows of the matrix */
+/* in columns K to I2. */
+
+ i__2 = i2;
+ for (j = k; j <= i__2; ++j) {
+ sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1];
+ h__[k + j * h_dim1] -= sum * t1;
+ h__[k + 1 + j * h_dim1] -= sum * t2;
+/* L100: */
+ }
+
+/* Apply G from the right to transform the columns of the */
+/* matrix in rows I1 to min(K+3,I). */
+
+ i__2 = i__;
+ for (j = i1; j <= i__2; ++j) {
+ sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
+ ;
+ h__[j + k * h_dim1] -= sum * t1;
+ h__[j + (k + 1) * h_dim1] -= sum * t2;
+/* L110: */
+ }
+
+ if (*wantz) {
+
+/* Accumulate transformations in the matrix Z */
+
+ i__2 = *ihiz;
+ for (j = *iloz; j <= i__2; ++j) {
+ sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) *
+ z_dim1];
+ z__[j + k * z_dim1] -= sum * t1;
+ z__[j + (k + 1) * z_dim1] -= sum * t2;
+/* L120: */
+ }
+ }
+ }
+/* L130: */
+ }
+
+/* L140: */
+ }
+
+/* Failure to converge in remaining number of iterations */
+
+ *info = i__;
+ return 0;
+
+L150:
+
+ if (l == i__) {
+
+/* H(I,I-1) is negligible: one eigenvalue has converged. */
+
+ wr[i__] = h__[i__ + i__ * h_dim1];
+ wi[i__] = 0.f;
+ } else if (l == i__ - 1) {
+
+/* H(I-1,I-2) is negligible: a pair of eigenvalues have converged. */
+
+/* Transform the 2-by-2 submatrix to standard Schur form, */
+/* and compute and store the eigenvalues. */
+
+ slanv2_(&h__[i__ - 1 + (i__ - 1) * h_dim1], &h__[i__ - 1 + i__ *
+ h_dim1], &h__[i__ + (i__ - 1) * h_dim1], &h__[i__ + i__ *
+ h_dim1], &wr[i__ - 1], &wi[i__ - 1], &wr[i__], &wi[i__], &cs,
+ &sn);
+
+ if (*wantt) {
+
+/* Apply the transformation to the rest of H. */
+
+ if (i2 > i__) {
+ i__1 = i2 - i__;
+ srot_(&i__1, &h__[i__ - 1 + (i__ + 1) * h_dim1], ldh, &h__[
+ i__ + (i__ + 1) * h_dim1], ldh, &cs, &sn);
+ }
+ i__1 = i__ - i1 - 1;
+ srot_(&i__1, &h__[i1 + (i__ - 1) * h_dim1], &c__1, &h__[i1 + i__ *
+ h_dim1], &c__1, &cs, &sn);
+ }
+ if (*wantz) {
+
+/* Apply the transformation to Z. */
+
+ srot_(&nz, &z__[*iloz + (i__ - 1) * z_dim1], &c__1, &z__[*iloz +
+ i__ * z_dim1], &c__1, &cs, &sn);
+ }
+ }
+
+/* return to start of the main loop with new value of I. */
+
+ i__ = l - 1;
+ goto L20;
+
+L160:
+ return 0;
+
+/* End of SLAHQR */
+
+} /* slahqr_ */
diff --git a/SRC/slahr2.c b/SRC/slahr2.c
new file mode 100644
index 0000000..d5df1ce
--- /dev/null
+++ b/SRC/slahr2.c
@@ -0,0 +1,309 @@
+/* slahr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b4 = -1.f;
+static real c_b5 = 1.f;
+static integer c__1 = 1;
+static real c_b38 = 0.f;
+
+/* Subroutine */ int slahr2_(integer *n, integer *k, integer *nb, real *a,
+ integer *lda, real *tau, real *t, integer *ldt, real *y, integer *ldy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
+ i__3;
+ real r__1;
+
+ /* Local variables */
+ integer i__;
+ real ei;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ sgemm_(char *, char *, integer *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *), sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *),
+ strmm_(char *, char *, char *, char *, integer *, integer *, real
+ *, real *, integer *, real *, integer *), saxpy_(integer *, real *, real *, integer *, real *,
+ integer *), strmv_(char *, char *, char *, integer *, real *,
+ integer *, real *, integer *), slarfg_(
+ integer *, real *, real *, integer *, real *), slacpy_(char *,
+ integer *, integer *, real *, integer *, real *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1) */
+/* matrix A so that elements below the k-th subdiagonal are zero. The */
+/* reduction is performed by an orthogonal similarity transformation */
+/* Q' * A * Q. The routine returns the matrices V and T which determine */
+/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */
+
+/* This is an auxiliary routine called by SGEHRD. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* K (input) INTEGER */
+/* The offset for the reduction. Elements below the k-th */
+/* subdiagonal in the first NB columns are reduced to zero. */
+/* K < N. */
+
+/* NB (input) INTEGER */
+/* The number of columns to be reduced. */
+
+/* A (input/output) REAL array, dimension (LDA,N-K+1) */
+/* On entry, the n-by-(n-k+1) general matrix A. */
+/* On exit, the elements on and above the k-th subdiagonal in */
+/* the first NB columns are overwritten with the corresponding */
+/* elements of the reduced matrix; the elements below the k-th */
+/* subdiagonal, with the array TAU, represent the matrix Q as a */
+/* product of elementary reflectors. The other columns of A are */
+/* unchanged. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAU (output) REAL array, dimension (NB) */
+/* The scalar factors of the elementary reflectors. See Further */
+/* Details. */
+
+/* T (output) REAL array, dimension (LDT,NB) */
+/* The upper triangular matrix T. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= NB. */
+
+/* Y (output) REAL array, dimension (LDY,NB) */
+/* The n-by-nb matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= N. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of nb elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(nb). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
+/* A(i+k+1:n,i), and tau in TAU(i). */
+
+/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */
+/* V which is needed, with T and Y, to apply the transformation to the */
+/* unreduced part of the matrix, using an update of the form: */
+/* A := (I - V*T*V') * (A - Y*V'). */
+
+/* The contents of A on exit are illustrated by the following example */
+/* with n = 7, k = 3 and nb = 2: */
+
+/* ( a a a a a ) */
+/* ( a a a a a ) */
+/* ( a a a a a ) */
+/* ( h h a a a ) */
+/* ( v1 h a a a ) */
+/* ( v1 v2 a a a ) */
+/* ( v1 v2 a a a ) */
+
+/* where a denotes an element of the original matrix A, h denotes a */
+/* modified element of the upper Hessenberg matrix H, and vi denotes an */
+/* element of the vector defining H(i). */
+
+/* This file is a slight modification of LAPACK-3.0's SLAHRD */
+/* incorporating improvements proposed by Quintana-Orti and Van de */
+/* Gejin. Note that the entries of A(1:K,2:NB) differ from those */
+/* returned by the original LAPACK routine. This function is */
+/* not backward compatible with LAPACK3.0. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --tau;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+
+ /* Function Body */
+ if (*n <= 1) {
+ return 0;
+ }
+
+ i__1 = *nb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (i__ > 1) {
+
+/* Update A(K+1:N,I) */
+
+/* Update I-th column of A - Y * V' */
+
+ i__2 = *n - *k;
+ i__3 = i__ - 1;
+ sgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1],
+ ldy, &a[*k + i__ - 1 + a_dim1], lda, &c_b5, &a[*k + 1 +
+ i__ * a_dim1], &c__1);
+
+/* Apply I - V * T' * V' to this column (call it b) from the */
+/* left, using the last column of T as workspace */
+
+/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */
+/* ( V2 ) ( b2 ) */
+
+/* where V1 is unit lower triangular */
+
+/* w := V1' * b1 */
+
+ i__2 = i__ - 1;
+ scopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 +
+ 1], &c__1);
+ i__2 = i__ - 1;
+ strmv_("Lower", "Transpose", "UNIT", &i__2, &a[*k + 1 + a_dim1],
+ lda, &t[*nb * t_dim1 + 1], &c__1);
+
+/* w := w + V2'*b2 */
+
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ sgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1],
+ lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b5, &t[*nb *
+ t_dim1 + 1], &c__1);
+
+/* w := T'*w */
+
+ i__2 = i__ - 1;
+ strmv_("Upper", "Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt,
+ &t[*nb * t_dim1 + 1], &c__1);
+
+/* b2 := b2 - V2*w */
+
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ sgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &a[*k + i__ + a_dim1],
+ lda, &t[*nb * t_dim1 + 1], &c__1, &c_b5, &a[*k + i__ +
+ i__ * a_dim1], &c__1);
+
+/* b1 := b1 - V1*w */
+
+ i__2 = i__ - 1;
+ strmv_("Lower", "NO TRANSPOSE", "UNIT", &i__2, &a[*k + 1 + a_dim1]
+, lda, &t[*nb * t_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ saxpy_(&i__2, &c_b4, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__
+ * a_dim1], &c__1);
+
+ a[*k + i__ - 1 + (i__ - 1) * a_dim1] = ei;
+ }
+
+/* Generate the elementary reflector H(I) to annihilate */
+/* A(K+I+1:N,I) */
+
+ i__2 = *n - *k - i__ + 1;
+/* Computing MIN */
+ i__3 = *k + i__ + 1;
+ slarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[min(i__3, *n)+ i__ *
+ a_dim1], &c__1, &tau[i__]);
+ ei = a[*k + i__ + i__ * a_dim1];
+ a[*k + i__ + i__ * a_dim1] = 1.f;
+
+/* Compute Y(K+1:N,I) */
+
+ i__2 = *n - *k;
+ i__3 = *n - *k - i__ + 1;
+ sgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b5, &a[*k + 1 + (i__ + 1) *
+ a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &y[*
+ k + 1 + i__ * y_dim1], &c__1);
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ sgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], lda, &
+ a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &t[i__ * t_dim1 +
+ 1], &c__1);
+ i__2 = *n - *k;
+ i__3 = i__ - 1;
+ sgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1], ldy,
+ &t[i__ * t_dim1 + 1], &c__1, &c_b5, &y[*k + 1 + i__ * y_dim1],
+ &c__1);
+ i__2 = *n - *k;
+ sscal_(&i__2, &tau[i__], &y[*k + 1 + i__ * y_dim1], &c__1);
+
+/* Compute T(1:I,I) */
+
+ i__2 = i__ - 1;
+ r__1 = -tau[i__];
+ sscal_(&i__2, &r__1, &t[i__ * t_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ strmv_("Upper", "No Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt,
+ &t[i__ * t_dim1 + 1], &c__1)
+ ;
+ t[i__ + i__ * t_dim1] = tau[i__];
+
+/* L10: */
+ }
+ a[*k + *nb + *nb * a_dim1] = ei;
+
+/* Compute Y(1:K,1:NB) */
+
+ slacpy_("ALL", k, nb, &a[(a_dim1 << 1) + 1], lda, &y[y_offset], ldy);
+ strmm_("RIGHT", "Lower", "NO TRANSPOSE", "UNIT", k, nb, &c_b5, &a[*k + 1
+ + a_dim1], lda, &y[y_offset], ldy);
+ if (*n > *k + *nb) {
+ i__1 = *n - *k - *nb;
+ sgemm_("NO TRANSPOSE", "NO TRANSPOSE", k, nb, &i__1, &c_b5, &a[(*nb +
+ 2) * a_dim1 + 1], lda, &a[*k + 1 + *nb + a_dim1], lda, &c_b5,
+ &y[y_offset], ldy);
+ }
+ strmm_("RIGHT", "Upper", "NO TRANSPOSE", "NON-UNIT", k, nb, &c_b5, &t[
+ t_offset], ldt, &y[y_offset], ldy);
+
+ return 0;
+
+/* End of SLAHR2 */
+
+} /* slahr2_ */
diff --git a/SRC/slahrd.c b/SRC/slahrd.c
new file mode 100644
index 0000000..d73e4ee
--- /dev/null
+++ b/SRC/slahrd.c
@@ -0,0 +1,282 @@
+/* slahrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b4 = -1.f;
+static real c_b5 = 1.f;
+static integer c__1 = 1;
+static real c_b38 = 0.f;
+
+/* Subroutine */ int slahrd_(integer *n, integer *k, integer *nb, real *a,
+ integer *lda, real *tau, real *t, integer *ldt, real *y, integer *ldy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
+ i__3;
+ real r__1;
+
+ /* Local variables */
+ integer i__;
+ real ei;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ sgemv_(char *, integer *, integer *, real *, real *, integer *,
+ real *, integer *, real *, real *, integer *), scopy_(
+ integer *, real *, integer *, real *, integer *), saxpy_(integer *
+, real *, real *, integer *, real *, integer *), strmv_(char *,
+ char *, char *, integer *, real *, integer *, real *, integer *), slarfg_(integer *, real *, real *,
+ integer *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAHRD reduces the first NB columns of a real general n-by-(n-k+1) */
+/* matrix A so that elements below the k-th subdiagonal are zero. The */
+/* reduction is performed by an orthogonal similarity transformation */
+/* Q' * A * Q. The routine returns the matrices V and T which determine */
+/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */
+
+/* This is an OBSOLETE auxiliary routine. */
+/* This routine will be 'deprecated' in a future release. */
+/* Please use the new routine SLAHR2 instead. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* K (input) INTEGER */
+/* The offset for the reduction. Elements below the k-th */
+/* subdiagonal in the first NB columns are reduced to zero. */
+
+/* NB (input) INTEGER */
+/* The number of columns to be reduced. */
+
+/* A (input/output) REAL array, dimension (LDA,N-K+1) */
+/* On entry, the n-by-(n-k+1) general matrix A. */
+/* On exit, the elements on and above the k-th subdiagonal in */
+/* the first NB columns are overwritten with the corresponding */
+/* elements of the reduced matrix; the elements below the k-th */
+/* subdiagonal, with the array TAU, represent the matrix Q as a */
+/* product of elementary reflectors. The other columns of A are */
+/* unchanged. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAU (output) REAL array, dimension (NB) */
+/* The scalar factors of the elementary reflectors. See Further */
+/* Details. */
+
+/* T (output) REAL array, dimension (LDT,NB) */
+/* The upper triangular matrix T. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= NB. */
+
+/* Y (output) REAL array, dimension (LDY,NB) */
+/* The n-by-nb matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= N. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of nb elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(nb). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
+/* A(i+k+1:n,i), and tau in TAU(i). */
+
+/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */
+/* V which is needed, with T and Y, to apply the transformation to the */
+/* unreduced part of the matrix, using an update of the form: */
+/* A := (I - V*T*V') * (A - Y*V'). */
+
+/* The contents of A on exit are illustrated by the following example */
+/* with n = 7, k = 3 and nb = 2: */
+
+/* ( a h a a a ) */
+/* ( a h a a a ) */
+/* ( a h a a a ) */
+/* ( h h a a a ) */
+/* ( v1 h a a a ) */
+/* ( v1 v2 a a a ) */
+/* ( v1 v2 a a a ) */
+
+/* where a denotes an element of the original matrix A, h denotes a */
+/* modified element of the upper Hessenberg matrix H, and vi denotes an */
+/* element of the vector defining H(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --tau;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+
+ /* Function Body */
+ if (*n <= 1) {
+ return 0;
+ }
+
+ i__1 = *nb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (i__ > 1) {
+
+/* Update A(1:n,i) */
+
+/* Compute i-th column of A - Y * V' */
+
+ i__2 = i__ - 1;
+ sgemv_("No transpose", n, &i__2, &c_b4, &y[y_offset], ldy, &a[*k
+ + i__ - 1 + a_dim1], lda, &c_b5, &a[i__ * a_dim1 + 1], &
+ c__1);
+
+/* Apply I - V * T' * V' to this column (call it b) from the */
+/* left, using the last column of T as workspace */
+
+/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */
+/* ( V2 ) ( b2 ) */
+
+/* where V1 is unit lower triangular */
+
+/* w := V1' * b1 */
+
+ i__2 = i__ - 1;
+ scopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 +
+ 1], &c__1);
+ i__2 = i__ - 1;
+ strmv_("Lower", "Transpose", "Unit", &i__2, &a[*k + 1 + a_dim1],
+ lda, &t[*nb * t_dim1 + 1], &c__1);
+
+/* w := w + V2'*b2 */
+
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ sgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1],
+ lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b5, &t[*nb *
+ t_dim1 + 1], &c__1);
+
+/* w := T'*w */
+
+ i__2 = i__ - 1;
+ strmv_("Upper", "Transpose", "Non-unit", &i__2, &t[t_offset], ldt,
+ &t[*nb * t_dim1 + 1], &c__1);
+
+/* b2 := b2 - V2*w */
+
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ sgemv_("No transpose", &i__2, &i__3, &c_b4, &a[*k + i__ + a_dim1],
+ lda, &t[*nb * t_dim1 + 1], &c__1, &c_b5, &a[*k + i__ +
+ i__ * a_dim1], &c__1);
+
+/* b1 := b1 - V1*w */
+
+ i__2 = i__ - 1;
+ strmv_("Lower", "No transpose", "Unit", &i__2, &a[*k + 1 + a_dim1]
+, lda, &t[*nb * t_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ saxpy_(&i__2, &c_b4, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__
+ * a_dim1], &c__1);
+
+ a[*k + i__ - 1 + (i__ - 1) * a_dim1] = ei;
+ }
+
+/* Generate the elementary reflector H(i) to annihilate */
+/* A(k+i+1:n,i) */
+
+ i__2 = *n - *k - i__ + 1;
+/* Computing MIN */
+ i__3 = *k + i__ + 1;
+ slarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[min(i__3, *n)+ i__ *
+ a_dim1], &c__1, &tau[i__]);
+ ei = a[*k + i__ + i__ * a_dim1];
+ a[*k + i__ + i__ * a_dim1] = 1.f;
+
+/* Compute Y(1:n,i) */
+
+ i__2 = *n - *k - i__ + 1;
+ sgemv_("No transpose", n, &i__2, &c_b5, &a[(i__ + 1) * a_dim1 + 1],
+ lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &y[i__ *
+ y_dim1 + 1], &c__1);
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ sgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], lda, &
+ a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &t[i__ * t_dim1 +
+ 1], &c__1);
+ i__2 = i__ - 1;
+ sgemv_("No transpose", n, &i__2, &c_b4, &y[y_offset], ldy, &t[i__ *
+ t_dim1 + 1], &c__1, &c_b5, &y[i__ * y_dim1 + 1], &c__1);
+ sscal_(n, &tau[i__], &y[i__ * y_dim1 + 1], &c__1);
+
+/* Compute T(1:i,i) */
+
+ i__2 = i__ - 1;
+ r__1 = -tau[i__];
+ sscal_(&i__2, &r__1, &t[i__ * t_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ strmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt,
+ &t[i__ * t_dim1 + 1], &c__1)
+ ;
+ t[i__ + i__ * t_dim1] = tau[i__];
+
+/* L10: */
+ }
+ a[*k + *nb + *nb * a_dim1] = ei;
+
+ return 0;
+
+/* End of SLAHRD */
+
+} /* slahrd_ */
diff --git a/SRC/slaic1.c b/SRC/slaic1.c
new file mode 100644
index 0000000..1ef8a6d
--- /dev/null
+++ b/SRC/slaic1.c
@@ -0,0 +1,324 @@
+/* slaic1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b5 = 1.f;
+
+/* Subroutine */ int slaic1_(integer *job, integer *j, real *x, real *sest,
+ real *w, real *gamma, real *sestpr, real *s, real *c__)
+{
+ /* System generated locals */
+ real r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_sign(real *, real *);
+
+ /* Local variables */
+ real b, t, s1, s2, eps, tmp, sine;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ real test, zeta1, zeta2, alpha, norma, absgam, absalp;
+ extern doublereal slamch_(char *);
+ real cosine, absest;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAIC1 applies one step of incremental condition estimation in */
+/* its simplest version: */
+
+/* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j */
+/* lower triangular matrix L, such that */
+/* twonorm(L*x) = sest */
+/* Then SLAIC1 computes sestpr, s, c such that */
+/* the vector */
+/* [ s*x ] */
+/* xhat = [ c ] */
+/* is an approximate singular vector of */
+/* [ L 0 ] */
+/* Lhat = [ w' gamma ] */
+/* in the sense that */
+/* twonorm(Lhat*xhat) = sestpr. */
+
+/* Depending on JOB, an estimate for the largest or smallest singular */
+/* value is computed. */
+
+/* Note that [s c]' and sestpr**2 is an eigenpair of the system */
+
+/* diag(sest*sest, 0) + [alpha gamma] * [ alpha ] */
+/* [ gamma ] */
+
+/* where alpha = x'*w. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) INTEGER */
+/* = 1: an estimate for the largest singular value is computed. */
+/* = 2: an estimate for the smallest singular value is computed. */
+
+/* J (input) INTEGER */
+/* Length of X and W */
+
+/* X (input) REAL array, dimension (J) */
+/* The j-vector x. */
+
+/* SEST (input) REAL */
+/* Estimated singular value of j by j matrix L */
+
+/* W (input) REAL array, dimension (J) */
+/* The j-vector w. */
+
+/* GAMMA (input) REAL */
+/* The diagonal element gamma. */
+
+/* SESTPR (output) REAL */
+/* Estimated singular value of (j+1) by (j+1) matrix Lhat. */
+
+/* S (output) REAL */
+/* Sine needed in forming xhat. */
+
+/* C (output) REAL */
+/* Cosine needed in forming xhat. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --w;
+ --x;
+
+ /* Function Body */
+ eps = slamch_("Epsilon");
+ alpha = sdot_(j, &x[1], &c__1, &w[1], &c__1);
+
+ absalp = dabs(alpha);
+ absgam = dabs(*gamma);
+ absest = dabs(*sest);
+
+ if (*job == 1) {
+
+/* Estimating largest singular value */
+
+/* special cases */
+
+ if (*sest == 0.f) {
+ s1 = dmax(absgam,absalp);
+ if (s1 == 0.f) {
+ *s = 0.f;
+ *c__ = 1.f;
+ *sestpr = 0.f;
+ } else {
+ *s = alpha / s1;
+ *c__ = *gamma / s1;
+ tmp = sqrt(*s * *s + *c__ * *c__);
+ *s /= tmp;
+ *c__ /= tmp;
+ *sestpr = s1 * tmp;
+ }
+ return 0;
+ } else if (absgam <= eps * absest) {
+ *s = 1.f;
+ *c__ = 0.f;
+ tmp = dmax(absest,absalp);
+ s1 = absest / tmp;
+ s2 = absalp / tmp;
+ *sestpr = tmp * sqrt(s1 * s1 + s2 * s2);
+ return 0;
+ } else if (absalp <= eps * absest) {
+ s1 = absgam;
+ s2 = absest;
+ if (s1 <= s2) {
+ *s = 1.f;
+ *c__ = 0.f;
+ *sestpr = s2;
+ } else {
+ *s = 0.f;
+ *c__ = 1.f;
+ *sestpr = s1;
+ }
+ return 0;
+ } else if (absest <= eps * absalp || absest <= eps * absgam) {
+ s1 = absgam;
+ s2 = absalp;
+ if (s1 <= s2) {
+ tmp = s1 / s2;
+ *s = sqrt(tmp * tmp + 1.f);
+ *sestpr = s2 * *s;
+ *c__ = *gamma / s2 / *s;
+ *s = r_sign(&c_b5, &alpha) / *s;
+ } else {
+ tmp = s2 / s1;
+ *c__ = sqrt(tmp * tmp + 1.f);
+ *sestpr = s1 * *c__;
+ *s = alpha / s1 / *c__;
+ *c__ = r_sign(&c_b5, gamma) / *c__;
+ }
+ return 0;
+ } else {
+
+/* normal case */
+
+ zeta1 = alpha / absest;
+ zeta2 = *gamma / absest;
+
+ b = (1.f - zeta1 * zeta1 - zeta2 * zeta2) * .5f;
+ *c__ = zeta1 * zeta1;
+ if (b > 0.f) {
+ t = *c__ / (b + sqrt(b * b + *c__));
+ } else {
+ t = sqrt(b * b + *c__) - b;
+ }
+
+ sine = -zeta1 / t;
+ cosine = -zeta2 / (t + 1.f);
+ tmp = sqrt(sine * sine + cosine * cosine);
+ *s = sine / tmp;
+ *c__ = cosine / tmp;
+ *sestpr = sqrt(t + 1.f) * absest;
+ return 0;
+ }
+
+ } else if (*job == 2) {
+
+/* Estimating smallest singular value */
+
+/* special cases */
+
+ if (*sest == 0.f) {
+ *sestpr = 0.f;
+ if (dmax(absgam,absalp) == 0.f) {
+ sine = 1.f;
+ cosine = 0.f;
+ } else {
+ sine = -(*gamma);
+ cosine = alpha;
+ }
+/* Computing MAX */
+ r__1 = dabs(sine), r__2 = dabs(cosine);
+ s1 = dmax(r__1,r__2);
+ *s = sine / s1;
+ *c__ = cosine / s1;
+ tmp = sqrt(*s * *s + *c__ * *c__);
+ *s /= tmp;
+ *c__ /= tmp;
+ return 0;
+ } else if (absgam <= eps * absest) {
+ *s = 0.f;
+ *c__ = 1.f;
+ *sestpr = absgam;
+ return 0;
+ } else if (absalp <= eps * absest) {
+ s1 = absgam;
+ s2 = absest;
+ if (s1 <= s2) {
+ *s = 0.f;
+ *c__ = 1.f;
+ *sestpr = s1;
+ } else {
+ *s = 1.f;
+ *c__ = 0.f;
+ *sestpr = s2;
+ }
+ return 0;
+ } else if (absest <= eps * absalp || absest <= eps * absgam) {
+ s1 = absgam;
+ s2 = absalp;
+ if (s1 <= s2) {
+ tmp = s1 / s2;
+ *c__ = sqrt(tmp * tmp + 1.f);
+ *sestpr = absest * (tmp / *c__);
+ *s = -(*gamma / s2) / *c__;
+ *c__ = r_sign(&c_b5, &alpha) / *c__;
+ } else {
+ tmp = s2 / s1;
+ *s = sqrt(tmp * tmp + 1.f);
+ *sestpr = absest / *s;
+ *c__ = alpha / s1 / *s;
+ *s = -r_sign(&c_b5, gamma) / *s;
+ }
+ return 0;
+ } else {
+
+/* normal case */
+
+ zeta1 = alpha / absest;
+ zeta2 = *gamma / absest;
+
+/* Computing MAX */
+ r__3 = zeta1 * zeta1 + 1.f + (r__1 = zeta1 * zeta2, dabs(r__1)),
+ r__4 = (r__2 = zeta1 * zeta2, dabs(r__2)) + zeta2 * zeta2;
+ norma = dmax(r__3,r__4);
+
+/* See if root is closer to zero or to ONE */
+
+ test = (zeta1 - zeta2) * 2.f * (zeta1 + zeta2) + 1.f;
+ if (test >= 0.f) {
+
+/* root is close to zero, compute directly */
+
+ b = (zeta1 * zeta1 + zeta2 * zeta2 + 1.f) * .5f;
+ *c__ = zeta2 * zeta2;
+ t = *c__ / (b + sqrt((r__1 = b * b - *c__, dabs(r__1))));
+ sine = zeta1 / (1.f - t);
+ cosine = -zeta2 / t;
+ *sestpr = sqrt(t + eps * 4.f * eps * norma) * absest;
+ } else {
+
+/* root is closer to ONE, shift by that amount */
+
+ b = (zeta2 * zeta2 + zeta1 * zeta1 - 1.f) * .5f;
+ *c__ = zeta1 * zeta1;
+ if (b >= 0.f) {
+ t = -(*c__) / (b + sqrt(b * b + *c__));
+ } else {
+ t = b - sqrt(b * b + *c__);
+ }
+ sine = -zeta1 / t;
+ cosine = -zeta2 / (t + 1.f);
+ *sestpr = sqrt(t + 1.f + eps * 4.f * eps * norma) * absest;
+ }
+ tmp = sqrt(sine * sine + cosine * cosine);
+ *s = sine / tmp;
+ *c__ = cosine / tmp;
+ return 0;
+
+ }
+ }
+ return 0;
+
+/* End of SLAIC1 */
+
+} /* slaic1_ */
diff --git a/SRC/slaisnan.c b/SRC/slaisnan.c
new file mode 100644
index 0000000..cb2b191
--- /dev/null
+++ b/SRC/slaisnan.c
@@ -0,0 +1,58 @@
+/* slaisnan.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+logical slaisnan_(real *sin1, real *sin2)
+{
+ /* System generated locals */
+ logical ret_val;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is not for general use. It exists solely to avoid */
+/* over-optimization in SISNAN. */
+
+/* SLAISNAN checks for NaNs by comparing its two arguments for */
+/* inequality. NaN is the only floating-point value where NaN != NaN */
+/* returns .TRUE. To check for NaNs, pass the same variable as both */
+/* arguments. */
+
+/* A compiler must assume that the two arguments are */
+/* not the same variable, and the test will not be optimized away. */
+/* Interprocedural or whole-program optimization may delete this */
+/* test. The ISNAN functions will be replaced by the correct */
+/* Fortran 03 intrinsic once the intrinsic is widely available. */
+
+/* Arguments */
+/* ========= */
+
+/* SIN1 (input) REAL */
+/* SIN2 (input) REAL */
+/* Two numbers to compare for inequality. */
+
+/* ===================================================================== */
+
+/* .. Executable Statements .. */
+ ret_val = *sin1 != *sin2;
+ return ret_val;
+} /* slaisnan_ */
diff --git a/SRC/slaln2.c b/SRC/slaln2.c
new file mode 100644
index 0000000..e1ebc2e
--- /dev/null
+++ b/SRC/slaln2.c
@@ -0,0 +1,577 @@
+/* slaln2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slaln2_(logical *ltrans, integer *na, integer *nw, real *
+ smin, real *ca, real *a, integer *lda, real *d1, real *d2, real *b,
+ integer *ldb, real *wr, real *wi, real *x, integer *ldx, real *scale,
+ real *xnorm, integer *info)
+{
+ /* Initialized data */
+
+ static logical cswap[4] = { FALSE_,FALSE_,TRUE_,TRUE_ };
+ static logical rswap[4] = { FALSE_,TRUE_,FALSE_,TRUE_ };
+ static integer ipivot[16] /* was [4][4] */ = { 1,2,3,4,2,1,4,3,3,4,1,2,
+ 4,3,2,1 };
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset;
+ real r__1, r__2, r__3, r__4, r__5, r__6;
+ static real equiv_0[4], equiv_1[4];
+
+ /* Local variables */
+ integer j;
+#define ci (equiv_0)
+#define cr (equiv_1)
+ real bi1, bi2, br1, br2, xi1, xi2, xr1, xr2, ci21, ci22, cr21, cr22, li21,
+ csi, ui11, lr21, ui12, ui22;
+#define civ (equiv_0)
+ real csr, ur11, ur12, ur22;
+#define crv (equiv_1)
+ real bbnd, cmax, ui11r, ui12s, temp, ur11r, ur12s, u22abs;
+ integer icmax;
+ real bnorm, cnorm, smini;
+ extern doublereal slamch_(char *);
+ real bignum;
+ extern /* Subroutine */ int sladiv_(real *, real *, real *, real *, real *
+, real *);
+ real smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLALN2 solves a system of the form (ca A - w D ) X = s B */
+/* or (ca A' - w D) X = s B with possible scaling ("s") and */
+/* perturbation of A. (A' means A-transpose.) */
+
+/* A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA */
+/* real diagonal matrix, w is a real or complex value, and X and B are */
+/* NA x 1 matrices -- real if w is real, complex if w is complex. NA */
+/* may be 1 or 2. */
+
+/* If w is complex, X and B are represented as NA x 2 matrices, */
+/* the first column of each being the real part and the second */
+/* being the imaginary part. */
+
+/* "s" is a scaling factor (.LE. 1), computed by SLALN2, which is */
+/* so chosen that X can be computed without overflow. X is further */
+/* scaled if necessary to assure that norm(ca A - w D)*norm(X) is less */
+/* than overflow. */
+
+/* If both singular values of (ca A - w D) are less than SMIN, */
+/* SMIN*identity will be used instead of (ca A - w D). If only one */
+/* singular value is less than SMIN, one element of (ca A - w D) will be */
+/* perturbed enough to make the smallest singular value roughly SMIN. */
+/* If both singular values are at least SMIN, (ca A - w D) will not be */
+/* perturbed. In any case, the perturbation will be at most some small */
+/* multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values */
+/* are computed by infinity-norm approximations, and thus will only be */
+/* correct to a factor of 2 or so. */
+
+/* Note: all input quantities are assumed to be smaller than overflow */
+/* by a reasonable factor. (See BIGNUM.) */
+
+/* Arguments */
+/* ========== */
+
+/* LTRANS (input) LOGICAL */
+/* =.TRUE.: A-transpose will be used. */
+/* =.FALSE.: A will be used (not transposed.) */
+
+/* NA (input) INTEGER */
+/* The size of the matrix A. It may (only) be 1 or 2. */
+
+/* NW (input) INTEGER */
+/* 1 if "w" is real, 2 if "w" is complex. It may only be 1 */
+/* or 2. */
+
+/* SMIN (input) REAL */
+/* The desired lower bound on the singular values of A. This */
+/* should be a safe distance away from underflow or overflow, */
+/* say, between (underflow/machine precision) and (machine */
+/* precision * overflow ). (See BIGNUM and ULP.) */
+
+/* CA (input) REAL */
+/* The coefficient c, which A is multiplied by. */
+
+/* A (input) REAL array, dimension (LDA,NA) */
+/* The NA x NA matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least NA. */
+
+/* D1 (input) REAL */
+/* The 1,1 element in the diagonal matrix D. */
+
+/* D2 (input) REAL */
+/* The 2,2 element in the diagonal matrix D. Not used if NW=1. */
+
+/* B (input) REAL array, dimension (LDB,NW) */
+/* The NA x NW matrix B (right-hand side). If NW=2 ("w" is */
+/* complex), column 1 contains the real part of B and column 2 */
+/* contains the imaginary part. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. It must be at least NA. */
+
+/* WR (input) REAL */
+/* The real part of the scalar "w". */
+
+/* WI (input) REAL */
+/* The imaginary part of the scalar "w". Not used if NW=1. */
+
+/* X (output) REAL array, dimension (LDX,NW) */
+/* The NA x NW matrix X (unknowns), as computed by SLALN2. */
+/* If NW=2 ("w" is complex), on exit, column 1 will contain */
+/* the real part of X and column 2 will contain the imaginary */
+/* part. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of X. It must be at least NA. */
+
+/* SCALE (output) REAL */
+/* The scale factor that B must be multiplied by to insure */
+/* that overflow does not occur when computing X. Thus, */
+/* (ca A - w D) X will be SCALE*B, not B (ignoring */
+/* perturbations of A.) It will be at most 1. */
+
+/* XNORM (output) REAL */
+/* The infinity-norm of X, when X is regarded as an NA x NW */
+/* real matrix. */
+
+/* INFO (output) INTEGER */
+/* An error flag. It will be set to zero if no error occurs, */
+/* a negative number if an argument is in error, or a positive */
+/* number if ca A - w D had to be perturbed. */
+/* The possible values are: */
+/* = 0: No error occurred, and (ca A - w D) did not have to be */
+/* perturbed. */
+/* = 1: (ca A - w D) had to be perturbed to make its smallest */
+/* (or only) singular value greater than SMIN. */
+/* NOTE: In the interests of speed, this routine does not */
+/* check the inputs for errors. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Equivalences .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Compute BIGNUM */
+
+ smlnum = 2.f * slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ smini = dmax(*smin,smlnum);
+
+/* Don't check for input errors */
+
+ *info = 0;
+
+/* Standard Initializations */
+
+ *scale = 1.f;
+
+ if (*na == 1) {
+
+/* 1 x 1 (i.e., scalar) system C X = B */
+
+ if (*nw == 1) {
+
+/* Real 1x1 system. */
+
+/* C = ca A - w D */
+
+ csr = *ca * a[a_dim1 + 1] - *wr * *d1;
+ cnorm = dabs(csr);
+
+/* If | C | < SMINI, use C = SMINI */
+
+ if (cnorm < smini) {
+ csr = smini;
+ cnorm = smini;
+ *info = 1;
+ }
+
+/* Check scaling for X = B / C */
+
+ bnorm = (r__1 = b[b_dim1 + 1], dabs(r__1));
+ if (cnorm < 1.f && bnorm > 1.f) {
+ if (bnorm > bignum * cnorm) {
+ *scale = 1.f / bnorm;
+ }
+ }
+
+/* Compute X */
+
+ x[x_dim1 + 1] = b[b_dim1 + 1] * *scale / csr;
+ *xnorm = (r__1 = x[x_dim1 + 1], dabs(r__1));
+ } else {
+
+/* Complex 1x1 system (w is complex) */
+
+/* C = ca A - w D */
+
+ csr = *ca * a[a_dim1 + 1] - *wr * *d1;
+ csi = -(*wi) * *d1;
+ cnorm = dabs(csr) + dabs(csi);
+
+/* If | C | < SMINI, use C = SMINI */
+
+ if (cnorm < smini) {
+ csr = smini;
+ csi = 0.f;
+ cnorm = smini;
+ *info = 1;
+ }
+
+/* Check scaling for X = B / C */
+
+ bnorm = (r__1 = b[b_dim1 + 1], dabs(r__1)) + (r__2 = b[(b_dim1 <<
+ 1) + 1], dabs(r__2));
+ if (cnorm < 1.f && bnorm > 1.f) {
+ if (bnorm > bignum * cnorm) {
+ *scale = 1.f / bnorm;
+ }
+ }
+
+/* Compute X */
+
+ r__1 = *scale * b[b_dim1 + 1];
+ r__2 = *scale * b[(b_dim1 << 1) + 1];
+ sladiv_(&r__1, &r__2, &csr, &csi, &x[x_dim1 + 1], &x[(x_dim1 << 1)
+ + 1]);
+ *xnorm = (r__1 = x[x_dim1 + 1], dabs(r__1)) + (r__2 = x[(x_dim1 <<
+ 1) + 1], dabs(r__2));
+ }
+
+ } else {
+
+/* 2x2 System */
+
+/* Compute the real part of C = ca A - w D (or ca A' - w D ) */
+
+ cr[0] = *ca * a[a_dim1 + 1] - *wr * *d1;
+ cr[3] = *ca * a[(a_dim1 << 1) + 2] - *wr * *d2;
+ if (*ltrans) {
+ cr[2] = *ca * a[a_dim1 + 2];
+ cr[1] = *ca * a[(a_dim1 << 1) + 1];
+ } else {
+ cr[1] = *ca * a[a_dim1 + 2];
+ cr[2] = *ca * a[(a_dim1 << 1) + 1];
+ }
+
+ if (*nw == 1) {
+
+/* Real 2x2 system (w is real) */
+
+/* Find the largest element in C */
+
+ cmax = 0.f;
+ icmax = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ if ((r__1 = crv[j - 1], dabs(r__1)) > cmax) {
+ cmax = (r__1 = crv[j - 1], dabs(r__1));
+ icmax = j;
+ }
+/* L10: */
+ }
+
+/* If norm(C) < SMINI, use SMINI*identity. */
+
+ if (cmax < smini) {
+/* Computing MAX */
+ r__3 = (r__1 = b[b_dim1 + 1], dabs(r__1)), r__4 = (r__2 = b[
+ b_dim1 + 2], dabs(r__2));
+ bnorm = dmax(r__3,r__4);
+ if (smini < 1.f && bnorm > 1.f) {
+ if (bnorm > bignum * smini) {
+ *scale = 1.f / bnorm;
+ }
+ }
+ temp = *scale / smini;
+ x[x_dim1 + 1] = temp * b[b_dim1 + 1];
+ x[x_dim1 + 2] = temp * b[b_dim1 + 2];
+ *xnorm = temp * bnorm;
+ *info = 1;
+ return 0;
+ }
+
+/* Gaussian elimination with complete pivoting. */
+
+ ur11 = crv[icmax - 1];
+ cr21 = crv[ipivot[(icmax << 2) - 3] - 1];
+ ur12 = crv[ipivot[(icmax << 2) - 2] - 1];
+ cr22 = crv[ipivot[(icmax << 2) - 1] - 1];
+ ur11r = 1.f / ur11;
+ lr21 = ur11r * cr21;
+ ur22 = cr22 - ur12 * lr21;
+
+/* If smaller pivot < SMINI, use SMINI */
+
+ if (dabs(ur22) < smini) {
+ ur22 = smini;
+ *info = 1;
+ }
+ if (rswap[icmax - 1]) {
+ br1 = b[b_dim1 + 2];
+ br2 = b[b_dim1 + 1];
+ } else {
+ br1 = b[b_dim1 + 1];
+ br2 = b[b_dim1 + 2];
+ }
+ br2 -= lr21 * br1;
+/* Computing MAX */
+ r__2 = (r__1 = br1 * (ur22 * ur11r), dabs(r__1)), r__3 = dabs(br2)
+ ;
+ bbnd = dmax(r__2,r__3);
+ if (bbnd > 1.f && dabs(ur22) < 1.f) {
+ if (bbnd >= bignum * dabs(ur22)) {
+ *scale = 1.f / bbnd;
+ }
+ }
+
+ xr2 = br2 * *scale / ur22;
+ xr1 = *scale * br1 * ur11r - xr2 * (ur11r * ur12);
+ if (cswap[icmax - 1]) {
+ x[x_dim1 + 1] = xr2;
+ x[x_dim1 + 2] = xr1;
+ } else {
+ x[x_dim1 + 1] = xr1;
+ x[x_dim1 + 2] = xr2;
+ }
+/* Computing MAX */
+ r__1 = dabs(xr1), r__2 = dabs(xr2);
+ *xnorm = dmax(r__1,r__2);
+
+/* Further scaling if norm(A) norm(X) > overflow */
+
+ if (*xnorm > 1.f && cmax > 1.f) {
+ if (*xnorm > bignum / cmax) {
+ temp = cmax / bignum;
+ x[x_dim1 + 1] = temp * x[x_dim1 + 1];
+ x[x_dim1 + 2] = temp * x[x_dim1 + 2];
+ *xnorm = temp * *xnorm;
+ *scale = temp * *scale;
+ }
+ }
+ } else {
+
+/* Complex 2x2 system (w is complex) */
+
+/* Find the largest element in C */
+
+ ci[0] = -(*wi) * *d1;
+ ci[1] = 0.f;
+ ci[2] = 0.f;
+ ci[3] = -(*wi) * *d2;
+ cmax = 0.f;
+ icmax = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ if ((r__1 = crv[j - 1], dabs(r__1)) + (r__2 = civ[j - 1],
+ dabs(r__2)) > cmax) {
+ cmax = (r__1 = crv[j - 1], dabs(r__1)) + (r__2 = civ[j -
+ 1], dabs(r__2));
+ icmax = j;
+ }
+/* L20: */
+ }
+
+/* If norm(C) < SMINI, use SMINI*identity. */
+
+ if (cmax < smini) {
+/* Computing MAX */
+ r__5 = (r__1 = b[b_dim1 + 1], dabs(r__1)) + (r__2 = b[(b_dim1
+ << 1) + 1], dabs(r__2)), r__6 = (r__3 = b[b_dim1 + 2],
+ dabs(r__3)) + (r__4 = b[(b_dim1 << 1) + 2], dabs(
+ r__4));
+ bnorm = dmax(r__5,r__6);
+ if (smini < 1.f && bnorm > 1.f) {
+ if (bnorm > bignum * smini) {
+ *scale = 1.f / bnorm;
+ }
+ }
+ temp = *scale / smini;
+ x[x_dim1 + 1] = temp * b[b_dim1 + 1];
+ x[x_dim1 + 2] = temp * b[b_dim1 + 2];
+ x[(x_dim1 << 1) + 1] = temp * b[(b_dim1 << 1) + 1];
+ x[(x_dim1 << 1) + 2] = temp * b[(b_dim1 << 1) + 2];
+ *xnorm = temp * bnorm;
+ *info = 1;
+ return 0;
+ }
+
+/* Gaussian elimination with complete pivoting. */
+
+ ur11 = crv[icmax - 1];
+ ui11 = civ[icmax - 1];
+ cr21 = crv[ipivot[(icmax << 2) - 3] - 1];
+ ci21 = civ[ipivot[(icmax << 2) - 3] - 1];
+ ur12 = crv[ipivot[(icmax << 2) - 2] - 1];
+ ui12 = civ[ipivot[(icmax << 2) - 2] - 1];
+ cr22 = crv[ipivot[(icmax << 2) - 1] - 1];
+ ci22 = civ[ipivot[(icmax << 2) - 1] - 1];
+ if (icmax == 1 || icmax == 4) {
+
+/* Code when off-diagonals of pivoted C are real */
+
+ if (dabs(ur11) > dabs(ui11)) {
+ temp = ui11 / ur11;
+/* Computing 2nd power */
+ r__1 = temp;
+ ur11r = 1.f / (ur11 * (r__1 * r__1 + 1.f));
+ ui11r = -temp * ur11r;
+ } else {
+ temp = ur11 / ui11;
+/* Computing 2nd power */
+ r__1 = temp;
+ ui11r = -1.f / (ui11 * (r__1 * r__1 + 1.f));
+ ur11r = -temp * ui11r;
+ }
+ lr21 = cr21 * ur11r;
+ li21 = cr21 * ui11r;
+ ur12s = ur12 * ur11r;
+ ui12s = ur12 * ui11r;
+ ur22 = cr22 - ur12 * lr21;
+ ui22 = ci22 - ur12 * li21;
+ } else {
+
+/* Code when diagonals of pivoted C are real */
+
+ ur11r = 1.f / ur11;
+ ui11r = 0.f;
+ lr21 = cr21 * ur11r;
+ li21 = ci21 * ur11r;
+ ur12s = ur12 * ur11r;
+ ui12s = ui12 * ur11r;
+ ur22 = cr22 - ur12 * lr21 + ui12 * li21;
+ ui22 = -ur12 * li21 - ui12 * lr21;
+ }
+ u22abs = dabs(ur22) + dabs(ui22);
+
+/* If smaller pivot < SMINI, use SMINI */
+
+ if (u22abs < smini) {
+ ur22 = smini;
+ ui22 = 0.f;
+ *info = 1;
+ }
+ if (rswap[icmax - 1]) {
+ br2 = b[b_dim1 + 1];
+ br1 = b[b_dim1 + 2];
+ bi2 = b[(b_dim1 << 1) + 1];
+ bi1 = b[(b_dim1 << 1) + 2];
+ } else {
+ br1 = b[b_dim1 + 1];
+ br2 = b[b_dim1 + 2];
+ bi1 = b[(b_dim1 << 1) + 1];
+ bi2 = b[(b_dim1 << 1) + 2];
+ }
+ br2 = br2 - lr21 * br1 + li21 * bi1;
+ bi2 = bi2 - li21 * br1 - lr21 * bi1;
+/* Computing MAX */
+ r__1 = (dabs(br1) + dabs(bi1)) * (u22abs * (dabs(ur11r) + dabs(
+ ui11r))), r__2 = dabs(br2) + dabs(bi2);
+ bbnd = dmax(r__1,r__2);
+ if (bbnd > 1.f && u22abs < 1.f) {
+ if (bbnd >= bignum * u22abs) {
+ *scale = 1.f / bbnd;
+ br1 = *scale * br1;
+ bi1 = *scale * bi1;
+ br2 = *scale * br2;
+ bi2 = *scale * bi2;
+ }
+ }
+
+ sladiv_(&br2, &bi2, &ur22, &ui22, &xr2, &xi2);
+ xr1 = ur11r * br1 - ui11r * bi1 - ur12s * xr2 + ui12s * xi2;
+ xi1 = ui11r * br1 + ur11r * bi1 - ui12s * xr2 - ur12s * xi2;
+ if (cswap[icmax - 1]) {
+ x[x_dim1 + 1] = xr2;
+ x[x_dim1 + 2] = xr1;
+ x[(x_dim1 << 1) + 1] = xi2;
+ x[(x_dim1 << 1) + 2] = xi1;
+ } else {
+ x[x_dim1 + 1] = xr1;
+ x[x_dim1 + 2] = xr2;
+ x[(x_dim1 << 1) + 1] = xi1;
+ x[(x_dim1 << 1) + 2] = xi2;
+ }
+/* Computing MAX */
+ r__1 = dabs(xr1) + dabs(xi1), r__2 = dabs(xr2) + dabs(xi2);
+ *xnorm = dmax(r__1,r__2);
+
+/* Further scaling if norm(A) norm(X) > overflow */
+
+ if (*xnorm > 1.f && cmax > 1.f) {
+ if (*xnorm > bignum / cmax) {
+ temp = cmax / bignum;
+ x[x_dim1 + 1] = temp * x[x_dim1 + 1];
+ x[x_dim1 + 2] = temp * x[x_dim1 + 2];
+ x[(x_dim1 << 1) + 1] = temp * x[(x_dim1 << 1) + 1];
+ x[(x_dim1 << 1) + 2] = temp * x[(x_dim1 << 1) + 2];
+ *xnorm = temp * *xnorm;
+ *scale = temp * *scale;
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SLALN2 */
+
+} /* slaln2_ */
+
+#undef crv
+#undef civ
+#undef cr
+#undef ci
diff --git a/SRC/slals0.c b/SRC/slals0.c
new file mode 100644
index 0000000..5d29eaa
--- /dev/null
+++ b/SRC/slals0.c
@@ -0,0 +1,470 @@
+/* slals0.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b5 = -1.f;
+static integer c__1 = 1;
+static real c_b11 = 1.f;
+static real c_b13 = 0.f;
+static integer c__0 = 0;
+
+/* Subroutine */ int slals0_(integer *icompq, integer *nl, integer *nr,
+ integer *sqre, integer *nrhs, real *b, integer *ldb, real *bx,
+ integer *ldbx, integer *perm, integer *givptr, integer *givcol,
+ integer *ldgcol, real *givnum, integer *ldgnum, real *poles, real *
+ difl, real *difr, real *z__, integer *k, real *c__, real *s, real *
+ work, integer *info)
+{
+ /* System generated locals */
+ integer givcol_dim1, givcol_offset, b_dim1, b_offset, bx_dim1, bx_offset,
+ difr_dim1, difr_offset, givnum_dim1, givnum_offset, poles_dim1,
+ poles_offset, i__1, i__2;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j, m, n;
+ real dj;
+ integer nlp1;
+ real temp;
+ extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
+ integer *, real *, real *);
+ extern doublereal snrm2_(integer *, real *, integer *);
+ real diflj, difrj, dsigj;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ sgemv_(char *, integer *, integer *, real *, real *, integer *,
+ real *, integer *, real *, real *, integer *), scopy_(
+ integer *, real *, integer *, real *, integer *);
+ extern doublereal slamc3_(real *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real dsigjp;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *,
+ real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLALS0 applies back the multiplying factors of either the left or the */
+/* right singular vector matrix of a diagonal matrix appended by a row */
+/* to the right hand side matrix B in solving the least squares problem */
+/* using the divide-and-conquer SVD approach. */
+
+/* For the left singular vector matrix, three types of orthogonal */
+/* matrices are involved: */
+
+/* (1L) Givens rotations: the number of such rotations is GIVPTR; the */
+/* pairs of columns/rows they were applied to are stored in GIVCOL; */
+/* and the C- and S-values of these rotations are stored in GIVNUM. */
+
+/* (2L) Permutation. The (NL+1)-st row of B is to be moved to the first */
+/* row, and for J=2:N, PERM(J)-th row of B is to be moved to the */
+/* J-th row. */
+
+/* (3L) The left singular vector matrix of the remaining matrix. */
+
+/* For the right singular vector matrix, four types of orthogonal */
+/* matrices are involved: */
+
+/* (1R) The right singular vector matrix of the remaining matrix. */
+
+/* (2R) If SQRE = 1, one extra Givens rotation to generate the right */
+/* null space. */
+
+/* (3R) The inverse transformation of (2L). */
+
+/* (4R) The inverse transformation of (1L). */
+
+/* Arguments */
+/* ========= */
+
+/* ICOMPQ (input) INTEGER */
+/* Specifies whether singular vectors are to be computed in */
+/* factored form: */
+/* = 0: Left singular vector matrix. */
+/* = 1: Right singular vector matrix. */
+
+/* NL (input) INTEGER */
+/* The row dimension of the upper block. NL >= 1. */
+
+/* NR (input) INTEGER */
+/* The row dimension of the lower block. NR >= 1. */
+
+/* SQRE (input) INTEGER */
+/* = 0: the lower block is an NR-by-NR square matrix. */
+/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */
+
+/* The bidiagonal matrix has row dimension N = NL + NR + 1, */
+/* and column dimension M = N + SQRE. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B and BX. NRHS must be at least 1. */
+
+/* B (input/output) REAL array, dimension ( LDB, NRHS ) */
+/* On input, B contains the right hand sides of the least */
+/* squares problem in rows 1 through M. On output, B contains */
+/* the solution X in rows 1 through N. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB must be at least */
+/* max(1,MAX( M, N ) ). */
+
+/* BX (workspace) REAL array, dimension ( LDBX, NRHS ) */
+
+/* LDBX (input) INTEGER */
+/* The leading dimension of BX. */
+
+/* PERM (input) INTEGER array, dimension ( N ) */
+/* The permutations (from deflation and sorting) applied */
+/* to the two blocks. */
+
+/* GIVPTR (input) INTEGER */
+/* The number of Givens rotations which took place in this */
+/* subproblem. */
+
+/* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 ) */
+/* Each pair of numbers indicates a pair of rows/columns */
+/* involved in a Givens rotation. */
+
+/* LDGCOL (input) INTEGER */
+/* The leading dimension of GIVCOL, must be at least N. */
+
+/* GIVNUM (input) REAL array, dimension ( LDGNUM, 2 ) */
+/* Each number indicates the C or S value used in the */
+/* corresponding Givens rotation. */
+
+/* LDGNUM (input) INTEGER */
+/* The leading dimension of arrays DIFR, POLES and */
+/* GIVNUM, must be at least K. */
+
+/* POLES (input) REAL array, dimension ( LDGNUM, 2 ) */
+/* On entry, POLES(1:K, 1) contains the new singular */
+/* values obtained from solving the secular equation, and */
+/* POLES(1:K, 2) is an array containing the poles in the secular */
+/* equation. */
+
+/* DIFL (input) REAL array, dimension ( K ). */
+/* On entry, DIFL(I) is the distance between I-th updated */
+/* (undeflated) singular value and the I-th (undeflated) old */
+/* singular value. */
+
+/* DIFR (input) REAL array, dimension ( LDGNUM, 2 ). */
+/* On entry, DIFR(I, 1) contains the distances between I-th */
+/* updated (undeflated) singular value and the I+1-th */
+/* (undeflated) old singular value. And DIFR(I, 2) is the */
+/* normalizing factor for the I-th right singular vector. */
+
+/* Z (input) REAL array, dimension ( K ) */
+/* Contain the components of the deflation-adjusted updating row */
+/* vector. */
+
+/* K (input) INTEGER */
+/* Contains the dimension of the non-deflated matrix, */
+/* This is the order of the related secular equation. 1 <= K <=N. */
+
+/* C (input) REAL */
+/* C contains garbage if SQRE =0 and the C-value of a Givens */
+/* rotation related to the right null space if SQRE = 1. */
+
+/* S (input) REAL */
+/* S contains garbage if SQRE =0 and the S-value of a Givens */
+/* rotation related to the right null space if SQRE = 1. */
+
+/* WORK (workspace) REAL array, dimension ( K ) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */
+/* California at Berkeley, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ bx_dim1 = *ldbx;
+ bx_offset = 1 + bx_dim1;
+ bx -= bx_offset;
+ --perm;
+ givcol_dim1 = *ldgcol;
+ givcol_offset = 1 + givcol_dim1;
+ givcol -= givcol_offset;
+ difr_dim1 = *ldgnum;
+ difr_offset = 1 + difr_dim1;
+ difr -= difr_offset;
+ poles_dim1 = *ldgnum;
+ poles_offset = 1 + poles_dim1;
+ poles -= poles_offset;
+ givnum_dim1 = *ldgnum;
+ givnum_offset = 1 + givnum_dim1;
+ givnum -= givnum_offset;
+ --difl;
+ --z__;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*icompq < 0 || *icompq > 1) {
+ *info = -1;
+ } else if (*nl < 1) {
+ *info = -2;
+ } else if (*nr < 1) {
+ *info = -3;
+ } else if (*sqre < 0 || *sqre > 1) {
+ *info = -4;
+ }
+
+ n = *nl + *nr + 1;
+
+ if (*nrhs < 1) {
+ *info = -5;
+ } else if (*ldb < n) {
+ *info = -7;
+ } else if (*ldbx < n) {
+ *info = -9;
+ } else if (*givptr < 0) {
+ *info = -11;
+ } else if (*ldgcol < n) {
+ *info = -13;
+ } else if (*ldgnum < n) {
+ *info = -15;
+ } else if (*k < 1) {
+ *info = -20;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLALS0", &i__1);
+ return 0;
+ }
+
+ m = n + *sqre;
+ nlp1 = *nl + 1;
+
+ if (*icompq == 0) {
+
+/* Apply back orthogonal transformations from the left. */
+
+/* Step (1L): apply back the Givens rotations performed. */
+
+ i__1 = *givptr;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ srot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, &
+ b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ +
+ (givnum_dim1 << 1)], &givnum[i__ + givnum_dim1]);
+/* L10: */
+ }
+
+/* Step (2L): permute rows of B. */
+
+ scopy_(nrhs, &b[nlp1 + b_dim1], ldb, &bx[bx_dim1 + 1], ldbx);
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ scopy_(nrhs, &b[perm[i__] + b_dim1], ldb, &bx[i__ + bx_dim1],
+ ldbx);
+/* L20: */
+ }
+
+/* Step (3L): apply the inverse of the left singular vector */
+/* matrix to BX. */
+
+ if (*k == 1) {
+ scopy_(nrhs, &bx[bx_offset], ldbx, &b[b_offset], ldb);
+ if (z__[1] < 0.f) {
+ sscal_(nrhs, &c_b5, &b[b_offset], ldb);
+ }
+ } else {
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ diflj = difl[j];
+ dj = poles[j + poles_dim1];
+ dsigj = -poles[j + (poles_dim1 << 1)];
+ if (j < *k) {
+ difrj = -difr[j + difr_dim1];
+ dsigjp = -poles[j + 1 + (poles_dim1 << 1)];
+ }
+ if (z__[j] == 0.f || poles[j + (poles_dim1 << 1)] == 0.f) {
+ work[j] = 0.f;
+ } else {
+ work[j] = -poles[j + (poles_dim1 << 1)] * z__[j] / diflj /
+ (poles[j + (poles_dim1 << 1)] + dj);
+ }
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (z__[i__] == 0.f || poles[i__ + (poles_dim1 << 1)] ==
+ 0.f) {
+ work[i__] = 0.f;
+ } else {
+ work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__]
+ / (slamc3_(&poles[i__ + (poles_dim1 << 1)], &
+ dsigj) - diflj) / (poles[i__ + (poles_dim1 <<
+ 1)] + dj);
+ }
+/* L30: */
+ }
+ i__2 = *k;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ if (z__[i__] == 0.f || poles[i__ + (poles_dim1 << 1)] ==
+ 0.f) {
+ work[i__] = 0.f;
+ } else {
+ work[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__]
+ / (slamc3_(&poles[i__ + (poles_dim1 << 1)], &
+ dsigjp) + difrj) / (poles[i__ + (poles_dim1 <<
+ 1)] + dj);
+ }
+/* L40: */
+ }
+ work[1] = -1.f;
+ temp = snrm2_(k, &work[1], &c__1);
+ sgemv_("T", k, nrhs, &c_b11, &bx[bx_offset], ldbx, &work[1], &
+ c__1, &c_b13, &b[j + b_dim1], ldb);
+ slascl_("G", &c__0, &c__0, &temp, &c_b11, &c__1, nrhs, &b[j +
+ b_dim1], ldb, info);
+/* L50: */
+ }
+ }
+
+/* Move the deflated rows of BX to B also. */
+
+ if (*k < max(m,n)) {
+ i__1 = n - *k;
+ slacpy_("A", &i__1, nrhs, &bx[*k + 1 + bx_dim1], ldbx, &b[*k + 1
+ + b_dim1], ldb);
+ }
+ } else {
+
+/* Apply back the right orthogonal transformations. */
+
+/* Step (1R): apply back the new right singular vector matrix */
+/* to B. */
+
+ if (*k == 1) {
+ scopy_(nrhs, &b[b_offset], ldb, &bx[bx_offset], ldbx);
+ } else {
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ dsigj = poles[j + (poles_dim1 << 1)];
+ if (z__[j] == 0.f) {
+ work[j] = 0.f;
+ } else {
+ work[j] = -z__[j] / difl[j] / (dsigj + poles[j +
+ poles_dim1]) / difr[j + (difr_dim1 << 1)];
+ }
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (z__[j] == 0.f) {
+ work[i__] = 0.f;
+ } else {
+ r__1 = -poles[i__ + 1 + (poles_dim1 << 1)];
+ work[i__] = z__[j] / (slamc3_(&dsigj, &r__1) - difr[
+ i__ + difr_dim1]) / (dsigj + poles[i__ +
+ poles_dim1]) / difr[i__ + (difr_dim1 << 1)];
+ }
+/* L60: */
+ }
+ i__2 = *k;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ if (z__[j] == 0.f) {
+ work[i__] = 0.f;
+ } else {
+ r__1 = -poles[i__ + (poles_dim1 << 1)];
+ work[i__] = z__[j] / (slamc3_(&dsigj, &r__1) - difl[
+ i__]) / (dsigj + poles[i__ + poles_dim1]) /
+ difr[i__ + (difr_dim1 << 1)];
+ }
+/* L70: */
+ }
+ sgemv_("T", k, nrhs, &c_b11, &b[b_offset], ldb, &work[1], &
+ c__1, &c_b13, &bx[j + bx_dim1], ldbx);
+/* L80: */
+ }
+ }
+
+/* Step (2R): if SQRE = 1, apply back the rotation that is */
+/* related to the right null space of the subproblem. */
+
+ if (*sqre == 1) {
+ scopy_(nrhs, &b[m + b_dim1], ldb, &bx[m + bx_dim1], ldbx);
+ srot_(nrhs, &bx[bx_dim1 + 1], ldbx, &bx[m + bx_dim1], ldbx, c__,
+ s);
+ }
+ if (*k < max(m,n)) {
+ i__1 = n - *k;
+ slacpy_("A", &i__1, nrhs, &b[*k + 1 + b_dim1], ldb, &bx[*k + 1 +
+ bx_dim1], ldbx);
+ }
+
+/* Step (3R): permute rows of B. */
+
+ scopy_(nrhs, &bx[bx_dim1 + 1], ldbx, &b[nlp1 + b_dim1], ldb);
+ if (*sqre == 1) {
+ scopy_(nrhs, &bx[m + bx_dim1], ldbx, &b[m + b_dim1], ldb);
+ }
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ scopy_(nrhs, &bx[i__ + bx_dim1], ldbx, &b[perm[i__] + b_dim1],
+ ldb);
+/* L90: */
+ }
+
+/* Step (4R): apply back the Givens rotations performed. */
+
+ for (i__ = *givptr; i__ >= 1; --i__) {
+ r__1 = -givnum[i__ + givnum_dim1];
+ srot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, &
+ b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ +
+ (givnum_dim1 << 1)], &r__1);
+/* L100: */
+ }
+ }
+
+ return 0;
+
+/* End of SLALS0 */
+
+} /* slals0_ */
diff --git a/SRC/slalsa.c b/SRC/slalsa.c
new file mode 100644
index 0000000..d349576
--- /dev/null
+++ b/SRC/slalsa.c
@@ -0,0 +1,454 @@
+/* slalsa.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b7 = 1.f;
+static real c_b8 = 0.f;
+static integer c__2 = 2;
+
+/* Subroutine */ int slalsa_(integer *icompq, integer *smlsiz, integer *n,
+ integer *nrhs, real *b, integer *ldb, real *bx, integer *ldbx, real *
+ u, integer *ldu, real *vt, integer *k, real *difl, real *difr, real *
+ z__, real *poles, integer *givptr, integer *givcol, integer *ldgcol,
+ integer *perm, real *givnum, real *c__, real *s, real *work, integer *
+ iwork, integer *info)
+{
+ /* System generated locals */
+ integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, b_dim1,
+ b_offset, bx_dim1, bx_offset, difl_dim1, difl_offset, difr_dim1,
+ difr_offset, givnum_dim1, givnum_offset, poles_dim1, poles_offset,
+ u_dim1, u_offset, vt_dim1, vt_offset, z_dim1, z_offset, i__1,
+ i__2;
+
+ /* Builtin functions */
+ integer pow_ii(integer *, integer *);
+
+ /* Local variables */
+ integer i__, j, i1, ic, lf, nd, ll, nl, nr, im1, nlf, nrf, lvl, ndb1,
+ nlp1, lvl2, nrp1, nlvl, sqre, inode, ndiml;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ integer ndimr;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), slals0_(integer *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *,
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, real *, real *, integer *, real *, real *, real *, integer *),
+ xerbla_(char *, integer *), slasdt_(integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLALSA is an itermediate step in solving the least squares problem */
+/* by computing the SVD of the coefficient matrix in compact form (The */
+/* singular vectors are computed as products of simple orthorgonal */
+/* matrices.). */
+
+/* If ICOMPQ = 0, SLALSA applies the inverse of the left singular vector */
+/* matrix of an upper bidiagonal matrix to the right hand side; and if */
+/* ICOMPQ = 1, SLALSA applies the right singular vector matrix to the */
+/* right hand side. The singular vector matrices were generated in */
+/* compact form by SLALSA. */
+
+/* Arguments */
+/* ========= */
+
+
+/* ICOMPQ (input) INTEGER */
+/* Specifies whether the left or the right singular vector */
+/* matrix is involved. */
+/* = 0: Left singular vector matrix */
+/* = 1: Right singular vector matrix */
+
+/* SMLSIZ (input) INTEGER */
+/* The maximum size of the subproblems at the bottom of the */
+/* computation tree. */
+
+/* N (input) INTEGER */
+/* The row and column dimensions of the upper bidiagonal matrix. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B and BX. NRHS must be at least 1. */
+
+/* B (input/output) REAL array, dimension ( LDB, NRHS ) */
+/* On input, B contains the right hand sides of the least */
+/* squares problem in rows 1 through M. */
+/* On output, B contains the solution X in rows 1 through N. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B in the calling subprogram. */
+/* LDB must be at least max(1,MAX( M, N ) ). */
+
+/* BX (output) REAL array, dimension ( LDBX, NRHS ) */
+/* On exit, the result of applying the left or right singular */
+/* vector matrix to B. */
+
+/* LDBX (input) INTEGER */
+/* The leading dimension of BX. */
+
+/* U (input) REAL array, dimension ( LDU, SMLSIZ ). */
+/* On entry, U contains the left singular vector matrices of all */
+/* subproblems at the bottom level. */
+
+/* LDU (input) INTEGER, LDU = > N. */
+/* The leading dimension of arrays U, VT, DIFL, DIFR, */
+/* POLES, GIVNUM, and Z. */
+
+/* VT (input) REAL array, dimension ( LDU, SMLSIZ+1 ). */
+/* On entry, VT' contains the right singular vector matrices of */
+/* all subproblems at the bottom level. */
+
+/* K (input) INTEGER array, dimension ( N ). */
+
+/* DIFL (input) REAL array, dimension ( LDU, NLVL ). */
+/* where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1. */
+
+/* DIFR (input) REAL array, dimension ( LDU, 2 * NLVL ). */
+/* On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record */
+/* distances between singular values on the I-th level and */
+/* singular values on the (I -1)-th level, and DIFR(*, 2 * I) */
+/* record the normalizing factors of the right singular vectors */
+/* matrices of subproblems on I-th level. */
+
+/* Z (input) REAL array, dimension ( LDU, NLVL ). */
+/* On entry, Z(1, I) contains the components of the deflation- */
+/* adjusted updating row vector for subproblems on the I-th */
+/* level. */
+
+/* POLES (input) REAL array, dimension ( LDU, 2 * NLVL ). */
+/* On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old */
+/* singular values involved in the secular equations on the I-th */
+/* level. */
+
+/* GIVPTR (input) INTEGER array, dimension ( N ). */
+/* On entry, GIVPTR( I ) records the number of Givens */
+/* rotations performed on the I-th problem on the computation */
+/* tree. */
+
+/* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ). */
+/* On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the */
+/* locations of Givens rotations performed on the I-th level on */
+/* the computation tree. */
+
+/* LDGCOL (input) INTEGER, LDGCOL = > N. */
+/* The leading dimension of arrays GIVCOL and PERM. */
+
+/* PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ). */
+/* On entry, PERM(*, I) records permutations done on the I-th */
+/* level of the computation tree. */
+
+/* GIVNUM (input) REAL array, dimension ( LDU, 2 * NLVL ). */
+/* On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S- */
+/* values of Givens rotations performed on the I-th level on the */
+/* computation tree. */
+
+/* C (input) REAL array, dimension ( N ). */
+/* On entry, if the I-th subproblem is not square, */
+/* C( I ) contains the C-value of a Givens rotation related to */
+/* the right null space of the I-th subproblem. */
+
+/* S (input) REAL array, dimension ( N ). */
+/* On entry, if the I-th subproblem is not square, */
+/* S( I ) contains the S-value of a Givens rotation related to */
+/* the right null space of the I-th subproblem. */
+
+/* WORK (workspace) REAL array. */
+/* The dimension must be at least N. */
+
+/* IWORK (workspace) INTEGER array. */
+/* The dimension must be at least 3 * N */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */
+/* California at Berkeley, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ bx_dim1 = *ldbx;
+ bx_offset = 1 + bx_dim1;
+ bx -= bx_offset;
+ givnum_dim1 = *ldu;
+ givnum_offset = 1 + givnum_dim1;
+ givnum -= givnum_offset;
+ poles_dim1 = *ldu;
+ poles_offset = 1 + poles_dim1;
+ poles -= poles_offset;
+ z_dim1 = *ldu;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ difr_dim1 = *ldu;
+ difr_offset = 1 + difr_dim1;
+ difr -= difr_offset;
+ difl_dim1 = *ldu;
+ difl_offset = 1 + difl_dim1;
+ difl -= difl_offset;
+ vt_dim1 = *ldu;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --k;
+ --givptr;
+ perm_dim1 = *ldgcol;
+ perm_offset = 1 + perm_dim1;
+ perm -= perm_offset;
+ givcol_dim1 = *ldgcol;
+ givcol_offset = 1 + givcol_dim1;
+ givcol -= givcol_offset;
+ --c__;
+ --s;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*icompq < 0 || *icompq > 1) {
+ *info = -1;
+ } else if (*smlsiz < 3) {
+ *info = -2;
+ } else if (*n < *smlsiz) {
+ *info = -3;
+ } else if (*nrhs < 1) {
+ *info = -4;
+ } else if (*ldb < *n) {
+ *info = -6;
+ } else if (*ldbx < *n) {
+ *info = -8;
+ } else if (*ldu < *n) {
+ *info = -10;
+ } else if (*ldgcol < *n) {
+ *info = -19;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLALSA", &i__1);
+ return 0;
+ }
+
+/* Book-keeping and setting up the computation tree. */
+
+ inode = 1;
+ ndiml = inode + *n;
+ ndimr = ndiml + *n;
+
+ slasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr],
+ smlsiz);
+
+/* The following code applies back the left singular vector factors. */
+/* For applying back the right singular vector factors, go to 50. */
+
+ if (*icompq == 1) {
+ goto L50;
+ }
+
+/* The nodes on the bottom level of the tree were solved */
+/* by SLASDQ. The corresponding left and right singular vector */
+/* matrices are in explicit form. First apply back the left */
+/* singular vector matrices. */
+
+ ndb1 = (nd + 1) / 2;
+ i__1 = nd;
+ for (i__ = ndb1; i__ <= i__1; ++i__) {
+
+/* IC : center row of each node */
+/* NL : number of rows of left subproblem */
+/* NR : number of rows of right subproblem */
+/* NLF: starting row of the left subproblem */
+/* NRF: starting row of the right subproblem */
+
+ i1 = i__ - 1;
+ ic = iwork[inode + i1];
+ nl = iwork[ndiml + i1];
+ nr = iwork[ndimr + i1];
+ nlf = ic - nl;
+ nrf = ic + 1;
+ sgemm_("T", "N", &nl, nrhs, &nl, &c_b7, &u[nlf + u_dim1], ldu, &b[nlf
+ + b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx);
+ sgemm_("T", "N", &nr, nrhs, &nr, &c_b7, &u[nrf + u_dim1], ldu, &b[nrf
+ + b_dim1], ldb, &c_b8, &bx[nrf + bx_dim1], ldbx);
+/* L10: */
+ }
+
+/* Next copy the rows of B that correspond to unchanged rows */
+/* in the bidiagonal matrix to BX. */
+
+ i__1 = nd;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ic = iwork[inode + i__ - 1];
+ scopy_(nrhs, &b[ic + b_dim1], ldb, &bx[ic + bx_dim1], ldbx);
+/* L20: */
+ }
+
+/* Finally go through the left singular vector matrices of all */
+/* the other subproblems bottom-up on the tree. */
+
+ j = pow_ii(&c__2, &nlvl);
+ sqre = 0;
+
+ for (lvl = nlvl; lvl >= 1; --lvl) {
+ lvl2 = (lvl << 1) - 1;
+
+/* find the first node LF and last node LL on */
+/* the current level LVL */
+
+ if (lvl == 1) {
+ lf = 1;
+ ll = 1;
+ } else {
+ i__1 = lvl - 1;
+ lf = pow_ii(&c__2, &i__1);
+ ll = (lf << 1) - 1;
+ }
+ i__1 = ll;
+ for (i__ = lf; i__ <= i__1; ++i__) {
+ im1 = i__ - 1;
+ ic = iwork[inode + im1];
+ nl = iwork[ndiml + im1];
+ nr = iwork[ndimr + im1];
+ nlf = ic - nl;
+ nrf = ic + 1;
+ --j;
+ slals0_(icompq, &nl, &nr, &sqre, nrhs, &bx[nlf + bx_dim1], ldbx, &
+ b[nlf + b_dim1], ldb, &perm[nlf + lvl * perm_dim1], &
+ givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, &
+ givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 *
+ poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf +
+ lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[
+ j], &s[j], &work[1], info);
+/* L30: */
+ }
+/* L40: */
+ }
+ goto L90;
+
+/* ICOMPQ = 1: applying back the right singular vector factors. */
+
+L50:
+
+/* First now go through the right singular vector matrices of all */
+/* the tree nodes top-down. */
+
+ j = 0;
+ i__1 = nlvl;
+ for (lvl = 1; lvl <= i__1; ++lvl) {
+ lvl2 = (lvl << 1) - 1;
+
+/* Find the first node LF and last node LL on */
+/* the current level LVL. */
+
+ if (lvl == 1) {
+ lf = 1;
+ ll = 1;
+ } else {
+ i__2 = lvl - 1;
+ lf = pow_ii(&c__2, &i__2);
+ ll = (lf << 1) - 1;
+ }
+ i__2 = lf;
+ for (i__ = ll; i__ >= i__2; --i__) {
+ im1 = i__ - 1;
+ ic = iwork[inode + im1];
+ nl = iwork[ndiml + im1];
+ nr = iwork[ndimr + im1];
+ nlf = ic - nl;
+ nrf = ic + 1;
+ if (i__ == ll) {
+ sqre = 0;
+ } else {
+ sqre = 1;
+ }
+ ++j;
+ slals0_(icompq, &nl, &nr, &sqre, nrhs, &b[nlf + b_dim1], ldb, &bx[
+ nlf + bx_dim1], ldbx, &perm[nlf + lvl * perm_dim1], &
+ givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, &
+ givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 *
+ poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf +
+ lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[
+ j], &s[j], &work[1], info);
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* The nodes on the bottom level of the tree were solved */
+/* by SLASDQ. The corresponding right singular vector */
+/* matrices are in explicit form. Apply them back. */
+
+ ndb1 = (nd + 1) / 2;
+ i__1 = nd;
+ for (i__ = ndb1; i__ <= i__1; ++i__) {
+ i1 = i__ - 1;
+ ic = iwork[inode + i1];
+ nl = iwork[ndiml + i1];
+ nr = iwork[ndimr + i1];
+ nlp1 = nl + 1;
+ if (i__ == nd) {
+ nrp1 = nr;
+ } else {
+ nrp1 = nr + 1;
+ }
+ nlf = ic - nl;
+ nrf = ic + 1;
+ sgemm_("T", "N", &nlp1, nrhs, &nlp1, &c_b7, &vt[nlf + vt_dim1], ldu, &
+ b[nlf + b_dim1], ldb, &c_b8, &bx[nlf + bx_dim1], ldbx);
+ sgemm_("T", "N", &nrp1, nrhs, &nrp1, &c_b7, &vt[nrf + vt_dim1], ldu, &
+ b[nrf + b_dim1], ldb, &c_b8, &bx[nrf + bx_dim1], ldbx);
+/* L80: */
+ }
+
+L90:
+
+ return 0;
+
+/* End of SLALSA */
+
+} /* slalsa_ */
diff --git a/SRC/slalsd.c b/SRC/slalsd.c
new file mode 100644
index 0000000..b90ddbf
--- /dev/null
+++ b/SRC/slalsd.c
@@ -0,0 +1,523 @@
+/* slalsd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b6 = 0.f;
+static integer c__0 = 0;
+static real c_b11 = 1.f;
+
+/* Subroutine */ int slalsd_(char *uplo, integer *smlsiz, integer *n, integer
+ *nrhs, real *d__, real *e, real *b, integer *ldb, real *rcond,
+ integer *rank, real *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2;
+ real r__1;
+
+ /* Builtin functions */
+ double log(doublereal), r_sign(real *, real *);
+
+ /* Local variables */
+ integer c__, i__, j, k;
+ real r__;
+ integer s, u, z__;
+ real cs;
+ integer bx;
+ real sn;
+ integer st, vt, nm1, st1;
+ real eps;
+ integer iwk;
+ real tol;
+ integer difl, difr;
+ real rcnd;
+ integer perm, nsub, nlvl, sqre, bxst;
+ extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
+ integer *, real *, real *), sgemm_(char *, char *, integer *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+, real *, real *, integer *);
+ integer poles, sizei, nsize;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ integer nwork, icmpq1, icmpq2;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int slasda_(integer *, integer *, integer *,
+ integer *, real *, real *, real *, integer *, real *, integer *,
+ real *, real *, real *, real *, integer *, integer *, integer *,
+ integer *, real *, real *, real *, real *, integer *, integer *),
+ xerbla_(char *, integer *), slalsa_(integer *, integer *,
+ integer *, integer *, real *, integer *, real *, integer *, real *
+, integer *, real *, integer *, real *, real *, real *, real *,
+ integer *, integer *, integer *, integer *, real *, real *, real *
+, real *, integer *, integer *), slascl_(char *, integer *,
+ integer *, real *, real *, integer *, integer *, real *, integer *
+, integer *);
+ integer givcol;
+ extern integer isamax_(integer *, real *, integer *);
+ extern /* Subroutine */ int slasdq_(char *, integer *, integer *, integer
+ *, integer *, integer *, real *, real *, real *, integer *, real *
+, integer *, real *, integer *, real *, integer *),
+ slacpy_(char *, integer *, integer *, real *, integer *, real *,
+ integer *), slartg_(real *, real *, real *, real *, real *
+), slaset_(char *, integer *, integer *, real *, real *, real *,
+ integer *);
+ real orgnrm;
+ integer givnum;
+ extern doublereal slanst_(char *, integer *, real *, real *);
+ extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *);
+ integer givptr, smlszp;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLALSD uses the singular value decomposition of A to solve the least */
+/* squares problem of finding X to minimize the Euclidean norm of each */
+/* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B */
+/* are N-by-NRHS. The solution X overwrites B. */
+
+/* The singular values of A smaller than RCOND times the largest */
+/* singular value are treated as zero in solving the least squares */
+/* problem; in this case a minimum norm solution is returned. */
+/* The actual singular values are returned in D in ascending order. */
+
+/* This code makes very mild assumptions about floating point */
+/* arithmetic. It will work on machines with a guard digit in */
+/* add/subtract, or on those binary machines without guard digits */
+/* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. */
+/* It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': D and E define an upper bidiagonal matrix. */
+/* = 'L': D and E define a lower bidiagonal matrix. */
+
+/* SMLSIZ (input) INTEGER */
+/* The maximum size of the subproblems at the bottom of the */
+/* computation tree. */
+
+/* N (input) INTEGER */
+/* The dimension of the bidiagonal matrix. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS must be at least 1. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry D contains the main diagonal of the bidiagonal */
+/* matrix. On exit, if INFO = 0, D contains its singular values. */
+
+/* E (input/output) REAL array, dimension (N-1) */
+/* Contains the super-diagonal entries of the bidiagonal matrix. */
+/* On exit, E has been destroyed. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On input, B contains the right hand sides of the least */
+/* squares problem. On output, B contains the solution X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B in the calling subprogram. */
+/* LDB must be at least max(1,N). */
+
+/* RCOND (input) REAL */
+/* The singular values of A less than or equal to RCOND times */
+/* the largest singular value are treated as zero in solving */
+/* the least squares problem. If RCOND is negative, */
+/* machine precision is used instead. */
+/* For example, if diag(S)*X=B were the least squares problem, */
+/* where diag(S) is a diagonal matrix of singular values, the */
+/* solution would be X(i) = B(i) / S(i) if S(i) is greater than */
+/* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to */
+/* RCOND*max(S). */
+
+/* RANK (output) INTEGER */
+/* The number of singular values of A greater than RCOND times */
+/* the largest singular value. */
+
+/* WORK (workspace) REAL array, dimension at least */
+/* (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2), */
+/* where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1). */
+
+/* IWORK (workspace) INTEGER array, dimension at least */
+/* (3*N*NLVL + 11*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: The algorithm failed to compute an singular value while */
+/* working on the submatrix lying in rows and columns */
+/* INFO/(N+1) through MOD(INFO,N+1). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */
+/* California at Berkeley, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 1) {
+ *info = -4;
+ } else if (*ldb < 1 || *ldb < *n) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLALSD", &i__1);
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+
+/* Set up the tolerance. */
+
+ if (*rcond <= 0.f || *rcond >= 1.f) {
+ rcnd = eps;
+ } else {
+ rcnd = *rcond;
+ }
+
+ *rank = 0;
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ } else if (*n == 1) {
+ if (d__[1] == 0.f) {
+ slaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[b_offset], ldb);
+ } else {
+ *rank = 1;
+ slascl_("G", &c__0, &c__0, &d__[1], &c_b11, &c__1, nrhs, &b[
+ b_offset], ldb, info);
+ d__[1] = dabs(d__[1]);
+ }
+ return 0;
+ }
+
+/* Rotate the matrix if it is lower bidiagonal. */
+
+ if (*(unsigned char *)uplo == 'L') {
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ slartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
+ d__[i__] = r__;
+ e[i__] = sn * d__[i__ + 1];
+ d__[i__ + 1] = cs * d__[i__ + 1];
+ if (*nrhs == 1) {
+ srot_(&c__1, &b[i__ + b_dim1], &c__1, &b[i__ + 1 + b_dim1], &
+ c__1, &cs, &sn);
+ } else {
+ work[(i__ << 1) - 1] = cs;
+ work[i__ * 2] = sn;
+ }
+/* L10: */
+ }
+ if (*nrhs > 1) {
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n - 1;
+ for (j = 1; j <= i__2; ++j) {
+ cs = work[(j << 1) - 1];
+ sn = work[j * 2];
+ srot_(&c__1, &b[j + i__ * b_dim1], &c__1, &b[j + 1 + i__ *
+ b_dim1], &c__1, &cs, &sn);
+/* L20: */
+ }
+/* L30: */
+ }
+ }
+ }
+
+/* Scale. */
+
+ nm1 = *n - 1;
+ orgnrm = slanst_("M", n, &d__[1], &e[1]);
+ if (orgnrm == 0.f) {
+ slaset_("A", n, nrhs, &c_b6, &c_b6, &b[b_offset], ldb);
+ return 0;
+ }
+
+ slascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, &c__1, &d__[1], n, info);
+ slascl_("G", &c__0, &c__0, &orgnrm, &c_b11, &nm1, &c__1, &e[1], &nm1,
+ info);
+
+/* If N is smaller than the minimum divide size SMLSIZ, then solve */
+/* the problem with another solver. */
+
+ if (*n <= *smlsiz) {
+ nwork = *n * *n + 1;
+ slaset_("A", n, n, &c_b6, &c_b11, &work[1], n);
+ slasdq_("U", &c__0, n, n, &c__0, nrhs, &d__[1], &e[1], &work[1], n, &
+ work[1], n, &b[b_offset], ldb, &work[nwork], info);
+ if (*info != 0) {
+ return 0;
+ }
+ tol = rcnd * (r__1 = d__[isamax_(n, &d__[1], &c__1)], dabs(r__1));
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (d__[i__] <= tol) {
+ slaset_("A", &c__1, nrhs, &c_b6, &c_b6, &b[i__ + b_dim1], ldb);
+ } else {
+ slascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &b[
+ i__ + b_dim1], ldb, info);
+ ++(*rank);
+ }
+/* L40: */
+ }
+ sgemm_("T", "N", n, nrhs, n, &c_b11, &work[1], n, &b[b_offset], ldb, &
+ c_b6, &work[nwork], n);
+ slacpy_("A", n, nrhs, &work[nwork], n, &b[b_offset], ldb);
+
+/* Unscale. */
+
+ slascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n,
+ info);
+ slasrt_("D", n, &d__[1], info);
+ slascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset],
+ ldb, info);
+
+ return 0;
+ }
+
+/* Book-keeping and setting up some constants. */
+
+ nlvl = (integer) (log((real) (*n) / (real) (*smlsiz + 1)) / log(2.f)) + 1;
+
+ smlszp = *smlsiz + 1;
+
+ u = 1;
+ vt = *smlsiz * *n + 1;
+ difl = vt + smlszp * *n;
+ difr = difl + nlvl * *n;
+ z__ = difr + (nlvl * *n << 1);
+ c__ = z__ + nlvl * *n;
+ s = c__ + *n;
+ poles = s + *n;
+ givnum = poles + (nlvl << 1) * *n;
+ bx = givnum + (nlvl << 1) * *n;
+ nwork = bx + *n * *nrhs;
+
+ sizei = *n + 1;
+ k = sizei + *n;
+ givptr = k + *n;
+ perm = givptr + *n;
+ givcol = perm + nlvl * *n;
+ iwk = givcol + (nlvl * *n << 1);
+
+ st = 1;
+ sqre = 0;
+ icmpq1 = 1;
+ icmpq2 = 0;
+ nsub = 0;
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((r__1 = d__[i__], dabs(r__1)) < eps) {
+ d__[i__] = r_sign(&eps, &d__[i__]);
+ }
+/* L50: */
+ }
+
+ i__1 = nm1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((r__1 = e[i__], dabs(r__1)) < eps || i__ == nm1) {
+ ++nsub;
+ iwork[nsub] = st;
+
+/* Subproblem found. First determine its size and then */
+/* apply divide and conquer on it. */
+
+ if (i__ < nm1) {
+
+/* A subproblem with E(I) small for I < NM1. */
+
+ nsize = i__ - st + 1;
+ iwork[sizei + nsub - 1] = nsize;
+ } else if ((r__1 = e[i__], dabs(r__1)) >= eps) {
+
+/* A subproblem with E(NM1) not too small but I = NM1. */
+
+ nsize = *n - st + 1;
+ iwork[sizei + nsub - 1] = nsize;
+ } else {
+
+/* A subproblem with E(NM1) small. This implies an */
+/* 1-by-1 subproblem at D(N), which is not solved */
+/* explicitly. */
+
+ nsize = i__ - st + 1;
+ iwork[sizei + nsub - 1] = nsize;
+ ++nsub;
+ iwork[nsub] = *n;
+ iwork[sizei + nsub - 1] = 1;
+ scopy_(nrhs, &b[*n + b_dim1], ldb, &work[bx + nm1], n);
+ }
+ st1 = st - 1;
+ if (nsize == 1) {
+
+/* This is a 1-by-1 subproblem and is not solved */
+/* explicitly. */
+
+ scopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n);
+ } else if (nsize <= *smlsiz) {
+
+/* This is a small subproblem and is solved by SLASDQ. */
+
+ slaset_("A", &nsize, &nsize, &c_b6, &c_b11, &work[vt + st1],
+ n);
+ slasdq_("U", &c__0, &nsize, &nsize, &c__0, nrhs, &d__[st], &e[
+ st], &work[vt + st1], n, &work[nwork], n, &b[st +
+ b_dim1], ldb, &work[nwork], info);
+ if (*info != 0) {
+ return 0;
+ }
+ slacpy_("A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx +
+ st1], n);
+ } else {
+
+/* A large problem. Solve it using divide and conquer. */
+
+ slasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], &
+ work[u + st1], n, &work[vt + st1], &iwork[k + st1], &
+ work[difl + st1], &work[difr + st1], &work[z__ + st1],
+ &work[poles + st1], &iwork[givptr + st1], &iwork[
+ givcol + st1], n, &iwork[perm + st1], &work[givnum +
+ st1], &work[c__ + st1], &work[s + st1], &work[nwork],
+ &iwork[iwk], info);
+ if (*info != 0) {
+ return 0;
+ }
+ bxst = bx + st1;
+ slalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b[st + b_dim1], ldb, &
+ work[bxst], n, &work[u + st1], n, &work[vt + st1], &
+ iwork[k + st1], &work[difl + st1], &work[difr + st1],
+ &work[z__ + st1], &work[poles + st1], &iwork[givptr +
+ st1], &iwork[givcol + st1], n, &iwork[perm + st1], &
+ work[givnum + st1], &work[c__ + st1], &work[s + st1],
+ &work[nwork], &iwork[iwk], info);
+ if (*info != 0) {
+ return 0;
+ }
+ }
+ st = i__ + 1;
+ }
+/* L60: */
+ }
+
+/* Apply the singular values and treat the tiny ones as zero. */
+
+ tol = rcnd * (r__1 = d__[isamax_(n, &d__[1], &c__1)], dabs(r__1));
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Some of the elements in D can be negative because 1-by-1 */
+/* subproblems were not solved explicitly. */
+
+ if ((r__1 = d__[i__], dabs(r__1)) <= tol) {
+ slaset_("A", &c__1, nrhs, &c_b6, &c_b6, &work[bx + i__ - 1], n);
+ } else {
+ ++(*rank);
+ slascl_("G", &c__0, &c__0, &d__[i__], &c_b11, &c__1, nrhs, &work[
+ bx + i__ - 1], n, info);
+ }
+ d__[i__] = (r__1 = d__[i__], dabs(r__1));
+/* L70: */
+ }
+
+/* Now apply back the right singular vectors. */
+
+ icmpq2 = 1;
+ i__1 = nsub;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ st = iwork[i__];
+ st1 = st - 1;
+ nsize = iwork[sizei + i__ - 1];
+ bxst = bx + st1;
+ if (nsize == 1) {
+ scopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb);
+ } else if (nsize <= *smlsiz) {
+ sgemm_("T", "N", &nsize, nrhs, &nsize, &c_b11, &work[vt + st1], n,
+ &work[bxst], n, &c_b6, &b[st + b_dim1], ldb);
+ } else {
+ slalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b[st +
+ b_dim1], ldb, &work[u + st1], n, &work[vt + st1], &iwork[
+ k + st1], &work[difl + st1], &work[difr + st1], &work[z__
+ + st1], &work[poles + st1], &iwork[givptr + st1], &iwork[
+ givcol + st1], n, &iwork[perm + st1], &work[givnum + st1],
+ &work[c__ + st1], &work[s + st1], &work[nwork], &iwork[
+ iwk], info);
+ if (*info != 0) {
+ return 0;
+ }
+ }
+/* L80: */
+ }
+
+/* Unscale and sort the singular values. */
+
+ slascl_("G", &c__0, &c__0, &c_b11, &orgnrm, n, &c__1, &d__[1], n, info);
+ slasrt_("D", n, &d__[1], info);
+ slascl_("G", &c__0, &c__0, &orgnrm, &c_b11, n, nrhs, &b[b_offset], ldb,
+ info);
+
+ return 0;
+
+/* End of SLALSD */
+
+} /* slalsd_ */
diff --git a/SRC/slamrg.c b/SRC/slamrg.c
new file mode 100644
index 0000000..4dfffc5
--- /dev/null
+++ b/SRC/slamrg.c
@@ -0,0 +1,131 @@
+/* slamrg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slamrg_(integer *n1, integer *n2, real *a, integer *
+ strd1, integer *strd2, integer *index)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, ind1, ind2, n1sv, n2sv;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAMRG will create a permutation list which will merge the elements */
+/* of A (which is composed of two independently sorted sets) into a */
+/* single set which is sorted in ascending order. */
+
+/* Arguments */
+/* ========= */
+
+/* N1 (input) INTEGER */
+/* N2 (input) INTEGER */
+/* These arguements contain the respective lengths of the two */
+/* sorted lists to be merged. */
+
+/* A (input) REAL array, dimension (N1+N2) */
+/* The first N1 elements of A contain a list of numbers which */
+/* are sorted in either ascending or descending order. Likewise */
+/* for the final N2 elements. */
+
+/* STRD1 (input) INTEGER */
+/* STRD2 (input) INTEGER */
+/* These are the strides to be taken through the array A. */
+/* Allowable strides are 1 and -1. They indicate whether a */
+/* subset of A is sorted in ascending (STRDx = 1) or descending */
+/* (STRDx = -1) order. */
+
+/* INDEX (output) INTEGER array, dimension (N1+N2) */
+/* On exit this array will contain a permutation such that */
+/* if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be */
+/* sorted in ascending order. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --index;
+ --a;
+
+ /* Function Body */
+ n1sv = *n1;
+ n2sv = *n2;
+ if (*strd1 > 0) {
+ ind1 = 1;
+ } else {
+ ind1 = *n1;
+ }
+ if (*strd2 > 0) {
+ ind2 = *n1 + 1;
+ } else {
+ ind2 = *n1 + *n2;
+ }
+ i__ = 1;
+/* while ( (N1SV > 0) & (N2SV > 0) ) */
+L10:
+ if (n1sv > 0 && n2sv > 0) {
+ if (a[ind1] <= a[ind2]) {
+ index[i__] = ind1;
+ ++i__;
+ ind1 += *strd1;
+ --n1sv;
+ } else {
+ index[i__] = ind2;
+ ++i__;
+ ind2 += *strd2;
+ --n2sv;
+ }
+ goto L10;
+ }
+/* end while */
+ if (n1sv == 0) {
+ i__1 = n2sv;
+ for (n1sv = 1; n1sv <= i__1; ++n1sv) {
+ index[i__] = ind2;
+ ++i__;
+ ind2 += *strd2;
+/* L20: */
+ }
+ } else {
+/* N2SV .EQ. 0 */
+ i__1 = n1sv;
+ for (n2sv = 1; n2sv <= i__1; ++n2sv) {
+ index[i__] = ind1;
+ ++i__;
+ ind1 += *strd1;
+/* L30: */
+ }
+ }
+
+ return 0;
+
+/* End of SLAMRG */
+
+} /* slamrg_ */
diff --git a/SRC/slaneg.c b/SRC/slaneg.c
new file mode 100644
index 0000000..2b1d242
--- /dev/null
+++ b/SRC/slaneg.c
@@ -0,0 +1,218 @@
+/* slaneg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer slaneg_(integer *n, real *d__, real *lld, real *sigma, real *pivmin,
+ integer *r__)
+{
+ /* System generated locals */
+ integer ret_val, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer j;
+ real p, t;
+ integer bj;
+ real tmp;
+ integer neg1, neg2;
+ real bsav, gamma, dplus;
+ integer negcnt;
+ logical sawnan;
+ extern logical sisnan_(real *);
+ real dminus;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLANEG computes the Sturm count, the number of negative pivots */
+/* encountered while factoring tridiagonal T - sigma I = L D L^T. */
+/* This implementation works directly on the factors without forming */
+/* the tridiagonal matrix T. The Sturm count is also the number of */
+/* eigenvalues of T less than sigma. */
+
+/* This routine is called from SLARRB. */
+
+/* The current routine does not use the PIVMIN parameter but rather */
+/* requires IEEE-754 propagation of Infinities and NaNs. This */
+/* routine also has no input range restrictions but does require */
+/* default exception handling such that x/0 produces Inf when x is */
+/* non-zero, and Inf/Inf produces NaN. For more information, see: */
+
+/* Marques, Riedy, and Voemel, "Benefits of IEEE-754 Features in */
+/* Modern Symmetric Tridiagonal Eigensolvers," SIAM Journal on */
+/* Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624 */
+/* (Tech report version in LAWN 172 with the same title.) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. */
+
+/* D (input) REAL array, dimension (N) */
+/* The N diagonal elements of the diagonal matrix D. */
+
+/* LLD (input) REAL array, dimension (N-1) */
+/* The (N-1) elements L(i)*L(i)*D(i). */
+
+/* SIGMA (input) REAL */
+/* Shift amount in T - sigma I = L D L^T. */
+
+/* PIVMIN (input) REAL */
+/* The minimum pivot in the Sturm sequence. May be used */
+/* when zero pivots are encountered on non-IEEE-754 */
+/* architectures. */
+
+/* R (input) INTEGER */
+/* The twist index for the twisted factorization that is used */
+/* for the negcount. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+/* Jason Riedy, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* Some architectures propagate Infinities and NaNs very slowly, so */
+/* the code computes counts in BLKLEN chunks. Then a NaN can */
+/* propagate at most BLKLEN columns before being detected. This is */
+/* not a general tuning parameter; it needs only to be just large */
+/* enough that the overhead is tiny in common cases. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ --lld;
+ --d__;
+
+ /* Function Body */
+ negcnt = 0;
+/* I) upper part: L D L^T - SIGMA I = L+ D+ L+^T */
+ t = -(*sigma);
+ i__1 = *r__ - 1;
+ for (bj = 1; bj <= i__1; bj += 128) {
+ neg1 = 0;
+ bsav = t;
+/* Computing MIN */
+ i__3 = bj + 127, i__4 = *r__ - 1;
+ i__2 = min(i__3,i__4);
+ for (j = bj; j <= i__2; ++j) {
+ dplus = d__[j] + t;
+ if (dplus < 0.f) {
+ ++neg1;
+ }
+ tmp = t / dplus;
+ t = tmp * lld[j] - *sigma;
+/* L21: */
+ }
+ sawnan = sisnan_(&t);
+/* Run a slower version of the above loop if a NaN is detected. */
+/* A NaN should occur only with a zero pivot after an infinite */
+/* pivot. In that case, substituting 1 for T/DPLUS is the */
+/* correct limit. */
+ if (sawnan) {
+ neg1 = 0;
+ t = bsav;
+/* Computing MIN */
+ i__3 = bj + 127, i__4 = *r__ - 1;
+ i__2 = min(i__3,i__4);
+ for (j = bj; j <= i__2; ++j) {
+ dplus = d__[j] + t;
+ if (dplus < 0.f) {
+ ++neg1;
+ }
+ tmp = t / dplus;
+ if (sisnan_(&tmp)) {
+ tmp = 1.f;
+ }
+ t = tmp * lld[j] - *sigma;
+/* L22: */
+ }
+ }
+ negcnt += neg1;
+/* L210: */
+ }
+
+/* II) lower part: L D L^T - SIGMA I = U- D- U-^T */
+ p = d__[*n] - *sigma;
+ i__1 = *r__;
+ for (bj = *n - 1; bj >= i__1; bj += -128) {
+ neg2 = 0;
+ bsav = p;
+/* Computing MAX */
+ i__3 = bj - 127;
+ i__2 = max(i__3,*r__);
+ for (j = bj; j >= i__2; --j) {
+ dminus = lld[j] + p;
+ if (dminus < 0.f) {
+ ++neg2;
+ }
+ tmp = p / dminus;
+ p = tmp * d__[j] - *sigma;
+/* L23: */
+ }
+ sawnan = sisnan_(&p);
+/* As above, run a slower version that substitutes 1 for Inf/Inf. */
+
+ if (sawnan) {
+ neg2 = 0;
+ p = bsav;
+/* Computing MAX */
+ i__3 = bj - 127;
+ i__2 = max(i__3,*r__);
+ for (j = bj; j >= i__2; --j) {
+ dminus = lld[j] + p;
+ if (dminus < 0.f) {
+ ++neg2;
+ }
+ tmp = p / dminus;
+ if (sisnan_(&tmp)) {
+ tmp = 1.f;
+ }
+ p = tmp * d__[j] - *sigma;
+/* L24: */
+ }
+ }
+ negcnt += neg2;
+/* L230: */
+ }
+
+/* III) Twist index */
+/* T was shifted by SIGMA initially. */
+ gamma = t + *sigma + p;
+ if (gamma < 0.f) {
+ ++negcnt;
+ }
+ ret_val = negcnt;
+ return ret_val;
+} /* slaneg_ */
diff --git a/SRC/slangb.c b/SRC/slangb.c
new file mode 100644
index 0000000..eaa27b8
--- /dev/null
+++ b/SRC/slangb.c
@@ -0,0 +1,226 @@
+/* slangb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal slangb_(char *norm, integer *n, integer *kl, integer *ku, real *ab,
+ integer *ldab, real *work)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real ret_val, r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, l;
+ real sum, scale;
+ extern logical lsame_(char *, char *);
+ real value;
+ extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
+ real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLANGB returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of an */
+/* n by n band matrix A, with kl sub-diagonals and ku super-diagonals. */
+
+/* Description */
+/* =========== */
+
+/* SLANGB returns the value */
+
+/* SLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in SLANGB as described */
+/* above. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, SLANGB is */
+/* set to zero. */
+
+/* KL (input) INTEGER */
+/* The number of sub-diagonals of the matrix A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of super-diagonals of the matrix A. KU >= 0. */
+
+/* AB (input) REAL array, dimension (LDAB,N) */
+/* The band matrix A, stored in rows 1 to KL+KU+1. The j-th */
+/* column of A is stored in the j-th column of the array AB as */
+/* follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = *ku + 2 - j;
+/* Computing MIN */
+ i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1;
+ i__3 = min(i__4,i__5);
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1], dabs(r__1)
+ );
+ value = dmax(r__2,r__3);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.f;
+/* Computing MAX */
+ i__3 = *ku + 2 - j;
+/* Computing MIN */
+ i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1;
+ i__2 = min(i__4,i__5);
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+ sum += (r__1 = ab[i__ + j * ab_dim1], dabs(r__1));
+/* L30: */
+ }
+ value = dmax(value,sum);
+/* L40: */
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L50: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ k = *ku + 1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *ku;
+/* Computing MIN */
+ i__5 = *n, i__6 = j + *kl;
+ i__4 = min(i__5,i__6);
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ work[i__] += (r__1 = ab[k + i__ + j * ab_dim1], dabs(r__1));
+/* L60: */
+ }
+/* L70: */
+ }
+ value = 0.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = work[i__];
+ value = dmax(r__1,r__2);
+/* L80: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.f;
+ sum = 1.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *ku;
+ l = max(i__4,i__2);
+ k = *ku + 1 - j + l;
+/* Computing MIN */
+ i__2 = *n, i__3 = j + *kl;
+ i__4 = min(i__2,i__3) - l + 1;
+ slassq_(&i__4, &ab[k + j * ab_dim1], &c__1, &scale, &sum);
+/* L90: */
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of SLANGB */
+
+} /* slangb_ */
diff --git a/SRC/slange.c b/SRC/slange.c
new file mode 100644
index 0000000..621cb2a
--- /dev/null
+++ b/SRC/slange.c
@@ -0,0 +1,199 @@
+/* slange.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal slange_(char *norm, integer *m, integer *n, real *a, integer *lda,
+ real *work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real ret_val, r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ real sum, scale;
+ extern logical lsame_(char *, char *);
+ real value;
+ extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
+ real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLANGE returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* real matrix A. */
+
+/* Description */
+/* =========== */
+
+/* SLANGE returns the value */
+
+/* SLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in SLANGE as described */
+/* above. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. When M = 0, */
+/* SLANGE is set to zero. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. When N = 0, */
+/* SLANGE is set to zero. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(M,1). */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ if (min(*m,*n) == 0) {
+ value = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ value = dmax(r__2,r__3);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.f;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ sum += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+/* L30: */
+ }
+ value = dmax(value,sum);
+/* L40: */
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L50: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+/* L60: */
+ }
+/* L70: */
+ }
+ value = 0.f;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = work[i__];
+ value = dmax(r__1,r__2);
+/* L80: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.f;
+ sum = 1.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ slassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
+/* L90: */
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of SLANGE */
+
+} /* slange_ */
diff --git a/SRC/slangt.c b/SRC/slangt.c
new file mode 100644
index 0000000..1d225b5
--- /dev/null
+++ b/SRC/slangt.c
@@ -0,0 +1,196 @@
+/* slangt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal slangt_(char *norm, integer *n, real *dl, real *d__, real *du)
+{
+ /* System generated locals */
+ integer i__1;
+ real ret_val, r__1, r__2, r__3, r__4, r__5;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real sum, scale;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
+ real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLANGT returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* real tridiagonal matrix A. */
+
+/* Description */
+/* =========== */
+
+/* SLANGT returns the value */
+
+/* SLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in SLANGT as described */
+/* above. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, SLANGT is */
+/* set to zero. */
+
+/* DL (input) REAL array, dimension (N-1) */
+/* The (n-1) sub-diagonal elements of A. */
+
+/* D (input) REAL array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* DU (input) REAL array, dimension (N-1) */
+/* The (n-1) super-diagonal elements of A. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --du;
+ --d__;
+ --dl;
+
+ /* Function Body */
+ if (*n <= 0) {
+ anorm = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ anorm = (r__1 = d__[*n], dabs(r__1));
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = anorm, r__3 = (r__1 = dl[i__], dabs(r__1));
+ anorm = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = anorm, r__3 = (r__1 = d__[i__], dabs(r__1));
+ anorm = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = anorm, r__3 = (r__1 = du[i__], dabs(r__1));
+ anorm = dmax(r__2,r__3);
+/* L10: */
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ if (*n == 1) {
+ anorm = dabs(d__[1]);
+ } else {
+/* Computing MAX */
+ r__3 = dabs(d__[1]) + dabs(dl[1]), r__4 = (r__1 = d__[*n], dabs(
+ r__1)) + (r__2 = du[*n - 1], dabs(r__2));
+ anorm = dmax(r__3,r__4);
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__4 = anorm, r__5 = (r__1 = d__[i__], dabs(r__1)) + (r__2 =
+ dl[i__], dabs(r__2)) + (r__3 = du[i__ - 1], dabs(r__3)
+ );
+ anorm = dmax(r__4,r__5);
+/* L20: */
+ }
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ if (*n == 1) {
+ anorm = dabs(d__[1]);
+ } else {
+/* Computing MAX */
+ r__3 = dabs(d__[1]) + dabs(du[1]), r__4 = (r__1 = d__[*n], dabs(
+ r__1)) + (r__2 = dl[*n - 1], dabs(r__2));
+ anorm = dmax(r__3,r__4);
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__4 = anorm, r__5 = (r__1 = d__[i__], dabs(r__1)) + (r__2 =
+ du[i__], dabs(r__2)) + (r__3 = dl[i__ - 1], dabs(r__3)
+ );
+ anorm = dmax(r__4,r__5);
+/* L30: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.f;
+ sum = 1.f;
+ slassq_(n, &d__[1], &c__1, &scale, &sum);
+ if (*n > 1) {
+ i__1 = *n - 1;
+ slassq_(&i__1, &dl[1], &c__1, &scale, &sum);
+ i__1 = *n - 1;
+ slassq_(&i__1, &du[1], &c__1, &scale, &sum);
+ }
+ anorm = scale * sqrt(sum);
+ }
+
+ ret_val = anorm;
+ return ret_val;
+
+/* End of SLANGT */
+
+} /* slangt_ */
diff --git a/SRC/slanhs.c b/SRC/slanhs.c
new file mode 100644
index 0000000..a09cf14
--- /dev/null
+++ b/SRC/slanhs.c
@@ -0,0 +1,204 @@
+/* slanhs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal slanhs_(char *norm, integer *n, real *a, integer *lda, real *work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ real ret_val, r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ real sum, scale;
+ extern logical lsame_(char *, char *);
+ real value;
+ extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
+ real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLANHS returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* Hessenberg matrix A. */
+
+/* Description */
+/* =========== */
+
+/* SLANHS returns the value */
+
+/* SLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in SLANHS as described */
+/* above. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, SLANHS is */
+/* set to zero. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The n by n upper Hessenberg matrix A; the part of A below the */
+/* first sub-diagonal is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(N,1). */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n, i__4 = j + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ value = dmax(r__2,r__3);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.f;
+/* Computing MIN */
+ i__3 = *n, i__4 = j + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ sum += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+/* L30: */
+ }
+ value = dmax(value,sum);
+/* L40: */
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L50: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n, i__4 = j + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+/* L60: */
+ }
+/* L70: */
+ }
+ value = 0.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = work[i__];
+ value = dmax(r__1,r__2);
+/* L80: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.f;
+ sum = 1.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n, i__4 = j + 1;
+ i__2 = min(i__3,i__4);
+ slassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
+/* L90: */
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of SLANHS */
+
+} /* slanhs_ */
diff --git a/SRC/slansb.c b/SRC/slansb.c
new file mode 100644
index 0000000..b071850
--- /dev/null
+++ b/SRC/slansb.c
@@ -0,0 +1,263 @@
+/* slansb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal slansb_(char *norm, char *uplo, integer *n, integer *k, real *ab,
+ integer *ldab, real *work)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ real ret_val, r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, l;
+ real sum, absa, scale;
+ extern logical lsame_(char *, char *);
+ real value;
+ extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
+ real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLANSB returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of an */
+/* n by n symmetric band matrix A, with k super-diagonals. */
+
+/* Description */
+/* =========== */
+
+/* SLANSB returns the value */
+
+/* SLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in SLANSB as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* band matrix A is supplied. */
+/* = 'U': Upper triangular part is supplied */
+/* = 'L': Lower triangular part is supplied */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, SLANSB is */
+/* set to zero. */
+
+/* K (input) INTEGER */
+/* The number of super-diagonals or sub-diagonals of the */
+/* band matrix A. K >= 0. */
+
+/* AB (input) REAL array, dimension (LDAB,N) */
+/* The upper or lower triangle of the symmetric band matrix A, */
+/* stored in the first K+1 rows of AB. The j-th column of A is */
+/* stored in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= K+1. */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
+/* WORK is not referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ i__3 = *k + 1;
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1], dabs(
+ r__1));
+ value = dmax(r__2,r__3);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *n + 1 - j, i__4 = *k + 1;
+ i__3 = min(i__2,i__4);
+ for (i__ = 1; i__ <= i__3; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1], dabs(
+ r__1));
+ value = dmax(r__2,r__3);
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
+
+/* Find normI(A) ( = norm1(A), since A is symmetric). */
+
+ value = 0.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.f;
+ l = *k + 1 - j;
+/* Computing MAX */
+ i__3 = 1, i__2 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__3,i__2); i__ <= i__4; ++i__) {
+ absa = (r__1 = ab[l + i__ + j * ab_dim1], dabs(r__1));
+ sum += absa;
+ work[i__] += absa;
+/* L50: */
+ }
+ work[j] = sum + (r__1 = ab[*k + 1 + j * ab_dim1], dabs(r__1));
+/* L60: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = work[i__];
+ value = dmax(r__1,r__2);
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L80: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = work[j] + (r__1 = ab[j * ab_dim1 + 1], dabs(r__1));
+ l = 1 - j;
+/* Computing MIN */
+ i__3 = *n, i__2 = j + *k;
+ i__4 = min(i__3,i__2);
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ absa = (r__1 = ab[l + i__ + j * ab_dim1], dabs(r__1));
+ sum += absa;
+ work[i__] += absa;
+/* L90: */
+ }
+ value = dmax(value,sum);
+/* L100: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.f;
+ sum = 1.f;
+ if (*k > 0) {
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j - 1;
+ i__4 = min(i__3,*k);
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ slassq_(&i__4, &ab[max(i__2, 1)+ j * ab_dim1], &c__1, &
+ scale, &sum);
+/* L110: */
+ }
+ l = *k + 1;
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n - j;
+ i__4 = min(i__3,*k);
+ slassq_(&i__4, &ab[j * ab_dim1 + 2], &c__1, &scale, &sum);
+/* L120: */
+ }
+ l = 1;
+ }
+ sum *= 2;
+ } else {
+ l = 1;
+ }
+ slassq_(n, &ab[l + ab_dim1], ldab, &scale, &sum);
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of SLANSB */
+
+} /* slansb_ */
diff --git a/SRC/slansf.c b/SRC/slansf.c
new file mode 100644
index 0000000..5224399
--- /dev/null
+++ b/SRC/slansf.c
@@ -0,0 +1,1013 @@
+/* slansf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal slansf_(char *norm, char *transr, char *uplo, integer *n, real *a,
+ real *work)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real ret_val, r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, l;
+ real s;
+ integer n1;
+ real aa;
+ integer lda, ifm, noe, ilu;
+ real scale;
+ extern logical lsame_(char *, char *);
+ real value;
+ extern integer isamax_(integer *, real *, integer *);
+ extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
+ real *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLANSF returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* real symmetric matrix A in RFP format. */
+
+/* Description */
+/* =========== */
+
+/* SLANSF returns the value */
+
+/* SLANSF = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER */
+/* Specifies the value to be returned in SLANSF as described */
+/* above. */
+
+/* TRANSR (input) CHARACTER */
+/* Specifies whether the RFP format of A is normal or */
+/* transposed format. */
+/* = 'N': RFP format is Normal; */
+/* = 'T': RFP format is Transpose. */
+
+/* UPLO (input) CHARACTER */
+/* On entry, UPLO specifies whether the RFP matrix A came from */
+/* an upper or lower triangular matrix as follows: */
+/* = 'U': RFP A came from an upper triangular matrix; */
+/* = 'L': RFP A came from a lower triangular matrix. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, SLANSF is */
+/* set to zero. */
+
+/* A (input) REAL array, dimension ( N*(N+1)/2 ); */
+/* On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L') */
+/* part of the symmetric matrix A stored in RFP format. See the */
+/* "Notes" below for more details. */
+/* Unchanged on exit. */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
+/* WORK is not referenced. */
+
+/* Notes */
+/* ===== */
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* even. We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* the transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* the transpose of the last three columns of AP lower. */
+/* This covers the case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 03 04 05 33 43 53 */
+/* 13 14 15 00 44 54 */
+/* 23 24 25 10 11 55 */
+/* 33 34 35 20 21 22 */
+/* 00 44 45 30 31 32 */
+/* 01 11 55 40 41 42 */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* odd. We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* the transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* the transpose of the last two columns of AP lower. */
+/* This covers the case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 02 03 04 00 33 43 */
+/* 12 13 14 10 11 44 */
+/* 22 23 24 20 21 22 */
+/* 00 33 34 30 31 32 */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+/* RFP A RFP A */
+
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* Reference */
+/* ========= */
+
+/* ===================================================================== */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (*n == 0) {
+ ret_val = 0.f;
+ return ret_val;
+ }
+
+/* set noe = 1 if n is odd. if n is even set noe=0 */
+
+ noe = 1;
+ if (*n % 2 == 0) {
+ noe = 0;
+ }
+
+/* set ifm = 0 when form='T or 't' and 1 otherwise */
+
+ ifm = 1;
+ if (lsame_(transr, "T")) {
+ ifm = 0;
+ }
+
+/* set ilu = 0 when uplo='U or 'u' and 1 otherwise */
+
+ ilu = 1;
+ if (lsame_(uplo, "U")) {
+ ilu = 0;
+ }
+
+/* set lda = (n+1)/2 when ifm = 0 */
+/* set lda = n when ifm = 1 and noe = 1 */
+/* set lda = n+1 when ifm = 1 and noe = 0 */
+
+ if (ifm == 1) {
+ if (noe == 1) {
+ lda = *n;
+ } else {
+/* noe=0 */
+ lda = *n + 1;
+ }
+ } else {
+/* ifm=0 */
+ lda = (*n + 1) / 2;
+ }
+
+ if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ k = (*n + 1) / 2;
+ value = 0.f;
+ if (noe == 1) {
+/* n is odd */
+ if (ifm == 1) {
+/* A is n by k */
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = a[i__ + j * lda], dabs(
+ r__1));
+ value = dmax(r__2,r__3);
+ }
+ }
+ } else {
+/* xpose case; A is k by n */
+ i__1 = *n - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = a[i__ + j * lda], dabs(
+ r__1));
+ value = dmax(r__2,r__3);
+ }
+ }
+ }
+ } else {
+/* n is even */
+ if (ifm == 1) {
+/* A is n+1 by k */
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = a[i__ + j * lda], dabs(
+ r__1));
+ value = dmax(r__2,r__3);
+ }
+ }
+ } else {
+/* xpose case; A is k by n+1 */
+ i__1 = *n;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = a[i__ + j * lda], dabs(
+ r__1));
+ value = dmax(r__2,r__3);
+ }
+ }
+ }
+ }
+ } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
+
+/* Find normI(A) ( = norm1(A), since A is symmetric). */
+
+ if (ifm == 1) {
+ k = *n / 2;
+ if (noe == 1) {
+/* n is odd */
+ if (ilu == 0) {
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+ }
+ i__1 = k;
+ for (j = 0; j <= i__1; ++j) {
+ s = 0.f;
+ i__2 = k + j - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* -> A(i,j+k) */
+ s += aa;
+ work[i__] += aa;
+ }
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* -> A(j+k,j+k) */
+ work[j + k] = s + aa;
+ if (i__ == k + k) {
+ goto L10;
+ }
+ ++i__;
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* -> A(j,j) */
+ work[j] += aa;
+ s = 0.f;
+ i__2 = k - 1;
+ for (l = j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* -> A(l,j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[j] += s;
+ }
+L10:
+ i__ = isamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ } else {
+/* ilu = 1 */
+ ++k;
+/* k=(n+1)/2 for n odd and ilu=1 */
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+ }
+ for (j = k - 1; j >= 0; --j) {
+ s = 0.f;
+ i__1 = j - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* -> A(j+k,i+k) */
+ s += aa;
+ work[i__ + k] += aa;
+ }
+ if (j > 0) {
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* -> A(j+k,j+k) */
+ s += aa;
+ work[i__ + k] += s;
+/* i=j */
+ ++i__;
+ }
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* -> A(j,j) */
+ work[j] = aa;
+ s = 0.f;
+ i__1 = *n - 1;
+ for (l = j + 1; l <= i__1; ++l) {
+ ++i__;
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* -> A(l,j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[j] += s;
+ }
+ i__ = isamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ }
+ } else {
+/* n is even */
+ if (ilu == 0) {
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+ }
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ s = 0.f;
+ i__2 = k + j - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* -> A(i,j+k) */
+ s += aa;
+ work[i__] += aa;
+ }
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* -> A(j+k,j+k) */
+ work[j + k] = s + aa;
+ ++i__;
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* -> A(j,j) */
+ work[j] += aa;
+ s = 0.f;
+ i__2 = k - 1;
+ for (l = j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* -> A(l,j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[j] += s;
+ }
+ i__ = isamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ } else {
+/* ilu = 1 */
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+ }
+ for (j = k - 1; j >= 0; --j) {
+ s = 0.f;
+ i__1 = j - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* -> A(j+k,i+k) */
+ s += aa;
+ work[i__ + k] += aa;
+ }
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* -> A(j+k,j+k) */
+ s += aa;
+ work[i__ + k] += s;
+/* i=j */
+ ++i__;
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* -> A(j,j) */
+ work[j] = aa;
+ s = 0.f;
+ i__1 = *n - 1;
+ for (l = j + 1; l <= i__1; ++l) {
+ ++i__;
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* -> A(l,j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[j] += s;
+ }
+ i__ = isamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ }
+ }
+ } else {
+/* ifm=0 */
+ k = *n / 2;
+ if (noe == 1) {
+/* n is odd */
+ if (ilu == 0) {
+ n1 = k;
+/* n/2 */
+ ++k;
+/* k is the row size and lda */
+ i__1 = *n - 1;
+ for (i__ = n1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+ }
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ s = 0.f;
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(j,n1+i) */
+ work[i__ + n1] += aa;
+ s += aa;
+ }
+ work[j] = s;
+ }
+/* j=n1=k-1 is special */
+ s = (r__1 = a[j * lda], dabs(r__1));
+/* A(k-1,k-1) */
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(k-1,i+n1) */
+ work[i__ + n1] += aa;
+ s += aa;
+ }
+ work[j] += s;
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+ s = 0.f;
+ i__2 = j - k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(i,j-k) */
+ work[i__] += aa;
+ s += aa;
+ }
+/* i=j-k */
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(j-k,j-k) */
+ s += aa;
+ work[j - k] += s;
+ ++i__;
+ s = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(j,j) */
+ i__2 = *n - 1;
+ for (l = j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(j,l) */
+ work[l] += aa;
+ s += aa;
+ }
+ work[j] += s;
+ }
+ i__ = isamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ } else {
+/* ilu=1 */
+ ++k;
+/* k=(n+1)/2 for n odd and ilu=1 */
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+/* process */
+ s = 0.f;
+ i__2 = j - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(j,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* i=j so process of A(j,j) */
+ s += aa;
+ work[j] = s;
+/* is initialised here */
+ ++i__;
+/* i=j process A(j+k,j+k) */
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+ s = aa;
+ i__2 = *n - 1;
+ for (l = k + j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(l,k+j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[k + j] += s;
+ }
+/* j=k-1 is special :process col A(k-1,0:k-1) */
+ s = 0.f;
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(k,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+/* i=k-1 */
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(k-1,k-1) */
+ s += aa;
+ work[i__] = s;
+/* done with col j=k+1 */
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+/* process col j of A = A(j,0:k-1) */
+ s = 0.f;
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(j,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+ work[j] += s;
+ }
+ i__ = isamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ }
+ } else {
+/* n is even */
+ if (ilu == 0) {
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+ }
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ s = 0.f;
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(j,i+k) */
+ work[i__ + k] += aa;
+ s += aa;
+ }
+ work[j] = s;
+ }
+/* j=k */
+ aa = (r__1 = a[j * lda], dabs(r__1));
+/* A(k,k) */
+ s = aa;
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(k,k+i) */
+ work[i__ + k] += aa;
+ s += aa;
+ }
+ work[j] += s;
+ i__1 = *n - 1;
+ for (j = k + 1; j <= i__1; ++j) {
+ s = 0.f;
+ i__2 = j - 2 - k;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(i,j-k-1) */
+ work[i__] += aa;
+ s += aa;
+ }
+/* i=j-1-k */
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(j-k-1,j-k-1) */
+ s += aa;
+ work[j - k - 1] += s;
+ ++i__;
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(j,j) */
+ s = aa;
+ i__2 = *n - 1;
+ for (l = j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(j,l) */
+ work[l] += aa;
+ s += aa;
+ }
+ work[j] += s;
+ }
+/* j=n */
+ s = 0.f;
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(i,k-1) */
+ work[i__] += aa;
+ s += aa;
+ }
+/* i=k-1 */
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(k-1,k-1) */
+ s += aa;
+ work[i__] += s;
+ i__ = isamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ } else {
+/* ilu=1 */
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+ }
+/* j=0 is special :process col A(k:n-1,k) */
+ s = dabs(a[0]);
+/* A(k,k) */
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ aa = (r__1 = a[i__], dabs(r__1));
+/* A(k+i,k) */
+ work[i__ + k] += aa;
+ s += aa;
+ }
+ work[k] += s;
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* process */
+ s = 0.f;
+ i__2 = j - 2;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(j-1,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* i=j-1 so process of A(j-1,j-1) */
+ s += aa;
+ work[j - 1] = s;
+/* is initialised here */
+ ++i__;
+/* i=j process A(j+k,j+k) */
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+ s = aa;
+ i__2 = *n - 1;
+ for (l = k + j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(l,k+j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[k + j] += s;
+ }
+/* j=k is special :process col A(k,0:k-1) */
+ s = 0.f;
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(k,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+/* i=k-1 */
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(k-1,k-1) */
+ s += aa;
+ work[i__] = s;
+/* done with col j=k+1 */
+ i__1 = *n;
+ for (j = k + 1; j <= i__1; ++j) {
+/* process col j-1 of A = A(j-1,0:k-1) */
+ s = 0.f;
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = (r__1 = a[i__ + j * lda], dabs(r__1));
+/* A(j-1,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+ work[j - 1] += s;
+ }
+ i__ = isamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ }
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ k = (*n + 1) / 2;
+ scale = 0.f;
+ s = 1.f;
+ if (noe == 1) {
+/* n is odd */
+ if (ifm == 1) {
+/* A is normal */
+ if (ilu == 0) {
+/* A is upper */
+ i__1 = k - 3;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 2;
+ slassq_(&i__2, &a[k + j + 1 + j * lda], &c__1, &scale,
+ &s);
+/* L at A(k,0) */
+ }
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k + j - 1;
+ slassq_(&i__2, &a[j * lda], &c__1, &scale, &s);
+/* trap U at A(0,0) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ i__1 = k - 1;
+ i__2 = lda + 1;
+ slassq_(&i__1, &a[k], &i__2, &scale, &s);
+/* tri L at A(k,0) */
+ i__1 = lda + 1;
+ slassq_(&k, &a[k - 1], &i__1, &scale, &s);
+/* tri U at A(k-1,0) */
+ } else {
+/* ilu=1 & A is lower */
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - j - 1;
+ slassq_(&i__2, &a[j + 1 + j * lda], &c__1, &scale, &s)
+ ;
+/* trap L at A(0,0) */
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ slassq_(&j, &a[(j + 1) * lda], &c__1, &scale, &s);
+/* U at A(0,1) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ i__1 = lda + 1;
+ slassq_(&k, a, &i__1, &scale, &s);
+/* tri L at A(0,0) */
+ i__1 = k - 1;
+ i__2 = lda + 1;
+ slassq_(&i__1, &a[lda], &i__2, &scale, &s);
+/* tri U at A(0,1) */
+ }
+ } else {
+/* A is xpose */
+ if (ilu == 0) {
+/* A' is upper */
+ i__1 = k - 2;
+ for (j = 1; j <= i__1; ++j) {
+ slassq_(&j, &a[(k + j) * lda], &c__1, &scale, &s);
+/* U at A(0,k) */
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ slassq_(&k, &a[j * lda], &c__1, &scale, &s);
+/* k by k-1 rect. at A(0,0) */
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 1;
+ slassq_(&i__2, &a[j + 1 + (j + k - 1) * lda], &c__1, &
+ scale, &s);
+/* L at A(0,k-1) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ i__1 = k - 1;
+ i__2 = lda + 1;
+ slassq_(&i__1, &a[k * lda], &i__2, &scale, &s);
+/* tri U at A(0,k) */
+ i__1 = lda + 1;
+ slassq_(&k, &a[(k - 1) * lda], &i__1, &scale, &s);
+/* tri L at A(0,k-1) */
+ } else {
+/* A' is lower */
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ slassq_(&j, &a[j * lda], &c__1, &scale, &s);
+/* U at A(0,0) */
+ }
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+ slassq_(&k, &a[j * lda], &c__1, &scale, &s);
+/* k by k-1 rect. at A(0,k) */
+ }
+ i__1 = k - 3;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 2;
+ slassq_(&i__2, &a[j + 2 + j * lda], &c__1, &scale, &s)
+ ;
+/* L at A(1,0) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ i__1 = lda + 1;
+ slassq_(&k, a, &i__1, &scale, &s);
+/* tri U at A(0,0) */
+ i__1 = k - 1;
+ i__2 = lda + 1;
+ slassq_(&i__1, &a[1], &i__2, &scale, &s);
+/* tri L at A(1,0) */
+ }
+ }
+ } else {
+/* n is even */
+ if (ifm == 1) {
+/* A is normal */
+ if (ilu == 0) {
+/* A is upper */
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 1;
+ slassq_(&i__2, &a[k + j + 2 + j * lda], &c__1, &scale,
+ &s);
+/* L at A(k+1,0) */
+ }
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k + j;
+ slassq_(&i__2, &a[j * lda], &c__1, &scale, &s);
+/* trap U at A(0,0) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ i__1 = lda + 1;
+ slassq_(&k, &a[k + 1], &i__1, &scale, &s);
+/* tri L at A(k+1,0) */
+ i__1 = lda + 1;
+ slassq_(&k, &a[k], &i__1, &scale, &s);
+/* tri U at A(k,0) */
+ } else {
+/* ilu=1 & A is lower */
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - j - 1;
+ slassq_(&i__2, &a[j + 2 + j * lda], &c__1, &scale, &s)
+ ;
+/* trap L at A(1,0) */
+ }
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ slassq_(&j, &a[j * lda], &c__1, &scale, &s);
+/* U at A(0,0) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ i__1 = lda + 1;
+ slassq_(&k, &a[1], &i__1, &scale, &s);
+/* tri L at A(1,0) */
+ i__1 = lda + 1;
+ slassq_(&k, a, &i__1, &scale, &s);
+/* tri U at A(0,0) */
+ }
+ } else {
+/* A is xpose */
+ if (ilu == 0) {
+/* A' is upper */
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ slassq_(&j, &a[(k + 1 + j) * lda], &c__1, &scale, &s);
+/* U at A(0,k+1) */
+ }
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ slassq_(&k, &a[j * lda], &c__1, &scale, &s);
+/* k by k rect. at A(0,0) */
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 1;
+ slassq_(&i__2, &a[j + 1 + (j + k) * lda], &c__1, &
+ scale, &s);
+/* L at A(0,k) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ i__1 = lda + 1;
+ slassq_(&k, &a[(k + 1) * lda], &i__1, &scale, &s);
+/* tri U at A(0,k+1) */
+ i__1 = lda + 1;
+ slassq_(&k, &a[k * lda], &i__1, &scale, &s);
+/* tri L at A(0,k) */
+ } else {
+/* A' is lower */
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ slassq_(&j, &a[(j + 1) * lda], &c__1, &scale, &s);
+/* U at A(0,1) */
+ }
+ i__1 = *n;
+ for (j = k + 1; j <= i__1; ++j) {
+ slassq_(&k, &a[j * lda], &c__1, &scale, &s);
+/* k by k rect. at A(0,k+1) */
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 1;
+ slassq_(&i__2, &a[j + 1 + j * lda], &c__1, &scale, &s)
+ ;
+/* L at A(0,0) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ i__1 = lda + 1;
+ slassq_(&k, &a[lda], &i__1, &scale, &s);
+/* tri L at A(0,1) */
+ i__1 = lda + 1;
+ slassq_(&k, a, &i__1, &scale, &s);
+/* tri U at A(0,0) */
+ }
+ }
+ }
+ value = scale * sqrt(s);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of SLANSF */
+
+} /* slansf_ */
diff --git a/SRC/slansp.c b/SRC/slansp.c
new file mode 100644
index 0000000..822c5ed
--- /dev/null
+++ b/SRC/slansp.c
@@ -0,0 +1,262 @@
+/* slansp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal slansp_(char *norm, char *uplo, integer *n, real *ap, real *work)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real ret_val, r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ real sum, absa, scale;
+ extern logical lsame_(char *, char *);
+ real value;
+ extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
+ real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLANSP returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* real symmetric matrix A, supplied in packed form. */
+
+/* Description */
+/* =========== */
+
+/* SLANSP returns the value */
+
+/* SLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in SLANSP as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is supplied. */
+/* = 'U': Upper triangular part of A is supplied */
+/* = 'L': Lower triangular part of A is supplied */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, SLANSP is */
+/* set to zero. */
+
+/* AP (input) REAL array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the symmetric matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
+/* WORK is not referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --ap;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.f;
+ if (lsame_(uplo, "U")) {
+ k = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1));
+ value = dmax(r__2,r__3);
+/* L10: */
+ }
+ k += j;
+/* L20: */
+ }
+ } else {
+ k = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + *n - j;
+ for (i__ = k; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1));
+ value = dmax(r__2,r__3);
+/* L30: */
+ }
+ k = k + *n - j + 1;
+/* L40: */
+ }
+ }
+ } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
+
+/* Find normI(A) ( = norm1(A), since A is symmetric). */
+
+ value = 0.f;
+ k = 1;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.f;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ absa = (r__1 = ap[k], dabs(r__1));
+ sum += absa;
+ work[i__] += absa;
+ ++k;
+/* L50: */
+ }
+ work[j] = sum + (r__1 = ap[k], dabs(r__1));
+ ++k;
+/* L60: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = work[i__];
+ value = dmax(r__1,r__2);
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L80: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = work[j] + (r__1 = ap[k], dabs(r__1));
+ ++k;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ absa = (r__1 = ap[k], dabs(r__1));
+ sum += absa;
+ work[i__] += absa;
+ ++k;
+/* L90: */
+ }
+ value = dmax(value,sum);
+/* L100: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.f;
+ sum = 1.f;
+ k = 2;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ slassq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k += j;
+/* L110: */
+ }
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ slassq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k = k + *n - j + 1;
+/* L120: */
+ }
+ }
+ sum *= 2;
+ k = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (ap[k] != 0.f) {
+ absa = (r__1 = ap[k], dabs(r__1));
+ if (scale < absa) {
+/* Computing 2nd power */
+ r__1 = scale / absa;
+ sum = sum * (r__1 * r__1) + 1.f;
+ scale = absa;
+ } else {
+/* Computing 2nd power */
+ r__1 = absa / scale;
+ sum += r__1 * r__1;
+ }
+ }
+ if (lsame_(uplo, "U")) {
+ k = k + i__ + 1;
+ } else {
+ k = k + *n - i__ + 1;
+ }
+/* L130: */
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of SLANSP */
+
+} /* slansp_ */
diff --git a/SRC/slanst.c b/SRC/slanst.c
new file mode 100644
index 0000000..dd240ca
--- /dev/null
+++ b/SRC/slanst.c
@@ -0,0 +1,166 @@
+/* slanst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal slanst_(char *norm, integer *n, real *d__, real *e)
+{
+ /* System generated locals */
+ integer i__1;
+ real ret_val, r__1, r__2, r__3, r__4, r__5;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real sum, scale;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
+ real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLANST returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* real symmetric tridiagonal matrix A. */
+
+/* Description */
+/* =========== */
+
+/* SLANST returns the value */
+
+/* SLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in SLANST as described */
+/* above. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, SLANST is */
+/* set to zero. */
+
+/* D (input) REAL array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* E (input) REAL array, dimension (N-1) */
+/* The (n-1) sub-diagonal or super-diagonal elements of A. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --e;
+ --d__;
+
+ /* Function Body */
+ if (*n <= 0) {
+ anorm = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ anorm = (r__1 = d__[*n], dabs(r__1));
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = anorm, r__3 = (r__1 = d__[i__], dabs(r__1));
+ anorm = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = anorm, r__3 = (r__1 = e[i__], dabs(r__1));
+ anorm = dmax(r__2,r__3);
+/* L10: */
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1' || lsame_(norm, "I")) {
+
+/* Find norm1(A). */
+
+ if (*n == 1) {
+ anorm = dabs(d__[1]);
+ } else {
+/* Computing MAX */
+ r__3 = dabs(d__[1]) + dabs(e[1]), r__4 = (r__1 = e[*n - 1], dabs(
+ r__1)) + (r__2 = d__[*n], dabs(r__2));
+ anorm = dmax(r__3,r__4);
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__4 = anorm, r__5 = (r__1 = d__[i__], dabs(r__1)) + (r__2 =
+ e[i__], dabs(r__2)) + (r__3 = e[i__ - 1], dabs(r__3));
+ anorm = dmax(r__4,r__5);
+/* L20: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.f;
+ sum = 1.f;
+ if (*n > 1) {
+ i__1 = *n - 1;
+ slassq_(&i__1, &e[1], &c__1, &scale, &sum);
+ sum *= 2;
+ }
+ slassq_(n, &d__[1], &c__1, &scale, &sum);
+ anorm = scale * sqrt(sum);
+ }
+
+ ret_val = anorm;
+ return ret_val;
+
+/* End of SLANST */
+
+} /* slanst_ */
diff --git a/SRC/slansy.c b/SRC/slansy.c
new file mode 100644
index 0000000..1064b19
--- /dev/null
+++ b/SRC/slansy.c
@@ -0,0 +1,239 @@
+/* slansy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal slansy_(char *norm, char *uplo, integer *n, real *a, integer *lda,
+ real *work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real ret_val, r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ real sum, absa, scale;
+ extern logical lsame_(char *, char *);
+ real value;
+ extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
+ real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLANSY returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* real symmetric matrix A. */
+
+/* Description */
+/* =========== */
+
+/* SLANSY returns the value */
+
+/* SLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in SLANSY as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is to be referenced. */
+/* = 'U': Upper triangular part of A is referenced */
+/* = 'L': Lower triangular part of A is referenced */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, SLANSY is */
+/* set to zero. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of A contains the upper triangular part */
+/* of the matrix A, and the strictly lower triangular part of A */
+/* is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of A contains the lower triangular part of */
+/* the matrix A, and the strictly upper triangular part of A is */
+/* not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(N,1). */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
+/* WORK is not referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(
+ r__1));
+ value = dmax(r__2,r__3);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(
+ r__1));
+ value = dmax(r__2,r__3);
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
+
+/* Find normI(A) ( = norm1(A), since A is symmetric). */
+
+ value = 0.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.f;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ absa = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ sum += absa;
+ work[i__] += absa;
+/* L50: */
+ }
+ work[j] = sum + (r__1 = a[j + j * a_dim1], dabs(r__1));
+/* L60: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = work[i__];
+ value = dmax(r__1,r__2);
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L80: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = work[j] + (r__1 = a[j + j * a_dim1], dabs(r__1));
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ absa = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ sum += absa;
+ work[i__] += absa;
+/* L90: */
+ }
+ value = dmax(value,sum);
+/* L100: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.f;
+ sum = 1.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ slassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
+/* L110: */
+ }
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ slassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum);
+/* L120: */
+ }
+ }
+ sum *= 2;
+ i__1 = *lda + 1;
+ slassq_(n, &a[a_offset], &i__1, &scale, &sum);
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of SLANSY */
+
+} /* slansy_ */
diff --git a/SRC/slantb.c b/SRC/slantb.c
new file mode 100644
index 0000000..22bdf10
--- /dev/null
+++ b/SRC/slantb.c
@@ -0,0 +1,434 @@
+/* slantb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal slantb_(char *norm, char *uplo, char *diag, integer *n, integer *k,
+ real *ab, integer *ldab, real *work)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5;
+ real ret_val, r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, l;
+ real sum, scale;
+ logical udiag;
+ extern logical lsame_(char *, char *);
+ real value;
+ extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
+ real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLANTB returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of an */
+/* n by n triangular band matrix A, with ( k + 1 ) diagonals. */
+
+/* Description */
+/* =========== */
+
+/* SLANTB returns the value */
+
+/* SLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in SLANTB as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, SLANTB is */
+/* set to zero. */
+
+/* K (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals of the matrix A if UPLO = 'L'. */
+/* K >= 0. */
+
+/* AB (input) REAL array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first k+1 rows of AB. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). */
+/* Note that when DIAG = 'U', the elements of the array AB */
+/* corresponding to the diagonal elements of the matrix A are */
+/* not referenced, but are assumed to be one. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= K+1. */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ if (lsame_(diag, "U")) {
+ value = 1.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ i__3 = *k;
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1],
+ dabs(r__1));
+ value = dmax(r__2,r__3);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *n + 1 - j, i__4 = *k + 1;
+ i__3 = min(i__2,i__4);
+ for (i__ = 2; i__ <= i__3; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1],
+ dabs(r__1));
+ value = dmax(r__2,r__3);
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else {
+ value = 0.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__3 = *k + 2 - j;
+ i__2 = *k + 1;
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1],
+ dabs(r__1));
+ value = dmax(r__2,r__3);
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n + 1 - j, i__4 = *k + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = ab[i__ + j * ab_dim1],
+ dabs(r__1));
+ value = dmax(r__2,r__3);
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.f;
+ udiag = lsame_(diag, "U");
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag) {
+ sum = 1.f;
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ i__3 = *k;
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+ sum += (r__1 = ab[i__ + j * ab_dim1], dabs(r__1));
+/* L90: */
+ }
+ } else {
+ sum = 0.f;
+/* Computing MAX */
+ i__3 = *k + 2 - j;
+ i__2 = *k + 1;
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+ sum += (r__1 = ab[i__ + j * ab_dim1], dabs(r__1));
+/* L100: */
+ }
+ }
+ value = dmax(value,sum);
+/* L110: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag) {
+ sum = 1.f;
+/* Computing MIN */
+ i__3 = *n + 1 - j, i__4 = *k + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ sum += (r__1 = ab[i__ + j * ab_dim1], dabs(r__1));
+/* L120: */
+ }
+ } else {
+ sum = 0.f;
+/* Computing MIN */
+ i__3 = *n + 1 - j, i__4 = *k + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ sum += (r__1 = ab[i__ + j * ab_dim1], dabs(r__1));
+/* L130: */
+ }
+ }
+ value = dmax(value,sum);
+/* L140: */
+ }
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ value = 0.f;
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.f;
+/* L150: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ l = *k + 1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ work[i__] += (r__1 = ab[l + i__ + j * ab_dim1], dabs(
+ r__1));
+/* L160: */
+ }
+/* L170: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L180: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ l = *k + 1 - j;
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *k;
+ i__3 = j;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ work[i__] += (r__1 = ab[l + i__ + j * ab_dim1], dabs(
+ r__1));
+/* L190: */
+ }
+/* L200: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.f;
+/* L210: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ l = 1 - j;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ work[i__] += (r__1 = ab[l + i__ + j * ab_dim1], dabs(
+ r__1));
+/* L220: */
+ }
+/* L230: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L240: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ l = 1 - j;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j; i__ <= i__3; ++i__) {
+ work[i__] += (r__1 = ab[l + i__ + j * ab_dim1], dabs(
+ r__1));
+/* L250: */
+ }
+/* L260: */
+ }
+ }
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = work[i__];
+ value = dmax(r__1,r__2);
+/* L270: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ scale = 1.f;
+ sum = (real) (*n);
+ if (*k > 0) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = j - 1;
+ i__3 = min(i__4,*k);
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ slassq_(&i__3, &ab[max(i__2, 1)+ j * ab_dim1], &c__1,
+ &scale, &sum);
+/* L280: */
+ }
+ }
+ } else {
+ scale = 0.f;
+ sum = 1.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = j, i__2 = *k + 1;
+ i__3 = min(i__4,i__2);
+/* Computing MAX */
+ i__5 = *k + 2 - j;
+ slassq_(&i__3, &ab[max(i__5, 1)+ j * ab_dim1], &c__1, &
+ scale, &sum);
+/* L290: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ scale = 1.f;
+ sum = (real) (*n);
+ if (*k > 0) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = *n - j;
+ i__3 = min(i__4,*k);
+ slassq_(&i__3, &ab[j * ab_dim1 + 2], &c__1, &scale, &
+ sum);
+/* L300: */
+ }
+ }
+ } else {
+ scale = 0.f;
+ sum = 1.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = *n - j + 1, i__2 = *k + 1;
+ i__3 = min(i__4,i__2);
+ slassq_(&i__3, &ab[j * ab_dim1 + 1], &c__1, &scale, &sum);
+/* L310: */
+ }
+ }
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of SLANTB */
+
+} /* slantb_ */
diff --git a/SRC/slantp.c b/SRC/slantp.c
new file mode 100644
index 0000000..f004758
--- /dev/null
+++ b/SRC/slantp.c
@@ -0,0 +1,391 @@
+/* slantp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal slantp_(char *norm, char *uplo, char *diag, integer *n, real *ap,
+ real *work)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real ret_val, r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ real sum, scale;
+ logical udiag;
+ extern logical lsame_(char *, char *);
+ real value;
+ extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
+ real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLANTP returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* triangular matrix A, supplied in packed form. */
+
+/* Description */
+/* =========== */
+
+/* SLANTP returns the value */
+
+/* SLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in SLANTP as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, SLANTP is */
+/* set to zero. */
+
+/* AP (input) REAL array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* Note that when DIAG = 'U', the elements of the array AP */
+/* corresponding to the diagonal elements of the matrix A are */
+/* not referenced, but are assumed to be one. */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --ap;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ k = 1;
+ if (lsame_(diag, "U")) {
+ value = 1.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j - 2;
+ for (i__ = k; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1));
+ value = dmax(r__2,r__3);
+/* L10: */
+ }
+ k += j;
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + *n - j;
+ for (i__ = k + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1));
+ value = dmax(r__2,r__3);
+/* L30: */
+ }
+ k = k + *n - j + 1;
+/* L40: */
+ }
+ }
+ } else {
+ value = 0.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1));
+ value = dmax(r__2,r__3);
+/* L50: */
+ }
+ k += j;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + *n - j;
+ for (i__ = k; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = ap[i__], dabs(r__1));
+ value = dmax(r__2,r__3);
+/* L70: */
+ }
+ k = k + *n - j + 1;
+/* L80: */
+ }
+ }
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.f;
+ k = 1;
+ udiag = lsame_(diag, "U");
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag) {
+ sum = 1.f;
+ i__2 = k + j - 2;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ sum += (r__1 = ap[i__], dabs(r__1));
+/* L90: */
+ }
+ } else {
+ sum = 0.f;
+ i__2 = k + j - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ sum += (r__1 = ap[i__], dabs(r__1));
+/* L100: */
+ }
+ }
+ k += j;
+ value = dmax(value,sum);
+/* L110: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag) {
+ sum = 1.f;
+ i__2 = k + *n - j;
+ for (i__ = k + 1; i__ <= i__2; ++i__) {
+ sum += (r__1 = ap[i__], dabs(r__1));
+/* L120: */
+ }
+ } else {
+ sum = 0.f;
+ i__2 = k + *n - j;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ sum += (r__1 = ap[i__], dabs(r__1));
+/* L130: */
+ }
+ }
+ k = k + *n - j + 1;
+ value = dmax(value,sum);
+/* L140: */
+ }
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ k = 1;
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.f;
+/* L150: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += (r__1 = ap[k], dabs(r__1));
+ ++k;
+/* L160: */
+ }
+ ++k;
+/* L170: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L180: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += (r__1 = ap[k], dabs(r__1));
+ ++k;
+/* L190: */
+ }
+/* L200: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.f;
+/* L210: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ++k;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ work[i__] += (r__1 = ap[k], dabs(r__1));
+ ++k;
+/* L220: */
+ }
+/* L230: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L240: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ work[i__] += (r__1 = ap[k], dabs(r__1));
+ ++k;
+/* L250: */
+ }
+/* L260: */
+ }
+ }
+ }
+ value = 0.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = work[i__];
+ value = dmax(r__1,r__2);
+/* L270: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ scale = 1.f;
+ sum = (real) (*n);
+ k = 2;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ slassq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k += j;
+/* L280: */
+ }
+ } else {
+ scale = 0.f;
+ sum = 1.f;
+ k = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ slassq_(&j, &ap[k], &c__1, &scale, &sum);
+ k += j;
+/* L290: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ scale = 1.f;
+ sum = (real) (*n);
+ k = 2;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ slassq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k = k + *n - j + 1;
+/* L300: */
+ }
+ } else {
+ scale = 0.f;
+ sum = 1.f;
+ k = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ slassq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k = k + *n - j + 1;
+/* L310: */
+ }
+ }
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of SLANTP */
+
+} /* slantp_ */
diff --git a/SRC/slantr.c b/SRC/slantr.c
new file mode 100644
index 0000000..b62c8d9
--- /dev/null
+++ b/SRC/slantr.c
@@ -0,0 +1,398 @@
+/* slantr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal slantr_(char *norm, char *uplo, char *diag, integer *m, integer *n,
+ real *a, integer *lda, real *work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ real ret_val, r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ real sum, scale;
+ logical udiag;
+ extern logical lsame_(char *, char *);
+ real value;
+ extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
+ real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLANTR returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* trapezoidal or triangular matrix A. */
+
+/* Description */
+/* =========== */
+
+/* SLANTR returns the value */
+
+/* SLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in SLANTR as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower trapezoidal. */
+/* = 'U': Upper trapezoidal */
+/* = 'L': Lower trapezoidal */
+/* Note that A is triangular instead of trapezoidal if M = N. */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A has unit diagonal. */
+/* = 'N': Non-unit diagonal */
+/* = 'U': Unit diagonal */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0, and if */
+/* UPLO = 'U', M <= N. When M = 0, SLANTR is set to zero. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0, and if */
+/* UPLO = 'L', N <= M. When N = 0, SLANTR is set to zero. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The trapezoidal matrix A (A is triangular if M = N). */
+/* If UPLO = 'U', the leading m by n upper trapezoidal part of */
+/* the array A contains the upper trapezoidal matrix, and the */
+/* strictly lower triangular part of A is not referenced. */
+/* If UPLO = 'L', the leading m by n lower trapezoidal part of */
+/* the array A contains the lower trapezoidal matrix, and the */
+/* strictly upper triangular part of A is not referenced. Note */
+/* that when DIAG = 'U', the diagonal elements of A are not */
+/* referenced and are assumed to be one. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(M,1). */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ if (min(*m,*n) == 0) {
+ value = 0.f;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ if (lsame_(diag, "U")) {
+ value = 1.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *m, i__4 = j - 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1],
+ dabs(r__1));
+ value = dmax(r__2,r__3);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1],
+ dabs(r__1));
+ value = dmax(r__2,r__3);
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else {
+ value = 0.f;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(*m,j);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1],
+ dabs(r__1));
+ value = dmax(r__2,r__3);
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = value, r__3 = (r__1 = a[i__ + j * a_dim1],
+ dabs(r__1));
+ value = dmax(r__2,r__3);
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.f;
+ udiag = lsame_(diag, "U");
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag && j <= *m) {
+ sum = 1.f;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ sum += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+/* L90: */
+ }
+ } else {
+ sum = 0.f;
+ i__2 = min(*m,j);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ sum += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+/* L100: */
+ }
+ }
+ value = dmax(value,sum);
+/* L110: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag) {
+ sum = 1.f;
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ sum += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+/* L120: */
+ }
+ } else {
+ sum = 0.f;
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ sum += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+/* L130: */
+ }
+ }
+ value = dmax(value,sum);
+/* L140: */
+ }
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.f;
+/* L150: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *m, i__4 = j - 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+/* L160: */
+ }
+/* L170: */
+ }
+ } else {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L180: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(*m,j);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+/* L190: */
+ }
+/* L200: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.f;
+/* L210: */
+ }
+ i__1 = *m;
+ for (i__ = *n + 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L220: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+/* L230: */
+ }
+/* L240: */
+ }
+ } else {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L250: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+/* L260: */
+ }
+/* L270: */
+ }
+ }
+ }
+ value = 0.f;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = value, r__2 = work[i__];
+ value = dmax(r__1,r__2);
+/* L280: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ scale = 1.f;
+ sum = (real) min(*m,*n);
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *m, i__4 = j - 1;
+ i__2 = min(i__3,i__4);
+ slassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
+/* L290: */
+ }
+ } else {
+ scale = 0.f;
+ sum = 1.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(*m,j);
+ slassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
+/* L300: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ scale = 1.f;
+ sum = (real) min(*m,*n);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m - j;
+/* Computing MIN */
+ i__3 = *m, i__4 = j + 1;
+ slassq_(&i__2, &a[min(i__3, i__4)+ j * a_dim1], &c__1, &
+ scale, &sum);
+/* L310: */
+ }
+ } else {
+ scale = 0.f;
+ sum = 1.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m - j + 1;
+ slassq_(&i__2, &a[j + j * a_dim1], &c__1, &scale, &sum);
+/* L320: */
+ }
+ }
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of SLANTR */
+
+} /* slantr_ */
diff --git a/SRC/slanv2.c b/SRC/slanv2.c
new file mode 100644
index 0000000..95a5934
--- /dev/null
+++ b/SRC/slanv2.c
@@ -0,0 +1,234 @@
+/* slanv2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b4 = 1.f;
+
+/* Subroutine */ int slanv2_(real *a, real *b, real *c__, real *d__, real *
+ rt1r, real *rt1i, real *rt2r, real *rt2i, real *cs, real *sn)
+{
+ /* System generated locals */
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double r_sign(real *, real *), sqrt(doublereal);
+
+ /* Local variables */
+ real p, z__, aa, bb, cc, dd, cs1, sn1, sab, sac, eps, tau, temp, scale,
+ bcmax, bcmis, sigma;
+ extern doublereal slapy2_(real *, real *), slamch_(char *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric */
+/* matrix in standard form: */
+
+/* [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] */
+/* [ C D ] [ SN CS ] [ CC DD ] [-SN CS ] */
+
+/* where either */
+/* 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or */
+/* 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex */
+/* conjugate eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* A (input/output) REAL */
+/* B (input/output) REAL */
+/* C (input/output) REAL */
+/* D (input/output) REAL */
+/* On entry, the elements of the input matrix. */
+/* On exit, they are overwritten by the elements of the */
+/* standardised Schur form. */
+
+/* RT1R (output) REAL */
+/* RT1I (output) REAL */
+/* RT2R (output) REAL */
+/* RT2I (output) REAL */
+/* The real and imaginary parts of the eigenvalues. If the */
+/* eigenvalues are a complex conjugate pair, RT1I > 0. */
+
+/* CS (output) REAL */
+/* SN (output) REAL */
+/* Parameters of the rotation matrix. */
+
+/* Further Details */
+/* =============== */
+
+/* Modified by V. Sima, Research Institute for Informatics, Bucharest, */
+/* Romania, to reduce the risk of cancellation errors, */
+/* when computing real eigenvalues, and to ensure, if possible, that */
+/* abs(RT1R) >= abs(RT2R). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = slamch_("P");
+ if (*c__ == 0.f) {
+ *cs = 1.f;
+ *sn = 0.f;
+ goto L10;
+
+ } else if (*b == 0.f) {
+
+/* Swap rows and columns */
+
+ *cs = 0.f;
+ *sn = 1.f;
+ temp = *d__;
+ *d__ = *a;
+ *a = temp;
+ *b = -(*c__);
+ *c__ = 0.f;
+ goto L10;
+ } else if (*a - *d__ == 0.f && r_sign(&c_b4, b) != r_sign(&c_b4, c__)) {
+ *cs = 1.f;
+ *sn = 0.f;
+ goto L10;
+ } else {
+
+ temp = *a - *d__;
+ p = temp * .5f;
+/* Computing MAX */
+ r__1 = dabs(*b), r__2 = dabs(*c__);
+ bcmax = dmax(r__1,r__2);
+/* Computing MIN */
+ r__1 = dabs(*b), r__2 = dabs(*c__);
+ bcmis = dmin(r__1,r__2) * r_sign(&c_b4, b) * r_sign(&c_b4, c__);
+/* Computing MAX */
+ r__1 = dabs(p);
+ scale = dmax(r__1,bcmax);
+ z__ = p / scale * p + bcmax / scale * bcmis;
+
+/* If Z is of the order of the machine accuracy, postpone the */
+/* decision on the nature of eigenvalues */
+
+ if (z__ >= eps * 4.f) {
+
+/* Real eigenvalues. Compute A and D. */
+
+ r__1 = sqrt(scale) * sqrt(z__);
+ z__ = p + r_sign(&r__1, &p);
+ *a = *d__ + z__;
+ *d__ -= bcmax / z__ * bcmis;
+
+/* Compute B and the rotation matrix */
+
+ tau = slapy2_(c__, &z__);
+ *cs = z__ / tau;
+ *sn = *c__ / tau;
+ *b -= *c__;
+ *c__ = 0.f;
+ } else {
+
+/* Complex eigenvalues, or real (almost) equal eigenvalues. */
+/* Make diagonal elements equal. */
+
+ sigma = *b + *c__;
+ tau = slapy2_(&sigma, &temp);
+ *cs = sqrt((dabs(sigma) / tau + 1.f) * .5f);
+ *sn = -(p / (tau * *cs)) * r_sign(&c_b4, &sigma);
+
+/* Compute [ AA BB ] = [ A B ] [ CS -SN ] */
+/* [ CC DD ] [ C D ] [ SN CS ] */
+
+ aa = *a * *cs + *b * *sn;
+ bb = -(*a) * *sn + *b * *cs;
+ cc = *c__ * *cs + *d__ * *sn;
+ dd = -(*c__) * *sn + *d__ * *cs;
+
+/* Compute [ A B ] = [ CS SN ] [ AA BB ] */
+/* [ C D ] [-SN CS ] [ CC DD ] */
+
+ *a = aa * *cs + cc * *sn;
+ *b = bb * *cs + dd * *sn;
+ *c__ = -aa * *sn + cc * *cs;
+ *d__ = -bb * *sn + dd * *cs;
+
+ temp = (*a + *d__) * .5f;
+ *a = temp;
+ *d__ = temp;
+
+ if (*c__ != 0.f) {
+ if (*b != 0.f) {
+ if (r_sign(&c_b4, b) == r_sign(&c_b4, c__)) {
+
+/* Real eigenvalues: reduce to upper triangular form */
+
+ sab = sqrt((dabs(*b)));
+ sac = sqrt((dabs(*c__)));
+ r__1 = sab * sac;
+ p = r_sign(&r__1, c__);
+ tau = 1.f / sqrt((r__1 = *b + *c__, dabs(r__1)));
+ *a = temp + p;
+ *d__ = temp - p;
+ *b -= *c__;
+ *c__ = 0.f;
+ cs1 = sab * tau;
+ sn1 = sac * tau;
+ temp = *cs * cs1 - *sn * sn1;
+ *sn = *cs * sn1 + *sn * cs1;
+ *cs = temp;
+ }
+ } else {
+ *b = -(*c__);
+ *c__ = 0.f;
+ temp = *cs;
+ *cs = -(*sn);
+ *sn = temp;
+ }
+ }
+ }
+
+ }
+
+L10:
+
+/* Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). */
+
+ *rt1r = *a;
+ *rt2r = *d__;
+ if (*c__ == 0.f) {
+ *rt1i = 0.f;
+ *rt2i = 0.f;
+ } else {
+ *rt1i = sqrt((dabs(*b))) * sqrt((dabs(*c__)));
+ *rt2i = -(*rt1i);
+ }
+ return 0;
+
+/* End of SLANV2 */
+
+} /* slanv2_ */
diff --git a/SRC/slapll.c b/SRC/slapll.c
new file mode 100644
index 0000000..45c30f1
--- /dev/null
+++ b/SRC/slapll.c
@@ -0,0 +1,126 @@
+/* slapll.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slapll_(integer *n, real *x, integer *incx, real *y,
+ integer *incy, real *ssmin)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ real c__, a11, a12, a22, tau;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ extern /* Subroutine */ int slas2_(real *, real *, real *, real *, real *)
+ ;
+ real ssmax;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *), slarfg_(integer *, real *, real *, integer *,
+ real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Given two column vectors X and Y, let */
+
+/* A = ( X Y ). */
+
+/* The subroutine first computes the QR factorization of A = Q*R, */
+/* and then computes the SVD of the 2-by-2 upper triangular matrix R. */
+/* The smaller singular value of R is returned in SSMIN, which is used */
+/* as the measurement of the linear dependency of the vectors X and Y. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The length of the vectors X and Y. */
+
+/* X (input/output) REAL array, */
+/* dimension (1+(N-1)*INCX) */
+/* On entry, X contains the N-vector X. */
+/* On exit, X is overwritten. */
+
+/* INCX (input) INTEGER */
+/* The increment between successive elements of X. INCX > 0. */
+
+/* Y (input/output) REAL array, */
+/* dimension (1+(N-1)*INCY) */
+/* On entry, Y contains the N-vector Y. */
+/* On exit, Y is overwritten. */
+
+/* INCY (input) INTEGER */
+/* The increment between successive elements of Y. INCY > 0. */
+
+/* SSMIN (output) REAL */
+/* The smallest singular value of the N-by-2 matrix A = ( X Y ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --y;
+ --x;
+
+ /* Function Body */
+ if (*n <= 1) {
+ *ssmin = 0.f;
+ return 0;
+ }
+
+/* Compute the QR factorization of the N-by-2 matrix ( X Y ) */
+
+ slarfg_(n, &x[1], &x[*incx + 1], incx, &tau);
+ a11 = x[1];
+ x[1] = 1.f;
+
+ c__ = -tau * sdot_(n, &x[1], incx, &y[1], incy);
+ saxpy_(n, &c__, &x[1], incx, &y[1], incy);
+
+ i__1 = *n - 1;
+ slarfg_(&i__1, &y[*incy + 1], &y[(*incy << 1) + 1], incy, &tau);
+
+ a12 = y[1];
+ a22 = y[*incy + 1];
+
+/* Compute the SVD of 2-by-2 Upper triangular matrix. */
+
+ slas2_(&a11, &a12, &a22, ssmin, &ssmax);
+
+ return 0;
+
+/* End of SLAPLL */
+
+} /* slapll_ */
diff --git a/SRC/slapmt.c b/SRC/slapmt.c
new file mode 100644
index 0000000..b77282e
--- /dev/null
+++ b/SRC/slapmt.c
@@ -0,0 +1,177 @@
+/* slapmt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slapmt_(logical *forwrd, integer *m, integer *n, real *x,
+ integer *ldx, integer *k)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, ii, in;
+ real temp;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAPMT rearranges the columns of the M by N matrix X as specified */
+/* by the permutation K(1),K(2),...,K(N) of the integers 1,...,N. */
+/* If FORWRD = .TRUE., forward permutation: */
+
+/* X(*,K(J)) is moved X(*,J) for J = 1,2,...,N. */
+
+/* If FORWRD = .FALSE., backward permutation: */
+
+/* X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N. */
+
+/* Arguments */
+/* ========= */
+
+/* FORWRD (input) LOGICAL */
+/* = .TRUE., forward permutation */
+/* = .FALSE., backward permutation */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix X. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix X. N >= 0. */
+
+/* X (input/output) REAL array, dimension (LDX,N) */
+/* On entry, the M by N matrix X. */
+/* On exit, X contains the permuted matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X, LDX >= MAX(1,M). */
+
+/* K (input/output) INTEGER array, dimension (N) */
+/* On entry, K contains the permutation vector. K is used as */
+/* internal workspace, but reset to its original value on */
+/* output. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --k;
+
+ /* Function Body */
+ if (*n <= 1) {
+ return 0;
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ k[i__] = -k[i__];
+/* L10: */
+ }
+
+ if (*forwrd) {
+
+/* Forward permutation */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+ if (k[i__] > 0) {
+ goto L40;
+ }
+
+ j = i__;
+ k[j] = -k[j];
+ in = k[j];
+
+L20:
+ if (k[in] > 0) {
+ goto L40;
+ }
+
+ i__2 = *m;
+ for (ii = 1; ii <= i__2; ++ii) {
+ temp = x[ii + j * x_dim1];
+ x[ii + j * x_dim1] = x[ii + in * x_dim1];
+ x[ii + in * x_dim1] = temp;
+/* L30: */
+ }
+
+ k[in] = -k[in];
+ j = in;
+ in = k[in];
+ goto L20;
+
+L40:
+
+/* L60: */
+ ;
+ }
+
+ } else {
+
+/* Backward permutation */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+ if (k[i__] > 0) {
+ goto L100;
+ }
+
+ k[i__] = -k[i__];
+ j = k[i__];
+L80:
+ if (j == i__) {
+ goto L100;
+ }
+
+ i__2 = *m;
+ for (ii = 1; ii <= i__2; ++ii) {
+ temp = x[ii + i__ * x_dim1];
+ x[ii + i__ * x_dim1] = x[ii + j * x_dim1];
+ x[ii + j * x_dim1] = temp;
+/* L90: */
+ }
+
+ k[j] = -k[j];
+ j = k[j];
+ goto L80;
+
+L100:
+/* L110: */
+ ;
+ }
+
+ }
+
+ return 0;
+
+/* End of SLAPMT */
+
+} /* slapmt_ */
diff --git a/SRC/slapy2.c b/SRC/slapy2.c
new file mode 100644
index 0000000..e048cac
--- /dev/null
+++ b/SRC/slapy2.c
@@ -0,0 +1,73 @@
+/* slapy2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal slapy2_(real *x, real *y)
+{
+ /* System generated locals */
+ real ret_val, r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real w, z__, xabs, yabs;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary */
+/* overflow. */
+
+/* Arguments */
+/* ========= */
+
+/* X (input) REAL */
+/* Y (input) REAL */
+/* X and Y specify the values x and y. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ xabs = dabs(*x);
+ yabs = dabs(*y);
+ w = dmax(xabs,yabs);
+ z__ = dmin(xabs,yabs);
+ if (z__ == 0.f) {
+ ret_val = w;
+ } else {
+/* Computing 2nd power */
+ r__1 = z__ / w;
+ ret_val = w * sqrt(r__1 * r__1 + 1.f);
+ }
+ return ret_val;
+
+/* End of SLAPY2 */
+
+} /* slapy2_ */
diff --git a/SRC/slapy3.c b/SRC/slapy3.c
new file mode 100644
index 0000000..921a2c4
--- /dev/null
+++ b/SRC/slapy3.c
@@ -0,0 +1,83 @@
+/* slapy3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal slapy3_(real *x, real *y, real *z__)
+{
+ /* System generated locals */
+ real ret_val, r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real w, xabs, yabs, zabs;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause */
+/* unnecessary overflow. */
+
+/* Arguments */
+/* ========= */
+
+/* X (input) REAL */
+/* Y (input) REAL */
+/* Z (input) REAL */
+/* X, Y and Z specify the values x, y and z. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ xabs = dabs(*x);
+ yabs = dabs(*y);
+ zabs = dabs(*z__);
+/* Computing MAX */
+ r__1 = max(xabs,yabs);
+ w = dmax(r__1,zabs);
+ if (w == 0.f) {
+/* W can be zero for max(0,nan,0) */
+/* adding all three entries together will make sure */
+/* NaN will not disappear. */
+ ret_val = xabs + yabs + zabs;
+ } else {
+/* Computing 2nd power */
+ r__1 = xabs / w;
+/* Computing 2nd power */
+ r__2 = yabs / w;
+/* Computing 2nd power */
+ r__3 = zabs / w;
+ ret_val = w * sqrt(r__1 * r__1 + r__2 * r__2 + r__3 * r__3);
+ }
+ return ret_val;
+
+/* End of SLAPY3 */
+
+} /* slapy3_ */
diff --git a/SRC/slaqgb.c b/SRC/slaqgb.c
new file mode 100644
index 0000000..1a4a6b0
--- /dev/null
+++ b/SRC/slaqgb.c
@@ -0,0 +1,216 @@
+/* slaqgb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slaqgb_(integer *m, integer *n, integer *kl, integer *ku,
+ real *ab, integer *ldab, real *r__, real *c__, real *rowcnd, real *
+ colcnd, real *amax, char *equed)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+
+ /* Local variables */
+ integer i__, j;
+ real cj, large, small;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAQGB equilibrates a general M by N band matrix A with KL */
+/* subdiagonals and KU superdiagonals using the row and scaling factors */
+/* in the vectors R and C. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input/output) REAL array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */
+
+/* On exit, the equilibrated matrix, in the same storage format */
+/* as A. See EQUED for the form of the equilibrated matrix. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDA >= KL+KU+1. */
+
+/* R (input) REAL array, dimension (M) */
+/* The row scale factors for A. */
+
+/* C (input) REAL array, dimension (N) */
+/* The column scale factors for A. */
+
+/* ROWCND (input) REAL */
+/* Ratio of the smallest R(i) to the largest R(i). */
+
+/* COLCND (input) REAL */
+/* Ratio of the smallest C(i) to the largest C(i). */
+
+/* AMAX (input) REAL */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if row or column scaling */
+/* should be done based on the ratio of the row or column scaling */
+/* factors. If ROWCND < THRESH, row scaling is done, and if */
+/* COLCND < THRESH, column scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if row scaling */
+/* should be done based on the absolute size of the largest matrix */
+/* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = slamch_("Safe minimum") / slamch_("Precision");
+ large = 1.f / small;
+
+ if (*rowcnd >= .1f && *amax >= small && *amax <= large) {
+
+/* No row scaling */
+
+ if (*colcnd >= .1f) {
+
+/* No column scaling */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = c__[j];
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__4 = min(i__5,i__6);
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ ab[*ku + 1 + i__ - j + j * ab_dim1] = cj * ab[*ku + 1 +
+ i__ - j + j * ab_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+ *(unsigned char *)equed = 'C';
+ }
+ } else if (*colcnd >= .1f) {
+
+/* Row scaling, no column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__3 = min(i__5,i__6);
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ ab[*ku + 1 + i__ - j + j * ab_dim1] = r__[i__] * ab[*ku + 1 +
+ i__ - j + j * ab_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ *(unsigned char *)equed = 'R';
+ } else {
+
+/* Row and column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = c__[j];
+/* Computing MAX */
+ i__3 = 1, i__4 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__2 = min(i__5,i__6);
+ for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) {
+ ab[*ku + 1 + i__ - j + j * ab_dim1] = cj * r__[i__] * ab[*ku
+ + 1 + i__ - j + j * ab_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+ *(unsigned char *)equed = 'B';
+ }
+
+ return 0;
+
+/* End of SLAQGB */
+
+} /* slaqgb_ */
diff --git a/SRC/slaqge.c b/SRC/slaqge.c
new file mode 100644
index 0000000..54e8f1b
--- /dev/null
+++ b/SRC/slaqge.c
@@ -0,0 +1,188 @@
+/* slaqge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slaqge_(integer *m, integer *n, real *a, integer *lda,
+ real *r__, real *c__, real *rowcnd, real *colcnd, real *amax, char *
+ equed)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ real cj, large, small;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAQGE equilibrates a general M by N matrix A using the row and */
+/* column scaling factors in the vectors R and C. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M by N matrix A. */
+/* On exit, the equilibrated matrix. See EQUED for the form of */
+/* the equilibrated matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(M,1). */
+
+/* R (input) REAL array, dimension (M) */
+/* The row scale factors for A. */
+
+/* C (input) REAL array, dimension (N) */
+/* The column scale factors for A. */
+
+/* ROWCND (input) REAL */
+/* Ratio of the smallest R(i) to the largest R(i). */
+
+/* COLCND (input) REAL */
+/* Ratio of the smallest C(i) to the largest C(i). */
+
+/* AMAX (input) REAL */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if row or column scaling */
+/* should be done based on the ratio of the row or column scaling */
+/* factors. If ROWCND < THRESH, row scaling is done, and if */
+/* COLCND < THRESH, column scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if row scaling */
+/* should be done based on the absolute size of the largest matrix */
+/* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = slamch_("Safe minimum") / slamch_("Precision");
+ large = 1.f / small;
+
+ if (*rowcnd >= .1f && *amax >= small && *amax <= large) {
+
+/* No row scaling */
+
+ if (*colcnd >= .1f) {
+
+/* No column scaling */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = c__[j];
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = cj * a[i__ + j * a_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+ *(unsigned char *)equed = 'C';
+ }
+ } else if (*colcnd >= .1f) {
+
+/* Row scaling, no column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = r__[i__] * a[i__ + j * a_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ *(unsigned char *)equed = 'R';
+ } else {
+
+/* Row and column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = c__[j];
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = cj * r__[i__] * a[i__ + j * a_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+ *(unsigned char *)equed = 'B';
+ }
+
+ return 0;
+
+/* End of SLAQGE */
+
+} /* slaqge_ */
diff --git a/SRC/slaqp2.c b/SRC/slaqp2.c
new file mode 100644
index 0000000..2b97dff
--- /dev/null
+++ b/SRC/slaqp2.c
@@ -0,0 +1,238 @@
+/* slaqp2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int slaqp2_(integer *m, integer *n, integer *offset, real *a,
+ integer *lda, integer *jpvt, real *tau, real *vn1, real *vn2, real *
+ work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, mn;
+ real aii;
+ integer pvt;
+ real temp, temp2;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ real tol3z;
+ integer offpi;
+ extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *);
+ integer itemp;
+ extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
+ integer *);
+ extern doublereal slamch_(char *);
+ extern integer isamax_(integer *, real *, integer *);
+ extern /* Subroutine */ int slarfp_(integer *, real *, real *, integer *,
+ real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAQP2 computes a QR factorization with column pivoting of */
+/* the block A(OFFSET+1:M,1:N). */
+/* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* OFFSET (input) INTEGER */
+/* The number of rows of the matrix A that must be pivoted */
+/* but no factorized. OFFSET >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is */
+/* the triangular factor obtained; the elements in block */
+/* A(OFFSET+1:M,1:N) below the diagonal, together with the */
+/* array TAU, represent the orthogonal matrix Q as a product of */
+/* elementary reflectors. Block A(1:OFFSET,1:N) has been */
+/* accordingly pivoted, but no factorized. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
+/* to the front of A*P (a leading column); if JPVT(i) = 0, */
+/* the i-th column of A is a free column. */
+/* On exit, if JPVT(i) = k, then the i-th column of A*P */
+/* was the k-th column of A. */
+
+/* TAU (output) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors. */
+
+/* VN1 (input/output) REAL array, dimension (N) */
+/* The vector with the partial column norms. */
+
+/* VN2 (input/output) REAL array, dimension (N) */
+/* The vector with the exact column norms. */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
+/* X. Sun, Computer Science Dept., Duke University, USA */
+
+/* Partial column norm updating strategy modified by */
+/* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */
+/* University of Zagreb, Croatia. */
+/* June 2006. */
+/* For more details see LAPACK Working Note 176. */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --jpvt;
+ --tau;
+ --vn1;
+ --vn2;
+ --work;
+
+ /* Function Body */
+/* Computing MIN */
+ i__1 = *m - *offset;
+ mn = min(i__1,*n);
+ tol3z = sqrt(slamch_("Epsilon"));
+
+/* Compute factorization. */
+
+ i__1 = mn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+ offpi = *offset + i__;
+
+/* Determine ith pivot column and swap if necessary. */
+
+ i__2 = *n - i__ + 1;
+ pvt = i__ - 1 + isamax_(&i__2, &vn1[i__], &c__1);
+
+ if (pvt != i__) {
+ sswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
+ c__1);
+ itemp = jpvt[pvt];
+ jpvt[pvt] = jpvt[i__];
+ jpvt[i__] = itemp;
+ vn1[pvt] = vn1[i__];
+ vn2[pvt] = vn2[i__];
+ }
+
+/* Generate elementary reflector H(i). */
+
+ if (offpi < *m) {
+ i__2 = *m - offpi + 1;
+ slarfp_(&i__2, &a[offpi + i__ * a_dim1], &a[offpi + 1 + i__ *
+ a_dim1], &c__1, &tau[i__]);
+ } else {
+ slarfp_(&c__1, &a[*m + i__ * a_dim1], &a[*m + i__ * a_dim1], &
+ c__1, &tau[i__]);
+ }
+
+ if (i__ < *n) {
+
+/* Apply H(i)' to A(offset+i:m,i+1:n) from the left. */
+
+ aii = a[offpi + i__ * a_dim1];
+ a[offpi + i__ * a_dim1] = 1.f;
+ i__2 = *m - offpi + 1;
+ i__3 = *n - i__;
+ slarf_("Left", &i__2, &i__3, &a[offpi + i__ * a_dim1], &c__1, &
+ tau[i__], &a[offpi + (i__ + 1) * a_dim1], lda, &work[1]);
+ a[offpi + i__ * a_dim1] = aii;
+ }
+
+/* Update partial column norms. */
+
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (vn1[j] != 0.f) {
+
+/* NOTE: The following 4 lines follow from the analysis in */
+/* Lapack Working Note 176. */
+
+/* Computing 2nd power */
+ r__2 = (r__1 = a[offpi + j * a_dim1], dabs(r__1)) / vn1[j];
+ temp = 1.f - r__2 * r__2;
+ temp = dmax(temp,0.f);
+/* Computing 2nd power */
+ r__1 = vn1[j] / vn2[j];
+ temp2 = temp * (r__1 * r__1);
+ if (temp2 <= tol3z) {
+ if (offpi < *m) {
+ i__3 = *m - offpi;
+ vn1[j] = snrm2_(&i__3, &a[offpi + 1 + j * a_dim1], &
+ c__1);
+ vn2[j] = vn1[j];
+ } else {
+ vn1[j] = 0.f;
+ vn2[j] = 0.f;
+ }
+ } else {
+ vn1[j] *= sqrt(temp);
+ }
+ }
+/* L10: */
+ }
+
+/* L20: */
+ }
+
+ return 0;
+
+/* End of SLAQP2 */
+
+} /* slaqp2_ */
diff --git a/SRC/slaqps.c b/SRC/slaqps.c
new file mode 100644
index 0000000..dc26102
--- /dev/null
+++ b/SRC/slaqps.c
@@ -0,0 +1,342 @@
+/* slaqps.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b8 = -1.f;
+static real c_b9 = 1.f;
+static real c_b16 = 0.f;
+
+/* Subroutine */ int slaqps_(integer *m, integer *n, integer *offset, integer
+ *nb, integer *kb, real *a, integer *lda, integer *jpvt, real *tau,
+ real *vn1, real *vn2, real *auxv, real *f, integer *ldf)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, f_dim1, f_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer i_nint(real *);
+
+ /* Local variables */
+ integer j, k, rk;
+ real akk;
+ integer pvt;
+ real temp, temp2;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ real tol3z;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ integer itemp;
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *), sswap_(integer *, real *, integer *, real *, integer *);
+ extern doublereal slamch_(char *);
+ integer lsticc;
+ extern integer isamax_(integer *, real *, integer *);
+ extern /* Subroutine */ int slarfp_(integer *, real *, real *, integer *,
+ real *);
+ integer lastrk;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAQPS computes a step of QR factorization with column pivoting */
+/* of a real M-by-N matrix A by using Blas-3. It tries to factorize */
+/* NB columns from A starting from the row OFFSET+1, and updates all */
+/* of the matrix with Blas-3 xGEMM. */
+
+/* In some cases, due to catastrophic cancellations, it cannot */
+/* factorize NB columns. Hence, the actual number of factorized */
+/* columns is returned in KB. */
+
+/* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0 */
+
+/* OFFSET (input) INTEGER */
+/* The number of rows of A that have been factorized in */
+/* previous steps. */
+
+/* NB (input) INTEGER */
+/* The number of columns to factorize. */
+
+/* KB (output) INTEGER */
+/* The number of columns actually factorized. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, block A(OFFSET+1:M,1:KB) is the triangular */
+/* factor obtained and block A(1:OFFSET,1:N) has been */
+/* accordingly pivoted, but no factorized. */
+/* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has */
+/* been updated. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* JPVT(I) = K <==> Column K of the full matrix A has been */
+/* permuted into position I in AP. */
+
+/* TAU (output) REAL array, dimension (KB) */
+/* The scalar factors of the elementary reflectors. */
+
+/* VN1 (input/output) REAL array, dimension (N) */
+/* The vector with the partial column norms. */
+
+/* VN2 (input/output) REAL array, dimension (N) */
+/* The vector with the exact column norms. */
+
+/* AUXV (input/output) REAL array, dimension (NB) */
+/* Auxiliar vector. */
+
+/* F (input/output) REAL array, dimension (LDF,NB) */
+/* Matrix F' = L*Y'*A. */
+
+/* LDF (input) INTEGER */
+/* The leading dimension of the array F. LDF >= max(1,N). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
+/* X. Sun, Computer Science Dept., Duke University, USA */
+
+/* Partial column norm updating strategy modified by */
+/* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */
+/* University of Zagreb, Croatia. */
+/* June 2006. */
+/* For more details see LAPACK Working Note 176. */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --jpvt;
+ --tau;
+ --vn1;
+ --vn2;
+ --auxv;
+ f_dim1 = *ldf;
+ f_offset = 1 + f_dim1;
+ f -= f_offset;
+
+ /* Function Body */
+/* Computing MIN */
+ i__1 = *m, i__2 = *n + *offset;
+ lastrk = min(i__1,i__2);
+ lsticc = 0;
+ k = 0;
+ tol3z = sqrt(slamch_("Epsilon"));
+
+/* Beginning of while loop. */
+
+L10:
+ if (k < *nb && lsticc == 0) {
+ ++k;
+ rk = *offset + k;
+
+/* Determine ith pivot column and swap if necessary */
+
+ i__1 = *n - k + 1;
+ pvt = k - 1 + isamax_(&i__1, &vn1[k], &c__1);
+ if (pvt != k) {
+ sswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1);
+ i__1 = k - 1;
+ sswap_(&i__1, &f[pvt + f_dim1], ldf, &f[k + f_dim1], ldf);
+ itemp = jpvt[pvt];
+ jpvt[pvt] = jpvt[k];
+ jpvt[k] = itemp;
+ vn1[pvt] = vn1[k];
+ vn2[pvt] = vn2[k];
+ }
+
+/* Apply previous Householder reflectors to column K: */
+/* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)'. */
+
+ if (k > 1) {
+ i__1 = *m - rk + 1;
+ i__2 = k - 1;
+ sgemv_("No transpose", &i__1, &i__2, &c_b8, &a[rk + a_dim1], lda,
+ &f[k + f_dim1], ldf, &c_b9, &a[rk + k * a_dim1], &c__1);
+ }
+
+/* Generate elementary reflector H(k). */
+
+ if (rk < *m) {
+ i__1 = *m - rk + 1;
+ slarfp_(&i__1, &a[rk + k * a_dim1], &a[rk + 1 + k * a_dim1], &
+ c__1, &tau[k]);
+ } else {
+ slarfp_(&c__1, &a[rk + k * a_dim1], &a[rk + k * a_dim1], &c__1, &
+ tau[k]);
+ }
+
+ akk = a[rk + k * a_dim1];
+ a[rk + k * a_dim1] = 1.f;
+
+/* Compute Kth column of F: */
+
+/* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)'*A(RK:M,K). */
+
+ if (k < *n) {
+ i__1 = *m - rk + 1;
+ i__2 = *n - k;
+ sgemv_("Transpose", &i__1, &i__2, &tau[k], &a[rk + (k + 1) *
+ a_dim1], lda, &a[rk + k * a_dim1], &c__1, &c_b16, &f[k +
+ 1 + k * f_dim1], &c__1);
+ }
+
+/* Padding F(1:K,K) with zeros. */
+
+ i__1 = k;
+ for (j = 1; j <= i__1; ++j) {
+ f[j + k * f_dim1] = 0.f;
+/* L20: */
+ }
+
+/* Incremental updating of F: */
+/* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)' */
+/* *A(RK:M,K). */
+
+ if (k > 1) {
+ i__1 = *m - rk + 1;
+ i__2 = k - 1;
+ r__1 = -tau[k];
+ sgemv_("Transpose", &i__1, &i__2, &r__1, &a[rk + a_dim1], lda, &a[
+ rk + k * a_dim1], &c__1, &c_b16, &auxv[1], &c__1);
+
+ i__1 = k - 1;
+ sgemv_("No transpose", n, &i__1, &c_b9, &f[f_dim1 + 1], ldf, &
+ auxv[1], &c__1, &c_b9, &f[k * f_dim1 + 1], &c__1);
+ }
+
+/* Update the current row of A: */
+/* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)'. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ sgemv_("No transpose", &i__1, &k, &c_b8, &f[k + 1 + f_dim1], ldf,
+ &a[rk + a_dim1], lda, &c_b9, &a[rk + (k + 1) * a_dim1],
+ lda);
+ }
+
+/* Update partial column norms. */
+
+ if (rk < lastrk) {
+ i__1 = *n;
+ for (j = k + 1; j <= i__1; ++j) {
+ if (vn1[j] != 0.f) {
+
+/* NOTE: The following 4 lines follow from the analysis in */
+/* Lapack Working Note 176. */
+
+ temp = (r__1 = a[rk + j * a_dim1], dabs(r__1)) / vn1[j];
+/* Computing MAX */
+ r__1 = 0.f, r__2 = (temp + 1.f) * (1.f - temp);
+ temp = dmax(r__1,r__2);
+/* Computing 2nd power */
+ r__1 = vn1[j] / vn2[j];
+ temp2 = temp * (r__1 * r__1);
+ if (temp2 <= tol3z) {
+ vn2[j] = (real) lsticc;
+ lsticc = j;
+ } else {
+ vn1[j] *= sqrt(temp);
+ }
+ }
+/* L30: */
+ }
+ }
+
+ a[rk + k * a_dim1] = akk;
+
+/* End of while loop. */
+
+ goto L10;
+ }
+ *kb = k;
+ rk = *offset + *kb;
+
+/* Apply the block reflector to the rest of the matrix: */
+/* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - */
+/* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)'. */
+
+/* Computing MIN */
+ i__1 = *n, i__2 = *m - *offset;
+ if (*kb < min(i__1,i__2)) {
+ i__1 = *m - rk;
+ i__2 = *n - *kb;
+ sgemm_("No transpose", "Transpose", &i__1, &i__2, kb, &c_b8, &a[rk +
+ 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b9, &a[rk + 1
+ + (*kb + 1) * a_dim1], lda);
+ }
+
+/* Recomputation of difficult columns. */
+
+L40:
+ if (lsticc > 0) {
+ itemp = i_nint(&vn2[lsticc]);
+ i__1 = *m - rk;
+ vn1[lsticc] = snrm2_(&i__1, &a[rk + 1 + lsticc * a_dim1], &c__1);
+
+/* NOTE: The computation of VN1( LSTICC ) relies on the fact that */
+/* SNRM2 does not fail on vectors with norm below the value of */
+/* SQRT(DLAMCH('S')) */
+
+ vn2[lsticc] = vn1[lsticc];
+ lsticc = itemp;
+ goto L40;
+ }
+
+ return 0;
+
+/* End of SLAQPS */
+
+} /* slaqps_ */
diff --git a/SRC/slaqr0.c b/SRC/slaqr0.c
new file mode 100644
index 0000000..4ef4a86
--- /dev/null
+++ b/SRC/slaqr0.c
@@ -0,0 +1,753 @@
+/* slaqr0.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__13 = 13;
+static integer c__15 = 15;
+static integer c_n1 = -1;
+static integer c__12 = 12;
+static integer c__14 = 14;
+static integer c__16 = 16;
+static logical c_false = FALSE_;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int slaqr0_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, real *h__, integer *ldh, real *wr, real *
+ wi, integer *iloz, integer *ihiz, real *z__, integer *ldz, real *work,
+ integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+
+ /* Local variables */
+ integer i__, k;
+ real aa, bb, cc, dd;
+ integer ld;
+ real cs;
+ integer nh, it, ks, kt;
+ real sn;
+ integer ku, kv, ls, ns;
+ real ss;
+ integer nw, inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot,
+ nmin;
+ real swap;
+ integer ktop;
+ real zdum[1] /* was [1][1] */;
+ integer kacc22, itmax, nsmax, nwmax, kwtop;
+ extern /* Subroutine */ int slanv2_(real *, real *, real *, real *, real *
+, real *, real *, real *, real *, real *), slaqr3_(logical *,
+ logical *, integer *, integer *, integer *, integer *, real *,
+ integer *, integer *, integer *, real *, integer *, integer *,
+ integer *, real *, real *, real *, integer *, integer *, real *,
+ integer *, integer *, real *, integer *, real *, integer *),
+ slaqr4_(logical *, logical *, integer *, integer *, integer *,
+ real *, integer *, real *, real *, integer *, integer *, real *,
+ integer *, real *, integer *, integer *), slaqr5_(logical *,
+ logical *, integer *, integer *, integer *, integer *, integer *,
+ real *, real *, real *, integer *, integer *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, integer *, real *
+, integer *, integer *, real *, integer *);
+ integer nibble;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ char jbcmpz[2];
+ extern /* Subroutine */ int slahqr_(logical *, logical *, integer *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, integer *, real *, integer *, integer *), slacpy_(char *,
+ integer *, integer *, real *, integer *, real *, integer *);
+ integer nwupbd;
+ logical sorted;
+ integer lwkopt;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAQR0 computes the eigenvalues of a Hessenberg matrix H */
+/* and, optionally, the matrices T and Z from the Schur decomposition */
+/* H = Z T Z**T, where T is an upper quasi-triangular matrix (the */
+/* Schur form), and Z is the orthogonal matrix of Schur vectors. */
+
+/* Optionally Z may be postmultiplied into an input orthogonal */
+/* matrix Q so that this routine can give the Schur factorization */
+/* of a matrix A which has been reduced to the Hessenberg form H */
+/* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */
+
+/* Arguments */
+/* ========= */
+
+/* WANTT (input) LOGICAL */
+/* = .TRUE. : the full Schur form T is required; */
+/* = .FALSE.: only eigenvalues are required. */
+
+/* WANTZ (input) LOGICAL */
+/* = .TRUE. : the matrix of Schur vectors Z is required; */
+/* = .FALSE.: Schur vectors are not required. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N .GE. 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that H is already upper triangular in rows */
+/* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, */
+/* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a */
+/* previous call to SGEBAL, and then passed to SGEHRD when the */
+/* matrix output by SGEBAL is reduced to Hessenberg form. */
+/* Otherwise, ILO and IHI should be set to 1 and N, */
+/* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */
+/* If N = 0, then ILO = 1 and IHI = 0. */
+
+/* H (input/output) REAL array, dimension (LDH,N) */
+/* On entry, the upper Hessenberg matrix H. */
+/* On exit, if INFO = 0 and WANTT is .TRUE., then H contains */
+/* the upper quasi-triangular matrix T from the Schur */
+/* decomposition (the Schur form); 2-by-2 diagonal blocks */
+/* (corresponding to complex conjugate pairs of eigenvalues) */
+/* are returned in standard form, with H(i,i) = H(i+1,i+1) */
+/* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is */
+/* .FALSE., then the contents of H are unspecified on exit. */
+/* (The output value of H when INFO.GT.0 is given under the */
+/* description of INFO below.) */
+
+/* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and */
+/* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH .GE. max(1,N). */
+
+/* WR (output) REAL array, dimension (IHI) */
+/* WI (output) REAL array, dimension (IHI) */
+/* The real and imaginary parts, respectively, of the computed */
+/* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) */
+/* and WI(ILO:IHI). If two eigenvalues are computed as a */
+/* complex conjugate pair, they are stored in consecutive */
+/* elements of WR and WI, say the i-th and (i+1)th, with */
+/* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then */
+/* the eigenvalues are stored in the same order as on the */
+/* diagonal of the Schur form returned in H, with */
+/* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal */
+/* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and */
+/* WI(i+1) = -WI(i). */
+
+/* ILOZ (input) INTEGER */
+/* IHIZ (input) INTEGER */
+/* Specify the rows of Z to which transformations must be */
+/* applied if WANTZ is .TRUE.. */
+/* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. */
+
+/* Z (input/output) REAL array, dimension (LDZ,IHI) */
+/* If WANTZ is .FALSE., then Z is not referenced. */
+/* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is */
+/* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the */
+/* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). */
+/* (The output value of Z when INFO.GT.0 is given under */
+/* the description of INFO below.) */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. if WANTZ is .TRUE. */
+/* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. */
+
+/* WORK (workspace/output) REAL array, dimension LWORK */
+/* On exit, if LWORK = -1, WORK(1) returns an estimate of */
+/* the optimal value for LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK .GE. max(1,N) */
+/* is sufficient, but LWORK typically as large as 6*N may */
+/* be required for optimal performance. A workspace query */
+/* to determine the optimal workspace size is recommended. */
+
+/* If LWORK = -1, then SLAQR0 does a workspace query. */
+/* In this case, SLAQR0 checks the input parameters and */
+/* estimates the optimal workspace size for the given */
+/* values of N, ILO and IHI. The estimate is returned */
+/* in WORK(1). No error message related to LWORK is */
+/* issued by XERBLA. Neither H nor Z are accessed. */
+
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* .GT. 0: if INFO = i, SLAQR0 failed to compute all of */
+/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */
+/* and WI contain those eigenvalues which have been */
+/* successfully computed. (Failures are rare.) */
+
+/* If INFO .GT. 0 and WANT is .FALSE., then on exit, */
+/* the remaining unconverged eigenvalues are the eigen- */
+/* values of the upper Hessenberg matrix rows and */
+/* columns ILO through INFO of the final, output */
+/* value of H. */
+
+/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */
+
+/* (*) (initial value of H)*U = U*(final value of H) */
+
+/* where U is an orthogonal matrix. The final */
+/* value of H is upper Hessenberg and quasi-triangular */
+/* in rows and columns INFO+1 through IHI. */
+
+/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
+
+/* (final value of Z(ILO:IHI,ILOZ:IHIZ) */
+/* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U */
+
+/* where U is the orthogonal matrix in (*) (regard- */
+/* less of the value of WANTT.) */
+
+/* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not */
+/* accessed. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* References: */
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */
+/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */
+/* 929--947, 2002. */
+
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */
+/* of Matrix Analysis, volume 23, pages 948--973, 2002. */
+
+/* ================================================================ */
+/* .. Parameters .. */
+
+/* ==== Matrices of order NTINY or smaller must be processed by */
+/* . SLAHQR because of insufficient subdiagonal scratch space. */
+/* . (This is a hard limit.) ==== */
+
+/* ==== Exceptional deflation windows: try to cure rare */
+/* . slow convergence by varying the size of the */
+/* . deflation window after KEXNW iterations. ==== */
+
+/* ==== Exceptional shifts: try to cure rare slow convergence */
+/* . with ad-hoc exceptional shifts every KEXSH iterations. */
+/* . ==== */
+
+/* ==== The constants WILK1 and WILK2 are used to form the */
+/* . exceptional shifts. ==== */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --wr;
+ --wi;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* ==== Quick return for N = 0: nothing to do. ==== */
+
+ if (*n == 0) {
+ work[1] = 1.f;
+ return 0;
+ }
+
+ if (*n <= 11) {
+
+/* ==== Tiny matrices must use SLAHQR. ==== */
+
+ lwkopt = 1;
+ if (*lwork != -1) {
+ slahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &
+ wi[1], iloz, ihiz, &z__[z_offset], ldz, info);
+ }
+ } else {
+
+/* ==== Use small bulge multi-shift QR with aggressive early */
+/* . deflation on larger-than-tiny matrices. ==== */
+
+/* ==== Hope for the best. ==== */
+
+ *info = 0;
+
+/* ==== Set up job flags for ILAENV. ==== */
+
+ if (*wantt) {
+ *(unsigned char *)jbcmpz = 'S';
+ } else {
+ *(unsigned char *)jbcmpz = 'E';
+ }
+ if (*wantz) {
+ *(unsigned char *)&jbcmpz[1] = 'V';
+ } else {
+ *(unsigned char *)&jbcmpz[1] = 'N';
+ }
+
+/* ==== NWR = recommended deflation window size. At this */
+/* . point, N .GT. NTINY = 11, so there is enough */
+/* . subdiagonal workspace for NWR.GE.2 as required. */
+/* . (In fact, there is enough subdiagonal space for */
+/* . NWR.GE.3.) ==== */
+
+ nwr = ilaenv_(&c__13, "SLAQR0", jbcmpz, n, ilo, ihi, lwork);
+ nwr = max(2,nwr);
+/* Computing MIN */
+ i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = min(i__1,i__2);
+ nwr = min(i__1,nwr);
+
+/* ==== NSR = recommended number of simultaneous shifts. */
+/* . At this point N .GT. NTINY = 11, so there is at */
+/* . enough subdiagonal workspace for NSR to be even */
+/* . and greater than or equal to two as required. ==== */
+
+ nsr = ilaenv_(&c__15, "SLAQR0", jbcmpz, n, ilo, ihi, lwork);
+/* Computing MIN */
+ i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = min(i__1,i__2), i__2 = *ihi -
+ *ilo;
+ nsr = min(i__1,i__2);
+/* Computing MAX */
+ i__1 = 2, i__2 = nsr - nsr % 2;
+ nsr = max(i__1,i__2);
+
+/* ==== Estimate optimal workspace ==== */
+
+/* ==== Workspace query call to SLAQR3 ==== */
+
+ i__1 = nwr + 1;
+ slaqr3_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz,
+ ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[
+ h_offset], ldh, n, &h__[h_offset], ldh, n, &h__[h_offset],
+ ldh, &work[1], &c_n1);
+
+/* ==== Optimal workspace = MAX(SLAQR5, SLAQR3) ==== */
+
+/* Computing MAX */
+ i__1 = nsr * 3 / 2, i__2 = (integer) work[1];
+ lwkopt = max(i__1,i__2);
+
+/* ==== Quick return in case of workspace query. ==== */
+
+ if (*lwork == -1) {
+ work[1] = (real) lwkopt;
+ return 0;
+ }
+
+/* ==== SLAHQR/SLAQR0 crossover point ==== */
+
+ nmin = ilaenv_(&c__12, "SLAQR0", jbcmpz, n, ilo, ihi, lwork);
+ nmin = max(11,nmin);
+
+/* ==== Nibble crossover point ==== */
+
+ nibble = ilaenv_(&c__14, "SLAQR0", jbcmpz, n, ilo, ihi, lwork);
+ nibble = max(0,nibble);
+
+/* ==== Accumulate reflections during ttswp? Use block */
+/* . 2-by-2 structure during matrix-matrix multiply? ==== */
+
+ kacc22 = ilaenv_(&c__16, "SLAQR0", jbcmpz, n, ilo, ihi, lwork);
+ kacc22 = max(0,kacc22);
+ kacc22 = min(2,kacc22);
+
+/* ==== NWMAX = the largest possible deflation window for */
+/* . which there is sufficient workspace. ==== */
+
+/* Computing MIN */
+ i__1 = (*n - 1) / 3, i__2 = *lwork / 2;
+ nwmax = min(i__1,i__2);
+ nw = nwmax;
+
+/* ==== NSMAX = the Largest number of simultaneous shifts */
+/* . for which there is sufficient workspace. ==== */
+
+/* Computing MIN */
+ i__1 = (*n + 6) / 9, i__2 = (*lwork << 1) / 3;
+ nsmax = min(i__1,i__2);
+ nsmax -= nsmax % 2;
+
+/* ==== NDFL: an iteration count restarted at deflation. ==== */
+
+ ndfl = 1;
+
+/* ==== ITMAX = iteration limit ==== */
+
+/* Computing MAX */
+ i__1 = 10, i__2 = *ihi - *ilo + 1;
+ itmax = max(i__1,i__2) * 30;
+
+/* ==== Last row and column in the active block ==== */
+
+ kbot = *ihi;
+
+/* ==== Main Loop ==== */
+
+ i__1 = itmax;
+ for (it = 1; it <= i__1; ++it) {
+
+/* ==== Done when KBOT falls below ILO ==== */
+
+ if (kbot < *ilo) {
+ goto L90;
+ }
+
+/* ==== Locate active block ==== */
+
+ i__2 = *ilo + 1;
+ for (k = kbot; k >= i__2; --k) {
+ if (h__[k + (k - 1) * h_dim1] == 0.f) {
+ goto L20;
+ }
+/* L10: */
+ }
+ k = *ilo;
+L20:
+ ktop = k;
+
+/* ==== Select deflation window size: */
+/* . Typical Case: */
+/* . If possible and advisable, nibble the entire */
+/* . active block. If not, use size MIN(NWR,NWMAX) */
+/* . or MIN(NWR+1,NWMAX) depending upon which has */
+/* . the smaller corresponding subdiagonal entry */
+/* . (a heuristic). */
+/* . */
+/* . Exceptional Case: */
+/* . If there have been no deflations in KEXNW or */
+/* . more iterations, then vary the deflation window */
+/* . size. At first, because, larger windows are, */
+/* . in general, more powerful than smaller ones, */
+/* . rapidly increase the window to the maximum possible. */
+/* . Then, gradually reduce the window size. ==== */
+
+ nh = kbot - ktop + 1;
+ nwupbd = min(nh,nwmax);
+ if (ndfl < 5) {
+ nw = min(nwupbd,nwr);
+ } else {
+/* Computing MIN */
+ i__2 = nwupbd, i__3 = nw << 1;
+ nw = min(i__2,i__3);
+ }
+ if (nw < nwmax) {
+ if (nw >= nh - 1) {
+ nw = nh;
+ } else {
+ kwtop = kbot - nw + 1;
+ if ((r__1 = h__[kwtop + (kwtop - 1) * h_dim1], dabs(r__1))
+ > (r__2 = h__[kwtop - 1 + (kwtop - 2) * h_dim1],
+ dabs(r__2))) {
+ ++nw;
+ }
+ }
+ }
+ if (ndfl < 5) {
+ ndec = -1;
+ } else if (ndec >= 0 || nw >= nwupbd) {
+ ++ndec;
+ if (nw - ndec < 2) {
+ ndec = 0;
+ }
+ nw -= ndec;
+ }
+
+/* ==== Aggressive early deflation: */
+/* . split workspace under the subdiagonal into */
+/* . - an nw-by-nw work array V in the lower */
+/* . left-hand-corner, */
+/* . - an NW-by-at-least-NW-but-more-is-better */
+/* . (NW-by-NHO) horizontal work array along */
+/* . the bottom edge, */
+/* . - an at-least-NW-but-more-is-better (NHV-by-NW) */
+/* . vertical work array along the left-hand-edge. */
+/* . ==== */
+
+ kv = *n - nw + 1;
+ kt = nw + 1;
+ nho = *n - nw - 1 - kt + 1;
+ kwv = nw + 2;
+ nve = *n - nw - kwv + 1;
+
+/* ==== Aggressive early deflation ==== */
+
+ slaqr3_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh,
+ iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1],
+ &h__[kv + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1],
+ ldh, &nve, &h__[kwv + h_dim1], ldh, &work[1], lwork);
+
+/* ==== Adjust KBOT accounting for new deflations. ==== */
+
+ kbot -= ld;
+
+/* ==== KS points to the shifts. ==== */
+
+ ks = kbot - ls + 1;
+
+/* ==== Skip an expensive QR sweep if there is a (partly */
+/* . heuristic) reason to expect that many eigenvalues */
+/* . will deflate without it. Here, the QR sweep is */
+/* . skipped if many eigenvalues have just been deflated */
+/* . or if the remaining active block is small. */
+
+ if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > min(
+ nmin,nwmax)) {
+
+/* ==== NS = nominal number of simultaneous shifts. */
+/* . This may be lowered (slightly) if SLAQR3 */
+/* . did not provide that many shifts. ==== */
+
+/* Computing MIN */
+/* Computing MAX */
+ i__4 = 2, i__5 = kbot - ktop;
+ i__2 = min(nsmax,nsr), i__3 = max(i__4,i__5);
+ ns = min(i__2,i__3);
+ ns -= ns % 2;
+
+/* ==== If there have been no deflations */
+/* . in a multiple of KEXSH iterations, */
+/* . then try exceptional shifts. */
+/* . Otherwise use shifts provided by */
+/* . SLAQR3 above or from the eigenvalues */
+/* . of a trailing principal submatrix. ==== */
+
+ if (ndfl % 6 == 0) {
+ ks = kbot - ns + 1;
+/* Computing MAX */
+ i__3 = ks + 1, i__4 = ktop + 2;
+ i__2 = max(i__3,i__4);
+ for (i__ = kbot; i__ >= i__2; i__ += -2) {
+ ss = (r__1 = h__[i__ + (i__ - 1) * h_dim1], dabs(r__1)
+ ) + (r__2 = h__[i__ - 1 + (i__ - 2) * h_dim1],
+ dabs(r__2));
+ aa = ss * .75f + h__[i__ + i__ * h_dim1];
+ bb = ss;
+ cc = ss * -.4375f;
+ dd = aa;
+ slanv2_(&aa, &bb, &cc, &dd, &wr[i__ - 1], &wi[i__ - 1]
+, &wr[i__], &wi[i__], &cs, &sn);
+/* L30: */
+ }
+ if (ks == ktop) {
+ wr[ks + 1] = h__[ks + 1 + (ks + 1) * h_dim1];
+ wi[ks + 1] = 0.f;
+ wr[ks] = wr[ks + 1];
+ wi[ks] = wi[ks + 1];
+ }
+ } else {
+
+/* ==== Got NS/2 or fewer shifts? Use SLAQR4 or */
+/* . SLAHQR on a trailing principal submatrix to */
+/* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, */
+/* . there is enough space below the subdiagonal */
+/* . to fit an NS-by-NS scratch array.) ==== */
+
+ if (kbot - ks + 1 <= ns / 2) {
+ ks = kbot - ns + 1;
+ kt = *n - ns + 1;
+ slacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, &
+ h__[kt + h_dim1], ldh);
+ if (ns > nmin) {
+ slaqr4_(&c_false, &c_false, &ns, &c__1, &ns, &h__[
+ kt + h_dim1], ldh, &wr[ks], &wi[ks], &
+ c__1, &c__1, zdum, &c__1, &work[1], lwork,
+ &inf);
+ } else {
+ slahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[
+ kt + h_dim1], ldh, &wr[ks], &wi[ks], &
+ c__1, &c__1, zdum, &c__1, &inf);
+ }
+ ks += inf;
+
+/* ==== In case of a rare QR failure use */
+/* . eigenvalues of the trailing 2-by-2 */
+/* . principal submatrix. ==== */
+
+ if (ks >= kbot) {
+ aa = h__[kbot - 1 + (kbot - 1) * h_dim1];
+ cc = h__[kbot + (kbot - 1) * h_dim1];
+ bb = h__[kbot - 1 + kbot * h_dim1];
+ dd = h__[kbot + kbot * h_dim1];
+ slanv2_(&aa, &bb, &cc, &dd, &wr[kbot - 1], &wi[
+ kbot - 1], &wr[kbot], &wi[kbot], &cs, &sn)
+ ;
+ ks = kbot - 1;
+ }
+ }
+
+ if (kbot - ks + 1 > ns) {
+
+/* ==== Sort the shifts (Helps a little) */
+/* . Bubble sort keeps complex conjugate */
+/* . pairs together. ==== */
+
+ sorted = FALSE_;
+ i__2 = ks + 1;
+ for (k = kbot; k >= i__2; --k) {
+ if (sorted) {
+ goto L60;
+ }
+ sorted = TRUE_;
+ i__3 = k - 1;
+ for (i__ = ks; i__ <= i__3; ++i__) {
+ if ((r__1 = wr[i__], dabs(r__1)) + (r__2 = wi[
+ i__], dabs(r__2)) < (r__3 = wr[i__ +
+ 1], dabs(r__3)) + (r__4 = wi[i__ + 1],
+ dabs(r__4))) {
+ sorted = FALSE_;
+
+ swap = wr[i__];
+ wr[i__] = wr[i__ + 1];
+ wr[i__ + 1] = swap;
+
+ swap = wi[i__];
+ wi[i__] = wi[i__ + 1];
+ wi[i__ + 1] = swap;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+L60:
+ ;
+ }
+
+/* ==== Shuffle shifts into pairs of real shifts */
+/* . and pairs of complex conjugate shifts */
+/* . assuming complex conjugate shifts are */
+/* . already adjacent to one another. (Yes, */
+/* . they are.) ==== */
+
+ i__2 = ks + 2;
+ for (i__ = kbot; i__ >= i__2; i__ += -2) {
+ if (wi[i__] != -wi[i__ - 1]) {
+
+ swap = wr[i__];
+ wr[i__] = wr[i__ - 1];
+ wr[i__ - 1] = wr[i__ - 2];
+ wr[i__ - 2] = swap;
+
+ swap = wi[i__];
+ wi[i__] = wi[i__ - 1];
+ wi[i__ - 1] = wi[i__ - 2];
+ wi[i__ - 2] = swap;
+ }
+/* L70: */
+ }
+ }
+
+/* ==== If there are only two shifts and both are */
+/* . real, then use only one. ==== */
+
+ if (kbot - ks + 1 == 2) {
+ if (wi[kbot] == 0.f) {
+ if ((r__1 = wr[kbot] - h__[kbot + kbot * h_dim1],
+ dabs(r__1)) < (r__2 = wr[kbot - 1] - h__[kbot
+ + kbot * h_dim1], dabs(r__2))) {
+ wr[kbot - 1] = wr[kbot];
+ } else {
+ wr[kbot] = wr[kbot - 1];
+ }
+ }
+ }
+
+/* ==== Use up to NS of the the smallest magnatiude */
+/* . shifts. If there aren't NS shifts available, */
+/* . then use them all, possibly dropping one to */
+/* . make the number of shifts even. ==== */
+
+/* Computing MIN */
+ i__2 = ns, i__3 = kbot - ks + 1;
+ ns = min(i__2,i__3);
+ ns -= ns % 2;
+ ks = kbot - ns + 1;
+
+/* ==== Small-bulge multi-shift QR sweep: */
+/* . split workspace under the subdiagonal into */
+/* . - a KDU-by-KDU work array U in the lower */
+/* . left-hand-corner, */
+/* . - a KDU-by-at-least-KDU-but-more-is-better */
+/* . (KDU-by-NHo) horizontal work array WH along */
+/* . the bottom edge, */
+/* . - and an at-least-KDU-but-more-is-better-by-KDU */
+/* . (NVE-by-KDU) vertical work WV arrow along */
+/* . the left-hand-edge. ==== */
+
+ kdu = ns * 3 - 3;
+ ku = *n - kdu + 1;
+ kwh = kdu + 1;
+ nho = *n - kdu - 3 - (kdu + 1) + 1;
+ kwv = kdu + 4;
+ nve = *n - kdu - kwv + 1;
+
+/* ==== Small-bulge multi-shift QR sweep ==== */
+
+ slaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &wr[ks],
+ &wi[ks], &h__[h_offset], ldh, iloz, ihiz, &z__[
+ z_offset], ldz, &work[1], &c__3, &h__[ku + h_dim1],
+ ldh, &nve, &h__[kwv + h_dim1], ldh, &nho, &h__[ku +
+ kwh * h_dim1], ldh);
+ }
+
+/* ==== Note progress (or the lack of it). ==== */
+
+ if (ld > 0) {
+ ndfl = 1;
+ } else {
+ ++ndfl;
+ }
+
+/* ==== End of main loop ==== */
+/* L80: */
+ }
+
+/* ==== Iteration limit exceeded. Set INFO to show where */
+/* . the problem occurred and exit. ==== */
+
+ *info = kbot;
+L90:
+ ;
+ }
+
+/* ==== Return the optimal value of LWORK. ==== */
+
+ work[1] = (real) lwkopt;
+
+/* ==== End of SLAQR0 ==== */
+
+ return 0;
+} /* slaqr0_ */
diff --git a/SRC/slaqr1.c b/SRC/slaqr1.c
new file mode 100644
index 0000000..4726190
--- /dev/null
+++ b/SRC/slaqr1.c
@@ -0,0 +1,126 @@
+/* slaqr1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slaqr1_(integer *n, real *h__, integer *ldh, real *sr1,
+ real *si1, real *sr2, real *si2, real *v)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ real s, h21s, h31s;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Given a 2-by-2 or 3-by-3 matrix H, SLAQR1 sets v to a */
+/* scalar multiple of the first column of the product */
+
+/* (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I) */
+
+/* scaling to avoid overflows and most underflows. It */
+/* is assumed that either */
+
+/* 1) sr1 = sr2 and si1 = -si2 */
+/* or */
+/* 2) si1 = si2 = 0. */
+
+/* This is useful for starting double implicit shift bulges */
+/* in the QR algorithm. */
+
+
+/* N (input) integer */
+/* Order of the matrix H. N must be either 2 or 3. */
+
+/* H (input) REAL array of dimension (LDH,N) */
+/* The 2-by-2 or 3-by-3 matrix H in (*). */
+
+/* LDH (input) integer */
+/* The leading dimension of H as declared in */
+/* the calling procedure. LDH.GE.N */
+
+/* SR1 (input) REAL */
+/* SI1 The shifts in (*). */
+/* SR2 */
+/* SI2 */
+
+/* V (output) REAL array of dimension N */
+/* A scalar multiple of the first column of the */
+/* matrix K in (*). */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --v;
+
+ /* Function Body */
+ if (*n == 2) {
+ s = (r__1 = h__[h_dim1 + 1] - *sr2, dabs(r__1)) + dabs(*si2) + (r__2 =
+ h__[h_dim1 + 2], dabs(r__2));
+ if (s == 0.f) {
+ v[1] = 0.f;
+ v[2] = 0.f;
+ } else {
+ h21s = h__[h_dim1 + 2] / s;
+ v[1] = h21s * h__[(h_dim1 << 1) + 1] + (h__[h_dim1 + 1] - *sr1) *
+ ((h__[h_dim1 + 1] - *sr2) / s) - *si1 * (*si2 / s);
+ v[2] = h21s * (h__[h_dim1 + 1] + h__[(h_dim1 << 1) + 2] - *sr1 - *
+ sr2);
+ }
+ } else {
+ s = (r__1 = h__[h_dim1 + 1] - *sr2, dabs(r__1)) + dabs(*si2) + (r__2 =
+ h__[h_dim1 + 2], dabs(r__2)) + (r__3 = h__[h_dim1 + 3], dabs(
+ r__3));
+ if (s == 0.f) {
+ v[1] = 0.f;
+ v[2] = 0.f;
+ v[3] = 0.f;
+ } else {
+ h21s = h__[h_dim1 + 2] / s;
+ h31s = h__[h_dim1 + 3] / s;
+ v[1] = (h__[h_dim1 + 1] - *sr1) * ((h__[h_dim1 + 1] - *sr2) / s)
+ - *si1 * (*si2 / s) + h__[(h_dim1 << 1) + 1] * h21s + h__[
+ h_dim1 * 3 + 1] * h31s;
+ v[2] = h21s * (h__[h_dim1 + 1] + h__[(h_dim1 << 1) + 2] - *sr1 - *
+ sr2) + h__[h_dim1 * 3 + 2] * h31s;
+ v[3] = h31s * (h__[h_dim1 + 1] + h__[h_dim1 * 3 + 3] - *sr1 - *
+ sr2) + h21s * h__[(h_dim1 << 1) + 3];
+ }
+ }
+ return 0;
+} /* slaqr1_ */
diff --git a/SRC/slaqr2.c b/SRC/slaqr2.c
new file mode 100644
index 0000000..977d453
--- /dev/null
+++ b/SRC/slaqr2.c
@@ -0,0 +1,694 @@
+/* slaqr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b12 = 0.f;
+static real c_b13 = 1.f;
+static logical c_true = TRUE_;
+
+/* Subroutine */ int slaqr2_(logical *wantt, logical *wantz, integer *n,
+ integer *ktop, integer *kbot, integer *nw, real *h__, integer *ldh,
+ integer *iloz, integer *ihiz, real *z__, integer *ldz, integer *ns,
+ integer *nd, real *sr, real *si, real *v, integer *ldv, integer *nh,
+ real *t, integer *ldt, integer *nv, real *wv, integer *ldwv, real *
+ work, integer *lwork)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1,
+ wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4, r__5, r__6;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ real s, aa, bb, cc, dd, cs, sn;
+ integer jw;
+ real evi, evk, foo;
+ integer kln;
+ real tau, ulp;
+ integer lwk1, lwk2;
+ real beta;
+ integer kend, kcol, info, ifst, ilst, ltop, krow;
+ logical bulge;
+ extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *), sgemm_(
+ char *, char *, integer *, integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, real *, integer *);
+ integer infqr;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ integer kwtop;
+ extern /* Subroutine */ int slanv2_(real *, real *, real *, real *, real *
+, real *, real *, real *, real *, real *), slabad_(real *, real *)
+ ;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *);
+ real safmin;
+ extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
+ real *);
+ real safmax;
+ extern /* Subroutine */ int slahqr_(logical *, logical *, integer *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, integer *, real *, integer *, integer *), slacpy_(char *,
+ integer *, integer *, real *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *,
+ real *, integer *);
+ logical sorted;
+ extern /* Subroutine */ int strexc_(char *, integer *, real *, integer *,
+ real *, integer *, integer *, integer *, real *, integer *), sormhr_(char *, char *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+ real smlnum;
+ integer lwkopt;
+
+
+/* -- LAPACK auxiliary routine (version 3.2.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* -- April 2009 -- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* This subroutine is identical to SLAQR3 except that it avoids */
+/* recursion by calling SLAHQR instead of SLAQR4. */
+
+
+/* ****************************************************************** */
+/* Aggressive early deflation: */
+
+/* This subroutine accepts as input an upper Hessenberg matrix */
+/* H and performs an orthogonal similarity transformation */
+/* designed to detect and deflate fully converged eigenvalues from */
+/* a trailing principal submatrix. On output H has been over- */
+/* written by a new Hessenberg matrix that is a perturbation of */
+/* an orthogonal similarity transformation of H. It is to be */
+/* hoped that the final version of H has many zero subdiagonal */
+/* entries. */
+
+/* ****************************************************************** */
+/* WANTT (input) LOGICAL */
+/* If .TRUE., then the Hessenberg matrix H is fully updated */
+/* so that the quasi-triangular Schur factor may be */
+/* computed (in cooperation with the calling subroutine). */
+/* If .FALSE., then only enough of H is updated to preserve */
+/* the eigenvalues. */
+
+/* WANTZ (input) LOGICAL */
+/* If .TRUE., then the orthogonal matrix Z is updated so */
+/* so that the orthogonal Schur factor may be computed */
+/* (in cooperation with the calling subroutine). */
+/* If .FALSE., then Z is not referenced. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H and (if WANTZ is .TRUE.) the */
+/* order of the orthogonal matrix Z. */
+
+/* KTOP (input) INTEGER */
+/* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */
+/* KBOT and KTOP together determine an isolated block */
+/* along the diagonal of the Hessenberg matrix. */
+
+/* KBOT (input) INTEGER */
+/* It is assumed without a check that either */
+/* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */
+/* determine an isolated block along the diagonal of the */
+/* Hessenberg matrix. */
+
+/* NW (input) INTEGER */
+/* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). */
+
+/* H (input/output) REAL array, dimension (LDH,N) */
+/* On input the initial N-by-N section of H stores the */
+/* Hessenberg matrix undergoing aggressive early deflation. */
+/* On output H has been transformed by an orthogonal */
+/* similarity transformation, perturbed, and the returned */
+/* to Hessenberg form that (it is to be hoped) has some */
+/* zero subdiagonal entries. */
+
+/* LDH (input) integer */
+/* Leading dimension of H just as declared in the calling */
+/* subroutine. N .LE. LDH */
+
+/* ILOZ (input) INTEGER */
+/* IHIZ (input) INTEGER */
+/* Specify the rows of Z to which transformations must be */
+/* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. */
+
+/* Z (input/output) REAL array, dimension (LDZ,N) */
+/* IF WANTZ is .TRUE., then on output, the orthogonal */
+/* similarity transformation mentioned above has been */
+/* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. */
+/* If WANTZ is .FALSE., then Z is unreferenced. */
+
+/* LDZ (input) integer */
+/* The leading dimension of Z just as declared in the */
+/* calling subroutine. 1 .LE. LDZ. */
+
+/* NS (output) integer */
+/* The number of unconverged (ie approximate) eigenvalues */
+/* returned in SR and SI that may be used as shifts by the */
+/* calling subroutine. */
+
+/* ND (output) integer */
+/* The number of converged eigenvalues uncovered by this */
+/* subroutine. */
+
+/* SR (output) REAL array, dimension KBOT */
+/* SI (output) REAL array, dimension KBOT */
+/* On output, the real and imaginary parts of approximate */
+/* eigenvalues that may be used for shifts are stored in */
+/* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and */
+/* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. */
+/* The real and imaginary parts of converged eigenvalues */
+/* are stored in SR(KBOT-ND+1) through SR(KBOT) and */
+/* SI(KBOT-ND+1) through SI(KBOT), respectively. */
+
+/* V (workspace) REAL array, dimension (LDV,NW) */
+/* An NW-by-NW work array. */
+
+/* LDV (input) integer scalar */
+/* The leading dimension of V just as declared in the */
+/* calling subroutine. NW .LE. LDV */
+
+/* NH (input) integer scalar */
+/* The number of columns of T. NH.GE.NW. */
+
+/* T (workspace) REAL array, dimension (LDT,NW) */
+
+/* LDT (input) integer */
+/* The leading dimension of T just as declared in the */
+/* calling subroutine. NW .LE. LDT */
+
+/* NV (input) integer */
+/* The number of rows of work array WV available for */
+/* workspace. NV.GE.NW. */
+
+/* WV (workspace) REAL array, dimension (LDWV,NW) */
+
+/* LDWV (input) integer */
+/* The leading dimension of W just as declared in the */
+/* calling subroutine. NW .LE. LDV */
+
+/* WORK (workspace) REAL array, dimension LWORK. */
+/* On exit, WORK(1) is set to an estimate of the optimal value */
+/* of LWORK for the given values of N, NW, KTOP and KBOT. */
+
+/* LWORK (input) integer */
+/* The dimension of the work array WORK. LWORK = 2*NW */
+/* suffices, but greater efficiency may result from larger */
+/* values of LWORK. */
+
+/* If LWORK = -1, then a workspace query is assumed; SLAQR2 */
+/* only estimates the optimal workspace size for the given */
+/* values of N, NW, KTOP and KBOT. The estimate is returned */
+/* in WORK(1). No error message related to LWORK is issued */
+/* by XERBLA. Neither H nor Z are accessed. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* ==== Estimate optimal workspace. ==== */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --sr;
+ --si;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ wv_dim1 = *ldwv;
+ wv_offset = 1 + wv_dim1;
+ wv -= wv_offset;
+ --work;
+
+ /* Function Body */
+/* Computing MIN */
+ i__1 = *nw, i__2 = *kbot - *ktop + 1;
+ jw = min(i__1,i__2);
+ if (jw <= 2) {
+ lwkopt = 1;
+ } else {
+
+/* ==== Workspace query call to SGEHRD ==== */
+
+ i__1 = jw - 1;
+ sgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], &
+ c_n1, &info);
+ lwk1 = (integer) work[1];
+
+/* ==== Workspace query call to SORMHR ==== */
+
+ i__1 = jw - 1;
+ sormhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1],
+ &v[v_offset], ldv, &work[1], &c_n1, &info);
+ lwk2 = (integer) work[1];
+
+/* ==== Optimal workspace ==== */
+
+ lwkopt = jw + max(lwk1,lwk2);
+ }
+
+/* ==== Quick return in case of workspace query. ==== */
+
+ if (*lwork == -1) {
+ work[1] = (real) lwkopt;
+ return 0;
+ }
+
+/* ==== Nothing to do ... */
+/* ... for an empty active block ... ==== */
+ *ns = 0;
+ *nd = 0;
+ work[1] = 1.f;
+ if (*ktop > *kbot) {
+ return 0;
+ }
+/* ... nor for an empty deflation window. ==== */
+ if (*nw < 1) {
+ return 0;
+ }
+
+/* ==== Machine constants ==== */
+
+ safmin = slamch_("SAFE MINIMUM");
+ safmax = 1.f / safmin;
+ slabad_(&safmin, &safmax);
+ ulp = slamch_("PRECISION");
+ smlnum = safmin * ((real) (*n) / ulp);
+
+/* ==== Setup deflation window ==== */
+
+/* Computing MIN */
+ i__1 = *nw, i__2 = *kbot - *ktop + 1;
+ jw = min(i__1,i__2);
+ kwtop = *kbot - jw + 1;
+ if (kwtop == *ktop) {
+ s = 0.f;
+ } else {
+ s = h__[kwtop + (kwtop - 1) * h_dim1];
+ }
+
+ if (*kbot == kwtop) {
+
+/* ==== 1-by-1 deflation window: not much to do ==== */
+
+ sr[kwtop] = h__[kwtop + kwtop * h_dim1];
+ si[kwtop] = 0.f;
+ *ns = 1;
+ *nd = 0;
+/* Computing MAX */
+ r__2 = smlnum, r__3 = ulp * (r__1 = h__[kwtop + kwtop * h_dim1], dabs(
+ r__1));
+ if (dabs(s) <= dmax(r__2,r__3)) {
+ *ns = 0;
+ *nd = 1;
+ if (kwtop > *ktop) {
+ h__[kwtop + (kwtop - 1) * h_dim1] = 0.f;
+ }
+ }
+ work[1] = 1.f;
+ return 0;
+ }
+
+/* ==== Convert to spike-triangular form. (In case of a */
+/* . rare QR failure, this routine continues to do */
+/* . aggressive early deflation using that part of */
+/* . the deflation window that converged using INFQR */
+/* . here and there to keep track.) ==== */
+
+ slacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset],
+ ldt);
+ i__1 = jw - 1;
+ i__2 = *ldh + 1;
+ i__3 = *ldt + 1;
+ scopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], &
+ i__3);
+
+ slaset_("A", &jw, &jw, &c_b12, &c_b13, &v[v_offset], ldv);
+ slahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[kwtop],
+ &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr);
+
+/* ==== STREXC needs a clean margin near the diagonal ==== */
+
+ i__1 = jw - 3;
+ for (j = 1; j <= i__1; ++j) {
+ t[j + 2 + j * t_dim1] = 0.f;
+ t[j + 3 + j * t_dim1] = 0.f;
+/* L10: */
+ }
+ if (jw > 2) {
+ t[jw + (jw - 2) * t_dim1] = 0.f;
+ }
+
+/* ==== Deflation detection loop ==== */
+
+ *ns = jw;
+ ilst = infqr + 1;
+L20:
+ if (ilst <= *ns) {
+ if (*ns == 1) {
+ bulge = FALSE_;
+ } else {
+ bulge = t[*ns + (*ns - 1) * t_dim1] != 0.f;
+ }
+
+/* ==== Small spike tip test for deflation ==== */
+
+ if (! bulge) {
+
+/* ==== Real eigenvalue ==== */
+
+ foo = (r__1 = t[*ns + *ns * t_dim1], dabs(r__1));
+ if (foo == 0.f) {
+ foo = dabs(s);
+ }
+/* Computing MAX */
+ r__2 = smlnum, r__3 = ulp * foo;
+ if ((r__1 = s * v[*ns * v_dim1 + 1], dabs(r__1)) <= dmax(r__2,
+ r__3)) {
+
+/* ==== Deflatable ==== */
+
+ --(*ns);
+ } else {
+
+/* ==== Undeflatable. Move it up out of the way. */
+/* . (STREXC can not fail in this case.) ==== */
+
+ ifst = *ns;
+ strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
+ &ilst, &work[1], &info);
+ ++ilst;
+ }
+ } else {
+
+/* ==== Complex conjugate pair ==== */
+
+ foo = (r__3 = t[*ns + *ns * t_dim1], dabs(r__3)) + sqrt((r__1 = t[
+ *ns + (*ns - 1) * t_dim1], dabs(r__1))) * sqrt((r__2 = t[*
+ ns - 1 + *ns * t_dim1], dabs(r__2)));
+ if (foo == 0.f) {
+ foo = dabs(s);
+ }
+/* Computing MAX */
+ r__3 = (r__1 = s * v[*ns * v_dim1 + 1], dabs(r__1)), r__4 = (r__2
+ = s * v[(*ns - 1) * v_dim1 + 1], dabs(r__2));
+/* Computing MAX */
+ r__5 = smlnum, r__6 = ulp * foo;
+ if (dmax(r__3,r__4) <= dmax(r__5,r__6)) {
+
+/* ==== Deflatable ==== */
+
+ *ns += -2;
+ } else {
+
+/* ==== Undeflatable. Move them up out of the way. */
+/* . Fortunately, STREXC does the right thing with */
+/* . ILST in case of a rare exchange failure. ==== */
+
+ ifst = *ns;
+ strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
+ &ilst, &work[1], &info);
+ ilst += 2;
+ }
+ }
+
+/* ==== End deflation detection loop ==== */
+
+ goto L20;
+ }
+
+/* ==== Return to Hessenberg form ==== */
+
+ if (*ns == 0) {
+ s = 0.f;
+ }
+
+ if (*ns < jw) {
+
+/* ==== sorting diagonal blocks of T improves accuracy for */
+/* . graded matrices. Bubble sort deals well with */
+/* . exchange failures. ==== */
+
+ sorted = FALSE_;
+ i__ = *ns + 1;
+L30:
+ if (sorted) {
+ goto L50;
+ }
+ sorted = TRUE_;
+
+ kend = i__ - 1;
+ i__ = infqr + 1;
+ if (i__ == *ns) {
+ k = i__ + 1;
+ } else if (t[i__ + 1 + i__ * t_dim1] == 0.f) {
+ k = i__ + 1;
+ } else {
+ k = i__ + 2;
+ }
+L40:
+ if (k <= kend) {
+ if (k == i__ + 1) {
+ evi = (r__1 = t[i__ + i__ * t_dim1], dabs(r__1));
+ } else {
+ evi = (r__3 = t[i__ + i__ * t_dim1], dabs(r__3)) + sqrt((r__1
+ = t[i__ + 1 + i__ * t_dim1], dabs(r__1))) * sqrt((
+ r__2 = t[i__ + (i__ + 1) * t_dim1], dabs(r__2)));
+ }
+
+ if (k == kend) {
+ evk = (r__1 = t[k + k * t_dim1], dabs(r__1));
+ } else if (t[k + 1 + k * t_dim1] == 0.f) {
+ evk = (r__1 = t[k + k * t_dim1], dabs(r__1));
+ } else {
+ evk = (r__3 = t[k + k * t_dim1], dabs(r__3)) + sqrt((r__1 = t[
+ k + 1 + k * t_dim1], dabs(r__1))) * sqrt((r__2 = t[k
+ + (k + 1) * t_dim1], dabs(r__2)));
+ }
+
+ if (evi >= evk) {
+ i__ = k;
+ } else {
+ sorted = FALSE_;
+ ifst = i__;
+ ilst = k;
+ strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
+ &ilst, &work[1], &info);
+ if (info == 0) {
+ i__ = ilst;
+ } else {
+ i__ = k;
+ }
+ }
+ if (i__ == kend) {
+ k = i__ + 1;
+ } else if (t[i__ + 1 + i__ * t_dim1] == 0.f) {
+ k = i__ + 1;
+ } else {
+ k = i__ + 2;
+ }
+ goto L40;
+ }
+ goto L30;
+L50:
+ ;
+ }
+
+/* ==== Restore shift/eigenvalue array from T ==== */
+
+ i__ = jw;
+L60:
+ if (i__ >= infqr + 1) {
+ if (i__ == infqr + 1) {
+ sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
+ si[kwtop + i__ - 1] = 0.f;
+ --i__;
+ } else if (t[i__ + (i__ - 1) * t_dim1] == 0.f) {
+ sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
+ si[kwtop + i__ - 1] = 0.f;
+ --i__;
+ } else {
+ aa = t[i__ - 1 + (i__ - 1) * t_dim1];
+ cc = t[i__ + (i__ - 1) * t_dim1];
+ bb = t[i__ - 1 + i__ * t_dim1];
+ dd = t[i__ + i__ * t_dim1];
+ slanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__
+ - 2], &sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, &
+ sn);
+ i__ += -2;
+ }
+ goto L60;
+ }
+
+ if (*ns < jw || s == 0.f) {
+ if (*ns > 1 && s != 0.f) {
+
+/* ==== Reflect spike back into lower triangle ==== */
+
+ scopy_(ns, &v[v_offset], ldv, &work[1], &c__1);
+ beta = work[1];
+ slarfg_(ns, &beta, &work[2], &c__1, &tau);
+ work[1] = 1.f;
+
+ i__1 = jw - 2;
+ i__2 = jw - 2;
+ slaset_("L", &i__1, &i__2, &c_b12, &c_b12, &t[t_dim1 + 3], ldt);
+
+ slarf_("L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, &
+ work[jw + 1]);
+ slarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, &
+ work[jw + 1]);
+ slarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, &
+ work[jw + 1]);
+
+ i__1 = *lwork - jw;
+ sgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1]
+, &i__1, &info);
+ }
+
+/* ==== Copy updated reduced window into place ==== */
+
+ if (kwtop > 1) {
+ h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1];
+ }
+ slacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1]
+, ldh);
+ i__1 = jw - 1;
+ i__2 = *ldt + 1;
+ i__3 = *ldh + 1;
+ scopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1],
+ &i__3);
+
+/* ==== Accumulate orthogonal matrix in order update */
+/* . H and Z, if requested. ==== */
+
+ if (*ns > 1 && s != 0.f) {
+ i__1 = *lwork - jw;
+ sormhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1],
+ &v[v_offset], ldv, &work[jw + 1], &i__1, &info);
+ }
+
+/* ==== Update vertical slab in H ==== */
+
+ if (*wantt) {
+ ltop = 1;
+ } else {
+ ltop = *ktop;
+ }
+ i__1 = kwtop - 1;
+ i__2 = *nv;
+ for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *nv, i__4 = kwtop - krow;
+ kln = min(i__3,i__4);
+ sgemm_("N", "N", &kln, &jw, &jw, &c_b13, &h__[krow + kwtop *
+ h_dim1], ldh, &v[v_offset], ldv, &c_b12, &wv[wv_offset],
+ ldwv);
+ slacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop *
+ h_dim1], ldh);
+/* L70: */
+ }
+
+/* ==== Update horizontal slab in H ==== */
+
+ if (*wantt) {
+ i__2 = *n;
+ i__1 = *nh;
+ for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2;
+ kcol += i__1) {
+/* Computing MIN */
+ i__3 = *nh, i__4 = *n - kcol + 1;
+ kln = min(i__3,i__4);
+ sgemm_("C", "N", &jw, &kln, &jw, &c_b13, &v[v_offset], ldv, &
+ h__[kwtop + kcol * h_dim1], ldh, &c_b12, &t[t_offset],
+ ldt);
+ slacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol *
+ h_dim1], ldh);
+/* L80: */
+ }
+ }
+
+/* ==== Update vertical slab in Z ==== */
+
+ if (*wantz) {
+ i__1 = *ihiz;
+ i__2 = *nv;
+ for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *nv, i__4 = *ihiz - krow + 1;
+ kln = min(i__3,i__4);
+ sgemm_("N", "N", &kln, &jw, &jw, &c_b13, &z__[krow + kwtop *
+ z_dim1], ldz, &v[v_offset], ldv, &c_b12, &wv[
+ wv_offset], ldwv);
+ slacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow +
+ kwtop * z_dim1], ldz);
+/* L90: */
+ }
+ }
+ }
+
+/* ==== Return the number of deflations ... ==== */
+
+ *nd = jw - *ns;
+
+/* ==== ... and the number of shifts. (Subtracting */
+/* . INFQR from the spike length takes care */
+/* . of the case of a rare QR failure while */
+/* . calculating eigenvalues of the deflation */
+/* . window.) ==== */
+
+ *ns -= infqr;
+
+/* ==== Return optimal workspace. ==== */
+
+ work[1] = (real) lwkopt;
+
+/* ==== End of SLAQR2 ==== */
+
+ return 0;
+} /* slaqr2_ */
diff --git a/SRC/slaqr3.c b/SRC/slaqr3.c
new file mode 100644
index 0000000..b3b828a
--- /dev/null
+++ b/SRC/slaqr3.c
@@ -0,0 +1,710 @@
+/* slaqr3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static logical c_true = TRUE_;
+static real c_b17 = 0.f;
+static real c_b18 = 1.f;
+static integer c__12 = 12;
+
+/* Subroutine */ int slaqr3_(logical *wantt, logical *wantz, integer *n,
+ integer *ktop, integer *kbot, integer *nw, real *h__, integer *ldh,
+ integer *iloz, integer *ihiz, real *z__, integer *ldz, integer *ns,
+ integer *nd, real *sr, real *si, real *v, integer *ldv, integer *nh,
+ real *t, integer *ldt, integer *nv, real *wv, integer *ldwv, real *
+ work, integer *lwork)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1,
+ wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4, r__5, r__6;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ real s, aa, bb, cc, dd, cs, sn;
+ integer jw;
+ real evi, evk, foo;
+ integer kln;
+ real tau, ulp;
+ integer lwk1, lwk2, lwk3;
+ real beta;
+ integer kend, kcol, info, nmin, ifst, ilst, ltop, krow;
+ logical bulge;
+ extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *), sgemm_(
+ char *, char *, integer *, integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, real *, integer *);
+ integer infqr;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ integer kwtop;
+ extern /* Subroutine */ int slanv2_(real *, real *, real *, real *, real *
+, real *, real *, real *, real *, real *), slaqr4_(logical *,
+ logical *, integer *, integer *, integer *, real *, integer *,
+ real *, real *, integer *, integer *, real *, integer *, real *,
+ integer *, integer *), slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *);
+ real safmin;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ real safmax;
+ extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
+ real *), slahqr_(logical *, logical *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, integer *
+, real *, integer *, integer *), slacpy_(char *, integer *,
+ integer *, real *, integer *, real *, integer *), slaset_(
+ char *, integer *, integer *, real *, real *, real *, integer *);
+ logical sorted;
+ extern /* Subroutine */ int strexc_(char *, integer *, real *, integer *,
+ real *, integer *, integer *, integer *, real *, integer *), sormhr_(char *, char *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+ real smlnum;
+ integer lwkopt;
+
+
+/* -- LAPACK auxiliary routine (version 3.2.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* -- April 2009 -- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* ****************************************************************** */
+/* Aggressive early deflation: */
+
+/* This subroutine accepts as input an upper Hessenberg matrix */
+/* H and performs an orthogonal similarity transformation */
+/* designed to detect and deflate fully converged eigenvalues from */
+/* a trailing principal submatrix. On output H has been over- */
+/* written by a new Hessenberg matrix that is a perturbation of */
+/* an orthogonal similarity transformation of H. It is to be */
+/* hoped that the final version of H has many zero subdiagonal */
+/* entries. */
+
+/* ****************************************************************** */
+/* WANTT (input) LOGICAL */
+/* If .TRUE., then the Hessenberg matrix H is fully updated */
+/* so that the quasi-triangular Schur factor may be */
+/* computed (in cooperation with the calling subroutine). */
+/* If .FALSE., then only enough of H is updated to preserve */
+/* the eigenvalues. */
+
+/* WANTZ (input) LOGICAL */
+/* If .TRUE., then the orthogonal matrix Z is updated so */
+/* so that the orthogonal Schur factor may be computed */
+/* (in cooperation with the calling subroutine). */
+/* If .FALSE., then Z is not referenced. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H and (if WANTZ is .TRUE.) the */
+/* order of the orthogonal matrix Z. */
+
+/* KTOP (input) INTEGER */
+/* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */
+/* KBOT and KTOP together determine an isolated block */
+/* along the diagonal of the Hessenberg matrix. */
+
+/* KBOT (input) INTEGER */
+/* It is assumed without a check that either */
+/* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */
+/* determine an isolated block along the diagonal of the */
+/* Hessenberg matrix. */
+
+/* NW (input) INTEGER */
+/* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). */
+
+/* H (input/output) REAL array, dimension (LDH,N) */
+/* On input the initial N-by-N section of H stores the */
+/* Hessenberg matrix undergoing aggressive early deflation. */
+/* On output H has been transformed by an orthogonal */
+/* similarity transformation, perturbed, and the returned */
+/* to Hessenberg form that (it is to be hoped) has some */
+/* zero subdiagonal entries. */
+
+/* LDH (input) integer */
+/* Leading dimension of H just as declared in the calling */
+/* subroutine. N .LE. LDH */
+
+/* ILOZ (input) INTEGER */
+/* IHIZ (input) INTEGER */
+/* Specify the rows of Z to which transformations must be */
+/* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. */
+
+/* Z (input/output) REAL array, dimension (LDZ,N) */
+/* IF WANTZ is .TRUE., then on output, the orthogonal */
+/* similarity transformation mentioned above has been */
+/* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. */
+/* If WANTZ is .FALSE., then Z is unreferenced. */
+
+/* LDZ (input) integer */
+/* The leading dimension of Z just as declared in the */
+/* calling subroutine. 1 .LE. LDZ. */
+
+/* NS (output) integer */
+/* The number of unconverged (ie approximate) eigenvalues */
+/* returned in SR and SI that may be used as shifts by the */
+/* calling subroutine. */
+
+/* ND (output) integer */
+/* The number of converged eigenvalues uncovered by this */
+/* subroutine. */
+
+/* SR (output) REAL array, dimension KBOT */
+/* SI (output) REAL array, dimension KBOT */
+/* On output, the real and imaginary parts of approximate */
+/* eigenvalues that may be used for shifts are stored in */
+/* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and */
+/* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. */
+/* The real and imaginary parts of converged eigenvalues */
+/* are stored in SR(KBOT-ND+1) through SR(KBOT) and */
+/* SI(KBOT-ND+1) through SI(KBOT), respectively. */
+
+/* V (workspace) REAL array, dimension (LDV,NW) */
+/* An NW-by-NW work array. */
+
+/* LDV (input) integer scalar */
+/* The leading dimension of V just as declared in the */
+/* calling subroutine. NW .LE. LDV */
+
+/* NH (input) integer scalar */
+/* The number of columns of T. NH.GE.NW. */
+
+/* T (workspace) REAL array, dimension (LDT,NW) */
+
+/* LDT (input) integer */
+/* The leading dimension of T just as declared in the */
+/* calling subroutine. NW .LE. LDT */
+
+/* NV (input) integer */
+/* The number of rows of work array WV available for */
+/* workspace. NV.GE.NW. */
+
+/* WV (workspace) REAL array, dimension (LDWV,NW) */
+
+/* LDWV (input) integer */
+/* The leading dimension of W just as declared in the */
+/* calling subroutine. NW .LE. LDV */
+
+/* WORK (workspace) REAL array, dimension LWORK. */
+/* On exit, WORK(1) is set to an estimate of the optimal value */
+/* of LWORK for the given values of N, NW, KTOP and KBOT. */
+
+/* LWORK (input) integer */
+/* The dimension of the work array WORK. LWORK = 2*NW */
+/* suffices, but greater efficiency may result from larger */
+/* values of LWORK. */
+
+/* If LWORK = -1, then a workspace query is assumed; SLAQR3 */
+/* only estimates the optimal workspace size for the given */
+/* values of N, NW, KTOP and KBOT. The estimate is returned */
+/* in WORK(1). No error message related to LWORK is issued */
+/* by XERBLA. Neither H nor Z are accessed. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* ==== Estimate optimal workspace. ==== */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --sr;
+ --si;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ wv_dim1 = *ldwv;
+ wv_offset = 1 + wv_dim1;
+ wv -= wv_offset;
+ --work;
+
+ /* Function Body */
+/* Computing MIN */
+ i__1 = *nw, i__2 = *kbot - *ktop + 1;
+ jw = min(i__1,i__2);
+ if (jw <= 2) {
+ lwkopt = 1;
+ } else {
+
+/* ==== Workspace query call to SGEHRD ==== */
+
+ i__1 = jw - 1;
+ sgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], &
+ c_n1, &info);
+ lwk1 = (integer) work[1];
+
+/* ==== Workspace query call to SORMHR ==== */
+
+ i__1 = jw - 1;
+ sormhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1],
+ &v[v_offset], ldv, &work[1], &c_n1, &info);
+ lwk2 = (integer) work[1];
+
+/* ==== Workspace query call to SLAQR4 ==== */
+
+ slaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[1],
+ &si[1], &c__1, &jw, &v[v_offset], ldv, &work[1], &c_n1, &
+ infqr);
+ lwk3 = (integer) work[1];
+
+/* ==== Optimal workspace ==== */
+
+/* Computing MAX */
+ i__1 = jw + max(lwk1,lwk2);
+ lwkopt = max(i__1,lwk3);
+ }
+
+/* ==== Quick return in case of workspace query. ==== */
+
+ if (*lwork == -1) {
+ work[1] = (real) lwkopt;
+ return 0;
+ }
+
+/* ==== Nothing to do ... */
+/* ... for an empty active block ... ==== */
+ *ns = 0;
+ *nd = 0;
+ work[1] = 1.f;
+ if (*ktop > *kbot) {
+ return 0;
+ }
+/* ... nor for an empty deflation window. ==== */
+ if (*nw < 1) {
+ return 0;
+ }
+
+/* ==== Machine constants ==== */
+
+ safmin = slamch_("SAFE MINIMUM");
+ safmax = 1.f / safmin;
+ slabad_(&safmin, &safmax);
+ ulp = slamch_("PRECISION");
+ smlnum = safmin * ((real) (*n) / ulp);
+
+/* ==== Setup deflation window ==== */
+
+/* Computing MIN */
+ i__1 = *nw, i__2 = *kbot - *ktop + 1;
+ jw = min(i__1,i__2);
+ kwtop = *kbot - jw + 1;
+ if (kwtop == *ktop) {
+ s = 0.f;
+ } else {
+ s = h__[kwtop + (kwtop - 1) * h_dim1];
+ }
+
+ if (*kbot == kwtop) {
+
+/* ==== 1-by-1 deflation window: not much to do ==== */
+
+ sr[kwtop] = h__[kwtop + kwtop * h_dim1];
+ si[kwtop] = 0.f;
+ *ns = 1;
+ *nd = 0;
+/* Computing MAX */
+ r__2 = smlnum, r__3 = ulp * (r__1 = h__[kwtop + kwtop * h_dim1], dabs(
+ r__1));
+ if (dabs(s) <= dmax(r__2,r__3)) {
+ *ns = 0;
+ *nd = 1;
+ if (kwtop > *ktop) {
+ h__[kwtop + (kwtop - 1) * h_dim1] = 0.f;
+ }
+ }
+ work[1] = 1.f;
+ return 0;
+ }
+
+/* ==== Convert to spike-triangular form. (In case of a */
+/* . rare QR failure, this routine continues to do */
+/* . aggressive early deflation using that part of */
+/* . the deflation window that converged using INFQR */
+/* . here and there to keep track.) ==== */
+
+ slacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset],
+ ldt);
+ i__1 = jw - 1;
+ i__2 = *ldh + 1;
+ i__3 = *ldt + 1;
+ scopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], &
+ i__3);
+
+ slaset_("A", &jw, &jw, &c_b17, &c_b18, &v[v_offset], ldv);
+ nmin = ilaenv_(&c__12, "SLAQR3", "SV", &jw, &c__1, &jw, lwork);
+ if (jw > nmin) {
+ slaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[
+ kwtop], &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &work[1],
+ lwork, &infqr);
+ } else {
+ slahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[
+ kwtop], &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr);
+ }
+
+/* ==== STREXC needs a clean margin near the diagonal ==== */
+
+ i__1 = jw - 3;
+ for (j = 1; j <= i__1; ++j) {
+ t[j + 2 + j * t_dim1] = 0.f;
+ t[j + 3 + j * t_dim1] = 0.f;
+/* L10: */
+ }
+ if (jw > 2) {
+ t[jw + (jw - 2) * t_dim1] = 0.f;
+ }
+
+/* ==== Deflation detection loop ==== */
+
+ *ns = jw;
+ ilst = infqr + 1;
+L20:
+ if (ilst <= *ns) {
+ if (*ns == 1) {
+ bulge = FALSE_;
+ } else {
+ bulge = t[*ns + (*ns - 1) * t_dim1] != 0.f;
+ }
+
+/* ==== Small spike tip test for deflation ==== */
+
+ if (! bulge) {
+
+/* ==== Real eigenvalue ==== */
+
+ foo = (r__1 = t[*ns + *ns * t_dim1], dabs(r__1));
+ if (foo == 0.f) {
+ foo = dabs(s);
+ }
+/* Computing MAX */
+ r__2 = smlnum, r__3 = ulp * foo;
+ if ((r__1 = s * v[*ns * v_dim1 + 1], dabs(r__1)) <= dmax(r__2,
+ r__3)) {
+
+/* ==== Deflatable ==== */
+
+ --(*ns);
+ } else {
+
+/* ==== Undeflatable. Move it up out of the way. */
+/* . (STREXC can not fail in this case.) ==== */
+
+ ifst = *ns;
+ strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
+ &ilst, &work[1], &info);
+ ++ilst;
+ }
+ } else {
+
+/* ==== Complex conjugate pair ==== */
+
+ foo = (r__3 = t[*ns + *ns * t_dim1], dabs(r__3)) + sqrt((r__1 = t[
+ *ns + (*ns - 1) * t_dim1], dabs(r__1))) * sqrt((r__2 = t[*
+ ns - 1 + *ns * t_dim1], dabs(r__2)));
+ if (foo == 0.f) {
+ foo = dabs(s);
+ }
+/* Computing MAX */
+ r__3 = (r__1 = s * v[*ns * v_dim1 + 1], dabs(r__1)), r__4 = (r__2
+ = s * v[(*ns - 1) * v_dim1 + 1], dabs(r__2));
+/* Computing MAX */
+ r__5 = smlnum, r__6 = ulp * foo;
+ if (dmax(r__3,r__4) <= dmax(r__5,r__6)) {
+
+/* ==== Deflatable ==== */
+
+ *ns += -2;
+ } else {
+
+/* ==== Undeflatable. Move them up out of the way. */
+/* . Fortunately, STREXC does the right thing with */
+/* . ILST in case of a rare exchange failure. ==== */
+
+ ifst = *ns;
+ strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
+ &ilst, &work[1], &info);
+ ilst += 2;
+ }
+ }
+
+/* ==== End deflation detection loop ==== */
+
+ goto L20;
+ }
+
+/* ==== Return to Hessenberg form ==== */
+
+ if (*ns == 0) {
+ s = 0.f;
+ }
+
+ if (*ns < jw) {
+
+/* ==== sorting diagonal blocks of T improves accuracy for */
+/* . graded matrices. Bubble sort deals well with */
+/* . exchange failures. ==== */
+
+ sorted = FALSE_;
+ i__ = *ns + 1;
+L30:
+ if (sorted) {
+ goto L50;
+ }
+ sorted = TRUE_;
+
+ kend = i__ - 1;
+ i__ = infqr + 1;
+ if (i__ == *ns) {
+ k = i__ + 1;
+ } else if (t[i__ + 1 + i__ * t_dim1] == 0.f) {
+ k = i__ + 1;
+ } else {
+ k = i__ + 2;
+ }
+L40:
+ if (k <= kend) {
+ if (k == i__ + 1) {
+ evi = (r__1 = t[i__ + i__ * t_dim1], dabs(r__1));
+ } else {
+ evi = (r__3 = t[i__ + i__ * t_dim1], dabs(r__3)) + sqrt((r__1
+ = t[i__ + 1 + i__ * t_dim1], dabs(r__1))) * sqrt((
+ r__2 = t[i__ + (i__ + 1) * t_dim1], dabs(r__2)));
+ }
+
+ if (k == kend) {
+ evk = (r__1 = t[k + k * t_dim1], dabs(r__1));
+ } else if (t[k + 1 + k * t_dim1] == 0.f) {
+ evk = (r__1 = t[k + k * t_dim1], dabs(r__1));
+ } else {
+ evk = (r__3 = t[k + k * t_dim1], dabs(r__3)) + sqrt((r__1 = t[
+ k + 1 + k * t_dim1], dabs(r__1))) * sqrt((r__2 = t[k
+ + (k + 1) * t_dim1], dabs(r__2)));
+ }
+
+ if (evi >= evk) {
+ i__ = k;
+ } else {
+ sorted = FALSE_;
+ ifst = i__;
+ ilst = k;
+ strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
+ &ilst, &work[1], &info);
+ if (info == 0) {
+ i__ = ilst;
+ } else {
+ i__ = k;
+ }
+ }
+ if (i__ == kend) {
+ k = i__ + 1;
+ } else if (t[i__ + 1 + i__ * t_dim1] == 0.f) {
+ k = i__ + 1;
+ } else {
+ k = i__ + 2;
+ }
+ goto L40;
+ }
+ goto L30;
+L50:
+ ;
+ }
+
+/* ==== Restore shift/eigenvalue array from T ==== */
+
+ i__ = jw;
+L60:
+ if (i__ >= infqr + 1) {
+ if (i__ == infqr + 1) {
+ sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
+ si[kwtop + i__ - 1] = 0.f;
+ --i__;
+ } else if (t[i__ + (i__ - 1) * t_dim1] == 0.f) {
+ sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1];
+ si[kwtop + i__ - 1] = 0.f;
+ --i__;
+ } else {
+ aa = t[i__ - 1 + (i__ - 1) * t_dim1];
+ cc = t[i__ + (i__ - 1) * t_dim1];
+ bb = t[i__ - 1 + i__ * t_dim1];
+ dd = t[i__ + i__ * t_dim1];
+ slanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__
+ - 2], &sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, &
+ sn);
+ i__ += -2;
+ }
+ goto L60;
+ }
+
+ if (*ns < jw || s == 0.f) {
+ if (*ns > 1 && s != 0.f) {
+
+/* ==== Reflect spike back into lower triangle ==== */
+
+ scopy_(ns, &v[v_offset], ldv, &work[1], &c__1);
+ beta = work[1];
+ slarfg_(ns, &beta, &work[2], &c__1, &tau);
+ work[1] = 1.f;
+
+ i__1 = jw - 2;
+ i__2 = jw - 2;
+ slaset_("L", &i__1, &i__2, &c_b17, &c_b17, &t[t_dim1 + 3], ldt);
+
+ slarf_("L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, &
+ work[jw + 1]);
+ slarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, &
+ work[jw + 1]);
+ slarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, &
+ work[jw + 1]);
+
+ i__1 = *lwork - jw;
+ sgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1]
+, &i__1, &info);
+ }
+
+/* ==== Copy updated reduced window into place ==== */
+
+ if (kwtop > 1) {
+ h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1];
+ }
+ slacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1]
+, ldh);
+ i__1 = jw - 1;
+ i__2 = *ldt + 1;
+ i__3 = *ldh + 1;
+ scopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1],
+ &i__3);
+
+/* ==== Accumulate orthogonal matrix in order update */
+/* . H and Z, if requested. ==== */
+
+ if (*ns > 1 && s != 0.f) {
+ i__1 = *lwork - jw;
+ sormhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1],
+ &v[v_offset], ldv, &work[jw + 1], &i__1, &info);
+ }
+
+/* ==== Update vertical slab in H ==== */
+
+ if (*wantt) {
+ ltop = 1;
+ } else {
+ ltop = *ktop;
+ }
+ i__1 = kwtop - 1;
+ i__2 = *nv;
+ for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *nv, i__4 = kwtop - krow;
+ kln = min(i__3,i__4);
+ sgemm_("N", "N", &kln, &jw, &jw, &c_b18, &h__[krow + kwtop *
+ h_dim1], ldh, &v[v_offset], ldv, &c_b17, &wv[wv_offset],
+ ldwv);
+ slacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop *
+ h_dim1], ldh);
+/* L70: */
+ }
+
+/* ==== Update horizontal slab in H ==== */
+
+ if (*wantt) {
+ i__2 = *n;
+ i__1 = *nh;
+ for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2;
+ kcol += i__1) {
+/* Computing MIN */
+ i__3 = *nh, i__4 = *n - kcol + 1;
+ kln = min(i__3,i__4);
+ sgemm_("C", "N", &jw, &kln, &jw, &c_b18, &v[v_offset], ldv, &
+ h__[kwtop + kcol * h_dim1], ldh, &c_b17, &t[t_offset],
+ ldt);
+ slacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol *
+ h_dim1], ldh);
+/* L80: */
+ }
+ }
+
+/* ==== Update vertical slab in Z ==== */
+
+ if (*wantz) {
+ i__1 = *ihiz;
+ i__2 = *nv;
+ for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *nv, i__4 = *ihiz - krow + 1;
+ kln = min(i__3,i__4);
+ sgemm_("N", "N", &kln, &jw, &jw, &c_b18, &z__[krow + kwtop *
+ z_dim1], ldz, &v[v_offset], ldv, &c_b17, &wv[
+ wv_offset], ldwv);
+ slacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow +
+ kwtop * z_dim1], ldz);
+/* L90: */
+ }
+ }
+ }
+
+/* ==== Return the number of deflations ... ==== */
+
+ *nd = jw - *ns;
+
+/* ==== ... and the number of shifts. (Subtracting */
+/* . INFQR from the spike length takes care */
+/* . of the case of a rare QR failure while */
+/* . calculating eigenvalues of the deflation */
+/* . window.) ==== */
+
+ *ns -= infqr;
+
+/* ==== Return optimal workspace. ==== */
+
+ work[1] = (real) lwkopt;
+
+/* ==== End of SLAQR3 ==== */
+
+ return 0;
+} /* slaqr3_ */
diff --git a/SRC/slaqr4.c b/SRC/slaqr4.c
new file mode 100644
index 0000000..4afb4b1
--- /dev/null
+++ b/SRC/slaqr4.c
@@ -0,0 +1,751 @@
+/* slaqr4.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__13 = 13;
+static integer c__15 = 15;
+static integer c_n1 = -1;
+static integer c__12 = 12;
+static integer c__14 = 14;
+static integer c__16 = 16;
+static logical c_false = FALSE_;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int slaqr4_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, real *h__, integer *ldh, real *wr, real *
+ wi, integer *iloz, integer *ihiz, real *z__, integer *ldz, real *work,
+ integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+
+ /* Local variables */
+ integer i__, k;
+ real aa, bb, cc, dd;
+ integer ld;
+ real cs;
+ integer nh, it, ks, kt;
+ real sn;
+ integer ku, kv, ls, ns;
+ real ss;
+ integer nw, inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot,
+ nmin;
+ real swap;
+ integer ktop;
+ real zdum[1] /* was [1][1] */;
+ integer kacc22, itmax, nsmax, nwmax, kwtop;
+ extern /* Subroutine */ int slaqr2_(logical *, logical *, integer *,
+ integer *, integer *, integer *, real *, integer *, integer *,
+ integer *, real *, integer *, integer *, integer *, real *, real *
+, real *, integer *, integer *, real *, integer *, integer *,
+ real *, integer *, real *, integer *), slanv2_(real *, real *,
+ real *, real *, real *, real *, real *, real *, real *, real *),
+ slaqr5_(logical *, logical *, integer *, integer *, integer *,
+ integer *, integer *, real *, real *, real *, integer *, integer *
+, integer *, real *, integer *, real *, integer *, real *,
+ integer *, integer *, real *, integer *, integer *, real *,
+ integer *);
+ integer nibble;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ char jbcmpz[2];
+ extern /* Subroutine */ int slahqr_(logical *, logical *, integer *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, integer *, real *, integer *, integer *), slacpy_(char *,
+ integer *, integer *, real *, integer *, real *, integer *);
+ integer nwupbd;
+ logical sorted;
+ integer lwkopt;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* This subroutine implements one level of recursion for SLAQR0. */
+/* It is a complete implementation of the small bulge multi-shift */
+/* QR algorithm. It may be called by SLAQR0 and, for large enough */
+/* deflation window size, it may be called by SLAQR3. This */
+/* subroutine is identical to SLAQR0 except that it calls SLAQR2 */
+/* instead of SLAQR3. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAQR4 computes the eigenvalues of a Hessenberg matrix H */
+/* and, optionally, the matrices T and Z from the Schur decomposition */
+/* H = Z T Z**T, where T is an upper quasi-triangular matrix (the */
+/* Schur form), and Z is the orthogonal matrix of Schur vectors. */
+
+/* Optionally Z may be postmultiplied into an input orthogonal */
+/* matrix Q so that this routine can give the Schur factorization */
+/* of a matrix A which has been reduced to the Hessenberg form H */
+/* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */
+
+/* Arguments */
+/* ========= */
+
+/* WANTT (input) LOGICAL */
+/* = .TRUE. : the full Schur form T is required; */
+/* = .FALSE.: only eigenvalues are required. */
+
+/* WANTZ (input) LOGICAL */
+/* = .TRUE. : the matrix of Schur vectors Z is required; */
+/* = .FALSE.: Schur vectors are not required. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N .GE. 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that H is already upper triangular in rows */
+/* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, */
+/* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a */
+/* previous call to SGEBAL, and then passed to SGEHRD when the */
+/* matrix output by SGEBAL is reduced to Hessenberg form. */
+/* Otherwise, ILO and IHI should be set to 1 and N, */
+/* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */
+/* If N = 0, then ILO = 1 and IHI = 0. */
+
+/* H (input/output) REAL array, dimension (LDH,N) */
+/* On entry, the upper Hessenberg matrix H. */
+/* On exit, if INFO = 0 and WANTT is .TRUE., then H contains */
+/* the upper quasi-triangular matrix T from the Schur */
+/* decomposition (the Schur form); 2-by-2 diagonal blocks */
+/* (corresponding to complex conjugate pairs of eigenvalues) */
+/* are returned in standard form, with H(i,i) = H(i+1,i+1) */
+/* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is */
+/* .FALSE., then the contents of H are unspecified on exit. */
+/* (The output value of H when INFO.GT.0 is given under the */
+/* description of INFO below.) */
+
+/* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and */
+/* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH .GE. max(1,N). */
+
+/* WR (output) REAL array, dimension (IHI) */
+/* WI (output) REAL array, dimension (IHI) */
+/* The real and imaginary parts, respectively, of the computed */
+/* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) */
+/* and WI(ILO:IHI). If two eigenvalues are computed as a */
+/* complex conjugate pair, they are stored in consecutive */
+/* elements of WR and WI, say the i-th and (i+1)th, with */
+/* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then */
+/* the eigenvalues are stored in the same order as on the */
+/* diagonal of the Schur form returned in H, with */
+/* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal */
+/* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and */
+/* WI(i+1) = -WI(i). */
+
+/* ILOZ (input) INTEGER */
+/* IHIZ (input) INTEGER */
+/* Specify the rows of Z to which transformations must be */
+/* applied if WANTZ is .TRUE.. */
+/* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N. */
+
+/* Z (input/output) REAL array, dimension (LDZ,IHI) */
+/* If WANTZ is .FALSE., then Z is not referenced. */
+/* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is */
+/* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the */
+/* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). */
+/* (The output value of Z when INFO.GT.0 is given under */
+/* the description of INFO below.) */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. if WANTZ is .TRUE. */
+/* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. */
+
+/* WORK (workspace/output) REAL array, dimension LWORK */
+/* On exit, if LWORK = -1, WORK(1) returns an estimate of */
+/* the optimal value for LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK .GE. max(1,N) */
+/* is sufficient, but LWORK typically as large as 6*N may */
+/* be required for optimal performance. A workspace query */
+/* to determine the optimal workspace size is recommended. */
+
+/* If LWORK = -1, then SLAQR4 does a workspace query. */
+/* In this case, SLAQR4 checks the input parameters and */
+/* estimates the optimal workspace size for the given */
+/* values of N, ILO and IHI. The estimate is returned */
+/* in WORK(1). No error message related to LWORK is */
+/* issued by XERBLA. Neither H nor Z are accessed. */
+
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* .GT. 0: if INFO = i, SLAQR4 failed to compute all of */
+/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */
+/* and WI contain those eigenvalues which have been */
+/* successfully computed. (Failures are rare.) */
+
+/* If INFO .GT. 0 and WANT is .FALSE., then on exit, */
+/* the remaining unconverged eigenvalues are the eigen- */
+/* values of the upper Hessenberg matrix rows and */
+/* columns ILO through INFO of the final, output */
+/* value of H. */
+
+/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */
+
+/* (*) (initial value of H)*U = U*(final value of H) */
+
+/* where U is an orthogonal matrix. The final */
+/* value of H is upper Hessenberg and quasi-triangular */
+/* in rows and columns INFO+1 through IHI. */
+
+/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
+
+/* (final value of Z(ILO:IHI,ILOZ:IHIZ) */
+/* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U */
+
+/* where U is the orthogonal matrix in (*) (regard- */
+/* less of the value of WANTT.) */
+
+/* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not */
+/* accessed. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* References: */
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */
+/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */
+/* 929--947, 2002. */
+
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */
+/* of Matrix Analysis, volume 23, pages 948--973, 2002. */
+
+/* ================================================================ */
+/* .. Parameters .. */
+
+/* ==== Matrices of order NTINY or smaller must be processed by */
+/* . SLAHQR because of insufficient subdiagonal scratch space. */
+/* . (This is a hard limit.) ==== */
+
+/* ==== Exceptional deflation windows: try to cure rare */
+/* . slow convergence by varying the size of the */
+/* . deflation window after KEXNW iterations. ==== */
+
+/* ==== Exceptional shifts: try to cure rare slow convergence */
+/* . with ad-hoc exceptional shifts every KEXSH iterations. */
+/* . ==== */
+
+/* ==== The constants WILK1 and WILK2 are used to form the */
+/* . exceptional shifts. ==== */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --wr;
+ --wi;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* ==== Quick return for N = 0: nothing to do. ==== */
+
+ if (*n == 0) {
+ work[1] = 1.f;
+ return 0;
+ }
+
+ if (*n <= 11) {
+
+/* ==== Tiny matrices must use SLAHQR. ==== */
+
+ lwkopt = 1;
+ if (*lwork != -1) {
+ slahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], &
+ wi[1], iloz, ihiz, &z__[z_offset], ldz, info);
+ }
+ } else {
+
+/* ==== Use small bulge multi-shift QR with aggressive early */
+/* . deflation on larger-than-tiny matrices. ==== */
+
+/* ==== Hope for the best. ==== */
+
+ *info = 0;
+
+/* ==== Set up job flags for ILAENV. ==== */
+
+ if (*wantt) {
+ *(unsigned char *)jbcmpz = 'S';
+ } else {
+ *(unsigned char *)jbcmpz = 'E';
+ }
+ if (*wantz) {
+ *(unsigned char *)&jbcmpz[1] = 'V';
+ } else {
+ *(unsigned char *)&jbcmpz[1] = 'N';
+ }
+
+/* ==== NWR = recommended deflation window size. At this */
+/* . point, N .GT. NTINY = 11, so there is enough */
+/* . subdiagonal workspace for NWR.GE.2 as required. */
+/* . (In fact, there is enough subdiagonal space for */
+/* . NWR.GE.3.) ==== */
+
+ nwr = ilaenv_(&c__13, "SLAQR4", jbcmpz, n, ilo, ihi, lwork);
+ nwr = max(2,nwr);
+/* Computing MIN */
+ i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = min(i__1,i__2);
+ nwr = min(i__1,nwr);
+
+/* ==== NSR = recommended number of simultaneous shifts. */
+/* . At this point N .GT. NTINY = 11, so there is at */
+/* . enough subdiagonal workspace for NSR to be even */
+/* . and greater than or equal to two as required. ==== */
+
+ nsr = ilaenv_(&c__15, "SLAQR4", jbcmpz, n, ilo, ihi, lwork);
+/* Computing MIN */
+ i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = min(i__1,i__2), i__2 = *ihi -
+ *ilo;
+ nsr = min(i__1,i__2);
+/* Computing MAX */
+ i__1 = 2, i__2 = nsr - nsr % 2;
+ nsr = max(i__1,i__2);
+
+/* ==== Estimate optimal workspace ==== */
+
+/* ==== Workspace query call to SLAQR2 ==== */
+
+ i__1 = nwr + 1;
+ slaqr2_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz,
+ ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[
+ h_offset], ldh, n, &h__[h_offset], ldh, n, &h__[h_offset],
+ ldh, &work[1], &c_n1);
+
+/* ==== Optimal workspace = MAX(SLAQR5, SLAQR2) ==== */
+
+/* Computing MAX */
+ i__1 = nsr * 3 / 2, i__2 = (integer) work[1];
+ lwkopt = max(i__1,i__2);
+
+/* ==== Quick return in case of workspace query. ==== */
+
+ if (*lwork == -1) {
+ work[1] = (real) lwkopt;
+ return 0;
+ }
+
+/* ==== SLAHQR/SLAQR0 crossover point ==== */
+
+ nmin = ilaenv_(&c__12, "SLAQR4", jbcmpz, n, ilo, ihi, lwork);
+ nmin = max(11,nmin);
+
+/* ==== Nibble crossover point ==== */
+
+ nibble = ilaenv_(&c__14, "SLAQR4", jbcmpz, n, ilo, ihi, lwork);
+ nibble = max(0,nibble);
+
+/* ==== Accumulate reflections during ttswp? Use block */
+/* . 2-by-2 structure during matrix-matrix multiply? ==== */
+
+ kacc22 = ilaenv_(&c__16, "SLAQR4", jbcmpz, n, ilo, ihi, lwork);
+ kacc22 = max(0,kacc22);
+ kacc22 = min(2,kacc22);
+
+/* ==== NWMAX = the largest possible deflation window for */
+/* . which there is sufficient workspace. ==== */
+
+/* Computing MIN */
+ i__1 = (*n - 1) / 3, i__2 = *lwork / 2;
+ nwmax = min(i__1,i__2);
+ nw = nwmax;
+
+/* ==== NSMAX = the Largest number of simultaneous shifts */
+/* . for which there is sufficient workspace. ==== */
+
+/* Computing MIN */
+ i__1 = (*n + 6) / 9, i__2 = (*lwork << 1) / 3;
+ nsmax = min(i__1,i__2);
+ nsmax -= nsmax % 2;
+
+/* ==== NDFL: an iteration count restarted at deflation. ==== */
+
+ ndfl = 1;
+
+/* ==== ITMAX = iteration limit ==== */
+
+/* Computing MAX */
+ i__1 = 10, i__2 = *ihi - *ilo + 1;
+ itmax = max(i__1,i__2) * 30;
+
+/* ==== Last row and column in the active block ==== */
+
+ kbot = *ihi;
+
+/* ==== Main Loop ==== */
+
+ i__1 = itmax;
+ for (it = 1; it <= i__1; ++it) {
+
+/* ==== Done when KBOT falls below ILO ==== */
+
+ if (kbot < *ilo) {
+ goto L90;
+ }
+
+/* ==== Locate active block ==== */
+
+ i__2 = *ilo + 1;
+ for (k = kbot; k >= i__2; --k) {
+ if (h__[k + (k - 1) * h_dim1] == 0.f) {
+ goto L20;
+ }
+/* L10: */
+ }
+ k = *ilo;
+L20:
+ ktop = k;
+
+/* ==== Select deflation window size: */
+/* . Typical Case: */
+/* . If possible and advisable, nibble the entire */
+/* . active block. If not, use size MIN(NWR,NWMAX) */
+/* . or MIN(NWR+1,NWMAX) depending upon which has */
+/* . the smaller corresponding subdiagonal entry */
+/* . (a heuristic). */
+/* . */
+/* . Exceptional Case: */
+/* . If there have been no deflations in KEXNW or */
+/* . more iterations, then vary the deflation window */
+/* . size. At first, because, larger windows are, */
+/* . in general, more powerful than smaller ones, */
+/* . rapidly increase the window to the maximum possible. */
+/* . Then, gradually reduce the window size. ==== */
+
+ nh = kbot - ktop + 1;
+ nwupbd = min(nh,nwmax);
+ if (ndfl < 5) {
+ nw = min(nwupbd,nwr);
+ } else {
+/* Computing MIN */
+ i__2 = nwupbd, i__3 = nw << 1;
+ nw = min(i__2,i__3);
+ }
+ if (nw < nwmax) {
+ if (nw >= nh - 1) {
+ nw = nh;
+ } else {
+ kwtop = kbot - nw + 1;
+ if ((r__1 = h__[kwtop + (kwtop - 1) * h_dim1], dabs(r__1))
+ > (r__2 = h__[kwtop - 1 + (kwtop - 2) * h_dim1],
+ dabs(r__2))) {
+ ++nw;
+ }
+ }
+ }
+ if (ndfl < 5) {
+ ndec = -1;
+ } else if (ndec >= 0 || nw >= nwupbd) {
+ ++ndec;
+ if (nw - ndec < 2) {
+ ndec = 0;
+ }
+ nw -= ndec;
+ }
+
+/* ==== Aggressive early deflation: */
+/* . split workspace under the subdiagonal into */
+/* . - an nw-by-nw work array V in the lower */
+/* . left-hand-corner, */
+/* . - an NW-by-at-least-NW-but-more-is-better */
+/* . (NW-by-NHO) horizontal work array along */
+/* . the bottom edge, */
+/* . - an at-least-NW-but-more-is-better (NHV-by-NW) */
+/* . vertical work array along the left-hand-edge. */
+/* . ==== */
+
+ kv = *n - nw + 1;
+ kt = nw + 1;
+ nho = *n - nw - 1 - kt + 1;
+ kwv = nw + 2;
+ nve = *n - nw - kwv + 1;
+
+/* ==== Aggressive early deflation ==== */
+
+ slaqr2_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh,
+ iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1],
+ &h__[kv + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1],
+ ldh, &nve, &h__[kwv + h_dim1], ldh, &work[1], lwork);
+
+/* ==== Adjust KBOT accounting for new deflations. ==== */
+
+ kbot -= ld;
+
+/* ==== KS points to the shifts. ==== */
+
+ ks = kbot - ls + 1;
+
+/* ==== Skip an expensive QR sweep if there is a (partly */
+/* . heuristic) reason to expect that many eigenvalues */
+/* . will deflate without it. Here, the QR sweep is */
+/* . skipped if many eigenvalues have just been deflated */
+/* . or if the remaining active block is small. */
+
+ if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > min(
+ nmin,nwmax)) {
+
+/* ==== NS = nominal number of simultaneous shifts. */
+/* . This may be lowered (slightly) if SLAQR2 */
+/* . did not provide that many shifts. ==== */
+
+/* Computing MIN */
+/* Computing MAX */
+ i__4 = 2, i__5 = kbot - ktop;
+ i__2 = min(nsmax,nsr), i__3 = max(i__4,i__5);
+ ns = min(i__2,i__3);
+ ns -= ns % 2;
+
+/* ==== If there have been no deflations */
+/* . in a multiple of KEXSH iterations, */
+/* . then try exceptional shifts. */
+/* . Otherwise use shifts provided by */
+/* . SLAQR2 above or from the eigenvalues */
+/* . of a trailing principal submatrix. ==== */
+
+ if (ndfl % 6 == 0) {
+ ks = kbot - ns + 1;
+/* Computing MAX */
+ i__3 = ks + 1, i__4 = ktop + 2;
+ i__2 = max(i__3,i__4);
+ for (i__ = kbot; i__ >= i__2; i__ += -2) {
+ ss = (r__1 = h__[i__ + (i__ - 1) * h_dim1], dabs(r__1)
+ ) + (r__2 = h__[i__ - 1 + (i__ - 2) * h_dim1],
+ dabs(r__2));
+ aa = ss * .75f + h__[i__ + i__ * h_dim1];
+ bb = ss;
+ cc = ss * -.4375f;
+ dd = aa;
+ slanv2_(&aa, &bb, &cc, &dd, &wr[i__ - 1], &wi[i__ - 1]
+, &wr[i__], &wi[i__], &cs, &sn);
+/* L30: */
+ }
+ if (ks == ktop) {
+ wr[ks + 1] = h__[ks + 1 + (ks + 1) * h_dim1];
+ wi[ks + 1] = 0.f;
+ wr[ks] = wr[ks + 1];
+ wi[ks] = wi[ks + 1];
+ }
+ } else {
+
+/* ==== Got NS/2 or fewer shifts? Use SLAHQR */
+/* . on a trailing principal submatrix to */
+/* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, */
+/* . there is enough space below the subdiagonal */
+/* . to fit an NS-by-NS scratch array.) ==== */
+
+ if (kbot - ks + 1 <= ns / 2) {
+ ks = kbot - ns + 1;
+ kt = *n - ns + 1;
+ slacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, &
+ h__[kt + h_dim1], ldh);
+ slahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[kt
+ + h_dim1], ldh, &wr[ks], &wi[ks], &c__1, &
+ c__1, zdum, &c__1, &inf);
+ ks += inf;
+
+/* ==== In case of a rare QR failure use */
+/* . eigenvalues of the trailing 2-by-2 */
+/* . principal submatrix. ==== */
+
+ if (ks >= kbot) {
+ aa = h__[kbot - 1 + (kbot - 1) * h_dim1];
+ cc = h__[kbot + (kbot - 1) * h_dim1];
+ bb = h__[kbot - 1 + kbot * h_dim1];
+ dd = h__[kbot + kbot * h_dim1];
+ slanv2_(&aa, &bb, &cc, &dd, &wr[kbot - 1], &wi[
+ kbot - 1], &wr[kbot], &wi[kbot], &cs, &sn)
+ ;
+ ks = kbot - 1;
+ }
+ }
+
+ if (kbot - ks + 1 > ns) {
+
+/* ==== Sort the shifts (Helps a little) */
+/* . Bubble sort keeps complex conjugate */
+/* . pairs together. ==== */
+
+ sorted = FALSE_;
+ i__2 = ks + 1;
+ for (k = kbot; k >= i__2; --k) {
+ if (sorted) {
+ goto L60;
+ }
+ sorted = TRUE_;
+ i__3 = k - 1;
+ for (i__ = ks; i__ <= i__3; ++i__) {
+ if ((r__1 = wr[i__], dabs(r__1)) + (r__2 = wi[
+ i__], dabs(r__2)) < (r__3 = wr[i__ +
+ 1], dabs(r__3)) + (r__4 = wi[i__ + 1],
+ dabs(r__4))) {
+ sorted = FALSE_;
+
+ swap = wr[i__];
+ wr[i__] = wr[i__ + 1];
+ wr[i__ + 1] = swap;
+
+ swap = wi[i__];
+ wi[i__] = wi[i__ + 1];
+ wi[i__ + 1] = swap;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+L60:
+ ;
+ }
+
+/* ==== Shuffle shifts into pairs of real shifts */
+/* . and pairs of complex conjugate shifts */
+/* . assuming complex conjugate shifts are */
+/* . already adjacent to one another. (Yes, */
+/* . they are.) ==== */
+
+ i__2 = ks + 2;
+ for (i__ = kbot; i__ >= i__2; i__ += -2) {
+ if (wi[i__] != -wi[i__ - 1]) {
+
+ swap = wr[i__];
+ wr[i__] = wr[i__ - 1];
+ wr[i__ - 1] = wr[i__ - 2];
+ wr[i__ - 2] = swap;
+
+ swap = wi[i__];
+ wi[i__] = wi[i__ - 1];
+ wi[i__ - 1] = wi[i__ - 2];
+ wi[i__ - 2] = swap;
+ }
+/* L70: */
+ }
+ }
+
+/* ==== If there are only two shifts and both are */
+/* . real, then use only one. ==== */
+
+ if (kbot - ks + 1 == 2) {
+ if (wi[kbot] == 0.f) {
+ if ((r__1 = wr[kbot] - h__[kbot + kbot * h_dim1],
+ dabs(r__1)) < (r__2 = wr[kbot - 1] - h__[kbot
+ + kbot * h_dim1], dabs(r__2))) {
+ wr[kbot - 1] = wr[kbot];
+ } else {
+ wr[kbot] = wr[kbot - 1];
+ }
+ }
+ }
+
+/* ==== Use up to NS of the the smallest magnatiude */
+/* . shifts. If there aren't NS shifts available, */
+/* . then use them all, possibly dropping one to */
+/* . make the number of shifts even. ==== */
+
+/* Computing MIN */
+ i__2 = ns, i__3 = kbot - ks + 1;
+ ns = min(i__2,i__3);
+ ns -= ns % 2;
+ ks = kbot - ns + 1;
+
+/* ==== Small-bulge multi-shift QR sweep: */
+/* . split workspace under the subdiagonal into */
+/* . - a KDU-by-KDU work array U in the lower */
+/* . left-hand-corner, */
+/* . - a KDU-by-at-least-KDU-but-more-is-better */
+/* . (KDU-by-NHo) horizontal work array WH along */
+/* . the bottom edge, */
+/* . - and an at-least-KDU-but-more-is-better-by-KDU */
+/* . (NVE-by-KDU) vertical work WV arrow along */
+/* . the left-hand-edge. ==== */
+
+ kdu = ns * 3 - 3;
+ ku = *n - kdu + 1;
+ kwh = kdu + 1;
+ nho = *n - kdu - 3 - (kdu + 1) + 1;
+ kwv = kdu + 4;
+ nve = *n - kdu - kwv + 1;
+
+/* ==== Small-bulge multi-shift QR sweep ==== */
+
+ slaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &wr[ks],
+ &wi[ks], &h__[h_offset], ldh, iloz, ihiz, &z__[
+ z_offset], ldz, &work[1], &c__3, &h__[ku + h_dim1],
+ ldh, &nve, &h__[kwv + h_dim1], ldh, &nho, &h__[ku +
+ kwh * h_dim1], ldh);
+ }
+
+/* ==== Note progress (or the lack of it). ==== */
+
+ if (ld > 0) {
+ ndfl = 1;
+ } else {
+ ++ndfl;
+ }
+
+/* ==== End of main loop ==== */
+/* L80: */
+ }
+
+/* ==== Iteration limit exceeded. Set INFO to show where */
+/* . the problem occurred and exit. ==== */
+
+ *info = kbot;
+L90:
+ ;
+ }
+
+/* ==== Return the optimal value of LWORK. ==== */
+
+ work[1] = (real) lwkopt;
+
+/* ==== End of SLAQR4 ==== */
+
+ return 0;
+} /* slaqr4_ */
diff --git a/SRC/slaqr5.c b/SRC/slaqr5.c
new file mode 100644
index 0000000..0f32351
--- /dev/null
+++ b/SRC/slaqr5.c
@@ -0,0 +1,1026 @@
+/* slaqr5.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b7 = 0.f;
+static real c_b8 = 1.f;
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int slaqr5_(logical *wantt, logical *wantz, integer *kacc22,
+ integer *n, integer *ktop, integer *kbot, integer *nshfts, real *sr,
+ real *si, real *h__, integer *ldh, integer *iloz, integer *ihiz, real
+ *z__, integer *ldz, real *v, integer *ldv, real *u, integer *ldu,
+ integer *nv, real *wv, integer *ldwv, integer *nh, real *wh, integer *
+ ldwh)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, u_dim1, u_offset, v_dim1, v_offset, wh_dim1,
+ wh_offset, wv_dim1, wv_offset, z_dim1, z_offset, i__1, i__2, i__3,
+ i__4, i__5, i__6, i__7;
+ real r__1, r__2, r__3, r__4, r__5;
+
+ /* Local variables */
+ integer i__, j, k, m, i2, j2, i4, j4, k1;
+ real h11, h12, h21, h22;
+ integer m22, ns, nu;
+ real vt[3], scl;
+ integer kdu, kms;
+ real ulp;
+ integer knz, kzs;
+ real tst1, tst2, beta;
+ logical blk22, bmp22;
+ integer mend, jcol, jlen, jbot, mbot;
+ real swap;
+ integer jtop, jrow, mtop;
+ real alpha;
+ logical accum;
+ integer ndcol, incol;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ integer krcol, nbmps;
+ extern /* Subroutine */ int strmm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), slaqr1_(integer *, real *,
+ integer *, real *, real *, real *, real *, real *), slabad_(real *
+, real *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
+ real *);
+ real safmax;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *);
+ real refsum;
+ integer mstart;
+ real smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* This auxiliary subroutine called by SLAQR0 performs a */
+/* single small-bulge multi-shift QR sweep. */
+
+/* WANTT (input) logical scalar */
+/* WANTT = .true. if the quasi-triangular Schur factor */
+/* is being computed. WANTT is set to .false. otherwise. */
+
+/* WANTZ (input) logical scalar */
+/* WANTZ = .true. if the orthogonal Schur factor is being */
+/* computed. WANTZ is set to .false. otherwise. */
+
+/* KACC22 (input) integer with value 0, 1, or 2. */
+/* Specifies the computation mode of far-from-diagonal */
+/* orthogonal updates. */
+/* = 0: SLAQR5 does not accumulate reflections and does not */
+/* use matrix-matrix multiply to update far-from-diagonal */
+/* matrix entries. */
+/* = 1: SLAQR5 accumulates reflections and uses matrix-matrix */
+/* multiply to update the far-from-diagonal matrix entries. */
+/* = 2: SLAQR5 accumulates reflections, uses matrix-matrix */
+/* multiply to update the far-from-diagonal matrix entries, */
+/* and takes advantage of 2-by-2 block structure during */
+/* matrix multiplies. */
+
+/* N (input) integer scalar */
+/* N is the order of the Hessenberg matrix H upon which this */
+/* subroutine operates. */
+
+/* KTOP (input) integer scalar */
+/* KBOT (input) integer scalar */
+/* These are the first and last rows and columns of an */
+/* isolated diagonal block upon which the QR sweep is to be */
+/* applied. It is assumed without a check that */
+/* either KTOP = 1 or H(KTOP,KTOP-1) = 0 */
+/* and */
+/* either KBOT = N or H(KBOT+1,KBOT) = 0. */
+
+/* NSHFTS (input) integer scalar */
+/* NSHFTS gives the number of simultaneous shifts. NSHFTS */
+/* must be positive and even. */
+
+/* SR (input/output) REAL array of size (NSHFTS) */
+/* SI (input/output) REAL array of size (NSHFTS) */
+/* SR contains the real parts and SI contains the imaginary */
+/* parts of the NSHFTS shifts of origin that define the */
+/* multi-shift QR sweep. On output SR and SI may be */
+/* reordered. */
+
+/* H (input/output) REAL array of size (LDH,N) */
+/* On input H contains a Hessenberg matrix. On output a */
+/* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied */
+/* to the isolated diagonal block in rows and columns KTOP */
+/* through KBOT. */
+
+/* LDH (input) integer scalar */
+/* LDH is the leading dimension of H just as declared in the */
+/* calling procedure. LDH.GE.MAX(1,N). */
+
+/* ILOZ (input) INTEGER */
+/* IHIZ (input) INTEGER */
+/* Specify the rows of Z to which transformations must be */
+/* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N */
+
+/* Z (input/output) REAL array of size (LDZ,IHI) */
+/* If WANTZ = .TRUE., then the QR Sweep orthogonal */
+/* similarity transformation is accumulated into */
+/* Z(ILOZ:IHIZ,ILO:IHI) from the right. */
+/* If WANTZ = .FALSE., then Z is unreferenced. */
+
+/* LDZ (input) integer scalar */
+/* LDA is the leading dimension of Z just as declared in */
+/* the calling procedure. LDZ.GE.N. */
+
+/* V (workspace) REAL array of size (LDV,NSHFTS/2) */
+
+/* LDV (input) integer scalar */
+/* LDV is the leading dimension of V as declared in the */
+/* calling procedure. LDV.GE.3. */
+
+/* U (workspace) REAL array of size */
+/* (LDU,3*NSHFTS-3) */
+
+/* LDU (input) integer scalar */
+/* LDU is the leading dimension of U just as declared in the */
+/* in the calling subroutine. LDU.GE.3*NSHFTS-3. */
+
+/* NH (input) integer scalar */
+/* NH is the number of columns in array WH available for */
+/* workspace. NH.GE.1. */
+
+/* WH (workspace) REAL array of size (LDWH,NH) */
+
+/* LDWH (input) integer scalar */
+/* Leading dimension of WH just as declared in the */
+/* calling procedure. LDWH.GE.3*NSHFTS-3. */
+
+/* NV (input) integer scalar */
+/* NV is the number of rows in WV agailable for workspace. */
+/* NV.GE.1. */
+
+/* WV (workspace) REAL array of size */
+/* (LDWV,3*NSHFTS-3) */
+
+/* LDWV (input) integer scalar */
+/* LDWV is the leading dimension of WV as declared in the */
+/* in the calling subroutine. LDWV.GE.NV. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* Reference: */
+
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part I: Maintaining Well Focused Shifts, and */
+/* Level 3 Performance, SIAM Journal of Matrix Analysis, */
+/* volume 23, pages 929--947, 2002. */
+
+/* ================================================================ */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* ==== If there are no shifts, then there is nothing to do. ==== */
+
+ /* Parameter adjustments */
+ --sr;
+ --si;
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ wv_dim1 = *ldwv;
+ wv_offset = 1 + wv_dim1;
+ wv -= wv_offset;
+ wh_dim1 = *ldwh;
+ wh_offset = 1 + wh_dim1;
+ wh -= wh_offset;
+
+ /* Function Body */
+ if (*nshfts < 2) {
+ return 0;
+ }
+
+/* ==== If the active block is empty or 1-by-1, then there */
+/* . is nothing to do. ==== */
+
+ if (*ktop >= *kbot) {
+ return 0;
+ }
+
+/* ==== Shuffle shifts into pairs of real shifts and pairs */
+/* . of complex conjugate shifts assuming complex */
+/* . conjugate shifts are already adjacent to one */
+/* . another. ==== */
+
+ i__1 = *nshfts - 2;
+ for (i__ = 1; i__ <= i__1; i__ += 2) {
+ if (si[i__] != -si[i__ + 1]) {
+
+ swap = sr[i__];
+ sr[i__] = sr[i__ + 1];
+ sr[i__ + 1] = sr[i__ + 2];
+ sr[i__ + 2] = swap;
+
+ swap = si[i__];
+ si[i__] = si[i__ + 1];
+ si[i__ + 1] = si[i__ + 2];
+ si[i__ + 2] = swap;
+ }
+/* L10: */
+ }
+
+/* ==== NSHFTS is supposed to be even, but if it is odd, */
+/* . then simply reduce it by one. The shuffle above */
+/* . ensures that the dropped shift is real and that */
+/* . the remaining shifts are paired. ==== */
+
+ ns = *nshfts - *nshfts % 2;
+
+/* ==== Machine constants for deflation ==== */
+
+ safmin = slamch_("SAFE MINIMUM");
+ safmax = 1.f / safmin;
+ slabad_(&safmin, &safmax);
+ ulp = slamch_("PRECISION");
+ smlnum = safmin * ((real) (*n) / ulp);
+
+/* ==== Use accumulated reflections to update far-from-diagonal */
+/* . entries ? ==== */
+
+ accum = *kacc22 == 1 || *kacc22 == 2;
+
+/* ==== If so, exploit the 2-by-2 block structure? ==== */
+
+ blk22 = ns > 2 && *kacc22 == 2;
+
+/* ==== clear trash ==== */
+
+ if (*ktop + 2 <= *kbot) {
+ h__[*ktop + 2 + *ktop * h_dim1] = 0.f;
+ }
+
+/* ==== NBMPS = number of 2-shift bulges in the chain ==== */
+
+ nbmps = ns / 2;
+
+/* ==== KDU = width of slab ==== */
+
+ kdu = nbmps * 6 - 3;
+
+/* ==== Create and chase chains of NBMPS bulges ==== */
+
+ i__1 = *kbot - 2;
+ i__2 = nbmps * 3 - 2;
+ for (incol = (1 - nbmps) * 3 + *ktop - 1; i__2 < 0 ? incol >= i__1 :
+ incol <= i__1; incol += i__2) {
+ ndcol = incol + kdu;
+ if (accum) {
+ slaset_("ALL", &kdu, &kdu, &c_b7, &c_b8, &u[u_offset], ldu);
+ }
+
+/* ==== Near-the-diagonal bulge chase. The following loop */
+/* . performs the near-the-diagonal part of a small bulge */
+/* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal */
+/* . chunk extends from column INCOL to column NDCOL */
+/* . (including both column INCOL and column NDCOL). The */
+/* . following loop chases a 3*NBMPS column long chain of */
+/* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL */
+/* . may be less than KTOP and and NDCOL may be greater than */
+/* . KBOT indicating phantom columns from which to chase */
+/* . bulges before they are actually introduced or to which */
+/* . to chase bulges beyond column KBOT.) ==== */
+
+/* Computing MIN */
+ i__4 = incol + nbmps * 3 - 3, i__5 = *kbot - 2;
+ i__3 = min(i__4,i__5);
+ for (krcol = incol; krcol <= i__3; ++krcol) {
+
+/* ==== Bulges number MTOP to MBOT are active double implicit */
+/* . shift bulges. There may or may not also be small */
+/* . 2-by-2 bulge, if there is room. The inactive bulges */
+/* . (if any) must wait until the active bulges have moved */
+/* . down the diagonal to make room. The phantom matrix */
+/* . paradigm described above helps keep track. ==== */
+
+/* Computing MAX */
+ i__4 = 1, i__5 = (*ktop - 1 - krcol + 2) / 3 + 1;
+ mtop = max(i__4,i__5);
+/* Computing MIN */
+ i__4 = nbmps, i__5 = (*kbot - krcol) / 3;
+ mbot = min(i__4,i__5);
+ m22 = mbot + 1;
+ bmp22 = mbot < nbmps && krcol + (m22 - 1) * 3 == *kbot - 2;
+
+/* ==== Generate reflections to chase the chain right */
+/* . one column. (The minimum value of K is KTOP-1.) ==== */
+
+ i__4 = mbot;
+ for (m = mtop; m <= i__4; ++m) {
+ k = krcol + (m - 1) * 3;
+ if (k == *ktop - 1) {
+ slaqr1_(&c__3, &h__[*ktop + *ktop * h_dim1], ldh, &sr[(m
+ << 1) - 1], &si[(m << 1) - 1], &sr[m * 2], &si[m *
+ 2], &v[m * v_dim1 + 1]);
+ alpha = v[m * v_dim1 + 1];
+ slarfg_(&c__3, &alpha, &v[m * v_dim1 + 2], &c__1, &v[m *
+ v_dim1 + 1]);
+ } else {
+ beta = h__[k + 1 + k * h_dim1];
+ v[m * v_dim1 + 2] = h__[k + 2 + k * h_dim1];
+ v[m * v_dim1 + 3] = h__[k + 3 + k * h_dim1];
+ slarfg_(&c__3, &beta, &v[m * v_dim1 + 2], &c__1, &v[m *
+ v_dim1 + 1]);
+
+/* ==== A Bulge may collapse because of vigilant */
+/* . deflation or destructive underflow. In the */
+/* . underflow case, try the two-small-subdiagonals */
+/* . trick to try to reinflate the bulge. ==== */
+
+ if (h__[k + 3 + k * h_dim1] != 0.f || h__[k + 3 + (k + 1)
+ * h_dim1] != 0.f || h__[k + 3 + (k + 2) * h_dim1]
+ == 0.f) {
+
+/* ==== Typical case: not collapsed (yet). ==== */
+
+ h__[k + 1 + k * h_dim1] = beta;
+ h__[k + 2 + k * h_dim1] = 0.f;
+ h__[k + 3 + k * h_dim1] = 0.f;
+ } else {
+
+/* ==== Atypical case: collapsed. Attempt to */
+/* . reintroduce ignoring H(K+1,K) and H(K+2,K). */
+/* . If the fill resulting from the new */
+/* . reflector is too large, then abandon it. */
+/* . Otherwise, use the new one. ==== */
+
+ slaqr1_(&c__3, &h__[k + 1 + (k + 1) * h_dim1], ldh, &
+ sr[(m << 1) - 1], &si[(m << 1) - 1], &sr[m *
+ 2], &si[m * 2], vt);
+ alpha = vt[0];
+ slarfg_(&c__3, &alpha, &vt[1], &c__1, vt);
+ refsum = vt[0] * (h__[k + 1 + k * h_dim1] + vt[1] *
+ h__[k + 2 + k * h_dim1]);
+
+ if ((r__1 = h__[k + 2 + k * h_dim1] - refsum * vt[1],
+ dabs(r__1)) + (r__2 = refsum * vt[2], dabs(
+ r__2)) > ulp * ((r__3 = h__[k + k * h_dim1],
+ dabs(r__3)) + (r__4 = h__[k + 1 + (k + 1) *
+ h_dim1], dabs(r__4)) + (r__5 = h__[k + 2 + (k
+ + 2) * h_dim1], dabs(r__5)))) {
+
+/* ==== Starting a new bulge here would */
+/* . create non-negligible fill. Use */
+/* . the old one with trepidation. ==== */
+
+ h__[k + 1 + k * h_dim1] = beta;
+ h__[k + 2 + k * h_dim1] = 0.f;
+ h__[k + 3 + k * h_dim1] = 0.f;
+ } else {
+
+/* ==== Stating a new bulge here would */
+/* . create only negligible fill. */
+/* . Replace the old reflector with */
+/* . the new one. ==== */
+
+ h__[k + 1 + k * h_dim1] -= refsum;
+ h__[k + 2 + k * h_dim1] = 0.f;
+ h__[k + 3 + k * h_dim1] = 0.f;
+ v[m * v_dim1 + 1] = vt[0];
+ v[m * v_dim1 + 2] = vt[1];
+ v[m * v_dim1 + 3] = vt[2];
+ }
+ }
+ }
+/* L20: */
+ }
+
+/* ==== Generate a 2-by-2 reflection, if needed. ==== */
+
+ k = krcol + (m22 - 1) * 3;
+ if (bmp22) {
+ if (k == *ktop - 1) {
+ slaqr1_(&c__2, &h__[k + 1 + (k + 1) * h_dim1], ldh, &sr[(
+ m22 << 1) - 1], &si[(m22 << 1) - 1], &sr[m22 * 2],
+ &si[m22 * 2], &v[m22 * v_dim1 + 1]);
+ beta = v[m22 * v_dim1 + 1];
+ slarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22
+ * v_dim1 + 1]);
+ } else {
+ beta = h__[k + 1 + k * h_dim1];
+ v[m22 * v_dim1 + 2] = h__[k + 2 + k * h_dim1];
+ slarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22
+ * v_dim1 + 1]);
+ h__[k + 1 + k * h_dim1] = beta;
+ h__[k + 2 + k * h_dim1] = 0.f;
+ }
+ }
+
+/* ==== Multiply H by reflections from the left ==== */
+
+ if (accum) {
+ jbot = min(ndcol,*kbot);
+ } else if (*wantt) {
+ jbot = *n;
+ } else {
+ jbot = *kbot;
+ }
+ i__4 = jbot;
+ for (j = max(*ktop,krcol); j <= i__4; ++j) {
+/* Computing MIN */
+ i__5 = mbot, i__6 = (j - krcol + 2) / 3;
+ mend = min(i__5,i__6);
+ i__5 = mend;
+ for (m = mtop; m <= i__5; ++m) {
+ k = krcol + (m - 1) * 3;
+ refsum = v[m * v_dim1 + 1] * (h__[k + 1 + j * h_dim1] + v[
+ m * v_dim1 + 2] * h__[k + 2 + j * h_dim1] + v[m *
+ v_dim1 + 3] * h__[k + 3 + j * h_dim1]);
+ h__[k + 1 + j * h_dim1] -= refsum;
+ h__[k + 2 + j * h_dim1] -= refsum * v[m * v_dim1 + 2];
+ h__[k + 3 + j * h_dim1] -= refsum * v[m * v_dim1 + 3];
+/* L30: */
+ }
+/* L40: */
+ }
+ if (bmp22) {
+ k = krcol + (m22 - 1) * 3;
+/* Computing MAX */
+ i__4 = k + 1;
+ i__5 = jbot;
+ for (j = max(i__4,*ktop); j <= i__5; ++j) {
+ refsum = v[m22 * v_dim1 + 1] * (h__[k + 1 + j * h_dim1] +
+ v[m22 * v_dim1 + 2] * h__[k + 2 + j * h_dim1]);
+ h__[k + 1 + j * h_dim1] -= refsum;
+ h__[k + 2 + j * h_dim1] -= refsum * v[m22 * v_dim1 + 2];
+/* L50: */
+ }
+ }
+
+/* ==== Multiply H by reflections from the right. */
+/* . Delay filling in the last row until the */
+/* . vigilant deflation check is complete. ==== */
+
+ if (accum) {
+ jtop = max(*ktop,incol);
+ } else if (*wantt) {
+ jtop = 1;
+ } else {
+ jtop = *ktop;
+ }
+ i__5 = mbot;
+ for (m = mtop; m <= i__5; ++m) {
+ if (v[m * v_dim1 + 1] != 0.f) {
+ k = krcol + (m - 1) * 3;
+/* Computing MIN */
+ i__6 = *kbot, i__7 = k + 3;
+ i__4 = min(i__6,i__7);
+ for (j = jtop; j <= i__4; ++j) {
+ refsum = v[m * v_dim1 + 1] * (h__[j + (k + 1) *
+ h_dim1] + v[m * v_dim1 + 2] * h__[j + (k + 2)
+ * h_dim1] + v[m * v_dim1 + 3] * h__[j + (k +
+ 3) * h_dim1]);
+ h__[j + (k + 1) * h_dim1] -= refsum;
+ h__[j + (k + 2) * h_dim1] -= refsum * v[m * v_dim1 +
+ 2];
+ h__[j + (k + 3) * h_dim1] -= refsum * v[m * v_dim1 +
+ 3];
+/* L60: */
+ }
+
+ if (accum) {
+
+/* ==== Accumulate U. (If necessary, update Z later */
+/* . with with an efficient matrix-matrix */
+/* . multiply.) ==== */
+
+ kms = k - incol;
+/* Computing MAX */
+ i__4 = 1, i__6 = *ktop - incol;
+ i__7 = kdu;
+ for (j = max(i__4,i__6); j <= i__7; ++j) {
+ refsum = v[m * v_dim1 + 1] * (u[j + (kms + 1) *
+ u_dim1] + v[m * v_dim1 + 2] * u[j + (kms
+ + 2) * u_dim1] + v[m * v_dim1 + 3] * u[j
+ + (kms + 3) * u_dim1]);
+ u[j + (kms + 1) * u_dim1] -= refsum;
+ u[j + (kms + 2) * u_dim1] -= refsum * v[m *
+ v_dim1 + 2];
+ u[j + (kms + 3) * u_dim1] -= refsum * v[m *
+ v_dim1 + 3];
+/* L70: */
+ }
+ } else if (*wantz) {
+
+/* ==== U is not accumulated, so update Z */
+/* . now by multiplying by reflections */
+/* . from the right. ==== */
+
+ i__7 = *ihiz;
+ for (j = *iloz; j <= i__7; ++j) {
+ refsum = v[m * v_dim1 + 1] * (z__[j + (k + 1) *
+ z_dim1] + v[m * v_dim1 + 2] * z__[j + (k
+ + 2) * z_dim1] + v[m * v_dim1 + 3] * z__[
+ j + (k + 3) * z_dim1]);
+ z__[j + (k + 1) * z_dim1] -= refsum;
+ z__[j + (k + 2) * z_dim1] -= refsum * v[m *
+ v_dim1 + 2];
+ z__[j + (k + 3) * z_dim1] -= refsum * v[m *
+ v_dim1 + 3];
+/* L80: */
+ }
+ }
+ }
+/* L90: */
+ }
+
+/* ==== Special case: 2-by-2 reflection (if needed) ==== */
+
+ k = krcol + (m22 - 1) * 3;
+ if (bmp22 && v[m22 * v_dim1 + 1] != 0.f) {
+/* Computing MIN */
+ i__7 = *kbot, i__4 = k + 3;
+ i__5 = min(i__7,i__4);
+ for (j = jtop; j <= i__5; ++j) {
+ refsum = v[m22 * v_dim1 + 1] * (h__[j + (k + 1) * h_dim1]
+ + v[m22 * v_dim1 + 2] * h__[j + (k + 2) * h_dim1])
+ ;
+ h__[j + (k + 1) * h_dim1] -= refsum;
+ h__[j + (k + 2) * h_dim1] -= refsum * v[m22 * v_dim1 + 2];
+/* L100: */
+ }
+
+ if (accum) {
+ kms = k - incol;
+/* Computing MAX */
+ i__5 = 1, i__7 = *ktop - incol;
+ i__4 = kdu;
+ for (j = max(i__5,i__7); j <= i__4; ++j) {
+ refsum = v[m22 * v_dim1 + 1] * (u[j + (kms + 1) *
+ u_dim1] + v[m22 * v_dim1 + 2] * u[j + (kms +
+ 2) * u_dim1]);
+ u[j + (kms + 1) * u_dim1] -= refsum;
+ u[j + (kms + 2) * u_dim1] -= refsum * v[m22 * v_dim1
+ + 2];
+/* L110: */
+ }
+ } else if (*wantz) {
+ i__4 = *ihiz;
+ for (j = *iloz; j <= i__4; ++j) {
+ refsum = v[m22 * v_dim1 + 1] * (z__[j + (k + 1) *
+ z_dim1] + v[m22 * v_dim1 + 2] * z__[j + (k +
+ 2) * z_dim1]);
+ z__[j + (k + 1) * z_dim1] -= refsum;
+ z__[j + (k + 2) * z_dim1] -= refsum * v[m22 * v_dim1
+ + 2];
+/* L120: */
+ }
+ }
+ }
+
+/* ==== Vigilant deflation check ==== */
+
+ mstart = mtop;
+ if (krcol + (mstart - 1) * 3 < *ktop) {
+ ++mstart;
+ }
+ mend = mbot;
+ if (bmp22) {
+ ++mend;
+ }
+ if (krcol == *kbot - 2) {
+ ++mend;
+ }
+ i__4 = mend;
+ for (m = mstart; m <= i__4; ++m) {
+/* Computing MIN */
+ i__5 = *kbot - 1, i__7 = krcol + (m - 1) * 3;
+ k = min(i__5,i__7);
+
+/* ==== The following convergence test requires that */
+/* . the tradition small-compared-to-nearby-diagonals */
+/* . criterion and the Ahues & Tisseur (LAWN 122, 1997) */
+/* . criteria both be satisfied. The latter improves */
+/* . accuracy in some examples. Falling back on an */
+/* . alternate convergence criterion when TST1 or TST2 */
+/* . is zero (as done here) is traditional but probably */
+/* . unnecessary. ==== */
+
+ if (h__[k + 1 + k * h_dim1] != 0.f) {
+ tst1 = (r__1 = h__[k + k * h_dim1], dabs(r__1)) + (r__2 =
+ h__[k + 1 + (k + 1) * h_dim1], dabs(r__2));
+ if (tst1 == 0.f) {
+ if (k >= *ktop + 1) {
+ tst1 += (r__1 = h__[k + (k - 1) * h_dim1], dabs(
+ r__1));
+ }
+ if (k >= *ktop + 2) {
+ tst1 += (r__1 = h__[k + (k - 2) * h_dim1], dabs(
+ r__1));
+ }
+ if (k >= *ktop + 3) {
+ tst1 += (r__1 = h__[k + (k - 3) * h_dim1], dabs(
+ r__1));
+ }
+ if (k <= *kbot - 2) {
+ tst1 += (r__1 = h__[k + 2 + (k + 1) * h_dim1],
+ dabs(r__1));
+ }
+ if (k <= *kbot - 3) {
+ tst1 += (r__1 = h__[k + 3 + (k + 1) * h_dim1],
+ dabs(r__1));
+ }
+ if (k <= *kbot - 4) {
+ tst1 += (r__1 = h__[k + 4 + (k + 1) * h_dim1],
+ dabs(r__1));
+ }
+ }
+/* Computing MAX */
+ r__2 = smlnum, r__3 = ulp * tst1;
+ if ((r__1 = h__[k + 1 + k * h_dim1], dabs(r__1)) <= dmax(
+ r__2,r__3)) {
+/* Computing MAX */
+ r__3 = (r__1 = h__[k + 1 + k * h_dim1], dabs(r__1)),
+ r__4 = (r__2 = h__[k + (k + 1) * h_dim1],
+ dabs(r__2));
+ h12 = dmax(r__3,r__4);
+/* Computing MIN */
+ r__3 = (r__1 = h__[k + 1 + k * h_dim1], dabs(r__1)),
+ r__4 = (r__2 = h__[k + (k + 1) * h_dim1],
+ dabs(r__2));
+ h21 = dmin(r__3,r__4);
+/* Computing MAX */
+ r__3 = (r__1 = h__[k + 1 + (k + 1) * h_dim1], dabs(
+ r__1)), r__4 = (r__2 = h__[k + k * h_dim1] -
+ h__[k + 1 + (k + 1) * h_dim1], dabs(r__2));
+ h11 = dmax(r__3,r__4);
+/* Computing MIN */
+ r__3 = (r__1 = h__[k + 1 + (k + 1) * h_dim1], dabs(
+ r__1)), r__4 = (r__2 = h__[k + k * h_dim1] -
+ h__[k + 1 + (k + 1) * h_dim1], dabs(r__2));
+ h22 = dmin(r__3,r__4);
+ scl = h11 + h12;
+ tst2 = h22 * (h11 / scl);
+
+/* Computing MAX */
+ r__1 = smlnum, r__2 = ulp * tst2;
+ if (tst2 == 0.f || h21 * (h12 / scl) <= dmax(r__1,
+ r__2)) {
+ h__[k + 1 + k * h_dim1] = 0.f;
+ }
+ }
+ }
+/* L130: */
+ }
+
+/* ==== Fill in the last row of each bulge. ==== */
+
+/* Computing MIN */
+ i__4 = nbmps, i__5 = (*kbot - krcol - 1) / 3;
+ mend = min(i__4,i__5);
+ i__4 = mend;
+ for (m = mtop; m <= i__4; ++m) {
+ k = krcol + (m - 1) * 3;
+ refsum = v[m * v_dim1 + 1] * v[m * v_dim1 + 3] * h__[k + 4 + (
+ k + 3) * h_dim1];
+ h__[k + 4 + (k + 1) * h_dim1] = -refsum;
+ h__[k + 4 + (k + 2) * h_dim1] = -refsum * v[m * v_dim1 + 2];
+ h__[k + 4 + (k + 3) * h_dim1] -= refsum * v[m * v_dim1 + 3];
+/* L140: */
+ }
+
+/* ==== End of near-the-diagonal bulge chase. ==== */
+
+/* L150: */
+ }
+
+/* ==== Use U (if accumulated) to update far-from-diagonal */
+/* . entries in H. If required, use U to update Z as */
+/* . well. ==== */
+
+ if (accum) {
+ if (*wantt) {
+ jtop = 1;
+ jbot = *n;
+ } else {
+ jtop = *ktop;
+ jbot = *kbot;
+ }
+ if (! blk22 || incol < *ktop || ndcol > *kbot || ns <= 2) {
+
+/* ==== Updates not exploiting the 2-by-2 block */
+/* . structure of U. K1 and NU keep track of */
+/* . the location and size of U in the special */
+/* . cases of introducing bulges and chasing */
+/* . bulges off the bottom. In these special */
+/* . cases and in case the number of shifts */
+/* . is NS = 2, there is no 2-by-2 block */
+/* . structure to exploit. ==== */
+
+/* Computing MAX */
+ i__3 = 1, i__4 = *ktop - incol;
+ k1 = max(i__3,i__4);
+/* Computing MAX */
+ i__3 = 0, i__4 = ndcol - *kbot;
+ nu = kdu - max(i__3,i__4) - k1 + 1;
+
+/* ==== Horizontal Multiply ==== */
+
+ i__3 = jbot;
+ i__4 = *nh;
+ for (jcol = min(ndcol,*kbot) + 1; i__4 < 0 ? jcol >= i__3 :
+ jcol <= i__3; jcol += i__4) {
+/* Computing MIN */
+ i__5 = *nh, i__7 = jbot - jcol + 1;
+ jlen = min(i__5,i__7);
+ sgemm_("C", "N", &nu, &jlen, &nu, &c_b8, &u[k1 + k1 *
+ u_dim1], ldu, &h__[incol + k1 + jcol * h_dim1],
+ ldh, &c_b7, &wh[wh_offset], ldwh);
+ slacpy_("ALL", &nu, &jlen, &wh[wh_offset], ldwh, &h__[
+ incol + k1 + jcol * h_dim1], ldh);
+/* L160: */
+ }
+
+/* ==== Vertical multiply ==== */
+
+ i__4 = max(*ktop,incol) - 1;
+ i__3 = *nv;
+ for (jrow = jtop; i__3 < 0 ? jrow >= i__4 : jrow <= i__4;
+ jrow += i__3) {
+/* Computing MIN */
+ i__5 = *nv, i__7 = max(*ktop,incol) - jrow;
+ jlen = min(i__5,i__7);
+ sgemm_("N", "N", &jlen, &nu, &nu, &c_b8, &h__[jrow + (
+ incol + k1) * h_dim1], ldh, &u[k1 + k1 * u_dim1],
+ ldu, &c_b7, &wv[wv_offset], ldwv);
+ slacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &h__[
+ jrow + (incol + k1) * h_dim1], ldh);
+/* L170: */
+ }
+
+/* ==== Z multiply (also vertical) ==== */
+
+ if (*wantz) {
+ i__3 = *ihiz;
+ i__4 = *nv;
+ for (jrow = *iloz; i__4 < 0 ? jrow >= i__3 : jrow <= i__3;
+ jrow += i__4) {
+/* Computing MIN */
+ i__5 = *nv, i__7 = *ihiz - jrow + 1;
+ jlen = min(i__5,i__7);
+ sgemm_("N", "N", &jlen, &nu, &nu, &c_b8, &z__[jrow + (
+ incol + k1) * z_dim1], ldz, &u[k1 + k1 *
+ u_dim1], ldu, &c_b7, &wv[wv_offset], ldwv);
+ slacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &z__[
+ jrow + (incol + k1) * z_dim1], ldz)
+ ;
+/* L180: */
+ }
+ }
+ } else {
+
+/* ==== Updates exploiting U's 2-by-2 block structure. */
+/* . (I2, I4, J2, J4 are the last rows and columns */
+/* . of the blocks.) ==== */
+
+ i2 = (kdu + 1) / 2;
+ i4 = kdu;
+ j2 = i4 - i2;
+ j4 = kdu;
+
+/* ==== KZS and KNZ deal with the band of zeros */
+/* . along the diagonal of one of the triangular */
+/* . blocks. ==== */
+
+ kzs = j4 - j2 - (ns + 1);
+ knz = ns + 1;
+
+/* ==== Horizontal multiply ==== */
+
+ i__4 = jbot;
+ i__3 = *nh;
+ for (jcol = min(ndcol,*kbot) + 1; i__3 < 0 ? jcol >= i__4 :
+ jcol <= i__4; jcol += i__3) {
+/* Computing MIN */
+ i__5 = *nh, i__7 = jbot - jcol + 1;
+ jlen = min(i__5,i__7);
+
+/* ==== Copy bottom of H to top+KZS of scratch ==== */
+/* (The first KZS rows get multiplied by zero.) ==== */
+
+ slacpy_("ALL", &knz, &jlen, &h__[incol + 1 + j2 + jcol *
+ h_dim1], ldh, &wh[kzs + 1 + wh_dim1], ldwh);
+
+/* ==== Multiply by U21' ==== */
+
+ slaset_("ALL", &kzs, &jlen, &c_b7, &c_b7, &wh[wh_offset],
+ ldwh);
+ strmm_("L", "U", "C", "N", &knz, &jlen, &c_b8, &u[j2 + 1
+ + (kzs + 1) * u_dim1], ldu, &wh[kzs + 1 + wh_dim1]
+, ldwh);
+
+/* ==== Multiply top of H by U11' ==== */
+
+ sgemm_("C", "N", &i2, &jlen, &j2, &c_b8, &u[u_offset],
+ ldu, &h__[incol + 1 + jcol * h_dim1], ldh, &c_b8,
+ &wh[wh_offset], ldwh);
+
+/* ==== Copy top of H to bottom of WH ==== */
+
+ slacpy_("ALL", &j2, &jlen, &h__[incol + 1 + jcol * h_dim1]
+, ldh, &wh[i2 + 1 + wh_dim1], ldwh);
+
+/* ==== Multiply by U21' ==== */
+
+ strmm_("L", "L", "C", "N", &j2, &jlen, &c_b8, &u[(i2 + 1)
+ * u_dim1 + 1], ldu, &wh[i2 + 1 + wh_dim1], ldwh);
+
+/* ==== Multiply by U22 ==== */
+
+ i__5 = i4 - i2;
+ i__7 = j4 - j2;
+ sgemm_("C", "N", &i__5, &jlen, &i__7, &c_b8, &u[j2 + 1 + (
+ i2 + 1) * u_dim1], ldu, &h__[incol + 1 + j2 +
+ jcol * h_dim1], ldh, &c_b8, &wh[i2 + 1 + wh_dim1],
+ ldwh);
+
+/* ==== Copy it back ==== */
+
+ slacpy_("ALL", &kdu, &jlen, &wh[wh_offset], ldwh, &h__[
+ incol + 1 + jcol * h_dim1], ldh);
+/* L190: */
+ }
+
+/* ==== Vertical multiply ==== */
+
+ i__3 = max(incol,*ktop) - 1;
+ i__4 = *nv;
+ for (jrow = jtop; i__4 < 0 ? jrow >= i__3 : jrow <= i__3;
+ jrow += i__4) {
+/* Computing MIN */
+ i__5 = *nv, i__7 = max(incol,*ktop) - jrow;
+ jlen = min(i__5,i__7);
+
+/* ==== Copy right of H to scratch (the first KZS */
+/* . columns get multiplied by zero) ==== */
+
+ slacpy_("ALL", &jlen, &knz, &h__[jrow + (incol + 1 + j2) *
+ h_dim1], ldh, &wv[(kzs + 1) * wv_dim1 + 1], ldwv);
+
+/* ==== Multiply by U21 ==== */
+
+ slaset_("ALL", &jlen, &kzs, &c_b7, &c_b7, &wv[wv_offset],
+ ldwv);
+ strmm_("R", "U", "N", "N", &jlen, &knz, &c_b8, &u[j2 + 1
+ + (kzs + 1) * u_dim1], ldu, &wv[(kzs + 1) *
+ wv_dim1 + 1], ldwv);
+
+/* ==== Multiply by U11 ==== */
+
+ sgemm_("N", "N", &jlen, &i2, &j2, &c_b8, &h__[jrow + (
+ incol + 1) * h_dim1], ldh, &u[u_offset], ldu, &
+ c_b8, &wv[wv_offset], ldwv);
+
+/* ==== Copy left of H to right of scratch ==== */
+
+ slacpy_("ALL", &jlen, &j2, &h__[jrow + (incol + 1) *
+ h_dim1], ldh, &wv[(i2 + 1) * wv_dim1 + 1], ldwv);
+
+/* ==== Multiply by U21 ==== */
+
+ i__5 = i4 - i2;
+ strmm_("R", "L", "N", "N", &jlen, &i__5, &c_b8, &u[(i2 +
+ 1) * u_dim1 + 1], ldu, &wv[(i2 + 1) * wv_dim1 + 1]
+, ldwv);
+
+/* ==== Multiply by U22 ==== */
+
+ i__5 = i4 - i2;
+ i__7 = j4 - j2;
+ sgemm_("N", "N", &jlen, &i__5, &i__7, &c_b8, &h__[jrow + (
+ incol + 1 + j2) * h_dim1], ldh, &u[j2 + 1 + (i2 +
+ 1) * u_dim1], ldu, &c_b8, &wv[(i2 + 1) * wv_dim1
+ + 1], ldwv);
+
+/* ==== Copy it back ==== */
+
+ slacpy_("ALL", &jlen, &kdu, &wv[wv_offset], ldwv, &h__[
+ jrow + (incol + 1) * h_dim1], ldh);
+/* L200: */
+ }
+
+/* ==== Multiply Z (also vertical) ==== */
+
+ if (*wantz) {
+ i__4 = *ihiz;
+ i__3 = *nv;
+ for (jrow = *iloz; i__3 < 0 ? jrow >= i__4 : jrow <= i__4;
+ jrow += i__3) {
+/* Computing MIN */
+ i__5 = *nv, i__7 = *ihiz - jrow + 1;
+ jlen = min(i__5,i__7);
+
+/* ==== Copy right of Z to left of scratch (first */
+/* . KZS columns get multiplied by zero) ==== */
+
+ slacpy_("ALL", &jlen, &knz, &z__[jrow + (incol + 1 +
+ j2) * z_dim1], ldz, &wv[(kzs + 1) * wv_dim1 +
+ 1], ldwv);
+
+/* ==== Multiply by U12 ==== */
+
+ slaset_("ALL", &jlen, &kzs, &c_b7, &c_b7, &wv[
+ wv_offset], ldwv);
+ strmm_("R", "U", "N", "N", &jlen, &knz, &c_b8, &u[j2
+ + 1 + (kzs + 1) * u_dim1], ldu, &wv[(kzs + 1)
+ * wv_dim1 + 1], ldwv);
+
+/* ==== Multiply by U11 ==== */
+
+ sgemm_("N", "N", &jlen, &i2, &j2, &c_b8, &z__[jrow + (
+ incol + 1) * z_dim1], ldz, &u[u_offset], ldu,
+ &c_b8, &wv[wv_offset], ldwv);
+
+/* ==== Copy left of Z to right of scratch ==== */
+
+ slacpy_("ALL", &jlen, &j2, &z__[jrow + (incol + 1) *
+ z_dim1], ldz, &wv[(i2 + 1) * wv_dim1 + 1],
+ ldwv);
+
+/* ==== Multiply by U21 ==== */
+
+ i__5 = i4 - i2;
+ strmm_("R", "L", "N", "N", &jlen, &i__5, &c_b8, &u[(
+ i2 + 1) * u_dim1 + 1], ldu, &wv[(i2 + 1) *
+ wv_dim1 + 1], ldwv);
+
+/* ==== Multiply by U22 ==== */
+
+ i__5 = i4 - i2;
+ i__7 = j4 - j2;
+ sgemm_("N", "N", &jlen, &i__5, &i__7, &c_b8, &z__[
+ jrow + (incol + 1 + j2) * z_dim1], ldz, &u[j2
+ + 1 + (i2 + 1) * u_dim1], ldu, &c_b8, &wv[(i2
+ + 1) * wv_dim1 + 1], ldwv);
+
+/* ==== Copy the result back to Z ==== */
+
+ slacpy_("ALL", &jlen, &kdu, &wv[wv_offset], ldwv, &
+ z__[jrow + (incol + 1) * z_dim1], ldz);
+/* L210: */
+ }
+ }
+ }
+ }
+/* L220: */
+ }
+
+/* ==== End of SLAQR5 ==== */
+
+ return 0;
+} /* slaqr5_ */
diff --git a/SRC/slaqsb.c b/SRC/slaqsb.c
new file mode 100644
index 0000000..772a959
--- /dev/null
+++ b/SRC/slaqsb.c
@@ -0,0 +1,184 @@
+/* slaqsb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slaqsb_(char *uplo, integer *n, integer *kd, real *ab,
+ integer *ldab, real *s, real *scond, real *amax, char *equed)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j;
+ real cj, large;
+ extern logical lsame_(char *, char *);
+ real small;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAQSB equilibrates a symmetric band matrix A using the scaling */
+/* factors in the vector S. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) REAL array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, if INFO = 0, the triangular factor U or L from the */
+/* Cholesky factorization A = U'*U or A = L*L' of the band */
+/* matrix A, in the same storage format as A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* S (input) REAL array, dimension (N) */
+/* The scale factors for A. */
+
+/* SCOND (input) REAL */
+/* Ratio of the smallest S(i) to the largest S(i). */
+
+/* AMAX (input) REAL */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies whether or not equilibration was done. */
+/* = 'N': No equilibration. */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if scaling should be done */
+/* based on the ratio of the scaling factors. If SCOND < THRESH, */
+/* scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if scaling should */
+/* be done based on the absolute size of the largest matrix element. */
+/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --s;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = slamch_("Safe minimum") / slamch_("Precision");
+ large = 1.f / small;
+
+ if (*scond >= .1f && *amax >= small && *amax <= large) {
+
+/* No equilibration */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Replace A by diag(S) * A * diag(S). */
+
+ if (lsame_(uplo, "U")) {
+
+/* Upper triangle of A is stored in band format. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *kd;
+ i__4 = j;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ ab[*kd + 1 + i__ - j + j * ab_dim1] = cj * s[i__] * ab[*
+ kd + 1 + i__ - j + j * ab_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+
+/* Lower triangle of A is stored. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+/* Computing MIN */
+ i__2 = *n, i__3 = j + *kd;
+ i__4 = min(i__2,i__3);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ ab[i__ + 1 - j + j * ab_dim1] = cj * s[i__] * ab[i__ + 1
+ - j + j * ab_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ *(unsigned char *)equed = 'Y';
+ }
+
+ return 0;
+
+/* End of SLAQSB */
+
+} /* slaqsb_ */
diff --git a/SRC/slaqsp.c b/SRC/slaqsp.c
new file mode 100644
index 0000000..3aed8f7
--- /dev/null
+++ b/SRC/slaqsp.c
@@ -0,0 +1,169 @@
+/* slaqsp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slaqsp_(char *uplo, integer *n, real *ap, real *s, real *
+ scond, real *amax, char *equed)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, jc;
+ real cj, large;
+ extern logical lsame_(char *, char *);
+ real small;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAQSP equilibrates a symmetric matrix A using the scaling factors */
+/* in the vector S. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) REAL array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the equilibrated matrix: diag(S) * A * diag(S), in */
+/* the same storage format as A. */
+
+/* S (input) REAL array, dimension (N) */
+/* The scale factors for A. */
+
+/* SCOND (input) REAL */
+/* Ratio of the smallest S(i) to the largest S(i). */
+
+/* AMAX (input) REAL */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies whether or not equilibration was done. */
+/* = 'N': No equilibration. */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if scaling should be done */
+/* based on the ratio of the scaling factors. If SCOND < THRESH, */
+/* scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if scaling should */
+/* be done based on the absolute size of the largest matrix element. */
+/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --s;
+ --ap;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = slamch_("Safe minimum") / slamch_("Precision");
+ large = 1.f / small;
+
+ if (*scond >= .1f && *amax >= small && *amax <= large) {
+
+/* No equilibration */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Replace A by diag(S) * A * diag(S). */
+
+ if (lsame_(uplo, "U")) {
+
+/* Upper triangle of A is stored. */
+
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ap[jc + i__ - 1] = cj * s[i__] * ap[jc + i__ - 1];
+/* L10: */
+ }
+ jc += j;
+/* L20: */
+ }
+ } else {
+
+/* Lower triangle of A is stored. */
+
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ap[jc + i__ - j] = cj * s[i__] * ap[jc + i__ - j];
+/* L30: */
+ }
+ jc = jc + *n - j + 1;
+/* L40: */
+ }
+ }
+ *(unsigned char *)equed = 'Y';
+ }
+
+ return 0;
+
+/* End of SLAQSP */
+
+} /* slaqsp_ */
diff --git a/SRC/slaqsy.c b/SRC/slaqsy.c
new file mode 100644
index 0000000..6ae4493
--- /dev/null
+++ b/SRC/slaqsy.c
@@ -0,0 +1,172 @@
+/* slaqsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slaqsy_(char *uplo, integer *n, real *a, integer *lda,
+ real *s, real *scond, real *amax, char *equed)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ real cj, large;
+ extern logical lsame_(char *, char *);
+ real small;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAQSY equilibrates a symmetric matrix A using the scaling factors */
+/* in the vector S. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n by n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n by n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if EQUED = 'Y', the equilibrated matrix: */
+/* diag(S) * A * diag(S). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(N,1). */
+
+/* S (input) REAL array, dimension (N) */
+/* The scale factors for A. */
+
+/* SCOND (input) REAL */
+/* Ratio of the smallest S(i) to the largest S(i). */
+
+/* AMAX (input) REAL */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies whether or not equilibration was done. */
+/* = 'N': No equilibration. */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if scaling should be done */
+/* based on the ratio of the scaling factors. If SCOND < THRESH, */
+/* scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if scaling should */
+/* be done based on the absolute size of the largest matrix element. */
+/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = slamch_("Safe minimum") / slamch_("Precision");
+ large = 1.f / small;
+
+ if (*scond >= .1f && *amax >= small && *amax <= large) {
+
+/* No equilibration */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Replace A by diag(S) * A * diag(S). */
+
+ if (lsame_(uplo, "U")) {
+
+/* Upper triangle of A is stored. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = cj * s[i__] * a[i__ + j * a_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+
+/* Lower triangle of A is stored. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = cj * s[i__] * a[i__ + j * a_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ *(unsigned char *)equed = 'Y';
+ }
+
+ return 0;
+
+/* End of SLAQSY */
+
+} /* slaqsy_ */
diff --git a/SRC/slaqtr.c b/SRC/slaqtr.c
new file mode 100644
index 0000000..dd32a08
--- /dev/null
+++ b/SRC/slaqtr.c
@@ -0,0 +1,831 @@
+/* slaqtr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static logical c_false = FALSE_;
+static integer c__2 = 2;
+static real c_b21 = 1.f;
+static real c_b25 = 0.f;
+static logical c_true = TRUE_;
+
+/* Subroutine */ int slaqtr_(logical *ltran, logical *lreal, integer *n, real
+ *t, integer *ldt, real *b, real *w, real *scale, real *x, real *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer t_dim1, t_offset, i__1, i__2;
+ real r__1, r__2, r__3, r__4, r__5, r__6;
+
+ /* Local variables */
+ real d__[4] /* was [2][2] */;
+ integer i__, j, k;
+ real v[4] /* was [2][2] */, z__;
+ integer j1, j2, n1, n2;
+ real si, xj, sr, rec, eps, tjj, tmp;
+ integer ierr;
+ real smin;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ real xmax;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ integer jnext;
+ extern doublereal sasum_(integer *, real *, integer *);
+ real sminw, xnorm;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *), slaln2_(logical *, integer *, integer *, real
+ *, real *, real *, integer *, real *, real *, real *, integer *,
+ real *, real *, real *, integer *, real *, real *, integer *);
+ real scaloc;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ real bignum;
+ extern integer isamax_(integer *, real *, integer *);
+ extern /* Subroutine */ int sladiv_(real *, real *, real *, real *, real *
+, real *);
+ logical notran;
+ real smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAQTR solves the real quasi-triangular system */
+
+/* op(T)*p = scale*c, if LREAL = .TRUE. */
+
+/* or the complex quasi-triangular systems */
+
+/* op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE. */
+
+/* in real arithmetic, where T is upper quasi-triangular. */
+/* If LREAL = .FALSE., then the first diagonal block of T must be */
+/* 1 by 1, B is the specially structured matrix */
+
+/* B = [ b(1) b(2) ... b(n) ] */
+/* [ w ] */
+/* [ w ] */
+/* [ . ] */
+/* [ w ] */
+
+/* op(A) = A or A', A' denotes the conjugate transpose of */
+/* matrix A. */
+
+/* On input, X = [ c ]. On output, X = [ p ]. */
+/* [ d ] [ q ] */
+
+/* This subroutine is designed for the condition number estimation */
+/* in routine STRSNA. */
+
+/* Arguments */
+/* ========= */
+
+/* LTRAN (input) LOGICAL */
+/* On entry, LTRAN specifies the option of conjugate transpose: */
+/* = .FALSE., op(T+i*B) = T+i*B, */
+/* = .TRUE., op(T+i*B) = (T+i*B)'. */
+
+/* LREAL (input) LOGICAL */
+/* On entry, LREAL specifies the input matrix structure: */
+/* = .FALSE., the input is complex */
+/* = .TRUE., the input is real */
+
+/* N (input) INTEGER */
+/* On entry, N specifies the order of T+i*B. N >= 0. */
+
+/* T (input) REAL array, dimension (LDT,N) */
+/* On entry, T contains a matrix in Schur canonical form. */
+/* If LREAL = .FALSE., then the first diagonal block of T must */
+/* be 1 by 1. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the matrix T. LDT >= max(1,N). */
+
+/* B (input) REAL array, dimension (N) */
+/* On entry, B contains the elements to form the matrix */
+/* B as described above. */
+/* If LREAL = .TRUE., B is not referenced. */
+
+/* W (input) REAL */
+/* On entry, W is the diagonal element of the matrix B. */
+/* If LREAL = .TRUE., W is not referenced. */
+
+/* SCALE (output) REAL */
+/* On exit, SCALE is the scale factor. */
+
+/* X (input/output) REAL array, dimension (2*N) */
+/* On entry, X contains the right hand side of the system. */
+/* On exit, X is overwritten by the solution. */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* On exit, INFO is set to */
+/* 0: successful exit. */
+/* 1: the some diagonal 1 by 1 block has been perturbed by */
+/* a small number SMIN to keep nonsingularity. */
+/* 2: the some diagonal 2 by 2 block has been perturbed by */
+/* a small number in SLALN2 to keep nonsingularity. */
+/* NOTE: In the interests of speed, this routine does not */
+/* check the inputs for errors. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Do not test the input parameters for errors */
+
+ /* Parameter adjustments */
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ --b;
+ --x;
+ --work;
+
+ /* Function Body */
+ notran = ! (*ltran);
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Set constants to control overflow */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S") / eps;
+ bignum = 1.f / smlnum;
+
+ xnorm = slange_("M", n, n, &t[t_offset], ldt, d__);
+ if (! (*lreal)) {
+/* Computing MAX */
+ r__1 = xnorm, r__2 = dabs(*w), r__1 = max(r__1,r__2), r__2 = slange_(
+ "M", n, &c__1, &b[1], n, d__);
+ xnorm = dmax(r__1,r__2);
+ }
+/* Computing MAX */
+ r__1 = smlnum, r__2 = eps * xnorm;
+ smin = dmax(r__1,r__2);
+
+/* Compute 1-norm of each column of strictly upper triangular */
+/* part of T to control overflow in triangular solver. */
+
+ work[1] = 0.f;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ work[j] = sasum_(&i__2, &t[j * t_dim1 + 1], &c__1);
+/* L10: */
+ }
+
+ if (! (*lreal)) {
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ work[i__] += (r__1 = b[i__], dabs(r__1));
+/* L20: */
+ }
+ }
+
+ n2 = *n << 1;
+ n1 = *n;
+ if (! (*lreal)) {
+ n1 = n2;
+ }
+ k = isamax_(&n1, &x[1], &c__1);
+ xmax = (r__1 = x[k], dabs(r__1));
+ *scale = 1.f;
+
+ if (xmax > bignum) {
+ *scale = bignum / xmax;
+ sscal_(&n1, scale, &x[1], &c__1);
+ xmax = bignum;
+ }
+
+ if (*lreal) {
+
+ if (notran) {
+
+/* Solve T*p = scale*c */
+
+ jnext = *n;
+ for (j = *n; j >= 1; --j) {
+ if (j > jnext) {
+ goto L30;
+ }
+ j1 = j;
+ j2 = j;
+ jnext = j - 1;
+ if (j > 1) {
+ if (t[j + (j - 1) * t_dim1] != 0.f) {
+ j1 = j - 1;
+ jnext = j - 2;
+ }
+ }
+
+ if (j1 == j2) {
+
+/* Meet 1 by 1 diagonal block */
+
+/* Scale to avoid overflow when computing */
+/* x(j) = b(j)/T(j,j) */
+
+ xj = (r__1 = x[j1], dabs(r__1));
+ tjj = (r__1 = t[j1 + j1 * t_dim1], dabs(r__1));
+ tmp = t[j1 + j1 * t_dim1];
+ if (tjj < smin) {
+ tmp = smin;
+ tjj = smin;
+ *info = 1;
+ }
+
+ if (xj == 0.f) {
+ goto L30;
+ }
+
+ if (tjj < 1.f) {
+ if (xj > bignum * tjj) {
+ rec = 1.f / xj;
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ x[j1] /= tmp;
+ xj = (r__1 = x[j1], dabs(r__1));
+
+/* Scale x if necessary to avoid overflow when adding a */
+/* multiple of column j1 of T. */
+
+ if (xj > 1.f) {
+ rec = 1.f / xj;
+ if (work[j1] > (bignum - xmax) * rec) {
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ }
+ }
+ if (j1 > 1) {
+ i__1 = j1 - 1;
+ r__1 = -x[j1];
+ saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
+, &c__1);
+ i__1 = j1 - 1;
+ k = isamax_(&i__1, &x[1], &c__1);
+ xmax = (r__1 = x[k], dabs(r__1));
+ }
+
+ } else {
+
+/* Meet 2 by 2 diagonal block */
+
+/* Call 2 by 2 linear system solve, to take */
+/* care of possible overflow by scaling factor. */
+
+ d__[0] = x[j1];
+ d__[1] = x[j2];
+ slaln2_(&c_false, &c__2, &c__1, &smin, &c_b21, &t[j1 + j1
+ * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &
+ c_b25, &c_b25, v, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 2;
+ }
+
+ if (scaloc != 1.f) {
+ sscal_(n, &scaloc, &x[1], &c__1);
+ *scale *= scaloc;
+ }
+ x[j1] = v[0];
+ x[j2] = v[1];
+
+/* Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2)) */
+/* to avoid overflow in updating right-hand side. */
+
+/* Computing MAX */
+ r__1 = dabs(v[0]), r__2 = dabs(v[1]);
+ xj = dmax(r__1,r__2);
+ if (xj > 1.f) {
+ rec = 1.f / xj;
+/* Computing MAX */
+ r__1 = work[j1], r__2 = work[j2];
+ if (dmax(r__1,r__2) > (bignum - xmax) * rec) {
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ }
+ }
+
+/* Update right-hand side */
+
+ if (j1 > 1) {
+ i__1 = j1 - 1;
+ r__1 = -x[j1];
+ saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
+, &c__1);
+ i__1 = j1 - 1;
+ r__1 = -x[j2];
+ saxpy_(&i__1, &r__1, &t[j2 * t_dim1 + 1], &c__1, &x[1]
+, &c__1);
+ i__1 = j1 - 1;
+ k = isamax_(&i__1, &x[1], &c__1);
+ xmax = (r__1 = x[k], dabs(r__1));
+ }
+
+ }
+
+L30:
+ ;
+ }
+
+ } else {
+
+/* Solve T'*p = scale*c */
+
+ jnext = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (j < jnext) {
+ goto L40;
+ }
+ j1 = j;
+ j2 = j;
+ jnext = j + 1;
+ if (j < *n) {
+ if (t[j + 1 + j * t_dim1] != 0.f) {
+ j2 = j + 1;
+ jnext = j + 2;
+ }
+ }
+
+ if (j1 == j2) {
+
+/* 1 by 1 diagonal block */
+
+/* Scale if necessary to avoid overflow in forming the */
+/* right-hand side element by inner product. */
+
+ xj = (r__1 = x[j1], dabs(r__1));
+ if (xmax > 1.f) {
+ rec = 1.f / xmax;
+ if (work[j1] > (bignum - xj) * rec) {
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ i__2 = j1 - 1;
+ x[j1] -= sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], &
+ c__1);
+
+ xj = (r__1 = x[j1], dabs(r__1));
+ tjj = (r__1 = t[j1 + j1 * t_dim1], dabs(r__1));
+ tmp = t[j1 + j1 * t_dim1];
+ if (tjj < smin) {
+ tmp = smin;
+ tjj = smin;
+ *info = 1;
+ }
+
+ if (tjj < 1.f) {
+ if (xj > bignum * tjj) {
+ rec = 1.f / xj;
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ x[j1] /= tmp;
+/* Computing MAX */
+ r__2 = xmax, r__3 = (r__1 = x[j1], dabs(r__1));
+ xmax = dmax(r__2,r__3);
+
+ } else {
+
+/* 2 by 2 diagonal block */
+
+/* Scale if necessary to avoid overflow in forming the */
+/* right-hand side elements by inner product. */
+
+/* Computing MAX */
+ r__3 = (r__1 = x[j1], dabs(r__1)), r__4 = (r__2 = x[j2],
+ dabs(r__2));
+ xj = dmax(r__3,r__4);
+ if (xmax > 1.f) {
+ rec = 1.f / xmax;
+/* Computing MAX */
+ r__1 = work[j2], r__2 = work[j1];
+ if (dmax(r__1,r__2) > (bignum - xj) * rec) {
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ i__2 = j1 - 1;
+ d__[0] = x[j1] - sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1,
+ &x[1], &c__1);
+ i__2 = j1 - 1;
+ d__[1] = x[j2] - sdot_(&i__2, &t[j2 * t_dim1 + 1], &c__1,
+ &x[1], &c__1);
+
+ slaln2_(&c_true, &c__2, &c__1, &smin, &c_b21, &t[j1 + j1 *
+ t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &c_b25,
+ &c_b25, v, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 2;
+ }
+
+ if (scaloc != 1.f) {
+ sscal_(n, &scaloc, &x[1], &c__1);
+ *scale *= scaloc;
+ }
+ x[j1] = v[0];
+ x[j2] = v[1];
+/* Computing MAX */
+ r__3 = (r__1 = x[j1], dabs(r__1)), r__4 = (r__2 = x[j2],
+ dabs(r__2)), r__3 = max(r__3,r__4);
+ xmax = dmax(r__3,xmax);
+
+ }
+L40:
+ ;
+ }
+ }
+
+ } else {
+
+/* Computing MAX */
+ r__1 = eps * dabs(*w);
+ sminw = dmax(r__1,smin);
+ if (notran) {
+
+/* Solve (T + iB)*(p+iq) = c+id */
+
+ jnext = *n;
+ for (j = *n; j >= 1; --j) {
+ if (j > jnext) {
+ goto L70;
+ }
+ j1 = j;
+ j2 = j;
+ jnext = j - 1;
+ if (j > 1) {
+ if (t[j + (j - 1) * t_dim1] != 0.f) {
+ j1 = j - 1;
+ jnext = j - 2;
+ }
+ }
+
+ if (j1 == j2) {
+
+/* 1 by 1 diagonal block */
+
+/* Scale if necessary to avoid overflow in division */
+
+ z__ = *w;
+ if (j1 == 1) {
+ z__ = b[1];
+ }
+ xj = (r__1 = x[j1], dabs(r__1)) + (r__2 = x[*n + j1],
+ dabs(r__2));
+ tjj = (r__1 = t[j1 + j1 * t_dim1], dabs(r__1)) + dabs(z__)
+ ;
+ tmp = t[j1 + j1 * t_dim1];
+ if (tjj < sminw) {
+ tmp = sminw;
+ tjj = sminw;
+ *info = 1;
+ }
+
+ if (xj == 0.f) {
+ goto L70;
+ }
+
+ if (tjj < 1.f) {
+ if (xj > bignum * tjj) {
+ rec = 1.f / xj;
+ sscal_(&n2, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ sladiv_(&x[j1], &x[*n + j1], &tmp, &z__, &sr, &si);
+ x[j1] = sr;
+ x[*n + j1] = si;
+ xj = (r__1 = x[j1], dabs(r__1)) + (r__2 = x[*n + j1],
+ dabs(r__2));
+
+/* Scale x if necessary to avoid overflow when adding a */
+/* multiple of column j1 of T. */
+
+ if (xj > 1.f) {
+ rec = 1.f / xj;
+ if (work[j1] > (bignum - xmax) * rec) {
+ sscal_(&n2, &rec, &x[1], &c__1);
+ *scale *= rec;
+ }
+ }
+
+ if (j1 > 1) {
+ i__1 = j1 - 1;
+ r__1 = -x[j1];
+ saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
+, &c__1);
+ i__1 = j1 - 1;
+ r__1 = -x[*n + j1];
+ saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[*
+ n + 1], &c__1);
+
+ x[1] += b[j1] * x[*n + j1];
+ x[*n + 1] -= b[j1] * x[j1];
+
+ xmax = 0.f;
+ i__1 = j1 - 1;
+ for (k = 1; k <= i__1; ++k) {
+/* Computing MAX */
+ r__3 = xmax, r__4 = (r__1 = x[k], dabs(r__1)) + (
+ r__2 = x[k + *n], dabs(r__2));
+ xmax = dmax(r__3,r__4);
+/* L50: */
+ }
+ }
+
+ } else {
+
+/* Meet 2 by 2 diagonal block */
+
+ d__[0] = x[j1];
+ d__[1] = x[j2];
+ d__[2] = x[*n + j1];
+ d__[3] = x[*n + j2];
+ r__1 = -(*w);
+ slaln2_(&c_false, &c__2, &c__2, &sminw, &c_b21, &t[j1 +
+ j1 * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &
+ c_b25, &r__1, v, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 2;
+ }
+
+ if (scaloc != 1.f) {
+ i__1 = *n << 1;
+ sscal_(&i__1, &scaloc, &x[1], &c__1);
+ *scale = scaloc * *scale;
+ }
+ x[j1] = v[0];
+ x[j2] = v[1];
+ x[*n + j1] = v[2];
+ x[*n + j2] = v[3];
+
+/* Scale X(J1), .... to avoid overflow in */
+/* updating right hand side. */
+
+/* Computing MAX */
+ r__1 = dabs(v[0]) + dabs(v[2]), r__2 = dabs(v[1]) + dabs(
+ v[3]);
+ xj = dmax(r__1,r__2);
+ if (xj > 1.f) {
+ rec = 1.f / xj;
+/* Computing MAX */
+ r__1 = work[j1], r__2 = work[j2];
+ if (dmax(r__1,r__2) > (bignum - xmax) * rec) {
+ sscal_(&n2, &rec, &x[1], &c__1);
+ *scale *= rec;
+ }
+ }
+
+/* Update the right-hand side. */
+
+ if (j1 > 1) {
+ i__1 = j1 - 1;
+ r__1 = -x[j1];
+ saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
+, &c__1);
+ i__1 = j1 - 1;
+ r__1 = -x[j2];
+ saxpy_(&i__1, &r__1, &t[j2 * t_dim1 + 1], &c__1, &x[1]
+, &c__1);
+
+ i__1 = j1 - 1;
+ r__1 = -x[*n + j1];
+ saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[*
+ n + 1], &c__1);
+ i__1 = j1 - 1;
+ r__1 = -x[*n + j2];
+ saxpy_(&i__1, &r__1, &t[j2 * t_dim1 + 1], &c__1, &x[*
+ n + 1], &c__1);
+
+ x[1] = x[1] + b[j1] * x[*n + j1] + b[j2] * x[*n + j2];
+ x[*n + 1] = x[*n + 1] - b[j1] * x[j1] - b[j2] * x[j2];
+
+ xmax = 0.f;
+ i__1 = j1 - 1;
+ for (k = 1; k <= i__1; ++k) {
+/* Computing MAX */
+ r__3 = (r__1 = x[k], dabs(r__1)) + (r__2 = x[k + *
+ n], dabs(r__2));
+ xmax = dmax(r__3,xmax);
+/* L60: */
+ }
+ }
+
+ }
+L70:
+ ;
+ }
+
+ } else {
+
+/* Solve (T + iB)'*(p+iq) = c+id */
+
+ jnext = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (j < jnext) {
+ goto L80;
+ }
+ j1 = j;
+ j2 = j;
+ jnext = j + 1;
+ if (j < *n) {
+ if (t[j + 1 + j * t_dim1] != 0.f) {
+ j2 = j + 1;
+ jnext = j + 2;
+ }
+ }
+
+ if (j1 == j2) {
+
+/* 1 by 1 diagonal block */
+
+/* Scale if necessary to avoid overflow in forming the */
+/* right-hand side element by inner product. */
+
+ xj = (r__1 = x[j1], dabs(r__1)) + (r__2 = x[j1 + *n],
+ dabs(r__2));
+ if (xmax > 1.f) {
+ rec = 1.f / xmax;
+ if (work[j1] > (bignum - xj) * rec) {
+ sscal_(&n2, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ i__2 = j1 - 1;
+ x[j1] -= sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], &
+ c__1);
+ i__2 = j1 - 1;
+ x[*n + j1] -= sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[
+ *n + 1], &c__1);
+ if (j1 > 1) {
+ x[j1] -= b[j1] * x[*n + 1];
+ x[*n + j1] += b[j1] * x[1];
+ }
+ xj = (r__1 = x[j1], dabs(r__1)) + (r__2 = x[j1 + *n],
+ dabs(r__2));
+
+ z__ = *w;
+ if (j1 == 1) {
+ z__ = b[1];
+ }
+
+/* Scale if necessary to avoid overflow in */
+/* complex division */
+
+ tjj = (r__1 = t[j1 + j1 * t_dim1], dabs(r__1)) + dabs(z__)
+ ;
+ tmp = t[j1 + j1 * t_dim1];
+ if (tjj < sminw) {
+ tmp = sminw;
+ tjj = sminw;
+ *info = 1;
+ }
+
+ if (tjj < 1.f) {
+ if (xj > bignum * tjj) {
+ rec = 1.f / xj;
+ sscal_(&n2, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ r__1 = -z__;
+ sladiv_(&x[j1], &x[*n + j1], &tmp, &r__1, &sr, &si);
+ x[j1] = sr;
+ x[j1 + *n] = si;
+/* Computing MAX */
+ r__3 = (r__1 = x[j1], dabs(r__1)) + (r__2 = x[j1 + *n],
+ dabs(r__2));
+ xmax = dmax(r__3,xmax);
+
+ } else {
+
+/* 2 by 2 diagonal block */
+
+/* Scale if necessary to avoid overflow in forming the */
+/* right-hand side element by inner product. */
+
+/* Computing MAX */
+ r__5 = (r__1 = x[j1], dabs(r__1)) + (r__2 = x[*n + j1],
+ dabs(r__2)), r__6 = (r__3 = x[j2], dabs(r__3)) + (
+ r__4 = x[*n + j2], dabs(r__4));
+ xj = dmax(r__5,r__6);
+ if (xmax > 1.f) {
+ rec = 1.f / xmax;
+/* Computing MAX */
+ r__1 = work[j1], r__2 = work[j2];
+ if (dmax(r__1,r__2) > (bignum - xj) / xmax) {
+ sscal_(&n2, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ i__2 = j1 - 1;
+ d__[0] = x[j1] - sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1,
+ &x[1], &c__1);
+ i__2 = j1 - 1;
+ d__[1] = x[j2] - sdot_(&i__2, &t[j2 * t_dim1 + 1], &c__1,
+ &x[1], &c__1);
+ i__2 = j1 - 1;
+ d__[2] = x[*n + j1] - sdot_(&i__2, &t[j1 * t_dim1 + 1], &
+ c__1, &x[*n + 1], &c__1);
+ i__2 = j1 - 1;
+ d__[3] = x[*n + j2] - sdot_(&i__2, &t[j2 * t_dim1 + 1], &
+ c__1, &x[*n + 1], &c__1);
+ d__[0] -= b[j1] * x[*n + 1];
+ d__[1] -= b[j2] * x[*n + 1];
+ d__[2] += b[j1] * x[1];
+ d__[3] += b[j2] * x[1];
+
+ slaln2_(&c_true, &c__2, &c__2, &sminw, &c_b21, &t[j1 + j1
+ * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &
+ c_b25, w, v, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 2;
+ }
+
+ if (scaloc != 1.f) {
+ sscal_(&n2, &scaloc, &x[1], &c__1);
+ *scale = scaloc * *scale;
+ }
+ x[j1] = v[0];
+ x[j2] = v[1];
+ x[*n + j1] = v[2];
+ x[*n + j2] = v[3];
+/* Computing MAX */
+ r__5 = (r__1 = x[j1], dabs(r__1)) + (r__2 = x[*n + j1],
+ dabs(r__2)), r__6 = (r__3 = x[j2], dabs(r__3)) + (
+ r__4 = x[*n + j2], dabs(r__4)), r__5 = max(r__5,
+ r__6);
+ xmax = dmax(r__5,xmax);
+
+ }
+
+L80:
+ ;
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of SLAQTR */
+
+} /* slaqtr_ */
diff --git a/SRC/slar1v.c b/SRC/slar1v.c
new file mode 100644
index 0000000..59de901
--- /dev/null
+++ b/SRC/slar1v.c
@@ -0,0 +1,440 @@
+/* slar1v.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slar1v_(integer *n, integer *b1, integer *bn, real *
+ lambda, real *d__, real *l, real *ld, real *lld, real *pivmin, real *
+ gaptol, real *z__, logical *wantnc, integer *negcnt, real *ztz, real *
+ mingma, integer *r__, integer *isuppz, real *nrminv, real *resid,
+ real *rqcorr, real *work)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real s;
+ integer r1, r2;
+ real eps, tmp;
+ integer neg1, neg2, indp, inds;
+ real dplus;
+ extern doublereal slamch_(char *);
+ integer indlpl, indumn;
+ extern logical sisnan_(real *);
+ real dminus;
+ logical sawnan1, sawnan2;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAR1V computes the (scaled) r-th column of the inverse of */
+/* the sumbmatrix in rows B1 through BN of the tridiagonal matrix */
+/* L D L^T - sigma I. When sigma is close to an eigenvalue, the */
+/* computed vector is an accurate eigenvector. Usually, r corresponds */
+/* to the index where the eigenvector is largest in magnitude. */
+/* The following steps accomplish this computation : */
+/* (a) Stationary qd transform, L D L^T - sigma I = L(+) D(+) L(+)^T, */
+/* (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T, */
+/* (c) Computation of the diagonal elements of the inverse of */
+/* L D L^T - sigma I by combining the above transforms, and choosing */
+/* r as the index where the diagonal of the inverse is (one of the) */
+/* largest in magnitude. */
+/* (d) Computation of the (scaled) r-th column of the inverse using the */
+/* twisted factorization obtained by combining the top part of the */
+/* the stationary and the bottom part of the progressive transform. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix L D L^T. */
+
+/* B1 (input) INTEGER */
+/* First index of the submatrix of L D L^T. */
+
+/* BN (input) INTEGER */
+/* Last index of the submatrix of L D L^T. */
+
+/* LAMBDA (input) REAL */
+/* The shift. In order to compute an accurate eigenvector, */
+/* LAMBDA should be a good approximation to an eigenvalue */
+/* of L D L^T. */
+
+/* L (input) REAL array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the unit bidiagonal matrix */
+/* L, in elements 1 to N-1. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the diagonal matrix D. */
+
+/* LD (input) REAL array, dimension (N-1) */
+/* The n-1 elements L(i)*D(i). */
+
+/* LLD (input) REAL array, dimension (N-1) */
+/* The n-1 elements L(i)*L(i)*D(i). */
+
+/* PIVMIN (input) REAL */
+/* The minimum pivot in the Sturm sequence. */
+
+/* GAPTOL (input) REAL */
+/* Tolerance that indicates when eigenvector entries are negligible */
+/* w.r.t. their contribution to the residual. */
+
+/* Z (input/output) REAL array, dimension (N) */
+/* On input, all entries of Z must be set to 0. */
+/* On output, Z contains the (scaled) r-th column of the */
+/* inverse. The scaling is such that Z(R) equals 1. */
+
+/* WANTNC (input) LOGICAL */
+/* Specifies whether NEGCNT has to be computed. */
+
+/* NEGCNT (output) INTEGER */
+/* If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin */
+/* in the matrix factorization L D L^T, and NEGCNT = -1 otherwise. */
+
+/* ZTZ (output) REAL */
+/* The square of the 2-norm of Z. */
+
+/* MINGMA (output) REAL */
+/* The reciprocal of the largest (in magnitude) diagonal */
+/* element of the inverse of L D L^T - sigma I. */
+
+/* R (input/output) INTEGER */
+/* The twist index for the twisted factorization used to */
+/* compute Z. */
+/* On input, 0 <= R <= N. If R is input as 0, R is set to */
+/* the index where (L D L^T - sigma I)^{-1} is largest */
+/* in magnitude. If 1 <= R <= N, R is unchanged. */
+/* On output, R contains the twist index used to compute Z. */
+/* Ideally, R designates the position of the maximum entry in the */
+/* eigenvector. */
+
+/* ISUPPZ (output) INTEGER array, dimension (2) */
+/* The support of the vector in Z, i.e., the vector Z is */
+/* nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ). */
+
+/* NRMINV (output) REAL */
+/* NRMINV = 1/SQRT( ZTZ ) */
+
+/* RESID (output) REAL */
+/* The residual of the FP vector. */
+/* RESID = ABS( MINGMA )/SQRT( ZTZ ) */
+
+/* RQCORR (output) REAL */
+/* The Rayleigh Quotient correction to LAMBDA. */
+/* RQCORR = MINGMA*TMP */
+
+/* WORK (workspace) REAL array, dimension (4*N) */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --isuppz;
+ --z__;
+ --lld;
+ --ld;
+ --l;
+ --d__;
+
+ /* Function Body */
+ eps = slamch_("Precision");
+ if (*r__ == 0) {
+ r1 = *b1;
+ r2 = *bn;
+ } else {
+ r1 = *r__;
+ r2 = *r__;
+ }
+/* Storage for LPLUS */
+ indlpl = 0;
+/* Storage for UMINUS */
+ indumn = *n;
+ inds = (*n << 1) + 1;
+ indp = *n * 3 + 1;
+ if (*b1 == 1) {
+ work[inds] = 0.f;
+ } else {
+ work[inds + *b1 - 1] = lld[*b1 - 1];
+ }
+
+/* Compute the stationary transform (using the differential form) */
+/* until the index R2. */
+
+ sawnan1 = FALSE_;
+ neg1 = 0;
+ s = work[inds + *b1 - 1] - *lambda;
+ i__1 = r1 - 1;
+ for (i__ = *b1; i__ <= i__1; ++i__) {
+ dplus = d__[i__] + s;
+ work[indlpl + i__] = ld[i__] / dplus;
+ if (dplus < 0.f) {
+ ++neg1;
+ }
+ work[inds + i__] = s * work[indlpl + i__] * l[i__];
+ s = work[inds + i__] - *lambda;
+/* L50: */
+ }
+ sawnan1 = sisnan_(&s);
+ if (sawnan1) {
+ goto L60;
+ }
+ i__1 = r2 - 1;
+ for (i__ = r1; i__ <= i__1; ++i__) {
+ dplus = d__[i__] + s;
+ work[indlpl + i__] = ld[i__] / dplus;
+ work[inds + i__] = s * work[indlpl + i__] * l[i__];
+ s = work[inds + i__] - *lambda;
+/* L51: */
+ }
+ sawnan1 = sisnan_(&s);
+
+L60:
+ if (sawnan1) {
+/* Runs a slower version of the above loop if a NaN is detected */
+ neg1 = 0;
+ s = work[inds + *b1 - 1] - *lambda;
+ i__1 = r1 - 1;
+ for (i__ = *b1; i__ <= i__1; ++i__) {
+ dplus = d__[i__] + s;
+ if (dabs(dplus) < *pivmin) {
+ dplus = -(*pivmin);
+ }
+ work[indlpl + i__] = ld[i__] / dplus;
+ if (dplus < 0.f) {
+ ++neg1;
+ }
+ work[inds + i__] = s * work[indlpl + i__] * l[i__];
+ if (work[indlpl + i__] == 0.f) {
+ work[inds + i__] = lld[i__];
+ }
+ s = work[inds + i__] - *lambda;
+/* L70: */
+ }
+ i__1 = r2 - 1;
+ for (i__ = r1; i__ <= i__1; ++i__) {
+ dplus = d__[i__] + s;
+ if (dabs(dplus) < *pivmin) {
+ dplus = -(*pivmin);
+ }
+ work[indlpl + i__] = ld[i__] / dplus;
+ work[inds + i__] = s * work[indlpl + i__] * l[i__];
+ if (work[indlpl + i__] == 0.f) {
+ work[inds + i__] = lld[i__];
+ }
+ s = work[inds + i__] - *lambda;
+/* L71: */
+ }
+ }
+
+/* Compute the progressive transform (using the differential form) */
+/* until the index R1 */
+
+ sawnan2 = FALSE_;
+ neg2 = 0;
+ work[indp + *bn - 1] = d__[*bn] - *lambda;
+ i__1 = r1;
+ for (i__ = *bn - 1; i__ >= i__1; --i__) {
+ dminus = lld[i__] + work[indp + i__];
+ tmp = d__[i__] / dminus;
+ if (dminus < 0.f) {
+ ++neg2;
+ }
+ work[indumn + i__] = l[i__] * tmp;
+ work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda;
+/* L80: */
+ }
+ tmp = work[indp + r1 - 1];
+ sawnan2 = sisnan_(&tmp);
+ if (sawnan2) {
+/* Runs a slower version of the above loop if a NaN is detected */
+ neg2 = 0;
+ i__1 = r1;
+ for (i__ = *bn - 1; i__ >= i__1; --i__) {
+ dminus = lld[i__] + work[indp + i__];
+ if (dabs(dminus) < *pivmin) {
+ dminus = -(*pivmin);
+ }
+ tmp = d__[i__] / dminus;
+ if (dminus < 0.f) {
+ ++neg2;
+ }
+ work[indumn + i__] = l[i__] * tmp;
+ work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda;
+ if (tmp == 0.f) {
+ work[indp + i__ - 1] = d__[i__] - *lambda;
+ }
+/* L100: */
+ }
+ }
+
+/* Find the index (from R1 to R2) of the largest (in magnitude) */
+/* diagonal element of the inverse */
+
+ *mingma = work[inds + r1 - 1] + work[indp + r1 - 1];
+ if (*mingma < 0.f) {
+ ++neg1;
+ }
+ if (*wantnc) {
+ *negcnt = neg1 + neg2;
+ } else {
+ *negcnt = -1;
+ }
+ if (dabs(*mingma) == 0.f) {
+ *mingma = eps * work[inds + r1 - 1];
+ }
+ *r__ = r1;
+ i__1 = r2 - 1;
+ for (i__ = r1; i__ <= i__1; ++i__) {
+ tmp = work[inds + i__] + work[indp + i__];
+ if (tmp == 0.f) {
+ tmp = eps * work[inds + i__];
+ }
+ if (dabs(tmp) <= dabs(*mingma)) {
+ *mingma = tmp;
+ *r__ = i__ + 1;
+ }
+/* L110: */
+ }
+
+/* Compute the FP vector: solve N^T v = e_r */
+
+ isuppz[1] = *b1;
+ isuppz[2] = *bn;
+ z__[*r__] = 1.f;
+ *ztz = 1.f;
+
+/* Compute the FP vector upwards from R */
+
+ if (! sawnan1 && ! sawnan2) {
+ i__1 = *b1;
+ for (i__ = *r__ - 1; i__ >= i__1; --i__) {
+ z__[i__] = -(work[indlpl + i__] * z__[i__ + 1]);
+ if (((r__1 = z__[i__], dabs(r__1)) + (r__2 = z__[i__ + 1], dabs(
+ r__2))) * (r__3 = ld[i__], dabs(r__3)) < *gaptol) {
+ z__[i__] = 0.f;
+ isuppz[1] = i__ + 1;
+ goto L220;
+ }
+ *ztz += z__[i__] * z__[i__];
+/* L210: */
+ }
+L220:
+ ;
+ } else {
+/* Run slower loop if NaN occurred. */
+ i__1 = *b1;
+ for (i__ = *r__ - 1; i__ >= i__1; --i__) {
+ if (z__[i__ + 1] == 0.f) {
+ z__[i__] = -(ld[i__ + 1] / ld[i__]) * z__[i__ + 2];
+ } else {
+ z__[i__] = -(work[indlpl + i__] * z__[i__ + 1]);
+ }
+ if (((r__1 = z__[i__], dabs(r__1)) + (r__2 = z__[i__ + 1], dabs(
+ r__2))) * (r__3 = ld[i__], dabs(r__3)) < *gaptol) {
+ z__[i__] = 0.f;
+ isuppz[1] = i__ + 1;
+ goto L240;
+ }
+ *ztz += z__[i__] * z__[i__];
+/* L230: */
+ }
+L240:
+ ;
+ }
+/* Compute the FP vector downwards from R in blocks of size BLKSIZ */
+ if (! sawnan1 && ! sawnan2) {
+ i__1 = *bn - 1;
+ for (i__ = *r__; i__ <= i__1; ++i__) {
+ z__[i__ + 1] = -(work[indumn + i__] * z__[i__]);
+ if (((r__1 = z__[i__], dabs(r__1)) + (r__2 = z__[i__ + 1], dabs(
+ r__2))) * (r__3 = ld[i__], dabs(r__3)) < *gaptol) {
+ z__[i__ + 1] = 0.f;
+ isuppz[2] = i__;
+ goto L260;
+ }
+ *ztz += z__[i__ + 1] * z__[i__ + 1];
+/* L250: */
+ }
+L260:
+ ;
+ } else {
+/* Run slower loop if NaN occurred. */
+ i__1 = *bn - 1;
+ for (i__ = *r__; i__ <= i__1; ++i__) {
+ if (z__[i__] == 0.f) {
+ z__[i__ + 1] = -(ld[i__ - 1] / ld[i__]) * z__[i__ - 1];
+ } else {
+ z__[i__ + 1] = -(work[indumn + i__] * z__[i__]);
+ }
+ if (((r__1 = z__[i__], dabs(r__1)) + (r__2 = z__[i__ + 1], dabs(
+ r__2))) * (r__3 = ld[i__], dabs(r__3)) < *gaptol) {
+ z__[i__ + 1] = 0.f;
+ isuppz[2] = i__;
+ goto L280;
+ }
+ *ztz += z__[i__ + 1] * z__[i__ + 1];
+/* L270: */
+ }
+L280:
+ ;
+ }
+
+/* Compute quantities for convergence test */
+
+ tmp = 1.f / *ztz;
+ *nrminv = sqrt(tmp);
+ *resid = dabs(*mingma) * *nrminv;
+ *rqcorr = *mingma * tmp;
+
+
+ return 0;
+
+/* End of SLAR1V */
+
+} /* slar1v_ */
diff --git a/SRC/slar2v.c b/SRC/slar2v.c
new file mode 100644
index 0000000..ab6a104
--- /dev/null
+++ b/SRC/slar2v.c
@@ -0,0 +1,120 @@
+/* slar2v.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slar2v_(integer *n, real *x, real *y, real *z__, integer
+ *incx, real *c__, real *s, integer *incc)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__;
+ real t1, t2, t3, t4, t5, t6;
+ integer ic;
+ real ci, si;
+ integer ix;
+ real xi, yi, zi;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAR2V applies a vector of real plane rotations from both sides to */
+/* a sequence of 2-by-2 real symmetric matrices, defined by the elements */
+/* of the vectors x, y and z. For i = 1,2,...,n */
+
+/* ( x(i) z(i) ) := ( c(i) s(i) ) ( x(i) z(i) ) ( c(i) -s(i) ) */
+/* ( z(i) y(i) ) ( -s(i) c(i) ) ( z(i) y(i) ) ( s(i) c(i) ) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of plane rotations to be applied. */
+
+/* X (input/output) REAL array, */
+/* dimension (1+(N-1)*INCX) */
+/* The vector x. */
+
+/* Y (input/output) REAL array, */
+/* dimension (1+(N-1)*INCX) */
+/* The vector y. */
+
+/* Z (input/output) REAL array, */
+/* dimension (1+(N-1)*INCX) */
+/* The vector z. */
+
+/* INCX (input) INTEGER */
+/* The increment between elements of X, Y and Z. INCX > 0. */
+
+/* C (input) REAL array, dimension (1+(N-1)*INCC) */
+/* The cosines of the plane rotations. */
+
+/* S (input) REAL array, dimension (1+(N-1)*INCC) */
+/* The sines of the plane rotations. */
+
+/* INCC (input) INTEGER */
+/* The increment between elements of C and S. INCC > 0. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --s;
+ --c__;
+ --z__;
+ --y;
+ --x;
+
+ /* Function Body */
+ ix = 1;
+ ic = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xi = x[ix];
+ yi = y[ix];
+ zi = z__[ix];
+ ci = c__[ic];
+ si = s[ic];
+ t1 = si * zi;
+ t2 = ci * zi;
+ t3 = t2 - si * xi;
+ t4 = t2 + si * yi;
+ t5 = ci * xi + t1;
+ t6 = ci * yi - t1;
+ x[ix] = ci * t5 + si * t4;
+ y[ix] = ci * t6 - si * t3;
+ z__[ix] = ci * t4 - si * t5;
+ ix += *incx;
+ ic += *incc;
+/* L10: */
+ }
+
+/* End of SLAR2V */
+
+ return 0;
+} /* slar2v_ */
diff --git a/SRC/slarf.c b/SRC/slarf.c
new file mode 100644
index 0000000..dbef082
--- /dev/null
+++ b/SRC/slarf.c
@@ -0,0 +1,191 @@
+/* slarf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b4 = 1.f;
+static real c_b5 = 0.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int slarf_(char *side, integer *m, integer *n, real *v,
+ integer *incv, real *tau, real *c__, integer *ldc, real *work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset;
+ real r__1;
+
+ /* Local variables */
+ integer i__;
+ logical applyleft;
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ extern logical lsame_(char *, char *);
+ integer lastc;
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ integer lastv;
+ extern integer ilaslc_(integer *, integer *, real *, integer *), ilaslr_(
+ integer *, integer *, real *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARF applies a real elementary reflector H to a real m by n matrix */
+/* C, from either the left or the right. H is represented in the form */
+
+/* H = I - tau * v * v' */
+
+/* where tau is a real scalar and v is a real vector. */
+
+/* If tau = 0, then H is taken to be the unit matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': form H * C */
+/* = 'R': form C * H */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* V (input) REAL array, dimension */
+/* (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
+/* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
+/* The vector v in the representation of H. V is not used if */
+/* TAU = 0. */
+
+/* INCV (input) INTEGER */
+/* The increment between elements of v. INCV <> 0. */
+
+/* TAU (input) REAL */
+/* The value tau in the representation of H. */
+
+/* C (input/output) REAL array, dimension (LDC,N) */
+/* On entry, the m by n matrix C. */
+/* On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
+/* or C * H if SIDE = 'R'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) REAL array, dimension */
+/* (N) if SIDE = 'L' */
+/* or (M) if SIDE = 'R' */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ applyleft = lsame_(side, "L");
+ lastv = 0;
+ lastc = 0;
+ if (*tau != 0.f) {
+/* Set up variables for scanning V. LASTV begins pointing to the end */
+/* of V. */
+ if (applyleft) {
+ lastv = *m;
+ } else {
+ lastv = *n;
+ }
+ if (*incv > 0) {
+ i__ = (lastv - 1) * *incv + 1;
+ } else {
+ i__ = 1;
+ }
+/* Look for the last non-zero row in V. */
+ while(lastv > 0 && v[i__] == 0.f) {
+ --lastv;
+ i__ -= *incv;
+ }
+ if (applyleft) {
+/* Scan for the last non-zero column in C(1:lastv,:). */
+ lastc = ilaslc_(&lastv, n, &c__[c_offset], ldc);
+ } else {
+/* Scan for the last non-zero row in C(:,1:lastv). */
+ lastc = ilaslr_(m, &lastv, &c__[c_offset], ldc);
+ }
+ }
+/* Note that lastc.eq.0 renders the BLAS operations null; no special */
+/* case is needed at this level. */
+ if (applyleft) {
+
+/* Form H * C */
+
+ if (lastv > 0) {
+
+/* w(1:lastc,1) := C(1:lastv,1:lastc)' * v(1:lastv,1) */
+
+ sgemv_("Transpose", &lastv, &lastc, &c_b4, &c__[c_offset], ldc, &
+ v[1], incv, &c_b5, &work[1], &c__1);
+
+/* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)' */
+
+ r__1 = -(*tau);
+ sger_(&lastv, &lastc, &r__1, &v[1], incv, &work[1], &c__1, &c__[
+ c_offset], ldc);
+ }
+ } else {
+
+/* Form C * H */
+
+ if (lastv > 0) {
+
+/* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) */
+
+ sgemv_("No transpose", &lastc, &lastv, &c_b4, &c__[c_offset], ldc,
+ &v[1], incv, &c_b5, &work[1], &c__1);
+
+/* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)' */
+
+ r__1 = -(*tau);
+ sger_(&lastc, &lastv, &r__1, &work[1], &c__1, &v[1], incv, &c__[
+ c_offset], ldc);
+ }
+ }
+ return 0;
+
+/* End of SLARF */
+
+} /* slarf_ */
diff --git a/SRC/slarfb.c b/SRC/slarfb.c
new file mode 100644
index 0000000..3c8030a
--- /dev/null
+++ b/SRC/slarfb.c
@@ -0,0 +1,773 @@
+/* slarfb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b14 = 1.f;
+static real c_b25 = -1.f;
+
+/* Subroutine */ int slarfb_(char *side, char *trans, char *direct, char *
+ storev, integer *m, integer *n, integer *k, real *v, integer *ldv,
+ real *t, integer *ldt, real *c__, integer *ldc, real *work, integer *
+ ldwork)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1,
+ work_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ extern logical lsame_(char *, char *);
+ integer lastc;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ integer lastv;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), strmm_(char *, char *, char *, char *, integer *,
+ integer *, real *, real *, integer *, real *, integer *);
+ extern integer ilaslc_(integer *, integer *, real *, integer *), ilaslr_(
+ integer *, integer *, real *, integer *);
+ char transt[1];
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARFB applies a real block reflector H or its transpose H' to a */
+/* real m by n matrix C, from either the left or the right. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply H or H' from the Left */
+/* = 'R': apply H or H' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply H (No transpose) */
+/* = 'T': apply H' (Transpose) */
+
+/* DIRECT (input) CHARACTER*1 */
+/* Indicates how H is formed from a product of elementary */
+/* reflectors */
+/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */
+/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
+
+/* STOREV (input) CHARACTER*1 */
+/* Indicates how the vectors which define the elementary */
+/* reflectors are stored: */
+/* = 'C': Columnwise */
+/* = 'R': Rowwise */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* K (input) INTEGER */
+/* The order of the matrix T (= the number of elementary */
+/* reflectors whose product defines the block reflector). */
+
+/* V (input) REAL array, dimension */
+/* (LDV,K) if STOREV = 'C' */
+/* (LDV,M) if STOREV = 'R' and SIDE = 'L' */
+/* (LDV,N) if STOREV = 'R' and SIDE = 'R' */
+/* The matrix V. See further details. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. */
+/* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); */
+/* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); */
+/* if STOREV = 'R', LDV >= K. */
+
+/* T (input) REAL array, dimension (LDT,K) */
+/* The triangular k by k matrix T in the representation of the */
+/* block reflector. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= K. */
+
+/* C (input/output) REAL array, dimension (LDC,N) */
+/* On entry, the m by n matrix C. */
+/* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDA >= max(1,M). */
+
+/* WORK (workspace) REAL array, dimension (LDWORK,K) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. */
+/* If SIDE = 'L', LDWORK >= max(1,N); */
+/* if SIDE = 'R', LDWORK >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+ if (lsame_(trans, "N")) {
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+ if (lsame_(storev, "C")) {
+
+ if (lsame_(direct, "F")) {
+
+/* Let V = ( V1 ) (first K rows) */
+/* ( V2 ) */
+/* where V1 is unit lower triangular. */
+
+ if (lsame_(side, "L")) {
+
+/* Form H * C or H' * C where C = ( C1 ) */
+/* ( C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilaslr_(m, k, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilaslc_(&lastv, n, &c__[c_offset], ldc);
+
+/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */
+
+/* W := C1' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1
+ + 1], &c__1);
+/* L10: */
+ }
+
+/* W := W * V1 */
+
+ strmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
+ c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C2'*V2 */
+
+ i__1 = lastv - *k;
+ sgemm_("Transpose", "No transpose", &lastc, k, &i__1, &
+ c_b14, &c__[*k + 1 + c_dim1], ldc, &v[*k + 1 +
+ v_dim1], ldv, &c_b14, &work[work_offset], ldwork);
+ }
+
+/* W := W * T' or W * T */
+
+ strmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &
+ c_b14, &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - V * W' */
+
+ if (lastv > *k) {
+
+/* C2 := C2 - V2 * W' */
+
+ i__1 = lastv - *k;
+ sgemm_("No transpose", "Transpose", &i__1, &lastc, k, &
+ c_b25, &v[*k + 1 + v_dim1], ldv, &work[
+ work_offset], ldwork, &c_b14, &c__[*k + 1 +
+ c_dim1], ldc);
+ }
+
+/* W := W * V1' */
+
+ strmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &
+ c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+
+/* C1 := C1 - W' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1];
+/* L20: */
+ }
+/* L30: */
+ }
+
+ } else if (lsame_(side, "R")) {
+
+/* Form C * H or C * H' where C = ( C1 C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilaslr_(n, k, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilaslr_(m, &lastv, &c__[c_offset], ldc);
+
+/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */
+
+/* W := C1 */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j *
+ work_dim1 + 1], &c__1);
+/* L40: */
+ }
+
+/* W := W * V1 */
+
+ strmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
+ c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C2 * V2 */
+
+ i__1 = lastv - *k;
+ sgemm_("No transpose", "No transpose", &lastc, k, &i__1, &
+ c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k +
+ 1 + v_dim1], ldv, &c_b14, &work[work_offset],
+ ldwork);
+ }
+
+/* W := W * T or W * T' */
+
+ strmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b14,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - W * V' */
+
+ if (lastv > *k) {
+
+/* C2 := C2 - W * V2' */
+
+ i__1 = lastv - *k;
+ sgemm_("No transpose", "Transpose", &lastc, &i__1, k, &
+ c_b25, &work[work_offset], ldwork, &v[*k + 1 +
+ v_dim1], ldv, &c_b14, &c__[(*k + 1) * c_dim1 + 1],
+ ldc);
+ }
+
+/* W := W * V1' */
+
+ strmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &
+ c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+
+/* C1 := C1 - W */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+
+ } else {
+
+/* Let V = ( V1 ) */
+/* ( V2 ) (last K rows) */
+/* where V2 is unit upper triangular. */
+
+ if (lsame_(side, "L")) {
+
+/* Form H * C or H' * C where C = ( C1 ) */
+/* ( C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilaslr_(m, k, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilaslc_(&lastv, n, &c__[c_offset], ldc);
+
+/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */
+
+/* W := C2' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[
+ j * work_dim1 + 1], &c__1);
+/* L70: */
+ }
+
+/* W := W * V2 */
+
+ strmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
+ c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[
+ work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C1'*V1 */
+
+ i__1 = lastv - *k;
+ sgemm_("Transpose", "No transpose", &lastc, k, &i__1, &
+ c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &
+ c_b14, &work[work_offset], ldwork);
+ }
+
+/* W := W * T' or W * T */
+
+ strmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &
+ c_b14, &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - V * W' */
+
+ if (lastv > *k) {
+
+/* C1 := C1 - V1 * W' */
+
+ i__1 = lastv - *k;
+ sgemm_("No transpose", "Transpose", &i__1, &lastc, k, &
+ c_b25, &v[v_offset], ldv, &work[work_offset],
+ ldwork, &c_b14, &c__[c_offset], ldc);
+ }
+
+/* W := W * V2' */
+
+ strmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &
+ c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[
+ work_offset], ldwork);
+
+/* C2 := C2 - W' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[lastv - *k + j + i__ * c_dim1] -= work[i__ + j *
+ work_dim1];
+/* L80: */
+ }
+/* L90: */
+ }
+
+ } else if (lsame_(side, "R")) {
+
+/* Form C * H or C * H' where C = ( C1 C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilaslr_(n, k, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilaslr_(m, &lastv, &c__[c_offset], ldc);
+
+/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */
+
+/* W := C2 */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(&lastc, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &
+ work[j * work_dim1 + 1], &c__1);
+/* L100: */
+ }
+
+/* W := W * V2 */
+
+ strmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
+ c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[
+ work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C1 * V1 */
+
+ i__1 = lastv - *k;
+ sgemm_("No transpose", "No transpose", &lastc, k, &i__1, &
+ c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &
+ c_b14, &work[work_offset], ldwork);
+ }
+
+/* W := W * T or W * T' */
+
+ strmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b14,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - W * V' */
+
+ if (lastv > *k) {
+
+/* C1 := C1 - W * V1' */
+
+ i__1 = lastv - *k;
+ sgemm_("No transpose", "Transpose", &lastc, &i__1, k, &
+ c_b25, &work[work_offset], ldwork, &v[v_offset],
+ ldv, &c_b14, &c__[c_offset], ldc);
+ }
+
+/* W := W * V2' */
+
+ strmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &
+ c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[
+ work_offset], ldwork);
+
+/* C2 := C2 - W */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + (lastv - *k + j) * c_dim1] -= work[i__ + j *
+ work_dim1];
+/* L110: */
+ }
+/* L120: */
+ }
+ }
+ }
+
+ } else if (lsame_(storev, "R")) {
+
+ if (lsame_(direct, "F")) {
+
+/* Let V = ( V1 V2 ) (V1: first K columns) */
+/* where V1 is unit upper triangular. */
+
+ if (lsame_(side, "L")) {
+
+/* Form H * C or H' * C where C = ( C1 ) */
+/* ( C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilaslc_(k, m, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilaslc_(&lastv, n, &c__[c_offset], ldc);
+
+/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */
+
+/* W := C1' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1
+ + 1], &c__1);
+/* L130: */
+ }
+
+/* W := W * V1' */
+
+ strmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &
+ c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C2'*V2' */
+
+ i__1 = lastv - *k;
+ sgemm_("Transpose", "Transpose", &lastc, k, &i__1, &c_b14,
+ &c__[*k + 1 + c_dim1], ldc, &v[(*k + 1) * v_dim1
+ + 1], ldv, &c_b14, &work[work_offset], ldwork);
+ }
+
+/* W := W * T' or W * T */
+
+ strmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &
+ c_b14, &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - V' * W' */
+
+ if (lastv > *k) {
+
+/* C2 := C2 - V2' * W' */
+
+ i__1 = lastv - *k;
+ sgemm_("Transpose", "Transpose", &i__1, &lastc, k, &c_b25,
+ &v[(*k + 1) * v_dim1 + 1], ldv, &work[
+ work_offset], ldwork, &c_b14, &c__[*k + 1 +
+ c_dim1], ldc);
+ }
+
+/* W := W * V1 */
+
+ strmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
+ c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+
+/* C1 := C1 - W' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1];
+/* L140: */
+ }
+/* L150: */
+ }
+
+ } else if (lsame_(side, "R")) {
+
+/* Form C * H or C * H' where C = ( C1 C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilaslc_(k, n, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilaslr_(m, &lastv, &c__[c_offset], ldc);
+
+/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */
+
+/* W := C1 */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j *
+ work_dim1 + 1], &c__1);
+/* L160: */
+ }
+
+/* W := W * V1' */
+
+ strmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &
+ c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C2 * V2' */
+
+ i__1 = lastv - *k;
+ sgemm_("No transpose", "Transpose", &lastc, k, &i__1, &
+ c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k +
+ 1) * v_dim1 + 1], ldv, &c_b14, &work[work_offset],
+ ldwork);
+ }
+
+/* W := W * T or W * T' */
+
+ strmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b14,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - W * V */
+
+ if (lastv > *k) {
+
+/* C2 := C2 - W * V2 */
+
+ i__1 = lastv - *k;
+ sgemm_("No transpose", "No transpose", &lastc, &i__1, k, &
+ c_b25, &work[work_offset], ldwork, &v[(*k + 1) *
+ v_dim1 + 1], ldv, &c_b14, &c__[(*k + 1) * c_dim1
+ + 1], ldc);
+ }
+
+/* W := W * V1 */
+
+ strmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
+ c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+
+/* C1 := C1 - W */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1];
+/* L170: */
+ }
+/* L180: */
+ }
+
+ }
+
+ } else {
+
+/* Let V = ( V1 V2 ) (V2: last K columns) */
+/* where V2 is unit lower triangular. */
+
+ if (lsame_(side, "L")) {
+
+/* Form H * C or H' * C where C = ( C1 ) */
+/* ( C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilaslc_(k, m, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilaslc_(&lastv, n, &c__[c_offset], ldc);
+
+/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */
+
+/* W := C2' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[
+ j * work_dim1 + 1], &c__1);
+/* L190: */
+ }
+
+/* W := W * V2' */
+
+ strmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &
+ c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
+ work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C1'*V1' */
+
+ i__1 = lastv - *k;
+ sgemm_("Transpose", "Transpose", &lastc, k, &i__1, &c_b14,
+ &c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, &
+ work[work_offset], ldwork);
+ }
+
+/* W := W * T' or W * T */
+
+ strmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &
+ c_b14, &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - V' * W' */
+
+ if (lastv > *k) {
+
+/* C1 := C1 - V1' * W' */
+
+ i__1 = lastv - *k;
+ sgemm_("Transpose", "Transpose", &i__1, &lastc, k, &c_b25,
+ &v[v_offset], ldv, &work[work_offset], ldwork, &
+ c_b14, &c__[c_offset], ldc);
+ }
+
+/* W := W * V2 */
+
+ strmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
+ c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
+ work_offset], ldwork);
+
+/* C2 := C2 - W' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[lastv - *k + j + i__ * c_dim1] -= work[i__ + j *
+ work_dim1];
+/* L200: */
+ }
+/* L210: */
+ }
+
+ } else if (lsame_(side, "R")) {
+
+/* Form C * H or C * H' where C = ( C1 C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilaslc_(k, n, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilaslr_(m, &lastv, &c__[c_offset], ldc);
+
+/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */
+
+/* W := C2 */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1,
+ &work[j * work_dim1 + 1], &c__1);
+/* L220: */
+ }
+
+/* W := W * V2' */
+
+ strmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &
+ c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
+ work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C1 * V1' */
+
+ i__1 = lastv - *k;
+ sgemm_("No transpose", "Transpose", &lastc, k, &i__1, &
+ c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &
+ c_b14, &work[work_offset], ldwork);
+ }
+
+/* W := W * T or W * T' */
+
+ strmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b14,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - W * V */
+
+ if (lastv > *k) {
+
+/* C1 := C1 - W * V1 */
+
+ i__1 = lastv - *k;
+ sgemm_("No transpose", "No transpose", &lastc, &i__1, k, &
+ c_b25, &work[work_offset], ldwork, &v[v_offset],
+ ldv, &c_b14, &c__[c_offset], ldc);
+ }
+
+/* W := W * V2 */
+
+ strmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
+ c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
+ work_offset], ldwork);
+
+/* C1 := C1 - W */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + (lastv - *k + j) * c_dim1] -= work[i__ + j *
+ work_dim1];
+/* L230: */
+ }
+/* L240: */
+ }
+
+ }
+
+ }
+ }
+
+ return 0;
+
+/* End of SLARFB */
+
+} /* slarfb_ */
diff --git a/SRC/slarfg.c b/SRC/slarfg.c
new file mode 100644
index 0000000..0d31251
--- /dev/null
+++ b/SRC/slarfg.c
@@ -0,0 +1,169 @@
+/* slarfg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slarfg_(integer *n, real *alpha, real *x, integer *incx,
+ real *tau)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1;
+
+ /* Builtin functions */
+ double r_sign(real *, real *);
+
+ /* Local variables */
+ integer j, knt;
+ real beta;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real xnorm;
+ extern doublereal slapy2_(real *, real *), slamch_(char *);
+ real safmin, rsafmn;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARFG generates a real elementary reflector H of order n, such */
+/* that */
+
+/* H * ( alpha ) = ( beta ), H' * H = I. */
+/* ( x ) ( 0 ) */
+
+/* where alpha and beta are scalars, and x is an (n-1)-element real */
+/* vector. H is represented in the form */
+
+/* H = I - tau * ( 1 ) * ( 1 v' ) , */
+/* ( v ) */
+
+/* where tau is a real scalar and v is a real (n-1)-element */
+/* vector. */
+
+/* If the elements of x are all zero, then tau = 0 and H is taken to be */
+/* the unit matrix. */
+
+/* Otherwise 1 <= tau <= 2. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the elementary reflector. */
+
+/* ALPHA (input/output) REAL */
+/* On entry, the value alpha. */
+/* On exit, it is overwritten with the value beta. */
+
+/* X (input/output) REAL array, dimension */
+/* (1+(N-2)*abs(INCX)) */
+/* On entry, the vector x. */
+/* On exit, it is overwritten with the vector v. */
+
+/* INCX (input) INTEGER */
+/* The increment between elements of X. INCX > 0. */
+
+/* TAU (output) REAL */
+/* The value tau. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --x;
+
+ /* Function Body */
+ if (*n <= 1) {
+ *tau = 0.f;
+ return 0;
+ }
+
+ i__1 = *n - 1;
+ xnorm = snrm2_(&i__1, &x[1], incx);
+
+ if (xnorm == 0.f) {
+
+/* H = I */
+
+ *tau = 0.f;
+ } else {
+
+/* general case */
+
+ r__1 = slapy2_(alpha, &xnorm);
+ beta = -r_sign(&r__1, alpha);
+ safmin = slamch_("S") / slamch_("E");
+ knt = 0;
+ if (dabs(beta) < safmin) {
+
+/* XNORM, BETA may be inaccurate; scale X and recompute them */
+
+ rsafmn = 1.f / safmin;
+L10:
+ ++knt;
+ i__1 = *n - 1;
+ sscal_(&i__1, &rsafmn, &x[1], incx);
+ beta *= rsafmn;
+ *alpha *= rsafmn;
+ if (dabs(beta) < safmin) {
+ goto L10;
+ }
+
+/* New BETA is at most 1, at least SAFMIN */
+
+ i__1 = *n - 1;
+ xnorm = snrm2_(&i__1, &x[1], incx);
+ r__1 = slapy2_(alpha, &xnorm);
+ beta = -r_sign(&r__1, alpha);
+ }
+ *tau = (beta - *alpha) / beta;
+ i__1 = *n - 1;
+ r__1 = 1.f / (*alpha - beta);
+ sscal_(&i__1, &r__1, &x[1], incx);
+
+/* If ALPHA is subnormal, it may lose relative accuracy */
+
+ i__1 = knt;
+ for (j = 1; j <= i__1; ++j) {
+ beta *= safmin;
+/* L20: */
+ }
+ *alpha = beta;
+ }
+
+ return 0;
+
+/* End of SLARFG */
+
+} /* slarfg_ */
diff --git a/SRC/slarfp.c b/SRC/slarfp.c
new file mode 100644
index 0000000..5db647a
--- /dev/null
+++ b/SRC/slarfp.c
@@ -0,0 +1,191 @@
+/* slarfp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slarfp_(integer *n, real *alpha, real *x, integer *incx,
+ real *tau)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1;
+
+ /* Builtin functions */
+ double r_sign(real *, real *);
+
+ /* Local variables */
+ integer j, knt;
+ real beta;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real xnorm;
+ extern doublereal slapy2_(real *, real *), slamch_(char *);
+ real safmin, rsafmn;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARFP generates a real elementary reflector H of order n, such */
+/* that */
+
+/* H * ( alpha ) = ( beta ), H' * H = I. */
+/* ( x ) ( 0 ) */
+
+/* where alpha and beta are scalars, beta is non-negative, and x is */
+/* an (n-1)-element real vector. H is represented in the form */
+
+/* H = I - tau * ( 1 ) * ( 1 v' ) , */
+/* ( v ) */
+
+/* where tau is a real scalar and v is a real (n-1)-element */
+/* vector. */
+
+/* If the elements of x are all zero, then tau = 0 and H is taken to be */
+/* the unit matrix. */
+
+/* Otherwise 1 <= tau <= 2. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the elementary reflector. */
+
+/* ALPHA (input/output) REAL */
+/* On entry, the value alpha. */
+/* On exit, it is overwritten with the value beta. */
+
+/* X (input/output) REAL array, dimension */
+/* (1+(N-2)*abs(INCX)) */
+/* On entry, the vector x. */
+/* On exit, it is overwritten with the vector v. */
+
+/* INCX (input) INTEGER */
+/* The increment between elements of X. INCX > 0. */
+
+/* TAU (output) REAL */
+/* The value tau. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --x;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *tau = 0.f;
+ return 0;
+ }
+
+ i__1 = *n - 1;
+ xnorm = snrm2_(&i__1, &x[1], incx);
+
+ if (xnorm == 0.f) {
+
+/* H = [+/-1, 0; I], sign chosen so ALPHA >= 0. */
+
+ if (*alpha >= 0.f) {
+/* When TAU.eq.ZERO, the vector is special-cased to be */
+/* all zeros in the application routines. We do not need */
+/* to clear it. */
+ *tau = 0.f;
+ } else {
+/* However, the application routines rely on explicit */
+/* zero checks when TAU.ne.ZERO, and we must clear X. */
+ *tau = 2.f;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ x[(j - 1) * *incx + 1] = 0.f;
+ }
+ *alpha = -(*alpha);
+ }
+ } else {
+
+/* general case */
+
+ r__1 = slapy2_(alpha, &xnorm);
+ beta = r_sign(&r__1, alpha);
+ safmin = slamch_("S") / slamch_("E");
+ knt = 0;
+ if (dabs(beta) < safmin) {
+
+/* XNORM, BETA may be inaccurate; scale X and recompute them */
+
+ rsafmn = 1.f / safmin;
+L10:
+ ++knt;
+ i__1 = *n - 1;
+ sscal_(&i__1, &rsafmn, &x[1], incx);
+ beta *= rsafmn;
+ *alpha *= rsafmn;
+ if (dabs(beta) < safmin) {
+ goto L10;
+ }
+
+/* New BETA is at most 1, at least SAFMIN */
+
+ i__1 = *n - 1;
+ xnorm = snrm2_(&i__1, &x[1], incx);
+ r__1 = slapy2_(alpha, &xnorm);
+ beta = r_sign(&r__1, alpha);
+ }
+ *alpha += beta;
+ if (beta < 0.f) {
+ beta = -beta;
+ *tau = -(*alpha) / beta;
+ } else {
+ *alpha = xnorm * (xnorm / *alpha);
+ *tau = *alpha / beta;
+ *alpha = -(*alpha);
+ }
+ i__1 = *n - 1;
+ r__1 = 1.f / *alpha;
+ sscal_(&i__1, &r__1, &x[1], incx);
+
+/* If BETA is subnormal, it may lose relative accuracy */
+
+ i__1 = knt;
+ for (j = 1; j <= i__1; ++j) {
+ beta *= safmin;
+/* L20: */
+ }
+ *alpha = beta;
+ }
+
+ return 0;
+
+/* End of SLARFP */
+
+} /* slarfp_ */
diff --git a/SRC/slarft.c b/SRC/slarft.c
new file mode 100644
index 0000000..4143ce4
--- /dev/null
+++ b/SRC/slarft.c
@@ -0,0 +1,323 @@
+/* slarft.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b8 = 0.f;
+
+/* Subroutine */ int slarft_(char *direct, char *storev, integer *n, integer *
+ k, real *v, integer *ldv, real *tau, real *t, integer *ldt)
+{
+ /* System generated locals */
+ integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j, prevlastv;
+ real vii;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ integer lastv;
+ extern /* Subroutine */ int strmv_(char *, char *, char *, integer *,
+ real *, integer *, real *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARFT forms the triangular factor T of a real block reflector H */
+/* of order n, which is defined as a product of k elementary reflectors. */
+
+/* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */
+
+/* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */
+
+/* If STOREV = 'C', the vector which defines the elementary reflector */
+/* H(i) is stored in the i-th column of the array V, and */
+
+/* H = I - V * T * V' */
+
+/* If STOREV = 'R', the vector which defines the elementary reflector */
+/* H(i) is stored in the i-th row of the array V, and */
+
+/* H = I - V' * T * V */
+
+/* Arguments */
+/* ========= */
+
+/* DIRECT (input) CHARACTER*1 */
+/* Specifies the order in which the elementary reflectors are */
+/* multiplied to form the block reflector: */
+/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */
+/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
+
+/* STOREV (input) CHARACTER*1 */
+/* Specifies how the vectors which define the elementary */
+/* reflectors are stored (see also Further Details): */
+/* = 'C': columnwise */
+/* = 'R': rowwise */
+
+/* N (input) INTEGER */
+/* The order of the block reflector H. N >= 0. */
+
+/* K (input) INTEGER */
+/* The order of the triangular factor T (= the number of */
+/* elementary reflectors). K >= 1. */
+
+/* V (input/output) REAL array, dimension */
+/* (LDV,K) if STOREV = 'C' */
+/* (LDV,N) if STOREV = 'R' */
+/* The matrix V. See further details. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. */
+/* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */
+
+/* TAU (input) REAL array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i). */
+
+/* T (output) REAL array, dimension (LDT,K) */
+/* The k by k triangular factor T of the block reflector. */
+/* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */
+/* lower triangular. The rest of the array is not used. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= K. */
+
+/* Further Details */
+/* =============== */
+
+/* The shape of the matrix V and the storage of the vectors which define */
+/* the H(i) is best illustrated by the following example with n = 5 and */
+/* k = 3. The elements equal to 1 are not stored; the corresponding */
+/* array elements are modified but restored on exit. The rest of the */
+/* array is not used. */
+
+/* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */
+
+/* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */
+/* ( v1 1 ) ( 1 v2 v2 v2 ) */
+/* ( v1 v2 1 ) ( 1 v3 v3 ) */
+/* ( v1 v2 v3 ) */
+/* ( v1 v2 v3 ) */
+
+/* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */
+
+/* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */
+/* ( v1 v2 v3 ) ( v2 v2 v2 1 ) */
+/* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */
+/* ( 1 v3 ) */
+/* ( 1 ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --tau;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+
+ /* Function Body */
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (lsame_(direct, "F")) {
+ prevlastv = *n;
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ prevlastv = max(i__,prevlastv);
+ if (tau[i__] == 0.f) {
+
+/* H(i) = I */
+
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ t[j + i__ * t_dim1] = 0.f;
+/* L10: */
+ }
+ } else {
+
+/* general case */
+
+ vii = v[i__ + i__ * v_dim1];
+ v[i__ + i__ * v_dim1] = 1.f;
+ if (lsame_(storev, "C")) {
+/* Skip any trailing zeros. */
+ i__2 = i__ + 1;
+ for (lastv = *n; lastv >= i__2; --lastv) {
+ if (v[lastv + i__ * v_dim1] != 0.f) {
+ break;
+ }
+ }
+ j = min(lastv,prevlastv);
+
+/* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i) */
+
+ i__2 = j - i__ + 1;
+ i__3 = i__ - 1;
+ r__1 = -tau[i__];
+ sgemv_("Transpose", &i__2, &i__3, &r__1, &v[i__ + v_dim1],
+ ldv, &v[i__ + i__ * v_dim1], &c__1, &c_b8, &t[
+ i__ * t_dim1 + 1], &c__1);
+ } else {
+/* Skip any trailing zeros. */
+ i__2 = i__ + 1;
+ for (lastv = *n; lastv >= i__2; --lastv) {
+ if (v[i__ + lastv * v_dim1] != 0.f) {
+ break;
+ }
+ }
+ j = min(lastv,prevlastv);
+
+/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)' */
+
+ i__2 = i__ - 1;
+ i__3 = j - i__ + 1;
+ r__1 = -tau[i__];
+ sgemv_("No transpose", &i__2, &i__3, &r__1, &v[i__ *
+ v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, &
+ c_b8, &t[i__ * t_dim1 + 1], &c__1);
+ }
+ v[i__ + i__ * v_dim1] = vii;
+
+/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */
+
+ i__2 = i__ - 1;
+ strmv_("Upper", "No transpose", "Non-unit", &i__2, &t[
+ t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1);
+ t[i__ + i__ * t_dim1] = tau[i__];
+ if (i__ > 1) {
+ prevlastv = max(prevlastv,lastv);
+ } else {
+ prevlastv = lastv;
+ }
+ }
+/* L20: */
+ }
+ } else {
+ prevlastv = 1;
+ for (i__ = *k; i__ >= 1; --i__) {
+ if (tau[i__] == 0.f) {
+
+/* H(i) = I */
+
+ i__1 = *k;
+ for (j = i__; j <= i__1; ++j) {
+ t[j + i__ * t_dim1] = 0.f;
+/* L30: */
+ }
+ } else {
+
+/* general case */
+
+ if (i__ < *k) {
+ if (lsame_(storev, "C")) {
+ vii = v[*n - *k + i__ + i__ * v_dim1];
+ v[*n - *k + i__ + i__ * v_dim1] = 1.f;
+/* Skip any leading zeros. */
+ i__1 = i__ - 1;
+ for (lastv = 1; lastv <= i__1; ++lastv) {
+ if (v[lastv + i__ * v_dim1] != 0.f) {
+ break;
+ }
+ }
+ j = max(lastv,prevlastv);
+
+/* T(i+1:k,i) := */
+/* - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i) */
+
+ i__1 = *n - *k + i__ - j + 1;
+ i__2 = *k - i__;
+ r__1 = -tau[i__];
+ sgemv_("Transpose", &i__1, &i__2, &r__1, &v[j + (i__
+ + 1) * v_dim1], ldv, &v[j + i__ * v_dim1], &
+ c__1, &c_b8, &t[i__ + 1 + i__ * t_dim1], &
+ c__1);
+ v[*n - *k + i__ + i__ * v_dim1] = vii;
+ } else {
+ vii = v[i__ + (*n - *k + i__) * v_dim1];
+ v[i__ + (*n - *k + i__) * v_dim1] = 1.f;
+/* Skip any leading zeros. */
+ i__1 = i__ - 1;
+ for (lastv = 1; lastv <= i__1; ++lastv) {
+ if (v[i__ + lastv * v_dim1] != 0.f) {
+ break;
+ }
+ }
+ j = max(lastv,prevlastv);
+
+/* T(i+1:k,i) := */
+/* - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)' */
+
+ i__1 = *k - i__;
+ i__2 = *n - *k + i__ - j + 1;
+ r__1 = -tau[i__];
+ sgemv_("No transpose", &i__1, &i__2, &r__1, &v[i__ +
+ 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1],
+ ldv, &c_b8, &t[i__ + 1 + i__ * t_dim1], &c__1);
+ v[i__ + (*n - *k + i__) * v_dim1] = vii;
+ }
+
+/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */
+
+ i__1 = *k - i__;
+ strmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__
+ + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ *
+ t_dim1], &c__1)
+ ;
+ if (i__ > 1) {
+ prevlastv = min(prevlastv,lastv);
+ } else {
+ prevlastv = lastv;
+ }
+ }
+ t[i__ + i__ * t_dim1] = tau[i__];
+ }
+/* L40: */
+ }
+ }
+ return 0;
+
+/* End of SLARFT */
+
+} /* slarft_ */
diff --git a/SRC/slarfx.c b/SRC/slarfx.c
new file mode 100644
index 0000000..59c5d0a
--- /dev/null
+++ b/SRC/slarfx.c
@@ -0,0 +1,729 @@
+/* slarfx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int slarfx_(char *side, integer *m, integer *n, real *v,
+ real *tau, real *c__, integer *ldc, real *work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1;
+
+ /* Local variables */
+ integer j;
+ real t1, t2, t3, t4, t5, t6, t7, t8, t9, v1, v2, v3, v4, v5, v6, v7, v8,
+ v9, t10, v10, sum;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARFX applies a real elementary reflector H to a real m by n */
+/* matrix C, from either the left or the right. H is represented in the */
+/* form */
+
+/* H = I - tau * v * v' */
+
+/* where tau is a real scalar and v is a real vector. */
+
+/* If tau = 0, then H is taken to be the unit matrix */
+
+/* This version uses inline code if H has order < 11. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': form H * C */
+/* = 'R': form C * H */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* V (input) REAL array, dimension (M) if SIDE = 'L' */
+/* or (N) if SIDE = 'R' */
+/* The vector v in the representation of H. */
+
+/* TAU (input) REAL */
+/* The value tau in the representation of H. */
+
+/* C (input/output) REAL array, dimension (LDC,N) */
+/* On entry, the m by n matrix C. */
+/* On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
+/* or C * H if SIDE = 'R'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDA >= (1,M). */
+
+/* WORK (workspace) REAL array, dimension */
+/* (N) if SIDE = 'L' */
+/* or (M) if SIDE = 'R' */
+/* WORK is not referenced if H has order < 11. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ if (*tau == 0.f) {
+ return 0;
+ }
+ if (lsame_(side, "L")) {
+
+/* Form H * C, where H has order m. */
+
+ switch (*m) {
+ case 1: goto L10;
+ case 2: goto L30;
+ case 3: goto L50;
+ case 4: goto L70;
+ case 5: goto L90;
+ case 6: goto L110;
+ case 7: goto L130;
+ case 8: goto L150;
+ case 9: goto L170;
+ case 10: goto L190;
+ }
+
+/* Code for general M */
+
+ slarf_(side, m, n, &v[1], &c__1, tau, &c__[c_offset], ldc, &work[1]);
+ goto L410;
+L10:
+
+/* Special code for 1 x 1 Householder */
+
+ t1 = 1.f - *tau * v[1] * v[1];
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j * c_dim1 + 1] = t1 * c__[j * c_dim1 + 1];
+/* L20: */
+ }
+ goto L410;
+L30:
+
+/* Special code for 2 x 2 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2];
+ c__[j * c_dim1 + 1] -= sum * t1;
+ c__[j * c_dim1 + 2] -= sum * t2;
+/* L40: */
+ }
+ goto L410;
+L50:
+
+/* Special code for 3 x 3 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
+ c__[j * c_dim1 + 3];
+ c__[j * c_dim1 + 1] -= sum * t1;
+ c__[j * c_dim1 + 2] -= sum * t2;
+ c__[j * c_dim1 + 3] -= sum * t3;
+/* L60: */
+ }
+ goto L410;
+L70:
+
+/* Special code for 4 x 4 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
+ c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4];
+ c__[j * c_dim1 + 1] -= sum * t1;
+ c__[j * c_dim1 + 2] -= sum * t2;
+ c__[j * c_dim1 + 3] -= sum * t3;
+ c__[j * c_dim1 + 4] -= sum * t4;
+/* L80: */
+ }
+ goto L410;
+L90:
+
+/* Special code for 5 x 5 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
+ c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
+ j * c_dim1 + 5];
+ c__[j * c_dim1 + 1] -= sum * t1;
+ c__[j * c_dim1 + 2] -= sum * t2;
+ c__[j * c_dim1 + 3] -= sum * t3;
+ c__[j * c_dim1 + 4] -= sum * t4;
+ c__[j * c_dim1 + 5] -= sum * t5;
+/* L100: */
+ }
+ goto L410;
+L110:
+
+/* Special code for 6 x 6 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ v6 = v[6];
+ t6 = *tau * v6;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
+ c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
+ j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6];
+ c__[j * c_dim1 + 1] -= sum * t1;
+ c__[j * c_dim1 + 2] -= sum * t2;
+ c__[j * c_dim1 + 3] -= sum * t3;
+ c__[j * c_dim1 + 4] -= sum * t4;
+ c__[j * c_dim1 + 5] -= sum * t5;
+ c__[j * c_dim1 + 6] -= sum * t6;
+/* L120: */
+ }
+ goto L410;
+L130:
+
+/* Special code for 7 x 7 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ v6 = v[6];
+ t6 = *tau * v6;
+ v7 = v[7];
+ t7 = *tau * v7;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
+ c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
+ j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j *
+ c_dim1 + 7];
+ c__[j * c_dim1 + 1] -= sum * t1;
+ c__[j * c_dim1 + 2] -= sum * t2;
+ c__[j * c_dim1 + 3] -= sum * t3;
+ c__[j * c_dim1 + 4] -= sum * t4;
+ c__[j * c_dim1 + 5] -= sum * t5;
+ c__[j * c_dim1 + 6] -= sum * t6;
+ c__[j * c_dim1 + 7] -= sum * t7;
+/* L140: */
+ }
+ goto L410;
+L150:
+
+/* Special code for 8 x 8 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ v6 = v[6];
+ t6 = *tau * v6;
+ v7 = v[7];
+ t7 = *tau * v7;
+ v8 = v[8];
+ t8 = *tau * v8;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
+ c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
+ j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j *
+ c_dim1 + 7] + v8 * c__[j * c_dim1 + 8];
+ c__[j * c_dim1 + 1] -= sum * t1;
+ c__[j * c_dim1 + 2] -= sum * t2;
+ c__[j * c_dim1 + 3] -= sum * t3;
+ c__[j * c_dim1 + 4] -= sum * t4;
+ c__[j * c_dim1 + 5] -= sum * t5;
+ c__[j * c_dim1 + 6] -= sum * t6;
+ c__[j * c_dim1 + 7] -= sum * t7;
+ c__[j * c_dim1 + 8] -= sum * t8;
+/* L160: */
+ }
+ goto L410;
+L170:
+
+/* Special code for 9 x 9 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ v6 = v[6];
+ t6 = *tau * v6;
+ v7 = v[7];
+ t7 = *tau * v7;
+ v8 = v[8];
+ t8 = *tau * v8;
+ v9 = v[9];
+ t9 = *tau * v9;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
+ c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
+ j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j *
+ c_dim1 + 7] + v8 * c__[j * c_dim1 + 8] + v9 * c__[j *
+ c_dim1 + 9];
+ c__[j * c_dim1 + 1] -= sum * t1;
+ c__[j * c_dim1 + 2] -= sum * t2;
+ c__[j * c_dim1 + 3] -= sum * t3;
+ c__[j * c_dim1 + 4] -= sum * t4;
+ c__[j * c_dim1 + 5] -= sum * t5;
+ c__[j * c_dim1 + 6] -= sum * t6;
+ c__[j * c_dim1 + 7] -= sum * t7;
+ c__[j * c_dim1 + 8] -= sum * t8;
+ c__[j * c_dim1 + 9] -= sum * t9;
+/* L180: */
+ }
+ goto L410;
+L190:
+
+/* Special code for 10 x 10 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ v6 = v[6];
+ t6 = *tau * v6;
+ v7 = v[7];
+ t7 = *tau * v7;
+ v8 = v[8];
+ t8 = *tau * v8;
+ v9 = v[9];
+ t9 = *tau * v9;
+ v10 = v[10];
+ t10 = *tau * v10;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 *
+ c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[
+ j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j *
+ c_dim1 + 7] + v8 * c__[j * c_dim1 + 8] + v9 * c__[j *
+ c_dim1 + 9] + v10 * c__[j * c_dim1 + 10];
+ c__[j * c_dim1 + 1] -= sum * t1;
+ c__[j * c_dim1 + 2] -= sum * t2;
+ c__[j * c_dim1 + 3] -= sum * t3;
+ c__[j * c_dim1 + 4] -= sum * t4;
+ c__[j * c_dim1 + 5] -= sum * t5;
+ c__[j * c_dim1 + 6] -= sum * t6;
+ c__[j * c_dim1 + 7] -= sum * t7;
+ c__[j * c_dim1 + 8] -= sum * t8;
+ c__[j * c_dim1 + 9] -= sum * t9;
+ c__[j * c_dim1 + 10] -= sum * t10;
+/* L200: */
+ }
+ goto L410;
+ } else {
+
+/* Form C * H, where H has order n. */
+
+ switch (*n) {
+ case 1: goto L210;
+ case 2: goto L230;
+ case 3: goto L250;
+ case 4: goto L270;
+ case 5: goto L290;
+ case 6: goto L310;
+ case 7: goto L330;
+ case 8: goto L350;
+ case 9: goto L370;
+ case 10: goto L390;
+ }
+
+/* Code for general N */
+
+ slarf_(side, m, n, &v[1], &c__1, tau, &c__[c_offset], ldc, &work[1]);
+ goto L410;
+L210:
+
+/* Special code for 1 x 1 Householder */
+
+ t1 = 1.f - *tau * v[1] * v[1];
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j + c_dim1] = t1 * c__[j + c_dim1];
+/* L220: */
+ }
+ goto L410;
+L230:
+
+/* Special code for 2 x 2 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)];
+ c__[j + c_dim1] -= sum * t1;
+ c__[j + (c_dim1 << 1)] -= sum * t2;
+/* L240: */
+ }
+ goto L410;
+L250:
+
+/* Special code for 3 x 3 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
+ c__[j + c_dim1 * 3];
+ c__[j + c_dim1] -= sum * t1;
+ c__[j + (c_dim1 << 1)] -= sum * t2;
+ c__[j + c_dim1 * 3] -= sum * t3;
+/* L260: */
+ }
+ goto L410;
+L270:
+
+/* Special code for 4 x 4 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
+ c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)];
+ c__[j + c_dim1] -= sum * t1;
+ c__[j + (c_dim1 << 1)] -= sum * t2;
+ c__[j + c_dim1 * 3] -= sum * t3;
+ c__[j + (c_dim1 << 2)] -= sum * t4;
+/* L280: */
+ }
+ goto L410;
+L290:
+
+/* Special code for 5 x 5 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
+ c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
+ c__[j + c_dim1 * 5];
+ c__[j + c_dim1] -= sum * t1;
+ c__[j + (c_dim1 << 1)] -= sum * t2;
+ c__[j + c_dim1 * 3] -= sum * t3;
+ c__[j + (c_dim1 << 2)] -= sum * t4;
+ c__[j + c_dim1 * 5] -= sum * t5;
+/* L300: */
+ }
+ goto L410;
+L310:
+
+/* Special code for 6 x 6 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ v6 = v[6];
+ t6 = *tau * v6;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
+ c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
+ c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6];
+ c__[j + c_dim1] -= sum * t1;
+ c__[j + (c_dim1 << 1)] -= sum * t2;
+ c__[j + c_dim1 * 3] -= sum * t3;
+ c__[j + (c_dim1 << 2)] -= sum * t4;
+ c__[j + c_dim1 * 5] -= sum * t5;
+ c__[j + c_dim1 * 6] -= sum * t6;
+/* L320: */
+ }
+ goto L410;
+L330:
+
+/* Special code for 7 x 7 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ v6 = v[6];
+ t6 = *tau * v6;
+ v7 = v[7];
+ t7 = *tau * v7;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
+ c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
+ c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[
+ j + c_dim1 * 7];
+ c__[j + c_dim1] -= sum * t1;
+ c__[j + (c_dim1 << 1)] -= sum * t2;
+ c__[j + c_dim1 * 3] -= sum * t3;
+ c__[j + (c_dim1 << 2)] -= sum * t4;
+ c__[j + c_dim1 * 5] -= sum * t5;
+ c__[j + c_dim1 * 6] -= sum * t6;
+ c__[j + c_dim1 * 7] -= sum * t7;
+/* L340: */
+ }
+ goto L410;
+L350:
+
+/* Special code for 8 x 8 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ v6 = v[6];
+ t6 = *tau * v6;
+ v7 = v[7];
+ t7 = *tau * v7;
+ v8 = v[8];
+ t8 = *tau * v8;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
+ c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
+ c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[
+ j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)];
+ c__[j + c_dim1] -= sum * t1;
+ c__[j + (c_dim1 << 1)] -= sum * t2;
+ c__[j + c_dim1 * 3] -= sum * t3;
+ c__[j + (c_dim1 << 2)] -= sum * t4;
+ c__[j + c_dim1 * 5] -= sum * t5;
+ c__[j + c_dim1 * 6] -= sum * t6;
+ c__[j + c_dim1 * 7] -= sum * t7;
+ c__[j + (c_dim1 << 3)] -= sum * t8;
+/* L360: */
+ }
+ goto L410;
+L370:
+
+/* Special code for 9 x 9 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ v6 = v[6];
+ t6 = *tau * v6;
+ v7 = v[7];
+ t7 = *tau * v7;
+ v8 = v[8];
+ t8 = *tau * v8;
+ v9 = v[9];
+ t9 = *tau * v9;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
+ c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
+ c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[
+ j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)] + v9 * c__[
+ j + c_dim1 * 9];
+ c__[j + c_dim1] -= sum * t1;
+ c__[j + (c_dim1 << 1)] -= sum * t2;
+ c__[j + c_dim1 * 3] -= sum * t3;
+ c__[j + (c_dim1 << 2)] -= sum * t4;
+ c__[j + c_dim1 * 5] -= sum * t5;
+ c__[j + c_dim1 * 6] -= sum * t6;
+ c__[j + c_dim1 * 7] -= sum * t7;
+ c__[j + (c_dim1 << 3)] -= sum * t8;
+ c__[j + c_dim1 * 9] -= sum * t9;
+/* L380: */
+ }
+ goto L410;
+L390:
+
+/* Special code for 10 x 10 Householder */
+
+ v1 = v[1];
+ t1 = *tau * v1;
+ v2 = v[2];
+ t2 = *tau * v2;
+ v3 = v[3];
+ t3 = *tau * v3;
+ v4 = v[4];
+ t4 = *tau * v4;
+ v5 = v[5];
+ t5 = *tau * v5;
+ v6 = v[6];
+ t6 = *tau * v6;
+ v7 = v[7];
+ t7 = *tau * v7;
+ v8 = v[8];
+ t8 = *tau * v8;
+ v9 = v[9];
+ t9 = *tau * v9;
+ v10 = v[10];
+ t10 = *tau * v10;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 *
+ c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 *
+ c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[
+ j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)] + v9 * c__[
+ j + c_dim1 * 9] + v10 * c__[j + c_dim1 * 10];
+ c__[j + c_dim1] -= sum * t1;
+ c__[j + (c_dim1 << 1)] -= sum * t2;
+ c__[j + c_dim1 * 3] -= sum * t3;
+ c__[j + (c_dim1 << 2)] -= sum * t4;
+ c__[j + c_dim1 * 5] -= sum * t5;
+ c__[j + c_dim1 * 6] -= sum * t6;
+ c__[j + c_dim1 * 7] -= sum * t7;
+ c__[j + (c_dim1 << 3)] -= sum * t8;
+ c__[j + c_dim1 * 9] -= sum * t9;
+ c__[j + c_dim1 * 10] -= sum * t10;
+/* L400: */
+ }
+ goto L410;
+ }
+L410:
+ return 0;
+
+/* End of SLARFX */
+
+} /* slarfx_ */
diff --git a/SRC/slargv.c b/SRC/slargv.c
new file mode 100644
index 0000000..32e0e33
--- /dev/null
+++ b/SRC/slargv.c
@@ -0,0 +1,130 @@
+/* slargv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slargv_(integer *n, real *x, integer *incx, real *y,
+ integer *incy, real *c__, integer *incc)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real f, g;
+ integer i__;
+ real t;
+ integer ic, ix, iy;
+ real tt;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARGV generates a vector of real plane rotations, determined by */
+/* elements of the real vectors x and y. For i = 1,2,...,n */
+
+/* ( c(i) s(i) ) ( x(i) ) = ( a(i) ) */
+/* ( -s(i) c(i) ) ( y(i) ) = ( 0 ) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of plane rotations to be generated. */
+
+/* X (input/output) REAL array, */
+/* dimension (1+(N-1)*INCX) */
+/* On entry, the vector x. */
+/* On exit, x(i) is overwritten by a(i), for i = 1,...,n. */
+
+/* INCX (input) INTEGER */
+/* The increment between elements of X. INCX > 0. */
+
+/* Y (input/output) REAL array, */
+/* dimension (1+(N-1)*INCY) */
+/* On entry, the vector y. */
+/* On exit, the sines of the plane rotations. */
+
+/* INCY (input) INTEGER */
+/* The increment between elements of Y. INCY > 0. */
+
+/* C (output) REAL array, dimension (1+(N-1)*INCC) */
+/* The cosines of the plane rotations. */
+
+/* INCC (input) INTEGER */
+/* The increment between elements of C. INCC > 0. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --c__;
+ --y;
+ --x;
+
+ /* Function Body */
+ ix = 1;
+ iy = 1;
+ ic = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ f = x[ix];
+ g = y[iy];
+ if (g == 0.f) {
+ c__[ic] = 1.f;
+ } else if (f == 0.f) {
+ c__[ic] = 0.f;
+ y[iy] = 1.f;
+ x[ix] = g;
+ } else if (dabs(f) > dabs(g)) {
+ t = g / f;
+ tt = sqrt(t * t + 1.f);
+ c__[ic] = 1.f / tt;
+ y[iy] = t * c__[ic];
+ x[ix] = f * tt;
+ } else {
+ t = f / g;
+ tt = sqrt(t * t + 1.f);
+ y[iy] = 1.f / tt;
+ c__[ic] = t * y[iy];
+ x[ix] = g * tt;
+ }
+ ic += *incc;
+ iy += *incy;
+ ix += *incx;
+/* L10: */
+ }
+ return 0;
+
+/* End of SLARGV */
+
+} /* slargv_ */
diff --git a/SRC/slarnv.c b/SRC/slarnv.c
new file mode 100644
index 0000000..9ea4b19
--- /dev/null
+++ b/SRC/slarnv.c
@@ -0,0 +1,146 @@
+/* slarnv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slarnv_(integer *idist, integer *iseed, integer *n, real
+ *x)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+
+ /* Builtin functions */
+ double log(doublereal), sqrt(doublereal), cos(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real u[128];
+ integer il, iv, il2;
+ extern /* Subroutine */ int slaruv_(integer *, integer *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARNV returns a vector of n random real numbers from a uniform or */
+/* normal distribution. */
+
+/* Arguments */
+/* ========= */
+
+/* IDIST (input) INTEGER */
+/* Specifies the distribution of the random numbers: */
+/* = 1: uniform (0,1) */
+/* = 2: uniform (-1,1) */
+/* = 3: normal (0,1) */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* N (input) INTEGER */
+/* The number of random numbers to be generated. */
+
+/* X (output) REAL array, dimension (N) */
+/* The generated random numbers. */
+
+/* Further Details */
+/* =============== */
+
+/* This routine calls the auxiliary routine SLARUV to generate random */
+/* real numbers from a uniform (0,1) distribution, in batches of up to */
+/* 128 using vectorisable code. The Box-Muller method is used to */
+/* transform numbers from a uniform to a normal distribution. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --x;
+ --iseed;
+
+ /* Function Body */
+ i__1 = *n;
+ for (iv = 1; iv <= i__1; iv += 64) {
+/* Computing MIN */
+ i__2 = 64, i__3 = *n - iv + 1;
+ il = min(i__2,i__3);
+ if (*idist == 3) {
+ il2 = il << 1;
+ } else {
+ il2 = il;
+ }
+
+/* Call SLARUV to generate IL2 numbers from a uniform (0,1) */
+/* distribution (IL2 <= LV) */
+
+ slaruv_(&iseed[1], &il2, u);
+
+ if (*idist == 1) {
+
+/* Copy generated numbers */
+
+ i__2 = il;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[iv + i__ - 1] = u[i__ - 1];
+/* L10: */
+ }
+ } else if (*idist == 2) {
+
+/* Convert generated numbers to uniform (-1,1) distribution */
+
+ i__2 = il;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[iv + i__ - 1] = u[i__ - 1] * 2.f - 1.f;
+/* L20: */
+ }
+ } else if (*idist == 3) {
+
+/* Convert generated numbers to normal (0,1) distribution */
+
+ i__2 = il;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[iv + i__ - 1] = sqrt(log(u[(i__ << 1) - 2]) * -2.f) * cos(u[
+ (i__ << 1) - 1] * 6.2831853071795864769252867663f);
+/* L30: */
+ }
+ }
+/* L40: */
+ }
+ return 0;
+
+/* End of SLARNV */
+
+} /* slarnv_ */
diff --git a/SRC/slarra.c b/SRC/slarra.c
new file mode 100644
index 0000000..ecff65a
--- /dev/null
+++ b/SRC/slarra.c
@@ -0,0 +1,155 @@
+/* slarra.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slarra_(integer *n, real *d__, real *e, real *e2, real *
+ spltol, real *tnrm, integer *nsplit, integer *isplit, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real tmp1, eabs;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Compute the splitting points with threshold SPLTOL. */
+/* SLARRA sets any "small" off-diagonal elements to zero. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N > 0. */
+
+/* D (input) REAL array, dimension (N) */
+/* On entry, the N diagonal elements of the tridiagonal */
+/* matrix T. */
+
+/* E (input/output) REAL array, dimension (N) */
+/* On entry, the first (N-1) entries contain the subdiagonal */
+/* elements of the tridiagonal matrix T; E(N) need not be set. */
+/* On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT, */
+/* are set to zero, the other entries of E are untouched. */
+
+/* E2 (input/output) REAL array, dimension (N) */
+/* On entry, the first (N-1) entries contain the SQUARES of the */
+/* subdiagonal elements of the tridiagonal matrix T; */
+/* E2(N) need not be set. */
+/* On exit, the entries E2( ISPLIT( I ) ), */
+/* 1 <= I <= NSPLIT, have been set to zero */
+
+/* SPLTOL (input) REAL */
+/* The threshold for splitting. Two criteria can be used: */
+/* SPLTOL<0 : criterion based on absolute off-diagonal value */
+/* SPLTOL>0 : criterion that preserves relative accuracy */
+
+/* TNRM (input) REAL */
+/* The norm of the matrix. */
+
+/* NSPLIT (output) INTEGER */
+/* The number of blocks T splits into. 1 <= NSPLIT <= N. */
+
+/* ISPLIT (output) INTEGER array, dimension (N) */
+/* The splitting points, at which T breaks up into blocks. */
+/* The first block consists of rows/columns 1 to ISPLIT(1), */
+/* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */
+/* etc., and the NSPLIT-th consists of rows/columns */
+/* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */
+
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --isplit;
+ --e2;
+ --e;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+/* Compute splitting points */
+ *nsplit = 1;
+ if (*spltol < 0.f) {
+/* Criterion based on absolute off-diagonal value */
+ tmp1 = dabs(*spltol) * *tnrm;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ eabs = (r__1 = e[i__], dabs(r__1));
+ if (eabs <= tmp1) {
+ e[i__] = 0.f;
+ e2[i__] = 0.f;
+ isplit[*nsplit] = i__;
+ ++(*nsplit);
+ }
+/* L9: */
+ }
+ } else {
+/* Criterion that guarantees relative accuracy */
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ eabs = (r__1 = e[i__], dabs(r__1));
+ if (eabs <= *spltol * sqrt((r__1 = d__[i__], dabs(r__1))) * sqrt((
+ r__2 = d__[i__ + 1], dabs(r__2)))) {
+ e[i__] = 0.f;
+ e2[i__] = 0.f;
+ isplit[*nsplit] = i__;
+ ++(*nsplit);
+ }
+/* L10: */
+ }
+ }
+ isplit[*nsplit] = *n;
+ return 0;
+
+/* End of SLARRA */
+
+} /* slarra_ */
diff --git a/SRC/slarrb.c b/SRC/slarrb.c
new file mode 100644
index 0000000..f1606a0
--- /dev/null
+++ b/SRC/slarrb.c
@@ -0,0 +1,349 @@
+/* slarrb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slarrb_(integer *n, real *d__, real *lld, integer *
+ ifirst, integer *ilast, real *rtol1, real *rtol2, integer *offset,
+ real *w, real *wgap, real *werr, real *work, integer *iwork, real *
+ pivmin, real *spdiam, integer *twist, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double log(doublereal);
+
+ /* Local variables */
+ integer i__, k, r__, i1, ii, ip;
+ real gap, mid, tmp, back, lgap, rgap, left;
+ integer iter, nint, prev, next;
+ real cvrgd, right, width;
+ extern integer slaneg_(integer *, real *, real *, real *, real *, integer
+ *);
+ integer negcnt;
+ real mnwdth;
+ integer olnint, maxitr;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Given the relatively robust representation(RRR) L D L^T, SLARRB */
+/* does "limited" bisection to refine the eigenvalues of L D L^T, */
+/* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial */
+/* guesses for these eigenvalues are input in W, the corresponding estimate */
+/* of the error in these guesses and their gaps are input in WERR */
+/* and WGAP, respectively. During bisection, intervals */
+/* [left, right] are maintained by storing their mid-points and */
+/* semi-widths in the arrays W and WERR respectively. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. */
+
+/* D (input) REAL array, dimension (N) */
+/* The N diagonal elements of the diagonal matrix D. */
+
+/* LLD (input) REAL array, dimension (N-1) */
+/* The (N-1) elements L(i)*L(i)*D(i). */
+
+/* IFIRST (input) INTEGER */
+/* The index of the first eigenvalue to be computed. */
+
+/* ILAST (input) INTEGER */
+/* The index of the last eigenvalue to be computed. */
+
+/* RTOL1 (input) REAL */
+/* RTOL2 (input) REAL */
+/* Tolerance for the convergence of the bisection intervals. */
+/* An interval [LEFT,RIGHT] has converged if */
+/* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */
+/* where GAP is the (estimated) distance to the nearest */
+/* eigenvalue. */
+
+/* OFFSET (input) INTEGER */
+/* Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET */
+/* through ILAST-OFFSET elements of these arrays are to be used. */
+
+/* W (input/output) REAL array, dimension (N) */
+/* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are */
+/* estimates of the eigenvalues of L D L^T indexed IFIRST throug */
+/* ILAST. */
+/* On output, these estimates are refined. */
+
+/* WGAP (input/output) REAL array, dimension (N-1) */
+/* On input, the (estimated) gaps between consecutive */
+/* eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between */
+/* eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST */
+/* then WGAP(IFIRST-OFFSET) must be set to ZERO. */
+/* On output, these gaps are refined. */
+
+/* WERR (input/output) REAL array, dimension (N) */
+/* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are */
+/* the errors in the estimates of the corresponding elements in W. */
+/* On output, these errors are refined. */
+
+/* WORK (workspace) REAL array, dimension (2*N) */
+/* Workspace. */
+
+/* IWORK (workspace) INTEGER array, dimension (2*N) */
+/* Workspace. */
+
+/* PIVMIN (input) DOUBLE PRECISION */
+/* The minimum pivot in the Sturm sequence. */
+
+/* SPDIAM (input) DOUBLE PRECISION */
+/* The spectral diameter of the matrix. */
+
+/* TWIST (input) INTEGER */
+/* The twist index for the twisted factorization that is used */
+/* for the negcount. */
+/* TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T */
+/* TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T */
+/* TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r) */
+
+/* INFO (output) INTEGER */
+/* Error flag. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --werr;
+ --wgap;
+ --w;
+ --lld;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+
+ maxitr = (integer) ((log(*spdiam + *pivmin) - log(*pivmin)) / log(2.f)) +
+ 2;
+ mnwdth = *pivmin * 2.f;
+
+ r__ = *twist;
+ if (r__ < 1 || r__ > *n) {
+ r__ = *n;
+ }
+
+/* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ]. */
+/* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while */
+/* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 ) */
+/* for an unconverged interval is set to the index of the next unconverged */
+/* interval, and is -1 or 0 for a converged interval. Thus a linked */
+/* list of unconverged intervals is set up. */
+
+ i1 = *ifirst;
+/* The number of unconverged intervals */
+ nint = 0;
+/* The last unconverged interval found */
+ prev = 0;
+ rgap = wgap[i1 - *offset];
+ i__1 = *ilast;
+ for (i__ = i1; i__ <= i__1; ++i__) {
+ k = i__ << 1;
+ ii = i__ - *offset;
+ left = w[ii] - werr[ii];
+ right = w[ii] + werr[ii];
+ lgap = rgap;
+ rgap = wgap[ii];
+ gap = dmin(lgap,rgap);
+/* Make sure that [LEFT,RIGHT] contains the desired eigenvalue */
+/* Compute negcount from dstqds facto L+D+L+^T = L D L^T - LEFT */
+
+/* Do while( NEGCNT(LEFT).GT.I-1 ) */
+
+ back = werr[ii];
+L20:
+ negcnt = slaneg_(n, &d__[1], &lld[1], &left, pivmin, &r__);
+ if (negcnt > i__ - 1) {
+ left -= back;
+ back *= 2.f;
+ goto L20;
+ }
+
+/* Do while( NEGCNT(RIGHT).LT.I ) */
+/* Compute negcount from dstqds facto L+D+L+^T = L D L^T - RIGHT */
+
+ back = werr[ii];
+L50:
+ negcnt = slaneg_(n, &d__[1], &lld[1], &right, pivmin, &r__);
+ if (negcnt < i__) {
+ right += back;
+ back *= 2.f;
+ goto L50;
+ }
+ width = (r__1 = left - right, dabs(r__1)) * .5f;
+/* Computing MAX */
+ r__1 = dabs(left), r__2 = dabs(right);
+ tmp = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = *rtol1 * gap, r__2 = *rtol2 * tmp;
+ cvrgd = dmax(r__1,r__2);
+ if (width <= cvrgd || width <= mnwdth) {
+/* This interval has already converged and does not need refinement. */
+/* (Note that the gaps might change through refining the */
+/* eigenvalues, however, they can only get bigger.) */
+/* Remove it from the list. */
+ iwork[k - 1] = -1;
+/* Make sure that I1 always points to the first unconverged interval */
+ if (i__ == i1 && i__ < *ilast) {
+ i1 = i__ + 1;
+ }
+ if (prev >= i1 && i__ <= *ilast) {
+ iwork[(prev << 1) - 1] = i__ + 1;
+ }
+ } else {
+/* unconverged interval found */
+ prev = i__;
+ ++nint;
+ iwork[k - 1] = i__ + 1;
+ iwork[k] = negcnt;
+ }
+ work[k - 1] = left;
+ work[k] = right;
+/* L75: */
+ }
+
+/* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals */
+/* and while (ITER.LT.MAXITR) */
+
+ iter = 0;
+L80:
+ prev = i1 - 1;
+ i__ = i1;
+ olnint = nint;
+ i__1 = olnint;
+ for (ip = 1; ip <= i__1; ++ip) {
+ k = i__ << 1;
+ ii = i__ - *offset;
+ rgap = wgap[ii];
+ lgap = rgap;
+ if (ii > 1) {
+ lgap = wgap[ii - 1];
+ }
+ gap = dmin(lgap,rgap);
+ next = iwork[k - 1];
+ left = work[k - 1];
+ right = work[k];
+ mid = (left + right) * .5f;
+/* semiwidth of interval */
+ width = right - mid;
+/* Computing MAX */
+ r__1 = dabs(left), r__2 = dabs(right);
+ tmp = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = *rtol1 * gap, r__2 = *rtol2 * tmp;
+ cvrgd = dmax(r__1,r__2);
+ if (width <= cvrgd || width <= mnwdth || iter == maxitr) {
+/* reduce number of unconverged intervals */
+ --nint;
+/* Mark interval as converged. */
+ iwork[k - 1] = 0;
+ if (i1 == i__) {
+ i1 = next;
+ } else {
+/* Prev holds the last unconverged interval previously examined */
+ if (prev >= i1) {
+ iwork[(prev << 1) - 1] = next;
+ }
+ }
+ i__ = next;
+ goto L100;
+ }
+ prev = i__;
+
+/* Perform one bisection step */
+
+ negcnt = slaneg_(n, &d__[1], &lld[1], &mid, pivmin, &r__);
+ if (negcnt <= i__ - 1) {
+ work[k - 1] = mid;
+ } else {
+ work[k] = mid;
+ }
+ i__ = next;
+L100:
+ ;
+ }
+ ++iter;
+/* do another loop if there are still unconverged intervals */
+/* However, in the last iteration, all intervals are accepted */
+/* since this is the best we can do. */
+ if (nint > 0 && iter <= maxitr) {
+ goto L80;
+ }
+
+
+/* At this point, all the intervals have converged */
+ i__1 = *ilast;
+ for (i__ = *ifirst; i__ <= i__1; ++i__) {
+ k = i__ << 1;
+ ii = i__ - *offset;
+/* All intervals marked by '0' have been refined. */
+ if (iwork[k - 1] == 0) {
+ w[ii] = (work[k - 1] + work[k]) * .5f;
+ werr[ii] = work[k] - w[ii];
+ }
+/* L110: */
+ }
+
+ i__1 = *ilast;
+ for (i__ = *ifirst + 1; i__ <= i__1; ++i__) {
+ k = i__ << 1;
+ ii = i__ - *offset;
+/* Computing MAX */
+ r__1 = 0.f, r__2 = w[ii] - werr[ii] - w[ii - 1] - werr[ii - 1];
+ wgap[ii - 1] = dmax(r__1,r__2);
+/* L111: */
+ }
+ return 0;
+
+/* End of SLARRB */
+
+} /* slarrb_ */
diff --git a/SRC/slarrc.c b/SRC/slarrc.c
new file mode 100644
index 0000000..d2b7bec
--- /dev/null
+++ b/SRC/slarrc.c
@@ -0,0 +1,183 @@
+/* slarrc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slarrc_(char *jobt, integer *n, real *vl, real *vu, real
+ *d__, real *e, real *pivmin, integer *eigcnt, integer *lcnt, integer *
+ rcnt, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1;
+
+ /* Local variables */
+ integer i__;
+ real sl, su, tmp, tmp2;
+ logical matt;
+ extern logical lsame_(char *, char *);
+ real lpivot, rpivot;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Find the number of eigenvalues of the symmetric tridiagonal matrix T */
+/* that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T */
+/* if JOBT = 'L'. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBT (input) CHARACTER*1 */
+/* = 'T': Compute Sturm count for matrix T. */
+/* = 'L': Compute Sturm count for matrix L D L^T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N > 0. */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* The lower and upper bounds for the eigenvalues. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* JOBT = 'T': The N diagonal elements of the tridiagonal matrix T. */
+/* JOBT = 'L': The N diagonal elements of the diagonal matrix D. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N) */
+/* JOBT = 'T': The N-1 offdiagonal elements of the matrix T. */
+/* JOBT = 'L': The N-1 offdiagonal elements of the matrix L. */
+
+/* PIVMIN (input) DOUBLE PRECISION */
+/* The minimum pivot in the Sturm sequence for T. */
+
+/* EIGCNT (output) INTEGER */
+/* The number of eigenvalues of the symmetric tridiagonal matrix T */
+/* that are in the interval (VL,VU] */
+
+/* LCNT (output) INTEGER */
+/* RCNT (output) INTEGER */
+/* The left and right negcounts of the interval. */
+
+/* INFO (output) INTEGER */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --e;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+ *lcnt = 0;
+ *rcnt = 0;
+ *eigcnt = 0;
+ matt = lsame_(jobt, "T");
+ if (matt) {
+/* Sturm sequence count on T */
+ lpivot = d__[1] - *vl;
+ rpivot = d__[1] - *vu;
+ if (lpivot <= 0.f) {
+ ++(*lcnt);
+ }
+ if (rpivot <= 0.f) {
+ ++(*rcnt);
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing 2nd power */
+ r__1 = e[i__];
+ tmp = r__1 * r__1;
+ lpivot = d__[i__ + 1] - *vl - tmp / lpivot;
+ rpivot = d__[i__ + 1] - *vu - tmp / rpivot;
+ if (lpivot <= 0.f) {
+ ++(*lcnt);
+ }
+ if (rpivot <= 0.f) {
+ ++(*rcnt);
+ }
+/* L10: */
+ }
+ } else {
+/* Sturm sequence count on L D L^T */
+ sl = -(*vl);
+ su = -(*vu);
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ lpivot = d__[i__] + sl;
+ rpivot = d__[i__] + su;
+ if (lpivot <= 0.f) {
+ ++(*lcnt);
+ }
+ if (rpivot <= 0.f) {
+ ++(*rcnt);
+ }
+ tmp = e[i__] * d__[i__] * e[i__];
+
+ tmp2 = tmp / lpivot;
+ if (tmp2 == 0.f) {
+ sl = tmp - *vl;
+ } else {
+ sl = sl * tmp2 - *vl;
+ }
+
+ tmp2 = tmp / rpivot;
+ if (tmp2 == 0.f) {
+ su = tmp - *vu;
+ } else {
+ su = su * tmp2 - *vu;
+ }
+/* L20: */
+ }
+ lpivot = d__[*n] + sl;
+ rpivot = d__[*n] + su;
+ if (lpivot <= 0.f) {
+ ++(*lcnt);
+ }
+ if (rpivot <= 0.f) {
+ ++(*rcnt);
+ }
+ }
+ *eigcnt = *rcnt - *lcnt;
+ return 0;
+
+/* end of SLARRC */
+
+} /* slarrc_ */
diff --git a/SRC/slarrd.c b/SRC/slarrd.c
new file mode 100644
index 0000000..7670ff9
--- /dev/null
+++ b/SRC/slarrd.c
@@ -0,0 +1,790 @@
+/* slarrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+static integer c__0 = 0;
+
+/* Subroutine */ int slarrd_(char *range, char *order, integer *n, real *vl,
+ real *vu, integer *il, integer *iu, real *gers, real *reltol, real *
+ d__, real *e, real *e2, real *pivmin, integer *nsplit, integer *
+ isplit, integer *m, real *w, real *werr, real *wl, real *wu, integer *
+ iblock, integer *indexw, real *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double log(doublereal);
+
+ /* Local variables */
+ integer i__, j, ib, ie, je, nb;
+ real gl;
+ integer im, in;
+ real gu;
+ integer iw, jee;
+ real eps;
+ integer nwl;
+ real wlu, wul;
+ integer nwu;
+ real tmp1, tmp2;
+ integer iend, jblk, ioff, iout, itmp1, itmp2, jdisc;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ real atoli;
+ integer iwoff, itmax;
+ real wkill, rtoli, uflow, tnorm;
+ integer ibegin, irange, idiscl;
+ extern doublereal slamch_(char *);
+ integer idumma[1];
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer idiscu;
+ extern /* Subroutine */ int slaebz_(integer *, integer *, integer *,
+ integer *, integer *, integer *, real *, real *, real *, real *,
+ real *, real *, integer *, real *, real *, integer *, integer *,
+ real *, integer *, integer *);
+ logical ncnvrg, toofew;
+
+
+/* -- LAPACK auxiliary routine (version 3.2.1) -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/* -- April 2009 -- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARRD computes the eigenvalues of a symmetric tridiagonal */
+/* matrix T to suitable accuracy. This is an auxiliary code to be */
+/* called from SSTEMR. */
+/* The user may ask for all eigenvalues, all eigenvalues */
+/* in the half-open interval (VL, VU], or the IL-th through IU-th */
+/* eigenvalues. */
+
+/* To avoid overflow, the matrix must be scaled so that its */
+/* largest element is no greater than overflow**(1/2) * */
+/* underflow**(1/4) in absolute value, and for greatest */
+/* accuracy, it should not be much smaller than that. */
+
+/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */
+/* Matrix", Report CS41, Computer Science Dept., Stanford */
+/* University, July 21, 1966. */
+
+/* Arguments */
+/* ========= */
+
+/* RANGE (input) CHARACTER */
+/* = 'A': ("All") all eigenvalues will be found. */
+/* = 'V': ("Value") all eigenvalues in the half-open interval */
+/* (VL, VU] will be found. */
+/* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the */
+/* entire matrix) will be found. */
+
+/* ORDER (input) CHARACTER */
+/* = 'B': ("By Block") the eigenvalues will be grouped by */
+/* split-off block (see IBLOCK, ISPLIT) and */
+/* ordered from smallest to largest within */
+/* the block. */
+/* = 'E': ("Entire matrix") */
+/* the eigenvalues for the entire matrix */
+/* will be ordered from smallest to */
+/* largest. */
+
+/* N (input) INTEGER */
+/* The order of the tridiagonal matrix T. N >= 0. */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. Eigenvalues less than or equal */
+/* to VL, or greater than VU, will not be returned. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* GERS (input) REAL array, dimension (2*N) */
+/* The N Gerschgorin intervals (the i-th Gerschgorin interval */
+/* is (GERS(2*i-1), GERS(2*i)). */
+
+/* RELTOL (input) REAL */
+/* The minimum relative width of an interval. When an interval */
+/* is narrower than RELTOL times the larger (in */
+/* magnitude) endpoint, then it is considered to be */
+/* sufficiently small, i.e., converged. Note: this should */
+/* always be at least radix*machine epsilon. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix T. */
+
+/* E (input) REAL array, dimension (N-1) */
+/* The (n-1) off-diagonal elements of the tridiagonal matrix T. */
+
+/* E2 (input) REAL array, dimension (N-1) */
+/* The (n-1) squared off-diagonal elements of the tridiagonal matrix T. */
+
+/* PIVMIN (input) REAL */
+/* The minimum pivot allowed in the Sturm sequence for T. */
+
+/* NSPLIT (input) INTEGER */
+/* The number of diagonal blocks in the matrix T. */
+/* 1 <= NSPLIT <= N. */
+
+/* ISPLIT (input) INTEGER array, dimension (N) */
+/* The splitting points, at which T breaks up into submatrices. */
+/* The first submatrix consists of rows/columns 1 to ISPLIT(1), */
+/* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */
+/* etc., and the NSPLIT-th consists of rows/columns */
+/* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */
+/* (Only the first NSPLIT elements will actually be used, but */
+/* since the user cannot know a priori what value NSPLIT will */
+/* have, N words must be reserved for ISPLIT.) */
+
+/* M (output) INTEGER */
+/* The actual number of eigenvalues found. 0 <= M <= N. */
+/* (See also the description of INFO=2,3.) */
+
+/* W (output) REAL array, dimension (N) */
+/* On exit, the first M elements of W will contain the */
+/* eigenvalue approximations. SLARRD computes an interval */
+/* I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue */
+/* approximation is given as the interval midpoint */
+/* W(j)= ( a_j + b_j)/2. The corresponding error is bounded by */
+/* WERR(j) = abs( a_j - b_j)/2 */
+
+/* WERR (output) REAL array, dimension (N) */
+/* The error bound on the corresponding eigenvalue approximation */
+/* in W. */
+
+/* WL (output) REAL */
+/* WU (output) REAL */
+/* The interval (WL, WU] contains all the wanted eigenvalues. */
+/* If RANGE='V', then WL=VL and WU=VU. */
+/* If RANGE='A', then WL and WU are the global Gerschgorin bounds */
+/* on the spectrum. */
+/* If RANGE='I', then WL and WU are computed by SLAEBZ from the */
+/* index range specified. */
+
+/* IBLOCK (output) INTEGER array, dimension (N) */
+/* At each row/column j where E(j) is zero or small, the */
+/* matrix T is considered to split into a block diagonal */
+/* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which */
+/* block (from 1 to the number of blocks) the eigenvalue W(i) */
+/* belongs. (SLARRD may use the remaining N-M elements as */
+/* workspace.) */
+
+/* INDEXW (output) INTEGER array, dimension (N) */
+/* The indices of the eigenvalues within each block (submatrix); */
+/* for example, INDEXW(i)= j and IBLOCK(i)=k imply that the */
+/* i-th eigenvalue W(i) is the j-th eigenvalue in block k. */
+
+/* WORK (workspace) REAL array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: some or all of the eigenvalues failed to converge or */
+/* were not computed: */
+/* =1 or 3: Bisection failed to converge for some */
+/* eigenvalues; these eigenvalues are flagged by a */
+/* negative block number. The effect is that the */
+/* eigenvalues may not be as accurate as the */
+/* absolute and relative tolerances. This is */
+/* generally caused by unexpectedly inaccurate */
+/* arithmetic. */
+/* =2 or 3: RANGE='I' only: Not all of the eigenvalues */
+/* IL:IU were found. */
+/* Effect: M < IU+1-IL */
+/* Cause: non-monotonic arithmetic, causing the */
+/* Sturm sequence to be non-monotonic. */
+/* Cure: recalculate, using RANGE='A', and pick */
+/* out eigenvalues IL:IU. In some cases, */
+/* increasing the PARAMETER "FUDGE" may */
+/* make things work. */
+/* = 4: RANGE='I', and the Gershgorin interval */
+/* initially used was too small. No eigenvalues */
+/* were computed. */
+/* Probable cause: your machine has sloppy */
+/* floating-point arithmetic. */
+/* Cure: Increase the PARAMETER "FUDGE", */
+/* recompile, and try again. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* FUDGE REAL , default = 2 */
+/* A "fudge factor" to widen the Gershgorin intervals. Ideally, */
+/* a value of 1 should work, but on machines with sloppy */
+/* arithmetic, this needs to be larger. The default for */
+/* publicly released versions should be large enough to handle */
+/* the worst machine around. Note that this has no effect */
+/* on accuracy of the solution. */
+
+/* Based on contributions by */
+/* W. Kahan, University of California, Berkeley, USA */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --indexw;
+ --iblock;
+ --werr;
+ --w;
+ --isplit;
+ --e2;
+ --e;
+ --d__;
+ --gers;
+
+ /* Function Body */
+ *info = 0;
+
+/* Decode RANGE */
+
+ if (lsame_(range, "A")) {
+ irange = 1;
+ } else if (lsame_(range, "V")) {
+ irange = 2;
+ } else if (lsame_(range, "I")) {
+ irange = 3;
+ } else {
+ irange = 0;
+ }
+
+/* Check for Errors */
+
+ if (irange <= 0) {
+ *info = -1;
+ } else if (! (lsame_(order, "B") || lsame_(order,
+ "E"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (irange == 2) {
+ if (*vl >= *vu) {
+ *info = -5;
+ }
+ } else if (irange == 3 && (*il < 1 || *il > max(1,*n))) {
+ *info = -6;
+ } else if (irange == 3 && (*iu < min(*n,*il) || *iu > *n)) {
+ *info = -7;
+ }
+
+ if (*info != 0) {
+ return 0;
+ }
+/* Initialize error flags */
+ *info = 0;
+ ncnvrg = FALSE_;
+ toofew = FALSE_;
+/* Quick return if possible */
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+/* Simplification: */
+ if (irange == 3 && *il == 1 && *iu == *n) {
+ irange = 1;
+ }
+/* Get machine constants */
+ eps = slamch_("P");
+ uflow = slamch_("U");
+/* Special Case when N=1 */
+/* Treat case of 1x1 matrix for quick return */
+ if (*n == 1) {
+ if (irange == 1 || irange == 2 && d__[1] > *vl && d__[1] <= *vu ||
+ irange == 3 && *il == 1 && *iu == 1) {
+ *m = 1;
+ w[1] = d__[1];
+/* The computation error of the eigenvalue is zero */
+ werr[1] = 0.f;
+ iblock[1] = 1;
+ indexw[1] = 1;
+ }
+ return 0;
+ }
+/* NB is the minimum vector length for vector bisection, or 0 */
+/* if only scalar is to be done. */
+ nb = ilaenv_(&c__1, "SSTEBZ", " ", n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1) {
+ nb = 0;
+ }
+/* Find global spectral radius */
+ gl = d__[1];
+ gu = d__[1];
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MIN */
+ r__1 = gl, r__2 = gers[(i__ << 1) - 1];
+ gl = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = gu, r__2 = gers[i__ * 2];
+ gu = dmax(r__1,r__2);
+/* L5: */
+ }
+/* Compute global Gerschgorin bounds and spectral diameter */
+/* Computing MAX */
+ r__1 = dabs(gl), r__2 = dabs(gu);
+ tnorm = dmax(r__1,r__2);
+ gl = gl - tnorm * 2.f * eps * *n - *pivmin * 4.f;
+ gu = gu + tnorm * 2.f * eps * *n + *pivmin * 4.f;
+/* [JAN/28/2009] remove the line below since SPDIAM variable not use */
+/* SPDIAM = GU - GL */
+/* Input arguments for SLAEBZ: */
+/* The relative tolerance. An interval (a,b] lies within */
+/* "relative tolerance" if b-a < RELTOL*max(|a|,|b|), */
+ rtoli = *reltol;
+/* Set the absolute tolerance for interval convergence to zero to force */
+/* interval convergence based on relative size of the interval. */
+/* This is dangerous because intervals might not converge when RELTOL is */
+/* small. But at least a very small number should be selected so that for */
+/* strongly graded matrices, the code can get relatively accurate */
+/* eigenvalues. */
+ atoli = uflow * 4.f + *pivmin * 4.f;
+ if (irange == 3) {
+/* RANGE='I': Compute an interval containing eigenvalues */
+/* IL through IU. The initial interval [GL,GU] from the global */
+/* Gerschgorin bounds GL and GU is refined by SLAEBZ. */
+ itmax = (integer) ((log(tnorm + *pivmin) - log(*pivmin)) / log(2.f))
+ + 2;
+ work[*n + 1] = gl;
+ work[*n + 2] = gl;
+ work[*n + 3] = gu;
+ work[*n + 4] = gu;
+ work[*n + 5] = gl;
+ work[*n + 6] = gu;
+ iwork[1] = -1;
+ iwork[2] = -1;
+ iwork[3] = *n + 1;
+ iwork[4] = *n + 1;
+ iwork[5] = *il - 1;
+ iwork[6] = *iu;
+
+ slaebz_(&c__3, &itmax, n, &c__2, &c__2, &nb, &atoli, &rtoli, pivmin, &
+ d__[1], &e[1], &e2[1], &iwork[5], &work[*n + 1], &work[*n + 5]
+, &iout, &iwork[1], &w[1], &iblock[1], &iinfo);
+ if (iinfo != 0) {
+ *info = iinfo;
+ return 0;
+ }
+/* On exit, output intervals may not be ordered by ascending negcount */
+ if (iwork[6] == *iu) {
+ *wl = work[*n + 1];
+ wlu = work[*n + 3];
+ nwl = iwork[1];
+ *wu = work[*n + 4];
+ wul = work[*n + 2];
+ nwu = iwork[4];
+ } else {
+ *wl = work[*n + 2];
+ wlu = work[*n + 4];
+ nwl = iwork[2];
+ *wu = work[*n + 3];
+ wul = work[*n + 1];
+ nwu = iwork[3];
+ }
+/* On exit, the interval [WL, WLU] contains a value with negcount NWL, */
+/* and [WUL, WU] contains a value with negcount NWU. */
+ if (nwl < 0 || nwl >= *n || nwu < 1 || nwu > *n) {
+ *info = 4;
+ return 0;
+ }
+ } else if (irange == 2) {
+ *wl = *vl;
+ *wu = *vu;
+ } else if (irange == 1) {
+ *wl = gl;
+ *wu = gu;
+ }
+/* Find Eigenvalues -- Loop Over blocks and recompute NWL and NWU. */
+/* NWL accumulates the number of eigenvalues .le. WL, */
+/* NWU accumulates the number of eigenvalues .le. WU */
+ *m = 0;
+ iend = 0;
+ *info = 0;
+ nwl = 0;
+ nwu = 0;
+
+ i__1 = *nsplit;
+ for (jblk = 1; jblk <= i__1; ++jblk) {
+ ioff = iend;
+ ibegin = ioff + 1;
+ iend = isplit[jblk];
+ in = iend - ioff;
+
+ if (in == 1) {
+/* 1x1 block */
+ if (*wl >= d__[ibegin] - *pivmin) {
+ ++nwl;
+ }
+ if (*wu >= d__[ibegin] - *pivmin) {
+ ++nwu;
+ }
+ if (irange == 1 || *wl < d__[ibegin] - *pivmin && *wu >= d__[
+ ibegin] - *pivmin) {
+ ++(*m);
+ w[*m] = d__[ibegin];
+ werr[*m] = 0.f;
+/* The gap for a single block doesn't matter for the later */
+/* algorithm and is assigned an arbitrary large value */
+ iblock[*m] = jblk;
+ indexw[*m] = 1;
+ }
+/* Disabled 2x2 case because of a failure on the following matrix */
+/* RANGE = 'I', IL = IU = 4 */
+/* Original Tridiagonal, d = [ */
+/* -0.150102010615740E+00 */
+/* -0.849897989384260E+00 */
+/* -0.128208148052635E-15 */
+/* 0.128257718286320E-15 */
+/* ]; */
+/* e = [ */
+/* -0.357171383266986E+00 */
+/* -0.180411241501588E-15 */
+/* -0.175152352710251E-15 */
+/* ]; */
+
+/* ELSE IF( IN.EQ.2 ) THEN */
+/* * 2x2 block */
+/* DISC = SQRT( (HALF*(D(IBEGIN)-D(IEND)))**2 + E(IBEGIN)**2 ) */
+/* TMP1 = HALF*(D(IBEGIN)+D(IEND)) */
+/* L1 = TMP1 - DISC */
+/* IF( WL.GE. L1-PIVMIN ) */
+/* $ NWL = NWL + 1 */
+/* IF( WU.GE. L1-PIVMIN ) */
+/* $ NWU = NWU + 1 */
+/* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L1-PIVMIN .AND. WU.GE. */
+/* $ L1-PIVMIN ) ) THEN */
+/* M = M + 1 */
+/* W( M ) = L1 */
+/* * The uncertainty of eigenvalues of a 2x2 matrix is very small */
+/* WERR( M ) = EPS * ABS( W( M ) ) * TWO */
+/* IBLOCK( M ) = JBLK */
+/* INDEXW( M ) = 1 */
+/* ENDIF */
+/* L2 = TMP1 + DISC */
+/* IF( WL.GE. L2-PIVMIN ) */
+/* $ NWL = NWL + 1 */
+/* IF( WU.GE. L2-PIVMIN ) */
+/* $ NWU = NWU + 1 */
+/* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L2-PIVMIN .AND. WU.GE. */
+/* $ L2-PIVMIN ) ) THEN */
+/* M = M + 1 */
+/* W( M ) = L2 */
+/* * The uncertainty of eigenvalues of a 2x2 matrix is very small */
+/* WERR( M ) = EPS * ABS( W( M ) ) * TWO */
+/* IBLOCK( M ) = JBLK */
+/* INDEXW( M ) = 2 */
+/* ENDIF */
+ } else {
+/* General Case - block of size IN >= 2 */
+/* Compute local Gerschgorin interval and use it as the initial */
+/* interval for SLAEBZ */
+ gu = d__[ibegin];
+ gl = d__[ibegin];
+ tmp1 = 0.f;
+ i__2 = iend;
+ for (j = ibegin; j <= i__2; ++j) {
+/* Computing MIN */
+ r__1 = gl, r__2 = gers[(j << 1) - 1];
+ gl = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = gu, r__2 = gers[j * 2];
+ gu = dmax(r__1,r__2);
+/* L40: */
+ }
+/* [JAN/28/2009] */
+/* change SPDIAM by TNORM in lines 2 and 3 thereafter */
+/* line 1: remove computation of SPDIAM (not useful anymore) */
+/* SPDIAM = GU - GL */
+/* GL = GL - FUDGE*SPDIAM*EPS*IN - FUDGE*PIVMIN */
+/* GU = GU + FUDGE*SPDIAM*EPS*IN + FUDGE*PIVMIN */
+ gl = gl - tnorm * 2.f * eps * in - *pivmin * 2.f;
+ gu = gu + tnorm * 2.f * eps * in + *pivmin * 2.f;
+
+ if (irange > 1) {
+ if (gu < *wl) {
+/* the local block contains none of the wanted eigenvalues */
+ nwl += in;
+ nwu += in;
+ goto L70;
+ }
+/* refine search interval if possible, only range (WL,WU] matters */
+ gl = dmax(gl,*wl);
+ gu = dmin(gu,*wu);
+ if (gl >= gu) {
+ goto L70;
+ }
+ }
+/* Find negcount of initial interval boundaries GL and GU */
+ work[*n + 1] = gl;
+ work[*n + in + 1] = gu;
+ slaebz_(&c__1, &c__0, &in, &in, &c__1, &nb, &atoli, &rtoli,
+ pivmin, &d__[ibegin], &e[ibegin], &e2[ibegin], idumma, &
+ work[*n + 1], &work[*n + (in << 1) + 1], &im, &iwork[1], &
+ w[*m + 1], &iblock[*m + 1], &iinfo);
+ if (iinfo != 0) {
+ *info = iinfo;
+ return 0;
+ }
+
+ nwl += iwork[1];
+ nwu += iwork[in + 1];
+ iwoff = *m - iwork[1];
+/* Compute Eigenvalues */
+ itmax = (integer) ((log(gu - gl + *pivmin) - log(*pivmin)) / log(
+ 2.f)) + 2;
+ slaebz_(&c__2, &itmax, &in, &in, &c__1, &nb, &atoli, &rtoli,
+ pivmin, &d__[ibegin], &e[ibegin], &e2[ibegin], idumma, &
+ work[*n + 1], &work[*n + (in << 1) + 1], &iout, &iwork[1],
+ &w[*m + 1], &iblock[*m + 1], &iinfo);
+ if (iinfo != 0) {
+ *info = iinfo;
+ return 0;
+ }
+
+/* Copy eigenvalues into W and IBLOCK */
+/* Use -JBLK for block number for unconverged eigenvalues. */
+/* Loop over the number of output intervals from SLAEBZ */
+ i__2 = iout;
+ for (j = 1; j <= i__2; ++j) {
+/* eigenvalue approximation is middle point of interval */
+ tmp1 = (work[j + *n] + work[j + in + *n]) * .5f;
+/* semi length of error interval */
+ tmp2 = (r__1 = work[j + *n] - work[j + in + *n], dabs(r__1)) *
+ .5f;
+ if (j > iout - iinfo) {
+/* Flag non-convergence. */
+ ncnvrg = TRUE_;
+ ib = -jblk;
+ } else {
+ ib = jblk;
+ }
+ i__3 = iwork[j + in] + iwoff;
+ for (je = iwork[j] + 1 + iwoff; je <= i__3; ++je) {
+ w[je] = tmp1;
+ werr[je] = tmp2;
+ indexw[je] = je - iwoff;
+ iblock[je] = ib;
+/* L50: */
+ }
+/* L60: */
+ }
+
+ *m += im;
+ }
+L70:
+ ;
+ }
+/* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU */
+/* If NWL+1 < IL or NWU > IU, discard extra eigenvalues. */
+ if (irange == 3) {
+ idiscl = *il - 1 - nwl;
+ idiscu = nwu - *iu;
+
+ if (idiscl > 0) {
+ im = 0;
+ i__1 = *m;
+ for (je = 1; je <= i__1; ++je) {
+/* Remove some of the smallest eigenvalues from the left so that */
+/* at the end IDISCL =0. Move all eigenvalues up to the left. */
+ if (w[je] <= wlu && idiscl > 0) {
+ --idiscl;
+ } else {
+ ++im;
+ w[im] = w[je];
+ werr[im] = werr[je];
+ indexw[im] = indexw[je];
+ iblock[im] = iblock[je];
+ }
+/* L80: */
+ }
+ *m = im;
+ }
+ if (idiscu > 0) {
+/* Remove some of the largest eigenvalues from the right so that */
+/* at the end IDISCU =0. Move all eigenvalues up to the left. */
+ im = *m + 1;
+ for (je = *m; je >= 1; --je) {
+ if (w[je] >= wul && idiscu > 0) {
+ --idiscu;
+ } else {
+ --im;
+ w[im] = w[je];
+ werr[im] = werr[je];
+ indexw[im] = indexw[je];
+ iblock[im] = iblock[je];
+ }
+/* L81: */
+ }
+ jee = 0;
+ i__1 = *m;
+ for (je = im; je <= i__1; ++je) {
+ ++jee;
+ w[jee] = w[je];
+ werr[jee] = werr[je];
+ indexw[jee] = indexw[je];
+ iblock[jee] = iblock[je];
+/* L82: */
+ }
+ *m = *m - im + 1;
+ }
+ if (idiscl > 0 || idiscu > 0) {
+/* Code to deal with effects of bad arithmetic. (If N(w) is */
+/* monotone non-decreasing, this should never happen.) */
+/* Some low eigenvalues to be discarded are not in (WL,WLU], */
+/* or high eigenvalues to be discarded are not in (WUL,WU] */
+/* so just kill off the smallest IDISCL/largest IDISCU */
+/* eigenvalues, by marking the corresponding IBLOCK = 0 */
+ if (idiscl > 0) {
+ wkill = *wu;
+ i__1 = idiscl;
+ for (jdisc = 1; jdisc <= i__1; ++jdisc) {
+ iw = 0;
+ i__2 = *m;
+ for (je = 1; je <= i__2; ++je) {
+ if (iblock[je] != 0 && (w[je] < wkill || iw == 0)) {
+ iw = je;
+ wkill = w[je];
+ }
+/* L90: */
+ }
+ iblock[iw] = 0;
+/* L100: */
+ }
+ }
+ if (idiscu > 0) {
+ wkill = *wl;
+ i__1 = idiscu;
+ for (jdisc = 1; jdisc <= i__1; ++jdisc) {
+ iw = 0;
+ i__2 = *m;
+ for (je = 1; je <= i__2; ++je) {
+ if (iblock[je] != 0 && (w[je] >= wkill || iw == 0)) {
+ iw = je;
+ wkill = w[je];
+ }
+/* L110: */
+ }
+ iblock[iw] = 0;
+/* L120: */
+ }
+ }
+/* Now erase all eigenvalues with IBLOCK set to zero */
+ im = 0;
+ i__1 = *m;
+ for (je = 1; je <= i__1; ++je) {
+ if (iblock[je] != 0) {
+ ++im;
+ w[im] = w[je];
+ werr[im] = werr[je];
+ indexw[im] = indexw[je];
+ iblock[im] = iblock[je];
+ }
+/* L130: */
+ }
+ *m = im;
+ }
+ if (idiscl < 0 || idiscu < 0) {
+ toofew = TRUE_;
+ }
+ }
+
+ if (irange == 1 && *m != *n || irange == 3 && *m != *iu - *il + 1) {
+ toofew = TRUE_;
+ }
+/* If ORDER='B', do nothing the eigenvalues are already sorted by */
+/* block. */
+/* If ORDER='E', sort the eigenvalues from smallest to largest */
+ if (lsame_(order, "E") && *nsplit > 1) {
+ i__1 = *m - 1;
+ for (je = 1; je <= i__1; ++je) {
+ ie = 0;
+ tmp1 = w[je];
+ i__2 = *m;
+ for (j = je + 1; j <= i__2; ++j) {
+ if (w[j] < tmp1) {
+ ie = j;
+ tmp1 = w[j];
+ }
+/* L140: */
+ }
+ if (ie != 0) {
+ tmp2 = werr[ie];
+ itmp1 = iblock[ie];
+ itmp2 = indexw[ie];
+ w[ie] = w[je];
+ werr[ie] = werr[je];
+ iblock[ie] = iblock[je];
+ indexw[ie] = indexw[je];
+ w[je] = tmp1;
+ werr[je] = tmp2;
+ iblock[je] = itmp1;
+ indexw[je] = itmp2;
+ }
+/* L150: */
+ }
+ }
+
+ *info = 0;
+ if (ncnvrg) {
+ ++(*info);
+ }
+ if (toofew) {
+ *info += 2;
+ }
+ return 0;
+
+/* End of SLARRD */
+
+} /* slarrd_ */
diff --git a/SRC/slarre.c b/SRC/slarre.c
new file mode 100644
index 0000000..0fd7a29
--- /dev/null
+++ b/SRC/slarre.c
@@ -0,0 +1,857 @@
+/* slarre.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int slarre_(char *range, integer *n, real *vl, real *vu,
+ integer *il, integer *iu, real *d__, real *e, real *e2, real *rtol1,
+ real *rtol2, real *spltol, integer *nsplit, integer *isplit, integer *
+ m, real *w, real *werr, real *wgap, integer *iblock, integer *indexw,
+ real *gers, real *pivmin, real *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal), log(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ real s1, s2;
+ integer mb;
+ real gl;
+ integer in, mm;
+ real gu;
+ integer cnt;
+ real eps, tau, tmp, rtl;
+ integer cnt1, cnt2;
+ real tmp1, eabs;
+ integer iend, jblk;
+ real eold;
+ integer indl;
+ real dmax__, emax;
+ integer wend, idum, indu;
+ real rtol;
+ integer iseed[4];
+ real avgap, sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical norep;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), slasq2_(integer *, real *, integer *);
+ integer ibegin;
+ logical forceb;
+ integer irange;
+ real sgndef;
+ extern doublereal slamch_(char *);
+ integer wbegin;
+ real safmin, spdiam;
+ extern /* Subroutine */ int slarra_(integer *, real *, real *, real *,
+ real *, real *, integer *, integer *, integer *);
+ logical usedqd;
+ real clwdth, isleft;
+ extern /* Subroutine */ int slarrb_(integer *, real *, real *, integer *,
+ integer *, real *, real *, integer *, real *, real *, real *,
+ real *, integer *, real *, real *, integer *, integer *), slarrc_(
+ char *, integer *, real *, real *, real *, real *, real *,
+ integer *, integer *, integer *, integer *), slarrd_(char
+ *, char *, integer *, real *, real *, integer *, integer *, real *
+, real *, real *, real *, real *, real *, integer *, integer *,
+ integer *, real *, real *, real *, real *, integer *, integer *,
+ real *, integer *, integer *), slarrk_(integer *,
+ integer *, real *, real *, real *, real *, real *, real *, real *,
+ real *, integer *);
+ real isrght, bsrtol, dpivot;
+ extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
+ *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* To find the desired eigenvalues of a given real symmetric */
+/* tridiagonal matrix T, SLARRE sets any "small" off-diagonal */
+/* elements to zero, and for each unreduced block T_i, it finds */
+/* (a) a suitable shift at one end of the block's spectrum, */
+/* (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and */
+/* (c) eigenvalues of each L_i D_i L_i^T. */
+/* The representations and eigenvalues found are then used by */
+/* SSTEMR to compute the eigenvectors of T. */
+/* The accuracy varies depending on whether bisection is used to */
+/* find a few eigenvalues or the dqds algorithm (subroutine SLASQ2) to */
+/* conpute all and then discard any unwanted one. */
+/* As an added benefit, SLARRE also outputs the n */
+/* Gerschgorin intervals for the matrices L_i D_i L_i^T. */
+
+/* Arguments */
+/* ========= */
+
+/* RANGE (input) CHARACTER */
+/* = 'A': ("All") all eigenvalues will be found. */
+/* = 'V': ("Value") all eigenvalues in the half-open interval */
+/* (VL, VU] will be found. */
+/* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the */
+/* entire matrix) will be found. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N > 0. */
+
+/* VL (input/output) REAL */
+/* VU (input/output) REAL */
+/* If RANGE='V', the lower and upper bounds for the eigenvalues. */
+/* Eigenvalues less than or equal to VL, or greater than VU, */
+/* will not be returned. VL < VU. */
+/* If RANGE='I' or ='A', SLARRE computes bounds on the desired */
+/* part of the spectrum. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the N diagonal elements of the tridiagonal */
+/* matrix T. */
+/* On exit, the N diagonal elements of the diagonal */
+/* matrices D_i. */
+
+/* E (input/output) REAL array, dimension (N) */
+/* On entry, the first (N-1) entries contain the subdiagonal */
+/* elements of the tridiagonal matrix T; E(N) need not be set. */
+/* On exit, E contains the subdiagonal elements of the unit */
+/* bidiagonal matrices L_i. The entries E( ISPLIT( I ) ), */
+/* 1 <= I <= NSPLIT, contain the base points sigma_i on output. */
+
+/* E2 (input/output) REAL array, dimension (N) */
+/* On entry, the first (N-1) entries contain the SQUARES of the */
+/* subdiagonal elements of the tridiagonal matrix T; */
+/* E2(N) need not be set. */
+/* On exit, the entries E2( ISPLIT( I ) ), */
+/* 1 <= I <= NSPLIT, have been set to zero */
+
+/* RTOL1 (input) REAL */
+/* RTOL2 (input) REAL */
+/* Parameters for bisection. */
+/* An interval [LEFT,RIGHT] has converged if */
+/* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */
+
+/* SPLTOL (input) REAL */
+/* The threshold for splitting. */
+
+/* NSPLIT (output) INTEGER */
+/* The number of blocks T splits into. 1 <= NSPLIT <= N. */
+
+/* ISPLIT (output) INTEGER array, dimension (N) */
+/* The splitting points, at which T breaks up into blocks. */
+/* The first block consists of rows/columns 1 to ISPLIT(1), */
+/* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */
+/* etc., and the NSPLIT-th consists of rows/columns */
+/* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues (of all L_i D_i L_i^T) */
+/* found. */
+
+/* W (output) REAL array, dimension (N) */
+/* The first M elements contain the eigenvalues. The */
+/* eigenvalues of each of the blocks, L_i D_i L_i^T, are */
+/* sorted in ascending order ( SLARRE may use the */
+/* remaining N-M elements as workspace). */
+
+/* WERR (output) REAL array, dimension (N) */
+/* The error bound on the corresponding eigenvalue in W. */
+
+/* WGAP (output) REAL array, dimension (N) */
+/* The separation from the right neighbor eigenvalue in W. */
+/* The gap is only with respect to the eigenvalues of the same block */
+/* as each block has its own representation tree. */
+/* Exception: at the right end of a block we store the left gap */
+
+/* IBLOCK (output) INTEGER array, dimension (N) */
+/* The indices of the blocks (submatrices) associated with the */
+/* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue */
+/* W(i) belongs to the first block from the top, =2 if W(i) */
+/* belongs to the second block, etc. */
+
+/* INDEXW (output) INTEGER array, dimension (N) */
+/* The indices of the eigenvalues within each block (submatrix); */
+/* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the */
+/* i-th eigenvalue W(i) is the 10-th eigenvalue in block 2 */
+
+/* GERS (output) REAL array, dimension (2*N) */
+/* The N Gerschgorin intervals (the i-th Gerschgorin interval */
+/* is (GERS(2*i-1), GERS(2*i)). */
+
+/* PIVMIN (output) DOUBLE PRECISION */
+/* The minimum pivot in the Sturm sequence for T. */
+
+/* WORK (workspace) REAL array, dimension (6*N) */
+/* Workspace. */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+/* Workspace. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* > 0: A problem occured in SLARRE. */
+/* < 0: One of the called subroutines signaled an internal problem. */
+/* Needs inspection of the corresponding parameter IINFO */
+/* for further information. */
+
+/* =-1: Problem in SLARRD. */
+/* = 2: No base representation could be found in MAXTRY iterations. */
+/* Increasing MAXTRY and recompilation might be a remedy. */
+/* =-3: Problem in SLARRB when computing the refined root */
+/* representation for SLASQ2. */
+/* =-4: Problem in SLARRB when preforming bisection on the */
+/* desired part of the spectrum. */
+/* =-5: Problem in SLASQ2. */
+/* =-6: Problem in SLASQ2. */
+
+/* Further Details */
+/* The base representations are required to suffer very little */
+/* element growth and consequently define all their eigenvalues to */
+/* high relative accuracy. */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --gers;
+ --indexw;
+ --iblock;
+ --wgap;
+ --werr;
+ --w;
+ --isplit;
+ --e2;
+ --e;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+
+/* Decode RANGE */
+
+ if (lsame_(range, "A")) {
+ irange = 1;
+ } else if (lsame_(range, "V")) {
+ irange = 3;
+ } else if (lsame_(range, "I")) {
+ irange = 2;
+ }
+ *m = 0;
+/* Get machine constants */
+ safmin = slamch_("S");
+ eps = slamch_("P");
+/* Set parameters */
+ rtl = eps * 100.f;
+/* If one were ever to ask for less initial precision in BSRTOL, */
+/* one should keep in mind that for the subset case, the extremal */
+/* eigenvalues must be at least as accurate as the current setting */
+/* (eigenvalues in the middle need not as much accuracy) */
+ bsrtol = sqrt(eps) * 5e-4f;
+/* Treat case of 1x1 matrix for quick return */
+ if (*n == 1) {
+ if (irange == 1 || irange == 3 && d__[1] > *vl && d__[1] <= *vu ||
+ irange == 2 && *il == 1 && *iu == 1) {
+ *m = 1;
+ w[1] = d__[1];
+/* The computation error of the eigenvalue is zero */
+ werr[1] = 0.f;
+ wgap[1] = 0.f;
+ iblock[1] = 1;
+ indexw[1] = 1;
+ gers[1] = d__[1];
+ gers[2] = d__[1];
+ }
+/* store the shift for the initial RRR, which is zero in this case */
+ e[1] = 0.f;
+ return 0;
+ }
+/* General case: tridiagonal matrix of order > 1 */
+
+/* Init WERR, WGAP. Compute Gerschgorin intervals and spectral diameter. */
+/* Compute maximum off-diagonal entry and pivmin. */
+ gl = d__[1];
+ gu = d__[1];
+ eold = 0.f;
+ emax = 0.f;
+ e[*n] = 0.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ werr[i__] = 0.f;
+ wgap[i__] = 0.f;
+ eabs = (r__1 = e[i__], dabs(r__1));
+ if (eabs >= emax) {
+ emax = eabs;
+ }
+ tmp1 = eabs + eold;
+ gers[(i__ << 1) - 1] = d__[i__] - tmp1;
+/* Computing MIN */
+ r__1 = gl, r__2 = gers[(i__ << 1) - 1];
+ gl = dmin(r__1,r__2);
+ gers[i__ * 2] = d__[i__] + tmp1;
+/* Computing MAX */
+ r__1 = gu, r__2 = gers[i__ * 2];
+ gu = dmax(r__1,r__2);
+ eold = eabs;
+/* L5: */
+ }
+/* The minimum pivot allowed in the Sturm sequence for T */
+/* Computing MAX */
+/* Computing 2nd power */
+ r__3 = emax;
+ r__1 = 1.f, r__2 = r__3 * r__3;
+ *pivmin = safmin * dmax(r__1,r__2);
+/* Compute spectral diameter. The Gerschgorin bounds give an */
+/* estimate that is wrong by at most a factor of SQRT(2) */
+ spdiam = gu - gl;
+/* Compute splitting points */
+ slarra_(n, &d__[1], &e[1], &e2[1], spltol, &spdiam, nsplit, &isplit[1], &
+ iinfo);
+/* Can force use of bisection instead of faster DQDS. */
+/* Option left in the code for future multisection work. */
+ forceb = FALSE_;
+/* Initialize USEDQD, DQDS should be used for ALLRNG unless someone */
+/* explicitly wants bisection. */
+ usedqd = irange == 1 && ! forceb;
+ if (irange == 1 && ! forceb) {
+/* Set interval [VL,VU] that contains all eigenvalues */
+ *vl = gl;
+ *vu = gu;
+ } else {
+/* We call SLARRD to find crude approximations to the eigenvalues */
+/* in the desired range. In case IRANGE = INDRNG, we also obtain the */
+/* interval (VL,VU] that contains all the wanted eigenvalues. */
+/* An interval [LEFT,RIGHT] has converged if */
+/* RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT)) */
+/* SLARRD needs a WORK of size 4*N, IWORK of size 3*N */
+ slarrd_(range, "B", n, vl, vu, il, iu, &gers[1], &bsrtol, &d__[1], &e[
+ 1], &e2[1], pivmin, nsplit, &isplit[1], &mm, &w[1], &werr[1],
+ vl, vu, &iblock[1], &indexw[1], &work[1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ *info = -1;
+ return 0;
+ }
+/* Make sure that the entries M+1 to N in W, WERR, IBLOCK, INDEXW are 0 */
+ i__1 = *n;
+ for (i__ = mm + 1; i__ <= i__1; ++i__) {
+ w[i__] = 0.f;
+ werr[i__] = 0.f;
+ iblock[i__] = 0;
+ indexw[i__] = 0;
+/* L14: */
+ }
+ }
+/* ** */
+/* Loop over unreduced blocks */
+ ibegin = 1;
+ wbegin = 1;
+ i__1 = *nsplit;
+ for (jblk = 1; jblk <= i__1; ++jblk) {
+ iend = isplit[jblk];
+ in = iend - ibegin + 1;
+/* 1 X 1 block */
+ if (in == 1) {
+ if (irange == 1 || irange == 3 && d__[ibegin] > *vl && d__[ibegin]
+ <= *vu || irange == 2 && iblock[wbegin] == jblk) {
+ ++(*m);
+ w[*m] = d__[ibegin];
+ werr[*m] = 0.f;
+/* The gap for a single block doesn't matter for the later */
+/* algorithm and is assigned an arbitrary large value */
+ wgap[*m] = 0.f;
+ iblock[*m] = jblk;
+ indexw[*m] = 1;
+ ++wbegin;
+ }
+/* E( IEND ) holds the shift for the initial RRR */
+ e[iend] = 0.f;
+ ibegin = iend + 1;
+ goto L170;
+ }
+
+/* Blocks of size larger than 1x1 */
+
+/* E( IEND ) will hold the shift for the initial RRR, for now set it =0 */
+ e[iend] = 0.f;
+
+/* Find local outer bounds GL,GU for the block */
+ gl = d__[ibegin];
+ gu = d__[ibegin];
+ i__2 = iend;
+ for (i__ = ibegin; i__ <= i__2; ++i__) {
+/* Computing MIN */
+ r__1 = gers[(i__ << 1) - 1];
+ gl = dmin(r__1,gl);
+/* Computing MAX */
+ r__1 = gers[i__ * 2];
+ gu = dmax(r__1,gu);
+/* L15: */
+ }
+ spdiam = gu - gl;
+ if (! (irange == 1 && ! forceb)) {
+/* Count the number of eigenvalues in the current block. */
+ mb = 0;
+ i__2 = mm;
+ for (i__ = wbegin; i__ <= i__2; ++i__) {
+ if (iblock[i__] == jblk) {
+ ++mb;
+ } else {
+ goto L21;
+ }
+/* L20: */
+ }
+L21:
+ if (mb == 0) {
+/* No eigenvalue in the current block lies in the desired range */
+/* E( IEND ) holds the shift for the initial RRR */
+ e[iend] = 0.f;
+ ibegin = iend + 1;
+ goto L170;
+ } else {
+/* Decide whether dqds or bisection is more efficient */
+ usedqd = (real) mb > in * .5f && ! forceb;
+ wend = wbegin + mb - 1;
+/* Calculate gaps for the current block */
+/* In later stages, when representations for individual */
+/* eigenvalues are different, we use SIGMA = E( IEND ). */
+ sigma = 0.f;
+ i__2 = wend - 1;
+ for (i__ = wbegin; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = 0.f, r__2 = w[i__ + 1] - werr[i__ + 1] - (w[i__] +
+ werr[i__]);
+ wgap[i__] = dmax(r__1,r__2);
+/* L30: */
+ }
+/* Computing MAX */
+ r__1 = 0.f, r__2 = *vu - sigma - (w[wend] + werr[wend]);
+ wgap[wend] = dmax(r__1,r__2);
+/* Find local index of the first and last desired evalue. */
+ indl = indexw[wbegin];
+ indu = indexw[wend];
+ }
+ }
+ if (irange == 1 && ! forceb || usedqd) {
+/* Case of DQDS */
+/* Find approximations to the extremal eigenvalues of the block */
+ slarrk_(&in, &c__1, &gl, &gu, &d__[ibegin], &e2[ibegin], pivmin, &
+ rtl, &tmp, &tmp1, &iinfo);
+ if (iinfo != 0) {
+ *info = -1;
+ return 0;
+ }
+/* Computing MAX */
+ r__2 = gl, r__3 = tmp - tmp1 - eps * 100.f * (r__1 = tmp - tmp1,
+ dabs(r__1));
+ isleft = dmax(r__2,r__3);
+ slarrk_(&in, &in, &gl, &gu, &d__[ibegin], &e2[ibegin], pivmin, &
+ rtl, &tmp, &tmp1, &iinfo);
+ if (iinfo != 0) {
+ *info = -1;
+ return 0;
+ }
+/* Computing MIN */
+ r__2 = gu, r__3 = tmp + tmp1 + eps * 100.f * (r__1 = tmp + tmp1,
+ dabs(r__1));
+ isrght = dmin(r__2,r__3);
+/* Improve the estimate of the spectral diameter */
+ spdiam = isrght - isleft;
+ } else {
+/* Case of bisection */
+/* Find approximations to the wanted extremal eigenvalues */
+/* Computing MAX */
+ r__2 = gl, r__3 = w[wbegin] - werr[wbegin] - eps * 100.f * (r__1 =
+ w[wbegin] - werr[wbegin], dabs(r__1));
+ isleft = dmax(r__2,r__3);
+/* Computing MIN */
+ r__2 = gu, r__3 = w[wend] + werr[wend] + eps * 100.f * (r__1 = w[
+ wend] + werr[wend], dabs(r__1));
+ isrght = dmin(r__2,r__3);
+ }
+/* Decide whether the base representation for the current block */
+/* L_JBLK D_JBLK L_JBLK^T = T_JBLK - sigma_JBLK I */
+/* should be on the left or the right end of the current block. */
+/* The strategy is to shift to the end which is "more populated" */
+/* Furthermore, decide whether to use DQDS for the computation of */
+/* the eigenvalue approximations at the end of SLARRE or bisection. */
+/* dqds is chosen if all eigenvalues are desired or the number of */
+/* eigenvalues to be computed is large compared to the blocksize. */
+ if (irange == 1 && ! forceb) {
+/* If all the eigenvalues have to be computed, we use dqd */
+ usedqd = TRUE_;
+/* INDL is the local index of the first eigenvalue to compute */
+ indl = 1;
+ indu = in;
+/* MB = number of eigenvalues to compute */
+ mb = in;
+ wend = wbegin + mb - 1;
+/* Define 1/4 and 3/4 points of the spectrum */
+ s1 = isleft + spdiam * .25f;
+ s2 = isrght - spdiam * .25f;
+ } else {
+/* SLARRD has computed IBLOCK and INDEXW for each eigenvalue */
+/* approximation. */
+/* choose sigma */
+ if (usedqd) {
+ s1 = isleft + spdiam * .25f;
+ s2 = isrght - spdiam * .25f;
+ } else {
+ tmp = dmin(isrght,*vu) - dmax(isleft,*vl);
+ s1 = dmax(isleft,*vl) + tmp * .25f;
+ s2 = dmin(isrght,*vu) - tmp * .25f;
+ }
+ }
+/* Compute the negcount at the 1/4 and 3/4 points */
+ if (mb > 1) {
+ slarrc_("T", &in, &s1, &s2, &d__[ibegin], &e[ibegin], pivmin, &
+ cnt, &cnt1, &cnt2, &iinfo);
+ }
+ if (mb == 1) {
+ sigma = gl;
+ sgndef = 1.f;
+ } else if (cnt1 - indl >= indu - cnt2) {
+ if (irange == 1 && ! forceb) {
+ sigma = dmax(isleft,gl);
+ } else if (usedqd) {
+/* use Gerschgorin bound as shift to get pos def matrix */
+/* for dqds */
+ sigma = isleft;
+ } else {
+/* use approximation of the first desired eigenvalue of the */
+/* block as shift */
+ sigma = dmax(isleft,*vl);
+ }
+ sgndef = 1.f;
+ } else {
+ if (irange == 1 && ! forceb) {
+ sigma = dmin(isrght,gu);
+ } else if (usedqd) {
+/* use Gerschgorin bound as shift to get neg def matrix */
+/* for dqds */
+ sigma = isrght;
+ } else {
+/* use approximation of the first desired eigenvalue of the */
+/* block as shift */
+ sigma = dmin(isrght,*vu);
+ }
+ sgndef = -1.f;
+ }
+/* An initial SIGMA has been chosen that will be used for computing */
+/* T - SIGMA I = L D L^T */
+/* Define the increment TAU of the shift in case the initial shift */
+/* needs to be refined to obtain a factorization with not too much */
+/* element growth. */
+ if (usedqd) {
+/* The initial SIGMA was to the outer end of the spectrum */
+/* the matrix is definite and we need not retreat. */
+ tau = spdiam * eps * *n + *pivmin * 2.f;
+ } else {
+ if (mb > 1) {
+ clwdth = w[wend] + werr[wend] - w[wbegin] - werr[wbegin];
+ avgap = (r__1 = clwdth / (real) (wend - wbegin), dabs(r__1));
+ if (sgndef == 1.f) {
+/* Computing MAX */
+ r__1 = wgap[wbegin];
+ tau = dmax(r__1,avgap) * .5f;
+/* Computing MAX */
+ r__1 = tau, r__2 = werr[wbegin];
+ tau = dmax(r__1,r__2);
+ } else {
+/* Computing MAX */
+ r__1 = wgap[wend - 1];
+ tau = dmax(r__1,avgap) * .5f;
+/* Computing MAX */
+ r__1 = tau, r__2 = werr[wend];
+ tau = dmax(r__1,r__2);
+ }
+ } else {
+ tau = werr[wbegin];
+ }
+ }
+
+ for (idum = 1; idum <= 6; ++idum) {
+/* Compute L D L^T factorization of tridiagonal matrix T - sigma I. */
+/* Store D in WORK(1:IN), L in WORK(IN+1:2*IN), and reciprocals of */
+/* pivots in WORK(2*IN+1:3*IN) */
+ dpivot = d__[ibegin] - sigma;
+ work[1] = dpivot;
+ dmax__ = dabs(work[1]);
+ j = ibegin;
+ i__2 = in - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[(in << 1) + i__] = 1.f / work[i__];
+ tmp = e[j] * work[(in << 1) + i__];
+ work[in + i__] = tmp;
+ dpivot = d__[j + 1] - sigma - tmp * e[j];
+ work[i__ + 1] = dpivot;
+/* Computing MAX */
+ r__1 = dmax__, r__2 = dabs(dpivot);
+ dmax__ = dmax(r__1,r__2);
+ ++j;
+/* L70: */
+ }
+/* check for element growth */
+ if (dmax__ > spdiam * 64.f) {
+ norep = TRUE_;
+ } else {
+ norep = FALSE_;
+ }
+ if (usedqd && ! norep) {
+/* Ensure the definiteness of the representation */
+/* All entries of D (of L D L^T) must have the same sign */
+ i__2 = in;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ tmp = sgndef * work[i__];
+ if (tmp < 0.f) {
+ norep = TRUE_;
+ }
+/* L71: */
+ }
+ }
+ if (norep) {
+/* Note that in the case of IRANGE=ALLRNG, we use the Gerschgorin */
+/* shift which makes the matrix definite. So we should end up */
+/* here really only in the case of IRANGE = VALRNG or INDRNG. */
+ if (idum == 5) {
+ if (sgndef == 1.f) {
+/* The fudged Gerschgorin shift should succeed */
+ sigma = gl - spdiam * 2.f * eps * *n - *pivmin * 4.f;
+ } else {
+ sigma = gu + spdiam * 2.f * eps * *n + *pivmin * 4.f;
+ }
+ } else {
+ sigma -= sgndef * tau;
+ tau *= 2.f;
+ }
+ } else {
+/* an initial RRR is found */
+ goto L83;
+ }
+/* L80: */
+ }
+/* if the program reaches this point, no base representation could be */
+/* found in MAXTRY iterations. */
+ *info = 2;
+ return 0;
+L83:
+/* At this point, we have found an initial base representation */
+/* T - SIGMA I = L D L^T with not too much element growth. */
+/* Store the shift. */
+ e[iend] = sigma;
+/* Store D and L. */
+ scopy_(&in, &work[1], &c__1, &d__[ibegin], &c__1);
+ i__2 = in - 1;
+ scopy_(&i__2, &work[in + 1], &c__1, &e[ibegin], &c__1);
+ if (mb > 1) {
+
+/* Perturb each entry of the base representation by a small */
+/* (but random) relative amount to overcome difficulties with */
+/* glued matrices. */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = 1;
+/* L122: */
+ }
+ i__2 = (in << 1) - 1;
+ slarnv_(&c__2, iseed, &i__2, &work[1]);
+ i__2 = in - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ d__[ibegin + i__ - 1] *= eps * 4.f * work[i__] + 1.f;
+ e[ibegin + i__ - 1] *= eps * 4.f * work[in + i__] + 1.f;
+/* L125: */
+ }
+ d__[iend] *= eps * 4.f * work[in] + 1.f;
+
+ }
+
+/* Don't update the Gerschgorin intervals because keeping track */
+/* of the updates would be too much work in SLARRV. */
+/* We update W instead and use it to locate the proper Gerschgorin */
+/* intervals. */
+/* Compute the required eigenvalues of L D L' by bisection or dqds */
+ if (! usedqd) {
+/* If SLARRD has been used, shift the eigenvalue approximations */
+/* according to their representation. This is necessary for */
+/* a uniform SLARRV since dqds computes eigenvalues of the */
+/* shifted representation. In SLARRV, W will always hold the */
+/* UNshifted eigenvalue approximation. */
+ i__2 = wend;
+ for (j = wbegin; j <= i__2; ++j) {
+ w[j] -= sigma;
+ werr[j] += (r__1 = w[j], dabs(r__1)) * eps;
+/* L134: */
+ }
+/* call SLARRB to reduce eigenvalue error of the approximations */
+/* from SLARRD */
+ i__2 = iend - 1;
+ for (i__ = ibegin; i__ <= i__2; ++i__) {
+/* Computing 2nd power */
+ r__1 = e[i__];
+ work[i__] = d__[i__] * (r__1 * r__1);
+/* L135: */
+ }
+/* use bisection to find EV from INDL to INDU */
+ i__2 = indl - 1;
+ slarrb_(&in, &d__[ibegin], &work[ibegin], &indl, &indu, rtol1,
+ rtol2, &i__2, &w[wbegin], &wgap[wbegin], &werr[wbegin], &
+ work[(*n << 1) + 1], &iwork[1], pivmin, &spdiam, &in, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = -4;
+ return 0;
+ }
+/* SLARRB computes all gaps correctly except for the last one */
+/* Record distance to VU/GU */
+/* Computing MAX */
+ r__1 = 0.f, r__2 = *vu - sigma - (w[wend] + werr[wend]);
+ wgap[wend] = dmax(r__1,r__2);
+ i__2 = indu;
+ for (i__ = indl; i__ <= i__2; ++i__) {
+ ++(*m);
+ iblock[*m] = jblk;
+ indexw[*m] = i__;
+/* L138: */
+ }
+ } else {
+/* Call dqds to get all eigs (and then possibly delete unwanted */
+/* eigenvalues). */
+/* Note that dqds finds the eigenvalues of the L D L^T representation */
+/* of T to high relative accuracy. High relative accuracy */
+/* might be lost when the shift of the RRR is subtracted to obtain */
+/* the eigenvalues of T. However, T is not guaranteed to define its */
+/* eigenvalues to high relative accuracy anyway. */
+/* Set RTOL to the order of the tolerance used in SLASQ2 */
+/* This is an ESTIMATED error, the worst case bound is 4*N*EPS */
+/* which is usually too large and requires unnecessary work to be */
+/* done by bisection when computing the eigenvectors */
+ rtol = log((real) in) * 4.f * eps;
+ j = ibegin;
+ i__2 = in - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[(i__ << 1) - 1] = (r__1 = d__[j], dabs(r__1));
+ work[i__ * 2] = e[j] * e[j] * work[(i__ << 1) - 1];
+ ++j;
+/* L140: */
+ }
+ work[(in << 1) - 1] = (r__1 = d__[iend], dabs(r__1));
+ work[in * 2] = 0.f;
+ slasq2_(&in, &work[1], &iinfo);
+ if (iinfo != 0) {
+/* If IINFO = -5 then an index is part of a tight cluster */
+/* and should be changed. The index is in IWORK(1) and the */
+/* gap is in WORK(N+1) */
+ *info = -5;
+ return 0;
+ } else {
+/* Test that all eigenvalues are positive as expected */
+ i__2 = in;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] < 0.f) {
+ *info = -6;
+ return 0;
+ }
+/* L149: */
+ }
+ }
+ if (sgndef > 0.f) {
+ i__2 = indu;
+ for (i__ = indl; i__ <= i__2; ++i__) {
+ ++(*m);
+ w[*m] = work[in - i__ + 1];
+ iblock[*m] = jblk;
+ indexw[*m] = i__;
+/* L150: */
+ }
+ } else {
+ i__2 = indu;
+ for (i__ = indl; i__ <= i__2; ++i__) {
+ ++(*m);
+ w[*m] = -work[i__];
+ iblock[*m] = jblk;
+ indexw[*m] = i__;
+/* L160: */
+ }
+ }
+ i__2 = *m;
+ for (i__ = *m - mb + 1; i__ <= i__2; ++i__) {
+/* the value of RTOL below should be the tolerance in SLASQ2 */
+ werr[i__] = rtol * (r__1 = w[i__], dabs(r__1));
+/* L165: */
+ }
+ i__2 = *m - 1;
+ for (i__ = *m - mb + 1; i__ <= i__2; ++i__) {
+/* compute the right gap between the intervals */
+/* Computing MAX */
+ r__1 = 0.f, r__2 = w[i__ + 1] - werr[i__ + 1] - (w[i__] +
+ werr[i__]);
+ wgap[i__] = dmax(r__1,r__2);
+/* L166: */
+ }
+/* Computing MAX */
+ r__1 = 0.f, r__2 = *vu - sigma - (w[*m] + werr[*m]);
+ wgap[*m] = dmax(r__1,r__2);
+ }
+/* proceed with next block */
+ ibegin = iend + 1;
+ wbegin = wend + 1;
+L170:
+ ;
+ }
+
+ return 0;
+
+/* end of SLARRE */
+
+} /* slarre_ */
diff --git a/SRC/slarrf.c b/SRC/slarrf.c
new file mode 100644
index 0000000..372a339
--- /dev/null
+++ b/SRC/slarrf.c
@@ -0,0 +1,422 @@
+/* slarrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int slarrf_(integer *n, real *d__, real *l, real *ld,
+ integer *clstrt, integer *clend, real *w, real *wgap, real *werr,
+ real *spdiam, real *clgapl, real *clgapr, real *pivmin, real *sigma,
+ real *dplus, real *lplus, real *work, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real s, bestshift, smlgrowth, eps, tmp, max1, max2, rrr1, rrr2, znm2,
+ growthbound, fail, fact, oldp;
+ integer indx;
+ real prod;
+ integer ktry;
+ real fail2, avgap, ldmax, rdmax;
+ integer shift;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ logical dorrr1;
+ real ldelta;
+ extern doublereal slamch_(char *);
+ logical nofail;
+ real mingap, lsigma, rdelta;
+ logical forcer;
+ real rsigma, clwdth;
+ extern logical sisnan_(real *);
+ logical sawnan1, sawnan2, tryrrr1;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+/* * */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Given the initial representation L D L^T and its cluster of close */
+/* eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ... */
+/* W( CLEND ), SLARRF finds a new relatively robust representation */
+/* L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the */
+/* eigenvalues of L(+) D(+) L(+)^T is relatively isolated. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix (subblock, if the matrix splitted). */
+
+/* D (input) REAL array, dimension (N) */
+/* The N diagonal elements of the diagonal matrix D. */
+
+/* L (input) REAL array, dimension (N-1) */
+/* The (N-1) subdiagonal elements of the unit bidiagonal */
+/* matrix L. */
+
+/* LD (input) REAL array, dimension (N-1) */
+/* The (N-1) elements L(i)*D(i). */
+
+/* CLSTRT (input) INTEGER */
+/* The index of the first eigenvalue in the cluster. */
+
+/* CLEND (input) INTEGER */
+/* The index of the last eigenvalue in the cluster. */
+
+/* W (input) REAL array, dimension >= (CLEND-CLSTRT+1) */
+/* The eigenvalue APPROXIMATIONS of L D L^T in ascending order. */
+/* W( CLSTRT ) through W( CLEND ) form the cluster of relatively */
+/* close eigenalues. */
+
+/* WGAP (input/output) REAL array, dimension >= (CLEND-CLSTRT+1) */
+/* The separation from the right neighbor eigenvalue in W. */
+
+/* WERR (input) REAL array, dimension >= (CLEND-CLSTRT+1) */
+/* WERR contain the semiwidth of the uncertainty */
+/* interval of the corresponding eigenvalue APPROXIMATION in W */
+
+/* SPDIAM (input) estimate of the spectral diameter obtained from the */
+/* Gerschgorin intervals */
+
+/* CLGAPL, CLGAPR (input) absolute gap on each end of the cluster. */
+/* Set by the calling routine to protect against shifts too close */
+/* to eigenvalues outside the cluster. */
+
+/* PIVMIN (input) DOUBLE PRECISION */
+/* The minimum pivot allowed in the Sturm sequence. */
+
+/* SIGMA (output) REAL */
+/* The shift used to form L(+) D(+) L(+)^T. */
+
+/* DPLUS (output) REAL array, dimension (N) */
+/* The N diagonal elements of the diagonal matrix D(+). */
+
+/* LPLUS (output) REAL array, dimension (N-1) */
+/* The first (N-1) elements of LPLUS contain the subdiagonal */
+/* elements of the unit bidiagonal matrix L(+). */
+
+/* WORK (workspace) REAL array, dimension (2*N) */
+/* Workspace. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --lplus;
+ --dplus;
+ --werr;
+ --wgap;
+ --w;
+ --ld;
+ --l;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+ fact = 2.f;
+ eps = slamch_("Precision");
+ shift = 0;
+ forcer = FALSE_;
+/* Note that we cannot guarantee that for any of the shifts tried, */
+/* the factorization has a small or even moderate element growth. */
+/* There could be Ritz values at both ends of the cluster and despite */
+/* backing off, there are examples where all factorizations tried */
+/* (in IEEE mode, allowing zero pivots & infinities) have INFINITE */
+/* element growth. */
+/* For this reason, we should use PIVMIN in this subroutine so that at */
+/* least the L D L^T factorization exists. It can be checked afterwards */
+/* whether the element growth caused bad residuals/orthogonality. */
+/* Decide whether the code should accept the best among all */
+/* representations despite large element growth or signal INFO=1 */
+ nofail = TRUE_;
+
+/* Compute the average gap length of the cluster */
+ clwdth = (r__1 = w[*clend] - w[*clstrt], dabs(r__1)) + werr[*clend] +
+ werr[*clstrt];
+ avgap = clwdth / (real) (*clend - *clstrt);
+ mingap = dmin(*clgapl,*clgapr);
+/* Initial values for shifts to both ends of cluster */
+/* Computing MIN */
+ r__1 = w[*clstrt], r__2 = w[*clend];
+ lsigma = dmin(r__1,r__2) - werr[*clstrt];
+/* Computing MAX */
+ r__1 = w[*clstrt], r__2 = w[*clend];
+ rsigma = dmax(r__1,r__2) + werr[*clend];
+/* Use a small fudge to make sure that we really shift to the outside */
+ lsigma -= dabs(lsigma) * 2.f * eps;
+ rsigma += dabs(rsigma) * 2.f * eps;
+/* Compute upper bounds for how much to back off the initial shifts */
+ ldmax = mingap * .25f + *pivmin * 2.f;
+ rdmax = mingap * .25f + *pivmin * 2.f;
+/* Computing MAX */
+ r__1 = avgap, r__2 = wgap[*clstrt];
+ ldelta = dmax(r__1,r__2) / fact;
+/* Computing MAX */
+ r__1 = avgap, r__2 = wgap[*clend - 1];
+ rdelta = dmax(r__1,r__2) / fact;
+
+/* Initialize the record of the best representation found */
+
+ s = slamch_("S");
+ smlgrowth = 1.f / s;
+ fail = (real) (*n - 1) * mingap / (*spdiam * eps);
+ fail2 = (real) (*n - 1) * mingap / (*spdiam * sqrt(eps));
+ bestshift = lsigma;
+
+/* while (KTRY <= KTRYMAX) */
+ ktry = 0;
+ growthbound = *spdiam * 8.f;
+L5:
+ sawnan1 = FALSE_;
+ sawnan2 = FALSE_;
+/* Ensure that we do not back off too much of the initial shifts */
+ ldelta = dmin(ldmax,ldelta);
+ rdelta = dmin(rdmax,rdelta);
+/* Compute the element growth when shifting to both ends of the cluster */
+/* accept the shift if there is no element growth at one of the two ends */
+/* Left end */
+ s = -lsigma;
+ dplus[1] = d__[1] + s;
+ if (dabs(dplus[1]) < *pivmin) {
+ dplus[1] = -(*pivmin);
+/* Need to set SAWNAN1 because refined RRR test should not be used */
+/* in this case */
+ sawnan1 = TRUE_;
+ }
+ max1 = dabs(dplus[1]);
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ lplus[i__] = ld[i__] / dplus[i__];
+ s = s * lplus[i__] * l[i__] - lsigma;
+ dplus[i__ + 1] = d__[i__ + 1] + s;
+ if ((r__1 = dplus[i__ + 1], dabs(r__1)) < *pivmin) {
+ dplus[i__ + 1] = -(*pivmin);
+/* Need to set SAWNAN1 because refined RRR test should not be used */
+/* in this case */
+ sawnan1 = TRUE_;
+ }
+/* Computing MAX */
+ r__2 = max1, r__3 = (r__1 = dplus[i__ + 1], dabs(r__1));
+ max1 = dmax(r__2,r__3);
+/* L6: */
+ }
+ sawnan1 = sawnan1 || sisnan_(&max1);
+ if (forcer || max1 <= growthbound && ! sawnan1) {
+ *sigma = lsigma;
+ shift = 1;
+ goto L100;
+ }
+/* Right end */
+ s = -rsigma;
+ work[1] = d__[1] + s;
+ if (dabs(work[1]) < *pivmin) {
+ work[1] = -(*pivmin);
+/* Need to set SAWNAN2 because refined RRR test should not be used */
+/* in this case */
+ sawnan2 = TRUE_;
+ }
+ max2 = dabs(work[1]);
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[*n + i__] = ld[i__] / work[i__];
+ s = s * work[*n + i__] * l[i__] - rsigma;
+ work[i__ + 1] = d__[i__ + 1] + s;
+ if ((r__1 = work[i__ + 1], dabs(r__1)) < *pivmin) {
+ work[i__ + 1] = -(*pivmin);
+/* Need to set SAWNAN2 because refined RRR test should not be used */
+/* in this case */
+ sawnan2 = TRUE_;
+ }
+/* Computing MAX */
+ r__2 = max2, r__3 = (r__1 = work[i__ + 1], dabs(r__1));
+ max2 = dmax(r__2,r__3);
+/* L7: */
+ }
+ sawnan2 = sawnan2 || sisnan_(&max2);
+ if (forcer || max2 <= growthbound && ! sawnan2) {
+ *sigma = rsigma;
+ shift = 2;
+ goto L100;
+ }
+/* If we are at this point, both shifts led to too much element growth */
+/* Record the better of the two shifts (provided it didn't lead to NaN) */
+ if (sawnan1 && sawnan2) {
+/* both MAX1 and MAX2 are NaN */
+ goto L50;
+ } else {
+ if (! sawnan1) {
+ indx = 1;
+ if (max1 <= smlgrowth) {
+ smlgrowth = max1;
+ bestshift = lsigma;
+ }
+ }
+ if (! sawnan2) {
+ if (sawnan1 || max2 <= max1) {
+ indx = 2;
+ }
+ if (max2 <= smlgrowth) {
+ smlgrowth = max2;
+ bestshift = rsigma;
+ }
+ }
+ }
+/* If we are here, both the left and the right shift led to */
+/* element growth. If the element growth is moderate, then */
+/* we may still accept the representation, if it passes a */
+/* refined test for RRR. This test supposes that no NaN occurred. */
+/* Moreover, we use the refined RRR test only for isolated clusters. */
+ if (clwdth < mingap / 128.f && dmin(max1,max2) < fail2 && ! sawnan1 && !
+ sawnan2) {
+ dorrr1 = TRUE_;
+ } else {
+ dorrr1 = FALSE_;
+ }
+ tryrrr1 = TRUE_;
+ if (tryrrr1 && dorrr1) {
+ if (indx == 1) {
+ tmp = (r__1 = dplus[*n], dabs(r__1));
+ znm2 = 1.f;
+ prod = 1.f;
+ oldp = 1.f;
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ if (prod <= eps) {
+ prod = dplus[i__ + 1] * work[*n + i__ + 1] / (dplus[i__] *
+ work[*n + i__]) * oldp;
+ } else {
+ prod *= (r__1 = work[*n + i__], dabs(r__1));
+ }
+ oldp = prod;
+/* Computing 2nd power */
+ r__1 = prod;
+ znm2 += r__1 * r__1;
+/* Computing MAX */
+ r__2 = tmp, r__3 = (r__1 = dplus[i__] * prod, dabs(r__1));
+ tmp = dmax(r__2,r__3);
+/* L15: */
+ }
+ rrr1 = tmp / (*spdiam * sqrt(znm2));
+ if (rrr1 <= 8.f) {
+ *sigma = lsigma;
+ shift = 1;
+ goto L100;
+ }
+ } else if (indx == 2) {
+ tmp = (r__1 = work[*n], dabs(r__1));
+ znm2 = 1.f;
+ prod = 1.f;
+ oldp = 1.f;
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ if (prod <= eps) {
+ prod = work[i__ + 1] * lplus[i__ + 1] / (work[i__] *
+ lplus[i__]) * oldp;
+ } else {
+ prod *= (r__1 = lplus[i__], dabs(r__1));
+ }
+ oldp = prod;
+/* Computing 2nd power */
+ r__1 = prod;
+ znm2 += r__1 * r__1;
+/* Computing MAX */
+ r__2 = tmp, r__3 = (r__1 = work[i__] * prod, dabs(r__1));
+ tmp = dmax(r__2,r__3);
+/* L16: */
+ }
+ rrr2 = tmp / (*spdiam * sqrt(znm2));
+ if (rrr2 <= 8.f) {
+ *sigma = rsigma;
+ shift = 2;
+ goto L100;
+ }
+ }
+ }
+L50:
+ if (ktry < 1) {
+/* If we are here, both shifts failed also the RRR test. */
+/* Back off to the outside */
+/* Computing MAX */
+ r__1 = lsigma - ldelta, r__2 = lsigma - ldmax;
+ lsigma = dmax(r__1,r__2);
+/* Computing MIN */
+ r__1 = rsigma + rdelta, r__2 = rsigma + rdmax;
+ rsigma = dmin(r__1,r__2);
+ ldelta *= 2.f;
+ rdelta *= 2.f;
+ ++ktry;
+ goto L5;
+ } else {
+/* None of the representations investigated satisfied our */
+/* criteria. Take the best one we found. */
+ if (smlgrowth < fail || nofail) {
+ lsigma = bestshift;
+ rsigma = bestshift;
+ forcer = TRUE_;
+ goto L5;
+ } else {
+ *info = 1;
+ return 0;
+ }
+ }
+L100:
+ if (shift == 1) {
+ } else if (shift == 2) {
+/* store new L and D back into DPLUS, LPLUS */
+ scopy_(n, &work[1], &c__1, &dplus[1], &c__1);
+ i__1 = *n - 1;
+ scopy_(&i__1, &work[*n + 1], &c__1, &lplus[1], &c__1);
+ }
+ return 0;
+
+/* End of SLARRF */
+
+} /* slarrf_ */
diff --git a/SRC/slarrj.c b/SRC/slarrj.c
new file mode 100644
index 0000000..4091bb6
--- /dev/null
+++ b/SRC/slarrj.c
@@ -0,0 +1,337 @@
+/* slarrj.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slarrj_(integer *n, real *d__, real *e2, integer *ifirst,
+ integer *ilast, real *rtol, integer *offset, real *w, real *werr,
+ real *work, integer *iwork, real *pivmin, real *spdiam, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double log(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, p;
+ real s;
+ integer i1, i2, ii;
+ real fac, mid;
+ integer cnt;
+ real tmp, left;
+ integer iter, nint, prev, next, savi1;
+ real right, width, dplus;
+ integer olnint, maxitr;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Given the initial eigenvalue approximations of T, SLARRJ */
+/* does bisection to refine the eigenvalues of T, */
+/* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial */
+/* guesses for these eigenvalues are input in W, the corresponding estimate */
+/* of the error in these guesses in WERR. During bisection, intervals */
+/* [left, right] are maintained by storing their mid-points and */
+/* semi-widths in the arrays W and WERR respectively. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. */
+
+/* D (input) REAL array, dimension (N) */
+/* The N diagonal elements of T. */
+
+/* E2 (input) REAL array, dimension (N-1) */
+/* The Squares of the (N-1) subdiagonal elements of T. */
+
+/* IFIRST (input) INTEGER */
+/* The index of the first eigenvalue to be computed. */
+
+/* ILAST (input) INTEGER */
+/* The index of the last eigenvalue to be computed. */
+
+/* RTOL (input) REAL */
+/* Tolerance for the convergence of the bisection intervals. */
+/* An interval [LEFT,RIGHT] has converged if */
+/* RIGHT-LEFT.LT.RTOL*MAX(|LEFT|,|RIGHT|). */
+
+/* OFFSET (input) INTEGER */
+/* Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET */
+/* through ILAST-OFFSET elements of these arrays are to be used. */
+
+/* W (input/output) REAL array, dimension (N) */
+/* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are */
+/* estimates of the eigenvalues of L D L^T indexed IFIRST through */
+/* ILAST. */
+/* On output, these estimates are refined. */
+
+/* WERR (input/output) REAL array, dimension (N) */
+/* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are */
+/* the errors in the estimates of the corresponding elements in W. */
+/* On output, these errors are refined. */
+
+/* WORK (workspace) REAL array, dimension (2*N) */
+/* Workspace. */
+
+/* IWORK (workspace) INTEGER array, dimension (2*N) */
+/* Workspace. */
+
+/* PIVMIN (input) DOUBLE PRECISION */
+/* The minimum pivot in the Sturm sequence for T. */
+
+/* SPDIAM (input) DOUBLE PRECISION */
+/* The spectral diameter of T. */
+
+/* INFO (output) INTEGER */
+/* Error flag. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --werr;
+ --w;
+ --e2;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+
+ maxitr = (integer) ((log(*spdiam + *pivmin) - log(*pivmin)) / log(2.f)) +
+ 2;
+
+/* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ]. */
+/* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while */
+/* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 ) */
+/* for an unconverged interval is set to the index of the next unconverged */
+/* interval, and is -1 or 0 for a converged interval. Thus a linked */
+/* list of unconverged intervals is set up. */
+
+ i1 = *ifirst;
+ i2 = *ilast;
+/* The number of unconverged intervals */
+ nint = 0;
+/* The last unconverged interval found */
+ prev = 0;
+ i__1 = i2;
+ for (i__ = i1; i__ <= i__1; ++i__) {
+ k = i__ << 1;
+ ii = i__ - *offset;
+ left = w[ii] - werr[ii];
+ mid = w[ii];
+ right = w[ii] + werr[ii];
+ width = right - mid;
+/* Computing MAX */
+ r__1 = dabs(left), r__2 = dabs(right);
+ tmp = dmax(r__1,r__2);
+/* The following test prevents the test of converged intervals */
+ if (width < *rtol * tmp) {
+/* This interval has already converged and does not need refinement. */
+/* (Note that the gaps might change through refining the */
+/* eigenvalues, however, they can only get bigger.) */
+/* Remove it from the list. */
+ iwork[k - 1] = -1;
+/* Make sure that I1 always points to the first unconverged interval */
+ if (i__ == i1 && i__ < i2) {
+ i1 = i__ + 1;
+ }
+ if (prev >= i1 && i__ <= i2) {
+ iwork[(prev << 1) - 1] = i__ + 1;
+ }
+ } else {
+/* unconverged interval found */
+ prev = i__;
+/* Make sure that [LEFT,RIGHT] contains the desired eigenvalue */
+
+/* Do while( CNT(LEFT).GT.I-1 ) */
+
+ fac = 1.f;
+L20:
+ cnt = 0;
+ s = left;
+ dplus = d__[1] - s;
+ if (dplus < 0.f) {
+ ++cnt;
+ }
+ i__2 = *n;
+ for (j = 2; j <= i__2; ++j) {
+ dplus = d__[j] - s - e2[j - 1] / dplus;
+ if (dplus < 0.f) {
+ ++cnt;
+ }
+/* L30: */
+ }
+ if (cnt > i__ - 1) {
+ left -= werr[ii] * fac;
+ fac *= 2.f;
+ goto L20;
+ }
+
+/* Do while( CNT(RIGHT).LT.I ) */
+
+ fac = 1.f;
+L50:
+ cnt = 0;
+ s = right;
+ dplus = d__[1] - s;
+ if (dplus < 0.f) {
+ ++cnt;
+ }
+ i__2 = *n;
+ for (j = 2; j <= i__2; ++j) {
+ dplus = d__[j] - s - e2[j - 1] / dplus;
+ if (dplus < 0.f) {
+ ++cnt;
+ }
+/* L60: */
+ }
+ if (cnt < i__) {
+ right += werr[ii] * fac;
+ fac *= 2.f;
+ goto L50;
+ }
+ ++nint;
+ iwork[k - 1] = i__ + 1;
+ iwork[k] = cnt;
+ }
+ work[k - 1] = left;
+ work[k] = right;
+/* L75: */
+ }
+ savi1 = i1;
+
+/* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals */
+/* and while (ITER.LT.MAXITR) */
+
+ iter = 0;
+L80:
+ prev = i1 - 1;
+ i__ = i1;
+ olnint = nint;
+ i__1 = olnint;
+ for (p = 1; p <= i__1; ++p) {
+ k = i__ << 1;
+ ii = i__ - *offset;
+ next = iwork[k - 1];
+ left = work[k - 1];
+ right = work[k];
+ mid = (left + right) * .5f;
+/* semiwidth of interval */
+ width = right - mid;
+/* Computing MAX */
+ r__1 = dabs(left), r__2 = dabs(right);
+ tmp = dmax(r__1,r__2);
+ if (width < *rtol * tmp || iter == maxitr) {
+/* reduce number of unconverged intervals */
+ --nint;
+/* Mark interval as converged. */
+ iwork[k - 1] = 0;
+ if (i1 == i__) {
+ i1 = next;
+ } else {
+/* Prev holds the last unconverged interval previously examined */
+ if (prev >= i1) {
+ iwork[(prev << 1) - 1] = next;
+ }
+ }
+ i__ = next;
+ goto L100;
+ }
+ prev = i__;
+
+/* Perform one bisection step */
+
+ cnt = 0;
+ s = mid;
+ dplus = d__[1] - s;
+ if (dplus < 0.f) {
+ ++cnt;
+ }
+ i__2 = *n;
+ for (j = 2; j <= i__2; ++j) {
+ dplus = d__[j] - s - e2[j - 1] / dplus;
+ if (dplus < 0.f) {
+ ++cnt;
+ }
+/* L90: */
+ }
+ if (cnt <= i__ - 1) {
+ work[k - 1] = mid;
+ } else {
+ work[k] = mid;
+ }
+ i__ = next;
+L100:
+ ;
+ }
+ ++iter;
+/* do another loop if there are still unconverged intervals */
+/* However, in the last iteration, all intervals are accepted */
+/* since this is the best we can do. */
+ if (nint > 0 && iter <= maxitr) {
+ goto L80;
+ }
+
+
+/* At this point, all the intervals have converged */
+ i__1 = *ilast;
+ for (i__ = savi1; i__ <= i__1; ++i__) {
+ k = i__ << 1;
+ ii = i__ - *offset;
+/* All intervals marked by '0' have been refined. */
+ if (iwork[k - 1] == 0) {
+ w[ii] = (work[k - 1] + work[k]) * .5f;
+ werr[ii] = work[k] - w[ii];
+ }
+/* L110: */
+ }
+
+ return 0;
+
+/* End of SLARRJ */
+
+} /* slarrj_ */
diff --git a/SRC/slarrk.c b/SRC/slarrk.c
new file mode 100644
index 0000000..b525a9f
--- /dev/null
+++ b/SRC/slarrk.c
@@ -0,0 +1,193 @@
+/* slarrk.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slarrk_(integer *n, integer *iw, real *gl, real *gu,
+ real *d__, real *e2, real *pivmin, real *reltol, real *w, real *werr,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double log(doublereal);
+
+ /* Local variables */
+ integer i__, it;
+ real mid, eps, tmp1, tmp2, left, atoli, right;
+ integer itmax;
+ real rtoli, tnorm;
+ extern doublereal slamch_(char *);
+ integer negcnt;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARRK computes one eigenvalue of a symmetric tridiagonal */
+/* matrix T to suitable accuracy. This is an auxiliary code to be */
+/* called from SSTEMR. */
+
+/* To avoid overflow, the matrix must be scaled so that its */
+/* largest element is no greater than overflow**(1/2) * */
+/* underflow**(1/4) in absolute value, and for greatest */
+/* accuracy, it should not be much smaller than that. */
+
+/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */
+/* Matrix", Report CS41, Computer Science Dept., Stanford */
+/* University, July 21, 1966. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the tridiagonal matrix T. N >= 0. */
+
+/* IW (input) INTEGER */
+/* The index of the eigenvalues to be returned. */
+
+/* GL (input) REAL */
+/* GU (input) REAL */
+/* An upper and a lower bound on the eigenvalue. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix T. */
+
+/* E2 (input) REAL array, dimension (N-1) */
+/* The (n-1) squared off-diagonal elements of the tridiagonal matrix T. */
+
+/* PIVMIN (input) REAL */
+/* The minimum pivot allowed in the Sturm sequence for T. */
+
+/* RELTOL (input) REAL */
+/* The minimum relative width of an interval. When an interval */
+/* is narrower than RELTOL times the larger (in */
+/* magnitude) endpoint, then it is considered to be */
+/* sufficiently small, i.e., converged. Note: this should */
+/* always be at least radix*machine epsilon. */
+
+/* W (output) REAL */
+
+/* WERR (output) REAL */
+/* The error bound on the corresponding eigenvalue approximation */
+/* in W. */
+
+/* INFO (output) INTEGER */
+/* = 0: Eigenvalue converged */
+/* = -1: Eigenvalue did NOT converge */
+
+/* Internal Parameters */
+/* =================== */
+
+/* FUDGE REAL , default = 2 */
+/* A "fudge factor" to widen the Gershgorin intervals. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Get machine constants */
+ /* Parameter adjustments */
+ --e2;
+ --d__;
+
+ /* Function Body */
+ eps = slamch_("P");
+/* Computing MAX */
+ r__1 = dabs(*gl), r__2 = dabs(*gu);
+ tnorm = dmax(r__1,r__2);
+ rtoli = *reltol;
+ atoli = *pivmin * 4.f;
+ itmax = (integer) ((log(tnorm + *pivmin) - log(*pivmin)) / log(2.f)) + 2;
+ *info = -1;
+ left = *gl - tnorm * 2.f * eps * *n - *pivmin * 4.f;
+ right = *gu + tnorm * 2.f * eps * *n + *pivmin * 4.f;
+ it = 0;
+L10:
+
+/* Check if interval converged or maximum number of iterations reached */
+
+ tmp1 = (r__1 = right - left, dabs(r__1));
+/* Computing MAX */
+ r__1 = dabs(right), r__2 = dabs(left);
+ tmp2 = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = max(atoli,*pivmin), r__2 = rtoli * tmp2;
+ if (tmp1 < dmax(r__1,r__2)) {
+ *info = 0;
+ goto L30;
+ }
+ if (it > itmax) {
+ goto L30;
+ }
+
+/* Count number of negative pivots for mid-point */
+
+ ++it;
+ mid = (left + right) * .5f;
+ negcnt = 0;
+ tmp1 = d__[1] - mid;
+ if (dabs(tmp1) < *pivmin) {
+ tmp1 = -(*pivmin);
+ }
+ if (tmp1 <= 0.f) {
+ ++negcnt;
+ }
+
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ tmp1 = d__[i__] - e2[i__ - 1] / tmp1 - mid;
+ if (dabs(tmp1) < *pivmin) {
+ tmp1 = -(*pivmin);
+ }
+ if (tmp1 <= 0.f) {
+ ++negcnt;
+ }
+/* L20: */
+ }
+ if (negcnt >= *iw) {
+ right = mid;
+ } else {
+ left = mid;
+ }
+ goto L10;
+L30:
+
+/* Converged or maximum number of iterations reached */
+
+ *w = (left + right) * .5f;
+ *werr = (r__1 = right - left, dabs(r__1)) * .5f;
+ return 0;
+
+/* End of SLARRK */
+
+} /* slarrk_ */
diff --git a/SRC/slarrr.c b/SRC/slarrr.c
new file mode 100644
index 0000000..f7f1577
--- /dev/null
+++ b/SRC/slarrr.c
@@ -0,0 +1,175 @@
+/* slarrr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slarrr_(integer *n, real *d__, real *e, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real eps, tmp, tmp2, rmin, offdig;
+ extern doublereal slamch_(char *);
+ real safmin;
+ logical yesrel;
+ real smlnum, offdig2;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+
+/* Purpose */
+/* ======= */
+
+/* Perform tests to decide whether the symmetric tridiagonal matrix T */
+/* warrants expensive computations which guarantee high relative accuracy */
+/* in the eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N > 0. */
+
+/* D (input) REAL array, dimension (N) */
+/* The N diagonal elements of the tridiagonal matrix T. */
+
+/* E (input/output) REAL array, dimension (N) */
+/* On entry, the first (N-1) entries contain the subdiagonal */
+/* elements of the tridiagonal matrix T; E(N) is set to ZERO. */
+
+/* INFO (output) INTEGER */
+/* INFO = 0(default) : the matrix warrants computations preserving */
+/* relative accuracy. */
+/* INFO = 1 : the matrix warrants computations guaranteeing */
+/* only absolute accuracy. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* As a default, do NOT go for relative-accuracy preserving computations. */
+ /* Parameter adjustments */
+ --e;
+ --d__;
+
+ /* Function Body */
+ *info = 1;
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ rmin = sqrt(smlnum);
+/* Tests for relative accuracy */
+
+/* Test for scaled diagonal dominance */
+/* Scale the diagonal entries to one and check whether the sum of the */
+/* off-diagonals is less than one */
+
+/* The sdd relative error bounds have a 1/(1- 2*x) factor in them, */
+/* x = max(OFFDIG + OFFDIG2), so when x is close to 1/2, no relative */
+/* accuracy is promised. In the notation of the code fragment below, */
+/* 1/(1 - (OFFDIG + OFFDIG2)) is the condition number. */
+/* We don't think it is worth going into "sdd mode" unless the relative */
+/* condition number is reasonable, not 1/macheps. */
+/* The threshold should be compatible with other thresholds used in the */
+/* code. We set OFFDIG + OFFDIG2 <= .999 =: RELCOND, it corresponds */
+/* to losing at most 3 decimal digits: 1 / (1 - (OFFDIG + OFFDIG2)) <= 1000 */
+/* instead of the current OFFDIG + OFFDIG2 < 1 */
+
+ yesrel = TRUE_;
+ offdig = 0.f;
+ tmp = sqrt((dabs(d__[1])));
+ if (tmp < rmin) {
+ yesrel = FALSE_;
+ }
+ if (! yesrel) {
+ goto L11;
+ }
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ tmp2 = sqrt((r__1 = d__[i__], dabs(r__1)));
+ if (tmp2 < rmin) {
+ yesrel = FALSE_;
+ }
+ if (! yesrel) {
+ goto L11;
+ }
+ offdig2 = (r__1 = e[i__ - 1], dabs(r__1)) / (tmp * tmp2);
+ if (offdig + offdig2 >= .999f) {
+ yesrel = FALSE_;
+ }
+ if (! yesrel) {
+ goto L11;
+ }
+ tmp = tmp2;
+ offdig = offdig2;
+/* L10: */
+ }
+L11:
+ if (yesrel) {
+ *info = 0;
+ return 0;
+ } else {
+ }
+
+
+/* *** MORE TO BE IMPLEMENTED *** */
+
+
+/* Test if the lower bidiagonal matrix L from T = L D L^T */
+/* (zero shift facto) is well conditioned */
+
+
+/* Test if the upper bidiagonal matrix U from T = U D U^T */
+/* (zero shift facto) is well conditioned. */
+/* In this case, the matrix needs to be flipped and, at the end */
+/* of the eigenvector computation, the flip needs to be applied */
+/* to the computed eigenvectors (and the support) */
+
+
+ return 0;
+
+/* END OF SLARRR */
+
+} /* slarrr_ */
diff --git a/SRC/slarrv.c b/SRC/slarrv.c
new file mode 100644
index 0000000..c1dc859
--- /dev/null
+++ b/SRC/slarrv.c
@@ -0,0 +1,980 @@
+/* slarrv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b5 = 0.f;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int slarrv_(integer *n, real *vl, real *vu, real *d__, real *
+ l, real *pivmin, integer *isplit, integer *m, integer *dol, integer *
+ dou, real *minrgp, real *rtol1, real *rtol2, real *w, real *werr,
+ real *wgap, integer *iblock, integer *indexw, real *gers, real *z__,
+ integer *ldz, integer *isuppz, real *work, integer *iwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2;
+ logical L__1;
+
+ /* Builtin functions */
+ double log(doublereal);
+
+ /* Local variables */
+ integer minwsize, i__, j, k, p, q, miniwsize, ii;
+ real gl;
+ integer im, in;
+ real gu, gap, eps, tau, tol, tmp;
+ integer zto;
+ real ztz;
+ integer iend, jblk;
+ real lgap;
+ integer done;
+ real rgap, left;
+ integer wend, iter;
+ real bstw;
+ integer itmp1, indld;
+ real fudge;
+ integer idone;
+ real sigma;
+ integer iinfo, iindr;
+ real resid;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ logical eskip;
+ real right;
+ integer nclus, zfrom;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ real rqtol;
+ integer iindc1, iindc2;
+ extern /* Subroutine */ int slar1v_(integer *, integer *, integer *, real
+ *, real *, real *, real *, real *, real *, real *, real *,
+ logical *, integer *, real *, real *, integer *, integer *, real *
+, real *, real *, real *);
+ logical stp2ii;
+ real lambda;
+ integer ibegin, indeig;
+ logical needbs;
+ integer indlld;
+ real sgndef, mingma;
+ extern doublereal slamch_(char *);
+ integer oldien, oldncl, wbegin;
+ real spdiam;
+ integer negcnt, oldcls;
+ real savgap;
+ integer ndepth;
+ real ssigma;
+ logical usedbs;
+ integer iindwk, offset;
+ real gaptol;
+ extern /* Subroutine */ int slarrb_(integer *, real *, real *, integer *,
+ integer *, real *, real *, integer *, real *, real *, real *,
+ real *, integer *, real *, real *, integer *, integer *), slarrf_(
+ integer *, real *, real *, real *, integer *, integer *, real *,
+ real *, real *, real *, real *, real *, real *, real *, real *,
+ real *, real *, integer *);
+ integer newcls, oldfst, indwrk, windex, oldlst;
+ logical usedrq;
+ integer newfst, newftt, parity, windmn, isupmn, newlst, windpl, zusedl,
+ newsiz, zusedu, zusedw;
+ real bstres, nrminv;
+ logical tryrqc;
+ integer isupmx;
+ real rqcorr;
+ extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARRV computes the eigenvectors of the tridiagonal matrix */
+/* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T. */
+/* The input eigenvalues should have been computed by SLARRE. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* Lower and upper bounds of the interval that contains the desired */
+/* eigenvalues. VL < VU. Needed to compute gaps on the left or right */
+/* end of the extremal eigenvalues in the desired RANGE. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the N diagonal elements of the diagonal matrix D. */
+/* On exit, D may be overwritten. */
+
+/* L (input/output) REAL array, dimension (N) */
+/* On entry, the (N-1) subdiagonal elements of the unit */
+/* bidiagonal matrix L are in elements 1 to N-1 of L */
+/* (if the matrix is not splitted.) At the end of each block */
+/* is stored the corresponding shift as given by SLARRE. */
+/* On exit, L is overwritten. */
+
+/* PIVMIN (in) DOUBLE PRECISION */
+/* The minimum pivot allowed in the Sturm sequence. */
+
+/* ISPLIT (input) INTEGER array, dimension (N) */
+/* The splitting points, at which T breaks up into blocks. */
+/* The first block consists of rows/columns 1 to */
+/* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 */
+/* through ISPLIT( 2 ), etc. */
+
+/* M (input) INTEGER */
+/* The total number of input eigenvalues. 0 <= M <= N. */
+
+/* DOL (input) INTEGER */
+/* DOU (input) INTEGER */
+/* If the user wants to compute only selected eigenvectors from all */
+/* the eigenvalues supplied, he can specify an index range DOL:DOU. */
+/* Or else the setting DOL=1, DOU=M should be applied. */
+/* Note that DOL and DOU refer to the order in which the eigenvalues */
+/* are stored in W. */
+/* If the user wants to compute only selected eigenpairs, then */
+/* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the */
+/* computed eigenvectors. All other columns of Z are set to zero. */
+
+/* MINRGP (input) REAL */
+
+/* RTOL1 (input) REAL */
+/* RTOL2 (input) REAL */
+/* Parameters for bisection. */
+/* An interval [LEFT,RIGHT] has converged if */
+/* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */
+
+/* W (input/output) REAL array, dimension (N) */
+/* The first M elements of W contain the APPROXIMATE eigenvalues for */
+/* which eigenvectors are to be computed. The eigenvalues */
+/* should be grouped by split-off block and ordered from */
+/* smallest to largest within the block ( The output array */
+/* W from SLARRE is expected here ). Furthermore, they are with */
+/* respect to the shift of the corresponding root representation */
+/* for their block. On exit, W holds the eigenvalues of the */
+/* UNshifted matrix. */
+
+/* WERR (input/output) REAL array, dimension (N) */
+/* The first M elements contain the semiwidth of the uncertainty */
+/* interval of the corresponding eigenvalue in W */
+
+/* WGAP (input/output) REAL array, dimension (N) */
+/* The separation from the right neighbor eigenvalue in W. */
+
+/* IBLOCK (input) INTEGER array, dimension (N) */
+/* The indices of the blocks (submatrices) associated with the */
+/* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue */
+/* W(i) belongs to the first block from the top, =2 if W(i) */
+/* belongs to the second block, etc. */
+
+/* INDEXW (input) INTEGER array, dimension (N) */
+/* The indices of the eigenvalues within each block (submatrix); */
+/* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the */
+/* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block. */
+
+/* GERS (input) REAL array, dimension (2*N) */
+/* The N Gerschgorin intervals (the i-th Gerschgorin interval */
+/* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should */
+/* be computed from the original UNshifted matrix. */
+
+/* Z (output) REAL array, dimension (LDZ, max(1,M) ) */
+/* If INFO = 0, the first M columns of Z contain the */
+/* orthonormal eigenvectors of the matrix T */
+/* corresponding to the input eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */
+/* The support of the eigenvectors in Z, i.e., the indices */
+/* indicating the nonzero elements in Z. The I-th eigenvector */
+/* is nonzero only in elements ISUPPZ( 2*I-1 ) through */
+/* ISUPPZ( 2*I ). */
+
+/* WORK (workspace) REAL array, dimension (12*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (7*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+
+/* > 0: A problem occured in SLARRV. */
+/* < 0: One of the called subroutines signaled an internal problem. */
+/* Needs inspection of the corresponding parameter IINFO */
+/* for further information. */
+
+/* =-1: Problem in SLARRB when refining a child's eigenvalues. */
+/* =-2: Problem in SLARRF when computing the RRR of a child. */
+/* When a child is inside a tight cluster, it can be difficult */
+/* to find an RRR. A partial remedy from the user's point of */
+/* view is to make the parameter MINRGP smaller and recompile. */
+/* However, as the orthogonality of the computed vectors is */
+/* proportional to 1/MINRGP, the user should be aware that */
+/* he might be trading in precision when he decreases MINRGP. */
+/* =-3: Problem in SLARRB when refining a single eigenvalue */
+/* after the Rayleigh correction was rejected. */
+/* = 5: The Rayleigh Quotient Iteration failed to converge to */
+/* full accuracy in MAXITR steps. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+/* .. */
+/* The first N entries of WORK are reserved for the eigenvalues */
+ /* Parameter adjustments */
+ --d__;
+ --l;
+ --isplit;
+ --w;
+ --werr;
+ --wgap;
+ --iblock;
+ --indexw;
+ --gers;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --isuppz;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ indld = *n + 1;
+ indlld = (*n << 1) + 1;
+ indwrk = *n * 3 + 1;
+ minwsize = *n * 12;
+ i__1 = minwsize;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L5: */
+ }
+/* IWORK(IINDR+1:IINDR+N) hold the twist indices R for the */
+/* factorization used to compute the FP vector */
+ iindr = 0;
+/* IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current */
+/* layer and the one above. */
+ iindc1 = *n;
+ iindc2 = *n << 1;
+ iindwk = *n * 3 + 1;
+ miniwsize = *n * 7;
+ i__1 = miniwsize;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ iwork[i__] = 0;
+/* L10: */
+ }
+ zusedl = 1;
+ if (*dol > 1) {
+/* Set lower bound for use of Z */
+ zusedl = *dol - 1;
+ }
+ zusedu = *m;
+ if (*dou < *m) {
+/* Set lower bound for use of Z */
+ zusedu = *dou + 1;
+ }
+/* The width of the part of Z that is used */
+ zusedw = zusedu - zusedl + 1;
+ slaset_("Full", n, &zusedw, &c_b5, &c_b5, &z__[zusedl * z_dim1 + 1], ldz);
+ eps = slamch_("Precision");
+ rqtol = eps * 2.f;
+
+/* Set expert flags for standard code. */
+ tryrqc = TRUE_;
+ if (*dol == 1 && *dou == *m) {
+ } else {
+/* Only selected eigenpairs are computed. Since the other evalues */
+/* are not refined by RQ iteration, bisection has to compute to full */
+/* accuracy. */
+ *rtol1 = eps * 4.f;
+ *rtol2 = eps * 4.f;
+ }
+/* The entries WBEGIN:WEND in W, WERR, WGAP correspond to the */
+/* desired eigenvalues. The support of the nonzero eigenvector */
+/* entries is contained in the interval IBEGIN:IEND. */
+/* Remark that if k eigenpairs are desired, then the eigenvectors */
+/* are stored in k contiguous columns of Z. */
+/* DONE is the number of eigenvectors already computed */
+ done = 0;
+ ibegin = 1;
+ wbegin = 1;
+ i__1 = iblock[*m];
+ for (jblk = 1; jblk <= i__1; ++jblk) {
+ iend = isplit[jblk];
+ sigma = l[iend];
+/* Find the eigenvectors of the submatrix indexed IBEGIN */
+/* through IEND. */
+ wend = wbegin - 1;
+L15:
+ if (wend < *m) {
+ if (iblock[wend + 1] == jblk) {
+ ++wend;
+ goto L15;
+ }
+ }
+ if (wend < wbegin) {
+ ibegin = iend + 1;
+ goto L170;
+ } else if (wend < *dol || wbegin > *dou) {
+ ibegin = iend + 1;
+ wbegin = wend + 1;
+ goto L170;
+ }
+/* Find local spectral diameter of the block */
+ gl = gers[(ibegin << 1) - 1];
+ gu = gers[ibegin * 2];
+ i__2 = iend;
+ for (i__ = ibegin + 1; i__ <= i__2; ++i__) {
+/* Computing MIN */
+ r__1 = gers[(i__ << 1) - 1];
+ gl = dmin(r__1,gl);
+/* Computing MAX */
+ r__1 = gers[i__ * 2];
+ gu = dmax(r__1,gu);
+/* L20: */
+ }
+ spdiam = gu - gl;
+/* OLDIEN is the last index of the previous block */
+ oldien = ibegin - 1;
+/* Calculate the size of the current block */
+ in = iend - ibegin + 1;
+/* The number of eigenvalues in the current block */
+ im = wend - wbegin + 1;
+/* This is for a 1x1 block */
+ if (ibegin == iend) {
+ ++done;
+ z__[ibegin + wbegin * z_dim1] = 1.f;
+ isuppz[(wbegin << 1) - 1] = ibegin;
+ isuppz[wbegin * 2] = ibegin;
+ w[wbegin] += sigma;
+ work[wbegin] = w[wbegin];
+ ibegin = iend + 1;
+ ++wbegin;
+ goto L170;
+ }
+/* The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND) */
+/* Note that these can be approximations, in this case, the corresp. */
+/* entries of WERR give the size of the uncertainty interval. */
+/* The eigenvalue approximations will be refined when necessary as */
+/* high relative accuracy is required for the computation of the */
+/* corresponding eigenvectors. */
+ scopy_(&im, &w[wbegin], &c__1, &work[wbegin], &c__1);
+/* We store in W the eigenvalue approximations w.r.t. the original */
+/* matrix T. */
+ i__2 = im;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ w[wbegin + i__ - 1] += sigma;
+/* L30: */
+ }
+/* NDEPTH is the current depth of the representation tree */
+ ndepth = 0;
+/* PARITY is either 1 or 0 */
+ parity = 1;
+/* NCLUS is the number of clusters for the next level of the */
+/* representation tree, we start with NCLUS = 1 for the root */
+ nclus = 1;
+ iwork[iindc1 + 1] = 1;
+ iwork[iindc1 + 2] = im;
+/* IDONE is the number of eigenvectors already computed in the current */
+/* block */
+ idone = 0;
+/* loop while( IDONE.LT.IM ) */
+/* generate the representation tree for the current block and */
+/* compute the eigenvectors */
+L40:
+ if (idone < im) {
+/* This is a crude protection against infinitely deep trees */
+ if (ndepth > *m) {
+ *info = -2;
+ return 0;
+ }
+/* breadth first processing of the current level of the representation */
+/* tree: OLDNCL = number of clusters on current level */
+ oldncl = nclus;
+/* reset NCLUS to count the number of child clusters */
+ nclus = 0;
+
+ parity = 1 - parity;
+ if (parity == 0) {
+ oldcls = iindc1;
+ newcls = iindc2;
+ } else {
+ oldcls = iindc2;
+ newcls = iindc1;
+ }
+/* Process the clusters on the current level */
+ i__2 = oldncl;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ j = oldcls + (i__ << 1);
+/* OLDFST, OLDLST = first, last index of current cluster. */
+/* cluster indices start with 1 and are relative */
+/* to WBEGIN when accessing W, WGAP, WERR, Z */
+ oldfst = iwork[j - 1];
+ oldlst = iwork[j];
+ if (ndepth > 0) {
+/* Retrieve relatively robust representation (RRR) of cluster */
+/* that has been computed at the previous level */
+/* The RRR is stored in Z and overwritten once the eigenvectors */
+/* have been computed or when the cluster is refined */
+ if (*dol == 1 && *dou == *m) {
+/* Get representation from location of the leftmost evalue */
+/* of the cluster */
+ j = wbegin + oldfst - 1;
+ } else {
+ if (wbegin + oldfst - 1 < *dol) {
+/* Get representation from the left end of Z array */
+ j = *dol - 1;
+ } else if (wbegin + oldfst - 1 > *dou) {
+/* Get representation from the right end of Z array */
+ j = *dou;
+ } else {
+ j = wbegin + oldfst - 1;
+ }
+ }
+ scopy_(&in, &z__[ibegin + j * z_dim1], &c__1, &d__[ibegin]
+, &c__1);
+ i__3 = in - 1;
+ scopy_(&i__3, &z__[ibegin + (j + 1) * z_dim1], &c__1, &l[
+ ibegin], &c__1);
+ sigma = z__[iend + (j + 1) * z_dim1];
+/* Set the corresponding entries in Z to zero */
+ slaset_("Full", &in, &c__2, &c_b5, &c_b5, &z__[ibegin + j
+ * z_dim1], ldz);
+ }
+/* Compute DL and DLL of current RRR */
+ i__3 = iend - 1;
+ for (j = ibegin; j <= i__3; ++j) {
+ tmp = d__[j] * l[j];
+ work[indld - 1 + j] = tmp;
+ work[indlld - 1 + j] = tmp * l[j];
+/* L50: */
+ }
+ if (ndepth > 0) {
+/* P and Q are index of the first and last eigenvalue to compute */
+/* within the current block */
+ p = indexw[wbegin - 1 + oldfst];
+ q = indexw[wbegin - 1 + oldlst];
+/* Offset for the arrays WORK, WGAP and WERR, i.e., th P-OFFSET */
+/* thru' Q-OFFSET elements of these arrays are to be used. */
+/* OFFSET = P-OLDFST */
+ offset = indexw[wbegin] - 1;
+/* perform limited bisection (if necessary) to get approximate */
+/* eigenvalues to the precision needed. */
+ slarrb_(&in, &d__[ibegin], &work[indlld + ibegin - 1], &p,
+ &q, rtol1, rtol2, &offset, &work[wbegin], &wgap[
+ wbegin], &werr[wbegin], &work[indwrk], &iwork[
+ iindwk], pivmin, &spdiam, &in, &iinfo);
+ if (iinfo != 0) {
+ *info = -1;
+ return 0;
+ }
+/* We also recompute the extremal gaps. W holds all eigenvalues */
+/* of the unshifted matrix and must be used for computation */
+/* of WGAP, the entries of WORK might stem from RRRs with */
+/* different shifts. The gaps from WBEGIN-1+OLDFST to */
+/* WBEGIN-1+OLDLST are correctly computed in SLARRB. */
+/* However, we only allow the gaps to become greater since */
+/* this is what should happen when we decrease WERR */
+ if (oldfst > 1) {
+/* Computing MAX */
+ r__1 = wgap[wbegin + oldfst - 2], r__2 = w[wbegin +
+ oldfst - 1] - werr[wbegin + oldfst - 1] - w[
+ wbegin + oldfst - 2] - werr[wbegin + oldfst -
+ 2];
+ wgap[wbegin + oldfst - 2] = dmax(r__1,r__2);
+ }
+ if (wbegin + oldlst - 1 < wend) {
+/* Computing MAX */
+ r__1 = wgap[wbegin + oldlst - 1], r__2 = w[wbegin +
+ oldlst] - werr[wbegin + oldlst] - w[wbegin +
+ oldlst - 1] - werr[wbegin + oldlst - 1];
+ wgap[wbegin + oldlst - 1] = dmax(r__1,r__2);
+ }
+/* Each time the eigenvalues in WORK get refined, we store */
+/* the newly found approximation with all shifts applied in W */
+ i__3 = oldlst;
+ for (j = oldfst; j <= i__3; ++j) {
+ w[wbegin + j - 1] = work[wbegin + j - 1] + sigma;
+/* L53: */
+ }
+ }
+/* Process the current node. */
+ newfst = oldfst;
+ i__3 = oldlst;
+ for (j = oldfst; j <= i__3; ++j) {
+ if (j == oldlst) {
+/* we are at the right end of the cluster, this is also the */
+/* boundary of the child cluster */
+ newlst = j;
+ } else if (wgap[wbegin + j - 1] >= *minrgp * (r__1 = work[
+ wbegin + j - 1], dabs(r__1))) {
+/* the right relative gap is big enough, the child cluster */
+/* (NEWFST,..,NEWLST) is well separated from the following */
+ newlst = j;
+ } else {
+/* inside a child cluster, the relative gap is not */
+/* big enough. */
+ goto L140;
+ }
+/* Compute size of child cluster found */
+ newsiz = newlst - newfst + 1;
+/* NEWFTT is the place in Z where the new RRR or the computed */
+/* eigenvector is to be stored */
+ if (*dol == 1 && *dou == *m) {
+/* Store representation at location of the leftmost evalue */
+/* of the cluster */
+ newftt = wbegin + newfst - 1;
+ } else {
+ if (wbegin + newfst - 1 < *dol) {
+/* Store representation at the left end of Z array */
+ newftt = *dol - 1;
+ } else if (wbegin + newfst - 1 > *dou) {
+/* Store representation at the right end of Z array */
+ newftt = *dou;
+ } else {
+ newftt = wbegin + newfst - 1;
+ }
+ }
+ if (newsiz > 1) {
+
+/* Current child is not a singleton but a cluster. */
+/* Compute and store new representation of child. */
+
+
+/* Compute left and right cluster gap. */
+
+/* LGAP and RGAP are not computed from WORK because */
+/* the eigenvalue approximations may stem from RRRs */
+/* different shifts. However, W hold all eigenvalues */
+/* of the unshifted matrix. Still, the entries in WGAP */
+/* have to be computed from WORK since the entries */
+/* in W might be of the same order so that gaps are not */
+/* exhibited correctly for very close eigenvalues. */
+ if (newfst == 1) {
+/* Computing MAX */
+ r__1 = 0.f, r__2 = w[wbegin] - werr[wbegin] - *vl;
+ lgap = dmax(r__1,r__2);
+ } else {
+ lgap = wgap[wbegin + newfst - 2];
+ }
+ rgap = wgap[wbegin + newlst - 1];
+
+/* Compute left- and rightmost eigenvalue of child */
+/* to high precision in order to shift as close */
+/* as possible and obtain as large relative gaps */
+/* as possible */
+
+ for (k = 1; k <= 2; ++k) {
+ if (k == 1) {
+ p = indexw[wbegin - 1 + newfst];
+ } else {
+ p = indexw[wbegin - 1 + newlst];
+ }
+ offset = indexw[wbegin] - 1;
+ slarrb_(&in, &d__[ibegin], &work[indlld + ibegin
+ - 1], &p, &p, &rqtol, &rqtol, &offset, &
+ work[wbegin], &wgap[wbegin], &werr[wbegin]
+, &work[indwrk], &iwork[iindwk], pivmin, &
+ spdiam, &in, &iinfo);
+/* L55: */
+ }
+
+ if (wbegin + newlst - 1 < *dol || wbegin + newfst - 1
+ > *dou) {
+/* if the cluster contains no desired eigenvalues */
+/* skip the computation of that branch of the rep. tree */
+
+/* We could skip before the refinement of the extremal */
+/* eigenvalues of the child, but then the representation */
+/* tree could be different from the one when nothing is */
+/* skipped. For this reason we skip at this place. */
+ idone = idone + newlst - newfst + 1;
+ goto L139;
+ }
+
+/* Compute RRR of child cluster. */
+/* Note that the new RRR is stored in Z */
+
+/* SLARRF needs LWORK = 2*N */
+ slarrf_(&in, &d__[ibegin], &l[ibegin], &work[indld +
+ ibegin - 1], &newfst, &newlst, &work[wbegin],
+ &wgap[wbegin], &werr[wbegin], &spdiam, &lgap,
+ &rgap, pivmin, &tau, &z__[ibegin + newftt *
+ z_dim1], &z__[ibegin + (newftt + 1) * z_dim1],
+ &work[indwrk], &iinfo);
+ if (iinfo == 0) {
+/* a new RRR for the cluster was found by SLARRF */
+/* update shift and store it */
+ ssigma = sigma + tau;
+ z__[iend + (newftt + 1) * z_dim1] = ssigma;
+/* WORK() are the midpoints and WERR() the semi-width */
+/* Note that the entries in W are unchanged. */
+ i__4 = newlst;
+ for (k = newfst; k <= i__4; ++k) {
+ fudge = eps * 3.f * (r__1 = work[wbegin + k -
+ 1], dabs(r__1));
+ work[wbegin + k - 1] -= tau;
+ fudge += eps * 4.f * (r__1 = work[wbegin + k
+ - 1], dabs(r__1));
+/* Fudge errors */
+ werr[wbegin + k - 1] += fudge;
+/* Gaps are not fudged. Provided that WERR is small */
+/* when eigenvalues are close, a zero gap indicates */
+/* that a new representation is needed for resolving */
+/* the cluster. A fudge could lead to a wrong decision */
+/* of judging eigenvalues 'separated' which in */
+/* reality are not. This could have a negative impact */
+/* on the orthogonality of the computed eigenvectors. */
+/* L116: */
+ }
+ ++nclus;
+ k = newcls + (nclus << 1);
+ iwork[k - 1] = newfst;
+ iwork[k] = newlst;
+ } else {
+ *info = -2;
+ return 0;
+ }
+ } else {
+
+/* Compute eigenvector of singleton */
+
+ iter = 0;
+
+ tol = log((real) in) * 4.f * eps;
+
+ k = newfst;
+ windex = wbegin + k - 1;
+/* Computing MAX */
+ i__4 = windex - 1;
+ windmn = max(i__4,1);
+/* Computing MIN */
+ i__4 = windex + 1;
+ windpl = min(i__4,*m);
+ lambda = work[windex];
+ ++done;
+/* Check if eigenvector computation is to be skipped */
+ if (windex < *dol || windex > *dou) {
+ eskip = TRUE_;
+ goto L125;
+ } else {
+ eskip = FALSE_;
+ }
+ left = work[windex] - werr[windex];
+ right = work[windex] + werr[windex];
+ indeig = indexw[windex];
+/* Note that since we compute the eigenpairs for a child, */
+/* all eigenvalue approximations are w.r.t the same shift. */
+/* In this case, the entries in WORK should be used for */
+/* computing the gaps since they exhibit even very small */
+/* differences in the eigenvalues, as opposed to the */
+/* entries in W which might "look" the same. */
+ if (k == 1) {
+/* In the case RANGE='I' and with not much initial */
+/* accuracy in LAMBDA and VL, the formula */
+/* LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA ) */
+/* can lead to an overestimation of the left gap and */
+/* thus to inadequately early RQI 'convergence'. */
+/* Prevent this by forcing a small left gap. */
+/* Computing MAX */
+ r__1 = dabs(left), r__2 = dabs(right);
+ lgap = eps * dmax(r__1,r__2);
+ } else {
+ lgap = wgap[windmn];
+ }
+ if (k == im) {
+/* In the case RANGE='I' and with not much initial */
+/* accuracy in LAMBDA and VU, the formula */
+/* can lead to an overestimation of the right gap and */
+/* thus to inadequately early RQI 'convergence'. */
+/* Prevent this by forcing a small right gap. */
+/* Computing MAX */
+ r__1 = dabs(left), r__2 = dabs(right);
+ rgap = eps * dmax(r__1,r__2);
+ } else {
+ rgap = wgap[windex];
+ }
+ gap = dmin(lgap,rgap);
+ if (k == 1 || k == im) {
+/* The eigenvector support can become wrong */
+/* because significant entries could be cut off due to a */
+/* large GAPTOL parameter in LAR1V. Prevent this. */
+ gaptol = 0.f;
+ } else {
+ gaptol = gap * eps;
+ }
+ isupmn = in;
+ isupmx = 1;
+/* Update WGAP so that it holds the minimum gap */
+/* to the left or the right. This is crucial in the */
+/* case where bisection is used to ensure that the */
+/* eigenvalue is refined up to the required precision. */
+/* The correct value is restored afterwards. */
+ savgap = wgap[windex];
+ wgap[windex] = gap;
+/* We want to use the Rayleigh Quotient Correction */
+/* as often as possible since it converges quadratically */
+/* when we are close enough to the desired eigenvalue. */
+/* However, the Rayleigh Quotient can have the wrong sign */
+/* and lead us away from the desired eigenvalue. In this */
+/* case, the best we can do is to use bisection. */
+ usedbs = FALSE_;
+ usedrq = FALSE_;
+/* Bisection is initially turned off unless it is forced */
+ needbs = ! tryrqc;
+L120:
+/* Check if bisection should be used to refine eigenvalue */
+ if (needbs) {
+/* Take the bisection as new iterate */
+ usedbs = TRUE_;
+ itmp1 = iwork[iindr + windex];
+ offset = indexw[wbegin] - 1;
+ r__1 = eps * 2.f;
+ slarrb_(&in, &d__[ibegin], &work[indlld + ibegin
+ - 1], &indeig, &indeig, &c_b5, &r__1, &
+ offset, &work[wbegin], &wgap[wbegin], &
+ werr[wbegin], &work[indwrk], &iwork[
+ iindwk], pivmin, &spdiam, &itmp1, &iinfo);
+ if (iinfo != 0) {
+ *info = -3;
+ return 0;
+ }
+ lambda = work[windex];
+/* Reset twist index from inaccurate LAMBDA to */
+/* force computation of true MINGMA */
+ iwork[iindr + windex] = 0;
+ }
+/* Given LAMBDA, compute the eigenvector. */
+ L__1 = ! usedbs;
+ slar1v_(&in, &c__1, &in, &lambda, &d__[ibegin], &l[
+ ibegin], &work[indld + ibegin - 1], &work[
+ indlld + ibegin - 1], pivmin, &gaptol, &z__[
+ ibegin + windex * z_dim1], &L__1, &negcnt, &
+ ztz, &mingma, &iwork[iindr + windex], &isuppz[
+ (windex << 1) - 1], &nrminv, &resid, &rqcorr,
+ &work[indwrk]);
+ if (iter == 0) {
+ bstres = resid;
+ bstw = lambda;
+ } else if (resid < bstres) {
+ bstres = resid;
+ bstw = lambda;
+ }
+/* Computing MIN */
+ i__4 = isupmn, i__5 = isuppz[(windex << 1) - 1];
+ isupmn = min(i__4,i__5);
+/* Computing MAX */
+ i__4 = isupmx, i__5 = isuppz[windex * 2];
+ isupmx = max(i__4,i__5);
+ ++iter;
+/* sin alpha <= |resid|/gap */
+/* Note that both the residual and the gap are */
+/* proportional to the matrix, so ||T|| doesn't play */
+/* a role in the quotient */
+
+/* Convergence test for Rayleigh-Quotient iteration */
+/* (omitted when Bisection has been used) */
+
+ if (resid > tol * gap && dabs(rqcorr) > rqtol * dabs(
+ lambda) && ! usedbs) {
+/* We need to check that the RQCORR update doesn't */
+/* move the eigenvalue away from the desired one and */
+/* towards a neighbor. -> protection with bisection */
+ if (indeig <= negcnt) {
+/* The wanted eigenvalue lies to the left */
+ sgndef = -1.f;
+ } else {
+/* The wanted eigenvalue lies to the right */
+ sgndef = 1.f;
+ }
+/* We only use the RQCORR if it improves the */
+/* the iterate reasonably. */
+ if (rqcorr * sgndef >= 0.f && lambda + rqcorr <=
+ right && lambda + rqcorr >= left) {
+ usedrq = TRUE_;
+/* Store new midpoint of bisection interval in WORK */
+ if (sgndef == 1.f) {
+/* The current LAMBDA is on the left of the true */
+/* eigenvalue */
+ left = lambda;
+/* We prefer to assume that the error estimate */
+/* is correct. We could make the interval not */
+/* as a bracket but to be modified if the RQCORR */
+/* chooses to. In this case, the RIGHT side should */
+/* be modified as follows: */
+/* RIGHT = MAX(RIGHT, LAMBDA + RQCORR) */
+ } else {
+/* The current LAMBDA is on the right of the true */
+/* eigenvalue */
+ right = lambda;
+/* See comment about assuming the error estimate is */
+/* correct above. */
+/* LEFT = MIN(LEFT, LAMBDA + RQCORR) */
+ }
+ work[windex] = (right + left) * .5f;
+/* Take RQCORR since it has the correct sign and */
+/* improves the iterate reasonably */
+ lambda += rqcorr;
+/* Update width of error interval */
+ werr[windex] = (right - left) * .5f;
+ } else {
+ needbs = TRUE_;
+ }
+ if (right - left < rqtol * dabs(lambda)) {
+/* The eigenvalue is computed to bisection accuracy */
+/* compute eigenvector and stop */
+ usedbs = TRUE_;
+ goto L120;
+ } else if (iter < 10) {
+ goto L120;
+ } else if (iter == 10) {
+ needbs = TRUE_;
+ goto L120;
+ } else {
+ *info = 5;
+ return 0;
+ }
+ } else {
+ stp2ii = FALSE_;
+ if (usedrq && usedbs && bstres <= resid) {
+ lambda = bstw;
+ stp2ii = TRUE_;
+ }
+ if (stp2ii) {
+/* improve error angle by second step */
+ L__1 = ! usedbs;
+ slar1v_(&in, &c__1, &in, &lambda, &d__[ibegin]
+, &l[ibegin], &work[indld + ibegin -
+ 1], &work[indlld + ibegin - 1],
+ pivmin, &gaptol, &z__[ibegin + windex
+ * z_dim1], &L__1, &negcnt, &ztz, &
+ mingma, &iwork[iindr + windex], &
+ isuppz[(windex << 1) - 1], &nrminv, &
+ resid, &rqcorr, &work[indwrk]);
+ }
+ work[windex] = lambda;
+ }
+
+/* Compute FP-vector support w.r.t. whole matrix */
+
+ isuppz[(windex << 1) - 1] += oldien;
+ isuppz[windex * 2] += oldien;
+ zfrom = isuppz[(windex << 1) - 1];
+ zto = isuppz[windex * 2];
+ isupmn += oldien;
+ isupmx += oldien;
+/* Ensure vector is ok if support in the RQI has changed */
+ if (isupmn < zfrom) {
+ i__4 = zfrom - 1;
+ for (ii = isupmn; ii <= i__4; ++ii) {
+ z__[ii + windex * z_dim1] = 0.f;
+/* L122: */
+ }
+ }
+ if (isupmx > zto) {
+ i__4 = isupmx;
+ for (ii = zto + 1; ii <= i__4; ++ii) {
+ z__[ii + windex * z_dim1] = 0.f;
+/* L123: */
+ }
+ }
+ i__4 = zto - zfrom + 1;
+ sscal_(&i__4, &nrminv, &z__[zfrom + windex * z_dim1],
+ &c__1);
+L125:
+/* Update W */
+ w[windex] = lambda + sigma;
+/* Recompute the gaps on the left and right */
+/* But only allow them to become larger and not */
+/* smaller (which can only happen through "bad" */
+/* cancellation and doesn't reflect the theory */
+/* where the initial gaps are underestimated due */
+/* to WERR being too crude.) */
+ if (! eskip) {
+ if (k > 1) {
+/* Computing MAX */
+ r__1 = wgap[windmn], r__2 = w[windex] - werr[
+ windex] - w[windmn] - werr[windmn];
+ wgap[windmn] = dmax(r__1,r__2);
+ }
+ if (windex < wend) {
+/* Computing MAX */
+ r__1 = savgap, r__2 = w[windpl] - werr[windpl]
+ - w[windex] - werr[windex];
+ wgap[windex] = dmax(r__1,r__2);
+ }
+ }
+ ++idone;
+ }
+/* here ends the code for the current child */
+
+L139:
+/* Proceed to any remaining child nodes */
+ newfst = j + 1;
+L140:
+ ;
+ }
+/* L150: */
+ }
+ ++ndepth;
+ goto L40;
+ }
+ ibegin = iend + 1;
+ wbegin = wend + 1;
+L170:
+ ;
+ }
+
+ return 0;
+
+/* End of SLARRV */
+
+} /* slarrv_ */
diff --git a/SRC/slarscl2.c b/SRC/slarscl2.c
new file mode 100644
index 0000000..c6ecda2
--- /dev/null
+++ b/SRC/slarscl2.c
@@ -0,0 +1,90 @@
+/* slarscl2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slarscl2_(integer *m, integer *n, real *d__, real *x,
+ integer *ldx)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARSCL2 performs a reciprocal diagonal scaling on an vector: */
+/* x <-- inv(D) * x */
+/* where the diagonal matrix D is stored as a vector. */
+
+/* Eventually to be replaced by BLAS_sge_diag_scale in the new BLAS */
+/* standard. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of D and X. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of D and X. N >= 0. */
+
+/* D (input) REAL array, length M */
+/* Diagonal matrix D, stored as a vector of length M. */
+
+/* X (input/output) REAL array, dimension (LDX,N) */
+/* On entry, the vector X to be scaled by D. */
+/* On exit, the scaled vector. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the vector X. LDX >= 0. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --d__;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+
+ /* Function Body */
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__ + j * x_dim1] /= d__[i__];
+ }
+ }
+ return 0;
+} /* slarscl2_ */
diff --git a/SRC/slartg.c b/SRC/slartg.c
new file mode 100644
index 0000000..d1d5281
--- /dev/null
+++ b/SRC/slartg.c
@@ -0,0 +1,189 @@
+/* slartg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slartg_(real *f, real *g, real *cs, real *sn, real *r__)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double log(doublereal), pow_ri(real *, integer *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real f1, g1, eps, scale;
+ integer count;
+ real safmn2, safmx2;
+ extern doublereal slamch_(char *);
+ real safmin;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARTG generate a plane rotation so that */
+
+/* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. */
+/* [ -SN CS ] [ G ] [ 0 ] */
+
+/* This is a slower, more accurate version of the BLAS1 routine SROTG, */
+/* with the following other differences: */
+/* F and G are unchanged on return. */
+/* If G=0, then CS=1 and SN=0. */
+/* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any */
+/* floating point operations (saves work in SBDSQR when */
+/* there are zeros on the diagonal). */
+
+/* If F exceeds G in magnitude, CS will be positive. */
+
+/* Arguments */
+/* ========= */
+
+/* F (input) REAL */
+/* The first component of vector to be rotated. */
+
+/* G (input) REAL */
+/* The second component of vector to be rotated. */
+
+/* CS (output) REAL */
+/* The cosine of the rotation. */
+
+/* SN (output) REAL */
+/* The sine of the rotation. */
+
+/* R (output) REAL */
+/* The nonzero component of the rotated vector. */
+
+/* This version has a few statements commented out for thread safety */
+/* (machine parameters are computed on each entry). 10 feb 03, SJH. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* LOGICAL FIRST */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Save statement .. */
+/* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 */
+/* .. */
+/* .. Data statements .. */
+/* DATA FIRST / .TRUE. / */
+/* .. */
+/* .. Executable Statements .. */
+
+/* IF( FIRST ) THEN */
+ safmin = slamch_("S");
+ eps = slamch_("E");
+ r__1 = slamch_("B");
+ i__1 = (integer) (log(safmin / eps) / log(slamch_("B")) / 2.f);
+ safmn2 = pow_ri(&r__1, &i__1);
+ safmx2 = 1.f / safmn2;
+/* FIRST = .FALSE. */
+/* END IF */
+ if (*g == 0.f) {
+ *cs = 1.f;
+ *sn = 0.f;
+ *r__ = *f;
+ } else if (*f == 0.f) {
+ *cs = 0.f;
+ *sn = 1.f;
+ *r__ = *g;
+ } else {
+ f1 = *f;
+ g1 = *g;
+/* Computing MAX */
+ r__1 = dabs(f1), r__2 = dabs(g1);
+ scale = dmax(r__1,r__2);
+ if (scale >= safmx2) {
+ count = 0;
+L10:
+ ++count;
+ f1 *= safmn2;
+ g1 *= safmn2;
+/* Computing MAX */
+ r__1 = dabs(f1), r__2 = dabs(g1);
+ scale = dmax(r__1,r__2);
+ if (scale >= safmx2) {
+ goto L10;
+ }
+/* Computing 2nd power */
+ r__1 = f1;
+/* Computing 2nd power */
+ r__2 = g1;
+ *r__ = sqrt(r__1 * r__1 + r__2 * r__2);
+ *cs = f1 / *r__;
+ *sn = g1 / *r__;
+ i__1 = count;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ *r__ *= safmx2;
+/* L20: */
+ }
+ } else if (scale <= safmn2) {
+ count = 0;
+L30:
+ ++count;
+ f1 *= safmx2;
+ g1 *= safmx2;
+/* Computing MAX */
+ r__1 = dabs(f1), r__2 = dabs(g1);
+ scale = dmax(r__1,r__2);
+ if (scale <= safmn2) {
+ goto L30;
+ }
+/* Computing 2nd power */
+ r__1 = f1;
+/* Computing 2nd power */
+ r__2 = g1;
+ *r__ = sqrt(r__1 * r__1 + r__2 * r__2);
+ *cs = f1 / *r__;
+ *sn = g1 / *r__;
+ i__1 = count;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ *r__ *= safmn2;
+/* L40: */
+ }
+ } else {
+/* Computing 2nd power */
+ r__1 = f1;
+/* Computing 2nd power */
+ r__2 = g1;
+ *r__ = sqrt(r__1 * r__1 + r__2 * r__2);
+ *cs = f1 / *r__;
+ *sn = g1 / *r__;
+ }
+ if (dabs(*f) > dabs(*g) && *cs < 0.f) {
+ *cs = -(*cs);
+ *sn = -(*sn);
+ *r__ = -(*r__);
+ }
+ }
+ return 0;
+
+/* End of SLARTG */
+
+} /* slartg_ */
diff --git a/SRC/slartv.c b/SRC/slartv.c
new file mode 100644
index 0000000..58d967b
--- /dev/null
+++ b/SRC/slartv.c
@@ -0,0 +1,105 @@
+/* slartv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slartv_(integer *n, real *x, integer *incx, real *y,
+ integer *incy, real *c__, real *s, integer *incc)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, ic, ix, iy;
+ real xi, yi;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARTV applies a vector of real plane rotations to elements of the */
+/* real vectors x and y. For i = 1,2,...,n */
+
+/* ( x(i) ) := ( c(i) s(i) ) ( x(i) ) */
+/* ( y(i) ) ( -s(i) c(i) ) ( y(i) ) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of plane rotations to be applied. */
+
+/* X (input/output) REAL array, */
+/* dimension (1+(N-1)*INCX) */
+/* The vector x. */
+
+/* INCX (input) INTEGER */
+/* The increment between elements of X. INCX > 0. */
+
+/* Y (input/output) REAL array, */
+/* dimension (1+(N-1)*INCY) */
+/* The vector y. */
+
+/* INCY (input) INTEGER */
+/* The increment between elements of Y. INCY > 0. */
+
+/* C (input) REAL array, dimension (1+(N-1)*INCC) */
+/* The cosines of the plane rotations. */
+
+/* S (input) REAL array, dimension (1+(N-1)*INCC) */
+/* The sines of the plane rotations. */
+
+/* INCC (input) INTEGER */
+/* The increment between elements of C and S. INCC > 0. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --s;
+ --c__;
+ --y;
+ --x;
+
+ /* Function Body */
+ ix = 1;
+ iy = 1;
+ ic = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xi = x[ix];
+ yi = y[iy];
+ x[ix] = c__[ic] * xi + s[ic] * yi;
+ y[iy] = c__[ic] * yi - s[ic] * xi;
+ ix += *incx;
+ iy += *incy;
+ ic += *incc;
+/* L10: */
+ }
+ return 0;
+
+/* End of SLARTV */
+
+} /* slartv_ */
diff --git a/SRC/slaruv.c b/SRC/slaruv.c
new file mode 100644
index 0000000..68d67fe
--- /dev/null
+++ b/SRC/slaruv.c
@@ -0,0 +1,193 @@
+/* slaruv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slaruv_(integer *iseed, integer *n, real *x)
+{
+ /* Initialized data */
+
+ static integer mm[512] /* was [128][4] */ = { 494,2637,255,2008,1253,
+ 3344,4084,1739,3143,3468,688,1657,1238,3166,1292,3422,1270,2016,
+ 154,2862,697,1706,491,931,1444,444,3577,3944,2184,1661,3482,657,
+ 3023,3618,1267,1828,164,3798,3087,2400,2870,3876,1905,1593,1797,
+ 1234,3460,328,2861,1950,617,2070,3331,769,1558,2412,2800,189,287,
+ 2045,1227,2838,209,2770,3654,3993,192,2253,3491,2889,2857,2094,
+ 1818,688,1407,634,3231,815,3524,1914,516,164,303,2144,3480,119,
+ 3357,837,2826,2332,2089,3780,1700,3712,150,2000,3375,1621,3090,
+ 3765,1149,3146,33,3082,2741,359,3316,1749,185,2784,2202,2199,1364,
+ 1244,2020,3160,2785,2772,1217,1822,1245,2252,3904,2774,997,2573,
+ 1148,545,322,789,1440,752,2859,123,1848,643,2405,2638,2344,46,
+ 3814,913,3649,339,3808,822,2832,3078,3633,2970,637,2249,2081,4019,
+ 1478,242,481,2075,4058,622,3376,812,234,641,4005,1122,3135,2640,
+ 2302,40,1832,2247,2034,2637,1287,1691,496,1597,2394,2584,1843,336,
+ 1472,2407,433,2096,1761,2810,566,442,41,1238,1086,603,840,3168,
+ 1499,1084,3438,2408,1589,2391,288,26,512,1456,171,1677,2657,2270,
+ 2587,2961,1970,1817,676,1410,3723,2803,3185,184,663,499,3784,1631,
+ 1925,3912,1398,1349,1441,2224,2411,1907,3192,2786,382,37,759,2948,
+ 1862,3802,2423,2051,2295,1332,1832,2405,3638,3661,327,3660,716,
+ 1842,3987,1368,1848,2366,2508,3754,1766,3572,2893,307,1297,3966,
+ 758,2598,3406,2922,1038,2934,2091,2451,1580,1958,2055,1507,1078,
+ 3273,17,854,2916,3971,2889,3831,2621,1541,893,736,3992,787,2125,
+ 2364,2460,257,1574,3912,1216,3248,3401,2124,2762,149,2245,166,466,
+ 4018,1399,190,2879,153,2320,18,712,2159,2318,2091,3443,1510,449,
+ 1956,2201,3137,3399,1321,2271,3667,2703,629,2365,2431,1113,3922,
+ 2554,184,2099,3228,4012,1921,3452,3901,572,3309,3171,817,3039,
+ 1696,1256,3715,2077,3019,1497,1101,717,51,981,1978,1813,3881,76,
+ 3846,3694,1682,124,1660,3997,479,1141,886,3514,1301,3604,1888,
+ 1836,1990,2058,692,1194,20,3285,2046,2107,3508,3525,3801,2549,
+ 1145,2253,305,3301,1065,3133,2913,3285,1241,1197,3729,2501,1673,
+ 541,2753,949,2361,1165,4081,2725,3305,3069,3617,3733,409,2157,
+ 1361,3973,1865,2525,1409,3445,3577,77,3761,2149,1449,3005,225,85,
+ 3673,3117,3089,1349,2057,413,65,1845,697,3085,3441,1573,3689,2941,
+ 929,533,2841,4077,721,2821,2249,2397,2817,245,1913,1997,3121,997,
+ 1833,2877,1633,981,2009,941,2449,197,2441,285,1473,2741,3129,909,
+ 2801,421,4073,2813,2337,1429,1177,1901,81,1669,2633,2269,129,1141,
+ 249,3917,2481,3941,2217,2749,3041,1877,345,2861,1809,3141,2825,
+ 157,2881,3637,1465,2829,2161,3365,361,2685,3745,2325,3609,3821,
+ 3537,517,3017,2141,1537 };
+
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, i1, i2, i3, i4, it1, it2, it3, it4;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARUV returns a vector of n random real numbers from a uniform (0,1) */
+/* distribution (n <= 128). */
+
+/* This is an auxiliary routine called by SLARNV and CLARNV. */
+
+/* Arguments */
+/* ========= */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* N (input) INTEGER */
+/* The number of random numbers to be generated. N <= 128. */
+
+/* X (output) REAL array, dimension (N) */
+/* The generated random numbers. */
+
+/* Further Details */
+/* =============== */
+
+/* This routine uses a multiplicative congruential method with modulus */
+/* 2**48 and multiplier 33952834046453 (see G.S.Fishman, */
+/* 'Multiplicative congruential random number generators with modulus */
+/* 2**b: an exhaustive analysis for b = 32 and a partial analysis for */
+/* b = 48', Math. Comp. 189, pp 331-344, 1990). */
+
+/* 48-bit integers are stored in 4 integer array elements with 12 bits */
+/* per element. Hence the routine is portable across machines with */
+/* integers of 32 bits or more. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iseed;
+ --x;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ i1 = iseed[1];
+ i2 = iseed[2];
+ i3 = iseed[3];
+ i4 = iseed[4];
+
+ i__1 = min(*n,128);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+L20:
+
+/* Multiply the seed by i-th power of the multiplier modulo 2**48 */
+
+ it4 = i4 * mm[i__ + 383];
+ it3 = it4 / 4096;
+ it4 -= it3 << 12;
+ it3 = it3 + i3 * mm[i__ + 383] + i4 * mm[i__ + 255];
+ it2 = it3 / 4096;
+ it3 -= it2 << 12;
+ it2 = it2 + i2 * mm[i__ + 383] + i3 * mm[i__ + 255] + i4 * mm[i__ +
+ 127];
+ it1 = it2 / 4096;
+ it2 -= it1 << 12;
+ it1 = it1 + i1 * mm[i__ + 383] + i2 * mm[i__ + 255] + i3 * mm[i__ +
+ 127] + i4 * mm[i__ - 1];
+ it1 %= 4096;
+
+/* Convert 48-bit integer to a real number in the interval (0,1) */
+
+ x[i__] = ((real) it1 + ((real) it2 + ((real) it3 + (real) it4 *
+ 2.44140625e-4f) * 2.44140625e-4f) * 2.44140625e-4f) *
+ 2.44140625e-4f;
+
+ if (x[i__] == 1.f) {
+/* If a real number has n bits of precision, and the first */
+/* n bits of the 48-bit integer above happen to be all 1 (which */
+/* will occur about once every 2**n calls), then X( I ) will */
+/* be rounded to exactly 1.0. In IEEE single precision arithmetic, */
+/* this will happen relatively often since n = 24. */
+/* Since X( I ) is not supposed to return exactly 0.0 or 1.0, */
+/* the statistically correct thing to do in this situation is */
+/* simply to iterate again. */
+/* N.B. the case X( I ) = 0.0 should not be possible. */
+ i1 += 2;
+ i2 += 2;
+ i3 += 2;
+ i4 += 2;
+ goto L20;
+ }
+
+/* L10: */
+ }
+
+/* Return final value of seed */
+
+ iseed[1] = it1;
+ iseed[2] = it2;
+ iseed[3] = it3;
+ iseed[4] = it4;
+ return 0;
+
+/* End of SLARUV */
+
+} /* slaruv_ */
diff --git a/SRC/slarz.c b/SRC/slarz.c
new file mode 100644
index 0000000..05e816d
--- /dev/null
+++ b/SRC/slarz.c
@@ -0,0 +1,190 @@
+/* slarz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b5 = 1.f;
+
+/* Subroutine */ int slarz_(char *side, integer *m, integer *n, integer *l,
+ real *v, integer *incv, real *tau, real *c__, integer *ldc, real *
+ work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset;
+ real r__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *),
+ saxpy_(integer *, real *, real *, integer *, real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARZ applies a real elementary reflector H to a real M-by-N */
+/* matrix C, from either the left or the right. H is represented in the */
+/* form */
+
+/* H = I - tau * v * v' */
+
+/* where tau is a real scalar and v is a real vector. */
+
+/* If tau = 0, then H is taken to be the unit matrix. */
+
+
+/* H is a product of k elementary reflectors as returned by STZRZF. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': form H * C */
+/* = 'R': form C * H */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* L (input) INTEGER */
+/* The number of entries of the vector V containing */
+/* the meaningful part of the Householder vectors. */
+/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */
+
+/* V (input) REAL array, dimension (1+(L-1)*abs(INCV)) */
+/* The vector v in the representation of H as returned by */
+/* STZRZF. V is not used if TAU = 0. */
+
+/* INCV (input) INTEGER */
+/* The increment between elements of v. INCV <> 0. */
+
+/* TAU (input) REAL */
+/* The value tau in the representation of H. */
+
+/* C (input/output) REAL array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
+/* or C * H if SIDE = 'R'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) REAL array, dimension */
+/* (N) if SIDE = 'L' */
+/* or (M) if SIDE = 'R' */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ if (lsame_(side, "L")) {
+
+/* Form H * C */
+
+ if (*tau != 0.f) {
+
+/* w( 1:n ) = C( 1, 1:n ) */
+
+ scopy_(n, &c__[c_offset], ldc, &work[1], &c__1);
+
+/* w( 1:n ) = w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l ) */
+
+ sgemv_("Transpose", l, n, &c_b5, &c__[*m - *l + 1 + c_dim1], ldc,
+ &v[1], incv, &c_b5, &work[1], &c__1);
+
+/* C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n ) */
+
+ r__1 = -(*tau);
+ saxpy_(n, &r__1, &work[1], &c__1, &c__[c_offset], ldc);
+
+/* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... */
+/* tau * v( 1:l ) * w( 1:n )' */
+
+ r__1 = -(*tau);
+ sger_(l, n, &r__1, &v[1], incv, &work[1], &c__1, &c__[*m - *l + 1
+ + c_dim1], ldc);
+ }
+
+ } else {
+
+/* Form C * H */
+
+ if (*tau != 0.f) {
+
+/* w( 1:m ) = C( 1:m, 1 ) */
+
+ scopy_(m, &c__[c_offset], &c__1, &work[1], &c__1);
+
+/* w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l ) */
+
+ sgemv_("No transpose", m, l, &c_b5, &c__[(*n - *l + 1) * c_dim1 +
+ 1], ldc, &v[1], incv, &c_b5, &work[1], &c__1);
+
+/* C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m ) */
+
+ r__1 = -(*tau);
+ saxpy_(m, &r__1, &work[1], &c__1, &c__[c_offset], &c__1);
+
+/* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... */
+/* tau * w( 1:m ) * v( 1:l )' */
+
+ r__1 = -(*tau);
+ sger_(m, l, &r__1, &work[1], &c__1, &v[1], incv, &c__[(*n - *l +
+ 1) * c_dim1 + 1], ldc);
+
+ }
+
+ }
+
+ return 0;
+
+/* End of SLARZ */
+
+} /* slarz_ */
diff --git a/SRC/slarzb.c b/SRC/slarzb.c
new file mode 100644
index 0000000..b472224
--- /dev/null
+++ b/SRC/slarzb.c
@@ -0,0 +1,287 @@
+/* slarzb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b13 = 1.f;
+static real c_b23 = -1.f;
+
+/* Subroutine */ int slarzb_(char *side, char *trans, char *direct, char *
+ storev, integer *m, integer *n, integer *k, integer *l, real *v,
+ integer *ldv, real *t, integer *ldt, real *c__, integer *ldc, real *
+ work, integer *ldwork)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1,
+ work_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, info;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *), scopy_(integer *, real *,
+ integer *, real *, integer *), strmm_(char *, char *, char *,
+ char *, integer *, integer *, real *, real *, integer *, real *,
+ integer *), xerbla_(char *,
+ integer *);
+ char transt[1];
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARZB applies a real block reflector H or its transpose H**T to */
+/* a real distributed M-by-N C from the left or the right. */
+
+/* Currently, only STOREV = 'R' and DIRECT = 'B' are supported. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply H or H' from the Left */
+/* = 'R': apply H or H' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply H (No transpose) */
+/* = 'C': apply H' (Transpose) */
+
+/* DIRECT (input) CHARACTER*1 */
+/* Indicates how H is formed from a product of elementary */
+/* reflectors */
+/* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet) */
+/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
+
+/* STOREV (input) CHARACTER*1 */
+/* Indicates how the vectors which define the elementary */
+/* reflectors are stored: */
+/* = 'C': Columnwise (not supported yet) */
+/* = 'R': Rowwise */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* K (input) INTEGER */
+/* The order of the matrix T (= the number of elementary */
+/* reflectors whose product defines the block reflector). */
+
+/* L (input) INTEGER */
+/* The number of columns of the matrix V containing the */
+/* meaningful part of the Householder reflectors. */
+/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */
+
+/* V (input) REAL array, dimension (LDV,NV). */
+/* If STOREV = 'C', NV = K; if STOREV = 'R', NV = L. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. */
+/* If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K. */
+
+/* T (input) REAL array, dimension (LDT,K) */
+/* The triangular K-by-K matrix T in the representation of the */
+/* block reflector. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= K. */
+
+/* C (input/output) REAL array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) REAL array, dimension (LDWORK,K) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. */
+/* If SIDE = 'L', LDWORK >= max(1,N); */
+/* if SIDE = 'R', LDWORK >= max(1,M). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+/* Check for currently supported options */
+
+ info = 0;
+ if (! lsame_(direct, "B")) {
+ info = -3;
+ } else if (! lsame_(storev, "R")) {
+ info = -4;
+ }
+ if (info != 0) {
+ i__1 = -info;
+ xerbla_("SLARZB", &i__1);
+ return 0;
+ }
+
+ if (lsame_(trans, "N")) {
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+ if (lsame_(side, "L")) {
+
+/* Form H * C or H' * C */
+
+/* W( 1:n, 1:k ) = C( 1:k, 1:n )' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1);
+/* L10: */
+ }
+
+/* W( 1:n, 1:k ) = W( 1:n, 1:k ) + ... */
+/* C( m-l+1:m, 1:n )' * V( 1:k, 1:l )' */
+
+ if (*l > 0) {
+ sgemm_("Transpose", "Transpose", n, k, l, &c_b13, &c__[*m - *l +
+ 1 + c_dim1], ldc, &v[v_offset], ldv, &c_b13, &work[
+ work_offset], ldwork);
+ }
+
+/* W( 1:n, 1:k ) = W( 1:n, 1:k ) * T' or W( 1:m, 1:k ) * T */
+
+ strmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b13, &t[
+ t_offset], ldt, &work[work_offset], ldwork);
+
+/* C( 1:k, 1:n ) = C( 1:k, 1:n ) - W( 1:n, 1:k )' */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *k;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] -= work[j + i__ * work_dim1];
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... */
+/* V( 1:k, 1:l )' * W( 1:n, 1:k )' */
+
+ if (*l > 0) {
+ sgemm_("Transpose", "Transpose", l, n, k, &c_b23, &v[v_offset],
+ ldv, &work[work_offset], ldwork, &c_b13, &c__[*m - *l + 1
+ + c_dim1], ldc);
+ }
+
+ } else if (lsame_(side, "R")) {
+
+/* Form C * H or C * H' */
+
+/* W( 1:m, 1:k ) = C( 1:m, 1:k ) */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &
+ c__1);
+/* L40: */
+ }
+
+/* W( 1:m, 1:k ) = W( 1:m, 1:k ) + ... */
+/* C( 1:m, n-l+1:n ) * V( 1:k, 1:l )' */
+
+ if (*l > 0) {
+ sgemm_("No transpose", "Transpose", m, k, l, &c_b13, &c__[(*n - *
+ l + 1) * c_dim1 + 1], ldc, &v[v_offset], ldv, &c_b13, &
+ work[work_offset], ldwork);
+ }
+
+/* W( 1:m, 1:k ) = W( 1:m, 1:k ) * T or W( 1:m, 1:k ) * T' */
+
+ strmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b13, &t[t_offset]
+, ldt, &work[work_offset], ldwork);
+
+/* C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k ) */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... */
+/* W( 1:m, 1:k ) * V( 1:k, 1:l ) */
+
+ if (*l > 0) {
+ sgemm_("No transpose", "No transpose", m, l, k, &c_b23, &work[
+ work_offset], ldwork, &v[v_offset], ldv, &c_b13, &c__[(*n
+ - *l + 1) * c_dim1 + 1], ldc);
+ }
+
+ }
+
+ return 0;
+
+/* End of SLARZB */
+
+} /* slarzb_ */
diff --git a/SRC/slarzt.c b/SRC/slarzt.c
new file mode 100644
index 0000000..ed5c92a
--- /dev/null
+++ b/SRC/slarzt.c
@@ -0,0 +1,227 @@
+/* slarzt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b8 = 0.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int slarzt_(char *direct, char *storev, integer *n, integer *
+ k, real *v, integer *ldv, real *tau, real *t, integer *ldt)
+{
+ /* System generated locals */
+ integer t_dim1, t_offset, v_dim1, v_offset, i__1;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j, info;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *), strmv_(char *, char *, char *, integer *, real *,
+ integer *, real *, integer *), xerbla_(
+ char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARZT forms the triangular factor T of a real block reflector */
+/* H of order > n, which is defined as a product of k elementary */
+/* reflectors. */
+
+/* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */
+
+/* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */
+
+/* If STOREV = 'C', the vector which defines the elementary reflector */
+/* H(i) is stored in the i-th column of the array V, and */
+
+/* H = I - V * T * V' */
+
+/* If STOREV = 'R', the vector which defines the elementary reflector */
+/* H(i) is stored in the i-th row of the array V, and */
+
+/* H = I - V' * T * V */
+
+/* Currently, only STOREV = 'R' and DIRECT = 'B' are supported. */
+
+/* Arguments */
+/* ========= */
+
+/* DIRECT (input) CHARACTER*1 */
+/* Specifies the order in which the elementary reflectors are */
+/* multiplied to form the block reflector: */
+/* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet) */
+/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
+
+/* STOREV (input) CHARACTER*1 */
+/* Specifies how the vectors which define the elementary */
+/* reflectors are stored (see also Further Details): */
+/* = 'C': columnwise (not supported yet) */
+/* = 'R': rowwise */
+
+/* N (input) INTEGER */
+/* The order of the block reflector H. N >= 0. */
+
+/* K (input) INTEGER */
+/* The order of the triangular factor T (= the number of */
+/* elementary reflectors). K >= 1. */
+
+/* V (input/output) REAL array, dimension */
+/* (LDV,K) if STOREV = 'C' */
+/* (LDV,N) if STOREV = 'R' */
+/* The matrix V. See further details. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. */
+/* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */
+
+/* TAU (input) REAL array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i). */
+
+/* T (output) REAL array, dimension (LDT,K) */
+/* The k by k triangular factor T of the block reflector. */
+/* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */
+/* lower triangular. The rest of the array is not used. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= K. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* The shape of the matrix V and the storage of the vectors which define */
+/* the H(i) is best illustrated by the following example with n = 5 and */
+/* k = 3. The elements equal to 1 are not stored; the corresponding */
+/* array elements are modified but restored on exit. The rest of the */
+/* array is not used. */
+
+/* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */
+
+/* ______V_____ */
+/* ( v1 v2 v3 ) / \ */
+/* ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 ) */
+/* V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 ) */
+/* ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 ) */
+/* ( v1 v2 v3 ) */
+/* . . . */
+/* . . . */
+/* 1 . . */
+/* 1 . */
+/* 1 */
+
+/* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */
+
+/* ______V_____ */
+/* 1 / \ */
+/* . 1 ( 1 . . . . v1 v1 v1 v1 v1 ) */
+/* . . 1 ( . 1 . . . v2 v2 v2 v2 v2 ) */
+/* . . . ( . . 1 . . v3 v3 v3 v3 v3 ) */
+/* . . . */
+/* ( v1 v2 v3 ) */
+/* ( v1 v2 v3 ) */
+/* V = ( v1 v2 v3 ) */
+/* ( v1 v2 v3 ) */
+/* ( v1 v2 v3 ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for currently supported options */
+
+ /* Parameter adjustments */
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --tau;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(direct, "B")) {
+ info = -1;
+ } else if (! lsame_(storev, "R")) {
+ info = -2;
+ }
+ if (info != 0) {
+ i__1 = -info;
+ xerbla_("SLARZT", &i__1);
+ return 0;
+ }
+
+ for (i__ = *k; i__ >= 1; --i__) {
+ if (tau[i__] == 0.f) {
+
+/* H(i) = I */
+
+ i__1 = *k;
+ for (j = i__; j <= i__1; ++j) {
+ t[j + i__ * t_dim1] = 0.f;
+/* L10: */
+ }
+ } else {
+
+/* general case */
+
+ if (i__ < *k) {
+
+/* T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)' */
+
+ i__1 = *k - i__;
+ r__1 = -tau[i__];
+ sgemv_("No transpose", &i__1, n, &r__1, &v[i__ + 1 + v_dim1],
+ ldv, &v[i__ + v_dim1], ldv, &c_b8, &t[i__ + 1 + i__ *
+ t_dim1], &c__1);
+
+/* T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i) */
+
+ i__1 = *k - i__;
+ strmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ + 1
+ + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * t_dim1]
+, &c__1);
+ }
+ t[i__ + i__ * t_dim1] = tau[i__];
+ }
+/* L20: */
+ }
+ return 0;
+
+/* End of SLARZT */
+
+} /* slarzt_ */
diff --git a/SRC/slas2.c b/SRC/slas2.c
new file mode 100644
index 0000000..4269a70
--- /dev/null
+++ b/SRC/slas2.c
@@ -0,0 +1,145 @@
+/* slas2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slas2_(real *f, real *g, real *h__, real *ssmin, real *
+ ssmax)
+{
+ /* System generated locals */
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real c__, fa, ga, ha, as, at, au, fhmn, fhmx;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAS2 computes the singular values of the 2-by-2 matrix */
+/* [ F G ] */
+/* [ 0 H ]. */
+/* On return, SSMIN is the smaller singular value and SSMAX is the */
+/* larger singular value. */
+
+/* Arguments */
+/* ========= */
+
+/* F (input) REAL */
+/* The (1,1) element of the 2-by-2 matrix. */
+
+/* G (input) REAL */
+/* The (1,2) element of the 2-by-2 matrix. */
+
+/* H (input) REAL */
+/* The (2,2) element of the 2-by-2 matrix. */
+
+/* SSMIN (output) REAL */
+/* The smaller singular value. */
+
+/* SSMAX (output) REAL */
+/* The larger singular value. */
+
+/* Further Details */
+/* =============== */
+
+/* Barring over/underflow, all output quantities are correct to within */
+/* a few units in the last place (ulps), even in the absence of a guard */
+/* digit in addition/subtraction. */
+
+/* In IEEE arithmetic, the code works correctly if one matrix element is */
+/* infinite. */
+
+/* Overflow will not occur unless the largest singular value itself */
+/* overflows, or is within a few ulps of overflow. (On machines with */
+/* partial overflow, like the Cray, overflow may occur if the largest */
+/* singular value is within a factor of 2 of overflow.) */
+
+/* Underflow is harmless if underflow is gradual. Otherwise, results */
+/* may correspond to a matrix modified by perturbations of size near */
+/* the underflow threshold. */
+
+/* ==================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ fa = dabs(*f);
+ ga = dabs(*g);
+ ha = dabs(*h__);
+ fhmn = dmin(fa,ha);
+ fhmx = dmax(fa,ha);
+ if (fhmn == 0.f) {
+ *ssmin = 0.f;
+ if (fhmx == 0.f) {
+ *ssmax = ga;
+ } else {
+/* Computing 2nd power */
+ r__1 = dmin(fhmx,ga) / dmax(fhmx,ga);
+ *ssmax = dmax(fhmx,ga) * sqrt(r__1 * r__1 + 1.f);
+ }
+ } else {
+ if (ga < fhmx) {
+ as = fhmn / fhmx + 1.f;
+ at = (fhmx - fhmn) / fhmx;
+/* Computing 2nd power */
+ r__1 = ga / fhmx;
+ au = r__1 * r__1;
+ c__ = 2.f / (sqrt(as * as + au) + sqrt(at * at + au));
+ *ssmin = fhmn * c__;
+ *ssmax = fhmx / c__;
+ } else {
+ au = fhmx / ga;
+ if (au == 0.f) {
+
+/* Avoid possible harmful underflow if exponent range */
+/* asymmetric (true SSMIN may not underflow even if */
+/* AU underflows) */
+
+ *ssmin = fhmn * fhmx / ga;
+ *ssmax = ga;
+ } else {
+ as = fhmn / fhmx + 1.f;
+ at = (fhmx - fhmn) / fhmx;
+/* Computing 2nd power */
+ r__1 = as * au;
+/* Computing 2nd power */
+ r__2 = at * au;
+ c__ = 1.f / (sqrt(r__1 * r__1 + 1.f) + sqrt(r__2 * r__2 + 1.f)
+ );
+ *ssmin = fhmn * c__ * au;
+ *ssmin += *ssmin;
+ *ssmax = ga / (c__ + c__);
+ }
+ }
+ }
+ return 0;
+
+/* End of SLAS2 */
+
+} /* slas2_ */
diff --git a/SRC/slascl.c b/SRC/slascl.c
new file mode 100644
index 0000000..6afa7ef
--- /dev/null
+++ b/SRC/slascl.c
@@ -0,0 +1,355 @@
+/* slascl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slascl_(char *type__, integer *kl, integer *ku, real *
+ cfrom, real *cto, integer *m, integer *n, real *a, integer *lda,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+
+ /* Local variables */
+ integer i__, j, k1, k2, k3, k4;
+ real mul, cto1;
+ logical done;
+ real ctoc;
+ extern logical lsame_(char *, char *);
+ integer itype;
+ real cfrom1;
+ extern doublereal slamch_(char *);
+ real cfromc;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ extern logical sisnan_(real *);
+ real smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASCL multiplies the M by N real matrix A by the real scalar */
+/* CTO/CFROM. This is done without over/underflow as long as the final */
+/* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that */
+/* A may be full, upper triangular, lower triangular, upper Hessenberg, */
+/* or banded. */
+
+/* Arguments */
+/* ========= */
+
+/* TYPE (input) CHARACTER*1 */
+/* TYPE indices the storage type of the input matrix. */
+/* = 'G': A is a full matrix. */
+/* = 'L': A is a lower triangular matrix. */
+/* = 'U': A is an upper triangular matrix. */
+/* = 'H': A is an upper Hessenberg matrix. */
+/* = 'B': A is a symmetric band matrix with lower bandwidth KL */
+/* and upper bandwidth KU and with the only the lower */
+/* half stored. */
+/* = 'Q': A is a symmetric band matrix with lower bandwidth KL */
+/* and upper bandwidth KU and with the only the upper */
+/* half stored. */
+/* = 'Z': A is a band matrix with lower bandwidth KL and upper */
+/* bandwidth KU. */
+
+/* KL (input) INTEGER */
+/* The lower bandwidth of A. Referenced only if TYPE = 'B', */
+/* 'Q' or 'Z'. */
+
+/* KU (input) INTEGER */
+/* The upper bandwidth of A. Referenced only if TYPE = 'B', */
+/* 'Q' or 'Z'. */
+
+/* CFROM (input) REAL */
+/* CTO (input) REAL */
+/* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed */
+/* without over/underflow if the final result CTO*A(I,J)/CFROM */
+/* can be represented without over/underflow. CFROM must be */
+/* nonzero. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* The matrix to be multiplied by CTO/CFROM. See TYPE for the */
+/* storage type. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* INFO (output) INTEGER */
+/* 0 - successful exit */
+/* <0 - if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+
+ if (lsame_(type__, "G")) {
+ itype = 0;
+ } else if (lsame_(type__, "L")) {
+ itype = 1;
+ } else if (lsame_(type__, "U")) {
+ itype = 2;
+ } else if (lsame_(type__, "H")) {
+ itype = 3;
+ } else if (lsame_(type__, "B")) {
+ itype = 4;
+ } else if (lsame_(type__, "Q")) {
+ itype = 5;
+ } else if (lsame_(type__, "Z")) {
+ itype = 6;
+ } else {
+ itype = -1;
+ }
+
+ if (itype == -1) {
+ *info = -1;
+ } else if (*cfrom == 0.f || sisnan_(cfrom)) {
+ *info = -4;
+ } else if (sisnan_(cto)) {
+ *info = -5;
+ } else if (*m < 0) {
+ *info = -6;
+ } else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) {
+ *info = -7;
+ } else if (itype <= 3 && *lda < max(1,*m)) {
+ *info = -9;
+ } else if (itype >= 4) {
+/* Computing MAX */
+ i__1 = *m - 1;
+ if (*kl < 0 || *kl > max(i__1,0)) {
+ *info = -2;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = *n - 1;
+ if (*ku < 0 || *ku > max(i__1,0) || (itype == 4 || itype == 5) &&
+ *kl != *ku) {
+ *info = -3;
+ } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < *
+ ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) {
+ *info = -9;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLASCL", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *m == 0) {
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+
+ cfromc = *cfrom;
+ ctoc = *cto;
+
+L10:
+ cfrom1 = cfromc * smlnum;
+ if (cfrom1 == cfromc) {
+/* CFROMC is an inf. Multiply by a correctly signed zero for */
+/* finite CTOC, or a NaN if CTOC is infinite. */
+ mul = ctoc / cfromc;
+ done = TRUE_;
+ cto1 = ctoc;
+ } else {
+ cto1 = ctoc / bignum;
+ if (cto1 == ctoc) {
+/* CTOC is either 0 or an inf. In both cases, CTOC itself */
+/* serves as the correct multiplication factor. */
+ mul = ctoc;
+ done = TRUE_;
+ cfromc = 1.f;
+ } else if (dabs(cfrom1) > dabs(ctoc) && ctoc != 0.f) {
+ mul = smlnum;
+ done = FALSE_;
+ cfromc = cfrom1;
+ } else if (dabs(cto1) > dabs(cfromc)) {
+ mul = bignum;
+ done = FALSE_;
+ ctoc = cto1;
+ } else {
+ mul = ctoc / cfromc;
+ done = TRUE_;
+ }
+ }
+
+ if (itype == 0) {
+
+/* Full matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] *= mul;
+/* L20: */
+ }
+/* L30: */
+ }
+
+ } else if (itype == 1) {
+
+/* Lower triangular matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] *= mul;
+/* L40: */
+ }
+/* L50: */
+ }
+
+ } else if (itype == 2) {
+
+/* Upper triangular matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(j,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] *= mul;
+/* L60: */
+ }
+/* L70: */
+ }
+
+ } else if (itype == 3) {
+
+/* Upper Hessenberg matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j + 1;
+ i__2 = min(i__3,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] *= mul;
+/* L80: */
+ }
+/* L90: */
+ }
+
+ } else if (itype == 4) {
+
+/* Lower half of a symmetric band matrix */
+
+ k3 = *kl + 1;
+ k4 = *n + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = k3, i__4 = k4 - j;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] *= mul;
+/* L100: */
+ }
+/* L110: */
+ }
+
+ } else if (itype == 5) {
+
+/* Upper half of a symmetric band matrix */
+
+ k1 = *ku + 2;
+ k3 = *ku + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = k1 - j;
+ i__3 = k3;
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+ a[i__ + j * a_dim1] *= mul;
+/* L120: */
+ }
+/* L130: */
+ }
+
+ } else if (itype == 6) {
+
+/* Band matrix */
+
+ k1 = *kl + *ku + 2;
+ k2 = *kl + 1;
+ k3 = (*kl << 1) + *ku + 1;
+ k4 = *kl + *ku + 1 + *m;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__3 = k1 - j;
+/* Computing MIN */
+ i__4 = k3, i__5 = k4 - j;
+ i__2 = min(i__4,i__5);
+ for (i__ = max(i__3,k2); i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] *= mul;
+/* L140: */
+ }
+/* L150: */
+ }
+
+ }
+
+ if (! done) {
+ goto L10;
+ }
+
+ return 0;
+
+/* End of SLASCL */
+
+} /* slascl_ */
diff --git a/SRC/slascl2.c b/SRC/slascl2.c
new file mode 100644
index 0000000..035e165
--- /dev/null
+++ b/SRC/slascl2.c
@@ -0,0 +1,90 @@
+/* slascl2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slascl2_(integer *m, integer *n, real *d__, real *x,
+ integer *ldx)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASCL2 performs a diagonal scaling on a vector: */
+/* x <-- D * x */
+/* where the diagonal matrix D is stored as a vector. */
+
+/* Eventually to be replaced by BLAS_sge_diag_scale in the new BLAS */
+/* standard. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of D and X. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of D and X. N >= 0. */
+
+/* D (input) REAL array, length M */
+/* Diagonal matrix D, stored as a vector of length M. */
+
+/* X (input/output) REAL array, dimension (LDX,N) */
+/* On entry, the vector X to be scaled by D. */
+/* On exit, the scaled vector. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the vector X. LDX >= 0. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --d__;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+
+ /* Function Body */
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__ + j * x_dim1] *= d__[i__];
+ }
+ }
+ return 0;
+} /* slascl2_ */
diff --git a/SRC/slasd0.c b/SRC/slasd0.c
new file mode 100644
index 0000000..41f3ee7
--- /dev/null
+++ b/SRC/slasd0.c
@@ -0,0 +1,286 @@
+/* slasd0.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c__2 = 2;
+
+/* Subroutine */ int slasd0_(integer *n, integer *sqre, real *d__, real *e,
+ real *u, integer *ldu, real *vt, integer *ldvt, integer *smlsiz,
+ integer *iwork, real *work, integer *info)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2;
+
+ /* Builtin functions */
+ integer pow_ii(integer *, integer *);
+
+ /* Local variables */
+ integer i__, j, m, i1, ic, lf, nd, ll, nl, nr, im1, ncc, nlf, nrf, iwk,
+ lvl, ndb1, nlp1, nrp1;
+ real beta;
+ integer idxq, nlvl;
+ real alpha;
+ integer inode, ndiml, idxqc, ndimr, itemp, sqrei;
+ extern /* Subroutine */ int slasd1_(integer *, integer *, integer *, real
+ *, real *, real *, real *, integer *, real *, integer *, integer *
+, integer *, real *, integer *), xerbla_(char *, integer *), slasdq_(char *, integer *, integer *, integer *, integer
+ *, integer *, real *, real *, real *, integer *, real *, integer *
+, real *, integer *, real *, integer *), slasdt_(integer *
+, integer *, integer *, integer *, integer *, integer *, integer *
+);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Using a divide and conquer approach, SLASD0 computes the singular */
+/* value decomposition (SVD) of a real upper bidiagonal N-by-M */
+/* matrix B with diagonal D and offdiagonal E, where M = N + SQRE. */
+/* The algorithm computes orthogonal matrices U and VT such that */
+/* B = U * S * VT. The singular values S are overwritten on D. */
+
+/* A related subroutine, SLASDA, computes only the singular values, */
+/* and optionally, the singular vectors in compact form. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* On entry, the row dimension of the upper bidiagonal matrix. */
+/* This is also the dimension of the main diagonal array D. */
+
+/* SQRE (input) INTEGER */
+/* Specifies the column dimension of the bidiagonal matrix. */
+/* = 0: The bidiagonal matrix has column dimension M = N; */
+/* = 1: The bidiagonal matrix has column dimension M = N+1; */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry D contains the main diagonal of the bidiagonal */
+/* matrix. */
+/* On exit D, if INFO = 0, contains its singular values. */
+
+/* E (input) REAL array, dimension (M-1) */
+/* Contains the subdiagonal entries of the bidiagonal matrix. */
+/* On exit, E has been destroyed. */
+
+/* U (output) REAL array, dimension at least (LDQ, N) */
+/* On exit, U contains the left singular vectors. */
+
+/* LDU (input) INTEGER */
+/* On entry, leading dimension of U. */
+
+/* VT (output) REAL array, dimension at least (LDVT, M) */
+/* On exit, VT' contains the right singular vectors. */
+
+/* LDVT (input) INTEGER */
+/* On entry, leading dimension of VT. */
+
+/* SMLSIZ (input) INTEGER */
+/* On entry, maximum size of the subproblems at the */
+/* bottom of the computation tree. */
+
+/* IWORK (workspace) INTEGER array, dimension (8*N) */
+
+/* WORK (workspace) REAL array, dimension (3*M**2+2*M) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, an singular value did not converge */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --iwork;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*n < 0) {
+ *info = -1;
+ } else if (*sqre < 0 || *sqre > 1) {
+ *info = -2;
+ }
+
+ m = *n + *sqre;
+
+ if (*ldu < *n) {
+ *info = -6;
+ } else if (*ldvt < m) {
+ *info = -8;
+ } else if (*smlsiz < 3) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLASD0", &i__1);
+ return 0;
+ }
+
+/* If the input matrix is too small, call SLASDQ to find the SVD. */
+
+ if (*n <= *smlsiz) {
+ slasdq_("U", sqre, n, &m, n, &c__0, &d__[1], &e[1], &vt[vt_offset],
+ ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[1], info);
+ return 0;
+ }
+
+/* Set up the computation tree. */
+
+ inode = 1;
+ ndiml = inode + *n;
+ ndimr = ndiml + *n;
+ idxq = ndimr + *n;
+ iwk = idxq + *n;
+ slasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr],
+ smlsiz);
+
+/* For the nodes on bottom level of the tree, solve */
+/* their subproblems by SLASDQ. */
+
+ ndb1 = (nd + 1) / 2;
+ ncc = 0;
+ i__1 = nd;
+ for (i__ = ndb1; i__ <= i__1; ++i__) {
+
+/* IC : center row of each node */
+/* NL : number of rows of left subproblem */
+/* NR : number of rows of right subproblem */
+/* NLF: starting row of the left subproblem */
+/* NRF: starting row of the right subproblem */
+
+ i1 = i__ - 1;
+ ic = iwork[inode + i1];
+ nl = iwork[ndiml + i1];
+ nlp1 = nl + 1;
+ nr = iwork[ndimr + i1];
+ nrp1 = nr + 1;
+ nlf = ic - nl;
+ nrf = ic + 1;
+ sqrei = 1;
+ slasdq_("U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], &vt[
+ nlf + nlf * vt_dim1], ldvt, &u[nlf + nlf * u_dim1], ldu, &u[
+ nlf + nlf * u_dim1], ldu, &work[1], info);
+ if (*info != 0) {
+ return 0;
+ }
+ itemp = idxq + nlf - 2;
+ i__2 = nl;
+ for (j = 1; j <= i__2; ++j) {
+ iwork[itemp + j] = j;
+/* L10: */
+ }
+ if (i__ == nd) {
+ sqrei = *sqre;
+ } else {
+ sqrei = 1;
+ }
+ nrp1 = nr + sqrei;
+ slasdq_("U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], &vt[
+ nrf + nrf * vt_dim1], ldvt, &u[nrf + nrf * u_dim1], ldu, &u[
+ nrf + nrf * u_dim1], ldu, &work[1], info);
+ if (*info != 0) {
+ return 0;
+ }
+ itemp = idxq + ic;
+ i__2 = nr;
+ for (j = 1; j <= i__2; ++j) {
+ iwork[itemp + j - 1] = j;
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* Now conquer each subproblem bottom-up. */
+
+ for (lvl = nlvl; lvl >= 1; --lvl) {
+
+/* Find the first node LF and last node LL on the */
+/* current level LVL. */
+
+ if (lvl == 1) {
+ lf = 1;
+ ll = 1;
+ } else {
+ i__1 = lvl - 1;
+ lf = pow_ii(&c__2, &i__1);
+ ll = (lf << 1) - 1;
+ }
+ i__1 = ll;
+ for (i__ = lf; i__ <= i__1; ++i__) {
+ im1 = i__ - 1;
+ ic = iwork[inode + im1];
+ nl = iwork[ndiml + im1];
+ nr = iwork[ndimr + im1];
+ nlf = ic - nl;
+ if (*sqre == 0 && i__ == ll) {
+ sqrei = *sqre;
+ } else {
+ sqrei = 1;
+ }
+ idxqc = idxq + nlf - 1;
+ alpha = d__[ic];
+ beta = e[ic];
+ slasd1_(&nl, &nr, &sqrei, &d__[nlf], &alpha, &beta, &u[nlf + nlf *
+ u_dim1], ldu, &vt[nlf + nlf * vt_dim1], ldvt, &iwork[
+ idxqc], &iwork[iwk], &work[1], info);
+ if (*info != 0) {
+ return 0;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+
+ return 0;
+
+/* End of SLASD0 */
+
+} /* slasd0_ */
diff --git a/SRC/slasd1.c b/SRC/slasd1.c
new file mode 100644
index 0000000..5341356
--- /dev/null
+++ b/SRC/slasd1.c
@@ -0,0 +1,286 @@
+/* slasd1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static real c_b7 = 1.f;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int slasd1_(integer *nl, integer *nr, integer *sqre, real *
+ d__, real *alpha, real *beta, real *u, integer *ldu, real *vt,
+ integer *ldvt, integer *idxq, integer *iwork, real *work, integer *
+ info)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, vt_dim1, vt_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer i__, k, m, n, n1, n2, iq, iz, iu2, ldq, idx, ldu2, ivt2, idxc,
+ idxp, ldvt2;
+ extern /* Subroutine */ int slasd2_(integer *, integer *, integer *,
+ integer *, real *, real *, real *, real *, real *, integer *,
+ real *, integer *, real *, real *, integer *, real *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *),
+ slasd3_(integer *, integer *, integer *, integer *, real *, real
+ *, integer *, real *, real *, integer *, real *, integer *, real *
+, integer *, real *, integer *, integer *, integer *, real *,
+ integer *);
+ integer isigma;
+ extern /* Subroutine */ int xerbla_(char *, integer *), slascl_(
+ char *, integer *, integer *, real *, real *, integer *, integer *
+, real *, integer *, integer *), slamrg_(integer *,
+ integer *, real *, integer *, integer *, integer *);
+ real orgnrm;
+ integer coltyp;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B, */
+/* where N = NL + NR + 1 and M = N + SQRE. SLASD1 is called from SLASD0. */
+
+/* A related subroutine SLASD7 handles the case in which the singular */
+/* values (and the singular vectors in factored form) are desired. */
+
+/* SLASD1 computes the SVD as follows: */
+
+/* ( D1(in) 0 0 0 ) */
+/* B = U(in) * ( Z1' a Z2' b ) * VT(in) */
+/* ( 0 0 D2(in) 0 ) */
+
+/* = U(out) * ( D(out) 0) * VT(out) */
+
+/* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M */
+/* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros */
+/* elsewhere; and the entry b is empty if SQRE = 0. */
+
+/* The left singular vectors of the original matrix are stored in U, and */
+/* the transpose of the right singular vectors are stored in VT, and the */
+/* singular values are in D. The algorithm consists of three stages: */
+
+/* The first stage consists of deflating the size of the problem */
+/* when there are multiple singular values or when there are zeros in */
+/* the Z vector. For each such occurence the dimension of the */
+/* secular equation problem is reduced by one. This stage is */
+/* performed by the routine SLASD2. */
+
+/* The second stage consists of calculating the updated */
+/* singular values. This is done by finding the square roots of the */
+/* roots of the secular equation via the routine SLASD4 (as called */
+/* by SLASD3). This routine also calculates the singular vectors of */
+/* the current problem. */
+
+/* The final stage consists of computing the updated singular vectors */
+/* directly using the updated singular values. The singular vectors */
+/* for the current problem are multiplied with the singular vectors */
+/* from the overall problem. */
+
+/* Arguments */
+/* ========= */
+
+/* NL (input) INTEGER */
+/* The row dimension of the upper block. NL >= 1. */
+
+/* NR (input) INTEGER */
+/* The row dimension of the lower block. NR >= 1. */
+
+/* SQRE (input) INTEGER */
+/* = 0: the lower block is an NR-by-NR square matrix. */
+/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */
+
+/* The bidiagonal matrix has row dimension N = NL + NR + 1, */
+/* and column dimension M = N + SQRE. */
+
+/* D (input/output) REAL array, dimension (NL+NR+1). */
+/* N = NL+NR+1 */
+/* On entry D(1:NL,1:NL) contains the singular values of the */
+/* upper block; and D(NL+2:N) contains the singular values of */
+/* the lower block. On exit D(1:N) contains the singular values */
+/* of the modified matrix. */
+
+/* ALPHA (input/output) REAL */
+/* Contains the diagonal element associated with the added row. */
+
+/* BETA (input/output) REAL */
+/* Contains the off-diagonal element associated with the added */
+/* row. */
+
+/* U (input/output) REAL array, dimension (LDU,N) */
+/* On entry U(1:NL, 1:NL) contains the left singular vectors of */
+/* the upper block; U(NL+2:N, NL+2:N) contains the left singular */
+/* vectors of the lower block. On exit U contains the left */
+/* singular vectors of the bidiagonal matrix. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max( 1, N ). */
+
+/* VT (input/output) REAL array, dimension (LDVT,M) */
+/* where M = N + SQRE. */
+/* On entry VT(1:NL+1, 1:NL+1)' contains the right singular */
+/* vectors of the upper block; VT(NL+2:M, NL+2:M)' contains */
+/* the right singular vectors of the lower block. On exit */
+/* VT' contains the right singular vectors of the */
+/* bidiagonal matrix. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. LDVT >= max( 1, M ). */
+
+/* IDXQ (output) INTEGER array, dimension (N) */
+/* This contains the permutation which will reintegrate the */
+/* subproblem just solved back into sorted order, i.e. */
+/* D( IDXQ( I = 1, N ) ) will be in ascending order. */
+
+/* IWORK (workspace) INTEGER array, dimension (4*N) */
+
+/* WORK (workspace) REAL array, dimension (3*M**2+2*M) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, an singular value did not converge */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --idxq;
+ --iwork;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*nl < 1) {
+ *info = -1;
+ } else if (*nr < 1) {
+ *info = -2;
+ } else if (*sqre < 0 || *sqre > 1) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLASD1", &i__1);
+ return 0;
+ }
+
+ n = *nl + *nr + 1;
+ m = n + *sqre;
+
+/* The following values are for bookkeeping purposes only. They are */
+/* integer pointers which indicate the portion of the workspace */
+/* used by a particular array in SLASD2 and SLASD3. */
+
+ ldu2 = n;
+ ldvt2 = m;
+
+ iz = 1;
+ isigma = iz + m;
+ iu2 = isigma + n;
+ ivt2 = iu2 + ldu2 * n;
+ iq = ivt2 + ldvt2 * m;
+
+ idx = 1;
+ idxc = idx + n;
+ coltyp = idxc + n;
+ idxp = coltyp + n;
+
+/* Scale. */
+
+/* Computing MAX */
+ r__1 = dabs(*alpha), r__2 = dabs(*beta);
+ orgnrm = dmax(r__1,r__2);
+ d__[*nl + 1] = 0.f;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((r__1 = d__[i__], dabs(r__1)) > orgnrm) {
+ orgnrm = (r__1 = d__[i__], dabs(r__1));
+ }
+/* L10: */
+ }
+ slascl_("G", &c__0, &c__0, &orgnrm, &c_b7, &n, &c__1, &d__[1], &n, info);
+ *alpha /= orgnrm;
+ *beta /= orgnrm;
+
+/* Deflate singular values. */
+
+ slasd2_(nl, nr, sqre, &k, &d__[1], &work[iz], alpha, beta, &u[u_offset],
+ ldu, &vt[vt_offset], ldvt, &work[isigma], &work[iu2], &ldu2, &
+ work[ivt2], &ldvt2, &iwork[idxp], &iwork[idx], &iwork[idxc], &
+ idxq[1], &iwork[coltyp], info);
+
+/* Solve Secular Equation and update singular vectors. */
+
+ ldq = k;
+ slasd3_(nl, nr, sqre, &k, &d__[1], &work[iq], &ldq, &work[isigma], &u[
+ u_offset], ldu, &work[iu2], &ldu2, &vt[vt_offset], ldvt, &work[
+ ivt2], &ldvt2, &iwork[idxc], &iwork[coltyp], &work[iz], info);
+ if (*info != 0) {
+ return 0;
+ }
+
+/* Unscale. */
+
+ slascl_("G", &c__0, &c__0, &c_b7, &orgnrm, &n, &c__1, &d__[1], &n, info);
+
+/* Prepare the IDXQ sorting permutation. */
+
+ n1 = k;
+ n2 = n - k;
+ slamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &idxq[1]);
+
+ return 0;
+
+/* End of SLASD1 */
+
+} /* slasd1_ */
diff --git a/SRC/slasd2.c b/SRC/slasd2.c
new file mode 100644
index 0000000..15e3e47
--- /dev/null
+++ b/SRC/slasd2.c
@@ -0,0 +1,607 @@
+/* slasd2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b30 = 0.f;
+
+/* Subroutine */ int slasd2_(integer *nl, integer *nr, integer *sqre, integer
+ *k, real *d__, real *z__, real *alpha, real *beta, real *u, integer *
+ ldu, real *vt, integer *ldvt, real *dsigma, real *u2, integer *ldu2,
+ real *vt2, integer *ldvt2, integer *idxp, integer *idx, integer *idxc,
+ integer *idxq, integer *coltyp, integer *info)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, u2_dim1, u2_offset, vt_dim1, vt_offset,
+ vt2_dim1, vt2_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ real c__;
+ integer i__, j, m, n;
+ real s;
+ integer k2;
+ real z1;
+ integer ct, jp;
+ real eps, tau, tol;
+ integer psm[4], nlp1, nlp2, idxi, idxj, ctot[4];
+ extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
+ integer *, real *, real *);
+ integer idxjp, jprev;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ extern doublereal slapy2_(real *, real *), slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), slamrg_(
+ integer *, integer *, real *, integer *, integer *, integer *);
+ real hlftol;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASD2 merges the two sets of singular values together into a single */
+/* sorted set. Then it tries to deflate the size of the problem. */
+/* There are two ways in which deflation can occur: when two or more */
+/* singular values are close together or if there is a tiny entry in the */
+/* Z vector. For each such occurrence the order of the related secular */
+/* equation problem is reduced by one. */
+
+/* SLASD2 is called from SLASD1. */
+
+/* Arguments */
+/* ========= */
+
+/* NL (input) INTEGER */
+/* The row dimension of the upper block. NL >= 1. */
+
+/* NR (input) INTEGER */
+/* The row dimension of the lower block. NR >= 1. */
+
+/* SQRE (input) INTEGER */
+/* = 0: the lower block is an NR-by-NR square matrix. */
+/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */
+
+/* The bidiagonal matrix has N = NL + NR + 1 rows and */
+/* M = N + SQRE >= N columns. */
+
+/* K (output) INTEGER */
+/* Contains the dimension of the non-deflated matrix, */
+/* This is the order of the related secular equation. 1 <= K <=N. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry D contains the singular values of the two submatrices */
+/* to be combined. On exit D contains the trailing (N-K) updated */
+/* singular values (those which were deflated) sorted into */
+/* increasing order. */
+
+/* Z (output) REAL array, dimension (N) */
+/* On exit Z contains the updating row vector in the secular */
+/* equation. */
+
+/* ALPHA (input) REAL */
+/* Contains the diagonal element associated with the added row. */
+
+/* BETA (input) REAL */
+/* Contains the off-diagonal element associated with the added */
+/* row. */
+
+/* U (input/output) REAL array, dimension (LDU,N) */
+/* On entry U contains the left singular vectors of two */
+/* submatrices in the two square blocks with corners at (1,1), */
+/* (NL, NL), and (NL+2, NL+2), (N,N). */
+/* On exit U contains the trailing (N-K) updated left singular */
+/* vectors (those which were deflated) in its last N-K columns. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= N. */
+
+/* VT (input/output) REAL array, dimension (LDVT,M) */
+/* On entry VT' contains the right singular vectors of two */
+/* submatrices in the two square blocks with corners at (1,1), */
+/* (NL+1, NL+1), and (NL+2, NL+2), (M,M). */
+/* On exit VT' contains the trailing (N-K) updated right singular */
+/* vectors (those which were deflated) in its last N-K columns. */
+/* In case SQRE =1, the last row of VT spans the right null */
+/* space. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. LDVT >= M. */
+
+/* DSIGMA (output) REAL array, dimension (N) */
+/* Contains a copy of the diagonal elements (K-1 singular values */
+/* and one zero) in the secular equation. */
+
+/* U2 (output) REAL array, dimension (LDU2,N) */
+/* Contains a copy of the first K-1 left singular vectors which */
+/* will be used by SLASD3 in a matrix multiply (SGEMM) to solve */
+/* for the new left singular vectors. U2 is arranged into four */
+/* blocks. The first block contains a column with 1 at NL+1 and */
+/* zero everywhere else; the second block contains non-zero */
+/* entries only at and above NL; the third contains non-zero */
+/* entries only below NL+1; and the fourth is dense. */
+
+/* LDU2 (input) INTEGER */
+/* The leading dimension of the array U2. LDU2 >= N. */
+
+/* VT2 (output) REAL array, dimension (LDVT2,N) */
+/* VT2' contains a copy of the first K right singular vectors */
+/* which will be used by SLASD3 in a matrix multiply (SGEMM) to */
+/* solve for the new right singular vectors. VT2 is arranged into */
+/* three blocks. The first block contains a row that corresponds */
+/* to the special 0 diagonal element in SIGMA; the second block */
+/* contains non-zeros only at and before NL +1; the third block */
+/* contains non-zeros only at and after NL +2. */
+
+/* LDVT2 (input) INTEGER */
+/* The leading dimension of the array VT2. LDVT2 >= M. */
+
+/* IDXP (workspace) INTEGER array, dimension (N) */
+/* This will contain the permutation used to place deflated */
+/* values of D at the end of the array. On output IDXP(2:K) */
+/* points to the nondeflated D-values and IDXP(K+1:N) */
+/* points to the deflated singular values. */
+
+/* IDX (workspace) INTEGER array, dimension (N) */
+/* This will contain the permutation used to sort the contents of */
+/* D into ascending order. */
+
+/* IDXC (output) INTEGER array, dimension (N) */
+/* This will contain the permutation used to arrange the columns */
+/* of the deflated U matrix into three groups: the first group */
+/* contains non-zero entries only at and above NL, the second */
+/* contains non-zero entries only below NL+2, and the third is */
+/* dense. */
+
+/* IDXQ (input/output) INTEGER array, dimension (N) */
+/* This contains the permutation which separately sorts the two */
+/* sub-problems in D into ascending order. Note that entries in */
+/* the first hlaf of this permutation must first be moved one */
+/* position backward; and entries in the second half */
+/* must first have NL+1 added to their values. */
+
+/* COLTYP (workspace/output) INTEGER array, dimension (N) */
+/* As workspace, this will contain a label which will indicate */
+/* which of the following types a column in the U2 matrix or a */
+/* row in the VT2 matrix is: */
+/* 1 : non-zero in the upper half only */
+/* 2 : non-zero in the lower half only */
+/* 3 : dense */
+/* 4 : deflated */
+
+/* On exit, it is an array of dimension 4, with COLTYP(I) being */
+/* the dimension of the I-th type columns. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --z__;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --dsigma;
+ u2_dim1 = *ldu2;
+ u2_offset = 1 + u2_dim1;
+ u2 -= u2_offset;
+ vt2_dim1 = *ldvt2;
+ vt2_offset = 1 + vt2_dim1;
+ vt2 -= vt2_offset;
+ --idxp;
+ --idx;
+ --idxc;
+ --idxq;
+ --coltyp;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*nl < 1) {
+ *info = -1;
+ } else if (*nr < 1) {
+ *info = -2;
+ } else if (*sqre != 1 && *sqre != 0) {
+ *info = -3;
+ }
+
+ n = *nl + *nr + 1;
+ m = n + *sqre;
+
+ if (*ldu < n) {
+ *info = -10;
+ } else if (*ldvt < m) {
+ *info = -12;
+ } else if (*ldu2 < n) {
+ *info = -15;
+ } else if (*ldvt2 < m) {
+ *info = -17;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLASD2", &i__1);
+ return 0;
+ }
+
+ nlp1 = *nl + 1;
+ nlp2 = *nl + 2;
+
+/* Generate the first part of the vector Z; and move the singular */
+/* values in the first part of D one position backward. */
+
+ z1 = *alpha * vt[nlp1 + nlp1 * vt_dim1];
+ z__[1] = z1;
+ for (i__ = *nl; i__ >= 1; --i__) {
+ z__[i__ + 1] = *alpha * vt[i__ + nlp1 * vt_dim1];
+ d__[i__ + 1] = d__[i__];
+ idxq[i__ + 1] = idxq[i__] + 1;
+/* L10: */
+ }
+
+/* Generate the second part of the vector Z. */
+
+ i__1 = m;
+ for (i__ = nlp2; i__ <= i__1; ++i__) {
+ z__[i__] = *beta * vt[i__ + nlp2 * vt_dim1];
+/* L20: */
+ }
+
+/* Initialize some reference arrays. */
+
+ i__1 = nlp1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ coltyp[i__] = 1;
+/* L30: */
+ }
+ i__1 = n;
+ for (i__ = nlp2; i__ <= i__1; ++i__) {
+ coltyp[i__] = 2;
+/* L40: */
+ }
+
+/* Sort the singular values into increasing order */
+
+ i__1 = n;
+ for (i__ = nlp2; i__ <= i__1; ++i__) {
+ idxq[i__] += nlp1;
+/* L50: */
+ }
+
+/* DSIGMA, IDXC, IDXC, and the first column of U2 */
+/* are used as storage space. */
+
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ dsigma[i__] = d__[idxq[i__]];
+ u2[i__ + u2_dim1] = z__[idxq[i__]];
+ idxc[i__] = coltyp[idxq[i__]];
+/* L60: */
+ }
+
+ slamrg_(nl, nr, &dsigma[2], &c__1, &c__1, &idx[2]);
+
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ idxi = idx[i__] + 1;
+ d__[i__] = dsigma[idxi];
+ z__[i__] = u2[idxi + u2_dim1];
+ coltyp[i__] = idxc[idxi];
+/* L70: */
+ }
+
+/* Calculate the allowable deflation tolerance */
+
+ eps = slamch_("Epsilon");
+/* Computing MAX */
+ r__1 = dabs(*alpha), r__2 = dabs(*beta);
+ tol = dmax(r__1,r__2);
+/* Computing MAX */
+ r__2 = (r__1 = d__[n], dabs(r__1));
+ tol = eps * 8.f * dmax(r__2,tol);
+
+/* There are 2 kinds of deflation -- first a value in the z-vector */
+/* is small, second two (or more) singular values are very close */
+/* together (their difference is small). */
+
+/* If the value in the z-vector is small, we simply permute the */
+/* array so that the corresponding singular value is moved to the */
+/* end. */
+
+/* If two values in the D-vector are close, we perform a two-sided */
+/* rotation designed to make one of the corresponding z-vector */
+/* entries zero, and then permute the array so that the deflated */
+/* singular value is moved to the end. */
+
+/* If there are multiple singular values then the problem deflates. */
+/* Here the number of equal singular values are found. As each equal */
+/* singular value is found, an elementary reflector is computed to */
+/* rotate the corresponding singular subspace so that the */
+/* corresponding components of Z are zero in this new basis. */
+
+ *k = 1;
+ k2 = n + 1;
+ i__1 = n;
+ for (j = 2; j <= i__1; ++j) {
+ if ((r__1 = z__[j], dabs(r__1)) <= tol) {
+
+/* Deflate due to small z component. */
+
+ --k2;
+ idxp[k2] = j;
+ coltyp[j] = 4;
+ if (j == n) {
+ goto L120;
+ }
+ } else {
+ jprev = j;
+ goto L90;
+ }
+/* L80: */
+ }
+L90:
+ j = jprev;
+L100:
+ ++j;
+ if (j > n) {
+ goto L110;
+ }
+ if ((r__1 = z__[j], dabs(r__1)) <= tol) {
+
+/* Deflate due to small z component. */
+
+ --k2;
+ idxp[k2] = j;
+ coltyp[j] = 4;
+ } else {
+
+/* Check if singular values are close enough to allow deflation. */
+
+ if ((r__1 = d__[j] - d__[jprev], dabs(r__1)) <= tol) {
+
+/* Deflation is possible. */
+
+ s = z__[jprev];
+ c__ = z__[j];
+
+/* Find sqrt(a**2+b**2) without overflow or */
+/* destructive underflow. */
+
+ tau = slapy2_(&c__, &s);
+ c__ /= tau;
+ s = -s / tau;
+ z__[j] = tau;
+ z__[jprev] = 0.f;
+
+/* Apply back the Givens rotation to the left and right */
+/* singular vector matrices. */
+
+ idxjp = idxq[idx[jprev] + 1];
+ idxj = idxq[idx[j] + 1];
+ if (idxjp <= nlp1) {
+ --idxjp;
+ }
+ if (idxj <= nlp1) {
+ --idxj;
+ }
+ srot_(&n, &u[idxjp * u_dim1 + 1], &c__1, &u[idxj * u_dim1 + 1], &
+ c__1, &c__, &s);
+ srot_(&m, &vt[idxjp + vt_dim1], ldvt, &vt[idxj + vt_dim1], ldvt, &
+ c__, &s);
+ if (coltyp[j] != coltyp[jprev]) {
+ coltyp[j] = 3;
+ }
+ coltyp[jprev] = 4;
+ --k2;
+ idxp[k2] = jprev;
+ jprev = j;
+ } else {
+ ++(*k);
+ u2[*k + u2_dim1] = z__[jprev];
+ dsigma[*k] = d__[jprev];
+ idxp[*k] = jprev;
+ jprev = j;
+ }
+ }
+ goto L100;
+L110:
+
+/* Record the last singular value. */
+
+ ++(*k);
+ u2[*k + u2_dim1] = z__[jprev];
+ dsigma[*k] = d__[jprev];
+ idxp[*k] = jprev;
+
+L120:
+
+/* Count up the total number of the various types of columns, then */
+/* form a permutation which positions the four column types into */
+/* four groups of uniform structure (although one or more of these */
+/* groups may be empty). */
+
+ for (j = 1; j <= 4; ++j) {
+ ctot[j - 1] = 0;
+/* L130: */
+ }
+ i__1 = n;
+ for (j = 2; j <= i__1; ++j) {
+ ct = coltyp[j];
+ ++ctot[ct - 1];
+/* L140: */
+ }
+
+/* PSM(*) = Position in SubMatrix (of types 1 through 4) */
+
+ psm[0] = 2;
+ psm[1] = ctot[0] + 2;
+ psm[2] = psm[1] + ctot[1];
+ psm[3] = psm[2] + ctot[2];
+
+/* Fill out the IDXC array so that the permutation which it induces */
+/* will place all type-1 columns first, all type-2 columns next, */
+/* then all type-3's, and finally all type-4's, starting from the */
+/* second column. This applies similarly to the rows of VT. */
+
+ i__1 = n;
+ for (j = 2; j <= i__1; ++j) {
+ jp = idxp[j];
+ ct = coltyp[jp];
+ idxc[psm[ct - 1]] = j;
+ ++psm[ct - 1];
+/* L150: */
+ }
+
+/* Sort the singular values and corresponding singular vectors into */
+/* DSIGMA, U2, and VT2 respectively. The singular values/vectors */
+/* which were not deflated go into the first K slots of DSIGMA, U2, */
+/* and VT2 respectively, while those which were deflated go into the */
+/* last N - K slots, except that the first column/row will be treated */
+/* separately. */
+
+ i__1 = n;
+ for (j = 2; j <= i__1; ++j) {
+ jp = idxp[j];
+ dsigma[j] = d__[jp];
+ idxj = idxq[idx[idxp[idxc[j]]] + 1];
+ if (idxj <= nlp1) {
+ --idxj;
+ }
+ scopy_(&n, &u[idxj * u_dim1 + 1], &c__1, &u2[j * u2_dim1 + 1], &c__1);
+ scopy_(&m, &vt[idxj + vt_dim1], ldvt, &vt2[j + vt2_dim1], ldvt2);
+/* L160: */
+ }
+
+/* Determine DSIGMA(1), DSIGMA(2) and Z(1) */
+
+ dsigma[1] = 0.f;
+ hlftol = tol / 2.f;
+ if (dabs(dsigma[2]) <= hlftol) {
+ dsigma[2] = hlftol;
+ }
+ if (m > n) {
+ z__[1] = slapy2_(&z1, &z__[m]);
+ if (z__[1] <= tol) {
+ c__ = 1.f;
+ s = 0.f;
+ z__[1] = tol;
+ } else {
+ c__ = z1 / z__[1];
+ s = z__[m] / z__[1];
+ }
+ } else {
+ if (dabs(z1) <= tol) {
+ z__[1] = tol;
+ } else {
+ z__[1] = z1;
+ }
+ }
+
+/* Move the rest of the updating row to Z. */
+
+ i__1 = *k - 1;
+ scopy_(&i__1, &u2[u2_dim1 + 2], &c__1, &z__[2], &c__1);
+
+/* Determine the first column of U2, the first row of VT2 and the */
+/* last row of VT. */
+
+ slaset_("A", &n, &c__1, &c_b30, &c_b30, &u2[u2_offset], ldu2);
+ u2[nlp1 + u2_dim1] = 1.f;
+ if (m > n) {
+ i__1 = nlp1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ vt[m + i__ * vt_dim1] = -s * vt[nlp1 + i__ * vt_dim1];
+ vt2[i__ * vt2_dim1 + 1] = c__ * vt[nlp1 + i__ * vt_dim1];
+/* L170: */
+ }
+ i__1 = m;
+ for (i__ = nlp2; i__ <= i__1; ++i__) {
+ vt2[i__ * vt2_dim1 + 1] = s * vt[m + i__ * vt_dim1];
+ vt[m + i__ * vt_dim1] = c__ * vt[m + i__ * vt_dim1];
+/* L180: */
+ }
+ } else {
+ scopy_(&m, &vt[nlp1 + vt_dim1], ldvt, &vt2[vt2_dim1 + 1], ldvt2);
+ }
+ if (m > n) {
+ scopy_(&m, &vt[m + vt_dim1], ldvt, &vt2[m + vt2_dim1], ldvt2);
+ }
+
+/* The deflated singular values and their corresponding vectors go */
+/* into the back of D, U, and V respectively. */
+
+ if (n > *k) {
+ i__1 = n - *k;
+ scopy_(&i__1, &dsigma[*k + 1], &c__1, &d__[*k + 1], &c__1);
+ i__1 = n - *k;
+ slacpy_("A", &n, &i__1, &u2[(*k + 1) * u2_dim1 + 1], ldu2, &u[(*k + 1)
+ * u_dim1 + 1], ldu);
+ i__1 = n - *k;
+ slacpy_("A", &i__1, &m, &vt2[*k + 1 + vt2_dim1], ldvt2, &vt[*k + 1 +
+ vt_dim1], ldvt);
+ }
+
+/* Copy CTOT into COLTYP for referencing in SLASD3. */
+
+ for (j = 1; j <= 4; ++j) {
+ coltyp[j] = ctot[j - 1];
+/* L190: */
+ }
+
+ return 0;
+
+/* End of SLASD2 */
+
+} /* slasd2_ */
diff --git a/SRC/slasd3.c b/SRC/slasd3.c
new file mode 100644
index 0000000..d4b3ab0
--- /dev/null
+++ b/SRC/slasd3.c
@@ -0,0 +1,450 @@
+/* slasd3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static real c_b13 = 1.f;
+static real c_b26 = 0.f;
+
+/* Subroutine */ int slasd3_(integer *nl, integer *nr, integer *sqre, integer
+ *k, real *d__, real *q, integer *ldq, real *dsigma, real *u, integer *
+ ldu, real *u2, integer *ldu2, real *vt, integer *ldvt, real *vt2,
+ integer *ldvt2, integer *idxc, integer *ctot, real *z__, integer *
+ info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, u_dim1, u_offset, u2_dim1, u2_offset, vt_dim1,
+ vt_offset, vt2_dim1, vt2_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_sign(real *, real *);
+
+ /* Local variables */
+ integer i__, j, m, n, jc;
+ real rho;
+ integer nlp1, nlp2, nrp1;
+ real temp;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ integer ctemp;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ integer ktemp;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ extern doublereal slamc3_(real *, real *);
+ extern /* Subroutine */ int slasd4_(integer *, integer *, real *, real *,
+ real *, real *, real *, real *, integer *), xerbla_(char *,
+ integer *), slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *,
+ real *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASD3 finds all the square roots of the roots of the secular */
+/* equation, as defined by the values in D and Z. It makes the */
+/* appropriate calls to SLASD4 and then updates the singular */
+/* vectors by matrix multiplication. */
+
+/* This code makes very mild assumptions about floating point */
+/* arithmetic. It will work on machines with a guard digit in */
+/* add/subtract, or on those binary machines without guard digits */
+/* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. */
+/* It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* SLASD3 is called from SLASD1. */
+
+/* Arguments */
+/* ========= */
+
+/* NL (input) INTEGER */
+/* The row dimension of the upper block. NL >= 1. */
+
+/* NR (input) INTEGER */
+/* The row dimension of the lower block. NR >= 1. */
+
+/* SQRE (input) INTEGER */
+/* = 0: the lower block is an NR-by-NR square matrix. */
+/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */
+
+/* The bidiagonal matrix has N = NL + NR + 1 rows and */
+/* M = N + SQRE >= N columns. */
+
+/* K (input) INTEGER */
+/* The size of the secular equation, 1 =< K = < N. */
+
+/* D (output) REAL array, dimension(K) */
+/* On exit the square roots of the roots of the secular equation, */
+/* in ascending order. */
+
+/* Q (workspace) REAL array, */
+/* dimension at least (LDQ,K). */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= K. */
+
+/* DSIGMA (input/output) REAL array, dimension(K) */
+/* The first K elements of this array contain the old roots */
+/* of the deflated updating problem. These are the poles */
+/* of the secular equation. */
+
+/* U (output) REAL array, dimension (LDU, N) */
+/* The last N - K columns of this matrix contain the deflated */
+/* left singular vectors. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= N. */
+
+/* U2 (input) REAL array, dimension (LDU2, N) */
+/* The first K columns of this matrix contain the non-deflated */
+/* left singular vectors for the split problem. */
+
+/* LDU2 (input) INTEGER */
+/* The leading dimension of the array U2. LDU2 >= N. */
+
+/* VT (output) REAL array, dimension (LDVT, M) */
+/* The last M - K columns of VT' contain the deflated */
+/* right singular vectors. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. LDVT >= N. */
+
+/* VT2 (input/output) REAL array, dimension (LDVT2, N) */
+/* The first K columns of VT2' contain the non-deflated */
+/* right singular vectors for the split problem. */
+
+/* LDVT2 (input) INTEGER */
+/* The leading dimension of the array VT2. LDVT2 >= N. */
+
+/* IDXC (input) INTEGER array, dimension (N) */
+/* The permutation used to arrange the columns of U (and rows of */
+/* VT) into three groups: the first group contains non-zero */
+/* entries only at and above (or before) NL +1; the second */
+/* contains non-zero entries only at and below (or after) NL+2; */
+/* and the third is dense. The first column of U and the row of */
+/* VT are treated separately, however. */
+
+/* The rows of the singular vectors found by SLASD4 */
+/* must be likewise permuted before the matrix multiplies can */
+/* take place. */
+
+/* CTOT (input) INTEGER array, dimension (4) */
+/* A count of the total number of the various types of columns */
+/* in U (or rows in VT), as described in IDXC. The fourth column */
+/* type is any column which has been deflated. */
+
+/* Z (input/output) REAL array, dimension (K) */
+/* The first K elements of this array contain the components */
+/* of the deflation-adjusted updating row vector. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, an singular value did not converge */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --dsigma;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ u2_dim1 = *ldu2;
+ u2_offset = 1 + u2_dim1;
+ u2 -= u2_offset;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ vt2_dim1 = *ldvt2;
+ vt2_offset = 1 + vt2_dim1;
+ vt2 -= vt2_offset;
+ --idxc;
+ --ctot;
+ --z__;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*nl < 1) {
+ *info = -1;
+ } else if (*nr < 1) {
+ *info = -2;
+ } else if (*sqre != 1 && *sqre != 0) {
+ *info = -3;
+ }
+
+ n = *nl + *nr + 1;
+ m = n + *sqre;
+ nlp1 = *nl + 1;
+ nlp2 = *nl + 2;
+
+ if (*k < 1 || *k > n) {
+ *info = -4;
+ } else if (*ldq < *k) {
+ *info = -7;
+ } else if (*ldu < n) {
+ *info = -10;
+ } else if (*ldu2 < n) {
+ *info = -12;
+ } else if (*ldvt < m) {
+ *info = -14;
+ } else if (*ldvt2 < m) {
+ *info = -16;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLASD3", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*k == 1) {
+ d__[1] = dabs(z__[1]);
+ scopy_(&m, &vt2[vt2_dim1 + 1], ldvt2, &vt[vt_dim1 + 1], ldvt);
+ if (z__[1] > 0.f) {
+ scopy_(&n, &u2[u2_dim1 + 1], &c__1, &u[u_dim1 + 1], &c__1);
+ } else {
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ u[i__ + u_dim1] = -u2[i__ + u2_dim1];
+/* L10: */
+ }
+ }
+ return 0;
+ }
+
+/* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can */
+/* be computed with high relative accuracy (barring over/underflow). */
+/* This is a problem on machines without a guard digit in */
+/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */
+/* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), */
+/* which on any of these machines zeros out the bottommost */
+/* bit of DSIGMA(I) if it is 1; this makes the subsequent */
+/* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation */
+/* occurs. On binary machines with a guard digit (almost all */
+/* machines) it does not change DSIGMA(I) at all. On hexadecimal */
+/* and decimal machines with a guard digit, it slightly */
+/* changes the bottommost bits of DSIGMA(I). It does not account */
+/* for hexadecimal or decimal machines without guard digits */
+/* (we know of none). We use a subroutine call to compute */
+/* 2*DSIGMA(I) to prevent optimizing compilers from eliminating */
+/* this code. */
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dsigma[i__] = slamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__];
+/* L20: */
+ }
+
+/* Keep a copy of Z. */
+
+ scopy_(k, &z__[1], &c__1, &q[q_offset], &c__1);
+
+/* Normalize Z. */
+
+ rho = snrm2_(k, &z__[1], &c__1);
+ slascl_("G", &c__0, &c__0, &rho, &c_b13, k, &c__1, &z__[1], k, info);
+ rho *= rho;
+
+/* Find the new singular values. */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ slasd4_(k, &j, &dsigma[1], &z__[1], &u[j * u_dim1 + 1], &rho, &d__[j],
+ &vt[j * vt_dim1 + 1], info);
+
+/* If the zero finder fails, the computation is terminated. */
+
+ if (*info != 0) {
+ return 0;
+ }
+/* L30: */
+ }
+
+/* Compute updated Z. */
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ z__[i__] = u[i__ + *k * u_dim1] * vt[i__ + *k * vt_dim1];
+ i__2 = i__ - 1;
+ for (j = 1; j <= i__2; ++j) {
+ z__[i__] *= u[i__ + j * u_dim1] * vt[i__ + j * vt_dim1] / (dsigma[
+ i__] - dsigma[j]) / (dsigma[i__] + dsigma[j]);
+/* L40: */
+ }
+ i__2 = *k - 1;
+ for (j = i__; j <= i__2; ++j) {
+ z__[i__] *= u[i__ + j * u_dim1] * vt[i__ + j * vt_dim1] / (dsigma[
+ i__] - dsigma[j + 1]) / (dsigma[i__] + dsigma[j + 1]);
+/* L50: */
+ }
+ r__2 = sqrt((r__1 = z__[i__], dabs(r__1)));
+ z__[i__] = r_sign(&r__2, &q[i__ + q_dim1]);
+/* L60: */
+ }
+
+/* Compute left singular vectors of the modified diagonal matrix, */
+/* and store related information for the right singular vectors. */
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ vt[i__ * vt_dim1 + 1] = z__[1] / u[i__ * u_dim1 + 1] / vt[i__ *
+ vt_dim1 + 1];
+ u[i__ * u_dim1 + 1] = -1.f;
+ i__2 = *k;
+ for (j = 2; j <= i__2; ++j) {
+ vt[j + i__ * vt_dim1] = z__[j] / u[j + i__ * u_dim1] / vt[j + i__
+ * vt_dim1];
+ u[j + i__ * u_dim1] = dsigma[j] * vt[j + i__ * vt_dim1];
+/* L70: */
+ }
+ temp = snrm2_(k, &u[i__ * u_dim1 + 1], &c__1);
+ q[i__ * q_dim1 + 1] = u[i__ * u_dim1 + 1] / temp;
+ i__2 = *k;
+ for (j = 2; j <= i__2; ++j) {
+ jc = idxc[j];
+ q[j + i__ * q_dim1] = u[jc + i__ * u_dim1] / temp;
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Update the left singular vector matrix. */
+
+ if (*k == 2) {
+ sgemm_("N", "N", &n, k, k, &c_b13, &u2[u2_offset], ldu2, &q[q_offset],
+ ldq, &c_b26, &u[u_offset], ldu);
+ goto L100;
+ }
+ if (ctot[1] > 0) {
+ sgemm_("N", "N", nl, k, &ctot[1], &c_b13, &u2[(u2_dim1 << 1) + 1],
+ ldu2, &q[q_dim1 + 2], ldq, &c_b26, &u[u_dim1 + 1], ldu);
+ if (ctot[3] > 0) {
+ ktemp = ctot[1] + 2 + ctot[2];
+ sgemm_("N", "N", nl, k, &ctot[3], &c_b13, &u2[ktemp * u2_dim1 + 1]
+, ldu2, &q[ktemp + q_dim1], ldq, &c_b13, &u[u_dim1 + 1],
+ ldu);
+ }
+ } else if (ctot[3] > 0) {
+ ktemp = ctot[1] + 2 + ctot[2];
+ sgemm_("N", "N", nl, k, &ctot[3], &c_b13, &u2[ktemp * u2_dim1 + 1],
+ ldu2, &q[ktemp + q_dim1], ldq, &c_b26, &u[u_dim1 + 1], ldu);
+ } else {
+ slacpy_("F", nl, k, &u2[u2_offset], ldu2, &u[u_offset], ldu);
+ }
+ scopy_(k, &q[q_dim1 + 1], ldq, &u[nlp1 + u_dim1], ldu);
+ ktemp = ctot[1] + 2;
+ ctemp = ctot[2] + ctot[3];
+ sgemm_("N", "N", nr, k, &ctemp, &c_b13, &u2[nlp2 + ktemp * u2_dim1], ldu2,
+ &q[ktemp + q_dim1], ldq, &c_b26, &u[nlp2 + u_dim1], ldu);
+
+/* Generate the right singular vectors. */
+
+L100:
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = snrm2_(k, &vt[i__ * vt_dim1 + 1], &c__1);
+ q[i__ + q_dim1] = vt[i__ * vt_dim1 + 1] / temp;
+ i__2 = *k;
+ for (j = 2; j <= i__2; ++j) {
+ jc = idxc[j];
+ q[i__ + j * q_dim1] = vt[jc + i__ * vt_dim1] / temp;
+/* L110: */
+ }
+/* L120: */
+ }
+
+/* Update the right singular vector matrix. */
+
+ if (*k == 2) {
+ sgemm_("N", "N", k, &m, k, &c_b13, &q[q_offset], ldq, &vt2[vt2_offset]
+, ldvt2, &c_b26, &vt[vt_offset], ldvt);
+ return 0;
+ }
+ ktemp = ctot[1] + 1;
+ sgemm_("N", "N", k, &nlp1, &ktemp, &c_b13, &q[q_dim1 + 1], ldq, &vt2[
+ vt2_dim1 + 1], ldvt2, &c_b26, &vt[vt_dim1 + 1], ldvt);
+ ktemp = ctot[1] + 2 + ctot[2];
+ if (ktemp <= *ldvt2) {
+ sgemm_("N", "N", k, &nlp1, &ctot[3], &c_b13, &q[ktemp * q_dim1 + 1],
+ ldq, &vt2[ktemp + vt2_dim1], ldvt2, &c_b13, &vt[vt_dim1 + 1],
+ ldvt);
+ }
+
+ ktemp = ctot[1] + 1;
+ nrp1 = *nr + *sqre;
+ if (ktemp > 1) {
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ q[i__ + ktemp * q_dim1] = q[i__ + q_dim1];
+/* L130: */
+ }
+ i__1 = m;
+ for (i__ = nlp2; i__ <= i__1; ++i__) {
+ vt2[ktemp + i__ * vt2_dim1] = vt2[i__ * vt2_dim1 + 1];
+/* L140: */
+ }
+ }
+ ctemp = ctot[2] + 1 + ctot[3];
+ sgemm_("N", "N", k, &nrp1, &ctemp, &c_b13, &q[ktemp * q_dim1 + 1], ldq, &
+ vt2[ktemp + nlp2 * vt2_dim1], ldvt2, &c_b26, &vt[nlp2 * vt_dim1 +
+ 1], ldvt);
+
+ return 0;
+
+/* End of SLASD3 */
+
+} /* slasd3_ */
diff --git a/SRC/slasd4.c b/SRC/slasd4.c
new file mode 100644
index 0000000..11ba6d2
--- /dev/null
+++ b/SRC/slasd4.c
@@ -0,0 +1,1010 @@
+/* slasd4.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slasd4_(integer *n, integer *i__, real *d__, real *z__,
+ real *delta, real *rho, real *sigma, real *work, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real a, b, c__;
+ integer j;
+ real w, dd[3];
+ integer ii;
+ real dw, zz[3];
+ integer ip1;
+ real eta, phi, eps, tau, psi;
+ integer iim1, iip1;
+ real dphi, dpsi;
+ integer iter;
+ real temp, prew, sg2lb, sg2ub, temp1, temp2, dtiim, delsq, dtiip;
+ integer niter;
+ real dtisq;
+ logical swtch;
+ real dtnsq;
+ extern /* Subroutine */ int slaed6_(integer *, logical *, real *, real *,
+ real *, real *, real *, integer *);
+ real delsq2;
+ extern /* Subroutine */ int slasd5_(integer *, real *, real *, real *,
+ real *, real *, real *);
+ real dtnsq1;
+ logical swtch3;
+ extern doublereal slamch_(char *);
+ logical orgati;
+ real erretm, dtipsq, rhoinv;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This subroutine computes the square root of the I-th updated */
+/* eigenvalue of a positive symmetric rank-one modification to */
+/* a positive diagonal matrix whose entries are given as the squares */
+/* of the corresponding entries in the array d, and that */
+
+/* 0 <= D(i) < D(j) for i < j */
+
+/* and that RHO > 0. This is arranged by the calling routine, and is */
+/* no loss in generality. The rank-one modified system is thus */
+
+/* diag( D ) * diag( D ) + RHO * Z * Z_transpose. */
+
+/* where we assume the Euclidean norm of Z is 1. */
+
+/* The method consists of approximating the rational functions in the */
+/* secular equation by simpler interpolating rational functions. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The length of all arrays. */
+
+/* I (input) INTEGER */
+/* The index of the eigenvalue to be computed. 1 <= I <= N. */
+
+/* D (input) REAL array, dimension ( N ) */
+/* The original eigenvalues. It is assumed that they are in */
+/* order, 0 <= D(I) < D(J) for I < J. */
+
+/* Z (input) REAL array, dimension (N) */
+/* The components of the updating vector. */
+
+/* DELTA (output) REAL array, dimension (N) */
+/* If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th */
+/* component. If N = 1, then DELTA(1) = 1. The vector DELTA */
+/* contains the information necessary to construct the */
+/* (singular) eigenvectors. */
+
+/* RHO (input) REAL */
+/* The scalar in the symmetric updating formula. */
+
+/* SIGMA (output) REAL */
+/* The computed sigma_I, the I-th updated eigenvalue. */
+
+/* WORK (workspace) REAL array, dimension (N) */
+/* If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th */
+/* component. If N = 1, then WORK( 1 ) = 1. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* > 0: if INFO = 1, the updating process failed. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* Logical variable ORGATI (origin-at-i?) is used for distinguishing */
+/* whether D(i) or D(i+1) is treated as the origin. */
+
+/* ORGATI = .true. origin at i */
+/* ORGATI = .false. origin at i+1 */
+
+/* Logical variable SWTCH3 (switch-for-3-poles?) is for noting */
+/* if we are working with THREE poles! */
+
+/* MAXIT is the maximum number of iterations allowed for each */
+/* eigenvalue. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ren-Cang Li, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Since this routine is called in an inner loop, we do no argument */
+/* checking. */
+
+/* Quick return for N=1 and 2. */
+
+ /* Parameter adjustments */
+ --work;
+ --delta;
+ --z__;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+ if (*n == 1) {
+
+/* Presumably, I=1 upon entry */
+
+ *sigma = sqrt(d__[1] * d__[1] + *rho * z__[1] * z__[1]);
+ delta[1] = 1.f;
+ work[1] = 1.f;
+ return 0;
+ }
+ if (*n == 2) {
+ slasd5_(i__, &d__[1], &z__[1], &delta[1], rho, sigma, &work[1]);
+ return 0;
+ }
+
+/* Compute machine epsilon */
+
+ eps = slamch_("Epsilon");
+ rhoinv = 1.f / *rho;
+
+/* The case I = N */
+
+ if (*i__ == *n) {
+
+/* Initialize some basic variables */
+
+ ii = *n - 1;
+ niter = 1;
+
+/* Calculate initial guess */
+
+ temp = *rho / 2.f;
+
+/* If ||Z||_2 is not one, then TEMP should be set to */
+/* RHO * ||Z||_2^2 / TWO */
+
+ temp1 = temp / (d__[*n] + sqrt(d__[*n] * d__[*n] + temp));
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[j] = d__[j] + d__[*n] + temp1;
+ delta[j] = d__[j] - d__[*n] - temp1;
+/* L10: */
+ }
+
+ psi = 0.f;
+ i__1 = *n - 2;
+ for (j = 1; j <= i__1; ++j) {
+ psi += z__[j] * z__[j] / (delta[j] * work[j]);
+/* L20: */
+ }
+
+ c__ = rhoinv + psi;
+ w = c__ + z__[ii] * z__[ii] / (delta[ii] * work[ii]) + z__[*n] * z__[*
+ n] / (delta[*n] * work[*n]);
+
+ if (w <= 0.f) {
+ temp1 = sqrt(d__[*n] * d__[*n] + *rho);
+ temp = z__[*n - 1] * z__[*n - 1] / ((d__[*n - 1] + temp1) * (d__[*
+ n] - d__[*n - 1] + *rho / (d__[*n] + temp1))) + z__[*n] *
+ z__[*n] / *rho;
+
+/* The following TAU is to approximate */
+/* SIGMA_n^2 - D( N )*D( N ) */
+
+ if (c__ <= temp) {
+ tau = *rho;
+ } else {
+ delsq = (d__[*n] - d__[*n - 1]) * (d__[*n] + d__[*n - 1]);
+ a = -c__ * delsq + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*
+ n];
+ b = z__[*n] * z__[*n] * delsq;
+ if (a < 0.f) {
+ tau = b * 2.f / (sqrt(a * a + b * 4.f * c__) - a);
+ } else {
+ tau = (a + sqrt(a * a + b * 4.f * c__)) / (c__ * 2.f);
+ }
+ }
+
+/* It can be proved that */
+/* D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU <= D(N)^2+RHO */
+
+ } else {
+ delsq = (d__[*n] - d__[*n - 1]) * (d__[*n] + d__[*n - 1]);
+ a = -c__ * delsq + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n];
+ b = z__[*n] * z__[*n] * delsq;
+
+/* The following TAU is to approximate */
+/* SIGMA_n^2 - D( N )*D( N ) */
+
+ if (a < 0.f) {
+ tau = b * 2.f / (sqrt(a * a + b * 4.f * c__) - a);
+ } else {
+ tau = (a + sqrt(a * a + b * 4.f * c__)) / (c__ * 2.f);
+ }
+
+/* It can be proved that */
+/* D(N)^2 < D(N)^2+TAU < SIGMA(N)^2 < D(N)^2+RHO/2 */
+
+ }
+
+/* The following ETA is to approximate SIGMA_n - D( N ) */
+
+ eta = tau / (d__[*n] + sqrt(d__[*n] * d__[*n] + tau));
+
+ *sigma = d__[*n] + eta;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] = d__[j] - d__[*i__] - eta;
+ work[j] = d__[j] + d__[*i__] + eta;
+/* L30: */
+ }
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.f;
+ psi = 0.f;
+ erretm = 0.f;
+ i__1 = ii;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / (delta[j] * work[j]);
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L40: */
+ }
+ erretm = dabs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ temp = z__[*n] / (delta[*n] * work[*n]);
+ phi = z__[*n] * temp;
+ dphi = temp * temp;
+ erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv + dabs(tau) * (
+ dpsi + dphi);
+
+ w = rhoinv + phi + psi;
+
+/* Test for convergence */
+
+ if (dabs(w) <= eps * erretm) {
+ goto L240;
+ }
+
+/* Calculate the new step */
+
+ ++niter;
+ dtnsq1 = work[*n - 1] * delta[*n - 1];
+ dtnsq = work[*n] * delta[*n];
+ c__ = w - dtnsq1 * dpsi - dtnsq * dphi;
+ a = (dtnsq + dtnsq1) * w - dtnsq * dtnsq1 * (dpsi + dphi);
+ b = dtnsq * dtnsq1 * w;
+ if (c__ < 0.f) {
+ c__ = dabs(c__);
+ }
+ if (c__ == 0.f) {
+ eta = *rho - *sigma * *sigma;
+ } else if (a >= 0.f) {
+ eta = (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) / (
+ c__ * 2.f);
+ } else {
+ eta = b * 2.f / (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(
+ r__1))));
+ }
+
+/* Note, eta should be positive if w is negative, and */
+/* eta should be negative otherwise. However, */
+/* if for some reason caused by roundoff, eta*w > 0, */
+/* we simply use one Newton step instead. This way */
+/* will guarantee eta*w < 0. */
+
+ if (w * eta > 0.f) {
+ eta = -w / (dpsi + dphi);
+ }
+ temp = eta - dtnsq;
+ if (temp > *rho) {
+ eta = *rho + dtnsq;
+ }
+
+ tau += eta;
+ eta /= *sigma + sqrt(eta + *sigma * *sigma);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] -= eta;
+ work[j] += eta;
+/* L50: */
+ }
+
+ *sigma += eta;
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.f;
+ psi = 0.f;
+ erretm = 0.f;
+ i__1 = ii;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / (work[j] * delta[j]);
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L60: */
+ }
+ erretm = dabs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ temp = z__[*n] / (work[*n] * delta[*n]);
+ phi = z__[*n] * temp;
+ dphi = temp * temp;
+ erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv + dabs(tau) * (
+ dpsi + dphi);
+
+ w = rhoinv + phi + psi;
+
+/* Main loop to update the values of the array DELTA */
+
+ iter = niter + 1;
+
+ for (niter = iter; niter <= 20; ++niter) {
+
+/* Test for convergence */
+
+ if (dabs(w) <= eps * erretm) {
+ goto L240;
+ }
+
+/* Calculate the new step */
+
+ dtnsq1 = work[*n - 1] * delta[*n - 1];
+ dtnsq = work[*n] * delta[*n];
+ c__ = w - dtnsq1 * dpsi - dtnsq * dphi;
+ a = (dtnsq + dtnsq1) * w - dtnsq1 * dtnsq * (dpsi + dphi);
+ b = dtnsq1 * dtnsq * w;
+ if (a >= 0.f) {
+ eta = (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) /
+ (c__ * 2.f);
+ } else {
+ eta = b * 2.f / (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(
+ r__1))));
+ }
+
+/* Note, eta should be positive if w is negative, and */
+/* eta should be negative otherwise. However, */
+/* if for some reason caused by roundoff, eta*w > 0, */
+/* we simply use one Newton step instead. This way */
+/* will guarantee eta*w < 0. */
+
+ if (w * eta > 0.f) {
+ eta = -w / (dpsi + dphi);
+ }
+ temp = eta - dtnsq;
+ if (temp <= 0.f) {
+ eta /= 2.f;
+ }
+
+ tau += eta;
+ eta /= *sigma + sqrt(eta + *sigma * *sigma);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ delta[j] -= eta;
+ work[j] += eta;
+/* L70: */
+ }
+
+ *sigma += eta;
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.f;
+ psi = 0.f;
+ erretm = 0.f;
+ i__1 = ii;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / (work[j] * delta[j]);
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L80: */
+ }
+ erretm = dabs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ temp = z__[*n] / (work[*n] * delta[*n]);
+ phi = z__[*n] * temp;
+ dphi = temp * temp;
+ erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv + dabs(tau) *
+ (dpsi + dphi);
+
+ w = rhoinv + phi + psi;
+/* L90: */
+ }
+
+/* Return with INFO = 1, NITER = MAXIT and not converged */
+
+ *info = 1;
+ goto L240;
+
+/* End for the case I = N */
+
+ } else {
+
+/* The case for I < N */
+
+ niter = 1;
+ ip1 = *i__ + 1;
+
+/* Calculate initial guess */
+
+ delsq = (d__[ip1] - d__[*i__]) * (d__[ip1] + d__[*i__]);
+ delsq2 = delsq / 2.f;
+ temp = delsq2 / (d__[*i__] + sqrt(d__[*i__] * d__[*i__] + delsq2));
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[j] = d__[j] + d__[*i__] + temp;
+ delta[j] = d__[j] - d__[*i__] - temp;
+/* L100: */
+ }
+
+ psi = 0.f;
+ i__1 = *i__ - 1;
+ for (j = 1; j <= i__1; ++j) {
+ psi += z__[j] * z__[j] / (work[j] * delta[j]);
+/* L110: */
+ }
+
+ phi = 0.f;
+ i__1 = *i__ + 2;
+ for (j = *n; j >= i__1; --j) {
+ phi += z__[j] * z__[j] / (work[j] * delta[j]);
+/* L120: */
+ }
+ c__ = rhoinv + psi + phi;
+ w = c__ + z__[*i__] * z__[*i__] / (work[*i__] * delta[*i__]) + z__[
+ ip1] * z__[ip1] / (work[ip1] * delta[ip1]);
+
+ if (w > 0.f) {
+
+/* d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2 */
+
+/* We choose d(i) as origin. */
+
+ orgati = TRUE_;
+ sg2lb = 0.f;
+ sg2ub = delsq2;
+ a = c__ * delsq + z__[*i__] * z__[*i__] + z__[ip1] * z__[ip1];
+ b = z__[*i__] * z__[*i__] * delsq;
+ if (a > 0.f) {
+ tau = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(
+ r__1))));
+ } else {
+ tau = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) /
+ (c__ * 2.f);
+ }
+
+/* TAU now is an estimation of SIGMA^2 - D( I )^2. The */
+/* following, however, is the corresponding estimation of */
+/* SIGMA - D( I ). */
+
+ eta = tau / (d__[*i__] + sqrt(d__[*i__] * d__[*i__] + tau));
+ } else {
+
+/* (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2 */
+
+/* We choose d(i+1) as origin. */
+
+ orgati = FALSE_;
+ sg2lb = -delsq2;
+ sg2ub = 0.f;
+ a = c__ * delsq - z__[*i__] * z__[*i__] - z__[ip1] * z__[ip1];
+ b = z__[ip1] * z__[ip1] * delsq;
+ if (a < 0.f) {
+ tau = b * 2.f / (a - sqrt((r__1 = a * a + b * 4.f * c__, dabs(
+ r__1))));
+ } else {
+ tau = -(a + sqrt((r__1 = a * a + b * 4.f * c__, dabs(r__1))))
+ / (c__ * 2.f);
+ }
+
+/* TAU now is an estimation of SIGMA^2 - D( IP1 )^2. The */
+/* following, however, is the corresponding estimation of */
+/* SIGMA - D( IP1 ). */
+
+ eta = tau / (d__[ip1] + sqrt((r__1 = d__[ip1] * d__[ip1] + tau,
+ dabs(r__1))));
+ }
+
+ if (orgati) {
+ ii = *i__;
+ *sigma = d__[*i__] + eta;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[j] = d__[j] + d__[*i__] + eta;
+ delta[j] = d__[j] - d__[*i__] - eta;
+/* L130: */
+ }
+ } else {
+ ii = *i__ + 1;
+ *sigma = d__[ip1] + eta;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[j] = d__[j] + d__[ip1] + eta;
+ delta[j] = d__[j] - d__[ip1] - eta;
+/* L140: */
+ }
+ }
+ iim1 = ii - 1;
+ iip1 = ii + 1;
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.f;
+ psi = 0.f;
+ erretm = 0.f;
+ i__1 = iim1;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / (work[j] * delta[j]);
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L150: */
+ }
+ erretm = dabs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ dphi = 0.f;
+ phi = 0.f;
+ i__1 = iip1;
+ for (j = *n; j >= i__1; --j) {
+ temp = z__[j] / (work[j] * delta[j]);
+ phi += z__[j] * temp;
+ dphi += temp * temp;
+ erretm += phi;
+/* L160: */
+ }
+
+ w = rhoinv + phi + psi;
+
+/* W is the value of the secular function with */
+/* its ii-th element removed. */
+
+ swtch3 = FALSE_;
+ if (orgati) {
+ if (w < 0.f) {
+ swtch3 = TRUE_;
+ }
+ } else {
+ if (w > 0.f) {
+ swtch3 = TRUE_;
+ }
+ }
+ if (ii == 1 || ii == *n) {
+ swtch3 = FALSE_;
+ }
+
+ temp = z__[ii] / (work[ii] * delta[ii]);
+ dw = dpsi + dphi + temp * temp;
+ temp = z__[ii] * temp;
+ w += temp;
+ erretm = (phi - psi) * 8.f + erretm + rhoinv * 2.f + dabs(temp) * 3.f
+ + dabs(tau) * dw;
+
+/* Test for convergence */
+
+ if (dabs(w) <= eps * erretm) {
+ goto L240;
+ }
+
+ if (w <= 0.f) {
+ sg2lb = dmax(sg2lb,tau);
+ } else {
+ sg2ub = dmin(sg2ub,tau);
+ }
+
+/* Calculate the new step */
+
+ ++niter;
+ if (! swtch3) {
+ dtipsq = work[ip1] * delta[ip1];
+ dtisq = work[*i__] * delta[*i__];
+ if (orgati) {
+/* Computing 2nd power */
+ r__1 = z__[*i__] / dtisq;
+ c__ = w - dtipsq * dw + delsq * (r__1 * r__1);
+ } else {
+/* Computing 2nd power */
+ r__1 = z__[ip1] / dtipsq;
+ c__ = w - dtisq * dw - delsq * (r__1 * r__1);
+ }
+ a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw;
+ b = dtipsq * dtisq * w;
+ if (c__ == 0.f) {
+ if (a == 0.f) {
+ if (orgati) {
+ a = z__[*i__] * z__[*i__] + dtipsq * dtipsq * (dpsi +
+ dphi);
+ } else {
+ a = z__[ip1] * z__[ip1] + dtisq * dtisq * (dpsi +
+ dphi);
+ }
+ }
+ eta = b / a;
+ } else if (a <= 0.f) {
+ eta = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) /
+ (c__ * 2.f);
+ } else {
+ eta = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(
+ r__1))));
+ }
+ } else {
+
+/* Interpolation using THREE most relevant poles */
+
+ dtiim = work[iim1] * delta[iim1];
+ dtiip = work[iip1] * delta[iip1];
+ temp = rhoinv + psi + phi;
+ if (orgati) {
+ temp1 = z__[iim1] / dtiim;
+ temp1 *= temp1;
+ c__ = temp - dtiip * (dpsi + dphi) - (d__[iim1] - d__[iip1]) *
+ (d__[iim1] + d__[iip1]) * temp1;
+ zz[0] = z__[iim1] * z__[iim1];
+ if (dpsi < temp1) {
+ zz[2] = dtiip * dtiip * dphi;
+ } else {
+ zz[2] = dtiip * dtiip * (dpsi - temp1 + dphi);
+ }
+ } else {
+ temp1 = z__[iip1] / dtiip;
+ temp1 *= temp1;
+ c__ = temp - dtiim * (dpsi + dphi) - (d__[iip1] - d__[iim1]) *
+ (d__[iim1] + d__[iip1]) * temp1;
+ if (dphi < temp1) {
+ zz[0] = dtiim * dtiim * dpsi;
+ } else {
+ zz[0] = dtiim * dtiim * (dpsi + (dphi - temp1));
+ }
+ zz[2] = z__[iip1] * z__[iip1];
+ }
+ zz[1] = z__[ii] * z__[ii];
+ dd[0] = dtiim;
+ dd[1] = delta[ii] * work[ii];
+ dd[2] = dtiip;
+ slaed6_(&niter, &orgati, &c__, dd, zz, &w, &eta, info);
+ if (*info != 0) {
+ goto L240;
+ }
+ }
+
+/* Note, eta should be positive if w is negative, and */
+/* eta should be negative otherwise. However, */
+/* if for some reason caused by roundoff, eta*w > 0, */
+/* we simply use one Newton step instead. This way */
+/* will guarantee eta*w < 0. */
+
+ if (w * eta >= 0.f) {
+ eta = -w / dw;
+ }
+ if (orgati) {
+ temp1 = work[*i__] * delta[*i__];
+ temp = eta - temp1;
+ } else {
+ temp1 = work[ip1] * delta[ip1];
+ temp = eta - temp1;
+ }
+ if (temp > sg2ub || temp < sg2lb) {
+ if (w < 0.f) {
+ eta = (sg2ub - tau) / 2.f;
+ } else {
+ eta = (sg2lb - tau) / 2.f;
+ }
+ }
+
+ tau += eta;
+ eta /= *sigma + sqrt(*sigma * *sigma + eta);
+
+ prew = w;
+
+ *sigma += eta;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[j] += eta;
+ delta[j] -= eta;
+/* L170: */
+ }
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.f;
+ psi = 0.f;
+ erretm = 0.f;
+ i__1 = iim1;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / (work[j] * delta[j]);
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L180: */
+ }
+ erretm = dabs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ dphi = 0.f;
+ phi = 0.f;
+ i__1 = iip1;
+ for (j = *n; j >= i__1; --j) {
+ temp = z__[j] / (work[j] * delta[j]);
+ phi += z__[j] * temp;
+ dphi += temp * temp;
+ erretm += phi;
+/* L190: */
+ }
+
+ temp = z__[ii] / (work[ii] * delta[ii]);
+ dw = dpsi + dphi + temp * temp;
+ temp = z__[ii] * temp;
+ w = rhoinv + phi + psi + temp;
+ erretm = (phi - psi) * 8.f + erretm + rhoinv * 2.f + dabs(temp) * 3.f
+ + dabs(tau) * dw;
+
+ if (w <= 0.f) {
+ sg2lb = dmax(sg2lb,tau);
+ } else {
+ sg2ub = dmin(sg2ub,tau);
+ }
+
+ swtch = FALSE_;
+ if (orgati) {
+ if (-w > dabs(prew) / 10.f) {
+ swtch = TRUE_;
+ }
+ } else {
+ if (w > dabs(prew) / 10.f) {
+ swtch = TRUE_;
+ }
+ }
+
+/* Main loop to update the values of the array DELTA and WORK */
+
+ iter = niter + 1;
+
+ for (niter = iter; niter <= 20; ++niter) {
+
+/* Test for convergence */
+
+ if (dabs(w) <= eps * erretm) {
+ goto L240;
+ }
+
+/* Calculate the new step */
+
+ if (! swtch3) {
+ dtipsq = work[ip1] * delta[ip1];
+ dtisq = work[*i__] * delta[*i__];
+ if (! swtch) {
+ if (orgati) {
+/* Computing 2nd power */
+ r__1 = z__[*i__] / dtisq;
+ c__ = w - dtipsq * dw + delsq * (r__1 * r__1);
+ } else {
+/* Computing 2nd power */
+ r__1 = z__[ip1] / dtipsq;
+ c__ = w - dtisq * dw - delsq * (r__1 * r__1);
+ }
+ } else {
+ temp = z__[ii] / (work[ii] * delta[ii]);
+ if (orgati) {
+ dpsi += temp * temp;
+ } else {
+ dphi += temp * temp;
+ }
+ c__ = w - dtisq * dpsi - dtipsq * dphi;
+ }
+ a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw;
+ b = dtipsq * dtisq * w;
+ if (c__ == 0.f) {
+ if (a == 0.f) {
+ if (! swtch) {
+ if (orgati) {
+ a = z__[*i__] * z__[*i__] + dtipsq * dtipsq *
+ (dpsi + dphi);
+ } else {
+ a = z__[ip1] * z__[ip1] + dtisq * dtisq * (
+ dpsi + dphi);
+ }
+ } else {
+ a = dtisq * dtisq * dpsi + dtipsq * dtipsq * dphi;
+ }
+ }
+ eta = b / a;
+ } else if (a <= 0.f) {
+ eta = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1))
+ )) / (c__ * 2.f);
+ } else {
+ eta = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__,
+ dabs(r__1))));
+ }
+ } else {
+
+/* Interpolation using THREE most relevant poles */
+
+ dtiim = work[iim1] * delta[iim1];
+ dtiip = work[iip1] * delta[iip1];
+ temp = rhoinv + psi + phi;
+ if (swtch) {
+ c__ = temp - dtiim * dpsi - dtiip * dphi;
+ zz[0] = dtiim * dtiim * dpsi;
+ zz[2] = dtiip * dtiip * dphi;
+ } else {
+ if (orgati) {
+ temp1 = z__[iim1] / dtiim;
+ temp1 *= temp1;
+ temp2 = (d__[iim1] - d__[iip1]) * (d__[iim1] + d__[
+ iip1]) * temp1;
+ c__ = temp - dtiip * (dpsi + dphi) - temp2;
+ zz[0] = z__[iim1] * z__[iim1];
+ if (dpsi < temp1) {
+ zz[2] = dtiip * dtiip * dphi;
+ } else {
+ zz[2] = dtiip * dtiip * (dpsi - temp1 + dphi);
+ }
+ } else {
+ temp1 = z__[iip1] / dtiip;
+ temp1 *= temp1;
+ temp2 = (d__[iip1] - d__[iim1]) * (d__[iim1] + d__[
+ iip1]) * temp1;
+ c__ = temp - dtiim * (dpsi + dphi) - temp2;
+ if (dphi < temp1) {
+ zz[0] = dtiim * dtiim * dpsi;
+ } else {
+ zz[0] = dtiim * dtiim * (dpsi + (dphi - temp1));
+ }
+ zz[2] = z__[iip1] * z__[iip1];
+ }
+ }
+ dd[0] = dtiim;
+ dd[1] = delta[ii] * work[ii];
+ dd[2] = dtiip;
+ slaed6_(&niter, &orgati, &c__, dd, zz, &w, &eta, info);
+ if (*info != 0) {
+ goto L240;
+ }
+ }
+
+/* Note, eta should be positive if w is negative, and */
+/* eta should be negative otherwise. However, */
+/* if for some reason caused by roundoff, eta*w > 0, */
+/* we simply use one Newton step instead. This way */
+/* will guarantee eta*w < 0. */
+
+ if (w * eta >= 0.f) {
+ eta = -w / dw;
+ }
+ if (orgati) {
+ temp1 = work[*i__] * delta[*i__];
+ temp = eta - temp1;
+ } else {
+ temp1 = work[ip1] * delta[ip1];
+ temp = eta - temp1;
+ }
+ if (temp > sg2ub || temp < sg2lb) {
+ if (w < 0.f) {
+ eta = (sg2ub - tau) / 2.f;
+ } else {
+ eta = (sg2lb - tau) / 2.f;
+ }
+ }
+
+ tau += eta;
+ eta /= *sigma + sqrt(*sigma * *sigma + eta);
+
+ *sigma += eta;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[j] += eta;
+ delta[j] -= eta;
+/* L200: */
+ }
+
+ prew = w;
+
+/* Evaluate PSI and the derivative DPSI */
+
+ dpsi = 0.f;
+ psi = 0.f;
+ erretm = 0.f;
+ i__1 = iim1;
+ for (j = 1; j <= i__1; ++j) {
+ temp = z__[j] / (work[j] * delta[j]);
+ psi += z__[j] * temp;
+ dpsi += temp * temp;
+ erretm += psi;
+/* L210: */
+ }
+ erretm = dabs(erretm);
+
+/* Evaluate PHI and the derivative DPHI */
+
+ dphi = 0.f;
+ phi = 0.f;
+ i__1 = iip1;
+ for (j = *n; j >= i__1; --j) {
+ temp = z__[j] / (work[j] * delta[j]);
+ phi += z__[j] * temp;
+ dphi += temp * temp;
+ erretm += phi;
+/* L220: */
+ }
+
+ temp = z__[ii] / (work[ii] * delta[ii]);
+ dw = dpsi + dphi + temp * temp;
+ temp = z__[ii] * temp;
+ w = rhoinv + phi + psi + temp;
+ erretm = (phi - psi) * 8.f + erretm + rhoinv * 2.f + dabs(temp) *
+ 3.f + dabs(tau) * dw;
+ if (w * prew > 0.f && dabs(w) > dabs(prew) / 10.f) {
+ swtch = ! swtch;
+ }
+
+ if (w <= 0.f) {
+ sg2lb = dmax(sg2lb,tau);
+ } else {
+ sg2ub = dmin(sg2ub,tau);
+ }
+
+/* L230: */
+ }
+
+/* Return with INFO = 1, NITER = MAXIT and not converged */
+
+ *info = 1;
+
+ }
+
+L240:
+ return 0;
+
+/* End of SLASD4 */
+
+} /* slasd4_ */
diff --git a/SRC/slasd5.c b/SRC/slasd5.c
new file mode 100644
index 0000000..6e2e3d2
--- /dev/null
+++ b/SRC/slasd5.c
@@ -0,0 +1,189 @@
+/* slasd5.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slasd5_(integer *i__, real *d__, real *z__, real *delta,
+ real *rho, real *dsigma, real *work)
+{
+ /* System generated locals */
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real b, c__, w, del, tau, delsq;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This subroutine computes the square root of the I-th eigenvalue */
+/* of a positive symmetric rank-one modification of a 2-by-2 diagonal */
+/* matrix */
+
+/* diag( D ) * diag( D ) + RHO * Z * transpose(Z) . */
+
+/* The diagonal entries in the array D are assumed to satisfy */
+
+/* 0 <= D(i) < D(j) for i < j . */
+
+/* We also assume RHO > 0 and that the Euclidean norm of the vector */
+/* Z is one. */
+
+/* Arguments */
+/* ========= */
+
+/* I (input) INTEGER */
+/* The index of the eigenvalue to be computed. I = 1 or I = 2. */
+
+/* D (input) REAL array, dimension (2) */
+/* The original eigenvalues. We assume 0 <= D(1) < D(2). */
+
+/* Z (input) REAL array, dimension (2) */
+/* The components of the updating vector. */
+
+/* DELTA (output) REAL array, dimension (2) */
+/* Contains (D(j) - sigma_I) in its j-th component. */
+/* The vector DELTA contains the information necessary */
+/* to construct the eigenvectors. */
+
+/* RHO (input) REAL */
+/* The scalar in the symmetric updating formula. */
+
+/* DSIGMA (output) REAL */
+/* The computed sigma_I, the I-th updated eigenvalue. */
+
+/* WORK (workspace) REAL array, dimension (2) */
+/* WORK contains (D(j) + sigma_I) in its j-th component. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ren-Cang Li, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --delta;
+ --z__;
+ --d__;
+
+ /* Function Body */
+ del = d__[2] - d__[1];
+ delsq = del * (d__[2] + d__[1]);
+ if (*i__ == 1) {
+ w = *rho * 4.f * (z__[2] * z__[2] / (d__[1] + d__[2] * 3.f) - z__[1] *
+ z__[1] / (d__[1] * 3.f + d__[2])) / del + 1.f;
+ if (w > 0.f) {
+ b = delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
+ c__ = *rho * z__[1] * z__[1] * delsq;
+
+/* B > ZERO, always */
+
+/* The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 ) */
+
+ tau = c__ * 2.f / (b + sqrt((r__1 = b * b - c__ * 4.f, dabs(r__1))
+ ));
+
+/* The following TAU is DSIGMA - D( 1 ) */
+
+ tau /= d__[1] + sqrt(d__[1] * d__[1] + tau);
+ *dsigma = d__[1] + tau;
+ delta[1] = -tau;
+ delta[2] = del - tau;
+ work[1] = d__[1] * 2.f + tau;
+ work[2] = d__[1] + tau + d__[2];
+/* DELTA( 1 ) = -Z( 1 ) / TAU */
+/* DELTA( 2 ) = Z( 2 ) / ( DEL-TAU ) */
+ } else {
+ b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
+ c__ = *rho * z__[2] * z__[2] * delsq;
+
+/* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) */
+
+ if (b > 0.f) {
+ tau = c__ * -2.f / (b + sqrt(b * b + c__ * 4.f));
+ } else {
+ tau = (b - sqrt(b * b + c__ * 4.f)) / 2.f;
+ }
+
+/* The following TAU is DSIGMA - D( 2 ) */
+
+ tau /= d__[2] + sqrt((r__1 = d__[2] * d__[2] + tau, dabs(r__1)));
+ *dsigma = d__[2] + tau;
+ delta[1] = -(del + tau);
+ delta[2] = -tau;
+ work[1] = d__[1] + tau + d__[2];
+ work[2] = d__[2] * 2.f + tau;
+/* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) */
+/* DELTA( 2 ) = -Z( 2 ) / TAU */
+ }
+/* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) */
+/* DELTA( 1 ) = DELTA( 1 ) / TEMP */
+/* DELTA( 2 ) = DELTA( 2 ) / TEMP */
+ } else {
+
+/* Now I=2 */
+
+ b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]);
+ c__ = *rho * z__[2] * z__[2] * delsq;
+
+/* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) */
+
+ if (b > 0.f) {
+ tau = (b + sqrt(b * b + c__ * 4.f)) / 2.f;
+ } else {
+ tau = c__ * 2.f / (-b + sqrt(b * b + c__ * 4.f));
+ }
+
+/* The following TAU is DSIGMA - D( 2 ) */
+
+ tau /= d__[2] + sqrt(d__[2] * d__[2] + tau);
+ *dsigma = d__[2] + tau;
+ delta[1] = -(del + tau);
+ delta[2] = -tau;
+ work[1] = d__[1] + tau + d__[2];
+ work[2] = d__[2] * 2.f + tau;
+/* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) */
+/* DELTA( 2 ) = -Z( 2 ) / TAU */
+/* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) */
+/* DELTA( 1 ) = DELTA( 1 ) / TEMP */
+/* DELTA( 2 ) = DELTA( 2 ) / TEMP */
+ }
+ return 0;
+
+/* End of SLASD5 */
+
+} /* slasd5_ */
diff --git a/SRC/slasd6.c b/SRC/slasd6.c
new file mode 100644
index 0000000..3be8d74
--- /dev/null
+++ b/SRC/slasd6.c
@@ -0,0 +1,364 @@
+/* slasd6.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static real c_b7 = 1.f;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int slasd6_(integer *icompq, integer *nl, integer *nr,
+ integer *sqre, real *d__, real *vf, real *vl, real *alpha, real *beta,
+ integer *idxq, integer *perm, integer *givptr, integer *givcol,
+ integer *ldgcol, real *givnum, integer *ldgnum, real *poles, real *
+ difl, real *difr, real *z__, integer *k, real *c__, real *s, real *
+ work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset,
+ poles_dim1, poles_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer i__, m, n, n1, n2, iw, idx, idxc, idxp, ivfw, ivlw;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), slasd7_(integer *, integer *, integer *, integer *,
+ integer *, real *, real *, real *, real *, real *, real *, real *,
+ real *, real *, real *, integer *, integer *, integer *, integer
+ *, integer *, integer *, integer *, real *, integer *, real *,
+ real *, integer *), slasd8_(integer *, integer *, real *, real *,
+ real *, real *, real *, real *, integer *, real *, real *,
+ integer *);
+ integer isigma;
+ extern /* Subroutine */ int xerbla_(char *, integer *), slascl_(
+ char *, integer *, integer *, real *, real *, integer *, integer *
+, real *, integer *, integer *), slamrg_(integer *,
+ integer *, real *, integer *, integer *, integer *);
+ real orgnrm;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASD6 computes the SVD of an updated upper bidiagonal matrix B */
+/* obtained by merging two smaller ones by appending a row. This */
+/* routine is used only for the problem which requires all singular */
+/* values and optionally singular vector matrices in factored form. */
+/* B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE. */
+/* A related subroutine, SLASD1, handles the case in which all singular */
+/* values and singular vectors of the bidiagonal matrix are desired. */
+
+/* SLASD6 computes the SVD as follows: */
+
+/* ( D1(in) 0 0 0 ) */
+/* B = U(in) * ( Z1' a Z2' b ) * VT(in) */
+/* ( 0 0 D2(in) 0 ) */
+
+/* = U(out) * ( D(out) 0) * VT(out) */
+
+/* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M */
+/* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros */
+/* elsewhere; and the entry b is empty if SQRE = 0. */
+
+/* The singular values of B can be computed using D1, D2, the first */
+/* components of all the right singular vectors of the lower block, and */
+/* the last components of all the right singular vectors of the upper */
+/* block. These components are stored and updated in VF and VL, */
+/* respectively, in SLASD6. Hence U and VT are not explicitly */
+/* referenced. */
+
+/* The singular values are stored in D. The algorithm consists of two */
+/* stages: */
+
+/* The first stage consists of deflating the size of the problem */
+/* when there are multiple singular values or if there is a zero */
+/* in the Z vector. For each such occurence the dimension of the */
+/* secular equation problem is reduced by one. This stage is */
+/* performed by the routine SLASD7. */
+
+/* The second stage consists of calculating the updated */
+/* singular values. This is done by finding the roots of the */
+/* secular equation via the routine SLASD4 (as called by SLASD8). */
+/* This routine also updates VF and VL and computes the distances */
+/* between the updated singular values and the old singular */
+/* values. */
+
+/* SLASD6 is called from SLASDA. */
+
+/* Arguments */
+/* ========= */
+
+/* ICOMPQ (input) INTEGER */
+/* Specifies whether singular vectors are to be computed in */
+/* factored form: */
+/* = 0: Compute singular values only. */
+/* = 1: Compute singular vectors in factored form as well. */
+
+/* NL (input) INTEGER */
+/* The row dimension of the upper block. NL >= 1. */
+
+/* NR (input) INTEGER */
+/* The row dimension of the lower block. NR >= 1. */
+
+/* SQRE (input) INTEGER */
+/* = 0: the lower block is an NR-by-NR square matrix. */
+/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */
+
+/* The bidiagonal matrix has row dimension N = NL + NR + 1, */
+/* and column dimension M = N + SQRE. */
+
+/* D (input/output) REAL array, dimension (NL+NR+1). */
+/* On entry D(1:NL,1:NL) contains the singular values of the */
+/* upper block, and D(NL+2:N) contains the singular values */
+/* of the lower block. On exit D(1:N) contains the singular */
+/* values of the modified matrix. */
+
+/* VF (input/output) REAL array, dimension (M) */
+/* On entry, VF(1:NL+1) contains the first components of all */
+/* right singular vectors of the upper block; and VF(NL+2:M) */
+/* contains the first components of all right singular vectors */
+/* of the lower block. On exit, VF contains the first components */
+/* of all right singular vectors of the bidiagonal matrix. */
+
+/* VL (input/output) REAL array, dimension (M) */
+/* On entry, VL(1:NL+1) contains the last components of all */
+/* right singular vectors of the upper block; and VL(NL+2:M) */
+/* contains the last components of all right singular vectors of */
+/* the lower block. On exit, VL contains the last components of */
+/* all right singular vectors of the bidiagonal matrix. */
+
+/* ALPHA (input/output) REAL */
+/* Contains the diagonal element associated with the added row. */
+
+/* BETA (input/output) REAL */
+/* Contains the off-diagonal element associated with the added */
+/* row. */
+
+/* IDXQ (output) INTEGER array, dimension (N) */
+/* This contains the permutation which will reintegrate the */
+/* subproblem just solved back into sorted order, i.e. */
+/* D( IDXQ( I = 1, N ) ) will be in ascending order. */
+
+/* PERM (output) INTEGER array, dimension ( N ) */
+/* The permutations (from deflation and sorting) to be applied */
+/* to each block. Not referenced if ICOMPQ = 0. */
+
+/* GIVPTR (output) INTEGER */
+/* The number of Givens rotations which took place in this */
+/* subproblem. Not referenced if ICOMPQ = 0. */
+
+/* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 ) */
+/* Each pair of numbers indicates a pair of columns to take place */
+/* in a Givens rotation. Not referenced if ICOMPQ = 0. */
+
+/* LDGCOL (input) INTEGER */
+/* leading dimension of GIVCOL, must be at least N. */
+
+/* GIVNUM (output) REAL array, dimension ( LDGNUM, 2 ) */
+/* Each number indicates the C or S value to be used in the */
+/* corresponding Givens rotation. Not referenced if ICOMPQ = 0. */
+
+/* LDGNUM (input) INTEGER */
+/* The leading dimension of GIVNUM and POLES, must be at least N. */
+
+/* POLES (output) REAL array, dimension ( LDGNUM, 2 ) */
+/* On exit, POLES(1,*) is an array containing the new singular */
+/* values obtained from solving the secular equation, and */
+/* POLES(2,*) is an array containing the poles in the secular */
+/* equation. Not referenced if ICOMPQ = 0. */
+
+/* DIFL (output) REAL array, dimension ( N ) */
+/* On exit, DIFL(I) is the distance between I-th updated */
+/* (undeflated) singular value and the I-th (undeflated) old */
+/* singular value. */
+
+/* DIFR (output) REAL array, */
+/* dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and */
+/* dimension ( N ) if ICOMPQ = 0. */
+/* On exit, DIFR(I, 1) is the distance between I-th updated */
+/* (undeflated) singular value and the I+1-th (undeflated) old */
+/* singular value. */
+
+/* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the */
+/* normalizing factors for the right singular vector matrix. */
+
+/* See SLASD8 for details on DIFL and DIFR. */
+
+/* Z (output) REAL array, dimension ( M ) */
+/* The first elements of this array contain the components */
+/* of the deflation-adjusted updating row vector. */
+
+/* K (output) INTEGER */
+/* Contains the dimension of the non-deflated matrix, */
+/* This is the order of the related secular equation. 1 <= K <=N. */
+
+/* C (output) REAL */
+/* C contains garbage if SQRE =0 and the C-value of a Givens */
+/* rotation related to the right null space if SQRE = 1. */
+
+/* S (output) REAL */
+/* S contains garbage if SQRE =0 and the S-value of a Givens */
+/* rotation related to the right null space if SQRE = 1. */
+
+/* WORK (workspace) REAL array, dimension ( 4 * M ) */
+
+/* IWORK (workspace) INTEGER array, dimension ( 3 * N ) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, an singular value did not converge */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --vf;
+ --vl;
+ --idxq;
+ --perm;
+ givcol_dim1 = *ldgcol;
+ givcol_offset = 1 + givcol_dim1;
+ givcol -= givcol_offset;
+ poles_dim1 = *ldgnum;
+ poles_offset = 1 + poles_dim1;
+ poles -= poles_offset;
+ givnum_dim1 = *ldgnum;
+ givnum_offset = 1 + givnum_dim1;
+ givnum -= givnum_offset;
+ --difl;
+ --difr;
+ --z__;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ n = *nl + *nr + 1;
+ m = n + *sqre;
+
+ if (*icompq < 0 || *icompq > 1) {
+ *info = -1;
+ } else if (*nl < 1) {
+ *info = -2;
+ } else if (*nr < 1) {
+ *info = -3;
+ } else if (*sqre < 0 || *sqre > 1) {
+ *info = -4;
+ } else if (*ldgcol < n) {
+ *info = -14;
+ } else if (*ldgnum < n) {
+ *info = -16;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLASD6", &i__1);
+ return 0;
+ }
+
+/* The following values are for bookkeeping purposes only. They are */
+/* integer pointers which indicate the portion of the workspace */
+/* used by a particular array in SLASD7 and SLASD8. */
+
+ isigma = 1;
+ iw = isigma + n;
+ ivfw = iw + m;
+ ivlw = ivfw + m;
+
+ idx = 1;
+ idxc = idx + n;
+ idxp = idxc + n;
+
+/* Scale. */
+
+/* Computing MAX */
+ r__1 = dabs(*alpha), r__2 = dabs(*beta);
+ orgnrm = dmax(r__1,r__2);
+ d__[*nl + 1] = 0.f;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((r__1 = d__[i__], dabs(r__1)) > orgnrm) {
+ orgnrm = (r__1 = d__[i__], dabs(r__1));
+ }
+/* L10: */
+ }
+ slascl_("G", &c__0, &c__0, &orgnrm, &c_b7, &n, &c__1, &d__[1], &n, info);
+ *alpha /= orgnrm;
+ *beta /= orgnrm;
+
+/* Sort and Deflate singular values. */
+
+ slasd7_(icompq, nl, nr, sqre, k, &d__[1], &z__[1], &work[iw], &vf[1], &
+ work[ivfw], &vl[1], &work[ivlw], alpha, beta, &work[isigma], &
+ iwork[idx], &iwork[idxp], &idxq[1], &perm[1], givptr, &givcol[
+ givcol_offset], ldgcol, &givnum[givnum_offset], ldgnum, c__, s,
+ info);
+
+/* Solve Secular Equation, compute DIFL, DIFR, and update VF, VL. */
+
+ slasd8_(icompq, k, &d__[1], &z__[1], &vf[1], &vl[1], &difl[1], &difr[1],
+ ldgnum, &work[isigma], &work[iw], info);
+
+/* Save the poles if ICOMPQ = 1. */
+
+ if (*icompq == 1) {
+ scopy_(k, &d__[1], &c__1, &poles[poles_dim1 + 1], &c__1);
+ scopy_(k, &work[isigma], &c__1, &poles[(poles_dim1 << 1) + 1], &c__1);
+ }
+
+/* Unscale. */
+
+ slascl_("G", &c__0, &c__0, &c_b7, &orgnrm, &n, &c__1, &d__[1], &n, info);
+
+/* Prepare the IDXQ sorting permutation. */
+
+ n1 = *k;
+ n2 = n - *k;
+ slamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &idxq[1]);
+
+ return 0;
+
+/* End of SLASD6 */
+
+} /* slasd6_ */
diff --git a/SRC/slasd7.c b/SRC/slasd7.c
new file mode 100644
index 0000000..01a0542
--- /dev/null
+++ b/SRC/slasd7.c
@@ -0,0 +1,516 @@
+/* slasd7.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int slasd7_(integer *icompq, integer *nl, integer *nr,
+ integer *sqre, integer *k, real *d__, real *z__, real *zw, real *vf,
+ real *vfw, real *vl, real *vlw, real *alpha, real *beta, real *dsigma,
+ integer *idx, integer *idxp, integer *idxq, integer *perm, integer *
+ givptr, integer *givcol, integer *ldgcol, real *givnum, integer *
+ ldgnum, real *c__, real *s, integer *info)
+{
+ /* System generated locals */
+ integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer i__, j, m, n, k2;
+ real z1;
+ integer jp;
+ real eps, tau, tol;
+ integer nlp1, nlp2, idxi, idxj;
+ extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
+ integer *, real *, real *);
+ integer idxjp, jprev;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ extern doublereal slapy2_(real *, real *), slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), slamrg_(
+ integer *, integer *, real *, integer *, integer *, integer *);
+ real hlftol;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASD7 merges the two sets of singular values together into a single */
+/* sorted set. Then it tries to deflate the size of the problem. There */
+/* are two ways in which deflation can occur: when two or more singular */
+/* values are close together or if there is a tiny entry in the Z */
+/* vector. For each such occurrence the order of the related */
+/* secular equation problem is reduced by one. */
+
+/* SLASD7 is called from SLASD6. */
+
+/* Arguments */
+/* ========= */
+
+/* ICOMPQ (input) INTEGER */
+/* Specifies whether singular vectors are to be computed */
+/* in compact form, as follows: */
+/* = 0: Compute singular values only. */
+/* = 1: Compute singular vectors of upper */
+/* bidiagonal matrix in compact form. */
+
+/* NL (input) INTEGER */
+/* The row dimension of the upper block. NL >= 1. */
+
+/* NR (input) INTEGER */
+/* The row dimension of the lower block. NR >= 1. */
+
+/* SQRE (input) INTEGER */
+/* = 0: the lower block is an NR-by-NR square matrix. */
+/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */
+
+/* The bidiagonal matrix has */
+/* N = NL + NR + 1 rows and */
+/* M = N + SQRE >= N columns. */
+
+/* K (output) INTEGER */
+/* Contains the dimension of the non-deflated matrix, this is */
+/* the order of the related secular equation. 1 <= K <=N. */
+
+/* D (input/output) REAL array, dimension ( N ) */
+/* On entry D contains the singular values of the two submatrices */
+/* to be combined. On exit D contains the trailing (N-K) updated */
+/* singular values (those which were deflated) sorted into */
+/* increasing order. */
+
+/* Z (output) REAL array, dimension ( M ) */
+/* On exit Z contains the updating row vector in the secular */
+/* equation. */
+
+/* ZW (workspace) REAL array, dimension ( M ) */
+/* Workspace for Z. */
+
+/* VF (input/output) REAL array, dimension ( M ) */
+/* On entry, VF(1:NL+1) contains the first components of all */
+/* right singular vectors of the upper block; and VF(NL+2:M) */
+/* contains the first components of all right singular vectors */
+/* of the lower block. On exit, VF contains the first components */
+/* of all right singular vectors of the bidiagonal matrix. */
+
+/* VFW (workspace) REAL array, dimension ( M ) */
+/* Workspace for VF. */
+
+/* VL (input/output) REAL array, dimension ( M ) */
+/* On entry, VL(1:NL+1) contains the last components of all */
+/* right singular vectors of the upper block; and VL(NL+2:M) */
+/* contains the last components of all right singular vectors */
+/* of the lower block. On exit, VL contains the last components */
+/* of all right singular vectors of the bidiagonal matrix. */
+
+/* VLW (workspace) REAL array, dimension ( M ) */
+/* Workspace for VL. */
+
+/* ALPHA (input) REAL */
+/* Contains the diagonal element associated with the added row. */
+
+/* BETA (input) REAL */
+/* Contains the off-diagonal element associated with the added */
+/* row. */
+
+/* DSIGMA (output) REAL array, dimension ( N ) */
+/* Contains a copy of the diagonal elements (K-1 singular values */
+/* and one zero) in the secular equation. */
+
+/* IDX (workspace) INTEGER array, dimension ( N ) */
+/* This will contain the permutation used to sort the contents of */
+/* D into ascending order. */
+
+/* IDXP (workspace) INTEGER array, dimension ( N ) */
+/* This will contain the permutation used to place deflated */
+/* values of D at the end of the array. On output IDXP(2:K) */
+/* points to the nondeflated D-values and IDXP(K+1:N) */
+/* points to the deflated singular values. */
+
+/* IDXQ (input) INTEGER array, dimension ( N ) */
+/* This contains the permutation which separately sorts the two */
+/* sub-problems in D into ascending order. Note that entries in */
+/* the first half of this permutation must first be moved one */
+/* position backward; and entries in the second half */
+/* must first have NL+1 added to their values. */
+
+/* PERM (output) INTEGER array, dimension ( N ) */
+/* The permutations (from deflation and sorting) to be applied */
+/* to each singular block. Not referenced if ICOMPQ = 0. */
+
+/* GIVPTR (output) INTEGER */
+/* The number of Givens rotations which took place in this */
+/* subproblem. Not referenced if ICOMPQ = 0. */
+
+/* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 ) */
+/* Each pair of numbers indicates a pair of columns to take place */
+/* in a Givens rotation. Not referenced if ICOMPQ = 0. */
+
+/* LDGCOL (input) INTEGER */
+/* The leading dimension of GIVCOL, must be at least N. */
+
+/* GIVNUM (output) REAL array, dimension ( LDGNUM, 2 ) */
+/* Each number indicates the C or S value to be used in the */
+/* corresponding Givens rotation. Not referenced if ICOMPQ = 0. */
+
+/* LDGNUM (input) INTEGER */
+/* The leading dimension of GIVNUM, must be at least N. */
+
+/* C (output) REAL */
+/* C contains garbage if SQRE =0 and the C-value of a Givens */
+/* rotation related to the right null space if SQRE = 1. */
+
+/* S (output) REAL */
+/* S contains garbage if SQRE =0 and the S-value of a Givens */
+/* rotation related to the right null space if SQRE = 1. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --z__;
+ --zw;
+ --vf;
+ --vfw;
+ --vl;
+ --vlw;
+ --dsigma;
+ --idx;
+ --idxp;
+ --idxq;
+ --perm;
+ givcol_dim1 = *ldgcol;
+ givcol_offset = 1 + givcol_dim1;
+ givcol -= givcol_offset;
+ givnum_dim1 = *ldgnum;
+ givnum_offset = 1 + givnum_dim1;
+ givnum -= givnum_offset;
+
+ /* Function Body */
+ *info = 0;
+ n = *nl + *nr + 1;
+ m = n + *sqre;
+
+ if (*icompq < 0 || *icompq > 1) {
+ *info = -1;
+ } else if (*nl < 1) {
+ *info = -2;
+ } else if (*nr < 1) {
+ *info = -3;
+ } else if (*sqre < 0 || *sqre > 1) {
+ *info = -4;
+ } else if (*ldgcol < n) {
+ *info = -22;
+ } else if (*ldgnum < n) {
+ *info = -24;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLASD7", &i__1);
+ return 0;
+ }
+
+ nlp1 = *nl + 1;
+ nlp2 = *nl + 2;
+ if (*icompq == 1) {
+ *givptr = 0;
+ }
+
+/* Generate the first part of the vector Z and move the singular */
+/* values in the first part of D one position backward. */
+
+ z1 = *alpha * vl[nlp1];
+ vl[nlp1] = 0.f;
+ tau = vf[nlp1];
+ for (i__ = *nl; i__ >= 1; --i__) {
+ z__[i__ + 1] = *alpha * vl[i__];
+ vl[i__] = 0.f;
+ vf[i__ + 1] = vf[i__];
+ d__[i__ + 1] = d__[i__];
+ idxq[i__ + 1] = idxq[i__] + 1;
+/* L10: */
+ }
+ vf[1] = tau;
+
+/* Generate the second part of the vector Z. */
+
+ i__1 = m;
+ for (i__ = nlp2; i__ <= i__1; ++i__) {
+ z__[i__] = *beta * vf[i__];
+ vf[i__] = 0.f;
+/* L20: */
+ }
+
+/* Sort the singular values into increasing order */
+
+ i__1 = n;
+ for (i__ = nlp2; i__ <= i__1; ++i__) {
+ idxq[i__] += nlp1;
+/* L30: */
+ }
+
+/* DSIGMA, IDXC, IDXC, and ZW are used as storage space. */
+
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ dsigma[i__] = d__[idxq[i__]];
+ zw[i__] = z__[idxq[i__]];
+ vfw[i__] = vf[idxq[i__]];
+ vlw[i__] = vl[idxq[i__]];
+/* L40: */
+ }
+
+ slamrg_(nl, nr, &dsigma[2], &c__1, &c__1, &idx[2]);
+
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ idxi = idx[i__] + 1;
+ d__[i__] = dsigma[idxi];
+ z__[i__] = zw[idxi];
+ vf[i__] = vfw[idxi];
+ vl[i__] = vlw[idxi];
+/* L50: */
+ }
+
+/* Calculate the allowable deflation tolerence */
+
+ eps = slamch_("Epsilon");
+/* Computing MAX */
+ r__1 = dabs(*alpha), r__2 = dabs(*beta);
+ tol = dmax(r__1,r__2);
+/* Computing MAX */
+ r__2 = (r__1 = d__[n], dabs(r__1));
+ tol = eps * 64.f * dmax(r__2,tol);
+
+/* There are 2 kinds of deflation -- first a value in the z-vector */
+/* is small, second two (or more) singular values are very close */
+/* together (their difference is small). */
+
+/* If the value in the z-vector is small, we simply permute the */
+/* array so that the corresponding singular value is moved to the */
+/* end. */
+
+/* If two values in the D-vector are close, we perform a two-sided */
+/* rotation designed to make one of the corresponding z-vector */
+/* entries zero, and then permute the array so that the deflated */
+/* singular value is moved to the end. */
+
+/* If there are multiple singular values then the problem deflates. */
+/* Here the number of equal singular values are found. As each equal */
+/* singular value is found, an elementary reflector is computed to */
+/* rotate the corresponding singular subspace so that the */
+/* corresponding components of Z are zero in this new basis. */
+
+ *k = 1;
+ k2 = n + 1;
+ i__1 = n;
+ for (j = 2; j <= i__1; ++j) {
+ if ((r__1 = z__[j], dabs(r__1)) <= tol) {
+
+/* Deflate due to small z component. */
+
+ --k2;
+ idxp[k2] = j;
+ if (j == n) {
+ goto L100;
+ }
+ } else {
+ jprev = j;
+ goto L70;
+ }
+/* L60: */
+ }
+L70:
+ j = jprev;
+L80:
+ ++j;
+ if (j > n) {
+ goto L90;
+ }
+ if ((r__1 = z__[j], dabs(r__1)) <= tol) {
+
+/* Deflate due to small z component. */
+
+ --k2;
+ idxp[k2] = j;
+ } else {
+
+/* Check if singular values are close enough to allow deflation. */
+
+ if ((r__1 = d__[j] - d__[jprev], dabs(r__1)) <= tol) {
+
+/* Deflation is possible. */
+
+ *s = z__[jprev];
+ *c__ = z__[j];
+
+/* Find sqrt(a**2+b**2) without overflow or */
+/* destructive underflow. */
+
+ tau = slapy2_(c__, s);
+ z__[j] = tau;
+ z__[jprev] = 0.f;
+ *c__ /= tau;
+ *s = -(*s) / tau;
+
+/* Record the appropriate Givens rotation */
+
+ if (*icompq == 1) {
+ ++(*givptr);
+ idxjp = idxq[idx[jprev] + 1];
+ idxj = idxq[idx[j] + 1];
+ if (idxjp <= nlp1) {
+ --idxjp;
+ }
+ if (idxj <= nlp1) {
+ --idxj;
+ }
+ givcol[*givptr + (givcol_dim1 << 1)] = idxjp;
+ givcol[*givptr + givcol_dim1] = idxj;
+ givnum[*givptr + (givnum_dim1 << 1)] = *c__;
+ givnum[*givptr + givnum_dim1] = *s;
+ }
+ srot_(&c__1, &vf[jprev], &c__1, &vf[j], &c__1, c__, s);
+ srot_(&c__1, &vl[jprev], &c__1, &vl[j], &c__1, c__, s);
+ --k2;
+ idxp[k2] = jprev;
+ jprev = j;
+ } else {
+ ++(*k);
+ zw[*k] = z__[jprev];
+ dsigma[*k] = d__[jprev];
+ idxp[*k] = jprev;
+ jprev = j;
+ }
+ }
+ goto L80;
+L90:
+
+/* Record the last singular value. */
+
+ ++(*k);
+ zw[*k] = z__[jprev];
+ dsigma[*k] = d__[jprev];
+ idxp[*k] = jprev;
+
+L100:
+
+/* Sort the singular values into DSIGMA. The singular values which */
+/* were not deflated go into the first K slots of DSIGMA, except */
+/* that DSIGMA(1) is treated separately. */
+
+ i__1 = n;
+ for (j = 2; j <= i__1; ++j) {
+ jp = idxp[j];
+ dsigma[j] = d__[jp];
+ vfw[j] = vf[jp];
+ vlw[j] = vl[jp];
+/* L110: */
+ }
+ if (*icompq == 1) {
+ i__1 = n;
+ for (j = 2; j <= i__1; ++j) {
+ jp = idxp[j];
+ perm[j] = idxq[idx[jp] + 1];
+ if (perm[j] <= nlp1) {
+ --perm[j];
+ }
+/* L120: */
+ }
+ }
+
+/* The deflated singular values go back into the last N - K slots of */
+/* D. */
+
+ i__1 = n - *k;
+ scopy_(&i__1, &dsigma[*k + 1], &c__1, &d__[*k + 1], &c__1);
+
+/* Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and */
+/* VL(M). */
+
+ dsigma[1] = 0.f;
+ hlftol = tol / 2.f;
+ if (dabs(dsigma[2]) <= hlftol) {
+ dsigma[2] = hlftol;
+ }
+ if (m > n) {
+ z__[1] = slapy2_(&z1, &z__[m]);
+ if (z__[1] <= tol) {
+ *c__ = 1.f;
+ *s = 0.f;
+ z__[1] = tol;
+ } else {
+ *c__ = z1 / z__[1];
+ *s = -z__[m] / z__[1];
+ }
+ srot_(&c__1, &vf[m], &c__1, &vf[1], &c__1, c__, s);
+ srot_(&c__1, &vl[m], &c__1, &vl[1], &c__1, c__, s);
+ } else {
+ if (dabs(z1) <= tol) {
+ z__[1] = tol;
+ } else {
+ z__[1] = z1;
+ }
+ }
+
+/* Restore Z, VF, and VL. */
+
+ i__1 = *k - 1;
+ scopy_(&i__1, &zw[2], &c__1, &z__[2], &c__1);
+ i__1 = n - 1;
+ scopy_(&i__1, &vfw[2], &c__1, &vf[2], &c__1);
+ i__1 = n - 1;
+ scopy_(&i__1, &vlw[2], &c__1, &vl[2], &c__1);
+
+ return 0;
+
+/* End of SLASD7 */
+
+} /* slasd7_ */
diff --git a/SRC/slasd8.c b/SRC/slasd8.c
new file mode 100644
index 0000000..b0079d5
--- /dev/null
+++ b/SRC/slasd8.c
@@ -0,0 +1,323 @@
+/* slasd8.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static real c_b8 = 1.f;
+
+/* Subroutine */ int slasd8_(integer *icompq, integer *k, real *d__, real *
+ z__, real *vf, real *vl, real *difl, real *difr, integer *lddifr,
+ real *dsigma, real *work, integer *info)
+{
+ /* System generated locals */
+ integer difr_dim1, difr_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_sign(real *, real *);
+
+ /* Local variables */
+ integer i__, j;
+ real dj, rho;
+ integer iwk1, iwk2, iwk3;
+ real temp;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ integer iwk2i, iwk3i;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ real diflj, difrj, dsigj;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ extern doublereal slamc3_(real *, real *);
+ extern /* Subroutine */ int slasd4_(integer *, integer *, real *, real *,
+ real *, real *, real *, real *, integer *), xerbla_(char *,
+ integer *);
+ real dsigjp;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *), slaset_(char *, integer *, integer *, real *, real *,
+ real *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* October 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASD8 finds the square roots of the roots of the secular equation, */
+/* as defined by the values in DSIGMA and Z. It makes the appropriate */
+/* calls to SLASD4, and stores, for each element in D, the distance */
+/* to its two nearest poles (elements in DSIGMA). It also updates */
+/* the arrays VF and VL, the first and last components of all the */
+/* right singular vectors of the original bidiagonal matrix. */
+
+/* SLASD8 is called from SLASD6. */
+
+/* Arguments */
+/* ========= */
+
+/* ICOMPQ (input) INTEGER */
+/* Specifies whether singular vectors are to be computed in */
+/* factored form in the calling routine: */
+/* = 0: Compute singular values only. */
+/* = 1: Compute singular vectors in factored form as well. */
+
+/* K (input) INTEGER */
+/* The number of terms in the rational function to be solved */
+/* by SLASD4. K >= 1. */
+
+/* D (output) REAL array, dimension ( K ) */
+/* On output, D contains the updated singular values. */
+
+/* Z (input/output) REAL array, dimension ( K ) */
+/* On entry, the first K elements of this array contain the */
+/* components of the deflation-adjusted updating row vector. */
+/* On exit, Z is updated. */
+
+/* VF (input/output) REAL array, dimension ( K ) */
+/* On entry, VF contains information passed through DBEDE8. */
+/* On exit, VF contains the first K components of the first */
+/* components of all right singular vectors of the bidiagonal */
+/* matrix. */
+
+/* VL (input/output) REAL array, dimension ( K ) */
+/* On entry, VL contains information passed through DBEDE8. */
+/* On exit, VL contains the first K components of the last */
+/* components of all right singular vectors of the bidiagonal */
+/* matrix. */
+
+/* DIFL (output) REAL array, dimension ( K ) */
+/* On exit, DIFL(I) = D(I) - DSIGMA(I). */
+
+/* DIFR (output) REAL array, */
+/* dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and */
+/* dimension ( K ) if ICOMPQ = 0. */
+/* On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not */
+/* defined and will not be referenced. */
+
+/* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the */
+/* normalizing factors for the right singular vector matrix. */
+
+/* LDDIFR (input) INTEGER */
+/* The leading dimension of DIFR, must be at least K. */
+
+/* DSIGMA (input/output) REAL array, dimension ( K ) */
+/* On entry, the first K elements of this array contain the old */
+/* roots of the deflated updating problem. These are the poles */
+/* of the secular equation. */
+/* On exit, the elements of DSIGMA may be very slightly altered */
+/* in value. */
+
+/* WORK (workspace) REAL array, dimension at least 3 * K */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, an singular value did not converge */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --z__;
+ --vf;
+ --vl;
+ --difl;
+ difr_dim1 = *lddifr;
+ difr_offset = 1 + difr_dim1;
+ difr -= difr_offset;
+ --dsigma;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*icompq < 0 || *icompq > 1) {
+ *info = -1;
+ } else if (*k < 1) {
+ *info = -2;
+ } else if (*lddifr < *k) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLASD8", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*k == 1) {
+ d__[1] = dabs(z__[1]);
+ difl[1] = d__[1];
+ if (*icompq == 1) {
+ difl[2] = 1.f;
+ difr[(difr_dim1 << 1) + 1] = 1.f;
+ }
+ return 0;
+ }
+
+/* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can */
+/* be computed with high relative accuracy (barring over/underflow). */
+/* This is a problem on machines without a guard digit in */
+/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */
+/* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), */
+/* which on any of these machines zeros out the bottommost */
+/* bit of DSIGMA(I) if it is 1; this makes the subsequent */
+/* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation */
+/* occurs. On binary machines with a guard digit (almost all */
+/* machines) it does not change DSIGMA(I) at all. On hexadecimal */
+/* and decimal machines with a guard digit, it slightly */
+/* changes the bottommost bits of DSIGMA(I). It does not account */
+/* for hexadecimal or decimal machines without guard digits */
+/* (we know of none). We use a subroutine call to compute */
+/* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating */
+/* this code. */
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dsigma[i__] = slamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__];
+/* L10: */
+ }
+
+/* Book keeping. */
+
+ iwk1 = 1;
+ iwk2 = iwk1 + *k;
+ iwk3 = iwk2 + *k;
+ iwk2i = iwk2 - 1;
+ iwk3i = iwk3 - 1;
+
+/* Normalize Z. */
+
+ rho = snrm2_(k, &z__[1], &c__1);
+ slascl_("G", &c__0, &c__0, &rho, &c_b8, k, &c__1, &z__[1], k, info);
+ rho *= rho;
+
+/* Initialize WORK(IWK3). */
+
+ slaset_("A", k, &c__1, &c_b8, &c_b8, &work[iwk3], k);
+
+/* Compute the updated singular values, the arrays DIFL, DIFR, */
+/* and the updated Z. */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ slasd4_(k, &j, &dsigma[1], &z__[1], &work[iwk1], &rho, &d__[j], &work[
+ iwk2], info);
+
+/* If the root finder fails, the computation is terminated. */
+
+ if (*info != 0) {
+ return 0;
+ }
+ work[iwk3i + j] = work[iwk3i + j] * work[j] * work[iwk2i + j];
+ difl[j] = -work[j];
+ difr[j + difr_dim1] = -work[j + 1];
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i +
+ i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[
+ j]);
+/* L20: */
+ }
+ i__2 = *k;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i +
+ i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[
+ j]);
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Compute updated Z. */
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__2 = sqrt((r__1 = work[iwk3i + i__], dabs(r__1)));
+ z__[i__] = r_sign(&r__2, &z__[i__]);
+/* L50: */
+ }
+
+/* Update VF and VL. */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ diflj = difl[j];
+ dj = d__[j];
+ dsigj = -dsigma[j];
+ if (j < *k) {
+ difrj = -difr[j + difr_dim1];
+ dsigjp = -dsigma[j + 1];
+ }
+ work[j] = -z__[j] / diflj / (dsigma[j] + dj);
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] = z__[i__] / (slamc3_(&dsigma[i__], &dsigj) - diflj) / (
+ dsigma[i__] + dj);
+/* L60: */
+ }
+ i__2 = *k;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ work[i__] = z__[i__] / (slamc3_(&dsigma[i__], &dsigjp) + difrj) /
+ (dsigma[i__] + dj);
+/* L70: */
+ }
+ temp = snrm2_(k, &work[1], &c__1);
+ work[iwk2i + j] = sdot_(k, &work[1], &c__1, &vf[1], &c__1) / temp;
+ work[iwk3i + j] = sdot_(k, &work[1], &c__1, &vl[1], &c__1) / temp;
+ if (*icompq == 1) {
+ difr[j + (difr_dim1 << 1)] = temp;
+ }
+/* L80: */
+ }
+
+ scopy_(k, &work[iwk2], &c__1, &vf[1], &c__1);
+ scopy_(k, &work[iwk3], &c__1, &vl[1], &c__1);
+
+ return 0;
+
+/* End of SLASD8 */
+
+} /* slasd8_ */
diff --git a/SRC/slasda.c b/SRC/slasda.c
new file mode 100644
index 0000000..694a4e2
--- /dev/null
+++ b/SRC/slasda.c
@@ -0,0 +1,483 @@
+/* slasda.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static real c_b11 = 0.f;
+static real c_b12 = 1.f;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int slasda_(integer *icompq, integer *smlsiz, integer *n,
+ integer *sqre, real *d__, real *e, real *u, integer *ldu, real *vt,
+ integer *k, real *difl, real *difr, real *z__, real *poles, integer *
+ givptr, integer *givcol, integer *ldgcol, integer *perm, real *givnum,
+ real *c__, real *s, real *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, difl_dim1,
+ difl_offset, difr_dim1, difr_offset, givnum_dim1, givnum_offset,
+ poles_dim1, poles_offset, u_dim1, u_offset, vt_dim1, vt_offset,
+ z_dim1, z_offset, i__1, i__2;
+
+ /* Builtin functions */
+ integer pow_ii(integer *, integer *);
+
+ /* Local variables */
+ integer i__, j, m, i1, ic, lf, nd, ll, nl, vf, nr, vl, im1, ncc, nlf, nrf,
+ vfi, iwk, vli, lvl, nru, ndb1, nlp1, lvl2, nrp1;
+ real beta;
+ integer idxq, nlvl;
+ real alpha;
+ integer inode, ndiml, ndimr, idxqi, itemp, sqrei;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), slasd6_(integer *, integer *, integer *, integer *,
+ real *, real *, real *, real *, real *, integer *, integer *,
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, real *, real *, integer *, real *, real *, real *, integer *,
+ integer *);
+ integer nwork1, nwork2;
+ extern /* Subroutine */ int xerbla_(char *, integer *), slasdq_(
+ char *, integer *, integer *, integer *, integer *, integer *,
+ real *, real *, real *, integer *, real *, integer *, real *,
+ integer *, real *, integer *), slasdt_(integer *, integer
+ *, integer *, integer *, integer *, integer *, integer *),
+ slaset_(char *, integer *, integer *, real *, real *, real *,
+ integer *);
+ integer smlszp;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Using a divide and conquer approach, SLASDA computes the singular */
+/* value decomposition (SVD) of a real upper bidiagonal N-by-M matrix */
+/* B with diagonal D and offdiagonal E, where M = N + SQRE. The */
+/* algorithm computes the singular values in the SVD B = U * S * VT. */
+/* The orthogonal matrices U and VT are optionally computed in */
+/* compact form. */
+
+/* A related subroutine, SLASD0, computes the singular values and */
+/* the singular vectors in explicit form. */
+
+/* Arguments */
+/* ========= */
+
+/* ICOMPQ (input) INTEGER */
+/* Specifies whether singular vectors are to be computed */
+/* in compact form, as follows */
+/* = 0: Compute singular values only. */
+/* = 1: Compute singular vectors of upper bidiagonal */
+/* matrix in compact form. */
+
+/* SMLSIZ (input) INTEGER */
+/* The maximum size of the subproblems at the bottom of the */
+/* computation tree. */
+
+/* N (input) INTEGER */
+/* The row dimension of the upper bidiagonal matrix. This is */
+/* also the dimension of the main diagonal array D. */
+
+/* SQRE (input) INTEGER */
+/* Specifies the column dimension of the bidiagonal matrix. */
+/* = 0: The bidiagonal matrix has column dimension M = N; */
+/* = 1: The bidiagonal matrix has column dimension M = N + 1. */
+
+/* D (input/output) REAL array, dimension ( N ) */
+/* On entry D contains the main diagonal of the bidiagonal */
+/* matrix. On exit D, if INFO = 0, contains its singular values. */
+
+/* E (input) REAL array, dimension ( M-1 ) */
+/* Contains the subdiagonal entries of the bidiagonal matrix. */
+/* On exit, E has been destroyed. */
+
+/* U (output) REAL array, */
+/* dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced */
+/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left */
+/* singular vector matrices of all subproblems at the bottom */
+/* level. */
+
+/* LDU (input) INTEGER, LDU = > N. */
+/* The leading dimension of arrays U, VT, DIFL, DIFR, POLES, */
+/* GIVNUM, and Z. */
+
+/* VT (output) REAL array, */
+/* dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced */
+/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right */
+/* singular vector matrices of all subproblems at the bottom */
+/* level. */
+
+/* K (output) INTEGER array, dimension ( N ) */
+/* if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0. */
+/* If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th */
+/* secular equation on the computation tree. */
+
+/* DIFL (output) REAL array, dimension ( LDU, NLVL ), */
+/* where NLVL = floor(log_2 (N/SMLSIZ))). */
+
+/* DIFR (output) REAL array, */
+/* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and */
+/* dimension ( N ) if ICOMPQ = 0. */
+/* If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1) */
+/* record distances between singular values on the I-th */
+/* level and singular values on the (I -1)-th level, and */
+/* DIFR(1:N, 2 * I ) contains the normalizing factors for */
+/* the right singular vector matrix. See SLASD8 for details. */
+
+/* Z (output) REAL array, */
+/* dimension ( LDU, NLVL ) if ICOMPQ = 1 and */
+/* dimension ( N ) if ICOMPQ = 0. */
+/* The first K elements of Z(1, I) contain the components of */
+/* the deflation-adjusted updating row vector for subproblems */
+/* on the I-th level. */
+
+/* POLES (output) REAL array, */
+/* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced */
+/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and */
+/* POLES(1, 2*I) contain the new and old singular values */
+/* involved in the secular equations on the I-th level. */
+
+/* GIVPTR (output) INTEGER array, */
+/* dimension ( N ) if ICOMPQ = 1, and not referenced if */
+/* ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records */
+/* the number of Givens rotations performed on the I-th */
+/* problem on the computation tree. */
+
+/* GIVCOL (output) INTEGER array, */
+/* dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not */
+/* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, */
+/* GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations */
+/* of Givens rotations performed on the I-th level on the */
+/* computation tree. */
+
+/* LDGCOL (input) INTEGER, LDGCOL = > N. */
+/* The leading dimension of arrays GIVCOL and PERM. */
+
+/* PERM (output) INTEGER array, dimension ( LDGCOL, NLVL ) */
+/* if ICOMPQ = 1, and not referenced */
+/* if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records */
+/* permutations done on the I-th level of the computation tree. */
+
+/* GIVNUM (output) REAL array, */
+/* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not */
+/* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, */
+/* GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S- */
+/* values of Givens rotations performed on the I-th level on */
+/* the computation tree. */
+
+/* C (output) REAL array, */
+/* dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. */
+/* If ICOMPQ = 1 and the I-th subproblem is not square, on exit, */
+/* C( I ) contains the C-value of a Givens rotation related to */
+/* the right null space of the I-th subproblem. */
+
+/* S (output) REAL array, dimension ( N ) if */
+/* ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1 */
+/* and the I-th subproblem is not square, on exit, S( I ) */
+/* contains the S-value of a Givens rotation related to */
+/* the right null space of the I-th subproblem. */
+
+/* WORK (workspace) REAL array, dimension */
+/* (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)). */
+
+/* IWORK (workspace) INTEGER array, dimension (7*N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, an singular value did not converge */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ givnum_dim1 = *ldu;
+ givnum_offset = 1 + givnum_dim1;
+ givnum -= givnum_offset;
+ poles_dim1 = *ldu;
+ poles_offset = 1 + poles_dim1;
+ poles -= poles_offset;
+ z_dim1 = *ldu;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ difr_dim1 = *ldu;
+ difr_offset = 1 + difr_dim1;
+ difr -= difr_offset;
+ difl_dim1 = *ldu;
+ difl_offset = 1 + difl_dim1;
+ difl -= difl_offset;
+ vt_dim1 = *ldu;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --k;
+ --givptr;
+ perm_dim1 = *ldgcol;
+ perm_offset = 1 + perm_dim1;
+ perm -= perm_offset;
+ givcol_dim1 = *ldgcol;
+ givcol_offset = 1 + givcol_dim1;
+ givcol -= givcol_offset;
+ --c__;
+ --s;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*icompq < 0 || *icompq > 1) {
+ *info = -1;
+ } else if (*smlsiz < 3) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*sqre < 0 || *sqre > 1) {
+ *info = -4;
+ } else if (*ldu < *n + *sqre) {
+ *info = -8;
+ } else if (*ldgcol < *n) {
+ *info = -17;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLASDA", &i__1);
+ return 0;
+ }
+
+ m = *n + *sqre;
+
+/* If the input matrix is too small, call SLASDQ to find the SVD. */
+
+ if (*n <= *smlsiz) {
+ if (*icompq == 0) {
+ slasdq_("U", sqre, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[
+ vt_offset], ldu, &u[u_offset], ldu, &u[u_offset], ldu, &
+ work[1], info);
+ } else {
+ slasdq_("U", sqre, n, &m, n, &c__0, &d__[1], &e[1], &vt[vt_offset]
+, ldu, &u[u_offset], ldu, &u[u_offset], ldu, &work[1],
+ info);
+ }
+ return 0;
+ }
+
+/* Book-keeping and set up the computation tree. */
+
+ inode = 1;
+ ndiml = inode + *n;
+ ndimr = ndiml + *n;
+ idxq = ndimr + *n;
+ iwk = idxq + *n;
+
+ ncc = 0;
+ nru = 0;
+
+ smlszp = *smlsiz + 1;
+ vf = 1;
+ vl = vf + m;
+ nwork1 = vl + m;
+ nwork2 = nwork1 + smlszp * smlszp;
+
+ slasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr],
+ smlsiz);
+
+/* for the nodes on bottom level of the tree, solve */
+/* their subproblems by SLASDQ. */
+
+ ndb1 = (nd + 1) / 2;
+ i__1 = nd;
+ for (i__ = ndb1; i__ <= i__1; ++i__) {
+
+/* IC : center row of each node */
+/* NL : number of rows of left subproblem */
+/* NR : number of rows of right subproblem */
+/* NLF: starting row of the left subproblem */
+/* NRF: starting row of the right subproblem */
+
+ i1 = i__ - 1;
+ ic = iwork[inode + i1];
+ nl = iwork[ndiml + i1];
+ nlp1 = nl + 1;
+ nr = iwork[ndimr + i1];
+ nlf = ic - nl;
+ nrf = ic + 1;
+ idxqi = idxq + nlf - 2;
+ vfi = vf + nlf - 1;
+ vli = vl + nlf - 1;
+ sqrei = 1;
+ if (*icompq == 0) {
+ slaset_("A", &nlp1, &nlp1, &c_b11, &c_b12, &work[nwork1], &smlszp);
+ slasdq_("U", &sqrei, &nl, &nlp1, &nru, &ncc, &d__[nlf], &e[nlf], &
+ work[nwork1], &smlszp, &work[nwork2], &nl, &work[nwork2],
+ &nl, &work[nwork2], info);
+ itemp = nwork1 + nl * smlszp;
+ scopy_(&nlp1, &work[nwork1], &c__1, &work[vfi], &c__1);
+ scopy_(&nlp1, &work[itemp], &c__1, &work[vli], &c__1);
+ } else {
+ slaset_("A", &nl, &nl, &c_b11, &c_b12, &u[nlf + u_dim1], ldu);
+ slaset_("A", &nlp1, &nlp1, &c_b11, &c_b12, &vt[nlf + vt_dim1],
+ ldu);
+ slasdq_("U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], &
+ vt[nlf + vt_dim1], ldu, &u[nlf + u_dim1], ldu, &u[nlf +
+ u_dim1], ldu, &work[nwork1], info);
+ scopy_(&nlp1, &vt[nlf + vt_dim1], &c__1, &work[vfi], &c__1);
+ scopy_(&nlp1, &vt[nlf + nlp1 * vt_dim1], &c__1, &work[vli], &c__1)
+ ;
+ }
+ if (*info != 0) {
+ return 0;
+ }
+ i__2 = nl;
+ for (j = 1; j <= i__2; ++j) {
+ iwork[idxqi + j] = j;
+/* L10: */
+ }
+ if (i__ == nd && *sqre == 0) {
+ sqrei = 0;
+ } else {
+ sqrei = 1;
+ }
+ idxqi += nlp1;
+ vfi += nlp1;
+ vli += nlp1;
+ nrp1 = nr + sqrei;
+ if (*icompq == 0) {
+ slaset_("A", &nrp1, &nrp1, &c_b11, &c_b12, &work[nwork1], &smlszp);
+ slasdq_("U", &sqrei, &nr, &nrp1, &nru, &ncc, &d__[nrf], &e[nrf], &
+ work[nwork1], &smlszp, &work[nwork2], &nr, &work[nwork2],
+ &nr, &work[nwork2], info);
+ itemp = nwork1 + (nrp1 - 1) * smlszp;
+ scopy_(&nrp1, &work[nwork1], &c__1, &work[vfi], &c__1);
+ scopy_(&nrp1, &work[itemp], &c__1, &work[vli], &c__1);
+ } else {
+ slaset_("A", &nr, &nr, &c_b11, &c_b12, &u[nrf + u_dim1], ldu);
+ slaset_("A", &nrp1, &nrp1, &c_b11, &c_b12, &vt[nrf + vt_dim1],
+ ldu);
+ slasdq_("U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], &
+ vt[nrf + vt_dim1], ldu, &u[nrf + u_dim1], ldu, &u[nrf +
+ u_dim1], ldu, &work[nwork1], info);
+ scopy_(&nrp1, &vt[nrf + vt_dim1], &c__1, &work[vfi], &c__1);
+ scopy_(&nrp1, &vt[nrf + nrp1 * vt_dim1], &c__1, &work[vli], &c__1)
+ ;
+ }
+ if (*info != 0) {
+ return 0;
+ }
+ i__2 = nr;
+ for (j = 1; j <= i__2; ++j) {
+ iwork[idxqi + j] = j;
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* Now conquer each subproblem bottom-up. */
+
+ j = pow_ii(&c__2, &nlvl);
+ for (lvl = nlvl; lvl >= 1; --lvl) {
+ lvl2 = (lvl << 1) - 1;
+
+/* Find the first node LF and last node LL on */
+/* the current level LVL. */
+
+ if (lvl == 1) {
+ lf = 1;
+ ll = 1;
+ } else {
+ i__1 = lvl - 1;
+ lf = pow_ii(&c__2, &i__1);
+ ll = (lf << 1) - 1;
+ }
+ i__1 = ll;
+ for (i__ = lf; i__ <= i__1; ++i__) {
+ im1 = i__ - 1;
+ ic = iwork[inode + im1];
+ nl = iwork[ndiml + im1];
+ nr = iwork[ndimr + im1];
+ nlf = ic - nl;
+ nrf = ic + 1;
+ if (i__ == ll) {
+ sqrei = *sqre;
+ } else {
+ sqrei = 1;
+ }
+ vfi = vf + nlf - 1;
+ vli = vl + nlf - 1;
+ idxqi = idxq + nlf - 1;
+ alpha = d__[ic];
+ beta = e[ic];
+ if (*icompq == 0) {
+ slasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], &
+ work[vli], &alpha, &beta, &iwork[idxqi], &perm[
+ perm_offset], &givptr[1], &givcol[givcol_offset],
+ ldgcol, &givnum[givnum_offset], ldu, &poles[
+ poles_offset], &difl[difl_offset], &difr[difr_offset],
+ &z__[z_offset], &k[1], &c__[1], &s[1], &work[nwork1],
+ &iwork[iwk], info);
+ } else {
+ --j;
+ slasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], &
+ work[vli], &alpha, &beta, &iwork[idxqi], &perm[nlf +
+ lvl * perm_dim1], &givptr[j], &givcol[nlf + lvl2 *
+ givcol_dim1], ldgcol, &givnum[nlf + lvl2 *
+ givnum_dim1], ldu, &poles[nlf + lvl2 * poles_dim1], &
+ difl[nlf + lvl * difl_dim1], &difr[nlf + lvl2 *
+ difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[j],
+ &s[j], &work[nwork1], &iwork[iwk], info);
+ }
+ if (*info != 0) {
+ return 0;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+
+ return 0;
+
+/* End of SLASDA */
+
+} /* slasda_ */
diff --git a/SRC/slasdq.c b/SRC/slasdq.c
new file mode 100644
index 0000000..fae6a16
--- /dev/null
+++ b/SRC/slasdq.c
@@ -0,0 +1,379 @@
+/* slasdq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int slasdq_(char *uplo, integer *sqre, integer *n, integer *
+ ncvt, integer *nru, integer *ncc, real *d__, real *e, real *vt,
+ integer *ldvt, real *u, integer *ldu, real *c__, integer *ldc, real *
+ work, integer *info)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
+ i__2;
+
+ /* Local variables */
+ integer i__, j;
+ real r__, cs, sn;
+ integer np1, isub;
+ real smin;
+ integer sqre1;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int slasr_(char *, char *, char *, integer *,
+ integer *, real *, real *, real *, integer *);
+ integer iuplo;
+ extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
+ integer *), xerbla_(char *, integer *), slartg_(real *,
+ real *, real *, real *, real *);
+ logical rotate;
+ extern /* Subroutine */ int sbdsqr_(char *, integer *, integer *, integer
+ *, integer *, real *, real *, real *, integer *, real *, integer *
+, real *, integer *, real *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASDQ computes the singular value decomposition (SVD) of a real */
+/* (upper or lower) bidiagonal matrix with diagonal D and offdiagonal */
+/* E, accumulating the transformations if desired. Letting B denote */
+/* the input bidiagonal matrix, the algorithm computes orthogonal */
+/* matrices Q and P such that B = Q * S * P' (P' denotes the transpose */
+/* of P). The singular values S are overwritten on D. */
+
+/* The input matrix U is changed to U * Q if desired. */
+/* The input matrix VT is changed to P' * VT if desired. */
+/* The input matrix C is changed to Q' * C if desired. */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices With */
+/* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, */
+/* LAPACK Working Note #3, for a detailed description of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* On entry, UPLO specifies whether the input bidiagonal matrix */
+/* is upper or lower bidiagonal, and wether it is square are */
+/* not. */
+/* UPLO = 'U' or 'u' B is upper bidiagonal. */
+/* UPLO = 'L' or 'l' B is lower bidiagonal. */
+
+/* SQRE (input) INTEGER */
+/* = 0: then the input matrix is N-by-N. */
+/* = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and */
+/* (N+1)-by-N if UPLU = 'L'. */
+
+/* The bidiagonal matrix has */
+/* N = NL + NR + 1 rows and */
+/* M = N + SQRE >= N columns. */
+
+/* N (input) INTEGER */
+/* On entry, N specifies the number of rows and columns */
+/* in the matrix. N must be at least 0. */
+
+/* NCVT (input) INTEGER */
+/* On entry, NCVT specifies the number of columns of */
+/* the matrix VT. NCVT must be at least 0. */
+
+/* NRU (input) INTEGER */
+/* On entry, NRU specifies the number of rows of */
+/* the matrix U. NRU must be at least 0. */
+
+/* NCC (input) INTEGER */
+/* On entry, NCC specifies the number of columns of */
+/* the matrix C. NCC must be at least 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, D contains the diagonal entries of the */
+/* bidiagonal matrix whose SVD is desired. On normal exit, */
+/* D contains the singular values in ascending order. */
+
+/* E (input/output) REAL array. */
+/* dimension is (N-1) if SQRE = 0 and N if SQRE = 1. */
+/* On entry, the entries of E contain the offdiagonal entries */
+/* of the bidiagonal matrix whose SVD is desired. On normal */
+/* exit, E will contain 0. If the algorithm does not converge, */
+/* D and E will contain the diagonal and superdiagonal entries */
+/* of a bidiagonal matrix orthogonally equivalent to the one */
+/* given as input. */
+
+/* VT (input/output) REAL array, dimension (LDVT, NCVT) */
+/* On entry, contains a matrix which on exit has been */
+/* premultiplied by P', dimension N-by-NCVT if SQRE = 0 */
+/* and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0). */
+
+/* LDVT (input) INTEGER */
+/* On entry, LDVT specifies the leading dimension of VT as */
+/* declared in the calling (sub) program. LDVT must be at */
+/* least 1. If NCVT is nonzero LDVT must also be at least N. */
+
+/* U (input/output) REAL array, dimension (LDU, N) */
+/* On entry, contains a matrix which on exit has been */
+/* postmultiplied by Q, dimension NRU-by-N if SQRE = 0 */
+/* and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0). */
+
+/* LDU (input) INTEGER */
+/* On entry, LDU specifies the leading dimension of U as */
+/* declared in the calling (sub) program. LDU must be at */
+/* least max( 1, NRU ) . */
+
+/* C (input/output) REAL array, dimension (LDC, NCC) */
+/* On entry, contains an N-by-NCC matrix which on exit */
+/* has been premultiplied by Q' dimension N-by-NCC if SQRE = 0 */
+/* and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0). */
+
+/* LDC (input) INTEGER */
+/* On entry, LDC specifies the leading dimension of C as */
+/* declared in the calling (sub) program. LDC must be at */
+/* least 1. If NCC is nonzero, LDC must also be at least N. */
+
+/* WORK (workspace) REAL array, dimension (4*N) */
+/* Workspace. Only referenced if one of NCVT, NRU, or NCC is */
+/* nonzero, and if N is at least 2. */
+
+/* INFO (output) INTEGER */
+/* On exit, a value of 0 indicates a successful exit. */
+/* If INFO < 0, argument number -INFO is illegal. */
+/* If INFO > 0, the algorithm did not converge, and INFO */
+/* specifies how many superdiagonals did not converge. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ iuplo = 0;
+ if (lsame_(uplo, "U")) {
+ iuplo = 1;
+ }
+ if (lsame_(uplo, "L")) {
+ iuplo = 2;
+ }
+ if (iuplo == 0) {
+ *info = -1;
+ } else if (*sqre < 0 || *sqre > 1) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ncvt < 0) {
+ *info = -4;
+ } else if (*nru < 0) {
+ *info = -5;
+ } else if (*ncc < 0) {
+ *info = -6;
+ } else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1,*n)) {
+ *info = -10;
+ } else if (*ldu < max(1,*nru)) {
+ *info = -12;
+ } else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1,*n)) {
+ *info = -14;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLASDQ", &i__1);
+ return 0;
+ }
+ if (*n == 0) {
+ return 0;
+ }
+
+/* ROTATE is true if any singular vectors desired, false otherwise */
+
+ rotate = *ncvt > 0 || *nru > 0 || *ncc > 0;
+ np1 = *n + 1;
+ sqre1 = *sqre;
+
+/* If matrix non-square upper bidiagonal, rotate to be lower */
+/* bidiagonal. The rotations are on the right. */
+
+ if (iuplo == 1 && sqre1 == 1) {
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ slartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
+ d__[i__] = r__;
+ e[i__] = sn * d__[i__ + 1];
+ d__[i__ + 1] = cs * d__[i__ + 1];
+ if (rotate) {
+ work[i__] = cs;
+ work[*n + i__] = sn;
+ }
+/* L10: */
+ }
+ slartg_(&d__[*n], &e[*n], &cs, &sn, &r__);
+ d__[*n] = r__;
+ e[*n] = 0.f;
+ if (rotate) {
+ work[*n] = cs;
+ work[*n + *n] = sn;
+ }
+ iuplo = 2;
+ sqre1 = 0;
+
+/* Update singular vectors if desired. */
+
+ if (*ncvt > 0) {
+ slasr_("L", "V", "F", &np1, ncvt, &work[1], &work[np1], &vt[
+ vt_offset], ldvt);
+ }
+ }
+
+/* If matrix lower bidiagonal, rotate to be upper bidiagonal */
+/* by applying Givens rotations on the left. */
+
+ if (iuplo == 2) {
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ slartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
+ d__[i__] = r__;
+ e[i__] = sn * d__[i__ + 1];
+ d__[i__ + 1] = cs * d__[i__ + 1];
+ if (rotate) {
+ work[i__] = cs;
+ work[*n + i__] = sn;
+ }
+/* L20: */
+ }
+
+/* If matrix (N+1)-by-N lower bidiagonal, one additional */
+/* rotation is needed. */
+
+ if (sqre1 == 1) {
+ slartg_(&d__[*n], &e[*n], &cs, &sn, &r__);
+ d__[*n] = r__;
+ if (rotate) {
+ work[*n] = cs;
+ work[*n + *n] = sn;
+ }
+ }
+
+/* Update singular vectors if desired. */
+
+ if (*nru > 0) {
+ if (sqre1 == 0) {
+ slasr_("R", "V", "F", nru, n, &work[1], &work[np1], &u[
+ u_offset], ldu);
+ } else {
+ slasr_("R", "V", "F", nru, &np1, &work[1], &work[np1], &u[
+ u_offset], ldu);
+ }
+ }
+ if (*ncc > 0) {
+ if (sqre1 == 0) {
+ slasr_("L", "V", "F", n, ncc, &work[1], &work[np1], &c__[
+ c_offset], ldc);
+ } else {
+ slasr_("L", "V", "F", &np1, ncc, &work[1], &work[np1], &c__[
+ c_offset], ldc);
+ }
+ }
+ }
+
+/* Call SBDSQR to compute the SVD of the reduced real */
+/* N-by-N upper bidiagonal matrix. */
+
+ sbdsqr_("U", n, ncvt, nru, ncc, &d__[1], &e[1], &vt[vt_offset], ldvt, &u[
+ u_offset], ldu, &c__[c_offset], ldc, &work[1], info);
+
+/* Sort the singular values into ascending order (insertion sort on */
+/* singular values, but only one transposition per singular vector) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Scan for smallest D(I). */
+
+ isub = i__;
+ smin = d__[i__];
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (d__[j] < smin) {
+ isub = j;
+ smin = d__[j];
+ }
+/* L30: */
+ }
+ if (isub != i__) {
+
+/* Swap singular values and vectors. */
+
+ d__[isub] = d__[i__];
+ d__[i__] = smin;
+ if (*ncvt > 0) {
+ sswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[i__ + vt_dim1],
+ ldvt);
+ }
+ if (*nru > 0) {
+ sswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[i__ * u_dim1 + 1]
+, &c__1);
+ }
+ if (*ncc > 0) {
+ sswap_(ncc, &c__[isub + c_dim1], ldc, &c__[i__ + c_dim1], ldc)
+ ;
+ }
+ }
+/* L40: */
+ }
+
+ return 0;
+
+/* End of SLASDQ */
+
+} /* slasdq_ */
diff --git a/SRC/slasdt.c b/SRC/slasdt.c
new file mode 100644
index 0000000..aac6d27
--- /dev/null
+++ b/SRC/slasdt.c
@@ -0,0 +1,136 @@
+/* slasdt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slasdt_(integer *n, integer *lvl, integer *nd, integer *
+ inode, integer *ndiml, integer *ndimr, integer *msub)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Builtin functions */
+ double log(doublereal);
+
+ /* Local variables */
+ integer i__, il, ir, maxn;
+ real temp;
+ integer nlvl, llst, ncrnt;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASDT creates a tree of subproblems for bidiagonal divide and */
+/* conquer. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* On entry, the number of diagonal elements of the */
+/* bidiagonal matrix. */
+
+/* LVL (output) INTEGER */
+/* On exit, the number of levels on the computation tree. */
+
+/* ND (output) INTEGER */
+/* On exit, the number of nodes on the tree. */
+
+/* INODE (output) INTEGER array, dimension ( N ) */
+/* On exit, centers of subproblems. */
+
+/* NDIML (output) INTEGER array, dimension ( N ) */
+/* On exit, row dimensions of left children. */
+
+/* NDIMR (output) INTEGER array, dimension ( N ) */
+/* On exit, row dimensions of right children. */
+
+/* MSUB (input) INTEGER. */
+/* On entry, the maximum row dimension each subproblem at the */
+/* bottom of the tree can be of. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Find the number of levels on the tree. */
+
+ /* Parameter adjustments */
+ --ndimr;
+ --ndiml;
+ --inode;
+
+ /* Function Body */
+ maxn = max(1,*n);
+ temp = log((real) maxn / (real) (*msub + 1)) / log(2.f);
+ *lvl = (integer) temp + 1;
+
+ i__ = *n / 2;
+ inode[1] = i__ + 1;
+ ndiml[1] = i__;
+ ndimr[1] = *n - i__ - 1;
+ il = 0;
+ ir = 1;
+ llst = 1;
+ i__1 = *lvl - 1;
+ for (nlvl = 1; nlvl <= i__1; ++nlvl) {
+
+/* Constructing the tree at (NLVL+1)-st level. The number of */
+/* nodes created on this level is LLST * 2. */
+
+ i__2 = llst - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ il += 2;
+ ir += 2;
+ ncrnt = llst + i__;
+ ndiml[il] = ndiml[ncrnt] / 2;
+ ndimr[il] = ndiml[ncrnt] - ndiml[il] - 1;
+ inode[il] = inode[ncrnt] - ndimr[il] - 1;
+ ndiml[ir] = ndimr[ncrnt] / 2;
+ ndimr[ir] = ndimr[ncrnt] - ndiml[ir] - 1;
+ inode[ir] = inode[ncrnt] + ndiml[ir] + 1;
+/* L10: */
+ }
+ llst <<= 1;
+/* L20: */
+ }
+ *nd = (llst << 1) - 1;
+
+ return 0;
+
+/* End of SLASDT */
+
+} /* slasdt_ */
diff --git a/SRC/slaset.c b/SRC/slaset.c
new file mode 100644
index 0000000..1566db7
--- /dev/null
+++ b/SRC/slaset.c
@@ -0,0 +1,152 @@
+/* slaset.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slaset_(char *uplo, integer *m, integer *n, real *alpha,
+ real *beta, real *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j;
+ extern logical lsame_(char *, char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASET initializes an m-by-n matrix A to BETA on the diagonal and */
+/* ALPHA on the offdiagonals. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies the part of the matrix A to be set. */
+/* = 'U': Upper triangular part is set; the strictly lower */
+/* triangular part of A is not changed. */
+/* = 'L': Lower triangular part is set; the strictly upper */
+/* triangular part of A is not changed. */
+/* Otherwise: All of the matrix A is set. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* ALPHA (input) REAL */
+/* The constant to which the offdiagonal elements are to be set. */
+
+/* BETA (input) REAL */
+/* The constant to which the diagonal elements are to be set. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On exit, the leading m-by-n submatrix of A is set as follows: */
+
+/* if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, */
+/* if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, */
+/* otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, */
+
+/* and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ if (lsame_(uplo, "U")) {
+
+/* Set the strictly upper triangular or trapezoidal part of the */
+/* array to ALPHA. */
+
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j - 1;
+ i__2 = min(i__3,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = *alpha;
+/* L10: */
+ }
+/* L20: */
+ }
+
+ } else if (lsame_(uplo, "L")) {
+
+/* Set the strictly lower triangular or trapezoidal part of the */
+/* array to ALPHA. */
+
+ i__1 = min(*m,*n);
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = *alpha;
+/* L30: */
+ }
+/* L40: */
+ }
+
+ } else {
+
+/* Set the leading m-by-n submatrix to ALPHA. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = *alpha;
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+
+/* Set the first min(M,N) diagonal elements to BETA. */
+
+ i__1 = min(*m,*n);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ a[i__ + i__ * a_dim1] = *beta;
+/* L70: */
+ }
+
+ return 0;
+
+/* End of SLASET */
+
+} /* slaset_ */
diff --git a/SRC/slasq1.c b/SRC/slasq1.c
new file mode 100644
index 0000000..b812d23
--- /dev/null
+++ b/SRC/slasq1.c
@@ -0,0 +1,216 @@
+/* slasq1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+
+/* Subroutine */ int slasq1_(integer *n, real *d__, real *e, real *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real eps;
+ extern /* Subroutine */ int slas2_(real *, real *, real *, real *, real *)
+ ;
+ real scale;
+ integer iinfo;
+ real sigmn, sigmx;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), slasq2_(integer *, real *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *), slascl_(
+ char *, integer *, integer *, real *, real *, integer *, integer *
+, real *, integer *, integer *), slasrt_(char *, integer *
+, real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
+/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
+/* -- Berkeley -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASQ1 computes the singular values of a real N-by-N bidiagonal */
+/* matrix with diagonal D and off-diagonal E. The singular values */
+/* are computed to high relative accuracy, in the absence of */
+/* denormalization, underflow and overflow. The algorithm was first */
+/* presented in */
+
+/* "Accurate singular values and differential qd algorithms" by K. V. */
+/* Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230, */
+/* 1994, */
+
+/* and the present implementation is described in "An implementation of */
+/* the dqds Algorithm (Positive Case)", LAPACK Working Note. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows and columns in the matrix. N >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, D contains the diagonal elements of the */
+/* bidiagonal matrix whose SVD is desired. On normal exit, */
+/* D contains the singular values in decreasing order. */
+
+/* E (input/output) REAL array, dimension (N) */
+/* On entry, elements E(1:N-1) contain the off-diagonal elements */
+/* of the bidiagonal matrix whose SVD is desired. */
+/* On exit, E is overwritten. */
+
+/* WORK (workspace) REAL array, dimension (4*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: the algorithm failed */
+/* = 1, a split was marked by a positive value in E */
+/* = 2, current block of Z not diagonalized after 30*N */
+/* iterations (in inner while loop) */
+/* = 3, termination criterion of outer while loop not met */
+/* (program created more than N unreduced blocks) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --e;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -2;
+ i__1 = -(*info);
+ xerbla_("SLASQ1", &i__1);
+ return 0;
+ } else if (*n == 0) {
+ return 0;
+ } else if (*n == 1) {
+ d__[1] = dabs(d__[1]);
+ return 0;
+ } else if (*n == 2) {
+ slas2_(&d__[1], &e[1], &d__[2], &sigmn, &sigmx);
+ d__[1] = sigmx;
+ d__[2] = sigmn;
+ return 0;
+ }
+
+/* Estimate the largest singular value. */
+
+ sigmx = 0.f;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = (r__1 = d__[i__], dabs(r__1));
+/* Computing MAX */
+ r__2 = sigmx, r__3 = (r__1 = e[i__], dabs(r__1));
+ sigmx = dmax(r__2,r__3);
+/* L10: */
+ }
+ d__[*n] = (r__1 = d__[*n], dabs(r__1));
+
+/* Early return if SIGMX is zero (matrix is already diagonal). */
+
+ if (sigmx == 0.f) {
+ slasrt_("D", n, &d__[1], &iinfo);
+ return 0;
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = sigmx, r__2 = d__[i__];
+ sigmx = dmax(r__1,r__2);
+/* L20: */
+ }
+
+/* Copy D and E into WORK (in the Z format) and scale (squaring the */
+/* input data makes scaling by a power of the radix pointless). */
+
+ eps = slamch_("Precision");
+ safmin = slamch_("Safe minimum");
+ scale = sqrt(eps / safmin);
+ scopy_(n, &d__[1], &c__1, &work[1], &c__2);
+ i__1 = *n - 1;
+ scopy_(&i__1, &e[1], &c__1, &work[2], &c__2);
+ i__1 = (*n << 1) - 1;
+ i__2 = (*n << 1) - 1;
+ slascl_("G", &c__0, &c__0, &sigmx, &scale, &i__1, &c__1, &work[1], &i__2,
+ &iinfo);
+
+/* Compute the q's and e's. */
+
+ i__1 = (*n << 1) - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing 2nd power */
+ r__1 = work[i__];
+ work[i__] = r__1 * r__1;
+/* L30: */
+ }
+ work[*n * 2] = 0.f;
+
+ slasq2_(n, &work[1], info);
+
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = sqrt(work[i__]);
+/* L40: */
+ }
+ slascl_("G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, &
+ iinfo);
+ }
+
+ return 0;
+
+/* End of SLASQ1 */
+
+} /* slasq1_ */
diff --git a/SRC/slasq2.c b/SRC/slasq2.c
new file mode 100644
index 0000000..00d11cc
--- /dev/null
+++ b/SRC/slasq2.c
@@ -0,0 +1,599 @@
+/* slasq2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int slasq2_(integer *n, real *z__, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real d__, e, g;
+ integer k;
+ real s, t;
+ integer i0, i4, n0;
+ real dn;
+ integer pp;
+ real dn1, dn2, dee, eps, tau, tol;
+ integer ipn4;
+ real tol2;
+ logical ieee;
+ integer nbig;
+ real dmin__, emin, emax;
+ integer kmin, ndiv, iter;
+ real qmin, temp, qmax, zmax;
+ integer splt;
+ real dmin1, dmin2;
+ integer nfail;
+ real desig, trace, sigma;
+ integer iinfo, ttype;
+ extern /* Subroutine */ int slasq3_(integer *, integer *, real *, integer
+ *, real *, real *, real *, real *, integer *, integer *, integer *
+, logical *, integer *, real *, real *, real *, real *, real *,
+ real *, real *);
+ real deemin;
+ extern doublereal slamch_(char *);
+ integer iwhila, iwhilb;
+ real oldemn, safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *), slasrt_(
+ char *, integer *, real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
+/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
+/* -- Berkeley -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASQ2 computes all the eigenvalues of the symmetric positive */
+/* definite tridiagonal matrix associated with the qd array Z to high */
+/* relative accuracy are computed to high relative accuracy, in the */
+/* absence of denormalization, underflow and overflow. */
+
+/* To see the relation of Z to the tridiagonal matrix, let L be a */
+/* unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and */
+/* let U be an upper bidiagonal matrix with 1's above and diagonal */
+/* Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the */
+/* symmetric tridiagonal to which it is similar. */
+
+/* Note : SLASQ2 defines a logical variable, IEEE, which is true */
+/* on machines which follow ieee-754 floating-point standard in their */
+/* handling of infinities and NaNs, and false otherwise. This variable */
+/* is passed to SLASQ3. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows and columns in the matrix. N >= 0. */
+
+/* Z (input/output) REAL array, dimension ( 4*N ) */
+/* On entry Z holds the qd array. On exit, entries 1 to N hold */
+/* the eigenvalues in decreasing order, Z( 2*N+1 ) holds the */
+/* trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If */
+/* N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 ) */
+/* holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of */
+/* shifts that failed. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if the i-th argument is a scalar and had an illegal */
+/* value, then INFO = -i, if the i-th argument is an */
+/* array and the j-entry had an illegal value, then */
+/* INFO = -(i*100+j) */
+/* > 0: the algorithm failed */
+/* = 1, a split was marked by a positive value in E */
+/* = 2, current block of Z not diagonalized after 30*N */
+/* iterations (in inner while loop) */
+/* = 3, termination criterion of outer while loop not met */
+/* (program created more than N unreduced blocks) */
+
+/* Further Details */
+/* =============== */
+/* Local Variables: I0:N0 defines a current unreduced segment of Z. */
+/* The shifts are accumulated in SIGMA. Iteration count is in ITER. */
+/* Ping-pong is controlled by PP (alternates between 0 and 1). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+/* (in case SLASQ2 is not called by SLASQ1) */
+
+ /* Parameter adjustments */
+ --z__;
+
+ /* Function Body */
+ *info = 0;
+ eps = slamch_("Precision");
+ safmin = slamch_("Safe minimum");
+ tol = eps * 100.f;
+/* Computing 2nd power */
+ r__1 = tol;
+ tol2 = r__1 * r__1;
+
+ if (*n < 0) {
+ *info = -1;
+ xerbla_("SLASQ2", &c__1);
+ return 0;
+ } else if (*n == 0) {
+ return 0;
+ } else if (*n == 1) {
+
+/* 1-by-1 case. */
+
+ if (z__[1] < 0.f) {
+ *info = -201;
+ xerbla_("SLASQ2", &c__2);
+ }
+ return 0;
+ } else if (*n == 2) {
+
+/* 2-by-2 case. */
+
+ if (z__[2] < 0.f || z__[3] < 0.f) {
+ *info = -2;
+ xerbla_("SLASQ2", &c__2);
+ return 0;
+ } else if (z__[3] > z__[1]) {
+ d__ = z__[3];
+ z__[3] = z__[1];
+ z__[1] = d__;
+ }
+ z__[5] = z__[1] + z__[2] + z__[3];
+ if (z__[2] > z__[3] * tol2) {
+ t = (z__[1] - z__[3] + z__[2]) * .5f;
+ s = z__[3] * (z__[2] / t);
+ if (s <= t) {
+ s = z__[3] * (z__[2] / (t * (sqrt(s / t + 1.f) + 1.f)));
+ } else {
+ s = z__[3] * (z__[2] / (t + sqrt(t) * sqrt(t + s)));
+ }
+ t = z__[1] + (s + z__[2]);
+ z__[3] *= z__[1] / t;
+ z__[1] = t;
+ }
+ z__[2] = z__[3];
+ z__[6] = z__[2] + z__[1];
+ return 0;
+ }
+
+/* Check for negative data and compute sums of q's and e's. */
+
+ z__[*n * 2] = 0.f;
+ emin = z__[2];
+ qmax = 0.f;
+ zmax = 0.f;
+ d__ = 0.f;
+ e = 0.f;
+
+ i__1 = *n - 1 << 1;
+ for (k = 1; k <= i__1; k += 2) {
+ if (z__[k] < 0.f) {
+ *info = -(k + 200);
+ xerbla_("SLASQ2", &c__2);
+ return 0;
+ } else if (z__[k + 1] < 0.f) {
+ *info = -(k + 201);
+ xerbla_("SLASQ2", &c__2);
+ return 0;
+ }
+ d__ += z__[k];
+ e += z__[k + 1];
+/* Computing MAX */
+ r__1 = qmax, r__2 = z__[k];
+ qmax = dmax(r__1,r__2);
+/* Computing MIN */
+ r__1 = emin, r__2 = z__[k + 1];
+ emin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = max(qmax,zmax), r__2 = z__[k + 1];
+ zmax = dmax(r__1,r__2);
+/* L10: */
+ }
+ if (z__[(*n << 1) - 1] < 0.f) {
+ *info = -((*n << 1) + 199);
+ xerbla_("SLASQ2", &c__2);
+ return 0;
+ }
+ d__ += z__[(*n << 1) - 1];
+/* Computing MAX */
+ r__1 = qmax, r__2 = z__[(*n << 1) - 1];
+ qmax = dmax(r__1,r__2);
+ zmax = dmax(qmax,zmax);
+
+/* Check for diagonality. */
+
+ if (e == 0.f) {
+ i__1 = *n;
+ for (k = 2; k <= i__1; ++k) {
+ z__[k] = z__[(k << 1) - 1];
+/* L20: */
+ }
+ slasrt_("D", n, &z__[1], &iinfo);
+ z__[(*n << 1) - 1] = d__;
+ return 0;
+ }
+
+ trace = d__ + e;
+
+/* Check for zero data. */
+
+ if (trace == 0.f) {
+ z__[(*n << 1) - 1] = 0.f;
+ return 0;
+ }
+
+/* Check whether the machine is IEEE conformable. */
+
+/* IEEE = ILAENV( 10, 'SLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND. */
+/* $ ILAENV( 11, 'SLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 */
+
+/* [11/15/2008] The case IEEE=.TRUE. has a problem in single precision with */
+/* some the test matrices of type 16. The double precision code is fine. */
+
+ ieee = FALSE_;
+
+/* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). */
+
+ for (k = *n << 1; k >= 2; k += -2) {
+ z__[k * 2] = 0.f;
+ z__[(k << 1) - 1] = z__[k];
+ z__[(k << 1) - 2] = 0.f;
+ z__[(k << 1) - 3] = z__[k - 1];
+/* L30: */
+ }
+
+ i0 = 1;
+ n0 = *n;
+
+/* Reverse the qd-array, if warranted. */
+
+ if (z__[(i0 << 2) - 3] * 1.5f < z__[(n0 << 2) - 3]) {
+ ipn4 = i0 + n0 << 2;
+ i__1 = i0 + n0 - 1 << 1;
+ for (i4 = i0 << 2; i4 <= i__1; i4 += 4) {
+ temp = z__[i4 - 3];
+ z__[i4 - 3] = z__[ipn4 - i4 - 3];
+ z__[ipn4 - i4 - 3] = temp;
+ temp = z__[i4 - 1];
+ z__[i4 - 1] = z__[ipn4 - i4 - 5];
+ z__[ipn4 - i4 - 5] = temp;
+/* L40: */
+ }
+ }
+
+/* Initial split checking via dqd and Li's test. */
+
+ pp = 0;
+
+ for (k = 1; k <= 2; ++k) {
+
+ d__ = z__[(n0 << 2) + pp - 3];
+ i__1 = (i0 << 2) + pp;
+ for (i4 = (n0 - 1 << 2) + pp; i4 >= i__1; i4 += -4) {
+ if (z__[i4 - 1] <= tol2 * d__) {
+ z__[i4 - 1] = -0.f;
+ d__ = z__[i4 - 3];
+ } else {
+ d__ = z__[i4 - 3] * (d__ / (d__ + z__[i4 - 1]));
+ }
+/* L50: */
+ }
+
+/* dqd maps Z to ZZ plus Li's test. */
+
+ emin = z__[(i0 << 2) + pp + 1];
+ d__ = z__[(i0 << 2) + pp - 3];
+ i__1 = (n0 - 1 << 2) + pp;
+ for (i4 = (i0 << 2) + pp; i4 <= i__1; i4 += 4) {
+ z__[i4 - (pp << 1) - 2] = d__ + z__[i4 - 1];
+ if (z__[i4 - 1] <= tol2 * d__) {
+ z__[i4 - 1] = -0.f;
+ z__[i4 - (pp << 1) - 2] = d__;
+ z__[i4 - (pp << 1)] = 0.f;
+ d__ = z__[i4 + 1];
+ } else if (safmin * z__[i4 + 1] < z__[i4 - (pp << 1) - 2] &&
+ safmin * z__[i4 - (pp << 1) - 2] < z__[i4 + 1]) {
+ temp = z__[i4 + 1] / z__[i4 - (pp << 1) - 2];
+ z__[i4 - (pp << 1)] = z__[i4 - 1] * temp;
+ d__ *= temp;
+ } else {
+ z__[i4 - (pp << 1)] = z__[i4 + 1] * (z__[i4 - 1] / z__[i4 - (
+ pp << 1) - 2]);
+ d__ = z__[i4 + 1] * (d__ / z__[i4 - (pp << 1) - 2]);
+ }
+/* Computing MIN */
+ r__1 = emin, r__2 = z__[i4 - (pp << 1)];
+ emin = dmin(r__1,r__2);
+/* L60: */
+ }
+ z__[(n0 << 2) - pp - 2] = d__;
+
+/* Now find qmax. */
+
+ qmax = z__[(i0 << 2) - pp - 2];
+ i__1 = (n0 << 2) - pp - 2;
+ for (i4 = (i0 << 2) - pp + 2; i4 <= i__1; i4 += 4) {
+/* Computing MAX */
+ r__1 = qmax, r__2 = z__[i4];
+ qmax = dmax(r__1,r__2);
+/* L70: */
+ }
+
+/* Prepare for the next iteration on K. */
+
+ pp = 1 - pp;
+/* L80: */
+ }
+
+/* Initialise variables to pass to SLASQ3. */
+
+ ttype = 0;
+ dmin1 = 0.f;
+ dmin2 = 0.f;
+ dn = 0.f;
+ dn1 = 0.f;
+ dn2 = 0.f;
+ g = 0.f;
+ tau = 0.f;
+
+ iter = 2;
+ nfail = 0;
+ ndiv = n0 - i0 << 1;
+
+ i__1 = *n + 1;
+ for (iwhila = 1; iwhila <= i__1; ++iwhila) {
+ if (n0 < 1) {
+ goto L170;
+ }
+
+/* While array unfinished do */
+
+/* E(N0) holds the value of SIGMA when submatrix in I0:N0 */
+/* splits from the rest of the array, but is negated. */
+
+ desig = 0.f;
+ if (n0 == *n) {
+ sigma = 0.f;
+ } else {
+ sigma = -z__[(n0 << 2) - 1];
+ }
+ if (sigma < 0.f) {
+ *info = 1;
+ return 0;
+ }
+
+/* Find last unreduced submatrix's top index I0, find QMAX and */
+/* EMIN. Find Gershgorin-type bound if Q's much greater than E's. */
+
+ emax = 0.f;
+ if (n0 > i0) {
+ emin = (r__1 = z__[(n0 << 2) - 5], dabs(r__1));
+ } else {
+ emin = 0.f;
+ }
+ qmin = z__[(n0 << 2) - 3];
+ qmax = qmin;
+ for (i4 = n0 << 2; i4 >= 8; i4 += -4) {
+ if (z__[i4 - 5] <= 0.f) {
+ goto L100;
+ }
+ if (qmin >= emax * 4.f) {
+/* Computing MIN */
+ r__1 = qmin, r__2 = z__[i4 - 3];
+ qmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = emax, r__2 = z__[i4 - 5];
+ emax = dmax(r__1,r__2);
+ }
+/* Computing MAX */
+ r__1 = qmax, r__2 = z__[i4 - 7] + z__[i4 - 5];
+ qmax = dmax(r__1,r__2);
+/* Computing MIN */
+ r__1 = emin, r__2 = z__[i4 - 5];
+ emin = dmin(r__1,r__2);
+/* L90: */
+ }
+ i4 = 4;
+
+L100:
+ i0 = i4 / 4;
+ pp = 0;
+
+ if (n0 - i0 > 1) {
+ dee = z__[(i0 << 2) - 3];
+ deemin = dee;
+ kmin = i0;
+ i__2 = (n0 << 2) - 3;
+ for (i4 = (i0 << 2) + 1; i4 <= i__2; i4 += 4) {
+ dee = z__[i4] * (dee / (dee + z__[i4 - 2]));
+ if (dee <= deemin) {
+ deemin = dee;
+ kmin = (i4 + 3) / 4;
+ }
+/* L110: */
+ }
+ if (kmin - i0 << 1 < n0 - kmin && deemin <= z__[(n0 << 2) - 3] *
+ .5f) {
+ ipn4 = i0 + n0 << 2;
+ pp = 2;
+ i__2 = i0 + n0 - 1 << 1;
+ for (i4 = i0 << 2; i4 <= i__2; i4 += 4) {
+ temp = z__[i4 - 3];
+ z__[i4 - 3] = z__[ipn4 - i4 - 3];
+ z__[ipn4 - i4 - 3] = temp;
+ temp = z__[i4 - 2];
+ z__[i4 - 2] = z__[ipn4 - i4 - 2];
+ z__[ipn4 - i4 - 2] = temp;
+ temp = z__[i4 - 1];
+ z__[i4 - 1] = z__[ipn4 - i4 - 5];
+ z__[ipn4 - i4 - 5] = temp;
+ temp = z__[i4];
+ z__[i4] = z__[ipn4 - i4 - 4];
+ z__[ipn4 - i4 - 4] = temp;
+/* L120: */
+ }
+ }
+ }
+
+/* Put -(initial shift) into DMIN. */
+
+/* Computing MAX */
+ r__1 = 0.f, r__2 = qmin - sqrt(qmin) * 2.f * sqrt(emax);
+ dmin__ = -dmax(r__1,r__2);
+
+/* Now I0:N0 is unreduced. */
+/* PP = 0 for ping, PP = 1 for pong. */
+/* PP = 2 indicates that flipping was applied to the Z array and */
+/* and that the tests for deflation upon entry in SLASQ3 */
+/* should not be performed. */
+
+ nbig = (n0 - i0 + 1) * 30;
+ i__2 = nbig;
+ for (iwhilb = 1; iwhilb <= i__2; ++iwhilb) {
+ if (i0 > n0) {
+ goto L150;
+ }
+
+/* While submatrix unfinished take a good dqds step. */
+
+ slasq3_(&i0, &n0, &z__[1], &pp, &dmin__, &sigma, &desig, &qmax, &
+ nfail, &iter, &ndiv, &ieee, &ttype, &dmin1, &dmin2, &dn, &
+ dn1, &dn2, &g, &tau);
+
+ pp = 1 - pp;
+
+/* When EMIN is very small check for splits. */
+
+ if (pp == 0 && n0 - i0 >= 3) {
+ if (z__[n0 * 4] <= tol2 * qmax || z__[(n0 << 2) - 1] <= tol2 *
+ sigma) {
+ splt = i0 - 1;
+ qmax = z__[(i0 << 2) - 3];
+ emin = z__[(i0 << 2) - 1];
+ oldemn = z__[i0 * 4];
+ i__3 = n0 - 3 << 2;
+ for (i4 = i0 << 2; i4 <= i__3; i4 += 4) {
+ if (z__[i4] <= tol2 * z__[i4 - 3] || z__[i4 - 1] <=
+ tol2 * sigma) {
+ z__[i4 - 1] = -sigma;
+ splt = i4 / 4;
+ qmax = 0.f;
+ emin = z__[i4 + 3];
+ oldemn = z__[i4 + 4];
+ } else {
+/* Computing MAX */
+ r__1 = qmax, r__2 = z__[i4 + 1];
+ qmax = dmax(r__1,r__2);
+/* Computing MIN */
+ r__1 = emin, r__2 = z__[i4 - 1];
+ emin = dmin(r__1,r__2);
+/* Computing MIN */
+ r__1 = oldemn, r__2 = z__[i4];
+ oldemn = dmin(r__1,r__2);
+ }
+/* L130: */
+ }
+ z__[(n0 << 2) - 1] = emin;
+ z__[n0 * 4] = oldemn;
+ i0 = splt + 1;
+ }
+ }
+
+/* L140: */
+ }
+
+ *info = 2;
+ return 0;
+
+/* end IWHILB */
+
+L150:
+
+/* L160: */
+ ;
+ }
+
+ *info = 3;
+ return 0;
+
+/* end IWHILA */
+
+L170:
+
+/* Move q's to the front. */
+
+ i__1 = *n;
+ for (k = 2; k <= i__1; ++k) {
+ z__[k] = z__[(k << 2) - 3];
+/* L180: */
+ }
+
+/* Sort and compute sum of eigenvalues. */
+
+ slasrt_("D", n, &z__[1], &iinfo);
+
+ e = 0.f;
+ for (k = *n; k >= 1; --k) {
+ e += z__[k];
+/* L190: */
+ }
+
+/* Store trace, sum(eigenvalues) and information on performance. */
+
+ z__[(*n << 1) + 1] = trace;
+ z__[(*n << 1) + 2] = e;
+ z__[(*n << 1) + 3] = (real) iter;
+/* Computing 2nd power */
+ i__1 = *n;
+ z__[(*n << 1) + 4] = (real) ndiv / (real) (i__1 * i__1);
+ z__[(*n << 1) + 5] = nfail * 100.f / (real) iter;
+ return 0;
+
+/* End of SLASQ2 */
+
+} /* slasq2_ */
diff --git a/SRC/slasq3.c b/SRC/slasq3.c
new file mode 100644
index 0000000..409ab3f
--- /dev/null
+++ b/SRC/slasq3.c
@@ -0,0 +1,346 @@
+/* slasq3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slasq3_(integer *i0, integer *n0, real *z__, integer *pp,
+ real *dmin__, real *sigma, real *desig, real *qmax, integer *nfail,
+ integer *iter, integer *ndiv, logical *ieee, integer *ttype, real *
+ dmin1, real *dmin2, real *dn, real *dn1, real *dn2, real *g, real *
+ tau)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real s, t;
+ integer j4, nn;
+ real eps, tol;
+ integer n0in, ipn4;
+ real tol2, temp;
+ extern /* Subroutine */ int slasq4_(integer *, integer *, real *, integer
+ *, integer *, real *, real *, real *, real *, real *, real *,
+ real *, integer *, real *), slasq5_(integer *, integer *, real *,
+ integer *, real *, real *, real *, real *, real *, real *, real *,
+ logical *), slasq6_(integer *, integer *, real *, integer *,
+ real *, real *, real *, real *, real *, real *);
+ extern doublereal slamch_(char *);
+ extern logical sisnan_(real *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
+/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
+/* -- Berkeley -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASQ3 checks for deflation, computes a shift (TAU) and calls dqds. */
+/* In case of failure it changes shifts, and tries again until output */
+/* is positive. */
+
+/* Arguments */
+/* ========= */
+
+/* I0 (input) INTEGER */
+/* First index. */
+
+/* N0 (input) INTEGER */
+/* Last index. */
+
+/* Z (input) REAL array, dimension ( 4*N ) */
+/* Z holds the qd array. */
+
+/* PP (input/output) INTEGER */
+/* PP=0 for ping, PP=1 for pong. */
+/* PP=2 indicates that flipping was applied to the Z array */
+/* and that the initial tests for deflation should not be */
+/* performed. */
+
+/* DMIN (output) REAL */
+/* Minimum value of d. */
+
+/* SIGMA (output) REAL */
+/* Sum of shifts used in current segment. */
+
+/* DESIG (input/output) REAL */
+/* Lower order part of SIGMA */
+
+/* QMAX (input) REAL */
+/* Maximum value of q. */
+
+/* NFAIL (output) INTEGER */
+/* Number of times shift was too big. */
+
+/* ITER (output) INTEGER */
+/* Number of iterations. */
+
+/* NDIV (output) INTEGER */
+/* Number of divisions. */
+
+/* IEEE (input) LOGICAL */
+/* Flag for IEEE or non IEEE arithmetic (passed to SLASQ5). */
+
+/* TTYPE (input/output) INTEGER */
+/* Shift type. */
+
+/* DMIN1, DMIN2, DN, DN1, DN2, G, TAU (input/output) REAL */
+/* These are passed as arguments in order to save their values */
+/* between calls to SLASQ3. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Function .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --z__;
+
+ /* Function Body */
+ n0in = *n0;
+ eps = slamch_("Precision");
+ tol = eps * 100.f;
+/* Computing 2nd power */
+ r__1 = tol;
+ tol2 = r__1 * r__1;
+
+/* Check for deflation. */
+
+L10:
+
+ if (*n0 < *i0) {
+ return 0;
+ }
+ if (*n0 == *i0) {
+ goto L20;
+ }
+ nn = (*n0 << 2) + *pp;
+ if (*n0 == *i0 + 1) {
+ goto L40;
+ }
+
+/* Check whether E(N0-1) is negligible, 1 eigenvalue. */
+
+ if (z__[nn - 5] > tol2 * (*sigma + z__[nn - 3]) && z__[nn - (*pp << 1) -
+ 4] > tol2 * z__[nn - 7]) {
+ goto L30;
+ }
+
+L20:
+
+ z__[(*n0 << 2) - 3] = z__[(*n0 << 2) + *pp - 3] + *sigma;
+ --(*n0);
+ goto L10;
+
+/* Check whether E(N0-2) is negligible, 2 eigenvalues. */
+
+L30:
+
+ if (z__[nn - 9] > tol2 * *sigma && z__[nn - (*pp << 1) - 8] > tol2 * z__[
+ nn - 11]) {
+ goto L50;
+ }
+
+L40:
+
+ if (z__[nn - 3] > z__[nn - 7]) {
+ s = z__[nn - 3];
+ z__[nn - 3] = z__[nn - 7];
+ z__[nn - 7] = s;
+ }
+ if (z__[nn - 5] > z__[nn - 3] * tol2) {
+ t = (z__[nn - 7] - z__[nn - 3] + z__[nn - 5]) * .5f;
+ s = z__[nn - 3] * (z__[nn - 5] / t);
+ if (s <= t) {
+ s = z__[nn - 3] * (z__[nn - 5] / (t * (sqrt(s / t + 1.f) + 1.f)));
+ } else {
+ s = z__[nn - 3] * (z__[nn - 5] / (t + sqrt(t) * sqrt(t + s)));
+ }
+ t = z__[nn - 7] + (s + z__[nn - 5]);
+ z__[nn - 3] *= z__[nn - 7] / t;
+ z__[nn - 7] = t;
+ }
+ z__[(*n0 << 2) - 7] = z__[nn - 7] + *sigma;
+ z__[(*n0 << 2) - 3] = z__[nn - 3] + *sigma;
+ *n0 += -2;
+ goto L10;
+
+L50:
+ if (*pp == 2) {
+ *pp = 0;
+ }
+
+/* Reverse the qd-array, if warranted. */
+
+ if (*dmin__ <= 0.f || *n0 < n0in) {
+ if (z__[(*i0 << 2) + *pp - 3] * 1.5f < z__[(*n0 << 2) + *pp - 3]) {
+ ipn4 = *i0 + *n0 << 2;
+ i__1 = *i0 + *n0 - 1 << 1;
+ for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
+ temp = z__[j4 - 3];
+ z__[j4 - 3] = z__[ipn4 - j4 - 3];
+ z__[ipn4 - j4 - 3] = temp;
+ temp = z__[j4 - 2];
+ z__[j4 - 2] = z__[ipn4 - j4 - 2];
+ z__[ipn4 - j4 - 2] = temp;
+ temp = z__[j4 - 1];
+ z__[j4 - 1] = z__[ipn4 - j4 - 5];
+ z__[ipn4 - j4 - 5] = temp;
+ temp = z__[j4];
+ z__[j4] = z__[ipn4 - j4 - 4];
+ z__[ipn4 - j4 - 4] = temp;
+/* L60: */
+ }
+ if (*n0 - *i0 <= 4) {
+ z__[(*n0 << 2) + *pp - 1] = z__[(*i0 << 2) + *pp - 1];
+ z__[(*n0 << 2) - *pp] = z__[(*i0 << 2) - *pp];
+ }
+/* Computing MIN */
+ r__1 = *dmin2, r__2 = z__[(*n0 << 2) + *pp - 1];
+ *dmin2 = dmin(r__1,r__2);
+/* Computing MIN */
+ r__1 = z__[(*n0 << 2) + *pp - 1], r__2 = z__[(*i0 << 2) + *pp - 1]
+ , r__1 = min(r__1,r__2), r__2 = z__[(*i0 << 2) + *pp + 3];
+ z__[(*n0 << 2) + *pp - 1] = dmin(r__1,r__2);
+/* Computing MIN */
+ r__1 = z__[(*n0 << 2) - *pp], r__2 = z__[(*i0 << 2) - *pp], r__1 =
+ min(r__1,r__2), r__2 = z__[(*i0 << 2) - *pp + 4];
+ z__[(*n0 << 2) - *pp] = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = *qmax, r__2 = z__[(*i0 << 2) + *pp - 3], r__1 = max(r__1,
+ r__2), r__2 = z__[(*i0 << 2) + *pp + 1];
+ *qmax = dmax(r__1,r__2);
+ *dmin__ = -0.f;
+ }
+ }
+
+/* Choose a shift. */
+
+ slasq4_(i0, n0, &z__[1], pp, &n0in, dmin__, dmin1, dmin2, dn, dn1, dn2,
+ tau, ttype, g);
+
+/* Call dqds until DMIN > 0. */
+
+L70:
+
+ slasq5_(i0, n0, &z__[1], pp, tau, dmin__, dmin1, dmin2, dn, dn1, dn2,
+ ieee);
+
+ *ndiv += *n0 - *i0 + 2;
+ ++(*iter);
+
+/* Check status. */
+
+ if (*dmin__ >= 0.f && *dmin1 > 0.f) {
+
+/* Success. */
+
+ goto L90;
+
+ } else if (*dmin__ < 0.f && *dmin1 > 0.f && z__[(*n0 - 1 << 2) - *pp] <
+ tol * (*sigma + *dn1) && dabs(*dn) < tol * *sigma) {
+
+/* Convergence hidden by negative DN. */
+
+ z__[(*n0 - 1 << 2) - *pp + 2] = 0.f;
+ *dmin__ = 0.f;
+ goto L90;
+ } else if (*dmin__ < 0.f) {
+
+/* TAU too big. Select new TAU and try again. */
+
+ ++(*nfail);
+ if (*ttype < -22) {
+
+/* Failed twice. Play it safe. */
+
+ *tau = 0.f;
+ } else if (*dmin1 > 0.f) {
+
+/* Late failure. Gives excellent shift. */
+
+ *tau = (*tau + *dmin__) * (1.f - eps * 2.f);
+ *ttype += -11;
+ } else {
+
+/* Early failure. Divide by 4. */
+
+ *tau *= .25f;
+ *ttype += -12;
+ }
+ goto L70;
+ } else if (sisnan_(dmin__)) {
+
+/* NaN. */
+
+ if (*tau == 0.f) {
+ goto L80;
+ } else {
+ *tau = 0.f;
+ goto L70;
+ }
+ } else {
+
+/* Possible underflow. Play it safe. */
+
+ goto L80;
+ }
+
+/* Risk of underflow. */
+
+L80:
+ slasq6_(i0, n0, &z__[1], pp, dmin__, dmin1, dmin2, dn, dn1, dn2);
+ *ndiv += *n0 - *i0 + 2;
+ ++(*iter);
+ *tau = 0.f;
+
+L90:
+ if (*tau < *sigma) {
+ *desig += *tau;
+ t = *sigma + *desig;
+ *desig -= t - *sigma;
+ } else {
+ t = *sigma + *tau;
+ *desig = *sigma - (t - *tau) + *desig;
+ }
+ *sigma = t;
+
+ return 0;
+
+/* End of SLASQ3 */
+
+} /* slasq3_ */
diff --git a/SRC/slasq4.c b/SRC/slasq4.c
new file mode 100644
index 0000000..8f3d36d
--- /dev/null
+++ b/SRC/slasq4.c
@@ -0,0 +1,402 @@
+/* slasq4.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slasq4_(integer *i0, integer *n0, real *z__, integer *pp,
+ integer *n0in, real *dmin__, real *dmin1, real *dmin2, real *dn,
+ real *dn1, real *dn2, real *tau, integer *ttype, real *g)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real s, a2, b1, b2;
+ integer i4, nn, np;
+ real gam, gap1, gap2;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
+/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
+/* -- Berkeley -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASQ4 computes an approximation TAU to the smallest eigenvalue */
+/* using values of d from the previous transform. */
+
+/* I0 (input) INTEGER */
+/* First index. */
+
+/* N0 (input) INTEGER */
+/* Last index. */
+
+/* Z (input) REAL array, dimension ( 4*N ) */
+/* Z holds the qd array. */
+
+/* PP (input) INTEGER */
+/* PP=0 for ping, PP=1 for pong. */
+
+/* NOIN (input) INTEGER */
+/* The value of N0 at start of EIGTEST. */
+
+/* DMIN (input) REAL */
+/* Minimum value of d. */
+
+/* DMIN1 (input) REAL */
+/* Minimum value of d, excluding D( N0 ). */
+
+/* DMIN2 (input) REAL */
+/* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */
+
+/* DN (input) REAL */
+/* d(N) */
+
+/* DN1 (input) REAL */
+/* d(N-1) */
+
+/* DN2 (input) REAL */
+/* d(N-2) */
+
+/* TAU (output) REAL */
+/* This is the shift. */
+
+/* TTYPE (output) INTEGER */
+/* Shift type. */
+
+/* G (input/output) REAL */
+/* G is passed as an argument in order to save its value between */
+/* calls to SLASQ4. */
+
+/* Further Details */
+/* =============== */
+/* CNST1 = 9/16 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* A negative DMIN forces the shift to take that absolute value */
+/* TTYPE records the type of shift. */
+
+ /* Parameter adjustments */
+ --z__;
+
+ /* Function Body */
+ if (*dmin__ <= 0.f) {
+ *tau = -(*dmin__);
+ *ttype = -1;
+ return 0;
+ }
+
+ nn = (*n0 << 2) + *pp;
+ if (*n0in == *n0) {
+
+/* No eigenvalues deflated. */
+
+ if (*dmin__ == *dn || *dmin__ == *dn1) {
+
+ b1 = sqrt(z__[nn - 3]) * sqrt(z__[nn - 5]);
+ b2 = sqrt(z__[nn - 7]) * sqrt(z__[nn - 9]);
+ a2 = z__[nn - 7] + z__[nn - 5];
+
+/* Cases 2 and 3. */
+
+ if (*dmin__ == *dn && *dmin1 == *dn1) {
+ gap2 = *dmin2 - a2 - *dmin2 * .25f;
+ if (gap2 > 0.f && gap2 > b2) {
+ gap1 = a2 - *dn - b2 / gap2 * b2;
+ } else {
+ gap1 = a2 - *dn - (b1 + b2);
+ }
+ if (gap1 > 0.f && gap1 > b1) {
+/* Computing MAX */
+ r__1 = *dn - b1 / gap1 * b1, r__2 = *dmin__ * .5f;
+ s = dmax(r__1,r__2);
+ *ttype = -2;
+ } else {
+ s = 0.f;
+ if (*dn > b1) {
+ s = *dn - b1;
+ }
+ if (a2 > b1 + b2) {
+/* Computing MIN */
+ r__1 = s, r__2 = a2 - (b1 + b2);
+ s = dmin(r__1,r__2);
+ }
+/* Computing MAX */
+ r__1 = s, r__2 = *dmin__ * .333f;
+ s = dmax(r__1,r__2);
+ *ttype = -3;
+ }
+ } else {
+
+/* Case 4. */
+
+ *ttype = -4;
+ s = *dmin__ * .25f;
+ if (*dmin__ == *dn) {
+ gam = *dn;
+ a2 = 0.f;
+ if (z__[nn - 5] > z__[nn - 7]) {
+ return 0;
+ }
+ b2 = z__[nn - 5] / z__[nn - 7];
+ np = nn - 9;
+ } else {
+ np = nn - (*pp << 1);
+ b2 = z__[np - 2];
+ gam = *dn1;
+ if (z__[np - 4] > z__[np - 2]) {
+ return 0;
+ }
+ a2 = z__[np - 4] / z__[np - 2];
+ if (z__[nn - 9] > z__[nn - 11]) {
+ return 0;
+ }
+ b2 = z__[nn - 9] / z__[nn - 11];
+ np = nn - 13;
+ }
+
+/* Approximate contribution to norm squared from I < NN-1. */
+
+ a2 += b2;
+ i__1 = (*i0 << 2) - 1 + *pp;
+ for (i4 = np; i4 >= i__1; i4 += -4) {
+ if (b2 == 0.f) {
+ goto L20;
+ }
+ b1 = b2;
+ if (z__[i4] > z__[i4 - 2]) {
+ return 0;
+ }
+ b2 *= z__[i4] / z__[i4 - 2];
+ a2 += b2;
+ if (dmax(b2,b1) * 100.f < a2 || .563f < a2) {
+ goto L20;
+ }
+/* L10: */
+ }
+L20:
+ a2 *= 1.05f;
+
+/* Rayleigh quotient residual bound. */
+
+ if (a2 < .563f) {
+ s = gam * (1.f - sqrt(a2)) / (a2 + 1.f);
+ }
+ }
+ } else if (*dmin__ == *dn2) {
+
+/* Case 5. */
+
+ *ttype = -5;
+ s = *dmin__ * .25f;
+
+/* Compute contribution to norm squared from I > NN-2. */
+
+ np = nn - (*pp << 1);
+ b1 = z__[np - 2];
+ b2 = z__[np - 6];
+ gam = *dn2;
+ if (z__[np - 8] > b2 || z__[np - 4] > b1) {
+ return 0;
+ }
+ a2 = z__[np - 8] / b2 * (z__[np - 4] / b1 + 1.f);
+
+/* Approximate contribution to norm squared from I < NN-2. */
+
+ if (*n0 - *i0 > 2) {
+ b2 = z__[nn - 13] / z__[nn - 15];
+ a2 += b2;
+ i__1 = (*i0 << 2) - 1 + *pp;
+ for (i4 = nn - 17; i4 >= i__1; i4 += -4) {
+ if (b2 == 0.f) {
+ goto L40;
+ }
+ b1 = b2;
+ if (z__[i4] > z__[i4 - 2]) {
+ return 0;
+ }
+ b2 *= z__[i4] / z__[i4 - 2];
+ a2 += b2;
+ if (dmax(b2,b1) * 100.f < a2 || .563f < a2) {
+ goto L40;
+ }
+/* L30: */
+ }
+L40:
+ a2 *= 1.05f;
+ }
+
+ if (a2 < .563f) {
+ s = gam * (1.f - sqrt(a2)) / (a2 + 1.f);
+ }
+ } else {
+
+/* Case 6, no information to guide us. */
+
+ if (*ttype == -6) {
+ *g += (1.f - *g) * .333f;
+ } else if (*ttype == -18) {
+ *g = .083250000000000005f;
+ } else {
+ *g = .25f;
+ }
+ s = *g * *dmin__;
+ *ttype = -6;
+ }
+
+ } else if (*n0in == *n0 + 1) {
+
+/* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. */
+
+ if (*dmin1 == *dn1 && *dmin2 == *dn2) {
+
+/* Cases 7 and 8. */
+
+ *ttype = -7;
+ s = *dmin1 * .333f;
+ if (z__[nn - 5] > z__[nn - 7]) {
+ return 0;
+ }
+ b1 = z__[nn - 5] / z__[nn - 7];
+ b2 = b1;
+ if (b2 == 0.f) {
+ goto L60;
+ }
+ i__1 = (*i0 << 2) - 1 + *pp;
+ for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) {
+ a2 = b1;
+ if (z__[i4] > z__[i4 - 2]) {
+ return 0;
+ }
+ b1 *= z__[i4] / z__[i4 - 2];
+ b2 += b1;
+ if (dmax(b1,a2) * 100.f < b2) {
+ goto L60;
+ }
+/* L50: */
+ }
+L60:
+ b2 = sqrt(b2 * 1.05f);
+/* Computing 2nd power */
+ r__1 = b2;
+ a2 = *dmin1 / (r__1 * r__1 + 1.f);
+ gap2 = *dmin2 * .5f - a2;
+ if (gap2 > 0.f && gap2 > b2 * a2) {
+/* Computing MAX */
+ r__1 = s, r__2 = a2 * (1.f - a2 * 1.01f * (b2 / gap2) * b2);
+ s = dmax(r__1,r__2);
+ } else {
+/* Computing MAX */
+ r__1 = s, r__2 = a2 * (1.f - b2 * 1.01f);
+ s = dmax(r__1,r__2);
+ *ttype = -8;
+ }
+ } else {
+
+/* Case 9. */
+
+ s = *dmin1 * .25f;
+ if (*dmin1 == *dn1) {
+ s = *dmin1 * .5f;
+ }
+ *ttype = -9;
+ }
+
+ } else if (*n0in == *n0 + 2) {
+
+/* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. */
+
+/* Cases 10 and 11. */
+
+ if (*dmin2 == *dn2 && z__[nn - 5] * 2.f < z__[nn - 7]) {
+ *ttype = -10;
+ s = *dmin2 * .333f;
+ if (z__[nn - 5] > z__[nn - 7]) {
+ return 0;
+ }
+ b1 = z__[nn - 5] / z__[nn - 7];
+ b2 = b1;
+ if (b2 == 0.f) {
+ goto L80;
+ }
+ i__1 = (*i0 << 2) - 1 + *pp;
+ for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) {
+ if (z__[i4] > z__[i4 - 2]) {
+ return 0;
+ }
+ b1 *= z__[i4] / z__[i4 - 2];
+ b2 += b1;
+ if (b1 * 100.f < b2) {
+ goto L80;
+ }
+/* L70: */
+ }
+L80:
+ b2 = sqrt(b2 * 1.05f);
+/* Computing 2nd power */
+ r__1 = b2;
+ a2 = *dmin2 / (r__1 * r__1 + 1.f);
+ gap2 = z__[nn - 7] + z__[nn - 9] - sqrt(z__[nn - 11]) * sqrt(z__[
+ nn - 9]) - a2;
+ if (gap2 > 0.f && gap2 > b2 * a2) {
+/* Computing MAX */
+ r__1 = s, r__2 = a2 * (1.f - a2 * 1.01f * (b2 / gap2) * b2);
+ s = dmax(r__1,r__2);
+ } else {
+/* Computing MAX */
+ r__1 = s, r__2 = a2 * (1.f - b2 * 1.01f);
+ s = dmax(r__1,r__2);
+ }
+ } else {
+ s = *dmin2 * .25f;
+ *ttype = -11;
+ }
+ } else if (*n0in > *n0 + 2) {
+
+/* Case 12, more than two eigenvalues deflated. No information. */
+
+ s = 0.f;
+ *ttype = -12;
+ }
+
+ *tau = s;
+ return 0;
+
+/* End of SLASQ4 */
+
+} /* slasq4_ */
diff --git a/SRC/slasq5.c b/SRC/slasq5.c
new file mode 100644
index 0000000..4faff01
--- /dev/null
+++ b/SRC/slasq5.c
@@ -0,0 +1,239 @@
+/* slasq5.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slasq5_(integer *i0, integer *n0, real *z__, integer *pp,
+ real *tau, real *dmin__, real *dmin1, real *dmin2, real *dn, real *
+ dnm1, real *dnm2, logical *ieee)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ real d__;
+ integer j4, j4p2;
+ real emin, temp;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
+/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
+/* -- Berkeley -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASQ5 computes one dqds transform in ping-pong form, one */
+/* version for IEEE machines another for non IEEE machines. */
+
+/* Arguments */
+/* ========= */
+
+/* I0 (input) INTEGER */
+/* First index. */
+
+/* N0 (input) INTEGER */
+/* Last index. */
+
+/* Z (input) REAL array, dimension ( 4*N ) */
+/* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid */
+/* an extra argument. */
+
+/* PP (input) INTEGER */
+/* PP=0 for ping, PP=1 for pong. */
+
+/* TAU (input) REAL */
+/* This is the shift. */
+
+/* DMIN (output) REAL */
+/* Minimum value of d. */
+
+/* DMIN1 (output) REAL */
+/* Minimum value of d, excluding D( N0 ). */
+
+/* DMIN2 (output) REAL */
+/* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */
+
+/* DN (output) REAL */
+/* d(N0), the last value of d. */
+
+/* DNM1 (output) REAL */
+/* d(N0-1). */
+
+/* DNM2 (output) REAL */
+/* d(N0-2). */
+
+/* IEEE (input) LOGICAL */
+/* Flag for IEEE or non IEEE arithmetic. */
+
+/* ===================================================================== */
+
+/* .. Parameter .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --z__;
+
+ /* Function Body */
+ if (*n0 - *i0 - 1 <= 0) {
+ return 0;
+ }
+
+ j4 = (*i0 << 2) + *pp - 3;
+ emin = z__[j4 + 4];
+ d__ = z__[j4] - *tau;
+ *dmin__ = d__;
+ *dmin1 = -z__[j4];
+
+ if (*ieee) {
+
+/* Code for IEEE arithmetic. */
+
+ if (*pp == 0) {
+ i__1 = *n0 - 3 << 2;
+ for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
+ z__[j4 - 2] = d__ + z__[j4 - 1];
+ temp = z__[j4 + 1] / z__[j4 - 2];
+ d__ = d__ * temp - *tau;
+ *dmin__ = dmin(*dmin__,d__);
+ z__[j4] = z__[j4 - 1] * temp;
+/* Computing MIN */
+ r__1 = z__[j4];
+ emin = dmin(r__1,emin);
+/* L10: */
+ }
+ } else {
+ i__1 = *n0 - 3 << 2;
+ for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
+ z__[j4 - 3] = d__ + z__[j4];
+ temp = z__[j4 + 2] / z__[j4 - 3];
+ d__ = d__ * temp - *tau;
+ *dmin__ = dmin(*dmin__,d__);
+ z__[j4 - 1] = z__[j4] * temp;
+/* Computing MIN */
+ r__1 = z__[j4 - 1];
+ emin = dmin(r__1,emin);
+/* L20: */
+ }
+ }
+
+/* Unroll last two steps. */
+
+ *dnm2 = d__;
+ *dmin2 = *dmin__;
+ j4 = (*n0 - 2 << 2) - *pp;
+ j4p2 = j4 + (*pp << 1) - 1;
+ z__[j4 - 2] = *dnm2 + z__[j4p2];
+ z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
+ *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau;
+ *dmin__ = dmin(*dmin__,*dnm1);
+
+ *dmin1 = *dmin__;
+ j4 += 4;
+ j4p2 = j4 + (*pp << 1) - 1;
+ z__[j4 - 2] = *dnm1 + z__[j4p2];
+ z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
+ *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau;
+ *dmin__ = dmin(*dmin__,*dn);
+
+ } else {
+
+/* Code for non IEEE arithmetic. */
+
+ if (*pp == 0) {
+ i__1 = *n0 - 3 << 2;
+ for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
+ z__[j4 - 2] = d__ + z__[j4 - 1];
+ if (d__ < 0.f) {
+ return 0;
+ } else {
+ z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]);
+ d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]) - *tau;
+ }
+ *dmin__ = dmin(*dmin__,d__);
+/* Computing MIN */
+ r__1 = emin, r__2 = z__[j4];
+ emin = dmin(r__1,r__2);
+/* L30: */
+ }
+ } else {
+ i__1 = *n0 - 3 << 2;
+ for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
+ z__[j4 - 3] = d__ + z__[j4];
+ if (d__ < 0.f) {
+ return 0;
+ } else {
+ z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]);
+ d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]) - *tau;
+ }
+ *dmin__ = dmin(*dmin__,d__);
+/* Computing MIN */
+ r__1 = emin, r__2 = z__[j4 - 1];
+ emin = dmin(r__1,r__2);
+/* L40: */
+ }
+ }
+
+/* Unroll last two steps. */
+
+ *dnm2 = d__;
+ *dmin2 = *dmin__;
+ j4 = (*n0 - 2 << 2) - *pp;
+ j4p2 = j4 + (*pp << 1) - 1;
+ z__[j4 - 2] = *dnm2 + z__[j4p2];
+ if (*dnm2 < 0.f) {
+ return 0;
+ } else {
+ z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
+ *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau;
+ }
+ *dmin__ = dmin(*dmin__,*dnm1);
+
+ *dmin1 = *dmin__;
+ j4 += 4;
+ j4p2 = j4 + (*pp << 1) - 1;
+ z__[j4 - 2] = *dnm1 + z__[j4p2];
+ if (*dnm1 < 0.f) {
+ return 0;
+ } else {
+ z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
+ *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau;
+ }
+ *dmin__ = dmin(*dmin__,*dn);
+
+ }
+
+ z__[j4 + 2] = *dn;
+ z__[(*n0 << 2) - *pp] = emin;
+ return 0;
+
+/* End of SLASQ5 */
+
+} /* slasq5_ */
diff --git a/SRC/slasq6.c b/SRC/slasq6.c
new file mode 100644
index 0000000..b856800
--- /dev/null
+++ b/SRC/slasq6.c
@@ -0,0 +1,212 @@
+/* slasq6.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slasq6_(integer *i0, integer *n0, real *z__, integer *pp,
+ real *dmin__, real *dmin1, real *dmin2, real *dn, real *dnm1, real *
+ dnm2)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ real d__;
+ integer j4, j4p2;
+ real emin, temp;
+ extern doublereal slamch_(char *);
+ real safmin;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
+/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
+/* -- Berkeley -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASQ6 computes one dqd (shift equal to zero) transform in */
+/* ping-pong form, with protection against underflow and overflow. */
+
+/* Arguments */
+/* ========= */
+
+/* I0 (input) INTEGER */
+/* First index. */
+
+/* N0 (input) INTEGER */
+/* Last index. */
+
+/* Z (input) REAL array, dimension ( 4*N ) */
+/* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid */
+/* an extra argument. */
+
+/* PP (input) INTEGER */
+/* PP=0 for ping, PP=1 for pong. */
+
+/* DMIN (output) REAL */
+/* Minimum value of d. */
+
+/* DMIN1 (output) REAL */
+/* Minimum value of d, excluding D( N0 ). */
+
+/* DMIN2 (output) REAL */
+/* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */
+
+/* DN (output) REAL */
+/* d(N0), the last value of d. */
+
+/* DNM1 (output) REAL */
+/* d(N0-1). */
+
+/* DNM2 (output) REAL */
+/* d(N0-2). */
+
+/* ===================================================================== */
+
+/* .. Parameter .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Function .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --z__;
+
+ /* Function Body */
+ if (*n0 - *i0 - 1 <= 0) {
+ return 0;
+ }
+
+ safmin = slamch_("Safe minimum");
+ j4 = (*i0 << 2) + *pp - 3;
+ emin = z__[j4 + 4];
+ d__ = z__[j4];
+ *dmin__ = d__;
+
+ if (*pp == 0) {
+ i__1 = *n0 - 3 << 2;
+ for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
+ z__[j4 - 2] = d__ + z__[j4 - 1];
+ if (z__[j4 - 2] == 0.f) {
+ z__[j4] = 0.f;
+ d__ = z__[j4 + 1];
+ *dmin__ = d__;
+ emin = 0.f;
+ } else if (safmin * z__[j4 + 1] < z__[j4 - 2] && safmin * z__[j4
+ - 2] < z__[j4 + 1]) {
+ temp = z__[j4 + 1] / z__[j4 - 2];
+ z__[j4] = z__[j4 - 1] * temp;
+ d__ *= temp;
+ } else {
+ z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]);
+ d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]);
+ }
+ *dmin__ = dmin(*dmin__,d__);
+/* Computing MIN */
+ r__1 = emin, r__2 = z__[j4];
+ emin = dmin(r__1,r__2);
+/* L10: */
+ }
+ } else {
+ i__1 = *n0 - 3 << 2;
+ for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
+ z__[j4 - 3] = d__ + z__[j4];
+ if (z__[j4 - 3] == 0.f) {
+ z__[j4 - 1] = 0.f;
+ d__ = z__[j4 + 2];
+ *dmin__ = d__;
+ emin = 0.f;
+ } else if (safmin * z__[j4 + 2] < z__[j4 - 3] && safmin * z__[j4
+ - 3] < z__[j4 + 2]) {
+ temp = z__[j4 + 2] / z__[j4 - 3];
+ z__[j4 - 1] = z__[j4] * temp;
+ d__ *= temp;
+ } else {
+ z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]);
+ d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]);
+ }
+ *dmin__ = dmin(*dmin__,d__);
+/* Computing MIN */
+ r__1 = emin, r__2 = z__[j4 - 1];
+ emin = dmin(r__1,r__2);
+/* L20: */
+ }
+ }
+
+/* Unroll last two steps. */
+
+ *dnm2 = d__;
+ *dmin2 = *dmin__;
+ j4 = (*n0 - 2 << 2) - *pp;
+ j4p2 = j4 + (*pp << 1) - 1;
+ z__[j4 - 2] = *dnm2 + z__[j4p2];
+ if (z__[j4 - 2] == 0.f) {
+ z__[j4] = 0.f;
+ *dnm1 = z__[j4p2 + 2];
+ *dmin__ = *dnm1;
+ emin = 0.f;
+ } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] <
+ z__[j4p2 + 2]) {
+ temp = z__[j4p2 + 2] / z__[j4 - 2];
+ z__[j4] = z__[j4p2] * temp;
+ *dnm1 = *dnm2 * temp;
+ } else {
+ z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
+ *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]);
+ }
+ *dmin__ = dmin(*dmin__,*dnm1);
+
+ *dmin1 = *dmin__;
+ j4 += 4;
+ j4p2 = j4 + (*pp << 1) - 1;
+ z__[j4 - 2] = *dnm1 + z__[j4p2];
+ if (z__[j4 - 2] == 0.f) {
+ z__[j4] = 0.f;
+ *dn = z__[j4p2 + 2];
+ *dmin__ = *dn;
+ emin = 0.f;
+ } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] <
+ z__[j4p2 + 2]) {
+ temp = z__[j4p2 + 2] / z__[j4 - 2];
+ z__[j4] = z__[j4p2] * temp;
+ *dn = *dnm1 * temp;
+ } else {
+ z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
+ *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]);
+ }
+ *dmin__ = dmin(*dmin__,*dn);
+
+ z__[j4 + 2] = *dn;
+ z__[(*n0 << 2) - *pp] = emin;
+ return 0;
+
+/* End of SLASQ6 */
+
+} /* slasq6_ */
diff --git a/SRC/slasr.c b/SRC/slasr.c
new file mode 100644
index 0000000..2b22242
--- /dev/null
+++ b/SRC/slasr.c
@@ -0,0 +1,452 @@
+/* slasr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slasr_(char *side, char *pivot, char *direct, integer *m,
+ integer *n, real *c__, real *s, real *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, info;
+ real temp;
+ extern logical lsame_(char *, char *);
+ real ctemp, stemp;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASR applies a sequence of plane rotations to a real matrix A, */
+/* from either the left or the right. */
+
+/* When SIDE = 'L', the transformation takes the form */
+
+/* A := P*A */
+
+/* and when SIDE = 'R', the transformation takes the form */
+
+/* A := A*P**T */
+
+/* where P is an orthogonal matrix consisting of a sequence of z plane */
+/* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', */
+/* and P**T is the transpose of P. */
+
+/* When DIRECT = 'F' (Forward sequence), then */
+
+/* P = P(z-1) * ... * P(2) * P(1) */
+
+/* and when DIRECT = 'B' (Backward sequence), then */
+
+/* P = P(1) * P(2) * ... * P(z-1) */
+
+/* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation */
+
+/* R(k) = ( c(k) s(k) ) */
+/* = ( -s(k) c(k) ). */
+
+/* When PIVOT = 'V' (Variable pivot), the rotation is performed */
+/* for the plane (k,k+1), i.e., P(k) has the form */
+
+/* P(k) = ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+/* ( c(k) s(k) ) */
+/* ( -s(k) c(k) ) */
+/* ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+
+/* where R(k) appears as a rank-2 modification to the identity matrix in */
+/* rows and columns k and k+1. */
+
+/* When PIVOT = 'T' (Top pivot), the rotation is performed for the */
+/* plane (1,k+1), so P(k) has the form */
+
+/* P(k) = ( c(k) s(k) ) */
+/* ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+/* ( -s(k) c(k) ) */
+/* ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+
+/* where R(k) appears in rows and columns 1 and k+1. */
+
+/* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is */
+/* performed for the plane (k,z), giving P(k) the form */
+
+/* P(k) = ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+/* ( c(k) s(k) ) */
+/* ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+/* ( -s(k) c(k) ) */
+
+/* where R(k) appears in rows and columns k and z. The rotations are */
+/* performed without ever forming P(k) explicitly. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* Specifies whether the plane rotation matrix P is applied to */
+/* A on the left or the right. */
+/* = 'L': Left, compute A := P*A */
+/* = 'R': Right, compute A:= A*P**T */
+
+/* PIVOT (input) CHARACTER*1 */
+/* Specifies the plane for which P(k) is a plane rotation */
+/* matrix. */
+/* = 'V': Variable pivot, the plane (k,k+1) */
+/* = 'T': Top pivot, the plane (1,k+1) */
+/* = 'B': Bottom pivot, the plane (k,z) */
+
+/* DIRECT (input) CHARACTER*1 */
+/* Specifies whether P is a forward or backward sequence of */
+/* plane rotations. */
+/* = 'F': Forward, P = P(z-1)*...*P(2)*P(1) */
+/* = 'B': Backward, P = P(1)*P(2)*...*P(z-1) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. If m <= 1, an immediate */
+/* return is effected. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. If n <= 1, an */
+/* immediate return is effected. */
+
+/* C (input) REAL array, dimension */
+/* (M-1) if SIDE = 'L' */
+/* (N-1) if SIDE = 'R' */
+/* The cosines c(k) of the plane rotations. */
+
+/* S (input) REAL array, dimension */
+/* (M-1) if SIDE = 'L' */
+/* (N-1) if SIDE = 'R' */
+/* The sines s(k) of the plane rotations. The 2-by-2 plane */
+/* rotation part of the matrix P(k), R(k), has the form */
+/* R(k) = ( c(k) s(k) ) */
+/* ( -s(k) c(k) ). */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* The M-by-N matrix A. On exit, A is overwritten by P*A if */
+/* SIDE = 'R' or by A*P**T if SIDE = 'L'. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ --c__;
+ --s;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ info = 0;
+ if (! (lsame_(side, "L") || lsame_(side, "R"))) {
+ info = 1;
+ } else if (! (lsame_(pivot, "V") || lsame_(pivot,
+ "T") || lsame_(pivot, "B"))) {
+ info = 2;
+ } else if (! (lsame_(direct, "F") || lsame_(direct,
+ "B"))) {
+ info = 3;
+ } else if (*m < 0) {
+ info = 4;
+ } else if (*n < 0) {
+ info = 5;
+ } else if (*lda < max(1,*m)) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("SLASR ", &info);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+ if (lsame_(side, "L")) {
+
+/* Form P * A */
+
+ if (lsame_(pivot, "V")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = a[j + 1 + i__ * a_dim1];
+ a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp *
+ a[j + i__ * a_dim1];
+ a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j
+ + i__ * a_dim1];
+/* L10: */
+ }
+ }
+/* L20: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *m - 1; j >= 1; --j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = a[j + 1 + i__ * a_dim1];
+ a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp *
+ a[j + i__ * a_dim1];
+ a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j
+ + i__ * a_dim1];
+/* L30: */
+ }
+ }
+/* L40: */
+ }
+ }
+ } else if (lsame_(pivot, "T")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *m;
+ for (j = 2; j <= i__1; ++j) {
+ ctemp = c__[j - 1];
+ stemp = s[j - 1];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = a[j + i__ * a_dim1];
+ a[j + i__ * a_dim1] = ctemp * temp - stemp * a[
+ i__ * a_dim1 + 1];
+ a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[
+ i__ * a_dim1 + 1];
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *m; j >= 2; --j) {
+ ctemp = c__[j - 1];
+ stemp = s[j - 1];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = a[j + i__ * a_dim1];
+ a[j + i__ * a_dim1] = ctemp * temp - stemp * a[
+ i__ * a_dim1 + 1];
+ a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[
+ i__ * a_dim1 + 1];
+/* L70: */
+ }
+ }
+/* L80: */
+ }
+ }
+ } else if (lsame_(pivot, "B")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = a[j + i__ * a_dim1];
+ a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1]
+ + ctemp * temp;
+ a[*m + i__ * a_dim1] = ctemp * a[*m + i__ *
+ a_dim1] - stemp * temp;
+/* L90: */
+ }
+ }
+/* L100: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *m - 1; j >= 1; --j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = a[j + i__ * a_dim1];
+ a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1]
+ + ctemp * temp;
+ a[*m + i__ * a_dim1] = ctemp * a[*m + i__ *
+ a_dim1] - stemp * temp;
+/* L110: */
+ }
+ }
+/* L120: */
+ }
+ }
+ }
+ } else if (lsame_(side, "R")) {
+
+/* Form A * P' */
+
+ if (lsame_(pivot, "V")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = a[i__ + (j + 1) * a_dim1];
+ a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp *
+ a[i__ + j * a_dim1];
+ a[i__ + j * a_dim1] = stemp * temp + ctemp * a[
+ i__ + j * a_dim1];
+/* L130: */
+ }
+ }
+/* L140: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *n - 1; j >= 1; --j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = a[i__ + (j + 1) * a_dim1];
+ a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp *
+ a[i__ + j * a_dim1];
+ a[i__ + j * a_dim1] = stemp * temp + ctemp * a[
+ i__ + j * a_dim1];
+/* L150: */
+ }
+ }
+/* L160: */
+ }
+ }
+ } else if (lsame_(pivot, "T")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ ctemp = c__[j - 1];
+ stemp = s[j - 1];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = a[i__ + j * a_dim1];
+ a[i__ + j * a_dim1] = ctemp * temp - stemp * a[
+ i__ + a_dim1];
+ a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ +
+ a_dim1];
+/* L170: */
+ }
+ }
+/* L180: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *n; j >= 2; --j) {
+ ctemp = c__[j - 1];
+ stemp = s[j - 1];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = a[i__ + j * a_dim1];
+ a[i__ + j * a_dim1] = ctemp * temp - stemp * a[
+ i__ + a_dim1];
+ a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ +
+ a_dim1];
+/* L190: */
+ }
+ }
+/* L200: */
+ }
+ }
+ } else if (lsame_(pivot, "B")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = a[i__ + j * a_dim1];
+ a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1]
+ + ctemp * temp;
+ a[i__ + *n * a_dim1] = ctemp * a[i__ + *n *
+ a_dim1] - stemp * temp;
+/* L210: */
+ }
+ }
+/* L220: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *n - 1; j >= 1; --j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1.f || stemp != 0.f) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = a[i__ + j * a_dim1];
+ a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1]
+ + ctemp * temp;
+ a[i__ + *n * a_dim1] = ctemp * a[i__ + *n *
+ a_dim1] - stemp * temp;
+/* L230: */
+ }
+ }
+/* L240: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SLASR */
+
+} /* slasr_ */
diff --git a/SRC/slasrt.c b/SRC/slasrt.c
new file mode 100644
index 0000000..d844db5
--- /dev/null
+++ b/SRC/slasrt.c
@@ -0,0 +1,285 @@
+/* slasrt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slasrt_(char *id, integer *n, real *d__, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ real d1, d2, d3;
+ integer dir;
+ real tmp;
+ integer endd;
+ extern logical lsame_(char *, char *);
+ integer stack[64] /* was [2][32] */;
+ real dmnmx;
+ integer start;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer stkpnt;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Sort the numbers in D in increasing order (if ID = 'I') or */
+/* in decreasing order (if ID = 'D' ). */
+
+/* Use Quick Sort, reverting to Insertion sort on arrays of */
+/* size <= 20. Dimension of STACK limits N to about 2**32. */
+
+/* Arguments */
+/* ========= */
+
+/* ID (input) CHARACTER*1 */
+/* = 'I': sort D in increasing order; */
+/* = 'D': sort D in decreasing order. */
+
+/* N (input) INTEGER */
+/* The length of the array D. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the array to be sorted. */
+/* On exit, D has been sorted into increasing order */
+/* (D(1) <= ... <= D(N) ) or into decreasing order */
+/* (D(1) >= ... >= D(N) ), depending on ID. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input paramters. */
+
+ /* Parameter adjustments */
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+ dir = -1;
+ if (lsame_(id, "D")) {
+ dir = 0;
+ } else if (lsame_(id, "I")) {
+ dir = 1;
+ }
+ if (dir == -1) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLASRT", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 1) {
+ return 0;
+ }
+
+ stkpnt = 1;
+ stack[0] = 1;
+ stack[1] = *n;
+L10:
+ start = stack[(stkpnt << 1) - 2];
+ endd = stack[(stkpnt << 1) - 1];
+ --stkpnt;
+ if (endd - start <= 20 && endd - start > 0) {
+
+/* Do Insertion sort on D( START:ENDD ) */
+
+ if (dir == 0) {
+
+/* Sort into decreasing order */
+
+ i__1 = endd;
+ for (i__ = start + 1; i__ <= i__1; ++i__) {
+ i__2 = start + 1;
+ for (j = i__; j >= i__2; --j) {
+ if (d__[j] > d__[j - 1]) {
+ dmnmx = d__[j];
+ d__[j] = d__[j - 1];
+ d__[j - 1] = dmnmx;
+ } else {
+ goto L30;
+ }
+/* L20: */
+ }
+L30:
+ ;
+ }
+
+ } else {
+
+/* Sort into increasing order */
+
+ i__1 = endd;
+ for (i__ = start + 1; i__ <= i__1; ++i__) {
+ i__2 = start + 1;
+ for (j = i__; j >= i__2; --j) {
+ if (d__[j] < d__[j - 1]) {
+ dmnmx = d__[j];
+ d__[j] = d__[j - 1];
+ d__[j - 1] = dmnmx;
+ } else {
+ goto L50;
+ }
+/* L40: */
+ }
+L50:
+ ;
+ }
+
+ }
+
+ } else if (endd - start > 20) {
+
+/* Partition D( START:ENDD ) and stack parts, largest one first */
+
+/* Choose partition entry as median of 3 */
+
+ d1 = d__[start];
+ d2 = d__[endd];
+ i__ = (start + endd) / 2;
+ d3 = d__[i__];
+ if (d1 < d2) {
+ if (d3 < d1) {
+ dmnmx = d1;
+ } else if (d3 < d2) {
+ dmnmx = d3;
+ } else {
+ dmnmx = d2;
+ }
+ } else {
+ if (d3 < d2) {
+ dmnmx = d2;
+ } else if (d3 < d1) {
+ dmnmx = d3;
+ } else {
+ dmnmx = d1;
+ }
+ }
+
+ if (dir == 0) {
+
+/* Sort into decreasing order */
+
+ i__ = start - 1;
+ j = endd + 1;
+L60:
+L70:
+ --j;
+ if (d__[j] < dmnmx) {
+ goto L70;
+ }
+L80:
+ ++i__;
+ if (d__[i__] > dmnmx) {
+ goto L80;
+ }
+ if (i__ < j) {
+ tmp = d__[i__];
+ d__[i__] = d__[j];
+ d__[j] = tmp;
+ goto L60;
+ }
+ if (j - start > endd - j - 1) {
+ ++stkpnt;
+ stack[(stkpnt << 1) - 2] = start;
+ stack[(stkpnt << 1) - 1] = j;
+ ++stkpnt;
+ stack[(stkpnt << 1) - 2] = j + 1;
+ stack[(stkpnt << 1) - 1] = endd;
+ } else {
+ ++stkpnt;
+ stack[(stkpnt << 1) - 2] = j + 1;
+ stack[(stkpnt << 1) - 1] = endd;
+ ++stkpnt;
+ stack[(stkpnt << 1) - 2] = start;
+ stack[(stkpnt << 1) - 1] = j;
+ }
+ } else {
+
+/* Sort into increasing order */
+
+ i__ = start - 1;
+ j = endd + 1;
+L90:
+L100:
+ --j;
+ if (d__[j] > dmnmx) {
+ goto L100;
+ }
+L110:
+ ++i__;
+ if (d__[i__] < dmnmx) {
+ goto L110;
+ }
+ if (i__ < j) {
+ tmp = d__[i__];
+ d__[i__] = d__[j];
+ d__[j] = tmp;
+ goto L90;
+ }
+ if (j - start > endd - j - 1) {
+ ++stkpnt;
+ stack[(stkpnt << 1) - 2] = start;
+ stack[(stkpnt << 1) - 1] = j;
+ ++stkpnt;
+ stack[(stkpnt << 1) - 2] = j + 1;
+ stack[(stkpnt << 1) - 1] = endd;
+ } else {
+ ++stkpnt;
+ stack[(stkpnt << 1) - 2] = j + 1;
+ stack[(stkpnt << 1) - 1] = endd;
+ ++stkpnt;
+ stack[(stkpnt << 1) - 2] = start;
+ stack[(stkpnt << 1) - 1] = j;
+ }
+ }
+ }
+ if (stkpnt > 0) {
+ goto L10;
+ }
+ return 0;
+
+/* End of SLASRT */
+
+} /* slasrt_ */
diff --git a/SRC/slassq.c b/SRC/slassq.c
new file mode 100644
index 0000000..56f3f93
--- /dev/null
+++ b/SRC/slassq.c
@@ -0,0 +1,116 @@
+/* slassq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slassq_(integer *n, real *x, integer *incx, real *scale,
+ real *sumsq)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real r__1;
+
+ /* Local variables */
+ integer ix;
+ real absxi;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASSQ returns the values scl and smsq such that */
+
+/* ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, */
+
+/* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is */
+/* assumed to be non-negative and scl returns the value */
+
+/* scl = max( scale, abs( x( i ) ) ). */
+
+/* scale and sumsq must be supplied in SCALE and SUMSQ and */
+/* scl and smsq are overwritten on SCALE and SUMSQ respectively. */
+
+/* The routine makes only one pass through the vector x. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of elements to be used from the vector X. */
+
+/* X (input) REAL array, dimension (N) */
+/* The vector for which a scaled sum of squares is computed. */
+/* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. */
+
+/* INCX (input) INTEGER */
+/* The increment between successive values of the vector X. */
+/* INCX > 0. */
+
+/* SCALE (input/output) REAL */
+/* On entry, the value scale in the equation above. */
+/* On exit, SCALE is overwritten with scl , the scaling factor */
+/* for the sum of squares. */
+
+/* SUMSQ (input/output) REAL */
+/* On entry, the value sumsq in the equation above. */
+/* On exit, SUMSQ is overwritten with smsq , the basic sum of */
+/* squares from which scl has been factored out. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --x;
+
+ /* Function Body */
+ if (*n > 0) {
+ i__1 = (*n - 1) * *incx + 1;
+ i__2 = *incx;
+ for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
+ if (x[ix] != 0.f) {
+ absxi = (r__1 = x[ix], dabs(r__1));
+ if (*scale < absxi) {
+/* Computing 2nd power */
+ r__1 = *scale / absxi;
+ *sumsq = *sumsq * (r__1 * r__1) + 1;
+ *scale = absxi;
+ } else {
+/* Computing 2nd power */
+ r__1 = absxi / *scale;
+ *sumsq += r__1 * r__1;
+ }
+ }
+/* L10: */
+ }
+ }
+ return 0;
+
+/* End of SLASSQ */
+
+} /* slassq_ */
diff --git a/SRC/slasv2.c b/SRC/slasv2.c
new file mode 100644
index 0000000..9fdca48
--- /dev/null
+++ b/SRC/slasv2.c
@@ -0,0 +1,273 @@
+/* slasv2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b3 = 2.f;
+static real c_b4 = 1.f;
+
+/* Subroutine */ int slasv2_(real *f, real *g, real *h__, real *ssmin, real *
+ ssmax, real *snr, real *csr, real *snl, real *csl)
+{
+ /* System generated locals */
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_sign(real *, real *);
+
+ /* Local variables */
+ real a, d__, l, m, r__, s, t, fa, ga, ha, ft, gt, ht, mm, tt, clt, crt,
+ slt, srt;
+ integer pmax;
+ real temp;
+ logical swap;
+ real tsign;
+ logical gasmal;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASV2 computes the singular value decomposition of a 2-by-2 */
+/* triangular matrix */
+/* [ F G ] */
+/* [ 0 H ]. */
+/* On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the */
+/* smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and */
+/* right singular vectors for abs(SSMAX), giving the decomposition */
+
+/* [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] */
+/* [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. */
+
+/* Arguments */
+/* ========= */
+
+/* F (input) REAL */
+/* The (1,1) element of the 2-by-2 matrix. */
+
+/* G (input) REAL */
+/* The (1,2) element of the 2-by-2 matrix. */
+
+/* H (input) REAL */
+/* The (2,2) element of the 2-by-2 matrix. */
+
+/* SSMIN (output) REAL */
+/* abs(SSMIN) is the smaller singular value. */
+
+/* SSMAX (output) REAL */
+/* abs(SSMAX) is the larger singular value. */
+
+/* SNL (output) REAL */
+/* CSL (output) REAL */
+/* The vector (CSL, SNL) is a unit left singular vector for the */
+/* singular value abs(SSMAX). */
+
+/* SNR (output) REAL */
+/* CSR (output) REAL */
+/* The vector (CSR, SNR) is a unit right singular vector for the */
+/* singular value abs(SSMAX). */
+
+/* Further Details */
+/* =============== */
+
+/* Any input parameter may be aliased with any output parameter. */
+
+/* Barring over/underflow and assuming a guard digit in subtraction, all */
+/* output quantities are correct to within a few units in the last */
+/* place (ulps). */
+
+/* In IEEE arithmetic, the code works correctly if one matrix element is */
+/* infinite. */
+
+/* Overflow will not occur unless the largest singular value itself */
+/* overflows or is within a few ulps of overflow. (On machines with */
+/* partial overflow, like the Cray, overflow may occur if the largest */
+/* singular value is within a factor of 2 of overflow.) */
+
+/* Underflow is harmless if underflow is gradual. Otherwise, results */
+/* may correspond to a matrix modified by perturbations of size near */
+/* the underflow threshold. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ ft = *f;
+ fa = dabs(ft);
+ ht = *h__;
+ ha = dabs(*h__);
+
+/* PMAX points to the maximum absolute element of matrix */
+/* PMAX = 1 if F largest in absolute values */
+/* PMAX = 2 if G largest in absolute values */
+/* PMAX = 3 if H largest in absolute values */
+
+ pmax = 1;
+ swap = ha > fa;
+ if (swap) {
+ pmax = 3;
+ temp = ft;
+ ft = ht;
+ ht = temp;
+ temp = fa;
+ fa = ha;
+ ha = temp;
+
+/* Now FA .ge. HA */
+
+ }
+ gt = *g;
+ ga = dabs(gt);
+ if (ga == 0.f) {
+
+/* Diagonal matrix */
+
+ *ssmin = ha;
+ *ssmax = fa;
+ clt = 1.f;
+ crt = 1.f;
+ slt = 0.f;
+ srt = 0.f;
+ } else {
+ gasmal = TRUE_;
+ if (ga > fa) {
+ pmax = 2;
+ if (fa / ga < slamch_("EPS")) {
+
+/* Case of very large GA */
+
+ gasmal = FALSE_;
+ *ssmax = ga;
+ if (ha > 1.f) {
+ *ssmin = fa / (ga / ha);
+ } else {
+ *ssmin = fa / ga * ha;
+ }
+ clt = 1.f;
+ slt = ht / gt;
+ srt = 1.f;
+ crt = ft / gt;
+ }
+ }
+ if (gasmal) {
+
+/* Normal case */
+
+ d__ = fa - ha;
+ if (d__ == fa) {
+
+/* Copes with infinite F or H */
+
+ l = 1.f;
+ } else {
+ l = d__ / fa;
+ }
+
+/* Note that 0 .le. L .le. 1 */
+
+ m = gt / ft;
+
+/* Note that abs(M) .le. 1/macheps */
+
+ t = 2.f - l;
+
+/* Note that T .ge. 1 */
+
+ mm = m * m;
+ tt = t * t;
+ s = sqrt(tt + mm);
+
+/* Note that 1 .le. S .le. 1 + 1/macheps */
+
+ if (l == 0.f) {
+ r__ = dabs(m);
+ } else {
+ r__ = sqrt(l * l + mm);
+ }
+
+/* Note that 0 .le. R .le. 1 + 1/macheps */
+
+ a = (s + r__) * .5f;
+
+/* Note that 1 .le. A .le. 1 + abs(M) */
+
+ *ssmin = ha / a;
+ *ssmax = fa * a;
+ if (mm == 0.f) {
+
+/* Note that M is very tiny */
+
+ if (l == 0.f) {
+ t = r_sign(&c_b3, &ft) * r_sign(&c_b4, >);
+ } else {
+ t = gt / r_sign(&d__, &ft) + m / t;
+ }
+ } else {
+ t = (m / (s + t) + m / (r__ + l)) * (a + 1.f);
+ }
+ l = sqrt(t * t + 4.f);
+ crt = 2.f / l;
+ srt = t / l;
+ clt = (crt + srt * m) / a;
+ slt = ht / ft * srt / a;
+ }
+ }
+ if (swap) {
+ *csl = srt;
+ *snl = crt;
+ *csr = slt;
+ *snr = clt;
+ } else {
+ *csl = clt;
+ *snl = slt;
+ *csr = crt;
+ *snr = srt;
+ }
+
+/* Correct signs of SSMAX and SSMIN */
+
+ if (pmax == 1) {
+ tsign = r_sign(&c_b4, csr) * r_sign(&c_b4, csl) * r_sign(&c_b4, f);
+ }
+ if (pmax == 2) {
+ tsign = r_sign(&c_b4, snr) * r_sign(&c_b4, csl) * r_sign(&c_b4, g);
+ }
+ if (pmax == 3) {
+ tsign = r_sign(&c_b4, snr) * r_sign(&c_b4, snl) * r_sign(&c_b4, h__);
+ }
+ *ssmax = r_sign(ssmax, &tsign);
+ r__1 = tsign * r_sign(&c_b4, f) * r_sign(&c_b4, h__);
+ *ssmin = r_sign(ssmin, &r__1);
+ return 0;
+
+/* End of SLASV2 */
+
+} /* slasv2_ */
diff --git a/SRC/slaswp.c b/SRC/slaswp.c
new file mode 100644
index 0000000..d89ee03
--- /dev/null
+++ b/SRC/slaswp.c
@@ -0,0 +1,158 @@
+/* slaswp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slaswp_(integer *n, real *a, integer *lda, integer *k1,
+ integer *k2, integer *ipiv, integer *incx)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, k, i1, i2, n32, ip, ix, ix0, inc;
+ real temp;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASWP performs a series of row interchanges on the matrix A. */
+/* One row interchange is initiated for each of rows K1 through K2 of A. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the matrix of column dimension N to which the row */
+/* interchanges will be applied. */
+/* On exit, the permuted matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* K1 (input) INTEGER */
+/* The first element of IPIV for which a row interchange will */
+/* be done. */
+
+/* K2 (input) INTEGER */
+/* The last element of IPIV for which a row interchange will */
+/* be done. */
+
+/* IPIV (input) INTEGER array, dimension (K2*abs(INCX)) */
+/* The vector of pivot indices. Only the elements in positions */
+/* K1 through K2 of IPIV are accessed. */
+/* IPIV(K) = L implies rows K and L are to be interchanged. */
+
+/* INCX (input) INTEGER */
+/* The increment between successive values of IPIV. If IPIV */
+/* is negative, the pivots are applied in reverse order. */
+
+/* Further Details */
+/* =============== */
+
+/* Modified by */
+/* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Interchange row I with row IPIV(I) for each of rows K1 through K2. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ if (*incx > 0) {
+ ix0 = *k1;
+ i1 = *k1;
+ i2 = *k2;
+ inc = 1;
+ } else if (*incx < 0) {
+ ix0 = (1 - *k2) * *incx + 1;
+ i1 = *k2;
+ i2 = *k1;
+ inc = -1;
+ } else {
+ return 0;
+ }
+
+ n32 = *n / 32 << 5;
+ if (n32 != 0) {
+ i__1 = n32;
+ for (j = 1; j <= i__1; j += 32) {
+ ix = ix0;
+ i__2 = i2;
+ i__3 = inc;
+ for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3)
+ {
+ ip = ipiv[ix];
+ if (ip != i__) {
+ i__4 = j + 31;
+ for (k = j; k <= i__4; ++k) {
+ temp = a[i__ + k * a_dim1];
+ a[i__ + k * a_dim1] = a[ip + k * a_dim1];
+ a[ip + k * a_dim1] = temp;
+/* L10: */
+ }
+ }
+ ix += *incx;
+/* L20: */
+ }
+/* L30: */
+ }
+ }
+ if (n32 != *n) {
+ ++n32;
+ ix = ix0;
+ i__1 = i2;
+ i__3 = inc;
+ for (i__ = i1; i__3 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__3) {
+ ip = ipiv[ix];
+ if (ip != i__) {
+ i__2 = *n;
+ for (k = n32; k <= i__2; ++k) {
+ temp = a[i__ + k * a_dim1];
+ a[i__ + k * a_dim1] = a[ip + k * a_dim1];
+ a[ip + k * a_dim1] = temp;
+/* L40: */
+ }
+ }
+ ix += *incx;
+/* L50: */
+ }
+ }
+
+ return 0;
+
+/* End of SLASWP */
+
+} /* slaswp_ */
diff --git a/SRC/slasy2.c b/SRC/slasy2.c
new file mode 100644
index 0000000..1f8e1c2
--- /dev/null
+++ b/SRC/slasy2.c
@@ -0,0 +1,479 @@
+/* slasy2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__4 = 4;
+static integer c__1 = 1;
+static integer c__16 = 16;
+static integer c__0 = 0;
+
+/* Subroutine */ int slasy2_(logical *ltranl, logical *ltranr, integer *isgn,
+ integer *n1, integer *n2, real *tl, integer *ldtl, real *tr, integer *
+ ldtr, real *b, integer *ldb, real *scale, real *x, integer *ldx, real
+ *xnorm, integer *info)
+{
+ /* Initialized data */
+
+ static integer locu12[4] = { 3,4,1,2 };
+ static integer locl21[4] = { 2,1,4,3 };
+ static integer locu22[4] = { 4,3,2,1 };
+ static logical xswpiv[4] = { FALSE_,FALSE_,TRUE_,TRUE_ };
+ static logical bswpiv[4] = { FALSE_,TRUE_,FALSE_,TRUE_ };
+
+ /* System generated locals */
+ integer b_dim1, b_offset, tl_dim1, tl_offset, tr_dim1, tr_offset, x_dim1,
+ x_offset;
+ real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8;
+
+ /* Local variables */
+ integer i__, j, k;
+ real x2[2], l21, u11, u12;
+ integer ip, jp;
+ real u22, t16[16] /* was [4][4] */, gam, bet, eps, sgn, tmp[4], tau1,
+ btmp[4], smin;
+ integer ipiv;
+ real temp;
+ integer jpiv[4];
+ real xmax;
+ integer ipsv, jpsv;
+ logical bswap;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), sswap_(integer *, real *, integer *, real *, integer *
+);
+ logical xswap;
+ extern doublereal slamch_(char *);
+ extern integer isamax_(integer *, real *, integer *);
+ real smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in */
+
+/* op(TL)*X + ISGN*X*op(TR) = SCALE*B, */
+
+/* where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or */
+/* -1. op(T) = T or T', where T' denotes the transpose of T. */
+
+/* Arguments */
+/* ========= */
+
+/* LTRANL (input) LOGICAL */
+/* On entry, LTRANL specifies the op(TL): */
+/* = .FALSE., op(TL) = TL, */
+/* = .TRUE., op(TL) = TL'. */
+
+/* LTRANR (input) LOGICAL */
+/* On entry, LTRANR specifies the op(TR): */
+/* = .FALSE., op(TR) = TR, */
+/* = .TRUE., op(TR) = TR'. */
+
+/* ISGN (input) INTEGER */
+/* On entry, ISGN specifies the sign of the equation */
+/* as described before. ISGN may only be 1 or -1. */
+
+/* N1 (input) INTEGER */
+/* On entry, N1 specifies the order of matrix TL. */
+/* N1 may only be 0, 1 or 2. */
+
+/* N2 (input) INTEGER */
+/* On entry, N2 specifies the order of matrix TR. */
+/* N2 may only be 0, 1 or 2. */
+
+/* TL (input) REAL array, dimension (LDTL,2) */
+/* On entry, TL contains an N1 by N1 matrix. */
+
+/* LDTL (input) INTEGER */
+/* The leading dimension of the matrix TL. LDTL >= max(1,N1). */
+
+/* TR (input) REAL array, dimension (LDTR,2) */
+/* On entry, TR contains an N2 by N2 matrix. */
+
+/* LDTR (input) INTEGER */
+/* The leading dimension of the matrix TR. LDTR >= max(1,N2). */
+
+/* B (input) REAL array, dimension (LDB,2) */
+/* On entry, the N1 by N2 matrix B contains the right-hand */
+/* side of the equation. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the matrix B. LDB >= max(1,N1). */
+
+/* SCALE (output) REAL */
+/* On exit, SCALE contains the scale factor. SCALE is chosen */
+/* less than or equal to 1 to prevent the solution overflowing. */
+
+/* X (output) REAL array, dimension (LDX,2) */
+/* On exit, X contains the N1 by N2 solution. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the matrix X. LDX >= max(1,N1). */
+
+/* XNORM (output) REAL */
+/* On exit, XNORM is the infinity-norm of the solution. */
+
+/* INFO (output) INTEGER */
+/* On exit, INFO is set to */
+/* 0: successful exit. */
+/* 1: TL and TR have too close eigenvalues, so TL or */
+/* TR is perturbed to get a nonsingular equation. */
+/* NOTE: In the interests of speed, this routine does not */
+/* check the inputs for errors. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ tl_dim1 = *ldtl;
+ tl_offset = 1 + tl_dim1;
+ tl -= tl_offset;
+ tr_dim1 = *ldtr;
+ tr_offset = 1 + tr_dim1;
+ tr -= tr_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Do not check the input parameters for errors */
+
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n1 == 0 || *n2 == 0) {
+ return 0;
+ }
+
+/* Set constants to control overflow */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S") / eps;
+ sgn = (real) (*isgn);
+
+ k = *n1 + *n1 + *n2 - 2;
+ switch (k) {
+ case 1: goto L10;
+ case 2: goto L20;
+ case 3: goto L30;
+ case 4: goto L50;
+ }
+
+/* 1 by 1: TL11*X + SGN*X*TR11 = B11 */
+
+L10:
+ tau1 = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1];
+ bet = dabs(tau1);
+ if (bet <= smlnum) {
+ tau1 = smlnum;
+ bet = smlnum;
+ *info = 1;
+ }
+
+ *scale = 1.f;
+ gam = (r__1 = b[b_dim1 + 1], dabs(r__1));
+ if (smlnum * gam > bet) {
+ *scale = 1.f / gam;
+ }
+
+ x[x_dim1 + 1] = b[b_dim1 + 1] * *scale / tau1;
+ *xnorm = (r__1 = x[x_dim1 + 1], dabs(r__1));
+ return 0;
+
+/* 1 by 2: */
+/* TL11*[X11 X12] + ISGN*[X11 X12]*op[TR11 TR12] = [B11 B12] */
+/* [TR21 TR22] */
+
+L20:
+
+/* Computing MAX */
+/* Computing MAX */
+ r__7 = (r__1 = tl[tl_dim1 + 1], dabs(r__1)), r__8 = (r__2 = tr[tr_dim1 +
+ 1], dabs(r__2)), r__7 = max(r__7,r__8), r__8 = (r__3 = tr[(
+ tr_dim1 << 1) + 1], dabs(r__3)), r__7 = max(r__7,r__8), r__8 = (
+ r__4 = tr[tr_dim1 + 2], dabs(r__4)), r__7 = max(r__7,r__8), r__8 =
+ (r__5 = tr[(tr_dim1 << 1) + 2], dabs(r__5));
+ r__6 = eps * dmax(r__7,r__8);
+ smin = dmax(r__6,smlnum);
+ tmp[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1];
+ tmp[3] = tl[tl_dim1 + 1] + sgn * tr[(tr_dim1 << 1) + 2];
+ if (*ltranr) {
+ tmp[1] = sgn * tr[tr_dim1 + 2];
+ tmp[2] = sgn * tr[(tr_dim1 << 1) + 1];
+ } else {
+ tmp[1] = sgn * tr[(tr_dim1 << 1) + 1];
+ tmp[2] = sgn * tr[tr_dim1 + 2];
+ }
+ btmp[0] = b[b_dim1 + 1];
+ btmp[1] = b[(b_dim1 << 1) + 1];
+ goto L40;
+
+/* 2 by 1: */
+/* op[TL11 TL12]*[X11] + ISGN* [X11]*TR11 = [B11] */
+/* [TL21 TL22] [X21] [X21] [B21] */
+
+L30:
+/* Computing MAX */
+/* Computing MAX */
+ r__7 = (r__1 = tr[tr_dim1 + 1], dabs(r__1)), r__8 = (r__2 = tl[tl_dim1 +
+ 1], dabs(r__2)), r__7 = max(r__7,r__8), r__8 = (r__3 = tl[(
+ tl_dim1 << 1) + 1], dabs(r__3)), r__7 = max(r__7,r__8), r__8 = (
+ r__4 = tl[tl_dim1 + 2], dabs(r__4)), r__7 = max(r__7,r__8), r__8 =
+ (r__5 = tl[(tl_dim1 << 1) + 2], dabs(r__5));
+ r__6 = eps * dmax(r__7,r__8);
+ smin = dmax(r__6,smlnum);
+ tmp[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1];
+ tmp[3] = tl[(tl_dim1 << 1) + 2] + sgn * tr[tr_dim1 + 1];
+ if (*ltranl) {
+ tmp[1] = tl[(tl_dim1 << 1) + 1];
+ tmp[2] = tl[tl_dim1 + 2];
+ } else {
+ tmp[1] = tl[tl_dim1 + 2];
+ tmp[2] = tl[(tl_dim1 << 1) + 1];
+ }
+ btmp[0] = b[b_dim1 + 1];
+ btmp[1] = b[b_dim1 + 2];
+L40:
+
+/* Solve 2 by 2 system using complete pivoting. */
+/* Set pivots less than SMIN to SMIN. */
+
+ ipiv = isamax_(&c__4, tmp, &c__1);
+ u11 = tmp[ipiv - 1];
+ if (dabs(u11) <= smin) {
+ *info = 1;
+ u11 = smin;
+ }
+ u12 = tmp[locu12[ipiv - 1] - 1];
+ l21 = tmp[locl21[ipiv - 1] - 1] / u11;
+ u22 = tmp[locu22[ipiv - 1] - 1] - u12 * l21;
+ xswap = xswpiv[ipiv - 1];
+ bswap = bswpiv[ipiv - 1];
+ if (dabs(u22) <= smin) {
+ *info = 1;
+ u22 = smin;
+ }
+ if (bswap) {
+ temp = btmp[1];
+ btmp[1] = btmp[0] - l21 * temp;
+ btmp[0] = temp;
+ } else {
+ btmp[1] -= l21 * btmp[0];
+ }
+ *scale = 1.f;
+ if (smlnum * 2.f * dabs(btmp[1]) > dabs(u22) || smlnum * 2.f * dabs(btmp[
+ 0]) > dabs(u11)) {
+/* Computing MAX */
+ r__1 = dabs(btmp[0]), r__2 = dabs(btmp[1]);
+ *scale = .5f / dmax(r__1,r__2);
+ btmp[0] *= *scale;
+ btmp[1] *= *scale;
+ }
+ x2[1] = btmp[1] / u22;
+ x2[0] = btmp[0] / u11 - u12 / u11 * x2[1];
+ if (xswap) {
+ temp = x2[1];
+ x2[1] = x2[0];
+ x2[0] = temp;
+ }
+ x[x_dim1 + 1] = x2[0];
+ if (*n1 == 1) {
+ x[(x_dim1 << 1) + 1] = x2[1];
+ *xnorm = (r__1 = x[x_dim1 + 1], dabs(r__1)) + (r__2 = x[(x_dim1 << 1)
+ + 1], dabs(r__2));
+ } else {
+ x[x_dim1 + 2] = x2[1];
+/* Computing MAX */
+ r__3 = (r__1 = x[x_dim1 + 1], dabs(r__1)), r__4 = (r__2 = x[x_dim1 +
+ 2], dabs(r__2));
+ *xnorm = dmax(r__3,r__4);
+ }
+ return 0;
+
+/* 2 by 2: */
+/* op[TL11 TL12]*[X11 X12] +ISGN* [X11 X12]*op[TR11 TR12] = [B11 B12] */
+/* [TL21 TL22] [X21 X22] [X21 X22] [TR21 TR22] [B21 B22] */
+
+/* Solve equivalent 4 by 4 system using complete pivoting. */
+/* Set pivots less than SMIN to SMIN. */
+
+L50:
+/* Computing MAX */
+ r__5 = (r__1 = tr[tr_dim1 + 1], dabs(r__1)), r__6 = (r__2 = tr[(tr_dim1 <<
+ 1) + 1], dabs(r__2)), r__5 = max(r__5,r__6), r__6 = (r__3 = tr[
+ tr_dim1 + 2], dabs(r__3)), r__5 = max(r__5,r__6), r__6 = (r__4 =
+ tr[(tr_dim1 << 1) + 2], dabs(r__4));
+ smin = dmax(r__5,r__6);
+/* Computing MAX */
+ r__5 = smin, r__6 = (r__1 = tl[tl_dim1 + 1], dabs(r__1)), r__5 = max(r__5,
+ r__6), r__6 = (r__2 = tl[(tl_dim1 << 1) + 1], dabs(r__2)), r__5 =
+ max(r__5,r__6), r__6 = (r__3 = tl[tl_dim1 + 2], dabs(r__3)), r__5
+ = max(r__5,r__6), r__6 = (r__4 = tl[(tl_dim1 << 1) + 2], dabs(
+ r__4));
+ smin = dmax(r__5,r__6);
+/* Computing MAX */
+ r__1 = eps * smin;
+ smin = dmax(r__1,smlnum);
+ btmp[0] = 0.f;
+ scopy_(&c__16, btmp, &c__0, t16, &c__1);
+ t16[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1];
+ t16[5] = tl[(tl_dim1 << 1) + 2] + sgn * tr[tr_dim1 + 1];
+ t16[10] = tl[tl_dim1 + 1] + sgn * tr[(tr_dim1 << 1) + 2];
+ t16[15] = tl[(tl_dim1 << 1) + 2] + sgn * tr[(tr_dim1 << 1) + 2];
+ if (*ltranl) {
+ t16[4] = tl[tl_dim1 + 2];
+ t16[1] = tl[(tl_dim1 << 1) + 1];
+ t16[14] = tl[tl_dim1 + 2];
+ t16[11] = tl[(tl_dim1 << 1) + 1];
+ } else {
+ t16[4] = tl[(tl_dim1 << 1) + 1];
+ t16[1] = tl[tl_dim1 + 2];
+ t16[14] = tl[(tl_dim1 << 1) + 1];
+ t16[11] = tl[tl_dim1 + 2];
+ }
+ if (*ltranr) {
+ t16[8] = sgn * tr[(tr_dim1 << 1) + 1];
+ t16[13] = sgn * tr[(tr_dim1 << 1) + 1];
+ t16[2] = sgn * tr[tr_dim1 + 2];
+ t16[7] = sgn * tr[tr_dim1 + 2];
+ } else {
+ t16[8] = sgn * tr[tr_dim1 + 2];
+ t16[13] = sgn * tr[tr_dim1 + 2];
+ t16[2] = sgn * tr[(tr_dim1 << 1) + 1];
+ t16[7] = sgn * tr[(tr_dim1 << 1) + 1];
+ }
+ btmp[0] = b[b_dim1 + 1];
+ btmp[1] = b[b_dim1 + 2];
+ btmp[2] = b[(b_dim1 << 1) + 1];
+ btmp[3] = b[(b_dim1 << 1) + 2];
+
+/* Perform elimination */
+
+ for (i__ = 1; i__ <= 3; ++i__) {
+ xmax = 0.f;
+ for (ip = i__; ip <= 4; ++ip) {
+ for (jp = i__; jp <= 4; ++jp) {
+ if ((r__1 = t16[ip + (jp << 2) - 5], dabs(r__1)) >= xmax) {
+ xmax = (r__1 = t16[ip + (jp << 2) - 5], dabs(r__1));
+ ipsv = ip;
+ jpsv = jp;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+ if (ipsv != i__) {
+ sswap_(&c__4, &t16[ipsv - 1], &c__4, &t16[i__ - 1], &c__4);
+ temp = btmp[i__ - 1];
+ btmp[i__ - 1] = btmp[ipsv - 1];
+ btmp[ipsv - 1] = temp;
+ }
+ if (jpsv != i__) {
+ sswap_(&c__4, &t16[(jpsv << 2) - 4], &c__1, &t16[(i__ << 2) - 4],
+ &c__1);
+ }
+ jpiv[i__ - 1] = jpsv;
+ if ((r__1 = t16[i__ + (i__ << 2) - 5], dabs(r__1)) < smin) {
+ *info = 1;
+ t16[i__ + (i__ << 2) - 5] = smin;
+ }
+ for (j = i__ + 1; j <= 4; ++j) {
+ t16[j + (i__ << 2) - 5] /= t16[i__ + (i__ << 2) - 5];
+ btmp[j - 1] -= t16[j + (i__ << 2) - 5] * btmp[i__ - 1];
+ for (k = i__ + 1; k <= 4; ++k) {
+ t16[j + (k << 2) - 5] -= t16[j + (i__ << 2) - 5] * t16[i__ + (
+ k << 2) - 5];
+/* L80: */
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+ if (dabs(t16[15]) < smin) {
+ t16[15] = smin;
+ }
+ *scale = 1.f;
+ if (smlnum * 8.f * dabs(btmp[0]) > dabs(t16[0]) || smlnum * 8.f * dabs(
+ btmp[1]) > dabs(t16[5]) || smlnum * 8.f * dabs(btmp[2]) > dabs(
+ t16[10]) || smlnum * 8.f * dabs(btmp[3]) > dabs(t16[15])) {
+/* Computing MAX */
+ r__1 = dabs(btmp[0]), r__2 = dabs(btmp[1]), r__1 = max(r__1,r__2),
+ r__2 = dabs(btmp[2]), r__1 = max(r__1,r__2), r__2 = dabs(btmp[
+ 3]);
+ *scale = .125f / dmax(r__1,r__2);
+ btmp[0] *= *scale;
+ btmp[1] *= *scale;
+ btmp[2] *= *scale;
+ btmp[3] *= *scale;
+ }
+ for (i__ = 1; i__ <= 4; ++i__) {
+ k = 5 - i__;
+ temp = 1.f / t16[k + (k << 2) - 5];
+ tmp[k - 1] = btmp[k - 1] * temp;
+ for (j = k + 1; j <= 4; ++j) {
+ tmp[k - 1] -= temp * t16[k + (j << 2) - 5] * tmp[j - 1];
+/* L110: */
+ }
+/* L120: */
+ }
+ for (i__ = 1; i__ <= 3; ++i__) {
+ if (jpiv[4 - i__ - 1] != 4 - i__) {
+ temp = tmp[4 - i__ - 1];
+ tmp[4 - i__ - 1] = tmp[jpiv[4 - i__ - 1] - 1];
+ tmp[jpiv[4 - i__ - 1] - 1] = temp;
+ }
+/* L130: */
+ }
+ x[x_dim1 + 1] = tmp[0];
+ x[x_dim1 + 2] = tmp[1];
+ x[(x_dim1 << 1) + 1] = tmp[2];
+ x[(x_dim1 << 1) + 2] = tmp[3];
+/* Computing MAX */
+ r__1 = dabs(tmp[0]) + dabs(tmp[2]), r__2 = dabs(tmp[1]) + dabs(tmp[3]);
+ *xnorm = dmax(r__1,r__2);
+ return 0;
+
+/* End of SLASY2 */
+
+} /* slasy2_ */
diff --git a/SRC/slasyf.c b/SRC/slasyf.c
new file mode 100644
index 0000000..0721540
--- /dev/null
+++ b/SRC/slasyf.c
@@ -0,0 +1,719 @@
+/* slasyf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b8 = -1.f;
+static real c_b9 = 1.f;
+
+/* Subroutine */ int slasyf_(char *uplo, integer *n, integer *nb, integer *kb,
+ real *a, integer *lda, integer *ipiv, real *w, integer *ldw, integer
+ *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer j, k;
+ real t, r1, d11, d21, d22;
+ integer jb, jj, kk, jp, kp, kw, kkw, imax, jmax;
+ real alpha;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ sgemm_(char *, char *, integer *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *), sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ integer kstep;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), sswap_(integer *, real *, integer *, real *, integer *
+);
+ real absakk;
+ extern integer isamax_(integer *, real *, integer *);
+ real colmax, rowmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASYF computes a partial factorization of a real symmetric matrix A */
+/* using the Bunch-Kaufman 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' U22' ) */
+
+/* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) 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 is an auxiliary routine called by SSYTRF. It uses blocked code */
+/* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or */
+/* A22 (if UPLO = 'L'). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NB (input) 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. */
+
+/* KB (output) INTEGER */
+/* The number of columns of A that were actually factored. */
+/* KB is either NB-1 or NB, or N if N <= NB. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n-by-n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n-by-n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+/* On exit, A contains details of the partial factorization. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If UPLO = 'U', only the last KB elements of IPIV are set; */
+/* if UPLO = 'L', only the first KB elements are set. */
+
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* W (workspace) REAL array, dimension (LDW,NB) */
+
+/* LDW (input) INTEGER */
+/* The leading dimension of the array W. LDW >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* > 0: if INFO = k, D(k,k) is exactly zero. The factorization */
+/* has been completed, but the block diagonal matrix D is */
+/* exactly singular. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ w_dim1 = *ldw;
+ w_offset = 1 + w_dim1;
+ w -= w_offset;
+
+ /* Function Body */
+ *info = 0;
+
+/* Initialize ALPHA for use in choosing pivot block size. */
+
+ alpha = (sqrt(17.f) + 1.f) / 8.f;
+
+ if (lsame_(uplo, "U")) {
+
+/* 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 */
+
+/* K is the main loop index, decreasing from N in steps of 1 or 2 */
+
+/* KW is the column of W which corresponds to column K of A */
+
+ k = *n;
+L10:
+ kw = *nb + k - *n;
+
+/* Exit from loop */
+
+ if (k <= *n - *nb + 1 && *nb < *n || k < 1) {
+ goto L30;
+ }
+
+/* Copy column K of A to column KW of W and update it */
+
+ scopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1);
+ if (k < *n) {
+ i__1 = *n - k;
+ sgemv_("No transpose", &k, &i__1, &c_b8, &a[(k + 1) * a_dim1 + 1],
+ lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b9, &w[kw *
+ w_dim1 + 1], &c__1);
+ }
+
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ absakk = (r__1 = w[k + kw * w_dim1], dabs(r__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ imax = isamax_(&i__1, &w[kw * w_dim1 + 1], &c__1);
+ colmax = (r__1 = w[imax + kw * w_dim1], dabs(r__1));
+ } else {
+ colmax = 0.f;
+ }
+
+ if (dmax(absakk,colmax) == 0.f) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* Copy column IMAX to column KW-1 of W and update it */
+
+ scopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) *
+ w_dim1 + 1], &c__1);
+ i__1 = k - imax;
+ scopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax +
+ 1 + (kw - 1) * w_dim1], &c__1);
+ if (k < *n) {
+ i__1 = *n - k;
+ sgemv_("No transpose", &k, &i__1, &c_b8, &a[(k + 1) *
+ a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1],
+ ldw, &c_b9, &w[(kw - 1) * w_dim1 + 1], &c__1);
+ }
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = k - imax;
+ jmax = imax + isamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1],
+ &c__1);
+ rowmax = (r__1 = w[jmax + (kw - 1) * w_dim1], dabs(r__1));
+ if (imax > 1) {
+ i__1 = imax - 1;
+ jmax = isamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
+/* Computing MAX */
+ r__2 = rowmax, r__3 = (r__1 = w[jmax + (kw - 1) * w_dim1],
+ dabs(r__1));
+ rowmax = dmax(r__2,r__3);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else if ((r__1 = w[imax + (kw - 1) * w_dim1], dabs(r__1)) >=
+ alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+
+/* copy column KW-1 of W to column KW */
+
+ scopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw *
+ w_dim1 + 1], &c__1);
+ } else {
+
+/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+
+ kk = k - kstep + 1;
+ kkw = *nb + kk - *n;
+
+/* Updated column KP is already stored in column KKW of W */
+
+ if (kp != kk) {
+
+/* Copy non-updated column KK to column KP */
+
+ a[kp + k * a_dim1] = a[kk + k * a_dim1];
+ i__1 = k - 1 - kp;
+ scopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp +
+ 1) * a_dim1], lda);
+ scopy_(&kp, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &
+ c__1);
+
+/* Interchange rows KK and KP in last KK columns of A and W */
+
+ i__1 = *n - kk + 1;
+ sswap_(&i__1, &a[kk + kk * a_dim1], lda, &a[kp + kk * a_dim1],
+ lda);
+ i__1 = *n - kk + 1;
+ sswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw *
+ w_dim1], ldw);
+ }
+
+ if (kstep == 1) {
+
+/* 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 */
+
+ scopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &
+ c__1);
+ r1 = 1.f / a[k + k * a_dim1];
+ i__1 = k - 1;
+ sscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
+ } 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 > 2) {
+
+/* Store U(k) and U(k-1) in columns k and k-1 of A */
+
+ d21 = w[k - 1 + kw * w_dim1];
+ d11 = w[k + kw * w_dim1] / d21;
+ d22 = w[k - 1 + (kw - 1) * w_dim1] / d21;
+ t = 1.f / (d11 * d22 - 1.f);
+ d21 = t / d21;
+ i__1 = k - 2;
+ for (j = 1; j <= i__1; ++j) {
+ a[j + (k - 1) * a_dim1] = d21 * (d11 * w[j + (kw - 1)
+ * w_dim1] - w[j + kw * w_dim1]);
+ a[j + k * a_dim1] = d21 * (d22 * w[j + kw * w_dim1] -
+ w[j + (kw - 1) * w_dim1]);
+/* L20: */
+ }
+ }
+
+/* Copy D(k) to A */
+
+ a[k - 1 + (k - 1) * a_dim1] = w[k - 1 + (kw - 1) * w_dim1];
+ a[k - 1 + k * a_dim1] = w[k - 1 + kw * w_dim1];
+ a[k + k * a_dim1] = w[k + kw * w_dim1];
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k - 1] = -kp;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kstep;
+ goto L10;
+
+L30:
+
+/* Update the upper triangle of A11 (= A(1:k,1:k)) as */
+
+/* A11 := A11 - U12*D*U12' = A11 - U12*W' */
+
+/* computing blocks of NB columns at a time */
+
+ i__1 = -(*nb);
+ for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j +=
+ i__1) {
+/* Computing MIN */
+ i__2 = *nb, i__3 = k - j + 1;
+ jb = min(i__2,i__3);
+
+/* Update the upper triangle of the diagonal block */
+
+ i__2 = j + jb - 1;
+ for (jj = j; jj <= i__2; ++jj) {
+ i__3 = jj - j + 1;
+ i__4 = *n - k;
+ sgemv_("No transpose", &i__3, &i__4, &c_b8, &a[j + (k + 1) *
+ a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b9,
+ &a[j + jj * a_dim1], &c__1);
+/* L40: */
+ }
+
+/* Update the rectangular superdiagonal block */
+
+ i__2 = j - 1;
+ i__3 = *n - k;
+ sgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &c_b8, &a[(
+ k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * w_dim1], ldw,
+ &c_b9, &a[j * a_dim1 + 1], lda);
+/* L50: */
+ }
+
+/* Put U12 in standard form by partially undoing the interchanges */
+/* in columns k+1:n */
+
+ j = k + 1;
+L60:
+ jj = j;
+ jp = ipiv[j];
+ if (jp < 0) {
+ jp = -jp;
+ ++j;
+ }
+ ++j;
+ if (jp != jj && j <= *n) {
+ i__1 = *n - j + 1;
+ sswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda);
+ }
+ if (j <= *n) {
+ goto L60;
+ }
+
+/* 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 */
+
+/* K is the main loop index, increasing from 1 in steps of 1 or 2 */
+
+ k = 1;
+L70:
+
+/* Exit from loop */
+
+ if (k >= *nb && *nb < *n || k > *n) {
+ goto L90;
+ }
+
+/* Copy column K of A to column K of W and update it */
+
+ i__1 = *n - k + 1;
+ scopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1);
+ i__1 = *n - k + 1;
+ i__2 = k - 1;
+ sgemv_("No transpose", &i__1, &i__2, &c_b8, &a[k + a_dim1], lda, &w[k
+ + w_dim1], ldw, &c_b9, &w[k + k * w_dim1], &c__1);
+
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ absakk = (r__1 = w[k + k * w_dim1], dabs(r__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ imax = k + isamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1);
+ colmax = (r__1 = w[imax + k * w_dim1], dabs(r__1));
+ } else {
+ colmax = 0.f;
+ }
+
+ if (dmax(absakk,colmax) == 0.f) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* Copy column IMAX to column K+1 of W and update it */
+
+ i__1 = imax - k;
+ scopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) *
+ w_dim1], &c__1);
+ i__1 = *n - imax + 1;
+ scopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k +
+ 1) * w_dim1], &c__1);
+ i__1 = *n - k + 1;
+ i__2 = k - 1;
+ sgemv_("No transpose", &i__1, &i__2, &c_b8, &a[k + a_dim1],
+ lda, &w[imax + w_dim1], ldw, &c_b9, &w[k + (k + 1) *
+ w_dim1], &c__1);
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = imax - k;
+ jmax = k - 1 + isamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1)
+ ;
+ rowmax = (r__1 = w[jmax + (k + 1) * w_dim1], dabs(r__1));
+ if (imax < *n) {
+ i__1 = *n - imax;
+ jmax = imax + isamax_(&i__1, &w[imax + 1 + (k + 1) *
+ w_dim1], &c__1);
+/* Computing MAX */
+ r__2 = rowmax, r__3 = (r__1 = w[jmax + (k + 1) * w_dim1],
+ dabs(r__1));
+ rowmax = dmax(r__2,r__3);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else if ((r__1 = w[imax + (k + 1) * w_dim1], dabs(r__1)) >=
+ alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+
+/* copy column K+1 of W to column K */
+
+ i__1 = *n - k + 1;
+ scopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k *
+ w_dim1], &c__1);
+ } else {
+
+/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+
+ kk = k + kstep - 1;
+
+/* Updated column KP is already stored in column KK of W */
+
+ if (kp != kk) {
+
+/* Copy non-updated column KK to column KP */
+
+ a[kp + k * a_dim1] = a[kk + k * a_dim1];
+ i__1 = kp - k - 1;
+ scopy_(&i__1, &a[k + 1 + kk * a_dim1], &c__1, &a[kp + (k + 1)
+ * a_dim1], lda);
+ i__1 = *n - kp + 1;
+ scopy_(&i__1, &a[kp + kk * a_dim1], &c__1, &a[kp + kp *
+ a_dim1], &c__1);
+
+/* Interchange rows KK and KP in first KK columns of A and W */
+
+ sswap_(&kk, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda);
+ sswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw);
+ }
+
+ if (kstep == 1) {
+
+/* 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 */
+
+ i__1 = *n - k + 1;
+ scopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], &
+ c__1);
+ if (k < *n) {
+ r1 = 1.f / a[k + k * a_dim1];
+ i__1 = *n - k;
+ sscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1);
+ }
+ } 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 < *n - 1) {
+
+/* Store L(k) and L(k+1) in columns k and k+1 of A */
+
+ d21 = w[k + 1 + k * w_dim1];
+ d11 = w[k + 1 + (k + 1) * w_dim1] / d21;
+ d22 = w[k + k * w_dim1] / d21;
+ t = 1.f / (d11 * d22 - 1.f);
+ d21 = t / d21;
+ i__1 = *n;
+ for (j = k + 2; j <= i__1; ++j) {
+ a[j + k * a_dim1] = d21 * (d11 * w[j + k * w_dim1] -
+ w[j + (k + 1) * w_dim1]);
+ a[j + (k + 1) * a_dim1] = d21 * (d22 * w[j + (k + 1) *
+ w_dim1] - w[j + k * w_dim1]);
+/* L80: */
+ }
+ }
+
+/* Copy D(k) to A */
+
+ a[k + k * a_dim1] = w[k + k * w_dim1];
+ a[k + 1 + k * a_dim1] = w[k + 1 + k * w_dim1];
+ a[k + 1 + (k + 1) * a_dim1] = w[k + 1 + (k + 1) * w_dim1];
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k + 1] = -kp;
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kstep;
+ goto L70;
+
+L90:
+
+/* Update the lower triangle of A22 (= A(k:n,k:n)) as */
+
+/* A22 := A22 - L21*D*L21' = A22 - L21*W' */
+
+/* computing blocks of NB columns at a time */
+
+ i__1 = *n;
+ i__2 = *nb;
+ for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = *nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+
+/* Update the lower triangle of the diagonal block */
+
+ i__3 = j + jb - 1;
+ for (jj = j; jj <= i__3; ++jj) {
+ i__4 = j + jb - jj;
+ i__5 = k - 1;
+ sgemv_("No transpose", &i__4, &i__5, &c_b8, &a[jj + a_dim1],
+ lda, &w[jj + w_dim1], ldw, &c_b9, &a[jj + jj * a_dim1]
+, &c__1);
+/* L100: */
+ }
+
+/* Update the rectangular subdiagonal block */
+
+ if (j + jb <= *n) {
+ i__3 = *n - j - jb + 1;
+ i__4 = k - 1;
+ sgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &c_b8,
+ &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b9,
+ &a[j + jb + j * a_dim1], lda);
+ }
+/* L110: */
+ }
+
+/* Put L21 in standard form by partially undoing the interchanges */
+/* in columns 1:k-1 */
+
+ j = k - 1;
+L120:
+ jj = j;
+ jp = ipiv[j];
+ if (jp < 0) {
+ jp = -jp;
+ --j;
+ }
+ --j;
+ if (jp != jj && j >= 1) {
+ sswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda);
+ }
+ if (j >= 1) {
+ goto L120;
+ }
+
+/* Set KB to the number of columns factorized */
+
+ *kb = k - 1;
+
+ }
+ return 0;
+
+/* End of SLASYF */
+
+} /* slasyf_ */
diff --git a/SRC/slatbs.c b/SRC/slatbs.c
new file mode 100644
index 0000000..9a3e867
--- /dev/null
+++ b/SRC/slatbs.c
@@ -0,0 +1,849 @@
+/* slatbs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b36 = .5f;
+
+/* Subroutine */ int slatbs_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, integer *kd, real *ab, integer *ldab, real *x,
+ real *scale, real *cnorm, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j;
+ real xj, rec, tjj;
+ integer jinc, jlen;
+ real xbnd;
+ integer imax;
+ real tmax, tjjs;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ real xmax, grow, sumj;
+ integer maind;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real tscal, uscal;
+ integer jlast;
+ extern doublereal sasum_(integer *, real *, integer *);
+ logical upper;
+ extern /* Subroutine */ int stbsv_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *), saxpy_(integer *, real *, real *, integer *, real *,
+ integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ extern integer isamax_(integer *, real *, integer *);
+ logical notran;
+ integer jfirst;
+ real smlnum;
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLATBS solves one of the triangular systems */
+
+/* A *x = s*b or A'*x = s*b */
+
+/* with scaling to prevent overflow, where A is an upper or lower */
+/* triangular band matrix. Here A' denotes the transpose of A, x and b */
+/* are n-element vectors, and s is a scaling factor, usually less than */
+/* or equal to 1, chosen so that the components of x will be less than */
+/* the overflow threshold. If the unscaled problem will not cause */
+/* overflow, the Level 2 BLAS routine STBSV is called. If the matrix A */
+/* is singular (A(j,j) = 0 for some j), then s is set to 0 and a */
+/* non-trivial solution to A*x = 0 is returned. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': Solve A * x = s*b (No transpose) */
+/* = 'T': Solve A'* x = s*b (Transpose) */
+/* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* NORMIN (input) CHARACTER*1 */
+/* Specifies whether CNORM has been set or not. */
+/* = 'Y': CNORM contains the column norms on entry */
+/* = 'N': CNORM is not set on entry. On exit, the norms will */
+/* be computed and stored in CNORM. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of subdiagonals or superdiagonals in the */
+/* triangular matrix A. KD >= 0. */
+
+/* AB (input) REAL array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first KD+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* X (input/output) REAL array, dimension (N) */
+/* On entry, the right hand side b of the triangular system. */
+/* On exit, X is overwritten by the solution vector x. */
+
+/* SCALE (output) REAL */
+/* The scaling factor s for the triangular system */
+/* A * x = s*b or A'* x = s*b. */
+/* If SCALE = 0, the matrix A is singular or badly scaled, and */
+/* the vector x is an exact or approximate solution to A*x = 0. */
+
+/* CNORM (input or output) REAL array, dimension (N) */
+
+/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
+/* contains the norm of the off-diagonal part of the j-th column */
+/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */
+/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
+/* must be greater than or equal to the 1-norm. */
+
+/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
+/* returns the 1-norm of the offdiagonal part of the j-th column */
+/* of A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* Further Details */
+/* ======= ======= */
+
+/* A rough bound on x is computed; if that is less than overflow, STBSV */
+/* is called, otherwise, specific code is used which checks for possible */
+/* overflow or divide-by-zero at every operation. */
+
+/* A columnwise scheme is used for solving A*x = b. The basic algorithm */
+/* if A is lower triangular is */
+
+/* x[1:n] := b[1:n] */
+/* for j = 1, ..., n */
+/* x(j) := x(j) / A(j,j) */
+/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
+/* end */
+
+/* Define bounds on the components of x after j iterations of the loop: */
+/* M(j) = bound on x[1:j] */
+/* G(j) = bound on x[j+1:n] */
+/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */
+
+/* Then for iteration j+1 we have */
+/* M(j+1) <= G(j) / | A(j+1,j+1) | */
+/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
+/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
+
+/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
+/* column j+1 of A, not counting the diagonal. Hence */
+
+/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
+/* 1<=i<=j */
+/* and */
+
+/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
+/* 1<=i< j */
+
+/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine STBSV if the */
+/* reciprocal of the largest M(j), j=1,..,n, is larger than */
+/* max(underflow, 1/overflow). */
+
+/* The bound on x(j) is also used to determine when a step in the */
+/* columnwise method can be performed without fear of overflow. If */
+/* the computed bound is greater than a large constant, x is scaled to */
+/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
+/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
+
+/* Similarly, a row-wise scheme is used to solve A'*x = b. The basic */
+/* algorithm for A upper triangular is */
+
+/* for j = 1, ..., n */
+/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
+/* end */
+
+/* We simultaneously compute two bounds */
+/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
+/* M(j) = bound on x(i), 1<=i<=j */
+
+/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */
+/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
+/* Then the bound on x(j) is */
+
+/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
+
+/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
+/* 1<=i<=j */
+
+/* and we can safely call STBSV if 1/M(n) and 1/G(n) are both greater */
+/* than max(underflow, 1/overflow). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --x;
+ --cnorm;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+/* Test the input parameters. */
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (! lsame_(normin, "Y") && ! lsame_(normin,
+ "N")) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*kd < 0) {
+ *info = -6;
+ } else if (*ldab < *kd + 1) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLATBS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine machine dependent parameters to control overflow. */
+
+ smlnum = slamch_("Safe minimum") / slamch_("Precision");
+ bignum = 1.f / smlnum;
+ *scale = 1.f;
+
+ if (lsame_(normin, "N")) {
+
+/* Compute the 1-norm of each column, not including the diagonal. */
+
+ if (upper) {
+
+/* A is upper triangular. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *kd, i__3 = j - 1;
+ jlen = min(i__2,i__3);
+ cnorm[j] = sasum_(&jlen, &ab[*kd + 1 - jlen + j * ab_dim1], &
+ c__1);
+/* L10: */
+ }
+ } else {
+
+/* A is lower triangular. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *kd, i__3 = *n - j;
+ jlen = min(i__2,i__3);
+ if (jlen > 0) {
+ cnorm[j] = sasum_(&jlen, &ab[j * ab_dim1 + 2], &c__1);
+ } else {
+ cnorm[j] = 0.f;
+ }
+/* L20: */
+ }
+ }
+ }
+
+/* Scale the column norms by TSCAL if the maximum element in CNORM is */
+/* greater than BIGNUM. */
+
+ imax = isamax_(n, &cnorm[1], &c__1);
+ tmax = cnorm[imax];
+ if (tmax <= bignum) {
+ tscal = 1.f;
+ } else {
+ tscal = 1.f / (smlnum * tmax);
+ sscal_(n, &tscal, &cnorm[1], &c__1);
+ }
+
+/* Compute a bound on the computed solution vector to see if the */
+/* Level 2 BLAS routine STBSV can be used. */
+
+ j = isamax_(n, &x[1], &c__1);
+ xmax = (r__1 = x[j], dabs(r__1));
+ xbnd = xmax;
+ if (notran) {
+
+/* Compute the growth in A * x = b. */
+
+ if (upper) {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ maind = *kd + 1;
+ } else {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ maind = 1;
+ }
+
+ if (tscal != 1.f) {
+ grow = 0.f;
+ goto L50;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, G(0) = max{x(i), i=1,...,n}. */
+
+ grow = 1.f / dmax(xbnd,smlnum);
+ xbnd = grow;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L50;
+ }
+
+/* M(j) = G(j-1) / abs(A(j,j)) */
+
+ tjj = (r__1 = ab[maind + j * ab_dim1], dabs(r__1));
+/* Computing MIN */
+ r__1 = xbnd, r__2 = dmin(1.f,tjj) * grow;
+ xbnd = dmin(r__1,r__2);
+ if (tjj + cnorm[j] >= smlnum) {
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
+
+ grow *= tjj / (tjj + cnorm[j]);
+ } else {
+
+/* G(j) could overflow, set GROW to 0. */
+
+ grow = 0.f;
+ }
+/* L30: */
+ }
+ grow = xbnd;
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ r__1 = 1.f, r__2 = 1.f / dmax(xbnd,smlnum);
+ grow = dmin(r__1,r__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L50;
+ }
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
+
+ grow *= 1.f / (cnorm[j] + 1.f);
+/* L40: */
+ }
+ }
+L50:
+
+ ;
+ } else {
+
+/* Compute the growth in A' * x = b. */
+
+ if (upper) {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ maind = *kd + 1;
+ } else {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ maind = 1;
+ }
+
+ if (tscal != 1.f) {
+ grow = 0.f;
+ goto L80;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, M(0) = max{x(i), i=1,...,n}. */
+
+ grow = 1.f / dmax(xbnd,smlnum);
+ xbnd = grow;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L80;
+ }
+
+/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
+
+ xj = cnorm[j] + 1.f;
+/* Computing MIN */
+ r__1 = grow, r__2 = xbnd / xj;
+ grow = dmin(r__1,r__2);
+
+/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
+
+ tjj = (r__1 = ab[maind + j * ab_dim1], dabs(r__1));
+ if (xj > tjj) {
+ xbnd *= tjj / xj;
+ }
+/* L60: */
+ }
+ grow = dmin(grow,xbnd);
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ r__1 = 1.f, r__2 = 1.f / dmax(xbnd,smlnum);
+ grow = dmin(r__1,r__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L80;
+ }
+
+/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
+
+ xj = cnorm[j] + 1.f;
+ grow /= xj;
+/* L70: */
+ }
+ }
+L80:
+ ;
+ }
+
+ if (grow * tscal > smlnum) {
+
+/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
+/* elements of X is not too small. */
+
+ stbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &x[1], &c__1);
+ } else {
+
+/* Use a Level 1 BLAS solve, scaling intermediate results. */
+
+ if (xmax > bignum) {
+
+/* Scale X so that its components are less than or equal to */
+/* BIGNUM in absolute value. */
+
+ *scale = bignum / xmax;
+ sscal_(n, scale, &x[1], &c__1);
+ xmax = bignum;
+ }
+
+ if (notran) {
+
+/* Solve A * x = b */
+
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
+
+ xj = (r__1 = x[j], dabs(r__1));
+ if (nounit) {
+ tjjs = ab[maind + j * ab_dim1] * tscal;
+ } else {
+ tjjs = tscal;
+ if (tscal == 1.f) {
+ goto L95;
+ }
+ }
+ tjj = dabs(tjjs);
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.f) {
+ if (xj > tjj * bignum) {
+
+/* Scale x by 1/b(j). */
+
+ rec = 1.f / xj;
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ x[j] /= tjjs;
+ xj = (r__1 = x[j], dabs(r__1));
+ } else if (tjj > 0.f) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
+/* to avoid overflow when dividing by A(j,j). */
+
+ rec = tjj * bignum / xj;
+ if (cnorm[j] > 1.f) {
+
+/* Scale by 1/CNORM(j) to avoid overflow when */
+/* multiplying x(j) times column j. */
+
+ rec /= cnorm[j];
+ }
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ x[j] /= tjjs;
+ xj = (r__1 = x[j], dabs(r__1));
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0, and compute a solution to A*x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ x[i__] = 0.f;
+/* L90: */
+ }
+ x[j] = 1.f;
+ xj = 1.f;
+ *scale = 0.f;
+ xmax = 0.f;
+ }
+L95:
+
+/* Scale x if necessary to avoid overflow when adding a */
+/* multiple of column j of A. */
+
+ if (xj > 1.f) {
+ rec = 1.f / xj;
+ if (cnorm[j] > (bignum - xmax) * rec) {
+
+/* Scale x by 1/(2*abs(x(j))). */
+
+ rec *= .5f;
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ }
+ } else if (xj * cnorm[j] > bignum - xmax) {
+
+/* Scale x by 1/2. */
+
+ sscal_(n, &c_b36, &x[1], &c__1);
+ *scale *= .5f;
+ }
+
+ if (upper) {
+ if (j > 1) {
+
+/* Compute the update */
+/* x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) - */
+/* x(j)* A(max(1,j-kd):j-1,j) */
+
+/* Computing MIN */
+ i__3 = *kd, i__4 = j - 1;
+ jlen = min(i__3,i__4);
+ r__1 = -x[j] * tscal;
+ saxpy_(&jlen, &r__1, &ab[*kd + 1 - jlen + j * ab_dim1]
+, &c__1, &x[j - jlen], &c__1);
+ i__3 = j - 1;
+ i__ = isamax_(&i__3, &x[1], &c__1);
+ xmax = (r__1 = x[i__], dabs(r__1));
+ }
+ } else if (j < *n) {
+
+/* Compute the update */
+/* x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) - */
+/* x(j) * A(j+1:min(j+kd,n),j) */
+
+/* Computing MIN */
+ i__3 = *kd, i__4 = *n - j;
+ jlen = min(i__3,i__4);
+ if (jlen > 0) {
+ r__1 = -x[j] * tscal;
+ saxpy_(&jlen, &r__1, &ab[j * ab_dim1 + 2], &c__1, &x[
+ j + 1], &c__1);
+ }
+ i__3 = *n - j;
+ i__ = j + isamax_(&i__3, &x[j + 1], &c__1);
+ xmax = (r__1 = x[i__], dabs(r__1));
+ }
+/* L100: */
+ }
+
+ } else {
+
+/* Solve A' * x = b */
+
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
+/* k<>j */
+
+ xj = (r__1 = x[j], dabs(r__1));
+ uscal = tscal;
+ rec = 1.f / dmax(xmax,1.f);
+ if (cnorm[j] > (bignum - xj) * rec) {
+
+/* If x(j) could overflow, scale x by 1/(2*XMAX). */
+
+ rec *= .5f;
+ if (nounit) {
+ tjjs = ab[maind + j * ab_dim1] * tscal;
+ } else {
+ tjjs = tscal;
+ }
+ tjj = dabs(tjjs);
+ if (tjj > 1.f) {
+
+/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
+
+/* Computing MIN */
+ r__1 = 1.f, r__2 = rec * tjj;
+ rec = dmin(r__1,r__2);
+ uscal /= tjjs;
+ }
+ if (rec < 1.f) {
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ sumj = 0.f;
+ if (uscal == 1.f) {
+
+/* If the scaling needed for A in the dot product is 1, */
+/* call SDOT to perform the dot product. */
+
+ if (upper) {
+/* Computing MIN */
+ i__3 = *kd, i__4 = j - 1;
+ jlen = min(i__3,i__4);
+ sumj = sdot_(&jlen, &ab[*kd + 1 - jlen + j * ab_dim1],
+ &c__1, &x[j - jlen], &c__1);
+ } else {
+/* Computing MIN */
+ i__3 = *kd, i__4 = *n - j;
+ jlen = min(i__3,i__4);
+ if (jlen > 0) {
+ sumj = sdot_(&jlen, &ab[j * ab_dim1 + 2], &c__1, &
+ x[j + 1], &c__1);
+ }
+ }
+ } else {
+
+/* Otherwise, use in-line code for the dot product. */
+
+ if (upper) {
+/* Computing MIN */
+ i__3 = *kd, i__4 = j - 1;
+ jlen = min(i__3,i__4);
+ i__3 = jlen;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ sumj += ab[*kd + i__ - jlen + j * ab_dim1] *
+ uscal * x[j - jlen - 1 + i__];
+/* L110: */
+ }
+ } else {
+/* Computing MIN */
+ i__3 = *kd, i__4 = *n - j;
+ jlen = min(i__3,i__4);
+ i__3 = jlen;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ sumj += ab[i__ + 1 + j * ab_dim1] * uscal * x[j +
+ i__];
+/* L120: */
+ }
+ }
+ }
+
+ if (uscal == tscal) {
+
+/* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) */
+/* was not used to scale the dotproduct. */
+
+ x[j] -= sumj;
+ xj = (r__1 = x[j], dabs(r__1));
+ if (nounit) {
+
+/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
+
+ tjjs = ab[maind + j * ab_dim1] * tscal;
+ } else {
+ tjjs = tscal;
+ if (tscal == 1.f) {
+ goto L135;
+ }
+ }
+ tjj = dabs(tjjs);
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.f) {
+ if (xj > tjj * bignum) {
+
+/* Scale X by 1/abs(x(j)). */
+
+ rec = 1.f / xj;
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ x[j] /= tjjs;
+ } else if (tjj > 0.f) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
+
+ rec = tjj * bignum / xj;
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ x[j] /= tjjs;
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0, and compute a solution to A'*x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ x[i__] = 0.f;
+/* L130: */
+ }
+ x[j] = 1.f;
+ *scale = 0.f;
+ xmax = 0.f;
+ }
+L135:
+ ;
+ } else {
+
+/* Compute x(j) := x(j) / A(j,j) - sumj if the dot */
+/* product has already been divided by 1/A(j,j). */
+
+ x[j] = x[j] / tjjs - sumj;
+ }
+/* Computing MAX */
+ r__2 = xmax, r__3 = (r__1 = x[j], dabs(r__1));
+ xmax = dmax(r__2,r__3);
+/* L140: */
+ }
+ }
+ *scale /= tscal;
+ }
+
+/* Scale the column norms by 1/TSCAL for return. */
+
+ if (tscal != 1.f) {
+ r__1 = 1.f / tscal;
+ sscal_(n, &r__1, &cnorm[1], &c__1);
+ }
+
+ return 0;
+
+/* End of SLATBS */
+
+} /* slatbs_ */
diff --git a/SRC/slatdf.c b/SRC/slatdf.c
new file mode 100644
index 0000000..3f9bbb0
--- /dev/null
+++ b/SRC/slatdf.c
@@ -0,0 +1,301 @@
+/* slatdf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b23 = 1.f;
+static real c_b37 = -1.f;
+
+/* Subroutine */ int slatdf_(integer *ijob, integer *n, real *z__, integer *
+ ldz, real *rhs, real *rdsum, real *rdscal, integer *ipiv, integer *
+ jpiv)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ real bm, bp, xm[8], xp[8];
+ integer info;
+ real temp;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ real work[32];
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real pmone;
+ extern doublereal sasum_(integer *, real *, integer *);
+ real sminu;
+ integer iwork[8];
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), saxpy_(integer *, real *, real *, integer *, real *,
+ integer *);
+ real splus;
+ extern /* Subroutine */ int sgesc2_(integer *, real *, integer *, real *,
+ integer *, integer *, real *), sgecon_(char *, integer *, real *,
+ integer *, real *, real *, real *, integer *, integer *),
+ slassq_(integer *, real *, integer *, real *, real *), slaswp_(
+ integer *, real *, integer *, integer *, integer *, integer *,
+ integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLATDF uses the LU factorization of the n-by-n matrix Z computed by */
+/* SGETC2 and computes a contribution to the reciprocal Dif-estimate */
+/* by solving Z * x = b for x, and choosing the r.h.s. b such that */
+/* the norm of x is as large as possible. On entry RHS = b holds the */
+/* contribution from earlier solved sub-systems, and on return RHS = x. */
+
+/* The factorization of Z returned by SGETC2 has the form Z = P*L*U*Q, */
+/* where P and Q are permutation matrices. L is lower triangular with */
+/* unit diagonal elements and U is upper triangular. */
+
+/* Arguments */
+/* ========= */
+
+/* IJOB (input) INTEGER */
+/* IJOB = 2: First compute an approximative null-vector e */
+/* of Z using SGECON, e is normalized and solve for */
+/* Zx = +-e - f with the sign giving the greater value */
+/* of 2-norm(x). About 5 times as expensive as Default. */
+/* IJOB .ne. 2: Local look ahead strategy where all entries of */
+/* the r.h.s. b is choosen as either +1 or -1 (Default). */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Z. */
+
+/* Z (input) REAL array, dimension (LDZ, N) */
+/* On entry, the LU part of the factorization of the n-by-n */
+/* matrix Z computed by SGETC2: Z = P * L * U * Q */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDA >= max(1, N). */
+
+/* RHS (input/output) REAL array, dimension N. */
+/* On entry, RHS contains contributions from other subsystems. */
+/* On exit, RHS contains the solution of the subsystem with */
+/* entries acoording to the value of IJOB (see above). */
+
+/* RDSUM (input/output) REAL */
+/* On entry, the sum of squares of computed contributions to */
+/* the Dif-estimate under computation by STGSYL, where the */
+/* scaling factor RDSCAL (see below) has been factored out. */
+/* On exit, the corresponding sum of squares updated with the */
+/* contributions from the current sub-system. */
+/* If TRANS = 'T' RDSUM is not touched. */
+/* NOTE: RDSUM only makes sense when STGSY2 is called by STGSYL. */
+
+/* RDSCAL (input/output) REAL */
+/* On entry, scaling factor used to prevent overflow in RDSUM. */
+/* On exit, RDSCAL is updated w.r.t. the current contributions */
+/* in RDSUM. */
+/* If TRANS = 'T', RDSCAL is not touched. */
+/* NOTE: RDSCAL only makes sense when STGSY2 is called by */
+/* STGSYL. */
+
+/* IPIV (input) INTEGER array, dimension (N). */
+/* The pivot indices; for 1 <= i <= N, row i of the */
+/* matrix has been interchanged with row IPIV(i). */
+
+/* JPIV (input) INTEGER array, dimension (N). */
+/* The pivot indices; for 1 <= j <= N, column j of the */
+/* matrix has been interchanged with column JPIV(j). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* This routine is a further developed implementation of algorithm */
+/* BSOLVE in [1] using complete pivoting in the LU factorization. */
+
+/* [1] Bo Kagstrom and Lars Westin, */
+/* Generalized Schur Methods with Condition Estimators for */
+/* Solving the Generalized Sylvester Equation, IEEE Transactions */
+/* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. */
+
+/* [2] Peter Poromaa, */
+/* On Efficient and Robust Estimators for the Separation */
+/* between two Regular Matrix Pairs with Applications in */
+/* Condition Estimation. Report IMINF-95.05, Departement of */
+/* Computing Science, Umea University, S-901 87 Umea, Sweden, 1995. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --rhs;
+ --ipiv;
+ --jpiv;
+
+ /* Function Body */
+ if (*ijob != 2) {
+
+/* Apply permutations IPIV to RHS */
+
+ i__1 = *n - 1;
+ slaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &ipiv[1], &c__1);
+
+/* Solve for L-part choosing RHS either to +1 or -1. */
+
+ pmone = -1.f;
+
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ bp = rhs[j] + 1.f;
+ bm = rhs[j] - 1.f;
+ splus = 1.f;
+
+/* Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and */
+/* SMIN computed more efficiently than in BSOLVE [1]. */
+
+ i__2 = *n - j;
+ splus += sdot_(&i__2, &z__[j + 1 + j * z_dim1], &c__1, &z__[j + 1
+ + j * z_dim1], &c__1);
+ i__2 = *n - j;
+ sminu = sdot_(&i__2, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1],
+ &c__1);
+ splus *= rhs[j];
+ if (splus > sminu) {
+ rhs[j] = bp;
+ } else if (sminu > splus) {
+ rhs[j] = bm;
+ } else {
+
+/* In this case the updating sums are equal and we can */
+/* choose RHS(J) +1 or -1. The first time this happens */
+/* we choose -1, thereafter +1. This is a simple way to */
+/* get good estimates of matrices like Byers well-known */
+/* example (see [1]). (Not done in BSOLVE.) */
+
+ rhs[j] += pmone;
+ pmone = 1.f;
+ }
+
+/* Compute the remaining r.h.s. */
+
+ temp = -rhs[j];
+ i__2 = *n - j;
+ saxpy_(&i__2, &temp, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1],
+ &c__1);
+
+/* L10: */
+ }
+
+/* Solve for U-part, look-ahead for RHS(N) = +-1. This is not done */
+/* in BSOLVE and will hopefully give us a better estimate because */
+/* any ill-conditioning of the original matrix is transfered to U */
+/* and not to L. U(N, N) is an approximation to sigma_min(LU). */
+
+ i__1 = *n - 1;
+ scopy_(&i__1, &rhs[1], &c__1, xp, &c__1);
+ xp[*n - 1] = rhs[*n] + 1.f;
+ rhs[*n] += -1.f;
+ splus = 0.f;
+ sminu = 0.f;
+ for (i__ = *n; i__ >= 1; --i__) {
+ temp = 1.f / z__[i__ + i__ * z_dim1];
+ xp[i__ - 1] *= temp;
+ rhs[i__] *= temp;
+ i__1 = *n;
+ for (k = i__ + 1; k <= i__1; ++k) {
+ xp[i__ - 1] -= xp[k - 1] * (z__[i__ + k * z_dim1] * temp);
+ rhs[i__] -= rhs[k] * (z__[i__ + k * z_dim1] * temp);
+/* L20: */
+ }
+ splus += (r__1 = xp[i__ - 1], dabs(r__1));
+ sminu += (r__1 = rhs[i__], dabs(r__1));
+/* L30: */
+ }
+ if (splus > sminu) {
+ scopy_(n, xp, &c__1, &rhs[1], &c__1);
+ }
+
+/* Apply the permutations JPIV to the computed solution (RHS) */
+
+ i__1 = *n - 1;
+ slaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &jpiv[1], &c_n1);
+
+/* Compute the sum of squares */
+
+ slassq_(n, &rhs[1], &c__1, rdscal, rdsum);
+
+ } else {
+
+/* IJOB = 2, Compute approximate nullvector XM of Z */
+
+ sgecon_("I", n, &z__[z_offset], ldz, &c_b23, &temp, work, iwork, &
+ info);
+ scopy_(n, &work[*n], &c__1, xm, &c__1);
+
+/* Compute RHS */
+
+ i__1 = *n - 1;
+ slaswp_(&c__1, xm, ldz, &c__1, &i__1, &ipiv[1], &c_n1);
+ temp = 1.f / sqrt(sdot_(n, xm, &c__1, xm, &c__1));
+ sscal_(n, &temp, xm, &c__1);
+ scopy_(n, xm, &c__1, xp, &c__1);
+ saxpy_(n, &c_b23, &rhs[1], &c__1, xp, &c__1);
+ saxpy_(n, &c_b37, xm, &c__1, &rhs[1], &c__1);
+ sgesc2_(n, &z__[z_offset], ldz, &rhs[1], &ipiv[1], &jpiv[1], &temp);
+ sgesc2_(n, &z__[z_offset], ldz, xp, &ipiv[1], &jpiv[1], &temp);
+ if (sasum_(n, xp, &c__1) > sasum_(n, &rhs[1], &c__1)) {
+ scopy_(n, xp, &c__1, &rhs[1], &c__1);
+ }
+
+/* Compute the sum of squares */
+
+ slassq_(n, &rhs[1], &c__1, rdscal, rdsum);
+
+ }
+
+ return 0;
+
+/* End of SLATDF */
+
+} /* slatdf_ */
diff --git a/SRC/slatps.c b/SRC/slatps.c
new file mode 100644
index 0000000..6ce1742
--- /dev/null
+++ b/SRC/slatps.c
@@ -0,0 +1,822 @@
+/* slatps.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b36 = .5f;
+
+/* Subroutine */ int slatps_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, real *ap, real *x, real *scale, real *cnorm,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, ip;
+ real xj, rec, tjj;
+ integer jinc, jlen;
+ real xbnd;
+ integer imax;
+ real tmax, tjjs;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ real xmax, grow, sumj;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real tscal, uscal;
+ integer jlast;
+ extern doublereal sasum_(integer *, real *, integer *);
+ logical upper;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *), stpsv_(char *, char *, char *, integer *,
+ real *, real *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ extern integer isamax_(integer *, real *, integer *);
+ logical notran;
+ integer jfirst;
+ real smlnum;
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLATPS solves one of the triangular systems */
+
+/* A *x = s*b or A'*x = s*b */
+
+/* with scaling to prevent overflow, where A is an upper or lower */
+/* triangular matrix stored in packed form. Here A' denotes the */
+/* transpose of A, x and b are n-element vectors, and s is a scaling */
+/* factor, usually less than or equal to 1, chosen so that the */
+/* components of x will be less than the overflow threshold. If the */
+/* unscaled problem will not cause overflow, the Level 2 BLAS routine */
+/* STPSV is called. If the matrix A is singular (A(j,j) = 0 for some j), */
+/* then s is set to 0 and a non-trivial solution to A*x = 0 is returned. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': Solve A * x = s*b (No transpose) */
+/* = 'T': Solve A'* x = s*b (Transpose) */
+/* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* NORMIN (input) CHARACTER*1 */
+/* Specifies whether CNORM has been set or not. */
+/* = 'Y': CNORM contains the column norms on entry */
+/* = 'N': CNORM is not set on entry. On exit, the norms will */
+/* be computed and stored in CNORM. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) REAL array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* X (input/output) REAL array, dimension (N) */
+/* On entry, the right hand side b of the triangular system. */
+/* On exit, X is overwritten by the solution vector x. */
+
+/* SCALE (output) REAL */
+/* The scaling factor s for the triangular system */
+/* A * x = s*b or A'* x = s*b. */
+/* If SCALE = 0, the matrix A is singular or badly scaled, and */
+/* the vector x is an exact or approximate solution to A*x = 0. */
+
+/* CNORM (input or output) REAL array, dimension (N) */
+
+/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
+/* contains the norm of the off-diagonal part of the j-th column */
+/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */
+/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
+/* must be greater than or equal to the 1-norm. */
+
+/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
+/* returns the 1-norm of the offdiagonal part of the j-th column */
+/* of A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* Further Details */
+/* ======= ======= */
+
+/* A rough bound on x is computed; if that is less than overflow, STPSV */
+/* is called, otherwise, specific code is used which checks for possible */
+/* overflow or divide-by-zero at every operation. */
+
+/* A columnwise scheme is used for solving A*x = b. The basic algorithm */
+/* if A is lower triangular is */
+
+/* x[1:n] := b[1:n] */
+/* for j = 1, ..., n */
+/* x(j) := x(j) / A(j,j) */
+/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
+/* end */
+
+/* Define bounds on the components of x after j iterations of the loop: */
+/* M(j) = bound on x[1:j] */
+/* G(j) = bound on x[j+1:n] */
+/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */
+
+/* Then for iteration j+1 we have */
+/* M(j+1) <= G(j) / | A(j+1,j+1) | */
+/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
+/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
+
+/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
+/* column j+1 of A, not counting the diagonal. Hence */
+
+/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
+/* 1<=i<=j */
+/* and */
+
+/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
+/* 1<=i< j */
+
+/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine STPSV if the */
+/* reciprocal of the largest M(j), j=1,..,n, is larger than */
+/* max(underflow, 1/overflow). */
+
+/* The bound on x(j) is also used to determine when a step in the */
+/* columnwise method can be performed without fear of overflow. If */
+/* the computed bound is greater than a large constant, x is scaled to */
+/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
+/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
+
+/* Similarly, a row-wise scheme is used to solve A'*x = b. The basic */
+/* algorithm for A upper triangular is */
+
+/* for j = 1, ..., n */
+/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
+/* end */
+
+/* We simultaneously compute two bounds */
+/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
+/* M(j) = bound on x(i), 1<=i<=j */
+
+/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */
+/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
+/* Then the bound on x(j) is */
+
+/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
+
+/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
+/* 1<=i<=j */
+
+/* and we can safely call STPSV if 1/M(n) and 1/G(n) are both greater */
+/* than max(underflow, 1/overflow). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --cnorm;
+ --x;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+/* Test the input parameters. */
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (! lsame_(normin, "Y") && ! lsame_(normin,
+ "N")) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLATPS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine machine dependent parameters to control overflow. */
+
+ smlnum = slamch_("Safe minimum") / slamch_("Precision");
+ bignum = 1.f / smlnum;
+ *scale = 1.f;
+
+ if (lsame_(normin, "N")) {
+
+/* Compute the 1-norm of each column, not including the diagonal. */
+
+ if (upper) {
+
+/* A is upper triangular. */
+
+ ip = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ cnorm[j] = sasum_(&i__2, &ap[ip], &c__1);
+ ip += j;
+/* L10: */
+ }
+ } else {
+
+/* A is lower triangular. */
+
+ ip = 1;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ cnorm[j] = sasum_(&i__2, &ap[ip + 1], &c__1);
+ ip = ip + *n - j + 1;
+/* L20: */
+ }
+ cnorm[*n] = 0.f;
+ }
+ }
+
+/* Scale the column norms by TSCAL if the maximum element in CNORM is */
+/* greater than BIGNUM. */
+
+ imax = isamax_(n, &cnorm[1], &c__1);
+ tmax = cnorm[imax];
+ if (tmax <= bignum) {
+ tscal = 1.f;
+ } else {
+ tscal = 1.f / (smlnum * tmax);
+ sscal_(n, &tscal, &cnorm[1], &c__1);
+ }
+
+/* Compute a bound on the computed solution vector to see if the */
+/* Level 2 BLAS routine STPSV can be used. */
+
+ j = isamax_(n, &x[1], &c__1);
+ xmax = (r__1 = x[j], dabs(r__1));
+ xbnd = xmax;
+ if (notran) {
+
+/* Compute the growth in A * x = b. */
+
+ if (upper) {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ } else {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ }
+
+ if (tscal != 1.f) {
+ grow = 0.f;
+ goto L50;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, G(0) = max{x(i), i=1,...,n}. */
+
+ grow = 1.f / dmax(xbnd,smlnum);
+ xbnd = grow;
+ ip = jfirst * (jfirst + 1) / 2;
+ jlen = *n;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L50;
+ }
+
+/* M(j) = G(j-1) / abs(A(j,j)) */
+
+ tjj = (r__1 = ap[ip], dabs(r__1));
+/* Computing MIN */
+ r__1 = xbnd, r__2 = dmin(1.f,tjj) * grow;
+ xbnd = dmin(r__1,r__2);
+ if (tjj + cnorm[j] >= smlnum) {
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
+
+ grow *= tjj / (tjj + cnorm[j]);
+ } else {
+
+/* G(j) could overflow, set GROW to 0. */
+
+ grow = 0.f;
+ }
+ ip += jinc * jlen;
+ --jlen;
+/* L30: */
+ }
+ grow = xbnd;
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ r__1 = 1.f, r__2 = 1.f / dmax(xbnd,smlnum);
+ grow = dmin(r__1,r__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L50;
+ }
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
+
+ grow *= 1.f / (cnorm[j] + 1.f);
+/* L40: */
+ }
+ }
+L50:
+
+ ;
+ } else {
+
+/* Compute the growth in A' * x = b. */
+
+ if (upper) {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ } else {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ }
+
+ if (tscal != 1.f) {
+ grow = 0.f;
+ goto L80;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, M(0) = max{x(i), i=1,...,n}. */
+
+ grow = 1.f / dmax(xbnd,smlnum);
+ xbnd = grow;
+ ip = jfirst * (jfirst + 1) / 2;
+ jlen = 1;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L80;
+ }
+
+/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
+
+ xj = cnorm[j] + 1.f;
+/* Computing MIN */
+ r__1 = grow, r__2 = xbnd / xj;
+ grow = dmin(r__1,r__2);
+
+/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
+
+ tjj = (r__1 = ap[ip], dabs(r__1));
+ if (xj > tjj) {
+ xbnd *= tjj / xj;
+ }
+ ++jlen;
+ ip += jinc * jlen;
+/* L60: */
+ }
+ grow = dmin(grow,xbnd);
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ r__1 = 1.f, r__2 = 1.f / dmax(xbnd,smlnum);
+ grow = dmin(r__1,r__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L80;
+ }
+
+/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
+
+ xj = cnorm[j] + 1.f;
+ grow /= xj;
+/* L70: */
+ }
+ }
+L80:
+ ;
+ }
+
+ if (grow * tscal > smlnum) {
+
+/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
+/* elements of X is not too small. */
+
+ stpsv_(uplo, trans, diag, n, &ap[1], &x[1], &c__1);
+ } else {
+
+/* Use a Level 1 BLAS solve, scaling intermediate results. */
+
+ if (xmax > bignum) {
+
+/* Scale X so that its components are less than or equal to */
+/* BIGNUM in absolute value. */
+
+ *scale = bignum / xmax;
+ sscal_(n, scale, &x[1], &c__1);
+ xmax = bignum;
+ }
+
+ if (notran) {
+
+/* Solve A * x = b */
+
+ ip = jfirst * (jfirst + 1) / 2;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
+
+ xj = (r__1 = x[j], dabs(r__1));
+ if (nounit) {
+ tjjs = ap[ip] * tscal;
+ } else {
+ tjjs = tscal;
+ if (tscal == 1.f) {
+ goto L95;
+ }
+ }
+ tjj = dabs(tjjs);
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.f) {
+ if (xj > tjj * bignum) {
+
+/* Scale x by 1/b(j). */
+
+ rec = 1.f / xj;
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ x[j] /= tjjs;
+ xj = (r__1 = x[j], dabs(r__1));
+ } else if (tjj > 0.f) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
+/* to avoid overflow when dividing by A(j,j). */
+
+ rec = tjj * bignum / xj;
+ if (cnorm[j] > 1.f) {
+
+/* Scale by 1/CNORM(j) to avoid overflow when */
+/* multiplying x(j) times column j. */
+
+ rec /= cnorm[j];
+ }
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ x[j] /= tjjs;
+ xj = (r__1 = x[j], dabs(r__1));
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0, and compute a solution to A*x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ x[i__] = 0.f;
+/* L90: */
+ }
+ x[j] = 1.f;
+ xj = 1.f;
+ *scale = 0.f;
+ xmax = 0.f;
+ }
+L95:
+
+/* Scale x if necessary to avoid overflow when adding a */
+/* multiple of column j of A. */
+
+ if (xj > 1.f) {
+ rec = 1.f / xj;
+ if (cnorm[j] > (bignum - xmax) * rec) {
+
+/* Scale x by 1/(2*abs(x(j))). */
+
+ rec *= .5f;
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ }
+ } else if (xj * cnorm[j] > bignum - xmax) {
+
+/* Scale x by 1/2. */
+
+ sscal_(n, &c_b36, &x[1], &c__1);
+ *scale *= .5f;
+ }
+
+ if (upper) {
+ if (j > 1) {
+
+/* Compute the update */
+/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */
+
+ i__3 = j - 1;
+ r__1 = -x[j] * tscal;
+ saxpy_(&i__3, &r__1, &ap[ip - j + 1], &c__1, &x[1], &
+ c__1);
+ i__3 = j - 1;
+ i__ = isamax_(&i__3, &x[1], &c__1);
+ xmax = (r__1 = x[i__], dabs(r__1));
+ }
+ ip -= j;
+ } else {
+ if (j < *n) {
+
+/* Compute the update */
+/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */
+
+ i__3 = *n - j;
+ r__1 = -x[j] * tscal;
+ saxpy_(&i__3, &r__1, &ap[ip + 1], &c__1, &x[j + 1], &
+ c__1);
+ i__3 = *n - j;
+ i__ = j + isamax_(&i__3, &x[j + 1], &c__1);
+ xmax = (r__1 = x[i__], dabs(r__1));
+ }
+ ip = ip + *n - j + 1;
+ }
+/* L100: */
+ }
+
+ } else {
+
+/* Solve A' * x = b */
+
+ ip = jfirst * (jfirst + 1) / 2;
+ jlen = 1;
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
+/* k<>j */
+
+ xj = (r__1 = x[j], dabs(r__1));
+ uscal = tscal;
+ rec = 1.f / dmax(xmax,1.f);
+ if (cnorm[j] > (bignum - xj) * rec) {
+
+/* If x(j) could overflow, scale x by 1/(2*XMAX). */
+
+ rec *= .5f;
+ if (nounit) {
+ tjjs = ap[ip] * tscal;
+ } else {
+ tjjs = tscal;
+ }
+ tjj = dabs(tjjs);
+ if (tjj > 1.f) {
+
+/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
+
+/* Computing MIN */
+ r__1 = 1.f, r__2 = rec * tjj;
+ rec = dmin(r__1,r__2);
+ uscal /= tjjs;
+ }
+ if (rec < 1.f) {
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ sumj = 0.f;
+ if (uscal == 1.f) {
+
+/* If the scaling needed for A in the dot product is 1, */
+/* call SDOT to perform the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ sumj = sdot_(&i__3, &ap[ip - j + 1], &c__1, &x[1], &
+ c__1);
+ } else if (j < *n) {
+ i__3 = *n - j;
+ sumj = sdot_(&i__3, &ap[ip + 1], &c__1, &x[j + 1], &
+ c__1);
+ }
+ } else {
+
+/* Otherwise, use in-line code for the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ sumj += ap[ip - j + i__] * uscal * x[i__];
+/* L110: */
+ }
+ } else if (j < *n) {
+ i__3 = *n - j;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ sumj += ap[ip + i__] * uscal * x[j + i__];
+/* L120: */
+ }
+ }
+ }
+
+ if (uscal == tscal) {
+
+/* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) */
+/* was not used to scale the dotproduct. */
+
+ x[j] -= sumj;
+ xj = (r__1 = x[j], dabs(r__1));
+ if (nounit) {
+
+/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
+
+ tjjs = ap[ip] * tscal;
+ } else {
+ tjjs = tscal;
+ if (tscal == 1.f) {
+ goto L135;
+ }
+ }
+ tjj = dabs(tjjs);
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.f) {
+ if (xj > tjj * bignum) {
+
+/* Scale X by 1/abs(x(j)). */
+
+ rec = 1.f / xj;
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ x[j] /= tjjs;
+ } else if (tjj > 0.f) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
+
+ rec = tjj * bignum / xj;
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ x[j] /= tjjs;
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0, and compute a solution to A'*x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ x[i__] = 0.f;
+/* L130: */
+ }
+ x[j] = 1.f;
+ *scale = 0.f;
+ xmax = 0.f;
+ }
+L135:
+ ;
+ } else {
+
+/* Compute x(j) := x(j) / A(j,j) - sumj if the dot */
+/* product has already been divided by 1/A(j,j). */
+
+ x[j] = x[j] / tjjs - sumj;
+ }
+/* Computing MAX */
+ r__2 = xmax, r__3 = (r__1 = x[j], dabs(r__1));
+ xmax = dmax(r__2,r__3);
+ ++jlen;
+ ip += jinc * jlen;
+/* L140: */
+ }
+ }
+ *scale /= tscal;
+ }
+
+/* Scale the column norms by 1/TSCAL for return. */
+
+ if (tscal != 1.f) {
+ r__1 = 1.f / tscal;
+ sscal_(n, &r__1, &cnorm[1], &c__1);
+ }
+
+ return 0;
+
+/* End of SLATPS */
+
+} /* slatps_ */
diff --git a/SRC/slatrd.c b/SRC/slatrd.c
new file mode 100644
index 0000000..6be05d9
--- /dev/null
+++ b/SRC/slatrd.c
@@ -0,0 +1,351 @@
+/* slatrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b5 = -1.f;
+static real c_b6 = 1.f;
+static integer c__1 = 1;
+static real c_b16 = 0.f;
+
+/* Subroutine */ int slatrd_(char *uplo, integer *n, integer *nb, real *a,
+ integer *lda, real *e, real *tau, real *w, integer *ldw)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, iw;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ real alpha;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ sgemv_(char *, integer *, integer *, real *, real *, integer *,
+ real *, integer *, real *, real *, integer *), saxpy_(
+ integer *, real *, real *, integer *, real *, integer *), ssymv_(
+ char *, integer *, real *, real *, integer *, real *, integer *,
+ real *, real *, integer *), slarfg_(integer *, real *,
+ real *, integer *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLATRD reduces NB rows and columns of a real symmetric matrix A to */
+/* symmetric tridiagonal form by an orthogonal similarity */
+/* transformation Q' * A * Q, and returns the matrices V and W which are */
+/* needed to apply the transformation to the unreduced part of A. */
+
+/* If UPLO = 'U', SLATRD reduces the last NB rows and columns of a */
+/* matrix, of which the upper triangle is supplied; */
+/* if UPLO = 'L', SLATRD reduces the first NB rows and columns of a */
+/* matrix, of which the lower triangle is supplied. */
+
+/* This is an auxiliary routine called by SSYTRD. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* NB (input) INTEGER */
+/* The number of rows and columns to be reduced. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n-by-n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n-by-n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+/* On exit: */
+/* if UPLO = 'U', the last NB columns have been reduced to */
+/* tridiagonal form, with the diagonal elements overwriting */
+/* the diagonal elements of A; the elements above the diagonal */
+/* with the array TAU, represent the orthogonal matrix Q as a */
+/* product of elementary reflectors; */
+/* if UPLO = 'L', the first NB columns have been reduced to */
+/* tridiagonal form, with the diagonal elements overwriting */
+/* the diagonal elements of A; the elements below the diagonal */
+/* with the array TAU, represent the orthogonal matrix Q as a */
+/* product of elementary reflectors. */
+/* See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= (1,N). */
+
+/* E (output) REAL array, dimension (N-1) */
+/* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal */
+/* elements of the last NB columns of the reduced matrix; */
+/* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of */
+/* the first NB columns of the reduced matrix. */
+
+/* TAU (output) REAL array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors, stored in */
+/* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. */
+/* See Further Details. */
+
+/* W (output) REAL array, dimension (LDW,NB) */
+/* The n-by-nb matrix W required to update the unreduced part */
+/* of A. */
+
+/* LDW (input) INTEGER */
+/* The leading dimension of the array W. LDW >= max(1,N). */
+
+/* Further Details */
+/* =============== */
+
+/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(n) H(n-1) . . . H(n-nb+1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), */
+/* and tau in TAU(i-1). */
+
+/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(1) H(2) . . . H(nb). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */
+/* and tau in TAU(i). */
+
+/* The elements of the vectors v together form the n-by-nb matrix V */
+/* which is needed, with W, to apply the transformation to the unreduced */
+/* part of the matrix, using a symmetric rank-2k update of the form: */
+/* A := A - V*W' - W*V'. */
+
+/* The contents of A on exit are illustrated by the following examples */
+/* with n = 5 and nb = 2: */
+
+/* if UPLO = 'U': if UPLO = 'L': */
+
+/* ( a a a v4 v5 ) ( d ) */
+/* ( a a v4 v5 ) ( 1 d ) */
+/* ( a 1 v5 ) ( v1 1 a ) */
+/* ( d 1 ) ( v1 v2 a a ) */
+/* ( d ) ( v1 v2 a a a ) */
+
+/* where d denotes a diagonal element of the reduced matrix, a denotes */
+/* an element of the original matrix that is unchanged, and vi denotes */
+/* an element of the vector defining H(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --e;
+ --tau;
+ w_dim1 = *ldw;
+ w_offset = 1 + w_dim1;
+ w -= w_offset;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+
+ if (lsame_(uplo, "U")) {
+
+/* Reduce last NB columns of upper triangle */
+
+ i__1 = *n - *nb + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ iw = i__ - *n + *nb;
+ if (i__ < *n) {
+
+/* Update A(1:i,i) */
+
+ i__2 = *n - i__;
+ sgemv_("No transpose", &i__, &i__2, &c_b5, &a[(i__ + 1) *
+ a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, &
+ c_b6, &a[i__ * a_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ sgemv_("No transpose", &i__, &i__2, &c_b5, &w[(iw + 1) *
+ w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, &
+ c_b6, &a[i__ * a_dim1 + 1], &c__1);
+ }
+ if (i__ > 1) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* A(1:i-2,i) */
+
+ i__2 = i__ - 1;
+ slarfg_(&i__2, &a[i__ - 1 + i__ * a_dim1], &a[i__ * a_dim1 +
+ 1], &c__1, &tau[i__ - 1]);
+ e[i__ - 1] = a[i__ - 1 + i__ * a_dim1];
+ a[i__ - 1 + i__ * a_dim1] = 1.f;
+
+/* Compute W(1:i-1,i) */
+
+ i__2 = i__ - 1;
+ ssymv_("Upper", &i__2, &c_b6, &a[a_offset], lda, &a[i__ *
+ a_dim1 + 1], &c__1, &c_b16, &w[iw * w_dim1 + 1], &
+ c__1);
+ if (i__ < *n) {
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ sgemv_("Transpose", &i__2, &i__3, &c_b6, &w[(iw + 1) *
+ w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], &c__1, &
+ c_b16, &w[i__ + 1 + iw * w_dim1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ sgemv_("No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) *
+ a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], &
+ c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ sgemv_("Transpose", &i__2, &i__3, &c_b6, &a[(i__ + 1) *
+ a_dim1 + 1], lda, &a[i__ * a_dim1 + 1], &c__1, &
+ c_b16, &w[i__ + 1 + iw * w_dim1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ sgemv_("No transpose", &i__2, &i__3, &c_b5, &w[(iw + 1) *
+ w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], &
+ c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1);
+ }
+ i__2 = i__ - 1;
+ sscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ alpha = tau[i__ - 1] * -.5f * sdot_(&i__2, &w[iw * w_dim1 + 1]
+, &c__1, &a[i__ * a_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ saxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw *
+ w_dim1 + 1], &c__1);
+ }
+
+/* L10: */
+ }
+ } else {
+
+/* Reduce first NB columns of lower triangle */
+
+ i__1 = *nb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Update A(i:n,i) */
+
+ i__2 = *n - i__ + 1;
+ i__3 = i__ - 1;
+ sgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1], lda,
+ &w[i__ + w_dim1], ldw, &c_b6, &a[i__ + i__ * a_dim1], &
+ c__1);
+ i__2 = *n - i__ + 1;
+ i__3 = i__ - 1;
+ sgemv_("No transpose", &i__2, &i__3, &c_b5, &w[i__ + w_dim1], ldw,
+ &a[i__ + a_dim1], lda, &c_b6, &a[i__ + i__ * a_dim1], &
+ c__1);
+ if (i__ < *n) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* A(i+2:n,i) */
+
+ i__2 = *n - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ slarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *n)+
+ i__ * a_dim1], &c__1, &tau[i__]);
+ e[i__] = a[i__ + 1 + i__ * a_dim1];
+ a[i__ + 1 + i__ * a_dim1] = 1.f;
+
+/* Compute W(i+1:n,i) */
+
+ i__2 = *n - i__;
+ ssymv_("Lower", &i__2, &c_b6, &a[i__ + 1 + (i__ + 1) * a_dim1]
+, lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[
+ i__ + 1 + i__ * w_dim1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ sgemv_("Transpose", &i__2, &i__3, &c_b6, &w[i__ + 1 + w_dim1],
+ ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[
+ i__ * w_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ sgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 +
+ a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[
+ i__ + 1 + i__ * w_dim1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ sgemv_("Transpose", &i__2, &i__3, &c_b6, &a[i__ + 1 + a_dim1],
+ lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[
+ i__ * w_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ sgemv_("No transpose", &i__2, &i__3, &c_b5, &w[i__ + 1 +
+ w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[
+ i__ + 1 + i__ * w_dim1], &c__1);
+ i__2 = *n - i__;
+ sscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1);
+ i__2 = *n - i__;
+ alpha = tau[i__] * -.5f * sdot_(&i__2, &w[i__ + 1 + i__ *
+ w_dim1], &c__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
+ i__2 = *n - i__;
+ saxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[
+ i__ + 1 + i__ * w_dim1], &c__1);
+ }
+
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of SLATRD */
+
+} /* slatrd_ */
diff --git a/SRC/slatrs.c b/SRC/slatrs.c
new file mode 100644
index 0000000..f996294
--- /dev/null
+++ b/SRC/slatrs.c
@@ -0,0 +1,813 @@
+/* slatrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b36 = .5f;
+
+/* Subroutine */ int slatrs_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, real *a, integer *lda, real *x, real *scale, real
+ *cnorm, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j;
+ real xj, rec, tjj;
+ integer jinc;
+ real xbnd;
+ integer imax;
+ real tmax, tjjs;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ real xmax, grow, sumj;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real tscal, uscal;
+ integer jlast;
+ extern doublereal sasum_(integer *, real *, integer *);
+ logical upper;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *), strsv_(char *, char *, char *, integer *,
+ real *, integer *, real *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ extern integer isamax_(integer *, real *, integer *);
+ logical notran;
+ integer jfirst;
+ real smlnum;
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLATRS solves one of the triangular systems */
+
+/* A *x = s*b or A'*x = s*b */
+
+/* with scaling to prevent overflow. Here A is an upper or lower */
+/* triangular matrix, A' denotes the transpose of A, x and b are */
+/* n-element vectors, and s is a scaling factor, usually less than */
+/* or equal to 1, chosen so that the components of x will be less than */
+/* the overflow threshold. If the unscaled problem will not cause */
+/* overflow, the Level 2 BLAS routine STRSV is called. If the matrix A */
+/* is singular (A(j,j) = 0 for some j), then s is set to 0 and a */
+/* non-trivial solution to A*x = 0 is returned. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': Solve A * x = s*b (No transpose) */
+/* = 'T': Solve A'* x = s*b (Transpose) */
+/* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* NORMIN (input) CHARACTER*1 */
+/* Specifies whether CNORM has been set or not. */
+/* = 'Y': CNORM contains the column norms on entry */
+/* = 'N': CNORM is not set on entry. On exit, the norms will */
+/* be computed and stored in CNORM. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max (1,N). */
+
+/* X (input/output) REAL array, dimension (N) */
+/* On entry, the right hand side b of the triangular system. */
+/* On exit, X is overwritten by the solution vector x. */
+
+/* SCALE (output) REAL */
+/* The scaling factor s for the triangular system */
+/* A * x = s*b or A'* x = s*b. */
+/* If SCALE = 0, the matrix A is singular or badly scaled, and */
+/* the vector x is an exact or approximate solution to A*x = 0. */
+
+/* CNORM (input or output) REAL array, dimension (N) */
+
+/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
+/* contains the norm of the off-diagonal part of the j-th column */
+/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */
+/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
+/* must be greater than or equal to the 1-norm. */
+
+/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
+/* returns the 1-norm of the offdiagonal part of the j-th column */
+/* of A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* Further Details */
+/* ======= ======= */
+
+/* A rough bound on x is computed; if that is less than overflow, STRSV */
+/* is called, otherwise, specific code is used which checks for possible */
+/* overflow or divide-by-zero at every operation. */
+
+/* A columnwise scheme is used for solving A*x = b. The basic algorithm */
+/* if A is lower triangular is */
+
+/* x[1:n] := b[1:n] */
+/* for j = 1, ..., n */
+/* x(j) := x(j) / A(j,j) */
+/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
+/* end */
+
+/* Define bounds on the components of x after j iterations of the loop: */
+/* M(j) = bound on x[1:j] */
+/* G(j) = bound on x[j+1:n] */
+/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */
+
+/* Then for iteration j+1 we have */
+/* M(j+1) <= G(j) / | A(j+1,j+1) | */
+/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
+/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
+
+/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
+/* column j+1 of A, not counting the diagonal. Hence */
+
+/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
+/* 1<=i<=j */
+/* and */
+
+/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
+/* 1<=i< j */
+
+/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine STRSV if the */
+/* reciprocal of the largest M(j), j=1,..,n, is larger than */
+/* max(underflow, 1/overflow). */
+
+/* The bound on x(j) is also used to determine when a step in the */
+/* columnwise method can be performed without fear of overflow. If */
+/* the computed bound is greater than a large constant, x is scaled to */
+/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
+/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
+
+/* Similarly, a row-wise scheme is used to solve A'*x = b. The basic */
+/* algorithm for A upper triangular is */
+
+/* for j = 1, ..., n */
+/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
+/* end */
+
+/* We simultaneously compute two bounds */
+/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
+/* M(j) = bound on x(i), 1<=i<=j */
+
+/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */
+/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
+/* Then the bound on x(j) is */
+
+/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
+
+/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
+/* 1<=i<=j */
+
+/* and we can safely call STRSV if 1/M(n) and 1/G(n) are both greater */
+/* than max(underflow, 1/overflow). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --cnorm;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+/* Test the input parameters. */
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (! lsame_(normin, "Y") && ! lsame_(normin,
+ "N")) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLATRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine machine dependent parameters to control overflow. */
+
+ smlnum = slamch_("Safe minimum") / slamch_("Precision");
+ bignum = 1.f / smlnum;
+ *scale = 1.f;
+
+ if (lsame_(normin, "N")) {
+
+/* Compute the 1-norm of each column, not including the diagonal. */
+
+ if (upper) {
+
+/* A is upper triangular. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ cnorm[j] = sasum_(&i__2, &a[j * a_dim1 + 1], &c__1);
+/* L10: */
+ }
+ } else {
+
+/* A is lower triangular. */
+
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ cnorm[j] = sasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1);
+/* L20: */
+ }
+ cnorm[*n] = 0.f;
+ }
+ }
+
+/* Scale the column norms by TSCAL if the maximum element in CNORM is */
+/* greater than BIGNUM. */
+
+ imax = isamax_(n, &cnorm[1], &c__1);
+ tmax = cnorm[imax];
+ if (tmax <= bignum) {
+ tscal = 1.f;
+ } else {
+ tscal = 1.f / (smlnum * tmax);
+ sscal_(n, &tscal, &cnorm[1], &c__1);
+ }
+
+/* Compute a bound on the computed solution vector to see if the */
+/* Level 2 BLAS routine STRSV can be used. */
+
+ j = isamax_(n, &x[1], &c__1);
+ xmax = (r__1 = x[j], dabs(r__1));
+ xbnd = xmax;
+ if (notran) {
+
+/* Compute the growth in A * x = b. */
+
+ if (upper) {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ } else {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ }
+
+ if (tscal != 1.f) {
+ grow = 0.f;
+ goto L50;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, G(0) = max{x(i), i=1,...,n}. */
+
+ grow = 1.f / dmax(xbnd,smlnum);
+ xbnd = grow;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L50;
+ }
+
+/* M(j) = G(j-1) / abs(A(j,j)) */
+
+ tjj = (r__1 = a[j + j * a_dim1], dabs(r__1));
+/* Computing MIN */
+ r__1 = xbnd, r__2 = dmin(1.f,tjj) * grow;
+ xbnd = dmin(r__1,r__2);
+ if (tjj + cnorm[j] >= smlnum) {
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
+
+ grow *= tjj / (tjj + cnorm[j]);
+ } else {
+
+/* G(j) could overflow, set GROW to 0. */
+
+ grow = 0.f;
+ }
+/* L30: */
+ }
+ grow = xbnd;
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ r__1 = 1.f, r__2 = 1.f / dmax(xbnd,smlnum);
+ grow = dmin(r__1,r__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L50;
+ }
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
+
+ grow *= 1.f / (cnorm[j] + 1.f);
+/* L40: */
+ }
+ }
+L50:
+
+ ;
+ } else {
+
+/* Compute the growth in A' * x = b. */
+
+ if (upper) {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ } else {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ }
+
+ if (tscal != 1.f) {
+ grow = 0.f;
+ goto L80;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, M(0) = max{x(i), i=1,...,n}. */
+
+ grow = 1.f / dmax(xbnd,smlnum);
+ xbnd = grow;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L80;
+ }
+
+/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
+
+ xj = cnorm[j] + 1.f;
+/* Computing MIN */
+ r__1 = grow, r__2 = xbnd / xj;
+ grow = dmin(r__1,r__2);
+
+/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
+
+ tjj = (r__1 = a[j + j * a_dim1], dabs(r__1));
+ if (xj > tjj) {
+ xbnd *= tjj / xj;
+ }
+/* L60: */
+ }
+ grow = dmin(grow,xbnd);
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ r__1 = 1.f, r__2 = 1.f / dmax(xbnd,smlnum);
+ grow = dmin(r__1,r__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L80;
+ }
+
+/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
+
+ xj = cnorm[j] + 1.f;
+ grow /= xj;
+/* L70: */
+ }
+ }
+L80:
+ ;
+ }
+
+ if (grow * tscal > smlnum) {
+
+/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
+/* elements of X is not too small. */
+
+ strsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1);
+ } else {
+
+/* Use a Level 1 BLAS solve, scaling intermediate results. */
+
+ if (xmax > bignum) {
+
+/* Scale X so that its components are less than or equal to */
+/* BIGNUM in absolute value. */
+
+ *scale = bignum / xmax;
+ sscal_(n, scale, &x[1], &c__1);
+ xmax = bignum;
+ }
+
+ if (notran) {
+
+/* Solve A * x = b */
+
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
+
+ xj = (r__1 = x[j], dabs(r__1));
+ if (nounit) {
+ tjjs = a[j + j * a_dim1] * tscal;
+ } else {
+ tjjs = tscal;
+ if (tscal == 1.f) {
+ goto L95;
+ }
+ }
+ tjj = dabs(tjjs);
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.f) {
+ if (xj > tjj * bignum) {
+
+/* Scale x by 1/b(j). */
+
+ rec = 1.f / xj;
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ x[j] /= tjjs;
+ xj = (r__1 = x[j], dabs(r__1));
+ } else if (tjj > 0.f) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
+/* to avoid overflow when dividing by A(j,j). */
+
+ rec = tjj * bignum / xj;
+ if (cnorm[j] > 1.f) {
+
+/* Scale by 1/CNORM(j) to avoid overflow when */
+/* multiplying x(j) times column j. */
+
+ rec /= cnorm[j];
+ }
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ x[j] /= tjjs;
+ xj = (r__1 = x[j], dabs(r__1));
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0, and compute a solution to A*x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ x[i__] = 0.f;
+/* L90: */
+ }
+ x[j] = 1.f;
+ xj = 1.f;
+ *scale = 0.f;
+ xmax = 0.f;
+ }
+L95:
+
+/* Scale x if necessary to avoid overflow when adding a */
+/* multiple of column j of A. */
+
+ if (xj > 1.f) {
+ rec = 1.f / xj;
+ if (cnorm[j] > (bignum - xmax) * rec) {
+
+/* Scale x by 1/(2*abs(x(j))). */
+
+ rec *= .5f;
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ }
+ } else if (xj * cnorm[j] > bignum - xmax) {
+
+/* Scale x by 1/2. */
+
+ sscal_(n, &c_b36, &x[1], &c__1);
+ *scale *= .5f;
+ }
+
+ if (upper) {
+ if (j > 1) {
+
+/* Compute the update */
+/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */
+
+ i__3 = j - 1;
+ r__1 = -x[j] * tscal;
+ saxpy_(&i__3, &r__1, &a[j * a_dim1 + 1], &c__1, &x[1],
+ &c__1);
+ i__3 = j - 1;
+ i__ = isamax_(&i__3, &x[1], &c__1);
+ xmax = (r__1 = x[i__], dabs(r__1));
+ }
+ } else {
+ if (j < *n) {
+
+/* Compute the update */
+/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */
+
+ i__3 = *n - j;
+ r__1 = -x[j] * tscal;
+ saxpy_(&i__3, &r__1, &a[j + 1 + j * a_dim1], &c__1, &
+ x[j + 1], &c__1);
+ i__3 = *n - j;
+ i__ = j + isamax_(&i__3, &x[j + 1], &c__1);
+ xmax = (r__1 = x[i__], dabs(r__1));
+ }
+ }
+/* L100: */
+ }
+
+ } else {
+
+/* Solve A' * x = b */
+
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
+/* k<>j */
+
+ xj = (r__1 = x[j], dabs(r__1));
+ uscal = tscal;
+ rec = 1.f / dmax(xmax,1.f);
+ if (cnorm[j] > (bignum - xj) * rec) {
+
+/* If x(j) could overflow, scale x by 1/(2*XMAX). */
+
+ rec *= .5f;
+ if (nounit) {
+ tjjs = a[j + j * a_dim1] * tscal;
+ } else {
+ tjjs = tscal;
+ }
+ tjj = dabs(tjjs);
+ if (tjj > 1.f) {
+
+/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
+
+/* Computing MIN */
+ r__1 = 1.f, r__2 = rec * tjj;
+ rec = dmin(r__1,r__2);
+ uscal /= tjjs;
+ }
+ if (rec < 1.f) {
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ sumj = 0.f;
+ if (uscal == 1.f) {
+
+/* If the scaling needed for A in the dot product is 1, */
+/* call SDOT to perform the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ sumj = sdot_(&i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
+ &c__1);
+ } else if (j < *n) {
+ i__3 = *n - j;
+ sumj = sdot_(&i__3, &a[j + 1 + j * a_dim1], &c__1, &x[
+ j + 1], &c__1);
+ }
+ } else {
+
+/* Otherwise, use in-line code for the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ sumj += a[i__ + j * a_dim1] * uscal * x[i__];
+/* L110: */
+ }
+ } else if (j < *n) {
+ i__3 = *n;
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ sumj += a[i__ + j * a_dim1] * uscal * x[i__];
+/* L120: */
+ }
+ }
+ }
+
+ if (uscal == tscal) {
+
+/* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) */
+/* was not used to scale the dotproduct. */
+
+ x[j] -= sumj;
+ xj = (r__1 = x[j], dabs(r__1));
+ if (nounit) {
+ tjjs = a[j + j * a_dim1] * tscal;
+ } else {
+ tjjs = tscal;
+ if (tscal == 1.f) {
+ goto L135;
+ }
+ }
+
+/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
+
+ tjj = dabs(tjjs);
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.f) {
+ if (xj > tjj * bignum) {
+
+/* Scale X by 1/abs(x(j)). */
+
+ rec = 1.f / xj;
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ x[j] /= tjjs;
+ } else if (tjj > 0.f) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
+
+ rec = tjj * bignum / xj;
+ sscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ x[j] /= tjjs;
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0, and compute a solution to A'*x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ x[i__] = 0.f;
+/* L130: */
+ }
+ x[j] = 1.f;
+ *scale = 0.f;
+ xmax = 0.f;
+ }
+L135:
+ ;
+ } else {
+
+/* Compute x(j) := x(j) / A(j,j) - sumj if the dot */
+/* product has already been divided by 1/A(j,j). */
+
+ x[j] = x[j] / tjjs - sumj;
+ }
+/* Computing MAX */
+ r__2 = xmax, r__3 = (r__1 = x[j], dabs(r__1));
+ xmax = dmax(r__2,r__3);
+/* L140: */
+ }
+ }
+ *scale /= tscal;
+ }
+
+/* Scale the column norms by 1/TSCAL for return. */
+
+ if (tscal != 1.f) {
+ r__1 = 1.f / tscal;
+ sscal_(n, &r__1, &cnorm[1], &c__1);
+ }
+
+ return 0;
+
+/* End of SLATRS */
+
+} /* slatrs_ */
diff --git a/SRC/slatrz.c b/SRC/slatrz.c
new file mode 100644
index 0000000..c6cd038
--- /dev/null
+++ b/SRC/slatrz.c
@@ -0,0 +1,162 @@
+/* slatrz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slatrz_(integer *m, integer *n, integer *l, real *a,
+ integer *lda, real *tau, real *work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__;
+ extern /* Subroutine */ int slarz_(char *, integer *, integer *, integer *
+, real *, integer *, real *, real *, integer *, real *),
+ slarfp_(integer *, real *, real *, integer *, real *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLATRZ factors the M-by-(M+L) real upper trapezoidal matrix */
+/* [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z, by means */
+/* of orthogonal transformations. Z is an (M+L)-by-(M+L) orthogonal */
+/* matrix and, R and A1 are M-by-M upper triangular matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* L (input) INTEGER */
+/* The number of columns of the matrix A containing the */
+/* meaningful part of the Householder vectors. N-M >= L >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the leading M-by-N upper trapezoidal part of the */
+/* array A must contain the matrix to be factorized. */
+/* On exit, the leading M-by-M upper triangular part of A */
+/* contains the upper triangular matrix R, and elements N-L+1 to */
+/* N of the first M rows of A, with the array TAU, represent the */
+/* orthogonal matrix Z as a product of M elementary reflectors. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) REAL array, dimension (M) */
+/* The scalar factors of the elementary reflectors. */
+
+/* WORK (workspace) REAL array, dimension (M) */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* The factorization is obtained by Householder's method. The kth */
+/* transformation matrix, Z( k ), which is used to introduce zeros into */
+/* the ( m - k + 1 )th row of A, is given in the form */
+
+/* Z( k ) = ( I 0 ), */
+/* ( 0 T( k ) ) */
+
+/* where */
+
+/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */
+/* ( 0 ) */
+/* ( z( k ) ) */
+
+/* tau is a scalar and z( k ) is an l element vector. tau and z( k ) */
+/* are chosen to annihilate the elements of the kth row of A2. */
+
+/* The scalar tau is returned in the kth element of TAU and the vector */
+/* u( k ) in the kth row of A2, such that the elements of z( k ) are */
+/* in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in */
+/* the upper triangular part of A1. */
+
+/* Z is given by */
+
+/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ if (*m == 0) {
+ return 0;
+ } else if (*m == *n) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tau[i__] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+ for (i__ = *m; i__ >= 1; --i__) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* [ A(i,i) A(i,n-l+1:n) ] */
+
+ i__1 = *l + 1;
+ slarfp_(&i__1, &a[i__ + i__ * a_dim1], &a[i__ + (*n - *l + 1) *
+ a_dim1], lda, &tau[i__]);
+
+/* Apply H(i) to A(1:i-1,i:n) from the right */
+
+ i__1 = i__ - 1;
+ i__2 = *n - i__ + 1;
+ slarz_("Right", &i__1, &i__2, l, &a[i__ + (*n - *l + 1) * a_dim1],
+ lda, &tau[i__], &a[i__ * a_dim1 + 1], lda, &work[1]);
+
+/* L20: */
+ }
+
+ return 0;
+
+/* End of SLATRZ */
+
+} /* slatrz_ */
diff --git a/SRC/slatzm.c b/SRC/slatzm.c
new file mode 100644
index 0000000..48279d7
--- /dev/null
+++ b/SRC/slatzm.c
@@ -0,0 +1,189 @@
+/* slatzm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b5 = 1.f;
+
+/* Subroutine */ int slatzm_(char *side, integer *m, integer *n, real *v,
+ integer *incv, real *tau, real *c1, real *c2, integer *ldc, real *
+ work)
+{
+ /* System generated locals */
+ integer c1_dim1, c1_offset, c2_dim1, c2_offset, i__1;
+ real r__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *),
+ saxpy_(integer *, real *, real *, integer *, real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine SORMRZ. */
+
+/* SLATZM applies a Householder matrix generated by STZRQF to a matrix. */
+
+/* Let P = I - tau*u*u', u = ( 1 ), */
+/* ( v ) */
+/* where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if */
+/* SIDE = 'R'. */
+
+/* If SIDE equals 'L', let */
+/* C = [ C1 ] 1 */
+/* [ C2 ] m-1 */
+/* n */
+/* Then C is overwritten by P*C. */
+
+/* If SIDE equals 'R', let */
+/* C = [ C1, C2 ] m */
+/* 1 n-1 */
+/* Then C is overwritten by C*P. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': form P * C */
+/* = 'R': form C * P */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* V (input) REAL array, dimension */
+/* (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
+/* (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
+/* The vector v in the representation of P. V is not used */
+/* if TAU = 0. */
+
+/* INCV (input) INTEGER */
+/* The increment between elements of v. INCV <> 0 */
+
+/* TAU (input) REAL */
+/* The value tau in the representation of P. */
+
+/* C1 (input/output) REAL array, dimension */
+/* (LDC,N) if SIDE = 'L' */
+/* (M,1) if SIDE = 'R' */
+/* On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1 */
+/* if SIDE = 'R'. */
+
+/* On exit, the first row of P*C if SIDE = 'L', or the first */
+/* column of C*P if SIDE = 'R'. */
+
+/* C2 (input/output) REAL array, dimension */
+/* (LDC, N) if SIDE = 'L' */
+/* (LDC, N-1) if SIDE = 'R' */
+/* On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the */
+/* m x (n - 1) matrix C2 if SIDE = 'R'. */
+
+/* On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P */
+/* if SIDE = 'R'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the arrays C1 and C2. LDC >= (1,M). */
+
+/* WORK (workspace) REAL array, dimension */
+/* (N) if SIDE = 'L' */
+/* (M) if SIDE = 'R' */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --v;
+ c2_dim1 = *ldc;
+ c2_offset = 1 + c2_dim1;
+ c2 -= c2_offset;
+ c1_dim1 = *ldc;
+ c1_offset = 1 + c1_dim1;
+ c1 -= c1_offset;
+ --work;
+
+ /* Function Body */
+ if (min(*m,*n) == 0 || *tau == 0.f) {
+ return 0;
+ }
+
+ if (lsame_(side, "L")) {
+
+/* w := C1 + v' * C2 */
+
+ scopy_(n, &c1[c1_offset], ldc, &work[1], &c__1);
+ i__1 = *m - 1;
+ sgemv_("Transpose", &i__1, n, &c_b5, &c2[c2_offset], ldc, &v[1], incv,
+ &c_b5, &work[1], &c__1);
+
+/* [ C1 ] := [ C1 ] - tau* [ 1 ] * w' */
+/* [ C2 ] [ C2 ] [ v ] */
+
+ r__1 = -(*tau);
+ saxpy_(n, &r__1, &work[1], &c__1, &c1[c1_offset], ldc);
+ i__1 = *m - 1;
+ r__1 = -(*tau);
+ sger_(&i__1, n, &r__1, &v[1], incv, &work[1], &c__1, &c2[c2_offset],
+ ldc);
+
+ } else if (lsame_(side, "R")) {
+
+/* w := C1 + C2 * v */
+
+ scopy_(m, &c1[c1_offset], &c__1, &work[1], &c__1);
+ i__1 = *n - 1;
+ sgemv_("No transpose", m, &i__1, &c_b5, &c2[c2_offset], ldc, &v[1],
+ incv, &c_b5, &work[1], &c__1);
+
+/* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v'] */
+
+ r__1 = -(*tau);
+ saxpy_(m, &r__1, &work[1], &c__1, &c1[c1_offset], &c__1);
+ i__1 = *n - 1;
+ r__1 = -(*tau);
+ sger_(m, &i__1, &r__1, &work[1], &c__1, &v[1], incv, &c2[c2_offset],
+ ldc);
+ }
+
+ return 0;
+
+/* End of SLATZM */
+
+} /* slatzm_ */
diff --git a/SRC/slauu2.c b/SRC/slauu2.c
new file mode 100644
index 0000000..ad80d23
--- /dev/null
+++ b/SRC/slauu2.c
@@ -0,0 +1,180 @@
+/* slauu2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b7 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int slauu2_(char *uplo, integer *n, real *a, integer *lda,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__;
+ real aii;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ sgemv_(char *, integer *, integer *, real *, real *, integer *,
+ real *, integer *, real *, real *, integer *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAUU2 computes the product U * U' or L' * L, where the triangular */
+/* factor U or L is stored in the upper or lower triangular part of */
+/* the array A. */
+
+/* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */
+/* overwriting the factor U in A. */
+/* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */
+/* overwriting the factor L in A. */
+
+/* This is the unblocked form of the algorithm, calling Level 2 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the triangular factor stored in the array A */
+/* is upper or lower triangular: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the triangular factor U or L. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the triangular factor U or L. */
+/* On exit, if UPLO = 'U', the upper triangle of A is */
+/* overwritten with the upper triangle of the product U * U'; */
+/* if UPLO = 'L', the lower triangle of A is overwritten with */
+/* the lower triangle of the product L' * L. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLAUU2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Compute the product U * U'. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ aii = a[i__ + i__ * a_dim1];
+ if (i__ < *n) {
+ i__2 = *n - i__ + 1;
+ a[i__ + i__ * a_dim1] = sdot_(&i__2, &a[i__ + i__ * a_dim1],
+ lda, &a[i__ + i__ * a_dim1], lda);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ sgemv_("No transpose", &i__2, &i__3, &c_b7, &a[(i__ + 1) *
+ a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, &
+ aii, &a[i__ * a_dim1 + 1], &c__1);
+ } else {
+ sscal_(&i__, &aii, &a[i__ * a_dim1 + 1], &c__1);
+ }
+/* L10: */
+ }
+
+ } else {
+
+/* Compute the product L' * L. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ aii = a[i__ + i__ * a_dim1];
+ if (i__ < *n) {
+ i__2 = *n - i__ + 1;
+ a[i__ + i__ * a_dim1] = sdot_(&i__2, &a[i__ + i__ * a_dim1], &
+ c__1, &a[i__ + i__ * a_dim1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ sgemv_("Transpose", &i__2, &i__3, &c_b7, &a[i__ + 1 + a_dim1],
+ lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &aii, &a[i__
+ + a_dim1], lda);
+ } else {
+ sscal_(&i__, &aii, &a[i__ + a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of SLAUU2 */
+
+} /* slauu2_ */
diff --git a/SRC/slauum.c b/SRC/slauum.c
new file mode 100644
index 0000000..d65e5bc
--- /dev/null
+++ b/SRC/slauum.c
@@ -0,0 +1,215 @@
+/* slauum.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b15 = 1.f;
+
+/* Subroutine */ int slauum_(char *uplo, integer *n, real *a, integer *lda,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, ib, nb;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ logical upper;
+ extern /* Subroutine */ int strmm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), ssyrk_(char *, char *, integer
+ *, integer *, real *, real *, integer *, real *, real *, integer *
+), slauu2_(char *, integer *, real *, integer *,
+ integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAUUM computes the product U * U' or L' * L, where the triangular */
+/* factor U or L is stored in the upper or lower triangular part of */
+/* the array A. */
+
+/* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */
+/* overwriting the factor U in A. */
+/* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */
+/* overwriting the factor L in A. */
+
+/* This is the blocked form of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the triangular factor stored in the array A */
+/* is upper or lower triangular: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the triangular factor U or L. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the triangular factor U or L. */
+/* On exit, if UPLO = 'U', the upper triangle of A is */
+/* overwritten with the upper triangle of the product U * U'; */
+/* if UPLO = 'L', the lower triangle of A is overwritten with */
+/* the lower triangle of the product L' * L. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLAUUM", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "SLAUUM", uplo, n, &c_n1, &c_n1, &c_n1);
+
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code */
+
+ slauu2_(uplo, n, &a[a_offset], lda, info);
+ } else {
+
+/* Use blocked code */
+
+ if (upper) {
+
+/* Compute the product U * U'. */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - i__ + 1;
+ ib = min(i__3,i__4);
+ i__3 = i__ - 1;
+ strmm_("Right", "Upper", "Transpose", "Non-unit", &i__3, &ib,
+ &c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ * a_dim1
+ + 1], lda)
+ ;
+ slauu2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info);
+ if (i__ + ib <= *n) {
+ i__3 = i__ - 1;
+ i__4 = *n - i__ - ib + 1;
+ sgemm_("No transpose", "Transpose", &i__3, &ib, &i__4, &
+ c_b15, &a[(i__ + ib) * a_dim1 + 1], lda, &a[i__ +
+ (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ *
+ a_dim1 + 1], lda);
+ i__3 = *n - i__ - ib + 1;
+ ssyrk_("Upper", "No transpose", &ib, &i__3, &c_b15, &a[
+ i__ + (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ +
+ i__ * a_dim1], lda);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Compute the product L' * L. */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - i__ + 1;
+ ib = min(i__3,i__4);
+ i__3 = i__ - 1;
+ strmm_("Left", "Lower", "Transpose", "Non-unit", &ib, &i__3, &
+ c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ + a_dim1],
+ lda);
+ slauu2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info);
+ if (i__ + ib <= *n) {
+ i__3 = i__ - 1;
+ i__4 = *n - i__ - ib + 1;
+ sgemm_("Transpose", "No transpose", &ib, &i__3, &i__4, &
+ c_b15, &a[i__ + ib + i__ * a_dim1], lda, &a[i__ +
+ ib + a_dim1], lda, &c_b15, &a[i__ + a_dim1], lda);
+ i__3 = *n - i__ - ib + 1;
+ ssyrk_("Lower", "Transpose", &ib, &i__3, &c_b15, &a[i__ +
+ ib + i__ * a_dim1], lda, &c_b15, &a[i__ + i__ *
+ a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SLAUUM */
+
+} /* slauum_ */
diff --git a/SRC/sopgtr.c b/SRC/sopgtr.c
new file mode 100644
index 0000000..7296c2e
--- /dev/null
+++ b/SRC/sopgtr.c
@@ -0,0 +1,209 @@
+/* sopgtr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sopgtr_(char *uplo, integer *n, real *ap, real *tau,
+ real *q, integer *ldq, real *work, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, ij;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical upper;
+ extern /* Subroutine */ int sorg2l_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *), sorg2r_(integer *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SOPGTR generates a real orthogonal matrix Q which is defined as the */
+/* product of n-1 elementary reflectors H(i) of order n, as returned by */
+/* SSPTRD using packed storage: */
+
+/* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), */
+
+/* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular packed storage used in previous */
+/* call to SSPTRD; */
+/* = 'L': Lower triangular packed storage used in previous */
+/* call to SSPTRD. */
+
+/* N (input) INTEGER */
+/* The order of the matrix Q. N >= 0. */
+
+/* AP (input) REAL array, dimension (N*(N+1)/2) */
+/* The vectors which define the elementary reflectors, as */
+/* returned by SSPTRD. */
+
+/* TAU (input) REAL array, dimension (N-1) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by SSPTRD. */
+
+/* Q (output) REAL array, dimension (LDQ,N) */
+/* The N-by-N orthogonal matrix Q. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (N-1) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --ap;
+ --tau;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldq < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SOPGTR", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Q was determined by a call to SSPTRD with UPLO = 'U' */
+
+/* Unpack the vectors which define the elementary reflectors and */
+/* set the last row and column of Q equal to those of the unit */
+/* matrix */
+
+ ij = 2;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ q[i__ + j * q_dim1] = ap[ij];
+ ++ij;
+/* L10: */
+ }
+ ij += 2;
+ q[*n + j * q_dim1] = 0.f;
+/* L20: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ q[i__ + *n * q_dim1] = 0.f;
+/* L30: */
+ }
+ q[*n + *n * q_dim1] = 1.f;
+
+/* Generate Q(1:n-1,1:n-1) */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ sorg2l_(&i__1, &i__2, &i__3, &q[q_offset], ldq, &tau[1], &work[1], &
+ iinfo);
+
+ } else {
+
+/* Q was determined by a call to SSPTRD with UPLO = 'L'. */
+
+/* Unpack the vectors which define the elementary reflectors and */
+/* set the first row and column of Q equal to those of the unit */
+/* matrix */
+
+ q[q_dim1 + 1] = 1.f;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ q[i__ + q_dim1] = 0.f;
+/* L40: */
+ }
+ ij = 3;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ q[j * q_dim1 + 1] = 0.f;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ q[i__ + j * q_dim1] = ap[ij];
+ ++ij;
+/* L50: */
+ }
+ ij += 2;
+/* L60: */
+ }
+ if (*n > 1) {
+
+/* Generate Q(2:n,2:n) */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ sorg2r_(&i__1, &i__2, &i__3, &q[(q_dim1 << 1) + 2], ldq, &tau[1],
+ &work[1], &iinfo);
+ }
+ }
+ return 0;
+
+/* End of SOPGTR */
+
+} /* sopgtr_ */
diff --git a/SRC/sopmtr.c b/SRC/sopmtr.c
new file mode 100644
index 0000000..f85bfd7
--- /dev/null
+++ b/SRC/sopmtr.c
@@ -0,0 +1,295 @@
+/* sopmtr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sopmtr_(char *side, char *uplo, char *trans, integer *m,
+ integer *n, real *ap, real *tau, real *c__, integer *ldc, real *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, i1, i2, i3, ic, jc, ii, mi, ni, nq;
+ real aii;
+ logical left;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran, forwrd;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SOPMTR overwrites the general real M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'T': Q**T * C C * Q**T */
+
+/* where Q is a real orthogonal matrix of order nq, with nq = m if */
+/* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */
+/* nq-1 elementary reflectors, as returned by SSPTRD using packed */
+/* storage: */
+
+/* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); */
+
+/* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**T from the Left; */
+/* = 'R': apply Q or Q**T from the Right. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular packed storage used in previous */
+/* call to SSPTRD; */
+/* = 'L': Lower triangular packed storage used in previous */
+/* call to SSPTRD. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'T': Transpose, apply Q**T. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* AP (input) REAL array, dimension */
+/* (M*(M+1)/2) if SIDE = 'L' */
+/* (N*(N+1)/2) if SIDE = 'R' */
+/* The vectors which define the elementary reflectors, as */
+/* returned by SSPTRD. AP is modified by the routine but */
+/* restored on exit. */
+
+/* TAU (input) REAL array, dimension (M-1) if SIDE = 'L' */
+/* or (N-1) if SIDE = 'R' */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by SSPTRD. */
+
+/* C (input/output) REAL array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) REAL array, dimension */
+/* (N) if SIDE = 'L' */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --ap;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ upper = lsame_(uplo, "U");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*ldc < max(1,*m)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SOPMTR", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Q was determined by a call to SSPTRD with UPLO = 'U' */
+
+ forwrd = left && notran || ! left && ! notran;
+
+ if (forwrd) {
+ i1 = 1;
+ i2 = nq - 1;
+ i3 = 1;
+ ii = 2;
+ } else {
+ i1 = nq - 1;
+ i2 = 1;
+ i3 = -1;
+ ii = nq * (nq + 1) / 2 - 1;
+ }
+
+ if (left) {
+ ni = *n;
+ } else {
+ mi = *m;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) is applied to C(1:i,1:n) */
+
+ mi = i__;
+ } else {
+
+/* H(i) is applied to C(1:m,1:i) */
+
+ ni = i__;
+ }
+
+/* Apply H(i) */
+
+ aii = ap[ii];
+ ap[ii] = 1.f;
+ slarf_(side, &mi, &ni, &ap[ii - i__ + 1], &c__1, &tau[i__], &c__[
+ c_offset], ldc, &work[1]);
+ ap[ii] = aii;
+
+ if (forwrd) {
+ ii = ii + i__ + 2;
+ } else {
+ ii = ii - i__ - 1;
+ }
+/* L10: */
+ }
+ } else {
+
+/* Q was determined by a call to SSPTRD with UPLO = 'L'. */
+
+ forwrd = left && ! notran || ! left && notran;
+
+ if (forwrd) {
+ i1 = 1;
+ i2 = nq - 1;
+ i3 = 1;
+ ii = 2;
+ } else {
+ i1 = nq - 1;
+ i2 = 1;
+ i3 = -1;
+ ii = nq * (nq + 1) / 2 - 1;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ }
+
+ i__2 = i2;
+ i__1 = i3;
+ for (i__ = i1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
+ aii = ap[ii];
+ ap[ii] = 1.f;
+ if (left) {
+
+/* H(i) is applied to C(i+1:m,1:n) */
+
+ mi = *m - i__;
+ ic = i__ + 1;
+ } else {
+
+/* H(i) is applied to C(1:m,i+1:n) */
+
+ ni = *n - i__;
+ jc = i__ + 1;
+ }
+
+/* Apply H(i) */
+
+ slarf_(side, &mi, &ni, &ap[ii], &c__1, &tau[i__], &c__[ic + jc *
+ c_dim1], ldc, &work[1]);
+ ap[ii] = aii;
+
+ if (forwrd) {
+ ii = ii + nq - i__ + 1;
+ } else {
+ ii = ii - nq + i__ - 2;
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+/* End of SOPMTR */
+
+} /* sopmtr_ */
diff --git a/SRC/sorg2l.c b/SRC/sorg2l.c
new file mode 100644
index 0000000..a668c6a
--- /dev/null
+++ b/SRC/sorg2l.c
@@ -0,0 +1,173 @@
+/* sorg2l.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sorg2l_(integer *m, integer *n, integer *k, real *a,
+ integer *lda, real *tau, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j, l, ii;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ slarf_(char *, integer *, integer *, real *, integer *, real *,
+ real *, integer *, real *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORG2L generates an m by n real matrix Q with orthonormal columns, */
+/* which is defined as the last n columns of a product of k elementary */
+/* reflectors of order m */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by SGEQLF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the (n-k+i)-th column must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by SGEQLF in the last k columns of its array */
+/* argument A. */
+/* On exit, the m by n matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) REAL array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by SGEQLF. */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SORG2L", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Initialise columns 1:n-k to columns of the unit matrix */
+
+ i__1 = *n - *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (l = 1; l <= i__2; ++l) {
+ a[l + j * a_dim1] = 0.f;
+/* L10: */
+ }
+ a[*m - *n + j + j * a_dim1] = 1.f;
+/* L20: */
+ }
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ii = *n - *k + i__;
+
+/* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left */
+
+ a[*m - *n + ii + ii * a_dim1] = 1.f;
+ i__2 = *m - *n + ii;
+ i__3 = ii - 1;
+ slarf_("Left", &i__2, &i__3, &a[ii * a_dim1 + 1], &c__1, &tau[i__], &
+ a[a_offset], lda, &work[1]);
+ i__2 = *m - *n + ii - 1;
+ r__1 = -tau[i__];
+ sscal_(&i__2, &r__1, &a[ii * a_dim1 + 1], &c__1);
+ a[*m - *n + ii + ii * a_dim1] = 1.f - tau[i__];
+
+/* Set A(m-k+i+1:m,n-k+i) to zero */
+
+ i__2 = *m;
+ for (l = *m - *n + ii + 1; l <= i__2; ++l) {
+ a[l + ii * a_dim1] = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+ return 0;
+
+/* End of SORG2L */
+
+} /* sorg2l_ */
diff --git a/SRC/sorg2r.c b/SRC/sorg2r.c
new file mode 100644
index 0000000..4fbbded
--- /dev/null
+++ b/SRC/sorg2r.c
@@ -0,0 +1,175 @@
+/* sorg2r.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sorg2r_(integer *m, integer *n, integer *k, real *a,
+ integer *lda, real *tau, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j, l;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ slarf_(char *, integer *, integer *, real *, integer *, real *,
+ real *, integer *, real *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORG2R generates an m by n real matrix Q with orthonormal columns, */
+/* which is defined as the first n columns of a product of k elementary */
+/* reflectors of order m */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by SGEQRF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the i-th column must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by SGEQRF in the first k columns of its array */
+/* argument A. */
+/* On exit, the m-by-n matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) REAL array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by SGEQRF. */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SORG2R", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Initialise columns k+1:n to columns of the unit matrix */
+
+ i__1 = *n;
+ for (j = *k + 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (l = 1; l <= i__2; ++l) {
+ a[l + j * a_dim1] = 0.f;
+/* L10: */
+ }
+ a[j + j * a_dim1] = 1.f;
+/* L20: */
+ }
+
+ for (i__ = *k; i__ >= 1; --i__) {
+
+/* Apply H(i) to A(i:m,i:n) from the left */
+
+ if (i__ < *n) {
+ a[i__ + i__ * a_dim1] = 1.f;
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__;
+ slarf_("Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[
+ i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
+ }
+ if (i__ < *m) {
+ i__1 = *m - i__;
+ r__1 = -tau[i__];
+ sscal_(&i__1, &r__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
+ }
+ a[i__ + i__ * a_dim1] = 1.f - tau[i__];
+
+/* Set A(1:i-1,i) to zero */
+
+ i__1 = i__ - 1;
+ for (l = 1; l <= i__1; ++l) {
+ a[l + i__ * a_dim1] = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+ return 0;
+
+/* End of SORG2R */
+
+} /* sorg2r_ */
diff --git a/SRC/sorgbr.c b/SRC/sorgbr.c
new file mode 100644
index 0000000..8274482
--- /dev/null
+++ b/SRC/sorgbr.c
@@ -0,0 +1,299 @@
+/* sorgbr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int sorgbr_(char *vect, integer *m, integer *n, integer *k,
+ real *a, integer *lda, real *tau, real *work, integer *lwork, integer
+ *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, nb, mn;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical wantq;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int sorglq_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *), sorgqr_(
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORGBR generates one of the real orthogonal matrices Q or P**T */
+/* determined by SGEBRD when reducing a real matrix A to bidiagonal */
+/* form: A = Q * B * P**T. Q and P**T are defined as products of */
+/* elementary reflectors H(i) or G(i) respectively. */
+
+/* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q */
+/* is of order M: */
+/* if m >= k, Q = H(1) H(2) . . . H(k) and SORGBR returns the first n */
+/* columns of Q, where m >= n >= k; */
+/* if m < k, Q = H(1) H(2) . . . H(m-1) and SORGBR returns Q as an */
+/* M-by-M matrix. */
+
+/* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T */
+/* is of order N: */
+/* if k < n, P**T = G(k) . . . G(2) G(1) and SORGBR returns the first m */
+/* rows of P**T, where n >= m >= k; */
+/* if k >= n, P**T = G(n-1) . . . G(2) G(1) and SORGBR returns P**T as */
+/* an N-by-N matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* VECT (input) CHARACTER*1 */
+/* Specifies whether the matrix Q or the matrix P**T is */
+/* required, as defined in the transformation applied by SGEBRD: */
+/* = 'Q': generate Q; */
+/* = 'P': generate P**T. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q or P**T to be returned. */
+/* M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q or P**T to be returned. */
+/* N >= 0. */
+/* If VECT = 'Q', M >= N >= min(M,K); */
+/* if VECT = 'P', N >= M >= min(N,K). */
+
+/* K (input) INTEGER */
+/* If VECT = 'Q', the number of columns in the original M-by-K */
+/* matrix reduced by SGEBRD. */
+/* If VECT = 'P', the number of rows in the original K-by-N */
+/* matrix reduced by SGEBRD. */
+/* K >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the vectors which define the elementary reflectors, */
+/* as returned by SGEBRD. */
+/* On exit, the M-by-N matrix Q or P**T. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) REAL array, dimension */
+/* (min(M,K)) if VECT = 'Q' */
+/* (min(N,K)) if VECT = 'P' */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i) or G(i), which determines Q or P**T, as */
+/* returned by SGEBRD in its array argument TAUQ or TAUP. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,min(M,N)). */
+/* For optimum performance LWORK >= min(M,N)*NB, where NB */
+/* is the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ wantq = lsame_(vect, "Q");
+ mn = min(*m,*n);
+ lquery = *lwork == -1;
+ if (! wantq && ! lsame_(vect, "P")) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*n < 0 || wantq && (*n > *m || *n < min(*m,*k)) || ! wantq && (
+ *m > *n || *m < min(*n,*k))) {
+ *info = -3;
+ } else if (*k < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -6;
+ } else if (*lwork < max(1,mn) && ! lquery) {
+ *info = -9;
+ }
+
+ if (*info == 0) {
+ if (wantq) {
+ nb = ilaenv_(&c__1, "SORGQR", " ", m, n, k, &c_n1);
+ } else {
+ nb = ilaenv_(&c__1, "SORGLQ", " ", m, n, k, &c_n1);
+ }
+ lwkopt = max(1,mn) * nb;
+ work[1] = (real) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SORGBR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ work[1] = 1.f;
+ return 0;
+ }
+
+ if (wantq) {
+
+/* Form Q, determined by a call to SGEBRD to reduce an m-by-k */
+/* matrix */
+
+ if (*m >= *k) {
+
+/* If m >= k, assume m >= n >= k */
+
+ sorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
+ iinfo);
+
+ } else {
+
+/* If m < k, assume m = n */
+
+/* Shift the vectors which define the elementary reflectors one */
+/* column to the right, and set the first row and column of Q */
+/* to those of the unit matrix */
+
+ for (j = *m; j >= 2; --j) {
+ a[j * a_dim1 + 1] = 0.f;
+ i__1 = *m;
+ for (i__ = j + 1; i__ <= i__1; ++i__) {
+ a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+ a[a_dim1 + 1] = 1.f;
+ i__1 = *m;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ a[i__ + a_dim1] = 0.f;
+/* L30: */
+ }
+ if (*m > 1) {
+
+/* Form Q(2:m,2:m) */
+
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ sorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[
+ 1], &work[1], lwork, &iinfo);
+ }
+ }
+ } else {
+
+/* Form P', determined by a call to SGEBRD to reduce a k-by-n */
+/* matrix */
+
+ if (*k < *n) {
+
+/* If k < n, assume k <= m <= n */
+
+ sorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
+ iinfo);
+
+ } else {
+
+/* If k >= n, assume m = n */
+
+/* Shift the vectors which define the elementary reflectors one */
+/* row downward, and set the first row and column of P' to */
+/* those of the unit matrix */
+
+ a[a_dim1 + 1] = 1.f;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ a[i__ + a_dim1] = 0.f;
+/* L40: */
+ }
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ for (i__ = j - 1; i__ >= 2; --i__) {
+ a[i__ + j * a_dim1] = a[i__ - 1 + j * a_dim1];
+/* L50: */
+ }
+ a[j * a_dim1 + 1] = 0.f;
+/* L60: */
+ }
+ if (*n > 1) {
+
+/* Form P'(2:n,2:n) */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ sorglq_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[
+ 1], &work[1], lwork, &iinfo);
+ }
+ }
+ }
+ work[1] = (real) lwkopt;
+ return 0;
+
+/* End of SORGBR */
+
+} /* sorgbr_ */
diff --git a/SRC/sorghr.c b/SRC/sorghr.c
new file mode 100644
index 0000000..3e5186c
--- /dev/null
+++ b/SRC/sorghr.c
@@ -0,0 +1,214 @@
+/* sorghr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int sorghr_(integer *n, integer *ilo, integer *ihi, real *a,
+ integer *lda, real *tau, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, nb, nh, iinfo;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int sorgqr_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORGHR generates a real orthogonal matrix Q which is defined as the */
+/* product of IHI-ILO elementary reflectors of order N, as returned by */
+/* SGEHRD: */
+
+/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix Q. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* ILO and IHI must have the same values as in the previous call */
+/* of SGEHRD. Q is equal to the unit matrix except in the */
+/* submatrix Q(ilo+1:ihi,ilo+1:ihi). */
+/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the vectors which define the elementary reflectors, */
+/* as returned by SGEHRD. */
+/* On exit, the N-by-N orthogonal matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAU (input) REAL array, dimension (N-1) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by SGEHRD. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= IHI-ILO. */
+/* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nh = *ihi - *ilo;
+ lquery = *lwork == -1;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*ilo < 1 || *ilo > max(1,*n)) {
+ *info = -2;
+ } else if (*ihi < min(*ilo,*n) || *ihi > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*lwork < max(1,nh) && ! lquery) {
+ *info = -8;
+ }
+
+ if (*info == 0) {
+ nb = ilaenv_(&c__1, "SORGQR", " ", &nh, &nh, &nh, &c_n1);
+ lwkopt = max(1,nh) * nb;
+ work[1] = (real) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SORGHR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ work[1] = 1.f;
+ return 0;
+ }
+
+/* Shift the vectors which define the elementary reflectors one */
+/* column to the right, and set the first ilo and the last n-ihi */
+/* rows and columns to those of the unit matrix */
+
+ i__1 = *ilo + 1;
+ for (j = *ihi; j >= i__1; --j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L10: */
+ }
+ i__2 = *ihi;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1];
+/* L20: */
+ }
+ i__2 = *n;
+ for (i__ = *ihi + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+ i__1 = *ilo;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L50: */
+ }
+ a[j + j * a_dim1] = 1.f;
+/* L60: */
+ }
+ i__1 = *n;
+ for (j = *ihi + 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L70: */
+ }
+ a[j + j * a_dim1] = 1.f;
+/* L80: */
+ }
+
+ if (nh > 0) {
+
+/* Generate Q(ilo+1:ihi,ilo+1:ihi) */
+
+ sorgqr_(&nh, &nh, &nh, &a[*ilo + 1 + (*ilo + 1) * a_dim1], lda, &tau[*
+ ilo], &work[1], lwork, &iinfo);
+ }
+ work[1] = (real) lwkopt;
+ return 0;
+
+/* End of SORGHR */
+
+} /* sorghr_ */
diff --git a/SRC/sorgl2.c b/SRC/sorgl2.c
new file mode 100644
index 0000000..8b0ac9f
--- /dev/null
+++ b/SRC/sorgl2.c
@@ -0,0 +1,175 @@
+/* sorgl2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sorgl2_(integer *m, integer *n, integer *k, real *a,
+ integer *lda, real *tau, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j, l;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ slarf_(char *, integer *, integer *, real *, integer *, real *,
+ real *, integer *, real *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORGL2 generates an m by n real matrix Q with orthonormal rows, */
+/* which is defined as the first m rows of a product of k elementary */
+/* reflectors of order n */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by SGELQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. N >= M. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the i-th row must contain the vector which defines */
+/* the elementary reflector H(i), for i = 1,2,...,k, as returned */
+/* by SGELQF in the first k rows of its array argument A. */
+/* On exit, the m-by-n matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) REAL array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by SGELQF. */
+
+/* WORK (workspace) REAL array, dimension (M) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *m) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SORGL2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0) {
+ return 0;
+ }
+
+ if (*k < *m) {
+
+/* Initialise rows k+1:m to rows of the unit matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (l = *k + 1; l <= i__2; ++l) {
+ a[l + j * a_dim1] = 0.f;
+/* L10: */
+ }
+ if (j > *k && j <= *m) {
+ a[j + j * a_dim1] = 1.f;
+ }
+/* L20: */
+ }
+ }
+
+ for (i__ = *k; i__ >= 1; --i__) {
+
+/* Apply H(i) to A(i:m,i:n) from the right */
+
+ if (i__ < *n) {
+ if (i__ < *m) {
+ a[i__ + i__ * a_dim1] = 1.f;
+ i__1 = *m - i__;
+ i__2 = *n - i__ + 1;
+ slarf_("Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &
+ tau[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]);
+ }
+ i__1 = *n - i__;
+ r__1 = -tau[i__];
+ sscal_(&i__1, &r__1, &a[i__ + (i__ + 1) * a_dim1], lda);
+ }
+ a[i__ + i__ * a_dim1] = 1.f - tau[i__];
+
+/* Set A(i,1:i-1) to zero */
+
+ i__1 = i__ - 1;
+ for (l = 1; l <= i__1; ++l) {
+ a[i__ + l * a_dim1] = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+ return 0;
+
+/* End of SORGL2 */
+
+} /* sorgl2_ */
diff --git a/SRC/sorglq.c b/SRC/sorglq.c
new file mode 100644
index 0000000..c72fb8f
--- /dev/null
+++ b/SRC/sorglq.c
@@ -0,0 +1,279 @@
+/* sorglq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int sorglq_(integer *m, integer *n, integer *k, real *a,
+ integer *lda, real *tau, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int sorgl2_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *), slarfb_(char *, char *,
+ char *, char *, integer *, integer *, integer *, real *, integer *
+, real *, integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slarft_(char *, char *, integer *, integer *,
+ real *, integer *, real *, real *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORGLQ generates an M-by-N real matrix Q with orthonormal rows, */
+/* which is defined as the first M rows of a product of K elementary */
+/* reflectors of order N */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by SGELQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. N >= M. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the i-th row must contain the vector which defines */
+/* the elementary reflector H(i), for i = 1,2,...,k, as returned */
+/* by SGELQF in the first k rows of its array argument A. */
+/* On exit, the M-by-N matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) REAL array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by SGELQF. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M). */
+/* For optimum performance LWORK >= M*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb = ilaenv_(&c__1, "SORGLQ", " ", m, n, k, &c_n1);
+ lwkopt = max(1,*m) * nb;
+ work[1] = (real) lwkopt;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *m) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*lwork < max(1,*m) && ! lquery) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SORGLQ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0) {
+ work[1] = 1.f;
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *m;
+ if (nb > 1 && nb < *k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "SORGLQ", " ", m, n, k, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *m;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "SORGLQ", " ", m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < *k && nx < *k) {
+
+/* Use blocked code after the last block. */
+/* The first kk rows are handled by the block method. */
+
+ ki = (*k - nx - 1) / nb * nb;
+/* Computing MIN */
+ i__1 = *k, i__2 = ki + nb;
+ kk = min(i__1,i__2);
+
+/* Set A(kk+1:m,1:kk) to zero. */
+
+ i__1 = kk;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = kk + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ kk = 0;
+ }
+
+/* Use unblocked code for the last or only block. */
+
+ if (kk < *m) {
+ i__1 = *m - kk;
+ i__2 = *n - kk;
+ i__3 = *k - kk;
+ sorgl2_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, &
+ tau[kk + 1], &work[1], &iinfo);
+ }
+
+ if (kk > 0) {
+
+/* Use blocked code */
+
+ i__1 = -nb;
+ for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) {
+/* Computing MIN */
+ i__2 = nb, i__3 = *k - i__ + 1;
+ ib = min(i__2,i__3);
+ if (i__ + ib <= *m) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__2 = *n - i__ + 1;
+ slarft_("Forward", "Rowwise", &i__2, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H' to A(i+ib:m,i:n) from the right */
+
+ i__2 = *m - i__ - ib + 1;
+ i__3 = *n - i__ + 1;
+ slarfb_("Right", "Transpose", "Forward", "Rowwise", &i__2, &
+ i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
+ ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib +
+ 1], &ldwork);
+ }
+
+/* Apply H' to columns i:n of current block */
+
+ i__2 = *n - i__ + 1;
+ sorgl2_(&ib, &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
+ work[1], &iinfo);
+
+/* Set columns 1:i-1 of current block to zero */
+
+ i__2 = i__ - 1;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + ib - 1;
+ for (l = i__; l <= i__3; ++l) {
+ a[l + j * a_dim1] = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+ work[1] = (real) iws;
+ return 0;
+
+/* End of SORGLQ */
+
+} /* sorglq_ */
diff --git a/SRC/sorgql.c b/SRC/sorgql.c
new file mode 100644
index 0000000..46fb3ea
--- /dev/null
+++ b/SRC/sorgql.c
@@ -0,0 +1,288 @@
+/* sorgql.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int sorgql_(integer *m, integer *n, integer *k, real *a,
+ integer *lda, real *tau, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, l, ib, nb, kk, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int sorg2l_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *), slarfb_(char *, char *,
+ char *, char *, integer *, integer *, integer *, real *, integer *
+, real *, integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slarft_(char *, char *, integer *, integer *,
+ real *, integer *, real *, real *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORGQL generates an M-by-N real matrix Q with orthonormal columns, */
+/* which is defined as the last N columns of a product of K elementary */
+/* reflectors of order M */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by SGEQLF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the (n-k+i)-th column must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by SGEQLF in the last k columns of its array */
+/* argument A. */
+/* On exit, the M-by-N matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) REAL array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by SGEQLF. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* For optimum performance LWORK >= N*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+
+ if (*info == 0) {
+ if (*n == 0) {
+ lwkopt = 1;
+ } else {
+ nb = ilaenv_(&c__1, "SORGQL", " ", m, n, k, &c_n1);
+ lwkopt = *n * nb;
+ }
+ work[1] = (real) lwkopt;
+
+ if (*lwork < max(1,*n) && ! lquery) {
+ *info = -8;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SORGQL", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *n;
+ if (nb > 1 && nb < *k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "SORGQL", " ", m, n, k, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *n;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "SORGQL", " ", m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < *k && nx < *k) {
+
+/* Use blocked code after the first block. */
+/* The last kk columns are handled by the block method. */
+
+/* Computing MIN */
+ i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb;
+ kk = min(i__1,i__2);
+
+/* Set A(m-kk+1:m,1:n-kk) to zero. */
+
+ i__1 = *n - kk;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = *m - kk + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ kk = 0;
+ }
+
+/* Use unblocked code for the first or only block. */
+
+ i__1 = *m - kk;
+ i__2 = *n - kk;
+ i__3 = *k - kk;
+ sorg2l_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &iinfo)
+ ;
+
+ if (kk > 0) {
+
+/* Use blocked code */
+
+ i__1 = *k;
+ i__2 = nb;
+ for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *k - i__ + 1;
+ ib = min(i__3,i__4);
+ if (*n - *k + i__ > 1) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__3 = *m - *k + i__ + ib - 1;
+ slarft_("Backward", "Columnwise", &i__3, &ib, &a[(*n - *k +
+ i__) * a_dim1 + 1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left */
+
+ i__3 = *m - *k + i__ + ib - 1;
+ i__4 = *n - *k + i__ - 1;
+ slarfb_("Left", "No transpose", "Backward", "Columnwise", &
+ i__3, &i__4, &ib, &a[(*n - *k + i__) * a_dim1 + 1],
+ lda, &work[1], &ldwork, &a[a_offset], lda, &work[ib +
+ 1], &ldwork);
+ }
+
+/* Apply H to rows 1:m-k+i+ib-1 of current block */
+
+ i__3 = *m - *k + i__ + ib - 1;
+ sorg2l_(&i__3, &ib, &ib, &a[(*n - *k + i__) * a_dim1 + 1], lda, &
+ tau[i__], &work[1], &iinfo);
+
+/* Set rows m-k+i+ib:m of current block to zero */
+
+ i__3 = *n - *k + i__ + ib - 1;
+ for (j = *n - *k + i__; j <= i__3; ++j) {
+ i__4 = *m;
+ for (l = *m - *k + i__ + ib; l <= i__4; ++l) {
+ a[l + j * a_dim1] = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+ work[1] = (real) iws;
+ return 0;
+
+/* End of SORGQL */
+
+} /* sorgql_ */
diff --git a/SRC/sorgqr.c b/SRC/sorgqr.c
new file mode 100644
index 0000000..667255d
--- /dev/null
+++ b/SRC/sorgqr.c
@@ -0,0 +1,280 @@
+/* sorgqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int sorgqr_(integer *m, integer *n, integer *k, real *a,
+ integer *lda, real *tau, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int sorg2r_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *), slarfb_(char *, char *,
+ char *, char *, integer *, integer *, integer *, real *, integer *
+, real *, integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slarft_(char *, char *, integer *, integer *,
+ real *, integer *, real *, real *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORGQR generates an M-by-N real matrix Q with orthonormal columns, */
+/* which is defined as the first N columns of a product of K elementary */
+/* reflectors of order M */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by SGEQRF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the i-th column must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by SGEQRF in the first k columns of its array */
+/* argument A. */
+/* On exit, the M-by-N matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) REAL array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by SGEQRF. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* For optimum performance LWORK >= N*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb = ilaenv_(&c__1, "SORGQR", " ", m, n, k, &c_n1);
+ lwkopt = max(1,*n) * nb;
+ work[1] = (real) lwkopt;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SORGQR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ work[1] = 1.f;
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *n;
+ if (nb > 1 && nb < *k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "SORGQR", " ", m, n, k, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *n;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "SORGQR", " ", m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < *k && nx < *k) {
+
+/* Use blocked code after the last block. */
+/* The first kk columns are handled by the block method. */
+
+ ki = (*k - nx - 1) / nb * nb;
+/* Computing MIN */
+ i__1 = *k, i__2 = ki + nb;
+ kk = min(i__1,i__2);
+
+/* Set A(1:kk,kk+1:n) to zero. */
+
+ i__1 = *n;
+ for (j = kk + 1; j <= i__1; ++j) {
+ i__2 = kk;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ kk = 0;
+ }
+
+/* Use unblocked code for the last or only block. */
+
+ if (kk < *n) {
+ i__1 = *m - kk;
+ i__2 = *n - kk;
+ i__3 = *k - kk;
+ sorg2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, &
+ tau[kk + 1], &work[1], &iinfo);
+ }
+
+ if (kk > 0) {
+
+/* Use blocked code */
+
+ i__1 = -nb;
+ for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) {
+/* Computing MIN */
+ i__2 = nb, i__3 = *k - i__ + 1;
+ ib = min(i__2,i__3);
+ if (i__ + ib <= *n) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__2 = *m - i__ + 1;
+ slarft_("Forward", "Columnwise", &i__2, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H to A(i:m,i+ib:n) from the left */
+
+ i__2 = *m - i__ + 1;
+ i__3 = *n - i__ - ib + 1;
+ slarfb_("Left", "No transpose", "Forward", "Columnwise", &
+ i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[
+ 1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &
+ work[ib + 1], &ldwork);
+ }
+
+/* Apply H to rows i:m of current block */
+
+ i__2 = *m - i__ + 1;
+ sorg2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
+ work[1], &iinfo);
+
+/* Set rows 1:i-1 of current block to zero */
+
+ i__2 = i__ + ib - 1;
+ for (j = i__; j <= i__2; ++j) {
+ i__3 = i__ - 1;
+ for (l = 1; l <= i__3; ++l) {
+ a[l + j * a_dim1] = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+ work[1] = (real) iws;
+ return 0;
+
+/* End of SORGQR */
+
+} /* sorgqr_ */
diff --git a/SRC/sorgr2.c b/SRC/sorgr2.c
new file mode 100644
index 0000000..c47f5b7
--- /dev/null
+++ b/SRC/sorgr2.c
@@ -0,0 +1,174 @@
+/* sorgr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sorgr2_(integer *m, integer *n, integer *k, real *a,
+ integer *lda, real *tau, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j, l, ii;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ slarf_(char *, integer *, integer *, real *, integer *, real *,
+ real *, integer *, real *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORGR2 generates an m by n real matrix Q with orthonormal rows, */
+/* which is defined as the last m rows of a product of k elementary */
+/* reflectors of order n */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by SGERQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. N >= M. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the (m-k+i)-th row must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by SGERQF in the last k rows of its array argument */
+/* A. */
+/* On exit, the m by n matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) REAL array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by SGERQF. */
+
+/* WORK (workspace) REAL array, dimension (M) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *m) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SORGR2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0) {
+ return 0;
+ }
+
+ if (*k < *m) {
+
+/* Initialise rows 1:m-k to rows of the unit matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m - *k;
+ for (l = 1; l <= i__2; ++l) {
+ a[l + j * a_dim1] = 0.f;
+/* L10: */
+ }
+ if (j > *n - *m && j <= *n - *k) {
+ a[*m - *n + j + j * a_dim1] = 1.f;
+ }
+/* L20: */
+ }
+ }
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ii = *m - *k + i__;
+
+/* Apply H(i) to A(1:m-k+i,1:n-k+i) from the right */
+
+ a[ii + (*n - *m + ii) * a_dim1] = 1.f;
+ i__2 = ii - 1;
+ i__3 = *n - *m + ii;
+ slarf_("Right", &i__2, &i__3, &a[ii + a_dim1], lda, &tau[i__], &a[
+ a_offset], lda, &work[1]);
+ i__2 = *n - *m + ii - 1;
+ r__1 = -tau[i__];
+ sscal_(&i__2, &r__1, &a[ii + a_dim1], lda);
+ a[ii + (*n - *m + ii) * a_dim1] = 1.f - tau[i__];
+
+/* Set A(m-k+i,n-k+i+1:n) to zero */
+
+ i__2 = *n;
+ for (l = *n - *m + ii + 1; l <= i__2; ++l) {
+ a[ii + l * a_dim1] = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+ return 0;
+
+/* End of SORGR2 */
+
+} /* sorgr2_ */
diff --git a/SRC/sorgrq.c b/SRC/sorgrq.c
new file mode 100644
index 0000000..36d853c
--- /dev/null
+++ b/SRC/sorgrq.c
@@ -0,0 +1,288 @@
+/* sorgrq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int sorgrq_(integer *m, integer *n, integer *k, real *a,
+ integer *lda, real *tau, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, l, ib, nb, ii, kk, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int sorgr2_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *), slarfb_(char *, char *,
+ char *, char *, integer *, integer *, integer *, real *, integer *
+, real *, integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slarft_(char *, char *, integer *, integer *,
+ real *, integer *, real *, real *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORGRQ generates an M-by-N real matrix Q with orthonormal rows, */
+/* which is defined as the last M rows of a product of K elementary */
+/* reflectors of order N */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by SGERQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. N >= M. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the (m-k+i)-th row must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by SGERQF in the last k rows of its array argument */
+/* A. */
+/* On exit, the M-by-N matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) REAL array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by SGERQF. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M). */
+/* For optimum performance LWORK >= M*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *m) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+
+ if (*info == 0) {
+ if (*m <= 0) {
+ lwkopt = 1;
+ } else {
+ nb = ilaenv_(&c__1, "SORGRQ", " ", m, n, k, &c_n1);
+ lwkopt = *m * nb;
+ }
+ work[1] = (real) lwkopt;
+
+ if (*lwork < max(1,*m) && ! lquery) {
+ *info = -8;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SORGRQ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *m;
+ if (nb > 1 && nb < *k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "SORGRQ", " ", m, n, k, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *m;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "SORGRQ", " ", m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < *k && nx < *k) {
+
+/* Use blocked code after the first block. */
+/* The last kk rows are handled by the block method. */
+
+/* Computing MIN */
+ i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb;
+ kk = min(i__1,i__2);
+
+/* Set A(1:m-kk,n-kk+1:n) to zero. */
+
+ i__1 = *n;
+ for (j = *n - kk + 1; j <= i__1; ++j) {
+ i__2 = *m - kk;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ kk = 0;
+ }
+
+/* Use unblocked code for the first or only block. */
+
+ i__1 = *m - kk;
+ i__2 = *n - kk;
+ i__3 = *k - kk;
+ sorgr2_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &iinfo)
+ ;
+
+ if (kk > 0) {
+
+/* Use blocked code */
+
+ i__1 = *k;
+ i__2 = nb;
+ for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *k - i__ + 1;
+ ib = min(i__3,i__4);
+ ii = *m - *k + i__;
+ if (ii > 1) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__3 = *n - *k + i__ + ib - 1;
+ slarft_("Backward", "Rowwise", &i__3, &ib, &a[ii + a_dim1],
+ lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H' to A(1:m-k+i-1,1:n-k+i+ib-1) from the right */
+
+ i__3 = ii - 1;
+ i__4 = *n - *k + i__ + ib - 1;
+ slarfb_("Right", "Transpose", "Backward", "Rowwise", &i__3, &
+ i__4, &ib, &a[ii + a_dim1], lda, &work[1], &ldwork, &
+ a[a_offset], lda, &work[ib + 1], &ldwork);
+ }
+
+/* Apply H' to columns 1:n-k+i+ib-1 of current block */
+
+ i__3 = *n - *k + i__ + ib - 1;
+ sorgr2_(&ib, &i__3, &ib, &a[ii + a_dim1], lda, &tau[i__], &work[1]
+, &iinfo);
+
+/* Set columns n-k+i+ib:n of current block to zero */
+
+ i__3 = *n;
+ for (l = *n - *k + i__ + ib; l <= i__3; ++l) {
+ i__4 = ii + ib - 1;
+ for (j = ii; j <= i__4; ++j) {
+ a[j + l * a_dim1] = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+ work[1] = (real) iws;
+ return 0;
+
+/* End of SORGRQ */
+
+} /* sorgrq_ */
diff --git a/SRC/sorgtr.c b/SRC/sorgtr.c
new file mode 100644
index 0000000..47e521e
--- /dev/null
+++ b/SRC/sorgtr.c
@@ -0,0 +1,250 @@
+/* sorgtr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int sorgtr_(char *uplo, integer *n, real *a, integer *lda,
+ real *tau, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, nb;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int sorgql_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *), sorgqr_(
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, integer *, integer *);
+ logical lquery;
+ integer lwkopt;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORGTR generates a real orthogonal matrix Q which is defined as the */
+/* product of n-1 elementary reflectors of order N, as returned by */
+/* SSYTRD: */
+
+/* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), */
+
+/* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A contains elementary reflectors */
+/* from SSYTRD; */
+/* = 'L': Lower triangle of A contains elementary reflectors */
+/* from SSYTRD. */
+
+/* N (input) INTEGER */
+/* The order of the matrix Q. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the vectors which define the elementary reflectors, */
+/* as returned by SSYTRD. */
+/* On exit, the N-by-N orthogonal matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAU (input) REAL array, dimension (N-1) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by SSYTRD. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N-1). */
+/* For optimum performance LWORK >= (N-1)*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n - 1;
+ if (*lwork < max(i__1,i__2) && ! lquery) {
+ *info = -7;
+ }
+ }
+
+ if (*info == 0) {
+ if (upper) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ nb = ilaenv_(&c__1, "SORGQL", " ", &i__1, &i__2, &i__3, &c_n1);
+ } else {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ nb = ilaenv_(&c__1, "SORGQR", " ", &i__1, &i__2, &i__3, &c_n1);
+ }
+/* Computing MAX */
+ i__1 = 1, i__2 = *n - 1;
+ lwkopt = max(i__1,i__2) * nb;
+ work[1] = (real) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SORGTR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ work[1] = 1.f;
+ return 0;
+ }
+
+ if (upper) {
+
+/* Q was determined by a call to SSYTRD with UPLO = 'U' */
+
+/* Shift the vectors which define the elementary reflectors one */
+/* column to the left, and set the last row and column of Q to */
+/* those of the unit matrix */
+
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = a[i__ + (j + 1) * a_dim1];
+/* L10: */
+ }
+ a[*n + j * a_dim1] = 0.f;
+/* L20: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ a[i__ + *n * a_dim1] = 0.f;
+/* L30: */
+ }
+ a[*n + *n * a_dim1] = 1.f;
+
+/* Generate Q(1:n-1,1:n-1) */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ sorgql_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1],
+ lwork, &iinfo);
+
+ } else {
+
+/* Q was determined by a call to SSYTRD with UPLO = 'L'. */
+
+/* Shift the vectors which define the elementary reflectors one */
+/* column to the right, and set the first row and column of Q to */
+/* those of the unit matrix */
+
+ for (j = *n; j >= 2; --j) {
+ a[j * a_dim1 + 1] = 0.f;
+ i__1 = *n;
+ for (i__ = j + 1; i__ <= i__1; ++i__) {
+ a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1];
+/* L40: */
+ }
+/* L50: */
+ }
+ a[a_dim1 + 1] = 1.f;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ a[i__ + a_dim1] = 0.f;
+/* L60: */
+ }
+ if (*n > 1) {
+
+/* Generate Q(2:n,2:n) */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ sorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[1],
+ &work[1], lwork, &iinfo);
+ }
+ }
+ work[1] = (real) lwkopt;
+ return 0;
+
+/* End of SORGTR */
+
+} /* sorgtr_ */
diff --git a/SRC/sorm2l.c b/SRC/sorm2l.c
new file mode 100644
index 0000000..2a727ad
--- /dev/null
+++ b/SRC/sorm2l.c
@@ -0,0 +1,230 @@
+/* sorm2l.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sorm2l_(char *side, char *trans, integer *m, integer *n,
+ integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
+ real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, i1, i2, i3, mi, ni, nq;
+ real aii;
+ logical left;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *), xerbla_(
+ char *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORM2L overwrites the general real m by n matrix C with */
+
+/* Q * C if SIDE = 'L' and TRANS = 'N', or */
+
+/* Q'* C if SIDE = 'L' and TRANS = 'T', or */
+
+/* C * Q if SIDE = 'R' and TRANS = 'N', or */
+
+/* C * Q' if SIDE = 'R' and TRANS = 'T', */
+
+/* where Q is a real orthogonal matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by SGEQLF. Q is of order m if SIDE = 'L' and of order n */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q' from the Left */
+/* = 'R': apply Q or Q' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply Q (No transpose) */
+/* = 'T': apply Q' (Transpose) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) REAL array, dimension (LDA,K) */
+/* The i-th column must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* SGEQLF in the last k columns of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If SIDE = 'L', LDA >= max(1,M); */
+/* if SIDE = 'R', LDA >= max(1,N). */
+
+/* TAU (input) REAL array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by SGEQLF. */
+
+/* C (input/output) REAL array, dimension (LDC,N) */
+/* On entry, the m by n matrix C. */
+/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) REAL array, dimension */
+/* (N) if SIDE = 'L', */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,nq)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SORM2L", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ return 0;
+ }
+
+ if (left && notran || ! left && ! notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = 1;
+ } else {
+ i1 = *k;
+ i2 = 1;
+ i3 = -1;
+ }
+
+ if (left) {
+ ni = *n;
+ } else {
+ mi = *m;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) is applied to C(1:m-k+i,1:n) */
+
+ mi = *m - *k + i__;
+ } else {
+
+/* H(i) is applied to C(1:m,1:n-k+i) */
+
+ ni = *n - *k + i__;
+ }
+
+/* Apply H(i) */
+
+ aii = a[nq - *k + i__ + i__ * a_dim1];
+ a[nq - *k + i__ + i__ * a_dim1] = 1.f;
+ slarf_(side, &mi, &ni, &a[i__ * a_dim1 + 1], &c__1, &tau[i__], &c__[
+ c_offset], ldc, &work[1]);
+ a[nq - *k + i__ + i__ * a_dim1] = aii;
+/* L10: */
+ }
+ return 0;
+
+/* End of SORM2L */
+
+} /* sorm2l_ */
diff --git a/SRC/sorm2r.c b/SRC/sorm2r.c
new file mode 100644
index 0000000..f12cbbb
--- /dev/null
+++ b/SRC/sorm2r.c
@@ -0,0 +1,234 @@
+/* sorm2r.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sorm2r_(char *side, char *trans, integer *m, integer *n,
+ integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
+ real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, i1, i2, i3, ic, jc, mi, ni, nq;
+ real aii;
+ logical left;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *), xerbla_(
+ char *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORM2R overwrites the general real m by n matrix C with */
+
+/* Q * C if SIDE = 'L' and TRANS = 'N', or */
+
+/* Q'* C if SIDE = 'L' and TRANS = 'T', or */
+
+/* C * Q if SIDE = 'R' and TRANS = 'N', or */
+
+/* C * Q' if SIDE = 'R' and TRANS = 'T', */
+
+/* where Q is a real orthogonal matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by SGEQRF. Q is of order m if SIDE = 'L' and of order n */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q' from the Left */
+/* = 'R': apply Q or Q' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply Q (No transpose) */
+/* = 'T': apply Q' (Transpose) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) REAL array, dimension (LDA,K) */
+/* The i-th column must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* SGEQRF in the first k columns of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If SIDE = 'L', LDA >= max(1,M); */
+/* if SIDE = 'R', LDA >= max(1,N). */
+
+/* TAU (input) REAL array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by SGEQRF. */
+
+/* C (input/output) REAL array, dimension (LDC,N) */
+/* On entry, the m by n matrix C. */
+/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) REAL array, dimension */
+/* (N) if SIDE = 'L', */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,nq)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SORM2R", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ return 0;
+ }
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = 1;
+ } else {
+ i1 = *k;
+ i2 = 1;
+ i3 = -1;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H(i) is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H(i) */
+
+ aii = a[i__ + i__ * a_dim1];
+ a[i__ + i__ * a_dim1] = 1.f;
+ slarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &tau[i__], &c__[
+ ic + jc * c_dim1], ldc, &work[1]);
+ a[i__ + i__ * a_dim1] = aii;
+/* L10: */
+ }
+ return 0;
+
+/* End of SORM2R */
+
+} /* sorm2r_ */
diff --git a/SRC/sormbr.c b/SRC/sormbr.c
new file mode 100644
index 0000000..1e86631
--- /dev/null
+++ b/SRC/sormbr.c
@@ -0,0 +1,358 @@
+/* sormbr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int sormbr_(char *vect, char *side, char *trans, integer *m,
+ integer *n, integer *k, real *a, integer *lda, real *tau, real *c__,
+ integer *ldc, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i1, i2, nb, mi, ni, nq, nw;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical notran, applyq;
+ char transt[1];
+ extern /* Subroutine */ int sormlq_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* If VECT = 'Q', SORMBR overwrites the general real M-by-N matrix C */
+/* with */
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'T': Q**T * C C * Q**T */
+
+/* If VECT = 'P', SORMBR overwrites the general real M-by-N matrix C */
+/* with */
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': P * C C * P */
+/* TRANS = 'T': P**T * C C * P**T */
+
+/* Here Q and P**T are the orthogonal matrices determined by SGEBRD when */
+/* reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and */
+/* P**T are defined as products of elementary reflectors H(i) and G(i) */
+/* respectively. */
+
+/* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the */
+/* order of the orthogonal matrix Q or P**T that is applied. */
+
+/* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: */
+/* if nq >= k, Q = H(1) H(2) . . . H(k); */
+/* if nq < k, Q = H(1) H(2) . . . H(nq-1). */
+
+/* If VECT = 'P', A is assumed to have been a K-by-NQ matrix: */
+/* if k < nq, P = G(1) G(2) . . . G(k); */
+/* if k >= nq, P = G(1) G(2) . . . G(nq-1). */
+
+/* Arguments */
+/* ========= */
+
+/* VECT (input) CHARACTER*1 */
+/* = 'Q': apply Q or Q**T; */
+/* = 'P': apply P or P**T. */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q, Q**T, P or P**T from the Left; */
+/* = 'R': apply Q, Q**T, P or P**T from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q or P; */
+/* = 'T': Transpose, apply Q**T or P**T. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* If VECT = 'Q', the number of columns in the original */
+/* matrix reduced by SGEBRD. */
+/* If VECT = 'P', the number of rows in the original */
+/* matrix reduced by SGEBRD. */
+/* K >= 0. */
+
+/* A (input) REAL array, dimension */
+/* (LDA,min(nq,K)) if VECT = 'Q' */
+/* (LDA,nq) if VECT = 'P' */
+/* The vectors which define the elementary reflectors H(i) and */
+/* G(i), whose products determine the matrices Q and P, as */
+/* returned by SGEBRD. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If VECT = 'Q', LDA >= max(1,nq); */
+/* if VECT = 'P', LDA >= max(1,min(nq,K)). */
+
+/* TAU (input) REAL array, dimension (min(nq,K)) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i) or G(i) which determines Q or P, as returned */
+/* by SGEBRD in the array argument TAUQ or TAUP. */
+
+/* C (input/output) REAL array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q */
+/* or P*C or P**T*C or C*P or C*P**T. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ applyq = lsame_(vect, "Q");
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q or P and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = *n;
+ } else {
+ nq = *n;
+ nw = *m;
+ }
+ if (! applyq && ! lsame_(vect, "P")) {
+ *info = -1;
+ } else if (! left && ! lsame_(side, "R")) {
+ *info = -2;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*k < 0) {
+ *info = -6;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = 1, i__2 = min(nq,*k);
+ if (applyq && *lda < max(1,nq) || ! applyq && *lda < max(i__1,i__2)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -11;
+ } else if (*lwork < max(1,nw) && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info == 0) {
+ if (applyq) {
+ if (left) {
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ nb = ilaenv_(&c__1, "SORMQR", ch__1, &i__1, n, &i__2, &c_n1);
+ } else {
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ nb = ilaenv_(&c__1, "SORMQR", ch__1, m, &i__1, &i__2, &c_n1);
+ }
+ } else {
+ if (left) {
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ nb = ilaenv_(&c__1, "SORMLQ", ch__1, &i__1, n, &i__2, &c_n1);
+ } else {
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ nb = ilaenv_(&c__1, "SORMLQ", ch__1, m, &i__1, &i__2, &c_n1);
+ }
+ }
+ lwkopt = max(1,nw) * nb;
+ work[1] = (real) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SORMBR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ work[1] = 1.f;
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ if (applyq) {
+
+/* Apply Q */
+
+ if (nq >= *k) {
+
+/* Q was determined by a call to SGEBRD with nq >= k */
+
+ sormqr_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], lwork, &iinfo);
+ } else if (nq > 1) {
+
+/* Q was determined by a call to SGEBRD with nq < k */
+
+ if (left) {
+ mi = *m - 1;
+ ni = *n;
+ i1 = 2;
+ i2 = 1;
+ } else {
+ mi = *m;
+ ni = *n - 1;
+ i1 = 1;
+ i2 = 2;
+ }
+ i__1 = nq - 1;
+ sormqr_(side, trans, &mi, &ni, &i__1, &a[a_dim1 + 2], lda, &tau[1]
+, &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo);
+ }
+ } else {
+
+/* Apply P */
+
+ if (notran) {
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+ if (nq > *k) {
+
+/* P was determined by a call to SGEBRD with nq > k */
+
+ sormlq_(side, transt, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], lwork, &iinfo);
+ } else if (nq > 1) {
+
+/* P was determined by a call to SGEBRD with nq <= k */
+
+ if (left) {
+ mi = *m - 1;
+ ni = *n;
+ i1 = 2;
+ i2 = 1;
+ } else {
+ mi = *m;
+ ni = *n - 1;
+ i1 = 1;
+ i2 = 2;
+ }
+ i__1 = nq - 1;
+ sormlq_(side, transt, &mi, &ni, &i__1, &a[(a_dim1 << 1) + 1], lda,
+ &tau[1], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &
+ iinfo);
+ }
+ }
+ work[1] = (real) lwkopt;
+ return 0;
+
+/* End of SORMBR */
+
+} /* sormbr_ */
diff --git a/SRC/sormhr.c b/SRC/sormhr.c
new file mode 100644
index 0000000..7fd17f7
--- /dev/null
+++ b/SRC/sormhr.c
@@ -0,0 +1,256 @@
+/* sormhr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int sormhr_(char *side, char *trans, integer *m, integer *n,
+ integer *ilo, integer *ihi, real *a, integer *lda, real *tau, real *
+ c__, integer *ldc, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i1, i2, nb, mi, nh, ni, nq, nw;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORMHR overwrites the general real M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'T': Q**T * C C * Q**T */
+
+/* where Q is a real orthogonal matrix of order nq, with nq = m if */
+/* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */
+/* IHI-ILO elementary reflectors, as returned by SGEHRD: */
+
+/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**T from the Left; */
+/* = 'R': apply Q or Q**T from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'T': Transpose, apply Q**T. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* ILO and IHI must have the same values as in the previous call */
+/* of SGEHRD. Q is equal to the unit matrix except in the */
+/* submatrix Q(ilo+1:ihi,ilo+1:ihi). */
+/* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and */
+/* ILO = 1 and IHI = 0, if M = 0; */
+/* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and */
+/* ILO = 1 and IHI = 0, if N = 0. */
+
+/* A (input) REAL array, dimension */
+/* (LDA,M) if SIDE = 'L' */
+/* (LDA,N) if SIDE = 'R' */
+/* The vectors which define the elementary reflectors, as */
+/* returned by SGEHRD. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. */
+
+/* TAU (input) REAL array, dimension */
+/* (M-1) if SIDE = 'L' */
+/* (N-1) if SIDE = 'R' */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by SGEHRD. */
+
+/* C (input/output) REAL array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nh = *ihi - *ilo;
+ left = lsame_(side, "L");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = *n;
+ } else {
+ nq = *n;
+ nw = *m;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ilo < 1 || *ilo > max(1,nq)) {
+ *info = -5;
+ } else if (*ihi < min(*ilo,nq) || *ihi > nq) {
+ *info = -6;
+ } else if (*lda < max(1,nq)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -11;
+ } else if (*lwork < max(1,nw) && ! lquery) {
+ *info = -13;
+ }
+
+ if (*info == 0) {
+ if (left) {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ nb = ilaenv_(&c__1, "SORMQR", ch__1, &nh, n, &nh, &c_n1);
+ } else {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ nb = ilaenv_(&c__1, "SORMQR", ch__1, m, &nh, &nh, &c_n1);
+ }
+ lwkopt = max(1,nw) * nb;
+ work[1] = (real) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__2 = -(*info);
+ xerbla_("SORMHR", &i__2);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || nh == 0) {
+ work[1] = 1.f;
+ return 0;
+ }
+
+ if (left) {
+ mi = nh;
+ ni = *n;
+ i1 = *ilo + 1;
+ i2 = 1;
+ } else {
+ mi = *m;
+ ni = nh;
+ i1 = 1;
+ i2 = *ilo + 1;
+ }
+
+ sormqr_(side, trans, &mi, &ni, &nh, &a[*ilo + 1 + *ilo * a_dim1], lda, &
+ tau[*ilo], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo);
+
+ work[1] = (real) lwkopt;
+ return 0;
+
+/* End of SORMHR */
+
+} /* sormhr_ */
diff --git a/SRC/sorml2.c b/SRC/sorml2.c
new file mode 100644
index 0000000..c2a6038
--- /dev/null
+++ b/SRC/sorml2.c
@@ -0,0 +1,230 @@
+/* sorml2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sorml2_(char *side, char *trans, integer *m, integer *n,
+ integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
+ real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, i1, i2, i3, ic, jc, mi, ni, nq;
+ real aii;
+ logical left;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *), xerbla_(
+ char *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORML2 overwrites the general real m by n matrix C with */
+
+/* Q * C if SIDE = 'L' and TRANS = 'N', or */
+
+/* Q'* C if SIDE = 'L' and TRANS = 'T', or */
+
+/* C * Q if SIDE = 'R' and TRANS = 'N', or */
+
+/* C * Q' if SIDE = 'R' and TRANS = 'T', */
+
+/* where Q is a real orthogonal matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by SGELQF. Q is of order m if SIDE = 'L' and of order n */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q' from the Left */
+/* = 'R': apply Q or Q' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply Q (No transpose) */
+/* = 'T': apply Q' (Transpose) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) REAL array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* SGELQF in the first k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) REAL array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by SGELQF. */
+
+/* C (input/output) REAL array, dimension (LDC,N) */
+/* On entry, the m by n matrix C. */
+/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) REAL array, dimension */
+/* (N) if SIDE = 'L', */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,*k)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SORML2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ return 0;
+ }
+
+ if (left && notran || ! left && ! notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = 1;
+ } else {
+ i1 = *k;
+ i2 = 1;
+ i3 = -1;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H(i) is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H(i) */
+
+ aii = a[i__ + i__ * a_dim1];
+ a[i__ + i__ * a_dim1] = 1.f;
+ slarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &tau[i__], &c__[
+ ic + jc * c_dim1], ldc, &work[1]);
+ a[i__ + i__ * a_dim1] = aii;
+/* L10: */
+ }
+ return 0;
+
+/* End of SORML2 */
+
+} /* sorml2_ */
diff --git a/SRC/sormlq.c b/SRC/sormlq.c
new file mode 100644
index 0000000..a5b8632
--- /dev/null
+++ b/SRC/sormlq.c
@@ -0,0 +1,334 @@
+/* sormlq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int sormlq_(char *side, char *trans, integer *m, integer *n,
+ integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
+ real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
+ i__5;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ real t[4160] /* was [65][64] */;
+ integer i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iws;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int sorml2_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *), slarfb_(char *, char *, char *, char *
+, integer *, integer *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slarft_(char *, char *, integer *, integer *,
+ real *, integer *, real *, real *, integer *);
+ logical notran;
+ integer ldwork;
+ char transt[1];
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORMLQ overwrites the general real M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'T': Q**T * C C * Q**T */
+
+/* where Q is a real orthogonal matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by SGELQF. Q is of order M if SIDE = 'L' and of order N */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**T from the Left; */
+/* = 'R': apply Q or Q**T from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'T': Transpose, apply Q**T. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) REAL array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* SGELQF in the first k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) REAL array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by SGELQF. */
+
+/* C (input/output) REAL array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = *n;
+ } else {
+ nq = *n;
+ nw = *m;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,*k)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ } else if (*lwork < max(1,nw) && ! lquery) {
+ *info = -12;
+ }
+
+ if (*info == 0) {
+
+/* Determine the block size. NB may be at most NBMAX, where NBMAX */
+/* is used to define the local array T. */
+
+/* Computing MIN */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 64, i__2 = ilaenv_(&c__1, "SORMLQ", ch__1, m, n, k, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = max(1,nw) * nb;
+ work[1] = (real) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SORMLQ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ work[1] = 1.f;
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = nw;
+ if (nb > 1 && nb < *k) {
+ iws = nw * nb;
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 2, i__2 = ilaenv_(&c__2, "SORMLQ", ch__1, m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = nw;
+ }
+
+ if (nb < nbmin || nb >= *k) {
+
+/* Use unblocked code */
+
+ sorml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], &iinfo);
+ } else {
+
+/* Use blocked code */
+
+ if (left && notran || ! left && ! notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = nb;
+ } else {
+ i1 = (*k - 1) / nb * nb + 1;
+ i2 = 1;
+ i3 = -nb;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ }
+
+ if (notran) {
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *k - i__ + 1;
+ ib = min(i__4,i__5);
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__4 = nq - i__ + 1;
+ slarft_("Forward", "Rowwise", &i__4, &ib, &a[i__ + i__ * a_dim1],
+ lda, &tau[i__], t, &c__65);
+ if (left) {
+
+/* H or H' is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H or H' is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H or H' */
+
+ slarfb_(side, transt, "Forward", "Rowwise", &mi, &ni, &ib, &a[i__
+ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1],
+ ldc, &work[1], &ldwork);
+/* L10: */
+ }
+ }
+ work[1] = (real) lwkopt;
+ return 0;
+
+/* End of SORMLQ */
+
+} /* sormlq_ */
diff --git a/SRC/sormql.c b/SRC/sormql.c
new file mode 100644
index 0000000..60d78d4
--- /dev/null
+++ b/SRC/sormql.c
@@ -0,0 +1,328 @@
+/* sormql.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int sormql_(char *side, char *trans, integer *m, integer *n,
+ integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
+ real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
+ i__5;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ real t[4160] /* was [65][64] */;
+ integer i1, i2, i3, ib, nb, mi, ni, nq, nw, iws;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int sorm2l_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *), slarfb_(char *, char *, char *, char *
+, integer *, integer *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slarft_(char *, char *, integer *, integer *,
+ real *, integer *, real *, real *, integer *);
+ logical notran;
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORMQL overwrites the general real M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'T': Q**T * C C * Q**T */
+
+/* where Q is a real orthogonal matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by SGEQLF. Q is of order M if SIDE = 'L' and of order N */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**T from the Left; */
+/* = 'R': apply Q or Q**T from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'T': Transpose, apply Q**T. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) REAL array, dimension (LDA,K) */
+/* The i-th column must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* SGEQLF in the last k columns of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If SIDE = 'L', LDA >= max(1,M); */
+/* if SIDE = 'R', LDA >= max(1,N). */
+
+/* TAU (input) REAL array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by SGEQLF. */
+
+/* C (input/output) REAL array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = max(1,*n);
+ } else {
+ nq = *n;
+ nw = max(1,*m);
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,nq)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+
+ if (*info == 0) {
+ if (*m == 0 || *n == 0) {
+ lwkopt = 1;
+ } else {
+
+/* Determine the block size. NB may be at most NBMAX, where */
+/* NBMAX is used to define the local array T. */
+
+
+/* Computing MIN */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 64, i__2 = ilaenv_(&c__1, "SORMQL", ch__1, m, n, k, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = nw * nb;
+ }
+ work[1] = (real) lwkopt;
+
+ if (*lwork < nw && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SORMQL", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = nw;
+ if (nb > 1 && nb < *k) {
+ iws = nw * nb;
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 2, i__2 = ilaenv_(&c__2, "SORMQL", ch__1, m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = nw;
+ }
+
+ if (nb < nbmin || nb >= *k) {
+
+/* Use unblocked code */
+
+ sorm2l_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], &iinfo);
+ } else {
+
+/* Use blocked code */
+
+ if (left && notran || ! left && ! notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = nb;
+ } else {
+ i1 = (*k - 1) / nb * nb + 1;
+ i2 = 1;
+ i3 = -nb;
+ }
+
+ if (left) {
+ ni = *n;
+ } else {
+ mi = *m;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *k - i__ + 1;
+ ib = min(i__4,i__5);
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__4 = nq - *k + i__ + ib - 1;
+ slarft_("Backward", "Columnwise", &i__4, &ib, &a[i__ * a_dim1 + 1]
+, lda, &tau[i__], t, &c__65);
+ if (left) {
+
+/* H or H' is applied to C(1:m-k+i+ib-1,1:n) */
+
+ mi = *m - *k + i__ + ib - 1;
+ } else {
+
+/* H or H' is applied to C(1:m,1:n-k+i+ib-1) */
+
+ ni = *n - *k + i__ + ib - 1;
+ }
+
+/* Apply H or H' */
+
+ slarfb_(side, trans, "Backward", "Columnwise", &mi, &ni, &ib, &a[
+ i__ * a_dim1 + 1], lda, t, &c__65, &c__[c_offset], ldc, &
+ work[1], &ldwork);
+/* L10: */
+ }
+ }
+ work[1] = (real) lwkopt;
+ return 0;
+
+/* End of SORMQL */
+
+} /* sormql_ */
diff --git a/SRC/sormqr.c b/SRC/sormqr.c
new file mode 100644
index 0000000..2e965b8
--- /dev/null
+++ b/SRC/sormqr.c
@@ -0,0 +1,327 @@
+/* sormqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int sormqr_(char *side, char *trans, integer *m, integer *n,
+ integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
+ real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
+ i__5;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ real t[4160] /* was [65][64] */;
+ integer i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iws;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *), slarfb_(char *, char *, char *, char *
+, integer *, integer *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slarft_(char *, char *, integer *, integer *,
+ real *, integer *, real *, real *, integer *);
+ logical notran;
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORMQR overwrites the general real M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'T': Q**T * C C * Q**T */
+
+/* where Q is a real orthogonal matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by SGEQRF. Q is of order M if SIDE = 'L' and of order N */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**T from the Left; */
+/* = 'R': apply Q or Q**T from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'T': Transpose, apply Q**T. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) REAL array, dimension (LDA,K) */
+/* The i-th column must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* SGEQRF in the first k columns of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If SIDE = 'L', LDA >= max(1,M); */
+/* if SIDE = 'R', LDA >= max(1,N). */
+
+/* TAU (input) REAL array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by SGEQRF. */
+
+/* C (input/output) REAL array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = *n;
+ } else {
+ nq = *n;
+ nw = *m;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,nq)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ } else if (*lwork < max(1,nw) && ! lquery) {
+ *info = -12;
+ }
+
+ if (*info == 0) {
+
+/* Determine the block size. NB may be at most NBMAX, where NBMAX */
+/* is used to define the local array T. */
+
+/* Computing MIN */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 64, i__2 = ilaenv_(&c__1, "SORMQR", ch__1, m, n, k, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = max(1,nw) * nb;
+ work[1] = (real) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SORMQR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ work[1] = 1.f;
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = nw;
+ if (nb > 1 && nb < *k) {
+ iws = nw * nb;
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 2, i__2 = ilaenv_(&c__2, "SORMQR", ch__1, m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = nw;
+ }
+
+ if (nb < nbmin || nb >= *k) {
+
+/* Use unblocked code */
+
+ sorm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], &iinfo);
+ } else {
+
+/* Use blocked code */
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = nb;
+ } else {
+ i1 = (*k - 1) / nb * nb + 1;
+ i2 = 1;
+ i3 = -nb;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *k - i__ + 1;
+ ib = min(i__4,i__5);
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__4 = nq - i__ + 1;
+ slarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], t, &c__65)
+ ;
+ if (left) {
+
+/* H or H' is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H or H' is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H or H' */
+
+ slarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &a[
+ i__ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc *
+ c_dim1], ldc, &work[1], &ldwork);
+/* L10: */
+ }
+ }
+ work[1] = (real) lwkopt;
+ return 0;
+
+/* End of SORMQR */
+
+} /* sormqr_ */
diff --git a/SRC/sormr2.c b/SRC/sormr2.c
new file mode 100644
index 0000000..b3bc353
--- /dev/null
+++ b/SRC/sormr2.c
@@ -0,0 +1,226 @@
+/* sormr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sormr2_(char *side, char *trans, integer *m, integer *n,
+ integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
+ real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, i1, i2, i3, mi, ni, nq;
+ real aii;
+ logical left;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *), xerbla_(
+ char *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORMR2 overwrites the general real m by n matrix C with */
+
+/* Q * C if SIDE = 'L' and TRANS = 'N', or */
+
+/* Q'* C if SIDE = 'L' and TRANS = 'T', or */
+
+/* C * Q if SIDE = 'R' and TRANS = 'N', or */
+
+/* C * Q' if SIDE = 'R' and TRANS = 'T', */
+
+/* where Q is a real orthogonal matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by SGERQF. Q is of order m if SIDE = 'L' and of order n */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q' from the Left */
+/* = 'R': apply Q or Q' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply Q (No transpose) */
+/* = 'T': apply Q' (Transpose) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) REAL array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* SGERQF in the last k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) REAL array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by SGERQF. */
+
+/* C (input/output) REAL array, dimension (LDC,N) */
+/* On entry, the m by n matrix C. */
+/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) REAL array, dimension */
+/* (N) if SIDE = 'L', */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,*k)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SORMR2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ return 0;
+ }
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = 1;
+ } else {
+ i1 = *k;
+ i2 = 1;
+ i3 = -1;
+ }
+
+ if (left) {
+ ni = *n;
+ } else {
+ mi = *m;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) is applied to C(1:m-k+i,1:n) */
+
+ mi = *m - *k + i__;
+ } else {
+
+/* H(i) is applied to C(1:m,1:n-k+i) */
+
+ ni = *n - *k + i__;
+ }
+
+/* Apply H(i) */
+
+ aii = a[i__ + (nq - *k + i__) * a_dim1];
+ a[i__ + (nq - *k + i__) * a_dim1] = 1.f;
+ slarf_(side, &mi, &ni, &a[i__ + a_dim1], lda, &tau[i__], &c__[
+ c_offset], ldc, &work[1]);
+ a[i__ + (nq - *k + i__) * a_dim1] = aii;
+/* L10: */
+ }
+ return 0;
+
+/* End of SORMR2 */
+
+} /* sormr2_ */
diff --git a/SRC/sormr3.c b/SRC/sormr3.c
new file mode 100644
index 0000000..33ad1e8
--- /dev/null
+++ b/SRC/sormr3.c
@@ -0,0 +1,241 @@
+/* sormr3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sormr3_(char *side, char *trans, integer *m, integer *n,
+ integer *k, integer *l, real *a, integer *lda, real *tau, real *c__,
+ integer *ldc, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, i1, i2, i3, ja, ic, jc, mi, ni, nq;
+ logical left;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int slarz_(char *, integer *, integer *, integer *
+, real *, integer *, real *, real *, integer *, real *),
+ xerbla_(char *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORMR3 overwrites the general real m by n matrix C with */
+
+/* Q * C if SIDE = 'L' and TRANS = 'N', or */
+
+/* Q'* C if SIDE = 'L' and TRANS = 'T', or */
+
+/* C * Q if SIDE = 'R' and TRANS = 'N', or */
+
+/* C * Q' if SIDE = 'R' and TRANS = 'T', */
+
+/* where Q is a real orthogonal matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by STZRZF. Q is of order m if SIDE = 'L' and of order n */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q' from the Left */
+/* = 'R': apply Q or Q' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply Q (No transpose) */
+/* = 'T': apply Q' (Transpose) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* L (input) INTEGER */
+/* The number of columns of the matrix A containing */
+/* the meaningful part of the Householder reflectors. */
+/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */
+
+/* A (input) REAL array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* STZRZF in the last k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) REAL array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by STZRZF. */
+
+/* C (input/output) REAL array, dimension (LDC,N) */
+/* On entry, the m-by-n matrix C. */
+/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) REAL array, dimension */
+/* (N) if SIDE = 'L', */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*l < 0 || left && *l > *m || ! left && *l > *n) {
+ *info = -6;
+ } else if (*lda < max(1,*k)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SORMR3", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ return 0;
+ }
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = 1;
+ } else {
+ i1 = *k;
+ i2 = 1;
+ i3 = -1;
+ }
+
+ if (left) {
+ ni = *n;
+ ja = *m - *l + 1;
+ jc = 1;
+ } else {
+ mi = *m;
+ ja = *n - *l + 1;
+ ic = 1;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) or H(i)' is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H(i) or H(i)' is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H(i) or H(i)' */
+
+ slarz_(side, &mi, &ni, l, &a[i__ + ja * a_dim1], lda, &tau[i__], &c__[
+ ic + jc * c_dim1], ldc, &work[1]);
+
+/* L10: */
+ }
+
+ return 0;
+
+/* End of SORMR3 */
+
+} /* sormr3_ */
diff --git a/SRC/sormrq.c b/SRC/sormrq.c
new file mode 100644
index 0000000..aa97bd5
--- /dev/null
+++ b/SRC/sormrq.c
@@ -0,0 +1,335 @@
+/* sormrq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int sormrq_(char *side, char *trans, integer *m, integer *n,
+ integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc,
+ real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
+ i__5;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ real t[4160] /* was [65][64] */;
+ integer i1, i2, i3, ib, nb, mi, ni, nq, nw, iws;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int sormr2_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *), slarfb_(char *, char *, char *, char *
+, integer *, integer *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slarft_(char *, char *, integer *, integer *,
+ real *, integer *, real *, real *, integer *);
+ logical notran;
+ integer ldwork;
+ char transt[1];
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORMRQ overwrites the general real M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'T': Q**T * C C * Q**T */
+
+/* where Q is a real orthogonal matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by SGERQF. Q is of order M if SIDE = 'L' and of order N */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**T from the Left; */
+/* = 'R': apply Q or Q**T from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'T': Transpose, apply Q**T. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) REAL array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* SGERQF in the last k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) REAL array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by SGERQF. */
+
+/* C (input/output) REAL array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = max(1,*n);
+ } else {
+ nq = *n;
+ nw = max(1,*m);
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,*k)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+
+ if (*info == 0) {
+ if (*m == 0 || *n == 0) {
+ lwkopt = 1;
+ } else {
+
+/* Determine the block size. NB may be at most NBMAX, where */
+/* NBMAX is used to define the local array T. */
+
+/* Computing MIN */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 64, i__2 = ilaenv_(&c__1, "SORMRQ", ch__1, m, n, k, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = nw * nb;
+ }
+ work[1] = (real) lwkopt;
+
+ if (*lwork < nw && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SORMRQ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = nw;
+ if (nb > 1 && nb < *k) {
+ iws = nw * nb;
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 2, i__2 = ilaenv_(&c__2, "SORMRQ", ch__1, m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = nw;
+ }
+
+ if (nb < nbmin || nb >= *k) {
+
+/* Use unblocked code */
+
+ sormr2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], &iinfo);
+ } else {
+
+/* Use blocked code */
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = nb;
+ } else {
+ i1 = (*k - 1) / nb * nb + 1;
+ i2 = 1;
+ i3 = -nb;
+ }
+
+ if (left) {
+ ni = *n;
+ } else {
+ mi = *m;
+ }
+
+ if (notran) {
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *k - i__ + 1;
+ ib = min(i__4,i__5);
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__4 = nq - *k + i__ + ib - 1;
+ slarft_("Backward", "Rowwise", &i__4, &ib, &a[i__ + a_dim1], lda,
+ &tau[i__], t, &c__65);
+ if (left) {
+
+/* H or H' is applied to C(1:m-k+i+ib-1,1:n) */
+
+ mi = *m - *k + i__ + ib - 1;
+ } else {
+
+/* H or H' is applied to C(1:m,1:n-k+i+ib-1) */
+
+ ni = *n - *k + i__ + ib - 1;
+ }
+
+/* Apply H or H' */
+
+ slarfb_(side, transt, "Backward", "Rowwise", &mi, &ni, &ib, &a[
+ i__ + a_dim1], lda, t, &c__65, &c__[c_offset], ldc, &work[
+ 1], &ldwork);
+/* L10: */
+ }
+ }
+ work[1] = (real) lwkopt;
+ return 0;
+
+/* End of SORMRQ */
+
+} /* sormrq_ */
diff --git a/SRC/sormrz.c b/SRC/sormrz.c
new file mode 100644
index 0000000..db1aed0
--- /dev/null
+++ b/SRC/sormrz.c
@@ -0,0 +1,358 @@
+/* sormrz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int sormrz_(char *side, char *trans, integer *m, integer *n,
+ integer *k, integer *l, real *a, integer *lda, real *tau, real *c__,
+ integer *ldc, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
+ i__5;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ real t[4160] /* was [65][64] */;
+ integer i1, i2, i3, ib, ic, ja, jc, nb, mi, ni, nq, nw, iws;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int sormr3_(char *, char *, integer *, integer *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, real *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slarzb_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, real *, integer *,
+ real *, integer *, real *, integer *, real *, integer *);
+ logical notran;
+ integer ldwork;
+ char transt[1];
+ extern /* Subroutine */ int slarzt_(char *, char *, integer *, integer *,
+ real *, integer *, real *, real *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORMRZ overwrites the general real M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'T': Q**T * C C * Q**T */
+
+/* where Q is a real orthogonal matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by STZRZF. Q is of order M if SIDE = 'L' and of order N */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**T from the Left; */
+/* = 'R': apply Q or Q**T from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'T': Transpose, apply Q**T. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* L (input) INTEGER */
+/* The number of columns of the matrix A containing */
+/* the meaningful part of the Householder reflectors. */
+/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */
+
+/* A (input) REAL array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* STZRZF in the last k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) REAL array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by STZRZF. */
+
+/* C (input/output) REAL array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = max(1,*n);
+ } else {
+ nq = *n;
+ nw = max(1,*m);
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*l < 0 || left && *l > *m || ! left && *l > *n) {
+ *info = -6;
+ } else if (*lda < max(1,*k)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -11;
+ }
+
+ if (*info == 0) {
+ if (*m == 0 || *n == 0) {
+ lwkopt = 1;
+ } else {
+
+/* Determine the block size. NB may be at most NBMAX, where */
+/* NBMAX is used to define the local array T. */
+
+/* Computing MIN */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 64, i__2 = ilaenv_(&c__1, "SORMRQ", ch__1, m, n, k, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = nw * nb;
+ }
+ work[1] = (real) lwkopt;
+
+ if (*lwork < max(1,nw) && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SORMRZ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = nw;
+ if (nb > 1 && nb < *k) {
+ iws = nw * nb;
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 2, i__2 = ilaenv_(&c__2, "SORMRQ", ch__1, m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = nw;
+ }
+
+ if (nb < nbmin || nb >= *k) {
+
+/* Use unblocked code */
+
+ sormr3_(side, trans, m, n, k, l, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], &iinfo);
+ } else {
+
+/* Use blocked code */
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = nb;
+ } else {
+ i1 = (*k - 1) / nb * nb + 1;
+ i2 = 1;
+ i3 = -nb;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ ja = *m - *l + 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ ja = *n - *l + 1;
+ }
+
+ if (notran) {
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *k - i__ + 1;
+ ib = min(i__4,i__5);
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ slarzt_("Backward", "Rowwise", l, &ib, &a[i__ + ja * a_dim1], lda,
+ &tau[i__], t, &c__65);
+
+ if (left) {
+
+/* H or H' is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H or H' is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H or H' */
+
+ slarzb_(side, transt, "Backward", "Rowwise", &mi, &ni, &ib, l, &a[
+ i__ + ja * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1]
+, ldc, &work[1], &ldwork);
+/* L10: */
+ }
+
+ }
+
+ work[1] = (real) lwkopt;
+
+ return 0;
+
+/* End of SORMRZ */
+
+} /* sormrz_ */
diff --git a/SRC/sormtr.c b/SRC/sormtr.c
new file mode 100644
index 0000000..0865f72
--- /dev/null
+++ b/SRC/sormtr.c
@@ -0,0 +1,295 @@
+/* sormtr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int sormtr_(char *side, char *uplo, char *trans, integer *m,
+ integer *n, real *a, integer *lda, real *tau, real *c__, integer *ldc,
+ real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2, i__3;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i1, i2, nb, mi, ni, nq, nw;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int sormql_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORMTR overwrites the general real M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'T': Q**T * C C * Q**T */
+
+/* where Q is a real orthogonal matrix of order nq, with nq = m if */
+/* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */
+/* nq-1 elementary reflectors, as returned by SSYTRD: */
+
+/* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); */
+
+/* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**T from the Left; */
+/* = 'R': apply Q or Q**T from the Right. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A contains elementary reflectors */
+/* from SSYTRD; */
+/* = 'L': Lower triangle of A contains elementary reflectors */
+/* from SSYTRD. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'T': Transpose, apply Q**T. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* A (input) REAL array, dimension */
+/* (LDA,M) if SIDE = 'L' */
+/* (LDA,N) if SIDE = 'R' */
+/* The vectors which define the elementary reflectors, as */
+/* returned by SSYTRD. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. */
+
+/* TAU (input) REAL array, dimension */
+/* (M-1) if SIDE = 'L' */
+/* (N-1) if SIDE = 'R' */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by SSYTRD. */
+
+/* C (input/output) REAL array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = *n;
+ } else {
+ nq = *n;
+ nw = *m;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T")) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,nq)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ } else if (*lwork < max(1,nw) && ! lquery) {
+ *info = -12;
+ }
+
+ if (*info == 0) {
+ if (upper) {
+ if (left) {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ nb = ilaenv_(&c__1, "SORMQL", ch__1, &i__2, n, &i__3, &c_n1);
+ } else {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ nb = ilaenv_(&c__1, "SORMQL", ch__1, m, &i__2, &i__3, &c_n1);
+ }
+ } else {
+ if (left) {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ nb = ilaenv_(&c__1, "SORMQR", ch__1, &i__2, n, &i__3, &c_n1);
+ } else {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ nb = ilaenv_(&c__1, "SORMQR", ch__1, m, &i__2, &i__3, &c_n1);
+ }
+ }
+ lwkopt = max(1,nw) * nb;
+ work[1] = (real) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__2 = -(*info);
+ xerbla_("SORMTR", &i__2);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || nq == 1) {
+ work[1] = 1.f;
+ return 0;
+ }
+
+ if (left) {
+ mi = *m - 1;
+ ni = *n;
+ } else {
+ mi = *m;
+ ni = *n - 1;
+ }
+
+ if (upper) {
+
+/* Q was determined by a call to SSYTRD with UPLO = 'U' */
+
+ i__2 = nq - 1;
+ sormql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, &
+ tau[1], &c__[c_offset], ldc, &work[1], lwork, &iinfo);
+ } else {
+
+/* Q was determined by a call to SSYTRD with UPLO = 'L' */
+
+ if (left) {
+ i1 = 2;
+ i2 = 1;
+ } else {
+ i1 = 1;
+ i2 = 2;
+ }
+ i__2 = nq - 1;
+ sormqr_(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], &
+ c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo);
+ }
+ work[1] = (real) lwkopt;
+ return 0;
+
+/* End of SORMTR */
+
+} /* sormtr_ */
diff --git a/SRC/spbcon.c b/SRC/spbcon.c
new file mode 100644
index 0000000..620291e
--- /dev/null
+++ b/SRC/spbcon.c
@@ -0,0 +1,232 @@
+/* spbcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int spbcon_(char *uplo, integer *n, integer *kd, real *ab,
+ integer *ldab, real *anorm, real *rcond, real *work, integer *iwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1;
+ real r__1;
+
+ /* Local variables */
+ integer ix, kase;
+ real scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *);
+ logical upper;
+ extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *,
+ real *, integer *, integer *);
+ real scalel;
+ extern doublereal slamch_(char *);
+ real scaleu;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int slatbs_(char *, char *, char *, char *,
+ integer *, integer *, real *, integer *, real *, real *, real *,
+ integer *);
+ char normin[1];
+ real smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPBCON estimates the reciprocal of the condition number (in the */
+/* 1-norm) of a real symmetric positive definite band matrix using the */
+/* Cholesky factorization A = U**T*U or A = L*L**T computed by SPBTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular factor stored in AB; */
+/* = 'L': Lower triangular factor stored in AB. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input) REAL array, dimension (LDAB,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T of the band matrix A, stored in the */
+/* first KD+1 rows of the array. The j-th column of U or L is */
+/* stored in the j-th column of the array AB as follows: */
+/* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* ANORM (input) REAL */
+/* The 1-norm (or infinity-norm) of the symmetric band matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*ldab < *kd + 1) {
+ *info = -5;
+ } else if (*anorm < 0.f) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPBCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.f;
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ } else if (*anorm == 0.f) {
+ return 0;
+ }
+
+ smlnum = slamch_("Safe minimum");
+
+/* Estimate the 1-norm of the inverse. */
+
+ kase = 0;
+ *(unsigned char *)normin = 'N';
+L10:
+ slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (upper) {
+
+/* Multiply by inv(U'). */
+
+ slatbs_("Upper", "Transpose", "Non-unit", normin, n, kd, &ab[
+ ab_offset], ldab, &work[1], &scalel, &work[(*n << 1) + 1],
+ info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(U). */
+
+ slatbs_("Upper", "No transpose", "Non-unit", normin, n, kd, &ab[
+ ab_offset], ldab, &work[1], &scaleu, &work[(*n << 1) + 1],
+ info);
+ } else {
+
+/* Multiply by inv(L). */
+
+ slatbs_("Lower", "No transpose", "Non-unit", normin, n, kd, &ab[
+ ab_offset], ldab, &work[1], &scalel, &work[(*n << 1) + 1],
+ info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(L'). */
+
+ slatbs_("Lower", "Transpose", "Non-unit", normin, n, kd, &ab[
+ ab_offset], ldab, &work[1], &scaleu, &work[(*n << 1) + 1],
+ info);
+ }
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ scale = scalel * scaleu;
+ if (scale != 1.f) {
+ ix = isamax_(n, &work[1], &c__1);
+ if (scale < (r__1 = work[ix], dabs(r__1)) * smlnum || scale ==
+ 0.f) {
+ goto L20;
+ }
+ srscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / ainvnm / *anorm;
+ }
+
+L20:
+
+ return 0;
+
+/* End of SPBCON */
+
+} /* spbcon_ */
diff --git a/SRC/spbequ.c b/SRC/spbequ.c
new file mode 100644
index 0000000..215af52
--- /dev/null
+++ b/SRC/spbequ.c
@@ -0,0 +1,202 @@
+/* spbequ.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int spbequ_(char *uplo, integer *n, integer *kd, real *ab,
+ integer *ldab, real *s, real *scond, real *amax, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ real smin;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPBEQU computes row and column scalings intended to equilibrate a */
+/* symmetric positive definite band matrix A and reduce its condition */
+/* number (with respect to the two-norm). S contains the scale factors, */
+/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
+/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
+/* choice of S puts the condition number of B within a factor N of the */
+/* smallest possible condition number over all possible diagonal */
+/* scalings. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular of A is stored; */
+/* = 'L': Lower triangular of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input) REAL array, dimension (LDAB,N) */
+/* The upper or lower triangle of the symmetric band matrix A, */
+/* stored in the first KD+1 rows of the array. The j-th column */
+/* of A is stored in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array A. LDAB >= KD+1. */
+
+/* S (output) REAL array, dimension (N) */
+/* If INFO = 0, S contains the scale factors for A. */
+
+/* SCOND (output) REAL */
+/* If INFO = 0, S contains the ratio of the smallest S(i) to */
+/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
+/* large nor too small, it is not worth scaling by S. */
+
+/* AMAX (output) REAL */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --s;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*ldab < *kd + 1) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPBEQU", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *scond = 1.f;
+ *amax = 0.f;
+ return 0;
+ }
+
+ if (upper) {
+ j = *kd + 1;
+ } else {
+ j = 1;
+ }
+
+/* Initialize SMIN and AMAX. */
+
+ s[1] = ab[j + ab_dim1];
+ smin = s[1];
+ *amax = s[1];
+
+/* Find the minimum and maximum diagonal elements. */
+
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ s[i__] = ab[j + i__ * ab_dim1];
+/* Computing MIN */
+ r__1 = smin, r__2 = s[i__];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = *amax, r__2 = s[i__];
+ *amax = dmax(r__1,r__2);
+/* L10: */
+ }
+
+ if (smin <= 0.f) {
+
+/* Find the first non-positive diagonal element and return. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] <= 0.f) {
+ *info = i__;
+ return 0;
+ }
+/* L20: */
+ }
+ } else {
+
+/* Set the scale factors to the reciprocals */
+/* of the diagonal elements. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s[i__] = 1.f / sqrt(s[i__]);
+/* L30: */
+ }
+
+/* Compute SCOND = min(S(I)) / max(S(I)) */
+
+ *scond = sqrt(smin) / sqrt(*amax);
+ }
+ return 0;
+
+/* End of SPBEQU */
+
+} /* spbequ_ */
diff --git a/SRC/spbrfs.c b/SRC/spbrfs.c
new file mode 100644
index 0000000..bbcab5a
--- /dev/null
+++ b/SRC/spbrfs.c
@@ -0,0 +1,434 @@
+/* spbrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b12 = -1.f;
+static real c_b14 = 1.f;
+
+/* Subroutine */ int spbrfs_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, real *ab, integer *ldab, real *afb, integer *ldafb, real *b,
+ integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *
+ work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, k, l;
+ real s, xk;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3], count;
+ extern /* Subroutine */ int ssbmv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ logical upper;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), saxpy_(integer *, real *, real *, integer *, real *,
+ integer *), slacn2_(integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real lstres;
+ extern /* Subroutine */ int spbtrs_(char *, integer *, integer *, integer
+ *, real *, integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPBRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric positive definite */
+/* and banded, and provides error bounds and backward error estimates */
+/* for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input) REAL array, dimension (LDAB,N) */
+/* The upper or lower triangle of the symmetric band matrix A, */
+/* stored in the first KD+1 rows of the array. The j-th column */
+/* of A is stored in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* AFB (input) REAL array, dimension (LDAFB,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T of the band matrix A as computed by */
+/* SPBTRF, in the same storage format as A (see AB). */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= KD+1. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) REAL array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by SPBTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldab < *kd + 1) {
+ *info = -6;
+ } else if (*ldafb < *kd + 1) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldx < max(1,*n)) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPBRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+/* Computing MIN */
+ i__1 = *n + 1, i__2 = (*kd << 1) + 2;
+ nz = min(i__1,i__2);
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.f;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ scopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+ ssbmv_(uplo, n, kd, &c_b12, &ab[ab_offset], ldab, &x[j * x_dim1 + 1],
+ &c__1, &c_b14, &work[*n + 1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] = (r__1 = b[i__ + j * b_dim1], dabs(r__1));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+ l = *kd + 1 - k;
+/* Computing MAX */
+ i__3 = 1, i__4 = k - *kd;
+ i__5 = k - 1;
+ for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
+ work[i__] += (r__1 = ab[l + i__ + k * ab_dim1], dabs(r__1)
+ ) * xk;
+ s += (r__1 = ab[l + i__ + k * ab_dim1], dabs(r__1)) * (
+ r__2 = x[i__ + j * x_dim1], dabs(r__2));
+/* L40: */
+ }
+ work[k] = work[k] + (r__1 = ab[*kd + 1 + k * ab_dim1], dabs(
+ r__1)) * xk + s;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+ work[k] += (r__1 = ab[k * ab_dim1 + 1], dabs(r__1)) * xk;
+ l = 1 - k;
+/* Computing MIN */
+ i__3 = *n, i__4 = k + *kd;
+ i__5 = min(i__3,i__4);
+ for (i__ = k + 1; i__ <= i__5; ++i__) {
+ work[i__] += (r__1 = ab[l + i__ + k * ab_dim1], dabs(r__1)
+ ) * xk;
+ s += (r__1 = ab[l + i__ + k * ab_dim1], dabs(r__1)) * (
+ r__2 = x[i__ + j * x_dim1], dabs(r__2));
+/* L60: */
+ }
+ work[k] += s;
+/* L70: */
+ }
+ }
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[
+ i__];
+ s = dmax(r__2,r__3);
+ } else {
+/* Computing MAX */
+ r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1)
+ / (work[i__] + safe1);
+ s = dmax(r__2,r__3);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ spbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[*n + 1]
+, n, info);
+ saxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
+ ;
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use SLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ slacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+ kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ spbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[*n
+ + 1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] *= work[i__];
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] *= work[i__];
+/* L120: */
+ }
+ spbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[*n
+ + 1], n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], dabs(r__1));
+ lstres = dmax(r__2,r__3);
+/* L130: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of SPBRFS */
+
+} /* spbrfs_ */
diff --git a/SRC/spbstf.c b/SRC/spbstf.c
new file mode 100644
index 0000000..6c79ba8
--- /dev/null
+++ b/SRC/spbstf.c
@@ -0,0 +1,312 @@
+/* spbstf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b9 = -1.f;
+
+/* Subroutine */ int spbstf_(char *uplo, integer *n, integer *kd, real *ab,
+ integer *ldab, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer j, m, km;
+ real ajj;
+ integer kld;
+ extern /* Subroutine */ int ssyr_(char *, integer *, real *, real *,
+ integer *, real *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPBSTF computes a split Cholesky factorization of a real */
+/* symmetric positive definite band matrix A. */
+
+/* This routine is designed to be used in conjunction with SSBGST. */
+
+/* The factorization has the form A = S**T*S where S is a band matrix */
+/* of the same bandwidth as A and the following structure: */
+
+/* S = ( U ) */
+/* ( M L ) */
+
+/* where U is upper triangular of order m = (n+kd)/2, and L is lower */
+/* triangular of order n-m. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) REAL array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first kd+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, if INFO = 0, the factor S from the split Cholesky */
+/* factorization A = S**T*S. See Further Details. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the factorization could not be completed, */
+/* because the updated element a(i,i) was negative; the */
+/* matrix A is not positive definite. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* N = 7, KD = 2: */
+
+/* S = ( s11 s12 s13 ) */
+/* ( s22 s23 s24 ) */
+/* ( s33 s34 ) */
+/* ( s44 ) */
+/* ( s53 s54 s55 ) */
+/* ( s64 s65 s66 ) */
+/* ( s75 s76 s77 ) */
+
+/* If UPLO = 'U', the array AB holds: */
+
+/* on entry: on exit: */
+
+/* * * a13 a24 a35 a46 a57 * * s13 s24 s53 s64 s75 */
+/* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54 s65 s76 */
+/* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 */
+
+/* If UPLO = 'L', the array AB holds: */
+
+/* on entry: on exit: */
+
+/* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 */
+/* a21 a32 a43 a54 a65 a76 * s12 s23 s34 s54 s65 s76 * */
+/* a31 a42 a53 a64 a64 * * s13 s24 s53 s64 s75 * * */
+
+/* Array elements marked * are not used by the routine. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*ldab < *kd + 1) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPBSTF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *ldab - 1;
+ kld = max(i__1,i__2);
+
+/* Set the splitting point m. */
+
+ m = (*n + *kd) / 2;
+
+ if (upper) {
+
+/* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m). */
+
+ i__1 = m + 1;
+ for (j = *n; j >= i__1; --j) {
+
+/* Compute s(j,j) and test for non-positive-definiteness. */
+
+ ajj = ab[*kd + 1 + j * ab_dim1];
+ if (ajj <= 0.f) {
+ goto L50;
+ }
+ ajj = sqrt(ajj);
+ ab[*kd + 1 + j * ab_dim1] = ajj;
+/* Computing MIN */
+ i__2 = j - 1;
+ km = min(i__2,*kd);
+
+/* Compute elements j-km:j-1 of the j-th column and update the */
+/* the leading submatrix within the band. */
+
+ r__1 = 1.f / ajj;
+ sscal_(&km, &r__1, &ab[*kd + 1 - km + j * ab_dim1], &c__1);
+ ssyr_("Upper", &km, &c_b9, &ab[*kd + 1 - km + j * ab_dim1], &c__1,
+ &ab[*kd + 1 + (j - km) * ab_dim1], &kld);
+/* L10: */
+ }
+
+/* Factorize the updated submatrix A(1:m,1:m) as U**T*U. */
+
+ i__1 = m;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute s(j,j) and test for non-positive-definiteness. */
+
+ ajj = ab[*kd + 1 + j * ab_dim1];
+ if (ajj <= 0.f) {
+ goto L50;
+ }
+ ajj = sqrt(ajj);
+ ab[*kd + 1 + j * ab_dim1] = ajj;
+/* Computing MIN */
+ i__2 = *kd, i__3 = m - j;
+ km = min(i__2,i__3);
+
+/* Compute elements j+1:j+km of the j-th row and update the */
+/* trailing submatrix within the band. */
+
+ if (km > 0) {
+ r__1 = 1.f / ajj;
+ sscal_(&km, &r__1, &ab[*kd + (j + 1) * ab_dim1], &kld);
+ ssyr_("Upper", &km, &c_b9, &ab[*kd + (j + 1) * ab_dim1], &kld,
+ &ab[*kd + 1 + (j + 1) * ab_dim1], &kld);
+ }
+/* L20: */
+ }
+ } else {
+
+/* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m). */
+
+ i__1 = m + 1;
+ for (j = *n; j >= i__1; --j) {
+
+/* Compute s(j,j) and test for non-positive-definiteness. */
+
+ ajj = ab[j * ab_dim1 + 1];
+ if (ajj <= 0.f) {
+ goto L50;
+ }
+ ajj = sqrt(ajj);
+ ab[j * ab_dim1 + 1] = ajj;
+/* Computing MIN */
+ i__2 = j - 1;
+ km = min(i__2,*kd);
+
+/* Compute elements j-km:j-1 of the j-th row and update the */
+/* trailing submatrix within the band. */
+
+ r__1 = 1.f / ajj;
+ sscal_(&km, &r__1, &ab[km + 1 + (j - km) * ab_dim1], &kld);
+ ssyr_("Lower", &km, &c_b9, &ab[km + 1 + (j - km) * ab_dim1], &kld,
+ &ab[(j - km) * ab_dim1 + 1], &kld);
+/* L30: */
+ }
+
+/* Factorize the updated submatrix A(1:m,1:m) as U**T*U. */
+
+ i__1 = m;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute s(j,j) and test for non-positive-definiteness. */
+
+ ajj = ab[j * ab_dim1 + 1];
+ if (ajj <= 0.f) {
+ goto L50;
+ }
+ ajj = sqrt(ajj);
+ ab[j * ab_dim1 + 1] = ajj;
+/* Computing MIN */
+ i__2 = *kd, i__3 = m - j;
+ km = min(i__2,i__3);
+
+/* Compute elements j+1:j+km of the j-th column and update the */
+/* trailing submatrix within the band. */
+
+ if (km > 0) {
+ r__1 = 1.f / ajj;
+ sscal_(&km, &r__1, &ab[j * ab_dim1 + 2], &c__1);
+ ssyr_("Lower", &km, &c_b9, &ab[j * ab_dim1 + 2], &c__1, &ab[(
+ j + 1) * ab_dim1 + 1], &kld);
+ }
+/* L40: */
+ }
+ }
+ return 0;
+
+L50:
+ *info = j;
+ return 0;
+
+/* End of SPBSTF */
+
+} /* spbstf_ */
diff --git a/SRC/spbsv.c b/SRC/spbsv.c
new file mode 100644
index 0000000..804dd54
--- /dev/null
+++ b/SRC/spbsv.c
@@ -0,0 +1,181 @@
+/* spbsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int spbsv_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, real *ab, integer *ldab, real *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), spbtrf_(
+ char *, integer *, integer *, real *, integer *, integer *), spbtrs_(char *, integer *, integer *, integer *, real *,
+ integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPBSV computes the solution to a real system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N symmetric positive definite band matrix and X */
+/* and B are N-by-NRHS matrices. */
+
+/* The Cholesky decomposition is used to factor A as */
+/* A = U**T * U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular band matrix, and L is a lower */
+/* triangular band matrix, with the same number of superdiagonals or */
+/* subdiagonals as A. The factored form of A is then used to solve the */
+/* system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AB (input/output) REAL array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD). */
+/* See below for further details. */
+
+/* On exit, if INFO = 0, the triangular factor U or L from the */
+/* Cholesky factorization A = U**T*U or A = L*L**T of the band */
+/* matrix A, in the same storage format as A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i of A is not */
+/* positive definite, so the factorization could not be */
+/* completed, and the solution has not been computed. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* N = 6, KD = 2, and UPLO = 'U': */
+
+/* On entry: On exit: */
+
+/* * * a13 a24 a35 a46 * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+
+/* Similarly, if UPLO = 'L' the format of A is as follows: */
+
+/* On entry: On exit: */
+
+/* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */
+/* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */
+/* a31 a42 a53 a64 * * l31 l42 l53 l64 * * */
+
+/* Array elements marked * are not used by the routine. */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldab < *kd + 1) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPBSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ spbtrf_(uplo, n, kd, &ab[ab_offset], ldab, info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ spbtrs_(uplo, n, kd, nrhs, &ab[ab_offset], ldab, &b[b_offset], ldb,
+ info);
+
+ }
+ return 0;
+
+/* End of SPBSV */
+
+} /* spbsv_ */
diff --git a/SRC/spbsvx.c b/SRC/spbsvx.c
new file mode 100644
index 0000000..d61997d
--- /dev/null
+++ b/SRC/spbsvx.c
@@ -0,0 +1,512 @@
+/* spbsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int spbsvx_(char *fact, char *uplo, integer *n, integer *kd,
+ integer *nrhs, real *ab, integer *ldab, real *afb, integer *ldafb,
+ char *equed, real *s, real *b, integer *ldb, real *x, integer *ldx,
+ real *rcond, real *ferr, real *berr, real *work, integer *iwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer i__, j, j1, j2;
+ real amax, smin, smax;
+ extern logical lsame_(char *, char *);
+ real scond, anorm;
+ logical equil, rcequ, upper;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ extern doublereal slamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ extern doublereal slansb_(char *, char *, integer *, integer *, real *,
+ integer *, real *);
+ extern /* Subroutine */ int spbcon_(char *, integer *, integer *, real *,
+ integer *, real *, real *, real *, integer *, integer *),
+ slaqsb_(char *, integer *, integer *, real *, integer *, real *,
+ real *, real *, char *);
+ integer infequ;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), spbequ_(char *, integer *,
+ integer *, real *, integer *, real *, real *, real *, integer *), spbrfs_(char *, integer *, integer *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, real *, real *, integer *, integer *), spbtrf_(
+ char *, integer *, integer *, real *, integer *, integer *);
+ real smlnum;
+ extern /* Subroutine */ int spbtrs_(char *, integer *, integer *, integer
+ *, real *, integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to */
+/* compute the solution to a real system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N symmetric positive definite band matrix and X */
+/* and B are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+/* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
+
+/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */
+/* factor the matrix A (after equilibration if FACT = 'E') as */
+/* A = U**T * U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular band matrix, and L is a lower */
+/* triangular band matrix. */
+
+/* 3. If the leading i-by-i principal minor is not positive definite, */
+/* then the routine returns with INFO = i. Otherwise, the factored */
+/* form of A is used to estimate the condition number of the matrix */
+/* A. If the reciprocal of the condition number is less than machine */
+/* precision, INFO = N+1 is returned as a warning, but the routine */
+/* still goes on to solve for X and compute error bounds as */
+/* described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(S) so that it solves the original system before */
+/* equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AFB contains the factored form of A. */
+/* If EQUED = 'Y', the matrix A has been equilibrated */
+/* with scaling factors given by S. AB and AFB will not */
+/* be modified. */
+/* = 'N': The matrix A will be copied to AFB and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AFB and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right-hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input/output) REAL array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first KD+1 rows of the array, except */
+/* if FACT = 'F' and EQUED = 'Y', then A must contain the */
+/* equilibrated matrix diag(S)*A*diag(S). The j-th column of A */
+/* is stored in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD). */
+/* See below for further details. */
+
+/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
+/* diag(S)*A*diag(S). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array A. LDAB >= KD+1. */
+
+/* AFB (input or output) REAL array, dimension (LDAFB,N) */
+/* If FACT = 'F', then AFB is an input argument and on entry */
+/* contains the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T of the band matrix */
+/* A, in the same storage format as A (see AB). If EQUED = 'Y', */
+/* then AFB is the factored form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AFB is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T. */
+
+/* If FACT = 'E', then AFB is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T of the equilibrated */
+/* matrix A (see the description of A for the form of the */
+/* equilibrated matrix). */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= KD+1. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* S (input or output) REAL array, dimension (N) */
+/* The scale factors for A; not accessed if EQUED = 'N'. S is */
+/* an input argument if FACT = 'F'; otherwise, S is an output */
+/* argument. If FACT = 'F' and EQUED = 'Y', each element of S */
+/* must be positive. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */
+/* B is overwritten by diag(S) * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) REAL array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */
+/* the original system of equations. Note that if EQUED = 'Y', */
+/* A and B are modified on exit, and the solution to the */
+/* equilibrated system is inv(diag(S))*X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A after equilibration (if done). If RCOND is less than the */
+/* machine precision (in particular, if RCOND = 0), the matrix */
+/* is singular to working precision. This condition is */
+/* indicated by a return code of INFO > 0. */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: the leading minor of order i of A is */
+/* not positive definite, so the factorization */
+/* could not be completed, and the solution has not */
+/* been computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* N = 6, KD = 2, and UPLO = 'U': */
+
+/* Two-dimensional storage of the symmetric matrix A: */
+
+/* a11 a12 a13 */
+/* a22 a23 a24 */
+/* a33 a34 a35 */
+/* a44 a45 a46 */
+/* a55 a56 */
+/* (aij=conjg(aji)) a66 */
+
+/* Band storage of the upper triangle of A: */
+
+/* * * a13 a24 a35 a46 */
+/* * a12 a23 a34 a45 a56 */
+/* a11 a22 a33 a44 a55 a66 */
+
+/* Similarly, if UPLO = 'L' the format of A is as follows: */
+
+/* a11 a22 a33 a44 a55 a66 */
+/* a21 a32 a43 a54 a65 * */
+/* a31 a42 a53 a64 * * */
+
+/* Array elements marked * are not used by the routine. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ upper = lsame_(uplo, "U");
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rcequ = FALSE_;
+ } else {
+ rcequ = lsame_(equed, "Y");
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ }
+
+/* Test the input parameters. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kd < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*ldab < *kd + 1) {
+ *info = -7;
+ } else if (*ldafb < *kd + 1) {
+ *info = -9;
+ } else if (lsame_(fact, "F") && ! (rcequ || lsame_(
+ equed, "N"))) {
+ *info = -10;
+ } else {
+ if (rcequ) {
+ smin = bignum;
+ smax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = smin, r__2 = s[j];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = smax, r__2 = s[j];
+ smax = dmax(r__1,r__2);
+/* L10: */
+ }
+ if (smin <= 0.f) {
+ *info = -11;
+ } else if (*n > 0) {
+ scond = dmax(smin,smlnum) / dmin(smax,bignum);
+ } else {
+ scond = 1.f;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -13;
+ } else if (*ldx < max(1,*n)) {
+ *info = -15;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPBSVX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ spbequ_(uplo, n, kd, &ab[ab_offset], ldab, &s[1], &scond, &amax, &
+ infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ slaqsb_(uplo, n, kd, &ab[ab_offset], ldab, &s[1], &scond, &amax,
+ equed);
+ rcequ = lsame_(equed, "Y");
+ }
+ }
+
+/* Scale the right-hand side. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = s[i__] * b[i__ + j * b_dim1];
+/* L20: */
+ }
+/* L30: */
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j - *kd;
+ j1 = max(i__2,1);
+ i__2 = j - j1 + 1;
+ scopy_(&i__2, &ab[*kd + 1 - j + j1 + j * ab_dim1], &c__1, &
+ afb[*kd + 1 - j + j1 + j * afb_dim1], &c__1);
+/* L40: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = j + *kd;
+ j2 = min(i__2,*n);
+ i__2 = j2 - j + 1;
+ scopy_(&i__2, &ab[j * ab_dim1 + 1], &c__1, &afb[j * afb_dim1
+ + 1], &c__1);
+/* L50: */
+ }
+ }
+
+ spbtrf_(uplo, n, kd, &afb[afb_offset], ldafb, info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.f;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = slansb_("1", uplo, n, kd, &ab[ab_offset], ldab, &work[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ spbcon_(uplo, n, kd, &afb[afb_offset], ldafb, &anorm, rcond, &work[1], &
+ iwork[1], info);
+
+/* Compute the solution matrix X. */
+
+ slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ spbtrs_(uplo, n, kd, nrhs, &afb[afb_offset], ldafb, &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ spbrfs_(uplo, n, kd, nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb,
+ &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1]
+, &iwork[1], info);
+
+/* Transform the solution matrix X to a solution of the original */
+/* system. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__ + j * x_dim1] = s[i__] * x[i__ + j * x_dim1];
+/* L60: */
+ }
+/* L70: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= scond;
+/* L80: */
+ }
+ }
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < slamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of SPBSVX */
+
+} /* spbsvx_ */
diff --git a/SRC/spbtf2.c b/SRC/spbtf2.c
new file mode 100644
index 0000000..e3d2dd2
--- /dev/null
+++ b/SRC/spbtf2.c
@@ -0,0 +1,244 @@
+/* spbtf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b8 = -1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int spbtf2_(char *uplo, integer *n, integer *kd, real *ab,
+ integer *ldab, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer j, kn;
+ real ajj;
+ integer kld;
+ extern /* Subroutine */ int ssyr_(char *, integer *, real *, real *,
+ integer *, real *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPBTF2 computes the Cholesky factorization of a real symmetric */
+/* positive definite band matrix A. */
+
+/* The factorization has the form */
+/* A = U' * U , if UPLO = 'U', or */
+/* A = L * L', if UPLO = 'L', */
+/* where U is an upper triangular matrix, U' is the transpose of U, and */
+/* L is lower triangular. */
+
+/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) REAL array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, if INFO = 0, the triangular factor U or L from the */
+/* Cholesky factorization A = U'*U or A = L*L' of the band */
+/* matrix A, in the same storage format as A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, the leading minor of order k is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* N = 6, KD = 2, and UPLO = 'U': */
+
+/* On entry: On exit: */
+
+/* * * a13 a24 a35 a46 * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+
+/* Similarly, if UPLO = 'L' the format of A is as follows: */
+
+/* On entry: On exit: */
+
+/* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */
+/* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */
+/* a31 a42 a53 a64 * * l31 l42 l53 l64 * * */
+
+/* Array elements marked * are not used by the routine. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*ldab < *kd + 1) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPBTF2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *ldab - 1;
+ kld = max(i__1,i__2);
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute U(J,J) and test for non-positive-definiteness. */
+
+ ajj = ab[*kd + 1 + j * ab_dim1];
+ if (ajj <= 0.f) {
+ goto L30;
+ }
+ ajj = sqrt(ajj);
+ ab[*kd + 1 + j * ab_dim1] = ajj;
+
+/* Compute elements J+1:J+KN of row J and update the */
+/* trailing submatrix within the band. */
+
+/* Computing MIN */
+ i__2 = *kd, i__3 = *n - j;
+ kn = min(i__2,i__3);
+ if (kn > 0) {
+ r__1 = 1.f / ajj;
+ sscal_(&kn, &r__1, &ab[*kd + (j + 1) * ab_dim1], &kld);
+ ssyr_("Upper", &kn, &c_b8, &ab[*kd + (j + 1) * ab_dim1], &kld,
+ &ab[*kd + 1 + (j + 1) * ab_dim1], &kld);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute L(J,J) and test for non-positive-definiteness. */
+
+ ajj = ab[j * ab_dim1 + 1];
+ if (ajj <= 0.f) {
+ goto L30;
+ }
+ ajj = sqrt(ajj);
+ ab[j * ab_dim1 + 1] = ajj;
+
+/* Compute elements J+1:J+KN of column J and update the */
+/* trailing submatrix within the band. */
+
+/* Computing MIN */
+ i__2 = *kd, i__3 = *n - j;
+ kn = min(i__2,i__3);
+ if (kn > 0) {
+ r__1 = 1.f / ajj;
+ sscal_(&kn, &r__1, &ab[j * ab_dim1 + 2], &c__1);
+ ssyr_("Lower", &kn, &c_b8, &ab[j * ab_dim1 + 2], &c__1, &ab[(
+ j + 1) * ab_dim1 + 1], &kld);
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+L30:
+ *info = j;
+ return 0;
+
+/* End of SPBTF2 */
+
+} /* spbtf2_ */
diff --git a/SRC/spbtrf.c b/SRC/spbtrf.c
new file mode 100644
index 0000000..8f8ccca
--- /dev/null
+++ b/SRC/spbtrf.c
@@ -0,0 +1,469 @@
+/* spbtrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b18 = 1.f;
+static real c_b21 = -1.f;
+static integer c__33 = 33;
+
+/* Subroutine */ int spbtrf_(char *uplo, integer *n, integer *kd, real *ab,
+ integer *ldab, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, i2, i3, ib, nb, ii, jj;
+ real work[1056] /* was [33][32] */;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *), strsm_(char *, char *, char *,
+ char *, integer *, integer *, real *, real *, integer *, real *,
+ integer *), ssyrk_(char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, real *,
+ integer *), spbtf2_(char *, integer *, integer *,
+ real *, integer *, integer *), spotf2_(char *, integer *,
+ real *, integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPBTRF computes the Cholesky factorization of a real symmetric */
+/* positive definite band matrix A. */
+
+/* The factorization has the form */
+/* A = U**T * U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) REAL array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, if INFO = 0, the triangular factor U or L from the */
+/* Cholesky factorization A = U**T*U or A = L*L**T of the band */
+/* matrix A, in the same storage format as A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* N = 6, KD = 2, and UPLO = 'U': */
+
+/* On entry: On exit: */
+
+/* * * a13 a24 a35 a46 * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+
+/* Similarly, if UPLO = 'L' the format of A is as follows: */
+
+/* On entry: On exit: */
+
+/* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */
+/* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */
+/* a31 a42 a53 a64 * * l31 l42 l53 l64 * * */
+
+/* Array elements marked * are not used by the routine. */
+
+/* Contributed by */
+/* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*ldab < *kd + 1) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPBTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment */
+
+ nb = ilaenv_(&c__1, "SPBTRF", uplo, n, kd, &c_n1, &c_n1);
+
+/* The block size must not exceed the semi-bandwidth KD, and must not */
+/* exceed the limit set by the size of the local array WORK. */
+
+ nb = min(nb,32);
+
+ if (nb <= 1 || nb > *kd) {
+
+/* Use unblocked code */
+
+ spbtf2_(uplo, n, kd, &ab[ab_offset], ldab, info);
+ } else {
+
+/* Use blocked code */
+
+ if (lsame_(uplo, "U")) {
+
+/* Compute the Cholesky factorization of a symmetric band */
+/* matrix, given the upper triangle of the matrix in band */
+/* storage. */
+
+/* Zero the upper triangle of the work array. */
+
+ i__1 = nb;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__ + j * 33 - 34] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Process the band matrix one diagonal block at a time. */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - i__ + 1;
+ ib = min(i__3,i__4);
+
+/* Factorize the diagonal block */
+
+ i__3 = *ldab - 1;
+ spotf2_(uplo, &ib, &ab[*kd + 1 + i__ * ab_dim1], &i__3, &ii);
+ if (ii != 0) {
+ *info = i__ + ii - 1;
+ goto L150;
+ }
+ if (i__ + ib <= *n) {
+
+/* Update the relevant part of the trailing submatrix. */
+/* If A11 denotes the diagonal block which has just been */
+/* factorized, then we need to update the remaining */
+/* blocks in the diagram: */
+
+/* A11 A12 A13 */
+/* A22 A23 */
+/* A33 */
+
+/* The numbers of rows and columns in the partitioning */
+/* are IB, I2, I3 respectively. The blocks A12, A22 and */
+/* A23 are empty if IB = KD. The upper triangle of A13 */
+/* lies outside the band. */
+
+/* Computing MIN */
+ i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
+ i2 = min(i__3,i__4);
+/* Computing MIN */
+ i__3 = ib, i__4 = *n - i__ - *kd + 1;
+ i3 = min(i__3,i__4);
+
+ if (i2 > 0) {
+
+/* Update A12 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ strsm_("Left", "Upper", "Transpose", "Non-unit", &ib,
+ &i2, &c_b18, &ab[*kd + 1 + i__ * ab_dim1], &
+ i__3, &ab[*kd + 1 - ib + (i__ + ib) * ab_dim1]
+, &i__4);
+
+/* Update A22 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ ssyrk_("Upper", "Transpose", &i2, &ib, &c_b21, &ab[*
+ kd + 1 - ib + (i__ + ib) * ab_dim1], &i__3, &
+ c_b18, &ab[*kd + 1 + (i__ + ib) * ab_dim1], &
+ i__4);
+ }
+
+ if (i3 > 0) {
+
+/* Copy the lower triangle of A13 into the work array. */
+
+ i__3 = i3;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = ib;
+ for (ii = jj; ii <= i__4; ++ii) {
+ work[ii + jj * 33 - 34] = ab[ii - jj + 1 + (
+ jj + i__ + *kd - 1) * ab_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Update A13 (in the work array). */
+
+ i__3 = *ldab - 1;
+ strsm_("Left", "Upper", "Transpose", "Non-unit", &ib,
+ &i3, &c_b18, &ab[*kd + 1 + i__ * ab_dim1], &
+ i__3, work, &c__33);
+
+/* Update A23 */
+
+ if (i2 > 0) {
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ sgemm_("Transpose", "No Transpose", &i2, &i3, &ib,
+ &c_b21, &ab[*kd + 1 - ib + (i__ + ib) *
+ ab_dim1], &i__3, work, &c__33, &c_b18, &
+ ab[ib + 1 + (i__ + *kd) * ab_dim1], &i__4);
+ }
+
+/* Update A33 */
+
+ i__3 = *ldab - 1;
+ ssyrk_("Upper", "Transpose", &i3, &ib, &c_b21, work, &
+ c__33, &c_b18, &ab[*kd + 1 + (i__ + *kd) *
+ ab_dim1], &i__3);
+
+/* Copy the lower triangle of A13 back into place. */
+
+ i__3 = i3;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = ib;
+ for (ii = jj; ii <= i__4; ++ii) {
+ ab[ii - jj + 1 + (jj + i__ + *kd - 1) *
+ ab_dim1] = work[ii + jj * 33 - 34];
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+ }
+/* L70: */
+ }
+ } else {
+
+/* Compute the Cholesky factorization of a symmetric band */
+/* matrix, given the lower triangle of the matrix in band */
+/* storage. */
+
+/* Zero the lower triangle of the work array. */
+
+ i__2 = nb;
+ for (j = 1; j <= i__2; ++j) {
+ i__1 = nb;
+ for (i__ = j + 1; i__ <= i__1; ++i__) {
+ work[i__ + j * 33 - 34] = 0.f;
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Process the band matrix one diagonal block at a time. */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - i__ + 1;
+ ib = min(i__3,i__4);
+
+/* Factorize the diagonal block */
+
+ i__3 = *ldab - 1;
+ spotf2_(uplo, &ib, &ab[i__ * ab_dim1 + 1], &i__3, &ii);
+ if (ii != 0) {
+ *info = i__ + ii - 1;
+ goto L150;
+ }
+ if (i__ + ib <= *n) {
+
+/* Update the relevant part of the trailing submatrix. */
+/* If A11 denotes the diagonal block which has just been */
+/* factorized, then we need to update the remaining */
+/* blocks in the diagram: */
+
+/* A11 */
+/* A21 A22 */
+/* A31 A32 A33 */
+
+/* The numbers of rows and columns in the partitioning */
+/* are IB, I2, I3 respectively. The blocks A21, A22 and */
+/* A32 are empty if IB = KD. The lower triangle of A31 */
+/* lies outside the band. */
+
+/* Computing MIN */
+ i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
+ i2 = min(i__3,i__4);
+/* Computing MIN */
+ i__3 = ib, i__4 = *n - i__ - *kd + 1;
+ i3 = min(i__3,i__4);
+
+ if (i2 > 0) {
+
+/* Update A21 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ strsm_("Right", "Lower", "Transpose", "Non-unit", &i2,
+ &ib, &c_b18, &ab[i__ * ab_dim1 + 1], &i__3, &
+ ab[ib + 1 + i__ * ab_dim1], &i__4);
+
+/* Update A22 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ ssyrk_("Lower", "No Transpose", &i2, &ib, &c_b21, &ab[
+ ib + 1 + i__ * ab_dim1], &i__3, &c_b18, &ab[(
+ i__ + ib) * ab_dim1 + 1], &i__4);
+ }
+
+ if (i3 > 0) {
+
+/* Copy the upper triangle of A31 into the work array. */
+
+ i__3 = ib;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = min(jj,i3);
+ for (ii = 1; ii <= i__4; ++ii) {
+ work[ii + jj * 33 - 34] = ab[*kd + 1 - jj +
+ ii + (jj + i__ - 1) * ab_dim1];
+/* L100: */
+ }
+/* L110: */
+ }
+
+/* Update A31 (in the work array). */
+
+ i__3 = *ldab - 1;
+ strsm_("Right", "Lower", "Transpose", "Non-unit", &i3,
+ &ib, &c_b18, &ab[i__ * ab_dim1 + 1], &i__3,
+ work, &c__33);
+
+/* Update A32 */
+
+ if (i2 > 0) {
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ sgemm_("No transpose", "Transpose", &i3, &i2, &ib,
+ &c_b21, work, &c__33, &ab[ib + 1 + i__ *
+ ab_dim1], &i__3, &c_b18, &ab[*kd + 1 - ib
+ + (i__ + ib) * ab_dim1], &i__4);
+ }
+
+/* Update A33 */
+
+ i__3 = *ldab - 1;
+ ssyrk_("Lower", "No Transpose", &i3, &ib, &c_b21,
+ work, &c__33, &c_b18, &ab[(i__ + *kd) *
+ ab_dim1 + 1], &i__3);
+
+/* Copy the upper triangle of A31 back into place. */
+
+ i__3 = ib;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = min(jj,i3);
+ for (ii = 1; ii <= i__4; ++ii) {
+ ab[*kd + 1 - jj + ii + (jj + i__ - 1) *
+ ab_dim1] = work[ii + jj * 33 - 34];
+/* L120: */
+ }
+/* L130: */
+ }
+ }
+ }
+/* L140: */
+ }
+ }
+ }
+ return 0;
+
+L150:
+ return 0;
+
+/* End of SPBTRF */
+
+} /* spbtrf_ */
diff --git a/SRC/spbtrs.c b/SRC/spbtrs.c
new file mode 100644
index 0000000..dd15ab8
--- /dev/null
+++ b/SRC/spbtrs.c
@@ -0,0 +1,182 @@
+/* spbtrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int spbtrs_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, real *ab, integer *ldab, real *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ integer j;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int stbsv_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPBTRS solves a system of linear equations A*X = B with a symmetric */
+/* positive definite band matrix A using the Cholesky factorization */
+/* A = U**T*U or A = L*L**T computed by SPBTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular factor stored in AB; */
+/* = 'L': Lower triangular factor stored in AB. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AB (input) REAL array, dimension (LDAB,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T of the band matrix A, stored in the */
+/* first KD+1 rows of the array. The j-th column of U or L is */
+/* stored in the j-th column of the array AB as follows: */
+/* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldab < *kd + 1) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPBTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B where A = U'*U. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve U'*X = B, overwriting B with X. */
+
+ stbsv_("Upper", "Transpose", "Non-unit", n, kd, &ab[ab_offset],
+ ldab, &b[j * b_dim1 + 1], &c__1);
+
+/* Solve U*X = B, overwriting B with X. */
+
+ stbsv_("Upper", "No transpose", "Non-unit", n, kd, &ab[ab_offset],
+ ldab, &b[j * b_dim1 + 1], &c__1);
+/* L10: */
+ }
+ } else {
+
+/* Solve A*X = B where A = L*L'. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve L*X = B, overwriting B with X. */
+
+ stbsv_("Lower", "No transpose", "Non-unit", n, kd, &ab[ab_offset],
+ ldab, &b[j * b_dim1 + 1], &c__1);
+
+/* Solve L'*X = B, overwriting B with X. */
+
+ stbsv_("Lower", "Transpose", "Non-unit", n, kd, &ab[ab_offset],
+ ldab, &b[j * b_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of SPBTRS */
+
+} /* spbtrs_ */
diff --git a/SRC/spftrf.c b/SRC/spftrf.c
new file mode 100644
index 0000000..64a2358
--- /dev/null
+++ b/SRC/spftrf.c
@@ -0,0 +1,451 @@
+/* spftrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b12 = 1.f;
+static real c_b15 = -1.f;
+
+/* Subroutine */ int spftrf_(char *transr, char *uplo, integer *n, real *a,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer k, n1, n2;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), ssyrk_(char *, char *, integer
+ *, integer *, real *, real *, integer *, real *, real *, integer *
+), xerbla_(char *, integer *);
+ logical nisodd;
+ extern /* Subroutine */ int spotrf_(char *, integer *, real *, integer *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPFTRF computes the Cholesky factorization of a real symmetric */
+/* positive definite matrix A. */
+
+/* The factorization has the form */
+/* A = U**T * U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* This is the block version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': The Normal TRANSR of RFP A is stored; */
+/* = 'T': The Transpose TRANSR of RFP A is stored. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': Upper triangle of RFP A is stored; */
+/* = 'L': Lower triangle of RFP A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension ( N*(N+1)/2 ); */
+/* On entry, the symmetric matrix A in RFP format. RFP format is */
+/* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' */
+/* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */
+/* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is */
+/* the transpose of RFP A as defined when */
+/* TRANSR = 'N'. The contents of RFP A are defined by UPLO as */
+/* follows: If UPLO = 'U' the RFP A contains the NT elements of */
+/* upper packed A. If UPLO = 'L' the RFP A contains the elements */
+/* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = */
+/* 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N */
+/* is odd. See the Note below for more details. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization RFP A = U**T*U or RFP A = L*L**T. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* Notes */
+/* ===== */
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* even. We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* the transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* the transpose of the last three columns of AP lower. */
+/* This covers the case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 03 04 05 33 43 53 */
+/* 13 14 15 00 44 54 */
+/* 23 24 25 10 11 55 */
+/* 33 34 35 20 21 22 */
+/* 00 44 45 30 31 32 */
+/* 01 11 55 40 41 42 */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* odd. We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* the transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* the transpose of the last two columns of AP lower. */
+/* This covers the case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 02 03 04 00 33 43 */
+/* 12 13 14 10 11 44 */
+/* 22 23 24 20 21 22 */
+/* 00 33 34 30 31 32 */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+/* RFP A RFP A */
+
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "T")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPFTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* If N is odd, set NISODD = .TRUE. */
+/* If N is even, set K = N/2 and NISODD = .FALSE. */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ } else {
+ nisodd = TRUE_;
+ }
+
+/* Set N1 and N2 depending on LOWER */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* start execution: there are eight cases */
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */
+/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */
+/* T1 -> a(0), T2 -> a(n), S -> a(n1) */
+
+ spotrf_("L", &n1, a, n, info);
+ if (*info > 0) {
+ return 0;
+ }
+ strsm_("R", "L", "T", "N", &n2, &n1, &c_b12, a, n, &a[n1], n);
+ ssyrk_("U", "N", &n2, &n1, &c_b15, &a[n1], n, &c_b12, &a[*n],
+ n);
+ spotrf_("U", &n2, &a[*n], n, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */
+/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */
+/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */
+
+ spotrf_("L", &n1, &a[n2], n, info);
+ if (*info > 0) {
+ return 0;
+ }
+ strsm_("L", "L", "N", "N", &n1, &n2, &c_b12, &a[n2], n, a, n);
+ ssyrk_("U", "T", &n2, &n1, &c_b15, a, n, &c_b12, &a[n1], n);
+ spotrf_("U", &n2, &a[n1], n, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is odd */
+/* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */
+/* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 */
+
+ spotrf_("U", &n1, a, &n1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ strsm_("L", "U", "T", "N", &n1, &n2, &c_b12, a, &n1, &a[n1 *
+ n1], &n1);
+ ssyrk_("L", "T", &n2, &n1, &c_b15, &a[n1 * n1], &n1, &c_b12, &
+ a[1], &n1);
+ spotrf_("L", &n2, &a[1], &n1, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is odd */
+/* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */
+/* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 */
+
+ spotrf_("U", &n1, &a[n2 * n2], &n2, info);
+ if (*info > 0) {
+ return 0;
+ }
+ strsm_("R", "U", "N", "N", &n2, &n1, &c_b12, &a[n2 * n2], &n2,
+ a, &n2);
+ ssyrk_("L", "N", &n2, &n1, &c_b15, a, &n2, &c_b12, &a[n1 * n2]
+, &n2);
+ spotrf_("L", &n2, &a[n1 * n2], &n2, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
+/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */
+
+ i__1 = *n + 1;
+ spotrf_("L", &k, &a[1], &i__1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ strsm_("R", "L", "T", "N", &k, &k, &c_b12, &a[1], &i__1, &a[k
+ + 1], &i__2);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ ssyrk_("U", "N", &k, &k, &c_b15, &a[k + 1], &i__1, &c_b12, a,
+ &i__2);
+ i__1 = *n + 1;
+ spotrf_("U", &k, a, &i__1, info);
+ if (*info > 0) {
+ *info += k;
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
+/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */
+
+ i__1 = *n + 1;
+ spotrf_("L", &k, &a[k + 1], &i__1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ strsm_("L", "L", "N", "N", &k, &k, &c_b12, &a[k + 1], &i__1,
+ a, &i__2);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ ssyrk_("U", "T", &k, &k, &c_b15, a, &i__1, &c_b12, &a[k], &
+ i__2);
+ i__1 = *n + 1;
+ spotrf_("U", &k, &a[k], &i__1, info);
+ if (*info > 0) {
+ *info += k;
+ }
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */
+/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */
+
+ spotrf_("U", &k, &a[k], &k, info);
+ if (*info > 0) {
+ return 0;
+ }
+ strsm_("L", "U", "T", "N", &k, &k, &c_b12, &a[k], &n1, &a[k *
+ (k + 1)], &k);
+ ssyrk_("L", "T", &k, &k, &c_b15, &a[k * (k + 1)], &k, &c_b12,
+ a, &k);
+ spotrf_("L", &k, a, &k, info);
+ if (*info > 0) {
+ *info += k;
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */
+/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */
+
+ spotrf_("U", &k, &a[k * (k + 1)], &k, info);
+ if (*info > 0) {
+ return 0;
+ }
+ strsm_("R", "U", "N", "N", &k, &k, &c_b12, &a[k * (k + 1)], &
+ k, a, &k);
+ ssyrk_("L", "N", &k, &k, &c_b15, a, &k, &c_b12, &a[k * k], &k);
+ spotrf_("L", &k, &a[k * k], &k, info);
+ if (*info > 0) {
+ *info += k;
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of SPFTRF */
+
+} /* spftrf_ */
diff --git a/SRC/spftri.c b/SRC/spftri.c
new file mode 100644
index 0000000..fde795a
--- /dev/null
+++ b/SRC/spftri.c
@@ -0,0 +1,402 @@
+/* spftri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b11 = 1.f;
+
+/* Subroutine */ int spftri_(char *transr, char *uplo, integer *n, real *a,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer k, n1, n2;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int strmm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), ssyrk_(char *, char *, integer
+ *, integer *, real *, real *, integer *, real *, real *, integer *
+), xerbla_(char *, integer *);
+ logical nisodd;
+ extern /* Subroutine */ int slauum_(char *, integer *, real *, integer *,
+ integer *), stftri_(char *, char *, char *, integer *,
+ real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPFTRI computes the inverse of a real (symmetric) positive definite */
+/* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T */
+/* computed by SPFTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': The Normal TRANSR of RFP A is stored; */
+/* = 'T': The Transpose TRANSR of RFP A is stored. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension ( N*(N+1)/2 ) */
+/* On entry, the symmetric matrix A in RFP format. RFP format is */
+/* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' */
+/* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */
+/* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is */
+/* the transpose of RFP A as defined when */
+/* TRANSR = 'N'. The contents of RFP A are defined by UPLO as */
+/* follows: If UPLO = 'U' the RFP A contains the nt elements of */
+/* upper packed A. If UPLO = 'L' the RFP A contains the elements */
+/* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = */
+/* 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N */
+/* is odd. See the Note below for more details. */
+
+/* On exit, the symmetric inverse of the original matrix, in the */
+/* same storage format. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the (i,i) element of the factor U or L is */
+/* zero, and the inverse could not be computed. */
+
+/* Notes */
+/* ===== */
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* even. We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* the transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* the transpose of the last three columns of AP lower. */
+/* This covers the case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 03 04 05 33 43 53 */
+/* 13 14 15 00 44 54 */
+/* 23 24 25 10 11 55 */
+/* 33 34 35 20 21 22 */
+/* 00 44 45 30 31 32 */
+/* 01 11 55 40 41 42 */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* odd. We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* the transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* the transpose of the last two columns of AP lower. */
+/* This covers the case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 02 03 04 00 33 43 */
+/* 12 13 14 10 11 44 */
+/* 22 23 24 20 21 22 */
+/* 00 33 34 30 31 32 */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+/* RFP A RFP A */
+
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "T")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPFTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Invert the triangular Cholesky factor U or L. */
+
+ stftri_(transr, uplo, "N", n, a, info);
+ if (*info > 0) {
+ return 0;
+ }
+
+/* If N is odd, set NISODD = .TRUE. */
+/* If N is even, set K = N/2 and NISODD = .FALSE. */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ } else {
+ nisodd = TRUE_;
+ }
+
+/* Set N1 and N2 depending on LOWER */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* Start execution of triangular matrix multiply: inv(U)*inv(U)^C or */
+/* inv(L)^C*inv(L). There are eight cases. */
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:N1-1) ) */
+/* T1 -> a(0,0), T2 -> a(0,1), S -> a(N1,0) */
+/* T1 -> a(0), T2 -> a(n), S -> a(N1) */
+
+ slauum_("L", &n1, a, n, info);
+ ssyrk_("L", "T", &n1, &n2, &c_b11, &a[n1], n, &c_b11, a, n);
+ strmm_("L", "U", "N", "N", &n2, &n1, &c_b11, &a[*n], n, &a[n1]
+, n);
+ slauum_("U", &n2, &a[*n], n, info);
+
+ } else {
+
+/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:N2-1) */
+/* T1 -> a(N1+1,0), T2 -> a(N1,0), S -> a(0,0) */
+/* T1 -> a(N2), T2 -> a(N1), S -> a(0) */
+
+ slauum_("L", &n1, &a[n2], n, info);
+ ssyrk_("L", "N", &n1, &n2, &c_b11, a, n, &c_b11, &a[n2], n);
+ strmm_("R", "U", "T", "N", &n1, &n2, &c_b11, &a[n1], n, a, n);
+ slauum_("U", &n2, &a[n1], n, info);
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE, and N is odd */
+/* T1 -> a(0), T2 -> a(1), S -> a(0+N1*N1) */
+
+ slauum_("U", &n1, a, &n1, info);
+ ssyrk_("U", "N", &n1, &n2, &c_b11, &a[n1 * n1], &n1, &c_b11,
+ a, &n1);
+ strmm_("R", "L", "N", "N", &n1, &n2, &c_b11, &a[1], &n1, &a[
+ n1 * n1], &n1);
+ slauum_("L", &n2, &a[1], &n1, info);
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE, and N is odd */
+/* T1 -> a(0+N2*N2), T2 -> a(0+N1*N2), S -> a(0) */
+
+ slauum_("U", &n1, &a[n2 * n2], &n2, info);
+ ssyrk_("U", "T", &n1, &n2, &c_b11, a, &n2, &c_b11, &a[n2 * n2]
+, &n2);
+ strmm_("L", "L", "T", "N", &n2, &n1, &c_b11, &a[n1 * n2], &n2,
+ a, &n2);
+ slauum_("L", &n2, &a[n1 * n2], &n2, info);
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
+/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */
+
+ i__1 = *n + 1;
+ slauum_("L", &k, &a[1], &i__1, info);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ ssyrk_("L", "T", &k, &k, &c_b11, &a[k + 1], &i__1, &c_b11, &a[
+ 1], &i__2);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ strmm_("L", "U", "N", "N", &k, &k, &c_b11, a, &i__1, &a[k + 1]
+, &i__2);
+ i__1 = *n + 1;
+ slauum_("U", &k, a, &i__1, info);
+
+ } else {
+
+/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
+/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */
+
+ i__1 = *n + 1;
+ slauum_("L", &k, &a[k + 1], &i__1, info);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ ssyrk_("L", "N", &k, &k, &c_b11, a, &i__1, &c_b11, &a[k + 1],
+ &i__2);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ strmm_("R", "U", "T", "N", &k, &k, &c_b11, &a[k], &i__1, a, &
+ i__2);
+ i__1 = *n + 1;
+ slauum_("U", &k, &a[k], &i__1, info);
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE, and N is even (see paper) */
+/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1), */
+/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */
+
+ slauum_("U", &k, &a[k], &k, info);
+ ssyrk_("U", "N", &k, &k, &c_b11, &a[k * (k + 1)], &k, &c_b11,
+ &a[k], &k);
+ strmm_("R", "L", "N", "N", &k, &k, &c_b11, a, &k, &a[k * (k +
+ 1)], &k);
+ slauum_("L", &k, a, &k, info);
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE, and N is even (see paper) */
+/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0), */
+/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */
+
+ slauum_("U", &k, &a[k * (k + 1)], &k, info);
+ ssyrk_("U", "T", &k, &k, &c_b11, a, &k, &c_b11, &a[k * (k + 1)
+ ], &k);
+ strmm_("L", "L", "T", "N", &k, &k, &c_b11, &a[k * k], &k, a, &
+ k);
+ slauum_("L", &k, &a[k * k], &k, info);
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of SPFTRI */
+
+} /* spftri_ */
diff --git a/SRC/spftrs.c b/SRC/spftrs.c
new file mode 100644
index 0000000..d8b3f6a
--- /dev/null
+++ b/SRC/spftrs.c
@@ -0,0 +1,238 @@
+/* spftrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b10 = 1.f;
+
+/* Subroutine */ int spftrs_(char *transr, char *uplo, integer *n, integer *
+ nrhs, real *a, real *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int stfsm_(char *, char *, char *, char *, char *,
+ integer *, integer *, real *, real *, real *, integer *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPFTRS solves a system of linear equations A*X = B with a symmetric */
+/* positive definite matrix A using the Cholesky factorization */
+/* A = U**T*U or A = L*L**T computed by SPFTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': The Normal TRANSR of RFP A is stored; */
+/* = 'T': The Transpose TRANSR of RFP A is stored. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': Upper triangle of RFP A is stored; */
+/* = 'L': Lower triangle of RFP A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input) REAL array, dimension ( N*(N+1)/2 ) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* of RFP A = U**H*U or RFP A = L*L**T, as computed by SPFTRF. */
+/* See note below for more details about RFP A. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Notes */
+/* ===== */
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* even. We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* the transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* the transpose of the last three columns of AP lower. */
+/* This covers the case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 03 04 05 33 43 53 */
+/* 13 14 15 00 44 54 */
+/* 23 24 25 10 11 55 */
+/* 33 34 35 20 21 22 */
+/* 00 44 45 30 31 32 */
+/* 01 11 55 40 41 42 */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* odd. We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* the transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* the transpose of the last two columns of AP lower. */
+/* This covers the case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 02 03 04 00 33 43 */
+/* 12 13 14 10 11 44 */
+/* 22 23 24 20 21 22 */
+/* 00 33 34 30 31 32 */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+/* RFP A RFP A */
+
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "T")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPFTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+/* start execution: there are two triangular solves */
+
+ if (lower) {
+ stfsm_(transr, "L", uplo, "N", "N", n, nrhs, &c_b10, a, &b[b_offset],
+ ldb);
+ stfsm_(transr, "L", uplo, "T", "N", n, nrhs, &c_b10, a, &b[b_offset],
+ ldb);
+ } else {
+ stfsm_(transr, "L", uplo, "T", "N", n, nrhs, &c_b10, a, &b[b_offset],
+ ldb);
+ stfsm_(transr, "L", uplo, "N", "N", n, nrhs, &c_b10, a, &b[b_offset],
+ ldb);
+ }
+
+ return 0;
+
+/* End of SPFTRS */
+
+} /* spftrs_ */
diff --git a/SRC/spocon.c b/SRC/spocon.c
new file mode 100644
index 0000000..6d1804d
--- /dev/null
+++ b/SRC/spocon.c
@@ -0,0 +1,217 @@
+/* spocon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int spocon_(char *uplo, integer *n, real *a, integer *lda,
+ real *anorm, real *rcond, real *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ real r__1;
+
+ /* Local variables */
+ integer ix, kase;
+ real scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *);
+ logical upper;
+ extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *,
+ real *, integer *, integer *);
+ real scalel;
+ extern doublereal slamch_(char *);
+ real scaleu;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ real ainvnm;
+ char normin[1];
+ extern /* Subroutine */ int slatrs_(char *, char *, char *, char *,
+ integer *, real *, integer *, real *, real *, real *, integer *);
+ real smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPOCON estimates the reciprocal of the condition number (in the */
+/* 1-norm) of a real symmetric positive definite matrix using the */
+/* Cholesky factorization A = U**T*U or A = L*L**T computed by SPOTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by SPOTRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* ANORM (input) REAL */
+/* The 1-norm (or infinity-norm) of the symmetric matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*anorm < 0.f) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPOCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.f;
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ } else if (*anorm == 0.f) {
+ return 0;
+ }
+
+ smlnum = slamch_("Safe minimum");
+
+/* Estimate the 1-norm of inv(A). */
+
+ kase = 0;
+ *(unsigned char *)normin = 'N';
+L10:
+ slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (upper) {
+
+/* Multiply by inv(U'). */
+
+ slatrs_("Upper", "Transpose", "Non-unit", normin, n, &a[a_offset],
+ lda, &work[1], &scalel, &work[(*n << 1) + 1], info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(U). */
+
+ slatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[
+ a_offset], lda, &work[1], &scaleu, &work[(*n << 1) + 1],
+ info);
+ } else {
+
+/* Multiply by inv(L). */
+
+ slatrs_("Lower", "No transpose", "Non-unit", normin, n, &a[
+ a_offset], lda, &work[1], &scalel, &work[(*n << 1) + 1],
+ info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(L'). */
+
+ slatrs_("Lower", "Transpose", "Non-unit", normin, n, &a[a_offset],
+ lda, &work[1], &scaleu, &work[(*n << 1) + 1], info);
+ }
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ scale = scalel * scaleu;
+ if (scale != 1.f) {
+ ix = isamax_(n, &work[1], &c__1);
+ if (scale < (r__1 = work[ix], dabs(r__1)) * smlnum || scale ==
+ 0.f) {
+ goto L20;
+ }
+ srscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / ainvnm / *anorm;
+ }
+
+L20:
+ return 0;
+
+/* End of SPOCON */
+
+} /* spocon_ */
diff --git a/SRC/spoequ.c b/SRC/spoequ.c
new file mode 100644
index 0000000..9b23897
--- /dev/null
+++ b/SRC/spoequ.c
@@ -0,0 +1,174 @@
+/* spoequ.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int spoequ_(integer *n, real *a, integer *lda, real *s, real
+ *scond, real *amax, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real smin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPOEQU computes row and column scalings intended to equilibrate a */
+/* symmetric positive definite matrix A and reduce its condition number */
+/* (with respect to the two-norm). S contains the scale factors, */
+/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
+/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
+/* choice of S puts the condition number of B within a factor N of the */
+/* smallest possible condition number over all possible diagonal */
+/* scalings. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The N-by-N symmetric positive definite matrix whose scaling */
+/* factors are to be computed. Only the diagonal elements of A */
+/* are referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* S (output) REAL array, dimension (N) */
+/* If INFO = 0, S contains the scale factors for A. */
+
+/* SCOND (output) REAL */
+/* If INFO = 0, S contains the ratio of the smallest S(i) to */
+/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
+/* large nor too small, it is not worth scaling by S. */
+
+/* AMAX (output) REAL */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*lda < max(1,*n)) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPOEQU", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *scond = 1.f;
+ *amax = 0.f;
+ return 0;
+ }
+
+/* Find the minimum and maximum diagonal elements. */
+
+ s[1] = a[a_dim1 + 1];
+ smin = s[1];
+ *amax = s[1];
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ s[i__] = a[i__ + i__ * a_dim1];
+/* Computing MIN */
+ r__1 = smin, r__2 = s[i__];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = *amax, r__2 = s[i__];
+ *amax = dmax(r__1,r__2);
+/* L10: */
+ }
+
+ if (smin <= 0.f) {
+
+/* Find the first non-positive diagonal element and return. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] <= 0.f) {
+ *info = i__;
+ return 0;
+ }
+/* L20: */
+ }
+ } else {
+
+/* Set the scale factors to the reciprocals */
+/* of the diagonal elements. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s[i__] = 1.f / sqrt(s[i__]);
+/* L30: */
+ }
+
+/* Compute SCOND = min(S(I)) / max(S(I)) */
+
+ *scond = sqrt(smin) / sqrt(*amax);
+ }
+ return 0;
+
+/* End of SPOEQU */
+
+} /* spoequ_ */
diff --git a/SRC/spoequb.c b/SRC/spoequb.c
new file mode 100644
index 0000000..cd6865a
--- /dev/null
+++ b/SRC/spoequb.c
@@ -0,0 +1,188 @@
+/* spoequb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int spoequb_(integer *n, real *a, integer *lda, real *s,
+ real *scond, real *amax, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double log(doublereal), pow_ri(real *, integer *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real tmp, base, smin;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPOEQU computes row and column scalings intended to equilibrate a */
+/* symmetric positive definite matrix A and reduce its condition number */
+/* (with respect to the two-norm). S contains the scale factors, */
+/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
+/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
+/* choice of S puts the condition number of B within a factor N of the */
+/* smallest possible condition number over all possible diagonal */
+/* scalings. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The N-by-N symmetric positive definite matrix whose scaling */
+/* factors are to be computed. Only the diagonal elements of A */
+/* are referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* S (output) REAL array, dimension (N) */
+/* If INFO = 0, S contains the scale factors for A. */
+
+/* SCOND (output) REAL */
+/* If INFO = 0, S contains the ratio of the smallest S(i) to */
+/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
+/* large nor too small, it is not worth scaling by S. */
+
+/* AMAX (output) REAL */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+/* Positive definite only performs 1 pass of equilibration. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*lda < max(1,*n)) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPOEQUB", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ *scond = 1.f;
+ *amax = 0.f;
+ return 0;
+ }
+ base = slamch_("B");
+ tmp = -.5f / log(base);
+
+/* Find the minimum and maximum diagonal elements. */
+
+ s[1] = a[a_dim1 + 1];
+ smin = s[1];
+ *amax = s[1];
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ s[i__] = a[i__ + i__ * a_dim1];
+/* Computing MIN */
+ r__1 = smin, r__2 = s[i__];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = *amax, r__2 = s[i__];
+ *amax = dmax(r__1,r__2);
+/* L10: */
+ }
+
+ if (smin <= 0.f) {
+
+/* Find the first non-positive diagonal element and return. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] <= 0.f) {
+ *info = i__;
+ return 0;
+ }
+/* L20: */
+ }
+ } else {
+
+/* Set the scale factors to the reciprocals */
+/* of the diagonal elements. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = (integer) (tmp * log(s[i__]));
+ s[i__] = pow_ri(&base, &i__2);
+/* L30: */
+ }
+
+/* Compute SCOND = min(S(I)) / max(S(I)). */
+
+ *scond = sqrt(smin) / sqrt(*amax);
+ }
+
+ return 0;
+
+/* End of SPOEQUB */
+
+} /* spoequb_ */
diff --git a/SRC/sporfs.c b/SRC/sporfs.c
new file mode 100644
index 0000000..d0ef95e
--- /dev/null
+++ b/SRC/sporfs.c
@@ -0,0 +1,421 @@
+/* sporfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b12 = -1.f;
+static real c_b14 = 1.f;
+
+/* Subroutine */ int sporfs_(char *uplo, integer *n, integer *nrhs, real *a,
+ integer *lda, real *af, integer *ldaf, real *b, integer *ldb, real *x,
+ integer *ldx, real *ferr, real *berr, real *work, integer *iwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2, i__3;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ real s, xk;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3], count;
+ logical upper;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), saxpy_(integer *, real *, real *, integer *, real *,
+ integer *), ssymv_(char *, integer *, real *, real *, integer *,
+ real *, integer *, real *, real *, integer *), slacn2_(
+ integer *, real *, real *, integer *, real *, integer *, integer *
+);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real lstres;
+ extern /* Subroutine */ int spotrs_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPORFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric positive definite, */
+/* and provides error bounds and backward error estimates for the */
+/* solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular part */
+/* of the matrix A, and the strictly lower triangular part of A */
+/* is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of A contains the lower triangular part of */
+/* the matrix A, and the strictly upper triangular part of A is */
+/* not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) REAL array, dimension (LDAF,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by SPOTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) REAL array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by SPOTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPORFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.f;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ scopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+ ssymv_(uplo, n, &c_b12, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1,
+ &c_b14, &work[*n + 1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] = (r__1 = b[i__ + j * b_dim1], dabs(r__1));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ work[i__] += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) *
+ xk;
+ s += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * (r__2 = x[
+ i__ + j * x_dim1], dabs(r__2));
+/* L40: */
+ }
+ work[k] = work[k] + (r__1 = a[k + k * a_dim1], dabs(r__1)) *
+ xk + s;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+ work[k] += (r__1 = a[k + k * a_dim1], dabs(r__1)) * xk;
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ work[i__] += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) *
+ xk;
+ s += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * (r__2 = x[
+ i__ + j * x_dim1], dabs(r__2));
+/* L60: */
+ }
+ work[k] += s;
+/* L70: */
+ }
+ }
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[
+ i__];
+ s = dmax(r__2,r__3);
+ } else {
+/* Computing MAX */
+ r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1)
+ / (work[i__] + safe1);
+ s = dmax(r__2,r__3);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ spotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[*n + 1], n,
+ info);
+ saxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
+ ;
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use SLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ slacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+ kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ spotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[*n + 1],
+ n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L120: */
+ }
+ spotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[*n + 1],
+ n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], dabs(r__1));
+ lstres = dmax(r__2,r__3);
+/* L130: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of SPORFS */
+
+} /* sporfs_ */
diff --git a/SRC/sporfsx.c b/SRC/sporfsx.c
new file mode 100644
index 0000000..ac4ccec
--- /dev/null
+++ b/SRC/sporfsx.c
@@ -0,0 +1,619 @@
+/* sporfsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int sporfsx_(char *uplo, char *equed, integer *n, integer *
+ nrhs, real *a, integer *lda, real *af, integer *ldaf, real *s, real *
+ b, integer *ldb, real *x, integer *ldx, real *rcond, real *berr,
+ integer *n_err_bnds__, real *err_bnds_norm__, real *err_bnds_comp__,
+ integer *nparams, real *params, real *work, integer *iwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real illrcond_thresh__, unstable_thresh__, err_lbnd__;
+ integer ref_type__, j;
+ real rcond_tmp__;
+ integer prec_type__;
+ extern doublereal sla_porcond__(char *, integer *, real *, integer *,
+ real *, integer *, integer *, real *, integer *, real *, integer *
+ , ftnlen);
+ real cwise_wrong__;
+ extern /* Subroutine */ int sla_porfsx_extended__(integer *, char *,
+ integer *, integer *, real *, integer *, real *, integer *,
+ logical *, real *, real *, integer *, real *, integer *, real *,
+ integer *, real *, real *, real *, real *, real *, real *, real *,
+ integer *, real *, real *, logical *, integer *, ftnlen);
+ char norm[1];
+ logical ignore_cwise__;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ logical rcequ;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), spocon_(
+ char *, integer *, real *, integer *, real *, real *, real *,
+ integer *, integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+ extern integer ilaprec_(char *);
+ integer ithresh, n_norms__;
+ real rthresh;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPORFSX improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric positive */
+/* definite, and provides error bounds and backward error estimates */
+/* for the solution. In addition to normwise error bound, the code */
+/* provides maximum componentwise error bound if possible. See */
+/* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the */
+/* error bounds. */
+
+/* The original system of linear equations may have been equilibrated */
+/* before calling this routine, as described by arguments EQUED and S */
+/* below. In this case, the solution and error bounds returned are */
+/* for the original unequilibrated system. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* EQUED (input) CHARACTER*1 */
+/* Specifies the form of equilibration that was done to A */
+/* before calling this routine. This is needed to compute */
+/* the solution and error bounds correctly. */
+/* = 'N': No equilibration */
+/* = 'Y': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(S) * A * diag(S). */
+/* The right hand side B has been changed accordingly. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular part */
+/* of the matrix A, and the strictly lower triangular part of A */
+/* is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of A contains the lower triangular part of */
+/* the matrix A, and the strictly upper triangular part of A is */
+/* not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) REAL array, dimension (LDAF,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by SPOTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* S (input or output) REAL array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'Y', A is multiplied on */
+/* the left and right by diag(S). S is an input argument if FACT = */
+/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
+/* = 'Y', each element of S must be positive. If S is output, each */
+/* element of S is a power of the radix. If S is input, each element */
+/* of S should be a power of the radix to ensure a reliable solution */
+/* and error estimates. Scaling by powers of the radix does not cause */
+/* rounding errors unless the result underflows or overflows. */
+/* Rounding errors during scaling lead to refining with a matrix that */
+/* is not equivalent to the input matrix, producing error estimates */
+/* that may not be reliable. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) REAL array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by SGETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) REAL array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) REAL array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check the input parameters. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ ref_type__ = 1;
+ if (*nparams >= 1) {
+ if (params[1] < 0.f) {
+ params[1] = 1.f;
+ } else {
+ ref_type__ = params[1];
+ }
+ }
+
+/* Set default parameters. */
+
+ illrcond_thresh__ = (real) (*n) * slamch_("Epsilon");
+ ithresh = 10;
+ rthresh = .5f;
+ unstable_thresh__ = .25f;
+ ignore_cwise__ = FALSE_;
+
+ if (*nparams >= 2) {
+ if (params[2] < 0.f) {
+ params[2] = (real) ithresh;
+ } else {
+ ithresh = (integer) params[2];
+ }
+ }
+ if (*nparams >= 3) {
+ if (params[3] < 0.f) {
+ if (ignore_cwise__) {
+ params[3] = 0.f;
+ } else {
+ params[3] = 1.f;
+ }
+ } else {
+ ignore_cwise__ = params[3] == 0.f;
+ }
+ }
+ if (ref_type__ == 0 || *n_err_bnds__ == 0) {
+ n_norms__ = 0;
+ } else if (ignore_cwise__) {
+ n_norms__ = 1;
+ } else {
+ n_norms__ = 2;
+ }
+
+ rcequ = lsame_(equed, "Y");
+
+/* Test input parameters. */
+
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! rcequ && ! lsame_(equed, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -11;
+ } else if (*ldx < max(1,*n)) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPORFSX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *nrhs == 0) {
+ *rcond = 1.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 0.f;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.f;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.f;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.f;
+ }
+ }
+ return 0;
+ }
+
+/* Default to failure. */
+
+ *rcond = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 1.f;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.f;
+ }
+ }
+
+/* Compute the norm of A and the reciprocal of the condition */
+/* number of A. */
+
+ *(unsigned char *)norm = 'I';
+ anorm = slansy_(norm, uplo, n, &a[a_offset], lda, &work[1]);
+ spocon_(uplo, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &iwork[1],
+ info);
+
+/* Perform refinement on each right-hand side */
+
+ if (ref_type__ != 0) {
+ prec_type__ = ilaprec_("D");
+ sla_porfsx_extended__(&prec_type__, uplo, n, nrhs, &a[a_offset], lda,
+ &af[af_offset], ldaf, &rcequ, &s[1], &b[b_offset], ldb, &x[
+ x_offset], ldx, &berr[1], &n_norms__, &err_bnds_norm__[
+ err_bnds_norm_offset], &err_bnds_comp__[err_bnds_comp_offset],
+ &work[*n + 1], &work[1], &work[(*n << 1) + 1], &work[1],
+ rcond, &ithresh, &rthresh, &unstable_thresh__, &
+ ignore_cwise__, info, (ftnlen)1);
+ }
+/* Computing MAX */
+ r__1 = 10.f, r__2 = sqrt((real) (*n));
+ err_lbnd__ = dmax(r__1,r__2) * slamch_("Epsilon");
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {
+
+/* Compute scaled normwise condition number cond(A*C). */
+
+ if (rcequ) {
+ rcond_tmp__ = sla_porcond__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &c_n1, &s[1], info, &work[1], &iwork[1],
+ (ftnlen)1);
+ } else {
+ rcond_tmp__ = sla_porcond__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &c__0, &s[1], info, &work[1], &iwork[1],
+ (ftnlen)1);
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1
+ << 1)] > 1.f) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 0.f;
+ if (*info <= *n) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {
+
+/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
+/* each right-hand side using the current solution as an estimate of */
+/* the true solution. If the componentwise error estimate is too */
+/* large, then the solution is a lousy estimate of truth and the */
+/* estimated RCOND may be too optimistic. To avoid misleading users, */
+/* the inverse condition number is set to 0.0 when the estimated */
+/* cwise error is at least CWISE_WRONG. */
+
+ cwise_wrong__ = sqrt(slamch_("Epsilon"));
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ cwise_wrong__) {
+ rcond_tmp__ = sla_porcond__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &c__1, &x[j * x_dim1 + 1], info, &
+ work[1], &iwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = 0.f;
+ }
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1
+ << 1)] > 1.f) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 0.f;
+ if (params[3] == 1.f && *info < *n + j) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SPORFSX */
+
+} /* sporfsx_ */
diff --git a/SRC/sposv.c b/SRC/sposv.c
new file mode 100644
index 0000000..02d37ee
--- /dev/null
+++ b/SRC/sposv.c
@@ -0,0 +1,151 @@
+/* sposv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sposv_(char *uplo, integer *n, integer *nrhs, real *a,
+ integer *lda, real *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), spotrf_(
+ char *, integer *, real *, integer *, integer *), spotrs_(
+ char *, integer *, integer *, real *, integer *, real *, integer *
+, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPOSV computes the solution to a real system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N symmetric positive definite matrix and X and B */
+/* are N-by-NRHS matrices. */
+
+/* The Cholesky decomposition is used to factor A as */
+/* A = U**T* U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is a lower triangular */
+/* matrix. The factored form of A is then used to solve the system of */
+/* equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i of A is not */
+/* positive definite, so the factorization could not be */
+/* completed, and the solution has not been computed. */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPOSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ spotrf_(uplo, n, &a[a_offset], lda, info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ spotrs_(uplo, n, nrhs, &a[a_offset], lda, &b[b_offset], ldb, info);
+
+ }
+ return 0;
+
+/* End of SPOSV */
+
+} /* sposv_ */
diff --git a/SRC/sposvx.c b/SRC/sposvx.c
new file mode 100644
index 0000000..16ca811
--- /dev/null
+++ b/SRC/sposvx.c
@@ -0,0 +1,446 @@
+/* sposvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sposvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, real *a, integer *lda, real *af, integer *ldaf, char *equed,
+ real *s, real *b, integer *ldb, real *x, integer *ldx, real *rcond,
+ real *ferr, real *berr, real *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer i__, j;
+ real amax, smin, smax;
+ extern logical lsame_(char *, char *);
+ real scond, anorm;
+ logical equil, rcequ;
+ extern doublereal slamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ integer infequ;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), spocon_(char *, integer *,
+ real *, integer *, real *, real *, real *, integer *, integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+ real smlnum;
+ extern /* Subroutine */ int slaqsy_(char *, integer *, real *, integer *,
+ real *, real *, real *, char *), spoequ_(integer *
+, real *, integer *, real *, real *, real *, integer *), sporfs_(
+ char *, integer *, integer *, real *, integer *, real *, integer *
+, real *, integer *, real *, integer *, real *, real *, real *,
+ integer *, integer *), spotrf_(char *, integer *, real *,
+ integer *, integer *), spotrs_(char *, integer *, integer
+ *, real *, integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to */
+/* compute the solution to a real system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N symmetric positive definite matrix and X and B */
+/* are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+/* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
+
+/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */
+/* factor the matrix A (after equilibration if FACT = 'E') as */
+/* A = U**T* U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is a lower triangular */
+/* matrix. */
+
+/* 3. If the leading i-by-i principal minor is not positive definite, */
+/* then the routine returns with INFO = i. Otherwise, the factored */
+/* form of A is used to estimate the condition number of the matrix */
+/* A. If the reciprocal of the condition number is less than machine */
+/* precision, INFO = N+1 is returned as a warning, but the routine */
+/* still goes on to solve for X and compute error bounds as */
+/* described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(S) so that it solves the original system before */
+/* equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF contains the factored form of A. */
+/* If EQUED = 'Y', the matrix A has been equilibrated */
+/* with scaling factors given by S. A and AF will not */
+/* be modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A, except if FACT = 'F' and */
+/* EQUED = 'Y', then A must contain the equilibrated matrix */
+/* diag(S)*A*diag(S). If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. A is not modified if */
+/* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
+
+/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
+/* diag(S)*A*diag(S). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) REAL array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T, in the same storage */
+/* format as A. If EQUED .ne. 'N', then AF is the factored form */
+/* of the equilibrated matrix diag(S)*A*diag(S). */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T of the original */
+/* matrix A. */
+
+/* If FACT = 'E', then AF is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T of the equilibrated */
+/* matrix A (see the description of A for the form of the */
+/* equilibrated matrix). */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* S (input or output) REAL array, dimension (N) */
+/* The scale factors for A; not accessed if EQUED = 'N'. S is */
+/* an input argument if FACT = 'F'; otherwise, S is an output */
+/* argument. If FACT = 'F' and EQUED = 'Y', each element of S */
+/* must be positive. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */
+/* B is overwritten by diag(S) * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) REAL array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */
+/* the original system of equations. Note that if EQUED = 'Y', */
+/* A and B are modified on exit, and the solution to the */
+/* equilibrated system is inv(diag(S))*X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A after equilibration (if done). If RCOND is less than the */
+/* machine precision (in particular, if RCOND = 0), the matrix */
+/* is singular to working precision. This condition is */
+/* indicated by a return code of INFO > 0. */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: the leading minor of order i of A is */
+/* not positive definite, so the factorization */
+/* could not be completed, and the solution has not */
+/* been computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rcequ = FALSE_;
+ } else {
+ rcequ = lsame_(equed, "Y");
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ }
+
+/* Test the input parameters. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (lsame_(fact, "F") && ! (rcequ || lsame_(
+ equed, "N"))) {
+ *info = -9;
+ } else {
+ if (rcequ) {
+ smin = bignum;
+ smax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = smin, r__2 = s[j];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = smax, r__2 = s[j];
+ smax = dmax(r__1,r__2);
+/* L10: */
+ }
+ if (smin <= 0.f) {
+ *info = -10;
+ } else if (*n > 0) {
+ scond = dmax(smin,smlnum) / dmin(smax,bignum);
+ } else {
+ scond = 1.f;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -12;
+ } else if (*ldx < max(1,*n)) {
+ *info = -14;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPOSVX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ spoequ_(n, &a[a_offset], lda, &s[1], &scond, &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ slaqsy_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed);
+ rcequ = lsame_(equed, "Y");
+ }
+ }
+
+/* Scale the right hand side. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = s[i__] * b[i__ + j * b_dim1];
+/* L20: */
+ }
+/* L30: */
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ slacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ spotrf_(uplo, n, &af[af_offset], ldaf, info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.f;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = slansy_("1", uplo, n, &a[a_offset], lda, &work[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ spocon_(uplo, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &iwork[1],
+ info);
+
+/* Compute the solution matrix X. */
+
+ slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ spotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &x[x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ sporfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &b[
+ b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1], &
+ iwork[1], info);
+
+/* Transform the solution matrix X to a solution of the original */
+/* system. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__ + j * x_dim1] = s[i__] * x[i__ + j * x_dim1];
+/* L40: */
+ }
+/* L50: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= scond;
+/* L60: */
+ }
+ }
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < slamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of SPOSVX */
+
+} /* sposvx_ */
diff --git a/SRC/sposvxx.c b/SRC/sposvxx.c
new file mode 100644
index 0000000..a5d859b
--- /dev/null
+++ b/SRC/sposvxx.c
@@ -0,0 +1,611 @@
+/* sposvxx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sposvxx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, real *a, integer *lda, real *af, integer *ldaf, char *equed,
+ real *s, real *b, integer *ldb, real *x, integer *ldx, real *rcond,
+ real *rpvgrw, real *berr, integer *n_err_bnds__, real *
+ err_bnds_norm__, real *err_bnds_comp__, integer *nparams, real *
+ params, real *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j;
+ real amax, smin, smax;
+ extern doublereal sla_porpvgrw__(char *, integer *, real *, integer *,
+ real *, integer *, real *, ftnlen);
+ extern logical lsame_(char *, char *);
+ real scond;
+ logical equil, rcequ;
+ extern doublereal slamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ integer infequ;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+ real smlnum;
+ extern /* Subroutine */ int slaqsy_(char *, integer *, real *, integer *,
+ real *, real *, real *, char *), spotrf_(char *,
+ integer *, real *, integer *, integer *), spotrs_(char *,
+ integer *, integer *, real *, integer *, real *, integer *,
+ integer *), slascl2_(integer *, integer *, real *, real *,
+ integer *), spoequb_(integer *, real *, integer *, real *, real *
+, real *, integer *), sporfsx_(char *, char *, integer *, integer
+ *, real *, integer *, real *, integer *, real *, real *, integer *
+, real *, integer *, real *, real *, integer *, real *, real *,
+ integer *, real *, real *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T */
+/* to compute the solution to a real system of linear equations */
+/* A * X = B, where A is an N-by-N symmetric positive definite matrix */
+/* and X and B are N-by-NRHS matrices. */
+
+/* If requested, both normwise and maximum componentwise error bounds */
+/* are returned. SPOSVXX will return a solution with a tiny */
+/* guaranteed error (O(eps) where eps is the working machine */
+/* precision) unless the matrix is very ill-conditioned, in which */
+/* case a warning is returned. Relevant condition numbers also are */
+/* calculated and returned. */
+
+/* SPOSVXX accepts user-provided factorizations and equilibration */
+/* factors; see the definitions of the FACT and EQUED options. */
+/* Solving with refinement and using a factorization from a previous */
+/* SPOSVXX call will also produce a solution with either O(eps) */
+/* errors or warnings, but we cannot make that claim for general */
+/* user-provided factorizations and equilibration factors if they */
+/* differ from what SPOSVXX would itself produce. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+
+/* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B */
+
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
+
+/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */
+/* factor the matrix A (after equilibration if FACT = 'E') as */
+/* A = U**T* U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is a lower triangular */
+/* matrix. */
+
+/* 3. If the leading i-by-i principal minor is not positive definite, */
+/* then the routine returns with INFO = i. Otherwise, the factored */
+/* form of A is used to estimate the condition number of the matrix */
+/* A (see argument RCOND). If the reciprocal of the condition number */
+/* is less than machine precision, the routine still goes on to solve */
+/* for X and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */
+/* the routine will use iterative refinement to try to get a small */
+/* error and error bounds. Refinement calculates the residual to at */
+/* least twice the working precision. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(S) so that it solves the original system before */
+/* equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF contains the factored form of A. */
+/* If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by S. */
+/* A and AF are not modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED = */
+/* 'Y', then A must contain the equilibrated matrix */
+/* diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper */
+/* triangular part of A contains the upper triangular part of the */
+/* matrix A, and the strictly lower triangular part of A is not */
+/* referenced. If UPLO = 'L', the leading N-by-N lower triangular */
+/* part of A contains the lower triangular part of the matrix A, and */
+/* the strictly upper triangular part of A is not referenced. A is */
+/* not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED = */
+/* 'N' on exit. */
+
+/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
+/* diag(S)*A*diag(S). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) REAL array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T, in the same storage */
+/* format as A. If EQUED .ne. 'N', then AF is the factored */
+/* form of the equilibrated matrix diag(S)*A*diag(S). */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T of the original */
+/* matrix A. */
+
+/* If FACT = 'E', then AF is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T of the equilibrated */
+/* matrix A (see the description of A for the form of the */
+/* equilibrated matrix). */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'Y': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(S) * A * diag(S). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* S (input or output) REAL array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'Y', A is multiplied on */
+/* the left and right by diag(S). S is an input argument if FACT = */
+/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
+/* = 'Y', each element of S must be positive. If S is output, each */
+/* element of S is a power of the radix. If S is input, each element */
+/* of S should be a power of the radix to ensure a reliable solution */
+/* and error estimates. Scaling by powers of the radix does not cause */
+/* rounding errors unless the result underflows or overflows. */
+/* Rounding errors during scaling lead to refining with a matrix that */
+/* is not equivalent to the input matrix, producing error estimates */
+/* that may not be reliable. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if EQUED = 'Y', B is overwritten by diag(S)*B; */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) REAL array, dimension (LDX,NRHS) */
+/* If INFO = 0, the N-by-NRHS solution matrix X to the original */
+/* system of equations. Note that A and B are modified on exit if */
+/* EQUED .ne. 'N', and the solution to the equilibrated system is */
+/* inv(diag(S))*X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* RPVGRW (output) REAL */
+/* Reciprocal pivot growth. On exit, this contains the reciprocal */
+/* pivot growth factor norm(A)/norm(U). The "max absolute element" */
+/* norm is used. If this is much less than 1, then the stability of */
+/* the LU factorization of the (equilibrated) matrix A could be poor. */
+/* This also means that the solution X, estimated condition numbers, */
+/* and error bounds could be unreliable. If factorization fails with */
+/* 0<INFO<=N, then this contains the reciprocal pivot growth factor */
+/* for the leading INFO columns of A. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) REAL array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) REAL array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rcequ = FALSE_;
+ } else {
+ rcequ = lsame_(equed, "Y");
+ }
+
+/* Default is failure. If an input parameter is wrong or */
+/* factorization fails, make everything look horrible. Only the */
+/* pivot growth is set here, the rest is initialized in SPORFSX. */
+
+ *rpvgrw = 0.f;
+
+/* Test the input parameters. PARAMS is not tested until SPORFSX. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (lsame_(fact, "F") && ! (rcequ || lsame_(
+ equed, "N"))) {
+ *info = -9;
+ } else {
+ if (rcequ) {
+ smin = bignum;
+ smax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = smin, r__2 = s[j];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = smax, r__2 = s[j];
+ smax = dmax(r__1,r__2);
+/* L10: */
+ }
+ if (smin <= 0.f) {
+ *info = -10;
+ } else if (*n > 0) {
+ scond = dmax(smin,smlnum) / dmin(smax,bignum);
+ } else {
+ scond = 1.f;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -12;
+ } else if (*ldx < max(1,*n)) {
+ *info = -14;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPOSVXX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ spoequb_(n, &a[a_offset], lda, &s[1], &scond, &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ slaqsy_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed);
+ rcequ = lsame_(equed, "Y");
+ }
+ }
+
+/* Scale the right-hand side. */
+
+ if (rcequ) {
+ slascl2_(n, nrhs, &s[1], &b[b_offset], ldb);
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of A. */
+
+ slacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ spotrf_(uplo, n, &af[af_offset], ldaf, info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info != 0) {
+
+/* Pivot in column INFO is exactly 0 */
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ *rpvgrw = sla_porpvgrw__(uplo, info, &a[a_offset], lda, &af[
+ af_offset], ldaf, &work[1], (ftnlen)1);
+ return 0;
+ }
+ }
+
+/* Compute the reciprocal growth factor RPVGRW. */
+
+ *rpvgrw = sla_porpvgrw__(uplo, n, &a[a_offset], lda, &af[af_offset], ldaf,
+ &work[1], (ftnlen)1);
+
+/* Compute the solution matrix X. */
+
+ slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ spotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &x[x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ sporfsx_(uplo, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &
+ s[1], &b[b_offset], ldb, &x[x_offset], ldx, rcond, &berr[1],
+ n_err_bnds__, &err_bnds_norm__[err_bnds_norm_offset], &
+ err_bnds_comp__[err_bnds_comp_offset], nparams, ¶ms[1], &work[
+ 1], &iwork[1], info);
+
+/* Scale solutions. */
+
+ if (rcequ) {
+ slascl2_(n, nrhs, &s[1], &x[x_offset], ldx);
+ }
+
+ return 0;
+
+/* End of SPOSVXX */
+
+} /* sposvxx_ */
diff --git a/SRC/spotf2.c b/SRC/spotf2.c
new file mode 100644
index 0000000..2349774
--- /dev/null
+++ b/SRC/spotf2.c
@@ -0,0 +1,221 @@
+/* spotf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b10 = -1.f;
+static real c_b12 = 1.f;
+
+/* Subroutine */ int spotf2_(char *uplo, integer *n, real *a, integer *lda,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer j;
+ real ajj;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ sgemv_(char *, integer *, integer *, real *, real *, integer *,
+ real *, integer *, real *, real *, integer *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern logical sisnan_(real *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPOTF2 computes the Cholesky factorization of a real symmetric */
+/* positive definite matrix A. */
+
+/* The factorization has the form */
+/* A = U' * U , if UPLO = 'U', or */
+/* A = L * L', if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n by n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n by n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization A = U'*U or A = L*L'. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, the leading minor of order k is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPOTF2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute U(J,J) and test for non-positive-definiteness. */
+
+ i__2 = j - 1;
+ ajj = a[j + j * a_dim1] - sdot_(&i__2, &a[j * a_dim1 + 1], &c__1,
+ &a[j * a_dim1 + 1], &c__1);
+ if (ajj <= 0.f || sisnan_(&ajj)) {
+ a[j + j * a_dim1] = ajj;
+ goto L30;
+ }
+ ajj = sqrt(ajj);
+ a[j + j * a_dim1] = ajj;
+
+/* Compute elements J+1:N of row J. */
+
+ if (j < *n) {
+ i__2 = j - 1;
+ i__3 = *n - j;
+ sgemv_("Transpose", &i__2, &i__3, &c_b10, &a[(j + 1) * a_dim1
+ + 1], lda, &a[j * a_dim1 + 1], &c__1, &c_b12, &a[j + (
+ j + 1) * a_dim1], lda);
+ i__2 = *n - j;
+ r__1 = 1.f / ajj;
+ sscal_(&i__2, &r__1, &a[j + (j + 1) * a_dim1], lda);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute L(J,J) and test for non-positive-definiteness. */
+
+ i__2 = j - 1;
+ ajj = a[j + j * a_dim1] - sdot_(&i__2, &a[j + a_dim1], lda, &a[j
+ + a_dim1], lda);
+ if (ajj <= 0.f || sisnan_(&ajj)) {
+ a[j + j * a_dim1] = ajj;
+ goto L30;
+ }
+ ajj = sqrt(ajj);
+ a[j + j * a_dim1] = ajj;
+
+/* Compute elements J+1:N of column J. */
+
+ if (j < *n) {
+ i__2 = *n - j;
+ i__3 = j - 1;
+ sgemv_("No transpose", &i__2, &i__3, &c_b10, &a[j + 1 +
+ a_dim1], lda, &a[j + a_dim1], lda, &c_b12, &a[j + 1 +
+ j * a_dim1], &c__1);
+ i__2 = *n - j;
+ r__1 = 1.f / ajj;
+ sscal_(&i__2, &r__1, &a[j + 1 + j * a_dim1], &c__1);
+ }
+/* L20: */
+ }
+ }
+ goto L40;
+
+L30:
+ *info = j;
+
+L40:
+ return 0;
+
+/* End of SPOTF2 */
+
+} /* spotf2_ */
diff --git a/SRC/spotrf.c b/SRC/spotrf.c
new file mode 100644
index 0000000..ff33e9e
--- /dev/null
+++ b/SRC/spotrf.c
@@ -0,0 +1,243 @@
+/* spotrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b13 = -1.f;
+static real c_b14 = 1.f;
+
+/* Subroutine */ int spotrf_(char *uplo, integer *n, real *a, integer *lda,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer j, jb, nb;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ logical upper;
+ extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), ssyrk_(char *, char *, integer
+ *, integer *, real *, real *, integer *, real *, real *, integer *
+), spotf2_(char *, integer *, real *, integer *,
+ integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPOTRF computes the Cholesky factorization of a real symmetric */
+/* positive definite matrix A. */
+
+/* The factorization has the form */
+/* A = U**T * U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* This is the block version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPOTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "SPOTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code. */
+
+ spotf2_(uplo, n, &a[a_offset], lda, info);
+ } else {
+
+/* Use blocked code. */
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+ i__3 = j - 1;
+ ssyrk_("Upper", "Transpose", &jb, &i__3, &c_b13, &a[j *
+ a_dim1 + 1], lda, &c_b14, &a[j + j * a_dim1], lda);
+ spotf2_("Upper", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+ if (j + jb <= *n) {
+
+/* Compute the current block row. */
+
+ i__3 = *n - j - jb + 1;
+ i__4 = j - 1;
+ sgemm_("Transpose", "No transpose", &jb, &i__3, &i__4, &
+ c_b13, &a[j * a_dim1 + 1], lda, &a[(j + jb) *
+ a_dim1 + 1], lda, &c_b14, &a[j + (j + jb) *
+ a_dim1], lda);
+ i__3 = *n - j - jb + 1;
+ strsm_("Left", "Upper", "Transpose", "Non-unit", &jb, &
+ i__3, &c_b14, &a[j + j * a_dim1], lda, &a[j + (j
+ + jb) * a_dim1], lda);
+ }
+/* L10: */
+ }
+
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+ i__3 = j - 1;
+ ssyrk_("Lower", "No transpose", &jb, &i__3, &c_b13, &a[j +
+ a_dim1], lda, &c_b14, &a[j + j * a_dim1], lda);
+ spotf2_("Lower", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+ if (j + jb <= *n) {
+
+/* Compute the current block column. */
+
+ i__3 = *n - j - jb + 1;
+ i__4 = j - 1;
+ sgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &
+ c_b13, &a[j + jb + a_dim1], lda, &a[j + a_dim1],
+ lda, &c_b14, &a[j + jb + j * a_dim1], lda);
+ i__3 = *n - j - jb + 1;
+ strsm_("Right", "Lower", "Transpose", "Non-unit", &i__3, &
+ jb, &c_b14, &a[j + j * a_dim1], lda, &a[j + jb +
+ j * a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+ }
+ goto L40;
+
+L30:
+ *info = *info + j - 1;
+
+L40:
+ return 0;
+
+/* End of SPOTRF */
+
+} /* spotrf_ */
diff --git a/SRC/spotri.c b/SRC/spotri.c
new file mode 100644
index 0000000..2669838
--- /dev/null
+++ b/SRC/spotri.c
@@ -0,0 +1,124 @@
+/* spotri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int spotri_(char *uplo, integer *n, real *a, integer *lda,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), slauum_(
+ char *, integer *, real *, integer *, integer *), strtri_(
+ char *, char *, integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPOTRI computes the inverse of a real symmetric positive definite */
+/* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T */
+/* computed by SPOTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T, as computed by */
+/* SPOTRF. */
+/* On exit, the upper or lower triangle of the (symmetric) */
+/* inverse of A, overwriting the input factor U or L. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the (i,i) element of the factor U or L is */
+/* zero, and the inverse could not be computed. */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPOTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Invert the triangular Cholesky factor U or L. */
+
+ strtri_(uplo, "Non-unit", n, &a[a_offset], lda, info);
+ if (*info > 0) {
+ return 0;
+ }
+
+/* Form inv(U)*inv(U)' or inv(L)'*inv(L). */
+
+ slauum_(uplo, n, &a[a_offset], lda, info);
+
+ return 0;
+
+/* End of SPOTRI */
+
+} /* spotri_ */
diff --git a/SRC/spotrs.c b/SRC/spotrs.c
new file mode 100644
index 0000000..ba0d324
--- /dev/null
+++ b/SRC/spotrs.c
@@ -0,0 +1,164 @@
+/* spotrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b9 = 1.f;
+
+/* Subroutine */ int spotrs_(char *uplo, integer *n, integer *nrhs, real *a,
+ integer *lda, real *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPOTRS solves a system of linear equations A*X = B with a symmetric */
+/* positive definite matrix A using the Cholesky factorization */
+/* A = U**T*U or A = L*L**T computed by SPOTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by SPOTRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPOTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B where A = U'*U. */
+
+/* Solve U'*X = B, overwriting B with X. */
+
+ strsm_("Left", "Upper", "Transpose", "Non-unit", n, nrhs, &c_b9, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+/* Solve U*X = B, overwriting B with X. */
+
+ strsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b9, &
+ a[a_offset], lda, &b[b_offset], ldb);
+ } else {
+
+/* Solve A*X = B where A = L*L'. */
+
+/* Solve L*X = B, overwriting B with X. */
+
+ strsm_("Left", "Lower", "No transpose", "Non-unit", n, nrhs, &c_b9, &
+ a[a_offset], lda, &b[b_offset], ldb);
+
+/* Solve L'*X = B, overwriting B with X. */
+
+ strsm_("Left", "Lower", "Transpose", "Non-unit", n, nrhs, &c_b9, &a[
+ a_offset], lda, &b[b_offset], ldb);
+ }
+
+ return 0;
+
+/* End of SPOTRS */
+
+} /* spotrs_ */
diff --git a/SRC/sppcon.c b/SRC/sppcon.c
new file mode 100644
index 0000000..8e3d0c1
--- /dev/null
+++ b/SRC/sppcon.c
@@ -0,0 +1,213 @@
+/* sppcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sppcon_(char *uplo, integer *n, real *ap, real *anorm,
+ real *rcond, real *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1;
+
+ /* Local variables */
+ integer ix, kase;
+ real scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *);
+ logical upper;
+ extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *,
+ real *, integer *, integer *);
+ real scalel;
+ extern doublereal slamch_(char *);
+ real scaleu;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ real ainvnm;
+ char normin[1];
+ extern /* Subroutine */ int slatps_(char *, char *, char *, char *,
+ integer *, real *, real *, real *, real *, integer *);
+ real smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPPCON estimates the reciprocal of the condition number (in the */
+/* 1-norm) of a real symmetric positive definite packed matrix using */
+/* the Cholesky factorization A = U**T*U or A = L*L**T computed by */
+/* SPPTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) REAL array, dimension (N*(N+1)/2) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, packed columnwise in a linear */
+/* array. The j-th column of U or L is stored in the array AP */
+/* as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */
+
+/* ANORM (input) REAL */
+/* The 1-norm (or infinity-norm) of the symmetric matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*anorm < 0.f) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPPCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.f;
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ } else if (*anorm == 0.f) {
+ return 0;
+ }
+
+ smlnum = slamch_("Safe minimum");
+
+/* Estimate the 1-norm of the inverse. */
+
+ kase = 0;
+ *(unsigned char *)normin = 'N';
+L10:
+ slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (upper) {
+
+/* Multiply by inv(U'). */
+
+ slatps_("Upper", "Transpose", "Non-unit", normin, n, &ap[1], &
+ work[1], &scalel, &work[(*n << 1) + 1], info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(U). */
+
+ slatps_("Upper", "No transpose", "Non-unit", normin, n, &ap[1], &
+ work[1], &scaleu, &work[(*n << 1) + 1], info);
+ } else {
+
+/* Multiply by inv(L). */
+
+ slatps_("Lower", "No transpose", "Non-unit", normin, n, &ap[1], &
+ work[1], &scalel, &work[(*n << 1) + 1], info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(L'). */
+
+ slatps_("Lower", "Transpose", "Non-unit", normin, n, &ap[1], &
+ work[1], &scaleu, &work[(*n << 1) + 1], info);
+ }
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ scale = scalel * scaleu;
+ if (scale != 1.f) {
+ ix = isamax_(n, &work[1], &c__1);
+ if (scale < (r__1 = work[ix], dabs(r__1)) * smlnum || scale ==
+ 0.f) {
+ goto L20;
+ }
+ srscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / ainvnm / *anorm;
+ }
+
+L20:
+ return 0;
+
+/* End of SPPCON */
+
+} /* sppcon_ */
diff --git a/SRC/sppequ.c b/SRC/sppequ.c
new file mode 100644
index 0000000..44142dd
--- /dev/null
+++ b/SRC/sppequ.c
@@ -0,0 +1,208 @@
+/* sppequ.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sppequ_(char *uplo, integer *n, real *ap, real *s, real *
+ scond, real *amax, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, jj;
+ real smin;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPPEQU computes row and column scalings intended to equilibrate a */
+/* symmetric positive definite matrix A in packed storage and reduce */
+/* its condition number (with respect to the two-norm). S contains the */
+/* scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix */
+/* B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal. */
+/* This choice of S puts the condition number of B within a factor N of */
+/* the smallest possible condition number over all possible diagonal */
+/* scalings. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) REAL array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the symmetric matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* S (output) REAL array, dimension (N) */
+/* If INFO = 0, S contains the scale factors for A. */
+
+/* SCOND (output) REAL */
+/* If INFO = 0, S contains the ratio of the smallest S(i) to */
+/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
+/* large nor too small, it is not worth scaling by S. */
+
+/* AMAX (output) REAL */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --s;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPPEQU", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *scond = 1.f;
+ *amax = 0.f;
+ return 0;
+ }
+
+/* Initialize SMIN and AMAX. */
+
+ s[1] = ap[1];
+ smin = s[1];
+ *amax = s[1];
+
+ if (upper) {
+
+/* UPLO = 'U': Upper triangle of A is stored. */
+/* Find the minimum and maximum diagonal elements. */
+
+ jj = 1;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ jj += i__;
+ s[i__] = ap[jj];
+/* Computing MIN */
+ r__1 = smin, r__2 = s[i__];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = *amax, r__2 = s[i__];
+ *amax = dmax(r__1,r__2);
+/* L10: */
+ }
+
+ } else {
+
+/* UPLO = 'L': Lower triangle of A is stored. */
+/* Find the minimum and maximum diagonal elements. */
+
+ jj = 1;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ jj = jj + *n - i__ + 2;
+ s[i__] = ap[jj];
+/* Computing MIN */
+ r__1 = smin, r__2 = s[i__];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = *amax, r__2 = s[i__];
+ *amax = dmax(r__1,r__2);
+/* L20: */
+ }
+ }
+
+ if (smin <= 0.f) {
+
+/* Find the first non-positive diagonal element and return. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] <= 0.f) {
+ *info = i__;
+ return 0;
+ }
+/* L30: */
+ }
+ } else {
+
+/* Set the scale factors to the reciprocals */
+/* of the diagonal elements. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s[i__] = 1.f / sqrt(s[i__]);
+/* L40: */
+ }
+
+/* Compute SCOND = min(S(I)) / max(S(I)) */
+
+ *scond = sqrt(smin) / sqrt(*amax);
+ }
+ return 0;
+
+/* End of SPPEQU */
+
+} /* sppequ_ */
diff --git a/SRC/spprfs.c b/SRC/spprfs.c
new file mode 100644
index 0000000..b12391f
--- /dev/null
+++ b/SRC/spprfs.c
@@ -0,0 +1,408 @@
+/* spprfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b12 = -1.f;
+static real c_b14 = 1.f;
+
+/* Subroutine */ int spprfs_(char *uplo, integer *n, integer *nrhs, real *ap,
+ real *afp, real *b, integer *ldb, real *x, integer *ldx, real *ferr,
+ real *berr, real *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ real s;
+ integer ik, kk;
+ real xk;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3], count;
+ logical upper;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), saxpy_(integer *, real *, real *, integer *, real *,
+ integer *), sspmv_(char *, integer *, real *, real *, real *,
+ integer *, real *, real *, integer *), slacn2_(integer *,
+ real *, real *, integer *, real *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real lstres;
+ extern /* Subroutine */ int spptrs_(char *, integer *, integer *, real *,
+ real *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPPRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric positive definite */
+/* and packed, and provides error bounds and backward error estimates */
+/* for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input) REAL array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the symmetric matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* AFP (input) REAL array, dimension (N*(N+1)/2) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by SPPTRF/CPPTRF, */
+/* packed columnwise in a linear array in the same format as A */
+/* (see AP). */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) REAL array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by SPPTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --afp;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldx < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPPRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.f;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ scopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+ sspmv_(uplo, n, &c_b12, &ap[1], &x[j * x_dim1 + 1], &c__1, &c_b14, &
+ work[*n + 1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] = (r__1 = b[i__ + j * b_dim1], dabs(r__1));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ kk = 1;
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+ ik = kk;
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ work[i__] += (r__1 = ap[ik], dabs(r__1)) * xk;
+ s += (r__1 = ap[ik], dabs(r__1)) * (r__2 = x[i__ + j *
+ x_dim1], dabs(r__2));
+ ++ik;
+/* L40: */
+ }
+ work[k] = work[k] + (r__1 = ap[kk + k - 1], dabs(r__1)) * xk
+ + s;
+ kk += k;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+ work[k] += (r__1 = ap[kk], dabs(r__1)) * xk;
+ ik = kk + 1;
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ work[i__] += (r__1 = ap[ik], dabs(r__1)) * xk;
+ s += (r__1 = ap[ik], dabs(r__1)) * (r__2 = x[i__ + j *
+ x_dim1], dabs(r__2));
+ ++ik;
+/* L60: */
+ }
+ work[k] += s;
+ kk += *n - k + 1;
+/* L70: */
+ }
+ }
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[
+ i__];
+ s = dmax(r__2,r__3);
+ } else {
+/* Computing MAX */
+ r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1)
+ / (work[i__] + safe1);
+ s = dmax(r__2,r__3);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ spptrs_(uplo, n, &c__1, &afp[1], &work[*n + 1], n, info);
+ saxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
+ ;
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use SLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ slacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+ kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ spptrs_(uplo, n, &c__1, &afp[1], &work[*n + 1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L120: */
+ }
+ spptrs_(uplo, n, &c__1, &afp[1], &work[*n + 1], n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], dabs(r__1));
+ lstres = dmax(r__2,r__3);
+/* L130: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of SPPRFS */
+
+} /* spprfs_ */
diff --git a/SRC/sppsv.c b/SRC/sppsv.c
new file mode 100644
index 0000000..cbeb78b
--- /dev/null
+++ b/SRC/sppsv.c
@@ -0,0 +1,160 @@
+/* sppsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sppsv_(char *uplo, integer *n, integer *nrhs, real *ap,
+ real *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), spptrf_(
+ char *, integer *, real *, integer *), spptrs_(char *,
+ integer *, integer *, real *, real *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPPSV computes the solution to a real system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N symmetric positive definite matrix stored in */
+/* packed format and X and B are N-by-NRHS matrices. */
+
+/* The Cholesky decomposition is used to factor A as */
+/* A = U**T* U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is a lower triangular */
+/* matrix. The factored form of A is then used to solve the system of */
+/* equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input/output) REAL array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T, in the same storage */
+/* format as A. */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i of A is not */
+/* positive definite, so the factorization could not be */
+/* completed, and the solution has not been computed. */
+
+/* Further Details */
+/* =============== */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the symmetric matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = conjg(aji)) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPPSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ spptrf_(uplo, n, &ap[1], info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ spptrs_(uplo, n, nrhs, &ap[1], &b[b_offset], ldb, info);
+
+ }
+ return 0;
+
+/* End of SPPSV */
+
+} /* sppsv_ */
diff --git a/SRC/sppsvx.c b/SRC/sppsvx.c
new file mode 100644
index 0000000..15f5d6e
--- /dev/null
+++ b/SRC/sppsvx.c
@@ -0,0 +1,452 @@
+/* sppsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sppsvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, real *ap, real *afp, char *equed, real *s, real *b, integer *
+ ldb, real *x, integer *ldx, real *rcond, real *ferr, real *berr, real
+ *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer i__, j;
+ real amax, smin, smax;
+ extern logical lsame_(char *, char *);
+ real scond, anorm;
+ logical equil, rcequ;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ extern doublereal slamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ integer infequ;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+ extern doublereal slansp_(char *, char *, integer *, real *, real *);
+ extern /* Subroutine */ int sppcon_(char *, integer *, real *, real *,
+ real *, real *, integer *, integer *), slaqsp_(char *,
+ integer *, real *, real *, real *, real *, char *)
+ ;
+ real smlnum;
+ extern /* Subroutine */ int sppequ_(char *, integer *, real *, real *,
+ real *, real *, integer *), spprfs_(char *, integer *,
+ integer *, real *, real *, real *, integer *, real *, integer *,
+ real *, real *, real *, integer *, integer *), spptrf_(
+ char *, integer *, real *, integer *), spptrs_(char *,
+ integer *, integer *, real *, real *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to */
+/* compute the solution to a real system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N symmetric positive definite matrix stored in */
+/* packed format and X and B are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+/* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
+
+/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */
+/* factor the matrix A (after equilibration if FACT = 'E') as */
+/* A = U**T* U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is a lower triangular */
+/* matrix. */
+
+/* 3. If the leading i-by-i principal minor is not positive definite, */
+/* then the routine returns with INFO = i. Otherwise, the factored */
+/* form of A is used to estimate the condition number of the matrix */
+/* A. If the reciprocal of the condition number is less than machine */
+/* precision, INFO = N+1 is returned as a warning, but the routine */
+/* still goes on to solve for X and compute error bounds as */
+/* described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(S) so that it solves the original system before */
+/* equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AFP contains the factored form of A. */
+/* If EQUED = 'Y', the matrix A has been equilibrated */
+/* with scaling factors given by S. AP and AFP will not */
+/* be modified. */
+/* = 'N': The matrix A will be copied to AFP and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AFP and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input/output) REAL array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array, except if FACT = 'F' */
+/* and EQUED = 'Y', then A must contain the equilibrated matrix */
+/* diag(S)*A*diag(S). The j-th column of A is stored in the */
+/* array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. A is not modified if */
+/* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
+
+/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
+/* diag(S)*A*diag(S). */
+
+/* AFP (input or output) REAL array, dimension */
+/* (N*(N+1)/2) */
+/* If FACT = 'F', then AFP is an input argument and on entry */
+/* contains the triangular factor U or L from the Cholesky */
+/* factorization A = U'*U or A = L*L', in the same storage */
+/* format as A. If EQUED .ne. 'N', then AFP is the factored */
+/* form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AFP is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U'*U or A = L*L' of the original matrix A. */
+
+/* If FACT = 'E', then AFP is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U'*U or A = L*L' of the equilibrated */
+/* matrix A (see the description of AP for the form of the */
+/* equilibrated matrix). */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* S (input or output) REAL array, dimension (N) */
+/* The scale factors for A; not accessed if EQUED = 'N'. S is */
+/* an input argument if FACT = 'F'; otherwise, S is an output */
+/* argument. If FACT = 'F' and EQUED = 'Y', each element of S */
+/* must be positive. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */
+/* B is overwritten by diag(S) * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) REAL array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */
+/* the original system of equations. Note that if EQUED = 'Y', */
+/* A and B are modified on exit, and the solution to the */
+/* equilibrated system is inv(diag(S))*X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A after equilibration (if done). If RCOND is less than the */
+/* machine precision (in particular, if RCOND = 0), the matrix */
+/* is singular to working precision. This condition is */
+/* indicated by a return code of INFO > 0. */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: the leading minor of order i of A is */
+/* not positive definite, so the factorization */
+/* could not be completed, and the solution has not */
+/* been computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* Further Details */
+/* =============== */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the symmetric matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = conjg(aji)) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ap;
+ --afp;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rcequ = FALSE_;
+ } else {
+ rcequ = lsame_(equed, "Y");
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ }
+
+/* Test the input parameters. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (lsame_(fact, "F") && ! (rcequ || lsame_(
+ equed, "N"))) {
+ *info = -7;
+ } else {
+ if (rcequ) {
+ smin = bignum;
+ smax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = smin, r__2 = s[j];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = smax, r__2 = s[j];
+ smax = dmax(r__1,r__2);
+/* L10: */
+ }
+ if (smin <= 0.f) {
+ *info = -8;
+ } else if (*n > 0) {
+ scond = dmax(smin,smlnum) / dmin(smax,bignum);
+ } else {
+ scond = 1.f;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldx < max(1,*n)) {
+ *info = -12;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPPSVX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ sppequ_(uplo, n, &ap[1], &s[1], &scond, &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ slaqsp_(uplo, n, &ap[1], &s[1], &scond, &amax, equed);
+ rcequ = lsame_(equed, "Y");
+ }
+ }
+
+/* Scale the right-hand side. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = s[i__] * b[i__ + j * b_dim1];
+/* L20: */
+ }
+/* L30: */
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ i__1 = *n * (*n + 1) / 2;
+ scopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1);
+ spptrf_(uplo, n, &afp[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.f;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = slansp_("I", uplo, n, &ap[1], &work[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ sppcon_(uplo, n, &afp[1], &anorm, rcond, &work[1], &iwork[1], info);
+
+/* Compute the solution matrix X. */
+
+ slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ spptrs_(uplo, n, nrhs, &afp[1], &x[x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ spprfs_(uplo, n, nrhs, &ap[1], &afp[1], &b[b_offset], ldb, &x[x_offset],
+ ldx, &ferr[1], &berr[1], &work[1], &iwork[1], info);
+
+/* Transform the solution matrix X to a solution of the original */
+/* system. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__ + j * x_dim1] = s[i__] * x[i__ + j * x_dim1];
+/* L40: */
+ }
+/* L50: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= scond;
+/* L60: */
+ }
+ }
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < slamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of SPPSVX */
+
+} /* sppsvx_ */
diff --git a/SRC/spptrf.c b/SRC/spptrf.c
new file mode 100644
index 0000000..997337b
--- /dev/null
+++ b/SRC/spptrf.c
@@ -0,0 +1,221 @@
+/* spptrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b16 = -1.f;
+
+/* Subroutine */ int spptrf_(char *uplo, integer *n, real *ap, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer j, jc, jj;
+ real ajj;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ extern /* Subroutine */ int sspr_(char *, integer *, real *, real *,
+ integer *, real *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ logical upper;
+ extern /* Subroutine */ int stpsv_(char *, char *, char *, integer *,
+ real *, real *, integer *), xerbla_(char *
+, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPPTRF computes the Cholesky factorization of a real symmetric */
+/* positive definite matrix A stored in packed format. */
+
+/* The factorization has the form */
+/* A = U**T * U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) REAL array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+
+/* On exit, if INFO = 0, the triangular factor U or L from the */
+/* Cholesky factorization A = U**T*U or A = L*L**T, in the same */
+/* storage format as A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* Further Details */
+/* ======= ======= */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the symmetric matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = aji) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPPTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ jj = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ jc = jj + 1;
+ jj += j;
+
+/* Compute elements 1:J-1 of column J. */
+
+ if (j > 1) {
+ i__2 = j - 1;
+ stpsv_("Upper", "Transpose", "Non-unit", &i__2, &ap[1], &ap[
+ jc], &c__1);
+ }
+
+/* Compute U(J,J) and test for non-positive-definiteness. */
+
+ i__2 = j - 1;
+ ajj = ap[jj] - sdot_(&i__2, &ap[jc], &c__1, &ap[jc], &c__1);
+ if (ajj <= 0.f) {
+ ap[jj] = ajj;
+ goto L30;
+ }
+ ap[jj] = sqrt(ajj);
+/* L10: */
+ }
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ jj = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute L(J,J) and test for non-positive-definiteness. */
+
+ ajj = ap[jj];
+ if (ajj <= 0.f) {
+ ap[jj] = ajj;
+ goto L30;
+ }
+ ajj = sqrt(ajj);
+ ap[jj] = ajj;
+
+/* Compute elements J+1:N of column J and update the trailing */
+/* submatrix. */
+
+ if (j < *n) {
+ i__2 = *n - j;
+ r__1 = 1.f / ajj;
+ sscal_(&i__2, &r__1, &ap[jj + 1], &c__1);
+ i__2 = *n - j;
+ sspr_("Lower", &i__2, &c_b16, &ap[jj + 1], &c__1, &ap[jj + *n
+ - j + 1]);
+ jj = jj + *n - j + 1;
+ }
+/* L20: */
+ }
+ }
+ goto L40;
+
+L30:
+ *info = j;
+
+L40:
+ return 0;
+
+/* End of SPPTRF */
+
+} /* spptrf_ */
diff --git a/SRC/spptri.c b/SRC/spptri.c
new file mode 100644
index 0000000..c4e7e95
--- /dev/null
+++ b/SRC/spptri.c
@@ -0,0 +1,171 @@
+/* spptri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b8 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int spptri_(char *uplo, integer *n, real *ap, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer j, jc, jj;
+ real ajj;
+ integer jjn;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ extern /* Subroutine */ int sspr_(char *, integer *, real *, real *,
+ integer *, real *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ logical upper;
+ extern /* Subroutine */ int stpmv_(char *, char *, char *, integer *,
+ real *, real *, integer *), xerbla_(char *
+, integer *), stptri_(char *, char *, integer *, real *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPPTRI computes the inverse of a real symmetric positive definite */
+/* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T */
+/* computed by SPPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular factor is stored in AP; */
+/* = 'L': Lower triangular factor is stored in AP. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) REAL array, dimension (N*(N+1)/2) */
+/* On entry, the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T, packed columnwise as */
+/* a linear array. The j-th column of U or L is stored in the */
+/* array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */
+
+/* On exit, the upper or lower triangle of the (symmetric) */
+/* inverse of A, overwriting the input factor U or L. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the (i,i) element of the factor U or L is */
+/* zero, and the inverse could not be computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPPTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Invert the triangular Cholesky factor U or L. */
+
+ stptri_(uplo, "Non-unit", n, &ap[1], info);
+ if (*info > 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Compute the product inv(U) * inv(U)'. */
+
+ jj = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ jc = jj + 1;
+ jj += j;
+ if (j > 1) {
+ i__2 = j - 1;
+ sspr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1]);
+ }
+ ajj = ap[jj];
+ sscal_(&j, &ajj, &ap[jc], &c__1);
+/* L10: */
+ }
+
+ } else {
+
+/* Compute the product inv(L)' * inv(L). */
+
+ jj = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ jjn = jj + *n - j + 1;
+ i__2 = *n - j + 1;
+ ap[jj] = sdot_(&i__2, &ap[jj], &c__1, &ap[jj], &c__1);
+ if (j < *n) {
+ i__2 = *n - j;
+ stpmv_("Lower", "Transpose", "Non-unit", &i__2, &ap[jjn], &ap[
+ jj + 1], &c__1);
+ }
+ jj = jjn;
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of SPPTRI */
+
+} /* spptri_ */
diff --git a/SRC/spptrs.c b/SRC/spptrs.c
new file mode 100644
index 0000000..6d0d30e
--- /dev/null
+++ b/SRC/spptrs.c
@@ -0,0 +1,170 @@
+/* spptrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int spptrs_(char *uplo, integer *n, integer *nrhs, real *ap,
+ real *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ integer i__;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int stpsv_(char *, char *, char *, integer *,
+ real *, real *, integer *), xerbla_(char *
+, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPPTRS solves a system of linear equations A*X = B with a symmetric */
+/* positive definite matrix A in packed storage using the Cholesky */
+/* factorization A = U**T*U or A = L*L**T computed by SPPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input) REAL array, dimension (N*(N+1)/2) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, packed columnwise in a linear */
+/* array. The j-th column of U or L is stored in the array AP */
+/* as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPPTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B where A = U'*U. */
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Solve U'*X = B, overwriting B with X. */
+
+ stpsv_("Upper", "Transpose", "Non-unit", n, &ap[1], &b[i__ *
+ b_dim1 + 1], &c__1);
+
+/* Solve U*X = B, overwriting B with X. */
+
+ stpsv_("Upper", "No transpose", "Non-unit", n, &ap[1], &b[i__ *
+ b_dim1 + 1], &c__1);
+/* L10: */
+ }
+ } else {
+
+/* Solve A*X = B where A = L*L'. */
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Solve L*Y = B, overwriting B with X. */
+
+ stpsv_("Lower", "No transpose", "Non-unit", n, &ap[1], &b[i__ *
+ b_dim1 + 1], &c__1);
+
+/* Solve L'*X = Y, overwriting B with X. */
+
+ stpsv_("Lower", "Transpose", "Non-unit", n, &ap[1], &b[i__ *
+ b_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of SPPTRS */
+
+} /* spptrs_ */
diff --git a/SRC/spstf2.c b/SRC/spstf2.c
new file mode 100644
index 0000000..0eab03e
--- /dev/null
+++ b/SRC/spstf2.c
@@ -0,0 +1,392 @@
+/* spstf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b16 = -1.f;
+static real c_b18 = 1.f;
+
+/* Subroutine */ int spstf2_(char *uplo, integer *n, real *a, integer *lda,
+ integer *piv, integer *rank, real *tol, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, maxlocval;
+ real ajj;
+ integer pvt;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ integer itemp;
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ real stemp;
+ logical upper;
+ extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
+ integer *);
+ real sstop;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern logical sisnan_(real *);
+ extern integer smaxloc_(real *, integer *);
+
+
+/* -- LAPACK PROTOTYPE routine (version 3.2) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPSTF2 computes the Cholesky factorization with complete */
+/* pivoting of a real symmetric positive semidefinite matrix A. */
+
+/* The factorization has the form */
+/* P' * A * P = U' * U , if UPLO = 'U', */
+/* P' * A * P = L * L', if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular, and */
+/* P is stored as vector PIV. */
+
+/* This algorithm does not attempt to check that A is positive */
+/* semidefinite. This version of the algorithm calls level 2 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n by n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n by n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization as above. */
+
+/* PIV (output) INTEGER array, dimension (N) */
+/* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. */
+
+/* RANK (output) INTEGER */
+/* The rank of A given by the number of steps the algorithm */
+/* completed. */
+
+/* TOL (input) REAL */
+/* User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) ) */
+/* will be used. The algorithm terminates at the (K-1)st step */
+/* if the pivot <= TOL. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* WORK REAL array, dimension (2*N) */
+/* Work space. */
+
+/* INFO (output) INTEGER */
+/* < 0: If INFO = -K, the K-th argument had an illegal value, */
+/* = 0: algorithm completed successfully, and */
+/* > 0: the matrix A is either rank deficient with computed rank */
+/* as returned in RANK, or is indefinite. See Section 7 of */
+/* LAPACK Working Note #161 for further information. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ --work;
+ --piv;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPSTF2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Initialize PIV */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ piv[i__] = i__;
+/* L100: */
+ }
+
+/* Compute stopping value */
+
+ pvt = 1;
+ ajj = a[pvt + pvt * a_dim1];
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ if (a[i__ + i__ * a_dim1] > ajj) {
+ pvt = i__;
+ ajj = a[pvt + pvt * a_dim1];
+ }
+ }
+ if (ajj == 0.f || sisnan_(&ajj)) {
+ *rank = 0;
+ *info = 1;
+ goto L170;
+ }
+
+/* Compute stopping value if not supplied */
+
+ if (*tol < 0.f) {
+ sstop = *n * slamch_("Epsilon") * ajj;
+ } else {
+ sstop = *tol;
+ }
+
+/* Set first half of WORK to zero, holds dot products */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L110: */
+ }
+
+ if (upper) {
+
+/* Compute the Cholesky factorization P' * A * P = U' * U */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Find pivot, test for exit, else swap rows and columns */
+/* Update dot products, compute possible pivots which are */
+/* stored in the second half of WORK */
+
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+
+ if (j > 1) {
+/* Computing 2nd power */
+ r__1 = a[j - 1 + i__ * a_dim1];
+ work[i__] += r__1 * r__1;
+ }
+ work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__];
+
+/* L120: */
+ }
+
+ if (j > 1) {
+ maxlocval = (*n << 1) - (*n + j) + 1;
+ itemp = smaxloc_(&work[*n + j], &maxlocval);
+ pvt = itemp + j - 1;
+ ajj = work[*n + pvt];
+ if (ajj <= sstop || sisnan_(&ajj)) {
+ a[j + j * a_dim1] = ajj;
+ goto L160;
+ }
+ }
+
+ if (j != pvt) {
+
+/* Pivot OK, so can now swap pivot rows and columns */
+
+ a[pvt + pvt * a_dim1] = a[j + j * a_dim1];
+ i__2 = j - 1;
+ sswap_(&i__2, &a[j * a_dim1 + 1], &c__1, &a[pvt * a_dim1 + 1],
+ &c__1);
+ if (pvt < *n) {
+ i__2 = *n - pvt;
+ sswap_(&i__2, &a[j + (pvt + 1) * a_dim1], lda, &a[pvt + (
+ pvt + 1) * a_dim1], lda);
+ }
+ i__2 = pvt - j - 1;
+ sswap_(&i__2, &a[j + (j + 1) * a_dim1], lda, &a[j + 1 + pvt *
+ a_dim1], &c__1);
+
+/* Swap dot products and PIV */
+
+ stemp = work[j];
+ work[j] = work[pvt];
+ work[pvt] = stemp;
+ itemp = piv[pvt];
+ piv[pvt] = piv[j];
+ piv[j] = itemp;
+ }
+
+ ajj = sqrt(ajj);
+ a[j + j * a_dim1] = ajj;
+
+/* Compute elements J+1:N of row J */
+
+ if (j < *n) {
+ i__2 = j - 1;
+ i__3 = *n - j;
+ sgemv_("Trans", &i__2, &i__3, &c_b16, &a[(j + 1) * a_dim1 + 1]
+, lda, &a[j * a_dim1 + 1], &c__1, &c_b18, &a[j + (j +
+ 1) * a_dim1], lda);
+ i__2 = *n - j;
+ r__1 = 1.f / ajj;
+ sscal_(&i__2, &r__1, &a[j + (j + 1) * a_dim1], lda);
+ }
+
+/* L130: */
+ }
+
+ } else {
+
+/* Compute the Cholesky factorization P' * A * P = L * L' */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Find pivot, test for exit, else swap rows and columns */
+/* Update dot products, compute possible pivots which are */
+/* stored in the second half of WORK */
+
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+
+ if (j > 1) {
+/* Computing 2nd power */
+ r__1 = a[i__ + (j - 1) * a_dim1];
+ work[i__] += r__1 * r__1;
+ }
+ work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__];
+
+/* L140: */
+ }
+
+ if (j > 1) {
+ maxlocval = (*n << 1) - (*n + j) + 1;
+ itemp = smaxloc_(&work[*n + j], &maxlocval);
+ pvt = itemp + j - 1;
+ ajj = work[*n + pvt];
+ if (ajj <= sstop || sisnan_(&ajj)) {
+ a[j + j * a_dim1] = ajj;
+ goto L160;
+ }
+ }
+
+ if (j != pvt) {
+
+/* Pivot OK, so can now swap pivot rows and columns */
+
+ a[pvt + pvt * a_dim1] = a[j + j * a_dim1];
+ i__2 = j - 1;
+ sswap_(&i__2, &a[j + a_dim1], lda, &a[pvt + a_dim1], lda);
+ if (pvt < *n) {
+ i__2 = *n - pvt;
+ sswap_(&i__2, &a[pvt + 1 + j * a_dim1], &c__1, &a[pvt + 1
+ + pvt * a_dim1], &c__1);
+ }
+ i__2 = pvt - j - 1;
+ sswap_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &a[pvt + (j + 1)
+ * a_dim1], lda);
+
+/* Swap dot products and PIV */
+
+ stemp = work[j];
+ work[j] = work[pvt];
+ work[pvt] = stemp;
+ itemp = piv[pvt];
+ piv[pvt] = piv[j];
+ piv[j] = itemp;
+ }
+
+ ajj = sqrt(ajj);
+ a[j + j * a_dim1] = ajj;
+
+/* Compute elements J+1:N of column J */
+
+ if (j < *n) {
+ i__2 = *n - j;
+ i__3 = j - 1;
+ sgemv_("No Trans", &i__2, &i__3, &c_b16, &a[j + 1 + a_dim1],
+ lda, &a[j + a_dim1], lda, &c_b18, &a[j + 1 + j *
+ a_dim1], &c__1);
+ i__2 = *n - j;
+ r__1 = 1.f / ajj;
+ sscal_(&i__2, &r__1, &a[j + 1 + j * a_dim1], &c__1);
+ }
+
+/* L150: */
+ }
+
+ }
+
+/* Ran to completion, A has full rank */
+
+ *rank = *n;
+
+ goto L170;
+L160:
+
+/* Rank is number of steps completed. Set INFO = 1 to signal */
+/* that the factorization cannot be used to solve a system. */
+
+ *rank = j - 1;
+ *info = 1;
+
+L170:
+ return 0;
+
+/* End of SPSTF2 */
+
+} /* spstf2_ */
diff --git a/SRC/spstrf.c b/SRC/spstrf.c
new file mode 100644
index 0000000..0f46f2f
--- /dev/null
+++ b/SRC/spstrf.c
@@ -0,0 +1,466 @@
+/* spstrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b22 = -1.f;
+static real c_b24 = 1.f;
+
+/* Subroutine */ int spstrf_(char *uplo, integer *n, real *a, integer *lda,
+ integer *piv, integer *rank, real *tol, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, maxlocval, jb, nb;
+ real ajj;
+ integer pvt;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ integer itemp;
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ real stemp;
+ logical upper;
+ extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
+ integer *);
+ real sstop;
+ extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *,
+ real *, real *, integer *, real *, real *, integer *), spstf2_(char *, integer *, real *, integer *, integer *,
+ integer *, real *, real *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern logical sisnan_(real *);
+ extern integer smaxloc_(real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPSTRF computes the Cholesky factorization with complete */
+/* pivoting of a real symmetric positive semidefinite matrix A. */
+
+/* The factorization has the form */
+/* P' * A * P = U' * U , if UPLO = 'U', */
+/* P' * A * P = L * L', if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular, and */
+/* P is stored as vector PIV. */
+
+/* This algorithm does not attempt to check that A is positive */
+/* semidefinite. This version of the algorithm calls level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n by n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n by n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization as above. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* PIV (output) INTEGER array, dimension (N) */
+/* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. */
+
+/* RANK (output) INTEGER */
+/* The rank of A given by the number of steps the algorithm */
+/* completed. */
+
+/* TOL (input) REAL */
+/* User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) ) */
+/* will be used. The algorithm terminates at the (K-1)st step */
+/* if the pivot <= TOL. */
+
+/* WORK REAL array, dimension (2*N) */
+/* Work space. */
+
+/* INFO (output) INTEGER */
+/* < 0: If INFO = -K, the K-th argument had an illegal value, */
+/* = 0: algorithm completed successfully, and */
+/* > 0: the matrix A is either rank deficient with computed rank */
+/* as returned in RANK, or is indefinite. See Section 7 of */
+/* LAPACK Working Note #161 for further information. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --work;
+ --piv;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPSTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get block size */
+
+ nb = ilaenv_(&c__1, "SPOTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code */
+
+ spstf2_(uplo, n, &a[a_dim1 + 1], lda, &piv[1], rank, tol, &work[1],
+ info);
+ goto L200;
+
+ } else {
+
+/* Initialize PIV */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ piv[i__] = i__;
+/* L100: */
+ }
+
+/* Compute stopping value */
+
+ pvt = 1;
+ ajj = a[pvt + pvt * a_dim1];
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ if (a[i__ + i__ * a_dim1] > ajj) {
+ pvt = i__;
+ ajj = a[pvt + pvt * a_dim1];
+ }
+ }
+ if (ajj == 0.f || sisnan_(&ajj)) {
+ *rank = 0;
+ *info = 1;
+ goto L200;
+ }
+
+/* Compute stopping value if not supplied */
+
+ if (*tol < 0.f) {
+ sstop = *n * slamch_("Epsilon") * ajj;
+ } else {
+ sstop = *tol;
+ }
+
+
+ if (upper) {
+
+/* Compute the Cholesky factorization P' * A * P = U' * U */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+
+/* Account for last block not being NB wide */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - k + 1;
+ jb = min(i__3,i__4);
+
+/* Set relevant part of first half of WORK to zero, */
+/* holds dot products */
+
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ work[i__] = 0.f;
+/* L110: */
+ }
+
+ i__3 = k + jb - 1;
+ for (j = k; j <= i__3; ++j) {
+
+/* Find pivot, test for exit, else swap rows and columns */
+/* Update dot products, compute possible pivots which are */
+/* stored in the second half of WORK */
+
+ i__4 = *n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+
+ if (j > k) {
+/* Computing 2nd power */
+ r__1 = a[j - 1 + i__ * a_dim1];
+ work[i__] += r__1 * r__1;
+ }
+ work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__];
+
+/* L120: */
+ }
+
+ if (j > 1) {
+ maxlocval = (*n << 1) - (*n + j) + 1;
+ itemp = smaxloc_(&work[*n + j], &maxlocval);
+ pvt = itemp + j - 1;
+ ajj = work[*n + pvt];
+ if (ajj <= sstop || sisnan_(&ajj)) {
+ a[j + j * a_dim1] = ajj;
+ goto L190;
+ }
+ }
+
+ if (j != pvt) {
+
+/* Pivot OK, so can now swap pivot rows and columns */
+
+ a[pvt + pvt * a_dim1] = a[j + j * a_dim1];
+ i__4 = j - 1;
+ sswap_(&i__4, &a[j * a_dim1 + 1], &c__1, &a[pvt *
+ a_dim1 + 1], &c__1);
+ if (pvt < *n) {
+ i__4 = *n - pvt;
+ sswap_(&i__4, &a[j + (pvt + 1) * a_dim1], lda, &a[
+ pvt + (pvt + 1) * a_dim1], lda);
+ }
+ i__4 = pvt - j - 1;
+ sswap_(&i__4, &a[j + (j + 1) * a_dim1], lda, &a[j + 1
+ + pvt * a_dim1], &c__1);
+
+/* Swap dot products and PIV */
+
+ stemp = work[j];
+ work[j] = work[pvt];
+ work[pvt] = stemp;
+ itemp = piv[pvt];
+ piv[pvt] = piv[j];
+ piv[j] = itemp;
+ }
+
+ ajj = sqrt(ajj);
+ a[j + j * a_dim1] = ajj;
+
+/* Compute elements J+1:N of row J. */
+
+ if (j < *n) {
+ i__4 = j - k;
+ i__5 = *n - j;
+ sgemv_("Trans", &i__4, &i__5, &c_b22, &a[k + (j + 1) *
+ a_dim1], lda, &a[k + j * a_dim1], &c__1, &
+ c_b24, &a[j + (j + 1) * a_dim1], lda);
+ i__4 = *n - j;
+ r__1 = 1.f / ajj;
+ sscal_(&i__4, &r__1, &a[j + (j + 1) * a_dim1], lda);
+ }
+
+/* L130: */
+ }
+
+/* Update trailing matrix, J already incremented */
+
+ if (k + jb <= *n) {
+ i__3 = *n - j + 1;
+ ssyrk_("Upper", "Trans", &i__3, &jb, &c_b22, &a[k + j *
+ a_dim1], lda, &c_b24, &a[j + j * a_dim1], lda);
+ }
+
+/* L140: */
+ }
+
+ } else {
+
+/* Compute the Cholesky factorization P' * A * P = L * L' */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+
+/* Account for last block not being NB wide */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - k + 1;
+ jb = min(i__3,i__4);
+
+/* Set relevant part of first half of WORK to zero, */
+/* holds dot products */
+
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ work[i__] = 0.f;
+/* L150: */
+ }
+
+ i__3 = k + jb - 1;
+ for (j = k; j <= i__3; ++j) {
+
+/* Find pivot, test for exit, else swap rows and columns */
+/* Update dot products, compute possible pivots which are */
+/* stored in the second half of WORK */
+
+ i__4 = *n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+
+ if (j > k) {
+/* Computing 2nd power */
+ r__1 = a[i__ + (j - 1) * a_dim1];
+ work[i__] += r__1 * r__1;
+ }
+ work[*n + i__] = a[i__ + i__ * a_dim1] - work[i__];
+
+/* L160: */
+ }
+
+ if (j > 1) {
+ maxlocval = (*n << 1) - (*n + j) + 1;
+ itemp = smaxloc_(&work[*n + j], &maxlocval);
+ pvt = itemp + j - 1;
+ ajj = work[*n + pvt];
+ if (ajj <= sstop || sisnan_(&ajj)) {
+ a[j + j * a_dim1] = ajj;
+ goto L190;
+ }
+ }
+
+ if (j != pvt) {
+
+/* Pivot OK, so can now swap pivot rows and columns */
+
+ a[pvt + pvt * a_dim1] = a[j + j * a_dim1];
+ i__4 = j - 1;
+ sswap_(&i__4, &a[j + a_dim1], lda, &a[pvt + a_dim1],
+ lda);
+ if (pvt < *n) {
+ i__4 = *n - pvt;
+ sswap_(&i__4, &a[pvt + 1 + j * a_dim1], &c__1, &a[
+ pvt + 1 + pvt * a_dim1], &c__1);
+ }
+ i__4 = pvt - j - 1;
+ sswap_(&i__4, &a[j + 1 + j * a_dim1], &c__1, &a[pvt +
+ (j + 1) * a_dim1], lda);
+
+/* Swap dot products and PIV */
+
+ stemp = work[j];
+ work[j] = work[pvt];
+ work[pvt] = stemp;
+ itemp = piv[pvt];
+ piv[pvt] = piv[j];
+ piv[j] = itemp;
+ }
+
+ ajj = sqrt(ajj);
+ a[j + j * a_dim1] = ajj;
+
+/* Compute elements J+1:N of column J. */
+
+ if (j < *n) {
+ i__4 = *n - j;
+ i__5 = j - k;
+ sgemv_("No Trans", &i__4, &i__5, &c_b22, &a[j + 1 + k
+ * a_dim1], lda, &a[j + k * a_dim1], lda, &
+ c_b24, &a[j + 1 + j * a_dim1], &c__1);
+ i__4 = *n - j;
+ r__1 = 1.f / ajj;
+ sscal_(&i__4, &r__1, &a[j + 1 + j * a_dim1], &c__1);
+ }
+
+/* L170: */
+ }
+
+/* Update trailing matrix, J already incremented */
+
+ if (k + jb <= *n) {
+ i__3 = *n - j + 1;
+ ssyrk_("Lower", "No Trans", &i__3, &jb, &c_b22, &a[j + k *
+ a_dim1], lda, &c_b24, &a[j + j * a_dim1], lda);
+ }
+
+/* L180: */
+ }
+
+ }
+ }
+
+/* Ran to completion, A has full rank */
+
+ *rank = *n;
+
+ goto L200;
+L190:
+
+/* Rank is the number of steps completed. Set INFO = 1 to signal */
+/* that the factorization cannot be used to solve a system. */
+
+ *rank = j - 1;
+ *info = 1;
+
+L200:
+ return 0;
+
+/* End of SPSTRF */
+
+} /* spstrf_ */
diff --git a/SRC/sptcon.c b/SRC/sptcon.c
new file mode 100644
index 0000000..1861ebe
--- /dev/null
+++ b/SRC/sptcon.c
@@ -0,0 +1,184 @@
+/* sptcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sptcon_(integer *n, real *d__, real *e, real *anorm,
+ real *rcond, real *work, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1;
+
+ /* Local variables */
+ integer i__, ix;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ real ainvnm;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPTCON computes the reciprocal of the condition number (in the */
+/* 1-norm) of a real symmetric positive definite tridiagonal matrix */
+/* using the factorization A = L*D*L**T or A = U**T*D*U computed by */
+/* SPTTRF. */
+
+/* Norm(inv(A)) is computed by a direct method, and the reciprocal of */
+/* the condition number is computed as */
+/* RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the diagonal matrix D from the */
+/* factorization of A, as computed by SPTTRF. */
+
+/* E (input) REAL array, dimension (N-1) */
+/* The (n-1) off-diagonal elements of the unit bidiagonal factor */
+/* U or L from the factorization of A, as computed by SPTTRF. */
+
+/* ANORM (input) REAL */
+/* The 1-norm of the original matrix A. */
+
+/* RCOND (output) REAL */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the */
+/* 1-norm of inv(A) computed in this routine. */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The method used is described in Nicholas J. Higham, "Efficient */
+/* Algorithms for Computing the Condition Number of a Tridiagonal */
+/* Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ --work;
+ --e;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*anorm < 0.f) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPTCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.f;
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ } else if (*anorm == 0.f) {
+ return 0;
+ }
+
+/* Check that D(1:N) is positive. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (d__[i__] <= 0.f) {
+ return 0;
+ }
+/* L10: */
+ }
+
+/* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by */
+
+/* m(i,j) = abs(A(i,j)), i = j, */
+/* m(i,j) = -abs(A(i,j)), i .ne. j, */
+
+/* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'. */
+
+/* Solve M(L) * x = e. */
+
+ work[1] = 1.f;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ work[i__] = work[i__ - 1] * (r__1 = e[i__ - 1], dabs(r__1)) + 1.f;
+/* L20: */
+ }
+
+/* Solve D * M(L)' * x = b. */
+
+ work[*n] /= d__[*n];
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ work[i__] = work[i__] / d__[i__] + work[i__ + 1] * (r__1 = e[i__],
+ dabs(r__1));
+/* L30: */
+ }
+
+/* Compute AINVNM = max(x(i)), 1<=i<=n. */
+
+ ix = isamax_(n, &work[1], &c__1);
+ ainvnm = (r__1 = work[ix], dabs(r__1));
+
+/* Compute the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / ainvnm / *anorm;
+ }
+
+ return 0;
+
+/* End of SPTCON */
+
+} /* sptcon_ */
diff --git a/SRC/spteqr.c b/SRC/spteqr.c
new file mode 100644
index 0000000..90fd206
--- /dev/null
+++ b/SRC/spteqr.c
@@ -0,0 +1,240 @@
+/* spteqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b7 = 0.f;
+static real c_b8 = 1.f;
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int spteqr_(char *compz, integer *n, real *d__, real *e,
+ real *z__, integer *ldz, real *work, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real c__[1] /* was [1][1] */;
+ integer i__;
+ real vt[1] /* was [1][1] */;
+ integer nru;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), slaset_(
+ char *, integer *, integer *, real *, real *, real *, integer *), sbdsqr_(char *, integer *, integer *, integer *, integer
+ *, real *, real *, real *, integer *, real *, integer *, real *,
+ integer *, real *, integer *);
+ integer icompz;
+ extern /* Subroutine */ int spttrf_(integer *, real *, real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPTEQR computes all eigenvalues and, optionally, eigenvectors of a */
+/* symmetric positive definite tridiagonal matrix by first factoring the */
+/* matrix using SPTTRF, and then calling SBDSQR to compute the singular */
+/* values of the bidiagonal factor. */
+
+/* This routine computes the eigenvalues of the positive definite */
+/* tridiagonal matrix to high relative accuracy. This means that if the */
+/* eigenvalues range over many orders of magnitude in size, then the */
+/* small eigenvalues and corresponding eigenvectors will be computed */
+/* more accurately than, for example, with the standard QR method. */
+
+/* The eigenvectors of a full or band symmetric positive definite matrix */
+/* can also be found if SSYTRD, SSPTRD, or SSBTRD has been used to */
+/* reduce this matrix to tridiagonal form. (The reduction to tridiagonal */
+/* form, however, may preclude the possibility of obtaining high */
+/* relative accuracy in the small eigenvalues of the original matrix, if */
+/* these eigenvalues range over many orders of magnitude.) */
+
+/* Arguments */
+/* ========= */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only. */
+/* = 'V': Compute eigenvectors of original symmetric */
+/* matrix also. Array Z contains the orthogonal */
+/* matrix used to reduce the original matrix to */
+/* tridiagonal form. */
+/* = 'I': Compute eigenvectors of tridiagonal matrix also. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the n diagonal elements of the tridiagonal */
+/* matrix. */
+/* On normal exit, D contains the eigenvalues, in descending */
+/* order. */
+
+/* E (input/output) REAL array, dimension (N-1) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix. */
+/* On exit, E has been destroyed. */
+
+/* Z (input/output) REAL array, dimension (LDZ, N) */
+/* On entry, if COMPZ = 'V', the orthogonal matrix used in the */
+/* reduction to tridiagonal form. */
+/* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the */
+/* original symmetric matrix; */
+/* if COMPZ = 'I', the orthonormal eigenvectors of the */
+/* tridiagonal matrix. */
+/* If INFO > 0 on exit, Z contains the eigenvectors associated */
+/* with only the stored eigenvalues. */
+/* If COMPZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* COMPZ = 'V' or 'I', LDZ >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (4*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, and i is: */
+/* <= N the Cholesky factorization of the matrix could */
+/* not be performed because the i-th principal minor */
+/* was not positive definite. */
+/* > N the SVD algorithm failed to converge; */
+/* if INFO = N+i, i off-diagonal elements of the */
+/* bidiagonal factor did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+ if (lsame_(compz, "N")) {
+ icompz = 0;
+ } else if (lsame_(compz, "V")) {
+ icompz = 1;
+ } else if (lsame_(compz, "I")) {
+ icompz = 2;
+ } else {
+ icompz = -1;
+ }
+ if (icompz < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPTEQR", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (icompz > 0) {
+ z__[z_dim1 + 1] = 1.f;
+ }
+ return 0;
+ }
+ if (icompz == 2) {
+ slaset_("Full", n, n, &c_b7, &c_b8, &z__[z_offset], ldz);
+ }
+
+/* Call SPTTRF to factor the matrix. */
+
+ spttrf_(n, &d__[1], &e[1], info);
+ if (*info != 0) {
+ return 0;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = sqrt(d__[i__]);
+/* L10: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ e[i__] *= d__[i__];
+/* L20: */
+ }
+
+/* Call SBDSQR to compute the singular values/vectors of the */
+/* bidiagonal factor. */
+
+ if (icompz > 0) {
+ nru = *n;
+ } else {
+ nru = 0;
+ }
+ sbdsqr_("Lower", n, &c__0, &nru, &c__0, &d__[1], &e[1], vt, &c__1, &z__[
+ z_offset], ldz, c__, &c__1, &work[1], info);
+
+/* Square the singular values. */
+
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] *= d__[i__];
+/* L30: */
+ }
+ } else {
+ *info = *n + *info;
+ }
+
+ return 0;
+
+/* End of SPTEQR */
+
+} /* spteqr_ */
diff --git a/SRC/sptrfs.c b/SRC/sptrfs.c
new file mode 100644
index 0000000..f6d9adb
--- /dev/null
+++ b/SRC/sptrfs.c
@@ -0,0 +1,365 @@
+/* sptrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b11 = 1.f;
+
+/* Subroutine */ int sptrfs_(integer *n, integer *nrhs, real *d__, real *e,
+ real *df, real *ef, real *b, integer *ldb, real *x, integer *ldx,
+ real *ferr, real *berr, real *work, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j;
+ real s, bi, cx, dx, ex;
+ integer ix, nz;
+ real eps, safe1, safe2;
+ integer count;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ real lstres;
+ extern /* Subroutine */ int spttrs_(integer *, integer *, real *, real *,
+ real *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPTRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric positive definite */
+/* and tridiagonal, and provides error bounds and backward error */
+/* estimates for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) REAL array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
+
+/* DF (input) REAL array, dimension (N) */
+/* The n diagonal elements of the diagonal matrix D from the */
+/* factorization computed by SPTTRF. */
+
+/* EF (input) REAL array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the unit bidiagonal factor */
+/* L from the factorization computed by SPTTRF. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) REAL array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by SPTTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) REAL array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --df;
+ --ef;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*ldx < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPTRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = 4;
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.f;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X. Also compute */
+/* abs(A)*abs(x) + abs(b) for use in the backward error bound. */
+
+ if (*n == 1) {
+ bi = b[j * b_dim1 + 1];
+ dx = d__[1] * x[j * x_dim1 + 1];
+ work[*n + 1] = bi - dx;
+ work[1] = dabs(bi) + dabs(dx);
+ } else {
+ bi = b[j * b_dim1 + 1];
+ dx = d__[1] * x[j * x_dim1 + 1];
+ ex = e[1] * x[j * x_dim1 + 2];
+ work[*n + 1] = bi - dx - ex;
+ work[1] = dabs(bi) + dabs(dx) + dabs(ex);
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ bi = b[i__ + j * b_dim1];
+ cx = e[i__ - 1] * x[i__ - 1 + j * x_dim1];
+ dx = d__[i__] * x[i__ + j * x_dim1];
+ ex = e[i__] * x[i__ + 1 + j * x_dim1];
+ work[*n + i__] = bi - cx - dx - ex;
+ work[i__] = dabs(bi) + dabs(cx) + dabs(dx) + dabs(ex);
+/* L30: */
+ }
+ bi = b[*n + j * b_dim1];
+ cx = e[*n - 1] * x[*n - 1 + j * x_dim1];
+ dx = d__[*n] * x[*n + j * x_dim1];
+ work[*n + *n] = bi - cx - dx;
+ work[*n] = dabs(bi) + dabs(cx) + dabs(dx);
+ }
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[
+ i__];
+ s = dmax(r__2,r__3);
+ } else {
+/* Computing MAX */
+ r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1)
+ / (work[i__] + safe1);
+ s = dmax(r__2,r__3);
+ }
+/* L40: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ spttrs_(n, &c__1, &df[1], &ef[1], &work[*n + 1], n, info);
+ saxpy_(n, &c_b11, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
+ ;
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L50: */
+ }
+ ix = isamax_(n, &work[1], &c__1);
+ ferr[j] = work[ix];
+
+/* Estimate the norm of inv(A). */
+
+/* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by */
+
+/* m(i,j) = abs(A(i,j)), i = j, */
+/* m(i,j) = -abs(A(i,j)), i .ne. j, */
+
+/* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'. */
+
+/* Solve M(L) * x = e. */
+
+ work[1] = 1.f;
+ i__2 = *n;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ work[i__] = work[i__ - 1] * (r__1 = ef[i__ - 1], dabs(r__1)) +
+ 1.f;
+/* L60: */
+ }
+
+/* Solve D * M(L)' * x = b. */
+
+ work[*n] /= df[*n];
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ work[i__] = work[i__] / df[i__] + work[i__ + 1] * (r__1 = ef[i__],
+ dabs(r__1));
+/* L70: */
+ }
+
+/* Compute norm(inv(A)) = max(x(i)), 1<=i<=n. */
+
+ ix = isamax_(n, &work[1], &c__1);
+ ferr[j] *= (r__1 = work[ix], dabs(r__1));
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], dabs(r__1));
+ lstres = dmax(r__2,r__3);
+/* L80: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L90: */
+ }
+
+ return 0;
+
+/* End of SPTRFS */
+
+} /* sptrfs_ */
diff --git a/SRC/sptsv.c b/SRC/sptsv.c
new file mode 100644
index 0000000..f39fe1e
--- /dev/null
+++ b/SRC/sptsv.c
@@ -0,0 +1,129 @@
+/* sptsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sptsv_(integer *n, integer *nrhs, real *d__, real *e,
+ real *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int xerbla_(char *, integer *), spttrf_(
+ integer *, real *, real *, integer *), spttrs_(integer *, integer
+ *, real *, real *, real *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPTSV computes the solution to a real system of linear equations */
+/* A*X = B, where A is an N-by-N symmetric positive definite tridiagonal */
+/* matrix, and X and B are N-by-NRHS matrices. */
+
+/* A is factored as A = L*D*L**T, and the factored form of A is then */
+/* used to solve the system of equations. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the n diagonal elements of the tridiagonal matrix */
+/* A. On exit, the n diagonal elements of the diagonal matrix */
+/* D from the factorization A = L*D*L**T. */
+
+/* E (input/output) REAL array, dimension (N-1) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix A. On exit, the (n-1) subdiagonal elements of the */
+/* unit bidiagonal factor L from the L*D*L**T factorization of */
+/* A. (E can also be regarded as the superdiagonal of the unit */
+/* bidiagonal factor U from the U**T*D*U factorization of A.) */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the solution has not been */
+/* computed. The factorization has not been completed */
+/* unless i = N. */
+
+/* ===================================================================== */
+
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*ldb < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPTSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the L*D*L' (or U'*D*U) factorization of A. */
+
+ spttrf_(n, &d__[1], &e[1], info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ spttrs_(n, nrhs, &d__[1], &e[1], &b[b_offset], ldb, info);
+ }
+ return 0;
+
+/* End of SPTSV */
+
+} /* sptsv_ */
diff --git a/SRC/sptsvx.c b/SRC/sptsvx.c
new file mode 100644
index 0000000..d8f5203
--- /dev/null
+++ b/SRC/sptsvx.c
@@ -0,0 +1,279 @@
+/* sptsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sptsvx_(char *fact, integer *n, integer *nrhs, real *d__,
+ real *e, real *df, real *ef, real *b, integer *ldb, real *x, integer
+ *ldx, real *rcond, real *ferr, real *berr, real *work, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ extern doublereal slamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *), slacpy_(
+ char *, integer *, integer *, real *, integer *, real *, integer *
+);
+ extern doublereal slanst_(char *, integer *, real *, real *);
+ extern /* Subroutine */ int sptcon_(integer *, real *, real *, real *,
+ real *, real *, integer *), sptrfs_(integer *, integer *, real *,
+ real *, real *, real *, real *, integer *, real *, integer *,
+ real *, real *, real *, integer *), spttrf_(integer *, real *,
+ real *, integer *), spttrs_(integer *, integer *, real *, real *,
+ real *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPTSVX uses the factorization A = L*D*L**T to compute the solution */
+/* to a real system of linear equations A*X = B, where A is an N-by-N */
+/* symmetric positive definite tridiagonal matrix and X and B are */
+/* N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L */
+/* is a unit lower bidiagonal matrix and D is diagonal. The */
+/* factorization can also be regarded as having the form */
+/* A = U**T*D*U. */
+
+/* 2. If the leading i-by-i principal minor is not positive definite, */
+/* then the routine returns with INFO = i. Otherwise, the factored */
+/* form of A is used to estimate the condition number of the matrix */
+/* A. If the reciprocal of the condition number is less than machine */
+/* precision, INFO = N+1 is returned as a warning, but the routine */
+/* still goes on to solve for X and compute error bounds as */
+/* described below. */
+
+/* 3. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 4. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of A has been */
+/* supplied on entry. */
+/* = 'F': On entry, DF and EF contain the factored form of A. */
+/* D, E, DF, and EF will not be modified. */
+/* = 'N': The matrix A will be copied to DF and EF and */
+/* factored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) REAL array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
+
+/* DF (input or output) REAL array, dimension (N) */
+/* If FACT = 'F', then DF is an input argument and on entry */
+/* contains the n diagonal elements of the diagonal matrix D */
+/* from the L*D*L**T factorization of A. */
+/* If FACT = 'N', then DF is an output argument and on exit */
+/* contains the n diagonal elements of the diagonal matrix D */
+/* from the L*D*L**T factorization of A. */
+
+/* EF (input or output) REAL array, dimension (N-1) */
+/* If FACT = 'F', then EF is an input argument and on entry */
+/* contains the (n-1) subdiagonal elements of the unit */
+/* bidiagonal factor L from the L*D*L**T factorization of A. */
+/* If FACT = 'N', then EF is an output argument and on exit */
+/* contains the (n-1) subdiagonal elements of the unit */
+/* bidiagonal factor L from the L*D*L**T factorization of A. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) REAL array, dimension (LDX,NRHS) */
+/* If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The reciprocal condition number of the matrix A. If RCOND */
+/* is less than the machine precision (in particular, if */
+/* RCOND = 0), the matrix is singular to working precision. */
+/* This condition is indicated by a return code of INFO > 0. */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in any */
+/* element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) REAL array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: the leading minor of order i of A is */
+/* not positive definite, so the factorization */
+/* could not be completed, and the solution has not */
+/* been computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --df;
+ --ef;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ if (! nofact && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPTSVX", &i__1);
+ return 0;
+ }
+
+ if (nofact) {
+
+/* Compute the L*D*L' (or U'*D*U) factorization of A. */
+
+ scopy_(n, &d__[1], &c__1, &df[1], &c__1);
+ if (*n > 1) {
+ i__1 = *n - 1;
+ scopy_(&i__1, &e[1], &c__1, &ef[1], &c__1);
+ }
+ spttrf_(n, &df[1], &ef[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.f;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = slanst_("1", n, &d__[1], &e[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ sptcon_(n, &df[1], &ef[1], &anorm, rcond, &work[1], info);
+
+/* Compute the solution vectors X. */
+
+ slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ spttrs_(n, nrhs, &df[1], &ef[1], &x[x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solutions and */
+/* compute error bounds and backward error estimates for them. */
+
+ sptrfs_(n, nrhs, &d__[1], &e[1], &df[1], &ef[1], &b[b_offset], ldb, &x[
+ x_offset], ldx, &ferr[1], &berr[1], &work[1], info);
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < slamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of SPTSVX */
+
+} /* sptsvx_ */
diff --git a/SRC/spttrf.c b/SRC/spttrf.c
new file mode 100644
index 0000000..f3cda23
--- /dev/null
+++ b/SRC/spttrf.c
@@ -0,0 +1,180 @@
+/* spttrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int spttrf_(integer *n, real *d__, real *e, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, i4;
+ real ei;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPTTRF computes the L*D*L' factorization of a real symmetric */
+/* positive definite tridiagonal matrix A. The factorization may also */
+/* be regarded as having the form A = U'*D*U. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the n diagonal elements of the tridiagonal matrix */
+/* A. On exit, the n diagonal elements of the diagonal matrix */
+/* D from the L*D*L' factorization of A. */
+
+/* E (input/output) REAL array, dimension (N-1) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix A. On exit, the (n-1) subdiagonal elements of the */
+/* unit bidiagonal factor L from the L*D*L' factorization of A. */
+/* E can also be regarded as the superdiagonal of the unit */
+/* bidiagonal factor U from the U'*D*U factorization of A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, the leading minor of order k is not */
+/* positive definite; if k < N, the factorization could not */
+/* be completed, while if k = N, the factorization was */
+/* completed, but D(N) <= 0. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --e;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ i__1 = -(*info);
+ xerbla_("SPTTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Compute the L*D*L' (or U'*D*U) factorization of A. */
+
+ i4 = (*n - 1) % 4;
+ i__1 = i4;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (d__[i__] <= 0.f) {
+ *info = i__;
+ goto L30;
+ }
+ ei = e[i__];
+ e[i__] = ei / d__[i__];
+ d__[i__ + 1] -= e[i__] * ei;
+/* L10: */
+ }
+
+ i__1 = *n - 4;
+ for (i__ = i4 + 1; i__ <= i__1; i__ += 4) {
+
+/* Drop out of the loop if d(i) <= 0: the matrix is not positive */
+/* definite. */
+
+ if (d__[i__] <= 0.f) {
+ *info = i__;
+ goto L30;
+ }
+
+/* Solve for e(i) and d(i+1). */
+
+ ei = e[i__];
+ e[i__] = ei / d__[i__];
+ d__[i__ + 1] -= e[i__] * ei;
+
+ if (d__[i__ + 1] <= 0.f) {
+ *info = i__ + 1;
+ goto L30;
+ }
+
+/* Solve for e(i+1) and d(i+2). */
+
+ ei = e[i__ + 1];
+ e[i__ + 1] = ei / d__[i__ + 1];
+ d__[i__ + 2] -= e[i__ + 1] * ei;
+
+ if (d__[i__ + 2] <= 0.f) {
+ *info = i__ + 2;
+ goto L30;
+ }
+
+/* Solve for e(i+2) and d(i+3). */
+
+ ei = e[i__ + 2];
+ e[i__ + 2] = ei / d__[i__ + 2];
+ d__[i__ + 3] -= e[i__ + 2] * ei;
+
+ if (d__[i__ + 3] <= 0.f) {
+ *info = i__ + 3;
+ goto L30;
+ }
+
+/* Solve for e(i+3) and d(i+4). */
+
+ ei = e[i__ + 3];
+ e[i__ + 3] = ei / d__[i__ + 3];
+ d__[i__ + 4] -= e[i__ + 3] * ei;
+/* L20: */
+ }
+
+/* Check d(n) for positive definiteness. */
+
+ if (d__[*n] <= 0.f) {
+ *info = *n;
+ }
+
+L30:
+ return 0;
+
+/* End of SPTTRF */
+
+} /* spttrf_ */
diff --git a/SRC/spttrs.c b/SRC/spttrs.c
new file mode 100644
index 0000000..bac3da4
--- /dev/null
+++ b/SRC/spttrs.c
@@ -0,0 +1,156 @@
+/* spttrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int spttrs_(integer *n, integer *nrhs, real *d__, real *e,
+ real *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer j, jb, nb;
+ extern /* Subroutine */ int sptts2_(integer *, integer *, real *, real *,
+ real *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPTTRS solves a tridiagonal system of the form */
+/* A * X = B */
+/* using the L*D*L' factorization of A computed by SPTTRF. D is a */
+/* diagonal matrix specified in the vector D, L is a unit bidiagonal */
+/* matrix whose subdiagonal is specified in the vector E, and X and B */
+/* are N by NRHS matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the tridiagonal matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the diagonal matrix D from the */
+/* L*D*L' factorization of A. */
+
+/* E (input) REAL array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the unit bidiagonal factor */
+/* L from the L*D*L' factorization of A. E can also be regarded */
+/* as the superdiagonal of the unit bidiagonal factor U from the */
+/* factorization A = U'*D*U. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors B for the system of */
+/* linear equations. */
+/* On exit, the solution vectors, X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*ldb < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SPTTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+/* Determine the number of right-hand sides to solve at a time. */
+
+ if (*nrhs == 1) {
+ nb = 1;
+ } else {
+/* Computing MAX */
+ i__1 = 1, i__2 = ilaenv_(&c__1, "SPTTRS", " ", n, nrhs, &c_n1, &c_n1);
+ nb = max(i__1,i__2);
+ }
+
+ if (nb >= *nrhs) {
+ sptts2_(n, nrhs, &d__[1], &e[1], &b[b_offset], ldb);
+ } else {
+ i__1 = *nrhs;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = *nrhs - j + 1;
+ jb = min(i__3,nb);
+ sptts2_(n, &jb, &d__[1], &e[1], &b[j * b_dim1 + 1], ldb);
+/* L10: */
+ }
+ }
+
+ return 0;
+
+/* End of SPTTRS */
+
+} /* spttrs_ */
diff --git a/SRC/sptts2.c b/SRC/sptts2.c
new file mode 100644
index 0000000..f67ca9f
--- /dev/null
+++ b/SRC/sptts2.c
@@ -0,0 +1,130 @@
+/* sptts2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sptts2_(integer *n, integer *nrhs, real *d__, real *e,
+ real *b, integer *ldb)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPTTS2 solves a tridiagonal system of the form */
+/* A * X = B */
+/* using the L*D*L' factorization of A computed by SPTTRF. D is a */
+/* diagonal matrix specified in the vector D, L is a unit bidiagonal */
+/* matrix whose subdiagonal is specified in the vector E, and X and B */
+/* are N by NRHS matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the tridiagonal matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the diagonal matrix D from the */
+/* L*D*L' factorization of A. */
+
+/* E (input) REAL array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the unit bidiagonal factor */
+/* L from the L*D*L' factorization of A. E can also be regarded */
+/* as the superdiagonal of the unit bidiagonal factor U from the */
+/* factorization A = U'*D*U. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors B for the system of */
+/* linear equations. */
+/* On exit, the solution vectors, X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*n <= 1) {
+ if (*n == 1) {
+ r__1 = 1.f / d__[1];
+ sscal_(nrhs, &r__1, &b[b_offset], ldb);
+ }
+ return 0;
+ }
+
+/* Solve A * X = B using the factorization A = L*D*L', */
+/* overwriting each right hand side vector with its solution. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve L * x = b. */
+
+ i__2 = *n;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] -= b[i__ - 1 + j * b_dim1] * e[i__ - 1];
+/* L10: */
+ }
+
+/* Solve D * L' * x = b. */
+
+ b[*n + j * b_dim1] /= d__[*n];
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ b[i__ + j * b_dim1] = b[i__ + j * b_dim1] / d__[i__] - b[i__ + 1
+ + j * b_dim1] * e[i__];
+/* L20: */
+ }
+/* L30: */
+ }
+
+ return 0;
+
+/* End of SPTTS2 */
+
+} /* sptts2_ */
diff --git a/SRC/srscl.c b/SRC/srscl.c
new file mode 100644
index 0000000..462c809
--- /dev/null
+++ b/SRC/srscl.c
@@ -0,0 +1,133 @@
+/* srscl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int srscl_(integer *n, real *sa, real *sx, integer *incx)
+{
+ real mul, cden;
+ logical done;
+ real cnum, cden1, cnum1;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ real bignum, smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SRSCL multiplies an n-element real vector x by the real scalar 1/a. */
+/* This is done without overflow or underflow as long as */
+/* the final result x/a does not overflow or underflow. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of components of the vector x. */
+
+/* SA (input) REAL */
+/* The scalar a which is used to divide each component of x. */
+/* SA must be >= 0, or the subroutine will divide by zero. */
+
+/* SX (input/output) REAL array, dimension */
+/* (1+(N-1)*abs(INCX)) */
+/* The n-element vector x. */
+
+/* INCX (input) INTEGER */
+/* The increment between successive values of the vector SX. */
+/* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --sx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Initialize the denominator to SA and the numerator to 1. */
+
+ cden = *sa;
+ cnum = 1.f;
+
+L10:
+ cden1 = cden * smlnum;
+ cnum1 = cnum / bignum;
+ if (dabs(cden1) > dabs(cnum) && cnum != 0.f) {
+
+/* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. */
+
+ mul = smlnum;
+ done = FALSE_;
+ cden = cden1;
+ } else if (dabs(cnum1) > dabs(cden)) {
+
+/* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. */
+
+ mul = bignum;
+ done = FALSE_;
+ cnum = cnum1;
+ } else {
+
+/* Multiply X by CNUM / CDEN and return. */
+
+ mul = cnum / cden;
+ done = TRUE_;
+ }
+
+/* Scale the vector X by MUL */
+
+ sscal_(n, &mul, &sx[1], incx);
+
+ if (! done) {
+ goto L10;
+ }
+
+ return 0;
+
+/* End of SRSCL */
+
+} /* srscl_ */
diff --git a/SRC/ssbev.c b/SRC/ssbev.c
new file mode 100644
index 0000000..bb0af95
--- /dev/null
+++ b/SRC/ssbev.c
@@ -0,0 +1,265 @@
+/* ssbev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b11 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int ssbev_(char *jobz, char *uplo, integer *n, integer *kd,
+ real *ab, integer *ldab, real *w, real *z__, integer *ldz, real *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, z_dim1, z_offset, i__1;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real eps;
+ integer inde;
+ real anrm;
+ integer imax;
+ real rmin, rmax, sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ logical lower, wantz;
+ integer iscale;
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ extern doublereal slansb_(char *, char *, integer *, integer *, real *,
+ integer *, real *);
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *);
+ integer indwrk;
+ extern /* Subroutine */ int ssbtrd_(char *, char *, integer *, integer *,
+ real *, integer *, real *, real *, real *, integer *, real *,
+ integer *), ssterf_(integer *, real *, real *,
+ integer *);
+ real smlnum;
+ extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *,
+ real *, integer *, real *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSBEV computes all the eigenvalues and, optionally, eigenvectors of */
+/* a real symmetric band matrix A. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) REAL array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, AB is overwritten by values generated during the */
+/* reduction to tridiagonal form. If UPLO = 'U', the first */
+/* superdiagonal and the diagonal of the tridiagonal matrix T */
+/* are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */
+/* the diagonal and first subdiagonal of T are returned in the */
+/* first two rows of AB. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD + 1. */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) REAL array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
+/* eigenvectors of the matrix A, with the i-th column of Z */
+/* holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (max(1,3*N-2)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of an intermediate tridiagonal */
+/* form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ lower = lsame_(uplo, "L");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kd < 0) {
+ *info = -4;
+ } else if (*ldab < *kd + 1) {
+ *info = -6;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -9;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSBEV ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (lower) {
+ w[1] = ab[ab_dim1 + 1];
+ } else {
+ w[1] = ab[*kd + 1 + ab_dim1];
+ }
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.f;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = slansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1]);
+ iscale = 0;
+ if (anrm > 0.f && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ if (lower) {
+ slascl_("B", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ } else {
+ slascl_("Q", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ }
+ }
+
+/* Call SSBTRD to reduce symmetric band matrix to tridiagonal form. */
+
+ inde = 1;
+ indwrk = inde + *n;
+ ssbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[
+ z_offset], ldz, &work[indwrk], &iinfo);
+
+/* For eigenvalues only, call SSTERF. For eigenvectors, call SSTEQR. */
+
+ if (! wantz) {
+ ssterf_(n, &w[1], &work[inde], info);
+ } else {
+ ssteqr_(jobz, n, &w[1], &work[inde], &z__[z_offset], ldz, &work[
+ indwrk], info);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *n;
+ } else {
+ imax = *info - 1;
+ }
+ r__1 = 1.f / sigma;
+ sscal_(&imax, &r__1, &w[1], &c__1);
+ }
+
+ return 0;
+
+/* End of SSBEV */
+
+} /* ssbev_ */
diff --git a/SRC/ssbevd.c b/SRC/ssbevd.c
new file mode 100644
index 0000000..7d58eaf
--- /dev/null
+++ b/SRC/ssbevd.c
@@ -0,0 +1,332 @@
+/* ssbevd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b11 = 1.f;
+static real c_b18 = 0.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int ssbevd_(char *jobz, char *uplo, integer *n, integer *kd,
+ real *ab, integer *ldab, real *w, real *z__, integer *ldz, real *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, z_dim1, z_offset, i__1;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real eps;
+ integer inde;
+ real anrm, rmin, rmax, sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ sgemm_(char *, char *, integer *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ integer lwmin;
+ logical lower, wantz;
+ integer indwk2, llwrk2, iscale;
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ extern doublereal slansb_(char *, char *, integer *, integer *, real *,
+ integer *, real *);
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *), sstedc_(char *, integer *, real *, real *, real *,
+ integer *, real *, integer *, integer *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *,
+ real *, integer *);
+ integer indwrk, liwmin;
+ extern /* Subroutine */ int ssbtrd_(char *, char *, integer *, integer *,
+ real *, integer *, real *, real *, real *, integer *, real *,
+ integer *), ssterf_(integer *, real *, real *,
+ integer *);
+ real smlnum;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSBEVD computes all the eigenvalues and, optionally, eigenvectors of */
+/* a real symmetric band matrix A. If eigenvectors are desired, it uses */
+/* a divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) REAL array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, AB is overwritten by values generated during the */
+/* reduction to tridiagonal form. If UPLO = 'U', the first */
+/* superdiagonal and the diagonal of the tridiagonal matrix T */
+/* are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */
+/* the diagonal and first subdiagonal of T are returned in the */
+/* first two rows of AB. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD + 1. */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) REAL array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
+/* eigenvectors of the matrix A, with the i-th column of Z */
+/* holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) REAL array, */
+/* dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* IF N <= 1, LWORK must be at least 1. */
+/* If JOBZ = 'N' and N > 2, LWORK must be at least 2*N. */
+/* If JOBZ = 'V' and N > 2, LWORK must be at least */
+/* ( 1 + 5*N + 2*N**2 ). */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK and IWORK */
+/* arrays, returns these values as the first entries of the WORK */
+/* and IWORK arrays, and no error message related to LWORK or */
+/* LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array LIWORK. */
+/* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. */
+/* If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK and IWORK arrays, and no error message related to */
+/* LWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of an intermediate tridiagonal */
+/* form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ lower = lsame_(uplo, "L");
+ lquery = *lwork == -1 || *liwork == -1;
+
+ *info = 0;
+ if (*n <= 1) {
+ liwmin = 1;
+ lwmin = 1;
+ } else {
+ if (wantz) {
+ liwmin = *n * 5 + 3;
+/* Computing 2nd power */
+ i__1 = *n;
+ lwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
+ } else {
+ liwmin = 1;
+ lwmin = *n << 1;
+ }
+ }
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kd < 0) {
+ *info = -4;
+ } else if (*ldab < *kd + 1) {
+ *info = -6;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -9;
+ }
+
+ if (*info == 0) {
+ work[1] = (real) lwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -11;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSBEVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ w[1] = ab[ab_dim1 + 1];
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.f;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = slansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1]);
+ iscale = 0;
+ if (anrm > 0.f && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ if (lower) {
+ slascl_("B", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ } else {
+ slascl_("Q", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ }
+ }
+
+/* Call SSBTRD to reduce symmetric band matrix to tridiagonal form. */
+
+ inde = 1;
+ indwrk = inde + *n;
+ indwk2 = indwrk + *n * *n;
+ llwrk2 = *lwork - indwk2 + 1;
+ ssbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[
+ z_offset], ldz, &work[indwrk], &iinfo);
+
+/* For eigenvalues only, call SSTERF. For eigenvectors, call SSTEDC. */
+
+ if (! wantz) {
+ ssterf_(n, &w[1], &work[inde], info);
+ } else {
+ sstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], &
+ llwrk2, &iwork[1], liwork, info);
+ sgemm_("N", "N", n, n, n, &c_b11, &z__[z_offset], ldz, &work[indwrk],
+ n, &c_b18, &work[indwk2], n);
+ slacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ r__1 = 1.f / sigma;
+ sscal_(n, &r__1, &w[1], &c__1);
+ }
+
+ work[1] = (real) lwmin;
+ iwork[1] = liwmin;
+ return 0;
+
+/* End of SSBEVD */
+
+} /* ssbevd_ */
diff --git a/SRC/ssbevx.c b/SRC/ssbevx.c
new file mode 100644
index 0000000..d9d1ce4
--- /dev/null
+++ b/SRC/ssbevx.c
@@ -0,0 +1,513 @@
+/* ssbevx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b14 = 1.f;
+static integer c__1 = 1;
+static real c_b34 = 0.f;
+
+/* Subroutine */ int ssbevx_(char *jobz, char *range, char *uplo, integer *n,
+ integer *kd, real *ab, integer *ldab, real *q, integer *ldq, real *vl,
+ real *vu, integer *il, integer *iu, real *abstol, integer *m, real *
+ w, real *z__, integer *ldz, real *work, integer *iwork, integer *
+ ifail, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, q_dim1, q_offset, z_dim1, z_offset, i__1,
+ i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, jj;
+ real eps, vll, vuu, tmp1;
+ integer indd, inde;
+ real anrm;
+ integer imax;
+ real rmin, rmax;
+ logical test;
+ integer itmp1, indee;
+ real sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ char order[1];
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ logical lower;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), sswap_(integer *, real *, integer *, real *, integer *
+);
+ logical wantz, alleig, indeig;
+ integer iscale, indibl;
+ logical valeig;
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real abstll, bignum;
+ extern doublereal slansb_(char *, char *, integer *, integer *, real *,
+ integer *, real *);
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *);
+ integer indisp, indiwo;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+ integer indwrk;
+ extern /* Subroutine */ int ssbtrd_(char *, char *, integer *, integer *,
+ real *, integer *, real *, real *, real *, integer *, real *,
+ integer *), sstein_(integer *, real *, real *,
+ integer *, real *, integer *, integer *, real *, integer *, real *
+, integer *, integer *, integer *), ssterf_(integer *, real *,
+ real *, integer *);
+ integer nsplit;
+ real smlnum;
+ extern /* Subroutine */ int sstebz_(char *, char *, integer *, real *,
+ real *, integer *, integer *, real *, real *, real *, integer *,
+ integer *, real *, integer *, integer *, real *, integer *,
+ integer *), ssteqr_(char *, integer *, real *,
+ real *, real *, integer *, real *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSBEVX computes selected eigenvalues and, optionally, eigenvectors */
+/* of a real symmetric band matrix A. Eigenvalues and eigenvectors can */
+/* be selected by specifying either a range of values or a range of */
+/* indices for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found; */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found; */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) REAL array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, AB is overwritten by values generated during the */
+/* reduction to tridiagonal form. If UPLO = 'U', the first */
+/* superdiagonal and the diagonal of the tridiagonal matrix T */
+/* are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */
+/* the diagonal and first subdiagonal of T are returned in the */
+/* first two rows of AB. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD + 1. */
+
+/* Q (output) REAL array, dimension (LDQ, N) */
+/* If JOBZ = 'V', the N-by-N orthogonal matrix used in the */
+/* reduction to tridiagonal form. */
+/* If JOBZ = 'N', the array Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. If JOBZ = 'V', then */
+/* LDQ >= max(1,N). */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) REAL */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing AB to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*SLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*SLAMCH('S'). */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices */
+/* with Guaranteed High Relative Accuracy," by Demmel and */
+/* Kahan, LAPACK Working Note #3. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* The first M elements contain the selected eigenvalues in */
+/* ascending order. */
+
+/* Z (output) REAL array, dimension (LDZ, max(1,M)) */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If an eigenvector fails to converge, then that column of Z */
+/* contains the latest approximation to the eigenvector, and the */
+/* index of the eigenvector is returned in IFAIL. */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (7*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, then i eigenvectors failed to converge. */
+/* Their indices are stored in array IFAIL. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+ lower = lsame_(uplo, "L");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*kd < 0) {
+ *info = -5;
+ } else if (*ldab < *kd + 1) {
+ *info = -7;
+ } else if (wantz && *ldq < max(1,*n)) {
+ *info = -9;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -11;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -12;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -13;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -18;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSBEVX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ *m = 1;
+ if (lower) {
+ tmp1 = ab[ab_dim1 + 1];
+ } else {
+ tmp1 = ab[*kd + 1 + ab_dim1];
+ }
+ if (valeig) {
+ if (! (*vl < tmp1 && *vu >= tmp1)) {
+ *m = 0;
+ }
+ }
+ if (*m == 1) {
+ w[1] = tmp1;
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.f;
+ }
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
+ rmax = dmin(r__1,r__2);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ abstll = *abstol;
+ if (valeig) {
+ vll = *vl;
+ vuu = *vu;
+ } else {
+ vll = 0.f;
+ vuu = 0.f;
+ }
+ anrm = slansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1]);
+ if (anrm > 0.f && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ if (lower) {
+ slascl_("B", kd, kd, &c_b14, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ } else {
+ slascl_("Q", kd, kd, &c_b14, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ }
+ if (*abstol > 0.f) {
+ abstll = *abstol * sigma;
+ }
+ if (valeig) {
+ vll = *vl * sigma;
+ vuu = *vu * sigma;
+ }
+ }
+
+/* Call SSBTRD to reduce symmetric band matrix to tridiagonal form. */
+
+ indd = 1;
+ inde = indd + *n;
+ indwrk = inde + *n;
+ ssbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &work[indd], &work[inde],
+ &q[q_offset], ldq, &work[indwrk], &iinfo);
+
+/* If all eigenvalues are desired and ABSTOL is less than or equal */
+/* to zero, then call SSTERF or SSTEQR. If this fails for some */
+/* eigenvalue, then try SSTEBZ. */
+
+ test = FALSE_;
+ if (indeig) {
+ if (*il == 1 && *iu == *n) {
+ test = TRUE_;
+ }
+ }
+ if ((alleig || test) && *abstol <= 0.f) {
+ scopy_(n, &work[indd], &c__1, &w[1], &c__1);
+ indee = indwrk + (*n << 1);
+ if (! wantz) {
+ i__1 = *n - 1;
+ scopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
+ ssterf_(n, &w[1], &work[indee], info);
+ } else {
+ slacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz);
+ i__1 = *n - 1;
+ scopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
+ ssteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[
+ indwrk], info);
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ifail[i__] = 0;
+/* L10: */
+ }
+ }
+ }
+ if (*info == 0) {
+ *m = *n;
+ goto L30;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ indibl = 1;
+ indisp = indibl + *n;
+ indiwo = indisp + *n;
+ sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[
+ inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[
+ indwrk], &iwork[indiwo], info);
+
+ if (wantz) {
+ sstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
+ indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &
+ ifail[1], info);
+
+/* Apply orthogonal matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by SSTEIN. */
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1);
+ sgemv_("N", n, n, &c_b14, &q[q_offset], ldq, &work[1], &c__1, &
+ c_b34, &z__[j * z_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+L30:
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *m;
+ } else {
+ imax = *info - 1;
+ }
+ r__1 = 1.f / sigma;
+ sscal_(&imax, &r__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L40: */
+ }
+
+ if (i__ != 0) {
+ itmp1 = iwork[indibl + i__ - 1];
+ w[i__] = w[j];
+ iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
+ w[j] = tmp1;
+ iwork[indibl + j - 1] = itmp1;
+ sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ if (*info != 0) {
+ itmp1 = ifail[i__];
+ ifail[i__] = ifail[j];
+ ifail[j] = itmp1;
+ }
+ }
+/* L50: */
+ }
+ }
+
+ return 0;
+
+/* End of SSBEVX */
+
+} /* ssbevx_ */
diff --git a/SRC/ssbgst.c b/SRC/ssbgst.c
new file mode 100644
index 0000000..1698683
--- /dev/null
+++ b/SRC/ssbgst.c
@@ -0,0 +1,1752 @@
+/* ssbgst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b8 = 0.f;
+static real c_b9 = 1.f;
+static integer c__1 = 1;
+static real c_b20 = -1.f;
+
+/* Subroutine */ int ssbgst_(char *vect, char *uplo, integer *n, integer *ka,
+ integer *kb, real *ab, integer *ldab, real *bb, integer *ldbb, real *
+ x, integer *ldx, real *work, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, bb_dim1, bb_offset, x_dim1, x_offset, i__1,
+ i__2, i__3, i__4;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j, k, l, m;
+ real t;
+ integer i0, i1, i2, j1, j2;
+ real ra;
+ integer nr, nx, ka1, kb1;
+ real ra1;
+ integer j1t, j2t;
+ real bii;
+ integer kbt, nrt, inca;
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *), srot_(integer *,
+ real *, integer *, real *, integer *, real *, real *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ logical upper, wantx;
+ extern /* Subroutine */ int slar2v_(integer *, real *, real *, real *,
+ integer *, real *, real *, integer *), xerbla_(char *, integer *);
+ logical update;
+ extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *), slartg_(real *, real *, real *
+, real *, real *), slargv_(integer *, real *, integer *, real *,
+ integer *, real *, integer *), slartv_(integer *, real *, integer
+ *, real *, integer *, real *, real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSBGST reduces a real symmetric-definite banded generalized */
+/* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y, */
+/* such that C has the same bandwidth as A. */
+
+/* B must have been previously factorized as S**T*S by SPBSTF, using a */
+/* split Cholesky factorization. A is overwritten by C = X**T*A*X, where */
+/* X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the */
+/* bandwidth of A. */
+
+/* Arguments */
+/* ========= */
+
+/* VECT (input) CHARACTER*1 */
+/* = 'N': do not form the transformation matrix X; */
+/* = 'V': form X. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* KA (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */
+
+/* KB (input) INTEGER */
+/* The number of superdiagonals of the matrix B if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0. */
+
+/* AB (input/output) REAL array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first ka+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */
+
+/* On exit, the transformed matrix X**T*A*X, stored in the same */
+/* format as A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KA+1. */
+
+/* BB (input) REAL array, dimension (LDBB,N) */
+/* The banded factor S from the split Cholesky factorization of */
+/* B, as returned by SPBSTF, stored in the first KB+1 rows of */
+/* the array. */
+
+/* LDBB (input) INTEGER */
+/* The leading dimension of the array BB. LDBB >= KB+1. */
+
+/* X (output) REAL array, dimension (LDX,N) */
+/* If VECT = 'V', the n-by-n matrix X. */
+/* If VECT = 'N', the array X is not referenced. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. */
+/* LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise. */
+
+/* WORK (workspace) REAL array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ bb_dim1 = *ldbb;
+ bb_offset = 1 + bb_dim1;
+ bb -= bb_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --work;
+
+ /* Function Body */
+ wantx = lsame_(vect, "V");
+ upper = lsame_(uplo, "U");
+ ka1 = *ka + 1;
+ kb1 = *kb + 1;
+ *info = 0;
+ if (! wantx && ! lsame_(vect, "N")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ka < 0) {
+ *info = -4;
+ } else if (*kb < 0 || *kb > *ka) {
+ *info = -5;
+ } else if (*ldab < *ka + 1) {
+ *info = -7;
+ } else if (*ldbb < *kb + 1) {
+ *info = -9;
+ } else if (*ldx < 1 || wantx && *ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSBGST", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ inca = *ldab * ka1;
+
+/* Initialize X to the unit matrix, if needed */
+
+ if (wantx) {
+ slaset_("Full", n, n, &c_b8, &c_b9, &x[x_offset], ldx);
+ }
+
+/* Set M to the splitting point m. It must be the same value as is */
+/* used in SPBSTF. The chosen value allows the arrays WORK and RWORK */
+/* to be of dimension (N). */
+
+ m = (*n + *kb) / 2;
+
+/* The routine works in two phases, corresponding to the two halves */
+/* of the split Cholesky factorization of B as S**T*S where */
+
+/* S = ( U ) */
+/* ( M L ) */
+
+/* with U upper triangular of order m, and L lower triangular of */
+/* order n-m. S has the same bandwidth as B. */
+
+/* S is treated as a product of elementary matrices: */
+
+/* S = S(m)*S(m-1)*...*S(2)*S(1)*S(m+1)*S(m+2)*...*S(n-1)*S(n) */
+
+/* where S(i) is determined by the i-th row of S. */
+
+/* In phase 1, the index i takes the values n, n-1, ... , m+1; */
+/* in phase 2, it takes the values 1, 2, ... , m. */
+
+/* For each value of i, the current matrix A is updated by forming */
+/* inv(S(i))**T*A*inv(S(i)). This creates a triangular bulge outside */
+/* the band of A. The bulge is then pushed down toward the bottom of */
+/* A in phase 1, and up toward the top of A in phase 2, by applying */
+/* plane rotations. */
+
+/* There are kb*(kb+1)/2 elements in the bulge, but at most 2*kb-1 */
+/* of them are linearly independent, so annihilating a bulge requires */
+/* only 2*kb-1 plane rotations. The rotations are divided into a 1st */
+/* set of kb-1 rotations, and a 2nd set of kb rotations. */
+
+/* Wherever possible, rotations are generated and applied in vector */
+/* operations of length NR between the indices J1 and J2 (sometimes */
+/* replaced by modified values NRT, J1T or J2T). */
+
+/* The cosines and sines of the rotations are stored in the array */
+/* WORK. The cosines of the 1st set of rotations are stored in */
+/* elements n+2:n+m-kb-1 and the sines of the 1st set in elements */
+/* 2:m-kb-1; the cosines of the 2nd set are stored in elements */
+/* n+m-kb+1:2*n and the sines of the second set in elements m-kb+1:n. */
+
+/* The bulges are not formed explicitly; nonzero elements outside the */
+/* band are created only when they are required for generating new */
+/* rotations; they are stored in the array WORK, in positions where */
+/* they are later overwritten by the sines of the rotations which */
+/* annihilate them. */
+
+/* **************************** Phase 1 ***************************** */
+
+/* The logical structure of this phase is: */
+
+/* UPDATE = .TRUE. */
+/* DO I = N, M + 1, -1 */
+/* use S(i) to update A and create a new bulge */
+/* apply rotations to push all bulges KA positions downward */
+/* END DO */
+/* UPDATE = .FALSE. */
+/* DO I = M + KA + 1, N - 1 */
+/* apply rotations to push all bulges KA positions downward */
+/* END DO */
+
+/* To avoid duplicating code, the two loops are merged. */
+
+ update = TRUE_;
+ i__ = *n + 1;
+L10:
+ if (update) {
+ --i__;
+/* Computing MIN */
+ i__1 = *kb, i__2 = i__ - 1;
+ kbt = min(i__1,i__2);
+ i0 = i__ - 1;
+/* Computing MIN */
+ i__1 = *n, i__2 = i__ + *ka;
+ i1 = min(i__1,i__2);
+ i2 = i__ - kbt + ka1;
+ if (i__ < m + 1) {
+ update = FALSE_;
+ ++i__;
+ i0 = m;
+ if (*ka == 0) {
+ goto L480;
+ }
+ goto L10;
+ }
+ } else {
+ i__ += *ka;
+ if (i__ > *n - 1) {
+ goto L480;
+ }
+ }
+
+ if (upper) {
+
+/* Transform A, working with the upper triangle */
+
+ if (update) {
+
+/* Form inv(S(i))**T * A * inv(S(i)) */
+
+ bii = bb[kb1 + i__ * bb_dim1];
+ i__1 = i1;
+ for (j = i__; j <= i__1; ++j) {
+ ab[i__ - j + ka1 + j * ab_dim1] /= bii;
+/* L20: */
+ }
+/* Computing MAX */
+ i__1 = 1, i__2 = i__ - *ka;
+ i__3 = i__;
+ for (j = max(i__1,i__2); j <= i__3; ++j) {
+ ab[j - i__ + ka1 + i__ * ab_dim1] /= bii;
+/* L30: */
+ }
+ i__3 = i__ - 1;
+ for (k = i__ - kbt; k <= i__3; ++k) {
+ i__1 = k;
+ for (j = i__ - kbt; j <= i__1; ++j) {
+ ab[j - k + ka1 + k * ab_dim1] = ab[j - k + ka1 + k *
+ ab_dim1] - bb[j - i__ + kb1 + i__ * bb_dim1] * ab[
+ k - i__ + ka1 + i__ * ab_dim1] - bb[k - i__ + kb1
+ + i__ * bb_dim1] * ab[j - i__ + ka1 + i__ *
+ ab_dim1] + ab[ka1 + i__ * ab_dim1] * bb[j - i__ +
+ kb1 + i__ * bb_dim1] * bb[k - i__ + kb1 + i__ *
+ bb_dim1];
+/* L40: */
+ }
+/* Computing MAX */
+ i__1 = 1, i__2 = i__ - *ka;
+ i__4 = i__ - kbt - 1;
+ for (j = max(i__1,i__2); j <= i__4; ++j) {
+ ab[j - k + ka1 + k * ab_dim1] -= bb[k - i__ + kb1 + i__ *
+ bb_dim1] * ab[j - i__ + ka1 + i__ * ab_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+ i__3 = i1;
+ for (j = i__; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = j - *ka, i__1 = i__ - kbt;
+ i__2 = i__ - 1;
+ for (k = max(i__4,i__1); k <= i__2; ++k) {
+ ab[k - j + ka1 + j * ab_dim1] -= bb[k - i__ + kb1 + i__ *
+ bb_dim1] * ab[i__ - j + ka1 + j * ab_dim1];
+/* L70: */
+ }
+/* L80: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by inv(S(i)) */
+
+ i__3 = *n - m;
+ r__1 = 1.f / bii;
+ sscal_(&i__3, &r__1, &x[m + 1 + i__ * x_dim1], &c__1);
+ if (kbt > 0) {
+ i__3 = *n - m;
+ sger_(&i__3, &kbt, &c_b20, &x[m + 1 + i__ * x_dim1], &
+ c__1, &bb[kb1 - kbt + i__ * bb_dim1], &c__1, &x[m
+ + 1 + (i__ - kbt) * x_dim1], ldx);
+ }
+ }
+
+/* store a(i,i1) in RA1 for use in next loop over K */
+
+ ra1 = ab[i__ - i1 + ka1 + i1 * ab_dim1];
+ }
+
+/* Generate and apply vectors of rotations to chase all the */
+/* existing bulges KA positions down toward the bottom of the */
+/* band */
+
+ i__3 = *kb - 1;
+ for (k = 1; k <= i__3; ++k) {
+ if (update) {
+
+/* Determine the rotations which would annihilate the bulge */
+/* which has in theory just been created */
+
+ if (i__ - k + *ka < *n && i__ - k > 1) {
+
+/* generate rotation to annihilate a(i,i-k+ka+1) */
+
+ slartg_(&ab[k + 1 + (i__ - k + *ka) * ab_dim1], &ra1, &
+ work[*n + i__ - k + *ka - m], &work[i__ - k + *ka
+ - m], &ra);
+
+/* create nonzero element a(i-k,i-k+ka+1) outside the */
+/* band and store it in WORK(i-k) */
+
+ t = -bb[kb1 - k + i__ * bb_dim1] * ra1;
+ work[i__ - k] = work[*n + i__ - k + *ka - m] * t - work[
+ i__ - k + *ka - m] * ab[(i__ - k + *ka) * ab_dim1
+ + 1];
+ ab[(i__ - k + *ka) * ab_dim1 + 1] = work[i__ - k + *ka -
+ m] * t + work[*n + i__ - k + *ka - m] * ab[(i__ -
+ k + *ka) * ab_dim1 + 1];
+ ra1 = ra;
+ }
+ }
+/* Computing MAX */
+ i__2 = 1, i__4 = k - i0 + 2;
+ j2 = i__ - k - 1 + max(i__2,i__4) * ka1;
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ if (update) {
+/* Computing MAX */
+ i__2 = j2, i__4 = i__ + (*ka << 1) - k + 1;
+ j2t = max(i__2,i__4);
+ } else {
+ j2t = j2;
+ }
+ nrt = (*n - j2t + *ka) / ka1;
+ i__2 = j1;
+ i__4 = ka1;
+ for (j = j2t; i__4 < 0 ? j >= i__2 : j <= i__2; j += i__4) {
+
+/* create nonzero element a(j-ka,j+1) outside the band */
+/* and store it in WORK(j-m) */
+
+ work[j - m] *= ab[(j + 1) * ab_dim1 + 1];
+ ab[(j + 1) * ab_dim1 + 1] = work[*n + j - m] * ab[(j + 1) *
+ ab_dim1 + 1];
+/* L90: */
+ }
+
+/* generate rotations in 1st set to annihilate elements which */
+/* have been created outside the band */
+
+ if (nrt > 0) {
+ slargv_(&nrt, &ab[j2t * ab_dim1 + 1], &inca, &work[j2t - m], &
+ ka1, &work[*n + j2t - m], &ka1);
+ }
+ if (nr > 0) {
+
+/* apply rotations in 1st set from the right */
+
+ i__4 = *ka - 1;
+ for (l = 1; l <= i__4; ++l) {
+ slartv_(&nr, &ab[ka1 - l + j2 * ab_dim1], &inca, &ab[*ka
+ - l + (j2 + 1) * ab_dim1], &inca, &work[*n + j2 -
+ m], &work[j2 - m], &ka1);
+/* L100: */
+ }
+
+/* apply rotations in 1st set from both sides to diagonal */
+/* blocks */
+
+ slar2v_(&nr, &ab[ka1 + j2 * ab_dim1], &ab[ka1 + (j2 + 1) *
+ ab_dim1], &ab[*ka + (j2 + 1) * ab_dim1], &inca, &work[
+ *n + j2 - m], &work[j2 - m], &ka1);
+
+ }
+
+/* start applying rotations in 1st set from the left */
+
+ i__4 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__4; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ slartv_(&nrt, &ab[l + (j2 + ka1 - l) * ab_dim1], &inca, &
+ ab[l + 1 + (j2 + ka1 - l) * ab_dim1], &inca, &
+ work[*n + j2 - m], &work[j2 - m], &ka1);
+ }
+/* L110: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 1st set */
+
+ i__4 = j1;
+ i__2 = ka1;
+ for (j = j2; i__2 < 0 ? j >= i__4 : j <= i__4; j += i__2) {
+ i__1 = *n - m;
+ srot_(&i__1, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j
+ + 1) * x_dim1], &c__1, &work[*n + j - m], &work[j
+ - m]);
+/* L120: */
+ }
+ }
+/* L130: */
+ }
+
+ if (update) {
+ if (i2 <= *n && kbt > 0) {
+
+/* create nonzero element a(i-kbt,i-kbt+ka+1) outside the */
+/* band and store it in WORK(i-kbt) */
+
+ work[i__ - kbt] = -bb[kb1 - kbt + i__ * bb_dim1] * ra1;
+ }
+ }
+
+ for (k = *kb; k >= 1; --k) {
+ if (update) {
+/* Computing MAX */
+ i__3 = 2, i__2 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__3,i__2) * ka1;
+ } else {
+/* Computing MAX */
+ i__3 = 1, i__2 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__3,i__2) * ka1;
+ }
+
+/* finish applying rotations in 2nd set from the left */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (*n - j2 + *ka + l) / ka1;
+ if (nrt > 0) {
+ slartv_(&nrt, &ab[l + (j2 - l + 1) * ab_dim1], &inca, &ab[
+ l + 1 + (j2 - l + 1) * ab_dim1], &inca, &work[*n
+ + j2 - *ka], &work[j2 - *ka], &ka1);
+ }
+/* L140: */
+ }
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ i__3 = j2;
+ i__2 = -ka1;
+ for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2) {
+ work[j] = work[j - *ka];
+ work[*n + j] = work[*n + j - *ka];
+/* L150: */
+ }
+ i__2 = j1;
+ i__3 = ka1;
+ for (j = j2; i__3 < 0 ? j >= i__2 : j <= i__2; j += i__3) {
+
+/* create nonzero element a(j-ka,j+1) outside the band */
+/* and store it in WORK(j) */
+
+ work[j] *= ab[(j + 1) * ab_dim1 + 1];
+ ab[(j + 1) * ab_dim1 + 1] = work[*n + j] * ab[(j + 1) *
+ ab_dim1 + 1];
+/* L160: */
+ }
+ if (update) {
+ if (i__ - k < *n - *ka && k <= kbt) {
+ work[i__ - k + *ka] = work[i__ - k];
+ }
+ }
+/* L170: */
+ }
+
+ for (k = *kb; k >= 1; --k) {
+/* Computing MAX */
+ i__3 = 1, i__2 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__3,i__2) * ka1;
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ if (nr > 0) {
+
+/* generate rotations in 2nd set to annihilate elements */
+/* which have been created outside the band */
+
+ slargv_(&nr, &ab[j2 * ab_dim1 + 1], &inca, &work[j2], &ka1, &
+ work[*n + j2], &ka1);
+
+/* apply rotations in 2nd set from the right */
+
+ i__3 = *ka - 1;
+ for (l = 1; l <= i__3; ++l) {
+ slartv_(&nr, &ab[ka1 - l + j2 * ab_dim1], &inca, &ab[*ka
+ - l + (j2 + 1) * ab_dim1], &inca, &work[*n + j2],
+ &work[j2], &ka1);
+/* L180: */
+ }
+
+/* apply rotations in 2nd set from both sides to diagonal */
+/* blocks */
+
+ slar2v_(&nr, &ab[ka1 + j2 * ab_dim1], &ab[ka1 + (j2 + 1) *
+ ab_dim1], &ab[*ka + (j2 + 1) * ab_dim1], &inca, &work[
+ *n + j2], &work[j2], &ka1);
+
+ }
+
+/* start applying rotations in 2nd set from the left */
+
+ i__3 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__3; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ slartv_(&nrt, &ab[l + (j2 + ka1 - l) * ab_dim1], &inca, &
+ ab[l + 1 + (j2 + ka1 - l) * ab_dim1], &inca, &
+ work[*n + j2], &work[j2], &ka1);
+ }
+/* L190: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 2nd set */
+
+ i__3 = j1;
+ i__2 = ka1;
+ for (j = j2; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2) {
+ i__4 = *n - m;
+ srot_(&i__4, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j
+ + 1) * x_dim1], &c__1, &work[*n + j], &work[j]);
+/* L200: */
+ }
+ }
+/* L210: */
+ }
+
+ i__2 = *kb - 1;
+ for (k = 1; k <= i__2; ++k) {
+/* Computing MAX */
+ i__3 = 1, i__4 = k - i0 + 2;
+ j2 = i__ - k - 1 + max(i__3,i__4) * ka1;
+
+/* finish applying rotations in 1st set from the left */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ slartv_(&nrt, &ab[l + (j2 + ka1 - l) * ab_dim1], &inca, &
+ ab[l + 1 + (j2 + ka1 - l) * ab_dim1], &inca, &
+ work[*n + j2 - m], &work[j2 - m], &ka1);
+ }
+/* L220: */
+ }
+/* L230: */
+ }
+
+ if (*kb > 1) {
+ i__2 = i__ - *kb + (*ka << 1) + 1;
+ for (j = *n - 1; j >= i__2; --j) {
+ work[*n + j - m] = work[*n + j - *ka - m];
+ work[j - m] = work[j - *ka - m];
+/* L240: */
+ }
+ }
+
+ } else {
+
+/* Transform A, working with the lower triangle */
+
+ if (update) {
+
+/* Form inv(S(i))**T * A * inv(S(i)) */
+
+ bii = bb[i__ * bb_dim1 + 1];
+ i__2 = i1;
+ for (j = i__; j <= i__2; ++j) {
+ ab[j - i__ + 1 + i__ * ab_dim1] /= bii;
+/* L250: */
+ }
+/* Computing MAX */
+ i__2 = 1, i__3 = i__ - *ka;
+ i__4 = i__;
+ for (j = max(i__2,i__3); j <= i__4; ++j) {
+ ab[i__ - j + 1 + j * ab_dim1] /= bii;
+/* L260: */
+ }
+ i__4 = i__ - 1;
+ for (k = i__ - kbt; k <= i__4; ++k) {
+ i__2 = k;
+ for (j = i__ - kbt; j <= i__2; ++j) {
+ ab[k - j + 1 + j * ab_dim1] = ab[k - j + 1 + j * ab_dim1]
+ - bb[i__ - j + 1 + j * bb_dim1] * ab[i__ - k + 1
+ + k * ab_dim1] - bb[i__ - k + 1 + k * bb_dim1] *
+ ab[i__ - j + 1 + j * ab_dim1] + ab[i__ * ab_dim1
+ + 1] * bb[i__ - j + 1 + j * bb_dim1] * bb[i__ - k
+ + 1 + k * bb_dim1];
+/* L270: */
+ }
+/* Computing MAX */
+ i__2 = 1, i__3 = i__ - *ka;
+ i__1 = i__ - kbt - 1;
+ for (j = max(i__2,i__3); j <= i__1; ++j) {
+ ab[k - j + 1 + j * ab_dim1] -= bb[i__ - k + 1 + k *
+ bb_dim1] * ab[i__ - j + 1 + j * ab_dim1];
+/* L280: */
+ }
+/* L290: */
+ }
+ i__4 = i1;
+ for (j = i__; j <= i__4; ++j) {
+/* Computing MAX */
+ i__1 = j - *ka, i__2 = i__ - kbt;
+ i__3 = i__ - 1;
+ for (k = max(i__1,i__2); k <= i__3; ++k) {
+ ab[j - k + 1 + k * ab_dim1] -= bb[i__ - k + 1 + k *
+ bb_dim1] * ab[j - i__ + 1 + i__ * ab_dim1];
+/* L300: */
+ }
+/* L310: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by inv(S(i)) */
+
+ i__4 = *n - m;
+ r__1 = 1.f / bii;
+ sscal_(&i__4, &r__1, &x[m + 1 + i__ * x_dim1], &c__1);
+ if (kbt > 0) {
+ i__4 = *n - m;
+ i__3 = *ldbb - 1;
+ sger_(&i__4, &kbt, &c_b20, &x[m + 1 + i__ * x_dim1], &
+ c__1, &bb[kbt + 1 + (i__ - kbt) * bb_dim1], &i__3,
+ &x[m + 1 + (i__ - kbt) * x_dim1], ldx);
+ }
+ }
+
+/* store a(i1,i) in RA1 for use in next loop over K */
+
+ ra1 = ab[i1 - i__ + 1 + i__ * ab_dim1];
+ }
+
+/* Generate and apply vectors of rotations to chase all the */
+/* existing bulges KA positions down toward the bottom of the */
+/* band */
+
+ i__4 = *kb - 1;
+ for (k = 1; k <= i__4; ++k) {
+ if (update) {
+
+/* Determine the rotations which would annihilate the bulge */
+/* which has in theory just been created */
+
+ if (i__ - k + *ka < *n && i__ - k > 1) {
+
+/* generate rotation to annihilate a(i-k+ka+1,i) */
+
+ slartg_(&ab[ka1 - k + i__ * ab_dim1], &ra1, &work[*n +
+ i__ - k + *ka - m], &work[i__ - k + *ka - m], &ra)
+ ;
+
+/* create nonzero element a(i-k+ka+1,i-k) outside the */
+/* band and store it in WORK(i-k) */
+
+ t = -bb[k + 1 + (i__ - k) * bb_dim1] * ra1;
+ work[i__ - k] = work[*n + i__ - k + *ka - m] * t - work[
+ i__ - k + *ka - m] * ab[ka1 + (i__ - k) * ab_dim1]
+ ;
+ ab[ka1 + (i__ - k) * ab_dim1] = work[i__ - k + *ka - m] *
+ t + work[*n + i__ - k + *ka - m] * ab[ka1 + (i__
+ - k) * ab_dim1];
+ ra1 = ra;
+ }
+ }
+/* Computing MAX */
+ i__3 = 1, i__1 = k - i0 + 2;
+ j2 = i__ - k - 1 + max(i__3,i__1) * ka1;
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ if (update) {
+/* Computing MAX */
+ i__3 = j2, i__1 = i__ + (*ka << 1) - k + 1;
+ j2t = max(i__3,i__1);
+ } else {
+ j2t = j2;
+ }
+ nrt = (*n - j2t + *ka) / ka1;
+ i__3 = j1;
+ i__1 = ka1;
+ for (j = j2t; i__1 < 0 ? j >= i__3 : j <= i__3; j += i__1) {
+
+/* create nonzero element a(j+1,j-ka) outside the band */
+/* and store it in WORK(j-m) */
+
+ work[j - m] *= ab[ka1 + (j - *ka + 1) * ab_dim1];
+ ab[ka1 + (j - *ka + 1) * ab_dim1] = work[*n + j - m] * ab[ka1
+ + (j - *ka + 1) * ab_dim1];
+/* L320: */
+ }
+
+/* generate rotations in 1st set to annihilate elements which */
+/* have been created outside the band */
+
+ if (nrt > 0) {
+ slargv_(&nrt, &ab[ka1 + (j2t - *ka) * ab_dim1], &inca, &work[
+ j2t - m], &ka1, &work[*n + j2t - m], &ka1);
+ }
+ if (nr > 0) {
+
+/* apply rotations in 1st set from the left */
+
+ i__1 = *ka - 1;
+ for (l = 1; l <= i__1; ++l) {
+ slartv_(&nr, &ab[l + 1 + (j2 - l) * ab_dim1], &inca, &ab[
+ l + 2 + (j2 - l) * ab_dim1], &inca, &work[*n + j2
+ - m], &work[j2 - m], &ka1);
+/* L330: */
+ }
+
+/* apply rotations in 1st set from both sides to diagonal */
+/* blocks */
+
+ slar2v_(&nr, &ab[j2 * ab_dim1 + 1], &ab[(j2 + 1) * ab_dim1 +
+ 1], &ab[j2 * ab_dim1 + 2], &inca, &work[*n + j2 - m],
+ &work[j2 - m], &ka1);
+
+ }
+
+/* start applying rotations in 1st set from the right */
+
+ i__1 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__1; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ slartv_(&nrt, &ab[ka1 - l + 1 + j2 * ab_dim1], &inca, &ab[
+ ka1 - l + (j2 + 1) * ab_dim1], &inca, &work[*n +
+ j2 - m], &work[j2 - m], &ka1);
+ }
+/* L340: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 1st set */
+
+ i__1 = j1;
+ i__3 = ka1;
+ for (j = j2; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) {
+ i__2 = *n - m;
+ srot_(&i__2, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j
+ + 1) * x_dim1], &c__1, &work[*n + j - m], &work[j
+ - m]);
+/* L350: */
+ }
+ }
+/* L360: */
+ }
+
+ if (update) {
+ if (i2 <= *n && kbt > 0) {
+
+/* create nonzero element a(i-kbt+ka+1,i-kbt) outside the */
+/* band and store it in WORK(i-kbt) */
+
+ work[i__ - kbt] = -bb[kbt + 1 + (i__ - kbt) * bb_dim1] * ra1;
+ }
+ }
+
+ for (k = *kb; k >= 1; --k) {
+ if (update) {
+/* Computing MAX */
+ i__4 = 2, i__3 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__4,i__3) * ka1;
+ } else {
+/* Computing MAX */
+ i__4 = 1, i__3 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__4,i__3) * ka1;
+ }
+
+/* finish applying rotations in 2nd set from the right */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (*n - j2 + *ka + l) / ka1;
+ if (nrt > 0) {
+ slartv_(&nrt, &ab[ka1 - l + 1 + (j2 - *ka) * ab_dim1], &
+ inca, &ab[ka1 - l + (j2 - *ka + 1) * ab_dim1], &
+ inca, &work[*n + j2 - *ka], &work[j2 - *ka], &ka1)
+ ;
+ }
+/* L370: */
+ }
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ i__4 = j2;
+ i__3 = -ka1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) {
+ work[j] = work[j - *ka];
+ work[*n + j] = work[*n + j - *ka];
+/* L380: */
+ }
+ i__3 = j1;
+ i__4 = ka1;
+ for (j = j2; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+
+/* create nonzero element a(j+1,j-ka) outside the band */
+/* and store it in WORK(j) */
+
+ work[j] *= ab[ka1 + (j - *ka + 1) * ab_dim1];
+ ab[ka1 + (j - *ka + 1) * ab_dim1] = work[*n + j] * ab[ka1 + (
+ j - *ka + 1) * ab_dim1];
+/* L390: */
+ }
+ if (update) {
+ if (i__ - k < *n - *ka && k <= kbt) {
+ work[i__ - k + *ka] = work[i__ - k];
+ }
+ }
+/* L400: */
+ }
+
+ for (k = *kb; k >= 1; --k) {
+/* Computing MAX */
+ i__4 = 1, i__3 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__4,i__3) * ka1;
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ if (nr > 0) {
+
+/* generate rotations in 2nd set to annihilate elements */
+/* which have been created outside the band */
+
+ slargv_(&nr, &ab[ka1 + (j2 - *ka) * ab_dim1], &inca, &work[j2]
+, &ka1, &work[*n + j2], &ka1);
+
+/* apply rotations in 2nd set from the left */
+
+ i__4 = *ka - 1;
+ for (l = 1; l <= i__4; ++l) {
+ slartv_(&nr, &ab[l + 1 + (j2 - l) * ab_dim1], &inca, &ab[
+ l + 2 + (j2 - l) * ab_dim1], &inca, &work[*n + j2]
+, &work[j2], &ka1);
+/* L410: */
+ }
+
+/* apply rotations in 2nd set from both sides to diagonal */
+/* blocks */
+
+ slar2v_(&nr, &ab[j2 * ab_dim1 + 1], &ab[(j2 + 1) * ab_dim1 +
+ 1], &ab[j2 * ab_dim1 + 2], &inca, &work[*n + j2], &
+ work[j2], &ka1);
+
+ }
+
+/* start applying rotations in 2nd set from the right */
+
+ i__4 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__4; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ slartv_(&nrt, &ab[ka1 - l + 1 + j2 * ab_dim1], &inca, &ab[
+ ka1 - l + (j2 + 1) * ab_dim1], &inca, &work[*n +
+ j2], &work[j2], &ka1);
+ }
+/* L420: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 2nd set */
+
+ i__4 = j1;
+ i__3 = ka1;
+ for (j = j2; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) {
+ i__1 = *n - m;
+ srot_(&i__1, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j
+ + 1) * x_dim1], &c__1, &work[*n + j], &work[j]);
+/* L430: */
+ }
+ }
+/* L440: */
+ }
+
+ i__3 = *kb - 1;
+ for (k = 1; k <= i__3; ++k) {
+/* Computing MAX */
+ i__4 = 1, i__1 = k - i0 + 2;
+ j2 = i__ - k - 1 + max(i__4,i__1) * ka1;
+
+/* finish applying rotations in 1st set from the right */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ slartv_(&nrt, &ab[ka1 - l + 1 + j2 * ab_dim1], &inca, &ab[
+ ka1 - l + (j2 + 1) * ab_dim1], &inca, &work[*n +
+ j2 - m], &work[j2 - m], &ka1);
+ }
+/* L450: */
+ }
+/* L460: */
+ }
+
+ if (*kb > 1) {
+ i__3 = i__ - *kb + (*ka << 1) + 1;
+ for (j = *n - 1; j >= i__3; --j) {
+ work[*n + j - m] = work[*n + j - *ka - m];
+ work[j - m] = work[j - *ka - m];
+/* L470: */
+ }
+ }
+
+ }
+
+ goto L10;
+
+L480:
+
+/* **************************** Phase 2 ***************************** */
+
+/* The logical structure of this phase is: */
+
+/* UPDATE = .TRUE. */
+/* DO I = 1, M */
+/* use S(i) to update A and create a new bulge */
+/* apply rotations to push all bulges KA positions upward */
+/* END DO */
+/* UPDATE = .FALSE. */
+/* DO I = M - KA - 1, 2, -1 */
+/* apply rotations to push all bulges KA positions upward */
+/* END DO */
+
+/* To avoid duplicating code, the two loops are merged. */
+
+ update = TRUE_;
+ i__ = 0;
+L490:
+ if (update) {
+ ++i__;
+/* Computing MIN */
+ i__3 = *kb, i__4 = m - i__;
+ kbt = min(i__3,i__4);
+ i0 = i__ + 1;
+/* Computing MAX */
+ i__3 = 1, i__4 = i__ - *ka;
+ i1 = max(i__3,i__4);
+ i2 = i__ + kbt - ka1;
+ if (i__ > m) {
+ update = FALSE_;
+ --i__;
+ i0 = m + 1;
+ if (*ka == 0) {
+ return 0;
+ }
+ goto L490;
+ }
+ } else {
+ i__ -= *ka;
+ if (i__ < 2) {
+ return 0;
+ }
+ }
+
+ if (i__ < m - kbt) {
+ nx = m;
+ } else {
+ nx = *n;
+ }
+
+ if (upper) {
+
+/* Transform A, working with the upper triangle */
+
+ if (update) {
+
+/* Form inv(S(i))**T * A * inv(S(i)) */
+
+ bii = bb[kb1 + i__ * bb_dim1];
+ i__3 = i__;
+ for (j = i1; j <= i__3; ++j) {
+ ab[j - i__ + ka1 + i__ * ab_dim1] /= bii;
+/* L500: */
+ }
+/* Computing MIN */
+ i__4 = *n, i__1 = i__ + *ka;
+ i__3 = min(i__4,i__1);
+ for (j = i__; j <= i__3; ++j) {
+ ab[i__ - j + ka1 + j * ab_dim1] /= bii;
+/* L510: */
+ }
+ i__3 = i__ + kbt;
+ for (k = i__ + 1; k <= i__3; ++k) {
+ i__4 = i__ + kbt;
+ for (j = k; j <= i__4; ++j) {
+ ab[k - j + ka1 + j * ab_dim1] = ab[k - j + ka1 + j *
+ ab_dim1] - bb[i__ - j + kb1 + j * bb_dim1] * ab[
+ i__ - k + ka1 + k * ab_dim1] - bb[i__ - k + kb1 +
+ k * bb_dim1] * ab[i__ - j + ka1 + j * ab_dim1] +
+ ab[ka1 + i__ * ab_dim1] * bb[i__ - j + kb1 + j *
+ bb_dim1] * bb[i__ - k + kb1 + k * bb_dim1];
+/* L520: */
+ }
+/* Computing MIN */
+ i__1 = *n, i__2 = i__ + *ka;
+ i__4 = min(i__1,i__2);
+ for (j = i__ + kbt + 1; j <= i__4; ++j) {
+ ab[k - j + ka1 + j * ab_dim1] -= bb[i__ - k + kb1 + k *
+ bb_dim1] * ab[i__ - j + ka1 + j * ab_dim1];
+/* L530: */
+ }
+/* L540: */
+ }
+ i__3 = i__;
+ for (j = i1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__1 = j + *ka, i__2 = i__ + kbt;
+ i__4 = min(i__1,i__2);
+ for (k = i__ + 1; k <= i__4; ++k) {
+ ab[j - k + ka1 + k * ab_dim1] -= bb[i__ - k + kb1 + k *
+ bb_dim1] * ab[j - i__ + ka1 + i__ * ab_dim1];
+/* L550: */
+ }
+/* L560: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by inv(S(i)) */
+
+ r__1 = 1.f / bii;
+ sscal_(&nx, &r__1, &x[i__ * x_dim1 + 1], &c__1);
+ if (kbt > 0) {
+ i__3 = *ldbb - 1;
+ sger_(&nx, &kbt, &c_b20, &x[i__ * x_dim1 + 1], &c__1, &bb[
+ *kb + (i__ + 1) * bb_dim1], &i__3, &x[(i__ + 1) *
+ x_dim1 + 1], ldx);
+ }
+ }
+
+/* store a(i1,i) in RA1 for use in next loop over K */
+
+ ra1 = ab[i1 - i__ + ka1 + i__ * ab_dim1];
+ }
+
+/* Generate and apply vectors of rotations to chase all the */
+/* existing bulges KA positions up toward the top of the band */
+
+ i__3 = *kb - 1;
+ for (k = 1; k <= i__3; ++k) {
+ if (update) {
+
+/* Determine the rotations which would annihilate the bulge */
+/* which has in theory just been created */
+
+ if (i__ + k - ka1 > 0 && i__ + k < m) {
+
+/* generate rotation to annihilate a(i+k-ka-1,i) */
+
+ slartg_(&ab[k + 1 + i__ * ab_dim1], &ra1, &work[*n + i__
+ + k - *ka], &work[i__ + k - *ka], &ra);
+
+/* create nonzero element a(i+k-ka-1,i+k) outside the */
+/* band and store it in WORK(m-kb+i+k) */
+
+ t = -bb[kb1 - k + (i__ + k) * bb_dim1] * ra1;
+ work[m - *kb + i__ + k] = work[*n + i__ + k - *ka] * t -
+ work[i__ + k - *ka] * ab[(i__ + k) * ab_dim1 + 1];
+ ab[(i__ + k) * ab_dim1 + 1] = work[i__ + k - *ka] * t +
+ work[*n + i__ + k - *ka] * ab[(i__ + k) * ab_dim1
+ + 1];
+ ra1 = ra;
+ }
+ }
+/* Computing MAX */
+ i__4 = 1, i__1 = k + i0 - m + 1;
+ j2 = i__ + k + 1 - max(i__4,i__1) * ka1;
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ if (update) {
+/* Computing MIN */
+ i__4 = j2, i__1 = i__ - (*ka << 1) + k - 1;
+ j2t = min(i__4,i__1);
+ } else {
+ j2t = j2;
+ }
+ nrt = (j2t + *ka - 1) / ka1;
+ i__4 = j2t;
+ i__1 = ka1;
+ for (j = j1; i__1 < 0 ? j >= i__4 : j <= i__4; j += i__1) {
+
+/* create nonzero element a(j-1,j+ka) outside the band */
+/* and store it in WORK(j) */
+
+ work[j] *= ab[(j + *ka - 1) * ab_dim1 + 1];
+ ab[(j + *ka - 1) * ab_dim1 + 1] = work[*n + j] * ab[(j + *ka
+ - 1) * ab_dim1 + 1];
+/* L570: */
+ }
+
+/* generate rotations in 1st set to annihilate elements which */
+/* have been created outside the band */
+
+ if (nrt > 0) {
+ slargv_(&nrt, &ab[(j1 + *ka) * ab_dim1 + 1], &inca, &work[j1],
+ &ka1, &work[*n + j1], &ka1);
+ }
+ if (nr > 0) {
+
+/* apply rotations in 1st set from the left */
+
+ i__1 = *ka - 1;
+ for (l = 1; l <= i__1; ++l) {
+ slartv_(&nr, &ab[ka1 - l + (j1 + l) * ab_dim1], &inca, &
+ ab[*ka - l + (j1 + l) * ab_dim1], &inca, &work[*n
+ + j1], &work[j1], &ka1);
+/* L580: */
+ }
+
+/* apply rotations in 1st set from both sides to diagonal */
+/* blocks */
+
+ slar2v_(&nr, &ab[ka1 + j1 * ab_dim1], &ab[ka1 + (j1 - 1) *
+ ab_dim1], &ab[*ka + j1 * ab_dim1], &inca, &work[*n +
+ j1], &work[j1], &ka1);
+
+ }
+
+/* start applying rotations in 1st set from the right */
+
+ i__1 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__1; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ slartv_(&nrt, &ab[l + j1t * ab_dim1], &inca, &ab[l + 1 + (
+ j1t - 1) * ab_dim1], &inca, &work[*n + j1t], &
+ work[j1t], &ka1);
+ }
+/* L590: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 1st set */
+
+ i__1 = j2;
+ i__4 = ka1;
+ for (j = j1; i__4 < 0 ? j >= i__1 : j <= i__1; j += i__4) {
+ srot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1
+ + 1], &c__1, &work[*n + j], &work[j]);
+/* L600: */
+ }
+ }
+/* L610: */
+ }
+
+ if (update) {
+ if (i2 > 0 && kbt > 0) {
+
+/* create nonzero element a(i+kbt-ka-1,i+kbt) outside the */
+/* band and store it in WORK(m-kb+i+kbt) */
+
+ work[m - *kb + i__ + kbt] = -bb[kb1 - kbt + (i__ + kbt) *
+ bb_dim1] * ra1;
+ }
+ }
+
+ for (k = *kb; k >= 1; --k) {
+ if (update) {
+/* Computing MAX */
+ i__3 = 2, i__4 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__3,i__4) * ka1;
+ } else {
+/* Computing MAX */
+ i__3 = 1, i__4 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__3,i__4) * ka1;
+ }
+
+/* finish applying rotations in 2nd set from the right */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (j2 + *ka + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ slartv_(&nrt, &ab[l + (j1t + *ka) * ab_dim1], &inca, &ab[
+ l + 1 + (j1t + *ka - 1) * ab_dim1], &inca, &work[*
+ n + m - *kb + j1t + *ka], &work[m - *kb + j1t + *
+ ka], &ka1);
+ }
+/* L620: */
+ }
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ i__3 = j2;
+ i__4 = ka1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+ work[m - *kb + j] = work[m - *kb + j + *ka];
+ work[*n + m - *kb + j] = work[*n + m - *kb + j + *ka];
+/* L630: */
+ }
+ i__4 = j2;
+ i__3 = ka1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) {
+
+/* create nonzero element a(j-1,j+ka) outside the band */
+/* and store it in WORK(m-kb+j) */
+
+ work[m - *kb + j] *= ab[(j + *ka - 1) * ab_dim1 + 1];
+ ab[(j + *ka - 1) * ab_dim1 + 1] = work[*n + m - *kb + j] * ab[
+ (j + *ka - 1) * ab_dim1 + 1];
+/* L640: */
+ }
+ if (update) {
+ if (i__ + k > ka1 && k <= kbt) {
+ work[m - *kb + i__ + k - *ka] = work[m - *kb + i__ + k];
+ }
+ }
+/* L650: */
+ }
+
+ for (k = *kb; k >= 1; --k) {
+/* Computing MAX */
+ i__3 = 1, i__4 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__3,i__4) * ka1;
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ if (nr > 0) {
+
+/* generate rotations in 2nd set to annihilate elements */
+/* which have been created outside the band */
+
+ slargv_(&nr, &ab[(j1 + *ka) * ab_dim1 + 1], &inca, &work[m - *
+ kb + j1], &ka1, &work[*n + m - *kb + j1], &ka1);
+
+/* apply rotations in 2nd set from the left */
+
+ i__3 = *ka - 1;
+ for (l = 1; l <= i__3; ++l) {
+ slartv_(&nr, &ab[ka1 - l + (j1 + l) * ab_dim1], &inca, &
+ ab[*ka - l + (j1 + l) * ab_dim1], &inca, &work[*n
+ + m - *kb + j1], &work[m - *kb + j1], &ka1);
+/* L660: */
+ }
+
+/* apply rotations in 2nd set from both sides to diagonal */
+/* blocks */
+
+ slar2v_(&nr, &ab[ka1 + j1 * ab_dim1], &ab[ka1 + (j1 - 1) *
+ ab_dim1], &ab[*ka + j1 * ab_dim1], &inca, &work[*n +
+ m - *kb + j1], &work[m - *kb + j1], &ka1);
+
+ }
+
+/* start applying rotations in 2nd set from the right */
+
+ i__3 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__3; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ slartv_(&nrt, &ab[l + j1t * ab_dim1], &inca, &ab[l + 1 + (
+ j1t - 1) * ab_dim1], &inca, &work[*n + m - *kb +
+ j1t], &work[m - *kb + j1t], &ka1);
+ }
+/* L670: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 2nd set */
+
+ i__3 = j2;
+ i__4 = ka1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+ srot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1
+ + 1], &c__1, &work[*n + m - *kb + j], &work[m - *
+ kb + j]);
+/* L680: */
+ }
+ }
+/* L690: */
+ }
+
+ i__4 = *kb - 1;
+ for (k = 1; k <= i__4; ++k) {
+/* Computing MAX */
+ i__3 = 1, i__1 = k + i0 - m + 1;
+ j2 = i__ + k + 1 - max(i__3,i__1) * ka1;
+
+/* finish applying rotations in 1st set from the right */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ slartv_(&nrt, &ab[l + j1t * ab_dim1], &inca, &ab[l + 1 + (
+ j1t - 1) * ab_dim1], &inca, &work[*n + j1t], &
+ work[j1t], &ka1);
+ }
+/* L700: */
+ }
+/* L710: */
+ }
+
+ if (*kb > 1) {
+/* Computing MIN */
+ i__3 = i__ + *kb;
+ i__4 = min(i__3,m) - (*ka << 1) - 1;
+ for (j = 2; j <= i__4; ++j) {
+ work[*n + j] = work[*n + j + *ka];
+ work[j] = work[j + *ka];
+/* L720: */
+ }
+ }
+
+ } else {
+
+/* Transform A, working with the lower triangle */
+
+ if (update) {
+
+/* Form inv(S(i))**T * A * inv(S(i)) */
+
+ bii = bb[i__ * bb_dim1 + 1];
+ i__4 = i__;
+ for (j = i1; j <= i__4; ++j) {
+ ab[i__ - j + 1 + j * ab_dim1] /= bii;
+/* L730: */
+ }
+/* Computing MIN */
+ i__3 = *n, i__1 = i__ + *ka;
+ i__4 = min(i__3,i__1);
+ for (j = i__; j <= i__4; ++j) {
+ ab[j - i__ + 1 + i__ * ab_dim1] /= bii;
+/* L740: */
+ }
+ i__4 = i__ + kbt;
+ for (k = i__ + 1; k <= i__4; ++k) {
+ i__3 = i__ + kbt;
+ for (j = k; j <= i__3; ++j) {
+ ab[j - k + 1 + k * ab_dim1] = ab[j - k + 1 + k * ab_dim1]
+ - bb[j - i__ + 1 + i__ * bb_dim1] * ab[k - i__ +
+ 1 + i__ * ab_dim1] - bb[k - i__ + 1 + i__ *
+ bb_dim1] * ab[j - i__ + 1 + i__ * ab_dim1] + ab[
+ i__ * ab_dim1 + 1] * bb[j - i__ + 1 + i__ *
+ bb_dim1] * bb[k - i__ + 1 + i__ * bb_dim1];
+/* L750: */
+ }
+/* Computing MIN */
+ i__1 = *n, i__2 = i__ + *ka;
+ i__3 = min(i__1,i__2);
+ for (j = i__ + kbt + 1; j <= i__3; ++j) {
+ ab[j - k + 1 + k * ab_dim1] -= bb[k - i__ + 1 + i__ *
+ bb_dim1] * ab[j - i__ + 1 + i__ * ab_dim1];
+/* L760: */
+ }
+/* L770: */
+ }
+ i__4 = i__;
+ for (j = i1; j <= i__4; ++j) {
+/* Computing MIN */
+ i__1 = j + *ka, i__2 = i__ + kbt;
+ i__3 = min(i__1,i__2);
+ for (k = i__ + 1; k <= i__3; ++k) {
+ ab[k - j + 1 + j * ab_dim1] -= bb[k - i__ + 1 + i__ *
+ bb_dim1] * ab[i__ - j + 1 + j * ab_dim1];
+/* L780: */
+ }
+/* L790: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by inv(S(i)) */
+
+ r__1 = 1.f / bii;
+ sscal_(&nx, &r__1, &x[i__ * x_dim1 + 1], &c__1);
+ if (kbt > 0) {
+ sger_(&nx, &kbt, &c_b20, &x[i__ * x_dim1 + 1], &c__1, &bb[
+ i__ * bb_dim1 + 2], &c__1, &x[(i__ + 1) * x_dim1
+ + 1], ldx);
+ }
+ }
+
+/* store a(i,i1) in RA1 for use in next loop over K */
+
+ ra1 = ab[i__ - i1 + 1 + i1 * ab_dim1];
+ }
+
+/* Generate and apply vectors of rotations to chase all the */
+/* existing bulges KA positions up toward the top of the band */
+
+ i__4 = *kb - 1;
+ for (k = 1; k <= i__4; ++k) {
+ if (update) {
+
+/* Determine the rotations which would annihilate the bulge */
+/* which has in theory just been created */
+
+ if (i__ + k - ka1 > 0 && i__ + k < m) {
+
+/* generate rotation to annihilate a(i,i+k-ka-1) */
+
+ slartg_(&ab[ka1 - k + (i__ + k - *ka) * ab_dim1], &ra1, &
+ work[*n + i__ + k - *ka], &work[i__ + k - *ka], &
+ ra);
+
+/* create nonzero element a(i+k,i+k-ka-1) outside the */
+/* band and store it in WORK(m-kb+i+k) */
+
+ t = -bb[k + 1 + i__ * bb_dim1] * ra1;
+ work[m - *kb + i__ + k] = work[*n + i__ + k - *ka] * t -
+ work[i__ + k - *ka] * ab[ka1 + (i__ + k - *ka) *
+ ab_dim1];
+ ab[ka1 + (i__ + k - *ka) * ab_dim1] = work[i__ + k - *ka]
+ * t + work[*n + i__ + k - *ka] * ab[ka1 + (i__ +
+ k - *ka) * ab_dim1];
+ ra1 = ra;
+ }
+ }
+/* Computing MAX */
+ i__3 = 1, i__1 = k + i0 - m + 1;
+ j2 = i__ + k + 1 - max(i__3,i__1) * ka1;
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ if (update) {
+/* Computing MIN */
+ i__3 = j2, i__1 = i__ - (*ka << 1) + k - 1;
+ j2t = min(i__3,i__1);
+ } else {
+ j2t = j2;
+ }
+ nrt = (j2t + *ka - 1) / ka1;
+ i__3 = j2t;
+ i__1 = ka1;
+ for (j = j1; i__1 < 0 ? j >= i__3 : j <= i__3; j += i__1) {
+
+/* create nonzero element a(j+ka,j-1) outside the band */
+/* and store it in WORK(j) */
+
+ work[j] *= ab[ka1 + (j - 1) * ab_dim1];
+ ab[ka1 + (j - 1) * ab_dim1] = work[*n + j] * ab[ka1 + (j - 1)
+ * ab_dim1];
+/* L800: */
+ }
+
+/* generate rotations in 1st set to annihilate elements which */
+/* have been created outside the band */
+
+ if (nrt > 0) {
+ slargv_(&nrt, &ab[ka1 + j1 * ab_dim1], &inca, &work[j1], &ka1,
+ &work[*n + j1], &ka1);
+ }
+ if (nr > 0) {
+
+/* apply rotations in 1st set from the right */
+
+ i__1 = *ka - 1;
+ for (l = 1; l <= i__1; ++l) {
+ slartv_(&nr, &ab[l + 1 + j1 * ab_dim1], &inca, &ab[l + 2
+ + (j1 - 1) * ab_dim1], &inca, &work[*n + j1], &
+ work[j1], &ka1);
+/* L810: */
+ }
+
+/* apply rotations in 1st set from both sides to diagonal */
+/* blocks */
+
+ slar2v_(&nr, &ab[j1 * ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 +
+ 1], &ab[(j1 - 1) * ab_dim1 + 2], &inca, &work[*n + j1]
+, &work[j1], &ka1);
+
+ }
+
+/* start applying rotations in 1st set from the left */
+
+ i__1 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__1; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ slartv_(&nrt, &ab[ka1 - l + 1 + (j1t - ka1 + l) * ab_dim1]
+, &inca, &ab[ka1 - l + (j1t - ka1 + l) * ab_dim1],
+ &inca, &work[*n + j1t], &work[j1t], &ka1);
+ }
+/* L820: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 1st set */
+
+ i__1 = j2;
+ i__3 = ka1;
+ for (j = j1; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) {
+ srot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1
+ + 1], &c__1, &work[*n + j], &work[j]);
+/* L830: */
+ }
+ }
+/* L840: */
+ }
+
+ if (update) {
+ if (i2 > 0 && kbt > 0) {
+
+/* create nonzero element a(i+kbt,i+kbt-ka-1) outside the */
+/* band and store it in WORK(m-kb+i+kbt) */
+
+ work[m - *kb + i__ + kbt] = -bb[kbt + 1 + i__ * bb_dim1] *
+ ra1;
+ }
+ }
+
+ for (k = *kb; k >= 1; --k) {
+ if (update) {
+/* Computing MAX */
+ i__4 = 2, i__3 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__4,i__3) * ka1;
+ } else {
+/* Computing MAX */
+ i__4 = 1, i__3 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__4,i__3) * ka1;
+ }
+
+/* finish applying rotations in 2nd set from the left */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (j2 + *ka + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ slartv_(&nrt, &ab[ka1 - l + 1 + (j1t + l - 1) * ab_dim1],
+ &inca, &ab[ka1 - l + (j1t + l - 1) * ab_dim1], &
+ inca, &work[*n + m - *kb + j1t + *ka], &work[m - *
+ kb + j1t + *ka], &ka1);
+ }
+/* L850: */
+ }
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ i__4 = j2;
+ i__3 = ka1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) {
+ work[m - *kb + j] = work[m - *kb + j + *ka];
+ work[*n + m - *kb + j] = work[*n + m - *kb + j + *ka];
+/* L860: */
+ }
+ i__3 = j2;
+ i__4 = ka1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+
+/* create nonzero element a(j+ka,j-1) outside the band */
+/* and store it in WORK(m-kb+j) */
+
+ work[m - *kb + j] *= ab[ka1 + (j - 1) * ab_dim1];
+ ab[ka1 + (j - 1) * ab_dim1] = work[*n + m - *kb + j] * ab[ka1
+ + (j - 1) * ab_dim1];
+/* L870: */
+ }
+ if (update) {
+ if (i__ + k > ka1 && k <= kbt) {
+ work[m - *kb + i__ + k - *ka] = work[m - *kb + i__ + k];
+ }
+ }
+/* L880: */
+ }
+
+ for (k = *kb; k >= 1; --k) {
+/* Computing MAX */
+ i__4 = 1, i__3 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__4,i__3) * ka1;
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ if (nr > 0) {
+
+/* generate rotations in 2nd set to annihilate elements */
+/* which have been created outside the band */
+
+ slargv_(&nr, &ab[ka1 + j1 * ab_dim1], &inca, &work[m - *kb +
+ j1], &ka1, &work[*n + m - *kb + j1], &ka1);
+
+/* apply rotations in 2nd set from the right */
+
+ i__4 = *ka - 1;
+ for (l = 1; l <= i__4; ++l) {
+ slartv_(&nr, &ab[l + 1 + j1 * ab_dim1], &inca, &ab[l + 2
+ + (j1 - 1) * ab_dim1], &inca, &work[*n + m - *kb
+ + j1], &work[m - *kb + j1], &ka1);
+/* L890: */
+ }
+
+/* apply rotations in 2nd set from both sides to diagonal */
+/* blocks */
+
+ slar2v_(&nr, &ab[j1 * ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 +
+ 1], &ab[(j1 - 1) * ab_dim1 + 2], &inca, &work[*n + m
+ - *kb + j1], &work[m - *kb + j1], &ka1);
+
+ }
+
+/* start applying rotations in 2nd set from the left */
+
+ i__4 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__4; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ slartv_(&nrt, &ab[ka1 - l + 1 + (j1t - ka1 + l) * ab_dim1]
+, &inca, &ab[ka1 - l + (j1t - ka1 + l) * ab_dim1],
+ &inca, &work[*n + m - *kb + j1t], &work[m - *kb
+ + j1t], &ka1);
+ }
+/* L900: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 2nd set */
+
+ i__4 = j2;
+ i__3 = ka1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) {
+ srot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1
+ + 1], &c__1, &work[*n + m - *kb + j], &work[m - *
+ kb + j]);
+/* L910: */
+ }
+ }
+/* L920: */
+ }
+
+ i__3 = *kb - 1;
+ for (k = 1; k <= i__3; ++k) {
+/* Computing MAX */
+ i__4 = 1, i__1 = k + i0 - m + 1;
+ j2 = i__ + k + 1 - max(i__4,i__1) * ka1;
+
+/* finish applying rotations in 1st set from the left */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ slartv_(&nrt, &ab[ka1 - l + 1 + (j1t - ka1 + l) * ab_dim1]
+, &inca, &ab[ka1 - l + (j1t - ka1 + l) * ab_dim1],
+ &inca, &work[*n + j1t], &work[j1t], &ka1);
+ }
+/* L930: */
+ }
+/* L940: */
+ }
+
+ if (*kb > 1) {
+/* Computing MIN */
+ i__4 = i__ + *kb;
+ i__3 = min(i__4,m) - (*ka << 1) - 1;
+ for (j = 2; j <= i__3; ++j) {
+ work[*n + j] = work[*n + j + *ka];
+ work[j] = work[j + *ka];
+/* L950: */
+ }
+ }
+
+ }
+
+ goto L490;
+
+/* End of SSBGST */
+
+} /* ssbgst_ */
diff --git a/SRC/ssbgv.c b/SRC/ssbgv.c
new file mode 100644
index 0000000..bdd9525
--- /dev/null
+++ b/SRC/ssbgv.c
@@ -0,0 +1,232 @@
+/* ssbgv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ssbgv_(char *jobz, char *uplo, integer *n, integer *ka,
+ integer *kb, real *ab, integer *ldab, real *bb, integer *ldbb, real *
+ w, real *z__, integer *ldz, real *work, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, bb_dim1, bb_offset, z_dim1, z_offset, i__1;
+
+ /* Local variables */
+ integer inde;
+ char vect[1];
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical upper, wantz;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer indwrk;
+ extern /* Subroutine */ int spbstf_(char *, integer *, integer *, real *,
+ integer *, integer *), ssbtrd_(char *, char *, integer *,
+ integer *, real *, integer *, real *, real *, real *, integer *,
+ real *, integer *), ssbgst_(char *, char *,
+ integer *, integer *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, real *, integer *),
+ ssterf_(integer *, real *, real *, integer *), ssteqr_(char *,
+ integer *, real *, real *, real *, integer *, real *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSBGV computes all the eigenvalues, and optionally, the eigenvectors */
+/* of a real generalized symmetric-definite banded eigenproblem, of */
+/* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric */
+/* and banded, and B is also positive definite. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* KA (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */
+
+/* KB (input) INTEGER */
+/* The number of superdiagonals of the matrix B if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KB >= 0. */
+
+/* AB (input/output) REAL array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first ka+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */
+
+/* On exit, the contents of AB are destroyed. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KA+1. */
+
+/* BB (input/output) REAL array, dimension (LDBB, N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix B, stored in the first kb+1 rows of the array. The */
+/* j-th column of B is stored in the j-th column of the array BB */
+/* as follows: */
+/* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; */
+/* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). */
+
+/* On exit, the factor S from the split Cholesky factorization */
+/* B = S**T*S, as returned by SPBSTF. */
+
+/* LDBB (input) INTEGER */
+/* The leading dimension of the array BB. LDBB >= KB+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) REAL array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
+/* eigenvectors, with the i-th column of Z holding the */
+/* eigenvector associated with W(i). The eigenvectors are */
+/* normalized so that Z**T*B*Z = I. */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= N. */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is: */
+/* <= N: the algorithm failed to converge: */
+/* i off-diagonal elements of an intermediate */
+/* tridiagonal form did not converge to zero; */
+/* > N: if INFO = N + i, for 1 <= i <= N, then SPBSTF */
+/* returned INFO = i: B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ bb_dim1 = *ldbb;
+ bb_offset = 1 + bb_dim1;
+ bb -= bb_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ka < 0) {
+ *info = -4;
+ } else if (*kb < 0 || *kb > *ka) {
+ *info = -5;
+ } else if (*ldab < *ka + 1) {
+ *info = -7;
+ } else if (*ldbb < *kb + 1) {
+ *info = -9;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSBGV ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a split Cholesky factorization of B. */
+
+ spbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem. */
+
+ inde = 1;
+ indwrk = inde + *n;
+ ssbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb,
+ &z__[z_offset], ldz, &work[indwrk], &iinfo)
+ ;
+
+/* Reduce to tridiagonal form. */
+
+ if (wantz) {
+ *(unsigned char *)vect = 'U';
+ } else {
+ *(unsigned char *)vect = 'N';
+ }
+ ssbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[
+ z_offset], ldz, &work[indwrk], &iinfo);
+
+/* For eigenvalues only, call SSTERF. For eigenvectors, call SSTEQR. */
+
+ if (! wantz) {
+ ssterf_(n, &w[1], &work[inde], info);
+ } else {
+ ssteqr_(jobz, n, &w[1], &work[inde], &z__[z_offset], ldz, &work[
+ indwrk], info);
+ }
+ return 0;
+
+/* End of SSBGV */
+
+} /* ssbgv_ */
diff --git a/SRC/ssbgvd.c b/SRC/ssbgvd.c
new file mode 100644
index 0000000..a3cebb6
--- /dev/null
+++ b/SRC/ssbgvd.c
@@ -0,0 +1,327 @@
+/* ssbgvd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b12 = 1.f;
+static real c_b13 = 0.f;
+
+/* Subroutine */ int ssbgvd_(char *jobz, char *uplo, integer *n, integer *ka,
+ integer *kb, real *ab, integer *ldab, real *bb, integer *ldbb, real *
+ w, real *z__, integer *ldz, real *work, integer *lwork, integer *
+ iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, bb_dim1, bb_offset, z_dim1, z_offset, i__1;
+
+ /* Local variables */
+ integer inde;
+ char vect[1];
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ integer lwmin;
+ logical upper, wantz;
+ integer indwk2, llwrk2;
+ extern /* Subroutine */ int xerbla_(char *, integer *), sstedc_(
+ char *, integer *, real *, real *, real *, integer *, real *,
+ integer *, integer *, integer *, integer *), slacpy_(char
+ *, integer *, integer *, real *, integer *, real *, integer *);
+ integer indwrk, liwmin;
+ extern /* Subroutine */ int spbstf_(char *, integer *, integer *, real *,
+ integer *, integer *), ssbtrd_(char *, char *, integer *,
+ integer *, real *, integer *, real *, real *, real *, integer *,
+ real *, integer *), ssbgst_(char *, char *,
+ integer *, integer *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, real *, integer *),
+ ssterf_(integer *, real *, real *, integer *);
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSBGVD computes all the eigenvalues, and optionally, the eigenvectors */
+/* of a real generalized symmetric-definite banded eigenproblem, of the */
+/* form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and */
+/* banded, and B is also positive definite. If eigenvectors are */
+/* desired, it uses a divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* KA (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */
+
+/* KB (input) INTEGER */
+/* The number of superdiagonals of the matrix B if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KB >= 0. */
+
+/* AB (input/output) REAL array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first ka+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */
+
+/* On exit, the contents of AB are destroyed. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KA+1. */
+
+/* BB (input/output) REAL array, dimension (LDBB, N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix B, stored in the first kb+1 rows of the array. The */
+/* j-th column of B is stored in the j-th column of the array BB */
+/* as follows: */
+/* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; */
+/* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). */
+
+/* On exit, the factor S from the split Cholesky factorization */
+/* B = S**T*S, as returned by SPBSTF. */
+
+/* LDBB (input) INTEGER */
+/* The leading dimension of the array BB. LDBB >= KB+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) REAL array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
+/* eigenvectors, with the i-th column of Z holding the */
+/* eigenvector associated with W(i). The eigenvectors are */
+/* normalized so Z**T*B*Z = I. */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If N <= 1, LWORK >= 1. */
+/* If JOBZ = 'N' and N > 1, LWORK >= 3*N. */
+/* If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK and IWORK */
+/* arrays, returns these values as the first entries of the WORK */
+/* and IWORK arrays, and no error message related to LWORK or */
+/* LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If JOBZ = 'N' or N <= 1, LIWORK >= 1. */
+/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK and IWORK arrays, and no error message related to */
+/* LWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is: */
+/* <= N: the algorithm failed to converge: */
+/* i off-diagonal elements of an intermediate */
+/* tridiagonal form did not converge to zero; */
+/* > N: if INFO = N + i, for 1 <= i <= N, then SPBSTF */
+/* returned INFO = i: B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ bb_dim1 = *ldbb;
+ bb_offset = 1 + bb_dim1;
+ bb -= bb_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1 || *liwork == -1;
+
+ *info = 0;
+ if (*n <= 1) {
+ liwmin = 1;
+ lwmin = 1;
+ } else if (wantz) {
+ liwmin = *n * 5 + 3;
+/* Computing 2nd power */
+ i__1 = *n;
+ lwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
+ } else {
+ liwmin = 1;
+ lwmin = *n << 1;
+ }
+
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ka < 0) {
+ *info = -4;
+ } else if (*kb < 0 || *kb > *ka) {
+ *info = -5;
+ } else if (*ldab < *ka + 1) {
+ *info = -7;
+ } else if (*ldbb < *kb + 1) {
+ *info = -9;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -12;
+ }
+
+ if (*info == 0) {
+ work[1] = (real) lwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -14;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -16;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSBGVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a split Cholesky factorization of B. */
+
+ spbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem. */
+
+ inde = 1;
+ indwrk = inde + *n;
+ indwk2 = indwrk + *n * *n;
+ llwrk2 = *lwork - indwk2 + 1;
+ ssbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb,
+ &z__[z_offset], ldz, &work[indwrk], &iinfo)
+ ;
+
+/* Reduce to tridiagonal form. */
+
+ if (wantz) {
+ *(unsigned char *)vect = 'U';
+ } else {
+ *(unsigned char *)vect = 'N';
+ }
+ ssbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[
+ z_offset], ldz, &work[indwrk], &iinfo);
+
+/* For eigenvalues only, call SSTERF. For eigenvectors, call SSTEDC. */
+
+ if (! wantz) {
+ ssterf_(n, &w[1], &work[inde], info);
+ } else {
+ sstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], &
+ llwrk2, &iwork[1], liwork, info);
+ sgemm_("N", "N", n, n, n, &c_b12, &z__[z_offset], ldz, &work[indwrk],
+ n, &c_b13, &work[indwk2], n);
+ slacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz);
+ }
+
+ work[1] = (real) lwmin;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of SSBGVD */
+
+} /* ssbgvd_ */
diff --git a/SRC/ssbgvx.c b/SRC/ssbgvx.c
new file mode 100644
index 0000000..39873e5
--- /dev/null
+++ b/SRC/ssbgvx.c
@@ -0,0 +1,461 @@
+/* ssbgvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b25 = 1.f;
+static real c_b27 = 0.f;
+
+/* Subroutine */ int ssbgvx_(char *jobz, char *range, char *uplo, integer *n,
+ integer *ka, integer *kb, real *ab, integer *ldab, real *bb, integer *
+ ldbb, real *q, integer *ldq, real *vl, real *vu, integer *il, integer
+ *iu, real *abstol, integer *m, real *w, real *z__, integer *ldz, real
+ *work, integer *iwork, integer *ifail, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, bb_dim1, bb_offset, q_dim1, q_offset, z_dim1,
+ z_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, jj;
+ real tmp1;
+ integer indd, inde;
+ char vect[1];
+ logical test;
+ integer itmp1, indee;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ char order[1];
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ logical upper;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), sswap_(integer *, real *, integer *, real *, integer *
+);
+ logical wantz, alleig, indeig;
+ integer indibl;
+ logical valeig;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer indisp, indiwo;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+ integer indwrk;
+ extern /* Subroutine */ int spbstf_(char *, integer *, integer *, real *,
+ integer *, integer *), ssbtrd_(char *, char *, integer *,
+ integer *, real *, integer *, real *, real *, real *, integer *,
+ real *, integer *), ssbgst_(char *, char *,
+ integer *, integer *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, real *, integer *),
+ sstein_(integer *, real *, real *, integer *, real *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *,
+ integer *), ssterf_(integer *, real *, real *, integer *);
+ integer nsplit;
+ extern /* Subroutine */ int sstebz_(char *, char *, integer *, real *,
+ real *, integer *, integer *, real *, real *, real *, integer *,
+ integer *, real *, integer *, integer *, real *, integer *,
+ integer *), ssteqr_(char *, integer *, real *,
+ real *, real *, integer *, real *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSBGVX computes selected eigenvalues, and optionally, eigenvectors */
+/* of a real generalized symmetric-definite banded eigenproblem, of */
+/* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric */
+/* and banded, and B is also positive definite. Eigenvalues and */
+/* eigenvectors can be selected by specifying either all eigenvalues, */
+/* a range of values or a range of indices for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* KA (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */
+
+/* KB (input) INTEGER */
+/* The number of superdiagonals of the matrix B if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KB >= 0. */
+
+/* AB (input/output) REAL array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first ka+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */
+
+/* On exit, the contents of AB are destroyed. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KA+1. */
+
+/* BB (input/output) REAL array, dimension (LDBB, N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix B, stored in the first kb+1 rows of the array. The */
+/* j-th column of B is stored in the j-th column of the array BB */
+/* as follows: */
+/* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; */
+/* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). */
+
+/* On exit, the factor S from the split Cholesky factorization */
+/* B = S**T*S, as returned by SPBSTF. */
+
+/* LDBB (input) INTEGER */
+/* The leading dimension of the array BB. LDBB >= KB+1. */
+
+/* Q (output) REAL array, dimension (LDQ, N) */
+/* If JOBZ = 'V', the n-by-n matrix used in the reduction of */
+/* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x, */
+/* and consequently C to tridiagonal form. */
+/* If JOBZ = 'N', the array Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. If JOBZ = 'N', */
+/* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N). */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) REAL */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing A to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*SLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*SLAMCH('S'). */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) REAL array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
+/* eigenvectors, with the i-th column of Z holding the */
+/* eigenvector associated with W(i). The eigenvectors are */
+/* normalized so Z**T*B*Z = I. */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) REAL array, dimension (7N) */
+
+/* IWORK (workspace/output) INTEGER array, dimension (5N) */
+
+/* IFAIL (output) INTEGER array, dimension (M) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvalues that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit */
+/* < 0 : if INFO = -i, the i-th argument had an illegal value */
+/* <= N: if INFO = i, then i eigenvectors failed to converge. */
+/* Their indices are stored in IFAIL. */
+/* > N : SPBSTF returned an error code; i.e., */
+/* if INFO = N + i, for 1 <= i <= N, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ bb_dim1 = *ldbb;
+ bb_offset = 1 + bb_dim1;
+ bb -= bb_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ka < 0) {
+ *info = -5;
+ } else if (*kb < 0 || *kb > *ka) {
+ *info = -6;
+ } else if (*ldab < *ka + 1) {
+ *info = -8;
+ } else if (*ldbb < *kb + 1) {
+ *info = -10;
+ } else if (*ldq < 1 || wantz && *ldq < *n) {
+ *info = -12;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -14;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -15;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -16;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -21;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSBGVX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a split Cholesky factorization of B. */
+
+ spbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem. */
+
+ ssbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb,
+ &q[q_offset], ldq, &work[1], &iinfo);
+
+/* Reduce symmetric band matrix to tridiagonal form. */
+
+ indd = 1;
+ inde = indd + *n;
+ indwrk = inde + *n;
+ if (wantz) {
+ *(unsigned char *)vect = 'U';
+ } else {
+ *(unsigned char *)vect = 'N';
+ }
+ ssbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &work[indd], &work[inde],
+ &q[q_offset], ldq, &work[indwrk], &iinfo);
+
+/* If all eigenvalues are desired and ABSTOL is less than or equal */
+/* to zero, then call SSTERF or SSTEQR. If this fails for some */
+/* eigenvalue, then try SSTEBZ. */
+
+ test = FALSE_;
+ if (indeig) {
+ if (*il == 1 && *iu == *n) {
+ test = TRUE_;
+ }
+ }
+ if ((alleig || test) && *abstol <= 0.f) {
+ scopy_(n, &work[indd], &c__1, &w[1], &c__1);
+ indee = indwrk + (*n << 1);
+ i__1 = *n - 1;
+ scopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
+ if (! wantz) {
+ ssterf_(n, &w[1], &work[indee], info);
+ } else {
+ slacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz);
+ ssteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[
+ indwrk], info);
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ifail[i__] = 0;
+/* L10: */
+ }
+ }
+ }
+ if (*info == 0) {
+ *m = *n;
+ goto L30;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call SSTEBZ and, if eigenvectors are desired, */
+/* call SSTEIN. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ indibl = 1;
+ indisp = indibl + *n;
+ indiwo = indisp + *n;
+ sstebz_(range, order, n, vl, vu, il, iu, abstol, &work[indd], &work[inde],
+ m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[indwrk],
+ &iwork[indiwo], info);
+
+ if (wantz) {
+ sstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
+ indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &
+ ifail[1], info);
+
+/* Apply transformation matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by SSTEIN. */
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1);
+ sgemv_("N", n, n, &c_b25, &q[q_offset], ldq, &work[1], &c__1, &
+ c_b27, &z__[j * z_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+
+L30:
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L40: */
+ }
+
+ if (i__ != 0) {
+ itmp1 = iwork[indibl + i__ - 1];
+ w[i__] = w[j];
+ iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
+ w[j] = tmp1;
+ iwork[indibl + j - 1] = itmp1;
+ sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ if (*info != 0) {
+ itmp1 = ifail[i__];
+ ifail[i__] = ifail[j];
+ ifail[j] = itmp1;
+ }
+ }
+/* L50: */
+ }
+ }
+
+ return 0;
+
+/* End of SSBGVX */
+
+} /* ssbgvx_ */
diff --git a/SRC/ssbtrd.c b/SRC/ssbtrd.c
new file mode 100644
index 0000000..32b9bcd
--- /dev/null
+++ b/SRC/ssbtrd.c
@@ -0,0 +1,710 @@
+/* ssbtrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b9 = 0.f;
+static real c_b10 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int ssbtrd_(char *vect, char *uplo, integer *n, integer *kd,
+ real *ab, integer *ldab, real *d__, real *e, real *q, integer *ldq,
+ real *work, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, q_dim1, q_offset, i__1, i__2, i__3, i__4,
+ i__5;
+
+ /* Local variables */
+ integer i__, j, k, l, i2, j1, j2, nq, nr, kd1, ibl, iqb, kdn, jin, nrt,
+ kdm1, inca, jend, lend, jinc, incx, last;
+ real temp;
+ extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
+ integer *, real *, real *);
+ integer j1end, j1inc, iqend;
+ extern logical lsame_(char *, char *);
+ logical initq, wantq, upper;
+ extern /* Subroutine */ int slar2v_(integer *, real *, real *, real *,
+ integer *, real *, real *, integer *);
+ integer iqaend;
+ extern /* Subroutine */ int xerbla_(char *, integer *), slaset_(
+ char *, integer *, integer *, real *, real *, real *, integer *), slartg_(real *, real *, real *, real *, real *), slargv_(
+ integer *, real *, integer *, real *, integer *, real *, integer *
+), slartv_(integer *, real *, integer *, real *, integer *, real *
+, real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSBTRD reduces a real symmetric band matrix A to symmetric */
+/* tridiagonal form T by an orthogonal similarity transformation: */
+/* Q**T * A * Q = T. */
+
+/* Arguments */
+/* ========= */
+
+/* VECT (input) CHARACTER*1 */
+/* = 'N': do not form Q; */
+/* = 'V': form Q; */
+/* = 'U': update a matrix X, by forming X*Q. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) REAL array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+/* On exit, the diagonal elements of AB are overwritten by the */
+/* diagonal elements of the tridiagonal matrix T; if KD > 0, the */
+/* elements on the first superdiagonal (if UPLO = 'U') or the */
+/* first subdiagonal (if UPLO = 'L') are overwritten by the */
+/* off-diagonal elements of T; the rest of AB is overwritten by */
+/* values generated during the reduction. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* D (output) REAL array, dimension (N) */
+/* The diagonal elements of the tridiagonal matrix T. */
+
+/* E (output) REAL array, dimension (N-1) */
+/* The off-diagonal elements of the tridiagonal matrix T: */
+/* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'. */
+
+/* Q (input/output) REAL array, dimension (LDQ,N) */
+/* On entry, if VECT = 'U', then Q must contain an N-by-N */
+/* matrix X; if VECT = 'N' or 'V', then Q need not be set. */
+
+/* On exit: */
+/* if VECT = 'V', Q contains the N-by-N orthogonal matrix Q; */
+/* if VECT = 'U', Q contains the product X*Q; */
+/* if VECT = 'N', the array Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. */
+/* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'. */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* Modified by Linda Kaufman, Bell Labs. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --d__;
+ --e;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+
+ /* Function Body */
+ initq = lsame_(vect, "V");
+ wantq = initq || lsame_(vect, "U");
+ upper = lsame_(uplo, "U");
+ kd1 = *kd + 1;
+ kdm1 = *kd - 1;
+ incx = *ldab - 1;
+ iqend = 1;
+
+ *info = 0;
+ if (! wantq && ! lsame_(vect, "N")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kd < 0) {
+ *info = -4;
+ } else if (*ldab < kd1) {
+ *info = -6;
+ } else if (*ldq < max(1,*n) && wantq) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSBTRD", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Initialize Q to the unit matrix, if needed */
+
+ if (initq) {
+ slaset_("Full", n, n, &c_b9, &c_b10, &q[q_offset], ldq);
+ }
+
+/* Wherever possible, plane rotations are generated and applied in */
+/* vector operations of length NR over the index set J1:J2:KD1. */
+
+/* The cosines and sines of the plane rotations are stored in the */
+/* arrays D and WORK. */
+
+ inca = kd1 * *ldab;
+/* Computing MIN */
+ i__1 = *n - 1;
+ kdn = min(i__1,*kd);
+ if (upper) {
+
+ if (*kd > 1) {
+
+/* Reduce to tridiagonal form, working with upper triangle */
+
+ nr = 0;
+ j1 = kdn + 2;
+ j2 = 1;
+
+ i__1 = *n - 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Reduce i-th row of matrix to tridiagonal form */
+
+ for (k = kdn + 1; k >= 2; --k) {
+ j1 += kdn;
+ j2 += kdn;
+
+ if (nr > 0) {
+
+/* generate plane rotations to annihilate nonzero */
+/* elements which have been created outside the band */
+
+ slargv_(&nr, &ab[(j1 - 1) * ab_dim1 + 1], &inca, &
+ work[j1], &kd1, &d__[j1], &kd1);
+
+/* apply rotations from the right */
+
+
+/* Dependent on the the number of diagonals either */
+/* SLARTV or SROT is used */
+
+ if (nr >= (*kd << 1) - 1) {
+ i__2 = *kd - 1;
+ for (l = 1; l <= i__2; ++l) {
+ slartv_(&nr, &ab[l + 1 + (j1 - 1) * ab_dim1],
+ &inca, &ab[l + j1 * ab_dim1], &inca, &
+ d__[j1], &work[j1], &kd1);
+/* L10: */
+ }
+
+ } else {
+ jend = j1 + (nr - 1) * kd1;
+ i__2 = jend;
+ i__3 = kd1;
+ for (jinc = j1; i__3 < 0 ? jinc >= i__2 : jinc <=
+ i__2; jinc += i__3) {
+ srot_(&kdm1, &ab[(jinc - 1) * ab_dim1 + 2], &
+ c__1, &ab[jinc * ab_dim1 + 1], &c__1,
+ &d__[jinc], &work[jinc]);
+/* L20: */
+ }
+ }
+ }
+
+
+ if (k > 2) {
+ if (k <= *n - i__ + 1) {
+
+/* generate plane rotation to annihilate a(i,i+k-1) */
+/* within the band */
+
+ slartg_(&ab[*kd - k + 3 + (i__ + k - 2) * ab_dim1]
+, &ab[*kd - k + 2 + (i__ + k - 1) *
+ ab_dim1], &d__[i__ + k - 1], &work[i__ +
+ k - 1], &temp);
+ ab[*kd - k + 3 + (i__ + k - 2) * ab_dim1] = temp;
+
+/* apply rotation from the right */
+
+ i__3 = k - 3;
+ srot_(&i__3, &ab[*kd - k + 4 + (i__ + k - 2) *
+ ab_dim1], &c__1, &ab[*kd - k + 3 + (i__ +
+ k - 1) * ab_dim1], &c__1, &d__[i__ + k -
+ 1], &work[i__ + k - 1]);
+ }
+ ++nr;
+ j1 = j1 - kdn - 1;
+ }
+
+/* apply plane rotations from both sides to diagonal */
+/* blocks */
+
+ if (nr > 0) {
+ slar2v_(&nr, &ab[kd1 + (j1 - 1) * ab_dim1], &ab[kd1 +
+ j1 * ab_dim1], &ab[*kd + j1 * ab_dim1], &inca,
+ &d__[j1], &work[j1], &kd1);
+ }
+
+/* apply plane rotations from the left */
+
+ if (nr > 0) {
+ if ((*kd << 1) - 1 < nr) {
+
+/* Dependent on the the number of diagonals either */
+/* SLARTV or SROT is used */
+
+ i__3 = *kd - 1;
+ for (l = 1; l <= i__3; ++l) {
+ if (j2 + l > *n) {
+ nrt = nr - 1;
+ } else {
+ nrt = nr;
+ }
+ if (nrt > 0) {
+ slartv_(&nrt, &ab[*kd - l + (j1 + l) *
+ ab_dim1], &inca, &ab[*kd - l + 1
+ + (j1 + l) * ab_dim1], &inca, &
+ d__[j1], &work[j1], &kd1);
+ }
+/* L30: */
+ }
+ } else {
+ j1end = j1 + kd1 * (nr - 2);
+ if (j1end >= j1) {
+ i__3 = j1end;
+ i__2 = kd1;
+ for (jin = j1; i__2 < 0 ? jin >= i__3 : jin <=
+ i__3; jin += i__2) {
+ i__4 = *kd - 1;
+ srot_(&i__4, &ab[*kd - 1 + (jin + 1) *
+ ab_dim1], &incx, &ab[*kd + (jin +
+ 1) * ab_dim1], &incx, &d__[jin], &
+ work[jin]);
+/* L40: */
+ }
+ }
+/* Computing MIN */
+ i__2 = kdm1, i__3 = *n - j2;
+ lend = min(i__2,i__3);
+ last = j1end + kd1;
+ if (lend > 0) {
+ srot_(&lend, &ab[*kd - 1 + (last + 1) *
+ ab_dim1], &incx, &ab[*kd + (last + 1)
+ * ab_dim1], &incx, &d__[last], &work[
+ last]);
+ }
+ }
+ }
+
+ if (wantq) {
+
+/* accumulate product of plane rotations in Q */
+
+ if (initq) {
+
+/* take advantage of the fact that Q was */
+/* initially the Identity matrix */
+
+ iqend = max(iqend,j2);
+/* Computing MAX */
+ i__2 = 0, i__3 = k - 3;
+ i2 = max(i__2,i__3);
+ iqaend = i__ * *kd + 1;
+ if (k == 2) {
+ iqaend += *kd;
+ }
+ iqaend = min(iqaend,iqend);
+ i__2 = j2;
+ i__3 = kd1;
+ for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j
+ += i__3) {
+ ibl = i__ - i2 / kdm1;
+ ++i2;
+/* Computing MAX */
+ i__4 = 1, i__5 = j - ibl;
+ iqb = max(i__4,i__5);
+ nq = iqaend + 1 - iqb;
+/* Computing MIN */
+ i__4 = iqaend + *kd;
+ iqaend = min(i__4,iqend);
+ srot_(&nq, &q[iqb + (j - 1) * q_dim1], &c__1,
+ &q[iqb + j * q_dim1], &c__1, &d__[j],
+ &work[j]);
+/* L50: */
+ }
+ } else {
+
+ i__3 = j2;
+ i__2 = kd1;
+ for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j
+ += i__2) {
+ srot_(n, &q[(j - 1) * q_dim1 + 1], &c__1, &q[
+ j * q_dim1 + 1], &c__1, &d__[j], &
+ work[j]);
+/* L60: */
+ }
+ }
+
+ }
+
+ if (j2 + kdn > *n) {
+
+/* adjust J2 to keep within the bounds of the matrix */
+
+ --nr;
+ j2 = j2 - kdn - 1;
+ }
+
+ i__2 = j2;
+ i__3 = kd1;
+ for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j += i__3)
+ {
+
+/* create nonzero element a(j-1,j+kd) outside the band */
+/* and store it in WORK */
+
+ work[j + *kd] = work[j] * ab[(j + *kd) * ab_dim1 + 1];
+ ab[(j + *kd) * ab_dim1 + 1] = d__[j] * ab[(j + *kd) *
+ ab_dim1 + 1];
+/* L70: */
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+
+ if (*kd > 0) {
+
+/* copy off-diagonal elements to E */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ e[i__] = ab[*kd + (i__ + 1) * ab_dim1];
+/* L100: */
+ }
+ } else {
+
+/* set E to zero if original matrix was diagonal */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ e[i__] = 0.f;
+/* L110: */
+ }
+ }
+
+/* copy diagonal elements to D */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = ab[kd1 + i__ * ab_dim1];
+/* L120: */
+ }
+
+ } else {
+
+ if (*kd > 1) {
+
+/* Reduce to tridiagonal form, working with lower triangle */
+
+ nr = 0;
+ j1 = kdn + 2;
+ j2 = 1;
+
+ i__1 = *n - 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Reduce i-th column of matrix to tridiagonal form */
+
+ for (k = kdn + 1; k >= 2; --k) {
+ j1 += kdn;
+ j2 += kdn;
+
+ if (nr > 0) {
+
+/* generate plane rotations to annihilate nonzero */
+/* elements which have been created outside the band */
+
+ slargv_(&nr, &ab[kd1 + (j1 - kd1) * ab_dim1], &inca, &
+ work[j1], &kd1, &d__[j1], &kd1);
+
+/* apply plane rotations from one side */
+
+
+/* Dependent on the the number of diagonals either */
+/* SLARTV or SROT is used */
+
+ if (nr > (*kd << 1) - 1) {
+ i__3 = *kd - 1;
+ for (l = 1; l <= i__3; ++l) {
+ slartv_(&nr, &ab[kd1 - l + (j1 - kd1 + l) *
+ ab_dim1], &inca, &ab[kd1 - l + 1 + (
+ j1 - kd1 + l) * ab_dim1], &inca, &d__[
+ j1], &work[j1], &kd1);
+/* L130: */
+ }
+ } else {
+ jend = j1 + kd1 * (nr - 1);
+ i__3 = jend;
+ i__2 = kd1;
+ for (jinc = j1; i__2 < 0 ? jinc >= i__3 : jinc <=
+ i__3; jinc += i__2) {
+ srot_(&kdm1, &ab[*kd + (jinc - *kd) * ab_dim1]
+, &incx, &ab[kd1 + (jinc - *kd) *
+ ab_dim1], &incx, &d__[jinc], &work[
+ jinc]);
+/* L140: */
+ }
+ }
+
+ }
+
+ if (k > 2) {
+ if (k <= *n - i__ + 1) {
+
+/* generate plane rotation to annihilate a(i+k-1,i) */
+/* within the band */
+
+ slartg_(&ab[k - 1 + i__ * ab_dim1], &ab[k + i__ *
+ ab_dim1], &d__[i__ + k - 1], &work[i__ +
+ k - 1], &temp);
+ ab[k - 1 + i__ * ab_dim1] = temp;
+
+/* apply rotation from the left */
+
+ i__2 = k - 3;
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ srot_(&i__2, &ab[k - 2 + (i__ + 1) * ab_dim1], &
+ i__3, &ab[k - 1 + (i__ + 1) * ab_dim1], &
+ i__4, &d__[i__ + k - 1], &work[i__ + k -
+ 1]);
+ }
+ ++nr;
+ j1 = j1 - kdn - 1;
+ }
+
+/* apply plane rotations from both sides to diagonal */
+/* blocks */
+
+ if (nr > 0) {
+ slar2v_(&nr, &ab[(j1 - 1) * ab_dim1 + 1], &ab[j1 *
+ ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 + 2], &
+ inca, &d__[j1], &work[j1], &kd1);
+ }
+
+/* apply plane rotations from the right */
+
+
+/* Dependent on the the number of diagonals either */
+/* SLARTV or SROT is used */
+
+ if (nr > 0) {
+ if (nr > (*kd << 1) - 1) {
+ i__2 = *kd - 1;
+ for (l = 1; l <= i__2; ++l) {
+ if (j2 + l > *n) {
+ nrt = nr - 1;
+ } else {
+ nrt = nr;
+ }
+ if (nrt > 0) {
+ slartv_(&nrt, &ab[l + 2 + (j1 - 1) *
+ ab_dim1], &inca, &ab[l + 1 + j1 *
+ ab_dim1], &inca, &d__[j1], &work[
+ j1], &kd1);
+ }
+/* L150: */
+ }
+ } else {
+ j1end = j1 + kd1 * (nr - 2);
+ if (j1end >= j1) {
+ i__2 = j1end;
+ i__3 = kd1;
+ for (j1inc = j1; i__3 < 0 ? j1inc >= i__2 :
+ j1inc <= i__2; j1inc += i__3) {
+ srot_(&kdm1, &ab[(j1inc - 1) * ab_dim1 +
+ 3], &c__1, &ab[j1inc * ab_dim1 +
+ 2], &c__1, &d__[j1inc], &work[
+ j1inc]);
+/* L160: */
+ }
+ }
+/* Computing MIN */
+ i__3 = kdm1, i__2 = *n - j2;
+ lend = min(i__3,i__2);
+ last = j1end + kd1;
+ if (lend > 0) {
+ srot_(&lend, &ab[(last - 1) * ab_dim1 + 3], &
+ c__1, &ab[last * ab_dim1 + 2], &c__1,
+ &d__[last], &work[last]);
+ }
+ }
+ }
+
+
+
+ if (wantq) {
+
+/* accumulate product of plane rotations in Q */
+
+ if (initq) {
+
+/* take advantage of the fact that Q was */
+/* initially the Identity matrix */
+
+ iqend = max(iqend,j2);
+/* Computing MAX */
+ i__3 = 0, i__2 = k - 3;
+ i2 = max(i__3,i__2);
+ iqaend = i__ * *kd + 1;
+ if (k == 2) {
+ iqaend += *kd;
+ }
+ iqaend = min(iqaend,iqend);
+ i__3 = j2;
+ i__2 = kd1;
+ for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j
+ += i__2) {
+ ibl = i__ - i2 / kdm1;
+ ++i2;
+/* Computing MAX */
+ i__4 = 1, i__5 = j - ibl;
+ iqb = max(i__4,i__5);
+ nq = iqaend + 1 - iqb;
+/* Computing MIN */
+ i__4 = iqaend + *kd;
+ iqaend = min(i__4,iqend);
+ srot_(&nq, &q[iqb + (j - 1) * q_dim1], &c__1,
+ &q[iqb + j * q_dim1], &c__1, &d__[j],
+ &work[j]);
+/* L170: */
+ }
+ } else {
+
+ i__2 = j2;
+ i__3 = kd1;
+ for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j
+ += i__3) {
+ srot_(n, &q[(j - 1) * q_dim1 + 1], &c__1, &q[
+ j * q_dim1 + 1], &c__1, &d__[j], &
+ work[j]);
+/* L180: */
+ }
+ }
+ }
+
+ if (j2 + kdn > *n) {
+
+/* adjust J2 to keep within the bounds of the matrix */
+
+ --nr;
+ j2 = j2 - kdn - 1;
+ }
+
+ i__3 = j2;
+ i__2 = kd1;
+ for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2)
+ {
+
+/* create nonzero element a(j+kd,j-1) outside the */
+/* band and store it in WORK */
+
+ work[j + *kd] = work[j] * ab[kd1 + j * ab_dim1];
+ ab[kd1 + j * ab_dim1] = d__[j] * ab[kd1 + j * ab_dim1]
+ ;
+/* L190: */
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+ }
+
+ if (*kd > 0) {
+
+/* copy off-diagonal elements to E */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ e[i__] = ab[i__ * ab_dim1 + 2];
+/* L220: */
+ }
+ } else {
+
+/* set E to zero if original matrix was diagonal */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ e[i__] = 0.f;
+/* L230: */
+ }
+ }
+
+/* copy diagonal elements to D */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = ab[i__ * ab_dim1 + 1];
+/* L240: */
+ }
+ }
+
+ return 0;
+
+/* End of SSBTRD */
+
+} /* ssbtrd_ */
diff --git a/SRC/ssfrk.c b/SRC/ssfrk.c
new file mode 100644
index 0000000..0b84159
--- /dev/null
+++ b/SRC/ssfrk.c
@@ -0,0 +1,516 @@
+/* ssfrk.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ssfrk_(char *transr, char *uplo, char *trans, integer *n,
+ integer *k, real *alpha, real *a, integer *lda, real *beta, real *
+ c__)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+
+ /* Local variables */
+ integer j, n1, n2, nk, info;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ integer nrowa;
+ logical lower;
+ extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *,
+ real *, real *, integer *, real *, real *, integer *), xerbla_(char *, integer *);
+ logical nisodd, notrans;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Level 3 BLAS like routine for C in RFP Format. */
+
+/* SSFRK performs one of the symmetric rank--k operations */
+
+/* C := alpha*A*A' + beta*C, */
+
+/* or */
+
+/* C := alpha*A'*A + beta*C, */
+
+/* where alpha and beta are real scalars, C is an n--by--n symmetric */
+/* matrix and A is an n--by--k matrix in the first case and a k--by--n */
+/* matrix in the second case. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': The Normal Form of RFP A is stored; */
+/* = 'T': The Transpose Form of RFP A is stored. */
+
+/* UPLO - (input) CHARACTER */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array C is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of C */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of C */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* TRANS - (input) CHARACTER */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. */
+
+/* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. */
+
+/* Unchanged on exit. */
+
+/* N - (input) INTEGER. */
+/* On entry, N specifies the order of the matrix C. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* K - (input) INTEGER. */
+/* On entry with TRANS = 'N' or 'n', K specifies the number */
+/* of columns of the matrix A, and on entry with TRANS = 'T' */
+/* or 't', K specifies the number of rows of the matrix A. K */
+/* must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - (input) REAL. */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - (input) REAL array of DIMENSION ( LDA, ka ), where KA */
+/* is K when TRANS = 'N' or 'n', and is N otherwise. Before */
+/* entry with TRANS = 'N' or 'n', the leading N--by--K part of */
+/* the array A must contain the matrix A, otherwise the leading */
+/* K--by--N part of the array A must contain the matrix A. */
+/* Unchanged on exit. */
+
+/* LDA - (input) INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When TRANS = 'N' or 'n' */
+/* then LDA must be at least max( 1, n ), otherwise LDA must */
+/* be at least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* BETA - (input) REAL. */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+
+/* C - (input/output) REAL array, dimension ( NT ); */
+/* NT = N*(N+1)/2. On entry, the symmetric matrix C in RFP */
+/* Format. RFP Format is described by TRANSR, UPLO and N. */
+
+/* Arguments */
+/* ========== */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --c__;
+
+ /* Function Body */
+ info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ notrans = lsame_(trans, "N");
+
+ if (notrans) {
+ nrowa = *n;
+ } else {
+ nrowa = *k;
+ }
+
+ if (! normaltransr && ! lsame_(transr, "T")) {
+ info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ info = -2;
+ } else if (! notrans && ! lsame_(trans, "T")) {
+ info = -3;
+ } else if (*n < 0) {
+ info = -4;
+ } else if (*k < 0) {
+ info = -5;
+ } else if (*lda < max(1,nrowa)) {
+ info = -8;
+ }
+ if (info != 0) {
+ i__1 = -info;
+ xerbla_("SSFRK ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+/* The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not */
+/* done (it is in SSYRK for example) and left in the general case. */
+
+ if (*n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) {
+ return 0;
+ }
+
+ if (*alpha == 0.f && *beta == 0.f) {
+ i__1 = *n * (*n + 1) / 2;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 0.f;
+ }
+ return 0;
+ }
+
+/* C is N-by-N. */
+/* If N is odd, set NISODD = .TRUE., and N1 and N2. */
+/* If N is even, NISODD = .FALSE., and NK. */
+
+ if (*n % 2 == 0) {
+ nisodd = FALSE_;
+ nk = *n / 2;
+ } else {
+ nisodd = TRUE_;
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+ }
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* N is odd, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' */
+
+ ssyrk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[1], n);
+ ssyrk_("U", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda,
+ beta, &c__[*n + 1], n);
+ sgemm_("N", "T", &n2, &n1, k, alpha, &a[n1 + 1 + a_dim1],
+ lda, &a[a_dim1 + 1], lda, beta, &c__[n1 + 1], n);
+
+ } else {
+
+/* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'T' */
+
+ ssyrk_("L", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[1], n);
+ ssyrk_("U", "T", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1],
+ lda, beta, &c__[*n + 1], n)
+ ;
+ sgemm_("T", "N", &n2, &n1, k, alpha, &a[(n1 + 1) * a_dim1
+ + 1], lda, &a[a_dim1 + 1], lda, beta, &c__[n1 + 1]
+, n);
+
+ }
+
+ } else {
+
+/* N is odd, TRANSR = 'N', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' */
+
+ ssyrk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[n2 + 1], n);
+ ssyrk_("U", "N", &n2, k, alpha, &a[n2 + a_dim1], lda,
+ beta, &c__[n1 + 1], n);
+ sgemm_("N", "T", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda,
+ &a[n2 + a_dim1], lda, beta, &c__[1], n);
+
+ } else {
+
+/* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'T' */
+
+ ssyrk_("L", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[n2 + 1], n);
+ ssyrk_("U", "T", &n2, k, alpha, &a[n2 * a_dim1 + 1], lda,
+ beta, &c__[n1 + 1], n);
+ sgemm_("T", "N", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda,
+ &a[n2 * a_dim1 + 1], lda, beta, &c__[1], n);
+
+ }
+
+ }
+
+ } else {
+
+/* N is odd, and TRANSR = 'T' */
+
+ if (lower) {
+
+/* N is odd, TRANSR = 'T', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'N' */
+
+ ssyrk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[1], &n1);
+ ssyrk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda,
+ beta, &c__[2], &n1);
+ sgemm_("N", "T", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda,
+ &a[n1 + 1 + a_dim1], lda, beta, &c__[n1 * n1 + 1],
+ &n1);
+
+ } else {
+
+/* N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'T' */
+
+ ssyrk_("U", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[1], &n1);
+ ssyrk_("L", "T", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1],
+ lda, beta, &c__[2], &n1);
+ sgemm_("T", "N", &n1, &n2, k, alpha, &a[a_dim1 + 1], lda,
+ &a[(n1 + 1) * a_dim1 + 1], lda, beta, &c__[n1 *
+ n1 + 1], &n1);
+
+ }
+
+ } else {
+
+/* N is odd, TRANSR = 'T', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'N' */
+
+ ssyrk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[n2 * n2 + 1], &n2);
+ ssyrk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda,
+ beta, &c__[n1 * n2 + 1], &n2);
+ sgemm_("N", "T", &n2, &n1, k, alpha, &a[n1 + 1 + a_dim1],
+ lda, &a[a_dim1 + 1], lda, beta, &c__[1], &n2);
+
+ } else {
+
+/* N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'T' */
+
+ ssyrk_("U", "T", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[n2 * n2 + 1], &n2);
+ ssyrk_("L", "T", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1],
+ lda, beta, &c__[n1 * n2 + 1], &n2);
+ sgemm_("T", "N", &n2, &n1, k, alpha, &a[(n1 + 1) * a_dim1
+ + 1], lda, &a[a_dim1 + 1], lda, beta, &c__[1], &
+ n2);
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* N is even, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' */
+
+ i__1 = *n + 1;
+ ssyrk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[2], &i__1);
+ i__1 = *n + 1;
+ ssyrk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
+ beta, &c__[1], &i__1);
+ i__1 = *n + 1;
+ sgemm_("N", "T", &nk, &nk, k, alpha, &a[nk + 1 + a_dim1],
+ lda, &a[a_dim1 + 1], lda, beta, &c__[nk + 2], &
+ i__1);
+
+ } else {
+
+/* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'T' */
+
+ i__1 = *n + 1;
+ ssyrk_("L", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[2], &i__1);
+ i__1 = *n + 1;
+ ssyrk_("U", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
+ lda, beta, &c__[1], &i__1);
+ i__1 = *n + 1;
+ sgemm_("T", "N", &nk, &nk, k, alpha, &a[(nk + 1) * a_dim1
+ + 1], lda, &a[a_dim1 + 1], lda, beta, &c__[nk + 2]
+, &i__1);
+
+ }
+
+ } else {
+
+/* N is even, TRANSR = 'N', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' */
+
+ i__1 = *n + 1;
+ ssyrk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk + 2], &i__1);
+ i__1 = *n + 1;
+ ssyrk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
+ beta, &c__[nk + 1], &i__1);
+ i__1 = *n + 1;
+ sgemm_("N", "T", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda,
+ &a[nk + 1 + a_dim1], lda, beta, &c__[1], &i__1);
+
+ } else {
+
+/* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'T' */
+
+ i__1 = *n + 1;
+ ssyrk_("L", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk + 2], &i__1);
+ i__1 = *n + 1;
+ ssyrk_("U", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
+ lda, beta, &c__[nk + 1], &i__1);
+ i__1 = *n + 1;
+ sgemm_("T", "N", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda,
+ &a[(nk + 1) * a_dim1 + 1], lda, beta, &c__[1], &
+ i__1);
+
+ }
+
+ }
+
+ } else {
+
+/* N is even, and TRANSR = 'T' */
+
+ if (lower) {
+
+/* N is even, TRANSR = 'T', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'N' */
+
+ ssyrk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk + 1], &nk);
+ ssyrk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
+ beta, &c__[1], &nk);
+ sgemm_("N", "T", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda,
+ &a[nk + 1 + a_dim1], lda, beta, &c__[(nk + 1) *
+ nk + 1], &nk);
+
+ } else {
+
+/* N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'T' */
+
+ ssyrk_("U", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk + 1], &nk);
+ ssyrk_("L", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
+ lda, beta, &c__[1], &nk);
+ sgemm_("T", "N", &nk, &nk, k, alpha, &a[a_dim1 + 1], lda,
+ &a[(nk + 1) * a_dim1 + 1], lda, beta, &c__[(nk +
+ 1) * nk + 1], &nk);
+
+ }
+
+ } else {
+
+/* N is even, TRANSR = 'T', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'N' */
+
+ ssyrk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk * (nk + 1) + 1], &nk);
+ ssyrk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
+ beta, &c__[nk * nk + 1], &nk);
+ sgemm_("N", "T", &nk, &nk, k, alpha, &a[nk + 1 + a_dim1],
+ lda, &a[a_dim1 + 1], lda, beta, &c__[1], &nk);
+
+ } else {
+
+/* N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'T' */
+
+ ssyrk_("U", "T", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk * (nk + 1) + 1], &nk);
+ ssyrk_("L", "T", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
+ lda, beta, &c__[nk * nk + 1], &nk);
+ sgemm_("T", "N", &nk, &nk, k, alpha, &a[(nk + 1) * a_dim1
+ + 1], lda, &a[a_dim1 + 1], lda, beta, &c__[1], &
+ nk);
+
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of SSFRK */
+
+} /* ssfrk_ */
diff --git a/SRC/sspcon.c b/SRC/sspcon.c
new file mode 100644
index 0000000..efbc487
--- /dev/null
+++ b/SRC/sspcon.c
@@ -0,0 +1,196 @@
+/* sspcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sspcon_(char *uplo, integer *n, real *ap, integer *ipiv,
+ real *anorm, real *rcond, real *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, ip, kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *,
+ real *, integer *, integer *), xerbla_(char *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int ssptrs_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSPCON estimates the reciprocal of the condition number (in the */
+/* 1-norm) of a real symmetric packed matrix A using the factorization */
+/* A = U*D*U**T or A = L*D*L**T computed by SSPTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) REAL array, dimension (N*(N+1)/2) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by SSPTRF, stored as a */
+/* packed triangular matrix. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by SSPTRF. */
+
+/* ANORM (input) REAL */
+/* The 1-norm of the original matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) REAL array, dimension (2*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --ipiv;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*anorm < 0.f) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSPCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.f;
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ } else if (*anorm <= 0.f) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ ip = *n * (*n + 1) / 2;
+ for (i__ = *n; i__ >= 1; --i__) {
+ if (ipiv[i__] > 0 && ap[ip] == 0.f) {
+ return 0;
+ }
+ ip -= i__;
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ ip = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (ipiv[i__] > 0 && ap[ip] == 0.f) {
+ return 0;
+ }
+ ip = ip + *n - i__ + 1;
+/* L20: */
+ }
+ }
+
+/* Estimate the 1-norm of the inverse. */
+
+ kase = 0;
+L30:
+ slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+
+/* Multiply by inv(L*D*L') or inv(U*D*U'). */
+
+ ssptrs_(uplo, n, &c__1, &ap[1], &ipiv[1], &work[1], n, info);
+ goto L30;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / ainvnm / *anorm;
+ }
+
+ return 0;
+
+/* End of SSPCON */
+
+} /* sspcon_ */
diff --git a/SRC/sspev.c b/SRC/sspev.c
new file mode 100644
index 0000000..7b6176f
--- /dev/null
+++ b/SRC/sspev.c
@@ -0,0 +1,240 @@
+/* sspev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sspev_(char *jobz, char *uplo, integer *n, real *ap,
+ real *w, real *z__, integer *ldz, real *work, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real eps;
+ integer inde;
+ real anrm;
+ integer imax;
+ real rmin, rmax, sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ logical wantz;
+ integer iscale;
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ integer indtau, indwrk;
+ extern doublereal slansp_(char *, char *, integer *, real *, real *);
+ extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
+ real smlnum;
+ extern /* Subroutine */ int sopgtr_(char *, integer *, real *, real *,
+ real *, integer *, real *, integer *), ssptrd_(char *,
+ integer *, real *, real *, real *, real *, integer *),
+ ssteqr_(char *, integer *, real *, real *, real *, integer *,
+ real *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSPEV computes all the eigenvalues and, optionally, eigenvectors of a */
+/* real symmetric matrix A in packed storage. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) REAL array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, AP is overwritten by values generated during the */
+/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */
+/* and first superdiagonal of the tridiagonal matrix T overwrite */
+/* the corresponding elements of A, and if UPLO = 'L', the */
+/* diagonal and first subdiagonal of T overwrite the */
+/* corresponding elements of A. */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) REAL array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
+/* eigenvectors of the matrix A, with the i-th column of Z */
+/* holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of an intermediate tridiagonal */
+/* form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lsame_(uplo, "U") || lsame_(uplo,
+ "L"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -7;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSPEV ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ w[1] = ap[1];
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.f;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = slansp_("M", uplo, n, &ap[1], &work[1]);
+ iscale = 0;
+ if (anrm > 0.f && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ i__1 = *n * (*n + 1) / 2;
+ sscal_(&i__1, &sigma, &ap[1], &c__1);
+ }
+
+/* Call SSPTRD to reduce symmetric packed matrix to tridiagonal form. */
+
+ inde = 1;
+ indtau = inde + *n;
+ ssptrd_(uplo, n, &ap[1], &w[1], &work[inde], &work[indtau], &iinfo);
+
+/* For eigenvalues only, call SSTERF. For eigenvectors, first call */
+/* SOPGTR to generate the orthogonal matrix, then call SSTEQR. */
+
+ if (! wantz) {
+ ssterf_(n, &w[1], &work[inde], info);
+ } else {
+ indwrk = indtau + *n;
+ sopgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &work[
+ indwrk], &iinfo);
+ ssteqr_(jobz, n, &w[1], &work[inde], &z__[z_offset], ldz, &work[
+ indtau], info);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *n;
+ } else {
+ imax = *info - 1;
+ }
+ r__1 = 1.f / sigma;
+ sscal_(&imax, &r__1, &w[1], &c__1);
+ }
+
+ return 0;
+
+/* End of SSPEV */
+
+} /* sspev_ */
diff --git a/SRC/sspevd.c b/SRC/sspevd.c
new file mode 100644
index 0000000..7abae02
--- /dev/null
+++ b/SRC/sspevd.c
@@ -0,0 +1,310 @@
+/* sspevd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sspevd_(char *jobz, char *uplo, integer *n, real *ap,
+ real *w, real *z__, integer *ldz, real *work, integer *lwork, integer
+ *iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real eps;
+ integer inde;
+ real anrm, rmin, rmax, sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ integer lwmin;
+ logical wantz;
+ integer iscale;
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ integer indtau;
+ extern /* Subroutine */ int sstedc_(char *, integer *, real *, real *,
+ real *, integer *, real *, integer *, integer *, integer *,
+ integer *);
+ integer indwrk, liwmin;
+ extern doublereal slansp_(char *, char *, integer *, real *, real *);
+ extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
+ integer llwork;
+ real smlnum;
+ extern /* Subroutine */ int ssptrd_(char *, integer *, real *, real *,
+ real *, real *, integer *);
+ logical lquery;
+ extern /* Subroutine */ int sopmtr_(char *, char *, char *, integer *,
+ integer *, real *, real *, real *, integer *, real *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSPEVD computes all the eigenvalues and, optionally, eigenvectors */
+/* of a real symmetric matrix A in packed storage. If eigenvectors are */
+/* desired, it uses a divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) REAL array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, AP is overwritten by values generated during the */
+/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */
+/* and first superdiagonal of the tridiagonal matrix T overwrite */
+/* the corresponding elements of A, and if UPLO = 'L', the */
+/* diagonal and first subdiagonal of T overwrite the */
+/* corresponding elements of A. */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) REAL array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
+/* eigenvectors of the matrix A, with the i-th column of Z */
+/* holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the required LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If N <= 1, LWORK must be at least 1. */
+/* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N. */
+/* If JOBZ = 'V' and N > 1, LWORK must be at least */
+/* 1 + 6*N + N**2. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the required sizes of the WORK and IWORK */
+/* arrays, returns these values as the first entries of the WORK */
+/* and IWORK arrays, and no error message related to LWORK or */
+/* LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the required LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. */
+/* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the required sizes of the WORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK and IWORK arrays, and no error message related to */
+/* LWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of an intermediate tridiagonal */
+/* form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ lquery = *lwork == -1 || *liwork == -1;
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lsame_(uplo, "U") || lsame_(uplo,
+ "L"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -7;
+ }
+
+ if (*info == 0) {
+ if (*n <= 1) {
+ liwmin = 1;
+ lwmin = 1;
+ } else {
+ if (wantz) {
+ liwmin = *n * 5 + 3;
+/* Computing 2nd power */
+ i__1 = *n;
+ lwmin = *n * 6 + 1 + i__1 * i__1;
+ } else {
+ liwmin = 1;
+ lwmin = *n << 1;
+ }
+ }
+ iwork[1] = liwmin;
+ work[1] = (real) lwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -9;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -11;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSPEVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ w[1] = ap[1];
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.f;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = slansp_("M", uplo, n, &ap[1], &work[1]);
+ iscale = 0;
+ if (anrm > 0.f && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ i__1 = *n * (*n + 1) / 2;
+ sscal_(&i__1, &sigma, &ap[1], &c__1);
+ }
+
+/* Call SSPTRD to reduce symmetric packed matrix to tridiagonal form. */
+
+ inde = 1;
+ indtau = inde + *n;
+ ssptrd_(uplo, n, &ap[1], &w[1], &work[inde], &work[indtau], &iinfo);
+
+/* For eigenvalues only, call SSTERF. For eigenvectors, first call */
+/* SSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the */
+/* tridiagonal matrix, then call SOPMTR to multiply it by the */
+/* Householder transformations represented in AP. */
+
+ if (! wantz) {
+ ssterf_(n, &w[1], &work[inde], info);
+ } else {
+ indwrk = indtau + *n;
+ llwork = *lwork - indwrk + 1;
+ sstedc_("I", n, &w[1], &work[inde], &z__[z_offset], ldz, &work[indwrk]
+, &llwork, &iwork[1], liwork, info);
+ sopmtr_("L", uplo, "N", n, n, &ap[1], &work[indtau], &z__[z_offset],
+ ldz, &work[indwrk], &iinfo);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ r__1 = 1.f / sigma;
+ sscal_(n, &r__1, &w[1], &c__1);
+ }
+
+ work[1] = (real) lwmin;
+ iwork[1] = liwmin;
+ return 0;
+
+/* End of SSPEVD */
+
+} /* sspevd_ */
diff --git a/SRC/sspevx.c b/SRC/sspevx.c
new file mode 100644
index 0000000..172aa32
--- /dev/null
+++ b/SRC/sspevx.c
@@ -0,0 +1,461 @@
+/* sspevx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sspevx_(char *jobz, char *range, char *uplo, integer *n,
+ real *ap, real *vl, real *vu, integer *il, integer *iu, real *abstol,
+ integer *m, real *w, real *z__, integer *ldz, real *work, integer *
+ iwork, integer *ifail, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, jj;
+ real eps, vll, vuu, tmp1;
+ integer indd, inde;
+ real anrm;
+ integer imax;
+ real rmin, rmax;
+ logical test;
+ integer itmp1, indee;
+ real sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ char order[1];
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), sswap_(integer *, real *, integer *, real *, integer *
+);
+ logical wantz, alleig, indeig;
+ integer iscale, indibl;
+ logical valeig;
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real abstll, bignum;
+ integer indtau, indisp, indiwo, indwrk;
+ extern doublereal slansp_(char *, char *, integer *, real *, real *);
+ extern /* Subroutine */ int sstein_(integer *, real *, real *, integer *,
+ real *, integer *, integer *, real *, integer *, real *, integer *
+, integer *, integer *), ssterf_(integer *, real *, real *,
+ integer *);
+ integer nsplit;
+ extern /* Subroutine */ int sstebz_(char *, char *, integer *, real *,
+ real *, integer *, integer *, real *, real *, real *, integer *,
+ integer *, real *, integer *, integer *, real *, integer *,
+ integer *);
+ real smlnum;
+ extern /* Subroutine */ int sopgtr_(char *, integer *, real *, real *,
+ real *, integer *, real *, integer *), ssptrd_(char *,
+ integer *, real *, real *, real *, real *, integer *),
+ ssteqr_(char *, integer *, real *, real *, real *, integer *,
+ real *, integer *), sopmtr_(char *, char *, char *,
+ integer *, integer *, real *, real *, real *, integer *, real *,
+ integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSPEVX computes selected eigenvalues and, optionally, eigenvectors */
+/* of a real symmetric matrix A in packed storage. Eigenvalues/vectors */
+/* can be selected by specifying either a range of values or a range of */
+/* indices for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found; */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found; */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) REAL array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, AP is overwritten by values generated during the */
+/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */
+/* and first superdiagonal of the tridiagonal matrix T overwrite */
+/* the corresponding elements of A, and if UPLO = 'L', the */
+/* diagonal and first subdiagonal of T overwrite the */
+/* corresponding elements of A. */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) REAL */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing AP to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*SLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*SLAMCH('S'). */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices */
+/* with Guaranteed High Relative Accuracy," by Demmel and */
+/* Kahan, LAPACK Working Note #3. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the selected eigenvalues in ascending order. */
+
+/* Z (output) REAL array, dimension (LDZ, max(1,M)) */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If an eigenvector fails to converge, then that column of Z */
+/* contains the latest approximation to the eigenvector, and the */
+/* index of the eigenvector is returned in IFAIL. */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (8*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, then i eigenvectors failed to converge. */
+/* Their indices are stored in array IFAIL. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (! (lsame_(uplo, "L") || lsame_(uplo,
+ "U"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -7;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -8;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -9;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -14;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSPEVX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (alleig || indeig) {
+ *m = 1;
+ w[1] = ap[1];
+ } else {
+ if (*vl < ap[1] && *vu >= ap[1]) {
+ *m = 1;
+ w[1] = ap[1];
+ }
+ }
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.f;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
+ rmax = dmin(r__1,r__2);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ abstll = *abstol;
+ if (valeig) {
+ vll = *vl;
+ vuu = *vu;
+ } else {
+ vll = 0.f;
+ vuu = 0.f;
+ }
+ anrm = slansp_("M", uplo, n, &ap[1], &work[1]);
+ if (anrm > 0.f && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ i__1 = *n * (*n + 1) / 2;
+ sscal_(&i__1, &sigma, &ap[1], &c__1);
+ if (*abstol > 0.f) {
+ abstll = *abstol * sigma;
+ }
+ if (valeig) {
+ vll = *vl * sigma;
+ vuu = *vu * sigma;
+ }
+ }
+
+/* Call SSPTRD to reduce symmetric packed matrix to tridiagonal form. */
+
+ indtau = 1;
+ inde = indtau + *n;
+ indd = inde + *n;
+ indwrk = indd + *n;
+ ssptrd_(uplo, n, &ap[1], &work[indd], &work[inde], &work[indtau], &iinfo);
+
+/* If all eigenvalues are desired and ABSTOL is less than or equal */
+/* to zero, then call SSTERF or SOPGTR and SSTEQR. If this fails */
+/* for some eigenvalue, then try SSTEBZ. */
+
+ test = FALSE_;
+ if (indeig) {
+ if (*il == 1 && *iu == *n) {
+ test = TRUE_;
+ }
+ }
+ if ((alleig || test) && *abstol <= 0.f) {
+ scopy_(n, &work[indd], &c__1, &w[1], &c__1);
+ indee = indwrk + (*n << 1);
+ if (! wantz) {
+ i__1 = *n - 1;
+ scopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
+ ssterf_(n, &w[1], &work[indee], info);
+ } else {
+ sopgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &
+ work[indwrk], &iinfo);
+ i__1 = *n - 1;
+ scopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
+ ssteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[
+ indwrk], info);
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ifail[i__] = 0;
+/* L10: */
+ }
+ }
+ }
+ if (*info == 0) {
+ *m = *n;
+ goto L20;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ indibl = 1;
+ indisp = indibl + *n;
+ indiwo = indisp + *n;
+ sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[
+ inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[
+ indwrk], &iwork[indiwo], info);
+
+ if (wantz) {
+ sstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
+ indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &
+ ifail[1], info);
+
+/* Apply orthogonal matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by SSTEIN. */
+
+ sopmtr_("L", uplo, "N", n, m, &ap[1], &work[indtau], &z__[z_offset],
+ ldz, &work[indwrk], &iinfo);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+L20:
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *m;
+ } else {
+ imax = *info - 1;
+ }
+ r__1 = 1.f / sigma;
+ sscal_(&imax, &r__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L30: */
+ }
+
+ if (i__ != 0) {
+ itmp1 = iwork[indibl + i__ - 1];
+ w[i__] = w[j];
+ iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
+ w[j] = tmp1;
+ iwork[indibl + j - 1] = itmp1;
+ sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ if (*info != 0) {
+ itmp1 = ifail[i__];
+ ifail[i__] = ifail[j];
+ ifail[j] = itmp1;
+ }
+ }
+/* L40: */
+ }
+ }
+
+ return 0;
+
+/* End of SSPEVX */
+
+} /* sspevx_ */
diff --git a/SRC/sspgst.c b/SRC/sspgst.c
new file mode 100644
index 0000000..a86622a
--- /dev/null
+++ b/SRC/sspgst.c
@@ -0,0 +1,281 @@
+/* sspgst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b9 = -1.f;
+static real c_b11 = 1.f;
+
+/* Subroutine */ int sspgst_(integer *itype, char *uplo, integer *n, real *ap,
+ real *bp, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real r__1;
+
+ /* Local variables */
+ integer j, k, j1, k1, jj, kk;
+ real ct, ajj;
+ integer j1j1;
+ real akk;
+ integer k1k1;
+ real bjj, bkk;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ extern /* Subroutine */ int sspr2_(char *, integer *, real *, real *,
+ integer *, real *, integer *, real *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ logical upper;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *), sspmv_(char *, integer *, real *, real *,
+ real *, integer *, real *, real *, integer *), stpmv_(
+ char *, char *, char *, integer *, real *, real *, integer *), stpsv_(char *, char *, char *, integer *,
+ real *, real *, integer *), xerbla_(char
+ *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSPGST reduces a real symmetric-definite generalized eigenproblem */
+/* to standard form, using packed storage. */
+
+/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
+/* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) */
+
+/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
+/* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L. */
+
+/* B must have been previously factorized as U**T*U or L*L**T by SPPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); */
+/* = 2 or 3: compute U*A*U**T or L**T*A*L. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored and B is factored as */
+/* U**T*U; */
+/* = 'L': Lower triangle of A is stored and B is factored as */
+/* L*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* AP (input/output) REAL array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, if INFO = 0, the transformed matrix, stored in the */
+/* same format as A. */
+
+/* BP (input) REAL array, dimension (N*(N+1)/2) */
+/* The triangular factor from the Cholesky factorization of B, */
+/* stored in the same format as A, as returned by SPPTRF. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --bp;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSPGST", &i__1);
+ return 0;
+ }
+
+ if (*itype == 1) {
+ if (upper) {
+
+/* Compute inv(U')*A*inv(U) */
+
+/* J1 and JJ are the indices of A(1,j) and A(j,j) */
+
+ jj = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ j1 = jj + 1;
+ jj += j;
+
+/* Compute the j-th column of the upper triangle of A */
+
+ bjj = bp[jj];
+ stpsv_(uplo, "Transpose", "Nonunit", &j, &bp[1], &ap[j1], &
+ c__1);
+ i__2 = j - 1;
+ sspmv_(uplo, &i__2, &c_b9, &ap[1], &bp[j1], &c__1, &c_b11, &
+ ap[j1], &c__1);
+ i__2 = j - 1;
+ r__1 = 1.f / bjj;
+ sscal_(&i__2, &r__1, &ap[j1], &c__1);
+ i__2 = j - 1;
+ ap[jj] = (ap[jj] - sdot_(&i__2, &ap[j1], &c__1, &bp[j1], &
+ c__1)) / bjj;
+/* L10: */
+ }
+ } else {
+
+/* Compute inv(L)*A*inv(L') */
+
+/* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */
+
+ kk = 1;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ k1k1 = kk + *n - k + 1;
+
+/* Update the lower triangle of A(k:n,k:n) */
+
+ akk = ap[kk];
+ bkk = bp[kk];
+/* Computing 2nd power */
+ r__1 = bkk;
+ akk /= r__1 * r__1;
+ ap[kk] = akk;
+ if (k < *n) {
+ i__2 = *n - k;
+ r__1 = 1.f / bkk;
+ sscal_(&i__2, &r__1, &ap[kk + 1], &c__1);
+ ct = akk * -.5f;
+ i__2 = *n - k;
+ saxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
+ ;
+ i__2 = *n - k;
+ sspr2_(uplo, &i__2, &c_b9, &ap[kk + 1], &c__1, &bp[kk + 1]
+, &c__1, &ap[k1k1]);
+ i__2 = *n - k;
+ saxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
+ ;
+ i__2 = *n - k;
+ stpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1],
+ &ap[kk + 1], &c__1);
+ }
+ kk = k1k1;
+/* L20: */
+ }
+ }
+ } else {
+ if (upper) {
+
+/* Compute U*A*U' */
+
+/* K1 and KK are the indices of A(1,k) and A(k,k) */
+
+ kk = 0;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ k1 = kk + 1;
+ kk += k;
+
+/* Update the upper triangle of A(1:k,1:k) */
+
+ akk = ap[kk];
+ bkk = bp[kk];
+ i__2 = k - 1;
+ stpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[
+ k1], &c__1);
+ ct = akk * .5f;
+ i__2 = k - 1;
+ saxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
+ i__2 = k - 1;
+ sspr2_(uplo, &i__2, &c_b11, &ap[k1], &c__1, &bp[k1], &c__1, &
+ ap[1]);
+ i__2 = k - 1;
+ saxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
+ i__2 = k - 1;
+ sscal_(&i__2, &bkk, &ap[k1], &c__1);
+/* Computing 2nd power */
+ r__1 = bkk;
+ ap[kk] = akk * (r__1 * r__1);
+/* L30: */
+ }
+ } else {
+
+/* Compute L'*A*L */
+
+/* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */
+
+ jj = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ j1j1 = jj + *n - j + 1;
+
+/* Compute the j-th column of the lower triangle of A */
+
+ ajj = ap[jj];
+ bjj = bp[jj];
+ i__2 = *n - j;
+ ap[jj] = ajj * bjj + sdot_(&i__2, &ap[jj + 1], &c__1, &bp[jj
+ + 1], &c__1);
+ i__2 = *n - j;
+ sscal_(&i__2, &bjj, &ap[jj + 1], &c__1);
+ i__2 = *n - j;
+ sspmv_(uplo, &i__2, &c_b11, &ap[j1j1], &bp[jj + 1], &c__1, &
+ c_b11, &ap[jj + 1], &c__1);
+ i__2 = *n - j + 1;
+ stpmv_(uplo, "Transpose", "Non-unit", &i__2, &bp[jj], &ap[jj],
+ &c__1);
+ jj = j1j1;
+/* L40: */
+ }
+ }
+ }
+ return 0;
+
+/* End of SSPGST */
+
+} /* sspgst_ */
diff --git a/SRC/sspgv.c b/SRC/sspgv.c
new file mode 100644
index 0000000..1433001
--- /dev/null
+++ b/SRC/sspgv.c
@@ -0,0 +1,240 @@
+/* sspgv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sspgv_(integer *itype, char *jobz, char *uplo, integer *
+ n, real *ap, real *bp, real *w, real *z__, integer *ldz, real *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+
+ /* Local variables */
+ integer j, neig;
+ extern logical lsame_(char *, char *);
+ char trans[1];
+ logical upper;
+ extern /* Subroutine */ int sspev_(char *, char *, integer *, real *,
+ real *, real *, integer *, real *, integer *);
+ logical wantz;
+ extern /* Subroutine */ int stpmv_(char *, char *, char *, integer *,
+ real *, real *, integer *), stpsv_(char *,
+ char *, char *, integer *, real *, real *, integer *), xerbla_(char *, integer *), spptrf_(char
+ *, integer *, real *, integer *), sspgst_(integer *, char
+ *, integer *, real *, real *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSPGV computes all the eigenvalues and, optionally, the eigenvectors */
+/* of a real generalized symmetric-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. */
+/* Here A and B are assumed to be symmetric, stored in packed format, */
+/* and B is also positive definite. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* AP (input/output) REAL array, dimension */
+/* (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the contents of AP are destroyed. */
+
+/* BP (input/output) REAL array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* B, packed columnwise in a linear array. The j-th column of B */
+/* is stored in the array BP as follows: */
+/* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */
+
+/* On exit, the triangular factor U or L from the Cholesky */
+/* factorization B = U**T*U or B = L*L**T, in the same storage */
+/* format as B. */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) REAL array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
+/* eigenvectors. The eigenvectors are normalized as follows: */
+/* if ITYPE = 1 or 2, Z**T*B*Z = I; */
+/* if ITYPE = 3, Z**T*inv(B)*Z = I. */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: SPPTRF or SSPEV returned an error code: */
+/* <= N: if INFO = i, SSPEV failed to converge; */
+/* i off-diagonal elements of an intermediate */
+/* tridiagonal form did not converge to zero. */
+/* > N: if INFO = n + i, for 1 <= i <= n, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --bp;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+
+ *info = 0;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSPGV ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of B. */
+
+ spptrf_(uplo, n, &bp[1], info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ sspgst_(itype, uplo, n, &ap[1], &bp[1], info);
+ sspev_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], info);
+
+ if (wantz) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ neig = *n;
+ if (*info > 0) {
+ neig = *info - 1;
+ }
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'T';
+ }
+
+ i__1 = neig;
+ for (j = 1; j <= i__1; ++j) {
+ stpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L10: */
+ }
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'T';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ i__1 = neig;
+ for (j = 1; j <= i__1; ++j) {
+ stpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L20: */
+ }
+ }
+ }
+ return 0;
+
+/* End of SSPGV */
+
+} /* sspgv_ */
diff --git a/SRC/sspgvd.c b/SRC/sspgvd.c
new file mode 100644
index 0000000..0ad98eb
--- /dev/null
+++ b/SRC/sspgvd.c
@@ -0,0 +1,330 @@
+/* sspgvd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sspgvd_(integer *itype, char *jobz, char *uplo, integer *
+ n, real *ap, real *bp, real *w, real *z__, integer *ldz, real *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j, neig;
+ extern logical lsame_(char *, char *);
+ integer lwmin;
+ char trans[1];
+ logical upper, wantz;
+ extern /* Subroutine */ int stpmv_(char *, char *, char *, integer *,
+ real *, real *, integer *), stpsv_(char *,
+ char *, char *, integer *, real *, real *, integer *), xerbla_(char *, integer *);
+ integer liwmin;
+ extern /* Subroutine */ int sspevd_(char *, char *, integer *, real *,
+ real *, real *, integer *, real *, integer *, integer *, integer *
+, integer *), spptrf_(char *, integer *, real *,
+ integer *);
+ logical lquery;
+ extern /* Subroutine */ int sspgst_(integer *, char *, integer *, real *,
+ real *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSPGVD computes all the eigenvalues, and optionally, the eigenvectors */
+/* of a real generalized symmetric-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */
+/* B are assumed to be symmetric, stored in packed format, and B is also */
+/* positive definite. */
+/* If eigenvectors are desired, it uses a divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* AP (input/output) REAL array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the contents of AP are destroyed. */
+
+/* BP (input/output) REAL array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* B, packed columnwise in a linear array. The j-th column of B */
+/* is stored in the array BP as follows: */
+/* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */
+
+/* On exit, the triangular factor U or L from the Cholesky */
+/* factorization B = U**T*U or B = L*L**T, in the same storage */
+/* format as B. */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) REAL array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
+/* eigenvectors. The eigenvectors are normalized as follows: */
+/* if ITYPE = 1 or 2, Z**T*B*Z = I; */
+/* if ITYPE = 3, Z**T*inv(B)*Z = I. */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the required LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If N <= 1, LWORK >= 1. */
+/* If JOBZ = 'N' and N > 1, LWORK >= 2*N. */
+/* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the required sizes of the WORK and IWORK */
+/* arrays, returns these values as the first entries of the WORK */
+/* and IWORK arrays, and no error message related to LWORK or */
+/* LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the required LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If JOBZ = 'N' or N <= 1, LIWORK >= 1. */
+/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the required sizes of the WORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK and IWORK arrays, and no error message related to */
+/* LWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: SPPTRF or SSPEVD returned an error code: */
+/* <= N: if INFO = i, SSPEVD failed to converge; */
+/* i off-diagonal elements of an intermediate */
+/* tridiagonal form did not converge to zero; */
+/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --bp;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1 || *liwork == -1;
+
+ *info = 0;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -9;
+ }
+
+ if (*info == 0) {
+ if (*n <= 1) {
+ liwmin = 1;
+ lwmin = 1;
+ } else {
+ if (wantz) {
+ liwmin = *n * 5 + 3;
+/* Computing 2nd power */
+ i__1 = *n;
+ lwmin = *n * 6 + 1 + (i__1 * i__1 << 1);
+ } else {
+ liwmin = 1;
+ lwmin = *n << 1;
+ }
+ }
+ work[1] = (real) lwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -11;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSPGVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of BP. */
+
+ spptrf_(uplo, n, &bp[1], info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ sspgst_(itype, uplo, n, &ap[1], &bp[1], info);
+ sspevd_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1],
+ lwork, &iwork[1], liwork, info);
+/* Computing MAX */
+ r__1 = (real) lwmin;
+ lwmin = dmax(r__1,work[1]);
+/* Computing MAX */
+ r__1 = (real) liwmin, r__2 = (real) iwork[1];
+ liwmin = dmax(r__1,r__2);
+
+ if (wantz) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ neig = *n;
+ if (*info > 0) {
+ neig = *info - 1;
+ }
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'T';
+ }
+
+ i__1 = neig;
+ for (j = 1; j <= i__1; ++j) {
+ stpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L10: */
+ }
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'T';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ i__1 = neig;
+ for (j = 1; j <= i__1; ++j) {
+ stpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L20: */
+ }
+ }
+ }
+
+ work[1] = (real) lwmin;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of SSPGVD */
+
+} /* sspgvd_ */
diff --git a/SRC/sspgvx.c b/SRC/sspgvx.c
new file mode 100644
index 0000000..30271be
--- /dev/null
+++ b/SRC/sspgvx.c
@@ -0,0 +1,339 @@
+/* sspgvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sspgvx_(integer *itype, char *jobz, char *range, char *
+ uplo, integer *n, real *ap, real *bp, real *vl, real *vu, integer *il,
+ integer *iu, real *abstol, integer *m, real *w, real *z__, integer *
+ ldz, real *work, integer *iwork, integer *ifail, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+
+ /* Local variables */
+ integer j;
+ extern logical lsame_(char *, char *);
+ char trans[1];
+ logical upper, wantz;
+ extern /* Subroutine */ int stpmv_(char *, char *, char *, integer *,
+ real *, real *, integer *), stpsv_(char *,
+ char *, char *, integer *, real *, real *, integer *);
+ logical alleig, indeig, valeig;
+ extern /* Subroutine */ int xerbla_(char *, integer *), spptrf_(
+ char *, integer *, real *, integer *), sspgst_(integer *,
+ char *, integer *, real *, real *, integer *), sspevx_(
+ char *, char *, char *, integer *, real *, real *, real *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, real *, integer *, integer *, integer *)
+ ;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSPGVX computes selected eigenvalues, and optionally, eigenvectors */
+/* of a real generalized symmetric-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A */
+/* and B are assumed to be symmetric, stored in packed storage, and B */
+/* is also positive definite. Eigenvalues and eigenvectors can be */
+/* selected by specifying either a range of values or a range of indices */
+/* for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A and B are stored; */
+/* = 'L': Lower triangle of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix pencil (A,B). N >= 0. */
+
+/* AP (input/output) REAL array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the contents of AP are destroyed. */
+
+/* BP (input/output) REAL array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* B, packed columnwise in a linear array. The j-th column of B */
+/* is stored in the array BP as follows: */
+/* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */
+
+/* On exit, the triangular factor U or L from the Cholesky */
+/* factorization B = U**T*U or B = L*L**T, in the same storage */
+/* format as B. */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) REAL */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing A to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*SLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*SLAMCH('S'). */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* On normal exit, the first M elements contain the selected */
+/* eigenvalues in ascending order. */
+
+/* Z (output) REAL array, dimension (LDZ, max(1,M)) */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* The eigenvectors are normalized as follows: */
+/* if ITYPE = 1 or 2, Z**T*B*Z = I; */
+/* if ITYPE = 3, Z**T*inv(B)*Z = I. */
+
+/* If an eigenvector fails to converge, then that column of Z */
+/* contains the latest approximation to the eigenvector, and the */
+/* index of the eigenvector is returned in IFAIL. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (8*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: SPPTRF or SSPEVX returned an error code: */
+/* <= N: if INFO = i, SSPEVX failed to converge; */
+/* i eigenvectors failed to converge. Their indices */
+/* are stored in array IFAIL. */
+/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --bp;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ upper = lsame_(uplo, "U");
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ *info = 0;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -3;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -9;
+ }
+ } else if (indeig) {
+ if (*il < 1) {
+ *info = -10;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -11;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -16;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSPGVX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of B. */
+
+ spptrf_(uplo, n, &bp[1], info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ sspgst_(itype, uplo, n, &ap[1], &bp[1], info);
+ sspevx_(jobz, range, uplo, n, &ap[1], vl, vu, il, iu, abstol, m, &w[1], &
+ z__[z_offset], ldz, &work[1], &iwork[1], &ifail[1], info);
+
+ if (wantz) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ if (*info > 0) {
+ *m = *info - 1;
+ }
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'T';
+ }
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ stpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L10: */
+ }
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'T';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ stpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L20: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SSPGVX */
+
+} /* sspgvx_ */
diff --git a/SRC/ssprfs.c b/SRC/ssprfs.c
new file mode 100644
index 0000000..9e02bea
--- /dev/null
+++ b/SRC/ssprfs.c
@@ -0,0 +1,417 @@
+/* ssprfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b12 = -1.f;
+static real c_b14 = 1.f;
+
+/* Subroutine */ int ssprfs_(char *uplo, integer *n, integer *nrhs, real *ap,
+ real *afp, integer *ipiv, real *b, integer *ldb, real *x, integer *
+ ldx, real *ferr, real *berr, real *work, integer *iwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ real s;
+ integer ik, kk;
+ real xk;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3], count;
+ logical upper;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), saxpy_(integer *, real *, real *, integer *, real *,
+ integer *), sspmv_(char *, integer *, real *, real *, real *,
+ integer *, real *, real *, integer *), slacn2_(integer *,
+ real *, real *, integer *, real *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real lstres;
+ extern /* Subroutine */ int ssptrs_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 5 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSPRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric indefinite */
+/* and packed, and provides error bounds and backward error estimates */
+/* for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input) REAL array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the symmetric matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* AFP (input) REAL array, dimension (N*(N+1)/2) */
+/* The factored form of the matrix A. AFP contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor U or L from the factorization A = U*D*U**T or */
+/* A = L*D*L**T as computed by SSPTRF, stored as a packed */
+/* triangular matrix. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by SSPTRF. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) REAL array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by SSPTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --afp;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*ldx < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSPRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.f;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ scopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+ sspmv_(uplo, n, &c_b12, &ap[1], &x[j * x_dim1 + 1], &c__1, &c_b14, &
+ work[*n + 1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] = (r__1 = b[i__ + j * b_dim1], dabs(r__1));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ kk = 1;
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+ ik = kk;
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ work[i__] += (r__1 = ap[ik], dabs(r__1)) * xk;
+ s += (r__1 = ap[ik], dabs(r__1)) * (r__2 = x[i__ + j *
+ x_dim1], dabs(r__2));
+ ++ik;
+/* L40: */
+ }
+ work[k] = work[k] + (r__1 = ap[kk + k - 1], dabs(r__1)) * xk
+ + s;
+ kk += k;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+ work[k] += (r__1 = ap[kk], dabs(r__1)) * xk;
+ ik = kk + 1;
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ work[i__] += (r__1 = ap[ik], dabs(r__1)) * xk;
+ s += (r__1 = ap[ik], dabs(r__1)) * (r__2 = x[i__ + j *
+ x_dim1], dabs(r__2));
+ ++ik;
+/* L60: */
+ }
+ work[k] += s;
+ kk += *n - k + 1;
+/* L70: */
+ }
+ }
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[
+ i__];
+ s = dmax(r__2,r__3);
+ } else {
+/* Computing MAX */
+ r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1)
+ / (work[i__] + safe1);
+ s = dmax(r__2,r__3);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ ssptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n, info);
+ saxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
+ ;
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use SLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ slacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+ kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ ssptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n,
+ info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L120: */
+ }
+ ssptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n,
+ info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], dabs(r__1));
+ lstres = dmax(r__2,r__3);
+/* L130: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of SSPRFS */
+
+} /* ssprfs_ */
diff --git a/SRC/sspsv.c b/SRC/sspsv.c
new file mode 100644
index 0000000..e902d61
--- /dev/null
+++ b/SRC/sspsv.c
@@ -0,0 +1,176 @@
+/* sspsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sspsv_(char *uplo, integer *n, integer *nrhs, real *ap,
+ integer *ipiv, real *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), ssptrf_(
+ char *, integer *, real *, integer *, integer *), ssptrs_(
+ char *, integer *, integer *, real *, integer *, real *, integer *
+, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSPSV computes the solution to a real system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N symmetric matrix stored in packed format and X */
+/* and B are N-by-NRHS matrices. */
+
+/* The diagonal pivoting method is used to factor A as */
+/* A = U * D * U**T, if UPLO = 'U', or */
+/* A = L * D * L**T, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, D is symmetric and block diagonal with 1-by-1 */
+/* and 2-by-2 diagonal blocks. The factored form of A is then used to */
+/* solve the system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input/output) REAL array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+
+/* On exit, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as */
+/* a packed triangular matrix in the same storage format as A. */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D, as */
+/* determined by SSPTRF. If IPIV(k) > 0, then rows and columns */
+/* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 */
+/* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, */
+/* then rows and columns k-1 and -IPIV(k) were interchanged and */
+/* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and */
+/* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and */
+/* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 */
+/* diagonal block. */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */
+/* has been completed, but the block diagonal matrix D is */
+/* exactly singular, so the solution could not be */
+/* computed. */
+
+/* Further Details */
+/* =============== */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the symmetric matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = aji) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSPSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ ssptrf_(uplo, n, &ap[1], &ipiv[1], info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ ssptrs_(uplo, n, nrhs, &ap[1], &ipiv[1], &b[b_offset], ldb, info);
+
+ }
+ return 0;
+
+/* End of SSPSV */
+
+} /* sspsv_ */
diff --git a/SRC/sspsvx.c b/SRC/sspsvx.c
new file mode 100644
index 0000000..96b88fe
--- /dev/null
+++ b/SRC/sspsvx.c
@@ -0,0 +1,325 @@
+/* sspsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sspsvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, real *ap, real *afp, integer *ipiv, real *b, integer *ldb, real
+ *x, integer *ldx, real *rcond, real *ferr, real *berr, real *work,
+ integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ extern doublereal slamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *), slacpy_(
+ char *, integer *, integer *, real *, integer *, real *, integer *
+);
+ extern doublereal slansp_(char *, char *, integer *, real *, real *);
+ extern /* Subroutine */ int sspcon_(char *, integer *, real *, integer *,
+ real *, real *, real *, integer *, integer *), ssprfs_(
+ char *, integer *, integer *, real *, real *, integer *, real *,
+ integer *, real *, integer *, real *, real *, real *, integer *,
+ integer *), ssptrf_(char *, integer *, real *, integer *,
+ integer *), ssptrs_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSPSVX uses the diagonal pivoting factorization A = U*D*U**T or */
+/* A = L*D*L**T to compute the solution to a real system of linear */
+/* equations A * X = B, where A is an N-by-N symmetric matrix stored */
+/* in packed format and X and B are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as */
+/* A = U * D * U**T, if UPLO = 'U', or */
+/* A = L * D * L**T, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* 2. If some D(i,i)=0, so that D is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 3. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 4. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of A has been */
+/* supplied on entry. */
+/* = 'F': On entry, AFP and IPIV contain the factored form of */
+/* A. AP, AFP and IPIV will not be modified. */
+/* = 'N': The matrix A will be copied to AFP and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input) REAL array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the symmetric matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+
+/* AFP (input or output) REAL array, dimension */
+/* (N*(N+1)/2) */
+/* If FACT = 'F', then AFP is an input argument and on entry */
+/* contains the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as */
+/* a packed triangular matrix in the same storage format as A. */
+
+/* If FACT = 'N', then AFP is an output argument and on exit */
+/* contains the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as */
+/* a packed triangular matrix in the same storage format as A. */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by SSPTRF. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by SSPTRF. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) REAL array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A. If RCOND is less than the machine precision (in */
+/* particular, if RCOND = 0), the matrix is singular to working */
+/* precision. This condition is indicated by a return code of */
+/* INFO > 0. */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: D(i,i) is exactly zero. The factorization */
+/* has been completed but the factor D is exactly */
+/* singular, so the solution and error bounds could */
+/* not be computed. RCOND = 0 is returned. */
+/* = N+1: D is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* Further Details */
+/* =============== */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the symmetric matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = aji) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --afp;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ if (! nofact && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSPSVX", &i__1);
+ return 0;
+ }
+
+ if (nofact) {
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ i__1 = *n * (*n + 1) / 2;
+ scopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1);
+ ssptrf_(uplo, n, &afp[1], &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.f;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = slansp_("I", uplo, n, &ap[1], &work[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ sspcon_(uplo, n, &afp[1], &ipiv[1], &anorm, rcond, &work[1], &iwork[1],
+ info);
+
+/* Compute the solution vectors X. */
+
+ slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ ssptrs_(uplo, n, nrhs, &afp[1], &ipiv[1], &x[x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solutions and */
+/* compute error bounds and backward error estimates for them. */
+
+ ssprfs_(uplo, n, nrhs, &ap[1], &afp[1], &ipiv[1], &b[b_offset], ldb, &x[
+ x_offset], ldx, &ferr[1], &berr[1], &work[1], &iwork[1], info);
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < slamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of SSPSVX */
+
+} /* sspsvx_ */
diff --git a/SRC/ssptrd.c b/SRC/ssptrd.c
new file mode 100644
index 0000000..db5eb88
--- /dev/null
+++ b/SRC/ssptrd.c
@@ -0,0 +1,275 @@
+/* ssptrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b8 = 0.f;
+static real c_b14 = -1.f;
+
+/* Subroutine */ int ssptrd_(char *uplo, integer *n, real *ap, real *d__,
+ real *e, real *tau, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, i1, ii, i1i1;
+ real taui;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ extern /* Subroutine */ int sspr2_(char *, integer *, real *, real *,
+ integer *, real *, integer *, real *);
+ real alpha;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *), sspmv_(char *, integer *, real *, real *,
+ real *, integer *, real *, real *, integer *), xerbla_(
+ char *, integer *), slarfg_(integer *, real *, real *,
+ integer *, real *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSPTRD reduces a real symmetric matrix A stored in packed form to */
+/* symmetric tridiagonal form T by an orthogonal similarity */
+/* transformation: Q**T * A * Q = T. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) REAL array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+/* On exit, if UPLO = 'U', the diagonal and first superdiagonal */
+/* of A are overwritten by the corresponding elements of the */
+/* tridiagonal matrix T, and the elements above the first */
+/* superdiagonal, with the array TAU, represent the orthogonal */
+/* matrix Q as a product of elementary reflectors; if UPLO */
+/* = 'L', the diagonal and first subdiagonal of A are over- */
+/* written by the corresponding elements of the tridiagonal */
+/* matrix T, and the elements below the first subdiagonal, with */
+/* the array TAU, represent the orthogonal matrix Q as a product */
+/* of elementary reflectors. See Further Details. */
+
+/* D (output) REAL array, dimension (N) */
+/* The diagonal elements of the tridiagonal matrix T: */
+/* D(i) = A(i,i). */
+
+/* E (output) REAL array, dimension (N-1) */
+/* The off-diagonal elements of the tridiagonal matrix T: */
+/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */
+
+/* TAU (output) REAL array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(n-1) . . . H(2) H(1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP, */
+/* overwriting A(1:i-1,i+1), and tau is stored in TAU(i). */
+
+/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(1) H(2) . . . H(n-1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP, */
+/* overwriting A(i+2:n,i), and tau is stored in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ --tau;
+ --e;
+ --d__;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSPTRD", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Reduce the upper triangle of A. */
+/* I1 is the index in AP of A(1,I+1). */
+
+ i1 = *n * (*n - 1) / 2 + 1;
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+
+/* Generate elementary reflector H(i) = I - tau * v * v' */
+/* to annihilate A(1:i-1,i+1) */
+
+ slarfg_(&i__, &ap[i1 + i__ - 1], &ap[i1], &c__1, &taui);
+ e[i__] = ap[i1 + i__ - 1];
+
+ if (taui != 0.f) {
+
+/* Apply H(i) from both sides to A(1:i,1:i) */
+
+ ap[i1 + i__ - 1] = 1.f;
+
+/* Compute y := tau * A * v storing y in TAU(1:i) */
+
+ sspmv_(uplo, &i__, &taui, &ap[1], &ap[i1], &c__1, &c_b8, &tau[
+ 1], &c__1);
+
+/* Compute w := y - 1/2 * tau * (y'*v) * v */
+
+ alpha = taui * -.5f * sdot_(&i__, &tau[1], &c__1, &ap[i1], &
+ c__1);
+ saxpy_(&i__, &alpha, &ap[i1], &c__1, &tau[1], &c__1);
+
+/* Apply the transformation as a rank-2 update: */
+/* A := A - v * w' - w * v' */
+
+ sspr2_(uplo, &i__, &c_b14, &ap[i1], &c__1, &tau[1], &c__1, &
+ ap[1]);
+
+ ap[i1 + i__ - 1] = e[i__];
+ }
+ d__[i__ + 1] = ap[i1 + i__];
+ tau[i__] = taui;
+ i1 -= i__;
+/* L10: */
+ }
+ d__[1] = ap[1];
+ } else {
+
+/* Reduce the lower triangle of A. II is the index in AP of */
+/* A(i,i) and I1I1 is the index of A(i+1,i+1). */
+
+ ii = 1;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i1i1 = ii + *n - i__ + 1;
+
+/* Generate elementary reflector H(i) = I - tau * v * v' */
+/* to annihilate A(i+2:n,i) */
+
+ i__2 = *n - i__;
+ slarfg_(&i__2, &ap[ii + 1], &ap[ii + 2], &c__1, &taui);
+ e[i__] = ap[ii + 1];
+
+ if (taui != 0.f) {
+
+/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
+
+ ap[ii + 1] = 1.f;
+
+/* Compute y := tau * A * v storing y in TAU(i:n-1) */
+
+ i__2 = *n - i__;
+ sspmv_(uplo, &i__2, &taui, &ap[i1i1], &ap[ii + 1], &c__1, &
+ c_b8, &tau[i__], &c__1);
+
+/* Compute w := y - 1/2 * tau * (y'*v) * v */
+
+ i__2 = *n - i__;
+ alpha = taui * -.5f * sdot_(&i__2, &tau[i__], &c__1, &ap[ii +
+ 1], &c__1);
+ i__2 = *n - i__;
+ saxpy_(&i__2, &alpha, &ap[ii + 1], &c__1, &tau[i__], &c__1);
+
+/* Apply the transformation as a rank-2 update: */
+/* A := A - v * w' - w * v' */
+
+ i__2 = *n - i__;
+ sspr2_(uplo, &i__2, &c_b14, &ap[ii + 1], &c__1, &tau[i__], &
+ c__1, &ap[i1i1]);
+
+ ap[ii + 1] = e[i__];
+ }
+ d__[i__] = ap[ii];
+ tau[i__] = taui;
+ ii = i1i1;
+/* L20: */
+ }
+ d__[*n] = ap[ii];
+ }
+
+ return 0;
+
+/* End of SSPTRD */
+
+} /* ssptrd_ */
diff --git a/SRC/ssptrf.c b/SRC/ssptrf.c
new file mode 100644
index 0000000..df4bb43
--- /dev/null
+++ b/SRC/ssptrf.c
@@ -0,0 +1,627 @@
+/* ssptrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ssptrf_(char *uplo, integer *n, real *ap, integer *ipiv,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ real t, r1, d11, d12, d21, d22;
+ integer kc, kk, kp;
+ real wk;
+ integer kx, knc, kpc, npp;
+ real wkm1, wkp1;
+ integer imax, jmax;
+ extern /* Subroutine */ int sspr_(char *, integer *, real *, real *,
+ integer *, real *);
+ real alpha;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ integer kstep;
+ logical upper;
+ extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
+ integer *);
+ real absakk;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ real colmax, rowmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSPTRF computes the factorization of a real symmetric matrix A stored */
+/* in packed format using the Bunch-Kaufman diagonal pivoting method: */
+
+/* A = U*D*U**T or A = L*D*L**T */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) REAL array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L, stored as a packed triangular */
+/* matrix overwriting A (see below for further details). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. 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. */
+
+/* Further Details */
+/* =============== */
+
+/* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services */
+/* Company */
+
+/* If UPLO = 'U', then A = U*D*U', where */
+/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
+/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
+/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I v 0 ) k-s */
+/* U(k) = ( 0 I 0 ) s */
+/* ( 0 0 I ) n-k */
+/* k-s s n-k */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
+/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
+/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
+
+/* If UPLO = 'L', then A = L*D*L', where */
+/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
+/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
+/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I 0 0 ) k-1 */
+/* L(k) = ( 0 I 0 ) s */
+/* ( 0 v I ) n-k-s+1 */
+/* k-1 s n-k-s+1 */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
+/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
+/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ipiv;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSPTRF", &i__1);
+ return 0;
+ }
+
+/* Initialize ALPHA for use in choosing pivot block size. */
+
+ alpha = (sqrt(17.f) + 1.f) / 8.f;
+
+ if (upper) {
+
+/* Factorize A as U*D*U' using the upper triangle of A */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2 */
+
+ k = *n;
+ kc = (*n - 1) * *n / 2 + 1;
+L10:
+ knc = kc;
+
+/* If K < 1, exit from loop */
+
+ if (k < 1) {
+ goto L110;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ absakk = (r__1 = ap[kc + k - 1], dabs(r__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ imax = isamax_(&i__1, &ap[kc], &c__1);
+ colmax = (r__1 = ap[kc + imax - 1], dabs(r__1));
+ } else {
+ colmax = 0.f;
+ }
+
+ if (dmax(absakk,colmax) == 0.f) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ rowmax = 0.f;
+ jmax = imax;
+ kx = imax * (imax + 1) / 2 + imax;
+ i__1 = k;
+ for (j = imax + 1; j <= i__1; ++j) {
+ if ((r__1 = ap[kx], dabs(r__1)) > rowmax) {
+ rowmax = (r__1 = ap[kx], dabs(r__1));
+ jmax = j;
+ }
+ kx += j;
+/* L20: */
+ }
+ kpc = (imax - 1) * imax / 2 + 1;
+ if (imax > 1) {
+ i__1 = imax - 1;
+ jmax = isamax_(&i__1, &ap[kpc], &c__1);
+/* Computing MAX */
+ r__2 = rowmax, r__3 = (r__1 = ap[kpc + jmax - 1], dabs(
+ r__1));
+ rowmax = dmax(r__2,r__3);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else if ((r__1 = ap[kpc + imax - 1], dabs(r__1)) >= alpha *
+ rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+
+ kk = k - kstep + 1;
+ if (kstep == 2) {
+ knc = knc - k + 1;
+ }
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the leading */
+/* submatrix A(1:k,1:k) */
+
+ i__1 = kp - 1;
+ sswap_(&i__1, &ap[knc], &c__1, &ap[kpc], &c__1);
+ kx = kpc + kp - 1;
+ i__1 = kk - 1;
+ for (j = kp + 1; j <= i__1; ++j) {
+ kx = kx + j - 1;
+ t = ap[knc + j - 1];
+ ap[knc + j - 1] = ap[kx];
+ ap[kx] = t;
+/* L30: */
+ }
+ t = ap[knc + kk - 1];
+ ap[knc + kk - 1] = ap[kpc + kp - 1];
+ ap[kpc + kp - 1] = t;
+ if (kstep == 2) {
+ t = ap[kc + k - 2];
+ ap[kc + k - 2] = ap[kc + kp - 1];
+ ap[kc + kp - 1] = t;
+ }
+ }
+
+/* Update the leading submatrix */
+
+ if (kstep == 1) {
+
+/* 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 */
+
+/* Perform a rank-1 update of A(1:k-1,1:k-1) as */
+
+/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */
+
+ r1 = 1.f / ap[kc + k - 1];
+ i__1 = k - 1;
+ r__1 = -r1;
+ sspr_(uplo, &i__1, &r__1, &ap[kc], &c__1, &ap[1]);
+
+/* Store U(k) in column k */
+
+ i__1 = k - 1;
+ sscal_(&i__1, &r1, &ap[kc], &c__1);
+ } 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) )' */
+/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */
+
+ if (k > 2) {
+
+ d12 = ap[k - 1 + (k - 1) * k / 2];
+ d22 = ap[k - 1 + (k - 2) * (k - 1) / 2] / d12;
+ d11 = ap[k + (k - 1) * k / 2] / d12;
+ t = 1.f / (d11 * d22 - 1.f);
+ d12 = t / d12;
+
+ for (j = k - 2; j >= 1; --j) {
+ wkm1 = d12 * (d11 * ap[j + (k - 2) * (k - 1) / 2] -
+ ap[j + (k - 1) * k / 2]);
+ wk = d12 * (d22 * ap[j + (k - 1) * k / 2] - ap[j + (k
+ - 2) * (k - 1) / 2]);
+ for (i__ = j; i__ >= 1; --i__) {
+ ap[i__ + (j - 1) * j / 2] = ap[i__ + (j - 1) * j /
+ 2] - ap[i__ + (k - 1) * k / 2] * wk - ap[
+ i__ + (k - 2) * (k - 1) / 2] * wkm1;
+/* L40: */
+ }
+ ap[j + (k - 1) * k / 2] = wk;
+ ap[j + (k - 2) * (k - 1) / 2] = wkm1;
+/* L50: */
+ }
+
+ }
+
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k - 1] = -kp;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kstep;
+ kc = knc - k;
+ goto L10;
+
+ } else {
+
+/* Factorize A as L*D*L' using the lower triangle of A */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2 */
+
+ k = 1;
+ kc = 1;
+ npp = *n * (*n + 1) / 2;
+L60:
+ knc = kc;
+
+/* If K > N, exit from loop */
+
+ if (k > *n) {
+ goto L110;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ absakk = (r__1 = ap[kc], dabs(r__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ imax = k + isamax_(&i__1, &ap[kc + 1], &c__1);
+ colmax = (r__1 = ap[kc + imax - k], dabs(r__1));
+ } else {
+ colmax = 0.f;
+ }
+
+ if (dmax(absakk,colmax) == 0.f) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ rowmax = 0.f;
+ kx = kc + imax - k;
+ i__1 = imax - 1;
+ for (j = k; j <= i__1; ++j) {
+ if ((r__1 = ap[kx], dabs(r__1)) > rowmax) {
+ rowmax = (r__1 = ap[kx], dabs(r__1));
+ jmax = j;
+ }
+ kx = kx + *n - j;
+/* L70: */
+ }
+ kpc = npp - (*n - imax + 1) * (*n - imax + 2) / 2 + 1;
+ if (imax < *n) {
+ i__1 = *n - imax;
+ jmax = imax + isamax_(&i__1, &ap[kpc + 1], &c__1);
+/* Computing MAX */
+ r__2 = rowmax, r__3 = (r__1 = ap[kpc + jmax - imax], dabs(
+ r__1));
+ rowmax = dmax(r__2,r__3);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else if ((r__1 = ap[kpc], dabs(r__1)) >= alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+
+ kk = k + kstep - 1;
+ if (kstep == 2) {
+ knc = knc + *n - k + 1;
+ }
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the trailing */
+/* submatrix A(k:n,k:n) */
+
+ if (kp < *n) {
+ i__1 = *n - kp;
+ sswap_(&i__1, &ap[knc + kp - kk + 1], &c__1, &ap[kpc + 1],
+ &c__1);
+ }
+ kx = knc + kp - kk;
+ i__1 = kp - 1;
+ for (j = kk + 1; j <= i__1; ++j) {
+ kx = kx + *n - j + 1;
+ t = ap[knc + j - kk];
+ ap[knc + j - kk] = ap[kx];
+ ap[kx] = t;
+/* L80: */
+ }
+ t = ap[knc];
+ ap[knc] = ap[kpc];
+ ap[kpc] = t;
+ if (kstep == 2) {
+ t = ap[kc + 1];
+ ap[kc + 1] = ap[kc + kp - k];
+ ap[kc + kp - k] = t;
+ }
+ }
+
+/* Update the trailing submatrix */
+
+ if (kstep == 1) {
+
+/* 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 < *n) {
+
+/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
+
+/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */
+
+ r1 = 1.f / ap[kc];
+ i__1 = *n - k;
+ r__1 = -r1;
+ sspr_(uplo, &i__1, &r__1, &ap[kc + 1], &c__1, &ap[kc + *n
+ - k + 1]);
+
+/* Store L(k) in column K */
+
+ i__1 = *n - k;
+ sscal_(&i__1, &r1, &ap[kc + 1], &c__1);
+ }
+ } 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 */
+
+ if (k < *n - 1) {
+
+/* 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) )' */
+/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' */
+
+ d21 = ap[k + 1 + (k - 1) * ((*n << 1) - k) / 2];
+ d11 = ap[k + 1 + k * ((*n << 1) - k - 1) / 2] / d21;
+ d22 = ap[k + (k - 1) * ((*n << 1) - k) / 2] / d21;
+ t = 1.f / (d11 * d22 - 1.f);
+ d21 = t / d21;
+
+ i__1 = *n;
+ for (j = k + 2; j <= i__1; ++j) {
+ wk = d21 * (d11 * ap[j + (k - 1) * ((*n << 1) - k) /
+ 2] - ap[j + k * ((*n << 1) - k - 1) / 2]);
+ wkp1 = d21 * (d22 * ap[j + k * ((*n << 1) - k - 1) /
+ 2] - ap[j + (k - 1) * ((*n << 1) - k) / 2]);
+
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ap[i__ + (j - 1) * ((*n << 1) - j) / 2] = ap[i__
+ + (j - 1) * ((*n << 1) - j) / 2] - ap[i__
+ + (k - 1) * ((*n << 1) - k) / 2] * wk -
+ ap[i__ + k * ((*n << 1) - k - 1) / 2] *
+ wkp1;
+/* L90: */
+ }
+
+ ap[j + (k - 1) * ((*n << 1) - k) / 2] = wk;
+ ap[j + k * ((*n << 1) - k - 1) / 2] = wkp1;
+
+/* L100: */
+ }
+ }
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k + 1] = -kp;
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kstep;
+ kc = knc + *n - k + 2;
+ goto L60;
+
+ }
+
+L110:
+ return 0;
+
+/* End of SSPTRF */
+
+} /* ssptrf_ */
diff --git a/SRC/ssptri.c b/SRC/ssptri.c
new file mode 100644
index 0000000..bdaa884
--- /dev/null
+++ b/SRC/ssptri.c
@@ -0,0 +1,407 @@
+/* ssptri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b11 = -1.f;
+static real c_b13 = 0.f;
+
+/* Subroutine */ int ssptri_(char *uplo, integer *n, real *ap, integer *ipiv,
+ real *work, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1;
+
+ /* Local variables */
+ real d__;
+ integer j, k;
+ real t, ak;
+ integer kc, kp, kx, kpc, npp;
+ real akp1, temp;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ real akkp1;
+ extern logical lsame_(char *, char *);
+ integer kstep;
+ logical upper;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), sswap_(integer *, real *, integer *, real *, integer *
+), sspmv_(char *, integer *, real *, real *, real *, integer *,
+ real *, real *, integer *), xerbla_(char *, integer *);
+ integer kcnext;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSPTRI computes the inverse of a real symmetric indefinite matrix */
+/* A in packed storage using the factorization A = U*D*U**T or */
+/* A = L*D*L**T computed by SSPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) REAL array, dimension (N*(N+1)/2) */
+/* On entry, the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L as computed by SSPTRF, */
+/* stored as a packed triangular matrix. */
+
+/* On exit, if INFO = 0, the (symmetric) inverse of the original */
+/* matrix, stored as a packed triangular matrix. The j-th column */
+/* of inv(A) is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by SSPTRF. */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) 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. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --work;
+ --ipiv;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSPTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ kp = *n * (*n + 1) / 2;
+ for (*info = *n; *info >= 1; --(*info)) {
+ if (ipiv[*info] > 0 && ap[kp] == 0.f) {
+ return 0;
+ }
+ kp -= *info;
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ kp = 1;
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ if (ipiv[*info] > 0 && ap[kp] == 0.f) {
+ return 0;
+ }
+ kp = kp + *n - *info + 1;
+/* L20: */
+ }
+ }
+ *info = 0;
+
+ if (upper) {
+
+/* Compute inv(A) from the factorization A = U*D*U'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+ kc = 1;
+L30:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L50;
+ }
+
+ kcnext = kc + k;
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ ap[kc + k - 1] = 1.f / ap[kc + k - 1];
+
+/* Compute column K of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ scopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ sspmv_(uplo, &i__1, &c_b11, &ap[1], &work[1], &c__1, &c_b13, &
+ ap[kc], &c__1);
+ i__1 = k - 1;
+ ap[kc + k - 1] -= sdot_(&i__1, &work[1], &c__1, &ap[kc], &
+ c__1);
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ t = (r__1 = ap[kcnext + k - 1], dabs(r__1));
+ ak = ap[kc + k - 1] / t;
+ akp1 = ap[kcnext + k] / t;
+ akkp1 = ap[kcnext + k - 1] / t;
+ d__ = t * (ak * akp1 - 1.f);
+ ap[kc + k - 1] = akp1 / d__;
+ ap[kcnext + k] = ak / d__;
+ ap[kcnext + k - 1] = -akkp1 / d__;
+
+/* Compute columns K and K+1 of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ scopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ sspmv_(uplo, &i__1, &c_b11, &ap[1], &work[1], &c__1, &c_b13, &
+ ap[kc], &c__1);
+ i__1 = k - 1;
+ ap[kc + k - 1] -= sdot_(&i__1, &work[1], &c__1, &ap[kc], &
+ c__1);
+ i__1 = k - 1;
+ ap[kcnext + k - 1] -= sdot_(&i__1, &ap[kc], &c__1, &ap[kcnext]
+, &c__1);
+ i__1 = k - 1;
+ scopy_(&i__1, &ap[kcnext], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ sspmv_(uplo, &i__1, &c_b11, &ap[1], &work[1], &c__1, &c_b13, &
+ ap[kcnext], &c__1);
+ i__1 = k - 1;
+ ap[kcnext + k] -= sdot_(&i__1, &work[1], &c__1, &ap[kcnext], &
+ c__1);
+ }
+ kstep = 2;
+ kcnext = kcnext + k + 1;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the leading */
+/* submatrix A(1:k+1,1:k+1) */
+
+ kpc = (kp - 1) * kp / 2 + 1;
+ i__1 = kp - 1;
+ sswap_(&i__1, &ap[kc], &c__1, &ap[kpc], &c__1);
+ kx = kpc + kp - 1;
+ i__1 = k - 1;
+ for (j = kp + 1; j <= i__1; ++j) {
+ kx = kx + j - 1;
+ temp = ap[kc + j - 1];
+ ap[kc + j - 1] = ap[kx];
+ ap[kx] = temp;
+/* L40: */
+ }
+ temp = ap[kc + k - 1];
+ ap[kc + k - 1] = ap[kpc + kp - 1];
+ ap[kpc + kp - 1] = temp;
+ if (kstep == 2) {
+ temp = ap[kc + k + k - 1];
+ ap[kc + k + k - 1] = ap[kc + k + kp - 1];
+ ap[kc + k + kp - 1] = temp;
+ }
+ }
+
+ k += kstep;
+ kc = kcnext;
+ goto L30;
+L50:
+
+ ;
+ } else {
+
+/* Compute inv(A) from the factorization A = L*D*L'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ npp = *n * (*n + 1) / 2;
+ k = *n;
+ kc = npp;
+L60:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L80;
+ }
+
+ kcnext = kc - (*n - k + 2);
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ ap[kc] = 1.f / ap[kc];
+
+/* Compute column K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ scopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ sspmv_(uplo, &i__1, &c_b11, &ap[kc + *n - k + 1], &work[1], &
+ c__1, &c_b13, &ap[kc + 1], &c__1);
+ i__1 = *n - k;
+ ap[kc] -= sdot_(&i__1, &work[1], &c__1, &ap[kc + 1], &c__1);
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ t = (r__1 = ap[kcnext + 1], dabs(r__1));
+ ak = ap[kcnext] / t;
+ akp1 = ap[kc] / t;
+ akkp1 = ap[kcnext + 1] / t;
+ d__ = t * (ak * akp1 - 1.f);
+ ap[kcnext] = akp1 / d__;
+ ap[kc] = ak / d__;
+ ap[kcnext + 1] = -akkp1 / d__;
+
+/* Compute columns K-1 and K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ scopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ sspmv_(uplo, &i__1, &c_b11, &ap[kc + (*n - k + 1)], &work[1],
+ &c__1, &c_b13, &ap[kc + 1], &c__1);
+ i__1 = *n - k;
+ ap[kc] -= sdot_(&i__1, &work[1], &c__1, &ap[kc + 1], &c__1);
+ i__1 = *n - k;
+ ap[kcnext + 1] -= sdot_(&i__1, &ap[kc + 1], &c__1, &ap[kcnext
+ + 2], &c__1);
+ i__1 = *n - k;
+ scopy_(&i__1, &ap[kcnext + 2], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ sspmv_(uplo, &i__1, &c_b11, &ap[kc + (*n - k + 1)], &work[1],
+ &c__1, &c_b13, &ap[kcnext + 2], &c__1);
+ i__1 = *n - k;
+ ap[kcnext] -= sdot_(&i__1, &work[1], &c__1, &ap[kcnext + 2], &
+ c__1);
+ }
+ kstep = 2;
+ kcnext -= *n - k + 3;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the trailing */
+/* submatrix A(k-1:n,k-1:n) */
+
+ kpc = npp - (*n - kp + 1) * (*n - kp + 2) / 2 + 1;
+ if (kp < *n) {
+ i__1 = *n - kp;
+ sswap_(&i__1, &ap[kc + kp - k + 1], &c__1, &ap[kpc + 1], &
+ c__1);
+ }
+ kx = kc + kp - k;
+ i__1 = kp - 1;
+ for (j = k + 1; j <= i__1; ++j) {
+ kx = kx + *n - j + 1;
+ temp = ap[kc + j - k];
+ ap[kc + j - k] = ap[kx];
+ ap[kx] = temp;
+/* L70: */
+ }
+ temp = ap[kc];
+ ap[kc] = ap[kpc];
+ ap[kpc] = temp;
+ if (kstep == 2) {
+ temp = ap[kc - *n + k - 1];
+ ap[kc - *n + k - 1] = ap[kc - *n + kp - 1];
+ ap[kc - *n + kp - 1] = temp;
+ }
+ }
+
+ k -= kstep;
+ kc = kcnext;
+ goto L60;
+L80:
+ ;
+ }
+
+ return 0;
+
+/* End of SSPTRI */
+
+} /* ssptri_ */
diff --git a/SRC/ssptrs.c b/SRC/ssptrs.c
new file mode 100644
index 0000000..c83efd6
--- /dev/null
+++ b/SRC/ssptrs.c
@@ -0,0 +1,452 @@
+/* ssptrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b7 = -1.f;
+static integer c__1 = 1;
+static real c_b19 = 1.f;
+
+/* Subroutine */ int ssptrs_(char *uplo, integer *n, integer *nrhs, real *ap,
+ integer *ipiv, real *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+ real r__1;
+
+ /* Local variables */
+ integer j, k;
+ real ak, bk;
+ integer kc, kp;
+ real akm1, bkm1;
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ real akm1k;
+ extern logical lsame_(char *, char *);
+ real denom;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ sgemv_(char *, integer *, integer *, real *, real *, integer *,
+ real *, integer *, real *, real *, integer *);
+ logical upper;
+ extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
+ integer *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSPTRS solves a system of linear equations A*X = B with a real */
+/* symmetric matrix A stored in packed format using the factorization */
+/* A = U*D*U**T or A = L*D*L**T computed by SSPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input) REAL array, dimension (N*(N+1)/2) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by SSPTRF, stored as a */
+/* packed triangular matrix. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by SSPTRF. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ap;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSPTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B, where A = U*D*U'. */
+
+/* First solve U*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L10:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L30;
+ }
+
+ kc -= k;
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ i__1 = k - 1;
+ sger_(&i__1, nrhs, &c_b7, &ap[kc], &c__1, &b[k + b_dim1], ldb, &b[
+ b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ r__1 = 1.f / ap[kc + k - 1];
+ sscal_(nrhs, &r__1, &b[k + b_dim1], ldb);
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K-1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k - 1) {
+ sswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ i__1 = k - 2;
+ sger_(&i__1, nrhs, &c_b7, &ap[kc], &c__1, &b[k + b_dim1], ldb, &b[
+ b_dim1 + 1], ldb);
+ i__1 = k - 2;
+ sger_(&i__1, nrhs, &c_b7, &ap[kc - (k - 1)], &c__1, &b[k - 1 +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ akm1k = ap[kc + k - 2];
+ akm1 = ap[kc - 1] / akm1k;
+ ak = ap[kc + k - 1] / akm1k;
+ denom = akm1 * ak - 1.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bkm1 = b[k - 1 + j * b_dim1] / akm1k;
+ bk = b[k + j * b_dim1] / akm1k;
+ b[k - 1 + j * b_dim1] = (ak * bkm1 - bk) / denom;
+ b[k + j * b_dim1] = (akm1 * bk - bkm1) / denom;
+/* L20: */
+ }
+ kc = kc - k + 1;
+ k += -2;
+ }
+
+ goto L10;
+L30:
+
+/* Next solve U'*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+ kc = 1;
+L40:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L50;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(U'(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ i__1 = k - 1;
+ sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &ap[kc]
+, &c__1, &c_b19, &b[k + b_dim1], ldb);
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ kc += k;
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ i__1 = k - 1;
+ sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &ap[kc]
+, &c__1, &c_b19, &b[k + b_dim1], ldb);
+ i__1 = k - 1;
+ sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &ap[kc
+ + k], &c__1, &c_b19, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ kc = kc + (k << 1) + 1;
+ k += 2;
+ }
+
+ goto L40;
+L50:
+
+ ;
+ } else {
+
+/* Solve A*X = B, where A = L*D*L'. */
+
+/* First solve L*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+ kc = 1;
+L60:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L80;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ sger_(&i__1, nrhs, &c_b7, &ap[kc + 1], &c__1, &b[k + b_dim1],
+ ldb, &b[k + 1 + b_dim1], ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ r__1 = 1.f / ap[kc];
+ sscal_(nrhs, &r__1, &b[k + b_dim1], ldb);
+ kc = kc + *n - k + 1;
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K+1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k + 1) {
+ sswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ if (k < *n - 1) {
+ i__1 = *n - k - 1;
+ sger_(&i__1, nrhs, &c_b7, &ap[kc + 2], &c__1, &b[k + b_dim1],
+ ldb, &b[k + 2 + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ sger_(&i__1, nrhs, &c_b7, &ap[kc + *n - k + 2], &c__1, &b[k +
+ 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ akm1k = ap[kc + 1];
+ akm1 = ap[kc] / akm1k;
+ ak = ap[kc + *n - k + 1] / akm1k;
+ denom = akm1 * ak - 1.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bkm1 = b[k + j * b_dim1] / akm1k;
+ bk = b[k + 1 + j * b_dim1] / akm1k;
+ b[k + j * b_dim1] = (ak * bkm1 - bk) / denom;
+ b[k + 1 + j * b_dim1] = (akm1 * bk - bkm1) / denom;
+/* L70: */
+ }
+ kc = kc + (*n - k << 1) + 1;
+ k += 2;
+ }
+
+ goto L60;
+L80:
+
+/* Next solve L'*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L90:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L100;
+ }
+
+ kc -= *n - k + 1;
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(L'(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1],
+ ldb, &ap[kc + 1], &c__1, &c_b19, &b[k + b_dim1], ldb);
+ }
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1],
+ ldb, &ap[kc + 1], &c__1, &c_b19, &b[k + b_dim1], ldb);
+ i__1 = *n - k;
+ sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1],
+ ldb, &ap[kc - (*n - k)], &c__1, &c_b19, &b[k - 1 +
+ b_dim1], ldb);
+ }
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ kc -= *n - k + 2;
+ k += -2;
+ }
+
+ goto L90;
+L100:
+ ;
+ }
+
+ return 0;
+
+/* End of SSPTRS */
+
+} /* ssptrs_ */
diff --git a/SRC/sstebz.c b/SRC/sstebz.c
new file mode 100644
index 0000000..c2457fd
--- /dev/null
+++ b/SRC/sstebz.c
@@ -0,0 +1,773 @@
+/* sstebz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+static integer c__0 = 0;
+
+/* Subroutine */ int sstebz_(char *range, char *order, integer *n, real *vl,
+ real *vu, integer *il, integer *iu, real *abstol, real *d__, real *e,
+ integer *m, integer *nsplit, real *w, integer *iblock, integer *
+ isplit, real *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real r__1, r__2, r__3, r__4, r__5;
+
+ /* Builtin functions */
+ double sqrt(doublereal), log(doublereal);
+
+ /* Local variables */
+ integer j, ib, jb, ie, je, nb;
+ real gl;
+ integer im, in;
+ real gu;
+ integer iw;
+ real wl, wu;
+ integer nwl;
+ real ulp, wlu, wul;
+ integer nwu;
+ real tmp1, tmp2;
+ integer iend, ioff, iout, itmp1, jdisc;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ real atoli;
+ integer iwoff;
+ real bnorm;
+ integer itmax;
+ real wkill, rtoli, tnorm;
+ integer ibegin, irange, idiscl;
+ extern doublereal slamch_(char *);
+ real safemn;
+ integer idumma[1];
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer idiscu;
+ extern /* Subroutine */ int slaebz_(integer *, integer *, integer *,
+ integer *, integer *, integer *, real *, real *, real *, real *,
+ real *, real *, integer *, real *, real *, integer *, integer *,
+ real *, integer *, integer *);
+ integer iorder;
+ logical ncnvrg;
+ real pivmin;
+ logical toofew;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+/* 8-18-00: Increase FUDGE factor for T3E (eca) */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSTEBZ computes the eigenvalues of a symmetric tridiagonal */
+/* matrix T. The user may ask for all eigenvalues, all eigenvalues */
+/* in the half-open interval (VL, VU], or the IL-th through IU-th */
+/* eigenvalues. */
+
+/* To avoid overflow, the matrix must be scaled so that its */
+/* largest element is no greater than overflow**(1/2) * */
+/* underflow**(1/4) in absolute value, and for greatest */
+/* accuracy, it should not be much smaller than that. */
+
+/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */
+/* Matrix", Report CS41, Computer Science Dept., Stanford */
+/* University, July 21, 1966. */
+
+/* Arguments */
+/* ========= */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': ("All") all eigenvalues will be found. */
+/* = 'V': ("Value") all eigenvalues in the half-open interval */
+/* (VL, VU] will be found. */
+/* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the */
+/* entire matrix) will be found. */
+
+/* ORDER (input) CHARACTER*1 */
+/* = 'B': ("By Block") the eigenvalues will be grouped by */
+/* split-off block (see IBLOCK, ISPLIT) and */
+/* ordered from smallest to largest within */
+/* the block. */
+/* = 'E': ("Entire matrix") */
+/* the eigenvalues for the entire matrix */
+/* will be ordered from smallest to */
+/* largest. */
+
+/* N (input) INTEGER */
+/* The order of the tridiagonal matrix T. N >= 0. */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. Eigenvalues less than or equal */
+/* to VL, or greater than VU, will not be returned. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) REAL */
+/* The absolute tolerance for the eigenvalues. An eigenvalue */
+/* (or cluster) is considered to be located if it has been */
+/* determined to lie in an interval whose width is ABSTOL or */
+/* less. If ABSTOL is less than or equal to zero, then ULP*|T| */
+/* will be used, where |T| means the 1-norm of T. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*SLAMCH('S'), not zero. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix T. */
+
+/* E (input) REAL array, dimension (N-1) */
+/* The (n-1) off-diagonal elements of the tridiagonal matrix T. */
+
+/* M (output) INTEGER */
+/* The actual number of eigenvalues found. 0 <= M <= N. */
+/* (See also the description of INFO=2,3.) */
+
+/* NSPLIT (output) INTEGER */
+/* The number of diagonal blocks in the matrix T. */
+/* 1 <= NSPLIT <= N. */
+
+/* W (output) REAL array, dimension (N) */
+/* On exit, the first M elements of W will contain the */
+/* eigenvalues. (SSTEBZ may use the remaining N-M elements as */
+/* workspace.) */
+
+/* IBLOCK (output) INTEGER array, dimension (N) */
+/* At each row/column j where E(j) is zero or small, the */
+/* matrix T is considered to split into a block diagonal */
+/* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which */
+/* block (from 1 to the number of blocks) the eigenvalue W(i) */
+/* belongs. (SSTEBZ may use the remaining N-M elements as */
+/* workspace.) */
+
+/* ISPLIT (output) INTEGER array, dimension (N) */
+/* The splitting points, at which T breaks up into submatrices. */
+/* The first submatrix consists of rows/columns 1 to ISPLIT(1), */
+/* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */
+/* etc., and the NSPLIT-th consists of rows/columns */
+/* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */
+/* (Only the first NSPLIT elements will actually be used, but */
+/* since the user cannot know a priori what value NSPLIT will */
+/* have, N words must be reserved for ISPLIT.) */
+
+/* WORK (workspace) REAL array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: some or all of the eigenvalues failed to converge or */
+/* were not computed: */
+/* =1 or 3: Bisection failed to converge for some */
+/* eigenvalues; these eigenvalues are flagged by a */
+/* negative block number. The effect is that the */
+/* eigenvalues may not be as accurate as the */
+/* absolute and relative tolerances. This is */
+/* generally caused by unexpectedly inaccurate */
+/* arithmetic. */
+/* =2 or 3: RANGE='I' only: Not all of the eigenvalues */
+/* IL:IU were found. */
+/* Effect: M < IU+1-IL */
+/* Cause: non-monotonic arithmetic, causing the */
+/* Sturm sequence to be non-monotonic. */
+/* Cure: recalculate, using RANGE='A', and pick */
+/* out eigenvalues IL:IU. In some cases, */
+/* increasing the PARAMETER "FUDGE" may */
+/* make things work. */
+/* = 4: RANGE='I', and the Gershgorin interval */
+/* initially used was too small. No eigenvalues */
+/* were computed. */
+/* Probable cause: your machine has sloppy */
+/* floating-point arithmetic. */
+/* Cure: Increase the PARAMETER "FUDGE", */
+/* recompile, and try again. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* RELFAC REAL, default = 2.0e0 */
+/* The relative tolerance. An interval (a,b] lies within */
+/* "relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|), */
+/* where "ulp" is the machine precision (distance from 1 to */
+/* the next larger floating point number.) */
+
+/* FUDGE REAL, default = 2 */
+/* A "fudge factor" to widen the Gershgorin intervals. Ideally, */
+/* a value of 1 should work, but on machines with sloppy */
+/* arithmetic, this needs to be larger. The default for */
+/* publicly released versions should be large enough to handle */
+/* the worst machine around. Note that this has no effect */
+/* on accuracy of the solution. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --isplit;
+ --iblock;
+ --w;
+ --e;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+
+/* Decode RANGE */
+
+ if (lsame_(range, "A")) {
+ irange = 1;
+ } else if (lsame_(range, "V")) {
+ irange = 2;
+ } else if (lsame_(range, "I")) {
+ irange = 3;
+ } else {
+ irange = 0;
+ }
+
+/* Decode ORDER */
+
+ if (lsame_(order, "B")) {
+ iorder = 2;
+ } else if (lsame_(order, "E")) {
+ iorder = 1;
+ } else {
+ iorder = 0;
+ }
+
+/* Check for Errors */
+
+ if (irange <= 0) {
+ *info = -1;
+ } else if (iorder <= 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (irange == 2) {
+ if (*vl >= *vu) {
+ *info = -5;
+ }
+ } else if (irange == 3 && (*il < 1 || *il > max(1,*n))) {
+ *info = -6;
+ } else if (irange == 3 && (*iu < min(*n,*il) || *iu > *n)) {
+ *info = -7;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSTEBZ", &i__1);
+ return 0;
+ }
+
+/* Initialize error flags */
+
+ *info = 0;
+ ncnvrg = FALSE_;
+ toofew = FALSE_;
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Simplifications: */
+
+ if (irange == 3 && *il == 1 && *iu == *n) {
+ irange = 1;
+ }
+
+/* Get machine constants */
+/* NB is the minimum vector length for vector bisection, or 0 */
+/* if only scalar is to be done. */
+
+ safemn = slamch_("S");
+ ulp = slamch_("P");
+ rtoli = ulp * 2.f;
+ nb = ilaenv_(&c__1, "SSTEBZ", " ", n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1) {
+ nb = 0;
+ }
+
+/* Special Case when N=1 */
+
+ if (*n == 1) {
+ *nsplit = 1;
+ isplit[1] = 1;
+ if (irange == 2 && (*vl >= d__[1] || *vu < d__[1])) {
+ *m = 0;
+ } else {
+ w[1] = d__[1];
+ iblock[1] = 1;
+ *m = 1;
+ }
+ return 0;
+ }
+
+/* Compute Splitting Points */
+
+ *nsplit = 1;
+ work[*n] = 0.f;
+ pivmin = 1.f;
+
+/* DIR$ NOVECTOR */
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing 2nd power */
+ r__1 = e[j - 1];
+ tmp1 = r__1 * r__1;
+/* Computing 2nd power */
+ r__2 = ulp;
+ if ((r__1 = d__[j] * d__[j - 1], dabs(r__1)) * (r__2 * r__2) + safemn
+ > tmp1) {
+ isplit[*nsplit] = j - 1;
+ ++(*nsplit);
+ work[j - 1] = 0.f;
+ } else {
+ work[j - 1] = tmp1;
+ pivmin = dmax(pivmin,tmp1);
+ }
+/* L10: */
+ }
+ isplit[*nsplit] = *n;
+ pivmin *= safemn;
+
+/* Compute Interval and ATOLI */
+
+ if (irange == 3) {
+
+/* RANGE='I': Compute the interval containing eigenvalues */
+/* IL through IU. */
+
+/* Compute Gershgorin interval for entire (split) matrix */
+/* and use it as the initial interval */
+
+ gu = d__[1];
+ gl = d__[1];
+ tmp1 = 0.f;
+
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ tmp2 = sqrt(work[j]);
+/* Computing MAX */
+ r__1 = gu, r__2 = d__[j] + tmp1 + tmp2;
+ gu = dmax(r__1,r__2);
+/* Computing MIN */
+ r__1 = gl, r__2 = d__[j] - tmp1 - tmp2;
+ gl = dmin(r__1,r__2);
+ tmp1 = tmp2;
+/* L20: */
+ }
+
+/* Computing MAX */
+ r__1 = gu, r__2 = d__[*n] + tmp1;
+ gu = dmax(r__1,r__2);
+/* Computing MIN */
+ r__1 = gl, r__2 = d__[*n] - tmp1;
+ gl = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = dabs(gl), r__2 = dabs(gu);
+ tnorm = dmax(r__1,r__2);
+ gl = gl - tnorm * 2.1f * ulp * *n - pivmin * 4.2000000000000002f;
+ gu = gu + tnorm * 2.1f * ulp * *n + pivmin * 2.1f;
+
+/* Compute Iteration parameters */
+
+ itmax = (integer) ((log(tnorm + pivmin) - log(pivmin)) / log(2.f)) +
+ 2;
+ if (*abstol <= 0.f) {
+ atoli = ulp * tnorm;
+ } else {
+ atoli = *abstol;
+ }
+
+ work[*n + 1] = gl;
+ work[*n + 2] = gl;
+ work[*n + 3] = gu;
+ work[*n + 4] = gu;
+ work[*n + 5] = gl;
+ work[*n + 6] = gu;
+ iwork[1] = -1;
+ iwork[2] = -1;
+ iwork[3] = *n + 1;
+ iwork[4] = *n + 1;
+ iwork[5] = *il - 1;
+ iwork[6] = *iu;
+
+ slaebz_(&c__3, &itmax, n, &c__2, &c__2, &nb, &atoli, &rtoli, &pivmin,
+ &d__[1], &e[1], &work[1], &iwork[5], &work[*n + 1], &work[*n
+ + 5], &iout, &iwork[1], &w[1], &iblock[1], &iinfo);
+
+ if (iwork[6] == *iu) {
+ wl = work[*n + 1];
+ wlu = work[*n + 3];
+ nwl = iwork[1];
+ wu = work[*n + 4];
+ wul = work[*n + 2];
+ nwu = iwork[4];
+ } else {
+ wl = work[*n + 2];
+ wlu = work[*n + 4];
+ nwl = iwork[2];
+ wu = work[*n + 3];
+ wul = work[*n + 1];
+ nwu = iwork[3];
+ }
+
+ if (nwl < 0 || nwl >= *n || nwu < 1 || nwu > *n) {
+ *info = 4;
+ return 0;
+ }
+ } else {
+
+/* RANGE='A' or 'V' -- Set ATOLI */
+
+/* Computing MAX */
+ r__3 = dabs(d__[1]) + dabs(e[1]), r__4 = (r__1 = d__[*n], dabs(r__1))
+ + (r__2 = e[*n - 1], dabs(r__2));
+ tnorm = dmax(r__3,r__4);
+
+ i__1 = *n - 1;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MAX */
+ r__4 = tnorm, r__5 = (r__1 = d__[j], dabs(r__1)) + (r__2 = e[j -
+ 1], dabs(r__2)) + (r__3 = e[j], dabs(r__3));
+ tnorm = dmax(r__4,r__5);
+/* L30: */
+ }
+
+ if (*abstol <= 0.f) {
+ atoli = ulp * tnorm;
+ } else {
+ atoli = *abstol;
+ }
+
+ if (irange == 2) {
+ wl = *vl;
+ wu = *vu;
+ } else {
+ wl = 0.f;
+ wu = 0.f;
+ }
+ }
+
+/* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU. */
+/* NWL accumulates the number of eigenvalues .le. WL, */
+/* NWU accumulates the number of eigenvalues .le. WU */
+
+ *m = 0;
+ iend = 0;
+ *info = 0;
+ nwl = 0;
+ nwu = 0;
+
+ i__1 = *nsplit;
+ for (jb = 1; jb <= i__1; ++jb) {
+ ioff = iend;
+ ibegin = ioff + 1;
+ iend = isplit[jb];
+ in = iend - ioff;
+
+ if (in == 1) {
+
+/* Special Case -- IN=1 */
+
+ if (irange == 1 || wl >= d__[ibegin] - pivmin) {
+ ++nwl;
+ }
+ if (irange == 1 || wu >= d__[ibegin] - pivmin) {
+ ++nwu;
+ }
+ if (irange == 1 || wl < d__[ibegin] - pivmin && wu >= d__[ibegin]
+ - pivmin) {
+ ++(*m);
+ w[*m] = d__[ibegin];
+ iblock[*m] = jb;
+ }
+ } else {
+
+/* General Case -- IN > 1 */
+
+/* Compute Gershgorin Interval */
+/* and use it as the initial interval */
+
+ gu = d__[ibegin];
+ gl = d__[ibegin];
+ tmp1 = 0.f;
+
+ i__2 = iend - 1;
+ for (j = ibegin; j <= i__2; ++j) {
+ tmp2 = (r__1 = e[j], dabs(r__1));
+/* Computing MAX */
+ r__1 = gu, r__2 = d__[j] + tmp1 + tmp2;
+ gu = dmax(r__1,r__2);
+/* Computing MIN */
+ r__1 = gl, r__2 = d__[j] - tmp1 - tmp2;
+ gl = dmin(r__1,r__2);
+ tmp1 = tmp2;
+/* L40: */
+ }
+
+/* Computing MAX */
+ r__1 = gu, r__2 = d__[iend] + tmp1;
+ gu = dmax(r__1,r__2);
+/* Computing MIN */
+ r__1 = gl, r__2 = d__[iend] - tmp1;
+ gl = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = dabs(gl), r__2 = dabs(gu);
+ bnorm = dmax(r__1,r__2);
+ gl = gl - bnorm * 2.1f * ulp * in - pivmin * 2.1f;
+ gu = gu + bnorm * 2.1f * ulp * in + pivmin * 2.1f;
+
+/* Compute ATOLI for the current submatrix */
+
+ if (*abstol <= 0.f) {
+/* Computing MAX */
+ r__1 = dabs(gl), r__2 = dabs(gu);
+ atoli = ulp * dmax(r__1,r__2);
+ } else {
+ atoli = *abstol;
+ }
+
+ if (irange > 1) {
+ if (gu < wl) {
+ nwl += in;
+ nwu += in;
+ goto L70;
+ }
+ gl = dmax(gl,wl);
+ gu = dmin(gu,wu);
+ if (gl >= gu) {
+ goto L70;
+ }
+ }
+
+/* Set Up Initial Interval */
+
+ work[*n + 1] = gl;
+ work[*n + in + 1] = gu;
+ slaebz_(&c__1, &c__0, &in, &in, &c__1, &nb, &atoli, &rtoli, &
+ pivmin, &d__[ibegin], &e[ibegin], &work[ibegin], idumma, &
+ work[*n + 1], &work[*n + (in << 1) + 1], &im, &iwork[1], &
+ w[*m + 1], &iblock[*m + 1], &iinfo);
+
+ nwl += iwork[1];
+ nwu += iwork[in + 1];
+ iwoff = *m - iwork[1];
+
+/* Compute Eigenvalues */
+
+ itmax = (integer) ((log(gu - gl + pivmin) - log(pivmin)) / log(
+ 2.f)) + 2;
+ slaebz_(&c__2, &itmax, &in, &in, &c__1, &nb, &atoli, &rtoli, &
+ pivmin, &d__[ibegin], &e[ibegin], &work[ibegin], idumma, &
+ work[*n + 1], &work[*n + (in << 1) + 1], &iout, &iwork[1],
+ &w[*m + 1], &iblock[*m + 1], &iinfo);
+
+/* Copy Eigenvalues Into W and IBLOCK */
+/* Use -JB for block number for unconverged eigenvalues. */
+
+ i__2 = iout;
+ for (j = 1; j <= i__2; ++j) {
+ tmp1 = (work[j + *n] + work[j + in + *n]) * .5f;
+
+/* Flag non-convergence. */
+
+ if (j > iout - iinfo) {
+ ncnvrg = TRUE_;
+ ib = -jb;
+ } else {
+ ib = jb;
+ }
+ i__3 = iwork[j + in] + iwoff;
+ for (je = iwork[j] + 1 + iwoff; je <= i__3; ++je) {
+ w[je] = tmp1;
+ iblock[je] = ib;
+/* L50: */
+ }
+/* L60: */
+ }
+
+ *m += im;
+ }
+L70:
+ ;
+ }
+
+/* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU */
+/* If NWL+1 < IL or NWU > IU, discard extra eigenvalues. */
+
+ if (irange == 3) {
+ im = 0;
+ idiscl = *il - 1 - nwl;
+ idiscu = nwu - *iu;
+
+ if (idiscl > 0 || idiscu > 0) {
+ i__1 = *m;
+ for (je = 1; je <= i__1; ++je) {
+ if (w[je] <= wlu && idiscl > 0) {
+ --idiscl;
+ } else if (w[je] >= wul && idiscu > 0) {
+ --idiscu;
+ } else {
+ ++im;
+ w[im] = w[je];
+ iblock[im] = iblock[je];
+ }
+/* L80: */
+ }
+ *m = im;
+ }
+ if (idiscl > 0 || idiscu > 0) {
+
+/* Code to deal with effects of bad arithmetic: */
+/* Some low eigenvalues to be discarded are not in (WL,WLU], */
+/* or high eigenvalues to be discarded are not in (WUL,WU] */
+/* so just kill off the smallest IDISCL/largest IDISCU */
+/* eigenvalues, by simply finding the smallest/largest */
+/* eigenvalue(s). */
+
+/* (If N(w) is monotone non-decreasing, this should never */
+/* happen.) */
+
+ if (idiscl > 0) {
+ wkill = wu;
+ i__1 = idiscl;
+ for (jdisc = 1; jdisc <= i__1; ++jdisc) {
+ iw = 0;
+ i__2 = *m;
+ for (je = 1; je <= i__2; ++je) {
+ if (iblock[je] != 0 && (w[je] < wkill || iw == 0)) {
+ iw = je;
+ wkill = w[je];
+ }
+/* L90: */
+ }
+ iblock[iw] = 0;
+/* L100: */
+ }
+ }
+ if (idiscu > 0) {
+
+ wkill = wl;
+ i__1 = idiscu;
+ for (jdisc = 1; jdisc <= i__1; ++jdisc) {
+ iw = 0;
+ i__2 = *m;
+ for (je = 1; je <= i__2; ++je) {
+ if (iblock[je] != 0 && (w[je] > wkill || iw == 0)) {
+ iw = je;
+ wkill = w[je];
+ }
+/* L110: */
+ }
+ iblock[iw] = 0;
+/* L120: */
+ }
+ }
+ im = 0;
+ i__1 = *m;
+ for (je = 1; je <= i__1; ++je) {
+ if (iblock[je] != 0) {
+ ++im;
+ w[im] = w[je];
+ iblock[im] = iblock[je];
+ }
+/* L130: */
+ }
+ *m = im;
+ }
+ if (idiscl < 0 || idiscu < 0) {
+ toofew = TRUE_;
+ }
+ }
+
+/* If ORDER='B', do nothing -- the eigenvalues are already sorted */
+/* by block. */
+/* If ORDER='E', sort the eigenvalues from smallest to largest */
+
+ if (iorder == 1 && *nsplit > 1) {
+ i__1 = *m - 1;
+ for (je = 1; je <= i__1; ++je) {
+ ie = 0;
+ tmp1 = w[je];
+ i__2 = *m;
+ for (j = je + 1; j <= i__2; ++j) {
+ if (w[j] < tmp1) {
+ ie = j;
+ tmp1 = w[j];
+ }
+/* L140: */
+ }
+
+ if (ie != 0) {
+ itmp1 = iblock[ie];
+ w[ie] = w[je];
+ iblock[ie] = iblock[je];
+ w[je] = tmp1;
+ iblock[je] = itmp1;
+ }
+/* L150: */
+ }
+ }
+
+ *info = 0;
+ if (ncnvrg) {
+ ++(*info);
+ }
+ if (toofew) {
+ *info += 2;
+ }
+ return 0;
+
+/* End of SSTEBZ */
+
+} /* sstebz_ */
diff --git a/SRC/sstedc.c b/SRC/sstedc.c
new file mode 100644
index 0000000..950f318
--- /dev/null
+++ b/SRC/sstedc.c
@@ -0,0 +1,484 @@
+/* sstedc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__9 = 9;
+static integer c__0 = 0;
+static integer c__2 = 2;
+static real c_b17 = 0.f;
+static real c_b18 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int sstedc_(char *compz, integer *n, real *d__, real *e,
+ real *z__, integer *ldz, real *work, integer *lwork, integer *iwork,
+ integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double log(doublereal);
+ integer pow_ii(integer *, integer *);
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, m;
+ real p;
+ integer ii, lgn;
+ real eps, tiny;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ integer lwmin, start;
+ extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
+ integer *), slaed0_(integer *, integer *, integer *, real *, real
+ *, real *, integer *, real *, integer *, real *, integer *,
+ integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer finish;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *,
+ real *, integer *), slaset_(char *, integer *, integer *,
+ real *, real *, real *, integer *);
+ integer liwmin, icompz;
+ real orgnrm;
+ extern doublereal slanst_(char *, integer *, real *, real *);
+ extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *),
+ slasrt_(char *, integer *, real *, integer *);
+ logical lquery;
+ integer smlsiz;
+ extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *,
+ real *, integer *, real *, integer *);
+ integer storez, strtrw;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSTEDC computes all eigenvalues and, optionally, eigenvectors of a */
+/* symmetric tridiagonal matrix using the divide and conquer method. */
+/* The eigenvectors of a full or band real symmetric matrix can also be */
+/* found if SSYTRD or SSPTRD or SSBTRD has been used to reduce this */
+/* matrix to tridiagonal form. */
+
+/* This code makes very mild assumptions about floating point */
+/* arithmetic. It will work on machines with a guard digit in */
+/* add/subtract, or on those binary machines without guard digits */
+/* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */
+/* It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. See SLAED3 for details. */
+
+/* Arguments */
+/* ========= */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only. */
+/* = 'I': Compute eigenvectors of tridiagonal matrix also. */
+/* = 'V': Compute eigenvectors of original dense symmetric */
+/* matrix also. On entry, Z contains the orthogonal */
+/* matrix used to reduce the original matrix to */
+/* tridiagonal form. */
+
+/* N (input) INTEGER */
+/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the diagonal elements of the tridiagonal matrix. */
+/* On exit, if INFO = 0, the eigenvalues in ascending order. */
+
+/* E (input/output) REAL array, dimension (N-1) */
+/* On entry, the subdiagonal elements of the tridiagonal matrix. */
+/* On exit, E has been destroyed. */
+
+/* Z (input/output) REAL array, dimension (LDZ,N) */
+/* On entry, if COMPZ = 'V', then Z contains the orthogonal */
+/* matrix used in the reduction to tridiagonal form. */
+/* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */
+/* orthonormal eigenvectors of the original symmetric matrix, */
+/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */
+/* of the symmetric tridiagonal matrix. */
+/* If COMPZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1. */
+/* If eigenvectors are desired, then LDZ >= max(1,N). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If COMPZ = 'N' or N <= 1 then LWORK must be at least 1. */
+/* If COMPZ = 'V' and N > 1 then LWORK must be at least */
+/* ( 1 + 3*N + 2*N*lg N + 3*N**2 ), */
+/* where lg( N ) = smallest integer k such */
+/* that 2**k >= N. */
+/* If COMPZ = 'I' and N > 1 then LWORK must be at least */
+/* ( 1 + 4*N + N**2 ). */
+/* Note that for COMPZ = 'I' or 'V', then if N is less than or */
+/* equal to the minimum divide size, usually 25, then LWORK need */
+/* only be max(1,2*(N-1)). */
+
+/* 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. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1. */
+/* If COMPZ = 'V' and N > 1 then LIWORK must be at least */
+/* ( 6 + 6*N + 5*N*lg N ). */
+/* If COMPZ = 'I' and N > 1 then LIWORK must be at least */
+/* ( 3 + 5*N ). */
+/* Note that for COMPZ = 'I' or 'V', then if N is less than or */
+/* equal to the minimum divide size, usually 25, then LIWORK */
+/* need only be 1. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal size of the IWORK array, */
+/* returns this value as the first entry of the IWORK array, and */
+/* no error message related to LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: The algorithm failed to compute an eigenvalue while */
+/* working on the submatrix lying in rows and columns */
+/* INFO/(N+1) through mod(INFO,N+1). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+/* Modified by Francoise Tisseur, University of Tennessee. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1 || *liwork == -1;
+
+ if (lsame_(compz, "N")) {
+ icompz = 0;
+ } else if (lsame_(compz, "V")) {
+ icompz = 1;
+ } else if (lsame_(compz, "I")) {
+ icompz = 2;
+ } else {
+ icompz = -1;
+ }
+ if (icompz < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
+ *info = -6;
+ }
+
+ if (*info == 0) {
+
+/* Compute the workspace requirements */
+
+ smlsiz = ilaenv_(&c__9, "SSTEDC", " ", &c__0, &c__0, &c__0, &c__0);
+ if (*n <= 1 || icompz == 0) {
+ liwmin = 1;
+ lwmin = 1;
+ } else if (*n <= smlsiz) {
+ liwmin = 1;
+ lwmin = *n - 1 << 1;
+ } else {
+ lgn = (integer) (log((real) (*n)) / log(2.f));
+ if (pow_ii(&c__2, &lgn) < *n) {
+ ++lgn;
+ }
+ if (pow_ii(&c__2, &lgn) < *n) {
+ ++lgn;
+ }
+ if (icompz == 1) {
+/* Computing 2nd power */
+ i__1 = *n;
+ lwmin = *n * 3 + 1 + (*n << 1) * lgn + i__1 * i__1 * 3;
+ liwmin = *n * 6 + 6 + *n * 5 * lgn;
+ } else if (icompz == 2) {
+/* Computing 2nd power */
+ i__1 = *n;
+ lwmin = (*n << 2) + 1 + i__1 * i__1;
+ liwmin = *n * 5 + 3;
+ }
+ }
+ work[1] = (real) lwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -8;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -10;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSTEDC", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+ if (*n == 1) {
+ if (icompz != 0) {
+ z__[z_dim1 + 1] = 1.f;
+ }
+ return 0;
+ }
+
+/* If the following conditional clause is removed, then the routine */
+/* will use the Divide and Conquer routine to compute only the */
+/* eigenvalues, which requires (3N + 3N**2) real workspace and */
+/* (2 + 5N + 2N lg(N)) integer workspace. */
+/* Since on many architectures SSTERF is much faster than any other */
+/* algorithm for finding eigenvalues only, it is used here */
+/* as the default. If the conditional clause is removed, then */
+/* information on the size of workspace needs to be changed. */
+
+/* If COMPZ = 'N', use SSTERF to compute the eigenvalues. */
+
+ if (icompz == 0) {
+ ssterf_(n, &d__[1], &e[1], info);
+ goto L50;
+ }
+
+/* If N is smaller than the minimum divide size (SMLSIZ+1), then */
+/* solve the problem with another solver. */
+
+ if (*n <= smlsiz) {
+
+ ssteqr_(compz, n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], info);
+
+ } else {
+
+/* If COMPZ = 'V', the Z matrix must be stored elsewhere for later */
+/* use. */
+
+ if (icompz == 1) {
+ storez = *n * *n + 1;
+ } else {
+ storez = 1;
+ }
+
+ if (icompz == 2) {
+ slaset_("Full", n, n, &c_b17, &c_b18, &z__[z_offset], ldz);
+ }
+
+/* Scale. */
+
+ orgnrm = slanst_("M", n, &d__[1], &e[1]);
+ if (orgnrm == 0.f) {
+ goto L50;
+ }
+
+ eps = slamch_("Epsilon");
+
+ start = 1;
+
+/* while ( START <= N ) */
+
+L10:
+ if (start <= *n) {
+
+/* Let FINISH be the position of the next subdiagonal entry */
+/* such that E( FINISH ) <= TINY or FINISH = N if no such */
+/* subdiagonal exists. The matrix identified by the elements */
+/* between START and FINISH constitutes an independent */
+/* sub-problem. */
+
+ finish = start;
+L20:
+ if (finish < *n) {
+ tiny = eps * sqrt((r__1 = d__[finish], dabs(r__1))) * sqrt((
+ r__2 = d__[finish + 1], dabs(r__2)));
+ if ((r__1 = e[finish], dabs(r__1)) > tiny) {
+ ++finish;
+ goto L20;
+ }
+ }
+
+/* (Sub) Problem determined. Compute its size and solve it. */
+
+ m = finish - start + 1;
+ if (m == 1) {
+ start = finish + 1;
+ goto L10;
+ }
+ if (m > smlsiz) {
+
+/* Scale. */
+
+ orgnrm = slanst_("M", &m, &d__[start], &e[start]);
+ slascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &m, &c__1, &d__[
+ start], &m, info);
+ i__1 = m - 1;
+ i__2 = m - 1;
+ slascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &i__1, &c__1, &e[
+ start], &i__2, info);
+
+ if (icompz == 1) {
+ strtrw = 1;
+ } else {
+ strtrw = start;
+ }
+ slaed0_(&icompz, n, &m, &d__[start], &e[start], &z__[strtrw +
+ start * z_dim1], ldz, &work[1], n, &work[storez], &
+ iwork[1], info);
+ if (*info != 0) {
+ *info = (*info / (m + 1) + start - 1) * (*n + 1) + *info %
+ (m + 1) + start - 1;
+ goto L50;
+ }
+
+/* Scale back. */
+
+ slascl_("G", &c__0, &c__0, &c_b18, &orgnrm, &m, &c__1, &d__[
+ start], &m, info);
+
+ } else {
+ if (icompz == 1) {
+
+/* Since QR won't update a Z matrix which is larger than */
+/* the length of D, we must solve the sub-problem in a */
+/* workspace and then multiply back into Z. */
+
+ ssteqr_("I", &m, &d__[start], &e[start], &work[1], &m, &
+ work[m * m + 1], info);
+ slacpy_("A", n, &m, &z__[start * z_dim1 + 1], ldz, &work[
+ storez], n);
+ sgemm_("N", "N", n, &m, &m, &c_b18, &work[storez], n, &
+ work[1], &m, &c_b17, &z__[start * z_dim1 + 1],
+ ldz);
+ } else if (icompz == 2) {
+ ssteqr_("I", &m, &d__[start], &e[start], &z__[start +
+ start * z_dim1], ldz, &work[1], info);
+ } else {
+ ssterf_(&m, &d__[start], &e[start], info);
+ }
+ if (*info != 0) {
+ *info = start * (*n + 1) + finish;
+ goto L50;
+ }
+ }
+
+ start = finish + 1;
+ goto L10;
+ }
+
+/* endwhile */
+
+/* If the problem split any number of times, then the eigenvalues */
+/* will not be properly ordered. Here we permute the eigenvalues */
+/* (and the associated eigenvectors) into ascending order. */
+
+ if (m != *n) {
+ if (icompz == 0) {
+
+/* Use Quick Sort */
+
+ slasrt_("I", n, &d__[1], info);
+
+ } else {
+
+/* Use Selection Sort to minimize swaps of eigenvectors */
+
+ i__1 = *n;
+ for (ii = 2; ii <= i__1; ++ii) {
+ i__ = ii - 1;
+ k = i__;
+ p = d__[i__];
+ i__2 = *n;
+ for (j = ii; j <= i__2; ++j) {
+ if (d__[j] < p) {
+ k = j;
+ p = d__[j];
+ }
+/* L30: */
+ }
+ if (k != i__) {
+ d__[k] = d__[i__];
+ d__[i__] = p;
+ sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k *
+ z_dim1 + 1], &c__1);
+ }
+/* L40: */
+ }
+ }
+ }
+ }
+
+L50:
+ work[1] = (real) lwmin;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of SSTEDC */
+
+} /* sstedc_ */
diff --git a/SRC/sstegr.c b/SRC/sstegr.c
new file mode 100644
index 0000000..77714cf
--- /dev/null
+++ b/SRC/sstegr.c
@@ -0,0 +1,209 @@
+/* sstegr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sstegr_(char *jobz, char *range, integer *n, real *d__,
+ real *e, real *vl, real *vu, integer *il, integer *iu, real *abstol,
+ integer *m, real *w, real *z__, integer *ldz, integer *isuppz, real *
+ work, integer *lwork, integer *iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset;
+
+ /* Local variables */
+ logical tryrac;
+ extern /* Subroutine */ int sstemr_(char *, char *, integer *, real *,
+ real *, real *, real *, integer *, integer *, integer *, real *,
+ real *, integer *, integer *, integer *, logical *, real *,
+ integer *, integer *, integer *, integer *);
+
+
+
+/* -- LAPACK computational routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSTEGR computes selected eigenvalues and, optionally, eigenvectors */
+/* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */
+/* a well defined set of pairwise different real eigenvalues, the corresponding */
+/* real eigenvectors are pairwise orthogonal. */
+
+/* The spectrum may be computed either completely or partially by specifying */
+/* either an interval (VL,VU] or a range of indices IL:IU for the desired */
+/* eigenvalues. */
+
+/* SSTEGR is a compatability wrapper around the improved SSTEMR routine. */
+/* See SSTEMR for further details. */
+
+/* One important change is that the ABSTOL parameter no longer provides any */
+/* benefit and hence is no longer used. */
+
+/* Note : SSTEGR and SSTEMR work only on machines which follow */
+/* IEEE-754 floating-point standard in their handling of infinities and */
+/* NaNs. Normal execution may create these exceptiona values and hence */
+/* may abort due to a floating point exception in environments which */
+/* do not conform to the IEEE-754 standard. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the N diagonal elements of the tridiagonal matrix */
+/* T. On exit, D is overwritten. */
+
+/* E (input/output) REAL array, dimension (N) */
+/* On entry, the (N-1) subdiagonal elements of the tridiagonal */
+/* matrix T in elements 1 to N-1 of E. E(N) need not be set on */
+/* input, but is used internally as workspace. */
+/* On exit, E is overwritten. */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) REAL */
+/* Unused. Was the absolute error tolerance for the */
+/* eigenvalues/eigenvectors in previous versions. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* The first M elements contain the selected eigenvalues in */
+/* ascending order. */
+
+/* Z (output) REAL array, dimension (LDZ, max(1,M) ) */
+/* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix T */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+/* Supplying N columns is always safe. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', then LDZ >= max(1,N). */
+
+/* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) ) */
+/* The support of the eigenvectors in Z, i.e., the indices */
+/* indicating the nonzero elements in Z. The i-th computed eigenvector */
+/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */
+/* ISUPPZ( 2*i ). This is relevant in the case when the matrix */
+/* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */
+
+/* WORK (workspace/output) REAL array, dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal */
+/* (and minimal) LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,18*N) */
+/* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'. */
+/* 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. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (LIWORK) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. LIWORK >= max(1,10*N) */
+/* if the eigenvectors are desired, and LIWORK >= max(1,8*N) */
+/* if only the eigenvalues are to be computed. */
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal size of the IWORK array, */
+/* returns this value as the first entry of the IWORK array, and */
+/* no error message related to LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* On exit, INFO */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = 1X, internal error in SLARRE, */
+/* if INFO = 2X, internal error in SLARRV. */
+/* Here, the digit X = ABS( IINFO ) < 10, where IINFO is */
+/* the nonzero error code returned by SLARRE or */
+/* SLARRV, respectively. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Inderjit Dhillon, IBM Almaden, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, LBNL/NERSC, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --isuppz;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ tryrac = FALSE_;
+ sstemr_(jobz, range, n, &d__[1], &e[1], vl, vu, il, iu, m, &w[1], &z__[
+ z_offset], ldz, n, &isuppz[1], &tryrac, &work[1], lwork, &iwork[1]
+, liwork, info);
+
+/* End of SSTEGR */
+
+ return 0;
+} /* sstegr_ */
diff --git a/SRC/sstein.c b/SRC/sstein.c
new file mode 100644
index 0000000..cd9ae76
--- /dev/null
+++ b/SRC/sstein.c
@@ -0,0 +1,449 @@
+/* sstein.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int sstein_(integer *n, real *d__, real *e, integer *m, real
+ *w, integer *iblock, integer *isplit, real *z__, integer *ldz, real *
+ work, integer *iwork, integer *ifail, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2, i__3;
+ real r__1, r__2, r__3, r__4, r__5;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, b1, j1, bn;
+ real xj, scl, eps, ctr, sep, nrm, tol;
+ integer its;
+ real xjm, eps1;
+ integer jblk, nblk, jmax;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *),
+ snrm2_(integer *, real *, integer *);
+ integer iseed[4], gpind, iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ extern doublereal sasum_(integer *, real *, integer *);
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ real ortol;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *);
+ integer indrv1, indrv2, indrv3, indrv4, indrv5;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), slagtf_(
+ integer *, real *, real *, real *, real *, real *, real *,
+ integer *, integer *);
+ integer nrmchk;
+ extern integer isamax_(integer *, real *, integer *);
+ extern /* Subroutine */ int slagts_(integer *, integer *, real *, real *,
+ real *, real *, integer *, real *, real *, integer *);
+ integer blksiz;
+ real onenrm, pertol;
+ extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
+ *);
+ real stpcrt;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSTEIN computes the eigenvectors of a real symmetric tridiagonal */
+/* matrix T corresponding to specified eigenvalues, using inverse */
+/* iteration. */
+
+/* The maximum number of iterations allowed for each eigenvector is */
+/* specified by an internal parameter MAXITS (currently set to 5). */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix T. */
+
+/* E (input) REAL array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the tridiagonal matrix */
+/* T, in elements 1 to N-1. */
+
+/* M (input) INTEGER */
+/* The number of eigenvectors to be found. 0 <= M <= N. */
+
+/* W (input) REAL array, dimension (N) */
+/* The first M elements of W contain the eigenvalues for */
+/* which eigenvectors are to be computed. The eigenvalues */
+/* should be grouped by split-off block and ordered from */
+/* smallest to largest within the block. ( The output array */
+/* W from SSTEBZ with ORDER = 'B' is expected here. ) */
+
+/* IBLOCK (input) INTEGER array, dimension (N) */
+/* The submatrix indices associated with the corresponding */
+/* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to */
+/* the first submatrix from the top, =2 if W(i) belongs to */
+/* the second submatrix, etc. ( The output array IBLOCK */
+/* from SSTEBZ is expected here. ) */
+
+/* ISPLIT (input) INTEGER array, dimension (N) */
+/* The splitting points, at which T breaks up into submatrices. */
+/* The first submatrix consists of rows/columns 1 to */
+/* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 */
+/* through ISPLIT( 2 ), etc. */
+/* ( The output array ISPLIT from SSTEBZ is expected here. ) */
+
+/* Z (output) REAL array, dimension (LDZ, M) */
+/* The computed eigenvectors. The eigenvector associated */
+/* with the eigenvalue W(i) is stored in the i-th column of */
+/* Z. Any vector which fails to converge is set to its current */
+/* iterate after MAXITS iterations. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (5*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* IFAIL (output) INTEGER array, dimension (M) */
+/* On normal exit, all elements of IFAIL are zero. */
+/* If one or more eigenvectors fail to converge after */
+/* MAXITS iterations, then their indices are stored in */
+/* array IFAIL. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, then i eigenvectors failed to converge */
+/* in MAXITS iterations. Their indices are stored in */
+/* array IFAIL. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* MAXITS INTEGER, default = 5 */
+/* The maximum number of iterations performed. */
+
+/* EXTRA INTEGER, default = 2 */
+/* The number of iterations performed after norm growth */
+/* criterion is satisfied, should be at least 1. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --w;
+ --iblock;
+ --isplit;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ *info = 0;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ifail[i__] = 0;
+/* L10: */
+ }
+
+ if (*n < 0) {
+ *info = -1;
+ } else if (*m < 0 || *m > *n) {
+ *info = -4;
+ } else if (*ldz < max(1,*n)) {
+ *info = -9;
+ } else {
+ i__1 = *m;
+ for (j = 2; j <= i__1; ++j) {
+ if (iblock[j] < iblock[j - 1]) {
+ *info = -6;
+ goto L30;
+ }
+ if (iblock[j] == iblock[j - 1] && w[j] < w[j - 1]) {
+ *info = -5;
+ goto L30;
+ }
+/* L20: */
+ }
+L30:
+ ;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSTEIN", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *m == 0) {
+ return 0;
+ } else if (*n == 1) {
+ z__[z_dim1 + 1] = 1.f;
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ eps = slamch_("Precision");
+
+/* Initialize seed for random number generator SLARNV. */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = 1;
+/* L40: */
+ }
+
+/* Initialize pointers. */
+
+ indrv1 = 0;
+ indrv2 = indrv1 + *n;
+ indrv3 = indrv2 + *n;
+ indrv4 = indrv3 + *n;
+ indrv5 = indrv4 + *n;
+
+/* Compute eigenvectors of matrix blocks. */
+
+ j1 = 1;
+ i__1 = iblock[*m];
+ for (nblk = 1; nblk <= i__1; ++nblk) {
+
+/* Find starting and ending indices of block nblk. */
+
+ if (nblk == 1) {
+ b1 = 1;
+ } else {
+ b1 = isplit[nblk - 1] + 1;
+ }
+ bn = isplit[nblk];
+ blksiz = bn - b1 + 1;
+ if (blksiz == 1) {
+ goto L60;
+ }
+ gpind = b1;
+
+/* Compute reorthogonalization criterion and stopping criterion. */
+
+ onenrm = (r__1 = d__[b1], dabs(r__1)) + (r__2 = e[b1], dabs(r__2));
+/* Computing MAX */
+ r__3 = onenrm, r__4 = (r__1 = d__[bn], dabs(r__1)) + (r__2 = e[bn - 1]
+ , dabs(r__2));
+ onenrm = dmax(r__3,r__4);
+ i__2 = bn - 1;
+ for (i__ = b1 + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__4 = onenrm, r__5 = (r__1 = d__[i__], dabs(r__1)) + (r__2 = e[
+ i__ - 1], dabs(r__2)) + (r__3 = e[i__], dabs(r__3));
+ onenrm = dmax(r__4,r__5);
+/* L50: */
+ }
+ ortol = onenrm * .001f;
+
+ stpcrt = sqrt(.1f / blksiz);
+
+/* Loop through eigenvalues of block nblk. */
+
+L60:
+ jblk = 0;
+ i__2 = *m;
+ for (j = j1; j <= i__2; ++j) {
+ if (iblock[j] != nblk) {
+ j1 = j;
+ goto L160;
+ }
+ ++jblk;
+ xj = w[j];
+
+/* Skip all the work if the block size is one. */
+
+ if (blksiz == 1) {
+ work[indrv1 + 1] = 1.f;
+ goto L120;
+ }
+
+/* If eigenvalues j and j-1 are too close, add a relatively */
+/* small perturbation. */
+
+ if (jblk > 1) {
+ eps1 = (r__1 = eps * xj, dabs(r__1));
+ pertol = eps1 * 10.f;
+ sep = xj - xjm;
+ if (sep < pertol) {
+ xj = xjm + pertol;
+ }
+ }
+
+ its = 0;
+ nrmchk = 0;
+
+/* Get random starting vector. */
+
+ slarnv_(&c__2, iseed, &blksiz, &work[indrv1 + 1]);
+
+/* Copy the matrix T so it won't be destroyed in factorization. */
+
+ scopy_(&blksiz, &d__[b1], &c__1, &work[indrv4 + 1], &c__1);
+ i__3 = blksiz - 1;
+ scopy_(&i__3, &e[b1], &c__1, &work[indrv2 + 2], &c__1);
+ i__3 = blksiz - 1;
+ scopy_(&i__3, &e[b1], &c__1, &work[indrv3 + 1], &c__1);
+
+/* Compute LU factors with partial pivoting ( PT = LU ) */
+
+ tol = 0.f;
+ slagtf_(&blksiz, &work[indrv4 + 1], &xj, &work[indrv2 + 2], &work[
+ indrv3 + 1], &tol, &work[indrv5 + 1], &iwork[1], &iinfo);
+
+/* Update iteration count. */
+
+L70:
+ ++its;
+ if (its > 5) {
+ goto L100;
+ }
+
+/* Normalize and scale the righthand side vector Pb. */
+
+/* Computing MAX */
+ r__2 = eps, r__3 = (r__1 = work[indrv4 + blksiz], dabs(r__1));
+ scl = blksiz * onenrm * dmax(r__2,r__3) / sasum_(&blksiz, &work[
+ indrv1 + 1], &c__1);
+ sscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1);
+
+/* Solve the system LU = Pb. */
+
+ slagts_(&c_n1, &blksiz, &work[indrv4 + 1], &work[indrv2 + 2], &
+ work[indrv3 + 1], &work[indrv5 + 1], &iwork[1], &work[
+ indrv1 + 1], &tol, &iinfo);
+
+/* Reorthogonalize by modified Gram-Schmidt if eigenvalues are */
+/* close enough. */
+
+ if (jblk == 1) {
+ goto L90;
+ }
+ if ((r__1 = xj - xjm, dabs(r__1)) > ortol) {
+ gpind = j;
+ }
+ if (gpind != j) {
+ i__3 = j - 1;
+ for (i__ = gpind; i__ <= i__3; ++i__) {
+ ctr = -sdot_(&blksiz, &work[indrv1 + 1], &c__1, &z__[b1 +
+ i__ * z_dim1], &c__1);
+ saxpy_(&blksiz, &ctr, &z__[b1 + i__ * z_dim1], &c__1, &
+ work[indrv1 + 1], &c__1);
+/* L80: */
+ }
+ }
+
+/* Check the infinity norm of the iterate. */
+
+L90:
+ jmax = isamax_(&blksiz, &work[indrv1 + 1], &c__1);
+ nrm = (r__1 = work[indrv1 + jmax], dabs(r__1));
+
+/* Continue for additional iterations after norm reaches */
+/* stopping criterion. */
+
+ if (nrm < stpcrt) {
+ goto L70;
+ }
+ ++nrmchk;
+ if (nrmchk < 3) {
+ goto L70;
+ }
+
+ goto L110;
+
+/* If stopping criterion was not satisfied, update info and */
+/* store eigenvector number in array ifail. */
+
+L100:
+ ++(*info);
+ ifail[*info] = j;
+
+/* Accept iterate as jth eigenvector. */
+
+L110:
+ scl = 1.f / snrm2_(&blksiz, &work[indrv1 + 1], &c__1);
+ jmax = isamax_(&blksiz, &work[indrv1 + 1], &c__1);
+ if (work[indrv1 + jmax] < 0.f) {
+ scl = -scl;
+ }
+ sscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1);
+L120:
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ z__[i__ + j * z_dim1] = 0.f;
+/* L130: */
+ }
+ i__3 = blksiz;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ z__[b1 + i__ - 1 + j * z_dim1] = work[indrv1 + i__];
+/* L140: */
+ }
+
+/* Save the shift to check eigenvalue spacing at next */
+/* iteration. */
+
+ xjm = xj;
+
+/* L150: */
+ }
+L160:
+ ;
+ }
+
+ return 0;
+
+/* End of SSTEIN */
+
+} /* sstein_ */
diff --git a/SRC/sstemr.c b/SRC/sstemr.c
new file mode 100644
index 0000000..64a646b
--- /dev/null
+++ b/SRC/sstemr.c
@@ -0,0 +1,726 @@
+/* sstemr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b18 = .003f;
+
+/* Subroutine */ int sstemr_(char *jobz, char *range, integer *n, real *d__,
+ real *e, real *vl, real *vu, integer *il, integer *iu, integer *m,
+ real *w, real *z__, integer *ldz, integer *nzc, integer *isuppz,
+ logical *tryrac, real *work, integer *lwork, integer *iwork, integer *
+ liwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ real r1, r2;
+ integer jj;
+ real cs;
+ integer in;
+ real sn, wl, wu;
+ integer iil, iiu;
+ real eps, tmp;
+ integer indd, iend, jblk, wend;
+ real rmin, rmax;
+ integer itmp;
+ real tnrm;
+ integer inde2;
+ extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *)
+ ;
+ integer itmp2;
+ real rtol1, rtol2, scale;
+ integer indgp;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ integer iindw, ilast, lwmin;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), sswap_(integer *, real *, integer *, real *, integer *
+);
+ logical wantz;
+ extern /* Subroutine */ int slaev2_(real *, real *, real *, real *, real *
+, real *, real *);
+ logical alleig;
+ integer ibegin;
+ logical indeig;
+ integer iindbl;
+ logical valeig;
+ extern doublereal slamch_(char *);
+ integer wbegin;
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ integer inderr, iindwk, indgrs, offset;
+ extern /* Subroutine */ int slarrc_(char *, integer *, real *, real *,
+ real *, real *, real *, integer *, integer *, integer *, integer *
+), slarre_(char *, integer *, real *, real *, integer *,
+ integer *, real *, real *, real *, real *, real *, real *,
+ integer *, integer *, integer *, real *, real *, real *, integer *
+, integer *, real *, real *, real *, integer *, integer *)
+ ;
+ real thresh;
+ integer iinspl, indwrk, ifirst, liwmin, nzcmin;
+ real pivmin;
+ extern doublereal slanst_(char *, integer *, real *, real *);
+ extern /* Subroutine */ int slarrj_(integer *, real *, real *, integer *,
+ integer *, real *, integer *, real *, real *, real *, integer *,
+ real *, real *, integer *), slarrr_(integer *, real *, real *,
+ integer *);
+ integer nsplit;
+ extern /* Subroutine */ int slarrv_(integer *, real *, real *, real *,
+ real *, real *, integer *, integer *, integer *, integer *, real *
+, real *, real *, real *, real *, real *, integer *, integer *,
+ real *, real *, integer *, integer *, real *, integer *, integer *
+);
+ real smlnum;
+ extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *);
+ logical lquery, zquery;
+
+
+/* -- LAPACK computational routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSTEMR computes selected eigenvalues and, optionally, eigenvectors */
+/* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */
+/* a well defined set of pairwise different real eigenvalues, the corresponding */
+/* real eigenvectors are pairwise orthogonal. */
+
+/* The spectrum may be computed either completely or partially by specifying */
+/* either an interval (VL,VU] or a range of indices IL:IU for the desired */
+/* eigenvalues. */
+
+/* Depending on the number of desired eigenvalues, these are computed either */
+/* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are */
+/* computed by the use of various suitable L D L^T factorizations near clusters */
+/* of close eigenvalues (referred to as RRRs, Relatively Robust */
+/* Representations). An informal sketch of the algorithm follows. */
+
+/* For each unreduced block (submatrix) of T, */
+/* (a) Compute T - sigma I = L D L^T, so that L and D */
+/* define all the wanted eigenvalues to high relative accuracy. */
+/* This means that small relative changes in the entries of D and L */
+/* cause only small relative changes in the eigenvalues and */
+/* eigenvectors. The standard (unfactored) representation of the */
+/* tridiagonal matrix T does not have this property in general. */
+/* (b) Compute the eigenvalues to suitable accuracy. */
+/* If the eigenvectors are desired, the algorithm attains full */
+/* accuracy of the computed eigenvalues only right before */
+/* the corresponding vectors have to be computed, see steps c) and d). */
+/* (c) For each cluster of close eigenvalues, select a new */
+/* shift close to the cluster, find a new factorization, and refine */
+/* the shifted eigenvalues to suitable accuracy. */
+/* (d) For each eigenvalue with a large enough relative separation compute */
+/* the corresponding eigenvector by forming a rank revealing twisted */
+/* factorization. Go back to (c) for any clusters that remain. */
+
+/* For more details, see: */
+/* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */
+/* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */
+/* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */
+/* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */
+/* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */
+/* 2004. Also LAPACK Working Note 154. */
+/* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */
+/* tridiagonal eigenvalue/eigenvector problem", */
+/* Computer Science Division Technical Report No. UCB/CSD-97-971, */
+/* UC Berkeley, May 1997. */
+
+/* Notes: */
+/* 1.SSTEMR works only on machines which follow IEEE-754 */
+/* floating-point standard in their handling of infinities and NaNs. */
+/* This permits the use of efficient inner loops avoiding a check for */
+/* zero divisors. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the N diagonal elements of the tridiagonal matrix */
+/* T. On exit, D is overwritten. */
+
+/* E (input/output) REAL array, dimension (N) */
+/* On entry, the (N-1) subdiagonal elements of the tridiagonal */
+/* matrix T in elements 1 to N-1 of E. E(N) need not be set on */
+/* input, but is used internally as workspace. */
+/* On exit, E is overwritten. */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* The first M elements contain the selected eigenvalues in */
+/* ascending order. */
+
+/* Z (output) REAL array, dimension (LDZ, max(1,M) ) */
+/* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix T */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and can be computed with a workspace */
+/* query by setting NZC = -1, see below. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', then LDZ >= max(1,N). */
+
+/* NZC (input) INTEGER */
+/* The number of eigenvectors to be held in the array Z. */
+/* If RANGE = 'A', then NZC >= max(1,N). */
+/* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU]. */
+/* If RANGE = 'I', then NZC >= IU-IL+1. */
+/* If NZC = -1, then a workspace query is assumed; the */
+/* routine calculates the number of columns of the array Z that */
+/* are needed to hold the eigenvectors. */
+/* This value is returned as the first entry of the Z array, and */
+/* no error message related to NZC is issued by XERBLA. */
+
+/* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) ) */
+/* The support of the eigenvectors in Z, i.e., the indices */
+/* indicating the nonzero elements in Z. The i-th computed eigenvector */
+/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */
+/* ISUPPZ( 2*i ). This is relevant in the case when the matrix */
+/* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */
+
+/* TRYRAC (input/output) LOGICAL */
+/* If TRYRAC.EQ..TRUE., indicates that the code should check whether */
+/* the tridiagonal matrix defines its eigenvalues to high relative */
+/* accuracy. If so, the code uses relative-accuracy preserving */
+/* algorithms that might be (a bit) slower depending on the matrix. */
+/* If the matrix does not define its eigenvalues to high relative */
+/* accuracy, the code can uses possibly faster algorithms. */
+/* If TRYRAC.EQ..FALSE., the code is not required to guarantee */
+/* relatively accurate eigenvalues and can use the fastest possible */
+/* techniques. */
+/* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix */
+/* does not define its eigenvalues to high relative accuracy. */
+
+/* WORK (workspace/output) REAL array, dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal */
+/* (and minimal) LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,18*N) */
+/* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'. */
+/* 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. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (LIWORK) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. LIWORK >= max(1,10*N) */
+/* if the eigenvectors are desired, and LIWORK >= max(1,8*N) */
+/* if only the eigenvalues are to be computed. */
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal size of the IWORK array, */
+/* returns this value as the first entry of the IWORK array, and */
+/* no error message related to LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* On exit, INFO */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = 1X, internal error in SLARRE, */
+/* if INFO = 2X, internal error in SLARRV. */
+/* Here, the digit X = ABS( IINFO ) < 10, where IINFO is */
+/* the nonzero error code returned by SLARRE or */
+/* SLARRV, respectively. */
+
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --isuppz;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ lquery = *lwork == -1 || *liwork == -1;
+ zquery = *nzc == -1;
+/* SSTEMR needs WORK of size 6*N, IWORK of size 3*N. */
+/* In addition, SLARRE needs WORK of size 6*N, IWORK of size 5*N. */
+/* Furthermore, SLARRV needs WORK of size 12*N, IWORK of size 7*N. */
+ if (wantz) {
+ lwmin = *n * 18;
+ liwmin = *n * 10;
+ } else {
+/* need less workspace if only the eigenvalues are wanted */
+ lwmin = *n * 12;
+ liwmin = *n << 3;
+ }
+ wl = 0.f;
+ wu = 0.f;
+ iil = 0;
+ iiu = 0;
+ if (valeig) {
+/* We do not reference VL, VU in the cases RANGE = 'I','A' */
+/* The interval (WL, WU] contains all the wanted eigenvalues. */
+/* It is either given by the user or computed in SLARRE. */
+ wl = *vl;
+ wu = *vu;
+ } else if (indeig) {
+/* We do not reference IL, IU in the cases RANGE = 'V','A' */
+ iil = *il;
+ iiu = *iu;
+ }
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (valeig && *n > 0 && wu <= wl) {
+ *info = -7;
+ } else if (indeig && (iil < 1 || iil > *n)) {
+ *info = -8;
+ } else if (indeig && (iiu < iil || iiu > *n)) {
+ *info = -9;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -13;
+ } else if (*lwork < lwmin && ! lquery) {
+ *info = -17;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -19;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
+ rmax = dmin(r__1,r__2);
+
+ if (*info == 0) {
+ work[1] = (real) lwmin;
+ iwork[1] = liwmin;
+
+ if (wantz && alleig) {
+ nzcmin = *n;
+ } else if (wantz && valeig) {
+ slarrc_("T", n, vl, vu, &d__[1], &e[1], &safmin, &nzcmin, &itmp, &
+ itmp2, info);
+ } else if (wantz && indeig) {
+ nzcmin = iiu - iil + 1;
+ } else {
+/* WANTZ .EQ. FALSE. */
+ nzcmin = 0;
+ }
+ if (zquery && *info == 0) {
+ z__[z_dim1 + 1] = (real) nzcmin;
+ } else if (*nzc < nzcmin && ! zquery) {
+ *info = -14;
+ }
+ }
+ if (*info != 0) {
+
+ i__1 = -(*info);
+ xerbla_("SSTEMR", &i__1);
+
+ return 0;
+ } else if (lquery || zquery) {
+ return 0;
+ }
+
+/* Handle N = 0, 1, and 2 cases immediately */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (alleig || indeig) {
+ *m = 1;
+ w[1] = d__[1];
+ } else {
+ if (wl < d__[1] && wu >= d__[1]) {
+ *m = 1;
+ w[1] = d__[1];
+ }
+ }
+ if (wantz && ! zquery) {
+ z__[z_dim1 + 1] = 1.f;
+ isuppz[1] = 1;
+ isuppz[2] = 1;
+ }
+ return 0;
+ }
+
+ if (*n == 2) {
+ if (! wantz) {
+ slae2_(&d__[1], &e[1], &d__[2], &r1, &r2);
+ } else if (wantz && ! zquery) {
+ slaev2_(&d__[1], &e[1], &d__[2], &r1, &r2, &cs, &sn);
+ }
+ if (alleig || valeig && r2 > wl && r2 <= wu || indeig && iil == 1) {
+ ++(*m);
+ w[*m] = r2;
+ if (wantz && ! zquery) {
+ z__[*m * z_dim1 + 1] = -sn;
+ z__[*m * z_dim1 + 2] = cs;
+/* Note: At most one of SN and CS can be zero. */
+ if (sn != 0.f) {
+ if (cs != 0.f) {
+ isuppz[(*m << 1) - 1] = 1;
+ isuppz[(*m << 1) - 1] = 2;
+ } else {
+ isuppz[(*m << 1) - 1] = 1;
+ isuppz[(*m << 1) - 1] = 1;
+ }
+ } else {
+ isuppz[(*m << 1) - 1] = 2;
+ isuppz[*m * 2] = 2;
+ }
+ }
+ }
+ if (alleig || valeig && r1 > wl && r1 <= wu || indeig && iiu == 2) {
+ ++(*m);
+ w[*m] = r1;
+ if (wantz && ! zquery) {
+ z__[*m * z_dim1 + 1] = cs;
+ z__[*m * z_dim1 + 2] = sn;
+/* Note: At most one of SN and CS can be zero. */
+ if (sn != 0.f) {
+ if (cs != 0.f) {
+ isuppz[(*m << 1) - 1] = 1;
+ isuppz[(*m << 1) - 1] = 2;
+ } else {
+ isuppz[(*m << 1) - 1] = 1;
+ isuppz[(*m << 1) - 1] = 1;
+ }
+ } else {
+ isuppz[(*m << 1) - 1] = 2;
+ isuppz[*m * 2] = 2;
+ }
+ }
+ }
+ return 0;
+ }
+/* Continue with general N */
+ indgrs = 1;
+ inderr = (*n << 1) + 1;
+ indgp = *n * 3 + 1;
+ indd = (*n << 2) + 1;
+ inde2 = *n * 5 + 1;
+ indwrk = *n * 6 + 1;
+
+ iinspl = 1;
+ iindbl = *n + 1;
+ iindw = (*n << 1) + 1;
+ iindwk = *n * 3 + 1;
+
+/* Scale matrix to allowable range, if necessary. */
+/* The allowable range is related to the PIVMIN parameter; see the */
+/* comments in SLARRD. The preference for scaling small values */
+/* up is heuristic; we expect users' matrices not to be close to the */
+/* RMAX threshold. */
+
+ scale = 1.f;
+ tnrm = slanst_("M", n, &d__[1], &e[1]);
+ if (tnrm > 0.f && tnrm < rmin) {
+ scale = rmin / tnrm;
+ } else if (tnrm > rmax) {
+ scale = rmax / tnrm;
+ }
+ if (scale != 1.f) {
+ sscal_(n, &scale, &d__[1], &c__1);
+ i__1 = *n - 1;
+ sscal_(&i__1, &scale, &e[1], &c__1);
+ tnrm *= scale;
+ if (valeig) {
+/* If eigenvalues in interval have to be found, */
+/* scale (WL, WU] accordingly */
+ wl *= scale;
+ wu *= scale;
+ }
+ }
+
+/* Compute the desired eigenvalues of the tridiagonal after splitting */
+/* into smaller subblocks if the corresponding off-diagonal elements */
+/* are small */
+/* THRESH is the splitting parameter for SLARRE */
+/* A negative THRESH forces the old splitting criterion based on the */
+/* size of the off-diagonal. A positive THRESH switches to splitting */
+/* which preserves relative accuracy. */
+
+ if (*tryrac) {
+/* Test whether the matrix warrants the more expensive relative approach. */
+ slarrr_(n, &d__[1], &e[1], &iinfo);
+ } else {
+/* The user does not care about relative accurately eigenvalues */
+ iinfo = -1;
+ }
+/* Set the splitting criterion */
+ if (iinfo == 0) {
+ thresh = eps;
+ } else {
+ thresh = -eps;
+/* relative accuracy is desired but T does not guarantee it */
+ *tryrac = FALSE_;
+ }
+
+ if (*tryrac) {
+/* Copy original diagonal, needed to guarantee relative accuracy */
+ scopy_(n, &d__[1], &c__1, &work[indd], &c__1);
+ }
+/* Store the squares of the offdiagonal values of T */
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing 2nd power */
+ r__1 = e[j];
+ work[inde2 + j - 1] = r__1 * r__1;
+/* L5: */
+ }
+/* Set the tolerance parameters for bisection */
+ if (! wantz) {
+/* SLARRE computes the eigenvalues to full precision. */
+ rtol1 = eps * 4.f;
+ rtol2 = eps * 4.f;
+ } else {
+/* SLARRE computes the eigenvalues to less than full precision. */
+/* SLARRV will refine the eigenvalue approximations, and we can */
+/* need less accurate initial bisection in SLARRE. */
+/* Note: these settings do only affect the subset case and SLARRE */
+/* Computing MAX */
+ r__1 = sqrt(eps) * .05f, r__2 = eps * 4.f;
+ rtol1 = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = sqrt(eps) * .005f, r__2 = eps * 4.f;
+ rtol2 = dmax(r__1,r__2);
+ }
+ slarre_(range, n, &wl, &wu, &iil, &iiu, &d__[1], &e[1], &work[inde2], &
+ rtol1, &rtol2, &thresh, &nsplit, &iwork[iinspl], m, &w[1], &work[
+ inderr], &work[indgp], &iwork[iindbl], &iwork[iindw], &work[
+ indgrs], &pivmin, &work[indwrk], &iwork[iindwk], &iinfo);
+ if (iinfo != 0) {
+ *info = abs(iinfo) + 10;
+ return 0;
+ }
+/* Note that if RANGE .NE. 'V', SLARRE computes bounds on the desired */
+/* part of the spectrum. All desired eigenvalues are contained in */
+/* (WL,WU] */
+ if (wantz) {
+
+/* Compute the desired eigenvectors corresponding to the computed */
+/* eigenvalues */
+
+ slarrv_(n, &wl, &wu, &d__[1], &e[1], &pivmin, &iwork[iinspl], m, &
+ c__1, m, &c_b18, &rtol1, &rtol2, &w[1], &work[inderr], &work[
+ indgp], &iwork[iindbl], &iwork[iindw], &work[indgrs], &z__[
+ z_offset], ldz, &isuppz[1], &work[indwrk], &iwork[iindwk], &
+ iinfo);
+ if (iinfo != 0) {
+ *info = abs(iinfo) + 20;
+ return 0;
+ }
+ } else {
+/* SLARRE computes eigenvalues of the (shifted) root representation */
+/* SLARRV returns the eigenvalues of the unshifted matrix. */
+/* However, if the eigenvectors are not desired by the user, we need */
+/* to apply the corresponding shifts from SLARRE to obtain the */
+/* eigenvalues of the original matrix. */
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ itmp = iwork[iindbl + j - 1];
+ w[j] += e[iwork[iinspl + itmp - 1]];
+/* L20: */
+ }
+ }
+
+ if (*tryrac) {
+/* Refine computed eigenvalues so that they are relatively accurate */
+/* with respect to the original matrix T. */
+ ibegin = 1;
+ wbegin = 1;
+ i__1 = iwork[iindbl + *m - 1];
+ for (jblk = 1; jblk <= i__1; ++jblk) {
+ iend = iwork[iinspl + jblk - 1];
+ in = iend - ibegin + 1;
+ wend = wbegin - 1;
+/* check if any eigenvalues have to be refined in this block */
+L36:
+ if (wend < *m) {
+ if (iwork[iindbl + wend] == jblk) {
+ ++wend;
+ goto L36;
+ }
+ }
+ if (wend < wbegin) {
+ ibegin = iend + 1;
+ goto L39;
+ }
+ offset = iwork[iindw + wbegin - 1] - 1;
+ ifirst = iwork[iindw + wbegin - 1];
+ ilast = iwork[iindw + wend - 1];
+ rtol2 = eps * 4.f;
+ slarrj_(&in, &work[indd + ibegin - 1], &work[inde2 + ibegin - 1],
+ &ifirst, &ilast, &rtol2, &offset, &w[wbegin], &work[
+ inderr + wbegin - 1], &work[indwrk], &iwork[iindwk], &
+ pivmin, &tnrm, &iinfo);
+ ibegin = iend + 1;
+ wbegin = wend + 1;
+L39:
+ ;
+ }
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (scale != 1.f) {
+ r__1 = 1.f / scale;
+ sscal_(m, &r__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in increasing order, then sort them, */
+/* possibly along with eigenvectors. */
+
+ if (nsplit > 1) {
+ if (! wantz) {
+ slasrt_("I", m, &w[1], &iinfo);
+ if (iinfo != 0) {
+ *info = 3;
+ return 0;
+ }
+ } else {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp) {
+ i__ = jj;
+ tmp = w[jj];
+ }
+/* L50: */
+ }
+ if (i__ != 0) {
+ w[i__] = w[j];
+ w[j] = tmp;
+ if (wantz) {
+ sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j *
+ z_dim1 + 1], &c__1);
+ itmp = isuppz[(i__ << 1) - 1];
+ isuppz[(i__ << 1) - 1] = isuppz[(j << 1) - 1];
+ isuppz[(j << 1) - 1] = itmp;
+ itmp = isuppz[i__ * 2];
+ isuppz[i__ * 2] = isuppz[j * 2];
+ isuppz[j * 2] = itmp;
+ }
+ }
+/* L60: */
+ }
+ }
+ }
+
+
+ work[1] = (real) lwmin;
+ iwork[1] = liwmin;
+ return 0;
+
+/* End of SSTEMR */
+
+} /* sstemr_ */
diff --git a/SRC/ssteqr.c b/SRC/ssteqr.c
new file mode 100644
index 0000000..a4740fe
--- /dev/null
+++ b/SRC/ssteqr.c
@@ -0,0 +1,617 @@
+/* ssteqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b9 = 0.f;
+static real c_b10 = 1.f;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int ssteqr_(char *compz, integer *n, real *d__, real *e,
+ real *z__, integer *ldz, real *work, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_sign(real *, real *);
+
+ /* Local variables */
+ real b, c__, f, g;
+ integer i__, j, k, l, m;
+ real p, r__, s;
+ integer l1, ii, mm, lm1, mm1, nm1;
+ real rt1, rt2, eps;
+ integer lsv;
+ real tst, eps2;
+ integer lend, jtot;
+ extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *)
+ ;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern /* Subroutine */ int slasr_(char *, char *, char *, integer *,
+ integer *, real *, real *, real *, integer *), sswap_(integer *, real *, integer *, real *, integer *);
+ integer lendm1, lendp1;
+ extern /* Subroutine */ int slaev2_(real *, real *, real *, real *, real *
+, real *, real *);
+ extern doublereal slapy2_(real *, real *);
+ integer iscale;
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real safmax;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *);
+ integer lendsv;
+ extern /* Subroutine */ int slartg_(real *, real *, real *, real *, real *
+), slaset_(char *, integer *, integer *, real *, real *, real *,
+ integer *);
+ real ssfmin;
+ integer nmaxit, icompz;
+ real ssfmax;
+ extern doublereal slanst_(char *, integer *, real *, real *);
+ extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSTEQR computes all eigenvalues and, optionally, eigenvectors of a */
+/* symmetric tridiagonal matrix using the implicit QL or QR method. */
+/* The eigenvectors of a full or band symmetric matrix can also be found */
+/* if SSYTRD or SSPTRD or SSBTRD has been used to reduce this matrix to */
+/* tridiagonal form. */
+
+/* Arguments */
+/* ========= */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only. */
+/* = 'V': Compute eigenvalues and eigenvectors of the original */
+/* symmetric matrix. On entry, Z must contain the */
+/* orthogonal matrix used to reduce the original matrix */
+/* to tridiagonal form. */
+/* = 'I': Compute eigenvalues and eigenvectors of the */
+/* tridiagonal matrix. Z is initialized to the identity */
+/* matrix. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the diagonal elements of the tridiagonal matrix. */
+/* On exit, if INFO = 0, the eigenvalues in ascending order. */
+
+/* E (input/output) REAL array, dimension (N-1) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix. */
+/* On exit, E has been destroyed. */
+
+/* Z (input/output) REAL array, dimension (LDZ, N) */
+/* On entry, if COMPZ = 'V', then Z contains the orthogonal */
+/* matrix used in the reduction to tridiagonal form. */
+/* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */
+/* orthonormal eigenvectors of the original symmetric matrix, */
+/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */
+/* of the symmetric tridiagonal matrix. */
+/* If COMPZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* eigenvectors are desired, then LDZ >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (max(1,2*N-2)) */
+/* If COMPZ = 'N', then WORK is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: the algorithm has failed to find all the eigenvalues in */
+/* a total of 30*N iterations; if INFO = i, then i */
+/* elements of E have not converged to zero; on exit, D */
+/* and E contain the elements of a symmetric tridiagonal */
+/* matrix which is orthogonally similar to the original */
+/* matrix. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+ if (lsame_(compz, "N")) {
+ icompz = 0;
+ } else if (lsame_(compz, "V")) {
+ icompz = 1;
+ } else if (lsame_(compz, "I")) {
+ icompz = 2;
+ } else {
+ icompz = -1;
+ }
+ if (icompz < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSTEQR", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (icompz == 2) {
+ z__[z_dim1 + 1] = 1.f;
+ }
+ return 0;
+ }
+
+/* Determine the unit roundoff and over/underflow thresholds. */
+
+ eps = slamch_("E");
+/* Computing 2nd power */
+ r__1 = eps;
+ eps2 = r__1 * r__1;
+ safmin = slamch_("S");
+ safmax = 1.f / safmin;
+ ssfmax = sqrt(safmax) / 3.f;
+ ssfmin = sqrt(safmin) / eps2;
+
+/* Compute the eigenvalues and eigenvectors of the tridiagonal */
+/* matrix. */
+
+ if (icompz == 2) {
+ slaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz);
+ }
+
+ nmaxit = *n * 30;
+ jtot = 0;
+
+/* Determine where the matrix splits and choose QL or QR iteration */
+/* for each block, according to whether top or bottom diagonal */
+/* element is smaller. */
+
+ l1 = 1;
+ nm1 = *n - 1;
+
+L10:
+ if (l1 > *n) {
+ goto L160;
+ }
+ if (l1 > 1) {
+ e[l1 - 1] = 0.f;
+ }
+ if (l1 <= nm1) {
+ i__1 = nm1;
+ for (m = l1; m <= i__1; ++m) {
+ tst = (r__1 = e[m], dabs(r__1));
+ if (tst == 0.f) {
+ goto L30;
+ }
+ if (tst <= sqrt((r__1 = d__[m], dabs(r__1))) * sqrt((r__2 = d__[m
+ + 1], dabs(r__2))) * eps) {
+ e[m] = 0.f;
+ goto L30;
+ }
+/* L20: */
+ }
+ }
+ m = *n;
+
+L30:
+ l = l1;
+ lsv = l;
+ lend = m;
+ lendsv = lend;
+ l1 = m + 1;
+ if (lend == l) {
+ goto L10;
+ }
+
+/* Scale submatrix in rows and columns L to LEND */
+
+ i__1 = lend - l + 1;
+ anorm = slanst_("I", &i__1, &d__[l], &e[l]);
+ iscale = 0;
+ if (anorm == 0.f) {
+ goto L10;
+ }
+ if (anorm > ssfmax) {
+ iscale = 1;
+ i__1 = lend - l + 1;
+ slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
+ info);
+ i__1 = lend - l;
+ slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
+ info);
+ } else if (anorm < ssfmin) {
+ iscale = 2;
+ i__1 = lend - l + 1;
+ slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
+ info);
+ i__1 = lend - l;
+ slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
+ info);
+ }
+
+/* Choose between QL and QR iteration */
+
+ if ((r__1 = d__[lend], dabs(r__1)) < (r__2 = d__[l], dabs(r__2))) {
+ lend = lsv;
+ l = lendsv;
+ }
+
+ if (lend > l) {
+
+/* QL Iteration */
+
+/* Look for small subdiagonal element. */
+
+L40:
+ if (l != lend) {
+ lendm1 = lend - 1;
+ i__1 = lendm1;
+ for (m = l; m <= i__1; ++m) {
+/* Computing 2nd power */
+ r__2 = (r__1 = e[m], dabs(r__1));
+ tst = r__2 * r__2;
+ if (tst <= eps2 * (r__1 = d__[m], dabs(r__1)) * (r__2 = d__[m
+ + 1], dabs(r__2)) + safmin) {
+ goto L60;
+ }
+/* L50: */
+ }
+ }
+
+ m = lend;
+
+L60:
+ if (m < lend) {
+ e[m] = 0.f;
+ }
+ p = d__[l];
+ if (m == l) {
+ goto L80;
+ }
+
+/* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2 */
+/* to compute its eigensystem. */
+
+ if (m == l + 1) {
+ if (icompz > 0) {
+ slaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
+ work[l] = c__;
+ work[*n - 1 + l] = s;
+ slasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], &
+ z__[l * z_dim1 + 1], ldz);
+ } else {
+ slae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
+ }
+ d__[l] = rt1;
+ d__[l + 1] = rt2;
+ e[l] = 0.f;
+ l += 2;
+ if (l <= lend) {
+ goto L40;
+ }
+ goto L140;
+ }
+
+ if (jtot == nmaxit) {
+ goto L140;
+ }
+ ++jtot;
+
+/* Form shift. */
+
+ g = (d__[l + 1] - p) / (e[l] * 2.f);
+ r__ = slapy2_(&g, &c_b10);
+ g = d__[m] - p + e[l] / (g + r_sign(&r__, &g));
+
+ s = 1.f;
+ c__ = 1.f;
+ p = 0.f;
+
+/* Inner loop */
+
+ mm1 = m - 1;
+ i__1 = l;
+ for (i__ = mm1; i__ >= i__1; --i__) {
+ f = s * e[i__];
+ b = c__ * e[i__];
+ slartg_(&g, &f, &c__, &s, &r__);
+ if (i__ != m - 1) {
+ e[i__ + 1] = r__;
+ }
+ g = d__[i__ + 1] - p;
+ r__ = (d__[i__] - g) * s + c__ * 2.f * b;
+ p = s * r__;
+ d__[i__ + 1] = g + p;
+ g = c__ * r__ - b;
+
+/* If eigenvectors are desired, then save rotations. */
+
+ if (icompz > 0) {
+ work[i__] = c__;
+ work[*n - 1 + i__] = -s;
+ }
+
+/* L70: */
+ }
+
+/* If eigenvectors are desired, then apply saved rotations. */
+
+ if (icompz > 0) {
+ mm = m - l + 1;
+ slasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l
+ * z_dim1 + 1], ldz);
+ }
+
+ d__[l] -= p;
+ e[l] = g;
+ goto L40;
+
+/* Eigenvalue found. */
+
+L80:
+ d__[l] = p;
+
+ ++l;
+ if (l <= lend) {
+ goto L40;
+ }
+ goto L140;
+
+ } else {
+
+/* QR Iteration */
+
+/* Look for small superdiagonal element. */
+
+L90:
+ if (l != lend) {
+ lendp1 = lend + 1;
+ i__1 = lendp1;
+ for (m = l; m >= i__1; --m) {
+/* Computing 2nd power */
+ r__2 = (r__1 = e[m - 1], dabs(r__1));
+ tst = r__2 * r__2;
+ if (tst <= eps2 * (r__1 = d__[m], dabs(r__1)) * (r__2 = d__[m
+ - 1], dabs(r__2)) + safmin) {
+ goto L110;
+ }
+/* L100: */
+ }
+ }
+
+ m = lend;
+
+L110:
+ if (m > lend) {
+ e[m - 1] = 0.f;
+ }
+ p = d__[l];
+ if (m == l) {
+ goto L130;
+ }
+
+/* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2 */
+/* to compute its eigensystem. */
+
+ if (m == l - 1) {
+ if (icompz > 0) {
+ slaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s)
+ ;
+ work[m] = c__;
+ work[*n - 1 + m] = s;
+ slasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], &
+ z__[(l - 1) * z_dim1 + 1], ldz);
+ } else {
+ slae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
+ }
+ d__[l - 1] = rt1;
+ d__[l] = rt2;
+ e[l - 1] = 0.f;
+ l += -2;
+ if (l >= lend) {
+ goto L90;
+ }
+ goto L140;
+ }
+
+ if (jtot == nmaxit) {
+ goto L140;
+ }
+ ++jtot;
+
+/* Form shift. */
+
+ g = (d__[l - 1] - p) / (e[l - 1] * 2.f);
+ r__ = slapy2_(&g, &c_b10);
+ g = d__[m] - p + e[l - 1] / (g + r_sign(&r__, &g));
+
+ s = 1.f;
+ c__ = 1.f;
+ p = 0.f;
+
+/* Inner loop */
+
+ lm1 = l - 1;
+ i__1 = lm1;
+ for (i__ = m; i__ <= i__1; ++i__) {
+ f = s * e[i__];
+ b = c__ * e[i__];
+ slartg_(&g, &f, &c__, &s, &r__);
+ if (i__ != m) {
+ e[i__ - 1] = r__;
+ }
+ g = d__[i__] - p;
+ r__ = (d__[i__ + 1] - g) * s + c__ * 2.f * b;
+ p = s * r__;
+ d__[i__] = g + p;
+ g = c__ * r__ - b;
+
+/* If eigenvectors are desired, then save rotations. */
+
+ if (icompz > 0) {
+ work[i__] = c__;
+ work[*n - 1 + i__] = s;
+ }
+
+/* L120: */
+ }
+
+/* If eigenvectors are desired, then apply saved rotations. */
+
+ if (icompz > 0) {
+ mm = l - m + 1;
+ slasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m
+ * z_dim1 + 1], ldz);
+ }
+
+ d__[l] -= p;
+ e[lm1] = g;
+ goto L90;
+
+/* Eigenvalue found. */
+
+L130:
+ d__[l] = p;
+
+ --l;
+ if (l >= lend) {
+ goto L90;
+ }
+ goto L140;
+
+ }
+
+/* Undo scaling if necessary */
+
+L140:
+ if (iscale == 1) {
+ i__1 = lendsv - lsv + 1;
+ slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
+ n, info);
+ i__1 = lendsv - lsv;
+ slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n,
+ info);
+ } else if (iscale == 2) {
+ i__1 = lendsv - lsv + 1;
+ slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
+ n, info);
+ i__1 = lendsv - lsv;
+ slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n,
+ info);
+ }
+
+/* Check for no convergence to an eigenvalue after a total */
+/* of N*MAXIT iterations. */
+
+ if (jtot < nmaxit) {
+ goto L10;
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (e[i__] != 0.f) {
+ ++(*info);
+ }
+/* L150: */
+ }
+ goto L190;
+
+/* Order eigenvalues and eigenvectors. */
+
+L160:
+ if (icompz == 0) {
+
+/* Use Quick Sort */
+
+ slasrt_("I", n, &d__[1], info);
+
+ } else {
+
+/* Use Selection Sort to minimize swaps of eigenvectors */
+
+ i__1 = *n;
+ for (ii = 2; ii <= i__1; ++ii) {
+ i__ = ii - 1;
+ k = i__;
+ p = d__[i__];
+ i__2 = *n;
+ for (j = ii; j <= i__2; ++j) {
+ if (d__[j] < p) {
+ k = j;
+ p = d__[j];
+ }
+/* L170: */
+ }
+ if (k != i__) {
+ d__[k] = d__[i__];
+ d__[i__] = p;
+ sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1],
+ &c__1);
+ }
+/* L180: */
+ }
+ }
+
+L190:
+ return 0;
+
+/* End of SSTEQR */
+
+} /* ssteqr_ */
diff --git a/SRC/ssterf.c b/SRC/ssterf.c
new file mode 100644
index 0000000..653dce0
--- /dev/null
+++ b/SRC/ssterf.c
@@ -0,0 +1,460 @@
+/* ssterf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c__1 = 1;
+static real c_b32 = 1.f;
+
+/* Subroutine */ int ssterf_(integer *n, real *d__, real *e, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_sign(real *, real *);
+
+ /* Local variables */
+ real c__;
+ integer i__, l, m;
+ real p, r__, s;
+ integer l1;
+ real bb, rt1, rt2, eps, rte;
+ integer lsv;
+ real eps2, oldc;
+ integer lend, jtot;
+ extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *)
+ ;
+ real gamma, alpha, sigma, anorm;
+ extern doublereal slapy2_(real *, real *);
+ integer iscale;
+ real oldgam;
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real safmax;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *);
+ integer lendsv;
+ real ssfmin;
+ integer nmaxit;
+ real ssfmax;
+ extern doublereal slanst_(char *, integer *, real *, real *);
+ extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSTERF computes all eigenvalues of a symmetric tridiagonal matrix */
+/* using the Pal-Walker-Kahan variant of the QL or QR algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the n diagonal elements of the tridiagonal matrix. */
+/* On exit, if INFO = 0, the eigenvalues in ascending order. */
+
+/* E (input/output) REAL array, dimension (N-1) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix. */
+/* On exit, E has been destroyed. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: the algorithm failed to find all of the eigenvalues in */
+/* a total of 30*N iterations; if INFO = i, then i */
+/* elements of E have not converged to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --e;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n < 0) {
+ *info = -1;
+ i__1 = -(*info);
+ xerbla_("SSTERF", &i__1);
+ return 0;
+ }
+ if (*n <= 1) {
+ return 0;
+ }
+
+/* Determine the unit roundoff for this environment. */
+
+ eps = slamch_("E");
+/* Computing 2nd power */
+ r__1 = eps;
+ eps2 = r__1 * r__1;
+ safmin = slamch_("S");
+ safmax = 1.f / safmin;
+ ssfmax = sqrt(safmax) / 3.f;
+ ssfmin = sqrt(safmin) / eps2;
+
+/* Compute the eigenvalues of the tridiagonal matrix. */
+
+ nmaxit = *n * 30;
+ sigma = 0.f;
+ jtot = 0;
+
+/* Determine where the matrix splits and choose QL or QR iteration */
+/* for each block, according to whether top or bottom diagonal */
+/* element is smaller. */
+
+ l1 = 1;
+
+L10:
+ if (l1 > *n) {
+ goto L170;
+ }
+ if (l1 > 1) {
+ e[l1 - 1] = 0.f;
+ }
+ i__1 = *n - 1;
+ for (m = l1; m <= i__1; ++m) {
+ if ((r__3 = e[m], dabs(r__3)) <= sqrt((r__1 = d__[m], dabs(r__1))) *
+ sqrt((r__2 = d__[m + 1], dabs(r__2))) * eps) {
+ e[m] = 0.f;
+ goto L30;
+ }
+/* L20: */
+ }
+ m = *n;
+
+L30:
+ l = l1;
+ lsv = l;
+ lend = m;
+ lendsv = lend;
+ l1 = m + 1;
+ if (lend == l) {
+ goto L10;
+ }
+
+/* Scale submatrix in rows and columns L to LEND */
+
+ i__1 = lend - l + 1;
+ anorm = slanst_("I", &i__1, &d__[l], &e[l]);
+ iscale = 0;
+ if (anorm > ssfmax) {
+ iscale = 1;
+ i__1 = lend - l + 1;
+ slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
+ info);
+ i__1 = lend - l;
+ slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
+ info);
+ } else if (anorm < ssfmin) {
+ iscale = 2;
+ i__1 = lend - l + 1;
+ slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
+ info);
+ i__1 = lend - l;
+ slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
+ info);
+ }
+
+ i__1 = lend - 1;
+ for (i__ = l; i__ <= i__1; ++i__) {
+/* Computing 2nd power */
+ r__1 = e[i__];
+ e[i__] = r__1 * r__1;
+/* L40: */
+ }
+
+/* Choose between QL and QR iteration */
+
+ if ((r__1 = d__[lend], dabs(r__1)) < (r__2 = d__[l], dabs(r__2))) {
+ lend = lsv;
+ l = lendsv;
+ }
+
+ if (lend >= l) {
+
+/* QL Iteration */
+
+/* Look for small subdiagonal element. */
+
+L50:
+ if (l != lend) {
+ i__1 = lend - 1;
+ for (m = l; m <= i__1; ++m) {
+ if ((r__2 = e[m], dabs(r__2)) <= eps2 * (r__1 = d__[m] * d__[
+ m + 1], dabs(r__1))) {
+ goto L70;
+ }
+/* L60: */
+ }
+ }
+ m = lend;
+
+L70:
+ if (m < lend) {
+ e[m] = 0.f;
+ }
+ p = d__[l];
+ if (m == l) {
+ goto L90;
+ }
+
+/* If remaining matrix is 2 by 2, use SLAE2 to compute its */
+/* eigenvalues. */
+
+ if (m == l + 1) {
+ rte = sqrt(e[l]);
+ slae2_(&d__[l], &rte, &d__[l + 1], &rt1, &rt2);
+ d__[l] = rt1;
+ d__[l + 1] = rt2;
+ e[l] = 0.f;
+ l += 2;
+ if (l <= lend) {
+ goto L50;
+ }
+ goto L150;
+ }
+
+ if (jtot == nmaxit) {
+ goto L150;
+ }
+ ++jtot;
+
+/* Form shift. */
+
+ rte = sqrt(e[l]);
+ sigma = (d__[l + 1] - p) / (rte * 2.f);
+ r__ = slapy2_(&sigma, &c_b32);
+ sigma = p - rte / (sigma + r_sign(&r__, &sigma));
+
+ c__ = 1.f;
+ s = 0.f;
+ gamma = d__[m] - sigma;
+ p = gamma * gamma;
+
+/* Inner loop */
+
+ i__1 = l;
+ for (i__ = m - 1; i__ >= i__1; --i__) {
+ bb = e[i__];
+ r__ = p + bb;
+ if (i__ != m - 1) {
+ e[i__ + 1] = s * r__;
+ }
+ oldc = c__;
+ c__ = p / r__;
+ s = bb / r__;
+ oldgam = gamma;
+ alpha = d__[i__];
+ gamma = c__ * (alpha - sigma) - s * oldgam;
+ d__[i__ + 1] = oldgam + (alpha - gamma);
+ if (c__ != 0.f) {
+ p = gamma * gamma / c__;
+ } else {
+ p = oldc * bb;
+ }
+/* L80: */
+ }
+
+ e[l] = s * p;
+ d__[l] = sigma + gamma;
+ goto L50;
+
+/* Eigenvalue found. */
+
+L90:
+ d__[l] = p;
+
+ ++l;
+ if (l <= lend) {
+ goto L50;
+ }
+ goto L150;
+
+ } else {
+
+/* QR Iteration */
+
+/* Look for small superdiagonal element. */
+
+L100:
+ i__1 = lend + 1;
+ for (m = l; m >= i__1; --m) {
+ if ((r__2 = e[m - 1], dabs(r__2)) <= eps2 * (r__1 = d__[m] * d__[
+ m - 1], dabs(r__1))) {
+ goto L120;
+ }
+/* L110: */
+ }
+ m = lend;
+
+L120:
+ if (m > lend) {
+ e[m - 1] = 0.f;
+ }
+ p = d__[l];
+ if (m == l) {
+ goto L140;
+ }
+
+/* If remaining matrix is 2 by 2, use SLAE2 to compute its */
+/* eigenvalues. */
+
+ if (m == l - 1) {
+ rte = sqrt(e[l - 1]);
+ slae2_(&d__[l], &rte, &d__[l - 1], &rt1, &rt2);
+ d__[l] = rt1;
+ d__[l - 1] = rt2;
+ e[l - 1] = 0.f;
+ l += -2;
+ if (l >= lend) {
+ goto L100;
+ }
+ goto L150;
+ }
+
+ if (jtot == nmaxit) {
+ goto L150;
+ }
+ ++jtot;
+
+/* Form shift. */
+
+ rte = sqrt(e[l - 1]);
+ sigma = (d__[l - 1] - p) / (rte * 2.f);
+ r__ = slapy2_(&sigma, &c_b32);
+ sigma = p - rte / (sigma + r_sign(&r__, &sigma));
+
+ c__ = 1.f;
+ s = 0.f;
+ gamma = d__[m] - sigma;
+ p = gamma * gamma;
+
+/* Inner loop */
+
+ i__1 = l - 1;
+ for (i__ = m; i__ <= i__1; ++i__) {
+ bb = e[i__];
+ r__ = p + bb;
+ if (i__ != m) {
+ e[i__ - 1] = s * r__;
+ }
+ oldc = c__;
+ c__ = p / r__;
+ s = bb / r__;
+ oldgam = gamma;
+ alpha = d__[i__ + 1];
+ gamma = c__ * (alpha - sigma) - s * oldgam;
+ d__[i__] = oldgam + (alpha - gamma);
+ if (c__ != 0.f) {
+ p = gamma * gamma / c__;
+ } else {
+ p = oldc * bb;
+ }
+/* L130: */
+ }
+
+ e[l - 1] = s * p;
+ d__[l] = sigma + gamma;
+ goto L100;
+
+/* Eigenvalue found. */
+
+L140:
+ d__[l] = p;
+
+ --l;
+ if (l >= lend) {
+ goto L100;
+ }
+ goto L150;
+
+ }
+
+/* Undo scaling if necessary */
+
+L150:
+ if (iscale == 1) {
+ i__1 = lendsv - lsv + 1;
+ slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
+ n, info);
+ }
+ if (iscale == 2) {
+ i__1 = lendsv - lsv + 1;
+ slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
+ n, info);
+ }
+
+/* Check for no convergence to an eigenvalue after a total */
+/* of N*MAXIT iterations. */
+
+ if (jtot < nmaxit) {
+ goto L10;
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (e[i__] != 0.f) {
+ ++(*info);
+ }
+/* L160: */
+ }
+ goto L180;
+
+/* Sort eigenvalues in increasing order. */
+
+L170:
+ slasrt_("I", n, &d__[1], info);
+
+L180:
+ return 0;
+
+/* End of SSTERF */
+
+} /* ssterf_ */
diff --git a/SRC/sstev.c b/SRC/sstev.c
new file mode 100644
index 0000000..5fe9ab2
--- /dev/null
+++ b/SRC/sstev.c
@@ -0,0 +1,209 @@
+/* sstev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sstev_(char *jobz, integer *n, real *d__, real *e, real *
+ z__, integer *ldz, real *work, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real eps;
+ integer imax;
+ real rmin, rmax, tnrm, sigma;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ logical wantz;
+ integer iscale;
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ extern doublereal slanst_(char *, integer *, real *, real *);
+ extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
+ real smlnum;
+ extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *,
+ real *, integer *, real *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSTEV computes all eigenvalues and, optionally, eigenvectors of a */
+/* real symmetric tridiagonal matrix A. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the n diagonal elements of the tridiagonal matrix */
+/* A. */
+/* On exit, if INFO = 0, the eigenvalues in ascending order. */
+
+/* E (input/output) REAL array, dimension (N-1) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix A, stored in elements 1 to N-1 of E. */
+/* On exit, the contents of E are destroyed. */
+
+/* Z (output) REAL array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
+/* eigenvectors of the matrix A, with the i-th column of Z */
+/* holding the eigenvector associated with D(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (max(1,2*N-2)) */
+/* If JOBZ = 'N', WORK is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of E did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -6;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSTEV ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.f;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ tnrm = slanst_("M", n, &d__[1], &e[1]);
+ if (tnrm > 0.f && tnrm < rmin) {
+ iscale = 1;
+ sigma = rmin / tnrm;
+ } else if (tnrm > rmax) {
+ iscale = 1;
+ sigma = rmax / tnrm;
+ }
+ if (iscale == 1) {
+ sscal_(n, &sigma, &d__[1], &c__1);
+ i__1 = *n - 1;
+ sscal_(&i__1, &sigma, &e[1], &c__1);
+ }
+
+/* For eigenvalues only, call SSTERF. For eigenvalues and */
+/* eigenvectors, call SSTEQR. */
+
+ if (! wantz) {
+ ssterf_(n, &d__[1], &e[1], info);
+ } else {
+ ssteqr_("I", n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], info);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *n;
+ } else {
+ imax = *info - 1;
+ }
+ r__1 = 1.f / sigma;
+ sscal_(&imax, &r__1, &d__[1], &c__1);
+ }
+
+ return 0;
+
+/* End of SSTEV */
+
+} /* sstev_ */
diff --git a/SRC/sstevd.c b/SRC/sstevd.c
new file mode 100644
index 0000000..d7e6ce2
--- /dev/null
+++ b/SRC/sstevd.c
@@ -0,0 +1,270 @@
+/* sstevd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sstevd_(char *jobz, integer *n, real *d__, real *e, real
+ *z__, integer *ldz, real *work, integer *lwork, integer *iwork,
+ integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real eps, rmin, rmax, tnrm, sigma;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ integer lwmin;
+ logical wantz;
+ integer iscale;
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ extern /* Subroutine */ int sstedc_(char *, integer *, real *, real *,
+ real *, integer *, real *, integer *, integer *, integer *,
+ integer *);
+ integer liwmin;
+ extern doublereal slanst_(char *, integer *, real *, real *);
+ extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
+ real smlnum;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSTEVD computes all eigenvalues and, optionally, eigenvectors of a */
+/* real symmetric tridiagonal matrix. If eigenvectors are desired, it */
+/* uses a divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the n diagonal elements of the tridiagonal matrix */
+/* A. */
+/* On exit, if INFO = 0, the eigenvalues in ascending order. */
+
+/* E (input/output) REAL array, dimension (N-1) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix A, stored in elements 1 to N-1 of E. */
+/* On exit, the contents of E are destroyed. */
+
+/* Z (output) REAL array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
+/* eigenvectors of the matrix A, with the i-th column of Z */
+/* holding the eigenvector associated with D(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) REAL array, */
+/* dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If JOBZ = 'N' or N <= 1 then LWORK must be at least 1. */
+/* If JOBZ = 'V' and N > 1 then LWORK must be at least */
+/* ( 1 + 4*N + N**2 ). */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK and IWORK */
+/* arrays, returns these values as the first entries of the WORK */
+/* and IWORK arrays, and no error message related to LWORK or */
+/* LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If JOBZ = 'N' or N <= 1 then LIWORK must be at least 1. */
+/* If JOBZ = 'V' and N > 1 then LIWORK must be at least 3+5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK and IWORK arrays, and no error message related to */
+/* LWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of E did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ lquery = *lwork == -1 || *liwork == -1;
+
+ *info = 0;
+ liwmin = 1;
+ lwmin = 1;
+ if (*n > 1 && wantz) {
+/* Computing 2nd power */
+ i__1 = *n;
+ lwmin = (*n << 2) + 1 + i__1 * i__1;
+ liwmin = *n * 5 + 3;
+ }
+
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -6;
+ }
+
+ if (*info == 0) {
+ work[1] = (real) lwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -8;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -10;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSTEVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.f;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ tnrm = slanst_("M", n, &d__[1], &e[1]);
+ if (tnrm > 0.f && tnrm < rmin) {
+ iscale = 1;
+ sigma = rmin / tnrm;
+ } else if (tnrm > rmax) {
+ iscale = 1;
+ sigma = rmax / tnrm;
+ }
+ if (iscale == 1) {
+ sscal_(n, &sigma, &d__[1], &c__1);
+ i__1 = *n - 1;
+ sscal_(&i__1, &sigma, &e[1], &c__1);
+ }
+
+/* For eigenvalues only, call SSTERF. For eigenvalues and */
+/* eigenvectors, call SSTEDC. */
+
+ if (! wantz) {
+ ssterf_(n, &d__[1], &e[1], info);
+ } else {
+ sstedc_("I", n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], lwork,
+ &iwork[1], liwork, info);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ r__1 = 1.f / sigma;
+ sscal_(n, &r__1, &d__[1], &c__1);
+ }
+
+ work[1] = (real) lwmin;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of SSTEVD */
+
+} /* sstevd_ */
diff --git a/SRC/sstevr.c b/SRC/sstevr.c
new file mode 100644
index 0000000..279446a
--- /dev/null
+++ b/SRC/sstevr.c
@@ -0,0 +1,541 @@
+/* sstevr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__10 = 10;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__4 = 4;
+
+/* Subroutine */ int sstevr_(char *jobz, char *range, integer *n, real *d__,
+ real *e, real *vl, real *vu, integer *il, integer *iu, real *abstol,
+ integer *m, real *w, real *z__, integer *ldz, integer *isuppz, real *
+ work, integer *lwork, integer *iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, jj;
+ real eps, vll, vuu, tmp1;
+ integer imax;
+ real rmin, rmax;
+ logical test;
+ real tnrm, sigma;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ char order[1];
+ integer lwmin;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), sswap_(integer *, real *, integer *, real *, integer *
+);
+ logical wantz, alleig, indeig;
+ integer iscale, ieeeok, indibl, indifl;
+ logical valeig;
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ integer indisp, indiwo, liwmin;
+ logical tryrac;
+ extern doublereal slanst_(char *, integer *, real *, real *);
+ extern /* Subroutine */ int sstein_(integer *, real *, real *, integer *,
+ real *, integer *, integer *, real *, integer *, real *, integer *
+, integer *, integer *), ssterf_(integer *, real *, real *,
+ integer *);
+ integer nsplit;
+ extern /* Subroutine */ int sstebz_(char *, char *, integer *, real *,
+ real *, integer *, integer *, real *, real *, real *, integer *,
+ integer *, real *, integer *, integer *, real *, integer *,
+ integer *);
+ real smlnum;
+ extern /* Subroutine */ int sstemr_(char *, char *, integer *, real *,
+ real *, real *, real *, integer *, integer *, integer *, real *,
+ real *, integer *, integer *, integer *, logical *, real *,
+ integer *, integer *, integer *, integer *);
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSTEVR computes selected eigenvalues and, optionally, eigenvectors */
+/* of a real symmetric tridiagonal matrix T. Eigenvalues and */
+/* eigenvectors can be selected by specifying either a range of values */
+/* or a range of indices for the desired eigenvalues. */
+
+/* Whenever possible, SSTEVR calls SSTEMR to compute the */
+/* eigenspectrum using Relatively Robust Representations. SSTEMR */
+/* computes eigenvalues by the dqds algorithm, while orthogonal */
+/* eigenvectors are computed from various "good" L D L^T representations */
+/* (also known as Relatively Robust Representations). Gram-Schmidt */
+/* orthogonalization is avoided as far as possible. More specifically, */
+/* the various steps of the algorithm are as follows. For the i-th */
+/* unreduced block of T, */
+/* (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T */
+/* is a relatively robust representation, */
+/* (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high */
+/* relative accuracy by the dqds algorithm, */
+/* (c) If there is a cluster of close eigenvalues, "choose" sigma_i */
+/* close to the cluster, and go to step (a), */
+/* (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T, */
+/* compute the corresponding eigenvector by forming a */
+/* rank-revealing twisted factorization. */
+/* The desired accuracy of the output can be specified by the input */
+/* parameter ABSTOL. */
+
+/* For more details, see "A new O(n^2) algorithm for the symmetric */
+/* tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon, */
+/* Computer Science Division Technical Report No. UCB//CSD-97-971, */
+/* UC Berkeley, May 1997. */
+
+
+/* Note 1 : SSTEVR calls SSTEMR when the full spectrum is requested */
+/* on machines which conform to the ieee-754 floating point standard. */
+/* SSTEVR calls SSTEBZ and SSTEIN on non-ieee machines and */
+/* when partial spectrum requests are made. */
+
+/* Normal execution of SSTEMR may create NaNs and infinities and */
+/* hence may abort due to a floating point exception in environments */
+/* which do not handle NaNs and infinities in the ieee standard default */
+/* manner. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+/* ********* For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and */
+/* ********* SSTEIN are called */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the n diagonal elements of the tridiagonal matrix */
+/* A. */
+/* On exit, D may be multiplied by a constant factor chosen */
+/* to avoid over/underflow in computing the eigenvalues. */
+
+/* E (input/output) REAL array, dimension (max(1,N-1)) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix A in elements 1 to N-1 of E. */
+/* On exit, E may be multiplied by a constant factor chosen */
+/* to avoid over/underflow in computing the eigenvalues. */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) REAL */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing A to tridiagonal form. */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices */
+/* with Guaranteed High Relative Accuracy," by Demmel and */
+/* Kahan, LAPACK Working Note #3. */
+
+/* If high relative accuracy is important, set ABSTOL to */
+/* SLAMCH( 'Safe minimum' ). Doing so will guarantee that */
+/* eigenvalues are computed to high relative accuracy when */
+/* possible in future releases. The current code does not */
+/* make any guarantees about high relative accuracy, but */
+/* future releases will. See J. Barlow and J. Demmel, */
+/* "Computing Accurate Eigensystems of Scaled Diagonally */
+/* Dominant Matrices", LAPACK Working Note #7, for a discussion */
+/* of which matrices define their eigenvalues to high relative */
+/* accuracy. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* The first M elements contain the selected eigenvalues in */
+/* ascending order. */
+
+/* Z (output) REAL array, dimension (LDZ, max(1,M) ) */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */
+/* The support of the eigenvectors in Z, i.e., the indices */
+/* indicating the nonzero elements in Z. The i-th eigenvector */
+/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */
+/* ISUPPZ( 2*i ). */
+/* ********* Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal (and */
+/* minimal) LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= 20*N. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK and IWORK */
+/* arrays, returns these values as the first entries of the WORK */
+/* and IWORK arrays, and no error message related to LWORK or */
+/* LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal (and */
+/* minimal) LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. LIWORK >= 10*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK and IWORK arrays, and no error message related to */
+/* LWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: Internal error */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Inderjit Dhillon, IBM Almaden, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Ken Stanley, Computer Science Division, University of */
+/* California at Berkeley, USA */
+/* Jason Riedy, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --isuppz;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ ieeeok = ilaenv_(&c__10, "SSTEVR", "N", &c__1, &c__2, &c__3, &c__4);
+
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ lquery = *lwork == -1 || *liwork == -1;
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * 20;
+ lwmin = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * 10;
+ liwmin = max(i__1,i__2);
+
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -7;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -8;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -9;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -14;
+ }
+ }
+
+ if (*info == 0) {
+ work[1] = (real) lwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -17;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -19;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSTEVR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (alleig || indeig) {
+ *m = 1;
+ w[1] = d__[1];
+ } else {
+ if (*vl < d__[1] && *vu >= d__[1]) {
+ *m = 1;
+ w[1] = d__[1];
+ }
+ }
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.f;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
+ rmax = dmin(r__1,r__2);
+
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ vll = *vl;
+ vuu = *vu;
+
+ tnrm = slanst_("M", n, &d__[1], &e[1]);
+ if (tnrm > 0.f && tnrm < rmin) {
+ iscale = 1;
+ sigma = rmin / tnrm;
+ } else if (tnrm > rmax) {
+ iscale = 1;
+ sigma = rmax / tnrm;
+ }
+ if (iscale == 1) {
+ sscal_(n, &sigma, &d__[1], &c__1);
+ i__1 = *n - 1;
+ sscal_(&i__1, &sigma, &e[1], &c__1);
+ if (valeig) {
+ vll = *vl * sigma;
+ vuu = *vu * sigma;
+ }
+ }
+/* Initialize indices into workspaces. Note: These indices are used only */
+/* if SSTERF or SSTEMR fail. */
+/* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in SSTEBZ and */
+/* stores the block indices of each of the M<=N eigenvalues. */
+ indibl = 1;
+/* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in SSTEBZ and */
+/* stores the starting and finishing indices of each block. */
+ indisp = indibl + *n;
+/* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors */
+/* that corresponding to eigenvectors that fail to converge in */
+/* SSTEIN. This information is discarded; if any fail, the driver */
+/* returns INFO > 0. */
+ indifl = indisp + *n;
+/* INDIWO is the offset of the remaining integer workspace. */
+ indiwo = indisp + *n;
+
+/* If all eigenvalues are desired, then */
+/* call SSTERF or SSTEMR. If this fails for some eigenvalue, then */
+/* try SSTEBZ. */
+
+
+ test = FALSE_;
+ if (indeig) {
+ if (*il == 1 && *iu == *n) {
+ test = TRUE_;
+ }
+ }
+ if ((alleig || test) && ieeeok == 1) {
+ i__1 = *n - 1;
+ scopy_(&i__1, &e[1], &c__1, &work[1], &c__1);
+ if (! wantz) {
+ scopy_(n, &d__[1], &c__1, &w[1], &c__1);
+ ssterf_(n, &w[1], &work[1], info);
+ } else {
+ scopy_(n, &d__[1], &c__1, &work[*n + 1], &c__1);
+ if (*abstol <= *n * 2.f * eps) {
+ tryrac = TRUE_;
+ } else {
+ tryrac = FALSE_;
+ }
+ i__1 = *lwork - (*n << 1);
+ sstemr_(jobz, "A", n, &work[*n + 1], &work[1], vl, vu, il, iu, m,
+ &w[1], &z__[z_offset], ldz, n, &isuppz[1], &tryrac, &work[
+ (*n << 1) + 1], &i__1, &iwork[1], liwork, info);
+
+ }
+ if (*info == 0) {
+ *m = *n;
+ goto L10;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ sstebz_(range, order, n, &vll, &vuu, il, iu, abstol, &d__[1], &e[1], m, &
+ nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[1], &iwork[
+ indiwo], info);
+
+ if (wantz) {
+ sstein_(n, &d__[1], &e[1], m, &w[1], &iwork[indibl], &iwork[indisp], &
+ z__[z_offset], ldz, &work[1], &iwork[indiwo], &iwork[indifl],
+ info);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+L10:
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *m;
+ } else {
+ imax = *info - 1;
+ }
+ r__1 = 1.f / sigma;
+ sscal_(&imax, &r__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L20: */
+ }
+
+ if (i__ != 0) {
+ w[i__] = w[j];
+ w[j] = tmp1;
+ sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ }
+/* L30: */
+ }
+ }
+
+/* Causes problems with tests 19 & 20: */
+/* IF (wantz .and. INDEIG ) Z( 1,1) = Z(1,1) / 1.002 + .002 */
+
+
+ work[1] = (real) lwmin;
+ iwork[1] = liwmin;
+ return 0;
+
+/* End of SSTEVR */
+
+} /* sstevr_ */
diff --git a/SRC/sstevx.c b/SRC/sstevx.c
new file mode 100644
index 0000000..5c3df45
--- /dev/null
+++ b/SRC/sstevx.c
@@ -0,0 +1,427 @@
+/* sstevx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sstevx_(char *jobz, char *range, integer *n, real *d__,
+ real *e, real *vl, real *vu, integer *il, integer *iu, real *abstol,
+ integer *m, real *w, real *z__, integer *ldz, real *work, integer *
+ iwork, integer *ifail, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, jj;
+ real eps, vll, vuu, tmp1;
+ integer imax;
+ real rmin, rmax;
+ logical test;
+ real tnrm;
+ integer itmp1;
+ real sigma;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ char order[1];
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), sswap_(integer *, real *, integer *, real *, integer *
+);
+ logical wantz, alleig, indeig;
+ integer iscale, indibl;
+ logical valeig;
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ integer indisp, indiwo, indwrk;
+ extern doublereal slanst_(char *, integer *, real *, real *);
+ extern /* Subroutine */ int sstein_(integer *, real *, real *, integer *,
+ real *, integer *, integer *, real *, integer *, real *, integer *
+, integer *, integer *), ssterf_(integer *, real *, real *,
+ integer *);
+ integer nsplit;
+ extern /* Subroutine */ int sstebz_(char *, char *, integer *, real *,
+ real *, integer *, integer *, real *, real *, real *, integer *,
+ integer *, real *, integer *, integer *, real *, integer *,
+ integer *);
+ real smlnum;
+ extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *,
+ real *, integer *, real *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSTEVX computes selected eigenvalues and, optionally, eigenvectors */
+/* of a real symmetric tridiagonal matrix A. Eigenvalues and */
+/* eigenvectors can be selected by specifying either a range of values */
+/* or a range of indices for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) REAL array, dimension (N) */
+/* On entry, the n diagonal elements of the tridiagonal matrix */
+/* A. */
+/* On exit, D may be multiplied by a constant factor chosen */
+/* to avoid over/underflow in computing the eigenvalues. */
+
+/* E (input/output) REAL array, dimension (max(1,N-1)) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix A in elements 1 to N-1 of E. */
+/* On exit, E may be multiplied by a constant factor chosen */
+/* to avoid over/underflow in computing the eigenvalues. */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) REAL */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less */
+/* than or equal to zero, then EPS*|T| will be used in */
+/* its place, where |T| is the 1-norm of the tridiagonal */
+/* matrix. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*SLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*SLAMCH('S'). */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices */
+/* with Guaranteed High Relative Accuracy," by Demmel and */
+/* Kahan, LAPACK Working Note #3. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* The first M elements contain the selected eigenvalues in */
+/* ascending order. */
+
+/* Z (output) REAL array, dimension (LDZ, max(1,M) ) */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If an eigenvector fails to converge (INFO > 0), then that */
+/* column of Z contains the latest approximation to the */
+/* eigenvector, and the index of the eigenvector is returned */
+/* in IFAIL. If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (5*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, then i eigenvectors failed to converge. */
+/* Their indices are stored in array IFAIL. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -7;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -8;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -9;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -14;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSTEVX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (alleig || indeig) {
+ *m = 1;
+ w[1] = d__[1];
+ } else {
+ if (*vl < d__[1] && *vu >= d__[1]) {
+ *m = 1;
+ w[1] = d__[1];
+ }
+ }
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.f;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
+ rmax = dmin(r__1,r__2);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ if (valeig) {
+ vll = *vl;
+ vuu = *vu;
+ } else {
+ vll = 0.f;
+ vuu = 0.f;
+ }
+ tnrm = slanst_("M", n, &d__[1], &e[1]);
+ if (tnrm > 0.f && tnrm < rmin) {
+ iscale = 1;
+ sigma = rmin / tnrm;
+ } else if (tnrm > rmax) {
+ iscale = 1;
+ sigma = rmax / tnrm;
+ }
+ if (iscale == 1) {
+ sscal_(n, &sigma, &d__[1], &c__1);
+ i__1 = *n - 1;
+ sscal_(&i__1, &sigma, &e[1], &c__1);
+ if (valeig) {
+ vll = *vl * sigma;
+ vuu = *vu * sigma;
+ }
+ }
+
+/* If all eigenvalues are desired and ABSTOL is less than zero, then */
+/* call SSTERF or SSTEQR. If this fails for some eigenvalue, then */
+/* try SSTEBZ. */
+
+ test = FALSE_;
+ if (indeig) {
+ if (*il == 1 && *iu == *n) {
+ test = TRUE_;
+ }
+ }
+ if ((alleig || test) && *abstol <= 0.f) {
+ scopy_(n, &d__[1], &c__1, &w[1], &c__1);
+ i__1 = *n - 1;
+ scopy_(&i__1, &e[1], &c__1, &work[1], &c__1);
+ indwrk = *n + 1;
+ if (! wantz) {
+ ssterf_(n, &w[1], &work[1], info);
+ } else {
+ ssteqr_("I", n, &w[1], &work[1], &z__[z_offset], ldz, &work[
+ indwrk], info);
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ifail[i__] = 0;
+/* L10: */
+ }
+ }
+ }
+ if (*info == 0) {
+ *m = *n;
+ goto L20;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ indwrk = 1;
+ indibl = 1;
+ indisp = indibl + *n;
+ indiwo = indisp + *n;
+ sstebz_(range, order, n, &vll, &vuu, il, iu, abstol, &d__[1], &e[1], m, &
+ nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[indwrk], &
+ iwork[indiwo], info);
+
+ if (wantz) {
+ sstein_(n, &d__[1], &e[1], m, &w[1], &iwork[indibl], &iwork[indisp], &
+ z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &ifail[1],
+ info);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+L20:
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *m;
+ } else {
+ imax = *info - 1;
+ }
+ r__1 = 1.f / sigma;
+ sscal_(&imax, &r__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L30: */
+ }
+
+ if (i__ != 0) {
+ itmp1 = iwork[indibl + i__ - 1];
+ w[i__] = w[j];
+ iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
+ w[j] = tmp1;
+ iwork[indibl + j - 1] = itmp1;
+ sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ if (*info != 0) {
+ itmp1 = ifail[i__];
+ ifail[i__] = ifail[j];
+ ifail[j] = itmp1;
+ }
+ }
+/* L40: */
+ }
+ }
+
+ return 0;
+
+/* End of SSTEVX */
+
+} /* sstevx_ */
diff --git a/SRC/ssycon.c b/SRC/ssycon.c
new file mode 100644
index 0000000..e553108
--- /dev/null
+++ b/SRC/ssycon.c
@@ -0,0 +1,202 @@
+/* ssycon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ssycon_(char *uplo, integer *n, real *a, integer *lda,
+ integer *ipiv, real *anorm, real *rcond, real *work, integer *iwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+
+ /* Local variables */
+ integer i__, kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *,
+ real *, integer *, integer *), xerbla_(char *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int ssytrs_(char *, integer *, integer *, real *,
+ integer *, integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYCON estimates the reciprocal of the condition number (in the */
+/* 1-norm) of a real symmetric matrix A using the factorization */
+/* A = U*D*U**T or A = L*D*L**T computed by SSYTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by SSYTRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by SSYTRF. */
+
+/* ANORM (input) REAL */
+/* The 1-norm of the original matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) REAL array, dimension (2*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*anorm < 0.f) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSYCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.f;
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ } else if (*anorm <= 0.f) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ for (i__ = *n; i__ >= 1; --i__) {
+ if (ipiv[i__] > 0 && a[i__ + i__ * a_dim1] == 0.f) {
+ return 0;
+ }
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (ipiv[i__] > 0 && a[i__ + i__ * a_dim1] == 0.f) {
+ return 0;
+ }
+/* L20: */
+ }
+ }
+
+/* Estimate the 1-norm of the inverse. */
+
+ kase = 0;
+L30:
+ slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+
+/* Multiply by inv(L*D*L') or inv(U*D*U'). */
+
+ ssytrs_(uplo, n, &c__1, &a[a_offset], lda, &ipiv[1], &work[1], n,
+ info);
+ goto L30;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / ainvnm / *anorm;
+ }
+
+ return 0;
+
+/* End of SSYCON */
+
+} /* ssycon_ */
diff --git a/SRC/ssyequb.c b/SRC/ssyequb.c
new file mode 100644
index 0000000..0ed411f
--- /dev/null
+++ b/SRC/ssyequb.c
@@ -0,0 +1,334 @@
+/* ssyequb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ssyequb_(char *uplo, integer *n, real *a, integer *lda,
+ real *s, real *scond, real *amax, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal), log(doublereal), pow_ri(real *, integer *);
+
+ /* Local variables */
+ real d__;
+ integer i__, j;
+ real t, u, c0, c1, c2, si;
+ logical up;
+ real avg, std, tol, base;
+ integer iter;
+ real smin, smax, scale;
+ extern logical lsame_(char *, char *);
+ real sumsq;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
+ real *);
+ real smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYEQUB computes row and column scalings intended to equilibrate a */
+/* symmetric matrix A and reduce its condition number */
+/* (with respect to the two-norm). S contains the scale factors, */
+/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
+/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
+/* choice of S puts the condition number of B within a factor N of the */
+/* smallest possible condition number over all possible diagonal */
+/* scalings. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The N-by-N symmetric matrix whose scaling */
+/* factors are to be computed. Only the diagonal elements of A */
+/* are referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* S (output) REAL array, dimension (N) */
+/* If INFO = 0, S contains the scale factors for A. */
+
+/* SCOND (output) REAL */
+/* If INFO = 0, S contains the ratio of the smallest S(i) to */
+/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
+/* large nor too small, it is not worth scaling by S. */
+
+/* AMAX (output) REAL */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
+
+/* Further Details */
+/* ======= ======= */
+
+/* Reference: Livne, O.E. and Golub, G.H., "Scaling by Binormalization", */
+/* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. */
+/* DOI 10.1023/B:NUMA.0000016606.32820.69 */
+/* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (! (lsame_(uplo, "U") || lsame_(uplo, "L"))) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSYEQUB", &i__1);
+ return 0;
+ }
+ up = lsame_(uplo, "U");
+ *amax = 0.f;
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ *scond = 1.f;
+ return 0;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s[i__] = 0.f;
+ }
+ *amax = 0.f;
+ if (up) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = s[i__], r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1))
+ ;
+ s[i__] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = s[j], r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ s[j] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = *amax, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ *amax = dmax(r__2,r__3);
+ }
+/* Computing MAX */
+ r__2 = s[j], r__3 = (r__1 = a[j + j * a_dim1], dabs(r__1));
+ s[j] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = *amax, r__3 = (r__1 = a[j + j * a_dim1], dabs(r__1));
+ *amax = dmax(r__2,r__3);
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ r__2 = s[j], r__3 = (r__1 = a[j + j * a_dim1], dabs(r__1));
+ s[j] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = *amax, r__3 = (r__1 = a[j + j * a_dim1], dabs(r__1));
+ *amax = dmax(r__2,r__3);
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = s[i__], r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1))
+ ;
+ s[i__] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = s[j], r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ s[j] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = *amax, r__3 = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ *amax = dmax(r__2,r__3);
+ }
+ }
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ s[j] = 1.f / s[j];
+ }
+ tol = 1.f / sqrt(*n * 2.f);
+ for (iter = 1; iter <= 100; ++iter) {
+ scale = 0.f;
+ sumsq = 0.f;
+/* BETA = |A|S */
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+ }
+ if (up) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ t = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * s[
+ j];
+ work[j] += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * s[
+ i__];
+ }
+ work[j] += (r__1 = a[j + j * a_dim1], dabs(r__1)) * s[j];
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[j] += (r__1 = a[j + j * a_dim1], dabs(r__1)) * s[j];
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ t = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ work[i__] += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * s[
+ j];
+ work[j] += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * s[
+ i__];
+ }
+ }
+ }
+/* avg = s^T beta / n */
+ avg = 0.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ avg += s[i__] * work[i__];
+ }
+ avg /= *n;
+ std = 0.f;
+ i__1 = *n * 3;
+ for (i__ = (*n << 1) + 1; i__ <= i__1; ++i__) {
+ work[i__] = s[i__ - (*n << 1)] * work[i__ - (*n << 1)] - avg;
+ }
+ slassq_(n, &work[(*n << 1) + 1], &c__1, &scale, &sumsq);
+ std = scale * sqrt(sumsq / *n);
+ if (std < tol * avg) {
+ goto L999;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ t = (r__1 = a[i__ + i__ * a_dim1], dabs(r__1));
+ si = s[i__];
+ c2 = (*n - 1) * t;
+ c1 = (*n - 2) * (work[i__] - t * si);
+ c0 = -(t * si) * si + work[i__] * 2 * si - *n * avg;
+ d__ = c1 * c1 - c0 * 4 * c2;
+ if (d__ <= 0.f) {
+ *info = -1;
+ return 0;
+ }
+ si = c0 * -2 / (c1 + sqrt(d__));
+ d__ = si - s[i__];
+ u = 0.f;
+ if (up) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ t = (r__1 = a[j + i__ * a_dim1], dabs(r__1));
+ u += s[j] * t;
+ work[j] += d__ * t;
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ t = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ u += s[j] * t;
+ work[j] += d__ * t;
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ t = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
+ u += s[j] * t;
+ work[j] += d__ * t;
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ t = (r__1 = a[j + i__ * a_dim1], dabs(r__1));
+ u += s[j] * t;
+ work[j] += d__ * t;
+ }
+ }
+ avg += (u + work[i__]) * d__ / *n;
+ s[i__] = si;
+ }
+ }
+L999:
+ smlnum = slamch_("SAFEMIN");
+ bignum = 1.f / smlnum;
+ smin = bignum;
+ smax = 0.f;
+ t = 1.f / sqrt(avg);
+ base = slamch_("B");
+ u = 1.f / log(base);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = (integer) (u * log(s[i__] * t));
+ s[i__] = pow_ri(&base, &i__2);
+/* Computing MIN */
+ r__1 = smin, r__2 = s[i__];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = smax, r__2 = s[i__];
+ smax = dmax(r__1,r__2);
+ }
+ *scond = dmax(smin,smlnum) / dmin(smax,bignum);
+
+ return 0;
+} /* ssyequb_ */
diff --git a/SRC/ssyev.c b/SRC/ssyev.c
new file mode 100644
index 0000000..49319d0
--- /dev/null
+++ b/SRC/ssyev.c
@@ -0,0 +1,276 @@
+/* ssyev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static real c_b17 = 1.f;
+
+/* Subroutine */ int ssyev_(char *jobz, char *uplo, integer *n, real *a,
+ integer *lda, real *w, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer nb;
+ real eps;
+ integer inde;
+ real anrm;
+ integer imax;
+ real rmin, rmax, sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ logical lower, wantz;
+ integer iscale;
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *);
+ integer indtau, indwrk;
+ extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+ integer llwork;
+ real smlnum;
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int sorgtr_(char *, integer *, real *, integer *,
+ real *, real *, integer *, integer *), ssteqr_(char *,
+ integer *, real *, real *, real *, integer *, real *, integer *), ssytrd_(char *, integer *, real *, integer *, real *,
+ real *, real *, real *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYEV computes all eigenvalues and, optionally, eigenvectors of a */
+/* real symmetric matrix A. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (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. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
+/* orthonormal eigenvectors of the matrix A. */
+/* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') */
+/* or the upper triangle (if UPLO='U') of A, including the */
+/* diagonal, is destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(1,3*N-1). */
+/* For optimal efficiency, LWORK >= (NB+2)*N, */
+/* where NB is the blocksize for SSYTRD 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of an intermediate tridiagonal */
+/* form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ --work;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ lower = lsame_(uplo, "L");
+ lquery = *lwork == -1;
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+
+ if (*info == 0) {
+ nb = ilaenv_(&c__1, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = 1, i__2 = (nb + 2) * *n;
+ lwkopt = max(i__1,i__2);
+ work[1] = (real) lwkopt;
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * 3 - 1;
+ if (*lwork < max(i__1,i__2) && ! lquery) {
+ *info = -8;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSYEV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ w[1] = a[a_dim1 + 1];
+ work[1] = 2.f;
+ if (wantz) {
+ a[a_dim1 + 1] = 1.f;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = slansy_("M", uplo, n, &a[a_offset], lda, &work[1]);
+ iscale = 0;
+ if (anrm > 0.f && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ slascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda,
+ info);
+ }
+
+/* Call SSYTRD to reduce symmetric matrix to tridiagonal form. */
+
+ inde = 1;
+ indtau = inde + *n;
+ indwrk = indtau + *n;
+ llwork = *lwork - indwrk + 1;
+ ssytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], &
+ work[indwrk], &llwork, &iinfo);
+
+/* For eigenvalues only, call SSTERF. For eigenvectors, first call */
+/* SORGTR to generate the orthogonal matrix, then call SSTEQR. */
+
+ if (! wantz) {
+ ssterf_(n, &w[1], &work[inde], info);
+ } else {
+ sorgtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], &
+ llwork, &iinfo);
+ ssteqr_(jobz, n, &w[1], &work[inde], &a[a_offset], lda, &work[indtau],
+ info);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *n;
+ } else {
+ imax = *info - 1;
+ }
+ r__1 = 1.f / sigma;
+ sscal_(&imax, &r__1, &w[1], &c__1);
+ }
+
+/* Set WORK(1) to optimal workspace size. */
+
+ work[1] = (real) lwkopt;
+
+ return 0;
+
+/* End of SSYEV */
+
+} /* ssyev_ */
diff --git a/SRC/ssyevd.c b/SRC/ssyevd.c
new file mode 100644
index 0000000..430de7d
--- /dev/null
+++ b/SRC/ssyevd.c
@@ -0,0 +1,344 @@
+/* ssyevd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static real c_b17 = 1.f;
+
+/* Subroutine */ int ssyevd_(char *jobz, char *uplo, integer *n, real *a,
+ integer *lda, real *w, real *work, integer *lwork, integer *iwork,
+ integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real eps;
+ integer inde;
+ real anrm, rmin, rmax;
+ integer lopt;
+ real sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ integer lwmin, liopt;
+ logical lower, wantz;
+ integer indwk2, llwrk2, iscale;
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *);
+ integer indtau;
+ extern /* Subroutine */ int sstedc_(char *, integer *, real *, real *,
+ real *, integer *, real *, integer *, integer *, integer *,
+ integer *), slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+ integer indwrk, liwmin;
+ extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+ integer llwork;
+ real smlnum;
+ logical lquery;
+ extern /* Subroutine */ int sormtr_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *), ssytrd_(char *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYEVD computes all eigenvalues and, optionally, eigenvectors of a */
+/* real symmetric matrix A. If eigenvectors are desired, it uses a */
+/* divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Because of large use of BLAS of level 3, SSYEVD needs N**2 more */
+/* workspace than SSYEVX. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (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. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
+/* orthonormal eigenvectors of the matrix A. */
+/* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') */
+/* or the upper triangle (if UPLO='U') of A, including the */
+/* diagonal, is destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* WORK (workspace/output) REAL array, */
+/* dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If N <= 1, LWORK must be at least 1. */
+/* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1. */
+/* If JOBZ = 'V' and N > 1, LWORK must be at least */
+/* 1 + 6*N + 2*N**2. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK and IWORK */
+/* arrays, returns these values as the first entries of the WORK */
+/* and IWORK arrays, and no error message related to LWORK or */
+/* LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If N <= 1, LIWORK must be at least 1. */
+/* If JOBZ = 'N' and N > 1, LIWORK must be at least 1. */
+/* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK and IWORK arrays, and no error message related to */
+/* LWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed */
+/* to converge; i off-diagonal elements of an intermediate */
+/* tridiagonal form did not converge to zero; */
+/* if INFO = i and JOBZ = 'V', then the algorithm failed */
+/* to compute an eigenvalue while working on the submatrix */
+/* lying in rows and columns INFO/(N+1) through */
+/* mod(INFO,N+1). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+/* Modified by Francoise Tisseur, University of Tennessee. */
+
+/* Modified description of INFO. Sven, 16 Feb 05. */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ lower = lsame_(uplo, "L");
+ lquery = *lwork == -1 || *liwork == -1;
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+
+ if (*info == 0) {
+ if (*n <= 1) {
+ liwmin = 1;
+ lwmin = 1;
+ lopt = lwmin;
+ liopt = liwmin;
+ } else {
+ if (wantz) {
+ liwmin = *n * 5 + 3;
+/* Computing 2nd power */
+ i__1 = *n;
+ lwmin = *n * 6 + 1 + (i__1 * i__1 << 1);
+ } else {
+ liwmin = 1;
+ lwmin = (*n << 1) + 1;
+ }
+/* Computing MAX */
+ i__1 = lwmin, i__2 = (*n << 1) + ilaenv_(&c__1, "SSYTRD", uplo, n,
+ &c_n1, &c_n1, &c_n1);
+ lopt = max(i__1,i__2);
+ liopt = liwmin;
+ }
+ work[1] = (real) lopt;
+ iwork[1] = liopt;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -8;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -10;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSYEVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ w[1] = a[a_dim1 + 1];
+ if (wantz) {
+ a[a_dim1 + 1] = 1.f;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = slansy_("M", uplo, n, &a[a_offset], lda, &work[1]);
+ iscale = 0;
+ if (anrm > 0.f && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ slascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda,
+ info);
+ }
+
+/* Call SSYTRD to reduce symmetric matrix to tridiagonal form. */
+
+ inde = 1;
+ indtau = inde + *n;
+ indwrk = indtau + *n;
+ llwork = *lwork - indwrk + 1;
+ indwk2 = indwrk + *n * *n;
+ llwrk2 = *lwork - indwk2 + 1;
+
+ ssytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], &
+ work[indwrk], &llwork, &iinfo);
+
+/* For eigenvalues only, call SSTERF. For eigenvectors, first call */
+/* SSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the */
+/* tridiagonal matrix, then call SORMTR to multiply it by the */
+/* Householder transformations stored in A. */
+
+ if (! wantz) {
+ ssterf_(n, &w[1], &work[inde], info);
+ } else {
+ sstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], &
+ llwrk2, &iwork[1], liwork, info);
+ sormtr_("L", uplo, "N", n, n, &a[a_offset], lda, &work[indtau], &work[
+ indwrk], n, &work[indwk2], &llwrk2, &iinfo);
+ slacpy_("A", n, n, &work[indwrk], n, &a[a_offset], lda);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ r__1 = 1.f / sigma;
+ sscal_(n, &r__1, &w[1], &c__1);
+ }
+
+ work[1] = (real) lopt;
+ iwork[1] = liopt;
+
+ return 0;
+
+/* End of SSYEVD */
+
+} /* ssyevd_ */
diff --git a/SRC/ssyevr.c b/SRC/ssyevr.c
new file mode 100644
index 0000000..af26cb0
--- /dev/null
+++ b/SRC/ssyevr.c
@@ -0,0 +1,658 @@
+/* ssyevr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__10 = 10;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static integer c_n1 = -1;
+
+/* Subroutine */ int ssyevr_(char *jobz, char *range, char *uplo, integer *n,
+ real *a, integer *lda, real *vl, real *vu, integer *il, integer *iu,
+ real *abstol, integer *m, real *w, real *z__, integer *ldz, integer *
+ isuppz, real *work, integer *lwork, integer *iwork, integer *liwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, nb, jj;
+ real eps, vll, vuu, tmp1;
+ integer indd, inde;
+ real anrm;
+ integer imax;
+ real rmin, rmax;
+ logical test;
+ integer inddd, indee;
+ real sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ char order[1];
+ integer indwk, lwmin;
+ logical lower;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), sswap_(integer *, real *, integer *, real *, integer *
+);
+ logical wantz, alleig, indeig;
+ integer iscale, ieeeok, indibl, indifl;
+ logical valeig;
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real abstll, bignum;
+ integer indtau, indisp, indiwo, indwkn, liwmin;
+ logical tryrac;
+ extern /* Subroutine */ int sstein_(integer *, real *, real *, integer *,
+ real *, integer *, integer *, real *, integer *, real *, integer *
+, integer *, integer *), ssterf_(integer *, real *, real *,
+ integer *);
+ integer llwrkn, llwork, nsplit;
+ real smlnum;
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+ extern /* Subroutine */ int sstebz_(char *, char *, integer *, real *,
+ real *, integer *, integer *, real *, real *, real *, integer *,
+ integer *, real *, integer *, integer *, real *, integer *,
+ integer *), sstemr_(char *, char *, integer *,
+ real *, real *, real *, real *, integer *, integer *, integer *,
+ real *, real *, integer *, integer *, integer *, logical *, real *
+, integer *, integer *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int sormtr_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *), ssytrd_(char *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYEVR computes selected eigenvalues and, optionally, eigenvectors */
+/* of a real symmetric matrix A. Eigenvalues and eigenvectors can be */
+/* selected by specifying either a range of values or a range of */
+/* indices for the desired eigenvalues. */
+
+/* SSYEVR first reduces the matrix A to tridiagonal form T with a call */
+/* to SSYTRD. Then, whenever possible, SSYEVR calls SSTEMR to compute */
+/* the eigenspectrum using Relatively Robust Representations. SSTEMR */
+/* computes eigenvalues by the dqds algorithm, while orthogonal */
+/* eigenvectors are computed from various "good" L D L^T representations */
+/* (also known as Relatively Robust Representations). Gram-Schmidt */
+/* orthogonalization is avoided as far as possible. More specifically, */
+/* the various steps of the algorithm are as follows. */
+
+/* For each unreduced block (submatrix) of T, */
+/* (a) Compute T - sigma I = L D L^T, so that L and D */
+/* define all the wanted eigenvalues to high relative accuracy. */
+/* This means that small relative changes in the entries of D and L */
+/* cause only small relative changes in the eigenvalues and */
+/* eigenvectors. The standard (unfactored) representation of the */
+/* tridiagonal matrix T does not have this property in general. */
+/* (b) Compute the eigenvalues to suitable accuracy. */
+/* If the eigenvectors are desired, the algorithm attains full */
+/* accuracy of the computed eigenvalues only right before */
+/* the corresponding vectors have to be computed, see steps c) and d). */
+/* (c) For each cluster of close eigenvalues, select a new */
+/* shift close to the cluster, find a new factorization, and refine */
+/* the shifted eigenvalues to suitable accuracy. */
+/* (d) For each eigenvalue with a large enough relative separation compute */
+/* the corresponding eigenvector by forming a rank revealing twisted */
+/* factorization. Go back to (c) for any clusters that remain. */
+
+/* The desired accuracy of the output can be specified by the input */
+/* parameter ABSTOL. */
+
+/* For more details, see SSTEMR's documentation and: */
+/* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */
+/* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */
+/* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */
+/* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */
+/* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */
+/* 2004. Also LAPACK Working Note 154. */
+/* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */
+/* tridiagonal eigenvalue/eigenvector problem", */
+/* Computer Science Division Technical Report No. UCB/CSD-97-971, */
+/* UC Berkeley, May 1997. */
+
+
+/* Note 1 : SSYEVR calls SSTEMR when the full spectrum is requested */
+/* on machines which conform to the ieee-754 floating point standard. */
+/* SSYEVR calls SSTEBZ and SSTEIN on non-ieee machines and */
+/* when partial spectrum requests are made. */
+
+/* Normal execution of SSTEMR may create NaNs and infinities and */
+/* hence may abort due to a floating point exception in environments */
+/* which do not handle NaNs and infinities in the ieee standard default */
+/* manner. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+/* ********* For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and */
+/* ********* SSTEIN are called */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (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. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+/* On exit, the lower triangle (if UPLO='L') or the upper */
+/* triangle (if UPLO='U') of A, including the diagonal, is */
+/* destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) REAL */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing A to tridiagonal form. */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices */
+/* with Guaranteed High Relative Accuracy," by Demmel and */
+/* Kahan, LAPACK Working Note #3. */
+
+/* If high relative accuracy is important, set ABSTOL to */
+/* SLAMCH( 'Safe minimum' ). Doing so will guarantee that */
+/* eigenvalues are computed to high relative accuracy when */
+/* possible in future releases. The current code does not */
+/* make any guarantees about high relative accuracy, but */
+/* future releases will. See J. Barlow and J. Demmel, */
+/* "Computing Accurate Eigensystems of Scaled Diagonally */
+/* Dominant Matrices", LAPACK Working Note #7, for a discussion */
+/* of which matrices define their eigenvalues to high relative */
+/* accuracy. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* The first M elements contain the selected eigenvalues in */
+/* ascending order. */
+
+/* Z (output) REAL array, dimension (LDZ, max(1,M)) */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+/* Supplying N columns is always safe. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */
+/* The support of the eigenvectors in Z, i.e., the indices */
+/* indicating the nonzero elements in Z. The i-th eigenvector */
+/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */
+/* ISUPPZ( 2*i ). */
+/* ********* Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,26*N). */
+/* For optimal efficiency, LWORK >= (NB+6)*N, */
+/* where NB is the max of the blocksize for SSYTRD and SORMTR */
+/* returned by ILAENV. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK and IWORK */
+/* arrays, returns these values as the first entries of the WORK */
+/* and IWORK arrays, and no error message related to LWORK or */
+/* LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. LIWORK >= max(1,10*N). */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK and IWORK arrays, and no error message related to */
+/* LWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: Internal error */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Inderjit Dhillon, IBM Almaden, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Ken Stanley, Computer Science Division, University of */
+/* California at Berkeley, USA */
+/* Jason Riedy, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --isuppz;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ ieeeok = ilaenv_(&c__10, "SSYEVR", "N", &c__1, &c__2, &c__3, &c__4);
+
+ lower = lsame_(uplo, "L");
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ lquery = *lwork == -1 || *liwork == -1;
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * 26;
+ lwmin = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * 10;
+ liwmin = max(i__1,i__2);
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -8;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -9;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -10;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -15;
+ }
+ }
+
+ if (*info == 0) {
+ nb = ilaenv_(&c__1, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "SORMTR", uplo, n, &c_n1, &c_n1, &
+ c_n1);
+ nb = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = (nb + 1) * *n;
+ lwkopt = max(i__1,lwmin);
+ work[1] = (real) lwkopt;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -18;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -20;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSYEVR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ work[1] = 1.f;
+ return 0;
+ }
+
+ if (*n == 1) {
+ work[1] = 26.f;
+ if (alleig || indeig) {
+ *m = 1;
+ w[1] = a[a_dim1 + 1];
+ } else {
+ if (*vl < a[a_dim1 + 1] && *vu >= a[a_dim1 + 1]) {
+ *m = 1;
+ w[1] = a[a_dim1 + 1];
+ }
+ }
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.f;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
+ rmax = dmin(r__1,r__2);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ abstll = *abstol;
+ if (valeig) {
+ vll = *vl;
+ vuu = *vu;
+ }
+ anrm = slansy_("M", uplo, n, &a[a_offset], lda, &work[1]);
+ if (anrm > 0.f && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ if (lower) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ sscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+ if (*abstol > 0.f) {
+ abstll = *abstol * sigma;
+ }
+ if (valeig) {
+ vll = *vl * sigma;
+ vuu = *vu * sigma;
+ }
+ }
+/* Initialize indices into workspaces. Note: The IWORK indices are */
+/* used only if SSTERF or SSTEMR fail. */
+/* WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the */
+/* elementary reflectors used in SSYTRD. */
+ indtau = 1;
+/* WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries. */
+ indd = indtau + *n;
+/* WORK(INDE:INDE+N-1) stores the off-diagonal entries of the */
+/* tridiagonal matrix from SSYTRD. */
+ inde = indd + *n;
+/* WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over */
+/* -written by SSTEMR (the SSTERF path copies the diagonal to W). */
+ inddd = inde + *n;
+/* WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over */
+/* -written while computing the eigenvalues in SSTERF and SSTEMR. */
+ indee = inddd + *n;
+/* INDWK is the starting offset of the left-over workspace, and */
+/* LLWORK is the remaining workspace size. */
+ indwk = indee + *n;
+ llwork = *lwork - indwk + 1;
+/* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in SSTEBZ and */
+/* stores the block indices of each of the M<=N eigenvalues. */
+ indibl = 1;
+/* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in SSTEBZ and */
+/* stores the starting and finishing indices of each block. */
+ indisp = indibl + *n;
+/* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors */
+/* that corresponding to eigenvectors that fail to converge in */
+/* SSTEIN. This information is discarded; if any fail, the driver */
+/* returns INFO > 0. */
+ indifl = indisp + *n;
+/* INDIWO is the offset of the remaining integer workspace. */
+ indiwo = indisp + *n;
+
+/* Call SSYTRD to reduce symmetric matrix to tridiagonal form. */
+
+ ssytrd_(uplo, n, &a[a_offset], lda, &work[indd], &work[inde], &work[
+ indtau], &work[indwk], &llwork, &iinfo);
+
+/* If all eigenvalues are desired */
+/* then call SSTERF or SSTEMR and SORMTR. */
+
+ test = FALSE_;
+ if (indeig) {
+ if (*il == 1 && *iu == *n) {
+ test = TRUE_;
+ }
+ }
+ if ((alleig || test) && ieeeok == 1) {
+ if (! wantz) {
+ scopy_(n, &work[indd], &c__1, &w[1], &c__1);
+ i__1 = *n - 1;
+ scopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
+ ssterf_(n, &w[1], &work[indee], info);
+ } else {
+ i__1 = *n - 1;
+ scopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
+ scopy_(n, &work[indd], &c__1, &work[inddd], &c__1);
+
+ if (*abstol <= *n * 2.f * eps) {
+ tryrac = TRUE_;
+ } else {
+ tryrac = FALSE_;
+ }
+ sstemr_(jobz, "A", n, &work[inddd], &work[indee], vl, vu, il, iu,
+ m, &w[1], &z__[z_offset], ldz, n, &isuppz[1], &tryrac, &
+ work[indwk], lwork, &iwork[1], liwork, info);
+
+
+
+/* Apply orthogonal matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by SSTEIN. */
+
+ if (wantz && *info == 0) {
+ indwkn = inde;
+ llwrkn = *lwork - indwkn + 1;
+ sormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau]
+, &z__[z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
+ }
+ }
+
+
+ if (*info == 0) {
+/* Everything worked. Skip SSTEBZ/SSTEIN. IWORK(:) are */
+/* undefined. */
+ *m = *n;
+ goto L30;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN. */
+/* Also call SSTEBZ and SSTEIN if SSTEMR fails. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[
+ inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[
+ indwk], &iwork[indiwo], info);
+
+ if (wantz) {
+ sstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
+ indisp], &z__[z_offset], ldz, &work[indwk], &iwork[indiwo], &
+ iwork[indifl], info);
+
+/* Apply orthogonal matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by SSTEIN. */
+
+ indwkn = inde;
+ llwrkn = *lwork - indwkn + 1;
+ sormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[
+ z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+/* Jump here if SSTEMR/SSTEIN succeeded. */
+L30:
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *m;
+ } else {
+ imax = *info - 1;
+ }
+ r__1 = 1.f / sigma;
+ sscal_(&imax, &r__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. Note: We do not sort the IFAIL portion of IWORK. */
+/* It may not be initialized (if SSTEMR/SSTEIN succeeded), and we do */
+/* not return this detailed information to the user. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L40: */
+ }
+
+ if (i__ != 0) {
+ w[i__] = w[j];
+ w[j] = tmp1;
+ sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ }
+/* L50: */
+ }
+ }
+
+/* Set WORK(1) to optimal workspace size. */
+
+ work[1] = (real) lwkopt;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of SSYEVR */
+
+} /* ssyevr_ */
diff --git a/SRC/ssyevx.c b/SRC/ssyevx.c
new file mode 100644
index 0000000..8b6679c
--- /dev/null
+++ b/SRC/ssyevx.c
@@ -0,0 +1,531 @@
+/* ssyevx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int ssyevx_(char *jobz, char *range, char *uplo, integer *n,
+ real *a, integer *lda, real *vl, real *vu, integer *il, integer *iu,
+ real *abstol, integer *m, real *w, real *z__, integer *ldz, real *
+ work, integer *lwork, integer *iwork, integer *ifail, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, nb, jj;
+ real eps, vll, vuu, tmp1;
+ integer indd, inde;
+ real anrm;
+ integer imax;
+ real rmin, rmax;
+ logical test;
+ integer itmp1, indee;
+ real sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ char order[1];
+ logical lower;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), sswap_(integer *, real *, integer *, real *, integer *
+);
+ logical wantz, alleig, indeig;
+ integer iscale, indibl;
+ logical valeig;
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real abstll, bignum;
+ integer indtau, indisp, indiwo, indwkn;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+ integer indwrk, lwkmin;
+ extern /* Subroutine */ int sstein_(integer *, real *, real *, integer *,
+ real *, integer *, integer *, real *, integer *, real *, integer *
+, integer *, integer *), ssterf_(integer *, real *, real *,
+ integer *);
+ integer llwrkn, llwork, nsplit;
+ real smlnum;
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+ extern /* Subroutine */ int sstebz_(char *, char *, integer *, real *,
+ real *, integer *, integer *, real *, real *, real *, integer *,
+ integer *, real *, integer *, integer *, real *, integer *,
+ integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int sorgtr_(char *, integer *, real *, integer *,
+ real *, real *, integer *, integer *), ssteqr_(char *,
+ integer *, real *, real *, real *, integer *, real *, integer *), sormtr_(char *, char *, char *, integer *, integer *,
+ real *, integer *, real *, real *, integer *, real *, integer *,
+ integer *), ssytrd_(char *, integer *,
+ real *, integer *, real *, real *, real *, real *, integer *,
+ integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYEVX computes selected eigenvalues and, optionally, eigenvectors */
+/* of a real symmetric matrix A. Eigenvalues and eigenvectors can be */
+/* selected by specifying either a range of values or a range of indices */
+/* for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (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. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+/* On exit, the lower triangle (if UPLO='L') or the upper */
+/* triangle (if UPLO='U') of A, including the diagonal, is */
+/* destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) REAL */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing A to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*SLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*SLAMCH('S'). */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices */
+/* with Guaranteed High Relative Accuracy," by Demmel and */
+/* Kahan, LAPACK Working Note #3. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* On normal exit, the first M elements contain the selected */
+/* eigenvalues in ascending order. */
+
+/* Z (output) REAL array, dimension (LDZ, max(1,M)) */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If an eigenvector fails to converge, then that column of Z */
+/* contains the latest approximation to the eigenvector, and the */
+/* index of the eigenvector is returned in IFAIL. */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= 1, when N <= 1; */
+/* otherwise 8*N. */
+/* For optimal efficiency, LWORK >= (NB+3)*N, */
+/* where NB is the max of the blocksize for SSYTRD and SORMTR */
+/* 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. */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, then i eigenvectors failed to converge. */
+/* Their indices are stored in array IFAIL. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ lower = lsame_(uplo, "L");
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+ lquery = *lwork == -1;
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -8;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -9;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -10;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -15;
+ }
+ }
+
+ if (*info == 0) {
+ if (*n <= 1) {
+ lwkmin = 1;
+ work[1] = (real) lwkmin;
+ } else {
+ lwkmin = *n << 3;
+ nb = ilaenv_(&c__1, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "SORMTR", uplo, n, &c_n1, &c_n1,
+ &c_n1);
+ nb = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = lwkmin, i__2 = (nb + 3) * *n;
+ lwkopt = max(i__1,i__2);
+ work[1] = (real) lwkopt;
+ }
+
+ if (*lwork < lwkmin && ! lquery) {
+ *info = -17;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSYEVX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (alleig || indeig) {
+ *m = 1;
+ w[1] = a[a_dim1 + 1];
+ } else {
+ if (*vl < a[a_dim1 + 1] && *vu >= a[a_dim1 + 1]) {
+ *m = 1;
+ w[1] = a[a_dim1 + 1];
+ }
+ }
+ if (wantz) {
+ z__[z_dim1 + 1] = 1.f;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1.f / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
+ rmax = dmin(r__1,r__2);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ abstll = *abstol;
+ if (valeig) {
+ vll = *vl;
+ vuu = *vu;
+ }
+ anrm = slansy_("M", uplo, n, &a[a_offset], lda, &work[1]);
+ if (anrm > 0.f && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ if (lower) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ sscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+ if (*abstol > 0.f) {
+ abstll = *abstol * sigma;
+ }
+ if (valeig) {
+ vll = *vl * sigma;
+ vuu = *vu * sigma;
+ }
+ }
+
+/* Call SSYTRD to reduce symmetric matrix to tridiagonal form. */
+
+ indtau = 1;
+ inde = indtau + *n;
+ indd = inde + *n;
+ indwrk = indd + *n;
+ llwork = *lwork - indwrk + 1;
+ ssytrd_(uplo, n, &a[a_offset], lda, &work[indd], &work[inde], &work[
+ indtau], &work[indwrk], &llwork, &iinfo);
+
+/* If all eigenvalues are desired and ABSTOL is less than or equal to */
+/* zero, then call SSTERF or SORGTR and SSTEQR. If this fails for */
+/* some eigenvalue, then try SSTEBZ. */
+
+ test = FALSE_;
+ if (indeig) {
+ if (*il == 1 && *iu == *n) {
+ test = TRUE_;
+ }
+ }
+ if ((alleig || test) && *abstol <= 0.f) {
+ scopy_(n, &work[indd], &c__1, &w[1], &c__1);
+ indee = indwrk + (*n << 1);
+ if (! wantz) {
+ i__1 = *n - 1;
+ scopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
+ ssterf_(n, &w[1], &work[indee], info);
+ } else {
+ slacpy_("A", n, n, &a[a_offset], lda, &z__[z_offset], ldz);
+ sorgtr_(uplo, n, &z__[z_offset], ldz, &work[indtau], &work[indwrk]
+, &llwork, &iinfo);
+ i__1 = *n - 1;
+ scopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
+ ssteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[
+ indwrk], info);
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ifail[i__] = 0;
+/* L30: */
+ }
+ }
+ }
+ if (*info == 0) {
+ *m = *n;
+ goto L40;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ indibl = 1;
+ indisp = indibl + *n;
+ indiwo = indisp + *n;
+ sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[
+ inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[
+ indwrk], &iwork[indiwo], info);
+
+ if (wantz) {
+ sstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
+ indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &
+ ifail[1], info);
+
+/* Apply orthogonal matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by SSTEIN. */
+
+ indwkn = inde;
+ llwrkn = *lwork - indwkn + 1;
+ sormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[
+ z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+L40:
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *m;
+ } else {
+ imax = *info - 1;
+ }
+ r__1 = 1.f / sigma;
+ sscal_(&imax, &r__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L50: */
+ }
+
+ if (i__ != 0) {
+ itmp1 = iwork[indibl + i__ - 1];
+ w[i__] = w[j];
+ iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
+ w[j] = tmp1;
+ iwork[indibl + j - 1] = itmp1;
+ sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ if (*info != 0) {
+ itmp1 = ifail[i__];
+ ifail[i__] = ifail[j];
+ ifail[j] = itmp1;
+ }
+ }
+/* L60: */
+ }
+ }
+
+/* Set WORK(1) to optimal workspace size. */
+
+ work[1] = (real) lwkopt;
+
+ return 0;
+
+/* End of SSYEVX */
+
+} /* ssyevx_ */
diff --git a/SRC/ssygs2.c b/SRC/ssygs2.c
new file mode 100644
index 0000000..bb683e1
--- /dev/null
+++ b/SRC/ssygs2.c
@@ -0,0 +1,296 @@
+/* ssygs2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b6 = -1.f;
+static integer c__1 = 1;
+static real c_b27 = 1.f;
+
+/* Subroutine */ int ssygs2_(integer *itype, char *uplo, integer *n, real *a,
+ integer *lda, real *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+ real r__1;
+
+ /* Local variables */
+ integer k;
+ real ct, akk, bkk;
+ extern /* Subroutine */ int ssyr2_(char *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ logical upper;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *), strmv_(char *, char *, char *, integer *,
+ real *, integer *, real *, integer *),
+ strsv_(char *, char *, char *, integer *, real *, integer *, real
+ *, integer *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYGS2 reduces a real symmetric-definite generalized eigenproblem */
+/* to standard form. */
+
+/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
+/* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L') */
+
+/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
+/* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L. */
+
+/* B must have been previously factorized as U'*U or L*L' by SPOTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L'); */
+/* = 2 or 3: compute U*A*U' or L'*A*L. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored, and how B has been factorized. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n by n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n by n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the transformed matrix, stored in the */
+/* same format as A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) REAL array, dimension (LDB,N) */
+/* The triangular factor from the Cholesky factorization of B, */
+/* as returned by SPOTRF. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSYGS2", &i__1);
+ return 0;
+ }
+
+ if (*itype == 1) {
+ if (upper) {
+
+/* Compute inv(U')*A*inv(U) */
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+/* Update the upper triangle of A(k:n,k:n) */
+
+ akk = a[k + k * a_dim1];
+ bkk = b[k + k * b_dim1];
+/* Computing 2nd power */
+ r__1 = bkk;
+ akk /= r__1 * r__1;
+ a[k + k * a_dim1] = akk;
+ if (k < *n) {
+ i__2 = *n - k;
+ r__1 = 1.f / bkk;
+ sscal_(&i__2, &r__1, &a[k + (k + 1) * a_dim1], lda);
+ ct = akk * -.5f;
+ i__2 = *n - k;
+ saxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
+ k + 1) * a_dim1], lda);
+ i__2 = *n - k;
+ ssyr2_(uplo, &i__2, &c_b6, &a[k + (k + 1) * a_dim1], lda,
+ &b[k + (k + 1) * b_dim1], ldb, &a[k + 1 + (k + 1)
+ * a_dim1], lda);
+ i__2 = *n - k;
+ saxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
+ k + 1) * a_dim1], lda);
+ i__2 = *n - k;
+ strsv_(uplo, "Transpose", "Non-unit", &i__2, &b[k + 1 + (
+ k + 1) * b_dim1], ldb, &a[k + (k + 1) * a_dim1],
+ lda);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Compute inv(L)*A*inv(L') */
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+/* Update the lower triangle of A(k:n,k:n) */
+
+ akk = a[k + k * a_dim1];
+ bkk = b[k + k * b_dim1];
+/* Computing 2nd power */
+ r__1 = bkk;
+ akk /= r__1 * r__1;
+ a[k + k * a_dim1] = akk;
+ if (k < *n) {
+ i__2 = *n - k;
+ r__1 = 1.f / bkk;
+ sscal_(&i__2, &r__1, &a[k + 1 + k * a_dim1], &c__1);
+ ct = akk * -.5f;
+ i__2 = *n - k;
+ saxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
+ 1 + k * a_dim1], &c__1);
+ i__2 = *n - k;
+ ssyr2_(uplo, &i__2, &c_b6, &a[k + 1 + k * a_dim1], &c__1,
+ &b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + (k + 1)
+ * a_dim1], lda);
+ i__2 = *n - k;
+ saxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
+ 1 + k * a_dim1], &c__1);
+ i__2 = *n - k;
+ strsv_(uplo, "No transpose", "Non-unit", &i__2, &b[k + 1
+ + (k + 1) * b_dim1], ldb, &a[k + 1 + k * a_dim1],
+ &c__1);
+ }
+/* L20: */
+ }
+ }
+ } else {
+ if (upper) {
+
+/* Compute U*A*U' */
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+/* Update the upper triangle of A(1:k,1:k) */
+
+ akk = a[k + k * a_dim1];
+ bkk = b[k + k * b_dim1];
+ i__2 = k - 1;
+ strmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset],
+ ldb, &a[k * a_dim1 + 1], &c__1);
+ ct = akk * .5f;
+ i__2 = k - 1;
+ saxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
+ 1], &c__1);
+ i__2 = k - 1;
+ ssyr2_(uplo, &i__2, &c_b27, &a[k * a_dim1 + 1], &c__1, &b[k *
+ b_dim1 + 1], &c__1, &a[a_offset], lda);
+ i__2 = k - 1;
+ saxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
+ 1], &c__1);
+ i__2 = k - 1;
+ sscal_(&i__2, &bkk, &a[k * a_dim1 + 1], &c__1);
+/* Computing 2nd power */
+ r__1 = bkk;
+ a[k + k * a_dim1] = akk * (r__1 * r__1);
+/* L30: */
+ }
+ } else {
+
+/* Compute L'*A*L */
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+/* Update the lower triangle of A(1:k,1:k) */
+
+ akk = a[k + k * a_dim1];
+ bkk = b[k + k * b_dim1];
+ i__2 = k - 1;
+ strmv_(uplo, "Transpose", "Non-unit", &i__2, &b[b_offset],
+ ldb, &a[k + a_dim1], lda);
+ ct = akk * .5f;
+ i__2 = k - 1;
+ saxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
+ i__2 = k - 1;
+ ssyr2_(uplo, &i__2, &c_b27, &a[k + a_dim1], lda, &b[k +
+ b_dim1], ldb, &a[a_offset], lda);
+ i__2 = k - 1;
+ saxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
+ i__2 = k - 1;
+ sscal_(&i__2, &bkk, &a[k + a_dim1], lda);
+/* Computing 2nd power */
+ r__1 = bkk;
+ a[k + k * a_dim1] = akk * (r__1 * r__1);
+/* L40: */
+ }
+ }
+ }
+ return 0;
+
+/* End of SSYGS2 */
+
+} /* ssygs2_ */
diff --git a/SRC/ssygst.c b/SRC/ssygst.c
new file mode 100644
index 0000000..4dffa59
--- /dev/null
+++ b/SRC/ssygst.c
@@ -0,0 +1,342 @@
+/* ssygst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b14 = 1.f;
+static real c_b16 = -.5f;
+static real c_b19 = -1.f;
+static real c_b52 = .5f;
+
+/* Subroutine */ int ssygst_(integer *itype, char *uplo, integer *n, real *a,
+ integer *lda, real *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer k, kb, nb;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int strmm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), ssymm_(char *, char *, integer
+ *, integer *, real *, real *, integer *, real *, integer *, real *
+, real *, integer *), strsm_(char *, char *, char
+ *, char *, integer *, integer *, real *, real *, integer *, real *
+, integer *), ssygs2_(integer *,
+ char *, integer *, real *, integer *, real *, integer *, integer *
+), ssyr2k_(char *, char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYGST reduces a real symmetric-definite generalized eigenproblem */
+/* to standard form. */
+
+/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
+/* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) */
+
+/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
+/* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L. */
+
+/* B must have been previously factorized as U**T*U or L*L**T by SPOTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); */
+/* = 2 or 3: compute U*A*U**T or L**T*A*L. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored and B is factored as */
+/* U**T*U; */
+/* = 'L': Lower triangle of A is stored and B is factored as */
+/* L*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the transformed matrix, stored in the */
+/* same format as A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) REAL array, dimension (LDB,N) */
+/* The triangular factor from the Cholesky factorization of B, */
+/* as returned by SPOTRF. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSYGST", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "SSYGST", uplo, n, &c_n1, &c_n1, &c_n1);
+
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code */
+
+ ssygs2_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
+ } else {
+
+/* Use blocked code */
+
+ if (*itype == 1) {
+ if (upper) {
+
+/* Compute inv(U')*A*inv(U) */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+/* Computing MIN */
+ i__3 = *n - k + 1;
+ kb = min(i__3,nb);
+
+/* Update the upper triangle of A(k:n,k:n) */
+
+ ssygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
+ k * b_dim1], ldb, info);
+ if (k + kb <= *n) {
+ i__3 = *n - k - kb + 1;
+ strsm_("Left", uplo, "Transpose", "Non-unit", &kb, &
+ i__3, &c_b14, &b[k + k * b_dim1], ldb, &a[k +
+ (k + kb) * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ ssymm_("Left", uplo, &kb, &i__3, &c_b16, &a[k + k *
+ a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb,
+ &c_b14, &a[k + (k + kb) * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ ssyr2k_(uplo, "Transpose", &i__3, &kb, &c_b19, &a[k +
+ (k + kb) * a_dim1], lda, &b[k + (k + kb) *
+ b_dim1], ldb, &c_b14, &a[k + kb + (k + kb) *
+ a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ ssymm_("Left", uplo, &kb, &i__3, &c_b16, &a[k + k *
+ a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb,
+ &c_b14, &a[k + (k + kb) * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ strsm_("Right", uplo, "No transpose", "Non-unit", &kb,
+ &i__3, &c_b14, &b[k + kb + (k + kb) * b_dim1]
+, ldb, &a[k + (k + kb) * a_dim1], lda);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Compute inv(L)*A*inv(L') */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+/* Computing MIN */
+ i__3 = *n - k + 1;
+ kb = min(i__3,nb);
+
+/* Update the lower triangle of A(k:n,k:n) */
+
+ ssygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
+ k * b_dim1], ldb, info);
+ if (k + kb <= *n) {
+ i__3 = *n - k - kb + 1;
+ strsm_("Right", uplo, "Transpose", "Non-unit", &i__3,
+ &kb, &c_b14, &b[k + k * b_dim1], ldb, &a[k +
+ kb + k * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ ssymm_("Right", uplo, &i__3, &kb, &c_b16, &a[k + k *
+ a_dim1], lda, &b[k + kb + k * b_dim1], ldb, &
+ c_b14, &a[k + kb + k * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ ssyr2k_(uplo, "No transpose", &i__3, &kb, &c_b19, &a[
+ k + kb + k * a_dim1], lda, &b[k + kb + k *
+ b_dim1], ldb, &c_b14, &a[k + kb + (k + kb) *
+ a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ ssymm_("Right", uplo, &i__3, &kb, &c_b16, &a[k + k *
+ a_dim1], lda, &b[k + kb + k * b_dim1], ldb, &
+ c_b14, &a[k + kb + k * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ strsm_("Left", uplo, "No transpose", "Non-unit", &
+ i__3, &kb, &c_b14, &b[k + kb + (k + kb) *
+ b_dim1], ldb, &a[k + kb + k * a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+ } else {
+ if (upper) {
+
+/* Compute U*A*U' */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+/* Computing MIN */
+ i__3 = *n - k + 1;
+ kb = min(i__3,nb);
+
+/* Update the upper triangle of A(1:k+kb-1,1:k+kb-1) */
+
+ i__3 = k - 1;
+ strmm_("Left", uplo, "No transpose", "Non-unit", &i__3, &
+ kb, &c_b14, &b[b_offset], ldb, &a[k * a_dim1 + 1],
+ lda)
+ ;
+ i__3 = k - 1;
+ ssymm_("Right", uplo, &i__3, &kb, &c_b52, &a[k + k *
+ a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, &a[
+ k * a_dim1 + 1], lda);
+ i__3 = k - 1;
+ ssyr2k_(uplo, "No transpose", &i__3, &kb, &c_b14, &a[k *
+ a_dim1 + 1], lda, &b[k * b_dim1 + 1], ldb, &c_b14,
+ &a[a_offset], lda);
+ i__3 = k - 1;
+ ssymm_("Right", uplo, &i__3, &kb, &c_b52, &a[k + k *
+ a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, &a[
+ k * a_dim1 + 1], lda);
+ i__3 = k - 1;
+ strmm_("Right", uplo, "Transpose", "Non-unit", &i__3, &kb,
+ &c_b14, &b[k + k * b_dim1], ldb, &a[k * a_dim1 +
+ 1], lda);
+ ssygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
+ k * b_dim1], ldb, info);
+/* L30: */
+ }
+ } else {
+
+/* Compute L'*A*L */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+/* Computing MIN */
+ i__3 = *n - k + 1;
+ kb = min(i__3,nb);
+
+/* Update the lower triangle of A(1:k+kb-1,1:k+kb-1) */
+
+ i__3 = k - 1;
+ strmm_("Right", uplo, "No transpose", "Non-unit", &kb, &
+ i__3, &c_b14, &b[b_offset], ldb, &a[k + a_dim1],
+ lda);
+ i__3 = k - 1;
+ ssymm_("Left", uplo, &kb, &i__3, &c_b52, &a[k + k *
+ a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[k +
+ a_dim1], lda);
+ i__3 = k - 1;
+ ssyr2k_(uplo, "Transpose", &i__3, &kb, &c_b14, &a[k +
+ a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[
+ a_offset], lda);
+ i__3 = k - 1;
+ ssymm_("Left", uplo, &kb, &i__3, &c_b52, &a[k + k *
+ a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[k +
+ a_dim1], lda);
+ i__3 = k - 1;
+ strmm_("Left", uplo, "Transpose", "Non-unit", &kb, &i__3,
+ &c_b14, &b[k + k * b_dim1], ldb, &a[k + a_dim1],
+ lda);
+ ssygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
+ k * b_dim1], ldb, info);
+/* L40: */
+ }
+ }
+ }
+ }
+ return 0;
+
+/* End of SSYGST */
+
+} /* ssygst_ */
diff --git a/SRC/ssygv.c b/SRC/ssygv.c
new file mode 100644
index 0000000..b27e8d5
--- /dev/null
+++ b/SRC/ssygv.c
@@ -0,0 +1,283 @@
+/* ssygv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b16 = 1.f;
+
+/* Subroutine */ int ssygv_(integer *itype, char *jobz, char *uplo, integer *
+ n, real *a, integer *lda, real *b, integer *ldb, real *w, real *work,
+ integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+
+ /* Local variables */
+ integer nb, neig;
+ extern logical lsame_(char *, char *);
+ char trans[1];
+ logical upper;
+ extern /* Subroutine */ int strmm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+);
+ logical wantz;
+ extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), ssyev_(char *, char *, integer
+ *, real *, integer *, real *, real *, integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer lwkmin;
+ extern /* Subroutine */ int spotrf_(char *, integer *, real *, integer *,
+ integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int ssygst_(integer *, char *, integer *, real *,
+ integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYGV computes all the eigenvalues, and optionally, the eigenvectors */
+/* of a real generalized symmetric-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. */
+/* Here A and B are assumed to be symmetric and B is also */
+/* positive definite. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA, N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of A contains the */
+/* upper triangular part of the matrix A. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+
+/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
+/* matrix Z of eigenvectors. The eigenvectors are normalized */
+/* as follows: */
+/* if ITYPE = 1 or 2, Z**T*B*Z = I; */
+/* if ITYPE = 3, Z**T*inv(B)*Z = I. */
+/* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') */
+/* or the lower triangle (if UPLO='L') of A, including the */
+/* diagonal, is destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) REAL array, dimension (LDB, N) */
+/* On entry, the symmetric positive definite matrix B. */
+/* If UPLO = 'U', the leading N-by-N upper triangular part of B */
+/* contains the upper triangular part of the matrix B. */
+/* If UPLO = 'L', the leading N-by-N lower triangular part of B */
+/* contains the lower triangular part of the matrix B. */
+
+/* On exit, if INFO <= N, the part of B containing the matrix is */
+/* overwritten by the triangular factor U or L from the Cholesky */
+/* factorization B = U**T*U or B = L*L**T. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(1,3*N-1). */
+/* For optimal efficiency, LWORK >= (NB+2)*N, */
+/* where NB is the blocksize for SSYTRD 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: SPOTRF or SSYEV returned an error code: */
+/* <= N: if INFO = i, SSYEV failed to converge; */
+/* i off-diagonal elements of an intermediate */
+/* tridiagonal form did not converge to zero; */
+/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --w;
+ --work;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1;
+
+ *info = 0;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+
+ if (*info == 0) {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * 3 - 1;
+ lwkmin = max(i__1,i__2);
+ nb = ilaenv_(&c__1, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = lwkmin, i__2 = (nb + 2) * *n;
+ lwkopt = max(i__1,i__2);
+ work[1] = (real) lwkopt;
+
+ if (*lwork < lwkmin && ! lquery) {
+ *info = -11;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSYGV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of B. */
+
+ spotrf_(uplo, n, &b[b_offset], ldb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ ssygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
+ ssyev_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, info);
+
+ if (wantz) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ neig = *n;
+ if (*info > 0) {
+ neig = *info - 1;
+ }
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'T';
+ }
+
+ strsm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b16, &b[
+ b_offset], ldb, &a[a_offset], lda);
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'T';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ strmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b16, &b[
+ b_offset], ldb, &a[a_offset], lda);
+ }
+ }
+
+ work[1] = (real) lwkopt;
+ return 0;
+
+/* End of SSYGV */
+
+} /* ssygv_ */
diff --git a/SRC/ssygvd.c b/SRC/ssygvd.c
new file mode 100644
index 0000000..fb1a2d0
--- /dev/null
+++ b/SRC/ssygvd.c
@@ -0,0 +1,337 @@
+/* ssygvd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b11 = 1.f;
+
+/* Subroutine */ int ssygvd_(integer *itype, char *jobz, char *uplo, integer *
+ n, real *a, integer *lda, real *b, integer *ldb, real *w, real *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer lopt;
+ extern logical lsame_(char *, char *);
+ integer lwmin;
+ char trans[1];
+ integer liopt;
+ logical upper;
+ extern /* Subroutine */ int strmm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+);
+ logical wantz;
+ extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), xerbla_(char *, integer *);
+ integer liwmin;
+ extern /* Subroutine */ int spotrf_(char *, integer *, real *, integer *,
+ integer *), ssyevd_(char *, char *, integer *, real *,
+ integer *, real *, real *, integer *, integer *, integer *,
+ integer *);
+ logical lquery;
+ extern /* Subroutine */ int ssygst_(integer *, char *, integer *, real *,
+ integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYGVD computes all the eigenvalues, and optionally, the eigenvectors */
+/* of a real generalized symmetric-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */
+/* B are assumed to be symmetric and B is also positive definite. */
+/* If eigenvectors are desired, it uses a divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA, N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of A contains the */
+/* upper triangular part of the matrix A. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+
+/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
+/* matrix Z of eigenvectors. The eigenvectors are normalized */
+/* as follows: */
+/* if ITYPE = 1 or 2, Z**T*B*Z = I; */
+/* if ITYPE = 3, Z**T*inv(B)*Z = I. */
+/* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') */
+/* or the lower triangle (if UPLO='L') of A, including the */
+/* diagonal, is destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) REAL array, dimension (LDB, N) */
+/* On entry, the symmetric matrix B. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of B contains the */
+/* upper triangular part of the matrix B. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of B contains */
+/* the lower triangular part of the matrix B. */
+
+/* On exit, if INFO <= N, the part of B containing the matrix is */
+/* overwritten by the triangular factor U or L from the Cholesky */
+/* factorization B = U**T*U or B = L*L**T. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* W (output) REAL array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If N <= 1, LWORK >= 1. */
+/* If JOBZ = 'N' and N > 1, LWORK >= 2*N+1. */
+/* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK and IWORK */
+/* arrays, returns these values as the first entries of the WORK */
+/* and IWORK arrays, and no error message related to LWORK or */
+/* LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If N <= 1, LIWORK >= 1. */
+/* If JOBZ = 'N' and N > 1, LIWORK >= 1. */
+/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK and IWORK arrays, and no error message related to */
+/* LWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: SPOTRF or SSYEVD returned an error code: */
+/* <= N: if INFO = i and JOBZ = 'N', then the algorithm */
+/* failed to converge; i off-diagonal elements of an */
+/* intermediate tridiagonal form did not converge to */
+/* zero; */
+/* if INFO = i and JOBZ = 'V', then the algorithm */
+/* failed to compute an eigenvalue while working on */
+/* the submatrix lying in rows and columns INFO/(N+1) */
+/* through mod(INFO,N+1); */
+/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* Modified so that no backsubstitution is performed if SSYEVD fails to */
+/* converge (NEIG in old code could be greater than N causing out of */
+/* bounds reference to A - reported by Ralf Meyer). Also corrected the */
+/* description of INFO and the test on ITYPE. Sven, 16 Feb 05. */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --w;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1 || *liwork == -1;
+
+ *info = 0;
+ if (*n <= 1) {
+ liwmin = 1;
+ lwmin = 1;
+ } else if (wantz) {
+ liwmin = *n * 5 + 3;
+/* Computing 2nd power */
+ i__1 = *n;
+ lwmin = *n * 6 + 1 + (i__1 * i__1 << 1);
+ } else {
+ liwmin = 1;
+ lwmin = (*n << 1) + 1;
+ }
+ lopt = lwmin;
+ liopt = liwmin;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+
+ if (*info == 0) {
+ work[1] = (real) lopt;
+ iwork[1] = liopt;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -11;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSYGVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of B. */
+
+ spotrf_(uplo, n, &b[b_offset], ldb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ ssygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
+ ssyevd_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &iwork[
+ 1], liwork, info);
+/* Computing MAX */
+ r__1 = (real) lopt;
+ lopt = dmax(r__1,work[1]);
+/* Computing MAX */
+ r__1 = (real) liopt, r__2 = (real) iwork[1];
+ liopt = dmax(r__1,r__2);
+
+ if (wantz && *info == 0) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'T';
+ }
+
+ strsm_("Left", uplo, trans, "Non-unit", n, n, &c_b11, &b[b_offset]
+, ldb, &a[a_offset], lda);
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'T';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ strmm_("Left", uplo, trans, "Non-unit", n, n, &c_b11, &b[b_offset]
+, ldb, &a[a_offset], lda);
+ }
+ }
+
+ work[1] = (real) lopt;
+ iwork[1] = liopt;
+
+ return 0;
+
+/* End of SSYGVD */
+
+} /* ssygvd_ */
diff --git a/SRC/ssygvx.c b/SRC/ssygvx.c
new file mode 100644
index 0000000..28c8c3a
--- /dev/null
+++ b/SRC/ssygvx.c
@@ -0,0 +1,395 @@
+/* ssygvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b19 = 1.f;
+
+/* Subroutine */ int ssygvx_(integer *itype, char *jobz, char *range, char *
+ uplo, integer *n, real *a, integer *lda, real *b, integer *ldb, real *
+ vl, real *vu, integer *il, integer *iu, real *abstol, integer *m,
+ real *w, real *z__, integer *ldz, real *work, integer *lwork, integer
+ *iwork, integer *ifail, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1, i__2;
+
+ /* Local variables */
+ integer nb;
+ extern logical lsame_(char *, char *);
+ char trans[1];
+ logical upper;
+ extern /* Subroutine */ int strmm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+);
+ logical wantz;
+ extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+);
+ logical alleig, indeig, valeig;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer lwkmin;
+ extern /* Subroutine */ int spotrf_(char *, integer *, real *, integer *,
+ integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int ssygst_(integer *, char *, integer *, real *,
+ integer *, real *, integer *, integer *), ssyevx_(char *,
+ char *, char *, integer *, real *, integer *, real *, real *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, real *, integer *, integer *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYGVX computes selected eigenvalues, and optionally, eigenvectors */
+/* of a real generalized symmetric-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A */
+/* and B are assumed to be symmetric and B is also positive definite. */
+/* Eigenvalues and eigenvectors can be selected by specifying either a */
+/* range of values or a range of indices for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A and B are stored; */
+/* = 'L': Lower triangle of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix pencil (A,B). N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA, N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of A contains the */
+/* upper triangular part of the matrix A. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+
+/* On exit, the lower triangle (if UPLO='L') or the upper */
+/* triangle (if UPLO='U') of A, including the diagonal, is */
+/* destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) REAL array, dimension (LDA, N) */
+/* On entry, the symmetric matrix B. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of B contains the */
+/* upper triangular part of the matrix B. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of B contains */
+/* the lower triangular part of the matrix B. */
+
+/* On exit, if INFO <= N, the part of B containing the matrix is */
+/* overwritten by the triangular factor U or L from the Cholesky */
+/* factorization B = U**T*U or B = L*L**T. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* VL (input) REAL */
+/* VU (input) REAL */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) REAL */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing A to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*SLAMCH('S'). */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) REAL array, dimension (N) */
+/* On normal exit, the first M elements contain the selected */
+/* eigenvalues in ascending order. */
+
+/* Z (output) REAL array, dimension (LDZ, max(1,M)) */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* The eigenvectors are normalized as follows: */
+/* if ITYPE = 1 or 2, Z**T*B*Z = I; */
+/* if ITYPE = 3, Z**T*inv(B)*Z = I. */
+
+/* If an eigenvector fails to converge, then that column of Z */
+/* contains the latest approximation to the eigenvector, and the */
+/* index of the eigenvector is returned in IFAIL. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(1,8*N). */
+/* For optimal efficiency, LWORK >= (NB+3)*N, */
+/* where NB is the blocksize for SSYTRD 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. */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: SPOTRF or SSYEVX returned an error code: */
+/* <= N: if INFO = i, SSYEVX failed to converge; */
+/* i eigenvectors failed to converge. Their indices */
+/* are stored in array IFAIL. */
+/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ upper = lsame_(uplo, "U");
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+ lquery = *lwork == -1;
+
+ *info = 0;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -3;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -11;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -12;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -13;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -18;
+ }
+ }
+
+ if (*info == 0) {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n << 3;
+ lwkmin = max(i__1,i__2);
+ nb = ilaenv_(&c__1, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = lwkmin, i__2 = (nb + 3) * *n;
+ lwkopt = max(i__1,i__2);
+ work[1] = (real) lwkopt;
+
+ if (*lwork < lwkmin && ! lquery) {
+ *info = -20;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSYGVX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of B. */
+
+ spotrf_(uplo, n, &b[b_offset], ldb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ ssygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
+ ssyevx_(jobz, range, uplo, n, &a[a_offset], lda, vl, vu, il, iu, abstol,
+ m, &w[1], &z__[z_offset], ldz, &work[1], lwork, &iwork[1], &ifail[
+ 1], info);
+
+ if (wantz) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ if (*info > 0) {
+ *m = *info - 1;
+ }
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'T';
+ }
+
+ strsm_("Left", uplo, trans, "Non-unit", n, m, &c_b19, &b[b_offset]
+, ldb, &z__[z_offset], ldz);
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'T';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ strmm_("Left", uplo, trans, "Non-unit", n, m, &c_b19, &b[b_offset]
+, ldb, &z__[z_offset], ldz);
+ }
+ }
+
+/* Set WORK(1) to optimal workspace size. */
+
+ work[1] = (real) lwkopt;
+
+ return 0;
+
+/* End of SSYGVX */
+
+} /* ssygvx_ */
diff --git a/SRC/ssyrfs.c b/SRC/ssyrfs.c
new file mode 100644
index 0000000..09a9585
--- /dev/null
+++ b/SRC/ssyrfs.c
@@ -0,0 +1,427 @@
+/* ssyrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b12 = -1.f;
+static real c_b14 = 1.f;
+
+/* Subroutine */ int ssyrfs_(char *uplo, integer *n, integer *nrhs, real *a,
+ integer *lda, real *af, integer *ldaf, integer *ipiv, real *b,
+ integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *
+ work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2, i__3;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ real s, xk;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3], count;
+ logical upper;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), saxpy_(integer *, real *, real *, integer *, real *,
+ integer *), ssymv_(char *, integer *, real *, real *, integer *,
+ real *, integer *, real *, real *, integer *), slacn2_(
+ integer *, real *, real *, integer *, real *, integer *, integer *
+);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real lstres;
+ extern /* Subroutine */ int ssytrs_(char *, integer *, integer *, real *,
+ integer *, integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric indefinite, and */
+/* provides error bounds and backward error estimates for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular part */
+/* of the matrix A, and the strictly lower triangular part of A */
+/* is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of A contains the lower triangular part of */
+/* the matrix A, and the strictly upper triangular part of A is */
+/* not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) REAL array, dimension (LDAF,N) */
+/* The factored form of the matrix A. AF contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor U or L from the factorization A = U*D*U**T or */
+/* A = L*D*L**T as computed by SSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by SSYTRF. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) REAL array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by SSYTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldx < max(1,*n)) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSYRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.f;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ scopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+ ssymv_(uplo, n, &c_b12, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1,
+ &c_b14, &work[*n + 1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] = (r__1 = b[i__ + j * b_dim1], dabs(r__1));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ work[i__] += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) *
+ xk;
+ s += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * (r__2 = x[
+ i__ + j * x_dim1], dabs(r__2));
+/* L40: */
+ }
+ work[k] = work[k] + (r__1 = a[k + k * a_dim1], dabs(r__1)) *
+ xk + s;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+ work[k] += (r__1 = a[k + k * a_dim1], dabs(r__1)) * xk;
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ work[i__] += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) *
+ xk;
+ s += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * (r__2 = x[
+ i__ + j * x_dim1], dabs(r__2));
+/* L60: */
+ }
+ work[k] += s;
+/* L70: */
+ }
+ }
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[
+ i__];
+ s = dmax(r__2,r__3);
+ } else {
+/* Computing MAX */
+ r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1)
+ / (work[i__] + safe1);
+ s = dmax(r__2,r__3);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ ssytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[*n
+ + 1], n, info);
+ saxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
+ ;
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use SLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ slacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+ kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ ssytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ *n + 1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L120: */
+ }
+ ssytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ *n + 1], n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], dabs(r__1));
+ lstres = dmax(r__2,r__3);
+/* L130: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of SSYRFS */
+
+} /* ssyrfs_ */
diff --git a/SRC/ssyrfsx.c b/SRC/ssyrfsx.c
new file mode 100644
index 0000000..056c209
--- /dev/null
+++ b/SRC/ssyrfsx.c
@@ -0,0 +1,626 @@
+/* ssyrfsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int ssyrfsx_(char *uplo, char *equed, integer *n, integer *
+ nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv,
+ real *s, real *b, integer *ldb, real *x, integer *ldx, real *rcond,
+ real *berr, integer *n_err_bnds__, real *err_bnds_norm__, real *
+ err_bnds_comp__, integer *nparams, real *params, real *work, integer *
+ iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real illrcond_thresh__, unstable_thresh__, err_lbnd__;
+ integer ref_type__, j;
+ real rcond_tmp__;
+ integer prec_type__;
+ extern doublereal sla_syrcond__(char *, integer *, real *, integer *,
+ real *, integer *, integer *, integer *, real *, integer *, real *
+ , integer *, ftnlen);
+ real cwise_wrong__;
+ extern /* Subroutine */ int sla_syrfsx_extended__(integer *, char *,
+ integer *, integer *, real *, integer *, real *, integer *,
+ integer *, logical *, real *, real *, integer *, real *, integer *
+ , real *, integer *, real *, real *, real *, real *, real *, real
+ *, real *, integer *, real *, real *, logical *, integer *,
+ ftnlen);
+ char norm[1];
+ logical ignore_cwise__;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ logical rcequ;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+ extern /* Subroutine */ int ssycon_(char *, integer *, real *, integer *,
+ integer *, real *, real *, real *, integer *, integer *);
+ extern integer ilaprec_(char *);
+ integer ithresh, n_norms__;
+ real rthresh;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYRFSX improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric indefinite, and */
+/* provides error bounds and backward error estimates for the */
+/* solution. In addition to normwise error bound, the code provides */
+/* maximum componentwise error bound if possible. See comments for */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds. */
+
+/* The original system of linear equations may have been equilibrated */
+/* before calling this routine, as described by arguments EQUED and S */
+/* below. In this case, the solution and error bounds returned are */
+/* for the original unequilibrated system. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* EQUED (input) CHARACTER*1 */
+/* Specifies the form of equilibration that was done to A */
+/* before calling this routine. This is needed to compute */
+/* the solution and error bounds correctly. */
+/* = 'N': No equilibration */
+/* = 'Y': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(S) * A * diag(S). */
+/* The right hand side B has been changed accordingly. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular */
+/* part of the matrix A, and the strictly lower triangular */
+/* part of A is not referenced. If UPLO = 'L', the leading */
+/* N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) REAL array, dimension (LDAF,N) */
+/* The factored form of the matrix A. AF contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor U or L from the factorization A = U*D*U**T or A = */
+/* L*D*L**T as computed by SSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by SSYTRF. */
+
+/* S (input or output) REAL array, dimension (N) */
+/* The scale factors for A. If EQUED = 'Y', A is multiplied on */
+/* the left and right by diag(S). S is an input argument if FACT = */
+/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
+/* = 'Y', each element of S must be positive. If S is output, each */
+/* element of S is a power of the radix. If S is input, each element */
+/* of S should be a power of the radix to ensure a reliable solution */
+/* and error estimates. Scaling by powers of the radix does not cause */
+/* rounding errors unless the result underflows or overflows. */
+/* Rounding errors during scaling lead to refining with a matrix that */
+/* is not equivalent to the input matrix, producing error estimates */
+/* that may not be reliable. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) REAL array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by SGETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) REAL array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) REAL array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check the input parameters. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ ref_type__ = 1;
+ if (*nparams >= 1) {
+ if (params[1] < 0.f) {
+ params[1] = 1.f;
+ } else {
+ ref_type__ = params[1];
+ }
+ }
+
+/* Set default parameters. */
+
+ illrcond_thresh__ = (real) (*n) * slamch_("Epsilon");
+ ithresh = 10;
+ rthresh = .5f;
+ unstable_thresh__ = .25f;
+ ignore_cwise__ = FALSE_;
+
+ if (*nparams >= 2) {
+ if (params[2] < 0.f) {
+ params[2] = (real) ithresh;
+ } else {
+ ithresh = (integer) params[2];
+ }
+ }
+ if (*nparams >= 3) {
+ if (params[3] < 0.f) {
+ if (ignore_cwise__) {
+ params[3] = 0.f;
+ } else {
+ params[3] = 1.f;
+ }
+ } else {
+ ignore_cwise__ = params[3] == 0.f;
+ }
+ }
+ if (ref_type__ == 0 || *n_err_bnds__ == 0) {
+ n_norms__ = 0;
+ } else if (ignore_cwise__) {
+ n_norms__ = 1;
+ } else {
+ n_norms__ = 2;
+ }
+
+ rcequ = lsame_(equed, "Y");
+
+/* Test input parameters. */
+
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! rcequ && ! lsame_(equed, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -11;
+ } else if (*ldx < max(1,*n)) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSYRFSX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *nrhs == 0) {
+ *rcond = 1.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 0.f;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.f;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.f;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.f;
+ }
+ }
+ return 0;
+ }
+
+/* Default to failure. */
+
+ *rcond = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 1.f;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.f;
+ }
+ }
+
+/* Compute the norm of A and the reciprocal of the condition */
+/* number of A. */
+
+ *(unsigned char *)norm = 'I';
+ anorm = slansy_(norm, uplo, n, &a[a_offset], lda, &work[1]);
+ ssycon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1],
+ &iwork[1], info);
+
+/* Perform refinement on each right-hand side */
+
+ if (ref_type__ != 0) {
+ prec_type__ = ilaprec_("D");
+ sla_syrfsx_extended__(&prec_type__, uplo, n, nrhs, &a[a_offset], lda,
+ &af[af_offset], ldaf, &ipiv[1], &rcequ, &s[1], &b[b_offset],
+ ldb, &x[x_offset], ldx, &berr[1], &n_norms__, &
+ err_bnds_norm__[err_bnds_norm_offset], &err_bnds_comp__[
+ err_bnds_comp_offset], &work[*n + 1], &work[1], &work[(*n <<
+ 1) + 1], &work[1], rcond, &ithresh, &rthresh, &
+ unstable_thresh__, &ignore_cwise__, info, (ftnlen)1);
+ }
+/* Computing MAX */
+ r__1 = 10.f, r__2 = sqrt((real) (*n));
+ err_lbnd__ = dmax(r__1,r__2) * slamch_("Epsilon");
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {
+
+/* Compute scaled normwise condition number cond(A*C). */
+
+ if (rcequ) {
+ rcond_tmp__ = sla_syrcond__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &c_n1, &s[1], info, &work[1],
+ &iwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = sla_syrcond__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &c__0, &s[1], info, &work[1],
+ &iwork[1], (ftnlen)1);
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1
+ << 1)] > 1.f) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 0.f;
+ if (*info <= *n) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {
+
+/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
+/* each right-hand side using the current solution as an estimate of */
+/* the true solution. If the componentwise error estimate is too */
+/* large, then the solution is a lousy estimate of truth and the */
+/* estimated RCOND may be too optimistic. To avoid misleading users, */
+/* the inverse condition number is set to 0.0 when the estimated */
+/* cwise error is at least CWISE_WRONG. */
+
+ cwise_wrong__ = sqrt(slamch_("Epsilon"));
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ cwise_wrong__) {
+ rcond_tmp__ = sla_syrcond__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &c__1, &x[j * x_dim1 + 1],
+ info, &work[1], &iwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = 0.f;
+ }
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1
+ << 1)] > 1.f) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 0.f;
+ if (params[3] == 1.f && *info < *n + j) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SSYRFSX */
+
+} /* ssyrfsx_ */
diff --git a/SRC/ssysv.c b/SRC/ssysv.c
new file mode 100644
index 0000000..15b4ef7
--- /dev/null
+++ b/SRC/ssysv.c
@@ -0,0 +1,214 @@
+/* ssysv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int ssysv_(char *uplo, integer *n, integer *nrhs, real *a,
+ integer *lda, integer *ipiv, real *b, integer *ldb, real *work,
+ integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ integer nb;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int ssytrf_(char *, integer *, real *, integer *,
+ integer *, real *, integer *, integer *), ssytrs_(char *,
+ integer *, integer *, real *, integer *, integer *, real *,
+ integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYSV 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 diagonal pivoting method is used to factor A as */
+/* A = U * D * U**T, if UPLO = 'U', or */
+/* A = L * D * L**T, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then */
+/* used to solve the system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the block diagonal matrix D and the */
+/* multipliers used to obtain the factor U or L from the */
+/* factorization A = U*D*U**T or A = L*D*L**T as computed by */
+/* SSYTRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D, as */
+/* determined by SSYTRF. If IPIV(k) > 0, then rows and columns */
+/* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 */
+/* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, */
+/* then rows and columns k-1 and -IPIV(k) were interchanged and */
+/* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and */
+/* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and */
+/* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 */
+/* diagonal block. */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK >= 1, and for best performance */
+/* LWORK >= max(1,N*NB), where NB is the optimal blocksize for */
+/* SSYTRF. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */
+/* has been completed, but the block diagonal matrix D is */
+/* exactly singular, so the solution could not be computed. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*lwork < 1 && ! lquery) {
+ *info = -10;
+ }
+
+ if (*info == 0) {
+ if (*n == 0) {
+ lwkopt = 1;
+ } else {
+ nb = ilaenv_(&c__1, "SSYTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ }
+ work[1] = (real) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSYSV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ ssytrf_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], lwork, info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ ssytrs_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], ldb,
+ info);
+
+ }
+
+ work[1] = (real) lwkopt;
+
+ return 0;
+
+/* End of SSYSV */
+
+} /* ssysv_ */
diff --git a/SRC/ssysvx.c b/SRC/ssysvx.c
new file mode 100644
index 0000000..df5e801
--- /dev/null
+++ b/SRC/ssysvx.c
@@ -0,0 +1,368 @@
+/* ssysvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int ssysvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv,
+ real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *ferr,
+ real *berr, real *work, integer *lwork, integer *iwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2;
+
+ /* Local variables */
+ integer nb;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern doublereal slamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+ extern /* Subroutine */ int ssycon_(char *, integer *, real *, integer *,
+ integer *, real *, real *, real *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int ssyrfs_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, integer *, real *, integer *, real *
+, integer *, real *, real *, real *, integer *, integer *)
+ , ssytrf_(char *, integer *, real *, integer *, integer *, real *,
+ integer *, integer *), ssytrs_(char *, integer *,
+ integer *, real *, integer *, integer *, real *, integer *,
+ integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYSVX uses the diagonal pivoting factorization to compute the */
+/* solution to a real system of linear equations A * X = B, */
+/* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */
+/* matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'N', the diagonal pivoting method is used to factor A. */
+/* The form of the factorization is */
+/* A = U * D * U**T, if UPLO = 'U', or */
+/* A = L * D * L**T, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* 2. If some D(i,i)=0, so that D is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 3. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 4. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of A has been */
+/* supplied on entry. */
+/* = 'F': On entry, AF and IPIV contain the factored form of */
+/* A. AF and IPIV will not be modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular part */
+/* of the matrix A, and the strictly lower triangular part of A */
+/* is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of A contains the lower triangular part of */
+/* the matrix A, and the strictly upper triangular part of A is */
+/* not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) REAL array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**T or A = L*D*L**T as computed by SSYTRF. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**T or A = L*D*L**T. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by SSYTRF. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by SSYTRF. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) REAL array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A. If RCOND is less than the machine precision (in */
+/* particular, if RCOND = 0), the matrix is singular to working */
+/* precision. This condition is indicated by a return code of */
+/* INFO > 0. */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK >= max(1,3*N), and for best */
+/* performance, when FACT = 'N', LWORK >= max(1,3*N,N*NB), where */
+/* NB is the optimal blocksize for SSYTRF. */
+
+/* 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. */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: D(i,i) is exactly zero. The factorization */
+/* has been completed but the factor D is exactly */
+/* singular, so the solution and error bounds could */
+/* not be computed. RCOND = 0 is returned. */
+/* = N+1: D is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ lquery = *lwork == -1;
+ if (! nofact && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -11;
+ } else if (*ldx < max(1,*n)) {
+ *info = -13;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * 3;
+ if (*lwork < max(i__1,i__2) && ! lquery) {
+ *info = -18;
+ }
+ }
+
+ if (*info == 0) {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * 3;
+ lwkopt = max(i__1,i__2);
+ if (nofact) {
+ nb = ilaenv_(&c__1, "SSYTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = *n * nb;
+ lwkopt = max(i__1,i__2);
+ }
+ work[1] = (real) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSYSVX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+ if (nofact) {
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ slacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ ssytrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], lwork,
+ info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.f;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = slansy_("I", uplo, n, &a[a_offset], lda, &work[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ ssycon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1],
+ &iwork[1], info);
+
+/* Compute the solution vectors X. */
+
+ slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ ssytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solutions and */
+/* compute error bounds and backward error estimates for them. */
+
+ ssyrfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1],
+ &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1]
+, &iwork[1], info);
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < slamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ work[1] = (real) lwkopt;
+
+ return 0;
+
+/* End of SSYSVX */
+
+} /* ssysvx_ */
diff --git a/SRC/ssysvxx.c b/SRC/ssysvxx.c
new file mode 100644
index 0000000..29e74dd
--- /dev/null
+++ b/SRC/ssysvxx.c
@@ -0,0 +1,630 @@
+/* ssysvxx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ssysvxx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv,
+ char *equed, real *s, real *b, integer *ldb, real *x, integer *ldx,
+ real *rcond, real *rpvgrw, real *berr, integer *n_err_bnds__, real *
+ err_bnds_norm__, real *err_bnds_comp__, integer *nparams, real *
+ params, real *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ extern /* Subroutine */ int ssyrfsx_(char *, char *, integer *, integer *,
+ real *, integer *, real *, integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ real *, integer *, real *, real *, integer *, integer *);
+ integer j;
+ real amax, smin, smax;
+ extern doublereal sla_syrpvgrw__(char *, integer *, integer *, real *,
+ integer *, real *, integer *, integer *, real *, ftnlen);
+ extern logical lsame_(char *, char *);
+ real scond;
+ logical equil, rcequ;
+ extern doublereal slamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ integer infequ;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+ real smlnum;
+ extern /* Subroutine */ int slaqsy_(char *, integer *, real *, integer *,
+ real *, real *, real *, char *), ssytrf_(char *,
+ integer *, real *, integer *, integer *, real *, integer *,
+ integer *), slascl2_(integer *, integer *, real *, real *,
+ integer *), ssytrs_(char *, integer *, integer *, real *,
+ integer *, integer *, real *, integer *, integer *),
+ ssyequb_(char *, integer *, real *, integer *, real *, real *,
+ real *, real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYSVXX uses the diagonal pivoting factorization to compute the */
+/* solution to a real system of linear equations A * X = B, where A */
+/* is an N-by-N symmetric matrix and X and B are N-by-NRHS matrices. */
+
+/* If requested, both normwise and maximum componentwise error bounds */
+/* are returned. SSYSVXX will return a solution with a tiny */
+/* guaranteed error (O(eps) where eps is the working machine */
+/* precision) unless the matrix is very ill-conditioned, in which */
+/* case a warning is returned. Relevant condition numbers also are */
+/* calculated and returned. */
+
+/* SSYSVXX accepts user-provided factorizations and equilibration */
+/* factors; see the definitions of the FACT and EQUED options. */
+/* Solving with refinement and using a factorization from a previous */
+/* SSYSVXX call will also produce a solution with either O(eps) */
+/* errors or warnings, but we cannot make that claim for general */
+/* user-provided factorizations and equilibration factors if they */
+/* differ from what SSYSVXX would itself produce. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+
+/* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B */
+
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
+
+/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */
+/* the matrix A (after equilibration if FACT = 'E') as */
+
+/* A = U * D * U**T, if UPLO = 'U', or */
+/* A = L * D * L**T, if UPLO = 'L', */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* 3. If some D(i,i)=0, so that D is exactly singular, then the */
+/* routine returns with INFO = i. Otherwise, the factored form of A */
+/* is used to estimate the condition number of the matrix A (see */
+/* argument RCOND). If the reciprocal of the condition number is */
+/* less than machine precision, the routine still goes on to solve */
+/* for X and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */
+/* the routine will use iterative refinement to try to get a small */
+/* error and error bounds. Refinement calculates the residual to at */
+/* least twice the working precision. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(R) so that it solves the original system before */
+/* equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF and IPIV contain the factored form of A. */
+/* If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by S. */
+/* A, AF, and IPIV are not modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular */
+/* part of the matrix A, and the strictly lower triangular */
+/* part of A is not referenced. If UPLO = 'L', the leading */
+/* N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
+/* diag(S)*A*diag(S). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) REAL array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L from the factorization A = */
+/* U*D*U**T or A = L*D*L**T as computed by SSYTRF. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L from the factorization A = */
+/* U*D*U**T or A = L*D*L**T. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains details of the interchanges and the block */
+/* structure of D, as determined by SSYTRF. If IPIV(k) > 0, */
+/* then rows and columns k and IPIV(k) were interchanged and */
+/* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and */
+/* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and */
+/* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 */
+/* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0, */
+/* then rows and columns k+1 and -IPIV(k) were interchanged */
+/* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains details of the interchanges and the block */
+/* structure of D, as determined by SSYTRF. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'Y': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(S) * A * diag(S). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* S (input or output) REAL array, dimension (N) */
+/* The scale factors for A. If EQUED = 'Y', A is multiplied on */
+/* the left and right by diag(S). S is an input argument if FACT = */
+/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
+/* = 'Y', each element of S must be positive. If S is output, each */
+/* element of S is a power of the radix. If S is input, each element */
+/* of S should be a power of the radix to ensure a reliable solution */
+/* and error estimates. Scaling by powers of the radix does not cause */
+/* rounding errors unless the result underflows or overflows. */
+/* Rounding errors during scaling lead to refining with a matrix that */
+/* is not equivalent to the input matrix, producing error estimates */
+/* that may not be reliable. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if EQUED = 'Y', B is overwritten by diag(S)*B; */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) REAL array, dimension (LDX,NRHS) */
+/* If INFO = 0, the N-by-NRHS solution matrix X to the original */
+/* system of equations. Note that A and B are modified on exit if */
+/* EQUED .ne. 'N', and the solution to the equilibrated system is */
+/* inv(diag(S))*X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* RPVGRW (output) REAL */
+/* Reciprocal pivot growth. On exit, this contains the reciprocal */
+/* pivot growth factor norm(A)/norm(U). The "max absolute element" */
+/* norm is used. If this is much less than 1, then the stability of */
+/* the LU factorization of the (equilibrated) matrix A could be poor. */
+/* This also means that the solution X, estimated condition numbers, */
+/* and error bounds could be unreliable. If factorization fails with */
+/* 0<INFO<=N, then this contains the reciprocal pivot growth factor */
+/* for the leading INFO columns of A. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) REAL array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) REAL array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rcequ = FALSE_;
+ } else {
+ rcequ = lsame_(equed, "Y");
+ }
+
+/* Default is failure. If an input parameter is wrong or */
+/* factorization fails, make everything look horrible. Only the */
+/* pivot growth is set here, the rest is initialized in SSYRFSX. */
+
+ *rpvgrw = 0.f;
+
+/* Test the input parameters. PARAMS is not tested until SSYRFSX. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (lsame_(fact, "F") && ! (rcequ || lsame_(
+ equed, "N"))) {
+ *info = -9;
+ } else {
+ if (rcequ) {
+ smin = bignum;
+ smax = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ r__1 = smin, r__2 = s[j];
+ smin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = smax, r__2 = s[j];
+ smax = dmax(r__1,r__2);
+/* L10: */
+ }
+ if (smin <= 0.f) {
+ *info = -10;
+ } else if (*n > 0) {
+ scond = dmax(smin,smlnum) / dmin(smax,bignum);
+ } else {
+ scond = 1.f;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -12;
+ } else if (*ldx < max(1,*n)) {
+ *info = -14;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSYSVXX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ ssyequb_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, &work[1], &
+ infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ slaqsy_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed);
+ rcequ = lsame_(equed, "Y");
+ }
+ }
+
+/* Scale the right-hand side. */
+
+ if (rcequ) {
+ slascl2_(n, nrhs, &s[1], &b[b_offset], ldb);
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of A. */
+
+ slacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ i__1 = max(1,*n) * 5;
+ ssytrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], &i__1,
+ info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Pivot in column INFO is exactly 0 */
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ if (*n > 0) {
+ *rpvgrw = sla_syrpvgrw__(uplo, n, info, &a[a_offset], lda, &
+ af[af_offset], ldaf, &ipiv[1], &work[1], (ftnlen)1);
+ }
+ return 0;
+ }
+ }
+
+/* Compute the reciprocal pivot growth factor RPVGRW. */
+
+ if (*n > 0) {
+ *rpvgrw = sla_syrpvgrw__(uplo, n, info, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &work[1], (ftnlen)1);
+ }
+
+/* Compute the solution matrix X. */
+
+ slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ ssytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ ssyrfsx_(uplo, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &
+ ipiv[1], &s[1], &b[b_offset], ldb, &x[x_offset], ldx, rcond, &
+ berr[1], n_err_bnds__, &err_bnds_norm__[err_bnds_norm_offset], &
+ err_bnds_comp__[err_bnds_comp_offset], nparams, ¶ms[1], &work[
+ 1], &iwork[1], info);
+
+/* Scale solutions. */
+
+ if (rcequ) {
+ slascl2_(n, nrhs, &s[1], &x[x_offset], ldx);
+ }
+
+ return 0;
+
+/* End of SSYSVXX */
+
+} /* ssysvxx_ */
diff --git a/SRC/ssytd2.c b/SRC/ssytd2.c
new file mode 100644
index 0000000..f202635
--- /dev/null
+++ b/SRC/ssytd2.c
@@ -0,0 +1,302 @@
+/* ssytd2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b8 = 0.f;
+static real c_b14 = -1.f;
+
+/* Subroutine */ int ssytd2_(char *uplo, integer *n, real *a, integer *lda,
+ real *d__, real *e, real *tau, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__;
+ real taui;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ extern /* Subroutine */ int ssyr2_(char *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ real alpha;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *), ssymv_(char *, integer *, real *, real *,
+ integer *, real *, integer *, real *, real *, integer *),
+ xerbla_(char *, integer *), slarfg_(integer *, real *,
+ real *, integer *, real *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal */
+/* form T by an orthogonal similarity transformation: Q' * A * Q = T. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n-by-n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n-by-n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+/* On exit, if UPLO = 'U', the diagonal and first superdiagonal */
+/* of A are overwritten by the corresponding elements of the */
+/* tridiagonal matrix T, and the elements above the first */
+/* superdiagonal, with the array TAU, represent the orthogonal */
+/* matrix Q as a product of elementary reflectors; if UPLO */
+/* = 'L', the diagonal and first subdiagonal of A are over- */
+/* written by the corresponding elements of the tridiagonal */
+/* matrix T, and the elements below the first subdiagonal, with */
+/* the array TAU, represent the orthogonal matrix Q as a product */
+/* of elementary reflectors. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* D (output) REAL array, dimension (N) */
+/* The diagonal elements of the tridiagonal matrix T: */
+/* D(i) = A(i,i). */
+
+/* E (output) REAL array, dimension (N-1) */
+/* The off-diagonal elements of the tridiagonal matrix T: */
+/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */
+
+/* TAU (output) REAL array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(n-1) . . . H(2) H(1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */
+/* A(1:i-1,i+1), and tau in TAU(i). */
+
+/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(1) H(2) . . . H(n-1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */
+/* and tau in TAU(i). */
+
+/* The contents of A on exit are illustrated by the following examples */
+/* with n = 5: */
+
+/* if UPLO = 'U': if UPLO = 'L': */
+
+/* ( d e v2 v3 v4 ) ( d ) */
+/* ( d e v3 v4 ) ( e d ) */
+/* ( d e v4 ) ( v1 e d ) */
+/* ( d e ) ( v1 v2 e d ) */
+/* ( d ) ( v1 v2 v3 e d ) */
+
+/* where d and e denote diagonal and off-diagonal elements of T, and vi */
+/* denotes an element of the vector defining H(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ --tau;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSYTD2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Reduce the upper triangle of A */
+
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+
+/* Generate elementary reflector H(i) = I - tau * v * v' */
+/* to annihilate A(1:i-1,i+1) */
+
+ slarfg_(&i__, &a[i__ + (i__ + 1) * a_dim1], &a[(i__ + 1) * a_dim1
+ + 1], &c__1, &taui);
+ e[i__] = a[i__ + (i__ + 1) * a_dim1];
+
+ if (taui != 0.f) {
+
+/* Apply H(i) from both sides to A(1:i,1:i) */
+
+ a[i__ + (i__ + 1) * a_dim1] = 1.f;
+
+/* Compute x := tau * A * v storing x in TAU(1:i) */
+
+ ssymv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) *
+ a_dim1 + 1], &c__1, &c_b8, &tau[1], &c__1);
+
+/* Compute w := x - 1/2 * tau * (x'*v) * v */
+
+ alpha = taui * -.5f * sdot_(&i__, &tau[1], &c__1, &a[(i__ + 1)
+ * a_dim1 + 1], &c__1);
+ saxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[
+ 1], &c__1);
+
+/* Apply the transformation as a rank-2 update: */
+/* A := A - v * w' - w * v' */
+
+ ssyr2_(uplo, &i__, &c_b14, &a[(i__ + 1) * a_dim1 + 1], &c__1,
+ &tau[1], &c__1, &a[a_offset], lda);
+
+ a[i__ + (i__ + 1) * a_dim1] = e[i__];
+ }
+ d__[i__ + 1] = a[i__ + 1 + (i__ + 1) * a_dim1];
+ tau[i__] = taui;
+/* L10: */
+ }
+ d__[1] = a[a_dim1 + 1];
+ } else {
+
+/* Reduce the lower triangle of A */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Generate elementary reflector H(i) = I - tau * v * v' */
+/* to annihilate A(i+2:n,i) */
+
+ i__2 = *n - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ slarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[min(i__3, *n)+ i__ *
+ a_dim1], &c__1, &taui);
+ e[i__] = a[i__ + 1 + i__ * a_dim1];
+
+ if (taui != 0.f) {
+
+/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
+
+ a[i__ + 1 + i__ * a_dim1] = 1.f;
+
+/* Compute x := tau * A * v storing y in TAU(i:n-1) */
+
+ i__2 = *n - i__;
+ ssymv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1],
+ lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b8, &tau[
+ i__], &c__1);
+
+/* Compute w := x - 1/2 * tau * (x'*v) * v */
+
+ i__2 = *n - i__;
+ alpha = taui * -.5f * sdot_(&i__2, &tau[i__], &c__1, &a[i__ +
+ 1 + i__ * a_dim1], &c__1);
+ i__2 = *n - i__;
+ saxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
+ i__], &c__1);
+
+/* Apply the transformation as a rank-2 update: */
+/* A := A - v * w' - w * v' */
+
+ i__2 = *n - i__;
+ ssyr2_(uplo, &i__2, &c_b14, &a[i__ + 1 + i__ * a_dim1], &c__1,
+ &tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1],
+ lda);
+
+ a[i__ + 1 + i__ * a_dim1] = e[i__];
+ }
+ d__[i__] = a[i__ + i__ * a_dim1];
+ tau[i__] = taui;
+/* L20: */
+ }
+ d__[*n] = a[*n + *n * a_dim1];
+ }
+
+ return 0;
+
+/* End of SSYTD2 */
+
+} /* ssytd2_ */
diff --git a/SRC/ssytf2.c b/SRC/ssytf2.c
new file mode 100644
index 0000000..245137d
--- /dev/null
+++ b/SRC/ssytf2.c
@@ -0,0 +1,608 @@
+/* ssytf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ssytf2_(char *uplo, integer *n, real *a, integer *lda,
+ integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ real t, r1, d11, d12, d21, d22;
+ integer kk, kp;
+ real wk, wkm1, wkp1;
+ integer imax, jmax;
+ extern /* Subroutine */ int ssyr_(char *, integer *, real *, real *,
+ integer *, real *, integer *);
+ real alpha;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ integer kstep;
+ logical upper;
+ extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
+ integer *);
+ real absakk;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ real colmax;
+ extern logical sisnan_(real *);
+ real rowmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYTF2 computes the factorization of a real symmetric matrix A using */
+/* the Bunch-Kaufman diagonal pivoting method: */
+
+/* A = U*D*U' or A = L*D*L' */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, U' is the transpose of U, 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. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n-by-n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n-by-n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L (see below for further details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, D(k,k) is exactly zero. 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. */
+
+/* Further Details */
+/* =============== */
+
+/* 09-29-06 - patch from */
+/* Bobby Cheng, MathWorks */
+
+/* Replace l.204 and l.372 */
+/* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN */
+/* by */
+/* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN */
+
+/* 01-01-96 - Based on modifications by */
+/* J. Lewis, Boeing Computer Services Company */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+/* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services */
+/* Company */
+
+/* If UPLO = 'U', then A = U*D*U', where */
+/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
+/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
+/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I v 0 ) k-s */
+/* U(k) = ( 0 I 0 ) s */
+/* ( 0 0 I ) n-k */
+/* k-s s n-k */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
+/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
+/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
+
+/* If UPLO = 'L', then A = L*D*L', where */
+/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
+/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
+/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I 0 0 ) k-1 */
+/* L(k) = ( 0 I 0 ) s */
+/* ( 0 v I ) n-k-s+1 */
+/* k-1 s n-k-s+1 */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
+/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
+/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSYTF2", &i__1);
+ return 0;
+ }
+
+/* Initialize ALPHA for use in choosing pivot block size. */
+
+ alpha = (sqrt(17.f) + 1.f) / 8.f;
+
+ if (upper) {
+
+/* Factorize A as U*D*U' using the upper triangle of A */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2 */
+
+ k = *n;
+L10:
+
+/* If K < 1, exit from loop */
+
+ if (k < 1) {
+ goto L70;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ absakk = (r__1 = a[k + k * a_dim1], dabs(r__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ imax = isamax_(&i__1, &a[k * a_dim1 + 1], &c__1);
+ colmax = (r__1 = a[imax + k * a_dim1], dabs(r__1));
+ } else {
+ colmax = 0.f;
+ }
+
+ if (dmax(absakk,colmax) == 0.f || sisnan_(&absakk)) {
+
+/* Column K is zero or contains a NaN: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = k - imax;
+ jmax = imax + isamax_(&i__1, &a[imax + (imax + 1) * a_dim1],
+ lda);
+ rowmax = (r__1 = a[imax + jmax * a_dim1], dabs(r__1));
+ if (imax > 1) {
+ i__1 = imax - 1;
+ jmax = isamax_(&i__1, &a[imax * a_dim1 + 1], &c__1);
+/* Computing MAX */
+ r__2 = rowmax, r__3 = (r__1 = a[jmax + imax * a_dim1],
+ dabs(r__1));
+ rowmax = dmax(r__2,r__3);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else if ((r__1 = a[imax + imax * a_dim1], dabs(r__1)) >=
+ alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+
+ kk = k - kstep + 1;
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the leading */
+/* submatrix A(1:k,1:k) */
+
+ i__1 = kp - 1;
+ sswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1],
+ &c__1);
+ i__1 = kk - kp - 1;
+ sswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp +
+ 1) * a_dim1], lda);
+ t = a[kk + kk * a_dim1];
+ a[kk + kk * a_dim1] = a[kp + kp * a_dim1];
+ a[kp + kp * a_dim1] = t;
+ if (kstep == 2) {
+ t = a[k - 1 + k * a_dim1];
+ a[k - 1 + k * a_dim1] = a[kp + k * a_dim1];
+ a[kp + k * a_dim1] = t;
+ }
+ }
+
+/* Update the leading submatrix */
+
+ if (kstep == 1) {
+
+/* 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 */
+
+/* Perform a rank-1 update of A(1:k-1,1:k-1) as */
+
+/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */
+
+ r1 = 1.f / a[k + k * a_dim1];
+ i__1 = k - 1;
+ r__1 = -r1;
+ ssyr_(uplo, &i__1, &r__1, &a[k * a_dim1 + 1], &c__1, &a[
+ a_offset], lda);
+
+/* Store U(k) in column k */
+
+ i__1 = k - 1;
+ sscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
+ } 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) )' */
+/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */
+
+ if (k > 2) {
+
+ d12 = a[k - 1 + k * a_dim1];
+ d22 = a[k - 1 + (k - 1) * a_dim1] / d12;
+ d11 = a[k + k * a_dim1] / d12;
+ t = 1.f / (d11 * d22 - 1.f);
+ d12 = t / d12;
+
+ for (j = k - 2; j >= 1; --j) {
+ wkm1 = d12 * (d11 * a[j + (k - 1) * a_dim1] - a[j + k
+ * a_dim1]);
+ wk = d12 * (d22 * a[j + k * a_dim1] - a[j + (k - 1) *
+ a_dim1]);
+ for (i__ = j; i__ >= 1; --i__) {
+ a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__
+ + k * a_dim1] * wk - a[i__ + (k - 1) *
+ a_dim1] * wkm1;
+/* L20: */
+ }
+ a[j + k * a_dim1] = wk;
+ a[j + (k - 1) * a_dim1] = wkm1;
+/* L30: */
+ }
+
+ }
+
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k - 1] = -kp;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kstep;
+ goto L10;
+
+ } else {
+
+/* Factorize A as L*D*L' using the lower triangle of A */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2 */
+
+ k = 1;
+L40:
+
+/* If K > N, exit from loop */
+
+ if (k > *n) {
+ goto L70;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ absakk = (r__1 = a[k + k * a_dim1], dabs(r__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ imax = k + isamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1);
+ colmax = (r__1 = a[imax + k * a_dim1], dabs(r__1));
+ } else {
+ colmax = 0.f;
+ }
+
+ if (dmax(absakk,colmax) == 0.f || sisnan_(&absakk)) {
+
+/* Column K is zero or contains a NaN: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = imax - k;
+ jmax = k - 1 + isamax_(&i__1, &a[imax + k * a_dim1], lda);
+ rowmax = (r__1 = a[imax + jmax * a_dim1], dabs(r__1));
+ if (imax < *n) {
+ i__1 = *n - imax;
+ jmax = imax + isamax_(&i__1, &a[imax + 1 + imax * a_dim1],
+ &c__1);
+/* Computing MAX */
+ r__2 = rowmax, r__3 = (r__1 = a[jmax + imax * a_dim1],
+ dabs(r__1));
+ rowmax = dmax(r__2,r__3);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else if ((r__1 = a[imax + imax * a_dim1], dabs(r__1)) >=
+ alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+
+ kk = k + kstep - 1;
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the trailing */
+/* submatrix A(k:n,k:n) */
+
+ if (kp < *n) {
+ i__1 = *n - kp;
+ sswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1
+ + kp * a_dim1], &c__1);
+ }
+ i__1 = kp - kk - 1;
+ sswap_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk +
+ 1) * a_dim1], lda);
+ t = a[kk + kk * a_dim1];
+ a[kk + kk * a_dim1] = a[kp + kp * a_dim1];
+ a[kp + kp * a_dim1] = t;
+ if (kstep == 2) {
+ t = a[k + 1 + k * a_dim1];
+ a[k + 1 + k * a_dim1] = a[kp + k * a_dim1];
+ a[kp + k * a_dim1] = t;
+ }
+ }
+
+/* Update the trailing submatrix */
+
+ if (kstep == 1) {
+
+/* 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 < *n) {
+
+/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
+
+/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */
+
+ d11 = 1.f / a[k + k * a_dim1];
+ i__1 = *n - k;
+ r__1 = -d11;
+ ssyr_(uplo, &i__1, &r__1, &a[k + 1 + k * a_dim1], &c__1, &
+ a[k + 1 + (k + 1) * a_dim1], lda);
+
+/* Store L(k) in column K */
+
+ i__1 = *n - k;
+ sscal_(&i__1, &d11, &a[k + 1 + k * a_dim1], &c__1);
+ }
+ } else {
+
+/* 2-by-2 pivot block D(k) */
+
+ if (k < *n - 1) {
+
+/* Perform a rank-2 update of A(k+2:n,k+2:n) as */
+
+/* A := A - ( (A(k) A(k+1))*D(k)**(-1) ) * (A(k) A(k+1))' */
+
+/* where L(k) and L(k+1) are the k-th and (k+1)-th */
+/* columns of L */
+
+ d21 = a[k + 1 + k * a_dim1];
+ d11 = a[k + 1 + (k + 1) * a_dim1] / d21;
+ d22 = a[k + k * a_dim1] / d21;
+ t = 1.f / (d11 * d22 - 1.f);
+ d21 = t / d21;
+
+ i__1 = *n;
+ for (j = k + 2; j <= i__1; ++j) {
+
+ wk = d21 * (d11 * a[j + k * a_dim1] - a[j + (k + 1) *
+ a_dim1]);
+ wkp1 = d21 * (d22 * a[j + (k + 1) * a_dim1] - a[j + k
+ * a_dim1]);
+
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__
+ + k * a_dim1] * wk - a[i__ + (k + 1) *
+ a_dim1] * wkp1;
+/* L50: */
+ }
+
+ a[j + k * a_dim1] = wk;
+ a[j + (k + 1) * a_dim1] = wkp1;
+
+/* L60: */
+ }
+ }
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k + 1] = -kp;
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kstep;
+ goto L40;
+
+ }
+
+L70:
+
+ return 0;
+
+/* End of SSYTF2 */
+
+} /* ssytf2_ */
diff --git a/SRC/ssytrd.c b/SRC/ssytrd.c
new file mode 100644
index 0000000..d4fe7b4
--- /dev/null
+++ b/SRC/ssytrd.c
@@ -0,0 +1,360 @@
+/* ssytrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+static real c_b22 = -1.f;
+static real c_b23 = 1.f;
+
+/* Subroutine */ int ssytrd_(char *uplo, integer *n, real *a, integer *lda,
+ real *d__, real *e, real *tau, real *work, integer *lwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, nb, kk, nx, iws;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ logical upper;
+ extern /* Subroutine */ int ssytd2_(char *, integer *, real *, integer *,
+ real *, real *, real *, integer *), ssyr2k_(char *, char *
+, integer *, integer *, real *, real *, integer *, real *,
+ integer *, real *, real *, integer *), xerbla_(
+ char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slatrd_(char *, integer *, integer *, real *,
+ integer *, real *, real *, real *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYTRD reduces a real symmetric matrix A to real symmetric */
+/* tridiagonal form T by an orthogonal similarity transformation: */
+/* Q**T * A * Q = T. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (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 UPLO = 'U', the diagonal and first superdiagonal */
+/* of A are overwritten by the corresponding elements of the */
+/* tridiagonal matrix T, and the elements above the first */
+/* superdiagonal, with the array TAU, represent the orthogonal */
+/* matrix Q as a product of elementary reflectors; if UPLO */
+/* = 'L', the diagonal and first subdiagonal of A are over- */
+/* written by the corresponding elements of the tridiagonal */
+/* matrix T, and the elements below the first subdiagonal, with */
+/* the array TAU, represent the orthogonal matrix Q as a product */
+/* of elementary reflectors. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* D (output) REAL array, dimension (N) */
+/* The diagonal elements of the tridiagonal matrix T: */
+/* D(i) = A(i,i). */
+
+/* E (output) REAL array, dimension (N-1) */
+/* The off-diagonal elements of the tridiagonal matrix T: */
+/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */
+
+/* TAU (output) REAL array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= 1. */
+/* For optimum performance LWORK >= N*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(n-1) . . . H(2) H(1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */
+/* A(1:i-1,i+1), and tau in TAU(i). */
+
+/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(1) H(2) . . . H(n-1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real scalar, and v is a real vector with */
+/* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */
+/* and tau in TAU(i). */
+
+/* The contents of A on exit are illustrated by the following examples */
+/* with n = 5: */
+
+/* if UPLO = 'U': if UPLO = 'L': */
+
+/* ( d e v2 v3 v4 ) ( d ) */
+/* ( d e v3 v4 ) ( e d ) */
+/* ( d e v4 ) ( v1 e d ) */
+/* ( d e ) ( v1 v2 e d ) */
+/* ( d ) ( v1 v2 v3 e d ) */
+
+/* where d and e denote diagonal and off-diagonal elements of T, and vi */
+/* denotes an element of the vector defining H(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1;
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*lwork < 1 && ! lquery) {
+ *info = -9;
+ }
+
+ if (*info == 0) {
+
+/* Determine the block size. */
+
+ nb = ilaenv_(&c__1, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ work[1] = (real) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSYTRD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ work[1] = 1.f;
+ return 0;
+ }
+
+ nx = *n;
+ iws = 1;
+ if (nb > 1 && nb < *n) {
+
+/* Determine when to cross over from blocked to unblocked code */
+/* (last block is always handled by unblocked code). */
+
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__3, "SSYTRD", uplo, n, &c_n1, &c_n1, &
+ c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *n) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *n;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: determine the */
+/* minimum value of NB, and reduce NB or force use of */
+/* unblocked code by setting NX = N. */
+
+/* Computing MAX */
+ i__1 = *lwork / ldwork;
+ nb = max(i__1,1);
+ nbmin = ilaenv_(&c__2, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
+ if (nb < nbmin) {
+ nx = *n;
+ }
+ }
+ } else {
+ nx = *n;
+ }
+ } else {
+ nb = 1;
+ }
+
+ if (upper) {
+
+/* Reduce the upper triangle of A. */
+/* Columns 1:kk are handled by the unblocked method. */
+
+ kk = *n - (*n - nx + nb - 1) / nb * nb;
+ i__1 = kk + 1;
+ i__2 = -nb;
+ for (i__ = *n - nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+
+/* Reduce columns i:i+nb-1 to tridiagonal form and form the */
+/* matrix W which is needed to update the unreduced part of */
+/* the matrix */
+
+ i__3 = i__ + nb - 1;
+ slatrd_(uplo, &i__3, &nb, &a[a_offset], lda, &e[1], &tau[1], &
+ work[1], &ldwork);
+
+/* Update the unreduced submatrix A(1:i-1,1:i-1), using an */
+/* update of the form: A := A - V*W' - W*V' */
+
+ i__3 = i__ - 1;
+ ssyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a[i__ * a_dim1
+ + 1], lda, &work[1], &ldwork, &c_b23, &a[a_offset], lda);
+
+/* Copy superdiagonal elements back into A, and diagonal */
+/* elements into D */
+
+ i__3 = i__ + nb - 1;
+ for (j = i__; j <= i__3; ++j) {
+ a[j - 1 + j * a_dim1] = e[j - 1];
+ d__[j] = a[j + j * a_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Use unblocked code to reduce the last or only block */
+
+ ssytd2_(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo);
+ } else {
+
+/* Reduce the lower triangle of A */
+
+ i__2 = *n - nx;
+ i__1 = nb;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
+
+/* Reduce columns i:i+nb-1 to tridiagonal form and form the */
+/* matrix W which is needed to update the unreduced part of */
+/* the matrix */
+
+ i__3 = *n - i__ + 1;
+ slatrd_(uplo, &i__3, &nb, &a[i__ + i__ * a_dim1], lda, &e[i__], &
+ tau[i__], &work[1], &ldwork);
+
+/* Update the unreduced submatrix A(i+ib:n,i+ib:n), using */
+/* an update of the form: A := A - V*W' - W*V' */
+
+ i__3 = *n - i__ - nb + 1;
+ ssyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a[i__ + nb +
+ i__ * a_dim1], lda, &work[nb + 1], &ldwork, &c_b23, &a[
+ i__ + nb + (i__ + nb) * a_dim1], lda);
+
+/* Copy subdiagonal elements back into A, and diagonal */
+/* elements into D */
+
+ i__3 = i__ + nb - 1;
+ for (j = i__; j <= i__3; ++j) {
+ a[j + 1 + j * a_dim1] = e[j];
+ d__[j] = a[j + j * a_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Use unblocked code to reduce the last or only block */
+
+ i__1 = *n - i__ + 1;
+ ssytd2_(uplo, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__],
+ &tau[i__], &iinfo);
+ }
+
+ work[1] = (real) lwkopt;
+ return 0;
+
+/* End of SSYTRD */
+
+} /* ssytrd_ */
diff --git a/SRC/ssytrf.c b/SRC/ssytrf.c
new file mode 100644
index 0000000..bc70303
--- /dev/null
+++ b/SRC/ssytrf.c
@@ -0,0 +1,339 @@
+/* ssytrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int ssytrf_(char *uplo, integer *n, real *a, integer *lda,
+ integer *ipiv, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer j, k, kb, nb, iws;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ logical upper;
+ extern /* Subroutine */ int ssytf2_(char *, integer *, real *, integer *,
+ integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slasyf_(char *, integer *, integer *, integer
+ *, real *, integer *, integer *, real *, integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYTRF computes the factorization of a real symmetric matrix A using */
+/* the Bunch-Kaufman diagonal pivoting method. The form of the */
+/* factorization is */
+
+/* A = U*D*U**T or A = L*D*L**T */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* This is the blocked version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (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, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L (see below for further details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. 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. */
+
+/* Further Details */
+/* =============== */
+
+/* If UPLO = 'U', then A = U*D*U', where */
+/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
+/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
+/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I v 0 ) k-s */
+/* U(k) = ( 0 I 0 ) s */
+/* ( 0 0 I ) n-k */
+/* k-s s n-k */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
+/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
+/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
+
+/* If UPLO = 'L', then A = L*D*L', where */
+/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
+/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
+/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I 0 0 ) k-1 */
+/* L(k) = ( 0 I 0 ) s */
+/* ( 0 v I ) n-k-s+1 */
+/* k-1 s n-k-s+1 */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
+/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
+/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1;
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*lwork < 1 && ! lquery) {
+ *info = -7;
+ }
+
+ if (*info == 0) {
+
+/* Determine the block size */
+
+ nb = ilaenv_(&c__1, "SSYTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ work[1] = (real) lwkopt;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSYTRF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = *n;
+ if (nb > 1 && nb < *n) {
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+/* Computing MAX */
+ i__1 = *lwork / ldwork;
+ nb = max(i__1,1);
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "SSYTRF", uplo, n, &c_n1, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = 1;
+ }
+ if (nb < nbmin) {
+ nb = *n;
+ }
+
+ if (upper) {
+
+/* Factorize A as U*D*U' 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; */
+/* KB is either NB or NB-1, or K for the last block */
+
+ k = *n;
+L10:
+
+/* If K < 1, exit from loop */
+
+ if (k < 1) {
+ goto L40;
+ }
+
+ if (k > nb) {
+
+/* Factorize columns k-kb+1:k of A and use blocked code to */
+/* update columns 1:k-kb */
+
+ slasyf_(uplo, &k, &nb, &kb, &a[a_offset], lda, &ipiv[1], &work[1],
+ &ldwork, &iinfo);
+ } else {
+
+/* Use unblocked code to factorize columns 1:k of A */
+
+ ssytf2_(uplo, &k, &a[a_offset], lda, &ipiv[1], &iinfo);
+ kb = k;
+ }
+
+/* Set INFO on the first occurrence of a zero pivot */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kb;
+ goto L10;
+
+ } else {
+
+/* Factorize A as L*D*L' 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; */
+/* KB is either NB or NB-1, or N-K+1 for the last block */
+
+ k = 1;
+L20:
+
+/* If K > N, exit from loop */
+
+ if (k > *n) {
+ goto L40;
+ }
+
+ if (k <= *n - nb) {
+
+/* Factorize columns k:k+kb-1 of A and use blocked code to */
+/* update columns k+kb:n */
+
+ i__1 = *n - k + 1;
+ slasyf_(uplo, &i__1, &nb, &kb, &a[k + k * a_dim1], lda, &ipiv[k],
+ &work[1], &ldwork, &iinfo);
+ } else {
+
+/* Use unblocked code to factorize columns k:n of A */
+
+ i__1 = *n - k + 1;
+ ssytf2_(uplo, &i__1, &a[k + k * a_dim1], lda, &ipiv[k], &iinfo);
+ kb = *n - k + 1;
+ }
+
+/* Set INFO on the first occurrence of a zero pivot */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo + k - 1;
+ }
+
+/* Adjust IPIV */
+
+ i__1 = k + kb - 1;
+ for (j = k; j <= i__1; ++j) {
+ if (ipiv[j] > 0) {
+ ipiv[j] = ipiv[j] + k - 1;
+ } else {
+ ipiv[j] = ipiv[j] - k + 1;
+ }
+/* L30: */
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kb;
+ goto L20;
+
+ }
+
+L40:
+ work[1] = (real) lwkopt;
+ return 0;
+
+/* End of SSYTRF */
+
+} /* ssytrf_ */
diff --git a/SRC/ssytri.c b/SRC/ssytri.c
new file mode 100644
index 0000000..24700ba
--- /dev/null
+++ b/SRC/ssytri.c
@@ -0,0 +1,394 @@
+/* ssytri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b11 = -1.f;
+static real c_b13 = 0.f;
+
+/* Subroutine */ int ssytri_(char *uplo, integer *n, real *a, integer *lda,
+ integer *ipiv, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ real r__1;
+
+ /* Local variables */
+ real d__;
+ integer k;
+ real t, ak;
+ integer kp;
+ real akp1, temp;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ real akkp1;
+ extern logical lsame_(char *, char *);
+ integer kstep;
+ logical upper;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), sswap_(integer *, real *, integer *, real *, integer *
+), ssymv_(char *, integer *, real *, real *, integer *, real *,
+ integer *, real *, real *, integer *), xerbla_(char *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYTRI computes the inverse of a real symmetric indefinite matrix */
+/* A using the factorization A = U*D*U**T or A = L*D*L**T computed by */
+/* SSYTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L as computed by SSYTRF. */
+
+/* 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. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by SSYTRF. */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) 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. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSYTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ for (*info = *n; *info >= 1; --(*info)) {
+ if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.f) {
+ return 0;
+ }
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.f) {
+ return 0;
+ }
+/* L20: */
+ }
+ }
+ *info = 0;
+
+ if (upper) {
+
+/* Compute inv(A) from the factorization A = U*D*U'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+L30:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L40;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ a[k + k * a_dim1] = 1.f / a[k + k * a_dim1];
+
+/* Compute column K of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ scopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ ssymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
+ c__1, &c_b13, &a[k * a_dim1 + 1], &c__1);
+ i__1 = k - 1;
+ a[k + k * a_dim1] -= sdot_(&i__1, &work[1], &c__1, &a[k *
+ a_dim1 + 1], &c__1);
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ t = (r__1 = a[k + (k + 1) * a_dim1], dabs(r__1));
+ ak = a[k + k * a_dim1] / t;
+ akp1 = a[k + 1 + (k + 1) * a_dim1] / t;
+ akkp1 = a[k + (k + 1) * a_dim1] / t;
+ d__ = t * (ak * akp1 - 1.f);
+ a[k + k * a_dim1] = akp1 / d__;
+ a[k + 1 + (k + 1) * a_dim1] = ak / d__;
+ a[k + (k + 1) * a_dim1] = -akkp1 / d__;
+
+/* Compute columns K and K+1 of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ scopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ ssymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
+ c__1, &c_b13, &a[k * a_dim1 + 1], &c__1);
+ i__1 = k - 1;
+ a[k + k * a_dim1] -= sdot_(&i__1, &work[1], &c__1, &a[k *
+ a_dim1 + 1], &c__1);
+ i__1 = k - 1;
+ a[k + (k + 1) * a_dim1] -= sdot_(&i__1, &a[k * a_dim1 + 1], &
+ c__1, &a[(k + 1) * a_dim1 + 1], &c__1);
+ i__1 = k - 1;
+ scopy_(&i__1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], &
+ c__1);
+ i__1 = k - 1;
+ ssymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
+ c__1, &c_b13, &a[(k + 1) * a_dim1 + 1], &c__1);
+ i__1 = k - 1;
+ a[k + 1 + (k + 1) * a_dim1] -= sdot_(&i__1, &work[1], &c__1, &
+ a[(k + 1) * a_dim1 + 1], &c__1);
+ }
+ kstep = 2;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the leading */
+/* submatrix A(1:k+1,1:k+1) */
+
+ i__1 = kp - 1;
+ sswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &
+ c__1);
+ i__1 = k - kp - 1;
+ sswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1) *
+ a_dim1], lda);
+ temp = a[k + k * a_dim1];
+ a[k + k * a_dim1] = a[kp + kp * a_dim1];
+ a[kp + kp * a_dim1] = temp;
+ if (kstep == 2) {
+ temp = a[k + (k + 1) * a_dim1];
+ a[k + (k + 1) * a_dim1] = a[kp + (k + 1) * a_dim1];
+ a[kp + (k + 1) * a_dim1] = temp;
+ }
+ }
+
+ k += kstep;
+ goto L30;
+L40:
+
+ ;
+ } else {
+
+/* Compute inv(A) from the factorization A = L*D*L'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+L50:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L60;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ a[k + k * a_dim1] = 1.f / a[k + k * a_dim1];
+
+/* Compute column K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ scopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ ssymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda,
+ &work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], &
+ c__1);
+ i__1 = *n - k;
+ a[k + k * a_dim1] -= sdot_(&i__1, &work[1], &c__1, &a[k + 1 +
+ k * a_dim1], &c__1);
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ t = (r__1 = a[k + (k - 1) * a_dim1], dabs(r__1));
+ ak = a[k - 1 + (k - 1) * a_dim1] / t;
+ akp1 = a[k + k * a_dim1] / t;
+ akkp1 = a[k + (k - 1) * a_dim1] / t;
+ d__ = t * (ak * akp1 - 1.f);
+ a[k - 1 + (k - 1) * a_dim1] = akp1 / d__;
+ a[k + k * a_dim1] = ak / d__;
+ a[k + (k - 1) * a_dim1] = -akkp1 / d__;
+
+/* Compute columns K-1 and K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ scopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ ssymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda,
+ &work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], &
+ c__1);
+ i__1 = *n - k;
+ a[k + k * a_dim1] -= sdot_(&i__1, &work[1], &c__1, &a[k + 1 +
+ k * a_dim1], &c__1);
+ i__1 = *n - k;
+ a[k + (k - 1) * a_dim1] -= sdot_(&i__1, &a[k + 1 + k * a_dim1]
+, &c__1, &a[k + 1 + (k - 1) * a_dim1], &c__1);
+ i__1 = *n - k;
+ scopy_(&i__1, &a[k + 1 + (k - 1) * a_dim1], &c__1, &work[1], &
+ c__1);
+ i__1 = *n - k;
+ ssymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda,
+ &work[1], &c__1, &c_b13, &a[k + 1 + (k - 1) * a_dim1]
+, &c__1);
+ i__1 = *n - k;
+ a[k - 1 + (k - 1) * a_dim1] -= sdot_(&i__1, &work[1], &c__1, &
+ a[k + 1 + (k - 1) * a_dim1], &c__1);
+ }
+ kstep = 2;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the trailing */
+/* submatrix A(k-1:n,k-1:n) */
+
+ if (kp < *n) {
+ i__1 = *n - kp;
+ sswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + kp *
+ a_dim1], &c__1);
+ }
+ i__1 = kp - k - 1;
+ sswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) *
+ a_dim1], lda);
+ temp = a[k + k * a_dim1];
+ a[k + k * a_dim1] = a[kp + kp * a_dim1];
+ a[kp + kp * a_dim1] = temp;
+ if (kstep == 2) {
+ temp = a[k + (k - 1) * a_dim1];
+ a[k + (k - 1) * a_dim1] = a[kp + (k - 1) * a_dim1];
+ a[kp + (k - 1) * a_dim1] = temp;
+ }
+ }
+
+ k -= kstep;
+ goto L50;
+L60:
+ ;
+ }
+
+ return 0;
+
+/* End of SSYTRI */
+
+} /* ssytri_ */
diff --git a/SRC/ssytrs.c b/SRC/ssytrs.c
new file mode 100644
index 0000000..a27e5e1
--- /dev/null
+++ b/SRC/ssytrs.c
@@ -0,0 +1,449 @@
+/* ssytrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b7 = -1.f;
+static integer c__1 = 1;
+static real c_b19 = 1.f;
+
+/* Subroutine */ int ssytrs_(char *uplo, integer *n, integer *nrhs, real *a,
+ integer *lda, integer *ipiv, real *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+ real r__1;
+
+ /* Local variables */
+ integer j, k;
+ real ak, bk;
+ integer kp;
+ real akm1, bkm1;
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ real akm1k;
+ extern logical lsame_(char *, char *);
+ real denom;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ sgemv_(char *, integer *, integer *, real *, real *, integer *,
+ real *, integer *, real *, real *, integer *);
+ logical upper;
+ extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
+ integer *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYTRS solves a system of linear equations A*X = B with a real */
+/* symmetric matrix A using the factorization A = U*D*U**T or */
+/* A = L*D*L**T computed by SSYTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by SSYTRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by SSYTRF. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SSYTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B, where A = U*D*U'. */
+
+/* First solve U*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+L10:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L30;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ i__1 = k - 1;
+ sger_(&i__1, nrhs, &c_b7, &a[k * a_dim1 + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ r__1 = 1.f / a[k + k * a_dim1];
+ sscal_(nrhs, &r__1, &b[k + b_dim1], ldb);
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K-1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k - 1) {
+ sswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ i__1 = k - 2;
+ sger_(&i__1, nrhs, &c_b7, &a[k * a_dim1 + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+ i__1 = k - 2;
+ sger_(&i__1, nrhs, &c_b7, &a[(k - 1) * a_dim1 + 1], &c__1, &b[k -
+ 1 + b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ akm1k = a[k - 1 + k * a_dim1];
+ akm1 = a[k - 1 + (k - 1) * a_dim1] / akm1k;
+ ak = a[k + k * a_dim1] / akm1k;
+ denom = akm1 * ak - 1.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bkm1 = b[k - 1 + j * b_dim1] / akm1k;
+ bk = b[k + j * b_dim1] / akm1k;
+ b[k - 1 + j * b_dim1] = (ak * bkm1 - bk) / denom;
+ b[k + j * b_dim1] = (akm1 * bk - bkm1) / denom;
+/* L20: */
+ }
+ k += -2;
+ }
+
+ goto L10;
+L30:
+
+/* Next solve U'*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+L40:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L50;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(U'(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ i__1 = k - 1;
+ sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[k *
+ a_dim1 + 1], &c__1, &c_b19, &b[k + b_dim1], ldb);
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ i__1 = k - 1;
+ sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[k *
+ a_dim1 + 1], &c__1, &c_b19, &b[k + b_dim1], ldb);
+ i__1 = k - 1;
+ sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[(k
+ + 1) * a_dim1 + 1], &c__1, &c_b19, &b[k + 1 + b_dim1],
+ ldb);
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ k += 2;
+ }
+
+ goto L40;
+L50:
+
+ ;
+ } else {
+
+/* Solve A*X = B, where A = L*D*L'. */
+
+/* First solve L*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+L60:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L80;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ sger_(&i__1, nrhs, &c_b7, &a[k + 1 + k * a_dim1], &c__1, &b[k
+ + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ r__1 = 1.f / a[k + k * a_dim1];
+ sscal_(nrhs, &r__1, &b[k + b_dim1], ldb);
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K+1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k + 1) {
+ sswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ if (k < *n - 1) {
+ i__1 = *n - k - 1;
+ sger_(&i__1, nrhs, &c_b7, &a[k + 2 + k * a_dim1], &c__1, &b[k
+ + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ sger_(&i__1, nrhs, &c_b7, &a[k + 2 + (k + 1) * a_dim1], &c__1,
+ &b[k + 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ akm1k = a[k + 1 + k * a_dim1];
+ akm1 = a[k + k * a_dim1] / akm1k;
+ ak = a[k + 1 + (k + 1) * a_dim1] / akm1k;
+ denom = akm1 * ak - 1.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bkm1 = b[k + j * b_dim1] / akm1k;
+ bk = b[k + 1 + j * b_dim1] / akm1k;
+ b[k + j * b_dim1] = (ak * bkm1 - bk) / denom;
+ b[k + 1 + j * b_dim1] = (akm1 * bk - bkm1) / denom;
+/* L70: */
+ }
+ k += 2;
+ }
+
+ goto L60;
+L80:
+
+/* Next solve L'*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+L90:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L100;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(L'(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1],
+ ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b19, &b[k +
+ b_dim1], ldb);
+ }
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1],
+ ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b19, &b[k +
+ b_dim1], ldb);
+ i__1 = *n - k;
+ sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1],
+ ldb, &a[k + 1 + (k - 1) * a_dim1], &c__1, &c_b19, &b[
+ k - 1 + b_dim1], ldb);
+ }
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ k += -2;
+ }
+
+ goto L90;
+L100:
+ ;
+ }
+
+ return 0;
+
+/* End of SSYTRS */
+
+} /* ssytrs_ */
diff --git a/SRC/stbcon.c b/SRC/stbcon.c
new file mode 100644
index 0000000..a567270
--- /dev/null
+++ b/SRC/stbcon.c
@@ -0,0 +1,247 @@
+/* stbcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int stbcon_(char *norm, char *uplo, char *diag, integer *n,
+ integer *kd, real *ab, integer *ldab, real *rcond, real *work,
+ integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1;
+ real r__1;
+
+ /* Local variables */
+ integer ix, kase, kase1;
+ real scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ real anorm;
+ extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *);
+ logical upper;
+ real xnorm;
+ extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *,
+ real *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ extern doublereal slantb_(char *, char *, char *, integer *, integer *,
+ real *, integer *, real *);
+ real ainvnm;
+ extern /* Subroutine */ int slatbs_(char *, char *, char *, char *,
+ integer *, integer *, real *, integer *, real *, real *, real *,
+ integer *);
+ logical onenrm;
+ char normin[1];
+ real smlnum;
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STBCON estimates the reciprocal of the condition number of a */
+/* triangular band matrix A, in either the 1-norm or the infinity-norm. */
+
+/* The norm of A is computed and an estimate is obtained for */
+/* norm(inv(A)), then the reciprocal of the condition number is */
+/* computed as */
+/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* AB (input) REAL array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* RCOND (output) REAL */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ nounit = lsame_(diag, "N");
+
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*kd < 0) {
+ *info = -5;
+ } else if (*ldab < *kd + 1) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STBCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ }
+
+ *rcond = 0.f;
+ smlnum = slamch_("Safe minimum") * (real) max(1,*n);
+
+/* Compute the norm of the triangular matrix A. */
+
+ anorm = slantb_(norm, uplo, diag, n, kd, &ab[ab_offset], ldab, &work[1]);
+
+/* Continue only if ANORM > 0. */
+
+ if (anorm > 0.f) {
+
+/* Estimate the norm of the inverse of A. */
+
+ ainvnm = 0.f;
+ *(unsigned char *)normin = 'N';
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kase = 0;
+L10:
+ slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(A). */
+
+ slatbs_(uplo, "No transpose", diag, normin, n, kd, &ab[
+ ab_offset], ldab, &work[1], &scale, &work[(*n << 1) +
+ 1], info)
+ ;
+ } else {
+
+/* Multiply by inv(A'). */
+
+ slatbs_(uplo, "Transpose", diag, normin, n, kd, &ab[ab_offset]
+, ldab, &work[1], &scale, &work[(*n << 1) + 1], info);
+ }
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ if (scale != 1.f) {
+ ix = isamax_(n, &work[1], &c__1);
+ xnorm = (r__1 = work[ix], dabs(r__1));
+ if (scale < xnorm * smlnum || scale == 0.f) {
+ goto L20;
+ }
+ srscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / anorm / ainvnm;
+ }
+ }
+
+L20:
+ return 0;
+
+/* End of STBCON */
+
+} /* stbcon_ */
diff --git a/SRC/stbrfs.c b/SRC/stbrfs.c
new file mode 100644
index 0000000..3ef7749
--- /dev/null
+++ b/SRC/stbrfs.c
@@ -0,0 +1,519 @@
+/* stbrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b19 = -1.f;
+
+/* Subroutine */ int stbrfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, real *ab, integer *ldab, real *b, integer
+ *ldb, real *x, integer *ldx, real *ferr, real *berr, real *work,
+ integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1,
+ i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ real s, xk;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), stbmv_(char *, char *, char *, integer *, integer *,
+ real *, integer *, real *, integer *),
+ stbsv_(char *, char *, char *, integer *, integer *, real *,
+ integer *, real *, integer *), saxpy_(
+ integer *, real *, real *, integer *, real *, integer *), slacn2_(
+ integer *, real *, real *, integer *, real *, integer *, integer *
+);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+ char transt[1];
+ logical nounit;
+ real lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STBRFS provides error bounds and backward error estimates for the */
+/* solution to a system of linear equations with a triangular band */
+/* coefficient matrix. */
+
+/* The solution matrix X must be computed by STBTRS or some other */
+/* means before entering this routine. STBRFS does not do iterative */
+/* refinement because doing so cannot improve the backward error. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input) REAL array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*kd < 0) {
+ *info = -5;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*ldab < *kd + 1) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldx < max(1,*n)) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STBRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *kd + 2;
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A or A', depending on TRANS. */
+
+ scopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+ stbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[*n + 1],
+ &c__1);
+ saxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] = (r__1 = b[i__ + j * b_dim1], dabs(r__1));
+/* L20: */
+ }
+
+ if (notran) {
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+/* Computing MAX */
+ i__3 = 1, i__4 = k - *kd;
+ i__5 = k;
+ for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
+ work[i__] += (r__1 = ab[*kd + 1 + i__ - k + k *
+ ab_dim1], dabs(r__1)) * xk;
+/* L30: */
+ }
+/* L40: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+/* Computing MAX */
+ i__5 = 1, i__3 = k - *kd;
+ i__4 = k - 1;
+ for (i__ = max(i__5,i__3); i__ <= i__4; ++i__) {
+ work[i__] += (r__1 = ab[*kd + 1 + i__ - k + k *
+ ab_dim1], dabs(r__1)) * xk;
+/* L50: */
+ }
+ work[k] += xk;
+/* L60: */
+ }
+ }
+ } else {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+/* Computing MIN */
+ i__5 = *n, i__3 = k + *kd;
+ i__4 = min(i__5,i__3);
+ for (i__ = k; i__ <= i__4; ++i__) {
+ work[i__] += (r__1 = ab[i__ + 1 - k + k * ab_dim1]
+ , dabs(r__1)) * xk;
+/* L70: */
+ }
+/* L80: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+/* Computing MIN */
+ i__5 = *n, i__3 = k + *kd;
+ i__4 = min(i__5,i__3);
+ for (i__ = k + 1; i__ <= i__4; ++i__) {
+ work[i__] += (r__1 = ab[i__ + 1 - k + k * ab_dim1]
+ , dabs(r__1)) * xk;
+/* L90: */
+ }
+ work[k] += xk;
+/* L100: */
+ }
+ }
+ }
+ } else {
+
+/* Compute abs(A')*abs(X) + abs(B). */
+
+ if (upper) {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+/* Computing MAX */
+ i__4 = 1, i__5 = k - *kd;
+ i__3 = k;
+ for (i__ = max(i__4,i__5); i__ <= i__3; ++i__) {
+ s += (r__1 = ab[*kd + 1 + i__ - k + k * ab_dim1],
+ dabs(r__1)) * (r__2 = x[i__ + j * x_dim1],
+ dabs(r__2));
+/* L110: */
+ }
+ work[k] += s;
+/* L120: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = (r__1 = x[k + j * x_dim1], dabs(r__1));
+/* Computing MAX */
+ i__3 = 1, i__4 = k - *kd;
+ i__5 = k - 1;
+ for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
+ s += (r__1 = ab[*kd + 1 + i__ - k + k * ab_dim1],
+ dabs(r__1)) * (r__2 = x[i__ + j * x_dim1],
+ dabs(r__2));
+/* L130: */
+ }
+ work[k] += s;
+/* L140: */
+ }
+ }
+ } else {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+/* Computing MIN */
+ i__3 = *n, i__4 = k + *kd;
+ i__5 = min(i__3,i__4);
+ for (i__ = k; i__ <= i__5; ++i__) {
+ s += (r__1 = ab[i__ + 1 - k + k * ab_dim1], dabs(
+ r__1)) * (r__2 = x[i__ + j * x_dim1],
+ dabs(r__2));
+/* L150: */
+ }
+ work[k] += s;
+/* L160: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = (r__1 = x[k + j * x_dim1], dabs(r__1));
+/* Computing MIN */
+ i__3 = *n, i__4 = k + *kd;
+ i__5 = min(i__3,i__4);
+ for (i__ = k + 1; i__ <= i__5; ++i__) {
+ s += (r__1 = ab[i__ + 1 - k + k * ab_dim1], dabs(
+ r__1)) * (r__2 = x[i__ + j * x_dim1],
+ dabs(r__2));
+/* L170: */
+ }
+ work[k] += s;
+/* L180: */
+ }
+ }
+ }
+ }
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[
+ i__];
+ s = dmax(r__2,r__3);
+ } else {
+/* Computing MAX */
+ r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1)
+ / (work[i__] + safe1);
+ s = dmax(r__2,r__3);
+ }
+/* L190: */
+ }
+ berr[j] = s;
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use SLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L200: */
+ }
+
+ kase = 0;
+L210:
+ slacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+ kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)'). */
+
+ stbsv_(uplo, transt, diag, n, kd, &ab[ab_offset], ldab, &work[
+ *n + 1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L220: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L230: */
+ }
+ stbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[*
+ n + 1], &c__1);
+ }
+ goto L210;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], dabs(r__1));
+ lstres = dmax(r__2,r__3);
+/* L240: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L250: */
+ }
+
+ return 0;
+
+/* End of STBRFS */
+
+} /* stbrfs_ */
diff --git a/SRC/stbtrs.c b/SRC/stbtrs.c
new file mode 100644
index 0000000..3fdcfa2
--- /dev/null
+++ b/SRC/stbtrs.c
@@ -0,0 +1,203 @@
+/* stbtrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int stbtrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, real *ab, integer *ldab, real *b, integer
+ *ldb, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ integer j;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int stbsv_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *);
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STBTRS solves a triangular system of the form */
+
+/* A * X = B or A**T * X = B, */
+
+/* where A is a triangular band matrix of order N, and B is an */
+/* N-by NRHS matrix. A check is made to verify that A is nonsingular. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AB (input) REAL array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of AB. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, if INFO = 0, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element of A is zero, */
+/* indicating that the matrix is singular and the */
+/* solutions X have not been computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ nounit = lsame_(diag, "N");
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*kd < 0) {
+ *info = -5;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*ldab < *kd + 1) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STBTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check for singularity. */
+
+ if (nounit) {
+ if (upper) {
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ if (ab[*kd + 1 + *info * ab_dim1] == 0.f) {
+ return 0;
+ }
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ if (ab[*info * ab_dim1 + 1] == 0.f) {
+ return 0;
+ }
+/* L20: */
+ }
+ }
+ }
+ *info = 0;
+
+/* Solve A * X = B or A' * X = B. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ stbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &b[j * b_dim1
+ + 1], &c__1);
+/* L30: */
+ }
+
+ return 0;
+
+/* End of STBTRS */
+
+} /* stbtrs_ */
diff --git a/SRC/stfsm.c b/SRC/stfsm.c
new file mode 100644
index 0000000..caec119
--- /dev/null
+++ b/SRC/stfsm.c
@@ -0,0 +1,973 @@
+/* stfsm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b23 = -1.f;
+static real c_b27 = 1.f;
+
+/* Subroutine */ int stfsm_(char *transr, char *side, char *uplo, char *trans,
+ char *diag, integer *m, integer *n, real *alpha, real *a, real *b,
+ integer *ldb)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k, m1, m2, n1, n2, info;
+ logical normaltransr, lside;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ logical lower;
+ extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), xerbla_(char *, integer *);
+ logical misodd, nisodd, notrans;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Level 3 BLAS like routine for A in RFP Format. */
+
+/* STFSM solves the matrix equation */
+
+/* op( A )*X = alpha*B or X*op( A ) = alpha*B */
+
+/* where alpha is a scalar, X and B are m by n matrices, A is a unit, or */
+/* non-unit, upper or lower triangular matrix and op( A ) is one of */
+
+/* op( A ) = A or op( A ) = A'. */
+
+/* A is in Rectangular Full Packed (RFP) Format. */
+
+/* The matrix X is overwritten on B. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANSR - (input) CHARACTER */
+/* = 'N': The Normal Form of RFP A is stored; */
+/* = 'T': The Transpose Form of RFP A is stored. */
+
+/* SIDE - (input) CHARACTER */
+/* On entry, SIDE specifies whether op( A ) appears on the left */
+/* or right of X as follows: */
+
+/* SIDE = 'L' or 'l' op( A )*X = alpha*B. */
+
+/* SIDE = 'R' or 'r' X*op( A ) = alpha*B. */
+
+/* Unchanged on exit. */
+
+/* UPLO - (input) CHARACTER */
+/* On entry, UPLO specifies whether the RFP matrix A came from */
+/* an upper or lower triangular matrix as follows: */
+/* UPLO = 'U' or 'u' RFP A came from an upper triangular matrix */
+/* UPLO = 'L' or 'l' RFP A came from a lower triangular matrix */
+
+/* Unchanged on exit. */
+
+/* TRANS - (input) CHARACTER */
+/* On entry, TRANS specifies the form of op( A ) to be used */
+/* in the matrix multiplication as follows: */
+
+/* TRANS = 'N' or 'n' op( A ) = A. */
+
+/* TRANS = 'T' or 't' op( A ) = A'. */
+
+/* Unchanged on exit. */
+
+/* DIAG - (input) CHARACTER */
+/* On entry, DIAG specifies whether or not RFP A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* M - (input) INTEGER. */
+/* On entry, M specifies the number of rows of B. M must be at */
+/* least zero. */
+/* Unchanged on exit. */
+
+/* N - (input) INTEGER. */
+/* On entry, N specifies the number of columns of B. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - (input) REAL. */
+/* On entry, ALPHA specifies the scalar alpha. When alpha is */
+/* zero then A is not referenced and B need not be set before */
+/* entry. */
+/* Unchanged on exit. */
+
+/* A - (input) REAL array, dimension (NT); */
+/* NT = N*(N+1)/2. On entry, the matrix A in RFP Format. */
+/* RFP Format is described by TRANSR, UPLO and N as follows: */
+/* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even; */
+/* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If */
+/* TRANSR = 'T' then RFP is the transpose of RFP A as */
+/* defined when TRANSR = 'N'. The contents of RFP A are defined */
+/* by UPLO as follows: If UPLO = 'U' the RFP A contains the NT */
+/* elements of upper packed A either in normal or */
+/* transpose Format. If UPLO = 'L' the RFP A contains */
+/* the NT elements of lower packed A either in normal or */
+/* transpose Format. The LDA of RFP A is (N+1)/2 when */
+/* TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is */
+/* even and is N when is odd. */
+/* See the Note below for more details. Unchanged on exit. */
+
+/* B - (input/ouptut) REAL array, DIMENSION (LDB,N) */
+/* Before entry, the leading m by n part of the array B must */
+/* contain the right-hand side matrix B, and on exit is */
+/* overwritten by the solution matrix X. */
+
+/* LDB - (input) INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. LDB must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+/* Further Details */
+/* =============== */
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* even. We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* the transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* the transpose of the last three columns of AP lower. */
+/* This covers the case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 03 04 05 33 43 53 */
+/* 13 14 15 00 44 54 */
+/* 23 24 25 10 11 55 */
+/* 33 34 35 20 21 22 */
+/* 00 44 45 30 31 32 */
+/* 01 11 55 40 41 42 */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* odd. We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* the transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* the transpose of the last two columns of AP lower. */
+/* This covers the case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 02 03 04 00 33 43 */
+/* 12 13 14 10 11 44 */
+/* 22 23 24 20 21 22 */
+/* 00 33 34 30 31 32 */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+/* RFP A RFP A */
+
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* Reference */
+/* ========= */
+
+/* ===================================================================== */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ b_dim1 = *ldb - 1 - 0 + 1;
+ b_offset = 0 + b_dim1 * 0;
+ b -= b_offset;
+
+ /* Function Body */
+ info = 0;
+ normaltransr = lsame_(transr, "N");
+ lside = lsame_(side, "L");
+ lower = lsame_(uplo, "L");
+ notrans = lsame_(trans, "N");
+ if (! normaltransr && ! lsame_(transr, "T")) {
+ info = -1;
+ } else if (! lside && ! lsame_(side, "R")) {
+ info = -2;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ info = -3;
+ } else if (! notrans && ! lsame_(trans, "T")) {
+ info = -4;
+ } else if (! lsame_(diag, "N") && ! lsame_(diag,
+ "U")) {
+ info = -5;
+ } else if (*m < 0) {
+ info = -6;
+ } else if (*n < 0) {
+ info = -7;
+ } else if (*ldb < max(1,*m)) {
+ info = -11;
+ }
+ if (info != 0) {
+ i__1 = -info;
+ xerbla_("STFSM ", &i__1);
+ return 0;
+ }
+
+/* Quick return when ( (N.EQ.0).OR.(M.EQ.0) ) */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Quick return when ALPHA.EQ.(0D+0) */
+
+ if (*alpha == 0.f) {
+ i__1 = *n - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *m - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ return 0;
+ }
+
+ if (lside) {
+
+/* SIDE = 'L' */
+
+/* A is M-by-M. */
+/* If M is odd, set NISODD = .TRUE., and M1 and M2. */
+/* If M is even, NISODD = .FALSE., and M. */
+
+ if (*m % 2 == 0) {
+ misodd = FALSE_;
+ k = *m / 2;
+ } else {
+ misodd = TRUE_;
+ if (lower) {
+ m2 = *m / 2;
+ m1 = *m - m2;
+ } else {
+ m1 = *m / 2;
+ m2 = *m - m1;
+ }
+ }
+
+ if (misodd) {
+
+/* SIDE = 'L' and N is odd */
+
+ if (normaltransr) {
+
+/* SIDE = 'L', N is odd, and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and */
+/* TRANS = 'N' */
+
+ if (*m == 1) {
+ strsm_("L", "L", "N", diag, &m1, n, alpha, a, m, &
+ b[b_offset], ldb);
+ } else {
+ strsm_("L", "L", "N", diag, &m1, n, alpha, a, m, &
+ b[b_offset], ldb);
+ sgemm_("N", "N", &m2, n, &m1, &c_b23, &a[m1], m, &
+ b[b_offset], ldb, alpha, &b[m1], ldb);
+ strsm_("L", "U", "T", diag, &m2, n, &c_b27, &a[*m]
+, m, &b[m1], ldb);
+ }
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and */
+/* TRANS = 'T' */
+
+ if (*m == 1) {
+ strsm_("L", "L", "T", diag, &m1, n, alpha, a, m, &
+ b[b_offset], ldb);
+ } else {
+ strsm_("L", "U", "N", diag, &m2, n, alpha, &a[*m],
+ m, &b[m1], ldb);
+ sgemm_("T", "N", &m1, n, &m2, &c_b23, &a[m1], m, &
+ b[m1], ldb, alpha, &b[b_offset], ldb);
+ strsm_("L", "L", "T", diag, &m1, n, &c_b27, a, m,
+ &b[b_offset], ldb);
+ }
+
+ }
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'U' */
+
+ if (! notrans) {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and */
+/* TRANS = 'N' */
+
+ strsm_("L", "L", "N", diag, &m1, n, alpha, &a[m2], m,
+ &b[b_offset], ldb);
+ sgemm_("T", "N", &m2, n, &m1, &c_b23, a, m, &b[
+ b_offset], ldb, alpha, &b[m1], ldb);
+ strsm_("L", "U", "T", diag, &m2, n, &c_b27, &a[m1], m,
+ &b[m1], ldb);
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and */
+/* TRANS = 'T' */
+
+ strsm_("L", "U", "N", diag, &m2, n, alpha, &a[m1], m,
+ &b[m1], ldb);
+ sgemm_("N", "N", &m1, n, &m2, &c_b23, a, m, &b[m1],
+ ldb, alpha, &b[b_offset], ldb);
+ strsm_("L", "L", "T", diag, &m1, n, &c_b27, &a[m2], m,
+ &b[b_offset], ldb);
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'L', N is odd, and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and */
+/* TRANS = 'N' */
+
+ if (*m == 1) {
+ strsm_("L", "U", "T", diag, &m1, n, alpha, a, &m1,
+ &b[b_offset], ldb);
+ } else {
+ strsm_("L", "U", "T", diag, &m1, n, alpha, a, &m1,
+ &b[b_offset], ldb);
+ sgemm_("T", "N", &m2, n, &m1, &c_b23, &a[m1 * m1],
+ &m1, &b[b_offset], ldb, alpha, &b[m1],
+ ldb);
+ strsm_("L", "L", "N", diag, &m2, n, &c_b27, &a[1],
+ &m1, &b[m1], ldb);
+ }
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and */
+/* TRANS = 'T' */
+
+ if (*m == 1) {
+ strsm_("L", "U", "N", diag, &m1, n, alpha, a, &m1,
+ &b[b_offset], ldb);
+ } else {
+ strsm_("L", "L", "T", diag, &m2, n, alpha, &a[1],
+ &m1, &b[m1], ldb);
+ sgemm_("N", "N", &m1, n, &m2, &c_b23, &a[m1 * m1],
+ &m1, &b[m1], ldb, alpha, &b[b_offset],
+ ldb);
+ strsm_("L", "U", "N", diag, &m1, n, &c_b27, a, &
+ m1, &b[b_offset], ldb);
+ }
+
+ }
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'U' */
+
+ if (! notrans) {
+
+/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and */
+/* TRANS = 'N' */
+
+ strsm_("L", "U", "T", diag, &m1, n, alpha, &a[m2 * m2]
+, &m2, &b[b_offset], ldb);
+ sgemm_("N", "N", &m2, n, &m1, &c_b23, a, &m2, &b[
+ b_offset], ldb, alpha, &b[m1], ldb);
+ strsm_("L", "L", "N", diag, &m2, n, &c_b27, &a[m1 *
+ m2], &m2, &b[m1], ldb);
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and */
+/* TRANS = 'T' */
+
+ strsm_("L", "L", "T", diag, &m2, n, alpha, &a[m1 * m2]
+, &m2, &b[m1], ldb);
+ sgemm_("T", "N", &m1, n, &m2, &c_b23, a, &m2, &b[m1],
+ ldb, alpha, &b[b_offset], ldb);
+ strsm_("L", "U", "N", diag, &m1, n, &c_b27, &a[m2 *
+ m2], &m2, &b[b_offset], ldb);
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'L' and N is even */
+
+ if (normaltransr) {
+
+/* SIDE = 'L', N is even, and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', */
+/* and TRANS = 'N' */
+
+ i__1 = *m + 1;
+ strsm_("L", "L", "N", diag, &k, n, alpha, &a[1], &
+ i__1, &b[b_offset], ldb);
+ i__1 = *m + 1;
+ sgemm_("N", "N", &k, n, &k, &c_b23, &a[k + 1], &i__1,
+ &b[b_offset], ldb, alpha, &b[k], ldb);
+ i__1 = *m + 1;
+ strsm_("L", "U", "T", diag, &k, n, &c_b27, a, &i__1, &
+ b[k], ldb);
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', */
+/* and TRANS = 'T' */
+
+ i__1 = *m + 1;
+ strsm_("L", "U", "N", diag, &k, n, alpha, a, &i__1, &
+ b[k], ldb);
+ i__1 = *m + 1;
+ sgemm_("T", "N", &k, n, &k, &c_b23, &a[k + 1], &i__1,
+ &b[k], ldb, alpha, &b[b_offset], ldb);
+ i__1 = *m + 1;
+ strsm_("L", "L", "T", diag, &k, n, &c_b27, &a[1], &
+ i__1, &b[b_offset], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'U' */
+
+ if (! notrans) {
+
+/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', */
+/* and TRANS = 'N' */
+
+ i__1 = *m + 1;
+ strsm_("L", "L", "N", diag, &k, n, alpha, &a[k + 1], &
+ i__1, &b[b_offset], ldb);
+ i__1 = *m + 1;
+ sgemm_("T", "N", &k, n, &k, &c_b23, a, &i__1, &b[
+ b_offset], ldb, alpha, &b[k], ldb);
+ i__1 = *m + 1;
+ strsm_("L", "U", "T", diag, &k, n, &c_b27, &a[k], &
+ i__1, &b[k], ldb);
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', */
+/* and TRANS = 'T' */
+ i__1 = *m + 1;
+ strsm_("L", "U", "N", diag, &k, n, alpha, &a[k], &
+ i__1, &b[k], ldb);
+ i__1 = *m + 1;
+ sgemm_("N", "N", &k, n, &k, &c_b23, a, &i__1, &b[k],
+ ldb, alpha, &b[b_offset], ldb);
+ i__1 = *m + 1;
+ strsm_("L", "L", "T", diag, &k, n, &c_b27, &a[k + 1],
+ &i__1, &b[b_offset], ldb);
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'L', N is even, and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', */
+/* and TRANS = 'N' */
+
+ strsm_("L", "U", "T", diag, &k, n, alpha, &a[k], &k, &
+ b[b_offset], ldb);
+ sgemm_("T", "N", &k, n, &k, &c_b23, &a[k * (k + 1)], &
+ k, &b[b_offset], ldb, alpha, &b[k], ldb);
+ strsm_("L", "L", "N", diag, &k, n, &c_b27, a, &k, &b[
+ k], ldb);
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', */
+/* and TRANS = 'T' */
+
+ strsm_("L", "L", "T", diag, &k, n, alpha, a, &k, &b[k]
+, ldb);
+ sgemm_("N", "N", &k, n, &k, &c_b23, &a[k * (k + 1)], &
+ k, &b[k], ldb, alpha, &b[b_offset], ldb);
+ strsm_("L", "U", "N", diag, &k, n, &c_b27, &a[k], &k,
+ &b[b_offset], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'U' */
+
+ if (! notrans) {
+
+/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', */
+/* and TRANS = 'N' */
+
+ strsm_("L", "U", "T", diag, &k, n, alpha, &a[k * (k +
+ 1)], &k, &b[b_offset], ldb);
+ sgemm_("N", "N", &k, n, &k, &c_b23, a, &k, &b[
+ b_offset], ldb, alpha, &b[k], ldb);
+ strsm_("L", "L", "N", diag, &k, n, &c_b27, &a[k * k],
+ &k, &b[k], ldb);
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', */
+/* and TRANS = 'T' */
+
+ strsm_("L", "L", "T", diag, &k, n, alpha, &a[k * k], &
+ k, &b[k], ldb);
+ sgemm_("T", "N", &k, n, &k, &c_b23, a, &k, &b[k], ldb,
+ alpha, &b[b_offset], ldb);
+ strsm_("L", "U", "N", diag, &k, n, &c_b27, &a[k * (k
+ + 1)], &k, &b[b_offset], ldb);
+
+ }
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'R' */
+
+/* A is N-by-N. */
+/* If N is odd, set NISODD = .TRUE., and N1 and N2. */
+/* If N is even, NISODD = .FALSE., and K. */
+
+ if (*n % 2 == 0) {
+ nisodd = FALSE_;
+ k = *n / 2;
+ } else {
+ nisodd = TRUE_;
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+ }
+
+ if (nisodd) {
+
+/* SIDE = 'R' and N is odd */
+
+ if (normaltransr) {
+
+/* SIDE = 'R', N is odd, and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and */
+/* TRANS = 'N' */
+
+ strsm_("R", "U", "T", diag, m, &n2, alpha, &a[*n], n,
+ &b[n1 * b_dim1], ldb);
+ sgemm_("N", "N", m, &n1, &n2, &c_b23, &b[n1 * b_dim1],
+ ldb, &a[n1], n, alpha, b, ldb);
+ strsm_("R", "L", "N", diag, m, &n1, &c_b27, a, n, b,
+ ldb);
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and */
+/* TRANS = 'T' */
+
+ strsm_("R", "L", "T", diag, m, &n1, alpha, a, n, b,
+ ldb);
+ sgemm_("N", "T", m, &n2, &n1, &c_b23, b, ldb, &a[n1],
+ n, alpha, &b[n1 * b_dim1], ldb);
+ strsm_("R", "U", "N", diag, m, &n2, &c_b27, &a[*n], n,
+ &b[n1 * b_dim1], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and */
+/* TRANS = 'N' */
+
+ strsm_("R", "L", "T", diag, m, &n1, alpha, &a[n2], n,
+ b, ldb);
+ sgemm_("N", "N", m, &n2, &n1, &c_b23, b, ldb, a, n,
+ alpha, &b[n1 * b_dim1], ldb);
+ strsm_("R", "U", "N", diag, m, &n2, &c_b27, &a[n1], n,
+ &b[n1 * b_dim1], ldb);
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and */
+/* TRANS = 'T' */
+
+ strsm_("R", "U", "T", diag, m, &n2, alpha, &a[n1], n,
+ &b[n1 * b_dim1], ldb);
+ sgemm_("N", "T", m, &n1, &n2, &c_b23, &b[n1 * b_dim1],
+ ldb, a, n, alpha, b, ldb);
+ strsm_("R", "L", "N", diag, m, &n1, &c_b27, &a[n2], n,
+ b, ldb);
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'R', N is odd, and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and */
+/* TRANS = 'N' */
+
+ strsm_("R", "L", "N", diag, m, &n2, alpha, &a[1], &n1,
+ &b[n1 * b_dim1], ldb);
+ sgemm_("N", "T", m, &n1, &n2, &c_b23, &b[n1 * b_dim1],
+ ldb, &a[n1 * n1], &n1, alpha, b, ldb);
+ strsm_("R", "U", "T", diag, m, &n1, &c_b27, a, &n1, b,
+ ldb);
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and */
+/* TRANS = 'T' */
+
+ strsm_("R", "U", "N", diag, m, &n1, alpha, a, &n1, b,
+ ldb);
+ sgemm_("N", "N", m, &n2, &n1, &c_b23, b, ldb, &a[n1 *
+ n1], &n1, alpha, &b[n1 * b_dim1], ldb);
+ strsm_("R", "L", "T", diag, m, &n2, &c_b27, &a[1], &
+ n1, &b[n1 * b_dim1], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and */
+/* TRANS = 'N' */
+
+ strsm_("R", "U", "N", diag, m, &n1, alpha, &a[n2 * n2]
+, &n2, b, ldb);
+ sgemm_("N", "T", m, &n2, &n1, &c_b23, b, ldb, a, &n2,
+ alpha, &b[n1 * b_dim1], ldb);
+ strsm_("R", "L", "T", diag, m, &n2, &c_b27, &a[n1 *
+ n2], &n2, &b[n1 * b_dim1], ldb);
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and */
+/* TRANS = 'T' */
+
+ strsm_("R", "L", "N", diag, m, &n2, alpha, &a[n1 * n2]
+, &n2, &b[n1 * b_dim1], ldb);
+ sgemm_("N", "N", m, &n1, &n2, &c_b23, &b[n1 * b_dim1],
+ ldb, a, &n2, alpha, b, ldb);
+ strsm_("R", "U", "T", diag, m, &n1, &c_b27, &a[n2 *
+ n2], &n2, b, ldb);
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'R' and N is even */
+
+ if (normaltransr) {
+
+/* SIDE = 'R', N is even, and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', */
+/* and TRANS = 'N' */
+
+ i__1 = *n + 1;
+ strsm_("R", "U", "T", diag, m, &k, alpha, a, &i__1, &
+ b[k * b_dim1], ldb);
+ i__1 = *n + 1;
+ sgemm_("N", "N", m, &k, &k, &c_b23, &b[k * b_dim1],
+ ldb, &a[k + 1], &i__1, alpha, b, ldb);
+ i__1 = *n + 1;
+ strsm_("R", "L", "N", diag, m, &k, &c_b27, &a[1], &
+ i__1, b, ldb);
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', */
+/* and TRANS = 'T' */
+
+ i__1 = *n + 1;
+ strsm_("R", "L", "T", diag, m, &k, alpha, &a[1], &
+ i__1, b, ldb);
+ i__1 = *n + 1;
+ sgemm_("N", "T", m, &k, &k, &c_b23, b, ldb, &a[k + 1],
+ &i__1, alpha, &b[k * b_dim1], ldb);
+ i__1 = *n + 1;
+ strsm_("R", "U", "N", diag, m, &k, &c_b27, a, &i__1, &
+ b[k * b_dim1], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', */
+/* and TRANS = 'N' */
+
+ i__1 = *n + 1;
+ strsm_("R", "L", "T", diag, m, &k, alpha, &a[k + 1], &
+ i__1, b, ldb);
+ i__1 = *n + 1;
+ sgemm_("N", "N", m, &k, &k, &c_b23, b, ldb, a, &i__1,
+ alpha, &b[k * b_dim1], ldb);
+ i__1 = *n + 1;
+ strsm_("R", "U", "N", diag, m, &k, &c_b27, &a[k], &
+ i__1, &b[k * b_dim1], ldb);
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', */
+/* and TRANS = 'T' */
+
+ i__1 = *n + 1;
+ strsm_("R", "U", "T", diag, m, &k, alpha, &a[k], &
+ i__1, &b[k * b_dim1], ldb);
+ i__1 = *n + 1;
+ sgemm_("N", "T", m, &k, &k, &c_b23, &b[k * b_dim1],
+ ldb, a, &i__1, alpha, b, ldb);
+ i__1 = *n + 1;
+ strsm_("R", "L", "N", diag, m, &k, &c_b27, &a[k + 1],
+ &i__1, b, ldb);
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'R', N is even, and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', */
+/* and TRANS = 'N' */
+
+ strsm_("R", "L", "N", diag, m, &k, alpha, a, &k, &b[k
+ * b_dim1], ldb);
+ sgemm_("N", "T", m, &k, &k, &c_b23, &b[k * b_dim1],
+ ldb, &a[(k + 1) * k], &k, alpha, b, ldb);
+ strsm_("R", "U", "T", diag, m, &k, &c_b27, &a[k], &k,
+ b, ldb);
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', */
+/* and TRANS = 'T' */
+
+ strsm_("R", "U", "N", diag, m, &k, alpha, &a[k], &k,
+ b, ldb);
+ sgemm_("N", "N", m, &k, &k, &c_b23, b, ldb, &a[(k + 1)
+ * k], &k, alpha, &b[k * b_dim1], ldb);
+ strsm_("R", "L", "T", diag, m, &k, &c_b27, a, &k, &b[
+ k * b_dim1], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', */
+/* and TRANS = 'N' */
+
+ strsm_("R", "U", "N", diag, m, &k, alpha, &a[(k + 1) *
+ k], &k, b, ldb);
+ sgemm_("N", "T", m, &k, &k, &c_b23, b, ldb, a, &k,
+ alpha, &b[k * b_dim1], ldb);
+ strsm_("R", "L", "T", diag, m, &k, &c_b27, &a[k * k],
+ &k, &b[k * b_dim1], ldb);
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', */
+/* and TRANS = 'T' */
+
+ strsm_("R", "L", "N", diag, m, &k, alpha, &a[k * k], &
+ k, &b[k * b_dim1], ldb);
+ sgemm_("N", "N", m, &k, &k, &c_b23, &b[k * b_dim1],
+ ldb, a, &k, alpha, b, ldb);
+ strsm_("R", "U", "T", diag, m, &k, &c_b27, &a[(k + 1)
+ * k], &k, b, ldb);
+
+ }
+
+ }
+
+ }
+
+ }
+ }
+
+ return 0;
+
+/* End of STFSM */
+
+} /* stfsm_ */
diff --git a/SRC/stftri.c b/SRC/stftri.c
new file mode 100644
index 0000000..ac83c97
--- /dev/null
+++ b/SRC/stftri.c
@@ -0,0 +1,473 @@
+/* stftri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b13 = -1.f;
+static real c_b18 = 1.f;
+
+/* Subroutine */ int stftri_(char *transr, char *uplo, char *diag, integer *n,
+ real *a, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer k, n1, n2;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int strmm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), xerbla_(char *, integer *);
+ logical nisodd;
+ extern /* Subroutine */ int strtri_(char *, char *, integer *, real *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STFTRI computes the inverse of a triangular matrix A stored in RFP */
+/* format. */
+
+/* This is a Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': The Normal TRANSR of RFP A is stored; */
+/* = 'T': The Transpose TRANSR of RFP A is stored. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (NT); */
+/* NT=N*(N+1)/2. On entry, the triangular factor of a Hermitian */
+/* Positive Definite matrix A in RFP format. RFP format is */
+/* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' */
+/* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */
+/* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is */
+/* the transpose of RFP A as defined when */
+/* TRANSR = 'N'. The contents of RFP A are defined by UPLO as */
+/* follows: If UPLO = 'U' the RFP A contains the nt elements of */
+/* upper packed A; If UPLO = 'L' the RFP A contains the nt */
+/* elements of lower packed A. The LDA of RFP A is (N+1)/2 when */
+/* TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is */
+/* even and N is odd. See the Note below for more details. */
+
+/* On exit, the (triangular) inverse of the original matrix, in */
+/* the same storage format. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */
+/* matrix is singular and its inverse can not be computed. */
+
+/* Notes */
+/* ===== */
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* even. We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* the transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* the transpose of the last three columns of AP lower. */
+/* This covers the case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 03 04 05 33 43 53 */
+/* 13 14 15 00 44 54 */
+/* 23 24 25 10 11 55 */
+/* 33 34 35 20 21 22 */
+/* 00 44 45 30 31 32 */
+/* 01 11 55 40 41 42 */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* odd. We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* the transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* the transpose of the last two columns of AP lower. */
+/* This covers the case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 02 03 04 00 33 43 */
+/* 12 13 14 10 11 44 */
+/* 22 23 24 20 21 22 */
+/* 00 33 34 30 31 32 */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+/* RFP A RFP A */
+
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "T")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (! lsame_(diag, "N") && ! lsame_(diag,
+ "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STFTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* If N is odd, set NISODD = .TRUE. */
+/* If N is even, set K = N/2 and NISODD = .FALSE. */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ } else {
+ nisodd = TRUE_;
+ }
+
+/* Set N1 and N2 depending on LOWER */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+
+/* start execution: there are eight cases */
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */
+/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */
+/* T1 -> a(0), T2 -> a(n), S -> a(n1) */
+
+ strtri_("L", diag, &n1, a, n, info);
+ if (*info > 0) {
+ return 0;
+ }
+ strmm_("R", "L", "N", diag, &n2, &n1, &c_b13, a, n, &a[n1], n);
+ strtri_("U", diag, &n2, &a[*n], n, info)
+ ;
+ if (*info > 0) {
+ *info += n1;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ strmm_("L", "U", "T", diag, &n2, &n1, &c_b18, &a[*n], n, &a[
+ n1], n);
+
+ } else {
+
+/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */
+/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */
+/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */
+
+ strtri_("L", diag, &n1, &a[n2], n, info)
+ ;
+ if (*info > 0) {
+ return 0;
+ }
+ strmm_("L", "L", "T", diag, &n1, &n2, &c_b13, &a[n2], n, a, n);
+ strtri_("U", diag, &n2, &a[n1], n, info)
+ ;
+ if (*info > 0) {
+ *info += n1;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ strmm_("R", "U", "N", diag, &n1, &n2, &c_b18, &a[n1], n, a, n);
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is odd */
+/* T1 -> a(0), T2 -> a(1), S -> a(0+n1*n1) */
+
+ strtri_("U", diag, &n1, a, &n1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ strmm_("L", "U", "N", diag, &n1, &n2, &c_b13, a, &n1, &a[n1 *
+ n1], &n1);
+ strtri_("L", diag, &n2, &a[1], &n1, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ strmm_("R", "L", "T", diag, &n1, &n2, &c_b18, &a[1], &n1, &a[
+ n1 * n1], &n1);
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is odd */
+/* T1 -> a(0+n2*n2), T2 -> a(0+n1*n2), S -> a(0) */
+
+ strtri_("U", diag, &n1, &a[n2 * n2], &n2, info);
+ if (*info > 0) {
+ return 0;
+ }
+ strmm_("R", "U", "T", diag, &n2, &n1, &c_b13, &a[n2 * n2], &
+ n2, a, &n2);
+ strtri_("L", diag, &n2, &a[n1 * n2], &n2, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ strmm_("L", "L", "N", diag, &n2, &n1, &c_b18, &a[n1 * n2], &
+ n2, a, &n2);
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
+/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */
+
+ i__1 = *n + 1;
+ strtri_("L", diag, &k, &a[1], &i__1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ strmm_("R", "L", "N", diag, &k, &k, &c_b13, &a[1], &i__1, &a[
+ k + 1], &i__2);
+ i__1 = *n + 1;
+ strtri_("U", diag, &k, a, &i__1, info);
+ if (*info > 0) {
+ *info += k;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ strmm_("L", "U", "T", diag, &k, &k, &c_b18, a, &i__1, &a[k +
+ 1], &i__2)
+ ;
+
+ } else {
+
+/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
+/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */
+
+ i__1 = *n + 1;
+ strtri_("L", diag, &k, &a[k + 1], &i__1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ strmm_("L", "L", "T", diag, &k, &k, &c_b13, &a[k + 1], &i__1,
+ a, &i__2);
+ i__1 = *n + 1;
+ strtri_("U", diag, &k, &a[k], &i__1, info);
+ if (*info > 0) {
+ *info += k;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ strmm_("R", "U", "N", diag, &k, &k, &c_b18, &a[k], &i__1, a, &
+ i__2);
+ }
+ } else {
+
+/* N is even and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */
+/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */
+
+ strtri_("U", diag, &k, &a[k], &k, info);
+ if (*info > 0) {
+ return 0;
+ }
+ strmm_("L", "U", "N", diag, &k, &k, &c_b13, &a[k], &k, &a[k *
+ (k + 1)], &k);
+ strtri_("L", diag, &k, a, &k, info);
+ if (*info > 0) {
+ *info += k;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ strmm_("R", "L", "T", diag, &k, &k, &c_b18, a, &k, &a[k * (k
+ + 1)], &k)
+ ;
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */
+/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */
+
+ strtri_("U", diag, &k, &a[k * (k + 1)], &k, info);
+ if (*info > 0) {
+ return 0;
+ }
+ strmm_("R", "U", "T", diag, &k, &k, &c_b13, &a[k * (k + 1)], &
+ k, a, &k);
+ strtri_("L", diag, &k, &a[k * k], &k, info);
+ if (*info > 0) {
+ *info += k;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ strmm_("L", "L", "N", diag, &k, &k, &c_b18, &a[k * k], &k, a,
+ &k);
+ }
+ }
+ }
+
+ return 0;
+
+/* End of STFTRI */
+
+} /* stftri_ */
diff --git a/SRC/stfttp.c b/SRC/stfttp.c
new file mode 100644
index 0000000..2c10db5
--- /dev/null
+++ b/SRC/stfttp.c
@@ -0,0 +1,514 @@
+/* stfttp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int stfttp_(char *transr, char *uplo, integer *n, real *arf,
+ real *ap, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, k, n1, n2, ij, jp, js, nt, lda, ijp;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nisodd;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STFTTP copies a triangular matrix A from rectangular full packed */
+/* format (TF) to standard packed format (TP). */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': ARF is in Normal format; */
+/* = 'T': ARF is in Transpose format; */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* ARF (input) REAL array, dimension ( N*(N+1)/2 ), */
+/* On entry, the upper or lower triangular matrix A stored in */
+/* RFP format. For a further discussion see Notes below. */
+
+/* AP (output) REAL array, dimension ( N*(N+1)/2 ), */
+/* On exit, the upper or lower triangular matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Notes */
+/* ===== */
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* even. We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* the transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* the transpose of the last three columns of AP lower. */
+/* This covers the case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 03 04 05 33 43 53 */
+/* 13 14 15 00 44 54 */
+/* 23 24 25 10 11 55 */
+/* 33 34 35 20 21 22 */
+/* 00 44 45 30 31 32 */
+/* 01 11 55 40 41 42 */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* odd. We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* the transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* the transpose of the last two columns of AP lower. */
+/* This covers the case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 02 03 04 00 33 43 */
+/* 12 13 14 10 11 44 */
+/* 22 23 24 20 21 22 */
+/* 00 33 34 30 31 32 */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+/* RFP A RFP A */
+
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "T")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STFTTP", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (normaltransr) {
+ ap[0] = arf[0];
+ } else {
+ ap[0] = arf[0];
+ }
+ return 0;
+ }
+
+/* Size of array ARF(0:NT-1) */
+
+ nt = *n * (*n + 1) / 2;
+
+/* Set N1 and N2 depending on LOWER */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* If N is odd, set NISODD = .TRUE. */
+/* If N is even, set K = N/2 and NISODD = .FALSE. */
+
+/* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) */
+/* where noe = 0 if n is even, noe = 1 if n is odd */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ lda = *n + 1;
+ } else {
+ nisodd = TRUE_;
+ lda = *n;
+ }
+
+/* ARF^C has lda rows and n+1-noe cols */
+
+ if (! normaltransr) {
+ lda = (*n + 1) / 2;
+ }
+
+/* start execution: there are eight cases */
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */
+/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */
+/* T1 -> a(0), T2 -> a(n), S -> a(n1); lda = n */
+
+ ijp = 0;
+ jp = 0;
+ i__1 = n2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ij = i__ + jp;
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ jp += lda;
+ }
+ i__1 = n2 - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = n2;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ ij = i__ + j * lda;
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */
+/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */
+/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */
+
+ ijp = 0;
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ ij = n2 + j;
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ ij += lda;
+ }
+ }
+ js = 0;
+ i__1 = *n - 1;
+ for (j = n1; j <= i__1; ++j) {
+ ij = js;
+ i__2 = js + j;
+ for (ij = js; ij <= i__2; ++ij) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ js += lda;
+ }
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is odd */
+/* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */
+/* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 */
+
+ ijp = 0;
+ i__1 = n2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = *n * lda - 1;
+ i__3 = lda;
+ for (ij = i__ * (lda + 1); i__3 < 0 ? ij >= i__2 : ij <=
+ i__2; ij += i__3) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ }
+ js = 1;
+ i__1 = n2 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + n2 - j - 1;
+ for (ij = js; ij <= i__3; ++ij) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ js = js + lda + 1;
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is odd */
+/* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */
+/* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 */
+
+ ijp = 0;
+ js = n2 * lda;
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + j;
+ for (ij = js; ij <= i__3; ++ij) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ js += lda;
+ }
+ i__1 = n1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__3 = i__ + (n1 + i__) * lda;
+ i__2 = lda;
+ for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij +=
+ i__2) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
+/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */
+
+ ijp = 0;
+ jp = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ij = i__ + 1 + jp;
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ jp += lda;
+ }
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = k - 1;
+ for (j = i__; j <= i__2; ++j) {
+ ij = i__ + j * lda;
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
+/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */
+
+ ijp = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ ij = k + 1 + j;
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ ij += lda;
+ }
+ }
+ js = 0;
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+ ij = js;
+ i__2 = js + j;
+ for (ij = js; ij <= i__2; ++ij) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ js += lda;
+ }
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'T' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */
+/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */
+
+ ijp = 0;
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = (*n + 1) * lda - 1;
+ i__3 = lda;
+ for (ij = i__ + (i__ + 1) * lda; i__3 < 0 ? ij >= i__2 :
+ ij <= i__2; ij += i__3) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ }
+ js = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + k - j - 1;
+ for (ij = js; ij <= i__3; ++ij) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ js = js + lda + 1;
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */
+/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */
+
+ ijp = 0;
+ js = (k + 1) * lda;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + j;
+ for (ij = js; ij <= i__3; ++ij) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ js += lda;
+ }
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__3 = i__ + (k + i__) * lda;
+ i__2 = lda;
+ for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij +=
+ i__2) {
+ ap[ijp] = arf[ij];
+ ++ijp;
+ }
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of STFTTP */
+
+} /* stfttp_ */
diff --git a/SRC/stfttr.c b/SRC/stfttr.c
new file mode 100644
index 0000000..c085b80
--- /dev/null
+++ b/SRC/stfttr.c
@@ -0,0 +1,491 @@
+/* stfttr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int stfttr_(char *transr, char *uplo, integer *n, real *arf,
+ real *a, integer *lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k, l, n1, n2, ij, nt, nx2, np1x2;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nisodd;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STFTTR copies a triangular matrix A from rectangular full packed */
+/* format (TF) to standard full format (TR). */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': ARF is in Normal format; */
+/* = 'T': ARF is in Transpose format. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrices ARF and A. N >= 0. */
+
+/* ARF (input) REAL array, dimension (N*(N+1)/2). */
+/* On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L') */
+/* matrix A in RFP format. See the "Notes" below for more */
+/* details. */
+
+/* A (output) REAL array, dimension (LDA,N) */
+/* On exit, the triangular matrix A. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of the array A contains */
+/* the upper triangular matrix, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of the array A contains */
+/* the lower triangular matrix, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Notes */
+/* ===== */
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* even. We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* the transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* the transpose of the last three columns of AP lower. */
+/* This covers the case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 03 04 05 33 43 53 */
+/* 13 14 15 00 44 54 */
+/* 23 24 25 10 11 55 */
+/* 33 34 35 20 21 22 */
+/* 00 44 45 30 31 32 */
+/* 01 11 55 40 41 42 */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* odd. We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* the transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* the transpose of the last two columns of AP lower. */
+/* This covers the case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 02 03 04 00 33 43 */
+/* 12 13 14 10 11 44 */
+/* 22 23 24 20 21 22 */
+/* 00 33 34 30 31 32 */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+/* RFP A RFP A */
+
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* Reference */
+/* ========= */
+
+/* ===================================================================== */
+
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda - 1 - 0 + 1;
+ a_offset = 0 + a_dim1 * 0;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "T")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STFTTR", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 1) {
+ if (*n == 1) {
+ a[0] = arf[0];
+ }
+ return 0;
+ }
+
+/* Size of array ARF(0:nt-1) */
+
+ nt = *n * (*n + 1) / 2;
+
+/* set N1 and N2 depending on LOWER: for N even N1=N2=K */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. */
+/* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is */
+/* N--by--(N+1)/2. */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ if (! lower) {
+ np1x2 = *n + *n + 2;
+ }
+ } else {
+ nisodd = TRUE_;
+ if (! lower) {
+ nx2 = *n + *n;
+ }
+ }
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* N is odd, TRANSR = 'N', and UPLO = 'L' */
+
+ ij = 0;
+ i__1 = n2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = n2 + j;
+ for (i__ = n1; i__ <= i__2; ++i__) {
+ a[n2 + j + i__ * a_dim1] = arf[ij];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = arf[ij];
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* N is odd, TRANSR = 'N', and UPLO = 'U' */
+
+ ij = nt - *n;
+ i__1 = n1;
+ for (j = *n - 1; j >= i__1; --j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = arf[ij];
+ ++ij;
+ }
+ i__2 = n1 - 1;
+ for (l = j - n1; l <= i__2; ++l) {
+ a[j - n1 + l * a_dim1] = arf[ij];
+ ++ij;
+ }
+ ij -= nx2;
+ }
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'T' */
+
+ if (lower) {
+
+/* N is odd, TRANSR = 'T', and UPLO = 'L' */
+
+ ij = 0;
+ i__1 = n2 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ a[j + i__ * a_dim1] = arf[ij];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = n1 + j; i__ <= i__2; ++i__) {
+ a[i__ + (n1 + j) * a_dim1] = arf[ij];
+ ++ij;
+ }
+ }
+ i__1 = *n - 1;
+ for (j = n2; j <= i__1; ++j) {
+ i__2 = n1 - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ a[j + i__ * a_dim1] = arf[ij];
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* N is odd, TRANSR = 'T', and UPLO = 'U' */
+
+ ij = 0;
+ i__1 = n1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = n1; i__ <= i__2; ++i__) {
+ a[j + i__ * a_dim1] = arf[ij];
+ ++ij;
+ }
+ }
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = arf[ij];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (l = n2 + j; l <= i__2; ++l) {
+ a[n2 + j + l * a_dim1] = arf[ij];
+ ++ij;
+ }
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* N is even, TRANSR = 'N', and UPLO = 'L' */
+
+ ij = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k + j;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ a[k + j + i__ * a_dim1] = arf[ij];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = arf[ij];
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* N is even, TRANSR = 'N', and UPLO = 'U' */
+
+ ij = nt - *n - 1;
+ i__1 = k;
+ for (j = *n - 1; j >= i__1; --j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = arf[ij];
+ ++ij;
+ }
+ i__2 = k - 1;
+ for (l = j - k; l <= i__2; ++l) {
+ a[j - k + l * a_dim1] = arf[ij];
+ ++ij;
+ }
+ ij -= np1x2;
+ }
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'T' */
+
+ if (lower) {
+
+/* N is even, TRANSR = 'T', and UPLO = 'L' */
+
+ ij = 0;
+ j = k;
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ a[i__ + j * a_dim1] = arf[ij];
+ ++ij;
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ a[j + i__ * a_dim1] = arf[ij];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = k + 1 + j; i__ <= i__2; ++i__) {
+ a[i__ + (k + 1 + j) * a_dim1] = arf[ij];
+ ++ij;
+ }
+ }
+ i__1 = *n - 1;
+ for (j = k - 1; j <= i__1; ++j) {
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ a[j + i__ * a_dim1] = arf[ij];
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* N is even, TRANSR = 'T', and UPLO = 'U' */
+
+ ij = 0;
+ i__1 = k;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ a[j + i__ * a_dim1] = arf[ij];
+ ++ij;
+ }
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = arf[ij];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (l = k + 1 + j; l <= i__2; ++l) {
+ a[k + 1 + j + l * a_dim1] = arf[ij];
+ ++ij;
+ }
+ }
+/* Note that here, on exit of the loop, J = K-1 */
+ i__1 = j;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ a[i__ + j * a_dim1] = arf[ij];
+ ++ij;
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of STFTTR */
+
+} /* stfttr_ */
diff --git a/SRC/stgevc.c b/SRC/stgevc.c
new file mode 100644
index 0000000..aa7e3f4
--- /dev/null
+++ b/SRC/stgevc.c
@@ -0,0 +1,1415 @@
+/* stgevc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static logical c_true = TRUE_;
+static integer c__2 = 2;
+static real c_b34 = 1.f;
+static integer c__1 = 1;
+static real c_b36 = 0.f;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int stgevc_(char *side, char *howmny, logical *select,
+ integer *n, real *s, integer *lds, real *p, integer *ldp, real *vl,
+ integer *ldvl, real *vr, integer *ldvr, integer *mm, integer *m, real
+ *work, integer *info)
+{
+ /* System generated locals */
+ integer p_dim1, p_offset, s_dim1, s_offset, vl_dim1, vl_offset, vr_dim1,
+ vr_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4, r__5, r__6;
+
+ /* Local variables */
+ integer i__, j, ja, jc, je, na, im, jr, jw, nw;
+ real big;
+ logical lsa, lsb;
+ real ulp, sum[4] /* was [2][2] */;
+ integer ibeg, ieig, iend;
+ real dmin__, temp, xmax, sump[4] /* was [2][2] */, sums[4] /*
+ was [2][2] */, cim2a, cim2b, cre2a, cre2b;
+ extern /* Subroutine */ int slag2_(real *, integer *, real *, integer *,
+ real *, real *, real *, real *, real *, real *);
+ real temp2, bdiag[2], acoef, scale;
+ logical ilall;
+ integer iside;
+ real sbeta;
+ extern logical lsame_(char *, char *);
+ logical il2by2;
+ integer iinfo;
+ real small;
+ logical compl;
+ real anorm, bnorm;
+ logical compr;
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *), slaln2_(logical *, integer *, integer *, real *, real *,
+ real *, integer *, real *, real *, real *, integer *, real *,
+ real *, real *, integer *, real *, real *, integer *);
+ real temp2i, temp2r;
+ logical ilabad, ilbbad;
+ real acoefa, bcoefa, cimaga, cimagb;
+ logical ilback;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ real bcoefi, ascale, bscale, creala, crealb, bcoefr;
+ extern doublereal slamch_(char *);
+ real salfar, safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real xscale, bignum;
+ logical ilcomp, ilcplx;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+ integer ihwmny;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+
+/* Purpose */
+/* ======= */
+
+/* STGEVC computes some or all of the right and/or left eigenvectors of */
+/* a pair of real matrices (S,P), where S is a quasi-triangular matrix */
+/* and P is upper triangular. Matrix pairs of this type are produced by */
+/* the generalized Schur factorization of a matrix pair (A,B): */
+
+/* A = Q*S*Z**T, B = Q*P*Z**T */
+
+/* as computed by SGGHRD + SHGEQZ. */
+
+/* The right eigenvector x and the left eigenvector y of (S,P) */
+/* corresponding to an eigenvalue w are defined by: */
+
+/* S*x = w*P*x, (y**H)*S = w*(y**H)*P, */
+
+/* where y**H denotes the conjugate tranpose of y. */
+/* The eigenvalues are not input to this routine, but are computed */
+/* directly from the diagonal blocks of S and P. */
+
+/* This routine returns the matrices X and/or Y of right and left */
+/* eigenvectors of (S,P), or the products Z*X and/or Q*Y, */
+/* where Z and Q are input matrices. */
+/* If Q and Z are the orthogonal factors from the generalized Schur */
+/* factorization of a matrix pair (A,B), then Z*X and Q*Y */
+/* are the matrices of right and left eigenvectors of (A,B). */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'R': compute right eigenvectors only; */
+/* = 'L': compute left eigenvectors only; */
+/* = 'B': compute both right and left eigenvectors. */
+
+/* HOWMNY (input) CHARACTER*1 */
+/* = 'A': compute all right and/or left eigenvectors; */
+/* = 'B': compute all right and/or left eigenvectors, */
+/* backtransformed by the matrices in VR and/or VL; */
+/* = 'S': compute selected right and/or left eigenvectors, */
+/* specified by the logical array SELECT. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* If HOWMNY='S', SELECT specifies the eigenvectors to be */
+/* computed. If w(j) is a real eigenvalue, the corresponding */
+/* real eigenvector is computed if SELECT(j) is .TRUE.. */
+/* If w(j) and w(j+1) are the real and imaginary parts of a */
+/* complex eigenvalue, the corresponding complex eigenvector */
+/* is computed if either SELECT(j) or SELECT(j+1) is .TRUE., */
+/* and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is */
+/* set to .FALSE.. */
+/* Not referenced if HOWMNY = 'A' or 'B'. */
+
+/* N (input) INTEGER */
+/* The order of the matrices S and P. N >= 0. */
+
+/* S (input) REAL array, dimension (LDS,N) */
+/* The upper quasi-triangular matrix S from a generalized Schur */
+/* factorization, as computed by SHGEQZ. */
+
+/* LDS (input) INTEGER */
+/* The leading dimension of array S. LDS >= max(1,N). */
+
+/* P (input) REAL array, dimension (LDP,N) */
+/* The upper triangular matrix P from a generalized Schur */
+/* factorization, as computed by SHGEQZ. */
+/* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks */
+/* of S must be in positive diagonal form. */
+
+/* LDP (input) INTEGER */
+/* The leading dimension of array P. LDP >= max(1,N). */
+
+/* VL (input/output) REAL array, dimension (LDVL,MM) */
+/* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */
+/* contain an N-by-N matrix Q (usually the orthogonal matrix Q */
+/* of left Schur vectors returned by SHGEQZ). */
+/* On exit, if SIDE = 'L' or 'B', VL contains: */
+/* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); */
+/* if HOWMNY = 'B', the matrix Q*Y; */
+/* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by */
+/* SELECT, stored consecutively in the columns of */
+/* VL, in the same order as their eigenvalues. */
+
+/* A complex eigenvector corresponding to a complex eigenvalue */
+/* is stored in two consecutive columns, the first holding the */
+/* real part, and the second the imaginary part. */
+
+/* Not referenced if SIDE = 'R'. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of array VL. LDVL >= 1, and if */
+/* SIDE = 'L' or 'B', LDVL >= N. */
+
+/* VR (input/output) REAL array, dimension (LDVR,MM) */
+/* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */
+/* contain an N-by-N matrix Z (usually the orthogonal matrix Z */
+/* of right Schur vectors returned by SHGEQZ). */
+
+/* On exit, if SIDE = 'R' or 'B', VR contains: */
+/* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); */
+/* if HOWMNY = 'B' or 'b', the matrix Z*X; */
+/* if HOWMNY = 'S' or 's', the right eigenvectors of (S,P) */
+/* specified by SELECT, stored consecutively in the */
+/* columns of VR, in the same order as their */
+/* eigenvalues. */
+
+/* A complex eigenvector corresponding to a complex eigenvalue */
+/* is stored in two consecutive columns, the first holding the */
+/* real part and the second the imaginary part. */
+
+/* Not referenced if SIDE = 'L'. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. LDVR >= 1, and if */
+/* SIDE = 'R' or 'B', LDVR >= N. */
+
+/* MM (input) INTEGER */
+/* The number of columns in the arrays VL and/or VR. MM >= M. */
+
+/* M (output) INTEGER */
+/* The number of columns in the arrays VL and/or VR actually */
+/* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M */
+/* is set to N. Each selected real eigenvector occupies one */
+/* column and each selected complex eigenvector occupies two */
+/* columns. */
+
+/* WORK (workspace) REAL array, dimension (6*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex */
+/* eigenvalue. */
+
+/* Further Details */
+/* =============== */
+
+/* Allocation of workspace: */
+/* ---------- -- --------- */
+
+/* WORK( j ) = 1-norm of j-th column of A, above the diagonal */
+/* WORK( N+j ) = 1-norm of j-th column of B, above the diagonal */
+/* WORK( 2*N+1:3*N ) = real part of eigenvector */
+/* WORK( 3*N+1:4*N ) = imaginary part of eigenvector */
+/* WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector */
+/* WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector */
+
+/* Rowwise vs. columnwise solution methods: */
+/* ------- -- ---------- -------- ------- */
+
+/* Finding a generalized eigenvector consists basically of solving the */
+/* singular triangular system */
+
+/* (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left) */
+
+/* Consider finding the i-th right eigenvector (assume all eigenvalues */
+/* are real). The equation to be solved is: */
+/* n i */
+/* 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1 */
+/* k=j k=j */
+
+/* where C = (A - w B) (The components v(i+1:n) are 0.) */
+
+/* The "rowwise" method is: */
+
+/* (1) v(i) := 1 */
+/* for j = i-1,. . .,1: */
+/* i */
+/* (2) compute s = - sum C(j,k) v(k) and */
+/* k=j+1 */
+
+/* (3) v(j) := s / C(j,j) */
+
+/* Step 2 is sometimes called the "dot product" step, since it is an */
+/* inner product between the j-th row and the portion of the eigenvector */
+/* that has been computed so far. */
+
+/* The "columnwise" method consists basically in doing the sums */
+/* for all the rows in parallel. As each v(j) is computed, the */
+/* contribution of v(j) times the j-th column of C is added to the */
+/* partial sums. Since FORTRAN arrays are stored columnwise, this has */
+/* the advantage that at each step, the elements of C that are accessed */
+/* are adjacent to one another, whereas with the rowwise method, the */
+/* elements accessed at a step are spaced LDS (and LDP) words apart. */
+
+/* When finding left eigenvectors, the matrix in question is the */
+/* transpose of the one in storage, so the rowwise method then */
+/* actually accesses columns of A and B at each step, and so is the */
+/* preferred method. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and Test the input parameters */
+
+ /* Parameter adjustments */
+ --select;
+ s_dim1 = *lds;
+ s_offset = 1 + s_dim1;
+ s -= s_offset;
+ p_dim1 = *ldp;
+ p_offset = 1 + p_dim1;
+ p -= p_offset;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+
+ /* Function Body */
+ if (lsame_(howmny, "A")) {
+ ihwmny = 1;
+ ilall = TRUE_;
+ ilback = FALSE_;
+ } else if (lsame_(howmny, "S")) {
+ ihwmny = 2;
+ ilall = FALSE_;
+ ilback = FALSE_;
+ } else if (lsame_(howmny, "B")) {
+ ihwmny = 3;
+ ilall = TRUE_;
+ ilback = TRUE_;
+ } else {
+ ihwmny = -1;
+ ilall = TRUE_;
+ }
+
+ if (lsame_(side, "R")) {
+ iside = 1;
+ compl = FALSE_;
+ compr = TRUE_;
+ } else if (lsame_(side, "L")) {
+ iside = 2;
+ compl = TRUE_;
+ compr = FALSE_;
+ } else if (lsame_(side, "B")) {
+ iside = 3;
+ compl = TRUE_;
+ compr = TRUE_;
+ } else {
+ iside = -1;
+ }
+
+ *info = 0;
+ if (iside < 0) {
+ *info = -1;
+ } else if (ihwmny < 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lds < max(1,*n)) {
+ *info = -6;
+ } else if (*ldp < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STGEVC", &i__1);
+ return 0;
+ }
+
+/* Count the number of eigenvectors to be computed */
+
+ if (! ilall) {
+ im = 0;
+ ilcplx = FALSE_;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (ilcplx) {
+ ilcplx = FALSE_;
+ goto L10;
+ }
+ if (j < *n) {
+ if (s[j + 1 + j * s_dim1] != 0.f) {
+ ilcplx = TRUE_;
+ }
+ }
+ if (ilcplx) {
+ if (select[j] || select[j + 1]) {
+ im += 2;
+ }
+ } else {
+ if (select[j]) {
+ ++im;
+ }
+ }
+L10:
+ ;
+ }
+ } else {
+ im = *n;
+ }
+
+/* Check 2-by-2 diagonal blocks of A, B */
+
+ ilabad = FALSE_;
+ ilbbad = FALSE_;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ if (s[j + 1 + j * s_dim1] != 0.f) {
+ if (p[j + j * p_dim1] == 0.f || p[j + 1 + (j + 1) * p_dim1] ==
+ 0.f || p[j + (j + 1) * p_dim1] != 0.f) {
+ ilbbad = TRUE_;
+ }
+ if (j < *n - 1) {
+ if (s[j + 2 + (j + 1) * s_dim1] != 0.f) {
+ ilabad = TRUE_;
+ }
+ }
+ }
+/* L20: */
+ }
+
+ if (ilabad) {
+ *info = -5;
+ } else if (ilbbad) {
+ *info = -7;
+ } else if (compl && *ldvl < *n || *ldvl < 1) {
+ *info = -10;
+ } else if (compr && *ldvr < *n || *ldvr < 1) {
+ *info = -12;
+ } else if (*mm < im) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STGEVC", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = im;
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Machine Constants */
+
+ safmin = slamch_("Safe minimum");
+ big = 1.f / safmin;
+ slabad_(&safmin, &big);
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ small = safmin * *n / ulp;
+ big = 1.f / small;
+ bignum = 1.f / (safmin * *n);
+
+/* Compute the 1-norm of each column of the strictly upper triangular */
+/* part (i.e., excluding all elements belonging to the diagonal */
+/* blocks) of A and B to check for possible overflow in the */
+/* triangular solver. */
+
+ anorm = (r__1 = s[s_dim1 + 1], dabs(r__1));
+ if (*n > 1) {
+ anorm += (r__1 = s[s_dim1 + 2], dabs(r__1));
+ }
+ bnorm = (r__1 = p[p_dim1 + 1], dabs(r__1));
+ work[1] = 0.f;
+ work[*n + 1] = 0.f;
+
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ temp = 0.f;
+ temp2 = 0.f;
+ if (s[j + (j - 1) * s_dim1] == 0.f) {
+ iend = j - 1;
+ } else {
+ iend = j - 2;
+ }
+ i__2 = iend;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp += (r__1 = s[i__ + j * s_dim1], dabs(r__1));
+ temp2 += (r__1 = p[i__ + j * p_dim1], dabs(r__1));
+/* L30: */
+ }
+ work[j] = temp;
+ work[*n + j] = temp2;
+/* Computing MIN */
+ i__3 = j + 1;
+ i__2 = min(i__3,*n);
+ for (i__ = iend + 1; i__ <= i__2; ++i__) {
+ temp += (r__1 = s[i__ + j * s_dim1], dabs(r__1));
+ temp2 += (r__1 = p[i__ + j * p_dim1], dabs(r__1));
+/* L40: */
+ }
+ anorm = dmax(anorm,temp);
+ bnorm = dmax(bnorm,temp2);
+/* L50: */
+ }
+
+ ascale = 1.f / dmax(anorm,safmin);
+ bscale = 1.f / dmax(bnorm,safmin);
+
+/* Left eigenvectors */
+
+ if (compl) {
+ ieig = 0;
+
+/* Main loop over eigenvalues */
+
+ ilcplx = FALSE_;
+ i__1 = *n;
+ for (je = 1; je <= i__1; ++je) {
+
+/* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or */
+/* (b) this would be the second of a complex pair. */
+/* Check for complex eigenvalue, so as to be sure of which */
+/* entry(-ies) of SELECT to look at. */
+
+ if (ilcplx) {
+ ilcplx = FALSE_;
+ goto L220;
+ }
+ nw = 1;
+ if (je < *n) {
+ if (s[je + 1 + je * s_dim1] != 0.f) {
+ ilcplx = TRUE_;
+ nw = 2;
+ }
+ }
+ if (ilall) {
+ ilcomp = TRUE_;
+ } else if (ilcplx) {
+ ilcomp = select[je] || select[je + 1];
+ } else {
+ ilcomp = select[je];
+ }
+ if (! ilcomp) {
+ goto L220;
+ }
+
+/* Decide if (a) singular pencil, (b) real eigenvalue, or */
+/* (c) complex eigenvalue. */
+
+ if (! ilcplx) {
+ if ((r__1 = s[je + je * s_dim1], dabs(r__1)) <= safmin && (
+ r__2 = p[je + je * p_dim1], dabs(r__2)) <= safmin) {
+
+/* Singular matrix pencil -- return unit eigenvector */
+
+ ++ieig;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vl[jr + ieig * vl_dim1] = 0.f;
+/* L60: */
+ }
+ vl[ieig + ieig * vl_dim1] = 1.f;
+ goto L220;
+ }
+ }
+
+/* Clear vector */
+
+ i__2 = nw * *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ work[(*n << 1) + jr] = 0.f;
+/* L70: */
+ }
+/* T */
+/* Compute coefficients in ( a A - b B ) y = 0 */
+/* a is ACOEF */
+/* b is BCOEFR + i*BCOEFI */
+
+ if (! ilcplx) {
+
+/* Real eigenvalue */
+
+/* Computing MAX */
+ r__3 = (r__1 = s[je + je * s_dim1], dabs(r__1)) * ascale,
+ r__4 = (r__2 = p[je + je * p_dim1], dabs(r__2)) *
+ bscale, r__3 = max(r__3,r__4);
+ temp = 1.f / dmax(r__3,safmin);
+ salfar = temp * s[je + je * s_dim1] * ascale;
+ sbeta = temp * p[je + je * p_dim1] * bscale;
+ acoef = sbeta * ascale;
+ bcoefr = salfar * bscale;
+ bcoefi = 0.f;
+
+/* Scale to avoid underflow */
+
+ scale = 1.f;
+ lsa = dabs(sbeta) >= safmin && dabs(acoef) < small;
+ lsb = dabs(salfar) >= safmin && dabs(bcoefr) < small;
+ if (lsa) {
+ scale = small / dabs(sbeta) * dmin(anorm,big);
+ }
+ if (lsb) {
+/* Computing MAX */
+ r__1 = scale, r__2 = small / dabs(salfar) * dmin(bnorm,
+ big);
+ scale = dmax(r__1,r__2);
+ }
+ if (lsa || lsb) {
+/* Computing MIN */
+/* Computing MAX */
+ r__3 = 1.f, r__4 = dabs(acoef), r__3 = max(r__3,r__4),
+ r__4 = dabs(bcoefr);
+ r__1 = scale, r__2 = 1.f / (safmin * dmax(r__3,r__4));
+ scale = dmin(r__1,r__2);
+ if (lsa) {
+ acoef = ascale * (scale * sbeta);
+ } else {
+ acoef = scale * acoef;
+ }
+ if (lsb) {
+ bcoefr = bscale * (scale * salfar);
+ } else {
+ bcoefr = scale * bcoefr;
+ }
+ }
+ acoefa = dabs(acoef);
+ bcoefa = dabs(bcoefr);
+
+/* First component is 1 */
+
+ work[(*n << 1) + je] = 1.f;
+ xmax = 1.f;
+ } else {
+
+/* Complex eigenvalue */
+
+ r__1 = safmin * 100.f;
+ slag2_(&s[je + je * s_dim1], lds, &p[je + je * p_dim1], ldp, &
+ r__1, &acoef, &temp, &bcoefr, &temp2, &bcoefi);
+ bcoefi = -bcoefi;
+ if (bcoefi == 0.f) {
+ *info = je;
+ return 0;
+ }
+
+/* Scale to avoid over/underflow */
+
+ acoefa = dabs(acoef);
+ bcoefa = dabs(bcoefr) + dabs(bcoefi);
+ scale = 1.f;
+ if (acoefa * ulp < safmin && acoefa >= safmin) {
+ scale = safmin / ulp / acoefa;
+ }
+ if (bcoefa * ulp < safmin && bcoefa >= safmin) {
+/* Computing MAX */
+ r__1 = scale, r__2 = safmin / ulp / bcoefa;
+ scale = dmax(r__1,r__2);
+ }
+ if (safmin * acoefa > ascale) {
+ scale = ascale / (safmin * acoefa);
+ }
+ if (safmin * bcoefa > bscale) {
+/* Computing MIN */
+ r__1 = scale, r__2 = bscale / (safmin * bcoefa);
+ scale = dmin(r__1,r__2);
+ }
+ if (scale != 1.f) {
+ acoef = scale * acoef;
+ acoefa = dabs(acoef);
+ bcoefr = scale * bcoefr;
+ bcoefi = scale * bcoefi;
+ bcoefa = dabs(bcoefr) + dabs(bcoefi);
+ }
+
+/* Compute first two components of eigenvector */
+
+ temp = acoef * s[je + 1 + je * s_dim1];
+ temp2r = acoef * s[je + je * s_dim1] - bcoefr * p[je + je *
+ p_dim1];
+ temp2i = -bcoefi * p[je + je * p_dim1];
+ if (dabs(temp) > dabs(temp2r) + dabs(temp2i)) {
+ work[(*n << 1) + je] = 1.f;
+ work[*n * 3 + je] = 0.f;
+ work[(*n << 1) + je + 1] = -temp2r / temp;
+ work[*n * 3 + je + 1] = -temp2i / temp;
+ } else {
+ work[(*n << 1) + je + 1] = 1.f;
+ work[*n * 3 + je + 1] = 0.f;
+ temp = acoef * s[je + (je + 1) * s_dim1];
+ work[(*n << 1) + je] = (bcoefr * p[je + 1 + (je + 1) *
+ p_dim1] - acoef * s[je + 1 + (je + 1) * s_dim1]) /
+ temp;
+ work[*n * 3 + je] = bcoefi * p[je + 1 + (je + 1) * p_dim1]
+ / temp;
+ }
+/* Computing MAX */
+ r__5 = (r__1 = work[(*n << 1) + je], dabs(r__1)) + (r__2 =
+ work[*n * 3 + je], dabs(r__2)), r__6 = (r__3 = work[(*
+ n << 1) + je + 1], dabs(r__3)) + (r__4 = work[*n * 3
+ + je + 1], dabs(r__4));
+ xmax = dmax(r__5,r__6);
+ }
+
+/* Computing MAX */
+ r__1 = ulp * acoefa * anorm, r__2 = ulp * bcoefa * bnorm, r__1 =
+ max(r__1,r__2);
+ dmin__ = dmax(r__1,safmin);
+
+/* T */
+/* Triangular solve of (a A - b B) y = 0 */
+
+/* T */
+/* (rowwise in (a A - b B) , or columnwise in (a A - b B) ) */
+
+ il2by2 = FALSE_;
+
+ i__2 = *n;
+ for (j = je + nw; j <= i__2; ++j) {
+ if (il2by2) {
+ il2by2 = FALSE_;
+ goto L160;
+ }
+
+ na = 1;
+ bdiag[0] = p[j + j * p_dim1];
+ if (j < *n) {
+ if (s[j + 1 + j * s_dim1] != 0.f) {
+ il2by2 = TRUE_;
+ bdiag[1] = p[j + 1 + (j + 1) * p_dim1];
+ na = 2;
+ }
+ }
+
+/* Check whether scaling is necessary for dot products */
+
+ xscale = 1.f / dmax(1.f,xmax);
+/* Computing MAX */
+ r__1 = work[j], r__2 = work[*n + j], r__1 = max(r__1,r__2),
+ r__2 = acoefa * work[j] + bcoefa * work[*n + j];
+ temp = dmax(r__1,r__2);
+ if (il2by2) {
+/* Computing MAX */
+ r__1 = temp, r__2 = work[j + 1], r__1 = max(r__1,r__2),
+ r__2 = work[*n + j + 1], r__1 = max(r__1,r__2),
+ r__2 = acoefa * work[j + 1] + bcoefa * work[*n +
+ j + 1];
+ temp = dmax(r__1,r__2);
+ }
+ if (temp > bignum * xscale) {
+ i__3 = nw - 1;
+ for (jw = 0; jw <= i__3; ++jw) {
+ i__4 = j - 1;
+ for (jr = je; jr <= i__4; ++jr) {
+ work[(jw + 2) * *n + jr] = xscale * work[(jw + 2)
+ * *n + jr];
+/* L80: */
+ }
+/* L90: */
+ }
+ xmax *= xscale;
+ }
+
+/* Compute dot products */
+
+/* j-1 */
+/* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) */
+/* k=je */
+
+/* To reduce the op count, this is done as */
+
+/* _ j-1 _ j-1 */
+/* a*conjg( sum S(k,j)*x(k) ) - b*conjg( sum P(k,j)*x(k) ) */
+/* k=je k=je */
+
+/* which may cause underflow problems if A or B are close */
+/* to underflow. (E.g., less than SMALL.) */
+
+
+/* A series of compiler directives to defeat vectorization */
+/* for the next loop */
+
+/* $PL$ CMCHAR=' ' */
+/* DIR$ NEXTSCALAR */
+/* $DIR SCALAR */
+/* DIR$ NEXT SCALAR */
+/* VD$L NOVECTOR */
+/* DEC$ NOVECTOR */
+/* VD$ NOVECTOR */
+/* VDIR NOVECTOR */
+/* VOCL LOOP,SCALAR */
+/* IBM PREFER SCALAR */
+/* $PL$ CMCHAR='*' */
+
+ i__3 = nw;
+ for (jw = 1; jw <= i__3; ++jw) {
+
+/* $PL$ CMCHAR=' ' */
+/* DIR$ NEXTSCALAR */
+/* $DIR SCALAR */
+/* DIR$ NEXT SCALAR */
+/* VD$L NOVECTOR */
+/* DEC$ NOVECTOR */
+/* VD$ NOVECTOR */
+/* VDIR NOVECTOR */
+/* VOCL LOOP,SCALAR */
+/* IBM PREFER SCALAR */
+/* $PL$ CMCHAR='*' */
+
+ i__4 = na;
+ for (ja = 1; ja <= i__4; ++ja) {
+ sums[ja + (jw << 1) - 3] = 0.f;
+ sump[ja + (jw << 1) - 3] = 0.f;
+
+ i__5 = j - 1;
+ for (jr = je; jr <= i__5; ++jr) {
+ sums[ja + (jw << 1) - 3] += s[jr + (j + ja - 1) *
+ s_dim1] * work[(jw + 1) * *n + jr];
+ sump[ja + (jw << 1) - 3] += p[jr + (j + ja - 1) *
+ p_dim1] * work[(jw + 1) * *n + jr];
+/* L100: */
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+
+/* $PL$ CMCHAR=' ' */
+/* DIR$ NEXTSCALAR */
+/* $DIR SCALAR */
+/* DIR$ NEXT SCALAR */
+/* VD$L NOVECTOR */
+/* DEC$ NOVECTOR */
+/* VD$ NOVECTOR */
+/* VDIR NOVECTOR */
+/* VOCL LOOP,SCALAR */
+/* IBM PREFER SCALAR */
+/* $PL$ CMCHAR='*' */
+
+ i__3 = na;
+ for (ja = 1; ja <= i__3; ++ja) {
+ if (ilcplx) {
+ sum[ja - 1] = -acoef * sums[ja - 1] + bcoefr * sump[
+ ja - 1] - bcoefi * sump[ja + 1];
+ sum[ja + 1] = -acoef * sums[ja + 1] + bcoefr * sump[
+ ja + 1] + bcoefi * sump[ja - 1];
+ } else {
+ sum[ja - 1] = -acoef * sums[ja - 1] + bcoefr * sump[
+ ja - 1];
+ }
+/* L130: */
+ }
+
+/* T */
+/* Solve ( a A - b B ) y = SUM(,) */
+/* with scaling and perturbation of the denominator */
+
+ slaln2_(&c_true, &na, &nw, &dmin__, &acoef, &s[j + j * s_dim1]
+, lds, bdiag, &bdiag[1], sum, &c__2, &bcoefr, &bcoefi,
+ &work[(*n << 1) + j], n, &scale, &temp, &iinfo);
+ if (scale < 1.f) {
+ i__3 = nw - 1;
+ for (jw = 0; jw <= i__3; ++jw) {
+ i__4 = j - 1;
+ for (jr = je; jr <= i__4; ++jr) {
+ work[(jw + 2) * *n + jr] = scale * work[(jw + 2) *
+ *n + jr];
+/* L140: */
+ }
+/* L150: */
+ }
+ xmax = scale * xmax;
+ }
+ xmax = dmax(xmax,temp);
+L160:
+ ;
+ }
+
+/* Copy eigenvector to VL, back transforming if */
+/* HOWMNY='B'. */
+
+ ++ieig;
+ if (ilback) {
+ i__2 = nw - 1;
+ for (jw = 0; jw <= i__2; ++jw) {
+ i__3 = *n + 1 - je;
+ sgemv_("N", n, &i__3, &c_b34, &vl[je * vl_dim1 + 1], ldvl,
+ &work[(jw + 2) * *n + je], &c__1, &c_b36, &work[(
+ jw + 4) * *n + 1], &c__1);
+/* L170: */
+ }
+ slacpy_(" ", n, &nw, &work[(*n << 2) + 1], n, &vl[je *
+ vl_dim1 + 1], ldvl);
+ ibeg = 1;
+ } else {
+ slacpy_(" ", n, &nw, &work[(*n << 1) + 1], n, &vl[ieig *
+ vl_dim1 + 1], ldvl);
+ ibeg = je;
+ }
+
+/* Scale eigenvector */
+
+ xmax = 0.f;
+ if (ilcplx) {
+ i__2 = *n;
+ for (j = ibeg; j <= i__2; ++j) {
+/* Computing MAX */
+ r__3 = xmax, r__4 = (r__1 = vl[j + ieig * vl_dim1], dabs(
+ r__1)) + (r__2 = vl[j + (ieig + 1) * vl_dim1],
+ dabs(r__2));
+ xmax = dmax(r__3,r__4);
+/* L180: */
+ }
+ } else {
+ i__2 = *n;
+ for (j = ibeg; j <= i__2; ++j) {
+/* Computing MAX */
+ r__2 = xmax, r__3 = (r__1 = vl[j + ieig * vl_dim1], dabs(
+ r__1));
+ xmax = dmax(r__2,r__3);
+/* L190: */
+ }
+ }
+
+ if (xmax > safmin) {
+ xscale = 1.f / xmax;
+
+ i__2 = nw - 1;
+ for (jw = 0; jw <= i__2; ++jw) {
+ i__3 = *n;
+ for (jr = ibeg; jr <= i__3; ++jr) {
+ vl[jr + (ieig + jw) * vl_dim1] = xscale * vl[jr + (
+ ieig + jw) * vl_dim1];
+/* L200: */
+ }
+/* L210: */
+ }
+ }
+ ieig = ieig + nw - 1;
+
+L220:
+ ;
+ }
+ }
+
+/* Right eigenvectors */
+
+ if (compr) {
+ ieig = im + 1;
+
+/* Main loop over eigenvalues */
+
+ ilcplx = FALSE_;
+ for (je = *n; je >= 1; --je) {
+
+/* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or */
+/* (b) this would be the second of a complex pair. */
+/* Check for complex eigenvalue, so as to be sure of which */
+/* entry(-ies) of SELECT to look at -- if complex, SELECT(JE) */
+/* or SELECT(JE-1). */
+/* If this is a complex pair, the 2-by-2 diagonal block */
+/* corresponding to the eigenvalue is in rows/columns JE-1:JE */
+
+ if (ilcplx) {
+ ilcplx = FALSE_;
+ goto L500;
+ }
+ nw = 1;
+ if (je > 1) {
+ if (s[je + (je - 1) * s_dim1] != 0.f) {
+ ilcplx = TRUE_;
+ nw = 2;
+ }
+ }
+ if (ilall) {
+ ilcomp = TRUE_;
+ } else if (ilcplx) {
+ ilcomp = select[je] || select[je - 1];
+ } else {
+ ilcomp = select[je];
+ }
+ if (! ilcomp) {
+ goto L500;
+ }
+
+/* Decide if (a) singular pencil, (b) real eigenvalue, or */
+/* (c) complex eigenvalue. */
+
+ if (! ilcplx) {
+ if ((r__1 = s[je + je * s_dim1], dabs(r__1)) <= safmin && (
+ r__2 = p[je + je * p_dim1], dabs(r__2)) <= safmin) {
+
+/* Singular matrix pencil -- unit eigenvector */
+
+ --ieig;
+ i__1 = *n;
+ for (jr = 1; jr <= i__1; ++jr) {
+ vr[jr + ieig * vr_dim1] = 0.f;
+/* L230: */
+ }
+ vr[ieig + ieig * vr_dim1] = 1.f;
+ goto L500;
+ }
+ }
+
+/* Clear vector */
+
+ i__1 = nw - 1;
+ for (jw = 0; jw <= i__1; ++jw) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ work[(jw + 2) * *n + jr] = 0.f;
+/* L240: */
+ }
+/* L250: */
+ }
+
+/* Compute coefficients in ( a A - b B ) x = 0 */
+/* a is ACOEF */
+/* b is BCOEFR + i*BCOEFI */
+
+ if (! ilcplx) {
+
+/* Real eigenvalue */
+
+/* Computing MAX */
+ r__3 = (r__1 = s[je + je * s_dim1], dabs(r__1)) * ascale,
+ r__4 = (r__2 = p[je + je * p_dim1], dabs(r__2)) *
+ bscale, r__3 = max(r__3,r__4);
+ temp = 1.f / dmax(r__3,safmin);
+ salfar = temp * s[je + je * s_dim1] * ascale;
+ sbeta = temp * p[je + je * p_dim1] * bscale;
+ acoef = sbeta * ascale;
+ bcoefr = salfar * bscale;
+ bcoefi = 0.f;
+
+/* Scale to avoid underflow */
+
+ scale = 1.f;
+ lsa = dabs(sbeta) >= safmin && dabs(acoef) < small;
+ lsb = dabs(salfar) >= safmin && dabs(bcoefr) < small;
+ if (lsa) {
+ scale = small / dabs(sbeta) * dmin(anorm,big);
+ }
+ if (lsb) {
+/* Computing MAX */
+ r__1 = scale, r__2 = small / dabs(salfar) * dmin(bnorm,
+ big);
+ scale = dmax(r__1,r__2);
+ }
+ if (lsa || lsb) {
+/* Computing MIN */
+/* Computing MAX */
+ r__3 = 1.f, r__4 = dabs(acoef), r__3 = max(r__3,r__4),
+ r__4 = dabs(bcoefr);
+ r__1 = scale, r__2 = 1.f / (safmin * dmax(r__3,r__4));
+ scale = dmin(r__1,r__2);
+ if (lsa) {
+ acoef = ascale * (scale * sbeta);
+ } else {
+ acoef = scale * acoef;
+ }
+ if (lsb) {
+ bcoefr = bscale * (scale * salfar);
+ } else {
+ bcoefr = scale * bcoefr;
+ }
+ }
+ acoefa = dabs(acoef);
+ bcoefa = dabs(bcoefr);
+
+/* First component is 1 */
+
+ work[(*n << 1) + je] = 1.f;
+ xmax = 1.f;
+
+/* Compute contribution from column JE of A and B to sum */
+/* (See "Further Details", above.) */
+
+ i__1 = je - 1;
+ for (jr = 1; jr <= i__1; ++jr) {
+ work[(*n << 1) + jr] = bcoefr * p[jr + je * p_dim1] -
+ acoef * s[jr + je * s_dim1];
+/* L260: */
+ }
+ } else {
+
+/* Complex eigenvalue */
+
+ r__1 = safmin * 100.f;
+ slag2_(&s[je - 1 + (je - 1) * s_dim1], lds, &p[je - 1 + (je -
+ 1) * p_dim1], ldp, &r__1, &acoef, &temp, &bcoefr, &
+ temp2, &bcoefi);
+ if (bcoefi == 0.f) {
+ *info = je - 1;
+ return 0;
+ }
+
+/* Scale to avoid over/underflow */
+
+ acoefa = dabs(acoef);
+ bcoefa = dabs(bcoefr) + dabs(bcoefi);
+ scale = 1.f;
+ if (acoefa * ulp < safmin && acoefa >= safmin) {
+ scale = safmin / ulp / acoefa;
+ }
+ if (bcoefa * ulp < safmin && bcoefa >= safmin) {
+/* Computing MAX */
+ r__1 = scale, r__2 = safmin / ulp / bcoefa;
+ scale = dmax(r__1,r__2);
+ }
+ if (safmin * acoefa > ascale) {
+ scale = ascale / (safmin * acoefa);
+ }
+ if (safmin * bcoefa > bscale) {
+/* Computing MIN */
+ r__1 = scale, r__2 = bscale / (safmin * bcoefa);
+ scale = dmin(r__1,r__2);
+ }
+ if (scale != 1.f) {
+ acoef = scale * acoef;
+ acoefa = dabs(acoef);
+ bcoefr = scale * bcoefr;
+ bcoefi = scale * bcoefi;
+ bcoefa = dabs(bcoefr) + dabs(bcoefi);
+ }
+
+/* Compute first two components of eigenvector */
+/* and contribution to sums */
+
+ temp = acoef * s[je + (je - 1) * s_dim1];
+ temp2r = acoef * s[je + je * s_dim1] - bcoefr * p[je + je *
+ p_dim1];
+ temp2i = -bcoefi * p[je + je * p_dim1];
+ if (dabs(temp) >= dabs(temp2r) + dabs(temp2i)) {
+ work[(*n << 1) + je] = 1.f;
+ work[*n * 3 + je] = 0.f;
+ work[(*n << 1) + je - 1] = -temp2r / temp;
+ work[*n * 3 + je - 1] = -temp2i / temp;
+ } else {
+ work[(*n << 1) + je - 1] = 1.f;
+ work[*n * 3 + je - 1] = 0.f;
+ temp = acoef * s[je - 1 + je * s_dim1];
+ work[(*n << 1) + je] = (bcoefr * p[je - 1 + (je - 1) *
+ p_dim1] - acoef * s[je - 1 + (je - 1) * s_dim1]) /
+ temp;
+ work[*n * 3 + je] = bcoefi * p[je - 1 + (je - 1) * p_dim1]
+ / temp;
+ }
+
+/* Computing MAX */
+ r__5 = (r__1 = work[(*n << 1) + je], dabs(r__1)) + (r__2 =
+ work[*n * 3 + je], dabs(r__2)), r__6 = (r__3 = work[(*
+ n << 1) + je - 1], dabs(r__3)) + (r__4 = work[*n * 3
+ + je - 1], dabs(r__4));
+ xmax = dmax(r__5,r__6);
+
+/* Compute contribution from columns JE and JE-1 */
+/* of A and B to the sums. */
+
+ creala = acoef * work[(*n << 1) + je - 1];
+ cimaga = acoef * work[*n * 3 + je - 1];
+ crealb = bcoefr * work[(*n << 1) + je - 1] - bcoefi * work[*n
+ * 3 + je - 1];
+ cimagb = bcoefi * work[(*n << 1) + je - 1] + bcoefr * work[*n
+ * 3 + je - 1];
+ cre2a = acoef * work[(*n << 1) + je];
+ cim2a = acoef * work[*n * 3 + je];
+ cre2b = bcoefr * work[(*n << 1) + je] - bcoefi * work[*n * 3
+ + je];
+ cim2b = bcoefi * work[(*n << 1) + je] + bcoefr * work[*n * 3
+ + je];
+ i__1 = je - 2;
+ for (jr = 1; jr <= i__1; ++jr) {
+ work[(*n << 1) + jr] = -creala * s[jr + (je - 1) * s_dim1]
+ + crealb * p[jr + (je - 1) * p_dim1] - cre2a * s[
+ jr + je * s_dim1] + cre2b * p[jr + je * p_dim1];
+ work[*n * 3 + jr] = -cimaga * s[jr + (je - 1) * s_dim1] +
+ cimagb * p[jr + (je - 1) * p_dim1] - cim2a * s[jr
+ + je * s_dim1] + cim2b * p[jr + je * p_dim1];
+/* L270: */
+ }
+ }
+
+/* Computing MAX */
+ r__1 = ulp * acoefa * anorm, r__2 = ulp * bcoefa * bnorm, r__1 =
+ max(r__1,r__2);
+ dmin__ = dmax(r__1,safmin);
+
+/* Columnwise triangular solve of (a A - b B) x = 0 */
+
+ il2by2 = FALSE_;
+ for (j = je - nw; j >= 1; --j) {
+
+/* If a 2-by-2 block, is in position j-1:j, wait until */
+/* next iteration to process it (when it will be j:j+1) */
+
+ if (! il2by2 && j > 1) {
+ if (s[j + (j - 1) * s_dim1] != 0.f) {
+ il2by2 = TRUE_;
+ goto L370;
+ }
+ }
+ bdiag[0] = p[j + j * p_dim1];
+ if (il2by2) {
+ na = 2;
+ bdiag[1] = p[j + 1 + (j + 1) * p_dim1];
+ } else {
+ na = 1;
+ }
+
+/* Compute x(j) (and x(j+1), if 2-by-2 block) */
+
+ slaln2_(&c_false, &na, &nw, &dmin__, &acoef, &s[j + j *
+ s_dim1], lds, bdiag, &bdiag[1], &work[(*n << 1) + j],
+ n, &bcoefr, &bcoefi, sum, &c__2, &scale, &temp, &
+ iinfo);
+ if (scale < 1.f) {
+
+ i__1 = nw - 1;
+ for (jw = 0; jw <= i__1; ++jw) {
+ i__2 = je;
+ for (jr = 1; jr <= i__2; ++jr) {
+ work[(jw + 2) * *n + jr] = scale * work[(jw + 2) *
+ *n + jr];
+/* L280: */
+ }
+/* L290: */
+ }
+ }
+/* Computing MAX */
+ r__1 = scale * xmax;
+ xmax = dmax(r__1,temp);
+
+ i__1 = nw;
+ for (jw = 1; jw <= i__1; ++jw) {
+ i__2 = na;
+ for (ja = 1; ja <= i__2; ++ja) {
+ work[(jw + 1) * *n + j + ja - 1] = sum[ja + (jw << 1)
+ - 3];
+/* L300: */
+ }
+/* L310: */
+ }
+
+/* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling */
+
+ if (j > 1) {
+
+/* Check whether scaling is necessary for sum. */
+
+ xscale = 1.f / dmax(1.f,xmax);
+ temp = acoefa * work[j] + bcoefa * work[*n + j];
+ if (il2by2) {
+/* Computing MAX */
+ r__1 = temp, r__2 = acoefa * work[j + 1] + bcoefa *
+ work[*n + j + 1];
+ temp = dmax(r__1,r__2);
+ }
+/* Computing MAX */
+ r__1 = max(temp,acoefa);
+ temp = dmax(r__1,bcoefa);
+ if (temp > bignum * xscale) {
+
+ i__1 = nw - 1;
+ for (jw = 0; jw <= i__1; ++jw) {
+ i__2 = je;
+ for (jr = 1; jr <= i__2; ++jr) {
+ work[(jw + 2) * *n + jr] = xscale * work[(jw
+ + 2) * *n + jr];
+/* L320: */
+ }
+/* L330: */
+ }
+ xmax *= xscale;
+ }
+
+/* Compute the contributions of the off-diagonals of */
+/* column j (and j+1, if 2-by-2 block) of A and B to the */
+/* sums. */
+
+
+ i__1 = na;
+ for (ja = 1; ja <= i__1; ++ja) {
+ if (ilcplx) {
+ creala = acoef * work[(*n << 1) + j + ja - 1];
+ cimaga = acoef * work[*n * 3 + j + ja - 1];
+ crealb = bcoefr * work[(*n << 1) + j + ja - 1] -
+ bcoefi * work[*n * 3 + j + ja - 1];
+ cimagb = bcoefi * work[(*n << 1) + j + ja - 1] +
+ bcoefr * work[*n * 3 + j + ja - 1];
+ i__2 = j - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ work[(*n << 1) + jr] = work[(*n << 1) + jr] -
+ creala * s[jr + (j + ja - 1) * s_dim1]
+ + crealb * p[jr + (j + ja - 1) *
+ p_dim1];
+ work[*n * 3 + jr] = work[*n * 3 + jr] -
+ cimaga * s[jr + (j + ja - 1) * s_dim1]
+ + cimagb * p[jr + (j + ja - 1) *
+ p_dim1];
+/* L340: */
+ }
+ } else {
+ creala = acoef * work[(*n << 1) + j + ja - 1];
+ crealb = bcoefr * work[(*n << 1) + j + ja - 1];
+ i__2 = j - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ work[(*n << 1) + jr] = work[(*n << 1) + jr] -
+ creala * s[jr + (j + ja - 1) * s_dim1]
+ + crealb * p[jr + (j + ja - 1) *
+ p_dim1];
+/* L350: */
+ }
+ }
+/* L360: */
+ }
+ }
+
+ il2by2 = FALSE_;
+L370:
+ ;
+ }
+
+/* Copy eigenvector to VR, back transforming if */
+/* HOWMNY='B'. */
+
+ ieig -= nw;
+ if (ilback) {
+
+ i__1 = nw - 1;
+ for (jw = 0; jw <= i__1; ++jw) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ work[(jw + 4) * *n + jr] = work[(jw + 2) * *n + 1] *
+ vr[jr + vr_dim1];
+/* L380: */
+ }
+
+/* A series of compiler directives to defeat */
+/* vectorization for the next loop */
+
+
+ i__2 = je;
+ for (jc = 2; jc <= i__2; ++jc) {
+ i__3 = *n;
+ for (jr = 1; jr <= i__3; ++jr) {
+ work[(jw + 4) * *n + jr] += work[(jw + 2) * *n +
+ jc] * vr[jr + jc * vr_dim1];
+/* L390: */
+ }
+/* L400: */
+ }
+/* L410: */
+ }
+
+ i__1 = nw - 1;
+ for (jw = 0; jw <= i__1; ++jw) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vr[jr + (ieig + jw) * vr_dim1] = work[(jw + 4) * *n +
+ jr];
+/* L420: */
+ }
+/* L430: */
+ }
+
+ iend = *n;
+ } else {
+ i__1 = nw - 1;
+ for (jw = 0; jw <= i__1; ++jw) {
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vr[jr + (ieig + jw) * vr_dim1] = work[(jw + 2) * *n +
+ jr];
+/* L440: */
+ }
+/* L450: */
+ }
+
+ iend = je;
+ }
+
+/* Scale eigenvector */
+
+ xmax = 0.f;
+ if (ilcplx) {
+ i__1 = iend;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ r__3 = xmax, r__4 = (r__1 = vr[j + ieig * vr_dim1], dabs(
+ r__1)) + (r__2 = vr[j + (ieig + 1) * vr_dim1],
+ dabs(r__2));
+ xmax = dmax(r__3,r__4);
+/* L460: */
+ }
+ } else {
+ i__1 = iend;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ r__2 = xmax, r__3 = (r__1 = vr[j + ieig * vr_dim1], dabs(
+ r__1));
+ xmax = dmax(r__2,r__3);
+/* L470: */
+ }
+ }
+
+ if (xmax > safmin) {
+ xscale = 1.f / xmax;
+ i__1 = nw - 1;
+ for (jw = 0; jw <= i__1; ++jw) {
+ i__2 = iend;
+ for (jr = 1; jr <= i__2; ++jr) {
+ vr[jr + (ieig + jw) * vr_dim1] = xscale * vr[jr + (
+ ieig + jw) * vr_dim1];
+/* L480: */
+ }
+/* L490: */
+ }
+ }
+L500:
+ ;
+ }
+ }
+
+ return 0;
+
+/* End of STGEVC */
+
+} /* stgevc_ */
diff --git a/SRC/stgex2.c b/SRC/stgex2.c
new file mode 100644
index 0000000..38d813d
--- /dev/null
+++ b/SRC/stgex2.c
@@ -0,0 +1,706 @@
+/* stgex2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__4 = 4;
+static real c_b5 = 0.f;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static real c_b42 = 1.f;
+static real c_b48 = -1.f;
+static integer c__0 = 0;
+
+/* Subroutine */ int stgex2_(logical *wantq, logical *wantz, integer *n, real
+ *a, integer *lda, real *b, integer *ldb, real *q, integer *ldq, real *
+ z__, integer *ldz, integer *j1, integer *n1, integer *n2, real *work,
+ integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
+ z_offset, i__1, i__2;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real f, g;
+ integer i__, m;
+ real s[16] /* was [4][4] */, t[16] /* was [4][4] */, be[2], ai[2], ar[2],
+ sa, sb, li[16] /* was [4][4] */, ir[16] /* was [4][4]
+ */, ss, ws, eps;
+ logical weak;
+ real ddum;
+ integer idum;
+ real taul[4], dsum, taur[4], scpy[16] /* was [4][4] */, tcpy[16]
+ /* was [4][4] */;
+ extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
+ integer *, real *, real *);
+ real scale, bqra21, brqa21;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real licop[16] /* was [4][4] */;
+ integer linfo;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real ircop[16] /* was [4][4] */, dnorm;
+ integer iwork[4];
+ extern /* Subroutine */ int slagv2_(real *, integer *, real *, integer *,
+ real *, real *, real *, real *, real *, real *, real *), sgeqr2_(
+ integer *, integer *, real *, integer *, real *, real *, integer *
+), sgerq2_(integer *, integer *, real *, integer *, real *, real *
+, integer *), sorg2r_(integer *, integer *, integer *, real *,
+ integer *, real *, real *, integer *), sorgr2_(integer *, integer
+ *, integer *, real *, integer *, real *, real *, integer *),
+ sorm2r_(char *, char *, integer *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *, integer *), sormr2_(char *, char *, integer *, integer *, integer *,
+ real *, integer *, real *, real *, integer *, real *, integer *);
+ real dscale;
+ extern /* Subroutine */ int stgsy2_(char *, integer *, integer *, integer
+ *, real *, integer *, real *, integer *, real *, integer *, real *
+, integer *, real *, integer *, real *, integer *, real *, real *,
+ real *, integer *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slartg_(real *, real *,
+ real *, real *, real *);
+ real thresh;
+ extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *), slassq_(integer *, real *,
+ integer *, real *, real *);
+ real smlnum;
+ logical strong;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22) */
+/* of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair */
+/* (A, B) by an orthogonal equivalence transformation. */
+
+/* (A, B) must be in generalized real Schur canonical form (as returned */
+/* by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 */
+/* diagonal blocks. B is upper triangular. */
+
+/* Optionally, the matrices Q and Z of generalized Schur vectors are */
+/* updated. */
+
+/* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' */
+/* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' */
+
+
+/* Arguments */
+/* ========= */
+
+/* WANTQ (input) LOGICAL */
+/* .TRUE. : update the left transformation matrix Q; */
+/* .FALSE.: do not update Q. */
+
+/* WANTZ (input) LOGICAL */
+/* .TRUE. : update the right transformation matrix Z; */
+/* .FALSE.: do not update Z. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) REAL arrays, dimensions (LDA,N) */
+/* On entry, the matrix A in the pair (A, B). */
+/* On exit, the updated matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) REAL arrays, dimensions (LDB,N) */
+/* On entry, the matrix B in the pair (A, B). */
+/* On exit, the updated matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Q (input/output) REAL array, dimension (LDZ,N) */
+/* On entry, if WANTQ = .TRUE., the orthogonal matrix Q. */
+/* On exit, the updated matrix Q. */
+/* Not referenced if WANTQ = .FALSE.. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= 1. */
+/* If WANTQ = .TRUE., LDQ >= N. */
+
+/* Z (input/output) REAL array, dimension (LDZ,N) */
+/* On entry, if WANTZ =.TRUE., the orthogonal matrix Z. */
+/* On exit, the updated matrix Z. */
+/* Not referenced if WANTZ = .FALSE.. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1. */
+/* If WANTZ = .TRUE., LDZ >= N. */
+
+/* J1 (input) INTEGER */
+/* The index to the first block (A11, B11). 1 <= J1 <= N. */
+
+/* N1 (input) INTEGER */
+/* The order of the first block (A11, B11). N1 = 0, 1 or 2. */
+
+/* N2 (input) INTEGER */
+/* The order of the second block (A22, B22). N2 = 0, 1 or 2. */
+
+/* WORK (workspace) REAL array, dimension (MAX(1,LWORK)). */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* LWORK >= MAX( N*(N2+N1), (N2+N1)*(N2+N1)*2 ) */
+
+/* INFO (output) INTEGER */
+/* =0: Successful exit */
+/* >0: If INFO = 1, the transformed matrix (A, B) would be */
+/* too far from generalized Schur form; the blocks are */
+/* not swapped and (A, B) and (Q, Z) are unchanged. */
+/* The problem of swapping is too ill-conditioned. */
+/* <0: If INFO = -16: LWORK is too small. Appropriate value */
+/* for LWORK is returned in WORK(1). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* In the current code both weak and strong stability tests are */
+/* performed. The user can omit the strong stability test by changing */
+/* the internal logical parameter WANDS to .FALSE.. See ref. [2] for */
+/* details. */
+
+/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
+/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
+/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
+/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
+
+/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
+/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
+/* Estimation: Theory, Algorithms and Software, */
+/* Report UMINF - 94.04, Department of Computing Science, Umea */
+/* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */
+/* Note 87. To appear in Numerical Algorithms, 1996. */
+
+/* ===================================================================== */
+/* Replaced various illegal calls to SCOPY by calls to SLASET, or by DO */
+/* loops. Sven Hammarling, 1/5/02. */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n <= 1 || *n1 <= 0 || *n2 <= 0) {
+ return 0;
+ }
+ if (*n1 > *n || *j1 + *n1 > *n) {
+ return 0;
+ }
+ m = *n1 + *n2;
+/* Computing MAX */
+ i__1 = *n * m, i__2 = m * m << 1;
+ if (*lwork < max(i__1,i__2)) {
+ *info = -16;
+/* Computing MAX */
+ i__1 = *n * m, i__2 = m * m << 1;
+ work[1] = (real) max(i__1,i__2);
+ return 0;
+ }
+
+ weak = FALSE_;
+ strong = FALSE_;
+
+/* Make a local copy of selected block */
+
+ slaset_("Full", &c__4, &c__4, &c_b5, &c_b5, li, &c__4);
+ slaset_("Full", &c__4, &c__4, &c_b5, &c_b5, ir, &c__4);
+ slacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, s, &c__4);
+ slacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, t, &c__4);
+
+/* Compute threshold for testing acceptance of swapping. */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S") / eps;
+ dscale = 0.f;
+ dsum = 1.f;
+ slacpy_("Full", &m, &m, s, &c__4, &work[1], &m);
+ i__1 = m * m;
+ slassq_(&i__1, &work[1], &c__1, &dscale, &dsum);
+ slacpy_("Full", &m, &m, t, &c__4, &work[1], &m);
+ i__1 = m * m;
+ slassq_(&i__1, &work[1], &c__1, &dscale, &dsum);
+ dnorm = dscale * sqrt(dsum);
+/* Computing MAX */
+ r__1 = eps * 10.f * dnorm;
+ thresh = dmax(r__1,smlnum);
+
+ if (m == 2) {
+
+/* CASE 1: Swap 1-by-1 and 1-by-1 blocks. */
+
+/* Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks */
+/* using Givens rotations and perform the swap tentatively. */
+
+ f = s[5] * t[0] - t[5] * s[0];
+ g = s[5] * t[4] - t[5] * s[4];
+ sb = dabs(t[5]);
+ sa = dabs(s[5]);
+ slartg_(&f, &g, &ir[4], ir, &ddum);
+ ir[1] = -ir[4];
+ ir[5] = ir[0];
+ srot_(&c__2, s, &c__1, &s[4], &c__1, ir, &ir[1]);
+ srot_(&c__2, t, &c__1, &t[4], &c__1, ir, &ir[1]);
+ if (sa >= sb) {
+ slartg_(s, &s[1], li, &li[1], &ddum);
+ } else {
+ slartg_(t, &t[1], li, &li[1], &ddum);
+ }
+ srot_(&c__2, s, &c__4, &s[1], &c__4, li, &li[1]);
+ srot_(&c__2, t, &c__4, &t[1], &c__4, li, &li[1]);
+ li[5] = li[0];
+ li[4] = -li[1];
+
+/* Weak stability test: */
+/* |S21| + |T21| <= O(EPS * F-norm((S, T))) */
+
+ ws = dabs(s[1]) + dabs(t[1]);
+ weak = ws <= thresh;
+ if (! weak) {
+ goto L70;
+ }
+
+ if (TRUE_) {
+
+/* Strong stability test: */
+/* F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A,B))) */
+
+ slacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, &work[m * m
+ + 1], &m);
+ sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, &
+ work[1], &m);
+ sgemm_("N", "T", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
+ c_b42, &work[m * m + 1], &m);
+ dscale = 0.f;
+ dsum = 1.f;
+ i__1 = m * m;
+ slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
+
+ slacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, &work[m * m
+ + 1], &m);
+ sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, &
+ work[1], &m);
+ sgemm_("N", "T", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
+ c_b42, &work[m * m + 1], &m);
+ i__1 = m * m;
+ slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
+ ss = dscale * sqrt(dsum);
+ strong = ss <= thresh;
+ if (! strong) {
+ goto L70;
+ }
+ }
+
+/* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and */
+/* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */
+
+ i__1 = *j1 + 1;
+ srot_(&i__1, &a[*j1 * a_dim1 + 1], &c__1, &a[(*j1 + 1) * a_dim1 + 1],
+ &c__1, ir, &ir[1]);
+ i__1 = *j1 + 1;
+ srot_(&i__1, &b[*j1 * b_dim1 + 1], &c__1, &b[(*j1 + 1) * b_dim1 + 1],
+ &c__1, ir, &ir[1]);
+ i__1 = *n - *j1 + 1;
+ srot_(&i__1, &a[*j1 + *j1 * a_dim1], lda, &a[*j1 + 1 + *j1 * a_dim1],
+ lda, li, &li[1]);
+ i__1 = *n - *j1 + 1;
+ srot_(&i__1, &b[*j1 + *j1 * b_dim1], ldb, &b[*j1 + 1 + *j1 * b_dim1],
+ ldb, li, &li[1]);
+
+/* Set N1-by-N2 (2,1) - blocks to ZERO. */
+
+ a[*j1 + 1 + *j1 * a_dim1] = 0.f;
+ b[*j1 + 1 + *j1 * b_dim1] = 0.f;
+
+/* Accumulate transformations into Q and Z if requested. */
+
+ if (*wantz) {
+ srot_(n, &z__[*j1 * z_dim1 + 1], &c__1, &z__[(*j1 + 1) * z_dim1 +
+ 1], &c__1, ir, &ir[1]);
+ }
+ if (*wantq) {
+ srot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[(*j1 + 1) * q_dim1 + 1],
+ &c__1, li, &li[1]);
+ }
+
+/* Exit with INFO = 0 if swap was successfully performed. */
+
+ return 0;
+
+ } else {
+
+/* CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2 */
+/* and 2-by-2 blocks. */
+
+/* Solve the generalized Sylvester equation */
+/* S11 * R - L * S22 = SCALE * S12 */
+/* T11 * R - L * T22 = SCALE * T12 */
+/* for R and L. Solutions in LI and IR. */
+
+ slacpy_("Full", n1, n2, &t[(*n1 + 1 << 2) - 4], &c__4, li, &c__4);
+ slacpy_("Full", n1, n2, &s[(*n1 + 1 << 2) - 4], &c__4, &ir[*n2 + 1 + (
+ *n1 + 1 << 2) - 5], &c__4);
+ stgsy2_("N", &c__0, n1, n2, s, &c__4, &s[*n1 + 1 + (*n1 + 1 << 2) - 5]
+, &c__4, &ir[*n2 + 1 + (*n1 + 1 << 2) - 5], &c__4, t, &c__4, &
+ t[*n1 + 1 + (*n1 + 1 << 2) - 5], &c__4, li, &c__4, &scale, &
+ dsum, &dscale, iwork, &idum, &linfo);
+
+/* Compute orthogonal matrix QL: */
+
+/* QL' * LI = [ TL ] */
+/* [ 0 ] */
+/* where */
+/* LI = [ -L ] */
+/* [ SCALE * identity(N2) ] */
+
+ i__1 = *n2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sscal_(n1, &c_b48, &li[(i__ << 2) - 4], &c__1);
+ li[*n1 + i__ + (i__ << 2) - 5] = scale;
+/* L10: */
+ }
+ sgeqr2_(&m, n2, li, &c__4, taul, &work[1], &linfo);
+ if (linfo != 0) {
+ goto L70;
+ }
+ sorg2r_(&m, &m, n2, li, &c__4, taul, &work[1], &linfo);
+ if (linfo != 0) {
+ goto L70;
+ }
+
+/* Compute orthogonal matrix RQ: */
+
+/* IR * RQ' = [ 0 TR], */
+
+/* where IR = [ SCALE * identity(N1), R ] */
+
+ i__1 = *n1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ir[*n2 + i__ + (i__ << 2) - 5] = scale;
+/* L20: */
+ }
+ sgerq2_(n1, &m, &ir[*n2], &c__4, taur, &work[1], &linfo);
+ if (linfo != 0) {
+ goto L70;
+ }
+ sorgr2_(&m, &m, n1, ir, &c__4, taur, &work[1], &linfo);
+ if (linfo != 0) {
+ goto L70;
+ }
+
+/* Perform the swapping tentatively: */
+
+ sgemm_("T", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, &
+ work[1], &m);
+ sgemm_("N", "T", &m, &m, &m, &c_b42, &work[1], &m, ir, &c__4, &c_b5,
+ s, &c__4);
+ sgemm_("T", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, &
+ work[1], &m);
+ sgemm_("N", "T", &m, &m, &m, &c_b42, &work[1], &m, ir, &c__4, &c_b5,
+ t, &c__4);
+ slacpy_("F", &m, &m, s, &c__4, scpy, &c__4);
+ slacpy_("F", &m, &m, t, &c__4, tcpy, &c__4);
+ slacpy_("F", &m, &m, ir, &c__4, ircop, &c__4);
+ slacpy_("F", &m, &m, li, &c__4, licop, &c__4);
+
+/* Triangularize the B-part by an RQ factorization. */
+/* Apply transformation (from left) to A-part, giving S. */
+
+ sgerq2_(&m, &m, t, &c__4, taur, &work[1], &linfo);
+ if (linfo != 0) {
+ goto L70;
+ }
+ sormr2_("R", "T", &m, &m, &m, t, &c__4, taur, s, &c__4, &work[1], &
+ linfo);
+ if (linfo != 0) {
+ goto L70;
+ }
+ sormr2_("L", "N", &m, &m, &m, t, &c__4, taur, ir, &c__4, &work[1], &
+ linfo);
+ if (linfo != 0) {
+ goto L70;
+ }
+
+/* Compute F-norm(S21) in BRQA21. (T21 is 0.) */
+
+ dscale = 0.f;
+ dsum = 1.f;
+ i__1 = *n2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ slassq_(n1, &s[*n2 + 1 + (i__ << 2) - 5], &c__1, &dscale, &dsum);
+/* L30: */
+ }
+ brqa21 = dscale * sqrt(dsum);
+
+/* Triangularize the B-part by a QR factorization. */
+/* Apply transformation (from right) to A-part, giving S. */
+
+ sgeqr2_(&m, &m, tcpy, &c__4, taul, &work[1], &linfo);
+ if (linfo != 0) {
+ goto L70;
+ }
+ sorm2r_("L", "T", &m, &m, &m, tcpy, &c__4, taul, scpy, &c__4, &work[1]
+, info);
+ sorm2r_("R", "N", &m, &m, &m, tcpy, &c__4, taul, licop, &c__4, &work[
+ 1], info);
+ if (linfo != 0) {
+ goto L70;
+ }
+
+/* Compute F-norm(S21) in BQRA21. (T21 is 0.) */
+
+ dscale = 0.f;
+ dsum = 1.f;
+ i__1 = *n2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ slassq_(n1, &scpy[*n2 + 1 + (i__ << 2) - 5], &c__1, &dscale, &
+ dsum);
+/* L40: */
+ }
+ bqra21 = dscale * sqrt(dsum);
+
+/* Decide which method to use. */
+/* Weak stability test: */
+/* F-norm(S21) <= O(EPS * F-norm((S, T))) */
+
+ if (bqra21 <= brqa21 && bqra21 <= thresh) {
+ slacpy_("F", &m, &m, scpy, &c__4, s, &c__4);
+ slacpy_("F", &m, &m, tcpy, &c__4, t, &c__4);
+ slacpy_("F", &m, &m, ircop, &c__4, ir, &c__4);
+ slacpy_("F", &m, &m, licop, &c__4, li, &c__4);
+ } else if (brqa21 >= thresh) {
+ goto L70;
+ }
+
+/* Set lower triangle of B-part to zero */
+
+ i__1 = m - 1;
+ i__2 = m - 1;
+ slaset_("Lower", &i__1, &i__2, &c_b5, &c_b5, &t[1], &c__4);
+
+ if (TRUE_) {
+
+/* Strong stability test: */
+/* F-norm((A-QL*S*QR', B-QL*T*QR')) <= O(EPS*F-norm((A,B))) */
+
+ slacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, &work[m * m
+ + 1], &m);
+ sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, &
+ work[1], &m);
+ sgemm_("N", "N", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
+ c_b42, &work[m * m + 1], &m);
+ dscale = 0.f;
+ dsum = 1.f;
+ i__1 = m * m;
+ slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
+
+ slacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, &work[m * m
+ + 1], &m);
+ sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, &
+ work[1], &m);
+ sgemm_("N", "N", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, &
+ c_b42, &work[m * m + 1], &m);
+ i__1 = m * m;
+ slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum);
+ ss = dscale * sqrt(dsum);
+ strong = ss <= thresh;
+ if (! strong) {
+ goto L70;
+ }
+
+ }
+
+/* If the swap is accepted ("weakly" and "strongly"), apply the */
+/* transformations and set N1-by-N2 (2,1)-block to zero. */
+
+ slaset_("Full", n1, n2, &c_b5, &c_b5, &s[*n2], &c__4);
+
+/* copy back M-by-M diagonal block starting at index J1 of (A, B) */
+
+ slacpy_("F", &m, &m, s, &c__4, &a[*j1 + *j1 * a_dim1], lda)
+ ;
+ slacpy_("F", &m, &m, t, &c__4, &b[*j1 + *j1 * b_dim1], ldb)
+ ;
+ slaset_("Full", &c__4, &c__4, &c_b5, &c_b5, t, &c__4);
+
+/* Standardize existing 2-by-2 blocks. */
+
+ i__1 = m * m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.f;
+/* L50: */
+ }
+ work[1] = 1.f;
+ t[0] = 1.f;
+ idum = *lwork - m * m - 2;
+ if (*n2 > 1) {
+ slagv2_(&a[*j1 + *j1 * a_dim1], lda, &b[*j1 + *j1 * b_dim1], ldb,
+ ar, ai, be, &work[1], &work[2], t, &t[1]);
+ work[m + 1] = -work[2];
+ work[m + 2] = work[1];
+ t[*n2 + (*n2 << 2) - 5] = t[0];
+ t[4] = -t[1];
+ }
+ work[m * m] = 1.f;
+ t[m + (m << 2) - 5] = 1.f;
+
+ if (*n1 > 1) {
+ slagv2_(&a[*j1 + *n2 + (*j1 + *n2) * a_dim1], lda, &b[*j1 + *n2 +
+ (*j1 + *n2) * b_dim1], ldb, taur, taul, &work[m * m + 1],
+ &work[*n2 * m + *n2 + 1], &work[*n2 * m + *n2 + 2], &t[*
+ n2 + 1 + (*n2 + 1 << 2) - 5], &t[m + (m - 1 << 2) - 5]);
+ work[m * m] = work[*n2 * m + *n2 + 1];
+ work[m * m - 1] = -work[*n2 * m + *n2 + 2];
+ t[m + (m << 2) - 5] = t[*n2 + 1 + (*n2 + 1 << 2) - 5];
+ t[m - 1 + (m << 2) - 5] = -t[m + (m - 1 << 2) - 5];
+ }
+ sgemm_("T", "N", n2, n1, n2, &c_b42, &work[1], &m, &a[*j1 + (*j1 + *
+ n2) * a_dim1], lda, &c_b5, &work[m * m + 1], n2);
+ slacpy_("Full", n2, n1, &work[m * m + 1], n2, &a[*j1 + (*j1 + *n2) *
+ a_dim1], lda);
+ sgemm_("T", "N", n2, n1, n2, &c_b42, &work[1], &m, &b[*j1 + (*j1 + *
+ n2) * b_dim1], ldb, &c_b5, &work[m * m + 1], n2);
+ slacpy_("Full", n2, n1, &work[m * m + 1], n2, &b[*j1 + (*j1 + *n2) *
+ b_dim1], ldb);
+ sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, &work[1], &m, &c_b5, &
+ work[m * m + 1], &m);
+ slacpy_("Full", &m, &m, &work[m * m + 1], &m, li, &c__4);
+ sgemm_("N", "N", n2, n1, n1, &c_b42, &a[*j1 + (*j1 + *n2) * a_dim1],
+ lda, &t[*n2 + 1 + (*n2 + 1 << 2) - 5], &c__4, &c_b5, &work[1],
+ n2);
+ slacpy_("Full", n2, n1, &work[1], n2, &a[*j1 + (*j1 + *n2) * a_dim1],
+ lda);
+ sgemm_("N", "N", n2, n1, n1, &c_b42, &b[*j1 + (*j1 + *n2) * b_dim1],
+ ldb, &t[*n2 + 1 + (*n2 + 1 << 2) - 5], &c__4, &c_b5, &work[1],
+ n2);
+ slacpy_("Full", n2, n1, &work[1], n2, &b[*j1 + (*j1 + *n2) * b_dim1],
+ ldb);
+ sgemm_("T", "N", &m, &m, &m, &c_b42, ir, &c__4, t, &c__4, &c_b5, &
+ work[1], &m);
+ slacpy_("Full", &m, &m, &work[1], &m, ir, &c__4);
+
+/* Accumulate transformations into Q and Z if requested. */
+
+ if (*wantq) {
+ sgemm_("N", "N", n, &m, &m, &c_b42, &q[*j1 * q_dim1 + 1], ldq, li,
+ &c__4, &c_b5, &work[1], n);
+ slacpy_("Full", n, &m, &work[1], n, &q[*j1 * q_dim1 + 1], ldq);
+
+ }
+
+ if (*wantz) {
+ sgemm_("N", "N", n, &m, &m, &c_b42, &z__[*j1 * z_dim1 + 1], ldz,
+ ir, &c__4, &c_b5, &work[1], n);
+ slacpy_("Full", n, &m, &work[1], n, &z__[*j1 * z_dim1 + 1], ldz);
+
+ }
+
+/* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and */
+/* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */
+
+ i__ = *j1 + m;
+ if (i__ <= *n) {
+ i__1 = *n - i__ + 1;
+ sgemm_("T", "N", &m, &i__1, &m, &c_b42, li, &c__4, &a[*j1 + i__ *
+ a_dim1], lda, &c_b5, &work[1], &m);
+ i__1 = *n - i__ + 1;
+ slacpy_("Full", &m, &i__1, &work[1], &m, &a[*j1 + i__ * a_dim1],
+ lda);
+ i__1 = *n - i__ + 1;
+ sgemm_("T", "N", &m, &i__1, &m, &c_b42, li, &c__4, &b[*j1 + i__ *
+ b_dim1], ldb, &c_b5, &work[1], &m);
+ i__1 = *n - i__ + 1;
+ slacpy_("Full", &m, &i__1, &work[1], &m, &b[*j1 + i__ * b_dim1],
+ ldb);
+ }
+ i__ = *j1 - 1;
+ if (i__ > 0) {
+ sgemm_("N", "N", &i__, &m, &m, &c_b42, &a[*j1 * a_dim1 + 1], lda,
+ ir, &c__4, &c_b5, &work[1], &i__);
+ slacpy_("Full", &i__, &m, &work[1], &i__, &a[*j1 * a_dim1 + 1],
+ lda);
+ sgemm_("N", "N", &i__, &m, &m, &c_b42, &b[*j1 * b_dim1 + 1], ldb,
+ ir, &c__4, &c_b5, &work[1], &i__);
+ slacpy_("Full", &i__, &m, &work[1], &i__, &b[*j1 * b_dim1 + 1],
+ ldb);
+ }
+
+/* Exit with INFO = 0 if swap was successfully performed. */
+
+ return 0;
+
+ }
+
+/* Exit with INFO = 1 if swap was rejected. */
+
+L70:
+
+ *info = 1;
+ return 0;
+
+/* End of STGEX2 */
+
+} /* stgex2_ */
diff --git a/SRC/stgexc.c b/SRC/stgexc.c
new file mode 100644
index 0000000..1255ee0
--- /dev/null
+++ b/SRC/stgexc.c
@@ -0,0 +1,514 @@
+/* stgexc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int stgexc_(logical *wantq, logical *wantz, integer *n, real
+ *a, integer *lda, real *b, integer *ldb, real *q, integer *ldq, real *
+ z__, integer *ldz, integer *ifst, integer *ilst, real *work, integer *
+ lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
+ z_offset, i__1;
+
+ /* Local variables */
+ integer nbf, nbl, here, lwmin;
+ extern /* Subroutine */ int stgex2_(logical *, logical *, integer *, real
+ *, integer *, real *, integer *, real *, integer *, real *,
+ integer *, integer *, integer *, integer *, real *, integer *,
+ integer *), xerbla_(char *, integer *);
+ integer nbnext;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STGEXC reorders the generalized real Schur decomposition of a real */
+/* matrix pair (A,B) using an orthogonal equivalence transformation */
+
+/* (A, B) = Q * (A, B) * Z', */
+
+/* so that the diagonal block of (A, B) with row index IFST is moved */
+/* to row ILST. */
+
+/* (A, B) must be in generalized real Schur canonical form (as returned */
+/* by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 */
+/* diagonal blocks. B is upper triangular. */
+
+/* Optionally, the matrices Q and Z of generalized Schur vectors are */
+/* updated. */
+
+/* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' */
+/* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' */
+
+
+/* Arguments */
+/* ========= */
+
+/* WANTQ (input) LOGICAL */
+/* .TRUE. : update the left transformation matrix Q; */
+/* .FALSE.: do not update Q. */
+
+/* WANTZ (input) LOGICAL */
+/* .TRUE. : update the right transformation matrix Z; */
+/* .FALSE.: do not update Z. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the matrix A in generalized real Schur canonical */
+/* form. */
+/* On exit, the updated matrix A, again in generalized */
+/* real Schur canonical form. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) REAL array, dimension (LDB,N) */
+/* On entry, the matrix B in generalized real Schur canonical */
+/* form (A,B). */
+/* On exit, the updated matrix B, again in generalized */
+/* real Schur canonical form (A,B). */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Q (input/output) REAL array, dimension (LDZ,N) */
+/* On entry, if WANTQ = .TRUE., the orthogonal matrix Q. */
+/* On exit, the updated matrix Q. */
+/* If WANTQ = .FALSE., Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= 1. */
+/* If WANTQ = .TRUE., LDQ >= N. */
+
+/* Z (input/output) REAL array, dimension (LDZ,N) */
+/* On entry, if WANTZ = .TRUE., the orthogonal matrix Z. */
+/* On exit, the updated matrix Z. */
+/* If WANTZ = .FALSE., Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1. */
+/* If WANTZ = .TRUE., LDZ >= N. */
+
+/* IFST (input/output) INTEGER */
+/* ILST (input/output) INTEGER */
+/* Specify the reordering of the diagonal blocks of (A, B). */
+/* The block with row index IFST is moved to row ILST, by a */
+/* sequence of swapping between adjacent blocks. */
+/* On exit, if IFST pointed on entry to the second row of */
+/* a 2-by-2 block, it is changed to point to the first row; */
+/* ILST always points to the first row of the block in its */
+/* final position (which may differ from its input value by */
+/* +1 or -1). 1 <= IFST, ILST <= N. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* LWORK >= 1 when N <= 1, otherwise LWORK >= 4*N + 16. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* =0: successful exit. */
+/* <0: if INFO = -i, the i-th argument had an illegal value. */
+/* =1: The transformed matrix pair (A, B) would be too far */
+/* from generalized Schur form; the problem is ill- */
+/* conditioned. (A, B) may have been partially reordered, */
+/* and ILST points to the first row of the current */
+/* position of the block being moved. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
+/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
+/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
+/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test input arguments. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldq < 1 || *wantq && *ldq < max(1,*n)) {
+ *info = -9;
+ } else if (*ldz < 1 || *wantz && *ldz < max(1,*n)) {
+ *info = -11;
+ } else if (*ifst < 1 || *ifst > *n) {
+ *info = -12;
+ } else if (*ilst < 1 || *ilst > *n) {
+ *info = -13;
+ }
+
+ if (*info == 0) {
+ if (*n <= 1) {
+ lwmin = 1;
+ } else {
+ lwmin = (*n << 2) + 16;
+ }
+ work[1] = (real) lwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -15;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STGEXC", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 1) {
+ return 0;
+ }
+
+/* Determine the first row of the specified block and find out */
+/* if it is 1-by-1 or 2-by-2. */
+
+ if (*ifst > 1) {
+ if (a[*ifst + (*ifst - 1) * a_dim1] != 0.f) {
+ --(*ifst);
+ }
+ }
+ nbf = 1;
+ if (*ifst < *n) {
+ if (a[*ifst + 1 + *ifst * a_dim1] != 0.f) {
+ nbf = 2;
+ }
+ }
+
+/* Determine the first row of the final block */
+/* and find out if it is 1-by-1 or 2-by-2. */
+
+ if (*ilst > 1) {
+ if (a[*ilst + (*ilst - 1) * a_dim1] != 0.f) {
+ --(*ilst);
+ }
+ }
+ nbl = 1;
+ if (*ilst < *n) {
+ if (a[*ilst + 1 + *ilst * a_dim1] != 0.f) {
+ nbl = 2;
+ }
+ }
+ if (*ifst == *ilst) {
+ return 0;
+ }
+
+ if (*ifst < *ilst) {
+
+/* Update ILST. */
+
+ if (nbf == 2 && nbl == 1) {
+ --(*ilst);
+ }
+ if (nbf == 1 && nbl == 2) {
+ ++(*ilst);
+ }
+
+ here = *ifst;
+
+L10:
+
+/* Swap with next one below. */
+
+ if (nbf == 1 || nbf == 2) {
+
+/* Current block either 1-by-1 or 2-by-2. */
+
+ nbnext = 1;
+ if (here + nbf + 1 <= *n) {
+ if (a[here + nbf + 1 + (here + nbf) * a_dim1] != 0.f) {
+ nbnext = 2;
+ }
+ }
+ stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[
+ q_offset], ldq, &z__[z_offset], ldz, &here, &nbf, &nbnext,
+ &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ here += nbnext;
+
+/* Test if 2-by-2 block breaks into two 1-by-1 blocks. */
+
+ if (nbf == 2) {
+ if (a[here + 1 + here * a_dim1] == 0.f) {
+ nbf = 3;
+ }
+ }
+
+ } else {
+
+/* Current block consists of two 1-by-1 blocks, each of which */
+/* must be swapped individually. */
+
+ nbnext = 1;
+ if (here + 3 <= *n) {
+ if (a[here + 3 + (here + 2) * a_dim1] != 0.f) {
+ nbnext = 2;
+ }
+ }
+ i__1 = here + 1;
+ stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[
+ q_offset], ldq, &z__[z_offset], ldz, &i__1, &c__1, &
+ nbnext, &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ if (nbnext == 1) {
+
+/* Swap two 1-by-1 blocks. */
+
+ stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb,
+ &q[q_offset], ldq, &z__[z_offset], ldz, &here, &c__1,
+ &c__1, &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ ++here;
+
+ } else {
+
+/* Recompute NBNEXT in case of 2-by-2 split. */
+
+ if (a[here + 2 + (here + 1) * a_dim1] == 0.f) {
+ nbnext = 1;
+ }
+ if (nbnext == 2) {
+
+/* 2-by-2 block did not split. */
+
+ stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
+ ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &
+ here, &c__1, &nbnext, &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ here += 2;
+ } else {
+
+/* 2-by-2 block did split. */
+
+ stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
+ ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &
+ here, &c__1, &c__1, &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ ++here;
+ stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
+ ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &
+ here, &c__1, &c__1, &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ ++here;
+ }
+
+ }
+ }
+ if (here < *ilst) {
+ goto L10;
+ }
+ } else {
+ here = *ifst;
+
+L20:
+
+/* Swap with next one below. */
+
+ if (nbf == 1 || nbf == 2) {
+
+/* Current block either 1-by-1 or 2-by-2. */
+
+ nbnext = 1;
+ if (here >= 3) {
+ if (a[here - 1 + (here - 2) * a_dim1] != 0.f) {
+ nbnext = 2;
+ }
+ }
+ i__1 = here - nbnext;
+ stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[
+ q_offset], ldq, &z__[z_offset], ldz, &i__1, &nbnext, &nbf,
+ &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ here -= nbnext;
+
+/* Test if 2-by-2 block breaks into two 1-by-1 blocks. */
+
+ if (nbf == 2) {
+ if (a[here + 1 + here * a_dim1] == 0.f) {
+ nbf = 3;
+ }
+ }
+
+ } else {
+
+/* Current block consists of two 1-by-1 blocks, each of which */
+/* must be swapped individually. */
+
+ nbnext = 1;
+ if (here >= 3) {
+ if (a[here - 1 + (here - 2) * a_dim1] != 0.f) {
+ nbnext = 2;
+ }
+ }
+ i__1 = here - nbnext;
+ stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[
+ q_offset], ldq, &z__[z_offset], ldz, &i__1, &nbnext, &
+ c__1, &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ if (nbnext == 1) {
+
+/* Swap two 1-by-1 blocks. */
+
+ stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb,
+ &q[q_offset], ldq, &z__[z_offset], ldz, &here, &
+ nbnext, &c__1, &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ --here;
+ } else {
+
+/* Recompute NBNEXT in case of 2-by-2 split. */
+
+ if (a[here + (here - 1) * a_dim1] == 0.f) {
+ nbnext = 1;
+ }
+ if (nbnext == 2) {
+
+/* 2-by-2 block did not split. */
+
+ i__1 = here - 1;
+ stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
+ ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &
+ i__1, &c__2, &c__1, &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ here += -2;
+ } else {
+
+/* 2-by-2 block did split. */
+
+ stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
+ ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &
+ here, &c__1, &c__1, &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ --here;
+ stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
+ ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &
+ here, &c__1, &c__1, &work[1], lwork, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ --here;
+ }
+ }
+ }
+ if (here > *ilst) {
+ goto L20;
+ }
+ }
+ *ilst = here;
+ work[1] = (real) lwmin;
+ return 0;
+
+/* End of STGEXC */
+
+} /* stgexc_ */
diff --git a/SRC/stgsen.c b/SRC/stgsen.c
new file mode 100644
index 0000000..93d55c1
--- /dev/null
+++ b/SRC/stgsen.c
@@ -0,0 +1,832 @@
+/* stgsen.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static real c_b28 = 1.f;
+
+/* Subroutine */ int stgsen_(integer *ijob, logical *wantq, logical *wantz,
+ logical *select, integer *n, real *a, integer *lda, real *b, integer *
+ ldb, real *alphar, real *alphai, real *beta, real *q, integer *ldq,
+ real *z__, integer *ldz, integer *m, real *pl, real *pr, real *dif,
+ real *work, integer *lwork, integer *iwork, integer *liwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
+ z_offset, i__1, i__2;
+ real r__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_sign(real *, real *);
+
+ /* Local variables */
+ integer i__, k, n1, n2, kk, ks, mn2, ijb;
+ real eps;
+ integer kase;
+ logical pair;
+ integer ierr;
+ real dsum;
+ logical swap;
+ extern /* Subroutine */ int slag2_(real *, integer *, real *, integer *,
+ real *, real *, real *, real *, real *, real *);
+ integer isave[3];
+ logical wantd;
+ integer lwmin;
+ logical wantp;
+ extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *,
+ real *, integer *, integer *);
+ logical wantd1, wantd2;
+ real dscale, rdscal;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), slacpy_(
+ char *, integer *, integer *, real *, integer *, real *, integer *
+), stgexc_(logical *, logical *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, integer *, integer *, real *, integer *, integer *);
+ integer liwmin;
+ extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *,
+ real *);
+ real smlnum;
+ logical lquery;
+ extern /* Subroutine */ int stgsyl_(char *, integer *, integer *, integer
+ *, real *, integer *, real *, integer *, real *, integer *, real *
+, integer *, real *, integer *, real *, integer *, real *, real *,
+ real *, integer *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/* January 2007 */
+
+/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STGSEN reorders the generalized real Schur decomposition of a real */
+/* matrix pair (A, B) (in terms of an orthonormal equivalence trans- */
+/* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues */
+/* appears in the leading diagonal blocks of the upper quasi-triangular */
+/* matrix A and the upper triangular B. The leading columns of Q and */
+/* Z form orthonormal bases of the corresponding left and right eigen- */
+/* spaces (deflating subspaces). (A, B) must be in generalized real */
+/* Schur canonical form (as returned by SGGES), i.e. A is block upper */
+/* triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper */
+/* triangular. */
+
+/* STGSEN also computes the generalized eigenvalues */
+
+/* w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j) */
+
+/* of the reordered matrix pair (A, B). */
+
+/* Optionally, STGSEN computes the estimates of reciprocal condition */
+/* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), */
+/* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) */
+/* between the matrix pairs (A11, B11) and (A22,B22) that correspond to */
+/* the selected cluster and the eigenvalues outside the cluster, resp., */
+/* and norms of "projections" onto left and right eigenspaces w.r.t. */
+/* the selected cluster in the (1,1)-block. */
+
+/* Arguments */
+/* ========= */
+
+/* IJOB (input) INTEGER */
+/* Specifies whether condition numbers are required for the */
+/* cluster of eigenvalues (PL and PR) or the deflating subspaces */
+/* (Difu and Difl): */
+/* =0: Only reorder w.r.t. SELECT. No extras. */
+/* =1: Reciprocal of norms of "projections" onto left and right */
+/* eigenspaces w.r.t. the selected cluster (PL and PR). */
+/* =2: Upper bounds on Difu and Difl. F-norm-based estimate */
+/* (DIF(1:2)). */
+/* =3: Estimate of Difu and Difl. 1-norm-based estimate */
+/* (DIF(1:2)). */
+/* About 5 times as expensive as IJOB = 2. */
+/* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic */
+/* version to get it all. */
+/* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) */
+
+/* WANTQ (input) LOGICAL */
+/* .TRUE. : update the left transformation matrix Q; */
+/* .FALSE.: do not update Q. */
+
+/* WANTZ (input) LOGICAL */
+/* .TRUE. : update the right transformation matrix Z; */
+/* .FALSE.: do not update Z. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* SELECT specifies the eigenvalues in the selected cluster. */
+/* To select a real eigenvalue w(j), SELECT(j) must be set to */
+/* .TRUE.. To select a complex conjugate pair of eigenvalues */
+/* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, */
+/* either SELECT(j) or SELECT(j+1) or both must be set to */
+/* .TRUE.; a complex conjugate pair of eigenvalues must be */
+/* either both included in the cluster or both excluded. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) REAL array, dimension(LDA,N) */
+/* On entry, the upper quasi-triangular matrix A, with (A, B) in */
+/* generalized real Schur canonical form. */
+/* On exit, A is overwritten by the reordered matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) REAL array, dimension(LDB,N) */
+/* On entry, the upper triangular matrix B, with (A, B) in */
+/* generalized real Schur canonical form. */
+/* On exit, B is overwritten by the reordered matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* ALPHAR (output) REAL array, dimension (N) */
+/* ALPHAI (output) REAL array, dimension (N) */
+/* BETA (output) REAL array, dimension (N) */
+/* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */
+/* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i */
+/* and BETA(j),j=1,...,N are the diagonals of the complex Schur */
+/* form (S,T) that would result if the 2-by-2 diagonal blocks of */
+/* the real generalized Schur form of (A,B) were further reduced */
+/* to triangular form using complex unitary transformations. */
+/* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */
+/* positive, then the j-th and (j+1)-st eigenvalues are a */
+/* complex conjugate pair, with ALPHAI(j+1) negative. */
+
+/* Q (input/output) REAL array, dimension (LDQ,N) */
+/* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. */
+/* On exit, Q has been postmultiplied by the left orthogonal */
+/* transformation matrix which reorder (A, B); The leading M */
+/* columns of Q form orthonormal bases for the specified pair of */
+/* left eigenspaces (deflating subspaces). */
+/* If WANTQ = .FALSE., Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= 1; */
+/* and if WANTQ = .TRUE., LDQ >= N. */
+
+/* Z (input/output) REAL array, dimension (LDZ,N) */
+/* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. */
+/* On exit, Z has been postmultiplied by the left orthogonal */
+/* transformation matrix which reorder (A, B); The leading M */
+/* columns of Z form orthonormal bases for the specified pair of */
+/* left eigenspaces (deflating subspaces). */
+/* If WANTZ = .FALSE., Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1; */
+/* If WANTZ = .TRUE., LDZ >= N. */
+
+/* M (output) INTEGER */
+/* The dimension of the specified pair of left and right eigen- */
+/* spaces (deflating subspaces). 0 <= M <= N. */
+
+/* PL (output) REAL */
+/* PR (output) REAL */
+/* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the */
+/* reciprocal of the norm of "projections" onto left and right */
+/* eigenspaces with respect to the selected cluster. */
+/* 0 < PL, PR <= 1. */
+/* If M = 0 or M = N, PL = PR = 1. */
+/* If IJOB = 0, 2 or 3, PL and PR are not referenced. */
+
+/* DIF (output) REAL array, dimension (2). */
+/* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. */
+/* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on */
+/* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based */
+/* estimates of Difu and Difl. */
+/* If M = 0 or N, DIF(1:2) = F-norm([A, B]). */
+/* If IJOB = 0 or 1, DIF is not referenced. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= 4*N+16. */
+/* If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)). */
+/* If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)). */
+
+/* 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. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* IF IJOB = 0, IWORK is not referenced. Otherwise, */
+/* on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. LIWORK >= 1. */
+/* If IJOB = 1, 2 or 4, LIWORK >= N+6. */
+/* If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6). */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal size of the IWORK array, */
+/* returns this value as the first entry of the IWORK array, and */
+/* no error message related to LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* =0: Successful exit. */
+/* <0: If INFO = -i, the i-th argument had an illegal value. */
+/* =1: Reordering of (A, B) failed because the transformed */
+/* matrix pair (A, B) would be too far from generalized */
+/* Schur form; the problem is very ill-conditioned. */
+/* (A, B) may have been partially reordered. */
+/* If requested, 0 is returned in DIF(*), PL and PR. */
+
+/* Further Details */
+/* =============== */
+
+/* STGSEN first collects the selected eigenvalues by computing */
+/* orthogonal U and W that move them to the top left corner of (A, B). */
+/* In other words, the selected eigenvalues are the eigenvalues of */
+/* (A11, B11) in: */
+
+/* U'*(A, B)*W = (A11 A12) (B11 B12) n1 */
+/* ( 0 A22),( 0 B22) n2 */
+/* n1 n2 n1 n2 */
+
+/* where N = n1+n2 and U' means the transpose of U. The first n1 columns */
+/* of U and W span the specified pair of left and right eigenspaces */
+/* (deflating subspaces) of (A, B). */
+
+/* If (A, B) has been obtained from the generalized real Schur */
+/* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the */
+/* reordered generalized real Schur form of (C, D) is given by */
+
+/* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)', */
+
+/* and the first n1 columns of Q*U and Z*W span the corresponding */
+/* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). */
+
+/* Note that if the selected eigenvalue is sufficiently ill-conditioned, */
+/* then its value may differ significantly from its value before */
+/* reordering. */
+
+/* The reciprocal condition numbers of the left and right eigenspaces */
+/* spanned by the first n1 columns of U and W (or Q*U and Z*W) may */
+/* be returned in DIF(1:2), corresponding to Difu and Difl, resp. */
+
+/* The Difu and Difl are defined as: */
+
+/* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu ) */
+/* and */
+/* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], */
+
+/* where sigma-min(Zu) is the smallest singular value of the */
+/* (2*n1*n2)-by-(2*n1*n2) matrix */
+
+/* Zu = [ kron(In2, A11) -kron(A22', In1) ] */
+/* [ kron(In2, B11) -kron(B22', In1) ]. */
+
+/* Here, Inx is the identity matrix of size nx and A22' is the */
+/* transpose of A22. kron(X, Y) is the Kronecker product between */
+/* the matrices X and Y. */
+
+/* When DIF(2) is small, small changes in (A, B) can cause large changes */
+/* in the deflating subspace. An approximate (asymptotic) bound on the */
+/* maximum angular error in the computed deflating subspaces is */
+
+/* EPS * norm((A, B)) / DIF(2), */
+
+/* where EPS is the machine precision. */
+
+/* The reciprocal norm of the projectors on the left and right */
+/* eigenspaces associated with (A11, B11) may be returned in PL and PR. */
+/* They are computed as follows. First we compute L and R so that */
+/* P*(A, B)*Q is block diagonal, where */
+
+/* P = ( I -L ) n1 Q = ( I R ) n1 */
+/* ( 0 I ) n2 and ( 0 I ) n2 */
+/* n1 n2 n1 n2 */
+
+/* and (L, R) is the solution to the generalized Sylvester equation */
+
+/* A11*R - L*A22 = -A12 */
+/* B11*R - L*B22 = -B12 */
+
+/* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). */
+/* An approximate (asymptotic) bound on the average absolute error of */
+/* the selected eigenvalues is */
+
+/* EPS * norm((A, B)) / PL. */
+
+/* There are also global error bounds which valid for perturbations up */
+/* to a certain restriction: A lower bound (x) on the smallest */
+/* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and */
+/* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), */
+/* (i.e. (A + E, B + F), is */
+
+/* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)). */
+
+/* An approximate bound on x can be computed from DIF(1:2), PL and PR. */
+
+/* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed */
+/* (L', R') and unperturbed (L, R) left and right deflating subspaces */
+/* associated with the selected cluster in the (1,1)-blocks can be */
+/* bounded as */
+
+/* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) */
+/* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) */
+
+/* See LAPACK User's Guide section 4.11 or the following references */
+/* for more information. */
+
+/* Note that if the default method for computing the Frobenius-norm- */
+/* based estimate DIF is not wanted (see SLATDF), then the parameter */
+/* IDIFJB (see below) should be changed from 3 to 4 (routine SLATDF */
+/* (IJOB = 2 will be used)). See STGSYL for more details. */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* References */
+/* ========== */
+
+/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
+/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
+/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
+/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
+
+/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
+/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
+/* Estimation: Theory, Algorithms and Software, */
+/* Report UMINF - 94.04, Department of Computing Science, Umea */
+/* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */
+/* Note 87. To appear in Numerical Algorithms, 1996. */
+
+/* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
+/* for Solving the Generalized Sylvester Equation and Estimating the */
+/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
+/* Department of Computing Science, Umea University, S-901 87 Umea, */
+/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */
+/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, */
+/* 1996. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ --select;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --dif;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1 || *liwork == -1;
+
+ if (*ijob < 0 || *ijob > 5) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldq < 1 || *wantq && *ldq < *n) {
+ *info = -14;
+ } else if (*ldz < 1 || *wantz && *ldz < *n) {
+ *info = -16;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STGSEN", &i__1);
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S") / eps;
+ ierr = 0;
+
+ wantp = *ijob == 1 || *ijob >= 4;
+ wantd1 = *ijob == 2 || *ijob == 4;
+ wantd2 = *ijob == 3 || *ijob == 5;
+ wantd = wantd1 || wantd2;
+
+/* Set M to the dimension of the specified pair of deflating */
+/* subspaces. */
+
+ *m = 0;
+ pair = FALSE_;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (pair) {
+ pair = FALSE_;
+ } else {
+ if (k < *n) {
+ if (a[k + 1 + k * a_dim1] == 0.f) {
+ if (select[k]) {
+ ++(*m);
+ }
+ } else {
+ pair = TRUE_;
+ if (select[k] || select[k + 1]) {
+ *m += 2;
+ }
+ }
+ } else {
+ if (select[*n]) {
+ ++(*m);
+ }
+ }
+ }
+/* L10: */
+ }
+
+ if (*ijob == 1 || *ijob == 2 || *ijob == 4) {
+/* Computing MAX */
+ i__1 = 1, i__2 = (*n << 2) + 16, i__1 = max(i__1,i__2), i__2 = (*m <<
+ 1) * (*n - *m);
+ lwmin = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = *n + 6;
+ liwmin = max(i__1,i__2);
+ } else if (*ijob == 3 || *ijob == 5) {
+/* Computing MAX */
+ i__1 = 1, i__2 = (*n << 2) + 16, i__1 = max(i__1,i__2), i__2 = (*m <<
+ 2) * (*n - *m);
+ lwmin = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = (*m << 1) * (*n - *m), i__1 = max(i__1,i__2), i__2 =
+ *n + 6;
+ liwmin = max(i__1,i__2);
+ } else {
+/* Computing MAX */
+ i__1 = 1, i__2 = (*n << 2) + 16;
+ lwmin = max(i__1,i__2);
+ liwmin = 1;
+ }
+
+ work[1] = (real) lwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -22;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -24;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STGSEN", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == *n || *m == 0) {
+ if (wantp) {
+ *pl = 1.f;
+ *pr = 1.f;
+ }
+ if (wantd) {
+ dscale = 0.f;
+ dsum = 1.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ slassq_(n, &a[i__ * a_dim1 + 1], &c__1, &dscale, &dsum);
+ slassq_(n, &b[i__ * b_dim1 + 1], &c__1, &dscale, &dsum);
+/* L20: */
+ }
+ dif[1] = dscale * sqrt(dsum);
+ dif[2] = dif[1];
+ }
+ goto L60;
+ }
+
+/* Collect the selected blocks at the top-left corner of (A, B). */
+
+ ks = 0;
+ pair = FALSE_;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (pair) {
+ pair = FALSE_;
+ } else {
+
+ swap = select[k];
+ if (k < *n) {
+ if (a[k + 1 + k * a_dim1] != 0.f) {
+ pair = TRUE_;
+ swap = swap || select[k + 1];
+ }
+ }
+
+ if (swap) {
+ ++ks;
+
+/* Swap the K-th block to position KS. */
+/* Perform the reordering of diagonal blocks in (A, B) */
+/* by orthogonal transformation matrices and update */
+/* Q and Z accordingly (if requested): */
+
+ kk = k;
+ if (k != ks) {
+ stgexc_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset],
+ ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &kk,
+ &ks, &work[1], lwork, &ierr);
+ }
+
+ if (ierr > 0) {
+
+/* Swap is rejected: exit. */
+
+ *info = 1;
+ if (wantp) {
+ *pl = 0.f;
+ *pr = 0.f;
+ }
+ if (wantd) {
+ dif[1] = 0.f;
+ dif[2] = 0.f;
+ }
+ goto L60;
+ }
+
+ if (pair) {
+ ++ks;
+ }
+ }
+ }
+/* L30: */
+ }
+ if (wantp) {
+
+/* Solve generalized Sylvester equation for R and L */
+/* and compute PL and PR. */
+
+ n1 = *m;
+ n2 = *n - *m;
+ i__ = n1 + 1;
+ ijb = 0;
+ slacpy_("Full", &n1, &n2, &a[i__ * a_dim1 + 1], lda, &work[1], &n1);
+ slacpy_("Full", &n1, &n2, &b[i__ * b_dim1 + 1], ldb, &work[n1 * n2 +
+ 1], &n1);
+ i__1 = *lwork - (n1 << 1) * n2;
+ stgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ * a_dim1]
+, lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ + i__ *
+ b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &dif[1], &
+ work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &ierr);
+
+/* Estimate the reciprocal of norms of "projections" onto left */
+/* and right eigenspaces. */
+
+ rdscal = 0.f;
+ dsum = 1.f;
+ i__1 = n1 * n2;
+ slassq_(&i__1, &work[1], &c__1, &rdscal, &dsum);
+ *pl = rdscal * sqrt(dsum);
+ if (*pl == 0.f) {
+ *pl = 1.f;
+ } else {
+ *pl = dscale / (sqrt(dscale * dscale / *pl + *pl) * sqrt(*pl));
+ }
+ rdscal = 0.f;
+ dsum = 1.f;
+ i__1 = n1 * n2;
+ slassq_(&i__1, &work[n1 * n2 + 1], &c__1, &rdscal, &dsum);
+ *pr = rdscal * sqrt(dsum);
+ if (*pr == 0.f) {
+ *pr = 1.f;
+ } else {
+ *pr = dscale / (sqrt(dscale * dscale / *pr + *pr) * sqrt(*pr));
+ }
+ }
+
+ if (wantd) {
+
+/* Compute estimates of Difu and Difl. */
+
+ if (wantd1) {
+ n1 = *m;
+ n2 = *n - *m;
+ i__ = n1 + 1;
+ ijb = 3;
+
+/* Frobenius norm-based Difu-estimate. */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ stgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ *
+ a_dim1], lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ +
+ i__ * b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &
+ dif[1], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], &
+ ierr);
+
+/* Frobenius norm-based Difl-estimate. */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ stgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, &a[
+ a_offset], lda, &work[1], &n2, &b[i__ + i__ * b_dim1],
+ ldb, &b[b_offset], ldb, &work[n1 * n2 + 1], &n2, &dscale,
+ &dif[2], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], &
+ ierr);
+ } else {
+
+
+/* Compute 1-norm-based estimates of Difu and Difl using */
+/* reversed communication with SLACN2. In each step a */
+/* generalized Sylvester equation or a transposed variant */
+/* is solved. */
+
+ kase = 0;
+ n1 = *m;
+ n2 = *n - *m;
+ i__ = n1 + 1;
+ ijb = 0;
+ mn2 = (n1 << 1) * n2;
+
+/* 1-norm-based estimate of Difu. */
+
+L40:
+ slacn2_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[1], &kase,
+ isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Solve generalized Sylvester equation. */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ stgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ +
+ i__ * a_dim1], lda, &work[1], &n1, &b[b_offset],
+ ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
+ 1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 +
+ 1], &i__1, &iwork[1], &ierr);
+ } else {
+
+/* Solve the transposed variant. */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ stgsyl_("T", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ +
+ i__ * a_dim1], lda, &work[1], &n1, &b[b_offset],
+ ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
+ 1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 +
+ 1], &i__1, &iwork[1], &ierr);
+ }
+ goto L40;
+ }
+ dif[1] = dscale / dif[1];
+
+/* 1-norm-based estimate of Difl. */
+
+L50:
+ slacn2_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[2], &kase,
+ isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Solve generalized Sylvester equation. */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ stgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda,
+ &a[a_offset], lda, &work[1], &n2, &b[i__ + i__ *
+ b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 +
+ 1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 +
+ 1], &i__1, &iwork[1], &ierr);
+ } else {
+
+/* Solve the transposed variant. */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ stgsyl_("T", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda,
+ &a[a_offset], lda, &work[1], &n2, &b[i__ + i__ *
+ b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 +
+ 1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 +
+ 1], &i__1, &iwork[1], &ierr);
+ }
+ goto L50;
+ }
+ dif[2] = dscale / dif[2];
+
+ }
+ }
+
+L60:
+
+/* Compute generalized eigenvalues of reordered pair (A, B) and */
+/* normalize the generalized Schur form. */
+
+ pair = FALSE_;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (pair) {
+ pair = FALSE_;
+ } else {
+
+ if (k < *n) {
+ if (a[k + 1 + k * a_dim1] != 0.f) {
+ pair = TRUE_;
+ }
+ }
+
+ if (pair) {
+
+/* Compute the eigenvalue(s) at position K. */
+
+ work[1] = a[k + k * a_dim1];
+ work[2] = a[k + 1 + k * a_dim1];
+ work[3] = a[k + (k + 1) * a_dim1];
+ work[4] = a[k + 1 + (k + 1) * a_dim1];
+ work[5] = b[k + k * b_dim1];
+ work[6] = b[k + 1 + k * b_dim1];
+ work[7] = b[k + (k + 1) * b_dim1];
+ work[8] = b[k + 1 + (k + 1) * b_dim1];
+ r__1 = smlnum * eps;
+ slag2_(&work[1], &c__2, &work[5], &c__2, &r__1, &beta[k], &
+ beta[k + 1], &alphar[k], &alphar[k + 1], &alphai[k]);
+ alphai[k + 1] = -alphai[k];
+
+ } else {
+
+ if (r_sign(&c_b28, &b[k + k * b_dim1]) < 0.f) {
+
+/* If B(K,K) is negative, make it positive */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[k + i__ * a_dim1] = -a[k + i__ * a_dim1];
+ b[k + i__ * b_dim1] = -b[k + i__ * b_dim1];
+ if (*wantq) {
+ q[i__ + k * q_dim1] = -q[i__ + k * q_dim1];
+ }
+/* L80: */
+ }
+ }
+
+ alphar[k] = a[k + k * a_dim1];
+ alphai[k] = 0.f;
+ beta[k] = b[k + k * b_dim1];
+
+ }
+ }
+/* L70: */
+ }
+
+ work[1] = (real) lwmin;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of STGSEN */
+
+} /* stgsen_ */
diff --git a/SRC/stgsja.c b/SRC/stgsja.c
new file mode 100644
index 0000000..677fbe3
--- /dev/null
+++ b/SRC/stgsja.c
@@ -0,0 +1,619 @@
+/* stgsja.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b13 = 0.f;
+static real c_b14 = 1.f;
+static integer c__1 = 1;
+static real c_b43 = -1.f;
+
+/* Subroutine */ int stgsja_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *p, integer *n, integer *k, integer *l, real *a, integer *lda,
+ real *b, integer *ldb, real *tola, real *tolb, real *alpha, real *
+ beta, real *u, integer *ldu, real *v, integer *ldv, real *q, integer *
+ ldq, real *work, integer *ncycle, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1,
+ u_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j;
+ real a1, a2, a3, b1, b2, b3, csq, csu, csv, snq, rwk, snu, snv;
+ extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
+ integer *, real *, real *);
+ real gamma;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ logical initq, initu, initv, wantq, upper;
+ real error, ssmin;
+ logical wantu, wantv;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), slags2_(logical *, real *, real *, real *, real *,
+ real *, real *, real *, real *, real *, real *, real *, real *);
+ integer kcycle;
+ extern /* Subroutine */ int xerbla_(char *, integer *), slapll_(
+ integer *, real *, integer *, real *, integer *, real *), slartg_(
+ real *, real *, real *, real *, real *), slaset_(char *, integer *
+, integer *, real *, real *, real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STGSJA computes the generalized singular value decomposition (GSVD) */
+/* of two real upper triangular (or trapezoidal) matrices A and B. */
+
+/* On entry, it is assumed that matrices A and B have the following */
+/* forms, which may be obtained by the preprocessing subroutine SGGSVP */
+/* from a general M-by-N matrix A and P-by-N matrix B: */
+
+/* N-K-L K L */
+/* A = K ( 0 A12 A13 ) if M-K-L >= 0; */
+/* L ( 0 0 A23 ) */
+/* M-K-L ( 0 0 0 ) */
+
+/* N-K-L K L */
+/* A = K ( 0 A12 A13 ) if M-K-L < 0; */
+/* M-K ( 0 0 A23 ) */
+
+/* N-K-L K L */
+/* B = L ( 0 0 B13 ) */
+/* P-L ( 0 0 0 ) */
+
+/* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */
+/* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */
+/* otherwise A23 is (M-K)-by-L upper trapezoidal. */
+
+/* On exit, */
+
+/* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ), */
+
+/* where U, V and Q are orthogonal matrices, Z' denotes the transpose */
+/* of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are */
+/* ``diagonal'' matrices, which are of the following structures: */
+
+/* If M-K-L >= 0, */
+
+/* K L */
+/* D1 = K ( I 0 ) */
+/* L ( 0 C ) */
+/* M-K-L ( 0 0 ) */
+
+/* K L */
+/* D2 = L ( 0 S ) */
+/* P-L ( 0 0 ) */
+
+/* N-K-L K L */
+/* ( 0 R ) = K ( 0 R11 R12 ) K */
+/* L ( 0 0 R22 ) L */
+
+/* where */
+
+/* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */
+/* S = diag( BETA(K+1), ... , BETA(K+L) ), */
+/* C**2 + S**2 = I. */
+
+/* R is stored in A(1:K+L,N-K-L+1:N) on exit. */
+
+/* If M-K-L < 0, */
+
+/* K M-K K+L-M */
+/* D1 = K ( I 0 0 ) */
+/* M-K ( 0 C 0 ) */
+
+/* K M-K K+L-M */
+/* D2 = M-K ( 0 S 0 ) */
+/* K+L-M ( 0 0 I ) */
+/* P-L ( 0 0 0 ) */
+
+/* N-K-L K M-K K+L-M */
+/* ( 0 R ) = K ( 0 R11 R12 R13 ) */
+/* M-K ( 0 0 R22 R23 ) */
+/* K+L-M ( 0 0 0 R33 ) */
+
+/* where */
+/* C = diag( ALPHA(K+1), ... , ALPHA(M) ), */
+/* S = diag( BETA(K+1), ... , BETA(M) ), */
+/* C**2 + S**2 = I. */
+
+/* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored */
+/* ( 0 R22 R23 ) */
+/* in B(M-K+1:L,N+M-K-L+1:N) on exit. */
+
+/* The computation of the orthogonal transformation matrices U, V or Q */
+/* is optional. These matrices may either be formed explicitly, or they */
+/* may be postmultiplied into input matrices U1, V1, or Q1. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBU (input) CHARACTER*1 */
+/* = 'U': U must contain an orthogonal matrix U1 on entry, and */
+/* the product U1*U is returned; */
+/* = 'I': U is initialized to the unit matrix, and the */
+/* orthogonal matrix U is returned; */
+/* = 'N': U is not computed. */
+
+/* JOBV (input) CHARACTER*1 */
+/* = 'V': V must contain an orthogonal matrix V1 on entry, and */
+/* the product V1*V is returned; */
+/* = 'I': V is initialized to the unit matrix, and the */
+/* orthogonal matrix V is returned; */
+/* = 'N': V is not computed. */
+
+/* JOBQ (input) CHARACTER*1 */
+/* = 'Q': Q must contain an orthogonal matrix Q1 on entry, and */
+/* the product Q1*Q is returned; */
+/* = 'I': Q is initialized to the unit matrix, and the */
+/* orthogonal matrix Q is returned; */
+/* = 'N': Q is not computed. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* K (input) INTEGER */
+/* L (input) INTEGER */
+/* K and L specify the subblocks in the input matrices A and B: */
+/* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N) */
+/* of A and B, whose GSVD is going to be computed by STGSJA. */
+/* See Further details. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular */
+/* matrix R or part of R. See Purpose for details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) REAL array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix B. */
+/* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains */
+/* a part of R. See Purpose for details. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,P). */
+
+/* TOLA (input) REAL */
+/* TOLB (input) REAL */
+/* TOLA and TOLB are the convergence criteria for the Jacobi- */
+/* Kogbetliantz iteration procedure. Generally, they are the */
+/* same as used in the preprocessing step, say */
+/* TOLA = max(M,N)*norm(A)*MACHEPS, */
+/* TOLB = max(P,N)*norm(B)*MACHEPS. */
+
+/* ALPHA (output) REAL array, dimension (N) */
+/* BETA (output) REAL array, dimension (N) */
+/* On exit, ALPHA and BETA contain the generalized singular */
+/* value pairs of A and B; */
+/* ALPHA(1:K) = 1, */
+/* BETA(1:K) = 0, */
+/* and if M-K-L >= 0, */
+/* ALPHA(K+1:K+L) = diag(C), */
+/* BETA(K+1:K+L) = diag(S), */
+/* or if M-K-L < 0, */
+/* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0 */
+/* BETA(K+1:M) = S, BETA(M+1:K+L) = 1. */
+/* Furthermore, if K+L < N, */
+/* ALPHA(K+L+1:N) = 0 and */
+/* BETA(K+L+1:N) = 0. */
+
+/* U (input/output) REAL array, dimension (LDU,M) */
+/* On entry, if JOBU = 'U', U must contain a matrix U1 (usually */
+/* the orthogonal matrix returned by SGGSVP). */
+/* On exit, */
+/* if JOBU = 'I', U contains the orthogonal matrix U; */
+/* if JOBU = 'U', U contains the product U1*U. */
+/* If JOBU = 'N', U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M) if */
+/* JOBU = 'U'; LDU >= 1 otherwise. */
+
+/* V (input/output) REAL array, dimension (LDV,P) */
+/* On entry, if JOBV = 'V', V must contain a matrix V1 (usually */
+/* the orthogonal matrix returned by SGGSVP). */
+/* On exit, */
+/* if JOBV = 'I', V contains the orthogonal matrix V; */
+/* if JOBV = 'V', V contains the product V1*V. */
+/* If JOBV = 'N', V is not referenced. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. LDV >= max(1,P) if */
+/* JOBV = 'V'; LDV >= 1 otherwise. */
+
+/* Q (input/output) REAL array, dimension (LDQ,N) */
+/* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually */
+/* the orthogonal matrix returned by SGGSVP). */
+/* On exit, */
+/* if JOBQ = 'I', Q contains the orthogonal matrix Q; */
+/* if JOBQ = 'Q', Q contains the product Q1*Q. */
+/* If JOBQ = 'N', Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N) if */
+/* JOBQ = 'Q'; LDQ >= 1 otherwise. */
+
+/* WORK (workspace) REAL array, dimension (2*N) */
+
+/* NCYCLE (output) INTEGER */
+/* The number of cycles required for convergence. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1: the procedure does not converge after MAXIT cycles. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* MAXIT INTEGER */
+/* MAXIT specifies the total loops that the iterative procedure */
+/* may take. If after MAXIT cycles, the routine fails to */
+/* converge, we return INFO = 1. */
+
+/* Further Details */
+/* =============== */
+
+/* STGSJA essentially uses a variant of Kogbetliantz algorithm to reduce */
+/* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L */
+/* matrix B13 to the form: */
+
+/* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1, */
+
+/* where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose */
+/* of Z. C1 and S1 are diagonal matrices satisfying */
+
+/* C1**2 + S1**2 = I, */
+
+/* and R1 is an L-by-L nonsingular upper triangular matrix. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alpha;
+ --beta;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+
+ /* Function Body */
+ initu = lsame_(jobu, "I");
+ wantu = initu || lsame_(jobu, "U");
+
+ initv = lsame_(jobv, "I");
+ wantv = initv || lsame_(jobv, "V");
+
+ initq = lsame_(jobq, "I");
+ wantq = initq || lsame_(jobq, "Q");
+
+ *info = 0;
+ if (! (initu || wantu || lsame_(jobu, "N"))) {
+ *info = -1;
+ } else if (! (initv || wantv || lsame_(jobv, "N")))
+ {
+ *info = -2;
+ } else if (! (initq || wantq || lsame_(jobq, "N")))
+ {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*p < 0) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (*lda < max(1,*m)) {
+ *info = -10;
+ } else if (*ldb < max(1,*p)) {
+ *info = -12;
+ } else if (*ldu < 1 || wantu && *ldu < *m) {
+ *info = -18;
+ } else if (*ldv < 1 || wantv && *ldv < *p) {
+ *info = -20;
+ } else if (*ldq < 1 || wantq && *ldq < *n) {
+ *info = -22;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STGSJA", &i__1);
+ return 0;
+ }
+
+/* Initialize U, V and Q, if necessary */
+
+ if (initu) {
+ slaset_("Full", m, m, &c_b13, &c_b14, &u[u_offset], ldu);
+ }
+ if (initv) {
+ slaset_("Full", p, p, &c_b13, &c_b14, &v[v_offset], ldv);
+ }
+ if (initq) {
+ slaset_("Full", n, n, &c_b13, &c_b14, &q[q_offset], ldq);
+ }
+
+/* Loop until convergence */
+
+ upper = FALSE_;
+ for (kcycle = 1; kcycle <= 40; ++kcycle) {
+
+ upper = ! upper;
+
+ i__1 = *l - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *l;
+ for (j = i__ + 1; j <= i__2; ++j) {
+
+ a1 = 0.f;
+ a2 = 0.f;
+ a3 = 0.f;
+ if (*k + i__ <= *m) {
+ a1 = a[*k + i__ + (*n - *l + i__) * a_dim1];
+ }
+ if (*k + j <= *m) {
+ a3 = a[*k + j + (*n - *l + j) * a_dim1];
+ }
+
+ b1 = b[i__ + (*n - *l + i__) * b_dim1];
+ b3 = b[j + (*n - *l + j) * b_dim1];
+
+ if (upper) {
+ if (*k + i__ <= *m) {
+ a2 = a[*k + i__ + (*n - *l + j) * a_dim1];
+ }
+ b2 = b[i__ + (*n - *l + j) * b_dim1];
+ } else {
+ if (*k + j <= *m) {
+ a2 = a[*k + j + (*n - *l + i__) * a_dim1];
+ }
+ b2 = b[j + (*n - *l + i__) * b_dim1];
+ }
+
+ slags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &
+ csv, &snv, &csq, &snq);
+
+/* Update (K+I)-th and (K+J)-th rows of matrix A: U'*A */
+
+ if (*k + j <= *m) {
+ srot_(l, &a[*k + j + (*n - *l + 1) * a_dim1], lda, &a[*k
+ + i__ + (*n - *l + 1) * a_dim1], lda, &csu, &snu);
+ }
+
+/* Update I-th and J-th rows of matrix B: V'*B */
+
+ srot_(l, &b[j + (*n - *l + 1) * b_dim1], ldb, &b[i__ + (*n - *
+ l + 1) * b_dim1], ldb, &csv, &snv);
+
+/* Update (N-L+I)-th and (N-L+J)-th columns of matrices */
+/* A and B: A*Q and B*Q */
+
+/* Computing MIN */
+ i__4 = *k + *l;
+ i__3 = min(i__4,*m);
+ srot_(&i__3, &a[(*n - *l + j) * a_dim1 + 1], &c__1, &a[(*n - *
+ l + i__) * a_dim1 + 1], &c__1, &csq, &snq);
+
+ srot_(l, &b[(*n - *l + j) * b_dim1 + 1], &c__1, &b[(*n - *l +
+ i__) * b_dim1 + 1], &c__1, &csq, &snq);
+
+ if (upper) {
+ if (*k + i__ <= *m) {
+ a[*k + i__ + (*n - *l + j) * a_dim1] = 0.f;
+ }
+ b[i__ + (*n - *l + j) * b_dim1] = 0.f;
+ } else {
+ if (*k + j <= *m) {
+ a[*k + j + (*n - *l + i__) * a_dim1] = 0.f;
+ }
+ b[j + (*n - *l + i__) * b_dim1] = 0.f;
+ }
+
+/* Update orthogonal matrices U, V, Q, if desired. */
+
+ if (wantu && *k + j <= *m) {
+ srot_(m, &u[(*k + j) * u_dim1 + 1], &c__1, &u[(*k + i__) *
+ u_dim1 + 1], &c__1, &csu, &snu);
+ }
+
+ if (wantv) {
+ srot_(p, &v[j * v_dim1 + 1], &c__1, &v[i__ * v_dim1 + 1],
+ &c__1, &csv, &snv);
+ }
+
+ if (wantq) {
+ srot_(n, &q[(*n - *l + j) * q_dim1 + 1], &c__1, &q[(*n - *
+ l + i__) * q_dim1 + 1], &c__1, &csq, &snq);
+ }
+
+/* L10: */
+ }
+/* L20: */
+ }
+
+ if (! upper) {
+
+/* The matrices A13 and B13 were lower triangular at the start */
+/* of the cycle, and are now upper triangular. */
+
+/* Convergence test: test the parallelism of the corresponding */
+/* rows of A and B. */
+
+ error = 0.f;
+/* Computing MIN */
+ i__2 = *l, i__3 = *m - *k;
+ i__1 = min(i__2,i__3);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *l - i__ + 1;
+ scopy_(&i__2, &a[*k + i__ + (*n - *l + i__) * a_dim1], lda, &
+ work[1], &c__1);
+ i__2 = *l - i__ + 1;
+ scopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &work[*
+ l + 1], &c__1);
+ i__2 = *l - i__ + 1;
+ slapll_(&i__2, &work[1], &c__1, &work[*l + 1], &c__1, &ssmin);
+ error = dmax(error,ssmin);
+/* L30: */
+ }
+
+ if (dabs(error) <= dmin(*tola,*tolb)) {
+ goto L50;
+ }
+ }
+
+/* End of cycle loop */
+
+/* L40: */
+ }
+
+/* The algorithm has not converged after MAXIT cycles. */
+
+ *info = 1;
+ goto L100;
+
+L50:
+
+/* If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged. */
+/* Compute the generalized singular value pairs (ALPHA, BETA), and */
+/* set the triangular matrix R to array A. */
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ alpha[i__] = 1.f;
+ beta[i__] = 0.f;
+/* L60: */
+ }
+
+/* Computing MIN */
+ i__2 = *l, i__3 = *m - *k;
+ i__1 = min(i__2,i__3);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+ a1 = a[*k + i__ + (*n - *l + i__) * a_dim1];
+ b1 = b[i__ + (*n - *l + i__) * b_dim1];
+
+ if (a1 != 0.f) {
+ gamma = b1 / a1;
+
+/* change sign if necessary */
+
+ if (gamma < 0.f) {
+ i__2 = *l - i__ + 1;
+ sscal_(&i__2, &c_b43, &b[i__ + (*n - *l + i__) * b_dim1], ldb)
+ ;
+ if (wantv) {
+ sscal_(p, &c_b43, &v[i__ * v_dim1 + 1], &c__1);
+ }
+ }
+
+ r__1 = dabs(gamma);
+ slartg_(&r__1, &c_b14, &beta[*k + i__], &alpha[*k + i__], &rwk);
+
+ if (alpha[*k + i__] >= beta[*k + i__]) {
+ i__2 = *l - i__ + 1;
+ r__1 = 1.f / alpha[*k + i__];
+ sscal_(&i__2, &r__1, &a[*k + i__ + (*n - *l + i__) * a_dim1],
+ lda);
+ } else {
+ i__2 = *l - i__ + 1;
+ r__1 = 1.f / beta[*k + i__];
+ sscal_(&i__2, &r__1, &b[i__ + (*n - *l + i__) * b_dim1], ldb);
+ i__2 = *l - i__ + 1;
+ scopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k
+ + i__ + (*n - *l + i__) * a_dim1], lda);
+ }
+
+ } else {
+
+ alpha[*k + i__] = 0.f;
+ beta[*k + i__] = 1.f;
+ i__2 = *l - i__ + 1;
+ scopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k +
+ i__ + (*n - *l + i__) * a_dim1], lda);
+
+ }
+
+/* L70: */
+ }
+
+/* Post-assignment */
+
+ i__1 = *k + *l;
+ for (i__ = *m + 1; i__ <= i__1; ++i__) {
+ alpha[i__] = 0.f;
+ beta[i__] = 1.f;
+/* L80: */
+ }
+
+ if (*k + *l < *n) {
+ i__1 = *n;
+ for (i__ = *k + *l + 1; i__ <= i__1; ++i__) {
+ alpha[i__] = 0.f;
+ beta[i__] = 0.f;
+/* L90: */
+ }
+ }
+
+L100:
+ *ncycle = kcycle;
+ return 0;
+
+/* End of STGSJA */
+
+} /* stgsja_ */
diff --git a/SRC/stgsna.c b/SRC/stgsna.c
new file mode 100644
index 0000000..d469299
--- /dev/null
+++ b/SRC/stgsna.c
@@ -0,0 +1,691 @@
+/* stgsna.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b19 = 1.f;
+static real c_b21 = 0.f;
+static integer c__2 = 2;
+static logical c_false = FALSE_;
+static integer c__3 = 3;
+
+/* Subroutine */ int stgsna_(char *job, char *howmny, logical *select,
+ integer *n, real *a, integer *lda, real *b, integer *ldb, real *vl,
+ integer *ldvl, real *vr, integer *ldvr, real *s, real *dif, integer *
+ mm, integer *m, real *work, integer *lwork, integer *iwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
+ vr_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, k;
+ real c1, c2;
+ integer n1, n2, ks, iz;
+ real eps, beta, cond;
+ logical pair;
+ integer ierr;
+ real uhav, uhbv;
+ integer ifst;
+ real lnrm;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ integer ilst;
+ real rnrm;
+ extern /* Subroutine */ int slag2_(real *, integer *, real *, integer *,
+ real *, real *, real *, real *, real *, real *);
+ extern doublereal snrm2_(integer *, real *, integer *);
+ real root1, root2, scale;
+ extern logical lsame_(char *, char *);
+ real uhavi, uhbvi;
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ real tmpii;
+ integer lwmin;
+ logical wants;
+ real tmpir, tmpri, dummy[1], tmprr;
+ extern doublereal slapy2_(real *, real *);
+ real dummy1[1], alphai, alphar;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical wantbh, wantdf;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), stgexc_(logical *, logical
+ *, integer *, real *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, integer *, integer *, real *,
+ integer *, integer *);
+ logical somcon;
+ real alprqt, smlnum;
+ logical lquery;
+ extern /* Subroutine */ int stgsyl_(char *, integer *, integer *, integer
+ *, real *, integer *, real *, integer *, real *, integer *, real *
+, integer *, real *, integer *, real *, integer *, real *, real *,
+ real *, integer *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STGSNA estimates reciprocal condition numbers for specified */
+/* eigenvalues and/or eigenvectors of a matrix pair (A, B) in */
+/* generalized real Schur canonical form (or of any matrix pair */
+/* (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where */
+/* Z' denotes the transpose of Z. */
+
+/* (A, B) must be in generalized real Schur form (as returned by SGGES), */
+/* i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal */
+/* blocks. B is upper triangular. */
+
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies whether condition numbers are required for */
+/* eigenvalues (S) or eigenvectors (DIF): */
+/* = 'E': for eigenvalues only (S); */
+/* = 'V': for eigenvectors only (DIF); */
+/* = 'B': for both eigenvalues and eigenvectors (S and DIF). */
+
+/* HOWMNY (input) CHARACTER*1 */
+/* = 'A': compute condition numbers for all eigenpairs; */
+/* = 'S': compute condition numbers for selected eigenpairs */
+/* specified by the array SELECT. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* If HOWMNY = 'S', SELECT specifies the eigenpairs for which */
+/* condition numbers are required. To select condition numbers */
+/* for the eigenpair corresponding to a real eigenvalue w(j), */
+/* SELECT(j) must be set to .TRUE.. To select condition numbers */
+/* corresponding to a complex conjugate pair of eigenvalues w(j) */
+/* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be */
+/* set to .TRUE.. */
+/* If HOWMNY = 'A', SELECT is not referenced. */
+
+/* N (input) INTEGER */
+/* The order of the square matrix pair (A, B). N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The upper quasi-triangular matrix A in the pair (A,B). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) REAL array, dimension (LDB,N) */
+/* The upper triangular matrix B in the pair (A,B). */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* VL (input) REAL array, dimension (LDVL,M) */
+/* If JOB = 'E' or 'B', VL must contain left eigenvectors of */
+/* (A, B), corresponding to the eigenpairs specified by HOWMNY */
+/* and SELECT. The eigenvectors must be stored in consecutive */
+/* columns of VL, as returned by STGEVC. */
+/* If JOB = 'V', VL is not referenced. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. LDVL >= 1. */
+/* If JOB = 'E' or 'B', LDVL >= N. */
+
+/* VR (input) REAL array, dimension (LDVR,M) */
+/* If JOB = 'E' or 'B', VR must contain right eigenvectors of */
+/* (A, B), corresponding to the eigenpairs specified by HOWMNY */
+/* and SELECT. The eigenvectors must be stored in consecutive */
+/* columns ov VR, as returned by STGEVC. */
+/* If JOB = 'V', VR is not referenced. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. LDVR >= 1. */
+/* If JOB = 'E' or 'B', LDVR >= N. */
+
+/* S (output) REAL array, dimension (MM) */
+/* If JOB = 'E' or 'B', the reciprocal condition numbers of the */
+/* selected eigenvalues, stored in consecutive elements of the */
+/* array. For a complex conjugate pair of eigenvalues two */
+/* consecutive elements of S are set to the same value. Thus */
+/* S(j), DIF(j), and the j-th columns of VL and VR all */
+/* correspond to the same eigenpair (but not in general the */
+/* j-th eigenpair, unless all eigenpairs are selected). */
+/* If JOB = 'V', S is not referenced. */
+
+/* DIF (output) REAL array, dimension (MM) */
+/* If JOB = 'V' or 'B', the estimated reciprocal condition */
+/* numbers of the selected eigenvectors, stored in consecutive */
+/* elements of the array. For a complex eigenvector two */
+/* consecutive elements of DIF are set to the same value. If */
+/* the eigenvalues cannot be reordered to compute DIF(j), DIF(j) */
+/* is set to 0; this can only occur when the true value would be */
+/* very small anyway. */
+/* If JOB = 'E', DIF is not referenced. */
+
+/* MM (input) INTEGER */
+/* The number of elements in the arrays S and DIF. MM >= M. */
+
+/* M (output) INTEGER */
+/* The number of elements of the arrays S and DIF used to store */
+/* the specified condition numbers; for each selected real */
+/* eigenvalue one element is used, and for each selected complex */
+/* conjugate pair of eigenvalues, two elements are used. */
+/* If HOWMNY = 'A', M is set to N. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16. */
+
+/* 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. */
+
+/* IWORK (workspace) INTEGER array, dimension (N + 6) */
+/* If JOB = 'E', IWORK is not referenced. */
+
+/* INFO (output) INTEGER */
+/* =0: Successful exit */
+/* <0: If INFO = -i, the i-th argument had an illegal value */
+
+
+/* Further Details */
+/* =============== */
+
+/* The reciprocal of the condition number of a generalized eigenvalue */
+/* w = (a, b) is defined as */
+
+/* S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v)) */
+
+/* where u and v are the left and right eigenvectors of (A, B) */
+/* corresponding to w; |z| denotes the absolute value of the complex */
+/* number, and norm(u) denotes the 2-norm of the vector u. */
+/* The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv) */
+/* of the matrix pair (A, B). If both a and b equal zero, then (A B) is */
+/* singular and S(I) = -1 is returned. */
+
+/* An approximate error bound on the chordal distance between the i-th */
+/* computed generalized eigenvalue w and the corresponding exact */
+/* eigenvalue lambda is */
+
+/* chord(w, lambda) <= EPS * norm(A, B) / S(I) */
+
+/* where EPS is the machine precision. */
+
+/* The reciprocal of the condition number DIF(i) of right eigenvector u */
+/* and left eigenvector v corresponding to the generalized eigenvalue w */
+/* is defined as follows: */
+
+/* a) If the i-th eigenvalue w = (a,b) is real */
+
+/* Suppose U and V are orthogonal transformations such that */
+
+/* U'*(A, B)*V = (S, T) = ( a * ) ( b * ) 1 */
+/* ( 0 S22 ),( 0 T22 ) n-1 */
+/* 1 n-1 1 n-1 */
+
+/* Then the reciprocal condition number DIF(i) is */
+
+/* Difl((a, b), (S22, T22)) = sigma-min( Zl ), */
+
+/* where sigma-min(Zl) denotes the smallest singular value of the */
+/* 2(n-1)-by-2(n-1) matrix */
+
+/* Zl = [ kron(a, In-1) -kron(1, S22) ] */
+/* [ kron(b, In-1) -kron(1, T22) ] . */
+
+/* Here In-1 is the identity matrix of size n-1. kron(X, Y) is the */
+/* Kronecker product between the matrices X and Y. */
+
+/* Note that if the default method for computing DIF(i) is wanted */
+/* (see SLATDF), then the parameter DIFDRI (see below) should be */
+/* changed from 3 to 4 (routine SLATDF(IJOB = 2 will be used)). */
+/* See STGSYL for more details. */
+
+/* b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair, */
+
+/* Suppose U and V are orthogonal transformations such that */
+
+/* U'*(A, B)*V = (S, T) = ( S11 * ) ( T11 * ) 2 */
+/* ( 0 S22 ),( 0 T22) n-2 */
+/* 2 n-2 2 n-2 */
+
+/* and (S11, T11) corresponds to the complex conjugate eigenvalue */
+/* pair (w, conjg(w)). There exist unitary matrices U1 and V1 such */
+/* that */
+
+/* U1'*S11*V1 = ( s11 s12 ) and U1'*T11*V1 = ( t11 t12 ) */
+/* ( 0 s22 ) ( 0 t22 ) */
+
+/* where the generalized eigenvalues w = s11/t11 and */
+/* conjg(w) = s22/t22. */
+
+/* Then the reciprocal condition number DIF(i) is bounded by */
+
+/* min( d1, max( 1, |real(s11)/real(s22)| )*d2 ) */
+
+/* where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where */
+/* Z1 is the complex 2-by-2 matrix */
+
+/* Z1 = [ s11 -s22 ] */
+/* [ t11 -t22 ], */
+
+/* This is done by computing (using real arithmetic) the */
+/* roots of the characteristical polynomial det(Z1' * Z1 - lambda I), */
+/* where Z1' denotes the conjugate transpose of Z1 and det(X) denotes */
+/* the determinant of X. */
+
+/* and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an */
+/* upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2) */
+
+/* Z2 = [ kron(S11', In-2) -kron(I2, S22) ] */
+/* [ kron(T11', In-2) -kron(I2, T22) ] */
+
+/* Note that if the default method for computing DIF is wanted (see */
+/* SLATDF), then the parameter DIFDRI (see below) should be changed */
+/* from 3 to 4 (routine SLATDF(IJOB = 2 will be used)). See STGSYL */
+/* for more details. */
+
+/* For each eigenvalue/vector specified by SELECT, DIF stores a */
+/* Frobenius norm-based estimate of Difl. */
+
+/* An approximate error bound for the i-th computed eigenvector VL(i) or */
+/* VR(i) is given by */
+
+/* EPS * norm(A, B) / DIF(i). */
+
+/* See ref. [2-3] for more details and further references. */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* References */
+/* ========== */
+
+/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
+/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
+/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
+/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
+
+/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
+/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
+/* Estimation: Theory, Algorithms and Software, */
+/* Report UMINF - 94.04, Department of Computing Science, Umea */
+/* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */
+/* Note 87. To appear in Numerical Algorithms, 1996. */
+
+/* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
+/* for Solving the Generalized Sylvester Equation and Estimating the */
+/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
+/* Department of Computing Science, Umea University, S-901 87 Umea, */
+/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */
+/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, */
+/* No 1, 1996. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ --select;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --s;
+ --dif;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantbh = lsame_(job, "B");
+ wants = lsame_(job, "E") || wantbh;
+ wantdf = lsame_(job, "V") || wantbh;
+
+ somcon = lsame_(howmny, "S");
+
+ *info = 0;
+ lquery = *lwork == -1;
+
+ if (! wants && ! wantdf) {
+ *info = -1;
+ } else if (! lsame_(howmny, "A") && ! somcon) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (wants && *ldvl < *n) {
+ *info = -10;
+ } else if (wants && *ldvr < *n) {
+ *info = -12;
+ } else {
+
+/* Set M to the number of eigenpairs for which condition numbers */
+/* are required, and test MM. */
+
+ if (somcon) {
+ *m = 0;
+ pair = FALSE_;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (pair) {
+ pair = FALSE_;
+ } else {
+ if (k < *n) {
+ if (a[k + 1 + k * a_dim1] == 0.f) {
+ if (select[k]) {
+ ++(*m);
+ }
+ } else {
+ pair = TRUE_;
+ if (select[k] || select[k + 1]) {
+ *m += 2;
+ }
+ }
+ } else {
+ if (select[*n]) {
+ ++(*m);
+ }
+ }
+ }
+/* L10: */
+ }
+ } else {
+ *m = *n;
+ }
+
+ if (*n == 0) {
+ lwmin = 1;
+ } else if (lsame_(job, "V") || lsame_(job,
+ "B")) {
+ lwmin = (*n << 1) * (*n + 2) + 16;
+ } else {
+ lwmin = *n;
+ }
+ work[1] = (real) lwmin;
+
+ if (*mm < *m) {
+ *info = -15;
+ } else if (*lwork < lwmin && ! lquery) {
+ *info = -18;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STGSNA", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S") / eps;
+ ks = 0;
+ pair = FALSE_;
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+/* Determine whether A(k,k) begins a 1-by-1 or 2-by-2 block. */
+
+ if (pair) {
+ pair = FALSE_;
+ goto L20;
+ } else {
+ if (k < *n) {
+ pair = a[k + 1 + k * a_dim1] != 0.f;
+ }
+ }
+
+/* Determine whether condition numbers are required for the k-th */
+/* eigenpair. */
+
+ if (somcon) {
+ if (pair) {
+ if (! select[k] && ! select[k + 1]) {
+ goto L20;
+ }
+ } else {
+ if (! select[k]) {
+ goto L20;
+ }
+ }
+ }
+
+ ++ks;
+
+ if (wants) {
+
+/* Compute the reciprocal condition number of the k-th */
+/* eigenvalue. */
+
+ if (pair) {
+
+/* Complex eigenvalue pair. */
+
+ r__1 = snrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
+ r__2 = snrm2_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1);
+ rnrm = slapy2_(&r__1, &r__2);
+ r__1 = snrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
+ r__2 = snrm2_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1);
+ lnrm = slapy2_(&r__1, &r__2);
+ sgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[ks * vr_dim1
+ + 1], &c__1, &c_b21, &work[1], &c__1);
+ tmprr = sdot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &
+ c__1);
+ tmpri = sdot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1],
+ &c__1);
+ sgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[(ks + 1) *
+ vr_dim1 + 1], &c__1, &c_b21, &work[1], &c__1);
+ tmpii = sdot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1],
+ &c__1);
+ tmpir = sdot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &
+ c__1);
+ uhav = tmprr + tmpii;
+ uhavi = tmpir - tmpri;
+ sgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[ks * vr_dim1
+ + 1], &c__1, &c_b21, &work[1], &c__1);
+ tmprr = sdot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &
+ c__1);
+ tmpri = sdot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1],
+ &c__1);
+ sgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[(ks + 1) *
+ vr_dim1 + 1], &c__1, &c_b21, &work[1], &c__1);
+ tmpii = sdot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1],
+ &c__1);
+ tmpir = sdot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &
+ c__1);
+ uhbv = tmprr + tmpii;
+ uhbvi = tmpir - tmpri;
+ uhav = slapy2_(&uhav, &uhavi);
+ uhbv = slapy2_(&uhbv, &uhbvi);
+ cond = slapy2_(&uhav, &uhbv);
+ s[ks] = cond / (rnrm * lnrm);
+ s[ks + 1] = s[ks];
+
+ } else {
+
+/* Real eigenvalue. */
+
+ rnrm = snrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
+ lnrm = snrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
+ sgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[ks * vr_dim1
+ + 1], &c__1, &c_b21, &work[1], &c__1);
+ uhav = sdot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1)
+ ;
+ sgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[ks * vr_dim1
+ + 1], &c__1, &c_b21, &work[1], &c__1);
+ uhbv = sdot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1)
+ ;
+ cond = slapy2_(&uhav, &uhbv);
+ if (cond == 0.f) {
+ s[ks] = -1.f;
+ } else {
+ s[ks] = cond / (rnrm * lnrm);
+ }
+ }
+ }
+
+ if (wantdf) {
+ if (*n == 1) {
+ dif[ks] = slapy2_(&a[a_dim1 + 1], &b[b_dim1 + 1]);
+ goto L20;
+ }
+
+/* Estimate the reciprocal condition number of the k-th */
+/* eigenvectors. */
+ if (pair) {
+
+/* Copy the 2-by 2 pencil beginning at (A(k,k), B(k, k)). */
+/* Compute the eigenvalue(s) at position K. */
+
+ work[1] = a[k + k * a_dim1];
+ work[2] = a[k + 1 + k * a_dim1];
+ work[3] = a[k + (k + 1) * a_dim1];
+ work[4] = a[k + 1 + (k + 1) * a_dim1];
+ work[5] = b[k + k * b_dim1];
+ work[6] = b[k + 1 + k * b_dim1];
+ work[7] = b[k + (k + 1) * b_dim1];
+ work[8] = b[k + 1 + (k + 1) * b_dim1];
+ r__1 = smlnum * eps;
+ slag2_(&work[1], &c__2, &work[5], &c__2, &r__1, &beta, dummy1,
+ &alphar, dummy, &alphai);
+ alprqt = 1.f;
+ c1 = (alphar * alphar + alphai * alphai + beta * beta) * 2.f;
+ c2 = beta * 4.f * beta * alphai * alphai;
+ root1 = c1 + sqrt(c1 * c1 - c2 * 4.f);
+ root2 = c2 / root1;
+ root1 /= 2.f;
+/* Computing MIN */
+ r__1 = sqrt(root1), r__2 = sqrt(root2);
+ cond = dmin(r__1,r__2);
+ }
+
+/* Copy the matrix (A, B) to the array WORK and swap the */
+/* diagonal block beginning at A(k,k) to the (1,1) position. */
+
+ slacpy_("Full", n, n, &a[a_offset], lda, &work[1], n);
+ slacpy_("Full", n, n, &b[b_offset], ldb, &work[*n * *n + 1], n);
+ ifst = k;
+ ilst = 1;
+
+ i__2 = *lwork - (*n << 1) * *n;
+ stgexc_(&c_false, &c_false, n, &work[1], n, &work[*n * *n + 1], n,
+ dummy, &c__1, dummy1, &c__1, &ifst, &ilst, &work[(*n * *
+ n << 1) + 1], &i__2, &ierr);
+
+ if (ierr > 0) {
+
+/* Ill-conditioned problem - swap rejected. */
+
+ dif[ks] = 0.f;
+ } else {
+
+/* Reordering successful, solve generalized Sylvester */
+/* equation for R and L, */
+/* A22 * R - L * A11 = A12 */
+/* B22 * R - L * B11 = B12, */
+/* and compute estimate of Difl((A11,B11), (A22, B22)). */
+
+ n1 = 1;
+ if (work[2] != 0.f) {
+ n1 = 2;
+ }
+ n2 = *n - n1;
+ if (n2 == 0) {
+ dif[ks] = cond;
+ } else {
+ i__ = *n * *n + 1;
+ iz = (*n << 1) * *n + 1;
+ i__2 = *lwork - (*n << 1) * *n;
+ stgsyl_("N", &c__3, &n2, &n1, &work[*n * n1 + n1 + 1], n,
+ &work[1], n, &work[n1 + 1], n, &work[*n * n1 + n1
+ + i__], n, &work[i__], n, &work[n1 + i__], n, &
+ scale, &dif[ks], &work[iz + 1], &i__2, &iwork[1],
+ &ierr);
+
+ if (pair) {
+/* Computing MIN */
+ r__1 = dmax(1.f,alprqt) * dif[ks];
+ dif[ks] = dmin(r__1,cond);
+ }
+ }
+ }
+ if (pair) {
+ dif[ks + 1] = dif[ks];
+ }
+ }
+ if (pair) {
+ ++ks;
+ }
+
+L20:
+ ;
+ }
+ work[1] = (real) lwmin;
+ return 0;
+
+/* End of STGSNA */
+
+} /* stgsna_ */
diff --git a/SRC/stgsy2.c b/SRC/stgsy2.c
new file mode 100644
index 0000000..4c3cd04
--- /dev/null
+++ b/SRC/stgsy2.c
@@ -0,0 +1,1106 @@
+/* stgsy2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static integer c__1 = 1;
+static real c_b27 = -1.f;
+static real c_b42 = 1.f;
+static real c_b56 = 0.f;
+
+/* Subroutine */ int stgsy2_(char *trans, integer *ijob, integer *m, integer *
+ n, real *a, integer *lda, real *b, integer *ldb, real *c__, integer *
+ ldc, real *d__, integer *ldd, real *e, integer *lde, real *f, integer
+ *ldf, real *scale, real *rdsum, real *rdscal, integer *iwork, integer
+ *pq, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
+ d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, k, p, q;
+ real z__[64] /* was [8][8] */;
+ integer ie, je, mb, nb, ii, jj, is, js;
+ real rhs[8];
+ integer isp1, jsp1;
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ integer ierr, zdim, ipiv[8], jpiv[8];
+ real alpha;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ sgemm_(char *, char *, integer *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *), sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *),
+ saxpy_(integer *, real *, real *, integer *, real *, integer *),
+ sgesc2_(integer *, real *, integer *, real *, integer *, integer *
+, real *), sgetc2_(integer *, real *, integer *, integer *,
+ integer *, integer *);
+ real scaloc;
+ extern /* Subroutine */ int slatdf_(integer *, integer *, real *, integer
+ *, real *, real *, real *, integer *, integer *), xerbla_(char *,
+ integer *), slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *);
+ logical notran;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STGSY2 solves the generalized Sylvester equation: */
+
+/* A * R - L * B = scale * C (1) */
+/* D * R - L * E = scale * F, */
+
+/* using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices, */
+/* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M, */
+/* N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E) */
+/* must be in generalized Schur canonical form, i.e. A, B are upper */
+/* quasi triangular and D, E are upper triangular. The solution (R, L) */
+/* overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor */
+/* chosen to avoid overflow. */
+
+/* In matrix notation solving equation (1) corresponds to solve */
+/* Z*x = scale*b, where Z is defined as */
+
+/* Z = [ kron(In, A) -kron(B', Im) ] (2) */
+/* [ kron(In, D) -kron(E', Im) ], */
+
+/* Ik is the identity matrix of size k and X' is the transpose of X. */
+/* kron(X, Y) is the Kronecker product between the matrices X and Y. */
+/* In the process of solving (1), we solve a number of such systems */
+/* where Dim(In), Dim(In) = 1 or 2. */
+
+/* If TRANS = 'T', solve the transposed system Z'*y = scale*b for y, */
+/* which is equivalent to solve for R and L in */
+
+/* A' * R + D' * L = scale * C (3) */
+/* R * B' + L * E' = scale * -F */
+
+/* This case is used to compute an estimate of Dif[(A, D), (B, E)] = */
+/* sigma_min(Z) using reverse communicaton with SLACON. */
+
+/* STGSY2 also (IJOB >= 1) contributes to the computation in STGSYL */
+/* of an upper bound on the separation between to matrix pairs. Then */
+/* the input (A, D), (B, E) are sub-pencils of the matrix pair in */
+/* STGSYL. See STGSYL for details. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N', solve the generalized Sylvester equation (1). */
+/* = 'T': solve the 'transposed' system (3). */
+
+/* IJOB (input) INTEGER */
+/* Specifies what kind of functionality to be performed. */
+/* = 0: solve (1) only. */
+/* = 1: A contribution from this subsystem to a Frobenius */
+/* norm-based estimate of the separation between two matrix */
+/* pairs is computed. (look ahead strategy is used). */
+/* = 2: A contribution from this subsystem to a Frobenius */
+/* norm-based estimate of the separation between two matrix */
+/* pairs is computed. (SGECON on sub-systems is used.) */
+/* Not referenced if TRANS = 'T'. */
+
+/* M (input) INTEGER */
+/* On entry, M specifies the order of A and D, and the row */
+/* dimension of C, F, R and L. */
+
+/* N (input) INTEGER */
+/* On entry, N specifies the order of B and E, and the column */
+/* dimension of C, F, R and L. */
+
+/* A (input) REAL array, dimension (LDA, M) */
+/* On entry, A contains an upper quasi triangular matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the matrix A. LDA >= max(1, M). */
+
+/* B (input) REAL array, dimension (LDB, N) */
+/* On entry, B contains an upper quasi triangular matrix. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the matrix B. LDB >= max(1, N). */
+
+/* C (input/output) REAL array, dimension (LDC, N) */
+/* On entry, C contains the right-hand-side of the first matrix */
+/* equation in (1). */
+/* On exit, if IJOB = 0, C has been overwritten by the */
+/* solution R. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the matrix C. LDC >= max(1, M). */
+
+/* D (input) REAL array, dimension (LDD, M) */
+/* On entry, D contains an upper triangular matrix. */
+
+/* LDD (input) INTEGER */
+/* The leading dimension of the matrix D. LDD >= max(1, M). */
+
+/* E (input) REAL array, dimension (LDE, N) */
+/* On entry, E contains an upper triangular matrix. */
+
+/* LDE (input) INTEGER */
+/* The leading dimension of the matrix E. LDE >= max(1, N). */
+
+/* F (input/output) REAL array, dimension (LDF, N) */
+/* On entry, F contains the right-hand-side of the second matrix */
+/* equation in (1). */
+/* On exit, if IJOB = 0, F has been overwritten by the */
+/* solution L. */
+
+/* LDF (input) INTEGER */
+/* The leading dimension of the matrix F. LDF >= max(1, M). */
+
+/* SCALE (output) REAL */
+/* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions */
+/* R and L (C and F on entry) will hold the solutions to a */
+/* slightly perturbed system but the input matrices A, B, D and */
+/* E have not been changed. If SCALE = 0, R and L will hold the */
+/* solutions to the homogeneous system with C = F = 0. Normally, */
+/* SCALE = 1. */
+
+/* RDSUM (input/output) REAL */
+/* On entry, the sum of squares of computed contributions to */
+/* the Dif-estimate under computation by STGSYL, where the */
+/* scaling factor RDSCAL (see below) has been factored out. */
+/* On exit, the corresponding sum of squares updated with the */
+/* contributions from the current sub-system. */
+/* If TRANS = 'T' RDSUM is not touched. */
+/* NOTE: RDSUM only makes sense when STGSY2 is called by STGSYL. */
+
+/* RDSCAL (input/output) REAL */
+/* On entry, scaling factor used to prevent overflow in RDSUM. */
+/* On exit, RDSCAL is updated w.r.t. the current contributions */
+/* in RDSUM. */
+/* If TRANS = 'T', RDSCAL is not touched. */
+/* NOTE: RDSCAL only makes sense when STGSY2 is called by */
+/* STGSYL. */
+
+/* IWORK (workspace) INTEGER array, dimension (M+N+2) */
+
+/* PQ (output) INTEGER */
+/* On exit, the number of subsystems (of size 2-by-2, 4-by-4 and */
+/* 8-by-8) solved by this routine. */
+
+/* INFO (output) INTEGER */
+/* On exit, if INFO is set to */
+/* =0: Successful exit */
+/* <0: If INFO = -i, the i-th argument had an illegal value. */
+/* >0: The matrix pairs (A, D) and (B, E) have common or very */
+/* close eigenvalues. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* ===================================================================== */
+/* Replaced various illegal calls to SCOPY by calls to SLASET. */
+/* Sven Hammarling, 27/5/02. */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ d_dim1 = *ldd;
+ d_offset = 1 + d_dim1;
+ d__ -= d_offset;
+ e_dim1 = *lde;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ f_dim1 = *ldf;
+ f_offset = 1 + f_dim1;
+ f -= f_offset;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ ierr = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "T")) {
+ *info = -1;
+ } else if (notran) {
+ if (*ijob < 0 || *ijob > 2) {
+ *info = -2;
+ }
+ }
+ if (*info == 0) {
+ if (*m <= 0) {
+ *info = -3;
+ } else if (*n <= 0) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ } else if (*ldd < max(1,*m)) {
+ *info = -12;
+ } else if (*lde < max(1,*n)) {
+ *info = -14;
+ } else if (*ldf < max(1,*m)) {
+ *info = -16;
+ }
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STGSY2", &i__1);
+ return 0;
+ }
+
+/* Determine block structure of A */
+
+ *pq = 0;
+ p = 0;
+ i__ = 1;
+L10:
+ if (i__ > *m) {
+ goto L20;
+ }
+ ++p;
+ iwork[p] = i__;
+ if (i__ == *m) {
+ goto L20;
+ }
+ if (a[i__ + 1 + i__ * a_dim1] != 0.f) {
+ i__ += 2;
+ } else {
+ ++i__;
+ }
+ goto L10;
+L20:
+ iwork[p + 1] = *m + 1;
+
+/* Determine block structure of B */
+
+ q = p + 1;
+ j = 1;
+L30:
+ if (j > *n) {
+ goto L40;
+ }
+ ++q;
+ iwork[q] = j;
+ if (j == *n) {
+ goto L40;
+ }
+ if (b[j + 1 + j * b_dim1] != 0.f) {
+ j += 2;
+ } else {
+ ++j;
+ }
+ goto L30;
+L40:
+ iwork[q + 1] = *n + 1;
+ *pq = p * (q - p - 1);
+
+ if (notran) {
+
+/* Solve (I, J) - subsystem */
+/* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) */
+/* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) */
+/* for I = P, P - 1, ..., 1; J = 1, 2, ..., Q */
+
+ *scale = 1.f;
+ scaloc = 1.f;
+ i__1 = q;
+ for (j = p + 2; j <= i__1; ++j) {
+ js = iwork[j];
+ jsp1 = js + 1;
+ je = iwork[j + 1] - 1;
+ nb = je - js + 1;
+ for (i__ = p; i__ >= 1; --i__) {
+
+ is = iwork[i__];
+ isp1 = is + 1;
+ ie = iwork[i__ + 1] - 1;
+ mb = ie - is + 1;
+ zdim = mb * nb << 1;
+
+ if (mb == 1 && nb == 1) {
+
+/* Build a 2-by-2 system Z * x = RHS */
+
+ z__[0] = a[is + is * a_dim1];
+ z__[1] = d__[is + is * d_dim1];
+ z__[8] = -b[js + js * b_dim1];
+ z__[9] = -e[js + js * e_dim1];
+
+/* Set up right hand side(s) */
+
+ rhs[0] = c__[is + js * c_dim1];
+ rhs[1] = f[is + js * f_dim1];
+
+/* Solve Z * x = RHS */
+
+ sgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
+ if (ierr > 0) {
+ *info = ierr;
+ }
+
+ if (*ijob == 0) {
+ sgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
+ if (scaloc != 1.f) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &
+ c__1);
+ sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L50: */
+ }
+ *scale *= scaloc;
+ }
+ } else {
+ slatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal,
+ ipiv, jpiv);
+ }
+
+/* Unpack solution vector(s) */
+
+ c__[is + js * c_dim1] = rhs[0];
+ f[is + js * f_dim1] = rhs[1];
+
+/* Substitute R(I, J) and L(I, J) into remaining */
+/* equation. */
+
+ if (i__ > 1) {
+ alpha = -rhs[0];
+ i__2 = is - 1;
+ saxpy_(&i__2, &alpha, &a[is * a_dim1 + 1], &c__1, &
+ c__[js * c_dim1 + 1], &c__1);
+ i__2 = is - 1;
+ saxpy_(&i__2, &alpha, &d__[is * d_dim1 + 1], &c__1, &
+ f[js * f_dim1 + 1], &c__1);
+ }
+ if (j < q) {
+ i__2 = *n - je;
+ saxpy_(&i__2, &rhs[1], &b[js + (je + 1) * b_dim1],
+ ldb, &c__[is + (je + 1) * c_dim1], ldc);
+ i__2 = *n - je;
+ saxpy_(&i__2, &rhs[1], &e[js + (je + 1) * e_dim1],
+ lde, &f[is + (je + 1) * f_dim1], ldf);
+ }
+
+ } else if (mb == 1 && nb == 2) {
+
+/* Build a 4-by-4 system Z * x = RHS */
+
+ z__[0] = a[is + is * a_dim1];
+ z__[1] = 0.f;
+ z__[2] = d__[is + is * d_dim1];
+ z__[3] = 0.f;
+
+ z__[8] = 0.f;
+ z__[9] = a[is + is * a_dim1];
+ z__[10] = 0.f;
+ z__[11] = d__[is + is * d_dim1];
+
+ z__[16] = -b[js + js * b_dim1];
+ z__[17] = -b[js + jsp1 * b_dim1];
+ z__[18] = -e[js + js * e_dim1];
+ z__[19] = -e[js + jsp1 * e_dim1];
+
+ z__[24] = -b[jsp1 + js * b_dim1];
+ z__[25] = -b[jsp1 + jsp1 * b_dim1];
+ z__[26] = 0.f;
+ z__[27] = -e[jsp1 + jsp1 * e_dim1];
+
+/* Set up right hand side(s) */
+
+ rhs[0] = c__[is + js * c_dim1];
+ rhs[1] = c__[is + jsp1 * c_dim1];
+ rhs[2] = f[is + js * f_dim1];
+ rhs[3] = f[is + jsp1 * f_dim1];
+
+/* Solve Z * x = RHS */
+
+ sgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
+ if (ierr > 0) {
+ *info = ierr;
+ }
+
+ if (*ijob == 0) {
+ sgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
+ if (scaloc != 1.f) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &
+ c__1);
+ sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L60: */
+ }
+ *scale *= scaloc;
+ }
+ } else {
+ slatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal,
+ ipiv, jpiv);
+ }
+
+/* Unpack solution vector(s) */
+
+ c__[is + js * c_dim1] = rhs[0];
+ c__[is + jsp1 * c_dim1] = rhs[1];
+ f[is + js * f_dim1] = rhs[2];
+ f[is + jsp1 * f_dim1] = rhs[3];
+
+/* Substitute R(I, J) and L(I, J) into remaining */
+/* equation. */
+
+ if (i__ > 1) {
+ i__2 = is - 1;
+ sger_(&i__2, &nb, &c_b27, &a[is * a_dim1 + 1], &c__1,
+ rhs, &c__1, &c__[js * c_dim1 + 1], ldc);
+ i__2 = is - 1;
+ sger_(&i__2, &nb, &c_b27, &d__[is * d_dim1 + 1], &
+ c__1, rhs, &c__1, &f[js * f_dim1 + 1], ldf);
+ }
+ if (j < q) {
+ i__2 = *n - je;
+ saxpy_(&i__2, &rhs[2], &b[js + (je + 1) * b_dim1],
+ ldb, &c__[is + (je + 1) * c_dim1], ldc);
+ i__2 = *n - je;
+ saxpy_(&i__2, &rhs[2], &e[js + (je + 1) * e_dim1],
+ lde, &f[is + (je + 1) * f_dim1], ldf);
+ i__2 = *n - je;
+ saxpy_(&i__2, &rhs[3], &b[jsp1 + (je + 1) * b_dim1],
+ ldb, &c__[is + (je + 1) * c_dim1], ldc);
+ i__2 = *n - je;
+ saxpy_(&i__2, &rhs[3], &e[jsp1 + (je + 1) * e_dim1],
+ lde, &f[is + (je + 1) * f_dim1], ldf);
+ }
+
+ } else if (mb == 2 && nb == 1) {
+
+/* Build a 4-by-4 system Z * x = RHS */
+
+ z__[0] = a[is + is * a_dim1];
+ z__[1] = a[isp1 + is * a_dim1];
+ z__[2] = d__[is + is * d_dim1];
+ z__[3] = 0.f;
+
+ z__[8] = a[is + isp1 * a_dim1];
+ z__[9] = a[isp1 + isp1 * a_dim1];
+ z__[10] = d__[is + isp1 * d_dim1];
+ z__[11] = d__[isp1 + isp1 * d_dim1];
+
+ z__[16] = -b[js + js * b_dim1];
+ z__[17] = 0.f;
+ z__[18] = -e[js + js * e_dim1];
+ z__[19] = 0.f;
+
+ z__[24] = 0.f;
+ z__[25] = -b[js + js * b_dim1];
+ z__[26] = 0.f;
+ z__[27] = -e[js + js * e_dim1];
+
+/* Set up right hand side(s) */
+
+ rhs[0] = c__[is + js * c_dim1];
+ rhs[1] = c__[isp1 + js * c_dim1];
+ rhs[2] = f[is + js * f_dim1];
+ rhs[3] = f[isp1 + js * f_dim1];
+
+/* Solve Z * x = RHS */
+
+ sgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
+ if (ierr > 0) {
+ *info = ierr;
+ }
+ if (*ijob == 0) {
+ sgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
+ if (scaloc != 1.f) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &
+ c__1);
+ sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L70: */
+ }
+ *scale *= scaloc;
+ }
+ } else {
+ slatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal,
+ ipiv, jpiv);
+ }
+
+/* Unpack solution vector(s) */
+
+ c__[is + js * c_dim1] = rhs[0];
+ c__[isp1 + js * c_dim1] = rhs[1];
+ f[is + js * f_dim1] = rhs[2];
+ f[isp1 + js * f_dim1] = rhs[3];
+
+/* Substitute R(I, J) and L(I, J) into remaining */
+/* equation. */
+
+ if (i__ > 1) {
+ i__2 = is - 1;
+ sgemv_("N", &i__2, &mb, &c_b27, &a[is * a_dim1 + 1],
+ lda, rhs, &c__1, &c_b42, &c__[js * c_dim1 + 1]
+, &c__1);
+ i__2 = is - 1;
+ sgemv_("N", &i__2, &mb, &c_b27, &d__[is * d_dim1 + 1],
+ ldd, rhs, &c__1, &c_b42, &f[js * f_dim1 + 1],
+ &c__1);
+ }
+ if (j < q) {
+ i__2 = *n - je;
+ sger_(&mb, &i__2, &c_b42, &rhs[2], &c__1, &b[js + (je
+ + 1) * b_dim1], ldb, &c__[is + (je + 1) *
+ c_dim1], ldc);
+ i__2 = *n - je;
+ sger_(&mb, &i__2, &c_b42, &rhs[2], &c__1, &e[js + (je
+ + 1) * e_dim1], lde, &f[is + (je + 1) *
+ f_dim1], ldf);
+ }
+
+ } else if (mb == 2 && nb == 2) {
+
+/* Build an 8-by-8 system Z * x = RHS */
+
+ slaset_("F", &c__8, &c__8, &c_b56, &c_b56, z__, &c__8);
+
+ z__[0] = a[is + is * a_dim1];
+ z__[1] = a[isp1 + is * a_dim1];
+ z__[4] = d__[is + is * d_dim1];
+
+ z__[8] = a[is + isp1 * a_dim1];
+ z__[9] = a[isp1 + isp1 * a_dim1];
+ z__[12] = d__[is + isp1 * d_dim1];
+ z__[13] = d__[isp1 + isp1 * d_dim1];
+
+ z__[18] = a[is + is * a_dim1];
+ z__[19] = a[isp1 + is * a_dim1];
+ z__[22] = d__[is + is * d_dim1];
+
+ z__[26] = a[is + isp1 * a_dim1];
+ z__[27] = a[isp1 + isp1 * a_dim1];
+ z__[30] = d__[is + isp1 * d_dim1];
+ z__[31] = d__[isp1 + isp1 * d_dim1];
+
+ z__[32] = -b[js + js * b_dim1];
+ z__[34] = -b[js + jsp1 * b_dim1];
+ z__[36] = -e[js + js * e_dim1];
+ z__[38] = -e[js + jsp1 * e_dim1];
+
+ z__[41] = -b[js + js * b_dim1];
+ z__[43] = -b[js + jsp1 * b_dim1];
+ z__[45] = -e[js + js * e_dim1];
+ z__[47] = -e[js + jsp1 * e_dim1];
+
+ z__[48] = -b[jsp1 + js * b_dim1];
+ z__[50] = -b[jsp1 + jsp1 * b_dim1];
+ z__[54] = -e[jsp1 + jsp1 * e_dim1];
+
+ z__[57] = -b[jsp1 + js * b_dim1];
+ z__[59] = -b[jsp1 + jsp1 * b_dim1];
+ z__[63] = -e[jsp1 + jsp1 * e_dim1];
+
+/* Set up right hand side(s) */
+
+ k = 1;
+ ii = mb * nb + 1;
+ i__2 = nb - 1;
+ for (jj = 0; jj <= i__2; ++jj) {
+ scopy_(&mb, &c__[is + (js + jj) * c_dim1], &c__1, &
+ rhs[k - 1], &c__1);
+ scopy_(&mb, &f[is + (js + jj) * f_dim1], &c__1, &rhs[
+ ii - 1], &c__1);
+ k += mb;
+ ii += mb;
+/* L80: */
+ }
+
+/* Solve Z * x = RHS */
+
+ sgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
+ if (ierr > 0) {
+ *info = ierr;
+ }
+ if (*ijob == 0) {
+ sgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
+ if (scaloc != 1.f) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &
+ c__1);
+ sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L90: */
+ }
+ *scale *= scaloc;
+ }
+ } else {
+ slatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal,
+ ipiv, jpiv);
+ }
+
+/* Unpack solution vector(s) */
+
+ k = 1;
+ ii = mb * nb + 1;
+ i__2 = nb - 1;
+ for (jj = 0; jj <= i__2; ++jj) {
+ scopy_(&mb, &rhs[k - 1], &c__1, &c__[is + (js + jj) *
+ c_dim1], &c__1);
+ scopy_(&mb, &rhs[ii - 1], &c__1, &f[is + (js + jj) *
+ f_dim1], &c__1);
+ k += mb;
+ ii += mb;
+/* L100: */
+ }
+
+/* Substitute R(I, J) and L(I, J) into remaining */
+/* equation. */
+
+ if (i__ > 1) {
+ i__2 = is - 1;
+ sgemm_("N", "N", &i__2, &nb, &mb, &c_b27, &a[is *
+ a_dim1 + 1], lda, rhs, &mb, &c_b42, &c__[js *
+ c_dim1 + 1], ldc);
+ i__2 = is - 1;
+ sgemm_("N", "N", &i__2, &nb, &mb, &c_b27, &d__[is *
+ d_dim1 + 1], ldd, rhs, &mb, &c_b42, &f[js *
+ f_dim1 + 1], ldf);
+ }
+ if (j < q) {
+ k = mb * nb + 1;
+ i__2 = *n - je;
+ sgemm_("N", "N", &mb, &i__2, &nb, &c_b42, &rhs[k - 1],
+ &mb, &b[js + (je + 1) * b_dim1], ldb, &c_b42,
+ &c__[is + (je + 1) * c_dim1], ldc);
+ i__2 = *n - je;
+ sgemm_("N", "N", &mb, &i__2, &nb, &c_b42, &rhs[k - 1],
+ &mb, &e[js + (je + 1) * e_dim1], lde, &c_b42,
+ &f[is + (je + 1) * f_dim1], ldf);
+ }
+
+ }
+
+/* L110: */
+ }
+/* L120: */
+ }
+ } else {
+
+/* Solve (I, J) - subsystem */
+/* A(I, I)' * R(I, J) + D(I, I)' * L(J, J) = C(I, J) */
+/* R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) */
+/* for I = 1, 2, ..., P, J = Q, Q - 1, ..., 1 */
+
+ *scale = 1.f;
+ scaloc = 1.f;
+ i__1 = p;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+ is = iwork[i__];
+ isp1 = is + 1;
+ ie = iwork[i__ + 1] - 1;
+ mb = ie - is + 1;
+ i__2 = p + 2;
+ for (j = q; j >= i__2; --j) {
+
+ js = iwork[j];
+ jsp1 = js + 1;
+ je = iwork[j + 1] - 1;
+ nb = je - js + 1;
+ zdim = mb * nb << 1;
+ if (mb == 1 && nb == 1) {
+
+/* Build a 2-by-2 system Z' * x = RHS */
+
+ z__[0] = a[is + is * a_dim1];
+ z__[1] = -b[js + js * b_dim1];
+ z__[8] = d__[is + is * d_dim1];
+ z__[9] = -e[js + js * e_dim1];
+
+/* Set up right hand side(s) */
+
+ rhs[0] = c__[is + js * c_dim1];
+ rhs[1] = f[is + js * f_dim1];
+
+/* Solve Z' * x = RHS */
+
+ sgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
+ if (ierr > 0) {
+ *info = ierr;
+ }
+
+ sgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
+ if (scaloc != 1.f) {
+ i__3 = *n;
+ for (k = 1; k <= i__3; ++k) {
+ sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
+ sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L130: */
+ }
+ *scale *= scaloc;
+ }
+
+/* Unpack solution vector(s) */
+
+ c__[is + js * c_dim1] = rhs[0];
+ f[is + js * f_dim1] = rhs[1];
+
+/* Substitute R(I, J) and L(I, J) into remaining */
+/* equation. */
+
+ if (j > p + 2) {
+ alpha = rhs[0];
+ i__3 = js - 1;
+ saxpy_(&i__3, &alpha, &b[js * b_dim1 + 1], &c__1, &f[
+ is + f_dim1], ldf);
+ alpha = rhs[1];
+ i__3 = js - 1;
+ saxpy_(&i__3, &alpha, &e[js * e_dim1 + 1], &c__1, &f[
+ is + f_dim1], ldf);
+ }
+ if (i__ < p) {
+ alpha = -rhs[0];
+ i__3 = *m - ie;
+ saxpy_(&i__3, &alpha, &a[is + (ie + 1) * a_dim1], lda,
+ &c__[ie + 1 + js * c_dim1], &c__1);
+ alpha = -rhs[1];
+ i__3 = *m - ie;
+ saxpy_(&i__3, &alpha, &d__[is + (ie + 1) * d_dim1],
+ ldd, &c__[ie + 1 + js * c_dim1], &c__1);
+ }
+
+ } else if (mb == 1 && nb == 2) {
+
+/* Build a 4-by-4 system Z' * x = RHS */
+
+ z__[0] = a[is + is * a_dim1];
+ z__[1] = 0.f;
+ z__[2] = -b[js + js * b_dim1];
+ z__[3] = -b[jsp1 + js * b_dim1];
+
+ z__[8] = 0.f;
+ z__[9] = a[is + is * a_dim1];
+ z__[10] = -b[js + jsp1 * b_dim1];
+ z__[11] = -b[jsp1 + jsp1 * b_dim1];
+
+ z__[16] = d__[is + is * d_dim1];
+ z__[17] = 0.f;
+ z__[18] = -e[js + js * e_dim1];
+ z__[19] = 0.f;
+
+ z__[24] = 0.f;
+ z__[25] = d__[is + is * d_dim1];
+ z__[26] = -e[js + jsp1 * e_dim1];
+ z__[27] = -e[jsp1 + jsp1 * e_dim1];
+
+/* Set up right hand side(s) */
+
+ rhs[0] = c__[is + js * c_dim1];
+ rhs[1] = c__[is + jsp1 * c_dim1];
+ rhs[2] = f[is + js * f_dim1];
+ rhs[3] = f[is + jsp1 * f_dim1];
+
+/* Solve Z' * x = RHS */
+
+ sgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
+ if (ierr > 0) {
+ *info = ierr;
+ }
+ sgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
+ if (scaloc != 1.f) {
+ i__3 = *n;
+ for (k = 1; k <= i__3; ++k) {
+ sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
+ sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L140: */
+ }
+ *scale *= scaloc;
+ }
+
+/* Unpack solution vector(s) */
+
+ c__[is + js * c_dim1] = rhs[0];
+ c__[is + jsp1 * c_dim1] = rhs[1];
+ f[is + js * f_dim1] = rhs[2];
+ f[is + jsp1 * f_dim1] = rhs[3];
+
+/* Substitute R(I, J) and L(I, J) into remaining */
+/* equation. */
+
+ if (j > p + 2) {
+ i__3 = js - 1;
+ saxpy_(&i__3, rhs, &b[js * b_dim1 + 1], &c__1, &f[is
+ + f_dim1], ldf);
+ i__3 = js - 1;
+ saxpy_(&i__3, &rhs[1], &b[jsp1 * b_dim1 + 1], &c__1, &
+ f[is + f_dim1], ldf);
+ i__3 = js - 1;
+ saxpy_(&i__3, &rhs[2], &e[js * e_dim1 + 1], &c__1, &f[
+ is + f_dim1], ldf);
+ i__3 = js - 1;
+ saxpy_(&i__3, &rhs[3], &e[jsp1 * e_dim1 + 1], &c__1, &
+ f[is + f_dim1], ldf);
+ }
+ if (i__ < p) {
+ i__3 = *m - ie;
+ sger_(&i__3, &nb, &c_b27, &a[is + (ie + 1) * a_dim1],
+ lda, rhs, &c__1, &c__[ie + 1 + js * c_dim1],
+ ldc);
+ i__3 = *m - ie;
+ sger_(&i__3, &nb, &c_b27, &d__[is + (ie + 1) * d_dim1]
+, ldd, &rhs[2], &c__1, &c__[ie + 1 + js *
+ c_dim1], ldc);
+ }
+
+ } else if (mb == 2 && nb == 1) {
+
+/* Build a 4-by-4 system Z' * x = RHS */
+
+ z__[0] = a[is + is * a_dim1];
+ z__[1] = a[is + isp1 * a_dim1];
+ z__[2] = -b[js + js * b_dim1];
+ z__[3] = 0.f;
+
+ z__[8] = a[isp1 + is * a_dim1];
+ z__[9] = a[isp1 + isp1 * a_dim1];
+ z__[10] = 0.f;
+ z__[11] = -b[js + js * b_dim1];
+
+ z__[16] = d__[is + is * d_dim1];
+ z__[17] = d__[is + isp1 * d_dim1];
+ z__[18] = -e[js + js * e_dim1];
+ z__[19] = 0.f;
+
+ z__[24] = 0.f;
+ z__[25] = d__[isp1 + isp1 * d_dim1];
+ z__[26] = 0.f;
+ z__[27] = -e[js + js * e_dim1];
+
+/* Set up right hand side(s) */
+
+ rhs[0] = c__[is + js * c_dim1];
+ rhs[1] = c__[isp1 + js * c_dim1];
+ rhs[2] = f[is + js * f_dim1];
+ rhs[3] = f[isp1 + js * f_dim1];
+
+/* Solve Z' * x = RHS */
+
+ sgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
+ if (ierr > 0) {
+ *info = ierr;
+ }
+
+ sgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
+ if (scaloc != 1.f) {
+ i__3 = *n;
+ for (k = 1; k <= i__3; ++k) {
+ sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
+ sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L150: */
+ }
+ *scale *= scaloc;
+ }
+
+/* Unpack solution vector(s) */
+
+ c__[is + js * c_dim1] = rhs[0];
+ c__[isp1 + js * c_dim1] = rhs[1];
+ f[is + js * f_dim1] = rhs[2];
+ f[isp1 + js * f_dim1] = rhs[3];
+
+/* Substitute R(I, J) and L(I, J) into remaining */
+/* equation. */
+
+ if (j > p + 2) {
+ i__3 = js - 1;
+ sger_(&mb, &i__3, &c_b42, rhs, &c__1, &b[js * b_dim1
+ + 1], &c__1, &f[is + f_dim1], ldf);
+ i__3 = js - 1;
+ sger_(&mb, &i__3, &c_b42, &rhs[2], &c__1, &e[js *
+ e_dim1 + 1], &c__1, &f[is + f_dim1], ldf);
+ }
+ if (i__ < p) {
+ i__3 = *m - ie;
+ sgemv_("T", &mb, &i__3, &c_b27, &a[is + (ie + 1) *
+ a_dim1], lda, rhs, &c__1, &c_b42, &c__[ie + 1
+ + js * c_dim1], &c__1);
+ i__3 = *m - ie;
+ sgemv_("T", &mb, &i__3, &c_b27, &d__[is + (ie + 1) *
+ d_dim1], ldd, &rhs[2], &c__1, &c_b42, &c__[ie
+ + 1 + js * c_dim1], &c__1);
+ }
+
+ } else if (mb == 2 && nb == 2) {
+
+/* Build an 8-by-8 system Z' * x = RHS */
+
+ slaset_("F", &c__8, &c__8, &c_b56, &c_b56, z__, &c__8);
+
+ z__[0] = a[is + is * a_dim1];
+ z__[1] = a[is + isp1 * a_dim1];
+ z__[4] = -b[js + js * b_dim1];
+ z__[6] = -b[jsp1 + js * b_dim1];
+
+ z__[8] = a[isp1 + is * a_dim1];
+ z__[9] = a[isp1 + isp1 * a_dim1];
+ z__[13] = -b[js + js * b_dim1];
+ z__[15] = -b[jsp1 + js * b_dim1];
+
+ z__[18] = a[is + is * a_dim1];
+ z__[19] = a[is + isp1 * a_dim1];
+ z__[20] = -b[js + jsp1 * b_dim1];
+ z__[22] = -b[jsp1 + jsp1 * b_dim1];
+
+ z__[26] = a[isp1 + is * a_dim1];
+ z__[27] = a[isp1 + isp1 * a_dim1];
+ z__[29] = -b[js + jsp1 * b_dim1];
+ z__[31] = -b[jsp1 + jsp1 * b_dim1];
+
+ z__[32] = d__[is + is * d_dim1];
+ z__[33] = d__[is + isp1 * d_dim1];
+ z__[36] = -e[js + js * e_dim1];
+
+ z__[41] = d__[isp1 + isp1 * d_dim1];
+ z__[45] = -e[js + js * e_dim1];
+
+ z__[50] = d__[is + is * d_dim1];
+ z__[51] = d__[is + isp1 * d_dim1];
+ z__[52] = -e[js + jsp1 * e_dim1];
+ z__[54] = -e[jsp1 + jsp1 * e_dim1];
+
+ z__[59] = d__[isp1 + isp1 * d_dim1];
+ z__[61] = -e[js + jsp1 * e_dim1];
+ z__[63] = -e[jsp1 + jsp1 * e_dim1];
+
+/* Set up right hand side(s) */
+
+ k = 1;
+ ii = mb * nb + 1;
+ i__3 = nb - 1;
+ for (jj = 0; jj <= i__3; ++jj) {
+ scopy_(&mb, &c__[is + (js + jj) * c_dim1], &c__1, &
+ rhs[k - 1], &c__1);
+ scopy_(&mb, &f[is + (js + jj) * f_dim1], &c__1, &rhs[
+ ii - 1], &c__1);
+ k += mb;
+ ii += mb;
+/* L160: */
+ }
+
+
+/* Solve Z' * x = RHS */
+
+ sgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr);
+ if (ierr > 0) {
+ *info = ierr;
+ }
+
+ sgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc);
+ if (scaloc != 1.f) {
+ i__3 = *n;
+ for (k = 1; k <= i__3; ++k) {
+ sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
+ sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L170: */
+ }
+ *scale *= scaloc;
+ }
+
+/* Unpack solution vector(s) */
+
+ k = 1;
+ ii = mb * nb + 1;
+ i__3 = nb - 1;
+ for (jj = 0; jj <= i__3; ++jj) {
+ scopy_(&mb, &rhs[k - 1], &c__1, &c__[is + (js + jj) *
+ c_dim1], &c__1);
+ scopy_(&mb, &rhs[ii - 1], &c__1, &f[is + (js + jj) *
+ f_dim1], &c__1);
+ k += mb;
+ ii += mb;
+/* L180: */
+ }
+
+/* Substitute R(I, J) and L(I, J) into remaining */
+/* equation. */
+
+ if (j > p + 2) {
+ i__3 = js - 1;
+ sgemm_("N", "T", &mb, &i__3, &nb, &c_b42, &c__[is +
+ js * c_dim1], ldc, &b[js * b_dim1 + 1], ldb, &
+ c_b42, &f[is + f_dim1], ldf);
+ i__3 = js - 1;
+ sgemm_("N", "T", &mb, &i__3, &nb, &c_b42, &f[is + js *
+ f_dim1], ldf, &e[js * e_dim1 + 1], lde, &
+ c_b42, &f[is + f_dim1], ldf);
+ }
+ if (i__ < p) {
+ i__3 = *m - ie;
+ sgemm_("T", "N", &i__3, &nb, &mb, &c_b27, &a[is + (ie
+ + 1) * a_dim1], lda, &c__[is + js * c_dim1],
+ ldc, &c_b42, &c__[ie + 1 + js * c_dim1], ldc);
+ i__3 = *m - ie;
+ sgemm_("T", "N", &i__3, &nb, &mb, &c_b27, &d__[is + (
+ ie + 1) * d_dim1], ldd, &f[is + js * f_dim1],
+ ldf, &c_b42, &c__[ie + 1 + js * c_dim1], ldc);
+ }
+
+ }
+
+/* L190: */
+ }
+/* L200: */
+ }
+
+ }
+ return 0;
+
+/* End of STGSY2 */
+
+} /* stgsy2_ */
diff --git a/SRC/stgsyl.c b/SRC/stgsyl.c
new file mode 100644
index 0000000..33b33c7
--- /dev/null
+++ b/SRC/stgsyl.c
@@ -0,0 +1,691 @@
+/* stgsyl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__5 = 5;
+static real c_b14 = 0.f;
+static integer c__1 = 1;
+static real c_b51 = -1.f;
+static real c_b52 = 1.f;
+
+/* Subroutine */ int stgsyl_(char *trans, integer *ijob, integer *m, integer *
+ n, real *a, integer *lda, real *b, integer *ldb, real *c__, integer *
+ ldc, real *d__, integer *ldd, real *e, integer *lde, real *f, integer
+ *ldf, real *scale, real *dif, real *work, integer *lwork, integer *
+ iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
+ d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3,
+ i__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, p, q, ie, je, mb, nb, is, js, pq;
+ real dsum;
+ integer ppqq;
+ extern logical lsame_(char *, char *);
+ integer ifunc;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ integer linfo;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ integer lwmin;
+ real scale2, dscale;
+ extern /* Subroutine */ int stgsy2_(char *, integer *, integer *, integer
+ *, real *, integer *, real *, integer *, real *, integer *, real *
+, integer *, real *, integer *, real *, integer *, real *, real *,
+ real *, integer *, integer *, integer *);
+ real scaloc;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *);
+ integer iround;
+ logical notran;
+ integer isolve;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STGSYL solves the generalized Sylvester equation: */
+
+/* A * R - L * B = scale * C (1) */
+/* D * R - L * E = scale * F */
+
+/* where R and L are unknown m-by-n matrices, (A, D), (B, E) and */
+/* (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n, */
+/* respectively, with real entries. (A, D) and (B, E) must be in */
+/* generalized (real) Schur canonical form, i.e. A, B are upper quasi */
+/* triangular and D, E are upper triangular. */
+
+/* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output */
+/* scaling factor chosen to avoid overflow. */
+
+/* In matrix notation (1) is equivalent to solve Zx = scale b, where */
+/* Z is defined as */
+
+/* Z = [ kron(In, A) -kron(B', Im) ] (2) */
+/* [ kron(In, D) -kron(E', Im) ]. */
+
+/* Here Ik is the identity matrix of size k and X' is the transpose of */
+/* X. kron(X, Y) is the Kronecker product between the matrices X and Y. */
+
+/* If TRANS = 'T', STGSYL solves the transposed system Z'*y = scale*b, */
+/* which is equivalent to solve for R and L in */
+
+/* A' * R + D' * L = scale * C (3) */
+/* R * B' + L * E' = scale * (-F) */
+
+/* This case (TRANS = 'T') is used to compute an one-norm-based estimate */
+/* of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D) */
+/* and (B,E), using SLACON. */
+
+/* If IJOB >= 1, STGSYL computes a Frobenius norm-based estimate */
+/* of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the */
+/* reciprocal of the smallest singular value of Z. See [1-2] for more */
+/* information. */
+
+/* This is a level 3 BLAS algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N', solve the generalized Sylvester equation (1). */
+/* = 'T', solve the 'transposed' system (3). */
+
+/* IJOB (input) INTEGER */
+/* Specifies what kind of functionality to be performed. */
+/* =0: solve (1) only. */
+/* =1: The functionality of 0 and 3. */
+/* =2: The functionality of 0 and 4. */
+/* =3: Only an estimate of Dif[(A,D), (B,E)] is computed. */
+/* (look ahead strategy IJOB = 1 is used). */
+/* =4: Only an estimate of Dif[(A,D), (B,E)] is computed. */
+/* ( SGECON on sub-systems is used ). */
+/* Not referenced if TRANS = 'T'. */
+
+/* M (input) INTEGER */
+/* The order of the matrices A and D, and the row dimension of */
+/* the matrices C, F, R and L. */
+
+/* N (input) INTEGER */
+/* The order of the matrices B and E, and the column dimension */
+/* of the matrices C, F, R and L. */
+
+/* A (input) REAL array, dimension (LDA, M) */
+/* The upper quasi triangular matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1, M). */
+
+/* B (input) REAL array, dimension (LDB, N) */
+/* The upper quasi triangular matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1, N). */
+
+/* C (input/output) REAL array, dimension (LDC, N) */
+/* On entry, C contains the right-hand-side of the first matrix */
+/* equation in (1) or (3). */
+/* On exit, if IJOB = 0, 1 or 2, C has been overwritten by */
+/* the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R, */
+/* the solution achieved during the computation of the */
+/* Dif-estimate. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1, M). */
+
+/* D (input) REAL array, dimension (LDD, M) */
+/* The upper triangular matrix D. */
+
+/* LDD (input) INTEGER */
+/* The leading dimension of the array D. LDD >= max(1, M). */
+
+/* E (input) REAL array, dimension (LDE, N) */
+/* The upper triangular matrix E. */
+
+/* LDE (input) INTEGER */
+/* The leading dimension of the array E. LDE >= max(1, N). */
+
+/* F (input/output) REAL array, dimension (LDF, N) */
+/* On entry, F contains the right-hand-side of the second matrix */
+/* equation in (1) or (3). */
+/* On exit, if IJOB = 0, 1 or 2, F has been overwritten by */
+/* the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L, */
+/* the solution achieved during the computation of the */
+/* Dif-estimate. */
+
+/* LDF (input) INTEGER */
+/* The leading dimension of the array F. LDF >= max(1, M). */
+
+/* DIF (output) REAL */
+/* On exit DIF is the reciprocal of a lower bound of the */
+/* reciprocal of the Dif-function, i.e. DIF is an upper bound of */
+/* Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2). */
+/* IF IJOB = 0 or TRANS = 'T', DIF is not touched. */
+
+/* SCALE (output) REAL */
+/* On exit SCALE is the scaling factor in (1) or (3). */
+/* If 0 < SCALE < 1, C and F hold the solutions R and L, resp., */
+/* to a slightly perturbed system but the input matrices A, B, D */
+/* and E have not been changed. If SCALE = 0, C and F hold the */
+/* solutions R and L, respectively, to the homogeneous system */
+/* with C = F = 0. Normally, SCALE = 1. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK > = 1. */
+/* If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N). */
+
+/* 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. */
+
+/* IWORK (workspace) INTEGER array, dimension (M+N+6) */
+
+/* INFO (output) INTEGER */
+/* =0: successful exit */
+/* <0: If INFO = -i, the i-th argument had an illegal value. */
+/* >0: (A, D) and (B, E) have common or close eigenvalues. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
+/* for Solving the Generalized Sylvester Equation and Estimating the */
+/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
+/* Department of Computing Science, Umea University, S-901 87 Umea, */
+/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */
+/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, */
+/* No 1, 1996. */
+
+/* [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester */
+/* Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal. */
+/* Appl., 15(4):1045-1060, 1994 */
+
+/* [3] B. Kagstrom and L. Westin, Generalized Schur Methods with */
+/* Condition Estimators for Solving the Generalized Sylvester */
+/* Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7, */
+/* July 1989, pp 745-751. */
+
+/* ===================================================================== */
+/* Replaced various illegal calls to SCOPY by calls to SLASET. */
+/* Sven Hammarling, 1/5/02. */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ d_dim1 = *ldd;
+ d_offset = 1 + d_dim1;
+ d__ -= d_offset;
+ e_dim1 = *lde;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ f_dim1 = *ldf;
+ f_offset = 1 + f_dim1;
+ f -= f_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+ if (! notran && ! lsame_(trans, "T")) {
+ *info = -1;
+ } else if (notran) {
+ if (*ijob < 0 || *ijob > 4) {
+ *info = -2;
+ }
+ }
+ if (*info == 0) {
+ if (*m <= 0) {
+ *info = -3;
+ } else if (*n <= 0) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ } else if (*ldd < max(1,*m)) {
+ *info = -12;
+ } else if (*lde < max(1,*n)) {
+ *info = -14;
+ } else if (*ldf < max(1,*m)) {
+ *info = -16;
+ }
+ }
+
+ if (*info == 0) {
+ if (notran) {
+ if (*ijob == 1 || *ijob == 2) {
+/* Computing MAX */
+ i__1 = 1, i__2 = (*m << 1) * *n;
+ lwmin = max(i__1,i__2);
+ } else {
+ lwmin = 1;
+ }
+ } else {
+ lwmin = 1;
+ }
+ work[1] = (real) lwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -20;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STGSYL", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ *scale = 1.f;
+ if (notran) {
+ if (*ijob != 0) {
+ *dif = 0.f;
+ }
+ }
+ return 0;
+ }
+
+/* Determine optimal block sizes MB and NB */
+
+ mb = ilaenv_(&c__2, "STGSYL", trans, m, n, &c_n1, &c_n1);
+ nb = ilaenv_(&c__5, "STGSYL", trans, m, n, &c_n1, &c_n1);
+
+ isolve = 1;
+ ifunc = 0;
+ if (notran) {
+ if (*ijob >= 3) {
+ ifunc = *ijob - 2;
+ slaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc)
+ ;
+ slaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf);
+ } else if (*ijob >= 1 && notran) {
+ isolve = 2;
+ }
+ }
+
+ if (mb <= 1 && nb <= 1 || mb >= *m && nb >= *n) {
+
+ i__1 = isolve;
+ for (iround = 1; iround <= i__1; ++iround) {
+
+/* Use unblocked Level 2 solver */
+
+ dscale = 0.f;
+ dsum = 1.f;
+ pq = 0;
+ stgsy2_(trans, &ifunc, m, n, &a[a_offset], lda, &b[b_offset], ldb,
+ &c__[c_offset], ldc, &d__[d_offset], ldd, &e[e_offset],
+ lde, &f[f_offset], ldf, scale, &dsum, &dscale, &iwork[1],
+ &pq, info);
+ if (dscale != 0.f) {
+ if (*ijob == 1 || *ijob == 3) {
+ *dif = sqrt((real) ((*m << 1) * *n)) / (dscale * sqrt(
+ dsum));
+ } else {
+ *dif = sqrt((real) pq) / (dscale * sqrt(dsum));
+ }
+ }
+
+ if (isolve == 2 && iround == 1) {
+ if (notran) {
+ ifunc = *ijob;
+ }
+ scale2 = *scale;
+ slacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m);
+ slacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m);
+ slaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc);
+ slaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf);
+ } else if (isolve == 2 && iround == 2) {
+ slacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc);
+ slacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf);
+ *scale = scale2;
+ }
+/* L30: */
+ }
+
+ return 0;
+ }
+
+/* Determine block structure of A */
+
+ p = 0;
+ i__ = 1;
+L40:
+ if (i__ > *m) {
+ goto L50;
+ }
+ ++p;
+ iwork[p] = i__;
+ i__ += mb;
+ if (i__ >= *m) {
+ goto L50;
+ }
+ if (a[i__ + (i__ - 1) * a_dim1] != 0.f) {
+ ++i__;
+ }
+ goto L40;
+L50:
+
+ iwork[p + 1] = *m + 1;
+ if (iwork[p] == iwork[p + 1]) {
+ --p;
+ }
+
+/* Determine block structure of B */
+
+ q = p + 1;
+ j = 1;
+L60:
+ if (j > *n) {
+ goto L70;
+ }
+ ++q;
+ iwork[q] = j;
+ j += nb;
+ if (j >= *n) {
+ goto L70;
+ }
+ if (b[j + (j - 1) * b_dim1] != 0.f) {
+ ++j;
+ }
+ goto L60;
+L70:
+
+ iwork[q + 1] = *n + 1;
+ if (iwork[q] == iwork[q + 1]) {
+ --q;
+ }
+
+ if (notran) {
+
+ i__1 = isolve;
+ for (iround = 1; iround <= i__1; ++iround) {
+
+/* Solve (I, J)-subsystem */
+/* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) */
+/* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) */
+/* for I = P, P - 1,..., 1; J = 1, 2,..., Q */
+
+ dscale = 0.f;
+ dsum = 1.f;
+ pq = 0;
+ *scale = 1.f;
+ i__2 = q;
+ for (j = p + 2; j <= i__2; ++j) {
+ js = iwork[j];
+ je = iwork[j + 1] - 1;
+ nb = je - js + 1;
+ for (i__ = p; i__ >= 1; --i__) {
+ is = iwork[i__];
+ ie = iwork[i__ + 1] - 1;
+ mb = ie - is + 1;
+ ppqq = 0;
+ stgsy2_(trans, &ifunc, &mb, &nb, &a[is + is * a_dim1],
+ lda, &b[js + js * b_dim1], ldb, &c__[is + js *
+ c_dim1], ldc, &d__[is + is * d_dim1], ldd, &e[js
+ + js * e_dim1], lde, &f[is + js * f_dim1], ldf, &
+ scaloc, &dsum, &dscale, &iwork[q + 2], &ppqq, &
+ linfo);
+ if (linfo > 0) {
+ *info = linfo;
+ }
+
+ pq += ppqq;
+ if (scaloc != 1.f) {
+ i__3 = js - 1;
+ for (k = 1; k <= i__3; ++k) {
+ sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
+ sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L80: */
+ }
+ i__3 = je;
+ for (k = js; k <= i__3; ++k) {
+ i__4 = is - 1;
+ sscal_(&i__4, &scaloc, &c__[k * c_dim1 + 1], &
+ c__1);
+ i__4 = is - 1;
+ sscal_(&i__4, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L90: */
+ }
+ i__3 = je;
+ for (k = js; k <= i__3; ++k) {
+ i__4 = *m - ie;
+ sscal_(&i__4, &scaloc, &c__[ie + 1 + k * c_dim1],
+ &c__1);
+ i__4 = *m - ie;
+ sscal_(&i__4, &scaloc, &f[ie + 1 + k * f_dim1], &
+ c__1);
+/* L100: */
+ }
+ i__3 = *n;
+ for (k = je + 1; k <= i__3; ++k) {
+ sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
+ sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L110: */
+ }
+ *scale *= scaloc;
+ }
+
+/* Substitute R(I, J) and L(I, J) into remaining */
+/* equation. */
+
+ if (i__ > 1) {
+ i__3 = is - 1;
+ sgemm_("N", "N", &i__3, &nb, &mb, &c_b51, &a[is *
+ a_dim1 + 1], lda, &c__[is + js * c_dim1], ldc,
+ &c_b52, &c__[js * c_dim1 + 1], ldc);
+ i__3 = is - 1;
+ sgemm_("N", "N", &i__3, &nb, &mb, &c_b51, &d__[is *
+ d_dim1 + 1], ldd, &c__[is + js * c_dim1], ldc,
+ &c_b52, &f[js * f_dim1 + 1], ldf);
+ }
+ if (j < q) {
+ i__3 = *n - je;
+ sgemm_("N", "N", &mb, &i__3, &nb, &c_b52, &f[is + js *
+ f_dim1], ldf, &b[js + (je + 1) * b_dim1],
+ ldb, &c_b52, &c__[is + (je + 1) * c_dim1],
+ ldc);
+ i__3 = *n - je;
+ sgemm_("N", "N", &mb, &i__3, &nb, &c_b52, &f[is + js *
+ f_dim1], ldf, &e[js + (je + 1) * e_dim1],
+ lde, &c_b52, &f[is + (je + 1) * f_dim1], ldf);
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+ if (dscale != 0.f) {
+ if (*ijob == 1 || *ijob == 3) {
+ *dif = sqrt((real) ((*m << 1) * *n)) / (dscale * sqrt(
+ dsum));
+ } else {
+ *dif = sqrt((real) pq) / (dscale * sqrt(dsum));
+ }
+ }
+ if (isolve == 2 && iround == 1) {
+ if (notran) {
+ ifunc = *ijob;
+ }
+ scale2 = *scale;
+ slacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m);
+ slacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m);
+ slaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc);
+ slaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf);
+ } else if (isolve == 2 && iround == 2) {
+ slacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc);
+ slacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf);
+ *scale = scale2;
+ }
+/* L150: */
+ }
+
+ } else {
+
+/* Solve transposed (I, J)-subsystem */
+/* A(I, I)' * R(I, J) + D(I, I)' * L(I, J) = C(I, J) */
+/* R(I, J) * B(J, J)' + L(I, J) * E(J, J)' = -F(I, J) */
+/* for I = 1,2,..., P; J = Q, Q-1,..., 1 */
+
+ *scale = 1.f;
+ i__1 = p;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ is = iwork[i__];
+ ie = iwork[i__ + 1] - 1;
+ mb = ie - is + 1;
+ i__2 = p + 2;
+ for (j = q; j >= i__2; --j) {
+ js = iwork[j];
+ je = iwork[j + 1] - 1;
+ nb = je - js + 1;
+ stgsy2_(trans, &ifunc, &mb, &nb, &a[is + is * a_dim1], lda, &
+ b[js + js * b_dim1], ldb, &c__[is + js * c_dim1], ldc,
+ &d__[is + is * d_dim1], ldd, &e[js + js * e_dim1],
+ lde, &f[is + js * f_dim1], ldf, &scaloc, &dsum, &
+ dscale, &iwork[q + 2], &ppqq, &linfo);
+ if (linfo > 0) {
+ *info = linfo;
+ }
+ if (scaloc != 1.f) {
+ i__3 = js - 1;
+ for (k = 1; k <= i__3; ++k) {
+ sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
+ sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L160: */
+ }
+ i__3 = je;
+ for (k = js; k <= i__3; ++k) {
+ i__4 = is - 1;
+ sscal_(&i__4, &scaloc, &c__[k * c_dim1 + 1], &c__1);
+ i__4 = is - 1;
+ sscal_(&i__4, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L170: */
+ }
+ i__3 = je;
+ for (k = js; k <= i__3; ++k) {
+ i__4 = *m - ie;
+ sscal_(&i__4, &scaloc, &c__[ie + 1 + k * c_dim1], &
+ c__1);
+ i__4 = *m - ie;
+ sscal_(&i__4, &scaloc, &f[ie + 1 + k * f_dim1], &c__1)
+ ;
+/* L180: */
+ }
+ i__3 = *n;
+ for (k = je + 1; k <= i__3; ++k) {
+ sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1);
+ sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1);
+/* L190: */
+ }
+ *scale *= scaloc;
+ }
+
+/* Substitute R(I, J) and L(I, J) into remaining equation. */
+
+ if (j > p + 2) {
+ i__3 = js - 1;
+ sgemm_("N", "T", &mb, &i__3, &nb, &c_b52, &c__[is + js *
+ c_dim1], ldc, &b[js * b_dim1 + 1], ldb, &c_b52, &
+ f[is + f_dim1], ldf);
+ i__3 = js - 1;
+ sgemm_("N", "T", &mb, &i__3, &nb, &c_b52, &f[is + js *
+ f_dim1], ldf, &e[js * e_dim1 + 1], lde, &c_b52, &
+ f[is + f_dim1], ldf);
+ }
+ if (i__ < p) {
+ i__3 = *m - ie;
+ sgemm_("T", "N", &i__3, &nb, &mb, &c_b51, &a[is + (ie + 1)
+ * a_dim1], lda, &c__[is + js * c_dim1], ldc, &
+ c_b52, &c__[ie + 1 + js * c_dim1], ldc);
+ i__3 = *m - ie;
+ sgemm_("T", "N", &i__3, &nb, &mb, &c_b51, &d__[is + (ie +
+ 1) * d_dim1], ldd, &f[is + js * f_dim1], ldf, &
+ c_b52, &c__[ie + 1 + js * c_dim1], ldc);
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+
+ }
+
+ work[1] = (real) lwmin;
+
+ return 0;
+
+/* End of STGSYL */
+
+} /* stgsyl_ */
diff --git a/SRC/stpcon.c b/SRC/stpcon.c
new file mode 100644
index 0000000..e16cac8
--- /dev/null
+++ b/SRC/stpcon.c
@@ -0,0 +1,230 @@
+/* stpcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int stpcon_(char *norm, char *uplo, char *diag, integer *n,
+ real *ap, real *rcond, real *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1;
+
+ /* Local variables */
+ integer ix, kase, kase1;
+ real scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ real anorm;
+ extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *);
+ logical upper;
+ real xnorm;
+ extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *,
+ real *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ real ainvnm;
+ logical onenrm;
+ extern doublereal slantp_(char *, char *, char *, integer *, real *, real
+ *);
+ char normin[1];
+ extern /* Subroutine */ int slatps_(char *, char *, char *, char *,
+ integer *, real *, real *, real *, real *, integer *);
+ real smlnum;
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STPCON estimates the reciprocal of the condition number of a packed */
+/* triangular matrix A, in either the 1-norm or the infinity-norm. */
+
+/* The norm of A is computed and an estimate is obtained for */
+/* norm(inv(A)), then the reciprocal of the condition number is */
+/* computed as */
+/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) REAL array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* RCOND (output) REAL */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ nounit = lsame_(diag, "N");
+
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STPCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ }
+
+ *rcond = 0.f;
+ smlnum = slamch_("Safe minimum") * (real) max(1,*n);
+
+/* Compute the norm of the triangular matrix A. */
+
+ anorm = slantp_(norm, uplo, diag, n, &ap[1], &work[1]);
+
+/* Continue only if ANORM > 0. */
+
+ if (anorm > 0.f) {
+
+/* Estimate the norm of the inverse of A. */
+
+ ainvnm = 0.f;
+ *(unsigned char *)normin = 'N';
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kase = 0;
+L10:
+ slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(A). */
+
+ slatps_(uplo, "No transpose", diag, normin, n, &ap[1], &work[
+ 1], &scale, &work[(*n << 1) + 1], info);
+ } else {
+
+/* Multiply by inv(A'). */
+
+ slatps_(uplo, "Transpose", diag, normin, n, &ap[1], &work[1],
+ &scale, &work[(*n << 1) + 1], info);
+ }
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ if (scale != 1.f) {
+ ix = isamax_(n, &work[1], &c__1);
+ xnorm = (r__1 = work[ix], dabs(r__1));
+ if (scale < xnorm * smlnum || scale == 0.f) {
+ goto L20;
+ }
+ srscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / anorm / ainvnm;
+ }
+ }
+
+L20:
+ return 0;
+
+/* End of STPCON */
+
+} /* stpcon_ */
diff --git a/SRC/stprfs.c b/SRC/stprfs.c
new file mode 100644
index 0000000..f72c96b
--- /dev/null
+++ b/SRC/stprfs.c
@@ -0,0 +1,493 @@
+/* stprfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b19 = -1.f;
+
+/* Subroutine */ int stprfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, real *ap, real *b, integer *ldb, real *x, integer *ldx,
+ real *ferr, real *berr, real *work, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ real s;
+ integer kc;
+ real xk;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), saxpy_(integer *, real *, real *, integer *, real *,
+ integer *), stpmv_(char *, char *, char *, integer *, real *,
+ real *, integer *), stpsv_(char *, char *,
+ char *, integer *, real *, real *, integer *), slacn2_(integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+ char transt[1];
+ logical nounit;
+ real lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STPRFS provides error bounds and backward error estimates for the */
+/* solution to a system of linear equations with a triangular packed */
+/* coefficient matrix. */
+
+/* The solution matrix X must be computed by STPTRS or some other */
+/* means before entering this routine. STPRFS does not do iterative */
+/* refinement because doing so cannot improve the backward error. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input) REAL array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*ldx < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STPRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A or A', depending on TRANS. */
+
+ scopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+ stpmv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1);
+ saxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] = (r__1 = b[i__ + j * b_dim1], dabs(r__1));
+/* L20: */
+ }
+
+ if (notran) {
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ kc = 1;
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+ i__3 = k;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ work[i__] += (r__1 = ap[kc + i__ - 1], dabs(r__1))
+ * xk;
+/* L30: */
+ }
+ kc += k;
+/* L40: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ work[i__] += (r__1 = ap[kc + i__ - 1], dabs(r__1))
+ * xk;
+/* L50: */
+ }
+ work[k] += xk;
+ kc += k;
+/* L60: */
+ }
+ }
+ } else {
+ kc = 1;
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ work[i__] += (r__1 = ap[kc + i__ - k], dabs(r__1))
+ * xk;
+/* L70: */
+ }
+ kc = kc + *n - k + 1;
+/* L80: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ work[i__] += (r__1 = ap[kc + i__ - k], dabs(r__1))
+ * xk;
+/* L90: */
+ }
+ work[k] += xk;
+ kc = kc + *n - k + 1;
+/* L100: */
+ }
+ }
+ }
+ } else {
+
+/* Compute abs(A')*abs(X) + abs(B). */
+
+ if (upper) {
+ kc = 1;
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__3 = k;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ s += (r__1 = ap[kc + i__ - 1], dabs(r__1)) * (
+ r__2 = x[i__ + j * x_dim1], dabs(r__2));
+/* L110: */
+ }
+ work[k] += s;
+ kc += k;
+/* L120: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = (r__1 = x[k + j * x_dim1], dabs(r__1));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ s += (r__1 = ap[kc + i__ - 1], dabs(r__1)) * (
+ r__2 = x[i__ + j * x_dim1], dabs(r__2));
+/* L130: */
+ }
+ work[k] += s;
+ kc += k;
+/* L140: */
+ }
+ }
+ } else {
+ kc = 1;
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ s += (r__1 = ap[kc + i__ - k], dabs(r__1)) * (
+ r__2 = x[i__ + j * x_dim1], dabs(r__2));
+/* L150: */
+ }
+ work[k] += s;
+ kc = kc + *n - k + 1;
+/* L160: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = (r__1 = x[k + j * x_dim1], dabs(r__1));
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ s += (r__1 = ap[kc + i__ - k], dabs(r__1)) * (
+ r__2 = x[i__ + j * x_dim1], dabs(r__2));
+/* L170: */
+ }
+ work[k] += s;
+ kc = kc + *n - k + 1;
+/* L180: */
+ }
+ }
+ }
+ }
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[
+ i__];
+ s = dmax(r__2,r__3);
+ } else {
+/* Computing MAX */
+ r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1)
+ / (work[i__] + safe1);
+ s = dmax(r__2,r__3);
+ }
+/* L190: */
+ }
+ berr[j] = s;
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use SLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L200: */
+ }
+
+ kase = 0;
+L210:
+ slacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+ kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)'). */
+
+ stpsv_(uplo, transt, diag, n, &ap[1], &work[*n + 1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L220: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L230: */
+ }
+ stpsv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1);
+ }
+ goto L210;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], dabs(r__1));
+ lstres = dmax(r__2,r__3);
+/* L240: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L250: */
+ }
+
+ return 0;
+
+/* End of STPRFS */
+
+} /* stprfs_ */
diff --git a/SRC/stptri.c b/SRC/stptri.c
new file mode 100644
index 0000000..3f98bb2
--- /dev/null
+++ b/SRC/stptri.c
@@ -0,0 +1,218 @@
+/* stptri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int stptri_(char *uplo, char *diag, integer *n, real *ap,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer j, jc, jj;
+ real ajj;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ logical upper;
+ extern /* Subroutine */ int stpmv_(char *, char *, char *, integer *,
+ real *, real *, integer *), xerbla_(char *
+, integer *);
+ integer jclast;
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STPTRI computes the inverse of a real upper or lower triangular */
+/* matrix A stored in packed format. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) REAL array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangular matrix A, stored */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+/* On exit, the (triangular) inverse of the original matrix, in */
+/* the same packed storage format. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */
+/* matrix is singular and its inverse can not be computed. */
+
+/* Further Details */
+/* =============== */
+
+/* A triangular matrix A can be transferred to packed storage using one */
+/* of the following program segments: */
+
+/* UPLO = 'U': UPLO = 'L': */
+
+/* JC = 1 JC = 1 */
+/* DO 2 J = 1, N DO 2 J = 1, N */
+/* DO 1 I = 1, J DO 1 I = J, N */
+/* AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J) */
+/* 1 CONTINUE 1 CONTINUE */
+/* JC = JC + J JC = JC + N - J + 1 */
+/* 2 CONTINUE 2 CONTINUE */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ nounit = lsame_(diag, "N");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STPTRI", &i__1);
+ return 0;
+ }
+
+/* Check for singularity if non-unit. */
+
+ if (nounit) {
+ if (upper) {
+ jj = 0;
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ jj += *info;
+ if (ap[jj] == 0.f) {
+ return 0;
+ }
+/* L10: */
+ }
+ } else {
+ jj = 1;
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ if (ap[jj] == 0.f) {
+ return 0;
+ }
+ jj = jj + *n - *info + 1;
+/* L20: */
+ }
+ }
+ *info = 0;
+ }
+
+ if (upper) {
+
+/* Compute inverse of upper triangular matrix. */
+
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (nounit) {
+ ap[jc + j - 1] = 1.f / ap[jc + j - 1];
+ ajj = -ap[jc + j - 1];
+ } else {
+ ajj = -1.f;
+ }
+
+/* Compute elements 1:j-1 of j-th column. */
+
+ i__2 = j - 1;
+ stpmv_("Upper", "No transpose", diag, &i__2, &ap[1], &ap[jc], &
+ c__1);
+ i__2 = j - 1;
+ sscal_(&i__2, &ajj, &ap[jc], &c__1);
+ jc += j;
+/* L30: */
+ }
+
+ } else {
+
+/* Compute inverse of lower triangular matrix. */
+
+ jc = *n * (*n + 1) / 2;
+ for (j = *n; j >= 1; --j) {
+ if (nounit) {
+ ap[jc] = 1.f / ap[jc];
+ ajj = -ap[jc];
+ } else {
+ ajj = -1.f;
+ }
+ if (j < *n) {
+
+/* Compute elements j+1:n of j-th column. */
+
+ i__1 = *n - j;
+ stpmv_("Lower", "No transpose", diag, &i__1, &ap[jclast], &ap[
+ jc + 1], &c__1);
+ i__1 = *n - j;
+ sscal_(&i__1, &ajj, &ap[jc + 1], &c__1);
+ }
+ jclast = jc;
+ jc = jc - *n + j - 2;
+/* L40: */
+ }
+ }
+
+ return 0;
+
+/* End of STPTRI */
+
+} /* stptri_ */
diff --git a/SRC/stptrs.c b/SRC/stptrs.c
new file mode 100644
index 0000000..4835333
--- /dev/null
+++ b/SRC/stptrs.c
@@ -0,0 +1,192 @@
+/* stptrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int stptrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, real *ap, real *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ integer j, jc;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int stpsv_(char *, char *, char *, integer *,
+ real *, real *, integer *), xerbla_(char *
+, integer *);
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STPTRS solves a triangular system of the form */
+
+/* A * X = B or A**T * X = B, */
+
+/* where A is a triangular matrix of order N stored in packed format, */
+/* and B is an N-by-NRHS matrix. A check is made to verify that A is */
+/* nonsingular. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input) REAL array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, if INFO = 0, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element of A is zero, */
+/* indicating that the matrix is singular and the */
+/* solutions X have not been computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ nounit = lsame_(diag, "N");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STPTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check for singularity. */
+
+ if (nounit) {
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ if (ap[jc + *info - 1] == 0.f) {
+ return 0;
+ }
+ jc += *info;
+/* L10: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ if (ap[jc] == 0.f) {
+ return 0;
+ }
+ jc = jc + *n - *info + 1;
+/* L20: */
+ }
+ }
+ }
+ *info = 0;
+
+/* Solve A * x = b or A' * x = b. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ stpsv_(uplo, trans, diag, n, &ap[1], &b[j * b_dim1 + 1], &c__1);
+/* L30: */
+ }
+
+ return 0;
+
+/* End of STPTRS */
+
+} /* stptrs_ */
diff --git a/SRC/stpttf.c b/SRC/stpttf.c
new file mode 100644
index 0000000..298f266
--- /dev/null
+++ b/SRC/stpttf.c
@@ -0,0 +1,499 @@
+/* stpttf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int stpttf_(char *transr, char *uplo, integer *n, real *ap,
+ real *arf, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, k, n1, n2, ij, jp, js, nt, lda, ijp;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nisodd;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+
+/* Purpose */
+/* ======= */
+
+/* STPTTF copies a triangular matrix A from standard packed format (TP) */
+/* to rectangular full packed format (TF). */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': ARF in Normal format is wanted; */
+/* = 'T': ARF in Conjugate-transpose format is wanted. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) REAL array, dimension ( N*(N+1)/2 ), */
+/* On entry, the upper or lower triangular matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* ARF (output) REAL array, dimension ( N*(N+1)/2 ), */
+/* On exit, the upper or lower triangular matrix A stored in */
+/* RFP format. For a further discussion see Notes below. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Notes */
+/* ===== */
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* even. We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* the transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* the transpose of the last three columns of AP lower. */
+/* This covers the case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 03 04 05 33 43 53 */
+/* 13 14 15 00 44 54 */
+/* 23 24 25 10 11 55 */
+/* 33 34 35 20 21 22 */
+/* 00 44 45 30 31 32 */
+/* 01 11 55 40 41 42 */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* odd. We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* the transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* the transpose of the last two columns of AP lower. */
+/* This covers the case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 02 03 04 00 33 43 */
+/* 12 13 14 10 11 44 */
+/* 22 23 24 20 21 22 */
+/* 00 33 34 30 31 32 */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+/* RFP A RFP A */
+
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "T")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STPTTF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (normaltransr) {
+ arf[0] = ap[0];
+ } else {
+ arf[0] = ap[0];
+ }
+ return 0;
+ }
+
+/* Size of array ARF(0:NT-1) */
+
+ nt = *n * (*n + 1) / 2;
+
+/* Set N1 and N2 depending on LOWER */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* If N is odd, set NISODD = .TRUE. */
+/* If N is even, set K = N/2 and NISODD = .FALSE. */
+
+/* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) */
+/* where noe = 0 if n is even, noe = 1 if n is odd */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ lda = *n + 1;
+ } else {
+ nisodd = TRUE_;
+ lda = *n;
+ }
+
+/* ARF^C has lda rows and n+1-noe cols */
+
+ if (! normaltransr) {
+ lda = (*n + 1) / 2;
+ }
+
+/* start execution: there are eight cases */
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* N is odd, TRANSR = 'N', and UPLO = 'L' */
+
+ ijp = 0;
+ jp = 0;
+ i__1 = n2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ij = i__ + jp;
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ jp += lda;
+ }
+ i__1 = n2 - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = n2;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ ij = i__ + j * lda;
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ }
+
+ } else {
+
+/* N is odd, TRANSR = 'N', and UPLO = 'U' */
+
+ ijp = 0;
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ ij = n2 + j;
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ ij += lda;
+ }
+ }
+ js = 0;
+ i__1 = *n - 1;
+ for (j = n1; j <= i__1; ++j) {
+ ij = js;
+ i__2 = js + j;
+ for (ij = js; ij <= i__2; ++ij) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ js += lda;
+ }
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'T' */
+
+ if (lower) {
+
+/* N is odd, TRANSR = 'T', and UPLO = 'L' */
+
+ ijp = 0;
+ i__1 = n2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = *n * lda - 1;
+ i__3 = lda;
+ for (ij = i__ * (lda + 1); i__3 < 0 ? ij >= i__2 : ij <=
+ i__2; ij += i__3) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ }
+ js = 1;
+ i__1 = n2 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + n2 - j - 1;
+ for (ij = js; ij <= i__3; ++ij) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ js = js + lda + 1;
+ }
+
+ } else {
+
+/* N is odd, TRANSR = 'T', and UPLO = 'U' */
+
+ ijp = 0;
+ js = n2 * lda;
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + j;
+ for (ij = js; ij <= i__3; ++ij) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ js += lda;
+ }
+ i__1 = n1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__3 = i__ + (n1 + i__) * lda;
+ i__2 = lda;
+ for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij +=
+ i__2) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* N is even, TRANSR = 'N', and UPLO = 'L' */
+
+ ijp = 0;
+ jp = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ij = i__ + 1 + jp;
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ jp += lda;
+ }
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = k - 1;
+ for (j = i__; j <= i__2; ++j) {
+ ij = i__ + j * lda;
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ }
+
+ } else {
+
+/* N is even, TRANSR = 'N', and UPLO = 'U' */
+
+ ijp = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ ij = k + 1 + j;
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ ij += lda;
+ }
+ }
+ js = 0;
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+ ij = js;
+ i__2 = js + j;
+ for (ij = js; ij <= i__2; ++ij) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ js += lda;
+ }
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'T' */
+
+ if (lower) {
+
+/* N is even, TRANSR = 'T', and UPLO = 'L' */
+
+ ijp = 0;
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = (*n + 1) * lda - 1;
+ i__3 = lda;
+ for (ij = i__ + (i__ + 1) * lda; i__3 < 0 ? ij >= i__2 :
+ ij <= i__2; ij += i__3) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ }
+ js = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + k - j - 1;
+ for (ij = js; ij <= i__3; ++ij) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ js = js + lda + 1;
+ }
+
+ } else {
+
+/* N is even, TRANSR = 'T', and UPLO = 'U' */
+
+ ijp = 0;
+ js = (k + 1) * lda;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + j;
+ for (ij = js; ij <= i__3; ++ij) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ js += lda;
+ }
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__3 = i__ + (k + i__) * lda;
+ i__2 = lda;
+ for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij +=
+ i__2) {
+ arf[ij] = ap[ijp];
+ ++ijp;
+ }
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of STPTTF */
+
+} /* stpttf_ */
diff --git a/SRC/stpttr.c b/SRC/stpttr.c
new file mode 100644
index 0000000..123038f
--- /dev/null
+++ b/SRC/stpttr.c
@@ -0,0 +1,144 @@
+/* stpttr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int stpttr_(char *uplo, integer *n, real *ap, real *a,
+ integer *lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STPTTR copies a triangular matrix A from standard packed format (TP) */
+/* to standard full format (TR). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular. */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) REAL array, dimension ( N*(N+1)/2 ), */
+/* On entry, the upper or lower triangular matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* A (output) REAL array, dimension ( LDA, N ) */
+/* On exit, the triangular matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ lower = lsame_(uplo, "L");
+ if (! lower && ! lsame_(uplo, "U")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STPTTR", &i__1);
+ return 0;
+ }
+
+ if (lower) {
+ k = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ++k;
+ a[i__ + j * a_dim1] = ap[k];
+ }
+ }
+ } else {
+ k = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ++k;
+ a[i__ + j * a_dim1] = ap[k];
+ }
+ }
+ }
+
+
+ return 0;
+
+/* End of STPTTR */
+
+} /* stpttr_ */
diff --git a/SRC/strcon.c b/SRC/strcon.c
new file mode 100644
index 0000000..430ca58
--- /dev/null
+++ b/SRC/strcon.c
@@ -0,0 +1,239 @@
+/* strcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int strcon_(char *norm, char *uplo, char *diag, integer *n,
+ real *a, integer *lda, real *rcond, real *work, integer *iwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ real r__1;
+
+ /* Local variables */
+ integer ix, kase, kase1;
+ real scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ real anorm;
+ extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *);
+ logical upper;
+ real xnorm;
+ extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *,
+ real *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ real ainvnm;
+ logical onenrm;
+ char normin[1];
+ extern doublereal slantr_(char *, char *, char *, integer *, integer *,
+ real *, integer *, real *);
+ extern /* Subroutine */ int slatrs_(char *, char *, char *, char *,
+ integer *, real *, integer *, real *, real *, real *, integer *);
+ real smlnum;
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STRCON estimates the reciprocal of the condition number of a */
+/* triangular matrix A, in either the 1-norm or the infinity-norm. */
+
+/* The norm of A is computed and an estimate is obtained for */
+/* norm(inv(A)), then the reciprocal of the condition number is */
+/* computed as */
+/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ nounit = lsame_(diag, "N");
+
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STRCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *rcond = 1.f;
+ return 0;
+ }
+
+ *rcond = 0.f;
+ smlnum = slamch_("Safe minimum") * (real) max(1,*n);
+
+/* Compute the norm of the triangular matrix A. */
+
+ anorm = slantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &work[1]);
+
+/* Continue only if ANORM > 0. */
+
+ if (anorm > 0.f) {
+
+/* Estimate the norm of the inverse of A. */
+
+ ainvnm = 0.f;
+ *(unsigned char *)normin = 'N';
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kase = 0;
+L10:
+ slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(A). */
+
+ slatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset],
+ lda, &work[1], &scale, &work[(*n << 1) + 1], info);
+ } else {
+
+/* Multiply by inv(A'). */
+
+ slatrs_(uplo, "Transpose", diag, normin, n, &a[a_offset], lda,
+ &work[1], &scale, &work[(*n << 1) + 1], info);
+ }
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ if (scale != 1.f) {
+ ix = isamax_(n, &work[1], &c__1);
+ xnorm = (r__1 = work[ix], dabs(r__1));
+ if (scale < xnorm * smlnum || scale == 0.f) {
+ goto L20;
+ }
+ srscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.f) {
+ *rcond = 1.f / anorm / ainvnm;
+ }
+ }
+
+L20:
+ return 0;
+
+/* End of STRCON */
+
+} /* strcon_ */
diff --git a/SRC/strevc.c b/SRC/strevc.c
new file mode 100644
index 0000000..1c95a80
--- /dev/null
+++ b/SRC/strevc.c
@@ -0,0 +1,1223 @@
+/* strevc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static logical c_false = FALSE_;
+static integer c__1 = 1;
+static real c_b22 = 1.f;
+static real c_b25 = 0.f;
+static integer c__2 = 2;
+static logical c_true = TRUE_;
+
+/* Subroutine */ int strevc_(char *side, char *howmny, logical *select,
+ integer *n, real *t, integer *ldt, real *vl, integer *ldvl, real *vr,
+ integer *ldvr, integer *mm, integer *m, real *work, integer *info)
+{
+ /* System generated locals */
+ integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
+ i__2, i__3;
+ real r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ real x[4] /* was [2][2] */;
+ integer j1, j2, n2, ii, ki, ip, is;
+ real wi, wr, rec, ulp, beta, emax;
+ logical pair, allv;
+ integer ierr;
+ real unfl, ovfl, smin;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ logical over;
+ real vmax;
+ integer jnxt;
+ real scale;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real remax;
+ logical leftv;
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ logical bothv;
+ real vcrit;
+ logical somev;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ real xnorm;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *), slaln2_(logical *, integer *, integer *, real
+ *, real *, real *, integer *, real *, real *, real *, integer *,
+ real *, real *, real *, integer *, real *, real *, integer *),
+ slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ extern integer isamax_(integer *, real *, integer *);
+ logical rightv;
+ real smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STREVC computes some or all of the right and/or left eigenvectors of */
+/* a real upper quasi-triangular matrix T. */
+/* Matrices of this type are produced by the Schur factorization of */
+/* a real general matrix: A = Q*T*Q**T, as computed by SHSEQR. */
+
+/* The right eigenvector x and the left eigenvector y of T corresponding */
+/* to an eigenvalue w are defined by: */
+
+/* T*x = w*x, (y**H)*T = w*(y**H) */
+
+/* where y**H denotes the conjugate transpose of y. */
+/* The eigenvalues are not input to this routine, but are read directly */
+/* from the diagonal blocks of T. */
+
+/* This routine returns the matrices X and/or Y of right and left */
+/* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an */
+/* input matrix. If Q is the orthogonal factor that reduces a matrix */
+/* A to Schur form T, then Q*X and Q*Y are the matrices of right and */
+/* left eigenvectors of A. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'R': compute right eigenvectors only; */
+/* = 'L': compute left eigenvectors only; */
+/* = 'B': compute both right and left eigenvectors. */
+
+/* HOWMNY (input) CHARACTER*1 */
+/* = 'A': compute all right and/or left eigenvectors; */
+/* = 'B': compute all right and/or left eigenvectors, */
+/* backtransformed by the matrices in VR and/or VL; */
+/* = 'S': compute selected right and/or left eigenvectors, */
+/* as indicated by the logical array SELECT. */
+
+/* SELECT (input/output) LOGICAL array, dimension (N) */
+/* If HOWMNY = 'S', SELECT specifies the eigenvectors to be */
+/* computed. */
+/* If w(j) is a real eigenvalue, the corresponding real */
+/* eigenvector is computed if SELECT(j) is .TRUE.. */
+/* If w(j) and w(j+1) are the real and imaginary parts of a */
+/* complex eigenvalue, the corresponding complex eigenvector is */
+/* computed if either SELECT(j) or SELECT(j+1) is .TRUE., and */
+/* on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to */
+/* .FALSE.. */
+/* Not referenced if HOWMNY = 'A' or 'B'. */
+
+/* N (input) INTEGER */
+/* The order of the matrix T. N >= 0. */
+
+/* T (input) REAL array, dimension (LDT,N) */
+/* The upper quasi-triangular matrix T in Schur canonical form. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= max(1,N). */
+
+/* VL (input/output) REAL array, dimension (LDVL,MM) */
+/* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */
+/* contain an N-by-N matrix Q (usually the orthogonal matrix Q */
+/* of Schur vectors returned by SHSEQR). */
+/* On exit, if SIDE = 'L' or 'B', VL contains: */
+/* if HOWMNY = 'A', the matrix Y of left eigenvectors of T; */
+/* if HOWMNY = 'B', the matrix Q*Y; */
+/* if HOWMNY = 'S', the left eigenvectors of T specified by */
+/* SELECT, stored consecutively in the columns */
+/* of VL, in the same order as their */
+/* eigenvalues. */
+/* A complex eigenvector corresponding to a complex eigenvalue */
+/* is stored in two consecutive columns, the first holding the */
+/* real part, and the second the imaginary part. */
+/* Not referenced if SIDE = 'R'. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. LDVL >= 1, and if */
+/* SIDE = 'L' or 'B', LDVL >= N. */
+
+/* VR (input/output) REAL array, dimension (LDVR,MM) */
+/* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */
+/* contain an N-by-N matrix Q (usually the orthogonal matrix Q */
+/* of Schur vectors returned by SHSEQR). */
+/* On exit, if SIDE = 'R' or 'B', VR contains: */
+/* if HOWMNY = 'A', the matrix X of right eigenvectors of T; */
+/* if HOWMNY = 'B', the matrix Q*X; */
+/* if HOWMNY = 'S', the right eigenvectors of T specified by */
+/* SELECT, stored consecutively in the columns */
+/* of VR, in the same order as their */
+/* eigenvalues. */
+/* A complex eigenvector corresponding to a complex eigenvalue */
+/* is stored in two consecutive columns, the first holding the */
+/* real part and the second the imaginary part. */
+/* Not referenced if SIDE = 'L'. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. LDVR >= 1, and if */
+/* SIDE = 'R' or 'B', LDVR >= N. */
+
+/* MM (input) INTEGER */
+/* The number of columns in the arrays VL and/or VR. MM >= M. */
+
+/* M (output) INTEGER */
+/* The number of columns in the arrays VL and/or VR actually */
+/* used to store the eigenvectors. */
+/* If HOWMNY = 'A' or 'B', M is set to N. */
+/* Each selected real eigenvector occupies one column and each */
+/* selected complex eigenvector occupies two columns. */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The algorithm used in this program is basically backward (forward) */
+/* substitution, with scaling to make the the code robust against */
+/* possible overflow. */
+
+/* Each eigenvector is normalized so that the element of largest */
+/* magnitude has magnitude 1; here the magnitude of a complex number */
+/* (x,y) is taken to be |x| + |y|. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ --select;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+
+ /* Function Body */
+ bothv = lsame_(side, "B");
+ rightv = lsame_(side, "R") || bothv;
+ leftv = lsame_(side, "L") || bothv;
+
+ allv = lsame_(howmny, "A");
+ over = lsame_(howmny, "B");
+ somev = lsame_(howmny, "S");
+
+ *info = 0;
+ if (! rightv && ! leftv) {
+ *info = -1;
+ } else if (! allv && ! over && ! somev) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldt < max(1,*n)) {
+ *info = -6;
+ } else if (*ldvl < 1 || leftv && *ldvl < *n) {
+ *info = -8;
+ } else if (*ldvr < 1 || rightv && *ldvr < *n) {
+ *info = -10;
+ } else {
+
+/* Set M to the number of columns required to store the selected */
+/* eigenvectors, standardize the array SELECT if necessary, and */
+/* test MM. */
+
+ if (somev) {
+ *m = 0;
+ pair = FALSE_;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (pair) {
+ pair = FALSE_;
+ select[j] = FALSE_;
+ } else {
+ if (j < *n) {
+ if (t[j + 1 + j * t_dim1] == 0.f) {
+ if (select[j]) {
+ ++(*m);
+ }
+ } else {
+ pair = TRUE_;
+ if (select[j] || select[j + 1]) {
+ select[j] = TRUE_;
+ *m += 2;
+ }
+ }
+ } else {
+ if (select[*n]) {
+ ++(*m);
+ }
+ }
+ }
+/* L10: */
+ }
+ } else {
+ *m = *n;
+ }
+
+ if (*mm < *m) {
+ *info = -11;
+ }
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STREVC", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Set the constants to control overflow. */
+
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ slabad_(&unfl, &ovfl);
+ ulp = slamch_("Precision");
+ smlnum = unfl * (*n / ulp);
+ bignum = (1.f - ulp) / smlnum;
+
+/* Compute 1-norm of each column of strictly upper triangular */
+/* part of T to control overflow in triangular solver. */
+
+ work[1] = 0.f;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ work[j] = 0.f;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[j] += (r__1 = t[i__ + j * t_dim1], dabs(r__1));
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* Index IP is used to specify the real or complex eigenvalue: */
+/* IP = 0, real eigenvalue, */
+/* 1, first of conjugate complex pair: (wr,wi) */
+/* -1, second of conjugate complex pair: (wr,wi) */
+
+ n2 = *n << 1;
+
+ if (rightv) {
+
+/* Compute right eigenvectors. */
+
+ ip = 0;
+ is = *m;
+ for (ki = *n; ki >= 1; --ki) {
+
+ if (ip == 1) {
+ goto L130;
+ }
+ if (ki == 1) {
+ goto L40;
+ }
+ if (t[ki + (ki - 1) * t_dim1] == 0.f) {
+ goto L40;
+ }
+ ip = -1;
+
+L40:
+ if (somev) {
+ if (ip == 0) {
+ if (! select[ki]) {
+ goto L130;
+ }
+ } else {
+ if (! select[ki - 1]) {
+ goto L130;
+ }
+ }
+ }
+
+/* Compute the KI-th eigenvalue (WR,WI). */
+
+ wr = t[ki + ki * t_dim1];
+ wi = 0.f;
+ if (ip != 0) {
+ wi = sqrt((r__1 = t[ki + (ki - 1) * t_dim1], dabs(r__1))) *
+ sqrt((r__2 = t[ki - 1 + ki * t_dim1], dabs(r__2)));
+ }
+/* Computing MAX */
+ r__1 = ulp * (dabs(wr) + dabs(wi));
+ smin = dmax(r__1,smlnum);
+
+ if (ip == 0) {
+
+/* Real right eigenvector */
+
+ work[ki + *n] = 1.f;
+
+/* Form right-hand side */
+
+ i__1 = ki - 1;
+ for (k = 1; k <= i__1; ++k) {
+ work[k + *n] = -t[k + ki * t_dim1];
+/* L50: */
+ }
+
+/* Solve the upper quasi-triangular system: */
+/* (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK. */
+
+ jnxt = ki - 1;
+ for (j = ki - 1; j >= 1; --j) {
+ if (j > jnxt) {
+ goto L60;
+ }
+ j1 = j;
+ j2 = j;
+ jnxt = j - 1;
+ if (j > 1) {
+ if (t[j + (j - 1) * t_dim1] != 0.f) {
+ j1 = j - 1;
+ jnxt = j - 2;
+ }
+ }
+
+ if (j1 == j2) {
+
+/* 1-by-1 diagonal block */
+
+ slaln2_(&c_false, &c__1, &c__1, &smin, &c_b22, &t[j +
+ j * t_dim1], ldt, &c_b22, &c_b22, &work[j + *
+ n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm,
+ &ierr);
+
+/* Scale X(1,1) to avoid overflow when updating */
+/* the right-hand side. */
+
+ if (xnorm > 1.f) {
+ if (work[j] > bignum / xnorm) {
+ x[0] /= xnorm;
+ scale /= xnorm;
+ }
+ }
+
+/* Scale if necessary */
+
+ if (scale != 1.f) {
+ sscal_(&ki, &scale, &work[*n + 1], &c__1);
+ }
+ work[j + *n] = x[0];
+
+/* Update right-hand side */
+
+ i__1 = j - 1;
+ r__1 = -x[0];
+ saxpy_(&i__1, &r__1, &t[j * t_dim1 + 1], &c__1, &work[
+ *n + 1], &c__1);
+
+ } else {
+
+/* 2-by-2 diagonal block */
+
+ slaln2_(&c_false, &c__2, &c__1, &smin, &c_b22, &t[j -
+ 1 + (j - 1) * t_dim1], ldt, &c_b22, &c_b22, &
+ work[j - 1 + *n], n, &wr, &c_b25, x, &c__2, &
+ scale, &xnorm, &ierr);
+
+/* Scale X(1,1) and X(2,1) to avoid overflow when */
+/* updating the right-hand side. */
+
+ if (xnorm > 1.f) {
+/* Computing MAX */
+ r__1 = work[j - 1], r__2 = work[j];
+ beta = dmax(r__1,r__2);
+ if (beta > bignum / xnorm) {
+ x[0] /= xnorm;
+ x[1] /= xnorm;
+ scale /= xnorm;
+ }
+ }
+
+/* Scale if necessary */
+
+ if (scale != 1.f) {
+ sscal_(&ki, &scale, &work[*n + 1], &c__1);
+ }
+ work[j - 1 + *n] = x[0];
+ work[j + *n] = x[1];
+
+/* Update right-hand side */
+
+ i__1 = j - 2;
+ r__1 = -x[0];
+ saxpy_(&i__1, &r__1, &t[(j - 1) * t_dim1 + 1], &c__1,
+ &work[*n + 1], &c__1);
+ i__1 = j - 2;
+ r__1 = -x[1];
+ saxpy_(&i__1, &r__1, &t[j * t_dim1 + 1], &c__1, &work[
+ *n + 1], &c__1);
+ }
+L60:
+ ;
+ }
+
+/* Copy the vector x or Q*x to VR and normalize. */
+
+ if (! over) {
+ scopy_(&ki, &work[*n + 1], &c__1, &vr[is * vr_dim1 + 1], &
+ c__1);
+
+ ii = isamax_(&ki, &vr[is * vr_dim1 + 1], &c__1);
+ remax = 1.f / (r__1 = vr[ii + is * vr_dim1], dabs(r__1));
+ sscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1);
+
+ i__1 = *n;
+ for (k = ki + 1; k <= i__1; ++k) {
+ vr[k + is * vr_dim1] = 0.f;
+/* L70: */
+ }
+ } else {
+ if (ki > 1) {
+ i__1 = ki - 1;
+ sgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, &
+ work[*n + 1], &c__1, &work[ki + *n], &vr[ki *
+ vr_dim1 + 1], &c__1);
+ }
+
+ ii = isamax_(n, &vr[ki * vr_dim1 + 1], &c__1);
+ remax = 1.f / (r__1 = vr[ii + ki * vr_dim1], dabs(r__1));
+ sscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1);
+ }
+
+ } else {
+
+/* Complex right eigenvector. */
+
+/* Initial solve */
+/* [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0. */
+/* [ (T(KI,KI-1) T(KI,KI) ) ] */
+
+ if ((r__1 = t[ki - 1 + ki * t_dim1], dabs(r__1)) >= (r__2 = t[
+ ki + (ki - 1) * t_dim1], dabs(r__2))) {
+ work[ki - 1 + *n] = 1.f;
+ work[ki + n2] = wi / t[ki - 1 + ki * t_dim1];
+ } else {
+ work[ki - 1 + *n] = -wi / t[ki + (ki - 1) * t_dim1];
+ work[ki + n2] = 1.f;
+ }
+ work[ki + *n] = 0.f;
+ work[ki - 1 + n2] = 0.f;
+
+/* Form right-hand side */
+
+ i__1 = ki - 2;
+ for (k = 1; k <= i__1; ++k) {
+ work[k + *n] = -work[ki - 1 + *n] * t[k + (ki - 1) *
+ t_dim1];
+ work[k + n2] = -work[ki + n2] * t[k + ki * t_dim1];
+/* L80: */
+ }
+
+/* Solve upper quasi-triangular system: */
+/* (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2) */
+
+ jnxt = ki - 2;
+ for (j = ki - 2; j >= 1; --j) {
+ if (j > jnxt) {
+ goto L90;
+ }
+ j1 = j;
+ j2 = j;
+ jnxt = j - 1;
+ if (j > 1) {
+ if (t[j + (j - 1) * t_dim1] != 0.f) {
+ j1 = j - 1;
+ jnxt = j - 2;
+ }
+ }
+
+ if (j1 == j2) {
+
+/* 1-by-1 diagonal block */
+
+ slaln2_(&c_false, &c__1, &c__2, &smin, &c_b22, &t[j +
+ j * t_dim1], ldt, &c_b22, &c_b22, &work[j + *
+ n], n, &wr, &wi, x, &c__2, &scale, &xnorm, &
+ ierr);
+
+/* Scale X(1,1) and X(1,2) to avoid overflow when */
+/* updating the right-hand side. */
+
+ if (xnorm > 1.f) {
+ if (work[j] > bignum / xnorm) {
+ x[0] /= xnorm;
+ x[2] /= xnorm;
+ scale /= xnorm;
+ }
+ }
+
+/* Scale if necessary */
+
+ if (scale != 1.f) {
+ sscal_(&ki, &scale, &work[*n + 1], &c__1);
+ sscal_(&ki, &scale, &work[n2 + 1], &c__1);
+ }
+ work[j + *n] = x[0];
+ work[j + n2] = x[2];
+
+/* Update the right-hand side */
+
+ i__1 = j - 1;
+ r__1 = -x[0];
+ saxpy_(&i__1, &r__1, &t[j * t_dim1 + 1], &c__1, &work[
+ *n + 1], &c__1);
+ i__1 = j - 1;
+ r__1 = -x[2];
+ saxpy_(&i__1, &r__1, &t[j * t_dim1 + 1], &c__1, &work[
+ n2 + 1], &c__1);
+
+ } else {
+
+/* 2-by-2 diagonal block */
+
+ slaln2_(&c_false, &c__2, &c__2, &smin, &c_b22, &t[j -
+ 1 + (j - 1) * t_dim1], ldt, &c_b22, &c_b22, &
+ work[j - 1 + *n], n, &wr, &wi, x, &c__2, &
+ scale, &xnorm, &ierr);
+
+/* Scale X to avoid overflow when updating */
+/* the right-hand side. */
+
+ if (xnorm > 1.f) {
+/* Computing MAX */
+ r__1 = work[j - 1], r__2 = work[j];
+ beta = dmax(r__1,r__2);
+ if (beta > bignum / xnorm) {
+ rec = 1.f / xnorm;
+ x[0] *= rec;
+ x[2] *= rec;
+ x[1] *= rec;
+ x[3] *= rec;
+ scale *= rec;
+ }
+ }
+
+/* Scale if necessary */
+
+ if (scale != 1.f) {
+ sscal_(&ki, &scale, &work[*n + 1], &c__1);
+ sscal_(&ki, &scale, &work[n2 + 1], &c__1);
+ }
+ work[j - 1 + *n] = x[0];
+ work[j + *n] = x[1];
+ work[j - 1 + n2] = x[2];
+ work[j + n2] = x[3];
+
+/* Update the right-hand side */
+
+ i__1 = j - 2;
+ r__1 = -x[0];
+ saxpy_(&i__1, &r__1, &t[(j - 1) * t_dim1 + 1], &c__1,
+ &work[*n + 1], &c__1);
+ i__1 = j - 2;
+ r__1 = -x[1];
+ saxpy_(&i__1, &r__1, &t[j * t_dim1 + 1], &c__1, &work[
+ *n + 1], &c__1);
+ i__1 = j - 2;
+ r__1 = -x[2];
+ saxpy_(&i__1, &r__1, &t[(j - 1) * t_dim1 + 1], &c__1,
+ &work[n2 + 1], &c__1);
+ i__1 = j - 2;
+ r__1 = -x[3];
+ saxpy_(&i__1, &r__1, &t[j * t_dim1 + 1], &c__1, &work[
+ n2 + 1], &c__1);
+ }
+L90:
+ ;
+ }
+
+/* Copy the vector x or Q*x to VR and normalize. */
+
+ if (! over) {
+ scopy_(&ki, &work[*n + 1], &c__1, &vr[(is - 1) * vr_dim1
+ + 1], &c__1);
+ scopy_(&ki, &work[n2 + 1], &c__1, &vr[is * vr_dim1 + 1], &
+ c__1);
+
+ emax = 0.f;
+ i__1 = ki;
+ for (k = 1; k <= i__1; ++k) {
+/* Computing MAX */
+ r__3 = emax, r__4 = (r__1 = vr[k + (is - 1) * vr_dim1]
+ , dabs(r__1)) + (r__2 = vr[k + is * vr_dim1],
+ dabs(r__2));
+ emax = dmax(r__3,r__4);
+/* L100: */
+ }
+
+ remax = 1.f / emax;
+ sscal_(&ki, &remax, &vr[(is - 1) * vr_dim1 + 1], &c__1);
+ sscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1);
+
+ i__1 = *n;
+ for (k = ki + 1; k <= i__1; ++k) {
+ vr[k + (is - 1) * vr_dim1] = 0.f;
+ vr[k + is * vr_dim1] = 0.f;
+/* L110: */
+ }
+
+ } else {
+
+ if (ki > 2) {
+ i__1 = ki - 2;
+ sgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, &
+ work[*n + 1], &c__1, &work[ki - 1 + *n], &vr[(
+ ki - 1) * vr_dim1 + 1], &c__1);
+ i__1 = ki - 2;
+ sgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, &
+ work[n2 + 1], &c__1, &work[ki + n2], &vr[ki *
+ vr_dim1 + 1], &c__1);
+ } else {
+ sscal_(n, &work[ki - 1 + *n], &vr[(ki - 1) * vr_dim1
+ + 1], &c__1);
+ sscal_(n, &work[ki + n2], &vr[ki * vr_dim1 + 1], &
+ c__1);
+ }
+
+ emax = 0.f;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+/* Computing MAX */
+ r__3 = emax, r__4 = (r__1 = vr[k + (ki - 1) * vr_dim1]
+ , dabs(r__1)) + (r__2 = vr[k + ki * vr_dim1],
+ dabs(r__2));
+ emax = dmax(r__3,r__4);
+/* L120: */
+ }
+ remax = 1.f / emax;
+ sscal_(n, &remax, &vr[(ki - 1) * vr_dim1 + 1], &c__1);
+ sscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1);
+ }
+ }
+
+ --is;
+ if (ip != 0) {
+ --is;
+ }
+L130:
+ if (ip == 1) {
+ ip = 0;
+ }
+ if (ip == -1) {
+ ip = 1;
+ }
+/* L140: */
+ }
+ }
+
+ if (leftv) {
+
+/* Compute left eigenvectors. */
+
+ ip = 0;
+ is = 1;
+ i__1 = *n;
+ for (ki = 1; ki <= i__1; ++ki) {
+
+ if (ip == -1) {
+ goto L250;
+ }
+ if (ki == *n) {
+ goto L150;
+ }
+ if (t[ki + 1 + ki * t_dim1] == 0.f) {
+ goto L150;
+ }
+ ip = 1;
+
+L150:
+ if (somev) {
+ if (! select[ki]) {
+ goto L250;
+ }
+ }
+
+/* Compute the KI-th eigenvalue (WR,WI). */
+
+ wr = t[ki + ki * t_dim1];
+ wi = 0.f;
+ if (ip != 0) {
+ wi = sqrt((r__1 = t[ki + (ki + 1) * t_dim1], dabs(r__1))) *
+ sqrt((r__2 = t[ki + 1 + ki * t_dim1], dabs(r__2)));
+ }
+/* Computing MAX */
+ r__1 = ulp * (dabs(wr) + dabs(wi));
+ smin = dmax(r__1,smlnum);
+
+ if (ip == 0) {
+
+/* Real left eigenvector. */
+
+ work[ki + *n] = 1.f;
+
+/* Form right-hand side */
+
+ i__2 = *n;
+ for (k = ki + 1; k <= i__2; ++k) {
+ work[k + *n] = -t[ki + k * t_dim1];
+/* L160: */
+ }
+
+/* Solve the quasi-triangular system: */
+/* (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK */
+
+ vmax = 1.f;
+ vcrit = bignum;
+
+ jnxt = ki + 1;
+ i__2 = *n;
+ for (j = ki + 1; j <= i__2; ++j) {
+ if (j < jnxt) {
+ goto L170;
+ }
+ j1 = j;
+ j2 = j;
+ jnxt = j + 1;
+ if (j < *n) {
+ if (t[j + 1 + j * t_dim1] != 0.f) {
+ j2 = j + 1;
+ jnxt = j + 2;
+ }
+ }
+
+ if (j1 == j2) {
+
+/* 1-by-1 diagonal block */
+
+/* Scale if necessary to avoid overflow when forming */
+/* the right-hand side. */
+
+ if (work[j] > vcrit) {
+ rec = 1.f / vmax;
+ i__3 = *n - ki + 1;
+ sscal_(&i__3, &rec, &work[ki + *n], &c__1);
+ vmax = 1.f;
+ vcrit = bignum;
+ }
+
+ i__3 = j - ki - 1;
+ work[j + *n] -= sdot_(&i__3, &t[ki + 1 + j * t_dim1],
+ &c__1, &work[ki + 1 + *n], &c__1);
+
+/* Solve (T(J,J)-WR)'*X = WORK */
+
+ slaln2_(&c_false, &c__1, &c__1, &smin, &c_b22, &t[j +
+ j * t_dim1], ldt, &c_b22, &c_b22, &work[j + *
+ n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm,
+ &ierr);
+
+/* Scale if necessary */
+
+ if (scale != 1.f) {
+ i__3 = *n - ki + 1;
+ sscal_(&i__3, &scale, &work[ki + *n], &c__1);
+ }
+ work[j + *n] = x[0];
+/* Computing MAX */
+ r__2 = (r__1 = work[j + *n], dabs(r__1));
+ vmax = dmax(r__2,vmax);
+ vcrit = bignum / vmax;
+
+ } else {
+
+/* 2-by-2 diagonal block */
+
+/* Scale if necessary to avoid overflow when forming */
+/* the right-hand side. */
+
+/* Computing MAX */
+ r__1 = work[j], r__2 = work[j + 1];
+ beta = dmax(r__1,r__2);
+ if (beta > vcrit) {
+ rec = 1.f / vmax;
+ i__3 = *n - ki + 1;
+ sscal_(&i__3, &rec, &work[ki + *n], &c__1);
+ vmax = 1.f;
+ vcrit = bignum;
+ }
+
+ i__3 = j - ki - 1;
+ work[j + *n] -= sdot_(&i__3, &t[ki + 1 + j * t_dim1],
+ &c__1, &work[ki + 1 + *n], &c__1);
+
+ i__3 = j - ki - 1;
+ work[j + 1 + *n] -= sdot_(&i__3, &t[ki + 1 + (j + 1) *
+ t_dim1], &c__1, &work[ki + 1 + *n], &c__1);
+
+/* Solve */
+/* [T(J,J)-WR T(J,J+1) ]'* X = SCALE*( WORK1 ) */
+/* [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 ) */
+
+ slaln2_(&c_true, &c__2, &c__1, &smin, &c_b22, &t[j +
+ j * t_dim1], ldt, &c_b22, &c_b22, &work[j + *
+ n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm,
+ &ierr);
+
+/* Scale if necessary */
+
+ if (scale != 1.f) {
+ i__3 = *n - ki + 1;
+ sscal_(&i__3, &scale, &work[ki + *n], &c__1);
+ }
+ work[j + *n] = x[0];
+ work[j + 1 + *n] = x[1];
+
+/* Computing MAX */
+ r__3 = (r__1 = work[j + *n], dabs(r__1)), r__4 = (
+ r__2 = work[j + 1 + *n], dabs(r__2)), r__3 =
+ max(r__3,r__4);
+ vmax = dmax(r__3,vmax);
+ vcrit = bignum / vmax;
+
+ }
+L170:
+ ;
+ }
+
+/* Copy the vector x or Q*x to VL and normalize. */
+
+ if (! over) {
+ i__2 = *n - ki + 1;
+ scopy_(&i__2, &work[ki + *n], &c__1, &vl[ki + is *
+ vl_dim1], &c__1);
+
+ i__2 = *n - ki + 1;
+ ii = isamax_(&i__2, &vl[ki + is * vl_dim1], &c__1) + ki -
+ 1;
+ remax = 1.f / (r__1 = vl[ii + is * vl_dim1], dabs(r__1));
+ i__2 = *n - ki + 1;
+ sscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1);
+
+ i__2 = ki - 1;
+ for (k = 1; k <= i__2; ++k) {
+ vl[k + is * vl_dim1] = 0.f;
+/* L180: */
+ }
+
+ } else {
+
+ if (ki < *n) {
+ i__2 = *n - ki;
+ sgemv_("N", n, &i__2, &c_b22, &vl[(ki + 1) * vl_dim1
+ + 1], ldvl, &work[ki + 1 + *n], &c__1, &work[
+ ki + *n], &vl[ki * vl_dim1 + 1], &c__1);
+ }
+
+ ii = isamax_(n, &vl[ki * vl_dim1 + 1], &c__1);
+ remax = 1.f / (r__1 = vl[ii + ki * vl_dim1], dabs(r__1));
+ sscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1);
+
+ }
+
+ } else {
+
+/* Complex left eigenvector. */
+
+/* Initial solve: */
+/* ((T(KI,KI) T(KI,KI+1) )' - (WR - I* WI))*X = 0. */
+/* ((T(KI+1,KI) T(KI+1,KI+1)) ) */
+
+ if ((r__1 = t[ki + (ki + 1) * t_dim1], dabs(r__1)) >= (r__2 =
+ t[ki + 1 + ki * t_dim1], dabs(r__2))) {
+ work[ki + *n] = wi / t[ki + (ki + 1) * t_dim1];
+ work[ki + 1 + n2] = 1.f;
+ } else {
+ work[ki + *n] = 1.f;
+ work[ki + 1 + n2] = -wi / t[ki + 1 + ki * t_dim1];
+ }
+ work[ki + 1 + *n] = 0.f;
+ work[ki + n2] = 0.f;
+
+/* Form right-hand side */
+
+ i__2 = *n;
+ for (k = ki + 2; k <= i__2; ++k) {
+ work[k + *n] = -work[ki + *n] * t[ki + k * t_dim1];
+ work[k + n2] = -work[ki + 1 + n2] * t[ki + 1 + k * t_dim1]
+ ;
+/* L190: */
+ }
+
+/* Solve complex quasi-triangular system: */
+/* ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2 */
+
+ vmax = 1.f;
+ vcrit = bignum;
+
+ jnxt = ki + 2;
+ i__2 = *n;
+ for (j = ki + 2; j <= i__2; ++j) {
+ if (j < jnxt) {
+ goto L200;
+ }
+ j1 = j;
+ j2 = j;
+ jnxt = j + 1;
+ if (j < *n) {
+ if (t[j + 1 + j * t_dim1] != 0.f) {
+ j2 = j + 1;
+ jnxt = j + 2;
+ }
+ }
+
+ if (j1 == j2) {
+
+/* 1-by-1 diagonal block */
+
+/* Scale if necessary to avoid overflow when */
+/* forming the right-hand side elements. */
+
+ if (work[j] > vcrit) {
+ rec = 1.f / vmax;
+ i__3 = *n - ki + 1;
+ sscal_(&i__3, &rec, &work[ki + *n], &c__1);
+ i__3 = *n - ki + 1;
+ sscal_(&i__3, &rec, &work[ki + n2], &c__1);
+ vmax = 1.f;
+ vcrit = bignum;
+ }
+
+ i__3 = j - ki - 2;
+ work[j + *n] -= sdot_(&i__3, &t[ki + 2 + j * t_dim1],
+ &c__1, &work[ki + 2 + *n], &c__1);
+ i__3 = j - ki - 2;
+ work[j + n2] -= sdot_(&i__3, &t[ki + 2 + j * t_dim1],
+ &c__1, &work[ki + 2 + n2], &c__1);
+
+/* Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2 */
+
+ r__1 = -wi;
+ slaln2_(&c_false, &c__1, &c__2, &smin, &c_b22, &t[j +
+ j * t_dim1], ldt, &c_b22, &c_b22, &work[j + *
+ n], n, &wr, &r__1, x, &c__2, &scale, &xnorm, &
+ ierr);
+
+/* Scale if necessary */
+
+ if (scale != 1.f) {
+ i__3 = *n - ki + 1;
+ sscal_(&i__3, &scale, &work[ki + *n], &c__1);
+ i__3 = *n - ki + 1;
+ sscal_(&i__3, &scale, &work[ki + n2], &c__1);
+ }
+ work[j + *n] = x[0];
+ work[j + n2] = x[2];
+/* Computing MAX */
+ r__3 = (r__1 = work[j + *n], dabs(r__1)), r__4 = (
+ r__2 = work[j + n2], dabs(r__2)), r__3 = max(
+ r__3,r__4);
+ vmax = dmax(r__3,vmax);
+ vcrit = bignum / vmax;
+
+ } else {
+
+/* 2-by-2 diagonal block */
+
+/* Scale if necessary to avoid overflow when forming */
+/* the right-hand side elements. */
+
+/* Computing MAX */
+ r__1 = work[j], r__2 = work[j + 1];
+ beta = dmax(r__1,r__2);
+ if (beta > vcrit) {
+ rec = 1.f / vmax;
+ i__3 = *n - ki + 1;
+ sscal_(&i__3, &rec, &work[ki + *n], &c__1);
+ i__3 = *n - ki + 1;
+ sscal_(&i__3, &rec, &work[ki + n2], &c__1);
+ vmax = 1.f;
+ vcrit = bignum;
+ }
+
+ i__3 = j - ki - 2;
+ work[j + *n] -= sdot_(&i__3, &t[ki + 2 + j * t_dim1],
+ &c__1, &work[ki + 2 + *n], &c__1);
+
+ i__3 = j - ki - 2;
+ work[j + n2] -= sdot_(&i__3, &t[ki + 2 + j * t_dim1],
+ &c__1, &work[ki + 2 + n2], &c__1);
+
+ i__3 = j - ki - 2;
+ work[j + 1 + *n] -= sdot_(&i__3, &t[ki + 2 + (j + 1) *
+ t_dim1], &c__1, &work[ki + 2 + *n], &c__1);
+
+ i__3 = j - ki - 2;
+ work[j + 1 + n2] -= sdot_(&i__3, &t[ki + 2 + (j + 1) *
+ t_dim1], &c__1, &work[ki + 2 + n2], &c__1);
+
+/* Solve 2-by-2 complex linear equation */
+/* ([T(j,j) T(j,j+1) ]'-(wr-i*wi)*I)*X = SCALE*B */
+/* ([T(j+1,j) T(j+1,j+1)] ) */
+
+ r__1 = -wi;
+ slaln2_(&c_true, &c__2, &c__2, &smin, &c_b22, &t[j +
+ j * t_dim1], ldt, &c_b22, &c_b22, &work[j + *
+ n], n, &wr, &r__1, x, &c__2, &scale, &xnorm, &
+ ierr);
+
+/* Scale if necessary */
+
+ if (scale != 1.f) {
+ i__3 = *n - ki + 1;
+ sscal_(&i__3, &scale, &work[ki + *n], &c__1);
+ i__3 = *n - ki + 1;
+ sscal_(&i__3, &scale, &work[ki + n2], &c__1);
+ }
+ work[j + *n] = x[0];
+ work[j + n2] = x[2];
+ work[j + 1 + *n] = x[1];
+ work[j + 1 + n2] = x[3];
+/* Computing MAX */
+ r__1 = dabs(x[0]), r__2 = dabs(x[2]), r__1 = max(r__1,
+ r__2), r__2 = dabs(x[1]), r__1 = max(r__1,
+ r__2), r__2 = dabs(x[3]), r__1 = max(r__1,
+ r__2);
+ vmax = dmax(r__1,vmax);
+ vcrit = bignum / vmax;
+
+ }
+L200:
+ ;
+ }
+
+/* Copy the vector x or Q*x to VL and normalize. */
+
+ if (! over) {
+ i__2 = *n - ki + 1;
+ scopy_(&i__2, &work[ki + *n], &c__1, &vl[ki + is *
+ vl_dim1], &c__1);
+ i__2 = *n - ki + 1;
+ scopy_(&i__2, &work[ki + n2], &c__1, &vl[ki + (is + 1) *
+ vl_dim1], &c__1);
+
+ emax = 0.f;
+ i__2 = *n;
+ for (k = ki; k <= i__2; ++k) {
+/* Computing MAX */
+ r__3 = emax, r__4 = (r__1 = vl[k + is * vl_dim1],
+ dabs(r__1)) + (r__2 = vl[k + (is + 1) *
+ vl_dim1], dabs(r__2));
+ emax = dmax(r__3,r__4);
+/* L220: */
+ }
+ remax = 1.f / emax;
+ i__2 = *n - ki + 1;
+ sscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1);
+ i__2 = *n - ki + 1;
+ sscal_(&i__2, &remax, &vl[ki + (is + 1) * vl_dim1], &c__1)
+ ;
+
+ i__2 = ki - 1;
+ for (k = 1; k <= i__2; ++k) {
+ vl[k + is * vl_dim1] = 0.f;
+ vl[k + (is + 1) * vl_dim1] = 0.f;
+/* L230: */
+ }
+ } else {
+ if (ki < *n - 1) {
+ i__2 = *n - ki - 1;
+ sgemv_("N", n, &i__2, &c_b22, &vl[(ki + 2) * vl_dim1
+ + 1], ldvl, &work[ki + 2 + *n], &c__1, &work[
+ ki + *n], &vl[ki * vl_dim1 + 1], &c__1);
+ i__2 = *n - ki - 1;
+ sgemv_("N", n, &i__2, &c_b22, &vl[(ki + 2) * vl_dim1
+ + 1], ldvl, &work[ki + 2 + n2], &c__1, &work[
+ ki + 1 + n2], &vl[(ki + 1) * vl_dim1 + 1], &
+ c__1);
+ } else {
+ sscal_(n, &work[ki + *n], &vl[ki * vl_dim1 + 1], &
+ c__1);
+ sscal_(n, &work[ki + 1 + n2], &vl[(ki + 1) * vl_dim1
+ + 1], &c__1);
+ }
+
+ emax = 0.f;
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+/* Computing MAX */
+ r__3 = emax, r__4 = (r__1 = vl[k + ki * vl_dim1],
+ dabs(r__1)) + (r__2 = vl[k + (ki + 1) *
+ vl_dim1], dabs(r__2));
+ emax = dmax(r__3,r__4);
+/* L240: */
+ }
+ remax = 1.f / emax;
+ sscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1);
+ sscal_(n, &remax, &vl[(ki + 1) * vl_dim1 + 1], &c__1);
+
+ }
+
+ }
+
+ ++is;
+ if (ip != 0) {
+ ++is;
+ }
+L250:
+ if (ip == -1) {
+ ip = 0;
+ }
+ if (ip == 1) {
+ ip = -1;
+ }
+
+/* L260: */
+ }
+
+ }
+
+ return 0;
+
+/* End of STREVC */
+
+} /* strevc_ */
diff --git a/SRC/strexc.c b/SRC/strexc.c
new file mode 100644
index 0000000..cc8c88f
--- /dev/null
+++ b/SRC/strexc.c
@@ -0,0 +1,403 @@
+/* strexc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int strexc_(char *compq, integer *n, real *t, integer *ldt,
+ real *q, integer *ldq, integer *ifst, integer *ilst, real *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, t_dim1, t_offset, i__1;
+
+ /* Local variables */
+ integer nbf, nbl, here;
+ extern logical lsame_(char *, char *);
+ logical wantq;
+ extern /* Subroutine */ int xerbla_(char *, integer *), slaexc_(
+ logical *, integer *, real *, integer *, real *, integer *,
+ integer *, integer *, integer *, real *, integer *);
+ integer nbnext;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STREXC reorders the real Schur factorization of a real matrix */
+/* A = Q*T*Q**T, so that the diagonal block of T with row index IFST is */
+/* moved to row ILST. */
+
+/* The real Schur form T is reordered by an orthogonal similarity */
+/* transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors */
+/* is updated by postmultiplying it with Z. */
+
+/* T must be in Schur canonical form (as returned by SHSEQR), that is, */
+/* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */
+/* 2-by-2 diagonal block has its diagonal elements equal and its */
+/* off-diagonal elements of opposite sign. */
+
+/* Arguments */
+/* ========= */
+
+/* COMPQ (input) CHARACTER*1 */
+/* = 'V': update the matrix Q of Schur vectors; */
+/* = 'N': do not update Q. */
+
+/* N (input) INTEGER */
+/* The order of the matrix T. N >= 0. */
+
+/* T (input/output) REAL array, dimension (LDT,N) */
+/* On entry, the upper quasi-triangular matrix T, in Schur */
+/* Schur canonical form. */
+/* On exit, the reordered upper quasi-triangular matrix, again */
+/* in Schur canonical form. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= max(1,N). */
+
+/* Q (input/output) REAL array, dimension (LDQ,N) */
+/* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */
+/* On exit, if COMPQ = 'V', Q has been postmultiplied by the */
+/* orthogonal transformation matrix Z which reorders T. */
+/* If COMPQ = 'N', Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* IFST (input/output) INTEGER */
+/* ILST (input/output) INTEGER */
+/* Specify the reordering of the diagonal blocks of T. */
+/* The block with row index IFST is moved to row ILST, by a */
+/* sequence of transpositions between adjacent blocks. */
+/* On exit, if IFST pointed on entry to the second row of a */
+/* 2-by-2 block, it is changed to point to the first row; ILST */
+/* always points to the first row of the block in its final */
+/* position (which may differ from its input value by +1 or -1). */
+/* 1 <= IFST <= N; 1 <= ILST <= N. */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* = 1: two adjacent blocks were too close to swap (the problem */
+/* is very ill-conditioned); T may have been partially */
+/* reordered, and ILST points to the first row of the */
+/* current position of the block being moved. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input arguments. */
+
+ /* Parameter adjustments */
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ wantq = lsame_(compq, "V");
+ if (! wantq && ! lsame_(compq, "N")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldt < max(1,*n)) {
+ *info = -4;
+ } else if (*ldq < 1 || wantq && *ldq < max(1,*n)) {
+ *info = -6;
+ } else if (*ifst < 1 || *ifst > *n) {
+ *info = -7;
+ } else if (*ilst < 1 || *ilst > *n) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STREXC", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 1) {
+ return 0;
+ }
+
+/* Determine the first row of specified block */
+/* and find out it is 1 by 1 or 2 by 2. */
+
+ if (*ifst > 1) {
+ if (t[*ifst + (*ifst - 1) * t_dim1] != 0.f) {
+ --(*ifst);
+ }
+ }
+ nbf = 1;
+ if (*ifst < *n) {
+ if (t[*ifst + 1 + *ifst * t_dim1] != 0.f) {
+ nbf = 2;
+ }
+ }
+
+/* Determine the first row of the final block */
+/* and find out it is 1 by 1 or 2 by 2. */
+
+ if (*ilst > 1) {
+ if (t[*ilst + (*ilst - 1) * t_dim1] != 0.f) {
+ --(*ilst);
+ }
+ }
+ nbl = 1;
+ if (*ilst < *n) {
+ if (t[*ilst + 1 + *ilst * t_dim1] != 0.f) {
+ nbl = 2;
+ }
+ }
+
+ if (*ifst == *ilst) {
+ return 0;
+ }
+
+ if (*ifst < *ilst) {
+
+/* Update ILST */
+
+ if (nbf == 2 && nbl == 1) {
+ --(*ilst);
+ }
+ if (nbf == 1 && nbl == 2) {
+ ++(*ilst);
+ }
+
+ here = *ifst;
+
+L10:
+
+/* Swap block with next one below */
+
+ if (nbf == 1 || nbf == 2) {
+
+/* Current block either 1 by 1 or 2 by 2 */
+
+ nbnext = 1;
+ if (here + nbf + 1 <= *n) {
+ if (t[here + nbf + 1 + (here + nbf) * t_dim1] != 0.f) {
+ nbnext = 2;
+ }
+ }
+ slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &here, &
+ nbf, &nbnext, &work[1], info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ here += nbnext;
+
+/* Test if 2 by 2 block breaks into two 1 by 1 blocks */
+
+ if (nbf == 2) {
+ if (t[here + 1 + here * t_dim1] == 0.f) {
+ nbf = 3;
+ }
+ }
+
+ } else {
+
+/* Current block consists of two 1 by 1 blocks each of which */
+/* must be swapped individually */
+
+ nbnext = 1;
+ if (here + 3 <= *n) {
+ if (t[here + 3 + (here + 2) * t_dim1] != 0.f) {
+ nbnext = 2;
+ }
+ }
+ i__1 = here + 1;
+ slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, &
+ c__1, &nbnext, &work[1], info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ if (nbnext == 1) {
+
+/* Swap two 1 by 1 blocks, no problems possible */
+
+ slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
+ here, &c__1, &nbnext, &work[1], info);
+ ++here;
+ } else {
+
+/* Recompute NBNEXT in case 2 by 2 split */
+
+ if (t[here + 2 + (here + 1) * t_dim1] == 0.f) {
+ nbnext = 1;
+ }
+ if (nbnext == 2) {
+
+/* 2 by 2 Block did not split */
+
+ slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
+ here, &c__1, &nbnext, &work[1], info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ here += 2;
+ } else {
+
+/* 2 by 2 Block did split */
+
+ slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
+ here, &c__1, &c__1, &work[1], info);
+ i__1 = here + 1;
+ slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
+ i__1, &c__1, &c__1, &work[1], info);
+ here += 2;
+ }
+ }
+ }
+ if (here < *ilst) {
+ goto L10;
+ }
+
+ } else {
+
+ here = *ifst;
+L20:
+
+/* Swap block with next one above */
+
+ if (nbf == 1 || nbf == 2) {
+
+/* Current block either 1 by 1 or 2 by 2 */
+
+ nbnext = 1;
+ if (here >= 3) {
+ if (t[here - 1 + (here - 2) * t_dim1] != 0.f) {
+ nbnext = 2;
+ }
+ }
+ i__1 = here - nbnext;
+ slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, &
+ nbnext, &nbf, &work[1], info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ here -= nbnext;
+
+/* Test if 2 by 2 block breaks into two 1 by 1 blocks */
+
+ if (nbf == 2) {
+ if (t[here + 1 + here * t_dim1] == 0.f) {
+ nbf = 3;
+ }
+ }
+
+ } else {
+
+/* Current block consists of two 1 by 1 blocks each of which */
+/* must be swapped individually */
+
+ nbnext = 1;
+ if (here >= 3) {
+ if (t[here - 1 + (here - 2) * t_dim1] != 0.f) {
+ nbnext = 2;
+ }
+ }
+ i__1 = here - nbnext;
+ slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, &
+ nbnext, &c__1, &work[1], info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ if (nbnext == 1) {
+
+/* Swap two 1 by 1 blocks, no problems possible */
+
+ slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
+ here, &nbnext, &c__1, &work[1], info);
+ --here;
+ } else {
+
+/* Recompute NBNEXT in case 2 by 2 split */
+
+ if (t[here + (here - 1) * t_dim1] == 0.f) {
+ nbnext = 1;
+ }
+ if (nbnext == 2) {
+
+/* 2 by 2 Block did not split */
+
+ i__1 = here - 1;
+ slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
+ i__1, &c__2, &c__1, &work[1], info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ here += -2;
+ } else {
+
+/* 2 by 2 Block did split */
+
+ slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
+ here, &c__1, &c__1, &work[1], info);
+ i__1 = here - 1;
+ slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
+ i__1, &c__1, &c__1, &work[1], info);
+ here += -2;
+ }
+ }
+ }
+ if (here > *ilst) {
+ goto L20;
+ }
+ }
+ *ilst = here;
+
+ return 0;
+
+/* End of STREXC */
+
+} /* strexc_ */
diff --git a/SRC/strrfs.c b/SRC/strrfs.c
new file mode 100644
index 0000000..b914b0e
--- /dev/null
+++ b/SRC/strrfs.c
@@ -0,0 +1,492 @@
+/* strrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b19 = -1.f;
+
+/* Subroutine */ int strrfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, real *a, integer *lda, real *b, integer *ldb, real *x,
+ integer *ldx, real *ferr, real *berr, real *work, integer *iwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2,
+ i__3;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ real s, xk;
+ integer nz;
+ real eps;
+ integer kase;
+ real safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), saxpy_(integer *, real *, real *, integer *, real *,
+ integer *), strmv_(char *, char *, char *, integer *, real *,
+ integer *, real *, integer *), strsv_(
+ char *, char *, char *, integer *, real *, integer *, real *,
+ integer *), slacn2_(integer *, real *,
+ real *, integer *, real *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+ char transt[1];
+ logical nounit;
+ real lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STRRFS provides error bounds and backward error estimates for the */
+/* solution to a system of linear equations with a triangular */
+/* coefficient matrix. */
+
+/* The solution matrix X must be computed by STRTRS or some other */
+/* means before entering this routine. STRRFS does not do iterative */
+/* refinement because doing so cannot improve the backward error. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) REAL array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STRRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.f;
+ berr[j] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transt = 'T';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = slamch_("Epsilon");
+ safmin = slamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A or A', depending on TRANS. */
+
+ scopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+ strmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1], &c__1);
+ saxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] = (r__1 = b[i__ + j * b_dim1], dabs(r__1));
+/* L20: */
+ }
+
+ if (notran) {
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+ i__3 = k;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ work[i__] += (r__1 = a[i__ + k * a_dim1], dabs(
+ r__1)) * xk;
+/* L30: */
+ }
+/* L40: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ work[i__] += (r__1 = a[i__ + k * a_dim1], dabs(
+ r__1)) * xk;
+/* L50: */
+ }
+ work[k] += xk;
+/* L60: */
+ }
+ }
+ } else {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ work[i__] += (r__1 = a[i__ + k * a_dim1], dabs(
+ r__1)) * xk;
+/* L70: */
+ }
+/* L80: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ xk = (r__1 = x[k + j * x_dim1], dabs(r__1));
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ work[i__] += (r__1 = a[i__ + k * a_dim1], dabs(
+ r__1)) * xk;
+/* L90: */
+ }
+ work[k] += xk;
+/* L100: */
+ }
+ }
+ }
+ } else {
+
+/* Compute abs(A')*abs(X) + abs(B). */
+
+ if (upper) {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__3 = k;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ s += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * (
+ r__2 = x[i__ + j * x_dim1], dabs(r__2));
+/* L110: */
+ }
+ work[k] += s;
+/* L120: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = (r__1 = x[k + j * x_dim1], dabs(r__1));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ s += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * (
+ r__2 = x[i__ + j * x_dim1], dabs(r__2));
+/* L130: */
+ }
+ work[k] += s;
+/* L140: */
+ }
+ }
+ } else {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.f;
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ s += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * (
+ r__2 = x[i__ + j * x_dim1], dabs(r__2));
+/* L150: */
+ }
+ work[k] += s;
+/* L160: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = (r__1 = x[k + j * x_dim1], dabs(r__1));
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ s += (r__1 = a[i__ + k * a_dim1], dabs(r__1)) * (
+ r__2 = x[i__ + j * x_dim1], dabs(r__2));
+/* L170: */
+ }
+ work[k] += s;
+/* L180: */
+ }
+ }
+ }
+ }
+ s = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+/* Computing MAX */
+ r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[
+ i__];
+ s = dmax(r__2,r__3);
+ } else {
+/* Computing MAX */
+ r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1)
+ / (work[i__] + safe1);
+ s = dmax(r__2,r__3);
+ }
+/* L190: */
+ }
+ berr[j] = s;
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use SLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (work[i__] > safe2) {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__];
+ } else {
+ work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
+ work[i__] + safe1;
+ }
+/* L200: */
+ }
+
+ kase = 0;
+L210:
+ slacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+ kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)'). */
+
+ strsv_(uplo, transt, diag, n, &a[a_offset], lda, &work[*n + 1]
+, &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L220: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = work[i__] * work[*n + i__];
+/* L230: */
+ }
+ strsv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1],
+ &c__1);
+ }
+ goto L210;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], dabs(r__1));
+ lstres = dmax(r__2,r__3);
+/* L240: */
+ }
+ if (lstres != 0.f) {
+ ferr[j] /= lstres;
+ }
+
+/* L250: */
+ }
+
+ return 0;
+
+/* End of STRRFS */
+
+} /* strrfs_ */
diff --git a/SRC/strsen.c b/SRC/strsen.c
new file mode 100644
index 0000000..8698273
--- /dev/null
+++ b/SRC/strsen.c
@@ -0,0 +1,530 @@
+/* strsen.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+
+/* Subroutine */ int strsen_(char *job, char *compq, logical *select, integer
+ *n, real *t, integer *ldt, real *q, integer *ldq, real *wr, real *wi,
+ integer *m, real *s, real *sep, real *work, integer *lwork, integer *
+ iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, t_dim1, t_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer k, n1, n2, kk, nn, ks;
+ real est;
+ integer kase;
+ logical pair;
+ integer ierr;
+ logical swap;
+ real scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3], lwmin;
+ logical wantq, wants;
+ real rnorm;
+ extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *,
+ real *, integer *, integer *);
+ extern doublereal slange_(char *, integer *, integer *, real *, integer *,
+ real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical wantbh;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+ integer liwmin;
+ extern /* Subroutine */ int strexc_(char *, integer *, real *, integer *,
+ real *, integer *, integer *, integer *, real *, integer *);
+ logical wantsp, lquery;
+ extern /* Subroutine */ int strsyl_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STRSEN reorders the real Schur factorization of a real matrix */
+/* A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in */
+/* the leading diagonal blocks of the upper quasi-triangular matrix T, */
+/* and the leading columns of Q form an orthonormal basis of the */
+/* corresponding right invariant subspace. */
+
+/* Optionally the routine computes the reciprocal condition numbers of */
+/* the cluster of eigenvalues and/or the invariant subspace. */
+
+/* T must be in Schur canonical form (as returned by SHSEQR), that is, */
+/* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */
+/* 2-by-2 diagonal block has its diagonal elemnts equal and its */
+/* off-diagonal elements of opposite sign. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies whether condition numbers are required for the */
+/* cluster of eigenvalues (S) or the invariant subspace (SEP): */
+/* = 'N': none; */
+/* = 'E': for eigenvalues only (S); */
+/* = 'V': for invariant subspace only (SEP); */
+/* = 'B': for both eigenvalues and invariant subspace (S and */
+/* SEP). */
+
+/* COMPQ (input) CHARACTER*1 */
+/* = 'V': update the matrix Q of Schur vectors; */
+/* = 'N': do not update Q. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* SELECT specifies the eigenvalues in the selected cluster. To */
+/* select a real eigenvalue w(j), SELECT(j) must be set to */
+/* .TRUE.. To select a complex conjugate pair of eigenvalues */
+/* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, */
+/* either SELECT(j) or SELECT(j+1) or both must be set to */
+/* .TRUE.; a complex conjugate pair of eigenvalues must be */
+/* either both included in the cluster or both excluded. */
+
+/* N (input) INTEGER */
+/* The order of the matrix T. N >= 0. */
+
+/* T (input/output) REAL array, dimension (LDT,N) */
+/* On entry, the upper quasi-triangular matrix T, in Schur */
+/* canonical form. */
+/* On exit, T is overwritten by the reordered matrix T, again in */
+/* Schur canonical form, with the selected eigenvalues in the */
+/* leading diagonal blocks. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= max(1,N). */
+
+/* Q (input/output) REAL array, dimension (LDQ,N) */
+/* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */
+/* On exit, if COMPQ = 'V', Q has been postmultiplied by the */
+/* orthogonal transformation matrix which reorders T; the */
+/* leading M columns of Q form an orthonormal basis for the */
+/* specified invariant subspace. */
+/* If COMPQ = 'N', Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. */
+/* LDQ >= 1; and if COMPQ = 'V', LDQ >= N. */
+
+/* WR (output) REAL array, dimension (N) */
+/* WI (output) REAL array, dimension (N) */
+/* The real and imaginary parts, respectively, of the reordered */
+/* eigenvalues of T. The eigenvalues are stored in the same */
+/* order as on the diagonal of T, with WR(i) = T(i,i) and, if */
+/* T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and */
+/* WI(i+1) = -WI(i). Note that if a complex eigenvalue is */
+/* sufficiently ill-conditioned, then its value may differ */
+/* significantly from its value before reordering. */
+
+/* M (output) INTEGER */
+/* The dimension of the specified invariant subspace. */
+/* 0 < = M <= N. */
+
+/* S (output) REAL */
+/* If JOB = 'E' or 'B', S is a lower bound on the reciprocal */
+/* condition number for the selected cluster of eigenvalues. */
+/* S cannot underestimate the true reciprocal condition number */
+/* by more than a factor of sqrt(N). If M = 0 or N, S = 1. */
+/* If JOB = 'N' or 'V', S is not referenced. */
+
+/* SEP (output) REAL */
+/* If JOB = 'V' or 'B', SEP is the estimated reciprocal */
+/* condition number of the specified invariant subspace. If */
+/* M = 0 or N, SEP = norm(T). */
+/* If JOB = 'N' or 'E', SEP is not referenced. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If JOB = 'N', LWORK >= max(1,N); */
+/* if JOB = 'E', LWORK >= max(1,M*(N-M)); */
+/* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)). */
+
+/* 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. */
+
+/* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If JOB = 'N' or 'E', LIWORK >= 1; */
+/* if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)). */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal size of the IWORK array, */
+/* returns this value as the first entry of the IWORK array, and */
+/* no error message related to LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* = 1: reordering of T failed because some eigenvalues are too */
+/* close to separate (the problem is very ill-conditioned); */
+/* T may have been partially reordered, and WR and WI */
+/* contain the eigenvalues in the same order as in T; S and */
+/* SEP (if requested) are set to zero. */
+
+/* Further Details */
+/* =============== */
+
+/* STRSEN first collects the selected eigenvalues by computing an */
+/* orthogonal transformation Z to move them to the top left corner of T. */
+/* In other words, the selected eigenvalues are the eigenvalues of T11 */
+/* in: */
+
+/* Z'*T*Z = ( T11 T12 ) n1 */
+/* ( 0 T22 ) n2 */
+/* n1 n2 */
+
+/* where N = n1+n2 and Z' means the transpose of Z. The first n1 columns */
+/* of Z span the specified invariant subspace of T. */
+
+/* If T has been obtained from the real Schur factorization of a matrix */
+/* A = Q*T*Q', then the reordered real Schur factorization of A is given */
+/* by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span */
+/* the corresponding invariant subspace of A. */
+
+/* The reciprocal condition number of the average of the eigenvalues of */
+/* T11 may be returned in S. S lies between 0 (very badly conditioned) */
+/* and 1 (very well conditioned). It is computed as follows. First we */
+/* compute R so that */
+
+/* P = ( I R ) n1 */
+/* ( 0 0 ) n2 */
+/* n1 n2 */
+
+/* is the projector on the invariant subspace associated with T11. */
+/* R is the solution of the Sylvester equation: */
+
+/* T11*R - R*T22 = T12. */
+
+/* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote */
+/* the two-norm of M. Then S is computed as the lower bound */
+
+/* (1 + F-norm(R)**2)**(-1/2) */
+
+/* on the reciprocal of 2-norm(P), the true reciprocal condition number. */
+/* S cannot underestimate 1 / 2-norm(P) by more than a factor of */
+/* sqrt(N). */
+
+/* An approximate error bound for the computed average of the */
+/* eigenvalues of T11 is */
+
+/* EPS * norm(T) / S */
+
+/* where EPS is the machine precision. */
+
+/* The reciprocal condition number of the right invariant subspace */
+/* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. */
+/* SEP is defined as the separation of T11 and T22: */
+
+/* sep( T11, T22 ) = sigma-min( C ) */
+
+/* where sigma-min(C) is the smallest singular value of the */
+/* n1*n2-by-n1*n2 matrix */
+
+/* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) */
+
+/* I(m) is an m by m identity matrix, and kprod denotes the Kronecker */
+/* product. We estimate sigma-min(C) by the reciprocal of an estimate of */
+/* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) */
+/* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2). */
+
+/* When SEP is small, small changes in T can cause large changes in */
+/* the invariant subspace. An approximate bound on the maximum angular */
+/* error in the computed right invariant subspace is */
+
+/* EPS * norm(T) / SEP */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ --select;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --wr;
+ --wi;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantbh = lsame_(job, "B");
+ wants = lsame_(job, "E") || wantbh;
+ wantsp = lsame_(job, "V") || wantbh;
+ wantq = lsame_(compq, "V");
+
+ *info = 0;
+ lquery = *lwork == -1;
+ if (! lsame_(job, "N") && ! wants && ! wantsp) {
+ *info = -1;
+ } else if (! lsame_(compq, "N") && ! wantq) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldt < max(1,*n)) {
+ *info = -6;
+ } else if (*ldq < 1 || wantq && *ldq < *n) {
+ *info = -8;
+ } else {
+
+/* Set M to the dimension of the specified invariant subspace, */
+/* and test LWORK and LIWORK. */
+
+ *m = 0;
+ pair = FALSE_;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (pair) {
+ pair = FALSE_;
+ } else {
+ if (k < *n) {
+ if (t[k + 1 + k * t_dim1] == 0.f) {
+ if (select[k]) {
+ ++(*m);
+ }
+ } else {
+ pair = TRUE_;
+ if (select[k] || select[k + 1]) {
+ *m += 2;
+ }
+ }
+ } else {
+ if (select[*n]) {
+ ++(*m);
+ }
+ }
+ }
+/* L10: */
+ }
+
+ n1 = *m;
+ n2 = *n - *m;
+ nn = n1 * n2;
+
+ if (wantsp) {
+/* Computing MAX */
+ i__1 = 1, i__2 = nn << 1;
+ lwmin = max(i__1,i__2);
+ liwmin = max(1,nn);
+ } else if (lsame_(job, "N")) {
+ lwmin = max(1,*n);
+ liwmin = 1;
+ } else if (lsame_(job, "E")) {
+ lwmin = max(1,nn);
+ liwmin = 1;
+ }
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -15;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -17;
+ }
+ }
+
+ if (*info == 0) {
+ work[1] = (real) lwmin;
+ iwork[1] = liwmin;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STRSEN", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == *n || *m == 0) {
+ if (wants) {
+ *s = 1.f;
+ }
+ if (wantsp) {
+ *sep = slange_("1", n, n, &t[t_offset], ldt, &work[1]);
+ }
+ goto L40;
+ }
+
+/* Collect the selected blocks at the top-left corner of T. */
+
+ ks = 0;
+ pair = FALSE_;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (pair) {
+ pair = FALSE_;
+ } else {
+ swap = select[k];
+ if (k < *n) {
+ if (t[k + 1 + k * t_dim1] != 0.f) {
+ pair = TRUE_;
+ swap = swap || select[k + 1];
+ }
+ }
+ if (swap) {
+ ++ks;
+
+/* Swap the K-th block to position KS. */
+
+ ierr = 0;
+ kk = k;
+ if (k != ks) {
+ strexc_(compq, n, &t[t_offset], ldt, &q[q_offset], ldq, &
+ kk, &ks, &work[1], &ierr);
+ }
+ if (ierr == 1 || ierr == 2) {
+
+/* Blocks too close to swap: exit. */
+
+ *info = 1;
+ if (wants) {
+ *s = 0.f;
+ }
+ if (wantsp) {
+ *sep = 0.f;
+ }
+ goto L40;
+ }
+ if (pair) {
+ ++ks;
+ }
+ }
+ }
+/* L20: */
+ }
+
+ if (wants) {
+
+/* Solve Sylvester equation for R: */
+
+/* T11*R - R*T22 = scale*T12 */
+
+ slacpy_("F", &n1, &n2, &t[(n1 + 1) * t_dim1 + 1], ldt, &work[1], &n1);
+ strsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1
+ + 1) * t_dim1], ldt, &work[1], &n1, &scale, &ierr);
+
+/* Estimate the reciprocal of the condition number of the cluster */
+/* of eigenvalues. */
+
+ rnorm = slange_("F", &n1, &n2, &work[1], &n1, &work[1]);
+ if (rnorm == 0.f) {
+ *s = 1.f;
+ } else {
+ *s = scale / (sqrt(scale * scale / rnorm + rnorm) * sqrt(rnorm));
+ }
+ }
+
+ if (wantsp) {
+
+/* Estimate sep(T11,T22). */
+
+ est = 0.f;
+ kase = 0;
+L30:
+ slacn2_(&nn, &work[nn + 1], &work[1], &iwork[1], &est, &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Solve T11*R - R*T22 = scale*X. */
+
+ strsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 +
+ 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &
+ ierr);
+ } else {
+
+/* Solve T11'*R - R*T22' = scale*X. */
+
+ strsyl_("T", "T", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 +
+ 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &
+ ierr);
+ }
+ goto L30;
+ }
+
+ *sep = scale / est;
+ }
+
+L40:
+
+/* Store the output eigenvalues in WR and WI. */
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ wr[k] = t[k + k * t_dim1];
+ wi[k] = 0.f;
+/* L50: */
+ }
+ i__1 = *n - 1;
+ for (k = 1; k <= i__1; ++k) {
+ if (t[k + 1 + k * t_dim1] != 0.f) {
+ wi[k] = sqrt((r__1 = t[k + (k + 1) * t_dim1], dabs(r__1))) * sqrt(
+ (r__2 = t[k + 1 + k * t_dim1], dabs(r__2)));
+ wi[k + 1] = -wi[k];
+ }
+/* L60: */
+ }
+
+ work[1] = (real) lwmin;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of STRSEN */
+
+} /* strsen_ */
diff --git a/SRC/strsna.c b/SRC/strsna.c
new file mode 100644
index 0000000..9631f4c
--- /dev/null
+++ b/SRC/strsna.c
@@ -0,0 +1,603 @@
+/* strsna.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int strsna_(char *job, char *howmny, logical *select,
+ integer *n, real *t, integer *ldt, real *vl, integer *ldvl, real *vr,
+ integer *ldvr, real *s, real *sep, integer *mm, integer *m, real *
+ work, integer *ldwork, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset,
+ work_dim1, work_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, n2;
+ real cs;
+ integer nn, ks;
+ real sn, mu, eps, est;
+ integer kase;
+ real cond;
+ logical pair;
+ integer ierr;
+ real dumm, prod;
+ integer ifst;
+ real lnrm;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ integer ilst;
+ real rnrm, prod1, prod2;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ real scale, delta;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical wants;
+ real dummy[1];
+ extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *,
+ real *, integer *, integer *);
+ extern doublereal slapy2_(real *, real *);
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ logical wantbh;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+ logical somcon;
+ extern /* Subroutine */ int slaqtr_(logical *, logical *, integer *, real
+ *, integer *, real *, real *, real *, real *, real *, integer *),
+ strexc_(char *, integer *, real *, integer *, real *, integer *,
+ integer *, integer *, real *, integer *);
+ real smlnum;
+ logical wantsp;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STRSNA estimates reciprocal condition numbers for specified */
+/* eigenvalues and/or right eigenvectors of a real upper */
+/* quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q */
+/* orthogonal). */
+
+/* T must be in Schur canonical form (as returned by SHSEQR), that is, */
+/* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */
+/* 2-by-2 diagonal block has its diagonal elements equal and its */
+/* off-diagonal elements of opposite sign. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies whether condition numbers are required for */
+/* eigenvalues (S) or eigenvectors (SEP): */
+/* = 'E': for eigenvalues only (S); */
+/* = 'V': for eigenvectors only (SEP); */
+/* = 'B': for both eigenvalues and eigenvectors (S and SEP). */
+
+/* HOWMNY (input) CHARACTER*1 */
+/* = 'A': compute condition numbers for all eigenpairs; */
+/* = 'S': compute condition numbers for selected eigenpairs */
+/* specified by the array SELECT. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* If HOWMNY = 'S', SELECT specifies the eigenpairs for which */
+/* condition numbers are required. To select condition numbers */
+/* for the eigenpair corresponding to a real eigenvalue w(j), */
+/* SELECT(j) must be set to .TRUE.. To select condition numbers */
+/* corresponding to a complex conjugate pair of eigenvalues w(j) */
+/* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be */
+/* set to .TRUE.. */
+/* If HOWMNY = 'A', SELECT is not referenced. */
+
+/* N (input) INTEGER */
+/* The order of the matrix T. N >= 0. */
+
+/* T (input) REAL array, dimension (LDT,N) */
+/* The upper quasi-triangular matrix T, in Schur canonical form. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= max(1,N). */
+
+/* VL (input) REAL array, dimension (LDVL,M) */
+/* If JOB = 'E' or 'B', VL must contain left eigenvectors of T */
+/* (or of any Q*T*Q**T with Q orthogonal), corresponding to the */
+/* eigenpairs specified by HOWMNY and SELECT. The eigenvectors */
+/* must be stored in consecutive columns of VL, as returned by */
+/* SHSEIN or STREVC. */
+/* If JOB = 'V', VL is not referenced. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. */
+/* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N. */
+
+/* VR (input) REAL array, dimension (LDVR,M) */
+/* If JOB = 'E' or 'B', VR must contain right eigenvectors of T */
+/* (or of any Q*T*Q**T with Q orthogonal), corresponding to the */
+/* eigenpairs specified by HOWMNY and SELECT. The eigenvectors */
+/* must be stored in consecutive columns of VR, as returned by */
+/* SHSEIN or STREVC. */
+/* If JOB = 'V', VR is not referenced. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. */
+/* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N. */
+
+/* S (output) REAL array, dimension (MM) */
+/* If JOB = 'E' or 'B', the reciprocal condition numbers of the */
+/* selected eigenvalues, stored in consecutive elements of the */
+/* array. For a complex conjugate pair of eigenvalues two */
+/* consecutive elements of S are set to the same value. Thus */
+/* S(j), SEP(j), and the j-th columns of VL and VR all */
+/* correspond to the same eigenpair (but not in general the */
+/* j-th eigenpair, unless all eigenpairs are selected). */
+/* If JOB = 'V', S is not referenced. */
+
+/* SEP (output) REAL array, dimension (MM) */
+/* If JOB = 'V' or 'B', the estimated reciprocal condition */
+/* numbers of the selected eigenvectors, stored in consecutive */
+/* elements of the array. For a complex eigenvector two */
+/* consecutive elements of SEP are set to the same value. If */
+/* the eigenvalues cannot be reordered to compute SEP(j), SEP(j) */
+/* is set to 0; this can only occur when the true value would be */
+/* very small anyway. */
+/* If JOB = 'E', SEP is not referenced. */
+
+/* MM (input) INTEGER */
+/* The number of elements in the arrays S (if JOB = 'E' or 'B') */
+/* and/or SEP (if JOB = 'V' or 'B'). MM >= M. */
+
+/* M (output) INTEGER */
+/* The number of elements of the arrays S and/or SEP actually */
+/* used to store the estimated condition numbers. */
+/* If HOWMNY = 'A', M is set to N. */
+
+/* WORK (workspace) REAL array, dimension (LDWORK,N+6) */
+/* If JOB = 'E', WORK is not referenced. */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. */
+/* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N. */
+
+/* IWORK (workspace) INTEGER array, dimension (2*(N-1)) */
+/* If JOB = 'E', IWORK is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The reciprocal of the condition number of an eigenvalue lambda is */
+/* defined as */
+
+/* S(lambda) = |v'*u| / (norm(u)*norm(v)) */
+
+/* where u and v are the right and left eigenvectors of T corresponding */
+/* to lambda; v' denotes the conjugate-transpose of v, and norm(u) */
+/* denotes the Euclidean norm. These reciprocal condition numbers always */
+/* lie between zero (very badly conditioned) and one (very well */
+/* conditioned). If n = 1, S(lambda) is defined to be 1. */
+
+/* An approximate error bound for a computed eigenvalue W(i) is given by */
+
+/* EPS * norm(T) / S(i) */
+
+/* where EPS is the machine precision. */
+
+/* The reciprocal of the condition number of the right eigenvector u */
+/* corresponding to lambda is defined as follows. Suppose */
+
+/* T = ( lambda c ) */
+/* ( 0 T22 ) */
+
+/* Then the reciprocal condition number is */
+
+/* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I ) */
+
+/* where sigma-min denotes the smallest singular value. We approximate */
+/* the smallest singular value by the reciprocal of an estimate of the */
+/* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is */
+/* defined to be abs(T(1,1)). */
+
+/* An approximate error bound for a computed right eigenvector VR(i) */
+/* is given by */
+
+/* EPS * norm(T) / SEP(i) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ --select;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --s;
+ --sep;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --iwork;
+
+ /* Function Body */
+ wantbh = lsame_(job, "B");
+ wants = lsame_(job, "E") || wantbh;
+ wantsp = lsame_(job, "V") || wantbh;
+
+ somcon = lsame_(howmny, "S");
+
+ *info = 0;
+ if (! wants && ! wantsp) {
+ *info = -1;
+ } else if (! lsame_(howmny, "A") && ! somcon) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldt < max(1,*n)) {
+ *info = -6;
+ } else if (*ldvl < 1 || wants && *ldvl < *n) {
+ *info = -8;
+ } else if (*ldvr < 1 || wants && *ldvr < *n) {
+ *info = -10;
+ } else {
+
+/* Set M to the number of eigenpairs for which condition numbers */
+/* are required, and test MM. */
+
+ if (somcon) {
+ *m = 0;
+ pair = FALSE_;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (pair) {
+ pair = FALSE_;
+ } else {
+ if (k < *n) {
+ if (t[k + 1 + k * t_dim1] == 0.f) {
+ if (select[k]) {
+ ++(*m);
+ }
+ } else {
+ pair = TRUE_;
+ if (select[k] || select[k + 1]) {
+ *m += 2;
+ }
+ }
+ } else {
+ if (select[*n]) {
+ ++(*m);
+ }
+ }
+ }
+/* L10: */
+ }
+ } else {
+ *m = *n;
+ }
+
+ if (*mm < *m) {
+ *info = -13;
+ } else if (*ldwork < 1 || wantsp && *ldwork < *n) {
+ *info = -16;
+ }
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STRSNA", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (somcon) {
+ if (! select[1]) {
+ return 0;
+ }
+ }
+ if (wants) {
+ s[1] = 1.f;
+ }
+ if (wantsp) {
+ sep[1] = (r__1 = t[t_dim1 + 1], dabs(r__1));
+ }
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S") / eps;
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+ ks = 0;
+ pair = FALSE_;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+/* Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block. */
+
+ if (pair) {
+ pair = FALSE_;
+ goto L60;
+ } else {
+ if (k < *n) {
+ pair = t[k + 1 + k * t_dim1] != 0.f;
+ }
+ }
+
+/* Determine whether condition numbers are required for the k-th */
+/* eigenpair. */
+
+ if (somcon) {
+ if (pair) {
+ if (! select[k] && ! select[k + 1]) {
+ goto L60;
+ }
+ } else {
+ if (! select[k]) {
+ goto L60;
+ }
+ }
+ }
+
+ ++ks;
+
+ if (wants) {
+
+/* Compute the reciprocal condition number of the k-th */
+/* eigenvalue. */
+
+ if (! pair) {
+
+/* Real eigenvalue. */
+
+ prod = sdot_(n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks *
+ vl_dim1 + 1], &c__1);
+ rnrm = snrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
+ lnrm = snrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
+ s[ks] = dabs(prod) / (rnrm * lnrm);
+ } else {
+
+/* Complex eigenvalue. */
+
+ prod1 = sdot_(n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks *
+ vl_dim1 + 1], &c__1);
+ prod1 += sdot_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1, &vl[(ks
+ + 1) * vl_dim1 + 1], &c__1);
+ prod2 = sdot_(n, &vl[ks * vl_dim1 + 1], &c__1, &vr[(ks + 1) *
+ vr_dim1 + 1], &c__1);
+ prod2 -= sdot_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1, &vr[ks *
+ vr_dim1 + 1], &c__1);
+ r__1 = snrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
+ r__2 = snrm2_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1);
+ rnrm = slapy2_(&r__1, &r__2);
+ r__1 = snrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
+ r__2 = snrm2_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1);
+ lnrm = slapy2_(&r__1, &r__2);
+ cond = slapy2_(&prod1, &prod2) / (rnrm * lnrm);
+ s[ks] = cond;
+ s[ks + 1] = cond;
+ }
+ }
+
+ if (wantsp) {
+
+/* Estimate the reciprocal condition number of the k-th */
+/* eigenvector. */
+
+/* Copy the matrix T to the array WORK and swap the diagonal */
+/* block beginning at T(k,k) to the (1,1) position. */
+
+ slacpy_("Full", n, n, &t[t_offset], ldt, &work[work_offset],
+ ldwork);
+ ifst = k;
+ ilst = 1;
+ strexc_("No Q", n, &work[work_offset], ldwork, dummy, &c__1, &
+ ifst, &ilst, &work[(*n + 1) * work_dim1 + 1], &ierr);
+
+ if (ierr == 1 || ierr == 2) {
+
+/* Could not swap because blocks not well separated */
+
+ scale = 1.f;
+ est = bignum;
+ } else {
+
+/* Reordering successful */
+
+ if (work[work_dim1 + 2] == 0.f) {
+
+/* Form C = T22 - lambda*I in WORK(2:N,2:N). */
+
+ i__2 = *n;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ work[i__ + i__ * work_dim1] -= work[work_dim1 + 1];
+/* L20: */
+ }
+ n2 = 1;
+ nn = *n - 1;
+ } else {
+
+/* Triangularize the 2 by 2 block by unitary */
+/* transformation U = [ cs i*ss ] */
+/* [ i*ss cs ]. */
+/* such that the (1,1) position of WORK is complex */
+/* eigenvalue lambda with positive imaginary part. (2,2) */
+/* position of WORK is the complex eigenvalue lambda */
+/* with negative imaginary part. */
+
+ mu = sqrt((r__1 = work[(work_dim1 << 1) + 1], dabs(r__1)))
+ * sqrt((r__2 = work[work_dim1 + 2], dabs(r__2)));
+ delta = slapy2_(&mu, &work[work_dim1 + 2]);
+ cs = mu / delta;
+ sn = -work[work_dim1 + 2] / delta;
+
+/* Form */
+
+/* C' = WORK(2:N,2:N) + i*[rwork(1) ..... rwork(n-1) ] */
+/* [ mu ] */
+/* [ .. ] */
+/* [ .. ] */
+/* [ mu ] */
+/* where C' is conjugate transpose of complex matrix C, */
+/* and RWORK is stored starting in the N+1-st column of */
+/* WORK. */
+
+ i__2 = *n;
+ for (j = 3; j <= i__2; ++j) {
+ work[j * work_dim1 + 2] = cs * work[j * work_dim1 + 2]
+ ;
+ work[j + j * work_dim1] -= work[work_dim1 + 1];
+/* L30: */
+ }
+ work[(work_dim1 << 1) + 2] = 0.f;
+
+ work[(*n + 1) * work_dim1 + 1] = mu * 2.f;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ work[i__ + (*n + 1) * work_dim1] = sn * work[(i__ + 1)
+ * work_dim1 + 1];
+/* L40: */
+ }
+ n2 = 2;
+ nn = *n - 1 << 1;
+ }
+
+/* Estimate norm(inv(C')) */
+
+ est = 0.f;
+ kase = 0;
+L50:
+ slacn2_(&nn, &work[(*n + 2) * work_dim1 + 1], &work[(*n + 4) *
+ work_dim1 + 1], &iwork[1], &est, &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+ if (n2 == 1) {
+
+/* Real eigenvalue: solve C'*x = scale*c. */
+
+ i__2 = *n - 1;
+ slaqtr_(&c_true, &c_true, &i__2, &work[(work_dim1
+ << 1) + 2], ldwork, dummy, &dumm, &scale,
+ &work[(*n + 4) * work_dim1 + 1], &work[(*
+ n + 6) * work_dim1 + 1], &ierr);
+ } else {
+
+/* Complex eigenvalue: solve */
+/* C'*(p+iq) = scale*(c+id) in real arithmetic. */
+
+ i__2 = *n - 1;
+ slaqtr_(&c_true, &c_false, &i__2, &work[(
+ work_dim1 << 1) + 2], ldwork, &work[(*n +
+ 1) * work_dim1 + 1], &mu, &scale, &work[(*
+ n + 4) * work_dim1 + 1], &work[(*n + 6) *
+ work_dim1 + 1], &ierr);
+ }
+ } else {
+ if (n2 == 1) {
+
+/* Real eigenvalue: solve C*x = scale*c. */
+
+ i__2 = *n - 1;
+ slaqtr_(&c_false, &c_true, &i__2, &work[(
+ work_dim1 << 1) + 2], ldwork, dummy, &
+ dumm, &scale, &work[(*n + 4) * work_dim1
+ + 1], &work[(*n + 6) * work_dim1 + 1], &
+ ierr);
+ } else {
+
+/* Complex eigenvalue: solve */
+/* C*(p+iq) = scale*(c+id) in real arithmetic. */
+
+ i__2 = *n - 1;
+ slaqtr_(&c_false, &c_false, &i__2, &work[(
+ work_dim1 << 1) + 2], ldwork, &work[(*n +
+ 1) * work_dim1 + 1], &mu, &scale, &work[(*
+ n + 4) * work_dim1 + 1], &work[(*n + 6) *
+ work_dim1 + 1], &ierr);
+
+ }
+ }
+
+ goto L50;
+ }
+ }
+
+ sep[ks] = scale / dmax(est,smlnum);
+ if (pair) {
+ sep[ks + 1] = sep[ks];
+ }
+ }
+
+ if (pair) {
+ ++ks;
+ }
+
+L60:
+ ;
+ }
+ return 0;
+
+/* End of STRSNA */
+
+} /* strsna_ */
diff --git a/SRC/strsyl.c b/SRC/strsyl.c
new file mode 100644
index 0000000..42a1b4c
--- /dev/null
+++ b/SRC/strsyl.c
@@ -0,0 +1,1316 @@
+/* strsyl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static logical c_false = FALSE_;
+static integer c__2 = 2;
+static real c_b26 = 1.f;
+static real c_b30 = 0.f;
+static logical c_true = TRUE_;
+
+/* Subroutine */ int strsyl_(char *trana, char *tranb, integer *isgn, integer
+ *m, integer *n, real *a, integer *lda, real *b, integer *ldb, real *
+ c__, integer *ldc, real *scale, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j, k, l;
+ real x[4] /* was [2][2] */;
+ integer k1, k2, l1, l2;
+ real a11, db, da11, vec[4] /* was [2][2] */, dum[1], eps, sgn;
+ integer ierr;
+ real smin;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ real suml, sumr;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ integer knext, lnext;
+ real xnorm;
+ extern /* Subroutine */ int slaln2_(logical *, integer *, integer *, real
+ *, real *, real *, integer *, real *, real *, real *, integer *,
+ real *, real *, real *, integer *, real *, real *, integer *),
+ slasy2_(logical *, logical *, integer *, integer *, integer *,
+ real *, integer *, real *, integer *, real *, integer *, real *,
+ real *, integer *, real *, integer *), slabad_(real *, real *);
+ real scaloc;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ logical notrna, notrnb;
+ real smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STRSYL solves the real Sylvester matrix equation: */
+
+/* op(A)*X + X*op(B) = scale*C or */
+/* op(A)*X - X*op(B) = scale*C, */
+
+/* where op(A) = A or A**T, and A and B are both upper quasi- */
+/* triangular. A is M-by-M and B is N-by-N; the right hand side C and */
+/* the solution X are M-by-N; and scale is an output scale factor, set */
+/* <= 1 to avoid overflow in X. */
+
+/* A and B must be in Schur canonical form (as returned by SHSEQR), that */
+/* is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; */
+/* each 2-by-2 diagonal block has its diagonal elements equal and its */
+/* off-diagonal elements of opposite sign. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANA (input) CHARACTER*1 */
+/* Specifies the option op(A): */
+/* = 'N': op(A) = A (No transpose) */
+/* = 'T': op(A) = A**T (Transpose) */
+/* = 'C': op(A) = A**H (Conjugate transpose = Transpose) */
+
+/* TRANB (input) CHARACTER*1 */
+/* Specifies the option op(B): */
+/* = 'N': op(B) = B (No transpose) */
+/* = 'T': op(B) = B**T (Transpose) */
+/* = 'C': op(B) = B**H (Conjugate transpose = Transpose) */
+
+/* ISGN (input) INTEGER */
+/* Specifies the sign in the equation: */
+/* = +1: solve op(A)*X + X*op(B) = scale*C */
+/* = -1: solve op(A)*X - X*op(B) = scale*C */
+
+/* M (input) INTEGER */
+/* The order of the matrix A, and the number of rows in the */
+/* matrices X and C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The order of the matrix B, and the number of columns in the */
+/* matrices X and C. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,M) */
+/* The upper quasi-triangular matrix A, in Schur canonical form. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input) REAL array, dimension (LDB,N) */
+/* The upper quasi-triangular matrix B, in Schur canonical form. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* C (input/output) REAL array, dimension (LDC,N) */
+/* On entry, the M-by-N right hand side matrix C. */
+/* On exit, C is overwritten by the solution matrix X. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M) */
+
+/* SCALE (output) REAL */
+/* The scale factor, scale, set <= 1 to avoid overflow in X. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* = 1: A and B have common or very close eigenvalues; perturbed */
+/* values were used to solve the equation (but the matrices */
+/* A and B are unchanged). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and Test input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ notrna = lsame_(trana, "N");
+ notrnb = lsame_(tranb, "N");
+
+ *info = 0;
+ if (! notrna && ! lsame_(trana, "T") && ! lsame_(
+ trana, "C")) {
+ *info = -1;
+ } else if (! notrnb && ! lsame_(tranb, "T") && !
+ lsame_(tranb, "C")) {
+ *info = -2;
+ } else if (*isgn != 1 && *isgn != -1) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*m)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldc < max(1,*m)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STRSYL", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *scale = 1.f;
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Set constants to control overflow */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ smlnum = smlnum * (real) (*m * *n) / eps;
+ bignum = 1.f / smlnum;
+
+/* Computing MAX */
+ r__1 = smlnum, r__2 = eps * slange_("M", m, m, &a[a_offset], lda, dum), r__1 = max(r__1,r__2), r__2 = eps * slange_("M", n, n,
+ &b[b_offset], ldb, dum);
+ smin = dmax(r__1,r__2);
+
+ sgn = (real) (*isgn);
+
+ if (notrna && notrnb) {
+
+/* Solve A*X + ISGN*X*B = scale*C. */
+
+/* The (K,L)th block of X is determined starting from */
+/* bottom-left corner column by column by */
+
+/* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */
+
+/* Where */
+/* M L-1 */
+/* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]. */
+/* I=K+1 J=1 */
+
+/* Start column loop (index = L) */
+/* L1 (L2) : column index of the first (first) row of X(K,L). */
+
+ lnext = 1;
+ i__1 = *n;
+ for (l = 1; l <= i__1; ++l) {
+ if (l < lnext) {
+ goto L70;
+ }
+ if (l == *n) {
+ l1 = l;
+ l2 = l;
+ } else {
+ if (b[l + 1 + l * b_dim1] != 0.f) {
+ l1 = l;
+ l2 = l + 1;
+ lnext = l + 2;
+ } else {
+ l1 = l;
+ l2 = l;
+ lnext = l + 1;
+ }
+ }
+
+/* Start row loop (index = K) */
+/* K1 (K2): row index of the first (last) row of X(K,L). */
+
+ knext = *m;
+ for (k = *m; k >= 1; --k) {
+ if (k > knext) {
+ goto L60;
+ }
+ if (k == 1) {
+ k1 = k;
+ k2 = k;
+ } else {
+ if (a[k + (k - 1) * a_dim1] != 0.f) {
+ k1 = k - 1;
+ k2 = k;
+ knext = k - 2;
+ } else {
+ k1 = k;
+ k2 = k;
+ knext = k - 1;
+ }
+ }
+
+ if (l1 == l2 && k1 == k2) {
+ i__2 = *m - k1;
+/* Computing MIN */
+ i__3 = k1 + 1;
+/* Computing MIN */
+ i__4 = k1 + 1;
+ suml = sdot_(&i__2, &a[k1 + min(i__3, *m)* a_dim1], lda, &
+ c__[min(i__4, *m)+ l1 * c_dim1], &c__1);
+ i__2 = l1 - 1;
+ sumr = sdot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+ scaloc = 1.f;
+
+ a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1];
+ da11 = dabs(a11);
+ if (da11 <= smin) {
+ a11 = smin;
+ da11 = smin;
+ *info = 1;
+ }
+ db = dabs(vec[0]);
+ if (da11 < 1.f && db > 1.f) {
+ if (db > bignum * da11) {
+ scaloc = 1.f / db;
+ }
+ }
+ x[0] = vec[0] * scaloc / a11;
+
+ if (scaloc != 1.f) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L10: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+
+ } else if (l1 == l2 && k1 != k2) {
+
+ i__2 = *m - k2;
+/* Computing MIN */
+ i__3 = k2 + 1;
+/* Computing MIN */
+ i__4 = k2 + 1;
+ suml = sdot_(&i__2, &a[k1 + min(i__3, *m)* a_dim1], lda, &
+ c__[min(i__4, *m)+ l1 * c_dim1], &c__1);
+ i__2 = l1 - 1;
+ sumr = sdot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__2 = *m - k2;
+/* Computing MIN */
+ i__3 = k2 + 1;
+/* Computing MIN */
+ i__4 = k2 + 1;
+ suml = sdot_(&i__2, &a[k2 + min(i__3, *m)* a_dim1], lda, &
+ c__[min(i__4, *m)+ l1 * c_dim1], &c__1);
+ i__2 = l1 - 1;
+ sumr = sdot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ r__1 = -sgn * b[l1 + l1 * b_dim1];
+ slaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1
+ * a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &r__1,
+ &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.f) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L20: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k2 + l1 * c_dim1] = x[1];
+
+ } else if (l1 != l2 && k1 == k2) {
+
+ i__2 = *m - k1;
+/* Computing MIN */
+ i__3 = k1 + 1;
+/* Computing MIN */
+ i__4 = k1 + 1;
+ suml = sdot_(&i__2, &a[k1 + min(i__3, *m)* a_dim1], lda, &
+ c__[min(i__4, *m)+ l1 * c_dim1], &c__1);
+ i__2 = l1 - 1;
+ sumr = sdot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn *
+ sumr));
+
+ i__2 = *m - k1;
+/* Computing MIN */
+ i__3 = k1 + 1;
+/* Computing MIN */
+ i__4 = k1 + 1;
+ suml = sdot_(&i__2, &a[k1 + min(i__3, *m)* a_dim1], lda, &
+ c__[min(i__4, *m)+ l2 * c_dim1], &c__1);
+ i__2 = l1 - 1;
+ sumr = sdot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l2 *
+ b_dim1 + 1], &c__1);
+ vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn *
+ sumr));
+
+ r__1 = -sgn * a[k1 + k1 * a_dim1];
+ slaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 *
+ b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &r__1,
+ &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.f) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L40: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k1 + l2 * c_dim1] = x[1];
+
+ } else if (l1 != l2 && k1 != k2) {
+
+ i__2 = *m - k2;
+/* Computing MIN */
+ i__3 = k2 + 1;
+/* Computing MIN */
+ i__4 = k2 + 1;
+ suml = sdot_(&i__2, &a[k1 + min(i__3, *m)* a_dim1], lda, &
+ c__[min(i__4, *m)+ l1 * c_dim1], &c__1);
+ i__2 = l1 - 1;
+ sumr = sdot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__2 = *m - k2;
+/* Computing MIN */
+ i__3 = k2 + 1;
+/* Computing MIN */
+ i__4 = k2 + 1;
+ suml = sdot_(&i__2, &a[k1 + min(i__3, *m)* a_dim1], lda, &
+ c__[min(i__4, *m)+ l2 * c_dim1], &c__1);
+ i__2 = l1 - 1;
+ sumr = sdot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l2 *
+ b_dim1 + 1], &c__1);
+ vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr);
+
+ i__2 = *m - k2;
+/* Computing MIN */
+ i__3 = k2 + 1;
+/* Computing MIN */
+ i__4 = k2 + 1;
+ suml = sdot_(&i__2, &a[k2 + min(i__3, *m)* a_dim1], lda, &
+ c__[min(i__4, *m)+ l1 * c_dim1], &c__1);
+ i__2 = l1 - 1;
+ sumr = sdot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__2 = *m - k2;
+/* Computing MIN */
+ i__3 = k2 + 1;
+/* Computing MIN */
+ i__4 = k2 + 1;
+ suml = sdot_(&i__2, &a[k2 + min(i__3, *m)* a_dim1], lda, &
+ c__[min(i__4, *m)+ l2 * c_dim1], &c__1);
+ i__2 = l1 - 1;
+ sumr = sdot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l2 *
+ b_dim1 + 1], &c__1);
+ vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr);
+
+ slasy2_(&c_false, &c_false, isgn, &c__2, &c__2, &a[k1 +
+ k1 * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec,
+ &c__2, &scaloc, x, &c__2, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.f) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L50: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k1 + l2 * c_dim1] = x[2];
+ c__[k2 + l1 * c_dim1] = x[1];
+ c__[k2 + l2 * c_dim1] = x[3];
+ }
+
+L60:
+ ;
+ }
+
+L70:
+ ;
+ }
+
+ } else if (! notrna && notrnb) {
+
+/* Solve A' *X + ISGN*X*B = scale*C. */
+
+/* The (K,L)th block of X is determined starting from */
+/* upper-left corner column by column by */
+
+/* A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */
+
+/* Where */
+/* K-1 L-1 */
+/* R(K,L) = SUM [A(I,K)'*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)] */
+/* I=1 J=1 */
+
+/* Start column loop (index = L) */
+/* L1 (L2): column index of the first (last) row of X(K,L) */
+
+ lnext = 1;
+ i__1 = *n;
+ for (l = 1; l <= i__1; ++l) {
+ if (l < lnext) {
+ goto L130;
+ }
+ if (l == *n) {
+ l1 = l;
+ l2 = l;
+ } else {
+ if (b[l + 1 + l * b_dim1] != 0.f) {
+ l1 = l;
+ l2 = l + 1;
+ lnext = l + 2;
+ } else {
+ l1 = l;
+ l2 = l;
+ lnext = l + 1;
+ }
+ }
+
+/* Start row loop (index = K) */
+/* K1 (K2): row index of the first (last) row of X(K,L) */
+
+ knext = 1;
+ i__2 = *m;
+ for (k = 1; k <= i__2; ++k) {
+ if (k < knext) {
+ goto L120;
+ }
+ if (k == *m) {
+ k1 = k;
+ k2 = k;
+ } else {
+ if (a[k + 1 + k * a_dim1] != 0.f) {
+ k1 = k;
+ k2 = k + 1;
+ knext = k + 2;
+ } else {
+ k1 = k;
+ k2 = k;
+ knext = k + 1;
+ }
+ }
+
+ if (l1 == l2 && k1 == k2) {
+ i__3 = k1 - 1;
+ suml = sdot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__3 = l1 - 1;
+ sumr = sdot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+ scaloc = 1.f;
+
+ a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1];
+ da11 = dabs(a11);
+ if (da11 <= smin) {
+ a11 = smin;
+ da11 = smin;
+ *info = 1;
+ }
+ db = dabs(vec[0]);
+ if (da11 < 1.f && db > 1.f) {
+ if (db > bignum * da11) {
+ scaloc = 1.f / db;
+ }
+ }
+ x[0] = vec[0] * scaloc / a11;
+
+ if (scaloc != 1.f) {
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L80: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+
+ } else if (l1 == l2 && k1 != k2) {
+
+ i__3 = k1 - 1;
+ suml = sdot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__3 = l1 - 1;
+ sumr = sdot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__3 = k1 - 1;
+ suml = sdot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__3 = l1 - 1;
+ sumr = sdot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ r__1 = -sgn * b[l1 + l1 * b_dim1];
+ slaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 *
+ a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &r__1,
+ &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.f) {
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L90: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k2 + l1 * c_dim1] = x[1];
+
+ } else if (l1 != l2 && k1 == k2) {
+
+ i__3 = k1 - 1;
+ suml = sdot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__3 = l1 - 1;
+ sumr = sdot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn *
+ sumr));
+
+ i__3 = k1 - 1;
+ suml = sdot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 *
+ c_dim1 + 1], &c__1);
+ i__3 = l1 - 1;
+ sumr = sdot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l2 *
+ b_dim1 + 1], &c__1);
+ vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn *
+ sumr));
+
+ r__1 = -sgn * a[k1 + k1 * a_dim1];
+ slaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 *
+ b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &r__1,
+ &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.f) {
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L100: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k1 + l2 * c_dim1] = x[1];
+
+ } else if (l1 != l2 && k1 != k2) {
+
+ i__3 = k1 - 1;
+ suml = sdot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__3 = l1 - 1;
+ sumr = sdot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__3 = k1 - 1;
+ suml = sdot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 *
+ c_dim1 + 1], &c__1);
+ i__3 = l1 - 1;
+ sumr = sdot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l2 *
+ b_dim1 + 1], &c__1);
+ vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr);
+
+ i__3 = k1 - 1;
+ suml = sdot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__3 = l1 - 1;
+ sumr = sdot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l1 *
+ b_dim1 + 1], &c__1);
+ vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__3 = k1 - 1;
+ suml = sdot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l2 *
+ c_dim1 + 1], &c__1);
+ i__3 = l1 - 1;
+ sumr = sdot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l2 *
+ b_dim1 + 1], &c__1);
+ vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr);
+
+ slasy2_(&c_true, &c_false, isgn, &c__2, &c__2, &a[k1 + k1
+ * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, &
+ c__2, &scaloc, x, &c__2, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.f) {
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L110: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k1 + l2 * c_dim1] = x[2];
+ c__[k2 + l1 * c_dim1] = x[1];
+ c__[k2 + l2 * c_dim1] = x[3];
+ }
+
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+
+ } else if (! notrna && ! notrnb) {
+
+/* Solve A'*X + ISGN*X*B' = scale*C. */
+
+/* The (K,L)th block of X is determined starting from */
+/* top-right corner column by column by */
+
+/* A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L) */
+
+/* Where */
+/* K-1 N */
+/* R(K,L) = SUM [A(I,K)'*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)']. */
+/* I=1 J=L+1 */
+
+/* Start column loop (index = L) */
+/* L1 (L2): column index of the first (last) row of X(K,L) */
+
+ lnext = *n;
+ for (l = *n; l >= 1; --l) {
+ if (l > lnext) {
+ goto L190;
+ }
+ if (l == 1) {
+ l1 = l;
+ l2 = l;
+ } else {
+ if (b[l + (l - 1) * b_dim1] != 0.f) {
+ l1 = l - 1;
+ l2 = l;
+ lnext = l - 2;
+ } else {
+ l1 = l;
+ l2 = l;
+ lnext = l - 1;
+ }
+ }
+
+/* Start row loop (index = K) */
+/* K1 (K2): row index of the first (last) row of X(K,L) */
+
+ knext = 1;
+ i__1 = *m;
+ for (k = 1; k <= i__1; ++k) {
+ if (k < knext) {
+ goto L180;
+ }
+ if (k == *m) {
+ k1 = k;
+ k2 = k;
+ } else {
+ if (a[k + 1 + k * a_dim1] != 0.f) {
+ k1 = k;
+ k2 = k + 1;
+ knext = k + 2;
+ } else {
+ k1 = k;
+ k2 = k;
+ knext = k + 1;
+ }
+ }
+
+ if (l1 == l2 && k1 == k2) {
+ i__2 = k1 - 1;
+ suml = sdot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__2 = *n - l1;
+/* Computing MIN */
+ i__3 = l1 + 1;
+/* Computing MIN */
+ i__4 = l1 + 1;
+ sumr = sdot_(&i__2, &c__[k1 + min(i__3, *n)* c_dim1], ldc,
+ &b[l1 + min(i__4, *n)* b_dim1], ldb);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+ scaloc = 1.f;
+
+ a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1];
+ da11 = dabs(a11);
+ if (da11 <= smin) {
+ a11 = smin;
+ da11 = smin;
+ *info = 1;
+ }
+ db = dabs(vec[0]);
+ if (da11 < 1.f && db > 1.f) {
+ if (db > bignum * da11) {
+ scaloc = 1.f / db;
+ }
+ }
+ x[0] = vec[0] * scaloc / a11;
+
+ if (scaloc != 1.f) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L140: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+
+ } else if (l1 == l2 && k1 != k2) {
+
+ i__2 = k1 - 1;
+ suml = sdot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__2 = *n - l2;
+/* Computing MIN */
+ i__3 = l2 + 1;
+/* Computing MIN */
+ i__4 = l2 + 1;
+ sumr = sdot_(&i__2, &c__[k1 + min(i__3, *n)* c_dim1], ldc,
+ &b[l1 + min(i__4, *n)* b_dim1], ldb);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__2 = k1 - 1;
+ suml = sdot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__2 = *n - l2;
+/* Computing MIN */
+ i__3 = l2 + 1;
+/* Computing MIN */
+ i__4 = l2 + 1;
+ sumr = sdot_(&i__2, &c__[k2 + min(i__3, *n)* c_dim1], ldc,
+ &b[l1 + min(i__4, *n)* b_dim1], ldb);
+ vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ r__1 = -sgn * b[l1 + l1 * b_dim1];
+ slaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 *
+ a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &r__1,
+ &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.f) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L150: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k2 + l1 * c_dim1] = x[1];
+
+ } else if (l1 != l2 && k1 == k2) {
+
+ i__2 = k1 - 1;
+ suml = sdot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__2 = *n - l2;
+/* Computing MIN */
+ i__3 = l2 + 1;
+/* Computing MIN */
+ i__4 = l2 + 1;
+ sumr = sdot_(&i__2, &c__[k1 + min(i__3, *n)* c_dim1], ldc,
+ &b[l1 + min(i__4, *n)* b_dim1], ldb);
+ vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn *
+ sumr));
+
+ i__2 = k1 - 1;
+ suml = sdot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 *
+ c_dim1 + 1], &c__1);
+ i__2 = *n - l2;
+/* Computing MIN */
+ i__3 = l2 + 1;
+/* Computing MIN */
+ i__4 = l2 + 1;
+ sumr = sdot_(&i__2, &c__[k1 + min(i__3, *n)* c_dim1], ldc,
+ &b[l2 + min(i__4, *n)* b_dim1], ldb);
+ vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn *
+ sumr));
+
+ r__1 = -sgn * a[k1 + k1 * a_dim1];
+ slaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1
+ * b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &r__1,
+ &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.f) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L160: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k1 + l2 * c_dim1] = x[1];
+
+ } else if (l1 != l2 && k1 != k2) {
+
+ i__2 = k1 - 1;
+ suml = sdot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__2 = *n - l2;
+/* Computing MIN */
+ i__3 = l2 + 1;
+/* Computing MIN */
+ i__4 = l2 + 1;
+ sumr = sdot_(&i__2, &c__[k1 + min(i__3, *n)* c_dim1], ldc,
+ &b[l1 + min(i__4, *n)* b_dim1], ldb);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__2 = k1 - 1;
+ suml = sdot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 *
+ c_dim1 + 1], &c__1);
+ i__2 = *n - l2;
+/* Computing MIN */
+ i__3 = l2 + 1;
+/* Computing MIN */
+ i__4 = l2 + 1;
+ sumr = sdot_(&i__2, &c__[k1 + min(i__3, *n)* c_dim1], ldc,
+ &b[l2 + min(i__4, *n)* b_dim1], ldb);
+ vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr);
+
+ i__2 = k1 - 1;
+ suml = sdot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 *
+ c_dim1 + 1], &c__1);
+ i__2 = *n - l2;
+/* Computing MIN */
+ i__3 = l2 + 1;
+/* Computing MIN */
+ i__4 = l2 + 1;
+ sumr = sdot_(&i__2, &c__[k2 + min(i__3, *n)* c_dim1], ldc,
+ &b[l1 + min(i__4, *n)* b_dim1], ldb);
+ vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__2 = k1 - 1;
+ suml = sdot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l2 *
+ c_dim1 + 1], &c__1);
+ i__2 = *n - l2;
+/* Computing MIN */
+ i__3 = l2 + 1;
+/* Computing MIN */
+ i__4 = l2 + 1;
+ sumr = sdot_(&i__2, &c__[k2 + min(i__3, *n)* c_dim1], ldc,
+ &b[l2 + min(i__4, *n)* b_dim1], ldb);
+ vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr);
+
+ slasy2_(&c_true, &c_true, isgn, &c__2, &c__2, &a[k1 + k1 *
+ a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, &
+ c__2, &scaloc, x, &c__2, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.f) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L170: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k1 + l2 * c_dim1] = x[2];
+ c__[k2 + l1 * c_dim1] = x[1];
+ c__[k2 + l2 * c_dim1] = x[3];
+ }
+
+L180:
+ ;
+ }
+L190:
+ ;
+ }
+
+ } else if (notrna && ! notrnb) {
+
+/* Solve A*X + ISGN*X*B' = scale*C. */
+
+/* The (K,L)th block of X is determined starting from */
+/* bottom-right corner column by column by */
+
+/* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L) */
+
+/* Where */
+/* M N */
+/* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)']. */
+/* I=K+1 J=L+1 */
+
+/* Start column loop (index = L) */
+/* L1 (L2): column index of the first (last) row of X(K,L) */
+
+ lnext = *n;
+ for (l = *n; l >= 1; --l) {
+ if (l > lnext) {
+ goto L250;
+ }
+ if (l == 1) {
+ l1 = l;
+ l2 = l;
+ } else {
+ if (b[l + (l - 1) * b_dim1] != 0.f) {
+ l1 = l - 1;
+ l2 = l;
+ lnext = l - 2;
+ } else {
+ l1 = l;
+ l2 = l;
+ lnext = l - 1;
+ }
+ }
+
+/* Start row loop (index = K) */
+/* K1 (K2): row index of the first (last) row of X(K,L) */
+
+ knext = *m;
+ for (k = *m; k >= 1; --k) {
+ if (k > knext) {
+ goto L240;
+ }
+ if (k == 1) {
+ k1 = k;
+ k2 = k;
+ } else {
+ if (a[k + (k - 1) * a_dim1] != 0.f) {
+ k1 = k - 1;
+ k2 = k;
+ knext = k - 2;
+ } else {
+ k1 = k;
+ k2 = k;
+ knext = k - 1;
+ }
+ }
+
+ if (l1 == l2 && k1 == k2) {
+ i__1 = *m - k1;
+/* Computing MIN */
+ i__2 = k1 + 1;
+/* Computing MIN */
+ i__3 = k1 + 1;
+ suml = sdot_(&i__1, &a[k1 + min(i__2, *m)* a_dim1], lda, &
+ c__[min(i__3, *m)+ l1 * c_dim1], &c__1);
+ i__1 = *n - l1;
+/* Computing MIN */
+ i__2 = l1 + 1;
+/* Computing MIN */
+ i__3 = l1 + 1;
+ sumr = sdot_(&i__1, &c__[k1 + min(i__2, *n)* c_dim1], ldc,
+ &b[l1 + min(i__3, *n)* b_dim1], ldb);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+ scaloc = 1.f;
+
+ a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1];
+ da11 = dabs(a11);
+ if (da11 <= smin) {
+ a11 = smin;
+ da11 = smin;
+ *info = 1;
+ }
+ db = dabs(vec[0]);
+ if (da11 < 1.f && db > 1.f) {
+ if (db > bignum * da11) {
+ scaloc = 1.f / db;
+ }
+ }
+ x[0] = vec[0] * scaloc / a11;
+
+ if (scaloc != 1.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L200: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+
+ } else if (l1 == l2 && k1 != k2) {
+
+ i__1 = *m - k2;
+/* Computing MIN */
+ i__2 = k2 + 1;
+/* Computing MIN */
+ i__3 = k2 + 1;
+ suml = sdot_(&i__1, &a[k1 + min(i__2, *m)* a_dim1], lda, &
+ c__[min(i__3, *m)+ l1 * c_dim1], &c__1);
+ i__1 = *n - l2;
+/* Computing MIN */
+ i__2 = l2 + 1;
+/* Computing MIN */
+ i__3 = l2 + 1;
+ sumr = sdot_(&i__1, &c__[k1 + min(i__2, *n)* c_dim1], ldc,
+ &b[l1 + min(i__3, *n)* b_dim1], ldb);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__1 = *m - k2;
+/* Computing MIN */
+ i__2 = k2 + 1;
+/* Computing MIN */
+ i__3 = k2 + 1;
+ suml = sdot_(&i__1, &a[k2 + min(i__2, *m)* a_dim1], lda, &
+ c__[min(i__3, *m)+ l1 * c_dim1], &c__1);
+ i__1 = *n - l2;
+/* Computing MIN */
+ i__2 = l2 + 1;
+/* Computing MIN */
+ i__3 = l2 + 1;
+ sumr = sdot_(&i__1, &c__[k2 + min(i__2, *n)* c_dim1], ldc,
+ &b[l1 + min(i__3, *n)* b_dim1], ldb);
+ vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ r__1 = -sgn * b[l1 + l1 * b_dim1];
+ slaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1
+ * a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &r__1,
+ &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L210: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k2 + l1 * c_dim1] = x[1];
+
+ } else if (l1 != l2 && k1 == k2) {
+
+ i__1 = *m - k1;
+/* Computing MIN */
+ i__2 = k1 + 1;
+/* Computing MIN */
+ i__3 = k1 + 1;
+ suml = sdot_(&i__1, &a[k1 + min(i__2, *m)* a_dim1], lda, &
+ c__[min(i__3, *m)+ l1 * c_dim1], &c__1);
+ i__1 = *n - l2;
+/* Computing MIN */
+ i__2 = l2 + 1;
+/* Computing MIN */
+ i__3 = l2 + 1;
+ sumr = sdot_(&i__1, &c__[k1 + min(i__2, *n)* c_dim1], ldc,
+ &b[l1 + min(i__3, *n)* b_dim1], ldb);
+ vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn *
+ sumr));
+
+ i__1 = *m - k1;
+/* Computing MIN */
+ i__2 = k1 + 1;
+/* Computing MIN */
+ i__3 = k1 + 1;
+ suml = sdot_(&i__1, &a[k1 + min(i__2, *m)* a_dim1], lda, &
+ c__[min(i__3, *m)+ l2 * c_dim1], &c__1);
+ i__1 = *n - l2;
+/* Computing MIN */
+ i__2 = l2 + 1;
+/* Computing MIN */
+ i__3 = l2 + 1;
+ sumr = sdot_(&i__1, &c__[k1 + min(i__2, *n)* c_dim1], ldc,
+ &b[l2 + min(i__3, *n)* b_dim1], ldb);
+ vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn *
+ sumr));
+
+ r__1 = -sgn * a[k1 + k1 * a_dim1];
+ slaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1
+ * b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &r__1,
+ &c_b30, x, &c__2, &scaloc, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L220: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k1 + l2 * c_dim1] = x[1];
+
+ } else if (l1 != l2 && k1 != k2) {
+
+ i__1 = *m - k2;
+/* Computing MIN */
+ i__2 = k2 + 1;
+/* Computing MIN */
+ i__3 = k2 + 1;
+ suml = sdot_(&i__1, &a[k1 + min(i__2, *m)* a_dim1], lda, &
+ c__[min(i__3, *m)+ l1 * c_dim1], &c__1);
+ i__1 = *n - l2;
+/* Computing MIN */
+ i__2 = l2 + 1;
+/* Computing MIN */
+ i__3 = l2 + 1;
+ sumr = sdot_(&i__1, &c__[k1 + min(i__2, *n)* c_dim1], ldc,
+ &b[l1 + min(i__3, *n)* b_dim1], ldb);
+ vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__1 = *m - k2;
+/* Computing MIN */
+ i__2 = k2 + 1;
+/* Computing MIN */
+ i__3 = k2 + 1;
+ suml = sdot_(&i__1, &a[k1 + min(i__2, *m)* a_dim1], lda, &
+ c__[min(i__3, *m)+ l2 * c_dim1], &c__1);
+ i__1 = *n - l2;
+/* Computing MIN */
+ i__2 = l2 + 1;
+/* Computing MIN */
+ i__3 = l2 + 1;
+ sumr = sdot_(&i__1, &c__[k1 + min(i__2, *n)* c_dim1], ldc,
+ &b[l2 + min(i__3, *n)* b_dim1], ldb);
+ vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr);
+
+ i__1 = *m - k2;
+/* Computing MIN */
+ i__2 = k2 + 1;
+/* Computing MIN */
+ i__3 = k2 + 1;
+ suml = sdot_(&i__1, &a[k2 + min(i__2, *m)* a_dim1], lda, &
+ c__[min(i__3, *m)+ l1 * c_dim1], &c__1);
+ i__1 = *n - l2;
+/* Computing MIN */
+ i__2 = l2 + 1;
+/* Computing MIN */
+ i__3 = l2 + 1;
+ sumr = sdot_(&i__1, &c__[k2 + min(i__2, *n)* c_dim1], ldc,
+ &b[l1 + min(i__3, *n)* b_dim1], ldb);
+ vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr);
+
+ i__1 = *m - k2;
+/* Computing MIN */
+ i__2 = k2 + 1;
+/* Computing MIN */
+ i__3 = k2 + 1;
+ suml = sdot_(&i__1, &a[k2 + min(i__2, *m)* a_dim1], lda, &
+ c__[min(i__3, *m)+ l2 * c_dim1], &c__1);
+ i__1 = *n - l2;
+/* Computing MIN */
+ i__2 = l2 + 1;
+/* Computing MIN */
+ i__3 = l2 + 1;
+ sumr = sdot_(&i__1, &c__[k2 + min(i__2, *n)* c_dim1], ldc,
+ &b[l2 + min(i__3, *n)* b_dim1], ldb);
+ vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr);
+
+ slasy2_(&c_false, &c_true, isgn, &c__2, &c__2, &a[k1 + k1
+ * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, &
+ c__2, &scaloc, x, &c__2, &xnorm, &ierr);
+ if (ierr != 0) {
+ *info = 1;
+ }
+
+ if (scaloc != 1.f) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L230: */
+ }
+ *scale *= scaloc;
+ }
+ c__[k1 + l1 * c_dim1] = x[0];
+ c__[k1 + l2 * c_dim1] = x[2];
+ c__[k2 + l1 * c_dim1] = x[1];
+ c__[k2 + l2 * c_dim1] = x[3];
+ }
+
+L240:
+ ;
+ }
+L250:
+ ;
+ }
+
+ }
+
+ return 0;
+
+/* End of STRSYL */
+
+} /* strsyl_ */
diff --git a/SRC/strti2.c b/SRC/strti2.c
new file mode 100644
index 0000000..e8edd48
--- /dev/null
+++ b/SRC/strti2.c
@@ -0,0 +1,183 @@
+/* strti2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int strti2_(char *uplo, char *diag, integer *n, real *a,
+ integer *lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer j;
+ real ajj;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ logical upper;
+ extern /* Subroutine */ int strmv_(char *, char *, char *, integer *,
+ real *, integer *, real *, integer *),
+ xerbla_(char *, integer *);
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STRTI2 computes the inverse of a real upper or lower triangular */
+/* matrix. */
+
+/* This is the Level 2 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the triangular matrix A. If UPLO = 'U', the */
+/* leading n by n upper triangular part of the array A contains */
+/* the upper triangular matrix, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n by n lower triangular part of the array A contains */
+/* the lower triangular matrix, and the strictly upper */
+/* triangular part of A is not referenced. If DIAG = 'U', the */
+/* diagonal elements of A are also not referenced and are */
+/* assumed to be 1. */
+
+/* On exit, the (triangular) inverse of the original matrix, in */
+/* the same storage format. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ nounit = lsame_(diag, "N");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STRTI2", &i__1);
+ return 0;
+ }
+
+ if (upper) {
+
+/* Compute inverse of upper triangular matrix. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (nounit) {
+ a[j + j * a_dim1] = 1.f / a[j + j * a_dim1];
+ ajj = -a[j + j * a_dim1];
+ } else {
+ ajj = -1.f;
+ }
+
+/* Compute elements 1:j-1 of j-th column. */
+
+ i__2 = j - 1;
+ strmv_("Upper", "No transpose", diag, &i__2, &a[a_offset], lda, &
+ a[j * a_dim1 + 1], &c__1);
+ i__2 = j - 1;
+ sscal_(&i__2, &ajj, &a[j * a_dim1 + 1], &c__1);
+/* L10: */
+ }
+ } else {
+
+/* Compute inverse of lower triangular matrix. */
+
+ for (j = *n; j >= 1; --j) {
+ if (nounit) {
+ a[j + j * a_dim1] = 1.f / a[j + j * a_dim1];
+ ajj = -a[j + j * a_dim1];
+ } else {
+ ajj = -1.f;
+ }
+ if (j < *n) {
+
+/* Compute elements j+1:n of j-th column. */
+
+ i__1 = *n - j;
+ strmv_("Lower", "No transpose", diag, &i__1, &a[j + 1 + (j +
+ 1) * a_dim1], lda, &a[j + 1 + j * a_dim1], &c__1);
+ i__1 = *n - j;
+ sscal_(&i__1, &ajj, &a[j + 1 + j * a_dim1], &c__1);
+ }
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of STRTI2 */
+
+} /* strti2_ */
diff --git a/SRC/strtri.c b/SRC/strtri.c
new file mode 100644
index 0000000..f9cc55e
--- /dev/null
+++ b/SRC/strtri.c
@@ -0,0 +1,241 @@
+/* strtri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static real c_b18 = 1.f;
+static real c_b22 = -1.f;
+
+/* Subroutine */ int strtri_(char *uplo, char *diag, integer *n, real *a,
+ integer *lda, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, i__1, i__2[2], i__3, i__4, i__5;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer j, jb, nb, nn;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int strmm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), strsm_(char *, char *, char *,
+ char *, integer *, integer *, real *, real *, integer *, real *,
+ integer *), strti2_(char *, char *
+, integer *, real *, integer *, integer *),
+ xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STRTRI computes the inverse of a real upper or lower triangular */
+/* matrix A. */
+
+/* This is the Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the triangular matrix A. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of the array A contains */
+/* the upper triangular matrix, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of the array A contains */
+/* the lower triangular matrix, and the strictly upper */
+/* triangular part of A is not referenced. If DIAG = 'U', the */
+/* diagonal elements of A are also not referenced and are */
+/* assumed to be 1. */
+/* On exit, the (triangular) inverse of the original matrix, in */
+/* the same storage format. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */
+/* matrix is singular and its inverse can not be computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ nounit = lsame_(diag, "N");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STRTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check for singularity if non-unit. */
+
+ if (nounit) {
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ if (a[*info + *info * a_dim1] == 0.f) {
+ return 0;
+ }
+/* L10: */
+ }
+ *info = 0;
+ }
+
+/* Determine the block size for this environment. */
+
+/* Writing concatenation */
+ i__2[0] = 1, a__1[0] = uplo;
+ i__2[1] = 1, a__1[1] = diag;
+ s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2);
+ nb = ilaenv_(&c__1, "STRTRI", ch__1, n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code */
+
+ strti2_(uplo, diag, n, &a[a_offset], lda, info);
+ } else {
+
+/* Use blocked code */
+
+ if (upper) {
+
+/* Compute inverse of upper triangular matrix */
+
+ i__1 = *n;
+ i__3 = nb;
+ for (j = 1; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *n - j + 1;
+ jb = min(i__4,i__5);
+
+/* Compute rows 1:j-1 of current block column */
+
+ i__4 = j - 1;
+ strmm_("Left", "Upper", "No transpose", diag, &i__4, &jb, &
+ c_b18, &a[a_offset], lda, &a[j * a_dim1 + 1], lda);
+ i__4 = j - 1;
+ strsm_("Right", "Upper", "No transpose", diag, &i__4, &jb, &
+ c_b22, &a[j + j * a_dim1], lda, &a[j * a_dim1 + 1],
+ lda);
+
+/* Compute inverse of current diagonal block */
+
+ strti2_("Upper", diag, &jb, &a[j + j * a_dim1], lda, info);
+/* L20: */
+ }
+ } else {
+
+/* Compute inverse of lower triangular matrix */
+
+ nn = (*n - 1) / nb * nb + 1;
+ i__3 = -nb;
+ for (j = nn; i__3 < 0 ? j >= 1 : j <= 1; j += i__3) {
+/* Computing MIN */
+ i__1 = nb, i__4 = *n - j + 1;
+ jb = min(i__1,i__4);
+ if (j + jb <= *n) {
+
+/* Compute rows j+jb:n of current block column */
+
+ i__1 = *n - j - jb + 1;
+ strmm_("Left", "Lower", "No transpose", diag, &i__1, &jb,
+ &c_b18, &a[j + jb + (j + jb) * a_dim1], lda, &a[j
+ + jb + j * a_dim1], lda);
+ i__1 = *n - j - jb + 1;
+ strsm_("Right", "Lower", "No transpose", diag, &i__1, &jb,
+ &c_b22, &a[j + j * a_dim1], lda, &a[j + jb + j *
+ a_dim1], lda);
+ }
+
+/* Compute inverse of current diagonal block */
+
+ strti2_("Lower", diag, &jb, &a[j + j * a_dim1], lda, info);
+/* L30: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of STRTRI */
+
+} /* strtri_ */
diff --git a/SRC/strtrs.c b/SRC/strtrs.c
new file mode 100644
index 0000000..d7f1baa
--- /dev/null
+++ b/SRC/strtrs.c
@@ -0,0 +1,182 @@
+/* strtrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b12 = 1.f;
+
+/* Subroutine */ int strtrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, real *a, integer *lda, real *b, integer *ldb, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), xerbla_(char *, integer *);
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STRTRS solves a triangular system of the form */
+
+/* A * X = B or A**T * X = B, */
+
+/* where A is a triangular matrix of order N, and B is an N-by-NRHS */
+/* matrix. A check is made to verify that A is nonsingular. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, if INFO = 0, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element of A is zero, */
+/* indicating that the matrix is singular and the solutions */
+/* X have not been computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ nounit = lsame_(diag, "N");
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STRTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check for singularity. */
+
+ if (nounit) {
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ if (a[*info + *info * a_dim1] == 0.f) {
+ return 0;
+ }
+/* L10: */
+ }
+ }
+ *info = 0;
+
+/* Solve A * x = b or A' * x = b. */
+
+ strsm_("Left", uplo, trans, diag, n, nrhs, &c_b12, &a[a_offset], lda, &b[
+ b_offset], ldb);
+
+ return 0;
+
+/* End of STRTRS */
+
+} /* strtrs_ */
diff --git a/SRC/strttf.c b/SRC/strttf.c
new file mode 100644
index 0000000..eb0993b
--- /dev/null
+++ b/SRC/strttf.c
@@ -0,0 +1,489 @@
+/* strttf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int strttf_(char *transr, char *uplo, integer *n, real *a,
+ integer *lda, real *arf, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k, l, n1, n2, ij, nt, nx2, np1x2;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nisodd;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STRTTF copies a triangular matrix A from standard full format (TR) */
+/* to rectangular full packed format (TF) . */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': ARF in Normal form is wanted; */
+/* = 'T': ARF in Transpose form is wanted. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N). */
+/* On entry, the triangular matrix A. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of the array A contains */
+/* the upper triangular matrix, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of the array A contains */
+/* the lower triangular matrix, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the matrix A. LDA >= max(1,N). */
+
+/* ARF (output) REAL array, dimension (NT). */
+/* NT=N*(N+1)/2. On exit, the triangular matrix A in RFP format. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Notes */
+/* ===== */
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* even. We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* the transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* the transpose of the last three columns of AP lower. */
+/* This covers the case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 03 04 05 33 43 53 */
+/* 13 14 15 00 44 54 */
+/* 23 24 25 10 11 55 */
+/* 33 34 35 20 21 22 */
+/* 00 44 45 30 31 32 */
+/* 01 11 55 40 41 42 */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We first consider Rectangular Full Packed (RFP) Format when N is */
+/* odd. We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* the transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* the transpose of the last two columns of AP lower. */
+/* This covers the case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* 02 03 04 00 33 43 */
+/* 12 13 14 10 11 44 */
+/* 22 23 24 20 21 22 */
+/* 00 33 34 30 31 32 */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */
+/* transpose of RFP A above. One therefore gets: */
+
+/* RFP A RFP A */
+
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* Reference */
+/* ========= */
+
+/* ===================================================================== */
+
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda - 1 - 0 + 1;
+ a_offset = 0 + a_dim1 * 0;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "T")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STRTTF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 1) {
+ if (*n == 1) {
+ arf[0] = a[0];
+ }
+ return 0;
+ }
+
+/* Size of array ARF(0:nt-1) */
+
+ nt = *n * (*n + 1) / 2;
+
+/* Set N1 and N2 depending on LOWER: for N even N1=N2=K */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. */
+/* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is */
+/* N--by--(N+1)/2. */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ if (! lower) {
+ np1x2 = *n + *n + 2;
+ }
+ } else {
+ nisodd = TRUE_;
+ if (! lower) {
+ nx2 = *n + *n;
+ }
+ }
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* N is odd, TRANSR = 'N', and UPLO = 'L' */
+
+ ij = 0;
+ i__1 = n2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = n2 + j;
+ for (i__ = n1; i__ <= i__2; ++i__) {
+ arf[ij] = a[n2 + j + i__ * a_dim1];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ arf[ij] = a[i__ + j * a_dim1];
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* N is odd, TRANSR = 'N', and UPLO = 'U' */
+
+ ij = nt - *n;
+ i__1 = n1;
+ for (j = *n - 1; j >= i__1; --j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ arf[ij] = a[i__ + j * a_dim1];
+ ++ij;
+ }
+ i__2 = n1 - 1;
+ for (l = j - n1; l <= i__2; ++l) {
+ arf[ij] = a[j - n1 + l * a_dim1];
+ ++ij;
+ }
+ ij -= nx2;
+ }
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'T' */
+
+ if (lower) {
+
+/* N is odd, TRANSR = 'T', and UPLO = 'L' */
+
+ ij = 0;
+ i__1 = n2 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ arf[ij] = a[j + i__ * a_dim1];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = n1 + j; i__ <= i__2; ++i__) {
+ arf[ij] = a[i__ + (n1 + j) * a_dim1];
+ ++ij;
+ }
+ }
+ i__1 = *n - 1;
+ for (j = n2; j <= i__1; ++j) {
+ i__2 = n1 - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ arf[ij] = a[j + i__ * a_dim1];
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* N is odd, TRANSR = 'T', and UPLO = 'U' */
+
+ ij = 0;
+ i__1 = n1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = n1; i__ <= i__2; ++i__) {
+ arf[ij] = a[j + i__ * a_dim1];
+ ++ij;
+ }
+ }
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ arf[ij] = a[i__ + j * a_dim1];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (l = n2 + j; l <= i__2; ++l) {
+ arf[ij] = a[n2 + j + l * a_dim1];
+ ++ij;
+ }
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* N is even, TRANSR = 'N', and UPLO = 'L' */
+
+ ij = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k + j;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ arf[ij] = a[k + j + i__ * a_dim1];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ arf[ij] = a[i__ + j * a_dim1];
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* N is even, TRANSR = 'N', and UPLO = 'U' */
+
+ ij = nt - *n - 1;
+ i__1 = k;
+ for (j = *n - 1; j >= i__1; --j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ arf[ij] = a[i__ + j * a_dim1];
+ ++ij;
+ }
+ i__2 = k - 1;
+ for (l = j - k; l <= i__2; ++l) {
+ arf[ij] = a[j - k + l * a_dim1];
+ ++ij;
+ }
+ ij -= np1x2;
+ }
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'T' */
+
+ if (lower) {
+
+/* N is even, TRANSR = 'T', and UPLO = 'L' */
+
+ ij = 0;
+ j = k;
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ arf[ij] = a[i__ + j * a_dim1];
+ ++ij;
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ arf[ij] = a[j + i__ * a_dim1];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = k + 1 + j; i__ <= i__2; ++i__) {
+ arf[ij] = a[i__ + (k + 1 + j) * a_dim1];
+ ++ij;
+ }
+ }
+ i__1 = *n - 1;
+ for (j = k - 1; j <= i__1; ++j) {
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ arf[ij] = a[j + i__ * a_dim1];
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* N is even, TRANSR = 'T', and UPLO = 'U' */
+
+ ij = 0;
+ i__1 = k;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ arf[ij] = a[j + i__ * a_dim1];
+ ++ij;
+ }
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ arf[ij] = a[i__ + j * a_dim1];
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (l = k + 1 + j; l <= i__2; ++l) {
+ arf[ij] = a[k + 1 + j + l * a_dim1];
+ ++ij;
+ }
+ }
+/* Note that here, on exit of the loop, J = K-1 */
+ i__1 = j;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ arf[ij] = a[i__ + j * a_dim1];
+ ++ij;
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of STRTTF */
+
+} /* strttf_ */
diff --git a/SRC/strttp.c b/SRC/strttp.c
new file mode 100644
index 0000000..2d4f203
--- /dev/null
+++ b/SRC/strttp.c
@@ -0,0 +1,143 @@
+/* strttp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int strttp_(char *uplo, integer *n, real *a, integer *lda,
+ real *ap, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- and Julien Langou of the Univ. of Colorado Denver -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STRTTP copies a triangular matrix A from full format (TR) to standard */
+/* packed format (TP). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular. */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrices AP and A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* On exit, the triangular matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AP (output) REAL array, dimension (N*(N+1)/2 */
+/* On exit, the upper or lower triangular matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ lower = lsame_(uplo, "L");
+ if (! lower && ! lsame_(uplo, "U")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STRTTP", &i__1);
+ return 0;
+ }
+
+ if (lower) {
+ k = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ++k;
+ ap[k] = a[i__ + j * a_dim1];
+ }
+ }
+ } else {
+ k = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ++k;
+ ap[k] = a[i__ + j * a_dim1];
+ }
+ }
+ }
+
+ return 0;
+
+/* End of STRTTP */
+
+} /* strttp_ */
diff --git a/SRC/stzrqf.c b/SRC/stzrqf.c
new file mode 100644
index 0000000..1a31566
--- /dev/null
+++ b/SRC/stzrqf.c
@@ -0,0 +1,219 @@
+/* stzrqf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b8 = 1.f;
+
+/* Subroutine */ int stzrqf_(integer *m, integer *n, real *a, integer *lda,
+ real *tau, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real r__1;
+
+ /* Local variables */
+ integer i__, k, m1;
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *), sgemv_(char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+, real *, real *, integer *), scopy_(integer *, real *,
+ integer *, real *, integer *), saxpy_(integer *, real *, real *,
+ integer *, real *, integer *), xerbla_(char *, integer *),
+ slarfp_(integer *, real *, real *, integer *, real *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine STZRZF. */
+
+/* STZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A */
+/* to upper triangular form by means of orthogonal transformations. */
+
+/* The upper trapezoidal matrix A is factored as */
+
+/* A = ( R 0 ) * Z, */
+
+/* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper */
+/* triangular matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= M. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the leading M-by-N upper trapezoidal part of the */
+/* array A must contain the matrix to be factorized. */
+/* On exit, the leading M-by-M upper triangular part of A */
+/* contains the upper triangular matrix R, and elements M+1 to */
+/* N of the first M rows of A, with the array TAU, represent the */
+/* orthogonal matrix Z as a product of M elementary reflectors. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) REAL array, dimension (M) */
+/* The scalar factors of the elementary reflectors. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The factorization is obtained by Householder's method. The kth */
+/* transformation matrix, Z( k ), which is used to introduce zeros into */
+/* the ( m - k + 1 )th row of A, is given in the form */
+
+/* Z( k ) = ( I 0 ), */
+/* ( 0 T( k ) ) */
+
+/* where */
+
+/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */
+/* ( 0 ) */
+/* ( z( k ) ) */
+
+/* tau is a scalar and z( k ) is an ( n - m ) element vector. */
+/* tau and z( k ) are chosen to annihilate the elements of the kth row */
+/* of X. */
+
+/* The scalar tau is returned in the kth element of TAU and the vector */
+/* u( k ) in the kth row of A, such that the elements of z( k ) are */
+/* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */
+/* the upper triangular part of A. */
+
+/* Z is given by */
+
+/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STZRQF", &i__1);
+ return 0;
+ }
+
+/* Perform the factorization. */
+
+ if (*m == 0) {
+ return 0;
+ }
+ if (*m == *n) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tau[i__] = 0.f;
+/* L10: */
+ }
+ } else {
+/* Computing MIN */
+ i__1 = *m + 1;
+ m1 = min(i__1,*n);
+ for (k = *m; k >= 1; --k) {
+
+/* Use a Householder reflection to zero the kth row of A. */
+/* First set up the reflection. */
+
+ i__1 = *n - *m + 1;
+ slarfp_(&i__1, &a[k + k * a_dim1], &a[k + m1 * a_dim1], lda, &tau[
+ k]);
+
+ if (tau[k] != 0.f && k > 1) {
+
+/* We now perform the operation A := A*P( k ). */
+
+/* Use the first ( k - 1 ) elements of TAU to store a( k ), */
+/* where a( k ) consists of the first ( k - 1 ) elements of */
+/* the kth column of A. Also let B denote the first */
+/* ( k - 1 ) rows of the last ( n - m ) columns of A. */
+
+ i__1 = k - 1;
+ scopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &tau[1], &c__1);
+
+/* Form w = a( k ) + B*z( k ) in TAU. */
+
+ i__1 = k - 1;
+ i__2 = *n - *m;
+ sgemv_("No transpose", &i__1, &i__2, &c_b8, &a[m1 * a_dim1 +
+ 1], lda, &a[k + m1 * a_dim1], lda, &c_b8, &tau[1], &
+ c__1);
+
+/* Now form a( k ) := a( k ) - tau*w */
+/* and B := B - tau*w*z( k )'. */
+
+ i__1 = k - 1;
+ r__1 = -tau[k];
+ saxpy_(&i__1, &r__1, &tau[1], &c__1, &a[k * a_dim1 + 1], &
+ c__1);
+ i__1 = k - 1;
+ i__2 = *n - *m;
+ r__1 = -tau[k];
+ sger_(&i__1, &i__2, &r__1, &tau[1], &c__1, &a[k + m1 * a_dim1]
+, lda, &a[m1 * a_dim1 + 1], lda);
+ }
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of STZRQF */
+
+} /* stzrqf_ */
diff --git a/SRC/stzrzf.c b/SRC/stzrzf.c
new file mode 100644
index 0000000..c555951
--- /dev/null
+++ b/SRC/stzrzf.c
@@ -0,0 +1,310 @@
+/* stzrzf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int stzrzf_(integer *m, integer *n, real *a, integer *lda,
+ real *tau, real *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+
+ /* Local variables */
+ integer i__, m1, ib, nb, ki, kk, mu, nx, iws, nbmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slarzb_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, real *, integer *,
+ real *, integer *, real *, integer *, real *, integer *);
+ integer ldwork;
+ extern /* Subroutine */ int slarzt_(char *, char *, integer *, integer *,
+ real *, integer *, real *, real *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int slatrz_(integer *, integer *, integer *, real
+ *, integer *, real *, real *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A */
+/* to upper triangular form by means of orthogonal transformations. */
+
+/* The upper trapezoidal matrix A is factored as */
+
+/* A = ( R 0 ) * Z, */
+
+/* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper */
+/* triangular matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= M. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the leading M-by-N upper trapezoidal part of the */
+/* array A must contain the matrix to be factorized. */
+/* On exit, the leading M-by-M upper triangular part of A */
+/* contains the upper triangular matrix R, and elements M+1 to */
+/* N of the first M rows of A, with the array TAU, represent the */
+/* orthogonal matrix Z as a product of M elementary reflectors. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) REAL array, dimension (M) */
+/* The scalar factors of the elementary reflectors. */
+
+/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M). */
+/* For optimum performance LWORK >= M*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* The factorization is obtained by Householder's method. The kth */
+/* transformation matrix, Z( k ), which is used to introduce zeros into */
+/* the ( m - k + 1 )th row of A, is given in the form */
+
+/* Z( k ) = ( I 0 ), */
+/* ( 0 T( k ) ) */
+
+/* where */
+
+/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */
+/* ( 0 ) */
+/* ( z( k ) ) */
+
+/* tau is a scalar and z( k ) is an ( n - m ) element vector. */
+/* tau and z( k ) are chosen to annihilate the elements of the kth row */
+/* of X. */
+
+/* The scalar tau is returned in the kth element of TAU and the vector */
+/* u( k ) in the kth row of A, such that the elements of z( k ) are */
+/* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */
+/* the upper triangular part of A. */
+
+/* Z is given by */
+
+/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+
+ if (*info == 0) {
+ if (*m == 0 || *m == *n) {
+ lwkopt = 1;
+ } else {
+
+/* Determine the block size. */
+
+ nb = ilaenv_(&c__1, "SGERQF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = *m * nb;
+ }
+ work[1] = (real) lwkopt;
+
+ if (*lwork < max(1,*m) && ! lquery) {
+ *info = -7;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("STZRZF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0) {
+ return 0;
+ } else if (*m == *n) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tau[i__] = 0.f;
+/* L10: */
+ }
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 1;
+ iws = *m;
+ if (nb > 1 && nb < *m) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "SGERQF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *m) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *m;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "SGERQF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < *m && nx < *m) {
+
+/* Use blocked code initially. */
+/* The last kk rows are handled by the block method. */
+
+/* Computing MIN */
+ i__1 = *m + 1;
+ m1 = min(i__1,*n);
+ ki = (*m - nx - 1) / nb * nb;
+/* Computing MIN */
+ i__1 = *m, i__2 = ki + nb;
+ kk = min(i__1,i__2);
+
+ i__1 = *m - kk + 1;
+ i__2 = -nb;
+ for (i__ = *m - kk + ki + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1;
+ i__ += i__2) {
+/* Computing MIN */
+ i__3 = *m - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Compute the TZ factorization of the current block */
+/* A(i:i+ib-1,i:n) */
+
+ i__3 = *n - i__ + 1;
+ i__4 = *n - *m;
+ slatrz_(&ib, &i__3, &i__4, &a[i__ + i__ * a_dim1], lda, &tau[i__],
+ &work[1]);
+ if (i__ > 1) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__3 = *n - *m;
+ slarzt_("Backward", "Rowwise", &i__3, &ib, &a[i__ + m1 *
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H to A(1:i-1,i:n) from the right */
+
+ i__3 = i__ - 1;
+ i__4 = *n - i__ + 1;
+ i__5 = *n - *m;
+ slarzb_("Right", "No transpose", "Backward", "Rowwise", &i__3,
+ &i__4, &ib, &i__5, &a[i__ + m1 * a_dim1], lda, &work[
+ 1], &ldwork, &a[i__ * a_dim1 + 1], lda, &work[ib + 1],
+ &ldwork)
+ ;
+ }
+/* L20: */
+ }
+ mu = i__ + nb - 1;
+ } else {
+ mu = *m;
+ }
+
+/* Use unblocked code to factor the last or only block */
+
+ if (mu > 0) {
+ i__2 = *n - *m;
+ slatrz_(&mu, n, &i__2, &a[a_offset], lda, &tau[1], &work[1]);
+ }
+
+ work[1] = (real) lwkopt;
+
+ return 0;
+
+/* End of STZRZF */
+
+} /* stzrzf_ */
diff --git a/SRC/xerbla.c b/SRC/xerbla.c
new file mode 100644
index 0000000..fb4a9d8
--- /dev/null
+++ b/SRC/xerbla.c
@@ -0,0 +1,65 @@
+/* xerbla.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+#include "stdio.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int xerbla_(char *srname, integer *info)
+{
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* XERBLA is an error handler for the LAPACK routines. */
+/* It is called by an LAPACK routine if an input parameter has an */
+/* invalid value. A message is printed and execution stops. */
+
+/* Installers may consider modifying the STOP statement in order to */
+/* call system-specific exception-handling facilities. */
+
+/* Arguments */
+/* ========= */
+
+/* SRNAME (input) CHARACTER*(*) */
+/* The name of the routine which called XERBLA. */
+
+/* INFO (input) INTEGER */
+/* The position of the invalid parameter in the parameter list */
+/* of the calling routine. */
+
+/* ===================================================================== */
+
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ printf("** On entry to %6s, parameter number %2i had an illegal value\n",
+ srname, *info);
+
+
+/* End of XERBLA */
+
+ return 0;
+} /* xerbla_ */
diff --git a/SRC/xerbla_array.c b/SRC/xerbla_array.c
new file mode 100644
index 0000000..d4e4c24
--- /dev/null
+++ b/SRC/xerbla_array.c
@@ -0,0 +1,102 @@
+/* xerbla_array.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int xerbla_array__(char *srname_array__, integer *
+ srname_len__, integer *info, ftnlen srname_array_len)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer i_len(char *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ char srname[32];
+
+
+/* -- LAPACK auxiliary routine (version 3.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
+/* September 19, 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* XERBLA_ARRAY assists other languages in calling XERBLA, the LAPACK */
+/* and BLAS error handler. Rather than taking a Fortran string argument */
+/* as the function's name, XERBLA_ARRAY takes an array of single */
+/* characters along with the array's length. XERBLA_ARRAY then copies */
+/* up to 32 characters of that array into a Fortran string and passes */
+/* that to XERBLA. If called with a non-positive SRNAME_LEN, */
+/* XERBLA_ARRAY will call XERBLA with a string of all blank characters. */
+
+/* Say some macro or other device makes XERBLA_ARRAY available to C99 */
+/* by a name lapack_xerbla and with a common Fortran calling convention. */
+/* Then a C99 program could invoke XERBLA via: */
+/* { */
+/* int flen = strlen(__func__); */
+/* lapack_xerbla(__func__, &flen, &info); */
+/* } */
+
+/* Providing XERBLA_ARRAY is not necessary for intercepting LAPACK */
+/* errors. XERBLA_ARRAY calls XERBLA. */
+
+/* Arguments */
+/* ========= */
+
+/* SRNAME_ARRAY (input) CHARACTER(1) array, dimension (SRNAME_LEN) */
+/* The name of the routine which called XERBLA_ARRAY. */
+
+/* SRNAME_LEN (input) INTEGER */
+/* The length of the name in SRNAME_ARRAY. */
+
+/* INFO (input) INTEGER */
+/* The position of the invalid parameter in the parameter list */
+/* of the calling routine. */
+
+/* ===================================================================== */
+
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ --srname_array__;
+
+ /* Function Body */
+ s_copy(srname, "", (ftnlen)32, (ftnlen)0);
+/* Computing MIN */
+ i__2 = *srname_len__, i__3 = i_len(srname, (ftnlen)32);
+ i__1 = min(i__2,i__3);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ *(unsigned char *)&srname[i__ - 1] = *(unsigned char *)&
+ srname_array__[i__];
+ }
+ xerbla_(srname, info);
+ return 0;
+} /* xerbla_array__ */
diff --git a/SRC/zbdsqr.c b/SRC/zbdsqr.c
new file mode 100644
index 0000000..7ab5c2d
--- /dev/null
+++ b/SRC/zbdsqr.c
@@ -0,0 +1,909 @@
+/* zbdsqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b15 = -.125;
+static integer c__1 = 1;
+static doublereal c_b49 = 1.;
+static doublereal c_b72 = -1.;
+
+/* Subroutine */ int zbdsqr_(char *uplo, integer *n, integer *ncvt, integer *
+ nru, integer *ncc, doublereal *d__, doublereal *e, doublecomplex *vt,
+ integer *ldvt, doublecomplex *u, integer *ldu, doublecomplex *c__,
+ integer *ldc, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
+ i__2;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double pow_dd(doublereal *, doublereal *), sqrt(doublereal), d_sign(
+ doublereal *, doublereal *);
+
+ /* Local variables */
+ doublereal f, g, h__;
+ integer i__, j, m;
+ doublereal r__, cs;
+ integer ll;
+ doublereal sn, mu;
+ integer nm1, nm12, nm13, lll;
+ doublereal eps, sll, tol, abse;
+ integer idir;
+ doublereal abss;
+ integer oldm;
+ doublereal cosl;
+ integer isub, iter;
+ doublereal unfl, sinl, cosr, smin, smax, sinr;
+ extern /* Subroutine */ int dlas2_(doublereal *, doublereal *, doublereal
+ *, doublereal *, doublereal *);
+ extern logical lsame_(char *, char *);
+ doublereal oldcs;
+ integer oldll;
+ doublereal shift, sigmn, oldsn;
+ integer maxit;
+ doublereal sminl, sigmx;
+ logical lower;
+ extern /* Subroutine */ int zlasr_(char *, char *, char *, integer *,
+ integer *, doublereal *, doublereal *, doublecomplex *, integer *), zdrot_(integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *)
+ , zswap_(integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), dlasq1_(integer *, doublereal *, doublereal *,
+ doublereal *, integer *), dlasv2_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *), xerbla_(char *,
+ integer *), zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ doublereal sminoa, thresh;
+ logical rotate;
+ doublereal tolmul;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZBDSQR computes the singular values and, optionally, the right and/or */
+/* left singular vectors from the singular value decomposition (SVD) of */
+/* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit */
+/* zero-shift QR algorithm. The SVD of B has the form */
+
+/* B = Q * S * P**H */
+
+/* where S is the diagonal matrix of singular values, Q is an orthogonal */
+/* matrix of left singular vectors, and P is an orthogonal matrix of */
+/* right singular vectors. If left singular vectors are requested, this */
+/* subroutine actually returns U*Q instead of Q, and, if right singular */
+/* vectors are requested, this subroutine returns P**H*VT instead of */
+/* P**H, for given complex input matrices U and VT. When U and VT are */
+/* the unitary matrices that reduce a general matrix A to bidiagonal */
+/* form: A = U*B*VT, as computed by ZGEBRD, then */
+
+/* A = (U*Q) * S * (P**H*VT) */
+
+/* is the SVD of A. Optionally, the subroutine may also compute Q**H*C */
+/* for a given complex input matrix C. */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices With */
+/* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, */
+/* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, */
+/* no. 5, pp. 873-912, Sept 1990) and */
+/* "Accurate singular values and differential qd algorithms," by */
+/* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics */
+/* Department, University of California at Berkeley, July 1992 */
+/* for a detailed description of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': B is upper bidiagonal; */
+/* = 'L': B is lower bidiagonal. */
+
+/* N (input) INTEGER */
+/* The order of the matrix B. N >= 0. */
+
+/* NCVT (input) INTEGER */
+/* The number of columns of the matrix VT. NCVT >= 0. */
+
+/* NRU (input) INTEGER */
+/* The number of rows of the matrix U. NRU >= 0. */
+
+/* NCC (input) INTEGER */
+/* The number of columns of the matrix C. NCC >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the n diagonal elements of the bidiagonal matrix B. */
+/* On exit, if INFO=0, the singular values of B in decreasing */
+/* order. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* On entry, the N-1 offdiagonal elements of the bidiagonal */
+/* matrix B. */
+/* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E */
+/* will contain the diagonal and superdiagonal elements of a */
+/* bidiagonal matrix orthogonally equivalent to the one given */
+/* as input. */
+
+/* VT (input/output) COMPLEX*16 array, dimension (LDVT, NCVT) */
+/* On entry, an N-by-NCVT matrix VT. */
+/* On exit, VT is overwritten by P**H * VT. */
+/* Not referenced if NCVT = 0. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. */
+/* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. */
+
+/* U (input/output) COMPLEX*16 array, dimension (LDU, N) */
+/* On entry, an NRU-by-N matrix U. */
+/* On exit, U is overwritten by U * Q. */
+/* Not referenced if NRU = 0. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,NRU). */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC, NCC) */
+/* On entry, an N-by-NCC matrix C. */
+/* On exit, C is overwritten by Q**H * C. */
+/* Not referenced if NCC = 0. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. */
+/* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+/* if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0: the algorithm did not converge; D and E contain the */
+/* elements of a bidiagonal matrix which is orthogonally */
+/* similar to the input matrix B; if INFO = i, i */
+/* elements of E have not converged to zero. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8))) */
+/* TOLMUL controls the convergence criterion of the QR loop. */
+/* If it is positive, TOLMUL*EPS is the desired relative */
+/* precision in the computed singular values. */
+/* If it is negative, abs(TOLMUL*EPS*sigma_max) is the */
+/* desired absolute accuracy in the computed singular */
+/* values (corresponds to relative accuracy */
+/* abs(TOLMUL*EPS) in the largest singular value. */
+/* abs(TOLMUL) should be between 1 and 1/EPS, and preferably */
+/* between 10 (for fast convergence) and .1/EPS */
+/* (for there to be some accuracy in the results). */
+/* Default is to lose at either one eighth or 2 of the */
+/* available decimal digits in each computed singular value */
+/* (whichever is smaller). */
+
+/* MAXITR INTEGER, default = 6 */
+/* MAXITR controls the maximum number of passes of the */
+/* algorithm through its inner loop. The algorithms stops */
+/* (and so fails to converge) if the number of passes */
+/* through the inner loop exceeds MAXITR*N**2. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ lower = lsame_(uplo, "L");
+ if (! lsame_(uplo, "U") && ! lower) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ncvt < 0) {
+ *info = -3;
+ } else if (*nru < 0) {
+ *info = -4;
+ } else if (*ncc < 0) {
+ *info = -5;
+ } else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < max(1,*n)) {
+ *info = -9;
+ } else if (*ldu < max(1,*nru)) {
+ *info = -11;
+ } else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < max(1,*n)) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZBDSQR", &i__1);
+ return 0;
+ }
+ if (*n == 0) {
+ return 0;
+ }
+ if (*n == 1) {
+ goto L160;
+ }
+
+/* ROTATE is true if any singular vectors desired, false otherwise */
+
+ rotate = *ncvt > 0 || *nru > 0 || *ncc > 0;
+
+/* If no singular vectors desired, use qd algorithm */
+
+ if (! rotate) {
+ dlasq1_(n, &d__[1], &e[1], &rwork[1], info);
+ return 0;
+ }
+
+ nm1 = *n - 1;
+ nm12 = nm1 + nm1;
+ nm13 = nm12 + nm1;
+ idir = 0;
+
+/* Get machine constants */
+
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+
+/* If matrix lower bidiagonal, rotate to be upper bidiagonal */
+/* by applying Givens rotations on the left */
+
+ if (lower) {
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
+ d__[i__] = r__;
+ e[i__] = sn * d__[i__ + 1];
+ d__[i__ + 1] = cs * d__[i__ + 1];
+ rwork[i__] = cs;
+ rwork[nm1 + i__] = sn;
+/* L10: */
+ }
+
+/* Update singular vectors if desired */
+
+ if (*nru > 0) {
+ zlasr_("R", "V", "F", nru, n, &rwork[1], &rwork[*n], &u[u_offset],
+ ldu);
+ }
+ if (*ncc > 0) {
+ zlasr_("L", "V", "F", n, ncc, &rwork[1], &rwork[*n], &c__[
+ c_offset], ldc);
+ }
+ }
+
+/* Compute singular values to relative accuracy TOL */
+/* (By setting TOL to be negative, algorithm will compute */
+/* singular values to absolute accuracy ABS(TOL)*norm(input matrix)) */
+
+/* Computing MAX */
+/* Computing MIN */
+ d__3 = 100., d__4 = pow_dd(&eps, &c_b15);
+ d__1 = 10., d__2 = min(d__3,d__4);
+ tolmul = max(d__1,d__2);
+ tol = tolmul * eps;
+
+/* Compute approximate maximum, minimum singular values */
+
+ smax = 0.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = smax, d__3 = (d__1 = d__[i__], abs(d__1));
+ smax = max(d__2,d__3);
+/* L20: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = smax, d__3 = (d__1 = e[i__], abs(d__1));
+ smax = max(d__2,d__3);
+/* L30: */
+ }
+ sminl = 0.;
+ if (tol >= 0.) {
+
+/* Relative accuracy desired */
+
+ sminoa = abs(d__[1]);
+ if (sminoa == 0.) {
+ goto L50;
+ }
+ mu = sminoa;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ mu = (d__2 = d__[i__], abs(d__2)) * (mu / (mu + (d__1 = e[i__ - 1]
+ , abs(d__1))));
+ sminoa = min(sminoa,mu);
+ if (sminoa == 0.) {
+ goto L50;
+ }
+/* L40: */
+ }
+L50:
+ sminoa /= sqrt((doublereal) (*n));
+/* Computing MAX */
+ d__1 = tol * sminoa, d__2 = *n * 6 * *n * unfl;
+ thresh = max(d__1,d__2);
+ } else {
+
+/* Absolute accuracy desired */
+
+/* Computing MAX */
+ d__1 = abs(tol) * smax, d__2 = *n * 6 * *n * unfl;
+ thresh = max(d__1,d__2);
+ }
+
+/* Prepare for main iteration loop for the singular values */
+/* (MAXIT is the maximum number of passes through the inner */
+/* loop permitted before nonconvergence signalled.) */
+
+ maxit = *n * 6 * *n;
+ iter = 0;
+ oldll = -1;
+ oldm = -1;
+
+/* M points to last element of unconverged part of matrix */
+
+ m = *n;
+
+/* Begin main iteration loop */
+
+L60:
+
+/* Check for convergence or exceeding iteration count */
+
+ if (m <= 1) {
+ goto L160;
+ }
+ if (iter > maxit) {
+ goto L200;
+ }
+
+/* Find diagonal block of matrix to work on */
+
+ if (tol < 0. && (d__1 = d__[m], abs(d__1)) <= thresh) {
+ d__[m] = 0.;
+ }
+ smax = (d__1 = d__[m], abs(d__1));
+ smin = smax;
+ i__1 = m - 1;
+ for (lll = 1; lll <= i__1; ++lll) {
+ ll = m - lll;
+ abss = (d__1 = d__[ll], abs(d__1));
+ abse = (d__1 = e[ll], abs(d__1));
+ if (tol < 0. && abss <= thresh) {
+ d__[ll] = 0.;
+ }
+ if (abse <= thresh) {
+ goto L80;
+ }
+ smin = min(smin,abss);
+/* Computing MAX */
+ d__1 = max(smax,abss);
+ smax = max(d__1,abse);
+/* L70: */
+ }
+ ll = 0;
+ goto L90;
+L80:
+ e[ll] = 0.;
+
+/* Matrix splits since E(LL) = 0 */
+
+ if (ll == m - 1) {
+
+/* Convergence of bottom singular value, return to top of loop */
+
+ --m;
+ goto L60;
+ }
+L90:
+ ++ll;
+
+/* E(LL) through E(M-1) are nonzero, E(LL-1) is zero */
+
+ if (ll == m - 1) {
+
+/* 2 by 2 block, handle separately */
+
+ dlasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr,
+ &sinl, &cosl);
+ d__[m - 1] = sigmx;
+ e[m - 1] = 0.;
+ d__[m] = sigmn;
+
+/* Compute singular vectors, if desired */
+
+ if (*ncvt > 0) {
+ zdrot_(ncvt, &vt[m - 1 + vt_dim1], ldvt, &vt[m + vt_dim1], ldvt, &
+ cosr, &sinr);
+ }
+ if (*nru > 0) {
+ zdrot_(nru, &u[(m - 1) * u_dim1 + 1], &c__1, &u[m * u_dim1 + 1], &
+ c__1, &cosl, &sinl);
+ }
+ if (*ncc > 0) {
+ zdrot_(ncc, &c__[m - 1 + c_dim1], ldc, &c__[m + c_dim1], ldc, &
+ cosl, &sinl);
+ }
+ m += -2;
+ goto L60;
+ }
+
+/* If working on new submatrix, choose shift direction */
+/* (from larger end diagonal element towards smaller) */
+
+ if (ll > oldm || m < oldll) {
+ if ((d__1 = d__[ll], abs(d__1)) >= (d__2 = d__[m], abs(d__2))) {
+
+/* Chase bulge from top (big end) to bottom (small end) */
+
+ idir = 1;
+ } else {
+
+/* Chase bulge from bottom (big end) to top (small end) */
+
+ idir = 2;
+ }
+ }
+
+/* Apply convergence tests */
+
+ if (idir == 1) {
+
+/* Run convergence test in forward direction */
+/* First apply standard test to bottom of matrix */
+
+ if ((d__2 = e[m - 1], abs(d__2)) <= abs(tol) * (d__1 = d__[m], abs(
+ d__1)) || tol < 0. && (d__3 = e[m - 1], abs(d__3)) <= thresh)
+ {
+ e[m - 1] = 0.;
+ goto L60;
+ }
+
+ if (tol >= 0.) {
+
+/* If relative accuracy desired, */
+/* apply convergence criterion forward */
+
+ mu = (d__1 = d__[ll], abs(d__1));
+ sminl = mu;
+ i__1 = m - 1;
+ for (lll = ll; lll <= i__1; ++lll) {
+ if ((d__1 = e[lll], abs(d__1)) <= tol * mu) {
+ e[lll] = 0.;
+ goto L60;
+ }
+ mu = (d__2 = d__[lll + 1], abs(d__2)) * (mu / (mu + (d__1 = e[
+ lll], abs(d__1))));
+ sminl = min(sminl,mu);
+/* L100: */
+ }
+ }
+
+ } else {
+
+/* Run convergence test in backward direction */
+/* First apply standard test to top of matrix */
+
+ if ((d__2 = e[ll], abs(d__2)) <= abs(tol) * (d__1 = d__[ll], abs(d__1)
+ ) || tol < 0. && (d__3 = e[ll], abs(d__3)) <= thresh) {
+ e[ll] = 0.;
+ goto L60;
+ }
+
+ if (tol >= 0.) {
+
+/* If relative accuracy desired, */
+/* apply convergence criterion backward */
+
+ mu = (d__1 = d__[m], abs(d__1));
+ sminl = mu;
+ i__1 = ll;
+ for (lll = m - 1; lll >= i__1; --lll) {
+ if ((d__1 = e[lll], abs(d__1)) <= tol * mu) {
+ e[lll] = 0.;
+ goto L60;
+ }
+ mu = (d__2 = d__[lll], abs(d__2)) * (mu / (mu + (d__1 = e[lll]
+ , abs(d__1))));
+ sminl = min(sminl,mu);
+/* L110: */
+ }
+ }
+ }
+ oldll = ll;
+ oldm = m;
+
+/* Compute shift. First, test if shifting would ruin relative */
+/* accuracy, and if so set the shift to zero. */
+
+/* Computing MAX */
+ d__1 = eps, d__2 = tol * .01;
+ if (tol >= 0. && *n * tol * (sminl / smax) <= max(d__1,d__2)) {
+
+/* Use a zero shift to avoid loss of relative accuracy */
+
+ shift = 0.;
+ } else {
+
+/* Compute the shift from 2-by-2 block at end of matrix */
+
+ if (idir == 1) {
+ sll = (d__1 = d__[ll], abs(d__1));
+ dlas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__);
+ } else {
+ sll = (d__1 = d__[m], abs(d__1));
+ dlas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__);
+ }
+
+/* Test if shift negligible, and if so set to zero */
+
+ if (sll > 0.) {
+/* Computing 2nd power */
+ d__1 = shift / sll;
+ if (d__1 * d__1 < eps) {
+ shift = 0.;
+ }
+ }
+ }
+
+/* Increment iteration count */
+
+ iter = iter + m - ll;
+
+/* If SHIFT = 0, do simplified QR iteration */
+
+ if (shift == 0.) {
+ if (idir == 1) {
+
+/* Chase bulge from top to bottom */
+/* Save cosines and sines for later singular vector updates */
+
+ cs = 1.;
+ oldcs = 1.;
+ i__1 = m - 1;
+ for (i__ = ll; i__ <= i__1; ++i__) {
+ d__1 = d__[i__] * cs;
+ dlartg_(&d__1, &e[i__], &cs, &sn, &r__);
+ if (i__ > ll) {
+ e[i__ - 1] = oldsn * r__;
+ }
+ d__1 = oldcs * r__;
+ d__2 = d__[i__ + 1] * sn;
+ dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
+ rwork[i__ - ll + 1] = cs;
+ rwork[i__ - ll + 1 + nm1] = sn;
+ rwork[i__ - ll + 1 + nm12] = oldcs;
+ rwork[i__ - ll + 1 + nm13] = oldsn;
+/* L120: */
+ }
+ h__ = d__[m] * cs;
+ d__[m] = h__ * oldcs;
+ e[m - 1] = h__ * oldsn;
+
+/* Update singular vectors */
+
+ if (*ncvt > 0) {
+ i__1 = m - ll + 1;
+ zlasr_("L", "V", "F", &i__1, ncvt, &rwork[1], &rwork[*n], &vt[
+ ll + vt_dim1], ldvt);
+ }
+ if (*nru > 0) {
+ i__1 = m - ll + 1;
+ zlasr_("R", "V", "F", nru, &i__1, &rwork[nm12 + 1], &rwork[
+ nm13 + 1], &u[ll * u_dim1 + 1], ldu);
+ }
+ if (*ncc > 0) {
+ i__1 = m - ll + 1;
+ zlasr_("L", "V", "F", &i__1, ncc, &rwork[nm12 + 1], &rwork[
+ nm13 + 1], &c__[ll + c_dim1], ldc);
+ }
+
+/* Test convergence */
+
+ if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
+ e[m - 1] = 0.;
+ }
+
+ } else {
+
+/* Chase bulge from bottom to top */
+/* Save cosines and sines for later singular vector updates */
+
+ cs = 1.;
+ oldcs = 1.;
+ i__1 = ll + 1;
+ for (i__ = m; i__ >= i__1; --i__) {
+ d__1 = d__[i__] * cs;
+ dlartg_(&d__1, &e[i__ - 1], &cs, &sn, &r__);
+ if (i__ < m) {
+ e[i__] = oldsn * r__;
+ }
+ d__1 = oldcs * r__;
+ d__2 = d__[i__ - 1] * sn;
+ dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]);
+ rwork[i__ - ll] = cs;
+ rwork[i__ - ll + nm1] = -sn;
+ rwork[i__ - ll + nm12] = oldcs;
+ rwork[i__ - ll + nm13] = -oldsn;
+/* L130: */
+ }
+ h__ = d__[ll] * cs;
+ d__[ll] = h__ * oldcs;
+ e[ll] = h__ * oldsn;
+
+/* Update singular vectors */
+
+ if (*ncvt > 0) {
+ i__1 = m - ll + 1;
+ zlasr_("L", "V", "B", &i__1, ncvt, &rwork[nm12 + 1], &rwork[
+ nm13 + 1], &vt[ll + vt_dim1], ldvt);
+ }
+ if (*nru > 0) {
+ i__1 = m - ll + 1;
+ zlasr_("R", "V", "B", nru, &i__1, &rwork[1], &rwork[*n], &u[
+ ll * u_dim1 + 1], ldu);
+ }
+ if (*ncc > 0) {
+ i__1 = m - ll + 1;
+ zlasr_("L", "V", "B", &i__1, ncc, &rwork[1], &rwork[*n], &c__[
+ ll + c_dim1], ldc);
+ }
+
+/* Test convergence */
+
+ if ((d__1 = e[ll], abs(d__1)) <= thresh) {
+ e[ll] = 0.;
+ }
+ }
+ } else {
+
+/* Use nonzero shift */
+
+ if (idir == 1) {
+
+/* Chase bulge from top to bottom */
+/* Save cosines and sines for later singular vector updates */
+
+ f = ((d__1 = d__[ll], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[
+ ll]) + shift / d__[ll]);
+ g = e[ll];
+ i__1 = m - 1;
+ for (i__ = ll; i__ <= i__1; ++i__) {
+ dlartg_(&f, &g, &cosr, &sinr, &r__);
+ if (i__ > ll) {
+ e[i__ - 1] = r__;
+ }
+ f = cosr * d__[i__] + sinr * e[i__];
+ e[i__] = cosr * e[i__] - sinr * d__[i__];
+ g = sinr * d__[i__ + 1];
+ d__[i__ + 1] = cosr * d__[i__ + 1];
+ dlartg_(&f, &g, &cosl, &sinl, &r__);
+ d__[i__] = r__;
+ f = cosl * e[i__] + sinl * d__[i__ + 1];
+ d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__];
+ if (i__ < m - 1) {
+ g = sinl * e[i__ + 1];
+ e[i__ + 1] = cosl * e[i__ + 1];
+ }
+ rwork[i__ - ll + 1] = cosr;
+ rwork[i__ - ll + 1 + nm1] = sinr;
+ rwork[i__ - ll + 1 + nm12] = cosl;
+ rwork[i__ - ll + 1 + nm13] = sinl;
+/* L140: */
+ }
+ e[m - 1] = f;
+
+/* Update singular vectors */
+
+ if (*ncvt > 0) {
+ i__1 = m - ll + 1;
+ zlasr_("L", "V", "F", &i__1, ncvt, &rwork[1], &rwork[*n], &vt[
+ ll + vt_dim1], ldvt);
+ }
+ if (*nru > 0) {
+ i__1 = m - ll + 1;
+ zlasr_("R", "V", "F", nru, &i__1, &rwork[nm12 + 1], &rwork[
+ nm13 + 1], &u[ll * u_dim1 + 1], ldu);
+ }
+ if (*ncc > 0) {
+ i__1 = m - ll + 1;
+ zlasr_("L", "V", "F", &i__1, ncc, &rwork[nm12 + 1], &rwork[
+ nm13 + 1], &c__[ll + c_dim1], ldc);
+ }
+
+/* Test convergence */
+
+ if ((d__1 = e[m - 1], abs(d__1)) <= thresh) {
+ e[m - 1] = 0.;
+ }
+
+ } else {
+
+/* Chase bulge from bottom to top */
+/* Save cosines and sines for later singular vector updates */
+
+ f = ((d__1 = d__[m], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[m]
+ ) + shift / d__[m]);
+ g = e[m - 1];
+ i__1 = ll + 1;
+ for (i__ = m; i__ >= i__1; --i__) {
+ dlartg_(&f, &g, &cosr, &sinr, &r__);
+ if (i__ < m) {
+ e[i__] = r__;
+ }
+ f = cosr * d__[i__] + sinr * e[i__ - 1];
+ e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__];
+ g = sinr * d__[i__ - 1];
+ d__[i__ - 1] = cosr * d__[i__ - 1];
+ dlartg_(&f, &g, &cosl, &sinl, &r__);
+ d__[i__] = r__;
+ f = cosl * e[i__ - 1] + sinl * d__[i__ - 1];
+ d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1];
+ if (i__ > ll + 1) {
+ g = sinl * e[i__ - 2];
+ e[i__ - 2] = cosl * e[i__ - 2];
+ }
+ rwork[i__ - ll] = cosr;
+ rwork[i__ - ll + nm1] = -sinr;
+ rwork[i__ - ll + nm12] = cosl;
+ rwork[i__ - ll + nm13] = -sinl;
+/* L150: */
+ }
+ e[ll] = f;
+
+/* Test convergence */
+
+ if ((d__1 = e[ll], abs(d__1)) <= thresh) {
+ e[ll] = 0.;
+ }
+
+/* Update singular vectors if desired */
+
+ if (*ncvt > 0) {
+ i__1 = m - ll + 1;
+ zlasr_("L", "V", "B", &i__1, ncvt, &rwork[nm12 + 1], &rwork[
+ nm13 + 1], &vt[ll + vt_dim1], ldvt);
+ }
+ if (*nru > 0) {
+ i__1 = m - ll + 1;
+ zlasr_("R", "V", "B", nru, &i__1, &rwork[1], &rwork[*n], &u[
+ ll * u_dim1 + 1], ldu);
+ }
+ if (*ncc > 0) {
+ i__1 = m - ll + 1;
+ zlasr_("L", "V", "B", &i__1, ncc, &rwork[1], &rwork[*n], &c__[
+ ll + c_dim1], ldc);
+ }
+ }
+ }
+
+/* QR iteration finished, go back and check convergence */
+
+ goto L60;
+
+/* All singular values converged, so make them positive */
+
+L160:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (d__[i__] < 0.) {
+ d__[i__] = -d__[i__];
+
+/* Change sign of singular vectors, if desired */
+
+ if (*ncvt > 0) {
+ zdscal_(ncvt, &c_b72, &vt[i__ + vt_dim1], ldvt);
+ }
+ }
+/* L170: */
+ }
+
+/* Sort the singular values into decreasing order (insertion sort on */
+/* singular values, but only one transposition per singular vector) */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Scan for smallest D(I) */
+
+ isub = 1;
+ smin = d__[1];
+ i__2 = *n + 1 - i__;
+ for (j = 2; j <= i__2; ++j) {
+ if (d__[j] <= smin) {
+ isub = j;
+ smin = d__[j];
+ }
+/* L180: */
+ }
+ if (isub != *n + 1 - i__) {
+
+/* Swap singular values and vectors */
+
+ d__[isub] = d__[*n + 1 - i__];
+ d__[*n + 1 - i__] = smin;
+ if (*ncvt > 0) {
+ zswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[*n + 1 - i__ +
+ vt_dim1], ldvt);
+ }
+ if (*nru > 0) {
+ zswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[(*n + 1 - i__) *
+ u_dim1 + 1], &c__1);
+ }
+ if (*ncc > 0) {
+ zswap_(ncc, &c__[isub + c_dim1], ldc, &c__[*n + 1 - i__ +
+ c_dim1], ldc);
+ }
+ }
+/* L190: */
+ }
+ goto L220;
+
+/* Maximum number of iterations exceeded, failure to converge */
+
+L200:
+ *info = 0;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (e[i__] != 0.) {
+ ++(*info);
+ }
+/* L210: */
+ }
+L220:
+ return 0;
+
+/* End of ZBDSQR */
+
+} /* zbdsqr_ */
diff --git a/SRC/zcgesv.c b/SRC/zcgesv.c
new file mode 100644
index 0000000..796322c
--- /dev/null
+++ b/SRC/zcgesv.c
@@ -0,0 +1,432 @@
+/* zcgesv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {-1.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zcgesv_(integer *n, integer *nrhs, doublecomplex *a,
+ integer *lda, integer *ipiv, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublecomplex *work, complex *swork,
+ doublereal *rwork, integer *iter, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, work_dim1, work_offset,
+ x_dim1, x_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__;
+ doublereal cte, eps, anrm;
+ integer ptsa;
+ doublereal rnrm, xnrm;
+ integer ptsx, iiter;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), clag2z_(
+ integer *, integer *, complex *, integer *, doublecomplex *,
+ integer *, integer *), zlag2c_(integer *, integer *,
+ doublecomplex *, integer *, complex *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int cgetrf_(integer *, integer *, complex *,
+ integer *, integer *, integer *), xerbla_(char *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int cgetrs_(char *, integer *, integer *, complex
+ *, integer *, integer *, complex *, integer *, integer *);
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zgetrf_(integer *, integer *, doublecomplex *, integer *, integer
+ *, integer *), zgetrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *);
+
+
+/* -- LAPACK PROTOTYPE driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCGESV computes the solution to a complex system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */
+
+/* ZCGESV first attempts to factorize the matrix in COMPLEX and use this */
+/* factorization within an iterative refinement procedure to produce a */
+/* solution with COMPLEX*16 normwise backward error quality (see below). */
+/* If the approach fails the method switches to a COMPLEX*16 */
+/* factorization and solve. */
+
+/* The iterative refinement is not going to be a winning strategy if */
+/* the ratio COMPLEX performance over COMPLEX*16 performance is too */
+/* small. A reasonable strategy should take the number of right-hand */
+/* sides and the size of the matrix into account. This might be done */
+/* with a call to ILAENV in the future. Up to now, we always try */
+/* iterative refinement. */
+
+/* The iterative refinement process is stopped if */
+/* ITER > ITERMAX */
+/* or for all the RHS we have: */
+/* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX */
+/* where */
+/* o ITER is the number of the current iteration in the iterative */
+/* refinement process */
+/* o RNRM is the infinity-norm of the residual */
+/* o XNRM is the infinity-norm of the solution */
+/* o ANRM is the infinity-operator-norm of the matrix A */
+/* o EPS is the machine epsilon returned by DLAMCH('Epsilon') */
+/* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 */
+/* respectively. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input or input/ouptut) COMPLEX*16 array, */
+/* dimension (LDA,N) */
+/* On entry, the N-by-N coefficient matrix A. */
+/* On exit, if iterative refinement has been successfully used */
+/* (INFO.EQ.0 and ITER.GE.0, see description below), then A is */
+/* unchanged, if double precision factorization has been used */
+/* (INFO.EQ.0 and ITER.LT.0, see description below), then the */
+/* array A contains the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* The pivot indices that define the permutation matrix P; */
+/* row i of the matrix was interchanged with row IPIV(i). */
+/* Corresponds either to the single precision factorization */
+/* (if INFO.EQ.0 and ITER.GE.0) or the double precision */
+/* factorization (if INFO.EQ.0 and ITER.LT.0). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* If INFO = 0, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N*NRHS) */
+/* This array is used to hold the residual vectors. */
+
+/* SWORK (workspace) COMPLEX array, dimension (N*(N+NRHS)) */
+/* This array is used to use the single precision matrix and the */
+/* right-hand sides or solutions in single precision. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* ITER (output) INTEGER */
+/* < 0: iterative refinement has failed, COMPLEX*16 */
+/* factorization has been performed */
+/* -1 : the routine fell back to full precision for */
+/* implementation- or machine-specific reasons */
+/* -2 : narrowing the precision induced an overflow, */
+/* the routine fell back to full precision */
+/* -3 : failure of CGETRF */
+/* -31: stop the iterative refinement after the 30th */
+/* iterations */
+/* > 0: iterative refinement has been sucessfully used. */
+/* Returns the number of iterations */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) computed in COMPLEX*16 is exactly */
+/* zero. The factorization has been completed, but the */
+/* factor U is exactly singular, so the solution */
+/* could not be computed. */
+
+/* ========= */
+
+/* .. Parameters .. */
+
+
+
+
+/* .. Local Scalars .. */
+
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ work_dim1 = *n;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --swork;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ *iter = 0;
+
+/* Test the input parameters. */
+
+ if (*n < 0) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldx < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZCGESV", &i__1);
+ return 0;
+ }
+
+/* Quick return if (N.EQ.0). */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Skip single precision iterative refinement if a priori slower */
+/* than double precision factorization. */
+
+ if (FALSE_) {
+ *iter = -1;
+ goto L40;
+ }
+
+/* Compute some constants. */
+
+ anrm = zlange_("I", n, n, &a[a_offset], lda, &rwork[1]);
+ eps = dlamch_("Epsilon");
+ cte = anrm * eps * sqrt((doublereal) (*n)) * 1.;
+
+/* Set the indices PTSA, PTSX for referencing SA and SX in SWORK. */
+
+ ptsa = 1;
+ ptsx = ptsa + *n * *n;
+
+/* Convert B from double precision to single precision and store the */
+/* result in SX. */
+
+ zlag2c_(n, nrhs, &b[b_offset], ldb, &swork[ptsx], n, info);
+
+ if (*info != 0) {
+ *iter = -2;
+ goto L40;
+ }
+
+/* Convert A from double precision to single precision and store the */
+/* result in SA. */
+
+ zlag2c_(n, n, &a[a_offset], lda, &swork[ptsa], n, info);
+
+ if (*info != 0) {
+ *iter = -2;
+ goto L40;
+ }
+
+/* Compute the LU factorization of SA. */
+
+ cgetrf_(n, n, &swork[ptsa], n, &ipiv[1], info);
+
+ if (*info != 0) {
+ *iter = -3;
+ goto L40;
+ }
+
+/* Solve the system SA*SX = SB. */
+
+ cgetrs_("No transpose", n, nrhs, &swork[ptsa], n, &ipiv[1], &swork[ptsx],
+ n, info);
+
+/* Convert SX back to double precision */
+
+ clag2z_(n, nrhs, &swork[ptsx], n, &x[x_offset], ldx, info);
+
+/* Compute R = B - AX (R is WORK). */
+
+ zlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n);
+
+ zgemm_("No Transpose", "No Transpose", n, nrhs, n, &c_b1, &a[a_offset],
+ lda, &x[x_offset], ldx, &c_b2, &work[work_offset], n);
+
+/* Check whether the NRHS normwise backward errors satisfy the */
+/* stopping criterion. If yes, set ITER=0 and return. */
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = izamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1;
+ xnrm = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[izamax_(n, &
+ x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1]), abs(d__2));
+ i__2 = izamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ *
+ work_dim1;
+ rnrm = (d__1 = work[i__2].r, abs(d__1)) + (d__2 = d_imag(&work[
+ izamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ *
+ work_dim1]), abs(d__2));
+ if (rnrm > xnrm * cte) {
+ goto L10;
+ }
+ }
+
+/* If we are here, the NRHS normwise backward errors satisfy the */
+/* stopping criterion. We are good to exit. */
+
+ *iter = 0;
+ return 0;
+
+L10:
+
+ for (iiter = 1; iiter <= 30; ++iiter) {
+
+/* Convert R (in WORK) from double precision to single precision */
+/* and store the result in SX. */
+
+ zlag2c_(n, nrhs, &work[work_offset], n, &swork[ptsx], n, info);
+
+ if (*info != 0) {
+ *iter = -2;
+ goto L40;
+ }
+
+/* Solve the system SA*SX = SR. */
+
+ cgetrs_("No transpose", n, nrhs, &swork[ptsa], n, &ipiv[1], &swork[
+ ptsx], n, info);
+
+/* Convert SX back to double precision and update the current */
+/* iterate. */
+
+ clag2z_(n, nrhs, &swork[ptsx], n, &work[work_offset], n, info);
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ zaxpy_(n, &c_b2, &work[i__ * work_dim1 + 1], &c__1, &x[i__ *
+ x_dim1 + 1], &c__1);
+ }
+
+/* Compute R = B - AX (R is WORK). */
+
+ zlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n);
+
+ zgemm_("No Transpose", "No Transpose", n, nrhs, n, &c_b1, &a[a_offset]
+, lda, &x[x_offset], ldx, &c_b2, &work[work_offset], n);
+
+/* Check whether the NRHS normwise backward errors satisfy the */
+/* stopping criterion. If yes, set ITER=IITER>0 and return. */
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = izamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1;
+ xnrm = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[izamax_(
+ n, &x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1]), abs(
+ d__2));
+ i__2 = izamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ *
+ work_dim1;
+ rnrm = (d__1 = work[i__2].r, abs(d__1)) + (d__2 = d_imag(&work[
+ izamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ *
+ work_dim1]), abs(d__2));
+ if (rnrm > xnrm * cte) {
+ goto L20;
+ }
+ }
+
+/* If we are here, the NRHS normwise backward errors satisfy the */
+/* stopping criterion, we are good to exit. */
+
+ *iter = iiter;
+
+ return 0;
+
+L20:
+
+/* L30: */
+ ;
+ }
+
+/* If we are at this place of the code, this is because we have */
+/* performed ITER=ITERMAX iterations and never satisified the stopping */
+/* criterion, set up the ITER flag accordingly and follow up on double */
+/* precision routine. */
+
+ *iter = -31;
+
+L40:
+
+/* Single-precision iterative refinement failed to converge to a */
+/* satisfactory solution, so we resort to double precision. */
+
+ zgetrf_(n, n, &a[a_offset], lda, &ipiv[1], info);
+
+ if (*info != 0) {
+ return 0;
+ }
+
+ zlacpy_("All", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ zgetrs_("No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &x[x_offset]
+, ldx, info);
+
+ return 0;
+
+/* End of ZCGESV. */
+
+} /* zcgesv_ */
diff --git a/SRC/zcposv.c b/SRC/zcposv.c
new file mode 100644
index 0000000..5a2d9c9
--- /dev/null
+++ b/SRC/zcposv.c
@@ -0,0 +1,440 @@
+/* zcposv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {-1.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zcposv_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublecomplex *work, complex *swork,
+ doublereal *rwork, integer *iter, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, work_dim1, work_offset,
+ x_dim1, x_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__;
+ doublereal cte, eps, anrm;
+ integer ptsa;
+ doublereal rnrm, xnrm;
+ integer ptsx;
+ extern logical lsame_(char *, char *);
+ integer iiter;
+ extern /* Subroutine */ int zhemm_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *), zlag2c_(integer *,
+ integer *, doublecomplex *, integer *, complex *, integer *,
+ integer *), clag2z_(integer *, integer *, complex *, integer *,
+ doublecomplex *, integer *, integer *), zlat2c_(char *, integer *,
+ doublecomplex *, integer *, complex *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int cpotrf_(char *, integer *, complex *, integer
+ *, integer *), zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ cpotrs_(char *, integer *, integer *, complex *, integer *,
+ complex *, integer *, integer *), zpotrf_(char *, integer
+ *, doublecomplex *, integer *, integer *), zpotrs_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *, integer *);
+
+
+/* -- LAPACK PROTOTYPE driver routine (version 3.2.1) -- */
+
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCPOSV computes the solution to a complex system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N Hermitian positive definite matrix and X and B */
+/* are N-by-NRHS matrices. */
+
+/* ZCPOSV first attempts to factorize the matrix in COMPLEX and use this */
+/* factorization within an iterative refinement procedure to produce a */
+/* solution with COMPLEX*16 normwise backward error quality (see below). */
+/* If the approach fails the method switches to a COMPLEX*16 */
+/* factorization and solve. */
+
+/* The iterative refinement is not going to be a winning strategy if */
+/* the ratio COMPLEX performance over COMPLEX*16 performance is too */
+/* small. A reasonable strategy should take the number of right-hand */
+/* sides and the size of the matrix into account. This might be done */
+/* with a call to ILAENV in the future. Up to now, we always try */
+/* iterative refinement. */
+
+/* The iterative refinement process is stopped if */
+/* ITER > ITERMAX */
+/* or for all the RHS we have: */
+/* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX */
+/* where */
+/* o ITER is the number of the current iteration in the iterative */
+/* refinement process */
+/* o RNRM is the infinity-norm of the residual */
+/* o XNRM is the infinity-norm of the solution */
+/* o ANRM is the infinity-operator-norm of the matrix A */
+/* o EPS is the machine epsilon returned by DLAMCH('Epsilon') */
+/* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 */
+/* respectively. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input or input/ouptut) COMPLEX*16 array, */
+/* dimension (LDA,N) */
+/* On entry, the Hermitian matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* Note that the imaginary parts of the diagonal */
+/* elements need not be set and are assumed to be zero. */
+
+/* On exit, if iterative refinement has been successfully used */
+/* (INFO.EQ.0 and ITER.GE.0, see description below), then A is */
+/* unchanged, if double precision factorization has been used */
+/* (INFO.EQ.0 and ITER.LT.0, see description below), then the */
+/* array A contains the factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* If INFO = 0, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N*NRHS) */
+/* This array is used to hold the residual vectors. */
+
+/* SWORK (workspace) COMPLEX array, dimension (N*(N+NRHS)) */
+/* This array is used to use the single precision matrix and the */
+/* right-hand sides or solutions in single precision. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* ITER (output) INTEGER */
+/* < 0: iterative refinement has failed, COMPLEX*16 */
+/* factorization has been performed */
+/* -1 : the routine fell back to full precision for */
+/* implementation- or machine-specific reasons */
+/* -2 : narrowing the precision induced an overflow, */
+/* the routine fell back to full precision */
+/* -3 : failure of CPOTRF */
+/* -31: stop the iterative refinement after the 30th */
+/* iterations */
+/* > 0: iterative refinement has been sucessfully used. */
+/* Returns the number of iterations */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i of */
+/* (COMPLEX*16) A is not positive definite, so the */
+/* factorization could not be completed, and the solution */
+/* has not been computed. */
+
+/* ========= */
+
+/* .. Parameters .. */
+
+
+
+
+/* .. Local Scalars .. */
+
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ work_dim1 = *n;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --swork;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ *iter = 0;
+
+/* Test the input parameters. */
+
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldx < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZCPOSV", &i__1);
+ return 0;
+ }
+
+/* Quick return if (N.EQ.0). */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Skip single precision iterative refinement if a priori slower */
+/* than double precision factorization. */
+
+ if (FALSE_) {
+ *iter = -1;
+ goto L40;
+ }
+
+/* Compute some constants. */
+
+ anrm = zlanhe_("I", uplo, n, &a[a_offset], lda, &rwork[1]);
+ eps = dlamch_("Epsilon");
+ cte = anrm * eps * sqrt((doublereal) (*n)) * 1.;
+
+/* Set the indices PTSA, PTSX for referencing SA and SX in SWORK. */
+
+ ptsa = 1;
+ ptsx = ptsa + *n * *n;
+
+/* Convert B from double precision to single precision and store the */
+/* result in SX. */
+
+ zlag2c_(n, nrhs, &b[b_offset], ldb, &swork[ptsx], n, info);
+
+ if (*info != 0) {
+ *iter = -2;
+ goto L40;
+ }
+
+/* Convert A from double precision to single precision and store the */
+/* result in SA. */
+
+ zlat2c_(uplo, n, &a[a_offset], lda, &swork[ptsa], n, info);
+
+ if (*info != 0) {
+ *iter = -2;
+ goto L40;
+ }
+
+/* Compute the Cholesky factorization of SA. */
+
+ cpotrf_(uplo, n, &swork[ptsa], n, info);
+
+ if (*info != 0) {
+ *iter = -3;
+ goto L40;
+ }
+
+/* Solve the system SA*SX = SB. */
+
+ cpotrs_(uplo, n, nrhs, &swork[ptsa], n, &swork[ptsx], n, info);
+
+/* Convert SX back to COMPLEX*16 */
+
+ clag2z_(n, nrhs, &swork[ptsx], n, &x[x_offset], ldx, info);
+
+/* Compute R = B - AX (R is WORK). */
+
+ zlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n);
+
+ zhemm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset], ldx,
+ &c_b2, &work[work_offset], n);
+
+/* Check whether the NRHS normwise backward errors satisfy the */
+/* stopping criterion. If yes, set ITER=0 and return. */
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = izamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1;
+ xnrm = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[izamax_(n, &
+ x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1]), abs(d__2));
+ i__2 = izamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ *
+ work_dim1;
+ rnrm = (d__1 = work[i__2].r, abs(d__1)) + (d__2 = d_imag(&work[
+ izamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ *
+ work_dim1]), abs(d__2));
+ if (rnrm > xnrm * cte) {
+ goto L10;
+ }
+ }
+
+/* If we are here, the NRHS normwise backward errors satisfy the */
+/* stopping criterion. We are good to exit. */
+
+ *iter = 0;
+ return 0;
+
+L10:
+
+ for (iiter = 1; iiter <= 30; ++iiter) {
+
+/* Convert R (in WORK) from double precision to single precision */
+/* and store the result in SX. */
+
+ zlag2c_(n, nrhs, &work[work_offset], n, &swork[ptsx], n, info);
+
+ if (*info != 0) {
+ *iter = -2;
+ goto L40;
+ }
+
+/* Solve the system SA*SX = SR. */
+
+ cpotrs_(uplo, n, nrhs, &swork[ptsa], n, &swork[ptsx], n, info);
+
+/* Convert SX back to double precision and update the current */
+/* iterate. */
+
+ clag2z_(n, nrhs, &swork[ptsx], n, &work[work_offset], n, info);
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ zaxpy_(n, &c_b2, &work[i__ * work_dim1 + 1], &c__1, &x[i__ *
+ x_dim1 + 1], &c__1);
+ }
+
+/* Compute R = B - AX (R is WORK). */
+
+ zlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n);
+
+ zhemm_("L", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset],
+ ldx, &c_b2, &work[work_offset], n);
+
+/* Check whether the NRHS normwise backward errors satisfy the */
+/* stopping criterion. If yes, set ITER=IITER>0 and return. */
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = izamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1;
+ xnrm = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[izamax_(
+ n, &x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1]), abs(
+ d__2));
+ i__2 = izamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ *
+ work_dim1;
+ rnrm = (d__1 = work[i__2].r, abs(d__1)) + (d__2 = d_imag(&work[
+ izamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ *
+ work_dim1]), abs(d__2));
+ if (rnrm > xnrm * cte) {
+ goto L20;
+ }
+ }
+
+/* If we are here, the NRHS normwise backward errors satisfy the */
+/* stopping criterion, we are good to exit. */
+
+ *iter = iiter;
+
+ return 0;
+
+L20:
+
+/* L30: */
+ ;
+ }
+
+/* If we are at this place of the code, this is because we have */
+/* performed ITER=ITERMAX iterations and never satisified the */
+/* stopping criterion, set up the ITER flag accordingly and follow */
+/* up on double precision routine. */
+
+ *iter = -31;
+
+L40:
+
+/* Single-precision iterative refinement failed to converge to a */
+/* satisfactory solution, so we resort to double precision. */
+
+ zpotrf_(uplo, n, &a[a_offset], lda, info);
+
+ if (*info != 0) {
+ return 0;
+ }
+
+ zlacpy_("All", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ zpotrs_(uplo, n, nrhs, &a[a_offset], lda, &x[x_offset], ldx, info);
+
+ return 0;
+
+/* End of ZCPOSV. */
+
+} /* zcposv_ */
diff --git a/SRC/zdrscl.c b/SRC/zdrscl.c
new file mode 100644
index 0000000..a21bd77
--- /dev/null
+++ b/SRC/zdrscl.c
@@ -0,0 +1,135 @@
+/* zdrscl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zdrscl_(integer *n, doublereal *sa, doublecomplex *sx,
+ integer *incx)
+{
+ doublereal mul, cden;
+ logical done;
+ doublereal cnum, cden1, cnum1;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ doublereal bignum, smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRSCL multiplies an n-element complex vector x by the real scalar */
+/* 1/a. This is done without overflow or underflow as long as */
+/* the final result x/a does not overflow or underflow. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of components of the vector x. */
+
+/* SA (input) DOUBLE PRECISION */
+/* The scalar a which is used to divide each component of x. */
+/* SA must be >= 0, or the subroutine will divide by zero. */
+
+/* SX (input/output) COMPLEX*16 array, dimension */
+/* (1+(N-1)*abs(INCX)) */
+/* The n-element vector x. */
+
+/* INCX (input) INTEGER */
+/* The increment between successive values of the vector SX. */
+/* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --sx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Initialize the denominator to SA and the numerator to 1. */
+
+ cden = *sa;
+ cnum = 1.;
+
+L10:
+ cden1 = cden * smlnum;
+ cnum1 = cnum / bignum;
+ if (abs(cden1) > abs(cnum) && cnum != 0.) {
+
+/* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. */
+
+ mul = smlnum;
+ done = FALSE_;
+ cden = cden1;
+ } else if (abs(cnum1) > abs(cden)) {
+
+/* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. */
+
+ mul = bignum;
+ done = FALSE_;
+ cnum = cnum1;
+ } else {
+
+/* Multiply X by CNUM / CDEN and return. */
+
+ mul = cnum / cden;
+ done = TRUE_;
+ }
+
+/* Scale the vector X by MUL */
+
+ zdscal_(n, &mul, &sx[1], incx);
+
+ if (! done) {
+ goto L10;
+ }
+
+ return 0;
+
+/* End of ZDRSCL */
+
+} /* zdrscl_ */
diff --git a/SRC/zgbbrd.c b/SRC/zgbbrd.c
new file mode 100644
index 0000000..64be234
--- /dev/null
+++ b/SRC/zgbbrd.c
@@ -0,0 +1,654 @@
+/* zgbbrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zgbbrd_(char *vect, integer *m, integer *n, integer *ncc,
+ integer *kl, integer *ku, doublecomplex *ab, integer *ldab,
+ doublereal *d__, doublereal *e, doublecomplex *q, integer *ldq,
+ doublecomplex *pt, integer *ldpt, doublecomplex *c__, integer *ldc,
+ doublecomplex *work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, c_dim1, c_offset, pt_dim1, pt_offset, q_dim1,
+ q_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ double z_abs(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, l;
+ doublecomplex t;
+ integer j1, j2, kb;
+ doublecomplex ra, rb;
+ doublereal rc;
+ integer kk, ml, nr, mu;
+ doublecomplex rs;
+ integer kb1, ml0, mu0, klm, kun, nrt, klu1, inca;
+ doublereal abst;
+ extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *);
+ extern logical lsame_(char *, char *);
+ logical wantb, wantc;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ integer minmn;
+ logical wantq;
+ extern /* Subroutine */ int xerbla_(char *, integer *), zlaset_(
+ char *, integer *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *), zlartg_(doublecomplex *,
+ doublecomplex *, doublereal *, doublecomplex *, doublecomplex *),
+ zlargv_(integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, integer *);
+ logical wantpt;
+ extern /* Subroutine */ int zlartv_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGBBRD reduces a complex general m-by-n band matrix A to real upper */
+/* bidiagonal form B by a unitary transformation: Q' * A * P = B. */
+
+/* The routine computes B, and optionally forms Q or P', or computes */
+/* Q'*C for a given matrix C. */
+
+/* Arguments */
+/* ========= */
+
+/* VECT (input) CHARACTER*1 */
+/* Specifies whether or not the matrices Q and P' are to be */
+/* formed. */
+/* = 'N': do not form Q or P'; */
+/* = 'Q': form Q only; */
+/* = 'P': form P' only; */
+/* = 'B': form both. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NCC (input) INTEGER */
+/* The number of columns of the matrix C. NCC >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals of the matrix A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals of the matrix A. KU >= 0. */
+
+/* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) */
+/* On entry, the m-by-n band matrix A, stored in rows 1 to */
+/* KL+KU+1. The j-th column of A is stored in the j-th column of */
+/* the array AB as follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). */
+/* On exit, A is overwritten by values generated during the */
+/* reduction. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array A. LDAB >= KL+KU+1. */
+
+/* D (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The diagonal elements of the bidiagonal matrix B. */
+
+/* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) */
+/* The superdiagonal elements of the bidiagonal matrix B. */
+
+/* Q (output) COMPLEX*16 array, dimension (LDQ,M) */
+/* If VECT = 'Q' or 'B', the m-by-m unitary matrix Q. */
+/* If VECT = 'N' or 'P', the array Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. */
+/* LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise. */
+
+/* PT (output) COMPLEX*16 array, dimension (LDPT,N) */
+/* If VECT = 'P' or 'B', the n-by-n unitary matrix P'. */
+/* If VECT = 'N' or 'Q', the array PT is not referenced. */
+
+/* LDPT (input) INTEGER */
+/* The leading dimension of the array PT. */
+/* LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise. */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC,NCC) */
+/* On entry, an m-by-ncc matrix C. */
+/* On exit, C is overwritten by Q'*C. */
+/* C is not referenced if NCC = 0. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. */
+/* LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (max(M,N)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(M,N)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --d__;
+ --e;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ pt_dim1 = *ldpt;
+ pt_offset = 1 + pt_dim1;
+ pt -= pt_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ wantb = lsame_(vect, "B");
+ wantq = lsame_(vect, "Q") || wantb;
+ wantpt = lsame_(vect, "P") || wantb;
+ wantc = *ncc > 0;
+ klu1 = *kl + *ku + 1;
+ *info = 0;
+ if (! wantq && ! wantpt && ! lsame_(vect, "N")) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ncc < 0) {
+ *info = -4;
+ } else if (*kl < 0) {
+ *info = -5;
+ } else if (*ku < 0) {
+ *info = -6;
+ } else if (*ldab < klu1) {
+ *info = -8;
+ } else if (*ldq < 1 || wantq && *ldq < max(1,*m)) {
+ *info = -12;
+ } else if (*ldpt < 1 || wantpt && *ldpt < max(1,*n)) {
+ *info = -14;
+ } else if (*ldc < 1 || wantc && *ldc < max(1,*m)) {
+ *info = -16;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGBBRD", &i__1);
+ return 0;
+ }
+
+/* Initialize Q and P' to the unit matrix, if needed */
+
+ if (wantq) {
+ zlaset_("Full", m, m, &c_b1, &c_b2, &q[q_offset], ldq);
+ }
+ if (wantpt) {
+ zlaset_("Full", n, n, &c_b1, &c_b2, &pt[pt_offset], ldpt);
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ minmn = min(*m,*n);
+
+ if (*kl + *ku > 1) {
+
+/* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce */
+/* first to lower bidiagonal form and then transform to upper */
+/* bidiagonal */
+
+ if (*ku > 0) {
+ ml0 = 1;
+ mu0 = 2;
+ } else {
+ ml0 = 2;
+ mu0 = 1;
+ }
+
+/* Wherever possible, plane rotations are generated and applied in */
+/* vector operations of length NR over the index set J1:J2:KLU1. */
+
+/* The complex sines of the plane rotations are stored in WORK, */
+/* and the real cosines in RWORK. */
+
+/* Computing MIN */
+ i__1 = *m - 1;
+ klm = min(i__1,*kl);
+/* Computing MIN */
+ i__1 = *n - 1;
+ kun = min(i__1,*ku);
+ kb = klm + kun;
+ kb1 = kb + 1;
+ inca = kb1 * *ldab;
+ nr = 0;
+ j1 = klm + 2;
+ j2 = 1 - kun;
+
+ i__1 = minmn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Reduce i-th column and i-th row of matrix to bidiagonal form */
+
+ ml = klm + 1;
+ mu = kun + 1;
+ i__2 = kb;
+ for (kk = 1; kk <= i__2; ++kk) {
+ j1 += kb;
+ j2 += kb;
+
+/* generate plane rotations to annihilate nonzero elements */
+/* which have been created below the band */
+
+ if (nr > 0) {
+ zlargv_(&nr, &ab[klu1 + (j1 - klm - 1) * ab_dim1], &inca,
+ &work[j1], &kb1, &rwork[j1], &kb1);
+ }
+
+/* apply plane rotations from the left */
+
+ i__3 = kb;
+ for (l = 1; l <= i__3; ++l) {
+ if (j2 - klm + l - 1 > *n) {
+ nrt = nr - 1;
+ } else {
+ nrt = nr;
+ }
+ if (nrt > 0) {
+ zlartv_(&nrt, &ab[klu1 - l + (j1 - klm + l - 1) *
+ ab_dim1], &inca, &ab[klu1 - l + 1 + (j1 - klm
+ + l - 1) * ab_dim1], &inca, &rwork[j1], &work[
+ j1], &kb1);
+ }
+/* L10: */
+ }
+
+ if (ml > ml0) {
+ if (ml <= *m - i__ + 1) {
+
+/* generate plane rotation to annihilate a(i+ml-1,i) */
+/* within the band, and apply rotation from the left */
+
+ zlartg_(&ab[*ku + ml - 1 + i__ * ab_dim1], &ab[*ku +
+ ml + i__ * ab_dim1], &rwork[i__ + ml - 1], &
+ work[i__ + ml - 1], &ra);
+ i__3 = *ku + ml - 1 + i__ * ab_dim1;
+ ab[i__3].r = ra.r, ab[i__3].i = ra.i;
+ if (i__ < *n) {
+/* Computing MIN */
+ i__4 = *ku + ml - 2, i__5 = *n - i__;
+ i__3 = min(i__4,i__5);
+ i__6 = *ldab - 1;
+ i__7 = *ldab - 1;
+ zrot_(&i__3, &ab[*ku + ml - 2 + (i__ + 1) *
+ ab_dim1], &i__6, &ab[*ku + ml - 1 + (i__
+ + 1) * ab_dim1], &i__7, &rwork[i__ + ml -
+ 1], &work[i__ + ml - 1]);
+ }
+ }
+ ++nr;
+ j1 -= kb1;
+ }
+
+ if (wantq) {
+
+/* accumulate product of plane rotations in Q */
+
+ i__3 = j2;
+ i__4 = kb1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4)
+ {
+ d_cnjg(&z__1, &work[j]);
+ zrot_(m, &q[(j - 1) * q_dim1 + 1], &c__1, &q[j *
+ q_dim1 + 1], &c__1, &rwork[j], &z__1);
+/* L20: */
+ }
+ }
+
+ if (wantc) {
+
+/* apply plane rotations to C */
+
+ i__4 = j2;
+ i__3 = kb1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3)
+ {
+ zrot_(ncc, &c__[j - 1 + c_dim1], ldc, &c__[j + c_dim1]
+, ldc, &rwork[j], &work[j]);
+/* L30: */
+ }
+ }
+
+ if (j2 + kun > *n) {
+
+/* adjust J2 to keep within the bounds of the matrix */
+
+ --nr;
+ j2 -= kb1;
+ }
+
+ i__3 = j2;
+ i__4 = kb1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+
+/* create nonzero element a(j-1,j+ku) above the band */
+/* and store it in WORK(n+1:2*n) */
+
+ i__5 = j + kun;
+ i__6 = j;
+ i__7 = (j + kun) * ab_dim1 + 1;
+ z__1.r = work[i__6].r * ab[i__7].r - work[i__6].i * ab[
+ i__7].i, z__1.i = work[i__6].r * ab[i__7].i +
+ work[i__6].i * ab[i__7].r;
+ work[i__5].r = z__1.r, work[i__5].i = z__1.i;
+ i__5 = (j + kun) * ab_dim1 + 1;
+ i__6 = j;
+ i__7 = (j + kun) * ab_dim1 + 1;
+ z__1.r = rwork[i__6] * ab[i__7].r, z__1.i = rwork[i__6] *
+ ab[i__7].i;
+ ab[i__5].r = z__1.r, ab[i__5].i = z__1.i;
+/* L40: */
+ }
+
+/* generate plane rotations to annihilate nonzero elements */
+/* which have been generated above the band */
+
+ if (nr > 0) {
+ zlargv_(&nr, &ab[(j1 + kun - 1) * ab_dim1 + 1], &inca, &
+ work[j1 + kun], &kb1, &rwork[j1 + kun], &kb1);
+ }
+
+/* apply plane rotations from the right */
+
+ i__4 = kb;
+ for (l = 1; l <= i__4; ++l) {
+ if (j2 + l - 1 > *m) {
+ nrt = nr - 1;
+ } else {
+ nrt = nr;
+ }
+ if (nrt > 0) {
+ zlartv_(&nrt, &ab[l + 1 + (j1 + kun - 1) * ab_dim1], &
+ inca, &ab[l + (j1 + kun) * ab_dim1], &inca, &
+ rwork[j1 + kun], &work[j1 + kun], &kb1);
+ }
+/* L50: */
+ }
+
+ if (ml == ml0 && mu > mu0) {
+ if (mu <= *n - i__ + 1) {
+
+/* generate plane rotation to annihilate a(i,i+mu-1) */
+/* within the band, and apply rotation from the right */
+
+ zlartg_(&ab[*ku - mu + 3 + (i__ + mu - 2) * ab_dim1],
+ &ab[*ku - mu + 2 + (i__ + mu - 1) * ab_dim1],
+ &rwork[i__ + mu - 1], &work[i__ + mu - 1], &
+ ra);
+ i__4 = *ku - mu + 3 + (i__ + mu - 2) * ab_dim1;
+ ab[i__4].r = ra.r, ab[i__4].i = ra.i;
+/* Computing MIN */
+ i__3 = *kl + mu - 2, i__5 = *m - i__;
+ i__4 = min(i__3,i__5);
+ zrot_(&i__4, &ab[*ku - mu + 4 + (i__ + mu - 2) *
+ ab_dim1], &c__1, &ab[*ku - mu + 3 + (i__ + mu
+ - 1) * ab_dim1], &c__1, &rwork[i__ + mu - 1],
+ &work[i__ + mu - 1]);
+ }
+ ++nr;
+ j1 -= kb1;
+ }
+
+ if (wantpt) {
+
+/* accumulate product of plane rotations in P' */
+
+ i__4 = j2;
+ i__3 = kb1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3)
+ {
+ d_cnjg(&z__1, &work[j + kun]);
+ zrot_(n, &pt[j + kun - 1 + pt_dim1], ldpt, &pt[j +
+ kun + pt_dim1], ldpt, &rwork[j + kun], &z__1);
+/* L60: */
+ }
+ }
+
+ if (j2 + kb > *m) {
+
+/* adjust J2 to keep within the bounds of the matrix */
+
+ --nr;
+ j2 -= kb1;
+ }
+
+ i__3 = j2;
+ i__4 = kb1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+
+/* create nonzero element a(j+kl+ku,j+ku-1) below the */
+/* band and store it in WORK(1:n) */
+
+ i__5 = j + kb;
+ i__6 = j + kun;
+ i__7 = klu1 + (j + kun) * ab_dim1;
+ z__1.r = work[i__6].r * ab[i__7].r - work[i__6].i * ab[
+ i__7].i, z__1.i = work[i__6].r * ab[i__7].i +
+ work[i__6].i * ab[i__7].r;
+ work[i__5].r = z__1.r, work[i__5].i = z__1.i;
+ i__5 = klu1 + (j + kun) * ab_dim1;
+ i__6 = j + kun;
+ i__7 = klu1 + (j + kun) * ab_dim1;
+ z__1.r = rwork[i__6] * ab[i__7].r, z__1.i = rwork[i__6] *
+ ab[i__7].i;
+ ab[i__5].r = z__1.r, ab[i__5].i = z__1.i;
+/* L70: */
+ }
+
+ if (ml > ml0) {
+ --ml;
+ } else {
+ --mu;
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+
+ if (*ku == 0 && *kl > 0) {
+
+/* A has been reduced to complex lower bidiagonal form */
+
+/* Transform lower bidiagonal form to upper bidiagonal by applying */
+/* plane rotations from the left, overwriting superdiagonal */
+/* elements on subdiagonal elements */
+
+/* Computing MIN */
+ i__2 = *m - 1;
+ i__1 = min(i__2,*n);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ zlartg_(&ab[i__ * ab_dim1 + 1], &ab[i__ * ab_dim1 + 2], &rc, &rs,
+ &ra);
+ i__2 = i__ * ab_dim1 + 1;
+ ab[i__2].r = ra.r, ab[i__2].i = ra.i;
+ if (i__ < *n) {
+ i__2 = i__ * ab_dim1 + 2;
+ i__4 = (i__ + 1) * ab_dim1 + 1;
+ z__1.r = rs.r * ab[i__4].r - rs.i * ab[i__4].i, z__1.i = rs.r
+ * ab[i__4].i + rs.i * ab[i__4].r;
+ ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
+ i__2 = (i__ + 1) * ab_dim1 + 1;
+ i__4 = (i__ + 1) * ab_dim1 + 1;
+ z__1.r = rc * ab[i__4].r, z__1.i = rc * ab[i__4].i;
+ ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
+ }
+ if (wantq) {
+ d_cnjg(&z__1, &rs);
+ zrot_(m, &q[i__ * q_dim1 + 1], &c__1, &q[(i__ + 1) * q_dim1 +
+ 1], &c__1, &rc, &z__1);
+ }
+ if (wantc) {
+ zrot_(ncc, &c__[i__ + c_dim1], ldc, &c__[i__ + 1 + c_dim1],
+ ldc, &rc, &rs);
+ }
+/* L100: */
+ }
+ } else {
+
+/* A has been reduced to complex upper bidiagonal form or is */
+/* diagonal */
+
+ if (*ku > 0 && *m < *n) {
+
+/* Annihilate a(m,m+1) by applying plane rotations from the */
+/* right */
+
+ i__1 = *ku + (*m + 1) * ab_dim1;
+ rb.r = ab[i__1].r, rb.i = ab[i__1].i;
+ for (i__ = *m; i__ >= 1; --i__) {
+ zlartg_(&ab[*ku + 1 + i__ * ab_dim1], &rb, &rc, &rs, &ra);
+ i__1 = *ku + 1 + i__ * ab_dim1;
+ ab[i__1].r = ra.r, ab[i__1].i = ra.i;
+ if (i__ > 1) {
+ d_cnjg(&z__3, &rs);
+ z__2.r = -z__3.r, z__2.i = -z__3.i;
+ i__1 = *ku + i__ * ab_dim1;
+ z__1.r = z__2.r * ab[i__1].r - z__2.i * ab[i__1].i,
+ z__1.i = z__2.r * ab[i__1].i + z__2.i * ab[i__1]
+ .r;
+ rb.r = z__1.r, rb.i = z__1.i;
+ i__1 = *ku + i__ * ab_dim1;
+ i__2 = *ku + i__ * ab_dim1;
+ z__1.r = rc * ab[i__2].r, z__1.i = rc * ab[i__2].i;
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+ }
+ if (wantpt) {
+ d_cnjg(&z__1, &rs);
+ zrot_(n, &pt[i__ + pt_dim1], ldpt, &pt[*m + 1 + pt_dim1],
+ ldpt, &rc, &z__1);
+ }
+/* L110: */
+ }
+ }
+ }
+
+/* Make diagonal and superdiagonal elements real, storing them in D */
+/* and E */
+
+ i__1 = *ku + 1 + ab_dim1;
+ t.r = ab[i__1].r, t.i = ab[i__1].i;
+ i__1 = minmn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ abst = z_abs(&t);
+ d__[i__] = abst;
+ if (abst != 0.) {
+ z__1.r = t.r / abst, z__1.i = t.i / abst;
+ t.r = z__1.r, t.i = z__1.i;
+ } else {
+ t.r = 1., t.i = 0.;
+ }
+ if (wantq) {
+ zscal_(m, &t, &q[i__ * q_dim1 + 1], &c__1);
+ }
+ if (wantc) {
+ d_cnjg(&z__1, &t);
+ zscal_(ncc, &z__1, &c__[i__ + c_dim1], ldc);
+ }
+ if (i__ < minmn) {
+ if (*ku == 0 && *kl == 0) {
+ e[i__] = 0.;
+ i__2 = (i__ + 1) * ab_dim1 + 1;
+ t.r = ab[i__2].r, t.i = ab[i__2].i;
+ } else {
+ if (*ku == 0) {
+ i__2 = i__ * ab_dim1 + 2;
+ d_cnjg(&z__2, &t);
+ z__1.r = ab[i__2].r * z__2.r - ab[i__2].i * z__2.i,
+ z__1.i = ab[i__2].r * z__2.i + ab[i__2].i *
+ z__2.r;
+ t.r = z__1.r, t.i = z__1.i;
+ } else {
+ i__2 = *ku + (i__ + 1) * ab_dim1;
+ d_cnjg(&z__2, &t);
+ z__1.r = ab[i__2].r * z__2.r - ab[i__2].i * z__2.i,
+ z__1.i = ab[i__2].r * z__2.i + ab[i__2].i *
+ z__2.r;
+ t.r = z__1.r, t.i = z__1.i;
+ }
+ abst = z_abs(&t);
+ e[i__] = abst;
+ if (abst != 0.) {
+ z__1.r = t.r / abst, z__1.i = t.i / abst;
+ t.r = z__1.r, t.i = z__1.i;
+ } else {
+ t.r = 1., t.i = 0.;
+ }
+ if (wantpt) {
+ zscal_(n, &t, &pt[i__ + 1 + pt_dim1], ldpt);
+ }
+ i__2 = *ku + 1 + (i__ + 1) * ab_dim1;
+ d_cnjg(&z__2, &t);
+ z__1.r = ab[i__2].r * z__2.r - ab[i__2].i * z__2.i, z__1.i =
+ ab[i__2].r * z__2.i + ab[i__2].i * z__2.r;
+ t.r = z__1.r, t.i = z__1.i;
+ }
+ }
+/* L120: */
+ }
+ return 0;
+
+/* End of ZGBBRD */
+
+} /* zgbbrd_ */
diff --git a/SRC/zgbcon.c b/SRC/zgbcon.c
new file mode 100644
index 0000000..8f72f3f
--- /dev/null
+++ b/SRC/zgbcon.c
@@ -0,0 +1,307 @@
+/* zgbcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zgbcon_(char *norm, integer *n, integer *kl, integer *ku,
+ doublecomplex *ab, integer *ldab, integer *ipiv, doublereal *anorm,
+ doublereal *rcond, doublecomplex *work, doublereal *rwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer j;
+ doublecomplex t;
+ integer kd, lm, jp, ix, kase, kase1;
+ doublereal scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ logical lnoti;
+ extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), zlacn2_(
+ integer *, doublecomplex *, doublecomplex *, doublereal *,
+ integer *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal ainvnm;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ logical onenrm;
+ extern /* Subroutine */ int zlatbs_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *, doublereal *, integer *), zdrscl_(integer *, doublereal *, doublecomplex *,
+ integer *);
+ char normin[1];
+ doublereal smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGBCON estimates the reciprocal of the condition number of a complex */
+/* general band matrix A, in either the 1-norm or the infinity-norm, */
+/* using the LU factorization computed by ZGBTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as */
+/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by ZGBTRF. U is stored as an upper triangular band */
+/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
+/* the multipliers used during the factorization are stored in */
+/* rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= N, row i of the matrix was */
+/* interchanged with row IPIV(i). */
+
+/* ANORM (input) DOUBLE PRECISION */
+/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */
+/* If NORM = 'I', the infinity-norm of the original matrix A. */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --ipiv;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*ldab < (*kl << 1) + *ku + 1) {
+ *info = -6;
+ } else if (*anorm < 0.) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGBCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.;
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ } else if (*anorm == 0.) {
+ return 0;
+ }
+
+ smlnum = dlamch_("Safe minimum");
+
+/* Estimate the norm of inv(A). */
+
+ ainvnm = 0.;
+ *(unsigned char *)normin = 'N';
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kd = *kl + *ku + 1;
+ lnoti = *kl > 0;
+ kase = 0;
+L10:
+ zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(L). */
+
+ if (lnoti) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *kl, i__3 = *n - j;
+ lm = min(i__2,i__3);
+ jp = ipiv[j];
+ i__2 = jp;
+ t.r = work[i__2].r, t.i = work[i__2].i;
+ if (jp != j) {
+ i__2 = jp;
+ i__3 = j;
+ work[i__2].r = work[i__3].r, work[i__2].i = work[i__3]
+ .i;
+ i__2 = j;
+ work[i__2].r = t.r, work[i__2].i = t.i;
+ }
+ z__1.r = -t.r, z__1.i = -t.i;
+ zaxpy_(&lm, &z__1, &ab[kd + 1 + j * ab_dim1], &c__1, &
+ work[j + 1], &c__1);
+/* L20: */
+ }
+ }
+
+/* Multiply by inv(U). */
+
+ i__1 = *kl + *ku;
+ zlatbs_("Upper", "No transpose", "Non-unit", normin, n, &i__1, &
+ ab[ab_offset], ldab, &work[1], &scale, &rwork[1], info);
+ } else {
+
+/* Multiply by inv(U'). */
+
+ i__1 = *kl + *ku;
+ zlatbs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &
+ i__1, &ab[ab_offset], ldab, &work[1], &scale, &rwork[1],
+ info);
+
+/* Multiply by inv(L'). */
+
+ if (lnoti) {
+ for (j = *n - 1; j >= 1; --j) {
+/* Computing MIN */
+ i__1 = *kl, i__2 = *n - j;
+ lm = min(i__1,i__2);
+ i__1 = j;
+ i__2 = j;
+ zdotc_(&z__2, &lm, &ab[kd + 1 + j * ab_dim1], &c__1, &
+ work[j + 1], &c__1);
+ z__1.r = work[i__2].r - z__2.r, z__1.i = work[i__2].i -
+ z__2.i;
+ work[i__1].r = z__1.r, work[i__1].i = z__1.i;
+ jp = ipiv[j];
+ if (jp != j) {
+ i__1 = jp;
+ t.r = work[i__1].r, t.i = work[i__1].i;
+ i__1 = jp;
+ i__2 = j;
+ work[i__1].r = work[i__2].r, work[i__1].i = work[i__2]
+ .i;
+ i__1 = j;
+ work[i__1].r = t.r, work[i__1].i = t.i;
+ }
+/* L30: */
+ }
+ }
+ }
+
+/* Divide X by 1/SCALE if doing so will not cause overflow. */
+
+ *(unsigned char *)normin = 'Y';
+ if (scale != 1.) {
+ ix = izamax_(n, &work[1], &c__1);
+ i__1 = ix;
+ if (scale < ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(&
+ work[ix]), abs(d__2))) * smlnum || scale == 0.) {
+ goto L40;
+ }
+ zdrscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / ainvnm / *anorm;
+ }
+
+L40:
+ return 0;
+
+/* End of ZGBCON */
+
+} /* zgbcon_ */
diff --git a/SRC/zgbequ.c b/SRC/zgbequ.c
new file mode 100644
index 0000000..c9e6d27
--- /dev/null
+++ b/SRC/zgbequ.c
@@ -0,0 +1,330 @@
+/* zgbequ.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zgbequ_(integer *m, integer *n, integer *kl, integer *ku,
+ doublecomplex *ab, integer *ldab, doublereal *r__, doublereal *c__,
+ doublereal *rowcnd, doublereal *colcnd, doublereal *amax, integer *
+ info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, kd;
+ doublereal rcmin, rcmax;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum, smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGBEQU computes row and column scalings intended to equilibrate an */
+/* M-by-N band matrix A and reduce its condition number. R returns the */
+/* row scale factors and C the column scale factors, chosen to try to */
+/* make the largest element in each row and column of the matrix B with */
+/* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. */
+
+/* R(i) and C(j) are restricted to be between SMLNUM = smallest safe */
+/* number and BIGNUM = largest safe number. Use of these scaling */
+/* factors is not guaranteed to reduce the condition number of A but */
+/* works well in practice. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
+/* The band matrix A, stored in rows 1 to KL+KU+1. The j-th */
+/* column of A is stored in the j-th column of the array AB as */
+/* follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* R (output) DOUBLE PRECISION array, dimension (M) */
+/* If INFO = 0, or INFO > M, R contains the row scale factors */
+/* for A. */
+
+/* C (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, C contains the column scale factors for A. */
+
+/* ROWCND (output) DOUBLE PRECISION */
+/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */
+/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */
+/* AMAX is neither too large nor too small, it is not worth */
+/* scaling by R. */
+
+/* COLCND (output) DOUBLE PRECISION */
+/* If INFO = 0, COLCND contains the ratio of the smallest */
+/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */
+/* worth scaling by C. */
+
+/* AMAX (output) DOUBLE PRECISION */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= M: the i-th row of A is exactly zero */
+/* > M: the (i-M)-th column of A is exactly zero */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGBEQU", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ *rowcnd = 1.;
+ *colcnd = 1.;
+ *amax = 0.;
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+
+/* Compute row scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__[i__] = 0.;
+/* L10: */
+ }
+
+/* Find the maximum element in each row. */
+
+ kd = *ku + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j - *ku;
+/* Computing MIN */
+ i__4 = j + *kl;
+ i__3 = min(i__4,*m);
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ i__2 = kd + i__ - j + j * ab_dim1;
+ d__3 = r__[i__], d__4 = (d__1 = ab[i__2].r, abs(d__1)) + (d__2 =
+ d_imag(&ab[kd + i__ - j + j * ab_dim1]), abs(d__2));
+ r__[i__] = max(d__3,d__4);
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = rcmax, d__2 = r__[i__];
+ rcmax = max(d__1,d__2);
+/* Computing MIN */
+ d__1 = rcmin, d__2 = r__[i__];
+ rcmin = min(d__1,d__2);
+/* L40: */
+ }
+ *amax = rcmax;
+
+ if (rcmin == 0.) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] == 0.) {
+ *info = i__;
+ return 0;
+ }
+/* L50: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MIN */
+/* Computing MAX */
+ d__2 = r__[i__];
+ d__1 = max(d__2,smlnum);
+ r__[i__] = 1. / min(d__1,bignum);
+/* L60: */
+ }
+
+/* Compute ROWCND = min(R(I)) / max(R(I)) */
+
+ *rowcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ }
+
+/* Compute column scale factors */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 0.;
+/* L70: */
+ }
+
+/* Find the maximum element in each column, */
+/* assuming the row scaling computed above. */
+
+ kd = *ku + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__3 = j - *ku;
+/* Computing MIN */
+ i__4 = j + *kl;
+ i__2 = min(i__4,*m);
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = kd + i__ - j + j * ab_dim1;
+ d__3 = c__[j], d__4 = ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&ab[kd + i__ - j + j * ab_dim1]), abs(d__2))) *
+ r__[i__];
+ c__[j] = max(d__3,d__4);
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = c__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = c__[j];
+ rcmax = max(d__1,d__2);
+/* L100: */
+ }
+
+ if (rcmin == 0.) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (c__[j] == 0.) {
+ *info = *m + j;
+ return 0;
+ }
+/* L110: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+/* Computing MAX */
+ d__2 = c__[j];
+ d__1 = max(d__2,smlnum);
+ c__[j] = 1. / min(d__1,bignum);
+/* L120: */
+ }
+
+/* Compute COLCND = min(C(J)) / max(C(J)) */
+
+ *colcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ }
+
+ return 0;
+
+/* End of ZGBEQU */
+
+} /* zgbequ_ */
diff --git a/SRC/zgbequb.c b/SRC/zgbequb.c
new file mode 100644
index 0000000..80c59a9
--- /dev/null
+++ b/SRC/zgbequb.c
@@ -0,0 +1,355 @@
+/* zgbequb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zgbequb_(integer *m, integer *n, integer *kl, integer *
+ ku, doublecomplex *ab, integer *ldab, doublereal *r__, doublereal *
+ c__, doublereal *rowcnd, doublereal *colcnd, doublereal *amax,
+ integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double log(doublereal), d_imag(doublecomplex *), pow_di(doublereal *,
+ integer *);
+
+ /* Local variables */
+ integer i__, j, kd;
+ doublereal radix, rcmin, rcmax;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum, logrdx, smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGBEQUB computes row and column scalings intended to equilibrate an */
+/* M-by-N matrix A and reduce its condition number. R returns the row */
+/* scale factors and C the column scale factors, chosen to try to make */
+/* the largest element in each row and column of the matrix B with */
+/* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most */
+/* the radix. */
+
+/* R(i) and C(j) are restricted to be a power of the radix between */
+/* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use */
+/* of these scaling factors is not guaranteed to reduce the condition */
+/* number of A but works well in practice. */
+
+/* This routine differs from ZGEEQU by restricting the scaling factors */
+/* to a power of the radix. Baring over- and underflow, scaling by */
+/* these factors introduces no additional rounding errors. However, the */
+/* scaled entries' magnitured are no longer approximately 1 but lie */
+/* between sqrt(radix) and 1/sqrt(radix). */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array A. LDAB >= max(1,M). */
+
+/* R (output) DOUBLE PRECISION array, dimension (M) */
+/* If INFO = 0 or INFO > M, R contains the row scale factors */
+/* for A. */
+
+/* C (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, C contains the column scale factors for A. */
+
+/* ROWCND (output) DOUBLE PRECISION */
+/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */
+/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */
+/* AMAX is neither too large nor too small, it is not worth */
+/* scaling by R. */
+
+/* COLCND (output) DOUBLE PRECISION */
+/* If INFO = 0, COLCND contains the ratio of the smallest */
+/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */
+/* worth scaling by C. */
+
+/* AMAX (output) DOUBLE PRECISION */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= M: the i-th row of A is exactly zero */
+/* > M: the (i-M)-th column of A is exactly zero */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGBEQUB", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ *rowcnd = 1.;
+ *colcnd = 1.;
+ *amax = 0.;
+ return 0;
+ }
+
+/* Get machine constants. Assume SMLNUM is a power of the radix. */
+
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+ radix = dlamch_("B");
+ logrdx = log(radix);
+
+/* Compute row scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__[i__] = 0.;
+/* L10: */
+ }
+
+/* Find the maximum element in each row. */
+
+ kd = *ku + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j - *ku;
+/* Computing MIN */
+ i__4 = j + *kl;
+ i__3 = min(i__4,*m);
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ i__2 = kd + i__ - j + j * ab_dim1;
+ d__3 = r__[i__], d__4 = (d__1 = ab[i__2].r, abs(d__1)) + (d__2 =
+ d_imag(&ab[kd + i__ - j + j * ab_dim1]), abs(d__2));
+ r__[i__] = max(d__3,d__4);
+/* L20: */
+ }
+/* L30: */
+ }
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] > 0.) {
+ i__3 = (integer) (log(r__[i__]) / logrdx);
+ r__[i__] = pow_di(&radix, &i__3);
+ }
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = rcmax, d__2 = r__[i__];
+ rcmax = max(d__1,d__2);
+/* Computing MIN */
+ d__1 = rcmin, d__2 = r__[i__];
+ rcmin = min(d__1,d__2);
+/* L40: */
+ }
+ *amax = rcmax;
+
+ if (rcmin == 0.) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] == 0.) {
+ *info = i__;
+ return 0;
+ }
+/* L50: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MIN */
+/* Computing MAX */
+ d__2 = r__[i__];
+ d__1 = max(d__2,smlnum);
+ r__[i__] = 1. / min(d__1,bignum);
+/* L60: */
+ }
+
+/* Compute ROWCND = min(R(I)) / max(R(I)). */
+
+ *rowcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ }
+
+/* Compute column scale factors. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 0.;
+/* L70: */
+ }
+
+/* Find the maximum element in each column, */
+/* assuming the row scaling computed above. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__3 = j - *ku;
+/* Computing MIN */
+ i__4 = j + *kl;
+ i__2 = min(i__4,*m);
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = kd + i__ - j + j * ab_dim1;
+ d__3 = c__[j], d__4 = ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&ab[kd + i__ - j + j * ab_dim1]), abs(d__2))) *
+ r__[i__];
+ c__[j] = max(d__3,d__4);
+/* L80: */
+ }
+ if (c__[j] > 0.) {
+ i__2 = (integer) (log(c__[j]) / logrdx);
+ c__[j] = pow_di(&radix, &i__2);
+ }
+/* L90: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = c__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = c__[j];
+ rcmax = max(d__1,d__2);
+/* L100: */
+ }
+
+ if (rcmin == 0.) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (c__[j] == 0.) {
+ *info = *m + j;
+ return 0;
+ }
+/* L110: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+/* Computing MAX */
+ d__2 = c__[j];
+ d__1 = max(d__2,smlnum);
+ c__[j] = 1. / min(d__1,bignum);
+/* L120: */
+ }
+
+/* Compute COLCND = min(C(J)) / max(C(J)). */
+
+ *colcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ }
+
+ return 0;
+
+/* End of ZGBEQUB */
+
+} /* zgbequb_ */
diff --git a/SRC/zgbrfs.c b/SRC/zgbrfs.c
new file mode 100644
index 0000000..f382760
--- /dev/null
+++ b/SRC/zgbrfs.c
@@ -0,0 +1,494 @@
+/* zgbrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zgbrfs_(char *trans, integer *n, integer *kl, integer *
+ ku, integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *
+ afb, integer *ldafb, integer *ipiv, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr,
+ doublecomplex *work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal s;
+ integer kk;
+ doublereal xk;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int zgbmv_(char *, integer *, integer *, integer *
+, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer count;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), zlacn2_(
+ integer *, doublecomplex *, doublecomplex *, doublereal *,
+ integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+ char transn[1], transt[1];
+ doublereal lstres;
+ extern /* Subroutine */ int zgbtrs_(char *, integer *, integer *, integer
+ *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGBRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is banded, and provides */
+/* error bounds and backward error estimates for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
+/* The original band matrix A, stored in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input) COMPLEX*16 array, dimension (LDAFB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by ZGBTRF. U is stored as an upper triangular band */
+/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
+/* the multipliers used during the factorization are stored in */
+/* rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from ZGBTRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by ZGBTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -7;
+ } else if (*ldafb < (*kl << 1) + *ku + 1) {
+ *info = -9;
+ } else if (*ldb < max(1,*n)) {
+ *info = -12;
+ } else if (*ldx < max(1,*n)) {
+ *info = -14;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGBRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transn = 'N';
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transn = 'C';
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+/* Computing MIN */
+ i__1 = *kl + *ku + 2, i__2 = *n + 1;
+ nz = min(i__1,i__2);
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A, A**T, or A**H, depending on TRANS. */
+
+ zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ z__1.r = -1., z__1.i = -0.;
+ zgbmv_(trans, n, n, kl, ku, &z__1, &ab[ab_offset], ldab, &x[j *
+ x_dim1 + 1], &c__1, &c_b1, &work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
+ i__ + j * b_dim1]), abs(d__2));
+/* L30: */
+ }
+
+/* Compute abs(op(A))*abs(X) + abs(B). */
+
+ if (notran) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ kk = *ku + 1 - k;
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
+ x_dim1]), abs(d__2));
+/* Computing MAX */
+ i__3 = 1, i__4 = k - *ku;
+/* Computing MIN */
+ i__6 = *n, i__7 = k + *kl;
+ i__5 = min(i__6,i__7);
+ for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
+ i__3 = kk + i__ + k * ab_dim1;
+ rwork[i__] += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&ab[kk + i__ + k * ab_dim1]), abs(d__2))) *
+ xk;
+/* L40: */
+ }
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ kk = *ku + 1 - k;
+/* Computing MAX */
+ i__5 = 1, i__3 = k - *ku;
+/* Computing MIN */
+ i__6 = *n, i__7 = k + *kl;
+ i__4 = min(i__6,i__7);
+ for (i__ = max(i__5,i__3); i__ <= i__4; ++i__) {
+ i__5 = kk + i__ + k * ab_dim1;
+ i__3 = i__ + j * x_dim1;
+ s += ((d__1 = ab[i__5].r, abs(d__1)) + (d__2 = d_imag(&ab[
+ kk + i__ + k * ab_dim1]), abs(d__2))) * ((d__3 =
+ x[i__3].r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j
+ * x_dim1]), abs(d__4)));
+/* L60: */
+ }
+ rwork[k] += s;
+/* L70: */
+ }
+ }
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__4 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2))) / rwork[i__];
+ s = max(d__3,d__4);
+ } else {
+/* Computing MAX */
+ i__4 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = max(d__3,d__4);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ zgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1]
+, &work[1], n, info);
+ zaxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use ZLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__4 = i__;
+ rwork[i__] = (d__1 = work[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ ;
+ } else {
+ i__4 = i__;
+ rwork[i__] = (d__1 = work[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)**H). */
+
+ zgbtrs_(transt, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &
+ ipiv[1], &work[1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ i__3 = i__;
+ z__1.r = rwork[i__5] * work[i__3].r, z__1.i = rwork[i__5]
+ * work[i__3].i;
+ work[i__4].r = z__1.r, work[i__4].i = z__1.i;
+/* L110: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ i__3 = i__;
+ z__1.r = rwork[i__5] * work[i__3].r, z__1.i = rwork[i__5]
+ * work[i__3].i;
+ work[i__4].r = z__1.r, work[i__4].i = z__1.i;
+/* L120: */
+ }
+ zgbtrs_(transn, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &
+ ipiv[1], &work[1], n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__4 = i__ + j * x_dim1;
+ d__3 = lstres, d__4 = (d__1 = x[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&x[i__ + j * x_dim1]), abs(d__2));
+ lstres = max(d__3,d__4);
+/* L130: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of ZGBRFS */
+
+} /* zgbrfs_ */
diff --git a/SRC/zgbrfsx.c b/SRC/zgbrfsx.c
new file mode 100644
index 0000000..b3c9c74
--- /dev/null
+++ b/SRC/zgbrfsx.c
@@ -0,0 +1,690 @@
+/* zgbrfsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int zgbrfsx_(char *trans, char *equed, integer *n, integer *
+ kl, integer *ku, integer *nrhs, doublecomplex *ab, integer *ldab,
+ doublecomplex *afb, integer *ldafb, integer *ipiv, doublereal *r__,
+ doublereal *c__, doublecomplex *b, integer *ldb, doublecomplex *x,
+ integer *ldx, doublereal *rcond, doublereal *berr, integer *
+ n_err_bnds__, doublereal *err_bnds_norm__, doublereal *
+ err_bnds_comp__, integer *nparams, doublereal *params, doublecomplex *
+ work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal illrcond_thresh__, unstable_thresh__, err_lbnd__;
+ integer ref_type__;
+ extern integer ilatrans_(char *);
+ integer j;
+ doublereal rcond_tmp__;
+ integer prec_type__, trans_type__;
+ doublereal cwise_wrong__;
+ extern /* Subroutine */ int zla_gbrfsx_extended__(integer *, integer *,
+ integer *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, logical *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, doublecomplex *, doublecomplex *,
+ doublereal *, integer *, doublereal *, doublereal *, logical *,
+ integer *);
+ char norm[1];
+ logical ignore_cwise__;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern doublereal zla_gbrcond_c__(char *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+ , doublereal *, logical *, integer *, doublecomplex *, doublereal
+ *, ftnlen), zla_gbrcond_x__(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *, ftnlen), dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal zlangb_(char *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int zgbcon_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, integer *, doublereal *,
+ doublereal *, doublecomplex *, doublereal *, integer *);
+ logical colequ, notran, rowequ;
+ extern integer ilaprec_(char *);
+ integer ithresh, n_norms__;
+ doublereal rthresh;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGBRFSX improves the computed solution to a system of linear */
+/* equations and provides error bounds and backward error estimates */
+/* for the solution. In addition to normwise error bound, the code */
+/* provides maximum componentwise error bound if possible. See */
+/* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the */
+/* error bounds. */
+
+/* The original system of linear equations may have been equilibrated */
+/* before calling this routine, as described by arguments EQUED, R */
+/* and C below. In this case, the solution and error bounds returned */
+/* are for the original unequilibrated system. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* EQUED (input) CHARACTER*1 */
+/* Specifies the form of equilibration that was done to A */
+/* before calling this routine. This is needed to compute */
+/* the solution and error bounds correctly. */
+/* = 'N': No equilibration */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* The right hand side B has been changed accordingly. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The original band matrix A, stored in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by DGBTRF. U is stored as an upper triangular band */
+/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
+/* the multipliers used during the factorization are stored in */
+/* rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from DGETRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* R (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+/* If R is output, each element of R is a power of the radix. */
+/* If R is input, each element of R should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* C (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+/* If C is output, each element of C is a power of the radix. */
+/* If C is input, each element of C should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by DGETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0D+0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check the input parameters. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ trans_type__ = ilatrans_(trans);
+ ref_type__ = 1;
+ if (*nparams >= 1) {
+ if (params[1] < 0.) {
+ params[1] = 1.;
+ } else {
+ ref_type__ = (integer) params[1];
+ }
+ }
+
+/* Set default parameters. */
+
+ illrcond_thresh__ = (doublereal) (*n) * dlamch_("Epsilon");
+ ithresh = 10;
+ rthresh = .5;
+ unstable_thresh__ = .25;
+ ignore_cwise__ = FALSE_;
+
+ if (*nparams >= 2) {
+ if (params[2] < 0.) {
+ params[2] = (doublereal) ithresh;
+ } else {
+ ithresh = (integer) params[2];
+ }
+ }
+ if (*nparams >= 3) {
+ if (params[3] < 0.) {
+ if (ignore_cwise__) {
+ params[3] = 0.;
+ } else {
+ params[3] = 1.;
+ }
+ } else {
+ ignore_cwise__ = params[3] == 0.;
+ }
+ }
+ if (ref_type__ == 0 || *n_err_bnds__ == 0) {
+ n_norms__ = 0;
+ } else if (ignore_cwise__) {
+ n_norms__ = 1;
+ } else {
+ n_norms__ = 2;
+ }
+
+ notran = lsame_(trans, "N");
+ rowequ = lsame_(equed, "R") || lsame_(equed, "B");
+ colequ = lsame_(equed, "C") || lsame_(equed, "B");
+
+/* Test input parameters. */
+
+ if (trans_type__ == -1) {
+ *info = -1;
+ } else if (! rowequ && ! colequ && ! lsame_(equed, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kl < 0) {
+ *info = -4;
+ } else if (*ku < 0) {
+ *info = -5;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -8;
+ } else if (*ldafb < (*kl << 1) + *ku + 1) {
+ *info = -10;
+ } else if (*ldb < max(1,*n)) {
+ *info = -13;
+ } else if (*ldx < max(1,*n)) {
+ *info = -15;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGBRFSX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *nrhs == 0) {
+ *rcond = 1.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 0.;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.;
+ }
+ }
+ return 0;
+ }
+
+/* Default to failure. */
+
+ *rcond = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 1.;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.;
+ }
+ }
+
+/* Compute the norm of A and the reciprocal of the condition */
+/* number of A. */
+
+ if (notran) {
+ *(unsigned char *)norm = 'I';
+ } else {
+ *(unsigned char *)norm = '1';
+ }
+ anorm = zlangb_(norm, n, kl, ku, &ab[ab_offset], ldab, &rwork[1]);
+ zgbcon_(norm, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], &anorm, rcond,
+ &work[1], &rwork[1], info);
+
+/* Perform refinement on each right-hand side */
+
+ if (ref_type__ != 0) {
+ prec_type__ = ilaprec_("E");
+ if (notran) {
+ zla_gbrfsx_extended__(&prec_type__, &trans_type__, n, kl, ku,
+ nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, &
+ ipiv[1], &colequ, &c__[1], &b[b_offset], ldb, &x[x_offset]
+ , ldx, &berr[1], &n_norms__, &err_bnds_norm__[
+ err_bnds_norm_offset], &err_bnds_comp__[
+ err_bnds_comp_offset], &work[1], &rwork[1], &work[*n + 1],
+ (doublecomplex *)(&rwork[1]), rcond, &ithresh, &rthresh, &unstable_thresh__, &
+ ignore_cwise__, info);
+ } else {
+ zla_gbrfsx_extended__(&prec_type__, &trans_type__, n, kl, ku,
+ nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, &
+ ipiv[1], &rowequ, &r__[1], &b[b_offset], ldb, &x[x_offset]
+ , ldx, &berr[1], &n_norms__, &err_bnds_norm__[
+ err_bnds_norm_offset], &err_bnds_comp__[
+ err_bnds_comp_offset], &work[1], &rwork[1], &work[*n + 1],
+ (doublecomplex *)(&rwork[1]), rcond, &ithresh, &rthresh, &unstable_thresh__, &
+ ignore_cwise__, info);
+ }
+ }
+/* Computing MAX */
+ d__1 = 10., d__2 = sqrt((doublereal) (*n));
+ err_lbnd__ = max(d__1,d__2) * dlamch_("Epsilon");
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {
+
+/* Compute scaled normwise condition number cond(A*C). */
+
+ if (colequ && notran) {
+ rcond_tmp__ = zla_gbrcond_c__(trans, n, kl, ku, &ab[ab_offset],
+ ldab, &afb[afb_offset], ldafb, &ipiv[1], &c__[1], &c_true,
+ info, &work[1], &rwork[1], (ftnlen)1);
+ } else if (rowequ && ! notran) {
+ rcond_tmp__ = zla_gbrcond_c__(trans, n, kl, ku, &ab[ab_offset],
+ ldab, &afb[afb_offset], ldafb, &ipiv[1], &r__[1], &c_true,
+ info, &work[1], &rwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = zla_gbrcond_c__(trans, n, kl, ku, &ab[ab_offset],
+ ldab, &afb[afb_offset], ldafb, &ipiv[1], &c__[1], &
+ c_false, info, &work[1], &rwork[1], (ftnlen)1);
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1
+ << 1)] > 1.) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 0.;
+ if (*info <= *n) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {
+
+/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
+/* each right-hand side using the current solution as an estimate of */
+/* the true solution. If the componentwise error estimate is too */
+/* large, then the solution is a lousy estimate of truth and the */
+/* estimated RCOND may be too optimistic. To avoid misleading users, */
+/* the inverse condition number is set to 0.0 when the estimated */
+/* cwise error is at least CWISE_WRONG. */
+
+ cwise_wrong__ = sqrt(dlamch_("Epsilon"));
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ cwise_wrong__) {
+ rcond_tmp__ = zla_gbrcond_x__(trans, n, kl, ku, &ab[ab_offset]
+ , ldab, &afb[afb_offset], ldafb, &ipiv[1], &x[j *
+ x_dim1 + 1], info, &work[1], &rwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = 0.;
+ }
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1
+ << 1)] > 1.) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 0.;
+ if (params[3] == 1. && *info < *n + j) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZGBRFSX */
+
+} /* zgbrfsx_ */
diff --git a/SRC/zgbsv.c b/SRC/zgbsv.c
new file mode 100644
index 0000000..7be165e
--- /dev/null
+++ b/SRC/zgbsv.c
@@ -0,0 +1,176 @@
+/* zgbsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zgbsv_(integer *n, integer *kl, integer *ku, integer *
+ nrhs, doublecomplex *ab, integer *ldab, integer *ipiv, doublecomplex *
+ b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int xerbla_(char *, integer *), zgbtrf_(
+ integer *, integer *, integer *, integer *, doublecomplex *,
+ integer *, integer *, integer *), zgbtrs_(char *, integer *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGBSV computes the solution to a complex system of linear equations */
+/* A * X = B, where A is a band matrix of order N with KL subdiagonals */
+/* and KU superdiagonals, and X and B are N-by-NRHS matrices. */
+
+/* The LU decomposition with partial pivoting and row interchanges is */
+/* used to factor A as A = L * U, where L is a product of permutation */
+/* and unit lower triangular matrices with KL subdiagonals, and U is */
+/* upper triangular with KL+KU superdiagonals. The factored form of A */
+/* is then used to solve the system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows KL+1 to */
+/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL) */
+/* On exit, details of the factorization: U is stored as an */
+/* upper triangular band matrix with KL+KU superdiagonals in */
+/* rows 1 to KL+KU+1, and the multipliers used during the */
+/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */
+/* See below for further details. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* The pivot indices that define the permutation matrix P; */
+/* row i of the matrix was interchanged with row IPIV(i). */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and the solution has not been computed. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* M = N = 6, KL = 2, KU = 1: */
+
+/* On entry: On exit: */
+
+/* * * * + + + * * * u14 u25 u36 */
+/* * * + + + + * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */
+/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */
+
+/* Array elements marked * are not used by the routine; elements marked */
+/* + need not be set on entry, but are required by the routine to store */
+/* elements of U because of fill-in resulting from the row interchanges. */
+
+/* ===================================================================== */
+
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*kl < 0) {
+ *info = -2;
+ } else if (*ku < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldab < (*kl << 1) + *ku + 1) {
+ *info = -6;
+ } else if (*ldb < max(*n,1)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGBSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the LU factorization of the band matrix A. */
+
+ zgbtrf_(n, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ zgbtrs_("No transpose", n, kl, ku, nrhs, &ab[ab_offset], ldab, &ipiv[
+ 1], &b[b_offset], ldb, info);
+ }
+ return 0;
+
+/* End of ZGBSV */
+
+} /* zgbsv_ */
diff --git a/SRC/zgbsvx.c b/SRC/zgbsvx.c
new file mode 100644
index 0000000..860abf5
--- /dev/null
+++ b/SRC/zgbsvx.c
@@ -0,0 +1,678 @@
+/* zgbsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zgbsvx_(char *fact, char *trans, integer *n, integer *kl,
+ integer *ku, integer *nrhs, doublecomplex *ab, integer *ldab,
+ doublecomplex *afb, integer *ldafb, integer *ipiv, char *equed,
+ doublereal *r__, doublereal *c__, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr,
+ doublereal *berr, doublecomplex *work, doublereal *rwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, j1, j2;
+ doublereal amax;
+ char norm[1];
+ extern logical lsame_(char *, char *);
+ doublereal rcmin, rcmax, anorm;
+ logical equil;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal colcnd;
+ logical nofact;
+ extern doublereal zlangb_(char *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), zlaqgb_(
+ integer *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, char *);
+ doublereal bignum;
+ extern /* Subroutine */ int zgbcon_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, integer *, doublereal *,
+ doublereal *, doublecomplex *, doublereal *, integer *);
+ integer infequ;
+ logical colequ;
+ extern doublereal zlantb_(char *, char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+ doublereal rowcnd;
+ extern /* Subroutine */ int zgbequ_(integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *), zgbrfs_(
+ char *, integer *, integer *, integer *, integer *, doublecomplex
+ *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zgbtrf_(integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, integer *, integer *);
+ logical notran;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal smlnum;
+ extern /* Subroutine */ int zgbtrs_(char *, integer *, integer *, integer
+ *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, integer *);
+ logical rowequ;
+ doublereal rpvgrw;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGBSVX uses the LU factorization to compute the solution to a complex */
+/* system of linear equations A * X = B, A**T * X = B, or A**H * X = B, */
+/* where A is a band matrix of order N with KL subdiagonals and KU */
+/* superdiagonals, and X and B are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed by this subroutine: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */
+/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */
+/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */
+/* or diag(C)*B (if TRANS = 'T' or 'C'). */
+
+/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the */
+/* matrix A (after equilibration if FACT = 'E') as */
+/* A = L * U, */
+/* where L is a product of permutation and unit lower triangular */
+/* matrices with KL subdiagonals, and U is upper triangular with */
+/* KL+KU superdiagonals. */
+
+/* 3. If some U(i,i)=0, so that U is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */
+/* that it solves the original system before equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AFB and IPIV contain the factored form of */
+/* A. If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by R and C. */
+/* AB, AFB, and IPIV are not modified. */
+/* = 'N': The matrix A will be copied to AFB and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AFB and factored. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
+
+/* If FACT = 'F' and EQUED is not 'N', then A must have been */
+/* equilibrated by the scaling factors in R and/or C. AB is not */
+/* modified if FACT = 'F' or 'N', or if FACT = 'E' and */
+/* EQUED = 'N' on exit. */
+
+/* On exit, if EQUED .ne. 'N', A is scaled as follows: */
+/* EQUED = 'R': A := diag(R) * A */
+/* EQUED = 'C': A := A * diag(C) */
+/* EQUED = 'B': A := diag(R) * A * diag(C). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input or output) COMPLEX*16 array, dimension (LDAFB,N) */
+/* If FACT = 'F', then AFB is an input argument and on entry */
+/* contains details of the LU factorization of the band matrix */
+/* A, as computed by ZGBTRF. U is stored as an upper triangular */
+/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */
+/* and the multipliers used during the factorization are stored */
+/* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is */
+/* the factored form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AFB is an output argument and on exit */
+/* returns details of the LU factorization of A. */
+
+/* If FACT = 'E', then AFB is an output argument and on exit */
+/* returns details of the LU factorization of the equilibrated */
+/* matrix A (see the description of AB for the form of the */
+/* equilibrated matrix). */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains the pivot indices from the factorization A = L*U */
+/* as computed by ZGBTRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = L*U */
+/* of the equilibrated matrix A. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* R (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+
+/* C (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */
+/* diag(R)*B; */
+/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */
+/* overwritten by diag(C)*B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X */
+/* to the original system of equations. Note that A and B are */
+/* modified on exit if EQUED .ne. 'N', and the solution to the */
+/* equilibrated system is inv(diag(C))*X if TRANS = 'N' and */
+/* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' */
+/* and EQUED = 'R' or 'B'. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A after equilibration (if done). If RCOND is less than the */
+/* machine precision (in particular, if RCOND = 0), the matrix */
+/* is singular to working precision. This condition is */
+/* indicated by a return code of INFO > 0. */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace/output) DOUBLE PRECISION array, dimension (N) */
+/* On exit, RWORK(1) contains the reciprocal pivot growth */
+/* factor norm(A)/norm(U). The "max absolute element" norm is */
+/* used. If RWORK(1) is much less than 1, then the stability */
+/* of the LU factorization of the (equilibrated) matrix A */
+/* could be poor. This also means that the solution X, condition */
+/* estimator RCOND, and forward error bound FERR could be */
+/* unreliable. If factorization fails with 0<INFO<=N, then */
+/* RWORK(1) contains the reciprocal pivot growth factor for the */
+/* leading INFO columns of A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, so the solution and error bounds */
+/* could not be computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+/* Moved setting of INFO = N+1 so INFO does not subsequently get */
+/* overwritten. Sven, 17 Mar 05. */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ notran = lsame_(trans, "N");
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rowequ = FALSE_;
+ colequ = FALSE_;
+ } else {
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ }
+
+/* Test the input parameters. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kl < 0) {
+ *info = -4;
+ } else if (*ku < 0) {
+ *info = -5;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -8;
+ } else if (*ldafb < (*kl << 1) + *ku + 1) {
+ *info = -10;
+ } else if (lsame_(fact, "F") && ! (rowequ || colequ
+ || lsame_(equed, "N"))) {
+ *info = -12;
+ } else {
+ if (rowequ) {
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = r__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = r__[j];
+ rcmax = max(d__1,d__2);
+/* L10: */
+ }
+ if (rcmin <= 0.) {
+ *info = -13;
+ } else if (*n > 0) {
+ rowcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ } else {
+ rowcnd = 1.;
+ }
+ }
+ if (colequ && *info == 0) {
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = c__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = c__[j];
+ rcmax = max(d__1,d__2);
+/* L20: */
+ }
+ if (rcmin <= 0.) {
+ *info = -14;
+ } else if (*n > 0) {
+ colcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ } else {
+ colcnd = 1.;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -16;
+ } else if (*ldx < max(1,*n)) {
+ *info = -18;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGBSVX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ zgbequ_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &rowcnd,
+ &colcnd, &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ zlaqgb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &
+ rowcnd, &colcnd, &amax, equed);
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+ }
+
+/* Scale the right hand side. */
+
+ if (notran) {
+ if (rowequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * b_dim1;
+ z__1.r = r__[i__4] * b[i__5].r, z__1.i = r__[i__4] * b[
+ i__5].i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else if (colequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * b_dim1;
+ z__1.r = c__[i__4] * b[i__5].r, z__1.i = c__[i__4] * b[i__5]
+ .i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of the band matrix A. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j - *ku;
+ j1 = max(i__2,1);
+/* Computing MIN */
+ i__2 = j + *kl;
+ j2 = min(i__2,*n);
+ i__2 = j2 - j1 + 1;
+ zcopy_(&i__2, &ab[*ku + 1 - j + j1 + j * ab_dim1], &c__1, &afb[*
+ kl + *ku + 1 - j + j1 + j * afb_dim1], &c__1);
+/* L70: */
+ }
+
+ zgbtrf_(n, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ anorm = 0.;
+ i__1 = *info;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = *ku + 2 - j;
+/* Computing MIN */
+ i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1;
+ i__3 = min(i__4,i__5);
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ d__1 = anorm, d__2 = z_abs(&ab[i__ + j * ab_dim1]);
+ anorm = max(d__1,d__2);
+/* L80: */
+ }
+/* L90: */
+ }
+/* Computing MIN */
+ i__3 = *info - 1, i__2 = *kl + *ku;
+ i__1 = min(i__3,i__2);
+/* Computing MAX */
+ i__4 = 1, i__5 = *kl + *ku + 2 - *info;
+ rpvgrw = zlantb_("M", "U", "N", info, &i__1, &afb[max(i__4, i__5)
+ + afb_dim1], ldafb, &rwork[1]);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = anorm / rpvgrw;
+ }
+ rwork[1] = rpvgrw;
+ *rcond = 0.;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A and the */
+/* reciprocal pivot growth factor RPVGRW. */
+
+ if (notran) {
+ *(unsigned char *)norm = '1';
+ } else {
+ *(unsigned char *)norm = 'I';
+ }
+ anorm = zlangb_(norm, n, kl, ku, &ab[ab_offset], ldab, &rwork[1]);
+ i__1 = *kl + *ku;
+ rpvgrw = zlantb_("M", "U", "N", n, &i__1, &afb[afb_offset], ldafb, &rwork[
+ 1]);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = zlangb_("M", n, kl, ku, &ab[ab_offset], ldab, &rwork[1]) / rpvgrw;
+ }
+
+/* Compute the reciprocal of the condition number of A. */
+
+ zgbcon_(norm, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], &anorm, rcond,
+ &work[1], &rwork[1], info);
+
+/* Compute the solution matrix X. */
+
+ zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ zgbtrs_(trans, n, kl, ku, nrhs, &afb[afb_offset], ldafb, &ipiv[1], &x[
+ x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ zgbrfs_(trans, n, kl, ku, nrhs, &ab[ab_offset], ldab, &afb[afb_offset],
+ ldafb, &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &
+ berr[1], &work[1], &rwork[1], info);
+
+/* Transform the solution matrix X to a solution of the original */
+/* system. */
+
+ if (notran) {
+ if (colequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__2 = i__ + j * x_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * x_dim1;
+ z__1.r = c__[i__4] * x[i__5].r, z__1.i = c__[i__4] * x[
+ i__5].i;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+/* L100: */
+ }
+/* L110: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= colcnd;
+/* L120: */
+ }
+ }
+ } else if (rowequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__2 = i__ + j * x_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * x_dim1;
+ z__1.r = r__[i__4] * x[i__5].r, z__1.i = r__[i__4] * x[i__5]
+ .i;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+/* L130: */
+ }
+/* L140: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= rowcnd;
+/* L150: */
+ }
+ }
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < dlamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ rwork[1] = rpvgrw;
+ return 0;
+
+/* End of ZGBSVX */
+
+} /* zgbsvx_ */
diff --git a/SRC/zgbsvxx.c b/SRC/zgbsvxx.c
new file mode 100644
index 0000000..88d7bba
--- /dev/null
+++ b/SRC/zgbsvxx.c
@@ -0,0 +1,747 @@
+/* zgbsvxx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zgbsvxx_(char *fact, char *trans, integer *n, integer *
+ kl, integer *ku, integer *nrhs, doublecomplex *ab, integer *ldab,
+ doublecomplex *afb, integer *ldafb, integer *ipiv, char *equed,
+ doublereal *r__, doublereal *c__, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *rpvgrw,
+ doublereal *berr, integer *n_err_bnds__, doublereal *err_bnds_norm__,
+ doublereal *err_bnds_comp__, integer *nparams, doublereal *params,
+ doublecomplex *work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal amax;
+ extern doublereal zla_gbrpvgrw__(integer *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *);
+ extern logical lsame_(char *, char *);
+ doublereal rcmin, rcmax;
+ logical equil;
+ extern doublereal dlamch_(char *);
+ doublereal colcnd;
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *), zlaqgb_(
+ integer *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, char *);
+ doublereal bignum;
+ integer infequ;
+ logical colequ;
+ doublereal rowcnd;
+ extern /* Subroutine */ int zgbtrf_(integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, integer *, integer *);
+ logical notran;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal smlnum;
+ extern /* Subroutine */ int zgbtrs_(char *, integer *, integer *, integer
+ *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, integer *);
+ logical rowequ;
+ extern /* Subroutine */ int zlascl2_(integer *, integer *, doublereal *,
+ doublecomplex *, integer *), zgbequb_(integer *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *)
+ , zgbrfsx_(char *, char *, integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *, doublereal *, doublereal *, doublecomplex *, integer *
+, doublecomplex *, integer *, doublereal *, doublereal *, integer
+ *, doublereal *, doublereal *, integer *, doublereal *,
+ doublecomplex *, doublereal *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGBSVXX uses the LU factorization to compute the solution to a */
+/* complex*16 system of linear equations A * X = B, where A is an */
+/* N-by-N matrix and X and B are N-by-NRHS matrices. */
+
+/* If requested, both normwise and maximum componentwise error bounds */
+/* are returned. ZGBSVXX will return a solution with a tiny */
+/* guaranteed error (O(eps) where eps is the working machine */
+/* precision) unless the matrix is very ill-conditioned, in which */
+/* case a warning is returned. Relevant condition numbers also are */
+/* calculated and returned. */
+
+/* ZGBSVXX accepts user-provided factorizations and equilibration */
+/* factors; see the definitions of the FACT and EQUED options. */
+/* Solving with refinement and using a factorization from a previous */
+/* ZGBSVXX call will also produce a solution with either O(eps) */
+/* errors or warnings, but we cannot make that claim for general */
+/* user-provided factorizations and equilibration factors if they */
+/* differ from what ZGBSVXX would itself produce. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate */
+/* the system: */
+
+/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */
+/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */
+/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */
+
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */
+/* or diag(C)*B (if TRANS = 'T' or 'C'). */
+
+/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */
+/* the matrix A (after equilibration if FACT = 'E') as */
+
+/* A = P * L * U, */
+
+/* where P is a permutation matrix, L is a unit lower triangular */
+/* matrix, and U is upper triangular. */
+
+/* 3. If some U(i,i)=0, so that U is exactly singular, then the */
+/* routine returns with INFO = i. Otherwise, the factored form of A */
+/* is used to estimate the condition number of the matrix A (see */
+/* argument RCOND). If the reciprocal of the condition number is less */
+/* than machine precision, the routine still goes on to solve for X */
+/* and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */
+/* the routine will use iterative refinement to try to get a small */
+/* error and error bounds. Refinement calculates the residual to at */
+/* least twice the working precision. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */
+/* that it solves the original system before equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF and IPIV contain the factored form of A. */
+/* If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by R and C. */
+/* A, AF, and IPIV are not modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
+
+/* If FACT = 'F' and EQUED is not 'N', then AB must have been */
+/* equilibrated by the scaling factors in R and/or C. AB is not */
+/* modified if FACT = 'F' or 'N', or if FACT = 'E' and */
+/* EQUED = 'N' on exit. */
+
+/* On exit, if EQUED .ne. 'N', A is scaled as follows: */
+/* EQUED = 'R': A := diag(R) * A */
+/* EQUED = 'C': A := A * diag(C) */
+/* EQUED = 'B': A := diag(R) * A * diag(C). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N) */
+/* If FACT = 'F', then AFB is an input argument and on entry */
+/* contains details of the LU factorization of the band matrix */
+/* A, as computed by ZGBTRF. U is stored as an upper triangular */
+/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */
+/* and the multipliers used during the factorization are stored */
+/* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is */
+/* the factored form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the equilibrated matrix A (see the description of A for */
+/* the form of the equilibrated matrix). */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* as computed by DGETRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the equilibrated matrix A. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* R (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+/* If R is output, each element of R is a power of the radix. */
+/* If R is input, each element of R should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* C (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+/* If C is output, each element of C is a power of the radix. */
+/* If C is input, each element of C should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */
+/* diag(R)*B; */
+/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */
+/* overwritten by diag(C)*B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* If INFO = 0, the N-by-NRHS solution matrix X to the original */
+/* system of equations. Note that A and B are modified on exit */
+/* if EQUED .ne. 'N', and the solution to the equilibrated system is */
+/* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or */
+/* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* RPVGRW (output) DOUBLE PRECISION */
+/* Reciprocal pivot growth. On exit, this contains the reciprocal */
+/* pivot growth factor norm(A)/norm(U). The "max absolute element" */
+/* norm is used. If this is much less than 1, then the stability of */
+/* the LU factorization of the (equilibrated) matrix A could be poor. */
+/* This also means that the solution X, estimated condition numbers, */
+/* and error bounds could be unreliable. If factorization fails with */
+/* 0<INFO<=N, then this contains the reciprocal pivot growth factor */
+/* for the leading INFO columns of A. In DGESVX, this quantity is */
+/* returned in WORK(1). */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0D+0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the extra-precise refinement algorithm. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ notran = lsame_(trans, "N");
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rowequ = FALSE_;
+ colequ = FALSE_;
+ } else {
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+
+/* Default is failure. If an input parameter is wrong or */
+/* factorization fails, make everything look horrible. Only the */
+/* pivot growth is set here, the rest is initialized in ZGBRFSX. */
+
+ *rpvgrw = 0.;
+
+/* Test the input parameters. PARAMS is not tested until DGERFSX. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kl < 0) {
+ *info = -4;
+ } else if (*ku < 0) {
+ *info = -5;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -8;
+ } else if (*ldafb < (*kl << 1) + *ku + 1) {
+ *info = -10;
+ } else if (lsame_(fact, "F") && ! (rowequ || colequ
+ || lsame_(equed, "N"))) {
+ *info = -12;
+ } else {
+ if (rowequ) {
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = r__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = r__[j];
+ rcmax = max(d__1,d__2);
+/* L10: */
+ }
+ if (rcmin <= 0.) {
+ *info = -13;
+ } else if (*n > 0) {
+ rowcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ } else {
+ rowcnd = 1.;
+ }
+ }
+ if (colequ && *info == 0) {
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = c__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = c__[j];
+ rcmax = max(d__1,d__2);
+/* L20: */
+ }
+ if (rcmin <= 0.) {
+ *info = -14;
+ } else if (*n > 0) {
+ colcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ } else {
+ colcnd = 1.;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -15;
+ } else if (*ldx < max(1,*n)) {
+ *info = -16;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGBSVXX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ zgbequb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &
+ rowcnd, &colcnd, &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ zlaqgb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &
+ rowcnd, &colcnd, &amax, equed);
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+
+/* If the scaling factors are not applied, set them to 1.0. */
+
+ if (! rowequ) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ r__[j] = 1.;
+ }
+ }
+ if (! colequ) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 1.;
+ }
+ }
+ }
+
+/* Scale the right-hand side. */
+
+ if (notran) {
+ if (rowequ) {
+ zlascl2_(n, nrhs, &r__[1], &b[b_offset], ldb);
+ }
+ } else {
+ if (colequ) {
+ zlascl2_(n, nrhs, &c__[1], &b[b_offset], ldb);
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of A. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (*kl << 1) + *ku + 1;
+ for (i__ = *kl + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * afb_dim1;
+ i__4 = i__ - *kl + j * ab_dim1;
+ afb[i__3].r = ab[i__4].r, afb[i__3].i = ab[i__4].i;
+/* L30: */
+ }
+/* L40: */
+ }
+ zgbtrf_(n, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Pivot in column INFO is exactly 0 */
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ *rpvgrw = zla_gbrpvgrw__(n, kl, ku, info, &ab[ab_offset], ldab, &
+ afb[afb_offset], ldafb);
+ return 0;
+ }
+ }
+
+/* Compute the reciprocal pivot growth factor RPVGRW. */
+
+ *rpvgrw = zla_gbrpvgrw__(n, kl, ku, n, &ab[ab_offset], ldab, &afb[
+ afb_offset], ldafb);
+
+/* Compute the solution matrix X. */
+
+ zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ zgbtrs_(trans, n, kl, ku, nrhs, &afb[afb_offset], ldafb, &ipiv[1], &x[
+ x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ zgbrfsx_(trans, equed, n, kl, ku, nrhs, &ab[ab_offset], ldab, &afb[
+ afb_offset], ldafb, &ipiv[1], &r__[1], &c__[1], &b[b_offset], ldb,
+ &x[x_offset], ldx, rcond, &berr[1], n_err_bnds__, &
+ err_bnds_norm__[err_bnds_norm_offset], &err_bnds_comp__[
+ err_bnds_comp_offset], nparams, ¶ms[1], &work[1], &rwork[1],
+ info);
+
+/* Scale solutions. */
+
+ if (colequ && notran) {
+ zlascl2_(n, nrhs, &c__[1], &x[x_offset], ldx);
+ } else if (rowequ && ! notran) {
+ zlascl2_(n, nrhs, &r__[1], &x[x_offset], ldx);
+ }
+
+ return 0;
+
+/* End of ZGBSVXX */
+
+} /* zgbsvxx_ */
diff --git a/SRC/zgbtf2.c b/SRC/zgbtf2.c
new file mode 100644
index 0000000..354252c
--- /dev/null
+++ b/SRC/zgbtf2.c
@@ -0,0 +1,268 @@
+/* zgbtf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zgbtf2_(integer *m, integer *n, integer *kl, integer *ku,
+ doublecomplex *ab, integer *ldab, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, km, jp, ju, kv;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zgeru_(integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), zswap_(integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(
+ char *, integer *);
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGBTF2 computes an LU factorization of a complex m-by-n band matrix */
+/* A using partial pivoting with row interchanges. */
+
+/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows KL+1 to */
+/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */
+
+/* On exit, details of the factorization: U is stored as an */
+/* upper triangular band matrix with KL+KU superdiagonals in */
+/* rows 1 to KL+KU+1, and the multipliers used during the */
+/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */
+/* See below for further details. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* M = N = 6, KL = 2, KU = 1: */
+
+/* On entry: On exit: */
+
+/* * * * + + + * * * u14 u25 u36 */
+/* * * + + + + * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */
+/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */
+
+/* Array elements marked * are not used by the routine; elements marked */
+/* + need not be set on entry, but are required by the routine to store */
+/* elements of U, because of fill-in resulting from the row */
+/* interchanges. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* KV is the number of superdiagonals in the factor U, allowing for */
+/* fill-in. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --ipiv;
+
+ /* Function Body */
+ kv = *ku + *kl;
+
+/* Test the input parameters. */
+
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*ldab < *kl + kv + 1) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGBTF2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Gaussian elimination with partial pivoting */
+
+/* Set fill-in elements in columns KU+2 to KV to zero. */
+
+ i__1 = min(kv,*n);
+ for (j = *ku + 2; j <= i__1; ++j) {
+ i__2 = *kl;
+ for (i__ = kv - j + 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * ab_dim1;
+ ab[i__3].r = 0., ab[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* JU is the index of the last column affected by the current stage */
+/* of the factorization. */
+
+ ju = 1;
+
+ i__1 = min(*m,*n);
+ for (j = 1; j <= i__1; ++j) {
+
+/* Set fill-in elements in column J+KV to zero. */
+
+ if (j + kv <= *n) {
+ i__2 = *kl;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j + kv) * ab_dim1;
+ ab[i__3].r = 0., ab[i__3].i = 0.;
+/* L30: */
+ }
+ }
+
+/* Find pivot and test for singularity. KM is the number of */
+/* subdiagonal elements in the current column. */
+
+/* Computing MIN */
+ i__2 = *kl, i__3 = *m - j;
+ km = min(i__2,i__3);
+ i__2 = km + 1;
+ jp = izamax_(&i__2, &ab[kv + 1 + j * ab_dim1], &c__1);
+ ipiv[j] = jp + j - 1;
+ i__2 = kv + jp + j * ab_dim1;
+ if (ab[i__2].r != 0. || ab[i__2].i != 0.) {
+/* Computing MAX */
+/* Computing MIN */
+ i__4 = j + *ku + jp - 1;
+ i__2 = ju, i__3 = min(i__4,*n);
+ ju = max(i__2,i__3);
+
+/* Apply interchange to columns J to JU. */
+
+ if (jp != 1) {
+ i__2 = ju - j + 1;
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ zswap_(&i__2, &ab[kv + jp + j * ab_dim1], &i__3, &ab[kv + 1 +
+ j * ab_dim1], &i__4);
+ }
+ if (km > 0) {
+
+/* Compute multipliers. */
+
+ z_div(&z__1, &c_b1, &ab[kv + 1 + j * ab_dim1]);
+ zscal_(&km, &z__1, &ab[kv + 2 + j * ab_dim1], &c__1);
+
+/* Update trailing submatrix within the band. */
+
+ if (ju > j) {
+ i__2 = ju - j;
+ z__1.r = -1., z__1.i = -0.;
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ zgeru_(&km, &i__2, &z__1, &ab[kv + 2 + j * ab_dim1], &
+ c__1, &ab[kv + (j + 1) * ab_dim1], &i__3, &ab[kv
+ + 1 + (j + 1) * ab_dim1], &i__4);
+ }
+ }
+ } else {
+
+/* If pivot is zero, set INFO to the index of the pivot */
+/* unless a zero pivot has already been found. */
+
+ if (*info == 0) {
+ *info = j;
+ }
+ }
+/* L40: */
+ }
+ return 0;
+
+/* End of ZGBTF2 */
+
+} /* zgbtf2_ */
diff --git a/SRC/zgbtrf.c b/SRC/zgbtrf.c
new file mode 100644
index 0000000..2e5c495
--- /dev/null
+++ b/SRC/zgbtrf.c
@@ -0,0 +1,605 @@
+/* zgbtrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+static integer c__65 = 65;
+
+/* Subroutine */ int zgbtrf_(integer *m, integer *n, integer *kl, integer *ku,
+ doublecomplex *ab, integer *ldab, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, i2, i3, j2, j3, k2, jb, nb, ii, jj, jm, ip, jp, km, ju,
+ kv, nw;
+ doublecomplex temp;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zgemm_(char *, char *, integer *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ doublecomplex work13[4160] /* was [65][64] */, work31[4160] /*
+ was [65][64] */;
+ extern /* Subroutine */ int zgeru_(integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zcopy_(integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), zswap_(integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *), ztrsm_(
+ char *, char *, char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zgbtf2_(integer *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *), izamax_(integer *,
+ doublecomplex *, integer *);
+ extern /* Subroutine */ int zlaswp_(integer *, doublecomplex *, integer *,
+ integer *, integer *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGBTRF computes an LU factorization of a complex m-by-n band matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* This is the blocked version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows KL+1 to */
+/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */
+
+/* On exit, details of the factorization: U is stored as an */
+/* upper triangular band matrix with KL+KU superdiagonals in */
+/* rows 1 to KL+KU+1, and the multipliers used during the */
+/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */
+/* See below for further details. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* M = N = 6, KL = 2, KU = 1: */
+
+/* On entry: On exit: */
+
+/* * * * + + + * * * u14 u25 u36 */
+/* * * + + + + * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */
+/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */
+
+/* Array elements marked * are not used by the routine; elements marked */
+/* + need not be set on entry, but are required by the routine to store */
+/* elements of U because of fill-in resulting from the row interchanges. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* KV is the number of superdiagonals in the factor U, allowing for */
+/* fill-in */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --ipiv;
+
+ /* Function Body */
+ kv = *ku + *kl;
+
+/* Test the input parameters. */
+
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*ldab < *kl + kv + 1) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGBTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment */
+
+ nb = ilaenv_(&c__1, "ZGBTRF", " ", m, n, kl, ku);
+
+/* The block size must not exceed the limit set by the size of the */
+/* local arrays WORK13 and WORK31. */
+
+ nb = min(nb,64);
+
+ if (nb <= 1 || nb > *kl) {
+
+/* Use unblocked code */
+
+ zgbtf2_(m, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info);
+ } else {
+
+/* Use blocked code */
+
+/* Zero the superdiagonal elements of the work array WORK13 */
+
+ i__1 = nb;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 65 - 66;
+ work13[i__3].r = 0., work13[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Zero the subdiagonal elements of the work array WORK31 */
+
+ i__1 = nb;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = nb;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 65 - 66;
+ work31[i__3].r = 0., work31[i__3].i = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Gaussian elimination with partial pivoting */
+
+/* Set fill-in elements in columns KU+2 to KV to zero */
+
+ i__1 = min(kv,*n);
+ for (j = *ku + 2; j <= i__1; ++j) {
+ i__2 = *kl;
+ for (i__ = kv - j + 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * ab_dim1;
+ ab[i__3].r = 0., ab[i__3].i = 0.;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* JU is the index of the last column affected by the current */
+/* stage of the factorization */
+
+ ju = 1;
+
+ i__1 = min(*m,*n);
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = min(*m,*n) - j + 1;
+ jb = min(i__3,i__4);
+
+/* The active part of the matrix is partitioned */
+
+/* A11 A12 A13 */
+/* A21 A22 A23 */
+/* A31 A32 A33 */
+
+/* Here A11, A21 and A31 denote the current block of JB columns */
+/* which is about to be factorized. The number of rows in the */
+/* partitioning are JB, I2, I3 respectively, and the numbers */
+/* of columns are JB, J2, J3. The superdiagonal elements of A13 */
+/* and the subdiagonal elements of A31 lie outside the band. */
+
+/* Computing MIN */
+ i__3 = *kl - jb, i__4 = *m - j - jb + 1;
+ i2 = min(i__3,i__4);
+/* Computing MIN */
+ i__3 = jb, i__4 = *m - j - *kl + 1;
+ i3 = min(i__3,i__4);
+
+/* J2 and J3 are computed after JU has been updated. */
+
+/* Factorize the current block of JB columns */
+
+ i__3 = j + jb - 1;
+ for (jj = j; jj <= i__3; ++jj) {
+
+/* Set fill-in elements in column JJ+KV to zero */
+
+ if (jj + kv <= *n) {
+ i__4 = *kl;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__ + (jj + kv) * ab_dim1;
+ ab[i__5].r = 0., ab[i__5].i = 0.;
+/* L70: */
+ }
+ }
+
+/* Find pivot and test for singularity. KM is the number of */
+/* subdiagonal elements in the current column. */
+
+/* Computing MIN */
+ i__4 = *kl, i__5 = *m - jj;
+ km = min(i__4,i__5);
+ i__4 = km + 1;
+ jp = izamax_(&i__4, &ab[kv + 1 + jj * ab_dim1], &c__1);
+ ipiv[jj] = jp + jj - j;
+ i__4 = kv + jp + jj * ab_dim1;
+ if (ab[i__4].r != 0. || ab[i__4].i != 0.) {
+/* Computing MAX */
+/* Computing MIN */
+ i__6 = jj + *ku + jp - 1;
+ i__4 = ju, i__5 = min(i__6,*n);
+ ju = max(i__4,i__5);
+ if (jp != 1) {
+
+/* Apply interchange to columns J to J+JB-1 */
+
+ if (jp + jj - 1 < j + *kl) {
+
+ i__4 = *ldab - 1;
+ i__5 = *ldab - 1;
+ zswap_(&jb, &ab[kv + 1 + jj - j + j * ab_dim1], &
+ i__4, &ab[kv + jp + jj - j + j * ab_dim1],
+ &i__5);
+ } else {
+
+/* The interchange affects columns J to JJ-1 of A31 */
+/* which are stored in the work array WORK31 */
+
+ i__4 = jj - j;
+ i__5 = *ldab - 1;
+ zswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1],
+ &i__5, &work31[jp + jj - j - *kl - 1], &
+ c__65);
+ i__4 = j + jb - jj;
+ i__5 = *ldab - 1;
+ i__6 = *ldab - 1;
+ zswap_(&i__4, &ab[kv + 1 + jj * ab_dim1], &i__5, &
+ ab[kv + jp + jj * ab_dim1], &i__6);
+ }
+ }
+
+/* Compute multipliers */
+
+ z_div(&z__1, &c_b1, &ab[kv + 1 + jj * ab_dim1]);
+ zscal_(&km, &z__1, &ab[kv + 2 + jj * ab_dim1], &c__1);
+
+/* Update trailing submatrix within the band and within */
+/* the current block. JM is the index of the last column */
+/* which needs to be updated. */
+
+/* Computing MIN */
+ i__4 = ju, i__5 = j + jb - 1;
+ jm = min(i__4,i__5);
+ if (jm > jj) {
+ i__4 = jm - jj;
+ z__1.r = -1., z__1.i = -0.;
+ i__5 = *ldab - 1;
+ i__6 = *ldab - 1;
+ zgeru_(&km, &i__4, &z__1, &ab[kv + 2 + jj * ab_dim1],
+ &c__1, &ab[kv + (jj + 1) * ab_dim1], &i__5, &
+ ab[kv + 1 + (jj + 1) * ab_dim1], &i__6);
+ }
+ } else {
+
+/* If pivot is zero, set INFO to the index of the pivot */
+/* unless a zero pivot has already been found. */
+
+ if (*info == 0) {
+ *info = jj;
+ }
+ }
+
+/* Copy current column of A31 into the work array WORK31 */
+
+/* Computing MIN */
+ i__4 = jj - j + 1;
+ nw = min(i__4,i3);
+ if (nw > 0) {
+ zcopy_(&nw, &ab[kv + *kl + 1 - jj + j + jj * ab_dim1], &
+ c__1, &work31[(jj - j + 1) * 65 - 65], &c__1);
+ }
+/* L80: */
+ }
+ if (j + jb <= *n) {
+
+/* Apply the row interchanges to the other blocks. */
+
+/* Computing MIN */
+ i__3 = ju - j + 1;
+ j2 = min(i__3,kv) - jb;
+/* Computing MAX */
+ i__3 = 0, i__4 = ju - j - kv + 1;
+ j3 = max(i__3,i__4);
+
+/* Use ZLASWP to apply the row interchanges to A12, A22, and */
+/* A32. */
+
+ i__3 = *ldab - 1;
+ zlaswp_(&j2, &ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__3, &
+ c__1, &jb, &ipiv[j], &c__1);
+
+/* Adjust the pivot indices. */
+
+ i__3 = j + jb - 1;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ ipiv[i__] = ipiv[i__] + j - 1;
+/* L90: */
+ }
+
+/* Apply the row interchanges to A13, A23, and A33 */
+/* columnwise. */
+
+ k2 = j - 1 + jb + j2;
+ i__3 = j3;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ jj = k2 + i__;
+ i__4 = j + jb - 1;
+ for (ii = j + i__ - 1; ii <= i__4; ++ii) {
+ ip = ipiv[ii];
+ if (ip != ii) {
+ i__5 = kv + 1 + ii - jj + jj * ab_dim1;
+ temp.r = ab[i__5].r, temp.i = ab[i__5].i;
+ i__5 = kv + 1 + ii - jj + jj * ab_dim1;
+ i__6 = kv + 1 + ip - jj + jj * ab_dim1;
+ ab[i__5].r = ab[i__6].r, ab[i__5].i = ab[i__6].i;
+ i__5 = kv + 1 + ip - jj + jj * ab_dim1;
+ ab[i__5].r = temp.r, ab[i__5].i = temp.i;
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+
+/* Update the relevant part of the trailing submatrix */
+
+ if (j2 > 0) {
+
+/* Update A12 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ ztrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j2,
+ &c_b1, &ab[kv + 1 + j * ab_dim1], &i__3, &ab[kv +
+ 1 - jb + (j + jb) * ab_dim1], &i__4);
+
+ if (i2 > 0) {
+
+/* Update A22 */
+
+ z__1.r = -1., z__1.i = -0.;
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ i__5 = *ldab - 1;
+ zgemm_("No transpose", "No transpose", &i2, &j2, &jb,
+ &z__1, &ab[kv + 1 + jb + j * ab_dim1], &i__3,
+ &ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__4,
+ &c_b1, &ab[kv + 1 + (j + jb) * ab_dim1], &
+ i__5);
+ }
+
+ if (i3 > 0) {
+
+/* Update A32 */
+
+ z__1.r = -1., z__1.i = -0.;
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ zgemm_("No transpose", "No transpose", &i3, &j2, &jb,
+ &z__1, work31, &c__65, &ab[kv + 1 - jb + (j +
+ jb) * ab_dim1], &i__3, &c_b1, &ab[kv + *kl +
+ 1 - jb + (j + jb) * ab_dim1], &i__4);
+ }
+ }
+
+ if (j3 > 0) {
+
+/* Copy the lower triangle of A13 into the work array */
+/* WORK13 */
+
+ i__3 = j3;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = jb;
+ for (ii = jj; ii <= i__4; ++ii) {
+ i__5 = ii + jj * 65 - 66;
+ i__6 = ii - jj + 1 + (jj + j + kv - 1) * ab_dim1;
+ work13[i__5].r = ab[i__6].r, work13[i__5].i = ab[
+ i__6].i;
+/* L120: */
+ }
+/* L130: */
+ }
+
+/* Update A13 in the work array */
+
+ i__3 = *ldab - 1;
+ ztrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j3,
+ &c_b1, &ab[kv + 1 + j * ab_dim1], &i__3, work13, &
+ c__65);
+
+ if (i2 > 0) {
+
+/* Update A23 */
+
+ z__1.r = -1., z__1.i = -0.;
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ zgemm_("No transpose", "No transpose", &i2, &j3, &jb,
+ &z__1, &ab[kv + 1 + jb + j * ab_dim1], &i__3,
+ work13, &c__65, &c_b1, &ab[jb + 1 + (j + kv) *
+ ab_dim1], &i__4);
+ }
+
+ if (i3 > 0) {
+
+/* Update A33 */
+
+ z__1.r = -1., z__1.i = -0.;
+ i__3 = *ldab - 1;
+ zgemm_("No transpose", "No transpose", &i3, &j3, &jb,
+ &z__1, work31, &c__65, work13, &c__65, &c_b1,
+ &ab[*kl + 1 + (j + kv) * ab_dim1], &i__3);
+ }
+
+/* Copy the lower triangle of A13 back into place */
+
+ i__3 = j3;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = jb;
+ for (ii = jj; ii <= i__4; ++ii) {
+ i__5 = ii - jj + 1 + (jj + j + kv - 1) * ab_dim1;
+ i__6 = ii + jj * 65 - 66;
+ ab[i__5].r = work13[i__6].r, ab[i__5].i = work13[
+ i__6].i;
+/* L140: */
+ }
+/* L150: */
+ }
+ }
+ } else {
+
+/* Adjust the pivot indices. */
+
+ i__3 = j + jb - 1;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ ipiv[i__] = ipiv[i__] + j - 1;
+/* L160: */
+ }
+ }
+
+/* Partially undo the interchanges in the current block to */
+/* restore the upper triangular form of A31 and copy the upper */
+/* triangle of A31 back into place */
+
+ i__3 = j;
+ for (jj = j + jb - 1; jj >= i__3; --jj) {
+ jp = ipiv[jj] - jj + 1;
+ if (jp != 1) {
+
+/* Apply interchange to columns J to JJ-1 */
+
+ if (jp + jj - 1 < j + *kl) {
+
+/* The interchange does not affect A31 */
+
+ i__4 = jj - j;
+ i__5 = *ldab - 1;
+ i__6 = *ldab - 1;
+ zswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], &
+ i__5, &ab[kv + jp + jj - j + j * ab_dim1], &
+ i__6);
+ } else {
+
+/* The interchange does affect A31 */
+
+ i__4 = jj - j;
+ i__5 = *ldab - 1;
+ zswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], &
+ i__5, &work31[jp + jj - j - *kl - 1], &c__65);
+ }
+ }
+
+/* Copy the current column of A31 back into place */
+
+/* Computing MIN */
+ i__4 = i3, i__5 = jj - j + 1;
+ nw = min(i__4,i__5);
+ if (nw > 0) {
+ zcopy_(&nw, &work31[(jj - j + 1) * 65 - 65], &c__1, &ab[
+ kv + *kl + 1 - jj + j + jj * ab_dim1], &c__1);
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+
+ return 0;
+
+/* End of ZGBTRF */
+
+} /* zgbtrf_ */
diff --git a/SRC/zgbtrs.c b/SRC/zgbtrs.c
new file mode 100644
index 0000000..a4c641a
--- /dev/null
+++ b/SRC/zgbtrs.c
@@ -0,0 +1,281 @@
+/* zgbtrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zgbtrs_(char *trans, integer *n, integer *kl, integer *
+ ku, integer *nrhs, doublecomplex *ab, integer *ldab, integer *ipiv,
+ doublecomplex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j, l, kd, lm;
+ extern logical lsame_(char *, char *);
+ logical lnoti;
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zgeru_(integer *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *)
+ , zswap_(integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), ztbsv_(char *, char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *), zlacgv_(
+ integer *, doublecomplex *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGBTRS solves a system of linear equations */
+/* A * X = B, A**T * X = B, or A**H * X = B */
+/* with a general band matrix A using the LU factorization computed */
+/* by ZGBTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by ZGBTRF. U is stored as an upper triangular band */
+/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
+/* the multipliers used during the factorization are stored in */
+/* rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= N, row i of the matrix was */
+/* interchanged with row IPIV(i). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0) {
+ *info = -3;
+ } else if (*ku < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*ldab < (*kl << 1) + *ku + 1) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGBTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ kd = *ku + *kl + 1;
+ lnoti = *kl > 0;
+
+ if (notran) {
+
+/* Solve A*X = B. */
+
+/* Solve L*X = B, overwriting B with X. */
+
+/* L is represented as a product of permutations and unit lower */
+/* triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), */
+/* where each transformation L(i) is a rank-one modification of */
+/* the identity matrix. */
+
+ if (lnoti) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *kl, i__3 = *n - j;
+ lm = min(i__2,i__3);
+ l = ipiv[j];
+ if (l != j) {
+ zswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb);
+ }
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&lm, nrhs, &z__1, &ab[kd + 1 + j * ab_dim1], &c__1, &b[
+ j + b_dim1], ldb, &b[j + 1 + b_dim1], ldb);
+/* L10: */
+ }
+ }
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Solve U*X = B, overwriting B with X. */
+
+ i__2 = *kl + *ku;
+ ztbsv_("Upper", "No transpose", "Non-unit", n, &i__2, &ab[
+ ab_offset], ldab, &b[i__ * b_dim1 + 1], &c__1);
+/* L20: */
+ }
+
+ } else if (lsame_(trans, "T")) {
+
+/* Solve A**T * X = B. */
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Solve U**T * X = B, overwriting B with X. */
+
+ i__2 = *kl + *ku;
+ ztbsv_("Upper", "Transpose", "Non-unit", n, &i__2, &ab[ab_offset],
+ ldab, &b[i__ * b_dim1 + 1], &c__1);
+/* L30: */
+ }
+
+/* Solve L**T * X = B, overwriting B with X. */
+
+ if (lnoti) {
+ for (j = *n - 1; j >= 1; --j) {
+/* Computing MIN */
+ i__1 = *kl, i__2 = *n - j;
+ lm = min(i__1,i__2);
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Transpose", &lm, nrhs, &z__1, &b[j + 1 + b_dim1], ldb,
+ &ab[kd + 1 + j * ab_dim1], &c__1, &c_b1, &b[j +
+ b_dim1], ldb);
+ l = ipiv[j];
+ if (l != j) {
+ zswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb);
+ }
+/* L40: */
+ }
+ }
+
+ } else {
+
+/* Solve A**H * X = B. */
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Solve U**H * X = B, overwriting B with X. */
+
+ i__2 = *kl + *ku;
+ ztbsv_("Upper", "Conjugate transpose", "Non-unit", n, &i__2, &ab[
+ ab_offset], ldab, &b[i__ * b_dim1 + 1], &c__1);
+/* L50: */
+ }
+
+/* Solve L**H * X = B, overwriting B with X. */
+
+ if (lnoti) {
+ for (j = *n - 1; j >= 1; --j) {
+/* Computing MIN */
+ i__1 = *kl, i__2 = *n - j;
+ lm = min(i__1,i__2);
+ zlacgv_(nrhs, &b[j + b_dim1], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Conjugate transpose", &lm, nrhs, &z__1, &b[j + 1 +
+ b_dim1], ldb, &ab[kd + 1 + j * ab_dim1], &c__1, &c_b1,
+ &b[j + b_dim1], ldb);
+ zlacgv_(nrhs, &b[j + b_dim1], ldb);
+ l = ipiv[j];
+ if (l != j) {
+ zswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb);
+ }
+/* L60: */
+ }
+ }
+ }
+ return 0;
+
+/* End of ZGBTRS */
+
+} /* zgbtrs_ */
diff --git a/SRC/zgebak.c b/SRC/zgebak.c
new file mode 100644
index 0000000..2e65764
--- /dev/null
+++ b/SRC/zgebak.c
@@ -0,0 +1,235 @@
+/* zgebak.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zgebak_(char *job, char *side, integer *n, integer *ilo,
+ integer *ihi, doublereal *scale, integer *m, doublecomplex *v,
+ integer *ldv, integer *info)
+{
+ /* System generated locals */
+ integer v_dim1, v_offset, i__1;
+
+ /* Local variables */
+ integer i__, k;
+ doublereal s;
+ integer ii;
+ extern logical lsame_(char *, char *);
+ logical leftv;
+ extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), xerbla_(char *, integer *),
+ zdscal_(integer *, doublereal *, doublecomplex *, integer *);
+ logical rightv;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGEBAK forms the right or left eigenvectors of a complex general */
+/* matrix by backward transformation on the computed eigenvectors of the */
+/* balanced matrix output by ZGEBAL. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies the type of backward transformation required: */
+/* = 'N', do nothing, return immediately; */
+/* = 'P', do backward transformation for permutation only; */
+/* = 'S', do backward transformation for scaling only; */
+/* = 'B', do backward transformations for both permutation and */
+/* scaling. */
+/* JOB must be the same as the argument JOB supplied to ZGEBAL. */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'R': V contains right eigenvectors; */
+/* = 'L': V contains left eigenvectors. */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrix V. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* The integers ILO and IHI determined by ZGEBAL. */
+/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
+
+/* SCALE (input) DOUBLE PRECISION array, dimension (N) */
+/* Details of the permutation and scaling factors, as returned */
+/* by ZGEBAL. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix V. M >= 0. */
+
+/* V (input/output) COMPLEX*16 array, dimension (LDV,M) */
+/* On entry, the matrix of right or left eigenvectors to be */
+/* transformed, as returned by ZHSEIN or ZTREVC. */
+/* On exit, V is overwritten by the transformed eigenvectors. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. LDV >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and Test the input parameters */
+
+ /* Parameter adjustments */
+ --scale;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+
+ /* Function Body */
+ rightv = lsame_(side, "R");
+ leftv = lsame_(side, "L");
+
+ *info = 0;
+ if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
+ && ! lsame_(job, "B")) {
+ *info = -1;
+ } else if (! rightv && ! leftv) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ilo < 1 || *ilo > max(1,*n)) {
+ *info = -4;
+ } else if (*ihi < min(*ilo,*n) || *ihi > *n) {
+ *info = -5;
+ } else if (*m < 0) {
+ *info = -7;
+ } else if (*ldv < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGEBAK", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+ if (*m == 0) {
+ return 0;
+ }
+ if (lsame_(job, "N")) {
+ return 0;
+ }
+
+ if (*ilo == *ihi) {
+ goto L30;
+ }
+
+/* Backward balance */
+
+ if (lsame_(job, "S") || lsame_(job, "B")) {
+
+ if (rightv) {
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ s = scale[i__];
+ zdscal_(m, &s, &v[i__ + v_dim1], ldv);
+/* L10: */
+ }
+ }
+
+ if (leftv) {
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ s = 1. / scale[i__];
+ zdscal_(m, &s, &v[i__ + v_dim1], ldv);
+/* L20: */
+ }
+ }
+
+ }
+
+/* Backward permutation */
+
+/* For I = ILO-1 step -1 until 1, */
+/* IHI+1 step 1 until N do -- */
+
+L30:
+ if (lsame_(job, "P") || lsame_(job, "B")) {
+ if (rightv) {
+ i__1 = *n;
+ for (ii = 1; ii <= i__1; ++ii) {
+ i__ = ii;
+ if (i__ >= *ilo && i__ <= *ihi) {
+ goto L40;
+ }
+ if (i__ < *ilo) {
+ i__ = *ilo - ii;
+ }
+ k = (integer) scale[i__];
+ if (k == i__) {
+ goto L40;
+ }
+ zswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L40:
+ ;
+ }
+ }
+
+ if (leftv) {
+ i__1 = *n;
+ for (ii = 1; ii <= i__1; ++ii) {
+ i__ = ii;
+ if (i__ >= *ilo && i__ <= *ihi) {
+ goto L50;
+ }
+ if (i__ < *ilo) {
+ i__ = *ilo - ii;
+ }
+ k = (integer) scale[i__];
+ if (k == i__) {
+ goto L50;
+ }
+ zswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L50:
+ ;
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZGEBAK */
+
+} /* zgebak_ */
diff --git a/SRC/zgebal.c b/SRC/zgebal.c
new file mode 100644
index 0000000..a7bfca2
--- /dev/null
+++ b/SRC/zgebal.c
@@ -0,0 +1,414 @@
+/* zgebal.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zgebal_(char *job, integer *n, doublecomplex *a, integer
+ *lda, integer *ilo, integer *ihi, doublereal *scale, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *), z_abs(doublecomplex *);
+
+ /* Local variables */
+ doublereal c__, f, g;
+ integer i__, j, k, l, m;
+ doublereal r__, s, ca, ra;
+ integer ica, ira, iexc;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ doublereal sfmin1, sfmin2, sfmax1, sfmax2;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
+ integer *, doublereal *, doublecomplex *, integer *);
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ logical noconv;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGEBAL balances a general complex matrix A. This involves, first, */
+/* permuting A by a similarity transformation to isolate eigenvalues */
+/* in the first 1 to ILO-1 and last IHI+1 to N elements on the */
+/* diagonal; and second, applying a diagonal similarity transformation */
+/* to rows and columns ILO to IHI to make the rows and columns as */
+/* close in norm as possible. Both steps are optional. */
+
+/* Balancing may reduce the 1-norm of the matrix, and improve the */
+/* accuracy of the computed eigenvalues and/or eigenvectors. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies the operations to be performed on A: */
+/* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 */
+/* for i = 1,...,N; */
+/* = 'P': permute only; */
+/* = 'S': scale only; */
+/* = 'B': both permute and scale. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the input matrix A. */
+/* On exit, A is overwritten by the balanced matrix. */
+/* If JOB = 'N', A is not referenced. */
+/* See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* ILO (output) INTEGER */
+/* IHI (output) INTEGER */
+/* ILO and IHI are set to integers such that on exit */
+/* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. */
+/* If JOB = 'N' or 'S', ILO = 1 and IHI = N. */
+
+/* SCALE (output) DOUBLE PRECISION array, dimension (N) */
+/* Details of the permutations and scaling factors applied to */
+/* A. If P(j) is the index of the row and column interchanged */
+/* with row and column j and D(j) is the scaling factor */
+/* applied to row and column j, then */
+/* SCALE(j) = P(j) for j = 1,...,ILO-1 */
+/* = D(j) for j = ILO,...,IHI */
+/* = P(j) for j = IHI+1,...,N. */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The permutations consist of row and column interchanges which put */
+/* the matrix in the form */
+
+/* ( T1 X Y ) */
+/* P A P = ( 0 B Z ) */
+/* ( 0 0 T2 ) */
+
+/* where T1 and T2 are upper triangular matrices whose eigenvalues lie */
+/* along the diagonal. The column indices ILO and IHI mark the starting */
+/* and ending columns of the submatrix B. Balancing consists of applying */
+/* a diagonal similarity transformation inv(D) * B * D to make the */
+/* 1-norms of each row of B and its corresponding column nearly equal. */
+/* The output matrix is */
+
+/* ( T1 X*D Y ) */
+/* ( 0 inv(D)*B*D inv(D)*Z ). */
+/* ( 0 0 T2 ) */
+
+/* Information about the permutations P and the diagonal matrix D is */
+/* returned in the vector SCALE. */
+
+/* This subroutine is based on the EISPACK routine CBAL. */
+
+/* Modified by Tzu-Yi Chen, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --scale;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
+ && ! lsame_(job, "B")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGEBAL", &i__1);
+ return 0;
+ }
+
+ k = 1;
+ l = *n;
+
+ if (*n == 0) {
+ goto L210;
+ }
+
+ if (lsame_(job, "N")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ scale[i__] = 1.;
+/* L10: */
+ }
+ goto L210;
+ }
+
+ if (lsame_(job, "S")) {
+ goto L120;
+ }
+
+/* Permutation to isolate eigenvalues if possible */
+
+ goto L50;
+
+/* Row and column exchange. */
+
+L20:
+ scale[m] = (doublereal) j;
+ if (j == m) {
+ goto L30;
+ }
+
+ zswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
+ i__1 = *n - k + 1;
+ zswap_(&i__1, &a[j + k * a_dim1], lda, &a[m + k * a_dim1], lda);
+
+L30:
+ switch (iexc) {
+ case 1: goto L40;
+ case 2: goto L80;
+ }
+
+/* Search for rows isolating an eigenvalue and push them down. */
+
+L40:
+ if (l == 1) {
+ goto L210;
+ }
+ --l;
+
+L50:
+ for (j = l; j >= 1; --j) {
+
+ i__1 = l;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (i__ == j) {
+ goto L60;
+ }
+ i__2 = j + i__ * a_dim1;
+ if (a[i__2].r != 0. || d_imag(&a[j + i__ * a_dim1]) != 0.) {
+ goto L70;
+ }
+L60:
+ ;
+ }
+
+ m = l;
+ iexc = 1;
+ goto L20;
+L70:
+ ;
+ }
+
+ goto L90;
+
+/* Search for columns isolating an eigenvalue and push them left. */
+
+L80:
+ ++k;
+
+L90:
+ i__1 = l;
+ for (j = k; j <= i__1; ++j) {
+
+ i__2 = l;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ if (i__ == j) {
+ goto L100;
+ }
+ i__3 = i__ + j * a_dim1;
+ if (a[i__3].r != 0. || d_imag(&a[i__ + j * a_dim1]) != 0.) {
+ goto L110;
+ }
+L100:
+ ;
+ }
+
+ m = k;
+ iexc = 2;
+ goto L20;
+L110:
+ ;
+ }
+
+L120:
+ i__1 = l;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ scale[i__] = 1.;
+/* L130: */
+ }
+
+ if (lsame_(job, "P")) {
+ goto L210;
+ }
+
+/* Balance the submatrix in rows K to L. */
+
+/* Iterative loop for norm reduction */
+
+ sfmin1 = dlamch_("S") / dlamch_("P");
+ sfmax1 = 1. / sfmin1;
+ sfmin2 = sfmin1 * 2.;
+ sfmax2 = 1. / sfmin2;
+L140:
+ noconv = FALSE_;
+
+ i__1 = l;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ c__ = 0.;
+ r__ = 0.;
+
+ i__2 = l;
+ for (j = k; j <= i__2; ++j) {
+ if (j == i__) {
+ goto L150;
+ }
+ i__3 = j + i__ * a_dim1;
+ c__ += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[j + i__ *
+ a_dim1]), abs(d__2));
+ i__3 = i__ + j * a_dim1;
+ r__ += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + j *
+ a_dim1]), abs(d__2));
+L150:
+ ;
+ }
+ ica = izamax_(&l, &a[i__ * a_dim1 + 1], &c__1);
+ ca = z_abs(&a[ica + i__ * a_dim1]);
+ i__2 = *n - k + 1;
+ ira = izamax_(&i__2, &a[i__ + k * a_dim1], lda);
+ ra = z_abs(&a[i__ + (ira + k - 1) * a_dim1]);
+
+/* Guard against zero C or R due to underflow. */
+
+ if (c__ == 0. || r__ == 0.) {
+ goto L200;
+ }
+ g = r__ / 2.;
+ f = 1.;
+ s = c__ + r__;
+L160:
+/* Computing MAX */
+ d__1 = max(f,c__);
+/* Computing MIN */
+ d__2 = min(r__,g);
+ if (c__ >= g || max(d__1,ca) >= sfmax2 || min(d__2,ra) <= sfmin2) {
+ goto L170;
+ }
+ f *= 2.;
+ c__ *= 2.;
+ ca *= 2.;
+ r__ /= 2.;
+ g /= 2.;
+ ra /= 2.;
+ goto L160;
+
+L170:
+ g = c__ / 2.;
+L180:
+/* Computing MIN */
+ d__1 = min(f,c__), d__1 = min(d__1,g);
+ if (g < r__ || max(r__,ra) >= sfmax2 || min(d__1,ca) <= sfmin2) {
+ goto L190;
+ }
+ f /= 2.;
+ c__ /= 2.;
+ g /= 2.;
+ ca /= 2.;
+ r__ *= 2.;
+ ra *= 2.;
+ goto L180;
+
+/* Now balance. */
+
+L190:
+ if (c__ + r__ >= s * .95) {
+ goto L200;
+ }
+ if (f < 1. && scale[i__] < 1.) {
+ if (f * scale[i__] <= sfmin1) {
+ goto L200;
+ }
+ }
+ if (f > 1. && scale[i__] > 1.) {
+ if (scale[i__] >= sfmax1 / f) {
+ goto L200;
+ }
+ }
+ g = 1. / f;
+ scale[i__] *= f;
+ noconv = TRUE_;
+
+ i__2 = *n - k + 1;
+ zdscal_(&i__2, &g, &a[i__ + k * a_dim1], lda);
+ zdscal_(&l, &f, &a[i__ * a_dim1 + 1], &c__1);
+
+L200:
+ ;
+ }
+
+ if (noconv) {
+ goto L140;
+ }
+
+L210:
+ *ilo = k;
+ *ihi = l;
+
+ return 0;
+
+/* End of ZGEBAL */
+
+} /* zgebal_ */
diff --git a/SRC/zgebd2.c b/SRC/zgebd2.c
new file mode 100644
index 0000000..8522fa8
--- /dev/null
+++ b/SRC/zgebd2.c
@@ -0,0 +1,345 @@
+/* zgebd2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zgebd2_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublereal *d__, doublereal *e, doublecomplex *tauq,
+ doublecomplex *taup, doublecomplex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__;
+ doublecomplex alpha;
+ extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *), xerbla_(char *, integer *), zlarfg_(integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *), zlacgv_(integer *, doublecomplex *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGEBD2 reduces a complex general m by n matrix A to upper or lower */
+/* real bidiagonal form B by a unitary transformation: Q' * A * P = B. */
+
+/* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows in the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns in the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the m by n general matrix to be reduced. */
+/* On exit, */
+/* if m >= n, the diagonal and the first superdiagonal are */
+/* overwritten with the upper bidiagonal matrix B; the */
+/* elements below the diagonal, with the array TAUQ, represent */
+/* the unitary matrix Q as a product of elementary */
+/* reflectors, and the elements above the first superdiagonal, */
+/* with the array TAUP, represent the unitary matrix P as */
+/* a product of elementary reflectors; */
+/* if m < n, the diagonal and the first subdiagonal are */
+/* overwritten with the lower bidiagonal matrix B; the */
+/* elements below the first subdiagonal, with the array TAUQ, */
+/* represent the unitary matrix Q as a product of */
+/* elementary reflectors, and the elements above the diagonal, */
+/* with the array TAUP, represent the unitary matrix P as */
+/* a product of elementary reflectors. */
+/* See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* D (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The diagonal elements of the bidiagonal matrix B: */
+/* D(i) = A(i,i). */
+
+/* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) */
+/* The off-diagonal elements of the bidiagonal matrix B: */
+/* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */
+/* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */
+
+/* TAUQ (output) COMPLEX*16 array dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the unitary matrix Q. See Further Details. */
+
+/* TAUP (output) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the unitary matrix P. See Further Details. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (max(M,N)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrices Q and P are represented as products of elementary */
+/* reflectors: */
+
+/* If m >= n, */
+
+/* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) */
+
+/* Each H(i) and G(i) has the form: */
+
+/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
+
+/* where tauq and taup are complex scalars, and v and u are complex */
+/* vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in */
+/* A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in */
+/* A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* If m < n, */
+
+/* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) */
+
+/* Each H(i) and G(i) has the form: */
+
+/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
+
+/* where tauq and taup are complex scalars, v and u are complex vectors; */
+/* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); */
+/* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); */
+/* tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* The contents of A on exit are illustrated by the following examples: */
+
+/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
+
+/* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) */
+/* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) */
+/* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) */
+/* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) */
+/* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) */
+/* ( v1 v2 v3 v4 v5 ) */
+
+/* where d and e denote diagonal and off-diagonal elements of B, vi */
+/* denotes an element of the vector defining H(i), and ui an element of */
+/* the vector defining G(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ --tauq;
+ --taup;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("ZGEBD2", &i__1);
+ return 0;
+ }
+
+ if (*m >= *n) {
+
+/* Reduce to upper bidiagonal form */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
+
+ i__2 = i__ + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *m - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ zlarfg_(&i__2, &alpha, &a[min(i__3, *m)+ i__ * a_dim1], &c__1, &
+ tauq[i__]);
+ i__2 = i__;
+ d__[i__2] = alpha.r;
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+
+/* Apply H(i)' to A(i:m,i+1:n) from the left */
+
+ if (i__ < *n) {
+ i__2 = *m - i__ + 1;
+ i__3 = *n - i__;
+ d_cnjg(&z__1, &tauq[i__]);
+ zlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
+ z__1, &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
+ }
+ i__2 = i__ + i__ * a_dim1;
+ i__3 = i__;
+ a[i__2].r = d__[i__3], a[i__2].i = 0.;
+
+ if (i__ < *n) {
+
+/* Generate elementary reflector G(i) to annihilate */
+/* A(i,i+2:n) */
+
+ i__2 = *n - i__;
+ zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
+ i__2 = i__ + (i__ + 1) * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *n - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ zlarfg_(&i__2, &alpha, &a[i__ + min(i__3, *n)* a_dim1], lda, &
+ taup[i__]);
+ i__2 = i__;
+ e[i__2] = alpha.r;
+ i__2 = i__ + (i__ + 1) * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+
+/* Apply G(i) to A(i+1:m,i+1:n) from the right */
+
+ i__2 = *m - i__;
+ i__3 = *n - i__;
+ zlarf_("Right", &i__2, &i__3, &a[i__ + (i__ + 1) * a_dim1],
+ lda, &taup[i__], &a[i__ + 1 + (i__ + 1) * a_dim1],
+ lda, &work[1]);
+ i__2 = *n - i__;
+ zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
+ i__2 = i__ + (i__ + 1) * a_dim1;
+ i__3 = i__;
+ a[i__2].r = e[i__3], a[i__2].i = 0.;
+ } else {
+ i__2 = i__;
+ taup[i__2].r = 0., taup[i__2].i = 0.;
+ }
+/* L10: */
+ }
+ } else {
+
+/* Reduce to lower bidiagonal form */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Generate elementary reflector G(i) to annihilate A(i,i+1:n) */
+
+ i__2 = *n - i__ + 1;
+ zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
+ i__2 = i__ + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *n - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ zlarfg_(&i__2, &alpha, &a[i__ + min(i__3, *n)* a_dim1], lda, &
+ taup[i__]);
+ i__2 = i__;
+ d__[i__2] = alpha.r;
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+
+/* Apply G(i) to A(i+1:m,i:n) from the right */
+
+ if (i__ < *m) {
+ i__2 = *m - i__;
+ i__3 = *n - i__ + 1;
+ zlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &
+ taup[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]);
+ }
+ i__2 = *n - i__ + 1;
+ zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
+ i__2 = i__ + i__ * a_dim1;
+ i__3 = i__;
+ a[i__2].r = d__[i__3], a[i__2].i = 0.;
+
+ if (i__ < *m) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* A(i+2:m,i) */
+
+ i__2 = i__ + 1 + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *m - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ zlarfg_(&i__2, &alpha, &a[min(i__3, *m)+ i__ * a_dim1], &c__1,
+ &tauq[i__]);
+ i__2 = i__;
+ e[i__2] = alpha.r;
+ i__2 = i__ + 1 + i__ * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+
+/* Apply H(i)' to A(i+1:m,i+1:n) from the left */
+
+ i__2 = *m - i__;
+ i__3 = *n - i__;
+ d_cnjg(&z__1, &tauq[i__]);
+ zlarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &
+ c__1, &z__1, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &
+ work[1]);
+ i__2 = i__ + 1 + i__ * a_dim1;
+ i__3 = i__;
+ a[i__2].r = e[i__3], a[i__2].i = 0.;
+ } else {
+ i__2 = i__;
+ tauq[i__2].r = 0., tauq[i__2].i = 0.;
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+/* End of ZGEBD2 */
+
+} /* zgebd2_ */
diff --git a/SRC/zgebrd.c b/SRC/zgebrd.c
new file mode 100644
index 0000000..8ec2dff
--- /dev/null
+++ b/SRC/zgebrd.c
@@ -0,0 +1,351 @@
+/* zgebrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int zgebrd_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublereal *d__, doublereal *e, doublecomplex *tauq,
+ doublecomplex *taup, doublecomplex *work, integer *lwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j, nb, nx;
+ doublereal ws;
+ integer nbmin, iinfo, minmn;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zgebd2_(integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *),
+ xerbla_(char *, integer *), zlabrd_(integer *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwrkx, ldwrky, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGEBRD reduces a general complex M-by-N matrix A to upper or lower */
+/* bidiagonal form B by a unitary transformation: Q**H * A * P = B. */
+
+/* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows in the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns in the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N general matrix to be reduced. */
+/* On exit, */
+/* if m >= n, the diagonal and the first superdiagonal are */
+/* overwritten with the upper bidiagonal matrix B; the */
+/* elements below the diagonal, with the array TAUQ, represent */
+/* the unitary matrix Q as a product of elementary */
+/* reflectors, and the elements above the first superdiagonal, */
+/* with the array TAUP, represent the unitary matrix P as */
+/* a product of elementary reflectors; */
+/* if m < n, the diagonal and the first subdiagonal are */
+/* overwritten with the lower bidiagonal matrix B; the */
+/* elements below the first subdiagonal, with the array TAUQ, */
+/* represent the unitary matrix Q as a product of */
+/* elementary reflectors, and the elements above the diagonal, */
+/* with the array TAUP, represent the unitary matrix P as */
+/* a product of elementary reflectors. */
+/* See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* D (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The diagonal elements of the bidiagonal matrix B: */
+/* D(i) = A(i,i). */
+
+/* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) */
+/* The off-diagonal elements of the bidiagonal matrix B: */
+/* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */
+/* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */
+
+/* TAUQ (output) COMPLEX*16 array dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the unitary matrix Q. See Further Details. */
+
+/* TAUP (output) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the unitary matrix P. See Further Details. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(1,M,N). */
+/* For optimum performance LWORK >= (M+N)*NB, where NB */
+/* is the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrices Q and P are represented as products of elementary */
+/* reflectors: */
+
+/* If m >= n, */
+
+/* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) */
+
+/* Each H(i) and G(i) has the form: */
+
+/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
+
+/* where tauq and taup are complex scalars, and v and u are complex */
+/* vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in */
+/* A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in */
+/* A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* If m < n, */
+
+/* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) */
+
+/* Each H(i) and G(i) has the form: */
+
+/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
+
+/* where tauq and taup are complex scalars, and v and u are complex */
+/* vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in */
+/* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in */
+/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* The contents of A on exit are illustrated by the following examples: */
+
+/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
+
+/* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) */
+/* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) */
+/* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) */
+/* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) */
+/* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) */
+/* ( v1 v2 v3 v4 v5 ) */
+
+/* where d and e denote diagonal and off-diagonal elements of B, vi */
+/* denotes an element of the vector defining H(i), and ui an element of */
+/* the vector defining G(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ --tauq;
+ --taup;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+/* Computing MAX */
+ i__1 = 1, i__2 = ilaenv_(&c__1, "ZGEBRD", " ", m, n, &c_n1, &c_n1);
+ nb = max(i__1,i__2);
+ lwkopt = (*m + *n) * nb;
+ d__1 = (doublereal) lwkopt;
+ work[1].r = d__1, work[1].i = 0.;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ if (*lwork < max(i__1,*n) && ! lquery) {
+ *info = -10;
+ }
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("ZGEBRD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ minmn = min(*m,*n);
+ if (minmn == 0) {
+ work[1].r = 1., work[1].i = 0.;
+ return 0;
+ }
+
+ ws = (doublereal) max(*m,*n);
+ ldwrkx = *m;
+ ldwrky = *n;
+
+ if (nb > 1 && nb < minmn) {
+
+/* Set the crossover point NX. */
+
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__3, "ZGEBRD", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+
+/* Determine when to switch from blocked to unblocked code. */
+
+ if (nx < minmn) {
+ ws = (doublereal) ((*m + *n) * nb);
+ if ((doublereal) (*lwork) < ws) {
+
+/* Not enough work space for the optimal NB, consider using */
+/* a smaller block size. */
+
+ nbmin = ilaenv_(&c__2, "ZGEBRD", " ", m, n, &c_n1, &c_n1);
+ if (*lwork >= (*m + *n) * nbmin) {
+ nb = *lwork / (*m + *n);
+ } else {
+ nb = 1;
+ nx = minmn;
+ }
+ }
+ }
+ } else {
+ nx = minmn;
+ }
+
+ i__1 = minmn - nx;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+
+/* Reduce rows and columns i:i+ib-1 to bidiagonal form and return */
+/* the matrices X and Y which are needed to update the unreduced */
+/* part of the matrix */
+
+ i__3 = *m - i__ + 1;
+ i__4 = *n - i__ + 1;
+ zlabrd_(&i__3, &i__4, &nb, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[
+ i__], &tauq[i__], &taup[i__], &work[1], &ldwrkx, &work[ldwrkx
+ * nb + 1], &ldwrky);
+
+/* Update the trailing submatrix A(i+ib:m,i+ib:n), using */
+/* an update of the form A := A - V*Y' - X*U' */
+
+ i__3 = *m - i__ - nb + 1;
+ i__4 = *n - i__ - nb + 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "Conjugate transpose", &i__3, &i__4, &nb, &
+ z__1, &a[i__ + nb + i__ * a_dim1], lda, &work[ldwrkx * nb +
+ nb + 1], &ldwrky, &c_b1, &a[i__ + nb + (i__ + nb) * a_dim1],
+ lda);
+ i__3 = *m - i__ - nb + 1;
+ i__4 = *n - i__ - nb + 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "No transpose", &i__3, &i__4, &nb, &z__1, &
+ work[nb + 1], &ldwrkx, &a[i__ + (i__ + nb) * a_dim1], lda, &
+ c_b1, &a[i__ + nb + (i__ + nb) * a_dim1], lda);
+
+/* Copy diagonal and off-diagonal elements of B back into A */
+
+ if (*m >= *n) {
+ i__3 = i__ + nb - 1;
+ for (j = i__; j <= i__3; ++j) {
+ i__4 = j + j * a_dim1;
+ i__5 = j;
+ a[i__4].r = d__[i__5], a[i__4].i = 0.;
+ i__4 = j + (j + 1) * a_dim1;
+ i__5 = j;
+ a[i__4].r = e[i__5], a[i__4].i = 0.;
+/* L10: */
+ }
+ } else {
+ i__3 = i__ + nb - 1;
+ for (j = i__; j <= i__3; ++j) {
+ i__4 = j + j * a_dim1;
+ i__5 = j;
+ a[i__4].r = d__[i__5], a[i__4].i = 0.;
+ i__4 = j + 1 + j * a_dim1;
+ i__5 = j;
+ a[i__4].r = e[i__5], a[i__4].i = 0.;
+/* L20: */
+ }
+ }
+/* L30: */
+ }
+
+/* Use unblocked code to reduce the remainder of the matrix */
+
+ i__2 = *m - i__ + 1;
+ i__1 = *n - i__ + 1;
+ zgebd2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], &
+ tauq[i__], &taup[i__], &work[1], &iinfo);
+ work[1].r = ws, work[1].i = 0.;
+ return 0;
+
+/* End of ZGEBRD */
+
+} /* zgebrd_ */
diff --git a/SRC/zgecon.c b/SRC/zgecon.c
new file mode 100644
index 0000000..894ab73
--- /dev/null
+++ b/SRC/zgecon.c
@@ -0,0 +1,235 @@
+/* zgecon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zgecon_(char *norm, integer *n, doublecomplex *a,
+ integer *lda, doublereal *anorm, doublereal *rcond, doublecomplex *
+ work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ doublereal sl;
+ integer ix;
+ doublereal su;
+ integer kase, kase1;
+ doublereal scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal ainvnm;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ logical onenrm;
+ extern /* Subroutine */ int zdrscl_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ char normin[1];
+ doublereal smlnum;
+ extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *, doublereal *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGECON estimates the reciprocal of the condition number of a general */
+/* complex matrix A, in either the 1-norm or the infinity-norm, using */
+/* the LU factorization computed by ZGETRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as */
+/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The factors L and U from the factorization A = P*L*U */
+/* as computed by ZGETRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* ANORM (input) DOUBLE PRECISION */
+/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */
+/* If NORM = 'I', the infinity-norm of the original matrix A. */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*anorm < 0.) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGECON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.;
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ } else if (*anorm == 0.) {
+ return 0;
+ }
+
+ smlnum = dlamch_("Safe minimum");
+
+/* Estimate the norm of inv(A). */
+
+ ainvnm = 0.;
+ *(unsigned char *)normin = 'N';
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kase = 0;
+L10:
+ zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(L). */
+
+ zlatrs_("Lower", "No transpose", "Unit", normin, n, &a[a_offset],
+ lda, &work[1], &sl, &rwork[1], info);
+
+/* Multiply by inv(U). */
+
+ zlatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[
+ a_offset], lda, &work[1], &su, &rwork[*n + 1], info);
+ } else {
+
+/* Multiply by inv(U'). */
+
+ zlatrs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &a[
+ a_offset], lda, &work[1], &su, &rwork[*n + 1], info);
+
+/* Multiply by inv(L'). */
+
+ zlatrs_("Lower", "Conjugate transpose", "Unit", normin, n, &a[
+ a_offset], lda, &work[1], &sl, &rwork[1], info);
+ }
+
+/* Divide X by 1/(SL*SU) if doing so will not cause overflow. */
+
+ scale = sl * su;
+ *(unsigned char *)normin = 'Y';
+ if (scale != 1.) {
+ ix = izamax_(n, &work[1], &c__1);
+ i__1 = ix;
+ if (scale < ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(&
+ work[ix]), abs(d__2))) * smlnum || scale == 0.) {
+ goto L20;
+ }
+ zdrscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / ainvnm / *anorm;
+ }
+
+L20:
+ return 0;
+
+/* End of ZGECON */
+
+} /* zgecon_ */
diff --git a/SRC/zgeequ.c b/SRC/zgeequ.c
new file mode 100644
index 0000000..cb53db4
--- /dev/null
+++ b/SRC/zgeequ.c
@@ -0,0 +1,306 @@
+/* zgeequ.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zgeequ_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublereal *r__, doublereal *c__, doublereal *rowcnd,
+ doublereal *colcnd, doublereal *amax, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal rcmin, rcmax;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum, smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGEEQU computes row and column scalings intended to equilibrate an */
+/* M-by-N matrix A and reduce its condition number. R returns the row */
+/* scale factors and C the column scale factors, chosen to try to make */
+/* the largest element in each row and column of the matrix B with */
+/* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. */
+
+/* R(i) and C(j) are restricted to be between SMLNUM = smallest safe */
+/* number and BIGNUM = largest safe number. Use of these scaling */
+/* factors is not guaranteed to reduce the condition number of A but */
+/* works well in practice. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The M-by-N matrix whose equilibration factors are */
+/* to be computed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* R (output) DOUBLE PRECISION array, dimension (M) */
+/* If INFO = 0 or INFO > M, R contains the row scale factors */
+/* for A. */
+
+/* C (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, C contains the column scale factors for A. */
+
+/* ROWCND (output) DOUBLE PRECISION */
+/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */
+/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */
+/* AMAX is neither too large nor too small, it is not worth */
+/* scaling by R. */
+
+/* COLCND (output) DOUBLE PRECISION */
+/* If INFO = 0, COLCND contains the ratio of the smallest */
+/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */
+/* worth scaling by C. */
+
+/* AMAX (output) DOUBLE PRECISION */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= M: the i-th row of A is exactly zero */
+/* > M: the (i-M)-th column of A is exactly zero */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGEEQU", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ *rowcnd = 1.;
+ *colcnd = 1.;
+ *amax = 0.;
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+
+/* Compute row scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__[i__] = 0.;
+/* L10: */
+ }
+
+/* Find the maximum element in each row. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = r__[i__], d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2));
+ r__[i__] = max(d__3,d__4);
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = rcmax, d__2 = r__[i__];
+ rcmax = max(d__1,d__2);
+/* Computing MIN */
+ d__1 = rcmin, d__2 = r__[i__];
+ rcmin = min(d__1,d__2);
+/* L40: */
+ }
+ *amax = rcmax;
+
+ if (rcmin == 0.) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] == 0.) {
+ *info = i__;
+ return 0;
+ }
+/* L50: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MIN */
+/* Computing MAX */
+ d__2 = r__[i__];
+ d__1 = max(d__2,smlnum);
+ r__[i__] = 1. / min(d__1,bignum);
+/* L60: */
+ }
+
+/* Compute ROWCND = min(R(I)) / max(R(I)) */
+
+ *rowcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ }
+
+/* Compute column scale factors */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 0.;
+/* L70: */
+ }
+
+/* Find the maximum element in each column, */
+/* assuming the row scaling computed above. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = c__[j], d__4 = ((d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2))) * r__[i__];
+ c__[j] = max(d__3,d__4);
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = c__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = c__[j];
+ rcmax = max(d__1,d__2);
+/* L100: */
+ }
+
+ if (rcmin == 0.) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (c__[j] == 0.) {
+ *info = *m + j;
+ return 0;
+ }
+/* L110: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+/* Computing MAX */
+ d__2 = c__[j];
+ d__1 = max(d__2,smlnum);
+ c__[j] = 1. / min(d__1,bignum);
+/* L120: */
+ }
+
+/* Compute COLCND = min(C(J)) / max(C(J)) */
+
+ *colcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ }
+
+ return 0;
+
+/* End of ZGEEQU */
+
+} /* zgeequ_ */
diff --git a/SRC/zgeequb.c b/SRC/zgeequb.c
new file mode 100644
index 0000000..f284cc3
--- /dev/null
+++ b/SRC/zgeequb.c
@@ -0,0 +1,332 @@
+/* zgeequb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zgeequb_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublereal *r__, doublereal *c__, doublereal *rowcnd,
+ doublereal *colcnd, doublereal *amax, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double log(doublereal), d_imag(doublecomplex *), pow_di(doublereal *,
+ integer *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal radix, rcmin, rcmax;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum, logrdx, smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGEEQUB computes row and column scalings intended to equilibrate an */
+/* M-by-N matrix A and reduce its condition number. R returns the row */
+/* scale factors and C the column scale factors, chosen to try to make */
+/* the largest element in each row and column of the matrix B with */
+/* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most */
+/* the radix. */
+
+/* R(i) and C(j) are restricted to be a power of the radix between */
+/* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use */
+/* of these scaling factors is not guaranteed to reduce the condition */
+/* number of A but works well in practice. */
+
+/* This routine differs from ZGEEQU by restricting the scaling factors */
+/* to a power of the radix. Baring over- and underflow, scaling by */
+/* these factors introduces no additional rounding errors. However, the */
+/* scaled entries' magnitured are no longer approximately 1 but lie */
+/* between sqrt(radix) and 1/sqrt(radix). */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The M-by-N matrix whose equilibration factors are */
+/* to be computed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* R (output) DOUBLE PRECISION array, dimension (M) */
+/* If INFO = 0 or INFO > M, R contains the row scale factors */
+/* for A. */
+
+/* C (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, C contains the column scale factors for A. */
+
+/* ROWCND (output) DOUBLE PRECISION */
+/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */
+/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */
+/* AMAX is neither too large nor too small, it is not worth */
+/* scaling by R. */
+
+/* COLCND (output) DOUBLE PRECISION */
+/* If INFO = 0, COLCND contains the ratio of the smallest */
+/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */
+/* worth scaling by C. */
+
+/* AMAX (output) DOUBLE PRECISION */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= M: the i-th row of A is exactly zero */
+/* > M: the (i-M)-th column of A is exactly zero */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGEEQUB", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ *rowcnd = 1.;
+ *colcnd = 1.;
+ *amax = 0.;
+ return 0;
+ }
+
+/* Get machine constants. Assume SMLNUM is a power of the radix. */
+
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+ radix = dlamch_("B");
+ logrdx = log(radix);
+
+/* Compute row scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__[i__] = 0.;
+/* L10: */
+ }
+
+/* Find the maximum element in each row. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = r__[i__], d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2));
+ r__[i__] = max(d__3,d__4);
+/* L20: */
+ }
+/* L30: */
+ }
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] > 0.) {
+ i__2 = (integer) (log(r__[i__]) / logrdx);
+ r__[i__] = pow_di(&radix, &i__2);
+ }
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = rcmax, d__2 = r__[i__];
+ rcmax = max(d__1,d__2);
+/* Computing MIN */
+ d__1 = rcmin, d__2 = r__[i__];
+ rcmin = min(d__1,d__2);
+/* L40: */
+ }
+ *amax = rcmax;
+
+ if (rcmin == 0.) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (r__[i__] == 0.) {
+ *info = i__;
+ return 0;
+ }
+/* L50: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MIN */
+/* Computing MAX */
+ d__2 = r__[i__];
+ d__1 = max(d__2,smlnum);
+ r__[i__] = 1. / min(d__1,bignum);
+/* L60: */
+ }
+
+/* Compute ROWCND = min(R(I)) / max(R(I)). */
+
+ *rowcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ }
+
+/* Compute column scale factors. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 0.;
+/* L70: */
+ }
+
+/* Find the maximum element in each column, */
+/* assuming the row scaling computed above. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = c__[j], d__4 = ((d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2))) * r__[i__];
+ c__[j] = max(d__3,d__4);
+/* L80: */
+ }
+ if (c__[j] > 0.) {
+ i__2 = (integer) (log(c__[j]) / logrdx);
+ c__[j] = pow_di(&radix, &i__2);
+ }
+/* L90: */
+ }
+
+/* Find the maximum and minimum scale factors. */
+
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = c__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = c__[j];
+ rcmax = max(d__1,d__2);
+/* L100: */
+ }
+
+ if (rcmin == 0.) {
+
+/* Find the first zero scale factor and return an error code. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (c__[j] == 0.) {
+ *info = *m + j;
+ return 0;
+ }
+/* L110: */
+ }
+ } else {
+
+/* Invert the scale factors. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+/* Computing MAX */
+ d__2 = c__[j];
+ d__1 = max(d__2,smlnum);
+ c__[j] = 1. / min(d__1,bignum);
+/* L120: */
+ }
+
+/* Compute COLCND = min(C(J)) / max(C(J)). */
+
+ *colcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ }
+
+ return 0;
+
+/* End of ZGEEQUB */
+
+} /* zgeequb_ */
diff --git a/SRC/zgees.c b/SRC/zgees.c
new file mode 100644
index 0000000..ab32998
--- /dev/null
+++ b/SRC/zgees.c
@@ -0,0 +1,409 @@
+/* zgees.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zgees_(char *jobvs, char *sort, L_fp select, integer *n,
+ doublecomplex *a, integer *lda, integer *sdim, doublecomplex *w,
+ doublecomplex *vs, integer *ldvs, doublecomplex *work, integer *lwork,
+ doublereal *rwork, logical *bwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal s;
+ integer ihi, ilo;
+ doublereal dum[1], eps, sep;
+ integer ibal;
+ doublereal anrm;
+ integer ierr, itau, iwrk, icond, ieval;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
+ logical scalea;
+ extern doublereal dlamch_(char *);
+ doublereal cscale;
+ extern /* Subroutine */ int zgebak_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublecomplex *, integer *,
+ integer *), zgebal_(char *, integer *,
+ doublecomplex *, integer *, integer *, integer *, doublereal *,
+ integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ doublereal bignum;
+ extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *), zlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublecomplex *,
+ integer *, integer *), zlacpy_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *);
+ integer minwrk, maxwrk;
+ doublereal smlnum;
+ extern /* Subroutine */ int zhseqr_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+ integer hswork;
+ extern /* Subroutine */ int zunghr_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+ logical wantst, lquery, wantvs;
+ extern /* Subroutine */ int ztrsen_(char *, char *, logical *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+/* .. Function Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGEES computes for an N-by-N complex nonsymmetric matrix A, the */
+/* eigenvalues, the Schur form T, and, optionally, the matrix of Schur */
+/* vectors Z. This gives the Schur factorization A = Z*T*(Z**H). */
+
+/* Optionally, it also orders the eigenvalues on the diagonal of the */
+/* Schur form so that selected eigenvalues are at the top left. */
+/* The leading columns of Z then form an orthonormal basis for the */
+/* invariant subspace corresponding to the selected eigenvalues. */
+
+/* A complex matrix is in Schur form if it is upper triangular. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVS (input) CHARACTER*1 */
+/* = 'N': Schur vectors are not computed; */
+/* = 'V': Schur vectors are computed. */
+
+/* SORT (input) CHARACTER*1 */
+/* Specifies whether or not to order the eigenvalues on the */
+/* diagonal of the Schur form. */
+/* = 'N': Eigenvalues are not ordered: */
+/* = 'S': Eigenvalues are ordered (see SELECT). */
+
+/* SELECT (external procedure) LOGICAL FUNCTION of one COMPLEX*16 argument */
+/* SELECT must be declared EXTERNAL in the calling subroutine. */
+/* If SORT = 'S', SELECT is used to select eigenvalues to order */
+/* to the top left of the Schur form. */
+/* IF SORT = 'N', SELECT is not referenced. */
+/* The eigenvalue W(j) is selected if SELECT(W(j)) is true. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+/* On exit, A has been overwritten by its Schur form T. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* SDIM (output) INTEGER */
+/* If SORT = 'N', SDIM = 0. */
+/* If SORT = 'S', SDIM = number of eigenvalues for which */
+/* SELECT is true. */
+
+/* W (output) COMPLEX*16 array, dimension (N) */
+/* W contains the computed eigenvalues, in the same order that */
+/* they appear on the diagonal of the output Schur form T. */
+
+/* VS (output) COMPLEX*16 array, dimension (LDVS,N) */
+/* If JOBVS = 'V', VS contains the unitary matrix Z of Schur */
+/* vectors. */
+/* If JOBVS = 'N', VS is not referenced. */
+
+/* LDVS (input) INTEGER */
+/* The leading dimension of the array VS. LDVS >= 1; if */
+/* JOBVS = 'V', LDVS >= N. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,2*N). */
+/* For good performance, LWORK must generally be larger. */
+
+/* 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. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+/* Not referenced if SORT = 'N'. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, and i is */
+/* <= N: the QR algorithm failed to compute all the */
+/* eigenvalues; elements 1:ILO-1 and i+1:N of W */
+/* contain those eigenvalues which have converged; */
+/* if JOBVS = 'V', VS contains the matrix which */
+/* reduces A to its partially converged Schur form. */
+/* = N+1: the eigenvalues could not be reordered because */
+/* some eigenvalues were too close to separate (the */
+/* problem is very ill-conditioned); */
+/* = N+2: after reordering, roundoff changed values of */
+/* some complex eigenvalues so that leading */
+/* eigenvalues in the Schur form no longer satisfy */
+/* SELECT = .TRUE.. This could also be caused by */
+/* underflow due to scaling. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ vs_dim1 = *ldvs;
+ vs_offset = 1 + vs_dim1;
+ vs -= vs_offset;
+ --work;
+ --rwork;
+ --bwork;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ wantvs = lsame_(jobvs, "V");
+ wantst = lsame_(sort, "S");
+ if (! wantvs && ! lsame_(jobvs, "N")) {
+ *info = -1;
+ } else if (! wantst && ! lsame_(sort, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldvs < 1 || wantvs && *ldvs < *n) {
+ *info = -10;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* CWorkspace refers to complex workspace, and RWorkspace to real */
+/* workspace. NB refers to the optimal block size for the */
+/* immediately following subroutine, as returned by ILAENV. */
+/* HSWORK refers to the workspace preferred by ZHSEQR, as */
+/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
+/* the worst case.) */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ } else {
+ maxwrk = *n + *n * ilaenv_(&c__1, "ZGEHRD", " ", n, &c__1, n, &
+ c__0);
+ minwrk = *n << 1;
+
+ zhseqr_("S", jobvs, n, &c__1, n, &a[a_offset], lda, &w[1], &vs[
+ vs_offset], ldvs, &work[1], &c_n1, &ieval);
+ hswork = (integer) work[1].r;
+
+ if (! wantvs) {
+ maxwrk = max(maxwrk,hswork);
+ } else {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "ZUNGHR",
+ " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ maxwrk = max(maxwrk,hswork);
+ }
+ }
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGEES ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *sdim = 0;
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1. / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = zlange_("M", n, n, &a[a_offset], lda, dum);
+ scalea = FALSE_;
+ if (anrm > 0. && anrm < smlnum) {
+ scalea = TRUE_;
+ cscale = smlnum;
+ } else if (anrm > bignum) {
+ scalea = TRUE_;
+ cscale = bignum;
+ }
+ if (scalea) {
+ zlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Permute the matrix to make it more nearly triangular */
+/* (CWorkspace: none) */
+/* (RWorkspace: need N) */
+
+ ibal = 1;
+ zgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &rwork[ibal], &ierr);
+
+/* Reduce to upper Hessenberg form */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: none) */
+
+ itau = 1;
+ iwrk = *n + itau;
+ i__1 = *lwork - iwrk + 1;
+ zgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
+ &ierr);
+
+ if (wantvs) {
+
+/* Copy Householder vectors to VS */
+
+ zlacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs)
+ ;
+
+/* Generate unitary matrix in VS */
+/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwrk + 1;
+ zunghr_(n, &ilo, &ihi, &vs[vs_offset], ldvs, &work[itau], &work[iwrk],
+ &i__1, &ierr);
+ }
+
+ *sdim = 0;
+
+/* Perform QR iteration, accumulating Schur vectors in VS if desired */
+/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
+/* (RWorkspace: none) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ zhseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vs[
+ vs_offset], ldvs, &work[iwrk], &i__1, &ieval);
+ if (ieval > 0) {
+ *info = ieval;
+ }
+
+/* Sort eigenvalues if desired */
+
+ if (wantst && *info == 0) {
+ if (scalea) {
+ zlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &w[1], n, &
+ ierr);
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ bwork[i__] = (*select)(&w[i__]);
+/* L10: */
+ }
+
+/* Reorder eigenvalues and transform Schur vectors */
+/* (CWorkspace: none) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwrk + 1;
+ ztrsen_("N", jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset],
+ ldvs, &w[1], sdim, &s, &sep, &work[iwrk], &i__1, &icond);
+ }
+
+ if (wantvs) {
+
+/* Undo balancing */
+/* (CWorkspace: none) */
+/* (RWorkspace: need N) */
+
+ zgebak_("P", "R", n, &ilo, &ihi, &rwork[ibal], n, &vs[vs_offset],
+ ldvs, &ierr);
+ }
+
+ if (scalea) {
+
+/* Undo scaling for the Schur form of A */
+
+ zlascl_("U", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, &
+ ierr);
+ i__1 = *lda + 1;
+ zcopy_(n, &a[a_offset], &i__1, &w[1], &c__1);
+ }
+
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+ return 0;
+
+/* End of ZGEES */
+
+} /* zgees_ */
diff --git a/SRC/zgeesx.c b/SRC/zgeesx.c
new file mode 100644
index 0000000..c04109e
--- /dev/null
+++ b/SRC/zgeesx.c
@@ -0,0 +1,477 @@
+/* zgeesx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zgeesx_(char *jobvs, char *sort, L_fp select, char *
+ sense, integer *n, doublecomplex *a, integer *lda, integer *sdim,
+ doublecomplex *w, doublecomplex *vs, integer *ldvs, doublereal *
+ rconde, doublereal *rcondv, doublecomplex *work, integer *lwork,
+ doublereal *rwork, logical *bwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, ihi, ilo;
+ doublereal dum[1], eps;
+ integer ibal;
+ doublereal anrm;
+ integer ierr, itau, iwrk, lwrk, icond, ieval;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
+ logical scalea;
+ extern doublereal dlamch_(char *);
+ doublereal cscale;
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), zgebak_(char *, char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublecomplex *,
+ integer *, integer *), zgebal_(char *, integer *,
+ doublecomplex *, integer *, integer *, integer *, doublereal *,
+ integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ doublereal bignum;
+ extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *), zlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublecomplex *,
+ integer *, integer *);
+ logical wantsb, wantse;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ integer minwrk, maxwrk;
+ logical wantsn;
+ doublereal smlnum;
+ extern /* Subroutine */ int zhseqr_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+ integer hswork;
+ extern /* Subroutine */ int zunghr_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+ logical wantst, wantsv, wantvs;
+ extern /* Subroutine */ int ztrsen_(char *, char *, logical *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+/* .. Function Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGEESX computes for an N-by-N complex nonsymmetric matrix A, the */
+/* eigenvalues, the Schur form T, and, optionally, the matrix of Schur */
+/* vectors Z. This gives the Schur factorization A = Z*T*(Z**H). */
+
+/* Optionally, it also orders the eigenvalues on the diagonal of the */
+/* Schur form so that selected eigenvalues are at the top left; */
+/* computes a reciprocal condition number for the average of the */
+/* selected eigenvalues (RCONDE); and computes a reciprocal condition */
+/* number for the right invariant subspace corresponding to the */
+/* selected eigenvalues (RCONDV). The leading columns of Z form an */
+/* orthonormal basis for this invariant subspace. */
+
+/* For further explanation of the reciprocal condition numbers RCONDE */
+/* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where */
+/* these quantities are called s and sep respectively). */
+
+/* A complex matrix is in Schur form if it is upper triangular. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVS (input) CHARACTER*1 */
+/* = 'N': Schur vectors are not computed; */
+/* = 'V': Schur vectors are computed. */
+
+/* SORT (input) CHARACTER*1 */
+/* Specifies whether or not to order the eigenvalues on the */
+/* diagonal of the Schur form. */
+/* = 'N': Eigenvalues are not ordered; */
+/* = 'S': Eigenvalues are ordered (see SELECT). */
+
+/* SELECT (external procedure) LOGICAL FUNCTION of one COMPLEX*16 argument */
+/* SELECT must be declared EXTERNAL in the calling subroutine. */
+/* If SORT = 'S', SELECT is used to select eigenvalues to order */
+/* to the top left of the Schur form. */
+/* If SORT = 'N', SELECT is not referenced. */
+/* An eigenvalue W(j) is selected if SELECT(W(j)) is true. */
+
+/* SENSE (input) CHARACTER*1 */
+/* Determines which reciprocal condition numbers are computed. */
+/* = 'N': None are computed; */
+/* = 'E': Computed for average of selected eigenvalues only; */
+/* = 'V': Computed for selected right invariant subspace only; */
+/* = 'B': Computed for both. */
+/* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA, N) */
+/* On entry, the N-by-N matrix A. */
+/* On exit, A is overwritten by its Schur form T. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* SDIM (output) INTEGER */
+/* If SORT = 'N', SDIM = 0. */
+/* If SORT = 'S', SDIM = number of eigenvalues for which */
+/* SELECT is true. */
+
+/* W (output) COMPLEX*16 array, dimension (N) */
+/* W contains the computed eigenvalues, in the same order */
+/* that they appear on the diagonal of the output Schur form T. */
+
+/* VS (output) COMPLEX*16 array, dimension (LDVS,N) */
+/* If JOBVS = 'V', VS contains the unitary matrix Z of Schur */
+/* vectors. */
+/* If JOBVS = 'N', VS is not referenced. */
+
+/* LDVS (input) INTEGER */
+/* The leading dimension of the array VS. LDVS >= 1, and if */
+/* JOBVS = 'V', LDVS >= N. */
+
+/* RCONDE (output) DOUBLE PRECISION */
+/* If SENSE = 'E' or 'B', RCONDE contains the reciprocal */
+/* condition number for the average of the selected eigenvalues. */
+/* Not referenced if SENSE = 'N' or 'V'. */
+
+/* RCONDV (output) DOUBLE PRECISION */
+/* If SENSE = 'V' or 'B', RCONDV contains the reciprocal */
+/* condition number for the selected right invariant subspace. */
+/* Not referenced if SENSE = 'N' or 'E'. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,2*N). */
+/* Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM), */
+/* where SDIM is the number of selected eigenvalues computed by */
+/* this routine. Note that 2*SDIM*(N-SDIM) <= N*N/2. Note also */
+/* that an error is only returned if LWORK < max(1,2*N), but if */
+/* SENSE = 'E' or 'V' or 'B' this may not be large enough. */
+/* For good performance, LWORK must generally be larger. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates upper bound on the optimal size of the */
+/* array WORK, returns this value as the first entry of the WORK */
+/* array, and no error message related to LWORK is issued by */
+/* XERBLA. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+/* Not referenced if SORT = 'N'. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, and i is */
+/* <= N: the QR algorithm failed to compute all the */
+/* eigenvalues; elements 1:ILO-1 and i+1:N of W */
+/* contain those eigenvalues which have converged; if */
+/* JOBVS = 'V', VS contains the transformation which */
+/* reduces A to its partially converged Schur form. */
+/* = N+1: the eigenvalues could not be reordered because some */
+/* eigenvalues were too close to separate (the problem */
+/* is very ill-conditioned); */
+/* = N+2: after reordering, roundoff changed values of some */
+/* complex eigenvalues so that leading eigenvalues in */
+/* the Schur form no longer satisfy SELECT=.TRUE. This */
+/* could also be caused by underflow due to scaling. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ vs_dim1 = *ldvs;
+ vs_offset = 1 + vs_dim1;
+ vs -= vs_offset;
+ --work;
+ --rwork;
+ --bwork;
+
+ /* Function Body */
+ *info = 0;
+ wantvs = lsame_(jobvs, "V");
+ wantst = lsame_(sort, "S");
+ wantsn = lsame_(sense, "N");
+ wantse = lsame_(sense, "E");
+ wantsv = lsame_(sense, "V");
+ wantsb = lsame_(sense, "B");
+ if (! wantvs && ! lsame_(jobvs, "N")) {
+ *info = -1;
+ } else if (! wantst && ! lsame_(sort, "N")) {
+ *info = -2;
+ } else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && !
+ wantsn) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvs < 1 || wantvs && *ldvs < *n) {
+ *info = -11;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of real workspace needed at that point in the */
+/* code, as well as the preferred amount for good performance. */
+/* CWorkspace refers to complex workspace, and RWorkspace to real */
+/* workspace. NB refers to the optimal block size for the */
+/* immediately following subroutine, as returned by ILAENV. */
+/* HSWORK refers to the workspace preferred by ZHSEQR, as */
+/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
+/* the worst case. */
+/* If SENSE = 'E', 'V' or 'B', then the amount of workspace needed */
+/* depends on SDIM, which is computed by the routine ZTRSEN later */
+/* in the code.) */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ minwrk = 1;
+ lwrk = 1;
+ } else {
+ maxwrk = *n + *n * ilaenv_(&c__1, "ZGEHRD", " ", n, &c__1, n, &
+ c__0);
+ minwrk = *n << 1;
+
+ zhseqr_("S", jobvs, n, &c__1, n, &a[a_offset], lda, &w[1], &vs[
+ vs_offset], ldvs, &work[1], &c_n1, &ieval);
+ hswork = (integer) work[1].r;
+
+ if (! wantvs) {
+ maxwrk = max(maxwrk,hswork);
+ } else {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "ZUNGHR",
+ " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ maxwrk = max(maxwrk,hswork);
+ }
+ lwrk = maxwrk;
+ if (! wantsn) {
+/* Computing MAX */
+ i__1 = lwrk, i__2 = *n * *n / 2;
+ lwrk = max(i__1,i__2);
+ }
+ }
+ work[1].r = (doublereal) lwrk, work[1].i = 0.;
+
+ if (*lwork < minwrk) {
+ *info = -15;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGEESX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *sdim = 0;
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1. / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = zlange_("M", n, n, &a[a_offset], lda, dum);
+ scalea = FALSE_;
+ if (anrm > 0. && anrm < smlnum) {
+ scalea = TRUE_;
+ cscale = smlnum;
+ } else if (anrm > bignum) {
+ scalea = TRUE_;
+ cscale = bignum;
+ }
+ if (scalea) {
+ zlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+
+/* Permute the matrix to make it more nearly triangular */
+/* (CWorkspace: none) */
+/* (RWorkspace: need N) */
+
+ ibal = 1;
+ zgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &rwork[ibal], &ierr);
+
+/* Reduce to upper Hessenberg form */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: none) */
+
+ itau = 1;
+ iwrk = *n + itau;
+ i__1 = *lwork - iwrk + 1;
+ zgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
+ &ierr);
+
+ if (wantvs) {
+
+/* Copy Householder vectors to VS */
+
+ zlacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs)
+ ;
+
+/* Generate unitary matrix in VS */
+/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwrk + 1;
+ zunghr_(n, &ilo, &ihi, &vs[vs_offset], ldvs, &work[itau], &work[iwrk],
+ &i__1, &ierr);
+ }
+
+ *sdim = 0;
+
+/* Perform QR iteration, accumulating Schur vectors in VS if desired */
+/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
+/* (RWorkspace: none) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ zhseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vs[
+ vs_offset], ldvs, &work[iwrk], &i__1, &ieval);
+ if (ieval > 0) {
+ *info = ieval;
+ }
+
+/* Sort eigenvalues if desired */
+
+ if (wantst && *info == 0) {
+ if (scalea) {
+ zlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &w[1], n, &
+ ierr);
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ bwork[i__] = (*select)(&w[i__]);
+/* L10: */
+ }
+
+/* Reorder eigenvalues, transform Schur vectors, and compute */
+/* reciprocal condition numbers */
+/* (CWorkspace: if SENSE is not 'N', need 2*SDIM*(N-SDIM) */
+/* otherwise, need none ) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwrk + 1;
+ ztrsen_(sense, jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset],
+ ldvs, &w[1], sdim, rconde, rcondv, &work[iwrk], &i__1, &
+ icond);
+ if (! wantsn) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*sdim << 1) * (*n - *sdim);
+ maxwrk = max(i__1,i__2);
+ }
+ if (icond == -14) {
+
+/* Not enough complex workspace */
+
+ *info = -15;
+ }
+ }
+
+ if (wantvs) {
+
+/* Undo balancing */
+/* (CWorkspace: none) */
+/* (RWorkspace: need N) */
+
+ zgebak_("P", "R", n, &ilo, &ihi, &rwork[ibal], n, &vs[vs_offset],
+ ldvs, &ierr);
+ }
+
+ if (scalea) {
+
+/* Undo scaling for the Schur form of A */
+
+ zlascl_("U", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, &
+ ierr);
+ i__1 = *lda + 1;
+ zcopy_(n, &a[a_offset], &i__1, &w[1], &c__1);
+ if ((wantsv || wantsb) && *info == 0) {
+ dum[0] = *rcondv;
+ dlascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &
+ c__1, &ierr);
+ *rcondv = dum[0];
+ }
+ }
+
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+ return 0;
+
+/* End of ZGEESX */
+
+} /* zgeesx_ */
diff --git a/SRC/zgeev.c b/SRC/zgeev.c
new file mode 100644
index 0000000..e4690ac
--- /dev/null
+++ b/SRC/zgeev.c
@@ -0,0 +1,533 @@
+/* zgeev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zgeev_(char *jobvl, char *jobvr, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *w, doublecomplex *vl,
+ integer *ldvl, doublecomplex *vr, integer *ldvr, doublecomplex *work,
+ integer *lwork, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
+ i__2, i__3;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_imag(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, k, ihi;
+ doublereal scl;
+ integer ilo;
+ doublereal dum[1], eps;
+ doublecomplex tmp;
+ integer ibal;
+ char side[1];
+ doublereal anrm;
+ integer ierr, itau, iwrk, nout;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
+ extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
+ logical scalea;
+ extern doublereal dlamch_(char *);
+ doublereal cscale;
+ extern /* Subroutine */ int zgebak_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublecomplex *, integer *,
+ integer *), zgebal_(char *, integer *,
+ doublecomplex *, integer *, integer *, integer *, doublereal *,
+ integer *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical select[1];
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ doublereal bignum;
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *), zlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublecomplex *,
+ integer *, integer *), zlacpy_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *);
+ integer minwrk, maxwrk;
+ logical wantvl;
+ doublereal smlnum;
+ integer hswork, irwork;
+ extern /* Subroutine */ int zhseqr_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *), ztrevc_(char *, char *, logical *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *, doublecomplex *,
+ doublereal *, integer *);
+ logical lquery, wantvr;
+ extern /* Subroutine */ int zunghr_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGEEV computes for an N-by-N complex nonsymmetric matrix A, the */
+/* eigenvalues and, optionally, the left and/or right eigenvectors. */
+
+/* The right eigenvector v(j) of A satisfies */
+/* A * v(j) = lambda(j) * v(j) */
+/* where lambda(j) is its eigenvalue. */
+/* The left eigenvector u(j) of A satisfies */
+/* u(j)**H * A = lambda(j) * u(j)**H */
+/* where u(j)**H denotes the conjugate transpose of u(j). */
+
+/* The computed eigenvectors are normalized to have Euclidean norm */
+/* equal to 1 and largest component real. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVL (input) CHARACTER*1 */
+/* = 'N': left eigenvectors of A are not computed; */
+/* = 'V': left eigenvectors of are computed. */
+
+/* JOBVR (input) CHARACTER*1 */
+/* = 'N': right eigenvectors of A are not computed; */
+/* = 'V': right eigenvectors of A are computed. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+/* On exit, A has been overwritten. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* W (output) COMPLEX*16 array, dimension (N) */
+/* W contains the computed eigenvalues. */
+
+/* VL (output) COMPLEX*16 array, dimension (LDVL,N) */
+/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
+/* after another in the columns of VL, in the same order */
+/* as their eigenvalues. */
+/* If JOBVL = 'N', VL is not referenced. */
+/* u(j) = VL(:,j), the j-th column of VL. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. LDVL >= 1; if */
+/* JOBVL = 'V', LDVL >= N. */
+
+/* VR (output) COMPLEX*16 array, dimension (LDVR,N) */
+/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
+/* after another in the columns of VR, in the same order */
+/* as their eigenvalues. */
+/* If JOBVR = 'N', VR is not referenced. */
+/* v(j) = VR(:,j), the j-th column of VR. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. LDVR >= 1; if */
+/* JOBVR = 'V', LDVR >= N. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,2*N). */
+/* For good performance, LWORK must generally be larger. */
+
+/* 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. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the QR algorithm failed to compute all the */
+/* eigenvalues, and no eigenvectors have been computed; */
+/* elements and i+1:N of W contain eigenvalues which have */
+/* converged. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ wantvl = lsame_(jobvl, "V");
+ wantvr = lsame_(jobvr, "V");
+ if (! wantvl && ! lsame_(jobvl, "N")) {
+ *info = -1;
+ } else if (! wantvr && ! lsame_(jobvr, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldvl < 1 || wantvl && *ldvl < *n) {
+ *info = -8;
+ } else if (*ldvr < 1 || wantvr && *ldvr < *n) {
+ *info = -10;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* CWorkspace refers to complex workspace, and RWorkspace to real */
+/* workspace. NB refers to the optimal block size for the */
+/* immediately following subroutine, as returned by ILAENV. */
+/* HSWORK refers to the workspace preferred by ZHSEQR, as */
+/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
+/* the worst case.) */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ } else {
+ maxwrk = *n + *n * ilaenv_(&c__1, "ZGEHRD", " ", n, &c__1, n, &
+ c__0);
+ minwrk = *n << 1;
+ if (wantvl) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "ZUNGHR",
+ " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ zhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vl[
+ vl_offset], ldvl, &work[1], &c_n1, info);
+ } else if (wantvr) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "ZUNGHR",
+ " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ zhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[
+ vr_offset], ldvr, &work[1], &c_n1, info);
+ } else {
+ zhseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[
+ vr_offset], ldvr, &work[1], &c_n1, info);
+ }
+ hswork = (integer) work[1].r;
+/* Computing MAX */
+ i__1 = max(maxwrk,hswork);
+ maxwrk = max(i__1,minwrk);
+ }
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGEEV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1. / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = zlange_("M", n, n, &a[a_offset], lda, dum);
+ scalea = FALSE_;
+ if (anrm > 0. && anrm < smlnum) {
+ scalea = TRUE_;
+ cscale = smlnum;
+ } else if (anrm > bignum) {
+ scalea = TRUE_;
+ cscale = bignum;
+ }
+ if (scalea) {
+ zlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Balance the matrix */
+/* (CWorkspace: none) */
+/* (RWorkspace: need N) */
+
+ ibal = 1;
+ zgebal_("B", n, &a[a_offset], lda, &ilo, &ihi, &rwork[ibal], &ierr);
+
+/* Reduce to upper Hessenberg form */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: none) */
+
+ itau = 1;
+ iwrk = itau + *n;
+ i__1 = *lwork - iwrk + 1;
+ zgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
+ &ierr);
+
+ if (wantvl) {
+
+/* Want left eigenvectors */
+/* Copy Householder vectors to VL */
+
+ *(unsigned char *)side = 'L';
+ zlacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
+ ;
+
+/* Generate unitary matrix in VL */
+/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwrk + 1;
+ zunghr_(n, &ilo, &ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk],
+ &i__1, &ierr);
+
+/* Perform QR iteration, accumulating Schur vectors in VL */
+/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
+/* (RWorkspace: none) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ zhseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vl[
+ vl_offset], ldvl, &work[iwrk], &i__1, info);
+
+ if (wantvr) {
+
+/* Want left and right eigenvectors */
+/* Copy Schur vectors to VR */
+
+ *(unsigned char *)side = 'B';
+ zlacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
+ }
+
+ } else if (wantvr) {
+
+/* Want right eigenvectors */
+/* Copy Householder vectors to VR */
+
+ *(unsigned char *)side = 'R';
+ zlacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
+ ;
+
+/* Generate unitary matrix in VR */
+/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwrk + 1;
+ zunghr_(n, &ilo, &ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk],
+ &i__1, &ierr);
+
+/* Perform QR iteration, accumulating Schur vectors in VR */
+/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
+/* (RWorkspace: none) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ zhseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vr[
+ vr_offset], ldvr, &work[iwrk], &i__1, info);
+
+ } else {
+
+/* Compute eigenvalues only */
+/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
+/* (RWorkspace: none) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ zhseqr_("E", "N", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vr[
+ vr_offset], ldvr, &work[iwrk], &i__1, info);
+ }
+
+/* If INFO > 0 from ZHSEQR, then quit */
+
+ if (*info > 0) {
+ goto L50;
+ }
+
+ if (wantvl || wantvr) {
+
+/* Compute left and/or right eigenvectors */
+/* (CWorkspace: need 2*N) */
+/* (RWorkspace: need 2*N) */
+
+ irwork = ibal + *n;
+ ztrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
+ &vr[vr_offset], ldvr, n, &nout, &work[iwrk], &rwork[irwork],
+ &ierr);
+ }
+
+ if (wantvl) {
+
+/* Undo balancing of left eigenvectors */
+/* (CWorkspace: none) */
+/* (RWorkspace: need N) */
+
+ zgebak_("B", "L", n, &ilo, &ihi, &rwork[ibal], n, &vl[vl_offset],
+ ldvl, &ierr);
+
+/* Normalize left eigenvectors and make largest component real */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ scl = 1. / dznrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
+ zdscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + i__ * vl_dim1;
+/* Computing 2nd power */
+ d__1 = vl[i__3].r;
+/* Computing 2nd power */
+ d__2 = d_imag(&vl[k + i__ * vl_dim1]);
+ rwork[irwork + k - 1] = d__1 * d__1 + d__2 * d__2;
+/* L10: */
+ }
+ k = idamax_(n, &rwork[irwork], &c__1);
+ d_cnjg(&z__2, &vl[k + i__ * vl_dim1]);
+ d__1 = sqrt(rwork[irwork + k - 1]);
+ z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
+ tmp.r = z__1.r, tmp.i = z__1.i;
+ zscal_(n, &tmp, &vl[i__ * vl_dim1 + 1], &c__1);
+ i__2 = k + i__ * vl_dim1;
+ i__3 = k + i__ * vl_dim1;
+ d__1 = vl[i__3].r;
+ z__1.r = d__1, z__1.i = 0.;
+ vl[i__2].r = z__1.r, vl[i__2].i = z__1.i;
+/* L20: */
+ }
+ }
+
+ if (wantvr) {
+
+/* Undo balancing of right eigenvectors */
+/* (CWorkspace: none) */
+/* (RWorkspace: need N) */
+
+ zgebak_("B", "R", n, &ilo, &ihi, &rwork[ibal], n, &vr[vr_offset],
+ ldvr, &ierr);
+
+/* Normalize right eigenvectors and make largest component real */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ scl = 1. / dznrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
+ zdscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + i__ * vr_dim1;
+/* Computing 2nd power */
+ d__1 = vr[i__3].r;
+/* Computing 2nd power */
+ d__2 = d_imag(&vr[k + i__ * vr_dim1]);
+ rwork[irwork + k - 1] = d__1 * d__1 + d__2 * d__2;
+/* L30: */
+ }
+ k = idamax_(n, &rwork[irwork], &c__1);
+ d_cnjg(&z__2, &vr[k + i__ * vr_dim1]);
+ d__1 = sqrt(rwork[irwork + k - 1]);
+ z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
+ tmp.r = z__1.r, tmp.i = z__1.i;
+ zscal_(n, &tmp, &vr[i__ * vr_dim1 + 1], &c__1);
+ i__2 = k + i__ * vr_dim1;
+ i__3 = k + i__ * vr_dim1;
+ d__1 = vr[i__3].r;
+ z__1.r = d__1, z__1.i = 0.;
+ vr[i__2].r = z__1.r, vr[i__2].i = z__1.i;
+/* L40: */
+ }
+ }
+
+/* Undo scaling if necessary */
+
+L50:
+ if (scalea) {
+ i__1 = *n - *info;
+/* Computing MAX */
+ i__3 = *n - *info;
+ i__2 = max(i__3,1);
+ zlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[*info + 1]
+, &i__2, &ierr);
+ if (*info > 0) {
+ i__1 = ilo - 1;
+ zlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[1], n,
+ &ierr);
+ }
+ }
+
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+ return 0;
+
+/* End of ZGEEV */
+
+} /* zgeev_ */
diff --git a/SRC/zgeevx.c b/SRC/zgeevx.c
new file mode 100644
index 0000000..3b3fbdf
--- /dev/null
+++ b/SRC/zgeevx.c
@@ -0,0 +1,686 @@
+/* zgeevx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zgeevx_(char *balanc, char *jobvl, char *jobvr, char *
+ sense, integer *n, doublecomplex *a, integer *lda, doublecomplex *w,
+ doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr,
+ integer *ilo, integer *ihi, doublereal *scale, doublereal *abnrm,
+ doublereal *rconde, doublereal *rcondv, doublecomplex *work, integer *
+ lwork, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
+ i__2, i__3;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_imag(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, k;
+ char job[1];
+ doublereal scl, dum[1], eps;
+ doublecomplex tmp;
+ char side[1];
+ doublereal anrm;
+ integer ierr, itau, iwrk, nout, icond;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
+ extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
+ logical scalea;
+ extern doublereal dlamch_(char *);
+ doublereal cscale;
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), zgebak_(char *, char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublecomplex *,
+ integer *, integer *), zgebal_(char *, integer *,
+ doublecomplex *, integer *, integer *, integer *, doublereal *,
+ integer *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical select[1];
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ doublereal bignum;
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *), zlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublecomplex *,
+ integer *, integer *), zlacpy_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *);
+ integer minwrk, maxwrk;
+ logical wantvl, wntsnb;
+ integer hswork;
+ logical wntsne;
+ doublereal smlnum;
+ extern /* Subroutine */ int zhseqr_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+ logical lquery, wantvr;
+ extern /* Subroutine */ int ztrevc_(char *, char *, logical *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *, doublecomplex *,
+ doublereal *, integer *), ztrsna_(char *, char *,
+ logical *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *, doublecomplex *, integer *, doublereal *, doublereal
+ *, integer *, integer *, doublecomplex *, integer *, doublereal *,
+ integer *), zunghr_(integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, integer *);
+ logical wntsnn, wntsnv;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGEEVX computes for an N-by-N complex nonsymmetric matrix A, the */
+/* eigenvalues and, optionally, the left and/or right eigenvectors. */
+
+/* Optionally also, it computes a balancing transformation to improve */
+/* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */
+/* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues */
+/* (RCONDE), and reciprocal condition numbers for the right */
+/* eigenvectors (RCONDV). */
+
+/* The right eigenvector v(j) of A satisfies */
+/* A * v(j) = lambda(j) * v(j) */
+/* where lambda(j) is its eigenvalue. */
+/* The left eigenvector u(j) of A satisfies */
+/* u(j)**H * A = lambda(j) * u(j)**H */
+/* where u(j)**H denotes the conjugate transpose of u(j). */
+
+/* The computed eigenvectors are normalized to have Euclidean norm */
+/* equal to 1 and largest component real. */
+
+/* Balancing a matrix means permuting the rows and columns to make it */
+/* more nearly upper triangular, and applying a diagonal similarity */
+/* transformation D * A * D**(-1), where D is a diagonal matrix, to */
+/* make its rows and columns closer in norm and the condition numbers */
+/* of its eigenvalues and eigenvectors smaller. The computed */
+/* reciprocal condition numbers correspond to the balanced matrix. */
+/* Permuting rows and columns will not change the condition numbers */
+/* (in exact arithmetic) but diagonal scaling will. For further */
+/* explanation of balancing, see section 4.10.2 of the LAPACK */
+/* Users' Guide. */
+
+/* Arguments */
+/* ========= */
+
+/* BALANC (input) CHARACTER*1 */
+/* Indicates how the input matrix should be diagonally scaled */
+/* and/or permuted to improve the conditioning of its */
+/* eigenvalues. */
+/* = 'N': Do not diagonally scale or permute; */
+/* = 'P': Perform permutations to make the matrix more nearly */
+/* upper triangular. Do not diagonally scale; */
+/* = 'S': Diagonally scale the matrix, ie. replace A by */
+/* D*A*D**(-1), where D is a diagonal matrix chosen */
+/* to make the rows and columns of A more equal in */
+/* norm. Do not permute; */
+/* = 'B': Both diagonally scale and permute A. */
+
+/* Computed reciprocal condition numbers will be for the matrix */
+/* after balancing and/or permuting. Permuting does not change */
+/* condition numbers (in exact arithmetic), but balancing does. */
+
+/* JOBVL (input) CHARACTER*1 */
+/* = 'N': left eigenvectors of A are not computed; */
+/* = 'V': left eigenvectors of A are computed. */
+/* If SENSE = 'E' or 'B', JOBVL must = 'V'. */
+
+/* JOBVR (input) CHARACTER*1 */
+/* = 'N': right eigenvectors of A are not computed; */
+/* = 'V': right eigenvectors of A are computed. */
+/* If SENSE = 'E' or 'B', JOBVR must = 'V'. */
+
+/* SENSE (input) CHARACTER*1 */
+/* Determines which reciprocal condition numbers are computed. */
+/* = 'N': None are computed; */
+/* = 'E': Computed for eigenvalues only; */
+/* = 'V': Computed for right eigenvectors only; */
+/* = 'B': Computed for eigenvalues and right eigenvectors. */
+
+/* If SENSE = 'E' or 'B', both left and right eigenvectors */
+/* must also be computed (JOBVL = 'V' and JOBVR = 'V'). */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+/* On exit, A has been overwritten. If JOBVL = 'V' or */
+/* JOBVR = 'V', A contains the Schur form of the balanced */
+/* version of the matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* W (output) COMPLEX*16 array, dimension (N) */
+/* W contains the computed eigenvalues. */
+
+/* VL (output) COMPLEX*16 array, dimension (LDVL,N) */
+/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
+/* after another in the columns of VL, in the same order */
+/* as their eigenvalues. */
+/* If JOBVL = 'N', VL is not referenced. */
+/* u(j) = VL(:,j), the j-th column of VL. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. LDVL >= 1; if */
+/* JOBVL = 'V', LDVL >= N. */
+
+/* VR (output) COMPLEX*16 array, dimension (LDVR,N) */
+/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
+/* after another in the columns of VR, in the same order */
+/* as their eigenvalues. */
+/* If JOBVR = 'N', VR is not referenced. */
+/* v(j) = VR(:,j), the j-th column of VR. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. LDVR >= 1; if */
+/* JOBVR = 'V', LDVR >= N. */
+
+/* ILO (output) INTEGER */
+/* IHI (output) INTEGER */
+/* ILO and IHI are integer values determined when A was */
+/* balanced. The balanced A(i,j) = 0 if I > J and */
+/* J = 1,...,ILO-1 or I = IHI+1,...,N. */
+
+/* SCALE (output) DOUBLE PRECISION array, dimension (N) */
+/* Details of the permutations and scaling factors applied */
+/* when balancing A. If P(j) is the index of the row and column */
+/* interchanged with row and column j, and D(j) is the scaling */
+/* factor applied to row and column j, then */
+/* SCALE(J) = P(J), for J = 1,...,ILO-1 */
+/* = D(J), for J = ILO,...,IHI */
+/* = P(J) for J = IHI+1,...,N. */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* ABNRM (output) DOUBLE PRECISION */
+/* The one-norm of the balanced matrix (the maximum */
+/* of the sum of absolute values of elements of any column). */
+
+/* RCONDE (output) DOUBLE PRECISION array, dimension (N) */
+/* RCONDE(j) is the reciprocal condition number of the j-th */
+/* eigenvalue. */
+
+/* RCONDV (output) DOUBLE PRECISION array, dimension (N) */
+/* RCONDV(j) is the reciprocal condition number of the j-th */
+/* right eigenvector. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. If SENSE = 'N' or 'E', */
+/* LWORK >= max(1,2*N), and if SENSE = 'V' or 'B', */
+/* LWORK >= N*N+2*N. */
+/* For good performance, LWORK must generally be larger. */
+
+/* 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. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the QR algorithm failed to compute all the */
+/* eigenvalues, and no eigenvectors or condition numbers */
+/* have been computed; elements 1:ILO-1 and i+1:N of W */
+/* contain eigenvalues which have converged. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --scale;
+ --rconde;
+ --rcondv;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ wantvl = lsame_(jobvl, "V");
+ wantvr = lsame_(jobvr, "V");
+ wntsnn = lsame_(sense, "N");
+ wntsne = lsame_(sense, "E");
+ wntsnv = lsame_(sense, "V");
+ wntsnb = lsame_(sense, "B");
+ if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P")
+ || lsame_(balanc, "B"))) {
+ *info = -1;
+ } else if (! wantvl && ! lsame_(jobvl, "N")) {
+ *info = -2;
+ } else if (! wantvr && ! lsame_(jobvr, "N")) {
+ *info = -3;
+ } else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb)
+ && ! (wantvl && wantvr)) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvl < 1 || wantvl && *ldvl < *n) {
+ *info = -10;
+ } else if (*ldvr < 1 || wantvr && *ldvr < *n) {
+ *info = -12;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* CWorkspace refers to complex workspace, and RWorkspace to real */
+/* workspace. NB refers to the optimal block size for the */
+/* immediately following subroutine, as returned by ILAENV. */
+/* HSWORK refers to the workspace preferred by ZHSEQR, as */
+/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
+/* the worst case.) */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ } else {
+ maxwrk = *n + *n * ilaenv_(&c__1, "ZGEHRD", " ", n, &c__1, n, &
+ c__0);
+
+ if (wantvl) {
+ zhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vl[
+ vl_offset], ldvl, &work[1], &c_n1, info);
+ } else if (wantvr) {
+ zhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[
+ vr_offset], ldvr, &work[1], &c_n1, info);
+ } else {
+ if (wntsnn) {
+ zhseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &w[1], &
+ vr[vr_offset], ldvr, &work[1], &c_n1, info);
+ } else {
+ zhseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &w[1], &
+ vr[vr_offset], ldvr, &work[1], &c_n1, info);
+ }
+ }
+ hswork = (integer) work[1].r;
+
+ if (! wantvl && ! wantvr) {
+ minwrk = *n << 1;
+ if (! (wntsnn || wntsne)) {
+/* Computing MAX */
+ i__1 = minwrk, i__2 = *n * *n + (*n << 1);
+ minwrk = max(i__1,i__2);
+ }
+ maxwrk = max(maxwrk,hswork);
+ if (! (wntsnn || wntsne)) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * *n + (*n << 1);
+ maxwrk = max(i__1,i__2);
+ }
+ } else {
+ minwrk = *n << 1;
+ if (! (wntsnn || wntsne)) {
+/* Computing MAX */
+ i__1 = minwrk, i__2 = *n * *n + (*n << 1);
+ minwrk = max(i__1,i__2);
+ }
+ maxwrk = max(maxwrk,hswork);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "ZUNGHR",
+ " ", n, &c__1, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ if (! (wntsnn || wntsne)) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * *n + (*n << 1);
+ maxwrk = max(i__1,i__2);
+ }
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n << 1;
+ maxwrk = max(i__1,i__2);
+ }
+ maxwrk = max(maxwrk,minwrk);
+ }
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -20;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGEEVX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1. / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ icond = 0;
+ anrm = zlange_("M", n, n, &a[a_offset], lda, dum);
+ scalea = FALSE_;
+ if (anrm > 0. && anrm < smlnum) {
+ scalea = TRUE_;
+ cscale = smlnum;
+ } else if (anrm > bignum) {
+ scalea = TRUE_;
+ cscale = bignum;
+ }
+ if (scalea) {
+ zlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Balance the matrix and compute ABNRM */
+
+ zgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr);
+ *abnrm = zlange_("1", n, n, &a[a_offset], lda, dum);
+ if (scalea) {
+ dum[0] = *abnrm;
+ dlascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, &
+ ierr);
+ *abnrm = dum[0];
+ }
+
+/* Reduce to upper Hessenberg form */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: none) */
+
+ itau = 1;
+ iwrk = itau + *n;
+ i__1 = *lwork - iwrk + 1;
+ zgehrd_(n, ilo, ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, &
+ ierr);
+
+ if (wantvl) {
+
+/* Want left eigenvectors */
+/* Copy Householder vectors to VL */
+
+ *(unsigned char *)side = 'L';
+ zlacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
+ ;
+
+/* Generate unitary matrix in VL */
+/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwrk + 1;
+ zunghr_(n, ilo, ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], &
+ i__1, &ierr);
+
+/* Perform QR iteration, accumulating Schur vectors in VL */
+/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
+/* (RWorkspace: none) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ zhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &w[1], &vl[
+ vl_offset], ldvl, &work[iwrk], &i__1, info);
+
+ if (wantvr) {
+
+/* Want left and right eigenvectors */
+/* Copy Schur vectors to VR */
+
+ *(unsigned char *)side = 'B';
+ zlacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
+ }
+
+ } else if (wantvr) {
+
+/* Want right eigenvectors */
+/* Copy Householder vectors to VR */
+
+ *(unsigned char *)side = 'R';
+ zlacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
+ ;
+
+/* Generate unitary matrix in VR */
+/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwrk + 1;
+ zunghr_(n, ilo, ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], &
+ i__1, &ierr);
+
+/* Perform QR iteration, accumulating Schur vectors in VR */
+/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
+/* (RWorkspace: none) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ zhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &w[1], &vr[
+ vr_offset], ldvr, &work[iwrk], &i__1, info);
+
+ } else {
+
+/* Compute eigenvalues only */
+/* If condition numbers desired, compute Schur form */
+
+ if (wntsnn) {
+ *(unsigned char *)job = 'E';
+ } else {
+ *(unsigned char *)job = 'S';
+ }
+
+/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
+/* (RWorkspace: none) */
+
+ iwrk = itau;
+ i__1 = *lwork - iwrk + 1;
+ zhseqr_(job, "N", n, ilo, ihi, &a[a_offset], lda, &w[1], &vr[
+ vr_offset], ldvr, &work[iwrk], &i__1, info);
+ }
+
+/* If INFO > 0 from ZHSEQR, then quit */
+
+ if (*info > 0) {
+ goto L50;
+ }
+
+ if (wantvl || wantvr) {
+
+/* Compute left and/or right eigenvectors */
+/* (CWorkspace: need 2*N) */
+/* (RWorkspace: need N) */
+
+ ztrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
+ &vr[vr_offset], ldvr, n, &nout, &work[iwrk], &rwork[1], &
+ ierr);
+ }
+
+/* Compute condition numbers if desired */
+/* (CWorkspace: need N*N+2*N unless SENSE = 'E') */
+/* (RWorkspace: need 2*N unless SENSE = 'E') */
+
+ if (! wntsnn) {
+ ztrsna_(sense, "A", select, n, &a[a_offset], lda, &vl[vl_offset],
+ ldvl, &vr[vr_offset], ldvr, &rconde[1], &rcondv[1], n, &nout,
+ &work[iwrk], n, &rwork[1], &icond);
+ }
+
+ if (wantvl) {
+
+/* Undo balancing of left eigenvectors */
+
+ zgebak_(balanc, "L", n, ilo, ihi, &scale[1], n, &vl[vl_offset], ldvl,
+ &ierr);
+
+/* Normalize left eigenvectors and make largest component real */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ scl = 1. / dznrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
+ zdscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + i__ * vl_dim1;
+/* Computing 2nd power */
+ d__1 = vl[i__3].r;
+/* Computing 2nd power */
+ d__2 = d_imag(&vl[k + i__ * vl_dim1]);
+ rwork[k] = d__1 * d__1 + d__2 * d__2;
+/* L10: */
+ }
+ k = idamax_(n, &rwork[1], &c__1);
+ d_cnjg(&z__2, &vl[k + i__ * vl_dim1]);
+ d__1 = sqrt(rwork[k]);
+ z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
+ tmp.r = z__1.r, tmp.i = z__1.i;
+ zscal_(n, &tmp, &vl[i__ * vl_dim1 + 1], &c__1);
+ i__2 = k + i__ * vl_dim1;
+ i__3 = k + i__ * vl_dim1;
+ d__1 = vl[i__3].r;
+ z__1.r = d__1, z__1.i = 0.;
+ vl[i__2].r = z__1.r, vl[i__2].i = z__1.i;
+/* L20: */
+ }
+ }
+
+ if (wantvr) {
+
+/* Undo balancing of right eigenvectors */
+
+ zgebak_(balanc, "R", n, ilo, ihi, &scale[1], n, &vr[vr_offset], ldvr,
+ &ierr);
+
+/* Normalize right eigenvectors and make largest component real */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ scl = 1. / dznrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
+ zdscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + i__ * vr_dim1;
+/* Computing 2nd power */
+ d__1 = vr[i__3].r;
+/* Computing 2nd power */
+ d__2 = d_imag(&vr[k + i__ * vr_dim1]);
+ rwork[k] = d__1 * d__1 + d__2 * d__2;
+/* L30: */
+ }
+ k = idamax_(n, &rwork[1], &c__1);
+ d_cnjg(&z__2, &vr[k + i__ * vr_dim1]);
+ d__1 = sqrt(rwork[k]);
+ z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
+ tmp.r = z__1.r, tmp.i = z__1.i;
+ zscal_(n, &tmp, &vr[i__ * vr_dim1 + 1], &c__1);
+ i__2 = k + i__ * vr_dim1;
+ i__3 = k + i__ * vr_dim1;
+ d__1 = vr[i__3].r;
+ z__1.r = d__1, z__1.i = 0.;
+ vr[i__2].r = z__1.r, vr[i__2].i = z__1.i;
+/* L40: */
+ }
+ }
+
+/* Undo scaling if necessary */
+
+L50:
+ if (scalea) {
+ i__1 = *n - *info;
+/* Computing MAX */
+ i__3 = *n - *info;
+ i__2 = max(i__3,1);
+ zlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[*info + 1]
+, &i__2, &ierr);
+ if (*info == 0) {
+ if ((wntsnv || wntsnb) && icond == 0) {
+ dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &rcondv[
+ 1], n, &ierr);
+ }
+ } else {
+ i__1 = *ilo - 1;
+ zlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[1], n,
+ &ierr);
+ }
+ }
+
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+ return 0;
+
+/* End of ZGEEVX */
+
+} /* zgeevx_ */
diff --git a/SRC/zgegs.c b/SRC/zgegs.c
new file mode 100644
index 0000000..027abc9
--- /dev/null
+++ b/SRC/zgegs.c
@@ -0,0 +1,543 @@
+/* zgegs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zgegs_(char *jobvsl, char *jobvsr, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *alpha, doublecomplex *beta, doublecomplex *vsl,
+ integer *ldvsl, doublecomplex *vsr, integer *ldvsr, doublecomplex *
+ work, integer *lwork, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
+ vsr_dim1, vsr_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer nb, nb1, nb2, nb3, ihi, ilo;
+ doublereal eps, anrm, bnrm;
+ integer itau, lopt;
+ extern logical lsame_(char *, char *);
+ integer ileft, iinfo, icols;
+ logical ilvsl;
+ integer iwork;
+ logical ilvsr;
+ integer irows;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zggbak_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublecomplex *,
+ integer *, integer *), zggbal_(char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+, integer *, doublereal *, doublereal *, doublereal *, integer *);
+ logical ilascl, ilbscl;
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ doublereal bignum;
+ integer ijobvl, iright;
+ extern /* Subroutine */ int zgghrd_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+), zlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublecomplex *,
+ integer *, integer *);
+ integer ijobvr;
+ extern /* Subroutine */ int zgeqrf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *
+);
+ doublereal anrmto;
+ integer lwkmin;
+ doublereal bnrmto;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *), zhgeqz_(
+ char *, char *, char *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *);
+ doublereal smlnum;
+ integer irwork, lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int zungqr_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *), zunmqr_(char *, char *, integer *, integer
+ *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine ZGGES. */
+
+/* ZGEGS computes the eigenvalues, Schur form, and, optionally, the */
+/* left and or/right Schur vectors of a complex matrix pair (A,B). */
+/* Given two square matrices A and B, the generalized Schur */
+/* factorization has the form */
+
+/* A = Q*S*Z**H, B = Q*T*Z**H */
+
+/* where Q and Z are unitary matrices and S and T are upper triangular. */
+/* The columns of Q are the left Schur vectors */
+/* and the columns of Z are the right Schur vectors. */
+
+/* If only the eigenvalues of (A,B) are needed, the driver routine */
+/* ZGEGV should be used instead. See ZGEGV for a description of the */
+/* eigenvalues of the generalized nonsymmetric eigenvalue problem */
+/* (GNEP). */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVSL (input) CHARACTER*1 */
+/* = 'N': do not compute the left Schur vectors; */
+/* = 'V': compute the left Schur vectors (returned in VSL). */
+
+/* JOBVSR (input) CHARACTER*1 */
+/* = 'N': do not compute the right Schur vectors; */
+/* = 'V': compute the right Schur vectors (returned in VSR). */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VSL, and VSR. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA, N) */
+/* On entry, the matrix A. */
+/* On exit, the upper triangular matrix S from the generalized */
+/* Schur factorization. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB, N) */
+/* On entry, the matrix B. */
+/* On exit, the upper triangular matrix T from the generalized */
+/* Schur factorization. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* ALPHA (output) COMPLEX*16 array, dimension (N) */
+/* The complex scalars alpha that define the eigenvalues of */
+/* GNEP. ALPHA(j) = S(j,j), the diagonal element of the Schur */
+/* form of A. */
+
+/* BETA (output) COMPLEX*16 array, dimension (N) */
+/* The non-negative real scalars beta that define the */
+/* eigenvalues of GNEP. BETA(j) = T(j,j), the diagonal element */
+/* of the triangular factor T. */
+
+/* Together, the quantities alpha = ALPHA(j) and beta = BETA(j) */
+/* represent the j-th eigenvalue of the matrix pair (A,B), in */
+/* one of the forms lambda = alpha/beta or mu = beta/alpha. */
+/* Since either lambda or mu may overflow, they should not, */
+/* in general, be computed. */
+
+
+/* VSL (output) COMPLEX*16 array, dimension (LDVSL,N) */
+/* If JOBVSL = 'V', the matrix of left Schur vectors Q. */
+/* Not referenced if JOBVSL = 'N'. */
+
+/* LDVSL (input) INTEGER */
+/* The leading dimension of the matrix VSL. LDVSL >= 1, and */
+/* if JOBVSL = 'V', LDVSL >= N. */
+
+/* VSR (output) COMPLEX*16 array, dimension (LDVSR,N) */
+/* If JOBVSR = 'V', the matrix of right Schur vectors Z. */
+/* Not referenced if JOBVSR = 'N'. */
+
+/* LDVSR (input) INTEGER */
+/* The leading dimension of the matrix VSR. LDVSR >= 1, and */
+/* if JOBVSR = 'V', LDVSR >= N. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,2*N). */
+/* For good performance, LWORK must generally be larger. */
+/* To compute the optimal value of LWORK, call ILAENV to get */
+/* blocksizes (for ZGEQRF, ZUNMQR, and CUNGQR.) Then compute: */
+/* NB -- MAX of the blocksizes for ZGEQRF, ZUNMQR, and CUNGQR; */
+/* the optimal LWORK is N*(NB+1). */
+
+/* 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. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* =1,...,N: */
+/* The QZ iteration failed. (A,B) are not in Schur */
+/* form, but ALPHA(j) and BETA(j) should be correct for */
+/* j=INFO+1,...,N. */
+/* > N: errors that usually indicate LAPACK problems: */
+/* =N+1: error return from ZGGBAL */
+/* =N+2: error return from ZGEQRF */
+/* =N+3: error return from ZUNMQR */
+/* =N+4: error return from ZUNGQR */
+/* =N+5: error return from ZGGHRD */
+/* =N+6: error return from ZHGEQZ (other than failed */
+/* iteration) */
+/* =N+7: error return from ZGGBAK (computing VSL) */
+/* =N+8: error return from ZGGBAK (computing VSR) */
+/* =N+9: error return from ZLASCL (various places) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alpha;
+ --beta;
+ vsl_dim1 = *ldvsl;
+ vsl_offset = 1 + vsl_dim1;
+ vsl -= vsl_offset;
+ vsr_dim1 = *ldvsr;
+ vsr_offset = 1 + vsr_dim1;
+ vsr -= vsr_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ if (lsame_(jobvsl, "N")) {
+ ijobvl = 1;
+ ilvsl = FALSE_;
+ } else if (lsame_(jobvsl, "V")) {
+ ijobvl = 2;
+ ilvsl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvsl = FALSE_;
+ }
+
+ if (lsame_(jobvsr, "N")) {
+ ijobvr = 1;
+ ilvsr = FALSE_;
+ } else if (lsame_(jobvsr, "V")) {
+ ijobvr = 2;
+ ilvsr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvsr = FALSE_;
+ }
+
+/* Test the input arguments */
+
+/* Computing MAX */
+ i__1 = *n << 1;
+ lwkmin = max(i__1,1);
+ lwkopt = lwkmin;
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ lquery = *lwork == -1;
+ *info = 0;
+ if (ijobvl <= 0) {
+ *info = -1;
+ } else if (ijobvr <= 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
+ *info = -11;
+ } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
+ *info = -13;
+ } else if (*lwork < lwkmin && ! lquery) {
+ *info = -15;
+ }
+
+ if (*info == 0) {
+ nb1 = ilaenv_(&c__1, "ZGEQRF", " ", n, n, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "ZUNMQR", " ", n, n, n, &c_n1);
+ nb3 = ilaenv_(&c__1, "ZUNGQR", " ", n, n, n, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2);
+ nb = max(i__1,nb3);
+ lopt = *n * (nb + 1);
+ work[1].r = (doublereal) lopt, work[1].i = 0.;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGEGS ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("E") * dlamch_("B");
+ safmin = dlamch_("S");
+ smlnum = *n * safmin / eps;
+ bignum = 1. / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = zlange_("M", n, n, &a[a_offset], lda, &rwork[1]);
+ ilascl = FALSE_;
+ if (anrm > 0. && anrm < smlnum) {
+ anrmto = smlnum;
+ ilascl = TRUE_;
+ } else if (anrm > bignum) {
+ anrmto = bignum;
+ ilascl = TRUE_;
+ }
+
+ if (ilascl) {
+ zlascl_("G", &c_n1, &c_n1, &anrm, &anrmto, n, n, &a[a_offset], lda, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = zlange_("M", n, n, &b[b_offset], ldb, &rwork[1]);
+ ilbscl = FALSE_;
+ if (bnrm > 0. && bnrm < smlnum) {
+ bnrmto = smlnum;
+ ilbscl = TRUE_;
+ } else if (bnrm > bignum) {
+ bnrmto = bignum;
+ ilbscl = TRUE_;
+ }
+
+ if (ilbscl) {
+ zlascl_("G", &c_n1, &c_n1, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ }
+
+/* Permute the matrix to make it more nearly triangular */
+
+ ileft = 1;
+ iright = *n + 1;
+ irwork = iright + *n;
+ iwork = 1;
+ zggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &rwork[
+ ileft], &rwork[iright], &rwork[irwork], &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 1;
+ goto L10;
+ }
+
+/* Reduce B to triangular form, and initialize VSL and/or VSR */
+
+ irows = ihi + 1 - ilo;
+ icols = *n + 1 - ilo;
+ itau = iwork;
+ iwork = itau + irows;
+ i__1 = *lwork + 1 - iwork;
+ zgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
+ iwork], &i__1, &iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__3 = iwork;
+ i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 2;
+ goto L10;
+ }
+
+ i__1 = *lwork + 1 - iwork;
+ zunmqr_("L", "C", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
+ work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, &
+ iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__3 = iwork;
+ i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 3;
+ goto L10;
+ }
+
+ if (ilvsl) {
+ zlaset_("Full", n, n, &c_b1, &c_b2, &vsl[vsl_offset], ldvsl);
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ zlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[ilo
+ + 1 + ilo * vsl_dim1], ldvsl);
+ i__1 = *lwork + 1 - iwork;
+ zungqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, &
+ work[itau], &work[iwork], &i__1, &iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__3 = iwork;
+ i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 4;
+ goto L10;
+ }
+ }
+
+ if (ilvsr) {
+ zlaset_("Full", n, n, &c_b1, &c_b2, &vsr[vsr_offset], ldvsr);
+ }
+
+/* Reduce to generalized Hessenberg form */
+
+ zgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 5;
+ goto L10;
+ }
+
+/* Perform QZ algorithm, computing Schur vectors if desired */
+
+ iwork = itau;
+ i__1 = *lwork + 1 - iwork;
+ zhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[
+ b_offset], ldb, &alpha[1], &beta[1], &vsl[vsl_offset], ldvsl, &
+ vsr[vsr_offset], ldvsr, &work[iwork], &i__1, &rwork[irwork], &
+ iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__3 = iwork;
+ i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ if (iinfo > 0 && iinfo <= *n) {
+ *info = iinfo;
+ } else if (iinfo > *n && iinfo <= *n << 1) {
+ *info = iinfo - *n;
+ } else {
+ *info = *n + 6;
+ }
+ goto L10;
+ }
+
+/* Apply permutation to VSL and VSR */
+
+ if (ilvsl) {
+ zggbak_("P", "L", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &
+ vsl[vsl_offset], ldvsl, &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 7;
+ goto L10;
+ }
+ }
+ if (ilvsr) {
+ zggbak_("P", "R", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &
+ vsr[vsr_offset], ldvsr, &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 8;
+ goto L10;
+ }
+ }
+
+/* Undo scaling */
+
+ if (ilascl) {
+ zlascl_("U", &c_n1, &c_n1, &anrmto, &anrm, n, n, &a[a_offset], lda, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ zlascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &alpha[1], n, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ }
+
+ if (ilbscl) {
+ zlascl_("U", &c_n1, &c_n1, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ zlascl_("G", &c_n1, &c_n1, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ return 0;
+ }
+ }
+
+L10:
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZGEGS */
+
+} /* zgegs_ */
diff --git a/SRC/zgegv.c b/SRC/zgegv.c
new file mode 100644
index 0000000..a244aa1
--- /dev/null
+++ b/SRC/zgegv.c
@@ -0,0 +1,781 @@
+/* zgegv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b29 = 1.;
+
+/* Subroutine */ int zgegv_(char *jobvl, char *jobvr, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *alpha, doublecomplex *beta, doublecomplex *vl, integer
+ *ldvl, doublecomplex *vr, integer *ldvr, doublecomplex *work, integer
+ *lwork, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
+ vr_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer jc, nb, in, jr, nb1, nb2, nb3, ihi, ilo;
+ doublereal eps;
+ logical ilv;
+ doublereal absb, anrm, bnrm;
+ integer itau;
+ doublereal temp;
+ logical ilvl, ilvr;
+ integer lopt;
+ doublereal anrm1, anrm2, bnrm1, bnrm2, absai, scale, absar, sbeta;
+ extern logical lsame_(char *, char *);
+ integer ileft, iinfo, icols, iwork, irows;
+ extern doublereal dlamch_(char *);
+ doublereal salfai;
+ extern /* Subroutine */ int zggbak_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublecomplex *,
+ integer *, integer *), zggbal_(char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+, integer *, doublereal *, doublereal *, doublereal *, integer *);
+ doublereal salfar, safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal safmax;
+ char chtemp[1];
+ logical ldumma[1];
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ integer ijobvl, iright;
+ logical ilimit;
+ extern /* Subroutine */ int zgghrd_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+), zlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublecomplex *,
+ integer *, integer *);
+ integer ijobvr;
+ extern /* Subroutine */ int zgeqrf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *
+);
+ integer lwkmin;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *), ztgevc_(
+ char *, char *, logical *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *, doublecomplex *,
+ doublereal *, integer *), zhgeqz_(char *, char *,
+ char *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, integer *);
+ integer irwork, lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int zungqr_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *), zunmqr_(char *, char *, integer *, integer
+ *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine ZGGEV. */
+
+/* ZGEGV computes the eigenvalues and, optionally, the left and/or right */
+/* eigenvectors of a complex matrix pair (A,B). */
+/* Given two square matrices A and B, */
+/* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the */
+/* eigenvalues lambda and corresponding (non-zero) eigenvectors x such */
+/* that */
+/* A*x = lambda*B*x. */
+
+/* An alternate form is to find the eigenvalues mu and corresponding */
+/* eigenvectors y such that */
+/* mu*A*y = B*y. */
+
+/* These two forms are equivalent with mu = 1/lambda and x = y if */
+/* neither lambda nor mu is zero. In order to deal with the case that */
+/* lambda or mu is zero or small, two values alpha and beta are returned */
+/* for each eigenvalue, such that lambda = alpha/beta and */
+/* mu = beta/alpha. */
+
+/* The vectors x and y in the above equations are right eigenvectors of */
+/* the matrix pair (A,B). Vectors u and v satisfying */
+/* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B */
+/* are left eigenvectors of (A,B). */
+
+/* Note: this routine performs "full balancing" on A and B -- see */
+/* "Further Details", below. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVL (input) CHARACTER*1 */
+/* = 'N': do not compute the left generalized eigenvectors; */
+/* = 'V': compute the left generalized eigenvectors (returned */
+/* in VL). */
+
+/* JOBVR (input) CHARACTER*1 */
+/* = 'N': do not compute the right generalized eigenvectors; */
+/* = 'V': compute the right generalized eigenvectors (returned */
+/* in VR). */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VL, and VR. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA, N) */
+/* On entry, the matrix A. */
+/* If JOBVL = 'V' or JOBVR = 'V', then on exit A */
+/* contains the Schur form of A from the generalized Schur */
+/* factorization of the pair (A,B) after balancing. If no */
+/* eigenvectors were computed, then only the diagonal elements */
+/* of the Schur form will be correct. See ZGGHRD and ZHGEQZ */
+/* for details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB, N) */
+/* On entry, the matrix B. */
+/* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the */
+/* upper triangular matrix obtained from B in the generalized */
+/* Schur factorization of the pair (A,B) after balancing. */
+/* If no eigenvectors were computed, then only the diagonal */
+/* elements of B will be correct. See ZGGHRD and ZHGEQZ for */
+/* details. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* ALPHA (output) COMPLEX*16 array, dimension (N) */
+/* The complex scalars alpha that define the eigenvalues of */
+/* GNEP. */
+
+/* BETA (output) COMPLEX*16 array, dimension (N) */
+/* The complex scalars beta that define the eigenvalues of GNEP. */
+
+/* Together, the quantities alpha = ALPHA(j) and beta = BETA(j) */
+/* represent the j-th eigenvalue of the matrix pair (A,B), in */
+/* one of the forms lambda = alpha/beta or mu = beta/alpha. */
+/* Since either lambda or mu may overflow, they should not, */
+/* in general, be computed. */
+
+/* VL (output) COMPLEX*16 array, dimension (LDVL,N) */
+/* If JOBVL = 'V', the left eigenvectors u(j) are stored */
+/* in the columns of VL, in the same order as their eigenvalues. */
+/* Each eigenvector is scaled so that its largest component has */
+/* abs(real part) + abs(imag. part) = 1, except for eigenvectors */
+/* corresponding to an eigenvalue with alpha = beta = 0, which */
+/* are set to zero. */
+/* Not referenced if JOBVL = 'N'. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the matrix VL. LDVL >= 1, and */
+/* if JOBVL = 'V', LDVL >= N. */
+
+/* VR (output) COMPLEX*16 array, dimension (LDVR,N) */
+/* If JOBVR = 'V', the right eigenvectors x(j) are stored */
+/* in the columns of VR, in the same order as their eigenvalues. */
+/* Each eigenvector is scaled so that its largest component has */
+/* abs(real part) + abs(imag. part) = 1, except for eigenvectors */
+/* corresponding to an eigenvalue with alpha = beta = 0, which */
+/* are set to zero. */
+/* Not referenced if JOBVR = 'N'. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the matrix VR. LDVR >= 1, and */
+/* if JOBVR = 'V', LDVR >= N. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,2*N). */
+/* For good performance, LWORK must generally be larger. */
+/* To compute the optimal value of LWORK, call ILAENV to get */
+/* blocksizes (for ZGEQRF, ZUNMQR, and ZUNGQR.) Then compute: */
+/* NB -- MAX of the blocksizes for ZGEQRF, ZUNMQR, and ZUNGQR; */
+/* The optimal LWORK is MAX( 2*N, N*(NB+1) ). */
+
+/* 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. */
+
+/* RWORK (workspace/output) DOUBLE PRECISION array, dimension (8*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* =1,...,N: */
+/* The QZ iteration failed. No eigenvectors have been */
+/* calculated, but ALPHA(j) and BETA(j) should be */
+/* correct for j=INFO+1,...,N. */
+/* > N: errors that usually indicate LAPACK problems: */
+/* =N+1: error return from ZGGBAL */
+/* =N+2: error return from ZGEQRF */
+/* =N+3: error return from ZUNMQR */
+/* =N+4: error return from ZUNGQR */
+/* =N+5: error return from ZGGHRD */
+/* =N+6: error return from ZHGEQZ (other than failed */
+/* iteration) */
+/* =N+7: error return from ZTGEVC */
+/* =N+8: error return from ZGGBAK (computing VL) */
+/* =N+9: error return from ZGGBAK (computing VR) */
+/* =N+10: error return from ZLASCL (various calls) */
+
+/* Further Details */
+/* =============== */
+
+/* Balancing */
+/* --------- */
+
+/* This driver calls ZGGBAL to both permute and scale rows and columns */
+/* of A and B. The permutations PL and PR are chosen so that PL*A*PR */
+/* and PL*B*R will be upper triangular except for the diagonal blocks */
+/* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as */
+/* possible. The diagonal scaling matrices DL and DR are chosen so */
+/* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to */
+/* one (except for the elements that start out zero.) */
+
+/* After the eigenvalues and eigenvectors of the balanced matrices */
+/* have been computed, ZGGBAK transforms the eigenvectors back to what */
+/* they would have been (in perfect arithmetic) if they had not been */
+/* balanced. */
+
+/* Contents of A and B on Exit */
+/* -------- -- - --- - -- ---- */
+
+/* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or */
+/* both), then on exit the arrays A and B will contain the complex Schur */
+/* form[*] of the "balanced" versions of A and B. If no eigenvectors */
+/* are computed, then only the diagonal blocks will be correct. */
+
+/* [*] In other words, upper triangular form. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alpha;
+ --beta;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ if (lsame_(jobvl, "N")) {
+ ijobvl = 1;
+ ilvl = FALSE_;
+ } else if (lsame_(jobvl, "V")) {
+ ijobvl = 2;
+ ilvl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvl = FALSE_;
+ }
+
+ if (lsame_(jobvr, "N")) {
+ ijobvr = 1;
+ ilvr = FALSE_;
+ } else if (lsame_(jobvr, "V")) {
+ ijobvr = 2;
+ ilvr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvr = FALSE_;
+ }
+ ilv = ilvl || ilvr;
+
+/* Test the input arguments */
+
+/* Computing MAX */
+ i__1 = *n << 1;
+ lwkmin = max(i__1,1);
+ lwkopt = lwkmin;
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ lquery = *lwork == -1;
+ *info = 0;
+ if (ijobvl <= 0) {
+ *info = -1;
+ } else if (ijobvr <= 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvl < 1 || ilvl && *ldvl < *n) {
+ *info = -11;
+ } else if (*ldvr < 1 || ilvr && *ldvr < *n) {
+ *info = -13;
+ } else if (*lwork < lwkmin && ! lquery) {
+ *info = -15;
+ }
+
+ if (*info == 0) {
+ nb1 = ilaenv_(&c__1, "ZGEQRF", " ", n, n, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "ZUNMQR", " ", n, n, n, &c_n1);
+ nb3 = ilaenv_(&c__1, "ZUNGQR", " ", n, n, n, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2);
+ nb = max(i__1,nb3);
+/* Computing MAX */
+ i__1 = *n << 1, i__2 = *n * (nb + 1);
+ lopt = max(i__1,i__2);
+ work[1].r = (doublereal) lopt, work[1].i = 0.;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGEGV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("E") * dlamch_("B");
+ safmin = dlamch_("S");
+ safmin += safmin;
+ safmax = 1. / safmin;
+
+/* Scale A */
+
+ anrm = zlange_("M", n, n, &a[a_offset], lda, &rwork[1]);
+ anrm1 = anrm;
+ anrm2 = 1.;
+ if (anrm < 1.) {
+ if (safmax * anrm < 1.) {
+ anrm1 = safmin;
+ anrm2 = safmax * anrm;
+ }
+ }
+
+ if (anrm > 0.) {
+ zlascl_("G", &c_n1, &c_n1, &anrm, &c_b29, n, n, &a[a_offset], lda, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 10;
+ return 0;
+ }
+ }
+
+/* Scale B */
+
+ bnrm = zlange_("M", n, n, &b[b_offset], ldb, &rwork[1]);
+ bnrm1 = bnrm;
+ bnrm2 = 1.;
+ if (bnrm < 1.) {
+ if (safmax * bnrm < 1.) {
+ bnrm1 = safmin;
+ bnrm2 = safmax * bnrm;
+ }
+ }
+
+ if (bnrm > 0.) {
+ zlascl_("G", &c_n1, &c_n1, &bnrm, &c_b29, n, n, &b[b_offset], ldb, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = *n + 10;
+ return 0;
+ }
+ }
+
+/* Permute the matrix to make it more nearly triangular */
+/* Also "balance" the matrix. */
+
+ ileft = 1;
+ iright = *n + 1;
+ irwork = iright + *n;
+ zggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &rwork[
+ ileft], &rwork[iright], &rwork[irwork], &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 1;
+ goto L80;
+ }
+
+/* Reduce B to triangular form, and initialize VL and/or VR */
+
+ irows = ihi + 1 - ilo;
+ if (ilv) {
+ icols = *n + 1 - ilo;
+ } else {
+ icols = irows;
+ }
+ itau = 1;
+ iwork = itau + irows;
+ i__1 = *lwork + 1 - iwork;
+ zgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
+ iwork], &i__1, &iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__3 = iwork;
+ i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 2;
+ goto L80;
+ }
+
+ i__1 = *lwork + 1 - iwork;
+ zunmqr_("L", "C", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
+ work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwork], &i__1, &
+ iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__3 = iwork;
+ i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 3;
+ goto L80;
+ }
+
+ if (ilvl) {
+ zlaset_("Full", n, n, &c_b1, &c_b2, &vl[vl_offset], ldvl);
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ zlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vl[ilo +
+ 1 + ilo * vl_dim1], ldvl);
+ i__1 = *lwork + 1 - iwork;
+ zungqr_(&irows, &irows, &irows, &vl[ilo + ilo * vl_dim1], ldvl, &work[
+ itau], &work[iwork], &i__1, &iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__3 = iwork;
+ i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ *info = *n + 4;
+ goto L80;
+ }
+ }
+
+ if (ilvr) {
+ zlaset_("Full", n, n, &c_b1, &c_b2, &vr[vr_offset], ldvr);
+ }
+
+/* Reduce to generalized Hessenberg form */
+
+ if (ilv) {
+
+/* Eigenvectors requested -- work on whole matrix. */
+
+ zgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &iinfo);
+ } else {
+ zgghrd_("N", "N", &irows, &c__1, &irows, &a[ilo + ilo * a_dim1], lda,
+ &b[ilo + ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[
+ vr_offset], ldvr, &iinfo);
+ }
+ if (iinfo != 0) {
+ *info = *n + 5;
+ goto L80;
+ }
+
+/* Perform QZ algorithm */
+
+ iwork = itau;
+ if (ilv) {
+ *(unsigned char *)chtemp = 'S';
+ } else {
+ *(unsigned char *)chtemp = 'E';
+ }
+ i__1 = *lwork + 1 - iwork;
+ zhgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[
+ b_offset], ldb, &alpha[1], &beta[1], &vl[vl_offset], ldvl, &vr[
+ vr_offset], ldvr, &work[iwork], &i__1, &rwork[irwork], &iinfo);
+ if (iinfo >= 0) {
+/* Computing MAX */
+ i__3 = iwork;
+ i__1 = lwkopt, i__2 = (integer) work[i__3].r + iwork - 1;
+ lwkopt = max(i__1,i__2);
+ }
+ if (iinfo != 0) {
+ if (iinfo > 0 && iinfo <= *n) {
+ *info = iinfo;
+ } else if (iinfo > *n && iinfo <= *n << 1) {
+ *info = iinfo - *n;
+ } else {
+ *info = *n + 6;
+ }
+ goto L80;
+ }
+
+ if (ilv) {
+
+/* Compute Eigenvectors */
+
+ if (ilvl) {
+ if (ilvr) {
+ *(unsigned char *)chtemp = 'B';
+ } else {
+ *(unsigned char *)chtemp = 'L';
+ }
+ } else {
+ *(unsigned char *)chtemp = 'R';
+ }
+
+ ztgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb,
+ &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[
+ iwork], &rwork[irwork], &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 7;
+ goto L80;
+ }
+
+/* Undo balancing on VL and VR, rescale */
+
+ if (ilvl) {
+ zggbak_("P", "L", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n,
+ &vl[vl_offset], ldvl, &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 8;
+ goto L80;
+ }
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ temp = 0.;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ i__3 = jr + jc * vl_dim1;
+ d__3 = temp, d__4 = (d__1 = vl[i__3].r, abs(d__1)) + (
+ d__2 = d_imag(&vl[jr + jc * vl_dim1]), abs(d__2));
+ temp = max(d__3,d__4);
+/* L10: */
+ }
+ if (temp < safmin) {
+ goto L30;
+ }
+ temp = 1. / temp;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = jr + jc * vl_dim1;
+ i__4 = jr + jc * vl_dim1;
+ z__1.r = temp * vl[i__4].r, z__1.i = temp * vl[i__4].i;
+ vl[i__3].r = z__1.r, vl[i__3].i = z__1.i;
+/* L20: */
+ }
+L30:
+ ;
+ }
+ }
+ if (ilvr) {
+ zggbak_("P", "R", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n,
+ &vr[vr_offset], ldvr, &iinfo);
+ if (iinfo != 0) {
+ *info = *n + 9;
+ goto L80;
+ }
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ temp = 0.;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ i__3 = jr + jc * vr_dim1;
+ d__3 = temp, d__4 = (d__1 = vr[i__3].r, abs(d__1)) + (
+ d__2 = d_imag(&vr[jr + jc * vr_dim1]), abs(d__2));
+ temp = max(d__3,d__4);
+/* L40: */
+ }
+ if (temp < safmin) {
+ goto L60;
+ }
+ temp = 1. / temp;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = jr + jc * vr_dim1;
+ i__4 = jr + jc * vr_dim1;
+ z__1.r = temp * vr[i__4].r, z__1.i = temp * vr[i__4].i;
+ vr[i__3].r = z__1.r, vr[i__3].i = z__1.i;
+/* L50: */
+ }
+L60:
+ ;
+ }
+ }
+
+/* End of eigenvector calculation */
+
+ }
+
+/* Undo scaling in alpha, beta */
+
+/* Note: this does not give the alpha and beta for the unscaled */
+/* problem. */
+
+/* Un-scaling is limited to avoid underflow in alpha and beta */
+/* if they are significant. */
+
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ i__2 = jc;
+ absar = (d__1 = alpha[i__2].r, abs(d__1));
+ absai = (d__1 = d_imag(&alpha[jc]), abs(d__1));
+ i__2 = jc;
+ absb = (d__1 = beta[i__2].r, abs(d__1));
+ i__2 = jc;
+ salfar = anrm * alpha[i__2].r;
+ salfai = anrm * d_imag(&alpha[jc]);
+ i__2 = jc;
+ sbeta = bnrm * beta[i__2].r;
+ ilimit = FALSE_;
+ scale = 1.;
+
+/* Check for significant underflow in imaginary part of ALPHA */
+
+/* Computing MAX */
+ d__1 = safmin, d__2 = eps * absar, d__1 = max(d__1,d__2), d__2 = eps *
+ absb;
+ if (abs(salfai) < safmin && absai >= max(d__1,d__2)) {
+ ilimit = TRUE_;
+/* Computing MAX */
+ d__1 = safmin, d__2 = anrm2 * absai;
+ scale = safmin / anrm1 / max(d__1,d__2);
+ }
+
+/* Check for significant underflow in real part of ALPHA */
+
+/* Computing MAX */
+ d__1 = safmin, d__2 = eps * absai, d__1 = max(d__1,d__2), d__2 = eps *
+ absb;
+ if (abs(salfar) < safmin && absar >= max(d__1,d__2)) {
+ ilimit = TRUE_;
+/* Computing MAX */
+/* Computing MAX */
+ d__3 = safmin, d__4 = anrm2 * absar;
+ d__1 = scale, d__2 = safmin / anrm1 / max(d__3,d__4);
+ scale = max(d__1,d__2);
+ }
+
+/* Check for significant underflow in BETA */
+
+/* Computing MAX */
+ d__1 = safmin, d__2 = eps * absar, d__1 = max(d__1,d__2), d__2 = eps *
+ absai;
+ if (abs(sbeta) < safmin && absb >= max(d__1,d__2)) {
+ ilimit = TRUE_;
+/* Computing MAX */
+/* Computing MAX */
+ d__3 = safmin, d__4 = bnrm2 * absb;
+ d__1 = scale, d__2 = safmin / bnrm1 / max(d__3,d__4);
+ scale = max(d__1,d__2);
+ }
+
+/* Check for possible overflow when limiting scaling */
+
+ if (ilimit) {
+/* Computing MAX */
+ d__1 = abs(salfar), d__2 = abs(salfai), d__1 = max(d__1,d__2),
+ d__2 = abs(sbeta);
+ temp = scale * safmin * max(d__1,d__2);
+ if (temp > 1.) {
+ scale /= temp;
+ }
+ if (scale < 1.) {
+ ilimit = FALSE_;
+ }
+ }
+
+/* Recompute un-scaled ALPHA, BETA if necessary. */
+
+ if (ilimit) {
+ i__2 = jc;
+ salfar = scale * alpha[i__2].r * anrm;
+ salfai = scale * d_imag(&alpha[jc]) * anrm;
+ i__2 = jc;
+ z__2.r = scale * beta[i__2].r, z__2.i = scale * beta[i__2].i;
+ z__1.r = bnrm * z__2.r, z__1.i = bnrm * z__2.i;
+ sbeta = z__1.r;
+ }
+ i__2 = jc;
+ z__1.r = salfar, z__1.i = salfai;
+ alpha[i__2].r = z__1.r, alpha[i__2].i = z__1.i;
+ i__2 = jc;
+ beta[i__2].r = sbeta, beta[i__2].i = 0.;
+/* L70: */
+ }
+
+L80:
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZGEGV */
+
+} /* zgegv_ */
diff --git a/SRC/zgehd2.c b/SRC/zgehd2.c
new file mode 100644
index 0000000..af1ba28
--- /dev/null
+++ b/SRC/zgehd2.c
@@ -0,0 +1,199 @@
+/* zgehd2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zgehd2_(integer *n, integer *ilo, integer *ihi,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__;
+ doublecomplex alpha;
+ extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *), xerbla_(char *, integer *), zlarfg_(integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H */
+/* by a unitary similarity transformation: Q' * A * Q = H . */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that A is already upper triangular in rows */
+/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
+/* set by a previous call to ZGEBAL; otherwise they should be */
+/* set to 1 and N respectively. See Further Details. */
+/* 1 <= ILO <= IHI <= max(1,N). */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the n by n general matrix to be reduced. */
+/* On exit, the upper triangle and the first subdiagonal of A */
+/* are overwritten with the upper Hessenberg matrix H, and the */
+/* elements below the first subdiagonal, with the array TAU, */
+/* represent the unitary matrix Q as a product of elementary */
+/* reflectors. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAU (output) COMPLEX*16 array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of (ihi-ilo) elementary */
+/* reflectors */
+
+/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */
+/* exit in A(i+2:ihi,i), and tau in TAU(i). */
+
+/* The contents of A are illustrated by the following example, with */
+/* n = 7, ilo = 2 and ihi = 6: */
+
+/* on entry, on exit, */
+
+/* ( a a a a a a a ) ( a a h h h h a ) */
+/* ( a a a a a a ) ( a h h h h a ) */
+/* ( a a a a a a ) ( h h h h h h ) */
+/* ( a a a a a a ) ( v2 h h h h h ) */
+/* ( a a a a a a ) ( v2 v3 h h h h ) */
+/* ( a a a a a a ) ( v2 v3 v4 h h h ) */
+/* ( a ) ( a ) */
+
+/* where a denotes an element of the original matrix A, h denotes a */
+/* modified element of the upper Hessenberg matrix H, and vi denotes an */
+/* element of the vector defining H(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*ilo < 1 || *ilo > max(1,*n)) {
+ *info = -2;
+ } else if (*ihi < min(*ilo,*n) || *ihi > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGEHD2", &i__1);
+ return 0;
+ }
+
+ i__1 = *ihi - 1;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+
+/* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) */
+
+ i__2 = i__ + 1 + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *ihi - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ zlarfg_(&i__2, &alpha, &a[min(i__3, *n)+ i__ * a_dim1], &c__1, &tau[
+ i__]);
+ i__2 = i__ + 1 + i__ * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+
+/* Apply H(i) to A(1:ihi,i+1:ihi) from the right */
+
+ i__2 = *ihi - i__;
+ zlarf_("Right", ihi, &i__2, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
+ i__], &a[(i__ + 1) * a_dim1 + 1], lda, &work[1]);
+
+/* Apply H(i)' to A(i+1:ihi,i+1:n) from the left */
+
+ i__2 = *ihi - i__;
+ i__3 = *n - i__;
+ d_cnjg(&z__1, &tau[i__]);
+ zlarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &z__1,
+ &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1]);
+
+ i__2 = i__ + 1 + i__ * a_dim1;
+ a[i__2].r = alpha.r, a[i__2].i = alpha.i;
+/* L10: */
+ }
+
+ return 0;
+
+/* End of ZGEHD2 */
+
+} /* zgehd2_ */
diff --git a/SRC/zgehrd.c b/SRC/zgehrd.c
new file mode 100644
index 0000000..0a84ef6
--- /dev/null
+++ b/SRC/zgehrd.c
@@ -0,0 +1,353 @@
+/* zgehrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int zgehrd_(integer *n, integer *ilo, integer *ihi,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j;
+ doublecomplex t[4160] /* was [65][64] */;
+ integer ib;
+ doublecomplex ei;
+ integer nb, nh, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), ztrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *
+, doublecomplex *, integer *),
+ zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zgehd2_(integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *), zlahr2_(integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(
+ char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by */
+/* an unitary similarity transformation: Q' * A * Q = H . */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that A is already upper triangular in rows */
+/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
+/* set by a previous call to ZGEBAL; otherwise they should be */
+/* set to 1 and N respectively. See Further Details. */
+/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N general matrix to be reduced. */
+/* On exit, the upper triangle and the first subdiagonal of A */
+/* are overwritten with the upper Hessenberg matrix H, and the */
+/* elements below the first subdiagonal, with the array TAU, */
+/* represent the unitary matrix Q as a product of elementary */
+/* reflectors. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAU (output) COMPLEX*16 array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to */
+/* zero. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(1,N). */
+/* For optimum performance LWORK >= N*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of (ihi-ilo) elementary */
+/* reflectors */
+
+/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */
+/* exit in A(i+2:ihi,i), and tau in TAU(i). */
+
+/* The contents of A are illustrated by the following example, with */
+/* n = 7, ilo = 2 and ihi = 6: */
+
+/* on entry, on exit, */
+
+/* ( a a a a a a a ) ( a a h h h h a ) */
+/* ( a a a a a a ) ( a h h h h a ) */
+/* ( a a a a a a ) ( h h h h h h ) */
+/* ( a a a a a a ) ( v2 h h h h h ) */
+/* ( a a a a a a ) ( v2 v3 h h h h ) */
+/* ( a a a a a a ) ( v2 v3 v4 h h h ) */
+/* ( a ) ( a ) */
+
+/* where a denotes an element of the original matrix A, h denotes a */
+/* modified element of the upper Hessenberg matrix H, and vi denotes an */
+/* element of the vector defining H(i). */
+
+/* This file is a slight modification of LAPACK-3.0's ZGEHRD */
+/* subroutine incorporating improvements proposed by Quintana-Orti and */
+/* Van de Geijn (2005). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+/* Computing MIN */
+ i__1 = 64, i__2 = ilaenv_(&c__1, "ZGEHRD", " ", n, ilo, ihi, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = *n * nb;
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ lquery = *lwork == -1;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*ilo < 1 || *ilo > max(1,*n)) {
+ *info = -2;
+ } else if (*ihi < min(*ilo,*n) || *ihi > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGEHRD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero */
+
+ i__1 = *ilo - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ tau[i__2].r = 0., tau[i__2].i = 0.;
+/* L10: */
+ }
+ i__1 = *n - 1;
+ for (i__ = max(1,*ihi); i__ <= i__1; ++i__) {
+ i__2 = i__;
+ tau[i__2].r = 0., tau[i__2].i = 0.;
+/* L20: */
+ }
+
+/* Quick return if possible */
+
+ nh = *ihi - *ilo + 1;
+ if (nh <= 1) {
+ work[1].r = 1., work[1].i = 0.;
+ return 0;
+ }
+
+/* Determine the block size */
+
+/* Computing MIN */
+ i__1 = 64, i__2 = ilaenv_(&c__1, "ZGEHRD", " ", n, ilo, ihi, &c_n1);
+ nb = min(i__1,i__2);
+ nbmin = 2;
+ iws = 1;
+ if (nb > 1 && nb < nh) {
+
+/* Determine when to cross over from blocked to unblocked code */
+/* (last block is always handled by unblocked code) */
+
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__3, "ZGEHRD", " ", n, ilo, ihi, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < nh) {
+
+/* Determine if workspace is large enough for blocked code */
+
+ iws = *n * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: determine the */
+/* minimum value of NB, and reduce NB or force use of */
+/* unblocked code */
+
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "ZGEHRD", " ", n, ilo, ihi, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ if (*lwork >= *n * nbmin) {
+ nb = *lwork / *n;
+ } else {
+ nb = 1;
+ }
+ }
+ }
+ }
+ ldwork = *n;
+
+ if (nb < nbmin || nb >= nh) {
+
+/* Use unblocked code below */
+
+ i__ = *ilo;
+
+ } else {
+
+/* Use blocked code */
+
+ i__1 = *ihi - 1 - nx;
+ i__2 = nb;
+ for (i__ = *ilo; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *ihi - i__;
+ ib = min(i__3,i__4);
+
+/* Reduce columns i:i+ib-1 to Hessenberg form, returning the */
+/* matrices V and T of the block reflector H = I - V*T*V' */
+/* which performs the reduction, and also the matrix Y = A*V*T */
+
+ zlahr2_(ihi, &i__, &ib, &a[i__ * a_dim1 + 1], lda, &tau[i__], t, &
+ c__65, &work[1], &ldwork);
+
+/* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the */
+/* right, computing A := A - Y * V'. V(i+ib,ib-1) must be set */
+/* to 1 */
+
+ i__3 = i__ + ib + (i__ + ib - 1) * a_dim1;
+ ei.r = a[i__3].r, ei.i = a[i__3].i;
+ i__3 = i__ + ib + (i__ + ib - 1) * a_dim1;
+ a[i__3].r = 1., a[i__3].i = 0.;
+ i__3 = *ihi - i__ - ib + 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "Conjugate transpose", ihi, &i__3, &ib, &
+ z__1, &work[1], &ldwork, &a[i__ + ib + i__ * a_dim1], lda,
+ &c_b2, &a[(i__ + ib) * a_dim1 + 1], lda);
+ i__3 = i__ + ib + (i__ + ib - 1) * a_dim1;
+ a[i__3].r = ei.r, a[i__3].i = ei.i;
+
+/* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the */
+/* right */
+
+ i__3 = ib - 1;
+ ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &i__, &
+ i__3, &c_b2, &a[i__ + 1 + i__ * a_dim1], lda, &work[1], &
+ ldwork);
+ i__3 = ib - 2;
+ for (j = 0; j <= i__3; ++j) {
+ z__1.r = -1., z__1.i = -0.;
+ zaxpy_(&i__, &z__1, &work[ldwork * j + 1], &c__1, &a[(i__ + j
+ + 1) * a_dim1 + 1], &c__1);
+/* L30: */
+ }
+
+/* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the */
+/* left */
+
+ i__3 = *ihi - i__;
+ i__4 = *n - i__ - ib + 1;
+ zlarfb_("Left", "Conjugate transpose", "Forward", "Columnwise", &
+ i__3, &i__4, &ib, &a[i__ + 1 + i__ * a_dim1], lda, t, &
+ c__65, &a[i__ + 1 + (i__ + ib) * a_dim1], lda, &work[1], &
+ ldwork);
+/* L40: */
+ }
+ }
+
+/* Use unblocked code to reduce the rest of the matrix */
+
+ zgehd2_(n, &i__, ihi, &a[a_offset], lda, &tau[1], &work[1], &iinfo);
+ work[1].r = (doublereal) iws, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZGEHRD */
+
+} /* zgehrd_ */
diff --git a/SRC/zgelq2.c b/SRC/zgelq2.c
new file mode 100644
index 0000000..30df244
--- /dev/null
+++ b/SRC/zgelq2.c
@@ -0,0 +1,165 @@
+/* zgelq2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zgelq2_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *tau, doublecomplex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, k;
+ doublecomplex alpha;
+ extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *), xerbla_(char *, integer *), zlacgv_(integer *, doublecomplex *, integer *), zlarfp_(
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGELQ2 computes an LQ factorization of a complex m by n matrix A: */
+/* A = L * Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the m by n matrix A. */
+/* On exit, the elements on and below the diagonal of the array */
+/* contain the m by min(m,n) lower trapezoidal matrix L (L is */
+/* lower triangular if m <= n); the elements above the diagonal, */
+/* with the array TAU, represent the unitary matrix Q as a */
+/* product of elementary reflectors (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (M) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(k)' . . . H(2)' H(1)', where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in */
+/* A(i,i+1:n), and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGELQ2", &i__1);
+ return 0;
+ }
+
+ k = min(*m,*n);
+
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Generate elementary reflector H(i) to annihilate A(i,i+1:n) */
+
+ i__2 = *n - i__ + 1;
+ zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
+ i__2 = i__ + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *n - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ zlarfp_(&i__2, &alpha, &a[i__ + min(i__3, *n)* a_dim1], lda, &tau[i__]
+);
+ if (i__ < *m) {
+
+/* Apply H(i) to A(i+1:m,i:n) from the right */
+
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+ i__2 = *m - i__;
+ i__3 = *n - i__ + 1;
+ zlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[
+ i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]);
+ }
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = alpha.r, a[i__2].i = alpha.i;
+ i__2 = *n - i__ + 1;
+ zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
+/* L10: */
+ }
+ return 0;
+
+/* End of ZGELQ2 */
+
+} /* zgelq2_ */
diff --git a/SRC/zgelqf.c b/SRC/zgelqf.c
new file mode 100644
index 0000000..36c16da
--- /dev/null
+++ b/SRC/zgelqf.c
@@ -0,0 +1,257 @@
+/* zgelqf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int zgelqf_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, k, ib, nb, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int zgelq2_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *), xerbla_(
+ char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ integer ldwork;
+ extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGELQF computes an LQ factorization of a complex M-by-N matrix A: */
+/* A = L * Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the elements on and below the diagonal of the array */
+/* contain the m-by-min(m,n) lower trapezoidal matrix L (L is */
+/* lower triangular if m <= n); the elements above the diagonal, */
+/* with the array TAU, represent the unitary matrix Q as a */
+/* product of elementary reflectors (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M). */
+/* For optimum performance LWORK >= M*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(k)' . . . H(2)' H(1)', where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in */
+/* A(i,i+1:n), and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb = ilaenv_(&c__1, "ZGELQF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = *m * nb;
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ } else if (*lwork < max(1,*m) && ! lquery) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGELQF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ k = min(*m,*n);
+ if (k == 0) {
+ work[1].r = 1., work[1].i = 0.;
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *m;
+ if (nb > 1 && nb < k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "ZGELQF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *m;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "ZGELQF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < k && nx < k) {
+
+/* Use blocked code initially */
+
+ i__1 = k - nx;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = k - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Compute the LQ factorization of the current block */
+/* A(i:i+ib-1,i:n) */
+
+ i__3 = *n - i__ + 1;
+ zgelq2_(&ib, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
+ 1], &iinfo);
+ if (i__ + ib <= *m) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__3 = *n - i__ + 1;
+ zlarft_("Forward", "Rowwise", &i__3, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H to A(i+ib:m,i:n) from the right */
+
+ i__3 = *m - i__ - ib + 1;
+ i__4 = *n - i__ + 1;
+ zlarfb_("Right", "No transpose", "Forward", "Rowwise", &i__3,
+ &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
+ ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib +
+ 1], &ldwork);
+ }
+/* L10: */
+ }
+ } else {
+ i__ = 1;
+ }
+
+/* Use unblocked code to factor the last or only block. */
+
+ if (i__ <= k) {
+ i__2 = *m - i__ + 1;
+ i__1 = *n - i__ + 1;
+ zgelq2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
+, &iinfo);
+ }
+
+ work[1].r = (doublereal) iws, work[1].i = 0.;
+ return 0;
+
+/* End of ZGELQF */
+
+} /* zgelqf_ */
diff --git a/SRC/zgels.c b/SRC/zgels.c
new file mode 100644
index 0000000..dac9e32
--- /dev/null
+++ b/SRC/zgels.c
@@ -0,0 +1,520 @@
+/* zgels.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+
+/* Subroutine */ int zgels_(char *trans, integer *m, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, j, nb, mn;
+ doublereal anrm, bnrm;
+ integer brow;
+ logical tpsd;
+ integer iascl, ibscl;
+ extern logical lsame_(char *, char *);
+ integer wsize;
+ doublereal rwork[1];
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer scllen;
+ doublereal bignum;
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zgelqf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *
+), zlascl_(char *, integer *, integer *, doublereal *, doublereal
+ *, integer *, integer *, doublecomplex *, integer *, integer *), zgeqrf_(integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *), zlaset_(
+ char *, integer *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *);
+ doublereal smlnum;
+ logical lquery;
+ extern /* Subroutine */ int zunmlq_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *), zunmqr_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *), ztrtrs_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGELS solves overdetermined or underdetermined complex linear systems */
+/* involving an M-by-N matrix A, or its conjugate-transpose, using a QR */
+/* or LQ factorization of A. It is assumed that A has full rank. */
+
+/* The following options are provided: */
+
+/* 1. If TRANS = 'N' and m >= n: find the least squares solution of */
+/* an overdetermined system, i.e., solve the least squares problem */
+/* minimize || B - A*X ||. */
+
+/* 2. If TRANS = 'N' and m < n: find the minimum norm solution of */
+/* an underdetermined system A * X = B. */
+
+/* 3. If TRANS = 'C' and m >= n: find the minimum norm solution of */
+/* an undetermined system A**H * X = B. */
+
+/* 4. If TRANS = 'C' and m < n: find the least squares solution of */
+/* an overdetermined system, i.e., solve the least squares problem */
+/* minimize || B - A**H * X ||. */
+
+/* Several right hand side vectors b and solution vectors x can be */
+/* handled in a single call; they are stored as the columns of the */
+/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
+/* matrix X. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': the linear system involves A; */
+/* = 'C': the linear system involves A**H. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of */
+/* columns of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* if M >= N, A is overwritten by details of its QR */
+/* factorization as returned by ZGEQRF; */
+/* if M < N, A is overwritten by details of its LQ */
+/* factorization as returned by ZGELQF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the matrix B of right hand side vectors, stored */
+/* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS */
+/* if TRANS = 'C'. */
+/* On exit, if INFO = 0, B is overwritten by the solution */
+/* vectors, stored columnwise: */
+/* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least */
+/* squares solution vectors; the residual sum of squares for the */
+/* solution in each column is given by the sum of squares of the */
+/* modulus of elements N+1 to M in that column; */
+/* if TRANS = 'N' and m < n, rows 1 to N of B contain the */
+/* minimum norm solution vectors; */
+/* if TRANS = 'C' and m >= n, rows 1 to M of B contain the */
+/* minimum norm solution vectors; */
+/* if TRANS = 'C' and m < n, rows 1 to M of B contain the */
+/* least squares solution vectors; the residual sum of squares */
+/* for the solution in each column is given by the sum of */
+/* squares of the modulus of elements M+1 to N in that column. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= MAX(1,M,N). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* LWORK >= max( 1, MN + max( MN, NRHS ) ). */
+/* For optimal performance, */
+/* LWORK >= max( 1, MN + max( MN, NRHS )*NB ). */
+/* where MN = min(M,N) and NB is the optimum block size. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element of the */
+/* triangular factor of A is zero, so that A does not have */
+/* full rank; the least squares solution could not be */
+/* computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ mn = min(*m,*n);
+ lquery = *lwork == -1;
+ if (! (lsame_(trans, "N") || lsame_(trans, "C"))) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -6;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ if (*ldb < max(i__1,*n)) {
+ *info = -8;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = 1, i__2 = mn + max(mn,*nrhs);
+ if (*lwork < max(i__1,i__2) && ! lquery) {
+ *info = -10;
+ }
+ }
+ }
+
+/* Figure out optimal block size */
+
+ if (*info == 0 || *info == -10) {
+
+ tpsd = TRUE_;
+ if (lsame_(trans, "N")) {
+ tpsd = FALSE_;
+ }
+
+ if (*m >= *n) {
+ nb = ilaenv_(&c__1, "ZGEQRF", " ", m, n, &c_n1, &c_n1);
+ if (tpsd) {
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMQR", "LN", m, nrhs, n, &
+ c_n1);
+ nb = max(i__1,i__2);
+ } else {
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMQR", "LC", m, nrhs, n, &
+ c_n1);
+ nb = max(i__1,i__2);
+ }
+ } else {
+ nb = ilaenv_(&c__1, "ZGELQF", " ", m, n, &c_n1, &c_n1);
+ if (tpsd) {
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMLQ", "LC", n, nrhs, m, &
+ c_n1);
+ nb = max(i__1,i__2);
+ } else {
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMLQ", "LN", n, nrhs, m, &
+ c_n1);
+ nb = max(i__1,i__2);
+ }
+ }
+
+/* Computing MAX */
+ i__1 = 1, i__2 = mn + max(mn,*nrhs) * nb;
+ wsize = max(i__1,i__2);
+ d__1 = (doublereal) wsize;
+ work[1].r = d__1, work[1].i = 0.;
+
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGELS ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+/* Computing MIN */
+ i__1 = min(*m,*n);
+ if (min(i__1,*nrhs) == 0) {
+ i__1 = max(*m,*n);
+ zlaset_("Full", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ smlnum = dlamch_("S") / dlamch_("P");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Scale A, B if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = zlange_("M", m, n, &a[a_offset], lda, rwork);
+ iascl = 0;
+ if (anrm > 0. && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 2;
+ } else if (anrm == 0.) {
+
+/* Matrix all zero. Return zero solution. */
+
+ i__1 = max(*m,*n);
+ zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+ goto L50;
+ }
+
+ brow = *m;
+ if (tpsd) {
+ brow = *n;
+ }
+ bnrm = zlange_("M", &brow, nrhs, &b[b_offset], ldb, rwork);
+ ibscl = 0;
+ if (bnrm > 0. && bnrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ zlascl_("G", &c__0, &c__0, &bnrm, &smlnum, &brow, nrhs, &b[b_offset],
+ ldb, info);
+ ibscl = 1;
+ } else if (bnrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ zlascl_("G", &c__0, &c__0, &bnrm, &bignum, &brow, nrhs, &b[b_offset],
+ ldb, info);
+ ibscl = 2;
+ }
+
+ if (*m >= *n) {
+
+/* compute QR factorization of A */
+
+ i__1 = *lwork - mn;
+ zgeqrf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
+ ;
+
+/* workspace at least N, optimally N*NB */
+
+ if (! tpsd) {
+
+/* Least-Squares Problem min || A * X - B || */
+
+/* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */
+
+ i__1 = *lwork - mn;
+ zunmqr_("Left", "Conjugate transpose", m, nrhs, n, &a[a_offset],
+ lda, &work[1], &b[b_offset], ldb, &work[mn + 1], &i__1,
+ info);
+
+/* workspace at least NRHS, optimally NRHS*NB */
+
+/* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) */
+
+ ztrtrs_("Upper", "No transpose", "Non-unit", n, nrhs, &a[a_offset]
+, lda, &b[b_offset], ldb, info);
+
+ if (*info > 0) {
+ return 0;
+ }
+
+ scllen = *n;
+
+ } else {
+
+/* Overdetermined system of equations A' * X = B */
+
+/* B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS) */
+
+ ztrtrs_("Upper", "Conjugate transpose", "Non-unit", n, nrhs, &a[
+ a_offset], lda, &b[b_offset], ldb, info);
+
+ if (*info > 0) {
+ return 0;
+ }
+
+/* B(N+1:M,1:NRHS) = ZERO */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = *n + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0., b[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) */
+
+ i__1 = *lwork - mn;
+ zunmqr_("Left", "No transpose", m, nrhs, n, &a[a_offset], lda, &
+ work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
+
+/* workspace at least NRHS, optimally NRHS*NB */
+
+ scllen = *m;
+
+ }
+
+ } else {
+
+/* Compute LQ factorization of A */
+
+ i__1 = *lwork - mn;
+ zgelqf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
+ ;
+
+/* workspace at least M, optimally M*NB. */
+
+ if (! tpsd) {
+
+/* underdetermined system of equations A * X = B */
+
+/* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) */
+
+ ztrtrs_("Lower", "No transpose", "Non-unit", m, nrhs, &a[a_offset]
+, lda, &b[b_offset], ldb, info);
+
+ if (*info > 0) {
+ return 0;
+ }
+
+/* B(M+1:N,1:NRHS) = 0 */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = *m + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0., b[i__3].i = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS) */
+
+ i__1 = *lwork - mn;
+ zunmlq_("Left", "Conjugate transpose", n, nrhs, m, &a[a_offset],
+ lda, &work[1], &b[b_offset], ldb, &work[mn + 1], &i__1,
+ info);
+
+/* workspace at least NRHS, optimally NRHS*NB */
+
+ scllen = *n;
+
+ } else {
+
+/* overdetermined system min || A' * X - B || */
+
+/* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) */
+
+ i__1 = *lwork - mn;
+ zunmlq_("Left", "No transpose", n, nrhs, m, &a[a_offset], lda, &
+ work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
+
+/* workspace at least NRHS, optimally NRHS*NB */
+
+/* B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS) */
+
+ ztrtrs_("Lower", "Conjugate transpose", "Non-unit", m, nrhs, &a[
+ a_offset], lda, &b[b_offset], ldb, info);
+
+ if (*info > 0) {
+ return 0;
+ }
+
+ scllen = *m;
+
+ }
+
+ }
+
+/* Undo scaling */
+
+ if (iascl == 1) {
+ zlascl_("G", &c__0, &c__0, &anrm, &smlnum, &scllen, nrhs, &b[b_offset]
+, ldb, info);
+ } else if (iascl == 2) {
+ zlascl_("G", &c__0, &c__0, &anrm, &bignum, &scllen, nrhs, &b[b_offset]
+, ldb, info);
+ }
+ if (ibscl == 1) {
+ zlascl_("G", &c__0, &c__0, &smlnum, &bnrm, &scllen, nrhs, &b[b_offset]
+, ldb, info);
+ } else if (ibscl == 2) {
+ zlascl_("G", &c__0, &c__0, &bignum, &bnrm, &scllen, nrhs, &b[b_offset]
+, ldb, info);
+ }
+
+L50:
+ d__1 = (doublereal) wsize;
+ work[1].r = d__1, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZGELS */
+
+} /* zgels_ */
diff --git a/SRC/zgelsd.c b/SRC/zgelsd.c
new file mode 100644
index 0000000..9b35320
--- /dev/null
+++ b/SRC/zgelsd.c
@@ -0,0 +1,724 @@
+/* zgelsd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static integer c__9 = 9;
+static integer c__0 = 0;
+static integer c__6 = 6;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static doublereal c_b80 = 0.;
+
+/* Subroutine */ int zgelsd_(integer *m, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublereal *s, doublereal *rcond, integer *rank, doublecomplex *work,
+ integer *lwork, doublereal *rwork, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ double log(doublereal);
+
+ /* Local variables */
+ integer ie, il, mm;
+ doublereal eps, anrm, bnrm;
+ integer itau, nlvl, iascl, ibscl;
+ doublereal sfmin;
+ integer minmn, maxmn, itaup, itauq, mnthr, nwork;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), dlaset_(char *, integer *, integer
+ *, doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *), zgebrd_(integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ doublereal bignum;
+ extern /* Subroutine */ int zgelqf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *
+), zlalsd_(char *, integer *, integer *, integer *, doublereal *,
+ doublereal *, doublecomplex *, integer *, doublereal *, integer *,
+ doublecomplex *, doublereal *, integer *, integer *),
+ zlascl_(char *, integer *, integer *, doublereal *, doublereal *,
+ integer *, integer *, doublecomplex *, integer *, integer *), zgeqrf_(integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *);
+ integer ldwork;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *);
+ integer liwork, minwrk, maxwrk;
+ doublereal smlnum;
+ extern /* Subroutine */ int zunmbr_(char *, char *, char *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+);
+ integer lrwork;
+ logical lquery;
+ integer nrwork, smlsiz;
+ extern /* Subroutine */ int zunmlq_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *), zunmqr_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGELSD computes the minimum-norm solution to a real linear least */
+/* squares problem: */
+/* minimize 2-norm(| b - A*x |) */
+/* using the singular value decomposition (SVD) of A. A is an M-by-N */
+/* matrix which may be rank-deficient. */
+
+/* Several right hand side vectors b and solution vectors x can be */
+/* handled in a single call; they are stored as the columns of the */
+/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
+/* matrix X. */
+
+/* The problem is solved in three steps: */
+/* (1) Reduce the coefficient matrix A to bidiagonal form with */
+/* Householder tranformations, reducing the original problem */
+/* into a "bidiagonal least squares problem" (BLS) */
+/* (2) Solve the BLS using a divide and conquer approach. */
+/* (3) Apply back all the Householder tranformations to solve */
+/* the original least squares problem. */
+
+/* The effective rank of A is determined by treating as zero those */
+/* singular values which are less than RCOND times the largest singular */
+/* value. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A has been destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the M-by-NRHS right hand side matrix B. */
+/* On exit, B is overwritten by the N-by-NRHS solution matrix X. */
+/* If m >= n and RANK = n, the residual sum-of-squares for */
+/* the solution in the i-th column is given by the sum of */
+/* squares of the modulus of elements n+1:m in that column. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M,N). */
+
+/* S (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The singular values of A in decreasing order. */
+/* The condition number of A in the 2-norm = S(1)/S(min(m,n)). */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* RCOND is used to determine the effective rank of A. */
+/* Singular values S(i) <= RCOND*S(1) are treated as zero. */
+/* If RCOND < 0, machine precision is used instead. */
+
+/* RANK (output) INTEGER */
+/* The effective rank of A, i.e., the number of singular values */
+/* which are greater than RCOND*S(1). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK must be at least 1. */
+/* The exact minimum amount of workspace needed depends on M, */
+/* N and NRHS. As long as LWORK is at least */
+/* 2*N + N*NRHS */
+/* if M is greater than or equal to N or */
+/* 2*M + M*NRHS */
+/* if M is less than N, the code will execute correctly. */
+/* For good performance, LWORK should generally be larger. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal size of the array WORK and the */
+/* minimum sizes of the arrays RWORK and IWORK, and returns */
+/* these values as the first entries of the WORK, RWORK and */
+/* IWORK arrays, and no error message related to LWORK is issued */
+/* by XERBLA. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LRWORK)) */
+/* LRWORK >= */
+/* 10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS + */
+/* (SMLSIZ+1)**2 */
+/* if M is greater than or equal to N or */
+/* 10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS + */
+/* (SMLSIZ+1)**2 */
+/* if M is less than N, the code will execute correctly. */
+/* SMLSIZ is returned by ILAENV and is equal to the maximum */
+/* size of the subproblems at the bottom of the computation */
+/* tree (usually about 25), and */
+/* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) */
+/* On exit, if INFO = 0, RWORK(1) returns the minimum LRWORK. */
+
+/* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN), */
+/* where MINMN = MIN( M,N ). */
+/* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: the algorithm for computing the SVD failed to converge; */
+/* if INFO = i, i off-diagonal elements of an intermediate */
+/* bidiagonal form did not converge to zero. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */
+/* California at Berkeley, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --s;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ minmn = min(*m,*n);
+ maxmn = max(*m,*n);
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,maxmn)) {
+ *info = -7;
+ }
+
+/* Compute workspace. */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ if (*info == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ liwork = 1;
+ lrwork = 1;
+ if (minmn > 0) {
+ smlsiz = ilaenv_(&c__9, "ZGELSD", " ", &c__0, &c__0, &c__0, &c__0);
+ mnthr = ilaenv_(&c__6, "ZGELSD", " ", m, n, nrhs, &c_n1);
+/* Computing MAX */
+ i__1 = (integer) (log((doublereal) minmn / (doublereal) (smlsiz +
+ 1)) / log(2.)) + 1;
+ nlvl = max(i__1,0);
+ liwork = minmn * 3 * nlvl + minmn * 11;
+ mm = *m;
+ if (*m >= *n && *m >= mnthr) {
+
+/* Path 1a - overdetermined, with many more rows than */
+/* columns. */
+
+ mm = *n;
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n,
+ &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *nrhs * ilaenv_(&c__1, "ZUNMQR", "LC",
+ m, nrhs, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ }
+ if (*m >= *n) {
+
+/* Path 1 - overdetermined or exactly determined. */
+
+/* Computing 2nd power */
+ i__1 = smlsiz + 1;
+ lrwork = *n * 10 + (*n << 1) * smlsiz + (*n << 3) * nlvl +
+ smlsiz * 3 * *nrhs + i__1 * i__1;
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + (mm + *n) * ilaenv_(&c__1,
+ "ZGEBRD", " ", &mm, n, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *nrhs * ilaenv_(&c__1,
+ "ZUNMBR", "QLC", &mm, nrhs, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
+ "ZUNMBR", "PLN", n, nrhs, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *n * *nrhs;
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = (*n << 1) + mm, i__2 = (*n << 1) + *n * *nrhs;
+ minwrk = max(i__1,i__2);
+ }
+ if (*n > *m) {
+/* Computing 2nd power */
+ i__1 = smlsiz + 1;
+ lrwork = *m * 10 + (*m << 1) * smlsiz + (*m << 3) * nlvl +
+ smlsiz * 3 * *nrhs + i__1 * i__1;
+ if (*n >= mnthr) {
+
+/* Path 2a - underdetermined, with many more columns */
+/* than rows. */
+
+ maxwrk = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) *
+ ilaenv_(&c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs *
+ ilaenv_(&c__1, "ZUNMBR", "QLC", m, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) *
+ ilaenv_(&c__1, "ZUNMLQ", "LC", n, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+ if (*nrhs > 1) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs;
+ maxwrk = max(i__1,i__2);
+ } else {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 1);
+ maxwrk = max(i__1,i__2);
+ }
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *m * *nrhs;
+ maxwrk = max(i__1,i__2);
+/* XXX: Ensure the Path 2a case below is triggered. The workspace */
+/* calculation should use queries for all routines eventually. */
+/* Computing MAX */
+/* Computing MAX */
+ i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4),
+ i__3 = max(i__3,*nrhs), i__4 = *n - *m * 3;
+ i__1 = maxwrk, i__2 = (*m << 2) + *m * *m + max(i__3,i__4)
+ ;
+ maxwrk = max(i__1,i__2);
+ } else {
+
+/* Path 2 - underdetermined. */
+
+ maxwrk = (*m << 1) + (*n + *m) * ilaenv_(&c__1, "ZGEBRD",
+ " ", m, n, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *nrhs * ilaenv_(&c__1,
+ "ZUNMBR", "QLC", m, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNMBR", "PLN", n, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * *nrhs;
+ maxwrk = max(i__1,i__2);
+ }
+/* Computing MAX */
+ i__1 = (*m << 1) + *n, i__2 = (*m << 1) + *m * *nrhs;
+ minwrk = max(i__1,i__2);
+ }
+ }
+ minwrk = min(minwrk,maxwrk);
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+ iwork[1] = liwork;
+ rwork[1] = (doublereal) lrwork;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGELSD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0) {
+ *rank = 0;
+ return 0;
+ }
+
+/* Get machine parameters. */
+
+ eps = dlamch_("P");
+ sfmin = dlamch_("S");
+ smlnum = sfmin / eps;
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Scale A if max entry outside range [SMLNUM,BIGNUM]. */
+
+ anrm = zlange_("M", m, n, &a[a_offset], lda, &rwork[1]);
+ iascl = 0;
+ if (anrm > 0. && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM. */
+
+ zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 2;
+ } else if (anrm == 0.) {
+
+/* Matrix all zero. Return zero solution. */
+
+ i__1 = max(*m,*n);
+ zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+ dlaset_("F", &minmn, &c__1, &c_b80, &c_b80, &s[1], &c__1);
+ *rank = 0;
+ goto L10;
+ }
+
+/* Scale B if max entry outside range [SMLNUM,BIGNUM]. */
+
+ bnrm = zlange_("M", m, nrhs, &b[b_offset], ldb, &rwork[1]);
+ ibscl = 0;
+ if (bnrm > 0. && bnrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM. */
+
+ zlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 1;
+ } else if (bnrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM. */
+
+ zlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 2;
+ }
+
+/* If M < N make sure B(M+1:N,:) = 0 */
+
+ if (*m < *n) {
+ i__1 = *n - *m;
+ zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[*m + 1 + b_dim1], ldb);
+ }
+
+/* Overdetermined case. */
+
+ if (*m >= *n) {
+
+/* Path 1 - overdetermined or exactly determined. */
+
+ mm = *m;
+ if (*m >= mnthr) {
+
+/* Path 1a - overdetermined, with many more rows than columns */
+
+ mm = *n;
+ itau = 1;
+ nwork = itau + *n;
+
+/* Compute A=Q*R. */
+/* (RWorkspace: need N) */
+/* (CWorkspace: need N, prefer N*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1,
+ info);
+
+/* Multiply B by transpose(Q). */
+/* (RWorkspace: need N) */
+/* (CWorkspace: need NRHS, prefer NRHS*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ zunmqr_("L", "C", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[
+ b_offset], ldb, &work[nwork], &i__1, info);
+
+/* Zero out below R. */
+
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &a[a_dim1 + 2], lda);
+ }
+ }
+
+ itauq = 1;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+ ie = 1;
+ nrwork = ie + *n;
+
+/* Bidiagonalize R in A. */
+/* (RWorkspace: need N) */
+/* (CWorkspace: need 2*N+MM, prefer 2*N+(MM+N)*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ zgebrd_(&mm, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq], &
+ work[itaup], &work[nwork], &i__1, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors of R. */
+/* (CWorkspace: need 2*N+NRHS, prefer 2*N+NRHS*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ zunmbr_("Q", "L", "C", &mm, nrhs, n, &a[a_offset], lda, &work[itauq],
+ &b[b_offset], ldb, &work[nwork], &i__1, info);
+
+/* Solve the bidiagonal least squares problem. */
+
+ zlalsd_("U", &smlsiz, n, nrhs, &s[1], &rwork[ie], &b[b_offset], ldb,
+ rcond, rank, &work[nwork], &rwork[nrwork], &iwork[1], info);
+ if (*info != 0) {
+ goto L10;
+ }
+
+/* Multiply B by right bidiagonalizing vectors of R. */
+
+ i__1 = *lwork - nwork + 1;
+ zunmbr_("P", "L", "N", n, nrhs, n, &a[a_offset], lda, &work[itaup], &
+ b[b_offset], ldb, &work[nwork], &i__1, info);
+
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = *m, i__2 = (*m << 1) - 4, i__1 = max(i__1,i__2), i__1 = max(
+ i__1,*nrhs), i__2 = *n - *m * 3;
+ if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__1,i__2)) {
+
+/* Path 2a - underdetermined, with many more columns than rows */
+/* and sufficient workspace for an efficient algorithm. */
+
+ ldwork = *m;
+/* Computing MAX */
+/* Computing MAX */
+ i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 =
+ max(i__3,*nrhs), i__4 = *n - *m * 3;
+ i__1 = (*m << 2) + *m * *lda + max(i__3,i__4), i__2 = *m * *lda +
+ *m + *m * *nrhs;
+ if (*lwork >= max(i__1,i__2)) {
+ ldwork = *lda;
+ }
+ itau = 1;
+ nwork = *m + 1;
+
+/* Compute A=L*Q. */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1,
+ info);
+ il = nwork;
+
+/* Copy L to WORK(IL), zeroing out above its diagonal. */
+
+ zlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork);
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ zlaset_("U", &i__1, &i__2, &c_b1, &c_b1, &work[il + ldwork], &
+ ldwork);
+ itauq = il + ldwork * *m;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+ ie = 1;
+ nrwork = ie + *m;
+
+/* Bidiagonalize L in WORK(IL). */
+/* (RWorkspace: need M) */
+/* (CWorkspace: need M*M+4*M, prefer M*M+4*M+2*M*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ zgebrd_(m, m, &work[il], &ldwork, &s[1], &rwork[ie], &work[itauq],
+ &work[itaup], &work[nwork], &i__1, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors of L. */
+/* (CWorkspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ zunmbr_("Q", "L", "C", m, nrhs, m, &work[il], &ldwork, &work[
+ itauq], &b[b_offset], ldb, &work[nwork], &i__1, info);
+
+/* Solve the bidiagonal least squares problem. */
+
+ zlalsd_("U", &smlsiz, m, nrhs, &s[1], &rwork[ie], &b[b_offset],
+ ldb, rcond, rank, &work[nwork], &rwork[nrwork], &iwork[1],
+ info);
+ if (*info != 0) {
+ goto L10;
+ }
+
+/* Multiply B by right bidiagonalizing vectors of L. */
+
+ i__1 = *lwork - nwork + 1;
+ zunmbr_("P", "L", "N", m, nrhs, m, &work[il], &ldwork, &work[
+ itaup], &b[b_offset], ldb, &work[nwork], &i__1, info);
+
+/* Zero out below first M rows of B. */
+
+ i__1 = *n - *m;
+ zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[*m + 1 + b_dim1], ldb);
+ nwork = itau + *m;
+
+/* Multiply transpose(Q) by B. */
+/* (CWorkspace: need NRHS, prefer NRHS*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ zunmlq_("L", "C", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[
+ b_offset], ldb, &work[nwork], &i__1, info);
+
+ } else {
+
+/* Path 2 - remaining underdetermined cases. */
+
+ itauq = 1;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+ ie = 1;
+ nrwork = ie + *m;
+
+/* Bidiagonalize A. */
+/* (RWorkspace: need M) */
+/* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ zgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq],
+ &work[itaup], &work[nwork], &i__1, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors. */
+/* (CWorkspace: need 2*M+NRHS, prefer 2*M+NRHS*NB) */
+
+ i__1 = *lwork - nwork + 1;
+ zunmbr_("Q", "L", "C", m, nrhs, n, &a[a_offset], lda, &work[itauq]
+, &b[b_offset], ldb, &work[nwork], &i__1, info);
+
+/* Solve the bidiagonal least squares problem. */
+
+ zlalsd_("L", &smlsiz, m, nrhs, &s[1], &rwork[ie], &b[b_offset],
+ ldb, rcond, rank, &work[nwork], &rwork[nrwork], &iwork[1],
+ info);
+ if (*info != 0) {
+ goto L10;
+ }
+
+/* Multiply B by right bidiagonalizing vectors of A. */
+
+ i__1 = *lwork - nwork + 1;
+ zunmbr_("P", "L", "N", n, nrhs, m, &a[a_offset], lda, &work[itaup]
+, &b[b_offset], ldb, &work[nwork], &i__1, info);
+
+ }
+ }
+
+/* Undo scaling. */
+
+ if (iascl == 1) {
+ zlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
+ info);
+ dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, info);
+ } else if (iascl == 2) {
+ zlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
+ info);
+ dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, info);
+ }
+ if (ibscl == 1) {
+ zlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ } else if (ibscl == 2) {
+ zlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ }
+
+L10:
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+ iwork[1] = liwork;
+ rwork[1] = (doublereal) lrwork;
+ return 0;
+
+/* End of ZGELSD */
+
+} /* zgelsd_ */
diff --git a/SRC/zgelss.c b/SRC/zgelss.c
new file mode 100644
index 0000000..29caf0e
--- /dev/null
+++ b/SRC/zgelss.c
@@ -0,0 +1,828 @@
+/* zgelss.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__6 = 6;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__0 = 0;
+static doublereal c_b78 = 0.;
+
+/* Subroutine */ int zgelss_(integer *m, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublereal *s, doublereal *rcond, integer *rank, doublecomplex *work,
+ integer *lwork, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, bl, ie, il, mm;
+ doublereal eps, thr, anrm, bnrm;
+ integer itau;
+ doublecomplex vdum[1];
+ integer iascl, ibscl, chunk;
+ doublereal sfmin;
+ integer minmn;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer maxmn, itaup, itauq, mnthr;
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ integer iwork;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), dlaset_(char *, integer *, integer
+ *, doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *), zgebrd_(integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ doublereal bignum;
+ extern /* Subroutine */ int zgelqf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *
+), zlascl_(char *, integer *, integer *, doublereal *, doublereal
+ *, integer *, integer *, doublecomplex *, integer *, integer *), zgeqrf_(integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *), zdrscl_(
+ integer *, doublereal *, doublecomplex *, integer *);
+ integer ldwork;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *), zbdsqr_(
+ char *, integer *, integer *, integer *, integer *, doublereal *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, integer *);
+ integer minwrk, maxwrk;
+ extern /* Subroutine */ int zungbr_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+ doublereal smlnum;
+ integer irwork;
+ extern /* Subroutine */ int zunmbr_(char *, char *, char *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+);
+ logical lquery;
+ extern /* Subroutine */ int zunmlq_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *), zunmqr_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGELSS computes the minimum norm solution to a complex linear */
+/* least squares problem: */
+
+/* Minimize 2-norm(| b - A*x |). */
+
+/* using the singular value decomposition (SVD) of A. A is an M-by-N */
+/* matrix which may be rank-deficient. */
+
+/* Several right hand side vectors b and solution vectors x can be */
+/* handled in a single call; they are stored as the columns of the */
+/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix */
+/* X. */
+
+/* The effective rank of A is determined by treating as zero those */
+/* singular values which are less than RCOND times the largest singular */
+/* value. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the first min(m,n) rows of A are overwritten with */
+/* its right singular vectors, stored rowwise. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the M-by-NRHS right hand side matrix B. */
+/* On exit, B is overwritten by the N-by-NRHS solution matrix X. */
+/* If m >= n and RANK = n, the residual sum-of-squares for */
+/* the solution in the i-th column is given by the sum of */
+/* squares of the modulus of elements n+1:m in that column. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M,N). */
+
+/* S (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The singular values of A in decreasing order. */
+/* The condition number of A in the 2-norm = S(1)/S(min(m,n)). */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* RCOND is used to determine the effective rank of A. */
+/* Singular values S(i) <= RCOND*S(1) are treated as zero. */
+/* If RCOND < 0, machine precision is used instead. */
+
+/* RANK (output) INTEGER */
+/* The effective rank of A, i.e., the number of singular values */
+/* which are greater than RCOND*S(1). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= 1, and also: */
+/* LWORK >= 2*min(M,N) + max(M,N,NRHS) */
+/* For good performance, LWORK should generally be larger. */
+
+/* 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. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (5*min(M,N)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: the algorithm for computing the SVD failed to converge; */
+/* if INFO = i, i off-diagonal elements of an intermediate */
+/* bidiagonal form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --s;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ minmn = min(*m,*n);
+ maxmn = max(*m,*n);
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,maxmn)) {
+ *info = -7;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* CWorkspace refers to complex workspace, and RWorkspace refers */
+/* to real workspace. NB refers to the optimal block size for the */
+/* immediately following subroutine, as returned by ILAENV.) */
+
+ if (*info == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ if (minmn > 0) {
+ mm = *m;
+ mnthr = ilaenv_(&c__6, "ZGELSS", " ", m, n, nrhs, &c_n1);
+ if (*m >= *n && *m >= mnthr) {
+
+/* Path 1a - overdetermined, with many more rows than */
+/* columns */
+
+ mm = *n;
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "ZGEQRF",
+ " ", m, n, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "ZUNMQR",
+ "LC", m, nrhs, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ }
+ if (*m >= *n) {
+
+/* Path 1 - overdetermined or exactly determined */
+
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + (mm + *n) * ilaenv_(&c__1,
+ "ZGEBRD", " ", &mm, n, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *nrhs * ilaenv_(&c__1,
+ "ZUNMBR", "QLC", &mm, nrhs, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
+ "ZUNGBR", "P", n, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * *nrhs;
+ maxwrk = max(i__1,i__2);
+ minwrk = (*n << 1) + max(*nrhs,*m);
+ }
+ if (*n > *m) {
+ minwrk = (*m << 1) + max(*nrhs,*n);
+ if (*n >= mnthr) {
+
+/* Path 2a - underdetermined, with many more columns */
+/* than rows */
+
+ maxwrk = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * 3 + *m * *m + (*m << 1) *
+ ilaenv_(&c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * 3 + *m * *m + *nrhs * ilaenv_(&
+ c__1, "ZUNMBR", "QLC", m, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * 3 + *m * *m + (*m - 1) *
+ ilaenv_(&c__1, "ZUNGBR", "P", m, m, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+ if (*nrhs > 1) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs;
+ maxwrk = max(i__1,i__2);
+ } else {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m * *m + (*m << 1);
+ maxwrk = max(i__1,i__2);
+ }
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, "ZUNMLQ"
+, "LC", n, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+ } else {
+
+/* Path 2 - underdetermined */
+
+ maxwrk = (*m << 1) + (*n + *m) * ilaenv_(&c__1, "ZGEBRD",
+ " ", m, n, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *nrhs * ilaenv_(&c__1,
+ "ZUNMBR", "QLC", m, nrhs, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNGBR", "P", m, n, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * *nrhs;
+ maxwrk = max(i__1,i__2);
+ }
+ }
+ maxwrk = max(minwrk,maxwrk);
+ }
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGELSS", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ *rank = 0;
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ eps = dlamch_("P");
+ sfmin = dlamch_("S");
+ smlnum = sfmin / eps;
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = zlange_("M", m, n, &a[a_offset], lda, &rwork[1]);
+ iascl = 0;
+ if (anrm > 0. && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 2;
+ } else if (anrm == 0.) {
+
+/* Matrix all zero. Return zero solution. */
+
+ i__1 = max(*m,*n);
+ zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+ dlaset_("F", &minmn, &c__1, &c_b78, &c_b78, &s[1], &minmn);
+ *rank = 0;
+ goto L70;
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = zlange_("M", m, nrhs, &b[b_offset], ldb, &rwork[1]);
+ ibscl = 0;
+ if (bnrm > 0. && bnrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ zlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 1;
+ } else if (bnrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ zlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 2;
+ }
+
+/* Overdetermined case */
+
+ if (*m >= *n) {
+
+/* Path 1 - overdetermined or exactly determined */
+
+ mm = *m;
+ if (*m >= mnthr) {
+
+/* Path 1a - overdetermined, with many more rows than columns */
+
+ mm = *n;
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwork + 1;
+ zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__1,
+ info);
+
+/* Multiply B by transpose(Q) */
+/* (CWorkspace: need N+NRHS, prefer N+NRHS*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwork + 1;
+ zunmqr_("L", "C", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[
+ b_offset], ldb, &work[iwork], &i__1, info);
+
+/* Zero out below R */
+
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &a[a_dim1 + 2], lda);
+ }
+ }
+
+ ie = 1;
+ itauq = 1;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in A */
+/* (CWorkspace: need 2*N+MM, prefer 2*N+(MM+N)*NB) */
+/* (RWorkspace: need N) */
+
+ i__1 = *lwork - iwork + 1;
+ zgebrd_(&mm, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq], &
+ work[itaup], &work[iwork], &i__1, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors of R */
+/* (CWorkspace: need 2*N+NRHS, prefer 2*N+NRHS*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwork + 1;
+ zunmbr_("Q", "L", "C", &mm, nrhs, n, &a[a_offset], lda, &work[itauq],
+ &b[b_offset], ldb, &work[iwork], &i__1, info);
+
+/* Generate right bidiagonalizing vectors of R in A */
+/* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwork + 1;
+ zungbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[iwork], &
+ i__1, info);
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration */
+/* multiply B by transpose of left singular vectors */
+/* compute right singular vectors in A */
+/* (CWorkspace: none) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", n, n, &c__0, nrhs, &s[1], &rwork[ie], &a[a_offset], lda,
+ vdum, &c__1, &b[b_offset], ldb, &rwork[irwork], info);
+ if (*info != 0) {
+ goto L70;
+ }
+
+/* Multiply B by reciprocals of singular values */
+
+/* Computing MAX */
+ d__1 = *rcond * s[1];
+ thr = max(d__1,sfmin);
+ if (*rcond < 0.) {
+/* Computing MAX */
+ d__1 = eps * s[1];
+ thr = max(d__1,sfmin);
+ }
+ *rank = 0;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] > thr) {
+ zdrscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb);
+ ++(*rank);
+ } else {
+ zlaset_("F", &c__1, nrhs, &c_b1, &c_b1, &b[i__ + b_dim1], ldb);
+ }
+/* L10: */
+ }
+
+/* Multiply B by right singular vectors */
+/* (CWorkspace: need N, prefer N*NRHS) */
+/* (RWorkspace: none) */
+
+ if (*lwork >= *ldb * *nrhs && *nrhs > 1) {
+ zgemm_("C", "N", n, nrhs, n, &c_b2, &a[a_offset], lda, &b[
+ b_offset], ldb, &c_b1, &work[1], ldb);
+ zlacpy_("G", n, nrhs, &work[1], ldb, &b[b_offset], ldb)
+ ;
+ } else if (*nrhs > 1) {
+ chunk = *lwork / *n;
+ i__1 = *nrhs;
+ i__2 = chunk;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = *nrhs - i__ + 1;
+ bl = min(i__3,chunk);
+ zgemm_("C", "N", n, &bl, n, &c_b2, &a[a_offset], lda, &b[i__ *
+ b_dim1 + 1], ldb, &c_b1, &work[1], n);
+ zlacpy_("G", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1], ldb);
+/* L20: */
+ }
+ } else {
+ zgemv_("C", n, n, &c_b2, &a[a_offset], lda, &b[b_offset], &c__1, &
+ c_b1, &work[1], &c__1);
+ zcopy_(n, &work[1], &c__1, &b[b_offset], &c__1);
+ }
+
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__2 = max(*m,*nrhs), i__1 = *n - (*m << 1);
+ if (*n >= mnthr && *lwork >= *m * 3 + *m * *m + max(i__2,i__1)) {
+
+/* Underdetermined case, M much less than N */
+
+/* Path 2a - underdetermined, with many more columns than rows */
+/* and sufficient workspace for an efficient algorithm */
+
+ ldwork = *m;
+/* Computing MAX */
+ i__2 = max(*m,*nrhs), i__1 = *n - (*m << 1);
+ if (*lwork >= *m * 3 + *m * *lda + max(i__2,i__1)) {
+ ldwork = *lda;
+ }
+ itau = 1;
+ iwork = *m + 1;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: none) */
+
+ i__2 = *lwork - iwork + 1;
+ zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2,
+ info);
+ il = iwork;
+
+/* Copy L to WORK(IL), zeroing out above it */
+
+ zlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork);
+ i__2 = *m - 1;
+ i__1 = *m - 1;
+ zlaset_("U", &i__2, &i__1, &c_b1, &c_b1, &work[il + ldwork], &
+ ldwork);
+ ie = 1;
+ itauq = il + ldwork * *m;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IL) */
+/* (CWorkspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(m, m, &work[il], &ldwork, &s[1], &rwork[ie], &work[itauq],
+ &work[itaup], &work[iwork], &i__2, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors of L */
+/* (CWorkspace: need M*M+3*M+NRHS, prefer M*M+3*M+NRHS*NB) */
+/* (RWorkspace: none) */
+
+ i__2 = *lwork - iwork + 1;
+ zunmbr_("Q", "L", "C", m, nrhs, m, &work[il], &ldwork, &work[
+ itauq], &b[b_offset], ldb, &work[iwork], &i__2, info);
+
+/* Generate right bidiagonalizing vectors of R in WORK(IL) */
+/* (CWorkspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB) */
+/* (RWorkspace: none) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("P", m, m, m, &work[il], &ldwork, &work[itaup], &work[
+ iwork], &i__2, info);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right singular */
+/* vectors of L in WORK(IL) and multiplying B by transpose of */
+/* left singular vectors */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", m, m, &c__0, nrhs, &s[1], &rwork[ie], &work[il], &
+ ldwork, &a[a_offset], lda, &b[b_offset], ldb, &rwork[
+ irwork], info);
+ if (*info != 0) {
+ goto L70;
+ }
+
+/* Multiply B by reciprocals of singular values */
+
+/* Computing MAX */
+ d__1 = *rcond * s[1];
+ thr = max(d__1,sfmin);
+ if (*rcond < 0.) {
+/* Computing MAX */
+ d__1 = eps * s[1];
+ thr = max(d__1,sfmin);
+ }
+ *rank = 0;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (s[i__] > thr) {
+ zdrscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb);
+ ++(*rank);
+ } else {
+ zlaset_("F", &c__1, nrhs, &c_b1, &c_b1, &b[i__ + b_dim1],
+ ldb);
+ }
+/* L30: */
+ }
+ iwork = il + *m * ldwork;
+
+/* Multiply B by right singular vectors of L in WORK(IL) */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NRHS) */
+/* (RWorkspace: none) */
+
+ if (*lwork >= *ldb * *nrhs + iwork - 1 && *nrhs > 1) {
+ zgemm_("C", "N", m, nrhs, m, &c_b2, &work[il], &ldwork, &b[
+ b_offset], ldb, &c_b1, &work[iwork], ldb);
+ zlacpy_("G", m, nrhs, &work[iwork], ldb, &b[b_offset], ldb);
+ } else if (*nrhs > 1) {
+ chunk = (*lwork - iwork + 1) / *m;
+ i__2 = *nrhs;
+ i__1 = chunk;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
+ i__1) {
+/* Computing MIN */
+ i__3 = *nrhs - i__ + 1;
+ bl = min(i__3,chunk);
+ zgemm_("C", "N", m, &bl, m, &c_b2, &work[il], &ldwork, &b[
+ i__ * b_dim1 + 1], ldb, &c_b1, &work[iwork], m);
+ zlacpy_("G", m, &bl, &work[iwork], m, &b[i__ * b_dim1 + 1]
+, ldb);
+/* L40: */
+ }
+ } else {
+ zgemv_("C", m, m, &c_b2, &work[il], &ldwork, &b[b_dim1 + 1], &
+ c__1, &c_b1, &work[iwork], &c__1);
+ zcopy_(m, &work[iwork], &c__1, &b[b_dim1 + 1], &c__1);
+ }
+
+/* Zero out below first M rows of B */
+
+ i__1 = *n - *m;
+ zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[*m + 1 + b_dim1], ldb);
+ iwork = itau + *m;
+
+/* Multiply transpose(Q) by B */
+/* (CWorkspace: need M+NRHS, prefer M+NHRS*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwork + 1;
+ zunmlq_("L", "C", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[
+ b_offset], ldb, &work[iwork], &i__1, info);
+
+ } else {
+
+/* Path 2 - remaining underdetermined cases */
+
+ ie = 1;
+ itauq = 1;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize A */
+/* (CWorkspace: need 3*M, prefer 2*M+(M+N)*NB) */
+/* (RWorkspace: need N) */
+
+ i__1 = *lwork - iwork + 1;
+ zgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq],
+ &work[itaup], &work[iwork], &i__1, info);
+
+/* Multiply B by transpose of left bidiagonalizing vectors */
+/* (CWorkspace: need 2*M+NRHS, prefer 2*M+NRHS*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwork + 1;
+ zunmbr_("Q", "L", "C", m, nrhs, n, &a[a_offset], lda, &work[itauq]
+, &b[b_offset], ldb, &work[iwork], &i__1, info);
+
+/* Generate right bidiagonalizing vectors in A */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: none) */
+
+ i__1 = *lwork - iwork + 1;
+ zungbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[
+ iwork], &i__1, info);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, */
+/* computing right singular vectors of A in A and */
+/* multiplying B by transpose of left singular vectors */
+/* (CWorkspace: none) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("L", m, n, &c__0, nrhs, &s[1], &rwork[ie], &a[a_offset],
+ lda, vdum, &c__1, &b[b_offset], ldb, &rwork[irwork], info);
+ if (*info != 0) {
+ goto L70;
+ }
+
+/* Multiply B by reciprocals of singular values */
+
+/* Computing MAX */
+ d__1 = *rcond * s[1];
+ thr = max(d__1,sfmin);
+ if (*rcond < 0.) {
+/* Computing MAX */
+ d__1 = eps * s[1];
+ thr = max(d__1,sfmin);
+ }
+ *rank = 0;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] > thr) {
+ zdrscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb);
+ ++(*rank);
+ } else {
+ zlaset_("F", &c__1, nrhs, &c_b1, &c_b1, &b[i__ + b_dim1],
+ ldb);
+ }
+/* L50: */
+ }
+
+/* Multiply B by right singular vectors of A */
+/* (CWorkspace: need N, prefer N*NRHS) */
+/* (RWorkspace: none) */
+
+ if (*lwork >= *ldb * *nrhs && *nrhs > 1) {
+ zgemm_("C", "N", n, nrhs, m, &c_b2, &a[a_offset], lda, &b[
+ b_offset], ldb, &c_b1, &work[1], ldb);
+ zlacpy_("G", n, nrhs, &work[1], ldb, &b[b_offset], ldb);
+ } else if (*nrhs > 1) {
+ chunk = *lwork / *n;
+ i__1 = *nrhs;
+ i__2 = chunk;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *nrhs - i__ + 1;
+ bl = min(i__3,chunk);
+ zgemm_("C", "N", n, &bl, m, &c_b2, &a[a_offset], lda, &b[
+ i__ * b_dim1 + 1], ldb, &c_b1, &work[1], n);
+ zlacpy_("F", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1],
+ ldb);
+/* L60: */
+ }
+ } else {
+ zgemv_("C", m, n, &c_b2, &a[a_offset], lda, &b[b_offset], &
+ c__1, &c_b1, &work[1], &c__1);
+ zcopy_(n, &work[1], &c__1, &b[b_offset], &c__1);
+ }
+ }
+ }
+
+/* Undo scaling */
+
+ if (iascl == 1) {
+ zlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
+ info);
+ dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, info);
+ } else if (iascl == 2) {
+ zlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
+ info);
+ dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, info);
+ }
+ if (ibscl == 1) {
+ zlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ } else if (ibscl == 2) {
+ zlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ }
+L70:
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+ return 0;
+
+/* End of ZGELSS */
+
+} /* zgelss_ */
diff --git a/SRC/zgelsx.c b/SRC/zgelsx.c
new file mode 100644
index 0000000..556353a
--- /dev/null
+++ b/SRC/zgelsx.c
@@ -0,0 +1,471 @@
+/* zgelsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__0 = 0;
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* Subroutine */ int zgelsx_(integer *m, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ integer *jpvt, doublereal *rcond, integer *rank, doublecomplex *work,
+ doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublecomplex c1, c2, s1, s2, t1, t2;
+ integer mn;
+ doublereal anrm, bnrm, smin, smax;
+ integer iascl, ibscl, ismin, ismax;
+ extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ zlaic1_(integer *, integer *, doublecomplex *, doublereal *,
+ doublecomplex *, doublecomplex *, doublereal *, doublecomplex *,
+ doublecomplex *), dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ doublereal bignum;
+ extern /* Subroutine */ int zlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublecomplex *,
+ integer *, integer *), zgeqpf_(integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *), zlaset_(char *,
+ integer *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *);
+ doublereal sminpr, smaxpr, smlnum;
+ extern /* Subroutine */ int zlatzm_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *), ztzrqf_(
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine ZGELSY. */
+
+/* ZGELSX computes the minimum-norm solution to a complex linear least */
+/* squares problem: */
+/* minimize || A * X - B || */
+/* using a complete orthogonal factorization of A. A is an M-by-N */
+/* matrix which may be rank-deficient. */
+
+/* Several right hand side vectors b and solution vectors x can be */
+/* handled in a single call; they are stored as the columns of the */
+/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
+/* matrix X. */
+
+/* The routine first computes a QR factorization with column pivoting: */
+/* A * P = Q * [ R11 R12 ] */
+/* [ 0 R22 ] */
+/* with R11 defined as the largest leading submatrix whose estimated */
+/* condition number is less than 1/RCOND. The order of R11, RANK, */
+/* is the effective rank of A. */
+
+/* Then, R22 is considered to be negligible, and R12 is annihilated */
+/* by unitary transformations from the right, arriving at the */
+/* complete orthogonal factorization: */
+/* A * P = Q * [ T11 0 ] * Z */
+/* [ 0 0 ] */
+/* The minimum-norm solution is then */
+/* X = P * Z' [ inv(T11)*Q1'*B ] */
+/* [ 0 ] */
+/* where Q1 consists of the first RANK columns of Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of */
+/* columns of matrices B and X. NRHS >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A has been overwritten by details of its */
+/* complete orthogonal factorization. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the M-by-NRHS right hand side matrix B. */
+/* On exit, the N-by-NRHS solution matrix X. */
+/* If m >= n and RANK = n, the residual sum-of-squares for */
+/* the solution in the i-th column is given by the sum of */
+/* squares of elements N+1:M in that column. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M,N). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* On entry, if JPVT(i) .ne. 0, the i-th column of A is an */
+/* initial column, otherwise it is a free column. Before */
+/* the QR factorization of A, all initial columns are */
+/* permuted to the leading positions; only the remaining */
+/* free columns are moved as a result of column pivoting */
+/* during the factorization. */
+/* On exit, if JPVT(i) = k, then the i-th column of A*P */
+/* was the k-th column of A. */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* RCOND is used to determine the effective rank of A, which */
+/* is defined as the order of the largest leading triangular */
+/* submatrix R11 in the QR factorization with pivoting of A, */
+/* whose estimated condition number < 1/RCOND. */
+
+/* RANK (output) INTEGER */
+/* The effective rank of A, i.e., the order of the submatrix */
+/* R11. This is the same as the order of the submatrix T11 */
+/* in the complete orthogonal factorization of A. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (min(M,N) + max( N, 2*min(M,N)+NRHS )), */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --jpvt;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ mn = min(*m,*n);
+ ismin = mn + 1;
+ ismax = (mn << 1) + 1;
+
+/* Test the input arguments. */
+
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ if (*ldb < max(i__1,*n)) {
+ *info = -7;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGELSX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+/* Computing MIN */
+ i__1 = min(*m,*n);
+ if (min(i__1,*nrhs) == 0) {
+ *rank = 0;
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ smlnum = dlamch_("S") / dlamch_("P");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Scale A, B if max elements outside range [SMLNUM,BIGNUM] */
+
+ anrm = zlange_("M", m, n, &a[a_offset], lda, &rwork[1]);
+ iascl = 0;
+ if (anrm > 0. && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 2;
+ } else if (anrm == 0.) {
+
+/* Matrix all zero. Return zero solution. */
+
+ i__1 = max(*m,*n);
+ zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+ *rank = 0;
+ goto L100;
+ }
+
+ bnrm = zlange_("M", m, nrhs, &b[b_offset], ldb, &rwork[1]);
+ ibscl = 0;
+ if (bnrm > 0. && bnrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ zlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 1;
+ } else if (bnrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ zlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 2;
+ }
+
+/* Compute QR factorization with column pivoting of A: */
+/* A * P = Q * R */
+
+ zgeqpf_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], &
+ rwork[1], info);
+
+/* complex workspace MN+N. Real workspace 2*N. Details of Householder */
+/* rotations stored in WORK(1:MN). */
+
+/* Determine RANK using incremental condition estimation */
+
+ i__1 = ismin;
+ work[i__1].r = 1., work[i__1].i = 0.;
+ i__1 = ismax;
+ work[i__1].r = 1., work[i__1].i = 0.;
+ smax = z_abs(&a[a_dim1 + 1]);
+ smin = smax;
+ if (z_abs(&a[a_dim1 + 1]) == 0.) {
+ *rank = 0;
+ i__1 = max(*m,*n);
+ zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+ goto L100;
+ } else {
+ *rank = 1;
+ }
+
+L10:
+ if (*rank < mn) {
+ i__ = *rank + 1;
+ zlaic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[
+ i__ + i__ * a_dim1], &sminpr, &s1, &c1);
+ zlaic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[
+ i__ + i__ * a_dim1], &smaxpr, &s2, &c2);
+
+ if (smaxpr * *rcond <= sminpr) {
+ i__1 = *rank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ismin + i__ - 1;
+ i__3 = ismin + i__ - 1;
+ z__1.r = s1.r * work[i__3].r - s1.i * work[i__3].i, z__1.i =
+ s1.r * work[i__3].i + s1.i * work[i__3].r;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ i__2 = ismax + i__ - 1;
+ i__3 = ismax + i__ - 1;
+ z__1.r = s2.r * work[i__3].r - s2.i * work[i__3].i, z__1.i =
+ s2.r * work[i__3].i + s2.i * work[i__3].r;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L20: */
+ }
+ i__1 = ismin + *rank;
+ work[i__1].r = c1.r, work[i__1].i = c1.i;
+ i__1 = ismax + *rank;
+ work[i__1].r = c2.r, work[i__1].i = c2.i;
+ smin = sminpr;
+ smax = smaxpr;
+ ++(*rank);
+ goto L10;
+ }
+ }
+
+/* Logically partition R = [ R11 R12 ] */
+/* [ 0 R22 ] */
+/* where R11 = R(1:RANK,1:RANK) */
+
+/* [R11,R12] = [ T11, 0 ] * Y */
+
+ if (*rank < *n) {
+ ztzrqf_(rank, n, &a[a_offset], lda, &work[mn + 1], info);
+ }
+
+/* Details of Householder rotations stored in WORK(MN+1:2*MN) */
+
+/* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */
+
+ zunm2r_("Left", "Conjugate transpose", m, nrhs, &mn, &a[a_offset], lda, &
+ work[1], &b[b_offset], ldb, &work[(mn << 1) + 1], info);
+
+/* workspace NRHS */
+
+/* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */
+
+ ztrsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b2, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+ i__1 = *n;
+ for (i__ = *rank + 1; i__ <= i__1; ++i__) {
+ i__2 = *nrhs;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0., b[i__3].i = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) */
+
+ if (*rank < *n) {
+ i__1 = *rank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n - *rank + 1;
+ d_cnjg(&z__1, &work[mn + i__]);
+ zlatzm_("Left", &i__2, nrhs, &a[i__ + (*rank + 1) * a_dim1], lda,
+ &z__1, &b[i__ + b_dim1], &b[*rank + 1 + b_dim1], ldb, &
+ work[(mn << 1) + 1]);
+/* L50: */
+ }
+ }
+
+/* workspace NRHS */
+
+/* B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = (mn << 1) + i__;
+ work[i__3].r = 1., work[i__3].i = 0.;
+/* L60: */
+ }
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = (mn << 1) + i__;
+ if (work[i__3].r == 1. && work[i__3].i == 0.) {
+ if (jpvt[i__] != i__) {
+ k = i__;
+ i__3 = k + j * b_dim1;
+ t1.r = b[i__3].r, t1.i = b[i__3].i;
+ i__3 = jpvt[k] + j * b_dim1;
+ t2.r = b[i__3].r, t2.i = b[i__3].i;
+L70:
+ i__3 = jpvt[k] + j * b_dim1;
+ b[i__3].r = t1.r, b[i__3].i = t1.i;
+ i__3 = (mn << 1) + k;
+ work[i__3].r = 0., work[i__3].i = 0.;
+ t1.r = t2.r, t1.i = t2.i;
+ k = jpvt[k];
+ i__3 = jpvt[k] + j * b_dim1;
+ t2.r = b[i__3].r, t2.i = b[i__3].i;
+ if (jpvt[k] != i__) {
+ goto L70;
+ }
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = t1.r, b[i__3].i = t1.i;
+ i__3 = (mn << 1) + k;
+ work[i__3].r = 0., work[i__3].i = 0.;
+ }
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Undo scaling */
+
+ if (iascl == 1) {
+ zlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
+ info);
+ zlascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset],
+ lda, info);
+ } else if (iascl == 2) {
+ zlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
+ info);
+ zlascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset],
+ lda, info);
+ }
+ if (ibscl == 1) {
+ zlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ } else if (ibscl == 2) {
+ zlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ }
+
+L100:
+
+ return 0;
+
+/* End of ZGELSX */
+
+} /* zgelsx_ */
diff --git a/SRC/zgelsy.c b/SRC/zgelsy.c
new file mode 100644
index 0000000..355ac16
--- /dev/null
+++ b/SRC/zgelsy.c
@@ -0,0 +1,512 @@
+/* zgelsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__2 = 2;
+
+/* Subroutine */ int zgelsy_(integer *m, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ integer *jpvt, doublereal *rcond, integer *rank, doublecomplex *work,
+ integer *lwork, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublecomplex c1, c2, s1, s2;
+ integer nb, mn, nb1, nb2, nb3, nb4;
+ doublereal anrm, bnrm, smin, smax;
+ integer iascl, ibscl, ismin, ismax;
+ doublereal wsize;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), ztrsm_(char *, char *, char *, char *
+, integer *, integer *, doublecomplex *, doublecomplex *, integer
+ *, doublecomplex *, integer *),
+ zlaic1_(integer *, integer *, doublecomplex *, doublereal *,
+ doublecomplex *, doublecomplex *, doublereal *, doublecomplex *,
+ doublecomplex *), dlabad_(doublereal *, doublereal *), zgeqp3_(
+ integer *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublereal *,
+ integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ doublereal bignum;
+ extern /* Subroutine */ int zlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublecomplex *,
+ integer *, integer *), zlaset_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *);
+ doublereal sminpr, smaxpr, smlnum;
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int zunmqr_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *), zunmrz_(char *, char *, integer *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+), ztzrzf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *)
+ ;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGELSY computes the minimum-norm solution to a complex linear least */
+/* squares problem: */
+/* minimize || A * X - B || */
+/* using a complete orthogonal factorization of A. A is an M-by-N */
+/* matrix which may be rank-deficient. */
+
+/* Several right hand side vectors b and solution vectors x can be */
+/* handled in a single call; they are stored as the columns of the */
+/* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
+/* matrix X. */
+
+/* The routine first computes a QR factorization with column pivoting: */
+/* A * P = Q * [ R11 R12 ] */
+/* [ 0 R22 ] */
+/* with R11 defined as the largest leading submatrix whose estimated */
+/* condition number is less than 1/RCOND. The order of R11, RANK, */
+/* is the effective rank of A. */
+
+/* Then, R22 is considered to be negligible, and R12 is annihilated */
+/* by unitary transformations from the right, arriving at the */
+/* complete orthogonal factorization: */
+/* A * P = Q * [ T11 0 ] * Z */
+/* [ 0 0 ] */
+/* The minimum-norm solution is then */
+/* X = P * Z' [ inv(T11)*Q1'*B ] */
+/* [ 0 ] */
+/* where Q1 consists of the first RANK columns of Q. */
+
+/* This routine is basically identical to the original xGELSX except */
+/* three differences: */
+/* o The permutation of matrix B (the right hand side) is faster and */
+/* more simple. */
+/* o The call to the subroutine xGEQPF has been substituted by the */
+/* the call to the subroutine xGEQP3. This subroutine is a Blas-3 */
+/* version of the QR factorization with column pivoting. */
+/* o Matrix B (the right hand side) is updated with Blas-3. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of */
+/* columns of matrices B and X. NRHS >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A has been overwritten by details of its */
+/* complete orthogonal factorization. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the M-by-NRHS right hand side matrix B. */
+/* On exit, the N-by-NRHS solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M,N). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
+/* to the front of AP, otherwise column i is a free column. */
+/* On exit, if JPVT(i) = k, then the i-th column of A*P */
+/* was the k-th column of A. */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* RCOND is used to determine the effective rank of A, which */
+/* is defined as the order of the largest leading triangular */
+/* submatrix R11 in the QR factorization with pivoting of A, */
+/* whose estimated condition number < 1/RCOND. */
+
+/* RANK (output) INTEGER */
+/* The effective rank of A, i.e., the order of the submatrix */
+/* R11. This is the same as the order of the submatrix T11 */
+/* in the complete orthogonal factorization of A. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* The unblocked strategy requires that: */
+/* LWORK >= MN + MAX( 2*MN, N+1, MN+NRHS ) */
+/* where MN = min(M,N). */
+/* The block algorithm requires that: */
+/* LWORK >= MN + MAX( 2*MN, NB*(N+1), MN+MN*NB, MN+NB*NRHS ) */
+/* where NB is an upper bound on the blocksize returned */
+/* by ILAENV for the routines ZGEQP3, ZTZRZF, CTZRQF, ZUNMQR, */
+/* and ZUNMRZ. */
+
+/* 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. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+/* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
+/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --jpvt;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ mn = min(*m,*n);
+ ismin = mn + 1;
+ ismax = (mn << 1) + 1;
+
+/* Test the input arguments. */
+
+ *info = 0;
+ nb1 = ilaenv_(&c__1, "ZGEQRF", " ", m, n, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "ZGERQF", " ", m, n, &c_n1, &c_n1);
+ nb3 = ilaenv_(&c__1, "ZUNMQR", " ", m, n, nrhs, &c_n1);
+ nb4 = ilaenv_(&c__1, "ZUNMRQ", " ", m, n, nrhs, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2), i__1 = max(i__1,nb3);
+ nb = max(i__1,nb4);
+/* Computing MAX */
+ i__1 = 1, i__2 = mn + (*n << 1) + nb * (*n + 1), i__1 = max(i__1,i__2),
+ i__2 = (mn << 1) + nb * *nrhs;
+ lwkopt = max(i__1,i__2);
+ z__1.r = (doublereal) lwkopt, z__1.i = 0.;
+ work[1].r = z__1.r, work[1].i = z__1.i;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ if (*ldb < max(i__1,*n)) {
+ *info = -7;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = mn << 1, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = mn +
+ *nrhs;
+ if (*lwork < mn + max(i__1,i__2) && ! lquery) {
+ *info = -12;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGELSY", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+/* Computing MIN */
+ i__1 = min(*m,*n);
+ if (min(i__1,*nrhs) == 0) {
+ *rank = 0;
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ smlnum = dlamch_("S") / dlamch_("P");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Scale A, B if max entries outside range [SMLNUM,BIGNUM] */
+
+ anrm = zlange_("M", m, n, &a[a_offset], lda, &rwork[1]);
+ iascl = 0;
+ if (anrm > 0. && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda,
+ info);
+ iascl = 2;
+ } else if (anrm == 0.) {
+
+/* Matrix all zero. Return zero solution. */
+
+ i__1 = max(*m,*n);
+ zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+ *rank = 0;
+ goto L70;
+ }
+
+ bnrm = zlange_("M", m, nrhs, &b[b_offset], ldb, &rwork[1]);
+ ibscl = 0;
+ if (bnrm > 0. && bnrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ zlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 1;
+ } else if (bnrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ zlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb,
+ info);
+ ibscl = 2;
+ }
+
+/* Compute QR factorization with column pivoting of A: */
+/* A * P = Q * R */
+
+ i__1 = *lwork - mn;
+ zgeqp3_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], &i__1,
+ &rwork[1], info);
+ i__1 = mn + 1;
+ wsize = mn + work[i__1].r;
+
+/* complex workspace: MN+NB*(N+1). real workspace 2*N. */
+/* Details of Householder rotations stored in WORK(1:MN). */
+
+/* Determine RANK using incremental condition estimation */
+
+ i__1 = ismin;
+ work[i__1].r = 1., work[i__1].i = 0.;
+ i__1 = ismax;
+ work[i__1].r = 1., work[i__1].i = 0.;
+ smax = z_abs(&a[a_dim1 + 1]);
+ smin = smax;
+ if (z_abs(&a[a_dim1 + 1]) == 0.) {
+ *rank = 0;
+ i__1 = max(*m,*n);
+ zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+ goto L70;
+ } else {
+ *rank = 1;
+ }
+
+L10:
+ if (*rank < mn) {
+ i__ = *rank + 1;
+ zlaic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[
+ i__ + i__ * a_dim1], &sminpr, &s1, &c1);
+ zlaic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[
+ i__ + i__ * a_dim1], &smaxpr, &s2, &c2);
+
+ if (smaxpr * *rcond <= sminpr) {
+ i__1 = *rank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ismin + i__ - 1;
+ i__3 = ismin + i__ - 1;
+ z__1.r = s1.r * work[i__3].r - s1.i * work[i__3].i, z__1.i =
+ s1.r * work[i__3].i + s1.i * work[i__3].r;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ i__2 = ismax + i__ - 1;
+ i__3 = ismax + i__ - 1;
+ z__1.r = s2.r * work[i__3].r - s2.i * work[i__3].i, z__1.i =
+ s2.r * work[i__3].i + s2.i * work[i__3].r;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L20: */
+ }
+ i__1 = ismin + *rank;
+ work[i__1].r = c1.r, work[i__1].i = c1.i;
+ i__1 = ismax + *rank;
+ work[i__1].r = c2.r, work[i__1].i = c2.i;
+ smin = sminpr;
+ smax = smaxpr;
+ ++(*rank);
+ goto L10;
+ }
+ }
+
+/* complex workspace: 3*MN. */
+
+/* Logically partition R = [ R11 R12 ] */
+/* [ 0 R22 ] */
+/* where R11 = R(1:RANK,1:RANK) */
+
+/* [R11,R12] = [ T11, 0 ] * Y */
+
+ if (*rank < *n) {
+ i__1 = *lwork - (mn << 1);
+ ztzrzf_(rank, n, &a[a_offset], lda, &work[mn + 1], &work[(mn << 1) +
+ 1], &i__1, info);
+ }
+
+/* complex workspace: 2*MN. */
+/* Details of Householder rotations stored in WORK(MN+1:2*MN) */
+
+/* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */
+
+ i__1 = *lwork - (mn << 1);
+ zunmqr_("Left", "Conjugate transpose", m, nrhs, &mn, &a[a_offset], lda, &
+ work[1], &b[b_offset], ldb, &work[(mn << 1) + 1], &i__1, info);
+/* Computing MAX */
+ i__1 = (mn << 1) + 1;
+ d__1 = wsize, d__2 = (mn << 1) + work[i__1].r;
+ wsize = max(d__1,d__2);
+
+/* complex workspace: 2*MN+NB*NRHS. */
+
+/* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */
+
+ ztrsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b2, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = *rank + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0., b[i__3].i = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) */
+
+ if (*rank < *n) {
+ i__1 = *n - *rank;
+ i__2 = *lwork - (mn << 1);
+ zunmrz_("Left", "Conjugate transpose", n, nrhs, rank, &i__1, &a[
+ a_offset], lda, &work[mn + 1], &b[b_offset], ldb, &work[(mn <<
+ 1) + 1], &i__2, info);
+ }
+
+/* complex workspace: 2*MN+NRHS. */
+
+/* B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = jpvt[i__];
+ i__4 = i__ + j * b_dim1;
+ work[i__3].r = b[i__4].r, work[i__3].i = b[i__4].i;
+/* L50: */
+ }
+ zcopy_(n, &work[1], &c__1, &b[j * b_dim1 + 1], &c__1);
+/* L60: */
+ }
+
+/* complex workspace: N. */
+
+/* Undo scaling */
+
+ if (iascl == 1) {
+ zlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb,
+ info);
+ zlascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset],
+ lda, info);
+ } else if (iascl == 2) {
+ zlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb,
+ info);
+ zlascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset],
+ lda, info);
+ }
+ if (ibscl == 1) {
+ zlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ } else if (ibscl == 2) {
+ zlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb,
+ info);
+ }
+
+L70:
+ z__1.r = (doublereal) lwkopt, z__1.i = 0.;
+ work[1].r = z__1.r, work[1].i = z__1.i;
+
+ return 0;
+
+/* End of ZGELSY */
+
+} /* zgelsy_ */
diff --git a/SRC/zgeql2.c b/SRC/zgeql2.c
new file mode 100644
index 0000000..28107f3
--- /dev/null
+++ b/SRC/zgeql2.c
@@ -0,0 +1,167 @@
+/* zgeql2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zgeql2_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *tau, doublecomplex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, k;
+ doublecomplex alpha;
+ extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *), xerbla_(char *, integer *), zlarfp_(integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGEQL2 computes a QL factorization of a complex m by n matrix A: */
+/* A = Q * L. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the m by n matrix A. */
+/* On exit, if m >= n, the lower triangle of the subarray */
+/* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L; */
+/* if m <= n, the elements on and below the (n-m)-th */
+/* superdiagonal contain the m by n lower trapezoidal matrix L; */
+/* the remaining elements, with the array TAU, represent the */
+/* unitary matrix Q as a product of elementary reflectors */
+/* (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in */
+/* A(1:m-k+i-1,n-k+i), and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGEQL2", &i__1);
+ return 0;
+ }
+
+ k = min(*m,*n);
+
+ for (i__ = k; i__ >= 1; --i__) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* A(1:m-k+i-1,n-k+i) */
+
+ i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
+ alpha.r = a[i__1].r, alpha.i = a[i__1].i;
+ i__1 = *m - k + i__;
+ zlarfp_(&i__1, &alpha, &a[(*n - k + i__) * a_dim1 + 1], &c__1, &tau[
+ i__]);
+
+/* Apply H(i)' to A(1:m-k+i,1:n-k+i-1) from the left */
+
+ i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
+ a[i__1].r = 1., a[i__1].i = 0.;
+ i__1 = *m - k + i__;
+ i__2 = *n - k + i__ - 1;
+ d_cnjg(&z__1, &tau[i__]);
+ zlarf_("Left", &i__1, &i__2, &a[(*n - k + i__) * a_dim1 + 1], &c__1, &
+ z__1, &a[a_offset], lda, &work[1]);
+ i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
+ a[i__1].r = alpha.r, a[i__1].i = alpha.i;
+/* L10: */
+ }
+ return 0;
+
+/* End of ZGEQL2 */
+
+} /* zgeql2_ */
diff --git a/SRC/zgeqlf.c b/SRC/zgeqlf.c
new file mode 100644
index 0000000..749283a
--- /dev/null
+++ b/SRC/zgeqlf.c
@@ -0,0 +1,276 @@
+/* zgeqlf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int zgeqlf_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, k, ib, nb, ki, kk, mu, nu, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int zgeql2_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *), xerbla_(
+ char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ integer ldwork;
+ extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGEQLF computes a QL factorization of a complex M-by-N matrix A: */
+/* A = Q * L. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, */
+/* if m >= n, the lower triangle of the subarray */
+/* A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L; */
+/* if m <= n, the elements on and below the (n-m)-th */
+/* superdiagonal contain the M-by-N lower trapezoidal matrix L; */
+/* the remaining elements, with the array TAU, represent the */
+/* unitary matrix Q as a product of elementary reflectors */
+/* (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* For optimum performance LWORK >= N*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in */
+/* A(1:m-k+i-1,n-k+i), and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+
+ if (*info == 0) {
+ k = min(*m,*n);
+ if (k == 0) {
+ lwkopt = 1;
+ } else {
+ nb = ilaenv_(&c__1, "ZGEQLF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ if (*lwork < max(1,*n) && ! lquery) {
+ *info = -7;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGEQLF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (k == 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 1;
+ iws = *n;
+ if (nb > 1 && nb < k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "ZGEQLF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *n;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "ZGEQLF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < k && nx < k) {
+
+/* Use blocked code initially. */
+/* The last kk columns are handled by the block method. */
+
+ ki = (k - nx - 1) / nb * nb;
+/* Computing MIN */
+ i__1 = k, i__2 = ki + nb;
+ kk = min(i__1,i__2);
+
+ i__1 = k - kk + 1;
+ i__2 = -nb;
+ for (i__ = k - kk + ki + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__
+ += i__2) {
+/* Computing MIN */
+ i__3 = k - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Compute the QL factorization of the current block */
+/* A(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1) */
+
+ i__3 = *m - k + i__ + ib - 1;
+ zgeql2_(&i__3, &ib, &a[(*n - k + i__) * a_dim1 + 1], lda, &tau[
+ i__], &work[1], &iinfo);
+ if (*n - k + i__ > 1) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__3 = *m - k + i__ + ib - 1;
+ zlarft_("Backward", "Columnwise", &i__3, &ib, &a[(*n - k +
+ i__) * a_dim1 + 1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H' to A(1:m-k+i+ib-1,1:n-k+i-1) from the left */
+
+ i__3 = *m - k + i__ + ib - 1;
+ i__4 = *n - k + i__ - 1;
+ zlarfb_("Left", "Conjugate transpose", "Backward", "Columnwi"
+ "se", &i__3, &i__4, &ib, &a[(*n - k + i__) * a_dim1 +
+ 1], lda, &work[1], &ldwork, &a[a_offset], lda, &work[
+ ib + 1], &ldwork);
+ }
+/* L10: */
+ }
+ mu = *m - k + i__ + nb - 1;
+ nu = *n - k + i__ + nb - 1;
+ } else {
+ mu = *m;
+ nu = *n;
+ }
+
+/* Use unblocked code to factor the last or only block */
+
+ if (mu > 0 && nu > 0) {
+ zgeql2_(&mu, &nu, &a[a_offset], lda, &tau[1], &work[1], &iinfo);
+ }
+
+ work[1].r = (doublereal) iws, work[1].i = 0.;
+ return 0;
+
+/* End of ZGEQLF */
+
+} /* zgeqlf_ */
diff --git a/SRC/zgeqp3.c b/SRC/zgeqp3.c
new file mode 100644
index 0000000..9e95d75
--- /dev/null
+++ b/SRC/zgeqp3.c
@@ -0,0 +1,361 @@
+/* zgeqp3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int zgeqp3_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, integer *jpvt, doublecomplex *tau, doublecomplex *work,
+ integer *lwork, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer j, jb, na, nb, sm, sn, nx, fjb, iws, nfxd, nbmin, minmn, minws;
+ extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zlaqp2_(integer *, integer *,
+ integer *, doublecomplex *, integer *, integer *, doublecomplex *,
+ doublereal *, doublereal *, doublecomplex *);
+ extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zgeqrf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *
+);
+ integer topbmn, sminmn;
+ extern /* Subroutine */ int zlaqps_(integer *, integer *, integer *,
+ integer *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, doublereal *, doublereal *, doublecomplex *,
+ doublecomplex *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int zunmqr_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGEQP3 computes a QR factorization with column pivoting of a */
+/* matrix A: A*P = Q*R using Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the upper triangle of the array contains the */
+/* min(M,N)-by-N upper trapezoidal matrix R; the elements below */
+/* the diagonal, together with the array TAU, represent the */
+/* unitary matrix Q as a product of min(M,N) elementary */
+/* reflectors. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* On entry, if JPVT(J).ne.0, the J-th column of A is permuted */
+/* to the front of A*P (a leading column); if JPVT(J)=0, */
+/* the J-th column of A is a free column. */
+/* On exit, if JPVT(J)=K, then the J-th column of A*P was the */
+/* the K-th column of A. */
+
+/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO=0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= N+1. */
+/* For optimal performance LWORK >= ( N+1 )*NB, where NB */
+/* is the optimal blocksize. */
+
+/* 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. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a real/complex scalar, and v is a real/complex vector */
+/* with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in */
+/* A(i+1:m,i), and tau in TAU(i). */
+
+/* Based on contributions by */
+/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
+/* X. Sun, Computer Science Dept., Duke University, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test input arguments */
+/* ==================== */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --jpvt;
+ --tau;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+
+ if (*info == 0) {
+ minmn = min(*m,*n);
+ if (minmn == 0) {
+ iws = 1;
+ lwkopt = 1;
+ } else {
+ iws = *n + 1;
+ nb = ilaenv_(&c__1, "ZGEQRF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = (*n + 1) * nb;
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ if (*lwork < iws && ! lquery) {
+ *info = -8;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGEQP3", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (minmn == 0) {
+ return 0;
+ }
+
+/* Move initial columns up front. */
+
+ nfxd = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (jpvt[j] != 0) {
+ if (j != nfxd) {
+ zswap_(m, &a[j * a_dim1 + 1], &c__1, &a[nfxd * a_dim1 + 1], &
+ c__1);
+ jpvt[j] = jpvt[nfxd];
+ jpvt[nfxd] = j;
+ } else {
+ jpvt[j] = j;
+ }
+ ++nfxd;
+ } else {
+ jpvt[j] = j;
+ }
+/* L10: */
+ }
+ --nfxd;
+
+/* Factorize fixed columns */
+/* ======================= */
+
+/* Compute the QR factorization of fixed columns and update */
+/* remaining columns. */
+
+ if (nfxd > 0) {
+ na = min(*m,nfxd);
+/* CC CALL ZGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) */
+ zgeqrf_(m, &na, &a[a_offset], lda, &tau[1], &work[1], lwork, info);
+/* Computing MAX */
+ i__1 = iws, i__2 = (integer) work[1].r;
+ iws = max(i__1,i__2);
+ if (na < *n) {
+/* CC CALL ZUNM2R( 'Left', 'Conjugate Transpose', M, N-NA, */
+/* CC $ NA, A, LDA, TAU, A( 1, NA+1 ), LDA, WORK, */
+/* CC $ INFO ) */
+ i__1 = *n - na;
+ zunmqr_("Left", "Conjugate Transpose", m, &i__1, &na, &a[a_offset]
+, lda, &tau[1], &a[(na + 1) * a_dim1 + 1], lda, &work[1],
+ lwork, info);
+/* Computing MAX */
+ i__1 = iws, i__2 = (integer) work[1].r;
+ iws = max(i__1,i__2);
+ }
+ }
+
+/* Factorize free columns */
+/* ====================== */
+
+ if (nfxd < minmn) {
+
+ sm = *m - nfxd;
+ sn = *n - nfxd;
+ sminmn = minmn - nfxd;
+
+/* Determine the block size. */
+
+ nb = ilaenv_(&c__1, "ZGEQRF", " ", &sm, &sn, &c_n1, &c_n1);
+ nbmin = 2;
+ nx = 0;
+
+ if (nb > 1 && nb < sminmn) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "ZGEQRF", " ", &sm, &sn, &c_n1, &
+ c_n1);
+ nx = max(i__1,i__2);
+
+
+ if (nx < sminmn) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ minws = (sn + 1) * nb;
+ iws = max(iws,minws);
+ if (*lwork < minws) {
+
+/* Not enough workspace to use optimal NB: Reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / (sn + 1);
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "ZGEQRF", " ", &sm, &sn, &
+ c_n1, &c_n1);
+ nbmin = max(i__1,i__2);
+
+
+ }
+ }
+ }
+
+/* Initialize partial column norms. The first N elements of work */
+/* store the exact column norms. */
+
+ i__1 = *n;
+ for (j = nfxd + 1; j <= i__1; ++j) {
+ rwork[j] = dznrm2_(&sm, &a[nfxd + 1 + j * a_dim1], &c__1);
+ rwork[*n + j] = rwork[j];
+/* L20: */
+ }
+
+ if (nb >= nbmin && nb < sminmn && nx < sminmn) {
+
+/* Use blocked code initially. */
+
+ j = nfxd + 1;
+
+/* Compute factorization: while loop. */
+
+
+ topbmn = minmn - nx;
+L30:
+ if (j <= topbmn) {
+/* Computing MIN */
+ i__1 = nb, i__2 = topbmn - j + 1;
+ jb = min(i__1,i__2);
+
+/* Factorize JB columns among columns J:N. */
+
+ i__1 = *n - j + 1;
+ i__2 = j - 1;
+ i__3 = *n - j + 1;
+ zlaqps_(m, &i__1, &i__2, &jb, &fjb, &a[j * a_dim1 + 1], lda, &
+ jpvt[j], &tau[j], &rwork[j], &rwork[*n + j], &work[1],
+ &work[jb + 1], &i__3);
+
+ j += fjb;
+ goto L30;
+ }
+ } else {
+ j = nfxd + 1;
+ }
+
+/* Use unblocked code to factor the last or only block. */
+
+
+ if (j <= minmn) {
+ i__1 = *n - j + 1;
+ i__2 = j - 1;
+ zlaqp2_(m, &i__1, &i__2, &a[j * a_dim1 + 1], lda, &jpvt[j], &tau[
+ j], &rwork[j], &rwork[*n + j], &work[1]);
+ }
+
+ }
+
+ work[1].r = (doublereal) iws, work[1].i = 0.;
+ return 0;
+
+/* End of ZGEQP3 */
+
+} /* zgeqp3_ */
diff --git a/SRC/zgeqpf.c b/SRC/zgeqpf.c
new file mode 100644
index 0000000..725c83f
--- /dev/null
+++ b/SRC/zgeqpf.c
@@ -0,0 +1,316 @@
+/* zgeqpf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zgeqpf_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, integer *jpvt, doublecomplex *tau, doublecomplex *work,
+ doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ double z_abs(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, ma, mn;
+ doublecomplex aii;
+ integer pvt;
+ doublereal temp, temp2, tol3z;
+ integer itemp;
+ extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *), zswap_(integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *), zgeqr2_(
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
+ char *);
+ extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), zlarfp_(
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *);
+
+
+/* -- LAPACK deprecated driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine ZGEQP3. */
+
+/* ZGEQPF computes a QR factorization with column pivoting of a */
+/* complex M-by-N matrix A: A*P = Q*R. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0 */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the upper triangle of the array contains the */
+/* min(M,N)-by-N upper triangular matrix R; the elements */
+/* below the diagonal, together with the array TAU, */
+/* represent the unitary matrix Q as a product of */
+/* min(m,n) elementary reflectors. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
+/* to the front of A*P (a leading column); if JPVT(i) = 0, */
+/* the i-th column of A is a free column. */
+/* On exit, if JPVT(i) = k, then the i-th column of A*P */
+/* was the k-th column of A. */
+
+/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(n) */
+
+/* Each H(i) has the form */
+
+/* H = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i). */
+
+/* The matrix P is represented in jpvt as follows: If */
+/* jpvt(j) = i */
+/* then the jth column of P is the ith canonical unit vector. */
+
+/* Partial column norm updating strategy modified by */
+/* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */
+/* University of Zagreb, Croatia. */
+/* June 2006. */
+/* For more details see LAPACK Working Note 176. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --jpvt;
+ --tau;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGEQPF", &i__1);
+ return 0;
+ }
+
+ mn = min(*m,*n);
+ tol3z = sqrt(dlamch_("Epsilon"));
+
+/* Move initial columns up front */
+
+ itemp = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (jpvt[i__] != 0) {
+ if (i__ != itemp) {
+ zswap_(m, &a[i__ * a_dim1 + 1], &c__1, &a[itemp * a_dim1 + 1],
+ &c__1);
+ jpvt[i__] = jpvt[itemp];
+ jpvt[itemp] = i__;
+ } else {
+ jpvt[i__] = i__;
+ }
+ ++itemp;
+ } else {
+ jpvt[i__] = i__;
+ }
+/* L10: */
+ }
+ --itemp;
+
+/* Compute the QR factorization and update remaining columns */
+
+ if (itemp > 0) {
+ ma = min(itemp,*m);
+ zgeqr2_(m, &ma, &a[a_offset], lda, &tau[1], &work[1], info);
+ if (ma < *n) {
+ i__1 = *n - ma;
+ zunm2r_("Left", "Conjugate transpose", m, &i__1, &ma, &a[a_offset]
+, lda, &tau[1], &a[(ma + 1) * a_dim1 + 1], lda, &work[1],
+ info);
+ }
+ }
+
+ if (itemp < mn) {
+
+/* Initialize partial column norms. The first n elements of */
+/* work store the exact column norms. */
+
+ i__1 = *n;
+ for (i__ = itemp + 1; i__ <= i__1; ++i__) {
+ i__2 = *m - itemp;
+ rwork[i__] = dznrm2_(&i__2, &a[itemp + 1 + i__ * a_dim1], &c__1);
+ rwork[*n + i__] = rwork[i__];
+/* L20: */
+ }
+
+/* Compute factorization */
+
+ i__1 = mn;
+ for (i__ = itemp + 1; i__ <= i__1; ++i__) {
+
+/* Determine ith pivot column and swap if necessary */
+
+ i__2 = *n - i__ + 1;
+ pvt = i__ - 1 + idamax_(&i__2, &rwork[i__], &c__1);
+
+ if (pvt != i__) {
+ zswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
+ c__1);
+ itemp = jpvt[pvt];
+ jpvt[pvt] = jpvt[i__];
+ jpvt[i__] = itemp;
+ rwork[pvt] = rwork[i__];
+ rwork[*n + pvt] = rwork[*n + i__];
+ }
+
+/* Generate elementary reflector H(i) */
+
+ i__2 = i__ + i__ * a_dim1;
+ aii.r = a[i__2].r, aii.i = a[i__2].i;
+ i__2 = *m - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ zlarfp_(&i__2, &aii, &a[min(i__3, *m)+ i__ * a_dim1], &c__1, &tau[
+ i__]);
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = aii.r, a[i__2].i = aii.i;
+
+ if (i__ < *n) {
+
+/* Apply H(i) to A(i:m,i+1:n) from the left */
+
+ i__2 = i__ + i__ * a_dim1;
+ aii.r = a[i__2].r, aii.i = a[i__2].i;
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+ i__2 = *m - i__ + 1;
+ i__3 = *n - i__;
+ d_cnjg(&z__1, &tau[i__]);
+ zlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &
+ z__1, &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = aii.r, a[i__2].i = aii.i;
+ }
+
+/* Update partial column norms */
+
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (rwork[j] != 0.) {
+
+/* NOTE: The following 4 lines follow from the analysis in */
+/* Lapack Working Note 176. */
+
+ temp = z_abs(&a[i__ + j * a_dim1]) / rwork[j];
+/* Computing MAX */
+ d__1 = 0., d__2 = (temp + 1.) * (1. - temp);
+ temp = max(d__1,d__2);
+/* Computing 2nd power */
+ d__1 = rwork[j] / rwork[*n + j];
+ temp2 = temp * (d__1 * d__1);
+ if (temp2 <= tol3z) {
+ if (*m - i__ > 0) {
+ i__3 = *m - i__;
+ rwork[j] = dznrm2_(&i__3, &a[i__ + 1 + j * a_dim1]
+, &c__1);
+ rwork[*n + j] = rwork[j];
+ } else {
+ rwork[j] = 0.;
+ rwork[*n + j] = 0.;
+ }
+ } else {
+ rwork[j] *= sqrt(temp);
+ }
+ }
+/* L30: */
+ }
+
+/* L40: */
+ }
+ }
+ return 0;
+
+/* End of ZGEQPF */
+
+} /* zgeqpf_ */
diff --git a/SRC/zgeqr2.c b/SRC/zgeqr2.c
new file mode 100644
index 0000000..4bc74a2
--- /dev/null
+++ b/SRC/zgeqr2.c
@@ -0,0 +1,169 @@
+/* zgeqr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zgeqr2_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *tau, doublecomplex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, k;
+ doublecomplex alpha;
+ extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *), xerbla_(char *, integer *), zlarfp_(integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGEQR2 computes a QR factorization of a complex m by n matrix A: */
+/* A = Q * R. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the m by n matrix A. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(m,n) by n upper trapezoidal matrix R (R is */
+/* upper triangular if m >= n); the elements below the diagonal, */
+/* with the array TAU, represent the unitary matrix Q as a */
+/* product of elementary reflectors (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */
+/* and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGEQR2", &i__1);
+ return 0;
+ }
+
+ k = min(*m,*n);
+
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
+
+ i__2 = *m - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ zlarfp_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3, *m)+ i__ * a_dim1]
+, &c__1, &tau[i__]);
+ if (i__ < *n) {
+
+/* Apply H(i)' to A(i:m,i+1:n) from the left */
+
+ i__2 = i__ + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+ i__2 = *m - i__ + 1;
+ i__3 = *n - i__;
+ d_cnjg(&z__1, &tau[i__]);
+ zlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &z__1,
+ &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = alpha.r, a[i__2].i = alpha.i;
+ }
+/* L10: */
+ }
+ return 0;
+
+/* End of ZGEQR2 */
+
+} /* zgeqr2_ */
diff --git a/SRC/zgeqrf.c b/SRC/zgeqrf.c
new file mode 100644
index 0000000..a26e355
--- /dev/null
+++ b/SRC/zgeqrf.c
@@ -0,0 +1,258 @@
+/* zgeqrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int zgeqrf_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, k, ib, nb, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *), xerbla_(
+ char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ integer ldwork;
+ extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGEQRF computes a QR factorization of a complex M-by-N matrix A: */
+/* A = Q * R. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(M,N)-by-N upper trapezoidal matrix R (R is */
+/* upper triangular if m >= n); the elements below the diagonal, */
+/* with the array TAU, represent the unitary matrix Q as a */
+/* product of min(m,n) elementary reflectors (see Further */
+/* Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* For optimum performance LWORK >= N*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */
+/* and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb = ilaenv_(&c__1, "ZGEQRF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGEQRF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ k = min(*m,*n);
+ if (k == 0) {
+ work[1].r = 1., work[1].i = 0.;
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *n;
+ if (nb > 1 && nb < k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "ZGEQRF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *n;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "ZGEQRF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < k && nx < k) {
+
+/* Use blocked code initially */
+
+ i__1 = k - nx;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = k - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Compute the QR factorization of the current block */
+/* A(i:m,i:i+ib-1) */
+
+ i__3 = *m - i__ + 1;
+ zgeqr2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
+ 1], &iinfo);
+ if (i__ + ib <= *n) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__3 = *m - i__ + 1;
+ zlarft_("Forward", "Columnwise", &i__3, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H' to A(i:m,i+ib:n) from the left */
+
+ i__3 = *m - i__ + 1;
+ i__4 = *n - i__ - ib + 1;
+ zlarfb_("Left", "Conjugate transpose", "Forward", "Columnwise"
+, &i__3, &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &
+ work[1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda,
+ &work[ib + 1], &ldwork);
+ }
+/* L10: */
+ }
+ } else {
+ i__ = 1;
+ }
+
+/* Use unblocked code to factor the last or only block. */
+
+ if (i__ <= k) {
+ i__2 = *m - i__ + 1;
+ i__1 = *n - i__ + 1;
+ zgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
+, &iinfo);
+ }
+
+ work[1].r = (doublereal) iws, work[1].i = 0.;
+ return 0;
+
+/* End of ZGEQRF */
+
+} /* zgeqrf_ */
diff --git a/SRC/zgerfs.c b/SRC/zgerfs.c
new file mode 100644
index 0000000..4fb472e
--- /dev/null
+++ b/SRC/zgerfs.c
@@ -0,0 +1,461 @@
+/* zgerfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zgerfs_(char *trans, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf,
+ integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x,
+ integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work,
+ doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal s, xk;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3], count;
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *), zlacn2_(integer *,
+ doublecomplex *, doublecomplex *, doublereal *, integer *,
+ integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+ char transn[1], transt[1];
+ doublereal lstres;
+ extern /* Subroutine */ int zgetrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGERFS improves the computed solution to a system of linear */
+/* equations and provides error bounds and backward error estimates for */
+/* the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The factors L and U from the factorization A = P*L*U */
+/* as computed by ZGETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from ZGETRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by ZGETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldx < max(1,*n)) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGERFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transn = 'N';
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transn = 'C';
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A, A**T, or A**H, depending on TRANS. */
+
+ zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_(trans, n, n, &z__1, &a[a_offset], lda, &x[j * x_dim1 + 1], &
+ c__1, &c_b1, &work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
+ i__ + j * b_dim1]), abs(d__2));
+/* L30: */
+ }
+
+/* Compute abs(op(A))*abs(X) + abs(B). */
+
+ if (notran) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
+ x_dim1]), abs(d__2));
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ rwork[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + k * a_dim1]), abs(d__2))) * xk;
+/* L40: */
+ }
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + k * a_dim1]), abs(d__2))) * ((d__3 = x[i__5]
+ .r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j *
+ x_dim1]), abs(d__4)));
+/* L60: */
+ }
+ rwork[k] += s;
+/* L70: */
+ }
+ }
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__3 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2))) / rwork[i__];
+ s = max(d__3,d__4);
+ } else {
+/* Computing MAX */
+ i__3 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = max(d__3,d__4);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ zgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[1],
+ n, info);
+ zaxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use ZLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__3 = i__;
+ rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ ;
+ } else {
+ i__3 = i__;
+ rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)**H). */
+
+ zgetrs_(transt, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &
+ work[1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L110: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L120: */
+ }
+ zgetrs_(transn, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &
+ work[1], n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * x_dim1;
+ d__3 = lstres, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&x[i__ + j * x_dim1]), abs(d__2));
+ lstres = max(d__3,d__4);
+/* L130: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of ZGERFS */
+
+} /* zgerfs_ */
diff --git a/SRC/zgerfsx.c b/SRC/zgerfsx.c
new file mode 100644
index 0000000..2adfab8
--- /dev/null
+++ b/SRC/zgerfsx.c
@@ -0,0 +1,669 @@
+/* zgerfsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int zgerfsx_(char *trans, char *equed, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, integer *ipiv, doublereal *r__, doublereal *c__, doublecomplex *
+ b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond,
+ doublereal *berr, integer *n_err_bnds__, doublereal *err_bnds_norm__,
+ doublereal *err_bnds_comp__, integer *nparams, doublereal *params,
+ doublecomplex *work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal illrcond_thresh__, unstable_thresh__, err_lbnd__;
+ integer ref_type__;
+ extern integer ilatrans_(char *);
+ integer j;
+ doublereal rcond_tmp__;
+ integer prec_type__, trans_type__;
+ doublereal cwise_wrong__;
+ extern /* Subroutine */ int zla_gerfsx_extended__(integer *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *, logical *, doublereal *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ doublecomplex *, doublecomplex *, doublereal *, integer *,
+ doublereal *, doublereal *, logical *, integer *);
+ char norm[1];
+ logical ignore_cwise__;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern doublereal zla_gercond_c__(char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, doublereal *,
+ logical *, integer *, doublecomplex *, doublereal *, ftnlen),
+ zla_gercond_x__(char *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublereal *, ftnlen), dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zgecon_(char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublecomplex *,
+ doublereal *, integer *);
+ logical colequ, notran, rowequ;
+ extern integer ilaprec_(char *);
+ integer ithresh, n_norms__;
+ doublereal rthresh;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGERFSX improves the computed solution to a system of linear */
+/* equations and provides error bounds and backward error estimates */
+/* for the solution. In addition to normwise error bound, the code */
+/* provides maximum componentwise error bound if possible. See */
+/* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the */
+/* error bounds. */
+
+/* The original system of linear equations may have been equilibrated */
+/* before calling this routine, as described by arguments EQUED, R */
+/* and C below. In this case, the solution and error bounds returned */
+/* are for the original unequilibrated system. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* EQUED (input) CHARACTER*1 */
+/* Specifies the form of equilibration that was done to A */
+/* before calling this routine. This is needed to compute */
+/* the solution and error bounds correctly. */
+/* = 'N': No equilibration */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* The right hand side B has been changed accordingly. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The factors L and U from the factorization A = P*L*U */
+/* as computed by ZGETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from ZGETRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* R (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+/* If R is output, each element of R is a power of the radix. */
+/* If R is input, each element of R should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* C (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+/* If C is output, each element of C is a power of the radix. */
+/* If C is input, each element of C should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by ZGETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0D+0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check the input parameters. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ trans_type__ = ilatrans_(trans);
+ ref_type__ = 1;
+ if (*nparams >= 1) {
+ if (params[1] < 0.) {
+ params[1] = 1.;
+ } else {
+ ref_type__ = (integer) params[1];
+ }
+ }
+
+/* Set default parameters. */
+
+ illrcond_thresh__ = (doublereal) (*n) * dlamch_("Epsilon");
+ ithresh = 10;
+ rthresh = .5;
+ unstable_thresh__ = .25;
+ ignore_cwise__ = FALSE_;
+
+ if (*nparams >= 2) {
+ if (params[2] < 0.) {
+ params[2] = (doublereal) ithresh;
+ } else {
+ ithresh = (integer) params[2];
+ }
+ }
+ if (*nparams >= 3) {
+ if (params[3] < 0.) {
+ if (ignore_cwise__) {
+ params[3] = 0.;
+ } else {
+ params[3] = 1.;
+ }
+ } else {
+ ignore_cwise__ = params[3] == 0.;
+ }
+ }
+ if (ref_type__ == 0 || *n_err_bnds__ == 0) {
+ n_norms__ = 0;
+ } else if (ignore_cwise__) {
+ n_norms__ = 1;
+ } else {
+ n_norms__ = 2;
+ }
+
+ notran = lsame_(trans, "N");
+ rowequ = lsame_(equed, "R") || lsame_(equed, "B");
+ colequ = lsame_(equed, "C") || lsame_(equed, "B");
+
+/* Test input parameters. */
+
+ if (trans_type__ == -1) {
+ *info = -1;
+ } else if (! rowequ && ! colequ && ! lsame_(equed, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -13;
+ } else if (*ldx < max(1,*n)) {
+ *info = -15;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGERFSX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *nrhs == 0) {
+ *rcond = 1.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 0.;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.;
+ }
+ }
+ return 0;
+ }
+
+/* Default to failure. */
+
+ *rcond = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 1.;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.;
+ }
+ }
+
+/* Compute the norm of A and the reciprocal of the condition */
+/* number of A. */
+
+ if (notran) {
+ *(unsigned char *)norm = 'I';
+ } else {
+ *(unsigned char *)norm = '1';
+ }
+ anorm = zlange_(norm, n, n, &a[a_offset], lda, &rwork[1]);
+ zgecon_(norm, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &rwork[1],
+ info);
+
+/* Perform refinement on each right-hand side */
+
+ if (ref_type__ != 0) {
+ prec_type__ = ilaprec_("E");
+ if (notran) {
+ zla_gerfsx_extended__(&prec_type__, &trans_type__, n, nrhs, &a[
+ a_offset], lda, &af[af_offset], ldaf, &ipiv[1], &colequ, &
+ c__[1], &b[b_offset], ldb, &x[x_offset], ldx, &berr[1], &
+ n_norms__, &err_bnds_norm__[err_bnds_norm_offset], &
+ err_bnds_comp__[err_bnds_comp_offset], &work[1], &rwork[1]
+ , &work[*n + 1], (doublecomplex*)(&rwork[1]), rcond, &ithresh, &rthresh, &
+ unstable_thresh__, &ignore_cwise__, info);
+ } else {
+ zla_gerfsx_extended__(&prec_type__, &trans_type__, n, nrhs, &a[
+ a_offset], lda, &af[af_offset], ldaf, &ipiv[1], &rowequ, &
+ r__[1], &b[b_offset], ldb, &x[x_offset], ldx, &berr[1], &
+ n_norms__, &err_bnds_norm__[err_bnds_norm_offset], &
+ err_bnds_comp__[err_bnds_comp_offset], &work[1], &rwork[1]
+ , &work[*n + 1], (doublecomplex *)(&rwork[1]), rcond, &ithresh, &rthresh, &
+ unstable_thresh__, &ignore_cwise__, info);
+ }
+ }
+/* Computing MAX */
+ d__1 = 10., d__2 = sqrt((doublereal) (*n));
+ err_lbnd__ = max(d__1,d__2) * dlamch_("Epsilon");
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {
+
+/* Compute scaled normwise condition number cond(A*C). */
+
+ if (colequ && notran) {
+ rcond_tmp__ = zla_gercond_c__(trans, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &c__[1], &c_true, info, &work[
+ 1], &rwork[1], (ftnlen)1);
+ } else if (rowequ && ! notran) {
+ rcond_tmp__ = zla_gercond_c__(trans, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &r__[1], &c_true, info, &work[
+ 1], &rwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = zla_gercond_c__(trans, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &c__[1], &c_false, info, &
+ work[1], &rwork[1], (ftnlen)1);
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1
+ << 1)] > 1.) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 0.;
+ if (*info <= *n) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {
+
+/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
+/* each right-hand side using the current solution as an estimate of */
+/* the true solution. If the componentwise error estimate is too */
+/* large, then the solution is a lousy estimate of truth and the */
+/* estimated RCOND may be too optimistic. To avoid misleading users, */
+/* the inverse condition number is set to 0.0 when the estimated */
+/* cwise error is at least CWISE_WRONG. */
+
+ cwise_wrong__ = sqrt(dlamch_("Epsilon"));
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ cwise_wrong__) {
+ rcond_tmp__ = zla_gercond_x__(trans, n, &a[a_offset], lda, &
+ af[af_offset], ldaf, &ipiv[1], &x[j * x_dim1 + 1],
+ info, &work[1], &rwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = 0.;
+ }
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1
+ << 1)] > 1.) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 0.;
+ if (params[3] == 1. && *info < *n + j) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZGERFSX */
+
+} /* zgerfsx_ */
diff --git a/SRC/zgerq2.c b/SRC/zgerq2.c
new file mode 100644
index 0000000..a91d0cb
--- /dev/null
+++ b/SRC/zgerq2.c
@@ -0,0 +1,162 @@
+/* zgerq2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zgerq2_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *tau, doublecomplex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, k;
+ doublecomplex alpha;
+ extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *), xerbla_(char *, integer *), zlacgv_(integer *, doublecomplex *, integer *), zlarfp_(
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGERQ2 computes an RQ factorization of a complex m by n matrix A: */
+/* A = R * Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the m by n matrix A. */
+/* On exit, if m <= n, the upper triangle of the subarray */
+/* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R; */
+/* if m >= n, the elements on and above the (m-n)-th subdiagonal */
+/* contain the m by n upper trapezoidal matrix R; the remaining */
+/* elements, with the array TAU, represent the unitary matrix */
+/* Q as a product of elementary reflectors (see Further */
+/* Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (M) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1)' H(2)' . . . H(k)', where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on */
+/* exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGERQ2", &i__1);
+ return 0;
+ }
+
+ k = min(*m,*n);
+
+ for (i__ = k; i__ >= 1; --i__) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* A(m-k+i,1:n-k+i-1) */
+
+ i__1 = *n - k + i__;
+ zlacgv_(&i__1, &a[*m - k + i__ + a_dim1], lda);
+ i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
+ alpha.r = a[i__1].r, alpha.i = a[i__1].i;
+ i__1 = *n - k + i__;
+ zlarfp_(&i__1, &alpha, &a[*m - k + i__ + a_dim1], lda, &tau[i__]);
+
+/* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right */
+
+ i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
+ a[i__1].r = 1., a[i__1].i = 0.;
+ i__1 = *m - k + i__ - 1;
+ i__2 = *n - k + i__;
+ zlarf_("Right", &i__1, &i__2, &a[*m - k + i__ + a_dim1], lda, &tau[
+ i__], &a[a_offset], lda, &work[1]);
+ i__1 = *m - k + i__ + (*n - k + i__) * a_dim1;
+ a[i__1].r = alpha.r, a[i__1].i = alpha.i;
+ i__1 = *n - k + i__ - 1;
+ zlacgv_(&i__1, &a[*m - k + i__ + a_dim1], lda);
+/* L10: */
+ }
+ return 0;
+
+/* End of ZGERQ2 */
+
+} /* zgerq2_ */
diff --git a/SRC/zgerqf.c b/SRC/zgerqf.c
new file mode 100644
index 0000000..9510b77
--- /dev/null
+++ b/SRC/zgerqf.c
@@ -0,0 +1,275 @@
+/* zgerqf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int zgerqf_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, k, ib, nb, ki, kk, mu, nu, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int zgerq2_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *), xerbla_(
+ char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ integer ldwork;
+ extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGERQF computes an RQ factorization of a complex M-by-N matrix A: */
+/* A = R * Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, */
+/* if m <= n, the upper triangle of the subarray */
+/* A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R; */
+/* if m >= n, the elements on and above the (m-n)-th subdiagonal */
+/* contain the M-by-N upper trapezoidal matrix R; */
+/* the remaining elements, with the array TAU, represent the */
+/* unitary matrix Q as a product of min(m,n) elementary */
+/* reflectors (see Further Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M). */
+/* For optimum performance LWORK >= M*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1)' H(2)' . . . H(k)', where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on */
+/* exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+
+ if (*info == 0) {
+ k = min(*m,*n);
+ if (k == 0) {
+ lwkopt = 1;
+ } else {
+ nb = ilaenv_(&c__1, "ZGERQF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = *m * nb;
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ if (*lwork < max(1,*m) && ! lquery) {
+ *info = -7;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGERQF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (k == 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 1;
+ iws = *m;
+ if (nb > 1 && nb < k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "ZGERQF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *m;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "ZGERQF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < k && nx < k) {
+
+/* Use blocked code initially. */
+/* The last kk rows are handled by the block method. */
+
+ ki = (k - nx - 1) / nb * nb;
+/* Computing MIN */
+ i__1 = k, i__2 = ki + nb;
+ kk = min(i__1,i__2);
+
+ i__1 = k - kk + 1;
+ i__2 = -nb;
+ for (i__ = k - kk + ki + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__
+ += i__2) {
+/* Computing MIN */
+ i__3 = k - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Compute the RQ factorization of the current block */
+/* A(m-k+i:m-k+i+ib-1,1:n-k+i+ib-1) */
+
+ i__3 = *n - k + i__ + ib - 1;
+ zgerq2_(&ib, &i__3, &a[*m - k + i__ + a_dim1], lda, &tau[i__], &
+ work[1], &iinfo);
+ if (*m - k + i__ > 1) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__3 = *n - k + i__ + ib - 1;
+ zlarft_("Backward", "Rowwise", &i__3, &ib, &a[*m - k + i__ +
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H to A(1:m-k+i-1,1:n-k+i+ib-1) from the right */
+
+ i__3 = *m - k + i__ - 1;
+ i__4 = *n - k + i__ + ib - 1;
+ zlarfb_("Right", "No transpose", "Backward", "Rowwise", &i__3,
+ &i__4, &ib, &a[*m - k + i__ + a_dim1], lda, &work[1],
+ &ldwork, &a[a_offset], lda, &work[ib + 1], &ldwork);
+ }
+/* L10: */
+ }
+ mu = *m - k + i__ + nb - 1;
+ nu = *n - k + i__ + nb - 1;
+ } else {
+ mu = *m;
+ nu = *n;
+ }
+
+/* Use unblocked code to factor the last or only block */
+
+ if (mu > 0 && nu > 0) {
+ zgerq2_(&mu, &nu, &a[a_offset], lda, &tau[1], &work[1], &iinfo);
+ }
+
+ work[1].r = (doublereal) iws, work[1].i = 0.;
+ return 0;
+
+/* End of ZGERQF */
+
+} /* zgerqf_ */
diff --git a/SRC/zgesc2.c b/SRC/zgesc2.c
new file mode 100644
index 0000000..90f667c
--- /dev/null
+++ b/SRC/zgesc2.c
@@ -0,0 +1,206 @@
+/* zgesc2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublecomplex c_b13 = {1.,0.};
+static integer c_n1 = -1;
+
+/* Subroutine */ int zgesc2_(integer *n, doublecomplex *a, integer *lda,
+ doublecomplex *rhs, integer *ipiv, integer *jpiv, doublereal *scale)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal eps;
+ doublecomplex temp;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ doublereal bignum;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ doublereal smlnum;
+ extern /* Subroutine */ int zlaswp_(integer *, doublecomplex *, integer *,
+ integer *, integer *, integer *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGESC2 solves a system of linear equations */
+
+/* A * X = scale* RHS */
+
+/* with a general N-by-N matrix A using the LU factorization with */
+/* complete pivoting computed by ZGETC2. */
+
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA, N) */
+/* On entry, the LU part of the factorization of the n-by-n */
+/* matrix A computed by ZGETC2: A = P * L * U * Q */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1, N). */
+
+/* RHS (input/output) COMPLEX*16 array, dimension N. */
+/* On entry, the right hand side vector b. */
+/* On exit, the solution vector X. */
+
+/* IPIV (input) INTEGER array, dimension (N). */
+/* The pivot indices; for 1 <= i <= N, row i of the */
+/* matrix has been interchanged with row IPIV(i). */
+
+/* JPIV (input) INTEGER array, dimension (N). */
+/* The pivot indices; for 1 <= j <= N, column j of the */
+/* matrix has been interchanged with column JPIV(j). */
+
+/* SCALE (output) DOUBLE PRECISION */
+/* On exit, SCALE contains the scale factor. SCALE is chosen */
+/* 0 <= SCALE <= 1 to prevent owerflow in the solution. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Set constant to control overflow */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --rhs;
+ --ipiv;
+ --jpiv;
+
+ /* Function Body */
+ eps = dlamch_("P");
+ smlnum = dlamch_("S") / eps;
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Apply permutations IPIV to RHS */
+
+ i__1 = *n - 1;
+ zlaswp_(&c__1, &rhs[1], lda, &c__1, &i__1, &ipiv[1], &c__1);
+
+/* Solve for L part */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j;
+ i__4 = j;
+ i__5 = j + i__ * a_dim1;
+ i__6 = i__;
+ z__2.r = a[i__5].r * rhs[i__6].r - a[i__5].i * rhs[i__6].i,
+ z__2.i = a[i__5].r * rhs[i__6].i + a[i__5].i * rhs[i__6]
+ .r;
+ z__1.r = rhs[i__4].r - z__2.r, z__1.i = rhs[i__4].i - z__2.i;
+ rhs[i__3].r = z__1.r, rhs[i__3].i = z__1.i;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Solve for U part */
+
+ *scale = 1.;
+
+/* Check for scaling */
+
+ i__ = izamax_(n, &rhs[1], &c__1);
+ if (smlnum * 2. * z_abs(&rhs[i__]) > z_abs(&a[*n + *n * a_dim1])) {
+ d__1 = z_abs(&rhs[i__]);
+ z__1.r = .5 / d__1, z__1.i = 0. / d__1;
+ temp.r = z__1.r, temp.i = z__1.i;
+ zscal_(n, &temp, &rhs[1], &c__1);
+ *scale *= temp.r;
+ }
+ for (i__ = *n; i__ >= 1; --i__) {
+ z_div(&z__1, &c_b13, &a[i__ + i__ * a_dim1]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__1 = i__;
+ i__2 = i__;
+ z__1.r = rhs[i__2].r * temp.r - rhs[i__2].i * temp.i, z__1.i = rhs[
+ i__2].r * temp.i + rhs[i__2].i * temp.r;
+ rhs[i__1].r = z__1.r, rhs[i__1].i = z__1.i;
+ i__1 = *n;
+ for (j = i__ + 1; j <= i__1; ++j) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = j;
+ i__5 = i__ + j * a_dim1;
+ z__3.r = a[i__5].r * temp.r - a[i__5].i * temp.i, z__3.i = a[i__5]
+ .r * temp.i + a[i__5].i * temp.r;
+ z__2.r = rhs[i__4].r * z__3.r - rhs[i__4].i * z__3.i, z__2.i =
+ rhs[i__4].r * z__3.i + rhs[i__4].i * z__3.r;
+ z__1.r = rhs[i__3].r - z__2.r, z__1.i = rhs[i__3].i - z__2.i;
+ rhs[i__2].r = z__1.r, rhs[i__2].i = z__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Apply permutations JPIV to the solution (RHS) */
+
+ i__1 = *n - 1;
+ zlaswp_(&c__1, &rhs[1], lda, &c__1, &i__1, &jpiv[1], &c_n1);
+ return 0;
+
+/* End of ZGESC2 */
+
+} /* zgesc2_ */
diff --git a/SRC/zgesdd.c b/SRC/zgesdd.c
new file mode 100644
index 0000000..6bc435d
--- /dev/null
+++ b/SRC/zgesdd.c
@@ -0,0 +1,2252 @@
+/* zgesdd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+
+/* Subroutine */ int zgesdd_(char *jobz, integer *m, integer *n,
+ doublecomplex *a, integer *lda, doublereal *s, doublecomplex *u,
+ integer *ldu, doublecomplex *vt, integer *ldvt, doublecomplex *work,
+ integer *lwork, doublereal *rwork, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1,
+ i__2, i__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, ie, il, ir, iu, blk;
+ doublereal dum[1], eps;
+ integer iru, ivt, iscl;
+ doublereal anrm;
+ integer idum[1], ierr, itau, irvt;
+ extern logical lsame_(char *, char *);
+ integer chunk, minmn;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer wrkbl, itaup, itauq;
+ logical wntqa;
+ integer nwork;
+ logical wntqn, wntqo, wntqs;
+ extern /* Subroutine */ int zlacp2_(char *, integer *, integer *,
+ doublereal *, integer *, doublecomplex *, integer *);
+ integer mnthr1, mnthr2;
+ extern /* Subroutine */ int dbdsdc_(char *, char *, integer *, doublereal
+ *, doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), xerbla_(char *, integer *),
+ zgebrd_(integer *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ doublereal bignum;
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zgelqf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *
+), zlacrm_(integer *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *, doublecomplex *, integer *, doublereal *)
+ , zlarcm_(integer *, integer *, doublereal *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *), zlascl_(char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublecomplex *, integer *,
+ integer *), zgeqrf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *
+);
+ integer ldwrkl;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *);
+ integer ldwrkr, minwrk, ldwrku, maxwrk;
+ extern /* Subroutine */ int zungbr_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+ integer ldwkvt;
+ doublereal smlnum;
+ logical wntqas;
+ extern /* Subroutine */ int zunmbr_(char *, char *, char *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+), zunglq_(integer *, integer *, integer *
+, doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+ integer nrwork;
+ extern /* Subroutine */ int zungqr_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+/* 8-15-00: Improve consistency of WS calculations (eca) */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGESDD computes the singular value decomposition (SVD) of a complex */
+/* M-by-N matrix A, optionally computing the left and/or right singular */
+/* vectors, by using divide-and-conquer method. The SVD is written */
+
+/* A = U * SIGMA * conjugate-transpose(V) */
+
+/* where SIGMA is an M-by-N matrix which is zero except for its */
+/* min(m,n) diagonal elements, U is an M-by-M unitary matrix, and */
+/* V is an N-by-N unitary matrix. The diagonal elements of SIGMA */
+/* are the singular values of A; they are real and non-negative, and */
+/* are returned in descending order. The first min(m,n) columns of */
+/* U and V are the left and right singular vectors of A. */
+
+/* Note that the routine returns VT = V**H, not V. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* Specifies options for computing all or part of the matrix U: */
+/* = 'A': all M columns of U and all N rows of V**H are */
+/* returned in the arrays U and VT; */
+/* = 'S': the first min(M,N) columns of U and the first */
+/* min(M,N) rows of V**H are returned in the arrays U */
+/* and VT; */
+/* = 'O': If M >= N, the first N columns of U are overwritten */
+/* in the array A and all rows of V**H are returned in */
+/* the array VT; */
+/* otherwise, all columns of U are returned in the */
+/* array U and the first M rows of V**H are overwritten */
+/* in the array A; */
+/* = 'N': no columns of U or rows of V**H are computed. */
+
+/* M (input) INTEGER */
+/* The number of rows of the input matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the input matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, */
+/* if JOBZ = 'O', A is overwritten with the first N columns */
+/* of U (the left singular vectors, stored */
+/* columnwise) if M >= N; */
+/* A is overwritten with the first M rows */
+/* of V**H (the right singular vectors, stored */
+/* rowwise) otherwise. */
+/* if JOBZ .ne. 'O', the contents of A are destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* S (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The singular values of A, sorted so that S(i) >= S(i+1). */
+
+/* U (output) COMPLEX*16 array, dimension (LDU,UCOL) */
+/* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N; */
+/* UCOL = min(M,N) if JOBZ = 'S'. */
+/* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M */
+/* unitary matrix U; */
+/* if JOBZ = 'S', U contains the first min(M,N) columns of U */
+/* (the left singular vectors, stored columnwise); */
+/* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= 1; if */
+/* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M. */
+
+/* VT (output) COMPLEX*16 array, dimension (LDVT,N) */
+/* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the */
+/* N-by-N unitary matrix V**H; */
+/* if JOBZ = 'S', VT contains the first min(M,N) rows of */
+/* V**H (the right singular vectors, stored rowwise); */
+/* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. LDVT >= 1; if */
+/* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N; */
+/* if JOBZ = 'S', LDVT >= min(M,N). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= 1. */
+/* if JOBZ = 'N', LWORK >= 2*min(M,N)+max(M,N). */
+/* if JOBZ = 'O', */
+/* LWORK >= 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N). */
+/* if JOBZ = 'S' or 'A', */
+/* LWORK >= min(M,N)*min(M,N)+2*min(M,N)+max(M,N). */
+/* For good performance, LWORK should generally be larger. */
+
+/* If LWORK = -1, a workspace query is assumed. The optimal */
+/* size for the WORK array is calculated and stored in WORK(1), */
+/* and no other work except argument checking is performed. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LRWORK)) */
+/* If JOBZ = 'N', LRWORK >= 5*min(M,N). */
+/* Otherwise, LRWORK >= 5*min(M,N)*min(M,N) + 7*min(M,N) */
+
+/* IWORK (workspace) INTEGER array, dimension (8*min(M,N)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: The updating process of DBDSDC did not converge. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ minmn = min(*m,*n);
+ mnthr1 = (integer) (minmn * 17. / 9.);
+ mnthr2 = (integer) (minmn * 5. / 3.);
+ wntqa = lsame_(jobz, "A");
+ wntqs = lsame_(jobz, "S");
+ wntqas = wntqa || wntqs;
+ wntqo = lsame_(jobz, "O");
+ wntqn = lsame_(jobz, "N");
+ minwrk = 1;
+ maxwrk = 1;
+
+ if (! (wntqa || wntqs || wntqo || wntqn)) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldu < 1 || wntqas && *ldu < *m || wntqo && *m < *n && *ldu < *
+ m) {
+ *info = -8;
+ } else if (*ldvt < 1 || wntqa && *ldvt < *n || wntqs && *ldvt < minmn ||
+ wntqo && *m >= *n && *ldvt < *n) {
+ *info = -10;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* CWorkspace refers to complex workspace, and RWorkspace to */
+/* real workspace. NB refers to the optimal block size for the */
+/* immediately following subroutine, as returned by ILAENV.) */
+
+ if (*info == 0 && *m > 0 && *n > 0) {
+ if (*m >= *n) {
+
+/* There is no complex work space needed for bidiagonal SVD */
+/* The real work space needed for bidiagonal SVD is BDSPAC */
+/* for computing singular values and singular vectors; BDSPAN */
+/* for computing singular values only. */
+/* BDSPAC = 5*N*N + 7*N */
+/* BDSPAN = MAX(7*N+4, 3*N+2+SMLSIZ*(SMLSIZ+8)) */
+
+ if (*m >= mnthr1) {
+ if (wntqn) {
+
+/* Path 1 (M much larger than N, JOBZ='N') */
+
+ maxwrk = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+ minwrk = *n * 3;
+ } else if (wntqo) {
+
+/* Path 2 (M much larger than N, JOBZ='O') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n + *n * ilaenv_(&c__1, "ZUNGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNMBR", "QLN", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNMBR", "PRC", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+ maxwrk = *m * *n + *n * *n + wrkbl;
+ minwrk = (*n << 1) * *n + *n * 3;
+ } else if (wntqs) {
+
+/* Path 3 (M much larger than N, JOBZ='S') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n + *n * ilaenv_(&c__1, "ZUNGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNMBR", "QLN", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNMBR", "PRC", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+ maxwrk = *n * *n + wrkbl;
+ minwrk = *n * *n + *n * 3;
+ } else if (wntqa) {
+
+/* Path 4 (M much larger than N, JOBZ='A') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *n + *m * ilaenv_(&c__1, "ZUNGQR",
+ " ", m, m, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNMBR", "QLN", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNMBR", "PRC", n, n, n, &c_n1);
+ wrkbl = max(i__1,i__2);
+ maxwrk = *n * *n + wrkbl;
+ minwrk = *n * *n + (*n << 1) + *m;
+ }
+ } else if (*m >= mnthr2) {
+
+/* Path 5 (M much larger than N, but not as much as MNTHR1) */
+
+ maxwrk = (*n << 1) + (*m + *n) * ilaenv_(&c__1, "ZGEBRD",
+ " ", m, n, &c_n1, &c_n1);
+ minwrk = (*n << 1) + *m;
+ if (wntqo) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNGBR", "P", n, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNGBR", "Q", m, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ maxwrk += *m * *n;
+ minwrk += *n * *n;
+ } else if (wntqs) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNGBR", "P", n, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNGBR", "Q", m, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ } else if (wntqa) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNGBR", "P", n, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *m * ilaenv_(&c__1,
+ "ZUNGBR", "Q", m, m, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ }
+ } else {
+
+/* Path 6 (M at least N, but not much larger) */
+
+ maxwrk = (*n << 1) + (*m + *n) * ilaenv_(&c__1, "ZGEBRD",
+ " ", m, n, &c_n1, &c_n1);
+ minwrk = (*n << 1) + *m;
+ if (wntqo) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNMBR", "PRC", n, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNMBR", "QLN", m, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ maxwrk += *m * *n;
+ minwrk += *n * *n;
+ } else if (wntqs) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNMBR", "PRC", n, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNMBR", "QLN", m, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ } else if (wntqa) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNGBR", "PRC", n, n, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*n << 1) + *m * ilaenv_(&c__1,
+ "ZUNGBR", "QLN", m, m, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ }
+ }
+ } else {
+
+/* There is no complex work space needed for bidiagonal SVD */
+/* The real work space needed for bidiagonal SVD is BDSPAC */
+/* for computing singular values and singular vectors; BDSPAN */
+/* for computing singular values only. */
+/* BDSPAC = 5*M*M + 7*M */
+/* BDSPAN = MAX(7*M+4, 3*M+2+SMLSIZ*(SMLSIZ+8)) */
+
+ if (*n >= mnthr1) {
+ if (wntqn) {
+
+/* Path 1t (N much larger than M, JOBZ='N') */
+
+ maxwrk = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+ minwrk = *m * 3;
+ } else if (wntqo) {
+
+/* Path 2t (N much larger than M, JOBZ='O') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m + *m * ilaenv_(&c__1, "ZUNGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNMBR", "PRC", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNMBR", "QLN", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+ maxwrk = *m * *n + *m * *m + wrkbl;
+ minwrk = (*m << 1) * *m + *m * 3;
+ } else if (wntqs) {
+
+/* Path 3t (N much larger than M, JOBZ='S') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m + *m * ilaenv_(&c__1, "ZUNGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNMBR", "PRC", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNMBR", "QLN", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+ maxwrk = *m * *m + wrkbl;
+ minwrk = *m * *m + *m * 3;
+ } else if (wntqa) {
+
+/* Path 4t (N much larger than M, JOBZ='A') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = *m + *n * ilaenv_(&c__1, "ZUNGLQ",
+ " ", n, n, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNMBR", "PRC", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = wrkbl, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNMBR", "QLN", m, m, m, &c_n1);
+ wrkbl = max(i__1,i__2);
+ maxwrk = *m * *m + wrkbl;
+ minwrk = *m * *m + (*m << 1) + *n;
+ }
+ } else if (*n >= mnthr2) {
+
+/* Path 5t (N much larger than M, but not as much as MNTHR1) */
+
+ maxwrk = (*m << 1) + (*m + *n) * ilaenv_(&c__1, "ZGEBRD",
+ " ", m, n, &c_n1, &c_n1);
+ minwrk = (*m << 1) + *n;
+ if (wntqo) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNGBR", "P", m, n, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNGBR", "Q", m, m, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ maxwrk += *m * *n;
+ minwrk += *m * *m;
+ } else if (wntqs) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNGBR", "P", m, n, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNGBR", "Q", m, m, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ } else if (wntqa) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *n * ilaenv_(&c__1,
+ "ZUNGBR", "P", n, n, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNGBR", "Q", m, m, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ }
+ } else {
+
+/* Path 6t (N greater than M, but not much larger) */
+
+ maxwrk = (*m << 1) + (*m + *n) * ilaenv_(&c__1, "ZGEBRD",
+ " ", m, n, &c_n1, &c_n1);
+ minwrk = (*m << 1) + *n;
+ if (wntqo) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNMBR", "PRC", m, n, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNMBR", "QLN", m, m, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ maxwrk += *m * *n;
+ minwrk += *m * *m;
+ } else if (wntqs) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNGBR", "PRC", m, n, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNGBR", "QLN", m, m, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ } else if (wntqa) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *n * ilaenv_(&c__1,
+ "ZUNGBR", "PRC", n, n, m, &c_n1);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNGBR", "QLN", m, m, n, &c_n1);
+ maxwrk = max(i__1,i__2);
+ }
+ }
+ }
+ maxwrk = max(maxwrk,minwrk);
+ }
+ if (*info == 0) {
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+ if (*lwork < minwrk && *lwork != -1) {
+ *info = -13;
+ }
+ }
+
+/* Quick returns */
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGESDD", &i__1);
+ return 0;
+ }
+ if (*lwork == -1) {
+ return 0;
+ }
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ smlnum = sqrt(dlamch_("S")) / eps;
+ bignum = 1. / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = zlange_("M", m, n, &a[a_offset], lda, dum);
+ iscl = 0;
+ if (anrm > 0. && anrm < smlnum) {
+ iscl = 1;
+ zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, &
+ ierr);
+ } else if (anrm > bignum) {
+ iscl = 1;
+ zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+ if (*m >= *n) {
+
+/* A has at least as many rows as columns. If A has sufficiently */
+/* more rows than columns, first reduce using the QR */
+/* decomposition (if sufficient workspace available) */
+
+ if (*m >= mnthr1) {
+
+ if (wntqn) {
+
+/* Path 1 (M much larger than N, JOBZ='N') */
+/* No singular vectors to be computed */
+
+ itau = 1;
+ nwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: need 0) */
+
+ i__1 = *lwork - nwork + 1;
+ zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__1, &ierr);
+
+/* Zero out below R */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &a[a_dim1 + 2], lda);
+ ie = 1;
+ itauq = 1;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize R in A */
+/* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__1 = *lwork - nwork + 1;
+ zgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__1, &ierr);
+ nrwork = ie + *n;
+
+/* Perform bidiagonal SVD, compute singular values only */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAN) */
+
+ dbdsdc_("U", "N", n, &s[1], &rwork[ie], dum, &c__1, dum, &
+ c__1, dum, idum, &rwork[nrwork], &iwork[1], info);
+
+ } else if (wntqo) {
+
+/* Path 2 (M much larger than N, JOBZ='O') */
+/* N left singular vectors to be overwritten on A and */
+/* N right singular vectors to be computed in VT */
+
+ iu = 1;
+
+/* WORK(IU) is N by N */
+
+ ldwrku = *n;
+ ir = iu + ldwrku * *n;
+ if (*lwork >= *m * *n + *n * *n + *n * 3) {
+
+/* WORK(IR) is M by N */
+
+ ldwrkr = *m;
+ } else {
+ ldwrkr = (*lwork - *n * *n - *n * 3) / *n;
+ }
+ itau = ir + ldwrkr * *n;
+ nwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (CWorkspace: need N*N+2*N, prefer M*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__1 = *lwork - nwork + 1;
+ zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__1, &ierr);
+
+/* Copy R to WORK( IR ), zeroing out below it */
+
+ zlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr);
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &work[ir + 1], &
+ ldwrkr);
+
+/* Generate Q in A */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__1 = *lwork - nwork + 1;
+ zungqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[nwork],
+ &i__1, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IR) */
+/* (CWorkspace: need N*N+3*N, prefer M*N+2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__1 = *lwork - nwork + 1;
+ zgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__1, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of R in WORK(IRU) and computing right singular vectors */
+/* of R in WORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ iru = ie + *n;
+ irvt = iru + *n * *n;
+ nrwork = irvt + *n * *n;
+ dbdsdc_("U", "I", n, &s[1], &rwork[ie], &rwork[iru], n, &
+ rwork[irvt], n, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Copy real matrix RWORK(IRU) to complex matrix WORK(IU) */
+/* Overwrite WORK(IU) by the left singular vectors of R */
+/* (CWorkspace: need 2*N*N+3*N, prefer M*N+N*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ zlacp2_("F", n, n, &rwork[iru], n, &work[iu], &ldwrku);
+ i__1 = *lwork - nwork + 1;
+ zunmbr_("Q", "L", "N", n, n, n, &work[ir], &ldwrkr, &work[
+ itauq], &work[iu], &ldwrku, &work[nwork], &i__1, &
+ ierr);
+
+/* Copy real matrix RWORK(IRVT) to complex matrix VT */
+/* Overwrite VT by the right singular vectors of R */
+/* (CWorkspace: need N*N+3*N, prefer M*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ zlacp2_("F", n, n, &rwork[irvt], n, &vt[vt_offset], ldvt);
+ i__1 = *lwork - nwork + 1;
+ zunmbr_("P", "R", "C", n, n, n, &work[ir], &ldwrkr, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, &
+ ierr);
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IU), storing result in WORK(IR) and copying to A */
+/* (CWorkspace: need 2*N*N, prefer N*N+M*N) */
+/* (RWorkspace: 0) */
+
+ i__1 = *m;
+ i__2 = ldwrkr;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *m - i__ + 1;
+ chunk = min(i__3,ldwrkr);
+ zgemm_("N", "N", &chunk, n, n, &c_b2, &a[i__ + a_dim1],
+ lda, &work[iu], &ldwrku, &c_b1, &work[ir], &
+ ldwrkr);
+ zlacpy_("F", &chunk, n, &work[ir], &ldwrkr, &a[i__ +
+ a_dim1], lda);
+/* L10: */
+ }
+
+ } else if (wntqs) {
+
+/* Path 3 (M much larger than N, JOBZ='S') */
+/* N left singular vectors to be computed in U and */
+/* N right singular vectors to be computed in VT */
+
+ ir = 1;
+
+/* WORK(IR) is N by N */
+
+ ldwrkr = *n;
+ itau = ir + ldwrkr * *n;
+ nwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - nwork + 1;
+ zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__2, &ierr);
+
+/* Copy R to WORK(IR), zeroing out below it */
+
+ zlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr);
+ i__2 = *n - 1;
+ i__1 = *n - 1;
+ zlaset_("L", &i__2, &i__1, &c_b1, &c_b1, &work[ir + 1], &
+ ldwrkr);
+
+/* Generate Q in A */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - nwork + 1;
+ zungqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[nwork],
+ &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IR) */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - nwork + 1;
+ zgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__2, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ iru = ie + *n;
+ irvt = iru + *n * *n;
+ nrwork = irvt + *n * *n;
+ dbdsdc_("U", "I", n, &s[1], &rwork[ie], &rwork[iru], n, &
+ rwork[irvt], n, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Copy real matrix RWORK(IRU) to complex matrix U */
+/* Overwrite U by left singular vectors of R */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ zlacp2_("F", n, n, &rwork[iru], n, &u[u_offset], ldu);
+ i__2 = *lwork - nwork + 1;
+ zunmbr_("Q", "L", "N", n, n, n, &work[ir], &ldwrkr, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr);
+
+/* Copy real matrix RWORK(IRVT) to complex matrix VT */
+/* Overwrite VT by right singular vectors of R */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ zlacp2_("F", n, n, &rwork[irvt], n, &vt[vt_offset], ldvt);
+ i__2 = *lwork - nwork + 1;
+ zunmbr_("P", "R", "C", n, n, n, &work[ir], &ldwrkr, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, &
+ ierr);
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IR), storing result in U */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: 0) */
+
+ zlacpy_("F", n, n, &u[u_offset], ldu, &work[ir], &ldwrkr);
+ zgemm_("N", "N", m, n, n, &c_b2, &a[a_offset], lda, &work[ir],
+ &ldwrkr, &c_b1, &u[u_offset], ldu);
+
+ } else if (wntqa) {
+
+/* Path 4 (M much larger than N, JOBZ='A') */
+/* M left singular vectors to be computed in U and */
+/* N right singular vectors to be computed in VT */
+
+ iu = 1;
+
+/* WORK(IU) is N by N */
+
+ ldwrku = *n;
+ itau = iu + ldwrku * *n;
+ nwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - nwork + 1;
+ zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__2, &ierr);
+ zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu);
+
+/* Generate Q in U */
+/* (CWorkspace: need N+M, prefer N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - nwork + 1;
+ zungqr_(m, m, n, &u[u_offset], ldu, &work[itau], &work[nwork],
+ &i__2, &ierr);
+
+/* Produce R in A, zeroing out below it */
+
+ i__2 = *n - 1;
+ i__1 = *n - 1;
+ zlaset_("L", &i__2, &i__1, &c_b1, &c_b1, &a[a_dim1 + 2], lda);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize R in A */
+/* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - nwork + 1;
+ zgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__2, &ierr);
+ iru = ie + *n;
+ irvt = iru + *n * *n;
+ nrwork = irvt + *n * *n;
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ dbdsdc_("U", "I", n, &s[1], &rwork[ie], &rwork[iru], n, &
+ rwork[irvt], n, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Copy real matrix RWORK(IRU) to complex matrix WORK(IU) */
+/* Overwrite WORK(IU) by left singular vectors of R */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ zlacp2_("F", n, n, &rwork[iru], n, &work[iu], &ldwrku);
+ i__2 = *lwork - nwork + 1;
+ zunmbr_("Q", "L", "N", n, n, n, &a[a_offset], lda, &work[
+ itauq], &work[iu], &ldwrku, &work[nwork], &i__2, &
+ ierr);
+
+/* Copy real matrix RWORK(IRVT) to complex matrix VT */
+/* Overwrite VT by right singular vectors of R */
+/* (CWorkspace: need 3*N, prefer 2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ zlacp2_("F", n, n, &rwork[irvt], n, &vt[vt_offset], ldvt);
+ i__2 = *lwork - nwork + 1;
+ zunmbr_("P", "R", "C", n, n, n, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, &
+ ierr);
+
+/* Multiply Q in U by left singular vectors of R in */
+/* WORK(IU), storing result in A */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: 0) */
+
+ zgemm_("N", "N", m, n, n, &c_b2, &u[u_offset], ldu, &work[iu],
+ &ldwrku, &c_b1, &a[a_offset], lda);
+
+/* Copy left singular vectors of A from A to U */
+
+ zlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset], ldu);
+
+ }
+
+ } else if (*m >= mnthr2) {
+
+/* MNTHR2 <= M < MNTHR1 */
+
+/* Path 5 (M much larger than N, but not as much as MNTHR1) */
+/* Reduce to bidiagonal form without QR decomposition, use */
+/* ZUNGBR and matrix multiplication to compute singular vectors */
+
+ ie = 1;
+ nrwork = ie + *n;
+ itauq = 1;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize A */
+/* (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - nwork + 1;
+ zgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq],
+ &work[itaup], &work[nwork], &i__2, &ierr);
+ if (wntqn) {
+
+/* Compute singular values only */
+/* (Cworkspace: 0) */
+/* (Rworkspace: need BDSPAN) */
+
+ dbdsdc_("U", "N", n, &s[1], &rwork[ie], dum, &c__1, dum, &
+ c__1, dum, idum, &rwork[nrwork], &iwork[1], info);
+ } else if (wntqo) {
+ iu = nwork;
+ iru = nrwork;
+ irvt = iru + *n * *n;
+ nrwork = irvt + *n * *n;
+
+/* Copy A to VT, generate P**H */
+/* (Cworkspace: need 2*N, prefer N+N*NB) */
+/* (Rworkspace: 0) */
+
+ zlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+ i__2 = *lwork - nwork + 1;
+ zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], &
+ work[nwork], &i__2, &ierr);
+
+/* Generate Q in A */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - nwork + 1;
+ zungbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], &work[
+ nwork], &i__2, &ierr);
+
+ if (*lwork >= *m * *n + *n * 3) {
+
+/* WORK( IU ) is M by N */
+
+ ldwrku = *m;
+ } else {
+
+/* WORK(IU) is LDWRKU by N */
+
+ ldwrku = (*lwork - *n * 3) / *n;
+ }
+ nwork = iu + ldwrku * *n;
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ dbdsdc_("U", "I", n, &s[1], &rwork[ie], &rwork[iru], n, &
+ rwork[irvt], n, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Multiply real matrix RWORK(IRVT) by P**H in VT, */
+/* storing the result in WORK(IU), copying to VT */
+/* (Cworkspace: need 0) */
+/* (Rworkspace: need 3*N*N) */
+
+ zlarcm_(n, n, &rwork[irvt], n, &vt[vt_offset], ldvt, &work[iu]
+, &ldwrku, &rwork[nrwork]);
+ zlacpy_("F", n, n, &work[iu], &ldwrku, &vt[vt_offset], ldvt);
+
+/* Multiply Q in A by real matrix RWORK(IRU), storing the */
+/* result in WORK(IU), copying to A */
+/* (CWorkspace: need N*N, prefer M*N) */
+/* (Rworkspace: need 3*N*N, prefer N*N+2*M*N) */
+
+ nrwork = irvt;
+ i__2 = *m;
+ i__1 = ldwrku;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
+ i__1) {
+/* Computing MIN */
+ i__3 = *m - i__ + 1;
+ chunk = min(i__3,ldwrku);
+ zlacrm_(&chunk, n, &a[i__ + a_dim1], lda, &rwork[iru], n,
+ &work[iu], &ldwrku, &rwork[nrwork]);
+ zlacpy_("F", &chunk, n, &work[iu], &ldwrku, &a[i__ +
+ a_dim1], lda);
+/* L20: */
+ }
+
+ } else if (wntqs) {
+
+/* Copy A to VT, generate P**H */
+/* (Cworkspace: need 2*N, prefer N+N*NB) */
+/* (Rworkspace: 0) */
+
+ zlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+ i__1 = *lwork - nwork + 1;
+ zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], &
+ work[nwork], &i__1, &ierr);
+
+/* Copy A to U, generate Q */
+/* (Cworkspace: need 2*N, prefer N+N*NB) */
+/* (Rworkspace: 0) */
+
+ zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu);
+ i__1 = *lwork - nwork + 1;
+ zungbr_("Q", m, n, n, &u[u_offset], ldu, &work[itauq], &work[
+ nwork], &i__1, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ iru = nrwork;
+ irvt = iru + *n * *n;
+ nrwork = irvt + *n * *n;
+ dbdsdc_("U", "I", n, &s[1], &rwork[ie], &rwork[iru], n, &
+ rwork[irvt], n, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Multiply real matrix RWORK(IRVT) by P**H in VT, */
+/* storing the result in A, copying to VT */
+/* (Cworkspace: need 0) */
+/* (Rworkspace: need 3*N*N) */
+
+ zlarcm_(n, n, &rwork[irvt], n, &vt[vt_offset], ldvt, &a[
+ a_offset], lda, &rwork[nrwork]);
+ zlacpy_("F", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+
+/* Multiply Q in U by real matrix RWORK(IRU), storing the */
+/* result in A, copying to U */
+/* (CWorkspace: need 0) */
+/* (Rworkspace: need N*N+2*M*N) */
+
+ nrwork = irvt;
+ zlacrm_(m, n, &u[u_offset], ldu, &rwork[iru], n, &a[a_offset],
+ lda, &rwork[nrwork]);
+ zlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset], ldu);
+ } else {
+
+/* Copy A to VT, generate P**H */
+/* (Cworkspace: need 2*N, prefer N+N*NB) */
+/* (Rworkspace: 0) */
+
+ zlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+ i__1 = *lwork - nwork + 1;
+ zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], &
+ work[nwork], &i__1, &ierr);
+
+/* Copy A to U, generate Q */
+/* (Cworkspace: need 2*N, prefer N+N*NB) */
+/* (Rworkspace: 0) */
+
+ zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu);
+ i__1 = *lwork - nwork + 1;
+ zungbr_("Q", m, m, n, &u[u_offset], ldu, &work[itauq], &work[
+ nwork], &i__1, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ iru = nrwork;
+ irvt = iru + *n * *n;
+ nrwork = irvt + *n * *n;
+ dbdsdc_("U", "I", n, &s[1], &rwork[ie], &rwork[iru], n, &
+ rwork[irvt], n, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Multiply real matrix RWORK(IRVT) by P**H in VT, */
+/* storing the result in A, copying to VT */
+/* (Cworkspace: need 0) */
+/* (Rworkspace: need 3*N*N) */
+
+ zlarcm_(n, n, &rwork[irvt], n, &vt[vt_offset], ldvt, &a[
+ a_offset], lda, &rwork[nrwork]);
+ zlacpy_("F", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+
+/* Multiply Q in U by real matrix RWORK(IRU), storing the */
+/* result in A, copying to U */
+/* (CWorkspace: 0) */
+/* (Rworkspace: need 3*N*N) */
+
+ nrwork = irvt;
+ zlacrm_(m, n, &u[u_offset], ldu, &rwork[iru], n, &a[a_offset],
+ lda, &rwork[nrwork]);
+ zlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset], ldu);
+ }
+
+ } else {
+
+/* M .LT. MNTHR2 */
+
+/* Path 6 (M at least N, but not much larger) */
+/* Reduce to bidiagonal form without QR decomposition */
+/* Use ZUNMBR to compute singular vectors */
+
+ ie = 1;
+ nrwork = ie + *n;
+ itauq = 1;
+ itaup = itauq + *n;
+ nwork = itaup + *n;
+
+/* Bidiagonalize A */
+/* (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB) */
+/* (RWorkspace: need N) */
+
+ i__1 = *lwork - nwork + 1;
+ zgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq],
+ &work[itaup], &work[nwork], &i__1, &ierr);
+ if (wntqn) {
+
+/* Compute singular values only */
+/* (Cworkspace: 0) */
+/* (Rworkspace: need BDSPAN) */
+
+ dbdsdc_("U", "N", n, &s[1], &rwork[ie], dum, &c__1, dum, &
+ c__1, dum, idum, &rwork[nrwork], &iwork[1], info);
+ } else if (wntqo) {
+ iu = nwork;
+ iru = nrwork;
+ irvt = iru + *n * *n;
+ nrwork = irvt + *n * *n;
+ if (*lwork >= *m * *n + *n * 3) {
+
+/* WORK( IU ) is M by N */
+
+ ldwrku = *m;
+ } else {
+
+/* WORK( IU ) is LDWRKU by N */
+
+ ldwrku = (*lwork - *n * 3) / *n;
+ }
+ nwork = iu + ldwrku * *n;
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ dbdsdc_("U", "I", n, &s[1], &rwork[ie], &rwork[iru], n, &
+ rwork[irvt], n, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Copy real matrix RWORK(IRVT) to complex matrix VT */
+/* Overwrite VT by right singular vectors of A */
+/* (Cworkspace: need 2*N, prefer N+N*NB) */
+/* (Rworkspace: need 0) */
+
+ zlacp2_("F", n, n, &rwork[irvt], n, &vt[vt_offset], ldvt);
+ i__1 = *lwork - nwork + 1;
+ zunmbr_("P", "R", "C", n, n, n, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, &
+ ierr);
+
+ if (*lwork >= *m * *n + *n * 3) {
+
+/* Copy real matrix RWORK(IRU) to complex matrix WORK(IU) */
+/* Overwrite WORK(IU) by left singular vectors of A, copying */
+/* to A */
+/* (Cworkspace: need M*N+2*N, prefer M*N+N+N*NB) */
+/* (Rworkspace: need 0) */
+
+ zlaset_("F", m, n, &c_b1, &c_b1, &work[iu], &ldwrku);
+ zlacp2_("F", n, n, &rwork[iru], n, &work[iu], &ldwrku);
+ i__1 = *lwork - nwork + 1;
+ zunmbr_("Q", "L", "N", m, n, n, &a[a_offset], lda, &work[
+ itauq], &work[iu], &ldwrku, &work[nwork], &i__1, &
+ ierr);
+ zlacpy_("F", m, n, &work[iu], &ldwrku, &a[a_offset], lda);
+ } else {
+
+/* Generate Q in A */
+/* (Cworkspace: need 2*N, prefer N+N*NB) */
+/* (Rworkspace: need 0) */
+
+ i__1 = *lwork - nwork + 1;
+ zungbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], &
+ work[nwork], &i__1, &ierr);
+
+/* Multiply Q in A by real matrix RWORK(IRU), storing the */
+/* result in WORK(IU), copying to A */
+/* (CWorkspace: need N*N, prefer M*N) */
+/* (Rworkspace: need 3*N*N, prefer N*N+2*M*N) */
+
+ nrwork = irvt;
+ i__1 = *m;
+ i__2 = ldwrku;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *m - i__ + 1;
+ chunk = min(i__3,ldwrku);
+ zlacrm_(&chunk, n, &a[i__ + a_dim1], lda, &rwork[iru],
+ n, &work[iu], &ldwrku, &rwork[nrwork]);
+ zlacpy_("F", &chunk, n, &work[iu], &ldwrku, &a[i__ +
+ a_dim1], lda);
+/* L30: */
+ }
+ }
+
+ } else if (wntqs) {
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ iru = nrwork;
+ irvt = iru + *n * *n;
+ nrwork = irvt + *n * *n;
+ dbdsdc_("U", "I", n, &s[1], &rwork[ie], &rwork[iru], n, &
+ rwork[irvt], n, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Copy real matrix RWORK(IRU) to complex matrix U */
+/* Overwrite U by left singular vectors of A */
+/* (CWorkspace: need 3*N, prefer 2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ zlaset_("F", m, n, &c_b1, &c_b1, &u[u_offset], ldu)
+ ;
+ zlacp2_("F", n, n, &rwork[iru], n, &u[u_offset], ldu);
+ i__2 = *lwork - nwork + 1;
+ zunmbr_("Q", "L", "N", m, n, n, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr);
+
+/* Copy real matrix RWORK(IRVT) to complex matrix VT */
+/* Overwrite VT by right singular vectors of A */
+/* (CWorkspace: need 3*N, prefer 2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ zlacp2_("F", n, n, &rwork[irvt], n, &vt[vt_offset], ldvt);
+ i__2 = *lwork - nwork + 1;
+ zunmbr_("P", "R", "C", n, n, n, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, &
+ ierr);
+ } else {
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ iru = nrwork;
+ irvt = iru + *n * *n;
+ nrwork = irvt + *n * *n;
+ dbdsdc_("U", "I", n, &s[1], &rwork[ie], &rwork[iru], n, &
+ rwork[irvt], n, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Set the right corner of U to identity matrix */
+
+ zlaset_("F", m, m, &c_b1, &c_b1, &u[u_offset], ldu)
+ ;
+ if (*m > *n) {
+ i__2 = *m - *n;
+ i__1 = *m - *n;
+ zlaset_("F", &i__2, &i__1, &c_b1, &c_b2, &u[*n + 1 + (*n
+ + 1) * u_dim1], ldu);
+ }
+
+/* Copy real matrix RWORK(IRU) to complex matrix U */
+/* Overwrite U by left singular vectors of A */
+/* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) */
+/* (RWorkspace: 0) */
+
+ zlacp2_("F", n, n, &rwork[iru], n, &u[u_offset], ldu);
+ i__2 = *lwork - nwork + 1;
+ zunmbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr);
+
+/* Copy real matrix RWORK(IRVT) to complex matrix VT */
+/* Overwrite VT by right singular vectors of A */
+/* (CWorkspace: need 3*N, prefer 2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ zlacp2_("F", n, n, &rwork[irvt], n, &vt[vt_offset], ldvt);
+ i__2 = *lwork - nwork + 1;
+ zunmbr_("P", "R", "C", n, n, n, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__2, &
+ ierr);
+ }
+
+ }
+
+ } else {
+
+/* A has more columns than rows. If A has sufficiently more */
+/* columns than rows, first reduce using the LQ decomposition (if */
+/* sufficient workspace available) */
+
+ if (*n >= mnthr1) {
+
+ if (wntqn) {
+
+/* Path 1t (N much larger than M, JOBZ='N') */
+/* No singular vectors to be computed */
+
+ itau = 1;
+ nwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - nwork + 1;
+ zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__2, &ierr);
+
+/* Zero out above L */
+
+ i__2 = *m - 1;
+ i__1 = *m - 1;
+ zlaset_("U", &i__2, &i__1, &c_b1, &c_b1, &a[(a_dim1 << 1) + 1]
+, lda);
+ ie = 1;
+ itauq = 1;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize L in A */
+/* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - nwork + 1;
+ zgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__2, &ierr);
+ nrwork = ie + *m;
+
+/* Perform bidiagonal SVD, compute singular values only */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAN) */
+
+ dbdsdc_("U", "N", m, &s[1], &rwork[ie], dum, &c__1, dum, &
+ c__1, dum, idum, &rwork[nrwork], &iwork[1], info);
+
+ } else if (wntqo) {
+
+/* Path 2t (N much larger than M, JOBZ='O') */
+/* M right singular vectors to be overwritten on A and */
+/* M left singular vectors to be computed in U */
+
+ ivt = 1;
+ ldwkvt = *m;
+
+/* WORK(IVT) is M by M */
+
+ il = ivt + ldwkvt * *m;
+ if (*lwork >= *m * *n + *m * *m + *m * 3) {
+
+/* WORK(IL) M by N */
+
+ ldwrkl = *m;
+ chunk = *n;
+ } else {
+
+/* WORK(IL) is M by CHUNK */
+
+ ldwrkl = *m;
+ chunk = (*lwork - *m * *m - *m * 3) / *m;
+ }
+ itau = il + ldwrkl * chunk;
+ nwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - nwork + 1;
+ zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__2, &ierr);
+
+/* Copy L to WORK(IL), zeroing about above it */
+
+ zlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwrkl);
+ i__2 = *m - 1;
+ i__1 = *m - 1;
+ zlaset_("U", &i__2, &i__1, &c_b1, &c_b1, &work[il + ldwrkl], &
+ ldwrkl);
+
+/* Generate Q in A */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - nwork + 1;
+ zunglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[nwork],
+ &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IL) */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - nwork + 1;
+ zgebrd_(m, m, &work[il], &ldwrkl, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__2, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ iru = ie + *m;
+ irvt = iru + *m * *m;
+ nrwork = irvt + *m * *m;
+ dbdsdc_("U", "I", m, &s[1], &rwork[ie], &rwork[iru], m, &
+ rwork[irvt], m, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Copy real matrix RWORK(IRU) to complex matrix WORK(IU) */
+/* Overwrite WORK(IU) by the left singular vectors of L */
+/* (CWorkspace: need N*N+3*N, prefer M*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ zlacp2_("F", m, m, &rwork[iru], m, &u[u_offset], ldu);
+ i__2 = *lwork - nwork + 1;
+ zunmbr_("Q", "L", "N", m, m, m, &work[il], &ldwrkl, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr);
+
+/* Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT) */
+/* Overwrite WORK(IVT) by the right singular vectors of L */
+/* (CWorkspace: need N*N+3*N, prefer M*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ zlacp2_("F", m, m, &rwork[irvt], m, &work[ivt], &ldwkvt);
+ i__2 = *lwork - nwork + 1;
+ zunmbr_("P", "R", "C", m, m, m, &work[il], &ldwrkl, &work[
+ itaup], &work[ivt], &ldwkvt, &work[nwork], &i__2, &
+ ierr);
+
+/* Multiply right singular vectors of L in WORK(IL) by Q */
+/* in A, storing result in WORK(IL) and copying to A */
+/* (CWorkspace: need 2*M*M, prefer M*M+M*N)) */
+/* (RWorkspace: 0) */
+
+ i__2 = *n;
+ i__1 = chunk;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
+ i__1) {
+/* Computing MIN */
+ i__3 = *n - i__ + 1;
+ blk = min(i__3,chunk);
+ zgemm_("N", "N", m, &blk, m, &c_b2, &work[ivt], m, &a[i__
+ * a_dim1 + 1], lda, &c_b1, &work[il], &ldwrkl);
+ zlacpy_("F", m, &blk, &work[il], &ldwrkl, &a[i__ * a_dim1
+ + 1], lda);
+/* L40: */
+ }
+
+ } else if (wntqs) {
+
+/* Path 3t (N much larger than M, JOBZ='S') */
+/* M right singular vectors to be computed in VT and */
+/* M left singular vectors to be computed in U */
+
+ il = 1;
+
+/* WORK(IL) is M by M */
+
+ ldwrkl = *m;
+ itau = il + ldwrkl * *m;
+ nwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__1 = *lwork - nwork + 1;
+ zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__1, &ierr);
+
+/* Copy L to WORK(IL), zeroing out above it */
+
+ zlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwrkl);
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ zlaset_("U", &i__1, &i__2, &c_b1, &c_b1, &work[il + ldwrkl], &
+ ldwrkl);
+
+/* Generate Q in A */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__1 = *lwork - nwork + 1;
+ zunglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[nwork],
+ &i__1, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IL) */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__1 = *lwork - nwork + 1;
+ zgebrd_(m, m, &work[il], &ldwrkl, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__1, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ iru = ie + *m;
+ irvt = iru + *m * *m;
+ nrwork = irvt + *m * *m;
+ dbdsdc_("U", "I", m, &s[1], &rwork[ie], &rwork[iru], m, &
+ rwork[irvt], m, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Copy real matrix RWORK(IRU) to complex matrix U */
+/* Overwrite U by left singular vectors of L */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ zlacp2_("F", m, m, &rwork[iru], m, &u[u_offset], ldu);
+ i__1 = *lwork - nwork + 1;
+ zunmbr_("Q", "L", "N", m, m, m, &work[il], &ldwrkl, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr);
+
+/* Copy real matrix RWORK(IRVT) to complex matrix VT */
+/* Overwrite VT by left singular vectors of L */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ zlacp2_("F", m, m, &rwork[irvt], m, &vt[vt_offset], ldvt);
+ i__1 = *lwork - nwork + 1;
+ zunmbr_("P", "R", "C", m, m, m, &work[il], &ldwrkl, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, &
+ ierr);
+
+/* Copy VT to WORK(IL), multiply right singular vectors of L */
+/* in WORK(IL) by Q in A, storing result in VT */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: 0) */
+
+ zlacpy_("F", m, m, &vt[vt_offset], ldvt, &work[il], &ldwrkl);
+ zgemm_("N", "N", m, n, m, &c_b2, &work[il], &ldwrkl, &a[
+ a_offset], lda, &c_b1, &vt[vt_offset], ldvt);
+
+ } else if (wntqa) {
+
+/* Path 9t (N much larger than M, JOBZ='A') */
+/* N right singular vectors to be computed in VT and */
+/* M left singular vectors to be computed in U */
+
+ ivt = 1;
+
+/* WORK(IVT) is M by M */
+
+ ldwkvt = *m;
+ itau = ivt + ldwkvt * *m;
+ nwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__1 = *lwork - nwork + 1;
+ zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &
+ i__1, &ierr);
+ zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+
+/* Generate Q in VT */
+/* (CWorkspace: need M+N, prefer M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__1 = *lwork - nwork + 1;
+ zunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &work[
+ nwork], &i__1, &ierr);
+
+/* Produce L in A, zeroing out above it */
+
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ zlaset_("U", &i__1, &i__2, &c_b1, &c_b1, &a[(a_dim1 << 1) + 1]
+, lda);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize L in A */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__1 = *lwork - nwork + 1;
+ zgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[nwork], &i__1, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ iru = ie + *m;
+ irvt = iru + *m * *m;
+ nrwork = irvt + *m * *m;
+ dbdsdc_("U", "I", m, &s[1], &rwork[ie], &rwork[iru], m, &
+ rwork[irvt], m, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Copy real matrix RWORK(IRU) to complex matrix U */
+/* Overwrite U by left singular vectors of L */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ zlacp2_("F", m, m, &rwork[iru], m, &u[u_offset], ldu);
+ i__1 = *lwork - nwork + 1;
+ zunmbr_("Q", "L", "N", m, m, m, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr);
+
+/* Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT) */
+/* Overwrite WORK(IVT) by right singular vectors of L */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ zlacp2_("F", m, m, &rwork[irvt], m, &work[ivt], &ldwkvt);
+ i__1 = *lwork - nwork + 1;
+ zunmbr_("P", "R", "C", m, m, m, &a[a_offset], lda, &work[
+ itaup], &work[ivt], &ldwkvt, &work[nwork], &i__1, &
+ ierr);
+
+/* Multiply right singular vectors of L in WORK(IVT) by */
+/* Q in VT, storing result in A */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: 0) */
+
+ zgemm_("N", "N", m, n, m, &c_b2, &work[ivt], &ldwkvt, &vt[
+ vt_offset], ldvt, &c_b1, &a[a_offset], lda);
+
+/* Copy right singular vectors of A from A to VT */
+
+ zlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+
+ }
+
+ } else if (*n >= mnthr2) {
+
+/* MNTHR2 <= N < MNTHR1 */
+
+/* Path 5t (N much larger than M, but not as much as MNTHR1) */
+/* Reduce to bidiagonal form without QR decomposition, use */
+/* ZUNGBR and matrix multiplication to compute singular vectors */
+
+
+ ie = 1;
+ nrwork = ie + *m;
+ itauq = 1;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize A */
+/* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) */
+/* (RWorkspace: M) */
+
+ i__1 = *lwork - nwork + 1;
+ zgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq],
+ &work[itaup], &work[nwork], &i__1, &ierr);
+
+ if (wntqn) {
+
+/* Compute singular values only */
+/* (Cworkspace: 0) */
+/* (Rworkspace: need BDSPAN) */
+
+ dbdsdc_("L", "N", m, &s[1], &rwork[ie], dum, &c__1, dum, &
+ c__1, dum, idum, &rwork[nrwork], &iwork[1], info);
+ } else if (wntqo) {
+ irvt = nrwork;
+ iru = irvt + *m * *m;
+ nrwork = iru + *m * *m;
+ ivt = nwork;
+
+/* Copy A to U, generate Q */
+/* (Cworkspace: need 2*M, prefer M+M*NB) */
+/* (Rworkspace: 0) */
+
+ zlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+ i__1 = *lwork - nwork + 1;
+ zungbr_("Q", m, m, n, &u[u_offset], ldu, &work[itauq], &work[
+ nwork], &i__1, &ierr);
+
+/* Generate P**H in A */
+/* (Cworkspace: need 2*M, prefer M+M*NB) */
+/* (Rworkspace: 0) */
+
+ i__1 = *lwork - nwork + 1;
+ zungbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[
+ nwork], &i__1, &ierr);
+
+ ldwkvt = *m;
+ if (*lwork >= *m * *n + *m * 3) {
+
+/* WORK( IVT ) is M by N */
+
+ nwork = ivt + ldwkvt * *n;
+ chunk = *n;
+ } else {
+
+/* WORK( IVT ) is M by CHUNK */
+
+ chunk = (*lwork - *m * 3) / *m;
+ nwork = ivt + ldwkvt * chunk;
+ }
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ dbdsdc_("L", "I", m, &s[1], &rwork[ie], &rwork[iru], m, &
+ rwork[irvt], m, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Multiply Q in U by real matrix RWORK(IRVT) */
+/* storing the result in WORK(IVT), copying to U */
+/* (Cworkspace: need 0) */
+/* (Rworkspace: need 2*M*M) */
+
+ zlacrm_(m, m, &u[u_offset], ldu, &rwork[iru], m, &work[ivt], &
+ ldwkvt, &rwork[nrwork]);
+ zlacpy_("F", m, m, &work[ivt], &ldwkvt, &u[u_offset], ldu);
+
+/* Multiply RWORK(IRVT) by P**H in A, storing the */
+/* result in WORK(IVT), copying to A */
+/* (CWorkspace: need M*M, prefer M*N) */
+/* (Rworkspace: need 2*M*M, prefer 2*M*N) */
+
+ nrwork = iru;
+ i__1 = *n;
+ i__2 = chunk;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *n - i__ + 1;
+ blk = min(i__3,chunk);
+ zlarcm_(m, &blk, &rwork[irvt], m, &a[i__ * a_dim1 + 1],
+ lda, &work[ivt], &ldwkvt, &rwork[nrwork]);
+ zlacpy_("F", m, &blk, &work[ivt], &ldwkvt, &a[i__ *
+ a_dim1 + 1], lda);
+/* L50: */
+ }
+ } else if (wntqs) {
+
+/* Copy A to U, generate Q */
+/* (Cworkspace: need 2*M, prefer M+M*NB) */
+/* (Rworkspace: 0) */
+
+ zlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+ i__2 = *lwork - nwork + 1;
+ zungbr_("Q", m, m, n, &u[u_offset], ldu, &work[itauq], &work[
+ nwork], &i__2, &ierr);
+
+/* Copy A to VT, generate P**H */
+/* (Cworkspace: need 2*M, prefer M+M*NB) */
+/* (Rworkspace: 0) */
+
+ zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+ i__2 = *lwork - nwork + 1;
+ zungbr_("P", m, n, m, &vt[vt_offset], ldvt, &work[itaup], &
+ work[nwork], &i__2, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ irvt = nrwork;
+ iru = irvt + *m * *m;
+ nrwork = iru + *m * *m;
+ dbdsdc_("L", "I", m, &s[1], &rwork[ie], &rwork[iru], m, &
+ rwork[irvt], m, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Multiply Q in U by real matrix RWORK(IRU), storing the */
+/* result in A, copying to U */
+/* (CWorkspace: need 0) */
+/* (Rworkspace: need 3*M*M) */
+
+ zlacrm_(m, m, &u[u_offset], ldu, &rwork[iru], m, &a[a_offset],
+ lda, &rwork[nrwork]);
+ zlacpy_("F", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+
+/* Multiply real matrix RWORK(IRVT) by P**H in VT, */
+/* storing the result in A, copying to VT */
+/* (Cworkspace: need 0) */
+/* (Rworkspace: need M*M+2*M*N) */
+
+ nrwork = iru;
+ zlarcm_(m, n, &rwork[irvt], m, &vt[vt_offset], ldvt, &a[
+ a_offset], lda, &rwork[nrwork]);
+ zlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+ } else {
+
+/* Copy A to U, generate Q */
+/* (Cworkspace: need 2*M, prefer M+M*NB) */
+/* (Rworkspace: 0) */
+
+ zlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+ i__2 = *lwork - nwork + 1;
+ zungbr_("Q", m, m, n, &u[u_offset], ldu, &work[itauq], &work[
+ nwork], &i__2, &ierr);
+
+/* Copy A to VT, generate P**H */
+/* (Cworkspace: need 2*M, prefer M+M*NB) */
+/* (Rworkspace: 0) */
+
+ zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+ i__2 = *lwork - nwork + 1;
+ zungbr_("P", n, n, m, &vt[vt_offset], ldvt, &work[itaup], &
+ work[nwork], &i__2, &ierr);
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ irvt = nrwork;
+ iru = irvt + *m * *m;
+ nrwork = iru + *m * *m;
+ dbdsdc_("L", "I", m, &s[1], &rwork[ie], &rwork[iru], m, &
+ rwork[irvt], m, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Multiply Q in U by real matrix RWORK(IRU), storing the */
+/* result in A, copying to U */
+/* (CWorkspace: need 0) */
+/* (Rworkspace: need 3*M*M) */
+
+ zlacrm_(m, m, &u[u_offset], ldu, &rwork[iru], m, &a[a_offset],
+ lda, &rwork[nrwork]);
+ zlacpy_("F", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+
+/* Multiply real matrix RWORK(IRVT) by P**H in VT, */
+/* storing the result in A, copying to VT */
+/* (Cworkspace: need 0) */
+/* (Rworkspace: need M*M+2*M*N) */
+
+ zlarcm_(m, n, &rwork[irvt], m, &vt[vt_offset], ldvt, &a[
+ a_offset], lda, &rwork[nrwork]);
+ zlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+ }
+
+ } else {
+
+/* N .LT. MNTHR2 */
+
+/* Path 6t (N greater than M, but not much larger) */
+/* Reduce to bidiagonal form without LQ decomposition */
+/* Use ZUNMBR to compute singular vectors */
+
+ ie = 1;
+ nrwork = ie + *m;
+ itauq = 1;
+ itaup = itauq + *m;
+ nwork = itaup + *m;
+
+/* Bidiagonalize A */
+/* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) */
+/* (RWorkspace: M) */
+
+ i__2 = *lwork - nwork + 1;
+ zgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq],
+ &work[itaup], &work[nwork], &i__2, &ierr);
+ if (wntqn) {
+
+/* Compute singular values only */
+/* (Cworkspace: 0) */
+/* (Rworkspace: need BDSPAN) */
+
+ dbdsdc_("L", "N", m, &s[1], &rwork[ie], dum, &c__1, dum, &
+ c__1, dum, idum, &rwork[nrwork], &iwork[1], info);
+ } else if (wntqo) {
+ ldwkvt = *m;
+ ivt = nwork;
+ if (*lwork >= *m * *n + *m * 3) {
+
+/* WORK( IVT ) is M by N */
+
+ zlaset_("F", m, n, &c_b1, &c_b1, &work[ivt], &ldwkvt);
+ nwork = ivt + ldwkvt * *n;
+ } else {
+
+/* WORK( IVT ) is M by CHUNK */
+
+ chunk = (*lwork - *m * 3) / *m;
+ nwork = ivt + ldwkvt * chunk;
+ }
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ irvt = nrwork;
+ iru = irvt + *m * *m;
+ nrwork = iru + *m * *m;
+ dbdsdc_("L", "I", m, &s[1], &rwork[ie], &rwork[iru], m, &
+ rwork[irvt], m, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Copy real matrix RWORK(IRU) to complex matrix U */
+/* Overwrite U by left singular vectors of A */
+/* (Cworkspace: need 2*M, prefer M+M*NB) */
+/* (Rworkspace: need 0) */
+
+ zlacp2_("F", m, m, &rwork[iru], m, &u[u_offset], ldu);
+ i__2 = *lwork - nwork + 1;
+ zunmbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__2, &ierr);
+
+ if (*lwork >= *m * *n + *m * 3) {
+
+/* Copy real matrix RWORK(IRVT) to complex matrix WORK(IVT) */
+/* Overwrite WORK(IVT) by right singular vectors of A, */
+/* copying to A */
+/* (Cworkspace: need M*N+2*M, prefer M*N+M+M*NB) */
+/* (Rworkspace: need 0) */
+
+ zlacp2_("F", m, m, &rwork[irvt], m, &work[ivt], &ldwkvt);
+ i__2 = *lwork - nwork + 1;
+ zunmbr_("P", "R", "C", m, n, m, &a[a_offset], lda, &work[
+ itaup], &work[ivt], &ldwkvt, &work[nwork], &i__2,
+ &ierr);
+ zlacpy_("F", m, n, &work[ivt], &ldwkvt, &a[a_offset], lda);
+ } else {
+
+/* Generate P**H in A */
+/* (Cworkspace: need 2*M, prefer M+M*NB) */
+/* (Rworkspace: need 0) */
+
+ i__2 = *lwork - nwork + 1;
+ zungbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &
+ work[nwork], &i__2, &ierr);
+
+/* Multiply Q in A by real matrix RWORK(IRU), storing the */
+/* result in WORK(IU), copying to A */
+/* (CWorkspace: need M*M, prefer M*N) */
+/* (Rworkspace: need 3*M*M, prefer M*M+2*M*N) */
+
+ nrwork = iru;
+ i__2 = *n;
+ i__1 = chunk;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
+ i__1) {
+/* Computing MIN */
+ i__3 = *n - i__ + 1;
+ blk = min(i__3,chunk);
+ zlarcm_(m, &blk, &rwork[irvt], m, &a[i__ * a_dim1 + 1]
+, lda, &work[ivt], &ldwkvt, &rwork[nrwork]);
+ zlacpy_("F", m, &blk, &work[ivt], &ldwkvt, &a[i__ *
+ a_dim1 + 1], lda);
+/* L60: */
+ }
+ }
+ } else if (wntqs) {
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ irvt = nrwork;
+ iru = irvt + *m * *m;
+ nrwork = iru + *m * *m;
+ dbdsdc_("L", "I", m, &s[1], &rwork[ie], &rwork[iru], m, &
+ rwork[irvt], m, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Copy real matrix RWORK(IRU) to complex matrix U */
+/* Overwrite U by left singular vectors of A */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: M*M) */
+
+ zlacp2_("F", m, m, &rwork[iru], m, &u[u_offset], ldu);
+ i__1 = *lwork - nwork + 1;
+ zunmbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr);
+
+/* Copy real matrix RWORK(IRVT) to complex matrix VT */
+/* Overwrite VT by right singular vectors of A */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: M*M) */
+
+ zlaset_("F", m, n, &c_b1, &c_b1, &vt[vt_offset], ldvt);
+ zlacp2_("F", m, m, &rwork[irvt], m, &vt[vt_offset], ldvt);
+ i__1 = *lwork - nwork + 1;
+ zunmbr_("P", "R", "C", m, n, m, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, &
+ ierr);
+ } else {
+
+/* Perform bidiagonal SVD, computing left singular vectors */
+/* of bidiagonal matrix in RWORK(IRU) and computing right */
+/* singular vectors of bidiagonal matrix in RWORK(IRVT) */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ irvt = nrwork;
+ iru = irvt + *m * *m;
+ nrwork = iru + *m * *m;
+
+ dbdsdc_("L", "I", m, &s[1], &rwork[ie], &rwork[iru], m, &
+ rwork[irvt], m, dum, idum, &rwork[nrwork], &iwork[1],
+ info);
+
+/* Copy real matrix RWORK(IRU) to complex matrix U */
+/* Overwrite U by left singular vectors of A */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: M*M) */
+
+ zlacp2_("F", m, m, &rwork[iru], m, &u[u_offset], ldu);
+ i__1 = *lwork - nwork + 1;
+ zunmbr_("Q", "L", "N", m, m, n, &a[a_offset], lda, &work[
+ itauq], &u[u_offset], ldu, &work[nwork], &i__1, &ierr);
+
+/* Set all of VT to identity matrix */
+
+ zlaset_("F", n, n, &c_b1, &c_b2, &vt[vt_offset], ldvt);
+
+/* Copy real matrix RWORK(IRVT) to complex matrix VT */
+/* Overwrite VT by right singular vectors of A */
+/* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) */
+/* (RWorkspace: M*M) */
+
+ zlacp2_("F", m, m, &rwork[irvt], m, &vt[vt_offset], ldvt);
+ i__1 = *lwork - nwork + 1;
+ zunmbr_("P", "R", "C", n, n, m, &a[a_offset], lda, &work[
+ itaup], &vt[vt_offset], ldvt, &work[nwork], &i__1, &
+ ierr);
+ }
+
+ }
+
+ }
+
+/* Undo scaling if necessary */
+
+ if (iscl == 1) {
+ if (anrm > bignum) {
+ dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, &ierr);
+ }
+ if (*info != 0 && anrm > bignum) {
+ i__1 = minmn - 1;
+ dlascl_("G", &c__0, &c__0, &bignum, &anrm, &i__1, &c__1, &rwork[
+ ie], &minmn, &ierr);
+ }
+ if (anrm < smlnum) {
+ dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, &ierr);
+ }
+ if (*info != 0 && anrm < smlnum) {
+ i__1 = minmn - 1;
+ dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &i__1, &c__1, &rwork[
+ ie], &minmn, &ierr);
+ }
+ }
+
+/* Return optimal workspace in WORK(1) */
+
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZGESDD */
+
+} /* zgesdd_ */
diff --git a/SRC/zgesv.c b/SRC/zgesv.c
new file mode 100644
index 0000000..ec74b35
--- /dev/null
+++ b/SRC/zgesv.c
@@ -0,0 +1,140 @@
+/* zgesv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zgesv_(integer *n, integer *nrhs, doublecomplex *a,
+ integer *lda, integer *ipiv, doublecomplex *b, integer *ldb, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int xerbla_(char *, integer *), zgetrf_(
+ integer *, integer *, doublecomplex *, integer *, integer *,
+ integer *), zgetrs_(char *, integer *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGESV computes the solution to a complex system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */
+
+/* The LU decomposition with partial pivoting and row interchanges is */
+/* used to factor A as */
+/* A = P * L * U, */
+/* where P is a permutation matrix, L is unit lower triangular, and U is */
+/* upper triangular. The factored form of A is then used to solve the */
+/* system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N coefficient matrix A. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* The pivot indices that define the permutation matrix P; */
+/* row i of the matrix was interchanged with row IPIV(i). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS matrix of right hand side matrix B. */
+/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, so the solution could not be computed. */
+
+/* ===================================================================== */
+
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGESV ", &i__1);
+ return 0;
+ }
+
+/* Compute the LU factorization of A. */
+
+ zgetrf_(n, n, &a[a_offset], lda, &ipiv[1], info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ zgetrs_("No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &b[
+ b_offset], ldb, info);
+ }
+ return 0;
+
+/* End of ZGESV */
+
+} /* zgesv_ */
diff --git a/SRC/zgesvd.c b/SRC/zgesvd.c
new file mode 100644
index 0000000..d8f217a
--- /dev/null
+++ b/SRC/zgesvd.c
@@ -0,0 +1,4173 @@
+/* zgesvd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__6 = 6;
+static integer c__0 = 0;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zgesvd_(char *jobu, char *jobvt, integer *m, integer *n,
+ doublecomplex *a, integer *lda, doublereal *s, doublecomplex *u,
+ integer *ldu, doublecomplex *vt, integer *ldvt, doublecomplex *work,
+ integer *lwork, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1[2],
+ i__2, i__3, i__4;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, ie, ir, iu, blk, ncu;
+ doublereal dum[1], eps;
+ integer nru;
+ doublecomplex cdum[1];
+ integer iscl;
+ doublereal anrm;
+ integer ierr, itau, ncvt, nrvt;
+ extern logical lsame_(char *, char *);
+ integer chunk, minmn;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer wrkbl, itaup, itauq, mnthr, iwork;
+ logical wntua, wntva, wntun, wntuo, wntvn, wntvo, wntus, wntvs;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), xerbla_(char *, integer *),
+ zgebrd_(integer *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ doublereal bignum;
+ extern /* Subroutine */ int zgelqf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *
+), zlascl_(char *, integer *, integer *, doublereal *, doublereal
+ *, integer *, integer *, doublecomplex *, integer *, integer *), zgeqrf_(integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *), zlacpy_(
+ char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zlaset_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer ldwrkr;
+ extern /* Subroutine */ int zbdsqr_(char *, integer *, integer *, integer
+ *, integer *, doublereal *, doublereal *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *);
+ integer minwrk, ldwrku, maxwrk;
+ extern /* Subroutine */ int zungbr_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+ doublereal smlnum;
+ integer irwork;
+ extern /* Subroutine */ int zunmbr_(char *, char *, char *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+), zunglq_(integer *, integer *, integer *
+, doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+ logical lquery, wntuas, wntvas;
+ extern /* Subroutine */ int zungqr_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGESVD computes the singular value decomposition (SVD) of a complex */
+/* M-by-N matrix A, optionally computing the left and/or right singular */
+/* vectors. The SVD is written */
+
+/* A = U * SIGMA * conjugate-transpose(V) */
+
+/* where SIGMA is an M-by-N matrix which is zero except for its */
+/* min(m,n) diagonal elements, U is an M-by-M unitary matrix, and */
+/* V is an N-by-N unitary matrix. The diagonal elements of SIGMA */
+/* are the singular values of A; they are real and non-negative, and */
+/* are returned in descending order. The first min(m,n) columns of */
+/* U and V are the left and right singular vectors of A. */
+
+/* Note that the routine returns V**H, not V. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBU (input) CHARACTER*1 */
+/* Specifies options for computing all or part of the matrix U: */
+/* = 'A': all M columns of U are returned in array U: */
+/* = 'S': the first min(m,n) columns of U (the left singular */
+/* vectors) are returned in the array U; */
+/* = 'O': the first min(m,n) columns of U (the left singular */
+/* vectors) are overwritten on the array A; */
+/* = 'N': no columns of U (no left singular vectors) are */
+/* computed. */
+
+/* JOBVT (input) CHARACTER*1 */
+/* Specifies options for computing all or part of the matrix */
+/* V**H: */
+/* = 'A': all N rows of V**H are returned in the array VT; */
+/* = 'S': the first min(m,n) rows of V**H (the right singular */
+/* vectors) are returned in the array VT; */
+/* = 'O': the first min(m,n) rows of V**H (the right singular */
+/* vectors) are overwritten on the array A; */
+/* = 'N': no rows of V**H (no right singular vectors) are */
+/* computed. */
+
+/* JOBVT and JOBU cannot both be 'O'. */
+
+/* M (input) INTEGER */
+/* The number of rows of the input matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the input matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, */
+/* if JOBU = 'O', A is overwritten with the first min(m,n) */
+/* columns of U (the left singular vectors, */
+/* stored columnwise); */
+/* if JOBVT = 'O', A is overwritten with the first min(m,n) */
+/* rows of V**H (the right singular vectors, */
+/* stored rowwise); */
+/* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A */
+/* are destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* S (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The singular values of A, sorted so that S(i) >= S(i+1). */
+
+/* U (output) COMPLEX*16 array, dimension (LDU,UCOL) */
+/* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'. */
+/* If JOBU = 'A', U contains the M-by-M unitary matrix U; */
+/* if JOBU = 'S', U contains the first min(m,n) columns of U */
+/* (the left singular vectors, stored columnwise); */
+/* if JOBU = 'N' or 'O', U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= 1; if */
+/* JOBU = 'S' or 'A', LDU >= M. */
+
+/* VT (output) COMPLEX*16 array, dimension (LDVT,N) */
+/* If JOBVT = 'A', VT contains the N-by-N unitary matrix */
+/* V**H; */
+/* if JOBVT = 'S', VT contains the first min(m,n) rows of */
+/* V**H (the right singular vectors, stored rowwise); */
+/* if JOBVT = 'N' or 'O', VT is not referenced. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. LDVT >= 1; if */
+/* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* LWORK >= MAX(1,2*MIN(M,N)+MAX(M,N)). */
+/* For good performance, LWORK should generally be larger. */
+
+/* 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. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (5*min(M,N)) */
+/* On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the */
+/* unconverged superdiagonal elements of an upper bidiagonal */
+/* matrix B whose diagonal is in S (not necessarily sorted). */
+/* B satisfies A = U * B * VT, so it has the same singular */
+/* values as A, and singular vectors related by U and VT. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if ZBDSQR did not converge, INFO specifies how many */
+/* superdiagonals of an intermediate bidiagonal form B */
+/* did not converge to zero. See the description of RWORK */
+/* above for details. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ minmn = min(*m,*n);
+ wntua = lsame_(jobu, "A");
+ wntus = lsame_(jobu, "S");
+ wntuas = wntua || wntus;
+ wntuo = lsame_(jobu, "O");
+ wntun = lsame_(jobu, "N");
+ wntva = lsame_(jobvt, "A");
+ wntvs = lsame_(jobvt, "S");
+ wntvas = wntva || wntvs;
+ wntvo = lsame_(jobvt, "O");
+ wntvn = lsame_(jobvt, "N");
+ lquery = *lwork == -1;
+
+ if (! (wntua || wntus || wntuo || wntun)) {
+ *info = -1;
+ } else if (! (wntva || wntvs || wntvo || wntvn) || wntvo && wntuo) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -6;
+ } else if (*ldu < 1 || wntuas && *ldu < *m) {
+ *info = -9;
+ } else if (*ldvt < 1 || wntva && *ldvt < *n || wntvs && *ldvt < minmn) {
+ *info = -11;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* CWorkspace refers to complex workspace, and RWorkspace to */
+/* real workspace. NB refers to the optimal block size for the */
+/* immediately following subroutine, as returned by ILAENV.) */
+
+ if (*info == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ if (*m >= *n && minmn > 0) {
+
+/* Space needed for ZBDSQR is BDSPAC = 5*N */
+
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = jobu;
+ i__1[1] = 1, a__1[1] = jobvt;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ mnthr = ilaenv_(&c__6, "ZGESVD", ch__1, m, n, &c__0, &c__0);
+ if (*m >= mnthr) {
+ if (wntun) {
+
+/* Path 1 (M much larger than N, JOBU='N') */
+
+ maxwrk = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1);
+ maxwrk = max(i__2,i__3);
+ if (wntvo || wntvas) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&
+ c__1, "ZUNGBR", "P", n, n, n, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ minwrk = *n * 3;
+ } else if (wntuo && wntvn) {
+
+/* Path 2 (M much larger than N, JOBU='O', JOBVT='N') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "ZUNGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNGBR", "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n;
+ maxwrk = max(i__2,i__3);
+ minwrk = (*n << 1) + *m;
+ } else if (wntuo && wntvas) {
+
+/* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or */
+/* 'A') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "ZUNGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNGBR", "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
+ "ZUNGBR", "P", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = *n * *n + wrkbl, i__3 = *n * *n + *m * *n;
+ maxwrk = max(i__2,i__3);
+ minwrk = (*n << 1) + *m;
+ } else if (wntus && wntvn) {
+
+/* Path 4 (M much larger than N, JOBU='S', JOBVT='N') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "ZUNGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNGBR", "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = *n * *n + wrkbl;
+ minwrk = (*n << 1) + *m;
+ } else if (wntus && wntvo) {
+
+/* Path 5 (M much larger than N, JOBU='S', JOBVT='O') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "ZUNGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNGBR", "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
+ "ZUNGBR", "P", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = (*n << 1) * *n + wrkbl;
+ minwrk = (*n << 1) + *m;
+ } else if (wntus && wntvas) {
+
+/* Path 6 (M much larger than N, JOBU='S', JOBVT='S' or */
+/* 'A') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *n * ilaenv_(&c__1, "ZUNGQR",
+ " ", m, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNGBR", "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
+ "ZUNGBR", "P", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = *n * *n + wrkbl;
+ minwrk = (*n << 1) + *m;
+ } else if (wntua && wntvn) {
+
+/* Path 7 (M much larger than N, JOBU='A', JOBVT='N') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "ZUNGQR",
+ " ", m, m, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNGBR", "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = *n * *n + wrkbl;
+ minwrk = (*n << 1) + *m;
+ } else if (wntua && wntvo) {
+
+/* Path 8 (M much larger than N, JOBU='A', JOBVT='O') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "ZUNGQR",
+ " ", m, m, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNGBR", "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
+ "ZUNGBR", "P", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = (*n << 1) * *n + wrkbl;
+ minwrk = (*n << 1) + *m;
+ } else if (wntua && wntvas) {
+
+/* Path 9 (M much larger than N, JOBU='A', JOBVT='S' or */
+/* 'A') */
+
+ wrkbl = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *n + *m * ilaenv_(&c__1, "ZUNGQR",
+ " ", m, m, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", n, n, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNGBR", "Q", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&c__1,
+ "ZUNGBR", "P", n, n, n, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = *n * *n + wrkbl;
+ minwrk = (*n << 1) + *m;
+ }
+ } else {
+
+/* Path 10 (M at least N, but not much larger) */
+
+ maxwrk = (*n << 1) + (*m + *n) * ilaenv_(&c__1, "ZGEBRD",
+ " ", m, n, &c_n1, &c_n1);
+ if (wntus || wntuo) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = (*n << 1) + *n * ilaenv_(&c__1,
+ "ZUNGBR", "Q", m, n, n, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ if (wntua) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = (*n << 1) + *m * ilaenv_(&c__1,
+ "ZUNGBR", "Q", m, m, n, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ if (! wntvn) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = (*n << 1) + (*n - 1) * ilaenv_(&
+ c__1, "ZUNGBR", "P", n, n, n, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ minwrk = (*n << 1) + *m;
+ }
+ } else if (minmn > 0) {
+
+/* Space needed for ZBDSQR is BDSPAC = 5*M */
+
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = jobu;
+ i__1[1] = 1, a__1[1] = jobvt;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ mnthr = ilaenv_(&c__6, "ZGESVD", ch__1, m, n, &c__0, &c__0);
+ if (*n >= mnthr) {
+ if (wntvn) {
+
+/* Path 1t(N much larger than M, JOBVT='N') */
+
+ maxwrk = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1);
+ maxwrk = max(i__2,i__3);
+ if (wntuo || wntuas) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNGBR", "Q", m, m, m, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ minwrk = *m * 3;
+ } else if (wntvo && wntun) {
+
+/* Path 2t(N much larger than M, JOBU='N', JOBVT='O') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "ZUNGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
+ "ZUNGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n;
+ maxwrk = max(i__2,i__3);
+ minwrk = (*m << 1) + *n;
+ } else if (wntvo && wntuas) {
+
+/* Path 3t(N much larger than M, JOBU='S' or 'A', */
+/* JOBVT='O') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "ZUNGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
+ "ZUNGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNGBR", "Q", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = *m * *m + wrkbl, i__3 = *m * *m + *m * *n;
+ maxwrk = max(i__2,i__3);
+ minwrk = (*m << 1) + *n;
+ } else if (wntvs && wntun) {
+
+/* Path 4t(N much larger than M, JOBU='N', JOBVT='S') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "ZUNGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
+ "ZUNGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = *m * *m + wrkbl;
+ minwrk = (*m << 1) + *n;
+ } else if (wntvs && wntuo) {
+
+/* Path 5t(N much larger than M, JOBU='O', JOBVT='S') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "ZUNGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
+ "ZUNGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNGBR", "Q", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = (*m << 1) * *m + wrkbl;
+ minwrk = (*m << 1) + *n;
+ } else if (wntvs && wntuas) {
+
+/* Path 6t(N much larger than M, JOBU='S' or 'A', */
+/* JOBVT='S') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *m * ilaenv_(&c__1, "ZUNGLQ",
+ " ", m, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
+ "ZUNGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNGBR", "Q", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = *m * *m + wrkbl;
+ minwrk = (*m << 1) + *n;
+ } else if (wntva && wntun) {
+
+/* Path 7t(N much larger than M, JOBU='N', JOBVT='A') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "ZUNGLQ",
+ " ", n, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
+ "ZUNGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = *m * *m + wrkbl;
+ minwrk = (*m << 1) + *n;
+ } else if (wntva && wntuo) {
+
+/* Path 8t(N much larger than M, JOBU='O', JOBVT='A') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "ZUNGLQ",
+ " ", n, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
+ "ZUNGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNGBR", "Q", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = (*m << 1) * *m + wrkbl;
+ minwrk = (*m << 1) + *n;
+ } else if (wntva && wntuas) {
+
+/* Path 9t(N much larger than M, JOBU='S' or 'A', */
+/* JOBVT='A') */
+
+ wrkbl = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, &
+ c_n1, &c_n1);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *m + *n * ilaenv_(&c__1, "ZUNGLQ",
+ " ", n, n, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m << 1) * ilaenv_(&
+ c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&c__1,
+ "ZUNGBR", "P", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNGBR", "Q", m, m, m, &c_n1);
+ wrkbl = max(i__2,i__3);
+ maxwrk = *m * *m + wrkbl;
+ minwrk = (*m << 1) + *n;
+ }
+ } else {
+
+/* Path 10t(N greater than M, but not much larger) */
+
+ maxwrk = (*m << 1) + (*m + *n) * ilaenv_(&c__1, "ZGEBRD",
+ " ", m, n, &c_n1, &c_n1);
+ if (wntvs || wntvo) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = (*m << 1) + *m * ilaenv_(&c__1,
+ "ZUNGBR", "P", m, n, m, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ if (wntva) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = (*m << 1) + *n * ilaenv_(&c__1,
+ "ZUNGBR", "P", n, n, m, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ if (! wntun) {
+/* Computing MAX */
+ i__2 = maxwrk, i__3 = (*m << 1) + (*m - 1) * ilaenv_(&
+ c__1, "ZUNGBR", "Q", m, m, m, &c_n1);
+ maxwrk = max(i__2,i__3);
+ }
+ minwrk = (*m << 1) + *n;
+ }
+ }
+ maxwrk = max(maxwrk,minwrk);
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info != 0) {
+ i__2 = -(*info);
+ xerbla_("ZGESVD", &i__2);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ smlnum = sqrt(dlamch_("S")) / eps;
+ bignum = 1. / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = zlange_("M", m, n, &a[a_offset], lda, dum);
+ iscl = 0;
+ if (anrm > 0. && anrm < smlnum) {
+ iscl = 1;
+ zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, &
+ ierr);
+ } else if (anrm > bignum) {
+ iscl = 1;
+ zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+ if (*m >= *n) {
+
+/* A has at least as many rows as columns. If A has sufficiently */
+/* more rows than columns, first reduce using the QR */
+/* decomposition (if sufficient workspace available) */
+
+ if (*m >= mnthr) {
+
+ if (wntun) {
+
+/* Path 1 (M much larger than N, JOBU='N') */
+/* No left singular vectors to be computed */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: need 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &
+ i__2, &ierr);
+
+/* Zero out below R */
+
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &a[a_dim1 + 2], lda);
+ ie = 1;
+ itauq = 1;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in A */
+/* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__2, &ierr);
+ ncvt = 0;
+ if (wntvo || wntvas) {
+
+/* If right singular vectors desired, generate P'. */
+/* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &
+ work[iwork], &i__2, &ierr);
+ ncvt = *n;
+ }
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of A in A if desired */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", n, &ncvt, &c__0, &c__0, &s[1], &rwork[ie], &a[
+ a_offset], lda, cdum, &c__1, cdum, &c__1, &rwork[
+ irwork], info);
+
+/* If right singular vectors desired in VT, copy them there */
+
+ if (wntvas) {
+ zlacpy_("F", n, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+ }
+
+ } else if (wntuo && wntvn) {
+
+/* Path 2 (M much larger than N, JOBU='O', JOBVT='N') */
+/* N left singular vectors to be overwritten on A and */
+/* no right singular vectors to be computed */
+
+ if (*lwork >= *n * *n + *n * 3) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *lda * *n;
+ if (*lwork >= max(i__2,i__3) + *lda * *n) {
+
+/* WORK(IU) is LDA by N, WORK(IR) is LDA by N */
+
+ ldwrku = *lda;
+ ldwrkr = *lda;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *lda * *n;
+ if (*lwork >= max(i__2,i__3) + *n * *n) {
+
+/* WORK(IU) is LDA by N, WORK(IR) is N by N */
+
+ ldwrku = *lda;
+ ldwrkr = *n;
+ } else {
+
+/* WORK(IU) is LDWRKU by N, WORK(IR) is N by N */
+
+ ldwrku = (*lwork - *n * *n) / *n;
+ ldwrkr = *n;
+ }
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__2, &ierr);
+
+/* Copy R to WORK(IR) and zero out below it */
+
+ zlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &ldwrkr);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[ir + 1], &
+ ldwrkr);
+
+/* Generate Q in A */
+/* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IR) */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &i__2, &
+ ierr);
+
+/* Generate left vectors bidiagonalizing R */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) */
+/* (RWorkspace: need 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], &
+ work[iwork], &i__2, &ierr);
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IR) */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", n, &c__0, n, &c__0, &s[1], &rwork[ie], cdum,
+ &c__1, &work[ir], &ldwrkr, cdum, &c__1, &rwork[
+ irwork], info);
+ iu = itauq;
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IR), storing result in WORK(IU) and copying to A */
+/* (CWorkspace: need N*N+N, prefer N*N+M*N) */
+/* (RWorkspace: 0) */
+
+ i__2 = *m;
+ i__3 = ldwrku;
+ for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
+ i__3) {
+/* Computing MIN */
+ i__4 = *m - i__ + 1;
+ chunk = min(i__4,ldwrku);
+ zgemm_("N", "N", &chunk, n, n, &c_b2, &a[i__ + a_dim1]
+, lda, &work[ir], &ldwrkr, &c_b1, &work[iu], &
+ ldwrku);
+ zlacpy_("F", &chunk, n, &work[iu], &ldwrku, &a[i__ +
+ a_dim1], lda);
+/* L10: */
+ }
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ ie = 1;
+ itauq = 1;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize A */
+/* (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB) */
+/* (RWorkspace: N) */
+
+ i__3 = *lwork - iwork + 1;
+ zgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__3, &ierr);
+
+/* Generate left vectors bidiagonalizing A */
+/* (CWorkspace: need 3*N, prefer 2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__3 = *lwork - iwork + 1;
+ zungbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], &
+ work[iwork], &i__3, &ierr);
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in A */
+/* (CWorkspace: need 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", n, &c__0, m, &c__0, &s[1], &rwork[ie], cdum,
+ &c__1, &a[a_offset], lda, cdum, &c__1, &rwork[
+ irwork], info);
+
+ }
+
+ } else if (wntuo && wntvas) {
+
+/* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A') */
+/* N left singular vectors to be overwritten on A and */
+/* N right singular vectors to be computed in VT */
+
+ if (*lwork >= *n * *n + *n * 3) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+/* Computing MAX */
+ i__3 = wrkbl, i__2 = *lda * *n;
+ if (*lwork >= max(i__3,i__2) + *lda * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is LDA by N */
+
+ ldwrku = *lda;
+ ldwrkr = *lda;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__3 = wrkbl, i__2 = *lda * *n;
+ if (*lwork >= max(i__3,i__2) + *n * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is N by N */
+
+ ldwrku = *lda;
+ ldwrkr = *n;
+ } else {
+
+/* WORK(IU) is LDWRKU by N and WORK(IR) is N by N */
+
+ ldwrku = (*lwork - *n * *n) / *n;
+ ldwrkr = *n;
+ }
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__3 = *lwork - iwork + 1;
+ zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__3, &ierr);
+
+/* Copy R to VT, zeroing out below it */
+
+ zlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+ if (*n > 1) {
+ i__3 = *n - 1;
+ i__2 = *n - 1;
+ zlaset_("L", &i__3, &i__2, &c_b1, &c_b1, &vt[vt_dim1
+ + 2], ldvt);
+ }
+
+/* Generate Q in A */
+/* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__3 = *lwork - iwork + 1;
+ zungqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__3, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in VT, copying result to WORK(IR) */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__3 = *lwork - iwork + 1;
+ zgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &i__3, &
+ ierr);
+ zlacpy_("L", n, n, &vt[vt_offset], ldvt, &work[ir], &
+ ldwrkr);
+
+/* Generate left vectors bidiagonalizing R in WORK(IR) */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__3 = *lwork - iwork + 1;
+ zungbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq], &
+ work[iwork], &i__3, &ierr);
+
+/* Generate right vectors bidiagonalizing R in VT */
+/* (CWorkspace: need N*N+3*N-1, prefer N*N+2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__3 = *lwork - iwork + 1;
+ zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup],
+ &work[iwork], &i__3, &ierr);
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IR) and computing right */
+/* singular vectors of R in VT */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", n, n, n, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &work[ir], &ldwrkr, cdum, &c__1,
+ &rwork[irwork], info);
+ iu = itauq;
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IR), storing result in WORK(IU) and copying to A */
+/* (CWorkspace: need N*N+N, prefer N*N+M*N) */
+/* (RWorkspace: 0) */
+
+ i__3 = *m;
+ i__2 = ldwrku;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__4 = *m - i__ + 1;
+ chunk = min(i__4,ldwrku);
+ zgemm_("N", "N", &chunk, n, n, &c_b2, &a[i__ + a_dim1]
+, lda, &work[ir], &ldwrkr, &c_b1, &work[iu], &
+ ldwrku);
+ zlacpy_("F", &chunk, n, &work[iu], &ldwrku, &a[i__ +
+ a_dim1], lda);
+/* L20: */
+ }
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__2, &ierr);
+
+/* Copy R to VT, zeroing out below it */
+
+ zlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+ if (*n > 1) {
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &vt[vt_dim1
+ + 2], ldvt);
+ }
+
+/* Generate Q in A */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungqr_(m, n, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in VT */
+/* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) */
+/* (RWorkspace: N) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &i__2, &
+ ierr);
+
+/* Multiply Q in A by left vectors bidiagonalizing R */
+/* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunmbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt, &
+ work[itauq], &a[a_offset], lda, &work[iwork], &
+ i__2, &ierr);
+
+/* Generate right vectors bidiagonalizing R in VT */
+/* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup],
+ &work[iwork], &i__2, &ierr);
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in A and computing right */
+/* singular vectors of A in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", n, n, m, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &a[a_offset], lda, cdum, &c__1,
+ &rwork[irwork], info);
+
+ }
+
+ } else if (wntus) {
+
+ if (wntvn) {
+
+/* Path 4 (M much larger than N, JOBU='S', JOBVT='N') */
+/* N left singular vectors to be computed in U and */
+/* no right singular vectors to be computed */
+
+ if (*lwork >= *n * *n + *n * 3) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+ if (*lwork >= wrkbl + *lda * *n) {
+
+/* WORK(IR) is LDA by N */
+
+ ldwrkr = *lda;
+ } else {
+
+/* WORK(IR) is N by N */
+
+ ldwrkr = *n;
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy R to WORK(IR), zeroing out below it */
+
+ zlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &
+ ldwrkr);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[ir + 1]
+, &ldwrkr);
+
+/* Generate Q in A */
+/* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungqr_(m, n, n, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IR) */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Generate left vectors bidiagonalizing R in WORK(IR) */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IR) */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", n, &c__0, n, &c__0, &s[1], &rwork[ie],
+ cdum, &c__1, &work[ir], &ldwrkr, cdum, &c__1,
+ &rwork[irwork], info);
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IR), storing result in U */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: 0) */
+
+ zgemm_("N", "N", m, n, n, &c_b2, &a[a_offset], lda, &
+ work[ir], &ldwrkr, &c_b1, &u[u_offset], ldu);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungqr_(m, n, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Zero out below R in A */
+
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &a[a_dim1 +
+ 2], lda);
+
+/* Bidiagonalize R in A */
+/* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left vectors bidiagonalizing R */
+/* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunmbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
+ work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr)
+ ;
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", n, &c__0, m, &c__0, &s[1], &rwork[ie],
+ cdum, &c__1, &u[u_offset], ldu, cdum, &c__1, &
+ rwork[irwork], info);
+
+ }
+
+ } else if (wntvo) {
+
+/* Path 5 (M much larger than N, JOBU='S', JOBVT='O') */
+/* N left singular vectors to be computed in U and */
+/* N right singular vectors to be overwritten on A */
+
+ if (*lwork >= (*n << 1) * *n + *n * 3) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + (*lda << 1) * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is LDA by N */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *lda;
+ } else if (*lwork >= wrkbl + (*lda + *n) * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is N by N */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *n;
+ } else {
+
+/* WORK(IU) is N by N and WORK(IR) is N by N */
+
+ ldwrku = *n;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *n;
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy R to WORK(IU), zeroing out below it */
+
+ zlacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[iu + 1]
+, &ldwrku);
+
+/* Generate Q in A */
+/* (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungqr_(m, n, n, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IU), copying result to */
+/* WORK(IR) */
+/* (CWorkspace: need 2*N*N+3*N, */
+/* prefer 2*N*N+2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(n, n, &work[iu], &ldwrku, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ zlacpy_("U", n, n, &work[iu], &ldwrku, &work[ir], &
+ ldwrkr);
+
+/* Generate left bidiagonalizing vectors in WORK(IU) */
+/* (CWorkspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in WORK(IR) */
+/* (CWorkspace: need 2*N*N+3*N-1, */
+/* prefer 2*N*N+2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("P", n, n, n, &work[ir], &ldwrkr, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IU) and computing */
+/* right singular vectors of R in WORK(IR) */
+/* (CWorkspace: need 2*N*N) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", n, n, n, &c__0, &s[1], &rwork[ie], &work[
+ ir], &ldwrkr, &work[iu], &ldwrku, cdum, &c__1,
+ &rwork[irwork], info);
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IU), storing result in U */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: 0) */
+
+ zgemm_("N", "N", m, n, n, &c_b2, &a[a_offset], lda, &
+ work[iu], &ldwrku, &c_b1, &u[u_offset], ldu);
+
+/* Copy right singular vectors of R to A */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: 0) */
+
+ zlacpy_("F", n, n, &work[ir], &ldwrkr, &a[a_offset],
+ lda);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungqr_(m, n, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Zero out below R in A */
+
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &a[a_dim1 +
+ 2], lda);
+
+/* Bidiagonalize R in A */
+/* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left vectors bidiagonalizing R */
+/* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunmbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
+ work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr)
+ ;
+
+/* Generate right vectors bidiagonalizing R in A */
+/* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("P", n, n, n, &a[a_offset], lda, &work[itaup],
+ &work[iwork], &i__2, &ierr);
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in A */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", n, n, m, &c__0, &s[1], &rwork[ie], &a[
+ a_offset], lda, &u[u_offset], ldu, cdum, &
+ c__1, &rwork[irwork], info);
+
+ }
+
+ } else if (wntvas) {
+
+/* Path 6 (M much larger than N, JOBU='S', JOBVT='S' */
+/* or 'A') */
+/* N left singular vectors to be computed in U and */
+/* N right singular vectors to be computed in VT */
+
+ if (*lwork >= *n * *n + *n * 3) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + *lda * *n) {
+
+/* WORK(IU) is LDA by N */
+
+ ldwrku = *lda;
+ } else {
+
+/* WORK(IU) is N by N */
+
+ ldwrku = *n;
+ }
+ itau = iu + ldwrku * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R */
+/* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy R to WORK(IU), zeroing out below it */
+
+ zlacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[iu + 1]
+, &ldwrku);
+
+/* Generate Q in A */
+/* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungqr_(m, n, n, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IU), copying result to VT */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(n, n, &work[iu], &ldwrku, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ zlacpy_("U", n, n, &work[iu], &ldwrku, &vt[vt_offset],
+ ldvt);
+
+/* Generate left bidiagonalizing vectors in WORK(IU) */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in VT */
+/* (CWorkspace: need N*N+3*N-1, */
+/* prefer N*N+2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
+ itaup], &work[iwork], &i__2, &ierr)
+ ;
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IU) and computing */
+/* right singular vectors of R in VT */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", n, n, n, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &work[iu], &ldwrku, cdum, &
+ c__1, &rwork[irwork], info);
+
+/* Multiply Q in A by left singular vectors of R in */
+/* WORK(IU), storing result in U */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: 0) */
+
+ zgemm_("N", "N", m, n, n, &c_b2, &a[a_offset], lda, &
+ work[iu], &ldwrku, &c_b1, &u[u_offset], ldu);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungqr_(m, n, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy R to VT, zeroing out below it */
+
+ zlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+ if (*n > 1) {
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &vt[
+ vt_dim1 + 2], ldvt);
+ }
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in VT */
+/* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &rwork[ie],
+ &work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left bidiagonalizing vectors */
+/* in VT */
+/* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunmbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt,
+ &work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in VT */
+/* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
+ itaup], &work[iwork], &i__2, &ierr)
+ ;
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", n, n, m, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, cdum, &
+ c__1, &rwork[irwork], info);
+
+ }
+
+ }
+
+ } else if (wntua) {
+
+ if (wntvn) {
+
+/* Path 7 (M much larger than N, JOBU='A', JOBVT='N') */
+/* M left singular vectors to be computed in U and */
+/* no right singular vectors to be computed */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *n * 3;
+ if (*lwork >= *n * *n + max(i__2,i__3)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+ if (*lwork >= wrkbl + *lda * *n) {
+
+/* WORK(IR) is LDA by N */
+
+ ldwrkr = *lda;
+ } else {
+
+/* WORK(IR) is N by N */
+
+ ldwrkr = *n;
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Copy R to WORK(IR), zeroing out below it */
+
+ zlacpy_("U", n, n, &a[a_offset], lda, &work[ir], &
+ ldwrkr);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[ir + 1]
+, &ldwrkr);
+
+/* Generate Q in U */
+/* (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IR) */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(n, n, &work[ir], &ldwrkr, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in WORK(IR) */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("Q", n, n, n, &work[ir], &ldwrkr, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IR) */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", n, &c__0, n, &c__0, &s[1], &rwork[ie],
+ cdum, &c__1, &work[ir], &ldwrkr, cdum, &c__1,
+ &rwork[irwork], info);
+
+/* Multiply Q in U by left singular vectors of R in */
+/* WORK(IR), storing result in A */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: 0) */
+
+ zgemm_("N", "N", m, n, n, &c_b2, &u[u_offset], ldu, &
+ work[ir], &ldwrkr, &c_b1, &a[a_offset], lda);
+
+/* Copy left singular vectors of A from A to U */
+
+ zlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (CWorkspace: need N+M, prefer N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Zero out below R in A */
+
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &a[a_dim1 +
+ 2], lda);
+
+/* Bidiagonalize R in A */
+/* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left bidiagonalizing vectors */
+/* in A */
+/* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunmbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
+ work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr)
+ ;
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", n, &c__0, m, &c__0, &s[1], &rwork[ie],
+ cdum, &c__1, &u[u_offset], ldu, cdum, &c__1, &
+ rwork[irwork], info);
+
+ }
+
+ } else if (wntvo) {
+
+/* Path 8 (M much larger than N, JOBU='A', JOBVT='O') */
+/* M left singular vectors to be computed in U and */
+/* N right singular vectors to be overwritten on A */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *n * 3;
+ if (*lwork >= (*n << 1) * *n + max(i__2,i__3)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + (*lda << 1) * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is LDA by N */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *lda;
+ } else if (*lwork >= wrkbl + (*lda + *n) * *n) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is N by N */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *n;
+ } else {
+
+/* WORK(IU) is N by N and WORK(IR) is N by N */
+
+ ldwrku = *n;
+ ir = iu + ldwrku * *n;
+ ldwrkr = *n;
+ }
+ itau = ir + ldwrkr * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (CWorkspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy R to WORK(IU), zeroing out below it */
+
+ zlacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[iu + 1]
+, &ldwrku);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IU), copying result to */
+/* WORK(IR) */
+/* (CWorkspace: need 2*N*N+3*N, */
+/* prefer 2*N*N+2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(n, n, &work[iu], &ldwrku, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ zlacpy_("U", n, n, &work[iu], &ldwrku, &work[ir], &
+ ldwrkr);
+
+/* Generate left bidiagonalizing vectors in WORK(IU) */
+/* (CWorkspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in WORK(IR) */
+/* (CWorkspace: need 2*N*N+3*N-1, */
+/* prefer 2*N*N+2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("P", n, n, n, &work[ir], &ldwrkr, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IU) and computing */
+/* right singular vectors of R in WORK(IR) */
+/* (CWorkspace: need 2*N*N) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", n, n, n, &c__0, &s[1], &rwork[ie], &work[
+ ir], &ldwrkr, &work[iu], &ldwrku, cdum, &c__1,
+ &rwork[irwork], info);
+
+/* Multiply Q in U by left singular vectors of R in */
+/* WORK(IU), storing result in A */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: 0) */
+
+ zgemm_("N", "N", m, n, n, &c_b2, &u[u_offset], ldu, &
+ work[iu], &ldwrku, &c_b1, &a[a_offset], lda);
+
+/* Copy left singular vectors of A from A to U */
+
+ zlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Copy right singular vectors of R from WORK(IR) to A */
+
+ zlacpy_("F", n, n, &work[ir], &ldwrkr, &a[a_offset],
+ lda);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (CWorkspace: need N+M, prefer N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Zero out below R in A */
+
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &a[a_dim1 +
+ 2], lda);
+
+/* Bidiagonalize R in A */
+/* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(n, n, &a[a_offset], lda, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left bidiagonalizing vectors */
+/* in A */
+/* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunmbr_("Q", "R", "N", m, n, n, &a[a_offset], lda, &
+ work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr)
+ ;
+
+/* Generate right bidiagonalizing vectors in A */
+/* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("P", n, n, n, &a[a_offset], lda, &work[itaup],
+ &work[iwork], &i__2, &ierr);
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in A */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", n, n, m, &c__0, &s[1], &rwork[ie], &a[
+ a_offset], lda, &u[u_offset], ldu, cdum, &
+ c__1, &rwork[irwork], info);
+
+ }
+
+ } else if (wntvas) {
+
+/* Path 9 (M much larger than N, JOBU='A', JOBVT='S' */
+/* or 'A') */
+/* M left singular vectors to be computed in U and */
+/* N right singular vectors to be computed in VT */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *n * 3;
+ if (*lwork >= *n * *n + max(i__2,i__3)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + *lda * *n) {
+
+/* WORK(IU) is LDA by N */
+
+ ldwrku = *lda;
+ } else {
+
+/* WORK(IU) is N by N */
+
+ ldwrku = *n;
+ }
+ itau = iu + ldwrku * *n;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy R to WORK(IU), zeroing out below it */
+
+ zlacpy_("U", n, n, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &work[iu + 1]
+, &ldwrku);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in WORK(IU), copying result to VT */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(n, n, &work[iu], &ldwrku, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ zlacpy_("U", n, n, &work[iu], &ldwrku, &vt[vt_offset],
+ ldvt);
+
+/* Generate left bidiagonalizing vectors in WORK(IU) */
+/* (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("Q", n, n, n, &work[iu], &ldwrku, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in VT */
+/* (CWorkspace: need N*N+3*N-1, */
+/* prefer N*N+2*N+(N-1)*NB) */
+/* (RWorkspace: need 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
+ itaup], &work[iwork], &i__2, &ierr)
+ ;
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of R in WORK(IU) and computing */
+/* right singular vectors of R in VT */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", n, n, n, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &work[iu], &ldwrku, cdum, &
+ c__1, &rwork[irwork], info);
+
+/* Multiply Q in U by left singular vectors of R in */
+/* WORK(IU), storing result in A */
+/* (CWorkspace: need N*N) */
+/* (RWorkspace: 0) */
+
+ zgemm_("N", "N", m, n, n, &c_b2, &u[u_offset], ldu, &
+ work[iu], &ldwrku, &c_b1, &a[a_offset], lda);
+
+/* Copy left singular vectors of A from A to U */
+
+ zlacpy_("F", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *n;
+
+/* Compute A=Q*R, copying result to U */
+/* (CWorkspace: need 2*N, prefer N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset],
+ ldu);
+
+/* Generate Q in U */
+/* (CWorkspace: need N+M, prefer N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungqr_(m, m, n, &u[u_offset], ldu, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy R from A to VT, zeroing out below it */
+
+ zlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+ if (*n > 1) {
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ zlaset_("L", &i__2, &i__3, &c_b1, &c_b1, &vt[
+ vt_dim1 + 2], ldvt);
+ }
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize R in VT */
+/* (CWorkspace: need 3*N, prefer 2*N+2*N*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(n, n, &vt[vt_offset], ldvt, &s[1], &rwork[ie],
+ &work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply Q in U by left bidiagonalizing vectors */
+/* in VT */
+/* (CWorkspace: need 2*N+M, prefer 2*N+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunmbr_("Q", "R", "N", m, n, n, &vt[vt_offset], ldvt,
+ &work[itauq], &u[u_offset], ldu, &work[iwork],
+ &i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in VT */
+/* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[
+ itaup], &work[iwork], &i__2, &ierr)
+ ;
+ irwork = ie + *n;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", n, n, m, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, cdum, &
+ c__1, &rwork[irwork], info);
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* M .LT. MNTHR */
+
+/* Path 10 (M at least N, but not much larger) */
+/* Reduce to bidiagonal form without QR decomposition */
+
+ ie = 1;
+ itauq = 1;
+ itaup = itauq + *n;
+ iwork = itaup + *n;
+
+/* Bidiagonalize A */
+/* (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB) */
+/* (RWorkspace: need N) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq],
+ &work[itaup], &work[iwork], &i__2, &ierr);
+ if (wntuas) {
+
+/* If left singular vectors desired in U, copy result to U */
+/* and generate left bidiagonalizing vectors in U */
+/* (CWorkspace: need 2*N+NCU, prefer 2*N+NCU*NB) */
+/* (RWorkspace: 0) */
+
+ zlacpy_("L", m, n, &a[a_offset], lda, &u[u_offset], ldu);
+ if (wntus) {
+ ncu = *n;
+ }
+ if (wntua) {
+ ncu = *m;
+ }
+ i__2 = *lwork - iwork + 1;
+ zungbr_("Q", m, &ncu, n, &u[u_offset], ldu, &work[itauq], &
+ work[iwork], &i__2, &ierr);
+ }
+ if (wntvas) {
+
+/* If right singular vectors desired in VT, copy result to */
+/* VT and generate right bidiagonalizing vectors in VT */
+/* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ zlacpy_("U", n, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+ i__2 = *lwork - iwork + 1;
+ zungbr_("P", n, n, n, &vt[vt_offset], ldvt, &work[itaup], &
+ work[iwork], &i__2, &ierr);
+ }
+ if (wntuo) {
+
+/* If left singular vectors desired in A, generate left */
+/* bidiagonalizing vectors in A */
+/* (CWorkspace: need 3*N, prefer 2*N+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("Q", m, n, n, &a[a_offset], lda, &work[itauq], &work[
+ iwork], &i__2, &ierr);
+ }
+ if (wntvo) {
+
+/* If right singular vectors desired in A, generate right */
+/* bidiagonalizing vectors in A */
+/* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[
+ iwork], &i__2, &ierr);
+ }
+ irwork = ie + *n;
+ if (wntuas || wntuo) {
+ nru = *m;
+ }
+ if (wntun) {
+ nru = 0;
+ }
+ if (wntvas || wntvo) {
+ ncvt = *n;
+ }
+ if (wntvn) {
+ ncvt = 0;
+ }
+ if (! wntuo && ! wntvo) {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in U and computing right singular */
+/* vectors in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, cdum, &c__1, &
+ rwork[irwork], info);
+ } else if (! wntuo && wntvo) {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in U and computing right singular */
+/* vectors in A */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &a[
+ a_offset], lda, &u[u_offset], ldu, cdum, &c__1, &
+ rwork[irwork], info);
+ } else {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in A and computing right singular */
+/* vectors in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", n, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &a[a_offset], lda, cdum, &c__1, &
+ rwork[irwork], info);
+ }
+
+ }
+
+ } else {
+
+/* A has more columns than rows. If A has sufficiently more */
+/* columns than rows, first reduce using the LQ decomposition (if */
+/* sufficient workspace available) */
+
+ if (*n >= mnthr) {
+
+ if (wntvn) {
+
+/* Path 1t(N much larger than M, JOBVT='N') */
+/* No right singular vectors to be computed */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &
+ i__2, &ierr);
+
+/* Zero out above L */
+
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &a[(a_dim1 << 1) + 1]
+, lda);
+ ie = 1;
+ itauq = 1;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in A */
+/* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__2, &ierr);
+ if (wntuo || wntuas) {
+
+/* If left singular vectors desired, generate Q */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq], &
+ work[iwork], &i__2, &ierr);
+ }
+ irwork = ie + *m;
+ nru = 0;
+ if (wntuo || wntuas) {
+ nru = *m;
+ }
+
+/* Perform bidiagonal QR iteration, computing left singular */
+/* vectors of A in A if desired */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", m, &c__0, &nru, &c__0, &s[1], &rwork[ie], cdum, &
+ c__1, &a[a_offset], lda, cdum, &c__1, &rwork[irwork],
+ info);
+
+/* If left singular vectors desired in U, copy them there */
+
+ if (wntuas) {
+ zlacpy_("F", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+ }
+
+ } else if (wntvo && wntun) {
+
+/* Path 2t(N much larger than M, JOBU='N', JOBVT='O') */
+/* M right singular vectors to be overwritten on A and */
+/* no left singular vectors to be computed */
+
+ if (*lwork >= *m * *m + *m * 3) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *lda * *n;
+ if (*lwork >= max(i__2,i__3) + *lda * *m) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is LDA by M */
+
+ ldwrku = *lda;
+ chunk = *n;
+ ldwrkr = *lda;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__2 = wrkbl, i__3 = *lda * *n;
+ if (*lwork >= max(i__2,i__3) + *m * *m) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is M by M */
+
+ ldwrku = *lda;
+ chunk = *n;
+ ldwrkr = *m;
+ } else {
+
+/* WORK(IU) is M by CHUNK and WORK(IR) is M by M */
+
+ ldwrku = *m;
+ chunk = (*lwork - *m * *m) / *m;
+ ldwrkr = *m;
+ }
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__2, &ierr);
+
+/* Copy L to WORK(IR) and zero out above it */
+
+ zlacpy_("L", m, m, &a[a_offset], lda, &work[ir], &ldwrkr);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[ir +
+ ldwrkr], &ldwrkr);
+
+/* Generate Q in A */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IR) */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &i__2, &
+ ierr);
+
+/* Generate right vectors bidiagonalizing L */
+/* (CWorkspace: need M*M+3*M-1, prefer M*M+2*M+(M-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup], &
+ work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of L in WORK(IR) */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", m, m, &c__0, &c__0, &s[1], &rwork[ie], &work[
+ ir], &ldwrkr, cdum, &c__1, cdum, &c__1, &rwork[
+ irwork], info);
+ iu = itauq;
+
+/* Multiply right singular vectors of L in WORK(IR) by Q */
+/* in A, storing result in WORK(IU) and copying to A */
+/* (CWorkspace: need M*M+M, prefer M*M+M*N) */
+/* (RWorkspace: 0) */
+
+ i__2 = *n;
+ i__3 = chunk;
+ for (i__ = 1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ +=
+ i__3) {
+/* Computing MIN */
+ i__4 = *n - i__ + 1;
+ blk = min(i__4,chunk);
+ zgemm_("N", "N", m, &blk, m, &c_b2, &work[ir], &
+ ldwrkr, &a[i__ * a_dim1 + 1], lda, &c_b1, &
+ work[iu], &ldwrku);
+ zlacpy_("F", m, &blk, &work[iu], &ldwrku, &a[i__ *
+ a_dim1 + 1], lda);
+/* L30: */
+ }
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ ie = 1;
+ itauq = 1;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize A */
+/* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) */
+/* (RWorkspace: need M) */
+
+ i__3 = *lwork - iwork + 1;
+ zgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__3, &ierr);
+
+/* Generate right vectors bidiagonalizing A */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__3 = *lwork - iwork + 1;
+ zungbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &
+ work[iwork], &i__3, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of A in A */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("L", m, n, &c__0, &c__0, &s[1], &rwork[ie], &a[
+ a_offset], lda, cdum, &c__1, cdum, &c__1, &rwork[
+ irwork], info);
+
+ }
+
+ } else if (wntvo && wntuas) {
+
+/* Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O') */
+/* M right singular vectors to be overwritten on A and */
+/* M left singular vectors to be computed in U */
+
+ if (*lwork >= *m * *m + *m * 3) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+/* Computing MAX */
+ i__3 = wrkbl, i__2 = *lda * *n;
+ if (*lwork >= max(i__3,i__2) + *lda * *m) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is LDA by M */
+
+ ldwrku = *lda;
+ chunk = *n;
+ ldwrkr = *lda;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__3 = wrkbl, i__2 = *lda * *n;
+ if (*lwork >= max(i__3,i__2) + *m * *m) {
+
+/* WORK(IU) is LDA by N and WORK(IR) is M by M */
+
+ ldwrku = *lda;
+ chunk = *n;
+ ldwrkr = *m;
+ } else {
+
+/* WORK(IU) is M by CHUNK and WORK(IR) is M by M */
+
+ ldwrku = *m;
+ chunk = (*lwork - *m * *m) / *m;
+ ldwrkr = *m;
+ }
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__3 = *lwork - iwork + 1;
+ zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__3, &ierr);
+
+/* Copy L to U, zeroing about above it */
+
+ zlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+ i__3 = *m - 1;
+ i__2 = *m - 1;
+ zlaset_("U", &i__3, &i__2, &c_b1, &c_b1, &u[(u_dim1 << 1)
+ + 1], ldu);
+
+/* Generate Q in A */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__3 = *lwork - iwork + 1;
+ zunglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__3, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in U, copying result to WORK(IR) */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__3 = *lwork - iwork + 1;
+ zgebrd_(m, m, &u[u_offset], ldu, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__3, &ierr);
+ zlacpy_("U", m, m, &u[u_offset], ldu, &work[ir], &ldwrkr);
+
+/* Generate right vectors bidiagonalizing L in WORK(IR) */
+/* (CWorkspace: need M*M+3*M-1, prefer M*M+2*M+(M-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__3 = *lwork - iwork + 1;
+ zungbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup], &
+ work[iwork], &i__3, &ierr);
+
+/* Generate left vectors bidiagonalizing L in U */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__3 = *lwork - iwork + 1;
+ zungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], &
+ work[iwork], &i__3, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of L in U, and computing right */
+/* singular vectors of L in WORK(IR) */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", m, m, m, &c__0, &s[1], &rwork[ie], &work[ir],
+ &ldwrkr, &u[u_offset], ldu, cdum, &c__1, &rwork[
+ irwork], info);
+ iu = itauq;
+
+/* Multiply right singular vectors of L in WORK(IR) by Q */
+/* in A, storing result in WORK(IU) and copying to A */
+/* (CWorkspace: need M*M+M, prefer M*M+M*N)) */
+/* (RWorkspace: 0) */
+
+ i__3 = *n;
+ i__2 = chunk;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__3 : i__ <= i__3; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__4 = *n - i__ + 1;
+ blk = min(i__4,chunk);
+ zgemm_("N", "N", m, &blk, m, &c_b2, &work[ir], &
+ ldwrkr, &a[i__ * a_dim1 + 1], lda, &c_b1, &
+ work[iu], &ldwrku);
+ zlacpy_("F", m, &blk, &work[iu], &ldwrku, &a[i__ *
+ a_dim1 + 1], lda);
+/* L40: */
+ }
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork]
+, &i__2, &ierr);
+
+/* Copy L to U, zeroing out above it */
+
+ zlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &u[(u_dim1 << 1)
+ + 1], ldu);
+
+/* Generate Q in A */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunglq_(m, n, m, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in U */
+/* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(m, m, &u[u_offset], ldu, &s[1], &rwork[ie], &work[
+ itauq], &work[itaup], &work[iwork], &i__2, &ierr);
+
+/* Multiply right vectors bidiagonalizing L by Q in A */
+/* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunmbr_("P", "L", "C", m, n, m, &u[u_offset], ldu, &work[
+ itaup], &a[a_offset], lda, &work[iwork], &i__2, &
+ ierr);
+
+/* Generate left vectors bidiagonalizing L in U */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq], &
+ work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in A */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", m, n, m, &c__0, &s[1], &rwork[ie], &a[
+ a_offset], lda, &u[u_offset], ldu, cdum, &c__1, &
+ rwork[irwork], info);
+
+ }
+
+ } else if (wntvs) {
+
+ if (wntun) {
+
+/* Path 4t(N much larger than M, JOBU='N', JOBVT='S') */
+/* M right singular vectors to be computed in VT and */
+/* no left singular vectors to be computed */
+
+ if (*lwork >= *m * *m + *m * 3) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+ if (*lwork >= wrkbl + *lda * *m) {
+
+/* WORK(IR) is LDA by M */
+
+ ldwrkr = *lda;
+ } else {
+
+/* WORK(IR) is M by M */
+
+ ldwrkr = *m;
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy L to WORK(IR), zeroing out above it */
+
+ zlacpy_("L", m, m, &a[a_offset], lda, &work[ir], &
+ ldwrkr);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[ir +
+ ldwrkr], &ldwrkr);
+
+/* Generate Q in A */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunglq_(m, n, m, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IR) */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Generate right vectors bidiagonalizing L in */
+/* WORK(IR) */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+(M-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of L in WORK(IR) */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", m, m, &c__0, &c__0, &s[1], &rwork[ie], &
+ work[ir], &ldwrkr, cdum, &c__1, cdum, &c__1, &
+ rwork[irwork], info);
+
+/* Multiply right singular vectors of L in WORK(IR) by */
+/* Q in A, storing result in VT */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: 0) */
+
+ zgemm_("N", "N", m, n, m, &c_b2, &work[ir], &ldwrkr, &
+ a[a_offset], lda, &c_b1, &vt[vt_offset], ldvt);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy result to VT */
+
+ zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Zero out above L in A */
+
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &a[(a_dim1 <<
+ 1) + 1], lda);
+
+/* Bidiagonalize L in A */
+/* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right vectors bidiagonalizing L by Q in VT */
+/* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunmbr_("P", "L", "C", m, n, m, &a[a_offset], lda, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of A in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", m, n, &c__0, &c__0, &s[1], &rwork[ie], &
+ vt[vt_offset], ldvt, cdum, &c__1, cdum, &c__1,
+ &rwork[irwork], info);
+
+ }
+
+ } else if (wntuo) {
+
+/* Path 5t(N much larger than M, JOBU='O', JOBVT='S') */
+/* M right singular vectors to be computed in VT and */
+/* M left singular vectors to be overwritten on A */
+
+ if (*lwork >= (*m << 1) * *m + *m * 3) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + (*lda << 1) * *m) {
+
+/* WORK(IU) is LDA by M and WORK(IR) is LDA by M */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *lda;
+ } else if (*lwork >= wrkbl + (*lda + *m) * *m) {
+
+/* WORK(IU) is LDA by M and WORK(IR) is M by M */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *m;
+ } else {
+
+/* WORK(IU) is M by M and WORK(IR) is M by M */
+
+ ldwrku = *m;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *m;
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy L to WORK(IU), zeroing out below it */
+
+ zlacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[iu +
+ ldwrku], &ldwrku);
+
+/* Generate Q in A */
+/* (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunglq_(m, n, m, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IU), copying result to */
+/* WORK(IR) */
+/* (CWorkspace: need 2*M*M+3*M, */
+/* prefer 2*M*M+2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(m, m, &work[iu], &ldwrku, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ zlacpy_("L", m, m, &work[iu], &ldwrku, &work[ir], &
+ ldwrkr);
+
+/* Generate right bidiagonalizing vectors in WORK(IU) */
+/* (CWorkspace: need 2*M*M+3*M-1, */
+/* prefer 2*M*M+2*M+(M-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in WORK(IR) */
+/* (CWorkspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("Q", m, m, m, &work[ir], &ldwrkr, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of L in WORK(IR) and computing */
+/* right singular vectors of L in WORK(IU) */
+/* (CWorkspace: need 2*M*M) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", m, m, m, &c__0, &s[1], &rwork[ie], &work[
+ iu], &ldwrku, &work[ir], &ldwrkr, cdum, &c__1,
+ &rwork[irwork], info);
+
+/* Multiply right singular vectors of L in WORK(IU) by */
+/* Q in A, storing result in VT */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: 0) */
+
+ zgemm_("N", "N", m, n, m, &c_b2, &work[iu], &ldwrku, &
+ a[a_offset], lda, &c_b1, &vt[vt_offset], ldvt);
+
+/* Copy left singular vectors of L to A */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: 0) */
+
+ zlacpy_("F", m, m, &work[ir], &ldwrkr, &a[a_offset],
+ lda);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Zero out above L in A */
+
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &a[(a_dim1 <<
+ 1) + 1], lda);
+
+/* Bidiagonalize L in A */
+/* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right vectors bidiagonalizing L by Q in VT */
+/* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunmbr_("P", "L", "C", m, n, m, &a[a_offset], lda, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors of L in A */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in A and computing right */
+/* singular vectors of A in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", m, n, m, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &a[a_offset], lda, cdum, &
+ c__1, &rwork[irwork], info);
+
+ }
+
+ } else if (wntuas) {
+
+/* Path 6t(N much larger than M, JOBU='S' or 'A', */
+/* JOBVT='S') */
+/* M right singular vectors to be computed in VT and */
+/* M left singular vectors to be computed in U */
+
+ if (*lwork >= *m * *m + *m * 3) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + *lda * *m) {
+
+/* WORK(IU) is LDA by N */
+
+ ldwrku = *lda;
+ } else {
+
+/* WORK(IU) is LDA by M */
+
+ ldwrku = *m;
+ }
+ itau = iu + ldwrku * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+
+/* Copy L to WORK(IU), zeroing out above it */
+
+ zlacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[iu +
+ ldwrku], &ldwrku);
+
+/* Generate Q in A */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunglq_(m, n, m, &a[a_offset], lda, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IU), copying result to U */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(m, m, &work[iu], &ldwrku, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ zlacpy_("L", m, m, &work[iu], &ldwrku, &u[u_offset],
+ ldu);
+
+/* Generate right bidiagonalizing vectors in WORK(IU) */
+/* (CWorkspace: need M*M+3*M-1, */
+/* prefer M*M+2*M+(M-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in U */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of L in U and computing right */
+/* singular vectors of L in WORK(IU) */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", m, m, m, &c__0, &s[1], &rwork[ie], &work[
+ iu], &ldwrku, &u[u_offset], ldu, cdum, &c__1,
+ &rwork[irwork], info);
+
+/* Multiply right singular vectors of L in WORK(IU) by */
+/* Q in A, storing result in VT */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: 0) */
+
+ zgemm_("N", "N", m, n, m, &c_b2, &work[iu], &ldwrku, &
+ a[a_offset], lda, &c_b1, &vt[vt_offset], ldvt);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunglq_(m, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy L to U, zeroing out above it */
+
+ zlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset],
+ ldu);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &u[(u_dim1 <<
+ 1) + 1], ldu);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in U */
+/* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(m, m, &u[u_offset], ldu, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right bidiagonalizing vectors in U by Q */
+/* in VT */
+/* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunmbr_("P", "L", "C", m, n, m, &u[u_offset], ldu, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in U */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", m, n, m, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, cdum, &
+ c__1, &rwork[irwork], info);
+
+ }
+
+ }
+
+ } else if (wntva) {
+
+ if (wntun) {
+
+/* Path 7t(N much larger than M, JOBU='N', JOBVT='A') */
+/* N right singular vectors to be computed in VT and */
+/* no left singular vectors to be computed */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *m * 3;
+ if (*lwork >= *m * *m + max(i__2,i__3)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ ir = 1;
+ if (*lwork >= wrkbl + *lda * *m) {
+
+/* WORK(IR) is LDA by M */
+
+ ldwrkr = *lda;
+ } else {
+
+/* WORK(IR) is M by M */
+
+ ldwrkr = *m;
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Copy L to WORK(IR), zeroing out above it */
+
+ zlacpy_("L", m, m, &a[a_offset], lda, &work[ir], &
+ ldwrkr);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[ir +
+ ldwrkr], &ldwrkr);
+
+/* Generate Q in VT */
+/* (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IR) */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(m, m, &work[ir], &ldwrkr, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Generate right bidiagonalizing vectors in WORK(IR) */
+/* (CWorkspace: need M*M+3*M-1, */
+/* prefer M*M+2*M+(M-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("P", m, m, m, &work[ir], &ldwrkr, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of L in WORK(IR) */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", m, m, &c__0, &c__0, &s[1], &rwork[ie], &
+ work[ir], &ldwrkr, cdum, &c__1, cdum, &c__1, &
+ rwork[irwork], info);
+
+/* Multiply right singular vectors of L in WORK(IR) by */
+/* Q in VT, storing result in A */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: 0) */
+
+ zgemm_("N", "N", m, n, m, &c_b2, &work[ir], &ldwrkr, &
+ vt[vt_offset], ldvt, &c_b1, &a[a_offset], lda);
+
+/* Copy right singular vectors of A from A to VT */
+
+ zlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (CWorkspace: need M+N, prefer M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Zero out above L in A */
+
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &a[(a_dim1 <<
+ 1) + 1], lda);
+
+/* Bidiagonalize L in A */
+/* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right bidiagonalizing vectors in A by Q */
+/* in VT */
+/* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunmbr_("P", "L", "C", m, n, m, &a[a_offset], lda, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing right */
+/* singular vectors of A in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", m, n, &c__0, &c__0, &s[1], &rwork[ie], &
+ vt[vt_offset], ldvt, cdum, &c__1, cdum, &c__1,
+ &rwork[irwork], info);
+
+ }
+
+ } else if (wntuo) {
+
+/* Path 8t(N much larger than M, JOBU='O', JOBVT='A') */
+/* N right singular vectors to be computed in VT and */
+/* M left singular vectors to be overwritten on A */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *m * 3;
+ if (*lwork >= (*m << 1) * *m + max(i__2,i__3)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + (*lda << 1) * *m) {
+
+/* WORK(IU) is LDA by M and WORK(IR) is LDA by M */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *lda;
+ } else if (*lwork >= wrkbl + (*lda + *m) * *m) {
+
+/* WORK(IU) is LDA by M and WORK(IR) is M by M */
+
+ ldwrku = *lda;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *m;
+ } else {
+
+/* WORK(IU) is M by M and WORK(IR) is M by M */
+
+ ldwrku = *m;
+ ir = iu + ldwrku * *m;
+ ldwrkr = *m;
+ }
+ itau = ir + ldwrkr * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (CWorkspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy L to WORK(IU), zeroing out above it */
+
+ zlacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[iu +
+ ldwrku], &ldwrku);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IU), copying result to */
+/* WORK(IR) */
+/* (CWorkspace: need 2*M*M+3*M, */
+/* prefer 2*M*M+2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(m, m, &work[iu], &ldwrku, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ zlacpy_("L", m, m, &work[iu], &ldwrku, &work[ir], &
+ ldwrkr);
+
+/* Generate right bidiagonalizing vectors in WORK(IU) */
+/* (CWorkspace: need 2*M*M+3*M-1, */
+/* prefer 2*M*M+2*M+(M-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in WORK(IR) */
+/* (CWorkspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("Q", m, m, m, &work[ir], &ldwrkr, &work[itauq]
+, &work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of L in WORK(IR) and computing */
+/* right singular vectors of L in WORK(IU) */
+/* (CWorkspace: need 2*M*M) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", m, m, m, &c__0, &s[1], &rwork[ie], &work[
+ iu], &ldwrku, &work[ir], &ldwrkr, cdum, &c__1,
+ &rwork[irwork], info);
+
+/* Multiply right singular vectors of L in WORK(IU) by */
+/* Q in VT, storing result in A */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: 0) */
+
+ zgemm_("N", "N", m, n, m, &c_b2, &work[iu], &ldwrku, &
+ vt[vt_offset], ldvt, &c_b1, &a[a_offset], lda);
+
+/* Copy right singular vectors of A from A to VT */
+
+ zlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Copy left singular vectors of A from WORK(IR) to A */
+
+ zlacpy_("F", m, m, &work[ir], &ldwrkr, &a[a_offset],
+ lda);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (CWorkspace: need M+N, prefer M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Zero out above L in A */
+
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &a[(a_dim1 <<
+ 1) + 1], lda);
+
+/* Bidiagonalize L in A */
+/* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(m, m, &a[a_offset], lda, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right bidiagonalizing vectors in A by Q */
+/* in VT */
+/* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunmbr_("P", "L", "C", m, n, m, &a[a_offset], lda, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in A */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("Q", m, m, m, &a[a_offset], lda, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in A and computing right */
+/* singular vectors of A in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", m, n, m, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &a[a_offset], lda, cdum, &
+ c__1, &rwork[irwork], info);
+
+ }
+
+ } else if (wntuas) {
+
+/* Path 9t(N much larger than M, JOBU='S' or 'A', */
+/* JOBVT='A') */
+/* N right singular vectors to be computed in VT and */
+/* M left singular vectors to be computed in U */
+
+/* Computing MAX */
+ i__2 = *n + *m, i__3 = *m * 3;
+ if (*lwork >= *m * *m + max(i__2,i__3)) {
+
+/* Sufficient workspace for a fast algorithm */
+
+ iu = 1;
+ if (*lwork >= wrkbl + *lda * *m) {
+
+/* WORK(IU) is LDA by M */
+
+ ldwrku = *lda;
+ } else {
+
+/* WORK(IU) is M by M */
+
+ ldwrku = *m;
+ }
+ itau = iu + ldwrku * *m;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy L to WORK(IU), zeroing out above it */
+
+ zlacpy_("L", m, m, &a[a_offset], lda, &work[iu], &
+ ldwrku);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &work[iu +
+ ldwrku], &ldwrku);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in WORK(IU), copying result to U */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(m, m, &work[iu], &ldwrku, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+ zlacpy_("L", m, m, &work[iu], &ldwrku, &u[u_offset],
+ ldu);
+
+/* Generate right bidiagonalizing vectors in WORK(IU) */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+(M-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("P", m, m, m, &work[iu], &ldwrku, &work[itaup]
+, &work[iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in U */
+/* (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of L in U and computing right */
+/* singular vectors of L in WORK(IU) */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", m, m, m, &c__0, &s[1], &rwork[ie], &work[
+ iu], &ldwrku, &u[u_offset], ldu, cdum, &c__1,
+ &rwork[irwork], info);
+
+/* Multiply right singular vectors of L in WORK(IU) by */
+/* Q in VT, storing result in A */
+/* (CWorkspace: need M*M) */
+/* (RWorkspace: 0) */
+
+ zgemm_("N", "N", m, n, m, &c_b2, &work[iu], &ldwrku, &
+ vt[vt_offset], ldvt, &c_b1, &a[a_offset], lda);
+
+/* Copy right singular vectors of A from A to VT */
+
+ zlacpy_("F", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+ } else {
+
+/* Insufficient workspace for a fast algorithm */
+
+ itau = 1;
+ iwork = itau + *m;
+
+/* Compute A=L*Q, copying result to VT */
+/* (CWorkspace: need 2*M, prefer M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[
+ iwork], &i__2, &ierr);
+ zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset],
+ ldvt);
+
+/* Generate Q in VT */
+/* (CWorkspace: need M+N, prefer M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunglq_(n, n, m, &vt[vt_offset], ldvt, &work[itau], &
+ work[iwork], &i__2, &ierr);
+
+/* Copy L to U, zeroing out above it */
+
+ zlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset],
+ ldu);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ zlaset_("U", &i__2, &i__3, &c_b1, &c_b1, &u[(u_dim1 <<
+ 1) + 1], ldu);
+ ie = 1;
+ itauq = itau;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize L in U */
+/* (CWorkspace: need 3*M, prefer 2*M+2*M*NB) */
+/* (RWorkspace: need M) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(m, m, &u[u_offset], ldu, &s[1], &rwork[ie], &
+ work[itauq], &work[itaup], &work[iwork], &
+ i__2, &ierr);
+
+/* Multiply right bidiagonalizing vectors in U by Q */
+/* in VT */
+/* (CWorkspace: need 2*M+N, prefer 2*M+N*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zunmbr_("P", "L", "C", m, n, m, &u[u_offset], ldu, &
+ work[itaup], &vt[vt_offset], ldvt, &work[
+ iwork], &i__2, &ierr);
+
+/* Generate left bidiagonalizing vectors in U */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("Q", m, m, m, &u[u_offset], ldu, &work[itauq],
+ &work[iwork], &i__2, &ierr);
+ irwork = ie + *m;
+
+/* Perform bidiagonal QR iteration, computing left */
+/* singular vectors of A in U and computing right */
+/* singular vectors of A in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("U", m, n, m, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, cdum, &
+ c__1, &rwork[irwork], info);
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N .LT. MNTHR */
+
+/* Path 10t(N greater than M, but not much larger) */
+/* Reduce to bidiagonal form without LQ decomposition */
+
+ ie = 1;
+ itauq = 1;
+ itaup = itauq + *m;
+ iwork = itaup + *m;
+
+/* Bidiagonalize A */
+/* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) */
+/* (RWorkspace: M) */
+
+ i__2 = *lwork - iwork + 1;
+ zgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq],
+ &work[itaup], &work[iwork], &i__2, &ierr);
+ if (wntuas) {
+
+/* If left singular vectors desired in U, copy result to U */
+/* and generate left bidiagonalizing vectors in U */
+/* (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB) */
+/* (RWorkspace: 0) */
+
+ zlacpy_("L", m, m, &a[a_offset], lda, &u[u_offset], ldu);
+ i__2 = *lwork - iwork + 1;
+ zungbr_("Q", m, m, n, &u[u_offset], ldu, &work[itauq], &work[
+ iwork], &i__2, &ierr);
+ }
+ if (wntvas) {
+
+/* If right singular vectors desired in VT, copy result to */
+/* VT and generate right bidiagonalizing vectors in VT */
+/* (CWorkspace: need 2*M+NRVT, prefer 2*M+NRVT*NB) */
+/* (RWorkspace: 0) */
+
+ zlacpy_("U", m, n, &a[a_offset], lda, &vt[vt_offset], ldvt);
+ if (wntva) {
+ nrvt = *n;
+ }
+ if (wntvs) {
+ nrvt = *m;
+ }
+ i__2 = *lwork - iwork + 1;
+ zungbr_("P", &nrvt, n, m, &vt[vt_offset], ldvt, &work[itaup],
+ &work[iwork], &i__2, &ierr);
+ }
+ if (wntuo) {
+
+/* If left singular vectors desired in A, generate left */
+/* bidiagonalizing vectors in A */
+/* (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("Q", m, m, n, &a[a_offset], lda, &work[itauq], &work[
+ iwork], &i__2, &ierr);
+ }
+ if (wntvo) {
+
+/* If right singular vectors desired in A, generate right */
+/* bidiagonalizing vectors in A */
+/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */
+/* (RWorkspace: 0) */
+
+ i__2 = *lwork - iwork + 1;
+ zungbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[
+ iwork], &i__2, &ierr);
+ }
+ irwork = ie + *m;
+ if (wntuas || wntuo) {
+ nru = *m;
+ }
+ if (wntun) {
+ nru = 0;
+ }
+ if (wntvas || wntvo) {
+ ncvt = *n;
+ }
+ if (wntvn) {
+ ncvt = 0;
+ }
+ if (! wntuo && ! wntvo) {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in U and computing right singular */
+/* vectors in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &u[u_offset], ldu, cdum, &c__1, &
+ rwork[irwork], info);
+ } else if (! wntuo && wntvo) {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in U and computing right singular */
+/* vectors in A */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &a[
+ a_offset], lda, &u[u_offset], ldu, cdum, &c__1, &
+ rwork[irwork], info);
+ } else {
+
+/* Perform bidiagonal QR iteration, if desired, computing */
+/* left singular vectors in A and computing right singular */
+/* vectors in VT */
+/* (CWorkspace: 0) */
+/* (RWorkspace: need BDSPAC) */
+
+ zbdsqr_("L", m, &ncvt, &nru, &c__0, &s[1], &rwork[ie], &vt[
+ vt_offset], ldvt, &a[a_offset], lda, cdum, &c__1, &
+ rwork[irwork], info);
+ }
+
+ }
+
+ }
+
+/* Undo scaling if necessary */
+
+ if (iscl == 1) {
+ if (anrm > bignum) {
+ dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, &ierr);
+ }
+ if (*info != 0 && anrm > bignum) {
+ i__2 = minmn - 1;
+ dlascl_("G", &c__0, &c__0, &bignum, &anrm, &i__2, &c__1, &rwork[
+ ie], &minmn, &ierr);
+ }
+ if (anrm < smlnum) {
+ dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], &
+ minmn, &ierr);
+ }
+ if (*info != 0 && anrm < smlnum) {
+ i__2 = minmn - 1;
+ dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &i__2, &c__1, &rwork[
+ ie], &minmn, &ierr);
+ }
+ }
+
+/* Return optimal workspace in WORK(1) */
+
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZGESVD */
+
+} /* zgesvd_ */
diff --git a/SRC/zgesvx.c b/SRC/zgesvx.c
new file mode 100644
index 0000000..44a3ff7
--- /dev/null
+++ b/SRC/zgesvx.c
@@ -0,0 +1,610 @@
+/* zgesvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zgesvx_(char *fact, char *trans, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, integer *ipiv, char *equed, doublereal *r__, doublereal *c__,
+ doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
+ doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *
+ work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal amax;
+ char norm[1];
+ extern logical lsame_(char *, char *);
+ doublereal rcmin, rcmax, anorm;
+ logical equil;
+ extern doublereal dlamch_(char *);
+ doublereal colcnd;
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ doublereal bignum;
+ extern /* Subroutine */ int zlaqge_(integer *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *
+, doublereal *, char *), zgecon_(char *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *);
+ integer infequ;
+ logical colequ;
+ doublereal rowcnd;
+ extern /* Subroutine */ int zgeequ_(integer *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *
+, doublereal *, integer *);
+ logical notran;
+ extern /* Subroutine */ int zgerfs_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zgetrf_(integer *, integer *, doublecomplex *,
+ integer *, integer *, integer *), zlacpy_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal zlantr_(char *, char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+ doublereal smlnum;
+ extern /* Subroutine */ int zgetrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *);
+ logical rowequ;
+ doublereal rpvgrw;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGESVX uses the LU factorization to compute the solution to a complex */
+/* system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */
+/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */
+/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */
+/* or diag(C)*B (if TRANS = 'T' or 'C'). */
+
+/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the */
+/* matrix A (after equilibration if FACT = 'E') as */
+/* A = P * L * U, */
+/* where P is a permutation matrix, L is a unit lower triangular */
+/* matrix, and U is upper triangular. */
+
+/* 3. If some U(i,i)=0, so that U is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */
+/* that it solves the original system before equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF and IPIV contain the factored form of A. */
+/* If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by R and C. */
+/* A, AF, and IPIV are not modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is */
+/* not 'N', then A must have been equilibrated by the scaling */
+/* factors in R and/or C. A is not modified if FACT = 'F' or */
+/* 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
+
+/* On exit, if EQUED .ne. 'N', A is scaled as follows: */
+/* EQUED = 'R': A := diag(R) * A */
+/* EQUED = 'C': A := A * diag(C) */
+/* EQUED = 'B': A := diag(R) * A * diag(C). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) COMPLEX*16 array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the factors L and U from the factorization */
+/* A = P*L*U as computed by ZGETRF. If EQUED .ne. 'N', then */
+/* AF is the factored form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the equilibrated matrix A (see the description of A for */
+/* the form of the equilibrated matrix). */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* as computed by ZGETRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the equilibrated matrix A. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* R (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+
+/* C (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */
+/* diag(R)*B; */
+/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */
+/* overwritten by diag(C)*B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X */
+/* to the original system of equations. Note that A and B are */
+/* modified on exit if EQUED .ne. 'N', and the solution to the */
+/* equilibrated system is inv(diag(C))*X if TRANS = 'N' and */
+/* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' */
+/* and EQUED = 'R' or 'B'. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A after equilibration (if done). If RCOND is less than the */
+/* machine precision (in particular, if RCOND = 0), the matrix */
+/* is singular to working precision. This condition is */
+/* indicated by a return code of INFO > 0. */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace/output) DOUBLE PRECISION array, dimension (2*N) */
+/* On exit, RWORK(1) contains the reciprocal pivot growth */
+/* factor norm(A)/norm(U). The "max absolute element" norm is */
+/* used. If RWORK(1) is much less than 1, then the stability */
+/* of the LU factorization of the (equilibrated) matrix A */
+/* could be poor. This also means that the solution X, condition */
+/* estimator RCOND, and forward error bound FERR could be */
+/* unreliable. If factorization fails with 0<INFO<=N, then */
+/* RWORK(1) contains the reciprocal pivot growth factor for the */
+/* leading INFO columns of A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: U(i,i) is exactly zero. The factorization has */
+/* been completed, but the factor U is exactly */
+/* singular, so the solution and error bounds */
+/* could not be computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ notran = lsame_(trans, "N");
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rowequ = FALSE_;
+ colequ = FALSE_;
+ } else {
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ }
+
+/* Test the input parameters. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (lsame_(fact, "F") && ! (rowequ || colequ
+ || lsame_(equed, "N"))) {
+ *info = -10;
+ } else {
+ if (rowequ) {
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = r__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = r__[j];
+ rcmax = max(d__1,d__2);
+/* L10: */
+ }
+ if (rcmin <= 0.) {
+ *info = -11;
+ } else if (*n > 0) {
+ rowcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ } else {
+ rowcnd = 1.;
+ }
+ }
+ if (colequ && *info == 0) {
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = c__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = c__[j];
+ rcmax = max(d__1,d__2);
+/* L20: */
+ }
+ if (rcmin <= 0.) {
+ *info = -12;
+ } else if (*n > 0) {
+ colcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ } else {
+ colcnd = 1.;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -14;
+ } else if (*ldx < max(1,*n)) {
+ *info = -16;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGESVX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ zgeequ_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &colcnd, &
+ amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ zlaqge_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &
+ colcnd, &amax, equed);
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+ }
+
+/* Scale the right hand side. */
+
+ if (notran) {
+ if (rowequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * b_dim1;
+ z__1.r = r__[i__4] * b[i__5].r, z__1.i = r__[i__4] * b[
+ i__5].i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else if (colequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * b_dim1;
+ z__1.r = c__[i__4] * b[i__5].r, z__1.i = c__[i__4] * b[i__5]
+ .i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of A. */
+
+ zlacpy_("Full", n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ zgetrf_(n, n, &af[af_offset], ldaf, &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ rpvgrw = zlantr_("M", "U", "N", info, info, &af[af_offset], ldaf,
+ &rwork[1]);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = zlange_("M", n, info, &a[a_offset], lda, &rwork[1]) / rpvgrw;
+ }
+ rwork[1] = rpvgrw;
+ *rcond = 0.;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A and the */
+/* reciprocal pivot growth factor RPVGRW. */
+
+ if (notran) {
+ *(unsigned char *)norm = '1';
+ } else {
+ *(unsigned char *)norm = 'I';
+ }
+ anorm = zlange_(norm, n, n, &a[a_offset], lda, &rwork[1]);
+ rpvgrw = zlantr_("M", "U", "N", n, n, &af[af_offset], ldaf, &rwork[1]);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = zlange_("M", n, n, &a[a_offset], lda, &rwork[1]) /
+ rpvgrw;
+ }
+
+/* Compute the reciprocal of the condition number of A. */
+
+ zgecon_(norm, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &rwork[1],
+ info);
+
+/* Compute the solution matrix X. */
+
+ zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ zgetrs_(trans, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ zgerfs_(trans, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1],
+ &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[
+ 1], &rwork[1], info);
+
+/* Transform the solution matrix X to a solution of the original */
+/* system. */
+
+ if (notran) {
+ if (colequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * x_dim1;
+ z__1.r = c__[i__4] * x[i__5].r, z__1.i = c__[i__4] * x[
+ i__5].i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= colcnd;
+/* L90: */
+ }
+ }
+ } else if (rowequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * x_dim1;
+ z__1.r = r__[i__4] * x[i__5].r, z__1.i = r__[i__4] * x[i__5]
+ .i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+/* L100: */
+ }
+/* L110: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= rowcnd;
+/* L120: */
+ }
+ }
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < dlamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ rwork[1] = rpvgrw;
+ return 0;
+
+/* End of ZGESVX */
+
+} /* zgesvx_ */
diff --git a/SRC/zgesvxx.c b/SRC/zgesvxx.c
new file mode 100644
index 0000000..fcd0706
--- /dev/null
+++ b/SRC/zgesvxx.c
@@ -0,0 +1,716 @@
+/* zgesvxx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zgesvxx_(char *fact, char *trans, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, integer *ipiv, char *equed, doublereal *r__, doublereal *c__,
+ doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
+ doublereal *rcond, doublereal *rpvgrw, doublereal *berr, integer *
+ n_err_bnds__, doublereal *err_bnds_norm__, doublereal *
+ err_bnds_comp__, integer *nparams, doublereal *params, doublecomplex *
+ work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ extern doublereal zla_rpvgrw__(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *);
+ doublereal amax;
+ extern logical lsame_(char *, char *);
+ doublereal rcmin, rcmax;
+ logical equil;
+ extern doublereal dlamch_(char *);
+ doublereal colcnd;
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int zlaqge_(integer *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *
+, doublereal *, char *);
+ integer infequ;
+ logical colequ;
+ doublereal rowcnd;
+ logical notran;
+ extern /* Subroutine */ int zgetrf_(integer *, integer *, doublecomplex *,
+ integer *, integer *, integer *), zlacpy_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal smlnum;
+ extern /* Subroutine */ int zgetrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *);
+ logical rowequ;
+ extern /* Subroutine */ int zlascl2_(integer *, integer *, doublereal *,
+ doublecomplex *, integer *), zgeequb_(integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *), zgerfsx_(
+ char *, char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, doublecomplex *, doublereal *, integer *
+);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGESVXX uses the LU factorization to compute the solution to a */
+/* complex*16 system of linear equations A * X = B, where A is an */
+/* N-by-N matrix and X and B are N-by-NRHS matrices. */
+
+/* If requested, both normwise and maximum componentwise error bounds */
+/* are returned. ZGESVXX will return a solution with a tiny */
+/* guaranteed error (O(eps) where eps is the working machine */
+/* precision) unless the matrix is very ill-conditioned, in which */
+/* case a warning is returned. Relevant condition numbers also are */
+/* calculated and returned. */
+
+/* ZGESVXX accepts user-provided factorizations and equilibration */
+/* factors; see the definitions of the FACT and EQUED options. */
+/* Solving with refinement and using a factorization from a previous */
+/* ZGESVXX call will also produce a solution with either O(eps) */
+/* errors or warnings, but we cannot make that claim for general */
+/* user-provided factorizations and equilibration factors if they */
+/* differ from what ZGESVXX would itself produce. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate */
+/* the system: */
+
+/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */
+/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */
+/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */
+
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */
+/* or diag(C)*B (if TRANS = 'T' or 'C'). */
+
+/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */
+/* the matrix A (after equilibration if FACT = 'E') as */
+
+/* A = P * L * U, */
+
+/* where P is a permutation matrix, L is a unit lower triangular */
+/* matrix, and U is upper triangular. */
+
+/* 3. If some U(i,i)=0, so that U is exactly singular, then the */
+/* routine returns with INFO = i. Otherwise, the factored form of A */
+/* is used to estimate the condition number of the matrix A (see */
+/* argument RCOND). If the reciprocal of the condition number is less */
+/* than machine precision, the routine still goes on to solve for X */
+/* and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */
+/* the routine will use iterative refinement to try to get a small */
+/* error and error bounds. Refinement calculates the residual to at */
+/* least twice the working precision. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */
+/* that it solves the original system before equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF and IPIV contain the factored form of A. */
+/* If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by R and C. */
+/* A, AF, and IPIV are not modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is */
+/* not 'N', then A must have been equilibrated by the scaling */
+/* factors in R and/or C. A is not modified if FACT = 'F' or */
+/* 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
+
+/* On exit, if EQUED .ne. 'N', A is scaled as follows: */
+/* EQUED = 'R': A := diag(R) * A */
+/* EQUED = 'C': A := A * diag(C) */
+/* EQUED = 'B': A := diag(R) * A * diag(C). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) COMPLEX*16 array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the factors L and U from the factorization */
+/* A = P*L*U as computed by ZGETRF. If EQUED .ne. 'N', then */
+/* AF is the factored form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then AF is an output argument and on exit */
+/* returns the factors L and U from the factorization A = P*L*U */
+/* of the equilibrated matrix A (see the description of A for */
+/* the form of the equilibrated matrix). */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* as computed by ZGETRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the original matrix A. */
+
+/* If FACT = 'E', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the factorization A = P*L*U */
+/* of the equilibrated matrix A. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* R (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
+/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
+/* is not accessed. R is an input argument if FACT = 'F'; */
+/* otherwise, R is an output argument. If FACT = 'F' and */
+/* EQUED = 'R' or 'B', each element of R must be positive. */
+/* If R is output, each element of R is a power of the radix. */
+/* If R is input, each element of R should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* C (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
+/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
+/* is not accessed. C is an input argument if FACT = 'F'; */
+/* otherwise, C is an output argument. If FACT = 'F' and */
+/* EQUED = 'C' or 'B', each element of C must be positive. */
+/* If C is output, each element of C is a power of the radix. */
+/* If C is input, each element of C should be a power of the radix */
+/* to ensure a reliable solution and error estimates. Scaling by */
+/* powers of the radix does not cause rounding errors unless the */
+/* result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */
+/* diag(R)*B; */
+/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */
+/* overwritten by diag(C)*B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* If INFO = 0, the N-by-NRHS solution matrix X to the original */
+/* system of equations. Note that A and B are modified on exit */
+/* if EQUED .ne. 'N', and the solution to the equilibrated system is */
+/* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or */
+/* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* RPVGRW (output) DOUBLE PRECISION */
+/* Reciprocal pivot growth. On exit, this contains the reciprocal */
+/* pivot growth factor norm(A)/norm(U). The "max absolute element" */
+/* norm is used. If this is much less than 1, then the stability of */
+/* the LU factorization of the (equilibrated) matrix A could be poor. */
+/* This also means that the solution X, estimated condition numbers, */
+/* and error bounds could be unreliable. If factorization fails with */
+/* 0<INFO<=N, then this contains the reciprocal pivot growth factor */
+/* for the leading INFO columns of A. In ZGESVX, this quantity is */
+/* returned in WORK(1). */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0D+0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the extra-precise refinement algorithm. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --r__;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ notran = lsame_(trans, "N");
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rowequ = FALSE_;
+ colequ = FALSE_;
+ } else {
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+
+/* Default is failure. If an input parameter is wrong or */
+/* factorization fails, make everything look horrible. Only the */
+/* pivot growth is set here, the rest is initialized in ZGERFSX. */
+
+ *rpvgrw = 0.;
+
+/* Test the input parameters. PARAMS is not tested until ZGERFSX. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (lsame_(fact, "F") && ! (rowequ || colequ
+ || lsame_(equed, "N"))) {
+ *info = -10;
+ } else {
+ if (rowequ) {
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = r__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = r__[j];
+ rcmax = max(d__1,d__2);
+/* L10: */
+ }
+ if (rcmin <= 0.) {
+ *info = -11;
+ } else if (*n > 0) {
+ rowcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ } else {
+ rowcnd = 1.;
+ }
+ }
+ if (colequ && *info == 0) {
+ rcmin = bignum;
+ rcmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = c__[j];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = c__[j];
+ rcmax = max(d__1,d__2);
+/* L20: */
+ }
+ if (rcmin <= 0.) {
+ *info = -12;
+ } else if (*n > 0) {
+ colcnd = max(rcmin,smlnum) / min(rcmax,bignum);
+ } else {
+ colcnd = 1.;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -14;
+ } else if (*ldx < max(1,*n)) {
+ *info = -16;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGESVXX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ zgeequb_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &colcnd,
+ &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ zlaqge_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &
+ colcnd, &amax, equed);
+ rowequ = lsame_(equed, "R") || lsame_(equed,
+ "B");
+ colequ = lsame_(equed, "C") || lsame_(equed,
+ "B");
+ }
+
+/* If the scaling factors are not applied, set them to 1.0. */
+
+ if (! rowequ) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ r__[j] = 1.;
+ }
+ }
+ if (! colequ) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ c__[j] = 1.;
+ }
+ }
+ }
+
+/* Scale the right-hand side. */
+
+ if (notran) {
+ if (rowequ) {
+ zlascl2_(n, nrhs, &r__[1], &b[b_offset], ldb);
+ }
+ } else {
+ if (colequ) {
+ zlascl2_(n, nrhs, &c__[1], &b[b_offset], ldb);
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of A. */
+
+ zlacpy_("Full", n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ zgetrf_(n, n, &af[af_offset], ldaf, &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Pivot in column INFO is exactly 0 */
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ *rpvgrw = zla_rpvgrw__(n, info, &a[a_offset], lda, &af[af_offset],
+ ldaf);
+ return 0;
+ }
+ }
+
+/* Compute the reciprocal pivot growth factor RPVGRW. */
+
+ *rpvgrw = zla_rpvgrw__(n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+
+/* Compute the solution matrix X. */
+
+ zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ zgetrs_(trans, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ zgerfsx_(trans, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &
+ ipiv[1], &r__[1], &c__[1], &b[b_offset], ldb, &x[x_offset], ldx,
+ rcond, &berr[1], n_err_bnds__, &err_bnds_norm__[
+ err_bnds_norm_offset], &err_bnds_comp__[err_bnds_comp_offset],
+ nparams, ¶ms[1], &work[1], &rwork[1], info);
+
+/* Scale solutions. */
+
+ if (colequ && notran) {
+ zlascl2_(n, nrhs, &c__[1], &x[x_offset], ldx);
+ } else if (rowequ && ! notran) {
+ zlascl2_(n, nrhs, &r__[1], &x[x_offset], ldx);
+ }
+
+ return 0;
+
+/* End of ZGESVXX */
+
+} /* zgesvxx_ */
diff --git a/SRC/zgetc2.c b/SRC/zgetc2.c
new file mode 100644
index 0000000..672180f
--- /dev/null
+++ b/SRC/zgetc2.c
@@ -0,0 +1,209 @@
+/* zgetc2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublecomplex c_b10 = {-1.,-0.};
+
+/* Subroutine */ int zgetc2_(integer *n, doublecomplex *a, integer *lda,
+ integer *ipiv, integer *jpiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, ip, jp;
+ doublereal eps;
+ integer ipv, jpv;
+ doublereal smin, xmax;
+ extern /* Subroutine */ int zgeru_(integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), dlabad_(doublereal *,
+ doublereal *);
+ extern doublereal dlamch_(char *);
+ doublereal bignum, smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGETC2 computes an LU factorization, using complete pivoting, of the */
+/* n-by-n matrix A. The factorization has the form A = P * L * U * Q, */
+/* where P and Q are permutation matrices, L is lower triangular with */
+/* unit diagonal elements and U is upper triangular. */
+
+/* This is a level 1 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA, N) */
+/* On entry, the n-by-n matrix to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U*Q; the unit diagonal elements of L are not stored. */
+/* If U(k, k) appears to be less than SMIN, U(k, k) is given the */
+/* value of SMIN, giving a nonsingular perturbed system. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1, N). */
+
+/* IPIV (output) INTEGER array, dimension (N). */
+/* The pivot indices; for 1 <= i <= N, row i of the */
+/* matrix has been interchanged with row IPIV(i). */
+
+/* JPIV (output) INTEGER array, dimension (N). */
+/* The pivot indices; for 1 <= j <= N, column j of the */
+/* matrix has been interchanged with column JPIV(j). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* > 0: if INFO = k, U(k, k) is likely to produce overflow if */
+/* one tries to solve for x in Ax = b. So U is perturbed */
+/* to avoid the overflow. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Set constants to control overflow */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --jpiv;
+
+ /* Function Body */
+ *info = 0;
+ eps = dlamch_("P");
+ smlnum = dlamch_("S") / eps;
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Factorize A using complete pivoting. */
+/* Set pivots less than SMIN to SMIN */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Find max element in matrix A */
+
+ xmax = 0.;
+ i__2 = *n;
+ for (ip = i__; ip <= i__2; ++ip) {
+ i__3 = *n;
+ for (jp = i__; jp <= i__3; ++jp) {
+ if (z_abs(&a[ip + jp * a_dim1]) >= xmax) {
+ xmax = z_abs(&a[ip + jp * a_dim1]);
+ ipv = ip;
+ jpv = jp;
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+ if (i__ == 1) {
+/* Computing MAX */
+ d__1 = eps * xmax;
+ smin = max(d__1,smlnum);
+ }
+
+/* Swap rows */
+
+ if (ipv != i__) {
+ zswap_(n, &a[ipv + a_dim1], lda, &a[i__ + a_dim1], lda);
+ }
+ ipiv[i__] = ipv;
+
+/* Swap columns */
+
+ if (jpv != i__) {
+ zswap_(n, &a[jpv * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
+ c__1);
+ }
+ jpiv[i__] = jpv;
+
+/* Check for singularity */
+
+ if (z_abs(&a[i__ + i__ * a_dim1]) < smin) {
+ *info = i__;
+ i__2 = i__ + i__ * a_dim1;
+ z__1.r = smin, z__1.i = 0.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ z_div(&z__1, &a[j + i__ * a_dim1], &a[i__ + i__ * a_dim1]);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L30: */
+ }
+ i__2 = *n - i__;
+ i__3 = *n - i__;
+ zgeru_(&i__2, &i__3, &c_b10, &a[i__ + 1 + i__ * a_dim1], &c__1, &a[
+ i__ + (i__ + 1) * a_dim1], lda, &a[i__ + 1 + (i__ + 1) *
+ a_dim1], lda);
+/* L40: */
+ }
+
+ if (z_abs(&a[*n + *n * a_dim1]) < smin) {
+ *info = *n;
+ i__1 = *n + *n * a_dim1;
+ z__1.r = smin, z__1.i = 0.;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ }
+ return 0;
+
+/* End of ZGETC2 */
+
+} /* zgetc2_ */
diff --git a/SRC/zgetf2.c b/SRC/zgetf2.c
new file mode 100644
index 0000000..ce382e3
--- /dev/null
+++ b/SRC/zgetf2.c
@@ -0,0 +1,202 @@
+/* zgetf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zgetf2_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, jp;
+ doublereal sfmin;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zgeru_(integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), zswap_(integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGETF2 computes an LU factorization of a general m-by-n matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* The factorization has the form */
+/* A = P * L * U */
+/* where P is a permutation matrix, L is lower triangular with unit */
+/* diagonal elements (lower trapezoidal if m > n), and U is upper */
+/* triangular (upper trapezoidal if m < n). */
+
+/* This is the right-looking Level 2 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the m by n matrix to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, U(k,k) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGETF2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Compute machine safe minimum */
+
+ sfmin = dlamch_("S");
+
+ i__1 = min(*m,*n);
+ for (j = 1; j <= i__1; ++j) {
+
+/* Find pivot and test for singularity. */
+
+ i__2 = *m - j + 1;
+ jp = j - 1 + izamax_(&i__2, &a[j + j * a_dim1], &c__1);
+ ipiv[j] = jp;
+ i__2 = jp + j * a_dim1;
+ if (a[i__2].r != 0. || a[i__2].i != 0.) {
+
+/* Apply the interchange to columns 1:N. */
+
+ if (jp != j) {
+ zswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda);
+ }
+
+/* Compute elements J+1:M of J-th column. */
+
+ if (j < *m) {
+ if (z_abs(&a[j + j * a_dim1]) >= sfmin) {
+ i__2 = *m - j;
+ z_div(&z__1, &c_b1, &a[j + j * a_dim1]);
+ zscal_(&i__2, &z__1, &a[j + 1 + j * a_dim1], &c__1);
+ } else {
+ i__2 = *m - j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ + j * a_dim1;
+ z_div(&z__1, &a[j + i__ + j * a_dim1], &a[j + j *
+ a_dim1]);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L20: */
+ }
+ }
+ }
+
+ } else if (*info == 0) {
+
+ *info = j;
+ }
+
+ if (j < min(*m,*n)) {
+
+/* Update trailing submatrix. */
+
+ i__2 = *m - j;
+ i__3 = *n - j;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__2, &i__3, &z__1, &a[j + 1 + j * a_dim1], &c__1, &a[j +
+ (j + 1) * a_dim1], lda, &a[j + 1 + (j + 1) * a_dim1], lda)
+ ;
+ }
+/* L10: */
+ }
+ return 0;
+
+/* End of ZGETF2 */
+
+} /* zgetf2_ */
diff --git a/SRC/zgetrf.c b/SRC/zgetrf.c
new file mode 100644
index 0000000..101dcd4
--- /dev/null
+++ b/SRC/zgetrf.c
@@ -0,0 +1,219 @@
+/* zgetrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zgetrf_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j, jb, nb, iinfo;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), ztrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *
+, doublecomplex *, integer *),
+ zgetf2_(integer *, integer *, doublecomplex *, integer *, integer
+ *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zlaswp_(integer *, doublecomplex *, integer *,
+ integer *, integer *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGETRF computes an LU factorization of a general M-by-N matrix A */
+/* using partial pivoting with row interchanges. */
+
+/* The factorization has the form */
+/* A = P * L * U */
+/* where P is a permutation matrix, L is lower triangular with unit */
+/* diagonal elements (lower trapezoidal if m > n), and U is upper */
+/* triangular (upper trapezoidal if m < n). */
+
+/* This is the right-looking Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix to be factored. */
+/* On exit, the factors L and U from the factorization */
+/* A = P*L*U; the unit diagonal elements of L are not stored. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* IPIV (output) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGETRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "ZGETRF", " ", m, n, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= min(*m,*n)) {
+
+/* Use unblocked code. */
+
+ zgetf2_(m, n, &a[a_offset], lda, &ipiv[1], info);
+ } else {
+
+/* Use blocked code. */
+
+ i__1 = min(*m,*n);
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = min(*m,*n) - j + 1;
+ jb = min(i__3,nb);
+
+/* Factor diagonal and subdiagonal blocks and test for exact */
+/* singularity. */
+
+ i__3 = *m - j + 1;
+ zgetf2_(&i__3, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo);
+
+/* Adjust INFO and the pivot indices. */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo + j - 1;
+ }
+/* Computing MIN */
+ i__4 = *m, i__5 = j + jb - 1;
+ i__3 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__3; ++i__) {
+ ipiv[i__] = j - 1 + ipiv[i__];
+/* L10: */
+ }
+
+/* Apply interchanges to columns 1:J-1. */
+
+ i__3 = j - 1;
+ i__4 = j + jb - 1;
+ zlaswp_(&i__3, &a[a_offset], lda, &j, &i__4, &ipiv[1], &c__1);
+
+ if (j + jb <= *n) {
+
+/* Apply interchanges to columns J+JB:N. */
+
+ i__3 = *n - j - jb + 1;
+ i__4 = j + jb - 1;
+ zlaswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, &
+ ipiv[1], &c__1);
+
+/* Compute block row of U. */
+
+ i__3 = *n - j - jb + 1;
+ ztrsm_("Left", "Lower", "No transpose", "Unit", &jb, &i__3, &
+ c_b1, &a[j + j * a_dim1], lda, &a[j + (j + jb) *
+ a_dim1], lda);
+ if (j + jb <= *m) {
+
+/* Update trailing submatrix. */
+
+ i__3 = *m - j - jb + 1;
+ i__4 = *n - j - jb + 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "No transpose", &i__3, &i__4, &jb,
+ &z__1, &a[j + jb + j * a_dim1], lda, &a[j + (j +
+ jb) * a_dim1], lda, &c_b1, &a[j + jb + (j + jb) *
+ a_dim1], lda);
+ }
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+/* End of ZGETRF */
+
+} /* zgetrf_ */
diff --git a/SRC/zgetri.c b/SRC/zgetri.c
new file mode 100644
index 0000000..246b34e
--- /dev/null
+++ b/SRC/zgetri.c
@@ -0,0 +1,270 @@
+/* zgetri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int zgetri_(integer *n, doublecomplex *a, integer *lda,
+ integer *ipiv, doublecomplex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j, jb, nb, jj, jp, nn, iws, nbmin;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zswap_(integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), ztrsm_(char *, char *, char *, char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int ztrtri_(char *, char *, integer *,
+ doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGETRI computes the inverse of a matrix using the LU factorization */
+/* computed by ZGETRF. */
+
+/* This method inverts U and then computes inv(A) by solving the system */
+/* inv(A)*L = inv(U) for inv(A). */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the factors L and U from the factorization */
+/* A = P*L*U as computed by ZGETRF. */
+/* On exit, if INFO = 0, the inverse of the original matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from ZGETRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO=0, then WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* For optimal performance LWORK >= N*NB, where NB is */
+/* the optimal blocksize 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is */
+/* singular and its inverse could not be computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb = ilaenv_(&c__1, "ZGETRI", " ", n, &c_n1, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ lquery = *lwork == -1;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*lda < max(1,*n)) {
+ *info = -3;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGETRI", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form inv(U). If INFO > 0 from ZTRTRI, then U is singular, */
+/* and the inverse is not computed. */
+
+ ztrtri_("Upper", "Non-unit", n, &a[a_offset], lda, info);
+ if (*info > 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = *n;
+ if (nb > 1 && nb < *n) {
+/* Computing MAX */
+ i__1 = ldwork * nb;
+ iws = max(i__1,1);
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "ZGETRI", " ", n, &c_n1, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = *n;
+ }
+
+/* Solve the equation inv(A)*L = inv(U) for inv(A). */
+
+ if (nb < nbmin || nb >= *n) {
+
+/* Use unblocked code. */
+
+ for (j = *n; j >= 1; --j) {
+
+/* Copy current column of L to WORK and replace with zeros. */
+
+ i__1 = *n;
+ for (i__ = j + 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__ + j * a_dim1;
+ work[i__2].r = a[i__3].r, work[i__2].i = a[i__3].i;
+ i__2 = i__ + j * a_dim1;
+ a[i__2].r = 0., a[i__2].i = 0.;
+/* L10: */
+ }
+
+/* Compute current column of inv(A). */
+
+ if (j < *n) {
+ i__1 = *n - j;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", n, &i__1, &z__1, &a[(j + 1) * a_dim1 +
+ 1], lda, &work[j + 1], &c__1, &c_b2, &a[j * a_dim1 +
+ 1], &c__1);
+ }
+/* L20: */
+ }
+ } else {
+
+/* Use blocked code. */
+
+ nn = (*n - 1) / nb * nb + 1;
+ i__1 = -nb;
+ for (j = nn; i__1 < 0 ? j >= 1 : j <= 1; j += i__1) {
+/* Computing MIN */
+ i__2 = nb, i__3 = *n - j + 1;
+ jb = min(i__2,i__3);
+
+/* Copy current block column of L to WORK and replace with */
+/* zeros. */
+
+ i__2 = j + jb - 1;
+ for (jj = j; jj <= i__2; ++jj) {
+ i__3 = *n;
+ for (i__ = jj + 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + (jj - j) * ldwork;
+ i__5 = i__ + jj * a_dim1;
+ work[i__4].r = a[i__5].r, work[i__4].i = a[i__5].i;
+ i__4 = i__ + jj * a_dim1;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Compute current block column of inv(A). */
+
+ if (j + jb <= *n) {
+ i__2 = *n - j - jb + 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "No transpose", n, &jb, &i__2, &z__1, &
+ a[(j + jb) * a_dim1 + 1], lda, &work[j + jb], &ldwork,
+ &c_b2, &a[j * a_dim1 + 1], lda);
+ }
+ ztrsm_("Right", "Lower", "No transpose", "Unit", n, &jb, &c_b2, &
+ work[j], &ldwork, &a[j * a_dim1 + 1], lda);
+/* L50: */
+ }
+ }
+
+/* Apply column interchanges. */
+
+ for (j = *n - 1; j >= 1; --j) {
+ jp = ipiv[j];
+ if (jp != j) {
+ zswap_(n, &a[j * a_dim1 + 1], &c__1, &a[jp * a_dim1 + 1], &c__1);
+ }
+/* L60: */
+ }
+
+ work[1].r = (doublereal) iws, work[1].i = 0.;
+ return 0;
+
+/* End of ZGETRI */
+
+} /* zgetri_ */
diff --git a/SRC/zgetrs.c b/SRC/zgetrs.c
new file mode 100644
index 0000000..2496939
--- /dev/null
+++ b/SRC/zgetrs.c
@@ -0,0 +1,187 @@
+/* zgetrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zgetrs_(char *trans, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b,
+ integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ xerbla_(char *, integer *);
+ logical notran;
+ extern /* Subroutine */ int zlaswp_(integer *, doublecomplex *, integer *,
+ integer *, integer *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGETRS solves a system of linear equations */
+/* A * X = B, A**T * X = B, or A**H * X = B */
+/* with a general N-by-N matrix A using the LU factorization computed */
+/* by ZGETRF. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The factors L and U from the factorization A = P*L*U */
+/* as computed by ZGETRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from ZGETRF; for 1<=i<=N, row i of the */
+/* matrix was interchanged with row IPIV(i). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGETRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (notran) {
+
+/* Solve A * X = B. */
+
+/* Apply row interchanges to the right hand sides. */
+
+ zlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c__1);
+
+/* Solve L*X = B, overwriting B with X. */
+
+ ztrsm_("Left", "Lower", "No transpose", "Unit", n, nrhs, &c_b1, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+/* Solve U*X = B, overwriting B with X. */
+
+ ztrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b1, &
+ a[a_offset], lda, &b[b_offset], ldb);
+ } else {
+
+/* Solve A**T * X = B or A**H * X = B. */
+
+/* Solve U'*X = B, overwriting B with X. */
+
+ ztrsm_("Left", "Upper", trans, "Non-unit", n, nrhs, &c_b1, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+/* Solve L'*X = B, overwriting B with X. */
+
+ ztrsm_("Left", "Lower", trans, "Unit", n, nrhs, &c_b1, &a[a_offset],
+ lda, &b[b_offset], ldb);
+
+/* Apply row interchanges to the solution vectors. */
+
+ zlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c_n1);
+ }
+
+ return 0;
+
+/* End of ZGETRS */
+
+} /* zgetrs_ */
diff --git a/SRC/zggbak.c b/SRC/zggbak.c
new file mode 100644
index 0000000..dd25ad9
--- /dev/null
+++ b/SRC/zggbak.c
@@ -0,0 +1,273 @@
+/* zggbak.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zggbak_(char *job, char *side, integer *n, integer *ilo,
+ integer *ihi, doublereal *lscale, doublereal *rscale, integer *m,
+ doublecomplex *v, integer *ldv, integer *info)
+{
+ /* System generated locals */
+ integer v_dim1, v_offset, i__1;
+
+ /* Local variables */
+ integer i__, k;
+ extern logical lsame_(char *, char *);
+ logical leftv;
+ extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), xerbla_(char *, integer *),
+ zdscal_(integer *, doublereal *, doublecomplex *, integer *);
+ logical rightv;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGGBAK forms the right or left eigenvectors of a complex generalized */
+/* eigenvalue problem A*x = lambda*B*x, by backward transformation on */
+/* the computed eigenvectors of the balanced pair of matrices output by */
+/* ZGGBAL. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies the type of backward transformation required: */
+/* = 'N': do nothing, return immediately; */
+/* = 'P': do backward transformation for permutation only; */
+/* = 'S': do backward transformation for scaling only; */
+/* = 'B': do backward transformations for both permutation and */
+/* scaling. */
+/* JOB must be the same as the argument JOB supplied to ZGGBAL. */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'R': V contains right eigenvectors; */
+/* = 'L': V contains left eigenvectors. */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrix V. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* The integers ILO and IHI determined by ZGGBAL. */
+/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
+
+/* LSCALE (input) DOUBLE PRECISION array, dimension (N) */
+/* Details of the permutations and/or scaling factors applied */
+/* to the left side of A and B, as returned by ZGGBAL. */
+
+/* RSCALE (input) DOUBLE PRECISION array, dimension (N) */
+/* Details of the permutations and/or scaling factors applied */
+/* to the right side of A and B, as returned by ZGGBAL. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix V. M >= 0. */
+
+/* V (input/output) COMPLEX*16 array, dimension (LDV,M) */
+/* On entry, the matrix of right or left eigenvectors to be */
+/* transformed, as returned by ZTGEVC. */
+/* On exit, V is overwritten by the transformed eigenvectors. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the matrix V. LDV >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* See R.C. Ward, Balancing the generalized eigenvalue problem, */
+/* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ --lscale;
+ --rscale;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+
+ /* Function Body */
+ rightv = lsame_(side, "R");
+ leftv = lsame_(side, "L");
+
+ *info = 0;
+ if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
+ && ! lsame_(job, "B")) {
+ *info = -1;
+ } else if (! rightv && ! leftv) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ilo < 1) {
+ *info = -4;
+ } else if (*n == 0 && *ihi == 0 && *ilo != 1) {
+ *info = -4;
+ } else if (*n > 0 && (*ihi < *ilo || *ihi > max(1,*n))) {
+ *info = -5;
+ } else if (*n == 0 && *ilo == 1 && *ihi != 0) {
+ *info = -5;
+ } else if (*m < 0) {
+ *info = -8;
+ } else if (*ldv < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGGBAK", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+ if (*m == 0) {
+ return 0;
+ }
+ if (lsame_(job, "N")) {
+ return 0;
+ }
+
+ if (*ilo == *ihi) {
+ goto L30;
+ }
+
+/* Backward balance */
+
+ if (lsame_(job, "S") || lsame_(job, "B")) {
+
+/* Backward transformation on right eigenvectors */
+
+ if (rightv) {
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ zdscal_(m, &rscale[i__], &v[i__ + v_dim1], ldv);
+/* L10: */
+ }
+ }
+
+/* Backward transformation on left eigenvectors */
+
+ if (leftv) {
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ zdscal_(m, &lscale[i__], &v[i__ + v_dim1], ldv);
+/* L20: */
+ }
+ }
+ }
+
+/* Backward permutation */
+
+L30:
+ if (lsame_(job, "P") || lsame_(job, "B")) {
+
+/* Backward permutation on right eigenvectors */
+
+ if (rightv) {
+ if (*ilo == 1) {
+ goto L50;
+ }
+ for (i__ = *ilo - 1; i__ >= 1; --i__) {
+ k = (integer) rscale[i__];
+ if (k == i__) {
+ goto L40;
+ }
+ zswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L40:
+ ;
+ }
+
+L50:
+ if (*ihi == *n) {
+ goto L70;
+ }
+ i__1 = *n;
+ for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
+ k = (integer) rscale[i__];
+ if (k == i__) {
+ goto L60;
+ }
+ zswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L60:
+ ;
+ }
+ }
+
+/* Backward permutation on left eigenvectors */
+
+L70:
+ if (leftv) {
+ if (*ilo == 1) {
+ goto L90;
+ }
+ for (i__ = *ilo - 1; i__ >= 1; --i__) {
+ k = (integer) lscale[i__];
+ if (k == i__) {
+ goto L80;
+ }
+ zswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L80:
+ ;
+ }
+
+L90:
+ if (*ihi == *n) {
+ goto L110;
+ }
+ i__1 = *n;
+ for (i__ = *ihi + 1; i__ <= i__1; ++i__) {
+ k = (integer) lscale[i__];
+ if (k == i__) {
+ goto L100;
+ }
+ zswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
+L100:
+ ;
+ }
+ }
+ }
+
+L110:
+
+ return 0;
+
+/* End of ZGGBAK */
+
+} /* zggbak_ */
diff --git a/SRC/zggbal.c b/SRC/zggbal.c
new file mode 100644
index 0000000..f875672
--- /dev/null
+++ b/SRC/zggbal.c
@@ -0,0 +1,657 @@
+/* zggbal.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b36 = 10.;
+static doublereal c_b72 = .5;
+
+/* Subroutine */ int zggbal_(char *job, integer *n, doublecomplex *a, integer
+ *lda, doublecomplex *b, integer *ldb, integer *ilo, integer *ihi,
+ doublereal *lscale, doublereal *rscale, doublereal *work, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double d_lg10(doublereal *), d_imag(doublecomplex *), z_abs(doublecomplex
+ *), d_sign(doublereal *, doublereal *), pow_di(doublereal *,
+ integer *);
+
+ /* Local variables */
+ integer i__, j, k, l, m;
+ doublereal t;
+ integer jc;
+ doublereal ta, tb, tc;
+ integer ir;
+ doublereal ew;
+ integer it, nr, ip1, jp1, lm1;
+ doublereal cab, rab, ewc, cor, sum;
+ integer nrp2, icab, lcab;
+ doublereal beta, coef;
+ integer irab, lrab;
+ doublereal basl, cmax;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal coef2, coef5, gamma, alpha;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ doublereal sfmin, sfmax;
+ integer iflow;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *);
+ integer kount;
+ extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal pgamma;
+ extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
+ integer *, doublereal *, doublecomplex *, integer *);
+ integer lsfmin;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ integer lsfmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGGBAL balances a pair of general complex matrices (A,B). This */
+/* involves, first, permuting A and B by similarity transformations to */
+/* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N */
+/* elements on the diagonal; and second, applying a diagonal similarity */
+/* transformation to rows and columns ILO to IHI to make the rows */
+/* and columns as close in norm as possible. Both steps are optional. */
+
+/* Balancing may reduce the 1-norm of the matrices, and improve the */
+/* accuracy of the computed eigenvalues and/or eigenvectors in the */
+/* generalized eigenvalue problem A*x = lambda*B*x. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies the operations to be performed on A and B: */
+/* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0 */
+/* and RSCALE(I) = 1.0 for i=1,...,N; */
+/* = 'P': permute only; */
+/* = 'S': scale only; */
+/* = 'B': both permute and scale. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the input matrix A. */
+/* On exit, A is overwritten by the balanced matrix. */
+/* If JOB = 'N', A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,N) */
+/* On entry, the input matrix B. */
+/* On exit, B is overwritten by the balanced matrix. */
+/* If JOB = 'N', B is not referenced. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* ILO (output) INTEGER */
+/* IHI (output) INTEGER */
+/* ILO and IHI are set to integers such that on exit */
+/* A(i,j) = 0 and B(i,j) = 0 if i > j and */
+/* j = 1,...,ILO-1 or i = IHI+1,...,N. */
+/* If JOB = 'N' or 'S', ILO = 1 and IHI = N. */
+
+/* LSCALE (output) DOUBLE PRECISION array, dimension (N) */
+/* Details of the permutations and scaling factors applied */
+/* to the left side of A and B. If P(j) is the index of the */
+/* row interchanged with row j, and D(j) is the scaling factor */
+/* applied to row j, then */
+/* LSCALE(j) = P(j) for J = 1,...,ILO-1 */
+/* = D(j) for J = ILO,...,IHI */
+/* = P(j) for J = IHI+1,...,N. */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* RSCALE (output) DOUBLE PRECISION array, dimension (N) */
+/* Details of the permutations and scaling factors applied */
+/* to the right side of A and B. If P(j) is the index of the */
+/* column interchanged with column j, and D(j) is the scaling */
+/* factor applied to column j, then */
+/* RSCALE(j) = P(j) for J = 1,...,ILO-1 */
+/* = D(j) for J = ILO,...,IHI */
+/* = P(j) for J = IHI+1,...,N. */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* WORK (workspace) REAL array, dimension (lwork) */
+/* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and */
+/* at least 1 when JOB = 'N' or 'P'. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* See R.C. WARD, Balancing the generalized eigenvalue problem, */
+/* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --lscale;
+ --rscale;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
+ && ! lsame_(job, "B")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGGBAL", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *ilo = 1;
+ *ihi = *n;
+ return 0;
+ }
+
+ if (*n == 1) {
+ *ilo = 1;
+ *ihi = *n;
+ lscale[1] = 1.;
+ rscale[1] = 1.;
+ return 0;
+ }
+
+ if (lsame_(job, "N")) {
+ *ilo = 1;
+ *ihi = *n;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ lscale[i__] = 1.;
+ rscale[i__] = 1.;
+/* L10: */
+ }
+ return 0;
+ }
+
+ k = 1;
+ l = *n;
+ if (lsame_(job, "S")) {
+ goto L190;
+ }
+
+ goto L30;
+
+/* Permute the matrices A and B to isolate the eigenvalues. */
+
+/* Find row with one nonzero in columns 1 through L */
+
+L20:
+ l = lm1;
+ if (l != 1) {
+ goto L30;
+ }
+
+ rscale[1] = 1.;
+ lscale[1] = 1.;
+ goto L190;
+
+L30:
+ lm1 = l - 1;
+ for (i__ = l; i__ >= 1; --i__) {
+ i__1 = lm1;
+ for (j = 1; j <= i__1; ++j) {
+ jp1 = j + 1;
+ i__2 = i__ + j * a_dim1;
+ i__3 = i__ + j * b_dim1;
+ if (a[i__2].r != 0. || a[i__2].i != 0. || (b[i__3].r != 0. || b[
+ i__3].i != 0.)) {
+ goto L50;
+ }
+/* L40: */
+ }
+ j = l;
+ goto L70;
+
+L50:
+ i__1 = l;
+ for (j = jp1; j <= i__1; ++j) {
+ i__2 = i__ + j * a_dim1;
+ i__3 = i__ + j * b_dim1;
+ if (a[i__2].r != 0. || a[i__2].i != 0. || (b[i__3].r != 0. || b[
+ i__3].i != 0.)) {
+ goto L80;
+ }
+/* L60: */
+ }
+ j = jp1 - 1;
+
+L70:
+ m = l;
+ iflow = 1;
+ goto L160;
+L80:
+ ;
+ }
+ goto L100;
+
+/* Find column with one nonzero in rows K through N */
+
+L90:
+ ++k;
+
+L100:
+ i__1 = l;
+ for (j = k; j <= i__1; ++j) {
+ i__2 = lm1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ ip1 = i__ + 1;
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * b_dim1;
+ if (a[i__3].r != 0. || a[i__3].i != 0. || (b[i__4].r != 0. || b[
+ i__4].i != 0.)) {
+ goto L120;
+ }
+/* L110: */
+ }
+ i__ = l;
+ goto L140;
+L120:
+ i__2 = l;
+ for (i__ = ip1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * b_dim1;
+ if (a[i__3].r != 0. || a[i__3].i != 0. || (b[i__4].r != 0. || b[
+ i__4].i != 0.)) {
+ goto L150;
+ }
+/* L130: */
+ }
+ i__ = ip1 - 1;
+L140:
+ m = k;
+ iflow = 2;
+ goto L160;
+L150:
+ ;
+ }
+ goto L190;
+
+/* Permute rows M and I */
+
+L160:
+ lscale[m] = (doublereal) i__;
+ if (i__ == m) {
+ goto L170;
+ }
+ i__1 = *n - k + 1;
+ zswap_(&i__1, &a[i__ + k * a_dim1], lda, &a[m + k * a_dim1], lda);
+ i__1 = *n - k + 1;
+ zswap_(&i__1, &b[i__ + k * b_dim1], ldb, &b[m + k * b_dim1], ldb);
+
+/* Permute columns M and J */
+
+L170:
+ rscale[m] = (doublereal) j;
+ if (j == m) {
+ goto L180;
+ }
+ zswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1);
+ zswap_(&l, &b[j * b_dim1 + 1], &c__1, &b[m * b_dim1 + 1], &c__1);
+
+L180:
+ switch (iflow) {
+ case 1: goto L20;
+ case 2: goto L90;
+ }
+
+L190:
+ *ilo = k;
+ *ihi = l;
+
+ if (lsame_(job, "P")) {
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ lscale[i__] = 1.;
+ rscale[i__] = 1.;
+/* L195: */
+ }
+ return 0;
+ }
+
+ if (*ilo == *ihi) {
+ return 0;
+ }
+
+/* Balance the submatrix in rows ILO to IHI. */
+
+ nr = *ihi - *ilo + 1;
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ rscale[i__] = 0.;
+ lscale[i__] = 0.;
+
+ work[i__] = 0.;
+ work[i__ + *n] = 0.;
+ work[i__ + (*n << 1)] = 0.;
+ work[i__ + *n * 3] = 0.;
+ work[i__ + (*n << 2)] = 0.;
+ work[i__ + *n * 5] = 0.;
+/* L200: */
+ }
+
+/* Compute right side vector in resulting linear equations */
+
+ basl = d_lg10(&c_b36);
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ i__2 = *ihi;
+ for (j = *ilo; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ if (a[i__3].r == 0. && a[i__3].i == 0.) {
+ ta = 0.;
+ goto L210;
+ }
+ i__3 = i__ + j * a_dim1;
+ d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + j *
+ a_dim1]), abs(d__2));
+ ta = d_lg10(&d__3) / basl;
+
+L210:
+ i__3 = i__ + j * b_dim1;
+ if (b[i__3].r == 0. && b[i__3].i == 0.) {
+ tb = 0.;
+ goto L220;
+ }
+ i__3 = i__ + j * b_dim1;
+ d__3 = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__ + j *
+ b_dim1]), abs(d__2));
+ tb = d_lg10(&d__3) / basl;
+
+L220:
+ work[i__ + (*n << 2)] = work[i__ + (*n << 2)] - ta - tb;
+ work[j + *n * 5] = work[j + *n * 5] - ta - tb;
+/* L230: */
+ }
+/* L240: */
+ }
+
+ coef = 1. / (doublereal) (nr << 1);
+ coef2 = coef * coef;
+ coef5 = coef2 * .5;
+ nrp2 = nr + 2;
+ beta = 0.;
+ it = 1;
+
+/* Start generalized conjugate gradient iteration */
+
+L250:
+
+ gamma = ddot_(&nr, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + (*n << 2)]
+, &c__1) + ddot_(&nr, &work[*ilo + *n * 5], &c__1, &work[*ilo + *
+ n * 5], &c__1);
+
+ ew = 0.;
+ ewc = 0.;
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ ew += work[i__ + (*n << 2)];
+ ewc += work[i__ + *n * 5];
+/* L260: */
+ }
+
+/* Computing 2nd power */
+ d__1 = ew;
+/* Computing 2nd power */
+ d__2 = ewc;
+/* Computing 2nd power */
+ d__3 = ew - ewc;
+ gamma = coef * gamma - coef2 * (d__1 * d__1 + d__2 * d__2) - coef5 * (
+ d__3 * d__3);
+ if (gamma == 0.) {
+ goto L350;
+ }
+ if (it != 1) {
+ beta = gamma / pgamma;
+ }
+ t = coef5 * (ewc - ew * 3.);
+ tc = coef5 * (ew - ewc * 3.);
+
+ dscal_(&nr, &beta, &work[*ilo], &c__1);
+ dscal_(&nr, &beta, &work[*ilo + *n], &c__1);
+
+ daxpy_(&nr, &coef, &work[*ilo + (*n << 2)], &c__1, &work[*ilo + *n], &
+ c__1);
+ daxpy_(&nr, &coef, &work[*ilo + *n * 5], &c__1, &work[*ilo], &c__1);
+
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ work[i__] += tc;
+ work[i__ + *n] += t;
+/* L270: */
+ }
+
+/* Apply matrix to vector */
+
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ kount = 0;
+ sum = 0.;
+ i__2 = *ihi;
+ for (j = *ilo; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ if (a[i__3].r == 0. && a[i__3].i == 0.) {
+ goto L280;
+ }
+ ++kount;
+ sum += work[j];
+L280:
+ i__3 = i__ + j * b_dim1;
+ if (b[i__3].r == 0. && b[i__3].i == 0.) {
+ goto L290;
+ }
+ ++kount;
+ sum += work[j];
+L290:
+ ;
+ }
+ work[i__ + (*n << 1)] = (doublereal) kount * work[i__ + *n] + sum;
+/* L300: */
+ }
+
+ i__1 = *ihi;
+ for (j = *ilo; j <= i__1; ++j) {
+ kount = 0;
+ sum = 0.;
+ i__2 = *ihi;
+ for (i__ = *ilo; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ if (a[i__3].r == 0. && a[i__3].i == 0.) {
+ goto L310;
+ }
+ ++kount;
+ sum += work[i__ + *n];
+L310:
+ i__3 = i__ + j * b_dim1;
+ if (b[i__3].r == 0. && b[i__3].i == 0.) {
+ goto L320;
+ }
+ ++kount;
+ sum += work[i__ + *n];
+L320:
+ ;
+ }
+ work[j + *n * 3] = (doublereal) kount * work[j] + sum;
+/* L330: */
+ }
+
+ sum = ddot_(&nr, &work[*ilo + *n], &c__1, &work[*ilo + (*n << 1)], &c__1)
+ + ddot_(&nr, &work[*ilo], &c__1, &work[*ilo + *n * 3], &c__1);
+ alpha = gamma / sum;
+
+/* Determine correction to current iteration */
+
+ cmax = 0.;
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ cor = alpha * work[i__ + *n];
+ if (abs(cor) > cmax) {
+ cmax = abs(cor);
+ }
+ lscale[i__] += cor;
+ cor = alpha * work[i__];
+ if (abs(cor) > cmax) {
+ cmax = abs(cor);
+ }
+ rscale[i__] += cor;
+/* L340: */
+ }
+ if (cmax < .5) {
+ goto L350;
+ }
+
+ d__1 = -alpha;
+ daxpy_(&nr, &d__1, &work[*ilo + (*n << 1)], &c__1, &work[*ilo + (*n << 2)]
+, &c__1);
+ d__1 = -alpha;
+ daxpy_(&nr, &d__1, &work[*ilo + *n * 3], &c__1, &work[*ilo + *n * 5], &
+ c__1);
+
+ pgamma = gamma;
+ ++it;
+ if (it <= nrp2) {
+ goto L250;
+ }
+
+/* End generalized conjugate gradient iteration */
+
+L350:
+ sfmin = dlamch_("S");
+ sfmax = 1. / sfmin;
+ lsfmin = (integer) (d_lg10(&sfmin) / basl + 1.);
+ lsfmax = (integer) (d_lg10(&sfmax) / basl);
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ i__2 = *n - *ilo + 1;
+ irab = izamax_(&i__2, &a[i__ + *ilo * a_dim1], lda);
+ rab = z_abs(&a[i__ + (irab + *ilo - 1) * a_dim1]);
+ i__2 = *n - *ilo + 1;
+ irab = izamax_(&i__2, &b[i__ + *ilo * b_dim1], ldb);
+/* Computing MAX */
+ d__1 = rab, d__2 = z_abs(&b[i__ + (irab + *ilo - 1) * b_dim1]);
+ rab = max(d__1,d__2);
+ d__1 = rab + sfmin;
+ lrab = (integer) (d_lg10(&d__1) / basl + 1.);
+ ir = (integer) (lscale[i__] + d_sign(&c_b72, &lscale[i__]));
+/* Computing MIN */
+ i__2 = max(ir,lsfmin), i__2 = min(i__2,lsfmax), i__3 = lsfmax - lrab;
+ ir = min(i__2,i__3);
+ lscale[i__] = pow_di(&c_b36, &ir);
+ icab = izamax_(ihi, &a[i__ * a_dim1 + 1], &c__1);
+ cab = z_abs(&a[icab + i__ * a_dim1]);
+ icab = izamax_(ihi, &b[i__ * b_dim1 + 1], &c__1);
+/* Computing MAX */
+ d__1 = cab, d__2 = z_abs(&b[icab + i__ * b_dim1]);
+ cab = max(d__1,d__2);
+ d__1 = cab + sfmin;
+ lcab = (integer) (d_lg10(&d__1) / basl + 1.);
+ jc = (integer) (rscale[i__] + d_sign(&c_b72, &rscale[i__]));
+/* Computing MIN */
+ i__2 = max(jc,lsfmin), i__2 = min(i__2,lsfmax), i__3 = lsfmax - lcab;
+ jc = min(i__2,i__3);
+ rscale[i__] = pow_di(&c_b36, &jc);
+/* L360: */
+ }
+
+/* Row scaling of matrices A and B */
+
+ i__1 = *ihi;
+ for (i__ = *ilo; i__ <= i__1; ++i__) {
+ i__2 = *n - *ilo + 1;
+ zdscal_(&i__2, &lscale[i__], &a[i__ + *ilo * a_dim1], lda);
+ i__2 = *n - *ilo + 1;
+ zdscal_(&i__2, &lscale[i__], &b[i__ + *ilo * b_dim1], ldb);
+/* L370: */
+ }
+
+/* Column scaling of matrices A and B */
+
+ i__1 = *ihi;
+ for (j = *ilo; j <= i__1; ++j) {
+ zdscal_(ihi, &rscale[j], &a[j * a_dim1 + 1], &c__1);
+ zdscal_(ihi, &rscale[j], &b[j * b_dim1 + 1], &c__1);
+/* L380: */
+ }
+
+ return 0;
+
+/* End of ZGGBAL */
+
+} /* zggbal_ */
diff --git a/SRC/zgges.c b/SRC/zgges.c
new file mode 100644
index 0000000..540ae27
--- /dev/null
+++ b/SRC/zgges.c
@@ -0,0 +1,604 @@
+/* zgges.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zgges_(char *jobvsl, char *jobvsr, char *sort, L_fp
+ selctg, integer *n, doublecomplex *a, integer *lda, doublecomplex *b,
+ integer *ldb, integer *sdim, doublecomplex *alpha, doublecomplex *
+ beta, doublecomplex *vsl, integer *ldvsl, doublecomplex *vsr, integer
+ *ldvsr, doublecomplex *work, integer *lwork, doublereal *rwork,
+ logical *bwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
+ vsr_dim1, vsr_offset, i__1, i__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal dif[2];
+ integer ihi, ilo;
+ doublereal eps, anrm, bnrm;
+ integer idum[1], ierr, itau, iwrk;
+ doublereal pvsl, pvsr;
+ extern logical lsame_(char *, char *);
+ integer ileft, icols;
+ logical cursl, ilvsl, ilvsr;
+ integer irwrk, irows;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zggbak_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublecomplex *,
+ integer *, integer *), zggbal_(char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+, integer *, doublereal *, doublereal *, doublereal *, integer *);
+ logical ilascl, ilbscl;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ doublereal bignum;
+ integer ijobvl, iright;
+ extern /* Subroutine */ int zgghrd_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+), zlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublecomplex *,
+ integer *, integer *);
+ integer ijobvr;
+ extern /* Subroutine */ int zgeqrf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *
+);
+ doublereal anrmto;
+ integer lwkmin;
+ logical lastsl;
+ doublereal bnrmto;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *), zhgeqz_(
+ char *, char *, char *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *), ztgsen_(integer
+ *, logical *, logical *, logical *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublecomplex *, integer *, integer *, integer *, integer *);
+ doublereal smlnum;
+ logical wantst, lquery;
+ integer lwkopt;
+ extern /* Subroutine */ int zungqr_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *), zunmqr_(char *, char *, integer *, integer
+ *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+/* .. Function Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGGES computes for a pair of N-by-N complex nonsymmetric matrices */
+/* (A,B), the generalized eigenvalues, the generalized complex Schur */
+/* form (S, T), and optionally left and/or right Schur vectors (VSL */
+/* and VSR). This gives the generalized Schur factorization */
+
+/* (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H ) */
+
+/* where (VSR)**H is the conjugate-transpose of VSR. */
+
+/* Optionally, it also orders the eigenvalues so that a selected cluster */
+/* of eigenvalues appears in the leading diagonal blocks of the upper */
+/* triangular matrix S and the upper triangular matrix T. The leading */
+/* columns of VSL and VSR then form an unitary basis for the */
+/* corresponding left and right eigenspaces (deflating subspaces). */
+
+/* (If only the generalized eigenvalues are needed, use the driver */
+/* ZGGEV instead, which is faster.) */
+
+/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w */
+/* or a ratio alpha/beta = w, such that A - w*B is singular. It is */
+/* usually represented as the pair (alpha,beta), as there is a */
+/* reasonable interpretation for beta=0, and even for both being zero. */
+
+/* A pair of matrices (S,T) is in generalized complex Schur form if S */
+/* and T are upper triangular and, in addition, the diagonal elements */
+/* of T are non-negative real numbers. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVSL (input) CHARACTER*1 */
+/* = 'N': do not compute the left Schur vectors; */
+/* = 'V': compute the left Schur vectors. */
+
+/* JOBVSR (input) CHARACTER*1 */
+/* = 'N': do not compute the right Schur vectors; */
+/* = 'V': compute the right Schur vectors. */
+
+/* SORT (input) CHARACTER*1 */
+/* Specifies whether or not to order the eigenvalues on the */
+/* diagonal of the generalized Schur form. */
+/* = 'N': Eigenvalues are not ordered; */
+/* = 'S': Eigenvalues are ordered (see SELCTG). */
+
+/* SELCTG (external procedure) LOGICAL FUNCTION of two COMPLEX*16 arguments */
+/* SELCTG must be declared EXTERNAL in the calling subroutine. */
+/* If SORT = 'N', SELCTG is not referenced. */
+/* If SORT = 'S', SELCTG is used to select eigenvalues to sort */
+/* to the top left of the Schur form. */
+/* An eigenvalue ALPHA(j)/BETA(j) is selected if */
+/* SELCTG(ALPHA(j),BETA(j)) is true. */
+
+/* Note that a selected complex eigenvalue may no longer satisfy */
+/* SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since */
+/* ordering may change the value of complex eigenvalues */
+/* (especially if the eigenvalue is ill-conditioned), in this */
+/* case INFO is set to N+2 (See INFO below). */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VSL, and VSR. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA, N) */
+/* On entry, the first of the pair of matrices. */
+/* On exit, A has been overwritten by its generalized Schur */
+/* form S. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB, N) */
+/* On entry, the second of the pair of matrices. */
+/* On exit, B has been overwritten by its generalized Schur */
+/* form T. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* SDIM (output) INTEGER */
+/* If SORT = 'N', SDIM = 0. */
+/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */
+/* for which SELCTG is true. */
+
+/* ALPHA (output) COMPLEX*16 array, dimension (N) */
+/* BETA (output) COMPLEX*16 array, dimension (N) */
+/* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the */
+/* generalized eigenvalues. ALPHA(j), j=1,...,N and BETA(j), */
+/* j=1,...,N are the diagonals of the complex Schur form (A,B) */
+/* output by ZGGES. The BETA(j) will be non-negative real. */
+
+/* Note: the quotients ALPHA(j)/BETA(j) may easily over- or */
+/* underflow, and BETA(j) may even be zero. Thus, the user */
+/* should avoid naively computing the ratio alpha/beta. */
+/* However, ALPHA will be always less than and usually */
+/* comparable with norm(A) in magnitude, and BETA always less */
+/* than and usually comparable with norm(B). */
+
+/* VSL (output) COMPLEX*16 array, dimension (LDVSL,N) */
+/* If JOBVSL = 'V', VSL will contain the left Schur vectors. */
+/* Not referenced if JOBVSL = 'N'. */
+
+/* LDVSL (input) INTEGER */
+/* The leading dimension of the matrix VSL. LDVSL >= 1, and */
+/* if JOBVSL = 'V', LDVSL >= N. */
+
+/* VSR (output) COMPLEX*16 array, dimension (LDVSR,N) */
+/* If JOBVSR = 'V', VSR will contain the right Schur vectors. */
+/* Not referenced if JOBVSR = 'N'. */
+
+/* LDVSR (input) INTEGER */
+/* The leading dimension of the matrix VSR. LDVSR >= 1, and */
+/* if JOBVSR = 'V', LDVSR >= N. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,2*N). */
+/* For good performance, LWORK must generally be larger. */
+
+/* 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. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (8*N) */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+/* Not referenced if SORT = 'N'. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* =1,...,N: */
+/* The QZ iteration failed. (A,B) are not in Schur */
+/* form, but ALPHA(j) and BETA(j) should be correct for */
+/* j=INFO+1,...,N. */
+/* > N: =N+1: other than QZ iteration failed in ZHGEQZ */
+/* =N+2: after reordering, roundoff changed values of */
+/* some complex eigenvalues so that leading */
+/* eigenvalues in the Generalized Schur form no */
+/* longer satisfy SELCTG=.TRUE. This could also */
+/* be caused due to scaling. */
+/* =N+3: reordering falied in ZTGSEN. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alpha;
+ --beta;
+ vsl_dim1 = *ldvsl;
+ vsl_offset = 1 + vsl_dim1;
+ vsl -= vsl_offset;
+ vsr_dim1 = *ldvsr;
+ vsr_offset = 1 + vsr_dim1;
+ vsr -= vsr_offset;
+ --work;
+ --rwork;
+ --bwork;
+
+ /* Function Body */
+ if (lsame_(jobvsl, "N")) {
+ ijobvl = 1;
+ ilvsl = FALSE_;
+ } else if (lsame_(jobvsl, "V")) {
+ ijobvl = 2;
+ ilvsl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvsl = FALSE_;
+ }
+
+ if (lsame_(jobvsr, "N")) {
+ ijobvr = 1;
+ ilvsr = FALSE_;
+ } else if (lsame_(jobvsr, "V")) {
+ ijobvr = 2;
+ ilvsr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvsr = FALSE_;
+ }
+
+ wantst = lsame_(sort, "S");
+
+/* Test the input arguments */
+
+ *info = 0;
+ lquery = *lwork == -1;
+ if (ijobvl <= 0) {
+ *info = -1;
+ } else if (ijobvr <= 0) {
+ *info = -2;
+ } else if (! wantst && ! lsame_(sort, "N")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
+ *info = -14;
+ } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
+ *info = -16;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ if (*info == 0) {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n << 1;
+ lwkmin = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", n, &c__1, n,
+ &c__0);
+ lwkopt = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = *n + *n * ilaenv_(&c__1, "ZUNMQR", " ", n, &
+ c__1, n, &c_n1);
+ lwkopt = max(i__1,i__2);
+ if (ilvsl) {
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = *n + *n * ilaenv_(&c__1, "ZUNGQR", " ", n, &
+ c__1, n, &c_n1);
+ lwkopt = max(i__1,i__2);
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ if (*lwork < lwkmin && ! lquery) {
+ *info = -18;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGGES ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *sdim = 0;
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1. / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = zlange_("M", n, n, &a[a_offset], lda, &rwork[1]);
+ ilascl = FALSE_;
+ if (anrm > 0. && anrm < smlnum) {
+ anrmto = smlnum;
+ ilascl = TRUE_;
+ } else if (anrm > bignum) {
+ anrmto = bignum;
+ ilascl = TRUE_;
+ }
+
+ if (ilascl) {
+ zlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = zlange_("M", n, n, &b[b_offset], ldb, &rwork[1]);
+ ilbscl = FALSE_;
+ if (bnrm > 0. && bnrm < smlnum) {
+ bnrmto = smlnum;
+ ilbscl = TRUE_;
+ } else if (bnrm > bignum) {
+ bnrmto = bignum;
+ ilbscl = TRUE_;
+ }
+
+ if (ilbscl) {
+ zlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
+ ierr);
+ }
+
+/* Permute the matrix to make it more nearly triangular */
+/* (Real Workspace: need 6*N) */
+
+ ileft = 1;
+ iright = *n + 1;
+ irwrk = iright + *n;
+ zggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &rwork[
+ ileft], &rwork[iright], &rwork[irwrk], &ierr);
+
+/* Reduce B to triangular form (QR decomposition of B) */
+/* (Complex Workspace: need N, prefer N*NB) */
+
+ irows = ihi + 1 - ilo;
+ icols = *n + 1 - ilo;
+ itau = 1;
+ iwrk = itau + irows;
+ i__1 = *lwork + 1 - iwrk;
+ zgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
+ iwrk], &i__1, &ierr);
+
+/* Apply the orthogonal transformation to matrix A */
+/* (Complex Workspace: need N, prefer N*NB) */
+
+ i__1 = *lwork + 1 - iwrk;
+ zunmqr_("L", "C", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
+ work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, &
+ ierr);
+
+/* Initialize VSL */
+/* (Complex Workspace: need N, prefer N*NB) */
+
+ if (ilvsl) {
+ zlaset_("Full", n, n, &c_b1, &c_b2, &vsl[vsl_offset], ldvsl);
+ if (irows > 1) {
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ zlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[
+ ilo + 1 + ilo * vsl_dim1], ldvsl);
+ }
+ i__1 = *lwork + 1 - iwrk;
+ zungqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, &
+ work[itau], &work[iwrk], &i__1, &ierr);
+ }
+
+/* Initialize VSR */
+
+ if (ilvsr) {
+ zlaset_("Full", n, n, &c_b1, &c_b2, &vsr[vsr_offset], ldvsr);
+ }
+
+/* Reduce to generalized Hessenberg form */
+/* (Workspace: none needed) */
+
+ zgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &ierr);
+
+ *sdim = 0;
+
+/* Perform QZ algorithm, computing Schur vectors if desired */
+/* (Complex Workspace: need N) */
+/* (Real Workspace: need N) */
+
+ iwrk = itau;
+ i__1 = *lwork + 1 - iwrk;
+ zhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[
+ b_offset], ldb, &alpha[1], &beta[1], &vsl[vsl_offset], ldvsl, &
+ vsr[vsr_offset], ldvsr, &work[iwrk], &i__1, &rwork[irwrk], &ierr);
+ if (ierr != 0) {
+ if (ierr > 0 && ierr <= *n) {
+ *info = ierr;
+ } else if (ierr > *n && ierr <= *n << 1) {
+ *info = ierr - *n;
+ } else {
+ *info = *n + 1;
+ }
+ goto L30;
+ }
+
+/* Sort eigenvalues ALPHA/BETA if desired */
+/* (Workspace: none needed) */
+
+ if (wantst) {
+
+/* Undo scaling on eigenvalues before selecting */
+
+ if (ilascl) {
+ zlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, &c__1, &alpha[1], n,
+ &ierr);
+ }
+ if (ilbscl) {
+ zlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, &c__1, &beta[1], n,
+ &ierr);
+ }
+
+/* Select eigenvalues */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ bwork[i__] = (*selctg)(&alpha[i__], &beta[i__]);
+/* L10: */
+ }
+
+ i__1 = *lwork - iwrk + 1;
+ ztgsen_(&c__0, &ilvsl, &ilvsr, &bwork[1], n, &a[a_offset], lda, &b[
+ b_offset], ldb, &alpha[1], &beta[1], &vsl[vsl_offset], ldvsl,
+ &vsr[vsr_offset], ldvsr, sdim, &pvsl, &pvsr, dif, &work[iwrk],
+ &i__1, idum, &c__1, &ierr);
+ if (ierr == 1) {
+ *info = *n + 3;
+ }
+
+ }
+
+/* Apply back-permutation to VSL and VSR */
+/* (Workspace: none needed) */
+
+ if (ilvsl) {
+ zggbak_("P", "L", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &
+ vsl[vsl_offset], ldvsl, &ierr);
+ }
+ if (ilvsr) {
+ zggbak_("P", "R", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &
+ vsr[vsr_offset], ldvsr, &ierr);
+ }
+
+/* Undo scaling */
+
+ if (ilascl) {
+ zlascl_("U", &c__0, &c__0, &anrmto, &anrm, n, n, &a[a_offset], lda, &
+ ierr);
+ zlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alpha[1], n, &
+ ierr);
+ }
+
+ if (ilbscl) {
+ zlascl_("U", &c__0, &c__0, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, &
+ ierr);
+ zlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
+ ierr);
+ }
+
+ if (wantst) {
+
+/* Check if reordering is correct */
+
+ lastsl = TRUE_;
+ *sdim = 0;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ cursl = (*selctg)(&alpha[i__], &beta[i__]);
+ if (cursl) {
+ ++(*sdim);
+ }
+ if (cursl && ! lastsl) {
+ *info = *n + 2;
+ }
+ lastsl = cursl;
+/* L20: */
+ }
+
+ }
+
+L30:
+
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZGGES */
+
+} /* zgges_ */
diff --git a/SRC/zggesx.c b/SRC/zggesx.c
new file mode 100644
index 0000000..b3a5d43
--- /dev/null
+++ b/SRC/zggesx.c
@@ -0,0 +1,708 @@
+/* zggesx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp
+ selctg, char *sense, integer *n, doublecomplex *a, integer *lda,
+ doublecomplex *b, integer *ldb, integer *sdim, doublecomplex *alpha,
+ doublecomplex *beta, doublecomplex *vsl, integer *ldvsl,
+ doublecomplex *vsr, integer *ldvsr, doublereal *rconde, doublereal *
+ rcondv, doublecomplex *work, integer *lwork, doublereal *rwork,
+ integer *iwork, integer *liwork, logical *bwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
+ vsr_dim1, vsr_offset, i__1, i__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal pl, pr, dif[2];
+ integer ihi, ilo;
+ doublereal eps;
+ integer ijob;
+ doublereal anrm, bnrm;
+ integer ierr, itau, iwrk, lwrk;
+ extern logical lsame_(char *, char *);
+ integer ileft, icols;
+ logical cursl, ilvsl, ilvsr;
+ integer irwrk, irows;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zggbak_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublecomplex *,
+ integer *, integer *), zggbal_(char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+, integer *, doublereal *, doublereal *, doublereal *, integer *);
+ logical ilascl, ilbscl;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ doublereal bignum;
+ integer ijobvl, iright;
+ extern /* Subroutine */ int zgghrd_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+), zlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublecomplex *,
+ integer *, integer *);
+ integer ijobvr;
+ logical wantsb;
+ integer liwmin;
+ logical wantse, lastsl;
+ doublereal anrmto, bnrmto;
+ extern /* Subroutine */ int zgeqrf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *
+);
+ integer maxwrk;
+ logical wantsn;
+ integer minwrk;
+ doublereal smlnum;
+ extern /* Subroutine */ int zhgeqz_(char *, char *, char *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *), zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+ logical wantst, lquery, wantsv;
+ extern /* Subroutine */ int ztgsen_(integer *, logical *, logical *,
+ logical *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, doublecomplex *, integer *, integer *,
+ integer *, integer *), zungqr_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *), zunmqr_(char *, char *, integer *, integer
+ *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+/* .. Function Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGGESX computes for a pair of N-by-N complex nonsymmetric matrices */
+/* (A,B), the generalized eigenvalues, the complex Schur form (S,T), */
+/* and, optionally, the left and/or right matrices of Schur vectors (VSL */
+/* and VSR). This gives the generalized Schur factorization */
+
+/* (A,B) = ( (VSL) S (VSR)**H, (VSL) T (VSR)**H ) */
+
+/* where (VSR)**H is the conjugate-transpose of VSR. */
+
+/* Optionally, it also orders the eigenvalues so that a selected cluster */
+/* of eigenvalues appears in the leading diagonal blocks of the upper */
+/* triangular matrix S and the upper triangular matrix T; computes */
+/* a reciprocal condition number for the average of the selected */
+/* eigenvalues (RCONDE); and computes a reciprocal condition number for */
+/* the right and left deflating subspaces corresponding to the selected */
+/* eigenvalues (RCONDV). The leading columns of VSL and VSR then form */
+/* an orthonormal basis for the corresponding left and right eigenspaces */
+/* (deflating subspaces). */
+
+/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w */
+/* or a ratio alpha/beta = w, such that A - w*B is singular. It is */
+/* usually represented as the pair (alpha,beta), as there is a */
+/* reasonable interpretation for beta=0 or for both being zero. */
+
+/* A pair of matrices (S,T) is in generalized complex Schur form if T is */
+/* upper triangular with non-negative diagonal and S is upper */
+/* triangular. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVSL (input) CHARACTER*1 */
+/* = 'N': do not compute the left Schur vectors; */
+/* = 'V': compute the left Schur vectors. */
+
+/* JOBVSR (input) CHARACTER*1 */
+/* = 'N': do not compute the right Schur vectors; */
+/* = 'V': compute the right Schur vectors. */
+
+/* SORT (input) CHARACTER*1 */
+/* Specifies whether or not to order the eigenvalues on the */
+/* diagonal of the generalized Schur form. */
+/* = 'N': Eigenvalues are not ordered; */
+/* = 'S': Eigenvalues are ordered (see SELCTG). */
+
+/* SELCTG (external procedure) LOGICAL FUNCTION of two COMPLEX*16 arguments */
+/* SELCTG must be declared EXTERNAL in the calling subroutine. */
+/* If SORT = 'N', SELCTG is not referenced. */
+/* If SORT = 'S', SELCTG is used to select eigenvalues to sort */
+/* to the top left of the Schur form. */
+/* Note that a selected complex eigenvalue may no longer satisfy */
+/* SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since */
+/* ordering may change the value of complex eigenvalues */
+/* (especially if the eigenvalue is ill-conditioned), in this */
+/* case INFO is set to N+3 see INFO below). */
+
+/* SENSE (input) CHARACTER*1 */
+/* Determines which reciprocal condition numbers are computed. */
+/* = 'N' : None are computed; */
+/* = 'E' : Computed for average of selected eigenvalues only; */
+/* = 'V' : Computed for selected deflating subspaces only; */
+/* = 'B' : Computed for both. */
+/* If SENSE = 'E', 'V', or 'B', SORT must equal 'S'. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VSL, and VSR. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA, N) */
+/* On entry, the first of the pair of matrices. */
+/* On exit, A has been overwritten by its generalized Schur */
+/* form S. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB, N) */
+/* On entry, the second of the pair of matrices. */
+/* On exit, B has been overwritten by its generalized Schur */
+/* form T. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* SDIM (output) INTEGER */
+/* If SORT = 'N', SDIM = 0. */
+/* If SORT = 'S', SDIM = number of eigenvalues (after sorting) */
+/* for which SELCTG is true. */
+
+/* ALPHA (output) COMPLEX*16 array, dimension (N) */
+/* BETA (output) COMPLEX*16 array, dimension (N) */
+/* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the */
+/* generalized eigenvalues. ALPHA(j) and BETA(j),j=1,...,N are */
+/* the diagonals of the complex Schur form (S,T). BETA(j) will */
+/* be non-negative real. */
+
+/* Note: the quotients ALPHA(j)/BETA(j) may easily over- or */
+/* underflow, and BETA(j) may even be zero. Thus, the user */
+/* should avoid naively computing the ratio alpha/beta. */
+/* However, ALPHA will be always less than and usually */
+/* comparable with norm(A) in magnitude, and BETA always less */
+/* than and usually comparable with norm(B). */
+
+/* VSL (output) COMPLEX*16 array, dimension (LDVSL,N) */
+/* If JOBVSL = 'V', VSL will contain the left Schur vectors. */
+/* Not referenced if JOBVSL = 'N'. */
+
+/* LDVSL (input) INTEGER */
+/* The leading dimension of the matrix VSL. LDVSL >=1, and */
+/* if JOBVSL = 'V', LDVSL >= N. */
+
+/* VSR (output) COMPLEX*16 array, dimension (LDVSR,N) */
+/* If JOBVSR = 'V', VSR will contain the right Schur vectors. */
+/* Not referenced if JOBVSR = 'N'. */
+
+/* LDVSR (input) INTEGER */
+/* The leading dimension of the matrix VSR. LDVSR >= 1, and */
+/* if JOBVSR = 'V', LDVSR >= N. */
+
+/* RCONDE (output) DOUBLE PRECISION array, dimension ( 2 ) */
+/* If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the */
+/* reciprocal condition numbers for the average of the selected */
+/* eigenvalues. */
+/* Not referenced if SENSE = 'N' or 'V'. */
+
+/* RCONDV (output) DOUBLE PRECISION array, dimension ( 2 ) */
+/* If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the */
+/* reciprocal condition number for the selected deflating */
+/* subspaces. */
+/* Not referenced if SENSE = 'N' or 'E'. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B', */
+/* LWORK >= MAX(1,2*N,2*SDIM*(N-SDIM)), else */
+/* LWORK >= MAX(1,2*N). Note that 2*SDIM*(N-SDIM) <= N*N/2. */
+/* Note also that an error is only returned if */
+/* LWORK < MAX(1,2*N), but if SENSE = 'E' or 'V' or 'B' this may */
+/* not be large enough. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the bound on the optimal size of the WORK */
+/* array and the minimum size of the IWORK array, returns these */
+/* values as the first entries of the WORK and IWORK arrays, and */
+/* no error message related to LWORK or LIWORK is issued by */
+/* XERBLA. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension ( 8*N ) */
+/* Real workspace. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise */
+/* LIWORK >= N+2. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the bound on the optimal size of the */
+/* WORK array and the minimum size of the IWORK array, returns */
+/* these values as the first entries of the WORK and IWORK */
+/* arrays, and no error message related to LWORK or LIWORK is */
+/* issued by XERBLA. */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+/* Not referenced if SORT = 'N'. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1,...,N: */
+/* The QZ iteration failed. (A,B) are not in Schur */
+/* form, but ALPHA(j) and BETA(j) should be correct for */
+/* j=INFO+1,...,N. */
+/* > N: =N+1: other than QZ iteration failed in ZHGEQZ */
+/* =N+2: after reordering, roundoff changed values of */
+/* some complex eigenvalues so that leading */
+/* eigenvalues in the Generalized Schur form no */
+/* longer satisfy SELCTG=.TRUE. This could also */
+/* be caused due to scaling. */
+/* =N+3: reordering failed in ZTGSEN. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alpha;
+ --beta;
+ vsl_dim1 = *ldvsl;
+ vsl_offset = 1 + vsl_dim1;
+ vsl -= vsl_offset;
+ vsr_dim1 = *ldvsr;
+ vsr_offset = 1 + vsr_dim1;
+ vsr -= vsr_offset;
+ --rconde;
+ --rcondv;
+ --work;
+ --rwork;
+ --iwork;
+ --bwork;
+
+ /* Function Body */
+ if (lsame_(jobvsl, "N")) {
+ ijobvl = 1;
+ ilvsl = FALSE_;
+ } else if (lsame_(jobvsl, "V")) {
+ ijobvl = 2;
+ ilvsl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvsl = FALSE_;
+ }
+
+ if (lsame_(jobvsr, "N")) {
+ ijobvr = 1;
+ ilvsr = FALSE_;
+ } else if (lsame_(jobvsr, "V")) {
+ ijobvr = 2;
+ ilvsr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvsr = FALSE_;
+ }
+
+ wantst = lsame_(sort, "S");
+ wantsn = lsame_(sense, "N");
+ wantse = lsame_(sense, "E");
+ wantsv = lsame_(sense, "V");
+ wantsb = lsame_(sense, "B");
+ lquery = *lwork == -1 || *liwork == -1;
+ if (wantsn) {
+ ijob = 0;
+ } else if (wantse) {
+ ijob = 1;
+ } else if (wantsv) {
+ ijob = 2;
+ } else if (wantsb) {
+ ijob = 4;
+ }
+
+/* Test the input arguments */
+
+ *info = 0;
+ if (ijobvl <= 0) {
+ *info = -1;
+ } else if (ijobvr <= 0) {
+ *info = -2;
+ } else if (! wantst && ! lsame_(sort, "N")) {
+ *info = -3;
+ } else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && !
+ wantsn) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (*lda < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
+ *info = -15;
+ } else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
+ *info = -17;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ if (*info == 0) {
+ if (*n > 0) {
+ minwrk = *n << 1;
+ maxwrk = *n * (ilaenv_(&c__1, "ZGEQRF", " ", n, &c__1, n, &c__0) + 1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * (ilaenv_(&c__1, "ZUNMQR", " ", n, &
+ c__1, n, &c_n1) + 1);
+ maxwrk = max(i__1,i__2);
+ if (ilvsl) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n * (ilaenv_(&c__1, "ZUNGQR", " ", n, &
+ c__1, n, &c_n1) + 1);
+ maxwrk = max(i__1,i__2);
+ }
+ lwrk = maxwrk;
+ if (ijob >= 1) {
+/* Computing MAX */
+ i__1 = lwrk, i__2 = *n * *n / 2;
+ lwrk = max(i__1,i__2);
+ }
+ } else {
+ minwrk = 1;
+ maxwrk = 1;
+ lwrk = 1;
+ }
+ work[1].r = (doublereal) lwrk, work[1].i = 0.;
+ if (wantsn || *n == 0) {
+ liwmin = 1;
+ } else {
+ liwmin = *n + 2;
+ }
+ iwork[1] = liwmin;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -21;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -24;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGGESX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *sdim = 0;
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1. / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = zlange_("M", n, n, &a[a_offset], lda, &rwork[1]);
+ ilascl = FALSE_;
+ if (anrm > 0. && anrm < smlnum) {
+ anrmto = smlnum;
+ ilascl = TRUE_;
+ } else if (anrm > bignum) {
+ anrmto = bignum;
+ ilascl = TRUE_;
+ }
+ if (ilascl) {
+ zlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = zlange_("M", n, n, &b[b_offset], ldb, &rwork[1]);
+ ilbscl = FALSE_;
+ if (bnrm > 0. && bnrm < smlnum) {
+ bnrmto = smlnum;
+ ilbscl = TRUE_;
+ } else if (bnrm > bignum) {
+ bnrmto = bignum;
+ ilbscl = TRUE_;
+ }
+ if (ilbscl) {
+ zlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
+ ierr);
+ }
+
+/* Permute the matrix to make it more nearly triangular */
+/* (Real Workspace: need 6*N) */
+
+ ileft = 1;
+ iright = *n + 1;
+ irwrk = iright + *n;
+ zggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &rwork[
+ ileft], &rwork[iright], &rwork[irwrk], &ierr);
+
+/* Reduce B to triangular form (QR decomposition of B) */
+/* (Complex Workspace: need N, prefer N*NB) */
+
+ irows = ihi + 1 - ilo;
+ icols = *n + 1 - ilo;
+ itau = 1;
+ iwrk = itau + irows;
+ i__1 = *lwork + 1 - iwrk;
+ zgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
+ iwrk], &i__1, &ierr);
+
+/* Apply the unitary transformation to matrix A */
+/* (Complex Workspace: need N, prefer N*NB) */
+
+ i__1 = *lwork + 1 - iwrk;
+ zunmqr_("L", "C", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
+ work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, &
+ ierr);
+
+/* Initialize VSL */
+/* (Complex Workspace: need N, prefer N*NB) */
+
+ if (ilvsl) {
+ zlaset_("Full", n, n, &c_b1, &c_b2, &vsl[vsl_offset], ldvsl);
+ if (irows > 1) {
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ zlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vsl[
+ ilo + 1 + ilo * vsl_dim1], ldvsl);
+ }
+ i__1 = *lwork + 1 - iwrk;
+ zungqr_(&irows, &irows, &irows, &vsl[ilo + ilo * vsl_dim1], ldvsl, &
+ work[itau], &work[iwrk], &i__1, &ierr);
+ }
+
+/* Initialize VSR */
+
+ if (ilvsr) {
+ zlaset_("Full", n, n, &c_b1, &c_b2, &vsr[vsr_offset], ldvsr);
+ }
+
+/* Reduce to generalized Hessenberg form */
+/* (Workspace: none needed) */
+
+ zgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vsl[vsl_offset], ldvsl, &vsr[vsr_offset], ldvsr, &ierr);
+
+ *sdim = 0;
+
+/* Perform QZ algorithm, computing Schur vectors if desired */
+/* (Complex Workspace: need N) */
+/* (Real Workspace: need N) */
+
+ iwrk = itau;
+ i__1 = *lwork + 1 - iwrk;
+ zhgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &a[a_offset], lda, &b[
+ b_offset], ldb, &alpha[1], &beta[1], &vsl[vsl_offset], ldvsl, &
+ vsr[vsr_offset], ldvsr, &work[iwrk], &i__1, &rwork[irwrk], &ierr);
+ if (ierr != 0) {
+ if (ierr > 0 && ierr <= *n) {
+ *info = ierr;
+ } else if (ierr > *n && ierr <= *n << 1) {
+ *info = ierr - *n;
+ } else {
+ *info = *n + 1;
+ }
+ goto L40;
+ }
+
+/* Sort eigenvalues ALPHA/BETA and compute the reciprocal of */
+/* condition number(s) */
+
+ if (wantst) {
+
+/* Undo scaling on eigenvalues before SELCTGing */
+
+ if (ilascl) {
+ zlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alpha[1], n,
+ &ierr);
+ }
+ if (ilbscl) {
+ zlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n,
+ &ierr);
+ }
+
+/* Select eigenvalues */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ bwork[i__] = (*selctg)(&alpha[i__], &beta[i__]);
+/* L10: */
+ }
+
+/* Reorder eigenvalues, transform Generalized Schur vectors, and */
+/* compute reciprocal condition numbers */
+/* (Complex Workspace: If IJOB >= 1, need MAX(1, 2*SDIM*(N-SDIM)) */
+/* otherwise, need 1 ) */
+
+ i__1 = *lwork - iwrk + 1;
+ ztgsen_(&ijob, &ilvsl, &ilvsr, &bwork[1], n, &a[a_offset], lda, &b[
+ b_offset], ldb, &alpha[1], &beta[1], &vsl[vsl_offset], ldvsl,
+ &vsr[vsr_offset], ldvsr, sdim, &pl, &pr, dif, &work[iwrk], &
+ i__1, &iwork[1], liwork, &ierr);
+
+ if (ijob >= 1) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*sdim << 1) * (*n - *sdim);
+ maxwrk = max(i__1,i__2);
+ }
+ if (ierr == -21) {
+
+/* not enough complex workspace */
+
+ *info = -21;
+ } else {
+ if (ijob == 1 || ijob == 4) {
+ rconde[1] = pl;
+ rconde[2] = pr;
+ }
+ if (ijob == 2 || ijob == 4) {
+ rcondv[1] = dif[0];
+ rcondv[2] = dif[1];
+ }
+ if (ierr == 1) {
+ *info = *n + 3;
+ }
+ }
+
+ }
+
+/* Apply permutation to VSL and VSR */
+/* (Workspace: none needed) */
+
+ if (ilvsl) {
+ zggbak_("P", "L", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &
+ vsl[vsl_offset], ldvsl, &ierr);
+ }
+
+ if (ilvsr) {
+ zggbak_("P", "R", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n, &
+ vsr[vsr_offset], ldvsr, &ierr);
+ }
+
+/* Undo scaling */
+
+ if (ilascl) {
+ zlascl_("U", &c__0, &c__0, &anrmto, &anrm, n, n, &a[a_offset], lda, &
+ ierr);
+ zlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alpha[1], n, &
+ ierr);
+ }
+
+ if (ilbscl) {
+ zlascl_("U", &c__0, &c__0, &bnrmto, &bnrm, n, n, &b[b_offset], ldb, &
+ ierr);
+ zlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
+ ierr);
+ }
+
+ if (wantst) {
+
+/* Check if reordering is correct */
+
+ lastsl = TRUE_;
+ *sdim = 0;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ cursl = (*selctg)(&alpha[i__], &beta[i__]);
+ if (cursl) {
+ ++(*sdim);
+ }
+ if (cursl && ! lastsl) {
+ *info = *n + 2;
+ }
+ lastsl = cursl;
+/* L30: */
+ }
+
+ }
+
+L40:
+
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of ZGGESX */
+
+} /* zggesx_ */
diff --git a/SRC/zggev.c b/SRC/zggev.c
new file mode 100644
index 0000000..6adee6b
--- /dev/null
+++ b/SRC/zggev.c
@@ -0,0 +1,599 @@
+/* zggev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zggev_(char *jobvl, char *jobvr, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *alpha, doublecomplex *beta, doublecomplex *vl, integer
+ *ldvl, doublecomplex *vr, integer *ldvr, doublecomplex *work, integer
+ *lwork, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
+ vr_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer jc, in, jr, ihi, ilo;
+ doublereal eps;
+ logical ilv;
+ doublereal anrm, bnrm;
+ integer ierr, itau;
+ doublereal temp;
+ logical ilvl, ilvr;
+ integer iwrk;
+ extern logical lsame_(char *, char *);
+ integer ileft, icols, irwrk, irows;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zggbak_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublecomplex *,
+ integer *, integer *), zggbal_(char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+, integer *, doublereal *, doublereal *, doublereal *, integer *);
+ logical ilascl, ilbscl;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical ldumma[1];
+ char chtemp[1];
+ doublereal bignum;
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ integer ijobvl, iright;
+ extern /* Subroutine */ int zgghrd_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+), zlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublecomplex *,
+ integer *, integer *);
+ integer ijobvr;
+ extern /* Subroutine */ int zgeqrf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *
+);
+ doublereal anrmto;
+ integer lwkmin;
+ doublereal bnrmto;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *), ztgevc_(
+ char *, char *, logical *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *, doublecomplex *,
+ doublereal *, integer *), zhgeqz_(char *, char *,
+ char *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, integer *);
+ doublereal smlnum;
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int zungqr_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *), zunmqr_(char *, char *, integer *, integer
+ *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGGEV computes for a pair of N-by-N complex nonsymmetric matrices */
+/* (A,B), the generalized eigenvalues, and optionally, the left and/or */
+/* right generalized eigenvectors. */
+
+/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar */
+/* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is */
+/* singular. It is usually represented as the pair (alpha,beta), as */
+/* there is a reasonable interpretation for beta=0, and even for both */
+/* being zero. */
+
+/* The right generalized eigenvector v(j) corresponding to the */
+/* generalized eigenvalue lambda(j) of (A,B) satisfies */
+
+/* A * v(j) = lambda(j) * B * v(j). */
+
+/* The left generalized eigenvector u(j) corresponding to the */
+/* generalized eigenvalues lambda(j) of (A,B) satisfies */
+
+/* u(j)**H * A = lambda(j) * u(j)**H * B */
+
+/* where u(j)**H is the conjugate-transpose of u(j). */
+
+/* Arguments */
+/* ========= */
+
+/* JOBVL (input) CHARACTER*1 */
+/* = 'N': do not compute the left generalized eigenvectors; */
+/* = 'V': compute the left generalized eigenvectors. */
+
+/* JOBVR (input) CHARACTER*1 */
+/* = 'N': do not compute the right generalized eigenvectors; */
+/* = 'V': compute the right generalized eigenvectors. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VL, and VR. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA, N) */
+/* On entry, the matrix A in the pair (A,B). */
+/* On exit, A has been overwritten. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB, N) */
+/* On entry, the matrix B in the pair (A,B). */
+/* On exit, B has been overwritten. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* ALPHA (output) COMPLEX*16 array, dimension (N) */
+/* BETA (output) COMPLEX*16 array, dimension (N) */
+/* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the */
+/* generalized eigenvalues. */
+
+/* Note: the quotients ALPHA(j)/BETA(j) may easily over- or */
+/* underflow, and BETA(j) may even be zero. Thus, the user */
+/* should avoid naively computing the ratio alpha/beta. */
+/* However, ALPHA will be always less than and usually */
+/* comparable with norm(A) in magnitude, and BETA always less */
+/* than and usually comparable with norm(B). */
+
+/* VL (output) COMPLEX*16 array, dimension (LDVL,N) */
+/* If JOBVL = 'V', the left generalized eigenvectors u(j) are */
+/* stored one after another in the columns of VL, in the same */
+/* order as their eigenvalues. */
+/* Each eigenvector is scaled so the largest component has */
+/* abs(real part) + abs(imag. part) = 1. */
+/* Not referenced if JOBVL = 'N'. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the matrix VL. LDVL >= 1, and */
+/* if JOBVL = 'V', LDVL >= N. */
+
+/* VR (output) COMPLEX*16 array, dimension (LDVR,N) */
+/* If JOBVR = 'V', the right generalized eigenvectors v(j) are */
+/* stored one after another in the columns of VR, in the same */
+/* order as their eigenvalues. */
+/* Each eigenvector is scaled so the largest component has */
+/* abs(real part) + abs(imag. part) = 1. */
+/* Not referenced if JOBVR = 'N'. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the matrix VR. LDVR >= 1, and */
+/* if JOBVR = 'V', LDVR >= N. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,2*N). */
+/* For good performance, LWORK must generally be larger. */
+
+/* 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. */
+
+/* RWORK (workspace/output) DOUBLE PRECISION array, dimension (8*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* =1,...,N: */
+/* The QZ iteration failed. No eigenvectors have been */
+/* calculated, but ALPHA(j) and BETA(j) should be */
+/* correct for j=INFO+1,...,N. */
+/* > N: =N+1: other then QZ iteration failed in DHGEQZ, */
+/* =N+2: error return from DTGEVC. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alpha;
+ --beta;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ if (lsame_(jobvl, "N")) {
+ ijobvl = 1;
+ ilvl = FALSE_;
+ } else if (lsame_(jobvl, "V")) {
+ ijobvl = 2;
+ ilvl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvl = FALSE_;
+ }
+
+ if (lsame_(jobvr, "N")) {
+ ijobvr = 1;
+ ilvr = FALSE_;
+ } else if (lsame_(jobvr, "V")) {
+ ijobvr = 2;
+ ilvr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvr = FALSE_;
+ }
+ ilv = ilvl || ilvr;
+
+/* Test the input arguments */
+
+ *info = 0;
+ lquery = *lwork == -1;
+ if (ijobvl <= 0) {
+ *info = -1;
+ } else if (ijobvr <= 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvl < 1 || ilvl && *ldvl < *n) {
+ *info = -11;
+ } else if (*ldvr < 1 || ilvr && *ldvr < *n) {
+ *info = -13;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. The workspace is */
+/* computed assuming ILO = 1 and IHI = N, the worst case.) */
+
+ if (*info == 0) {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n << 1;
+ lwkmin = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", n, &c__1, n,
+ &c__0);
+ lwkopt = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = *n + *n * ilaenv_(&c__1, "ZUNMQR", " ", n, &
+ c__1, n, &c__0);
+ lwkopt = max(i__1,i__2);
+ if (ilvl) {
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = *n + *n * ilaenv_(&c__1, "ZUNGQR", " ", n, &
+ c__1, n, &c_n1);
+ lwkopt = max(i__1,i__2);
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ if (*lwork < lwkmin && ! lquery) {
+ *info = -15;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGGEV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("E") * dlamch_("B");
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1. / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = zlange_("M", n, n, &a[a_offset], lda, &rwork[1]);
+ ilascl = FALSE_;
+ if (anrm > 0. && anrm < smlnum) {
+ anrmto = smlnum;
+ ilascl = TRUE_;
+ } else if (anrm > bignum) {
+ anrmto = bignum;
+ ilascl = TRUE_;
+ }
+ if (ilascl) {
+ zlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = zlange_("M", n, n, &b[b_offset], ldb, &rwork[1]);
+ ilbscl = FALSE_;
+ if (bnrm > 0. && bnrm < smlnum) {
+ bnrmto = smlnum;
+ ilbscl = TRUE_;
+ } else if (bnrm > bignum) {
+ bnrmto = bignum;
+ ilbscl = TRUE_;
+ }
+ if (ilbscl) {
+ zlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
+ ierr);
+ }
+
+/* Permute the matrices A, B to isolate eigenvalues if possible */
+/* (Real Workspace: need 6*N) */
+
+ ileft = 1;
+ iright = *n + 1;
+ irwrk = iright + *n;
+ zggbal_("P", n, &a[a_offset], lda, &b[b_offset], ldb, &ilo, &ihi, &rwork[
+ ileft], &rwork[iright], &rwork[irwrk], &ierr);
+
+/* Reduce B to triangular form (QR decomposition of B) */
+/* (Complex Workspace: need N, prefer N*NB) */
+
+ irows = ihi + 1 - ilo;
+ if (ilv) {
+ icols = *n + 1 - ilo;
+ } else {
+ icols = irows;
+ }
+ itau = 1;
+ iwrk = itau + irows;
+ i__1 = *lwork + 1 - iwrk;
+ zgeqrf_(&irows, &icols, &b[ilo + ilo * b_dim1], ldb, &work[itau], &work[
+ iwrk], &i__1, &ierr);
+
+/* Apply the orthogonal transformation to matrix A */
+/* (Complex Workspace: need N, prefer N*NB) */
+
+ i__1 = *lwork + 1 - iwrk;
+ zunmqr_("L", "C", &irows, &icols, &irows, &b[ilo + ilo * b_dim1], ldb, &
+ work[itau], &a[ilo + ilo * a_dim1], lda, &work[iwrk], &i__1, &
+ ierr);
+
+/* Initialize VL */
+/* (Complex Workspace: need N, prefer N*NB) */
+
+ if (ilvl) {
+ zlaset_("Full", n, n, &c_b1, &c_b2, &vl[vl_offset], ldvl);
+ if (irows > 1) {
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ zlacpy_("L", &i__1, &i__2, &b[ilo + 1 + ilo * b_dim1], ldb, &vl[
+ ilo + 1 + ilo * vl_dim1], ldvl);
+ }
+ i__1 = *lwork + 1 - iwrk;
+ zungqr_(&irows, &irows, &irows, &vl[ilo + ilo * vl_dim1], ldvl, &work[
+ itau], &work[iwrk], &i__1, &ierr);
+ }
+
+/* Initialize VR */
+
+ if (ilvr) {
+ zlaset_("Full", n, n, &c_b1, &c_b2, &vr[vr_offset], ldvr);
+ }
+
+/* Reduce to generalized Hessenberg form */
+
+ if (ilv) {
+
+/* Eigenvectors requested -- work on whole matrix. */
+
+ zgghrd_(jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr);
+ } else {
+ zgghrd_("N", "N", &irows, &c__1, &irows, &a[ilo + ilo * a_dim1], lda,
+ &b[ilo + ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[
+ vr_offset], ldvr, &ierr);
+ }
+
+/* Perform QZ algorithm (Compute eigenvalues, and optionally, the */
+/* Schur form and Schur vectors) */
+/* (Complex Workspace: need N) */
+/* (Real Workspace: need N) */
+
+ iwrk = itau;
+ if (ilv) {
+ *(unsigned char *)chtemp = 'S';
+ } else {
+ *(unsigned char *)chtemp = 'E';
+ }
+ i__1 = *lwork + 1 - iwrk;
+ zhgeqz_(chtemp, jobvl, jobvr, n, &ilo, &ihi, &a[a_offset], lda, &b[
+ b_offset], ldb, &alpha[1], &beta[1], &vl[vl_offset], ldvl, &vr[
+ vr_offset], ldvr, &work[iwrk], &i__1, &rwork[irwrk], &ierr);
+ if (ierr != 0) {
+ if (ierr > 0 && ierr <= *n) {
+ *info = ierr;
+ } else if (ierr > *n && ierr <= *n << 1) {
+ *info = ierr - *n;
+ } else {
+ *info = *n + 1;
+ }
+ goto L70;
+ }
+
+/* Compute Eigenvectors */
+/* (Real Workspace: need 2*N) */
+/* (Complex Workspace: need 2*N) */
+
+ if (ilv) {
+ if (ilvl) {
+ if (ilvr) {
+ *(unsigned char *)chtemp = 'B';
+ } else {
+ *(unsigned char *)chtemp = 'L';
+ }
+ } else {
+ *(unsigned char *)chtemp = 'R';
+ }
+
+ ztgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset], ldb,
+ &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &work[
+ iwrk], &rwork[irwrk], &ierr);
+ if (ierr != 0) {
+ *info = *n + 2;
+ goto L70;
+ }
+
+/* Undo balancing on VL and VR and normalization */
+/* (Workspace: none needed) */
+
+ if (ilvl) {
+ zggbak_("P", "L", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n,
+ &vl[vl_offset], ldvl, &ierr);
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ temp = 0.;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ i__3 = jr + jc * vl_dim1;
+ d__3 = temp, d__4 = (d__1 = vl[i__3].r, abs(d__1)) + (
+ d__2 = d_imag(&vl[jr + jc * vl_dim1]), abs(d__2));
+ temp = max(d__3,d__4);
+/* L10: */
+ }
+ if (temp < smlnum) {
+ goto L30;
+ }
+ temp = 1. / temp;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = jr + jc * vl_dim1;
+ i__4 = jr + jc * vl_dim1;
+ z__1.r = temp * vl[i__4].r, z__1.i = temp * vl[i__4].i;
+ vl[i__3].r = z__1.r, vl[i__3].i = z__1.i;
+/* L20: */
+ }
+L30:
+ ;
+ }
+ }
+ if (ilvr) {
+ zggbak_("P", "R", n, &ilo, &ihi, &rwork[ileft], &rwork[iright], n,
+ &vr[vr_offset], ldvr, &ierr);
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ temp = 0.;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ i__3 = jr + jc * vr_dim1;
+ d__3 = temp, d__4 = (d__1 = vr[i__3].r, abs(d__1)) + (
+ d__2 = d_imag(&vr[jr + jc * vr_dim1]), abs(d__2));
+ temp = max(d__3,d__4);
+/* L40: */
+ }
+ if (temp < smlnum) {
+ goto L60;
+ }
+ temp = 1. / temp;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = jr + jc * vr_dim1;
+ i__4 = jr + jc * vr_dim1;
+ z__1.r = temp * vr[i__4].r, z__1.i = temp * vr[i__4].i;
+ vr[i__3].r = z__1.r, vr[i__3].i = z__1.i;
+/* L50: */
+ }
+L60:
+ ;
+ }
+ }
+ }
+
+/* Undo scaling if necessary */
+
+ if (ilascl) {
+ zlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alpha[1], n, &
+ ierr);
+ }
+
+ if (ilbscl) {
+ zlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
+ ierr);
+ }
+
+L70:
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZGGEV */
+
+} /* zggev_ */
diff --git a/SRC/zggevx.c b/SRC/zggevx.c
new file mode 100644
index 0000000..b589a5a
--- /dev/null
+++ b/SRC/zggevx.c
@@ -0,0 +1,812 @@
+/* zggevx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+static integer c__0 = 0;
+
+/* Subroutine */ int zggevx_(char *balanc, char *jobvl, char *jobvr, char *
+ sense, integer *n, doublecomplex *a, integer *lda, doublecomplex *b,
+ integer *ldb, doublecomplex *alpha, doublecomplex *beta,
+ doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr,
+ integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale,
+ doublereal *abnrm, doublereal *bbnrm, doublereal *rconde, doublereal *
+ rcondv, doublecomplex *work, integer *lwork, doublereal *rwork,
+ integer *iwork, logical *bwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
+ vr_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, m, jc, in, jr;
+ doublereal eps;
+ logical ilv;
+ doublereal anrm, bnrm;
+ integer ierr, itau;
+ doublereal temp;
+ logical ilvl, ilvr;
+ integer iwrk, iwrk1;
+ extern logical lsame_(char *, char *);
+ integer icols;
+ logical noscl;
+ integer irows;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), zggbak_(char *, char *, integer *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublecomplex *, integer *, integer *), zggbal_(
+ char *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *);
+ logical ilascl, ilbscl;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical ldumma[1];
+ char chtemp[1];
+ doublereal bignum;
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ integer ijobvl;
+ extern /* Subroutine */ int zgghrd_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+), zlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublecomplex *,
+ integer *, integer *);
+ integer ijobvr;
+ logical wantsb;
+ extern /* Subroutine */ int zgeqrf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *
+);
+ doublereal anrmto;
+ logical wantse;
+ doublereal bnrmto;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *), ztgevc_(
+ char *, char *, logical *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *, doublecomplex *,
+ doublereal *, integer *), ztgsna_(char *, char *,
+ logical *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *, doublecomplex *, integer *, doublecomplex *, integer
+ *, doublereal *, doublereal *, integer *, integer *,
+ doublecomplex *, integer *, integer *, integer *);
+ integer minwrk;
+ extern /* Subroutine */ int zhgeqz_(char *, char *, char *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *);
+ integer maxwrk;
+ logical wantsn;
+ doublereal smlnum;
+ logical lquery, wantsv;
+ extern /* Subroutine */ int zungqr_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *), zunmqr_(char *, char *, integer *, integer
+ *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGGEVX computes for a pair of N-by-N complex nonsymmetric matrices */
+/* (A,B) the generalized eigenvalues, and optionally, the left and/or */
+/* right generalized eigenvectors. */
+
+/* Optionally, it also computes a balancing transformation to improve */
+/* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */
+/* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for */
+/* the eigenvalues (RCONDE), and reciprocal condition numbers for the */
+/* right eigenvectors (RCONDV). */
+
+/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar */
+/* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is */
+/* singular. It is usually represented as the pair (alpha,beta), as */
+/* there is a reasonable interpretation for beta=0, and even for both */
+/* being zero. */
+
+/* The right eigenvector v(j) corresponding to the eigenvalue lambda(j) */
+/* of (A,B) satisfies */
+/* A * v(j) = lambda(j) * B * v(j) . */
+/* The left eigenvector u(j) corresponding to the eigenvalue lambda(j) */
+/* of (A,B) satisfies */
+/* u(j)**H * A = lambda(j) * u(j)**H * B. */
+/* where u(j)**H is the conjugate-transpose of u(j). */
+
+
+/* Arguments */
+/* ========= */
+
+/* BALANC (input) CHARACTER*1 */
+/* Specifies the balance option to be performed: */
+/* = 'N': do not diagonally scale or permute; */
+/* = 'P': permute only; */
+/* = 'S': scale only; */
+/* = 'B': both permute and scale. */
+/* Computed reciprocal condition numbers will be for the */
+/* matrices after permuting and/or balancing. Permuting does */
+/* not change condition numbers (in exact arithmetic), but */
+/* balancing does. */
+
+/* JOBVL (input) CHARACTER*1 */
+/* = 'N': do not compute the left generalized eigenvectors; */
+/* = 'V': compute the left generalized eigenvectors. */
+
+/* JOBVR (input) CHARACTER*1 */
+/* = 'N': do not compute the right generalized eigenvectors; */
+/* = 'V': compute the right generalized eigenvectors. */
+
+/* SENSE (input) CHARACTER*1 */
+/* Determines which reciprocal condition numbers are computed. */
+/* = 'N': none are computed; */
+/* = 'E': computed for eigenvalues only; */
+/* = 'V': computed for eigenvectors only; */
+/* = 'B': computed for eigenvalues and eigenvectors. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A, B, VL, and VR. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA, N) */
+/* On entry, the matrix A in the pair (A,B). */
+/* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V' */
+/* or both, then A contains the first part of the complex Schur */
+/* form of the "balanced" versions of the input A and B. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB, N) */
+/* On entry, the matrix B in the pair (A,B). */
+/* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V' */
+/* or both, then B contains the second part of the complex */
+/* Schur form of the "balanced" versions of the input A and B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB >= max(1,N). */
+
+/* ALPHA (output) COMPLEX*16 array, dimension (N) */
+/* BETA (output) COMPLEX*16 array, dimension (N) */
+/* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the generalized */
+/* eigenvalues. */
+
+/* Note: the quotient ALPHA(j)/BETA(j) ) may easily over- or */
+/* underflow, and BETA(j) may even be zero. Thus, the user */
+/* should avoid naively computing the ratio ALPHA/BETA. */
+/* However, ALPHA will be always less than and usually */
+/* comparable with norm(A) in magnitude, and BETA always less */
+/* than and usually comparable with norm(B). */
+
+/* VL (output) COMPLEX*16 array, dimension (LDVL,N) */
+/* If JOBVL = 'V', the left generalized eigenvectors u(j) are */
+/* stored one after another in the columns of VL, in the same */
+/* order as their eigenvalues. */
+/* Each eigenvector will be scaled so the largest component */
+/* will have abs(real part) + abs(imag. part) = 1. */
+/* Not referenced if JOBVL = 'N'. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the matrix VL. LDVL >= 1, and */
+/* if JOBVL = 'V', LDVL >= N. */
+
+/* VR (output) COMPLEX*16 array, dimension (LDVR,N) */
+/* If JOBVR = 'V', the right generalized eigenvectors v(j) are */
+/* stored one after another in the columns of VR, in the same */
+/* order as their eigenvalues. */
+/* Each eigenvector will be scaled so the largest component */
+/* will have abs(real part) + abs(imag. part) = 1. */
+/* Not referenced if JOBVR = 'N'. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the matrix VR. LDVR >= 1, and */
+/* if JOBVR = 'V', LDVR >= N. */
+
+/* ILO (output) INTEGER */
+/* IHI (output) INTEGER */
+/* ILO and IHI are integer values such that on exit */
+/* A(i,j) = 0 and B(i,j) = 0 if i > j and */
+/* j = 1,...,ILO-1 or i = IHI+1,...,N. */
+/* If BALANC = 'N' or 'S', ILO = 1 and IHI = N. */
+
+/* LSCALE (output) DOUBLE PRECISION array, dimension (N) */
+/* Details of the permutations and scaling factors applied */
+/* to the left side of A and B. If PL(j) is the index of the */
+/* row interchanged with row j, and DL(j) is the scaling */
+/* factor applied to row j, then */
+/* LSCALE(j) = PL(j) for j = 1,...,ILO-1 */
+/* = DL(j) for j = ILO,...,IHI */
+/* = PL(j) for j = IHI+1,...,N. */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* RSCALE (output) DOUBLE PRECISION array, dimension (N) */
+/* Details of the permutations and scaling factors applied */
+/* to the right side of A and B. If PR(j) is the index of the */
+/* column interchanged with column j, and DR(j) is the scaling */
+/* factor applied to column j, then */
+/* RSCALE(j) = PR(j) for j = 1,...,ILO-1 */
+/* = DR(j) for j = ILO,...,IHI */
+/* = PR(j) for j = IHI+1,...,N */
+/* The order in which the interchanges are made is N to IHI+1, */
+/* then 1 to ILO-1. */
+
+/* ABNRM (output) DOUBLE PRECISION */
+/* The one-norm of the balanced matrix A. */
+
+/* BBNRM (output) DOUBLE PRECISION */
+/* The one-norm of the balanced matrix B. */
+
+/* RCONDE (output) DOUBLE PRECISION array, dimension (N) */
+/* If SENSE = 'E' or 'B', the reciprocal condition numbers of */
+/* the eigenvalues, stored in consecutive elements of the array. */
+/* If SENSE = 'N' or 'V', RCONDE is not referenced. */
+
+/* RCONDV (output) DOUBLE PRECISION array, dimension (N) */
+/* If JOB = 'V' or 'B', the estimated reciprocal condition */
+/* numbers of the eigenvectors, stored in consecutive elements */
+/* of the array. If the eigenvalues cannot be reordered to */
+/* compute RCONDV(j), RCONDV(j) is set to 0; this can only occur */
+/* when the true value would be very small anyway. */
+/* If SENSE = 'N' or 'E', RCONDV is not referenced. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,2*N). */
+/* If SENSE = 'E', LWORK >= max(1,4*N). */
+/* If SENSE = 'V' or 'B', LWORK >= max(1,2*N*N+2*N). */
+
+/* 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. */
+
+/* RWORK (workspace) REAL array, dimension (lrwork) */
+/* lrwork must be at least max(1,6*N) if BALANC = 'S' or 'B', */
+/* and at least max(1,2*N) otherwise. */
+/* Real workspace. */
+
+/* IWORK (workspace) INTEGER array, dimension (N+2) */
+/* If SENSE = 'E', IWORK is not referenced. */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+/* If SENSE = 'N', BWORK is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1,...,N: */
+/* The QZ iteration failed. No eigenvectors have been */
+/* calculated, but ALPHA(j) and BETA(j) should be correct */
+/* for j=INFO+1,...,N. */
+/* > N: =N+1: other than QZ iteration failed in ZHGEQZ. */
+/* =N+2: error return from ZTGEVC. */
+
+/* Further Details */
+/* =============== */
+
+/* Balancing a matrix pair (A,B) includes, first, permuting rows and */
+/* columns to isolate eigenvalues, second, applying diagonal similarity */
+/* transformation to the rows and columns to make the rows and columns */
+/* as close in norm as possible. The computed reciprocal condition */
+/* numbers correspond to the balanced matrix. Permuting rows and columns */
+/* will not change the condition numbers (in exact arithmetic) but */
+/* diagonal scaling will. For further explanation of balancing, see */
+/* section 4.11.1.2 of LAPACK Users' Guide. */
+
+/* An approximate error bound on the chordal distance between the i-th */
+/* computed generalized eigenvalue w and the corresponding exact */
+/* eigenvalue lambda is */
+
+/* chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I) */
+
+/* An approximate error bound for the angle between the i-th computed */
+/* eigenvector VL(i) or VR(i) is given by */
+
+/* EPS * norm(ABNRM, BBNRM) / DIF(i). */
+
+/* For further explanation of the reciprocal condition numbers RCONDE */
+/* and RCONDV, see section 4.11 of LAPACK User's Guide. */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alpha;
+ --beta;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --lscale;
+ --rscale;
+ --rconde;
+ --rcondv;
+ --work;
+ --rwork;
+ --iwork;
+ --bwork;
+
+ /* Function Body */
+ if (lsame_(jobvl, "N")) {
+ ijobvl = 1;
+ ilvl = FALSE_;
+ } else if (lsame_(jobvl, "V")) {
+ ijobvl = 2;
+ ilvl = TRUE_;
+ } else {
+ ijobvl = -1;
+ ilvl = FALSE_;
+ }
+
+ if (lsame_(jobvr, "N")) {
+ ijobvr = 1;
+ ilvr = FALSE_;
+ } else if (lsame_(jobvr, "V")) {
+ ijobvr = 2;
+ ilvr = TRUE_;
+ } else {
+ ijobvr = -1;
+ ilvr = FALSE_;
+ }
+ ilv = ilvl || ilvr;
+
+ noscl = lsame_(balanc, "N") || lsame_(balanc, "P");
+ wantsn = lsame_(sense, "N");
+ wantse = lsame_(sense, "E");
+ wantsv = lsame_(sense, "V");
+ wantsb = lsame_(sense, "B");
+
+/* Test the input arguments */
+
+ *info = 0;
+ lquery = *lwork == -1;
+ if (! (noscl || lsame_(balanc, "S") || lsame_(
+ balanc, "B"))) {
+ *info = -1;
+ } else if (ijobvl <= 0) {
+ *info = -2;
+ } else if (ijobvr <= 0) {
+ *info = -3;
+ } else if (! (wantsn || wantse || wantsb || wantsv)) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldvl < 1 || ilvl && *ldvl < *n) {
+ *info = -13;
+ } else if (*ldvr < 1 || ilvr && *ldvr < *n) {
+ *info = -15;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. The workspace is */
+/* computed assuming ILO = 1 and IHI = N, the worst case.) */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ minwrk = 1;
+ maxwrk = 1;
+ } else {
+ minwrk = *n << 1;
+ if (wantse) {
+ minwrk = *n << 2;
+ } else if (wantsv || wantsb) {
+ minwrk = (*n << 1) * (*n + 1);
+ }
+ maxwrk = minwrk;
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "ZGEQRF", " ", n, &
+ c__1, n, &c__0);
+ maxwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "ZUNMQR", " ", n, &
+ c__1, n, &c__0);
+ maxwrk = max(i__1,i__2);
+ if (ilvl) {
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "ZUNGQR",
+ " ", n, &c__1, n, &c__0);
+ maxwrk = max(i__1,i__2);
+ }
+ }
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+
+ if (*lwork < minwrk && ! lquery) {
+ *info = -25;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGGEVX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ smlnum = sqrt(smlnum) / eps;
+ bignum = 1. / smlnum;
+
+/* Scale A if max element outside range [SMLNUM,BIGNUM] */
+
+ anrm = zlange_("M", n, n, &a[a_offset], lda, &rwork[1]);
+ ilascl = FALSE_;
+ if (anrm > 0. && anrm < smlnum) {
+ anrmto = smlnum;
+ ilascl = TRUE_;
+ } else if (anrm > bignum) {
+ anrmto = bignum;
+ ilascl = TRUE_;
+ }
+ if (ilascl) {
+ zlascl_("G", &c__0, &c__0, &anrm, &anrmto, n, n, &a[a_offset], lda, &
+ ierr);
+ }
+
+/* Scale B if max element outside range [SMLNUM,BIGNUM] */
+
+ bnrm = zlange_("M", n, n, &b[b_offset], ldb, &rwork[1]);
+ ilbscl = FALSE_;
+ if (bnrm > 0. && bnrm < smlnum) {
+ bnrmto = smlnum;
+ ilbscl = TRUE_;
+ } else if (bnrm > bignum) {
+ bnrmto = bignum;
+ ilbscl = TRUE_;
+ }
+ if (ilbscl) {
+ zlascl_("G", &c__0, &c__0, &bnrm, &bnrmto, n, n, &b[b_offset], ldb, &
+ ierr);
+ }
+
+/* Permute and/or balance the matrix pair (A,B) */
+/* (Real Workspace: need 6*N if BALANC = 'S' or 'B', 1 otherwise) */
+
+ zggbal_(balanc, n, &a[a_offset], lda, &b[b_offset], ldb, ilo, ihi, &
+ lscale[1], &rscale[1], &rwork[1], &ierr);
+
+/* Compute ABNRM and BBNRM */
+
+ *abnrm = zlange_("1", n, n, &a[a_offset], lda, &rwork[1]);
+ if (ilascl) {
+ rwork[1] = *abnrm;
+ dlascl_("G", &c__0, &c__0, &anrmto, &anrm, &c__1, &c__1, &rwork[1], &
+ c__1, &ierr);
+ *abnrm = rwork[1];
+ }
+
+ *bbnrm = zlange_("1", n, n, &b[b_offset], ldb, &rwork[1]);
+ if (ilbscl) {
+ rwork[1] = *bbnrm;
+ dlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, &c__1, &c__1, &rwork[1], &
+ c__1, &ierr);
+ *bbnrm = rwork[1];
+ }
+
+/* Reduce B to triangular form (QR decomposition of B) */
+/* (Complex Workspace: need N, prefer N*NB ) */
+
+ irows = *ihi + 1 - *ilo;
+ if (ilv || ! wantsn) {
+ icols = *n + 1 - *ilo;
+ } else {
+ icols = irows;
+ }
+ itau = 1;
+ iwrk = itau + irows;
+ i__1 = *lwork + 1 - iwrk;
+ zgeqrf_(&irows, &icols, &b[*ilo + *ilo * b_dim1], ldb, &work[itau], &work[
+ iwrk], &i__1, &ierr);
+
+/* Apply the unitary transformation to A */
+/* (Complex Workspace: need N, prefer N*NB) */
+
+ i__1 = *lwork + 1 - iwrk;
+ zunmqr_("L", "C", &irows, &icols, &irows, &b[*ilo + *ilo * b_dim1], ldb, &
+ work[itau], &a[*ilo + *ilo * a_dim1], lda, &work[iwrk], &i__1, &
+ ierr);
+
+/* Initialize VL and/or VR */
+/* (Workspace: need N, prefer N*NB) */
+
+ if (ilvl) {
+ zlaset_("Full", n, n, &c_b1, &c_b2, &vl[vl_offset], ldvl);
+ if (irows > 1) {
+ i__1 = irows - 1;
+ i__2 = irows - 1;
+ zlacpy_("L", &i__1, &i__2, &b[*ilo + 1 + *ilo * b_dim1], ldb, &vl[
+ *ilo + 1 + *ilo * vl_dim1], ldvl);
+ }
+ i__1 = *lwork + 1 - iwrk;
+ zungqr_(&irows, &irows, &irows, &vl[*ilo + *ilo * vl_dim1], ldvl, &
+ work[itau], &work[iwrk], &i__1, &ierr);
+ }
+
+ if (ilvr) {
+ zlaset_("Full", n, n, &c_b1, &c_b2, &vr[vr_offset], ldvr);
+ }
+
+/* Reduce to generalized Hessenberg form */
+/* (Workspace: none needed) */
+
+ if (ilv || ! wantsn) {
+
+/* Eigenvectors requested -- work on whole matrix. */
+
+ zgghrd_(jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset],
+ ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ierr);
+ } else {
+ zgghrd_("N", "N", &irows, &c__1, &irows, &a[*ilo + *ilo * a_dim1],
+ lda, &b[*ilo + *ilo * b_dim1], ldb, &vl[vl_offset], ldvl, &vr[
+ vr_offset], ldvr, &ierr);
+ }
+
+/* Perform QZ algorithm (Compute eigenvalues, and optionally, the */
+/* Schur forms and Schur vectors) */
+/* (Complex Workspace: need N) */
+/* (Real Workspace: need N) */
+
+ iwrk = itau;
+ if (ilv || ! wantsn) {
+ *(unsigned char *)chtemp = 'S';
+ } else {
+ *(unsigned char *)chtemp = 'E';
+ }
+
+ i__1 = *lwork + 1 - iwrk;
+ zhgeqz_(chtemp, jobvl, jobvr, n, ilo, ihi, &a[a_offset], lda, &b[b_offset]
+, ldb, &alpha[1], &beta[1], &vl[vl_offset], ldvl, &vr[vr_offset],
+ ldvr, &work[iwrk], &i__1, &rwork[1], &ierr);
+ if (ierr != 0) {
+ if (ierr > 0 && ierr <= *n) {
+ *info = ierr;
+ } else if (ierr > *n && ierr <= *n << 1) {
+ *info = ierr - *n;
+ } else {
+ *info = *n + 1;
+ }
+ goto L90;
+ }
+
+/* Compute Eigenvectors and estimate condition numbers if desired */
+/* ZTGEVC: (Complex Workspace: need 2*N ) */
+/* (Real Workspace: need 2*N ) */
+/* ZTGSNA: (Complex Workspace: need 2*N*N if SENSE='V' or 'B') */
+/* (Integer Workspace: need N+2 ) */
+
+ if (ilv || ! wantsn) {
+ if (ilv) {
+ if (ilvl) {
+ if (ilvr) {
+ *(unsigned char *)chtemp = 'B';
+ } else {
+ *(unsigned char *)chtemp = 'L';
+ }
+ } else {
+ *(unsigned char *)chtemp = 'R';
+ }
+
+ ztgevc_(chtemp, "B", ldumma, n, &a[a_offset], lda, &b[b_offset],
+ ldb, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr, n, &in, &
+ work[iwrk], &rwork[1], &ierr);
+ if (ierr != 0) {
+ *info = *n + 2;
+ goto L90;
+ }
+ }
+
+ if (! wantsn) {
+
+/* compute eigenvectors (DTGEVC) and estimate condition */
+/* numbers (DTGSNA). Note that the definition of the condition */
+/* number is not invariant under transformation (u,v) to */
+/* (Q*u, Z*v), where (u,v) are eigenvectors of the generalized */
+/* Schur form (S,T), Q and Z are orthogonal matrices. In order */
+/* to avoid using extra 2*N*N workspace, we have to */
+/* re-calculate eigenvectors and estimate the condition numbers */
+/* one at a time. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ bwork[j] = FALSE_;
+/* L10: */
+ }
+ bwork[i__] = TRUE_;
+
+ iwrk = *n + 1;
+ iwrk1 = iwrk + *n;
+
+ if (wantse || wantsb) {
+ ztgevc_("B", "S", &bwork[1], n, &a[a_offset], lda, &b[
+ b_offset], ldb, &work[1], n, &work[iwrk], n, &
+ c__1, &m, &work[iwrk1], &rwork[1], &ierr);
+ if (ierr != 0) {
+ *info = *n + 2;
+ goto L90;
+ }
+ }
+
+ i__2 = *lwork - iwrk1 + 1;
+ ztgsna_(sense, "S", &bwork[1], n, &a[a_offset], lda, &b[
+ b_offset], ldb, &work[1], n, &work[iwrk], n, &rconde[
+ i__], &rcondv[i__], &c__1, &m, &work[iwrk1], &i__2, &
+ iwork[1], &ierr);
+
+/* L20: */
+ }
+ }
+ }
+
+/* Undo balancing on VL and VR and normalization */
+/* (Workspace: none needed) */
+
+ if (ilvl) {
+ zggbak_(balanc, "L", n, ilo, ihi, &lscale[1], &rscale[1], n, &vl[
+ vl_offset], ldvl, &ierr);
+
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ temp = 0.;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ i__3 = jr + jc * vl_dim1;
+ d__3 = temp, d__4 = (d__1 = vl[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&vl[jr + jc * vl_dim1]), abs(d__2));
+ temp = max(d__3,d__4);
+/* L30: */
+ }
+ if (temp < smlnum) {
+ goto L50;
+ }
+ temp = 1. / temp;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = jr + jc * vl_dim1;
+ i__4 = jr + jc * vl_dim1;
+ z__1.r = temp * vl[i__4].r, z__1.i = temp * vl[i__4].i;
+ vl[i__3].r = z__1.r, vl[i__3].i = z__1.i;
+/* L40: */
+ }
+L50:
+ ;
+ }
+ }
+
+ if (ilvr) {
+ zggbak_(balanc, "R", n, ilo, ihi, &lscale[1], &rscale[1], n, &vr[
+ vr_offset], ldvr, &ierr);
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ temp = 0.;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+/* Computing MAX */
+ i__3 = jr + jc * vr_dim1;
+ d__3 = temp, d__4 = (d__1 = vr[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&vr[jr + jc * vr_dim1]), abs(d__2));
+ temp = max(d__3,d__4);
+/* L60: */
+ }
+ if (temp < smlnum) {
+ goto L80;
+ }
+ temp = 1. / temp;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = jr + jc * vr_dim1;
+ i__4 = jr + jc * vr_dim1;
+ z__1.r = temp * vr[i__4].r, z__1.i = temp * vr[i__4].i;
+ vr[i__3].r = z__1.r, vr[i__3].i = z__1.i;
+/* L70: */
+ }
+L80:
+ ;
+ }
+ }
+
+/* Undo scaling if necessary */
+
+ if (ilascl) {
+ zlascl_("G", &c__0, &c__0, &anrmto, &anrm, n, &c__1, &alpha[1], n, &
+ ierr);
+ }
+
+ if (ilbscl) {
+ zlascl_("G", &c__0, &c__0, &bnrmto, &bnrm, n, &c__1, &beta[1], n, &
+ ierr);
+ }
+
+L90:
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZGGEVX */
+
+} /* zggevx_ */
diff --git a/SRC/zggglm.c b/SRC/zggglm.c
new file mode 100644
index 0000000..a6e9095
--- /dev/null
+++ b/SRC/zggglm.c
@@ -0,0 +1,337 @@
+/* zggglm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zggglm_(integer *n, integer *m, integer *p,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *d__, doublecomplex *x, doublecomplex *y, doublecomplex
+ *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, nb, np, nb1, nb2, nb3, nb4, lopt;
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zggqrf_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *)
+ ;
+ integer lwkmin, lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int zunmqr_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *), zunmrq_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *), ztrtrs_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGGGLM solves a general Gauss-Markov linear model (GLM) problem: */
+
+/* minimize || y ||_2 subject to d = A*x + B*y */
+/* x */
+
+/* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a */
+/* given N-vector. It is assumed that M <= N <= M+P, and */
+
+/* rank(A) = M and rank( A B ) = N. */
+
+/* Under these assumptions, the constrained equation is always */
+/* consistent, and there is a unique solution x and a minimal 2-norm */
+/* solution y, which is obtained using a generalized QR factorization */
+/* of the matrices (A, B) given by */
+
+/* A = Q*(R), B = Q*T*Z. */
+/* (0) */
+
+/* In particular, if matrix B is square nonsingular, then the problem */
+/* GLM is equivalent to the following weighted linear least squares */
+/* problem */
+
+/* minimize || inv(B)*(d-A*x) ||_2 */
+/* x */
+
+/* where inv(B) denotes the inverse of B. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices A and B. N >= 0. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix A. 0 <= M <= N. */
+
+/* P (input) INTEGER */
+/* The number of columns of the matrix B. P >= N-M. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,M) */
+/* On entry, the N-by-M matrix A. */
+/* On exit, the upper triangular part of the array A contains */
+/* the M-by-M upper triangular matrix R. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,P) */
+/* On entry, the N-by-P matrix B. */
+/* On exit, if N <= P, the upper triangle of the subarray */
+/* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T; */
+/* if N > P, the elements on and above the (N-P)th subdiagonal */
+/* contain the N-by-P upper trapezoidal matrix T. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* D (input/output) COMPLEX*16 array, dimension (N) */
+/* On entry, D is the left hand side of the GLM equation. */
+/* On exit, D is destroyed. */
+
+/* X (output) COMPLEX*16 array, dimension (M) */
+/* Y (output) COMPLEX*16 array, dimension (P) */
+/* On exit, X and Y are the solutions of the GLM problem. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N+M+P). */
+/* For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB, */
+/* where NB is an upper bound for the optimal blocksizes for */
+/* ZGEQRF, ZGERQF, ZUNMQR and ZUNMRQ. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1: the upper triangular factor R associated with A in the */
+/* generalized QR factorization of the pair (A, B) is */
+/* singular, so that rank(A) < M; the least squares */
+/* solution could not be computed. */
+/* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal */
+/* factor T associated with B in the generalized QR */
+/* factorization of the pair (A, B) is singular, so that */
+/* rank( A B ) < N; the least squares solution could not */
+/* be computed. */
+
+/* =================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --d__;
+ --x;
+ --y;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ np = min(*n,*p);
+ lquery = *lwork == -1;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*m < 0 || *m > *n) {
+ *info = -2;
+ } else if (*p < 0 || *p < *n - *m) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+
+/* Calculate workspace */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ lwkmin = 1;
+ lwkopt = 1;
+ } else {
+ nb1 = ilaenv_(&c__1, "ZGEQRF", " ", n, m, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "ZGERQF", " ", n, m, &c_n1, &c_n1);
+ nb3 = ilaenv_(&c__1, "ZUNMQR", " ", n, m, p, &c_n1);
+ nb4 = ilaenv_(&c__1, "ZUNMRQ", " ", n, m, p, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2), i__1 = max(i__1,nb3);
+ nb = max(i__1,nb4);
+ lwkmin = *m + *n + *p;
+ lwkopt = *m + np + max(*n,*p) * nb;
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ if (*lwork < lwkmin && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGGGLM", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Compute the GQR factorization of matrices A and B: */
+
+/* Q'*A = ( R11 ) M, Q'*B*Z' = ( T11 T12 ) M */
+/* ( 0 ) N-M ( 0 T22 ) N-M */
+/* M M+P-N N-M */
+
+/* where R11 and T22 are upper triangular, and Q and Z are */
+/* unitary. */
+
+ i__1 = *lwork - *m - np;
+ zggqrf_(n, m, p, &a[a_offset], lda, &work[1], &b[b_offset], ldb, &work[*m
+ + 1], &work[*m + np + 1], &i__1, info);
+ i__1 = *m + np + 1;
+ lopt = (integer) work[i__1].r;
+
+/* Update left-hand-side vector d = Q'*d = ( d1 ) M */
+/* ( d2 ) N-M */
+
+ i__1 = max(1,*n);
+ i__2 = *lwork - *m - np;
+ zunmqr_("Left", "Conjugate transpose", n, &c__1, m, &a[a_offset], lda, &
+ work[1], &d__[1], &i__1, &work[*m + np + 1], &i__2, info);
+/* Computing MAX */
+ i__3 = *m + np + 1;
+ i__1 = lopt, i__2 = (integer) work[i__3].r;
+ lopt = max(i__1,i__2);
+
+/* Solve T22*y2 = d2 for y2 */
+
+ if (*n > *m) {
+ i__1 = *n - *m;
+ i__2 = *n - *m;
+ ztrtrs_("Upper", "No transpose", "Non unit", &i__1, &c__1, &b[*m + 1
+ + (*m + *p - *n + 1) * b_dim1], ldb, &d__[*m + 1], &i__2,
+ info);
+
+ if (*info > 0) {
+ *info = 1;
+ return 0;
+ }
+
+ i__1 = *n - *m;
+ zcopy_(&i__1, &d__[*m + 1], &c__1, &y[*m + *p - *n + 1], &c__1);
+ }
+
+/* Set y1 = 0 */
+
+ i__1 = *m + *p - *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ y[i__2].r = 0., y[i__2].i = 0.;
+/* L10: */
+ }
+
+/* Update d1 = d1 - T12*y2 */
+
+ i__1 = *n - *m;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", m, &i__1, &z__1, &b[(*m + *p - *n + 1) * b_dim1 +
+ 1], ldb, &y[*m + *p - *n + 1], &c__1, &c_b2, &d__[1], &c__1);
+
+/* Solve triangular system: R11*x = d1 */
+
+ if (*m > 0) {
+ ztrtrs_("Upper", "No Transpose", "Non unit", m, &c__1, &a[a_offset],
+ lda, &d__[1], m, info);
+
+ if (*info > 0) {
+ *info = 2;
+ return 0;
+ }
+
+/* Copy D to X */
+
+ zcopy_(m, &d__[1], &c__1, &x[1], &c__1);
+ }
+
+/* Backward transformation y = Z'*y */
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *n - *p + 1;
+ i__3 = max(1,*p);
+ i__4 = *lwork - *m - np;
+ zunmrq_("Left", "Conjugate transpose", p, &c__1, &np, &b[max(i__1, i__2)+
+ b_dim1], ldb, &work[*m + 1], &y[1], &i__3, &work[*m + np + 1], &
+ i__4, info);
+/* Computing MAX */
+ i__4 = *m + np + 1;
+ i__2 = lopt, i__3 = (integer) work[i__4].r;
+ i__1 = *m + np + max(i__2,i__3);
+ work[1].r = (doublereal) i__1, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZGGGLM */
+
+} /* zggglm_ */
diff --git a/SRC/zgghrd.c b/SRC/zgghrd.c
new file mode 100644
index 0000000..6ad8eb9
--- /dev/null
+++ b/SRC/zgghrd.c
@@ -0,0 +1,336 @@
+/* zgghrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static doublecomplex c_b2 = {0.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zgghrd_(char *compq, char *compz, integer *n, integer *
+ ilo, integer *ihi, doublecomplex *a, integer *lda, doublecomplex *b,
+ integer *ldb, doublecomplex *q, integer *ldq, doublecomplex *z__,
+ integer *ldz, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
+ z_offset, i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ doublereal c__;
+ doublecomplex s;
+ logical ilq, ilz;
+ integer jcol, jrow;
+ extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *);
+ extern logical lsame_(char *, char *);
+ doublecomplex ctemp;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer icompq, icompz;
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlartg_(doublecomplex *, doublecomplex *, doublereal *,
+ doublecomplex *, doublecomplex *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGGHRD reduces a pair of complex matrices (A,B) to generalized upper */
+/* Hessenberg form using unitary transformations, where A is a */
+/* general matrix and B is upper triangular. The form of the */
+/* generalized eigenvalue problem is */
+/* A*x = lambda*B*x, */
+/* and B is typically made upper triangular by computing its QR */
+/* factorization and moving the unitary matrix Q to the left side */
+/* of the equation. */
+
+/* This subroutine simultaneously reduces A to a Hessenberg matrix H: */
+/* Q**H*A*Z = H */
+/* and transforms B to another upper triangular matrix T: */
+/* Q**H*B*Z = T */
+/* in order to reduce the problem to its standard form */
+/* H*y = lambda*T*y */
+/* where y = Z**H*x. */
+
+/* The unitary matrices Q and Z are determined as products of Givens */
+/* rotations. They may either be formed explicitly, or they may be */
+/* postmultiplied into input matrices Q1 and Z1, so that */
+/* Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H */
+/* Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H */
+/* If Q1 is the unitary matrix from the QR factorization of B in the */
+/* original equation A*x = lambda*B*x, then ZGGHRD reduces the original */
+/* problem to generalized Hessenberg form. */
+
+/* Arguments */
+/* ========= */
+
+/* COMPQ (input) CHARACTER*1 */
+/* = 'N': do not compute Q; */
+/* = 'I': Q is initialized to the unit matrix, and the */
+/* unitary matrix Q is returned; */
+/* = 'V': Q must contain a unitary matrix Q1 on entry, */
+/* and the product Q1*Q is returned. */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': do not compute Q; */
+/* = 'I': Q is initialized to the unit matrix, and the */
+/* unitary matrix Q is returned; */
+/* = 'V': Q must contain a unitary matrix Q1 on entry, */
+/* and the product Q1*Q is returned. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* ILO and IHI mark the rows and columns of A which are to be */
+/* reduced. It is assumed that A is already upper triangular */
+/* in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are */
+/* normally set by a previous call to ZGGBAL; otherwise they */
+/* should be set to 1 and N respectively. */
+/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA, N) */
+/* On entry, the N-by-N general matrix to be reduced. */
+/* On exit, the upper triangle and the first subdiagonal of A */
+/* are overwritten with the upper Hessenberg matrix H, and the */
+/* rest is set to zero. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB, N) */
+/* On entry, the N-by-N upper triangular matrix B. */
+/* On exit, the upper triangular matrix T = Q**H B Z. The */
+/* elements below the diagonal are set to zero. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Q (input/output) COMPLEX*16 array, dimension (LDQ, N) */
+/* On entry, if COMPQ = 'V', the unitary matrix Q1, typically */
+/* from the QR factorization of B. */
+/* On exit, if COMPQ='I', the unitary matrix Q, and if */
+/* COMPQ = 'V', the product Q1*Q. */
+/* Not referenced if COMPQ='N'. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. */
+/* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise. */
+
+/* Z (input/output) COMPLEX*16 array, dimension (LDZ, N) */
+/* On entry, if COMPZ = 'V', the unitary matrix Z1. */
+/* On exit, if COMPZ='I', the unitary matrix Z, and if */
+/* COMPZ = 'V', the product Z1*Z. */
+/* Not referenced if COMPZ='N'. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. */
+/* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* This routine reduces A to Hessenberg and B to triangular form by */
+/* an unblocked reduction, as described in _Matrix_Computations_, */
+/* by Golub and van Loan (Johns Hopkins Press). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode COMPQ */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+
+ /* Function Body */
+ if (lsame_(compq, "N")) {
+ ilq = FALSE_;
+ icompq = 1;
+ } else if (lsame_(compq, "V")) {
+ ilq = TRUE_;
+ icompq = 2;
+ } else if (lsame_(compq, "I")) {
+ ilq = TRUE_;
+ icompq = 3;
+ } else {
+ icompq = 0;
+ }
+
+/* Decode COMPZ */
+
+ if (lsame_(compz, "N")) {
+ ilz = FALSE_;
+ icompz = 1;
+ } else if (lsame_(compz, "V")) {
+ ilz = TRUE_;
+ icompz = 2;
+ } else if (lsame_(compz, "I")) {
+ ilz = TRUE_;
+ icompz = 3;
+ } else {
+ icompz = 0;
+ }
+
+/* Test the input parameters. */
+
+ *info = 0;
+ if (icompq <= 0) {
+ *info = -1;
+ } else if (icompz <= 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ilo < 1) {
+ *info = -4;
+ } else if (*ihi > *n || *ihi < *ilo - 1) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (ilq && *ldq < *n || *ldq < 1) {
+ *info = -11;
+ } else if (ilz && *ldz < *n || *ldz < 1) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGGHRD", &i__1);
+ return 0;
+ }
+
+/* Initialize Q and Z if desired. */
+
+ if (icompq == 3) {
+ zlaset_("Full", n, n, &c_b2, &c_b1, &q[q_offset], ldq);
+ }
+ if (icompz == 3) {
+ zlaset_("Full", n, n, &c_b2, &c_b1, &z__[z_offset], ldz);
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 1) {
+ return 0;
+ }
+
+/* Zero out lower triangle of B */
+
+ i__1 = *n - 1;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ i__2 = *n;
+ for (jrow = jcol + 1; jrow <= i__2; ++jrow) {
+ i__3 = jrow + jcol * b_dim1;
+ b[i__3].r = 0., b[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Reduce A and B */
+
+ i__1 = *ihi - 2;
+ for (jcol = *ilo; jcol <= i__1; ++jcol) {
+
+ i__2 = jcol + 2;
+ for (jrow = *ihi; jrow >= i__2; --jrow) {
+
+/* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL) */
+
+ i__3 = jrow - 1 + jcol * a_dim1;
+ ctemp.r = a[i__3].r, ctemp.i = a[i__3].i;
+ zlartg_(&ctemp, &a[jrow + jcol * a_dim1], &c__, &s, &a[jrow - 1 +
+ jcol * a_dim1]);
+ i__3 = jrow + jcol * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ i__3 = *n - jcol;
+ zrot_(&i__3, &a[jrow - 1 + (jcol + 1) * a_dim1], lda, &a[jrow + (
+ jcol + 1) * a_dim1], lda, &c__, &s);
+ i__3 = *n + 2 - jrow;
+ zrot_(&i__3, &b[jrow - 1 + (jrow - 1) * b_dim1], ldb, &b[jrow + (
+ jrow - 1) * b_dim1], ldb, &c__, &s);
+ if (ilq) {
+ d_cnjg(&z__1, &s);
+ zrot_(n, &q[(jrow - 1) * q_dim1 + 1], &c__1, &q[jrow * q_dim1
+ + 1], &c__1, &c__, &z__1);
+ }
+
+/* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1) */
+
+ i__3 = jrow + jrow * b_dim1;
+ ctemp.r = b[i__3].r, ctemp.i = b[i__3].i;
+ zlartg_(&ctemp, &b[jrow + (jrow - 1) * b_dim1], &c__, &s, &b[jrow
+ + jrow * b_dim1]);
+ i__3 = jrow + (jrow - 1) * b_dim1;
+ b[i__3].r = 0., b[i__3].i = 0.;
+ zrot_(ihi, &a[jrow * a_dim1 + 1], &c__1, &a[(jrow - 1) * a_dim1 +
+ 1], &c__1, &c__, &s);
+ i__3 = jrow - 1;
+ zrot_(&i__3, &b[jrow * b_dim1 + 1], &c__1, &b[(jrow - 1) * b_dim1
+ + 1], &c__1, &c__, &s);
+ if (ilz) {
+ zrot_(n, &z__[jrow * z_dim1 + 1], &c__1, &z__[(jrow - 1) *
+ z_dim1 + 1], &c__1, &c__, &s);
+ }
+/* L30: */
+ }
+/* L40: */
+ }
+
+ return 0;
+
+/* End of ZGGHRD */
+
+} /* zgghrd_ */
diff --git a/SRC/zgglse.c b/SRC/zgglse.c
new file mode 100644
index 0000000..065663e
--- /dev/null
+++ b/SRC/zgglse.c
@@ -0,0 +1,346 @@
+/* zgglse.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zgglse_(integer *m, integer *n, integer *p,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *c__, doublecomplex *d__, doublecomplex *x,
+ doublecomplex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer nb, mn, nr, nb1, nb2, nb3, nb4, lopt;
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *), ztrmv_(char *, char *,
+ char *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zggrqf_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *)
+ ;
+ integer lwkmin, lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int zunmqr_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *), zunmrq_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *), ztrtrs_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGGLSE solves the linear equality-constrained least squares (LSE) */
+/* problem: */
+
+/* minimize || c - A*x ||_2 subject to B*x = d */
+
+/* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given */
+/* M-vector, and d is a given P-vector. It is assumed that */
+/* P <= N <= M+P, and */
+
+/* rank(B) = P and rank( ( A ) ) = N. */
+/* ( ( B ) ) */
+
+/* These conditions ensure that the LSE problem has a unique solution, */
+/* which is obtained using a generalized RQ factorization of the */
+/* matrices (B, A) given by */
+
+/* B = (0 R)*Q, A = Z*T*Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. 0 <= P <= N <= M+P. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(M,N)-by-N upper trapezoidal matrix T. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix B. */
+/* On exit, the upper triangle of the subarray B(1:P,N-P+1:N) */
+/* contains the P-by-P upper triangular matrix R. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,P). */
+
+/* C (input/output) COMPLEX*16 array, dimension (M) */
+/* On entry, C contains the right hand side vector for the */
+/* least squares part of the LSE problem. */
+/* On exit, the residual sum of squares for the solution */
+/* is given by the sum of squares of elements N-P+1 to M of */
+/* vector C. */
+
+/* D (input/output) COMPLEX*16 array, dimension (P) */
+/* On entry, D contains the right hand side vector for the */
+/* constrained equation. */
+/* On exit, D is destroyed. */
+
+/* X (output) COMPLEX*16 array, dimension (N) */
+/* On exit, X is the solution of the LSE problem. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M+N+P). */
+/* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB, */
+/* where NB is an upper bound for the optimal blocksizes for */
+/* ZGEQRF, CGERQF, ZUNMQR and CUNMRQ. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1: the upper triangular factor R associated with B in the */
+/* generalized RQ factorization of the pair (B, A) is */
+/* singular, so that rank(B) < P; the least squares */
+/* solution could not be computed. */
+/* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor */
+/* T associated with A in the generalized RQ factorization */
+/* of the pair (B, A) is singular, so that */
+/* rank( (A) ) < N; the least squares solution could not */
+/* ( (B) ) */
+/* be computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --c__;
+ --d__;
+ --x;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ mn = min(*m,*n);
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*p < 0 || *p > *n || *p < *n - *m) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*p)) {
+ *info = -7;
+ }
+
+/* Calculate workspace */
+
+ if (*info == 0) {
+ if (*n == 0) {
+ lwkmin = 1;
+ lwkopt = 1;
+ } else {
+ nb1 = ilaenv_(&c__1, "ZGEQRF", " ", m, n, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "ZGERQF", " ", m, n, &c_n1, &c_n1);
+ nb3 = ilaenv_(&c__1, "ZUNMQR", " ", m, n, p, &c_n1);
+ nb4 = ilaenv_(&c__1, "ZUNMRQ", " ", m, n, p, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2), i__1 = max(i__1,nb3);
+ nb = max(i__1,nb4);
+ lwkmin = *m + *n + *p;
+ lwkopt = *p + mn + max(*m,*n) * nb;
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ if (*lwork < lwkmin && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGGLSE", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Compute the GRQ factorization of matrices B and A: */
+
+/* B*Q' = ( 0 T12 ) P Z'*A*Q' = ( R11 R12 ) N-P */
+/* N-P P ( 0 R22 ) M+P-N */
+/* N-P P */
+
+/* where T12 and R11 are upper triangular, and Q and Z are */
+/* unitary. */
+
+ i__1 = *lwork - *p - mn;
+ zggrqf_(p, m, n, &b[b_offset], ldb, &work[1], &a[a_offset], lda, &work[*p
+ + 1], &work[*p + mn + 1], &i__1, info);
+ i__1 = *p + mn + 1;
+ lopt = (integer) work[i__1].r;
+
+/* Update c = Z'*c = ( c1 ) N-P */
+/* ( c2 ) M+P-N */
+
+ i__1 = max(1,*m);
+ i__2 = *lwork - *p - mn;
+ zunmqr_("Left", "Conjugate Transpose", m, &c__1, &mn, &a[a_offset], lda, &
+ work[*p + 1], &c__[1], &i__1, &work[*p + mn + 1], &i__2, info);
+/* Computing MAX */
+ i__3 = *p + mn + 1;
+ i__1 = lopt, i__2 = (integer) work[i__3].r;
+ lopt = max(i__1,i__2);
+
+/* Solve T12*x2 = d for x2 */
+
+ if (*p > 0) {
+ ztrtrs_("Upper", "No transpose", "Non-unit", p, &c__1, &b[(*n - *p +
+ 1) * b_dim1 + 1], ldb, &d__[1], p, info);
+
+ if (*info > 0) {
+ *info = 1;
+ return 0;
+ }
+
+/* Put the solution in X */
+
+ zcopy_(p, &d__[1], &c__1, &x[*n - *p + 1], &c__1);
+
+/* Update c1 */
+
+ i__1 = *n - *p;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__1, p, &z__1, &a[(*n - *p + 1) * a_dim1 + 1]
+, lda, &d__[1], &c__1, &c_b1, &c__[1], &c__1);
+ }
+
+/* Solve R11*x1 = c1 for x1 */
+
+ if (*n > *p) {
+ i__1 = *n - *p;
+ i__2 = *n - *p;
+ ztrtrs_("Upper", "No transpose", "Non-unit", &i__1, &c__1, &a[
+ a_offset], lda, &c__[1], &i__2, info);
+
+ if (*info > 0) {
+ *info = 2;
+ return 0;
+ }
+
+/* Put the solutions in X */
+
+ i__1 = *n - *p;
+ zcopy_(&i__1, &c__[1], &c__1, &x[1], &c__1);
+ }
+
+/* Compute the residual vector: */
+
+ if (*m < *n) {
+ nr = *m + *p - *n;
+ if (nr > 0) {
+ i__1 = *n - *m;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &nr, &i__1, &z__1, &a[*n - *p + 1 + (*m +
+ 1) * a_dim1], lda, &d__[nr + 1], &c__1, &c_b1, &c__[*n - *
+ p + 1], &c__1);
+ }
+ } else {
+ nr = *p;
+ }
+ if (nr > 0) {
+ ztrmv_("Upper", "No transpose", "Non unit", &nr, &a[*n - *p + 1 + (*n
+ - *p + 1) * a_dim1], lda, &d__[1], &c__1);
+ z__1.r = -1., z__1.i = -0.;
+ zaxpy_(&nr, &z__1, &d__[1], &c__1, &c__[*n - *p + 1], &c__1);
+ }
+
+/* Backward transformation x = Q'*x */
+
+ i__1 = *lwork - *p - mn;
+ zunmrq_("Left", "Conjugate Transpose", n, &c__1, p, &b[b_offset], ldb, &
+ work[1], &x[1], n, &work[*p + mn + 1], &i__1, info);
+/* Computing MAX */
+ i__4 = *p + mn + 1;
+ i__2 = lopt, i__3 = (integer) work[i__4].r;
+ i__1 = *p + mn + max(i__2,i__3);
+ work[1].r = (doublereal) i__1, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZGGLSE */
+
+} /* zgglse_ */
diff --git a/SRC/zggqrf.c b/SRC/zggqrf.c
new file mode 100644
index 0000000..dcd18a8
--- /dev/null
+++ b/SRC/zggqrf.c
@@ -0,0 +1,270 @@
+/* zggqrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zggqrf_(integer *n, integer *m, integer *p,
+ doublecomplex *a, integer *lda, doublecomplex *taua, doublecomplex *b,
+ integer *ldb, doublecomplex *taub, doublecomplex *work, integer *
+ lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer nb, nb1, nb2, nb3, lopt;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zgeqrf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *
+), zgerqf_(integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int zunmqr_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGGQRF computes a generalized QR factorization of an N-by-M matrix A */
+/* and an N-by-P matrix B: */
+
+/* A = Q*R, B = Q*T*Z, */
+
+/* where Q is an N-by-N unitary matrix, Z is a P-by-P unitary matrix, */
+/* and R and T assume one of the forms: */
+
+/* if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N, */
+/* ( 0 ) N-M N M-N */
+/* M */
+
+/* where R11 is upper triangular, and */
+
+/* if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P, */
+/* P-N N ( T21 ) P */
+/* P */
+
+/* where T12 or T21 is upper triangular. */
+
+/* In particular, if B is square and nonsingular, the GQR factorization */
+/* of A and B implicitly gives the QR factorization of inv(B)*A: */
+
+/* inv(B)*A = Z'*(inv(T)*R) */
+
+/* where inv(B) denotes the inverse of the matrix B, and Z' denotes the */
+/* conjugate transpose of matrix Z. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices A and B. N >= 0. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of columns of the matrix B. P >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,M) */
+/* On entry, the N-by-M matrix A. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(N,M)-by-M upper trapezoidal matrix R (R is */
+/* upper triangular if N >= M); the elements below the diagonal, */
+/* with the array TAUA, represent the unitary matrix Q as a */
+/* product of min(N,M) elementary reflectors (see Further */
+/* Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAUA (output) COMPLEX*16 array, dimension (min(N,M)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the unitary matrix Q (see Further Details). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,P) */
+/* On entry, the N-by-P matrix B. */
+/* On exit, if N <= P, the upper triangle of the subarray */
+/* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T; */
+/* if N > P, the elements on and above the (N-P)-th subdiagonal */
+/* contain the N-by-P upper trapezoidal matrix T; the remaining */
+/* elements, with the array TAUB, represent the unitary */
+/* matrix Z as a product of elementary reflectors (see Further */
+/* Details). */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* TAUB (output) COMPLEX*16 array, dimension (min(N,P)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the unitary matrix Z (see Further Details). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N,M,P). */
+/* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3), */
+/* where NB1 is the optimal blocksize for the QR factorization */
+/* of an N-by-M matrix, NB2 is the optimal blocksize for the */
+/* RQ factorization of an N-by-P matrix, and NB3 is the optimal */
+/* blocksize for a call of ZUNMQR. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(n,m). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - taua * v * v' */
+
+/* where taua is a complex scalar, and v is a complex vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */
+/* and taua in TAUA(i). */
+/* To form Q explicitly, use LAPACK subroutine ZUNGQR. */
+/* To use Q to update another matrix, use LAPACK subroutine ZUNMQR. */
+
+/* The matrix Z is represented as a product of elementary reflectors */
+
+/* Z = H(1) H(2) . . . H(k), where k = min(n,p). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - taub * v * v' */
+
+/* where taub is a complex scalar, and v is a complex vector with */
+/* v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in */
+/* B(n-k+i,1:p-k+i-1), and taub in TAUB(i). */
+/* To form Z explicitly, use LAPACK subroutine ZUNGRQ. */
+/* To use Z to update another matrix, use LAPACK subroutine ZUNMRQ. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --taua;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --taub;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb1 = ilaenv_(&c__1, "ZGEQRF", " ", n, m, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "ZGERQF", " ", n, p, &c_n1, &c_n1);
+ nb3 = ilaenv_(&c__1, "ZUNMQR", " ", n, m, p, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2);
+ nb = max(i__1,nb3);
+/* Computing MAX */
+ i__1 = max(*n,*m);
+ lwkopt = max(i__1,*p) * nb;
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ lquery = *lwork == -1;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*p < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*n), i__1 = max(i__1,*m);
+ if (*lwork < max(i__1,*p) && ! lquery) {
+ *info = -11;
+ }
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGGQRF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* QR factorization of N-by-M matrix A: A = Q*R */
+
+ zgeqrf_(n, m, &a[a_offset], lda, &taua[1], &work[1], lwork, info);
+ lopt = (integer) work[1].r;
+
+/* Update B := Q'*B. */
+
+ i__1 = min(*n,*m);
+ zunmqr_("Left", "Conjugate Transpose", n, p, &i__1, &a[a_offset], lda, &
+ taua[1], &b[b_offset], ldb, &work[1], lwork, info);
+/* Computing MAX */
+ i__1 = lopt, i__2 = (integer) work[1].r;
+ lopt = max(i__1,i__2);
+
+/* RQ factorization of N-by-P matrix B: B = T*Z. */
+
+ zgerqf_(n, p, &b[b_offset], ldb, &taub[1], &work[1], lwork, info);
+/* Computing MAX */
+ i__2 = lopt, i__3 = (integer) work[1].r;
+ i__1 = max(i__2,i__3);
+ work[1].r = (doublereal) i__1, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZGGQRF */
+
+} /* zggqrf_ */
diff --git a/SRC/zggrqf.c b/SRC/zggrqf.c
new file mode 100644
index 0000000..bc3c559
--- /dev/null
+++ b/SRC/zggrqf.c
@@ -0,0 +1,271 @@
+/* zggrqf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zggrqf_(integer *m, integer *p, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *taua, doublecomplex *b,
+ integer *ldb, doublecomplex *taub, doublecomplex *work, integer *
+ lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer nb, nb1, nb2, nb3, lopt;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zgeqrf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *
+), zgerqf_(integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int zunmrq_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGGRQF computes a generalized RQ factorization of an M-by-N matrix A */
+/* and a P-by-N matrix B: */
+
+/* A = R*Q, B = Z*T*Q, */
+
+/* where Q is an N-by-N unitary matrix, Z is a P-by-P unitary */
+/* matrix, and R and T assume one of the forms: */
+
+/* if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N, */
+/* N-M M ( R21 ) N */
+/* N */
+
+/* where R12 or R21 is upper triangular, and */
+
+/* if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P, */
+/* ( 0 ) P-N P N-P */
+/* N */
+
+/* where T11 is upper triangular. */
+
+/* In particular, if B is square and nonsingular, the GRQ factorization */
+/* of A and B implicitly gives the RQ factorization of A*inv(B): */
+
+/* A*inv(B) = (R*inv(T))*Z' */
+
+/* where inv(B) denotes the inverse of the matrix B, and Z' denotes the */
+/* conjugate transpose of the matrix Z. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, if M <= N, the upper triangle of the subarray */
+/* A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R; */
+/* if M > N, the elements on and above the (M-N)-th subdiagonal */
+/* contain the M-by-N upper trapezoidal matrix R; the remaining */
+/* elements, with the array TAUA, represent the unitary */
+/* matrix Q as a product of elementary reflectors (see Further */
+/* Details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAUA (output) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the unitary matrix Q (see Further Details). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix B. */
+/* On exit, the elements on and above the diagonal of the array */
+/* contain the min(P,N)-by-N upper trapezoidal matrix T (T is */
+/* upper triangular if P >= N); the elements below the diagonal, */
+/* with the array TAUB, represent the unitary matrix Z as a */
+/* product of elementary reflectors (see Further Details). */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,P). */
+
+/* TAUB (output) COMPLEX*16 array, dimension (min(P,N)) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the unitary matrix Z (see Further Details). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N,M,P). */
+/* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3), */
+/* where NB1 is the optimal blocksize for the RQ factorization */
+/* of an M-by-N matrix, NB2 is the optimal blocksize for the */
+/* QR factorization of a P-by-N matrix, and NB3 is the optimal */
+/* blocksize for a call of ZUNMRQ. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO=-i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - taua * v * v' */
+
+/* where taua is a complex scalar, and v is a complex vector with */
+/* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in */
+/* A(m-k+i,1:n-k+i-1), and taua in TAUA(i). */
+/* To form Q explicitly, use LAPACK subroutine ZUNGRQ. */
+/* To use Q to update another matrix, use LAPACK subroutine ZUNMRQ. */
+
+/* The matrix Z is represented as a product of elementary reflectors */
+
+/* Z = H(1) H(2) . . . H(k), where k = min(p,n). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - taub * v * v' */
+
+/* where taub is a complex scalar, and v is a complex vector with */
+/* v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i), */
+/* and taub in TAUB(i). */
+/* To form Z explicitly, use LAPACK subroutine ZUNGQR. */
+/* To use Z to update another matrix, use LAPACK subroutine ZUNMQR. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --taua;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --taub;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb1 = ilaenv_(&c__1, "ZGERQF", " ", m, n, &c_n1, &c_n1);
+ nb2 = ilaenv_(&c__1, "ZGEQRF", " ", p, n, &c_n1, &c_n1);
+ nb3 = ilaenv_(&c__1, "ZUNMRQ", " ", m, n, p, &c_n1);
+/* Computing MAX */
+ i__1 = max(nb1,nb2);
+ nb = max(i__1,nb3);
+/* Computing MAX */
+ i__1 = max(*n,*m);
+ lwkopt = max(i__1,*p) * nb;
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*p < 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*p)) {
+ *info = -8;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = max(1,*m), i__1 = max(i__1,*p);
+ if (*lwork < max(i__1,*n) && ! lquery) {
+ *info = -11;
+ }
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGGRQF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* RQ factorization of M-by-N matrix A: A = R*Q */
+
+ zgerqf_(m, n, &a[a_offset], lda, &taua[1], &work[1], lwork, info);
+ lopt = (integer) work[1].r;
+
+/* Update B := B*Q' */
+
+ i__1 = min(*m,*n);
+/* Computing MAX */
+ i__2 = 1, i__3 = *m - *n + 1;
+ zunmrq_("Right", "Conjugate Transpose", p, n, &i__1, &a[max(i__2, i__3)+
+ a_dim1], lda, &taua[1], &b[b_offset], ldb, &work[1], lwork, info);
+/* Computing MAX */
+ i__1 = lopt, i__2 = (integer) work[1].r;
+ lopt = max(i__1,i__2);
+
+/* QR factorization of P-by-N matrix B: B = Z*T */
+
+ zgeqrf_(p, n, &b[b_offset], ldb, &taub[1], &work[1], lwork, info);
+/* Computing MAX */
+ i__2 = lopt, i__3 = (integer) work[1].r;
+ i__1 = max(i__2,i__3);
+ work[1].r = (doublereal) i__1, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZGGRQF */
+
+} /* zggrqf_ */
diff --git a/SRC/zggsvd.c b/SRC/zggsvd.c
new file mode 100644
index 0000000..00bf0e5
--- /dev/null
+++ b/SRC/zggsvd.c
@@ -0,0 +1,407 @@
+/* zggsvd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zggsvd_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *n, integer *p, integer *k, integer *l, doublecomplex *a,
+ integer *lda, doublecomplex *b, integer *ldb, doublereal *alpha,
+ doublereal *beta, doublecomplex *u, integer *ldu, doublecomplex *v,
+ integer *ldv, doublecomplex *q, integer *ldq, doublecomplex *work,
+ doublereal *rwork, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1,
+ u_offset, v_dim1, v_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal ulp;
+ integer ibnd;
+ doublereal tola;
+ integer isub;
+ doublereal tolb, unfl, temp, smax;
+ extern logical lsame_(char *, char *);
+ doublereal anorm, bnorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical wantq, wantu, wantv;
+ extern doublereal dlamch_(char *);
+ integer ncycle;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int ztgsja_(char *, char *, char *, integer *,
+ integer *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *),
+ zggsvp_(char *, char *, char *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *
+, integer *, doublereal *, doublecomplex *, doublecomplex *,
+ integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGGSVD computes the generalized singular value decomposition (GSVD) */
+/* of an M-by-N complex matrix A and P-by-N complex matrix B: */
+
+/* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ) */
+
+/* where U, V and Q are unitary matrices, and Z' means the conjugate */
+/* transpose of Z. Let K+L = the effective numerical rank of the */
+/* matrix (A',B')', then R is a (K+L)-by-(K+L) nonsingular upper */
+/* triangular matrix, D1 and D2 are M-by-(K+L) and P-by-(K+L) "diagonal" */
+/* matrices and of the following structures, respectively: */
+
+/* If M-K-L >= 0, */
+
+/* K L */
+/* D1 = K ( I 0 ) */
+/* L ( 0 C ) */
+/* M-K-L ( 0 0 ) */
+
+/* K L */
+/* D2 = L ( 0 S ) */
+/* P-L ( 0 0 ) */
+
+/* N-K-L K L */
+/* ( 0 R ) = K ( 0 R11 R12 ) */
+/* L ( 0 0 R22 ) */
+/* where */
+
+/* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */
+/* S = diag( BETA(K+1), ... , BETA(K+L) ), */
+/* C**2 + S**2 = I. */
+
+/* R is stored in A(1:K+L,N-K-L+1:N) on exit. */
+
+/* If M-K-L < 0, */
+
+/* K M-K K+L-M */
+/* D1 = K ( I 0 0 ) */
+/* M-K ( 0 C 0 ) */
+
+/* K M-K K+L-M */
+/* D2 = M-K ( 0 S 0 ) */
+/* K+L-M ( 0 0 I ) */
+/* P-L ( 0 0 0 ) */
+
+/* N-K-L K M-K K+L-M */
+/* ( 0 R ) = K ( 0 R11 R12 R13 ) */
+/* M-K ( 0 0 R22 R23 ) */
+/* K+L-M ( 0 0 0 R33 ) */
+
+/* where */
+
+/* C = diag( ALPHA(K+1), ... , ALPHA(M) ), */
+/* S = diag( BETA(K+1), ... , BETA(M) ), */
+/* C**2 + S**2 = I. */
+
+/* (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored */
+/* ( 0 R22 R23 ) */
+/* in B(M-K+1:L,N+M-K-L+1:N) on exit. */
+
+/* The routine computes C, S, R, and optionally the unitary */
+/* transformation matrices U, V and Q. */
+
+/* In particular, if B is an N-by-N nonsingular matrix, then the GSVD of */
+/* A and B implicitly gives the SVD of A*inv(B): */
+/* A*inv(B) = U*(D1*inv(D2))*V'. */
+/* If ( A',B')' has orthnormal columns, then the GSVD of A and B is also */
+/* equal to the CS decomposition of A and B. Furthermore, the GSVD can */
+/* be used to derive the solution of the eigenvalue problem: */
+/* A'*A x = lambda* B'*B x. */
+/* In some literature, the GSVD of A and B is presented in the form */
+/* U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 ) */
+/* where U and V are orthogonal and X is nonsingular, and D1 and D2 are */
+/* ``diagonal''. The former GSVD form can be converted to the latter */
+/* form by taking the nonsingular matrix X as */
+
+/* X = Q*( I 0 ) */
+/* ( 0 inv(R) ) */
+
+/* Arguments */
+/* ========= */
+
+/* JOBU (input) CHARACTER*1 */
+/* = 'U': Unitary matrix U is computed; */
+/* = 'N': U is not computed. */
+
+/* JOBV (input) CHARACTER*1 */
+/* = 'V': Unitary matrix V is computed; */
+/* = 'N': V is not computed. */
+
+/* JOBQ (input) CHARACTER*1 */
+/* = 'Q': Unitary matrix Q is computed; */
+/* = 'N': Q is not computed. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* K (output) INTEGER */
+/* L (output) INTEGER */
+/* On exit, K and L specify the dimension of the subblocks */
+/* described in Purpose. */
+/* K + L = effective numerical rank of (A',B')'. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A contains the triangular matrix R, or part of R. */
+/* See Purpose for details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix B. */
+/* On exit, B contains part of the triangular matrix R if */
+/* M-K-L < 0. See Purpose for details. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,P). */
+
+/* ALPHA (output) DOUBLE PRECISION array, dimension (N) */
+/* BETA (output) DOUBLE PRECISION array, dimension (N) */
+/* On exit, ALPHA and BETA contain the generalized singular */
+/* value pairs of A and B; */
+/* ALPHA(1:K) = 1, */
+/* BETA(1:K) = 0, */
+/* and if M-K-L >= 0, */
+/* ALPHA(K+1:K+L) = C, */
+/* BETA(K+1:K+L) = S, */
+/* or if M-K-L < 0, */
+/* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0 */
+/* BETA(K+1:M) = S, BETA(M+1:K+L) = 1 */
+/* and */
+/* ALPHA(K+L+1:N) = 0 */
+/* BETA(K+L+1:N) = 0 */
+
+/* U (output) COMPLEX*16 array, dimension (LDU,M) */
+/* If JOBU = 'U', U contains the M-by-M unitary matrix U. */
+/* If JOBU = 'N', U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M) if */
+/* JOBU = 'U'; LDU >= 1 otherwise. */
+
+/* V (output) COMPLEX*16 array, dimension (LDV,P) */
+/* If JOBV = 'V', V contains the P-by-P unitary matrix V. */
+/* If JOBV = 'N', V is not referenced. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. LDV >= max(1,P) if */
+/* JOBV = 'V'; LDV >= 1 otherwise. */
+
+/* Q (output) COMPLEX*16 array, dimension (LDQ,N) */
+/* If JOBQ = 'Q', Q contains the N-by-N unitary matrix Q. */
+/* If JOBQ = 'N', Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N) if */
+/* JOBQ = 'Q'; LDQ >= 1 otherwise. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (max(3*N,M,P)+N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* IWORK (workspace/output) INTEGER array, dimension (N) */
+/* On exit, IWORK stores the sorting information. More */
+/* precisely, the following loop will sort ALPHA */
+/* for I = K+1, min(M,K+L) */
+/* swap ALPHA(I) and ALPHA(IWORK(I)) */
+/* endfor */
+/* such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, the Jacobi-type procedure failed to */
+/* converge. For further details, see subroutine ZTGSJA. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* TOLA DOUBLE PRECISION */
+/* TOLB DOUBLE PRECISION */
+/* TOLA and TOLB are the thresholds to determine the effective */
+/* rank of (A',B')'. Generally, they are set to */
+/* TOLA = MAX(M,N)*norm(A)*MAZHEPS, */
+/* TOLB = MAX(P,N)*norm(B)*MAZHEPS. */
+/* The size of TOLA and TOLB may affect the size of backward */
+/* errors of the decomposition. */
+
+/* Further Details */
+/* =============== */
+
+/* 2-96 Based on modifications by */
+/* Ming Gu and Huan Ren, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alpha;
+ --beta;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ wantu = lsame_(jobu, "U");
+ wantv = lsame_(jobv, "V");
+ wantq = lsame_(jobq, "Q");
+
+ *info = 0;
+ if (! (wantu || lsame_(jobu, "N"))) {
+ *info = -1;
+ } else if (! (wantv || lsame_(jobv, "N"))) {
+ *info = -2;
+ } else if (! (wantq || lsame_(jobq, "N"))) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*p < 0) {
+ *info = -6;
+ } else if (*lda < max(1,*m)) {
+ *info = -10;
+ } else if (*ldb < max(1,*p)) {
+ *info = -12;
+ } else if (*ldu < 1 || wantu && *ldu < *m) {
+ *info = -16;
+ } else if (*ldv < 1 || wantv && *ldv < *p) {
+ *info = -18;
+ } else if (*ldq < 1 || wantq && *ldq < *n) {
+ *info = -20;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGGSVD", &i__1);
+ return 0;
+ }
+
+/* Compute the Frobenius norm of matrices A and B */
+
+ anorm = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ bnorm = zlange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
+
+/* Get machine precision and set up threshold for determining */
+/* the effective numerical rank of the matrices A and B. */
+
+ ulp = dlamch_("Precision");
+ unfl = dlamch_("Safe Minimum");
+ tola = max(*m,*n) * max(anorm,unfl) * ulp;
+ tolb = max(*p,*n) * max(bnorm,unfl) * ulp;
+
+ zggsvp_(jobu, jobv, jobq, m, p, n, &a[a_offset], lda, &b[b_offset], ldb, &
+ tola, &tolb, k, l, &u[u_offset], ldu, &v[v_offset], ldv, &q[
+ q_offset], ldq, &iwork[1], &rwork[1], &work[1], &work[*n + 1],
+ info);
+
+/* Compute the GSVD of two upper "triangular" matrices */
+
+ ztgsja_(jobu, jobv, jobq, m, p, n, k, l, &a[a_offset], lda, &b[b_offset],
+ ldb, &tola, &tolb, &alpha[1], &beta[1], &u[u_offset], ldu, &v[
+ v_offset], ldv, &q[q_offset], ldq, &work[1], &ncycle, info);
+
+/* Sort the singular values and store the pivot indices in IWORK */
+/* Copy ALPHA to RWORK, then sort ALPHA in RWORK */
+
+ dcopy_(n, &alpha[1], &c__1, &rwork[1], &c__1);
+/* Computing MIN */
+ i__1 = *l, i__2 = *m - *k;
+ ibnd = min(i__1,i__2);
+ i__1 = ibnd;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Scan for largest ALPHA(K+I) */
+
+ isub = i__;
+ smax = rwork[*k + i__];
+ i__2 = ibnd;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ temp = rwork[*k + j];
+ if (temp > smax) {
+ isub = j;
+ smax = temp;
+ }
+/* L10: */
+ }
+ if (isub != i__) {
+ rwork[*k + isub] = rwork[*k + i__];
+ rwork[*k + i__] = smax;
+ iwork[*k + i__] = *k + isub;
+ } else {
+ iwork[*k + i__] = *k + i__;
+ }
+/* L20: */
+ }
+
+ return 0;
+
+/* End of ZGGSVD */
+
+} /* zggsvd_ */
diff --git a/SRC/zggsvp.c b/SRC/zggsvp.c
new file mode 100644
index 0000000..e323ba6
--- /dev/null
+++ b/SRC/zggsvp.c
@@ -0,0 +1,533 @@
+/* zggsvp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+
+/* Subroutine */ int zggsvp_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *p, integer *n, doublecomplex *a, integer *lda, doublecomplex
+ *b, integer *ldb, doublereal *tola, doublereal *tolb, integer *k,
+ integer *l, doublecomplex *u, integer *ldu, doublecomplex *v, integer
+ *ldv, doublecomplex *q, integer *ldq, integer *iwork, doublereal *
+ rwork, doublecomplex *tau, doublecomplex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1,
+ u_offset, v_dim1, v_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ extern logical lsame_(char *, char *);
+ logical wantq, wantu, wantv;
+ extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *), zgerq2_(
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *), zung2r_(integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *), zunm2r_(char *, char *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), zunmr2_(char *, char *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *), xerbla_(
+ char *, integer *), zgeqpf_(integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *);
+ logical forwrd;
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlapmt_(logical *, integer *, integer *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGGSVP computes unitary matrices U, V and Q such that */
+
+/* N-K-L K L */
+/* U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0; */
+/* L ( 0 0 A23 ) */
+/* M-K-L ( 0 0 0 ) */
+
+/* N-K-L K L */
+/* = K ( 0 A12 A13 ) if M-K-L < 0; */
+/* M-K ( 0 0 A23 ) */
+
+/* N-K-L K L */
+/* V'*B*Q = L ( 0 0 B13 ) */
+/* P-L ( 0 0 0 ) */
+
+/* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */
+/* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */
+/* otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective */
+/* numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the */
+/* conjugate transpose of Z. */
+
+/* This decomposition is the preprocessing step for computing the */
+/* Generalized Singular Value Decomposition (GSVD), see subroutine */
+/* ZGGSVD. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBU (input) CHARACTER*1 */
+/* = 'U': Unitary matrix U is computed; */
+/* = 'N': U is not computed. */
+
+/* JOBV (input) CHARACTER*1 */
+/* = 'V': Unitary matrix V is computed; */
+/* = 'N': V is not computed. */
+
+/* JOBQ (input) CHARACTER*1 */
+/* = 'Q': Unitary matrix Q is computed; */
+/* = 'N': Q is not computed. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A contains the triangular (or trapezoidal) matrix */
+/* described in the Purpose section. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix B. */
+/* On exit, B contains the triangular matrix described in */
+/* the Purpose section. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,P). */
+
+/* TOLA (input) DOUBLE PRECISION */
+/* TOLB (input) DOUBLE PRECISION */
+/* TOLA and TOLB are the thresholds to determine the effective */
+/* numerical rank of matrix B and a subblock of A. Generally, */
+/* they are set to */
+/* TOLA = MAX(M,N)*norm(A)*MAZHEPS, */
+/* TOLB = MAX(P,N)*norm(B)*MAZHEPS. */
+/* The size of TOLA and TOLB may affect the size of backward */
+/* errors of the decomposition. */
+
+/* K (output) INTEGER */
+/* L (output) INTEGER */
+/* On exit, K and L specify the dimension of the subblocks */
+/* described in Purpose section. */
+/* K + L = effective numerical rank of (A',B')'. */
+
+/* U (output) COMPLEX*16 array, dimension (LDU,M) */
+/* If JOBU = 'U', U contains the unitary matrix U. */
+/* If JOBU = 'N', U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M) if */
+/* JOBU = 'U'; LDU >= 1 otherwise. */
+
+/* V (output) COMPLEX*16 array, dimension (LDV,P) */
+/* If JOBV = 'V', V contains the unitary matrix V. */
+/* If JOBV = 'N', V is not referenced. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. LDV >= max(1,P) if */
+/* JOBV = 'V'; LDV >= 1 otherwise. */
+
+/* Q (output) COMPLEX*16 array, dimension (LDQ,N) */
+/* If JOBQ = 'Q', Q contains the unitary matrix Q. */
+/* If JOBQ = 'N', Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N) if */
+/* JOBQ = 'Q'; LDQ >= 1 otherwise. */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* TAU (workspace) COMPLEX*16 array, dimension (N) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (max(3*N,M,P)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The subroutine uses LAPACK subroutine ZGEQPF for the QR factorization */
+/* with column pivoting to detect the effective numerical rank of the */
+/* a matrix. It may be replaced by a better rank determination strategy. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --iwork;
+ --rwork;
+ --tau;
+ --work;
+
+ /* Function Body */
+ wantu = lsame_(jobu, "U");
+ wantv = lsame_(jobv, "V");
+ wantq = lsame_(jobq, "Q");
+ forwrd = TRUE_;
+
+ *info = 0;
+ if (! (wantu || lsame_(jobu, "N"))) {
+ *info = -1;
+ } else if (! (wantv || lsame_(jobv, "N"))) {
+ *info = -2;
+ } else if (! (wantq || lsame_(jobq, "N"))) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*p < 0) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (*lda < max(1,*m)) {
+ *info = -8;
+ } else if (*ldb < max(1,*p)) {
+ *info = -10;
+ } else if (*ldu < 1 || wantu && *ldu < *m) {
+ *info = -16;
+ } else if (*ldv < 1 || wantv && *ldv < *p) {
+ *info = -18;
+ } else if (*ldq < 1 || wantq && *ldq < *n) {
+ *info = -20;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGGSVP", &i__1);
+ return 0;
+ }
+
+/* QR with column pivoting of B: B*P = V*( S11 S12 ) */
+/* ( 0 0 ) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ iwork[i__] = 0;
+/* L10: */
+ }
+ zgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], &rwork[1],
+ info);
+
+/* Update A := A*P */
+
+ zlapmt_(&forwrd, m, n, &a[a_offset], lda, &iwork[1]);
+
+/* Determine the effective rank of matrix B. */
+
+ *l = 0;
+ i__1 = min(*p,*n);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * b_dim1;
+ if ((d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[i__ + i__ *
+ b_dim1]), abs(d__2)) > *tolb) {
+ ++(*l);
+ }
+/* L20: */
+ }
+
+ if (wantv) {
+
+/* Copy the details of V, and form V. */
+
+ zlaset_("Full", p, p, &c_b1, &c_b1, &v[v_offset], ldv);
+ if (*p > 1) {
+ i__1 = *p - 1;
+ zlacpy_("Lower", &i__1, n, &b[b_dim1 + 2], ldb, &v[v_dim1 + 2],
+ ldv);
+ }
+ i__1 = min(*p,*n);
+ zung2r_(p, p, &i__1, &v[v_offset], ldv, &tau[1], &work[1], info);
+ }
+
+/* Clean up B */
+
+ i__1 = *l - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *l;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0., b[i__3].i = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+ if (*p > *l) {
+ i__1 = *p - *l;
+ zlaset_("Full", &i__1, n, &c_b1, &c_b1, &b[*l + 1 + b_dim1], ldb);
+ }
+
+ if (wantq) {
+
+/* Set Q = I and Update Q := Q*P */
+
+ zlaset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
+ zlapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]);
+ }
+
+ if (*p >= *l && *n != *l) {
+
+/* RQ factorization of ( S11 S12 ) = ( 0 S12 )*Z */
+
+ zgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info);
+
+/* Update A := A*Z' */
+
+ zunmr2_("Right", "Conjugate transpose", m, n, l, &b[b_offset], ldb, &
+ tau[1], &a[a_offset], lda, &work[1], info);
+ if (wantq) {
+
+/* Update Q := Q*Z' */
+
+ zunmr2_("Right", "Conjugate transpose", n, n, l, &b[b_offset],
+ ldb, &tau[1], &q[q_offset], ldq, &work[1], info);
+ }
+
+/* Clean up B */
+
+ i__1 = *n - *l;
+ zlaset_("Full", l, &i__1, &c_b1, &c_b1, &b[b_offset], ldb);
+ i__1 = *n;
+ for (j = *n - *l + 1; j <= i__1; ++j) {
+ i__2 = *l;
+ for (i__ = j - *n + *l + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0., b[i__3].i = 0.;
+/* L50: */
+ }
+/* L60: */
+ }
+
+ }
+
+/* Let N-L L */
+/* A = ( A11 A12 ) M, */
+
+/* then the following does the complete QR decomposition of A11: */
+
+/* A11 = U*( 0 T12 )*P1' */
+/* ( 0 0 ) */
+
+ i__1 = *n - *l;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ iwork[i__] = 0;
+/* L70: */
+ }
+ i__1 = *n - *l;
+ zgeqpf_(m, &i__1, &a[a_offset], lda, &iwork[1], &tau[1], &work[1], &rwork[
+ 1], info);
+
+/* Determine the effective rank of A11 */
+
+ *k = 0;
+/* Computing MIN */
+ i__2 = *m, i__3 = *n - *l;
+ i__1 = min(i__2,i__3);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ if ((d__1 = a[i__2].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + i__ *
+ a_dim1]), abs(d__2)) > *tola) {
+ ++(*k);
+ }
+/* L80: */
+ }
+
+/* Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N ) */
+
+/* Computing MIN */
+ i__2 = *m, i__3 = *n - *l;
+ i__1 = min(i__2,i__3);
+ zunm2r_("Left", "Conjugate transpose", m, l, &i__1, &a[a_offset], lda, &
+ tau[1], &a[(*n - *l + 1) * a_dim1 + 1], lda, &work[1], info);
+
+ if (wantu) {
+
+/* Copy the details of U, and form U */
+
+ zlaset_("Full", m, m, &c_b1, &c_b1, &u[u_offset], ldu);
+ if (*m > 1) {
+ i__1 = *m - 1;
+ i__2 = *n - *l;
+ zlacpy_("Lower", &i__1, &i__2, &a[a_dim1 + 2], lda, &u[u_dim1 + 2]
+, ldu);
+ }
+/* Computing MIN */
+ i__2 = *m, i__3 = *n - *l;
+ i__1 = min(i__2,i__3);
+ zung2r_(m, m, &i__1, &u[u_offset], ldu, &tau[1], &work[1], info);
+ }
+
+ if (wantq) {
+
+/* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 */
+
+ i__1 = *n - *l;
+ zlapmt_(&forwrd, n, &i__1, &q[q_offset], ldq, &iwork[1]);
+ }
+
+/* Clean up A: set the strictly lower triangular part of */
+/* A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. */
+
+ i__1 = *k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *k;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L90: */
+ }
+/* L100: */
+ }
+ if (*m > *k) {
+ i__1 = *m - *k;
+ i__2 = *n - *l;
+ zlaset_("Full", &i__1, &i__2, &c_b1, &c_b1, &a[*k + 1 + a_dim1], lda);
+ }
+
+ if (*n - *l > *k) {
+
+/* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */
+
+ i__1 = *n - *l;
+ zgerq2_(k, &i__1, &a[a_offset], lda, &tau[1], &work[1], info);
+
+ if (wantq) {
+
+/* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1' */
+
+ i__1 = *n - *l;
+ zunmr2_("Right", "Conjugate transpose", n, &i__1, k, &a[a_offset],
+ lda, &tau[1], &q[q_offset], ldq, &work[1], info);
+ }
+
+/* Clean up A */
+
+ i__1 = *n - *l - *k;
+ zlaset_("Full", k, &i__1, &c_b1, &c_b1, &a[a_offset], lda);
+ i__1 = *n - *l;
+ for (j = *n - *l - *k + 1; j <= i__1; ++j) {
+ i__2 = *k;
+ for (i__ = j - *n + *l + *k + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L110: */
+ }
+/* L120: */
+ }
+
+ }
+
+ if (*m > *k) {
+
+/* QR factorization of A( K+1:M,N-L+1:N ) */
+
+ i__1 = *m - *k;
+ zgeqr2_(&i__1, l, &a[*k + 1 + (*n - *l + 1) * a_dim1], lda, &tau[1], &
+ work[1], info);
+
+ if (wantu) {
+
+/* Update U(:,K+1:M) := U(:,K+1:M)*U1 */
+
+ i__1 = *m - *k;
+/* Computing MIN */
+ i__3 = *m - *k;
+ i__2 = min(i__3,*l);
+ zunm2r_("Right", "No transpose", m, &i__1, &i__2, &a[*k + 1 + (*n
+ - *l + 1) * a_dim1], lda, &tau[1], &u[(*k + 1) * u_dim1 +
+ 1], ldu, &work[1], info);
+ }
+
+/* Clean up */
+
+ i__1 = *n;
+ for (j = *n - *l + 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j - *n + *k + *l + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L130: */
+ }
+/* L140: */
+ }
+
+ }
+
+ return 0;
+
+/* End of ZGGSVP */
+
+} /* zggsvp_ */
diff --git a/SRC/zgtcon.c b/SRC/zgtcon.c
new file mode 100644
index 0000000..a7607fd
--- /dev/null
+++ b/SRC/zgtcon.c
@@ -0,0 +1,209 @@
+/* zgtcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zgtcon_(char *norm, integer *n, doublecomplex *dl,
+ doublecomplex *d__, doublecomplex *du, doublecomplex *du2, integer *
+ ipiv, doublereal *anorm, doublereal *rcond, doublecomplex *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, kase, kase1;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *), xerbla_(
+ char *, integer *);
+ doublereal ainvnm;
+ logical onenrm;
+ extern /* Subroutine */ int zgttrs_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGTCON estimates the reciprocal of the condition number of a complex */
+/* tridiagonal matrix A using the LU factorization as computed by */
+/* ZGTTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* DL (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) multipliers that define the matrix L from the */
+/* LU factorization of A as computed by ZGTTRF. */
+
+/* D (input) COMPLEX*16 array, dimension (N) */
+/* The n diagonal elements of the upper triangular matrix U from */
+/* the LU factorization of A. */
+
+/* DU (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) elements of the first superdiagonal of U. */
+
+/* DU2 (input) COMPLEX*16 array, dimension (N-2) */
+/* The (n-2) elements of the second superdiagonal of U. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* ANORM (input) DOUBLE PRECISION */
+/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */
+/* If NORM = 'I', the infinity-norm of the original matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ --work;
+ --ipiv;
+ --du2;
+ --du;
+ --d__;
+ --dl;
+
+ /* Function Body */
+ *info = 0;
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*anorm < 0.) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGTCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.;
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ } else if (*anorm == 0.) {
+ return 0;
+ }
+
+/* Check that D(1:N) is non-zero. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ if (d__[i__2].r == 0. && d__[i__2].i == 0.) {
+ return 0;
+ }
+/* L10: */
+ }
+
+ ainvnm = 0.;
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kase = 0;
+L20:
+ zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(U)*inv(L). */
+
+ zgttrs_("No transpose", n, &c__1, &dl[1], &d__[1], &du[1], &du2[1]
+, &ipiv[1], &work[1], n, info);
+ } else {
+
+/* Multiply by inv(L')*inv(U'). */
+
+ zgttrs_("Conjugate transpose", n, &c__1, &dl[1], &d__[1], &du[1],
+ &du2[1], &ipiv[1], &work[1], n, info);
+ }
+ goto L20;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / ainvnm / *anorm;
+ }
+
+ return 0;
+
+/* End of ZGTCON */
+
+} /* zgtcon_ */
diff --git a/SRC/zgtrfs.c b/SRC/zgtrfs.c
new file mode 100644
index 0000000..53a8337
--- /dev/null
+++ b/SRC/zgtrfs.c
@@ -0,0 +1,553 @@
+/* zgtrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b18 = -1.;
+static doublereal c_b19 = 1.;
+static doublecomplex c_b26 = {1.,0.};
+
+/* Subroutine */ int zgtrfs_(char *trans, integer *n, integer *nrhs,
+ doublecomplex *dl, doublecomplex *d__, doublecomplex *du,
+ doublecomplex *dlf, doublecomplex *df, doublecomplex *duf,
+ doublecomplex *du2, integer *ipiv, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr,
+ doublecomplex *work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6, i__7, i__8, i__9;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
+ d__11, d__12, d__13, d__14;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal s;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3], count;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), zlacn2_(
+ integer *, doublecomplex *, doublecomplex *, doublereal *,
+ integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *), zlagtm_(
+ char *, integer *, integer *, doublereal *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublereal *, doublecomplex *, integer *);
+ logical notran;
+ char transn[1], transt[1];
+ doublereal lstres;
+ extern /* Subroutine */ int zgttrs_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGTRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is tridiagonal, and provides */
+/* error bounds and backward error estimates for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* DL (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of A. */
+
+/* D (input) COMPLEX*16 array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* DU (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) superdiagonal elements of A. */
+
+/* DLF (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) multipliers that define the matrix L from the */
+/* LU factorization of A as computed by ZGTTRF. */
+
+/* DF (input) COMPLEX*16 array, dimension (N) */
+/* The n diagonal elements of the upper triangular matrix U from */
+/* the LU factorization of A. */
+
+/* DUF (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) elements of the first superdiagonal of U. */
+
+/* DU2 (input) COMPLEX*16 array, dimension (N-2) */
+/* The (n-2) elements of the second superdiagonal of U. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by ZGTTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ --dlf;
+ --df;
+ --duf;
+ --du2;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -13;
+ } else if (*ldx < max(1,*n)) {
+ *info = -15;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGTRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transn = 'N';
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transn = 'C';
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = 4;
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A, A**T, or A**H, depending on TRANS. */
+
+ zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ zlagtm_(trans, n, &c__1, &c_b18, &dl[1], &d__[1], &du[1], &x[j *
+ x_dim1 + 1], ldx, &c_b19, &work[1], n);
+
+/* Compute abs(op(A))*abs(x) + abs(b) for use in the backward */
+/* error bound. */
+
+ if (notran) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * x_dim1 + 1;
+ rwork[1] = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[
+ j * b_dim1 + 1]), abs(d__2)) + ((d__3 = d__[1].r, abs(
+ d__3)) + (d__4 = d_imag(&d__[1]), abs(d__4))) * ((
+ d__5 = x[i__3].r, abs(d__5)) + (d__6 = d_imag(&x[j *
+ x_dim1 + 1]), abs(d__6)));
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * x_dim1 + 1;
+ i__4 = j * x_dim1 + 2;
+ rwork[1] = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[
+ j * b_dim1 + 1]), abs(d__2)) + ((d__3 = d__[1].r, abs(
+ d__3)) + (d__4 = d_imag(&d__[1]), abs(d__4))) * ((
+ d__5 = x[i__3].r, abs(d__5)) + (d__6 = d_imag(&x[j *
+ x_dim1 + 1]), abs(d__6))) + ((d__7 = du[1].r, abs(
+ d__7)) + (d__8 = d_imag(&du[1]), abs(d__8))) * ((d__9
+ = x[i__4].r, abs(d__9)) + (d__10 = d_imag(&x[j *
+ x_dim1 + 2]), abs(d__10)));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ - 1;
+ i__5 = i__ - 1 + j * x_dim1;
+ i__6 = i__;
+ i__7 = i__ + j * x_dim1;
+ i__8 = i__;
+ i__9 = i__ + 1 + j * x_dim1;
+ rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&b[i__ + j * b_dim1]), abs(d__2)) + ((d__3
+ = dl[i__4].r, abs(d__3)) + (d__4 = d_imag(&dl[i__
+ - 1]), abs(d__4))) * ((d__5 = x[i__5].r, abs(d__5)
+ ) + (d__6 = d_imag(&x[i__ - 1 + j * x_dim1]), abs(
+ d__6))) + ((d__7 = d__[i__6].r, abs(d__7)) + (
+ d__8 = d_imag(&d__[i__]), abs(d__8))) * ((d__9 =
+ x[i__7].r, abs(d__9)) + (d__10 = d_imag(&x[i__ +
+ j * x_dim1]), abs(d__10))) + ((d__11 = du[i__8].r,
+ abs(d__11)) + (d__12 = d_imag(&du[i__]), abs(
+ d__12))) * ((d__13 = x[i__9].r, abs(d__13)) + (
+ d__14 = d_imag(&x[i__ + 1 + j * x_dim1]), abs(
+ d__14)));
+/* L30: */
+ }
+ i__2 = *n + j * b_dim1;
+ i__3 = *n - 1;
+ i__4 = *n - 1 + j * x_dim1;
+ i__5 = *n;
+ i__6 = *n + j * x_dim1;
+ rwork[*n] = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[
+ *n + j * b_dim1]), abs(d__2)) + ((d__3 = dl[i__3].r,
+ abs(d__3)) + (d__4 = d_imag(&dl[*n - 1]), abs(d__4)))
+ * ((d__5 = x[i__4].r, abs(d__5)) + (d__6 = d_imag(&x[*
+ n - 1 + j * x_dim1]), abs(d__6))) + ((d__7 = d__[i__5]
+ .r, abs(d__7)) + (d__8 = d_imag(&d__[*n]), abs(d__8)))
+ * ((d__9 = x[i__6].r, abs(d__9)) + (d__10 = d_imag(&
+ x[*n + j * x_dim1]), abs(d__10)));
+ }
+ } else {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * x_dim1 + 1;
+ rwork[1] = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[
+ j * b_dim1 + 1]), abs(d__2)) + ((d__3 = d__[1].r, abs(
+ d__3)) + (d__4 = d_imag(&d__[1]), abs(d__4))) * ((
+ d__5 = x[i__3].r, abs(d__5)) + (d__6 = d_imag(&x[j *
+ x_dim1 + 1]), abs(d__6)));
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * x_dim1 + 1;
+ i__4 = j * x_dim1 + 2;
+ rwork[1] = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[
+ j * b_dim1 + 1]), abs(d__2)) + ((d__3 = d__[1].r, abs(
+ d__3)) + (d__4 = d_imag(&d__[1]), abs(d__4))) * ((
+ d__5 = x[i__3].r, abs(d__5)) + (d__6 = d_imag(&x[j *
+ x_dim1 + 1]), abs(d__6))) + ((d__7 = dl[1].r, abs(
+ d__7)) + (d__8 = d_imag(&dl[1]), abs(d__8))) * ((d__9
+ = x[i__4].r, abs(d__9)) + (d__10 = d_imag(&x[j *
+ x_dim1 + 2]), abs(d__10)));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ - 1;
+ i__5 = i__ - 1 + j * x_dim1;
+ i__6 = i__;
+ i__7 = i__ + j * x_dim1;
+ i__8 = i__;
+ i__9 = i__ + 1 + j * x_dim1;
+ rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&b[i__ + j * b_dim1]), abs(d__2)) + ((d__3
+ = du[i__4].r, abs(d__3)) + (d__4 = d_imag(&du[i__
+ - 1]), abs(d__4))) * ((d__5 = x[i__5].r, abs(d__5)
+ ) + (d__6 = d_imag(&x[i__ - 1 + j * x_dim1]), abs(
+ d__6))) + ((d__7 = d__[i__6].r, abs(d__7)) + (
+ d__8 = d_imag(&d__[i__]), abs(d__8))) * ((d__9 =
+ x[i__7].r, abs(d__9)) + (d__10 = d_imag(&x[i__ +
+ j * x_dim1]), abs(d__10))) + ((d__11 = dl[i__8].r,
+ abs(d__11)) + (d__12 = d_imag(&dl[i__]), abs(
+ d__12))) * ((d__13 = x[i__9].r, abs(d__13)) + (
+ d__14 = d_imag(&x[i__ + 1 + j * x_dim1]), abs(
+ d__14)));
+/* L40: */
+ }
+ i__2 = *n + j * b_dim1;
+ i__3 = *n - 1;
+ i__4 = *n - 1 + j * x_dim1;
+ i__5 = *n;
+ i__6 = *n + j * x_dim1;
+ rwork[*n] = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[
+ *n + j * b_dim1]), abs(d__2)) + ((d__3 = du[i__3].r,
+ abs(d__3)) + (d__4 = d_imag(&du[*n - 1]), abs(d__4)))
+ * ((d__5 = x[i__4].r, abs(d__5)) + (d__6 = d_imag(&x[*
+ n - 1 + j * x_dim1]), abs(d__6))) + ((d__7 = d__[i__5]
+ .r, abs(d__7)) + (d__8 = d_imag(&d__[*n]), abs(d__8)))
+ * ((d__9 = x[i__6].r, abs(d__9)) + (d__10 = d_imag(&
+ x[*n + j * x_dim1]), abs(d__10)));
+ }
+ }
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__3 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2))) / rwork[i__];
+ s = max(d__3,d__4);
+ } else {
+/* Computing MAX */
+ i__3 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = max(d__3,d__4);
+ }
+/* L50: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ zgttrs_(trans, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[
+ 1], &work[1], n, info);
+ zaxpy_(n, &c_b26, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use ZLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__3 = i__;
+ rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ ;
+ } else {
+ i__3 = i__;
+ rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ + safe1;
+ }
+/* L60: */
+ }
+
+ kase = 0;
+L70:
+ zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)**H). */
+
+ zgttrs_(transt, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &
+ ipiv[1], &work[1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L80: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L90: */
+ }
+ zgttrs_(transn, n, &c__1, &dlf[1], &df[1], &duf[1], &du2[1], &
+ ipiv[1], &work[1], n, info);
+ }
+ goto L70;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * x_dim1;
+ d__3 = lstres, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&x[i__ + j * x_dim1]), abs(d__2));
+ lstres = max(d__3,d__4);
+/* L100: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L110: */
+ }
+
+ return 0;
+
+/* End of ZGTRFS */
+
+} /* zgtrfs_ */
diff --git a/SRC/zgtsv.c b/SRC/zgtsv.c
new file mode 100644
index 0000000..e1d9bc2
--- /dev/null
+++ b/SRC/zgtsv.c
@@ -0,0 +1,288 @@
+/* zgtsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zgtsv_(integer *n, integer *nrhs, doublecomplex *dl,
+ doublecomplex *d__, doublecomplex *du, doublecomplex *b, integer *ldb,
+ integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2, z__3, z__4, z__5;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer j, k;
+ doublecomplex temp, mult;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGTSV solves the equation */
+
+/* A*X = B, */
+
+/* where A is an N-by-N tridiagonal matrix, by Gaussian elimination with */
+/* partial pivoting. */
+
+/* Note that the equation A'*X = B may be solved by interchanging the */
+/* order of the arguments DU and DL. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* DL (input/output) COMPLEX*16 array, dimension (N-1) */
+/* On entry, DL must contain the (n-1) subdiagonal elements of */
+/* A. */
+/* On exit, DL is overwritten by the (n-2) elements of the */
+/* second superdiagonal of the upper triangular matrix U from */
+/* the LU factorization of A, in DL(1), ..., DL(n-2). */
+
+/* D (input/output) COMPLEX*16 array, dimension (N) */
+/* On entry, D must contain the diagonal elements of A. */
+/* On exit, D is overwritten by the n diagonal elements of U. */
+
+/* DU (input/output) COMPLEX*16 array, dimension (N-1) */
+/* On entry, DU must contain the (n-1) superdiagonal elements */
+/* of A. */
+/* On exit, DU is overwritten by the (n-1) elements of the first */
+/* superdiagonal of U. */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, U(i,i) is exactly zero, and the solution */
+/* has not been computed. The factorization has not been */
+/* completed unless i = N. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGTSV ", &i__1);
+ return 0;
+ }
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ i__1 = *n - 1;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = k;
+ if (dl[i__2].r == 0. && dl[i__2].i == 0.) {
+
+/* Subdiagonal is zero, no elimination is required. */
+
+ i__2 = k;
+ if (d__[i__2].r == 0. && d__[i__2].i == 0.) {
+
+/* Diagonal is zero: set INFO = K and return; a unique */
+/* solution can not be found. */
+
+ *info = k;
+ return 0;
+ }
+ } else /* if(complicated condition) */ {
+ i__2 = k;
+ i__3 = k;
+ if ((d__1 = d__[i__2].r, abs(d__1)) + (d__2 = d_imag(&d__[k]),
+ abs(d__2)) >= (d__3 = dl[i__3].r, abs(d__3)) + (d__4 =
+ d_imag(&dl[k]), abs(d__4))) {
+
+/* No row interchange required */
+
+ z_div(&z__1, &dl[k], &d__[k]);
+ mult.r = z__1.r, mult.i = z__1.i;
+ i__2 = k + 1;
+ i__3 = k + 1;
+ i__4 = k;
+ z__2.r = mult.r * du[i__4].r - mult.i * du[i__4].i, z__2.i =
+ mult.r * du[i__4].i + mult.i * du[i__4].r;
+ z__1.r = d__[i__3].r - z__2.r, z__1.i = d__[i__3].i - z__2.i;
+ d__[i__2].r = z__1.r, d__[i__2].i = z__1.i;
+ i__2 = *nrhs;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = k + 1 + j * b_dim1;
+ i__4 = k + 1 + j * b_dim1;
+ i__5 = k + j * b_dim1;
+ z__2.r = mult.r * b[i__5].r - mult.i * b[i__5].i, z__2.i =
+ mult.r * b[i__5].i + mult.i * b[i__5].r;
+ z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4].i - z__2.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L10: */
+ }
+ if (k < *n - 1) {
+ i__2 = k;
+ dl[i__2].r = 0., dl[i__2].i = 0.;
+ }
+ } else {
+
+/* Interchange rows K and K+1 */
+
+ z_div(&z__1, &d__[k], &dl[k]);
+ mult.r = z__1.r, mult.i = z__1.i;
+ i__2 = k;
+ i__3 = k;
+ d__[i__2].r = dl[i__3].r, d__[i__2].i = dl[i__3].i;
+ i__2 = k + 1;
+ temp.r = d__[i__2].r, temp.i = d__[i__2].i;
+ i__2 = k + 1;
+ i__3 = k;
+ z__2.r = mult.r * temp.r - mult.i * temp.i, z__2.i = mult.r *
+ temp.i + mult.i * temp.r;
+ z__1.r = du[i__3].r - z__2.r, z__1.i = du[i__3].i - z__2.i;
+ d__[i__2].r = z__1.r, d__[i__2].i = z__1.i;
+ if (k < *n - 1) {
+ i__2 = k;
+ i__3 = k + 1;
+ dl[i__2].r = du[i__3].r, dl[i__2].i = du[i__3].i;
+ i__2 = k + 1;
+ z__2.r = -mult.r, z__2.i = -mult.i;
+ i__3 = k;
+ z__1.r = z__2.r * dl[i__3].r - z__2.i * dl[i__3].i,
+ z__1.i = z__2.r * dl[i__3].i + z__2.i * dl[i__3]
+ .r;
+ du[i__2].r = z__1.r, du[i__2].i = z__1.i;
+ }
+ i__2 = k;
+ du[i__2].r = temp.r, du[i__2].i = temp.i;
+ i__2 = *nrhs;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = k + j * b_dim1;
+ temp.r = b[i__3].r, temp.i = b[i__3].i;
+ i__3 = k + j * b_dim1;
+ i__4 = k + 1 + j * b_dim1;
+ b[i__3].r = b[i__4].r, b[i__3].i = b[i__4].i;
+ i__3 = k + 1 + j * b_dim1;
+ i__4 = k + 1 + j * b_dim1;
+ z__2.r = mult.r * b[i__4].r - mult.i * b[i__4].i, z__2.i =
+ mult.r * b[i__4].i + mult.i * b[i__4].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i - z__2.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L20: */
+ }
+ }
+ }
+/* L30: */
+ }
+ i__1 = *n;
+ if (d__[i__1].r == 0. && d__[i__1].i == 0.) {
+ *info = *n;
+ return 0;
+ }
+
+/* Back solve with the matrix U from the factorization. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n + j * b_dim1;
+ z_div(&z__1, &b[*n + j * b_dim1], &d__[*n]);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ if (*n > 1) {
+ i__2 = *n - 1 + j * b_dim1;
+ i__3 = *n - 1 + j * b_dim1;
+ i__4 = *n - 1;
+ i__5 = *n + j * b_dim1;
+ z__3.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i, z__3.i =
+ du[i__4].r * b[i__5].i + du[i__4].i * b[i__5].r;
+ z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i;
+ z_div(&z__1, &z__2, &d__[*n - 1]);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ }
+ for (k = *n - 2; k >= 1; --k) {
+ i__2 = k + j * b_dim1;
+ i__3 = k + j * b_dim1;
+ i__4 = k;
+ i__5 = k + 1 + j * b_dim1;
+ z__4.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i, z__4.i =
+ du[i__4].r * b[i__5].i + du[i__4].i * b[i__5].r;
+ z__3.r = b[i__3].r - z__4.r, z__3.i = b[i__3].i - z__4.i;
+ i__6 = k;
+ i__7 = k + 2 + j * b_dim1;
+ z__5.r = dl[i__6].r * b[i__7].r - dl[i__6].i * b[i__7].i, z__5.i =
+ dl[i__6].r * b[i__7].i + dl[i__6].i * b[i__7].r;
+ z__2.r = z__3.r - z__5.r, z__2.i = z__3.i - z__5.i;
+ z_div(&z__1, &z__2, &d__[k]);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L40: */
+ }
+/* L50: */
+ }
+
+ return 0;
+
+/* End of ZGTSV */
+
+} /* zgtsv_ */
diff --git a/SRC/zgtsvx.c b/SRC/zgtsvx.c
new file mode 100644
index 0000000..aeffccd
--- /dev/null
+++ b/SRC/zgtsvx.c
@@ -0,0 +1,353 @@
+/* zgtsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zgtsvx_(char *fact, char *trans, integer *n, integer *
+ nrhs, doublecomplex *dl, doublecomplex *d__, doublecomplex *du,
+ doublecomplex *dlf, doublecomplex *df, doublecomplex *duf,
+ doublecomplex *du2, integer *ipiv, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr,
+ doublereal *berr, doublecomplex *work, doublereal *rwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+
+ /* Local variables */
+ char norm[1];
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal zlangt_(char *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *);
+ logical notran;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zgtcon_(char *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *, doublereal *,
+ doublereal *, doublecomplex *, integer *), zgtrfs_(char *,
+ integer *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *), zgttrf_(
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, integer *), zgttrs_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGTSVX uses the LU factorization to compute the solution to a complex */
+/* system of linear equations A * X = B, A**T * X = B, or A**H * X = B, */
+/* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS */
+/* matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A */
+/* as A = L * U, where L is a product of permutation and unit lower */
+/* bidiagonal matrices and U is upper triangular with nonzeros in */
+/* only the main diagonal and first two superdiagonals. */
+
+/* 2. If some U(i,i)=0, so that U is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 3. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 4. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of A has been */
+/* supplied on entry. */
+/* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored form */
+/* of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV will not */
+/* be modified. */
+/* = 'N': The matrix will be copied to DLF, DF, and DUF */
+/* and factored. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* DL (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of A. */
+
+/* D (input) COMPLEX*16 array, dimension (N) */
+/* The n diagonal elements of A. */
+
+/* DU (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) superdiagonal elements of A. */
+
+/* DLF (input or output) COMPLEX*16 array, dimension (N-1) */
+/* If FACT = 'F', then DLF is an input argument and on entry */
+/* contains the (n-1) multipliers that define the matrix L from */
+/* the LU factorization of A as computed by ZGTTRF. */
+
+/* If FACT = 'N', then DLF is an output argument and on exit */
+/* contains the (n-1) multipliers that define the matrix L from */
+/* the LU factorization of A. */
+
+/* DF (input or output) COMPLEX*16 array, dimension (N) */
+/* If FACT = 'F', then DF is an input argument and on entry */
+/* contains the n diagonal elements of the upper triangular */
+/* matrix U from the LU factorization of A. */
+
+/* If FACT = 'N', then DF is an output argument and on exit */
+/* contains the n diagonal elements of the upper triangular */
+/* matrix U from the LU factorization of A. */
+
+/* DUF (input or output) COMPLEX*16 array, dimension (N-1) */
+/* If FACT = 'F', then DUF is an input argument and on entry */
+/* contains the (n-1) elements of the first superdiagonal of U. */
+
+/* If FACT = 'N', then DUF is an output argument and on exit */
+/* contains the (n-1) elements of the first superdiagonal of U. */
+
+/* DU2 (input or output) COMPLEX*16 array, dimension (N-2) */
+/* If FACT = 'F', then DU2 is an input argument and on entry */
+/* contains the (n-2) elements of the second superdiagonal of */
+/* U. */
+
+/* If FACT = 'N', then DU2 is an output argument and on exit */
+/* contains the (n-2) elements of the second superdiagonal of */
+/* U. */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains the pivot indices from the LU factorization of A as */
+/* computed by ZGTTRF. */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains the pivot indices from the LU factorization of A; */
+/* row i of the matrix was interchanged with row IPIV(i). */
+/* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates */
+/* a row interchange was not required. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A. If RCOND is less than the machine precision (in */
+/* particular, if RCOND = 0), the matrix is singular to working */
+/* precision. This condition is indicated by a return code of */
+/* INFO > 0. */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: U(i,i) is exactly zero. The factorization */
+/* has not been completed unless i = N, but the */
+/* factor U is exactly singular, so the solution */
+/* and error bounds could not be computed. */
+/* RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ --dlf;
+ --df;
+ --duf;
+ --du2;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ notran = lsame_(trans, "N");
+ if (! nofact && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -14;
+ } else if (*ldx < max(1,*n)) {
+ *info = -16;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGTSVX", &i__1);
+ return 0;
+ }
+
+ if (nofact) {
+
+/* Compute the LU factorization of A. */
+
+ zcopy_(n, &d__[1], &c__1, &df[1], &c__1);
+ if (*n > 1) {
+ i__1 = *n - 1;
+ zcopy_(&i__1, &dl[1], &c__1, &dlf[1], &c__1);
+ i__1 = *n - 1;
+ zcopy_(&i__1, &du[1], &c__1, &duf[1], &c__1);
+ }
+ zgttrf_(n, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ if (notran) {
+ *(unsigned char *)norm = '1';
+ } else {
+ *(unsigned char *)norm = 'I';
+ }
+ anorm = zlangt_(norm, n, &dl[1], &d__[1], &du[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ zgtcon_(norm, n, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], &anorm,
+ rcond, &work[1], info);
+
+/* Compute the solution vectors X. */
+
+ zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ zgttrs_(trans, n, nrhs, &dlf[1], &df[1], &duf[1], &du2[1], &ipiv[1], &x[
+ x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solutions and */
+/* compute error bounds and backward error estimates for them. */
+
+ zgtrfs_(trans, n, nrhs, &dl[1], &d__[1], &du[1], &dlf[1], &df[1], &duf[1],
+ &du2[1], &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1]
+, &berr[1], &work[1], &rwork[1], info);
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < dlamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of ZGTSVX */
+
+} /* zgtsvx_ */
diff --git a/SRC/zgttrf.c b/SRC/zgttrf.c
new file mode 100644
index 0000000..714ae0f
--- /dev/null
+++ b/SRC/zgttrf.c
@@ -0,0 +1,275 @@
+/* zgttrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zgttrf_(integer *n, doublecomplex *dl, doublecomplex *
+ d__, doublecomplex *du, doublecomplex *du2, integer *ipiv, integer *
+ info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__;
+ doublecomplex fact, temp;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGTTRF computes an LU factorization of a complex tridiagonal matrix A */
+/* using elimination with partial pivoting and row interchanges. */
+
+/* The factorization has the form */
+/* A = L * U */
+/* where L is a product of permutation and unit lower bidiagonal */
+/* matrices and U is upper triangular with nonzeros in only the main */
+/* diagonal and first two superdiagonals. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* DL (input/output) COMPLEX*16 array, dimension (N-1) */
+/* On entry, DL must contain the (n-1) sub-diagonal elements of */
+/* A. */
+
+/* On exit, DL is overwritten by the (n-1) multipliers that */
+/* define the matrix L from the LU factorization of A. */
+
+/* D (input/output) COMPLEX*16 array, dimension (N) */
+/* On entry, D must contain the diagonal elements of A. */
+
+/* On exit, D is overwritten by the n diagonal elements of the */
+/* upper triangular matrix U from the LU factorization of A. */
+
+/* DU (input/output) COMPLEX*16 array, dimension (N-1) */
+/* On entry, DU must contain the (n-1) super-diagonal elements */
+/* of A. */
+
+/* On exit, DU is overwritten by the (n-1) elements of the first */
+/* super-diagonal of U. */
+
+/* DU2 (output) COMPLEX*16 array, dimension (N-2) */
+/* On exit, DU2 is overwritten by the (n-2) elements of the */
+/* second super-diagonal of U. */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, U(k,k) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly */
+/* singular, and division by zero will occur if it is used */
+/* to solve a system of equations. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ipiv;
+ --du2;
+ --du;
+ --d__;
+ --dl;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ i__1 = -(*info);
+ xerbla_("ZGTTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Initialize IPIV(i) = i and DU2(i) = 0 */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ipiv[i__] = i__;
+/* L10: */
+ }
+ i__1 = *n - 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ du2[i__2].r = 0., du2[i__2].i = 0.;
+/* L20: */
+ }
+
+ i__1 = *n - 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ if ((d__1 = d__[i__2].r, abs(d__1)) + (d__2 = d_imag(&d__[i__]), abs(
+ d__2)) >= (d__3 = dl[i__3].r, abs(d__3)) + (d__4 = d_imag(&dl[
+ i__]), abs(d__4))) {
+
+/* No row interchange required, eliminate DL(I) */
+
+ i__2 = i__;
+ if ((d__1 = d__[i__2].r, abs(d__1)) + (d__2 = d_imag(&d__[i__]),
+ abs(d__2)) != 0.) {
+ z_div(&z__1, &dl[i__], &d__[i__]);
+ fact.r = z__1.r, fact.i = z__1.i;
+ i__2 = i__;
+ dl[i__2].r = fact.r, dl[i__2].i = fact.i;
+ i__2 = i__ + 1;
+ i__3 = i__ + 1;
+ i__4 = i__;
+ z__2.r = fact.r * du[i__4].r - fact.i * du[i__4].i, z__2.i =
+ fact.r * du[i__4].i + fact.i * du[i__4].r;
+ z__1.r = d__[i__3].r - z__2.r, z__1.i = d__[i__3].i - z__2.i;
+ d__[i__2].r = z__1.r, d__[i__2].i = z__1.i;
+ }
+ } else {
+
+/* Interchange rows I and I+1, eliminate DL(I) */
+
+ z_div(&z__1, &d__[i__], &dl[i__]);
+ fact.r = z__1.r, fact.i = z__1.i;
+ i__2 = i__;
+ i__3 = i__;
+ d__[i__2].r = dl[i__3].r, d__[i__2].i = dl[i__3].i;
+ i__2 = i__;
+ dl[i__2].r = fact.r, dl[i__2].i = fact.i;
+ i__2 = i__;
+ temp.r = du[i__2].r, temp.i = du[i__2].i;
+ i__2 = i__;
+ i__3 = i__ + 1;
+ du[i__2].r = d__[i__3].r, du[i__2].i = d__[i__3].i;
+ i__2 = i__ + 1;
+ i__3 = i__ + 1;
+ z__2.r = fact.r * d__[i__3].r - fact.i * d__[i__3].i, z__2.i =
+ fact.r * d__[i__3].i + fact.i * d__[i__3].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i - z__2.i;
+ d__[i__2].r = z__1.r, d__[i__2].i = z__1.i;
+ i__2 = i__;
+ i__3 = i__ + 1;
+ du2[i__2].r = du[i__3].r, du2[i__2].i = du[i__3].i;
+ i__2 = i__ + 1;
+ z__2.r = -fact.r, z__2.i = -fact.i;
+ i__3 = i__ + 1;
+ z__1.r = z__2.r * du[i__3].r - z__2.i * du[i__3].i, z__1.i =
+ z__2.r * du[i__3].i + z__2.i * du[i__3].r;
+ du[i__2].r = z__1.r, du[i__2].i = z__1.i;
+ ipiv[i__] = i__ + 1;
+ }
+/* L30: */
+ }
+ if (*n > 1) {
+ i__ = *n - 1;
+ i__1 = i__;
+ i__2 = i__;
+ if ((d__1 = d__[i__1].r, abs(d__1)) + (d__2 = d_imag(&d__[i__]), abs(
+ d__2)) >= (d__3 = dl[i__2].r, abs(d__3)) + (d__4 = d_imag(&dl[
+ i__]), abs(d__4))) {
+ i__1 = i__;
+ if ((d__1 = d__[i__1].r, abs(d__1)) + (d__2 = d_imag(&d__[i__]),
+ abs(d__2)) != 0.) {
+ z_div(&z__1, &dl[i__], &d__[i__]);
+ fact.r = z__1.r, fact.i = z__1.i;
+ i__1 = i__;
+ dl[i__1].r = fact.r, dl[i__1].i = fact.i;
+ i__1 = i__ + 1;
+ i__2 = i__ + 1;
+ i__3 = i__;
+ z__2.r = fact.r * du[i__3].r - fact.i * du[i__3].i, z__2.i =
+ fact.r * du[i__3].i + fact.i * du[i__3].r;
+ z__1.r = d__[i__2].r - z__2.r, z__1.i = d__[i__2].i - z__2.i;
+ d__[i__1].r = z__1.r, d__[i__1].i = z__1.i;
+ }
+ } else {
+ z_div(&z__1, &d__[i__], &dl[i__]);
+ fact.r = z__1.r, fact.i = z__1.i;
+ i__1 = i__;
+ i__2 = i__;
+ d__[i__1].r = dl[i__2].r, d__[i__1].i = dl[i__2].i;
+ i__1 = i__;
+ dl[i__1].r = fact.r, dl[i__1].i = fact.i;
+ i__1 = i__;
+ temp.r = du[i__1].r, temp.i = du[i__1].i;
+ i__1 = i__;
+ i__2 = i__ + 1;
+ du[i__1].r = d__[i__2].r, du[i__1].i = d__[i__2].i;
+ i__1 = i__ + 1;
+ i__2 = i__ + 1;
+ z__2.r = fact.r * d__[i__2].r - fact.i * d__[i__2].i, z__2.i =
+ fact.r * d__[i__2].i + fact.i * d__[i__2].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i - z__2.i;
+ d__[i__1].r = z__1.r, d__[i__1].i = z__1.i;
+ ipiv[i__] = i__ + 1;
+ }
+ }
+
+/* Check for a zero on the diagonal of U. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ if ((d__1 = d__[i__2].r, abs(d__1)) + (d__2 = d_imag(&d__[i__]), abs(
+ d__2)) == 0.) {
+ *info = i__;
+ goto L50;
+ }
+/* L40: */
+ }
+L50:
+
+ return 0;
+
+/* End of ZGTTRF */
+
+} /* zgttrf_ */
diff --git a/SRC/zgttrs.c b/SRC/zgttrs.c
new file mode 100644
index 0000000..f8130e2
--- /dev/null
+++ b/SRC/zgttrs.c
@@ -0,0 +1,194 @@
+/* zgttrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zgttrs_(char *trans, integer *n, integer *nrhs,
+ doublecomplex *dl, doublecomplex *d__, doublecomplex *du,
+ doublecomplex *du2, integer *ipiv, doublecomplex *b, integer *ldb,
+ integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer j, jb, nb;
+ extern /* Subroutine */ int zgtts2_(integer *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, doublecomplex *, integer *), xerbla_(char *, integer
+ *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer itrans;
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGTTRS solves one of the systems of equations */
+/* A * X = B, A**T * X = B, or A**H * X = B, */
+/* with a tridiagonal matrix A using the LU factorization computed */
+/* by ZGTTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* DL (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) multipliers that define the matrix L from the */
+/* LU factorization of A. */
+
+/* D (input) COMPLEX*16 array, dimension (N) */
+/* The n diagonal elements of the upper triangular matrix U from */
+/* the LU factorization of A. */
+
+/* DU (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) elements of the first super-diagonal of U. */
+
+/* DU2 (input) COMPLEX*16 array, dimension (N-2) */
+/* The (n-2) elements of the second super-diagonal of U. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the matrix of right hand side vectors B. */
+/* On exit, B is overwritten by the solution vectors X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ --du2;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ notran = *(unsigned char *)trans == 'N' || *(unsigned char *)trans == 'n';
+ if (! notran && ! (*(unsigned char *)trans == 'T' || *(unsigned char *)
+ trans == 't') && ! (*(unsigned char *)trans == 'C' || *(unsigned
+ char *)trans == 'c')) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(*n,1)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGTTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+/* Decode TRANS */
+
+ if (notran) {
+ itrans = 0;
+ } else if (*(unsigned char *)trans == 'T' || *(unsigned char *)trans ==
+ 't') {
+ itrans = 1;
+ } else {
+ itrans = 2;
+ }
+
+/* Determine the number of right-hand sides to solve at a time. */
+
+ if (*nrhs == 1) {
+ nb = 1;
+ } else {
+/* Computing MAX */
+ i__1 = 1, i__2 = ilaenv_(&c__1, "ZGTTRS", trans, n, nrhs, &c_n1, &
+ c_n1);
+ nb = max(i__1,i__2);
+ }
+
+ if (nb >= *nrhs) {
+ zgtts2_(&itrans, n, nrhs, &dl[1], &d__[1], &du[1], &du2[1], &ipiv[1],
+ &b[b_offset], ldb);
+ } else {
+ i__1 = *nrhs;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = *nrhs - j + 1;
+ jb = min(i__3,nb);
+ zgtts2_(&itrans, n, &jb, &dl[1], &d__[1], &du[1], &du2[1], &ipiv[
+ 1], &b[j * b_dim1 + 1], ldb);
+/* L10: */
+ }
+ }
+
+/* End of ZGTTRS */
+
+ return 0;
+} /* zgttrs_ */
diff --git a/SRC/zgtts2.c b/SRC/zgtts2.c
new file mode 100644
index 0000000..fc98b35
--- /dev/null
+++ b/SRC/zgtts2.c
@@ -0,0 +1,584 @@
+/* zgtts2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zgtts2_(integer *itrans, integer *n, integer *nrhs,
+ doublecomplex *dl, doublecomplex *d__, doublecomplex *du,
+ doublecomplex *du2, integer *ipiv, doublecomplex *b, integer *ldb)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
+ doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8;
+
+ /* Builtin functions */
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
+ doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublecomplex temp;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGTTS2 solves one of the systems of equations */
+/* A * X = B, A**T * X = B, or A**H * X = B, */
+/* with a tridiagonal matrix A using the LU factorization computed */
+/* by ZGTTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* ITRANS (input) INTEGER */
+/* Specifies the form of the system of equations. */
+/* = 0: A * X = B (No transpose) */
+/* = 1: A**T * X = B (Transpose) */
+/* = 2: A**H * X = B (Conjugate transpose) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* DL (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) multipliers that define the matrix L from the */
+/* LU factorization of A. */
+
+/* D (input) COMPLEX*16 array, dimension (N) */
+/* The n diagonal elements of the upper triangular matrix U from */
+/* the LU factorization of A. */
+
+/* DU (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) elements of the first super-diagonal of U. */
+
+/* DU2 (input) COMPLEX*16 array, dimension (N-2) */
+/* The (n-2) elements of the second super-diagonal of U. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the matrix of right hand side vectors B. */
+/* On exit, B is overwritten by the solution vectors X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ --du2;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (*itrans == 0) {
+
+/* Solve A*X = B using the LU factorization of A, */
+/* overwriting each right hand side vector with its solution. */
+
+ if (*nrhs <= 1) {
+ j = 1;
+L10:
+
+/* Solve L*x = b. */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (ipiv[i__] == i__) {
+ i__2 = i__ + 1 + j * b_dim1;
+ i__3 = i__ + 1 + j * b_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * b_dim1;
+ z__2.r = dl[i__4].r * b[i__5].r - dl[i__4].i * b[i__5].i,
+ z__2.i = dl[i__4].r * b[i__5].i + dl[i__4].i * b[
+ i__5].r;
+ z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i - z__2.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ } else {
+ i__2 = i__ + j * b_dim1;
+ temp.r = b[i__2].r, temp.i = b[i__2].i;
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + 1 + j * b_dim1;
+ b[i__2].r = b[i__3].r, b[i__2].i = b[i__3].i;
+ i__2 = i__ + 1 + j * b_dim1;
+ i__3 = i__;
+ i__4 = i__ + j * b_dim1;
+ z__2.r = dl[i__3].r * b[i__4].r - dl[i__3].i * b[i__4].i,
+ z__2.i = dl[i__3].r * b[i__4].i + dl[i__3].i * b[
+ i__4].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i - z__2.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ }
+/* L20: */
+ }
+
+/* Solve U*x = b. */
+
+ i__1 = *n + j * b_dim1;
+ z_div(&z__1, &b[*n + j * b_dim1], &d__[*n]);
+ b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+ if (*n > 1) {
+ i__1 = *n - 1 + j * b_dim1;
+ i__2 = *n - 1 + j * b_dim1;
+ i__3 = *n - 1;
+ i__4 = *n + j * b_dim1;
+ z__3.r = du[i__3].r * b[i__4].r - du[i__3].i * b[i__4].i,
+ z__3.i = du[i__3].r * b[i__4].i + du[i__3].i * b[i__4]
+ .r;
+ z__2.r = b[i__2].r - z__3.r, z__2.i = b[i__2].i - z__3.i;
+ z_div(&z__1, &z__2, &d__[*n - 1]);
+ b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+ }
+ for (i__ = *n - 2; i__ >= 1; --i__) {
+ i__1 = i__ + j * b_dim1;
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__;
+ i__4 = i__ + 1 + j * b_dim1;
+ z__4.r = du[i__3].r * b[i__4].r - du[i__3].i * b[i__4].i,
+ z__4.i = du[i__3].r * b[i__4].i + du[i__3].i * b[i__4]
+ .r;
+ z__3.r = b[i__2].r - z__4.r, z__3.i = b[i__2].i - z__4.i;
+ i__5 = i__;
+ i__6 = i__ + 2 + j * b_dim1;
+ z__5.r = du2[i__5].r * b[i__6].r - du2[i__5].i * b[i__6].i,
+ z__5.i = du2[i__5].r * b[i__6].i + du2[i__5].i * b[
+ i__6].r;
+ z__2.r = z__3.r - z__5.r, z__2.i = z__3.i - z__5.i;
+ z_div(&z__1, &z__2, &d__[i__]);
+ b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+/* L30: */
+ }
+ if (j < *nrhs) {
+ ++j;
+ goto L10;
+ }
+ } else {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve L*x = b. */
+
+ i__2 = *n - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (ipiv[i__] == i__) {
+ i__3 = i__ + 1 + j * b_dim1;
+ i__4 = i__ + 1 + j * b_dim1;
+ i__5 = i__;
+ i__6 = i__ + j * b_dim1;
+ z__2.r = dl[i__5].r * b[i__6].r - dl[i__5].i * b[i__6]
+ .i, z__2.i = dl[i__5].r * b[i__6].i + dl[i__5]
+ .i * b[i__6].r;
+ z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4].i -
+ z__2.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+ } else {
+ i__3 = i__ + j * b_dim1;
+ temp.r = b[i__3].r, temp.i = b[i__3].i;
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + 1 + j * b_dim1;
+ b[i__3].r = b[i__4].r, b[i__3].i = b[i__4].i;
+ i__3 = i__ + 1 + j * b_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * b_dim1;
+ z__2.r = dl[i__4].r * b[i__5].r - dl[i__4].i * b[i__5]
+ .i, z__2.i = dl[i__4].r * b[i__5].i + dl[i__4]
+ .i * b[i__5].r;
+ z__1.r = temp.r - z__2.r, z__1.i = temp.i - z__2.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+ }
+/* L40: */
+ }
+
+/* Solve U*x = b. */
+
+ i__2 = *n + j * b_dim1;
+ z_div(&z__1, &b[*n + j * b_dim1], &d__[*n]);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ if (*n > 1) {
+ i__2 = *n - 1 + j * b_dim1;
+ i__3 = *n - 1 + j * b_dim1;
+ i__4 = *n - 1;
+ i__5 = *n + j * b_dim1;
+ z__3.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i,
+ z__3.i = du[i__4].r * b[i__5].i + du[i__4].i * b[
+ i__5].r;
+ z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i;
+ z_div(&z__1, &z__2, &d__[*n - 1]);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ }
+ for (i__ = *n - 2; i__ >= 1; --i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ i__5 = i__ + 1 + j * b_dim1;
+ z__4.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i,
+ z__4.i = du[i__4].r * b[i__5].i + du[i__4].i * b[
+ i__5].r;
+ z__3.r = b[i__3].r - z__4.r, z__3.i = b[i__3].i - z__4.i;
+ i__6 = i__;
+ i__7 = i__ + 2 + j * b_dim1;
+ z__5.r = du2[i__6].r * b[i__7].r - du2[i__6].i * b[i__7]
+ .i, z__5.i = du2[i__6].r * b[i__7].i + du2[i__6]
+ .i * b[i__7].r;
+ z__2.r = z__3.r - z__5.r, z__2.i = z__3.i - z__5.i;
+ z_div(&z__1, &z__2, &d__[i__]);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+ } else if (*itrans == 1) {
+
+/* Solve A**T * X = B. */
+
+ if (*nrhs <= 1) {
+ j = 1;
+L70:
+
+/* Solve U**T * x = b. */
+
+ i__1 = j * b_dim1 + 1;
+ z_div(&z__1, &b[j * b_dim1 + 1], &d__[1]);
+ b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+ if (*n > 1) {
+ i__1 = j * b_dim1 + 2;
+ i__2 = j * b_dim1 + 2;
+ i__3 = j * b_dim1 + 1;
+ z__3.r = du[1].r * b[i__3].r - du[1].i * b[i__3].i, z__3.i =
+ du[1].r * b[i__3].i + du[1].i * b[i__3].r;
+ z__2.r = b[i__2].r - z__3.r, z__2.i = b[i__2].i - z__3.i;
+ z_div(&z__1, &z__2, &d__[2]);
+ b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+ }
+ i__1 = *n;
+ for (i__ = 3; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ - 1;
+ i__5 = i__ - 1 + j * b_dim1;
+ z__4.r = du[i__4].r * b[i__5].r - du[i__4].i * b[i__5].i,
+ z__4.i = du[i__4].r * b[i__5].i + du[i__4].i * b[i__5]
+ .r;
+ z__3.r = b[i__3].r - z__4.r, z__3.i = b[i__3].i - z__4.i;
+ i__6 = i__ - 2;
+ i__7 = i__ - 2 + j * b_dim1;
+ z__5.r = du2[i__6].r * b[i__7].r - du2[i__6].i * b[i__7].i,
+ z__5.i = du2[i__6].r * b[i__7].i + du2[i__6].i * b[
+ i__7].r;
+ z__2.r = z__3.r - z__5.r, z__2.i = z__3.i - z__5.i;
+ z_div(&z__1, &z__2, &d__[i__]);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L80: */
+ }
+
+/* Solve L**T * x = b. */
+
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ if (ipiv[i__] == i__) {
+ i__1 = i__ + j * b_dim1;
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__;
+ i__4 = i__ + 1 + j * b_dim1;
+ z__2.r = dl[i__3].r * b[i__4].r - dl[i__3].i * b[i__4].i,
+ z__2.i = dl[i__3].r * b[i__4].i + dl[i__3].i * b[
+ i__4].r;
+ z__1.r = b[i__2].r - z__2.r, z__1.i = b[i__2].i - z__2.i;
+ b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+ } else {
+ i__1 = i__ + 1 + j * b_dim1;
+ temp.r = b[i__1].r, temp.i = b[i__1].i;
+ i__1 = i__ + 1 + j * b_dim1;
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__;
+ z__2.r = dl[i__3].r * temp.r - dl[i__3].i * temp.i,
+ z__2.i = dl[i__3].r * temp.i + dl[i__3].i *
+ temp.r;
+ z__1.r = b[i__2].r - z__2.r, z__1.i = b[i__2].i - z__2.i;
+ b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+ i__1 = i__ + j * b_dim1;
+ b[i__1].r = temp.r, b[i__1].i = temp.i;
+ }
+/* L90: */
+ }
+ if (j < *nrhs) {
+ ++j;
+ goto L70;
+ }
+ } else {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve U**T * x = b. */
+
+ i__2 = j * b_dim1 + 1;
+ z_div(&z__1, &b[j * b_dim1 + 1], &d__[1]);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ if (*n > 1) {
+ i__2 = j * b_dim1 + 2;
+ i__3 = j * b_dim1 + 2;
+ i__4 = j * b_dim1 + 1;
+ z__3.r = du[1].r * b[i__4].r - du[1].i * b[i__4].i,
+ z__3.i = du[1].r * b[i__4].i + du[1].i * b[i__4]
+ .r;
+ z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i;
+ z_div(&z__1, &z__2, &d__[2]);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ }
+ i__2 = *n;
+ for (i__ = 3; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ - 1;
+ i__6 = i__ - 1 + j * b_dim1;
+ z__4.r = du[i__5].r * b[i__6].r - du[i__5].i * b[i__6].i,
+ z__4.i = du[i__5].r * b[i__6].i + du[i__5].i * b[
+ i__6].r;
+ z__3.r = b[i__4].r - z__4.r, z__3.i = b[i__4].i - z__4.i;
+ i__7 = i__ - 2;
+ i__8 = i__ - 2 + j * b_dim1;
+ z__5.r = du2[i__7].r * b[i__8].r - du2[i__7].i * b[i__8]
+ .i, z__5.i = du2[i__7].r * b[i__8].i + du2[i__7]
+ .i * b[i__8].r;
+ z__2.r = z__3.r - z__5.r, z__2.i = z__3.i - z__5.i;
+ z_div(&z__1, &z__2, &d__[i__]);
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L100: */
+ }
+
+/* Solve L**T * x = b. */
+
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ if (ipiv[i__] == i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ i__5 = i__ + 1 + j * b_dim1;
+ z__2.r = dl[i__4].r * b[i__5].r - dl[i__4].i * b[i__5]
+ .i, z__2.i = dl[i__4].r * b[i__5].i + dl[i__4]
+ .i * b[i__5].r;
+ z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i -
+ z__2.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ } else {
+ i__2 = i__ + 1 + j * b_dim1;
+ temp.r = b[i__2].r, temp.i = b[i__2].i;
+ i__2 = i__ + 1 + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ z__2.r = dl[i__4].r * temp.r - dl[i__4].i * temp.i,
+ z__2.i = dl[i__4].r * temp.i + dl[i__4].i *
+ temp.r;
+ z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i -
+ z__2.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = i__ + j * b_dim1;
+ b[i__2].r = temp.r, b[i__2].i = temp.i;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+ }
+ } else {
+
+/* Solve A**H * X = B. */
+
+ if (*nrhs <= 1) {
+ j = 1;
+L130:
+
+/* Solve U**H * x = b. */
+
+ i__1 = j * b_dim1 + 1;
+ d_cnjg(&z__2, &d__[1]);
+ z_div(&z__1, &b[j * b_dim1 + 1], &z__2);
+ b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+ if (*n > 1) {
+ i__1 = j * b_dim1 + 2;
+ i__2 = j * b_dim1 + 2;
+ d_cnjg(&z__4, &du[1]);
+ i__3 = j * b_dim1 + 1;
+ z__3.r = z__4.r * b[i__3].r - z__4.i * b[i__3].i, z__3.i =
+ z__4.r * b[i__3].i + z__4.i * b[i__3].r;
+ z__2.r = b[i__2].r - z__3.r, z__2.i = b[i__2].i - z__3.i;
+ d_cnjg(&z__5, &d__[2]);
+ z_div(&z__1, &z__2, &z__5);
+ b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+ }
+ i__1 = *n;
+ for (i__ = 3; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ d_cnjg(&z__5, &du[i__ - 1]);
+ i__4 = i__ - 1 + j * b_dim1;
+ z__4.r = z__5.r * b[i__4].r - z__5.i * b[i__4].i, z__4.i =
+ z__5.r * b[i__4].i + z__5.i * b[i__4].r;
+ z__3.r = b[i__3].r - z__4.r, z__3.i = b[i__3].i - z__4.i;
+ d_cnjg(&z__7, &du2[i__ - 2]);
+ i__5 = i__ - 2 + j * b_dim1;
+ z__6.r = z__7.r * b[i__5].r - z__7.i * b[i__5].i, z__6.i =
+ z__7.r * b[i__5].i + z__7.i * b[i__5].r;
+ z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
+ d_cnjg(&z__8, &d__[i__]);
+ z_div(&z__1, &z__2, &z__8);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L140: */
+ }
+
+/* Solve L**H * x = b. */
+
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ if (ipiv[i__] == i__) {
+ i__1 = i__ + j * b_dim1;
+ i__2 = i__ + j * b_dim1;
+ d_cnjg(&z__3, &dl[i__]);
+ i__3 = i__ + 1 + j * b_dim1;
+ z__2.r = z__3.r * b[i__3].r - z__3.i * b[i__3].i, z__2.i =
+ z__3.r * b[i__3].i + z__3.i * b[i__3].r;
+ z__1.r = b[i__2].r - z__2.r, z__1.i = b[i__2].i - z__2.i;
+ b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+ } else {
+ i__1 = i__ + 1 + j * b_dim1;
+ temp.r = b[i__1].r, temp.i = b[i__1].i;
+ i__1 = i__ + 1 + j * b_dim1;
+ i__2 = i__ + j * b_dim1;
+ d_cnjg(&z__3, &dl[i__]);
+ z__2.r = z__3.r * temp.r - z__3.i * temp.i, z__2.i =
+ z__3.r * temp.i + z__3.i * temp.r;
+ z__1.r = b[i__2].r - z__2.r, z__1.i = b[i__2].i - z__2.i;
+ b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+ i__1 = i__ + j * b_dim1;
+ b[i__1].r = temp.r, b[i__1].i = temp.i;
+ }
+/* L150: */
+ }
+ if (j < *nrhs) {
+ ++j;
+ goto L130;
+ }
+ } else {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve U**H * x = b. */
+
+ i__2 = j * b_dim1 + 1;
+ d_cnjg(&z__2, &d__[1]);
+ z_div(&z__1, &b[j * b_dim1 + 1], &z__2);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ if (*n > 1) {
+ i__2 = j * b_dim1 + 2;
+ i__3 = j * b_dim1 + 2;
+ d_cnjg(&z__4, &du[1]);
+ i__4 = j * b_dim1 + 1;
+ z__3.r = z__4.r * b[i__4].r - z__4.i * b[i__4].i, z__3.i =
+ z__4.r * b[i__4].i + z__4.i * b[i__4].r;
+ z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i;
+ d_cnjg(&z__5, &d__[2]);
+ z_div(&z__1, &z__2, &z__5);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ }
+ i__2 = *n;
+ for (i__ = 3; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ d_cnjg(&z__5, &du[i__ - 1]);
+ i__5 = i__ - 1 + j * b_dim1;
+ z__4.r = z__5.r * b[i__5].r - z__5.i * b[i__5].i, z__4.i =
+ z__5.r * b[i__5].i + z__5.i * b[i__5].r;
+ z__3.r = b[i__4].r - z__4.r, z__3.i = b[i__4].i - z__4.i;
+ d_cnjg(&z__7, &du2[i__ - 2]);
+ i__6 = i__ - 2 + j * b_dim1;
+ z__6.r = z__7.r * b[i__6].r - z__7.i * b[i__6].i, z__6.i =
+ z__7.r * b[i__6].i + z__7.i * b[i__6].r;
+ z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
+ d_cnjg(&z__8, &d__[i__]);
+ z_div(&z__1, &z__2, &z__8);
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L160: */
+ }
+
+/* Solve L**H * x = b. */
+
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ if (ipiv[i__] == i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ d_cnjg(&z__3, &dl[i__]);
+ i__4 = i__ + 1 + j * b_dim1;
+ z__2.r = z__3.r * b[i__4].r - z__3.i * b[i__4].i,
+ z__2.i = z__3.r * b[i__4].i + z__3.i * b[i__4]
+ .r;
+ z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i -
+ z__2.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ } else {
+ i__2 = i__ + 1 + j * b_dim1;
+ temp.r = b[i__2].r, temp.i = b[i__2].i;
+ i__2 = i__ + 1 + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ d_cnjg(&z__3, &dl[i__]);
+ z__2.r = z__3.r * temp.r - z__3.i * temp.i, z__2.i =
+ z__3.r * temp.i + z__3.i * temp.r;
+ z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i -
+ z__2.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = i__ + j * b_dim1;
+ b[i__2].r = temp.r, b[i__2].i = temp.i;
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+ }
+
+/* End of ZGTTS2 */
+
+ return 0;
+} /* zgtts2_ */
diff --git a/SRC/zhbev.c b/SRC/zhbev.c
new file mode 100644
index 0000000..3195188
--- /dev/null
+++ b/SRC/zhbev.c
@@ -0,0 +1,273 @@
+/* zhbev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b11 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int zhbev_(char *jobz, char *uplo, integer *n, integer *kd,
+ doublecomplex *ab, integer *ldab, doublereal *w, doublecomplex *z__,
+ integer *ldz, doublecomplex *work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, z_dim1, z_offset, i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal eps;
+ integer inde;
+ doublereal anrm;
+ integer imax;
+ doublereal rmin, rmax;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical lower, wantz;
+ extern doublereal dlamch_(char *);
+ integer iscale;
+ doublereal safmin;
+ extern doublereal zlanhb_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
+ integer *), zlascl_(char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublecomplex *, integer *,
+ integer *), zhbtrd_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ integer indrwk;
+ doublereal smlnum;
+ extern /* Subroutine */ int zsteqr_(char *, integer *, doublereal *,
+ doublereal *, doublecomplex *, integer *, doublereal *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHBEV computes all the eigenvalues and, optionally, eigenvectors of */
+/* a complex Hermitian band matrix A. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) COMPLEX*16 array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, AB is overwritten by values generated during the */
+/* reduction to tridiagonal form. If UPLO = 'U', the first */
+/* superdiagonal and the diagonal of the tridiagonal matrix T */
+/* are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */
+/* the diagonal and first subdiagonal of T are returned in the */
+/* first two rows of AB. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD + 1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX*16 array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
+/* eigenvectors of the matrix A, with the i-th column of Z */
+/* holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1,3*N-2)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of an intermediate tridiagonal */
+/* form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ lower = lsame_(uplo, "L");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kd < 0) {
+ *info = -4;
+ } else if (*ldab < *kd + 1) {
+ *info = -6;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -9;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHBEV ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (lower) {
+ i__1 = ab_dim1 + 1;
+ w[1] = ab[i__1].r;
+ } else {
+ i__1 = *kd + 1 + ab_dim1;
+ w[1] = ab[i__1].r;
+ }
+ if (wantz) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1., z__[i__1].i = 0.;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = zlanhb_("M", uplo, n, kd, &ab[ab_offset], ldab, &rwork[1]);
+ iscale = 0;
+ if (anrm > 0. && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ if (lower) {
+ zlascl_("B", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ } else {
+ zlascl_("Q", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ }
+ }
+
+/* Call ZHBTRD to reduce Hermitian band matrix to tridiagonal form. */
+
+ inde = 1;
+ zhbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &rwork[inde], &
+ z__[z_offset], ldz, &work[1], &iinfo);
+
+/* For eigenvalues only, call DSTERF. For eigenvectors, call ZSTEQR. */
+
+ if (! wantz) {
+ dsterf_(n, &w[1], &rwork[inde], info);
+ } else {
+ indrwk = inde + *n;
+ zsteqr_(jobz, n, &w[1], &rwork[inde], &z__[z_offset], ldz, &rwork[
+ indrwk], info);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *n;
+ } else {
+ imax = *info - 1;
+ }
+ d__1 = 1. / sigma;
+ dscal_(&imax, &d__1, &w[1], &c__1);
+ }
+
+ return 0;
+
+/* End of ZHBEV */
+
+} /* zhbev_ */
diff --git a/SRC/zhbevd.c b/SRC/zhbevd.c
new file mode 100644
index 0000000..dc58f4b
--- /dev/null
+++ b/SRC/zhbevd.c
@@ -0,0 +1,381 @@
+/* zhbevd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static doublereal c_b13 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int zhbevd_(char *jobz, char *uplo, integer *n, integer *kd,
+ doublecomplex *ab, integer *ldab, doublereal *w, doublecomplex *z__,
+ integer *ldz, doublecomplex *work, integer *lwork, doublereal *rwork,
+ integer *lrwork, integer *iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, z_dim1, z_offset, i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal eps;
+ integer inde;
+ doublereal anrm;
+ integer imax;
+ doublereal rmin, rmax;
+ integer llwk2;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer lwmin;
+ logical lower;
+ integer llrwk;
+ logical wantz;
+ integer indwk2;
+ extern doublereal dlamch_(char *);
+ integer iscale;
+ doublereal safmin;
+ extern doublereal zlanhb_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
+ integer *), zlascl_(char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublecomplex *, integer *,
+ integer *), zstedc_(char *, integer *, doublereal *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, integer *, integer *, integer *, integer
+ *), zhbtrd_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ integer indwrk, liwmin;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ integer lrwmin;
+ doublereal smlnum;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHBEVD computes all the eigenvalues and, optionally, eigenvectors of */
+/* a complex Hermitian band matrix A. If eigenvectors are desired, it */
+/* uses a divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) COMPLEX*16 array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, AB is overwritten by values generated during the */
+/* reduction to tridiagonal form. If UPLO = 'U', the first */
+/* superdiagonal and the diagonal of the tridiagonal matrix T */
+/* are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */
+/* the diagonal and first subdiagonal of T are returned in the */
+/* first two rows of AB. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD + 1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX*16 array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
+/* eigenvectors of the matrix A, with the i-th column of Z */
+/* holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If N <= 1, LWORK must be at least 1. */
+/* If JOBZ = 'N' and N > 1, LWORK must be at least N. */
+/* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N**2. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK, RWORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* RWORK (workspace/output) DOUBLE PRECISION array, */
+/* dimension (LRWORK) */
+/* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. */
+
+/* LRWORK (input) INTEGER */
+/* The dimension of array RWORK. */
+/* If N <= 1, LRWORK must be at least 1. */
+/* If JOBZ = 'N' and N > 1, LRWORK must be at least N. */
+/* If JOBZ = 'V' and N > 1, LRWORK must be at least */
+/* 1 + 5*N + 2*N**2. */
+
+/* If LRWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of array IWORK. */
+/* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. */
+/* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N . */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of an intermediate tridiagonal */
+/* form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ lower = lsame_(uplo, "L");
+ lquery = *lwork == -1 || *liwork == -1 || *lrwork == -1;
+
+ *info = 0;
+ if (*n <= 1) {
+ lwmin = 1;
+ lrwmin = 1;
+ liwmin = 1;
+ } else {
+ if (wantz) {
+/* Computing 2nd power */
+ i__1 = *n;
+ lwmin = i__1 * i__1 << 1;
+/* Computing 2nd power */
+ i__1 = *n;
+ lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
+ liwmin = *n * 5 + 3;
+ } else {
+ lwmin = *n;
+ lrwmin = *n;
+ liwmin = 1;
+ }
+ }
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kd < 0) {
+ *info = -4;
+ } else if (*ldab < *kd + 1) {
+ *info = -6;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -9;
+ }
+
+ if (*info == 0) {
+ work[1].r = (doublereal) lwmin, work[1].i = 0.;
+ rwork[1] = (doublereal) lrwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -11;
+ } else if (*lrwork < lrwmin && ! lquery) {
+ *info = -13;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -15;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHBEVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ i__1 = ab_dim1 + 1;
+ w[1] = ab[i__1].r;
+ if (wantz) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1., z__[i__1].i = 0.;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = zlanhb_("M", uplo, n, kd, &ab[ab_offset], ldab, &rwork[1]);
+ iscale = 0;
+ if (anrm > 0. && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ if (lower) {
+ zlascl_("B", kd, kd, &c_b13, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ } else {
+ zlascl_("Q", kd, kd, &c_b13, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ }
+ }
+
+/* Call ZHBTRD to reduce Hermitian band matrix to tridiagonal form. */
+
+ inde = 1;
+ indwrk = inde + *n;
+ indwk2 = *n * *n + 1;
+ llwk2 = *lwork - indwk2 + 1;
+ llrwk = *lrwork - indwrk + 1;
+ zhbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &rwork[inde], &
+ z__[z_offset], ldz, &work[1], &iinfo);
+
+/* For eigenvalues only, call DSTERF. For eigenvectors, call ZSTEDC. */
+
+ if (! wantz) {
+ dsterf_(n, &w[1], &rwork[inde], info);
+ } else {
+ zstedc_("I", n, &w[1], &rwork[inde], &work[1], n, &work[indwk2], &
+ llwk2, &rwork[indwrk], &llrwk, &iwork[1], liwork, info);
+ zgemm_("N", "N", n, n, n, &c_b2, &z__[z_offset], ldz, &work[1], n, &
+ c_b1, &work[indwk2], n);
+ zlacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *n;
+ } else {
+ imax = *info - 1;
+ }
+ d__1 = 1. / sigma;
+ dscal_(&imax, &d__1, &w[1], &c__1);
+ }
+
+ work[1].r = (doublereal) lwmin, work[1].i = 0.;
+ rwork[1] = (doublereal) lrwmin;
+ iwork[1] = liwmin;
+ return 0;
+
+/* End of ZHBEVD */
+
+} /* zhbevd_ */
diff --git a/SRC/zhbevx.c b/SRC/zhbevx.c
new file mode 100644
index 0000000..2c4bde8
--- /dev/null
+++ b/SRC/zhbevx.c
@@ -0,0 +1,527 @@
+/* zhbevx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static doublereal c_b16 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int zhbevx_(char *jobz, char *range, char *uplo, integer *n,
+ integer *kd, doublecomplex *ab, integer *ldab, doublecomplex *q,
+ integer *ldq, doublereal *vl, doublereal *vu, integer *il, integer *
+ iu, doublereal *abstol, integer *m, doublereal *w, doublecomplex *z__,
+ integer *ldz, doublecomplex *work, doublereal *rwork, integer *iwork,
+ integer *ifail, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, q_dim1, q_offset, z_dim1, z_offset, i__1,
+ i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, jj;
+ doublereal eps, vll, vuu, tmp1;
+ integer indd, inde;
+ doublereal anrm;
+ integer imax;
+ doublereal rmin, rmax;
+ logical test;
+ doublecomplex ctmp1;
+ integer itmp1, indee;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ char order[1];
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical lower;
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ logical wantz;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ logical alleig, indeig;
+ integer iscale, indibl;
+ logical valeig;
+ doublereal safmin;
+ extern doublereal zlanhb_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal abstll, bignum;
+ integer indiwk, indisp;
+ extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
+ integer *), zlascl_(char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublecomplex *, integer *,
+ integer *), dstebz_(char *, char *, integer *, doublereal
+ *, doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, integer *),
+ zhbtrd_(char *, char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ integer indrwk, indwrk;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ integer nsplit;
+ doublereal smlnum;
+ extern /* Subroutine */ int zstein_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *, integer *, integer *, integer *),
+ zsteqr_(char *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublereal *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHBEVX computes selected eigenvalues and, optionally, eigenvectors */
+/* of a complex Hermitian band matrix A. Eigenvalues and eigenvectors */
+/* can be selected by specifying either a range of values or a range of */
+/* indices for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found; */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found; */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) COMPLEX*16 array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, AB is overwritten by values generated during the */
+/* reduction to tridiagonal form. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD + 1. */
+
+/* Q (output) COMPLEX*16 array, dimension (LDQ, N) */
+/* If JOBZ = 'V', the N-by-N unitary matrix used in the */
+/* reduction to tridiagonal form. */
+/* If JOBZ = 'N', the array Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. If JOBZ = 'V', then */
+/* LDQ >= max(1,N). */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) DOUBLE PRECISION */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing AB to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*DLAMCH('S'). */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices */
+/* with Guaranteed High Relative Accuracy," by Demmel and */
+/* Kahan, LAPACK Working Note #3. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* The first M elements contain the selected eigenvalues in */
+/* ascending order. */
+
+/* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M)) */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If an eigenvector fails to converge, then that column of Z */
+/* contains the latest approximation to the eigenvector, and the */
+/* index of the eigenvector is returned in IFAIL. */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, then i eigenvectors failed to converge. */
+/* Their indices are stored in array IFAIL. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+ lower = lsame_(uplo, "L");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*kd < 0) {
+ *info = -5;
+ } else if (*ldab < *kd + 1) {
+ *info = -7;
+ } else if (wantz && *ldq < max(1,*n)) {
+ *info = -9;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -11;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -12;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -13;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -18;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHBEVX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ *m = 1;
+ if (lower) {
+ i__1 = ab_dim1 + 1;
+ ctmp1.r = ab[i__1].r, ctmp1.i = ab[i__1].i;
+ } else {
+ i__1 = *kd + 1 + ab_dim1;
+ ctmp1.r = ab[i__1].r, ctmp1.i = ab[i__1].i;
+ }
+ tmp1 = ctmp1.r;
+ if (valeig) {
+ if (! (*vl < tmp1 && *vu >= tmp1)) {
+ *m = 0;
+ }
+ }
+ if (*m == 1) {
+ w[1] = ctmp1.r;
+ if (wantz) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1., z__[i__1].i = 0.;
+ }
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
+ rmax = min(d__1,d__2);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ abstll = *abstol;
+ if (valeig) {
+ vll = *vl;
+ vuu = *vu;
+ } else {
+ vll = 0.;
+ vuu = 0.;
+ }
+ anrm = zlanhb_("M", uplo, n, kd, &ab[ab_offset], ldab, &rwork[1]);
+ if (anrm > 0. && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ if (lower) {
+ zlascl_("B", kd, kd, &c_b16, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ } else {
+ zlascl_("Q", kd, kd, &c_b16, &sigma, n, n, &ab[ab_offset], ldab,
+ info);
+ }
+ if (*abstol > 0.) {
+ abstll = *abstol * sigma;
+ }
+ if (valeig) {
+ vll = *vl * sigma;
+ vuu = *vu * sigma;
+ }
+ }
+
+/* Call ZHBTRD to reduce Hermitian band matrix to tridiagonal form. */
+
+ indd = 1;
+ inde = indd + *n;
+ indrwk = inde + *n;
+ indwrk = 1;
+ zhbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &rwork[indd], &rwork[
+ inde], &q[q_offset], ldq, &work[indwrk], &iinfo);
+
+/* If all eigenvalues are desired and ABSTOL is less than or equal */
+/* to zero, then call DSTERF or ZSTEQR. If this fails for some */
+/* eigenvalue, then try DSTEBZ. */
+
+ test = FALSE_;
+ if (indeig) {
+ if (*il == 1 && *iu == *n) {
+ test = TRUE_;
+ }
+ }
+ if ((alleig || test) && *abstol <= 0.) {
+ dcopy_(n, &rwork[indd], &c__1, &w[1], &c__1);
+ indee = indrwk + (*n << 1);
+ if (! wantz) {
+ i__1 = *n - 1;
+ dcopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
+ dsterf_(n, &w[1], &rwork[indee], info);
+ } else {
+ zlacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz);
+ i__1 = *n - 1;
+ dcopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
+ zsteqr_(jobz, n, &w[1], &rwork[indee], &z__[z_offset], ldz, &
+ rwork[indrwk], info);
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ifail[i__] = 0;
+/* L10: */
+ }
+ }
+ }
+ if (*info == 0) {
+ *m = *n;
+ goto L30;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ indibl = 1;
+ indisp = indibl + *n;
+ indiwk = indisp + *n;
+ dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], &
+ rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &
+ rwork[indrwk], &iwork[indiwk], info);
+
+ if (wantz) {
+ zstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], &
+ iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[
+ indiwk], &ifail[1], info);
+
+/* Apply unitary matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by ZSTEIN. */
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1);
+ zgemv_("N", n, n, &c_b2, &q[q_offset], ldq, &work[1], &c__1, &
+ c_b1, &z__[j * z_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+L30:
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *m;
+ } else {
+ imax = *info - 1;
+ }
+ d__1 = 1. / sigma;
+ dscal_(&imax, &d__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L40: */
+ }
+
+ if (i__ != 0) {
+ itmp1 = iwork[indibl + i__ - 1];
+ w[i__] = w[j];
+ iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
+ w[j] = tmp1;
+ iwork[indibl + j - 1] = itmp1;
+ zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ if (*info != 0) {
+ itmp1 = ifail[i__];
+ ifail[i__] = ifail[j];
+ ifail[j] = itmp1;
+ }
+ }
+/* L50: */
+ }
+ }
+
+ return 0;
+
+/* End of ZHBEVX */
+
+} /* zhbevx_ */
diff --git a/SRC/zhbgst.c b/SRC/zhbgst.c
new file mode 100644
index 0000000..59ec866
--- /dev/null
+++ b/SRC/zhbgst.c
@@ -0,0 +1,2152 @@
+/* zhbgst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zhbgst_(char *vect, char *uplo, integer *n, integer *ka,
+ integer *kb, doublecomplex *ab, integer *ldab, doublecomplex *bb,
+ integer *ldbb, doublecomplex *x, integer *ldx, doublecomplex *work,
+ doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, bb_dim1, bb_offset, x_dim1, x_offset, i__1,
+ i__2, i__3, i__4, i__5, i__6, i__7, i__8;
+ doublereal d__1;
+ doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8, z__9, z__10;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, l, m;
+ doublecomplex t;
+ integer i0, i1, i2, j1, j2;
+ doublecomplex ra;
+ integer nr, nx, ka1, kb1;
+ doublecomplex ra1;
+ integer j1t, j2t;
+ doublereal bii;
+ integer kbt, nrt, inca;
+ extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int zgeru_(integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ logical wantx;
+ extern /* Subroutine */ int zlar2v_(integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *), xerbla_(char *, integer *),
+ zdscal_(integer *, doublereal *, doublecomplex *, integer *);
+ logical update;
+ extern /* Subroutine */ int zlacgv_(integer *, doublecomplex *, integer *)
+ , zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *), zlartg_(
+ doublecomplex *, doublecomplex *, doublereal *, doublecomplex *,
+ doublecomplex *), zlargv_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, integer *), zlartv_(
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublecomplex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHBGST reduces a complex Hermitian-definite banded generalized */
+/* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y, */
+/* such that C has the same bandwidth as A. */
+
+/* B must have been previously factorized as S**H*S by ZPBSTF, using a */
+/* split Cholesky factorization. A is overwritten by C = X**H*A*X, where */
+/* X = S**(-1)*Q and Q is a unitary matrix chosen to preserve the */
+/* bandwidth of A. */
+
+/* Arguments */
+/* ========= */
+
+/* VECT (input) CHARACTER*1 */
+/* = 'N': do not form the transformation matrix X; */
+/* = 'V': form X. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* KA (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */
+
+/* KB (input) INTEGER */
+/* The number of superdiagonals of the matrix B if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0. */
+
+/* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first ka+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */
+
+/* On exit, the transformed matrix X**H*A*X, stored in the same */
+/* format as A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KA+1. */
+
+/* BB (input) COMPLEX*16 array, dimension (LDBB,N) */
+/* The banded factor S from the split Cholesky factorization of */
+/* B, as returned by ZPBSTF, stored in the first kb+1 rows of */
+/* the array. */
+
+/* LDBB (input) INTEGER */
+/* The leading dimension of the array BB. LDBB >= KB+1. */
+
+/* X (output) COMPLEX*16 array, dimension (LDX,N) */
+/* If VECT = 'V', the n-by-n matrix X. */
+/* If VECT = 'N', the array X is not referenced. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. */
+/* LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ bb_dim1 = *ldbb;
+ bb_offset = 1 + bb_dim1;
+ bb -= bb_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ wantx = lsame_(vect, "V");
+ upper = lsame_(uplo, "U");
+ ka1 = *ka + 1;
+ kb1 = *kb + 1;
+ *info = 0;
+ if (! wantx && ! lsame_(vect, "N")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ka < 0) {
+ *info = -4;
+ } else if (*kb < 0 || *kb > *ka) {
+ *info = -5;
+ } else if (*ldab < *ka + 1) {
+ *info = -7;
+ } else if (*ldbb < *kb + 1) {
+ *info = -9;
+ } else if (*ldx < 1 || wantx && *ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHBGST", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ inca = *ldab * ka1;
+
+/* Initialize X to the unit matrix, if needed */
+
+ if (wantx) {
+ zlaset_("Full", n, n, &c_b1, &c_b2, &x[x_offset], ldx);
+ }
+
+/* Set M to the splitting point m. It must be the same value as is */
+/* used in ZPBSTF. The chosen value allows the arrays WORK and RWORK */
+/* to be of dimension (N). */
+
+ m = (*n + *kb) / 2;
+
+/* The routine works in two phases, corresponding to the two halves */
+/* of the split Cholesky factorization of B as S**H*S where */
+
+/* S = ( U ) */
+/* ( M L ) */
+
+/* with U upper triangular of order m, and L lower triangular of */
+/* order n-m. S has the same bandwidth as B. */
+
+/* S is treated as a product of elementary matrices: */
+
+/* S = S(m)*S(m-1)*...*S(2)*S(1)*S(m+1)*S(m+2)*...*S(n-1)*S(n) */
+
+/* where S(i) is determined by the i-th row of S. */
+
+/* In phase 1, the index i takes the values n, n-1, ... , m+1; */
+/* in phase 2, it takes the values 1, 2, ... , m. */
+
+/* For each value of i, the current matrix A is updated by forming */
+/* inv(S(i))**H*A*inv(S(i)). This creates a triangular bulge outside */
+/* the band of A. The bulge is then pushed down toward the bottom of */
+/* A in phase 1, and up toward the top of A in phase 2, by applying */
+/* plane rotations. */
+
+/* There are kb*(kb+1)/2 elements in the bulge, but at most 2*kb-1 */
+/* of them are linearly independent, so annihilating a bulge requires */
+/* only 2*kb-1 plane rotations. The rotations are divided into a 1st */
+/* set of kb-1 rotations, and a 2nd set of kb rotations. */
+
+/* Wherever possible, rotations are generated and applied in vector */
+/* operations of length NR between the indices J1 and J2 (sometimes */
+/* replaced by modified values NRT, J1T or J2T). */
+
+/* The real cosines and complex sines of the rotations are stored in */
+/* the arrays RWORK and WORK, those of the 1st set in elements */
+/* 2:m-kb-1, and those of the 2nd set in elements m-kb+1:n. */
+
+/* The bulges are not formed explicitly; nonzero elements outside the */
+/* band are created only when they are required for generating new */
+/* rotations; they are stored in the array WORK, in positions where */
+/* they are later overwritten by the sines of the rotations which */
+/* annihilate them. */
+
+/* **************************** Phase 1 ***************************** */
+
+/* The logical structure of this phase is: */
+
+/* UPDATE = .TRUE. */
+/* DO I = N, M + 1, -1 */
+/* use S(i) to update A and create a new bulge */
+/* apply rotations to push all bulges KA positions downward */
+/* END DO */
+/* UPDATE = .FALSE. */
+/* DO I = M + KA + 1, N - 1 */
+/* apply rotations to push all bulges KA positions downward */
+/* END DO */
+
+/* To avoid duplicating code, the two loops are merged. */
+
+ update = TRUE_;
+ i__ = *n + 1;
+L10:
+ if (update) {
+ --i__;
+/* Computing MIN */
+ i__1 = *kb, i__2 = i__ - 1;
+ kbt = min(i__1,i__2);
+ i0 = i__ - 1;
+/* Computing MIN */
+ i__1 = *n, i__2 = i__ + *ka;
+ i1 = min(i__1,i__2);
+ i2 = i__ - kbt + ka1;
+ if (i__ < m + 1) {
+ update = FALSE_;
+ ++i__;
+ i0 = m;
+ if (*ka == 0) {
+ goto L480;
+ }
+ goto L10;
+ }
+ } else {
+ i__ += *ka;
+ if (i__ > *n - 1) {
+ goto L480;
+ }
+ }
+
+ if (upper) {
+
+/* Transform A, working with the upper triangle */
+
+ if (update) {
+
+/* Form inv(S(i))**H * A * inv(S(i)) */
+
+ i__1 = kb1 + i__ * bb_dim1;
+ bii = bb[i__1].r;
+ i__1 = ka1 + i__ * ab_dim1;
+ i__2 = ka1 + i__ * ab_dim1;
+ d__1 = ab[i__2].r / bii / bii;
+ ab[i__1].r = d__1, ab[i__1].i = 0.;
+ i__1 = i1;
+ for (j = i__ + 1; j <= i__1; ++j) {
+ i__2 = i__ - j + ka1 + j * ab_dim1;
+ i__3 = i__ - j + ka1 + j * ab_dim1;
+ z__1.r = ab[i__3].r / bii, z__1.i = ab[i__3].i / bii;
+ ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
+/* L20: */
+ }
+/* Computing MAX */
+ i__1 = 1, i__2 = i__ - *ka;
+ i__3 = i__ - 1;
+ for (j = max(i__1,i__2); j <= i__3; ++j) {
+ i__1 = j - i__ + ka1 + i__ * ab_dim1;
+ i__2 = j - i__ + ka1 + i__ * ab_dim1;
+ z__1.r = ab[i__2].r / bii, z__1.i = ab[i__2].i / bii;
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+/* L30: */
+ }
+ i__3 = i__ - 1;
+ for (k = i__ - kbt; k <= i__3; ++k) {
+ i__1 = k;
+ for (j = i__ - kbt; j <= i__1; ++j) {
+ i__2 = j - k + ka1 + k * ab_dim1;
+ i__4 = j - k + ka1 + k * ab_dim1;
+ i__5 = j - i__ + kb1 + i__ * bb_dim1;
+ d_cnjg(&z__5, &ab[k - i__ + ka1 + i__ * ab_dim1]);
+ z__4.r = bb[i__5].r * z__5.r - bb[i__5].i * z__5.i,
+ z__4.i = bb[i__5].r * z__5.i + bb[i__5].i *
+ z__5.r;
+ z__3.r = ab[i__4].r - z__4.r, z__3.i = ab[i__4].i -
+ z__4.i;
+ d_cnjg(&z__7, &bb[k - i__ + kb1 + i__ * bb_dim1]);
+ i__6 = j - i__ + ka1 + i__ * ab_dim1;
+ z__6.r = z__7.r * ab[i__6].r - z__7.i * ab[i__6].i,
+ z__6.i = z__7.r * ab[i__6].i + z__7.i * ab[i__6]
+ .r;
+ z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
+ i__7 = ka1 + i__ * ab_dim1;
+ d__1 = ab[i__7].r;
+ i__8 = j - i__ + kb1 + i__ * bb_dim1;
+ z__9.r = d__1 * bb[i__8].r, z__9.i = d__1 * bb[i__8].i;
+ d_cnjg(&z__10, &bb[k - i__ + kb1 + i__ * bb_dim1]);
+ z__8.r = z__9.r * z__10.r - z__9.i * z__10.i, z__8.i =
+ z__9.r * z__10.i + z__9.i * z__10.r;
+ z__1.r = z__2.r + z__8.r, z__1.i = z__2.i + z__8.i;
+ ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
+/* L40: */
+ }
+/* Computing MAX */
+ i__1 = 1, i__2 = i__ - *ka;
+ i__4 = i__ - kbt - 1;
+ for (j = max(i__1,i__2); j <= i__4; ++j) {
+ i__1 = j - k + ka1 + k * ab_dim1;
+ i__2 = j - k + ka1 + k * ab_dim1;
+ d_cnjg(&z__3, &bb[k - i__ + kb1 + i__ * bb_dim1]);
+ i__5 = j - i__ + ka1 + i__ * ab_dim1;
+ z__2.r = z__3.r * ab[i__5].r - z__3.i * ab[i__5].i,
+ z__2.i = z__3.r * ab[i__5].i + z__3.i * ab[i__5]
+ .r;
+ z__1.r = ab[i__2].r - z__2.r, z__1.i = ab[i__2].i -
+ z__2.i;
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+/* L50: */
+ }
+/* L60: */
+ }
+ i__3 = i1;
+ for (j = i__; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = j - *ka, i__1 = i__ - kbt;
+ i__2 = i__ - 1;
+ for (k = max(i__4,i__1); k <= i__2; ++k) {
+ i__4 = k - j + ka1 + j * ab_dim1;
+ i__1 = k - j + ka1 + j * ab_dim1;
+ i__5 = k - i__ + kb1 + i__ * bb_dim1;
+ i__6 = i__ - j + ka1 + j * ab_dim1;
+ z__2.r = bb[i__5].r * ab[i__6].r - bb[i__5].i * ab[i__6]
+ .i, z__2.i = bb[i__5].r * ab[i__6].i + bb[i__5].i
+ * ab[i__6].r;
+ z__1.r = ab[i__1].r - z__2.r, z__1.i = ab[i__1].i -
+ z__2.i;
+ ab[i__4].r = z__1.r, ab[i__4].i = z__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by inv(S(i)) */
+
+ i__3 = *n - m;
+ d__1 = 1. / bii;
+ zdscal_(&i__3, &d__1, &x[m + 1 + i__ * x_dim1], &c__1);
+ if (kbt > 0) {
+ i__3 = *n - m;
+ z__1.r = -1., z__1.i = -0.;
+ zgerc_(&i__3, &kbt, &z__1, &x[m + 1 + i__ * x_dim1], &
+ c__1, &bb[kb1 - kbt + i__ * bb_dim1], &c__1, &x[m
+ + 1 + (i__ - kbt) * x_dim1], ldx);
+ }
+ }
+
+/* store a(i,i1) in RA1 for use in next loop over K */
+
+ i__3 = i__ - i1 + ka1 + i1 * ab_dim1;
+ ra1.r = ab[i__3].r, ra1.i = ab[i__3].i;
+ }
+
+/* Generate and apply vectors of rotations to chase all the */
+/* existing bulges KA positions down toward the bottom of the */
+/* band */
+
+ i__3 = *kb - 1;
+ for (k = 1; k <= i__3; ++k) {
+ if (update) {
+
+/* Determine the rotations which would annihilate the bulge */
+/* which has in theory just been created */
+
+ if (i__ - k + *ka < *n && i__ - k > 1) {
+
+/* generate rotation to annihilate a(i,i-k+ka+1) */
+
+ zlartg_(&ab[k + 1 + (i__ - k + *ka) * ab_dim1], &ra1, &
+ rwork[i__ - k + *ka - m], &work[i__ - k + *ka - m]
+, &ra);
+
+/* create nonzero element a(i-k,i-k+ka+1) outside the */
+/* band and store it in WORK(i-k) */
+
+ i__2 = kb1 - k + i__ * bb_dim1;
+ z__2.r = -bb[i__2].r, z__2.i = -bb[i__2].i;
+ z__1.r = z__2.r * ra1.r - z__2.i * ra1.i, z__1.i = z__2.r
+ * ra1.i + z__2.i * ra1.r;
+ t.r = z__1.r, t.i = z__1.i;
+ i__2 = i__ - k;
+ i__4 = i__ - k + *ka - m;
+ z__2.r = rwork[i__4] * t.r, z__2.i = rwork[i__4] * t.i;
+ d_cnjg(&z__4, &work[i__ - k + *ka - m]);
+ i__1 = (i__ - k + *ka) * ab_dim1 + 1;
+ z__3.r = z__4.r * ab[i__1].r - z__4.i * ab[i__1].i,
+ z__3.i = z__4.r * ab[i__1].i + z__4.i * ab[i__1]
+ .r;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ i__2 = (i__ - k + *ka) * ab_dim1 + 1;
+ i__4 = i__ - k + *ka - m;
+ z__2.r = work[i__4].r * t.r - work[i__4].i * t.i, z__2.i =
+ work[i__4].r * t.i + work[i__4].i * t.r;
+ i__1 = i__ - k + *ka - m;
+ i__5 = (i__ - k + *ka) * ab_dim1 + 1;
+ z__3.r = rwork[i__1] * ab[i__5].r, z__3.i = rwork[i__1] *
+ ab[i__5].i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
+ ra1.r = ra.r, ra1.i = ra.i;
+ }
+ }
+/* Computing MAX */
+ i__2 = 1, i__4 = k - i0 + 2;
+ j2 = i__ - k - 1 + max(i__2,i__4) * ka1;
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ if (update) {
+/* Computing MAX */
+ i__2 = j2, i__4 = i__ + (*ka << 1) - k + 1;
+ j2t = max(i__2,i__4);
+ } else {
+ j2t = j2;
+ }
+ nrt = (*n - j2t + *ka) / ka1;
+ i__2 = j1;
+ i__4 = ka1;
+ for (j = j2t; i__4 < 0 ? j >= i__2 : j <= i__2; j += i__4) {
+
+/* create nonzero element a(j-ka,j+1) outside the band */
+/* and store it in WORK(j-m) */
+
+ i__1 = j - m;
+ i__5 = j - m;
+ i__6 = (j + 1) * ab_dim1 + 1;
+ z__1.r = work[i__5].r * ab[i__6].r - work[i__5].i * ab[i__6]
+ .i, z__1.i = work[i__5].r * ab[i__6].i + work[i__5].i
+ * ab[i__6].r;
+ work[i__1].r = z__1.r, work[i__1].i = z__1.i;
+ i__1 = (j + 1) * ab_dim1 + 1;
+ i__5 = j - m;
+ i__6 = (j + 1) * ab_dim1 + 1;
+ z__1.r = rwork[i__5] * ab[i__6].r, z__1.i = rwork[i__5] * ab[
+ i__6].i;
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+/* L90: */
+ }
+
+/* generate rotations in 1st set to annihilate elements which */
+/* have been created outside the band */
+
+ if (nrt > 0) {
+ zlargv_(&nrt, &ab[j2t * ab_dim1 + 1], &inca, &work[j2t - m], &
+ ka1, &rwork[j2t - m], &ka1);
+ }
+ if (nr > 0) {
+
+/* apply rotations in 1st set from the right */
+
+ i__4 = *ka - 1;
+ for (l = 1; l <= i__4; ++l) {
+ zlartv_(&nr, &ab[ka1 - l + j2 * ab_dim1], &inca, &ab[*ka
+ - l + (j2 + 1) * ab_dim1], &inca, &rwork[j2 - m],
+ &work[j2 - m], &ka1);
+/* L100: */
+ }
+
+/* apply rotations in 1st set from both sides to diagonal */
+/* blocks */
+
+ zlar2v_(&nr, &ab[ka1 + j2 * ab_dim1], &ab[ka1 + (j2 + 1) *
+ ab_dim1], &ab[*ka + (j2 + 1) * ab_dim1], &inca, &
+ rwork[j2 - m], &work[j2 - m], &ka1);
+
+ zlacgv_(&nr, &work[j2 - m], &ka1);
+ }
+
+/* start applying rotations in 1st set from the left */
+
+ i__4 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__4; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ zlartv_(&nrt, &ab[l + (j2 + ka1 - l) * ab_dim1], &inca, &
+ ab[l + 1 + (j2 + ka1 - l) * ab_dim1], &inca, &
+ rwork[j2 - m], &work[j2 - m], &ka1);
+ }
+/* L110: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 1st set */
+
+ i__4 = j1;
+ i__2 = ka1;
+ for (j = j2; i__2 < 0 ? j >= i__4 : j <= i__4; j += i__2) {
+ i__1 = *n - m;
+ d_cnjg(&z__1, &work[j - m]);
+ zrot_(&i__1, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j
+ + 1) * x_dim1], &c__1, &rwork[j - m], &z__1);
+/* L120: */
+ }
+ }
+/* L130: */
+ }
+
+ if (update) {
+ if (i2 <= *n && kbt > 0) {
+
+/* create nonzero element a(i-kbt,i-kbt+ka+1) outside the */
+/* band and store it in WORK(i-kbt) */
+
+ i__3 = i__ - kbt;
+ i__2 = kb1 - kbt + i__ * bb_dim1;
+ z__2.r = -bb[i__2].r, z__2.i = -bb[i__2].i;
+ z__1.r = z__2.r * ra1.r - z__2.i * ra1.i, z__1.i = z__2.r *
+ ra1.i + z__2.i * ra1.r;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ }
+ }
+
+ for (k = *kb; k >= 1; --k) {
+ if (update) {
+/* Computing MAX */
+ i__3 = 2, i__2 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__3,i__2) * ka1;
+ } else {
+/* Computing MAX */
+ i__3 = 1, i__2 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__3,i__2) * ka1;
+ }
+
+/* finish applying rotations in 2nd set from the left */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (*n - j2 + *ka + l) / ka1;
+ if (nrt > 0) {
+ zlartv_(&nrt, &ab[l + (j2 - l + 1) * ab_dim1], &inca, &ab[
+ l + 1 + (j2 - l + 1) * ab_dim1], &inca, &rwork[j2
+ - *ka], &work[j2 - *ka], &ka1);
+ }
+/* L140: */
+ }
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ i__3 = j2;
+ i__2 = -ka1;
+ for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2) {
+ i__4 = j;
+ i__1 = j - *ka;
+ work[i__4].r = work[i__1].r, work[i__4].i = work[i__1].i;
+ rwork[j] = rwork[j - *ka];
+/* L150: */
+ }
+ i__2 = j1;
+ i__3 = ka1;
+ for (j = j2; i__3 < 0 ? j >= i__2 : j <= i__2; j += i__3) {
+
+/* create nonzero element a(j-ka,j+1) outside the band */
+/* and store it in WORK(j) */
+
+ i__4 = j;
+ i__1 = j;
+ i__5 = (j + 1) * ab_dim1 + 1;
+ z__1.r = work[i__1].r * ab[i__5].r - work[i__1].i * ab[i__5]
+ .i, z__1.i = work[i__1].r * ab[i__5].i + work[i__1].i
+ * ab[i__5].r;
+ work[i__4].r = z__1.r, work[i__4].i = z__1.i;
+ i__4 = (j + 1) * ab_dim1 + 1;
+ i__1 = j;
+ i__5 = (j + 1) * ab_dim1 + 1;
+ z__1.r = rwork[i__1] * ab[i__5].r, z__1.i = rwork[i__1] * ab[
+ i__5].i;
+ ab[i__4].r = z__1.r, ab[i__4].i = z__1.i;
+/* L160: */
+ }
+ if (update) {
+ if (i__ - k < *n - *ka && k <= kbt) {
+ i__3 = i__ - k + *ka;
+ i__2 = i__ - k;
+ work[i__3].r = work[i__2].r, work[i__3].i = work[i__2].i;
+ }
+ }
+/* L170: */
+ }
+
+ for (k = *kb; k >= 1; --k) {
+/* Computing MAX */
+ i__3 = 1, i__2 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__3,i__2) * ka1;
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ if (nr > 0) {
+
+/* generate rotations in 2nd set to annihilate elements */
+/* which have been created outside the band */
+
+ zlargv_(&nr, &ab[j2 * ab_dim1 + 1], &inca, &work[j2], &ka1, &
+ rwork[j2], &ka1);
+
+/* apply rotations in 2nd set from the right */
+
+ i__3 = *ka - 1;
+ for (l = 1; l <= i__3; ++l) {
+ zlartv_(&nr, &ab[ka1 - l + j2 * ab_dim1], &inca, &ab[*ka
+ - l + (j2 + 1) * ab_dim1], &inca, &rwork[j2], &
+ work[j2], &ka1);
+/* L180: */
+ }
+
+/* apply rotations in 2nd set from both sides to diagonal */
+/* blocks */
+
+ zlar2v_(&nr, &ab[ka1 + j2 * ab_dim1], &ab[ka1 + (j2 + 1) *
+ ab_dim1], &ab[*ka + (j2 + 1) * ab_dim1], &inca, &
+ rwork[j2], &work[j2], &ka1);
+
+ zlacgv_(&nr, &work[j2], &ka1);
+ }
+
+/* start applying rotations in 2nd set from the left */
+
+ i__3 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__3; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ zlartv_(&nrt, &ab[l + (j2 + ka1 - l) * ab_dim1], &inca, &
+ ab[l + 1 + (j2 + ka1 - l) * ab_dim1], &inca, &
+ rwork[j2], &work[j2], &ka1);
+ }
+/* L190: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 2nd set */
+
+ i__3 = j1;
+ i__2 = ka1;
+ for (j = j2; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2) {
+ i__4 = *n - m;
+ d_cnjg(&z__1, &work[j]);
+ zrot_(&i__4, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j
+ + 1) * x_dim1], &c__1, &rwork[j], &z__1);
+/* L200: */
+ }
+ }
+/* L210: */
+ }
+
+ i__2 = *kb - 1;
+ for (k = 1; k <= i__2; ++k) {
+/* Computing MAX */
+ i__3 = 1, i__4 = k - i0 + 2;
+ j2 = i__ - k - 1 + max(i__3,i__4) * ka1;
+
+/* finish applying rotations in 1st set from the left */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ zlartv_(&nrt, &ab[l + (j2 + ka1 - l) * ab_dim1], &inca, &
+ ab[l + 1 + (j2 + ka1 - l) * ab_dim1], &inca, &
+ rwork[j2 - m], &work[j2 - m], &ka1);
+ }
+/* L220: */
+ }
+/* L230: */
+ }
+
+ if (*kb > 1) {
+ i__2 = i2 + *ka;
+ for (j = *n - 1; j >= i__2; --j) {
+ rwork[j - m] = rwork[j - *ka - m];
+ i__3 = j - m;
+ i__4 = j - *ka - m;
+ work[i__3].r = work[i__4].r, work[i__3].i = work[i__4].i;
+/* L240: */
+ }
+ }
+
+ } else {
+
+/* Transform A, working with the lower triangle */
+
+ if (update) {
+
+/* Form inv(S(i))**H * A * inv(S(i)) */
+
+ i__2 = i__ * bb_dim1 + 1;
+ bii = bb[i__2].r;
+ i__2 = i__ * ab_dim1 + 1;
+ i__3 = i__ * ab_dim1 + 1;
+ d__1 = ab[i__3].r / bii / bii;
+ ab[i__2].r = d__1, ab[i__2].i = 0.;
+ i__2 = i1;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j - i__ + 1 + i__ * ab_dim1;
+ i__4 = j - i__ + 1 + i__ * ab_dim1;
+ z__1.r = ab[i__4].r / bii, z__1.i = ab[i__4].i / bii;
+ ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
+/* L250: */
+ }
+/* Computing MAX */
+ i__2 = 1, i__3 = i__ - *ka;
+ i__4 = i__ - 1;
+ for (j = max(i__2,i__3); j <= i__4; ++j) {
+ i__2 = i__ - j + 1 + j * ab_dim1;
+ i__3 = i__ - j + 1 + j * ab_dim1;
+ z__1.r = ab[i__3].r / bii, z__1.i = ab[i__3].i / bii;
+ ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
+/* L260: */
+ }
+ i__4 = i__ - 1;
+ for (k = i__ - kbt; k <= i__4; ++k) {
+ i__2 = k;
+ for (j = i__ - kbt; j <= i__2; ++j) {
+ i__3 = k - j + 1 + j * ab_dim1;
+ i__1 = k - j + 1 + j * ab_dim1;
+ i__5 = i__ - j + 1 + j * bb_dim1;
+ d_cnjg(&z__5, &ab[i__ - k + 1 + k * ab_dim1]);
+ z__4.r = bb[i__5].r * z__5.r - bb[i__5].i * z__5.i,
+ z__4.i = bb[i__5].r * z__5.i + bb[i__5].i *
+ z__5.r;
+ z__3.r = ab[i__1].r - z__4.r, z__3.i = ab[i__1].i -
+ z__4.i;
+ d_cnjg(&z__7, &bb[i__ - k + 1 + k * bb_dim1]);
+ i__6 = i__ - j + 1 + j * ab_dim1;
+ z__6.r = z__7.r * ab[i__6].r - z__7.i * ab[i__6].i,
+ z__6.i = z__7.r * ab[i__6].i + z__7.i * ab[i__6]
+ .r;
+ z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
+ i__7 = i__ * ab_dim1 + 1;
+ d__1 = ab[i__7].r;
+ i__8 = i__ - j + 1 + j * bb_dim1;
+ z__9.r = d__1 * bb[i__8].r, z__9.i = d__1 * bb[i__8].i;
+ d_cnjg(&z__10, &bb[i__ - k + 1 + k * bb_dim1]);
+ z__8.r = z__9.r * z__10.r - z__9.i * z__10.i, z__8.i =
+ z__9.r * z__10.i + z__9.i * z__10.r;
+ z__1.r = z__2.r + z__8.r, z__1.i = z__2.i + z__8.i;
+ ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
+/* L270: */
+ }
+/* Computing MAX */
+ i__2 = 1, i__3 = i__ - *ka;
+ i__1 = i__ - kbt - 1;
+ for (j = max(i__2,i__3); j <= i__1; ++j) {
+ i__2 = k - j + 1 + j * ab_dim1;
+ i__3 = k - j + 1 + j * ab_dim1;
+ d_cnjg(&z__3, &bb[i__ - k + 1 + k * bb_dim1]);
+ i__5 = i__ - j + 1 + j * ab_dim1;
+ z__2.r = z__3.r * ab[i__5].r - z__3.i * ab[i__5].i,
+ z__2.i = z__3.r * ab[i__5].i + z__3.i * ab[i__5]
+ .r;
+ z__1.r = ab[i__3].r - z__2.r, z__1.i = ab[i__3].i -
+ z__2.i;
+ ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
+/* L280: */
+ }
+/* L290: */
+ }
+ i__4 = i1;
+ for (j = i__; j <= i__4; ++j) {
+/* Computing MAX */
+ i__1 = j - *ka, i__2 = i__ - kbt;
+ i__3 = i__ - 1;
+ for (k = max(i__1,i__2); k <= i__3; ++k) {
+ i__1 = j - k + 1 + k * ab_dim1;
+ i__2 = j - k + 1 + k * ab_dim1;
+ i__5 = i__ - k + 1 + k * bb_dim1;
+ i__6 = j - i__ + 1 + i__ * ab_dim1;
+ z__2.r = bb[i__5].r * ab[i__6].r - bb[i__5].i * ab[i__6]
+ .i, z__2.i = bb[i__5].r * ab[i__6].i + bb[i__5].i
+ * ab[i__6].r;
+ z__1.r = ab[i__2].r - z__2.r, z__1.i = ab[i__2].i -
+ z__2.i;
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+/* L300: */
+ }
+/* L310: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by inv(S(i)) */
+
+ i__4 = *n - m;
+ d__1 = 1. / bii;
+ zdscal_(&i__4, &d__1, &x[m + 1 + i__ * x_dim1], &c__1);
+ if (kbt > 0) {
+ i__4 = *n - m;
+ z__1.r = -1., z__1.i = -0.;
+ i__3 = *ldbb - 1;
+ zgeru_(&i__4, &kbt, &z__1, &x[m + 1 + i__ * x_dim1], &
+ c__1, &bb[kbt + 1 + (i__ - kbt) * bb_dim1], &i__3,
+ &x[m + 1 + (i__ - kbt) * x_dim1], ldx);
+ }
+ }
+
+/* store a(i1,i) in RA1 for use in next loop over K */
+
+ i__4 = i1 - i__ + 1 + i__ * ab_dim1;
+ ra1.r = ab[i__4].r, ra1.i = ab[i__4].i;
+ }
+
+/* Generate and apply vectors of rotations to chase all the */
+/* existing bulges KA positions down toward the bottom of the */
+/* band */
+
+ i__4 = *kb - 1;
+ for (k = 1; k <= i__4; ++k) {
+ if (update) {
+
+/* Determine the rotations which would annihilate the bulge */
+/* which has in theory just been created */
+
+ if (i__ - k + *ka < *n && i__ - k > 1) {
+
+/* generate rotation to annihilate a(i-k+ka+1,i) */
+
+ zlartg_(&ab[ka1 - k + i__ * ab_dim1], &ra1, &rwork[i__ -
+ k + *ka - m], &work[i__ - k + *ka - m], &ra);
+
+/* create nonzero element a(i-k+ka+1,i-k) outside the */
+/* band and store it in WORK(i-k) */
+
+ i__3 = k + 1 + (i__ - k) * bb_dim1;
+ z__2.r = -bb[i__3].r, z__2.i = -bb[i__3].i;
+ z__1.r = z__2.r * ra1.r - z__2.i * ra1.i, z__1.i = z__2.r
+ * ra1.i + z__2.i * ra1.r;
+ t.r = z__1.r, t.i = z__1.i;
+ i__3 = i__ - k;
+ i__1 = i__ - k + *ka - m;
+ z__2.r = rwork[i__1] * t.r, z__2.i = rwork[i__1] * t.i;
+ d_cnjg(&z__4, &work[i__ - k + *ka - m]);
+ i__2 = ka1 + (i__ - k) * ab_dim1;
+ z__3.r = z__4.r * ab[i__2].r - z__4.i * ab[i__2].i,
+ z__3.i = z__4.r * ab[i__2].i + z__4.i * ab[i__2]
+ .r;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ i__3 = ka1 + (i__ - k) * ab_dim1;
+ i__1 = i__ - k + *ka - m;
+ z__2.r = work[i__1].r * t.r - work[i__1].i * t.i, z__2.i =
+ work[i__1].r * t.i + work[i__1].i * t.r;
+ i__2 = i__ - k + *ka - m;
+ i__5 = ka1 + (i__ - k) * ab_dim1;
+ z__3.r = rwork[i__2] * ab[i__5].r, z__3.i = rwork[i__2] *
+ ab[i__5].i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
+ ra1.r = ra.r, ra1.i = ra.i;
+ }
+ }
+/* Computing MAX */
+ i__3 = 1, i__1 = k - i0 + 2;
+ j2 = i__ - k - 1 + max(i__3,i__1) * ka1;
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ if (update) {
+/* Computing MAX */
+ i__3 = j2, i__1 = i__ + (*ka << 1) - k + 1;
+ j2t = max(i__3,i__1);
+ } else {
+ j2t = j2;
+ }
+ nrt = (*n - j2t + *ka) / ka1;
+ i__3 = j1;
+ i__1 = ka1;
+ for (j = j2t; i__1 < 0 ? j >= i__3 : j <= i__3; j += i__1) {
+
+/* create nonzero element a(j+1,j-ka) outside the band */
+/* and store it in WORK(j-m) */
+
+ i__2 = j - m;
+ i__5 = j - m;
+ i__6 = ka1 + (j - *ka + 1) * ab_dim1;
+ z__1.r = work[i__5].r * ab[i__6].r - work[i__5].i * ab[i__6]
+ .i, z__1.i = work[i__5].r * ab[i__6].i + work[i__5].i
+ * ab[i__6].r;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ i__2 = ka1 + (j - *ka + 1) * ab_dim1;
+ i__5 = j - m;
+ i__6 = ka1 + (j - *ka + 1) * ab_dim1;
+ z__1.r = rwork[i__5] * ab[i__6].r, z__1.i = rwork[i__5] * ab[
+ i__6].i;
+ ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
+/* L320: */
+ }
+
+/* generate rotations in 1st set to annihilate elements which */
+/* have been created outside the band */
+
+ if (nrt > 0) {
+ zlargv_(&nrt, &ab[ka1 + (j2t - *ka) * ab_dim1], &inca, &work[
+ j2t - m], &ka1, &rwork[j2t - m], &ka1);
+ }
+ if (nr > 0) {
+
+/* apply rotations in 1st set from the left */
+
+ i__1 = *ka - 1;
+ for (l = 1; l <= i__1; ++l) {
+ zlartv_(&nr, &ab[l + 1 + (j2 - l) * ab_dim1], &inca, &ab[
+ l + 2 + (j2 - l) * ab_dim1], &inca, &rwork[j2 - m]
+, &work[j2 - m], &ka1);
+/* L330: */
+ }
+
+/* apply rotations in 1st set from both sides to diagonal */
+/* blocks */
+
+ zlar2v_(&nr, &ab[j2 * ab_dim1 + 1], &ab[(j2 + 1) * ab_dim1 +
+ 1], &ab[j2 * ab_dim1 + 2], &inca, &rwork[j2 - m], &
+ work[j2 - m], &ka1);
+
+ zlacgv_(&nr, &work[j2 - m], &ka1);
+ }
+
+/* start applying rotations in 1st set from the right */
+
+ i__1 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__1; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ zlartv_(&nrt, &ab[ka1 - l + 1 + j2 * ab_dim1], &inca, &ab[
+ ka1 - l + (j2 + 1) * ab_dim1], &inca, &rwork[j2 -
+ m], &work[j2 - m], &ka1);
+ }
+/* L340: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 1st set */
+
+ i__1 = j1;
+ i__3 = ka1;
+ for (j = j2; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) {
+ i__2 = *n - m;
+ zrot_(&i__2, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j
+ + 1) * x_dim1], &c__1, &rwork[j - m], &work[j - m]
+);
+/* L350: */
+ }
+ }
+/* L360: */
+ }
+
+ if (update) {
+ if (i2 <= *n && kbt > 0) {
+
+/* create nonzero element a(i-kbt+ka+1,i-kbt) outside the */
+/* band and store it in WORK(i-kbt) */
+
+ i__4 = i__ - kbt;
+ i__3 = kbt + 1 + (i__ - kbt) * bb_dim1;
+ z__2.r = -bb[i__3].r, z__2.i = -bb[i__3].i;
+ z__1.r = z__2.r * ra1.r - z__2.i * ra1.i, z__1.i = z__2.r *
+ ra1.i + z__2.i * ra1.r;
+ work[i__4].r = z__1.r, work[i__4].i = z__1.i;
+ }
+ }
+
+ for (k = *kb; k >= 1; --k) {
+ if (update) {
+/* Computing MAX */
+ i__4 = 2, i__3 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__4,i__3) * ka1;
+ } else {
+/* Computing MAX */
+ i__4 = 1, i__3 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__4,i__3) * ka1;
+ }
+
+/* finish applying rotations in 2nd set from the right */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (*n - j2 + *ka + l) / ka1;
+ if (nrt > 0) {
+ zlartv_(&nrt, &ab[ka1 - l + 1 + (j2 - *ka) * ab_dim1], &
+ inca, &ab[ka1 - l + (j2 - *ka + 1) * ab_dim1], &
+ inca, &rwork[j2 - *ka], &work[j2 - *ka], &ka1);
+ }
+/* L370: */
+ }
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ i__4 = j2;
+ i__3 = -ka1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) {
+ i__1 = j;
+ i__2 = j - *ka;
+ work[i__1].r = work[i__2].r, work[i__1].i = work[i__2].i;
+ rwork[j] = rwork[j - *ka];
+/* L380: */
+ }
+ i__3 = j1;
+ i__4 = ka1;
+ for (j = j2; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+
+/* create nonzero element a(j+1,j-ka) outside the band */
+/* and store it in WORK(j) */
+
+ i__1 = j;
+ i__2 = j;
+ i__5 = ka1 + (j - *ka + 1) * ab_dim1;
+ z__1.r = work[i__2].r * ab[i__5].r - work[i__2].i * ab[i__5]
+ .i, z__1.i = work[i__2].r * ab[i__5].i + work[i__2].i
+ * ab[i__5].r;
+ work[i__1].r = z__1.r, work[i__1].i = z__1.i;
+ i__1 = ka1 + (j - *ka + 1) * ab_dim1;
+ i__2 = j;
+ i__5 = ka1 + (j - *ka + 1) * ab_dim1;
+ z__1.r = rwork[i__2] * ab[i__5].r, z__1.i = rwork[i__2] * ab[
+ i__5].i;
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+/* L390: */
+ }
+ if (update) {
+ if (i__ - k < *n - *ka && k <= kbt) {
+ i__4 = i__ - k + *ka;
+ i__3 = i__ - k;
+ work[i__4].r = work[i__3].r, work[i__4].i = work[i__3].i;
+ }
+ }
+/* L400: */
+ }
+
+ for (k = *kb; k >= 1; --k) {
+/* Computing MAX */
+ i__4 = 1, i__3 = k - i0 + 1;
+ j2 = i__ - k - 1 + max(i__4,i__3) * ka1;
+ nr = (*n - j2 + *ka) / ka1;
+ j1 = j2 + (nr - 1) * ka1;
+ if (nr > 0) {
+
+/* generate rotations in 2nd set to annihilate elements */
+/* which have been created outside the band */
+
+ zlargv_(&nr, &ab[ka1 + (j2 - *ka) * ab_dim1], &inca, &work[j2]
+, &ka1, &rwork[j2], &ka1);
+
+/* apply rotations in 2nd set from the left */
+
+ i__4 = *ka - 1;
+ for (l = 1; l <= i__4; ++l) {
+ zlartv_(&nr, &ab[l + 1 + (j2 - l) * ab_dim1], &inca, &ab[
+ l + 2 + (j2 - l) * ab_dim1], &inca, &rwork[j2], &
+ work[j2], &ka1);
+/* L410: */
+ }
+
+/* apply rotations in 2nd set from both sides to diagonal */
+/* blocks */
+
+ zlar2v_(&nr, &ab[j2 * ab_dim1 + 1], &ab[(j2 + 1) * ab_dim1 +
+ 1], &ab[j2 * ab_dim1 + 2], &inca, &rwork[j2], &work[
+ j2], &ka1);
+
+ zlacgv_(&nr, &work[j2], &ka1);
+ }
+
+/* start applying rotations in 2nd set from the right */
+
+ i__4 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__4; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ zlartv_(&nrt, &ab[ka1 - l + 1 + j2 * ab_dim1], &inca, &ab[
+ ka1 - l + (j2 + 1) * ab_dim1], &inca, &rwork[j2],
+ &work[j2], &ka1);
+ }
+/* L420: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 2nd set */
+
+ i__4 = j1;
+ i__3 = ka1;
+ for (j = j2; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) {
+ i__1 = *n - m;
+ zrot_(&i__1, &x[m + 1 + j * x_dim1], &c__1, &x[m + 1 + (j
+ + 1) * x_dim1], &c__1, &rwork[j], &work[j]);
+/* L430: */
+ }
+ }
+/* L440: */
+ }
+
+ i__3 = *kb - 1;
+ for (k = 1; k <= i__3; ++k) {
+/* Computing MAX */
+ i__4 = 1, i__1 = k - i0 + 2;
+ j2 = i__ - k - 1 + max(i__4,i__1) * ka1;
+
+/* finish applying rotations in 1st set from the right */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (*n - j2 + l) / ka1;
+ if (nrt > 0) {
+ zlartv_(&nrt, &ab[ka1 - l + 1 + j2 * ab_dim1], &inca, &ab[
+ ka1 - l + (j2 + 1) * ab_dim1], &inca, &rwork[j2 -
+ m], &work[j2 - m], &ka1);
+ }
+/* L450: */
+ }
+/* L460: */
+ }
+
+ if (*kb > 1) {
+ i__3 = i2 + *ka;
+ for (j = *n - 1; j >= i__3; --j) {
+ rwork[j - m] = rwork[j - *ka - m];
+ i__4 = j - m;
+ i__1 = j - *ka - m;
+ work[i__4].r = work[i__1].r, work[i__4].i = work[i__1].i;
+/* L470: */
+ }
+ }
+
+ }
+
+ goto L10;
+
+L480:
+
+/* **************************** Phase 2 ***************************** */
+
+/* The logical structure of this phase is: */
+
+/* UPDATE = .TRUE. */
+/* DO I = 1, M */
+/* use S(i) to update A and create a new bulge */
+/* apply rotations to push all bulges KA positions upward */
+/* END DO */
+/* UPDATE = .FALSE. */
+/* DO I = M - KA - 1, 2, -1 */
+/* apply rotations to push all bulges KA positions upward */
+/* END DO */
+
+/* To avoid duplicating code, the two loops are merged. */
+
+ update = TRUE_;
+ i__ = 0;
+L490:
+ if (update) {
+ ++i__;
+/* Computing MIN */
+ i__3 = *kb, i__4 = m - i__;
+ kbt = min(i__3,i__4);
+ i0 = i__ + 1;
+/* Computing MAX */
+ i__3 = 1, i__4 = i__ - *ka;
+ i1 = max(i__3,i__4);
+ i2 = i__ + kbt - ka1;
+ if (i__ > m) {
+ update = FALSE_;
+ --i__;
+ i0 = m + 1;
+ if (*ka == 0) {
+ return 0;
+ }
+ goto L490;
+ }
+ } else {
+ i__ -= *ka;
+ if (i__ < 2) {
+ return 0;
+ }
+ }
+
+ if (i__ < m - kbt) {
+ nx = m;
+ } else {
+ nx = *n;
+ }
+
+ if (upper) {
+
+/* Transform A, working with the upper triangle */
+
+ if (update) {
+
+/* Form inv(S(i))**H * A * inv(S(i)) */
+
+ i__3 = kb1 + i__ * bb_dim1;
+ bii = bb[i__3].r;
+ i__3 = ka1 + i__ * ab_dim1;
+ i__4 = ka1 + i__ * ab_dim1;
+ d__1 = ab[i__4].r / bii / bii;
+ ab[i__3].r = d__1, ab[i__3].i = 0.;
+ i__3 = i__ - 1;
+ for (j = i1; j <= i__3; ++j) {
+ i__4 = j - i__ + ka1 + i__ * ab_dim1;
+ i__1 = j - i__ + ka1 + i__ * ab_dim1;
+ z__1.r = ab[i__1].r / bii, z__1.i = ab[i__1].i / bii;
+ ab[i__4].r = z__1.r, ab[i__4].i = z__1.i;
+/* L500: */
+ }
+/* Computing MIN */
+ i__4 = *n, i__1 = i__ + *ka;
+ i__3 = min(i__4,i__1);
+ for (j = i__ + 1; j <= i__3; ++j) {
+ i__4 = i__ - j + ka1 + j * ab_dim1;
+ i__1 = i__ - j + ka1 + j * ab_dim1;
+ z__1.r = ab[i__1].r / bii, z__1.i = ab[i__1].i / bii;
+ ab[i__4].r = z__1.r, ab[i__4].i = z__1.i;
+/* L510: */
+ }
+ i__3 = i__ + kbt;
+ for (k = i__ + 1; k <= i__3; ++k) {
+ i__4 = i__ + kbt;
+ for (j = k; j <= i__4; ++j) {
+ i__1 = k - j + ka1 + j * ab_dim1;
+ i__2 = k - j + ka1 + j * ab_dim1;
+ i__5 = i__ - j + kb1 + j * bb_dim1;
+ d_cnjg(&z__5, &ab[i__ - k + ka1 + k * ab_dim1]);
+ z__4.r = bb[i__5].r * z__5.r - bb[i__5].i * z__5.i,
+ z__4.i = bb[i__5].r * z__5.i + bb[i__5].i *
+ z__5.r;
+ z__3.r = ab[i__2].r - z__4.r, z__3.i = ab[i__2].i -
+ z__4.i;
+ d_cnjg(&z__7, &bb[i__ - k + kb1 + k * bb_dim1]);
+ i__6 = i__ - j + ka1 + j * ab_dim1;
+ z__6.r = z__7.r * ab[i__6].r - z__7.i * ab[i__6].i,
+ z__6.i = z__7.r * ab[i__6].i + z__7.i * ab[i__6]
+ .r;
+ z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
+ i__7 = ka1 + i__ * ab_dim1;
+ d__1 = ab[i__7].r;
+ i__8 = i__ - j + kb1 + j * bb_dim1;
+ z__9.r = d__1 * bb[i__8].r, z__9.i = d__1 * bb[i__8].i;
+ d_cnjg(&z__10, &bb[i__ - k + kb1 + k * bb_dim1]);
+ z__8.r = z__9.r * z__10.r - z__9.i * z__10.i, z__8.i =
+ z__9.r * z__10.i + z__9.i * z__10.r;
+ z__1.r = z__2.r + z__8.r, z__1.i = z__2.i + z__8.i;
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+/* L520: */
+ }
+/* Computing MIN */
+ i__1 = *n, i__2 = i__ + *ka;
+ i__4 = min(i__1,i__2);
+ for (j = i__ + kbt + 1; j <= i__4; ++j) {
+ i__1 = k - j + ka1 + j * ab_dim1;
+ i__2 = k - j + ka1 + j * ab_dim1;
+ d_cnjg(&z__3, &bb[i__ - k + kb1 + k * bb_dim1]);
+ i__5 = i__ - j + ka1 + j * ab_dim1;
+ z__2.r = z__3.r * ab[i__5].r - z__3.i * ab[i__5].i,
+ z__2.i = z__3.r * ab[i__5].i + z__3.i * ab[i__5]
+ .r;
+ z__1.r = ab[i__2].r - z__2.r, z__1.i = ab[i__2].i -
+ z__2.i;
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+/* L530: */
+ }
+/* L540: */
+ }
+ i__3 = i__;
+ for (j = i1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__1 = j + *ka, i__2 = i__ + kbt;
+ i__4 = min(i__1,i__2);
+ for (k = i__ + 1; k <= i__4; ++k) {
+ i__1 = j - k + ka1 + k * ab_dim1;
+ i__2 = j - k + ka1 + k * ab_dim1;
+ i__5 = i__ - k + kb1 + k * bb_dim1;
+ i__6 = j - i__ + ka1 + i__ * ab_dim1;
+ z__2.r = bb[i__5].r * ab[i__6].r - bb[i__5].i * ab[i__6]
+ .i, z__2.i = bb[i__5].r * ab[i__6].i + bb[i__5].i
+ * ab[i__6].r;
+ z__1.r = ab[i__2].r - z__2.r, z__1.i = ab[i__2].i -
+ z__2.i;
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+/* L550: */
+ }
+/* L560: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by inv(S(i)) */
+
+ d__1 = 1. / bii;
+ zdscal_(&nx, &d__1, &x[i__ * x_dim1 + 1], &c__1);
+ if (kbt > 0) {
+ z__1.r = -1., z__1.i = -0.;
+ i__3 = *ldbb - 1;
+ zgeru_(&nx, &kbt, &z__1, &x[i__ * x_dim1 + 1], &c__1, &bb[
+ *kb + (i__ + 1) * bb_dim1], &i__3, &x[(i__ + 1) *
+ x_dim1 + 1], ldx);
+ }
+ }
+
+/* store a(i1,i) in RA1 for use in next loop over K */
+
+ i__3 = i1 - i__ + ka1 + i__ * ab_dim1;
+ ra1.r = ab[i__3].r, ra1.i = ab[i__3].i;
+ }
+
+/* Generate and apply vectors of rotations to chase all the */
+/* existing bulges KA positions up toward the top of the band */
+
+ i__3 = *kb - 1;
+ for (k = 1; k <= i__3; ++k) {
+ if (update) {
+
+/* Determine the rotations which would annihilate the bulge */
+/* which has in theory just been created */
+
+ if (i__ + k - ka1 > 0 && i__ + k < m) {
+
+/* generate rotation to annihilate a(i+k-ka-1,i) */
+
+ zlartg_(&ab[k + 1 + i__ * ab_dim1], &ra1, &rwork[i__ + k
+ - *ka], &work[i__ + k - *ka], &ra);
+
+/* create nonzero element a(i+k-ka-1,i+k) outside the */
+/* band and store it in WORK(m-kb+i+k) */
+
+ i__4 = kb1 - k + (i__ + k) * bb_dim1;
+ z__2.r = -bb[i__4].r, z__2.i = -bb[i__4].i;
+ z__1.r = z__2.r * ra1.r - z__2.i * ra1.i, z__1.i = z__2.r
+ * ra1.i + z__2.i * ra1.r;
+ t.r = z__1.r, t.i = z__1.i;
+ i__4 = m - *kb + i__ + k;
+ i__1 = i__ + k - *ka;
+ z__2.r = rwork[i__1] * t.r, z__2.i = rwork[i__1] * t.i;
+ d_cnjg(&z__4, &work[i__ + k - *ka]);
+ i__2 = (i__ + k) * ab_dim1 + 1;
+ z__3.r = z__4.r * ab[i__2].r - z__4.i * ab[i__2].i,
+ z__3.i = z__4.r * ab[i__2].i + z__4.i * ab[i__2]
+ .r;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ work[i__4].r = z__1.r, work[i__4].i = z__1.i;
+ i__4 = (i__ + k) * ab_dim1 + 1;
+ i__1 = i__ + k - *ka;
+ z__2.r = work[i__1].r * t.r - work[i__1].i * t.i, z__2.i =
+ work[i__1].r * t.i + work[i__1].i * t.r;
+ i__2 = i__ + k - *ka;
+ i__5 = (i__ + k) * ab_dim1 + 1;
+ z__3.r = rwork[i__2] * ab[i__5].r, z__3.i = rwork[i__2] *
+ ab[i__5].i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ ab[i__4].r = z__1.r, ab[i__4].i = z__1.i;
+ ra1.r = ra.r, ra1.i = ra.i;
+ }
+ }
+/* Computing MAX */
+ i__4 = 1, i__1 = k + i0 - m + 1;
+ j2 = i__ + k + 1 - max(i__4,i__1) * ka1;
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ if (update) {
+/* Computing MIN */
+ i__4 = j2, i__1 = i__ - (*ka << 1) + k - 1;
+ j2t = min(i__4,i__1);
+ } else {
+ j2t = j2;
+ }
+ nrt = (j2t + *ka - 1) / ka1;
+ i__4 = j2t;
+ i__1 = ka1;
+ for (j = j1; i__1 < 0 ? j >= i__4 : j <= i__4; j += i__1) {
+
+/* create nonzero element a(j-1,j+ka) outside the band */
+/* and store it in WORK(j) */
+
+ i__2 = j;
+ i__5 = j;
+ i__6 = (j + *ka - 1) * ab_dim1 + 1;
+ z__1.r = work[i__5].r * ab[i__6].r - work[i__5].i * ab[i__6]
+ .i, z__1.i = work[i__5].r * ab[i__6].i + work[i__5].i
+ * ab[i__6].r;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ i__2 = (j + *ka - 1) * ab_dim1 + 1;
+ i__5 = j;
+ i__6 = (j + *ka - 1) * ab_dim1 + 1;
+ z__1.r = rwork[i__5] * ab[i__6].r, z__1.i = rwork[i__5] * ab[
+ i__6].i;
+ ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
+/* L570: */
+ }
+
+/* generate rotations in 1st set to annihilate elements which */
+/* have been created outside the band */
+
+ if (nrt > 0) {
+ zlargv_(&nrt, &ab[(j1 + *ka) * ab_dim1 + 1], &inca, &work[j1],
+ &ka1, &rwork[j1], &ka1);
+ }
+ if (nr > 0) {
+
+/* apply rotations in 1st set from the left */
+
+ i__1 = *ka - 1;
+ for (l = 1; l <= i__1; ++l) {
+ zlartv_(&nr, &ab[ka1 - l + (j1 + l) * ab_dim1], &inca, &
+ ab[*ka - l + (j1 + l) * ab_dim1], &inca, &rwork[
+ j1], &work[j1], &ka1);
+/* L580: */
+ }
+
+/* apply rotations in 1st set from both sides to diagonal */
+/* blocks */
+
+ zlar2v_(&nr, &ab[ka1 + j1 * ab_dim1], &ab[ka1 + (j1 - 1) *
+ ab_dim1], &ab[*ka + j1 * ab_dim1], &inca, &rwork[j1],
+ &work[j1], &ka1);
+
+ zlacgv_(&nr, &work[j1], &ka1);
+ }
+
+/* start applying rotations in 1st set from the right */
+
+ i__1 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__1; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ zlartv_(&nrt, &ab[l + j1t * ab_dim1], &inca, &ab[l + 1 + (
+ j1t - 1) * ab_dim1], &inca, &rwork[j1t], &work[
+ j1t], &ka1);
+ }
+/* L590: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 1st set */
+
+ i__1 = j2;
+ i__4 = ka1;
+ for (j = j1; i__4 < 0 ? j >= i__1 : j <= i__1; j += i__4) {
+ zrot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1
+ + 1], &c__1, &rwork[j], &work[j]);
+/* L600: */
+ }
+ }
+/* L610: */
+ }
+
+ if (update) {
+ if (i2 > 0 && kbt > 0) {
+
+/* create nonzero element a(i+kbt-ka-1,i+kbt) outside the */
+/* band and store it in WORK(m-kb+i+kbt) */
+
+ i__3 = m - *kb + i__ + kbt;
+ i__4 = kb1 - kbt + (i__ + kbt) * bb_dim1;
+ z__2.r = -bb[i__4].r, z__2.i = -bb[i__4].i;
+ z__1.r = z__2.r * ra1.r - z__2.i * ra1.i, z__1.i = z__2.r *
+ ra1.i + z__2.i * ra1.r;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ }
+ }
+
+ for (k = *kb; k >= 1; --k) {
+ if (update) {
+/* Computing MAX */
+ i__3 = 2, i__4 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__3,i__4) * ka1;
+ } else {
+/* Computing MAX */
+ i__3 = 1, i__4 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__3,i__4) * ka1;
+ }
+
+/* finish applying rotations in 2nd set from the right */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (j2 + *ka + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ zlartv_(&nrt, &ab[l + (j1t + *ka) * ab_dim1], &inca, &ab[
+ l + 1 + (j1t + *ka - 1) * ab_dim1], &inca, &rwork[
+ m - *kb + j1t + *ka], &work[m - *kb + j1t + *ka],
+ &ka1);
+ }
+/* L620: */
+ }
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ i__3 = j2;
+ i__4 = ka1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+ i__1 = m - *kb + j;
+ i__2 = m - *kb + j + *ka;
+ work[i__1].r = work[i__2].r, work[i__1].i = work[i__2].i;
+ rwork[m - *kb + j] = rwork[m - *kb + j + *ka];
+/* L630: */
+ }
+ i__4 = j2;
+ i__3 = ka1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) {
+
+/* create nonzero element a(j-1,j+ka) outside the band */
+/* and store it in WORK(m-kb+j) */
+
+ i__1 = m - *kb + j;
+ i__2 = m - *kb + j;
+ i__5 = (j + *ka - 1) * ab_dim1 + 1;
+ z__1.r = work[i__2].r * ab[i__5].r - work[i__2].i * ab[i__5]
+ .i, z__1.i = work[i__2].r * ab[i__5].i + work[i__2].i
+ * ab[i__5].r;
+ work[i__1].r = z__1.r, work[i__1].i = z__1.i;
+ i__1 = (j + *ka - 1) * ab_dim1 + 1;
+ i__2 = m - *kb + j;
+ i__5 = (j + *ka - 1) * ab_dim1 + 1;
+ z__1.r = rwork[i__2] * ab[i__5].r, z__1.i = rwork[i__2] * ab[
+ i__5].i;
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+/* L640: */
+ }
+ if (update) {
+ if (i__ + k > ka1 && k <= kbt) {
+ i__3 = m - *kb + i__ + k - *ka;
+ i__4 = m - *kb + i__ + k;
+ work[i__3].r = work[i__4].r, work[i__3].i = work[i__4].i;
+ }
+ }
+/* L650: */
+ }
+
+ for (k = *kb; k >= 1; --k) {
+/* Computing MAX */
+ i__3 = 1, i__4 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__3,i__4) * ka1;
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ if (nr > 0) {
+
+/* generate rotations in 2nd set to annihilate elements */
+/* which have been created outside the band */
+
+ zlargv_(&nr, &ab[(j1 + *ka) * ab_dim1 + 1], &inca, &work[m - *
+ kb + j1], &ka1, &rwork[m - *kb + j1], &ka1);
+
+/* apply rotations in 2nd set from the left */
+
+ i__3 = *ka - 1;
+ for (l = 1; l <= i__3; ++l) {
+ zlartv_(&nr, &ab[ka1 - l + (j1 + l) * ab_dim1], &inca, &
+ ab[*ka - l + (j1 + l) * ab_dim1], &inca, &rwork[m
+ - *kb + j1], &work[m - *kb + j1], &ka1);
+/* L660: */
+ }
+
+/* apply rotations in 2nd set from both sides to diagonal */
+/* blocks */
+
+ zlar2v_(&nr, &ab[ka1 + j1 * ab_dim1], &ab[ka1 + (j1 - 1) *
+ ab_dim1], &ab[*ka + j1 * ab_dim1], &inca, &rwork[m - *
+ kb + j1], &work[m - *kb + j1], &ka1);
+
+ zlacgv_(&nr, &work[m - *kb + j1], &ka1);
+ }
+
+/* start applying rotations in 2nd set from the right */
+
+ i__3 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__3; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ zlartv_(&nrt, &ab[l + j1t * ab_dim1], &inca, &ab[l + 1 + (
+ j1t - 1) * ab_dim1], &inca, &rwork[m - *kb + j1t],
+ &work[m - *kb + j1t], &ka1);
+ }
+/* L670: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 2nd set */
+
+ i__3 = j2;
+ i__4 = ka1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+ zrot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1
+ + 1], &c__1, &rwork[m - *kb + j], &work[m - *kb +
+ j]);
+/* L680: */
+ }
+ }
+/* L690: */
+ }
+
+ i__4 = *kb - 1;
+ for (k = 1; k <= i__4; ++k) {
+/* Computing MAX */
+ i__3 = 1, i__1 = k + i0 - m + 1;
+ j2 = i__ + k + 1 - max(i__3,i__1) * ka1;
+
+/* finish applying rotations in 1st set from the right */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ zlartv_(&nrt, &ab[l + j1t * ab_dim1], &inca, &ab[l + 1 + (
+ j1t - 1) * ab_dim1], &inca, &rwork[j1t], &work[
+ j1t], &ka1);
+ }
+/* L700: */
+ }
+/* L710: */
+ }
+
+ if (*kb > 1) {
+ i__4 = i2 - *ka;
+ for (j = 2; j <= i__4; ++j) {
+ rwork[j] = rwork[j + *ka];
+ i__3 = j;
+ i__1 = j + *ka;
+ work[i__3].r = work[i__1].r, work[i__3].i = work[i__1].i;
+/* L720: */
+ }
+ }
+
+ } else {
+
+/* Transform A, working with the lower triangle */
+
+ if (update) {
+
+/* Form inv(S(i))**H * A * inv(S(i)) */
+
+ i__4 = i__ * bb_dim1 + 1;
+ bii = bb[i__4].r;
+ i__4 = i__ * ab_dim1 + 1;
+ i__3 = i__ * ab_dim1 + 1;
+ d__1 = ab[i__3].r / bii / bii;
+ ab[i__4].r = d__1, ab[i__4].i = 0.;
+ i__4 = i__ - 1;
+ for (j = i1; j <= i__4; ++j) {
+ i__3 = i__ - j + 1 + j * ab_dim1;
+ i__1 = i__ - j + 1 + j * ab_dim1;
+ z__1.r = ab[i__1].r / bii, z__1.i = ab[i__1].i / bii;
+ ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
+/* L730: */
+ }
+/* Computing MIN */
+ i__3 = *n, i__1 = i__ + *ka;
+ i__4 = min(i__3,i__1);
+ for (j = i__ + 1; j <= i__4; ++j) {
+ i__3 = j - i__ + 1 + i__ * ab_dim1;
+ i__1 = j - i__ + 1 + i__ * ab_dim1;
+ z__1.r = ab[i__1].r / bii, z__1.i = ab[i__1].i / bii;
+ ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
+/* L740: */
+ }
+ i__4 = i__ + kbt;
+ for (k = i__ + 1; k <= i__4; ++k) {
+ i__3 = i__ + kbt;
+ for (j = k; j <= i__3; ++j) {
+ i__1 = j - k + 1 + k * ab_dim1;
+ i__2 = j - k + 1 + k * ab_dim1;
+ i__5 = j - i__ + 1 + i__ * bb_dim1;
+ d_cnjg(&z__5, &ab[k - i__ + 1 + i__ * ab_dim1]);
+ z__4.r = bb[i__5].r * z__5.r - bb[i__5].i * z__5.i,
+ z__4.i = bb[i__5].r * z__5.i + bb[i__5].i *
+ z__5.r;
+ z__3.r = ab[i__2].r - z__4.r, z__3.i = ab[i__2].i -
+ z__4.i;
+ d_cnjg(&z__7, &bb[k - i__ + 1 + i__ * bb_dim1]);
+ i__6 = j - i__ + 1 + i__ * ab_dim1;
+ z__6.r = z__7.r * ab[i__6].r - z__7.i * ab[i__6].i,
+ z__6.i = z__7.r * ab[i__6].i + z__7.i * ab[i__6]
+ .r;
+ z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
+ i__7 = i__ * ab_dim1 + 1;
+ d__1 = ab[i__7].r;
+ i__8 = j - i__ + 1 + i__ * bb_dim1;
+ z__9.r = d__1 * bb[i__8].r, z__9.i = d__1 * bb[i__8].i;
+ d_cnjg(&z__10, &bb[k - i__ + 1 + i__ * bb_dim1]);
+ z__8.r = z__9.r * z__10.r - z__9.i * z__10.i, z__8.i =
+ z__9.r * z__10.i + z__9.i * z__10.r;
+ z__1.r = z__2.r + z__8.r, z__1.i = z__2.i + z__8.i;
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+/* L750: */
+ }
+/* Computing MIN */
+ i__1 = *n, i__2 = i__ + *ka;
+ i__3 = min(i__1,i__2);
+ for (j = i__ + kbt + 1; j <= i__3; ++j) {
+ i__1 = j - k + 1 + k * ab_dim1;
+ i__2 = j - k + 1 + k * ab_dim1;
+ d_cnjg(&z__3, &bb[k - i__ + 1 + i__ * bb_dim1]);
+ i__5 = j - i__ + 1 + i__ * ab_dim1;
+ z__2.r = z__3.r * ab[i__5].r - z__3.i * ab[i__5].i,
+ z__2.i = z__3.r * ab[i__5].i + z__3.i * ab[i__5]
+ .r;
+ z__1.r = ab[i__2].r - z__2.r, z__1.i = ab[i__2].i -
+ z__2.i;
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+/* L760: */
+ }
+/* L770: */
+ }
+ i__4 = i__;
+ for (j = i1; j <= i__4; ++j) {
+/* Computing MIN */
+ i__1 = j + *ka, i__2 = i__ + kbt;
+ i__3 = min(i__1,i__2);
+ for (k = i__ + 1; k <= i__3; ++k) {
+ i__1 = k - j + 1 + j * ab_dim1;
+ i__2 = k - j + 1 + j * ab_dim1;
+ i__5 = k - i__ + 1 + i__ * bb_dim1;
+ i__6 = i__ - j + 1 + j * ab_dim1;
+ z__2.r = bb[i__5].r * ab[i__6].r - bb[i__5].i * ab[i__6]
+ .i, z__2.i = bb[i__5].r * ab[i__6].i + bb[i__5].i
+ * ab[i__6].r;
+ z__1.r = ab[i__2].r - z__2.r, z__1.i = ab[i__2].i -
+ z__2.i;
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+/* L780: */
+ }
+/* L790: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by inv(S(i)) */
+
+ d__1 = 1. / bii;
+ zdscal_(&nx, &d__1, &x[i__ * x_dim1 + 1], &c__1);
+ if (kbt > 0) {
+ z__1.r = -1., z__1.i = -0.;
+ zgerc_(&nx, &kbt, &z__1, &x[i__ * x_dim1 + 1], &c__1, &bb[
+ i__ * bb_dim1 + 2], &c__1, &x[(i__ + 1) * x_dim1
+ + 1], ldx);
+ }
+ }
+
+/* store a(i,i1) in RA1 for use in next loop over K */
+
+ i__4 = i__ - i1 + 1 + i1 * ab_dim1;
+ ra1.r = ab[i__4].r, ra1.i = ab[i__4].i;
+ }
+
+/* Generate and apply vectors of rotations to chase all the */
+/* existing bulges KA positions up toward the top of the band */
+
+ i__4 = *kb - 1;
+ for (k = 1; k <= i__4; ++k) {
+ if (update) {
+
+/* Determine the rotations which would annihilate the bulge */
+/* which has in theory just been created */
+
+ if (i__ + k - ka1 > 0 && i__ + k < m) {
+
+/* generate rotation to annihilate a(i,i+k-ka-1) */
+
+ zlartg_(&ab[ka1 - k + (i__ + k - *ka) * ab_dim1], &ra1, &
+ rwork[i__ + k - *ka], &work[i__ + k - *ka], &ra);
+
+/* create nonzero element a(i+k,i+k-ka-1) outside the */
+/* band and store it in WORK(m-kb+i+k) */
+
+ i__3 = k + 1 + i__ * bb_dim1;
+ z__2.r = -bb[i__3].r, z__2.i = -bb[i__3].i;
+ z__1.r = z__2.r * ra1.r - z__2.i * ra1.i, z__1.i = z__2.r
+ * ra1.i + z__2.i * ra1.r;
+ t.r = z__1.r, t.i = z__1.i;
+ i__3 = m - *kb + i__ + k;
+ i__1 = i__ + k - *ka;
+ z__2.r = rwork[i__1] * t.r, z__2.i = rwork[i__1] * t.i;
+ d_cnjg(&z__4, &work[i__ + k - *ka]);
+ i__2 = ka1 + (i__ + k - *ka) * ab_dim1;
+ z__3.r = z__4.r * ab[i__2].r - z__4.i * ab[i__2].i,
+ z__3.i = z__4.r * ab[i__2].i + z__4.i * ab[i__2]
+ .r;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ i__3 = ka1 + (i__ + k - *ka) * ab_dim1;
+ i__1 = i__ + k - *ka;
+ z__2.r = work[i__1].r * t.r - work[i__1].i * t.i, z__2.i =
+ work[i__1].r * t.i + work[i__1].i * t.r;
+ i__2 = i__ + k - *ka;
+ i__5 = ka1 + (i__ + k - *ka) * ab_dim1;
+ z__3.r = rwork[i__2] * ab[i__5].r, z__3.i = rwork[i__2] *
+ ab[i__5].i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
+ ra1.r = ra.r, ra1.i = ra.i;
+ }
+ }
+/* Computing MAX */
+ i__3 = 1, i__1 = k + i0 - m + 1;
+ j2 = i__ + k + 1 - max(i__3,i__1) * ka1;
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ if (update) {
+/* Computing MIN */
+ i__3 = j2, i__1 = i__ - (*ka << 1) + k - 1;
+ j2t = min(i__3,i__1);
+ } else {
+ j2t = j2;
+ }
+ nrt = (j2t + *ka - 1) / ka1;
+ i__3 = j2t;
+ i__1 = ka1;
+ for (j = j1; i__1 < 0 ? j >= i__3 : j <= i__3; j += i__1) {
+
+/* create nonzero element a(j+ka,j-1) outside the band */
+/* and store it in WORK(j) */
+
+ i__2 = j;
+ i__5 = j;
+ i__6 = ka1 + (j - 1) * ab_dim1;
+ z__1.r = work[i__5].r * ab[i__6].r - work[i__5].i * ab[i__6]
+ .i, z__1.i = work[i__5].r * ab[i__6].i + work[i__5].i
+ * ab[i__6].r;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ i__2 = ka1 + (j - 1) * ab_dim1;
+ i__5 = j;
+ i__6 = ka1 + (j - 1) * ab_dim1;
+ z__1.r = rwork[i__5] * ab[i__6].r, z__1.i = rwork[i__5] * ab[
+ i__6].i;
+ ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
+/* L800: */
+ }
+
+/* generate rotations in 1st set to annihilate elements which */
+/* have been created outside the band */
+
+ if (nrt > 0) {
+ zlargv_(&nrt, &ab[ka1 + j1 * ab_dim1], &inca, &work[j1], &ka1,
+ &rwork[j1], &ka1);
+ }
+ if (nr > 0) {
+
+/* apply rotations in 1st set from the right */
+
+ i__1 = *ka - 1;
+ for (l = 1; l <= i__1; ++l) {
+ zlartv_(&nr, &ab[l + 1 + j1 * ab_dim1], &inca, &ab[l + 2
+ + (j1 - 1) * ab_dim1], &inca, &rwork[j1], &work[
+ j1], &ka1);
+/* L810: */
+ }
+
+/* apply rotations in 1st set from both sides to diagonal */
+/* blocks */
+
+ zlar2v_(&nr, &ab[j1 * ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 +
+ 1], &ab[(j1 - 1) * ab_dim1 + 2], &inca, &rwork[j1], &
+ work[j1], &ka1);
+
+ zlacgv_(&nr, &work[j1], &ka1);
+ }
+
+/* start applying rotations in 1st set from the left */
+
+ i__1 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__1; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ zlartv_(&nrt, &ab[ka1 - l + 1 + (j1t - ka1 + l) * ab_dim1]
+, &inca, &ab[ka1 - l + (j1t - ka1 + l) * ab_dim1],
+ &inca, &rwork[j1t], &work[j1t], &ka1);
+ }
+/* L820: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 1st set */
+
+ i__1 = j2;
+ i__3 = ka1;
+ for (j = j1; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) {
+ d_cnjg(&z__1, &work[j]);
+ zrot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1
+ + 1], &c__1, &rwork[j], &z__1);
+/* L830: */
+ }
+ }
+/* L840: */
+ }
+
+ if (update) {
+ if (i2 > 0 && kbt > 0) {
+
+/* create nonzero element a(i+kbt,i+kbt-ka-1) outside the */
+/* band and store it in WORK(m-kb+i+kbt) */
+
+ i__4 = m - *kb + i__ + kbt;
+ i__3 = kbt + 1 + i__ * bb_dim1;
+ z__2.r = -bb[i__3].r, z__2.i = -bb[i__3].i;
+ z__1.r = z__2.r * ra1.r - z__2.i * ra1.i, z__1.i = z__2.r *
+ ra1.i + z__2.i * ra1.r;
+ work[i__4].r = z__1.r, work[i__4].i = z__1.i;
+ }
+ }
+
+ for (k = *kb; k >= 1; --k) {
+ if (update) {
+/* Computing MAX */
+ i__4 = 2, i__3 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__4,i__3) * ka1;
+ } else {
+/* Computing MAX */
+ i__4 = 1, i__3 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__4,i__3) * ka1;
+ }
+
+/* finish applying rotations in 2nd set from the left */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (j2 + *ka + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ zlartv_(&nrt, &ab[ka1 - l + 1 + (j1t + l - 1) * ab_dim1],
+ &inca, &ab[ka1 - l + (j1t + l - 1) * ab_dim1], &
+ inca, &rwork[m - *kb + j1t + *ka], &work[m - *kb
+ + j1t + *ka], &ka1);
+ }
+/* L850: */
+ }
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ i__4 = j2;
+ i__3 = ka1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) {
+ i__1 = m - *kb + j;
+ i__2 = m - *kb + j + *ka;
+ work[i__1].r = work[i__2].r, work[i__1].i = work[i__2].i;
+ rwork[m - *kb + j] = rwork[m - *kb + j + *ka];
+/* L860: */
+ }
+ i__3 = j2;
+ i__4 = ka1;
+ for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) {
+
+/* create nonzero element a(j+ka,j-1) outside the band */
+/* and store it in WORK(m-kb+j) */
+
+ i__1 = m - *kb + j;
+ i__2 = m - *kb + j;
+ i__5 = ka1 + (j - 1) * ab_dim1;
+ z__1.r = work[i__2].r * ab[i__5].r - work[i__2].i * ab[i__5]
+ .i, z__1.i = work[i__2].r * ab[i__5].i + work[i__2].i
+ * ab[i__5].r;
+ work[i__1].r = z__1.r, work[i__1].i = z__1.i;
+ i__1 = ka1 + (j - 1) * ab_dim1;
+ i__2 = m - *kb + j;
+ i__5 = ka1 + (j - 1) * ab_dim1;
+ z__1.r = rwork[i__2] * ab[i__5].r, z__1.i = rwork[i__2] * ab[
+ i__5].i;
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+/* L870: */
+ }
+ if (update) {
+ if (i__ + k > ka1 && k <= kbt) {
+ i__4 = m - *kb + i__ + k - *ka;
+ i__3 = m - *kb + i__ + k;
+ work[i__4].r = work[i__3].r, work[i__4].i = work[i__3].i;
+ }
+ }
+/* L880: */
+ }
+
+ for (k = *kb; k >= 1; --k) {
+/* Computing MAX */
+ i__4 = 1, i__3 = k + i0 - m;
+ j2 = i__ + k + 1 - max(i__4,i__3) * ka1;
+ nr = (j2 + *ka - 1) / ka1;
+ j1 = j2 - (nr - 1) * ka1;
+ if (nr > 0) {
+
+/* generate rotations in 2nd set to annihilate elements */
+/* which have been created outside the band */
+
+ zlargv_(&nr, &ab[ka1 + j1 * ab_dim1], &inca, &work[m - *kb +
+ j1], &ka1, &rwork[m - *kb + j1], &ka1);
+
+/* apply rotations in 2nd set from the right */
+
+ i__4 = *ka - 1;
+ for (l = 1; l <= i__4; ++l) {
+ zlartv_(&nr, &ab[l + 1 + j1 * ab_dim1], &inca, &ab[l + 2
+ + (j1 - 1) * ab_dim1], &inca, &rwork[m - *kb + j1]
+, &work[m - *kb + j1], &ka1);
+/* L890: */
+ }
+
+/* apply rotations in 2nd set from both sides to diagonal */
+/* blocks */
+
+ zlar2v_(&nr, &ab[j1 * ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 +
+ 1], &ab[(j1 - 1) * ab_dim1 + 2], &inca, &rwork[m - *
+ kb + j1], &work[m - *kb + j1], &ka1);
+
+ zlacgv_(&nr, &work[m - *kb + j1], &ka1);
+ }
+
+/* start applying rotations in 2nd set from the left */
+
+ i__4 = *kb - k + 1;
+ for (l = *ka - 1; l >= i__4; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ zlartv_(&nrt, &ab[ka1 - l + 1 + (j1t - ka1 + l) * ab_dim1]
+, &inca, &ab[ka1 - l + (j1t - ka1 + l) * ab_dim1],
+ &inca, &rwork[m - *kb + j1t], &work[m - *kb +
+ j1t], &ka1);
+ }
+/* L900: */
+ }
+
+ if (wantx) {
+
+/* post-multiply X by product of rotations in 2nd set */
+
+ i__4 = j2;
+ i__3 = ka1;
+ for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) {
+ d_cnjg(&z__1, &work[m - *kb + j]);
+ zrot_(&nx, &x[j * x_dim1 + 1], &c__1, &x[(j - 1) * x_dim1
+ + 1], &c__1, &rwork[m - *kb + j], &z__1);
+/* L910: */
+ }
+ }
+/* L920: */
+ }
+
+ i__3 = *kb - 1;
+ for (k = 1; k <= i__3; ++k) {
+/* Computing MAX */
+ i__4 = 1, i__1 = k + i0 - m + 1;
+ j2 = i__ + k + 1 - max(i__4,i__1) * ka1;
+
+/* finish applying rotations in 1st set from the left */
+
+ for (l = *kb - k; l >= 1; --l) {
+ nrt = (j2 + l - 1) / ka1;
+ j1t = j2 - (nrt - 1) * ka1;
+ if (nrt > 0) {
+ zlartv_(&nrt, &ab[ka1 - l + 1 + (j1t - ka1 + l) * ab_dim1]
+, &inca, &ab[ka1 - l + (j1t - ka1 + l) * ab_dim1],
+ &inca, &rwork[j1t], &work[j1t], &ka1);
+ }
+/* L930: */
+ }
+/* L940: */
+ }
+
+ if (*kb > 1) {
+ i__3 = i2 - *ka;
+ for (j = 2; j <= i__3; ++j) {
+ rwork[j] = rwork[j + *ka];
+ i__4 = j;
+ i__1 = j + *ka;
+ work[i__4].r = work[i__1].r, work[i__4].i = work[i__1].i;
+/* L950: */
+ }
+ }
+
+ }
+
+ goto L490;
+
+/* End of ZHBGST */
+
+} /* zhbgst_ */
diff --git a/SRC/zhbgv.c b/SRC/zhbgv.c
new file mode 100644
index 0000000..5361f0a
--- /dev/null
+++ b/SRC/zhbgv.c
@@ -0,0 +1,238 @@
+/* zhbgv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zhbgv_(char *jobz, char *uplo, integer *n, integer *ka,
+ integer *kb, doublecomplex *ab, integer *ldab, doublecomplex *bb,
+ integer *ldbb, doublereal *w, doublecomplex *z__, integer *ldz,
+ doublecomplex *work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, bb_dim1, bb_offset, z_dim1, z_offset, i__1;
+
+ /* Local variables */
+ integer inde;
+ char vect[1];
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical upper, wantz;
+ extern /* Subroutine */ int xerbla_(char *, integer *), dsterf_(
+ integer *, doublereal *, doublereal *, integer *), zhbtrd_(char *,
+ char *, integer *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ integer indwrk;
+ extern /* Subroutine */ int zhbgst_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublereal *,
+ integer *), zpbstf_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *), zsteqr_(char *,
+ integer *, doublereal *, doublereal *, doublecomplex *, integer *,
+ doublereal *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHBGV computes all the eigenvalues, and optionally, the eigenvectors */
+/* of a complex generalized Hermitian-definite banded eigenproblem, of */
+/* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian */
+/* and banded, and B is also positive definite. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* KA (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */
+
+/* KB (input) INTEGER */
+/* The number of superdiagonals of the matrix B if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KB >= 0. */
+
+/* AB (input/output) COMPLEX*16 array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first ka+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */
+
+/* On exit, the contents of AB are destroyed. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KA+1. */
+
+/* BB (input/output) COMPLEX*16 array, dimension (LDBB, N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix B, stored in the first kb+1 rows of the array. The */
+/* j-th column of B is stored in the j-th column of the array BB */
+/* as follows: */
+/* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; */
+/* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). */
+
+/* On exit, the factor S from the split Cholesky factorization */
+/* B = S**H*S, as returned by ZPBSTF. */
+
+/* LDBB (input) INTEGER */
+/* The leading dimension of the array BB. LDBB >= KB+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX*16 array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
+/* eigenvectors, with the i-th column of Z holding the */
+/* eigenvector associated with W(i). The eigenvectors are */
+/* normalized so that Z**H*B*Z = I. */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= N. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is: */
+/* <= N: the algorithm failed to converge: */
+/* i off-diagonal elements of an intermediate */
+/* tridiagonal form did not converge to zero; */
+/* > N: if INFO = N + i, for 1 <= i <= N, then ZPBSTF */
+/* returned INFO = i: B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ bb_dim1 = *ldbb;
+ bb_offset = 1 + bb_dim1;
+ bb -= bb_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ka < 0) {
+ *info = -4;
+ } else if (*kb < 0 || *kb > *ka) {
+ *info = -5;
+ } else if (*ldab < *ka + 1) {
+ *info = -7;
+ } else if (*ldbb < *kb + 1) {
+ *info = -9;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHBGV ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a split Cholesky factorization of B. */
+
+ zpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem. */
+
+ inde = 1;
+ indwrk = inde + *n;
+ zhbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb,
+ &z__[z_offset], ldz, &work[1], &rwork[indwrk], &iinfo);
+
+/* Reduce to tridiagonal form. */
+
+ if (wantz) {
+ *(unsigned char *)vect = 'U';
+ } else {
+ *(unsigned char *)vect = 'N';
+ }
+ zhbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &w[1], &rwork[inde], &
+ z__[z_offset], ldz, &work[1], &iinfo);
+
+/* For eigenvalues only, call DSTERF. For eigenvectors, call ZSTEQR. */
+
+ if (! wantz) {
+ dsterf_(n, &w[1], &rwork[inde], info);
+ } else {
+ zsteqr_(jobz, n, &w[1], &rwork[inde], &z__[z_offset], ldz, &rwork[
+ indwrk], info);
+ }
+ return 0;
+
+/* End of ZHBGV */
+
+} /* zhbgv_ */
diff --git a/SRC/zhbgvd.c b/SRC/zhbgvd.c
new file mode 100644
index 0000000..bcdd4a9
--- /dev/null
+++ b/SRC/zhbgvd.c
@@ -0,0 +1,359 @@
+/* zhbgvd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static doublecomplex c_b2 = {0.,0.};
+
+/* Subroutine */ int zhbgvd_(char *jobz, char *uplo, integer *n, integer *ka,
+ integer *kb, doublecomplex *ab, integer *ldab, doublecomplex *bb,
+ integer *ldbb, doublereal *w, doublecomplex *z__, integer *ldz,
+ doublecomplex *work, integer *lwork, doublereal *rwork, integer *
+ lrwork, integer *iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, bb_dim1, bb_offset, z_dim1, z_offset, i__1;
+
+ /* Local variables */
+ integer inde;
+ char vect[1];
+ integer llwk2;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer lwmin;
+ logical upper;
+ integer llrwk;
+ logical wantz;
+ integer indwk2;
+ extern /* Subroutine */ int xerbla_(char *, integer *), dsterf_(
+ integer *, doublereal *, doublereal *, integer *), zstedc_(char *,
+ integer *, doublereal *, doublereal *, doublecomplex *, integer *
+, doublecomplex *, integer *, doublereal *, integer *, integer *,
+ integer *, integer *), zhbtrd_(char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ integer indwrk, liwmin;
+ extern /* Subroutine */ int zhbgst_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublereal *,
+ integer *), zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ integer lrwmin;
+ extern /* Subroutine */ int zpbstf_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *);
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHBGVD computes all the eigenvalues, and optionally, the eigenvectors */
+/* of a complex generalized Hermitian-definite banded eigenproblem, of */
+/* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian */
+/* and banded, and B is also positive definite. If eigenvectors are */
+/* desired, it uses a divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* KA (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */
+
+/* KB (input) INTEGER */
+/* The number of superdiagonals of the matrix B if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KB >= 0. */
+
+/* AB (input/output) COMPLEX*16 array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first ka+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */
+
+/* On exit, the contents of AB are destroyed. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KA+1. */
+
+/* BB (input/output) COMPLEX*16 array, dimension (LDBB, N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix B, stored in the first kb+1 rows of the array. The */
+/* j-th column of B is stored in the j-th column of the array BB */
+/* as follows: */
+/* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; */
+/* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). */
+
+/* On exit, the factor S from the split Cholesky factorization */
+/* B = S**H*S, as returned by ZPBSTF. */
+
+/* LDBB (input) INTEGER */
+/* The leading dimension of the array BB. LDBB >= KB+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX*16 array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
+/* eigenvectors, with the i-th column of Z holding the */
+/* eigenvector associated with W(i). The eigenvectors are */
+/* normalized so that Z**H*B*Z = I. */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= N. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO=0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If N <= 1, LWORK >= 1. */
+/* If JOBZ = 'N' and N > 1, LWORK >= N. */
+/* If JOBZ = 'V' and N > 1, LWORK >= 2*N**2. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK, RWORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* RWORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LRWORK)) */
+/* On exit, if INFO=0, RWORK(1) returns the optimal LRWORK. */
+
+/* LRWORK (input) INTEGER */
+/* The dimension of array RWORK. */
+/* If N <= 1, LRWORK >= 1. */
+/* If JOBZ = 'N' and N > 1, LRWORK >= N. */
+/* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2. */
+
+/* If LRWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO=0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of array IWORK. */
+/* If JOBZ = 'N' or N <= 1, LIWORK >= 1. */
+/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is: */
+/* <= N: the algorithm failed to converge: */
+/* i off-diagonal elements of an intermediate */
+/* tridiagonal form did not converge to zero; */
+/* > N: if INFO = N + i, for 1 <= i <= N, then ZPBSTF */
+/* returned INFO = i: B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ bb_dim1 = *ldbb;
+ bb_offset = 1 + bb_dim1;
+ bb -= bb_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
+
+ *info = 0;
+ if (*n <= 1) {
+ lwmin = 1;
+ lrwmin = 1;
+ liwmin = 1;
+ } else if (wantz) {
+/* Computing 2nd power */
+ i__1 = *n;
+ lwmin = i__1 * i__1 << 1;
+/* Computing 2nd power */
+ i__1 = *n;
+ lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
+ liwmin = *n * 5 + 3;
+ } else {
+ lwmin = *n;
+ lrwmin = *n;
+ liwmin = 1;
+ }
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ka < 0) {
+ *info = -4;
+ } else if (*kb < 0 || *kb > *ka) {
+ *info = -5;
+ } else if (*ldab < *ka + 1) {
+ *info = -7;
+ } else if (*ldbb < *kb + 1) {
+ *info = -9;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -12;
+ }
+
+ if (*info == 0) {
+ work[1].r = (doublereal) lwmin, work[1].i = 0.;
+ rwork[1] = (doublereal) lrwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -14;
+ } else if (*lrwork < lrwmin && ! lquery) {
+ *info = -16;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -18;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHBGVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a split Cholesky factorization of B. */
+
+ zpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem. */
+
+ inde = 1;
+ indwrk = inde + *n;
+ indwk2 = *n * *n + 1;
+ llwk2 = *lwork - indwk2 + 2;
+ llrwk = *lrwork - indwrk + 2;
+ zhbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb,
+ &z__[z_offset], ldz, &work[1], &rwork[indwrk], &iinfo);
+
+/* Reduce Hermitian band matrix to tridiagonal form. */
+
+ if (wantz) {
+ *(unsigned char *)vect = 'U';
+ } else {
+ *(unsigned char *)vect = 'N';
+ }
+ zhbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &w[1], &rwork[inde], &
+ z__[z_offset], ldz, &work[1], &iinfo);
+
+/* For eigenvalues only, call DSTERF. For eigenvectors, call ZSTEDC. */
+
+ if (! wantz) {
+ dsterf_(n, &w[1], &rwork[inde], info);
+ } else {
+ zstedc_("I", n, &w[1], &rwork[inde], &work[1], n, &work[indwk2], &
+ llwk2, &rwork[indwrk], &llrwk, &iwork[1], liwork, info);
+ zgemm_("N", "N", n, n, n, &c_b1, &z__[z_offset], ldz, &work[1], n, &
+ c_b2, &work[indwk2], n);
+ zlacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz);
+ }
+
+ work[1].r = (doublereal) lwmin, work[1].i = 0.;
+ rwork[1] = (doublereal) lrwmin;
+ iwork[1] = liwmin;
+ return 0;
+
+/* End of ZHBGVD */
+
+} /* zhbgvd_ */
diff --git a/SRC/zhbgvx.c b/SRC/zhbgvx.c
new file mode 100644
index 0000000..6663aab
--- /dev/null
+++ b/SRC/zhbgvx.c
@@ -0,0 +1,473 @@
+/* zhbgvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zhbgvx_(char *jobz, char *range, char *uplo, integer *n,
+ integer *ka, integer *kb, doublecomplex *ab, integer *ldab,
+ doublecomplex *bb, integer *ldbb, doublecomplex *q, integer *ldq,
+ doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *
+ abstol, integer *m, doublereal *w, doublecomplex *z__, integer *ldz,
+ doublecomplex *work, doublereal *rwork, integer *iwork, integer *
+ ifail, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, bb_dim1, bb_offset, q_dim1, q_offset, z_dim1,
+ z_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, jj;
+ doublereal tmp1;
+ integer indd, inde;
+ char vect[1];
+ logical test;
+ integer itmp1, indee;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ char order[1];
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ logical upper, wantz;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *);
+ logical alleig, indeig;
+ integer indibl;
+ logical valeig;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer indiwk, indisp;
+ extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
+ integer *), dstebz_(char *, char *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, integer *),
+ zhbtrd_(char *, char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ integer indrwk, indwrk;
+ extern /* Subroutine */ int zhbgst_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublereal *,
+ integer *), zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ integer nsplit;
+ extern /* Subroutine */ int zpbstf_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *), zstein_(integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *, integer *,
+ integer *, integer *), zsteqr_(char *, integer *, doublereal *,
+ doublereal *, doublecomplex *, integer *, doublereal *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHBGVX computes all the eigenvalues, and optionally, the eigenvectors */
+/* of a complex generalized Hermitian-definite banded eigenproblem, of */
+/* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian */
+/* and banded, and B is also positive definite. Eigenvalues and */
+/* eigenvectors can be selected by specifying either all eigenvalues, */
+/* a range of values or a range of indices for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found; */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found; */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* KA (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */
+
+/* KB (input) INTEGER */
+/* The number of superdiagonals of the matrix B if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KB >= 0. */
+
+/* AB (input/output) COMPLEX*16 array, dimension (LDAB, N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first ka+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */
+
+/* On exit, the contents of AB are destroyed. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KA+1. */
+
+/* BB (input/output) COMPLEX*16 array, dimension (LDBB, N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix B, stored in the first kb+1 rows of the array. The */
+/* j-th column of B is stored in the j-th column of the array BB */
+/* as follows: */
+/* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; */
+/* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). */
+
+/* On exit, the factor S from the split Cholesky factorization */
+/* B = S**H*S, as returned by ZPBSTF. */
+
+/* LDBB (input) INTEGER */
+/* The leading dimension of the array BB. LDBB >= KB+1. */
+
+/* Q (output) COMPLEX*16 array, dimension (LDQ, N) */
+/* If JOBZ = 'V', the n-by-n matrix used in the reduction of */
+/* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x, */
+/* and consequently C to tridiagonal form. */
+/* If JOBZ = 'N', the array Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. If JOBZ = 'N', */
+/* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N). */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) DOUBLE PRECISION */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing AP to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*DLAMCH('S'). */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX*16 array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
+/* eigenvectors, with the i-th column of Z holding the */
+/* eigenvector associated with W(i). The eigenvectors are */
+/* normalized so that Z**H*B*Z = I. */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= N. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is: */
+/* <= N: then i eigenvectors failed to converge. Their */
+/* indices are stored in array IFAIL. */
+/* > N: if INFO = N + i, for 1 <= i <= N, then ZPBSTF */
+/* returned INFO = i: B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ bb_dim1 = *ldbb;
+ bb_offset = 1 + bb_dim1;
+ bb -= bb_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ka < 0) {
+ *info = -5;
+ } else if (*kb < 0 || *kb > *ka) {
+ *info = -6;
+ } else if (*ldab < *ka + 1) {
+ *info = -8;
+ } else if (*ldbb < *kb + 1) {
+ *info = -10;
+ } else if (*ldq < 1 || wantz && *ldq < *n) {
+ *info = -12;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -14;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -15;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -16;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -21;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHBGVX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a split Cholesky factorization of B. */
+
+ zpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem. */
+
+ zhbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb,
+ &q[q_offset], ldq, &work[1], &rwork[1], &iinfo);
+
+/* Solve the standard eigenvalue problem. */
+/* Reduce Hermitian band matrix to tridiagonal form. */
+
+ indd = 1;
+ inde = indd + *n;
+ indrwk = inde + *n;
+ indwrk = 1;
+ if (wantz) {
+ *(unsigned char *)vect = 'U';
+ } else {
+ *(unsigned char *)vect = 'N';
+ }
+ zhbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &rwork[indd], &rwork[
+ inde], &q[q_offset], ldq, &work[indwrk], &iinfo);
+
+/* If all eigenvalues are desired and ABSTOL is less than or equal */
+/* to zero, then call DSTERF or ZSTEQR. If this fails for some */
+/* eigenvalue, then try DSTEBZ. */
+
+ test = FALSE_;
+ if (indeig) {
+ if (*il == 1 && *iu == *n) {
+ test = TRUE_;
+ }
+ }
+ if ((alleig || test) && *abstol <= 0.) {
+ dcopy_(n, &rwork[indd], &c__1, &w[1], &c__1);
+ indee = indrwk + (*n << 1);
+ i__1 = *n - 1;
+ dcopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
+ if (! wantz) {
+ dsterf_(n, &w[1], &rwork[indee], info);
+ } else {
+ zlacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz);
+ zsteqr_(jobz, n, &w[1], &rwork[indee], &z__[z_offset], ldz, &
+ rwork[indrwk], info);
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ifail[i__] = 0;
+/* L10: */
+ }
+ }
+ }
+ if (*info == 0) {
+ *m = *n;
+ goto L30;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call DSTEBZ and, if eigenvectors are desired, */
+/* call ZSTEIN. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ indibl = 1;
+ indisp = indibl + *n;
+ indiwk = indisp + *n;
+ dstebz_(range, order, n, vl, vu, il, iu, abstol, &rwork[indd], &rwork[
+ inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &rwork[
+ indrwk], &iwork[indiwk], info);
+
+ if (wantz) {
+ zstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], &
+ iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[
+ indiwk], &ifail[1], info);
+
+/* Apply unitary matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by ZSTEIN. */
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1);
+ zgemv_("N", n, n, &c_b2, &q[q_offset], ldq, &work[1], &c__1, &
+ c_b1, &z__[j * z_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+
+L30:
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L40: */
+ }
+
+ if (i__ != 0) {
+ itmp1 = iwork[indibl + i__ - 1];
+ w[i__] = w[j];
+ iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
+ w[j] = tmp1;
+ iwork[indibl + j - 1] = itmp1;
+ zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ if (*info != 0) {
+ itmp1 = ifail[i__];
+ ifail[i__] = ifail[j];
+ ifail[j] = itmp1;
+ }
+ }
+/* L50: */
+ }
+ }
+
+ return 0;
+
+/* End of ZHBGVX */
+
+} /* zhbgvx_ */
diff --git a/SRC/zhbtrd.c b/SRC/zhbtrd.c
new file mode 100644
index 0000000..f2c3593
--- /dev/null
+++ b/SRC/zhbtrd.c
@@ -0,0 +1,810 @@
+/* zhbtrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zhbtrd_(char *vect, char *uplo, integer *n, integer *kd,
+ doublecomplex *ab, integer *ldab, doublereal *d__, doublereal *e,
+ doublecomplex *q, integer *ldq, doublecomplex *work, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, q_dim1, q_offset, i__1, i__2, i__3, i__4,
+ i__5, i__6;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ double z_abs(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, l;
+ doublecomplex t;
+ integer i2, j1, j2, nq, nr, kd1, ibl, iqb, kdn, jin, nrt, kdm1, inca,
+ jend, lend, jinc;
+ doublereal abst;
+ integer incx, last;
+ doublecomplex temp;
+ extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *);
+ integer j1end, j1inc, iqend;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ logical initq, wantq, upper;
+ extern /* Subroutine */ int zlar2v_(integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *);
+ integer iqaend;
+ extern /* Subroutine */ int xerbla_(char *, integer *), zlacgv_(
+ integer *, doublecomplex *, integer *), zlaset_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *), zlartg_(doublecomplex *, doublecomplex *,
+ doublereal *, doublecomplex *, doublecomplex *), zlargv_(integer *
+, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *), zlartv_(integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHBTRD reduces a complex Hermitian band matrix A to real symmetric */
+/* tridiagonal form T by a unitary similarity transformation: */
+/* Q**H * A * Q = T. */
+
+/* Arguments */
+/* ========= */
+
+/* VECT (input) CHARACTER*1 */
+/* = 'N': do not form Q; */
+/* = 'V': form Q; */
+/* = 'U': update a matrix X, by forming X*Q. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+/* On exit, the diagonal elements of AB are overwritten by the */
+/* diagonal elements of the tridiagonal matrix T; if KD > 0, the */
+/* elements on the first superdiagonal (if UPLO = 'U') or the */
+/* first subdiagonal (if UPLO = 'L') are overwritten by the */
+/* off-diagonal elements of T; the rest of AB is overwritten by */
+/* values generated during the reduction. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* D (output) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal elements of the tridiagonal matrix T. */
+
+/* E (output) DOUBLE PRECISION array, dimension (N-1) */
+/* The off-diagonal elements of the tridiagonal matrix T: */
+/* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'. */
+
+/* Q (input/output) COMPLEX*16 array, dimension (LDQ,N) */
+/* On entry, if VECT = 'U', then Q must contain an N-by-N */
+/* matrix X; if VECT = 'N' or 'V', then Q need not be set. */
+
+/* On exit: */
+/* if VECT = 'V', Q contains the N-by-N unitary matrix Q; */
+/* if VECT = 'U', Q contains the product X*Q; */
+/* if VECT = 'N', the array Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. */
+/* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* Modified by Linda Kaufman, Bell Labs. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --d__;
+ --e;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+
+ /* Function Body */
+ initq = lsame_(vect, "V");
+ wantq = initq || lsame_(vect, "U");
+ upper = lsame_(uplo, "U");
+ kd1 = *kd + 1;
+ kdm1 = *kd - 1;
+ incx = *ldab - 1;
+ iqend = 1;
+
+ *info = 0;
+ if (! wantq && ! lsame_(vect, "N")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kd < 0) {
+ *info = -4;
+ } else if (*ldab < kd1) {
+ *info = -6;
+ } else if (*ldq < max(1,*n) && wantq) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHBTRD", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Initialize Q to the unit matrix, if needed */
+
+ if (initq) {
+ zlaset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
+ }
+
+/* Wherever possible, plane rotations are generated and applied in */
+/* vector operations of length NR over the index set J1:J2:KD1. */
+
+/* The real cosines and complex sines of the plane rotations are */
+/* stored in the arrays D and WORK. */
+
+ inca = kd1 * *ldab;
+/* Computing MIN */
+ i__1 = *n - 1;
+ kdn = min(i__1,*kd);
+ if (upper) {
+
+ if (*kd > 1) {
+
+/* Reduce to complex Hermitian tridiagonal form, working with */
+/* the upper triangle */
+
+ nr = 0;
+ j1 = kdn + 2;
+ j2 = 1;
+
+ i__1 = kd1 + ab_dim1;
+ i__2 = kd1 + ab_dim1;
+ d__1 = ab[i__2].r;
+ ab[i__1].r = d__1, ab[i__1].i = 0.;
+ i__1 = *n - 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Reduce i-th row of matrix to tridiagonal form */
+
+ for (k = kdn + 1; k >= 2; --k) {
+ j1 += kdn;
+ j2 += kdn;
+
+ if (nr > 0) {
+
+/* generate plane rotations to annihilate nonzero */
+/* elements which have been created outside the band */
+
+ zlargv_(&nr, &ab[(j1 - 1) * ab_dim1 + 1], &inca, &
+ work[j1], &kd1, &d__[j1], &kd1);
+
+/* apply rotations from the right */
+
+
+/* Dependent on the the number of diagonals either */
+/* ZLARTV or ZROT is used */
+
+ if (nr >= (*kd << 1) - 1) {
+ i__2 = *kd - 1;
+ for (l = 1; l <= i__2; ++l) {
+ zlartv_(&nr, &ab[l + 1 + (j1 - 1) * ab_dim1],
+ &inca, &ab[l + j1 * ab_dim1], &inca, &
+ d__[j1], &work[j1], &kd1);
+/* L10: */
+ }
+
+ } else {
+ jend = j1 + (nr - 1) * kd1;
+ i__2 = jend;
+ i__3 = kd1;
+ for (jinc = j1; i__3 < 0 ? jinc >= i__2 : jinc <=
+ i__2; jinc += i__3) {
+ zrot_(&kdm1, &ab[(jinc - 1) * ab_dim1 + 2], &
+ c__1, &ab[jinc * ab_dim1 + 1], &c__1,
+ &d__[jinc], &work[jinc]);
+/* L20: */
+ }
+ }
+ }
+
+
+ if (k > 2) {
+ if (k <= *n - i__ + 1) {
+
+/* generate plane rotation to annihilate a(i,i+k-1) */
+/* within the band */
+
+ zlartg_(&ab[*kd - k + 3 + (i__ + k - 2) * ab_dim1]
+, &ab[*kd - k + 2 + (i__ + k - 1) *
+ ab_dim1], &d__[i__ + k - 1], &work[i__ +
+ k - 1], &temp);
+ i__3 = *kd - k + 3 + (i__ + k - 2) * ab_dim1;
+ ab[i__3].r = temp.r, ab[i__3].i = temp.i;
+
+/* apply rotation from the right */
+
+ i__3 = k - 3;
+ zrot_(&i__3, &ab[*kd - k + 4 + (i__ + k - 2) *
+ ab_dim1], &c__1, &ab[*kd - k + 3 + (i__ +
+ k - 1) * ab_dim1], &c__1, &d__[i__ + k -
+ 1], &work[i__ + k - 1]);
+ }
+ ++nr;
+ j1 = j1 - kdn - 1;
+ }
+
+/* apply plane rotations from both sides to diagonal */
+/* blocks */
+
+ if (nr > 0) {
+ zlar2v_(&nr, &ab[kd1 + (j1 - 1) * ab_dim1], &ab[kd1 +
+ j1 * ab_dim1], &ab[*kd + j1 * ab_dim1], &inca,
+ &d__[j1], &work[j1], &kd1);
+ }
+
+/* apply plane rotations from the left */
+
+ if (nr > 0) {
+ zlacgv_(&nr, &work[j1], &kd1);
+ if ((*kd << 1) - 1 < nr) {
+
+/* Dependent on the the number of diagonals either */
+/* ZLARTV or ZROT is used */
+
+ i__3 = *kd - 1;
+ for (l = 1; l <= i__3; ++l) {
+ if (j2 + l > *n) {
+ nrt = nr - 1;
+ } else {
+ nrt = nr;
+ }
+ if (nrt > 0) {
+ zlartv_(&nrt, &ab[*kd - l + (j1 + l) *
+ ab_dim1], &inca, &ab[*kd - l + 1
+ + (j1 + l) * ab_dim1], &inca, &
+ d__[j1], &work[j1], &kd1);
+ }
+/* L30: */
+ }
+ } else {
+ j1end = j1 + kd1 * (nr - 2);
+ if (j1end >= j1) {
+ i__3 = j1end;
+ i__2 = kd1;
+ for (jin = j1; i__2 < 0 ? jin >= i__3 : jin <=
+ i__3; jin += i__2) {
+ i__4 = *kd - 1;
+ zrot_(&i__4, &ab[*kd - 1 + (jin + 1) *
+ ab_dim1], &incx, &ab[*kd + (jin +
+ 1) * ab_dim1], &incx, &d__[jin], &
+ work[jin]);
+/* L40: */
+ }
+ }
+/* Computing MIN */
+ i__2 = kdm1, i__3 = *n - j2;
+ lend = min(i__2,i__3);
+ last = j1end + kd1;
+ if (lend > 0) {
+ zrot_(&lend, &ab[*kd - 1 + (last + 1) *
+ ab_dim1], &incx, &ab[*kd + (last + 1)
+ * ab_dim1], &incx, &d__[last], &work[
+ last]);
+ }
+ }
+ }
+
+ if (wantq) {
+
+/* accumulate product of plane rotations in Q */
+
+ if (initq) {
+
+/* take advantage of the fact that Q was */
+/* initially the Identity matrix */
+
+ iqend = max(iqend,j2);
+/* Computing MAX */
+ i__2 = 0, i__3 = k - 3;
+ i2 = max(i__2,i__3);
+ iqaend = i__ * *kd + 1;
+ if (k == 2) {
+ iqaend += *kd;
+ }
+ iqaend = min(iqaend,iqend);
+ i__2 = j2;
+ i__3 = kd1;
+ for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j
+ += i__3) {
+ ibl = i__ - i2 / kdm1;
+ ++i2;
+/* Computing MAX */
+ i__4 = 1, i__5 = j - ibl;
+ iqb = max(i__4,i__5);
+ nq = iqaend + 1 - iqb;
+/* Computing MIN */
+ i__4 = iqaend + *kd;
+ iqaend = min(i__4,iqend);
+ d_cnjg(&z__1, &work[j]);
+ zrot_(&nq, &q[iqb + (j - 1) * q_dim1], &c__1,
+ &q[iqb + j * q_dim1], &c__1, &d__[j],
+ &z__1);
+/* L50: */
+ }
+ } else {
+
+ i__3 = j2;
+ i__2 = kd1;
+ for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j
+ += i__2) {
+ d_cnjg(&z__1, &work[j]);
+ zrot_(n, &q[(j - 1) * q_dim1 + 1], &c__1, &q[
+ j * q_dim1 + 1], &c__1, &d__[j], &
+ z__1);
+/* L60: */
+ }
+ }
+
+ }
+
+ if (j2 + kdn > *n) {
+
+/* adjust J2 to keep within the bounds of the matrix */
+
+ --nr;
+ j2 = j2 - kdn - 1;
+ }
+
+ i__2 = j2;
+ i__3 = kd1;
+ for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j += i__3)
+ {
+
+/* create nonzero element a(j-1,j+kd) outside the band */
+/* and store it in WORK */
+
+ i__4 = j + *kd;
+ i__5 = j;
+ i__6 = (j + *kd) * ab_dim1 + 1;
+ z__1.r = work[i__5].r * ab[i__6].r - work[i__5].i *
+ ab[i__6].i, z__1.i = work[i__5].r * ab[i__6]
+ .i + work[i__5].i * ab[i__6].r;
+ work[i__4].r = z__1.r, work[i__4].i = z__1.i;
+ i__4 = (j + *kd) * ab_dim1 + 1;
+ i__5 = j;
+ i__6 = (j + *kd) * ab_dim1 + 1;
+ z__1.r = d__[i__5] * ab[i__6].r, z__1.i = d__[i__5] *
+ ab[i__6].i;
+ ab[i__4].r = z__1.r, ab[i__4].i = z__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+
+ if (*kd > 0) {
+
+/* make off-diagonal elements real and copy them to E */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__3 = *kd + (i__ + 1) * ab_dim1;
+ t.r = ab[i__3].r, t.i = ab[i__3].i;
+ abst = z_abs(&t);
+ i__3 = *kd + (i__ + 1) * ab_dim1;
+ ab[i__3].r = abst, ab[i__3].i = 0.;
+ e[i__] = abst;
+ if (abst != 0.) {
+ z__1.r = t.r / abst, z__1.i = t.i / abst;
+ t.r = z__1.r, t.i = z__1.i;
+ } else {
+ t.r = 1., t.i = 0.;
+ }
+ if (i__ < *n - 1) {
+ i__3 = *kd + (i__ + 2) * ab_dim1;
+ i__2 = *kd + (i__ + 2) * ab_dim1;
+ z__1.r = ab[i__2].r * t.r - ab[i__2].i * t.i, z__1.i = ab[
+ i__2].r * t.i + ab[i__2].i * t.r;
+ ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
+ }
+ if (wantq) {
+ d_cnjg(&z__1, &t);
+ zscal_(n, &z__1, &q[(i__ + 1) * q_dim1 + 1], &c__1);
+ }
+/* L100: */
+ }
+ } else {
+
+/* set E to zero if original matrix was diagonal */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ e[i__] = 0.;
+/* L110: */
+ }
+ }
+
+/* copy diagonal elements to D */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__3 = i__;
+ i__2 = kd1 + i__ * ab_dim1;
+ d__[i__3] = ab[i__2].r;
+/* L120: */
+ }
+
+ } else {
+
+ if (*kd > 1) {
+
+/* Reduce to complex Hermitian tridiagonal form, working with */
+/* the lower triangle */
+
+ nr = 0;
+ j1 = kdn + 2;
+ j2 = 1;
+
+ i__1 = ab_dim1 + 1;
+ i__3 = ab_dim1 + 1;
+ d__1 = ab[i__3].r;
+ ab[i__1].r = d__1, ab[i__1].i = 0.;
+ i__1 = *n - 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Reduce i-th column of matrix to tridiagonal form */
+
+ for (k = kdn + 1; k >= 2; --k) {
+ j1 += kdn;
+ j2 += kdn;
+
+ if (nr > 0) {
+
+/* generate plane rotations to annihilate nonzero */
+/* elements which have been created outside the band */
+
+ zlargv_(&nr, &ab[kd1 + (j1 - kd1) * ab_dim1], &inca, &
+ work[j1], &kd1, &d__[j1], &kd1);
+
+/* apply plane rotations from one side */
+
+
+/* Dependent on the the number of diagonals either */
+/* ZLARTV or ZROT is used */
+
+ if (nr > (*kd << 1) - 1) {
+ i__3 = *kd - 1;
+ for (l = 1; l <= i__3; ++l) {
+ zlartv_(&nr, &ab[kd1 - l + (j1 - kd1 + l) *
+ ab_dim1], &inca, &ab[kd1 - l + 1 + (
+ j1 - kd1 + l) * ab_dim1], &inca, &d__[
+ j1], &work[j1], &kd1);
+/* L130: */
+ }
+ } else {
+ jend = j1 + kd1 * (nr - 1);
+ i__3 = jend;
+ i__2 = kd1;
+ for (jinc = j1; i__2 < 0 ? jinc >= i__3 : jinc <=
+ i__3; jinc += i__2) {
+ zrot_(&kdm1, &ab[*kd + (jinc - *kd) * ab_dim1]
+, &incx, &ab[kd1 + (jinc - *kd) *
+ ab_dim1], &incx, &d__[jinc], &work[
+ jinc]);
+/* L140: */
+ }
+ }
+
+ }
+
+ if (k > 2) {
+ if (k <= *n - i__ + 1) {
+
+/* generate plane rotation to annihilate a(i+k-1,i) */
+/* within the band */
+
+ zlartg_(&ab[k - 1 + i__ * ab_dim1], &ab[k + i__ *
+ ab_dim1], &d__[i__ + k - 1], &work[i__ +
+ k - 1], &temp);
+ i__2 = k - 1 + i__ * ab_dim1;
+ ab[i__2].r = temp.r, ab[i__2].i = temp.i;
+
+/* apply rotation from the left */
+
+ i__2 = k - 3;
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ zrot_(&i__2, &ab[k - 2 + (i__ + 1) * ab_dim1], &
+ i__3, &ab[k - 1 + (i__ + 1) * ab_dim1], &
+ i__4, &d__[i__ + k - 1], &work[i__ + k -
+ 1]);
+ }
+ ++nr;
+ j1 = j1 - kdn - 1;
+ }
+
+/* apply plane rotations from both sides to diagonal */
+/* blocks */
+
+ if (nr > 0) {
+ zlar2v_(&nr, &ab[(j1 - 1) * ab_dim1 + 1], &ab[j1 *
+ ab_dim1 + 1], &ab[(j1 - 1) * ab_dim1 + 2], &
+ inca, &d__[j1], &work[j1], &kd1);
+ }
+
+/* apply plane rotations from the right */
+
+
+/* Dependent on the the number of diagonals either */
+/* ZLARTV or ZROT is used */
+
+ if (nr > 0) {
+ zlacgv_(&nr, &work[j1], &kd1);
+ if (nr > (*kd << 1) - 1) {
+ i__2 = *kd - 1;
+ for (l = 1; l <= i__2; ++l) {
+ if (j2 + l > *n) {
+ nrt = nr - 1;
+ } else {
+ nrt = nr;
+ }
+ if (nrt > 0) {
+ zlartv_(&nrt, &ab[l + 2 + (j1 - 1) *
+ ab_dim1], &inca, &ab[l + 1 + j1 *
+ ab_dim1], &inca, &d__[j1], &work[
+ j1], &kd1);
+ }
+/* L150: */
+ }
+ } else {
+ j1end = j1 + kd1 * (nr - 2);
+ if (j1end >= j1) {
+ i__2 = j1end;
+ i__3 = kd1;
+ for (j1inc = j1; i__3 < 0 ? j1inc >= i__2 :
+ j1inc <= i__2; j1inc += i__3) {
+ zrot_(&kdm1, &ab[(j1inc - 1) * ab_dim1 +
+ 3], &c__1, &ab[j1inc * ab_dim1 +
+ 2], &c__1, &d__[j1inc], &work[
+ j1inc]);
+/* L160: */
+ }
+ }
+/* Computing MIN */
+ i__3 = kdm1, i__2 = *n - j2;
+ lend = min(i__3,i__2);
+ last = j1end + kd1;
+ if (lend > 0) {
+ zrot_(&lend, &ab[(last - 1) * ab_dim1 + 3], &
+ c__1, &ab[last * ab_dim1 + 2], &c__1,
+ &d__[last], &work[last]);
+ }
+ }
+ }
+
+
+
+ if (wantq) {
+
+/* accumulate product of plane rotations in Q */
+
+ if (initq) {
+
+/* take advantage of the fact that Q was */
+/* initially the Identity matrix */
+
+ iqend = max(iqend,j2);
+/* Computing MAX */
+ i__3 = 0, i__2 = k - 3;
+ i2 = max(i__3,i__2);
+ iqaend = i__ * *kd + 1;
+ if (k == 2) {
+ iqaend += *kd;
+ }
+ iqaend = min(iqaend,iqend);
+ i__3 = j2;
+ i__2 = kd1;
+ for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j
+ += i__2) {
+ ibl = i__ - i2 / kdm1;
+ ++i2;
+/* Computing MAX */
+ i__4 = 1, i__5 = j - ibl;
+ iqb = max(i__4,i__5);
+ nq = iqaend + 1 - iqb;
+/* Computing MIN */
+ i__4 = iqaend + *kd;
+ iqaend = min(i__4,iqend);
+ zrot_(&nq, &q[iqb + (j - 1) * q_dim1], &c__1,
+ &q[iqb + j * q_dim1], &c__1, &d__[j],
+ &work[j]);
+/* L170: */
+ }
+ } else {
+
+ i__2 = j2;
+ i__3 = kd1;
+ for (j = j1; i__3 < 0 ? j >= i__2 : j <= i__2; j
+ += i__3) {
+ zrot_(n, &q[(j - 1) * q_dim1 + 1], &c__1, &q[
+ j * q_dim1 + 1], &c__1, &d__[j], &
+ work[j]);
+/* L180: */
+ }
+ }
+ }
+
+ if (j2 + kdn > *n) {
+
+/* adjust J2 to keep within the bounds of the matrix */
+
+ --nr;
+ j2 = j2 - kdn - 1;
+ }
+
+ i__3 = j2;
+ i__2 = kd1;
+ for (j = j1; i__2 < 0 ? j >= i__3 : j <= i__3; j += i__2)
+ {
+
+/* create nonzero element a(j+kd,j-1) outside the */
+/* band and store it in WORK */
+
+ i__4 = j + *kd;
+ i__5 = j;
+ i__6 = kd1 + j * ab_dim1;
+ z__1.r = work[i__5].r * ab[i__6].r - work[i__5].i *
+ ab[i__6].i, z__1.i = work[i__5].r * ab[i__6]
+ .i + work[i__5].i * ab[i__6].r;
+ work[i__4].r = z__1.r, work[i__4].i = z__1.i;
+ i__4 = kd1 + j * ab_dim1;
+ i__5 = j;
+ i__6 = kd1 + j * ab_dim1;
+ z__1.r = d__[i__5] * ab[i__6].r, z__1.i = d__[i__5] *
+ ab[i__6].i;
+ ab[i__4].r = z__1.r, ab[i__4].i = z__1.i;
+/* L190: */
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+ }
+
+ if (*kd > 0) {
+
+/* make off-diagonal elements real and copy them to E */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ * ab_dim1 + 2;
+ t.r = ab[i__2].r, t.i = ab[i__2].i;
+ abst = z_abs(&t);
+ i__2 = i__ * ab_dim1 + 2;
+ ab[i__2].r = abst, ab[i__2].i = 0.;
+ e[i__] = abst;
+ if (abst != 0.) {
+ z__1.r = t.r / abst, z__1.i = t.i / abst;
+ t.r = z__1.r, t.i = z__1.i;
+ } else {
+ t.r = 1., t.i = 0.;
+ }
+ if (i__ < *n - 1) {
+ i__2 = (i__ + 1) * ab_dim1 + 2;
+ i__3 = (i__ + 1) * ab_dim1 + 2;
+ z__1.r = ab[i__3].r * t.r - ab[i__3].i * t.i, z__1.i = ab[
+ i__3].r * t.i + ab[i__3].i * t.r;
+ ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
+ }
+ if (wantq) {
+ zscal_(n, &t, &q[(i__ + 1) * q_dim1 + 1], &c__1);
+ }
+/* L220: */
+ }
+ } else {
+
+/* set E to zero if original matrix was diagonal */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ e[i__] = 0.;
+/* L230: */
+ }
+ }
+
+/* copy diagonal elements to D */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__ * ab_dim1 + 1;
+ d__[i__2] = ab[i__3].r;
+/* L240: */
+ }
+ }
+
+ return 0;
+
+/* End of ZHBTRD */
+
+} /* zhbtrd_ */
diff --git a/SRC/zhecon.c b/SRC/zhecon.c
new file mode 100644
index 0000000..869cdc0
--- /dev/null
+++ b/SRC/zhecon.c
@@ -0,0 +1,203 @@
+/* zhecon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zhecon_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *ipiv, doublereal *anorm, doublereal *rcond,
+ doublecomplex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *), xerbla_(
+ char *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int zhetrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHECON estimates the reciprocal of the condition number of a complex */
+/* Hermitian matrix A using the factorization A = U*D*U**H or */
+/* A = L*D*L**H computed by ZHETRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**H; */
+/* = 'L': Lower triangular, form is A = L*D*L**H. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by ZHETRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by ZHETRF. */
+
+/* ANORM (input) DOUBLE PRECISION */
+/* The 1-norm of the original matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*anorm < 0.) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHECON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.;
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ } else if (*anorm <= 0.) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ for (i__ = *n; i__ >= 1; --i__) {
+ i__1 = i__ + i__ * a_dim1;
+ if (ipiv[i__] > 0 && (a[i__1].r == 0. && a[i__1].i == 0.)) {
+ return 0;
+ }
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ if (ipiv[i__] > 0 && (a[i__2].r == 0. && a[i__2].i == 0.)) {
+ return 0;
+ }
+/* L20: */
+ }
+ }
+
+/* Estimate the 1-norm of the inverse. */
+
+ kase = 0;
+L30:
+ zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+
+/* Multiply by inv(L*D*L') or inv(U*D*U'). */
+
+ zhetrs_(uplo, n, &c__1, &a[a_offset], lda, &ipiv[1], &work[1], n,
+ info);
+ goto L30;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / ainvnm / *anorm;
+ }
+
+ return 0;
+
+/* End of ZHECON */
+
+} /* zhecon_ */
diff --git a/SRC/zheequb.c b/SRC/zheequb.c
new file mode 100644
index 0000000..eb1bcd7
--- /dev/null
+++ b/SRC/zheequb.c
@@ -0,0 +1,439 @@
+/* zheequb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zheequb_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublereal *s, doublereal *scond, doublereal *amax,
+ doublecomplex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *), sqrt(doublereal), log(doublereal), pow_di(
+ doublereal *, integer *);
+
+ /* Local variables */
+ doublereal d__;
+ integer i__, j;
+ doublereal t, u, c0, c1, c2, si;
+ logical up;
+ doublereal avg, std, tol, base;
+ integer iter;
+ doublereal smin, smax, scale;
+ extern logical lsame_(char *, char *);
+ doublereal sumsq;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum, smlnum;
+ extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSYEQUB computes row and column scalings intended to equilibrate a */
+/* symmetric matrix A and reduce its condition number */
+/* (with respect to the two-norm). S contains the scale factors, */
+/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
+/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
+/* choice of S puts the condition number of B within a factor N of the */
+/* smallest possible condition number over all possible diagonal */
+/* scalings. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The N-by-N symmetric matrix whose scaling */
+/* factors are to be computed. Only the diagonal elements of A */
+/* are referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* S (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, S contains the scale factors for A. */
+
+/* SCOND (output) DOUBLE PRECISION */
+/* If INFO = 0, S contains the ratio of the smallest S(i) to */
+/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
+/* large nor too small, it is not worth scaling by S. */
+
+/* AMAX (output) DOUBLE PRECISION */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+
+/* Test input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (! (lsame_(uplo, "U") || lsame_(uplo, "L"))) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHEEQUB", &i__1);
+ return 0;
+ }
+ up = lsame_(uplo, "U");
+ *amax = 0.;
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ *scond = 1.;
+ return 0;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s[i__] = 0.;
+ }
+ *amax = 0.;
+ if (up) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = s[i__], d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2));
+ s[i__] = max(d__3,d__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = s[j], d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2));
+ s[j] = max(d__3,d__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = *amax, d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2));
+ *amax = max(d__3,d__4);
+ }
+/* Computing MAX */
+ i__2 = j + j * a_dim1;
+ d__3 = s[j], d__4 = (d__1 = a[i__2].r, abs(d__1)) + (d__2 =
+ d_imag(&a[j + j * a_dim1]), abs(d__2));
+ s[j] = max(d__3,d__4);
+/* Computing MAX */
+ i__2 = j + j * a_dim1;
+ d__3 = *amax, d__4 = (d__1 = a[i__2].r, abs(d__1)) + (d__2 =
+ d_imag(&a[j + j * a_dim1]), abs(d__2));
+ *amax = max(d__3,d__4);
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j + j * a_dim1;
+ d__3 = s[j], d__4 = (d__1 = a[i__2].r, abs(d__1)) + (d__2 =
+ d_imag(&a[j + j * a_dim1]), abs(d__2));
+ s[j] = max(d__3,d__4);
+/* Computing MAX */
+ i__2 = j + j * a_dim1;
+ d__3 = *amax, d__4 = (d__1 = a[i__2].r, abs(d__1)) + (d__2 =
+ d_imag(&a[j + j * a_dim1]), abs(d__2));
+ *amax = max(d__3,d__4);
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = s[i__], d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2));
+ s[i__] = max(d__3,d__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = s[j], d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2));
+ s[j] = max(d__3,d__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = *amax, d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2));
+ *amax = max(d__3,d__4);
+ }
+ }
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ s[j] = 1. / s[j];
+ }
+ tol = 1. / sqrt(*n * 2.);
+ for (iter = 1; iter <= 100; ++iter) {
+ scale = 0.;
+ sumsq = 0.;
+/* beta = |A|s */
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ work[i__2].r = 0., work[i__2].i = 0.;
+ }
+ if (up) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ + j * a_dim1]), abs(d__2));
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ d__3 = ((d__1 = a[i__5].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2))) * s[j];
+ z__1.r = work[i__4].r + d__3, z__1.i = work[i__4].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ i__3 = j;
+ i__4 = j;
+ i__5 = i__ + j * a_dim1;
+ d__3 = ((d__1 = a[i__5].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2))) * s[i__];
+ z__1.r = work[i__4].r + d__3, z__1.i = work[i__4].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ }
+ i__2 = j;
+ i__3 = j;
+ i__4 = j + j * a_dim1;
+ d__3 = ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[j +
+ j * a_dim1]), abs(d__2))) * s[j];
+ z__1.r = work[i__3].r + d__3, z__1.i = work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ i__3 = j;
+ i__4 = j + j * a_dim1;
+ d__3 = ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[j +
+ j * a_dim1]), abs(d__2))) * s[j];
+ z__1.r = work[i__3].r + d__3, z__1.i = work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ + j * a_dim1]), abs(d__2));
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ d__3 = ((d__1 = a[i__5].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2))) * s[j];
+ z__1.r = work[i__4].r + d__3, z__1.i = work[i__4].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ i__3 = j;
+ i__4 = j;
+ i__5 = i__ + j * a_dim1;
+ d__3 = ((d__1 = a[i__5].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2))) * s[i__];
+ z__1.r = work[i__4].r + d__3, z__1.i = work[i__4].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ }
+ }
+ }
+/* avg = s^T beta / n */
+ avg = 0.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ z__2.r = s[i__2] * work[i__3].r, z__2.i = s[i__2] * work[i__3].i;
+ z__1.r = avg + z__2.r, z__1.i = z__2.i;
+ avg = z__1.r;
+ }
+ avg /= *n;
+ std = 0.;
+ i__1 = *n * 3;
+ for (i__ = (*n << 1) + 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__ - (*n << 1);
+ i__4 = i__ - (*n << 1);
+ z__2.r = s[i__3] * work[i__4].r, z__2.i = s[i__3] * work[i__4].i;
+ z__1.r = z__2.r - avg, z__1.i = z__2.i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ zlassq_(n, &work[(*n << 1) + 1], &c__1, &scale, &sumsq);
+ std = scale * sqrt(sumsq / *n);
+ if (std < tol * avg) {
+ goto L999;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ t = (d__1 = a[i__2].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + i__ *
+ a_dim1]), abs(d__2));
+ si = s[i__];
+ c2 = (*n - 1) * t;
+ i__2 = *n - 2;
+ i__3 = i__;
+ d__1 = t * si;
+ z__2.r = work[i__3].r - d__1, z__2.i = work[i__3].i;
+ d__2 = (doublereal) i__2;
+ z__1.r = d__2 * z__2.r, z__1.i = d__2 * z__2.i;
+ c1 = z__1.r;
+ d__1 = -(t * si) * si;
+ i__2 = i__;
+ d__2 = 2.;
+ z__4.r = d__2 * work[i__2].r, z__4.i = d__2 * work[i__2].i;
+ z__3.r = si * z__4.r, z__3.i = si * z__4.i;
+ z__2.r = d__1 + z__3.r, z__2.i = z__3.i;
+ d__3 = *n * avg;
+ z__1.r = z__2.r - d__3, z__1.i = z__2.i;
+ c0 = z__1.r;
+ d__ = c1 * c1 - c0 * 4 * c2;
+ if (d__ <= 0.) {
+ *info = -1;
+ return 0;
+ }
+ si = c0 * -2 / (c1 + sqrt(d__));
+ d__ = si - s[i__];
+ u = 0.;
+ if (up) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[j +
+ i__ * a_dim1]), abs(d__2));
+ u += s[j] * t;
+ i__3 = j;
+ i__4 = j;
+ d__1 = d__ * t;
+ z__1.r = work[i__4].r + d__1, z__1.i = work[i__4].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ + j * a_dim1]), abs(d__2));
+ u += s[j] * t;
+ i__3 = j;
+ i__4 = j;
+ d__1 = d__ * t;
+ z__1.r = work[i__4].r + d__1, z__1.i = work[i__4].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ + j * a_dim1]), abs(d__2));
+ u += s[j] * t;
+ i__3 = j;
+ i__4 = j;
+ d__1 = d__ * t;
+ z__1.r = work[i__4].r + d__1, z__1.i = work[i__4].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[j +
+ i__ * a_dim1]), abs(d__2));
+ u += s[j] * t;
+ i__3 = j;
+ i__4 = j;
+ d__1 = d__ * t;
+ z__1.r = work[i__4].r + d__1, z__1.i = work[i__4].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ }
+ }
+ i__2 = i__;
+ z__4.r = u + work[i__2].r, z__4.i = work[i__2].i;
+ z__3.r = d__ * z__4.r, z__3.i = d__ * z__4.i;
+ d__1 = (doublereal) (*n);
+ z__2.r = z__3.r / d__1, z__2.i = z__3.i / d__1;
+ z__1.r = avg + z__2.r, z__1.i = z__2.i;
+ avg = z__1.r;
+ s[i__] = si;
+ }
+ }
+L999:
+ smlnum = dlamch_("SAFEMIN");
+ bignum = 1. / smlnum;
+ smin = bignum;
+ smax = 0.;
+ t = 1. / sqrt(avg);
+ base = dlamch_("B");
+ u = 1. / log(base);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = (integer) (u * log(s[i__] * t));
+ s[i__] = pow_di(&base, &i__2);
+/* Computing MIN */
+ d__1 = smin, d__2 = s[i__];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = smax, d__2 = s[i__];
+ smax = max(d__1,d__2);
+ }
+ *scond = max(smin,smlnum) / min(smax,bignum);
+ return 0;
+} /* zheequb_ */
diff --git a/SRC/zheev.c b/SRC/zheev.c
new file mode 100644
index 0000000..f712fd8
--- /dev/null
+++ b/SRC/zheev.c
@@ -0,0 +1,289 @@
+/* zheev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static doublereal c_b18 = 1.;
+
+/* Subroutine */ int zheev_(char *jobz, char *uplo, integer *n, doublecomplex
+ *a, integer *lda, doublereal *w, doublecomplex *work, integer *lwork,
+ doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer nb;
+ doublereal eps;
+ integer inde;
+ doublereal anrm;
+ integer imax;
+ doublereal rmin, rmax;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical lower, wantz;
+ extern doublereal dlamch_(char *);
+ integer iscale;
+ doublereal safmin;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ integer indtau;
+ extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
+ integer *), zlascl_(char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublecomplex *, integer *,
+ integer *);
+ integer indwrk;
+ extern /* Subroutine */ int zhetrd_(char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublecomplex *,
+ doublecomplex *, integer *, integer *);
+ integer llwork;
+ doublereal smlnum;
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int zsteqr_(char *, integer *, doublereal *,
+ doublereal *, doublecomplex *, integer *, doublereal *, integer *), zungtr_(char *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHEEV computes all eigenvalues and, optionally, eigenvectors of a */
+/* complex Hermitian matrix A. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (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. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
+/* orthonormal eigenvectors of the matrix A. */
+/* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') */
+/* or the upper triangle (if UPLO='U') of A, including the */
+/* diagonal, is destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(1,2*N-1). */
+/* For optimal efficiency, LWORK >= (NB+1)*N, */
+/* where NB is the blocksize for ZHETRD 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. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of an intermediate tridiagonal */
+/* form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ lower = lsame_(uplo, "L");
+ lquery = *lwork == -1;
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+
+ if (*info == 0) {
+ nb = ilaenv_(&c__1, "ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = 1, i__2 = (nb + 1) * *n;
+ lwkopt = max(i__1,i__2);
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+/* Computing MAX */
+ i__1 = 1, i__2 = (*n << 1) - 1;
+ if (*lwork < max(i__1,i__2) && ! lquery) {
+ *info = -8;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHEEV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ i__1 = a_dim1 + 1;
+ w[1] = a[i__1].r;
+ work[1].r = 1., work[1].i = 0.;
+ if (wantz) {
+ i__1 = a_dim1 + 1;
+ a[i__1].r = 1., a[i__1].i = 0.;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = zlanhe_("M", uplo, n, &a[a_offset], lda, &rwork[1]);
+ iscale = 0;
+ if (anrm > 0. && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ zlascl_(uplo, &c__0, &c__0, &c_b18, &sigma, n, n, &a[a_offset], lda,
+ info);
+ }
+
+/* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. */
+
+ inde = 1;
+ indtau = 1;
+ indwrk = indtau + *n;
+ llwork = *lwork - indwrk + 1;
+ zhetrd_(uplo, n, &a[a_offset], lda, &w[1], &rwork[inde], &work[indtau], &
+ work[indwrk], &llwork, &iinfo);
+
+/* For eigenvalues only, call DSTERF. For eigenvectors, first call */
+/* ZUNGTR to generate the unitary matrix, then call ZSTEQR. */
+
+ if (! wantz) {
+ dsterf_(n, &w[1], &rwork[inde], info);
+ } else {
+ zungtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], &
+ llwork, &iinfo);
+ indwrk = inde + *n;
+ zsteqr_(jobz, n, &w[1], &rwork[inde], &a[a_offset], lda, &rwork[
+ indwrk], info);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *n;
+ } else {
+ imax = *info - 1;
+ }
+ d__1 = 1. / sigma;
+ dscal_(&imax, &d__1, &w[1], &c__1);
+ }
+
+/* Set WORK(1) to optimal complex workspace size. */
+
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZHEEV */
+
+} /* zheev_ */
diff --git a/SRC/zheevd.c b/SRC/zheevd.c
new file mode 100644
index 0000000..cf766e4
--- /dev/null
+++ b/SRC/zheevd.c
@@ -0,0 +1,382 @@
+/* zheevd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static doublereal c_b18 = 1.;
+
+/* Subroutine */ int zheevd_(char *jobz, char *uplo, integer *n,
+ doublecomplex *a, integer *lda, doublereal *w, doublecomplex *work,
+ integer *lwork, doublereal *rwork, integer *lrwork, integer *iwork,
+ integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal eps;
+ integer inde;
+ doublereal anrm;
+ integer imax;
+ doublereal rmin, rmax;
+ integer lopt;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo, lwmin, liopt;
+ logical lower;
+ integer llrwk, lropt;
+ logical wantz;
+ integer indwk2, llwrk2;
+ extern doublereal dlamch_(char *);
+ integer iscale;
+ doublereal safmin;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ integer indtau;
+ extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
+ integer *), zlascl_(char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublecomplex *, integer *,
+ integer *), zstedc_(char *, integer *, doublereal *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, integer *, integer *, integer *, integer
+ *);
+ integer indrwk, indwrk, liwmin;
+ extern /* Subroutine */ int zhetrd_(char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublecomplex *,
+ doublecomplex *, integer *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *);
+ integer lrwmin, llwork;
+ doublereal smlnum;
+ logical lquery;
+ extern /* Subroutine */ int zunmtr_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHEEVD computes all eigenvalues and, optionally, eigenvectors of a */
+/* complex Hermitian matrix A. If eigenvectors are desired, it uses a */
+/* divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (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. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
+/* orthonormal eigenvectors of the matrix A. */
+/* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') */
+/* or the upper triangle (if UPLO='U') of A, including the */
+/* diagonal, is destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. */
+/* If N <= 1, LWORK must be at least 1. */
+/* If JOBZ = 'N' and N > 1, LWORK must be at least N + 1. */
+/* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N + N**2. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK, RWORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* RWORK (workspace/output) DOUBLE PRECISION array, */
+/* dimension (LRWORK) */
+/* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. */
+
+/* LRWORK (input) INTEGER */
+/* The dimension of the array RWORK. */
+/* If N <= 1, LRWORK must be at least 1. */
+/* If JOBZ = 'N' and N > 1, LRWORK must be at least N. */
+/* If JOBZ = 'V' and N > 1, LRWORK must be at least */
+/* 1 + 5*N + 2*N**2. */
+
+/* If LRWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If N <= 1, LIWORK must be at least 1. */
+/* If JOBZ = 'N' and N > 1, LIWORK must be at least 1. */
+/* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed */
+/* to converge; i off-diagonal elements of an intermediate */
+/* tridiagonal form did not converge to zero; */
+/* if INFO = i and JOBZ = 'V', then the algorithm failed */
+/* to compute an eigenvalue while working on the submatrix */
+/* lying in rows and columns INFO/(N+1) through */
+/* mod(INFO,N+1). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* Modified description of INFO. Sven, 16 Feb 05. */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ lower = lsame_(uplo, "L");
+ lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+
+ if (*info == 0) {
+ if (*n <= 1) {
+ lwmin = 1;
+ lrwmin = 1;
+ liwmin = 1;
+ lopt = lwmin;
+ lropt = lrwmin;
+ liopt = liwmin;
+ } else {
+ if (wantz) {
+ lwmin = (*n << 1) + *n * *n;
+/* Computing 2nd power */
+ i__1 = *n;
+ lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
+ liwmin = *n * 5 + 3;
+ } else {
+ lwmin = *n + 1;
+ lrwmin = *n;
+ liwmin = 1;
+ }
+/* Computing MAX */
+ i__1 = lwmin, i__2 = *n + ilaenv_(&c__1, "ZHETRD", uplo, n, &c_n1,
+ &c_n1, &c_n1);
+ lopt = max(i__1,i__2);
+ lropt = lrwmin;
+ liopt = liwmin;
+ }
+ work[1].r = (doublereal) lopt, work[1].i = 0.;
+ rwork[1] = (doublereal) lropt;
+ iwork[1] = liopt;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -8;
+ } else if (*lrwork < lrwmin && ! lquery) {
+ *info = -10;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHEEVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ i__1 = a_dim1 + 1;
+ w[1] = a[i__1].r;
+ if (wantz) {
+ i__1 = a_dim1 + 1;
+ a[i__1].r = 1., a[i__1].i = 0.;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = zlanhe_("M", uplo, n, &a[a_offset], lda, &rwork[1]);
+ iscale = 0;
+ if (anrm > 0. && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ zlascl_(uplo, &c__0, &c__0, &c_b18, &sigma, n, n, &a[a_offset], lda,
+ info);
+ }
+
+/* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. */
+
+ inde = 1;
+ indtau = 1;
+ indwrk = indtau + *n;
+ indrwk = inde + *n;
+ indwk2 = indwrk + *n * *n;
+ llwork = *lwork - indwrk + 1;
+ llwrk2 = *lwork - indwk2 + 1;
+ llrwk = *lrwork - indrwk + 1;
+ zhetrd_(uplo, n, &a[a_offset], lda, &w[1], &rwork[inde], &work[indtau], &
+ work[indwrk], &llwork, &iinfo);
+
+/* For eigenvalues only, call DSTERF. For eigenvectors, first call */
+/* ZSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the */
+/* tridiagonal matrix, then call ZUNMTR to multiply it to the */
+/* Householder transformations represented as Householder vectors in */
+/* A. */
+
+ if (! wantz) {
+ dsterf_(n, &w[1], &rwork[inde], info);
+ } else {
+ zstedc_("I", n, &w[1], &rwork[inde], &work[indwrk], n, &work[indwk2],
+ &llwrk2, &rwork[indrwk], &llrwk, &iwork[1], liwork, info);
+ zunmtr_("L", uplo, "N", n, n, &a[a_offset], lda, &work[indtau], &work[
+ indwrk], n, &work[indwk2], &llwrk2, &iinfo);
+ zlacpy_("A", n, n, &work[indwrk], n, &a[a_offset], lda);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *n;
+ } else {
+ imax = *info - 1;
+ }
+ d__1 = 1. / sigma;
+ dscal_(&imax, &d__1, &w[1], &c__1);
+ }
+
+ work[1].r = (doublereal) lopt, work[1].i = 0.;
+ rwork[1] = (doublereal) lropt;
+ iwork[1] = liopt;
+
+ return 0;
+
+/* End of ZHEEVD */
+
+} /* zheevd_ */
diff --git a/SRC/zheevr.c b/SRC/zheevr.c
new file mode 100644
index 0000000..66d725b
--- /dev/null
+++ b/SRC/zheevr.c
@@ -0,0 +1,696 @@
+/* zheevr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__10 = 10;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zheevr_(char *jobz, char *range, char *uplo, integer *n,
+ doublecomplex *a, integer *lda, doublereal *vl, doublereal *vu,
+ integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *
+ w, doublecomplex *z__, integer *ldz, integer *isuppz, doublecomplex *
+ work, integer *lwork, doublereal *rwork, integer *lrwork, integer *
+ iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, nb, jj;
+ doublereal eps, vll, vuu, tmp1, anrm;
+ integer imax;
+ doublereal rmin, rmax;
+ logical test;
+ integer itmp1;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ integer indrd, indre;
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ char order[1];
+ integer indwk;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer lwmin;
+ logical lower, wantz;
+ extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ logical alleig, indeig;
+ integer iscale, ieeeok, indibl, indrdd, indifl, indree;
+ logical valeig;
+ doublereal safmin;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
+ integer *, doublereal *, doublecomplex *, integer *);
+ doublereal abstll, bignum;
+ integer indtau, indisp;
+ extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
+ integer *);
+ integer indiwo, indwkn;
+ extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal
+ *, doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, integer *);
+ integer indrwk, liwmin;
+ extern /* Subroutine */ int zhetrd_(char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublecomplex *,
+ doublecomplex *, integer *, integer *);
+ logical tryrac;
+ integer lrwmin, llwrkn, llwork, nsplit;
+ doublereal smlnum;
+ extern /* Subroutine */ int zstein_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *, integer *, integer *, integer *);
+ logical lquery;
+ integer lwkopt;
+ extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zstemr_(char *, char *, integer *, doublereal
+ *, doublereal *, doublereal *, doublereal *, integer *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *, integer *,
+ integer *, logical *, doublereal *, integer *, integer *, integer
+ *, integer *), zunmtr_(char *, char *, char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+);
+ integer llrwork;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHEEVR computes selected eigenvalues and, optionally, eigenvectors */
+/* of a complex Hermitian matrix A. Eigenvalues and eigenvectors can */
+/* be selected by specifying either a range of values or a range of */
+/* indices for the desired eigenvalues. */
+
+/* ZHEEVR first reduces the matrix A to tridiagonal form T with a call */
+/* to ZHETRD. Then, whenever possible, ZHEEVR calls ZSTEMR to compute */
+/* eigenspectrum using Relatively Robust Representations. ZSTEMR */
+/* computes eigenvalues by the dqds algorithm, while orthogonal */
+/* eigenvectors are computed from various "good" L D L^T representations */
+/* (also known as Relatively Robust Representations). Gram-Schmidt */
+/* orthogonalization is avoided as far as possible. More specifically, */
+/* the various steps of the algorithm are as follows. */
+
+/* For each unreduced block (submatrix) of T, */
+/* (a) Compute T - sigma I = L D L^T, so that L and D */
+/* define all the wanted eigenvalues to high relative accuracy. */
+/* This means that small relative changes in the entries of D and L */
+/* cause only small relative changes in the eigenvalues and */
+/* eigenvectors. The standard (unfactored) representation of the */
+/* tridiagonal matrix T does not have this property in general. */
+/* (b) Compute the eigenvalues to suitable accuracy. */
+/* If the eigenvectors are desired, the algorithm attains full */
+/* accuracy of the computed eigenvalues only right before */
+/* the corresponding vectors have to be computed, see steps c) and d). */
+/* (c) For each cluster of close eigenvalues, select a new */
+/* shift close to the cluster, find a new factorization, and refine */
+/* the shifted eigenvalues to suitable accuracy. */
+/* (d) For each eigenvalue with a large enough relative separation compute */
+/* the corresponding eigenvector by forming a rank revealing twisted */
+/* factorization. Go back to (c) for any clusters that remain. */
+
+/* The desired accuracy of the output can be specified by the input */
+/* parameter ABSTOL. */
+
+/* For more details, see DSTEMR's documentation and: */
+/* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */
+/* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */
+/* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */
+/* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */
+/* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */
+/* 2004. Also LAPACK Working Note 154. */
+/* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */
+/* tridiagonal eigenvalue/eigenvector problem", */
+/* Computer Science Division Technical Report No. UCB/CSD-97-971, */
+/* UC Berkeley, May 1997. */
+
+
+/* Note 1 : ZHEEVR calls ZSTEMR when the full spectrum is requested */
+/* on machines which conform to the ieee-754 floating point standard. */
+/* ZHEEVR calls DSTEBZ and ZSTEIN on non-ieee machines and */
+/* when partial spectrum requests are made. */
+
+/* Normal execution of ZSTEMR may create NaNs and infinities and */
+/* hence may abort due to a floating point exception in environments */
+/* which do not handle NaNs and infinities in the ieee standard default */
+/* manner. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+/* ********* For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and */
+/* ********* ZSTEIN are called */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (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. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+/* On exit, the lower triangle (if UPLO='L') or the upper */
+/* triangle (if UPLO='U') of A, including the diagonal, is */
+/* destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) DOUBLE PRECISION */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing A to tridiagonal form. */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices */
+/* with Guaranteed High Relative Accuracy," by Demmel and */
+/* Kahan, LAPACK Working Note #3. */
+
+/* If high relative accuracy is important, set ABSTOL to */
+/* DLAMCH( 'Safe minimum' ). Doing so will guarantee that */
+/* eigenvalues are computed to high relative accuracy when */
+/* possible in future releases. The current code does not */
+/* make any guarantees about high relative accuracy, but */
+/* furutre releases will. See J. Barlow and J. Demmel, */
+/* "Computing Accurate Eigensystems of Scaled Diagonally */
+/* Dominant Matrices", LAPACK Working Note #7, for a discussion */
+/* of which matrices define their eigenvalues to high relative */
+/* accuracy. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* The first M elements contain the selected eigenvalues in */
+/* ascending order. */
+
+/* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M)) */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */
+/* The support of the eigenvectors in Z, i.e., the indices */
+/* indicating the nonzero elements in Z. The i-th eigenvector */
+/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */
+/* ISUPPZ( 2*i ). */
+/* ********* Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(1,2*N). */
+/* For optimal efficiency, LWORK >= (NB+1)*N, */
+/* where NB is the max of the blocksize for ZHETRD and for */
+/* ZUNMTR as returned by ILAENV. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK, RWORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* RWORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LRWORK)) */
+/* On exit, if INFO = 0, RWORK(1) returns the optimal */
+/* (and minimal) LRWORK. */
+
+/* LRWORK (input) INTEGER */
+/* The length of the array RWORK. LRWORK >= max(1,24*N). */
+
+/* If LRWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal */
+/* (and minimal) LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. LIWORK >= max(1,10*N). */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: Internal error */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Inderjit Dhillon, IBM Almaden, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Ken Stanley, Computer Science Division, University of */
+/* California at Berkeley, USA */
+/* Jason Riedy, Computer Science Division, University of */
+/* California at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --isuppz;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ ieeeok = ilaenv_(&c__10, "ZHEEVR", "N", &c__1, &c__2, &c__3, &c__4);
+
+ lower = lsame_(uplo, "L");
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * 24;
+ lrwmin = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = *n * 10;
+ liwmin = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = *n << 1;
+ lwmin = max(i__1,i__2);
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -8;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -9;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -10;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -15;
+ }
+ }
+
+ if (*info == 0) {
+ nb = ilaenv_(&c__1, "ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMTR", uplo, n, &c_n1, &c_n1, &
+ c_n1);
+ nb = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = (nb + 1) * *n;
+ lwkopt = max(i__1,lwmin);
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ rwork[1] = (doublereal) lrwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -18;
+ } else if (*lrwork < lrwmin && ! lquery) {
+ *info = -20;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -22;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHEEVR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ work[1].r = 1., work[1].i = 0.;
+ return 0;
+ }
+
+ if (*n == 1) {
+ work[1].r = 2., work[1].i = 0.;
+ if (alleig || indeig) {
+ *m = 1;
+ i__1 = a_dim1 + 1;
+ w[1] = a[i__1].r;
+ } else {
+ i__1 = a_dim1 + 1;
+ i__2 = a_dim1 + 1;
+ if (*vl < a[i__1].r && *vu >= a[i__2].r) {
+ *m = 1;
+ i__1 = a_dim1 + 1;
+ w[1] = a[i__1].r;
+ }
+ }
+ if (wantz) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1., z__[i__1].i = 0.;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
+ rmax = min(d__1,d__2);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ abstll = *abstol;
+ if (valeig) {
+ vll = *vl;
+ vuu = *vu;
+ }
+ anrm = zlansy_("M", uplo, n, &a[a_offset], lda, &rwork[1]);
+ if (anrm > 0. && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ if (lower) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ zdscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ zdscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+ if (*abstol > 0.) {
+ abstll = *abstol * sigma;
+ }
+ if (valeig) {
+ vll = *vl * sigma;
+ vuu = *vu * sigma;
+ }
+ }
+/* Initialize indices into workspaces. Note: The IWORK indices are */
+/* used only if DSTERF or ZSTEMR fail. */
+/* WORK(INDTAU:INDTAU+N-1) stores the complex scalar factors of the */
+/* elementary reflectors used in ZHETRD. */
+ indtau = 1;
+/* INDWK is the starting offset of the remaining complex workspace, */
+/* and LLWORK is the remaining complex workspace size. */
+ indwk = indtau + *n;
+ llwork = *lwork - indwk + 1;
+/* RWORK(INDRD:INDRD+N-1) stores the real tridiagonal's diagonal */
+/* entries. */
+ indrd = 1;
+/* RWORK(INDRE:INDRE+N-1) stores the off-diagonal entries of the */
+/* tridiagonal matrix from ZHETRD. */
+ indre = indrd + *n;
+/* RWORK(INDRDD:INDRDD+N-1) is a copy of the diagonal entries over */
+/* -written by ZSTEMR (the DSTERF path copies the diagonal to W). */
+ indrdd = indre + *n;
+/* RWORK(INDREE:INDREE+N-1) is a copy of the off-diagonal entries over */
+/* -written while computing the eigenvalues in DSTERF and ZSTEMR. */
+ indree = indrdd + *n;
+/* INDRWK is the starting offset of the left-over real workspace, and */
+/* LLRWORK is the remaining workspace size. */
+ indrwk = indree + *n;
+ llrwork = *lrwork - indrwk + 1;
+/* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and */
+/* stores the block indices of each of the M<=N eigenvalues. */
+ indibl = 1;
+/* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and */
+/* stores the starting and finishing indices of each block. */
+ indisp = indibl + *n;
+/* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors */
+/* that corresponding to eigenvectors that fail to converge in */
+/* DSTEIN. This information is discarded; if any fail, the driver */
+/* returns INFO > 0. */
+ indifl = indisp + *n;
+/* INDIWO is the offset of the remaining integer workspace. */
+ indiwo = indisp + *n;
+
+/* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. */
+
+ zhetrd_(uplo, n, &a[a_offset], lda, &rwork[indrd], &rwork[indre], &work[
+ indtau], &work[indwk], &llwork, &iinfo);
+
+/* If all eigenvalues are desired */
+/* then call DSTERF or ZSTEMR and ZUNMTR. */
+
+ test = FALSE_;
+ if (indeig) {
+ if (*il == 1 && *iu == *n) {
+ test = TRUE_;
+ }
+ }
+ if ((alleig || test) && ieeeok == 1) {
+ if (! wantz) {
+ dcopy_(n, &rwork[indrd], &c__1, &w[1], &c__1);
+ i__1 = *n - 1;
+ dcopy_(&i__1, &rwork[indre], &c__1, &rwork[indree], &c__1);
+ dsterf_(n, &w[1], &rwork[indree], info);
+ } else {
+ i__1 = *n - 1;
+ dcopy_(&i__1, &rwork[indre], &c__1, &rwork[indree], &c__1);
+ dcopy_(n, &rwork[indrd], &c__1, &rwork[indrdd], &c__1);
+
+ if (*abstol <= *n * 2. * eps) {
+ tryrac = TRUE_;
+ } else {
+ tryrac = FALSE_;
+ }
+ zstemr_(jobz, "A", n, &rwork[indrdd], &rwork[indree], vl, vu, il,
+ iu, m, &w[1], &z__[z_offset], ldz, n, &isuppz[1], &tryrac,
+ &rwork[indrwk], &llrwork, &iwork[1], liwork, info);
+
+/* Apply unitary matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by ZSTEIN. */
+
+ if (wantz && *info == 0) {
+ indwkn = indwk;
+ llwrkn = *lwork - indwkn + 1;
+ zunmtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau]
+, &z__[z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
+ }
+ }
+
+
+ if (*info == 0) {
+ *m = *n;
+ goto L30;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN. */
+/* Also call DSTEBZ and ZSTEIN if ZSTEMR fails. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indrd], &
+ rwork[indre], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &
+ rwork[indrwk], &iwork[indiwo], info);
+
+ if (wantz) {
+ zstein_(n, &rwork[indrd], &rwork[indre], m, &w[1], &iwork[indibl], &
+ iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[
+ indiwo], &iwork[indifl], info);
+
+/* Apply unitary matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by ZSTEIN. */
+
+ indwkn = indwk;
+ llwrkn = *lwork - indwkn + 1;
+ zunmtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[
+ z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+L30:
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *m;
+ } else {
+ imax = *info - 1;
+ }
+ d__1 = 1. / sigma;
+ dscal_(&imax, &d__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L40: */
+ }
+
+ if (i__ != 0) {
+ itmp1 = iwork[indibl + i__ - 1];
+ w[i__] = w[j];
+ iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
+ w[j] = tmp1;
+ iwork[indibl + j - 1] = itmp1;
+ zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ }
+/* L50: */
+ }
+ }
+
+/* Set WORK(1) to optimal workspace size. */
+
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ rwork[1] = (doublereal) lrwmin;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of ZHEEVR */
+
+} /* zheevr_ */
diff --git a/SRC/zheevx.c b/SRC/zheevx.c
new file mode 100644
index 0000000..30a6090
--- /dev/null
+++ b/SRC/zheevx.c
@@ -0,0 +1,548 @@
+/* zheevx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zheevx_(char *jobz, char *range, char *uplo, integer *n,
+ doublecomplex *a, integer *lda, doublereal *vl, doublereal *vu,
+ integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *
+ w, doublecomplex *z__, integer *ldz, doublecomplex *work, integer *
+ lwork, doublereal *rwork, integer *iwork, integer *ifail, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, nb, jj;
+ doublereal eps, vll, vuu, tmp1;
+ integer indd, inde;
+ doublereal anrm;
+ integer imax;
+ doublereal rmin, rmax;
+ logical test;
+ integer itmp1, indee;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ char order[1];
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical lower, wantz;
+ extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ logical alleig, indeig;
+ integer iscale, indibl;
+ logical valeig;
+ doublereal safmin;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
+ integer *, doublereal *, doublecomplex *, integer *);
+ doublereal abstll, bignum;
+ extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ integer indiwk, indisp, indtau;
+ extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
+ integer *), dstebz_(char *, char *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, integer *);
+ integer indrwk, indwrk;
+ extern /* Subroutine */ int zhetrd_(char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublecomplex *,
+ doublecomplex *, integer *, integer *);
+ integer lwkmin;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ integer llwork, nsplit;
+ doublereal smlnum;
+ extern /* Subroutine */ int zstein_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *, integer *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int zsteqr_(char *, integer *, doublereal *,
+ doublereal *, doublecomplex *, integer *, doublereal *, integer *), zungtr_(char *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *),
+ zunmtr_(char *, char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHEEVX computes selected eigenvalues and, optionally, eigenvectors */
+/* of a complex Hermitian matrix A. Eigenvalues and eigenvectors can */
+/* be selected by specifying either a range of values or a range of */
+/* indices for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (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. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+/* On exit, the lower triangle (if UPLO='L') or the upper */
+/* triangle (if UPLO='U') of A, including the diagonal, is */
+/* destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) DOUBLE PRECISION */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing A to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*DLAMCH('S'). */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices */
+/* with Guaranteed High Relative Accuracy," by Demmel and */
+/* Kahan, LAPACK Working Note #3. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* On normal exit, the first M elements contain the selected */
+/* eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M)) */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If an eigenvector fails to converge, then that column of Z */
+/* contains the latest approximation to the eigenvector, and the */
+/* index of the eigenvector is returned in IFAIL. */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= 1, when N <= 1; */
+/* otherwise 2*N. */
+/* For optimal efficiency, LWORK >= (NB+1)*N, */
+/* where NB is the max of the blocksize for ZHETRD and for */
+/* ZUNMTR as 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. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, then i eigenvectors failed to converge. */
+/* Their indices are stored in array IFAIL. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ lower = lsame_(uplo, "L");
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+ lquery = *lwork == -1;
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (! (lower || lsame_(uplo, "U"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -8;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -9;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -10;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -15;
+ }
+ }
+
+ if (*info == 0) {
+ if (*n <= 1) {
+ lwkmin = 1;
+ work[1].r = (doublereal) lwkmin, work[1].i = 0.;
+ } else {
+ lwkmin = *n << 1;
+ nb = ilaenv_(&c__1, "ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMTR", uplo, n, &c_n1, &c_n1,
+ &c_n1);
+ nb = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = (nb + 1) * *n;
+ lwkopt = max(i__1,i__2);
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ }
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *n << 1;
+ if (*lwork < max(i__1,i__2) && ! lquery) {
+ *info = -17;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHEEVX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (alleig || indeig) {
+ *m = 1;
+ i__1 = a_dim1 + 1;
+ w[1] = a[i__1].r;
+ } else if (valeig) {
+ i__1 = a_dim1 + 1;
+ i__2 = a_dim1 + 1;
+ if (*vl < a[i__1].r && *vu >= a[i__2].r) {
+ *m = 1;
+ i__1 = a_dim1 + 1;
+ w[1] = a[i__1].r;
+ }
+ }
+ if (wantz) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1., z__[i__1].i = 0.;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
+ rmax = min(d__1,d__2);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ abstll = *abstol;
+ if (valeig) {
+ vll = *vl;
+ vuu = *vu;
+ }
+ anrm = zlanhe_("M", uplo, n, &a[a_offset], lda, &rwork[1]);
+ if (anrm > 0. && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ if (lower) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ zdscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ zdscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+ if (*abstol > 0.) {
+ abstll = *abstol * sigma;
+ }
+ if (valeig) {
+ vll = *vl * sigma;
+ vuu = *vu * sigma;
+ }
+ }
+
+/* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. */
+
+ indd = 1;
+ inde = indd + *n;
+ indrwk = inde + *n;
+ indtau = 1;
+ indwrk = indtau + *n;
+ llwork = *lwork - indwrk + 1;
+ zhetrd_(uplo, n, &a[a_offset], lda, &rwork[indd], &rwork[inde], &work[
+ indtau], &work[indwrk], &llwork, &iinfo);
+
+/* If all eigenvalues are desired and ABSTOL is less than or equal to */
+/* zero, then call DSTERF or ZUNGTR and ZSTEQR. If this fails for */
+/* some eigenvalue, then try DSTEBZ. */
+
+ test = FALSE_;
+ if (indeig) {
+ if (*il == 1 && *iu == *n) {
+ test = TRUE_;
+ }
+ }
+ if ((alleig || test) && *abstol <= 0.) {
+ dcopy_(n, &rwork[indd], &c__1, &w[1], &c__1);
+ indee = indrwk + (*n << 1);
+ if (! wantz) {
+ i__1 = *n - 1;
+ dcopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
+ dsterf_(n, &w[1], &rwork[indee], info);
+ } else {
+ zlacpy_("A", n, n, &a[a_offset], lda, &z__[z_offset], ldz);
+ zungtr_(uplo, n, &z__[z_offset], ldz, &work[indtau], &work[indwrk]
+, &llwork, &iinfo);
+ i__1 = *n - 1;
+ dcopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
+ zsteqr_(jobz, n, &w[1], &rwork[indee], &z__[z_offset], ldz, &
+ rwork[indrwk], info);
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ifail[i__] = 0;
+/* L30: */
+ }
+ }
+ }
+ if (*info == 0) {
+ *m = *n;
+ goto L40;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ indibl = 1;
+ indisp = indibl + *n;
+ indiwk = indisp + *n;
+ dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], &
+ rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &
+ rwork[indrwk], &iwork[indiwk], info);
+
+ if (wantz) {
+ zstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], &
+ iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[
+ indiwk], &ifail[1], info);
+
+/* Apply unitary matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by ZSTEIN. */
+
+ zunmtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[
+ z_offset], ldz, &work[indwrk], &llwork, &iinfo);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+L40:
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *m;
+ } else {
+ imax = *info - 1;
+ }
+ d__1 = 1. / sigma;
+ dscal_(&imax, &d__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L50: */
+ }
+
+ if (i__ != 0) {
+ itmp1 = iwork[indibl + i__ - 1];
+ w[i__] = w[j];
+ iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
+ w[j] = tmp1;
+ iwork[indibl + j - 1] = itmp1;
+ zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ if (*info != 0) {
+ itmp1 = ifail[i__];
+ ifail[i__] = ifail[j];
+ ifail[j] = itmp1;
+ }
+ }
+/* L60: */
+ }
+ }
+
+/* Set WORK(1) to optimal complex workspace size. */
+
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZHEEVX */
+
+} /* zheevx_ */
diff --git a/SRC/zhegs2.c b/SRC/zhegs2.c
new file mode 100644
index 0000000..3e7f85e
--- /dev/null
+++ b/SRC/zhegs2.c
@@ -0,0 +1,338 @@
+/* zhegs2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zhegs2_(integer *itype, char *uplo, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer k;
+ doublecomplex ct;
+ doublereal akk, bkk;
+ extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), ztrmv_(
+ char *, char *, char *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), ztrsv_(char *
+, char *, char *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), xerbla_(char
+ *, integer *), zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *), zlacgv_(integer *, doublecomplex *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHEGS2 reduces a complex Hermitian-definite generalized */
+/* eigenproblem to standard form. */
+
+/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
+/* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L') */
+
+/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
+/* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L. */
+
+/* B must have been previously factorized as U'*U or L*L' by ZPOTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L'); */
+/* = 2 or 3: compute U*A*U' or L'*A*L. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored, and how B has been factorized. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) 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, the transformed matrix, stored in the */
+/* same format as A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,N) */
+/* The triangular factor from the Cholesky factorization of B, */
+/* as returned by ZPOTRF. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHEGS2", &i__1);
+ return 0;
+ }
+
+ if (*itype == 1) {
+ if (upper) {
+
+/* Compute inv(U')*A*inv(U) */
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+/* Update the upper triangle of A(k:n,k:n) */
+
+ i__2 = k + k * a_dim1;
+ akk = a[i__2].r;
+ i__2 = k + k * b_dim1;
+ bkk = b[i__2].r;
+/* Computing 2nd power */
+ d__1 = bkk;
+ akk /= d__1 * d__1;
+ i__2 = k + k * a_dim1;
+ a[i__2].r = akk, a[i__2].i = 0.;
+ if (k < *n) {
+ i__2 = *n - k;
+ d__1 = 1. / bkk;
+ zdscal_(&i__2, &d__1, &a[k + (k + 1) * a_dim1], lda);
+ d__1 = akk * -.5;
+ ct.r = d__1, ct.i = 0.;
+ i__2 = *n - k;
+ zlacgv_(&i__2, &a[k + (k + 1) * a_dim1], lda);
+ i__2 = *n - k;
+ zlacgv_(&i__2, &b[k + (k + 1) * b_dim1], ldb);
+ i__2 = *n - k;
+ zaxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
+ k + 1) * a_dim1], lda);
+ i__2 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zher2_(uplo, &i__2, &z__1, &a[k + (k + 1) * a_dim1], lda,
+ &b[k + (k + 1) * b_dim1], ldb, &a[k + 1 + (k + 1)
+ * a_dim1], lda);
+ i__2 = *n - k;
+ zaxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
+ k + 1) * a_dim1], lda);
+ i__2 = *n - k;
+ zlacgv_(&i__2, &b[k + (k + 1) * b_dim1], ldb);
+ i__2 = *n - k;
+ ztrsv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &b[
+ k + 1 + (k + 1) * b_dim1], ldb, &a[k + (k + 1) *
+ a_dim1], lda);
+ i__2 = *n - k;
+ zlacgv_(&i__2, &a[k + (k + 1) * a_dim1], lda);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Compute inv(L)*A*inv(L') */
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+/* Update the lower triangle of A(k:n,k:n) */
+
+ i__2 = k + k * a_dim1;
+ akk = a[i__2].r;
+ i__2 = k + k * b_dim1;
+ bkk = b[i__2].r;
+/* Computing 2nd power */
+ d__1 = bkk;
+ akk /= d__1 * d__1;
+ i__2 = k + k * a_dim1;
+ a[i__2].r = akk, a[i__2].i = 0.;
+ if (k < *n) {
+ i__2 = *n - k;
+ d__1 = 1. / bkk;
+ zdscal_(&i__2, &d__1, &a[k + 1 + k * a_dim1], &c__1);
+ d__1 = akk * -.5;
+ ct.r = d__1, ct.i = 0.;
+ i__2 = *n - k;
+ zaxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
+ 1 + k * a_dim1], &c__1);
+ i__2 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zher2_(uplo, &i__2, &z__1, &a[k + 1 + k * a_dim1], &c__1,
+ &b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + (k + 1)
+ * a_dim1], lda);
+ i__2 = *n - k;
+ zaxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
+ 1 + k * a_dim1], &c__1);
+ i__2 = *n - k;
+ ztrsv_(uplo, "No transpose", "Non-unit", &i__2, &b[k + 1
+ + (k + 1) * b_dim1], ldb, &a[k + 1 + k * a_dim1],
+ &c__1);
+ }
+/* L20: */
+ }
+ }
+ } else {
+ if (upper) {
+
+/* Compute U*A*U' */
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+/* Update the upper triangle of A(1:k,1:k) */
+
+ i__2 = k + k * a_dim1;
+ akk = a[i__2].r;
+ i__2 = k + k * b_dim1;
+ bkk = b[i__2].r;
+ i__2 = k - 1;
+ ztrmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset],
+ ldb, &a[k * a_dim1 + 1], &c__1);
+ d__1 = akk * .5;
+ ct.r = d__1, ct.i = 0.;
+ i__2 = k - 1;
+ zaxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
+ 1], &c__1);
+ i__2 = k - 1;
+ zher2_(uplo, &i__2, &c_b1, &a[k * a_dim1 + 1], &c__1, &b[k *
+ b_dim1 + 1], &c__1, &a[a_offset], lda);
+ i__2 = k - 1;
+ zaxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
+ 1], &c__1);
+ i__2 = k - 1;
+ zdscal_(&i__2, &bkk, &a[k * a_dim1 + 1], &c__1);
+ i__2 = k + k * a_dim1;
+/* Computing 2nd power */
+ d__2 = bkk;
+ d__1 = akk * (d__2 * d__2);
+ a[i__2].r = d__1, a[i__2].i = 0.;
+/* L30: */
+ }
+ } else {
+
+/* Compute L'*A*L */
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+/* Update the lower triangle of A(1:k,1:k) */
+
+ i__2 = k + k * a_dim1;
+ akk = a[i__2].r;
+ i__2 = k + k * b_dim1;
+ bkk = b[i__2].r;
+ i__2 = k - 1;
+ zlacgv_(&i__2, &a[k + a_dim1], lda);
+ i__2 = k - 1;
+ ztrmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &b[
+ b_offset], ldb, &a[k + a_dim1], lda);
+ d__1 = akk * .5;
+ ct.r = d__1, ct.i = 0.;
+ i__2 = k - 1;
+ zlacgv_(&i__2, &b[k + b_dim1], ldb);
+ i__2 = k - 1;
+ zaxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
+ i__2 = k - 1;
+ zher2_(uplo, &i__2, &c_b1, &a[k + a_dim1], lda, &b[k + b_dim1]
+, ldb, &a[a_offset], lda);
+ i__2 = k - 1;
+ zaxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
+ i__2 = k - 1;
+ zlacgv_(&i__2, &b[k + b_dim1], ldb);
+ i__2 = k - 1;
+ zdscal_(&i__2, &bkk, &a[k + a_dim1], lda);
+ i__2 = k - 1;
+ zlacgv_(&i__2, &a[k + a_dim1], lda);
+ i__2 = k + k * a_dim1;
+/* Computing 2nd power */
+ d__2 = bkk;
+ d__1 = akk * (d__2 * d__2);
+ a[i__2].r = d__1, a[i__2].i = 0.;
+/* L40: */
+ }
+ }
+ }
+ return 0;
+
+/* End of ZHEGS2 */
+
+} /* zhegs2_ */
diff --git a/SRC/zhegst.c b/SRC/zhegst.c
new file mode 100644
index 0000000..12d9fa3
--- /dev/null
+++ b/SRC/zhegst.c
@@ -0,0 +1,353 @@
+/* zhegst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static doublecomplex c_b2 = {.5,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b18 = 1.;
+
+/* Subroutine */ int zhegst_(integer *itype, char *uplo, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer k, kb, nb;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zhemm_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int ztrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ ztrsm_(char *, char *, char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zhegs2_(integer *,
+ char *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *), zher2k_(char *, char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHEGST reduces a complex Hermitian-definite generalized */
+/* eigenproblem to standard form. */
+
+/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
+/* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H) */
+
+/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
+/* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L. */
+
+/* B must have been previously factorized as U**H*U or L*L**H by ZPOTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H); */
+/* = 2 or 3: compute U*A*U**H or L**H*A*L. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored and B is factored as */
+/* U**H*U; */
+/* = 'L': Lower triangle of A is stored and B is factored as */
+/* L*L**H. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) 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, the transformed matrix, stored in the */
+/* same format as A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,N) */
+/* The triangular factor from the Cholesky factorization of B, */
+/* as returned by ZPOTRF. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHEGST", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "ZHEGST", uplo, n, &c_n1, &c_n1, &c_n1);
+
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code */
+
+ zhegs2_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
+ } else {
+
+/* Use blocked code */
+
+ if (*itype == 1) {
+ if (upper) {
+
+/* Compute inv(U')*A*inv(U) */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+/* Computing MIN */
+ i__3 = *n - k + 1;
+ kb = min(i__3,nb);
+
+/* Update the upper triangle of A(k:n,k:n) */
+
+ zhegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
+ k * b_dim1], ldb, info);
+ if (k + kb <= *n) {
+ i__3 = *n - k - kb + 1;
+ ztrsm_("Left", uplo, "Conjugate transpose", "Non-unit"
+, &kb, &i__3, &c_b1, &b[k + k * b_dim1], ldb,
+ &a[k + (k + kb) * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ z__1.r = -.5, z__1.i = -0.;
+ zhemm_("Left", uplo, &kb, &i__3, &z__1, &a[k + k *
+ a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb,
+ &c_b1, &a[k + (k + kb) * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ z__1.r = -1., z__1.i = -0.;
+ zher2k_(uplo, "Conjugate transpose", &i__3, &kb, &
+ z__1, &a[k + (k + kb) * a_dim1], lda, &b[k + (
+ k + kb) * b_dim1], ldb, &c_b18, &a[k + kb + (
+ k + kb) * a_dim1], lda)
+ ;
+ i__3 = *n - k - kb + 1;
+ z__1.r = -.5, z__1.i = -0.;
+ zhemm_("Left", uplo, &kb, &i__3, &z__1, &a[k + k *
+ a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb,
+ &c_b1, &a[k + (k + kb) * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ ztrsm_("Right", uplo, "No transpose", "Non-unit", &kb,
+ &i__3, &c_b1, &b[k + kb + (k + kb) * b_dim1],
+ ldb, &a[k + (k + kb) * a_dim1], lda);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Compute inv(L)*A*inv(L') */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+/* Computing MIN */
+ i__3 = *n - k + 1;
+ kb = min(i__3,nb);
+
+/* Update the lower triangle of A(k:n,k:n) */
+
+ zhegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
+ k * b_dim1], ldb, info);
+ if (k + kb <= *n) {
+ i__3 = *n - k - kb + 1;
+ ztrsm_("Right", uplo, "Conjugate transpose", "Non-un"
+ "it", &i__3, &kb, &c_b1, &b[k + k * b_dim1],
+ ldb, &a[k + kb + k * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ z__1.r = -.5, z__1.i = -0.;
+ zhemm_("Right", uplo, &i__3, &kb, &z__1, &a[k + k *
+ a_dim1], lda, &b[k + kb + k * b_dim1], ldb, &
+ c_b1, &a[k + kb + k * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ z__1.r = -1., z__1.i = -0.;
+ zher2k_(uplo, "No transpose", &i__3, &kb, &z__1, &a[k
+ + kb + k * a_dim1], lda, &b[k + kb + k *
+ b_dim1], ldb, &c_b18, &a[k + kb + (k + kb) *
+ a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ z__1.r = -.5, z__1.i = -0.;
+ zhemm_("Right", uplo, &i__3, &kb, &z__1, &a[k + k *
+ a_dim1], lda, &b[k + kb + k * b_dim1], ldb, &
+ c_b1, &a[k + kb + k * a_dim1], lda);
+ i__3 = *n - k - kb + 1;
+ ztrsm_("Left", uplo, "No transpose", "Non-unit", &
+ i__3, &kb, &c_b1, &b[k + kb + (k + kb) *
+ b_dim1], ldb, &a[k + kb + k * a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+ } else {
+ if (upper) {
+
+/* Compute U*A*U' */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+/* Computing MIN */
+ i__3 = *n - k + 1;
+ kb = min(i__3,nb);
+
+/* Update the upper triangle of A(1:k+kb-1,1:k+kb-1) */
+
+ i__3 = k - 1;
+ ztrmm_("Left", uplo, "No transpose", "Non-unit", &i__3, &
+ kb, &c_b1, &b[b_offset], ldb, &a[k * a_dim1 + 1],
+ lda);
+ i__3 = k - 1;
+ zhemm_("Right", uplo, &i__3, &kb, &c_b2, &a[k + k *
+ a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b1, &a[
+ k * a_dim1 + 1], lda);
+ i__3 = k - 1;
+ zher2k_(uplo, "No transpose", &i__3, &kb, &c_b1, &a[k *
+ a_dim1 + 1], lda, &b[k * b_dim1 + 1], ldb, &c_b18,
+ &a[a_offset], lda);
+ i__3 = k - 1;
+ zhemm_("Right", uplo, &i__3, &kb, &c_b2, &a[k + k *
+ a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b1, &a[
+ k * a_dim1 + 1], lda);
+ i__3 = k - 1;
+ ztrmm_("Right", uplo, "Conjugate transpose", "Non-unit", &
+ i__3, &kb, &c_b1, &b[k + k * b_dim1], ldb, &a[k *
+ a_dim1 + 1], lda);
+ zhegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
+ k * b_dim1], ldb, info);
+/* L30: */
+ }
+ } else {
+
+/* Compute L'*A*L */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+/* Computing MIN */
+ i__3 = *n - k + 1;
+ kb = min(i__3,nb);
+
+/* Update the lower triangle of A(1:k+kb-1,1:k+kb-1) */
+
+ i__3 = k - 1;
+ ztrmm_("Right", uplo, "No transpose", "Non-unit", &kb, &
+ i__3, &c_b1, &b[b_offset], ldb, &a[k + a_dim1],
+ lda);
+ i__3 = k - 1;
+ zhemm_("Left", uplo, &kb, &i__3, &c_b2, &a[k + k * a_dim1]
+, lda, &b[k + b_dim1], ldb, &c_b1, &a[k + a_dim1],
+ lda);
+ i__3 = k - 1;
+ zher2k_(uplo, "Conjugate transpose", &i__3, &kb, &c_b1, &
+ a[k + a_dim1], lda, &b[k + b_dim1], ldb, &c_b18, &
+ a[a_offset], lda);
+ i__3 = k - 1;
+ zhemm_("Left", uplo, &kb, &i__3, &c_b2, &a[k + k * a_dim1]
+, lda, &b[k + b_dim1], ldb, &c_b1, &a[k + a_dim1],
+ lda);
+ i__3 = k - 1;
+ ztrmm_("Left", uplo, "Conjugate transpose", "Non-unit", &
+ kb, &i__3, &c_b1, &b[k + k * b_dim1], ldb, &a[k +
+ a_dim1], lda);
+ zhegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k +
+ k * b_dim1], ldb, info);
+/* L40: */
+ }
+ }
+ }
+ }
+ return 0;
+
+/* End of ZHEGST */
+
+} /* zhegst_ */
diff --git a/SRC/zhegv.c b/SRC/zhegv.c
new file mode 100644
index 0000000..71eb842
--- /dev/null
+++ b/SRC/zhegv.c
@@ -0,0 +1,289 @@
+/* zhegv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zhegv_(integer *itype, char *jobz, char *uplo, integer *
+ n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublereal *w, doublecomplex *work, integer *lwork, doublereal *rwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+
+ /* Local variables */
+ integer nb, neig;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zheev_(char *, char *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ integer *, doublereal *, integer *);
+ char trans[1];
+ logical upper, wantz;
+ extern /* Subroutine */ int ztrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ ztrsm_(char *, char *, char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *), xerbla_(char *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zhegst_(integer *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int zpotrf_(char *, integer *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHEGV computes all the eigenvalues, and optionally, the eigenvectors */
+/* of a complex generalized Hermitian-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. */
+/* Here A and B are assumed to be Hermitian and B is also */
+/* positive definite. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) 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. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+
+/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
+/* matrix Z of eigenvectors. The eigenvectors are normalized */
+/* as follows: */
+/* if ITYPE = 1 or 2, Z**H*B*Z = I; */
+/* if ITYPE = 3, Z**H*inv(B)*Z = I. */
+/* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') */
+/* or the lower triangle (if UPLO='L') of A, including the */
+/* diagonal, is destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB, N) */
+/* On entry, the Hermitian positive definite matrix B. */
+/* If UPLO = 'U', the leading N-by-N upper triangular part of B */
+/* contains the upper triangular part of the matrix B. */
+/* If UPLO = 'L', the leading N-by-N lower triangular part of B */
+/* contains the lower triangular part of the matrix B. */
+
+/* On exit, if INFO <= N, the part of B containing the matrix is */
+/* overwritten by the triangular factor U or L from the Cholesky */
+/* factorization B = U**H*U or B = L*L**H. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(1,2*N-1). */
+/* For optimal efficiency, LWORK >= (NB+1)*N, */
+/* where NB is the blocksize for ZHETRD 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. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: ZPOTRF or ZHEEV returned an error code: */
+/* <= N: if INFO = i, ZHEEV failed to converge; */
+/* i off-diagonal elements of an intermediate */
+/* tridiagonal form did not converge to zero; */
+/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --w;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1;
+
+ *info = 0;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+
+ if (*info == 0) {
+ nb = ilaenv_(&c__1, "ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = 1, i__2 = (nb + 1) * *n;
+ lwkopt = max(i__1,i__2);
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+/* Computing MAX */
+ i__1 = 1, i__2 = (*n << 1) - 1;
+ if (*lwork < max(i__1,i__2) && ! lquery) {
+ *info = -11;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHEGV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of B. */
+
+ zpotrf_(uplo, n, &b[b_offset], ldb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ zhegst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
+ zheev_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &rwork[1]
+, info);
+
+ if (wantz) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ neig = *n;
+ if (*info > 0) {
+ neig = *info - 1;
+ }
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'C';
+ }
+
+ ztrsm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &b[
+ b_offset], ldb, &a[a_offset], lda);
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'C';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ ztrmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &b[
+ b_offset], ldb, &a[a_offset], lda);
+ }
+ }
+
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZHEGV */
+
+} /* zhegv_ */
diff --git a/SRC/zhegvd.c b/SRC/zhegvd.c
new file mode 100644
index 0000000..6556caf
--- /dev/null
+++ b/SRC/zhegvd.c
@@ -0,0 +1,367 @@
+/* zhegvd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+
+/* Subroutine */ int zhegvd_(integer *itype, char *jobz, char *uplo, integer *
+ n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublereal *w, doublecomplex *work, integer *lwork, doublereal *rwork,
+ integer *lrwork, integer *iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer lopt;
+ extern logical lsame_(char *, char *);
+ integer lwmin;
+ char trans[1];
+ integer liopt;
+ logical upper;
+ integer lropt;
+ logical wantz;
+ extern /* Subroutine */ int ztrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ ztrsm_(char *, char *, char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *), xerbla_(char *,
+ integer *), zheevd_(char *, char *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ integer *, doublereal *, integer *, integer *, integer *, integer
+ *);
+ integer liwmin;
+ extern /* Subroutine */ int zhegst_(integer *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+ integer lrwmin;
+ logical lquery;
+ extern /* Subroutine */ int zpotrf_(char *, integer *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHEGVD computes all the eigenvalues, and optionally, the eigenvectors */
+/* of a complex generalized Hermitian-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */
+/* B are assumed to be Hermitian and B is also positive definite. */
+/* If eigenvectors are desired, it uses a divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) 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. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+
+/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
+/* matrix Z of eigenvectors. The eigenvectors are normalized */
+/* as follows: */
+/* if ITYPE = 1 or 2, Z**H*B*Z = I; */
+/* if ITYPE = 3, Z**H*inv(B)*Z = I. */
+/* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') */
+/* or the lower triangle (if UPLO='L') of A, including the */
+/* diagonal, is destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB, N) */
+/* On entry, the Hermitian matrix B. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of B contains the */
+/* upper triangular part of the matrix B. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of B contains */
+/* the lower triangular part of the matrix B. */
+
+/* On exit, if INFO <= N, the part of B containing the matrix is */
+/* overwritten by the triangular factor U or L from the Cholesky */
+/* factorization B = U**H*U or B = L*L**H. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. */
+/* If N <= 1, LWORK >= 1. */
+/* If JOBZ = 'N' and N > 1, LWORK >= N + 1. */
+/* If JOBZ = 'V' and N > 1, LWORK >= 2*N + N**2. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK, RWORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* RWORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LRWORK)) */
+/* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. */
+
+/* LRWORK (input) INTEGER */
+/* The dimension of the array RWORK. */
+/* If N <= 1, LRWORK >= 1. */
+/* If JOBZ = 'N' and N > 1, LRWORK >= N. */
+/* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2. */
+
+/* If LRWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If N <= 1, LIWORK >= 1. */
+/* If JOBZ = 'N' and N > 1, LIWORK >= 1. */
+/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: ZPOTRF or ZHEEVD returned an error code: */
+/* <= N: if INFO = i and JOBZ = 'N', then the algorithm */
+/* failed to converge; i off-diagonal elements of an */
+/* intermediate tridiagonal form did not converge to */
+/* zero; */
+/* if INFO = i and JOBZ = 'V', then the algorithm */
+/* failed to compute an eigenvalue while working on */
+/* the submatrix lying in rows and columns INFO/(N+1) */
+/* through mod(INFO,N+1); */
+/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* Modified so that no backsubstitution is performed if ZHEEVD fails to */
+/* converge (NEIG in old code could be greater than N causing out of */
+/* bounds reference to A - reported by Ralf Meyer). Also corrected the */
+/* description of INFO and the test on ITYPE. Sven, 16 Feb 05. */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --w;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
+
+ *info = 0;
+ if (*n <= 1) {
+ lwmin = 1;
+ lrwmin = 1;
+ liwmin = 1;
+ } else if (wantz) {
+ lwmin = (*n << 1) + *n * *n;
+ lrwmin = *n * 5 + 1 + (*n << 1) * *n;
+ liwmin = *n * 5 + 3;
+ } else {
+ lwmin = *n + 1;
+ lrwmin = *n;
+ liwmin = 1;
+ }
+ lopt = lwmin;
+ lropt = lrwmin;
+ liopt = liwmin;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+
+ if (*info == 0) {
+ work[1].r = (doublereal) lopt, work[1].i = 0.;
+ rwork[1] = (doublereal) lropt;
+ iwork[1] = liopt;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -11;
+ } else if (*lrwork < lrwmin && ! lquery) {
+ *info = -13;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -15;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHEGVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of B. */
+
+ zpotrf_(uplo, n, &b[b_offset], ldb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ zhegst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
+ zheevd_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &rwork[
+ 1], lrwork, &iwork[1], liwork, info);
+/* Computing MAX */
+ d__1 = (doublereal) lopt, d__2 = work[1].r;
+ lopt = (integer) max(d__1,d__2);
+/* Computing MAX */
+ d__1 = (doublereal) lropt;
+ lropt = (integer) max(d__1,rwork[1]);
+/* Computing MAX */
+ d__1 = (doublereal) liopt, d__2 = (doublereal) iwork[1];
+ liopt = (integer) max(d__1,d__2);
+
+ if (wantz && *info == 0) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'C';
+ }
+
+ ztrsm_("Left", uplo, trans, "Non-unit", n, n, &c_b1, &b[b_offset],
+ ldb, &a[a_offset], lda);
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'C';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ ztrmm_("Left", uplo, trans, "Non-unit", n, n, &c_b1, &b[b_offset],
+ ldb, &a[a_offset], lda);
+ }
+ }
+
+ work[1].r = (doublereal) lopt, work[1].i = 0.;
+ rwork[1] = (doublereal) lropt;
+ iwork[1] = liopt;
+
+ return 0;
+
+/* End of ZHEGVD */
+
+} /* zhegvd_ */
diff --git a/SRC/zhegvx.c b/SRC/zhegvx.c
new file mode 100644
index 0000000..889981c
--- /dev/null
+++ b/SRC/zhegvx.c
@@ -0,0 +1,397 @@
+/* zhegvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zhegvx_(integer *itype, char *jobz, char *range, char *
+ uplo, integer *n, doublecomplex *a, integer *lda, doublecomplex *b,
+ integer *ldb, doublereal *vl, doublereal *vu, integer *il, integer *
+ iu, doublereal *abstol, integer *m, doublereal *w, doublecomplex *z__,
+ integer *ldz, doublecomplex *work, integer *lwork, doublereal *rwork,
+ integer *iwork, integer *ifail, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1, i__2;
+
+ /* Local variables */
+ integer nb;
+ extern logical lsame_(char *, char *);
+ char trans[1];
+ logical upper, wantz;
+ extern /* Subroutine */ int ztrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ ztrsm_(char *, char *, char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *);
+ logical alleig, indeig, valeig;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zhegst_(integer *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *), zheevx_(char *, char *, char *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublecomplex *
+, integer *, doublecomplex *, integer *, doublereal *, integer *,
+ integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int zpotrf_(char *, integer *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHEGVX computes selected eigenvalues, and optionally, eigenvectors */
+/* of a complex generalized Hermitian-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */
+/* B are assumed to be Hermitian and B is also positive definite. */
+/* Eigenvalues and eigenvectors can be selected by specifying either a */
+/* range of values or a range of indices for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+/* * */
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) 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. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of A contains */
+/* the lower triangular part of the matrix A. */
+
+/* On exit, the lower triangle (if UPLO='L') or the upper */
+/* triangle (if UPLO='U') of A, including the diagonal, is */
+/* destroyed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB, N) */
+/* On entry, the Hermitian matrix B. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of B contains the */
+/* upper triangular part of the matrix B. If UPLO = 'L', */
+/* the leading N-by-N lower triangular part of B contains */
+/* the lower triangular part of the matrix B. */
+
+/* On exit, if INFO <= N, the part of B containing the matrix is */
+/* overwritten by the triangular factor U or L from the Cholesky */
+/* factorization B = U**H*U or B = L*L**H. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) DOUBLE PRECISION */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing A to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*DLAMCH('S'). */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* The first M elements contain the selected */
+/* eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M)) */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* The eigenvectors are normalized as follows: */
+/* if ITYPE = 1 or 2, Z**T*B*Z = I; */
+/* if ITYPE = 3, Z**T*inv(B)*Z = I. */
+
+/* If an eigenvector fails to converge, then that column of Z */
+/* contains the latest approximation to the eigenvector, and the */
+/* index of the eigenvector is returned in IFAIL. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(1,2*N). */
+/* For optimal efficiency, LWORK >= (NB+1)*N, */
+/* where NB is the blocksize for ZHETRD 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. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: ZPOTRF or ZHEEVX returned an error code: */
+/* <= N: if INFO = i, ZHEEVX failed to converge; */
+/* i eigenvectors failed to converge. Their indices */
+/* are stored in array IFAIL. */
+/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+ lquery = *lwork == -1;
+
+ *info = 0;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -3;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -11;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -12;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -13;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -18;
+ }
+ }
+
+ if (*info == 0) {
+ nb = ilaenv_(&c__1, "ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = 1, i__2 = (nb + 1) * *n;
+ lwkopt = max(i__1,i__2);
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *n << 1;
+ if (*lwork < max(i__1,i__2) && ! lquery) {
+ *info = -20;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHEGVX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of B. */
+
+ zpotrf_(uplo, n, &b[b_offset], ldb, info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ zhegst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
+ zheevx_(jobz, range, uplo, n, &a[a_offset], lda, vl, vu, il, iu, abstol,
+ m, &w[1], &z__[z_offset], ldz, &work[1], lwork, &rwork[1], &iwork[
+ 1], &ifail[1], info);
+
+ if (wantz) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ if (*info > 0) {
+ *m = *info - 1;
+ }
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'C';
+ }
+
+ ztrsm_("Left", uplo, trans, "Non-unit", n, m, &c_b1, &b[b_offset],
+ ldb, &z__[z_offset], ldz);
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'C';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ ztrmm_("Left", uplo, trans, "Non-unit", n, m, &c_b1, &b[b_offset],
+ ldb, &z__[z_offset], ldz);
+ }
+ }
+
+/* Set WORK(1) to optimal complex workspace size. */
+
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZHEGVX */
+
+} /* zhegvx_ */
diff --git a/SRC/zherfs.c b/SRC/zherfs.c
new file mode 100644
index 0000000..b92d421
--- /dev/null
+++ b/SRC/zherfs.c
@@ -0,0 +1,473 @@
+/* zherfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zherfs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf,
+ integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x,
+ integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work,
+ doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal s, xk;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3], count;
+ extern /* Subroutine */ int zhemv_(char *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), zlacn2_(
+ integer *, doublecomplex *, doublecomplex *, doublereal *,
+ integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal lstres;
+ extern /* Subroutine */ int zhetrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHERFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is Hermitian indefinite, and */
+/* provides error bounds and backward error estimates for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The 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. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The factored form of the matrix A. AF contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor U or L from the factorization A = U*D*U**H or */
+/* A = L*D*L**H as computed by ZHETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by ZHETRF. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by ZHETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldx < max(1,*n)) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHERFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ z__1.r = -1., z__1.i = -0.;
+ zhemv_(uplo, n, &z__1, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, &
+ c_b1, &work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
+ i__ + j * b_dim1]), abs(d__2));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
+ x_dim1]), abs(d__2));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ rwork[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + k * a_dim1]), abs(d__2))) * xk;
+ i__4 = i__ + k * a_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + k * a_dim1]), abs(d__2))) * ((d__3 = x[i__5]
+ .r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j *
+ x_dim1]), abs(d__4)));
+/* L40: */
+ }
+ i__3 = k + k * a_dim1;
+ rwork[k] = rwork[k] + (d__1 = a[i__3].r, abs(d__1)) * xk + s;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
+ x_dim1]), abs(d__2));
+ i__3 = k + k * a_dim1;
+ rwork[k] += (d__1 = a[i__3].r, abs(d__1)) * xk;
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ rwork[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + k * a_dim1]), abs(d__2))) * xk;
+ i__4 = i__ + k * a_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + k * a_dim1]), abs(d__2))) * ((d__3 = x[i__5]
+ .r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j *
+ x_dim1]), abs(d__4)));
+/* L60: */
+ }
+ rwork[k] += s;
+/* L70: */
+ }
+ }
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__3 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2))) / rwork[i__];
+ s = max(d__3,d__4);
+ } else {
+/* Computing MAX */
+ i__3 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = max(d__3,d__4);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ zhetrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[1],
+ n, info);
+ zaxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use ZLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__3 = i__;
+ rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ ;
+ } else {
+ i__3 = i__;
+ rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ zhetrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L120: */
+ }
+ zhetrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * x_dim1;
+ d__3 = lstres, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&x[i__ + j * x_dim1]), abs(d__2));
+ lstres = max(d__3,d__4);
+/* L130: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of ZHERFS */
+
+} /* zherfs_ */
diff --git a/SRC/zherfsx.c b/SRC/zherfsx.c
new file mode 100644
index 0000000..2b9e6b5
--- /dev/null
+++ b/SRC/zherfsx.c
@@ -0,0 +1,630 @@
+/* zherfsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int zherfsx_(char *uplo, char *equed, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, integer *ipiv, doublereal *s, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *berr,
+ integer *n_err_bnds__, doublereal *err_bnds_norm__, doublereal *
+ err_bnds_comp__, integer *nparams, doublereal *params, doublecomplex *
+ work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal illrcond_thresh__, unstable_thresh__, err_lbnd__;
+ integer ref_type__;
+ integer j;
+ doublereal rcond_tmp__;
+ integer prec_type__;
+ doublereal cwise_wrong__;
+ extern /* Subroutine */ int zla_herfsx_extended__(integer *, char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *, logical *, doublereal *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ doublecomplex *, doublecomplex *, doublereal *, integer *,
+ doublereal *, doublereal *, logical *, integer *, ftnlen);
+ char norm[1];
+ logical ignore_cwise__;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ logical rcequ;
+ extern doublereal zla_hercond_c__(char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, doublereal *,
+ logical *, integer *, doublecomplex *, doublereal *, ftnlen),
+ zla_hercond_x__(char *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublereal *, ftnlen), dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zhecon_(char *, integer *, doublecomplex *,
+ integer *, integer *, doublereal *, doublereal *, doublecomplex *,
+ integer *);
+ extern integer ilaprec_(char *);
+ integer ithresh, n_norms__;
+ doublereal rthresh;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHERFSX improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is Hermitian indefinite, and */
+/* provides error bounds and backward error estimates for the */
+/* solution. In addition to normwise error bound, the code provides */
+/* maximum componentwise error bound if possible. See comments for */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds. */
+
+/* The original system of linear equations may have been equilibrated */
+/* before calling this routine, as described by arguments EQUED and S */
+/* below. In this case, the solution and error bounds returned are */
+/* for the original unequilibrated system. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* EQUED (input) CHARACTER*1 */
+/* Specifies the form of equilibration that was done to A */
+/* before calling this routine. This is needed to compute */
+/* the solution and error bounds correctly. */
+/* = 'N': No equilibration */
+/* = 'Y': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(S) * A * diag(S). */
+/* The right hand side B has been changed accordingly. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular */
+/* part of the matrix A, and the strictly lower triangular */
+/* part of A is not referenced. If UPLO = 'L', the leading */
+/* N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The factored form of the matrix A. AF contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor U or L from the factorization A = U*D*U**T or A = */
+/* L*D*L**T as computed by DSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by DSYTRF. */
+
+/* S (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The scale factors for A. If EQUED = 'Y', A is multiplied on */
+/* the left and right by diag(S). S is an input argument if FACT = */
+/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
+/* = 'Y', each element of S must be positive. If S is output, each */
+/* element of S is a power of the radix. If S is input, each element */
+/* of S should be a power of the radix to ensure a reliable solution */
+/* and error estimates. Scaling by powers of the radix does not cause */
+/* rounding errors unless the result underflows or overflows. */
+/* Rounding errors during scaling lead to refining with a matrix that */
+/* is not equivalent to the input matrix, producing error estimates */
+/* that may not be reliable. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by DGETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0D+0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check the input parameters. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ ref_type__ = 1;
+ if (*nparams >= 1) {
+ if (params[1] < 0.) {
+ params[1] = 1.;
+ } else {
+ ref_type__ = (integer) params[1];
+ }
+ }
+
+/* Set default parameters. */
+
+ illrcond_thresh__ = (doublereal) (*n) * dlamch_("Epsilon");
+ ithresh = 10;
+ rthresh = .5;
+ unstable_thresh__ = .25;
+ ignore_cwise__ = FALSE_;
+
+ if (*nparams >= 2) {
+ if (params[2] < 0.) {
+ params[2] = (doublereal) ithresh;
+ } else {
+ ithresh = (integer) params[2];
+ }
+ }
+ if (*nparams >= 3) {
+ if (params[3] < 0.) {
+ if (ignore_cwise__) {
+ params[3] = 0.;
+ } else {
+ params[3] = 1.;
+ }
+ } else {
+ ignore_cwise__ = params[3] == 0.;
+ }
+ }
+ if (ref_type__ == 0 || *n_err_bnds__ == 0) {
+ n_norms__ = 0;
+ } else if (ignore_cwise__) {
+ n_norms__ = 1;
+ } else {
+ n_norms__ = 2;
+ }
+
+ rcequ = lsame_(equed, "Y");
+
+/* Test input parameters. */
+
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! rcequ && ! lsame_(equed, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -11;
+ } else if (*ldx < max(1,*n)) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHERFSX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *nrhs == 0) {
+ *rcond = 1.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 0.;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.;
+ }
+ }
+ return 0;
+ }
+
+/* Default to failure. */
+
+ *rcond = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 1.;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.;
+ }
+ }
+
+/* Compute the norm of A and the reciprocal of the condition */
+/* number of A. */
+
+ *(unsigned char *)norm = 'I';
+ anorm = zlanhe_(norm, uplo, n, &a[a_offset], lda, &rwork[1]);
+ zhecon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1],
+ info);
+
+/* Perform refinement on each right-hand side */
+
+ if (ref_type__ != 0) {
+ prec_type__ = ilaprec_("E");
+ zla_herfsx_extended__(&prec_type__, uplo, n, nrhs, &a[a_offset], lda,
+ &af[af_offset], ldaf, &ipiv[1], &rcequ, &s[1], &b[b_offset],
+ ldb, &x[x_offset], ldx, &berr[1], &n_norms__, &
+ err_bnds_norm__[err_bnds_norm_offset], &err_bnds_comp__[
+ err_bnds_comp_offset], &work[1], &rwork[1], &work[*n + 1],
+ (doublecomplex *)(&rwork[1]), rcond, &ithresh, &rthresh, &unstable_thresh__, &
+ ignore_cwise__, info, (ftnlen)1);
+ }
+/* Computing MAX */
+ d__1 = 10., d__2 = sqrt((doublereal) (*n));
+ err_lbnd__ = max(d__1,d__2) * dlamch_("Epsilon");
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {
+
+/* Compute scaled normwise condition number cond(A*C). */
+
+ if (rcequ) {
+ rcond_tmp__ = zla_hercond_c__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &s[1], &c_true, info, &work[1]
+ , &rwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = zla_hercond_c__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &s[1], &c_false, info, &work[
+ 1], &rwork[1], (ftnlen)1);
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1
+ << 1)] > 1.) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 0.;
+ if (*info <= *n) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {
+
+/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
+/* each right-hand side using the current solution as an estimate of */
+/* the true solution. If the componentwise error estimate is too */
+/* large, then the solution is a lousy estimate of truth and the */
+/* estimated RCOND may be too optimistic. To avoid misleading users, */
+/* the inverse condition number is set to 0.0 when the estimated */
+/* cwise error is at least CWISE_WRONG. */
+
+ cwise_wrong__ = sqrt(dlamch_("Epsilon"));
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ cwise_wrong__) {
+ rcond_tmp__ = zla_hercond_x__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &x[j * x_dim1 + 1], info,
+ &work[1], &rwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = 0.;
+ }
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1
+ << 1)] > 1.) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 0.;
+ if (params[3] == 1. && *info < *n + j) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZHERFSX */
+
+} /* zherfsx_ */
diff --git a/SRC/zhesv.c b/SRC/zhesv.c
new file mode 100644
index 0000000..76d08b7
--- /dev/null
+++ b/SRC/zhesv.c
@@ -0,0 +1,213 @@
+/* zhesv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zhesv_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b,
+ integer *ldb, doublecomplex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ integer nb;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zhetrf_(char *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *, integer *), zhetrs_(char *, integer *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHESV 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 diagonal pivoting method is used to factor A as */
+/* A = U * D * U**H, if UPLO = 'U', or */
+/* A = L * D * L**H, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is Hermitian and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then */
+/* used to solve the system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input/output) 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, the block diagonal matrix D and the */
+/* multipliers used to obtain the factor U or L from the */
+/* factorization A = U*D*U**H or A = L*D*L**H as computed by */
+/* ZHETRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D, as */
+/* determined by ZHETRF. If IPIV(k) > 0, then rows and columns */
+/* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 */
+/* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, */
+/* then rows and columns k-1 and -IPIV(k) were interchanged and */
+/* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and */
+/* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and */
+/* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 */
+/* diagonal block. */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK >= 1, and for best performance */
+/* LWORK >= max(1,N*NB), where NB is the optimal blocksize for */
+/* ZHETRF. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */
+/* has been completed, but the block diagonal matrix D is */
+/* exactly singular, so the solution could not be computed. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*lwork < 1 && ! lquery) {
+ *info = -10;
+ }
+
+ if (*info == 0) {
+ if (*n == 0) {
+ lwkopt = 1;
+ } else {
+ nb = ilaenv_(&c__1, "ZHETRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHESV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ zhetrf_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], lwork, info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ zhetrs_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], ldb,
+ info);
+
+ }
+
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZHESV */
+
+} /* zhesv_ */
diff --git a/SRC/zhesvx.c b/SRC/zhesvx.c
new file mode 100644
index 0000000..71c8492
--- /dev/null
+++ b/SRC/zhesvx.c
@@ -0,0 +1,368 @@
+/* zhesvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zhesvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x,
+ integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr,
+ doublecomplex *work, integer *lwork, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2;
+
+ /* Local variables */
+ integer nb;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern doublereal dlamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zhecon_(char *, integer *, doublecomplex *,
+ integer *, integer *, doublereal *, doublereal *, doublecomplex *,
+ integer *), zherfs_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zhetrf_(char *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), zhetrs_(char *,
+ integer *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHESVX uses the diagonal pivoting factorization to compute the */
+/* solution to a complex system of linear equations A * X = B, */
+/* where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS */
+/* matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'N', the diagonal pivoting method is used to factor A. */
+/* The form of the factorization is */
+/* A = U * D * U**H, if UPLO = 'U', or */
+/* A = L * D * L**H, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is Hermitian and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* 2. If some D(i,i)=0, so that D is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 3. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 4. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of A has been */
+/* supplied on entry. */
+/* = 'F': On entry, AF and IPIV contain the factored form */
+/* of A. A, AF and IPIV will not be modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* 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. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) COMPLEX*16 array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**H or A = L*D*L**H as computed by ZHETRF. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**H or A = L*D*L**H. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by ZHETRF. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by ZHETRF. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A. If RCOND is less than the machine precision (in */
+/* particular, if RCOND = 0), the matrix is singular to working */
+/* precision. This condition is indicated by a return code of */
+/* INFO > 0. */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK >= max(1,2*N), and for best */
+/* performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where */
+/* NB is the optimal blocksize for ZHETRF. */
+
+/* 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. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: D(i,i) is exactly zero. The factorization */
+/* has been completed but the factor D is exactly */
+/* singular, so the solution and error bounds could */
+/* not be computed. RCOND = 0 is returned. */
+/* = N+1: D is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ lquery = *lwork == -1;
+ if (! nofact && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -11;
+ } else if (*ldx < max(1,*n)) {
+ *info = -13;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n << 1;
+ if (*lwork < max(i__1,i__2) && ! lquery) {
+ *info = -18;
+ }
+ }
+
+ if (*info == 0) {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n << 1;
+ lwkopt = max(i__1,i__2);
+ if (nofact) {
+ nb = ilaenv_(&c__1, "ZHETRF", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = *n * nb;
+ lwkopt = max(i__1,i__2);
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHESVX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+ if (nofact) {
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ zlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ zhetrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], lwork,
+ info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = zlanhe_("I", uplo, n, &a[a_offset], lda, &rwork[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ zhecon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1],
+ info);
+
+/* Compute the solution vectors X. */
+
+ zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ zhetrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solutions and */
+/* compute error bounds and backward error estimates for them. */
+
+ zherfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1],
+ &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1]
+, &rwork[1], info);
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < dlamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZHESVX */
+
+} /* zhesvx_ */
diff --git a/SRC/zhesvxx.c b/SRC/zhesvxx.c
new file mode 100644
index 0000000..3c10266
--- /dev/null
+++ b/SRC/zhesvxx.c
@@ -0,0 +1,630 @@
+/* zhesvxx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zhesvxx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, integer *ipiv, char *equed, doublereal *s, doublecomplex *b,
+ integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond,
+ doublereal *rpvgrw, doublereal *berr, integer *n_err_bnds__,
+ doublereal *err_bnds_norm__, doublereal *err_bnds_comp__, integer *
+ nparams, doublereal *params, doublecomplex *work, doublereal *rwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ doublereal amax, smin, smax;
+ extern doublereal zla_herpvgrw__(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ doublereal *, ftnlen);
+ extern logical lsame_(char *, char *);
+ doublereal scond;
+ logical equil, rcequ;
+ extern doublereal dlamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int zlaqhe_(char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *, char *);
+ integer infequ;
+ extern /* Subroutine */ int zhetrf_(char *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *);
+ doublereal smlnum;
+ extern /* Subroutine */ int zhetrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *), zlascl2_(integer *, integer *, doublereal *,
+ doublecomplex *, integer *), zheequb_(char *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *, doublecomplex *, integer *), zherfsx_(char *
+, char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, doublecomplex *, doublereal *, integer *
+);
+
+
+/* -- LAPACK driver routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHESVXX uses the diagonal pivoting factorization to compute the */
+/* solution to a complex*16 system of linear equations A * X = B, where */
+/* A is an N-by-N symmetric matrix and X and B are N-by-NRHS */
+/* matrices. */
+
+/* If requested, both normwise and maximum componentwise error bounds */
+/* are returned. ZHESVXX will return a solution with a tiny */
+/* guaranteed error (O(eps) where eps is the working machine */
+/* precision) unless the matrix is very ill-conditioned, in which */
+/* case a warning is returned. Relevant condition numbers also are */
+/* calculated and returned. */
+
+/* ZHESVXX accepts user-provided factorizations and equilibration */
+/* factors; see the definitions of the FACT and EQUED options. */
+/* Solving with refinement and using a factorization from a previous */
+/* ZHESVXX call will also produce a solution with either O(eps) */
+/* errors or warnings, but we cannot make that claim for general */
+/* user-provided factorizations and equilibration factors if they */
+/* differ from what ZHESVXX would itself produce. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate */
+/* the system: */
+
+/* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B */
+
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
+
+/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */
+/* the matrix A (after equilibration if FACT = 'E') as */
+
+/* A = U * D * U**T, if UPLO = 'U', or */
+/* A = L * D * L**T, if UPLO = 'L', */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* 3. If some D(i,i)=0, so that D is exactly singular, then the */
+/* routine returns with INFO = i. Otherwise, the factored form of A */
+/* is used to estimate the condition number of the matrix A (see */
+/* argument RCOND). If the reciprocal of the condition number is */
+/* less than machine precision, the routine still goes on to solve */
+/* for X and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */
+/* the routine will use iterative refinement to try to get a small */
+/* error and error bounds. Refinement calculates the residual to at */
+/* least twice the working precision. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(R) so that it solves the original system before */
+/* equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF and IPIV contain the factored form of A. */
+/* If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by S. */
+/* A, AF, and IPIV are not modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular */
+/* part of the matrix A, and the strictly lower triangular */
+/* part of A is not referenced. If UPLO = 'L', the leading */
+/* N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
+/* diag(S)*A*diag(S). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) COMPLEX*16 array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L from the factorization A = */
+/* U*D*U**T or A = L*D*L**T as computed by DSYTRF. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L from the factorization A = */
+/* U*D*U**T or A = L*D*L**T. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains details of the interchanges and the block */
+/* structure of D, as determined by ZHETRF. If IPIV(k) > 0, */
+/* then rows and columns k and IPIV(k) were interchanged and */
+/* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and */
+/* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and */
+/* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 */
+/* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0, */
+/* then rows and columns k+1 and -IPIV(k) were interchanged */
+/* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains details of the interchanges and the block */
+/* structure of D, as determined by ZHETRF. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'Y': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(S) * A * diag(S). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* S (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The scale factors for A. If EQUED = 'Y', A is multiplied on */
+/* the left and right by diag(S). S is an input argument if FACT = */
+/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
+/* = 'Y', each element of S must be positive. If S is output, each */
+/* element of S is a power of the radix. If S is input, each element */
+/* of S should be a power of the radix to ensure a reliable solution */
+/* and error estimates. Scaling by powers of the radix does not cause */
+/* rounding errors unless the result underflows or overflows. */
+/* Rounding errors during scaling lead to refining with a matrix that */
+/* is not equivalent to the input matrix, producing error estimates */
+/* that may not be reliable. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if EQUED = 'Y', B is overwritten by diag(S)*B; */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* If INFO = 0, the N-by-NRHS solution matrix X to the original */
+/* system of equations. Note that A and B are modified on exit if */
+/* EQUED .ne. 'N', and the solution to the equilibrated system is */
+/* inv(diag(S))*X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* RPVGRW (output) DOUBLE PRECISION */
+/* Reciprocal pivot growth. On exit, this contains the reciprocal */
+/* pivot growth factor norm(A)/norm(U). The "max absolute element" */
+/* norm is used. If this is much less than 1, then the stability of */
+/* the LU factorization of the (equilibrated) matrix A could be poor. */
+/* This also means that the solution X, estimated condition numbers, */
+/* and error bounds could be unreliable. If factorization fails with */
+/* 0<INFO<=N, then this contains the reciprocal pivot growth factor */
+/* for the leading INFO columns of A. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0D+0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the extra-precise refinement algorithm. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rcequ = FALSE_;
+ } else {
+ rcequ = lsame_(equed, "Y");
+ }
+
+/* Default is failure. If an input parameter is wrong or */
+/* factorization fails, make everything look horrible. Only the */
+/* pivot growth is set here, the rest is initialized in ZHERFSX. */
+
+ *rpvgrw = 0.;
+
+/* Test the input parameters. PARAMS is not tested until ZHERFSX. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (lsame_(fact, "F") && ! (rcequ || lsame_(
+ equed, "N"))) {
+ *info = -9;
+ } else {
+ if (rcequ) {
+ smin = bignum;
+ smax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = smin, d__2 = s[j];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = smax, d__2 = s[j];
+ smax = max(d__1,d__2);
+/* L10: */
+ }
+ if (smin <= 0.) {
+ *info = -10;
+ } else if (*n > 0) {
+ scond = max(smin,smlnum) / min(smax,bignum);
+ } else {
+ scond = 1.;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -12;
+ } else if (*ldx < max(1,*n)) {
+ *info = -14;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHESVXX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ zheequb_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, &work[1], &
+ infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ zlaqhe_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed);
+ rcequ = lsame_(equed, "Y");
+ }
+ }
+
+/* Scale the right-hand side. */
+
+ if (rcequ) {
+ zlascl2_(n, nrhs, &s[1], &b[b_offset], ldb);
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of A. */
+
+ zlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ i__1 = max(1,*n) * 5;
+ zhetrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], &i__1,
+ info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Pivot in column INFO is exactly 0 */
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ if (*n > 0) {
+ *rpvgrw = zla_herpvgrw__(uplo, n, info, &a[a_offset], lda, &
+ af[af_offset], ldaf, &ipiv[1], &rwork[1], (ftnlen)1);
+ }
+ return 0;
+ }
+ }
+
+/* Compute the reciprocal pivot growth factor RPVGRW. */
+
+ if (*n > 0) {
+ *rpvgrw = zla_herpvgrw__(uplo, n, info, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &rwork[1], (ftnlen)1);
+ }
+
+/* Compute the solution matrix X. */
+
+ zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ zhetrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ zherfsx_(uplo, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &
+ ipiv[1], &s[1], &b[b_offset], ldb, &x[x_offset], ldx, rcond, &
+ berr[1], n_err_bnds__, &err_bnds_norm__[err_bnds_norm_offset], &
+ err_bnds_comp__[err_bnds_comp_offset], nparams, ¶ms[1], &work[
+ 1], &rwork[1], info);
+
+/* Scale solutions. */
+
+ if (rcequ) {
+ zlascl2_(n, nrhs, &s[1], &x[x_offset], ldx);
+ }
+
+ return 0;
+
+/* End of ZHESVXX */
+
+} /* zhesvxx_ */
diff --git a/SRC/zhetd2.c b/SRC/zhetd2.c
new file mode 100644
index 0000000..a783b5d
--- /dev/null
+++ b/SRC/zhetd2.c
@@ -0,0 +1,361 @@
+/* zhetd2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b2 = {0.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zhetd2_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublereal *d__, doublereal *e, doublecomplex *tau,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Local variables */
+ integer i__;
+ doublecomplex taui;
+ extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ doublecomplex alpha;
+ extern logical lsame_(char *, char *);
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zhemv_(char *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(
+ char *, integer *), zlarfg_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHETD2 reduces a complex Hermitian matrix A to real symmetric */
+/* tridiagonal form T by a unitary similarity transformation: */
+/* Q' * A * Q = T. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the 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 UPLO = 'U', the diagonal and first superdiagonal */
+/* of A are overwritten by the corresponding elements of the */
+/* tridiagonal matrix T, and the elements above the first */
+/* superdiagonal, with the array TAU, represent the unitary */
+/* matrix Q as a product of elementary reflectors; if UPLO */
+/* = 'L', the diagonal and first subdiagonal of A are over- */
+/* written by the corresponding elements of the tridiagonal */
+/* matrix T, and the elements below the first subdiagonal, with */
+/* the array TAU, represent the unitary matrix Q as a product */
+/* of elementary reflectors. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* D (output) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal elements of the tridiagonal matrix T: */
+/* D(i) = A(i,i). */
+
+/* E (output) DOUBLE PRECISION array, dimension (N-1) */
+/* The off-diagonal elements of the tridiagonal matrix T: */
+/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */
+
+/* TAU (output) COMPLEX*16 array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(n-1) . . . H(2) H(1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */
+/* A(1:i-1,i+1), and tau in TAU(i). */
+
+/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(1) H(2) . . . H(n-1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */
+/* and tau in TAU(i). */
+
+/* The contents of A on exit are illustrated by the following examples */
+/* with n = 5: */
+
+/* if UPLO = 'U': if UPLO = 'L': */
+
+/* ( d e v2 v3 v4 ) ( d ) */
+/* ( d e v3 v4 ) ( e d ) */
+/* ( d e v4 ) ( v1 e d ) */
+/* ( d e ) ( v1 v2 e d ) */
+/* ( d ) ( v1 v2 v3 e d ) */
+
+/* where d and e denote diagonal and off-diagonal elements of T, and vi */
+/* denotes an element of the vector defining H(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ --tau;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHETD2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Reduce the upper triangle of A */
+
+ i__1 = *n + *n * a_dim1;
+ i__2 = *n + *n * a_dim1;
+ d__1 = a[i__2].r;
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+
+/* Generate elementary reflector H(i) = I - tau * v * v' */
+/* to annihilate A(1:i-1,i+1) */
+
+ i__1 = i__ + (i__ + 1) * a_dim1;
+ alpha.r = a[i__1].r, alpha.i = a[i__1].i;
+ zlarfg_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &taui);
+ i__1 = i__;
+ e[i__1] = alpha.r;
+
+ if (taui.r != 0. || taui.i != 0.) {
+
+/* Apply H(i) from both sides to A(1:i,1:i) */
+
+ i__1 = i__ + (i__ + 1) * a_dim1;
+ a[i__1].r = 1., a[i__1].i = 0.;
+
+/* Compute x := tau * A * v storing x in TAU(1:i) */
+
+ zhemv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) *
+ a_dim1 + 1], &c__1, &c_b2, &tau[1], &c__1);
+
+/* Compute w := x - 1/2 * tau * (x'*v) * v */
+
+ z__3.r = -.5, z__3.i = -0.;
+ z__2.r = z__3.r * taui.r - z__3.i * taui.i, z__2.i = z__3.r *
+ taui.i + z__3.i * taui.r;
+ zdotc_(&z__4, &i__, &tau[1], &c__1, &a[(i__ + 1) * a_dim1 + 1]
+, &c__1);
+ z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r *
+ z__4.i + z__2.i * z__4.r;
+ alpha.r = z__1.r, alpha.i = z__1.i;
+ zaxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[
+ 1], &c__1);
+
+/* Apply the transformation as a rank-2 update: */
+/* A := A - v * w' - w * v' */
+
+ z__1.r = -1., z__1.i = -0.;
+ zher2_(uplo, &i__, &z__1, &a[(i__ + 1) * a_dim1 + 1], &c__1, &
+ tau[1], &c__1, &a[a_offset], lda);
+
+ } else {
+ i__1 = i__ + i__ * a_dim1;
+ i__2 = i__ + i__ * a_dim1;
+ d__1 = a[i__2].r;
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ }
+ i__1 = i__ + (i__ + 1) * a_dim1;
+ i__2 = i__;
+ a[i__1].r = e[i__2], a[i__1].i = 0.;
+ i__1 = i__ + 1;
+ i__2 = i__ + 1 + (i__ + 1) * a_dim1;
+ d__[i__1] = a[i__2].r;
+ i__1 = i__;
+ tau[i__1].r = taui.r, tau[i__1].i = taui.i;
+/* L10: */
+ }
+ i__1 = a_dim1 + 1;
+ d__[1] = a[i__1].r;
+ } else {
+
+/* Reduce the lower triangle of A */
+
+ i__1 = a_dim1 + 1;
+ i__2 = a_dim1 + 1;
+ d__1 = a[i__2].r;
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Generate elementary reflector H(i) = I - tau * v * v' */
+/* to annihilate A(i+2:n,i) */
+
+ i__2 = i__ + 1 + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *n - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ zlarfg_(&i__2, &alpha, &a[min(i__3, *n)+ i__ * a_dim1], &c__1, &
+ taui);
+ i__2 = i__;
+ e[i__2] = alpha.r;
+
+ if (taui.r != 0. || taui.i != 0.) {
+
+/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
+
+ i__2 = i__ + 1 + i__ * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+
+/* Compute x := tau * A * v storing y in TAU(i:n-1) */
+
+ i__2 = *n - i__;
+ zhemv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1],
+ lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b2, &tau[
+ i__], &c__1);
+
+/* Compute w := x - 1/2 * tau * (x'*v) * v */
+
+ z__3.r = -.5, z__3.i = -0.;
+ z__2.r = z__3.r * taui.r - z__3.i * taui.i, z__2.i = z__3.r *
+ taui.i + z__3.i * taui.r;
+ i__2 = *n - i__;
+ zdotc_(&z__4, &i__2, &tau[i__], &c__1, &a[i__ + 1 + i__ *
+ a_dim1], &c__1);
+ z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r *
+ z__4.i + z__2.i * z__4.r;
+ alpha.r = z__1.r, alpha.i = z__1.i;
+ i__2 = *n - i__;
+ zaxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
+ i__], &c__1);
+
+/* Apply the transformation as a rank-2 update: */
+/* A := A - v * w' - w * v' */
+
+ i__2 = *n - i__;
+ z__1.r = -1., z__1.i = -0.;
+ zher2_(uplo, &i__2, &z__1, &a[i__ + 1 + i__ * a_dim1], &c__1,
+ &tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1],
+ lda);
+
+ } else {
+ i__2 = i__ + 1 + (i__ + 1) * a_dim1;
+ i__3 = i__ + 1 + (i__ + 1) * a_dim1;
+ d__1 = a[i__3].r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ }
+ i__2 = i__ + 1 + i__ * a_dim1;
+ i__3 = i__;
+ a[i__2].r = e[i__3], a[i__2].i = 0.;
+ i__2 = i__;
+ i__3 = i__ + i__ * a_dim1;
+ d__[i__2] = a[i__3].r;
+ i__2 = i__;
+ tau[i__2].r = taui.r, tau[i__2].i = taui.i;
+/* L20: */
+ }
+ i__1 = *n;
+ i__2 = *n + *n * a_dim1;
+ d__[i__1] = a[i__2].r;
+ }
+
+ return 0;
+
+/* End of ZHETD2 */
+
+} /* zhetd2_ */
diff --git a/SRC/zhetf2.c b/SRC/zhetf2.c
new file mode 100644
index 0000000..24a5289
--- /dev/null
+++ b/SRC/zhetf2.c
@@ -0,0 +1,802 @@
+/* zhetf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zhetf2_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_imag(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ doublereal d__;
+ integer i__, j, k;
+ doublecomplex t;
+ doublereal r1, d11;
+ doublecomplex d12;
+ doublereal d22;
+ doublecomplex d21;
+ integer kk, kp;
+ doublecomplex wk;
+ doublereal tt;
+ doublecomplex wkm1, wkp1;
+ integer imax, jmax;
+ extern /* Subroutine */ int zher_(char *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal alpha;
+ extern logical lsame_(char *, char *);
+ integer kstep;
+ logical upper;
+ extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern doublereal dlapy2_(doublereal *, doublereal *);
+ doublereal absakk;
+ extern logical disnan_(doublereal *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
+ integer *, doublereal *, doublecomplex *, integer *);
+ doublereal colmax;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ doublereal rowmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHETF2 computes the factorization of a complex Hermitian matrix A */
+/* using the Bunch-Kaufman diagonal pivoting method: */
+
+/* A = U*D*U' or A = L*D*L' */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, U' is the conjugate transpose of U, 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. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the 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, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L (see below for further details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, D(k,k) is exactly zero. 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. */
+
+/* Further Details */
+/* =============== */
+
+/* 09-29-06 - patch from */
+/* Bobby Cheng, MathWorks */
+
+/* Replace l.210 and l.393 */
+/* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN */
+/* by */
+/* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN */
+
+/* 01-01-96 - Based on modifications by */
+/* J. Lewis, Boeing Computer Services Company */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* If UPLO = 'U', then A = U*D*U', where */
+/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
+/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
+/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I v 0 ) k-s */
+/* U(k) = ( 0 I 0 ) s */
+/* ( 0 0 I ) n-k */
+/* k-s s n-k */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
+/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
+/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
+
+/* If UPLO = 'L', then A = L*D*L', where */
+/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
+/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
+/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I 0 0 ) k-1 */
+/* L(k) = ( 0 I 0 ) s */
+/* ( 0 v I ) n-k-s+1 */
+/* k-1 s n-k-s+1 */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
+/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
+/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHETF2", &i__1);
+ return 0;
+ }
+
+/* Initialize ALPHA for use in choosing pivot block size. */
+
+ alpha = (sqrt(17.) + 1.) / 8.;
+
+ if (upper) {
+
+/* Factorize A as U*D*U' using the upper triangle of A */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2 */
+
+ k = *n;
+L10:
+
+/* If K < 1, exit from loop */
+
+ if (k < 1) {
+ goto L90;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = k + k * a_dim1;
+ absakk = (d__1 = a[i__1].r, abs(d__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ imax = izamax_(&i__1, &a[k * a_dim1 + 1], &c__1);
+ i__1 = imax + k * a_dim1;
+ colmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[imax +
+ k * a_dim1]), abs(d__2));
+ } else {
+ colmax = 0.;
+ }
+
+ if (max(absakk,colmax) == 0. || disnan_(&absakk)) {
+
+/* Column K is zero or contains a NaN: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ d__1 = a[i__2].r;
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = k - imax;
+ jmax = imax + izamax_(&i__1, &a[imax + (imax + 1) * a_dim1],
+ lda);
+ i__1 = imax + jmax * a_dim1;
+ rowmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[
+ imax + jmax * a_dim1]), abs(d__2));
+ if (imax > 1) {
+ i__1 = imax - 1;
+ jmax = izamax_(&i__1, &a[imax * a_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__1 = jmax + imax * a_dim1;
+ d__3 = rowmax, d__4 = (d__1 = a[i__1].r, abs(d__1)) + (
+ d__2 = d_imag(&a[jmax + imax * a_dim1]), abs(d__2)
+ );
+ rowmax = max(d__3,d__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = imax + imax * a_dim1;
+ if ((d__1 = a[i__1].r, abs(d__1)) >= alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k - kstep + 1;
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the leading */
+/* submatrix A(1:k,1:k) */
+
+ i__1 = kp - 1;
+ zswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1],
+ &c__1);
+ i__1 = kk - 1;
+ for (j = kp + 1; j <= i__1; ++j) {
+ d_cnjg(&z__1, &a[j + kk * a_dim1]);
+ t.r = z__1.r, t.i = z__1.i;
+ i__2 = j + kk * a_dim1;
+ d_cnjg(&z__1, &a[kp + j * a_dim1]);
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ i__2 = kp + j * a_dim1;
+ a[i__2].r = t.r, a[i__2].i = t.i;
+/* L20: */
+ }
+ i__1 = kp + kk * a_dim1;
+ d_cnjg(&z__1, &a[kp + kk * a_dim1]);
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = kk + kk * a_dim1;
+ r1 = a[i__1].r;
+ i__1 = kk + kk * a_dim1;
+ i__2 = kp + kp * a_dim1;
+ d__1 = a[i__2].r;
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ i__1 = kp + kp * a_dim1;
+ a[i__1].r = r1, a[i__1].i = 0.;
+ if (kstep == 2) {
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ d__1 = a[i__2].r;
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ i__1 = k - 1 + k * a_dim1;
+ t.r = a[i__1].r, t.i = a[i__1].i;
+ i__1 = k - 1 + k * a_dim1;
+ i__2 = kp + k * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + k * a_dim1;
+ a[i__1].r = t.r, a[i__1].i = t.i;
+ }
+ } else {
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ d__1 = a[i__2].r;
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ if (kstep == 2) {
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ i__2 = k - 1 + (k - 1) * a_dim1;
+ d__1 = a[i__2].r;
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ }
+ }
+
+/* Update the leading submatrix */
+
+ if (kstep == 1) {
+
+/* 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 */
+
+/* Perform a rank-1 update of A(1:k-1,1:k-1) as */
+
+/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */
+
+ i__1 = k + k * a_dim1;
+ r1 = 1. / a[i__1].r;
+ i__1 = k - 1;
+ d__1 = -r1;
+ zher_(uplo, &i__1, &d__1, &a[k * a_dim1 + 1], &c__1, &a[
+ a_offset], lda);
+
+/* Store U(k) in column k */
+
+ i__1 = k - 1;
+ zdscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
+ } 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) )' */
+/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */
+
+ if (k > 2) {
+
+ i__1 = k - 1 + k * a_dim1;
+ d__1 = a[i__1].r;
+ d__2 = d_imag(&a[k - 1 + k * a_dim1]);
+ d__ = dlapy2_(&d__1, &d__2);
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ d22 = a[i__1].r / d__;
+ i__1 = k + k * a_dim1;
+ d11 = a[i__1].r / d__;
+ tt = 1. / (d11 * d22 - 1.);
+ i__1 = k - 1 + k * a_dim1;
+ z__1.r = a[i__1].r / d__, z__1.i = a[i__1].i / d__;
+ d12.r = z__1.r, d12.i = z__1.i;
+ d__ = tt / d__;
+
+ for (j = k - 2; j >= 1; --j) {
+ i__1 = j + (k - 1) * a_dim1;
+ z__3.r = d11 * a[i__1].r, z__3.i = d11 * a[i__1].i;
+ d_cnjg(&z__5, &d12);
+ i__2 = j + k * a_dim1;
+ z__4.r = z__5.r * a[i__2].r - z__5.i * a[i__2].i,
+ z__4.i = z__5.r * a[i__2].i + z__5.i * a[i__2]
+ .r;
+ z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
+ z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
+ wkm1.r = z__1.r, wkm1.i = z__1.i;
+ i__1 = j + k * a_dim1;
+ z__3.r = d22 * a[i__1].r, z__3.i = d22 * a[i__1].i;
+ i__2 = j + (k - 1) * a_dim1;
+ z__4.r = d12.r * a[i__2].r - d12.i * a[i__2].i,
+ z__4.i = d12.r * a[i__2].i + d12.i * a[i__2]
+ .r;
+ z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
+ z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
+ wk.r = z__1.r, wk.i = z__1.i;
+ for (i__ = j; i__ >= 1; --i__) {
+ i__1 = i__ + j * a_dim1;
+ i__2 = i__ + j * a_dim1;
+ i__3 = i__ + k * a_dim1;
+ d_cnjg(&z__4, &wk);
+ z__3.r = a[i__3].r * z__4.r - a[i__3].i * z__4.i,
+ z__3.i = a[i__3].r * z__4.i + a[i__3].i *
+ z__4.r;
+ z__2.r = a[i__2].r - z__3.r, z__2.i = a[i__2].i -
+ z__3.i;
+ i__4 = i__ + (k - 1) * a_dim1;
+ d_cnjg(&z__6, &wkm1);
+ z__5.r = a[i__4].r * z__6.r - a[i__4].i * z__6.i,
+ z__5.i = a[i__4].r * z__6.i + a[i__4].i *
+ z__6.r;
+ z__1.r = z__2.r - z__5.r, z__1.i = z__2.i -
+ z__5.i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+/* L30: */
+ }
+ i__1 = j + k * a_dim1;
+ a[i__1].r = wk.r, a[i__1].i = wk.i;
+ i__1 = j + (k - 1) * a_dim1;
+ a[i__1].r = wkm1.r, a[i__1].i = wkm1.i;
+ i__1 = j + j * a_dim1;
+ i__2 = j + j * a_dim1;
+ d__1 = a[i__2].r;
+ z__1.r = d__1, z__1.i = 0.;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+/* L40: */
+ }
+
+ }
+
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k - 1] = -kp;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kstep;
+ goto L10;
+
+ } else {
+
+/* Factorize A as L*D*L' using the lower triangle of A */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2 */
+
+ k = 1;
+L50:
+
+/* If K > N, exit from loop */
+
+ if (k > *n) {
+ goto L90;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = k + k * a_dim1;
+ absakk = (d__1 = a[i__1].r, abs(d__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ imax = k + izamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1);
+ i__1 = imax + k * a_dim1;
+ colmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[imax +
+ k * a_dim1]), abs(d__2));
+ } else {
+ colmax = 0.;
+ }
+
+ if (max(absakk,colmax) == 0. || disnan_(&absakk)) {
+
+/* Column K is zero or contains a NaN: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ d__1 = a[i__2].r;
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = imax - k;
+ jmax = k - 1 + izamax_(&i__1, &a[imax + k * a_dim1], lda);
+ i__1 = imax + jmax * a_dim1;
+ rowmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[
+ imax + jmax * a_dim1]), abs(d__2));
+ if (imax < *n) {
+ i__1 = *n - imax;
+ jmax = imax + izamax_(&i__1, &a[imax + 1 + imax * a_dim1],
+ &c__1);
+/* Computing MAX */
+ i__1 = jmax + imax * a_dim1;
+ d__3 = rowmax, d__4 = (d__1 = a[i__1].r, abs(d__1)) + (
+ d__2 = d_imag(&a[jmax + imax * a_dim1]), abs(d__2)
+ );
+ rowmax = max(d__3,d__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = imax + imax * a_dim1;
+ if ((d__1 = a[i__1].r, abs(d__1)) >= alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k + kstep - 1;
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the trailing */
+/* submatrix A(k:n,k:n) */
+
+ if (kp < *n) {
+ i__1 = *n - kp;
+ zswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1
+ + kp * a_dim1], &c__1);
+ }
+ i__1 = kp - 1;
+ for (j = kk + 1; j <= i__1; ++j) {
+ d_cnjg(&z__1, &a[j + kk * a_dim1]);
+ t.r = z__1.r, t.i = z__1.i;
+ i__2 = j + kk * a_dim1;
+ d_cnjg(&z__1, &a[kp + j * a_dim1]);
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ i__2 = kp + j * a_dim1;
+ a[i__2].r = t.r, a[i__2].i = t.i;
+/* L60: */
+ }
+ i__1 = kp + kk * a_dim1;
+ d_cnjg(&z__1, &a[kp + kk * a_dim1]);
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = kk + kk * a_dim1;
+ r1 = a[i__1].r;
+ i__1 = kk + kk * a_dim1;
+ i__2 = kp + kp * a_dim1;
+ d__1 = a[i__2].r;
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ i__1 = kp + kp * a_dim1;
+ a[i__1].r = r1, a[i__1].i = 0.;
+ if (kstep == 2) {
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ d__1 = a[i__2].r;
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ i__1 = k + 1 + k * a_dim1;
+ t.r = a[i__1].r, t.i = a[i__1].i;
+ i__1 = k + 1 + k * a_dim1;
+ i__2 = kp + k * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + k * a_dim1;
+ a[i__1].r = t.r, a[i__1].i = t.i;
+ }
+ } else {
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ d__1 = a[i__2].r;
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ if (kstep == 2) {
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ i__2 = k + 1 + (k + 1) * a_dim1;
+ d__1 = a[i__2].r;
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ }
+ }
+
+/* Update the trailing submatrix */
+
+ if (kstep == 1) {
+
+/* 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 < *n) {
+
+/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
+
+/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */
+
+ i__1 = k + k * a_dim1;
+ r1 = 1. / a[i__1].r;
+ i__1 = *n - k;
+ d__1 = -r1;
+ zher_(uplo, &i__1, &d__1, &a[k + 1 + k * a_dim1], &c__1, &
+ a[k + 1 + (k + 1) * a_dim1], lda);
+
+/* Store L(k) in column K */
+
+ i__1 = *n - k;
+ zdscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1);
+ }
+ } else {
+
+/* 2-by-2 pivot block D(k) */
+
+ if (k < *n - 1) {
+
+/* 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) )' */
+/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' */
+
+/* where L(k) and L(k+1) are the k-th and (k+1)-th */
+/* columns of L */
+
+ i__1 = k + 1 + k * a_dim1;
+ d__1 = a[i__1].r;
+ d__2 = d_imag(&a[k + 1 + k * a_dim1]);
+ d__ = dlapy2_(&d__1, &d__2);
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ d11 = a[i__1].r / d__;
+ i__1 = k + k * a_dim1;
+ d22 = a[i__1].r / d__;
+ tt = 1. / (d11 * d22 - 1.);
+ i__1 = k + 1 + k * a_dim1;
+ z__1.r = a[i__1].r / d__, z__1.i = a[i__1].i / d__;
+ d21.r = z__1.r, d21.i = z__1.i;
+ d__ = tt / d__;
+
+ i__1 = *n;
+ for (j = k + 2; j <= i__1; ++j) {
+ i__2 = j + k * a_dim1;
+ z__3.r = d11 * a[i__2].r, z__3.i = d11 * a[i__2].i;
+ i__3 = j + (k + 1) * a_dim1;
+ z__4.r = d21.r * a[i__3].r - d21.i * a[i__3].i,
+ z__4.i = d21.r * a[i__3].i + d21.i * a[i__3]
+ .r;
+ z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
+ z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
+ wk.r = z__1.r, wk.i = z__1.i;
+ i__2 = j + (k + 1) * a_dim1;
+ z__3.r = d22 * a[i__2].r, z__3.i = d22 * a[i__2].i;
+ d_cnjg(&z__5, &d21);
+ i__3 = j + k * a_dim1;
+ z__4.r = z__5.r * a[i__3].r - z__5.i * a[i__3].i,
+ z__4.i = z__5.r * a[i__3].i + z__5.i * a[i__3]
+ .r;
+ z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
+ z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
+ wkp1.r = z__1.r, wkp1.i = z__1.i;
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__ + k * a_dim1;
+ d_cnjg(&z__4, &wk);
+ z__3.r = a[i__5].r * z__4.r - a[i__5].i * z__4.i,
+ z__3.i = a[i__5].r * z__4.i + a[i__5].i *
+ z__4.r;
+ z__2.r = a[i__4].r - z__3.r, z__2.i = a[i__4].i -
+ z__3.i;
+ i__6 = i__ + (k + 1) * a_dim1;
+ d_cnjg(&z__6, &wkp1);
+ z__5.r = a[i__6].r * z__6.r - a[i__6].i * z__6.i,
+ z__5.i = a[i__6].r * z__6.i + a[i__6].i *
+ z__6.r;
+ z__1.r = z__2.r - z__5.r, z__1.i = z__2.i -
+ z__5.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L70: */
+ }
+ i__2 = j + k * a_dim1;
+ a[i__2].r = wk.r, a[i__2].i = wk.i;
+ i__2 = j + (k + 1) * a_dim1;
+ a[i__2].r = wkp1.r, a[i__2].i = wkp1.i;
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ d__1 = a[i__3].r;
+ z__1.r = d__1, z__1.i = 0.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L80: */
+ }
+ }
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k + 1] = -kp;
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kstep;
+ goto L50;
+
+ }
+
+L90:
+ return 0;
+
+/* End of ZHETF2 */
+
+} /* zhetf2_ */
diff --git a/SRC/zhetrd.c b/SRC/zhetrd.c
new file mode 100644
index 0000000..fcab44a
--- /dev/null
+++ b/SRC/zhetrd.c
@@ -0,0 +1,370 @@
+/* zhetrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+static doublereal c_b23 = 1.;
+
+/* Subroutine */ int zhetrd_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublereal *d__, doublereal *e, doublecomplex *tau,
+ doublecomplex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j, nb, kk, nx, iws;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ logical upper;
+ extern /* Subroutine */ int zhetd2_(char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublecomplex *, integer *), zher2k_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, doublecomplex *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zlatrd_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ doublecomplex *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHETRD reduces a complex Hermitian matrix A to real symmetric */
+/* tridiagonal form T by a unitary similarity transformation: */
+/* Q**H * A * Q = T. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (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 UPLO = 'U', the diagonal and first superdiagonal */
+/* of A are overwritten by the corresponding elements of the */
+/* tridiagonal matrix T, and the elements above the first */
+/* superdiagonal, with the array TAU, represent the unitary */
+/* matrix Q as a product of elementary reflectors; if UPLO */
+/* = 'L', the diagonal and first subdiagonal of A are over- */
+/* written by the corresponding elements of the tridiagonal */
+/* matrix T, and the elements below the first subdiagonal, with */
+/* the array TAU, represent the unitary matrix Q as a product */
+/* of elementary reflectors. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* D (output) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal elements of the tridiagonal matrix T: */
+/* D(i) = A(i,i). */
+
+/* E (output) DOUBLE PRECISION array, dimension (N-1) */
+/* The off-diagonal elements of the tridiagonal matrix T: */
+/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */
+
+/* TAU (output) COMPLEX*16 array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= 1. */
+/* For optimum performance LWORK >= N*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(n-1) . . . H(2) H(1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */
+/* A(1:i-1,i+1), and tau in TAU(i). */
+
+/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(1) H(2) . . . H(n-1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */
+/* and tau in TAU(i). */
+
+/* The contents of A on exit are illustrated by the following examples */
+/* with n = 5: */
+
+/* if UPLO = 'U': if UPLO = 'L': */
+
+/* ( d e v2 v3 v4 ) ( d ) */
+/* ( d e v3 v4 ) ( e d ) */
+/* ( d e v4 ) ( v1 e d ) */
+/* ( d e ) ( v1 v2 e d ) */
+/* ( d ) ( v1 v2 v3 e d ) */
+
+/* where d and e denote diagonal and off-diagonal elements of T, and vi */
+/* denotes an element of the vector defining H(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1;
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*lwork < 1 && ! lquery) {
+ *info = -9;
+ }
+
+ if (*info == 0) {
+
+/* Determine the block size. */
+
+ nb = ilaenv_(&c__1, "ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHETRD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ work[1].r = 1., work[1].i = 0.;
+ return 0;
+ }
+
+ nx = *n;
+ iws = 1;
+ if (nb > 1 && nb < *n) {
+
+/* Determine when to cross over from blocked to unblocked code */
+/* (last block is always handled by unblocked code). */
+
+/* Computing MAX */
+ i__1 = nb, i__2 = ilaenv_(&c__3, "ZHETRD", uplo, n, &c_n1, &c_n1, &
+ c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *n) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *n;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: determine the */
+/* minimum value of NB, and reduce NB or force use of */
+/* unblocked code by setting NX = N. */
+
+/* Computing MAX */
+ i__1 = *lwork / ldwork;
+ nb = max(i__1,1);
+ nbmin = ilaenv_(&c__2, "ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
+ if (nb < nbmin) {
+ nx = *n;
+ }
+ }
+ } else {
+ nx = *n;
+ }
+ } else {
+ nb = 1;
+ }
+
+ if (upper) {
+
+/* Reduce the upper triangle of A. */
+/* Columns 1:kk are handled by the unblocked method. */
+
+ kk = *n - (*n - nx + nb - 1) / nb * nb;
+ i__1 = kk + 1;
+ i__2 = -nb;
+ for (i__ = *n - nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+
+/* Reduce columns i:i+nb-1 to tridiagonal form and form the */
+/* matrix W which is needed to update the unreduced part of */
+/* the matrix */
+
+ i__3 = i__ + nb - 1;
+ zlatrd_(uplo, &i__3, &nb, &a[a_offset], lda, &e[1], &tau[1], &
+ work[1], &ldwork);
+
+/* Update the unreduced submatrix A(1:i-1,1:i-1), using an */
+/* update of the form: A := A - V*W' - W*V' */
+
+ i__3 = i__ - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zher2k_(uplo, "No transpose", &i__3, &nb, &z__1, &a[i__ * a_dim1
+ + 1], lda, &work[1], &ldwork, &c_b23, &a[a_offset], lda);
+
+/* Copy superdiagonal elements back into A, and diagonal */
+/* elements into D */
+
+ i__3 = i__ + nb - 1;
+ for (j = i__; j <= i__3; ++j) {
+ i__4 = j - 1 + j * a_dim1;
+ i__5 = j - 1;
+ a[i__4].r = e[i__5], a[i__4].i = 0.;
+ i__4 = j;
+ i__5 = j + j * a_dim1;
+ d__[i__4] = a[i__5].r;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Use unblocked code to reduce the last or only block */
+
+ zhetd2_(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo);
+ } else {
+
+/* Reduce the lower triangle of A */
+
+ i__2 = *n - nx;
+ i__1 = nb;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
+
+/* Reduce columns i:i+nb-1 to tridiagonal form and form the */
+/* matrix W which is needed to update the unreduced part of */
+/* the matrix */
+
+ i__3 = *n - i__ + 1;
+ zlatrd_(uplo, &i__3, &nb, &a[i__ + i__ * a_dim1], lda, &e[i__], &
+ tau[i__], &work[1], &ldwork);
+
+/* Update the unreduced submatrix A(i+nb:n,i+nb:n), using */
+/* an update of the form: A := A - V*W' - W*V' */
+
+ i__3 = *n - i__ - nb + 1;
+ z__1.r = -1., z__1.i = -0.;
+ zher2k_(uplo, "No transpose", &i__3, &nb, &z__1, &a[i__ + nb +
+ i__ * a_dim1], lda, &work[nb + 1], &ldwork, &c_b23, &a[
+ i__ + nb + (i__ + nb) * a_dim1], lda);
+
+/* Copy subdiagonal elements back into A, and diagonal */
+/* elements into D */
+
+ i__3 = i__ + nb - 1;
+ for (j = i__; j <= i__3; ++j) {
+ i__4 = j + 1 + j * a_dim1;
+ i__5 = j;
+ a[i__4].r = e[i__5], a[i__4].i = 0.;
+ i__4 = j;
+ i__5 = j + j * a_dim1;
+ d__[i__4] = a[i__5].r;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Use unblocked code to reduce the last or only block */
+
+ i__1 = *n - i__ + 1;
+ zhetd2_(uplo, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__],
+ &tau[i__], &iinfo);
+ }
+
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ return 0;
+
+/* End of ZHETRD */
+
+} /* zhetrd_ */
diff --git a/SRC/zhetrf.c b/SRC/zhetrf.c
new file mode 100644
index 0000000..7fe2907
--- /dev/null
+++ b/SRC/zhetrf.c
@@ -0,0 +1,336 @@
+/* zhetrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int zhetrf_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *ipiv, doublecomplex *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer j, k, kb, nb, iws;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ logical upper;
+ extern /* Subroutine */ int zhetf2_(char *, integer *, doublecomplex *,
+ integer *, integer *, integer *), zlahef_(char *, integer
+ *, integer *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, integer *), xerbla_(char *,
+ integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork, lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHETRF computes the factorization of a complex Hermitian matrix A */
+/* using the Bunch-Kaufman diagonal pivoting method. The form of the */
+/* factorization is */
+
+/* A = U*D*U**H or A = L*D*L**H */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, 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. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (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, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L (see below for further details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK >=1. For best performance */
+/* LWORK >= N*NB, where NB is the block size returned by ILAENV. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. 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. */
+
+/* Further Details */
+/* =============== */
+
+/* If UPLO = 'U', then A = U*D*U', where */
+/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
+/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
+/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I v 0 ) k-s */
+/* U(k) = ( 0 I 0 ) s */
+/* ( 0 0 I ) n-k */
+/* k-s s n-k */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
+/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
+/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
+
+/* If UPLO = 'L', then A = L*D*L', where */
+/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
+/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
+/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I 0 0 ) k-1 */
+/* L(k) = ( 0 I 0 ) s */
+/* ( 0 v I ) n-k-s+1 */
+/* k-1 s n-k-s+1 */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
+/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
+/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1;
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*lwork < 1 && ! lquery) {
+ *info = -7;
+ }
+
+ if (*info == 0) {
+
+/* Determine the block size */
+
+ nb = ilaenv_(&c__1, "ZHETRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHETRF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = *n;
+ if (nb > 1 && nb < *n) {
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+/* Computing MAX */
+ i__1 = *lwork / ldwork;
+ nb = max(i__1,1);
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "ZHETRF", uplo, n, &c_n1, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = 1;
+ }
+ if (nb < nbmin) {
+ nb = *n;
+ }
+
+ if (upper) {
+
+/* Factorize A as U*D*U' 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; */
+/* KB is either NB or NB-1, or K for the last block */
+
+ k = *n;
+L10:
+
+/* If K < 1, exit from loop */
+
+ if (k < 1) {
+ goto L40;
+ }
+
+ if (k > nb) {
+
+/* Factorize columns k-kb+1:k of A and use blocked code to */
+/* update columns 1:k-kb */
+
+ zlahef_(uplo, &k, &nb, &kb, &a[a_offset], lda, &ipiv[1], &work[1],
+ n, &iinfo);
+ } else {
+
+/* Use unblocked code to factorize columns 1:k of A */
+
+ zhetf2_(uplo, &k, &a[a_offset], lda, &ipiv[1], &iinfo);
+ kb = k;
+ }
+
+/* Set INFO on the first occurrence of a zero pivot */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kb;
+ goto L10;
+
+ } else {
+
+/* Factorize A as L*D*L' 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; */
+/* KB is either NB or NB-1, or N-K+1 for the last block */
+
+ k = 1;
+L20:
+
+/* If K > N, exit from loop */
+
+ if (k > *n) {
+ goto L40;
+ }
+
+ if (k <= *n - nb) {
+
+/* Factorize columns k:k+kb-1 of A and use blocked code to */
+/* update columns k+kb:n */
+
+ i__1 = *n - k + 1;
+ zlahef_(uplo, &i__1, &nb, &kb, &a[k + k * a_dim1], lda, &ipiv[k],
+ &work[1], n, &iinfo);
+ } else {
+
+/* Use unblocked code to factorize columns k:n of A */
+
+ i__1 = *n - k + 1;
+ zhetf2_(uplo, &i__1, &a[k + k * a_dim1], lda, &ipiv[k], &iinfo);
+ kb = *n - k + 1;
+ }
+
+/* Set INFO on the first occurrence of a zero pivot */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo + k - 1;
+ }
+
+/* Adjust IPIV */
+
+ i__1 = k + kb - 1;
+ for (j = k; j <= i__1; ++j) {
+ if (ipiv[j] > 0) {
+ ipiv[j] = ipiv[j] + k - 1;
+ } else {
+ ipiv[j] = ipiv[j] - k + 1;
+ }
+/* L30: */
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kb;
+ goto L20;
+
+ }
+
+L40:
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ return 0;
+
+/* End of ZHETRF */
+
+} /* zhetrf_ */
diff --git a/SRC/zhetri.c b/SRC/zhetri.c
new file mode 100644
index 0000000..7dadd4f
--- /dev/null
+++ b/SRC/zhetri.c
@@ -0,0 +1,510 @@
+/* zhetri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b2 = {0.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zhetri_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *ipiv, doublecomplex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ doublereal d__;
+ integer j, k;
+ doublereal t, ak;
+ integer kp;
+ doublereal akp1;
+ doublecomplex temp, akkp1;
+ extern logical lsame_(char *, char *);
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ integer kstep;
+ extern /* Subroutine */ int zhemv_(char *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHETRI computes the inverse of a complex Hermitian indefinite matrix */
+/* A using the factorization A = U*D*U**H or A = L*D*L**H computed by */
+/* ZHETRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**H; */
+/* = 'L': Lower triangular, form is A = L*D*L**H. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L as computed by ZHETRF. */
+
+/* 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. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by ZHETRF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* INFO (output) 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. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHETRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ for (*info = *n; *info >= 1; --(*info)) {
+ i__1 = *info + *info * a_dim1;
+ if (ipiv[*info] > 0 && (a[i__1].r == 0. && a[i__1].i == 0.)) {
+ return 0;
+ }
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ i__2 = *info + *info * a_dim1;
+ if (ipiv[*info] > 0 && (a[i__2].r == 0. && a[i__2].i == 0.)) {
+ return 0;
+ }
+/* L20: */
+ }
+ }
+ *info = 0;
+
+ if (upper) {
+
+/* Compute inv(A) from the factorization A = U*D*U'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+L30:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L50;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ d__1 = 1. / a[i__2].r;
+ a[i__1].r = d__1, a[i__1].i = 0.;
+
+/* Compute column K of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zhemv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1,
+ &c_b2, &a[k * a_dim1 + 1], &c__1);
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ i__3 = k - 1;
+ zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k * a_dim1 + 1], &
+ c__1);
+ d__1 = z__2.r;
+ z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ t = z_abs(&a[k + (k + 1) * a_dim1]);
+ i__1 = k + k * a_dim1;
+ ak = a[i__1].r / t;
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ akp1 = a[i__1].r / t;
+ i__1 = k + (k + 1) * a_dim1;
+ z__1.r = a[i__1].r / t, z__1.i = a[i__1].i / t;
+ akkp1.r = z__1.r, akkp1.i = z__1.i;
+ d__ = t * (ak * akp1 - 1.);
+ i__1 = k + k * a_dim1;
+ d__1 = akp1 / d__;
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ d__1 = ak / d__;
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ i__1 = k + (k + 1) * a_dim1;
+ z__2.r = -akkp1.r, z__2.i = -akkp1.i;
+ z__1.r = z__2.r / d__, z__1.i = z__2.i / d__;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+
+/* Compute columns K and K+1 of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zhemv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1,
+ &c_b2, &a[k * a_dim1 + 1], &c__1);
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ i__3 = k - 1;
+ zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k * a_dim1 + 1], &
+ c__1);
+ d__1 = z__2.r;
+ z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = k + (k + 1) * a_dim1;
+ i__2 = k + (k + 1) * a_dim1;
+ i__3 = k - 1;
+ zdotc_(&z__2, &i__3, &a[k * a_dim1 + 1], &c__1, &a[(k + 1) *
+ a_dim1 + 1], &c__1);
+ z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = k - 1;
+ zcopy_(&i__1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], &
+ c__1);
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zhemv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1,
+ &c_b2, &a[(k + 1) * a_dim1 + 1], &c__1);
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ i__2 = k + 1 + (k + 1) * a_dim1;
+ i__3 = k - 1;
+ zdotc_(&z__2, &i__3, &work[1], &c__1, &a[(k + 1) * a_dim1 + 1]
+, &c__1);
+ d__1 = z__2.r;
+ z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ }
+ kstep = 2;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the leading */
+/* submatrix A(1:k+1,1:k+1) */
+
+ i__1 = kp - 1;
+ zswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &
+ c__1);
+ i__1 = k - 1;
+ for (j = kp + 1; j <= i__1; ++j) {
+ d_cnjg(&z__1, &a[j + k * a_dim1]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__2 = j + k * a_dim1;
+ d_cnjg(&z__1, &a[kp + j * a_dim1]);
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ i__2 = kp + j * a_dim1;
+ a[i__2].r = temp.r, a[i__2].i = temp.i;
+/* L40: */
+ }
+ i__1 = kp + k * a_dim1;
+ d_cnjg(&z__1, &a[kp + k * a_dim1]);
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = k + k * a_dim1;
+ temp.r = a[i__1].r, temp.i = a[i__1].i;
+ i__1 = k + k * a_dim1;
+ i__2 = kp + kp * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + kp * a_dim1;
+ a[i__1].r = temp.r, a[i__1].i = temp.i;
+ if (kstep == 2) {
+ i__1 = k + (k + 1) * a_dim1;
+ temp.r = a[i__1].r, temp.i = a[i__1].i;
+ i__1 = k + (k + 1) * a_dim1;
+ i__2 = kp + (k + 1) * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + (k + 1) * a_dim1;
+ a[i__1].r = temp.r, a[i__1].i = temp.i;
+ }
+ }
+
+ k += kstep;
+ goto L30;
+L50:
+
+ ;
+ } else {
+
+/* Compute inv(A) from the factorization A = L*D*L'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+L60:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L80;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ d__1 = 1. / a[i__2].r;
+ a[i__1].r = d__1, a[i__1].i = 0.;
+
+/* Compute column K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ zcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zhemv_(uplo, &i__1, &z__1, &a[k + 1 + (k + 1) * a_dim1], lda,
+ &work[1], &c__1, &c_b2, &a[k + 1 + k * a_dim1], &c__1);
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ i__3 = *n - k;
+ zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k + 1 + k * a_dim1],
+ &c__1);
+ d__1 = z__2.r;
+ z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ t = z_abs(&a[k + (k - 1) * a_dim1]);
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ ak = a[i__1].r / t;
+ i__1 = k + k * a_dim1;
+ akp1 = a[i__1].r / t;
+ i__1 = k + (k - 1) * a_dim1;
+ z__1.r = a[i__1].r / t, z__1.i = a[i__1].i / t;
+ akkp1.r = z__1.r, akkp1.i = z__1.i;
+ d__ = t * (ak * akp1 - 1.);
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ d__1 = akp1 / d__;
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ i__1 = k + k * a_dim1;
+ d__1 = ak / d__;
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ i__1 = k + (k - 1) * a_dim1;
+ z__2.r = -akkp1.r, z__2.i = -akkp1.i;
+ z__1.r = z__2.r / d__, z__1.i = z__2.i / d__;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+
+/* Compute columns K-1 and K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ zcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zhemv_(uplo, &i__1, &z__1, &a[k + 1 + (k + 1) * a_dim1], lda,
+ &work[1], &c__1, &c_b2, &a[k + 1 + k * a_dim1], &c__1);
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ i__3 = *n - k;
+ zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k + 1 + k * a_dim1],
+ &c__1);
+ d__1 = z__2.r;
+ z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = k + (k - 1) * a_dim1;
+ i__2 = k + (k - 1) * a_dim1;
+ i__3 = *n - k;
+ zdotc_(&z__2, &i__3, &a[k + 1 + k * a_dim1], &c__1, &a[k + 1
+ + (k - 1) * a_dim1], &c__1);
+ z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = *n - k;
+ zcopy_(&i__1, &a[k + 1 + (k - 1) * a_dim1], &c__1, &work[1], &
+ c__1);
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zhemv_(uplo, &i__1, &z__1, &a[k + 1 + (k + 1) * a_dim1], lda,
+ &work[1], &c__1, &c_b2, &a[k + 1 + (k - 1) * a_dim1],
+ &c__1);
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ i__2 = k - 1 + (k - 1) * a_dim1;
+ i__3 = *n - k;
+ zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k + 1 + (k - 1) *
+ a_dim1], &c__1);
+ d__1 = z__2.r;
+ z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ }
+ kstep = 2;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the trailing */
+/* submatrix A(k-1:n,k-1:n) */
+
+ if (kp < *n) {
+ i__1 = *n - kp;
+ zswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + kp *
+ a_dim1], &c__1);
+ }
+ i__1 = kp - 1;
+ for (j = k + 1; j <= i__1; ++j) {
+ d_cnjg(&z__1, &a[j + k * a_dim1]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__2 = j + k * a_dim1;
+ d_cnjg(&z__1, &a[kp + j * a_dim1]);
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ i__2 = kp + j * a_dim1;
+ a[i__2].r = temp.r, a[i__2].i = temp.i;
+/* L70: */
+ }
+ i__1 = kp + k * a_dim1;
+ d_cnjg(&z__1, &a[kp + k * a_dim1]);
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = k + k * a_dim1;
+ temp.r = a[i__1].r, temp.i = a[i__1].i;
+ i__1 = k + k * a_dim1;
+ i__2 = kp + kp * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + kp * a_dim1;
+ a[i__1].r = temp.r, a[i__1].i = temp.i;
+ if (kstep == 2) {
+ i__1 = k + (k - 1) * a_dim1;
+ temp.r = a[i__1].r, temp.i = a[i__1].i;
+ i__1 = k + (k - 1) * a_dim1;
+ i__2 = kp + (k - 1) * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + (k - 1) * a_dim1;
+ a[i__1].r = temp.r, a[i__1].i = temp.i;
+ }
+ }
+
+ k -= kstep;
+ goto L60;
+L80:
+ ;
+ }
+
+ return 0;
+
+/* End of ZHETRI */
+
+} /* zhetri_ */
diff --git a/SRC/zhetrs.c b/SRC/zhetrs.c
new file mode 100644
index 0000000..ba56662
--- /dev/null
+++ b/SRC/zhetrs.c
@@ -0,0 +1,529 @@
+/* zhetrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zhetrs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b,
+ integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
+ doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer j, k;
+ doublereal s;
+ doublecomplex ak, bk;
+ integer kp;
+ doublecomplex akm1, bkm1, akm1k;
+ extern logical lsame_(char *, char *);
+ doublecomplex denom;
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int zgeru_(integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), xerbla_(char *, integer *), zdscal_(integer *, doublereal *, doublecomplex *,
+ integer *), zlacgv_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHETRS solves a system of linear equations A*X = B with a complex */
+/* Hermitian matrix A using the factorization A = U*D*U**H or */
+/* A = L*D*L**H computed by ZHETRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**H; */
+/* = 'L': Lower triangular, form is A = L*D*L**H. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by ZHETRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by ZHETRF. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHETRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B, where A = U*D*U'. */
+
+/* First solve U*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+L10:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L30;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &a[k * a_dim1 + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = k + k * a_dim1;
+ s = 1. / a[i__1].r;
+ zdscal_(nrhs, &s, &b[k + b_dim1], ldb);
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K-1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k - 1) {
+ zswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ i__1 = k - 2;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &a[k * a_dim1 + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+ i__1 = k - 2;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &a[(k - 1) * a_dim1 + 1], &c__1, &b[k
+ - 1 + b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = k - 1 + k * a_dim1;
+ akm1k.r = a[i__1].r, akm1k.i = a[i__1].i;
+ z_div(&z__1, &a[k - 1 + (k - 1) * a_dim1], &akm1k);
+ akm1.r = z__1.r, akm1.i = z__1.i;
+ d_cnjg(&z__2, &akm1k);
+ z_div(&z__1, &a[k + k * a_dim1], &z__2);
+ ak.r = z__1.r, ak.i = z__1.i;
+ z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i +
+ akm1.i * ak.r;
+ z__1.r = z__2.r - 1., z__1.i = z__2.i - 0.;
+ denom.r = z__1.r, denom.i = z__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ z_div(&z__1, &b[k - 1 + j * b_dim1], &akm1k);
+ bkm1.r = z__1.r, bkm1.i = z__1.i;
+ d_cnjg(&z__2, &akm1k);
+ z_div(&z__1, &b[k + j * b_dim1], &z__2);
+ bk.r = z__1.r, bk.i = z__1.i;
+ i__2 = k - 1 + j * b_dim1;
+ z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r *
+ bkm1.i + ak.i * bkm1.r;
+ z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i;
+ z_div(&z__1, &z__2, &denom);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + j * b_dim1;
+ z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r *
+ bk.i + akm1.i * bk.r;
+ z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i;
+ z_div(&z__1, &z__2, &denom);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L20: */
+ }
+ k += -2;
+ }
+
+ goto L10;
+L30:
+
+/* Next solve U'*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+L40:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L50;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(U'(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k > 1) {
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset]
+, ldb, &a[k * a_dim1 + 1], &c__1, &c_b1, &b[k +
+ b_dim1], ldb);
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ }
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ if (k > 1) {
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset]
+, ldb, &a[k * a_dim1 + 1], &c__1, &c_b1, &b[k +
+ b_dim1], ldb);
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+
+ zlacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset]
+, ldb, &a[(k + 1) * a_dim1 + 1], &c__1, &c_b1, &b[k +
+ 1 + b_dim1], ldb);
+ zlacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
+ }
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ k += 2;
+ }
+
+ goto L40;
+L50:
+
+ ;
+ } else {
+
+/* Solve A*X = B, where A = L*D*L'. */
+
+/* First solve L*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+L60:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L80;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &a[k + 1 + k * a_dim1], &c__1, &b[
+ k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = k + k * a_dim1;
+ s = 1. / a[i__1].r;
+ zdscal_(nrhs, &s, &b[k + b_dim1], ldb);
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K+1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k + 1) {
+ zswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ if (k < *n - 1) {
+ i__1 = *n - k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &a[k + 2 + k * a_dim1], &c__1, &b[
+ k + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &a[k + 2 + (k + 1) * a_dim1], &
+ c__1, &b[k + 1 + b_dim1], ldb, &b[k + 2 + b_dim1],
+ ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = k + 1 + k * a_dim1;
+ akm1k.r = a[i__1].r, akm1k.i = a[i__1].i;
+ d_cnjg(&z__2, &akm1k);
+ z_div(&z__1, &a[k + k * a_dim1], &z__2);
+ akm1.r = z__1.r, akm1.i = z__1.i;
+ z_div(&z__1, &a[k + 1 + (k + 1) * a_dim1], &akm1k);
+ ak.r = z__1.r, ak.i = z__1.i;
+ z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i +
+ akm1.i * ak.r;
+ z__1.r = z__2.r - 1., z__1.i = z__2.i - 0.;
+ denom.r = z__1.r, denom.i = z__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ d_cnjg(&z__2, &akm1k);
+ z_div(&z__1, &b[k + j * b_dim1], &z__2);
+ bkm1.r = z__1.r, bkm1.i = z__1.i;
+ z_div(&z__1, &b[k + 1 + j * b_dim1], &akm1k);
+ bk.r = z__1.r, bk.i = z__1.i;
+ i__2 = k + j * b_dim1;
+ z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r *
+ bkm1.i + ak.i * bkm1.r;
+ z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i;
+ z_div(&z__1, &z__2, &denom);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r *
+ bk.i + akm1.i * bk.r;
+ z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i;
+ z_div(&z__1, &z__2, &denom);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L70: */
+ }
+ k += 2;
+ }
+
+ goto L60;
+L80:
+
+/* Next solve L'*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+L90:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L100;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(L'(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 +
+ b_dim1], ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, &
+ b[k + b_dim1], ldb);
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ }
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ if (k < *n) {
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 +
+ b_dim1], ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, &
+ b[k + b_dim1], ldb);
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+
+ zlacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 +
+ b_dim1], ldb, &a[k + 1 + (k - 1) * a_dim1], &c__1, &
+ c_b1, &b[k - 1 + b_dim1], ldb);
+ zlacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
+ }
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ k += -2;
+ }
+
+ goto L90;
+L100:
+ ;
+ }
+
+ return 0;
+
+/* End of ZHETRS */
+
+} /* zhetrs_ */
diff --git a/SRC/zhfrk.c b/SRC/zhfrk.c
new file mode 100644
index 0000000..87f3043
--- /dev/null
+++ b/SRC/zhfrk.c
@@ -0,0 +1,531 @@
+/* zhfrk.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zhfrk_(char *transr, char *uplo, char *trans, integer *n,
+ integer *k, doublereal *alpha, doublecomplex *a, integer *lda,
+ doublereal *beta, doublecomplex *c__)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer j, n1, n2, nk, info;
+ doublecomplex cbeta;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zherk_(char *, char *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *);
+ integer nrowa;
+ logical lower;
+ doublecomplex calpha;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nisodd, notrans;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Level 3 BLAS like routine for C in RFP Format. */
+
+/* ZHFRK performs one of the Hermitian rank--k operations */
+
+/* C := alpha*A*conjg( A' ) + beta*C, */
+
+/* or */
+
+/* C := alpha*conjg( A' )*A + beta*C, */
+
+/* where alpha and beta are real scalars, C is an n--by--n Hermitian */
+/* matrix and A is an n--by--k matrix in the first case and a k--by--n */
+/* matrix in the second case. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANSR (input) CHARACTER. */
+/* = 'N': The Normal Form of RFP A is stored; */
+/* = 'C': The Conjugate-transpose Form of RFP A is stored. */
+
+/* UPLO - (input) CHARACTER. */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array C is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of C */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of C */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* TRANS - (input) CHARACTER. */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C. */
+
+/* TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C. */
+
+/* Unchanged on exit. */
+
+/* N - (input) INTEGER. */
+/* On entry, N specifies the order of the matrix C. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* K - (input) INTEGER. */
+/* On entry with TRANS = 'N' or 'n', K specifies the number */
+/* of columns of the matrix A, and on entry with */
+/* TRANS = 'C' or 'c', K specifies the number of rows of the */
+/* matrix A. K must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - (input) DOUBLE PRECISION. */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - (input) COMPLEX*16 array of DIMENSION ( LDA, ka ), where KA */
+/* is K when TRANS = 'N' or 'n', and is N otherwise. Before */
+/* entry with TRANS = 'N' or 'n', the leading N--by--K part of */
+/* the array A must contain the matrix A, otherwise the leading */
+/* K--by--N part of the array A must contain the matrix A. */
+/* Unchanged on exit. */
+
+/* LDA - (input) INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. When TRANS = 'N' or 'n' */
+/* then LDA must be at least max( 1, n ), otherwise LDA must */
+/* be at least max( 1, k ). */
+/* Unchanged on exit. */
+
+/* BETA - (input) DOUBLE PRECISION. */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+/* C - (input/output) COMPLEX*16 array, dimension ( N*(N+1)/2 ). */
+/* On entry, the matrix A in RFP Format. RFP Format is */
+/* described by TRANSR, UPLO and N. Note that the imaginary */
+/* parts of the diagonal elements need not be set, they are */
+/* assumed to be zero, and on exit they are set to zero. */
+
+/* Arguments */
+/* ========== */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --c__;
+
+ /* Function Body */
+ info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ notrans = lsame_(trans, "N");
+
+ if (notrans) {
+ nrowa = *n;
+ } else {
+ nrowa = *k;
+ }
+
+ if (! normaltransr && ! lsame_(transr, "C")) {
+ info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ info = -2;
+ } else if (! notrans && ! lsame_(trans, "C")) {
+ info = -3;
+ } else if (*n < 0) {
+ info = -4;
+ } else if (*k < 0) {
+ info = -5;
+ } else if (*lda < max(1,nrowa)) {
+ info = -8;
+ }
+ if (info != 0) {
+ i__1 = -info;
+ xerbla_("ZHFRK ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+/* The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not */
+/* done (it is in ZHERK for example) and left in the general case. */
+
+ if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
+ return 0;
+ }
+
+ if (*alpha == 0. && *beta == 0.) {
+ i__1 = *n * (*n + 1) / 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ c__[i__2].r = 0., c__[i__2].i = 0.;
+ }
+ return 0;
+ }
+
+ z__1.r = *alpha, z__1.i = 0.;
+ calpha.r = z__1.r, calpha.i = z__1.i;
+ z__1.r = *beta, z__1.i = 0.;
+ cbeta.r = z__1.r, cbeta.i = z__1.i;
+
+/* C is N-by-N. */
+/* If N is odd, set NISODD = .TRUE., and N1 and N2. */
+/* If N is even, NISODD = .FALSE., and NK. */
+
+ if (*n % 2 == 0) {
+ nisodd = FALSE_;
+ nk = *n / 2;
+ } else {
+ nisodd = TRUE_;
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+ }
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* N is odd, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' */
+
+ zherk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[1], n);
+ zherk_("U", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda,
+ beta, &c__[*n + 1], n);
+ zgemm_("N", "C", &n2, &n1, k, &calpha, &a[n1 + 1 + a_dim1]
+, lda, &a[a_dim1 + 1], lda, &cbeta, &c__[n1 + 1],
+ n);
+
+ } else {
+
+/* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'C' */
+
+ zherk_("L", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[1], n);
+ zherk_("U", "C", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1],
+ lda, beta, &c__[*n + 1], n)
+ ;
+ zgemm_("C", "N", &n2, &n1, k, &calpha, &a[(n1 + 1) *
+ a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, &
+ c__[n1 + 1], n);
+
+ }
+
+ } else {
+
+/* N is odd, TRANSR = 'N', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' */
+
+ zherk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[n2 + 1], n);
+ zherk_("U", "N", &n2, k, alpha, &a[n2 + a_dim1], lda,
+ beta, &c__[n1 + 1], n);
+ zgemm_("N", "C", &n1, &n2, k, &calpha, &a[a_dim1 + 1],
+ lda, &a[n2 + a_dim1], lda, &cbeta, &c__[1], n);
+
+ } else {
+
+/* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'C' */
+
+ zherk_("L", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[n2 + 1], n);
+ zherk_("U", "C", &n2, k, alpha, &a[n2 * a_dim1 + 1], lda,
+ beta, &c__[n1 + 1], n);
+ zgemm_("C", "N", &n1, &n2, k, &calpha, &a[a_dim1 + 1],
+ lda, &a[n2 * a_dim1 + 1], lda, &cbeta, &c__[1], n);
+
+ }
+
+ }
+
+ } else {
+
+/* N is odd, and TRANSR = 'C' */
+
+ if (lower) {
+
+/* N is odd, TRANSR = 'C', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'N' */
+
+ zherk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[1], &n1);
+ zherk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda,
+ beta, &c__[2], &n1);
+ zgemm_("N", "C", &n1, &n2, k, &calpha, &a[a_dim1 + 1],
+ lda, &a[n1 + 1 + a_dim1], lda, &cbeta, &c__[n1 *
+ n1 + 1], &n1);
+
+ } else {
+
+/* N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'C' */
+
+ zherk_("U", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[1], &n1);
+ zherk_("L", "C", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1],
+ lda, beta, &c__[2], &n1);
+ zgemm_("C", "N", &n1, &n2, k, &calpha, &a[a_dim1 + 1],
+ lda, &a[(n1 + 1) * a_dim1 + 1], lda, &cbeta, &c__[
+ n1 * n1 + 1], &n1);
+
+ }
+
+ } else {
+
+/* N is odd, TRANSR = 'C', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'N' */
+
+ zherk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[n2 * n2 + 1], &n2);
+ zherk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda,
+ beta, &c__[n1 * n2 + 1], &n2);
+ zgemm_("N", "C", &n2, &n1, k, &calpha, &a[n1 + 1 + a_dim1]
+, lda, &a[a_dim1 + 1], lda, &cbeta, &c__[1], &n2);
+
+ } else {
+
+/* N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'C' */
+
+ zherk_("U", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[n2 * n2 + 1], &n2);
+ zherk_("L", "C", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1],
+ lda, beta, &c__[n1 * n2 + 1], &n2);
+ zgemm_("C", "N", &n2, &n1, k, &calpha, &a[(n1 + 1) *
+ a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, &
+ c__[1], &n2);
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* N is even, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' */
+
+ i__1 = *n + 1;
+ zherk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[2], &i__1);
+ i__1 = *n + 1;
+ zherk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
+ beta, &c__[1], &i__1);
+ i__1 = *n + 1;
+ zgemm_("N", "C", &nk, &nk, k, &calpha, &a[nk + 1 + a_dim1]
+, lda, &a[a_dim1 + 1], lda, &cbeta, &c__[nk + 2],
+ &i__1);
+
+ } else {
+
+/* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'C' */
+
+ i__1 = *n + 1;
+ zherk_("L", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[2], &i__1);
+ i__1 = *n + 1;
+ zherk_("U", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
+ lda, beta, &c__[1], &i__1);
+ i__1 = *n + 1;
+ zgemm_("C", "N", &nk, &nk, k, &calpha, &a[(nk + 1) *
+ a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, &
+ c__[nk + 2], &i__1);
+
+ }
+
+ } else {
+
+/* N is even, TRANSR = 'N', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' */
+
+ i__1 = *n + 1;
+ zherk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk + 2], &i__1);
+ i__1 = *n + 1;
+ zherk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
+ beta, &c__[nk + 1], &i__1);
+ i__1 = *n + 1;
+ zgemm_("N", "C", &nk, &nk, k, &calpha, &a[a_dim1 + 1],
+ lda, &a[nk + 1 + a_dim1], lda, &cbeta, &c__[1], &
+ i__1);
+
+ } else {
+
+/* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'C' */
+
+ i__1 = *n + 1;
+ zherk_("L", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk + 2], &i__1);
+ i__1 = *n + 1;
+ zherk_("U", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
+ lda, beta, &c__[nk + 1], &i__1);
+ i__1 = *n + 1;
+ zgemm_("C", "N", &nk, &nk, k, &calpha, &a[a_dim1 + 1],
+ lda, &a[(nk + 1) * a_dim1 + 1], lda, &cbeta, &c__[
+ 1], &i__1);
+
+ }
+
+ }
+
+ } else {
+
+/* N is even, and TRANSR = 'C' */
+
+ if (lower) {
+
+/* N is even, TRANSR = 'C', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'N' */
+
+ zherk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk + 1], &nk);
+ zherk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
+ beta, &c__[1], &nk);
+ zgemm_("N", "C", &nk, &nk, k, &calpha, &a[a_dim1 + 1],
+ lda, &a[nk + 1 + a_dim1], lda, &cbeta, &c__[(nk +
+ 1) * nk + 1], &nk);
+
+ } else {
+
+/* N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'C' */
+
+ zherk_("U", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk + 1], &nk);
+ zherk_("L", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
+ lda, beta, &c__[1], &nk);
+ zgemm_("C", "N", &nk, &nk, k, &calpha, &a[a_dim1 + 1],
+ lda, &a[(nk + 1) * a_dim1 + 1], lda, &cbeta, &c__[
+ (nk + 1) * nk + 1], &nk);
+
+ }
+
+ } else {
+
+/* N is even, TRANSR = 'C', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'N' */
+
+ zherk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk * (nk + 1) + 1], &nk);
+ zherk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda,
+ beta, &c__[nk * nk + 1], &nk);
+ zgemm_("N", "C", &nk, &nk, k, &calpha, &a[nk + 1 + a_dim1]
+, lda, &a[a_dim1 + 1], lda, &cbeta, &c__[1], &nk);
+
+ } else {
+
+/* N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'C' */
+
+ zherk_("U", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta,
+ &c__[nk * (nk + 1) + 1], &nk);
+ zherk_("L", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1],
+ lda, beta, &c__[nk * nk + 1], &nk);
+ zgemm_("C", "N", &nk, &nk, k, &calpha, &a[(nk + 1) *
+ a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, &
+ c__[1], &nk);
+
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of ZHFRK */
+
+} /* zhfrk_ */
diff --git a/SRC/zhgeqz.c b/SRC/zhgeqz.c
new file mode 100644
index 0000000..7792559
--- /dev/null
+++ b/SRC/zhgeqz.c
@@ -0,0 +1,1149 @@
+/* zhgeqz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int zhgeqz_(char *job, char *compq, char *compz, integer *n,
+ integer *ilo, integer *ihi, doublecomplex *h__, integer *ldh,
+ doublecomplex *t, integer *ldt, doublecomplex *alpha, doublecomplex *
+ beta, doublecomplex *q, integer *ldq, doublecomplex *z__, integer *
+ ldz, doublecomplex *work, integer *lwork, doublereal *rwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, q_dim1, q_offset, t_dim1, t_offset, z_dim1,
+ z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6;
+ doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ double d_imag(doublecomplex *);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *), pow_zi(
+ doublecomplex *, doublecomplex *, integer *), z_sqrt(
+ doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ doublereal c__;
+ integer j;
+ doublecomplex s, t1;
+ integer jc, in;
+ doublecomplex u12;
+ integer jr;
+ doublecomplex ad11, ad12, ad21, ad22;
+ integer jch;
+ logical ilq, ilz;
+ doublereal ulp;
+ doublecomplex abi22;
+ doublereal absb, atol, btol, temp;
+ extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *);
+ doublereal temp2;
+ extern logical lsame_(char *, char *);
+ doublecomplex ctemp;
+ integer iiter, ilast, jiter;
+ doublereal anorm, bnorm;
+ integer maxit;
+ doublecomplex shift;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ doublereal tempr;
+ doublecomplex ctemp2, ctemp3;
+ logical ilazr2;
+ doublereal ascale, bscale;
+ extern doublereal dlamch_(char *);
+ doublecomplex signbc;
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublecomplex eshift;
+ logical ilschr;
+ integer icompq, ilastm;
+ doublecomplex rtdisc;
+ integer ischur;
+ extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *,
+ doublereal *);
+ logical ilazro;
+ integer icompz, ifirst;
+ extern /* Subroutine */ int zlartg_(doublecomplex *, doublecomplex *,
+ doublereal *, doublecomplex *, doublecomplex *);
+ integer ifrstm;
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+ integer istart;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHGEQZ computes the eigenvalues of a complex matrix pair (H,T), */
+/* where H is an upper Hessenberg matrix and T is upper triangular, */
+/* using the single-shift QZ method. */
+/* Matrix pairs of this type are produced by the reduction to */
+/* generalized upper Hessenberg form of a complex matrix pair (A,B): */
+
+/* A = Q1*H*Z1**H, B = Q1*T*Z1**H, */
+
+/* as computed by ZGGHRD. */
+
+/* If JOB='S', then the Hessenberg-triangular pair (H,T) is */
+/* also reduced to generalized Schur form, */
+
+/* H = Q*S*Z**H, T = Q*P*Z**H, */
+
+/* where Q and Z are unitary matrices and S and P are upper triangular. */
+
+/* Optionally, the unitary matrix Q from the generalized Schur */
+/* factorization may be postmultiplied into an input matrix Q1, and the */
+/* unitary matrix Z may be postmultiplied into an input matrix Z1. */
+/* If Q1 and Z1 are the unitary matrices from ZGGHRD that reduced */
+/* the matrix pair (A,B) to generalized Hessenberg form, then the output */
+/* matrices Q1*Q and Z1*Z are the unitary factors from the generalized */
+/* Schur factorization of (A,B): */
+
+/* A = (Q1*Q)*S*(Z1*Z)**H, B = (Q1*Q)*P*(Z1*Z)**H. */
+
+/* To avoid overflow, eigenvalues of the matrix pair (H,T) */
+/* (equivalently, of (A,B)) are computed as a pair of complex values */
+/* (alpha,beta). If beta is nonzero, lambda = alpha / beta is an */
+/* eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP) */
+/* A*x = lambda*B*x */
+/* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the */
+/* alternate form of the GNEP */
+/* mu*A*y = B*y. */
+/* The values of alpha and beta for the i-th eigenvalue can be read */
+/* directly from the generalized Schur form: alpha = S(i,i), */
+/* beta = P(i,i). */
+
+/* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix */
+/* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), */
+/* pp. 241--256. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* = 'E': Compute eigenvalues only; */
+/* = 'S': Computer eigenvalues and the Schur form. */
+
+/* COMPQ (input) CHARACTER*1 */
+/* = 'N': Left Schur vectors (Q) are not computed; */
+/* = 'I': Q is initialized to the unit matrix and the matrix Q */
+/* of left Schur vectors of (H,T) is returned; */
+/* = 'V': Q must contain a unitary matrix Q1 on entry and */
+/* the product Q1*Q is returned. */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': Right Schur vectors (Z) are not computed; */
+/* = 'I': Q is initialized to the unit matrix and the matrix Z */
+/* of right Schur vectors of (H,T) is returned; */
+/* = 'V': Z must contain a unitary matrix Z1 on entry and */
+/* the product Z1*Z is returned. */
+
+/* N (input) INTEGER */
+/* The order of the matrices H, T, Q, and Z. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* ILO and IHI mark the rows and columns of H which are in */
+/* Hessenberg form. It is assumed that A is already upper */
+/* triangular in rows and columns 1:ILO-1 and IHI+1:N. */
+/* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. */
+
+/* H (input/output) COMPLEX*16 array, dimension (LDH, N) */
+/* On entry, the N-by-N upper Hessenberg matrix H. */
+/* On exit, if JOB = 'S', H contains the upper triangular */
+/* matrix S from the generalized Schur factorization. */
+/* If JOB = 'E', the diagonal of H matches that of S, but */
+/* the rest of H is unspecified. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH >= max( 1, N ). */
+
+/* T (input/output) COMPLEX*16 array, dimension (LDT, N) */
+/* On entry, the N-by-N upper triangular matrix T. */
+/* On exit, if JOB = 'S', T contains the upper triangular */
+/* matrix P from the generalized Schur factorization. */
+/* If JOB = 'E', the diagonal of T matches that of P, but */
+/* the rest of T is unspecified. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= max( 1, N ). */
+
+/* ALPHA (output) COMPLEX*16 array, dimension (N) */
+/* The complex scalars alpha that define the eigenvalues of */
+/* GNEP. ALPHA(i) = S(i,i) in the generalized Schur */
+/* factorization. */
+
+/* BETA (output) COMPLEX*16 array, dimension (N) */
+/* The real non-negative scalars beta that define the */
+/* eigenvalues of GNEP. BETA(i) = P(i,i) in the generalized */
+/* Schur factorization. */
+
+/* Together, the quantities alpha = ALPHA(j) and beta = BETA(j) */
+/* represent the j-th eigenvalue of the matrix pair (A,B), in */
+/* one of the forms lambda = alpha/beta or mu = beta/alpha. */
+/* Since either lambda or mu may overflow, they should not, */
+/* in general, be computed. */
+
+/* Q (input/output) COMPLEX*16 array, dimension (LDQ, N) */
+/* On entry, if COMPZ = 'V', the unitary matrix Q1 used in the */
+/* reduction of (A,B) to generalized Hessenberg form. */
+/* On exit, if COMPZ = 'I', the unitary matrix of left Schur */
+/* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of */
+/* left Schur vectors of (A,B). */
+/* Not referenced if COMPZ = 'N'. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= 1. */
+/* If COMPQ='V' or 'I', then LDQ >= N. */
+
+/* Z (input/output) COMPLEX*16 array, dimension (LDZ, N) */
+/* On entry, if COMPZ = 'V', the unitary matrix Z1 used in the */
+/* reduction of (A,B) to generalized Hessenberg form. */
+/* On exit, if COMPZ = 'I', the unitary matrix of right Schur */
+/* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of */
+/* right Schur vectors of (A,B). */
+/* Not referenced if COMPZ = 'N'. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1. */
+/* If COMPZ='V' or 'I', then LDZ >= N. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+
+/* 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. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* = 1,...,N: the QZ iteration did not converge. (H,T) is not */
+/* in Schur form, but ALPHA(i) and BETA(i), */
+/* i=INFO+1,...,N should be correct. */
+/* = N+1,...,2*N: the shift calculation failed. (H,T) is not */
+/* in Schur form, but ALPHA(i) and BETA(i), */
+/* i=INFO-N+1,...,N should be correct. */
+
+/* Further Details */
+/* =============== */
+
+/* We assume that complex ABS works as long as its value is less than */
+/* overflow. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode JOB, COMPQ, COMPZ */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ --alpha;
+ --beta;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ if (lsame_(job, "E")) {
+ ilschr = FALSE_;
+ ischur = 1;
+ } else if (lsame_(job, "S")) {
+ ilschr = TRUE_;
+ ischur = 2;
+ } else {
+ ischur = 0;
+ }
+
+ if (lsame_(compq, "N")) {
+ ilq = FALSE_;
+ icompq = 1;
+ } else if (lsame_(compq, "V")) {
+ ilq = TRUE_;
+ icompq = 2;
+ } else if (lsame_(compq, "I")) {
+ ilq = TRUE_;
+ icompq = 3;
+ } else {
+ icompq = 0;
+ }
+
+ if (lsame_(compz, "N")) {
+ ilz = FALSE_;
+ icompz = 1;
+ } else if (lsame_(compz, "V")) {
+ ilz = TRUE_;
+ icompz = 2;
+ } else if (lsame_(compz, "I")) {
+ ilz = TRUE_;
+ icompz = 3;
+ } else {
+ icompz = 0;
+ }
+
+/* Check Argument Values */
+
+ *info = 0;
+ i__1 = max(1,*n);
+ work[1].r = (doublereal) i__1, work[1].i = 0.;
+ lquery = *lwork == -1;
+ if (ischur == 0) {
+ *info = -1;
+ } else if (icompq == 0) {
+ *info = -2;
+ } else if (icompz == 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ilo < 1) {
+ *info = -5;
+ } else if (*ihi > *n || *ihi < *ilo - 1) {
+ *info = -6;
+ } else if (*ldh < *n) {
+ *info = -8;
+ } else if (*ldt < *n) {
+ *info = -10;
+ } else if (*ldq < 1 || ilq && *ldq < *n) {
+ *info = -14;
+ } else if (*ldz < 1 || ilz && *ldz < *n) {
+ *info = -16;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -18;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHGEQZ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+/* WORK( 1 ) = CMPLX( 1 ) */
+ if (*n <= 0) {
+ work[1].r = 1., work[1].i = 0.;
+ return 0;
+ }
+
+/* Initialize Q and Z */
+
+ if (icompq == 3) {
+ zlaset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
+ }
+ if (icompz == 3) {
+ zlaset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
+ }
+
+/* Machine Constants */
+
+ in = *ihi + 1 - *ilo;
+ safmin = dlamch_("S");
+ ulp = dlamch_("E") * dlamch_("B");
+ anorm = zlanhs_("F", &in, &h__[*ilo + *ilo * h_dim1], ldh, &rwork[1]);
+ bnorm = zlanhs_("F", &in, &t[*ilo + *ilo * t_dim1], ldt, &rwork[1]);
+/* Computing MAX */
+ d__1 = safmin, d__2 = ulp * anorm;
+ atol = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = safmin, d__2 = ulp * bnorm;
+ btol = max(d__1,d__2);
+ ascale = 1. / max(safmin,anorm);
+ bscale = 1. / max(safmin,bnorm);
+
+
+/* Set Eigenvalues IHI+1:N */
+
+ i__1 = *n;
+ for (j = *ihi + 1; j <= i__1; ++j) {
+ absb = z_abs(&t[j + j * t_dim1]);
+ if (absb > safmin) {
+ i__2 = j + j * t_dim1;
+ z__2.r = t[i__2].r / absb, z__2.i = t[i__2].i / absb;
+ d_cnjg(&z__1, &z__2);
+ signbc.r = z__1.r, signbc.i = z__1.i;
+ i__2 = j + j * t_dim1;
+ t[i__2].r = absb, t[i__2].i = 0.;
+ if (ilschr) {
+ i__2 = j - 1;
+ zscal_(&i__2, &signbc, &t[j * t_dim1 + 1], &c__1);
+ zscal_(&j, &signbc, &h__[j * h_dim1 + 1], &c__1);
+ } else {
+ i__2 = j + j * h_dim1;
+ i__3 = j + j * h_dim1;
+ z__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i,
+ z__1.i = h__[i__3].r * signbc.i + h__[i__3].i *
+ signbc.r;
+ h__[i__2].r = z__1.r, h__[i__2].i = z__1.i;
+ }
+ if (ilz) {
+ zscal_(n, &signbc, &z__[j * z_dim1 + 1], &c__1);
+ }
+ } else {
+ i__2 = j + j * t_dim1;
+ t[i__2].r = 0., t[i__2].i = 0.;
+ }
+ i__2 = j;
+ i__3 = j + j * h_dim1;
+ alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
+ i__2 = j;
+ i__3 = j + j * t_dim1;
+ beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
+/* L10: */
+ }
+
+/* If IHI < ILO, skip QZ steps */
+
+ if (*ihi < *ilo) {
+ goto L190;
+ }
+
+/* MAIN QZ ITERATION LOOP */
+
+/* Initialize dynamic indices */
+
+/* Eigenvalues ILAST+1:N have been found. */
+/* Column operations modify rows IFRSTM:whatever */
+/* Row operations modify columns whatever:ILASTM */
+
+/* If only eigenvalues are being computed, then */
+/* IFRSTM is the row of the last splitting row above row ILAST; */
+/* this is always at least ILO. */
+/* IITER counts iterations since the last eigenvalue was found, */
+/* to tell when to use an extraordinary shift. */
+/* MAXIT is the maximum number of QZ sweeps allowed. */
+
+ ilast = *ihi;
+ if (ilschr) {
+ ifrstm = 1;
+ ilastm = *n;
+ } else {
+ ifrstm = *ilo;
+ ilastm = *ihi;
+ }
+ iiter = 0;
+ eshift.r = 0., eshift.i = 0.;
+ maxit = (*ihi - *ilo + 1) * 30;
+
+ i__1 = maxit;
+ for (jiter = 1; jiter <= i__1; ++jiter) {
+
+/* Check for too many iterations. */
+
+ if (jiter > maxit) {
+ goto L180;
+ }
+
+/* Split the matrix if possible. */
+
+/* Two tests: */
+/* 1: H(j,j-1)=0 or j=ILO */
+/* 2: T(j,j)=0 */
+
+/* Special case: j=ILAST */
+
+ if (ilast == *ilo) {
+ goto L60;
+ } else {
+ i__2 = ilast + (ilast - 1) * h_dim1;
+ if ((d__1 = h__[i__2].r, abs(d__1)) + (d__2 = d_imag(&h__[ilast +
+ (ilast - 1) * h_dim1]), abs(d__2)) <= atol) {
+ i__2 = ilast + (ilast - 1) * h_dim1;
+ h__[i__2].r = 0., h__[i__2].i = 0.;
+ goto L60;
+ }
+ }
+
+ if (z_abs(&t[ilast + ilast * t_dim1]) <= btol) {
+ i__2 = ilast + ilast * t_dim1;
+ t[i__2].r = 0., t[i__2].i = 0.;
+ goto L50;
+ }
+
+/* General case: j<ILAST */
+
+ i__2 = *ilo;
+ for (j = ilast - 1; j >= i__2; --j) {
+
+/* Test 1: for H(j,j-1)=0 or j=ILO */
+
+ if (j == *ilo) {
+ ilazro = TRUE_;
+ } else {
+ i__3 = j + (j - 1) * h_dim1;
+ if ((d__1 = h__[i__3].r, abs(d__1)) + (d__2 = d_imag(&h__[j +
+ (j - 1) * h_dim1]), abs(d__2)) <= atol) {
+ i__3 = j + (j - 1) * h_dim1;
+ h__[i__3].r = 0., h__[i__3].i = 0.;
+ ilazro = TRUE_;
+ } else {
+ ilazro = FALSE_;
+ }
+ }
+
+/* Test 2: for T(j,j)=0 */
+
+ if (z_abs(&t[j + j * t_dim1]) < btol) {
+ i__3 = j + j * t_dim1;
+ t[i__3].r = 0., t[i__3].i = 0.;
+
+/* Test 1a: Check for 2 consecutive small subdiagonals in A */
+
+ ilazr2 = FALSE_;
+ if (! ilazro) {
+ i__3 = j + (j - 1) * h_dim1;
+ i__4 = j + 1 + j * h_dim1;
+ i__5 = j + j * h_dim1;
+ if (((d__1 = h__[i__3].r, abs(d__1)) + (d__2 = d_imag(&
+ h__[j + (j - 1) * h_dim1]), abs(d__2))) * (ascale
+ * ((d__3 = h__[i__4].r, abs(d__3)) + (d__4 =
+ d_imag(&h__[j + 1 + j * h_dim1]), abs(d__4)))) <=
+ ((d__5 = h__[i__5].r, abs(d__5)) + (d__6 = d_imag(
+ &h__[j + j * h_dim1]), abs(d__6))) * (ascale *
+ atol)) {
+ ilazr2 = TRUE_;
+ }
+ }
+
+/* If both tests pass (1 & 2), i.e., the leading diagonal */
+/* element of B in the block is zero, split a 1x1 block off */
+/* at the top. (I.e., at the J-th row/column) The leading */
+/* diagonal element of the remainder can also be zero, so */
+/* this may have to be done repeatedly. */
+
+ if (ilazro || ilazr2) {
+ i__3 = ilast - 1;
+ for (jch = j; jch <= i__3; ++jch) {
+ i__4 = jch + jch * h_dim1;
+ ctemp.r = h__[i__4].r, ctemp.i = h__[i__4].i;
+ zlartg_(&ctemp, &h__[jch + 1 + jch * h_dim1], &c__, &
+ s, &h__[jch + jch * h_dim1]);
+ i__4 = jch + 1 + jch * h_dim1;
+ h__[i__4].r = 0., h__[i__4].i = 0.;
+ i__4 = ilastm - jch;
+ zrot_(&i__4, &h__[jch + (jch + 1) * h_dim1], ldh, &
+ h__[jch + 1 + (jch + 1) * h_dim1], ldh, &c__,
+ &s);
+ i__4 = ilastm - jch;
+ zrot_(&i__4, &t[jch + (jch + 1) * t_dim1], ldt, &t[
+ jch + 1 + (jch + 1) * t_dim1], ldt, &c__, &s);
+ if (ilq) {
+ d_cnjg(&z__1, &s);
+ zrot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1)
+ * q_dim1 + 1], &c__1, &c__, &z__1);
+ }
+ if (ilazr2) {
+ i__4 = jch + (jch - 1) * h_dim1;
+ i__5 = jch + (jch - 1) * h_dim1;
+ z__1.r = c__ * h__[i__5].r, z__1.i = c__ * h__[
+ i__5].i;
+ h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
+ }
+ ilazr2 = FALSE_;
+ i__4 = jch + 1 + (jch + 1) * t_dim1;
+ if ((d__1 = t[i__4].r, abs(d__1)) + (d__2 = d_imag(&t[
+ jch + 1 + (jch + 1) * t_dim1]), abs(d__2)) >=
+ btol) {
+ if (jch + 1 >= ilast) {
+ goto L60;
+ } else {
+ ifirst = jch + 1;
+ goto L70;
+ }
+ }
+ i__4 = jch + 1 + (jch + 1) * t_dim1;
+ t[i__4].r = 0., t[i__4].i = 0.;
+/* L20: */
+ }
+ goto L50;
+ } else {
+
+/* Only test 2 passed -- chase the zero to T(ILAST,ILAST) */
+/* Then process as in the case T(ILAST,ILAST)=0 */
+
+ i__3 = ilast - 1;
+ for (jch = j; jch <= i__3; ++jch) {
+ i__4 = jch + (jch + 1) * t_dim1;
+ ctemp.r = t[i__4].r, ctemp.i = t[i__4].i;
+ zlartg_(&ctemp, &t[jch + 1 + (jch + 1) * t_dim1], &
+ c__, &s, &t[jch + (jch + 1) * t_dim1]);
+ i__4 = jch + 1 + (jch + 1) * t_dim1;
+ t[i__4].r = 0., t[i__4].i = 0.;
+ if (jch < ilastm - 1) {
+ i__4 = ilastm - jch - 1;
+ zrot_(&i__4, &t[jch + (jch + 2) * t_dim1], ldt, &
+ t[jch + 1 + (jch + 2) * t_dim1], ldt, &
+ c__, &s);
+ }
+ i__4 = ilastm - jch + 2;
+ zrot_(&i__4, &h__[jch + (jch - 1) * h_dim1], ldh, &
+ h__[jch + 1 + (jch - 1) * h_dim1], ldh, &c__,
+ &s);
+ if (ilq) {
+ d_cnjg(&z__1, &s);
+ zrot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1)
+ * q_dim1 + 1], &c__1, &c__, &z__1);
+ }
+ i__4 = jch + 1 + jch * h_dim1;
+ ctemp.r = h__[i__4].r, ctemp.i = h__[i__4].i;
+ zlartg_(&ctemp, &h__[jch + 1 + (jch - 1) * h_dim1], &
+ c__, &s, &h__[jch + 1 + jch * h_dim1]);
+ i__4 = jch + 1 + (jch - 1) * h_dim1;
+ h__[i__4].r = 0., h__[i__4].i = 0.;
+ i__4 = jch + 1 - ifrstm;
+ zrot_(&i__4, &h__[ifrstm + jch * h_dim1], &c__1, &h__[
+ ifrstm + (jch - 1) * h_dim1], &c__1, &c__, &s)
+ ;
+ i__4 = jch - ifrstm;
+ zrot_(&i__4, &t[ifrstm + jch * t_dim1], &c__1, &t[
+ ifrstm + (jch - 1) * t_dim1], &c__1, &c__, &s)
+ ;
+ if (ilz) {
+ zrot_(n, &z__[jch * z_dim1 + 1], &c__1, &z__[(jch
+ - 1) * z_dim1 + 1], &c__1, &c__, &s);
+ }
+/* L30: */
+ }
+ goto L50;
+ }
+ } else if (ilazro) {
+
+/* Only test 1 passed -- work on J:ILAST */
+
+ ifirst = j;
+ goto L70;
+ }
+
+/* Neither test passed -- try next J */
+
+/* L40: */
+ }
+
+/* (Drop-through is "impossible") */
+
+ *info = (*n << 1) + 1;
+ goto L210;
+
+/* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a */
+/* 1x1 block. */
+
+L50:
+ i__2 = ilast + ilast * h_dim1;
+ ctemp.r = h__[i__2].r, ctemp.i = h__[i__2].i;
+ zlartg_(&ctemp, &h__[ilast + (ilast - 1) * h_dim1], &c__, &s, &h__[
+ ilast + ilast * h_dim1]);
+ i__2 = ilast + (ilast - 1) * h_dim1;
+ h__[i__2].r = 0., h__[i__2].i = 0.;
+ i__2 = ilast - ifrstm;
+ zrot_(&i__2, &h__[ifrstm + ilast * h_dim1], &c__1, &h__[ifrstm + (
+ ilast - 1) * h_dim1], &c__1, &c__, &s);
+ i__2 = ilast - ifrstm;
+ zrot_(&i__2, &t[ifrstm + ilast * t_dim1], &c__1, &t[ifrstm + (ilast -
+ 1) * t_dim1], &c__1, &c__, &s);
+ if (ilz) {
+ zrot_(n, &z__[ilast * z_dim1 + 1], &c__1, &z__[(ilast - 1) *
+ z_dim1 + 1], &c__1, &c__, &s);
+ }
+
+/* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA */
+
+L60:
+ absb = z_abs(&t[ilast + ilast * t_dim1]);
+ if (absb > safmin) {
+ i__2 = ilast + ilast * t_dim1;
+ z__2.r = t[i__2].r / absb, z__2.i = t[i__2].i / absb;
+ d_cnjg(&z__1, &z__2);
+ signbc.r = z__1.r, signbc.i = z__1.i;
+ i__2 = ilast + ilast * t_dim1;
+ t[i__2].r = absb, t[i__2].i = 0.;
+ if (ilschr) {
+ i__2 = ilast - ifrstm;
+ zscal_(&i__2, &signbc, &t[ifrstm + ilast * t_dim1], &c__1);
+ i__2 = ilast + 1 - ifrstm;
+ zscal_(&i__2, &signbc, &h__[ifrstm + ilast * h_dim1], &c__1);
+ } else {
+ i__2 = ilast + ilast * h_dim1;
+ i__3 = ilast + ilast * h_dim1;
+ z__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i,
+ z__1.i = h__[i__3].r * signbc.i + h__[i__3].i *
+ signbc.r;
+ h__[i__2].r = z__1.r, h__[i__2].i = z__1.i;
+ }
+ if (ilz) {
+ zscal_(n, &signbc, &z__[ilast * z_dim1 + 1], &c__1);
+ }
+ } else {
+ i__2 = ilast + ilast * t_dim1;
+ t[i__2].r = 0., t[i__2].i = 0.;
+ }
+ i__2 = ilast;
+ i__3 = ilast + ilast * h_dim1;
+ alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
+ i__2 = ilast;
+ i__3 = ilast + ilast * t_dim1;
+ beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
+
+/* Go to next block -- exit if finished. */
+
+ --ilast;
+ if (ilast < *ilo) {
+ goto L190;
+ }
+
+/* Reset counters */
+
+ iiter = 0;
+ eshift.r = 0., eshift.i = 0.;
+ if (! ilschr) {
+ ilastm = ilast;
+ if (ifrstm > ilast) {
+ ifrstm = *ilo;
+ }
+ }
+ goto L160;
+
+/* QZ step */
+
+/* This iteration only involves rows/columns IFIRST:ILAST. We */
+/* assume IFIRST < ILAST, and that the diagonal of B is non-zero. */
+
+L70:
+ ++iiter;
+ if (! ilschr) {
+ ifrstm = ifirst;
+ }
+
+/* Compute the Shift. */
+
+/* At this point, IFIRST < ILAST, and the diagonal elements of */
+/* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in */
+/* magnitude) */
+
+ if (iiter / 10 * 10 != iiter) {
+
+/* The Wilkinson shift (AEP p.512), i.e., the eigenvalue of */
+/* the bottom-right 2x2 block of A inv(B) which is nearest to */
+/* the bottom-right element. */
+
+/* We factor B as U*D, where U has unit diagonals, and */
+/* compute (A*inv(D))*inv(U). */
+
+ i__2 = ilast - 1 + ilast * t_dim1;
+ z__2.r = bscale * t[i__2].r, z__2.i = bscale * t[i__2].i;
+ i__3 = ilast + ilast * t_dim1;
+ z__3.r = bscale * t[i__3].r, z__3.i = bscale * t[i__3].i;
+ z_div(&z__1, &z__2, &z__3);
+ u12.r = z__1.r, u12.i = z__1.i;
+ i__2 = ilast - 1 + (ilast - 1) * h_dim1;
+ z__2.r = ascale * h__[i__2].r, z__2.i = ascale * h__[i__2].i;
+ i__3 = ilast - 1 + (ilast - 1) * t_dim1;
+ z__3.r = bscale * t[i__3].r, z__3.i = bscale * t[i__3].i;
+ z_div(&z__1, &z__2, &z__3);
+ ad11.r = z__1.r, ad11.i = z__1.i;
+ i__2 = ilast + (ilast - 1) * h_dim1;
+ z__2.r = ascale * h__[i__2].r, z__2.i = ascale * h__[i__2].i;
+ i__3 = ilast - 1 + (ilast - 1) * t_dim1;
+ z__3.r = bscale * t[i__3].r, z__3.i = bscale * t[i__3].i;
+ z_div(&z__1, &z__2, &z__3);
+ ad21.r = z__1.r, ad21.i = z__1.i;
+ i__2 = ilast - 1 + ilast * h_dim1;
+ z__2.r = ascale * h__[i__2].r, z__2.i = ascale * h__[i__2].i;
+ i__3 = ilast + ilast * t_dim1;
+ z__3.r = bscale * t[i__3].r, z__3.i = bscale * t[i__3].i;
+ z_div(&z__1, &z__2, &z__3);
+ ad12.r = z__1.r, ad12.i = z__1.i;
+ i__2 = ilast + ilast * h_dim1;
+ z__2.r = ascale * h__[i__2].r, z__2.i = ascale * h__[i__2].i;
+ i__3 = ilast + ilast * t_dim1;
+ z__3.r = bscale * t[i__3].r, z__3.i = bscale * t[i__3].i;
+ z_div(&z__1, &z__2, &z__3);
+ ad22.r = z__1.r, ad22.i = z__1.i;
+ z__2.r = u12.r * ad21.r - u12.i * ad21.i, z__2.i = u12.r * ad21.i
+ + u12.i * ad21.r;
+ z__1.r = ad22.r - z__2.r, z__1.i = ad22.i - z__2.i;
+ abi22.r = z__1.r, abi22.i = z__1.i;
+
+ z__2.r = ad11.r + abi22.r, z__2.i = ad11.i + abi22.i;
+ z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
+ t1.r = z__1.r, t1.i = z__1.i;
+ pow_zi(&z__4, &t1, &c__2);
+ z__5.r = ad12.r * ad21.r - ad12.i * ad21.i, z__5.i = ad12.r *
+ ad21.i + ad12.i * ad21.r;
+ z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
+ z__6.r = ad11.r * ad22.r - ad11.i * ad22.i, z__6.i = ad11.r *
+ ad22.i + ad11.i * ad22.r;
+ z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
+ z_sqrt(&z__1, &z__2);
+ rtdisc.r = z__1.r, rtdisc.i = z__1.i;
+ z__1.r = t1.r - abi22.r, z__1.i = t1.i - abi22.i;
+ z__2.r = t1.r - abi22.r, z__2.i = t1.i - abi22.i;
+ temp = z__1.r * rtdisc.r + d_imag(&z__2) * d_imag(&rtdisc);
+ if (temp <= 0.) {
+ z__1.r = t1.r + rtdisc.r, z__1.i = t1.i + rtdisc.i;
+ shift.r = z__1.r, shift.i = z__1.i;
+ } else {
+ z__1.r = t1.r - rtdisc.r, z__1.i = t1.i - rtdisc.i;
+ shift.r = z__1.r, shift.i = z__1.i;
+ }
+ } else {
+
+/* Exceptional shift. Chosen for no particularly good reason. */
+
+ i__2 = ilast - 1 + ilast * h_dim1;
+ z__4.r = ascale * h__[i__2].r, z__4.i = ascale * h__[i__2].i;
+ i__3 = ilast - 1 + (ilast - 1) * t_dim1;
+ z__5.r = bscale * t[i__3].r, z__5.i = bscale * t[i__3].i;
+ z_div(&z__3, &z__4, &z__5);
+ d_cnjg(&z__2, &z__3);
+ z__1.r = eshift.r + z__2.r, z__1.i = eshift.i + z__2.i;
+ eshift.r = z__1.r, eshift.i = z__1.i;
+ shift.r = eshift.r, shift.i = eshift.i;
+ }
+
+/* Now check for two consecutive small subdiagonals. */
+
+ i__2 = ifirst + 1;
+ for (j = ilast - 1; j >= i__2; --j) {
+ istart = j;
+ i__3 = j + j * h_dim1;
+ z__2.r = ascale * h__[i__3].r, z__2.i = ascale * h__[i__3].i;
+ i__4 = j + j * t_dim1;
+ z__4.r = bscale * t[i__4].r, z__4.i = bscale * t[i__4].i;
+ z__3.r = shift.r * z__4.r - shift.i * z__4.i, z__3.i = shift.r *
+ z__4.i + shift.i * z__4.r;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ temp = (d__1 = ctemp.r, abs(d__1)) + (d__2 = d_imag(&ctemp), abs(
+ d__2));
+ i__3 = j + 1 + j * h_dim1;
+ temp2 = ascale * ((d__1 = h__[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&h__[j + 1 + j * h_dim1]), abs(d__2)));
+ tempr = max(temp,temp2);
+ if (tempr < 1. && tempr != 0.) {
+ temp /= tempr;
+ temp2 /= tempr;
+ }
+ i__3 = j + (j - 1) * h_dim1;
+ if (((d__1 = h__[i__3].r, abs(d__1)) + (d__2 = d_imag(&h__[j + (j
+ - 1) * h_dim1]), abs(d__2))) * temp2 <= temp * atol) {
+ goto L90;
+ }
+/* L80: */
+ }
+
+ istart = ifirst;
+ i__2 = ifirst + ifirst * h_dim1;
+ z__2.r = ascale * h__[i__2].r, z__2.i = ascale * h__[i__2].i;
+ i__3 = ifirst + ifirst * t_dim1;
+ z__4.r = bscale * t[i__3].r, z__4.i = bscale * t[i__3].i;
+ z__3.r = shift.r * z__4.r - shift.i * z__4.i, z__3.i = shift.r *
+ z__4.i + shift.i * z__4.r;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+L90:
+
+/* Do an implicit-shift QZ sweep. */
+
+/* Initial Q */
+
+ i__2 = istart + 1 + istart * h_dim1;
+ z__1.r = ascale * h__[i__2].r, z__1.i = ascale * h__[i__2].i;
+ ctemp2.r = z__1.r, ctemp2.i = z__1.i;
+ zlartg_(&ctemp, &ctemp2, &c__, &s, &ctemp3);
+
+/* Sweep */
+
+ i__2 = ilast - 1;
+ for (j = istart; j <= i__2; ++j) {
+ if (j > istart) {
+ i__3 = j + (j - 1) * h_dim1;
+ ctemp.r = h__[i__3].r, ctemp.i = h__[i__3].i;
+ zlartg_(&ctemp, &h__[j + 1 + (j - 1) * h_dim1], &c__, &s, &
+ h__[j + (j - 1) * h_dim1]);
+ i__3 = j + 1 + (j - 1) * h_dim1;
+ h__[i__3].r = 0., h__[i__3].i = 0.;
+ }
+
+ i__3 = ilastm;
+ for (jc = j; jc <= i__3; ++jc) {
+ i__4 = j + jc * h_dim1;
+ z__2.r = c__ * h__[i__4].r, z__2.i = c__ * h__[i__4].i;
+ i__5 = j + 1 + jc * h_dim1;
+ z__3.r = s.r * h__[i__5].r - s.i * h__[i__5].i, z__3.i = s.r *
+ h__[i__5].i + s.i * h__[i__5].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__4 = j + 1 + jc * h_dim1;
+ d_cnjg(&z__4, &s);
+ z__3.r = -z__4.r, z__3.i = -z__4.i;
+ i__5 = j + jc * h_dim1;
+ z__2.r = z__3.r * h__[i__5].r - z__3.i * h__[i__5].i, z__2.i =
+ z__3.r * h__[i__5].i + z__3.i * h__[i__5].r;
+ i__6 = j + 1 + jc * h_dim1;
+ z__5.r = c__ * h__[i__6].r, z__5.i = c__ * h__[i__6].i;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+ h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
+ i__4 = j + jc * h_dim1;
+ h__[i__4].r = ctemp.r, h__[i__4].i = ctemp.i;
+ i__4 = j + jc * t_dim1;
+ z__2.r = c__ * t[i__4].r, z__2.i = c__ * t[i__4].i;
+ i__5 = j + 1 + jc * t_dim1;
+ z__3.r = s.r * t[i__5].r - s.i * t[i__5].i, z__3.i = s.r * t[
+ i__5].i + s.i * t[i__5].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ ctemp2.r = z__1.r, ctemp2.i = z__1.i;
+ i__4 = j + 1 + jc * t_dim1;
+ d_cnjg(&z__4, &s);
+ z__3.r = -z__4.r, z__3.i = -z__4.i;
+ i__5 = j + jc * t_dim1;
+ z__2.r = z__3.r * t[i__5].r - z__3.i * t[i__5].i, z__2.i =
+ z__3.r * t[i__5].i + z__3.i * t[i__5].r;
+ i__6 = j + 1 + jc * t_dim1;
+ z__5.r = c__ * t[i__6].r, z__5.i = c__ * t[i__6].i;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+ t[i__4].r = z__1.r, t[i__4].i = z__1.i;
+ i__4 = j + jc * t_dim1;
+ t[i__4].r = ctemp2.r, t[i__4].i = ctemp2.i;
+/* L100: */
+ }
+ if (ilq) {
+ i__3 = *n;
+ for (jr = 1; jr <= i__3; ++jr) {
+ i__4 = jr + j * q_dim1;
+ z__2.r = c__ * q[i__4].r, z__2.i = c__ * q[i__4].i;
+ d_cnjg(&z__4, &s);
+ i__5 = jr + (j + 1) * q_dim1;
+ z__3.r = z__4.r * q[i__5].r - z__4.i * q[i__5].i, z__3.i =
+ z__4.r * q[i__5].i + z__4.i * q[i__5].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__4 = jr + (j + 1) * q_dim1;
+ z__3.r = -s.r, z__3.i = -s.i;
+ i__5 = jr + j * q_dim1;
+ z__2.r = z__3.r * q[i__5].r - z__3.i * q[i__5].i, z__2.i =
+ z__3.r * q[i__5].i + z__3.i * q[i__5].r;
+ i__6 = jr + (j + 1) * q_dim1;
+ z__4.r = c__ * q[i__6].r, z__4.i = c__ * q[i__6].i;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ q[i__4].r = z__1.r, q[i__4].i = z__1.i;
+ i__4 = jr + j * q_dim1;
+ q[i__4].r = ctemp.r, q[i__4].i = ctemp.i;
+/* L110: */
+ }
+ }
+
+ i__3 = j + 1 + (j + 1) * t_dim1;
+ ctemp.r = t[i__3].r, ctemp.i = t[i__3].i;
+ zlartg_(&ctemp, &t[j + 1 + j * t_dim1], &c__, &s, &t[j + 1 + (j +
+ 1) * t_dim1]);
+ i__3 = j + 1 + j * t_dim1;
+ t[i__3].r = 0., t[i__3].i = 0.;
+
+/* Computing MIN */
+ i__4 = j + 2;
+ i__3 = min(i__4,ilast);
+ for (jr = ifrstm; jr <= i__3; ++jr) {
+ i__4 = jr + (j + 1) * h_dim1;
+ z__2.r = c__ * h__[i__4].r, z__2.i = c__ * h__[i__4].i;
+ i__5 = jr + j * h_dim1;
+ z__3.r = s.r * h__[i__5].r - s.i * h__[i__5].i, z__3.i = s.r *
+ h__[i__5].i + s.i * h__[i__5].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__4 = jr + j * h_dim1;
+ d_cnjg(&z__4, &s);
+ z__3.r = -z__4.r, z__3.i = -z__4.i;
+ i__5 = jr + (j + 1) * h_dim1;
+ z__2.r = z__3.r * h__[i__5].r - z__3.i * h__[i__5].i, z__2.i =
+ z__3.r * h__[i__5].i + z__3.i * h__[i__5].r;
+ i__6 = jr + j * h_dim1;
+ z__5.r = c__ * h__[i__6].r, z__5.i = c__ * h__[i__6].i;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+ h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
+ i__4 = jr + (j + 1) * h_dim1;
+ h__[i__4].r = ctemp.r, h__[i__4].i = ctemp.i;
+/* L120: */
+ }
+ i__3 = j;
+ for (jr = ifrstm; jr <= i__3; ++jr) {
+ i__4 = jr + (j + 1) * t_dim1;
+ z__2.r = c__ * t[i__4].r, z__2.i = c__ * t[i__4].i;
+ i__5 = jr + j * t_dim1;
+ z__3.r = s.r * t[i__5].r - s.i * t[i__5].i, z__3.i = s.r * t[
+ i__5].i + s.i * t[i__5].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__4 = jr + j * t_dim1;
+ d_cnjg(&z__4, &s);
+ z__3.r = -z__4.r, z__3.i = -z__4.i;
+ i__5 = jr + (j + 1) * t_dim1;
+ z__2.r = z__3.r * t[i__5].r - z__3.i * t[i__5].i, z__2.i =
+ z__3.r * t[i__5].i + z__3.i * t[i__5].r;
+ i__6 = jr + j * t_dim1;
+ z__5.r = c__ * t[i__6].r, z__5.i = c__ * t[i__6].i;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+ t[i__4].r = z__1.r, t[i__4].i = z__1.i;
+ i__4 = jr + (j + 1) * t_dim1;
+ t[i__4].r = ctemp.r, t[i__4].i = ctemp.i;
+/* L130: */
+ }
+ if (ilz) {
+ i__3 = *n;
+ for (jr = 1; jr <= i__3; ++jr) {
+ i__4 = jr + (j + 1) * z_dim1;
+ z__2.r = c__ * z__[i__4].r, z__2.i = c__ * z__[i__4].i;
+ i__5 = jr + j * z_dim1;
+ z__3.r = s.r * z__[i__5].r - s.i * z__[i__5].i, z__3.i =
+ s.r * z__[i__5].i + s.i * z__[i__5].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__4 = jr + j * z_dim1;
+ d_cnjg(&z__4, &s);
+ z__3.r = -z__4.r, z__3.i = -z__4.i;
+ i__5 = jr + (j + 1) * z_dim1;
+ z__2.r = z__3.r * z__[i__5].r - z__3.i * z__[i__5].i,
+ z__2.i = z__3.r * z__[i__5].i + z__3.i * z__[i__5]
+ .r;
+ i__6 = jr + j * z_dim1;
+ z__5.r = c__ * z__[i__6].r, z__5.i = c__ * z__[i__6].i;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+ z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
+ i__4 = jr + (j + 1) * z_dim1;
+ z__[i__4].r = ctemp.r, z__[i__4].i = ctemp.i;
+/* L140: */
+ }
+ }
+/* L150: */
+ }
+
+L160:
+
+/* L170: */
+ ;
+ }
+
+/* Drop-through = non-convergence */
+
+L180:
+ *info = ilast;
+ goto L210;
+
+/* Successful completion of all QZ steps */
+
+L190:
+
+/* Set Eigenvalues 1:ILO-1 */
+
+ i__1 = *ilo - 1;
+ for (j = 1; j <= i__1; ++j) {
+ absb = z_abs(&t[j + j * t_dim1]);
+ if (absb > safmin) {
+ i__2 = j + j * t_dim1;
+ z__2.r = t[i__2].r / absb, z__2.i = t[i__2].i / absb;
+ d_cnjg(&z__1, &z__2);
+ signbc.r = z__1.r, signbc.i = z__1.i;
+ i__2 = j + j * t_dim1;
+ t[i__2].r = absb, t[i__2].i = 0.;
+ if (ilschr) {
+ i__2 = j - 1;
+ zscal_(&i__2, &signbc, &t[j * t_dim1 + 1], &c__1);
+ zscal_(&j, &signbc, &h__[j * h_dim1 + 1], &c__1);
+ } else {
+ i__2 = j + j * h_dim1;
+ i__3 = j + j * h_dim1;
+ z__1.r = h__[i__3].r * signbc.r - h__[i__3].i * signbc.i,
+ z__1.i = h__[i__3].r * signbc.i + h__[i__3].i *
+ signbc.r;
+ h__[i__2].r = z__1.r, h__[i__2].i = z__1.i;
+ }
+ if (ilz) {
+ zscal_(n, &signbc, &z__[j * z_dim1 + 1], &c__1);
+ }
+ } else {
+ i__2 = j + j * t_dim1;
+ t[i__2].r = 0., t[i__2].i = 0.;
+ }
+ i__2 = j;
+ i__3 = j + j * h_dim1;
+ alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i;
+ i__2 = j;
+ i__3 = j + j * t_dim1;
+ beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i;
+/* L200: */
+ }
+
+/* Normal Termination */
+
+ *info = 0;
+
+/* Exit (other than argument error) -- return optimal workspace size */
+
+L210:
+ z__1.r = (doublereal) (*n), z__1.i = 0.;
+ work[1].r = z__1.r, work[1].i = z__1.i;
+ return 0;
+
+/* End of ZHGEQZ */
+
+} /* zhgeqz_ */
diff --git a/SRC/zhpcon.c b/SRC/zhpcon.c
new file mode 100644
index 0000000..e95fe20
--- /dev/null
+++ b/SRC/zhpcon.c
@@ -0,0 +1,197 @@
+/* zhpcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zhpcon_(char *uplo, integer *n, doublecomplex *ap,
+ integer *ipiv, doublereal *anorm, doublereal *rcond, doublecomplex *
+ work, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, ip, kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *), xerbla_(
+ char *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int zhptrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHPCON estimates the reciprocal of the condition number of a complex */
+/* Hermitian packed matrix A using the factorization A = U*D*U**H or */
+/* A = L*D*L**H computed by ZHPTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**H; */
+/* = 'L': Lower triangular, form is A = L*D*L**H. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by ZHPTRF, stored as a */
+/* packed triangular matrix. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by ZHPTRF. */
+
+/* ANORM (input) DOUBLE PRECISION */
+/* The 1-norm of the original matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --work;
+ --ipiv;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*anorm < 0.) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHPCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.;
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ } else if (*anorm <= 0.) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ ip = *n * (*n + 1) / 2;
+ for (i__ = *n; i__ >= 1; --i__) {
+ i__1 = ip;
+ if (ipiv[i__] > 0 && (ap[i__1].r == 0. && ap[i__1].i == 0.)) {
+ return 0;
+ }
+ ip -= i__;
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ ip = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ip;
+ if (ipiv[i__] > 0 && (ap[i__2].r == 0. && ap[i__2].i == 0.)) {
+ return 0;
+ }
+ ip = ip + *n - i__ + 1;
+/* L20: */
+ }
+ }
+
+/* Estimate the 1-norm of the inverse. */
+
+ kase = 0;
+L30:
+ zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+
+/* Multiply by inv(L*D*L') or inv(U*D*U'). */
+
+ zhptrs_(uplo, n, &c__1, &ap[1], &ipiv[1], &work[1], n, info);
+ goto L30;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / ainvnm / *anorm;
+ }
+
+ return 0;
+
+/* End of ZHPCON */
+
+} /* zhpcon_ */
diff --git a/SRC/zhpev.c b/SRC/zhpev.c
new file mode 100644
index 0000000..49193c8
--- /dev/null
+++ b/SRC/zhpev.c
@@ -0,0 +1,254 @@
+/* zhpev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zhpev_(char *jobz, char *uplo, integer *n, doublecomplex
+ *ap, doublereal *w, doublecomplex *z__, integer *ldz, doublecomplex *
+ work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal eps;
+ integer inde;
+ doublereal anrm;
+ integer imax;
+ doublereal rmin, rmax;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical wantz;
+ extern doublereal dlamch_(char *);
+ integer iscale;
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
+ integer *, doublereal *, doublecomplex *, integer *);
+ doublereal bignum;
+ integer indtau;
+ extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern doublereal zlanhp_(char *, char *, integer *, doublecomplex *,
+ doublereal *);
+ integer indrwk, indwrk;
+ doublereal smlnum;
+ extern /* Subroutine */ int zhptrd_(char *, integer *, doublecomplex *,
+ doublereal *, doublereal *, doublecomplex *, integer *),
+ zsteqr_(char *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublereal *, integer *),
+ zupgtr_(char *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHPEV computes all the eigenvalues and, optionally, eigenvectors of a */
+/* complex Hermitian matrix in packed storage. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, AP is overwritten by values generated during the */
+/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */
+/* and first superdiagonal of the tridiagonal matrix T overwrite */
+/* the corresponding elements of A, and if UPLO = 'L', the */
+/* diagonal and first subdiagonal of T overwrite the */
+/* corresponding elements of A. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX*16 array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
+/* eigenvectors of the matrix A, with the i-th column of Z */
+/* holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (max(1, 2*N-1)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of an intermediate tridiagonal */
+/* form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lsame_(uplo, "L") || lsame_(uplo,
+ "U"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -7;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHPEV ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ w[1] = ap[1].r;
+ rwork[1] = 1.;
+ if (wantz) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1., z__[i__1].i = 0.;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = zlanhp_("M", uplo, n, &ap[1], &rwork[1]);
+ iscale = 0;
+ if (anrm > 0. && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ i__1 = *n * (*n + 1) / 2;
+ zdscal_(&i__1, &sigma, &ap[1], &c__1);
+ }
+
+/* Call ZHPTRD to reduce Hermitian packed matrix to tridiagonal form. */
+
+ inde = 1;
+ indtau = 1;
+ zhptrd_(uplo, n, &ap[1], &w[1], &rwork[inde], &work[indtau], &iinfo);
+
+/* For eigenvalues only, call DSTERF. For eigenvectors, first call */
+/* ZUPGTR to generate the orthogonal matrix, then call ZSTEQR. */
+
+ if (! wantz) {
+ dsterf_(n, &w[1], &rwork[inde], info);
+ } else {
+ indwrk = indtau + *n;
+ zupgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &work[
+ indwrk], &iinfo);
+ indrwk = inde + *n;
+ zsteqr_(jobz, n, &w[1], &rwork[inde], &z__[z_offset], ldz, &rwork[
+ indrwk], info);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *n;
+ } else {
+ imax = *info - 1;
+ }
+ d__1 = 1. / sigma;
+ dscal_(&imax, &d__1, &w[1], &c__1);
+ }
+
+ return 0;
+
+/* End of ZHPEV */
+
+} /* zhpev_ */
diff --git a/SRC/zhpevd.c b/SRC/zhpevd.c
new file mode 100644
index 0000000..9bc9ad8
--- /dev/null
+++ b/SRC/zhpevd.c
@@ -0,0 +1,349 @@
+/* zhpevd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zhpevd_(char *jobz, char *uplo, integer *n,
+ doublecomplex *ap, doublereal *w, doublecomplex *z__, integer *ldz,
+ doublecomplex *work, integer *lwork, doublereal *rwork, integer *
+ lrwork, integer *iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal eps;
+ integer inde;
+ doublereal anrm;
+ integer imax;
+ doublereal rmin, rmax;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo, lwmin, llrwk, llwrk;
+ logical wantz;
+ extern doublereal dlamch_(char *);
+ integer iscale;
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
+ integer *, doublereal *, doublecomplex *, integer *);
+ doublereal bignum;
+ integer indtau;
+ extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern doublereal zlanhp_(char *, char *, integer *, doublecomplex *,
+ doublereal *);
+ extern /* Subroutine */ int zstedc_(char *, integer *, doublereal *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, integer *, integer *, integer *, integer
+ *);
+ integer indrwk, indwrk, liwmin, lrwmin;
+ doublereal smlnum;
+ extern /* Subroutine */ int zhptrd_(char *, integer *, doublecomplex *,
+ doublereal *, doublereal *, doublecomplex *, integer *);
+ logical lquery;
+ extern /* Subroutine */ int zupmtr_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHPEVD computes all the eigenvalues and, optionally, eigenvectors of */
+/* a complex Hermitian matrix A in packed storage. If eigenvectors are */
+/* desired, it uses a divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, AP is overwritten by values generated during the */
+/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */
+/* and first superdiagonal of the tridiagonal matrix T overwrite */
+/* the corresponding elements of A, and if UPLO = 'L', the */
+/* diagonal and first subdiagonal of T overwrite the */
+/* corresponding elements of A. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX*16 array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
+/* eigenvectors of the matrix A, with the i-th column of Z */
+/* holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the required LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of array WORK. */
+/* If N <= 1, LWORK must be at least 1. */
+/* If JOBZ = 'N' and N > 1, LWORK must be at least N. */
+/* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the required sizes of the WORK, RWORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* RWORK (workspace/output) DOUBLE PRECISION array, */
+/* dimension (LRWORK) */
+/* On exit, if INFO = 0, RWORK(1) returns the required LRWORK. */
+
+/* LRWORK (input) INTEGER */
+/* The dimension of array RWORK. */
+/* If N <= 1, LRWORK must be at least 1. */
+/* If JOBZ = 'N' and N > 1, LRWORK must be at least N. */
+/* If JOBZ = 'V' and N > 1, LRWORK must be at least */
+/* 1 + 5*N + 2*N**2. */
+
+/* If LRWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the required sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the required LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of array IWORK. */
+/* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. */
+/* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the required sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the algorithm failed to converge; i */
+/* off-diagonal elements of an intermediate tridiagonal */
+/* form did not converge to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (lsame_(uplo, "L") || lsame_(uplo,
+ "U"))) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -7;
+ }
+
+ if (*info == 0) {
+ if (*n <= 1) {
+ lwmin = 1;
+ liwmin = 1;
+ lrwmin = 1;
+ } else {
+ if (wantz) {
+ lwmin = *n << 1;
+/* Computing 2nd power */
+ i__1 = *n;
+ lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
+ liwmin = *n * 5 + 3;
+ } else {
+ lwmin = *n;
+ lrwmin = *n;
+ liwmin = 1;
+ }
+ }
+ work[1].r = (doublereal) lwmin, work[1].i = 0.;
+ rwork[1] = (doublereal) lrwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -9;
+ } else if (*lrwork < lrwmin && ! lquery) {
+ *info = -11;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHPEVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ w[1] = ap[1].r;
+ if (wantz) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1., z__[i__1].i = 0.;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+ rmax = sqrt(bignum);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ anrm = zlanhp_("M", uplo, n, &ap[1], &rwork[1]);
+ iscale = 0;
+ if (anrm > 0. && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ i__1 = *n * (*n + 1) / 2;
+ zdscal_(&i__1, &sigma, &ap[1], &c__1);
+ }
+
+/* Call ZHPTRD to reduce Hermitian packed matrix to tridiagonal form. */
+
+ inde = 1;
+ indtau = 1;
+ indrwk = inde + *n;
+ indwrk = indtau + *n;
+ llwrk = *lwork - indwrk + 1;
+ llrwk = *lrwork - indrwk + 1;
+ zhptrd_(uplo, n, &ap[1], &w[1], &rwork[inde], &work[indtau], &iinfo);
+
+/* For eigenvalues only, call DSTERF. For eigenvectors, first call */
+/* ZUPGTR to generate the orthogonal matrix, then call ZSTEDC. */
+
+ if (! wantz) {
+ dsterf_(n, &w[1], &rwork[inde], info);
+ } else {
+ zstedc_("I", n, &w[1], &rwork[inde], &z__[z_offset], ldz, &work[
+ indwrk], &llwrk, &rwork[indrwk], &llrwk, &iwork[1], liwork,
+ info);
+ zupmtr_("L", uplo, "N", n, n, &ap[1], &work[indtau], &z__[z_offset],
+ ldz, &work[indwrk], &iinfo);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *n;
+ } else {
+ imax = *info - 1;
+ }
+ d__1 = 1. / sigma;
+ dscal_(&imax, &d__1, &w[1], &c__1);
+ }
+
+ work[1].r = (doublereal) lwmin, work[1].i = 0.;
+ rwork[1] = (doublereal) lrwmin;
+ iwork[1] = liwmin;
+ return 0;
+
+/* End of ZHPEVD */
+
+} /* zhpevd_ */
diff --git a/SRC/zhpevx.c b/SRC/zhpevx.c
new file mode 100644
index 0000000..3f5d87d
--- /dev/null
+++ b/SRC/zhpevx.c
@@ -0,0 +1,475 @@
+/* zhpevx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zhpevx_(char *jobz, char *range, char *uplo, integer *n,
+ doublecomplex *ap, doublereal *vl, doublereal *vu, integer *il,
+ integer *iu, doublereal *abstol, integer *m, doublereal *w,
+ doublecomplex *z__, integer *ldz, doublecomplex *work, doublereal *
+ rwork, integer *iwork, integer *ifail, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, jj;
+ doublereal eps, vll, vuu, tmp1;
+ integer indd, inde;
+ doublereal anrm;
+ integer imax;
+ doublereal rmin, rmax;
+ logical test;
+ integer itmp1, indee;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal sigma;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ char order[1];
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical wantz;
+ extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ logical alleig, indeig;
+ integer iscale, indibl;
+ logical valeig;
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
+ integer *, doublereal *, doublecomplex *, integer *);
+ doublereal abstll, bignum;
+ integer indiwk, indisp, indtau;
+ extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
+ integer *), dstebz_(char *, char *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, integer *);
+ extern doublereal zlanhp_(char *, char *, integer *, doublecomplex *,
+ doublereal *);
+ integer indrwk, indwrk, nsplit;
+ doublereal smlnum;
+ extern /* Subroutine */ int zhptrd_(char *, integer *, doublecomplex *,
+ doublereal *, doublereal *, doublecomplex *, integer *),
+ zstein_(integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *, integer *, integer *), zsteqr_(char *,
+ integer *, doublereal *, doublereal *, doublecomplex *, integer *,
+ doublereal *, integer *), zupgtr_(char *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zupmtr_(char *, char *, char
+ *, integer *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHPEVX computes selected eigenvalues and, optionally, eigenvectors */
+/* of a complex Hermitian matrix A in packed storage. */
+/* Eigenvalues/vectors can be selected by specifying either a range of */
+/* values or a range of indices for the desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found; */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found; */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, AP is overwritten by values generated during the */
+/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */
+/* and first superdiagonal of the tridiagonal matrix T overwrite */
+/* the corresponding elements of A, and if UPLO = 'L', the */
+/* diagonal and first subdiagonal of T overwrite the */
+/* corresponding elements of A. */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) DOUBLE PRECISION */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing AP to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*DLAMCH('S'). */
+
+/* See "Computing Small Singular Values of Bidiagonal Matrices */
+/* with Guaranteed High Relative Accuracy," by Demmel and */
+/* Kahan, LAPACK Working Note #3. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the selected eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M)) */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If an eigenvector fails to converge, then that column of Z */
+/* contains the latest approximation to the eigenvector, and */
+/* the index of the eigenvector is returned in IFAIL. */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, then i eigenvectors failed to converge. */
+/* Their indices are stored in array IFAIL. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (! (lsame_(uplo, "L") || lsame_(uplo,
+ "U"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -7;
+ }
+ } else if (indeig) {
+ if (*il < 1 || *il > max(1,*n)) {
+ *info = -8;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -9;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -14;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHPEVX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (alleig || indeig) {
+ *m = 1;
+ w[1] = ap[1].r;
+ } else {
+ if (*vl < ap[1].r && *vu >= ap[1].r) {
+ *m = 1;
+ w[1] = ap[1].r;
+ }
+ }
+ if (wantz) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1., z__[i__1].i = 0.;
+ }
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
+ rmax = min(d__1,d__2);
+
+/* Scale matrix to allowable range, if necessary. */
+
+ iscale = 0;
+ abstll = *abstol;
+ if (valeig) {
+ vll = *vl;
+ vuu = *vu;
+ } else {
+ vll = 0.;
+ vuu = 0.;
+ }
+ anrm = zlanhp_("M", uplo, n, &ap[1], &rwork[1]);
+ if (anrm > 0. && anrm < rmin) {
+ iscale = 1;
+ sigma = rmin / anrm;
+ } else if (anrm > rmax) {
+ iscale = 1;
+ sigma = rmax / anrm;
+ }
+ if (iscale == 1) {
+ i__1 = *n * (*n + 1) / 2;
+ zdscal_(&i__1, &sigma, &ap[1], &c__1);
+ if (*abstol > 0.) {
+ abstll = *abstol * sigma;
+ }
+ if (valeig) {
+ vll = *vl * sigma;
+ vuu = *vu * sigma;
+ }
+ }
+
+/* Call ZHPTRD to reduce Hermitian packed matrix to tridiagonal form. */
+
+ indd = 1;
+ inde = indd + *n;
+ indrwk = inde + *n;
+ indtau = 1;
+ indwrk = indtau + *n;
+ zhptrd_(uplo, n, &ap[1], &rwork[indd], &rwork[inde], &work[indtau], &
+ iinfo);
+
+/* If all eigenvalues are desired and ABSTOL is less than or equal */
+/* to zero, then call DSTERF or ZUPGTR and ZSTEQR. If this fails */
+/* for some eigenvalue, then try DSTEBZ. */
+
+ test = FALSE_;
+ if (indeig) {
+ if (*il == 1 && *iu == *n) {
+ test = TRUE_;
+ }
+ }
+ if ((alleig || test) && *abstol <= 0.) {
+ dcopy_(n, &rwork[indd], &c__1, &w[1], &c__1);
+ indee = indrwk + (*n << 1);
+ if (! wantz) {
+ i__1 = *n - 1;
+ dcopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
+ dsterf_(n, &w[1], &rwork[indee], info);
+ } else {
+ zupgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &
+ work[indwrk], &iinfo);
+ i__1 = *n - 1;
+ dcopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
+ zsteqr_(jobz, n, &w[1], &rwork[indee], &z__[z_offset], ldz, &
+ rwork[indrwk], info);
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ifail[i__] = 0;
+/* L10: */
+ }
+ }
+ }
+ if (*info == 0) {
+ *m = *n;
+ goto L20;
+ }
+ *info = 0;
+ }
+
+/* Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN. */
+
+ if (wantz) {
+ *(unsigned char *)order = 'B';
+ } else {
+ *(unsigned char *)order = 'E';
+ }
+ indibl = 1;
+ indisp = indibl + *n;
+ indiwk = indisp + *n;
+ dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], &
+ rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &
+ rwork[indrwk], &iwork[indiwk], info);
+
+ if (wantz) {
+ zstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], &
+ iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[
+ indiwk], &ifail[1], info);
+
+/* Apply unitary matrix used in reduction to tridiagonal */
+/* form to eigenvectors returned by ZSTEIN. */
+
+ indwrk = indtau + *n;
+ zupmtr_("L", uplo, "N", n, m, &ap[1], &work[indtau], &z__[z_offset],
+ ldz, &work[indwrk], &iinfo);
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+L20:
+ if (iscale == 1) {
+ if (*info == 0) {
+ imax = *m;
+ } else {
+ imax = *info - 1;
+ }
+ d__1 = 1. / sigma;
+ dscal_(&imax, &d__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in order, then sort them, along with */
+/* eigenvectors. */
+
+ if (wantz) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp1 = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp1) {
+ i__ = jj;
+ tmp1 = w[jj];
+ }
+/* L30: */
+ }
+
+ if (i__ != 0) {
+ itmp1 = iwork[indibl + i__ - 1];
+ w[i__] = w[j];
+ iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
+ w[j] = tmp1;
+ iwork[indibl + j - 1] = itmp1;
+ zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+ &c__1);
+ if (*info != 0) {
+ itmp1 = ifail[i__];
+ ifail[i__] = ifail[j];
+ ifail[j] = itmp1;
+ }
+ }
+/* L40: */
+ }
+ }
+
+ return 0;
+
+/* End of ZHPEVX */
+
+} /* zhpevx_ */
diff --git a/SRC/zhpgst.c b/SRC/zhpgst.c
new file mode 100644
index 0000000..3533152
--- /dev/null
+++ b/SRC/zhpgst.c
@@ -0,0 +1,313 @@
+/* zhpgst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zhpgst_(integer *itype, char *uplo, integer *n,
+ doublecomplex *ap, doublecomplex *bp, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Local variables */
+ integer j, k, j1, k1, jj, kk;
+ doublecomplex ct;
+ doublereal ajj;
+ integer j1j1;
+ doublereal akk;
+ integer k1k1;
+ doublereal bjj, bkk;
+ extern /* Subroutine */ int zhpr2_(char *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *);
+ extern logical lsame_(char *, char *);
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int zhpmv_(char *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *), zaxpy_(integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *), ztpmv_(char *, char *, char *, integer *,
+ doublecomplex *, doublecomplex *, integer *), ztpsv_(char *, char *, char *, integer *, doublecomplex *
+, doublecomplex *, integer *), xerbla_(
+ char *, integer *), zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHPGST reduces a complex Hermitian-definite generalized */
+/* eigenproblem to standard form, using packed storage. */
+
+/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
+/* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H) */
+
+/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
+/* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L. */
+
+/* B must have been previously factorized as U**H*U or L*L**H by ZPPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H); */
+/* = 2 or 3: compute U*A*U**H or L**H*A*L. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored and B is factored as */
+/* U**H*U; */
+/* = 'L': Lower triangle of A is stored and B is factored as */
+/* L*L**H. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, if INFO = 0, the transformed matrix, stored in the */
+/* same format as A. */
+
+/* BP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The triangular factor from the Cholesky factorization of B, */
+/* stored in the same format as A, as returned by ZPPTRF. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --bp;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHPGST", &i__1);
+ return 0;
+ }
+
+ if (*itype == 1) {
+ if (upper) {
+
+/* Compute inv(U')*A*inv(U) */
+
+/* J1 and JJ are the indices of A(1,j) and A(j,j) */
+
+ jj = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ j1 = jj + 1;
+ jj += j;
+
+/* Compute the j-th column of the upper triangle of A */
+
+ i__2 = jj;
+ i__3 = jj;
+ d__1 = ap[i__3].r;
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+ i__2 = jj;
+ bjj = bp[i__2].r;
+ ztpsv_(uplo, "Conjugate transpose", "Non-unit", &j, &bp[1], &
+ ap[j1], &c__1);
+ i__2 = j - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zhpmv_(uplo, &i__2, &z__1, &ap[1], &bp[j1], &c__1, &c_b1, &ap[
+ j1], &c__1);
+ i__2 = j - 1;
+ d__1 = 1. / bjj;
+ zdscal_(&i__2, &d__1, &ap[j1], &c__1);
+ i__2 = jj;
+ i__3 = jj;
+ i__4 = j - 1;
+ zdotc_(&z__3, &i__4, &ap[j1], &c__1, &bp[j1], &c__1);
+ z__2.r = ap[i__3].r - z__3.r, z__2.i = ap[i__3].i - z__3.i;
+ z__1.r = z__2.r / bjj, z__1.i = z__2.i / bjj;
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+/* L10: */
+ }
+ } else {
+
+/* Compute inv(L)*A*inv(L') */
+
+/* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */
+
+ kk = 1;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ k1k1 = kk + *n - k + 1;
+
+/* Update the lower triangle of A(k:n,k:n) */
+
+ i__2 = kk;
+ akk = ap[i__2].r;
+ i__2 = kk;
+ bkk = bp[i__2].r;
+/* Computing 2nd power */
+ d__1 = bkk;
+ akk /= d__1 * d__1;
+ i__2 = kk;
+ ap[i__2].r = akk, ap[i__2].i = 0.;
+ if (k < *n) {
+ i__2 = *n - k;
+ d__1 = 1. / bkk;
+ zdscal_(&i__2, &d__1, &ap[kk + 1], &c__1);
+ d__1 = akk * -.5;
+ ct.r = d__1, ct.i = 0.;
+ i__2 = *n - k;
+ zaxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
+ ;
+ i__2 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zhpr2_(uplo, &i__2, &z__1, &ap[kk + 1], &c__1, &bp[kk + 1]
+, &c__1, &ap[k1k1]);
+ i__2 = *n - k;
+ zaxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
+ ;
+ i__2 = *n - k;
+ ztpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1],
+ &ap[kk + 1], &c__1);
+ }
+ kk = k1k1;
+/* L20: */
+ }
+ }
+ } else {
+ if (upper) {
+
+/* Compute U*A*U' */
+
+/* K1 and KK are the indices of A(1,k) and A(k,k) */
+
+ kk = 0;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ k1 = kk + 1;
+ kk += k;
+
+/* Update the upper triangle of A(1:k,1:k) */
+
+ i__2 = kk;
+ akk = ap[i__2].r;
+ i__2 = kk;
+ bkk = bp[i__2].r;
+ i__2 = k - 1;
+ ztpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[
+ k1], &c__1);
+ d__1 = akk * .5;
+ ct.r = d__1, ct.i = 0.;
+ i__2 = k - 1;
+ zaxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
+ i__2 = k - 1;
+ zhpr2_(uplo, &i__2, &c_b1, &ap[k1], &c__1, &bp[k1], &c__1, &
+ ap[1]);
+ i__2 = k - 1;
+ zaxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
+ i__2 = k - 1;
+ zdscal_(&i__2, &bkk, &ap[k1], &c__1);
+ i__2 = kk;
+/* Computing 2nd power */
+ d__2 = bkk;
+ d__1 = akk * (d__2 * d__2);
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+/* L30: */
+ }
+ } else {
+
+/* Compute L'*A*L */
+
+/* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */
+
+ jj = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ j1j1 = jj + *n - j + 1;
+
+/* Compute the j-th column of the lower triangle of A */
+
+ i__2 = jj;
+ ajj = ap[i__2].r;
+ i__2 = jj;
+ bjj = bp[i__2].r;
+ i__2 = jj;
+ d__1 = ajj * bjj;
+ i__3 = *n - j;
+ zdotc_(&z__2, &i__3, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1);
+ z__1.r = d__1 + z__2.r, z__1.i = z__2.i;
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ i__2 = *n - j;
+ zdscal_(&i__2, &bjj, &ap[jj + 1], &c__1);
+ i__2 = *n - j;
+ zhpmv_(uplo, &i__2, &c_b1, &ap[j1j1], &bp[jj + 1], &c__1, &
+ c_b1, &ap[jj + 1], &c__1);
+ i__2 = *n - j + 1;
+ ztpmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &bp[jj]
+, &ap[jj], &c__1);
+ jj = j1j1;
+/* L40: */
+ }
+ }
+ }
+ return 0;
+
+/* End of ZHPGST */
+
+} /* zhpgst_ */
diff --git a/SRC/zhpgv.c b/SRC/zhpgv.c
new file mode 100644
index 0000000..ffd205f
--- /dev/null
+++ b/SRC/zhpgv.c
@@ -0,0 +1,246 @@
+/* zhpgv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zhpgv_(integer *itype, char *jobz, char *uplo, integer *
+ n, doublecomplex *ap, doublecomplex *bp, doublereal *w, doublecomplex
+ *z__, integer *ldz, doublecomplex *work, doublereal *rwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+
+ /* Local variables */
+ integer j, neig;
+ extern logical lsame_(char *, char *);
+ char trans[1];
+ logical upper;
+ extern /* Subroutine */ int zhpev_(char *, char *, integer *,
+ doublecomplex *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, doublereal *, integer *);
+ logical wantz;
+ extern /* Subroutine */ int ztpmv_(char *, char *, char *, integer *,
+ doublecomplex *, doublecomplex *, integer *), ztpsv_(char *, char *, char *, integer *, doublecomplex *
+, doublecomplex *, integer *), xerbla_(
+ char *, integer *), zhpgst_(integer *, char *, integer *,
+ doublecomplex *, doublecomplex *, integer *), zpptrf_(
+ char *, integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHPGV computes all the eigenvalues and, optionally, the eigenvectors */
+/* of a complex generalized Hermitian-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. */
+/* Here A and B are assumed to be Hermitian, stored in packed format, */
+/* and B is also positive definite. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the contents of AP are destroyed. */
+
+/* BP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* B, packed columnwise in a linear array. The j-th column of B */
+/* is stored in the array BP as follows: */
+/* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */
+
+/* On exit, the triangular factor U or L from the Cholesky */
+/* factorization B = U**H*U or B = L*L**H, in the same storage */
+/* format as B. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX*16 array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
+/* eigenvectors. The eigenvectors are normalized as follows: */
+/* if ITYPE = 1 or 2, Z**H*B*Z = I; */
+/* if ITYPE = 3, Z**H*inv(B)*Z = I. */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (max(1, 2*N-1)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2)) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: ZPPTRF or ZHPEV returned an error code: */
+/* <= N: if INFO = i, ZHPEV failed to converge; */
+/* i off-diagonal elements of an intermediate */
+/* tridiagonal form did not convergeto zero; */
+/* > N: if INFO = N + i, for 1 <= i <= n, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --bp;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+
+ *info = 0;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHPGV ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of B. */
+
+ zpptrf_(uplo, n, &bp[1], info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ zhpgst_(itype, uplo, n, &ap[1], &bp[1], info);
+ zhpev_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], &
+ rwork[1], info);
+
+ if (wantz) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ neig = *n;
+ if (*info > 0) {
+ neig = *info - 1;
+ }
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'C';
+ }
+
+ i__1 = neig;
+ for (j = 1; j <= i__1; ++j) {
+ ztpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L10: */
+ }
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'C';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ i__1 = neig;
+ for (j = 1; j <= i__1; ++j) {
+ ztpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L20: */
+ }
+ }
+ }
+ return 0;
+
+/* End of ZHPGV */
+
+} /* zhpgv_ */
diff --git a/SRC/zhpgvd.c b/SRC/zhpgvd.c
new file mode 100644
index 0000000..b47f689
--- /dev/null
+++ b/SRC/zhpgvd.c
@@ -0,0 +1,359 @@
+/* zhpgvd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zhpgvd_(integer *itype, char *jobz, char *uplo, integer *
+ n, doublecomplex *ap, doublecomplex *bp, doublereal *w, doublecomplex
+ *z__, integer *ldz, doublecomplex *work, integer *lwork, doublereal *
+ rwork, integer *lrwork, integer *iwork, integer *liwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j, neig;
+ extern logical lsame_(char *, char *);
+ integer lwmin;
+ char trans[1];
+ logical upper, wantz;
+ extern /* Subroutine */ int ztpmv_(char *, char *, char *, integer *,
+ doublecomplex *, doublecomplex *, integer *), ztpsv_(char *, char *, char *, integer *, doublecomplex *
+, doublecomplex *, integer *), xerbla_(
+ char *, integer *);
+ integer liwmin;
+ extern /* Subroutine */ int zhpevd_(char *, char *, integer *,
+ doublecomplex *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, integer *, integer *,
+ integer *, integer *);
+ integer lrwmin;
+ extern /* Subroutine */ int zhpgst_(integer *, char *, integer *,
+ doublecomplex *, doublecomplex *, integer *);
+ logical lquery;
+ extern /* Subroutine */ int zpptrf_(char *, integer *, doublecomplex *,
+ integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHPGVD computes all the eigenvalues and, optionally, the eigenvectors */
+/* of a complex generalized Hermitian-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */
+/* B are assumed to be Hermitian, stored in packed format, and B is also */
+/* positive definite. */
+/* If eigenvectors are desired, it uses a divide and conquer algorithm. */
+
+/* The divide and conquer algorithm makes very mild assumptions about */
+/* floating point arithmetic. It will work on machines with a guard */
+/* digit in add/subtract, or on those binary machines without guard */
+/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the contents of AP are destroyed. */
+
+/* BP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* B, packed columnwise in a linear array. The j-th column of B */
+/* is stored in the array BP as follows: */
+/* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */
+
+/* On exit, the triangular factor U or L from the Cholesky */
+/* factorization B = U**H*U or B = L*L**H, in the same storage */
+/* format as B. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, the eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX*16 array, dimension (LDZ, N) */
+/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
+/* eigenvectors. The eigenvectors are normalized as follows: */
+/* if ITYPE = 1 or 2, Z**H*B*Z = I; */
+/* if ITYPE = 3, Z**H*inv(B)*Z = I. */
+/* If JOBZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the required LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of array WORK. */
+/* If N <= 1, LWORK >= 1. */
+/* If JOBZ = 'N' and N > 1, LWORK >= N. */
+/* If JOBZ = 'V' and N > 1, LWORK >= 2*N. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the required sizes of the WORK, RWORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LRWORK)) */
+/* On exit, if INFO = 0, RWORK(1) returns the required LRWORK. */
+
+/* LRWORK (input) INTEGER */
+/* The dimension of array RWORK. */
+/* If N <= 1, LRWORK >= 1. */
+/* If JOBZ = 'N' and N > 1, LRWORK >= N. */
+/* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2. */
+
+/* If LRWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the required sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the required LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of array IWORK. */
+/* If JOBZ = 'N' or N <= 1, LIWORK >= 1. */
+/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the required sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: ZPPTRF or ZHPEVD returned an error code: */
+/* <= N: if INFO = i, ZHPEVD failed to converge; */
+/* i off-diagonal elements of an intermediate */
+/* tridiagonal form did not convergeto zero; */
+/* > N: if INFO = N + i, for 1 <= i <= n, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --bp;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
+
+ *info = 0;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -9;
+ }
+
+ if (*info == 0) {
+ if (*n <= 1) {
+ lwmin = 1;
+ liwmin = 1;
+ lrwmin = 1;
+ } else {
+ if (wantz) {
+ lwmin = *n << 1;
+/* Computing 2nd power */
+ i__1 = *n;
+ lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
+ liwmin = *n * 5 + 3;
+ } else {
+ lwmin = *n;
+ lrwmin = *n;
+ liwmin = 1;
+ }
+ }
+
+ work[1].r = (doublereal) lwmin, work[1].i = 0.;
+ rwork[1] = (doublereal) lrwmin;
+ iwork[1] = liwmin;
+ if (*lwork < lwmin && ! lquery) {
+ *info = -11;
+ } else if (*lrwork < lrwmin && ! lquery) {
+ *info = -13;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -15;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHPGVD", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of B. */
+
+ zpptrf_(uplo, n, &bp[1], info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ zhpgst_(itype, uplo, n, &ap[1], &bp[1], info);
+ zhpevd_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1],
+ lwork, &rwork[1], lrwork, &iwork[1], liwork, info);
+/* Computing MAX */
+ d__1 = (doublereal) lwmin, d__2 = work[1].r;
+ lwmin = (integer) max(d__1,d__2);
+/* Computing MAX */
+ d__1 = (doublereal) lrwmin;
+ lrwmin = (integer) max(d__1,rwork[1]);
+/* Computing MAX */
+ d__1 = (doublereal) liwmin, d__2 = (doublereal) iwork[1];
+ liwmin = (integer) max(d__1,d__2);
+
+ if (wantz) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ neig = *n;
+ if (*info > 0) {
+ neig = *info - 1;
+ }
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'C';
+ }
+
+ i__1 = neig;
+ for (j = 1; j <= i__1; ++j) {
+ ztpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L10: */
+ }
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'C';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ i__1 = neig;
+ for (j = 1; j <= i__1; ++j) {
+ ztpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L20: */
+ }
+ }
+ }
+
+ work[1].r = (doublereal) lwmin, work[1].i = 0.;
+ rwork[1] = (doublereal) lrwmin;
+ iwork[1] = liwmin;
+ return 0;
+
+/* End of ZHPGVD */
+
+} /* zhpgvd_ */
diff --git a/SRC/zhpgvx.c b/SRC/zhpgvx.c
new file mode 100644
index 0000000..2c76291
--- /dev/null
+++ b/SRC/zhpgvx.c
@@ -0,0 +1,344 @@
+/* zhpgvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zhpgvx_(integer *itype, char *jobz, char *range, char *
+ uplo, integer *n, doublecomplex *ap, doublecomplex *bp, doublereal *
+ vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol,
+ integer *m, doublereal *w, doublecomplex *z__, integer *ldz,
+ doublecomplex *work, doublereal *rwork, integer *iwork, integer *
+ ifail, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+
+ /* Local variables */
+ integer j;
+ extern logical lsame_(char *, char *);
+ char trans[1];
+ logical upper, wantz;
+ extern /* Subroutine */ int ztpmv_(char *, char *, char *, integer *,
+ doublecomplex *, doublecomplex *, integer *), ztpsv_(char *, char *, char *, integer *, doublecomplex *
+, doublecomplex *, integer *);
+ logical alleig, indeig, valeig;
+ extern /* Subroutine */ int xerbla_(char *, integer *), zhpgst_(
+ integer *, char *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zhpevx_(char *, char *, char *, integer *,
+ doublecomplex *, doublereal *, doublereal *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublecomplex *, integer *
+, doublecomplex *, doublereal *, integer *, integer *, integer *), zpptrf_(char *, integer *, doublecomplex
+ *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHPGVX computes selected eigenvalues and, optionally, eigenvectors */
+/* of a complex generalized Hermitian-definite eigenproblem, of the form */
+/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */
+/* B are assumed to be Hermitian, stored in packed format, and B is also */
+/* positive definite. Eigenvalues and eigenvectors can be selected by */
+/* specifying either a range of values or a range of indices for the */
+/* desired eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the problem type to be solved: */
+/* = 1: A*x = (lambda)*B*x */
+/* = 2: A*B*x = (lambda)*x */
+/* = 3: B*A*x = (lambda)*x */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found; */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found; */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangles of A and B are stored; */
+/* = 'L': Lower triangles of A and B are stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the contents of AP are destroyed. */
+
+/* BP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* B, packed columnwise in a linear array. The j-th column of B */
+/* is stored in the array BP as follows: */
+/* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */
+
+/* On exit, the triangular factor U or L from the Cholesky */
+/* factorization B = U**H*U or B = L*L**H, in the same storage */
+/* format as B. */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) DOUBLE PRECISION */
+/* The absolute error tolerance for the eigenvalues. */
+/* An approximate eigenvalue is accepted as converged */
+/* when it is determined to lie in an interval [a,b] */
+/* of width less than or equal to */
+
+/* ABSTOL + EPS * max( |a|,|b| ) , */
+
+/* where EPS is the machine precision. If ABSTOL is less than */
+/* or equal to zero, then EPS*|T| will be used in its place, */
+/* where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* by reducing AP to tridiagonal form. */
+
+/* Eigenvalues will be computed most accurately when ABSTOL is */
+/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
+/* If this routine returns with INFO>0, indicating that some */
+/* eigenvectors did not converge, try setting ABSTOL to */
+/* 2*DLAMCH('S'). */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* On normal exit, the first M elements contain the selected */
+/* eigenvalues in ascending order. */
+
+/* Z (output) COMPLEX*16 array, dimension (LDZ, N) */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix A */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* The eigenvectors are normalized as follows: */
+/* if ITYPE = 1 or 2, Z**H*B*Z = I; */
+/* if ITYPE = 3, Z**H*inv(B)*Z = I. */
+
+/* If an eigenvector fails to converge, then that column of Z */
+/* contains the latest approximation to the eigenvector, and the */
+/* index of the eigenvector is returned in IFAIL. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (5*N) */
+
+/* IFAIL (output) INTEGER array, dimension (N) */
+/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
+/* indices of the eigenvectors that failed to converge. */
+/* If JOBZ = 'N', then IFAIL is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: ZPPTRF or ZHPEVX returned an error code: */
+/* <= N: if INFO = i, ZHPEVX failed to converge; */
+/* i eigenvectors failed to converge. Their indices */
+/* are stored in array IFAIL. */
+/* > N: if INFO = N + i, for 1 <= i <= n, then the leading */
+/* minor of order i of B is not positive definite. */
+/* The factorization of B could not be completed and */
+/* no eigenvalues or eigenvectors were computed. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --bp;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ upper = lsame_(uplo, "U");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ *info = 0;
+ if (*itype < 1 || *itype > 3) {
+ *info = -1;
+ } else if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -2;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -3;
+ } else if (! (upper || lsame_(uplo, "L"))) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else {
+ if (valeig) {
+ if (*n > 0 && *vu <= *vl) {
+ *info = -9;
+ }
+ } else if (indeig) {
+ if (*il < 1) {
+ *info = -10;
+ } else if (*iu < min(*n,*il) || *iu > *n) {
+ *info = -11;
+ }
+ }
+ }
+ if (*info == 0) {
+ if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -16;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHPGVX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Form a Cholesky factorization of B. */
+
+ zpptrf_(uplo, n, &bp[1], info);
+ if (*info != 0) {
+ *info = *n + *info;
+ return 0;
+ }
+
+/* Transform problem to standard eigenvalue problem and solve. */
+
+ zhpgst_(itype, uplo, n, &ap[1], &bp[1], info);
+ zhpevx_(jobz, range, uplo, n, &ap[1], vl, vu, il, iu, abstol, m, &w[1], &
+ z__[z_offset], ldz, &work[1], &rwork[1], &iwork[1], &ifail[1],
+ info);
+
+ if (wantz) {
+
+/* Backtransform eigenvectors to the original problem. */
+
+ if (*info > 0) {
+ *m = *info - 1;
+ }
+ if (*itype == 1 || *itype == 2) {
+
+/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'C';
+ }
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ ztpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L10: */
+ }
+
+ } else if (*itype == 3) {
+
+/* For B*A*x=(lambda)*x; */
+/* backtransform eigenvectors: x = L*y or U'*y */
+
+ if (upper) {
+ *(unsigned char *)trans = 'C';
+ } else {
+ *(unsigned char *)trans = 'N';
+ }
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ ztpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
+ 1], &c__1);
+/* L20: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZHPGVX */
+
+} /* zhpgvx_ */
diff --git a/SRC/zhprfs.c b/SRC/zhprfs.c
new file mode 100644
index 0000000..75e7f05
--- /dev/null
+++ b/SRC/zhprfs.c
@@ -0,0 +1,462 @@
+/* zhprfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zhprfs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *ap, doublecomplex *afp, integer *ipiv, doublecomplex *
+ b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr,
+ doublereal *berr, doublecomplex *work, doublereal *rwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal s;
+ integer ik, kk;
+ doublereal xk;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3], count;
+ logical upper;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zhpmv_(char *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *), zaxpy_(
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal lstres;
+ extern /* Subroutine */ int zhptrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHPRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is Hermitian indefinite */
+/* and packed, and provides error bounds and backward error estimates */
+/* for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the Hermitian matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* AFP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The factored form of the matrix A. AFP contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor U or L from the factorization A = U*D*U**H or */
+/* A = L*D*L**H as computed by ZHPTRF, stored as a packed */
+/* triangular matrix. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by ZHPTRF. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by ZHPTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --afp;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*ldx < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHPRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ z__1.r = -1., z__1.i = -0.;
+ zhpmv_(uplo, n, &z__1, &ap[1], &x[j * x_dim1 + 1], &c__1, &c_b1, &
+ work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
+ i__ + j * b_dim1]), abs(d__2));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ kk = 1;
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
+ x_dim1]), abs(d__2));
+ ik = kk;
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ik;
+ rwork[i__] += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&ap[ik]), abs(d__2))) * xk;
+ i__4 = ik;
+ i__5 = i__ + j * x_dim1;
+ s += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 = d_imag(&ap[
+ ik]), abs(d__2))) * ((d__3 = x[i__5].r, abs(d__3))
+ + (d__4 = d_imag(&x[i__ + j * x_dim1]), abs(d__4)
+ ));
+ ++ik;
+/* L40: */
+ }
+ i__3 = kk + k - 1;
+ rwork[k] = rwork[k] + (d__1 = ap[i__3].r, abs(d__1)) * xk + s;
+ kk += k;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
+ x_dim1]), abs(d__2));
+ i__3 = kk;
+ rwork[k] += (d__1 = ap[i__3].r, abs(d__1)) * xk;
+ ik = kk + 1;
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ i__4 = ik;
+ rwork[i__] += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&ap[ik]), abs(d__2))) * xk;
+ i__4 = ik;
+ i__5 = i__ + j * x_dim1;
+ s += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 = d_imag(&ap[
+ ik]), abs(d__2))) * ((d__3 = x[i__5].r, abs(d__3))
+ + (d__4 = d_imag(&x[i__ + j * x_dim1]), abs(d__4)
+ ));
+ ++ik;
+/* L60: */
+ }
+ rwork[k] += s;
+ kk += *n - k + 1;
+/* L70: */
+ }
+ }
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__3 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2))) / rwork[i__];
+ s = max(d__3,d__4);
+ } else {
+/* Computing MAX */
+ i__3 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = max(d__3,d__4);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ zhptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info);
+ zaxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use ZLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__3 = i__;
+ rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ ;
+ } else {
+ i__3 = i__;
+ rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ zhptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L120: */
+ }
+ zhptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * x_dim1;
+ d__3 = lstres, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&x[i__ + j * x_dim1]), abs(d__2));
+ lstres = max(d__3,d__4);
+/* L130: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of ZHPRFS */
+
+} /* zhprfs_ */
diff --git a/SRC/zhpsv.c b/SRC/zhpsv.c
new file mode 100644
index 0000000..fe60b30
--- /dev/null
+++ b/SRC/zhpsv.c
@@ -0,0 +1,177 @@
+/* zhpsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zhpsv_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *ap, integer *ipiv, doublecomplex *b, integer *ldb,
+ integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), zhptrf_(
+ char *, integer *, doublecomplex *, integer *, integer *),
+ zhptrs_(char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHPSV computes the solution to a complex system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N Hermitian matrix stored in packed format and X */
+/* and B are N-by-NRHS matrices. */
+
+/* The diagonal pivoting method is used to factor A as */
+/* A = U * D * U**H, if UPLO = 'U', or */
+/* A = L * D * L**H, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, D is Hermitian and block diagonal with 1-by-1 */
+/* and 2-by-2 diagonal blocks. The factored form of A is then used to */
+/* solve the system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+
+/* On exit, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as */
+/* a packed triangular matrix in the same storage format as A. */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D, as */
+/* determined by ZHPTRF. If IPIV(k) > 0, then rows and columns */
+/* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 */
+/* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, */
+/* then rows and columns k-1 and -IPIV(k) were interchanged and */
+/* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and */
+/* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and */
+/* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 */
+/* diagonal block. */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */
+/* has been completed, but the block diagonal matrix D is */
+/* exactly singular, so the solution could not be */
+/* computed. */
+
+/* Further Details */
+/* =============== */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the Hermitian matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = conjg(aji)) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHPSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ zhptrf_(uplo, n, &ap[1], &ipiv[1], info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ zhptrs_(uplo, n, nrhs, &ap[1], &ipiv[1], &b[b_offset], ldb, info);
+
+ }
+ return 0;
+
+/* End of ZHPSV */
+
+} /* zhpsv_ */
diff --git a/SRC/zhpsvx.c b/SRC/zhpsvx.c
new file mode 100644
index 0000000..2b92743
--- /dev/null
+++ b/SRC/zhpsvx.c
@@ -0,0 +1,326 @@
+/* zhpsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zhpsvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublecomplex *ap, doublecomplex *afp, integer *ipiv,
+ doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
+ doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *
+ work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal zlanhp_(char *, char *, integer *, doublecomplex *,
+ doublereal *);
+ extern /* Subroutine */ int zhpcon_(char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublecomplex *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), zhprfs_(char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zhptrf_(char *, integer *, doublecomplex *,
+ integer *, integer *), zhptrs_(char *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHPSVX uses the diagonal pivoting factorization A = U*D*U**H or */
+/* A = L*D*L**H to compute the solution to a complex system of linear */
+/* equations A * X = B, where A is an N-by-N Hermitian matrix stored */
+/* in packed format and X and B are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as */
+/* A = U * D * U**H, if UPLO = 'U', or */
+/* A = L * D * L**H, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices and D is Hermitian and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* 2. If some D(i,i)=0, so that D is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 3. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 4. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of A has been */
+/* supplied on entry. */
+/* = 'F': On entry, AFP and IPIV contain the factored form of */
+/* A. AFP and IPIV will not be modified. */
+/* = 'N': The matrix A will be copied to AFP and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the Hermitian matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+
+/* AFP (input or output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* If FACT = 'F', then AFP is an input argument and on entry */
+/* contains the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as */
+/* a packed triangular matrix in the same storage format as A. */
+
+/* If FACT = 'N', then AFP is an output argument and on exit */
+/* contains the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as */
+/* a packed triangular matrix in the same storage format as A. */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by ZHPTRF. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by ZHPTRF. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A. If RCOND is less than the machine precision (in */
+/* particular, if RCOND = 0), the matrix is singular to working */
+/* precision. This condition is indicated by a return code of */
+/* INFO > 0. */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: D(i,i) is exactly zero. The factorization */
+/* has been completed but the factor D is exactly */
+/* singular, so the solution and error bounds could */
+/* not be computed. RCOND = 0 is returned. */
+/* = N+1: D is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* Further Details */
+/* =============== */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the Hermitian matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = conjg(aji)) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --afp;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ if (! nofact && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHPSVX", &i__1);
+ return 0;
+ }
+
+ if (nofact) {
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ i__1 = *n * (*n + 1) / 2;
+ zcopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1);
+ zhptrf_(uplo, n, &afp[1], &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = zlanhp_("I", uplo, n, &ap[1], &rwork[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ zhpcon_(uplo, n, &afp[1], &ipiv[1], &anorm, rcond, &work[1], info);
+
+/* Compute the solution vectors X. */
+
+ zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ zhptrs_(uplo, n, nrhs, &afp[1], &ipiv[1], &x[x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solutions and */
+/* compute error bounds and backward error estimates for them. */
+
+ zhprfs_(uplo, n, nrhs, &ap[1], &afp[1], &ipiv[1], &b[b_offset], ldb, &x[
+ x_offset], ldx, &ferr[1], &berr[1], &work[1], &rwork[1], info);
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < dlamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of ZHPSVX */
+
+} /* zhpsvx_ */
diff --git a/SRC/zhptrd.c b/SRC/zhptrd.c
new file mode 100644
index 0000000..4829833
--- /dev/null
+++ b/SRC/zhptrd.c
@@ -0,0 +1,319 @@
+/* zhptrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b2 = {0.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zhptrd_(char *uplo, integer *n, doublecomplex *ap,
+ doublereal *d__, doublereal *e, doublecomplex *tau, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublereal d__1;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Local variables */
+ integer i__, i1, ii, i1i1;
+ doublecomplex taui;
+ extern /* Subroutine */ int zhpr2_(char *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *);
+ doublecomplex alpha;
+ extern logical lsame_(char *, char *);
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int zhpmv_(char *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *), zaxpy_(integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *), xerbla_(char *, integer *), zlarfg_(integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHPTRD reduces a complex Hermitian matrix A stored in packed form to */
+/* real symmetric tridiagonal form T by a unitary similarity */
+/* transformation: Q**H * A * Q = T. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+/* On exit, if UPLO = 'U', the diagonal and first superdiagonal */
+/* of A are overwritten by the corresponding elements of the */
+/* tridiagonal matrix T, and the elements above the first */
+/* superdiagonal, with the array TAU, represent the unitary */
+/* matrix Q as a product of elementary reflectors; if UPLO */
+/* = 'L', the diagonal and first subdiagonal of A are over- */
+/* written by the corresponding elements of the tridiagonal */
+/* matrix T, and the elements below the first subdiagonal, with */
+/* the array TAU, represent the unitary matrix Q as a product */
+/* of elementary reflectors. See Further Details. */
+
+/* D (output) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal elements of the tridiagonal matrix T: */
+/* D(i) = A(i,i). */
+
+/* E (output) DOUBLE PRECISION array, dimension (N-1) */
+/* The off-diagonal elements of the tridiagonal matrix T: */
+/* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */
+
+/* TAU (output) COMPLEX*16 array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors (see Further */
+/* Details). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(n-1) . . . H(2) H(1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP, */
+/* overwriting A(1:i-1,i+1), and tau is stored in TAU(i). */
+
+/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(1) H(2) . . . H(n-1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP, */
+/* overwriting A(i+2:n,i), and tau is stored in TAU(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ --tau;
+ --e;
+ --d__;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHPTRD", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Reduce the upper triangle of A. */
+/* I1 is the index in AP of A(1,I+1). */
+
+ i1 = *n * (*n - 1) / 2 + 1;
+ i__1 = i1 + *n - 1;
+ i__2 = i1 + *n - 1;
+ d__1 = ap[i__2].r;
+ ap[i__1].r = d__1, ap[i__1].i = 0.;
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+
+/* Generate elementary reflector H(i) = I - tau * v * v' */
+/* to annihilate A(1:i-1,i+1) */
+
+ i__1 = i1 + i__ - 1;
+ alpha.r = ap[i__1].r, alpha.i = ap[i__1].i;
+ zlarfg_(&i__, &alpha, &ap[i1], &c__1, &taui);
+ i__1 = i__;
+ e[i__1] = alpha.r;
+
+ if (taui.r != 0. || taui.i != 0.) {
+
+/* Apply H(i) from both sides to A(1:i,1:i) */
+
+ i__1 = i1 + i__ - 1;
+ ap[i__1].r = 1., ap[i__1].i = 0.;
+
+/* Compute y := tau * A * v storing y in TAU(1:i) */
+
+ zhpmv_(uplo, &i__, &taui, &ap[1], &ap[i1], &c__1, &c_b2, &tau[
+ 1], &c__1);
+
+/* Compute w := y - 1/2 * tau * (y'*v) * v */
+
+ z__3.r = -.5, z__3.i = -0.;
+ z__2.r = z__3.r * taui.r - z__3.i * taui.i, z__2.i = z__3.r *
+ taui.i + z__3.i * taui.r;
+ zdotc_(&z__4, &i__, &tau[1], &c__1, &ap[i1], &c__1);
+ z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r *
+ z__4.i + z__2.i * z__4.r;
+ alpha.r = z__1.r, alpha.i = z__1.i;
+ zaxpy_(&i__, &alpha, &ap[i1], &c__1, &tau[1], &c__1);
+
+/* Apply the transformation as a rank-2 update: */
+/* A := A - v * w' - w * v' */
+
+ z__1.r = -1., z__1.i = -0.;
+ zhpr2_(uplo, &i__, &z__1, &ap[i1], &c__1, &tau[1], &c__1, &ap[
+ 1]);
+
+ }
+ i__1 = i1 + i__ - 1;
+ i__2 = i__;
+ ap[i__1].r = e[i__2], ap[i__1].i = 0.;
+ i__1 = i__ + 1;
+ i__2 = i1 + i__;
+ d__[i__1] = ap[i__2].r;
+ i__1 = i__;
+ tau[i__1].r = taui.r, tau[i__1].i = taui.i;
+ i1 -= i__;
+/* L10: */
+ }
+ d__[1] = ap[1].r;
+ } else {
+
+/* Reduce the lower triangle of A. II is the index in AP of */
+/* A(i,i) and I1I1 is the index of A(i+1,i+1). */
+
+ ii = 1;
+ d__1 = ap[1].r;
+ ap[1].r = d__1, ap[1].i = 0.;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i1i1 = ii + *n - i__ + 1;
+
+/* Generate elementary reflector H(i) = I - tau * v * v' */
+/* to annihilate A(i+2:n,i) */
+
+ i__2 = ii + 1;
+ alpha.r = ap[i__2].r, alpha.i = ap[i__2].i;
+ i__2 = *n - i__;
+ zlarfg_(&i__2, &alpha, &ap[ii + 2], &c__1, &taui);
+ i__2 = i__;
+ e[i__2] = alpha.r;
+
+ if (taui.r != 0. || taui.i != 0.) {
+
+/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
+
+ i__2 = ii + 1;
+ ap[i__2].r = 1., ap[i__2].i = 0.;
+
+/* Compute y := tau * A * v storing y in TAU(i:n-1) */
+
+ i__2 = *n - i__;
+ zhpmv_(uplo, &i__2, &taui, &ap[i1i1], &ap[ii + 1], &c__1, &
+ c_b2, &tau[i__], &c__1);
+
+/* Compute w := y - 1/2 * tau * (y'*v) * v */
+
+ z__3.r = -.5, z__3.i = -0.;
+ z__2.r = z__3.r * taui.r - z__3.i * taui.i, z__2.i = z__3.r *
+ taui.i + z__3.i * taui.r;
+ i__2 = *n - i__;
+ zdotc_(&z__4, &i__2, &tau[i__], &c__1, &ap[ii + 1], &c__1);
+ z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r *
+ z__4.i + z__2.i * z__4.r;
+ alpha.r = z__1.r, alpha.i = z__1.i;
+ i__2 = *n - i__;
+ zaxpy_(&i__2, &alpha, &ap[ii + 1], &c__1, &tau[i__], &c__1);
+
+/* Apply the transformation as a rank-2 update: */
+/* A := A - v * w' - w * v' */
+
+ i__2 = *n - i__;
+ z__1.r = -1., z__1.i = -0.;
+ zhpr2_(uplo, &i__2, &z__1, &ap[ii + 1], &c__1, &tau[i__], &
+ c__1, &ap[i1i1]);
+
+ }
+ i__2 = ii + 1;
+ i__3 = i__;
+ ap[i__2].r = e[i__3], ap[i__2].i = 0.;
+ i__2 = i__;
+ i__3 = ii;
+ d__[i__2] = ap[i__3].r;
+ i__2 = i__;
+ tau[i__2].r = taui.r, tau[i__2].i = taui.i;
+ ii = i1i1;
+/* L20: */
+ }
+ i__1 = *n;
+ i__2 = ii;
+ d__[i__1] = ap[i__2].r;
+ }
+
+ return 0;
+
+/* End of ZHPTRD */
+
+} /* zhptrd_ */
diff --git a/SRC/zhptrf.c b/SRC/zhptrf.c
new file mode 100644
index 0000000..12d1a8a
--- /dev/null
+++ b/SRC/zhptrf.c
@@ -0,0 +1,821 @@
+/* zhptrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zhptrf_(char *uplo, integer *n, doublecomplex *ap,
+ integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_imag(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ doublereal d__;
+ integer i__, j, k;
+ doublecomplex t;
+ doublereal r1, d11;
+ doublecomplex d12;
+ doublereal d22;
+ doublecomplex d21;
+ integer kc, kk, kp;
+ doublecomplex wk;
+ integer kx;
+ doublereal tt;
+ integer knc, kpc, npp;
+ doublecomplex wkm1, wkp1;
+ integer imax, jmax;
+ extern /* Subroutine */ int zhpr_(char *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *);
+ doublereal alpha;
+ extern logical lsame_(char *, char *);
+ integer kstep;
+ logical upper;
+ extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern doublereal dlapy2_(doublereal *, doublereal *);
+ doublereal absakk;
+ extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
+ integer *, doublereal *, doublecomplex *, integer *);
+ doublereal colmax;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ doublereal rowmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHPTRF computes the factorization of a complex Hermitian packed */
+/* matrix A using the Bunch-Kaufman diagonal pivoting method: */
+
+/* A = U*D*U**H or A = L*D*L**H */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is Hermitian and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L, stored as a packed triangular */
+/* matrix overwriting A (see below for further details). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. 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. */
+
+/* Further Details */
+/* =============== */
+
+/* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services */
+/* Company */
+
+/* If UPLO = 'U', then A = U*D*U', where */
+/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
+/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
+/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I v 0 ) k-s */
+/* U(k) = ( 0 I 0 ) s */
+/* ( 0 0 I ) n-k */
+/* k-s s n-k */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
+/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
+/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
+
+/* If UPLO = 'L', then A = L*D*L', where */
+/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
+/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
+/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I 0 0 ) k-1 */
+/* L(k) = ( 0 I 0 ) s */
+/* ( 0 v I ) n-k-s+1 */
+/* k-1 s n-k-s+1 */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
+/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
+/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ipiv;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHPTRF", &i__1);
+ return 0;
+ }
+
+/* Initialize ALPHA for use in choosing pivot block size. */
+
+ alpha = (sqrt(17.) + 1.) / 8.;
+
+ if (upper) {
+
+/* Factorize A as U*D*U' using the upper triangle of A */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2 */
+
+ k = *n;
+ kc = (*n - 1) * *n / 2 + 1;
+L10:
+ knc = kc;
+
+/* If K < 1, exit from loop */
+
+ if (k < 1) {
+ goto L110;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = kc + k - 1;
+ absakk = (d__1 = ap[i__1].r, abs(d__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ imax = izamax_(&i__1, &ap[kc], &c__1);
+ i__1 = kc + imax - 1;
+ colmax = (d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[kc +
+ imax - 1]), abs(d__2));
+ } else {
+ colmax = 0.;
+ }
+
+ if (max(absakk,colmax) == 0.) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ i__1 = kc + k - 1;
+ i__2 = kc + k - 1;
+ d__1 = ap[i__2].r;
+ ap[i__1].r = d__1, ap[i__1].i = 0.;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ rowmax = 0.;
+ jmax = imax;
+ kx = imax * (imax + 1) / 2 + imax;
+ i__1 = k;
+ for (j = imax + 1; j <= i__1; ++j) {
+ i__2 = kx;
+ if ((d__1 = ap[i__2].r, abs(d__1)) + (d__2 = d_imag(&ap[
+ kx]), abs(d__2)) > rowmax) {
+ i__2 = kx;
+ rowmax = (d__1 = ap[i__2].r, abs(d__1)) + (d__2 =
+ d_imag(&ap[kx]), abs(d__2));
+ jmax = j;
+ }
+ kx += j;
+/* L20: */
+ }
+ kpc = (imax - 1) * imax / 2 + 1;
+ if (imax > 1) {
+ i__1 = imax - 1;
+ jmax = izamax_(&i__1, &ap[kpc], &c__1);
+/* Computing MAX */
+ i__1 = kpc + jmax - 1;
+ d__3 = rowmax, d__4 = (d__1 = ap[i__1].r, abs(d__1)) + (
+ d__2 = d_imag(&ap[kpc + jmax - 1]), abs(d__2));
+ rowmax = max(d__3,d__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = kpc + imax - 1;
+ if ((d__1 = ap[i__1].r, abs(d__1)) >= alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k - kstep + 1;
+ if (kstep == 2) {
+ knc = knc - k + 1;
+ }
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the leading */
+/* submatrix A(1:k,1:k) */
+
+ i__1 = kp - 1;
+ zswap_(&i__1, &ap[knc], &c__1, &ap[kpc], &c__1);
+ kx = kpc + kp - 1;
+ i__1 = kk - 1;
+ for (j = kp + 1; j <= i__1; ++j) {
+ kx = kx + j - 1;
+ d_cnjg(&z__1, &ap[knc + j - 1]);
+ t.r = z__1.r, t.i = z__1.i;
+ i__2 = knc + j - 1;
+ d_cnjg(&z__1, &ap[kx]);
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ i__2 = kx;
+ ap[i__2].r = t.r, ap[i__2].i = t.i;
+/* L30: */
+ }
+ i__1 = kx + kk - 1;
+ d_cnjg(&z__1, &ap[kx + kk - 1]);
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ i__1 = knc + kk - 1;
+ r1 = ap[i__1].r;
+ i__1 = knc + kk - 1;
+ i__2 = kpc + kp - 1;
+ d__1 = ap[i__2].r;
+ ap[i__1].r = d__1, ap[i__1].i = 0.;
+ i__1 = kpc + kp - 1;
+ ap[i__1].r = r1, ap[i__1].i = 0.;
+ if (kstep == 2) {
+ i__1 = kc + k - 1;
+ i__2 = kc + k - 1;
+ d__1 = ap[i__2].r;
+ ap[i__1].r = d__1, ap[i__1].i = 0.;
+ i__1 = kc + k - 2;
+ t.r = ap[i__1].r, t.i = ap[i__1].i;
+ i__1 = kc + k - 2;
+ i__2 = kc + kp - 1;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kc + kp - 1;
+ ap[i__1].r = t.r, ap[i__1].i = t.i;
+ }
+ } else {
+ i__1 = kc + k - 1;
+ i__2 = kc + k - 1;
+ d__1 = ap[i__2].r;
+ ap[i__1].r = d__1, ap[i__1].i = 0.;
+ if (kstep == 2) {
+ i__1 = kc - 1;
+ i__2 = kc - 1;
+ d__1 = ap[i__2].r;
+ ap[i__1].r = d__1, ap[i__1].i = 0.;
+ }
+ }
+
+/* Update the leading submatrix */
+
+ if (kstep == 1) {
+
+/* 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 */
+
+/* Perform a rank-1 update of A(1:k-1,1:k-1) as */
+
+/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */
+
+ i__1 = kc + k - 1;
+ r1 = 1. / ap[i__1].r;
+ i__1 = k - 1;
+ d__1 = -r1;
+ zhpr_(uplo, &i__1, &d__1, &ap[kc], &c__1, &ap[1]);
+
+/* Store U(k) in column k */
+
+ i__1 = k - 1;
+ zdscal_(&i__1, &r1, &ap[kc], &c__1);
+ } 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) )' */
+/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */
+
+ if (k > 2) {
+
+ i__1 = k - 1 + (k - 1) * k / 2;
+ d__1 = ap[i__1].r;
+ d__2 = d_imag(&ap[k - 1 + (k - 1) * k / 2]);
+ d__ = dlapy2_(&d__1, &d__2);
+ i__1 = k - 1 + (k - 2) * (k - 1) / 2;
+ d22 = ap[i__1].r / d__;
+ i__1 = k + (k - 1) * k / 2;
+ d11 = ap[i__1].r / d__;
+ tt = 1. / (d11 * d22 - 1.);
+ i__1 = k - 1 + (k - 1) * k / 2;
+ z__1.r = ap[i__1].r / d__, z__1.i = ap[i__1].i / d__;
+ d12.r = z__1.r, d12.i = z__1.i;
+ d__ = tt / d__;
+
+ for (j = k - 2; j >= 1; --j) {
+ i__1 = j + (k - 2) * (k - 1) / 2;
+ z__3.r = d11 * ap[i__1].r, z__3.i = d11 * ap[i__1].i;
+ d_cnjg(&z__5, &d12);
+ i__2 = j + (k - 1) * k / 2;
+ z__4.r = z__5.r * ap[i__2].r - z__5.i * ap[i__2].i,
+ z__4.i = z__5.r * ap[i__2].i + z__5.i * ap[
+ i__2].r;
+ z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
+ z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
+ wkm1.r = z__1.r, wkm1.i = z__1.i;
+ i__1 = j + (k - 1) * k / 2;
+ z__3.r = d22 * ap[i__1].r, z__3.i = d22 * ap[i__1].i;
+ i__2 = j + (k - 2) * (k - 1) / 2;
+ z__4.r = d12.r * ap[i__2].r - d12.i * ap[i__2].i,
+ z__4.i = d12.r * ap[i__2].i + d12.i * ap[i__2]
+ .r;
+ z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
+ z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
+ wk.r = z__1.r, wk.i = z__1.i;
+ for (i__ = j; i__ >= 1; --i__) {
+ i__1 = i__ + (j - 1) * j / 2;
+ i__2 = i__ + (j - 1) * j / 2;
+ i__3 = i__ + (k - 1) * k / 2;
+ d_cnjg(&z__4, &wk);
+ z__3.r = ap[i__3].r * z__4.r - ap[i__3].i *
+ z__4.i, z__3.i = ap[i__3].r * z__4.i + ap[
+ i__3].i * z__4.r;
+ z__2.r = ap[i__2].r - z__3.r, z__2.i = ap[i__2].i
+ - z__3.i;
+ i__4 = i__ + (k - 2) * (k - 1) / 2;
+ d_cnjg(&z__6, &wkm1);
+ z__5.r = ap[i__4].r * z__6.r - ap[i__4].i *
+ z__6.i, z__5.i = ap[i__4].r * z__6.i + ap[
+ i__4].i * z__6.r;
+ z__1.r = z__2.r - z__5.r, z__1.i = z__2.i -
+ z__5.i;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+/* L40: */
+ }
+ i__1 = j + (k - 1) * k / 2;
+ ap[i__1].r = wk.r, ap[i__1].i = wk.i;
+ i__1 = j + (k - 2) * (k - 1) / 2;
+ ap[i__1].r = wkm1.r, ap[i__1].i = wkm1.i;
+ i__1 = j + (j - 1) * j / 2;
+ i__2 = j + (j - 1) * j / 2;
+ d__1 = ap[i__2].r;
+ z__1.r = d__1, z__1.i = 0.;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+/* L50: */
+ }
+
+ }
+
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k - 1] = -kp;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kstep;
+ kc = knc - k;
+ goto L10;
+
+ } else {
+
+/* Factorize A as L*D*L' using the lower triangle of A */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2 */
+
+ k = 1;
+ kc = 1;
+ npp = *n * (*n + 1) / 2;
+L60:
+ knc = kc;
+
+/* If K > N, exit from loop */
+
+ if (k > *n) {
+ goto L110;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = kc;
+ absakk = (d__1 = ap[i__1].r, abs(d__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ imax = k + izamax_(&i__1, &ap[kc + 1], &c__1);
+ i__1 = kc + imax - k;
+ colmax = (d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[kc +
+ imax - k]), abs(d__2));
+ } else {
+ colmax = 0.;
+ }
+
+ if (max(absakk,colmax) == 0.) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ i__1 = kc;
+ i__2 = kc;
+ d__1 = ap[i__2].r;
+ ap[i__1].r = d__1, ap[i__1].i = 0.;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ rowmax = 0.;
+ kx = kc + imax - k;
+ i__1 = imax - 1;
+ for (j = k; j <= i__1; ++j) {
+ i__2 = kx;
+ if ((d__1 = ap[i__2].r, abs(d__1)) + (d__2 = d_imag(&ap[
+ kx]), abs(d__2)) > rowmax) {
+ i__2 = kx;
+ rowmax = (d__1 = ap[i__2].r, abs(d__1)) + (d__2 =
+ d_imag(&ap[kx]), abs(d__2));
+ jmax = j;
+ }
+ kx = kx + *n - j;
+/* L70: */
+ }
+ kpc = npp - (*n - imax + 1) * (*n - imax + 2) / 2 + 1;
+ if (imax < *n) {
+ i__1 = *n - imax;
+ jmax = imax + izamax_(&i__1, &ap[kpc + 1], &c__1);
+/* Computing MAX */
+ i__1 = kpc + jmax - imax;
+ d__3 = rowmax, d__4 = (d__1 = ap[i__1].r, abs(d__1)) + (
+ d__2 = d_imag(&ap[kpc + jmax - imax]), abs(d__2));
+ rowmax = max(d__3,d__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = kpc;
+ if ((d__1 = ap[i__1].r, abs(d__1)) >= alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k + kstep - 1;
+ if (kstep == 2) {
+ knc = knc + *n - k + 1;
+ }
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the trailing */
+/* submatrix A(k:n,k:n) */
+
+ if (kp < *n) {
+ i__1 = *n - kp;
+ zswap_(&i__1, &ap[knc + kp - kk + 1], &c__1, &ap[kpc + 1],
+ &c__1);
+ }
+ kx = knc + kp - kk;
+ i__1 = kp - 1;
+ for (j = kk + 1; j <= i__1; ++j) {
+ kx = kx + *n - j + 1;
+ d_cnjg(&z__1, &ap[knc + j - kk]);
+ t.r = z__1.r, t.i = z__1.i;
+ i__2 = knc + j - kk;
+ d_cnjg(&z__1, &ap[kx]);
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ i__2 = kx;
+ ap[i__2].r = t.r, ap[i__2].i = t.i;
+/* L80: */
+ }
+ i__1 = knc + kp - kk;
+ d_cnjg(&z__1, &ap[knc + kp - kk]);
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ i__1 = knc;
+ r1 = ap[i__1].r;
+ i__1 = knc;
+ i__2 = kpc;
+ d__1 = ap[i__2].r;
+ ap[i__1].r = d__1, ap[i__1].i = 0.;
+ i__1 = kpc;
+ ap[i__1].r = r1, ap[i__1].i = 0.;
+ if (kstep == 2) {
+ i__1 = kc;
+ i__2 = kc;
+ d__1 = ap[i__2].r;
+ ap[i__1].r = d__1, ap[i__1].i = 0.;
+ i__1 = kc + 1;
+ t.r = ap[i__1].r, t.i = ap[i__1].i;
+ i__1 = kc + 1;
+ i__2 = kc + kp - k;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kc + kp - k;
+ ap[i__1].r = t.r, ap[i__1].i = t.i;
+ }
+ } else {
+ i__1 = kc;
+ i__2 = kc;
+ d__1 = ap[i__2].r;
+ ap[i__1].r = d__1, ap[i__1].i = 0.;
+ if (kstep == 2) {
+ i__1 = knc;
+ i__2 = knc;
+ d__1 = ap[i__2].r;
+ ap[i__1].r = d__1, ap[i__1].i = 0.;
+ }
+ }
+
+/* Update the trailing submatrix */
+
+ if (kstep == 1) {
+
+/* 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 < *n) {
+
+/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
+
+/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */
+
+ i__1 = kc;
+ r1 = 1. / ap[i__1].r;
+ i__1 = *n - k;
+ d__1 = -r1;
+ zhpr_(uplo, &i__1, &d__1, &ap[kc + 1], &c__1, &ap[kc + *n
+ - k + 1]);
+
+/* Store L(k) in column K */
+
+ i__1 = *n - k;
+ zdscal_(&i__1, &r1, &ap[kc + 1], &c__1);
+ }
+ } 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 */
+
+ if (k < *n - 1) {
+
+/* 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) )' */
+/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' */
+
+/* where L(k) and L(k+1) are the k-th and (k+1)-th */
+/* columns of L */
+
+ i__1 = k + 1 + (k - 1) * ((*n << 1) - k) / 2;
+ d__1 = ap[i__1].r;
+ d__2 = d_imag(&ap[k + 1 + (k - 1) * ((*n << 1) - k) / 2]);
+ d__ = dlapy2_(&d__1, &d__2);
+ i__1 = k + 1 + k * ((*n << 1) - k - 1) / 2;
+ d11 = ap[i__1].r / d__;
+ i__1 = k + (k - 1) * ((*n << 1) - k) / 2;
+ d22 = ap[i__1].r / d__;
+ tt = 1. / (d11 * d22 - 1.);
+ i__1 = k + 1 + (k - 1) * ((*n << 1) - k) / 2;
+ z__1.r = ap[i__1].r / d__, z__1.i = ap[i__1].i / d__;
+ d21.r = z__1.r, d21.i = z__1.i;
+ d__ = tt / d__;
+
+ i__1 = *n;
+ for (j = k + 2; j <= i__1; ++j) {
+ i__2 = j + (k - 1) * ((*n << 1) - k) / 2;
+ z__3.r = d11 * ap[i__2].r, z__3.i = d11 * ap[i__2].i;
+ i__3 = j + k * ((*n << 1) - k - 1) / 2;
+ z__4.r = d21.r * ap[i__3].r - d21.i * ap[i__3].i,
+ z__4.i = d21.r * ap[i__3].i + d21.i * ap[i__3]
+ .r;
+ z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
+ z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
+ wk.r = z__1.r, wk.i = z__1.i;
+ i__2 = j + k * ((*n << 1) - k - 1) / 2;
+ z__3.r = d22 * ap[i__2].r, z__3.i = d22 * ap[i__2].i;
+ d_cnjg(&z__5, &d21);
+ i__3 = j + (k - 1) * ((*n << 1) - k) / 2;
+ z__4.r = z__5.r * ap[i__3].r - z__5.i * ap[i__3].i,
+ z__4.i = z__5.r * ap[i__3].i + z__5.i * ap[
+ i__3].r;
+ z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
+ z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i;
+ wkp1.r = z__1.r, wkp1.i = z__1.i;
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * ((*n << 1) - j) / 2;
+ i__4 = i__ + (j - 1) * ((*n << 1) - j) / 2;
+ i__5 = i__ + (k - 1) * ((*n << 1) - k) / 2;
+ d_cnjg(&z__4, &wk);
+ z__3.r = ap[i__5].r * z__4.r - ap[i__5].i *
+ z__4.i, z__3.i = ap[i__5].r * z__4.i + ap[
+ i__5].i * z__4.r;
+ z__2.r = ap[i__4].r - z__3.r, z__2.i = ap[i__4].i
+ - z__3.i;
+ i__6 = i__ + k * ((*n << 1) - k - 1) / 2;
+ d_cnjg(&z__6, &wkp1);
+ z__5.r = ap[i__6].r * z__6.r - ap[i__6].i *
+ z__6.i, z__5.i = ap[i__6].r * z__6.i + ap[
+ i__6].i * z__6.r;
+ z__1.r = z__2.r - z__5.r, z__1.i = z__2.i -
+ z__5.i;
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+/* L90: */
+ }
+ i__2 = j + (k - 1) * ((*n << 1) - k) / 2;
+ ap[i__2].r = wk.r, ap[i__2].i = wk.i;
+ i__2 = j + k * ((*n << 1) - k - 1) / 2;
+ ap[i__2].r = wkp1.r, ap[i__2].i = wkp1.i;
+ i__2 = j + (j - 1) * ((*n << 1) - j) / 2;
+ i__3 = j + (j - 1) * ((*n << 1) - j) / 2;
+ d__1 = ap[i__3].r;
+ z__1.r = d__1, z__1.i = 0.;
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+/* L100: */
+ }
+ }
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k + 1] = -kp;
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kstep;
+ kc = knc + *n - k + 2;
+ goto L60;
+
+ }
+
+L110:
+ return 0;
+
+/* End of ZHPTRF */
+
+} /* zhptrf_ */
diff --git a/SRC/zhptri.c b/SRC/zhptri.c
new file mode 100644
index 0000000..f4e4938
--- /dev/null
+++ b/SRC/zhptri.c
@@ -0,0 +1,513 @@
+/* zhptri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b2 = {0.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zhptri_(char *uplo, integer *n, doublecomplex *ap,
+ integer *ipiv, doublecomplex *work, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublereal d__1;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ doublereal d__;
+ integer j, k;
+ doublereal t, ak;
+ integer kc, kp, kx, kpc, npp;
+ doublereal akp1;
+ doublecomplex temp, akkp1;
+ extern logical lsame_(char *, char *);
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ integer kstep;
+ logical upper;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zhpmv_(char *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *), zswap_(
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *)
+ , xerbla_(char *, integer *);
+ integer kcnext;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHPTRI computes the inverse of a complex Hermitian indefinite matrix */
+/* A in packed storage using the factorization A = U*D*U**H or */
+/* A = L*D*L**H computed by ZHPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**H; */
+/* = 'L': Lower triangular, form is A = L*D*L**H. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L as computed by ZHPTRF, */
+/* stored as a packed triangular matrix. */
+
+/* On exit, if INFO = 0, the (Hermitian) inverse of the original */
+/* matrix, stored as a packed triangular matrix. The j-th column */
+/* of inv(A) is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by ZHPTRF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* INFO (output) 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. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --work;
+ --ipiv;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHPTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ kp = *n * (*n + 1) / 2;
+ for (*info = *n; *info >= 1; --(*info)) {
+ i__1 = kp;
+ if (ipiv[*info] > 0 && (ap[i__1].r == 0. && ap[i__1].i == 0.)) {
+ return 0;
+ }
+ kp -= *info;
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ kp = 1;
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ i__2 = kp;
+ if (ipiv[*info] > 0 && (ap[i__2].r == 0. && ap[i__2].i == 0.)) {
+ return 0;
+ }
+ kp = kp + *n - *info + 1;
+/* L20: */
+ }
+ }
+ *info = 0;
+
+ if (upper) {
+
+/* Compute inv(A) from the factorization A = U*D*U'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+ kc = 1;
+L30:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L50;
+ }
+
+ kcnext = kc + k;
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = kc + k - 1;
+ i__2 = kc + k - 1;
+ d__1 = 1. / ap[i__2].r;
+ ap[i__1].r = d__1, ap[i__1].i = 0.;
+
+/* Compute column K of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ zcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zhpmv_(uplo, &i__1, &z__1, &ap[1], &work[1], &c__1, &c_b2, &
+ ap[kc], &c__1);
+ i__1 = kc + k - 1;
+ i__2 = kc + k - 1;
+ i__3 = k - 1;
+ zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kc], &c__1);
+ d__1 = z__2.r;
+ z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__2].i;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ t = z_abs(&ap[kcnext + k - 1]);
+ i__1 = kc + k - 1;
+ ak = ap[i__1].r / t;
+ i__1 = kcnext + k;
+ akp1 = ap[i__1].r / t;
+ i__1 = kcnext + k - 1;
+ z__1.r = ap[i__1].r / t, z__1.i = ap[i__1].i / t;
+ akkp1.r = z__1.r, akkp1.i = z__1.i;
+ d__ = t * (ak * akp1 - 1.);
+ i__1 = kc + k - 1;
+ d__1 = akp1 / d__;
+ ap[i__1].r = d__1, ap[i__1].i = 0.;
+ i__1 = kcnext + k;
+ d__1 = ak / d__;
+ ap[i__1].r = d__1, ap[i__1].i = 0.;
+ i__1 = kcnext + k - 1;
+ z__2.r = -akkp1.r, z__2.i = -akkp1.i;
+ z__1.r = z__2.r / d__, z__1.i = z__2.i / d__;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+
+/* Compute columns K and K+1 of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ zcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zhpmv_(uplo, &i__1, &z__1, &ap[1], &work[1], &c__1, &c_b2, &
+ ap[kc], &c__1);
+ i__1 = kc + k - 1;
+ i__2 = kc + k - 1;
+ i__3 = k - 1;
+ zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kc], &c__1);
+ d__1 = z__2.r;
+ z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__2].i;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ i__1 = kcnext + k - 1;
+ i__2 = kcnext + k - 1;
+ i__3 = k - 1;
+ zdotc_(&z__2, &i__3, &ap[kc], &c__1, &ap[kcnext], &c__1);
+ z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ i__1 = k - 1;
+ zcopy_(&i__1, &ap[kcnext], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zhpmv_(uplo, &i__1, &z__1, &ap[1], &work[1], &c__1, &c_b2, &
+ ap[kcnext], &c__1);
+ i__1 = kcnext + k;
+ i__2 = kcnext + k;
+ i__3 = k - 1;
+ zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kcnext], &c__1);
+ d__1 = z__2.r;
+ z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__2].i;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ }
+ kstep = 2;
+ kcnext = kcnext + k + 1;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the leading */
+/* submatrix A(1:k+1,1:k+1) */
+
+ kpc = (kp - 1) * kp / 2 + 1;
+ i__1 = kp - 1;
+ zswap_(&i__1, &ap[kc], &c__1, &ap[kpc], &c__1);
+ kx = kpc + kp - 1;
+ i__1 = k - 1;
+ for (j = kp + 1; j <= i__1; ++j) {
+ kx = kx + j - 1;
+ d_cnjg(&z__1, &ap[kc + j - 1]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__2 = kc + j - 1;
+ d_cnjg(&z__1, &ap[kx]);
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ i__2 = kx;
+ ap[i__2].r = temp.r, ap[i__2].i = temp.i;
+/* L40: */
+ }
+ i__1 = kc + kp - 1;
+ d_cnjg(&z__1, &ap[kc + kp - 1]);
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ i__1 = kc + k - 1;
+ temp.r = ap[i__1].r, temp.i = ap[i__1].i;
+ i__1 = kc + k - 1;
+ i__2 = kpc + kp - 1;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kpc + kp - 1;
+ ap[i__1].r = temp.r, ap[i__1].i = temp.i;
+ if (kstep == 2) {
+ i__1 = kc + k + k - 1;
+ temp.r = ap[i__1].r, temp.i = ap[i__1].i;
+ i__1 = kc + k + k - 1;
+ i__2 = kc + k + kp - 1;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kc + k + kp - 1;
+ ap[i__1].r = temp.r, ap[i__1].i = temp.i;
+ }
+ }
+
+ k += kstep;
+ kc = kcnext;
+ goto L30;
+L50:
+
+ ;
+ } else {
+
+/* Compute inv(A) from the factorization A = L*D*L'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ npp = *n * (*n + 1) / 2;
+ k = *n;
+ kc = npp;
+L60:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L80;
+ }
+
+ kcnext = kc - (*n - k + 2);
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = kc;
+ i__2 = kc;
+ d__1 = 1. / ap[i__2].r;
+ ap[i__1].r = d__1, ap[i__1].i = 0.;
+
+/* Compute column K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ zcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zhpmv_(uplo, &i__1, &z__1, &ap[kc + *n - k + 1], &work[1], &
+ c__1, &c_b2, &ap[kc + 1], &c__1);
+ i__1 = kc;
+ i__2 = kc;
+ i__3 = *n - k;
+ zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1);
+ d__1 = z__2.r;
+ z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__2].i;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ t = z_abs(&ap[kcnext + 1]);
+ i__1 = kcnext;
+ ak = ap[i__1].r / t;
+ i__1 = kc;
+ akp1 = ap[i__1].r / t;
+ i__1 = kcnext + 1;
+ z__1.r = ap[i__1].r / t, z__1.i = ap[i__1].i / t;
+ akkp1.r = z__1.r, akkp1.i = z__1.i;
+ d__ = t * (ak * akp1 - 1.);
+ i__1 = kcnext;
+ d__1 = akp1 / d__;
+ ap[i__1].r = d__1, ap[i__1].i = 0.;
+ i__1 = kc;
+ d__1 = ak / d__;
+ ap[i__1].r = d__1, ap[i__1].i = 0.;
+ i__1 = kcnext + 1;
+ z__2.r = -akkp1.r, z__2.i = -akkp1.i;
+ z__1.r = z__2.r / d__, z__1.i = z__2.i / d__;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+
+/* Compute columns K-1 and K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ zcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zhpmv_(uplo, &i__1, &z__1, &ap[kc + (*n - k + 1)], &work[1], &
+ c__1, &c_b2, &ap[kc + 1], &c__1);
+ i__1 = kc;
+ i__2 = kc;
+ i__3 = *n - k;
+ zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1);
+ d__1 = z__2.r;
+ z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__2].i;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ i__1 = kcnext + 1;
+ i__2 = kcnext + 1;
+ i__3 = *n - k;
+ zdotc_(&z__2, &i__3, &ap[kc + 1], &c__1, &ap[kcnext + 2], &
+ c__1);
+ z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ i__1 = *n - k;
+ zcopy_(&i__1, &ap[kcnext + 2], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zhpmv_(uplo, &i__1, &z__1, &ap[kc + (*n - k + 1)], &work[1], &
+ c__1, &c_b2, &ap[kcnext + 2], &c__1);
+ i__1 = kcnext;
+ i__2 = kcnext;
+ i__3 = *n - k;
+ zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kcnext + 2], &c__1);
+ d__1 = z__2.r;
+ z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__2].i;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ }
+ kstep = 2;
+ kcnext -= *n - k + 3;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the trailing */
+/* submatrix A(k-1:n,k-1:n) */
+
+ kpc = npp - (*n - kp + 1) * (*n - kp + 2) / 2 + 1;
+ if (kp < *n) {
+ i__1 = *n - kp;
+ zswap_(&i__1, &ap[kc + kp - k + 1], &c__1, &ap[kpc + 1], &
+ c__1);
+ }
+ kx = kc + kp - k;
+ i__1 = kp - 1;
+ for (j = k + 1; j <= i__1; ++j) {
+ kx = kx + *n - j + 1;
+ d_cnjg(&z__1, &ap[kc + j - k]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__2 = kc + j - k;
+ d_cnjg(&z__1, &ap[kx]);
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ i__2 = kx;
+ ap[i__2].r = temp.r, ap[i__2].i = temp.i;
+/* L70: */
+ }
+ i__1 = kc + kp - k;
+ d_cnjg(&z__1, &ap[kc + kp - k]);
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ i__1 = kc;
+ temp.r = ap[i__1].r, temp.i = ap[i__1].i;
+ i__1 = kc;
+ i__2 = kpc;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kpc;
+ ap[i__1].r = temp.r, ap[i__1].i = temp.i;
+ if (kstep == 2) {
+ i__1 = kc - *n + k - 1;
+ temp.r = ap[i__1].r, temp.i = ap[i__1].i;
+ i__1 = kc - *n + k - 1;
+ i__2 = kc - *n + kp - 1;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kc - *n + kp - 1;
+ ap[i__1].r = temp.r, ap[i__1].i = temp.i;
+ }
+ }
+
+ k -= kstep;
+ kc = kcnext;
+ goto L60;
+L80:
+ ;
+ }
+
+ return 0;
+
+/* End of ZHPTRI */
+
+} /* zhptri_ */
diff --git a/SRC/zhptrs.c b/SRC/zhptrs.c
new file mode 100644
index 0000000..0c35c79
--- /dev/null
+++ b/SRC/zhptrs.c
@@ -0,0 +1,532 @@
+/* zhptrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zhptrs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *ap, integer *ipiv, doublecomplex *b, integer *ldb,
+ integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
+ doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer j, k;
+ doublereal s;
+ doublecomplex ak, bk;
+ integer kc, kp;
+ doublecomplex akm1, bkm1, akm1k;
+ extern logical lsame_(char *, char *);
+ doublecomplex denom;
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int zgeru_(integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), xerbla_(char *, integer *), zdscal_(integer *, doublereal *, doublecomplex *,
+ integer *), zlacgv_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHPTRS solves a system of linear equations A*X = B with a complex */
+/* Hermitian matrix A stored in packed format using the factorization */
+/* A = U*D*U**H or A = L*D*L**H computed by ZHPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**H; */
+/* = 'L': Lower triangular, form is A = L*D*L**H. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by ZHPTRF, stored as a */
+/* packed triangular matrix. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by ZHPTRF. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ap;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHPTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B, where A = U*D*U'. */
+
+/* First solve U*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L10:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L30;
+ }
+
+ kc -= k;
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &ap[kc], &c__1, &b[k + b_dim1], ldb, &
+ b[b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = kc + k - 1;
+ s = 1. / ap[i__1].r;
+ zdscal_(nrhs, &s, &b[k + b_dim1], ldb);
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K-1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k - 1) {
+ zswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ i__1 = k - 2;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &ap[kc], &c__1, &b[k + b_dim1], ldb, &
+ b[b_dim1 + 1], ldb);
+ i__1 = k - 2;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &ap[kc - (k - 1)], &c__1, &b[k - 1 +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = kc + k - 2;
+ akm1k.r = ap[i__1].r, akm1k.i = ap[i__1].i;
+ z_div(&z__1, &ap[kc - 1], &akm1k);
+ akm1.r = z__1.r, akm1.i = z__1.i;
+ d_cnjg(&z__2, &akm1k);
+ z_div(&z__1, &ap[kc + k - 1], &z__2);
+ ak.r = z__1.r, ak.i = z__1.i;
+ z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i +
+ akm1.i * ak.r;
+ z__1.r = z__2.r - 1., z__1.i = z__2.i - 0.;
+ denom.r = z__1.r, denom.i = z__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ z_div(&z__1, &b[k - 1 + j * b_dim1], &akm1k);
+ bkm1.r = z__1.r, bkm1.i = z__1.i;
+ d_cnjg(&z__2, &akm1k);
+ z_div(&z__1, &b[k + j * b_dim1], &z__2);
+ bk.r = z__1.r, bk.i = z__1.i;
+ i__2 = k - 1 + j * b_dim1;
+ z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r *
+ bkm1.i + ak.i * bkm1.r;
+ z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i;
+ z_div(&z__1, &z__2, &denom);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + j * b_dim1;
+ z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r *
+ bk.i + akm1.i * bk.r;
+ z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i;
+ z_div(&z__1, &z__2, &denom);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L20: */
+ }
+ kc = kc - k + 1;
+ k += -2;
+ }
+
+ goto L10;
+L30:
+
+/* Next solve U'*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+ kc = 1;
+L40:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L50;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(U'(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k > 1) {
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset]
+, ldb, &ap[kc], &c__1, &c_b1, &b[k + b_dim1], ldb);
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ }
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ kc += k;
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ if (k > 1) {
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset]
+, ldb, &ap[kc], &c__1, &c_b1, &b[k + b_dim1], ldb);
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+
+ zlacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset]
+, ldb, &ap[kc + k], &c__1, &c_b1, &b[k + 1 + b_dim1],
+ ldb);
+ zlacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
+ }
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ kc = kc + (k << 1) + 1;
+ k += 2;
+ }
+
+ goto L40;
+L50:
+
+ ;
+ } else {
+
+/* Solve A*X = B, where A = L*D*L'. */
+
+/* First solve L*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+ kc = 1;
+L60:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L80;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &ap[kc + 1], &c__1, &b[k + b_dim1],
+ ldb, &b[k + 1 + b_dim1], ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = kc;
+ s = 1. / ap[i__1].r;
+ zdscal_(nrhs, &s, &b[k + b_dim1], ldb);
+ kc = kc + *n - k + 1;
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K+1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k + 1) {
+ zswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ if (k < *n - 1) {
+ i__1 = *n - k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &ap[kc + 2], &c__1, &b[k + b_dim1],
+ ldb, &b[k + 2 + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &ap[kc + *n - k + 2], &c__1, &b[k
+ + 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = kc + 1;
+ akm1k.r = ap[i__1].r, akm1k.i = ap[i__1].i;
+ d_cnjg(&z__2, &akm1k);
+ z_div(&z__1, &ap[kc], &z__2);
+ akm1.r = z__1.r, akm1.i = z__1.i;
+ z_div(&z__1, &ap[kc + *n - k + 1], &akm1k);
+ ak.r = z__1.r, ak.i = z__1.i;
+ z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i +
+ akm1.i * ak.r;
+ z__1.r = z__2.r - 1., z__1.i = z__2.i - 0.;
+ denom.r = z__1.r, denom.i = z__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ d_cnjg(&z__2, &akm1k);
+ z_div(&z__1, &b[k + j * b_dim1], &z__2);
+ bkm1.r = z__1.r, bkm1.i = z__1.i;
+ z_div(&z__1, &b[k + 1 + j * b_dim1], &akm1k);
+ bk.r = z__1.r, bk.i = z__1.i;
+ i__2 = k + j * b_dim1;
+ z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r *
+ bkm1.i + ak.i * bkm1.r;
+ z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i;
+ z_div(&z__1, &z__2, &denom);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r *
+ bk.i + akm1.i * bk.r;
+ z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i;
+ z_div(&z__1, &z__2, &denom);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L70: */
+ }
+ kc = kc + (*n - k << 1) + 1;
+ k += 2;
+ }
+
+ goto L60;
+L80:
+
+/* Next solve L'*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L90:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L100;
+ }
+
+ kc -= *n - k + 1;
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(L'(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 +
+ b_dim1], ldb, &ap[kc + 1], &c__1, &c_b1, &b[k +
+ b_dim1], ldb);
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ }
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ if (k < *n) {
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 +
+ b_dim1], ldb, &ap[kc + 1], &c__1, &c_b1, &b[k +
+ b_dim1], ldb);
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+
+ zlacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 +
+ b_dim1], ldb, &ap[kc - (*n - k)], &c__1, &c_b1, &b[k
+ - 1 + b_dim1], ldb);
+ zlacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
+ }
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ kc -= *n - k + 2;
+ k += -2;
+ }
+
+ goto L90;
+L100:
+ ;
+ }
+
+ return 0;
+
+/* End of ZHPTRS */
+
+} /* zhptrs_ */
diff --git a/SRC/zhsein.c b/SRC/zhsein.c
new file mode 100644
index 0000000..0e27b9b
--- /dev/null
+++ b/SRC/zhsein.c
@@ -0,0 +1,433 @@
+/* zhsein.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static logical c_false = FALSE_;
+static logical c_true = TRUE_;
+
+/* Subroutine */ int zhsein_(char *side, char *eigsrc, char *initv, logical *
+ select, integer *n, doublecomplex *h__, integer *ldh, doublecomplex *
+ w, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr,
+ integer *mm, integer *m, doublecomplex *work, doublereal *rwork,
+ integer *ifaill, integer *ifailr, integer *info)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
+ i__2, i__3;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, k, kl, kr, ks;
+ doublecomplex wk;
+ integer kln;
+ doublereal ulp, eps3, unfl;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical leftv, bothv;
+ doublereal hnorm;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), zlaein_(
+ logical *, logical *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *,
+ doublereal *);
+ logical noinit;
+ integer ldwork;
+ logical rightv, fromqr;
+ doublereal smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHSEIN uses inverse iteration to find specified right and/or left */
+/* eigenvectors of a complex upper Hessenberg matrix H. */
+
+/* The right eigenvector x and the left eigenvector y of the matrix H */
+/* corresponding to an eigenvalue w are defined by: */
+
+/* H * x = w * x, y**h * H = w * y**h */
+
+/* where y**h denotes the conjugate transpose of the vector y. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'R': compute right eigenvectors only; */
+/* = 'L': compute left eigenvectors only; */
+/* = 'B': compute both right and left eigenvectors. */
+
+/* EIGSRC (input) CHARACTER*1 */
+/* Specifies the source of eigenvalues supplied in W: */
+/* = 'Q': the eigenvalues were found using ZHSEQR; thus, if */
+/* H has zero subdiagonal elements, and so is */
+/* block-triangular, then the j-th eigenvalue can be */
+/* assumed to be an eigenvalue of the block containing */
+/* the j-th row/column. This property allows ZHSEIN to */
+/* perform inverse iteration on just one diagonal block. */
+/* = 'N': no assumptions are made on the correspondence */
+/* between eigenvalues and diagonal blocks. In this */
+/* case, ZHSEIN must always perform inverse iteration */
+/* using the whole matrix H. */
+
+/* INITV (input) CHARACTER*1 */
+/* = 'N': no initial vectors are supplied; */
+/* = 'U': user-supplied initial vectors are stored in the arrays */
+/* VL and/or VR. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* Specifies the eigenvectors to be computed. To select the */
+/* eigenvector corresponding to the eigenvalue W(j), */
+/* SELECT(j) must be set to .TRUE.. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N >= 0. */
+
+/* H (input) COMPLEX*16 array, dimension (LDH,N) */
+/* The upper Hessenberg matrix H. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH >= max(1,N). */
+
+/* W (input/output) COMPLEX*16 array, dimension (N) */
+/* On entry, the eigenvalues of H. */
+/* On exit, the real parts of W may have been altered since */
+/* close eigenvalues are perturbed slightly in searching for */
+/* independent eigenvectors. */
+
+/* VL (input/output) COMPLEX*16 array, dimension (LDVL,MM) */
+/* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must */
+/* contain starting vectors for the inverse iteration for the */
+/* left eigenvectors; the starting vector for each eigenvector */
+/* must be in the same column in which the eigenvector will be */
+/* stored. */
+/* On exit, if SIDE = 'L' or 'B', the left eigenvectors */
+/* specified by SELECT will be stored consecutively in the */
+/* columns of VL, in the same order as their eigenvalues. */
+/* If SIDE = 'R', VL is not referenced. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. */
+/* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. */
+
+/* VR (input/output) COMPLEX*16 array, dimension (LDVR,MM) */
+/* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must */
+/* contain starting vectors for the inverse iteration for the */
+/* right eigenvectors; the starting vector for each eigenvector */
+/* must be in the same column in which the eigenvector will be */
+/* stored. */
+/* On exit, if SIDE = 'R' or 'B', the right eigenvectors */
+/* specified by SELECT will be stored consecutively in the */
+/* columns of VR, in the same order as their eigenvalues. */
+/* If SIDE = 'L', VR is not referenced. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. */
+/* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. */
+
+/* MM (input) INTEGER */
+/* The number of columns in the arrays VL and/or VR. MM >= M. */
+
+/* M (output) INTEGER */
+/* The number of columns in the arrays VL and/or VR required to */
+/* store the eigenvectors (= the number of .TRUE. elements in */
+/* SELECT). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* IFAILL (output) INTEGER array, dimension (MM) */
+/* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left */
+/* eigenvector in the i-th column of VL (corresponding to the */
+/* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the */
+/* eigenvector converged satisfactorily. */
+/* If SIDE = 'R', IFAILL is not referenced. */
+
+/* IFAILR (output) INTEGER array, dimension (MM) */
+/* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right */
+/* eigenvector in the i-th column of VR (corresponding to the */
+/* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the */
+/* eigenvector converged satisfactorily. */
+/* If SIDE = 'L', IFAILR is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, i is the number of eigenvectors which */
+/* failed to converge; see IFAILL and IFAILR for further */
+/* details. */
+
+/* Further Details */
+/* =============== */
+
+/* Each eigenvector is normalized so that the element of largest */
+/* magnitude has magnitude 1; here the magnitude of a complex number */
+/* (x,y) is taken to be |x|+|y|. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters. */
+
+ /* Parameter adjustments */
+ --select;
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --w;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+ --rwork;
+ --ifaill;
+ --ifailr;
+
+ /* Function Body */
+ bothv = lsame_(side, "B");
+ rightv = lsame_(side, "R") || bothv;
+ leftv = lsame_(side, "L") || bothv;
+
+ fromqr = lsame_(eigsrc, "Q");
+
+ noinit = lsame_(initv, "N");
+
+/* Set M to the number of columns required to store the selected */
+/* eigenvectors. */
+
+ *m = 0;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (select[k]) {
+ ++(*m);
+ }
+/* L10: */
+ }
+
+ *info = 0;
+ if (! rightv && ! leftv) {
+ *info = -1;
+ } else if (! fromqr && ! lsame_(eigsrc, "N")) {
+ *info = -2;
+ } else if (! noinit && ! lsame_(initv, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*ldh < max(1,*n)) {
+ *info = -7;
+ } else if (*ldvl < 1 || leftv && *ldvl < *n) {
+ *info = -10;
+ } else if (*ldvr < 1 || rightv && *ldvr < *n) {
+ *info = -12;
+ } else if (*mm < *m) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZHSEIN", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Set machine-dependent constants. */
+
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Precision");
+ smlnum = unfl * (*n / ulp);
+
+ ldwork = *n;
+
+ kl = 1;
+ kln = 0;
+ if (fromqr) {
+ kr = 0;
+ } else {
+ kr = *n;
+ }
+ ks = 1;
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (select[k]) {
+
+/* Compute eigenvector(s) corresponding to W(K). */
+
+ if (fromqr) {
+
+/* If affiliation of eigenvalues is known, check whether */
+/* the matrix splits. */
+
+/* Determine KL and KR such that 1 <= KL <= K <= KR <= N */
+/* and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or */
+/* KR = N). */
+
+/* Then inverse iteration can be performed with the */
+/* submatrix H(KL:N,KL:N) for a left eigenvector, and with */
+/* the submatrix H(1:KR,1:KR) for a right eigenvector. */
+
+ i__2 = kl + 1;
+ for (i__ = k; i__ >= i__2; --i__) {
+ i__3 = i__ + (i__ - 1) * h_dim1;
+ if (h__[i__3].r == 0. && h__[i__3].i == 0.) {
+ goto L30;
+ }
+/* L20: */
+ }
+L30:
+ kl = i__;
+ if (k > kr) {
+ i__2 = *n - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ i__3 = i__ + 1 + i__ * h_dim1;
+ if (h__[i__3].r == 0. && h__[i__3].i == 0.) {
+ goto L50;
+ }
+/* L40: */
+ }
+L50:
+ kr = i__;
+ }
+ }
+
+ if (kl != kln) {
+ kln = kl;
+
+/* Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it */
+/* has not ben computed before. */
+
+ i__2 = kr - kl + 1;
+ hnorm = zlanhs_("I", &i__2, &h__[kl + kl * h_dim1], ldh, &
+ rwork[1]);
+ if (hnorm > 0.) {
+ eps3 = hnorm * ulp;
+ } else {
+ eps3 = smlnum;
+ }
+ }
+
+/* Perturb eigenvalue if it is close to any previous */
+/* selected eigenvalues affiliated to the submatrix */
+/* H(KL:KR,KL:KR). Close roots are modified by EPS3. */
+
+ i__2 = k;
+ wk.r = w[i__2].r, wk.i = w[i__2].i;
+L60:
+ i__2 = kl;
+ for (i__ = k - 1; i__ >= i__2; --i__) {
+ i__3 = i__;
+ z__2.r = w[i__3].r - wk.r, z__2.i = w[i__3].i - wk.i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ if (select[i__] && (d__1 = z__1.r, abs(d__1)) + (d__2 =
+ d_imag(&z__1), abs(d__2)) < eps3) {
+ z__1.r = wk.r + eps3, z__1.i = wk.i;
+ wk.r = z__1.r, wk.i = z__1.i;
+ goto L60;
+ }
+/* L70: */
+ }
+ i__2 = k;
+ w[i__2].r = wk.r, w[i__2].i = wk.i;
+
+ if (leftv) {
+
+/* Compute left eigenvector. */
+
+ i__2 = *n - kl + 1;
+ zlaein_(&c_false, &noinit, &i__2, &h__[kl + kl * h_dim1], ldh,
+ &wk, &vl[kl + ks * vl_dim1], &work[1], &ldwork, &
+ rwork[1], &eps3, &smlnum, &iinfo);
+ if (iinfo > 0) {
+ ++(*info);
+ ifaill[ks] = k;
+ } else {
+ ifaill[ks] = 0;
+ }
+ i__2 = kl - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + ks * vl_dim1;
+ vl[i__3].r = 0., vl[i__3].i = 0.;
+/* L80: */
+ }
+ }
+ if (rightv) {
+
+/* Compute right eigenvector. */
+
+ zlaein_(&c_true, &noinit, &kr, &h__[h_offset], ldh, &wk, &vr[
+ ks * vr_dim1 + 1], &work[1], &ldwork, &rwork[1], &
+ eps3, &smlnum, &iinfo);
+ if (iinfo > 0) {
+ ++(*info);
+ ifailr[ks] = k;
+ } else {
+ ifailr[ks] = 0;
+ }
+ i__2 = *n;
+ for (i__ = kr + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + ks * vr_dim1;
+ vr[i__3].r = 0., vr[i__3].i = 0.;
+/* L90: */
+ }
+ }
+ ++ks;
+ }
+/* L100: */
+ }
+
+ return 0;
+
+/* End of ZHSEIN */
+
+} /* zhsein_ */
diff --git a/SRC/zhseqr.c b/SRC/zhseqr.c
new file mode 100644
index 0000000..dc69792
--- /dev/null
+++ b/SRC/zhseqr.c
@@ -0,0 +1,483 @@
+/* zhseqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+static integer c__12 = 12;
+static integer c__2 = 2;
+static integer c__49 = 49;
+
+/* Subroutine */ int zhseqr_(char *job, char *compz, integer *n, integer *ilo,
+ integer *ihi, doublecomplex *h__, integer *ldh, doublecomplex *w,
+ doublecomplex *z__, integer *ldz, doublecomplex *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3[2];
+ doublereal d__1, d__2, d__3;
+ doublecomplex z__1;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ doublecomplex hl[2401] /* was [49][49] */;
+ integer kbot, nmin;
+ extern logical lsame_(char *, char *);
+ logical initz;
+ doublecomplex workl[49];
+ logical wantt, wantz;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zlaqr0_(logical *, logical *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *), xerbla_(char *, integer *
+);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zlahqr_(logical *, logical *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *, integer *),
+ zlacpy_(char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zlaset_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *);
+ logical lquery;
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+/* Purpose */
+/* ======= */
+
+/* ZHSEQR computes the eigenvalues of a Hessenberg matrix H */
+/* and, optionally, the matrices T and Z from the Schur decomposition */
+/* H = Z T Z**H, where T is an upper triangular matrix (the */
+/* Schur form), and Z is the unitary matrix of Schur vectors. */
+
+/* Optionally Z may be postmultiplied into an input unitary */
+/* matrix Q so that this routine can give the Schur factorization */
+/* of a matrix A which has been reduced to the Hessenberg form H */
+/* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* = 'E': compute eigenvalues only; */
+/* = 'S': compute eigenvalues and the Schur form T. */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': no Schur vectors are computed; */
+/* = 'I': Z is initialized to the unit matrix and the matrix Z */
+/* of Schur vectors of H is returned; */
+/* = 'V': Z must contain an unitary matrix Q on entry, and */
+/* the product Q*Z is returned. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N .GE. 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that H is already upper triangular in rows */
+/* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */
+/* set by a previous call to ZGEBAL, and then passed to ZGEHRD */
+/* when the matrix output by ZGEBAL is reduced to Hessenberg */
+/* form. Otherwise ILO and IHI should be set to 1 and N */
+/* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */
+/* If N = 0, then ILO = 1 and IHI = 0. */
+
+/* H (input/output) COMPLEX*16 array, dimension (LDH,N) */
+/* On entry, the upper Hessenberg matrix H. */
+/* On exit, if INFO = 0 and JOB = 'S', H contains the upper */
+/* triangular matrix T from the Schur decomposition (the */
+/* Schur form). If INFO = 0 and JOB = 'E', the contents of */
+/* H are unspecified on exit. (The output value of H when */
+/* INFO.GT.0 is given under the description of INFO below.) */
+
+/* Unlike earlier versions of ZHSEQR, this subroutine may */
+/* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1 */
+/* or j = IHI+1, IHI+2, ... N. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH .GE. max(1,N). */
+
+/* W (output) COMPLEX*16 array, dimension (N) */
+/* The computed eigenvalues. If JOB = 'S', the eigenvalues are */
+/* stored in the same order as on the diagonal of the Schur */
+/* form returned in H, with W(i) = H(i,i). */
+
+/* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) */
+/* If COMPZ = 'N', Z is not referenced. */
+/* If COMPZ = 'I', on entry Z need not be set and on exit, */
+/* if INFO = 0, Z contains the unitary matrix Z of the Schur */
+/* vectors of H. If COMPZ = 'V', on entry Z must contain an */
+/* N-by-N matrix Q, which is assumed to be equal to the unit */
+/* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, */
+/* if INFO = 0, Z contains Q*Z. */
+/* Normally Q is the unitary matrix generated by ZUNGHR */
+/* after the call to ZGEHRD which formed the Hessenberg matrix */
+/* H. (The output value of Z when INFO.GT.0 is given under */
+/* the description of INFO below.) */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. if COMPZ = 'I' or */
+/* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns an estimate of */
+/* the optimal value for LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK .GE. max(1,N) */
+/* is sufficient and delivers very good and sometimes */
+/* optimal performance. However, LWORK as large as 11*N */
+/* may be required for optimal performance. A workspace */
+/* query is recommended to determine the optimal workspace */
+/* size. */
+
+/* If LWORK = -1, then ZHSEQR does a workspace query. */
+/* In this case, ZHSEQR checks the input parameters and */
+/* estimates the optimal workspace size for the given */
+/* values of N, ILO and IHI. The estimate is returned */
+/* in WORK(1). No error message related to LWORK is */
+/* issued by XERBLA. Neither H nor Z are accessed. */
+
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* .LT. 0: if INFO = -i, the i-th argument had an illegal */
+/* value */
+/* .GT. 0: if INFO = i, ZHSEQR failed to compute all of */
+/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */
+/* and WI contain those eigenvalues which have been */
+/* successfully computed. (Failures are rare.) */
+
+/* If INFO .GT. 0 and JOB = 'E', then on exit, the */
+/* remaining unconverged eigenvalues are the eigen- */
+/* values of the upper Hessenberg matrix rows and */
+/* columns ILO through INFO of the final, output */
+/* value of H. */
+
+/* If INFO .GT. 0 and JOB = 'S', then on exit */
+
+/* (*) (initial value of H)*U = U*(final value of H) */
+
+/* where U is a unitary matrix. The final */
+/* value of H is upper Hessenberg and triangular in */
+/* rows and columns INFO+1 through IHI. */
+
+/* If INFO .GT. 0 and COMPZ = 'V', then on exit */
+
+/* (final value of Z) = (initial value of Z)*U */
+
+/* where U is the unitary matrix in (*) (regard- */
+/* less of the value of JOB.) */
+
+/* If INFO .GT. 0 and COMPZ = 'I', then on exit */
+/* (final value of Z) = U */
+/* where U is the unitary matrix in (*) (regard- */
+/* less of the value of JOB.) */
+
+/* If INFO .GT. 0 and COMPZ = 'N', then Z is not */
+/* accessed. */
+
+/* ================================================================ */
+/* Default values supplied by */
+/* ILAENV(ISPEC,'ZHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). */
+/* It is suggested that these defaults be adjusted in order */
+/* to attain best performance in each particular */
+/* computational environment. */
+
+/* ISPEC=12: The ZLAHQR vs ZLAQR0 crossover point. */
+/* Default: 75. (Must be at least 11.) */
+
+/* ISPEC=13: Recommended deflation window size. */
+/* This depends on ILO, IHI and NS. NS is the */
+/* number of simultaneous shifts returned */
+/* by ILAENV(ISPEC=15). (See ISPEC=15 below.) */
+/* The default for (IHI-ILO+1).LE.500 is NS. */
+/* The default for (IHI-ILO+1).GT.500 is 3*NS/2. */
+
+/* ISPEC=14: Nibble crossover point. (See IPARMQ for */
+/* details.) Default: 14% of deflation window */
+/* size. */
+
+/* ISPEC=15: Number of simultaneous shifts in a multishift */
+/* QR iteration. */
+
+/* If IHI-ILO+1 is ... */
+
+/* greater than ...but less ... the */
+/* or equal to ... than default is */
+
+/* 1 30 NS = 2(+) */
+/* 30 60 NS = 4(+) */
+/* 60 150 NS = 10(+) */
+/* 150 590 NS = ** */
+/* 590 3000 NS = 64 */
+/* 3000 6000 NS = 128 */
+/* 6000 infinity NS = 256 */
+
+/* (+) By default some or all matrices of this order */
+/* are passed to the implicit double shift routine */
+/* ZLAHQR and this parameter is ignored. See */
+/* ISPEC=12 above and comments in IPARMQ for */
+/* details. */
+
+/* (**) The asterisks (**) indicate an ad-hoc */
+/* function of N increasing from 10 to 64. */
+
+/* ISPEC=16: Select structured matrix multiply. */
+/* If the number of simultaneous shifts (specified */
+/* by ISPEC=15) is less than 14, then the default */
+/* for ISPEC=16 is 0. Otherwise the default for */
+/* ISPEC=16 is 2. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* References: */
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */
+/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */
+/* 929--947, 2002. */
+
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */
+/* of Matrix Analysis, volume 23, pages 948--973, 2002. */
+
+/* ================================================================ */
+/* .. Parameters .. */
+
+/* ==== Matrices of order NTINY or smaller must be processed by */
+/* . ZLAHQR because of insufficient subdiagonal scratch space. */
+/* . (This is a hard limit.) ==== */
+
+/* ==== NL allocates some local workspace to help small matrices */
+/* . through a rare ZLAHQR failure. NL .GT. NTINY = 11 is */
+/* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- */
+/* . mended. (The default value of NMIN is 75.) Using NL = 49 */
+/* . allows up to six simultaneous shifts and a 16-by-16 */
+/* . deflation window. ==== */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* ==== Decode and check the input parameters. ==== */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ wantt = lsame_(job, "S");
+ initz = lsame_(compz, "I");
+ wantz = initz || lsame_(compz, "V");
+ d__1 = (doublereal) max(1,*n);
+ z__1.r = d__1, z__1.i = 0.;
+ work[1].r = z__1.r, work[1].i = z__1.i;
+ lquery = *lwork == -1;
+
+ *info = 0;
+ if (! lsame_(job, "E") && ! wantt) {
+ *info = -1;
+ } else if (! lsame_(compz, "N") && ! wantz) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*ilo < 1 || *ilo > max(1,*n)) {
+ *info = -4;
+ } else if (*ihi < min(*ilo,*n) || *ihi > *n) {
+ *info = -5;
+ } else if (*ldh < max(1,*n)) {
+ *info = -7;
+ } else if (*ldz < 1 || wantz && *ldz < max(1,*n)) {
+ *info = -10;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -12;
+ }
+
+ if (*info != 0) {
+
+/* ==== Quick return in case of invalid argument. ==== */
+
+ i__1 = -(*info);
+ xerbla_("ZHSEQR", &i__1);
+ return 0;
+
+ } else if (*n == 0) {
+
+/* ==== Quick return in case N = 0; nothing to do. ==== */
+
+ return 0;
+
+ } else if (lquery) {
+
+/* ==== Quick return in case of a workspace query ==== */
+
+ zlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1], ilo,
+ ihi, &z__[z_offset], ldz, &work[1], lwork, info);
+/* ==== Ensure reported workspace size is backward-compatible with */
+/* . previous LAPACK versions. ==== */
+/* Computing MAX */
+ d__2 = work[1].r, d__3 = (doublereal) max(1,*n);
+ d__1 = max(d__2,d__3);
+ z__1.r = d__1, z__1.i = 0.;
+ work[1].r = z__1.r, work[1].i = z__1.i;
+ return 0;
+
+ } else {
+
+/* ==== copy eigenvalues isolated by ZGEBAL ==== */
+
+ if (*ilo > 1) {
+ i__1 = *ilo - 1;
+ i__2 = *ldh + 1;
+ zcopy_(&i__1, &h__[h_offset], &i__2, &w[1], &c__1);
+ }
+ if (*ihi < *n) {
+ i__1 = *n - *ihi;
+ i__2 = *ldh + 1;
+ zcopy_(&i__1, &h__[*ihi + 1 + (*ihi + 1) * h_dim1], &i__2, &w[*
+ ihi + 1], &c__1);
+ }
+
+/* ==== Initialize Z, if requested ==== */
+
+ if (initz) {
+ zlaset_("A", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
+ }
+
+/* ==== Quick return if possible ==== */
+
+ if (*ilo == *ihi) {
+ i__1 = *ilo;
+ i__2 = *ilo + *ilo * h_dim1;
+ w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
+ return 0;
+ }
+
+/* ==== ZLAHQR/ZLAQR0 crossover point ==== */
+
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = job;
+ i__3[1] = 1, a__1[1] = compz;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ nmin = ilaenv_(&c__12, "ZHSEQR", ch__1, n, ilo, ihi, lwork);
+ nmin = max(11,nmin);
+
+/* ==== ZLAQR0 for big matrices; ZLAHQR for small ones ==== */
+
+ if (*n > nmin) {
+ zlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1],
+ ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, info);
+ } else {
+
+/* ==== Small matrix ==== */
+
+ zlahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1],
+ ilo, ihi, &z__[z_offset], ldz, info);
+
+ if (*info > 0) {
+
+/* ==== A rare ZLAHQR failure! ZLAQR0 sometimes succeeds */
+/* . when ZLAHQR fails. ==== */
+
+ kbot = *info;
+
+ if (*n >= 49) {
+
+/* ==== Larger matrices have enough subdiagonal scratch */
+/* . space to call ZLAQR0 directly. ==== */
+
+ zlaqr0_(&wantt, &wantz, n, ilo, &kbot, &h__[h_offset],
+ ldh, &w[1], ilo, ihi, &z__[z_offset], ldz, &work[
+ 1], lwork, info);
+
+ } else {
+
+/* ==== Tiny matrices don't have enough subdiagonal */
+/* . scratch space to benefit from ZLAQR0. Hence, */
+/* . tiny matrices must be copied into a larger */
+/* . array before calling ZLAQR0. ==== */
+
+ zlacpy_("A", n, n, &h__[h_offset], ldh, hl, &c__49);
+ i__1 = *n + 1 + *n * 49 - 50;
+ hl[i__1].r = 0., hl[i__1].i = 0.;
+ i__1 = 49 - *n;
+ zlaset_("A", &c__49, &i__1, &c_b1, &c_b1, &hl[(*n + 1) *
+ 49 - 49], &c__49);
+ zlaqr0_(&wantt, &wantz, &c__49, ilo, &kbot, hl, &c__49, &
+ w[1], ilo, ihi, &z__[z_offset], ldz, workl, &
+ c__49, info);
+ if (wantt || *info != 0) {
+ zlacpy_("A", n, n, hl, &c__49, &h__[h_offset], ldh);
+ }
+ }
+ }
+ }
+
+/* ==== Clear out the trash, if necessary. ==== */
+
+ if ((wantt || *info != 0) && *n > 2) {
+ i__1 = *n - 2;
+ i__2 = *n - 2;
+ zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &h__[h_dim1 + 3], ldh);
+ }
+
+/* ==== Ensure reported workspace size is backward-compatible with */
+/* . previous LAPACK versions. ==== */
+
+/* Computing MAX */
+ d__2 = (doublereal) max(1,*n), d__3 = work[1].r;
+ d__1 = max(d__2,d__3);
+ z__1.r = d__1, z__1.i = 0.;
+ work[1].r = z__1.r, work[1].i = z__1.i;
+ }
+
+/* ==== End of ZHSEQR ==== */
+
+ return 0;
+} /* zhseqr_ */
diff --git a/SRC/zla_gbamv.c b/SRC/zla_gbamv.c
new file mode 100644
index 0000000..6bf7b5d
--- /dev/null
+++ b/SRC/zla_gbamv.c
@@ -0,0 +1,337 @@
+/* zla_gbamv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zla_gbamv__(integer *trans, integer *m, integer *n,
+ integer *kl, integer *ku, doublereal *alpha, doublecomplex *ab,
+ integer *ldab, doublecomplex *x, integer *incx, doublereal *beta,
+ doublereal *y, integer *incy)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ extern integer ilatrans_(char *);
+ integer i__, j;
+ logical symb_zero__;
+ integer kd, iy, jx, kx, ky, info;
+ doublereal temp;
+ integer lenx, leny;
+ doublereal safe1;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLA_GEAMV performs one of the matrix-vector operations */
+
+/* y := alpha*abs(A)*abs(x) + beta*abs(y), */
+/* or y := alpha*abs(A)'*abs(x) + beta*abs(y), */
+
+/* where alpha and beta are scalars, x and y are vectors and A is an */
+/* m by n matrix. */
+
+/* This function is primarily used in calculating error bounds. */
+/* To protect against underflow during evaluation, components in */
+/* the resulting vector are perturbed away from zero by (N+1) */
+/* times the underflow threshold. To prevent unnecessarily large */
+/* errors for block-structure embedded in general matrices, */
+/* "symbolically" zero components are not perturbed. A zero */
+/* entry is considered "symbolic" if all multiplications involved */
+/* in computing that entry have at least one zero multiplicand. */
+
+/* Parameters */
+/* ========== */
+
+/* TRANS - INTEGER */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) */
+/* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) */
+/* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER */
+/* On entry, M specifies the number of rows of the matrix A. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* KL - INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU - INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* ALPHA - DOUBLE PRECISION */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ) */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+/* X - DOUBLE PRECISION array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - DOUBLE PRECISION */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - DOUBLE PRECISION array of DIMENSION at least */
+/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
+/* Before entry with BETA non-zero, the incremented array Y */
+/* must contain the vector y. On exit, Y is overwritten by the */
+/* updated vector y. */
+
+/* INCY - INTEGER */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! (*trans == ilatrans_("N") || *trans == ilatrans_("T") || *trans == ilatrans_("C"))) {
+ info = 1;
+ } else if (*m < 0) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*kl < 0) {
+ info = 4;
+ } else if (*ku < 0) {
+ info = 5;
+ } else if (*ldab < *kl + *ku + 1) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ } else if (*incy == 0) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("ZLA_GBAMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) {
+ return 0;
+ }
+
+/* Set LENX and LENY, the lengths of the vectors x and y, and set */
+/* up the start points in X and Y. */
+
+ if (*trans == ilatrans_("N")) {
+ lenx = *n;
+ leny = *m;
+ } else {
+ lenx = *m;
+ leny = *n;
+ }
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (lenx - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (leny - 1) * *incy;
+ }
+
+/* Set SAFE1 essentially to be the underflow threshold times the */
+/* number of additions in each row. */
+
+ safe1 = dlamch_("Safe minimum");
+ safe1 = (*n + 1) * safe1;
+
+/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */
+
+/* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to */
+/* the inexact flag. Still doesn't help change the iteration order */
+/* to per-column. */
+
+ kd = *ku + 1;
+ iy = ky;
+ if (*incx == 1) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.;
+ } else if (y[iy] == 0.) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (d__1 = y[iy], abs(d__1));
+ }
+ if (*alpha != 0.) {
+/* Computing MAX */
+ i__2 = i__ - *ku;
+/* Computing MIN */
+ i__4 = i__ + *kl;
+ i__3 = min(i__4,lenx);
+ for (j = max(i__2,1); j <= i__3; ++j) {
+ if (*trans == ilatrans_("N")) {
+ i__2 = kd + i__ - j + j * ab_dim1;
+ temp = (d__1 = ab[i__2].r, abs(d__1)) + (d__2 =
+ d_imag(&ab[kd + i__ - j + j * ab_dim1]), abs(
+ d__2));
+ } else {
+ i__2 = j + (kd + i__ - j) * ab_dim1;
+ temp = (d__1 = ab[i__2].r, abs(d__1)) + (d__2 =
+ d_imag(&ab[j + (kd + i__ - j) * ab_dim1]),
+ abs(d__2));
+ }
+ i__2 = j;
+ symb_zero__ = symb_zero__ && (x[i__2].r == 0. && x[i__2]
+ .i == 0. || temp == 0.);
+ i__2 = j;
+ y[iy] += *alpha * ((d__1 = x[i__2].r, abs(d__1)) + (d__2 =
+ d_imag(&x[j]), abs(d__2))) * temp;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += d_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.;
+ } else if (y[iy] == 0.) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (d__1 = y[iy], abs(d__1));
+ }
+ if (*alpha != 0.) {
+ jx = kx;
+/* Computing MAX */
+ i__3 = i__ - *ku;
+/* Computing MIN */
+ i__4 = i__ + *kl;
+ i__2 = min(i__4,lenx);
+ for (j = max(i__3,1); j <= i__2; ++j) {
+ if (*trans == ilatrans_("N")) {
+ i__3 = kd + i__ - j + j * ab_dim1;
+ temp = (d__1 = ab[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&ab[kd + i__ - j + j * ab_dim1]), abs(
+ d__2));
+ } else {
+ i__3 = j + (kd + i__ - j) * ab_dim1;
+ temp = (d__1 = ab[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&ab[j + (kd + i__ - j) * ab_dim1]),
+ abs(d__2));
+ }
+ i__3 = jx;
+ symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[i__3]
+ .i == 0. || temp == 0.);
+ i__3 = jx;
+ y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&x[jx]), abs(d__2))) * temp;
+ jx += *incx;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += d_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ }
+
+ return 0;
+
+/* End of ZLA_GBAMV */
+
+} /* zla_gbamv__ */
diff --git a/SRC/zla_gbrcond_c.c b/SRC/zla_gbrcond_c.c
new file mode 100644
index 0000000..7620afa
--- /dev/null
+++ b/SRC/zla_gbrcond_c.c
@@ -0,0 +1,351 @@
+/* zla_gbrcond_c.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zla_gbrcond_c__(char *trans, integer *n, integer *kl, integer *ku,
+ doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *ldafb,
+ integer *ipiv, doublereal *c__, logical *capply, integer *info,
+ doublecomplex *work, doublereal *rwork, ftnlen trans_len)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val, d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, kd, ke;
+ doublereal tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ doublereal anorm;
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *), xerbla_(
+ char *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int zgbtrs_(char *, integer *, integer *, integer
+ *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, integer *);
+ logical notrans;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_GBRCOND_C Computes the infinity norm condition number of */
+/* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input) COMPLEX*16 array, dimension (LDAFB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by ZGBTRF. U is stored as an upper triangular */
+/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */
+/* and the multipliers used during the factorization are stored */
+/* in rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from the factorization A = P*L*U */
+/* as computed by ZGBTRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* C (input) DOUBLE PRECISION array, dimension (N) */
+/* The vector C in the formula op(A) * inv(diag(C)). */
+
+/* CAPPLY (input) LOGICAL */
+/* If .TRUE. then access the vector C in the formula above. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) COMPLEX*16 array, dimension (2*N). */
+/* Workspace. */
+
+/* RWORK (input) DOUBLE PRECISION array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ --c__;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ *info = 0;
+ notrans = lsame_(trans, "N");
+ if (! notrans && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0 || *kl > *n - 1) {
+ *info = -3;
+ } else if (*ku < 0 || *ku > *n - 1) {
+ *info = -4;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -6;
+ } else if (*ldafb < (*kl << 1) + *ku + 1) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLA_GBRCOND_C", &i__1);
+ return ret_val;
+ }
+
+/* Compute norm of op(A)*op2(C). */
+
+ anorm = 0.;
+ kd = *ku + 1;
+ ke = *kl + 1;
+ if (notrans) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ if (*capply) {
+/* Computing MAX */
+ i__2 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__3 = min(i__4,*n);
+ for (j = max(i__2,1); j <= i__3; ++j) {
+ i__2 = kd + i__ - j + j * ab_dim1;
+ tmp += ((d__1 = ab[i__2].r, abs(d__1)) + (d__2 = d_imag(&
+ ab[kd + i__ - j + j * ab_dim1]), abs(d__2))) /
+ c__[j];
+ }
+ } else {
+/* Computing MAX */
+ i__3 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__2 = min(i__4,*n);
+ for (j = max(i__3,1); j <= i__2; ++j) {
+ i__3 = kd + i__ - j + j * ab_dim1;
+ tmp += (d__1 = ab[i__3].r, abs(d__1)) + (d__2 = d_imag(&
+ ab[kd + i__ - j + j * ab_dim1]), abs(d__2));
+ }
+ }
+ rwork[i__] = tmp;
+ anorm = max(anorm,tmp);
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ if (*capply) {
+/* Computing MAX */
+ i__2 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__3 = min(i__4,*n);
+ for (j = max(i__2,1); j <= i__3; ++j) {
+ i__2 = ke - i__ + j + i__ * ab_dim1;
+ tmp += ((d__1 = ab[i__2].r, abs(d__1)) + (d__2 = d_imag(&
+ ab[ke - i__ + j + i__ * ab_dim1]), abs(d__2))) /
+ c__[j];
+ }
+ } else {
+/* Computing MAX */
+ i__3 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__2 = min(i__4,*n);
+ for (j = max(i__3,1); j <= i__2; ++j) {
+ i__3 = ke - i__ + j + i__ * ab_dim1;
+ tmp += (d__1 = ab[i__3].r, abs(d__1)) + (d__2 = d_imag(&
+ ab[ke - i__ + j + i__ * ab_dim1]), abs(d__2));
+ }
+ }
+ rwork[i__] = tmp;
+ anorm = max(anorm,tmp);
+ }
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ ret_val = 1.;
+ return ret_val;
+ } else if (anorm == 0.) {
+ return ret_val;
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.;
+
+ kase = 0;
+L10:
+ zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+
+ if (notrans) {
+ zgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset],
+ ldafb, &ipiv[1], &work[1], n, info);
+ } else {
+ zgbtrs_("Conjugate transpose", n, kl, ku, &c__1, &afb[
+ afb_offset], ldafb, &ipiv[1], &work[1], n, info);
+ }
+
+/* Multiply by inv(C). */
+
+ if (*capply) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = c__[i__4] * work[i__3].r, z__1.i = c__[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ }
+ } else {
+
+/* Multiply by inv(C'). */
+
+ if (*capply) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = c__[i__4] * work[i__3].r, z__1.i = c__[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ }
+
+ if (notrans) {
+ zgbtrs_("Conjugate transpose", n, kl, ku, &c__1, &afb[
+ afb_offset], ldafb, &ipiv[1], &work[1], n, info);
+ } else {
+ zgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset],
+ ldafb, &ipiv[1], &work[1], n, info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ ret_val = 1. / ainvnm;
+ }
+
+ return ret_val;
+
+} /* zla_gbrcond_c__ */
diff --git a/SRC/zla_gbrcond_x.c b/SRC/zla_gbrcond_x.c
new file mode 100644
index 0000000..1a89b34
--- /dev/null
+++ b/SRC/zla_gbrcond_x.c
@@ -0,0 +1,322 @@
+/* zla_gbrcond_x.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zla_gbrcond_x__(char *trans, integer *n, integer *kl, integer *ku,
+ doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *ldafb,
+ integer *ipiv, doublecomplex *x, integer *info, doublecomplex *work,
+ doublereal *rwork, ftnlen trans_len)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val, d__1, d__2;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, kd, ke;
+ doublereal tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ doublereal anorm;
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *), xerbla_(
+ char *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int zgbtrs_(char *, integer *, integer *, integer
+ *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, integer *);
+ logical notrans;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_GBRCOND_X Computes the infinity norm condition number of */
+/* op(A) * diag(X) where X is a COMPLEX*16 vector. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input) COMPLEX*16 array, dimension (LDAFB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by ZGBTRF. U is stored as an upper triangular */
+/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */
+/* and the multipliers used during the factorization are stored */
+/* in rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from the factorization A = P*L*U */
+/* as computed by ZGBTRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* X (input) COMPLEX*16 array, dimension (N) */
+/* The vector X in the formula op(A) * diag(X). */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) COMPLEX*16 array, dimension (2*N). */
+/* Workspace. */
+
+/* RWORK (input) DOUBLE PRECISION array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ --x;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ *info = 0;
+ notrans = lsame_(trans, "N");
+ if (! notrans && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0 || *kl > *n - 1) {
+ *info = -3;
+ } else if (*ku < 0 || *ku > *n - 1) {
+ *info = -4;
+ } else if (*ldab < *kl + *ku + 1) {
+ *info = -6;
+ } else if (*ldafb < (*kl << 1) + *ku + 1) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLA_GBRCOND_X", &i__1);
+ return ret_val;
+ }
+
+/* Compute norm of op(A)*op2(C). */
+
+ kd = *ku + 1;
+ ke = *kl + 1;
+ anorm = 0.;
+ if (notrans) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+/* Computing MAX */
+ i__2 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__3 = min(i__4,*n);
+ for (j = max(i__2,1); j <= i__3; ++j) {
+ i__2 = kd + i__ - j + j * ab_dim1;
+ i__4 = j;
+ z__2.r = ab[i__2].r * x[i__4].r - ab[i__2].i * x[i__4].i,
+ z__2.i = ab[i__2].r * x[i__4].i + ab[i__2].i * x[i__4]
+ .r;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
+ abs(d__2));
+ }
+ rwork[i__] = tmp;
+ anorm = max(anorm,tmp);
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+/* Computing MAX */
+ i__3 = i__ - *kl;
+/* Computing MIN */
+ i__4 = i__ + *ku;
+ i__2 = min(i__4,*n);
+ for (j = max(i__3,1); j <= i__2; ++j) {
+ i__3 = ke - i__ + j + i__ * ab_dim1;
+ i__4 = j;
+ z__2.r = ab[i__3].r * x[i__4].r - ab[i__3].i * x[i__4].i,
+ z__2.i = ab[i__3].r * x[i__4].i + ab[i__3].i * x[i__4]
+ .r;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
+ abs(d__2));
+ }
+ rwork[i__] = tmp;
+ anorm = max(anorm,tmp);
+ }
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ ret_val = 1.;
+ return ret_val;
+ } else if (anorm == 0.) {
+ return ret_val;
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.;
+
+ kase = 0;
+L10:
+ zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+
+ if (notrans) {
+ zgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset],
+ ldafb, &ipiv[1], &work[1], n, info);
+ } else {
+ zgbtrs_("Conjugate transpose", n, kl, ku, &c__1, &afb[
+ afb_offset], ldafb, &ipiv[1], &work[1], n, info);
+ }
+
+/* Multiply by inv(X). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ z_div(&z__1, &work[i__], &x[i__]);
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ } else {
+
+/* Multiply by inv(X'). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ z_div(&z__1, &work[i__], &x[i__]);
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+
+ if (notrans) {
+ zgbtrs_("Conjugate transpose", n, kl, ku, &c__1, &afb[
+ afb_offset], ldafb, &ipiv[1], &work[1], n, info);
+ } else {
+ zgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset],
+ ldafb, &ipiv[1], &work[1], n, info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ ret_val = 1. / ainvnm;
+ }
+
+ return ret_val;
+
+} /* zla_gbrcond_x__ */
diff --git a/SRC/zla_gbrfsx_extended.c b/SRC/zla_gbrfsx_extended.c
new file mode 100644
index 0000000..5ef7198
--- /dev/null
+++ b/SRC/zla_gbrfsx_extended.c
@@ -0,0 +1,648 @@
+/* zla_gbrfsx_extended.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublecomplex c_b6 = {-1.,0.};
+static doublecomplex c_b8 = {1.,0.};
+static doublereal c_b31 = 1.;
+
+/* Subroutine */ int zla_gbrfsx_extended__(integer *prec_type__, integer *
+ trans_type__, integer *n, integer *kl, integer *ku, integer *nrhs,
+ doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *ldafb,
+ integer *ipiv, logical *colequ, doublereal *c__, doublecomplex *b,
+ integer *ldb, doublecomplex *y, integer *ldy, doublereal *berr_out__,
+ integer *n_norms__, doublereal *err_bnds_norm__, doublereal *
+ err_bnds_comp__, doublecomplex *res, doublereal *ayb, doublecomplex *
+ dy, doublecomplex *y_tail__, doublereal *rcond, integer *ithresh,
+ doublereal *rthresh, doublereal *dz_ub__, logical *ignore_cwise__,
+ integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ y_dim1, y_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2;
+ char ch__1[1];
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ doublereal dxratmax, dzratmax;
+ integer i__, j, m;
+ extern /* Subroutine */ int zla_gbamv__(integer *, integer *, integer *,
+ integer *, integer *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *, integer *)
+ ;
+ logical incr_prec__;
+ doublereal prev_dz_z__, yk, final_dx_x__, final_dz_z__;
+ extern /* Subroutine */ int zla_wwaddw__(integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *);
+ doublereal prevnormdx;
+ integer cnt;
+ doublereal dyk, eps, incr_thresh__, dx_x__, dz_z__, ymin;
+ extern /* Subroutine */ int zla_lin_berr__(integer *, integer *, integer *
+ , doublecomplex *, doublereal *, doublereal *), blas_zgbmv_x__(
+ integer *, integer *, integer *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *)
+ ;
+ integer y_prec_state__;
+ extern /* Subroutine */ int blas_zgbmv2_x__(integer *, integer *, integer
+ *, integer *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *);
+ doublereal dxrat, dzrat;
+ extern /* Subroutine */ int zgbmv_(char *, integer *, integer *, integer *
+, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ char trans[1];
+ doublereal normx, normy;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal normdx;
+ extern /* Subroutine */ int zgbtrs_(char *, integer *, integer *, integer
+ *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, integer *);
+ extern /* Character */ VOID chla_transtype__(char *, ftnlen, integer *);
+ doublereal hugeval;
+ integer x_state__, z_state__;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_GBRFSX_EXTENDED improves the computed solution to a system of */
+/* linear equations by performing extra-precise iterative refinement */
+/* and provides error bounds and backward error estimates for the solution. */
+/* This subroutine is called by ZGBRFSX to perform iterative refinement. */
+/* In addition to normwise error bound, the code provides maximum */
+/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP for details of the error bounds. Note that this */
+/* subroutine is only resonsible for setting the second fields of */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP. */
+
+/* Arguments */
+/* ========= */
+
+/* PREC_TYPE (input) INTEGER */
+/* Specifies the intermediate precision to be used in refinement. */
+/* The value is defined by ILAPREC(P) where P is a CHARACTER and */
+/* P = 'S': Single */
+/* = 'D': Double */
+/* = 'I': Indigenous */
+/* = 'X', 'E': Extra */
+
+/* TRANS_TYPE (input) INTEGER */
+/* Specifies the transposition operation on A. */
+/* The value is defined by ILATRANS(T) where T is a CHARACTER and */
+/* T = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0 */
+
+/* NRHS (input) INTEGER */
+/* The number of right-hand-sides, i.e., the number of columns of the */
+/* matrix B. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AFB (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The factors L and U from the factorization */
+/* A = P*L*U as computed by ZGBTRF. */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from the factorization A = P*L*U */
+/* as computed by ZGBTRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* COLEQU (input) LOGICAL */
+/* If .TRUE. then column equilibration was done to A before calling */
+/* this routine. This is needed to compute the solution and error */
+/* bounds correctly. */
+
+/* C (input) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. If COLEQU = .FALSE., C */
+/* is not accessed. If C is input, each element of C should be a power */
+/* of the radix to ensure a reliable solution and error estimates. */
+/* Scaling by powers of the radix does not cause rounding errors unless */
+/* the result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right-hand-side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Y (input/output) COMPLEX*16 array, dimension (LDY,NRHS) */
+/* On entry, the solution matrix X, as computed by ZGBTRS. */
+/* On exit, the improved solution matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= max(1,N). */
+
+/* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* On exit, BERR_OUT(j) contains the componentwise relative backward */
+/* error for right-hand-side j from the formula */
+/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. This is computed by ZLA_LIN_BERR. */
+
+/* N_NORMS (input) INTEGER */
+/* Determines which error bounds to return (see ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP). */
+/* If N_NORMS >= 1 return normwise error bounds. */
+/* If N_NORMS >= 2 return componentwise error bounds. */
+
+/* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* RES (input) COMPLEX*16 array, dimension (N) */
+/* Workspace to hold the intermediate residual. */
+
+/* AYB (input) DOUBLE PRECISION array, dimension (N) */
+/* Workspace. */
+
+/* DY (input) COMPLEX*16 array, dimension (N) */
+/* Workspace to hold the intermediate solution. */
+
+/* Y_TAIL (input) COMPLEX*16 array, dimension (N) */
+/* Workspace to hold the trailing bits of the intermediate solution. */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* ITHRESH (input) INTEGER */
+/* The maximum number of residual computations allowed for */
+/* refinement. The default is 10. For 'aggressive' set to 100 to */
+/* permit convergence using approximate factorizations or */
+/* factorizations other than LU. If the factorization uses a */
+/* technique other than Gaussian elimination, the guarantees in */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */
+
+/* RTHRESH (input) DOUBLE PRECISION */
+/* Determines when to stop refinement if the error estimate stops */
+/* decreasing. Refinement will stop when the next solution no longer */
+/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */
+/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */
+/* default value is 0.5. For 'aggressive' set to 0.9 to permit */
+/* convergence on extremely ill-conditioned matrices. See LAWN 165 */
+/* for more details. */
+
+/* DZ_UB (input) DOUBLE PRECISION */
+/* Determines when to start considering componentwise convergence. */
+/* Componentwise convergence is only considered after each component */
+/* of the solution Y is stable, which we definte as the relative */
+/* change in each component being less than DZ_UB. The default value */
+/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */
+/* more details. */
+
+/* IGNORE_CWISE (input) LOGICAL */
+/* If .TRUE. then ignore componentwise convergence. Default value */
+/* is .FALSE.. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* < 0: if INFO = -i, the ith argument to ZGBTRS had an illegal */
+/* value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions.. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --ipiv;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ --berr_out__;
+ --res;
+ --ayb;
+ --dy;
+ --y_tail__;
+
+ /* Function Body */
+ if (*info != 0) {
+ return 0;
+ }
+ chla_transtype__(ch__1, (ftnlen)1, trans_type__);
+ *(unsigned char *)trans = *(unsigned char *)&ch__1[0];
+ eps = dlamch_("Epsilon");
+ hugeval = dlamch_("Overflow");
+/* Force HUGEVAL to Inf */
+ hugeval *= hugeval;
+/* Using HUGEVAL may lead to spurious underflows. */
+ incr_thresh__ = (doublereal) (*n) * eps;
+ m = *kl + *ku + 1;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ y_prec_state__ = 1;
+ if (y_prec_state__ == 2) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ y_tail__[i__3].r = 0., y_tail__[i__3].i = 0.;
+ }
+ }
+ dxrat = 0.;
+ dxratmax = 0.;
+ dzrat = 0.;
+ dzratmax = 0.;
+ final_dx_x__ = hugeval;
+ final_dz_z__ = hugeval;
+ prevnormdx = hugeval;
+ prev_dz_z__ = hugeval;
+ dz_z__ = hugeval;
+ dx_x__ = hugeval;
+ x_state__ = 1;
+ z_state__ = 0;
+ incr_prec__ = FALSE_;
+ i__2 = *ithresh;
+ for (cnt = 1; cnt <= i__2; ++cnt) {
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ if (y_prec_state__ == 0) {
+ zgbmv_(trans, &m, n, kl, ku, &c_b6, &ab[ab_offset], ldab, &y[
+ j * y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1);
+ } else if (y_prec_state__ == 1) {
+ blas_zgbmv_x__(trans_type__, n, n, kl, ku, &c_b6, &ab[
+ ab_offset], ldab, &y[j * y_dim1 + 1], &c__1, &c_b8, &
+ res[1], &c__1, prec_type__);
+ } else {
+ blas_zgbmv2_x__(trans_type__, n, n, kl, ku, &c_b6, &ab[
+ ab_offset], ldab, &y[j * y_dim1 + 1], &y_tail__[1], &
+ c__1, &c_b8, &res[1], &c__1, prec_type__);
+ }
+/* XXX: RES is no longer needed. */
+ zcopy_(n, &res[1], &c__1, &dy[1], &c__1);
+ zgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1]
+, &dy[1], n, info);
+
+/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
+
+ normx = 0.;
+ normy = 0.;
+ normdx = 0.;
+ dz_z__ = 0.;
+ ymin = hugeval;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * y_dim1;
+ yk = (d__1 = y[i__4].r, abs(d__1)) + (d__2 = d_imag(&y[i__ +
+ j * y_dim1]), abs(d__2));
+ i__4 = i__;
+ dyk = (d__1 = dy[i__4].r, abs(d__1)) + (d__2 = d_imag(&dy[i__]
+ ), abs(d__2));
+ if (yk != 0.) {
+/* Computing MAX */
+ d__1 = dz_z__, d__2 = dyk / yk;
+ dz_z__ = max(d__1,d__2);
+ } else if (dyk != 0.) {
+ dz_z__ = hugeval;
+ }
+ ymin = min(ymin,yk);
+ normy = max(normy,yk);
+ if (*colequ) {
+/* Computing MAX */
+ d__1 = normx, d__2 = yk * c__[i__];
+ normx = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = normdx, d__2 = dyk * c__[i__];
+ normdx = max(d__1,d__2);
+ } else {
+ normx = normy;
+ normdx = max(normdx,dyk);
+ }
+ }
+ if (normx != 0.) {
+ dx_x__ = normdx / normx;
+ } else if (normdx == 0.) {
+ dx_x__ = 0.;
+ } else {
+ dx_x__ = hugeval;
+ }
+ dxrat = normdx / prevnormdx;
+ dzrat = dz_z__ / prev_dz_z__;
+
+/* Check termination criteria. */
+
+ if (! (*ignore_cwise__) && ymin * *rcond < incr_thresh__ * normy
+ && y_prec_state__ < 2) {
+ incr_prec__ = TRUE_;
+ }
+ if (x_state__ == 3 && dxrat <= *rthresh) {
+ x_state__ = 1;
+ }
+ if (x_state__ == 1) {
+ if (dx_x__ <= eps) {
+ x_state__ = 2;
+ } else if (dxrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ x_state__ = 3;
+ }
+ } else {
+ if (dxrat > dxratmax) {
+ dxratmax = dxrat;
+ }
+ }
+ if (x_state__ > 1) {
+ final_dx_x__ = dx_x__;
+ }
+ }
+ if (z_state__ == 0 && dz_z__ <= *dz_ub__) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 3 && dzrat <= *rthresh) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 1) {
+ if (dz_z__ <= eps) {
+ z_state__ = 2;
+ } else if (dz_z__ > *dz_ub__) {
+ z_state__ = 0;
+ dzratmax = 0.;
+ final_dz_z__ = hugeval;
+ } else if (dzrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ z_state__ = 3;
+ }
+ } else {
+ if (dzrat > dzratmax) {
+ dzratmax = dzrat;
+ }
+ }
+ if (z_state__ > 1) {
+ final_dz_z__ = dz_z__;
+ }
+ }
+
+/* Exit if both normwise and componentwise stopped working, */
+/* but if componentwise is unstable, let it go at least two */
+/* iterations. */
+
+ if (x_state__ != 1) {
+ if (*ignore_cwise__) {
+ goto L666;
+ }
+ if (z_state__ == 3 || z_state__ == 2) {
+ goto L666;
+ }
+ if (z_state__ == 0 && cnt > 1) {
+ goto L666;
+ }
+ }
+ if (incr_prec__) {
+ incr_prec__ = FALSE_;
+ ++y_prec_state__;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ y_tail__[i__4].r = 0., y_tail__[i__4].i = 0.;
+ }
+ }
+ prevnormdx = normdx;
+ prev_dz_z__ = dz_z__;
+
+/* Update soluton. */
+
+ if (y_prec_state__ < 2) {
+ zaxpy_(n, &c_b8, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
+ } else {
+ zla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
+ }
+ }
+/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */
+L666:
+
+/* Set final_* when cnt hits ithresh. */
+
+ if (x_state__ == 1) {
+ final_dx_x__ = dx_x__;
+ }
+ if (z_state__ == 1) {
+ final_dz_z__ = dz_z__;
+ }
+
+/* Compute error bounds. */
+
+ if (*n_norms__ >= 1) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / (
+ 1 - dxratmax);
+ }
+ if (*n_norms__ >= 2) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / (
+ 1 - dzratmax);
+ }
+
+/* Compute componentwise relative backward error from formula */
+/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. */
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ zgbmv_(trans, n, n, kl, ku, &c_b6, &ab[ab_offset], ldab, &y[j *
+ y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ ayb[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__
+ + j * b_dim1]), abs(d__2));
+ }
+
+/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */
+
+ zla_gbamv__(trans_type__, n, n, kl, ku, &c_b31, &ab[ab_offset], ldab,
+ &y[j * y_dim1 + 1], &c__1, &c_b31, &ayb[1], &c__1);
+ zla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
+
+/* End of loop for each RHS. */
+
+ }
+
+ return 0;
+} /* zla_gbrfsx_extended__ */
diff --git a/SRC/zla_gbrpvgrw.c b/SRC/zla_gbrpvgrw.c
new file mode 100644
index 0000000..64c14cb
--- /dev/null
+++ b/SRC/zla_gbrpvgrw.c
@@ -0,0 +1,148 @@
+/* zla_gbrpvgrw.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal zla_gbrpvgrw__(integer *n, integer *kl, integer *ku, integer *
+ ncols, doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *
+ ldafb)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val, d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, kd;
+ doublereal amax, umax, rpvgrw;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_GBRPVGRW computes the reciprocal pivot growth factor */
+/* norm(A)/norm(U). The "max absolute element" norm is used. If this is */
+/* much less than 1, the stability of the LU factorization of the */
+/* (equilibrated) matrix A could be poor. This also means that the */
+/* solution X, estimated condition numbers, and error bounds could be */
+/* unreliable. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NCOLS (input) INTEGER */
+/* The number of columns of the matrix A. NCOLS >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* AFB (input) COMPLEX*16 array, dimension (LDAFB,N) */
+/* Details of the LU factorization of the band matrix A, as */
+/* computed by ZGBTRF. U is stored as an upper triangular */
+/* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */
+/* and the multipliers used during the factorization are stored */
+/* in rows KL+KU+2 to 2*KL+KU+1. */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+
+ /* Function Body */
+ rpvgrw = 1.;
+ kd = *ku + 1;
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ amax = 0.;
+ umax = 0.;
+/* Computing MAX */
+ i__2 = j - *ku;
+/* Computing MIN */
+ i__4 = j + *kl;
+ i__3 = min(i__4,*n);
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ i__2 = kd + i__ - j + j * ab_dim1;
+ d__3 = (d__1 = ab[i__2].r, abs(d__1)) + (d__2 = d_imag(&ab[kd +
+ i__ - j + j * ab_dim1]), abs(d__2));
+ amax = max(d__3,amax);
+ }
+/* Computing MAX */
+ i__3 = j - *ku;
+ i__2 = j;
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = kd + i__ - j + j * afb_dim1;
+ d__3 = (d__1 = afb[i__3].r, abs(d__1)) + (d__2 = d_imag(&afb[kd +
+ i__ - j + j * afb_dim1]), abs(d__2));
+ umax = max(d__3,umax);
+ }
+ if (umax != 0.) {
+/* Computing MIN */
+ d__1 = amax / umax;
+ rpvgrw = min(d__1,rpvgrw);
+ }
+ }
+ ret_val = rpvgrw;
+ return ret_val;
+} /* zla_gbrpvgrw__ */
diff --git a/SRC/zla_geamv.c b/SRC/zla_geamv.c
new file mode 100644
index 0000000..b69da5c
--- /dev/null
+++ b/SRC/zla_geamv.c
@@ -0,0 +1,313 @@
+/* zla_geamv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zla_geamv__(integer *trans, integer *m, integer *n,
+ doublereal *alpha, doublecomplex *a, integer *lda, doublecomplex *x,
+ integer *incx, doublereal *beta, doublereal *y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ extern integer ilatrans_(char *);
+ integer i__, j;
+ logical symb_zero__;
+ integer iy, jx, kx, ky, info;
+ doublereal temp;
+ integer lenx, leny;
+ doublereal safe1;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_GEAMV performs one of the matrix-vector operations */
+
+/* y := alpha*abs(A)*abs(x) + beta*abs(y), */
+/* or y := alpha*abs(A)'*abs(x) + beta*abs(y), */
+
+/* where alpha and beta are scalars, x and y are vectors and A is an */
+/* m by n matrix. */
+
+/* This function is primarily used in calculating error bounds. */
+/* To protect against underflow during evaluation, components in */
+/* the resulting vector are perturbed away from zero by (N+1) */
+/* times the underflow threshold. To prevent unnecessarily large */
+/* errors for block-structure embedded in general matrices, */
+/* "symbolically" zero components are not perturbed. A zero */
+/* entry is considered "symbolic" if all multiplications involved */
+/* in computing that entry have at least one zero multiplicand. */
+
+/* Parameters */
+/* ========== */
+
+/* TRANS - INTEGER */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+
+/* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) */
+/* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) */
+/* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) */
+
+/* Unchanged on exit. */
+
+/* M - INTEGER */
+/* On entry, M specifies the number of rows of the matrix A. */
+/* M must be at least zero. */
+/* Unchanged on exit. */
+
+/* N - INTEGER */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, n ) */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX*16 array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - DOUBLE PRECISION */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - DOUBLE PRECISION array of DIMENSION at least */
+/* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
+/* and at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
+/* Before entry with BETA non-zero, the incremented array Y */
+/* must contain the vector y. On exit, Y is overwritten by the */
+/* updated vector y. */
+
+/* INCY - INTEGER */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! (*trans == ilatrans_("N") || *trans == ilatrans_("T") || *trans == ilatrans_("C"))) {
+ info = 1;
+ } else if (*m < 0) {
+ info = 2;
+ } else if (*n < 0) {
+ info = 3;
+ } else if (*lda < max(1,*m)) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ } else if (*incy == 0) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("ZLA_GEAMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) {
+ return 0;
+ }
+
+/* Set LENX and LENY, the lengths of the vectors x and y, and set */
+/* up the start points in X and Y. */
+
+ if (*trans == ilatrans_("N")) {
+ lenx = *n;
+ leny = *m;
+ } else {
+ lenx = *m;
+ leny = *n;
+ }
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (lenx - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (leny - 1) * *incy;
+ }
+
+/* Set SAFE1 essentially to be the underflow threshold times the */
+/* number of additions in each row. */
+
+ safe1 = dlamch_("Safe minimum");
+ safe1 = (*n + 1) * safe1;
+
+/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */
+
+/* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to */
+/* the inexact flag. Still doesn't help change the iteration order */
+/* to per-column. */
+
+ iy = ky;
+ if (*incx == 1) {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.;
+ } else if (y[iy] == 0.) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (d__1 = y[iy], abs(d__1));
+ }
+ if (*alpha != 0.) {
+ i__2 = lenx;
+ for (j = 1; j <= i__2; ++j) {
+ if (*trans == ilatrans_("N")) {
+ i__3 = i__ + j * a_dim1;
+ temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(
+ &a[i__ + j * a_dim1]), abs(d__2));
+ } else {
+ i__3 = j + i__ * a_dim1;
+ temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(
+ &a[j + i__ * a_dim1]), abs(d__2));
+ }
+ i__3 = j;
+ symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[i__3]
+ .i == 0. || temp == 0.);
+ i__3 = j;
+ y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&x[j]), abs(d__2))) * temp;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += d_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ } else {
+ i__1 = leny;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.;
+ } else if (y[iy] == 0.) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (d__1 = y[iy], abs(d__1));
+ }
+ if (*alpha != 0.) {
+ jx = kx;
+ i__2 = lenx;
+ for (j = 1; j <= i__2; ++j) {
+ if (*trans == ilatrans_("N")) {
+ i__3 = i__ + j * a_dim1;
+ temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(
+ &a[i__ + j * a_dim1]), abs(d__2));
+ } else {
+ i__3 = j + i__ * a_dim1;
+ temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(
+ &a[j + i__ * a_dim1]), abs(d__2));
+ }
+ i__3 = jx;
+ symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[i__3]
+ .i == 0. || temp == 0.);
+ i__3 = jx;
+ y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&x[jx]), abs(d__2))) * temp;
+ jx += *incx;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += d_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ }
+
+ return 0;
+
+/* End of ZLA_GEAMV */
+
+} /* zla_geamv__ */
diff --git a/SRC/zla_gercond_c.c b/SRC/zla_gercond_c.c
new file mode 100644
index 0000000..f0b6dc2
--- /dev/null
+++ b/SRC/zla_gercond_c.c
@@ -0,0 +1,310 @@
+/* zla_gercond_c.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zla_gercond_c__(char *trans, integer *n, doublecomplex *a, integer
+ *lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublereal *
+ c__, logical *capply, integer *info, doublecomplex *work, doublereal *
+ rwork, ftnlen trans_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val, d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ doublereal anorm;
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *), xerbla_(
+ char *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int zgetrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *);
+ logical notrans;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Aguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_GERCOND_C computes the infinity norm condition number of */
+/* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The factors L and U from the factorization */
+/* A = P*L*U as computed by ZGETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from the factorization A = P*L*U */
+/* as computed by ZGETRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* C (input) DOUBLE PRECISION array, dimension (N) */
+/* The vector C in the formula op(A) * inv(diag(C)). */
+
+/* CAPPLY (input) LOGICAL */
+/* If .TRUE. then access the vector C in the formula above. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) COMPLEX*16 array, dimension (2*N). */
+/* Workspace. */
+
+/* RWORK (input) DOUBLE PRECISION array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --c__;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ *info = 0;
+ notrans = lsame_(trans, "N");
+ if (! notrans && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLA_GERCOND_C", &i__1);
+ return ret_val;
+ }
+
+/* Compute norm of op(A)*op2(C). */
+
+ anorm = 0.;
+ if (notrans) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ if (*capply) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2))) / c__[j];
+ }
+ } else {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2));
+ }
+ }
+ rwork[i__] = tmp;
+ anorm = max(anorm,tmp);
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ if (*capply) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ j + i__ * a_dim1]), abs(d__2))) / c__[j];
+ }
+ } else {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ j + i__ * a_dim1]), abs(d__2));
+ }
+ }
+ rwork[i__] = tmp;
+ anorm = max(anorm,tmp);
+ }
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ ret_val = 1.;
+ return ret_val;
+ } else if (anorm == 0.) {
+ return ret_val;
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.;
+
+ kase = 0;
+L10:
+ zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+
+ if (notrans) {
+ zgetrs_("No transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[
+ 1], &work[1], n, info);
+ } else {
+ zgetrs_("Conjugate transpose", n, &c__1, &af[af_offset], ldaf,
+ &ipiv[1], &work[1], n, info);
+ }
+
+/* Multiply by inv(C). */
+
+ if (*capply) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = c__[i__4] * work[i__3].r, z__1.i = c__[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ }
+ } else {
+
+/* Multiply by inv(C'). */
+
+ if (*capply) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = c__[i__4] * work[i__3].r, z__1.i = c__[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ }
+
+ if (notrans) {
+ zgetrs_("Conjugate transpose", n, &c__1, &af[af_offset], ldaf,
+ &ipiv[1], &work[1], n, info);
+ } else {
+ zgetrs_("No transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[
+ 1], &work[1], n, info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ ret_val = 1. / ainvnm;
+ }
+
+ return ret_val;
+
+} /* zla_gercond_c__ */
diff --git a/SRC/zla_gercond_x.c b/SRC/zla_gercond_x.c
new file mode 100644
index 0000000..dcb399e
--- /dev/null
+++ b/SRC/zla_gercond_x.c
@@ -0,0 +1,290 @@
+/* zla_gercond_x.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zla_gercond_x__(char *trans, integer *n, doublecomplex *a, integer
+ *lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublecomplex *
+ x, integer *info, doublecomplex *work, doublereal *rwork, ftnlen
+ trans_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val, d__1, d__2;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ doublereal anorm;
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *), xerbla_(
+ char *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int zgetrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *);
+ logical notrans;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_GERCOND_X computes the infinity norm condition number of */
+/* op(A) * diag(X) where X is a COMPLEX*16 vector. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate Transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The factors L and U from the factorization */
+/* A = P*L*U as computed by ZGETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from the factorization A = P*L*U */
+/* as computed by ZGETRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* X (input) COMPLEX*16 array, dimension (N) */
+/* The vector X in the formula op(A) * diag(X). */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) COMPLEX*16 array, dimension (2*N). */
+/* Workspace. */
+
+/* RWORK (input) DOUBLE PRECISION array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --x;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ *info = 0;
+ notrans = lsame_(trans, "N");
+ if (! notrans && ! lsame_(trans, "T") && ! lsame_(
+ trans, "C")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLA_GERCOND_X", &i__1);
+ return ret_val;
+ }
+
+/* Compute norm of op(A)*op2(C). */
+
+ anorm = 0.;
+ if (notrans) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = j;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
+ abs(d__2));
+ }
+ rwork[i__] = tmp;
+ anorm = max(anorm,tmp);
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ i__4 = j;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
+ abs(d__2));
+ }
+ rwork[i__] = tmp;
+ anorm = max(anorm,tmp);
+ }
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ ret_val = 1.;
+ return ret_val;
+ } else if (anorm == 0.) {
+ return ret_val;
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.;
+
+ kase = 0;
+L10:
+ zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+/* Multiply by R. */
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+
+ if (notrans) {
+ zgetrs_("No transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[
+ 1], &work[1], n, info);
+ } else {
+ zgetrs_("Conjugate transpose", n, &c__1, &af[af_offset], ldaf,
+ &ipiv[1], &work[1], n, info);
+ }
+
+/* Multiply by inv(X). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ z_div(&z__1, &work[i__], &x[i__]);
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ } else {
+
+/* Multiply by inv(X'). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ z_div(&z__1, &work[i__], &x[i__]);
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+
+ if (notrans) {
+ zgetrs_("Conjugate transpose", n, &c__1, &af[af_offset], ldaf,
+ &ipiv[1], &work[1], n, info);
+ } else {
+ zgetrs_("No transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[
+ 1], &work[1], n, info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ ret_val = 1. / ainvnm;
+ }
+
+ return ret_val;
+
+} /* zla_gercond_x__ */
diff --git a/SRC/zla_gerfsx_extended.c b/SRC/zla_gerfsx_extended.c
new file mode 100644
index 0000000..b6d4dcf
--- /dev/null
+++ b/SRC/zla_gerfsx_extended.c
@@ -0,0 +1,637 @@
+/* zla_gerfsx_extended.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublecomplex c_b6 = {-1.,0.};
+static doublecomplex c_b8 = {1.,0.};
+static doublereal c_b31 = 1.;
+
+/* Subroutine */ int zla_gerfsx_extended__(integer *prec_type__, integer *
+ trans_type__, integer *n, integer *nrhs, doublecomplex *a, integer *
+ lda, doublecomplex *af, integer *ldaf, integer *ipiv, logical *colequ,
+ doublereal *c__, doublecomplex *b, integer *ldb, doublecomplex *y,
+ integer *ldy, doublereal *berr_out__, integer *n_norms__, doublereal *
+ errs_n__, doublereal *errs_c__, doublecomplex *res, doublereal *ayb,
+ doublecomplex *dy, doublecomplex *y_tail__, doublereal *rcond,
+ integer *ithresh, doublereal *rthresh, doublereal *dz_ub__, logical *
+ ignore_cwise__, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1,
+ y_offset, errs_n_dim1, errs_n_offset, errs_c_dim1, errs_c_offset,
+ i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2;
+ char ch__1[1];
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ doublereal dxratmax, dzratmax;
+ integer i__, j;
+ logical incr_prec__;
+ extern /* Subroutine */ int zla_geamv__(integer *, integer *, integer *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, integer *);
+ doublereal prev_dz_z__, yk, final_dx_x__, final_dz_z__;
+ extern /* Subroutine */ int zla_wwaddw__(integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *);
+ doublereal prevnormdx;
+ integer cnt;
+ doublereal dyk, eps, incr_thresh__, dx_x__, dz_z__, ymin;
+ extern /* Subroutine */ int zla_lin_berr__(integer *, integer *, integer *
+ , doublecomplex *, doublereal *, doublereal *), blas_zgemv_x__(
+ integer *, integer *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, integer *);
+ integer y_prec_state__;
+ extern /* Subroutine */ int blas_zgemv2_x__(integer *, integer *, integer
+ *, doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+ doublereal dxrat, dzrat;
+ char trans[1];
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ doublereal normx, normy;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal normdx;
+ extern /* Subroutine */ int zgetrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *);
+ extern /* Character */ VOID chla_transtype__(char *, ftnlen, integer *);
+ doublereal hugeval;
+ integer x_state__, z_state__;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_GERFSX_EXTENDED improves the computed solution to a system of */
+/* linear equations by performing extra-precise iterative refinement */
+/* and provides error bounds and backward error estimates for the solution. */
+/* This subroutine is called by ZGERFSX to perform iterative refinement. */
+/* In addition to normwise error bound, the code provides maximum */
+/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP for details of the error bounds. Note that this */
+/* subroutine is only resonsible for setting the second fields of */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP. */
+
+/* Arguments */
+/* ========= */
+
+/* PREC_TYPE (input) INTEGER */
+/* Specifies the intermediate precision to be used in refinement. */
+/* The value is defined by ILAPREC(P) where P is a CHARACTER and */
+/* P = 'S': Single */
+/* = 'D': Double */
+/* = 'I': Indigenous */
+/* = 'X', 'E': Extra */
+
+/* TRANS_TYPE (input) INTEGER */
+/* Specifies the transposition operation on A. */
+/* The value is defined by ILATRANS(T) where T is a CHARACTER and */
+/* T = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right-hand-sides, i.e., the number of columns of the */
+/* matrix B. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The factors L and U from the factorization */
+/* A = P*L*U as computed by ZGETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from the factorization A = P*L*U */
+/* as computed by ZGETRF; row i of the matrix was interchanged */
+/* with row IPIV(i). */
+
+/* COLEQU (input) LOGICAL */
+/* If .TRUE. then column equilibration was done to A before calling */
+/* this routine. This is needed to compute the solution and error */
+/* bounds correctly. */
+
+/* C (input) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. If COLEQU = .FALSE., C */
+/* is not accessed. If C is input, each element of C should be a power */
+/* of the radix to ensure a reliable solution and error estimates. */
+/* Scaling by powers of the radix does not cause rounding errors unless */
+/* the result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right-hand-side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Y (input/output) COMPLEX*16 array, dimension (LDY,NRHS) */
+/* On entry, the solution matrix X, as computed by ZGETRS. */
+/* On exit, the improved solution matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= max(1,N). */
+
+/* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* On exit, BERR_OUT(j) contains the componentwise relative backward */
+/* error for right-hand-side j from the formula */
+/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. This is computed by ZLA_LIN_BERR. */
+
+/* N_NORMS (input) INTEGER */
+/* Determines which error bounds to return (see ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP). */
+/* If N_NORMS >= 1 return normwise error bounds. */
+/* If N_NORMS >= 2 return componentwise error bounds. */
+
+/* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* RES (input) COMPLEX*16 array, dimension (N) */
+/* Workspace to hold the intermediate residual. */
+
+/* AYB (input) DOUBLE PRECISION array, dimension (N) */
+/* Workspace. */
+
+/* DY (input) COMPLEX*16 array, dimension (N) */
+/* Workspace to hold the intermediate solution. */
+
+/* Y_TAIL (input) COMPLEX*16 array, dimension (N) */
+/* Workspace to hold the trailing bits of the intermediate solution. */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* ITHRESH (input) INTEGER */
+/* The maximum number of residual computations allowed for */
+/* refinement. The default is 10. For 'aggressive' set to 100 to */
+/* permit convergence using approximate factorizations or */
+/* factorizations other than LU. If the factorization uses a */
+/* technique other than Gaussian elimination, the guarantees in */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */
+
+/* RTHRESH (input) DOUBLE PRECISION */
+/* Determines when to stop refinement if the error estimate stops */
+/* decreasing. Refinement will stop when the next solution no longer */
+/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */
+/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */
+/* default value is 0.5. For 'aggressive' set to 0.9 to permit */
+/* convergence on extremely ill-conditioned matrices. See LAWN 165 */
+/* for more details. */
+
+/* DZ_UB (input) DOUBLE PRECISION */
+/* Determines when to start considering componentwise convergence. */
+/* Componentwise convergence is only considered after each component */
+/* of the solution Y is stable, which we definte as the relative */
+/* change in each component being less than DZ_UB. The default value */
+/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */
+/* more details. */
+
+/* IGNORE_CWISE (input) LOGICAL */
+/* If .TRUE. then ignore componentwise convergence. Default value */
+/* is .FALSE.. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* < 0: if INFO = -i, the ith argument to ZGETRS had an illegal */
+/* value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ errs_c_dim1 = *nrhs;
+ errs_c_offset = 1 + errs_c_dim1;
+ errs_c__ -= errs_c_offset;
+ errs_n_dim1 = *nrhs;
+ errs_n_offset = 1 + errs_n_dim1;
+ errs_n__ -= errs_n_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ --berr_out__;
+ --res;
+ --ayb;
+ --dy;
+ --y_tail__;
+
+ /* Function Body */
+ if (*info != 0) {
+ return 0;
+ }
+ chla_transtype__(ch__1, (ftnlen)1, trans_type__);
+ *(unsigned char *)trans = *(unsigned char *)&ch__1[0];
+ eps = dlamch_("Epsilon");
+ hugeval = dlamch_("Overflow");
+/* Force HUGEVAL to Inf */
+ hugeval *= hugeval;
+/* Using HUGEVAL may lead to spurious underflows. */
+ incr_thresh__ = (doublereal) (*n) * eps;
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ y_prec_state__ = 1;
+ if (y_prec_state__ == 2) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ y_tail__[i__3].r = 0., y_tail__[i__3].i = 0.;
+ }
+ }
+ dxrat = 0.;
+ dxratmax = 0.;
+ dzrat = 0.;
+ dzratmax = 0.;
+ final_dx_x__ = hugeval;
+ final_dz_z__ = hugeval;
+ prevnormdx = hugeval;
+ prev_dz_z__ = hugeval;
+ dz_z__ = hugeval;
+ dx_x__ = hugeval;
+ x_state__ = 1;
+ z_state__ = 0;
+ incr_prec__ = FALSE_;
+ i__2 = *ithresh;
+ for (cnt = 1; cnt <= i__2; ++cnt) {
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ if (y_prec_state__ == 0) {
+ zgemv_(trans, n, n, &c_b6, &a[a_offset], lda, &y[j * y_dim1 +
+ 1], &c__1, &c_b8, &res[1], &c__1);
+ } else if (y_prec_state__ == 1) {
+ blas_zgemv_x__(trans_type__, n, n, &c_b6, &a[a_offset], lda, &
+ y[j * y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1,
+ prec_type__);
+ } else {
+ blas_zgemv2_x__(trans_type__, n, n, &c_b6, &a[a_offset], lda,
+ &y[j * y_dim1 + 1], &y_tail__[1], &c__1, &c_b8, &res[
+ 1], &c__1, prec_type__);
+ }
+/* XXX: RES is no longer needed. */
+ zcopy_(n, &res[1], &c__1, &dy[1], &c__1);
+ zgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &dy[1],
+ n, info);
+
+/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
+
+ normx = 0.;
+ normy = 0.;
+ normdx = 0.;
+ dz_z__ = 0.;
+ ymin = hugeval;
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * y_dim1;
+ yk = (d__1 = y[i__4].r, abs(d__1)) + (d__2 = d_imag(&y[i__ +
+ j * y_dim1]), abs(d__2));
+ i__4 = i__;
+ dyk = (d__1 = dy[i__4].r, abs(d__1)) + (d__2 = d_imag(&dy[i__]
+ ), abs(d__2));
+ if (yk != 0.) {
+/* Computing MAX */
+ d__1 = dz_z__, d__2 = dyk / yk;
+ dz_z__ = max(d__1,d__2);
+ } else if (dyk != 0.) {
+ dz_z__ = hugeval;
+ }
+ ymin = min(ymin,yk);
+ normy = max(normy,yk);
+ if (*colequ) {
+/* Computing MAX */
+ d__1 = normx, d__2 = yk * c__[i__];
+ normx = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = normdx, d__2 = dyk * c__[i__];
+ normdx = max(d__1,d__2);
+ } else {
+ normx = normy;
+ normdx = max(normdx,dyk);
+ }
+ }
+ if (normx != 0.) {
+ dx_x__ = normdx / normx;
+ } else if (normdx == 0.) {
+ dx_x__ = 0.;
+ } else {
+ dx_x__ = hugeval;
+ }
+ dxrat = normdx / prevnormdx;
+ dzrat = dz_z__ / prev_dz_z__;
+
+/* Check termination criteria */
+
+ if (! (*ignore_cwise__) && ymin * *rcond < incr_thresh__ * normy
+ && y_prec_state__ < 2) {
+ incr_prec__ = TRUE_;
+ }
+ if (x_state__ == 3 && dxrat <= *rthresh) {
+ x_state__ = 1;
+ }
+ if (x_state__ == 1) {
+ if (dx_x__ <= eps) {
+ x_state__ = 2;
+ } else if (dxrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ x_state__ = 3;
+ }
+ } else {
+ if (dxrat > dxratmax) {
+ dxratmax = dxrat;
+ }
+ }
+ if (x_state__ > 1) {
+ final_dx_x__ = dx_x__;
+ }
+ }
+ if (z_state__ == 0 && dz_z__ <= *dz_ub__) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 3 && dzrat <= *rthresh) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 1) {
+ if (dz_z__ <= eps) {
+ z_state__ = 2;
+ } else if (dz_z__ > *dz_ub__) {
+ z_state__ = 0;
+ dzratmax = 0.;
+ final_dz_z__ = hugeval;
+ } else if (dzrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ z_state__ = 3;
+ }
+ } else {
+ if (dzrat > dzratmax) {
+ dzratmax = dzrat;
+ }
+ }
+ if (z_state__ > 1) {
+ final_dz_z__ = dz_z__;
+ }
+ }
+
+/* Exit if both normwise and componentwise stopped working, */
+/* but if componentwise is unstable, let it go at least two */
+/* iterations. */
+
+ if (x_state__ != 1) {
+ if (*ignore_cwise__) {
+ goto L666;
+ }
+ if (z_state__ == 3 || z_state__ == 2) {
+ goto L666;
+ }
+ if (z_state__ == 0 && cnt > 1) {
+ goto L666;
+ }
+ }
+ if (incr_prec__) {
+ incr_prec__ = FALSE_;
+ ++y_prec_state__;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ y_tail__[i__4].r = 0., y_tail__[i__4].i = 0.;
+ }
+ }
+ prevnormdx = normdx;
+ prev_dz_z__ = dz_z__;
+
+/* Update soluton. */
+
+ if (y_prec_state__ < 2) {
+ zaxpy_(n, &c_b8, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
+ } else {
+ zla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
+ }
+ }
+/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */
+L666:
+
+/* Set final_* when cnt hits ithresh */
+
+ if (x_state__ == 1) {
+ final_dx_x__ = dx_x__;
+ }
+ if (z_state__ == 1) {
+ final_dz_z__ = dz_z__;
+ }
+
+/* Compute error bounds */
+
+ if (*n_norms__ >= 1) {
+ errs_n__[j + (errs_n_dim1 << 1)] = final_dx_x__ / (1 - dxratmax);
+ }
+ if (*n_norms__ >= 2) {
+ errs_c__[j + (errs_c_dim1 << 1)] = final_dz_z__ / (1 - dzratmax);
+ }
+
+/* Compute componentwise relative backward error from formula */
+/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. */
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ zgemv_(trans, n, n, &c_b6, &a[a_offset], lda, &y[j * y_dim1 + 1], &
+ c__1, &c_b8, &res[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ ayb[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__
+ + j * b_dim1]), abs(d__2));
+ }
+
+/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */
+
+ zla_geamv__(trans_type__, n, n, &c_b31, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &c__1, &c_b31, &ayb[1], &c__1);
+ zla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
+
+/* End of loop for each RHS. */
+
+ }
+
+ return 0;
+} /* zla_gerfsx_extended__ */
diff --git a/SRC/zla_heamv.c b/SRC/zla_heamv.c
new file mode 100644
index 0000000..1f07857
--- /dev/null
+++ b/SRC/zla_heamv.c
@@ -0,0 +1,327 @@
+/* zla_heamv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zla_heamv__(integer *uplo, integer *n, doublereal *alpha,
+ doublecomplex *a, integer *lda, doublecomplex *x, integer *incx,
+ doublereal *beta, doublereal *y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer i__, j;
+ logical symb_zero__;
+ integer iy, jx, kx, ky, info;
+ doublereal temp, safe1;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilauplo_(char *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_SYAMV performs the matrix-vector operation */
+
+/* y := alpha*abs(A)*abs(x) + beta*abs(y), */
+
+/* where alpha and beta are scalars, x and y are vectors and A is an */
+/* n by n symmetric matrix. */
+
+/* This function is primarily used in calculating error bounds. */
+/* To protect against underflow during evaluation, components in */
+/* the resulting vector are perturbed away from zero by (N+1) */
+/* times the underflow threshold. To prevent unnecessarily large */
+/* errors for block-structure embedded in general matrices, */
+/* "symbolically" zero components are not perturbed. A zero */
+/* entry is considered "symbolic" if all multiplications involved */
+/* in computing that entry have at least one zero multiplicand. */
+
+/* Parameters */
+/* ========== */
+
+/* UPLO - INTEGER */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array A is to be referenced as */
+/* follows: */
+
+/* UPLO = BLAS_UPPER Only the upper triangular part of A */
+/* is to be referenced. */
+
+/* UPLO = BLAS_LOWER Only the lower triangular part of A */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX*16 array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ) */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - DOUBLE PRECISION . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - DOUBLE PRECISION array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ) */
+/* Before entry with BETA non-zero, the incremented array Y */
+/* must contain the vector y. On exit, Y is overwritten by the */
+/* updated vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+/* -- Modified for the absolute-value product, April 2006 */
+/* Jason Riedy, UC Berkeley */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (*uplo != ilauplo_("U") && *uplo != ilauplo_("L")
+ ) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*lda < max(1,*n)) {
+ info = 5;
+ } else if (*incx == 0) {
+ info = 7;
+ } else if (*incy == 0) {
+ info = 10;
+ }
+ if (info != 0) {
+ xerbla_("ZHEMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0. && *beta == 1.) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Set SAFE1 essentially to be the underflow threshold times the */
+/* number of additions in each row. */
+
+ safe1 = dlamch_("Safe minimum");
+ safe1 = (*n + 1) * safe1;
+
+/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */
+
+/* The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to */
+/* the inexact flag. Still doesn't help change the iteration order */
+/* to per-column. */
+
+ iy = ky;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.;
+ } else if (y[iy] == 0.) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (d__1 = y[iy], abs(d__1));
+ }
+ if (*alpha != 0.) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (*uplo == ilauplo_("U")) {
+ if (i__ <= j) {
+ i__3 = i__ + j * a_dim1;
+ temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2));
+ } else {
+ i__3 = j + i__ * a_dim1;
+ temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[j + i__ * a_dim1]), abs(d__2));
+ }
+ } else {
+ if (i__ >= j) {
+ i__3 = i__ + j * a_dim1;
+ temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2));
+ } else {
+ i__3 = j + i__ * a_dim1;
+ temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[j + i__ * a_dim1]), abs(d__2));
+ }
+ }
+ i__3 = j;
+ symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[i__3]
+ .i == 0. || temp == 0.);
+ i__3 = j;
+ y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&x[j]), abs(d__2))) * temp;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += d_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.;
+ } else if (y[iy] == 0.) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (d__1 = y[iy], abs(d__1));
+ }
+ jx = kx;
+ if (*alpha != 0.) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (*uplo == ilauplo_("U")) {
+ if (i__ <= j) {
+ i__3 = i__ + j * a_dim1;
+ temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2));
+ } else {
+ i__3 = j + i__ * a_dim1;
+ temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[j + i__ * a_dim1]), abs(d__2));
+ }
+ } else {
+ if (i__ >= j) {
+ i__3 = i__ + j * a_dim1;
+ temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2));
+ } else {
+ i__3 = j + i__ * a_dim1;
+ temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[j + i__ * a_dim1]), abs(d__2));
+ }
+ }
+ i__3 = j;
+ symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[i__3]
+ .i == 0. || temp == 0.);
+ i__3 = jx;
+ y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&x[jx]), abs(d__2))) * temp;
+ jx += *incx;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += d_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ }
+
+ return 0;
+
+/* End of ZLA_HEAMV */
+
+} /* zla_heamv__ */
diff --git a/SRC/zla_hercond_c.c b/SRC/zla_hercond_c.c
new file mode 100644
index 0000000..ab9771d
--- /dev/null
+++ b/SRC/zla_hercond_c.c
@@ -0,0 +1,333 @@
+/* zla_hercond_c.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zla_hercond_c__(char *uplo, integer *n, doublecomplex *a, integer *
+ lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublereal *c__,
+ logical *capply, integer *info, doublecomplex *work, doublereal *
+ rwork, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val, d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ logical up;
+ doublereal tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ doublereal anorm;
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *), xerbla_(
+ char *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int zhetrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_HERCOND_C computes the infinity norm condition number of */
+/* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by ZHETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CHETRF. */
+
+/* C (input) DOUBLE PRECISION array, dimension (N) */
+/* The vector C in the formula op(A) * inv(diag(C)). */
+
+/* CAPPLY (input) LOGICAL */
+/* If .TRUE. then access the vector C in the formula above. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) COMPLEX*16 array, dimension (2*N). */
+/* Workspace. */
+
+/* RWORK (input) DOUBLE PRECISION array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --c__;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ *info = 0;
+ if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLA_HERCOND_C", &i__1);
+ return ret_val;
+ }
+ up = FALSE_;
+ if (lsame_(uplo, "U")) {
+ up = TRUE_;
+ }
+
+/* Compute norm of op(A)*op2(C). */
+
+ anorm = 0.;
+ if (up) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ if (*capply) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ j + i__ * a_dim1]), abs(d__2))) / c__[j];
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2))) / c__[j];
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ j + i__ * a_dim1]), abs(d__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2));
+ }
+ }
+ rwork[i__] = tmp;
+ anorm = max(anorm,tmp);
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ if (*capply) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2))) / c__[j];
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ j + i__ * a_dim1]), abs(d__2))) / c__[j];
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ j + i__ * a_dim1]), abs(d__2));
+ }
+ }
+ rwork[i__] = tmp;
+ anorm = max(anorm,tmp);
+ }
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ ret_val = 1.;
+ return ret_val;
+ } else if (anorm == 0.) {
+ return ret_val;
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.;
+
+ kase = 0;
+L10:
+ zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+
+ if (up) {
+ zhetrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ } else {
+ zhetrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+
+/* Multiply by inv(C). */
+
+ if (*capply) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = c__[i__4] * work[i__3].r, z__1.i = c__[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ }
+ } else {
+
+/* Multiply by inv(C'). */
+
+ if (*capply) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = c__[i__4] * work[i__3].r, z__1.i = c__[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ }
+
+ if (up) {
+ zhetrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ } else {
+ zhetrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ ret_val = 1. / ainvnm;
+ }
+
+ return ret_val;
+
+} /* zla_hercond_c__ */
diff --git a/SRC/zla_hercond_x.c b/SRC/zla_hercond_x.c
new file mode 100644
index 0000000..8105c1d
--- /dev/null
+++ b/SRC/zla_hercond_x.c
@@ -0,0 +1,311 @@
+/* zla_hercond_x.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zla_hercond_x__(char *uplo, integer *n, doublecomplex *a, integer *
+ lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublecomplex *
+ x, integer *info, doublecomplex *work, doublereal *rwork, ftnlen
+ uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val, d__1, d__2;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ logical up;
+ doublereal tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ doublereal anorm;
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *), xerbla_(
+ char *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int zhetrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_HERCOND_X computes the infinity norm condition number of */
+/* op(A) * diag(X) where X is a COMPLEX*16 vector. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by ZHETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by CHETRF. */
+
+/* X (input) COMPLEX*16 array, dimension (N) */
+/* The vector X in the formula op(A) * diag(X). */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) COMPLEX*16 array, dimension (2*N). */
+/* Workspace. */
+
+/* RWORK (input) DOUBLE PRECISION array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --x;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ *info = 0;
+ if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLA_HERCOND_X", &i__1);
+ return ret_val;
+ }
+ up = FALSE_;
+ if (lsame_(uplo, "U")) {
+ up = TRUE_;
+ }
+
+/* Compute norm of op(A)*op2(C). */
+
+ anorm = 0.;
+ if (up) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ i__4 = j;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
+ abs(d__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = j;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
+ abs(d__2));
+ }
+ rwork[i__] = tmp;
+ anorm = max(anorm,tmp);
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = j;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
+ abs(d__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ i__4 = j;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
+ abs(d__2));
+ }
+ rwork[i__] = tmp;
+ anorm = max(anorm,tmp);
+ }
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ ret_val = 1.;
+ return ret_val;
+ } else if (anorm == 0.) {
+ return ret_val;
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.;
+
+ kase = 0;
+L10:
+ zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+
+ if (up) {
+ zhetrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ } else {
+ zhetrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+
+/* Multiply by inv(X). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ z_div(&z__1, &work[i__], &x[i__]);
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ } else {
+
+/* Multiply by inv(X'). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ z_div(&z__1, &work[i__], &x[i__]);
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+
+ if (up) {
+ zhetrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ } else {
+ zhetrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ ret_val = 1. / ainvnm;
+ }
+
+ return ret_val;
+
+} /* zla_hercond_x__ */
diff --git a/SRC/zla_herfsx_extended.c b/SRC/zla_herfsx_extended.c
new file mode 100644
index 0000000..62dcf65
--- /dev/null
+++ b/SRC/zla_herfsx_extended.c
@@ -0,0 +1,626 @@
+/* zla_herfsx_extended.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublecomplex c_b11 = {-1.,0.};
+static doublecomplex c_b12 = {1.,0.};
+static doublereal c_b33 = 1.;
+
+/* Subroutine */ int zla_herfsx_extended__(integer *prec_type__, char *uplo,
+ integer *n, integer *nrhs, doublecomplex *a, integer *lda,
+ doublecomplex *af, integer *ldaf, integer *ipiv, logical *colequ,
+ doublereal *c__, doublecomplex *b, integer *ldb, doublecomplex *y,
+ integer *ldy, doublereal *berr_out__, integer *n_norms__, doublereal *
+ err_bnds_norm__, doublereal *err_bnds_comp__, doublecomplex *res,
+ doublereal *ayb, doublecomplex *dy, doublecomplex *y_tail__,
+ doublereal *rcond, integer *ithresh, doublereal *rthresh, doublereal *
+ dz_ub__, logical *ignore_cwise__, integer *info, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1,
+ y_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ doublereal dxratmax, dzratmax;
+ integer i__, j;
+ logical incr_prec__;
+ extern /* Subroutine */ int zla_heamv__(integer *, integer *, doublereal *
+ , doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, integer *);
+ doublereal prev_dz_z__, yk, final_dx_x__, final_dz_z__;
+ extern /* Subroutine */ int zla_wwaddw__(integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *);
+ doublereal prevnormdx;
+ integer cnt;
+ doublereal dyk, eps, incr_thresh__, dx_x__, dz_z__, ymin;
+ extern /* Subroutine */ int zla_lin_berr__(integer *, integer *, integer *
+ , doublecomplex *, doublereal *, doublereal *);
+ integer y_prec_state__;
+ extern /* Subroutine */ int blas_zhemv_x__(integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *)
+ ;
+ integer uplo2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int blas_zhemv2_x__(integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+ doublereal dxrat, dzrat;
+ extern /* Subroutine */ int zhemv_(char *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *);
+ doublereal normx, normy;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal normdx;
+ extern /* Subroutine */ int zhetrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *);
+ doublereal hugeval;
+ extern integer ilauplo_(char *);
+ integer x_state__, z_state__;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_HERFSX_EXTENDED improves the computed solution to a system of */
+/* linear equations by performing extra-precise iterative refinement */
+/* and provides error bounds and backward error estimates for the solution. */
+/* This subroutine is called by ZHERFSX to perform iterative refinement. */
+/* In addition to normwise error bound, the code provides maximum */
+/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP for details of the error bounds. Note that this */
+/* subroutine is only resonsible for setting the second fields of */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP. */
+
+/* Arguments */
+/* ========= */
+
+/* PREC_TYPE (input) INTEGER */
+/* Specifies the intermediate precision to be used in refinement. */
+/* The value is defined by ILAPREC(P) where P is a CHARACTER and */
+/* P = 'S': Single */
+/* = 'D': Double */
+/* = 'I': Indigenous */
+/* = 'X', 'E': Extra */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right-hand-sides, i.e., the number of columns of the */
+/* matrix B. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by ZHETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by ZHETRF. */
+
+/* COLEQU (input) LOGICAL */
+/* If .TRUE. then column equilibration was done to A before calling */
+/* this routine. This is needed to compute the solution and error */
+/* bounds correctly. */
+
+/* C (input) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. If COLEQU = .FALSE., C */
+/* is not accessed. If C is input, each element of C should be a power */
+/* of the radix to ensure a reliable solution and error estimates. */
+/* Scaling by powers of the radix does not cause rounding errors unless */
+/* the result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right-hand-side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Y (input/output) COMPLEX*16 array, dimension */
+/* (LDY,NRHS) */
+/* On entry, the solution matrix X, as computed by ZHETRS. */
+/* On exit, the improved solution matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= max(1,N). */
+
+/* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* On exit, BERR_OUT(j) contains the componentwise relative backward */
+/* error for right-hand-side j from the formula */
+/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. This is computed by ZLA_LIN_BERR. */
+
+/* N_NORMS (input) INTEGER */
+/* Determines which error bounds to return (see ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP). */
+/* If N_NORMS >= 1 return normwise error bounds. */
+/* If N_NORMS >= 2 return componentwise error bounds. */
+
+/* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* RES (input) COMPLEX*16 array, dimension (N) */
+/* Workspace to hold the intermediate residual. */
+
+/* AYB (input) DOUBLE PRECISION array, dimension (N) */
+/* Workspace. */
+
+/* DY (input) COMPLEX*16 array, dimension (N) */
+/* Workspace to hold the intermediate solution. */
+
+/* Y_TAIL (input) COMPLEX*16 array, dimension (N) */
+/* Workspace to hold the trailing bits of the intermediate solution. */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* ITHRESH (input) INTEGER */
+/* The maximum number of residual computations allowed for */
+/* refinement. The default is 10. For 'aggressive' set to 100 to */
+/* permit convergence using approximate factorizations or */
+/* factorizations other than LU. If the factorization uses a */
+/* technique other than Gaussian elimination, the guarantees in */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */
+
+/* RTHRESH (input) DOUBLE PRECISION */
+/* Determines when to stop refinement if the error estimate stops */
+/* decreasing. Refinement will stop when the next solution no longer */
+/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */
+/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */
+/* default value is 0.5. For 'aggressive' set to 0.9 to permit */
+/* convergence on extremely ill-conditioned matrices. See LAWN 165 */
+/* for more details. */
+
+/* DZ_UB (input) DOUBLE PRECISION */
+/* Determines when to start considering componentwise convergence. */
+/* Componentwise convergence is only considered after each component */
+/* of the solution Y is stable, which we definte as the relative */
+/* change in each component being less than DZ_UB. The default value */
+/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */
+/* more details. */
+
+/* IGNORE_CWISE (input) LOGICAL */
+/* If .TRUE. then ignore componentwise convergence. Default value */
+/* is .FALSE.. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* < 0: if INFO = -i, the ith argument to ZHETRS had an illegal */
+/* value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ --berr_out__;
+ --res;
+ --ayb;
+ --dy;
+ --y_tail__;
+
+ /* Function Body */
+ if (*info != 0) {
+ return 0;
+ }
+ eps = dlamch_("Epsilon");
+ hugeval = dlamch_("Overflow");
+/* Force HUGEVAL to Inf */
+ hugeval *= hugeval;
+/* Using HUGEVAL may lead to spurious underflows. */
+ incr_thresh__ = (doublereal) (*n) * eps;
+ if (lsame_(uplo, "L")) {
+ uplo2 = ilauplo_("L");
+ } else {
+ uplo2 = ilauplo_("U");
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ y_prec_state__ = 1;
+ if (y_prec_state__ == 2) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ y_tail__[i__3].r = 0., y_tail__[i__3].i = 0.;
+ }
+ }
+ dxrat = 0.;
+ dxratmax = 0.;
+ dzrat = 0.;
+ dzratmax = 0.;
+ final_dx_x__ = hugeval;
+ final_dz_z__ = hugeval;
+ prevnormdx = hugeval;
+ prev_dz_z__ = hugeval;
+ dz_z__ = hugeval;
+ dx_x__ = hugeval;
+ x_state__ = 1;
+ z_state__ = 0;
+ incr_prec__ = FALSE_;
+ i__2 = *ithresh;
+ for (cnt = 1; cnt <= i__2; ++cnt) {
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ if (y_prec_state__ == 0) {
+ zhemv_(uplo, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1],
+ &c__1, &c_b12, &res[1], &c__1);
+ } else if (y_prec_state__ == 1) {
+ blas_zhemv_x__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &c__1, &c_b12, &res[1], &c__1,
+ prec_type__);
+ } else {
+ blas_zhemv2_x__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &y_tail__[1], &c__1, &c_b12, &res[1], &
+ c__1, prec_type__);
+ }
+/* XXX: RES is no longer needed. */
+ zcopy_(n, &res[1], &c__1, &dy[1], &c__1);
+ zhetrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &dy[1], n,
+ info);
+
+/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
+
+ normx = 0.;
+ normy = 0.;
+ normdx = 0.;
+ dz_z__ = 0.;
+ ymin = hugeval;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * y_dim1;
+ yk = (d__1 = y[i__4].r, abs(d__1)) + (d__2 = d_imag(&y[i__ +
+ j * y_dim1]), abs(d__2));
+ i__4 = i__;
+ dyk = (d__1 = dy[i__4].r, abs(d__1)) + (d__2 = d_imag(&dy[i__]
+ ), abs(d__2));
+ if (yk != 0.) {
+/* Computing MAX */
+ d__1 = dz_z__, d__2 = dyk / yk;
+ dz_z__ = max(d__1,d__2);
+ } else if (dyk != 0.) {
+ dz_z__ = hugeval;
+ }
+ ymin = min(ymin,yk);
+ normy = max(normy,yk);
+ if (*colequ) {
+/* Computing MAX */
+ d__1 = normx, d__2 = yk * c__[i__];
+ normx = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = normdx, d__2 = dyk * c__[i__];
+ normdx = max(d__1,d__2);
+ } else {
+ normx = normy;
+ normdx = max(normdx,dyk);
+ }
+ }
+ if (normx != 0.) {
+ dx_x__ = normdx / normx;
+ } else if (normdx == 0.) {
+ dx_x__ = 0.;
+ } else {
+ dx_x__ = hugeval;
+ }
+ dxrat = normdx / prevnormdx;
+ dzrat = dz_z__ / prev_dz_z__;
+
+/* Check termination criteria. */
+
+ if (ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2) {
+ incr_prec__ = TRUE_;
+ }
+ if (x_state__ == 3 && dxrat <= *rthresh) {
+ x_state__ = 1;
+ }
+ if (x_state__ == 1) {
+ if (dx_x__ <= eps) {
+ x_state__ = 2;
+ } else if (dxrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ x_state__ = 3;
+ }
+ } else {
+ if (dxrat > dxratmax) {
+ dxratmax = dxrat;
+ }
+ }
+ if (x_state__ > 1) {
+ final_dx_x__ = dx_x__;
+ }
+ }
+ if (z_state__ == 0 && dz_z__ <= *dz_ub__) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 3 && dzrat <= *rthresh) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 1) {
+ if (dz_z__ <= eps) {
+ z_state__ = 2;
+ } else if (dz_z__ > *dz_ub__) {
+ z_state__ = 0;
+ dzratmax = 0.;
+ final_dz_z__ = hugeval;
+ } else if (dzrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ z_state__ = 3;
+ }
+ } else {
+ if (dzrat > dzratmax) {
+ dzratmax = dzrat;
+ }
+ }
+ if (z_state__ > 1) {
+ final_dz_z__ = dz_z__;
+ }
+ }
+ if (x_state__ != 1 && (*ignore_cwise__ || z_state__ != 1)) {
+ goto L666;
+ }
+ if (incr_prec__) {
+ incr_prec__ = FALSE_;
+ ++y_prec_state__;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ y_tail__[i__4].r = 0., y_tail__[i__4].i = 0.;
+ }
+ }
+ prevnormdx = normdx;
+ prev_dz_z__ = dz_z__;
+
+/* Update soluton. */
+
+ if (y_prec_state__ < 2) {
+ zaxpy_(n, &c_b12, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
+ } else {
+ zla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
+ }
+ }
+/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */
+L666:
+
+/* Set final_* when cnt hits ithresh. */
+
+ if (x_state__ == 1) {
+ final_dx_x__ = dx_x__;
+ }
+ if (z_state__ == 1) {
+ final_dz_z__ = dz_z__;
+ }
+
+/* Compute error bounds. */
+
+ if (*n_norms__ >= 1) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / (
+ 1 - dxratmax);
+ }
+ if (*n_norms__ >= 2) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / (
+ 1 - dzratmax);
+ }
+
+/* Compute componentwise relative backward error from formula */
+/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. */
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ zhemv_(uplo, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1,
+ &c_b12, &res[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ ayb[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__
+ + j * b_dim1]), abs(d__2));
+ }
+
+/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */
+
+ zla_heamv__(&uplo2, n, &c_b33, &a[a_offset], lda, &y[j * y_dim1 + 1],
+ &c__1, &c_b33, &ayb[1], &c__1);
+ zla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
+
+/* End of loop for each RHS. */
+
+ }
+
+ return 0;
+} /* zla_herfsx_extended__ */
diff --git a/SRC/zla_herpvgrw.c b/SRC/zla_herpvgrw.c
new file mode 100644
index 0000000..2cc0f68
--- /dev/null
+++ b/SRC/zla_herpvgrw.c
@@ -0,0 +1,355 @@
+/* zla_herpvgrw.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal zla_herpvgrw__(char *uplo, integer *n, integer *info,
+ doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf,
+ integer *ipiv, doublereal *work, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3;
+ doublereal ret_val, d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, kp;
+ doublereal tmp, amax, umax;
+ extern logical lsame_(char *, char *);
+ integer ncols;
+ logical upper;
+ doublereal rpvgrw;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_HERPVGRW computes the reciprocal pivot growth factor */
+/* norm(A)/norm(U). The "max absolute element" norm is used. If this is */
+/* much less than 1, the stability of the LU factorization of the */
+/* (equilibrated) matrix A could be poor. This also means that the */
+/* solution X, estimated condition numbers, and error bounds could be */
+/* unreliable. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* INFO (input) INTEGER */
+/* The value of INFO returned from ZHETRF, .i.e., the pivot in */
+/* column INFO is exactly 0. */
+
+/* NCOLS (input) INTEGER */
+/* The number of columns of the matrix A. NCOLS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by ZHETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by ZHETRF. */
+
+/* WORK (input) COMPLEX*16 array, dimension (2*N) */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ upper = lsame_("Upper", uplo);
+ if (*info == 0) {
+ if (upper) {
+ ncols = 1;
+ } else {
+ ncols = *n;
+ }
+ } else {
+ ncols = *info;
+ }
+ rpvgrw = 1.;
+ i__1 = *n << 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+ }
+
+/* Find the max magnitude entry of each column of A. Compute the max */
+/* for all N columns so we can apply the pivot permutation while */
+/* looping below. Assume a full factorization is the common case. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ + j * a_dim1]), abs(d__2)), d__4 = work[*n + i__];
+ work[*n + i__] = max(d__3,d__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ + j * a_dim1]), abs(d__2)), d__4 = work[*n + j];
+ work[*n + j] = max(d__3,d__4);
+ }
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ + j * a_dim1]), abs(d__2)), d__4 = work[*n + i__];
+ work[*n + i__] = max(d__3,d__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ + j * a_dim1]), abs(d__2)), d__4 = work[*n + j];
+ work[*n + j] = max(d__3,d__4);
+ }
+ }
+ }
+
+/* Now find the max magnitude entry of each column of U or L. Also */
+/* permute the magnitudes of A above so they're in the same order as */
+/* the factor. */
+
+/* The iteration orders and permutations were copied from zsytrs. */
+/* Calls to SSWAP would be severe overkill. */
+
+ if (upper) {
+ k = *n;
+ while(k < ncols && k > 0) {
+ if (ipiv[k] > 0) {
+/* 1x1 pivot */
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ i__2 = i__ + k * af_dim1;
+ d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(&
+ af[i__ + k * af_dim1]), abs(d__2)), d__4 = work[k]
+ ;
+ work[k] = max(d__3,d__4);
+ }
+ --k;
+ } else {
+/* 2x2 pivot */
+ kp = -ipiv[k];
+ tmp = work[*n + k - 1];
+ work[*n + k - 1] = work[*n + kp];
+ work[*n + kp] = tmp;
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ i__2 = i__ + k * af_dim1;
+ d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(&
+ af[i__ + k * af_dim1]), abs(d__2)), d__4 = work[k]
+ ;
+ work[k] = max(d__3,d__4);
+/* Computing MAX */
+ i__2 = i__ + (k - 1) * af_dim1;
+ d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(&
+ af[i__ + (k - 1) * af_dim1]), abs(d__2)), d__4 =
+ work[k - 1];
+ work[k - 1] = max(d__3,d__4);
+ }
+/* Computing MAX */
+ i__1 = k + k * af_dim1;
+ d__3 = (d__1 = af[i__1].r, abs(d__1)) + (d__2 = d_imag(&af[k
+ + k * af_dim1]), abs(d__2)), d__4 = work[k];
+ work[k] = max(d__3,d__4);
+ k += -2;
+ }
+ }
+ k = ncols;
+ while(k <= *n) {
+ if (ipiv[k] > 0) {
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ ++k;
+ } else {
+ kp = -ipiv[k];
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ k += 2;
+ }
+ }
+ } else {
+ k = 1;
+ while(k <= ncols) {
+ if (ipiv[k] > 0) {
+/* 1x1 pivot */
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ i__1 = *n;
+ for (i__ = k; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ i__2 = i__ + k * af_dim1;
+ d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(&
+ af[i__ + k * af_dim1]), abs(d__2)), d__4 = work[k]
+ ;
+ work[k] = max(d__3,d__4);
+ }
+ ++k;
+ } else {
+/* 2x2 pivot */
+ kp = -ipiv[k];
+ tmp = work[*n + k + 1];
+ work[*n + k + 1] = work[*n + kp];
+ work[*n + kp] = tmp;
+ i__1 = *n;
+ for (i__ = k + 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ i__2 = i__ + k * af_dim1;
+ d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(&
+ af[i__ + k * af_dim1]), abs(d__2)), d__4 = work[k]
+ ;
+ work[k] = max(d__3,d__4);
+/* Computing MAX */
+ i__2 = i__ + (k + 1) * af_dim1;
+ d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(&
+ af[i__ + (k + 1) * af_dim1]), abs(d__2)), d__4 =
+ work[k + 1];
+ work[k + 1] = max(d__3,d__4);
+ }
+/* Computing MAX */
+ i__1 = k + k * af_dim1;
+ d__3 = (d__1 = af[i__1].r, abs(d__1)) + (d__2 = d_imag(&af[k
+ + k * af_dim1]), abs(d__2)), d__4 = work[k];
+ work[k] = max(d__3,d__4);
+ k += 2;
+ }
+ }
+ k = ncols;
+ while(k >= 1) {
+ if (ipiv[k] > 0) {
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ --k;
+ } else {
+ kp = -ipiv[k];
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ k += -2;
+ }
+ }
+ }
+
+/* Compute the *inverse* of the max element growth factor. Dividing */
+/* by zero would imply the largest entry of the factor's column is */
+/* zero. Than can happen when either the column of A is zero or */
+/* massive pivots made the factor underflow to zero. Neither counts */
+/* as growth in itself, so simply ignore terms with zero */
+/* denominators. */
+
+ if (upper) {
+ i__1 = *n;
+ for (i__ = ncols; i__ <= i__1; ++i__) {
+ umax = work[i__];
+ amax = work[*n + i__];
+ if (umax != 0.) {
+/* Computing MIN */
+ d__1 = amax / umax;
+ rpvgrw = min(d__1,rpvgrw);
+ }
+ }
+ } else {
+ i__1 = ncols;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ umax = work[i__];
+ amax = work[*n + i__];
+ if (umax != 0.) {
+/* Computing MIN */
+ d__1 = amax / umax;
+ rpvgrw = min(d__1,rpvgrw);
+ }
+ }
+ }
+ ret_val = rpvgrw;
+ return ret_val;
+} /* zla_herpvgrw__ */
diff --git a/SRC/zla_lin_berr.c b/SRC/zla_lin_berr.c
new file mode 100644
index 0000000..bb1b189
--- /dev/null
+++ b/SRC/zla_lin_berr.c
@@ -0,0 +1,136 @@
+/* zla_lin_berr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zla_lin_berr__(integer *n, integer *nz, integer *nrhs,
+ doublecomplex *res, doublereal *ayb, doublereal *berr)
+{
+ /* System generated locals */
+ integer ayb_dim1, ayb_offset, res_dim1, res_offset, i__1, i__2, i__3,
+ i__4;
+ doublereal d__1, d__2, d__3;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal tmp, safe1;
+ extern doublereal dlamch_(char *);
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_LIN_BERR computes componentwise relative backward error from */
+/* the formula */
+/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NZ (input) INTEGER */
+/* We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to */
+/* guard against spuriously zero residuals. Default value is N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices AYB, RES, and BERR. NRHS >= 0. */
+
+/* RES (input) DOUBLE PRECISION array, dimension (N,NRHS) */
+/* The residual matrix, i.e., the matrix R in the relative backward */
+/* error formula above. */
+
+/* AYB (input) DOUBLE PRECISION array, dimension (N, NRHS) */
+/* The denominator in the relative backward error formula above, i.e., */
+/* the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B */
+/* are from iterative refinement (see zla_gerfsx_extended.f). */
+
+/* RES (output) COMPLEX*16 array, dimension (NRHS) */
+/* The componentwise relative backward error from the formula above. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Adding SAFE1 to the numerator guards against spuriously zero */
+/* residuals. A similar safeguard is in the CLA_yyAMV routine used */
+/* to compute AYB. */
+
+ /* Parameter adjustments */
+ --berr;
+ ayb_dim1 = *n;
+ ayb_offset = 1 + ayb_dim1;
+ ayb -= ayb_offset;
+ res_dim1 = *n;
+ res_offset = 1 + res_dim1;
+ res -= res_offset;
+
+ /* Function Body */
+ safe1 = dlamch_("Safe minimum");
+ safe1 = (*nz + 1) * safe1;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (ayb[i__ + j * ayb_dim1] != 0.) {
+ i__3 = i__ + j * res_dim1;
+ d__3 = (d__1 = res[i__3].r, abs(d__1)) + (d__2 = d_imag(&res[
+ i__ + j * res_dim1]), abs(d__2));
+ z__3.r = d__3, z__3.i = 0.;
+ z__2.r = safe1 + z__3.r, z__2.i = z__3.i;
+ i__4 = i__ + j * ayb_dim1;
+ z__1.r = z__2.r / ayb[i__4], z__1.i = z__2.i / ayb[i__4];
+ tmp = z__1.r;
+/* Computing MAX */
+ d__1 = berr[j];
+ berr[j] = max(d__1,tmp);
+ }
+
+/* If AYB is exactly 0.0 (and if computed by CLA_yyAMV), then we know */
+/* the true residual also must be exactly 0.0. */
+
+ }
+ }
+ return 0;
+} /* zla_lin_berr__ */
diff --git a/SRC/zla_porcond_c.c b/SRC/zla_porcond_c.c
new file mode 100644
index 0000000..13bb2b9
--- /dev/null
+++ b/SRC/zla_porcond_c.c
@@ -0,0 +1,327 @@
+/* zla_porcond_c.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zla_porcond_c__(char *uplo, integer *n, doublecomplex *a, integer *
+ lda, doublecomplex *af, integer *ldaf, doublereal *c__, logical *
+ capply, integer *info, doublecomplex *work, doublereal *rwork, ftnlen
+ uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val, d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ logical up;
+ doublereal tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ doublereal anorm;
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *), xerbla_(
+ char *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int zpotrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_PORCOND_C Computes the infinity norm condition number of */
+/* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by ZPOTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* C (input) DOUBLE PRECISION array, dimension (N) */
+/* The vector C in the formula op(A) * inv(diag(C)). */
+
+/* CAPPLY (input) LOGICAL */
+/* If .TRUE. then access the vector C in the formula above. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) COMPLEX*16 array, dimension (2*N). */
+/* Workspace. */
+
+/* RWORK (input) DOUBLE PRECISION array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --c__;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ *info = 0;
+ if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLA_PORCOND_C", &i__1);
+ return ret_val;
+ }
+ up = FALSE_;
+ if (lsame_(uplo, "U")) {
+ up = TRUE_;
+ }
+
+/* Compute norm of op(A)*op2(C). */
+
+ anorm = 0.;
+ if (up) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ if (*capply) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ j + i__ * a_dim1]), abs(d__2))) / c__[j];
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2))) / c__[j];
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ j + i__ * a_dim1]), abs(d__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2));
+ }
+ }
+ rwork[i__] = tmp;
+ anorm = max(anorm,tmp);
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ if (*capply) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2))) / c__[j];
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ j + i__ * a_dim1]), abs(d__2))) / c__[j];
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ j + i__ * a_dim1]), abs(d__2));
+ }
+ }
+ rwork[i__] = tmp;
+ anorm = max(anorm,tmp);
+ }
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ ret_val = 1.;
+ return ret_val;
+ } else if (anorm == 0.) {
+ return ret_val;
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.;
+
+ kase = 0;
+L10:
+ zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+
+ if (up) {
+ zpotrs_("U", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ } else {
+ zpotrs_("L", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ }
+
+/* Multiply by inv(C). */
+
+ if (*capply) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = c__[i__4] * work[i__3].r, z__1.i = c__[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ }
+ } else {
+
+/* Multiply by inv(C'). */
+
+ if (*capply) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = c__[i__4] * work[i__3].r, z__1.i = c__[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ }
+
+ if (up) {
+ zpotrs_("U", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ } else {
+ zpotrs_("L", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ ret_val = 1. / ainvnm;
+ }
+
+ return ret_val;
+
+} /* zla_porcond_c__ */
diff --git a/SRC/zla_porcond_x.c b/SRC/zla_porcond_x.c
new file mode 100644
index 0000000..7efed2f
--- /dev/null
+++ b/SRC/zla_porcond_x.c
@@ -0,0 +1,304 @@
+/* zla_porcond_x.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zla_porcond_x__(char *uplo, integer *n, doublecomplex *a, integer *
+ lda, doublecomplex *af, integer *ldaf, doublecomplex *x, integer *
+ info, doublecomplex *work, doublereal *rwork, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val, d__1, d__2;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ logical up;
+ doublereal tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ doublereal anorm;
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *), xerbla_(
+ char *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int zpotrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_PORCOND_X Computes the infinity norm condition number of */
+/* op(A) * diag(X) where X is a COMPLEX*16 vector. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by ZPOTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* X (input) COMPLEX*16 array, dimension (N) */
+/* The vector X in the formula op(A) * diag(X). */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) COMPLEX*16 array, dimension (2*N). */
+/* Workspace. */
+
+/* RWORK (input) DOUBLE PRECISION array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --x;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ *info = 0;
+ if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLA_PORCOND_X", &i__1);
+ return ret_val;
+ }
+ up = FALSE_;
+ if (lsame_(uplo, "U")) {
+ up = TRUE_;
+ }
+
+/* Compute norm of op(A)*op2(C). */
+
+ anorm = 0.;
+ if (up) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ i__4 = j;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
+ abs(d__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = j;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
+ abs(d__2));
+ }
+ rwork[i__] = tmp;
+ anorm = max(anorm,tmp);
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = j;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
+ abs(d__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ i__4 = j;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
+ abs(d__2));
+ }
+ rwork[i__] = tmp;
+ anorm = max(anorm,tmp);
+ }
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ ret_val = 1.;
+ return ret_val;
+ } else if (anorm == 0.) {
+ return ret_val;
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.;
+
+ kase = 0;
+L10:
+ zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+
+ if (up) {
+ zpotrs_("U", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ } else {
+ zpotrs_("L", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ }
+
+/* Multiply by inv(X). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ z_div(&z__1, &work[i__], &x[i__]);
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ } else {
+
+/* Multiply by inv(X'). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ z_div(&z__1, &work[i__], &x[i__]);
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+
+ if (up) {
+ zpotrs_("U", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ } else {
+ zpotrs_("L", n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ ret_val = 1. / ainvnm;
+ }
+
+ return ret_val;
+
+} /* zla_porcond_x__ */
diff --git a/SRC/zla_porfsx_extended.c b/SRC/zla_porfsx_extended.c
new file mode 100644
index 0000000..3006a05
--- /dev/null
+++ b/SRC/zla_porfsx_extended.c
@@ -0,0 +1,619 @@
+/* zla_porfsx_extended.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublecomplex c_b11 = {-1.,0.};
+static doublecomplex c_b12 = {1.,0.};
+static doublereal c_b33 = 1.;
+
+/* Subroutine */ int zla_porfsx_extended__(integer *prec_type__, char *uplo,
+ integer *n, integer *nrhs, doublecomplex *a, integer *lda,
+ doublecomplex *af, integer *ldaf, logical *colequ, doublereal *c__,
+ doublecomplex *b, integer *ldb, doublecomplex *y, integer *ldy,
+ doublereal *berr_out__, integer *n_norms__, doublereal *
+ err_bnds_norm__, doublereal *err_bnds_comp__, doublecomplex *res,
+ doublereal *ayb, doublecomplex *dy, doublecomplex *y_tail__,
+ doublereal *rcond, integer *ithresh, doublereal *rthresh, doublereal *
+ dz_ub__, logical *ignore_cwise__, integer *info, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1,
+ y_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ doublereal dxratmax, dzratmax;
+ integer i__, j;
+ logical incr_prec__;
+ extern /* Subroutine */ int zla_heamv__(integer *, integer *, doublereal *
+ , doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, integer *);
+ doublereal prev_dz_z__, yk, final_dx_x__, final_dz_z__;
+ extern /* Subroutine */ int zla_wwaddw__(integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *);
+ doublereal prevnormdx;
+ integer cnt;
+ doublereal dyk, eps, incr_thresh__, dx_x__, dz_z__, ymin;
+ extern /* Subroutine */ int zla_lin_berr__(integer *, integer *, integer *
+ , doublecomplex *, doublereal *, doublereal *);
+ integer y_prec_state__;
+ extern /* Subroutine */ int blas_zhemv_x__(integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *)
+ ;
+ integer uplo2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int blas_zhemv2_x__(integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+ doublereal dxrat, dzrat;
+ extern /* Subroutine */ int zhemv_(char *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *);
+ doublereal normx, normy;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal normdx;
+ extern /* Subroutine */ int zpotrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+ doublereal hugeval;
+ extern integer ilauplo_(char *);
+ integer x_state__, z_state__;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_PORFSX_EXTENDED improves the computed solution to a system of */
+/* linear equations by performing extra-precise iterative refinement */
+/* and provides error bounds and backward error estimates for the solution. */
+/* This subroutine is called by ZPORFSX to perform iterative refinement. */
+/* In addition to normwise error bound, the code provides maximum */
+/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP for details of the error bounds. Note that this */
+/* subroutine is only resonsible for setting the second fields of */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP. */
+
+/* Arguments */
+/* ========= */
+
+/* PREC_TYPE (input) INTEGER */
+/* Specifies the intermediate precision to be used in refinement. */
+/* The value is defined by ILAPREC(P) where P is a CHARACTER and */
+/* P = 'S': Single */
+/* = 'D': Double */
+/* = 'I': Indigenous */
+/* = 'X', 'E': Extra */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right-hand-sides, i.e., the number of columns of the */
+/* matrix B. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by ZPOTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* COLEQU (input) LOGICAL */
+/* If .TRUE. then column equilibration was done to A before calling */
+/* this routine. This is needed to compute the solution and error */
+/* bounds correctly. */
+
+/* C (input) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. If COLEQU = .FALSE., C */
+/* is not accessed. If C is input, each element of C should be a power */
+/* of the radix to ensure a reliable solution and error estimates. */
+/* Scaling by powers of the radix does not cause rounding errors unless */
+/* the result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right-hand-side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Y (input/output) COMPLEX*16 array, dimension */
+/* (LDY,NRHS) */
+/* On entry, the solution matrix X, as computed by ZPOTRS. */
+/* On exit, the improved solution matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= max(1,N). */
+
+/* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* On exit, BERR_OUT(j) contains the componentwise relative backward */
+/* error for right-hand-side j from the formula */
+/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. This is computed by ZLA_LIN_BERR. */
+
+/* N_NORMS (input) INTEGER */
+/* Determines which error bounds to return (see ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP). */
+/* If N_NORMS >= 1 return normwise error bounds. */
+/* If N_NORMS >= 2 return componentwise error bounds. */
+
+/* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* RES (input) COMPLEX*16 array, dimension (N) */
+/* Workspace to hold the intermediate residual. */
+
+/* AYB (input) DOUBLE PRECISION array, dimension (N) */
+/* Workspace. */
+
+/* DY (input) COMPLEX*16 PRECISION array, dimension (N) */
+/* Workspace to hold the intermediate solution. */
+
+/* Y_TAIL (input) COMPLEX*16 array, dimension (N) */
+/* Workspace to hold the trailing bits of the intermediate solution. */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* ITHRESH (input) INTEGER */
+/* The maximum number of residual computations allowed for */
+/* refinement. The default is 10. For 'aggressive' set to 100 to */
+/* permit convergence using approximate factorizations or */
+/* factorizations other than LU. If the factorization uses a */
+/* technique other than Gaussian elimination, the guarantees in */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */
+
+/* RTHRESH (input) DOUBLE PRECISION */
+/* Determines when to stop refinement if the error estimate stops */
+/* decreasing. Refinement will stop when the next solution no longer */
+/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */
+/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */
+/* default value is 0.5. For 'aggressive' set to 0.9 to permit */
+/* convergence on extremely ill-conditioned matrices. See LAWN 165 */
+/* for more details. */
+
+/* DZ_UB (input) DOUBLE PRECISION */
+/* Determines when to start considering componentwise convergence. */
+/* Componentwise convergence is only considered after each component */
+/* of the solution Y is stable, which we definte as the relative */
+/* change in each component being less than DZ_UB. The default value */
+/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */
+/* more details. */
+
+/* IGNORE_CWISE (input) LOGICAL */
+/* If .TRUE. then ignore componentwise convergence. Default value */
+/* is .FALSE.. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* < 0: if INFO = -i, the ith argument to ZPOTRS had an illegal */
+/* value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ --berr_out__;
+ --res;
+ --ayb;
+ --dy;
+ --y_tail__;
+
+ /* Function Body */
+ if (*info != 0) {
+ return 0;
+ }
+ eps = dlamch_("Epsilon");
+ hugeval = dlamch_("Overflow");
+/* Force HUGEVAL to Inf */
+ hugeval *= hugeval;
+/* Using HUGEVAL may lead to spurious underflows. */
+ incr_thresh__ = (doublereal) (*n) * eps;
+ if (lsame_(uplo, "L")) {
+ uplo2 = ilauplo_("L");
+ } else {
+ uplo2 = ilauplo_("U");
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ y_prec_state__ = 1;
+ if (y_prec_state__ == 2) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ y_tail__[i__3].r = 0., y_tail__[i__3].i = 0.;
+ }
+ }
+ dxrat = 0.;
+ dxratmax = 0.;
+ dzrat = 0.;
+ dzratmax = 0.;
+ final_dx_x__ = hugeval;
+ final_dz_z__ = hugeval;
+ prevnormdx = hugeval;
+ prev_dz_z__ = hugeval;
+ dz_z__ = hugeval;
+ dx_x__ = hugeval;
+ x_state__ = 1;
+ z_state__ = 0;
+ incr_prec__ = FALSE_;
+ i__2 = *ithresh;
+ for (cnt = 1; cnt <= i__2; ++cnt) {
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ if (y_prec_state__ == 0) {
+ zhemv_(uplo, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1],
+ &c__1, &c_b12, &res[1], &c__1);
+ } else if (y_prec_state__ == 1) {
+ blas_zhemv_x__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &c__1, &c_b12, &res[1], &c__1,
+ prec_type__);
+ } else {
+ blas_zhemv2_x__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &y_tail__[1], &c__1, &c_b12, &res[1], &
+ c__1, prec_type__);
+ }
+/* XXX: RES is no longer needed. */
+ zcopy_(n, &res[1], &c__1, &dy[1], &c__1);
+ zpotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &dy[1], n, info);
+
+/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
+
+ normx = 0.;
+ normy = 0.;
+ normdx = 0.;
+ dz_z__ = 0.;
+ ymin = hugeval;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * y_dim1;
+ yk = (d__1 = y[i__4].r, abs(d__1)) + (d__2 = d_imag(&y[i__ +
+ j * y_dim1]), abs(d__2));
+ i__4 = i__;
+ dyk = (d__1 = dy[i__4].r, abs(d__1)) + (d__2 = d_imag(&dy[i__]
+ ), abs(d__2));
+ if (yk != 0.) {
+/* Computing MAX */
+ d__1 = dz_z__, d__2 = dyk / yk;
+ dz_z__ = max(d__1,d__2);
+ } else if (dyk != 0.) {
+ dz_z__ = hugeval;
+ }
+ ymin = min(ymin,yk);
+ normy = max(normy,yk);
+ if (*colequ) {
+/* Computing MAX */
+ d__1 = normx, d__2 = yk * c__[i__];
+ normx = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = normdx, d__2 = dyk * c__[i__];
+ normdx = max(d__1,d__2);
+ } else {
+ normx = normy;
+ normdx = max(normdx,dyk);
+ }
+ }
+ if (normx != 0.) {
+ dx_x__ = normdx / normx;
+ } else if (normdx == 0.) {
+ dx_x__ = 0.;
+ } else {
+ dx_x__ = hugeval;
+ }
+ dxrat = normdx / prevnormdx;
+ dzrat = dz_z__ / prev_dz_z__;
+
+/* Check termination criteria. */
+
+ if (ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2) {
+ incr_prec__ = TRUE_;
+ }
+ if (x_state__ == 3 && dxrat <= *rthresh) {
+ x_state__ = 1;
+ }
+ if (x_state__ == 1) {
+ if (dx_x__ <= eps) {
+ x_state__ = 2;
+ } else if (dxrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ x_state__ = 3;
+ }
+ } else {
+ if (dxrat > dxratmax) {
+ dxratmax = dxrat;
+ }
+ }
+ if (x_state__ > 1) {
+ final_dx_x__ = dx_x__;
+ }
+ }
+ if (z_state__ == 0 && dz_z__ <= *dz_ub__) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 3 && dzrat <= *rthresh) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 1) {
+ if (dz_z__ <= eps) {
+ z_state__ = 2;
+ } else if (dz_z__ > *dz_ub__) {
+ z_state__ = 0;
+ dzratmax = 0.;
+ final_dz_z__ = hugeval;
+ } else if (dzrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ z_state__ = 3;
+ }
+ } else {
+ if (dzrat > dzratmax) {
+ dzratmax = dzrat;
+ }
+ }
+ if (z_state__ > 1) {
+ final_dz_z__ = dz_z__;
+ }
+ }
+ if (x_state__ != 1 && (*ignore_cwise__ || z_state__ != 1)) {
+ goto L666;
+ }
+ if (incr_prec__) {
+ incr_prec__ = FALSE_;
+ ++y_prec_state__;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ y_tail__[i__4].r = 0., y_tail__[i__4].i = 0.;
+ }
+ }
+ prevnormdx = normdx;
+ prev_dz_z__ = dz_z__;
+
+/* Update soluton. */
+
+ if (y_prec_state__ < 2) {
+ zaxpy_(n, &c_b12, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
+ } else {
+ zla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
+ }
+ }
+/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */
+L666:
+
+/* Set final_* when cnt hits ithresh. */
+
+ if (x_state__ == 1) {
+ final_dx_x__ = dx_x__;
+ }
+ if (z_state__ == 1) {
+ final_dz_z__ = dz_z__;
+ }
+
+/* Compute error bounds. */
+
+ if (*n_norms__ >= 1) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / (
+ 1 - dxratmax);
+ }
+ if (*n_norms__ >= 2) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / (
+ 1 - dzratmax);
+ }
+
+/* Compute componentwise relative backward error from formula */
+/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. */
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ zhemv_(uplo, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1,
+ &c_b12, &res[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ ayb[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__
+ + j * b_dim1]), abs(d__2));
+ }
+
+/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */
+
+ zla_heamv__(&uplo2, n, &c_b33, &a[a_offset], lda, &y[j * y_dim1 + 1],
+ &c__1, &c_b33, &ayb[1], &c__1);
+ zla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
+
+/* End of loop for each RHS. */
+
+ }
+
+ return 0;
+} /* zla_porfsx_extended__ */
diff --git a/SRC/zla_porpvgrw.c b/SRC/zla_porpvgrw.c
new file mode 100644
index 0000000..93ea5bb
--- /dev/null
+++ b/SRC/zla_porpvgrw.c
@@ -0,0 +1,208 @@
+/* zla_porpvgrw.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal zla_porpvgrw__(char *uplo, integer *ncols, doublecomplex *a,
+ integer *lda, doublecomplex *af, integer *ldaf, doublereal *work,
+ ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3;
+ doublereal ret_val, d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal amax, umax;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ doublereal rpvgrw;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_PORPVGRW computes the reciprocal pivot growth factor */
+/* norm(A)/norm(U). The "max absolute element" norm is used. If this is */
+/* much less than 1, the stability of the LU factorization of the */
+/* (equilibrated) matrix A could be poor. This also means that the */
+/* solution X, estimated condition numbers, and error bounds could be */
+/* unreliable. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* NCOLS (input) INTEGER */
+/* The number of columns of the matrix A. NCOLS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by ZPOTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* WORK (input) COMPLEX*16 array, dimension (2*N) */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --work;
+
+ /* Function Body */
+ upper = lsame_("Upper", uplo);
+
+/* DPOTRF will have factored only the NCOLSxNCOLS leading minor, so */
+/* we restrict the growth search to that minor and use only the first */
+/* 2*NCOLS workspace entries. */
+
+ rpvgrw = 1.;
+ i__1 = *ncols << 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+ }
+
+/* Find the max magnitude entry of each column. */
+
+ if (upper) {
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ + j * a_dim1]), abs(d__2)), d__4 = work[*ncols + j];
+ work[*ncols + j] = max(d__3,d__4);
+ }
+ }
+ } else {
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *ncols;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ + j * a_dim1]), abs(d__2)), d__4 = work[*ncols + j];
+ work[*ncols + j] = max(d__3,d__4);
+ }
+ }
+ }
+
+/* Now find the max magnitude entry of each column of the factor in */
+/* AF. No pivoting, so no permutations. */
+
+ if (lsame_("Upper", uplo)) {
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * af_dim1;
+ d__3 = (d__1 = af[i__3].r, abs(d__1)) + (d__2 = d_imag(&af[
+ i__ + j * af_dim1]), abs(d__2)), d__4 = work[j];
+ work[j] = max(d__3,d__4);
+ }
+ }
+ } else {
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *ncols;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * af_dim1;
+ d__3 = (d__1 = af[i__3].r, abs(d__1)) + (d__2 = d_imag(&af[
+ i__ + j * af_dim1]), abs(d__2)), d__4 = work[j];
+ work[j] = max(d__3,d__4);
+ }
+ }
+ }
+
+/* Compute the *inverse* of the max element growth factor. Dividing */
+/* by zero would imply the largest entry of the factor's column is */
+/* zero. Than can happen when either the column of A is zero or */
+/* massive pivots made the factor underflow to zero. Neither counts */
+/* as growth in itself, so simply ignore terms with zero */
+/* denominators. */
+
+ if (lsame_("Upper", uplo)) {
+ i__1 = *ncols;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ umax = work[i__];
+ amax = work[*ncols + i__];
+ if (umax != 0.) {
+/* Computing MIN */
+ d__1 = amax / umax;
+ rpvgrw = min(d__1,rpvgrw);
+ }
+ }
+ } else {
+ i__1 = *ncols;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ umax = work[i__];
+ amax = work[*ncols + i__];
+ if (umax != 0.) {
+/* Computing MIN */
+ d__1 = amax / umax;
+ rpvgrw = min(d__1,rpvgrw);
+ }
+ }
+ }
+ ret_val = rpvgrw;
+ return ret_val;
+} /* zla_porpvgrw__ */
diff --git a/SRC/zla_rpvgrw.c b/SRC/zla_rpvgrw.c
new file mode 100644
index 0000000..b229ea8
--- /dev/null
+++ b/SRC/zla_rpvgrw.c
@@ -0,0 +1,128 @@
+/* zla_rpvgrw.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal zla_rpvgrw__(integer *n, integer *ncols, doublecomplex *a, integer
+ *lda, doublecomplex *af, integer *ldaf)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3;
+ doublereal ret_val, d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal amax, umax, rpvgrw;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_RPVGRW computes the reciprocal pivot growth factor */
+/* norm(A)/norm(U). The "max absolute element" norm is used. If this is */
+/* much less than 1, the stability of the LU factorization of the */
+/* (equilibrated) matrix A could be poor. This also means that the */
+/* solution X, estimated condition numbers, and error bounds could be */
+/* unreliable. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NCOLS (input) INTEGER */
+/* The number of columns of the matrix A. NCOLS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */
+/* The factors L and U from the factorization */
+/* A = P*L*U as computed by ZGETRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+
+ /* Function Body */
+ rpvgrw = 1.;
+ i__1 = *ncols;
+ for (j = 1; j <= i__1; ++j) {
+ amax = 0.;
+ umax = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + j *
+ a_dim1]), abs(d__2));
+ amax = max(d__3,amax);
+ }
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * af_dim1;
+ d__3 = (d__1 = af[i__3].r, abs(d__1)) + (d__2 = d_imag(&af[i__ +
+ j * af_dim1]), abs(d__2));
+ umax = max(d__3,umax);
+ }
+ if (umax != 0.) {
+/* Computing MIN */
+ d__1 = amax / umax;
+ rpvgrw = min(d__1,rpvgrw);
+ }
+ }
+ ret_val = rpvgrw;
+ return ret_val;
+} /* zla_rpvgrw__ */
diff --git a/SRC/zla_syamv.c b/SRC/zla_syamv.c
new file mode 100644
index 0000000..b9b6341
--- /dev/null
+++ b/SRC/zla_syamv.c
@@ -0,0 +1,327 @@
+/* zla_syamv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zla_syamv__(integer *uplo, integer *n, doublereal *alpha,
+ doublecomplex *a, integer *lda, doublecomplex *x, integer *incx,
+ doublereal *beta, doublereal *y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer i__, j;
+ logical symb_zero__;
+ integer iy, jx, kx, ky, info;
+ doublereal temp, safe1;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilauplo_(char *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_SYAMV performs the matrix-vector operation */
+
+/* y := alpha*abs(A)*abs(x) + beta*abs(y), */
+
+/* where alpha and beta are scalars, x and y are vectors and A is an */
+/* n by n symmetric matrix. */
+
+/* This function is primarily used in calculating error bounds. */
+/* To protect against underflow during evaluation, components in */
+/* the resulting vector are perturbed away from zero by (N+1) */
+/* times the underflow threshold. To prevent unnecessarily large */
+/* errors for block-structure embedded in general matrices, */
+/* "symbolically" zero components are not perturbed. A zero */
+/* entry is considered "symbolic" if all multiplications involved */
+/* in computing that entry have at least one zero multiplicand. */
+
+/* Parameters */
+/* ========== */
+
+/* UPLO - INTEGER */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array A is to be referenced as */
+/* follows: */
+
+/* UPLO = BLAS_UPPER Only the upper triangular part of A */
+/* is to be referenced. */
+
+/* UPLO = BLAS_LOWER Only the lower triangular part of A */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER. */
+/* On entry, N specifies the number of columns of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - DOUBLE PRECISION . */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array of DIMENSION ( LDA, n ). */
+/* Before entry, the leading m by n part of the array A must */
+/* contain the matrix of coefficients. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER. */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, n ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX*16 array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCX ) ) */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER. */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - DOUBLE PRECISION . */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y - DOUBLE PRECISION array of DIMENSION at least */
+/* ( 1 + ( n - 1 )*abs( INCY ) ) */
+/* Before entry with BETA non-zero, the incremented array Y */
+/* must contain the vector y. On exit, Y is overwritten by the */
+/* updated vector y. */
+
+/* INCY - INTEGER. */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+
+/* Level 2 Blas routine. */
+
+/* -- Written on 22-October-1986. */
+/* Jack Dongarra, Argonne National Lab. */
+/* Jeremy Du Croz, Nag Central Office. */
+/* Sven Hammarling, Nag Central Office. */
+/* Richard Hanson, Sandia National Labs. */
+/* -- Modified for the absolute-value product, April 2006 */
+/* Jason Riedy, UC Berkeley */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (*uplo != ilauplo_("U") && *uplo != ilauplo_("L")
+ ) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*lda < max(1,*n)) {
+ info = 5;
+ } else if (*incx == 0) {
+ info = 7;
+ } else if (*incy == 0) {
+ info = 10;
+ }
+ if (info != 0) {
+ xerbla_("DSYMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *alpha == 0. && *beta == 1.) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Set SAFE1 essentially to be the underflow threshold times the */
+/* number of additions in each row. */
+
+ safe1 = dlamch_("Safe minimum");
+ safe1 = (*n + 1) * safe1;
+
+/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */
+
+/* The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to */
+/* the inexact flag. Still doesn't help change the iteration order */
+/* to per-column. */
+
+ iy = ky;
+ if (*incx == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.;
+ } else if (y[iy] == 0.) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (d__1 = y[iy], abs(d__1));
+ }
+ if (*alpha != 0.) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (*uplo == ilauplo_("U")) {
+ if (i__ <= j) {
+ i__3 = i__ + j * a_dim1;
+ temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2));
+ } else {
+ i__3 = j + i__ * a_dim1;
+ temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[j + i__ * a_dim1]), abs(d__2));
+ }
+ } else {
+ if (i__ >= j) {
+ i__3 = i__ + j * a_dim1;
+ temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2));
+ } else {
+ i__3 = j + i__ * a_dim1;
+ temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[j + i__ * a_dim1]), abs(d__2));
+ }
+ }
+ i__3 = j;
+ symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[i__3]
+ .i == 0. || temp == 0.);
+ i__3 = j;
+ y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&x[j]), abs(d__2))) * temp;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += d_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*beta == 0.) {
+ symb_zero__ = TRUE_;
+ y[iy] = 0.;
+ } else if (y[iy] == 0.) {
+ symb_zero__ = TRUE_;
+ } else {
+ symb_zero__ = FALSE_;
+ y[iy] = *beta * (d__1 = y[iy], abs(d__1));
+ }
+ jx = kx;
+ if (*alpha != 0.) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (*uplo == ilauplo_("U")) {
+ if (i__ <= j) {
+ i__3 = i__ + j * a_dim1;
+ temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2));
+ } else {
+ i__3 = j + i__ * a_dim1;
+ temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[j + i__ * a_dim1]), abs(d__2));
+ }
+ } else {
+ if (i__ >= j) {
+ i__3 = i__ + j * a_dim1;
+ temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2));
+ } else {
+ i__3 = j + i__ * a_dim1;
+ temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[j + i__ * a_dim1]), abs(d__2));
+ }
+ }
+ i__3 = j;
+ symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[i__3]
+ .i == 0. || temp == 0.);
+ i__3 = jx;
+ y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&x[jx]), abs(d__2))) * temp;
+ jx += *incx;
+ }
+ }
+ if (! symb_zero__) {
+ y[iy] += d_sign(&safe1, &y[iy]);
+ }
+ iy += *incy;
+ }
+ }
+
+ return 0;
+
+/* End of ZLA_SYAMV */
+
+} /* zla_syamv__ */
diff --git a/SRC/zla_syrcond_c.c b/SRC/zla_syrcond_c.c
new file mode 100644
index 0000000..f819da6
--- /dev/null
+++ b/SRC/zla_syrcond_c.c
@@ -0,0 +1,333 @@
+/* zla_syrcond_c.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zla_syrcond_c__(char *uplo, integer *n, doublecomplex *a, integer *
+ lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublereal *c__,
+ logical *capply, integer *info, doublecomplex *work, doublereal *
+ rwork, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val, d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ logical up;
+ doublereal tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ doublereal anorm;
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *), xerbla_(
+ char *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int zsytrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_SYRCOND_C Computes the infinity norm condition number of */
+/* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by ZSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by ZSYTRF. */
+
+/* C (input) DOUBLE PRECISION array, dimension (N) */
+/* The vector C in the formula op(A) * inv(diag(C)). */
+
+/* CAPPLY (input) LOGICAL */
+/* If .TRUE. then access the vector C in the formula above. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) COMPLEX*16 array, dimension (2*N). */
+/* Workspace. */
+
+/* RWORK (input) DOUBLE PRECISION array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --c__;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ *info = 0;
+ if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLA_SYRCOND_C", &i__1);
+ return ret_val;
+ }
+ up = FALSE_;
+ if (lsame_(uplo, "U")) {
+ up = TRUE_;
+ }
+
+/* Compute norm of op(A)*op2(C). */
+
+ anorm = 0.;
+ if (up) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ if (*capply) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ j + i__ * a_dim1]), abs(d__2))) / c__[j];
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2))) / c__[j];
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ j + i__ * a_dim1]), abs(d__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2));
+ }
+ }
+ rwork[i__] = tmp;
+ anorm = max(anorm,tmp);
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ if (*capply) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2))) / c__[j];
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ j + i__ * a_dim1]), abs(d__2))) / c__[j];
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[
+ j + i__ * a_dim1]), abs(d__2));
+ }
+ }
+ rwork[i__] = tmp;
+ anorm = max(anorm,tmp);
+ }
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ ret_val = 1.;
+ return ret_val;
+ } else if (anorm == 0.) {
+ return ret_val;
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.;
+
+ kase = 0;
+L10:
+ zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+
+ if (up) {
+ zsytrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ } else {
+ zsytrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+
+/* Multiply by inv(C). */
+
+ if (*capply) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = c__[i__4] * work[i__3].r, z__1.i = c__[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ }
+ } else {
+
+/* Multiply by inv(C'). */
+
+ if (*capply) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = c__[i__4] * work[i__3].r, z__1.i = c__[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ }
+
+ if (up) {
+ zsytrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ } else {
+ zsytrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ ret_val = 1. / ainvnm;
+ }
+
+ return ret_val;
+
+} /* zla_syrcond_c__ */
diff --git a/SRC/zla_syrcond_x.c b/SRC/zla_syrcond_x.c
new file mode 100644
index 0000000..682f54d
--- /dev/null
+++ b/SRC/zla_syrcond_x.c
@@ -0,0 +1,311 @@
+/* zla_syrcond_x.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zla_syrcond_x__(char *uplo, integer *n, doublecomplex *a, integer *
+ lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublecomplex *
+ x, integer *info, doublecomplex *work, doublereal *rwork, ftnlen
+ uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val, d__1, d__2;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ logical up;
+ doublereal tmp;
+ integer kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ doublereal anorm;
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *), xerbla_(
+ char *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int zsytrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_SYRCOND_X Computes the infinity norm condition number of */
+/* op(A) * diag(X) where X is a COMPLEX*16 vector. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by ZSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by ZSYTRF. */
+
+/* X (input) COMPLEX*16 array, dimension (N) */
+/* The vector X in the formula op(A) * diag(X). */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* i > 0: The ith argument is invalid. */
+
+/* WORK (input) COMPLEX*16 array, dimension (2*N). */
+/* Workspace. */
+
+/* RWORK (input) DOUBLE PRECISION array, dimension (N). */
+/* Workspace. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --x;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ *info = 0;
+ if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLA_SYRCOND_X", &i__1);
+ return ret_val;
+ }
+ up = FALSE_;
+ if (lsame_(uplo, "U")) {
+ up = TRUE_;
+ }
+
+/* Compute norm of op(A)*op2(C). */
+
+ anorm = 0.;
+ if (up) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ i__4 = j;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
+ abs(d__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = j;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
+ abs(d__2));
+ }
+ rwork[i__] = tmp;
+ anorm = max(anorm,tmp);
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = 0.;
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = j;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
+ abs(d__2));
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ i__4 = j;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4]
+ .r;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
+ abs(d__2));
+ }
+ rwork[i__] = tmp;
+ anorm = max(anorm,tmp);
+ }
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ ret_val = 1.;
+ return ret_val;
+ } else if (anorm == 0.) {
+ return ret_val;
+ }
+
+/* Estimate the norm of inv(op(A)). */
+
+ ainvnm = 0.;
+
+ kase = 0;
+L10:
+ zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == 2) {
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+
+ if (up) {
+ zsytrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ } else {
+ zsytrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+
+/* Multiply by inv(X). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ z_div(&z__1, &work[i__], &x[i__]);
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ } else {
+
+/* Multiply by inv(X'). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ z_div(&z__1, &work[i__], &x[i__]);
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+
+ if (up) {
+ zsytrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ } else {
+ zsytrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+
+/* Multiply by R. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ ret_val = 1. / ainvnm;
+ }
+
+ return ret_val;
+
+} /* zla_syrcond_x__ */
diff --git a/SRC/zla_syrfsx_extended.c b/SRC/zla_syrfsx_extended.c
new file mode 100644
index 0000000..072c62e
--- /dev/null
+++ b/SRC/zla_syrfsx_extended.c
@@ -0,0 +1,626 @@
+/* zla_syrfsx_extended.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublecomplex c_b11 = {-1.,0.};
+static doublecomplex c_b12 = {1.,0.};
+static doublereal c_b33 = 1.;
+
+/* Subroutine */ int zla_syrfsx_extended__(integer *prec_type__, char *uplo,
+ integer *n, integer *nrhs, doublecomplex *a, integer *lda,
+ doublecomplex *af, integer *ldaf, integer *ipiv, logical *colequ,
+ doublereal *c__, doublecomplex *b, integer *ldb, doublecomplex *y,
+ integer *ldy, doublereal *berr_out__, integer *n_norms__, doublereal *
+ err_bnds_norm__, doublereal *err_bnds_comp__, doublecomplex *res,
+ doublereal *ayb, doublecomplex *dy, doublecomplex *y_tail__,
+ doublereal *rcond, integer *ithresh, doublereal *rthresh, doublereal *
+ dz_ub__, logical *ignore_cwise__, integer *info, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1,
+ y_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ doublereal dxratmax, dzratmax;
+ integer i__, j;
+ logical incr_prec__;
+ doublereal prev_dz_z__;
+ extern /* Subroutine */ int zla_syamv__(integer *, integer *, doublereal *
+ , doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, integer *);
+ doublereal yk, final_dx_x__, final_dz_z__;
+ extern /* Subroutine */ int zla_wwaddw__(integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *);
+ doublereal prevnormdx;
+ integer cnt;
+ doublereal dyk, eps, incr_thresh__, dx_x__, dz_z__, ymin;
+ extern /* Subroutine */ int zla_lin_berr__(integer *, integer *, integer *
+ , doublecomplex *, doublereal *, doublereal *);
+ integer y_prec_state__, uplo2;
+ extern /* Subroutine */ int blas_zsymv_x__(integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *)
+ ;
+ extern logical lsame_(char *, char *);
+ doublereal dxrat, dzrat;
+ extern /* Subroutine */ int blas_zsymv2_x__(integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+ doublereal normx, normy;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), zsymv_(
+ char *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ extern doublereal dlamch_(char *);
+ doublereal normdx;
+ extern /* Subroutine */ int zsytrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *);
+ doublereal hugeval;
+ extern integer ilauplo_(char *);
+ integer x_state__, z_state__;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_SYRFSX_EXTENDED improves the computed solution to a system of */
+/* linear equations by performing extra-precise iterative refinement */
+/* and provides error bounds and backward error estimates for the solution. */
+/* This subroutine is called by ZSYRFSX to perform iterative refinement. */
+/* In addition to normwise error bound, the code provides maximum */
+/* componentwise error bound if possible. See comments for ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP for details of the error bounds. Note that this */
+/* subroutine is only resonsible for setting the second fields of */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP. */
+
+/* Arguments */
+/* ========= */
+
+/* PREC_TYPE (input) INTEGER */
+/* Specifies the intermediate precision to be used in refinement. */
+/* The value is defined by ILAPREC(P) where P is a CHARACTER and */
+/* P = 'S': Single */
+/* = 'D': Double */
+/* = 'I': Indigenous */
+/* = 'X', 'E': Extra */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right-hand-sides, i.e., the number of columns of the */
+/* matrix B. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by ZSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by ZSYTRF. */
+
+/* COLEQU (input) LOGICAL */
+/* If .TRUE. then column equilibration was done to A before calling */
+/* this routine. This is needed to compute the solution and error */
+/* bounds correctly. */
+
+/* C (input) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. If COLEQU = .FALSE., C */
+/* is not accessed. If C is input, each element of C should be a power */
+/* of the radix to ensure a reliable solution and error estimates. */
+/* Scaling by powers of the radix does not cause rounding errors unless */
+/* the result underflows or overflows. Rounding errors during scaling */
+/* lead to refining with a matrix that is not equivalent to the */
+/* input matrix, producing error estimates that may not be */
+/* reliable. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right-hand-side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Y (input/output) COMPLEX*16 array, dimension */
+/* (LDY,NRHS) */
+/* On entry, the solution matrix X, as computed by ZSYTRS. */
+/* On exit, the improved solution matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= max(1,N). */
+
+/* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* On exit, BERR_OUT(j) contains the componentwise relative backward */
+/* error for right-hand-side j from the formula */
+/* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. This is computed by ZLA_LIN_BERR. */
+
+/* N_NORMS (input) INTEGER */
+/* Determines which error bounds to return (see ERR_BNDS_NORM */
+/* and ERR_BNDS_COMP). */
+/* If N_NORMS >= 1 return normwise error bounds. */
+/* If N_NORMS >= 2 return componentwise error bounds. */
+
+/* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension */
+/* (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * slamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * slamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * slamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* This subroutine is only responsible for setting the second field */
+/* above. */
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* RES (input) COMPLEX*16 array, dimension (N) */
+/* Workspace to hold the intermediate residual. */
+
+/* AYB (input) DOUBLE PRECISION array, dimension (N) */
+/* Workspace. */
+
+/* DY (input) COMPLEX*16 array, dimension (N) */
+/* Workspace to hold the intermediate solution. */
+
+/* Y_TAIL (input) COMPLEX*16 array, dimension (N) */
+/* Workspace to hold the trailing bits of the intermediate solution. */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* ITHRESH (input) INTEGER */
+/* The maximum number of residual computations allowed for */
+/* refinement. The default is 10. For 'aggressive' set to 100 to */
+/* permit convergence using approximate factorizations or */
+/* factorizations other than LU. If the factorization uses a */
+/* technique other than Gaussian elimination, the guarantees in */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy. */
+
+/* RTHRESH (input) DOUBLE PRECISION */
+/* Determines when to stop refinement if the error estimate stops */
+/* decreasing. Refinement will stop when the next solution no longer */
+/* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */
+/* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */
+/* default value is 0.5. For 'aggressive' set to 0.9 to permit */
+/* convergence on extremely ill-conditioned matrices. See LAWN 165 */
+/* for more details. */
+
+/* DZ_UB (input) DOUBLE PRECISION */
+/* Determines when to start considering componentwise convergence. */
+/* Componentwise convergence is only considered after each component */
+/* of the solution Y is stable, which we definte as the relative */
+/* change in each component being less than DZ_UB. The default value */
+/* is 0.25, requiring the first bit to be stable. See LAWN 165 for */
+/* more details. */
+
+/* IGNORE_CWISE (input) LOGICAL */
+/* If .TRUE. then ignore componentwise convergence. Default value */
+/* is .FALSE.. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. */
+/* < 0: if INFO = -i, the ith argument to ZSYTRS had an illegal */
+/* value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --c__;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ --berr_out__;
+ --res;
+ --ayb;
+ --dy;
+ --y_tail__;
+
+ /* Function Body */
+ if (*info != 0) {
+ return 0;
+ }
+ eps = dlamch_("Epsilon");
+ hugeval = dlamch_("Overflow");
+/* Force HUGEVAL to Inf */
+ hugeval *= hugeval;
+/* Using HUGEVAL may lead to spurious underflows. */
+ incr_thresh__ = (doublereal) (*n) * eps;
+ if (lsame_(uplo, "L")) {
+ uplo2 = ilauplo_("L");
+ } else {
+ uplo2 = ilauplo_("U");
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ y_prec_state__ = 1;
+ if (y_prec_state__ == 2) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ y_tail__[i__3].r = 0., y_tail__[i__3].i = 0.;
+ }
+ }
+ dxrat = 0.;
+ dxratmax = 0.;
+ dzrat = 0.;
+ dzratmax = 0.;
+ final_dx_x__ = hugeval;
+ final_dz_z__ = hugeval;
+ prevnormdx = hugeval;
+ prev_dz_z__ = hugeval;
+ dz_z__ = hugeval;
+ dx_x__ = hugeval;
+ x_state__ = 1;
+ z_state__ = 0;
+ incr_prec__ = FALSE_;
+ i__2 = *ithresh;
+ for (cnt = 1; cnt <= i__2; ++cnt) {
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ if (y_prec_state__ == 0) {
+ zsymv_(uplo, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1],
+ &c__1, &c_b12, &res[1], &c__1);
+ } else if (y_prec_state__ == 1) {
+ blas_zsymv_x__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &c__1, &c_b12, &res[1], &c__1,
+ prec_type__);
+ } else {
+ blas_zsymv2_x__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j *
+ y_dim1 + 1], &y_tail__[1], &c__1, &c_b12, &res[1], &
+ c__1, prec_type__);
+ }
+/* XXX: RES is no longer needed. */
+ zcopy_(n, &res[1], &c__1, &dy[1], &c__1);
+ zsytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &dy[1], n,
+ info);
+
+/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
+
+ normx = 0.;
+ normy = 0.;
+ normdx = 0.;
+ dz_z__ = 0.;
+ ymin = hugeval;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * y_dim1;
+ yk = (d__1 = y[i__4].r, abs(d__1)) + (d__2 = d_imag(&y[i__ +
+ j * y_dim1]), abs(d__2));
+ i__4 = i__;
+ dyk = (d__1 = dy[i__4].r, abs(d__1)) + (d__2 = d_imag(&dy[i__]
+ ), abs(d__2));
+ if (yk != 0.) {
+/* Computing MAX */
+ d__1 = dz_z__, d__2 = dyk / yk;
+ dz_z__ = max(d__1,d__2);
+ } else if (dyk != 0.) {
+ dz_z__ = hugeval;
+ }
+ ymin = min(ymin,yk);
+ normy = max(normy,yk);
+ if (*colequ) {
+/* Computing MAX */
+ d__1 = normx, d__2 = yk * c__[i__];
+ normx = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = normdx, d__2 = dyk * c__[i__];
+ normdx = max(d__1,d__2);
+ } else {
+ normx = normy;
+ normdx = max(normdx,dyk);
+ }
+ }
+ if (normx != 0.) {
+ dx_x__ = normdx / normx;
+ } else if (normdx == 0.) {
+ dx_x__ = 0.;
+ } else {
+ dx_x__ = hugeval;
+ }
+ dxrat = normdx / prevnormdx;
+ dzrat = dz_z__ / prev_dz_z__;
+
+/* Check termination criteria. */
+
+ if (ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2) {
+ incr_prec__ = TRUE_;
+ }
+ if (x_state__ == 3 && dxrat <= *rthresh) {
+ x_state__ = 1;
+ }
+ if (x_state__ == 1) {
+ if (dx_x__ <= eps) {
+ x_state__ = 2;
+ } else if (dxrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ x_state__ = 3;
+ }
+ } else {
+ if (dxrat > dxratmax) {
+ dxratmax = dxrat;
+ }
+ }
+ if (x_state__ > 1) {
+ final_dx_x__ = dx_x__;
+ }
+ }
+ if (z_state__ == 0 && dz_z__ <= *dz_ub__) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 3 && dzrat <= *rthresh) {
+ z_state__ = 1;
+ }
+ if (z_state__ == 1) {
+ if (dz_z__ <= eps) {
+ z_state__ = 2;
+ } else if (dz_z__ > *dz_ub__) {
+ z_state__ = 0;
+ dzratmax = 0.;
+ final_dz_z__ = hugeval;
+ } else if (dzrat > *rthresh) {
+ if (y_prec_state__ != 2) {
+ incr_prec__ = TRUE_;
+ } else {
+ z_state__ = 3;
+ }
+ } else {
+ if (dzrat > dzratmax) {
+ dzratmax = dzrat;
+ }
+ }
+ if (z_state__ > 1) {
+ final_dz_z__ = dz_z__;
+ }
+ }
+ if (x_state__ != 1 && (*ignore_cwise__ || z_state__ != 1)) {
+ goto L666;
+ }
+ if (incr_prec__) {
+ incr_prec__ = FALSE_;
+ ++y_prec_state__;
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ y_tail__[i__4].r = 0., y_tail__[i__4].i = 0.;
+ }
+ }
+ prevnormdx = normdx;
+ prev_dz_z__ = dz_z__;
+
+/* Update soluton. */
+
+ if (y_prec_state__ < 2) {
+ zaxpy_(n, &c_b12, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
+ } else {
+ zla_wwaddw__(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
+ }
+ }
+/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. */
+L666:
+
+/* Set final_* when cnt hits ithresh. */
+
+ if (x_state__ == 1) {
+ final_dx_x__ = dx_x__;
+ }
+ if (z_state__ == 1) {
+ final_dz_z__ = dz_z__;
+ }
+
+/* Compute error bounds. */
+
+ if (*n_norms__ >= 1) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / (
+ 1 - dxratmax);
+ }
+ if (*n_norms__ >= 2) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / (
+ 1 - dzratmax);
+ }
+
+/* Compute componentwise relative backward error from formula */
+/* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. */
+
+/* Compute residual RES = B_s - op(A_s) * Y, */
+/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
+
+ zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
+ zsymv_(uplo, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1,
+ &c_b12, &res[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ ayb[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__
+ + j * b_dim1]), abs(d__2));
+ }
+
+/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */
+
+ zla_syamv__(&uplo2, n, &c_b33, &a[a_offset], lda, &y[j * y_dim1 + 1],
+ &c__1, &c_b33, &ayb[1], &c__1);
+ zla_lin_berr__(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
+
+/* End of loop for each RHS. */
+
+ }
+
+ return 0;
+} /* zla_syrfsx_extended__ */
diff --git a/SRC/zla_syrpvgrw.c b/SRC/zla_syrpvgrw.c
new file mode 100644
index 0000000..b3c38ae
--- /dev/null
+++ b/SRC/zla_syrpvgrw.c
@@ -0,0 +1,355 @@
+/* zla_syrpvgrw.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal zla_syrpvgrw__(char *uplo, integer *n, integer *info,
+ doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf,
+ integer *ipiv, doublereal *work, ftnlen uplo_len)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3;
+ doublereal ret_val, d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, kp;
+ doublereal tmp, amax, umax;
+ extern logical lsame_(char *, char *);
+ integer ncols;
+ logical upper;
+ doublereal rpvgrw;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_SYRPVGRW computes the reciprocal pivot growth factor */
+/* norm(A)/norm(U). The "max absolute element" norm is used. If this is */
+/* much less than 1, the stability of the LU factorization of the */
+/* (equilibrated) matrix A could be poor. This also means that the */
+/* solution X, estimated condition numbers, and error bounds could be */
+/* unreliable. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* INFO (input) INTEGER */
+/* The value of INFO returned from ZSYTRF, .i.e., the pivot in */
+/* column INFO is exactly 0. */
+
+/* NCOLS (input) INTEGER */
+/* The number of columns of the matrix A. NCOLS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by ZSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by ZSYTRF. */
+
+/* WORK (input) COMPLEX*16 array, dimension (2*N) */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ upper = lsame_("Upper", uplo);
+ if (*info == 0) {
+ if (upper) {
+ ncols = 1;
+ } else {
+ ncols = *n;
+ }
+ } else {
+ ncols = *info;
+ }
+ rpvgrw = 1.;
+ i__1 = *n << 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+ }
+
+/* Find the max magnitude entry of each column of A. Compute the max */
+/* for all N columns so we can apply the pivot permutation while */
+/* looping below. Assume a full factorization is the common case. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ + j * a_dim1]), abs(d__2)), d__4 = work[*n + i__];
+ work[*n + i__] = max(d__3,d__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ + j * a_dim1]), abs(d__2)), d__4 = work[*n + j];
+ work[*n + j] = max(d__3,d__4);
+ }
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ + j * a_dim1]), abs(d__2)), d__4 = work[*n + i__];
+ work[*n + i__] = max(d__3,d__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ + j * a_dim1]), abs(d__2)), d__4 = work[*n + j];
+ work[*n + j] = max(d__3,d__4);
+ }
+ }
+ }
+
+/* Now find the max magnitude entry of each column of U or L. Also */
+/* permute the magnitudes of A above so they're in the same order as */
+/* the factor. */
+
+/* The iteration orders and permutations were copied from zsytrs. */
+/* Calls to SSWAP would be severe overkill. */
+
+ if (upper) {
+ k = *n;
+ while(k < ncols && k > 0) {
+ if (ipiv[k] > 0) {
+/* 1x1 pivot */
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ i__2 = i__ + k * af_dim1;
+ d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(&
+ af[i__ + k * af_dim1]), abs(d__2)), d__4 = work[k]
+ ;
+ work[k] = max(d__3,d__4);
+ }
+ --k;
+ } else {
+/* 2x2 pivot */
+ kp = -ipiv[k];
+ tmp = work[*n + k - 1];
+ work[*n + k - 1] = work[*n + kp];
+ work[*n + kp] = tmp;
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ i__2 = i__ + k * af_dim1;
+ d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(&
+ af[i__ + k * af_dim1]), abs(d__2)), d__4 = work[k]
+ ;
+ work[k] = max(d__3,d__4);
+/* Computing MAX */
+ i__2 = i__ + (k - 1) * af_dim1;
+ d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(&
+ af[i__ + (k - 1) * af_dim1]), abs(d__2)), d__4 =
+ work[k - 1];
+ work[k - 1] = max(d__3,d__4);
+ }
+/* Computing MAX */
+ i__1 = k + k * af_dim1;
+ d__3 = (d__1 = af[i__1].r, abs(d__1)) + (d__2 = d_imag(&af[k
+ + k * af_dim1]), abs(d__2)), d__4 = work[k];
+ work[k] = max(d__3,d__4);
+ k += -2;
+ }
+ }
+ k = ncols;
+ while(k <= *n) {
+ if (ipiv[k] > 0) {
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ ++k;
+ } else {
+ kp = -ipiv[k];
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ k += 2;
+ }
+ }
+ } else {
+ k = 1;
+ while(k <= ncols) {
+ if (ipiv[k] > 0) {
+/* 1x1 pivot */
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ i__1 = *n;
+ for (i__ = k; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ i__2 = i__ + k * af_dim1;
+ d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(&
+ af[i__ + k * af_dim1]), abs(d__2)), d__4 = work[k]
+ ;
+ work[k] = max(d__3,d__4);
+ }
+ ++k;
+ } else {
+/* 2x2 pivot */
+ kp = -ipiv[k];
+ tmp = work[*n + k + 1];
+ work[*n + k + 1] = work[*n + kp];
+ work[*n + kp] = tmp;
+ i__1 = *n;
+ for (i__ = k + 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ i__2 = i__ + k * af_dim1;
+ d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(&
+ af[i__ + k * af_dim1]), abs(d__2)), d__4 = work[k]
+ ;
+ work[k] = max(d__3,d__4);
+/* Computing MAX */
+ i__2 = i__ + (k + 1) * af_dim1;
+ d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(&
+ af[i__ + (k + 1) * af_dim1]), abs(d__2)), d__4 =
+ work[k + 1];
+ work[k + 1] = max(d__3,d__4);
+ }
+/* Computing MAX */
+ i__1 = k + k * af_dim1;
+ d__3 = (d__1 = af[i__1].r, abs(d__1)) + (d__2 = d_imag(&af[k
+ + k * af_dim1]), abs(d__2)), d__4 = work[k];
+ work[k] = max(d__3,d__4);
+ k += 2;
+ }
+ }
+ k = ncols;
+ while(k >= 1) {
+ if (ipiv[k] > 0) {
+ kp = ipiv[k];
+ if (kp != k) {
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ }
+ --k;
+ } else {
+ kp = -ipiv[k];
+ tmp = work[*n + k];
+ work[*n + k] = work[*n + kp];
+ work[*n + kp] = tmp;
+ k += -2;
+ }
+ }
+ }
+
+/* Compute the *inverse* of the max element growth factor. Dividing */
+/* by zero would imply the largest entry of the factor's column is */
+/* zero. Than can happen when either the column of A is zero or */
+/* massive pivots made the factor underflow to zero. Neither counts */
+/* as growth in itself, so simply ignore terms with zero */
+/* denominators. */
+
+ if (upper) {
+ i__1 = *n;
+ for (i__ = ncols; i__ <= i__1; ++i__) {
+ umax = work[i__];
+ amax = work[*n + i__];
+ if (umax != 0.) {
+/* Computing MIN */
+ d__1 = amax / umax;
+ rpvgrw = min(d__1,rpvgrw);
+ }
+ }
+ } else {
+ i__1 = ncols;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ umax = work[i__];
+ amax = work[*n + i__];
+ if (umax != 0.) {
+/* Computing MIN */
+ d__1 = amax / umax;
+ rpvgrw = min(d__1,rpvgrw);
+ }
+ }
+ }
+ ret_val = rpvgrw;
+ return ret_val;
+} /* zla_syrpvgrw__ */
diff --git a/SRC/zla_wwaddw.c b/SRC/zla_wwaddw.c
new file mode 100644
index 0000000..31bf913
--- /dev/null
+++ b/SRC/zla_wwaddw.c
@@ -0,0 +1,93 @@
+/* zla_wwaddw.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zla_wwaddw__(integer *n, doublecomplex *x, doublecomplex
+ *y, doublecomplex *w)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Local variables */
+ integer i__;
+ doublecomplex s;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLA_WWADDW adds a vector W into a doubled-single vector (X, Y). */
+
+/* This works for all extant IBM's hex and binary floating point */
+/* arithmetics, but not for decimal. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The length of vectors X, Y, and W. */
+
+/* X, Y (input/output) COMPLEX*16 array, length N */
+/* The doubled-single accumulation vector. */
+
+/* W (input) COMPLEX*16 array, length N */
+/* The vector to be added. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ --w;
+ --y;
+ --x;
+
+ /* Function Body */
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ z__1.r = x[i__2].r + w[i__3].r, z__1.i = x[i__2].i + w[i__3].i;
+ s.r = z__1.r, s.i = z__1.i;
+ z__2.r = s.r + s.r, z__2.i = s.i + s.i;
+ z__1.r = z__2.r - s.r, z__1.i = z__2.i - s.i;
+ s.r = z__1.r, s.i = z__1.i;
+ i__2 = i__;
+ i__3 = i__;
+ z__3.r = x[i__3].r - s.r, z__3.i = x[i__3].i - s.i;
+ i__4 = i__;
+ z__2.r = z__3.r + w[i__4].r, z__2.i = z__3.i + w[i__4].i;
+ i__5 = i__;
+ z__1.r = z__2.r + y[i__5].r, z__1.i = z__2.i + y[i__5].i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ i__2 = i__;
+ x[i__2].r = s.r, x[i__2].i = s.i;
+/* L10: */
+ }
+ return 0;
+} /* zla_wwaddw__ */
diff --git a/SRC/zlabrd.c b/SRC/zlabrd.c
new file mode 100644
index 0000000..4019ed3
--- /dev/null
+++ b/SRC/zlabrd.c
@@ -0,0 +1,502 @@
+/* zlabrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zlabrd_(integer *m, integer *n, integer *nb,
+ doublecomplex *a, integer *lda, doublereal *d__, doublereal *e,
+ doublecomplex *tauq, doublecomplex *taup, doublecomplex *x, integer *
+ ldx, doublecomplex *y, integer *ldy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2,
+ i__3;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__;
+ doublecomplex alpha;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *), zlacgv_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLABRD reduces the first NB rows and columns of a complex general */
+/* m by n matrix A to upper or lower real bidiagonal form by a unitary */
+/* transformation Q' * A * P, and returns the matrices X and Y which */
+/* are needed to apply the transformation to the unreduced part of A. */
+
+/* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower */
+/* bidiagonal form. */
+
+/* This is an auxiliary routine called by ZGEBRD */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows in the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns in the matrix A. */
+
+/* NB (input) INTEGER */
+/* The number of leading rows and columns of A to be reduced. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the m by n general matrix to be reduced. */
+/* On exit, the first NB rows and columns of the matrix are */
+/* overwritten; the rest of the array is unchanged. */
+/* If m >= n, elements on and below the diagonal in the first NB */
+/* columns, with the array TAUQ, represent the unitary */
+/* matrix Q as a product of elementary reflectors; and */
+/* elements above the diagonal in the first NB rows, with the */
+/* array TAUP, represent the unitary matrix P as a product */
+/* of elementary reflectors. */
+/* If m < n, elements below the diagonal in the first NB */
+/* columns, with the array TAUQ, represent the unitary */
+/* matrix Q as a product of elementary reflectors, and */
+/* elements on and above the diagonal in the first NB rows, */
+/* with the array TAUP, represent the unitary matrix P as */
+/* a product of elementary reflectors. */
+/* See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* D (output) DOUBLE PRECISION array, dimension (NB) */
+/* The diagonal elements of the first NB rows and columns of */
+/* the reduced matrix. D(i) = A(i,i). */
+
+/* E (output) DOUBLE PRECISION array, dimension (NB) */
+/* The off-diagonal elements of the first NB rows and columns of */
+/* the reduced matrix. */
+
+/* TAUQ (output) COMPLEX*16 array dimension (NB) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the unitary matrix Q. See Further Details. */
+
+/* TAUP (output) COMPLEX*16 array, dimension (NB) */
+/* The scalar factors of the elementary reflectors which */
+/* represent the unitary matrix P. See Further Details. */
+
+/* X (output) COMPLEX*16 array, dimension (LDX,NB) */
+/* The m-by-nb matrix X required to update the unreduced part */
+/* of A. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,M). */
+
+/* Y (output) COMPLEX*16 array, dimension (LDY,NB) */
+/* The n-by-nb matrix Y required to update the unreduced part */
+/* of A. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= max(1,N). */
+
+/* Further Details */
+/* =============== */
+
+/* The matrices Q and P are represented as products of elementary */
+/* reflectors: */
+
+/* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) */
+
+/* Each H(i) and G(i) has the form: */
+
+/* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' */
+
+/* where tauq and taup are complex scalars, and v and u are complex */
+/* vectors. */
+
+/* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in */
+/* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in */
+/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in */
+/* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in */
+/* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */
+
+/* The elements of the vectors v and u together form the m-by-nb matrix */
+/* V and the nb-by-n matrix U' which are needed, with X and Y, to apply */
+/* the transformation to the unreduced part of the matrix, using a block */
+/* update of the form: A := A - V*Y' - X*U'. */
+
+/* The contents of A on exit are illustrated by the following examples */
+/* with nb = 2: */
+
+/* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */
+
+/* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) */
+/* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) */
+/* ( v1 v2 a a a ) ( v1 1 a a a a ) */
+/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */
+/* ( v1 v2 a a a ) ( v1 v2 a a a a ) */
+/* ( v1 v2 a a a ) */
+
+/* where a denotes an element of the original matrix which is unchanged, */
+/* vi denotes an element of the vector defining H(i), and ui an element */
+/* of the vector defining G(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ --tauq;
+ --taup;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+ if (*m >= *n) {
+
+/* Reduce to upper bidiagonal form */
+
+ i__1 = *nb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Update A(i:m,i) */
+
+ i__2 = i__ - 1;
+ zlacgv_(&i__2, &y[i__ + y_dim1], ldy);
+ i__2 = *m - i__ + 1;
+ i__3 = i__ - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + a_dim1], lda,
+ &y[i__ + y_dim1], ldy, &c_b2, &a[i__ + i__ * a_dim1], &
+ c__1);
+ i__2 = i__ - 1;
+ zlacgv_(&i__2, &y[i__ + y_dim1], ldy);
+ i__2 = *m - i__ + 1;
+ i__3 = i__ - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__2, &i__3, &z__1, &x[i__ + x_dim1], ldx,
+ &a[i__ * a_dim1 + 1], &c__1, &c_b2, &a[i__ + i__ *
+ a_dim1], &c__1);
+
+/* Generate reflection Q(i) to annihilate A(i+1:m,i) */
+
+ i__2 = i__ + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *m - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ zlarfg_(&i__2, &alpha, &a[min(i__3, *m)+ i__ * a_dim1], &c__1, &
+ tauq[i__]);
+ i__2 = i__;
+ d__[i__2] = alpha.r;
+ if (i__ < *n) {
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+
+/* Compute Y(i+1:n,i) */
+
+ i__2 = *m - i__ + 1;
+ i__3 = *n - i__;
+ zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + (
+ i__ + 1) * a_dim1], lda, &a[i__ + i__ * a_dim1], &
+ c__1, &c_b1, &y[i__ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *m - i__ + 1;
+ i__3 = i__ - 1;
+ zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ +
+ a_dim1], lda, &a[i__ + i__ * a_dim1], &c__1, &c_b1, &
+ y[i__ * y_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__2, &i__3, &z__1, &y[i__ + 1 +
+ y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b2, &y[
+ i__ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *m - i__ + 1;
+ i__3 = i__ - 1;
+ zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &x[i__ +
+ x_dim1], ldx, &a[i__ + i__ * a_dim1], &c__1, &c_b1, &
+ y[i__ * y_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &a[(i__ +
+ 1) * a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &
+ c_b2, &y[i__ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *n - i__;
+ zscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
+
+/* Update A(i,i+1:n) */
+
+ i__2 = *n - i__;
+ zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
+ zlacgv_(&i__, &a[i__ + a_dim1], lda);
+ i__2 = *n - i__;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__2, &i__, &z__1, &y[i__ + 1 +
+ y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b2, &a[i__ + (
+ i__ + 1) * a_dim1], lda);
+ zlacgv_(&i__, &a[i__ + a_dim1], lda);
+ i__2 = i__ - 1;
+ zlacgv_(&i__2, &x[i__ + x_dim1], ldx);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &a[(i__ +
+ 1) * a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b2, &
+ a[i__ + (i__ + 1) * a_dim1], lda);
+ i__2 = i__ - 1;
+ zlacgv_(&i__2, &x[i__ + x_dim1], ldx);
+
+/* Generate reflection P(i) to annihilate A(i,i+2:n) */
+
+ i__2 = i__ + (i__ + 1) * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *n - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ zlarfg_(&i__2, &alpha, &a[i__ + min(i__3, *n)* a_dim1], lda, &
+ taup[i__]);
+ i__2 = i__;
+ e[i__2] = alpha.r;
+ i__2 = i__ + (i__ + 1) * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+
+/* Compute X(i+1:m,i) */
+
+ i__2 = *m - i__;
+ i__3 = *n - i__;
+ zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (i__
+ + 1) * a_dim1], lda, &a[i__ + (i__ + 1) * a_dim1],
+ lda, &c_b1, &x[i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = *n - i__;
+ zgemv_("Conjugate transpose", &i__2, &i__, &c_b2, &y[i__ + 1
+ + y_dim1], ldy, &a[i__ + (i__ + 1) * a_dim1], lda, &
+ c_b1, &x[i__ * x_dim1 + 1], &c__1);
+ i__2 = *m - i__;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__2, &i__, &z__1, &a[i__ + 1 +
+ a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
+ i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[(i__ + 1) *
+ a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, &
+ c_b1, &x[i__ * x_dim1 + 1], &c__1);
+ i__2 = *m - i__;
+ i__3 = i__ - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__2, &i__3, &z__1, &x[i__ + 1 +
+ x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
+ i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = *m - i__;
+ zscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = *n - i__;
+ zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Reduce to lower bidiagonal form */
+
+ i__1 = *nb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Update A(i,i:n) */
+
+ i__2 = *n - i__ + 1;
+ zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
+ i__2 = i__ - 1;
+ zlacgv_(&i__2, &a[i__ + a_dim1], lda);
+ i__2 = *n - i__ + 1;
+ i__3 = i__ - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__2, &i__3, &z__1, &y[i__ + y_dim1], ldy,
+ &a[i__ + a_dim1], lda, &c_b2, &a[i__ + i__ * a_dim1],
+ lda);
+ i__2 = i__ - 1;
+ zlacgv_(&i__2, &a[i__ + a_dim1], lda);
+ i__2 = i__ - 1;
+ zlacgv_(&i__2, &x[i__ + x_dim1], ldx);
+ i__2 = i__ - 1;
+ i__3 = *n - i__ + 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &a[i__ *
+ a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b2, &a[i__ +
+ i__ * a_dim1], lda);
+ i__2 = i__ - 1;
+ zlacgv_(&i__2, &x[i__ + x_dim1], ldx);
+
+/* Generate reflection P(i) to annihilate A(i,i+1:n) */
+
+ i__2 = i__ + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *n - i__ + 1;
+/* Computing MIN */
+ i__3 = i__ + 1;
+ zlarfg_(&i__2, &alpha, &a[i__ + min(i__3, *n)* a_dim1], lda, &
+ taup[i__]);
+ i__2 = i__;
+ d__[i__2] = alpha.r;
+ if (i__ < *m) {
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+
+/* Compute X(i+1:m,i) */
+
+ i__2 = *m - i__;
+ i__3 = *n - i__ + 1;
+ zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + i__ *
+ a_dim1], lda, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[
+ i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = *n - i__ + 1;
+ i__3 = i__ - 1;
+ zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &y[i__ +
+ y_dim1], ldy, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[
+ i__ * x_dim1 + 1], &c__1);
+ i__2 = *m - i__;
+ i__3 = i__ - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + 1 +
+ a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
+ i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__ + 1;
+ zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ * a_dim1 +
+ 1], lda, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[i__ *
+ x_dim1 + 1], &c__1);
+ i__2 = *m - i__;
+ i__3 = i__ - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__2, &i__3, &z__1, &x[i__ + 1 +
+ x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[
+ i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = *m - i__;
+ zscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1);
+ i__2 = *n - i__ + 1;
+ zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
+
+/* Update A(i+1:m,i) */
+
+ i__2 = i__ - 1;
+ zlacgv_(&i__2, &y[i__ + y_dim1], ldy);
+ i__2 = *m - i__;
+ i__3 = i__ - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + 1 +
+ a_dim1], lda, &y[i__ + y_dim1], ldy, &c_b2, &a[i__ +
+ 1 + i__ * a_dim1], &c__1);
+ i__2 = i__ - 1;
+ zlacgv_(&i__2, &y[i__ + y_dim1], ldy);
+ i__2 = *m - i__;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__2, &i__, &z__1, &x[i__ + 1 +
+ x_dim1], ldx, &a[i__ * a_dim1 + 1], &c__1, &c_b2, &a[
+ i__ + 1 + i__ * a_dim1], &c__1);
+
+/* Generate reflection Q(i) to annihilate A(i+2:m,i) */
+
+ i__2 = i__ + 1 + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *m - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ zlarfg_(&i__2, &alpha, &a[min(i__3, *m)+ i__ * a_dim1], &c__1,
+ &tauq[i__]);
+ i__2 = i__;
+ e[i__2] = alpha.r;
+ i__2 = i__ + 1 + i__ * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+
+/* Compute Y(i+1:n,i) */
+
+ i__2 = *m - i__;
+ i__3 = *n - i__;
+ zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1
+ + (i__ + 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1]
+, &c__1, &c_b1, &y[i__ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *m - i__;
+ i__3 = i__ - 1;
+ zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1
+ + a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &
+ c_b1, &y[i__ * y_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__2, &i__3, &z__1, &y[i__ + 1 +
+ y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b2, &y[
+ i__ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *m - i__;
+ zgemv_("Conjugate transpose", &i__2, &i__, &c_b2, &x[i__ + 1
+ + x_dim1], ldx, &a[i__ + 1 + i__ * a_dim1], &c__1, &
+ c_b1, &y[i__ * y_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Conjugate transpose", &i__, &i__2, &z__1, &a[(i__ + 1)
+ * a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, &
+ c_b2, &y[i__ + 1 + i__ * y_dim1], &c__1);
+ i__2 = *n - i__;
+ zscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1);
+ } else {
+ i__2 = *n - i__ + 1;
+ zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+/* End of ZLABRD */
+
+} /* zlabrd_ */
diff --git a/SRC/zlacgv.c b/SRC/zlacgv.c
new file mode 100644
index 0000000..e455696
--- /dev/null
+++ b/SRC/zlacgv.c
@@ -0,0 +1,95 @@
+/* zlacgv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlacgv_(integer *n, doublecomplex *x, integer *incx)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, ioff;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLACGV conjugates a complex vector of length N. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The length of the vector X. N >= 0. */
+
+/* X (input/output) COMPLEX*16 array, dimension */
+/* (1+(N-1)*abs(INCX)) */
+/* On entry, the vector of length N to be conjugated. */
+/* On exit, X is overwritten with conjg(X). */
+
+/* INCX (input) INTEGER */
+/* The spacing between successive elements of X. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --x;
+
+ /* Function Body */
+ if (*incx == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ d_cnjg(&z__1, &x[i__]);
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+/* L10: */
+ }
+ } else {
+ ioff = 1;
+ if (*incx < 0) {
+ ioff = 1 - (*n - 1) * *incx;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ioff;
+ d_cnjg(&z__1, &x[ioff]);
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ ioff += *incx;
+/* L20: */
+ }
+ }
+ return 0;
+
+/* End of ZLACGV */
+
+} /* zlacgv_ */
diff --git a/SRC/zlacn2.c b/SRC/zlacn2.c
new file mode 100644
index 0000000..522fdaf
--- /dev/null
+++ b/SRC/zlacn2.c
@@ -0,0 +1,283 @@
+/* zlacn2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zlacn2_(integer *n, doublecomplex *v, doublecomplex *x,
+ doublereal *est, integer *kase, integer *isave)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *), d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__;
+ doublereal temp, absxi;
+ integer jlast;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern integer izmax1_(integer *, doublecomplex *, integer *);
+ extern doublereal dzsum1_(integer *, doublecomplex *, integer *), dlamch_(
+ char *);
+ doublereal safmin, altsgn, estold;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLACN2 estimates the 1-norm of a square, complex matrix A. */
+/* Reverse communication is used for evaluating matrix-vector products. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 1. */
+
+/* V (workspace) COMPLEX*16 array, dimension (N) */
+/* On the final return, V = A*W, where EST = norm(V)/norm(W) */
+/* (W is not returned). */
+
+/* X (input/output) COMPLEX*16 array, dimension (N) */
+/* On an intermediate return, X should be overwritten by */
+/* A * X, if KASE=1, */
+/* A' * X, if KASE=2, */
+/* where A' is the conjugate transpose of A, and ZLACN2 must be */
+/* re-called with all the other parameters unchanged. */
+
+/* EST (input/output) DOUBLE PRECISION */
+/* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be */
+/* unchanged from the previous call to ZLACN2. */
+/* On exit, EST is an estimate (a lower bound) for norm(A). */
+
+/* KASE (input/output) INTEGER */
+/* On the initial call to ZLACN2, KASE should be 0. */
+/* On an intermediate return, KASE will be 1 or 2, indicating */
+/* whether X should be overwritten by A * X or A' * X. */
+/* On the final return from ZLACN2, KASE will again be 0. */
+
+/* ISAVE (input/output) INTEGER array, dimension (3) */
+/* ISAVE is used to save variables between calls to ZLACN2 */
+
+/* Further Details */
+/* ======= ======= */
+
+/* Contributed by Nick Higham, University of Manchester. */
+/* Originally named CONEST, dated March 16, 1988. */
+
+/* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */
+/* a real or complex matrix, with applications to condition estimation", */
+/* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */
+
+/* Last modified: April, 1999 */
+
+/* This is a thread safe version of ZLACON, which uses the array ISAVE */
+/* in place of a SAVE statement, as follows: */
+
+/* ZLACON ZLACN2 */
+/* JUMP ISAVE(1) */
+/* J ISAVE(2) */
+/* ITER ISAVE(3) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --isave;
+ --x;
+ --v;
+
+ /* Function Body */
+ safmin = dlamch_("Safe minimum");
+ if (*kase == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ d__1 = 1. / (doublereal) (*n);
+ z__1.r = d__1, z__1.i = 0.;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+/* L10: */
+ }
+ *kase = 1;
+ isave[1] = 1;
+ return 0;
+ }
+
+ switch (isave[1]) {
+ case 1: goto L20;
+ case 2: goto L40;
+ case 3: goto L70;
+ case 4: goto L90;
+ case 5: goto L120;
+ }
+
+/* ................ ENTRY (ISAVE( 1 ) = 1) */
+/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */
+
+L20:
+ if (*n == 1) {
+ v[1].r = x[1].r, v[1].i = x[1].i;
+ *est = z_abs(&v[1]);
+/* ... QUIT */
+ goto L130;
+ }
+ *est = dzsum1_(n, &x[1], &c__1);
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ absxi = z_abs(&x[i__]);
+ if (absxi > safmin) {
+ i__2 = i__;
+ i__3 = i__;
+ d__1 = x[i__3].r / absxi;
+ d__2 = d_imag(&x[i__]) / absxi;
+ z__1.r = d__1, z__1.i = d__2;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ } else {
+ i__2 = i__;
+ x[i__2].r = 1., x[i__2].i = 0.;
+ }
+/* L30: */
+ }
+ *kase = 2;
+ isave[1] = 2;
+ return 0;
+
+/* ................ ENTRY (ISAVE( 1 ) = 2) */
+/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. */
+
+L40:
+ isave[2] = izmax1_(n, &x[1], &c__1);
+ isave[3] = 2;
+
+/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */
+
+L50:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ x[i__2].r = 0., x[i__2].i = 0.;
+/* L60: */
+ }
+ i__1 = isave[2];
+ x[i__1].r = 1., x[i__1].i = 0.;
+ *kase = 1;
+ isave[1] = 3;
+ return 0;
+
+/* ................ ENTRY (ISAVE( 1 ) = 3) */
+/* X HAS BEEN OVERWRITTEN BY A*X. */
+
+L70:
+ zcopy_(n, &x[1], &c__1, &v[1], &c__1);
+ estold = *est;
+ *est = dzsum1_(n, &v[1], &c__1);
+
+/* TEST FOR CYCLING. */
+ if (*est <= estold) {
+ goto L100;
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ absxi = z_abs(&x[i__]);
+ if (absxi > safmin) {
+ i__2 = i__;
+ i__3 = i__;
+ d__1 = x[i__3].r / absxi;
+ d__2 = d_imag(&x[i__]) / absxi;
+ z__1.r = d__1, z__1.i = d__2;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ } else {
+ i__2 = i__;
+ x[i__2].r = 1., x[i__2].i = 0.;
+ }
+/* L80: */
+ }
+ *kase = 2;
+ isave[1] = 4;
+ return 0;
+
+/* ................ ENTRY (ISAVE( 1 ) = 4) */
+/* X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. */
+
+L90:
+ jlast = isave[2];
+ isave[2] = izmax1_(n, &x[1], &c__1);
+ if (z_abs(&x[jlast]) != z_abs(&x[isave[2]]) && isave[3] < 5) {
+ ++isave[3];
+ goto L50;
+ }
+
+/* ITERATION COMPLETE. FINAL STAGE. */
+
+L100:
+ altsgn = 1.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ d__1 = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) + 1.);
+ z__1.r = d__1, z__1.i = 0.;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ altsgn = -altsgn;
+/* L110: */
+ }
+ *kase = 1;
+ isave[1] = 5;
+ return 0;
+
+/* ................ ENTRY (ISAVE( 1 ) = 5) */
+/* X HAS BEEN OVERWRITTEN BY A*X. */
+
+L120:
+ temp = dzsum1_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.;
+ if (temp > *est) {
+ zcopy_(n, &x[1], &c__1, &v[1], &c__1);
+ *est = temp;
+ }
+
+L130:
+ *kase = 0;
+ return 0;
+
+/* End of ZLACN2 */
+
+} /* zlacn2_ */
diff --git a/SRC/zlacon.c b/SRC/zlacon.c
new file mode 100644
index 0000000..9291b3f
--- /dev/null
+++ b/SRC/zlacon.c
@@ -0,0 +1,275 @@
+/* zlacon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zlacon_(integer *n, doublecomplex *v, doublecomplex *x,
+ doublereal *est, integer *kase)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *), d_imag(doublecomplex *);
+
+ /* Local variables */
+ static integer i__, j, iter;
+ static doublereal temp;
+ static integer jump;
+ static doublereal absxi;
+ static integer jlast;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern integer izmax1_(integer *, doublecomplex *, integer *);
+ extern doublereal dzsum1_(integer *, doublecomplex *, integer *), dlamch_(
+ char *);
+ static doublereal safmin, altsgn, estold;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLACON estimates the 1-norm of a square, complex matrix A. */
+/* Reverse communication is used for evaluating matrix-vector products. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 1. */
+
+/* V (workspace) COMPLEX*16 array, dimension (N) */
+/* On the final return, V = A*W, where EST = norm(V)/norm(W) */
+/* (W is not returned). */
+
+/* X (input/output) COMPLEX*16 array, dimension (N) */
+/* On an intermediate return, X should be overwritten by */
+/* A * X, if KASE=1, */
+/* A' * X, if KASE=2, */
+/* where A' is the conjugate transpose of A, and ZLACON must be */
+/* re-called with all the other parameters unchanged. */
+
+/* EST (input/output) DOUBLE PRECISION */
+/* On entry with KASE = 1 or 2 and JUMP = 3, EST should be */
+/* unchanged from the previous call to ZLACON. */
+/* On exit, EST is an estimate (a lower bound) for norm(A). */
+
+/* KASE (input/output) INTEGER */
+/* On the initial call to ZLACON, KASE should be 0. */
+/* On an intermediate return, KASE will be 1 or 2, indicating */
+/* whether X should be overwritten by A * X or A' * X. */
+/* On the final return from ZLACON, KASE will again be 0. */
+
+/* Further Details */
+/* ======= ======= */
+
+/* Contributed by Nick Higham, University of Manchester. */
+/* Originally named CONEST, dated March 16, 1988. */
+
+/* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */
+/* a real or complex matrix, with applications to condition estimation", */
+/* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */
+
+/* Last modified: April, 1999 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --x;
+ --v;
+
+ /* Function Body */
+ safmin = dlamch_("Safe minimum");
+ if (*kase == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ d__1 = 1. / (doublereal) (*n);
+ z__1.r = d__1, z__1.i = 0.;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+/* L10: */
+ }
+ *kase = 1;
+ jump = 1;
+ return 0;
+ }
+
+ switch (jump) {
+ case 1: goto L20;
+ case 2: goto L40;
+ case 3: goto L70;
+ case 4: goto L90;
+ case 5: goto L120;
+ }
+
+/* ................ ENTRY (JUMP = 1) */
+/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */
+
+L20:
+ if (*n == 1) {
+ v[1].r = x[1].r, v[1].i = x[1].i;
+ *est = z_abs(&v[1]);
+/* ... QUIT */
+ goto L130;
+ }
+ *est = dzsum1_(n, &x[1], &c__1);
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ absxi = z_abs(&x[i__]);
+ if (absxi > safmin) {
+ i__2 = i__;
+ i__3 = i__;
+ d__1 = x[i__3].r / absxi;
+ d__2 = d_imag(&x[i__]) / absxi;
+ z__1.r = d__1, z__1.i = d__2;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ } else {
+ i__2 = i__;
+ x[i__2].r = 1., x[i__2].i = 0.;
+ }
+/* L30: */
+ }
+ *kase = 2;
+ jump = 2;
+ return 0;
+
+/* ................ ENTRY (JUMP = 2) */
+/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. */
+
+L40:
+ j = izmax1_(n, &x[1], &c__1);
+ iter = 2;
+
+/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */
+
+L50:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ x[i__2].r = 0., x[i__2].i = 0.;
+/* L60: */
+ }
+ i__1 = j;
+ x[i__1].r = 1., x[i__1].i = 0.;
+ *kase = 1;
+ jump = 3;
+ return 0;
+
+/* ................ ENTRY (JUMP = 3) */
+/* X HAS BEEN OVERWRITTEN BY A*X. */
+
+L70:
+ zcopy_(n, &x[1], &c__1, &v[1], &c__1);
+ estold = *est;
+ *est = dzsum1_(n, &v[1], &c__1);
+
+/* TEST FOR CYCLING. */
+ if (*est <= estold) {
+ goto L100;
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ absxi = z_abs(&x[i__]);
+ if (absxi > safmin) {
+ i__2 = i__;
+ i__3 = i__;
+ d__1 = x[i__3].r / absxi;
+ d__2 = d_imag(&x[i__]) / absxi;
+ z__1.r = d__1, z__1.i = d__2;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ } else {
+ i__2 = i__;
+ x[i__2].r = 1., x[i__2].i = 0.;
+ }
+/* L80: */
+ }
+ *kase = 2;
+ jump = 4;
+ return 0;
+
+/* ................ ENTRY (JUMP = 4) */
+/* X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. */
+
+L90:
+ jlast = j;
+ j = izmax1_(n, &x[1], &c__1);
+ if (z_abs(&x[jlast]) != z_abs(&x[j]) && iter < 5) {
+ ++iter;
+ goto L50;
+ }
+
+/* ITERATION COMPLETE. FINAL STAGE. */
+
+L100:
+ altsgn = 1.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ d__1 = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) + 1.);
+ z__1.r = d__1, z__1.i = 0.;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ altsgn = -altsgn;
+/* L110: */
+ }
+ *kase = 1;
+ jump = 5;
+ return 0;
+
+/* ................ ENTRY (JUMP = 5) */
+/* X HAS BEEN OVERWRITTEN BY A*X. */
+
+L120:
+ temp = dzsum1_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.;
+ if (temp > *est) {
+ zcopy_(n, &x[1], &c__1, &v[1], &c__1);
+ *est = temp;
+ }
+
+L130:
+ *kase = 0;
+ return 0;
+
+/* End of ZLACON */
+
+} /* zlacon_ */
diff --git a/SRC/zlacp2.c b/SRC/zlacp2.c
new file mode 100644
index 0000000..2a1ecdb
--- /dev/null
+++ b/SRC/zlacp2.c
@@ -0,0 +1,134 @@
+/* zlacp2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlacp2_(char *uplo, integer *m, integer *n, doublereal *
+ a, integer *lda, doublecomplex *b, integer *ldb)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j;
+ extern logical lsame_(char *, char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLACP2 copies all or part of a real two-dimensional matrix A to a */
+/* complex matrix B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies the part of the matrix A to be copied to B. */
+/* = 'U': Upper triangular part */
+/* = 'L': Lower triangular part */
+/* Otherwise: All of the matrix A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The m by n matrix A. If UPLO = 'U', only the upper trapezium */
+/* is accessed; if UPLO = 'L', only the lower trapezium is */
+/* accessed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (output) COMPLEX*16 array, dimension (LDB,N) */
+/* On exit, B = A in the locations specified by UPLO. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(j,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * a_dim1;
+ b[i__3].r = a[i__4], b[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+
+ } else if (lsame_(uplo, "L")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * a_dim1;
+ b[i__3].r = a[i__4], b[i__3].i = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * a_dim1;
+ b[i__3].r = a[i__4], b[i__3].i = 0.;
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+
+ return 0;
+
+/* End of ZLACP2 */
+
+} /* zlacp2_ */
diff --git a/SRC/zlacpy.c b/SRC/zlacpy.c
new file mode 100644
index 0000000..dfa21c0
--- /dev/null
+++ b/SRC/zlacpy.c
@@ -0,0 +1,134 @@
+/* zlacpy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlacpy_(char *uplo, integer *m, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j;
+ extern logical lsame_(char *, char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLACPY copies all or part of a two-dimensional matrix A to another */
+/* matrix B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies the part of the matrix A to be copied to B. */
+/* = 'U': Upper triangular part */
+/* = 'L': Lower triangular part */
+/* Otherwise: All of the matrix A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The m by n matrix A. If UPLO = 'U', only the upper trapezium */
+/* is accessed; if UPLO = 'L', only the lower trapezium is */
+/* accessed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (output) COMPLEX*16 array, dimension (LDB,N) */
+/* On exit, B = A in the locations specified by UPLO. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(j,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * a_dim1;
+ b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i;
+/* L10: */
+ }
+/* L20: */
+ }
+
+ } else if (lsame_(uplo, "L")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * a_dim1;
+ b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i;
+/* L30: */
+ }
+/* L40: */
+ }
+
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * a_dim1;
+ b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i;
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+
+ return 0;
+
+/* End of ZLACPY */
+
+} /* zlacpy_ */
diff --git a/SRC/zlacrm.c b/SRC/zlacrm.c
new file mode 100644
index 0000000..96fb840
--- /dev/null
+++ b/SRC/zlacrm.c
@@ -0,0 +1,177 @@
+/* zlacrm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b6 = 1.;
+static doublereal c_b7 = 0.;
+
+/* Subroutine */ int zlacrm_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublereal *b, integer *ldb, doublecomplex *c__,
+ integer *ldc, doublereal *rwork)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, a_dim1, a_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, l;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLACRM performs a very simple matrix-matrix multiplication: */
+/* C := A * B, */
+/* where A is M by N and complex; B is N by N and real; */
+/* C is M by N and complex. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A and of the matrix C. */
+/* M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns and rows of the matrix B and */
+/* the number of columns of the matrix C. */
+/* N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA, N) */
+/* A contains the M by N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >=max(1,M). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB, N) */
+/* B contains the N by N matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >=max(1,N). */
+
+/* C (input) COMPLEX*16 array, dimension (LDC, N) */
+/* C contains the M by N matrix C. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >=max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*M*N) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ rwork[(j - 1) * *m + i__] = a[i__3].r;
+/* L10: */
+ }
+/* L20: */
+ }
+
+ l = *m * *n + 1;
+ dgemm_("N", "N", m, n, n, &c_b6, &rwork[1], m, &b[b_offset], ldb, &c_b7, &
+ rwork[l], m);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = l + (j - 1) * *m + i__ - 1;
+ c__[i__3].r = rwork[i__4], c__[i__3].i = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ rwork[(j - 1) * *m + i__] = d_imag(&a[i__ + j * a_dim1]);
+/* L50: */
+ }
+/* L60: */
+ }
+ dgemm_("N", "N", m, n, n, &c_b6, &rwork[1], m, &b[b_offset], ldb, &c_b7, &
+ rwork[l], m);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ d__1 = c__[i__4].r;
+ i__5 = l + (j - 1) * *m + i__ - 1;
+ z__1.r = d__1, z__1.i = rwork[i__5];
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+
+ return 0;
+
+/* End of ZLACRM */
+
+} /* zlacrm_ */
diff --git a/SRC/zlacrt.c b/SRC/zlacrt.c
new file mode 100644
index 0000000..270a9df
--- /dev/null
+++ b/SRC/zlacrt.c
@@ -0,0 +1,156 @@
+/* zlacrt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlacrt_(integer *n, doublecomplex *cx, integer *incx,
+ doublecomplex *cy, integer *incy, doublecomplex *c__, doublecomplex *
+ s)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Local variables */
+ integer i__, ix, iy;
+ doublecomplex ctemp;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLACRT performs the operation */
+
+/* ( c s )( x ) ==> ( x ) */
+/* ( -s c )( y ) ( y ) */
+
+/* where c and s are complex and the vectors x and y are complex. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of elements in the vectors CX and CY. */
+
+/* CX (input/output) COMPLEX*16 array, dimension (N) */
+/* On input, the vector x. */
+/* On output, CX is overwritten with c*x + s*y. */
+
+/* INCX (input) INTEGER */
+/* The increment between successive values of CX. INCX <> 0. */
+
+/* CY (input/output) COMPLEX*16 array, dimension (N) */
+/* On input, the vector y. */
+/* On output, CY is overwritten with -s*x + c*y. */
+
+/* INCY (input) INTEGER */
+/* The increment between successive values of CY. INCY <> 0. */
+
+/* C (input) COMPLEX*16 */
+/* S (input) COMPLEX*16 */
+/* C and S define the matrix */
+/* [ C S ]. */
+/* [ -S C ] */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --cy;
+ --cx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* Code for unequal increments or equal increments not equal to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ix;
+ z__2.r = c__->r * cx[i__2].r - c__->i * cx[i__2].i, z__2.i = c__->r *
+ cx[i__2].i + c__->i * cx[i__2].r;
+ i__3 = iy;
+ z__3.r = s->r * cy[i__3].r - s->i * cy[i__3].i, z__3.i = s->r * cy[
+ i__3].i + s->i * cy[i__3].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__2 = iy;
+ i__3 = iy;
+ z__2.r = c__->r * cy[i__3].r - c__->i * cy[i__3].i, z__2.i = c__->r *
+ cy[i__3].i + c__->i * cy[i__3].r;
+ i__4 = ix;
+ z__3.r = s->r * cx[i__4].r - s->i * cx[i__4].i, z__3.i = s->r * cx[
+ i__4].i + s->i * cx[i__4].r;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ cy[i__2].r = z__1.r, cy[i__2].i = z__1.i;
+ i__2 = ix;
+ cx[i__2].r = ctemp.r, cx[i__2].i = ctemp.i;
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ return 0;
+
+/* Code for both increments equal to 1 */
+
+L20:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ z__2.r = c__->r * cx[i__2].r - c__->i * cx[i__2].i, z__2.i = c__->r *
+ cx[i__2].i + c__->i * cx[i__2].r;
+ i__3 = i__;
+ z__3.r = s->r * cy[i__3].r - s->i * cy[i__3].i, z__3.i = s->r * cy[
+ i__3].i + s->i * cy[i__3].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__2 = i__;
+ i__3 = i__;
+ z__2.r = c__->r * cy[i__3].r - c__->i * cy[i__3].i, z__2.i = c__->r *
+ cy[i__3].i + c__->i * cy[i__3].r;
+ i__4 = i__;
+ z__3.r = s->r * cx[i__4].r - s->i * cx[i__4].i, z__3.i = s->r * cx[
+ i__4].i + s->i * cx[i__4].r;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ cy[i__2].r = z__1.r, cy[i__2].i = z__1.i;
+ i__2 = i__;
+ cx[i__2].r = ctemp.r, cx[i__2].i = ctemp.i;
+/* L30: */
+ }
+ return 0;
+} /* zlacrt_ */
diff --git a/SRC/zladiv.c b/SRC/zladiv.c
new file mode 100644
index 0000000..d92be5a
--- /dev/null
+++ b/SRC/zladiv.c
@@ -0,0 +1,75 @@
+/* zladiv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Double Complex */ VOID zladiv_(doublecomplex * ret_val, doublecomplex *x,
+ doublecomplex *y)
+{
+ /* System generated locals */
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ doublereal zi, zr;
+ extern /* Subroutine */ int dladiv_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLADIV := X / Y, where X and Y are complex. The computation of X / Y */
+/* will not overflow on an intermediary step unless the results */
+/* overflows. */
+
+/* Arguments */
+/* ========= */
+
+/* X (input) COMPLEX*16 */
+/* Y (input) COMPLEX*16 */
+/* The complex scalars X and Y. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ d__1 = x->r;
+ d__2 = d_imag(x);
+ d__3 = y->r;
+ d__4 = d_imag(y);
+ dladiv_(&d__1, &d__2, &d__3, &d__4, &zr, &zi);
+ z__1.r = zr, z__1.i = zi;
+ ret_val->r = z__1.r, ret_val->i = z__1.i;
+
+ return ;
+
+/* End of ZLADIV */
+
+} /* zladiv_ */
diff --git a/SRC/zlaed0.c b/SRC/zlaed0.c
new file mode 100644
index 0000000..c8a76ad
--- /dev/null
+++ b/SRC/zlaed0.c
@@ -0,0 +1,366 @@
+/* zlaed0.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__9 = 9;
+static integer c__0 = 0;
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* Subroutine */ int zlaed0_(integer *qsiz, integer *n, doublereal *d__,
+ doublereal *e, doublecomplex *q, integer *ldq, doublecomplex *qstore,
+ integer *ldqs, doublereal *rwork, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double log(doublereal);
+ integer pow_ii(integer *, integer *);
+
+ /* Local variables */
+ integer i__, j, k, ll, iq, lgn, msd2, smm1, spm1, spm2;
+ doublereal temp;
+ integer curr, iperm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer indxq, iwrem, iqptr, tlvls;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zlaed7_(integer *, integer *,
+ integer *, integer *, integer *, integer *, doublereal *,
+ doublecomplex *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *, integer *, integer *, integer *,
+ doublereal *, doublecomplex *, doublereal *, integer *, integer *)
+ ;
+ integer igivcl;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zlacrm_(integer *, integer *, doublecomplex *,
+ integer *, doublereal *, integer *, doublecomplex *, integer *,
+ doublereal *);
+ integer igivnm, submat, curprb, subpbs, igivpt;
+ extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *);
+ integer curlvl, matsiz, iprmpt, smlsiz;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Using the divide and conquer method, ZLAED0 computes all eigenvalues */
+/* of a symmetric tridiagonal matrix which is one diagonal block of */
+/* those from reducing a dense or band Hermitian matrix and */
+/* corresponding eigenvectors of the dense or band matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* QSIZ (input) INTEGER */
+/* The dimension of the unitary matrix used to reduce */
+/* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. */
+
+/* N (input) INTEGER */
+/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the diagonal elements of the tridiagonal matrix. */
+/* On exit, the eigenvalues in ascending order. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* On entry, the off-diagonal elements of the tridiagonal matrix. */
+/* On exit, E has been destroyed. */
+
+/* Q (input/output) COMPLEX*16 array, dimension (LDQ,N) */
+/* On entry, Q must contain an QSIZ x N matrix whose columns */
+/* unitarily orthonormal. It is a part of the unitary matrix */
+/* that reduces the full dense Hermitian matrix to a */
+/* (reducible) symmetric tridiagonal matrix. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* IWORK (workspace) INTEGER array, */
+/* the dimension of IWORK must be at least */
+/* 6 + 6*N + 5*N*lg N */
+/* ( lg( N ) = smallest integer k */
+/* such that 2^k >= N ) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, */
+/* dimension (1 + 3*N + 2*N*lg N + 3*N**2) */
+/* ( lg( N ) = smallest integer k */
+/* such that 2^k >= N ) */
+
+/* QSTORE (workspace) COMPLEX*16 array, dimension (LDQS, N) */
+/* Used to store parts of */
+/* the eigenvector matrix when the updating matrix multiplies */
+/* take place. */
+
+/* LDQS (input) INTEGER */
+/* The leading dimension of the array QSTORE. */
+/* LDQS >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: The algorithm failed to compute an eigenvalue while */
+/* working on the submatrix lying in rows and columns */
+/* INFO/(N+1) through mod(INFO,N+1). */
+
+/* ===================================================================== */
+
+/* Warning: N could be as big as QSIZ! */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ qstore_dim1 = *ldqs;
+ qstore_offset = 1 + qstore_dim1;
+ qstore -= qstore_offset;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+/* IF( ICOMPQ .LT. 0 .OR. ICOMPQ .GT. 2 ) THEN */
+/* INFO = -1 */
+/* ELSE IF( ( ICOMPQ .EQ. 1 ) .AND. ( QSIZ .LT. MAX( 0, N ) ) ) */
+/* $ THEN */
+ if (*qsiz < max(0,*n)) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldq < max(1,*n)) {
+ *info = -6;
+ } else if (*ldqs < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLAED0", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ smlsiz = ilaenv_(&c__9, "ZLAED0", " ", &c__0, &c__0, &c__0, &c__0);
+
+/* Determine the size and placement of the submatrices, and save in */
+/* the leading elements of IWORK. */
+
+ iwork[1] = *n;
+ subpbs = 1;
+ tlvls = 0;
+L10:
+ if (iwork[subpbs] > smlsiz) {
+ for (j = subpbs; j >= 1; --j) {
+ iwork[j * 2] = (iwork[j] + 1) / 2;
+ iwork[(j << 1) - 1] = iwork[j] / 2;
+/* L20: */
+ }
+ ++tlvls;
+ subpbs <<= 1;
+ goto L10;
+ }
+ i__1 = subpbs;
+ for (j = 2; j <= i__1; ++j) {
+ iwork[j] += iwork[j - 1];
+/* L30: */
+ }
+
+/* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 */
+/* using rank-1 modifications (cuts). */
+
+ spm1 = subpbs - 1;
+ i__1 = spm1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ submat = iwork[i__] + 1;
+ smm1 = submat - 1;
+ d__[smm1] -= (d__1 = e[smm1], abs(d__1));
+ d__[submat] -= (d__1 = e[smm1], abs(d__1));
+/* L40: */
+ }
+
+ indxq = (*n << 2) + 3;
+
+/* Set up workspaces for eigenvalues only/accumulate new vectors */
+/* routine */
+
+ temp = log((doublereal) (*n)) / log(2.);
+ lgn = (integer) temp;
+ if (pow_ii(&c__2, &lgn) < *n) {
+ ++lgn;
+ }
+ if (pow_ii(&c__2, &lgn) < *n) {
+ ++lgn;
+ }
+ iprmpt = indxq + *n + 1;
+ iperm = iprmpt + *n * lgn;
+ iqptr = iperm + *n * lgn;
+ igivpt = iqptr + *n + 2;
+ igivcl = igivpt + *n * lgn;
+
+ igivnm = 1;
+ iq = igivnm + (*n << 1) * lgn;
+/* Computing 2nd power */
+ i__1 = *n;
+ iwrem = iq + i__1 * i__1 + 1;
+/* Initialize pointers */
+ i__1 = subpbs;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ iwork[iprmpt + i__] = 1;
+ iwork[igivpt + i__] = 1;
+/* L50: */
+ }
+ iwork[iqptr] = 1;
+
+/* Solve each submatrix eigenproblem at the bottom of the divide and */
+/* conquer tree. */
+
+ curr = 0;
+ i__1 = spm1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ if (i__ == 0) {
+ submat = 1;
+ matsiz = iwork[1];
+ } else {
+ submat = iwork[i__] + 1;
+ matsiz = iwork[i__ + 1] - iwork[i__];
+ }
+ ll = iq - 1 + iwork[iqptr + curr];
+ dsteqr_("I", &matsiz, &d__[submat], &e[submat], &rwork[ll], &matsiz, &
+ rwork[1], info);
+ zlacrm_(qsiz, &matsiz, &q[submat * q_dim1 + 1], ldq, &rwork[ll], &
+ matsiz, &qstore[submat * qstore_dim1 + 1], ldqs, &rwork[iwrem]
+);
+/* Computing 2nd power */
+ i__2 = matsiz;
+ iwork[iqptr + curr + 1] = iwork[iqptr + curr] + i__2 * i__2;
+ ++curr;
+ if (*info > 0) {
+ *info = submat * (*n + 1) + submat + matsiz - 1;
+ return 0;
+ }
+ k = 1;
+ i__2 = iwork[i__ + 1];
+ for (j = submat; j <= i__2; ++j) {
+ iwork[indxq + j] = k;
+ ++k;
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Successively merge eigensystems of adjacent submatrices */
+/* into eigensystem for the corresponding larger matrix. */
+
+/* while ( SUBPBS > 1 ) */
+
+ curlvl = 1;
+L80:
+ if (subpbs > 1) {
+ spm2 = subpbs - 2;
+ i__1 = spm2;
+ for (i__ = 0; i__ <= i__1; i__ += 2) {
+ if (i__ == 0) {
+ submat = 1;
+ matsiz = iwork[2];
+ msd2 = iwork[1];
+ curprb = 0;
+ } else {
+ submat = iwork[i__] + 1;
+ matsiz = iwork[i__ + 2] - iwork[i__];
+ msd2 = matsiz / 2;
+ ++curprb;
+ }
+
+/* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) */
+/* into an eigensystem of size MATSIZ. ZLAED7 handles the case */
+/* when the eigenvectors of a full or band Hermitian matrix (which */
+/* was reduced to tridiagonal form) are desired. */
+
+/* I am free to use Q as a valuable working space until Loop 150. */
+
+ zlaed7_(&matsiz, &msd2, qsiz, &tlvls, &curlvl, &curprb, &d__[
+ submat], &qstore[submat * qstore_dim1 + 1], ldqs, &e[
+ submat + msd2 - 1], &iwork[indxq + submat], &rwork[iq], &
+ iwork[iqptr], &iwork[iprmpt], &iwork[iperm], &iwork[
+ igivpt], &iwork[igivcl], &rwork[igivnm], &q[submat *
+ q_dim1 + 1], &rwork[iwrem], &iwork[subpbs + 1], info);
+ if (*info > 0) {
+ *info = submat * (*n + 1) + submat + matsiz - 1;
+ return 0;
+ }
+ iwork[i__ / 2 + 1] = iwork[i__ + 2];
+/* L90: */
+ }
+ subpbs /= 2;
+ ++curlvl;
+ goto L80;
+ }
+
+/* end while */
+
+/* Re-merge the eigenvalues/vectors which were deflated at the final */
+/* merge step. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ j = iwork[indxq + i__];
+ rwork[i__] = d__[j];
+ zcopy_(qsiz, &qstore[j * qstore_dim1 + 1], &c__1, &q[i__ * q_dim1 + 1]
+, &c__1);
+/* L100: */
+ }
+ dcopy_(n, &rwork[1], &c__1, &d__[1], &c__1);
+
+ return 0;
+
+/* End of ZLAED0 */
+
+} /* zlaed0_ */
diff --git a/SRC/zlaed7.c b/SRC/zlaed7.c
new file mode 100644
index 0000000..ec956a7
--- /dev/null
+++ b/SRC/zlaed7.c
@@ -0,0 +1,327 @@
+/* zlaed7.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zlaed7_(integer *n, integer *cutpnt, integer *qsiz,
+ integer *tlvls, integer *curlvl, integer *curpbm, doublereal *d__,
+ doublecomplex *q, integer *ldq, doublereal *rho, integer *indxq,
+ doublereal *qstore, integer *qptr, integer *prmptr, integer *perm,
+ integer *givptr, integer *givcol, doublereal *givnum, doublecomplex *
+ work, doublereal *rwork, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, i__1, i__2;
+
+ /* Builtin functions */
+ integer pow_ii(integer *, integer *);
+
+ /* Local variables */
+ integer i__, k, n1, n2, iq, iw, iz, ptr, indx, curr, indxc, indxp;
+ extern /* Subroutine */ int dlaed9_(integer *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *),
+ zlaed8_(integer *, integer *, integer *, doublecomplex *, integer
+ *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublecomplex *, integer *, doublereal *, integer *,
+ integer *, integer *, integer *, integer *, integer *,
+ doublereal *, integer *), dlaeda_(integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ integer idlmda;
+ extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *,
+ integer *, integer *, integer *), xerbla_(char *, integer *), zlacrm_(integer *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *, doublecomplex *, integer *, doublereal *
+);
+ integer coltyp;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAED7 computes the updated eigensystem of a diagonal */
+/* matrix after modification by a rank-one symmetric matrix. This */
+/* routine is used only for the eigenproblem which requires all */
+/* eigenvalues and optionally eigenvectors of a dense or banded */
+/* Hermitian matrix that has been reduced to tridiagonal form. */
+
+/* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out) */
+
+/* where Z = Q'u, u is a vector of length N with ones in the */
+/* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. */
+
+/* The eigenvectors of the original matrix are stored in Q, and the */
+/* eigenvalues are in D. The algorithm consists of three stages: */
+
+/* The first stage consists of deflating the size of the problem */
+/* when there are multiple eigenvalues or if there is a zero in */
+/* the Z vector. For each such occurence the dimension of the */
+/* secular equation problem is reduced by one. This stage is */
+/* performed by the routine DLAED2. */
+
+/* The second stage consists of calculating the updated */
+/* eigenvalues. This is done by finding the roots of the secular */
+/* equation via the routine DLAED4 (as called by SLAED3). */
+/* This routine also calculates the eigenvectors of the current */
+/* problem. */
+
+/* The final stage consists of computing the updated eigenvectors */
+/* directly using the updated eigenvalues. The eigenvectors for */
+/* the current problem are multiplied with the eigenvectors from */
+/* the overall problem. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
+
+/* CUTPNT (input) INTEGER */
+/* Contains the location of the last eigenvalue in the leading */
+/* sub-matrix. min(1,N) <= CUTPNT <= N. */
+
+/* QSIZ (input) INTEGER */
+/* The dimension of the unitary matrix used to reduce */
+/* the full matrix to tridiagonal form. QSIZ >= N. */
+
+/* TLVLS (input) INTEGER */
+/* The total number of merging levels in the overall divide and */
+/* conquer tree. */
+
+/* CURLVL (input) INTEGER */
+/* The current level in the overall merge routine, */
+/* 0 <= curlvl <= tlvls. */
+
+/* CURPBM (input) INTEGER */
+/* The current problem in the current level in the overall */
+/* merge routine (counting from upper left to lower right). */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the eigenvalues of the rank-1-perturbed matrix. */
+/* On exit, the eigenvalues of the repaired matrix. */
+
+/* Q (input/output) COMPLEX*16 array, dimension (LDQ,N) */
+/* On entry, the eigenvectors of the rank-1-perturbed matrix. */
+/* On exit, the eigenvectors of the repaired tridiagonal matrix. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* RHO (input) DOUBLE PRECISION */
+/* Contains the subdiagonal element used to create the rank-1 */
+/* modification. */
+
+/* INDXQ (output) INTEGER array, dimension (N) */
+/* This contains the permutation which will reintegrate the */
+/* subproblem just solved back into sorted order, */
+/* ie. D( INDXQ( I = 1, N ) ) will be in ascending order. */
+
+/* IWORK (workspace) INTEGER array, dimension (4*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, */
+/* dimension (3*N+2*QSIZ*N) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (QSIZ*N) */
+
+/* QSTORE (input/output) DOUBLE PRECISION array, dimension (N**2+1) */
+/* Stores eigenvectors of submatrices encountered during */
+/* divide and conquer, packed together. QPTR points to */
+/* beginning of the submatrices. */
+
+/* QPTR (input/output) INTEGER array, dimension (N+2) */
+/* List of indices pointing to beginning of submatrices stored */
+/* in QSTORE. The submatrices are numbered starting at the */
+/* bottom left of the divide and conquer tree, from left to */
+/* right and bottom to top. */
+
+/* PRMPTR (input) INTEGER array, dimension (N lg N) */
+/* Contains a list of pointers which indicate where in PERM a */
+/* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) */
+/* indicates the size of the permutation and also the size of */
+/* the full, non-deflated problem. */
+
+/* PERM (input) INTEGER array, dimension (N lg N) */
+/* Contains the permutations (from deflation and sorting) to be */
+/* applied to each eigenblock. */
+
+/* GIVPTR (input) INTEGER array, dimension (N lg N) */
+/* Contains a list of pointers which indicate where in GIVCOL a */
+/* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) */
+/* indicates the number of Givens rotations. */
+
+/* GIVCOL (input) INTEGER array, dimension (2, N lg N) */
+/* Each pair of numbers indicates a pair of columns to take place */
+/* in a Givens rotation. */
+
+/* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N) */
+/* Each number indicates the S value to be used in the */
+/* corresponding Givens rotation. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = 1, an eigenvalue did not converge */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --indxq;
+ --qstore;
+ --qptr;
+ --prmptr;
+ --perm;
+ --givptr;
+ givcol -= 3;
+ givnum -= 3;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+/* IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN */
+/* INFO = -1 */
+/* ELSE IF( N.LT.0 ) THEN */
+ if (*n < 0) {
+ *info = -1;
+ } else if (min(1,*n) > *cutpnt || *n < *cutpnt) {
+ *info = -2;
+ } else if (*qsiz < *n) {
+ *info = -3;
+ } else if (*ldq < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLAED7", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* The following values are for bookkeeping purposes only. They are */
+/* integer pointers which indicate the portion of the workspace */
+/* used by a particular array in DLAED2 and SLAED3. */
+
+ iz = 1;
+ idlmda = iz + *n;
+ iw = idlmda + *n;
+ iq = iw + *n;
+
+ indx = 1;
+ indxc = indx + *n;
+ coltyp = indxc + *n;
+ indxp = coltyp + *n;
+
+/* Form the z-vector which consists of the last row of Q_1 and the */
+/* first row of Q_2. */
+
+ ptr = pow_ii(&c__2, tlvls) + 1;
+ i__1 = *curlvl - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *tlvls - i__;
+ ptr += pow_ii(&c__2, &i__2);
+/* L10: */
+ }
+ curr = ptr + *curpbm;
+ dlaeda_(n, tlvls, curlvl, curpbm, &prmptr[1], &perm[1], &givptr[1], &
+ givcol[3], &givnum[3], &qstore[1], &qptr[1], &rwork[iz], &rwork[
+ iz + *n], info);
+
+/* When solving the final problem, we no longer need the stored data, */
+/* so we will overwrite the data from this level onto the previously */
+/* used storage space. */
+
+ if (*curlvl == *tlvls) {
+ qptr[curr] = 1;
+ prmptr[curr] = 1;
+ givptr[curr] = 1;
+ }
+
+/* Sort and Deflate eigenvalues. */
+
+ zlaed8_(&k, n, qsiz, &q[q_offset], ldq, &d__[1], rho, cutpnt, &rwork[iz],
+ &rwork[idlmda], &work[1], qsiz, &rwork[iw], &iwork[indxp], &iwork[
+ indx], &indxq[1], &perm[prmptr[curr]], &givptr[curr + 1], &givcol[
+ (givptr[curr] << 1) + 1], &givnum[(givptr[curr] << 1) + 1], info);
+ prmptr[curr + 1] = prmptr[curr] + *n;
+ givptr[curr + 1] += givptr[curr];
+
+/* Solve Secular Equation. */
+
+ if (k != 0) {
+ dlaed9_(&k, &c__1, &k, n, &d__[1], &rwork[iq], &k, rho, &rwork[idlmda]
+, &rwork[iw], &qstore[qptr[curr]], &k, info);
+ zlacrm_(qsiz, &k, &work[1], qsiz, &qstore[qptr[curr]], &k, &q[
+ q_offset], ldq, &rwork[iq]);
+/* Computing 2nd power */
+ i__1 = k;
+ qptr[curr + 1] = qptr[curr] + i__1 * i__1;
+ if (*info != 0) {
+ return 0;
+ }
+
+/* Prepare the INDXQ sorting premutation. */
+
+ n1 = k;
+ n2 = *n - k;
+ dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]);
+ } else {
+ qptr[curr + 1] = qptr[curr];
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ indxq[i__] = i__;
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of ZLAED7 */
+
+} /* zlaed7_ */
diff --git a/SRC/zlaed8.c b/SRC/zlaed8.c
new file mode 100644
index 0000000..9533c0c
--- /dev/null
+++ b/SRC/zlaed8.c
@@ -0,0 +1,436 @@
+/* zlaed8.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b3 = -1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int zlaed8_(integer *k, integer *n, integer *qsiz,
+ doublecomplex *q, integer *ldq, doublereal *d__, doublereal *rho,
+ integer *cutpnt, doublereal *z__, doublereal *dlamda, doublecomplex *
+ q2, integer *ldq2, doublereal *w, integer *indxp, integer *indx,
+ integer *indxq, integer *perm, integer *givptr, integer *givcol,
+ doublereal *givnum, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, q2_dim1, q2_offset, i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal c__;
+ integer i__, j;
+ doublereal s, t;
+ integer k2, n1, n2, jp, n1p1;
+ doublereal eps, tau, tol;
+ integer jlam, imax, jmax;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *), dcopy_(integer *, doublereal *, integer *, doublereal
+ *, integer *), zdrot_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *), zcopy_(
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *)
+ ;
+ extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *,
+ integer *, integer *, integer *), xerbla_(char *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAED8 merges the two sets of eigenvalues together into a single */
+/* sorted set. Then it tries to deflate the size of the problem. */
+/* There are two ways in which deflation can occur: when two or more */
+/* eigenvalues are close together or if there is a tiny element in the */
+/* Z vector. For each such occurrence the order of the related secular */
+/* equation problem is reduced by one. */
+
+/* Arguments */
+/* ========= */
+
+/* K (output) INTEGER */
+/* Contains the number of non-deflated eigenvalues. */
+/* This is the order of the related secular equation. */
+
+/* N (input) INTEGER */
+/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
+
+/* QSIZ (input) INTEGER */
+/* The dimension of the unitary matrix used to reduce */
+/* the dense or band matrix to tridiagonal form. */
+/* QSIZ >= N if ICOMPQ = 1. */
+
+/* Q (input/output) COMPLEX*16 array, dimension (LDQ,N) */
+/* On entry, Q contains the eigenvectors of the partially solved */
+/* system which has been previously updated in matrix */
+/* multiplies with other partially solved eigensystems. */
+/* On exit, Q contains the trailing (N-K) updated eigenvectors */
+/* (those which were deflated) in its last N-K columns. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max( 1, N ). */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, D contains the eigenvalues of the two submatrices to */
+/* be combined. On exit, D contains the trailing (N-K) updated */
+/* eigenvalues (those which were deflated) sorted into increasing */
+/* order. */
+
+/* RHO (input/output) DOUBLE PRECISION */
+/* Contains the off diagonal element associated with the rank-1 */
+/* cut which originally split the two submatrices which are now */
+/* being recombined. RHO is modified during the computation to */
+/* the value required by DLAED3. */
+
+/* CUTPNT (input) INTEGER */
+/* Contains the location of the last eigenvalue in the leading */
+/* sub-matrix. MIN(1,N) <= CUTPNT <= N. */
+
+/* Z (input) DOUBLE PRECISION array, dimension (N) */
+/* On input this vector contains the updating vector (the last */
+/* row of the first sub-eigenvector matrix and the first row of */
+/* the second sub-eigenvector matrix). The contents of Z are */
+/* destroyed during the updating process. */
+
+/* DLAMDA (output) DOUBLE PRECISION array, dimension (N) */
+/* Contains a copy of the first K eigenvalues which will be used */
+/* by DLAED3 to form the secular equation. */
+
+/* Q2 (output) COMPLEX*16 array, dimension (LDQ2,N) */
+/* If ICOMPQ = 0, Q2 is not referenced. Otherwise, */
+/* Contains a copy of the first K eigenvectors which will be used */
+/* by DLAED7 in a matrix multiply (DGEMM) to update the new */
+/* eigenvectors. */
+
+/* LDQ2 (input) INTEGER */
+/* The leading dimension of the array Q2. LDQ2 >= max( 1, N ). */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* This will hold the first k values of the final */
+/* deflation-altered z-vector and will be passed to DLAED3. */
+
+/* INDXP (workspace) INTEGER array, dimension (N) */
+/* This will contain the permutation used to place deflated */
+/* values of D at the end of the array. On output INDXP(1:K) */
+/* points to the nondeflated D-values and INDXP(K+1:N) */
+/* points to the deflated eigenvalues. */
+
+/* INDX (workspace) INTEGER array, dimension (N) */
+/* This will contain the permutation used to sort the contents of */
+/* D into ascending order. */
+
+/* INDXQ (input) INTEGER array, dimension (N) */
+/* This contains the permutation which separately sorts the two */
+/* sub-problems in D into ascending order. Note that elements in */
+/* the second half of this permutation must first have CUTPNT */
+/* added to their values in order to be accurate. */
+
+/* PERM (output) INTEGER array, dimension (N) */
+/* Contains the permutations (from deflation and sorting) to be */
+/* applied to each eigenblock. */
+
+/* GIVPTR (output) INTEGER */
+/* Contains the number of Givens rotations which took place in */
+/* this subproblem. */
+
+/* GIVCOL (output) INTEGER array, dimension (2, N) */
+/* Each pair of numbers indicates a pair of columns to take place */
+/* in a Givens rotation. */
+
+/* GIVNUM (output) DOUBLE PRECISION array, dimension (2, N) */
+/* Each number indicates the S value to be used in the */
+/* corresponding Givens rotation. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --d__;
+ --z__;
+ --dlamda;
+ q2_dim1 = *ldq2;
+ q2_offset = 1 + q2_dim1;
+ q2 -= q2_offset;
+ --w;
+ --indxp;
+ --indx;
+ --indxq;
+ --perm;
+ givcol -= 3;
+ givnum -= 3;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*n < 0) {
+ *info = -2;
+ } else if (*qsiz < *n) {
+ *info = -3;
+ } else if (*ldq < max(1,*n)) {
+ *info = -5;
+ } else if (*cutpnt < min(1,*n) || *cutpnt > *n) {
+ *info = -8;
+ } else if (*ldq2 < max(1,*n)) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLAED8", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ n1 = *cutpnt;
+ n2 = *n - n1;
+ n1p1 = n1 + 1;
+
+ if (*rho < 0.) {
+ dscal_(&n2, &c_b3, &z__[n1p1], &c__1);
+ }
+
+/* Normalize z so that norm(z) = 1 */
+
+ t = 1. / sqrt(2.);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ indx[j] = j;
+/* L10: */
+ }
+ dscal_(n, &t, &z__[1], &c__1);
+ *rho = (d__1 = *rho * 2., abs(d__1));
+
+/* Sort the eigenvalues into increasing order */
+
+ i__1 = *n;
+ for (i__ = *cutpnt + 1; i__ <= i__1; ++i__) {
+ indxq[i__] += *cutpnt;
+/* L20: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dlamda[i__] = d__[indxq[i__]];
+ w[i__] = z__[indxq[i__]];
+/* L30: */
+ }
+ i__ = 1;
+ j = *cutpnt + 1;
+ dlamrg_(&n1, &n2, &dlamda[1], &c__1, &c__1, &indx[1]);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = dlamda[indx[i__]];
+ z__[i__] = w[indx[i__]];
+/* L40: */
+ }
+
+/* Calculate the allowable deflation tolerance */
+
+ imax = idamax_(n, &z__[1], &c__1);
+ jmax = idamax_(n, &d__[1], &c__1);
+ eps = dlamch_("Epsilon");
+ tol = eps * 8. * (d__1 = d__[jmax], abs(d__1));
+
+/* If the rank-1 modifier is small enough, no more needs to be done */
+/* -- except to reorganize Q so that its columns correspond with the */
+/* elements in D. */
+
+ if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) {
+ *k = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ perm[j] = indxq[indx[j]];
+ zcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1]
+, &c__1);
+/* L50: */
+ }
+ zlacpy_("A", qsiz, n, &q2[q2_dim1 + 1], ldq2, &q[q_dim1 + 1], ldq);
+ return 0;
+ }
+
+/* If there are multiple eigenvalues then the problem deflates. Here */
+/* the number of equal eigenvalues are found. As each equal */
+/* eigenvalue is found, an elementary reflector is computed to rotate */
+/* the corresponding eigensubspace so that the corresponding */
+/* components of Z are zero in this new basis. */
+
+ *k = 0;
+ *givptr = 0;
+ k2 = *n + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) {
+
+/* Deflate due to small z component. */
+
+ --k2;
+ indxp[k2] = j;
+ if (j == *n) {
+ goto L100;
+ }
+ } else {
+ jlam = j;
+ goto L70;
+ }
+/* L60: */
+ }
+L70:
+ ++j;
+ if (j > *n) {
+ goto L90;
+ }
+ if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) {
+
+/* Deflate due to small z component. */
+
+ --k2;
+ indxp[k2] = j;
+ } else {
+
+/* Check if eigenvalues are close enough to allow deflation. */
+
+ s = z__[jlam];
+ c__ = z__[j];
+
+/* Find sqrt(a**2+b**2) without overflow or */
+/* destructive underflow. */
+
+ tau = dlapy2_(&c__, &s);
+ t = d__[j] - d__[jlam];
+ c__ /= tau;
+ s = -s / tau;
+ if ((d__1 = t * c__ * s, abs(d__1)) <= tol) {
+
+/* Deflation is possible. */
+
+ z__[j] = tau;
+ z__[jlam] = 0.;
+
+/* Record the appropriate Givens rotation */
+
+ ++(*givptr);
+ givcol[(*givptr << 1) + 1] = indxq[indx[jlam]];
+ givcol[(*givptr << 1) + 2] = indxq[indx[j]];
+ givnum[(*givptr << 1) + 1] = c__;
+ givnum[(*givptr << 1) + 2] = s;
+ zdrot_(qsiz, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, &q[indxq[
+ indx[j]] * q_dim1 + 1], &c__1, &c__, &s);
+ t = d__[jlam] * c__ * c__ + d__[j] * s * s;
+ d__[j] = d__[jlam] * s * s + d__[j] * c__ * c__;
+ d__[jlam] = t;
+ --k2;
+ i__ = 1;
+L80:
+ if (k2 + i__ <= *n) {
+ if (d__[jlam] < d__[indxp[k2 + i__]]) {
+ indxp[k2 + i__ - 1] = indxp[k2 + i__];
+ indxp[k2 + i__] = jlam;
+ ++i__;
+ goto L80;
+ } else {
+ indxp[k2 + i__ - 1] = jlam;
+ }
+ } else {
+ indxp[k2 + i__ - 1] = jlam;
+ }
+ jlam = j;
+ } else {
+ ++(*k);
+ w[*k] = z__[jlam];
+ dlamda[*k] = d__[jlam];
+ indxp[*k] = jlam;
+ jlam = j;
+ }
+ }
+ goto L70;
+L90:
+
+/* Record the last eigenvalue. */
+
+ ++(*k);
+ w[*k] = z__[jlam];
+ dlamda[*k] = d__[jlam];
+ indxp[*k] = jlam;
+
+L100:
+
+/* Sort the eigenvalues and corresponding eigenvectors into DLAMDA */
+/* and Q2 respectively. The eigenvalues/vectors which were not */
+/* deflated go into the first K slots of DLAMDA and Q2 respectively, */
+/* while those which were deflated go into the last N - K slots. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ jp = indxp[j];
+ dlamda[j] = d__[jp];
+ perm[j] = indxq[indx[jp]];
+ zcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1], &
+ c__1);
+/* L110: */
+ }
+
+/* The deflated eigenvalues and their corresponding vectors go back */
+/* into the last N - K slots of D and Q respectively. */
+
+ if (*k < *n) {
+ i__1 = *n - *k;
+ dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1);
+ i__1 = *n - *k;
+ zlacpy_("A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(*k +
+ 1) * q_dim1 + 1], ldq);
+ }
+
+ return 0;
+
+/* End of ZLAED8 */
+
+} /* zlaed8_ */
diff --git a/SRC/zlaein.c b/SRC/zlaein.c
new file mode 100644
index 0000000..7b03e27
--- /dev/null
+++ b/SRC/zlaein.c
@@ -0,0 +1,397 @@
+/* zlaein.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zlaein_(logical *rightv, logical *noinit, integer *n,
+ doublecomplex *h__, integer *ldh, doublecomplex *w, doublecomplex *v,
+ doublecomplex *b, integer *ldb, doublereal *rwork, doublereal *eps3,
+ doublereal *smlnum, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublecomplex x, ei, ej;
+ integer its, ierr;
+ doublecomplex temp;
+ doublereal scale;
+ char trans[1];
+ doublereal rtemp, rootn, vnorm;
+ extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
+ doublecomplex *);
+ char normin[1];
+ extern doublereal dzasum_(integer *, doublecomplex *, integer *);
+ doublereal nrmsml;
+ extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *, doublereal *, integer *);
+ doublereal growto;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAEIN uses inverse iteration to find a right or left eigenvector */
+/* corresponding to the eigenvalue W of a complex upper Hessenberg */
+/* matrix H. */
+
+/* Arguments */
+/* ========= */
+
+/* RIGHTV (input) LOGICAL */
+/* = .TRUE. : compute right eigenvector; */
+/* = .FALSE.: compute left eigenvector. */
+
+/* NOINIT (input) LOGICAL */
+/* = .TRUE. : no initial vector supplied in V */
+/* = .FALSE.: initial vector supplied in V. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N >= 0. */
+
+/* H (input) COMPLEX*16 array, dimension (LDH,N) */
+/* The upper Hessenberg matrix H. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH >= max(1,N). */
+
+/* W (input) COMPLEX*16 */
+/* The eigenvalue of H whose corresponding right or left */
+/* eigenvector is to be computed. */
+
+/* V (input/output) COMPLEX*16 array, dimension (N) */
+/* On entry, if NOINIT = .FALSE., V must contain a starting */
+/* vector for inverse iteration; otherwise V need not be set. */
+/* On exit, V contains the computed eigenvector, normalized so */
+/* that the component of largest magnitude has magnitude 1; here */
+/* the magnitude of a complex number (x,y) is taken to be */
+/* |x| + |y|. */
+
+/* B (workspace) COMPLEX*16 array, dimension (LDB,N) */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* EPS3 (input) DOUBLE PRECISION */
+/* A small machine-dependent value which is used to perturb */
+/* close eigenvalues, and to replace zero pivots. */
+
+/* SMLNUM (input) DOUBLE PRECISION */
+/* A machine-dependent value close to the underflow threshold. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* = 1: inverse iteration did not converge; V is set to the */
+/* last iterate. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --v;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+
+/* GROWTO is the threshold used in the acceptance test for an */
+/* eigenvector. */
+
+ rootn = sqrt((doublereal) (*n));
+ growto = .1 / rootn;
+/* Computing MAX */
+ d__1 = 1., d__2 = *eps3 * rootn;
+ nrmsml = max(d__1,d__2) * *smlnum;
+
+/* Form B = H - W*I (except that the subdiagonal elements are not */
+/* stored). */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * h_dim1;
+ b[i__3].r = h__[i__4].r, b[i__3].i = h__[i__4].i;
+/* L10: */
+ }
+ i__2 = j + j * b_dim1;
+ i__3 = j + j * h_dim1;
+ z__1.r = h__[i__3].r - w->r, z__1.i = h__[i__3].i - w->i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L20: */
+ }
+
+ if (*noinit) {
+
+/* Initialize V. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ v[i__2].r = *eps3, v[i__2].i = 0.;
+/* L30: */
+ }
+ } else {
+
+/* Scale supplied initial vector. */
+
+ vnorm = dznrm2_(n, &v[1], &c__1);
+ d__1 = *eps3 * rootn / max(vnorm,nrmsml);
+ zdscal_(n, &d__1, &v[1], &c__1);
+ }
+
+ if (*rightv) {
+
+/* LU decomposition with partial pivoting of B, replacing zero */
+/* pivots by EPS3. */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + 1 + i__ * h_dim1;
+ ei.r = h__[i__2].r, ei.i = h__[i__2].i;
+ i__2 = i__ + i__ * b_dim1;
+ if ((d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[i__ + i__ *
+ b_dim1]), abs(d__2)) < (d__3 = ei.r, abs(d__3)) + (d__4 =
+ d_imag(&ei), abs(d__4))) {
+
+/* Interchange rows and eliminate. */
+
+ zladiv_(&z__1, &b[i__ + i__ * b_dim1], &ei);
+ x.r = z__1.r, x.i = z__1.i;
+ i__2 = i__ + i__ * b_dim1;
+ b[i__2].r = ei.r, b[i__2].i = ei.i;
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + 1 + j * b_dim1;
+ temp.r = b[i__3].r, temp.i = b[i__3].i;
+ i__3 = i__ + 1 + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ z__2.r = x.r * temp.r - x.i * temp.i, z__2.i = x.r *
+ temp.i + x.i * temp.r;
+ z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4].i - z__2.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = temp.r, b[i__3].i = temp.i;
+/* L40: */
+ }
+ } else {
+
+/* Eliminate without interchange. */
+
+ i__2 = i__ + i__ * b_dim1;
+ if (b[i__2].r == 0. && b[i__2].i == 0.) {
+ i__3 = i__ + i__ * b_dim1;
+ b[i__3].r = *eps3, b[i__3].i = 0.;
+ }
+ zladiv_(&z__1, &ei, &b[i__ + i__ * b_dim1]);
+ x.r = z__1.r, x.i = z__1.i;
+ if (x.r != 0. || x.i != 0.) {
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + 1 + j * b_dim1;
+ i__4 = i__ + 1 + j * b_dim1;
+ i__5 = i__ + j * b_dim1;
+ z__2.r = x.r * b[i__5].r - x.i * b[i__5].i, z__2.i =
+ x.r * b[i__5].i + x.i * b[i__5].r;
+ z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4].i -
+ z__2.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L50: */
+ }
+ }
+ }
+/* L60: */
+ }
+ i__1 = *n + *n * b_dim1;
+ if (b[i__1].r == 0. && b[i__1].i == 0.) {
+ i__2 = *n + *n * b_dim1;
+ b[i__2].r = *eps3, b[i__2].i = 0.;
+ }
+
+ *(unsigned char *)trans = 'N';
+
+ } else {
+
+/* UL decomposition with partial pivoting of B, replacing zero */
+/* pivots by EPS3. */
+
+ for (j = *n; j >= 2; --j) {
+ i__1 = j + (j - 1) * h_dim1;
+ ej.r = h__[i__1].r, ej.i = h__[i__1].i;
+ i__1 = j + j * b_dim1;
+ if ((d__1 = b[i__1].r, abs(d__1)) + (d__2 = d_imag(&b[j + j *
+ b_dim1]), abs(d__2)) < (d__3 = ej.r, abs(d__3)) + (d__4 =
+ d_imag(&ej), abs(d__4))) {
+
+/* Interchange columns and eliminate. */
+
+ zladiv_(&z__1, &b[j + j * b_dim1], &ej);
+ x.r = z__1.r, x.i = z__1.i;
+ i__1 = j + j * b_dim1;
+ b[i__1].r = ej.r, b[i__1].i = ej.i;
+ i__1 = j - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + (j - 1) * b_dim1;
+ temp.r = b[i__2].r, temp.i = b[i__2].i;
+ i__2 = i__ + (j - 1) * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ z__2.r = x.r * temp.r - x.i * temp.i, z__2.i = x.r *
+ temp.i + x.i * temp.r;
+ z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i - z__2.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = i__ + j * b_dim1;
+ b[i__2].r = temp.r, b[i__2].i = temp.i;
+/* L70: */
+ }
+ } else {
+
+/* Eliminate without interchange. */
+
+ i__1 = j + j * b_dim1;
+ if (b[i__1].r == 0. && b[i__1].i == 0.) {
+ i__2 = j + j * b_dim1;
+ b[i__2].r = *eps3, b[i__2].i = 0.;
+ }
+ zladiv_(&z__1, &ej, &b[j + j * b_dim1]);
+ x.r = z__1.r, x.i = z__1.i;
+ if (x.r != 0. || x.i != 0.) {
+ i__1 = j - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + (j - 1) * b_dim1;
+ i__3 = i__ + (j - 1) * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ z__2.r = x.r * b[i__4].r - x.i * b[i__4].i, z__2.i =
+ x.r * b[i__4].i + x.i * b[i__4].r;
+ z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i -
+ z__2.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L80: */
+ }
+ }
+ }
+/* L90: */
+ }
+ i__1 = b_dim1 + 1;
+ if (b[i__1].r == 0. && b[i__1].i == 0.) {
+ i__2 = b_dim1 + 1;
+ b[i__2].r = *eps3, b[i__2].i = 0.;
+ }
+
+ *(unsigned char *)trans = 'C';
+
+ }
+
+ *(unsigned char *)normin = 'N';
+ i__1 = *n;
+ for (its = 1; its <= i__1; ++its) {
+
+/* Solve U*x = scale*v for a right eigenvector */
+/* or U'*x = scale*v for a left eigenvector, */
+/* overwriting x on v. */
+
+ zlatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, &v[1]
+, &scale, &rwork[1], &ierr);
+ *(unsigned char *)normin = 'Y';
+
+/* Test for sufficient growth in the norm of v. */
+
+ vnorm = dzasum_(n, &v[1], &c__1);
+ if (vnorm >= growto * scale) {
+ goto L120;
+ }
+
+/* Choose new orthogonal starting vector and try again. */
+
+ rtemp = *eps3 / (rootn + 1.);
+ v[1].r = *eps3, v[1].i = 0.;
+ i__2 = *n;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ v[i__3].r = rtemp, v[i__3].i = 0.;
+/* L100: */
+ }
+ i__2 = *n - its + 1;
+ i__3 = *n - its + 1;
+ d__1 = *eps3 * rootn;
+ z__1.r = v[i__3].r - d__1, z__1.i = v[i__3].i;
+ v[i__2].r = z__1.r, v[i__2].i = z__1.i;
+/* L110: */
+ }
+
+/* Failure to find eigenvector in N iterations. */
+
+ *info = 1;
+
+L120:
+
+/* Normalize eigenvector. */
+
+ i__ = izamax_(n, &v[1], &c__1);
+ i__1 = i__;
+ d__3 = 1. / ((d__1 = v[i__1].r, abs(d__1)) + (d__2 = d_imag(&v[i__]), abs(
+ d__2)));
+ zdscal_(n, &d__3, &v[1], &c__1);
+
+ return 0;
+
+/* End of ZLAEIN */
+
+} /* zlaein_ */
diff --git a/SRC/zlaesy.c b/SRC/zlaesy.c
new file mode 100644
index 0000000..a377469
--- /dev/null
+++ b/SRC/zlaesy.c
@@ -0,0 +1,208 @@
+/* zlaesy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__2 = 2;
+
+/* Subroutine */ int zlaesy_(doublecomplex *a, doublecomplex *b,
+ doublecomplex *c__, doublecomplex *rt1, doublecomplex *rt2,
+ doublecomplex *evscal, doublecomplex *cs1, doublecomplex *sn1)
+{
+ /* System generated locals */
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+ void pow_zi(doublecomplex *, doublecomplex *, integer *), z_sqrt(
+ doublecomplex *, doublecomplex *), z_div(doublecomplex *,
+ doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ doublecomplex s, t;
+ doublereal z__;
+ doublecomplex tmp;
+ doublereal babs, tabs, evnorm;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAESY computes the eigendecomposition of a 2-by-2 symmetric matrix */
+/* ( ( A, B );( B, C ) ) */
+/* provided the norm of the matrix of eigenvectors is larger than */
+/* some threshold value. */
+
+/* RT1 is the eigenvalue of larger absolute value, and RT2 of */
+/* smaller absolute value. If the eigenvectors are computed, then */
+/* on return ( CS1, SN1 ) is the unit eigenvector for RT1, hence */
+
+/* [ CS1 SN1 ] . [ A B ] . [ CS1 -SN1 ] = [ RT1 0 ] */
+/* [ -SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ] */
+
+/* Arguments */
+/* ========= */
+
+/* A (input) COMPLEX*16 */
+/* The ( 1, 1 ) element of input matrix. */
+
+/* B (input) COMPLEX*16 */
+/* The ( 1, 2 ) element of input matrix. The ( 2, 1 ) element */
+/* is also given by B, since the 2-by-2 matrix is symmetric. */
+
+/* C (input) COMPLEX*16 */
+/* The ( 2, 2 ) element of input matrix. */
+
+/* RT1 (output) COMPLEX*16 */
+/* The eigenvalue of larger modulus. */
+
+/* RT2 (output) COMPLEX*16 */
+/* The eigenvalue of smaller modulus. */
+
+/* EVSCAL (output) COMPLEX*16 */
+/* The complex value by which the eigenvector matrix was scaled */
+/* to make it orthonormal. If EVSCAL is zero, the eigenvectors */
+/* were not computed. This means one of two things: the 2-by-2 */
+/* matrix could not be diagonalized, or the norm of the matrix */
+/* of eigenvectors before scaling was larger than the threshold */
+/* value THRESH (set below). */
+
+/* CS1 (output) COMPLEX*16 */
+/* SN1 (output) COMPLEX*16 */
+/* If EVSCAL .NE. 0, ( CS1, SN1 ) is the unit right eigenvector */
+/* for RT1. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+
+/* Special case: The matrix is actually diagonal. */
+/* To avoid divide by zero later, we treat this case separately. */
+
+ if (z_abs(b) == 0.) {
+ rt1->r = a->r, rt1->i = a->i;
+ rt2->r = c__->r, rt2->i = c__->i;
+ if (z_abs(rt1) < z_abs(rt2)) {
+ tmp.r = rt1->r, tmp.i = rt1->i;
+ rt1->r = rt2->r, rt1->i = rt2->i;
+ rt2->r = tmp.r, rt2->i = tmp.i;
+ cs1->r = 0., cs1->i = 0.;
+ sn1->r = 1., sn1->i = 0.;
+ } else {
+ cs1->r = 1., cs1->i = 0.;
+ sn1->r = 0., sn1->i = 0.;
+ }
+ } else {
+
+/* Compute the eigenvalues and eigenvectors. */
+/* The characteristic equation is */
+/* lambda **2 - (A+C) lambda + (A*C - B*B) */
+/* and we solve it using the quadratic formula. */
+
+ z__2.r = a->r + c__->r, z__2.i = a->i + c__->i;
+ z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
+ s.r = z__1.r, s.i = z__1.i;
+ z__2.r = a->r - c__->r, z__2.i = a->i - c__->i;
+ z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
+ t.r = z__1.r, t.i = z__1.i;
+
+/* Take the square root carefully to avoid over/under flow. */
+
+ babs = z_abs(b);
+ tabs = z_abs(&t);
+ z__ = max(babs,tabs);
+ if (z__ > 0.) {
+ z__5.r = t.r / z__, z__5.i = t.i / z__;
+ pow_zi(&z__4, &z__5, &c__2);
+ z__7.r = b->r / z__, z__7.i = b->i / z__;
+ pow_zi(&z__6, &z__7, &c__2);
+ z__3.r = z__4.r + z__6.r, z__3.i = z__4.i + z__6.i;
+ z_sqrt(&z__2, &z__3);
+ z__1.r = z__ * z__2.r, z__1.i = z__ * z__2.i;
+ t.r = z__1.r, t.i = z__1.i;
+ }
+
+/* Compute the two eigenvalues. RT1 and RT2 are exchanged */
+/* if necessary so that RT1 will have the greater magnitude. */
+
+ z__1.r = s.r + t.r, z__1.i = s.i + t.i;
+ rt1->r = z__1.r, rt1->i = z__1.i;
+ z__1.r = s.r - t.r, z__1.i = s.i - t.i;
+ rt2->r = z__1.r, rt2->i = z__1.i;
+ if (z_abs(rt1) < z_abs(rt2)) {
+ tmp.r = rt1->r, tmp.i = rt1->i;
+ rt1->r = rt2->r, rt1->i = rt2->i;
+ rt2->r = tmp.r, rt2->i = tmp.i;
+ }
+
+/* Choose CS1 = 1 and SN1 to satisfy the first equation, then */
+/* scale the components of this eigenvector so that the matrix */
+/* of eigenvectors X satisfies X * X' = I . (No scaling is */
+/* done if the norm of the eigenvalue matrix is less than THRESH.) */
+
+ z__2.r = rt1->r - a->r, z__2.i = rt1->i - a->i;
+ z_div(&z__1, &z__2, b);
+ sn1->r = z__1.r, sn1->i = z__1.i;
+ tabs = z_abs(sn1);
+ if (tabs > 1.) {
+/* Computing 2nd power */
+ d__2 = 1. / tabs;
+ d__1 = d__2 * d__2;
+ z__5.r = sn1->r / tabs, z__5.i = sn1->i / tabs;
+ pow_zi(&z__4, &z__5, &c__2);
+ z__3.r = d__1 + z__4.r, z__3.i = z__4.i;
+ z_sqrt(&z__2, &z__3);
+ z__1.r = tabs * z__2.r, z__1.i = tabs * z__2.i;
+ t.r = z__1.r, t.i = z__1.i;
+ } else {
+ z__3.r = sn1->r * sn1->r - sn1->i * sn1->i, z__3.i = sn1->r *
+ sn1->i + sn1->i * sn1->r;
+ z__2.r = z__3.r + 1., z__2.i = z__3.i + 0.;
+ z_sqrt(&z__1, &z__2);
+ t.r = z__1.r, t.i = z__1.i;
+ }
+ evnorm = z_abs(&t);
+ if (evnorm >= .1) {
+ z_div(&z__1, &c_b1, &t);
+ evscal->r = z__1.r, evscal->i = z__1.i;
+ cs1->r = evscal->r, cs1->i = evscal->i;
+ z__1.r = sn1->r * evscal->r - sn1->i * evscal->i, z__1.i = sn1->r
+ * evscal->i + sn1->i * evscal->r;
+ sn1->r = z__1.r, sn1->i = z__1.i;
+ } else {
+ evscal->r = 0., evscal->i = 0.;
+ }
+ }
+ return 0;
+
+/* End of ZLAESY */
+
+} /* zlaesy_ */
diff --git a/SRC/zlaev2.c b/SRC/zlaev2.c
new file mode 100644
index 0000000..4a66392
--- /dev/null
+++ b/SRC/zlaev2.c
@@ -0,0 +1,125 @@
+/* zlaev2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlaev2_(doublecomplex *a, doublecomplex *b,
+ doublecomplex *c__, doublereal *rt1, doublereal *rt2, doublereal *cs1,
+ doublecomplex *sn1)
+{
+ /* System generated locals */
+ doublereal d__1, d__2, d__3;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ doublereal t;
+ doublecomplex w;
+ extern /* Subroutine */ int dlaev2_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAEV2 computes the eigendecomposition of a 2-by-2 Hermitian matrix */
+/* [ A B ] */
+/* [ CONJG(B) C ]. */
+/* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the */
+/* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right */
+/* eigenvector for RT1, giving the decomposition */
+
+/* [ CS1 CONJG(SN1) ] [ A B ] [ CS1 -CONJG(SN1) ] = [ RT1 0 ] */
+/* [-SN1 CS1 ] [ CONJG(B) C ] [ SN1 CS1 ] [ 0 RT2 ]. */
+
+/* Arguments */
+/* ========= */
+
+/* A (input) COMPLEX*16 */
+/* The (1,1) element of the 2-by-2 matrix. */
+
+/* B (input) COMPLEX*16 */
+/* The (1,2) element and the conjugate of the (2,1) element of */
+/* the 2-by-2 matrix. */
+
+/* C (input) COMPLEX*16 */
+/* The (2,2) element of the 2-by-2 matrix. */
+
+/* RT1 (output) DOUBLE PRECISION */
+/* The eigenvalue of larger absolute value. */
+
+/* RT2 (output) DOUBLE PRECISION */
+/* The eigenvalue of smaller absolute value. */
+
+/* CS1 (output) DOUBLE PRECISION */
+/* SN1 (output) COMPLEX*16 */
+/* The vector (CS1, SN1) is a unit right eigenvector for RT1. */
+
+/* Further Details */
+/* =============== */
+
+/* RT1 is accurate to a few ulps barring over/underflow. */
+
+/* RT2 may be inaccurate if there is massive cancellation in the */
+/* determinant A*C-B*B; higher precision or correctly rounded or */
+/* correctly truncated arithmetic would be needed to compute RT2 */
+/* accurately in all cases. */
+
+/* CS1 and SN1 are accurate to a few ulps barring over/underflow. */
+
+/* Overflow is possible only if RT1 is within a factor of 5 of overflow. */
+/* Underflow is harmless if the input data is 0 or exceeds */
+/* underflow_threshold / macheps. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (z_abs(b) == 0.) {
+ w.r = 1., w.i = 0.;
+ } else {
+ d_cnjg(&z__2, b);
+ d__1 = z_abs(b);
+ z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
+ w.r = z__1.r, w.i = z__1.i;
+ }
+ d__1 = a->r;
+ d__2 = z_abs(b);
+ d__3 = c__->r;
+ dlaev2_(&d__1, &d__2, &d__3, rt1, rt2, cs1, &t);
+ z__1.r = t * w.r, z__1.i = t * w.i;
+ sn1->r = z__1.r, sn1->i = z__1.i;
+ return 0;
+
+/* End of ZLAEV2 */
+
+} /* zlaev2_ */
diff --git a/SRC/zlag2c.c b/SRC/zlag2c.c
new file mode 100644
index 0000000..6f408f9
--- /dev/null
+++ b/SRC/zlag2c.c
@@ -0,0 +1,124 @@
+/* zlag2c.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlag2c_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, complex *sa, integer *ldsa, integer *info)
+{
+ /* System generated locals */
+ integer sa_dim1, sa_offset, a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal rmax;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK PROTOTYPE auxiliary routine (version 3.1.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* August 2007 */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAG2C converts a COMPLEX*16 matrix, SA, to a COMPLEX matrix, A. */
+
+/* RMAX is the overflow for the SINGLE PRECISION arithmetic */
+/* ZLAG2C checks that all the entries of A are between -RMAX and */
+/* RMAX. If not the convertion is aborted and a flag is raised. */
+
+/* This is an auxiliary routine so there is no argument checking. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of lines of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N coefficient matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* SA (output) COMPLEX array, dimension (LDSA,N) */
+/* On exit, if INFO=0, the M-by-N coefficient matrix SA; if */
+/* INFO>0, the content of SA is unspecified. */
+
+/* LDSA (input) INTEGER */
+/* The leading dimension of the array SA. LDSA >= max(1,M). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* = 1: an entry of the matrix A is greater than the SINGLE */
+/* PRECISION overflow threshold, in this case, the content */
+/* of SA in exit is unspecified. */
+
+/* ========= */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ sa_dim1 = *ldsa;
+ sa_offset = 1 + sa_dim1;
+ sa -= sa_offset;
+
+ /* Function Body */
+ rmax = slamch_("O");
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ if (a[i__3].r < -rmax || a[i__4].r > rmax || d_imag(&a[i__ + j *
+ a_dim1]) < -rmax || d_imag(&a[i__ + j * a_dim1]) > rmax) {
+ *info = 1;
+ goto L30;
+ }
+ i__3 = i__ + j * sa_dim1;
+ i__4 = i__ + j * a_dim1;
+ sa[i__3].r = a[i__4].r, sa[i__3].i = a[i__4].i;
+/* L10: */
+ }
+/* L20: */
+ }
+ *info = 0;
+L30:
+ return 0;
+
+/* End of ZLAG2C */
+
+} /* zlag2c_ */
diff --git a/SRC/zlags2.c b/SRC/zlags2.c
new file mode 100644
index 0000000..89ac38f
--- /dev/null
+++ b/SRC/zlags2.c
@@ -0,0 +1,468 @@
+/* zlags2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlags2_(logical *upper, doublereal *a1, doublecomplex *
+ a2, doublereal *a3, doublereal *b1, doublecomplex *b2, doublereal *b3,
+ doublereal *csu, doublecomplex *snu, doublereal *csv, doublecomplex *
+ snv, doublereal *csq, doublecomplex *snq)
+{
+ /* System generated locals */
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8;
+ doublecomplex z__1, z__2, z__3, z__4, z__5;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *), d_imag(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ doublereal a;
+ doublecomplex b, c__;
+ doublereal d__;
+ doublecomplex r__, d1;
+ doublereal s1, s2, fb, fc;
+ doublecomplex ua11, ua12, ua21, ua22, vb11, vb12, vb21, vb22;
+ doublereal csl, csr, snl, snr, aua11, aua12, aua21, aua22, avb12, avb11,
+ avb21, avb22, ua11r, ua22r, vb11r, vb22r;
+ extern /* Subroutine */ int dlasv2_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *), zlartg_(doublecomplex *
+, doublecomplex *, doublereal *, doublecomplex *, doublecomplex *)
+ ;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAGS2 computes 2-by-2 unitary matrices U, V and Q, such */
+/* that if ( UPPER ) then */
+
+/* U'*A*Q = U'*( A1 A2 )*Q = ( x 0 ) */
+/* ( 0 A3 ) ( x x ) */
+/* and */
+/* V'*B*Q = V'*( B1 B2 )*Q = ( x 0 ) */
+/* ( 0 B3 ) ( x x ) */
+
+/* or if ( .NOT.UPPER ) then */
+
+/* U'*A*Q = U'*( A1 0 )*Q = ( x x ) */
+/* ( A2 A3 ) ( 0 x ) */
+/* and */
+/* V'*B*Q = V'*( B1 0 )*Q = ( x x ) */
+/* ( B2 B3 ) ( 0 x ) */
+/* where */
+
+/* U = ( CSU SNU ), V = ( CSV SNV ), */
+/* ( -CONJG(SNU) CSU ) ( -CONJG(SNV) CSV ) */
+
+/* Q = ( CSQ SNQ ) */
+/* ( -CONJG(SNQ) CSQ ) */
+
+/* Z' denotes the conjugate transpose of Z. */
+
+/* The rows of the transformed A and B are parallel. Moreover, if the */
+/* input 2-by-2 matrix A is not zero, then the transformed (1,1) entry */
+/* of A is not zero. If the input matrices A and B are both not zero, */
+/* then the transformed (2,2) element of B is not zero, except when the */
+/* first rows of input A and B are parallel and the second rows are */
+/* zero. */
+
+/* Arguments */
+/* ========= */
+
+/* UPPER (input) LOGICAL */
+/* = .TRUE.: the input matrices A and B are upper triangular. */
+/* = .FALSE.: the input matrices A and B are lower triangular. */
+
+/* A1 (input) DOUBLE PRECISION */
+/* A2 (input) COMPLEX*16 */
+/* A3 (input) DOUBLE PRECISION */
+/* On entry, A1, A2 and A3 are elements of the input 2-by-2 */
+/* upper (lower) triangular matrix A. */
+
+/* B1 (input) DOUBLE PRECISION */
+/* B2 (input) COMPLEX*16 */
+/* B3 (input) DOUBLE PRECISION */
+/* On entry, B1, B2 and B3 are elements of the input 2-by-2 */
+/* upper (lower) triangular matrix B. */
+
+/* CSU (output) DOUBLE PRECISION */
+/* SNU (output) COMPLEX*16 */
+/* The desired unitary matrix U. */
+
+/* CSV (output) DOUBLE PRECISION */
+/* SNV (output) COMPLEX*16 */
+/* The desired unitary matrix V. */
+
+/* CSQ (output) DOUBLE PRECISION */
+/* SNQ (output) COMPLEX*16 */
+/* The desired unitary matrix Q. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (*upper) {
+
+/* Input matrices A and B are upper triangular matrices */
+
+/* Form matrix C = A*adj(B) = ( a b ) */
+/* ( 0 d ) */
+
+ a = *a1 * *b3;
+ d__ = *a3 * *b1;
+ z__2.r = *b1 * a2->r, z__2.i = *b1 * a2->i;
+ z__3.r = *a1 * b2->r, z__3.i = *a1 * b2->i;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ b.r = z__1.r, b.i = z__1.i;
+ fb = z_abs(&b);
+
+/* Transform complex 2-by-2 matrix C to real matrix by unitary */
+/* diagonal matrix diag(1,D1). */
+
+ d1.r = 1., d1.i = 0.;
+ if (fb != 0.) {
+ z__1.r = b.r / fb, z__1.i = b.i / fb;
+ d1.r = z__1.r, d1.i = z__1.i;
+ }
+
+/* The SVD of real 2 by 2 triangular C */
+
+/* ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 ) */
+/* ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T ) */
+
+ dlasv2_(&a, &fb, &d__, &s1, &s2, &snr, &csr, &snl, &csl);
+
+ if (abs(csl) >= abs(snl) || abs(csr) >= abs(snr)) {
+
+/* Compute the (1,1) and (1,2) elements of U'*A and V'*B, */
+/* and (1,2) element of |U|'*|A| and |V|'*|B|. */
+
+ ua11r = csl * *a1;
+ z__2.r = csl * a2->r, z__2.i = csl * a2->i;
+ z__4.r = snl * d1.r, z__4.i = snl * d1.i;
+ z__3.r = *a3 * z__4.r, z__3.i = *a3 * z__4.i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ ua12.r = z__1.r, ua12.i = z__1.i;
+
+ vb11r = csr * *b1;
+ z__2.r = csr * b2->r, z__2.i = csr * b2->i;
+ z__4.r = snr * d1.r, z__4.i = snr * d1.i;
+ z__3.r = *b3 * z__4.r, z__3.i = *b3 * z__4.i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ vb12.r = z__1.r, vb12.i = z__1.i;
+
+ aua12 = abs(csl) * ((d__1 = a2->r, abs(d__1)) + (d__2 = d_imag(a2)
+ , abs(d__2))) + abs(snl) * abs(*a3);
+ avb12 = abs(csr) * ((d__1 = b2->r, abs(d__1)) + (d__2 = d_imag(b2)
+ , abs(d__2))) + abs(snr) * abs(*b3);
+
+/* zero (1,2) elements of U'*A and V'*B */
+
+ if (abs(ua11r) + ((d__1 = ua12.r, abs(d__1)) + (d__2 = d_imag(&
+ ua12), abs(d__2))) == 0.) {
+ z__2.r = vb11r, z__2.i = 0.;
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ d_cnjg(&z__3, &vb12);
+ zlartg_(&z__1, &z__3, csq, snq, &r__);
+ } else if (abs(vb11r) + ((d__1 = vb12.r, abs(d__1)) + (d__2 =
+ d_imag(&vb12), abs(d__2))) == 0.) {
+ z__2.r = ua11r, z__2.i = 0.;
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ d_cnjg(&z__3, &ua12);
+ zlartg_(&z__1, &z__3, csq, snq, &r__);
+ } else if (aua12 / (abs(ua11r) + ((d__1 = ua12.r, abs(d__1)) + (
+ d__2 = d_imag(&ua12), abs(d__2)))) <= avb12 / (abs(vb11r)
+ + ((d__3 = vb12.r, abs(d__3)) + (d__4 = d_imag(&vb12),
+ abs(d__4))))) {
+ z__2.r = ua11r, z__2.i = 0.;
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ d_cnjg(&z__3, &ua12);
+ zlartg_(&z__1, &z__3, csq, snq, &r__);
+ } else {
+ z__2.r = vb11r, z__2.i = 0.;
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ d_cnjg(&z__3, &vb12);
+ zlartg_(&z__1, &z__3, csq, snq, &r__);
+ }
+
+ *csu = csl;
+ z__2.r = -d1.r, z__2.i = -d1.i;
+ z__1.r = snl * z__2.r, z__1.i = snl * z__2.i;
+ snu->r = z__1.r, snu->i = z__1.i;
+ *csv = csr;
+ z__2.r = -d1.r, z__2.i = -d1.i;
+ z__1.r = snr * z__2.r, z__1.i = snr * z__2.i;
+ snv->r = z__1.r, snv->i = z__1.i;
+
+ } else {
+
+/* Compute the (2,1) and (2,2) elements of U'*A and V'*B, */
+/* and (2,2) element of |U|'*|A| and |V|'*|B|. */
+
+ d_cnjg(&z__4, &d1);
+ z__3.r = -z__4.r, z__3.i = -z__4.i;
+ z__2.r = snl * z__3.r, z__2.i = snl * z__3.i;
+ z__1.r = *a1 * z__2.r, z__1.i = *a1 * z__2.i;
+ ua21.r = z__1.r, ua21.i = z__1.i;
+ d_cnjg(&z__5, &d1);
+ z__4.r = -z__5.r, z__4.i = -z__5.i;
+ z__3.r = snl * z__4.r, z__3.i = snl * z__4.i;
+ z__2.r = z__3.r * a2->r - z__3.i * a2->i, z__2.i = z__3.r * a2->i
+ + z__3.i * a2->r;
+ d__1 = csl * *a3;
+ z__1.r = z__2.r + d__1, z__1.i = z__2.i;
+ ua22.r = z__1.r, ua22.i = z__1.i;
+
+ d_cnjg(&z__4, &d1);
+ z__3.r = -z__4.r, z__3.i = -z__4.i;
+ z__2.r = snr * z__3.r, z__2.i = snr * z__3.i;
+ z__1.r = *b1 * z__2.r, z__1.i = *b1 * z__2.i;
+ vb21.r = z__1.r, vb21.i = z__1.i;
+ d_cnjg(&z__5, &d1);
+ z__4.r = -z__5.r, z__4.i = -z__5.i;
+ z__3.r = snr * z__4.r, z__3.i = snr * z__4.i;
+ z__2.r = z__3.r * b2->r - z__3.i * b2->i, z__2.i = z__3.r * b2->i
+ + z__3.i * b2->r;
+ d__1 = csr * *b3;
+ z__1.r = z__2.r + d__1, z__1.i = z__2.i;
+ vb22.r = z__1.r, vb22.i = z__1.i;
+
+ aua22 = abs(snl) * ((d__1 = a2->r, abs(d__1)) + (d__2 = d_imag(a2)
+ , abs(d__2))) + abs(csl) * abs(*a3);
+ avb22 = abs(snr) * ((d__1 = b2->r, abs(d__1)) + (d__2 = d_imag(b2)
+ , abs(d__2))) + abs(csr) * abs(*b3);
+
+/* zero (2,2) elements of U'*A and V'*B, and then swap. */
+
+ if ((d__1 = ua21.r, abs(d__1)) + (d__2 = d_imag(&ua21), abs(d__2))
+ + ((d__3 = ua22.r, abs(d__3)) + (d__4 = d_imag(&ua22),
+ abs(d__4))) == 0.) {
+ d_cnjg(&z__2, &vb21);
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ d_cnjg(&z__3, &vb22);
+ zlartg_(&z__1, &z__3, csq, snq, &r__);
+ } else if ((d__1 = vb21.r, abs(d__1)) + (d__2 = d_imag(&vb21),
+ abs(d__2)) + z_abs(&vb22) == 0.) {
+ d_cnjg(&z__2, &ua21);
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ d_cnjg(&z__3, &ua22);
+ zlartg_(&z__1, &z__3, csq, snq, &r__);
+ } else if (aua22 / ((d__1 = ua21.r, abs(d__1)) + (d__2 = d_imag(&
+ ua21), abs(d__2)) + ((d__3 = ua22.r, abs(d__3)) + (d__4 =
+ d_imag(&ua22), abs(d__4)))) <= avb22 / ((d__5 = vb21.r,
+ abs(d__5)) + (d__6 = d_imag(&vb21), abs(d__6)) + ((d__7 =
+ vb22.r, abs(d__7)) + (d__8 = d_imag(&vb22), abs(d__8)))))
+ {
+ d_cnjg(&z__2, &ua21);
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ d_cnjg(&z__3, &ua22);
+ zlartg_(&z__1, &z__3, csq, snq, &r__);
+ } else {
+ d_cnjg(&z__2, &vb21);
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ d_cnjg(&z__3, &vb22);
+ zlartg_(&z__1, &z__3, csq, snq, &r__);
+ }
+
+ *csu = snl;
+ z__1.r = csl * d1.r, z__1.i = csl * d1.i;
+ snu->r = z__1.r, snu->i = z__1.i;
+ *csv = snr;
+ z__1.r = csr * d1.r, z__1.i = csr * d1.i;
+ snv->r = z__1.r, snv->i = z__1.i;
+
+ }
+
+ } else {
+
+/* Input matrices A and B are lower triangular matrices */
+
+/* Form matrix C = A*adj(B) = ( a 0 ) */
+/* ( c d ) */
+
+ a = *a1 * *b3;
+ d__ = *a3 * *b1;
+ z__2.r = *b3 * a2->r, z__2.i = *b3 * a2->i;
+ z__3.r = *a3 * b2->r, z__3.i = *a3 * b2->i;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ fc = z_abs(&c__);
+
+/* Transform complex 2-by-2 matrix C to real matrix by unitary */
+/* diagonal matrix diag(d1,1). */
+
+ d1.r = 1., d1.i = 0.;
+ if (fc != 0.) {
+ z__1.r = c__.r / fc, z__1.i = c__.i / fc;
+ d1.r = z__1.r, d1.i = z__1.i;
+ }
+
+/* The SVD of real 2 by 2 triangular C */
+
+/* ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 ) */
+/* ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T ) */
+
+ dlasv2_(&a, &fc, &d__, &s1, &s2, &snr, &csr, &snl, &csl);
+
+ if (abs(csr) >= abs(snr) || abs(csl) >= abs(snl)) {
+
+/* Compute the (2,1) and (2,2) elements of U'*A and V'*B, */
+/* and (2,1) element of |U|'*|A| and |V|'*|B|. */
+
+ z__4.r = -d1.r, z__4.i = -d1.i;
+ z__3.r = snr * z__4.r, z__3.i = snr * z__4.i;
+ z__2.r = *a1 * z__3.r, z__2.i = *a1 * z__3.i;
+ z__5.r = csr * a2->r, z__5.i = csr * a2->i;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+ ua21.r = z__1.r, ua21.i = z__1.i;
+ ua22r = csr * *a3;
+
+ z__4.r = -d1.r, z__4.i = -d1.i;
+ z__3.r = snl * z__4.r, z__3.i = snl * z__4.i;
+ z__2.r = *b1 * z__3.r, z__2.i = *b1 * z__3.i;
+ z__5.r = csl * b2->r, z__5.i = csl * b2->i;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+ vb21.r = z__1.r, vb21.i = z__1.i;
+ vb22r = csl * *b3;
+
+ aua21 = abs(snr) * abs(*a1) + abs(csr) * ((d__1 = a2->r, abs(d__1)
+ ) + (d__2 = d_imag(a2), abs(d__2)));
+ avb21 = abs(snl) * abs(*b1) + abs(csl) * ((d__1 = b2->r, abs(d__1)
+ ) + (d__2 = d_imag(b2), abs(d__2)));
+
+/* zero (2,1) elements of U'*A and V'*B. */
+
+ if ((d__1 = ua21.r, abs(d__1)) + (d__2 = d_imag(&ua21), abs(d__2))
+ + abs(ua22r) == 0.) {
+ z__1.r = vb22r, z__1.i = 0.;
+ zlartg_(&z__1, &vb21, csq, snq, &r__);
+ } else if ((d__1 = vb21.r, abs(d__1)) + (d__2 = d_imag(&vb21),
+ abs(d__2)) + abs(vb22r) == 0.) {
+ z__1.r = ua22r, z__1.i = 0.;
+ zlartg_(&z__1, &ua21, csq, snq, &r__);
+ } else if (aua21 / ((d__1 = ua21.r, abs(d__1)) + (d__2 = d_imag(&
+ ua21), abs(d__2)) + abs(ua22r)) <= avb21 / ((d__3 =
+ vb21.r, abs(d__3)) + (d__4 = d_imag(&vb21), abs(d__4)) +
+ abs(vb22r))) {
+ z__1.r = ua22r, z__1.i = 0.;
+ zlartg_(&z__1, &ua21, csq, snq, &r__);
+ } else {
+ z__1.r = vb22r, z__1.i = 0.;
+ zlartg_(&z__1, &vb21, csq, snq, &r__);
+ }
+
+ *csu = csr;
+ d_cnjg(&z__3, &d1);
+ z__2.r = -z__3.r, z__2.i = -z__3.i;
+ z__1.r = snr * z__2.r, z__1.i = snr * z__2.i;
+ snu->r = z__1.r, snu->i = z__1.i;
+ *csv = csl;
+ d_cnjg(&z__3, &d1);
+ z__2.r = -z__3.r, z__2.i = -z__3.i;
+ z__1.r = snl * z__2.r, z__1.i = snl * z__2.i;
+ snv->r = z__1.r, snv->i = z__1.i;
+
+ } else {
+
+/* Compute the (1,1) and (1,2) elements of U'*A and V'*B, */
+/* and (1,1) element of |U|'*|A| and |V|'*|B|. */
+
+ d__1 = csr * *a1;
+ d_cnjg(&z__4, &d1);
+ z__3.r = snr * z__4.r, z__3.i = snr * z__4.i;
+ z__2.r = z__3.r * a2->r - z__3.i * a2->i, z__2.i = z__3.r * a2->i
+ + z__3.i * a2->r;
+ z__1.r = d__1 + z__2.r, z__1.i = z__2.i;
+ ua11.r = z__1.r, ua11.i = z__1.i;
+ d_cnjg(&z__3, &d1);
+ z__2.r = snr * z__3.r, z__2.i = snr * z__3.i;
+ z__1.r = *a3 * z__2.r, z__1.i = *a3 * z__2.i;
+ ua12.r = z__1.r, ua12.i = z__1.i;
+
+ d__1 = csl * *b1;
+ d_cnjg(&z__4, &d1);
+ z__3.r = snl * z__4.r, z__3.i = snl * z__4.i;
+ z__2.r = z__3.r * b2->r - z__3.i * b2->i, z__2.i = z__3.r * b2->i
+ + z__3.i * b2->r;
+ z__1.r = d__1 + z__2.r, z__1.i = z__2.i;
+ vb11.r = z__1.r, vb11.i = z__1.i;
+ d_cnjg(&z__3, &d1);
+ z__2.r = snl * z__3.r, z__2.i = snl * z__3.i;
+ z__1.r = *b3 * z__2.r, z__1.i = *b3 * z__2.i;
+ vb12.r = z__1.r, vb12.i = z__1.i;
+
+ aua11 = abs(csr) * abs(*a1) + abs(snr) * ((d__1 = a2->r, abs(d__1)
+ ) + (d__2 = d_imag(a2), abs(d__2)));
+ avb11 = abs(csl) * abs(*b1) + abs(snl) * ((d__1 = b2->r, abs(d__1)
+ ) + (d__2 = d_imag(b2), abs(d__2)));
+
+/* zero (1,1) elements of U'*A and V'*B, and then swap. */
+
+ if ((d__1 = ua11.r, abs(d__1)) + (d__2 = d_imag(&ua11), abs(d__2))
+ + ((d__3 = ua12.r, abs(d__3)) + (d__4 = d_imag(&ua12),
+ abs(d__4))) == 0.) {
+ zlartg_(&vb12, &vb11, csq, snq, &r__);
+ } else if ((d__1 = vb11.r, abs(d__1)) + (d__2 = d_imag(&vb11),
+ abs(d__2)) + ((d__3 = vb12.r, abs(d__3)) + (d__4 = d_imag(
+ &vb12), abs(d__4))) == 0.) {
+ zlartg_(&ua12, &ua11, csq, snq, &r__);
+ } else if (aua11 / ((d__1 = ua11.r, abs(d__1)) + (d__2 = d_imag(&
+ ua11), abs(d__2)) + ((d__3 = ua12.r, abs(d__3)) + (d__4 =
+ d_imag(&ua12), abs(d__4)))) <= avb11 / ((d__5 = vb11.r,
+ abs(d__5)) + (d__6 = d_imag(&vb11), abs(d__6)) + ((d__7 =
+ vb12.r, abs(d__7)) + (d__8 = d_imag(&vb12), abs(d__8)))))
+ {
+ zlartg_(&ua12, &ua11, csq, snq, &r__);
+ } else {
+ zlartg_(&vb12, &vb11, csq, snq, &r__);
+ }
+
+ *csu = snr;
+ d_cnjg(&z__2, &d1);
+ z__1.r = csr * z__2.r, z__1.i = csr * z__2.i;
+ snu->r = z__1.r, snu->i = z__1.i;
+ *csv = snl;
+ d_cnjg(&z__2, &d1);
+ z__1.r = csl * z__2.r, z__1.i = csl * z__2.i;
+ snv->r = z__1.r, snv->i = z__1.i;
+
+ }
+
+ }
+
+ return 0;
+
+/* End of ZLAGS2 */
+
+} /* zlags2_ */
diff --git a/SRC/zlagtm.c b/SRC/zlagtm.c
new file mode 100644
index 0000000..dcd3775
--- /dev/null
+++ b/SRC/zlagtm.c
@@ -0,0 +1,599 @@
+/* zlagtm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlagtm_(char *trans, integer *n, integer *nrhs,
+ doublereal *alpha, doublecomplex *dl, doublecomplex *d__,
+ doublecomplex *du, doublecomplex *x, integer *ldx, doublereal *beta,
+ doublecomplex *b, integer *ldb)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6, i__7, i__8, i__9, i__10;
+ doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8, z__9;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ extern logical lsame_(char *, char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAGTM performs a matrix-vector product of the form */
+
+/* B := alpha * A * X + beta * B */
+
+/* where A is a tridiagonal matrix of order N, B and X are N by NRHS */
+/* matrices, and alpha and beta are real scalars, each of which may be */
+/* 0., 1., or -1. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': No transpose, B := alpha * A * X + beta * B */
+/* = 'T': Transpose, B := alpha * A**T * X + beta * B */
+/* = 'C': Conjugate transpose, B := alpha * A**H * X + beta * B */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. */
+
+/* ALPHA (input) DOUBLE PRECISION */
+/* The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise, */
+/* it is assumed to be 0. */
+
+/* DL (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) sub-diagonal elements of T. */
+
+/* D (input) COMPLEX*16 array, dimension (N) */
+/* The diagonal elements of T. */
+
+/* DU (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) super-diagonal elements of T. */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The N by NRHS matrix X. */
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(N,1). */
+
+/* BETA (input) DOUBLE PRECISION */
+/* The scalar beta. BETA must be 0., 1., or -1.; otherwise, */
+/* it is assumed to be 1. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the N by NRHS matrix B. */
+/* On exit, B is overwritten by the matrix expression */
+/* B := alpha * A * X + beta * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(N,1). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Multiply B by BETA if BETA.NE.1. */
+
+ if (*beta == 0.) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0., b[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (*beta == -1.) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ z__1.r = -b[i__4].r, z__1.i = -b[i__4].i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+ if (*alpha == 1.) {
+ if (lsame_(trans, "N")) {
+
+/* Compute B := B + A*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ z__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
+ z__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
+ .r;
+ z__1.r = b[i__3].r + z__2.r, z__1.i = b[i__3].i + z__2.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ z__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
+ z__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
+ .r;
+ z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i;
+ i__5 = j * x_dim1 + 2;
+ z__4.r = du[1].r * x[i__5].r - du[1].i * x[i__5].i,
+ z__4.i = du[1].r * x[i__5].i + du[1].i * x[i__5]
+ .r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ i__4 = *n - 1;
+ i__5 = *n - 1 + j * x_dim1;
+ z__3.r = dl[i__4].r * x[i__5].r - dl[i__4].i * x[i__5].i,
+ z__3.i = dl[i__4].r * x[i__5].i + dl[i__4].i * x[
+ i__5].r;
+ z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i;
+ i__6 = *n;
+ i__7 = *n + j * x_dim1;
+ z__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7]
+ .i, z__4.i = d__[i__6].r * x[i__7].i + d__[i__6]
+ .i * x[i__7].r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ - 1;
+ i__6 = i__ - 1 + j * x_dim1;
+ z__4.r = dl[i__5].r * x[i__6].r - dl[i__5].i * x[i__6]
+ .i, z__4.i = dl[i__5].r * x[i__6].i + dl[i__5]
+ .i * x[i__6].r;
+ z__3.r = b[i__4].r + z__4.r, z__3.i = b[i__4].i +
+ z__4.i;
+ i__7 = i__;
+ i__8 = i__ + j * x_dim1;
+ z__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[
+ i__8].i, z__5.i = d__[i__7].r * x[i__8].i +
+ d__[i__7].i * x[i__8].r;
+ z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
+ i__9 = i__;
+ i__10 = i__ + 1 + j * x_dim1;
+ z__6.r = du[i__9].r * x[i__10].r - du[i__9].i * x[
+ i__10].i, z__6.i = du[i__9].r * x[i__10].i +
+ du[i__9].i * x[i__10].r;
+ z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else if (lsame_(trans, "T")) {
+
+/* Compute B := B + A**T * X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ z__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
+ z__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
+ .r;
+ z__1.r = b[i__3].r + z__2.r, z__1.i = b[i__3].i + z__2.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ z__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
+ z__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
+ .r;
+ z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i;
+ i__5 = j * x_dim1 + 2;
+ z__4.r = dl[1].r * x[i__5].r - dl[1].i * x[i__5].i,
+ z__4.i = dl[1].r * x[i__5].i + dl[1].i * x[i__5]
+ .r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ i__4 = *n - 1;
+ i__5 = *n - 1 + j * x_dim1;
+ z__3.r = du[i__4].r * x[i__5].r - du[i__4].i * x[i__5].i,
+ z__3.i = du[i__4].r * x[i__5].i + du[i__4].i * x[
+ i__5].r;
+ z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i;
+ i__6 = *n;
+ i__7 = *n + j * x_dim1;
+ z__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7]
+ .i, z__4.i = d__[i__6].r * x[i__7].i + d__[i__6]
+ .i * x[i__7].r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ - 1;
+ i__6 = i__ - 1 + j * x_dim1;
+ z__4.r = du[i__5].r * x[i__6].r - du[i__5].i * x[i__6]
+ .i, z__4.i = du[i__5].r * x[i__6].i + du[i__5]
+ .i * x[i__6].r;
+ z__3.r = b[i__4].r + z__4.r, z__3.i = b[i__4].i +
+ z__4.i;
+ i__7 = i__;
+ i__8 = i__ + j * x_dim1;
+ z__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[
+ i__8].i, z__5.i = d__[i__7].r * x[i__8].i +
+ d__[i__7].i * x[i__8].r;
+ z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
+ i__9 = i__;
+ i__10 = i__ + 1 + j * x_dim1;
+ z__6.r = dl[i__9].r * x[i__10].r - dl[i__9].i * x[
+ i__10].i, z__6.i = dl[i__9].r * x[i__10].i +
+ dl[i__9].i * x[i__10].r;
+ z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L70: */
+ }
+ }
+/* L80: */
+ }
+ } else if (lsame_(trans, "C")) {
+
+/* Compute B := B + A**H * X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ d_cnjg(&z__3, &d__[1]);
+ i__4 = j * x_dim1 + 1;
+ z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i =
+ z__3.r * x[i__4].i + z__3.i * x[i__4].r;
+ z__1.r = b[i__3].r + z__2.r, z__1.i = b[i__3].i + z__2.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ d_cnjg(&z__4, &d__[1]);
+ i__4 = j * x_dim1 + 1;
+ z__3.r = z__4.r * x[i__4].r - z__4.i * x[i__4].i, z__3.i =
+ z__4.r * x[i__4].i + z__4.i * x[i__4].r;
+ z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i;
+ d_cnjg(&z__6, &dl[1]);
+ i__5 = j * x_dim1 + 2;
+ z__5.r = z__6.r * x[i__5].r - z__6.i * x[i__5].i, z__5.i =
+ z__6.r * x[i__5].i + z__6.i * x[i__5].r;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ d_cnjg(&z__4, &du[*n - 1]);
+ i__4 = *n - 1 + j * x_dim1;
+ z__3.r = z__4.r * x[i__4].r - z__4.i * x[i__4].i, z__3.i =
+ z__4.r * x[i__4].i + z__4.i * x[i__4].r;
+ z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i;
+ d_cnjg(&z__6, &d__[*n]);
+ i__5 = *n + j * x_dim1;
+ z__5.r = z__6.r * x[i__5].r - z__6.i * x[i__5].i, z__5.i =
+ z__6.r * x[i__5].i + z__6.i * x[i__5].r;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ d_cnjg(&z__5, &du[i__ - 1]);
+ i__5 = i__ - 1 + j * x_dim1;
+ z__4.r = z__5.r * x[i__5].r - z__5.i * x[i__5].i,
+ z__4.i = z__5.r * x[i__5].i + z__5.i * x[i__5]
+ .r;
+ z__3.r = b[i__4].r + z__4.r, z__3.i = b[i__4].i +
+ z__4.i;
+ d_cnjg(&z__7, &d__[i__]);
+ i__6 = i__ + j * x_dim1;
+ z__6.r = z__7.r * x[i__6].r - z__7.i * x[i__6].i,
+ z__6.i = z__7.r * x[i__6].i + z__7.i * x[i__6]
+ .r;
+ z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
+ d_cnjg(&z__9, &dl[i__]);
+ i__7 = i__ + 1 + j * x_dim1;
+ z__8.r = z__9.r * x[i__7].r - z__9.i * x[i__7].i,
+ z__8.i = z__9.r * x[i__7].i + z__9.i * x[i__7]
+ .r;
+ z__1.r = z__2.r + z__8.r, z__1.i = z__2.i + z__8.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L90: */
+ }
+ }
+/* L100: */
+ }
+ }
+ } else if (*alpha == -1.) {
+ if (lsame_(trans, "N")) {
+
+/* Compute B := B - A*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ z__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
+ z__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
+ .r;
+ z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i - z__2.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ z__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
+ z__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
+ .r;
+ z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i;
+ i__5 = j * x_dim1 + 2;
+ z__4.r = du[1].r * x[i__5].r - du[1].i * x[i__5].i,
+ z__4.i = du[1].r * x[i__5].i + du[1].i * x[i__5]
+ .r;
+ z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ i__4 = *n - 1;
+ i__5 = *n - 1 + j * x_dim1;
+ z__3.r = dl[i__4].r * x[i__5].r - dl[i__4].i * x[i__5].i,
+ z__3.i = dl[i__4].r * x[i__5].i + dl[i__4].i * x[
+ i__5].r;
+ z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i;
+ i__6 = *n;
+ i__7 = *n + j * x_dim1;
+ z__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7]
+ .i, z__4.i = d__[i__6].r * x[i__7].i + d__[i__6]
+ .i * x[i__7].r;
+ z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ - 1;
+ i__6 = i__ - 1 + j * x_dim1;
+ z__4.r = dl[i__5].r * x[i__6].r - dl[i__5].i * x[i__6]
+ .i, z__4.i = dl[i__5].r * x[i__6].i + dl[i__5]
+ .i * x[i__6].r;
+ z__3.r = b[i__4].r - z__4.r, z__3.i = b[i__4].i -
+ z__4.i;
+ i__7 = i__;
+ i__8 = i__ + j * x_dim1;
+ z__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[
+ i__8].i, z__5.i = d__[i__7].r * x[i__8].i +
+ d__[i__7].i * x[i__8].r;
+ z__2.r = z__3.r - z__5.r, z__2.i = z__3.i - z__5.i;
+ i__9 = i__;
+ i__10 = i__ + 1 + j * x_dim1;
+ z__6.r = du[i__9].r * x[i__10].r - du[i__9].i * x[
+ i__10].i, z__6.i = du[i__9].r * x[i__10].i +
+ du[i__9].i * x[i__10].r;
+ z__1.r = z__2.r - z__6.r, z__1.i = z__2.i - z__6.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L110: */
+ }
+ }
+/* L120: */
+ }
+ } else if (lsame_(trans, "T")) {
+
+/* Compute B := B - A'*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ z__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
+ z__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
+ .r;
+ z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i - z__2.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ z__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i,
+ z__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4]
+ .r;
+ z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i;
+ i__5 = j * x_dim1 + 2;
+ z__4.r = dl[1].r * x[i__5].r - dl[1].i * x[i__5].i,
+ z__4.i = dl[1].r * x[i__5].i + dl[1].i * x[i__5]
+ .r;
+ z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ i__4 = *n - 1;
+ i__5 = *n - 1 + j * x_dim1;
+ z__3.r = du[i__4].r * x[i__5].r - du[i__4].i * x[i__5].i,
+ z__3.i = du[i__4].r * x[i__5].i + du[i__4].i * x[
+ i__5].r;
+ z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i;
+ i__6 = *n;
+ i__7 = *n + j * x_dim1;
+ z__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7]
+ .i, z__4.i = d__[i__6].r * x[i__7].i + d__[i__6]
+ .i * x[i__7].r;
+ z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ - 1;
+ i__6 = i__ - 1 + j * x_dim1;
+ z__4.r = du[i__5].r * x[i__6].r - du[i__5].i * x[i__6]
+ .i, z__4.i = du[i__5].r * x[i__6].i + du[i__5]
+ .i * x[i__6].r;
+ z__3.r = b[i__4].r - z__4.r, z__3.i = b[i__4].i -
+ z__4.i;
+ i__7 = i__;
+ i__8 = i__ + j * x_dim1;
+ z__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[
+ i__8].i, z__5.i = d__[i__7].r * x[i__8].i +
+ d__[i__7].i * x[i__8].r;
+ z__2.r = z__3.r - z__5.r, z__2.i = z__3.i - z__5.i;
+ i__9 = i__;
+ i__10 = i__ + 1 + j * x_dim1;
+ z__6.r = dl[i__9].r * x[i__10].r - dl[i__9].i * x[
+ i__10].i, z__6.i = dl[i__9].r * x[i__10].i +
+ dl[i__9].i * x[i__10].r;
+ z__1.r = z__2.r - z__6.r, z__1.i = z__2.i - z__6.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L130: */
+ }
+ }
+/* L140: */
+ }
+ } else if (lsame_(trans, "C")) {
+
+/* Compute B := B - A'*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ d_cnjg(&z__3, &d__[1]);
+ i__4 = j * x_dim1 + 1;
+ z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i =
+ z__3.r * x[i__4].i + z__3.i * x[i__4].r;
+ z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i - z__2.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ d_cnjg(&z__4, &d__[1]);
+ i__4 = j * x_dim1 + 1;
+ z__3.r = z__4.r * x[i__4].r - z__4.i * x[i__4].i, z__3.i =
+ z__4.r * x[i__4].i + z__4.i * x[i__4].r;
+ z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i;
+ d_cnjg(&z__6, &dl[1]);
+ i__5 = j * x_dim1 + 2;
+ z__5.r = z__6.r * x[i__5].r - z__6.i * x[i__5].i, z__5.i =
+ z__6.r * x[i__5].i + z__6.i * x[i__5].r;
+ z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - z__5.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ d_cnjg(&z__4, &du[*n - 1]);
+ i__4 = *n - 1 + j * x_dim1;
+ z__3.r = z__4.r * x[i__4].r - z__4.i * x[i__4].i, z__3.i =
+ z__4.r * x[i__4].i + z__4.i * x[i__4].r;
+ z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i;
+ d_cnjg(&z__6, &d__[*n]);
+ i__5 = *n + j * x_dim1;
+ z__5.r = z__6.r * x[i__5].r - z__6.i * x[i__5].i, z__5.i =
+ z__6.r * x[i__5].i + z__6.i * x[i__5].r;
+ z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - z__5.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ d_cnjg(&z__5, &du[i__ - 1]);
+ i__5 = i__ - 1 + j * x_dim1;
+ z__4.r = z__5.r * x[i__5].r - z__5.i * x[i__5].i,
+ z__4.i = z__5.r * x[i__5].i + z__5.i * x[i__5]
+ .r;
+ z__3.r = b[i__4].r - z__4.r, z__3.i = b[i__4].i -
+ z__4.i;
+ d_cnjg(&z__7, &d__[i__]);
+ i__6 = i__ + j * x_dim1;
+ z__6.r = z__7.r * x[i__6].r - z__7.i * x[i__6].i,
+ z__6.i = z__7.r * x[i__6].i + z__7.i * x[i__6]
+ .r;
+ z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
+ d_cnjg(&z__9, &dl[i__]);
+ i__7 = i__ + 1 + j * x_dim1;
+ z__8.r = z__9.r * x[i__7].r - z__9.i * x[i__7].i,
+ z__8.i = z__9.r * x[i__7].i + z__9.i * x[i__7]
+ .r;
+ z__1.r = z__2.r - z__8.r, z__1.i = z__2.i - z__8.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L150: */
+ }
+ }
+/* L160: */
+ }
+ }
+ }
+ return 0;
+
+/* End of ZLAGTM */
+
+} /* zlagtm_ */
diff --git a/SRC/zlahef.c b/SRC/zlahef.c
new file mode 100644
index 0000000..048db90
--- /dev/null
+++ b/SRC/zlahef.c
@@ -0,0 +1,938 @@
+/* zlahef.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zlahef_(char *uplo, integer *n, integer *nb, integer *kb,
+ doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *w,
+ integer *ldw, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_imag(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *), z_div(doublecomplex *,
+ doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer j, k;
+ doublereal t, r1;
+ doublecomplex d11, d21, d22;
+ integer jb, jj, kk, jp, kp, kw, kkw, imax, jmax;
+ doublereal alpha;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer kstep;
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zswap_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ doublereal absakk;
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ doublereal colmax;
+ extern /* Subroutine */ int zlacgv_(integer *, doublecomplex *, integer *)
+ ;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ doublereal rowmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAHEF computes a partial factorization of a complex Hermitian */
+/* matrix A using the Bunch-Kaufman 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' U22' ) */
+
+/* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) 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. */
+/* Note that U' denotes the conjugate transpose of U. */
+
+/* ZLAHEF is an auxiliary routine called by ZHETRF. It uses blocked code */
+/* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or */
+/* A22 (if UPLO = 'L'). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NB (input) 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. */
+
+/* KB (output) INTEGER */
+/* The number of columns of A that were actually factored. */
+/* KB is either NB-1 or NB, or N if N <= NB. */
+
+/* A (input/output) 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, A contains details of the partial factorization. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If UPLO = 'U', only the last KB elements of IPIV are set; */
+/* if UPLO = 'L', only the first KB elements are set. */
+
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* W (workspace) COMPLEX*16 array, dimension (LDW,NB) */
+
+/* LDW (input) INTEGER */
+/* The leading dimension of the array W. LDW >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* > 0: if INFO = k, D(k,k) is exactly zero. The factorization */
+/* has been completed, but the block diagonal matrix D is */
+/* exactly singular. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ w_dim1 = *ldw;
+ w_offset = 1 + w_dim1;
+ w -= w_offset;
+
+ /* Function Body */
+ *info = 0;
+
+/* Initialize ALPHA for use in choosing pivot block size. */
+
+ alpha = (sqrt(17.) + 1.) / 8.;
+
+ if (lsame_(uplo, "U")) {
+
+/* 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) */
+
+/* K is the main loop index, decreasing from N in steps of 1 or 2 */
+
+/* KW is the column of W which corresponds to column K of A */
+
+ k = *n;
+L10:
+ kw = *nb + k - *n;
+
+/* Exit from loop */
+
+ if (k <= *n - *nb + 1 && *nb < *n || k < 1) {
+ goto L30;
+ }
+
+/* Copy column K of A to column KW of W and update it */
+
+ i__1 = k - 1;
+ zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1);
+ i__1 = k + kw * w_dim1;
+ i__2 = k + k * a_dim1;
+ d__1 = a[i__2].r;
+ w[i__1].r = d__1, w[i__1].i = 0.;
+ if (k < *n) {
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * a_dim1 + 1],
+ lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw *
+ w_dim1 + 1], &c__1);
+ i__1 = k + kw * w_dim1;
+ i__2 = k + kw * w_dim1;
+ d__1 = w[i__2].r;
+ w[i__1].r = d__1, w[i__1].i = 0.;
+ }
+
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = k + kw * w_dim1;
+ absakk = (d__1 = w[i__1].r, abs(d__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ imax = izamax_(&i__1, &w[kw * w_dim1 + 1], &c__1);
+ i__1 = imax + kw * w_dim1;
+ colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax +
+ kw * w_dim1]), abs(d__2));
+ } else {
+ colmax = 0.;
+ }
+
+ if (max(absakk,colmax) == 0.) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ d__1 = a[i__2].r;
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* Copy column IMAX to column KW-1 of W and update it */
+
+ i__1 = imax - 1;
+ zcopy_(&i__1, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) *
+ w_dim1 + 1], &c__1);
+ i__1 = imax + (kw - 1) * w_dim1;
+ i__2 = imax + imax * a_dim1;
+ d__1 = a[i__2].r;
+ w[i__1].r = d__1, w[i__1].i = 0.;
+ i__1 = k - imax;
+ zcopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax +
+ 1 + (kw - 1) * w_dim1], &c__1);
+ i__1 = k - imax;
+ zlacgv_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], &c__1);
+ if (k < *n) {
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) *
+ a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1],
+ ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1);
+ i__1 = imax + (kw - 1) * w_dim1;
+ i__2 = imax + (kw - 1) * w_dim1;
+ d__1 = w[i__2].r;
+ w[i__1].r = d__1, w[i__1].i = 0.;
+ }
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = k - imax;
+ jmax = imax + izamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1],
+ &c__1);
+ i__1 = jmax + (kw - 1) * w_dim1;
+ rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[
+ jmax + (kw - 1) * w_dim1]), abs(d__2));
+ if (imax > 1) {
+ i__1 = imax - 1;
+ jmax = izamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__1 = jmax + (kw - 1) * w_dim1;
+ d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) + (
+ d__2 = d_imag(&w[jmax + (kw - 1) * w_dim1]), abs(
+ d__2));
+ rowmax = max(d__3,d__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = imax + (kw - 1) * w_dim1;
+ if ((d__1 = w[i__1].r, abs(d__1)) >= alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+
+/* copy column KW-1 of W to column KW */
+
+ zcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw *
+ w_dim1 + 1], &c__1);
+ } else {
+
+/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k - kstep + 1;
+ kkw = *nb + kk - *n;
+
+/* Updated column KP is already stored in column KKW of W */
+
+ if (kp != kk) {
+
+/* Copy non-updated column KK to column KP */
+
+ i__1 = kp + kp * a_dim1;
+ i__2 = kk + kk * a_dim1;
+ d__1 = a[i__2].r;
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ i__1 = kk - 1 - kp;
+ zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp +
+ 1) * a_dim1], lda);
+ i__1 = kk - 1 - kp;
+ zlacgv_(&i__1, &a[kp + (kp + 1) * a_dim1], lda);
+ i__1 = kp - 1;
+ zcopy_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1],
+ &c__1);
+
+/* Interchange rows KK and KP in last KK columns of A and W */
+
+ if (kk < *n) {
+ i__1 = *n - kk;
+ zswap_(&i__1, &a[kk + (kk + 1) * a_dim1], lda, &a[kp + (
+ kk + 1) * a_dim1], lda);
+ }
+ i__1 = *n - kk + 1;
+ zswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw *
+ w_dim1], ldw);
+ }
+
+ if (kstep == 1) {
+
+/* 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 */
+
+ zcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &
+ c__1);
+ i__1 = k + k * a_dim1;
+ r1 = 1. / a[i__1].r;
+ i__1 = k - 1;
+ zdscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
+
+/* Conjugate W(k) */
+
+ i__1 = k - 1;
+ zlacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1);
+ } 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 > 2) {
+
+/* Store U(k) and U(k-1) in columns k and k-1 of A */
+
+ i__1 = k - 1 + kw * w_dim1;
+ d21.r = w[i__1].r, d21.i = w[i__1].i;
+ d_cnjg(&z__2, &d21);
+ z_div(&z__1, &w[k + kw * w_dim1], &z__2);
+ d11.r = z__1.r, d11.i = z__1.i;
+ z_div(&z__1, &w[k - 1 + (kw - 1) * w_dim1], &d21);
+ d22.r = z__1.r, d22.i = z__1.i;
+ z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r *
+ d22.i + d11.i * d22.r;
+ t = 1. / (z__1.r - 1.);
+ z__2.r = t, z__2.i = 0.;
+ z_div(&z__1, &z__2, &d21);
+ d21.r = z__1.r, d21.i = z__1.i;
+ i__1 = k - 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + (k - 1) * a_dim1;
+ i__3 = j + (kw - 1) * w_dim1;
+ z__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
+ z__3.i = d11.r * w[i__3].i + d11.i * w[i__3]
+ .r;
+ i__4 = j + kw * w_dim1;
+ z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4]
+ .i;
+ z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i =
+ d21.r * z__2.i + d21.i * z__2.r;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ i__2 = j + k * a_dim1;
+ d_cnjg(&z__2, &d21);
+ i__3 = j + kw * w_dim1;
+ z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
+ z__4.i = d22.r * w[i__3].i + d22.i * w[i__3]
+ .r;
+ i__4 = j + (kw - 1) * w_dim1;
+ z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4]
+ .i;
+ z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i =
+ z__2.r * z__3.i + z__2.i * z__3.r;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L20: */
+ }
+ }
+
+/* Copy D(k) to A */
+
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ i__2 = k - 1 + (kw - 1) * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+ i__1 = k - 1 + k * a_dim1;
+ i__2 = k - 1 + kw * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+ i__1 = k + k * a_dim1;
+ i__2 = k + kw * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+
+/* Conjugate W(k) and W(k-1) */
+
+ i__1 = k - 1;
+ zlacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1);
+ i__1 = k - 2;
+ zlacgv_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k - 1] = -kp;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kstep;
+ goto L10;
+
+L30:
+
+/* Update the upper triangle of A11 (= A(1:k,1:k)) as */
+
+/* A11 := A11 - U12*D*U12' = A11 - U12*W' */
+
+/* computing blocks of NB columns at a time (note that conjg(W) is */
+/* actually stored) */
+
+ i__1 = -(*nb);
+ for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j +=
+ i__1) {
+/* Computing MIN */
+ i__2 = *nb, i__3 = k - j + 1;
+ jb = min(i__2,i__3);
+
+/* Update the upper triangle of the diagonal block */
+
+ i__2 = j + jb - 1;
+ for (jj = j; jj <= i__2; ++jj) {
+ i__3 = jj + jj * a_dim1;
+ i__4 = jj + jj * a_dim1;
+ d__1 = a[i__4].r;
+ a[i__3].r = d__1, a[i__3].i = 0.;
+ i__3 = jj - j + 1;
+ i__4 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__3, &i__4, &z__1, &a[j + (k + 1) *
+ a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b1,
+ &a[j + jj * a_dim1], &c__1);
+ i__3 = jj + jj * a_dim1;
+ i__4 = jj + jj * a_dim1;
+ d__1 = a[i__4].r;
+ a[i__3].r = d__1, a[i__3].i = 0.;
+/* L40: */
+ }
+
+/* Update the rectangular superdiagonal block */
+
+ i__2 = j - 1;
+ i__3 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &z__1, &a[(
+ k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * w_dim1], ldw,
+ &c_b1, &a[j * a_dim1 + 1], lda);
+/* L50: */
+ }
+
+/* Put U12 in standard form by partially undoing the interchanges */
+/* in columns k+1:n */
+
+ j = k + 1;
+L60:
+ jj = j;
+ jp = ipiv[j];
+ if (jp < 0) {
+ jp = -jp;
+ ++j;
+ }
+ ++j;
+ if (jp != jj && j <= *n) {
+ i__1 = *n - j + 1;
+ zswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda);
+ }
+ if (j <= *n) {
+ goto L60;
+ }
+
+/* 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) */
+
+/* K is the main loop index, increasing from 1 in steps of 1 or 2 */
+
+ k = 1;
+L70:
+
+/* Exit from loop */
+
+ if (k >= *nb && *nb < *n || k > *n) {
+ goto L90;
+ }
+
+/* Copy column K of A to column K of W and update it */
+
+ i__1 = k + k * w_dim1;
+ i__2 = k + k * a_dim1;
+ d__1 = a[i__2].r;
+ w[i__1].r = d__1, w[i__1].i = 0.;
+ if (k < *n) {
+ i__1 = *n - k;
+ zcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &w[k + 1 + k *
+ w_dim1], &c__1);
+ }
+ i__1 = *n - k + 1;
+ i__2 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], lda, &w[k
+ + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1);
+ i__1 = k + k * w_dim1;
+ i__2 = k + k * w_dim1;
+ d__1 = w[i__2].r;
+ w[i__1].r = d__1, w[i__1].i = 0.;
+
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = k + k * w_dim1;
+ absakk = (d__1 = w[i__1].r, abs(d__1));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ imax = k + izamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1);
+ i__1 = imax + k * w_dim1;
+ colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax +
+ k * w_dim1]), abs(d__2));
+ } else {
+ colmax = 0.;
+ }
+
+ if (max(absakk,colmax) == 0.) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ d__1 = a[i__2].r;
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* Copy column IMAX to column K+1 of W and update it */
+
+ i__1 = imax - k;
+ zcopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) *
+ w_dim1], &c__1);
+ i__1 = imax - k;
+ zlacgv_(&i__1, &w[k + (k + 1) * w_dim1], &c__1);
+ i__1 = imax + (k + 1) * w_dim1;
+ i__2 = imax + imax * a_dim1;
+ d__1 = a[i__2].r;
+ w[i__1].r = d__1, w[i__1].i = 0.;
+ if (imax < *n) {
+ i__1 = *n - imax;
+ zcopy_(&i__1, &a[imax + 1 + imax * a_dim1], &c__1, &w[
+ imax + 1 + (k + 1) * w_dim1], &c__1);
+ }
+ i__1 = *n - k + 1;
+ i__2 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1],
+ lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + 1) *
+ w_dim1], &c__1);
+ i__1 = imax + (k + 1) * w_dim1;
+ i__2 = imax + (k + 1) * w_dim1;
+ d__1 = w[i__2].r;
+ w[i__1].r = d__1, w[i__1].i = 0.;
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = imax - k;
+ jmax = k - 1 + izamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1)
+ ;
+ i__1 = jmax + (k + 1) * w_dim1;
+ rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[
+ jmax + (k + 1) * w_dim1]), abs(d__2));
+ if (imax < *n) {
+ i__1 = *n - imax;
+ jmax = imax + izamax_(&i__1, &w[imax + 1 + (k + 1) *
+ w_dim1], &c__1);
+/* Computing MAX */
+ i__1 = jmax + (k + 1) * w_dim1;
+ d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) + (
+ d__2 = d_imag(&w[jmax + (k + 1) * w_dim1]), abs(
+ d__2));
+ rowmax = max(d__3,d__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = imax + (k + 1) * w_dim1;
+ if ((d__1 = w[i__1].r, abs(d__1)) >= alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+
+/* copy column K+1 of W to column K */
+
+ i__1 = *n - k + 1;
+ zcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k +
+ k * w_dim1], &c__1);
+ } else {
+
+/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k + kstep - 1;
+
+/* Updated column KP is already stored in column KK of W */
+
+ if (kp != kk) {
+
+/* Copy non-updated column KK to column KP */
+
+ i__1 = kp + kp * a_dim1;
+ i__2 = kk + kk * a_dim1;
+ d__1 = a[i__2].r;
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ i__1 = kp - kk - 1;
+ zcopy_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk +
+ 1) * a_dim1], lda);
+ i__1 = kp - kk - 1;
+ zlacgv_(&i__1, &a[kp + (kk + 1) * a_dim1], lda);
+ if (kp < *n) {
+ i__1 = *n - kp;
+ zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1
+ + kp * a_dim1], &c__1);
+ }
+
+/* Interchange rows KK and KP in first KK columns of A and W */
+
+ i__1 = kk - 1;
+ zswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda);
+ zswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw);
+ }
+
+ if (kstep == 1) {
+
+/* 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 */
+
+ i__1 = *n - k + 1;
+ zcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], &
+ c__1);
+ if (k < *n) {
+ i__1 = k + k * a_dim1;
+ r1 = 1. / a[i__1].r;
+ i__1 = *n - k;
+ zdscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1);
+
+/* Conjugate W(k) */
+
+ i__1 = *n - k;
+ zlacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1);
+ }
+ } 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 < *n - 1) {
+
+/* Store L(k) and L(k+1) in columns k and k+1 of A */
+
+ i__1 = k + 1 + k * w_dim1;
+ d21.r = w[i__1].r, d21.i = w[i__1].i;
+ z_div(&z__1, &w[k + 1 + (k + 1) * w_dim1], &d21);
+ d11.r = z__1.r, d11.i = z__1.i;
+ d_cnjg(&z__2, &d21);
+ z_div(&z__1, &w[k + k * w_dim1], &z__2);
+ d22.r = z__1.r, d22.i = z__1.i;
+ z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r *
+ d22.i + d11.i * d22.r;
+ t = 1. / (z__1.r - 1.);
+ z__2.r = t, z__2.i = 0.;
+ z_div(&z__1, &z__2, &d21);
+ d21.r = z__1.r, d21.i = z__1.i;
+ i__1 = *n;
+ for (j = k + 2; j <= i__1; ++j) {
+ i__2 = j + k * a_dim1;
+ d_cnjg(&z__2, &d21);
+ i__3 = j + k * w_dim1;
+ z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
+ z__4.i = d11.r * w[i__3].i + d11.i * w[i__3]
+ .r;
+ i__4 = j + (k + 1) * w_dim1;
+ z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4]
+ .i;
+ z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i =
+ z__2.r * z__3.i + z__2.i * z__3.r;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ i__2 = j + (k + 1) * a_dim1;
+ i__3 = j + (k + 1) * w_dim1;
+ z__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
+ z__3.i = d22.r * w[i__3].i + d22.i * w[i__3]
+ .r;
+ i__4 = j + k * w_dim1;
+ z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4]
+ .i;
+ z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i =
+ d21.r * z__2.i + d21.i * z__2.r;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L80: */
+ }
+ }
+
+/* Copy D(k) to A */
+
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+ i__1 = k + 1 + k * a_dim1;
+ i__2 = k + 1 + k * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ i__2 = k + 1 + (k + 1) * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+
+/* Conjugate W(k) and W(k+1) */
+
+ i__1 = *n - k;
+ zlacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1);
+ i__1 = *n - k - 1;
+ zlacgv_(&i__1, &w[k + 2 + (k + 1) * w_dim1], &c__1);
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k + 1] = -kp;
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kstep;
+ goto L70;
+
+L90:
+
+/* Update the lower triangle of A22 (= A(k:n,k:n)) as */
+
+/* A22 := A22 - L21*D*L21' = A22 - L21*W' */
+
+/* computing blocks of NB columns at a time (note that conjg(W) is */
+/* actually stored) */
+
+ i__1 = *n;
+ i__2 = *nb;
+ for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = *nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+
+/* Update the lower triangle of the diagonal block */
+
+ i__3 = j + jb - 1;
+ for (jj = j; jj <= i__3; ++jj) {
+ i__4 = jj + jj * a_dim1;
+ i__5 = jj + jj * a_dim1;
+ d__1 = a[i__5].r;
+ a[i__4].r = d__1, a[i__4].i = 0.;
+ i__4 = j + jb - jj;
+ i__5 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__4, &i__5, &z__1, &a[jj + a_dim1],
+ lda, &w[jj + w_dim1], ldw, &c_b1, &a[jj + jj * a_dim1]
+, &c__1);
+ i__4 = jj + jj * a_dim1;
+ i__5 = jj + jj * a_dim1;
+ d__1 = a[i__5].r;
+ a[i__4].r = d__1, a[i__4].i = 0.;
+/* L100: */
+ }
+
+/* Update the rectangular subdiagonal block */
+
+ if (j + jb <= *n) {
+ i__3 = *n - j - jb + 1;
+ i__4 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &z__1,
+ &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b1,
+ &a[j + jb + j * a_dim1], lda);
+ }
+/* L110: */
+ }
+
+/* Put L21 in standard form by partially undoing the interchanges */
+/* in columns 1:k-1 */
+
+ j = k - 1;
+L120:
+ jj = j;
+ jp = ipiv[j];
+ if (jp < 0) {
+ jp = -jp;
+ --j;
+ }
+ --j;
+ if (jp != jj && j >= 1) {
+ zswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda);
+ }
+ if (j >= 1) {
+ goto L120;
+ }
+
+/* Set KB to the number of columns factorized */
+
+ *kb = k - 1;
+
+ }
+ return 0;
+
+/* End of ZLAHEF */
+
+} /* zlahef_ */
diff --git a/SRC/zlahqr.c b/SRC/zlahqr.c
new file mode 100644
index 0000000..ea4178f
--- /dev/null
+++ b/SRC/zlahqr.c
@@ -0,0 +1,755 @@
+/* zlahqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int zlahqr_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, doublecomplex *h__, integer *ldh,
+ doublecomplex *w, integer *iloz, integer *ihiz, doublecomplex *z__,
+ integer *ldz, integer *info)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6;
+ doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ double z_abs(doublecomplex *);
+ void z_sqrt(doublecomplex *, doublecomplex *), pow_zi(doublecomplex *,
+ doublecomplex *, integer *);
+
+ /* Local variables */
+ integer i__, j, k, l, m;
+ doublereal s;
+ doublecomplex t, u, v[2], x, y;
+ integer i1, i2;
+ doublecomplex t1;
+ doublereal t2;
+ doublecomplex v2;
+ doublereal aa, ab, ba, bb, h10;
+ doublecomplex h11;
+ doublereal h21;
+ doublecomplex h22, sc;
+ integer nh, nz;
+ doublereal sx;
+ integer jhi;
+ doublecomplex h11s;
+ integer jlo, its;
+ doublereal ulp;
+ doublecomplex sum;
+ doublereal tst;
+ doublecomplex temp;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ doublereal rtemp;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin, safmax;
+ extern /* Subroutine */ int zlarfg_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *);
+ extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
+ doublecomplex *);
+ doublereal smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAHQR is an auxiliary routine called by CHSEQR to update the */
+/* eigenvalues and Schur decomposition already computed by CHSEQR, by */
+/* dealing with the Hessenberg submatrix in rows and columns ILO to */
+/* IHI. */
+
+/* Arguments */
+/* ========= */
+
+/* WANTT (input) LOGICAL */
+/* = .TRUE. : the full Schur form T is required; */
+/* = .FALSE.: only eigenvalues are required. */
+
+/* WANTZ (input) LOGICAL */
+/* = .TRUE. : the matrix of Schur vectors Z is required; */
+/* = .FALSE.: Schur vectors are not required. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that H is already upper triangular in rows and */
+/* columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1). */
+/* ZLAHQR works primarily with the Hessenberg submatrix in rows */
+/* and columns ILO to IHI, but applies transformations to all of */
+/* H if WANTT is .TRUE.. */
+/* 1 <= ILO <= max(1,IHI); IHI <= N. */
+
+/* H (input/output) COMPLEX*16 array, dimension (LDH,N) */
+/* On entry, the upper Hessenberg matrix H. */
+/* On exit, if INFO is zero and if WANTT is .TRUE., then H */
+/* is upper triangular in rows and columns ILO:IHI. If INFO */
+/* is zero and if WANTT is .FALSE., then the contents of H */
+/* are unspecified on exit. The output state of H in case */
+/* INF is positive is below under the description of INFO. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH >= max(1,N). */
+
+/* W (output) COMPLEX*16 array, dimension (N) */
+/* The computed eigenvalues ILO to IHI are stored in the */
+/* corresponding elements of W. If WANTT is .TRUE., the */
+/* eigenvalues are stored in the same order as on the diagonal */
+/* of the Schur form returned in H, with W(i) = H(i,i). */
+
+/* ILOZ (input) INTEGER */
+/* IHIZ (input) INTEGER */
+/* Specify the rows of Z to which transformations must be */
+/* applied if WANTZ is .TRUE.. */
+/* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */
+
+/* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) */
+/* If WANTZ is .TRUE., on entry Z must contain the current */
+/* matrix Z of transformations accumulated by CHSEQR, and on */
+/* exit Z has been updated; transformations are applied only to */
+/* the submatrix Z(ILOZ:IHIZ,ILO:IHI). */
+/* If WANTZ is .FALSE., Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* .GT. 0: if INFO = i, ZLAHQR failed to compute all the */
+/* eigenvalues ILO to IHI in a total of 30 iterations */
+/* per eigenvalue; elements i+1:ihi of W contain */
+/* those eigenvalues which have been successfully */
+/* computed. */
+
+/* If INFO .GT. 0 and WANTT is .FALSE., then on exit, */
+/* the remaining unconverged eigenvalues are the */
+/* eigenvalues of the upper Hessenberg matrix */
+/* rows and columns ILO thorugh INFO of the final, */
+/* output value of H. */
+
+/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */
+/* (*) (initial value of H)*U = U*(final value of H) */
+/* where U is an orthognal matrix. The final */
+/* value of H is upper Hessenberg and triangular in */
+/* rows and columns INFO+1 through IHI. */
+
+/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
+/* (final value of Z) = (initial value of Z)*U */
+/* where U is the orthogonal matrix in (*) */
+/* (regardless of the value of WANTT.) */
+
+/* Further Details */
+/* =============== */
+
+/* 02-96 Based on modifications by */
+/* David Day, Sandia National Laboratory, USA */
+
+/* 12-04 Further modifications by */
+/* Ralph Byers, University of Kansas, USA */
+/* This is a modified version of ZLAHQR from LAPACK version 3.0. */
+/* It is (1) more robust against overflow and underflow and */
+/* (2) adopts the more conservative Ahues & Tisseur stopping */
+/* criterion (LAWN 122, 1997). */
+
+/* ========================================================= */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+ if (*ilo == *ihi) {
+ i__1 = *ilo;
+ i__2 = *ilo + *ilo * h_dim1;
+ w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
+ return 0;
+ }
+
+/* ==== clear out the trash ==== */
+ i__1 = *ihi - 3;
+ for (j = *ilo; j <= i__1; ++j) {
+ i__2 = j + 2 + j * h_dim1;
+ h__[i__2].r = 0., h__[i__2].i = 0.;
+ i__2 = j + 3 + j * h_dim1;
+ h__[i__2].r = 0., h__[i__2].i = 0.;
+/* L10: */
+ }
+ if (*ilo <= *ihi - 2) {
+ i__1 = *ihi + (*ihi - 2) * h_dim1;
+ h__[i__1].r = 0., h__[i__1].i = 0.;
+ }
+/* ==== ensure that subdiagonal entries are real ==== */
+ if (*wantt) {
+ jlo = 1;
+ jhi = *n;
+ } else {
+ jlo = *ilo;
+ jhi = *ihi;
+ }
+ i__1 = *ihi;
+ for (i__ = *ilo + 1; i__ <= i__1; ++i__) {
+ if (d_imag(&h__[i__ + (i__ - 1) * h_dim1]) != 0.) {
+/* ==== The following redundant normalization */
+/* . avoids problems with both gradual and */
+/* . sudden underflow in ABS(H(I,I-1)) ==== */
+ i__2 = i__ + (i__ - 1) * h_dim1;
+ i__3 = i__ + (i__ - 1) * h_dim1;
+ d__3 = (d__1 = h__[i__3].r, abs(d__1)) + (d__2 = d_imag(&h__[i__
+ + (i__ - 1) * h_dim1]), abs(d__2));
+ z__1.r = h__[i__2].r / d__3, z__1.i = h__[i__2].i / d__3;
+ sc.r = z__1.r, sc.i = z__1.i;
+ d_cnjg(&z__2, &sc);
+ d__1 = z_abs(&sc);
+ z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
+ sc.r = z__1.r, sc.i = z__1.i;
+ i__2 = i__ + (i__ - 1) * h_dim1;
+ d__1 = z_abs(&h__[i__ + (i__ - 1) * h_dim1]);
+ h__[i__2].r = d__1, h__[i__2].i = 0.;
+ i__2 = jhi - i__ + 1;
+ zscal_(&i__2, &sc, &h__[i__ + i__ * h_dim1], ldh);
+/* Computing MIN */
+ i__3 = jhi, i__4 = i__ + 1;
+ i__2 = min(i__3,i__4) - jlo + 1;
+ d_cnjg(&z__1, &sc);
+ zscal_(&i__2, &z__1, &h__[jlo + i__ * h_dim1], &c__1);
+ if (*wantz) {
+ i__2 = *ihiz - *iloz + 1;
+ d_cnjg(&z__1, &sc);
+ zscal_(&i__2, &z__1, &z__[*iloz + i__ * z_dim1], &c__1);
+ }
+ }
+/* L20: */
+ }
+
+ nh = *ihi - *ilo + 1;
+ nz = *ihiz - *iloz + 1;
+
+/* Set machine-dependent constants for the stopping criterion. */
+
+ safmin = dlamch_("SAFE MINIMUM");
+ safmax = 1. / safmin;
+ dlabad_(&safmin, &safmax);
+ ulp = dlamch_("PRECISION");
+ smlnum = safmin * ((doublereal) nh / ulp);
+
+/* I1 and I2 are the indices of the first row and last column of H */
+/* to which transformations must be applied. If eigenvalues only are */
+/* being computed, I1 and I2 are set inside the main loop. */
+
+ if (*wantt) {
+ i1 = 1;
+ i2 = *n;
+ }
+
+/* The main loop begins here. I is the loop index and decreases from */
+/* IHI to ILO in steps of 1. Each iteration of the loop works */
+/* with the active submatrix in rows and columns L to I. */
+/* Eigenvalues I+1 to IHI have already converged. Either L = ILO, or */
+/* H(L,L-1) is negligible so that the matrix splits. */
+
+ i__ = *ihi;
+L30:
+ if (i__ < *ilo) {
+ goto L150;
+ }
+
+/* Perform QR iterations on rows and columns ILO to I until a */
+/* submatrix of order 1 splits off at the bottom because a */
+/* subdiagonal element has become negligible. */
+
+ l = *ilo;
+ for (its = 0; its <= 30; ++its) {
+
+/* Look for a single small subdiagonal element. */
+
+ i__1 = l + 1;
+ for (k = i__; k >= i__1; --k) {
+ i__2 = k + (k - 1) * h_dim1;
+ if ((d__1 = h__[i__2].r, abs(d__1)) + (d__2 = d_imag(&h__[k + (k
+ - 1) * h_dim1]), abs(d__2)) <= smlnum) {
+ goto L50;
+ }
+ i__2 = k - 1 + (k - 1) * h_dim1;
+ i__3 = k + k * h_dim1;
+ tst = (d__1 = h__[i__2].r, abs(d__1)) + (d__2 = d_imag(&h__[k - 1
+ + (k - 1) * h_dim1]), abs(d__2)) + ((d__3 = h__[i__3].r,
+ abs(d__3)) + (d__4 = d_imag(&h__[k + k * h_dim1]), abs(
+ d__4)));
+ if (tst == 0.) {
+ if (k - 2 >= *ilo) {
+ i__2 = k - 1 + (k - 2) * h_dim1;
+ tst += (d__1 = h__[i__2].r, abs(d__1));
+ }
+ if (k + 1 <= *ihi) {
+ i__2 = k + 1 + k * h_dim1;
+ tst += (d__1 = h__[i__2].r, abs(d__1));
+ }
+ }
+/* ==== The following is a conservative small subdiagonal */
+/* . deflation criterion due to Ahues & Tisseur (LAWN 122, */
+/* . 1997). It has better mathematical foundation and */
+/* . improves accuracy in some examples. ==== */
+ i__2 = k + (k - 1) * h_dim1;
+ if ((d__1 = h__[i__2].r, abs(d__1)) <= ulp * tst) {
+/* Computing MAX */
+ i__2 = k + (k - 1) * h_dim1;
+ i__3 = k - 1 + k * h_dim1;
+ d__5 = (d__1 = h__[i__2].r, abs(d__1)) + (d__2 = d_imag(&h__[
+ k + (k - 1) * h_dim1]), abs(d__2)), d__6 = (d__3 =
+ h__[i__3].r, abs(d__3)) + (d__4 = d_imag(&h__[k - 1 +
+ k * h_dim1]), abs(d__4));
+ ab = max(d__5,d__6);
+/* Computing MIN */
+ i__2 = k + (k - 1) * h_dim1;
+ i__3 = k - 1 + k * h_dim1;
+ d__5 = (d__1 = h__[i__2].r, abs(d__1)) + (d__2 = d_imag(&h__[
+ k + (k - 1) * h_dim1]), abs(d__2)), d__6 = (d__3 =
+ h__[i__3].r, abs(d__3)) + (d__4 = d_imag(&h__[k - 1 +
+ k * h_dim1]), abs(d__4));
+ ba = min(d__5,d__6);
+ i__2 = k - 1 + (k - 1) * h_dim1;
+ i__3 = k + k * h_dim1;
+ z__2.r = h__[i__2].r - h__[i__3].r, z__2.i = h__[i__2].i -
+ h__[i__3].i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+/* Computing MAX */
+ i__4 = k + k * h_dim1;
+ d__5 = (d__1 = h__[i__4].r, abs(d__1)) + (d__2 = d_imag(&h__[
+ k + k * h_dim1]), abs(d__2)), d__6 = (d__3 = z__1.r,
+ abs(d__3)) + (d__4 = d_imag(&z__1), abs(d__4));
+ aa = max(d__5,d__6);
+ i__2 = k - 1 + (k - 1) * h_dim1;
+ i__3 = k + k * h_dim1;
+ z__2.r = h__[i__2].r - h__[i__3].r, z__2.i = h__[i__2].i -
+ h__[i__3].i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+/* Computing MIN */
+ i__4 = k + k * h_dim1;
+ d__5 = (d__1 = h__[i__4].r, abs(d__1)) + (d__2 = d_imag(&h__[
+ k + k * h_dim1]), abs(d__2)), d__6 = (d__3 = z__1.r,
+ abs(d__3)) + (d__4 = d_imag(&z__1), abs(d__4));
+ bb = min(d__5,d__6);
+ s = aa + ab;
+/* Computing MAX */
+ d__1 = smlnum, d__2 = ulp * (bb * (aa / s));
+ if (ba * (ab / s) <= max(d__1,d__2)) {
+ goto L50;
+ }
+ }
+/* L40: */
+ }
+L50:
+ l = k;
+ if (l > *ilo) {
+
+/* H(L,L-1) is negligible */
+
+ i__1 = l + (l - 1) * h_dim1;
+ h__[i__1].r = 0., h__[i__1].i = 0.;
+ }
+
+/* Exit from loop if a submatrix of order 1 has split off. */
+
+ if (l >= i__) {
+ goto L140;
+ }
+
+/* Now the active submatrix is in rows and columns L to I. If */
+/* eigenvalues only are being computed, only the active submatrix */
+/* need be transformed. */
+
+ if (! (*wantt)) {
+ i1 = l;
+ i2 = i__;
+ }
+
+ if (its == 10) {
+
+/* Exceptional shift. */
+
+ i__1 = l + 1 + l * h_dim1;
+ s = (d__1 = h__[i__1].r, abs(d__1)) * .75;
+ i__1 = l + l * h_dim1;
+ z__1.r = s + h__[i__1].r, z__1.i = h__[i__1].i;
+ t.r = z__1.r, t.i = z__1.i;
+ } else if (its == 20) {
+
+/* Exceptional shift. */
+
+ i__1 = i__ + (i__ - 1) * h_dim1;
+ s = (d__1 = h__[i__1].r, abs(d__1)) * .75;
+ i__1 = i__ + i__ * h_dim1;
+ z__1.r = s + h__[i__1].r, z__1.i = h__[i__1].i;
+ t.r = z__1.r, t.i = z__1.i;
+ } else {
+
+/* Wilkinson's shift. */
+
+ i__1 = i__ + i__ * h_dim1;
+ t.r = h__[i__1].r, t.i = h__[i__1].i;
+ z_sqrt(&z__2, &h__[i__ - 1 + i__ * h_dim1]);
+ z_sqrt(&z__3, &h__[i__ + (i__ - 1) * h_dim1]);
+ z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r *
+ z__3.i + z__2.i * z__3.r;
+ u.r = z__1.r, u.i = z__1.i;
+ s = (d__1 = u.r, abs(d__1)) + (d__2 = d_imag(&u), abs(d__2));
+ if (s != 0.) {
+ i__1 = i__ - 1 + (i__ - 1) * h_dim1;
+ z__2.r = h__[i__1].r - t.r, z__2.i = h__[i__1].i - t.i;
+ z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
+ x.r = z__1.r, x.i = z__1.i;
+ sx = (d__1 = x.r, abs(d__1)) + (d__2 = d_imag(&x), abs(d__2));
+/* Computing MAX */
+ d__3 = s, d__4 = (d__1 = x.r, abs(d__1)) + (d__2 = d_imag(&x),
+ abs(d__2));
+ s = max(d__3,d__4);
+ z__5.r = x.r / s, z__5.i = x.i / s;
+ pow_zi(&z__4, &z__5, &c__2);
+ z__7.r = u.r / s, z__7.i = u.i / s;
+ pow_zi(&z__6, &z__7, &c__2);
+ z__3.r = z__4.r + z__6.r, z__3.i = z__4.i + z__6.i;
+ z_sqrt(&z__2, &z__3);
+ z__1.r = s * z__2.r, z__1.i = s * z__2.i;
+ y.r = z__1.r, y.i = z__1.i;
+ if (sx > 0.) {
+ z__1.r = x.r / sx, z__1.i = x.i / sx;
+ z__2.r = x.r / sx, z__2.i = x.i / sx;
+ if (z__1.r * y.r + d_imag(&z__2) * d_imag(&y) < 0.) {
+ z__3.r = -y.r, z__3.i = -y.i;
+ y.r = z__3.r, y.i = z__3.i;
+ }
+ }
+ z__4.r = x.r + y.r, z__4.i = x.i + y.i;
+ zladiv_(&z__3, &u, &z__4);
+ z__2.r = u.r * z__3.r - u.i * z__3.i, z__2.i = u.r * z__3.i +
+ u.i * z__3.r;
+ z__1.r = t.r - z__2.r, z__1.i = t.i - z__2.i;
+ t.r = z__1.r, t.i = z__1.i;
+ }
+ }
+
+/* Look for two consecutive small subdiagonal elements. */
+
+ i__1 = l + 1;
+ for (m = i__ - 1; m >= i__1; --m) {
+
+/* Determine the effect of starting the single-shift QR */
+/* iteration at row M, and see if this would make H(M,M-1) */
+/* negligible. */
+
+ i__2 = m + m * h_dim1;
+ h11.r = h__[i__2].r, h11.i = h__[i__2].i;
+ i__2 = m + 1 + (m + 1) * h_dim1;
+ h22.r = h__[i__2].r, h22.i = h__[i__2].i;
+ z__1.r = h11.r - t.r, z__1.i = h11.i - t.i;
+ h11s.r = z__1.r, h11s.i = z__1.i;
+ i__2 = m + 1 + m * h_dim1;
+ h21 = h__[i__2].r;
+ s = (d__1 = h11s.r, abs(d__1)) + (d__2 = d_imag(&h11s), abs(d__2))
+ + abs(h21);
+ z__1.r = h11s.r / s, z__1.i = h11s.i / s;
+ h11s.r = z__1.r, h11s.i = z__1.i;
+ h21 /= s;
+ v[0].r = h11s.r, v[0].i = h11s.i;
+ v[1].r = h21, v[1].i = 0.;
+ i__2 = m + (m - 1) * h_dim1;
+ h10 = h__[i__2].r;
+ if (abs(h10) * abs(h21) <= ulp * (((d__1 = h11s.r, abs(d__1)) + (
+ d__2 = d_imag(&h11s), abs(d__2))) * ((d__3 = h11.r, abs(
+ d__3)) + (d__4 = d_imag(&h11), abs(d__4)) + ((d__5 =
+ h22.r, abs(d__5)) + (d__6 = d_imag(&h22), abs(d__6)))))) {
+ goto L70;
+ }
+/* L60: */
+ }
+ i__1 = l + l * h_dim1;
+ h11.r = h__[i__1].r, h11.i = h__[i__1].i;
+ i__1 = l + 1 + (l + 1) * h_dim1;
+ h22.r = h__[i__1].r, h22.i = h__[i__1].i;
+ z__1.r = h11.r - t.r, z__1.i = h11.i - t.i;
+ h11s.r = z__1.r, h11s.i = z__1.i;
+ i__1 = l + 1 + l * h_dim1;
+ h21 = h__[i__1].r;
+ s = (d__1 = h11s.r, abs(d__1)) + (d__2 = d_imag(&h11s), abs(d__2)) +
+ abs(h21);
+ z__1.r = h11s.r / s, z__1.i = h11s.i / s;
+ h11s.r = z__1.r, h11s.i = z__1.i;
+ h21 /= s;
+ v[0].r = h11s.r, v[0].i = h11s.i;
+ v[1].r = h21, v[1].i = 0.;
+L70:
+
+/* Single-shift QR step */
+
+ i__1 = i__ - 1;
+ for (k = m; k <= i__1; ++k) {
+
+/* The first iteration of this loop determines a reflection G */
+/* from the vector V and applies it from left and right to H, */
+/* thus creating a nonzero bulge below the subdiagonal. */
+
+/* Each subsequent iteration determines a reflection G to */
+/* restore the Hessenberg form in the (K-1)th column, and thus */
+/* chases the bulge one step toward the bottom of the active */
+/* submatrix. */
+
+/* V(2) is always real before the call to ZLARFG, and hence */
+/* after the call T2 ( = T1*V(2) ) is also real. */
+
+ if (k > m) {
+ zcopy_(&c__2, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
+ }
+ zlarfg_(&c__2, v, &v[1], &c__1, &t1);
+ if (k > m) {
+ i__2 = k + (k - 1) * h_dim1;
+ h__[i__2].r = v[0].r, h__[i__2].i = v[0].i;
+ i__2 = k + 1 + (k - 1) * h_dim1;
+ h__[i__2].r = 0., h__[i__2].i = 0.;
+ }
+ v2.r = v[1].r, v2.i = v[1].i;
+ z__1.r = t1.r * v2.r - t1.i * v2.i, z__1.i = t1.r * v2.i + t1.i *
+ v2.r;
+ t2 = z__1.r;
+
+/* Apply G from the left to transform the rows of the matrix */
+/* in columns K to I2. */
+
+ i__2 = i2;
+ for (j = k; j <= i__2; ++j) {
+ d_cnjg(&z__3, &t1);
+ i__3 = k + j * h_dim1;
+ z__2.r = z__3.r * h__[i__3].r - z__3.i * h__[i__3].i, z__2.i =
+ z__3.r * h__[i__3].i + z__3.i * h__[i__3].r;
+ i__4 = k + 1 + j * h_dim1;
+ z__4.r = t2 * h__[i__4].r, z__4.i = t2 * h__[i__4].i;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ sum.r = z__1.r, sum.i = z__1.i;
+ i__3 = k + j * h_dim1;
+ i__4 = k + j * h_dim1;
+ z__1.r = h__[i__4].r - sum.r, z__1.i = h__[i__4].i - sum.i;
+ h__[i__3].r = z__1.r, h__[i__3].i = z__1.i;
+ i__3 = k + 1 + j * h_dim1;
+ i__4 = k + 1 + j * h_dim1;
+ z__2.r = sum.r * v2.r - sum.i * v2.i, z__2.i = sum.r * v2.i +
+ sum.i * v2.r;
+ z__1.r = h__[i__4].r - z__2.r, z__1.i = h__[i__4].i - z__2.i;
+ h__[i__3].r = z__1.r, h__[i__3].i = z__1.i;
+/* L80: */
+ }
+
+/* Apply G from the right to transform the columns of the */
+/* matrix in rows I1 to min(K+2,I). */
+
+/* Computing MIN */
+ i__3 = k + 2;
+ i__2 = min(i__3,i__);
+ for (j = i1; j <= i__2; ++j) {
+ i__3 = j + k * h_dim1;
+ z__2.r = t1.r * h__[i__3].r - t1.i * h__[i__3].i, z__2.i =
+ t1.r * h__[i__3].i + t1.i * h__[i__3].r;
+ i__4 = j + (k + 1) * h_dim1;
+ z__3.r = t2 * h__[i__4].r, z__3.i = t2 * h__[i__4].i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ sum.r = z__1.r, sum.i = z__1.i;
+ i__3 = j + k * h_dim1;
+ i__4 = j + k * h_dim1;
+ z__1.r = h__[i__4].r - sum.r, z__1.i = h__[i__4].i - sum.i;
+ h__[i__3].r = z__1.r, h__[i__3].i = z__1.i;
+ i__3 = j + (k + 1) * h_dim1;
+ i__4 = j + (k + 1) * h_dim1;
+ d_cnjg(&z__3, &v2);
+ z__2.r = sum.r * z__3.r - sum.i * z__3.i, z__2.i = sum.r *
+ z__3.i + sum.i * z__3.r;
+ z__1.r = h__[i__4].r - z__2.r, z__1.i = h__[i__4].i - z__2.i;
+ h__[i__3].r = z__1.r, h__[i__3].i = z__1.i;
+/* L90: */
+ }
+
+ if (*wantz) {
+
+/* Accumulate transformations in the matrix Z */
+
+ i__2 = *ihiz;
+ for (j = *iloz; j <= i__2; ++j) {
+ i__3 = j + k * z_dim1;
+ z__2.r = t1.r * z__[i__3].r - t1.i * z__[i__3].i, z__2.i =
+ t1.r * z__[i__3].i + t1.i * z__[i__3].r;
+ i__4 = j + (k + 1) * z_dim1;
+ z__3.r = t2 * z__[i__4].r, z__3.i = t2 * z__[i__4].i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ sum.r = z__1.r, sum.i = z__1.i;
+ i__3 = j + k * z_dim1;
+ i__4 = j + k * z_dim1;
+ z__1.r = z__[i__4].r - sum.r, z__1.i = z__[i__4].i -
+ sum.i;
+ z__[i__3].r = z__1.r, z__[i__3].i = z__1.i;
+ i__3 = j + (k + 1) * z_dim1;
+ i__4 = j + (k + 1) * z_dim1;
+ d_cnjg(&z__3, &v2);
+ z__2.r = sum.r * z__3.r - sum.i * z__3.i, z__2.i = sum.r *
+ z__3.i + sum.i * z__3.r;
+ z__1.r = z__[i__4].r - z__2.r, z__1.i = z__[i__4].i -
+ z__2.i;
+ z__[i__3].r = z__1.r, z__[i__3].i = z__1.i;
+/* L100: */
+ }
+ }
+
+ if (k == m && m > l) {
+
+/* If the QR step was started at row M > L because two */
+/* consecutive small subdiagonals were found, then extra */
+/* scaling must be performed to ensure that H(M,M-1) remains */
+/* real. */
+
+ z__1.r = 1. - t1.r, z__1.i = 0. - t1.i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ d__1 = z_abs(&temp);
+ z__1.r = temp.r / d__1, z__1.i = temp.i / d__1;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__2 = m + 1 + m * h_dim1;
+ i__3 = m + 1 + m * h_dim1;
+ d_cnjg(&z__2, &temp);
+ z__1.r = h__[i__3].r * z__2.r - h__[i__3].i * z__2.i, z__1.i =
+ h__[i__3].r * z__2.i + h__[i__3].i * z__2.r;
+ h__[i__2].r = z__1.r, h__[i__2].i = z__1.i;
+ if (m + 2 <= i__) {
+ i__2 = m + 2 + (m + 1) * h_dim1;
+ i__3 = m + 2 + (m + 1) * h_dim1;
+ z__1.r = h__[i__3].r * temp.r - h__[i__3].i * temp.i,
+ z__1.i = h__[i__3].r * temp.i + h__[i__3].i *
+ temp.r;
+ h__[i__2].r = z__1.r, h__[i__2].i = z__1.i;
+ }
+ i__2 = i__;
+ for (j = m; j <= i__2; ++j) {
+ if (j != m + 1) {
+ if (i2 > j) {
+ i__3 = i2 - j;
+ zscal_(&i__3, &temp, &h__[j + (j + 1) * h_dim1],
+ ldh);
+ }
+ i__3 = j - i1;
+ d_cnjg(&z__1, &temp);
+ zscal_(&i__3, &z__1, &h__[i1 + j * h_dim1], &c__1);
+ if (*wantz) {
+ d_cnjg(&z__1, &temp);
+ zscal_(&nz, &z__1, &z__[*iloz + j * z_dim1], &
+ c__1);
+ }
+ }
+/* L110: */
+ }
+ }
+/* L120: */
+ }
+
+/* Ensure that H(I,I-1) is real. */
+
+ i__1 = i__ + (i__ - 1) * h_dim1;
+ temp.r = h__[i__1].r, temp.i = h__[i__1].i;
+ if (d_imag(&temp) != 0.) {
+ rtemp = z_abs(&temp);
+ i__1 = i__ + (i__ - 1) * h_dim1;
+ h__[i__1].r = rtemp, h__[i__1].i = 0.;
+ z__1.r = temp.r / rtemp, z__1.i = temp.i / rtemp;
+ temp.r = z__1.r, temp.i = z__1.i;
+ if (i2 > i__) {
+ i__1 = i2 - i__;
+ d_cnjg(&z__1, &temp);
+ zscal_(&i__1, &z__1, &h__[i__ + (i__ + 1) * h_dim1], ldh);
+ }
+ i__1 = i__ - i1;
+ zscal_(&i__1, &temp, &h__[i1 + i__ * h_dim1], &c__1);
+ if (*wantz) {
+ zscal_(&nz, &temp, &z__[*iloz + i__ * z_dim1], &c__1);
+ }
+ }
+
+/* L130: */
+ }
+
+/* Failure to converge in remaining number of iterations */
+
+ *info = i__;
+ return 0;
+
+L140:
+
+/* H(I,I-1) is negligible: one eigenvalue has converged. */
+
+ i__1 = i__;
+ i__2 = i__ + i__ * h_dim1;
+ w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
+
+/* return to start of the main loop with new value of I. */
+
+ i__ = l - 1;
+ goto L30;
+
+L150:
+ return 0;
+
+/* End of ZLAHQR */
+
+} /* zlahqr_ */
diff --git a/SRC/zlahr2.c b/SRC/zlahr2.c
new file mode 100644
index 0000000..761a5f6
--- /dev/null
+++ b/SRC/zlahr2.c
@@ -0,0 +1,331 @@
+/* zlahr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zlahr2_(integer *n, integer *k, integer *nb,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *t,
+ integer *ldt, doublecomplex *y, integer *ldy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
+ i__3;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__;
+ doublecomplex ei;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zgemm_(char *, char *, integer *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), ztrmm_(char *, char *, char *, char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *), ztrmv_(char *, char *, char *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlarfg_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *), zlacgv_(integer *,
+ doublecomplex *, integer *), zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1) */
+/* matrix A so that elements below the k-th subdiagonal are zero. The */
+/* reduction is performed by an unitary similarity transformation */
+/* Q' * A * Q. The routine returns the matrices V and T which determine */
+/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */
+
+/* This is an auxiliary routine called by ZGEHRD. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* K (input) INTEGER */
+/* The offset for the reduction. Elements below the k-th */
+/* subdiagonal in the first NB columns are reduced to zero. */
+/* K < N. */
+
+/* NB (input) INTEGER */
+/* The number of columns to be reduced. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N-K+1) */
+/* On entry, the n-by-(n-k+1) general matrix A. */
+/* On exit, the elements on and above the k-th subdiagonal in */
+/* the first NB columns are overwritten with the corresponding */
+/* elements of the reduced matrix; the elements below the k-th */
+/* subdiagonal, with the array TAU, represent the matrix Q as a */
+/* product of elementary reflectors. The other columns of A are */
+/* unchanged. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAU (output) COMPLEX*16 array, dimension (NB) */
+/* The scalar factors of the elementary reflectors. See Further */
+/* Details. */
+
+/* T (output) COMPLEX*16 array, dimension (LDT,NB) */
+/* The upper triangular matrix T. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= NB. */
+
+/* Y (output) COMPLEX*16 array, dimension (LDY,NB) */
+/* The n-by-nb matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= N. */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of nb elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(nb). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
+/* A(i+k+1:n,i), and tau in TAU(i). */
+
+/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */
+/* V which is needed, with T and Y, to apply the transformation to the */
+/* unreduced part of the matrix, using an update of the form: */
+/* A := (I - V*T*V') * (A - Y*V'). */
+
+/* The contents of A on exit are illustrated by the following example */
+/* with n = 7, k = 3 and nb = 2: */
+
+/* ( a a a a a ) */
+/* ( a a a a a ) */
+/* ( a a a a a ) */
+/* ( h h a a a ) */
+/* ( v1 h a a a ) */
+/* ( v1 v2 a a a ) */
+/* ( v1 v2 a a a ) */
+
+/* where a denotes an element of the original matrix A, h denotes a */
+/* modified element of the upper Hessenberg matrix H, and vi denotes an */
+/* element of the vector defining H(i). */
+
+/* This file is a slight modification of LAPACK-3.0's ZLAHRD */
+/* incorporating improvements proposed by Quintana-Orti and Van de */
+/* Gejin. Note that the entries of A(1:K,2:NB) differ from those */
+/* returned by the original LAPACK routine. This function is */
+/* not backward compatible with LAPACK3.0. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --tau;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+
+ /* Function Body */
+ if (*n <= 1) {
+ return 0;
+ }
+
+ i__1 = *nb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (i__ > 1) {
+
+/* Update A(K+1:N,I) */
+
+/* Update I-th column of A - Y * V' */
+
+ i__2 = i__ - 1;
+ zlacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
+ i__2 = *n - *k;
+ i__3 = i__ - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("NO TRANSPOSE", &i__2, &i__3, &z__1, &y[*k + 1 + y_dim1],
+ ldy, &a[*k + i__ - 1 + a_dim1], lda, &c_b2, &a[*k + 1 +
+ i__ * a_dim1], &c__1);
+ i__2 = i__ - 1;
+ zlacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
+
+/* Apply I - V * T' * V' to this column (call it b) from the */
+/* left, using the last column of T as workspace */
+
+/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */
+/* ( V2 ) ( b2 ) */
+
+/* where V1 is unit lower triangular */
+
+/* w := V1' * b1 */
+
+ i__2 = i__ - 1;
+ zcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 +
+ 1], &c__1);
+ i__2 = i__ - 1;
+ ztrmv_("Lower", "Conjugate transpose", "UNIT", &i__2, &a[*k + 1 +
+ a_dim1], lda, &t[*nb * t_dim1 + 1], &c__1);
+
+/* w := w + V2'*b2 */
+
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ +
+ a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b2, &
+ t[*nb * t_dim1 + 1], &c__1);
+
+/* w := T'*w */
+
+ i__2 = i__ - 1;
+ ztrmv_("Upper", "Conjugate transpose", "NON-UNIT", &i__2, &t[
+ t_offset], ldt, &t[*nb * t_dim1 + 1], &c__1);
+
+/* b2 := b2 - V2*w */
+
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("NO TRANSPOSE", &i__2, &i__3, &z__1, &a[*k + i__ + a_dim1],
+ lda, &t[*nb * t_dim1 + 1], &c__1, &c_b2, &a[*k + i__ +
+ i__ * a_dim1], &c__1);
+
+/* b1 := b1 - V1*w */
+
+ i__2 = i__ - 1;
+ ztrmv_("Lower", "NO TRANSPOSE", "UNIT", &i__2, &a[*k + 1 + a_dim1]
+, lda, &t[*nb * t_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zaxpy_(&i__2, &z__1, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__
+ * a_dim1], &c__1);
+
+ i__2 = *k + i__ - 1 + (i__ - 1) * a_dim1;
+ a[i__2].r = ei.r, a[i__2].i = ei.i;
+ }
+
+/* Generate the elementary reflector H(I) to annihilate */
+/* A(K+I+1:N,I) */
+
+ i__2 = *n - *k - i__ + 1;
+/* Computing MIN */
+ i__3 = *k + i__ + 1;
+ zlarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[min(i__3, *n)+ i__ *
+ a_dim1], &c__1, &tau[i__]);
+ i__2 = *k + i__ + i__ * a_dim1;
+ ei.r = a[i__2].r, ei.i = a[i__2].i;
+ i__2 = *k + i__ + i__ * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+
+/* Compute Y(K+1:N,I) */
+
+ i__2 = *n - *k;
+ i__3 = *n - *k - i__ + 1;
+ zgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b2, &a[*k + 1 + (i__ + 1) *
+ a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &y[*
+ k + 1 + i__ * y_dim1], &c__1);
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ +
+ a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &t[
+ i__ * t_dim1 + 1], &c__1);
+ i__2 = *n - *k;
+ i__3 = i__ - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("NO TRANSPOSE", &i__2, &i__3, &z__1, &y[*k + 1 + y_dim1], ldy,
+ &t[i__ * t_dim1 + 1], &c__1, &c_b2, &y[*k + 1 + i__ * y_dim1],
+ &c__1);
+ i__2 = *n - *k;
+ zscal_(&i__2, &tau[i__], &y[*k + 1 + i__ * y_dim1], &c__1);
+
+/* Compute T(1:I,I) */
+
+ i__2 = i__ - 1;
+ i__3 = i__;
+ z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i;
+ zscal_(&i__2, &z__1, &t[i__ * t_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ ztrmv_("Upper", "No Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt,
+ &t[i__ * t_dim1 + 1], &c__1)
+ ;
+ i__2 = i__ + i__ * t_dim1;
+ i__3 = i__;
+ t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i;
+
+/* L10: */
+ }
+ i__1 = *k + *nb + *nb * a_dim1;
+ a[i__1].r = ei.r, a[i__1].i = ei.i;
+
+/* Compute Y(1:K,1:NB) */
+
+ zlacpy_("ALL", k, nb, &a[(a_dim1 << 1) + 1], lda, &y[y_offset], ldy);
+ ztrmm_("RIGHT", "Lower", "NO TRANSPOSE", "UNIT", k, nb, &c_b2, &a[*k + 1
+ + a_dim1], lda, &y[y_offset], ldy);
+ if (*n > *k + *nb) {
+ i__1 = *n - *k - *nb;
+ zgemm_("NO TRANSPOSE", "NO TRANSPOSE", k, nb, &i__1, &c_b2, &a[(*nb +
+ 2) * a_dim1 + 1], lda, &a[*k + 1 + *nb + a_dim1], lda, &c_b2,
+ &y[y_offset], ldy);
+ }
+ ztrmm_("RIGHT", "Upper", "NO TRANSPOSE", "NON-UNIT", k, nb, &c_b2, &t[
+ t_offset], ldt, &y[y_offset], ldy);
+
+ return 0;
+
+/* End of ZLAHR2 */
+
+} /* zlahr2_ */
diff --git a/SRC/zlahrd.c b/SRC/zlahrd.c
new file mode 100644
index 0000000..b5a8f6f
--- /dev/null
+++ b/SRC/zlahrd.c
@@ -0,0 +1,301 @@
+/* zlahrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zlahrd_(integer *n, integer *k, integer *nb,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *t,
+ integer *ldt, doublecomplex *y, integer *ldy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
+ i__3;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__;
+ doublecomplex ei;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *), ztrmv_(char *, char *,
+ char *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zlarfg_(integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *),
+ zlacgv_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAHRD reduces the first NB columns of a complex general n-by-(n-k+1) */
+/* matrix A so that elements below the k-th subdiagonal are zero. The */
+/* reduction is performed by a unitary similarity transformation */
+/* Q' * A * Q. The routine returns the matrices V and T which determine */
+/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */
+
+/* This is an OBSOLETE auxiliary routine. */
+/* This routine will be 'deprecated' in a future release. */
+/* Please use the new routine ZLAHR2 instead. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* K (input) INTEGER */
+/* The offset for the reduction. Elements below the k-th */
+/* subdiagonal in the first NB columns are reduced to zero. */
+
+/* NB (input) INTEGER */
+/* The number of columns to be reduced. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N-K+1) */
+/* On entry, the n-by-(n-k+1) general matrix A. */
+/* On exit, the elements on and above the k-th subdiagonal in */
+/* the first NB columns are overwritten with the corresponding */
+/* elements of the reduced matrix; the elements below the k-th */
+/* subdiagonal, with the array TAU, represent the matrix Q as a */
+/* product of elementary reflectors. The other columns of A are */
+/* unchanged. See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAU (output) COMPLEX*16 array, dimension (NB) */
+/* The scalar factors of the elementary reflectors. See Further */
+/* Details. */
+
+/* T (output) COMPLEX*16 array, dimension (LDT,NB) */
+/* The upper triangular matrix T. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= NB. */
+
+/* Y (output) COMPLEX*16 array, dimension (LDY,NB) */
+/* The n-by-nb matrix Y. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of the array Y. LDY >= max(1,N). */
+
+/* Further Details */
+/* =============== */
+
+/* The matrix Q is represented as a product of nb elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(nb). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
+/* A(i+k+1:n,i), and tau in TAU(i). */
+
+/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */
+/* V which is needed, with T and Y, to apply the transformation to the */
+/* unreduced part of the matrix, using an update of the form: */
+/* A := (I - V*T*V') * (A - Y*V'). */
+
+/* The contents of A on exit are illustrated by the following example */
+/* with n = 7, k = 3 and nb = 2: */
+
+/* ( a h a a a ) */
+/* ( a h a a a ) */
+/* ( a h a a a ) */
+/* ( h h a a a ) */
+/* ( v1 h a a a ) */
+/* ( v1 v2 a a a ) */
+/* ( v1 v2 a a a ) */
+
+/* where a denotes an element of the original matrix A, h denotes a */
+/* modified element of the upper Hessenberg matrix H, and vi denotes an */
+/* element of the vector defining H(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --tau;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+
+ /* Function Body */
+ if (*n <= 1) {
+ return 0;
+ }
+
+ i__1 = *nb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (i__ > 1) {
+
+/* Update A(1:n,i) */
+
+/* Compute i-th column of A - Y * V' */
+
+ i__2 = i__ - 1;
+ zlacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
+ i__2 = i__ - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", n, &i__2, &z__1, &y[y_offset], ldy, &a[*k
+ + i__ - 1 + a_dim1], lda, &c_b2, &a[i__ * a_dim1 + 1], &
+ c__1);
+ i__2 = i__ - 1;
+ zlacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
+
+/* Apply I - V * T' * V' to this column (call it b) from the */
+/* left, using the last column of T as workspace */
+
+/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */
+/* ( V2 ) ( b2 ) */
+
+/* where V1 is unit lower triangular */
+
+/* w := V1' * b1 */
+
+ i__2 = i__ - 1;
+ zcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 +
+ 1], &c__1);
+ i__2 = i__ - 1;
+ ztrmv_("Lower", "Conjugate transpose", "Unit", &i__2, &a[*k + 1 +
+ a_dim1], lda, &t[*nb * t_dim1 + 1], &c__1);
+
+/* w := w + V2'*b2 */
+
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ +
+ a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b2, &
+ t[*nb * t_dim1 + 1], &c__1);
+
+/* w := T'*w */
+
+ i__2 = i__ - 1;
+ ztrmv_("Upper", "Conjugate transpose", "Non-unit", &i__2, &t[
+ t_offset], ldt, &t[*nb * t_dim1 + 1], &c__1);
+
+/* b2 := b2 - V2*w */
+
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__2, &i__3, &z__1, &a[*k + i__ + a_dim1],
+ lda, &t[*nb * t_dim1 + 1], &c__1, &c_b2, &a[*k + i__ +
+ i__ * a_dim1], &c__1);
+
+/* b1 := b1 - V1*w */
+
+ i__2 = i__ - 1;
+ ztrmv_("Lower", "No transpose", "Unit", &i__2, &a[*k + 1 + a_dim1]
+, lda, &t[*nb * t_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zaxpy_(&i__2, &z__1, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__
+ * a_dim1], &c__1);
+
+ i__2 = *k + i__ - 1 + (i__ - 1) * a_dim1;
+ a[i__2].r = ei.r, a[i__2].i = ei.i;
+ }
+
+/* Generate the elementary reflector H(i) to annihilate */
+/* A(k+i+1:n,i) */
+
+ i__2 = *k + i__ + i__ * a_dim1;
+ ei.r = a[i__2].r, ei.i = a[i__2].i;
+ i__2 = *n - *k - i__ + 1;
+/* Computing MIN */
+ i__3 = *k + i__ + 1;
+ zlarfg_(&i__2, &ei, &a[min(i__3, *n)+ i__ * a_dim1], &c__1, &tau[i__])
+ ;
+ i__2 = *k + i__ + i__ * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+
+/* Compute Y(1:n,i) */
+
+ i__2 = *n - *k - i__ + 1;
+ zgemv_("No transpose", n, &i__2, &c_b2, &a[(i__ + 1) * a_dim1 + 1],
+ lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &y[i__ *
+ y_dim1 + 1], &c__1);
+ i__2 = *n - *k - i__ + 1;
+ i__3 = i__ - 1;
+ zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ +
+ a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &t[
+ i__ * t_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", n, &i__2, &z__1, &y[y_offset], ldy, &t[i__ *
+ t_dim1 + 1], &c__1, &c_b2, &y[i__ * y_dim1 + 1], &c__1);
+ zscal_(n, &tau[i__], &y[i__ * y_dim1 + 1], &c__1);
+
+/* Compute T(1:i,i) */
+
+ i__2 = i__ - 1;
+ i__3 = i__;
+ z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i;
+ zscal_(&i__2, &z__1, &t[i__ * t_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ ztrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt,
+ &t[i__ * t_dim1 + 1], &c__1)
+ ;
+ i__2 = i__ + i__ * t_dim1;
+ i__3 = i__;
+ t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i;
+
+/* L10: */
+ }
+ i__1 = *k + *nb + *nb * a_dim1;
+ a[i__1].r = ei.r, a[i__1].i = ei.i;
+
+ return 0;
+
+/* End of ZLAHRD */
+
+} /* zlahrd_ */
diff --git a/SRC/zlaic1.c b/SRC/zlaic1.c
new file mode 100644
index 0000000..4312ffe
--- /dev/null
+++ b/SRC/zlaic1.c
@@ -0,0 +1,451 @@
+/* zlaic1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zlaic1_(integer *job, integer *j, doublecomplex *x,
+ doublereal *sest, doublecomplex *w, doublecomplex *gamma, doublereal *
+ sestpr, doublecomplex *s, doublecomplex *c__)
+{
+ /* System generated locals */
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *), z_sqrt(doublecomplex *,
+ doublecomplex *);
+ double sqrt(doublereal);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ doublereal b, t, s1, s2, scl, eps, tmp;
+ doublecomplex sine;
+ doublereal test, zeta1, zeta2;
+ doublecomplex alpha;
+ doublereal norma;
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal absgam, absalp;
+ doublecomplex cosine;
+ doublereal absest;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAIC1 applies one step of incremental condition estimation in */
+/* its simplest version: */
+
+/* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j */
+/* lower triangular matrix L, such that */
+/* twonorm(L*x) = sest */
+/* Then ZLAIC1 computes sestpr, s, c such that */
+/* the vector */
+/* [ s*x ] */
+/* xhat = [ c ] */
+/* is an approximate singular vector of */
+/* [ L 0 ] */
+/* Lhat = [ w' gamma ] */
+/* in the sense that */
+/* twonorm(Lhat*xhat) = sestpr. */
+
+/* Depending on JOB, an estimate for the largest or smallest singular */
+/* value is computed. */
+
+/* Note that [s c]' and sestpr**2 is an eigenpair of the system */
+
+/* diag(sest*sest, 0) + [alpha gamma] * [ conjg(alpha) ] */
+/* [ conjg(gamma) ] */
+
+/* where alpha = conjg(x)'*w. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) INTEGER */
+/* = 1: an estimate for the largest singular value is computed. */
+/* = 2: an estimate for the smallest singular value is computed. */
+
+/* J (input) INTEGER */
+/* Length of X and W */
+
+/* X (input) COMPLEX*16 array, dimension (J) */
+/* The j-vector x. */
+
+/* SEST (input) DOUBLE PRECISION */
+/* Estimated singular value of j by j matrix L */
+
+/* W (input) COMPLEX*16 array, dimension (J) */
+/* The j-vector w. */
+
+/* GAMMA (input) COMPLEX*16 */
+/* The diagonal element gamma. */
+
+/* SESTPR (output) DOUBLE PRECISION */
+/* Estimated singular value of (j+1) by (j+1) matrix Lhat. */
+
+/* S (output) COMPLEX*16 */
+/* Sine needed in forming xhat. */
+
+/* C (output) COMPLEX*16 */
+/* Cosine needed in forming xhat. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --w;
+ --x;
+
+ /* Function Body */
+ eps = dlamch_("Epsilon");
+ zdotc_(&z__1, j, &x[1], &c__1, &w[1], &c__1);
+ alpha.r = z__1.r, alpha.i = z__1.i;
+
+ absalp = z_abs(&alpha);
+ absgam = z_abs(gamma);
+ absest = abs(*sest);
+
+ if (*job == 1) {
+
+/* Estimating largest singular value */
+
+/* special cases */
+
+ if (*sest == 0.) {
+ s1 = max(absgam,absalp);
+ if (s1 == 0.) {
+ s->r = 0., s->i = 0.;
+ c__->r = 1., c__->i = 0.;
+ *sestpr = 0.;
+ } else {
+ z__1.r = alpha.r / s1, z__1.i = alpha.i / s1;
+ s->r = z__1.r, s->i = z__1.i;
+ z__1.r = gamma->r / s1, z__1.i = gamma->i / s1;
+ c__->r = z__1.r, c__->i = z__1.i;
+ d_cnjg(&z__4, s);
+ z__3.r = s->r * z__4.r - s->i * z__4.i, z__3.i = s->r *
+ z__4.i + s->i * z__4.r;
+ d_cnjg(&z__6, c__);
+ z__5.r = c__->r * z__6.r - c__->i * z__6.i, z__5.i = c__->r *
+ z__6.i + c__->i * z__6.r;
+ z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
+ z_sqrt(&z__1, &z__2);
+ tmp = z__1.r;
+ z__1.r = s->r / tmp, z__1.i = s->i / tmp;
+ s->r = z__1.r, s->i = z__1.i;
+ z__1.r = c__->r / tmp, z__1.i = c__->i / tmp;
+ c__->r = z__1.r, c__->i = z__1.i;
+ *sestpr = s1 * tmp;
+ }
+ return 0;
+ } else if (absgam <= eps * absest) {
+ s->r = 1., s->i = 0.;
+ c__->r = 0., c__->i = 0.;
+ tmp = max(absest,absalp);
+ s1 = absest / tmp;
+ s2 = absalp / tmp;
+ *sestpr = tmp * sqrt(s1 * s1 + s2 * s2);
+ return 0;
+ } else if (absalp <= eps * absest) {
+ s1 = absgam;
+ s2 = absest;
+ if (s1 <= s2) {
+ s->r = 1., s->i = 0.;
+ c__->r = 0., c__->i = 0.;
+ *sestpr = s2;
+ } else {
+ s->r = 0., s->i = 0.;
+ c__->r = 1., c__->i = 0.;
+ *sestpr = s1;
+ }
+ return 0;
+ } else if (absest <= eps * absalp || absest <= eps * absgam) {
+ s1 = absgam;
+ s2 = absalp;
+ if (s1 <= s2) {
+ tmp = s1 / s2;
+ scl = sqrt(tmp * tmp + 1.);
+ *sestpr = s2 * scl;
+ z__2.r = alpha.r / s2, z__2.i = alpha.i / s2;
+ z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
+ s->r = z__1.r, s->i = z__1.i;
+ z__2.r = gamma->r / s2, z__2.i = gamma->i / s2;
+ z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
+ c__->r = z__1.r, c__->i = z__1.i;
+ } else {
+ tmp = s2 / s1;
+ scl = sqrt(tmp * tmp + 1.);
+ *sestpr = s1 * scl;
+ z__2.r = alpha.r / s1, z__2.i = alpha.i / s1;
+ z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
+ s->r = z__1.r, s->i = z__1.i;
+ z__2.r = gamma->r / s1, z__2.i = gamma->i / s1;
+ z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
+ c__->r = z__1.r, c__->i = z__1.i;
+ }
+ return 0;
+ } else {
+
+/* normal case */
+
+ zeta1 = absalp / absest;
+ zeta2 = absgam / absest;
+
+ b = (1. - zeta1 * zeta1 - zeta2 * zeta2) * .5;
+ d__1 = zeta1 * zeta1;
+ c__->r = d__1, c__->i = 0.;
+ if (b > 0.) {
+ d__1 = b * b;
+ z__4.r = d__1 + c__->r, z__4.i = c__->i;
+ z_sqrt(&z__3, &z__4);
+ z__2.r = b + z__3.r, z__2.i = z__3.i;
+ z_div(&z__1, c__, &z__2);
+ t = z__1.r;
+ } else {
+ d__1 = b * b;
+ z__3.r = d__1 + c__->r, z__3.i = c__->i;
+ z_sqrt(&z__2, &z__3);
+ z__1.r = z__2.r - b, z__1.i = z__2.i;
+ t = z__1.r;
+ }
+
+ z__3.r = alpha.r / absest, z__3.i = alpha.i / absest;
+ z__2.r = -z__3.r, z__2.i = -z__3.i;
+ z__1.r = z__2.r / t, z__1.i = z__2.i / t;
+ sine.r = z__1.r, sine.i = z__1.i;
+ z__3.r = gamma->r / absest, z__3.i = gamma->i / absest;
+ z__2.r = -z__3.r, z__2.i = -z__3.i;
+ d__1 = t + 1.;
+ z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
+ cosine.r = z__1.r, cosine.i = z__1.i;
+ d_cnjg(&z__4, &sine);
+ z__3.r = sine.r * z__4.r - sine.i * z__4.i, z__3.i = sine.r *
+ z__4.i + sine.i * z__4.r;
+ d_cnjg(&z__6, &cosine);
+ z__5.r = cosine.r * z__6.r - cosine.i * z__6.i, z__5.i = cosine.r
+ * z__6.i + cosine.i * z__6.r;
+ z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
+ z_sqrt(&z__1, &z__2);
+ tmp = z__1.r;
+ z__1.r = sine.r / tmp, z__1.i = sine.i / tmp;
+ s->r = z__1.r, s->i = z__1.i;
+ z__1.r = cosine.r / tmp, z__1.i = cosine.i / tmp;
+ c__->r = z__1.r, c__->i = z__1.i;
+ *sestpr = sqrt(t + 1.) * absest;
+ return 0;
+ }
+
+ } else if (*job == 2) {
+
+/* Estimating smallest singular value */
+
+/* special cases */
+
+ if (*sest == 0.) {
+ *sestpr = 0.;
+ if (max(absgam,absalp) == 0.) {
+ sine.r = 1., sine.i = 0.;
+ cosine.r = 0., cosine.i = 0.;
+ } else {
+ d_cnjg(&z__2, gamma);
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ sine.r = z__1.r, sine.i = z__1.i;
+ d_cnjg(&z__1, &alpha);
+ cosine.r = z__1.r, cosine.i = z__1.i;
+ }
+/* Computing MAX */
+ d__1 = z_abs(&sine), d__2 = z_abs(&cosine);
+ s1 = max(d__1,d__2);
+ z__1.r = sine.r / s1, z__1.i = sine.i / s1;
+ s->r = z__1.r, s->i = z__1.i;
+ z__1.r = cosine.r / s1, z__1.i = cosine.i / s1;
+ c__->r = z__1.r, c__->i = z__1.i;
+ d_cnjg(&z__4, s);
+ z__3.r = s->r * z__4.r - s->i * z__4.i, z__3.i = s->r * z__4.i +
+ s->i * z__4.r;
+ d_cnjg(&z__6, c__);
+ z__5.r = c__->r * z__6.r - c__->i * z__6.i, z__5.i = c__->r *
+ z__6.i + c__->i * z__6.r;
+ z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
+ z_sqrt(&z__1, &z__2);
+ tmp = z__1.r;
+ z__1.r = s->r / tmp, z__1.i = s->i / tmp;
+ s->r = z__1.r, s->i = z__1.i;
+ z__1.r = c__->r / tmp, z__1.i = c__->i / tmp;
+ c__->r = z__1.r, c__->i = z__1.i;
+ return 0;
+ } else if (absgam <= eps * absest) {
+ s->r = 0., s->i = 0.;
+ c__->r = 1., c__->i = 0.;
+ *sestpr = absgam;
+ return 0;
+ } else if (absalp <= eps * absest) {
+ s1 = absgam;
+ s2 = absest;
+ if (s1 <= s2) {
+ s->r = 0., s->i = 0.;
+ c__->r = 1., c__->i = 0.;
+ *sestpr = s1;
+ } else {
+ s->r = 1., s->i = 0.;
+ c__->r = 0., c__->i = 0.;
+ *sestpr = s2;
+ }
+ return 0;
+ } else if (absest <= eps * absalp || absest <= eps * absgam) {
+ s1 = absgam;
+ s2 = absalp;
+ if (s1 <= s2) {
+ tmp = s1 / s2;
+ scl = sqrt(tmp * tmp + 1.);
+ *sestpr = absest * (tmp / scl);
+ d_cnjg(&z__4, gamma);
+ z__3.r = z__4.r / s2, z__3.i = z__4.i / s2;
+ z__2.r = -z__3.r, z__2.i = -z__3.i;
+ z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
+ s->r = z__1.r, s->i = z__1.i;
+ d_cnjg(&z__3, &alpha);
+ z__2.r = z__3.r / s2, z__2.i = z__3.i / s2;
+ z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
+ c__->r = z__1.r, c__->i = z__1.i;
+ } else {
+ tmp = s2 / s1;
+ scl = sqrt(tmp * tmp + 1.);
+ *sestpr = absest / scl;
+ d_cnjg(&z__4, gamma);
+ z__3.r = z__4.r / s1, z__3.i = z__4.i / s1;
+ z__2.r = -z__3.r, z__2.i = -z__3.i;
+ z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
+ s->r = z__1.r, s->i = z__1.i;
+ d_cnjg(&z__3, &alpha);
+ z__2.r = z__3.r / s1, z__2.i = z__3.i / s1;
+ z__1.r = z__2.r / scl, z__1.i = z__2.i / scl;
+ c__->r = z__1.r, c__->i = z__1.i;
+ }
+ return 0;
+ } else {
+
+/* normal case */
+
+ zeta1 = absalp / absest;
+ zeta2 = absgam / absest;
+
+/* Computing MAX */
+ d__1 = zeta1 * zeta1 + 1. + zeta1 * zeta2, d__2 = zeta1 * zeta2 +
+ zeta2 * zeta2;
+ norma = max(d__1,d__2);
+
+/* See if root is closer to zero or to ONE */
+
+ test = (zeta1 - zeta2) * 2. * (zeta1 + zeta2) + 1.;
+ if (test >= 0.) {
+
+/* root is close to zero, compute directly */
+
+ b = (zeta1 * zeta1 + zeta2 * zeta2 + 1.) * .5;
+ d__1 = zeta2 * zeta2;
+ c__->r = d__1, c__->i = 0.;
+ d__2 = b * b;
+ z__2.r = d__2 - c__->r, z__2.i = -c__->i;
+ d__1 = b + sqrt(z_abs(&z__2));
+ z__1.r = c__->r / d__1, z__1.i = c__->i / d__1;
+ t = z__1.r;
+ z__2.r = alpha.r / absest, z__2.i = alpha.i / absest;
+ d__1 = 1. - t;
+ z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
+ sine.r = z__1.r, sine.i = z__1.i;
+ z__3.r = gamma->r / absest, z__3.i = gamma->i / absest;
+ z__2.r = -z__3.r, z__2.i = -z__3.i;
+ z__1.r = z__2.r / t, z__1.i = z__2.i / t;
+ cosine.r = z__1.r, cosine.i = z__1.i;
+ *sestpr = sqrt(t + eps * 4. * eps * norma) * absest;
+ } else {
+
+/* root is closer to ONE, shift by that amount */
+
+ b = (zeta2 * zeta2 + zeta1 * zeta1 - 1.) * .5;
+ d__1 = zeta1 * zeta1;
+ c__->r = d__1, c__->i = 0.;
+ if (b >= 0.) {
+ z__2.r = -c__->r, z__2.i = -c__->i;
+ d__1 = b * b;
+ z__5.r = d__1 + c__->r, z__5.i = c__->i;
+ z_sqrt(&z__4, &z__5);
+ z__3.r = b + z__4.r, z__3.i = z__4.i;
+ z_div(&z__1, &z__2, &z__3);
+ t = z__1.r;
+ } else {
+ d__1 = b * b;
+ z__3.r = d__1 + c__->r, z__3.i = c__->i;
+ z_sqrt(&z__2, &z__3);
+ z__1.r = b - z__2.r, z__1.i = -z__2.i;
+ t = z__1.r;
+ }
+ z__3.r = alpha.r / absest, z__3.i = alpha.i / absest;
+ z__2.r = -z__3.r, z__2.i = -z__3.i;
+ z__1.r = z__2.r / t, z__1.i = z__2.i / t;
+ sine.r = z__1.r, sine.i = z__1.i;
+ z__3.r = gamma->r / absest, z__3.i = gamma->i / absest;
+ z__2.r = -z__3.r, z__2.i = -z__3.i;
+ d__1 = t + 1.;
+ z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
+ cosine.r = z__1.r, cosine.i = z__1.i;
+ *sestpr = sqrt(t + 1. + eps * 4. * eps * norma) * absest;
+ }
+ d_cnjg(&z__4, &sine);
+ z__3.r = sine.r * z__4.r - sine.i * z__4.i, z__3.i = sine.r *
+ z__4.i + sine.i * z__4.r;
+ d_cnjg(&z__6, &cosine);
+ z__5.r = cosine.r * z__6.r - cosine.i * z__6.i, z__5.i = cosine.r
+ * z__6.i + cosine.i * z__6.r;
+ z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
+ z_sqrt(&z__1, &z__2);
+ tmp = z__1.r;
+ z__1.r = sine.r / tmp, z__1.i = sine.i / tmp;
+ s->r = z__1.r, s->i = z__1.i;
+ z__1.r = cosine.r / tmp, z__1.i = cosine.i / tmp;
+ c__->r = z__1.r, c__->i = z__1.i;
+ return 0;
+
+ }
+ }
+ return 0;
+
+/* End of ZLAIC1 */
+
+} /* zlaic1_ */
diff --git a/SRC/zlals0.c b/SRC/zlals0.c
new file mode 100644
index 0000000..354ed21
--- /dev/null
+++ b/SRC/zlals0.c
@@ -0,0 +1,563 @@
+/* zlals0.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b5 = -1.;
+static integer c__1 = 1;
+static doublereal c_b13 = 1.;
+static doublereal c_b15 = 0.;
+static integer c__0 = 0;
+
+/* Subroutine */ int zlals0_(integer *icompq, integer *nl, integer *nr,
+ integer *sqre, integer *nrhs, doublecomplex *b, integer *ldb,
+ doublecomplex *bx, integer *ldbx, integer *perm, integer *givptr,
+ integer *givcol, integer *ldgcol, doublereal *givnum, integer *ldgnum,
+ doublereal *poles, doublereal *difl, doublereal *difr, doublereal *
+ z__, integer *k, doublereal *c__, doublereal *s, doublereal *rwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer givcol_dim1, givcol_offset, difr_dim1, difr_offset, givnum_dim1,
+ givnum_offset, poles_dim1, poles_offset, b_dim1, b_offset,
+ bx_dim1, bx_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, m, n;
+ doublereal dj;
+ integer nlp1, jcol;
+ doublereal temp;
+ integer jrow;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ doublereal diflj, difrj, dsigj;
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), zdrot_(integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+ extern doublereal dlamc3_(doublereal *, doublereal *);
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), xerbla_(char *, integer *);
+ doublereal dsigjp;
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *), zlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublecomplex *
+, integer *, integer *), zlacpy_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLALS0 applies back the multiplying factors of either the left or the */
+/* right singular vector matrix of a diagonal matrix appended by a row */
+/* to the right hand side matrix B in solving the least squares problem */
+/* using the divide-and-conquer SVD approach. */
+
+/* For the left singular vector matrix, three types of orthogonal */
+/* matrices are involved: */
+
+/* (1L) Givens rotations: the number of such rotations is GIVPTR; the */
+/* pairs of columns/rows they were applied to are stored in GIVCOL; */
+/* and the C- and S-values of these rotations are stored in GIVNUM. */
+
+/* (2L) Permutation. The (NL+1)-st row of B is to be moved to the first */
+/* row, and for J=2:N, PERM(J)-th row of B is to be moved to the */
+/* J-th row. */
+
+/* (3L) The left singular vector matrix of the remaining matrix. */
+
+/* For the right singular vector matrix, four types of orthogonal */
+/* matrices are involved: */
+
+/* (1R) The right singular vector matrix of the remaining matrix. */
+
+/* (2R) If SQRE = 1, one extra Givens rotation to generate the right */
+/* null space. */
+
+/* (3R) The inverse transformation of (2L). */
+
+/* (4R) The inverse transformation of (1L). */
+
+/* Arguments */
+/* ========= */
+
+/* ICOMPQ (input) INTEGER */
+/* Specifies whether singular vectors are to be computed in */
+/* factored form: */
+/* = 0: Left singular vector matrix. */
+/* = 1: Right singular vector matrix. */
+
+/* NL (input) INTEGER */
+/* The row dimension of the upper block. NL >= 1. */
+
+/* NR (input) INTEGER */
+/* The row dimension of the lower block. NR >= 1. */
+
+/* SQRE (input) INTEGER */
+/* = 0: the lower block is an NR-by-NR square matrix. */
+/* = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */
+
+/* The bidiagonal matrix has row dimension N = NL + NR + 1, */
+/* and column dimension M = N + SQRE. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B and BX. NRHS must be at least 1. */
+
+/* B (input/output) COMPLEX*16 array, dimension ( LDB, NRHS ) */
+/* On input, B contains the right hand sides of the least */
+/* squares problem in rows 1 through M. On output, B contains */
+/* the solution X in rows 1 through N. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. LDB must be at least */
+/* max(1,MAX( M, N ) ). */
+
+/* BX (workspace) COMPLEX*16 array, dimension ( LDBX, NRHS ) */
+
+/* LDBX (input) INTEGER */
+/* The leading dimension of BX. */
+
+/* PERM (input) INTEGER array, dimension ( N ) */
+/* The permutations (from deflation and sorting) applied */
+/* to the two blocks. */
+
+/* GIVPTR (input) INTEGER */
+/* The number of Givens rotations which took place in this */
+/* subproblem. */
+
+/* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 ) */
+/* Each pair of numbers indicates a pair of rows/columns */
+/* involved in a Givens rotation. */
+
+/* LDGCOL (input) INTEGER */
+/* The leading dimension of GIVCOL, must be at least N. */
+
+/* GIVNUM (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */
+/* Each number indicates the C or S value used in the */
+/* corresponding Givens rotation. */
+
+/* LDGNUM (input) INTEGER */
+/* The leading dimension of arrays DIFR, POLES and */
+/* GIVNUM, must be at least K. */
+
+/* POLES (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */
+/* On entry, POLES(1:K, 1) contains the new singular */
+/* values obtained from solving the secular equation, and */
+/* POLES(1:K, 2) is an array containing the poles in the secular */
+/* equation. */
+
+/* DIFL (input) DOUBLE PRECISION array, dimension ( K ). */
+/* On entry, DIFL(I) is the distance between I-th updated */
+/* (undeflated) singular value and the I-th (undeflated) old */
+/* singular value. */
+
+/* DIFR (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ). */
+/* On entry, DIFR(I, 1) contains the distances between I-th */
+/* updated (undeflated) singular value and the I+1-th */
+/* (undeflated) old singular value. And DIFR(I, 2) is the */
+/* normalizing factor for the I-th right singular vector. */
+
+/* Z (input) DOUBLE PRECISION array, dimension ( K ) */
+/* Contain the components of the deflation-adjusted updating row */
+/* vector. */
+
+/* K (input) INTEGER */
+/* Contains the dimension of the non-deflated matrix, */
+/* This is the order of the related secular equation. 1 <= K <=N. */
+
+/* C (input) DOUBLE PRECISION */
+/* C contains garbage if SQRE =0 and the C-value of a Givens */
+/* rotation related to the right null space if SQRE = 1. */
+
+/* S (input) DOUBLE PRECISION */
+/* S contains garbage if SQRE =0 and the S-value of a Givens */
+/* rotation related to the right null space if SQRE = 1. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* ( K*(1+NRHS) + 2*NRHS ) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */
+/* California at Berkeley, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ bx_dim1 = *ldbx;
+ bx_offset = 1 + bx_dim1;
+ bx -= bx_offset;
+ --perm;
+ givcol_dim1 = *ldgcol;
+ givcol_offset = 1 + givcol_dim1;
+ givcol -= givcol_offset;
+ difr_dim1 = *ldgnum;
+ difr_offset = 1 + difr_dim1;
+ difr -= difr_offset;
+ poles_dim1 = *ldgnum;
+ poles_offset = 1 + poles_dim1;
+ poles -= poles_offset;
+ givnum_dim1 = *ldgnum;
+ givnum_offset = 1 + givnum_dim1;
+ givnum -= givnum_offset;
+ --difl;
+ --z__;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*icompq < 0 || *icompq > 1) {
+ *info = -1;
+ } else if (*nl < 1) {
+ *info = -2;
+ } else if (*nr < 1) {
+ *info = -3;
+ } else if (*sqre < 0 || *sqre > 1) {
+ *info = -4;
+ }
+
+ n = *nl + *nr + 1;
+
+ if (*nrhs < 1) {
+ *info = -5;
+ } else if (*ldb < n) {
+ *info = -7;
+ } else if (*ldbx < n) {
+ *info = -9;
+ } else if (*givptr < 0) {
+ *info = -11;
+ } else if (*ldgcol < n) {
+ *info = -13;
+ } else if (*ldgnum < n) {
+ *info = -15;
+ } else if (*k < 1) {
+ *info = -20;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLALS0", &i__1);
+ return 0;
+ }
+
+ m = n + *sqre;
+ nlp1 = *nl + 1;
+
+ if (*icompq == 0) {
+
+/* Apply back orthogonal transformations from the left. */
+
+/* Step (1L): apply back the Givens rotations performed. */
+
+ i__1 = *givptr;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ zdrot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, &
+ b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ +
+ (givnum_dim1 << 1)], &givnum[i__ + givnum_dim1]);
+/* L10: */
+ }
+
+/* Step (2L): permute rows of B. */
+
+ zcopy_(nrhs, &b[nlp1 + b_dim1], ldb, &bx[bx_dim1 + 1], ldbx);
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ zcopy_(nrhs, &b[perm[i__] + b_dim1], ldb, &bx[i__ + bx_dim1],
+ ldbx);
+/* L20: */
+ }
+
+/* Step (3L): apply the inverse of the left singular vector */
+/* matrix to BX. */
+
+ if (*k == 1) {
+ zcopy_(nrhs, &bx[bx_offset], ldbx, &b[b_offset], ldb);
+ if (z__[1] < 0.) {
+ zdscal_(nrhs, &c_b5, &b[b_offset], ldb);
+ }
+ } else {
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ diflj = difl[j];
+ dj = poles[j + poles_dim1];
+ dsigj = -poles[j + (poles_dim1 << 1)];
+ if (j < *k) {
+ difrj = -difr[j + difr_dim1];
+ dsigjp = -poles[j + 1 + (poles_dim1 << 1)];
+ }
+ if (z__[j] == 0. || poles[j + (poles_dim1 << 1)] == 0.) {
+ rwork[j] = 0.;
+ } else {
+ rwork[j] = -poles[j + (poles_dim1 << 1)] * z__[j] / diflj
+ / (poles[j + (poles_dim1 << 1)] + dj);
+ }
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] ==
+ 0.) {
+ rwork[i__] = 0.;
+ } else {
+ rwork[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__]
+ / (dlamc3_(&poles[i__ + (poles_dim1 << 1)], &
+ dsigj) - diflj) / (poles[i__ + (poles_dim1 <<
+ 1)] + dj);
+ }
+/* L30: */
+ }
+ i__2 = *k;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] ==
+ 0.) {
+ rwork[i__] = 0.;
+ } else {
+ rwork[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__]
+ / (dlamc3_(&poles[i__ + (poles_dim1 << 1)], &
+ dsigjp) + difrj) / (poles[i__ + (poles_dim1 <<
+ 1)] + dj);
+ }
+/* L40: */
+ }
+ rwork[1] = -1.;
+ temp = dnrm2_(k, &rwork[1], &c__1);
+
+/* Since B and BX are complex, the following call to DGEMV */
+/* is performed in two steps (real and imaginary parts). */
+
+/* CALL DGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO, */
+/* $ B( J, 1 ), LDB ) */
+
+ i__ = *k + (*nrhs << 1);
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = *k;
+ for (jrow = 1; jrow <= i__3; ++jrow) {
+ ++i__;
+ i__4 = jrow + jcol * bx_dim1;
+ rwork[i__] = bx[i__4].r;
+/* L50: */
+ }
+/* L60: */
+ }
+ dgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k,
+ &rwork[1], &c__1, &c_b15, &rwork[*k + 1], &c__1);
+ i__ = *k + (*nrhs << 1);
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = *k;
+ for (jrow = 1; jrow <= i__3; ++jrow) {
+ ++i__;
+ rwork[i__] = d_imag(&bx[jrow + jcol * bx_dim1]);
+/* L70: */
+ }
+/* L80: */
+ }
+ dgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k,
+ &rwork[1], &c__1, &c_b15, &rwork[*k + 1 + *nrhs], &
+ c__1);
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = j + jcol * b_dim1;
+ i__4 = jcol + *k;
+ i__5 = jcol + *k + *nrhs;
+ z__1.r = rwork[i__4], z__1.i = rwork[i__5];
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L90: */
+ }
+ zlascl_("G", &c__0, &c__0, &temp, &c_b13, &c__1, nrhs, &b[j +
+ b_dim1], ldb, info);
+/* L100: */
+ }
+ }
+
+/* Move the deflated rows of BX to B also. */
+
+ if (*k < max(m,n)) {
+ i__1 = n - *k;
+ zlacpy_("A", &i__1, nrhs, &bx[*k + 1 + bx_dim1], ldbx, &b[*k + 1
+ + b_dim1], ldb);
+ }
+ } else {
+
+/* Apply back the right orthogonal transformations. */
+
+/* Step (1R): apply back the new right singular vector matrix */
+/* to B. */
+
+ if (*k == 1) {
+ zcopy_(nrhs, &b[b_offset], ldb, &bx[bx_offset], ldbx);
+ } else {
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ dsigj = poles[j + (poles_dim1 << 1)];
+ if (z__[j] == 0.) {
+ rwork[j] = 0.;
+ } else {
+ rwork[j] = -z__[j] / difl[j] / (dsigj + poles[j +
+ poles_dim1]) / difr[j + (difr_dim1 << 1)];
+ }
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (z__[j] == 0.) {
+ rwork[i__] = 0.;
+ } else {
+ d__1 = -poles[i__ + 1 + (poles_dim1 << 1)];
+ rwork[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difr[
+ i__ + difr_dim1]) / (dsigj + poles[i__ +
+ poles_dim1]) / difr[i__ + (difr_dim1 << 1)];
+ }
+/* L110: */
+ }
+ i__2 = *k;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ if (z__[j] == 0.) {
+ rwork[i__] = 0.;
+ } else {
+ d__1 = -poles[i__ + (poles_dim1 << 1)];
+ rwork[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difl[
+ i__]) / (dsigj + poles[i__ + poles_dim1]) /
+ difr[i__ + (difr_dim1 << 1)];
+ }
+/* L120: */
+ }
+
+/* Since B and BX are complex, the following call to DGEMV */
+/* is performed in two steps (real and imaginary parts). */
+
+/* CALL DGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO, */
+/* $ BX( J, 1 ), LDBX ) */
+
+ i__ = *k + (*nrhs << 1);
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = *k;
+ for (jrow = 1; jrow <= i__3; ++jrow) {
+ ++i__;
+ i__4 = jrow + jcol * b_dim1;
+ rwork[i__] = b[i__4].r;
+/* L130: */
+ }
+/* L140: */
+ }
+ dgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k,
+ &rwork[1], &c__1, &c_b15, &rwork[*k + 1], &c__1);
+ i__ = *k + (*nrhs << 1);
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = *k;
+ for (jrow = 1; jrow <= i__3; ++jrow) {
+ ++i__;
+ rwork[i__] = d_imag(&b[jrow + jcol * b_dim1]);
+/* L150: */
+ }
+/* L160: */
+ }
+ dgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k,
+ &rwork[1], &c__1, &c_b15, &rwork[*k + 1 + *nrhs], &
+ c__1);
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = j + jcol * bx_dim1;
+ i__4 = jcol + *k;
+ i__5 = jcol + *k + *nrhs;
+ z__1.r = rwork[i__4], z__1.i = rwork[i__5];
+ bx[i__3].r = z__1.r, bx[i__3].i = z__1.i;
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+
+/* Step (2R): if SQRE = 1, apply back the rotation that is */
+/* related to the right null space of the subproblem. */
+
+ if (*sqre == 1) {
+ zcopy_(nrhs, &b[m + b_dim1], ldb, &bx[m + bx_dim1], ldbx);
+ zdrot_(nrhs, &bx[bx_dim1 + 1], ldbx, &bx[m + bx_dim1], ldbx, c__,
+ s);
+ }
+ if (*k < max(m,n)) {
+ i__1 = n - *k;
+ zlacpy_("A", &i__1, nrhs, &b[*k + 1 + b_dim1], ldb, &bx[*k + 1 +
+ bx_dim1], ldbx);
+ }
+
+/* Step (3R): permute rows of B. */
+
+ zcopy_(nrhs, &bx[bx_dim1 + 1], ldbx, &b[nlp1 + b_dim1], ldb);
+ if (*sqre == 1) {
+ zcopy_(nrhs, &bx[m + bx_dim1], ldbx, &b[m + b_dim1], ldb);
+ }
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ zcopy_(nrhs, &bx[i__ + bx_dim1], ldbx, &b[perm[i__] + b_dim1],
+ ldb);
+/* L190: */
+ }
+
+/* Step (4R): apply back the Givens rotations performed. */
+
+ for (i__ = *givptr; i__ >= 1; --i__) {
+ d__1 = -givnum[i__ + givnum_dim1];
+ zdrot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, &
+ b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ +
+ (givnum_dim1 << 1)], &d__1);
+/* L200: */
+ }
+ }
+
+ return 0;
+
+/* End of ZLALS0 */
+
+} /* zlals0_ */
diff --git a/SRC/zlalsa.c b/SRC/zlalsa.c
new file mode 100644
index 0000000..9b29e00
--- /dev/null
+++ b/SRC/zlalsa.c
@@ -0,0 +1,664 @@
+/* zlalsa.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b9 = 1.;
+static doublereal c_b10 = 0.;
+static integer c__2 = 2;
+
+/* Subroutine */ int zlalsa_(integer *icompq, integer *smlsiz, integer *n,
+ integer *nrhs, doublecomplex *b, integer *ldb, doublecomplex *bx,
+ integer *ldbx, doublereal *u, integer *ldu, doublereal *vt, integer *
+ k, doublereal *difl, doublereal *difr, doublereal *z__, doublereal *
+ poles, integer *givptr, integer *givcol, integer *ldgcol, integer *
+ perm, doublereal *givnum, doublereal *c__, doublereal *s, doublereal *
+ rwork, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, difl_dim1,
+ difl_offset, difr_dim1, difr_offset, givnum_dim1, givnum_offset,
+ poles_dim1, poles_offset, u_dim1, u_offset, vt_dim1, vt_offset,
+ z_dim1, z_offset, b_dim1, b_offset, bx_dim1, bx_offset, i__1,
+ i__2, i__3, i__4, i__5, i__6;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ integer pow_ii(integer *, integer *);
+
+ /* Local variables */
+ integer i__, j, i1, ic, lf, nd, ll, nl, nr, im1, nlf, nrf, lvl, ndb1,
+ nlp1, lvl2, nrp1, jcol, nlvl, sqre, jrow, jimag;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ integer jreal, inode, ndiml, ndimr;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zlals0_(integer *, integer *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), dlasdt_(integer *, integer *, integer *
+, integer *, integer *, integer *, integer *), xerbla_(char *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLALSA is an itermediate step in solving the least squares problem */
+/* by computing the SVD of the coefficient matrix in compact form (The */
+/* singular vectors are computed as products of simple orthorgonal */
+/* matrices.). */
+
+/* If ICOMPQ = 0, ZLALSA applies the inverse of the left singular vector */
+/* matrix of an upper bidiagonal matrix to the right hand side; and if */
+/* ICOMPQ = 1, ZLALSA applies the right singular vector matrix to the */
+/* right hand side. The singular vector matrices were generated in */
+/* compact form by ZLALSA. */
+
+/* Arguments */
+/* ========= */
+
+/* ICOMPQ (input) INTEGER */
+/* Specifies whether the left or the right singular vector */
+/* matrix is involved. */
+/* = 0: Left singular vector matrix */
+/* = 1: Right singular vector matrix */
+
+/* SMLSIZ (input) INTEGER */
+/* The maximum size of the subproblems at the bottom of the */
+/* computation tree. */
+
+/* N (input) INTEGER */
+/* The row and column dimensions of the upper bidiagonal matrix. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B and BX. NRHS must be at least 1. */
+
+/* B (input/output) COMPLEX*16 array, dimension ( LDB, NRHS ) */
+/* On input, B contains the right hand sides of the least */
+/* squares problem in rows 1 through M. */
+/* On output, B contains the solution X in rows 1 through N. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B in the calling subprogram. */
+/* LDB must be at least max(1,MAX( M, N ) ). */
+
+/* BX (output) COMPLEX*16 array, dimension ( LDBX, NRHS ) */
+/* On exit, the result of applying the left or right singular */
+/* vector matrix to B. */
+
+/* LDBX (input) INTEGER */
+/* The leading dimension of BX. */
+
+/* U (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ). */
+/* On entry, U contains the left singular vector matrices of all */
+/* subproblems at the bottom level. */
+
+/* LDU (input) INTEGER, LDU = > N. */
+/* The leading dimension of arrays U, VT, DIFL, DIFR, */
+/* POLES, GIVNUM, and Z. */
+
+/* VT (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ). */
+/* On entry, VT' contains the right singular vector matrices of */
+/* all subproblems at the bottom level. */
+
+/* K (input) INTEGER array, dimension ( N ). */
+
+/* DIFL (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ). */
+/* where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1. */
+
+/* DIFR (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). */
+/* On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record */
+/* distances between singular values on the I-th level and */
+/* singular values on the (I -1)-th level, and DIFR(*, 2 * I) */
+/* record the normalizing factors of the right singular vectors */
+/* matrices of subproblems on I-th level. */
+
+/* Z (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ). */
+/* On entry, Z(1, I) contains the components of the deflation- */
+/* adjusted updating row vector for subproblems on the I-th */
+/* level. */
+
+/* POLES (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). */
+/* On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old */
+/* singular values involved in the secular equations on the I-th */
+/* level. */
+
+/* GIVPTR (input) INTEGER array, dimension ( N ). */
+/* On entry, GIVPTR( I ) records the number of Givens */
+/* rotations performed on the I-th problem on the computation */
+/* tree. */
+
+/* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ). */
+/* On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the */
+/* locations of Givens rotations performed on the I-th level on */
+/* the computation tree. */
+
+/* LDGCOL (input) INTEGER, LDGCOL = > N. */
+/* The leading dimension of arrays GIVCOL and PERM. */
+
+/* PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ). */
+/* On entry, PERM(*, I) records permutations done on the I-th */
+/* level of the computation tree. */
+
+/* GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). */
+/* On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S- */
+/* values of Givens rotations performed on the I-th level on the */
+/* computation tree. */
+
+/* C (input) DOUBLE PRECISION array, dimension ( N ). */
+/* On entry, if the I-th subproblem is not square, */
+/* C( I ) contains the C-value of a Givens rotation related to */
+/* the right null space of the I-th subproblem. */
+
+/* S (input) DOUBLE PRECISION array, dimension ( N ). */
+/* On entry, if the I-th subproblem is not square, */
+/* S( I ) contains the S-value of a Givens rotation related to */
+/* the right null space of the I-th subproblem. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension at least */
+/* max ( N, (SMLSZ+1)*NRHS*3 ). */
+
+/* IWORK (workspace) INTEGER array. */
+/* The dimension must be at least 3 * N */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */
+/* California at Berkeley, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ bx_dim1 = *ldbx;
+ bx_offset = 1 + bx_dim1;
+ bx -= bx_offset;
+ givnum_dim1 = *ldu;
+ givnum_offset = 1 + givnum_dim1;
+ givnum -= givnum_offset;
+ poles_dim1 = *ldu;
+ poles_offset = 1 + poles_dim1;
+ poles -= poles_offset;
+ z_dim1 = *ldu;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ difr_dim1 = *ldu;
+ difr_offset = 1 + difr_dim1;
+ difr -= difr_offset;
+ difl_dim1 = *ldu;
+ difl_offset = 1 + difl_dim1;
+ difl -= difl_offset;
+ vt_dim1 = *ldu;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --k;
+ --givptr;
+ perm_dim1 = *ldgcol;
+ perm_offset = 1 + perm_dim1;
+ perm -= perm_offset;
+ givcol_dim1 = *ldgcol;
+ givcol_offset = 1 + givcol_dim1;
+ givcol -= givcol_offset;
+ --c__;
+ --s;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*icompq < 0 || *icompq > 1) {
+ *info = -1;
+ } else if (*smlsiz < 3) {
+ *info = -2;
+ } else if (*n < *smlsiz) {
+ *info = -3;
+ } else if (*nrhs < 1) {
+ *info = -4;
+ } else if (*ldb < *n) {
+ *info = -6;
+ } else if (*ldbx < *n) {
+ *info = -8;
+ } else if (*ldu < *n) {
+ *info = -10;
+ } else if (*ldgcol < *n) {
+ *info = -19;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLALSA", &i__1);
+ return 0;
+ }
+
+/* Book-keeping and setting up the computation tree. */
+
+ inode = 1;
+ ndiml = inode + *n;
+ ndimr = ndiml + *n;
+
+ dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr],
+ smlsiz);
+
+/* The following code applies back the left singular vector factors. */
+/* For applying back the right singular vector factors, go to 170. */
+
+ if (*icompq == 1) {
+ goto L170;
+ }
+
+/* The nodes on the bottom level of the tree were solved */
+/* by DLASDQ. The corresponding left and right singular vector */
+/* matrices are in explicit form. First apply back the left */
+/* singular vector matrices. */
+
+ ndb1 = (nd + 1) / 2;
+ i__1 = nd;
+ for (i__ = ndb1; i__ <= i__1; ++i__) {
+
+/* IC : center row of each node */
+/* NL : number of rows of left subproblem */
+/* NR : number of rows of right subproblem */
+/* NLF: starting row of the left subproblem */
+/* NRF: starting row of the right subproblem */
+
+ i1 = i__ - 1;
+ ic = iwork[inode + i1];
+ nl = iwork[ndiml + i1];
+ nr = iwork[ndimr + i1];
+ nlf = ic - nl;
+ nrf = ic + 1;
+
+/* Since B and BX are complex, the following call to DGEMM */
+/* is performed in two steps (real and imaginary parts). */
+
+/* CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU, */
+/* $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX ) */
+
+ j = nl * *nrhs << 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nlf + nl - 1;
+ for (jrow = nlf; jrow <= i__3; ++jrow) {
+ ++j;
+ i__4 = jrow + jcol * b_dim1;
+ rwork[j] = b[i__4].r;
+/* L10: */
+ }
+/* L20: */
+ }
+ dgemm_("T", "N", &nl, nrhs, &nl, &c_b9, &u[nlf + u_dim1], ldu, &rwork[
+ (nl * *nrhs << 1) + 1], &nl, &c_b10, &rwork[1], &nl);
+ j = nl * *nrhs << 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nlf + nl - 1;
+ for (jrow = nlf; jrow <= i__3; ++jrow) {
+ ++j;
+ rwork[j] = d_imag(&b[jrow + jcol * b_dim1]);
+/* L30: */
+ }
+/* L40: */
+ }
+ dgemm_("T", "N", &nl, nrhs, &nl, &c_b9, &u[nlf + u_dim1], ldu, &rwork[
+ (nl * *nrhs << 1) + 1], &nl, &c_b10, &rwork[nl * *nrhs + 1], &
+ nl);
+ jreal = 0;
+ jimag = nl * *nrhs;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nlf + nl - 1;
+ for (jrow = nlf; jrow <= i__3; ++jrow) {
+ ++jreal;
+ ++jimag;
+ i__4 = jrow + jcol * bx_dim1;
+ i__5 = jreal;
+ i__6 = jimag;
+ z__1.r = rwork[i__5], z__1.i = rwork[i__6];
+ bx[i__4].r = z__1.r, bx[i__4].i = z__1.i;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* Since B and BX are complex, the following call to DGEMM */
+/* is performed in two steps (real and imaginary parts). */
+
+/* CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU, */
+/* $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX ) */
+
+ j = nr * *nrhs << 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nrf + nr - 1;
+ for (jrow = nrf; jrow <= i__3; ++jrow) {
+ ++j;
+ i__4 = jrow + jcol * b_dim1;
+ rwork[j] = b[i__4].r;
+/* L70: */
+ }
+/* L80: */
+ }
+ dgemm_("T", "N", &nr, nrhs, &nr, &c_b9, &u[nrf + u_dim1], ldu, &rwork[
+ (nr * *nrhs << 1) + 1], &nr, &c_b10, &rwork[1], &nr);
+ j = nr * *nrhs << 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nrf + nr - 1;
+ for (jrow = nrf; jrow <= i__3; ++jrow) {
+ ++j;
+ rwork[j] = d_imag(&b[jrow + jcol * b_dim1]);
+/* L90: */
+ }
+/* L100: */
+ }
+ dgemm_("T", "N", &nr, nrhs, &nr, &c_b9, &u[nrf + u_dim1], ldu, &rwork[
+ (nr * *nrhs << 1) + 1], &nr, &c_b10, &rwork[nr * *nrhs + 1], &
+ nr);
+ jreal = 0;
+ jimag = nr * *nrhs;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nrf + nr - 1;
+ for (jrow = nrf; jrow <= i__3; ++jrow) {
+ ++jreal;
+ ++jimag;
+ i__4 = jrow + jcol * bx_dim1;
+ i__5 = jreal;
+ i__6 = jimag;
+ z__1.r = rwork[i__5], z__1.i = rwork[i__6];
+ bx[i__4].r = z__1.r, bx[i__4].i = z__1.i;
+/* L110: */
+ }
+/* L120: */
+ }
+
+/* L130: */
+ }
+
+/* Next copy the rows of B that correspond to unchanged rows */
+/* in the bidiagonal matrix to BX. */
+
+ i__1 = nd;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ic = iwork[inode + i__ - 1];
+ zcopy_(nrhs, &b[ic + b_dim1], ldb, &bx[ic + bx_dim1], ldbx);
+/* L140: */
+ }
+
+/* Finally go through the left singular vector matrices of all */
+/* the other subproblems bottom-up on the tree. */
+
+ j = pow_ii(&c__2, &nlvl);
+ sqre = 0;
+
+ for (lvl = nlvl; lvl >= 1; --lvl) {
+ lvl2 = (lvl << 1) - 1;
+
+/* find the first node LF and last node LL on */
+/* the current level LVL */
+
+ if (lvl == 1) {
+ lf = 1;
+ ll = 1;
+ } else {
+ i__1 = lvl - 1;
+ lf = pow_ii(&c__2, &i__1);
+ ll = (lf << 1) - 1;
+ }
+ i__1 = ll;
+ for (i__ = lf; i__ <= i__1; ++i__) {
+ im1 = i__ - 1;
+ ic = iwork[inode + im1];
+ nl = iwork[ndiml + im1];
+ nr = iwork[ndimr + im1];
+ nlf = ic - nl;
+ nrf = ic + 1;
+ --j;
+ zlals0_(icompq, &nl, &nr, &sqre, nrhs, &bx[nlf + bx_dim1], ldbx, &
+ b[nlf + b_dim1], ldb, &perm[nlf + lvl * perm_dim1], &
+ givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, &
+ givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 *
+ poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf +
+ lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[
+ j], &s[j], &rwork[1], info);
+/* L150: */
+ }
+/* L160: */
+ }
+ goto L330;
+
+/* ICOMPQ = 1: applying back the right singular vector factors. */
+
+L170:
+
+/* First now go through the right singular vector matrices of all */
+/* the tree nodes top-down. */
+
+ j = 0;
+ i__1 = nlvl;
+ for (lvl = 1; lvl <= i__1; ++lvl) {
+ lvl2 = (lvl << 1) - 1;
+
+/* Find the first node LF and last node LL on */
+/* the current level LVL. */
+
+ if (lvl == 1) {
+ lf = 1;
+ ll = 1;
+ } else {
+ i__2 = lvl - 1;
+ lf = pow_ii(&c__2, &i__2);
+ ll = (lf << 1) - 1;
+ }
+ i__2 = lf;
+ for (i__ = ll; i__ >= i__2; --i__) {
+ im1 = i__ - 1;
+ ic = iwork[inode + im1];
+ nl = iwork[ndiml + im1];
+ nr = iwork[ndimr + im1];
+ nlf = ic - nl;
+ nrf = ic + 1;
+ if (i__ == ll) {
+ sqre = 0;
+ } else {
+ sqre = 1;
+ }
+ ++j;
+ zlals0_(icompq, &nl, &nr, &sqre, nrhs, &b[nlf + b_dim1], ldb, &bx[
+ nlf + bx_dim1], ldbx, &perm[nlf + lvl * perm_dim1], &
+ givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, &
+ givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 *
+ poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf +
+ lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[
+ j], &s[j], &rwork[1], info);
+/* L180: */
+ }
+/* L190: */
+ }
+
+/* The nodes on the bottom level of the tree were solved */
+/* by DLASDQ. The corresponding right singular vector */
+/* matrices are in explicit form. Apply them back. */
+
+ ndb1 = (nd + 1) / 2;
+ i__1 = nd;
+ for (i__ = ndb1; i__ <= i__1; ++i__) {
+ i1 = i__ - 1;
+ ic = iwork[inode + i1];
+ nl = iwork[ndiml + i1];
+ nr = iwork[ndimr + i1];
+ nlp1 = nl + 1;
+ if (i__ == nd) {
+ nrp1 = nr;
+ } else {
+ nrp1 = nr + 1;
+ }
+ nlf = ic - nl;
+ nrf = ic + 1;
+
+/* Since B and BX are complex, the following call to DGEMM is */
+/* performed in two steps (real and imaginary parts). */
+
+/* CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU, */
+/* $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX ) */
+
+ j = nlp1 * *nrhs << 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nlf + nlp1 - 1;
+ for (jrow = nlf; jrow <= i__3; ++jrow) {
+ ++j;
+ i__4 = jrow + jcol * b_dim1;
+ rwork[j] = b[i__4].r;
+/* L200: */
+ }
+/* L210: */
+ }
+ dgemm_("T", "N", &nlp1, nrhs, &nlp1, &c_b9, &vt[nlf + vt_dim1], ldu, &
+ rwork[(nlp1 * *nrhs << 1) + 1], &nlp1, &c_b10, &rwork[1], &
+ nlp1);
+ j = nlp1 * *nrhs << 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nlf + nlp1 - 1;
+ for (jrow = nlf; jrow <= i__3; ++jrow) {
+ ++j;
+ rwork[j] = d_imag(&b[jrow + jcol * b_dim1]);
+/* L220: */
+ }
+/* L230: */
+ }
+ dgemm_("T", "N", &nlp1, nrhs, &nlp1, &c_b9, &vt[nlf + vt_dim1], ldu, &
+ rwork[(nlp1 * *nrhs << 1) + 1], &nlp1, &c_b10, &rwork[nlp1 * *
+ nrhs + 1], &nlp1);
+ jreal = 0;
+ jimag = nlp1 * *nrhs;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nlf + nlp1 - 1;
+ for (jrow = nlf; jrow <= i__3; ++jrow) {
+ ++jreal;
+ ++jimag;
+ i__4 = jrow + jcol * bx_dim1;
+ i__5 = jreal;
+ i__6 = jimag;
+ z__1.r = rwork[i__5], z__1.i = rwork[i__6];
+ bx[i__4].r = z__1.r, bx[i__4].i = z__1.i;
+/* L240: */
+ }
+/* L250: */
+ }
+
+/* Since B and BX are complex, the following call to DGEMM is */
+/* performed in two steps (real and imaginary parts). */
+
+/* CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU, */
+/* $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX ) */
+
+ j = nrp1 * *nrhs << 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nrf + nrp1 - 1;
+ for (jrow = nrf; jrow <= i__3; ++jrow) {
+ ++j;
+ i__4 = jrow + jcol * b_dim1;
+ rwork[j] = b[i__4].r;
+/* L260: */
+ }
+/* L270: */
+ }
+ dgemm_("T", "N", &nrp1, nrhs, &nrp1, &c_b9, &vt[nrf + vt_dim1], ldu, &
+ rwork[(nrp1 * *nrhs << 1) + 1], &nrp1, &c_b10, &rwork[1], &
+ nrp1);
+ j = nrp1 * *nrhs << 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nrf + nrp1 - 1;
+ for (jrow = nrf; jrow <= i__3; ++jrow) {
+ ++j;
+ rwork[j] = d_imag(&b[jrow + jcol * b_dim1]);
+/* L280: */
+ }
+/* L290: */
+ }
+ dgemm_("T", "N", &nrp1, nrhs, &nrp1, &c_b9, &vt[nrf + vt_dim1], ldu, &
+ rwork[(nrp1 * *nrhs << 1) + 1], &nrp1, &c_b10, &rwork[nrp1 * *
+ nrhs + 1], &nrp1);
+ jreal = 0;
+ jimag = nrp1 * *nrhs;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = nrf + nrp1 - 1;
+ for (jrow = nrf; jrow <= i__3; ++jrow) {
+ ++jreal;
+ ++jimag;
+ i__4 = jrow + jcol * bx_dim1;
+ i__5 = jreal;
+ i__6 = jimag;
+ z__1.r = rwork[i__5], z__1.i = rwork[i__6];
+ bx[i__4].r = z__1.r, bx[i__4].i = z__1.i;
+/* L300: */
+ }
+/* L310: */
+ }
+
+/* L320: */
+ }
+
+L330:
+
+ return 0;
+
+/* End of ZLALSA */
+
+} /* zlalsa_ */
diff --git a/SRC/zlalsd.c b/SRC/zlalsd.c
new file mode 100644
index 0000000..3c37773
--- /dev/null
+++ b/SRC/zlalsd.c
@@ -0,0 +1,758 @@
+/* zlalsd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static integer c__1 = 1;
+static integer c__0 = 0;
+static doublereal c_b10 = 1.;
+static doublereal c_b35 = 0.;
+
+/* Subroutine */ int zlalsd_(char *uplo, integer *smlsiz, integer *n, integer
+ *nrhs, doublereal *d__, doublereal *e, doublecomplex *b, integer *ldb,
+ doublereal *rcond, integer *rank, doublecomplex *work, doublereal *
+ rwork, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *), log(doublereal), d_sign(doublereal *,
+ doublereal *);
+
+ /* Local variables */
+ integer c__, i__, j, k;
+ doublereal r__;
+ integer s, u, z__;
+ doublereal cs;
+ integer bx;
+ doublereal sn;
+ integer st, vt, nm1, st1;
+ doublereal eps;
+ integer iwk;
+ doublereal tol;
+ integer difl, difr;
+ doublereal rcnd;
+ integer jcol, irwb, perm, nsub, nlvl, sqre, bxst, jrow, irwu, jimag;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ integer jreal, irwib, poles, sizei, irwrb, nsize;
+ extern /* Subroutine */ int zdrot_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *), zcopy_(
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *)
+ ;
+ integer irwvt, icmpq1, icmpq2;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlasda_(integer *, integer *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *), dlascl_(char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer
+ *, integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *), dlaset_(char *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *), dlartg_(doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *), xerbla_(char *, integer *);
+ integer givcol;
+ extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
+ extern /* Subroutine */ int zlalsa_(integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *), zlascl_(char *, integer *,
+ integer *, doublereal *, doublereal *, integer *, integer *,
+ doublecomplex *, integer *, integer *), dlasrt_(char *,
+ integer *, doublereal *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+ doublereal orgnrm;
+ integer givnum, givptr, nrwork, irwwrk, smlszp;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLALSD uses the singular value decomposition of A to solve the least */
+/* squares problem of finding X to minimize the Euclidean norm of each */
+/* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B */
+/* are N-by-NRHS. The solution X overwrites B. */
+
+/* The singular values of A smaller than RCOND times the largest */
+/* singular value are treated as zero in solving the least squares */
+/* problem; in this case a minimum norm solution is returned. */
+/* The actual singular values are returned in D in ascending order. */
+
+/* This code makes very mild assumptions about floating point */
+/* arithmetic. It will work on machines with a guard digit in */
+/* add/subtract, or on those binary machines without guard digits */
+/* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. */
+/* It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': D and E define an upper bidiagonal matrix. */
+/* = 'L': D and E define a lower bidiagonal matrix. */
+
+/* SMLSIZ (input) INTEGER */
+/* The maximum size of the subproblems at the bottom of the */
+/* computation tree. */
+
+/* N (input) INTEGER */
+/* The dimension of the bidiagonal matrix. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS must be at least 1. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry D contains the main diagonal of the bidiagonal */
+/* matrix. On exit, if INFO = 0, D contains its singular values. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* Contains the super-diagonal entries of the bidiagonal matrix. */
+/* On exit, E has been destroyed. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On input, B contains the right hand sides of the least */
+/* squares problem. On output, B contains the solution X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B in the calling subprogram. */
+/* LDB must be at least max(1,N). */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* The singular values of A less than or equal to RCOND times */
+/* the largest singular value are treated as zero in solving */
+/* the least squares problem. If RCOND is negative, */
+/* machine precision is used instead. */
+/* For example, if diag(S)*X=B were the least squares problem, */
+/* where diag(S) is a diagonal matrix of singular values, the */
+/* solution would be X(i) = B(i) / S(i) if S(i) is greater than */
+/* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to */
+/* RCOND*max(S). */
+
+/* RANK (output) INTEGER */
+/* The number of singular values of A greater than RCOND times */
+/* the largest singular value. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension at least */
+/* (N * NRHS). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension at least */
+/* (9*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS + (SMLSIZ+1)**2), */
+/* where */
+/* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) */
+
+/* IWORK (workspace) INTEGER array, dimension at least */
+/* (3*N*NLVL + 11*N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: The algorithm failed to compute an singular value while */
+/* working on the submatrix lying in rows and columns */
+/* INFO/(N+1) through MOD(INFO,N+1). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */
+/* California at Berkeley, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+ if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 1) {
+ *info = -4;
+ } else if (*ldb < 1 || *ldb < *n) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLALSD", &i__1);
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+
+/* Set up the tolerance. */
+
+ if (*rcond <= 0. || *rcond >= 1.) {
+ rcnd = eps;
+ } else {
+ rcnd = *rcond;
+ }
+
+ *rank = 0;
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ } else if (*n == 1) {
+ if (d__[1] == 0.) {
+ zlaset_("A", &c__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+ } else {
+ *rank = 1;
+ zlascl_("G", &c__0, &c__0, &d__[1], &c_b10, &c__1, nrhs, &b[
+ b_offset], ldb, info);
+ d__[1] = abs(d__[1]);
+ }
+ return 0;
+ }
+
+/* Rotate the matrix if it is lower bidiagonal. */
+
+ if (*(unsigned char *)uplo == 'L') {
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
+ d__[i__] = r__;
+ e[i__] = sn * d__[i__ + 1];
+ d__[i__ + 1] = cs * d__[i__ + 1];
+ if (*nrhs == 1) {
+ zdrot_(&c__1, &b[i__ + b_dim1], &c__1, &b[i__ + 1 + b_dim1], &
+ c__1, &cs, &sn);
+ } else {
+ rwork[(i__ << 1) - 1] = cs;
+ rwork[i__ * 2] = sn;
+ }
+/* L10: */
+ }
+ if (*nrhs > 1) {
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n - 1;
+ for (j = 1; j <= i__2; ++j) {
+ cs = rwork[(j << 1) - 1];
+ sn = rwork[j * 2];
+ zdrot_(&c__1, &b[j + i__ * b_dim1], &c__1, &b[j + 1 + i__
+ * b_dim1], &c__1, &cs, &sn);
+/* L20: */
+ }
+/* L30: */
+ }
+ }
+ }
+
+/* Scale. */
+
+ nm1 = *n - 1;
+ orgnrm = dlanst_("M", n, &d__[1], &e[1]);
+ if (orgnrm == 0.) {
+ zlaset_("A", n, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+ return 0;
+ }
+
+ dlascl_("G", &c__0, &c__0, &orgnrm, &c_b10, n, &c__1, &d__[1], n, info);
+ dlascl_("G", &c__0, &c__0, &orgnrm, &c_b10, &nm1, &c__1, &e[1], &nm1,
+ info);
+
+/* If N is smaller than the minimum divide size SMLSIZ, then solve */
+/* the problem with another solver. */
+
+ if (*n <= *smlsiz) {
+ irwu = 1;
+ irwvt = irwu + *n * *n;
+ irwwrk = irwvt + *n * *n;
+ irwrb = irwwrk;
+ irwib = irwrb + *n * *nrhs;
+ irwb = irwib + *n * *nrhs;
+ dlaset_("A", n, n, &c_b35, &c_b10, &rwork[irwu], n);
+ dlaset_("A", n, n, &c_b35, &c_b10, &rwork[irwvt], n);
+ dlasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &rwork[irwvt], n,
+ &rwork[irwu], n, &rwork[irwwrk], &c__1, &rwork[irwwrk], info);
+ if (*info != 0) {
+ return 0;
+ }
+
+/* In the real version, B is passed to DLASDQ and multiplied */
+/* internally by Q'. Here B is complex and that product is */
+/* computed below in two steps (real and imaginary parts). */
+
+ j = irwb - 1;
+ i__1 = *nrhs;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ i__2 = *n;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ ++j;
+ i__3 = jrow + jcol * b_dim1;
+ rwork[j] = b[i__3].r;
+/* L40: */
+ }
+/* L50: */
+ }
+ dgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwu], n, &rwork[irwb], n,
+ &c_b35, &rwork[irwrb], n);
+ j = irwb - 1;
+ i__1 = *nrhs;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ i__2 = *n;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ ++j;
+ rwork[j] = d_imag(&b[jrow + jcol * b_dim1]);
+/* L60: */
+ }
+/* L70: */
+ }
+ dgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwu], n, &rwork[irwb], n,
+ &c_b35, &rwork[irwib], n);
+ jreal = irwrb - 1;
+ jimag = irwib - 1;
+ i__1 = *nrhs;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ i__2 = *n;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ ++jreal;
+ ++jimag;
+ i__3 = jrow + jcol * b_dim1;
+ i__4 = jreal;
+ i__5 = jimag;
+ z__1.r = rwork[i__4], z__1.i = rwork[i__5];
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L80: */
+ }
+/* L90: */
+ }
+
+ tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1));
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (d__[i__] <= tol) {
+ zlaset_("A", &c__1, nrhs, &c_b1, &c_b1, &b[i__ + b_dim1], ldb);
+ } else {
+ zlascl_("G", &c__0, &c__0, &d__[i__], &c_b10, &c__1, nrhs, &b[
+ i__ + b_dim1], ldb, info);
+ ++(*rank);
+ }
+/* L100: */
+ }
+
+/* Since B is complex, the following call to DGEMM is performed */
+/* in two steps (real and imaginary parts). That is for V * B */
+/* (in the real version of the code V' is stored in WORK). */
+
+/* CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO, */
+/* $ WORK( NWORK ), N ) */
+
+ j = irwb - 1;
+ i__1 = *nrhs;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ i__2 = *n;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ ++j;
+ i__3 = jrow + jcol * b_dim1;
+ rwork[j] = b[i__3].r;
+/* L110: */
+ }
+/* L120: */
+ }
+ dgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwvt], n, &rwork[irwb],
+ n, &c_b35, &rwork[irwrb], n);
+ j = irwb - 1;
+ i__1 = *nrhs;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ i__2 = *n;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ ++j;
+ rwork[j] = d_imag(&b[jrow + jcol * b_dim1]);
+/* L130: */
+ }
+/* L140: */
+ }
+ dgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwvt], n, &rwork[irwb],
+ n, &c_b35, &rwork[irwib], n);
+ jreal = irwrb - 1;
+ jimag = irwib - 1;
+ i__1 = *nrhs;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ i__2 = *n;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ ++jreal;
+ ++jimag;
+ i__3 = jrow + jcol * b_dim1;
+ i__4 = jreal;
+ i__5 = jimag;
+ z__1.r = rwork[i__4], z__1.i = rwork[i__5];
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L150: */
+ }
+/* L160: */
+ }
+
+/* Unscale. */
+
+ dlascl_("G", &c__0, &c__0, &c_b10, &orgnrm, n, &c__1, &d__[1], n,
+ info);
+ dlasrt_("D", n, &d__[1], info);
+ zlascl_("G", &c__0, &c__0, &orgnrm, &c_b10, n, nrhs, &b[b_offset],
+ ldb, info);
+
+ return 0;
+ }
+
+/* Book-keeping and setting up some constants. */
+
+ nlvl = (integer) (log((doublereal) (*n) / (doublereal) (*smlsiz + 1)) /
+ log(2.)) + 1;
+
+ smlszp = *smlsiz + 1;
+
+ u = 1;
+ vt = *smlsiz * *n + 1;
+ difl = vt + smlszp * *n;
+ difr = difl + nlvl * *n;
+ z__ = difr + (nlvl * *n << 1);
+ c__ = z__ + nlvl * *n;
+ s = c__ + *n;
+ poles = s + *n;
+ givnum = poles + (nlvl << 1) * *n;
+ nrwork = givnum + (nlvl << 1) * *n;
+ bx = 1;
+
+ irwrb = nrwork;
+ irwib = irwrb + *smlsiz * *nrhs;
+ irwb = irwib + *smlsiz * *nrhs;
+
+ sizei = *n + 1;
+ k = sizei + *n;
+ givptr = k + *n;
+ perm = givptr + *n;
+ givcol = perm + nlvl * *n;
+ iwk = givcol + (nlvl * *n << 1);
+
+ st = 1;
+ sqre = 0;
+ icmpq1 = 1;
+ icmpq2 = 0;
+ nsub = 0;
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((d__1 = d__[i__], abs(d__1)) < eps) {
+ d__[i__] = d_sign(&eps, &d__[i__]);
+ }
+/* L170: */
+ }
+
+ i__1 = nm1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) {
+ ++nsub;
+ iwork[nsub] = st;
+
+/* Subproblem found. First determine its size and then */
+/* apply divide and conquer on it. */
+
+ if (i__ < nm1) {
+
+/* A subproblem with E(I) small for I < NM1. */
+
+ nsize = i__ - st + 1;
+ iwork[sizei + nsub - 1] = nsize;
+ } else if ((d__1 = e[i__], abs(d__1)) >= eps) {
+
+/* A subproblem with E(NM1) not too small but I = NM1. */
+
+ nsize = *n - st + 1;
+ iwork[sizei + nsub - 1] = nsize;
+ } else {
+
+/* A subproblem with E(NM1) small. This implies an */
+/* 1-by-1 subproblem at D(N), which is not solved */
+/* explicitly. */
+
+ nsize = i__ - st + 1;
+ iwork[sizei + nsub - 1] = nsize;
+ ++nsub;
+ iwork[nsub] = *n;
+ iwork[sizei + nsub - 1] = 1;
+ zcopy_(nrhs, &b[*n + b_dim1], ldb, &work[bx + nm1], n);
+ }
+ st1 = st - 1;
+ if (nsize == 1) {
+
+/* This is a 1-by-1 subproblem and is not solved */
+/* explicitly. */
+
+ zcopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n);
+ } else if (nsize <= *smlsiz) {
+
+/* This is a small subproblem and is solved by DLASDQ. */
+
+ dlaset_("A", &nsize, &nsize, &c_b35, &c_b10, &rwork[vt + st1],
+ n);
+ dlaset_("A", &nsize, &nsize, &c_b35, &c_b10, &rwork[u + st1],
+ n);
+ dlasdq_("U", &c__0, &nsize, &nsize, &nsize, &c__0, &d__[st], &
+ e[st], &rwork[vt + st1], n, &rwork[u + st1], n, &
+ rwork[nrwork], &c__1, &rwork[nrwork], info)
+ ;
+ if (*info != 0) {
+ return 0;
+ }
+
+/* In the real version, B is passed to DLASDQ and multiplied */
+/* internally by Q'. Here B is complex and that product is */
+/* computed below in two steps (real and imaginary parts). */
+
+ j = irwb - 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = st + nsize - 1;
+ for (jrow = st; jrow <= i__3; ++jrow) {
+ ++j;
+ i__4 = jrow + jcol * b_dim1;
+ rwork[j] = b[i__4].r;
+/* L180: */
+ }
+/* L190: */
+ }
+ dgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[u + st1]
+, n, &rwork[irwb], &nsize, &c_b35, &rwork[irwrb], &
+ nsize);
+ j = irwb - 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = st + nsize - 1;
+ for (jrow = st; jrow <= i__3; ++jrow) {
+ ++j;
+ rwork[j] = d_imag(&b[jrow + jcol * b_dim1]);
+/* L200: */
+ }
+/* L210: */
+ }
+ dgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[u + st1]
+, n, &rwork[irwb], &nsize, &c_b35, &rwork[irwib], &
+ nsize);
+ jreal = irwrb - 1;
+ jimag = irwib - 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = st + nsize - 1;
+ for (jrow = st; jrow <= i__3; ++jrow) {
+ ++jreal;
+ ++jimag;
+ i__4 = jrow + jcol * b_dim1;
+ i__5 = jreal;
+ i__6 = jimag;
+ z__1.r = rwork[i__5], z__1.i = rwork[i__6];
+ b[i__4].r = z__1.r, b[i__4].i = z__1.i;
+/* L220: */
+ }
+/* L230: */
+ }
+
+ zlacpy_("A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx +
+ st1], n);
+ } else {
+
+/* A large problem. Solve it using divide and conquer. */
+
+ dlasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], &
+ rwork[u + st1], n, &rwork[vt + st1], &iwork[k + st1],
+ &rwork[difl + st1], &rwork[difr + st1], &rwork[z__ +
+ st1], &rwork[poles + st1], &iwork[givptr + st1], &
+ iwork[givcol + st1], n, &iwork[perm + st1], &rwork[
+ givnum + st1], &rwork[c__ + st1], &rwork[s + st1], &
+ rwork[nrwork], &iwork[iwk], info);
+ if (*info != 0) {
+ return 0;
+ }
+ bxst = bx + st1;
+ zlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b[st + b_dim1], ldb, &
+ work[bxst], n, &rwork[u + st1], n, &rwork[vt + st1], &
+ iwork[k + st1], &rwork[difl + st1], &rwork[difr + st1]
+, &rwork[z__ + st1], &rwork[poles + st1], &iwork[
+ givptr + st1], &iwork[givcol + st1], n, &iwork[perm +
+ st1], &rwork[givnum + st1], &rwork[c__ + st1], &rwork[
+ s + st1], &rwork[nrwork], &iwork[iwk], info);
+ if (*info != 0) {
+ return 0;
+ }
+ }
+ st = i__ + 1;
+ }
+/* L240: */
+ }
+
+/* Apply the singular values and treat the tiny ones as zero. */
+
+ tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1));
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Some of the elements in D can be negative because 1-by-1 */
+/* subproblems were not solved explicitly. */
+
+ if ((d__1 = d__[i__], abs(d__1)) <= tol) {
+ zlaset_("A", &c__1, nrhs, &c_b1, &c_b1, &work[bx + i__ - 1], n);
+ } else {
+ ++(*rank);
+ zlascl_("G", &c__0, &c__0, &d__[i__], &c_b10, &c__1, nrhs, &work[
+ bx + i__ - 1], n, info);
+ }
+ d__[i__] = (d__1 = d__[i__], abs(d__1));
+/* L250: */
+ }
+
+/* Now apply back the right singular vectors. */
+
+ icmpq2 = 1;
+ i__1 = nsub;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ st = iwork[i__];
+ st1 = st - 1;
+ nsize = iwork[sizei + i__ - 1];
+ bxst = bx + st1;
+ if (nsize == 1) {
+ zcopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb);
+ } else if (nsize <= *smlsiz) {
+
+/* Since B and BX are complex, the following call to DGEMM */
+/* is performed in two steps (real and imaginary parts). */
+
+/* CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE, */
+/* $ RWORK( VT+ST1 ), N, RWORK( BXST ), N, ZERO, */
+/* $ B( ST, 1 ), LDB ) */
+
+ j = bxst - *n - 1;
+ jreal = irwb - 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ j += *n;
+ i__3 = nsize;
+ for (jrow = 1; jrow <= i__3; ++jrow) {
+ ++jreal;
+ i__4 = j + jrow;
+ rwork[jreal] = work[i__4].r;
+/* L260: */
+ }
+/* L270: */
+ }
+ dgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[vt + st1],
+ n, &rwork[irwb], &nsize, &c_b35, &rwork[irwrb], &nsize);
+ j = bxst - *n - 1;
+ jimag = irwb - 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ j += *n;
+ i__3 = nsize;
+ for (jrow = 1; jrow <= i__3; ++jrow) {
+ ++jimag;
+ rwork[jimag] = d_imag(&work[j + jrow]);
+/* L280: */
+ }
+/* L290: */
+ }
+ dgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[vt + st1],
+ n, &rwork[irwb], &nsize, &c_b35, &rwork[irwib], &nsize);
+ jreal = irwrb - 1;
+ jimag = irwib - 1;
+ i__2 = *nrhs;
+ for (jcol = 1; jcol <= i__2; ++jcol) {
+ i__3 = st + nsize - 1;
+ for (jrow = st; jrow <= i__3; ++jrow) {
+ ++jreal;
+ ++jimag;
+ i__4 = jrow + jcol * b_dim1;
+ i__5 = jreal;
+ i__6 = jimag;
+ z__1.r = rwork[i__5], z__1.i = rwork[i__6];
+ b[i__4].r = z__1.r, b[i__4].i = z__1.i;
+/* L300: */
+ }
+/* L310: */
+ }
+ } else {
+ zlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b[st +
+ b_dim1], ldb, &rwork[u + st1], n, &rwork[vt + st1], &
+ iwork[k + st1], &rwork[difl + st1], &rwork[difr + st1], &
+ rwork[z__ + st1], &rwork[poles + st1], &iwork[givptr +
+ st1], &iwork[givcol + st1], n, &iwork[perm + st1], &rwork[
+ givnum + st1], &rwork[c__ + st1], &rwork[s + st1], &rwork[
+ nrwork], &iwork[iwk], info);
+ if (*info != 0) {
+ return 0;
+ }
+ }
+/* L320: */
+ }
+
+/* Unscale and sort the singular values. */
+
+ dlascl_("G", &c__0, &c__0, &c_b10, &orgnrm, n, &c__1, &d__[1], n, info);
+ dlasrt_("D", n, &d__[1], info);
+ zlascl_("G", &c__0, &c__0, &orgnrm, &c_b10, n, nrhs, &b[b_offset], ldb,
+ info);
+
+ return 0;
+
+/* End of ZLALSD */
+
+} /* zlalsd_ */
diff --git a/SRC/zlangb.c b/SRC/zlangb.c
new file mode 100644
index 0000000..0f64ade
--- /dev/null
+++ b/SRC/zlangb.c
@@ -0,0 +1,224 @@
+/* zlangb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zlangb_(char *norm, integer *n, integer *kl, integer *ku,
+ doublecomplex *ab, integer *ldab, doublereal *work)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal ret_val, d__1, d__2;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, l;
+ doublereal sum, scale;
+ extern logical lsame_(char *, char *);
+ doublereal value;
+ extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLANGB returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of an */
+/* n by n band matrix A, with kl sub-diagonals and ku super-diagonals. */
+
+/* Description */
+/* =========== */
+
+/* ZLANGB returns the value */
+
+/* ZLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in ZLANGB as described */
+/* above. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, ZLANGB is */
+/* set to zero. */
+
+/* KL (input) INTEGER */
+/* The number of sub-diagonals of the matrix A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of super-diagonals of the matrix A. KU >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
+/* The band matrix A, stored in rows 1 to KL+KU+1. The j-th */
+/* column of A is stored in the j-th column of the array AB as */
+/* follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = *ku + 2 - j;
+/* Computing MIN */
+ i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1;
+ i__3 = min(i__4,i__5);
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&ab[i__ + j * ab_dim1]);
+ value = max(d__1,d__2);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.;
+/* Computing MAX */
+ i__3 = *ku + 2 - j;
+/* Computing MIN */
+ i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1;
+ i__2 = min(i__4,i__5);
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+ sum += z_abs(&ab[i__ + j * ab_dim1]);
+/* L30: */
+ }
+ value = max(value,sum);
+/* L40: */
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L50: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ k = *ku + 1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *ku;
+/* Computing MIN */
+ i__5 = *n, i__6 = j + *kl;
+ i__4 = min(i__5,i__6);
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ work[i__] += z_abs(&ab[k + i__ + j * ab_dim1]);
+/* L60: */
+ }
+/* L70: */
+ }
+ value = 0.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = work[i__];
+ value = max(d__1,d__2);
+/* L80: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.;
+ sum = 1.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *ku;
+ l = max(i__4,i__2);
+ k = *ku + 1 - j + l;
+/* Computing MIN */
+ i__2 = *n, i__3 = j + *kl;
+ i__4 = min(i__2,i__3) - l + 1;
+ zlassq_(&i__4, &ab[k + j * ab_dim1], &c__1, &scale, &sum);
+/* L90: */
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of ZLANGB */
+
+} /* zlangb_ */
diff --git a/SRC/zlange.c b/SRC/zlange.c
new file mode 100644
index 0000000..28d6465
--- /dev/null
+++ b/SRC/zlange.c
@@ -0,0 +1,199 @@
+/* zlange.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zlange_(char *norm, integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublereal *work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal ret_val, d__1, d__2;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal sum, scale;
+ extern logical lsame_(char *, char *);
+ doublereal value;
+ extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLANGE returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* complex matrix A. */
+
+/* Description */
+/* =========== */
+
+/* ZLANGE returns the value */
+
+/* ZLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in ZLANGE as described */
+/* above. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. When M = 0, */
+/* ZLANGE is set to zero. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. When N = 0, */
+/* ZLANGE is set to zero. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(M,1). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ if (min(*m,*n) == 0) {
+ value = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * a_dim1]);
+ value = max(d__1,d__2);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.;
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ sum += z_abs(&a[i__ + j * a_dim1]);
+/* L30: */
+ }
+ value = max(value,sum);
+/* L40: */
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L50: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += z_abs(&a[i__ + j * a_dim1]);
+/* L60: */
+ }
+/* L70: */
+ }
+ value = 0.;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = work[i__];
+ value = max(d__1,d__2);
+/* L80: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.;
+ sum = 1.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ zlassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
+/* L90: */
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of ZLANGE */
+
+} /* zlange_ */
diff --git a/SRC/zlangt.c b/SRC/zlangt.c
new file mode 100644
index 0000000..02f244f
--- /dev/null
+++ b/SRC/zlangt.c
@@ -0,0 +1,195 @@
+/* zlangt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zlangt_(char *norm, integer *n, doublecomplex *dl, doublecomplex *
+ d__, doublecomplex *du)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal ret_val, d__1, d__2;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal sum, scale;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLANGT returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* complex tridiagonal matrix A. */
+
+/* Description */
+/* =========== */
+
+/* ZLANGT returns the value */
+
+/* ZLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in ZLANGT as described */
+/* above. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, ZLANGT is */
+/* set to zero. */
+
+/* DL (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) sub-diagonal elements of A. */
+
+/* D (input) COMPLEX*16 array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* DU (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) super-diagonal elements of A. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --du;
+ --d__;
+ --dl;
+
+ /* Function Body */
+ if (*n <= 0) {
+ anorm = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ anorm = z_abs(&d__[*n]);
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = anorm, d__2 = z_abs(&dl[i__]);
+ anorm = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = anorm, d__2 = z_abs(&d__[i__]);
+ anorm = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = anorm, d__2 = z_abs(&du[i__]);
+ anorm = max(d__1,d__2);
+/* L10: */
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ if (*n == 1) {
+ anorm = z_abs(&d__[1]);
+ } else {
+/* Computing MAX */
+ d__1 = z_abs(&d__[1]) + z_abs(&dl[1]), d__2 = z_abs(&d__[*n]) +
+ z_abs(&du[*n - 1]);
+ anorm = max(d__1,d__2);
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = anorm, d__2 = z_abs(&d__[i__]) + z_abs(&dl[i__]) +
+ z_abs(&du[i__ - 1]);
+ anorm = max(d__1,d__2);
+/* L20: */
+ }
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ if (*n == 1) {
+ anorm = z_abs(&d__[1]);
+ } else {
+/* Computing MAX */
+ d__1 = z_abs(&d__[1]) + z_abs(&du[1]), d__2 = z_abs(&d__[*n]) +
+ z_abs(&dl[*n - 1]);
+ anorm = max(d__1,d__2);
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = anorm, d__2 = z_abs(&d__[i__]) + z_abs(&du[i__]) +
+ z_abs(&dl[i__ - 1]);
+ anorm = max(d__1,d__2);
+/* L30: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.;
+ sum = 1.;
+ zlassq_(n, &d__[1], &c__1, &scale, &sum);
+ if (*n > 1) {
+ i__1 = *n - 1;
+ zlassq_(&i__1, &dl[1], &c__1, &scale, &sum);
+ i__1 = *n - 1;
+ zlassq_(&i__1, &du[1], &c__1, &scale, &sum);
+ }
+ anorm = scale * sqrt(sum);
+ }
+
+ ret_val = anorm;
+ return ret_val;
+
+/* End of ZLANGT */
+
+} /* zlangt_ */
diff --git a/SRC/zlanhb.c b/SRC/zlanhb.c
new file mode 100644
index 0000000..285565d
--- /dev/null
+++ b/SRC/zlanhb.c
@@ -0,0 +1,291 @@
+/* zlanhb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zlanhb_(char *norm, char *uplo, integer *n, integer *k,
+ doublecomplex *ab, integer *ldab, doublereal *work)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val, d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, l;
+ doublereal sum, absa, scale;
+ extern logical lsame_(char *, char *);
+ doublereal value;
+ extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLANHB returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of an */
+/* n by n hermitian band matrix A, with k super-diagonals. */
+
+/* Description */
+/* =========== */
+
+/* ZLANHB returns the value */
+
+/* ZLANHB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in ZLANHB as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* band matrix A is supplied. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, ZLANHB is */
+/* set to zero. */
+
+/* K (input) INTEGER */
+/* The number of super-diagonals or sub-diagonals of the */
+/* band matrix A. K >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
+/* The upper or lower triangle of the hermitian band matrix A, */
+/* stored in the first K+1 rows of AB. The j-th column of A is */
+/* stored in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set and are assumed to be zero. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= K+1. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
+/* WORK is not referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ i__3 = *k;
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&ab[i__ + j * ab_dim1]);
+ value = max(d__1,d__2);
+/* L10: */
+ }
+/* Computing MAX */
+ i__3 = *k + 1 + j * ab_dim1;
+ d__2 = value, d__3 = (d__1 = ab[i__3].r, abs(d__1));
+ value = max(d__2,d__3);
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__3 = j * ab_dim1 + 1;
+ d__2 = value, d__3 = (d__1 = ab[i__3].r, abs(d__1));
+ value = max(d__2,d__3);
+/* Computing MIN */
+ i__2 = *n + 1 - j, i__4 = *k + 1;
+ i__3 = min(i__2,i__4);
+ for (i__ = 2; i__ <= i__3; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&ab[i__ + j * ab_dim1]);
+ value = max(d__1,d__2);
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
+
+/* Find normI(A) ( = norm1(A), since A is hermitian). */
+
+ value = 0.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.;
+ l = *k + 1 - j;
+/* Computing MAX */
+ i__3 = 1, i__2 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__3,i__2); i__ <= i__4; ++i__) {
+ absa = z_abs(&ab[l + i__ + j * ab_dim1]);
+ sum += absa;
+ work[i__] += absa;
+/* L50: */
+ }
+ i__4 = *k + 1 + j * ab_dim1;
+ work[j] = sum + (d__1 = ab[i__4].r, abs(d__1));
+/* L60: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = work[i__];
+ value = max(d__1,d__2);
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L80: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = j * ab_dim1 + 1;
+ sum = work[j] + (d__1 = ab[i__4].r, abs(d__1));
+ l = 1 - j;
+/* Computing MIN */
+ i__3 = *n, i__2 = j + *k;
+ i__4 = min(i__3,i__2);
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ absa = z_abs(&ab[l + i__ + j * ab_dim1]);
+ sum += absa;
+ work[i__] += absa;
+/* L90: */
+ }
+ value = max(value,sum);
+/* L100: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.;
+ sum = 1.;
+ if (*k > 0) {
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j - 1;
+ i__4 = min(i__3,*k);
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ zlassq_(&i__4, &ab[max(i__2, 1)+ j * ab_dim1], &c__1, &
+ scale, &sum);
+/* L110: */
+ }
+ l = *k + 1;
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n - j;
+ i__4 = min(i__3,*k);
+ zlassq_(&i__4, &ab[j * ab_dim1 + 2], &c__1, &scale, &sum);
+/* L120: */
+ }
+ l = 1;
+ }
+ sum *= 2;
+ } else {
+ l = 1;
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = l + j * ab_dim1;
+ if (ab[i__4].r != 0.) {
+ i__4 = l + j * ab_dim1;
+ absa = (d__1 = ab[i__4].r, abs(d__1));
+ if (scale < absa) {
+/* Computing 2nd power */
+ d__1 = scale / absa;
+ sum = sum * (d__1 * d__1) + 1.;
+ scale = absa;
+ } else {
+/* Computing 2nd power */
+ d__1 = absa / scale;
+ sum += d__1 * d__1;
+ }
+ }
+/* L130: */
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of ZLANHB */
+
+} /* zlanhb_ */
diff --git a/SRC/zlanhe.c b/SRC/zlanhe.c
new file mode 100644
index 0000000..1a6f9ff
--- /dev/null
+++ b/SRC/zlanhe.c
@@ -0,0 +1,265 @@
+/* zlanhe.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zlanhe_(char *norm, char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublereal *work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal ret_val, d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal sum, absa, scale;
+ extern logical lsame_(char *, char *);
+ doublereal value;
+ extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLANHE returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* complex hermitian matrix A. */
+
+/* Description */
+/* =========== */
+
+/* ZLANHE returns the value */
+
+/* ZLANHE = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in ZLANHE as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* hermitian matrix A is to be referenced. */
+/* = 'U': Upper triangular part of A is referenced */
+/* = 'L': Lower triangular part of A is referenced */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, ZLANHE is */
+/* set to zero. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The hermitian matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of A contains the upper triangular part */
+/* of the matrix A, and the strictly lower triangular part of A */
+/* is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of A contains the lower triangular part of */
+/* the matrix A, and the strictly upper triangular part of A is */
+/* not referenced. Note that the imaginary parts of the diagonal */
+/* elements need not be set and are assumed to be zero. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(N,1). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
+/* WORK is not referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * a_dim1]);
+ value = max(d__1,d__2);
+/* L10: */
+ }
+/* Computing MAX */
+ i__2 = j + j * a_dim1;
+ d__2 = value, d__3 = (d__1 = a[i__2].r, abs(d__1));
+ value = max(d__2,d__3);
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j + j * a_dim1;
+ d__2 = value, d__3 = (d__1 = a[i__2].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * a_dim1]);
+ value = max(d__1,d__2);
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
+
+/* Find normI(A) ( = norm1(A), since A is hermitian). */
+
+ value = 0.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ absa = z_abs(&a[i__ + j * a_dim1]);
+ sum += absa;
+ work[i__] += absa;
+/* L50: */
+ }
+ i__2 = j + j * a_dim1;
+ work[j] = sum + (d__1 = a[i__2].r, abs(d__1));
+/* L60: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = work[i__];
+ value = max(d__1,d__2);
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L80: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * a_dim1;
+ sum = work[j] + (d__1 = a[i__2].r, abs(d__1));
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ absa = z_abs(&a[i__ + j * a_dim1]);
+ sum += absa;
+ work[i__] += absa;
+/* L90: */
+ }
+ value = max(value,sum);
+/* L100: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.;
+ sum = 1.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ zlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
+/* L110: */
+ }
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ zlassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum);
+/* L120: */
+ }
+ }
+ sum *= 2;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ if (a[i__2].r != 0.) {
+ i__2 = i__ + i__ * a_dim1;
+ absa = (d__1 = a[i__2].r, abs(d__1));
+ if (scale < absa) {
+/* Computing 2nd power */
+ d__1 = scale / absa;
+ sum = sum * (d__1 * d__1) + 1.;
+ scale = absa;
+ } else {
+/* Computing 2nd power */
+ d__1 = absa / scale;
+ sum += d__1 * d__1;
+ }
+ }
+/* L130: */
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of ZLANHE */
+
+} /* zlanhe_ */
diff --git a/SRC/zlanhf.c b/SRC/zlanhf.c
new file mode 100644
index 0000000..c78146d
--- /dev/null
+++ b/SRC/zlanhf.c
@@ -0,0 +1,1803 @@
+/* zlanhf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zlanhf_(char *norm, char *transr, char *uplo, integer *n,
+ doublecomplex *a, doublereal *work)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal ret_val, d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, l;
+ doublereal s;
+ integer n1;
+ doublereal aa;
+ integer lda, ifm, noe, ilu;
+ doublereal scale;
+ extern logical lsame_(char *, char *);
+ doublereal value;
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLANHF returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* complex Hermitian matrix A in RFP format. */
+
+/* Description */
+/* =========== */
+
+/* ZLANHF returns the value */
+
+/* ZLANHF = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER */
+/* Specifies the value to be returned in ZLANHF as described */
+/* above. */
+
+/* TRANSR (input) CHARACTER */
+/* Specifies whether the RFP format of A is normal or */
+/* conjugate-transposed format. */
+/* = 'N': RFP format is Normal */
+/* = 'C': RFP format is Conjugate-transposed */
+
+/* UPLO (input) CHARACTER */
+/* On entry, UPLO specifies whether the RFP matrix A came from */
+/* an upper or lower triangular matrix as follows: */
+
+/* UPLO = 'U' or 'u' RFP A came from an upper triangular */
+/* matrix */
+
+/* UPLO = 'L' or 'l' RFP A came from a lower triangular */
+/* matrix */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, ZLANHF is */
+/* set to zero. */
+
+/* A (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ); */
+/* On entry, the matrix A in RFP Format. */
+/* RFP Format is described by TRANSR, UPLO and N as follows: */
+/* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even; */
+/* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If */
+/* TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A */
+/* as defined when TRANSR = 'N'. The contents of RFP A are */
+/* defined by UPLO as follows: If UPLO = 'U' the RFP A */
+/* contains the ( N*(N+1)/2 ) elements of upper packed A */
+/* either in normal or conjugate-transpose Format. If */
+/* UPLO = 'L' the RFP A contains the ( N*(N+1) /2 ) elements */
+/* of lower packed A either in normal or conjugate-transpose */
+/* Format. The LDA of RFP A is (N+1)/2 when TRANSR = 'C'. When */
+/* TRANSR is 'N' the LDA is N+1 when N is even and is N when */
+/* is odd. See the Note below for more details. */
+/* Unchanged on exit. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), */
+/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
+/* WORK is not referenced. */
+
+/* Note: */
+/* ===== */
+
+/* We first consider Standard Packed Format when N is even. */
+/* We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* conjugate-transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* conjugate-transpose of the last three columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- -- */
+/* 03 04 05 33 43 53 */
+/* -- -- */
+/* 13 14 15 00 44 54 */
+/* -- */
+/* 23 24 25 10 11 55 */
+
+/* 33 34 35 20 21 22 */
+/* -- */
+/* 00 44 45 30 31 32 */
+/* -- -- */
+/* 01 11 55 40 41 42 */
+/* -- -- -- */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We next consider Standard Packed Format when N is odd. */
+/* We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* conjugate-transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* conjugate-transpose of the last two columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- */
+/* 02 03 04 00 33 43 */
+/* -- */
+/* 12 13 14 10 11 44 */
+
+/* 22 23 24 20 21 22 */
+/* -- */
+/* 00 33 34 30 31 32 */
+/* -- -- */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- */
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (*n == 0) {
+ ret_val = 0.;
+ return ret_val;
+ }
+
+/* set noe = 1 if n is odd. if n is even set noe=0 */
+
+ noe = 1;
+ if (*n % 2 == 0) {
+ noe = 0;
+ }
+
+/* set ifm = 0 when form='C' or 'c' and 1 otherwise */
+
+ ifm = 1;
+ if (lsame_(transr, "C")) {
+ ifm = 0;
+ }
+
+/* set ilu = 0 when uplo='U or 'u' and 1 otherwise */
+
+ ilu = 1;
+ if (lsame_(uplo, "U")) {
+ ilu = 0;
+ }
+
+/* set lda = (n+1)/2 when ifm = 0 */
+/* set lda = n when ifm = 1 and noe = 1 */
+/* set lda = n+1 when ifm = 1 and noe = 0 */
+
+ if (ifm == 1) {
+ if (noe == 1) {
+ lda = *n;
+ } else {
+/* noe=0 */
+ lda = *n + 1;
+ }
+ } else {
+/* ifm=0 */
+ lda = (*n + 1) / 2;
+ }
+
+ if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ k = (*n + 1) / 2;
+ value = 0.;
+ if (noe == 1) {
+/* n is odd & n = k + k - 1 */
+ if (ifm == 1) {
+/* A is n by k */
+ if (ilu == 1) {
+/* uplo ='L' */
+ j = 0;
+/* -> L(0,0) */
+/* Computing MAX */
+ i__1 = j + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__1].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 2;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ i__ = j - 1;
+/* L(k+j,k+j) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__2].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__ = j;
+/* -> L(j,j) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__2].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__2 = *n - 1;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ }
+ } else {
+/* uplo = 'U' */
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k + j - 2;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ i__ = k + j - 1;
+/* -> U(i,i) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__2].r, abs(d__1));
+ value = max(d__2,d__3);
+ ++i__;
+/* =k+j; i -> U(j,j) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__2].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__2 = *n - 1;
+ for (i__ = k + j + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ }
+ i__1 = *n - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+/* j=k-1 */
+ }
+/* i=n-1 -> U(n-1,n-1) */
+/* Computing MAX */
+ i__1 = i__ + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__1].r, abs(d__1));
+ value = max(d__2,d__3);
+ }
+ } else {
+/* xpose case; A is k by n */
+ if (ilu == 1) {
+/* uplo ='L' */
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ i__ = j;
+/* L(i,i) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__2].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__ = j + 1;
+/* L(j+k,j+k) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__2].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__2 = k - 1;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ }
+ j = k - 1;
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ i__ = k - 1;
+/* -> L(i,i) is at A(i,j) */
+/* Computing MAX */
+ i__1 = i__ + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__1].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ }
+ } else {
+/* uplo = 'U' */
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ }
+ j = k - 1;
+/* -> U(j,j) is at A(0,j) */
+/* Computing MAX */
+ i__1 = j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__1].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+ i__2 = j - k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ i__ = j - k;
+/* -> U(i,i) at A(i,j) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__2].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__ = j - k + 1;
+/* U(j,j) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__2].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__2 = k - 1;
+ for (i__ = j - k + 2; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ }
+ }
+ }
+ } else {
+/* n is even & k = n/2 */
+ if (ifm == 1) {
+/* A is n+1 by k */
+ if (ilu == 1) {
+/* uplo ='L' */
+ j = 0;
+/* -> L(k,k) & j=1 -> L(0,0) */
+/* Computing MAX */
+ i__1 = j + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__1].r, abs(d__1));
+ value = max(d__2,d__3);
+/* Computing MAX */
+ i__1 = j + 1 + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__1].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ i__ = j;
+/* L(k+j,k+j) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__2].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__ = j + 1;
+/* -> L(j,j) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__2].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__2 = *n;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ }
+ } else {
+/* uplo = 'U' */
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k + j - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ i__ = k + j;
+/* -> U(i,i) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__2].r, abs(d__1));
+ value = max(d__2,d__3);
+ ++i__;
+/* =k+j+1; i -> U(j,j) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__2].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__2 = *n;
+ for (i__ = k + j + 2; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ }
+ i__1 = *n - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+/* j=k-1 */
+ }
+/* i=n-1 -> U(n-1,n-1) */
+/* Computing MAX */
+ i__1 = i__ + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__1].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__ = *n;
+/* -> U(k-1,k-1) */
+/* Computing MAX */
+ i__1 = i__ + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__1].r, abs(d__1));
+ value = max(d__2,d__3);
+ }
+ } else {
+/* xpose case; A is k by n+1 */
+ if (ilu == 1) {
+/* uplo ='L' */
+ j = 0;
+/* -> L(k,k) at A(0,0) */
+/* Computing MAX */
+ i__1 = j + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__1].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 2;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ i__ = j - 1;
+/* L(i,i) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__2].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__ = j;
+/* L(j+k,j+k) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__2].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__2 = k - 1;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ }
+ j = k;
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ i__ = k - 1;
+/* -> L(i,i) is at A(i,j) */
+/* Computing MAX */
+ i__1 = i__ + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__1].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__1 = *n;
+ for (j = k + 1; j <= i__1; ++j) {
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ }
+ } else {
+/* uplo = 'U' */
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ }
+ j = k;
+/* -> U(j,j) is at A(0,j) */
+/* Computing MAX */
+ i__1 = j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__1].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ i__1 = *n - 1;
+ for (j = k + 1; j <= i__1; ++j) {
+ i__2 = j - k - 2;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ i__ = j - k - 1;
+/* -> U(i,i) at A(i,j) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__2].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__ = j - k;
+/* U(j,j) */
+/* Computing MAX */
+ i__2 = i__ + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__2].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__2 = k - 1;
+ for (i__ = j - k + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ }
+ j = *n;
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * lda]);
+ value = max(d__1,d__2);
+ }
+ i__ = k - 1;
+/* U(k,k) at A(i,j) */
+/* Computing MAX */
+ i__1 = i__ + j * lda;
+ d__2 = value, d__3 = (d__1 = a[i__1].r, abs(d__1));
+ value = max(d__2,d__3);
+ }
+ }
+ }
+ } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
+
+/* Find normI(A) ( = norm1(A), since A is Hermitian). */
+
+ if (ifm == 1) {
+/* A is 'N' */
+ k = *n / 2;
+ if (noe == 1) {
+/* n is odd & A is n by (n+1)/2 */
+ if (ilu == 0) {
+/* uplo = 'U' */
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+ }
+ i__1 = k;
+ for (j = 0; j <= i__1; ++j) {
+ s = 0.;
+ i__2 = k + j - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = z_abs(&a[i__ + j * lda]);
+/* -> A(i,j+k) */
+ s += aa;
+ work[i__] += aa;
+ }
+ i__2 = i__ + j * lda;
+ aa = (d__1 = a[i__2].r, abs(d__1));
+/* -> A(j+k,j+k) */
+ work[j + k] = s + aa;
+ if (i__ == k + k) {
+ goto L10;
+ }
+ ++i__;
+ i__2 = i__ + j * lda;
+ aa = (d__1 = a[i__2].r, abs(d__1));
+/* -> A(j,j) */
+ work[j] += aa;
+ s = 0.;
+ i__2 = k - 1;
+ for (l = j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = z_abs(&a[i__ + j * lda]);
+/* -> A(l,j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[j] += s;
+ }
+L10:
+ i__ = idamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ } else {
+/* ilu = 1 & uplo = 'L' */
+ ++k;
+/* k=(n+1)/2 for n odd and ilu=1 */
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+ }
+ for (j = k - 1; j >= 0; --j) {
+ s = 0.;
+ i__1 = j - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ aa = z_abs(&a[i__ + j * lda]);
+/* -> A(j+k,i+k) */
+ s += aa;
+ work[i__ + k] += aa;
+ }
+ if (j > 0) {
+ i__1 = i__ + j * lda;
+ aa = (d__1 = a[i__1].r, abs(d__1));
+/* -> A(j+k,j+k) */
+ s += aa;
+ work[i__ + k] += s;
+/* i=j */
+ ++i__;
+ }
+ i__1 = i__ + j * lda;
+ aa = (d__1 = a[i__1].r, abs(d__1));
+/* -> A(j,j) */
+ work[j] = aa;
+ s = 0.;
+ i__1 = *n - 1;
+ for (l = j + 1; l <= i__1; ++l) {
+ ++i__;
+ aa = z_abs(&a[i__ + j * lda]);
+/* -> A(l,j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[j] += s;
+ }
+ i__ = idamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ }
+ } else {
+/* n is even & A is n+1 by k = n/2 */
+ if (ilu == 0) {
+/* uplo = 'U' */
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+ }
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ s = 0.;
+ i__2 = k + j - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = z_abs(&a[i__ + j * lda]);
+/* -> A(i,j+k) */
+ s += aa;
+ work[i__] += aa;
+ }
+ i__2 = i__ + j * lda;
+ aa = (d__1 = a[i__2].r, abs(d__1));
+/* -> A(j+k,j+k) */
+ work[j + k] = s + aa;
+ ++i__;
+ i__2 = i__ + j * lda;
+ aa = (d__1 = a[i__2].r, abs(d__1));
+/* -> A(j,j) */
+ work[j] += aa;
+ s = 0.;
+ i__2 = k - 1;
+ for (l = j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = z_abs(&a[i__ + j * lda]);
+/* -> A(l,j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[j] += s;
+ }
+ i__ = idamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ } else {
+/* ilu = 1 & uplo = 'L' */
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+ }
+ for (j = k - 1; j >= 0; --j) {
+ s = 0.;
+ i__1 = j - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ aa = z_abs(&a[i__ + j * lda]);
+/* -> A(j+k,i+k) */
+ s += aa;
+ work[i__ + k] += aa;
+ }
+ i__1 = i__ + j * lda;
+ aa = (d__1 = a[i__1].r, abs(d__1));
+/* -> A(j+k,j+k) */
+ s += aa;
+ work[i__ + k] += s;
+/* i=j */
+ ++i__;
+ i__1 = i__ + j * lda;
+ aa = (d__1 = a[i__1].r, abs(d__1));
+/* -> A(j,j) */
+ work[j] = aa;
+ s = 0.;
+ i__1 = *n - 1;
+ for (l = j + 1; l <= i__1; ++l) {
+ ++i__;
+ aa = z_abs(&a[i__ + j * lda]);
+/* -> A(l,j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[j] += s;
+ }
+ i__ = idamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ }
+ }
+ } else {
+/* ifm=0 */
+ k = *n / 2;
+ if (noe == 1) {
+/* n is odd & A is (n+1)/2 by n */
+ if (ilu == 0) {
+/* uplo = 'U' */
+ n1 = k;
+/* n/2 */
+ ++k;
+/* k is the row size and lda */
+ i__1 = *n - 1;
+ for (i__ = n1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+ }
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ s = 0.;
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = z_abs(&a[i__ + j * lda]);
+/* A(j,n1+i) */
+ work[i__ + n1] += aa;
+ s += aa;
+ }
+ work[j] = s;
+ }
+/* j=n1=k-1 is special */
+ i__1 = j * lda;
+ s = (d__1 = a[i__1].r, abs(d__1));
+/* A(k-1,k-1) */
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ aa = z_abs(&a[i__ + j * lda]);
+/* A(k-1,i+n1) */
+ work[i__ + n1] += aa;
+ s += aa;
+ }
+ work[j] += s;
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+ s = 0.;
+ i__2 = j - k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = z_abs(&a[i__ + j * lda]);
+/* A(i,j-k) */
+ work[i__] += aa;
+ s += aa;
+ }
+/* i=j-k */
+ i__2 = i__ + j * lda;
+ aa = (d__1 = a[i__2].r, abs(d__1));
+/* A(j-k,j-k) */
+ s += aa;
+ work[j - k] += s;
+ ++i__;
+ i__2 = i__ + j * lda;
+ s = (d__1 = a[i__2].r, abs(d__1));
+/* A(j,j) */
+ i__2 = *n - 1;
+ for (l = j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = z_abs(&a[i__ + j * lda]);
+/* A(j,l) */
+ work[l] += aa;
+ s += aa;
+ }
+ work[j] += s;
+ }
+ i__ = idamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ } else {
+/* ilu=1 & uplo = 'L' */
+ ++k;
+/* k=(n+1)/2 for n odd and ilu=1 */
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+/* process */
+ s = 0.;
+ i__2 = j - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = z_abs(&a[i__ + j * lda]);
+/* A(j,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+ i__2 = i__ + j * lda;
+ aa = (d__1 = a[i__2].r, abs(d__1));
+/* i=j so process of A(j,j) */
+ s += aa;
+ work[j] = s;
+/* is initialised here */
+ ++i__;
+/* i=j process A(j+k,j+k) */
+ i__2 = i__ + j * lda;
+ aa = (d__1 = a[i__2].r, abs(d__1));
+ s = aa;
+ i__2 = *n - 1;
+ for (l = k + j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = z_abs(&a[i__ + j * lda]);
+/* A(l,k+j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[k + j] += s;
+ }
+/* j=k-1 is special :process col A(k-1,0:k-1) */
+ s = 0.;
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ aa = z_abs(&a[i__ + j * lda]);
+/* A(k,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+/* i=k-1 */
+ i__1 = i__ + j * lda;
+ aa = (d__1 = a[i__1].r, abs(d__1));
+/* A(k-1,k-1) */
+ s += aa;
+ work[i__] = s;
+/* done with col j=k+1 */
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+/* process col j of A = A(j,0:k-1) */
+ s = 0.;
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = z_abs(&a[i__ + j * lda]);
+/* A(j,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+ work[j] += s;
+ }
+ i__ = idamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ }
+ } else {
+/* n is even & A is k=n/2 by n+1 */
+ if (ilu == 0) {
+/* uplo = 'U' */
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+ }
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ s = 0.;
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = z_abs(&a[i__ + j * lda]);
+/* A(j,i+k) */
+ work[i__ + k] += aa;
+ s += aa;
+ }
+ work[j] = s;
+ }
+/* j=k */
+ i__1 = j * lda;
+ aa = (d__1 = a[i__1].r, abs(d__1));
+/* A(k,k) */
+ s = aa;
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ aa = z_abs(&a[i__ + j * lda]);
+/* A(k,k+i) */
+ work[i__ + k] += aa;
+ s += aa;
+ }
+ work[j] += s;
+ i__1 = *n - 1;
+ for (j = k + 1; j <= i__1; ++j) {
+ s = 0.;
+ i__2 = j - 2 - k;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = z_abs(&a[i__ + j * lda]);
+/* A(i,j-k-1) */
+ work[i__] += aa;
+ s += aa;
+ }
+/* i=j-1-k */
+ i__2 = i__ + j * lda;
+ aa = (d__1 = a[i__2].r, abs(d__1));
+/* A(j-k-1,j-k-1) */
+ s += aa;
+ work[j - k - 1] += s;
+ ++i__;
+ i__2 = i__ + j * lda;
+ aa = (d__1 = a[i__2].r, abs(d__1));
+/* A(j,j) */
+ s = aa;
+ i__2 = *n - 1;
+ for (l = j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = z_abs(&a[i__ + j * lda]);
+/* A(j,l) */
+ work[l] += aa;
+ s += aa;
+ }
+ work[j] += s;
+ }
+/* j=n */
+ s = 0.;
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ aa = z_abs(&a[i__ + j * lda]);
+/* A(i,k-1) */
+ work[i__] += aa;
+ s += aa;
+ }
+/* i=k-1 */
+ i__1 = i__ + j * lda;
+ aa = (d__1 = a[i__1].r, abs(d__1));
+/* A(k-1,k-1) */
+ s += aa;
+ work[i__] += s;
+ i__ = idamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ } else {
+/* ilu=1 & uplo = 'L' */
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+ }
+/* j=0 is special :process col A(k:n-1,k) */
+ s = (d__1 = a[0].r, abs(d__1));
+/* A(k,k) */
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ aa = z_abs(&a[i__]);
+/* A(k+i,k) */
+ work[i__ + k] += aa;
+ s += aa;
+ }
+ work[k] += s;
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* process */
+ s = 0.;
+ i__2 = j - 2;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = z_abs(&a[i__ + j * lda]);
+/* A(j-1,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+ i__2 = i__ + j * lda;
+ aa = (d__1 = a[i__2].r, abs(d__1));
+/* i=j-1 so process of A(j-1,j-1) */
+ s += aa;
+ work[j - 1] = s;
+/* is initialised here */
+ ++i__;
+/* i=j process A(j+k,j+k) */
+ i__2 = i__ + j * lda;
+ aa = (d__1 = a[i__2].r, abs(d__1));
+ s = aa;
+ i__2 = *n - 1;
+ for (l = k + j + 1; l <= i__2; ++l) {
+ ++i__;
+ aa = z_abs(&a[i__ + j * lda]);
+/* A(l,k+j) */
+ s += aa;
+ work[l] += aa;
+ }
+ work[k + j] += s;
+ }
+/* j=k is special :process col A(k,0:k-1) */
+ s = 0.;
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ aa = z_abs(&a[i__ + j * lda]);
+/* A(k,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+
+/* i=k-1 */
+ i__1 = i__ + j * lda;
+ aa = (d__1 = a[i__1].r, abs(d__1));
+/* A(k-1,k-1) */
+ s += aa;
+ work[i__] = s;
+/* done with col j=k+1 */
+ i__1 = *n;
+ for (j = k + 1; j <= i__1; ++j) {
+
+/* process col j-1 of A = A(j-1,0:k-1) */
+ s = 0.;
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ aa = z_abs(&a[i__ + j * lda]);
+/* A(j-1,i) */
+ work[i__] += aa;
+ s += aa;
+ }
+ work[j - 1] += s;
+ }
+ i__ = idamax_(n, work, &c__1);
+ value = work[i__ - 1];
+ }
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ k = (*n + 1) / 2;
+ scale = 0.;
+ s = 1.;
+ if (noe == 1) {
+/* n is odd */
+ if (ifm == 1) {
+/* A is normal & A is n by k */
+ if (ilu == 0) {
+/* A is upper */
+ i__1 = k - 3;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 2;
+ zlassq_(&i__2, &a[k + j + 1 + j * lda], &c__1, &scale,
+ &s);
+/* L at A(k,0) */
+ }
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k + j - 1;
+ zlassq_(&i__2, &a[j * lda], &c__1, &scale, &s);
+/* trap U at A(0,0) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ l = k - 1;
+/* -> U(k,k) at A(k-1,0) */
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = l;
+ aa = a[i__2].r;
+/* U(k+i,k+i) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ i__2 = l + 1;
+ aa = a[i__2].r;
+/* U(i,i) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ l = l + lda + 1;
+ }
+ i__1 = l;
+ aa = a[i__1].r;
+/* U(n-1,n-1) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ } else {
+/* ilu=1 & A is lower */
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - j - 1;
+ zlassq_(&i__2, &a[j + 1 + j * lda], &c__1, &scale, &s)
+ ;
+/* trap L at A(0,0) */
+ }
+ i__1 = k - 2;
+ for (j = 1; j <= i__1; ++j) {
+ zlassq_(&j, &a[(j + 1) * lda], &c__1, &scale, &s);
+/* U at A(0,1) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ aa = a[0].r;
+/* L(0,0) at A(0,0) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ l = lda;
+/* -> L(k,k) at A(0,1) */
+ i__1 = k - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = l;
+ aa = a[i__2].r;
+/* L(k-1+i,k-1+i) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ i__2 = l + 1;
+ aa = a[i__2].r;
+/* L(i,i) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ l = l + lda + 1;
+ }
+ }
+ } else {
+/* A is xpose & A is k by n */
+ if (ilu == 0) {
+/* A' is upper */
+ i__1 = k - 2;
+ for (j = 1; j <= i__1; ++j) {
+ zlassq_(&j, &a[(k + j) * lda], &c__1, &scale, &s);
+/* U at A(0,k) */
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ zlassq_(&k, &a[j * lda], &c__1, &scale, &s);
+/* k by k-1 rect. at A(0,0) */
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 1;
+ zlassq_(&i__2, &a[j + 1 + (j + k - 1) * lda], &c__1, &
+ scale, &s);
+/* L at A(0,k-1) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ l = k * lda - lda;
+/* -> U(k-1,k-1) at A(0,k-1) */
+ i__1 = l;
+ aa = a[i__1].r;
+/* U(k-1,k-1) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ l += lda;
+/* -> U(0,0) at A(0,k) */
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+ i__2 = l;
+ aa = a[i__2].r;
+/* -> U(j-k,j-k) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ i__2 = l + 1;
+ aa = a[i__2].r;
+/* -> U(j,j) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ l = l + lda + 1;
+ }
+ } else {
+/* A' is lower */
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ zlassq_(&j, &a[j * lda], &c__1, &scale, &s);
+/* U at A(0,0) */
+ }
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+ zlassq_(&k, &a[j * lda], &c__1, &scale, &s);
+/* k by k-1 rect. at A(0,k) */
+ }
+ i__1 = k - 3;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 2;
+ zlassq_(&i__2, &a[j + 2 + j * lda], &c__1, &scale, &s)
+ ;
+/* L at A(1,0) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ l = 0;
+/* -> L(0,0) at A(0,0) */
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = l;
+ aa = a[i__2].r;
+/* L(i,i) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ i__2 = l + 1;
+ aa = a[i__2].r;
+/* L(k+i,k+i) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ l = l + lda + 1;
+ }
+/* L-> k-1 + (k-1)*lda or L(k-1,k-1) at A(k-1,k-1) */
+ i__1 = l;
+ aa = a[i__1].r;
+/* L(k-1,k-1) at A(k-1,k-1) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ }
+ }
+ } else {
+/* n is even */
+ if (ifm == 1) {
+/* A is normal */
+ if (ilu == 0) {
+/* A is upper */
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 1;
+ zlassq_(&i__2, &a[k + j + 2 + j * lda], &c__1, &scale,
+ &s);
+/* L at A(k+1,0) */
+ }
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k + j;
+ zlassq_(&i__2, &a[j * lda], &c__1, &scale, &s);
+/* trap U at A(0,0) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ l = k;
+/* -> U(k,k) at A(k,0) */
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = l;
+ aa = a[i__2].r;
+/* U(k+i,k+i) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ i__2 = l + 1;
+ aa = a[i__2].r;
+/* U(i,i) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ l = l + lda + 1;
+ }
+ } else {
+/* ilu=1 & A is lower */
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - j - 1;
+ zlassq_(&i__2, &a[j + 2 + j * lda], &c__1, &scale, &s)
+ ;
+/* trap L at A(1,0) */
+ }
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ zlassq_(&j, &a[j * lda], &c__1, &scale, &s);
+/* U at A(0,0) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ l = 0;
+/* -> L(k,k) at A(0,0) */
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = l;
+ aa = a[i__2].r;
+/* L(k-1+i,k-1+i) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ i__2 = l + 1;
+ aa = a[i__2].r;
+/* L(i,i) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ l = l + lda + 1;
+ }
+ }
+ } else {
+/* A is xpose */
+ if (ilu == 0) {
+/* A' is upper */
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ zlassq_(&j, &a[(k + 1 + j) * lda], &c__1, &scale, &s);
+/* U at A(0,k+1) */
+ }
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ zlassq_(&k, &a[j * lda], &c__1, &scale, &s);
+/* k by k rect. at A(0,0) */
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 1;
+ zlassq_(&i__2, &a[j + 1 + (j + k) * lda], &c__1, &
+ scale, &s);
+/* L at A(0,k) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ l = k * lda;
+/* -> U(k,k) at A(0,k) */
+ i__1 = l;
+ aa = a[i__1].r;
+/* U(k,k) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ l += lda;
+/* -> U(0,0) at A(0,k+1) */
+ i__1 = *n - 1;
+ for (j = k + 1; j <= i__1; ++j) {
+ i__2 = l;
+ aa = a[i__2].r;
+/* -> U(j-k-1,j-k-1) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ i__2 = l + 1;
+ aa = a[i__2].r;
+/* -> U(j,j) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ l = l + lda + 1;
+ }
+/* L=k-1+n*lda */
+/* -> U(k-1,k-1) at A(k-1,n) */
+ i__1 = l;
+ aa = a[i__1].r;
+/* U(k,k) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ } else {
+/* A' is lower */
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ zlassq_(&j, &a[(j + 1) * lda], &c__1, &scale, &s);
+/* U at A(0,1) */
+ }
+ i__1 = *n;
+ for (j = k + 1; j <= i__1; ++j) {
+ zlassq_(&k, &a[j * lda], &c__1, &scale, &s);
+/* k by k rect. at A(0,k+1) */
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k - j - 1;
+ zlassq_(&i__2, &a[j + 1 + j * lda], &c__1, &scale, &s)
+ ;
+/* L at A(0,0) */
+ }
+ s += s;
+/* double s for the off diagonal elements */
+ l = 0;
+/* -> L(k,k) at A(0,0) */
+ i__1 = l;
+ aa = a[i__1].r;
+/* L(k,k) at A(0,0) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ l = lda;
+/* -> L(0,0) at A(0,1) */
+ i__1 = k - 2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = l;
+ aa = a[i__2].r;
+/* L(i,i) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ i__2 = l + 1;
+ aa = a[i__2].r;
+/* L(k+i+1,k+i+1) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ l = l + lda + 1;
+ }
+/* L-> k - 1 + k*lda or L(k-1,k-1) at A(k-1,k) */
+ i__1 = l;
+ aa = a[i__1].r;
+/* L(k-1,k-1) at A(k-1,k) */
+ if (aa != 0.) {
+ if (scale < aa) {
+/* Computing 2nd power */
+ d__1 = scale / aa;
+ s = s * (d__1 * d__1) + 1.;
+ scale = aa;
+ } else {
+/* Computing 2nd power */
+ d__1 = aa / scale;
+ s += d__1 * d__1;
+ }
+ }
+ }
+ }
+ }
+ value = scale * sqrt(s);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of ZLANHF */
+
+} /* zlanhf_ */
diff --git a/SRC/zlanhp.c b/SRC/zlanhp.c
new file mode 100644
index 0000000..80c8cd2
--- /dev/null
+++ b/SRC/zlanhp.c
@@ -0,0 +1,277 @@
+/* zlanhp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zlanhp_(char *norm, char *uplo, integer *n, doublecomplex *ap,
+ doublereal *work)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal ret_val, d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal sum, absa, scale;
+ extern logical lsame_(char *, char *);
+ doublereal value;
+ extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLANHP returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* complex hermitian matrix A, supplied in packed form. */
+
+/* Description */
+/* =========== */
+
+/* ZLANHP returns the value */
+
+/* ZLANHP = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in ZLANHP as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* hermitian matrix A is supplied. */
+/* = 'U': Upper triangular part of A is supplied */
+/* = 'L': Lower triangular part of A is supplied */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, ZLANHP is */
+/* set to zero. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the hermitian matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set and are assumed to be zero. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
+/* WORK is not referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --ap;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.;
+ if (lsame_(uplo, "U")) {
+ k = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j - 1;
+ for (i__ = k + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&ap[i__]);
+ value = max(d__1,d__2);
+/* L10: */
+ }
+ k += j;
+/* Computing MAX */
+ i__2 = k;
+ d__2 = value, d__3 = (d__1 = ap[i__2].r, abs(d__1));
+ value = max(d__2,d__3);
+/* L20: */
+ }
+ } else {
+ k = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = k;
+ d__2 = value, d__3 = (d__1 = ap[i__2].r, abs(d__1));
+ value = max(d__2,d__3);
+ i__2 = k + *n - j;
+ for (i__ = k + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&ap[i__]);
+ value = max(d__1,d__2);
+/* L30: */
+ }
+ k = k + *n - j + 1;
+/* L40: */
+ }
+ }
+ } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
+
+/* Find normI(A) ( = norm1(A), since A is hermitian). */
+
+ value = 0.;
+ k = 1;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ absa = z_abs(&ap[k]);
+ sum += absa;
+ work[i__] += absa;
+ ++k;
+/* L50: */
+ }
+ i__2 = k;
+ work[j] = sum + (d__1 = ap[i__2].r, abs(d__1));
+ ++k;
+/* L60: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = work[i__];
+ value = max(d__1,d__2);
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L80: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k;
+ sum = work[j] + (d__1 = ap[i__2].r, abs(d__1));
+ ++k;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ absa = z_abs(&ap[k]);
+ sum += absa;
+ work[i__] += absa;
+ ++k;
+/* L90: */
+ }
+ value = max(value,sum);
+/* L100: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.;
+ sum = 1.;
+ k = 2;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ zlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k += j;
+/* L110: */
+ }
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ zlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k = k + *n - j + 1;
+/* L120: */
+ }
+ }
+ sum *= 2;
+ k = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = k;
+ if (ap[i__2].r != 0.) {
+ i__2 = k;
+ absa = (d__1 = ap[i__2].r, abs(d__1));
+ if (scale < absa) {
+/* Computing 2nd power */
+ d__1 = scale / absa;
+ sum = sum * (d__1 * d__1) + 1.;
+ scale = absa;
+ } else {
+/* Computing 2nd power */
+ d__1 = absa / scale;
+ sum += d__1 * d__1;
+ }
+ }
+ if (lsame_(uplo, "U")) {
+ k = k + i__ + 1;
+ } else {
+ k = k + *n - i__ + 1;
+ }
+/* L130: */
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of ZLANHP */
+
+} /* zlanhp_ */
diff --git a/SRC/zlanhs.c b/SRC/zlanhs.c
new file mode 100644
index 0000000..77f25f7
--- /dev/null
+++ b/SRC/zlanhs.c
@@ -0,0 +1,205 @@
+/* zlanhs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zlanhs_(char *norm, integer *n, doublecomplex *a, integer *lda,
+ doublereal *work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val, d__1, d__2;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal sum, scale;
+ extern logical lsame_(char *, char *);
+ doublereal value;
+ extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLANHS returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* Hessenberg matrix A. */
+
+/* Description */
+/* =========== */
+
+/* ZLANHS returns the value */
+
+/* ZLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in ZLANHS as described */
+/* above. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, ZLANHS is */
+/* set to zero. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The n by n upper Hessenberg matrix A; the part of A below the */
+/* first sub-diagonal is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(N,1). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n, i__4 = j + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * a_dim1]);
+ value = max(d__1,d__2);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.;
+/* Computing MIN */
+ i__3 = *n, i__4 = j + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ sum += z_abs(&a[i__ + j * a_dim1]);
+/* L30: */
+ }
+ value = max(value,sum);
+/* L40: */
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L50: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n, i__4 = j + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += z_abs(&a[i__ + j * a_dim1]);
+/* L60: */
+ }
+/* L70: */
+ }
+ value = 0.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = work[i__];
+ value = max(d__1,d__2);
+/* L80: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.;
+ sum = 1.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n, i__4 = j + 1;
+ i__2 = min(i__3,i__4);
+ zlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
+/* L90: */
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of ZLANHS */
+
+} /* zlanhs_ */
diff --git a/SRC/zlanht.c b/SRC/zlanht.c
new file mode 100644
index 0000000..6eac013
--- /dev/null
+++ b/SRC/zlanht.c
@@ -0,0 +1,167 @@
+/* zlanht.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zlanht_(char *norm, integer *n, doublereal *d__, doublecomplex *e)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal ret_val, d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal sum, scale;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
+ doublereal *, doublereal *), zlassq_(integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLANHT returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* complex Hermitian tridiagonal matrix A. */
+
+/* Description */
+/* =========== */
+
+/* ZLANHT returns the value */
+
+/* ZLANHT = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in ZLANHT as described */
+/* above. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, ZLANHT is */
+/* set to zero. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* E (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) sub-diagonal or super-diagonal elements of A. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --e;
+ --d__;
+
+ /* Function Body */
+ if (*n <= 0) {
+ anorm = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ anorm = (d__1 = d__[*n], abs(d__1));
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = anorm, d__3 = (d__1 = d__[i__], abs(d__1));
+ anorm = max(d__2,d__3);
+/* Computing MAX */
+ d__1 = anorm, d__2 = z_abs(&e[i__]);
+ anorm = max(d__1,d__2);
+/* L10: */
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1' || lsame_(norm, "I")) {
+
+/* Find norm1(A). */
+
+ if (*n == 1) {
+ anorm = abs(d__[1]);
+ } else {
+/* Computing MAX */
+ d__2 = abs(d__[1]) + z_abs(&e[1]), d__3 = z_abs(&e[*n - 1]) + (
+ d__1 = d__[*n], abs(d__1));
+ anorm = max(d__2,d__3);
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = anorm, d__3 = (d__1 = d__[i__], abs(d__1)) + z_abs(&e[
+ i__]) + z_abs(&e[i__ - 1]);
+ anorm = max(d__2,d__3);
+/* L20: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.;
+ sum = 1.;
+ if (*n > 1) {
+ i__1 = *n - 1;
+ zlassq_(&i__1, &e[1], &c__1, &scale, &sum);
+ sum *= 2;
+ }
+ dlassq_(n, &d__[1], &c__1, &scale, &sum);
+ anorm = scale * sqrt(sum);
+ }
+
+ ret_val = anorm;
+ return ret_val;
+
+/* End of ZLANHT */
+
+} /* zlanht_ */
diff --git a/SRC/zlansb.c b/SRC/zlansb.c
new file mode 100644
index 0000000..6d3c11c
--- /dev/null
+++ b/SRC/zlansb.c
@@ -0,0 +1,261 @@
+/* zlansb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zlansb_(char *norm, char *uplo, integer *n, integer *k,
+ doublecomplex *ab, integer *ldab, doublereal *work)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val, d__1, d__2;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, l;
+ doublereal sum, absa, scale;
+ extern logical lsame_(char *, char *);
+ doublereal value;
+ extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLANSB returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of an */
+/* n by n symmetric band matrix A, with k super-diagonals. */
+
+/* Description */
+/* =========== */
+
+/* ZLANSB returns the value */
+
+/* ZLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in ZLANSB as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* band matrix A is supplied. */
+/* = 'U': Upper triangular part is supplied */
+/* = 'L': Lower triangular part is supplied */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, ZLANSB is */
+/* set to zero. */
+
+/* K (input) INTEGER */
+/* The number of super-diagonals or sub-diagonals of the */
+/* band matrix A. K >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
+/* The upper or lower triangle of the symmetric band matrix A, */
+/* stored in the first K+1 rows of AB. The j-th column of A is */
+/* stored in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= K+1. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
+/* WORK is not referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ i__3 = *k + 1;
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&ab[i__ + j * ab_dim1]);
+ value = max(d__1,d__2);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *n + 1 - j, i__4 = *k + 1;
+ i__3 = min(i__2,i__4);
+ for (i__ = 1; i__ <= i__3; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&ab[i__ + j * ab_dim1]);
+ value = max(d__1,d__2);
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
+
+/* Find normI(A) ( = norm1(A), since A is symmetric). */
+
+ value = 0.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.;
+ l = *k + 1 - j;
+/* Computing MAX */
+ i__3 = 1, i__2 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__3,i__2); i__ <= i__4; ++i__) {
+ absa = z_abs(&ab[l + i__ + j * ab_dim1]);
+ sum += absa;
+ work[i__] += absa;
+/* L50: */
+ }
+ work[j] = sum + z_abs(&ab[*k + 1 + j * ab_dim1]);
+/* L60: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = work[i__];
+ value = max(d__1,d__2);
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L80: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = work[j] + z_abs(&ab[j * ab_dim1 + 1]);
+ l = 1 - j;
+/* Computing MIN */
+ i__3 = *n, i__2 = j + *k;
+ i__4 = min(i__3,i__2);
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ absa = z_abs(&ab[l + i__ + j * ab_dim1]);
+ sum += absa;
+ work[i__] += absa;
+/* L90: */
+ }
+ value = max(value,sum);
+/* L100: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.;
+ sum = 1.;
+ if (*k > 0) {
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j - 1;
+ i__4 = min(i__3,*k);
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ zlassq_(&i__4, &ab[max(i__2, 1)+ j * ab_dim1], &c__1, &
+ scale, &sum);
+/* L110: */
+ }
+ l = *k + 1;
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n - j;
+ i__4 = min(i__3,*k);
+ zlassq_(&i__4, &ab[j * ab_dim1 + 2], &c__1, &scale, &sum);
+/* L120: */
+ }
+ l = 1;
+ }
+ sum *= 2;
+ } else {
+ l = 1;
+ }
+ zlassq_(n, &ab[l + ab_dim1], ldab, &scale, &sum);
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of ZLANSB */
+
+} /* zlansb_ */
diff --git a/SRC/zlansp.c b/SRC/zlansp.c
new file mode 100644
index 0000000..35260bb
--- /dev/null
+++ b/SRC/zlansp.c
@@ -0,0 +1,278 @@
+/* zlansp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zlansp_(char *norm, char *uplo, integer *n, doublecomplex *ap,
+ doublereal *work)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal ret_val, d__1, d__2;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *), d_imag(doublecomplex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal sum, absa, scale;
+ extern logical lsame_(char *, char *);
+ doublereal value;
+ extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLANSP returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* complex symmetric matrix A, supplied in packed form. */
+
+/* Description */
+/* =========== */
+
+/* ZLANSP returns the value */
+
+/* ZLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in ZLANSP as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is supplied. */
+/* = 'U': Upper triangular part of A is supplied */
+/* = 'L': Lower triangular part of A is supplied */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, ZLANSP is */
+/* set to zero. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the symmetric matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
+/* WORK is not referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --ap;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.;
+ if (lsame_(uplo, "U")) {
+ k = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&ap[i__]);
+ value = max(d__1,d__2);
+/* L10: */
+ }
+ k += j;
+/* L20: */
+ }
+ } else {
+ k = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + *n - j;
+ for (i__ = k; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&ap[i__]);
+ value = max(d__1,d__2);
+/* L30: */
+ }
+ k = k + *n - j + 1;
+/* L40: */
+ }
+ }
+ } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
+
+/* Find normI(A) ( = norm1(A), since A is symmetric). */
+
+ value = 0.;
+ k = 1;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ absa = z_abs(&ap[k]);
+ sum += absa;
+ work[i__] += absa;
+ ++k;
+/* L50: */
+ }
+ work[j] = sum + z_abs(&ap[k]);
+ ++k;
+/* L60: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = work[i__];
+ value = max(d__1,d__2);
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L80: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = work[j] + z_abs(&ap[k]);
+ ++k;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ absa = z_abs(&ap[k]);
+ sum += absa;
+ work[i__] += absa;
+ ++k;
+/* L90: */
+ }
+ value = max(value,sum);
+/* L100: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.;
+ sum = 1.;
+ k = 2;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ zlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k += j;
+/* L110: */
+ }
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ zlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k = k + *n - j + 1;
+/* L120: */
+ }
+ }
+ sum *= 2;
+ k = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = k;
+ if (ap[i__2].r != 0.) {
+ i__2 = k;
+ absa = (d__1 = ap[i__2].r, abs(d__1));
+ if (scale < absa) {
+/* Computing 2nd power */
+ d__1 = scale / absa;
+ sum = sum * (d__1 * d__1) + 1.;
+ scale = absa;
+ } else {
+/* Computing 2nd power */
+ d__1 = absa / scale;
+ sum += d__1 * d__1;
+ }
+ }
+ if (d_imag(&ap[k]) != 0.) {
+ absa = (d__1 = d_imag(&ap[k]), abs(d__1));
+ if (scale < absa) {
+/* Computing 2nd power */
+ d__1 = scale / absa;
+ sum = sum * (d__1 * d__1) + 1.;
+ scale = absa;
+ } else {
+/* Computing 2nd power */
+ d__1 = absa / scale;
+ sum += d__1 * d__1;
+ }
+ }
+ if (lsame_(uplo, "U")) {
+ k = k + i__ + 1;
+ } else {
+ k = k + *n - i__ + 1;
+ }
+/* L130: */
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of ZLANSP */
+
+} /* zlansp_ */
diff --git a/SRC/zlansy.c b/SRC/zlansy.c
new file mode 100644
index 0000000..6239fdd
--- /dev/null
+++ b/SRC/zlansy.c
@@ -0,0 +1,237 @@
+/* zlansy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zlansy_(char *norm, char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublereal *work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal ret_val, d__1, d__2;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal sum, absa, scale;
+ extern logical lsame_(char *, char *);
+ doublereal value;
+ extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLANSY returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* complex symmetric matrix A. */
+
+/* Description */
+/* =========== */
+
+/* ZLANSY returns the value */
+
+/* ZLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in ZLANSY as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is to be referenced. */
+/* = 'U': Upper triangular part of A is referenced */
+/* = 'L': Lower triangular part of A is referenced */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, ZLANSY is */
+/* set to zero. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of A contains the upper triangular part */
+/* of the matrix A, and the strictly lower triangular part of A */
+/* is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of A contains the lower triangular part of */
+/* the matrix A, and the strictly upper triangular part of A is */
+/* not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(N,1). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */
+/* WORK is not referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ value = 0.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * a_dim1]);
+ value = max(d__1,d__2);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * a_dim1]);
+ value = max(d__1,d__2);
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
+
+/* Find normI(A) ( = norm1(A), since A is symmetric). */
+
+ value = 0.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = 0.;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ absa = z_abs(&a[i__ + j * a_dim1]);
+ sum += absa;
+ work[i__] += absa;
+/* L50: */
+ }
+ work[j] = sum + z_abs(&a[j + j * a_dim1]);
+/* L60: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = work[i__];
+ value = max(d__1,d__2);
+/* L70: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L80: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sum = work[j] + z_abs(&a[j + j * a_dim1]);
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ absa = z_abs(&a[i__ + j * a_dim1]);
+ sum += absa;
+ work[i__] += absa;
+/* L90: */
+ }
+ value = max(value,sum);
+/* L100: */
+ }
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ scale = 0.;
+ sum = 1.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ zlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
+/* L110: */
+ }
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ zlassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, &scale, &sum);
+/* L120: */
+ }
+ }
+ sum *= 2;
+ i__1 = *lda + 1;
+ zlassq_(n, &a[a_offset], &i__1, &scale, &sum);
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of ZLANSY */
+
+} /* zlansy_ */
diff --git a/SRC/zlantb.c b/SRC/zlantb.c
new file mode 100644
index 0000000..28ad3e2
--- /dev/null
+++ b/SRC/zlantb.c
@@ -0,0 +1,426 @@
+/* zlantb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zlantb_(char *norm, char *uplo, char *diag, integer *n, integer *k,
+ doublecomplex *ab, integer *ldab, doublereal *work)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal ret_val, d__1, d__2;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, l;
+ doublereal sum, scale;
+ logical udiag;
+ extern logical lsame_(char *, char *);
+ doublereal value;
+ extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLANTB returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of an */
+/* n by n triangular band matrix A, with ( k + 1 ) diagonals. */
+
+/* Description */
+/* =========== */
+
+/* ZLANTB returns the value */
+
+/* ZLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in ZLANTB as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, ZLANTB is */
+/* set to zero. */
+
+/* K (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals of the matrix A if UPLO = 'L'. */
+/* K >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first k+1 rows of AB. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). */
+/* Note that when DIAG = 'U', the elements of the array AB */
+/* corresponding to the diagonal elements of the matrix A are */
+/* not referenced, but are assumed to be one. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= K+1. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ if (lsame_(diag, "U")) {
+ value = 1.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ i__3 = *k;
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&ab[i__ + j * ab_dim1]);
+ value = max(d__1,d__2);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *n + 1 - j, i__4 = *k + 1;
+ i__3 = min(i__2,i__4);
+ for (i__ = 2; i__ <= i__3; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&ab[i__ + j * ab_dim1]);
+ value = max(d__1,d__2);
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else {
+ value = 0.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__3 = *k + 2 - j;
+ i__2 = *k + 1;
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&ab[i__ + j * ab_dim1]);
+ value = max(d__1,d__2);
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n + 1 - j, i__4 = *k + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&ab[i__ + j * ab_dim1]);
+ value = max(d__1,d__2);
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.;
+ udiag = lsame_(diag, "U");
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag) {
+ sum = 1.;
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ i__3 = *k;
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+ sum += z_abs(&ab[i__ + j * ab_dim1]);
+/* L90: */
+ }
+ } else {
+ sum = 0.;
+/* Computing MAX */
+ i__3 = *k + 2 - j;
+ i__2 = *k + 1;
+ for (i__ = max(i__3,1); i__ <= i__2; ++i__) {
+ sum += z_abs(&ab[i__ + j * ab_dim1]);
+/* L100: */
+ }
+ }
+ value = max(value,sum);
+/* L110: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag) {
+ sum = 1.;
+/* Computing MIN */
+ i__3 = *n + 1 - j, i__4 = *k + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ sum += z_abs(&ab[i__ + j * ab_dim1]);
+/* L120: */
+ }
+ } else {
+ sum = 0.;
+/* Computing MIN */
+ i__3 = *n + 1 - j, i__4 = *k + 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ sum += z_abs(&ab[i__ + j * ab_dim1]);
+/* L130: */
+ }
+ }
+ value = max(value,sum);
+/* L140: */
+ }
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ value = 0.;
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.;
+/* L150: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ l = *k + 1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ work[i__] += z_abs(&ab[l + i__ + j * ab_dim1]);
+/* L160: */
+ }
+/* L170: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L180: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ l = *k + 1 - j;
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *k;
+ i__3 = j;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ work[i__] += z_abs(&ab[l + i__ + j * ab_dim1]);
+/* L190: */
+ }
+/* L200: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.;
+/* L210: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ l = 1 - j;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ work[i__] += z_abs(&ab[l + i__ + j * ab_dim1]);
+/* L220: */
+ }
+/* L230: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L240: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ l = 1 - j;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j; i__ <= i__3; ++i__) {
+ work[i__] += z_abs(&ab[l + i__ + j * ab_dim1]);
+/* L250: */
+ }
+/* L260: */
+ }
+ }
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = work[i__];
+ value = max(d__1,d__2);
+/* L270: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ scale = 1.;
+ sum = (doublereal) (*n);
+ if (*k > 0) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = j - 1;
+ i__3 = min(i__4,*k);
+/* Computing MAX */
+ i__2 = *k + 2 - j;
+ zlassq_(&i__3, &ab[max(i__2, 1)+ j * ab_dim1], &c__1,
+ &scale, &sum);
+/* L280: */
+ }
+ }
+ } else {
+ scale = 0.;
+ sum = 1.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = j, i__2 = *k + 1;
+ i__3 = min(i__4,i__2);
+/* Computing MAX */
+ i__5 = *k + 2 - j;
+ zlassq_(&i__3, &ab[max(i__5, 1)+ j * ab_dim1], &c__1, &
+ scale, &sum);
+/* L290: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ scale = 1.;
+ sum = (doublereal) (*n);
+ if (*k > 0) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = *n - j;
+ i__3 = min(i__4,*k);
+ zlassq_(&i__3, &ab[j * ab_dim1 + 2], &c__1, &scale, &
+ sum);
+/* L300: */
+ }
+ }
+ } else {
+ scale = 0.;
+ sum = 1.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = *n - j + 1, i__2 = *k + 1;
+ i__3 = min(i__4,i__2);
+ zlassq_(&i__3, &ab[j * ab_dim1 + 1], &c__1, &scale, &sum);
+/* L310: */
+ }
+ }
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of ZLANTB */
+
+} /* zlantb_ */
diff --git a/SRC/zlantp.c b/SRC/zlantp.c
new file mode 100644
index 0000000..ffcfddf
--- /dev/null
+++ b/SRC/zlantp.c
@@ -0,0 +1,391 @@
+/* zlantp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zlantp_(char *norm, char *uplo, char *diag, integer *n,
+ doublecomplex *ap, doublereal *work)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal ret_val, d__1, d__2;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal sum, scale;
+ logical udiag;
+ extern logical lsame_(char *, char *);
+ doublereal value;
+ extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLANTP returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* triangular matrix A, supplied in packed form. */
+
+/* Description */
+/* =========== */
+
+/* ZLANTP returns the value */
+
+/* ZLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in ZLANTP as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. When N = 0, ZLANTP is */
+/* set to zero. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* Note that when DIAG = 'U', the elements of the array AP */
+/* corresponding to the diagonal elements of the matrix A are */
+/* not referenced, but are assumed to be one. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= N when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --ap;
+
+ /* Function Body */
+ if (*n == 0) {
+ value = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ k = 1;
+ if (lsame_(diag, "U")) {
+ value = 1.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j - 2;
+ for (i__ = k; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&ap[i__]);
+ value = max(d__1,d__2);
+/* L10: */
+ }
+ k += j;
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + *n - j;
+ for (i__ = k + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&ap[i__]);
+ value = max(d__1,d__2);
+/* L30: */
+ }
+ k = k + *n - j + 1;
+/* L40: */
+ }
+ }
+ } else {
+ value = 0.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&ap[i__]);
+ value = max(d__1,d__2);
+/* L50: */
+ }
+ k += j;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + *n - j;
+ for (i__ = k; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&ap[i__]);
+ value = max(d__1,d__2);
+/* L70: */
+ }
+ k = k + *n - j + 1;
+/* L80: */
+ }
+ }
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.;
+ k = 1;
+ udiag = lsame_(diag, "U");
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag) {
+ sum = 1.;
+ i__2 = k + j - 2;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ sum += z_abs(&ap[i__]);
+/* L90: */
+ }
+ } else {
+ sum = 0.;
+ i__2 = k + j - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ sum += z_abs(&ap[i__]);
+/* L100: */
+ }
+ }
+ k += j;
+ value = max(value,sum);
+/* L110: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag) {
+ sum = 1.;
+ i__2 = k + *n - j;
+ for (i__ = k + 1; i__ <= i__2; ++i__) {
+ sum += z_abs(&ap[i__]);
+/* L120: */
+ }
+ } else {
+ sum = 0.;
+ i__2 = k + *n - j;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ sum += z_abs(&ap[i__]);
+/* L130: */
+ }
+ }
+ k = k + *n - j + 1;
+ value = max(value,sum);
+/* L140: */
+ }
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ k = 1;
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.;
+/* L150: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += z_abs(&ap[k]);
+ ++k;
+/* L160: */
+ }
+ ++k;
+/* L170: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L180: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += z_abs(&ap[k]);
+ ++k;
+/* L190: */
+ }
+/* L200: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.;
+/* L210: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ++k;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ work[i__] += z_abs(&ap[k]);
+ ++k;
+/* L220: */
+ }
+/* L230: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L240: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ work[i__] += z_abs(&ap[k]);
+ ++k;
+/* L250: */
+ }
+/* L260: */
+ }
+ }
+ }
+ value = 0.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = work[i__];
+ value = max(d__1,d__2);
+/* L270: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ scale = 1.;
+ sum = (doublereal) (*n);
+ k = 2;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ zlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k += j;
+/* L280: */
+ }
+ } else {
+ scale = 0.;
+ sum = 1.;
+ k = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ zlassq_(&j, &ap[k], &c__1, &scale, &sum);
+ k += j;
+/* L290: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ scale = 1.;
+ sum = (doublereal) (*n);
+ k = 2;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ zlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k = k + *n - j + 1;
+/* L300: */
+ }
+ } else {
+ scale = 0.;
+ sum = 1.;
+ k = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ zlassq_(&i__2, &ap[k], &c__1, &scale, &sum);
+ k = k + *n - j + 1;
+/* L310: */
+ }
+ }
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of ZLANTP */
+
+} /* zlantp_ */
diff --git a/SRC/zlantr.c b/SRC/zlantr.c
new file mode 100644
index 0000000..43ddb89
--- /dev/null
+++ b/SRC/zlantr.c
@@ -0,0 +1,394 @@
+/* zlantr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal zlantr_(char *norm, char *uplo, char *diag, integer *m, integer *n,
+ doublecomplex *a, integer *lda, doublereal *work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val, d__1, d__2;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal sum, scale;
+ logical udiag;
+ extern logical lsame_(char *, char *);
+ doublereal value;
+ extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLANTR returns the value of the one norm, or the Frobenius norm, or */
+/* the infinity norm, or the element of largest absolute value of a */
+/* trapezoidal or triangular matrix A. */
+
+/* Description */
+/* =========== */
+
+/* ZLANTR returns the value */
+
+/* ZLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/* ( */
+/* ( norm1(A), NORM = '1', 'O' or 'o' */
+/* ( */
+/* ( normI(A), NORM = 'I' or 'i' */
+/* ( */
+/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */
+
+/* where norm1 denotes the one norm of a matrix (maximum column sum), */
+/* normI denotes the infinity norm of a matrix (maximum row sum) and */
+/* normF denotes the Frobenius norm of a matrix (square root of sum of */
+/* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies the value to be returned in ZLANTR as described */
+/* above. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower trapezoidal. */
+/* = 'U': Upper trapezoidal */
+/* = 'L': Lower trapezoidal */
+/* Note that A is triangular instead of trapezoidal if M = N. */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A has unit diagonal. */
+/* = 'N': Non-unit diagonal */
+/* = 'U': Unit diagonal */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0, and if */
+/* UPLO = 'U', M <= N. When M = 0, ZLANTR is set to zero. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0, and if */
+/* UPLO = 'L', N <= M. When N = 0, ZLANTR is set to zero. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The trapezoidal matrix A (A is triangular if M = N). */
+/* If UPLO = 'U', the leading m by n upper trapezoidal part of */
+/* the array A contains the upper trapezoidal matrix, and the */
+/* strictly lower triangular part of A is not referenced. */
+/* If UPLO = 'L', the leading m by n lower trapezoidal part of */
+/* the array A contains the lower trapezoidal matrix, and the */
+/* strictly upper triangular part of A is not referenced. Note */
+/* that when DIAG = 'U', the diagonal elements of A are not */
+/* referenced and are assumed to be one. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(M,1). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
+/* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */
+/* referenced. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ if (min(*m,*n) == 0) {
+ value = 0.;
+ } else if (lsame_(norm, "M")) {
+
+/* Find max(abs(A(i,j))). */
+
+ if (lsame_(diag, "U")) {
+ value = 1.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *m, i__4 = j - 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * a_dim1]);
+ value = max(d__1,d__2);
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * a_dim1]);
+ value = max(d__1,d__2);
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ } else {
+ value = 0.;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(*m,j);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * a_dim1]);
+ value = max(d__1,d__2);
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = z_abs(&a[i__ + j * a_dim1]);
+ value = max(d__1,d__2);
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ }
+ } else if (lsame_(norm, "O") || *(unsigned char *)
+ norm == '1') {
+
+/* Find norm1(A). */
+
+ value = 0.;
+ udiag = lsame_(diag, "U");
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag && j <= *m) {
+ sum = 1.;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ sum += z_abs(&a[i__ + j * a_dim1]);
+/* L90: */
+ }
+ } else {
+ sum = 0.;
+ i__2 = min(*m,j);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ sum += z_abs(&a[i__ + j * a_dim1]);
+/* L100: */
+ }
+ }
+ value = max(value,sum);
+/* L110: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (udiag) {
+ sum = 1.;
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ sum += z_abs(&a[i__ + j * a_dim1]);
+/* L120: */
+ }
+ } else {
+ sum = 0.;
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ sum += z_abs(&a[i__ + j * a_dim1]);
+/* L130: */
+ }
+ }
+ value = max(value,sum);
+/* L140: */
+ }
+ }
+ } else if (lsame_(norm, "I")) {
+
+/* Find normI(A). */
+
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.;
+/* L150: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *m, i__4 = j - 1;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += z_abs(&a[i__ + j * a_dim1]);
+/* L160: */
+ }
+/* L170: */
+ }
+ } else {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L180: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(*m,j);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__] += z_abs(&a[i__ + j * a_dim1]);
+/* L190: */
+ }
+/* L200: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 1.;
+/* L210: */
+ }
+ i__1 = *m;
+ for (i__ = *n + 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L220: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ work[i__] += z_abs(&a[i__ + j * a_dim1]);
+/* L230: */
+ }
+/* L240: */
+ }
+ } else {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L250: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ work[i__] += z_abs(&a[i__ + j * a_dim1]);
+/* L260: */
+ }
+/* L270: */
+ }
+ }
+ }
+ value = 0.;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = value, d__2 = work[i__];
+ value = max(d__1,d__2);
+/* L280: */
+ }
+ } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/* Find normF(A). */
+
+ if (lsame_(uplo, "U")) {
+ if (lsame_(diag, "U")) {
+ scale = 1.;
+ sum = (doublereal) min(*m,*n);
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *m, i__4 = j - 1;
+ i__2 = min(i__3,i__4);
+ zlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
+/* L290: */
+ }
+ } else {
+ scale = 0.;
+ sum = 1.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(*m,j);
+ zlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
+/* L300: */
+ }
+ }
+ } else {
+ if (lsame_(diag, "U")) {
+ scale = 1.;
+ sum = (doublereal) min(*m,*n);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m - j;
+/* Computing MIN */
+ i__3 = *m, i__4 = j + 1;
+ zlassq_(&i__2, &a[min(i__3, i__4)+ j * a_dim1], &c__1, &
+ scale, &sum);
+/* L310: */
+ }
+ } else {
+ scale = 0.;
+ sum = 1.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m - j + 1;
+ zlassq_(&i__2, &a[j + j * a_dim1], &c__1, &scale, &sum);
+/* L320: */
+ }
+ }
+ }
+ value = scale * sqrt(sum);
+ }
+
+ ret_val = value;
+ return ret_val;
+
+/* End of ZLANTR */
+
+} /* zlantr_ */
diff --git a/SRC/zlapll.c b/SRC/zlapll.c
new file mode 100644
index 0000000..66a4405
--- /dev/null
+++ b/SRC/zlapll.c
@@ -0,0 +1,143 @@
+/* zlapll.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlapll_(integer *n, doublecomplex *x, integer *incx,
+ doublecomplex *y, integer *incy, doublereal *ssmin)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2, d__3;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ double z_abs(doublecomplex *);
+
+ /* Local variables */
+ doublecomplex c__, a11, a12, a22, tau;
+ extern /* Subroutine */ int dlas2_(doublereal *, doublereal *, doublereal
+ *, doublereal *, doublereal *);
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal ssmax;
+ extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), zlarfg_(
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Given two column vectors X and Y, let */
+
+/* A = ( X Y ). */
+
+/* The subroutine first computes the QR factorization of A = Q*R, */
+/* and then computes the SVD of the 2-by-2 upper triangular matrix R. */
+/* The smaller singular value of R is returned in SSMIN, which is used */
+/* as the measurement of the linear dependency of the vectors X and Y. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The length of the vectors X and Y. */
+
+/* X (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX) */
+/* On entry, X contains the N-vector X. */
+/* On exit, X is overwritten. */
+
+/* INCX (input) INTEGER */
+/* The increment between successive elements of X. INCX > 0. */
+
+/* Y (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCY) */
+/* On entry, Y contains the N-vector Y. */
+/* On exit, Y is overwritten. */
+
+/* INCY (input) INTEGER */
+/* The increment between successive elements of Y. INCY > 0. */
+
+/* SSMIN (output) DOUBLE PRECISION */
+/* The smallest singular value of the N-by-2 matrix A = ( X Y ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --y;
+ --x;
+
+ /* Function Body */
+ if (*n <= 1) {
+ *ssmin = 0.;
+ return 0;
+ }
+
+/* Compute the QR factorization of the N-by-2 matrix ( X Y ) */
+
+ zlarfg_(n, &x[1], &x[*incx + 1], incx, &tau);
+ a11.r = x[1].r, a11.i = x[1].i;
+ x[1].r = 1., x[1].i = 0.;
+
+ d_cnjg(&z__3, &tau);
+ z__2.r = -z__3.r, z__2.i = -z__3.i;
+ zdotc_(&z__4, n, &x[1], incx, &y[1], incy);
+ z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i +
+ z__2.i * z__4.r;
+ c__.r = z__1.r, c__.i = z__1.i;
+ zaxpy_(n, &c__, &x[1], incx, &y[1], incy);
+
+ i__1 = *n - 1;
+ zlarfg_(&i__1, &y[*incy + 1], &y[(*incy << 1) + 1], incy, &tau);
+
+ a12.r = y[1].r, a12.i = y[1].i;
+ i__1 = *incy + 1;
+ a22.r = y[i__1].r, a22.i = y[i__1].i;
+
+/* Compute the SVD of 2-by-2 Upper triangular matrix. */
+
+ d__1 = z_abs(&a11);
+ d__2 = z_abs(&a12);
+ d__3 = z_abs(&a22);
+ dlas2_(&d__1, &d__2, &d__3, ssmin, &ssmax);
+
+ return 0;
+
+/* End of ZLAPLL */
+
+} /* zlapll_ */
diff --git a/SRC/zlapmt.c b/SRC/zlapmt.c
new file mode 100644
index 0000000..365526e
--- /dev/null
+++ b/SRC/zlapmt.c
@@ -0,0 +1,186 @@
+/* zlapmt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlapmt_(logical *forwrd, integer *m, integer *n,
+ doublecomplex *x, integer *ldx, integer *k)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, ii, in;
+ doublecomplex temp;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAPMT rearranges the columns of the M by N matrix X as specified */
+/* by the permutation K(1),K(2),...,K(N) of the integers 1,...,N. */
+/* If FORWRD = .TRUE., forward permutation: */
+
+/* X(*,K(J)) is moved X(*,J) for J = 1,2,...,N. */
+
+/* If FORWRD = .FALSE., backward permutation: */
+
+/* X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N. */
+
+/* Arguments */
+/* ========= */
+
+/* FORWRD (input) LOGICAL */
+/* = .TRUE., forward permutation */
+/* = .FALSE., backward permutation */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix X. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix X. N >= 0. */
+
+/* X (input/output) COMPLEX*16 array, dimension (LDX,N) */
+/* On entry, the M by N matrix X. */
+/* On exit, X contains the permuted matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X, LDX >= MAX(1,M). */
+
+/* K (input/output) INTEGER array, dimension (N) */
+/* On entry, K contains the permutation vector. K is used as */
+/* internal workspace, but reset to its original value on */
+/* output. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --k;
+
+ /* Function Body */
+ if (*n <= 1) {
+ return 0;
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ k[i__] = -k[i__];
+/* L10: */
+ }
+
+ if (*forwrd) {
+
+/* Forward permutation */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+ if (k[i__] > 0) {
+ goto L40;
+ }
+
+ j = i__;
+ k[j] = -k[j];
+ in = k[j];
+
+L20:
+ if (k[in] > 0) {
+ goto L40;
+ }
+
+ i__2 = *m;
+ for (ii = 1; ii <= i__2; ++ii) {
+ i__3 = ii + j * x_dim1;
+ temp.r = x[i__3].r, temp.i = x[i__3].i;
+ i__3 = ii + j * x_dim1;
+ i__4 = ii + in * x_dim1;
+ x[i__3].r = x[i__4].r, x[i__3].i = x[i__4].i;
+ i__3 = ii + in * x_dim1;
+ x[i__3].r = temp.r, x[i__3].i = temp.i;
+/* L30: */
+ }
+
+ k[in] = -k[in];
+ j = in;
+ in = k[in];
+ goto L20;
+
+L40:
+
+/* L50: */
+ ;
+ }
+
+ } else {
+
+/* Backward permutation */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+ if (k[i__] > 0) {
+ goto L80;
+ }
+
+ k[i__] = -k[i__];
+ j = k[i__];
+L60:
+ if (j == i__) {
+ goto L80;
+ }
+
+ i__2 = *m;
+ for (ii = 1; ii <= i__2; ++ii) {
+ i__3 = ii + i__ * x_dim1;
+ temp.r = x[i__3].r, temp.i = x[i__3].i;
+ i__3 = ii + i__ * x_dim1;
+ i__4 = ii + j * x_dim1;
+ x[i__3].r = x[i__4].r, x[i__3].i = x[i__4].i;
+ i__3 = ii + j * x_dim1;
+ x[i__3].r = temp.r, x[i__3].i = temp.i;
+/* L70: */
+ }
+
+ k[j] = -k[j];
+ j = k[j];
+ goto L60;
+
+L80:
+
+/* L90: */
+ ;
+ }
+
+ }
+
+ return 0;
+
+/* End of ZLAPMT */
+
+} /* zlapmt_ */
diff --git a/SRC/zlaqgb.c b/SRC/zlaqgb.c
new file mode 100644
index 0000000..c105a33
--- /dev/null
+++ b/SRC/zlaqgb.c
@@ -0,0 +1,227 @@
+/* zlaqgb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlaqgb_(integer *m, integer *n, integer *kl, integer *ku,
+ doublecomplex *ab, integer *ldab, doublereal *r__, doublereal *c__,
+ doublereal *rowcnd, doublereal *colcnd, doublereal *amax, char *equed)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal cj, large, small;
+ extern doublereal dlamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAQGB equilibrates a general M by N band matrix A with KL */
+/* subdiagonals and KU superdiagonals using the row and scaling factors */
+/* in the vectors R and C. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) */
+/* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */
+
+/* On exit, the equilibrated matrix, in the same storage format */
+/* as A. See EQUED for the form of the equilibrated matrix. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDA >= KL+KU+1. */
+
+/* R (input) DOUBLE PRECISION array, dimension (M) */
+/* The row scale factors for A. */
+
+/* C (input) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. */
+
+/* ROWCND (input) DOUBLE PRECISION */
+/* Ratio of the smallest R(i) to the largest R(i). */
+
+/* COLCND (input) DOUBLE PRECISION */
+/* Ratio of the smallest C(i) to the largest C(i). */
+
+/* AMAX (input) DOUBLE PRECISION */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if row or column scaling */
+/* should be done based on the ratio of the row or column scaling */
+/* factors. If ROWCND < THRESH, row scaling is done, and if */
+/* COLCND < THRESH, column scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if row scaling */
+/* should be done based on the absolute size of the largest matrix */
+/* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = dlamch_("Safe minimum") / dlamch_("Precision");
+ large = 1. / small;
+
+ if (*rowcnd >= .1 && *amax >= small && *amax <= large) {
+
+/* No row scaling */
+
+ if (*colcnd >= .1) {
+
+/* No column scaling */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = c__[j];
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__4 = min(i__5,i__6);
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ i__2 = *ku + 1 + i__ - j + j * ab_dim1;
+ i__3 = *ku + 1 + i__ - j + j * ab_dim1;
+ z__1.r = cj * ab[i__3].r, z__1.i = cj * ab[i__3].i;
+ ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
+/* L10: */
+ }
+/* L20: */
+ }
+ *(unsigned char *)equed = 'C';
+ }
+ } else if (*colcnd >= .1) {
+
+/* Row scaling, no column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__3 = min(i__5,i__6);
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ i__4 = *ku + 1 + i__ - j + j * ab_dim1;
+ i__2 = i__;
+ i__5 = *ku + 1 + i__ - j + j * ab_dim1;
+ z__1.r = r__[i__2] * ab[i__5].r, z__1.i = r__[i__2] * ab[i__5]
+ .i;
+ ab[i__4].r = z__1.r, ab[i__4].i = z__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ *(unsigned char *)equed = 'R';
+ } else {
+
+/* Row and column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = c__[j];
+/* Computing MAX */
+ i__3 = 1, i__4 = j - *ku;
+/* Computing MIN */
+ i__5 = *m, i__6 = j + *kl;
+ i__2 = min(i__5,i__6);
+ for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) {
+ i__3 = *ku + 1 + i__ - j + j * ab_dim1;
+ d__1 = cj * r__[i__];
+ i__4 = *ku + 1 + i__ - j + j * ab_dim1;
+ z__1.r = d__1 * ab[i__4].r, z__1.i = d__1 * ab[i__4].i;
+ ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
+/* L50: */
+ }
+/* L60: */
+ }
+ *(unsigned char *)equed = 'B';
+ }
+
+ return 0;
+
+/* End of ZLAQGB */
+
+} /* zlaqgb_ */
diff --git a/SRC/zlaqge.c b/SRC/zlaqge.c
new file mode 100644
index 0000000..a07ee30
--- /dev/null
+++ b/SRC/zlaqge.c
@@ -0,0 +1,202 @@
+/* zlaqge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlaqge_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublereal *r__, doublereal *c__, doublereal *rowcnd,
+ doublereal *colcnd, doublereal *amax, char *equed)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal cj, large, small;
+ extern doublereal dlamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAQGE equilibrates a general M by N matrix A using the row and */
+/* column scaling factors in the vectors R and C. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M by N matrix A. */
+/* On exit, the equilibrated matrix. See EQUED for the form of */
+/* the equilibrated matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(M,1). */
+
+/* R (input) DOUBLE PRECISION array, dimension (M) */
+/* The row scale factors for A. */
+
+/* C (input) DOUBLE PRECISION array, dimension (N) */
+/* The column scale factors for A. */
+
+/* ROWCND (input) DOUBLE PRECISION */
+/* Ratio of the smallest R(i) to the largest R(i). */
+
+/* COLCND (input) DOUBLE PRECISION */
+/* Ratio of the smallest C(i) to the largest C(i). */
+
+/* AMAX (input) DOUBLE PRECISION */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration */
+/* = 'R': Row equilibration, i.e., A has been premultiplied by */
+/* diag(R). */
+/* = 'C': Column equilibration, i.e., A has been postmultiplied */
+/* by diag(C). */
+/* = 'B': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(R) * A * diag(C). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if row or column scaling */
+/* should be done based on the ratio of the row or column scaling */
+/* factors. If ROWCND < THRESH, row scaling is done, and if */
+/* COLCND < THRESH, column scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if row scaling */
+/* should be done based on the absolute size of the largest matrix */
+/* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --r__;
+ --c__;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = dlamch_("Safe minimum") / dlamch_("Precision");
+ large = 1. / small;
+
+ if (*rowcnd >= .1 && *amax >= small && *amax <= large) {
+
+/* No row scaling */
+
+ if (*colcnd >= .1) {
+
+/* No column scaling */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = c__[j];
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ z__1.r = cj * a[i__4].r, z__1.i = cj * a[i__4].i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L10: */
+ }
+/* L20: */
+ }
+ *(unsigned char *)equed = 'C';
+ }
+ } else if (*colcnd >= .1) {
+
+/* Row scaling, no column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ z__1.r = r__[i__4] * a[i__5].r, z__1.i = r__[i__4] * a[i__5]
+ .i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ *(unsigned char *)equed = 'R';
+ } else {
+
+/* Row and column scaling */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = c__[j];
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ d__1 = cj * r__[i__];
+ i__4 = i__ + j * a_dim1;
+ z__1.r = d__1 * a[i__4].r, z__1.i = d__1 * a[i__4].i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L50: */
+ }
+/* L60: */
+ }
+ *(unsigned char *)equed = 'B';
+ }
+
+ return 0;
+
+/* End of ZLAQGE */
+
+} /* zlaqge_ */
diff --git a/SRC/zlaqhb.c b/SRC/zlaqhb.c
new file mode 100644
index 0000000..6d01748
--- /dev/null
+++ b/SRC/zlaqhb.c
@@ -0,0 +1,201 @@
+/* zlaqhb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlaqhb_(char *uplo, integer *n, integer *kd,
+ doublecomplex *ab, integer *ldab, doublereal *s, doublereal *scond,
+ doublereal *amax, char *equed)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal cj, large;
+ extern logical lsame_(char *, char *);
+ doublereal small;
+ extern doublereal dlamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAQHB equilibrates a symmetric band matrix A using the scaling */
+/* factors in the vector S. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, if INFO = 0, the triangular factor U or L from the */
+/* Cholesky factorization A = U'*U or A = L*L' of the band */
+/* matrix A, in the same storage format as A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* S (output) DOUBLE PRECISION array, dimension (N) */
+/* The scale factors for A. */
+
+/* SCOND (input) DOUBLE PRECISION */
+/* Ratio of the smallest S(i) to the largest S(i). */
+
+/* AMAX (input) DOUBLE PRECISION */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies whether or not equilibration was done. */
+/* = 'N': No equilibration. */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if scaling should be done */
+/* based on the ratio of the scaling factors. If SCOND < THRESH, */
+/* scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if scaling should */
+/* be done based on the absolute size of the largest matrix element. */
+/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --s;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = dlamch_("Safe minimum") / dlamch_("Precision");
+ large = 1. / small;
+
+ if (*scond >= .1 && *amax >= small && *amax <= large) {
+
+/* No equilibration */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Replace A by diag(S) * A * diag(S). */
+
+ if (lsame_(uplo, "U")) {
+
+/* Upper triangle of A is stored in band format. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *kd;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ i__2 = *kd + 1 + i__ - j + j * ab_dim1;
+ d__1 = cj * s[i__];
+ i__3 = *kd + 1 + i__ - j + j * ab_dim1;
+ z__1.r = d__1 * ab[i__3].r, z__1.i = d__1 * ab[i__3].i;
+ ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
+/* L10: */
+ }
+ i__4 = *kd + 1 + j * ab_dim1;
+ i__2 = *kd + 1 + j * ab_dim1;
+ d__1 = cj * cj * ab[i__2].r;
+ ab[i__4].r = d__1, ab[i__4].i = 0.;
+/* L20: */
+ }
+ } else {
+
+/* Lower triangle of A is stored. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__4 = j * ab_dim1 + 1;
+ i__2 = j * ab_dim1 + 1;
+ d__1 = cj * cj * ab[i__2].r;
+ ab[i__4].r = d__1, ab[i__4].i = 0.;
+/* Computing MIN */
+ i__2 = *n, i__3 = j + *kd;
+ i__4 = min(i__2,i__3);
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ i__2 = i__ + 1 - j + j * ab_dim1;
+ d__1 = cj * s[i__];
+ i__3 = i__ + 1 - j + j * ab_dim1;
+ z__1.r = d__1 * ab[i__3].r, z__1.i = d__1 * ab[i__3].i;
+ ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ *(unsigned char *)equed = 'Y';
+ }
+
+ return 0;
+
+/* End of ZLAQHB */
+
+} /* zlaqhb_ */
diff --git a/SRC/zlaqhe.c b/SRC/zlaqhe.c
new file mode 100644
index 0000000..b77fc0a
--- /dev/null
+++ b/SRC/zlaqhe.c
@@ -0,0 +1,193 @@
+/* zlaqhe.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlaqhe_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublereal *s, doublereal *scond, doublereal *amax,
+ char *equed)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal cj, large;
+ extern logical lsame_(char *, char *);
+ doublereal small;
+ extern doublereal dlamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAQHE equilibrates a Hermitian matrix A using the scaling factors */
+/* in the vector S. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the 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 EQUED = 'Y', the equilibrated matrix: */
+/* diag(S) * A * diag(S). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(N,1). */
+
+/* S (input) DOUBLE PRECISION array, dimension (N) */
+/* The scale factors for A. */
+
+/* SCOND (input) DOUBLE PRECISION */
+/* Ratio of the smallest S(i) to the largest S(i). */
+
+/* AMAX (input) DOUBLE PRECISION */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies whether or not equilibration was done. */
+/* = 'N': No equilibration. */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if scaling should be done */
+/* based on the ratio of the scaling factors. If SCOND < THRESH, */
+/* scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if scaling should */
+/* be done based on the absolute size of the largest matrix element. */
+/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = dlamch_("Safe minimum") / dlamch_("Precision");
+ large = 1. / small;
+
+ if (*scond >= .1 && *amax >= small && *amax <= large) {
+
+/* No equilibration */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Replace A by diag(S) * A * diag(S). */
+
+ if (lsame_(uplo, "U")) {
+
+/* Upper triangle of A is stored. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ d__1 = cj * s[i__];
+ i__4 = i__ + j * a_dim1;
+ z__1.r = d__1 * a[i__4].r, z__1.i = d__1 * a[i__4].i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L10: */
+ }
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ d__1 = cj * cj * a[i__3].r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+/* L20: */
+ }
+ } else {
+
+/* Lower triangle of A is stored. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ d__1 = cj * cj * a[i__3].r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ d__1 = cj * s[i__];
+ i__4 = i__ + j * a_dim1;
+ z__1.r = d__1 * a[i__4].r, z__1.i = d__1 * a[i__4].i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ *(unsigned char *)equed = 'Y';
+ }
+
+ return 0;
+
+/* End of ZLAQHE */
+
+} /* zlaqhe_ */
diff --git a/SRC/zlaqhp.c b/SRC/zlaqhp.c
new file mode 100644
index 0000000..15019ff
--- /dev/null
+++ b/SRC/zlaqhp.c
@@ -0,0 +1,189 @@
+/* zlaqhp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlaqhp_(char *uplo, integer *n, doublecomplex *ap,
+ doublereal *s, doublereal *scond, doublereal *amax, char *equed)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j, jc;
+ doublereal cj, large;
+ extern logical lsame_(char *, char *);
+ doublereal small;
+ extern doublereal dlamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAQHP equilibrates a Hermitian matrix A using the scaling factors */
+/* in the vector S. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the equilibrated matrix: diag(S) * A * diag(S), in */
+/* the same storage format as A. */
+
+/* S (input) DOUBLE PRECISION array, dimension (N) */
+/* The scale factors for A. */
+
+/* SCOND (input) DOUBLE PRECISION */
+/* Ratio of the smallest S(i) to the largest S(i). */
+
+/* AMAX (input) DOUBLE PRECISION */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies whether or not equilibration was done. */
+/* = 'N': No equilibration. */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if scaling should be done */
+/* based on the ratio of the scaling factors. If SCOND < THRESH, */
+/* scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if scaling should */
+/* be done based on the absolute size of the largest matrix element. */
+/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --s;
+ --ap;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = dlamch_("Safe minimum") / dlamch_("Precision");
+ large = 1. / small;
+
+ if (*scond >= .1 && *amax >= small && *amax <= large) {
+
+/* No equilibration */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Replace A by diag(S) * A * diag(S). */
+
+ if (lsame_(uplo, "U")) {
+
+/* Upper triangle of A is stored. */
+
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - 1;
+ d__1 = cj * s[i__];
+ i__4 = jc + i__ - 1;
+ z__1.r = d__1 * ap[i__4].r, z__1.i = d__1 * ap[i__4].i;
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+/* L10: */
+ }
+ i__2 = jc + j - 1;
+ i__3 = jc + j - 1;
+ d__1 = cj * cj * ap[i__3].r;
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+ jc += j;
+/* L20: */
+ }
+ } else {
+
+/* Lower triangle of A is stored. */
+
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = jc;
+ i__3 = jc;
+ d__1 = cj * cj * ap[i__3].r;
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - j;
+ d__1 = cj * s[i__];
+ i__4 = jc + i__ - j;
+ z__1.r = d__1 * ap[i__4].r, z__1.i = d__1 * ap[i__4].i;
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+/* L30: */
+ }
+ jc = jc + *n - j + 1;
+/* L40: */
+ }
+ }
+ *(unsigned char *)equed = 'Y';
+ }
+
+ return 0;
+
+/* End of ZLAQHP */
+
+} /* zlaqhp_ */
diff --git a/SRC/zlaqp2.c b/SRC/zlaqp2.c
new file mode 100644
index 0000000..8b85675
--- /dev/null
+++ b/SRC/zlaqp2.c
@@ -0,0 +1,242 @@
+/* zlaqp2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zlaqp2_(integer *m, integer *n, integer *offset,
+ doublecomplex *a, integer *lda, integer *jpvt, doublecomplex *tau,
+ doublereal *vn1, doublereal *vn2, doublecomplex *work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ double z_abs(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, mn;
+ doublecomplex aii;
+ integer pvt;
+ doublereal temp, temp2, tol3z;
+ integer offpi, itemp;
+ extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *), zswap_(integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
+ char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int zlarfp_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAQP2 computes a QR factorization with column pivoting of */
+/* the block A(OFFSET+1:M,1:N). */
+/* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* OFFSET (input) INTEGER */
+/* The number of rows of the matrix A that must be pivoted */
+/* but no factorized. OFFSET >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is */
+/* the triangular factor obtained; the elements in block */
+/* A(OFFSET+1:M,1:N) below the diagonal, together with the */
+/* array TAU, represent the orthogonal matrix Q as a product of */
+/* elementary reflectors. Block A(1:OFFSET,1:N) has been */
+/* accordingly pivoted, but no factorized. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
+/* to the front of A*P (a leading column); if JPVT(i) = 0, */
+/* the i-th column of A is a free column. */
+/* On exit, if JPVT(i) = k, then the i-th column of A*P */
+/* was the k-th column of A. */
+
+/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors. */
+
+/* VN1 (input/output) DOUBLE PRECISION array, dimension (N) */
+/* The vector with the partial column norms. */
+
+/* VN2 (input/output) DOUBLE PRECISION array, dimension (N) */
+/* The vector with the exact column norms. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
+/* X. Sun, Computer Science Dept., Duke University, USA */
+
+/* Partial column norm updating strategy modified by */
+/* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */
+/* University of Zagreb, Croatia. */
+/* June 2006. */
+/* For more details see LAPACK Working Note 176. */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --jpvt;
+ --tau;
+ --vn1;
+ --vn2;
+ --work;
+
+ /* Function Body */
+/* Computing MIN */
+ i__1 = *m - *offset;
+ mn = min(i__1,*n);
+ tol3z = sqrt(dlamch_("Epsilon"));
+
+/* Compute factorization. */
+
+ i__1 = mn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+ offpi = *offset + i__;
+
+/* Determine ith pivot column and swap if necessary. */
+
+ i__2 = *n - i__ + 1;
+ pvt = i__ - 1 + idamax_(&i__2, &vn1[i__], &c__1);
+
+ if (pvt != i__) {
+ zswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
+ c__1);
+ itemp = jpvt[pvt];
+ jpvt[pvt] = jpvt[i__];
+ jpvt[i__] = itemp;
+ vn1[pvt] = vn1[i__];
+ vn2[pvt] = vn2[i__];
+ }
+
+/* Generate elementary reflector H(i). */
+
+ if (offpi < *m) {
+ i__2 = *m - offpi + 1;
+ zlarfp_(&i__2, &a[offpi + i__ * a_dim1], &a[offpi + 1 + i__ *
+ a_dim1], &c__1, &tau[i__]);
+ } else {
+ zlarfp_(&c__1, &a[*m + i__ * a_dim1], &a[*m + i__ * a_dim1], &
+ c__1, &tau[i__]);
+ }
+
+ if (i__ < *n) {
+
+/* Apply H(i)' to A(offset+i:m,i+1:n) from the left. */
+
+ i__2 = offpi + i__ * a_dim1;
+ aii.r = a[i__2].r, aii.i = a[i__2].i;
+ i__2 = offpi + i__ * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+ i__2 = *m - offpi + 1;
+ i__3 = *n - i__;
+ d_cnjg(&z__1, &tau[i__]);
+ zlarf_("Left", &i__2, &i__3, &a[offpi + i__ * a_dim1], &c__1, &
+ z__1, &a[offpi + (i__ + 1) * a_dim1], lda, &work[1]);
+ i__2 = offpi + i__ * a_dim1;
+ a[i__2].r = aii.r, a[i__2].i = aii.i;
+ }
+
+/* Update partial column norms. */
+
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (vn1[j] != 0.) {
+
+/* NOTE: The following 4 lines follow from the analysis in */
+/* Lapack Working Note 176. */
+
+/* Computing 2nd power */
+ d__1 = z_abs(&a[offpi + j * a_dim1]) / vn1[j];
+ temp = 1. - d__1 * d__1;
+ temp = max(temp,0.);
+/* Computing 2nd power */
+ d__1 = vn1[j] / vn2[j];
+ temp2 = temp * (d__1 * d__1);
+ if (temp2 <= tol3z) {
+ if (offpi < *m) {
+ i__3 = *m - offpi;
+ vn1[j] = dznrm2_(&i__3, &a[offpi + 1 + j * a_dim1], &
+ c__1);
+ vn2[j] = vn1[j];
+ } else {
+ vn1[j] = 0.;
+ vn2[j] = 0.;
+ }
+ } else {
+ vn1[j] *= sqrt(temp);
+ }
+ }
+/* L10: */
+ }
+
+/* L20: */
+ }
+
+ return 0;
+
+/* End of ZLAQP2 */
+
+} /* zlaqp2_ */
diff --git a/SRC/zlaqps.c b/SRC/zlaqps.c
new file mode 100644
index 0000000..3fd88c6
--- /dev/null
+++ b/SRC/zlaqps.c
@@ -0,0 +1,364 @@
+/* zlaqps.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zlaqps_(integer *m, integer *n, integer *offset, integer
+ *nb, integer *kb, doublecomplex *a, integer *lda, integer *jpvt,
+ doublecomplex *tau, doublereal *vn1, doublereal *vn2, doublecomplex *
+ auxv, doublecomplex *f, integer *ldf)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, f_dim1, f_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ double z_abs(doublecomplex *);
+ integer i_dnnt(doublereal *);
+
+ /* Local variables */
+ integer j, k, rk;
+ doublecomplex akk;
+ integer pvt;
+ doublereal temp, temp2, tol3z;
+ integer itemp;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zswap_(integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *);
+ extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
+ char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ integer lsticc;
+ extern /* Subroutine */ int zlarfp_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *);
+ integer lastrk;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAQPS computes a step of QR factorization with column pivoting */
+/* of a complex M-by-N matrix A by using Blas-3. It tries to factorize */
+/* NB columns from A starting from the row OFFSET+1, and updates all */
+/* of the matrix with Blas-3 xGEMM. */
+
+/* In some cases, due to catastrophic cancellations, it cannot */
+/* factorize NB columns. Hence, the actual number of factorized */
+/* columns is returned in KB. */
+
+/* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0 */
+
+/* OFFSET (input) INTEGER */
+/* The number of rows of A that have been factorized in */
+/* previous steps. */
+
+/* NB (input) INTEGER */
+/* The number of columns to factorize. */
+
+/* KB (output) INTEGER */
+/* The number of columns actually factorized. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, block A(OFFSET+1:M,1:KB) is the triangular */
+/* factor obtained and block A(1:OFFSET,1:N) has been */
+/* accordingly pivoted, but no factorized. */
+/* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has */
+/* been updated. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* JPVT (input/output) INTEGER array, dimension (N) */
+/* JPVT(I) = K <==> Column K of the full matrix A has been */
+/* permuted into position I in AP. */
+
+/* TAU (output) COMPLEX*16 array, dimension (KB) */
+/* The scalar factors of the elementary reflectors. */
+
+/* VN1 (input/output) DOUBLE PRECISION array, dimension (N) */
+/* The vector with the partial column norms. */
+
+/* VN2 (input/output) DOUBLE PRECISION array, dimension (N) */
+/* The vector with the exact column norms. */
+
+/* AUXV (input/output) COMPLEX*16 array, dimension (NB) */
+/* Auxiliar vector. */
+
+/* F (input/output) COMPLEX*16 array, dimension (LDF,NB) */
+/* Matrix F' = L*Y'*A. */
+
+/* LDF (input) INTEGER */
+/* The leading dimension of the array F. LDF >= max(1,N). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
+/* X. Sun, Computer Science Dept., Duke University, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --jpvt;
+ --tau;
+ --vn1;
+ --vn2;
+ --auxv;
+ f_dim1 = *ldf;
+ f_offset = 1 + f_dim1;
+ f -= f_offset;
+
+ /* Function Body */
+/* Computing MIN */
+ i__1 = *m, i__2 = *n + *offset;
+ lastrk = min(i__1,i__2);
+ lsticc = 0;
+ k = 0;
+ tol3z = sqrt(dlamch_("Epsilon"));
+
+/* Beginning of while loop. */
+
+L10:
+ if (k < *nb && lsticc == 0) {
+ ++k;
+ rk = *offset + k;
+
+/* Determine ith pivot column and swap if necessary */
+
+ i__1 = *n - k + 1;
+ pvt = k - 1 + idamax_(&i__1, &vn1[k], &c__1);
+ if (pvt != k) {
+ zswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1);
+ i__1 = k - 1;
+ zswap_(&i__1, &f[pvt + f_dim1], ldf, &f[k + f_dim1], ldf);
+ itemp = jpvt[pvt];
+ jpvt[pvt] = jpvt[k];
+ jpvt[k] = itemp;
+ vn1[pvt] = vn1[k];
+ vn2[pvt] = vn2[k];
+ }
+
+/* Apply previous Householder reflectors to column K: */
+/* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)'. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j * f_dim1;
+ d_cnjg(&z__1, &f[k + j * f_dim1]);
+ f[i__2].r = z__1.r, f[i__2].i = z__1.i;
+/* L20: */
+ }
+ i__1 = *m - rk + 1;
+ i__2 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__1, &i__2, &z__1, &a[rk + a_dim1], lda,
+ &f[k + f_dim1], ldf, &c_b2, &a[rk + k * a_dim1], &c__1);
+ i__1 = k - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j * f_dim1;
+ d_cnjg(&z__1, &f[k + j * f_dim1]);
+ f[i__2].r = z__1.r, f[i__2].i = z__1.i;
+/* L30: */
+ }
+ }
+
+/* Generate elementary reflector H(k). */
+
+ if (rk < *m) {
+ i__1 = *m - rk + 1;
+ zlarfp_(&i__1, &a[rk + k * a_dim1], &a[rk + 1 + k * a_dim1], &
+ c__1, &tau[k]);
+ } else {
+ zlarfp_(&c__1, &a[rk + k * a_dim1], &a[rk + k * a_dim1], &c__1, &
+ tau[k]);
+ }
+
+ i__1 = rk + k * a_dim1;
+ akk.r = a[i__1].r, akk.i = a[i__1].i;
+ i__1 = rk + k * a_dim1;
+ a[i__1].r = 1., a[i__1].i = 0.;
+
+/* Compute Kth column of F: */
+
+/* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)'*A(RK:M,K). */
+
+ if (k < *n) {
+ i__1 = *m - rk + 1;
+ i__2 = *n - k;
+ zgemv_("Conjugate transpose", &i__1, &i__2, &tau[k], &a[rk + (k +
+ 1) * a_dim1], lda, &a[rk + k * a_dim1], &c__1, &c_b1, &f[
+ k + 1 + k * f_dim1], &c__1);
+ }
+
+/* Padding F(1:K,K) with zeros. */
+
+ i__1 = k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + k * f_dim1;
+ f[i__2].r = 0., f[i__2].i = 0.;
+/* L40: */
+ }
+
+/* Incremental updating of F: */
+/* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)' */
+/* *A(RK:M,K). */
+
+ if (k > 1) {
+ i__1 = *m - rk + 1;
+ i__2 = k - 1;
+ i__3 = k;
+ z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i;
+ zgemv_("Conjugate transpose", &i__1, &i__2, &z__1, &a[rk + a_dim1]
+, lda, &a[rk + k * a_dim1], &c__1, &c_b1, &auxv[1], &c__1);
+
+ i__1 = k - 1;
+ zgemv_("No transpose", n, &i__1, &c_b2, &f[f_dim1 + 1], ldf, &
+ auxv[1], &c__1, &c_b2, &f[k * f_dim1 + 1], &c__1);
+ }
+
+/* Update the current row of A: */
+/* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)'. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "Conjugate transpose", &c__1, &i__1, &k, &
+ z__1, &a[rk + a_dim1], lda, &f[k + 1 + f_dim1], ldf, &
+ c_b2, &a[rk + (k + 1) * a_dim1], lda);
+ }
+
+/* Update partial column norms. */
+
+ if (rk < lastrk) {
+ i__1 = *n;
+ for (j = k + 1; j <= i__1; ++j) {
+ if (vn1[j] != 0.) {
+
+/* NOTE: The following 4 lines follow from the analysis in */
+/* Lapack Working Note 176. */
+
+ temp = z_abs(&a[rk + j * a_dim1]) / vn1[j];
+/* Computing MAX */
+ d__1 = 0., d__2 = (temp + 1.) * (1. - temp);
+ temp = max(d__1,d__2);
+/* Computing 2nd power */
+ d__1 = vn1[j] / vn2[j];
+ temp2 = temp * (d__1 * d__1);
+ if (temp2 <= tol3z) {
+ vn2[j] = (doublereal) lsticc;
+ lsticc = j;
+ } else {
+ vn1[j] *= sqrt(temp);
+ }
+ }
+/* L50: */
+ }
+ }
+
+ i__1 = rk + k * a_dim1;
+ a[i__1].r = akk.r, a[i__1].i = akk.i;
+
+/* End of while loop. */
+
+ goto L10;
+ }
+ *kb = k;
+ rk = *offset + *kb;
+
+/* Apply the block reflector to the rest of the matrix: */
+/* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - */
+/* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)'. */
+
+/* Computing MIN */
+ i__1 = *n, i__2 = *m - *offset;
+ if (*kb < min(i__1,i__2)) {
+ i__1 = *m - rk;
+ i__2 = *n - *kb;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "Conjugate transpose", &i__1, &i__2, kb, &z__1,
+ &a[rk + 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b2, &
+ a[rk + 1 + (*kb + 1) * a_dim1], lda);
+ }
+
+/* Recomputation of difficult columns. */
+
+L60:
+ if (lsticc > 0) {
+ itemp = i_dnnt(&vn2[lsticc]);
+ i__1 = *m - rk;
+ vn1[lsticc] = dznrm2_(&i__1, &a[rk + 1 + lsticc * a_dim1], &c__1);
+
+/* NOTE: The computation of VN1( LSTICC ) relies on the fact that */
+/* SNRM2 does not fail on vectors with norm below the value of */
+/* SQRT(DLAMCH('S')) */
+
+ vn2[lsticc] = vn1[lsticc];
+ lsticc = itemp;
+ goto L60;
+ }
+
+ return 0;
+
+/* End of ZLAQPS */
+
+} /* zlaqps_ */
diff --git a/SRC/zlaqr0.c b/SRC/zlaqr0.c
new file mode 100644
index 0000000..9673b29
--- /dev/null
+++ b/SRC/zlaqr0.c
@@ -0,0 +1,787 @@
+/* zlaqr0.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__13 = 13;
+static integer c__15 = 15;
+static integer c_n1 = -1;
+static integer c__12 = 12;
+static integer c__14 = 14;
+static integer c__16 = 16;
+static logical c_false = FALSE_;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int zlaqr0_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, doublecomplex *h__, integer *ldh,
+ doublecomplex *w, integer *iloz, integer *ihiz, doublecomplex *z__,
+ integer *ldz, doublecomplex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8;
+ doublecomplex z__1, z__2, z__3, z__4, z__5;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void z_sqrt(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, k;
+ doublereal s;
+ doublecomplex aa, bb, cc, dd;
+ integer ld, nh, it, ks, kt, ku, kv, ls, ns, nw;
+ doublecomplex tr2, det;
+ integer inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot, nmin;
+ doublecomplex swap;
+ integer ktop;
+ doublecomplex zdum[1] /* was [1][1] */;
+ integer kacc22, itmax, nsmax, nwmax, kwtop;
+ extern /* Subroutine */ int zlaqr3_(logical *, logical *, integer *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ integer *, integer *, doublecomplex *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *
+, doublecomplex *, integer *), zlaqr4_(logical *, logical *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *), zlaqr5_(logical *,
+ logical *, integer *, integer *, integer *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *, doublecomplex *, integer *);
+ integer nibble;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ char jbcmpz[2];
+ doublecomplex rtdisc;
+ integer nwupbd;
+ logical sorted;
+ extern /* Subroutine */ int zlahqr_(logical *, logical *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *, integer *),
+ zlacpy_(char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ integer lwkopt;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAQR0 computes the eigenvalues of a Hessenberg matrix H */
+/* and, optionally, the matrices T and Z from the Schur decomposition */
+/* H = Z T Z**H, where T is an upper triangular matrix (the */
+/* Schur form), and Z is the unitary matrix of Schur vectors. */
+
+/* Optionally Z may be postmultiplied into an input unitary */
+/* matrix Q so that this routine can give the Schur factorization */
+/* of a matrix A which has been reduced to the Hessenberg form H */
+/* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. */
+
+/* Arguments */
+/* ========= */
+
+/* WANTT (input) LOGICAL */
+/* = .TRUE. : the full Schur form T is required; */
+/* = .FALSE.: only eigenvalues are required. */
+
+/* WANTZ (input) LOGICAL */
+/* = .TRUE. : the matrix of Schur vectors Z is required; */
+/* = .FALSE.: Schur vectors are not required. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N .GE. 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that H is already upper triangular in rows */
+/* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, */
+/* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a */
+/* previous call to ZGEBAL, and then passed to ZGEHRD when the */
+/* matrix output by ZGEBAL is reduced to Hessenberg form. */
+/* Otherwise, ILO and IHI should be set to 1 and N, */
+/* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */
+/* If N = 0, then ILO = 1 and IHI = 0. */
+
+/* H (input/output) COMPLEX*16 array, dimension (LDH,N) */
+/* On entry, the upper Hessenberg matrix H. */
+/* On exit, if INFO = 0 and WANTT is .TRUE., then H */
+/* contains the upper triangular matrix T from the Schur */
+/* decomposition (the Schur form). If INFO = 0 and WANT is */
+/* .FALSE., then the contents of H are unspecified on exit. */
+/* (The output value of H when INFO.GT.0 is given under the */
+/* description of INFO below.) */
+
+/* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and */
+/* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH .GE. max(1,N). */
+
+/* W (output) COMPLEX*16 array, dimension (N) */
+/* The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored */
+/* in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are */
+/* stored in the same order as on the diagonal of the Schur */
+/* form returned in H, with W(i) = H(i,i). */
+
+/* Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI) */
+/* If WANTZ is .FALSE., then Z is not referenced. */
+/* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is */
+/* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the */
+/* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). */
+/* (The output value of Z when INFO.GT.0 is given under */
+/* the description of INFO below.) */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. if WANTZ is .TRUE. */
+/* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension LWORK */
+/* On exit, if LWORK = -1, WORK(1) returns an estimate of */
+/* the optimal value for LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK .GE. max(1,N) */
+/* is sufficient, but LWORK typically as large as 6*N may */
+/* be required for optimal performance. A workspace query */
+/* to determine the optimal workspace size is recommended. */
+
+/* If LWORK = -1, then ZLAQR0 does a workspace query. */
+/* In this case, ZLAQR0 checks the input parameters and */
+/* estimates the optimal workspace size for the given */
+/* values of N, ILO and IHI. The estimate is returned */
+/* in WORK(1). No error message related to LWORK is */
+/* issued by XERBLA. Neither H nor Z are accessed. */
+
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* .GT. 0: if INFO = i, ZLAQR0 failed to compute all of */
+/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */
+/* and WI contain those eigenvalues which have been */
+/* successfully computed. (Failures are rare.) */
+
+/* If INFO .GT. 0 and WANT is .FALSE., then on exit, */
+/* the remaining unconverged eigenvalues are the eigen- */
+/* values of the upper Hessenberg matrix rows and */
+/* columns ILO through INFO of the final, output */
+/* value of H. */
+
+/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */
+
+/* (*) (initial value of H)*U = U*(final value of H) */
+
+/* where U is a unitary matrix. The final */
+/* value of H is upper Hessenberg and triangular in */
+/* rows and columns INFO+1 through IHI. */
+
+/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
+
+/* (final value of Z(ILO:IHI,ILOZ:IHIZ) */
+/* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U */
+
+/* where U is the unitary matrix in (*) (regard- */
+/* less of the value of WANTT.) */
+
+/* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not */
+/* accessed. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* References: */
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */
+/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */
+/* 929--947, 2002. */
+
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */
+/* of Matrix Analysis, volume 23, pages 948--973, 2002. */
+
+/* ================================================================ */
+/* .. Parameters .. */
+
+/* ==== Matrices of order NTINY or smaller must be processed by */
+/* . ZLAHQR because of insufficient subdiagonal scratch space. */
+/* . (This is a hard limit.) ==== */
+
+/* ==== Exceptional deflation windows: try to cure rare */
+/* . slow convergence by varying the size of the */
+/* . deflation window after KEXNW iterations. ==== */
+
+/* ==== Exceptional shifts: try to cure rare slow convergence */
+/* . with ad-hoc exceptional shifts every KEXSH iterations. */
+/* . ==== */
+
+/* ==== The constant WILK1 is used to form the exceptional */
+/* . shifts. ==== */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* ==== Quick return for N = 0: nothing to do. ==== */
+
+ if (*n == 0) {
+ work[1].r = 1., work[1].i = 0.;
+ return 0;
+ }
+
+ if (*n <= 11) {
+
+/* ==== Tiny matrices must use ZLAHQR. ==== */
+
+ lwkopt = 1;
+ if (*lwork != -1) {
+ zlahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1],
+ iloz, ihiz, &z__[z_offset], ldz, info);
+ }
+ } else {
+
+/* ==== Use small bulge multi-shift QR with aggressive early */
+/* . deflation on larger-than-tiny matrices. ==== */
+
+/* ==== Hope for the best. ==== */
+
+ *info = 0;
+
+/* ==== Set up job flags for ILAENV. ==== */
+
+ if (*wantt) {
+ *(unsigned char *)jbcmpz = 'S';
+ } else {
+ *(unsigned char *)jbcmpz = 'E';
+ }
+ if (*wantz) {
+ *(unsigned char *)&jbcmpz[1] = 'V';
+ } else {
+ *(unsigned char *)&jbcmpz[1] = 'N';
+ }
+
+/* ==== NWR = recommended deflation window size. At this */
+/* . point, N .GT. NTINY = 11, so there is enough */
+/* . subdiagonal workspace for NWR.GE.2 as required. */
+/* . (In fact, there is enough subdiagonal space for */
+/* . NWR.GE.3.) ==== */
+
+ nwr = ilaenv_(&c__13, "ZLAQR0", jbcmpz, n, ilo, ihi, lwork);
+ nwr = max(2,nwr);
+/* Computing MIN */
+ i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = min(i__1,i__2);
+ nwr = min(i__1,nwr);
+
+/* ==== NSR = recommended number of simultaneous shifts. */
+/* . At this point N .GT. NTINY = 11, so there is at */
+/* . enough subdiagonal workspace for NSR to be even */
+/* . and greater than or equal to two as required. ==== */
+
+ nsr = ilaenv_(&c__15, "ZLAQR0", jbcmpz, n, ilo, ihi, lwork);
+/* Computing MIN */
+ i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = min(i__1,i__2), i__2 = *ihi -
+ *ilo;
+ nsr = min(i__1,i__2);
+/* Computing MAX */
+ i__1 = 2, i__2 = nsr - nsr % 2;
+ nsr = max(i__1,i__2);
+
+/* ==== Estimate optimal workspace ==== */
+
+/* ==== Workspace query call to ZLAQR3 ==== */
+
+ i__1 = nwr + 1;
+ zlaqr3_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz,
+ ihiz, &z__[z_offset], ldz, &ls, &ld, &w[1], &h__[h_offset],
+ ldh, n, &h__[h_offset], ldh, n, &h__[h_offset], ldh, &work[1],
+ &c_n1);
+
+/* ==== Optimal workspace = MAX(ZLAQR5, ZLAQR3) ==== */
+
+/* Computing MAX */
+ i__1 = nsr * 3 / 2, i__2 = (integer) work[1].r;
+ lwkopt = max(i__1,i__2);
+
+/* ==== Quick return in case of workspace query. ==== */
+
+ if (*lwork == -1) {
+ d__1 = (doublereal) lwkopt;
+ z__1.r = d__1, z__1.i = 0.;
+ work[1].r = z__1.r, work[1].i = z__1.i;
+ return 0;
+ }
+
+/* ==== ZLAHQR/ZLAQR0 crossover point ==== */
+
+ nmin = ilaenv_(&c__12, "ZLAQR0", jbcmpz, n, ilo, ihi, lwork);
+ nmin = max(11,nmin);
+
+/* ==== Nibble crossover point ==== */
+
+ nibble = ilaenv_(&c__14, "ZLAQR0", jbcmpz, n, ilo, ihi, lwork);
+ nibble = max(0,nibble);
+
+/* ==== Accumulate reflections during ttswp? Use block */
+/* . 2-by-2 structure during matrix-matrix multiply? ==== */
+
+ kacc22 = ilaenv_(&c__16, "ZLAQR0", jbcmpz, n, ilo, ihi, lwork);
+ kacc22 = max(0,kacc22);
+ kacc22 = min(2,kacc22);
+
+/* ==== NWMAX = the largest possible deflation window for */
+/* . which there is sufficient workspace. ==== */
+
+/* Computing MIN */
+ i__1 = (*n - 1) / 3, i__2 = *lwork / 2;
+ nwmax = min(i__1,i__2);
+ nw = nwmax;
+
+/* ==== NSMAX = the Largest number of simultaneous shifts */
+/* . for which there is sufficient workspace. ==== */
+
+/* Computing MIN */
+ i__1 = (*n + 6) / 9, i__2 = (*lwork << 1) / 3;
+ nsmax = min(i__1,i__2);
+ nsmax -= nsmax % 2;
+
+/* ==== NDFL: an iteration count restarted at deflation. ==== */
+
+ ndfl = 1;
+
+/* ==== ITMAX = iteration limit ==== */
+
+/* Computing MAX */
+ i__1 = 10, i__2 = *ihi - *ilo + 1;
+ itmax = max(i__1,i__2) * 30;
+
+/* ==== Last row and column in the active block ==== */
+
+ kbot = *ihi;
+
+/* ==== Main Loop ==== */
+
+ i__1 = itmax;
+ for (it = 1; it <= i__1; ++it) {
+
+/* ==== Done when KBOT falls below ILO ==== */
+
+ if (kbot < *ilo) {
+ goto L80;
+ }
+
+/* ==== Locate active block ==== */
+
+ i__2 = *ilo + 1;
+ for (k = kbot; k >= i__2; --k) {
+ i__3 = k + (k - 1) * h_dim1;
+ if (h__[i__3].r == 0. && h__[i__3].i == 0.) {
+ goto L20;
+ }
+/* L10: */
+ }
+ k = *ilo;
+L20:
+ ktop = k;
+
+/* ==== Select deflation window size: */
+/* . Typical Case: */
+/* . If possible and advisable, nibble the entire */
+/* . active block. If not, use size MIN(NWR,NWMAX) */
+/* . or MIN(NWR+1,NWMAX) depending upon which has */
+/* . the smaller corresponding subdiagonal entry */
+/* . (a heuristic). */
+/* . */
+/* . Exceptional Case: */
+/* . If there have been no deflations in KEXNW or */
+/* . more iterations, then vary the deflation window */
+/* . size. At first, because, larger windows are, */
+/* . in general, more powerful than smaller ones, */
+/* . rapidly increase the window to the maximum possible. */
+/* . Then, gradually reduce the window size. ==== */
+
+ nh = kbot - ktop + 1;
+ nwupbd = min(nh,nwmax);
+ if (ndfl < 5) {
+ nw = min(nwupbd,nwr);
+ } else {
+/* Computing MIN */
+ i__2 = nwupbd, i__3 = nw << 1;
+ nw = min(i__2,i__3);
+ }
+ if (nw < nwmax) {
+ if (nw >= nh - 1) {
+ nw = nh;
+ } else {
+ kwtop = kbot - nw + 1;
+ i__2 = kwtop + (kwtop - 1) * h_dim1;
+ i__3 = kwtop - 1 + (kwtop - 2) * h_dim1;
+ if ((d__1 = h__[i__2].r, abs(d__1)) + (d__2 = d_imag(&h__[
+ kwtop + (kwtop - 1) * h_dim1]), abs(d__2)) > (
+ d__3 = h__[i__3].r, abs(d__3)) + (d__4 = d_imag(&
+ h__[kwtop - 1 + (kwtop - 2) * h_dim1]), abs(d__4))
+ ) {
+ ++nw;
+ }
+ }
+ }
+ if (ndfl < 5) {
+ ndec = -1;
+ } else if (ndec >= 0 || nw >= nwupbd) {
+ ++ndec;
+ if (nw - ndec < 2) {
+ ndec = 0;
+ }
+ nw -= ndec;
+ }
+
+/* ==== Aggressive early deflation: */
+/* . split workspace under the subdiagonal into */
+/* . - an nw-by-nw work array V in the lower */
+/* . left-hand-corner, */
+/* . - an NW-by-at-least-NW-but-more-is-better */
+/* . (NW-by-NHO) horizontal work array along */
+/* . the bottom edge, */
+/* . - an at-least-NW-but-more-is-better (NHV-by-NW) */
+/* . vertical work array along the left-hand-edge. */
+/* . ==== */
+
+ kv = *n - nw + 1;
+ kt = nw + 1;
+ nho = *n - nw - 1 - kt + 1;
+ kwv = nw + 2;
+ nve = *n - nw - kwv + 1;
+
+/* ==== Aggressive early deflation ==== */
+
+ zlaqr3_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh,
+ iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &w[1], &h__[kv
+ + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1], ldh, &nve, &
+ h__[kwv + h_dim1], ldh, &work[1], lwork);
+
+/* ==== Adjust KBOT accounting for new deflations. ==== */
+
+ kbot -= ld;
+
+/* ==== KS points to the shifts. ==== */
+
+ ks = kbot - ls + 1;
+
+/* ==== Skip an expensive QR sweep if there is a (partly */
+/* . heuristic) reason to expect that many eigenvalues */
+/* . will deflate without it. Here, the QR sweep is */
+/* . skipped if many eigenvalues have just been deflated */
+/* . or if the remaining active block is small. */
+
+ if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > min(
+ nmin,nwmax)) {
+
+/* ==== NS = nominal number of simultaneous shifts. */
+/* . This may be lowered (slightly) if ZLAQR3 */
+/* . did not provide that many shifts. ==== */
+
+/* Computing MIN */
+/* Computing MAX */
+ i__4 = 2, i__5 = kbot - ktop;
+ i__2 = min(nsmax,nsr), i__3 = max(i__4,i__5);
+ ns = min(i__2,i__3);
+ ns -= ns % 2;
+
+/* ==== If there have been no deflations */
+/* . in a multiple of KEXSH iterations, */
+/* . then try exceptional shifts. */
+/* . Otherwise use shifts provided by */
+/* . ZLAQR3 above or from the eigenvalues */
+/* . of a trailing principal submatrix. ==== */
+
+ if (ndfl % 6 == 0) {
+ ks = kbot - ns + 1;
+ i__2 = ks + 1;
+ for (i__ = kbot; i__ >= i__2; i__ += -2) {
+ i__3 = i__;
+ i__4 = i__ + i__ * h_dim1;
+ i__5 = i__ + (i__ - 1) * h_dim1;
+ d__3 = ((d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
+ d_imag(&h__[i__ + (i__ - 1) * h_dim1]), abs(
+ d__2))) * .75;
+ z__1.r = h__[i__4].r + d__3, z__1.i = h__[i__4].i;
+ w[i__3].r = z__1.r, w[i__3].i = z__1.i;
+ i__3 = i__ - 1;
+ i__4 = i__;
+ w[i__3].r = w[i__4].r, w[i__3].i = w[i__4].i;
+/* L30: */
+ }
+ } else {
+
+/* ==== Got NS/2 or fewer shifts? Use ZLAQR4 or */
+/* . ZLAHQR on a trailing principal submatrix to */
+/* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, */
+/* . there is enough space below the subdiagonal */
+/* . to fit an NS-by-NS scratch array.) ==== */
+
+ if (kbot - ks + 1 <= ns / 2) {
+ ks = kbot - ns + 1;
+ kt = *n - ns + 1;
+ zlacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, &
+ h__[kt + h_dim1], ldh);
+ if (ns > nmin) {
+ zlaqr4_(&c_false, &c_false, &ns, &c__1, &ns, &h__[
+ kt + h_dim1], ldh, &w[ks], &c__1, &c__1,
+ zdum, &c__1, &work[1], lwork, &inf);
+ } else {
+ zlahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[
+ kt + h_dim1], ldh, &w[ks], &c__1, &c__1,
+ zdum, &c__1, &inf);
+ }
+ ks += inf;
+
+/* ==== In case of a rare QR failure use */
+/* . eigenvalues of the trailing 2-by-2 */
+/* . principal submatrix. Scale to avoid */
+/* . overflows, underflows and subnormals. */
+/* . (The scale factor S can not be zero, */
+/* . because H(KBOT,KBOT-1) is nonzero.) ==== */
+
+ if (ks >= kbot) {
+ i__2 = kbot - 1 + (kbot - 1) * h_dim1;
+ i__3 = kbot + (kbot - 1) * h_dim1;
+ i__4 = kbot - 1 + kbot * h_dim1;
+ i__5 = kbot + kbot * h_dim1;
+ s = (d__1 = h__[i__2].r, abs(d__1)) + (d__2 =
+ d_imag(&h__[kbot - 1 + (kbot - 1) *
+ h_dim1]), abs(d__2)) + ((d__3 = h__[i__3]
+ .r, abs(d__3)) + (d__4 = d_imag(&h__[kbot
+ + (kbot - 1) * h_dim1]), abs(d__4))) + ((
+ d__5 = h__[i__4].r, abs(d__5)) + (d__6 =
+ d_imag(&h__[kbot - 1 + kbot * h_dim1]),
+ abs(d__6))) + ((d__7 = h__[i__5].r, abs(
+ d__7)) + (d__8 = d_imag(&h__[kbot + kbot *
+ h_dim1]), abs(d__8)));
+ i__2 = kbot - 1 + (kbot - 1) * h_dim1;
+ z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i /
+ s;
+ aa.r = z__1.r, aa.i = z__1.i;
+ i__2 = kbot + (kbot - 1) * h_dim1;
+ z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i /
+ s;
+ cc.r = z__1.r, cc.i = z__1.i;
+ i__2 = kbot - 1 + kbot * h_dim1;
+ z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i /
+ s;
+ bb.r = z__1.r, bb.i = z__1.i;
+ i__2 = kbot + kbot * h_dim1;
+ z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i /
+ s;
+ dd.r = z__1.r, dd.i = z__1.i;
+ z__2.r = aa.r + dd.r, z__2.i = aa.i + dd.i;
+ z__1.r = z__2.r / 2., z__1.i = z__2.i / 2.;
+ tr2.r = z__1.r, tr2.i = z__1.i;
+ z__3.r = aa.r - tr2.r, z__3.i = aa.i - tr2.i;
+ z__4.r = dd.r - tr2.r, z__4.i = dd.i - tr2.i;
+ z__2.r = z__3.r * z__4.r - z__3.i * z__4.i,
+ z__2.i = z__3.r * z__4.i + z__3.i *
+ z__4.r;
+ z__5.r = bb.r * cc.r - bb.i * cc.i, z__5.i = bb.r
+ * cc.i + bb.i * cc.r;
+ z__1.r = z__2.r - z__5.r, z__1.i = z__2.i -
+ z__5.i;
+ det.r = z__1.r, det.i = z__1.i;
+ z__2.r = -det.r, z__2.i = -det.i;
+ z_sqrt(&z__1, &z__2);
+ rtdisc.r = z__1.r, rtdisc.i = z__1.i;
+ i__2 = kbot - 1;
+ z__2.r = tr2.r + rtdisc.r, z__2.i = tr2.i +
+ rtdisc.i;
+ z__1.r = s * z__2.r, z__1.i = s * z__2.i;
+ w[i__2].r = z__1.r, w[i__2].i = z__1.i;
+ i__2 = kbot;
+ z__2.r = tr2.r - rtdisc.r, z__2.i = tr2.i -
+ rtdisc.i;
+ z__1.r = s * z__2.r, z__1.i = s * z__2.i;
+ w[i__2].r = z__1.r, w[i__2].i = z__1.i;
+
+ ks = kbot - 1;
+ }
+ }
+
+ if (kbot - ks + 1 > ns) {
+
+/* ==== Sort the shifts (Helps a little) ==== */
+
+ sorted = FALSE_;
+ i__2 = ks + 1;
+ for (k = kbot; k >= i__2; --k) {
+ if (sorted) {
+ goto L60;
+ }
+ sorted = TRUE_;
+ i__3 = k - 1;
+ for (i__ = ks; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__ + 1;
+ if ((d__1 = w[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&w[i__]), abs(d__2)) < (d__3 =
+ w[i__5].r, abs(d__3)) + (d__4 =
+ d_imag(&w[i__ + 1]), abs(d__4))) {
+ sorted = FALSE_;
+ i__4 = i__;
+ swap.r = w[i__4].r, swap.i = w[i__4].i;
+ i__4 = i__;
+ i__5 = i__ + 1;
+ w[i__4].r = w[i__5].r, w[i__4].i = w[i__5]
+ .i;
+ i__4 = i__ + 1;
+ w[i__4].r = swap.r, w[i__4].i = swap.i;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+L60:
+ ;
+ }
+ }
+
+/* ==== If there are only two shifts, then use */
+/* . only one. ==== */
+
+ if (kbot - ks + 1 == 2) {
+ i__2 = kbot;
+ i__3 = kbot + kbot * h_dim1;
+ z__2.r = w[i__2].r - h__[i__3].r, z__2.i = w[i__2].i -
+ h__[i__3].i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ i__4 = kbot - 1;
+ i__5 = kbot + kbot * h_dim1;
+ z__4.r = w[i__4].r - h__[i__5].r, z__4.i = w[i__4].i -
+ h__[i__5].i;
+ z__3.r = z__4.r, z__3.i = z__4.i;
+ if ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
+ abs(d__2)) < (d__3 = z__3.r, abs(d__3)) + (d__4 =
+ d_imag(&z__3), abs(d__4))) {
+ i__2 = kbot - 1;
+ i__3 = kbot;
+ w[i__2].r = w[i__3].r, w[i__2].i = w[i__3].i;
+ } else {
+ i__2 = kbot;
+ i__3 = kbot - 1;
+ w[i__2].r = w[i__3].r, w[i__2].i = w[i__3].i;
+ }
+ }
+
+/* ==== Use up to NS of the the smallest magnatiude */
+/* . shifts. If there aren't NS shifts available, */
+/* . then use them all, possibly dropping one to */
+/* . make the number of shifts even. ==== */
+
+/* Computing MIN */
+ i__2 = ns, i__3 = kbot - ks + 1;
+ ns = min(i__2,i__3);
+ ns -= ns % 2;
+ ks = kbot - ns + 1;
+
+/* ==== Small-bulge multi-shift QR sweep: */
+/* . split workspace under the subdiagonal into */
+/* . - a KDU-by-KDU work array U in the lower */
+/* . left-hand-corner, */
+/* . - a KDU-by-at-least-KDU-but-more-is-better */
+/* . (KDU-by-NHo) horizontal work array WH along */
+/* . the bottom edge, */
+/* . - and an at-least-KDU-but-more-is-better-by-KDU */
+/* . (NVE-by-KDU) vertical work WV arrow along */
+/* . the left-hand-edge. ==== */
+
+ kdu = ns * 3 - 3;
+ ku = *n - kdu + 1;
+ kwh = kdu + 1;
+ nho = *n - kdu - 3 - (kdu + 1) + 1;
+ kwv = kdu + 4;
+ nve = *n - kdu - kwv + 1;
+
+/* ==== Small-bulge multi-shift QR sweep ==== */
+
+ zlaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &w[ks], &
+ h__[h_offset], ldh, iloz, ihiz, &z__[z_offset], ldz, &
+ work[1], &c__3, &h__[ku + h_dim1], ldh, &nve, &h__[
+ kwv + h_dim1], ldh, &nho, &h__[ku + kwh * h_dim1],
+ ldh);
+ }
+
+/* ==== Note progress (or the lack of it). ==== */
+
+ if (ld > 0) {
+ ndfl = 1;
+ } else {
+ ++ndfl;
+ }
+
+/* ==== End of main loop ==== */
+/* L70: */
+ }
+
+/* ==== Iteration limit exceeded. Set INFO to show where */
+/* . the problem occurred and exit. ==== */
+
+ *info = kbot;
+L80:
+ ;
+ }
+
+/* ==== Return the optimal value of LWORK. ==== */
+
+ d__1 = (doublereal) lwkopt;
+ z__1.r = d__1, z__1.i = 0.;
+ work[1].r = z__1.r, work[1].i = z__1.i;
+
+/* ==== End of ZLAQR0 ==== */
+
+ return 0;
+} /* zlaqr0_ */
diff --git a/SRC/zlaqr1.c b/SRC/zlaqr1.c
new file mode 100644
index 0000000..fc0bb5e
--- /dev/null
+++ b/SRC/zlaqr1.c
@@ -0,0 +1,197 @@
+/* zlaqr1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlaqr1_(integer *n, doublecomplex *h__, integer *ldh,
+ doublecomplex *s1, doublecomplex *s2, doublecomplex *v)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6;
+ doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ doublereal s;
+ doublecomplex h21s, h31s;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1 sets v to a */
+/* scalar multiple of the first column of the product */
+
+/* (*) K = (H - s1*I)*(H - s2*I) */
+
+/* scaling to avoid overflows and most underflows. */
+
+/* This is useful for starting double implicit shift bulges */
+/* in the QR algorithm. */
+
+
+/* N (input) integer */
+/* Order of the matrix H. N must be either 2 or 3. */
+
+/* H (input) COMPLEX*16 array of dimension (LDH,N) */
+/* The 2-by-2 or 3-by-3 matrix H in (*). */
+
+/* LDH (input) integer */
+/* The leading dimension of H as declared in */
+/* the calling procedure. LDH.GE.N */
+
+/* S1 (input) COMPLEX*16 */
+/* S2 S1 and S2 are the shifts defining K in (*) above. */
+
+/* V (output) COMPLEX*16 array of dimension N */
+/* A scalar multiple of the first column of the */
+/* matrix K in (*). */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --v;
+
+ /* Function Body */
+ if (*n == 2) {
+ i__1 = h_dim1 + 1;
+ z__2.r = h__[i__1].r - s2->r, z__2.i = h__[i__1].i - s2->i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ i__2 = h_dim1 + 2;
+ s = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), abs(d__2)) + (
+ (d__3 = h__[i__2].r, abs(d__3)) + (d__4 = d_imag(&h__[h_dim1
+ + 2]), abs(d__4)));
+ if (s == 0.) {
+ v[1].r = 0., v[1].i = 0.;
+ v[2].r = 0., v[2].i = 0.;
+ } else {
+ i__1 = h_dim1 + 2;
+ z__1.r = h__[i__1].r / s, z__1.i = h__[i__1].i / s;
+ h21s.r = z__1.r, h21s.i = z__1.i;
+ i__1 = (h_dim1 << 1) + 1;
+ z__2.r = h21s.r * h__[i__1].r - h21s.i * h__[i__1].i, z__2.i =
+ h21s.r * h__[i__1].i + h21s.i * h__[i__1].r;
+ i__2 = h_dim1 + 1;
+ z__4.r = h__[i__2].r - s1->r, z__4.i = h__[i__2].i - s1->i;
+ i__3 = h_dim1 + 1;
+ z__6.r = h__[i__3].r - s2->r, z__6.i = h__[i__3].i - s2->i;
+ z__5.r = z__6.r / s, z__5.i = z__6.i / s;
+ z__3.r = z__4.r * z__5.r - z__4.i * z__5.i, z__3.i = z__4.r *
+ z__5.i + z__4.i * z__5.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ v[1].r = z__1.r, v[1].i = z__1.i;
+ i__1 = h_dim1 + 1;
+ i__2 = (h_dim1 << 1) + 2;
+ z__4.r = h__[i__1].r + h__[i__2].r, z__4.i = h__[i__1].i + h__[
+ i__2].i;
+ z__3.r = z__4.r - s1->r, z__3.i = z__4.i - s1->i;
+ z__2.r = z__3.r - s2->r, z__2.i = z__3.i - s2->i;
+ z__1.r = h21s.r * z__2.r - h21s.i * z__2.i, z__1.i = h21s.r *
+ z__2.i + h21s.i * z__2.r;
+ v[2].r = z__1.r, v[2].i = z__1.i;
+ }
+ } else {
+ i__1 = h_dim1 + 1;
+ z__2.r = h__[i__1].r - s2->r, z__2.i = h__[i__1].i - s2->i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ i__2 = h_dim1 + 2;
+ i__3 = h_dim1 + 3;
+ s = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), abs(d__2)) + (
+ (d__3 = h__[i__2].r, abs(d__3)) + (d__4 = d_imag(&h__[h_dim1
+ + 2]), abs(d__4))) + ((d__5 = h__[i__3].r, abs(d__5)) + (d__6
+ = d_imag(&h__[h_dim1 + 3]), abs(d__6)));
+ if (s == 0.) {
+ v[1].r = 0., v[1].i = 0.;
+ v[2].r = 0., v[2].i = 0.;
+ v[3].r = 0., v[3].i = 0.;
+ } else {
+ i__1 = h_dim1 + 2;
+ z__1.r = h__[i__1].r / s, z__1.i = h__[i__1].i / s;
+ h21s.r = z__1.r, h21s.i = z__1.i;
+ i__1 = h_dim1 + 3;
+ z__1.r = h__[i__1].r / s, z__1.i = h__[i__1].i / s;
+ h31s.r = z__1.r, h31s.i = z__1.i;
+ i__1 = h_dim1 + 1;
+ z__4.r = h__[i__1].r - s1->r, z__4.i = h__[i__1].i - s1->i;
+ i__2 = h_dim1 + 1;
+ z__6.r = h__[i__2].r - s2->r, z__6.i = h__[i__2].i - s2->i;
+ z__5.r = z__6.r / s, z__5.i = z__6.i / s;
+ z__3.r = z__4.r * z__5.r - z__4.i * z__5.i, z__3.i = z__4.r *
+ z__5.i + z__4.i * z__5.r;
+ i__3 = (h_dim1 << 1) + 1;
+ z__7.r = h__[i__3].r * h21s.r - h__[i__3].i * h21s.i, z__7.i =
+ h__[i__3].r * h21s.i + h__[i__3].i * h21s.r;
+ z__2.r = z__3.r + z__7.r, z__2.i = z__3.i + z__7.i;
+ i__4 = h_dim1 * 3 + 1;
+ z__8.r = h__[i__4].r * h31s.r - h__[i__4].i * h31s.i, z__8.i =
+ h__[i__4].r * h31s.i + h__[i__4].i * h31s.r;
+ z__1.r = z__2.r + z__8.r, z__1.i = z__2.i + z__8.i;
+ v[1].r = z__1.r, v[1].i = z__1.i;
+ i__1 = h_dim1 + 1;
+ i__2 = (h_dim1 << 1) + 2;
+ z__5.r = h__[i__1].r + h__[i__2].r, z__5.i = h__[i__1].i + h__[
+ i__2].i;
+ z__4.r = z__5.r - s1->r, z__4.i = z__5.i - s1->i;
+ z__3.r = z__4.r - s2->r, z__3.i = z__4.i - s2->i;
+ z__2.r = h21s.r * z__3.r - h21s.i * z__3.i, z__2.i = h21s.r *
+ z__3.i + h21s.i * z__3.r;
+ i__3 = h_dim1 * 3 + 2;
+ z__6.r = h__[i__3].r * h31s.r - h__[i__3].i * h31s.i, z__6.i =
+ h__[i__3].r * h31s.i + h__[i__3].i * h31s.r;
+ z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
+ v[2].r = z__1.r, v[2].i = z__1.i;
+ i__1 = h_dim1 + 1;
+ i__2 = h_dim1 * 3 + 3;
+ z__5.r = h__[i__1].r + h__[i__2].r, z__5.i = h__[i__1].i + h__[
+ i__2].i;
+ z__4.r = z__5.r - s1->r, z__4.i = z__5.i - s1->i;
+ z__3.r = z__4.r - s2->r, z__3.i = z__4.i - s2->i;
+ z__2.r = h31s.r * z__3.r - h31s.i * z__3.i, z__2.i = h31s.r *
+ z__3.i + h31s.i * z__3.r;
+ i__3 = (h_dim1 << 1) + 3;
+ z__6.r = h21s.r * h__[i__3].r - h21s.i * h__[i__3].i, z__6.i =
+ h21s.r * h__[i__3].i + h21s.i * h__[i__3].r;
+ z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
+ v[3].r = z__1.r, v[3].i = z__1.i;
+ }
+ }
+ return 0;
+} /* zlaqr1_ */
diff --git a/SRC/zlaqr2.c b/SRC/zlaqr2.c
new file mode 100644
index 0000000..48ccec1
--- /dev/null
+++ b/SRC/zlaqr2.c
@@ -0,0 +1,611 @@
+/* zlaqr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static logical c_true = TRUE_;
+
+/* Subroutine */ int zlaqr2_(logical *wantt, logical *wantz, integer *n,
+ integer *ktop, integer *kbot, integer *nw, doublecomplex *h__,
+ integer *ldh, integer *iloz, integer *ihiz, doublecomplex *z__,
+ integer *ldz, integer *ns, integer *nd, doublecomplex *sh,
+ doublecomplex *v, integer *ldv, integer *nh, doublecomplex *t,
+ integer *ldt, integer *nv, doublecomplex *wv, integer *ldwv,
+ doublecomplex *work, integer *lwork)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1,
+ wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublecomplex s;
+ integer jw;
+ doublereal foo;
+ integer kln;
+ doublecomplex tau;
+ integer knt;
+ doublereal ulp;
+ integer lwk1, lwk2;
+ doublecomplex beta;
+ integer kcol, info, ifst, ilst, ltop, krow;
+ extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *);
+ integer infqr;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer kwtop;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin, safmax;
+ extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *), zlarfg_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *), zlahqr_(logical *,
+ logical *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, doublecomplex *,
+ integer *, integer *), zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *);
+ doublereal smlnum;
+ extern /* Subroutine */ int ztrexc_(char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, integer *,
+ integer *);
+ integer lwkopt;
+ extern /* Subroutine */ int zunmhr_(char *, char *, integer *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+);
+
+
+/* -- LAPACK auxiliary routine (version 3.2.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* -- April 2009 -- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* This subroutine is identical to ZLAQR3 except that it avoids */
+/* recursion by calling ZLAHQR instead of ZLAQR4. */
+
+
+/* ****************************************************************** */
+/* Aggressive early deflation: */
+
+/* This subroutine accepts as input an upper Hessenberg matrix */
+/* H and performs an unitary similarity transformation */
+/* designed to detect and deflate fully converged eigenvalues from */
+/* a trailing principal submatrix. On output H has been over- */
+/* written by a new Hessenberg matrix that is a perturbation of */
+/* an unitary similarity transformation of H. It is to be */
+/* hoped that the final version of H has many zero subdiagonal */
+/* entries. */
+
+/* ****************************************************************** */
+/* WANTT (input) LOGICAL */
+/* If .TRUE., then the Hessenberg matrix H is fully updated */
+/* so that the triangular Schur factor may be */
+/* computed (in cooperation with the calling subroutine). */
+/* If .FALSE., then only enough of H is updated to preserve */
+/* the eigenvalues. */
+
+/* WANTZ (input) LOGICAL */
+/* If .TRUE., then the unitary matrix Z is updated so */
+/* so that the unitary Schur factor may be computed */
+/* (in cooperation with the calling subroutine). */
+/* If .FALSE., then Z is not referenced. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H and (if WANTZ is .TRUE.) the */
+/* order of the unitary matrix Z. */
+
+/* KTOP (input) INTEGER */
+/* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */
+/* KBOT and KTOP together determine an isolated block */
+/* along the diagonal of the Hessenberg matrix. */
+
+/* KBOT (input) INTEGER */
+/* It is assumed without a check that either */
+/* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */
+/* determine an isolated block along the diagonal of the */
+/* Hessenberg matrix. */
+
+/* NW (input) INTEGER */
+/* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). */
+
+/* H (input/output) COMPLEX*16 array, dimension (LDH,N) */
+/* On input the initial N-by-N section of H stores the */
+/* Hessenberg matrix undergoing aggressive early deflation. */
+/* On output H has been transformed by a unitary */
+/* similarity transformation, perturbed, and the returned */
+/* to Hessenberg form that (it is to be hoped) has some */
+/* zero subdiagonal entries. */
+
+/* LDH (input) integer */
+/* Leading dimension of H just as declared in the calling */
+/* subroutine. N .LE. LDH */
+
+/* ILOZ (input) INTEGER */
+/* IHIZ (input) INTEGER */
+/* Specify the rows of Z to which transformations must be */
+/* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. */
+
+/* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) */
+/* IF WANTZ is .TRUE., then on output, the unitary */
+/* similarity transformation mentioned above has been */
+/* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. */
+/* If WANTZ is .FALSE., then Z is unreferenced. */
+
+/* LDZ (input) integer */
+/* The leading dimension of Z just as declared in the */
+/* calling subroutine. 1 .LE. LDZ. */
+
+/* NS (output) integer */
+/* The number of unconverged (ie approximate) eigenvalues */
+/* returned in SR and SI that may be used as shifts by the */
+/* calling subroutine. */
+
+/* ND (output) integer */
+/* The number of converged eigenvalues uncovered by this */
+/* subroutine. */
+
+/* SH (output) COMPLEX*16 array, dimension KBOT */
+/* On output, approximate eigenvalues that may */
+/* be used for shifts are stored in SH(KBOT-ND-NS+1) */
+/* through SR(KBOT-ND). Converged eigenvalues are */
+/* stored in SH(KBOT-ND+1) through SH(KBOT). */
+
+/* V (workspace) COMPLEX*16 array, dimension (LDV,NW) */
+/* An NW-by-NW work array. */
+
+/* LDV (input) integer scalar */
+/* The leading dimension of V just as declared in the */
+/* calling subroutine. NW .LE. LDV */
+
+/* NH (input) integer scalar */
+/* The number of columns of T. NH.GE.NW. */
+
+/* T (workspace) COMPLEX*16 array, dimension (LDT,NW) */
+
+/* LDT (input) integer */
+/* The leading dimension of T just as declared in the */
+/* calling subroutine. NW .LE. LDT */
+
+/* NV (input) integer */
+/* The number of rows of work array WV available for */
+/* workspace. NV.GE.NW. */
+
+/* WV (workspace) COMPLEX*16 array, dimension (LDWV,NW) */
+
+/* LDWV (input) integer */
+/* The leading dimension of W just as declared in the */
+/* calling subroutine. NW .LE. LDV */
+
+/* WORK (workspace) COMPLEX*16 array, dimension LWORK. */
+/* On exit, WORK(1) is set to an estimate of the optimal value */
+/* of LWORK for the given values of N, NW, KTOP and KBOT. */
+
+/* LWORK (input) integer */
+/* The dimension of the work array WORK. LWORK = 2*NW */
+/* suffices, but greater efficiency may result from larger */
+/* values of LWORK. */
+
+/* If LWORK = -1, then a workspace query is assumed; ZLAQR2 */
+/* only estimates the optimal workspace size for the given */
+/* values of N, NW, KTOP and KBOT. The estimate is returned */
+/* in WORK(1). No error message related to LWORK is issued */
+/* by XERBLA. Neither H nor Z are accessed. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* ==== Estimate optimal workspace. ==== */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --sh;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ wv_dim1 = *ldwv;
+ wv_offset = 1 + wv_dim1;
+ wv -= wv_offset;
+ --work;
+
+ /* Function Body */
+/* Computing MIN */
+ i__1 = *nw, i__2 = *kbot - *ktop + 1;
+ jw = min(i__1,i__2);
+ if (jw <= 2) {
+ lwkopt = 1;
+ } else {
+
+/* ==== Workspace query call to ZGEHRD ==== */
+
+ i__1 = jw - 1;
+ zgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], &
+ c_n1, &info);
+ lwk1 = (integer) work[1].r;
+
+/* ==== Workspace query call to ZUNMHR ==== */
+
+ i__1 = jw - 1;
+ zunmhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1],
+ &v[v_offset], ldv, &work[1], &c_n1, &info);
+ lwk2 = (integer) work[1].r;
+
+/* ==== Optimal workspace ==== */
+
+ lwkopt = jw + max(lwk1,lwk2);
+ }
+
+/* ==== Quick return in case of workspace query. ==== */
+
+ if (*lwork == -1) {
+ d__1 = (doublereal) lwkopt;
+ z__1.r = d__1, z__1.i = 0.;
+ work[1].r = z__1.r, work[1].i = z__1.i;
+ return 0;
+ }
+
+/* ==== Nothing to do ... */
+/* ... for an empty active block ... ==== */
+ *ns = 0;
+ *nd = 0;
+ work[1].r = 1., work[1].i = 0.;
+ if (*ktop > *kbot) {
+ return 0;
+ }
+/* ... nor for an empty deflation window. ==== */
+ if (*nw < 1) {
+ return 0;
+ }
+
+/* ==== Machine constants ==== */
+
+ safmin = dlamch_("SAFE MINIMUM");
+ safmax = 1. / safmin;
+ dlabad_(&safmin, &safmax);
+ ulp = dlamch_("PRECISION");
+ smlnum = safmin * ((doublereal) (*n) / ulp);
+
+/* ==== Setup deflation window ==== */
+
+/* Computing MIN */
+ i__1 = *nw, i__2 = *kbot - *ktop + 1;
+ jw = min(i__1,i__2);
+ kwtop = *kbot - jw + 1;
+ if (kwtop == *ktop) {
+ s.r = 0., s.i = 0.;
+ } else {
+ i__1 = kwtop + (kwtop - 1) * h_dim1;
+ s.r = h__[i__1].r, s.i = h__[i__1].i;
+ }
+
+ if (*kbot == kwtop) {
+
+/* ==== 1-by-1 deflation window: not much to do ==== */
+
+ i__1 = kwtop;
+ i__2 = kwtop + kwtop * h_dim1;
+ sh[i__1].r = h__[i__2].r, sh[i__1].i = h__[i__2].i;
+ *ns = 1;
+ *nd = 0;
+/* Computing MAX */
+ i__1 = kwtop + kwtop * h_dim1;
+ d__5 = smlnum, d__6 = ulp * ((d__1 = h__[i__1].r, abs(d__1)) + (d__2 =
+ d_imag(&h__[kwtop + kwtop * h_dim1]), abs(d__2)));
+ if ((d__3 = s.r, abs(d__3)) + (d__4 = d_imag(&s), abs(d__4)) <= max(
+ d__5,d__6)) {
+ *ns = 0;
+ *nd = 1;
+ if (kwtop > *ktop) {
+ i__1 = kwtop + (kwtop - 1) * h_dim1;
+ h__[i__1].r = 0., h__[i__1].i = 0.;
+ }
+ }
+ work[1].r = 1., work[1].i = 0.;
+ return 0;
+ }
+
+/* ==== Convert to spike-triangular form. (In case of a */
+/* . rare QR failure, this routine continues to do */
+/* . aggressive early deflation using that part of */
+/* . the deflation window that converged using INFQR */
+/* . here and there to keep track.) ==== */
+
+ zlacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset],
+ ldt);
+ i__1 = jw - 1;
+ i__2 = *ldh + 1;
+ i__3 = *ldt + 1;
+ zcopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], &
+ i__3);
+
+ zlaset_("A", &jw, &jw, &c_b1, &c_b2, &v[v_offset], ldv);
+ zlahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[kwtop],
+ &c__1, &jw, &v[v_offset], ldv, &infqr);
+
+/* ==== Deflation detection loop ==== */
+
+ *ns = jw;
+ ilst = infqr + 1;
+ i__1 = jw;
+ for (knt = infqr + 1; knt <= i__1; ++knt) {
+
+/* ==== Small spike tip deflation test ==== */
+
+ i__2 = *ns + *ns * t_dim1;
+ foo = (d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&t[*ns + *ns *
+ t_dim1]), abs(d__2));
+ if (foo == 0.) {
+ foo = (d__1 = s.r, abs(d__1)) + (d__2 = d_imag(&s), abs(d__2));
+ }
+ i__2 = *ns * v_dim1 + 1;
+/* Computing MAX */
+ d__5 = smlnum, d__6 = ulp * foo;
+ if (((d__1 = s.r, abs(d__1)) + (d__2 = d_imag(&s), abs(d__2))) * ((
+ d__3 = v[i__2].r, abs(d__3)) + (d__4 = d_imag(&v[*ns * v_dim1
+ + 1]), abs(d__4))) <= max(d__5,d__6)) {
+
+/* ==== One more converged eigenvalue ==== */
+
+ --(*ns);
+ } else {
+
+/* ==== One undeflatable eigenvalue. Move it up out of the */
+/* . way. (ZTREXC can not fail in this case.) ==== */
+
+ ifst = *ns;
+ ztrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &
+ ilst, &info);
+ ++ilst;
+ }
+/* L10: */
+ }
+
+/* ==== Return to Hessenberg form ==== */
+
+ if (*ns == 0) {
+ s.r = 0., s.i = 0.;
+ }
+
+ if (*ns < jw) {
+
+/* ==== sorting the diagonal of T improves accuracy for */
+/* . graded matrices. ==== */
+
+ i__1 = *ns;
+ for (i__ = infqr + 1; i__ <= i__1; ++i__) {
+ ifst = i__;
+ i__2 = *ns;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + j * t_dim1;
+ i__4 = ifst + ifst * t_dim1;
+ if ((d__1 = t[i__3].r, abs(d__1)) + (d__2 = d_imag(&t[j + j *
+ t_dim1]), abs(d__2)) > (d__3 = t[i__4].r, abs(d__3))
+ + (d__4 = d_imag(&t[ifst + ifst * t_dim1]), abs(d__4))
+ ) {
+ ifst = j;
+ }
+/* L20: */
+ }
+ ilst = i__;
+ if (ifst != ilst) {
+ ztrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
+ &ilst, &info);
+ }
+/* L30: */
+ }
+ }
+
+/* ==== Restore shift/eigenvalue array from T ==== */
+
+ i__1 = jw;
+ for (i__ = infqr + 1; i__ <= i__1; ++i__) {
+ i__2 = kwtop + i__ - 1;
+ i__3 = i__ + i__ * t_dim1;
+ sh[i__2].r = t[i__3].r, sh[i__2].i = t[i__3].i;
+/* L40: */
+ }
+
+
+ if (*ns < jw || s.r == 0. && s.i == 0.) {
+ if (*ns > 1 && (s.r != 0. || s.i != 0.)) {
+
+/* ==== Reflect spike back into lower triangle ==== */
+
+ zcopy_(ns, &v[v_offset], ldv, &work[1], &c__1);
+ i__1 = *ns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ d_cnjg(&z__1, &work[i__]);
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L50: */
+ }
+ beta.r = work[1].r, beta.i = work[1].i;
+ zlarfg_(ns, &beta, &work[2], &c__1, &tau);
+ work[1].r = 1., work[1].i = 0.;
+
+ i__1 = jw - 2;
+ i__2 = jw - 2;
+ zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &t[t_dim1 + 3], ldt);
+
+ d_cnjg(&z__1, &tau);
+ zlarf_("L", ns, &jw, &work[1], &c__1, &z__1, &t[t_offset], ldt, &
+ work[jw + 1]);
+ zlarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, &
+ work[jw + 1]);
+ zlarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, &
+ work[jw + 1]);
+
+ i__1 = *lwork - jw;
+ zgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1]
+, &i__1, &info);
+ }
+
+/* ==== Copy updated reduced window into place ==== */
+
+ if (kwtop > 1) {
+ i__1 = kwtop + (kwtop - 1) * h_dim1;
+ d_cnjg(&z__2, &v[v_dim1 + 1]);
+ z__1.r = s.r * z__2.r - s.i * z__2.i, z__1.i = s.r * z__2.i + s.i
+ * z__2.r;
+ h__[i__1].r = z__1.r, h__[i__1].i = z__1.i;
+ }
+ zlacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1]
+, ldh);
+ i__1 = jw - 1;
+ i__2 = *ldt + 1;
+ i__3 = *ldh + 1;
+ zcopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1],
+ &i__3);
+
+/* ==== Accumulate orthogonal matrix in order update */
+/* . H and Z, if requested. ==== */
+
+ if (*ns > 1 && (s.r != 0. || s.i != 0.)) {
+ i__1 = *lwork - jw;
+ zunmhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1],
+ &v[v_offset], ldv, &work[jw + 1], &i__1, &info);
+ }
+
+/* ==== Update vertical slab in H ==== */
+
+ if (*wantt) {
+ ltop = 1;
+ } else {
+ ltop = *ktop;
+ }
+ i__1 = kwtop - 1;
+ i__2 = *nv;
+ for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *nv, i__4 = kwtop - krow;
+ kln = min(i__3,i__4);
+ zgemm_("N", "N", &kln, &jw, &jw, &c_b2, &h__[krow + kwtop *
+ h_dim1], ldh, &v[v_offset], ldv, &c_b1, &wv[wv_offset],
+ ldwv);
+ zlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop *
+ h_dim1], ldh);
+/* L60: */
+ }
+
+/* ==== Update horizontal slab in H ==== */
+
+ if (*wantt) {
+ i__2 = *n;
+ i__1 = *nh;
+ for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2;
+ kcol += i__1) {
+/* Computing MIN */
+ i__3 = *nh, i__4 = *n - kcol + 1;
+ kln = min(i__3,i__4);
+ zgemm_("C", "N", &jw, &kln, &jw, &c_b2, &v[v_offset], ldv, &
+ h__[kwtop + kcol * h_dim1], ldh, &c_b1, &t[t_offset],
+ ldt);
+ zlacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol *
+ h_dim1], ldh);
+/* L70: */
+ }
+ }
+
+/* ==== Update vertical slab in Z ==== */
+
+ if (*wantz) {
+ i__1 = *ihiz;
+ i__2 = *nv;
+ for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *nv, i__4 = *ihiz - krow + 1;
+ kln = min(i__3,i__4);
+ zgemm_("N", "N", &kln, &jw, &jw, &c_b2, &z__[krow + kwtop *
+ z_dim1], ldz, &v[v_offset], ldv, &c_b1, &wv[wv_offset]
+, ldwv);
+ zlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow +
+ kwtop * z_dim1], ldz);
+/* L80: */
+ }
+ }
+ }
+
+/* ==== Return the number of deflations ... ==== */
+
+ *nd = jw - *ns;
+
+/* ==== ... and the number of shifts. (Subtracting */
+/* . INFQR from the spike length takes care */
+/* . of the case of a rare QR failure while */
+/* . calculating eigenvalues of the deflation */
+/* . window.) ==== */
+
+ *ns -= infqr;
+
+/* ==== Return optimal workspace. ==== */
+
+ d__1 = (doublereal) lwkopt;
+ z__1.r = d__1, z__1.i = 0.;
+ work[1].r = z__1.r, work[1].i = z__1.i;
+
+/* ==== End of ZLAQR2 ==== */
+
+ return 0;
+} /* zlaqr2_ */
diff --git a/SRC/zlaqr3.c b/SRC/zlaqr3.c
new file mode 100644
index 0000000..a9d3453
--- /dev/null
+++ b/SRC/zlaqr3.c
@@ -0,0 +1,630 @@
+/* zlaqr3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static logical c_true = TRUE_;
+static integer c__12 = 12;
+
+/* Subroutine */ int zlaqr3_(logical *wantt, logical *wantz, integer *n,
+ integer *ktop, integer *kbot, integer *nw, doublecomplex *h__,
+ integer *ldh, integer *iloz, integer *ihiz, doublecomplex *z__,
+ integer *ldz, integer *ns, integer *nd, doublecomplex *sh,
+ doublecomplex *v, integer *ldv, integer *nh, doublecomplex *t,
+ integer *ldt, integer *nv, doublecomplex *wv, integer *ldwv,
+ doublecomplex *work, integer *lwork)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1,
+ wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublecomplex s;
+ integer jw;
+ doublereal foo;
+ integer kln;
+ doublecomplex tau;
+ integer knt;
+ doublereal ulp;
+ integer lwk1, lwk2, lwk3;
+ doublecomplex beta;
+ integer kcol, info, nmin, ifst, ilst, ltop, krow;
+ extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *);
+ integer infqr;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer kwtop;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), dlabad_(doublereal *, doublereal *),
+ zlaqr4_(logical *, logical *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ doublereal safmax;
+ extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *), zlarfg_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *), zlahqr_(logical *,
+ logical *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, doublecomplex *,
+ integer *, integer *), zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *);
+ doublereal smlnum;
+ extern /* Subroutine */ int ztrexc_(char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, integer *,
+ integer *);
+ integer lwkopt;
+ extern /* Subroutine */ int zunmhr_(char *, char *, integer *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+);
+
+
+/* -- LAPACK auxiliary routine (version 3.2.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* -- April 2009 -- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* ****************************************************************** */
+/* Aggressive early deflation: */
+
+/* This subroutine accepts as input an upper Hessenberg matrix */
+/* H and performs an unitary similarity transformation */
+/* designed to detect and deflate fully converged eigenvalues from */
+/* a trailing principal submatrix. On output H has been over- */
+/* written by a new Hessenberg matrix that is a perturbation of */
+/* an unitary similarity transformation of H. It is to be */
+/* hoped that the final version of H has many zero subdiagonal */
+/* entries. */
+
+/* ****************************************************************** */
+/* WANTT (input) LOGICAL */
+/* If .TRUE., then the Hessenberg matrix H is fully updated */
+/* so that the triangular Schur factor may be */
+/* computed (in cooperation with the calling subroutine). */
+/* If .FALSE., then only enough of H is updated to preserve */
+/* the eigenvalues. */
+
+/* WANTZ (input) LOGICAL */
+/* If .TRUE., then the unitary matrix Z is updated so */
+/* so that the unitary Schur factor may be computed */
+/* (in cooperation with the calling subroutine). */
+/* If .FALSE., then Z is not referenced. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H and (if WANTZ is .TRUE.) the */
+/* order of the unitary matrix Z. */
+
+/* KTOP (input) INTEGER */
+/* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */
+/* KBOT and KTOP together determine an isolated block */
+/* along the diagonal of the Hessenberg matrix. */
+
+/* KBOT (input) INTEGER */
+/* It is assumed without a check that either */
+/* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */
+/* determine an isolated block along the diagonal of the */
+/* Hessenberg matrix. */
+
+/* NW (input) INTEGER */
+/* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1). */
+
+/* H (input/output) COMPLEX*16 array, dimension (LDH,N) */
+/* On input the initial N-by-N section of H stores the */
+/* Hessenberg matrix undergoing aggressive early deflation. */
+/* On output H has been transformed by a unitary */
+/* similarity transformation, perturbed, and the returned */
+/* to Hessenberg form that (it is to be hoped) has some */
+/* zero subdiagonal entries. */
+
+/* LDH (input) integer */
+/* Leading dimension of H just as declared in the calling */
+/* subroutine. N .LE. LDH */
+
+/* ILOZ (input) INTEGER */
+/* IHIZ (input) INTEGER */
+/* Specify the rows of Z to which transformations must be */
+/* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. */
+
+/* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) */
+/* IF WANTZ is .TRUE., then on output, the unitary */
+/* similarity transformation mentioned above has been */
+/* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. */
+/* If WANTZ is .FALSE., then Z is unreferenced. */
+
+/* LDZ (input) integer */
+/* The leading dimension of Z just as declared in the */
+/* calling subroutine. 1 .LE. LDZ. */
+
+/* NS (output) integer */
+/* The number of unconverged (ie approximate) eigenvalues */
+/* returned in SR and SI that may be used as shifts by the */
+/* calling subroutine. */
+
+/* ND (output) integer */
+/* The number of converged eigenvalues uncovered by this */
+/* subroutine. */
+
+/* SH (output) COMPLEX*16 array, dimension KBOT */
+/* On output, approximate eigenvalues that may */
+/* be used for shifts are stored in SH(KBOT-ND-NS+1) */
+/* through SR(KBOT-ND). Converged eigenvalues are */
+/* stored in SH(KBOT-ND+1) through SH(KBOT). */
+
+/* V (workspace) COMPLEX*16 array, dimension (LDV,NW) */
+/* An NW-by-NW work array. */
+
+/* LDV (input) integer scalar */
+/* The leading dimension of V just as declared in the */
+/* calling subroutine. NW .LE. LDV */
+
+/* NH (input) integer scalar */
+/* The number of columns of T. NH.GE.NW. */
+
+/* T (workspace) COMPLEX*16 array, dimension (LDT,NW) */
+
+/* LDT (input) integer */
+/* The leading dimension of T just as declared in the */
+/* calling subroutine. NW .LE. LDT */
+
+/* NV (input) integer */
+/* The number of rows of work array WV available for */
+/* workspace. NV.GE.NW. */
+
+/* WV (workspace) COMPLEX*16 array, dimension (LDWV,NW) */
+
+/* LDWV (input) integer */
+/* The leading dimension of W just as declared in the */
+/* calling subroutine. NW .LE. LDV */
+
+/* WORK (workspace) COMPLEX*16 array, dimension LWORK. */
+/* On exit, WORK(1) is set to an estimate of the optimal value */
+/* of LWORK for the given values of N, NW, KTOP and KBOT. */
+
+/* LWORK (input) integer */
+/* The dimension of the work array WORK. LWORK = 2*NW */
+/* suffices, but greater efficiency may result from larger */
+/* values of LWORK. */
+
+/* If LWORK = -1, then a workspace query is assumed; ZLAQR3 */
+/* only estimates the optimal workspace size for the given */
+/* values of N, NW, KTOP and KBOT. The estimate is returned */
+/* in WORK(1). No error message related to LWORK is issued */
+/* by XERBLA. Neither H nor Z are accessed. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* ==== Estimate optimal workspace. ==== */
+
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --sh;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ wv_dim1 = *ldwv;
+ wv_offset = 1 + wv_dim1;
+ wv -= wv_offset;
+ --work;
+
+ /* Function Body */
+/* Computing MIN */
+ i__1 = *nw, i__2 = *kbot - *ktop + 1;
+ jw = min(i__1,i__2);
+ if (jw <= 2) {
+ lwkopt = 1;
+ } else {
+
+/* ==== Workspace query call to ZGEHRD ==== */
+
+ i__1 = jw - 1;
+ zgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], &
+ c_n1, &info);
+ lwk1 = (integer) work[1].r;
+
+/* ==== Workspace query call to ZUNMHR ==== */
+
+ i__1 = jw - 1;
+ zunmhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1],
+ &v[v_offset], ldv, &work[1], &c_n1, &info);
+ lwk2 = (integer) work[1].r;
+
+/* ==== Workspace query call to ZLAQR4 ==== */
+
+ zlaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[1],
+ &c__1, &jw, &v[v_offset], ldv, &work[1], &c_n1, &infqr);
+ lwk3 = (integer) work[1].r;
+
+/* ==== Optimal workspace ==== */
+
+/* Computing MAX */
+ i__1 = jw + max(lwk1,lwk2);
+ lwkopt = max(i__1,lwk3);
+ }
+
+/* ==== Quick return in case of workspace query. ==== */
+
+ if (*lwork == -1) {
+ d__1 = (doublereal) lwkopt;
+ z__1.r = d__1, z__1.i = 0.;
+ work[1].r = z__1.r, work[1].i = z__1.i;
+ return 0;
+ }
+
+/* ==== Nothing to do ... */
+/* ... for an empty active block ... ==== */
+ *ns = 0;
+ *nd = 0;
+ work[1].r = 1., work[1].i = 0.;
+ if (*ktop > *kbot) {
+ return 0;
+ }
+/* ... nor for an empty deflation window. ==== */
+ if (*nw < 1) {
+ return 0;
+ }
+
+/* ==== Machine constants ==== */
+
+ safmin = dlamch_("SAFE MINIMUM");
+ safmax = 1. / safmin;
+ dlabad_(&safmin, &safmax);
+ ulp = dlamch_("PRECISION");
+ smlnum = safmin * ((doublereal) (*n) / ulp);
+
+/* ==== Setup deflation window ==== */
+
+/* Computing MIN */
+ i__1 = *nw, i__2 = *kbot - *ktop + 1;
+ jw = min(i__1,i__2);
+ kwtop = *kbot - jw + 1;
+ if (kwtop == *ktop) {
+ s.r = 0., s.i = 0.;
+ } else {
+ i__1 = kwtop + (kwtop - 1) * h_dim1;
+ s.r = h__[i__1].r, s.i = h__[i__1].i;
+ }
+
+ if (*kbot == kwtop) {
+
+/* ==== 1-by-1 deflation window: not much to do ==== */
+
+ i__1 = kwtop;
+ i__2 = kwtop + kwtop * h_dim1;
+ sh[i__1].r = h__[i__2].r, sh[i__1].i = h__[i__2].i;
+ *ns = 1;
+ *nd = 0;
+/* Computing MAX */
+ i__1 = kwtop + kwtop * h_dim1;
+ d__5 = smlnum, d__6 = ulp * ((d__1 = h__[i__1].r, abs(d__1)) + (d__2 =
+ d_imag(&h__[kwtop + kwtop * h_dim1]), abs(d__2)));
+ if ((d__3 = s.r, abs(d__3)) + (d__4 = d_imag(&s), abs(d__4)) <= max(
+ d__5,d__6)) {
+ *ns = 0;
+ *nd = 1;
+ if (kwtop > *ktop) {
+ i__1 = kwtop + (kwtop - 1) * h_dim1;
+ h__[i__1].r = 0., h__[i__1].i = 0.;
+ }
+ }
+ work[1].r = 1., work[1].i = 0.;
+ return 0;
+ }
+
+/* ==== Convert to spike-triangular form. (In case of a */
+/* . rare QR failure, this routine continues to do */
+/* . aggressive early deflation using that part of */
+/* . the deflation window that converged using INFQR */
+/* . here and there to keep track.) ==== */
+
+ zlacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset],
+ ldt);
+ i__1 = jw - 1;
+ i__2 = *ldh + 1;
+ i__3 = *ldt + 1;
+ zcopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], &
+ i__3);
+
+ zlaset_("A", &jw, &jw, &c_b1, &c_b2, &v[v_offset], ldv);
+ nmin = ilaenv_(&c__12, "ZLAQR3", "SV", &jw, &c__1, &jw, lwork);
+ if (jw > nmin) {
+ zlaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[
+ kwtop], &c__1, &jw, &v[v_offset], ldv, &work[1], lwork, &
+ infqr);
+ } else {
+ zlahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[
+ kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr);
+ }
+
+/* ==== Deflation detection loop ==== */
+
+ *ns = jw;
+ ilst = infqr + 1;
+ i__1 = jw;
+ for (knt = infqr + 1; knt <= i__1; ++knt) {
+
+/* ==== Small spike tip deflation test ==== */
+
+ i__2 = *ns + *ns * t_dim1;
+ foo = (d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&t[*ns + *ns *
+ t_dim1]), abs(d__2));
+ if (foo == 0.) {
+ foo = (d__1 = s.r, abs(d__1)) + (d__2 = d_imag(&s), abs(d__2));
+ }
+ i__2 = *ns * v_dim1 + 1;
+/* Computing MAX */
+ d__5 = smlnum, d__6 = ulp * foo;
+ if (((d__1 = s.r, abs(d__1)) + (d__2 = d_imag(&s), abs(d__2))) * ((
+ d__3 = v[i__2].r, abs(d__3)) + (d__4 = d_imag(&v[*ns * v_dim1
+ + 1]), abs(d__4))) <= max(d__5,d__6)) {
+
+/* ==== One more converged eigenvalue ==== */
+
+ --(*ns);
+ } else {
+
+/* ==== One undeflatable eigenvalue. Move it up out of the */
+/* . way. (ZTREXC can not fail in this case.) ==== */
+
+ ifst = *ns;
+ ztrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, &
+ ilst, &info);
+ ++ilst;
+ }
+/* L10: */
+ }
+
+/* ==== Return to Hessenberg form ==== */
+
+ if (*ns == 0) {
+ s.r = 0., s.i = 0.;
+ }
+
+ if (*ns < jw) {
+
+/* ==== sorting the diagonal of T improves accuracy for */
+/* . graded matrices. ==== */
+
+ i__1 = *ns;
+ for (i__ = infqr + 1; i__ <= i__1; ++i__) {
+ ifst = i__;
+ i__2 = *ns;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + j * t_dim1;
+ i__4 = ifst + ifst * t_dim1;
+ if ((d__1 = t[i__3].r, abs(d__1)) + (d__2 = d_imag(&t[j + j *
+ t_dim1]), abs(d__2)) > (d__3 = t[i__4].r, abs(d__3))
+ + (d__4 = d_imag(&t[ifst + ifst * t_dim1]), abs(d__4))
+ ) {
+ ifst = j;
+ }
+/* L20: */
+ }
+ ilst = i__;
+ if (ifst != ilst) {
+ ztrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst,
+ &ilst, &info);
+ }
+/* L30: */
+ }
+ }
+
+/* ==== Restore shift/eigenvalue array from T ==== */
+
+ i__1 = jw;
+ for (i__ = infqr + 1; i__ <= i__1; ++i__) {
+ i__2 = kwtop + i__ - 1;
+ i__3 = i__ + i__ * t_dim1;
+ sh[i__2].r = t[i__3].r, sh[i__2].i = t[i__3].i;
+/* L40: */
+ }
+
+
+ if (*ns < jw || s.r == 0. && s.i == 0.) {
+ if (*ns > 1 && (s.r != 0. || s.i != 0.)) {
+
+/* ==== Reflect spike back into lower triangle ==== */
+
+ zcopy_(ns, &v[v_offset], ldv, &work[1], &c__1);
+ i__1 = *ns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ d_cnjg(&z__1, &work[i__]);
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L50: */
+ }
+ beta.r = work[1].r, beta.i = work[1].i;
+ zlarfg_(ns, &beta, &work[2], &c__1, &tau);
+ work[1].r = 1., work[1].i = 0.;
+
+ i__1 = jw - 2;
+ i__2 = jw - 2;
+ zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &t[t_dim1 + 3], ldt);
+
+ d_cnjg(&z__1, &tau);
+ zlarf_("L", ns, &jw, &work[1], &c__1, &z__1, &t[t_offset], ldt, &
+ work[jw + 1]);
+ zlarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, &
+ work[jw + 1]);
+ zlarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, &
+ work[jw + 1]);
+
+ i__1 = *lwork - jw;
+ zgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1]
+, &i__1, &info);
+ }
+
+/* ==== Copy updated reduced window into place ==== */
+
+ if (kwtop > 1) {
+ i__1 = kwtop + (kwtop - 1) * h_dim1;
+ d_cnjg(&z__2, &v[v_dim1 + 1]);
+ z__1.r = s.r * z__2.r - s.i * z__2.i, z__1.i = s.r * z__2.i + s.i
+ * z__2.r;
+ h__[i__1].r = z__1.r, h__[i__1].i = z__1.i;
+ }
+ zlacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1]
+, ldh);
+ i__1 = jw - 1;
+ i__2 = *ldt + 1;
+ i__3 = *ldh + 1;
+ zcopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1],
+ &i__3);
+
+/* ==== Accumulate orthogonal matrix in order update */
+/* . H and Z, if requested. ==== */
+
+ if (*ns > 1 && (s.r != 0. || s.i != 0.)) {
+ i__1 = *lwork - jw;
+ zunmhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1],
+ &v[v_offset], ldv, &work[jw + 1], &i__1, &info);
+ }
+
+/* ==== Update vertical slab in H ==== */
+
+ if (*wantt) {
+ ltop = 1;
+ } else {
+ ltop = *ktop;
+ }
+ i__1 = kwtop - 1;
+ i__2 = *nv;
+ for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *nv, i__4 = kwtop - krow;
+ kln = min(i__3,i__4);
+ zgemm_("N", "N", &kln, &jw, &jw, &c_b2, &h__[krow + kwtop *
+ h_dim1], ldh, &v[v_offset], ldv, &c_b1, &wv[wv_offset],
+ ldwv);
+ zlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop *
+ h_dim1], ldh);
+/* L60: */
+ }
+
+/* ==== Update horizontal slab in H ==== */
+
+ if (*wantt) {
+ i__2 = *n;
+ i__1 = *nh;
+ for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2;
+ kcol += i__1) {
+/* Computing MIN */
+ i__3 = *nh, i__4 = *n - kcol + 1;
+ kln = min(i__3,i__4);
+ zgemm_("C", "N", &jw, &kln, &jw, &c_b2, &v[v_offset], ldv, &
+ h__[kwtop + kcol * h_dim1], ldh, &c_b1, &t[t_offset],
+ ldt);
+ zlacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol *
+ h_dim1], ldh);
+/* L70: */
+ }
+ }
+
+/* ==== Update vertical slab in Z ==== */
+
+ if (*wantz) {
+ i__1 = *ihiz;
+ i__2 = *nv;
+ for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow +=
+ i__2) {
+/* Computing MIN */
+ i__3 = *nv, i__4 = *ihiz - krow + 1;
+ kln = min(i__3,i__4);
+ zgemm_("N", "N", &kln, &jw, &jw, &c_b2, &z__[krow + kwtop *
+ z_dim1], ldz, &v[v_offset], ldv, &c_b1, &wv[wv_offset]
+, ldwv);
+ zlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow +
+ kwtop * z_dim1], ldz);
+/* L80: */
+ }
+ }
+ }
+
+/* ==== Return the number of deflations ... ==== */
+
+ *nd = jw - *ns;
+
+/* ==== ... and the number of shifts. (Subtracting */
+/* . INFQR from the spike length takes care */
+/* . of the case of a rare QR failure while */
+/* . calculating eigenvalues of the deflation */
+/* . window.) ==== */
+
+ *ns -= infqr;
+
+/* ==== Return optimal workspace. ==== */
+
+ d__1 = (doublereal) lwkopt;
+ z__1.r = d__1, z__1.i = 0.;
+ work[1].r = z__1.r, work[1].i = z__1.i;
+
+/* ==== End of ZLAQR3 ==== */
+
+ return 0;
+} /* zlaqr3_ */
diff --git a/SRC/zlaqr4.c b/SRC/zlaqr4.c
new file mode 100644
index 0000000..f6acaa5
--- /dev/null
+++ b/SRC/zlaqr4.c
@@ -0,0 +1,785 @@
+/* zlaqr4.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__13 = 13;
+static integer c__15 = 15;
+static integer c_n1 = -1;
+static integer c__12 = 12;
+static integer c__14 = 14;
+static integer c__16 = 16;
+static logical c_false = FALSE_;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int zlaqr4_(logical *wantt, logical *wantz, integer *n,
+ integer *ilo, integer *ihi, doublecomplex *h__, integer *ldh,
+ doublecomplex *w, integer *iloz, integer *ihiz, doublecomplex *z__,
+ integer *ldz, doublecomplex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8;
+ doublecomplex z__1, z__2, z__3, z__4, z__5;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void z_sqrt(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, k;
+ doublereal s;
+ doublecomplex aa, bb, cc, dd;
+ integer ld, nh, it, ks, kt, ku, kv, ls, ns, nw;
+ doublecomplex tr2, det;
+ integer inf, kdu, nho, nve, kwh, nsr, nwr, kwv, ndec, ndfl, kbot, nmin;
+ doublecomplex swap;
+ integer ktop;
+ doublecomplex zdum[1] /* was [1][1] */;
+ integer kacc22, itmax, nsmax, nwmax, kwtop;
+ extern /* Subroutine */ int zlaqr2_(logical *, logical *, integer *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ integer *, integer *, doublecomplex *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *
+, doublecomplex *, integer *), zlaqr5_(logical *, logical *,
+ integer *, integer *, integer *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *, doublecomplex *, integer *);
+ integer nibble;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ char jbcmpz[2];
+ doublecomplex rtdisc;
+ integer nwupbd;
+ logical sorted;
+ extern /* Subroutine */ int zlahqr_(logical *, logical *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *, integer *),
+ zlacpy_(char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ integer lwkopt;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* This subroutine implements one level of recursion for ZLAQR0. */
+/* It is a complete implementation of the small bulge multi-shift */
+/* QR algorithm. It may be called by ZLAQR0 and, for large enough */
+/* deflation window size, it may be called by ZLAQR3. This */
+/* subroutine is identical to ZLAQR0 except that it calls ZLAQR2 */
+/* instead of ZLAQR3. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAQR4 computes the eigenvalues of a Hessenberg matrix H */
+/* and, optionally, the matrices T and Z from the Schur decomposition */
+/* H = Z T Z**H, where T is an upper triangular matrix (the */
+/* Schur form), and Z is the unitary matrix of Schur vectors. */
+
+/* Optionally Z may be postmultiplied into an input unitary */
+/* matrix Q so that this routine can give the Schur factorization */
+/* of a matrix A which has been reduced to the Hessenberg form H */
+/* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. */
+
+/* Arguments */
+/* ========= */
+
+/* WANTT (input) LOGICAL */
+/* = .TRUE. : the full Schur form T is required; */
+/* = .FALSE.: only eigenvalues are required. */
+
+/* WANTZ (input) LOGICAL */
+/* = .TRUE. : the matrix of Schur vectors Z is required; */
+/* = .FALSE.: Schur vectors are not required. */
+
+/* N (input) INTEGER */
+/* The order of the matrix H. N .GE. 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* It is assumed that H is already upper triangular in rows */
+/* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1, */
+/* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a */
+/* previous call to ZGEBAL, and then passed to ZGEHRD when the */
+/* matrix output by ZGEBAL is reduced to Hessenberg form. */
+/* Otherwise, ILO and IHI should be set to 1 and N, */
+/* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N. */
+/* If N = 0, then ILO = 1 and IHI = 0. */
+
+/* H (input/output) COMPLEX*16 array, dimension (LDH,N) */
+/* On entry, the upper Hessenberg matrix H. */
+/* On exit, if INFO = 0 and WANTT is .TRUE., then H */
+/* contains the upper triangular matrix T from the Schur */
+/* decomposition (the Schur form). If INFO = 0 and WANT is */
+/* .FALSE., then the contents of H are unspecified on exit. */
+/* (The output value of H when INFO.GT.0 is given under the */
+/* description of INFO below.) */
+
+/* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and */
+/* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH .GE. max(1,N). */
+
+/* W (output) COMPLEX*16 array, dimension (N) */
+/* The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored */
+/* in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are */
+/* stored in the same order as on the diagonal of the Schur */
+/* form returned in H, with W(i) = H(i,i). */
+
+/* Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI) */
+/* If WANTZ is .FALSE., then Z is not referenced. */
+/* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is */
+/* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the */
+/* orthogonal Schur factor of H(ILO:IHI,ILO:IHI). */
+/* (The output value of Z when INFO.GT.0 is given under */
+/* the description of INFO below.) */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. if WANTZ is .TRUE. */
+/* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension LWORK */
+/* On exit, if LWORK = -1, WORK(1) returns an estimate of */
+/* the optimal value for LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK .GE. max(1,N) */
+/* is sufficient, but LWORK typically as large as 6*N may */
+/* be required for optimal performance. A workspace query */
+/* to determine the optimal workspace size is recommended. */
+
+/* If LWORK = -1, then ZLAQR4 does a workspace query. */
+/* In this case, ZLAQR4 checks the input parameters and */
+/* estimates the optimal workspace size for the given */
+/* values of N, ILO and IHI. The estimate is returned */
+/* in WORK(1). No error message related to LWORK is */
+/* issued by XERBLA. Neither H nor Z are accessed. */
+
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* .GT. 0: if INFO = i, ZLAQR4 failed to compute all of */
+/* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */
+/* and WI contain those eigenvalues which have been */
+/* successfully computed. (Failures are rare.) */
+
+/* If INFO .GT. 0 and WANT is .FALSE., then on exit, */
+/* the remaining unconverged eigenvalues are the eigen- */
+/* values of the upper Hessenberg matrix rows and */
+/* columns ILO through INFO of the final, output */
+/* value of H. */
+
+/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */
+
+/* (*) (initial value of H)*U = U*(final value of H) */
+
+/* where U is a unitary matrix. The final */
+/* value of H is upper Hessenberg and triangular in */
+/* rows and columns INFO+1 through IHI. */
+
+/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
+
+/* (final value of Z(ILO:IHI,ILOZ:IHIZ) */
+/* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U */
+
+/* where U is the unitary matrix in (*) (regard- */
+/* less of the value of WANTT.) */
+
+/* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not */
+/* accessed. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* References: */
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */
+/* Performance, SIAM Journal of Matrix Analysis, volume 23, pages */
+/* 929--947, 2002. */
+
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part II: Aggressive Early Deflation, SIAM Journal */
+/* of Matrix Analysis, volume 23, pages 948--973, 2002. */
+
+/* ================================================================ */
+/* .. Parameters .. */
+
+/* ==== Matrices of order NTINY or smaller must be processed by */
+/* . ZLAHQR because of insufficient subdiagonal scratch space. */
+/* . (This is a hard limit.) ==== */
+
+/* ==== Exceptional deflation windows: try to cure rare */
+/* . slow convergence by varying the size of the */
+/* . deflation window after KEXNW iterations. ==== */
+
+/* ==== Exceptional shifts: try to cure rare slow convergence */
+/* . with ad-hoc exceptional shifts every KEXSH iterations. */
+/* . ==== */
+
+/* ==== The constant WILK1 is used to form the exceptional */
+/* . shifts. ==== */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* ==== Quick return for N = 0: nothing to do. ==== */
+
+ if (*n == 0) {
+ work[1].r = 1., work[1].i = 0.;
+ return 0;
+ }
+
+ if (*n <= 11) {
+
+/* ==== Tiny matrices must use ZLAHQR. ==== */
+
+ lwkopt = 1;
+ if (*lwork != -1) {
+ zlahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1],
+ iloz, ihiz, &z__[z_offset], ldz, info);
+ }
+ } else {
+
+/* ==== Use small bulge multi-shift QR with aggressive early */
+/* . deflation on larger-than-tiny matrices. ==== */
+
+/* ==== Hope for the best. ==== */
+
+ *info = 0;
+
+/* ==== Set up job flags for ILAENV. ==== */
+
+ if (*wantt) {
+ *(unsigned char *)jbcmpz = 'S';
+ } else {
+ *(unsigned char *)jbcmpz = 'E';
+ }
+ if (*wantz) {
+ *(unsigned char *)&jbcmpz[1] = 'V';
+ } else {
+ *(unsigned char *)&jbcmpz[1] = 'N';
+ }
+
+/* ==== NWR = recommended deflation window size. At this */
+/* . point, N .GT. NTINY = 11, so there is enough */
+/* . subdiagonal workspace for NWR.GE.2 as required. */
+/* . (In fact, there is enough subdiagonal space for */
+/* . NWR.GE.3.) ==== */
+
+ nwr = ilaenv_(&c__13, "ZLAQR4", jbcmpz, n, ilo, ihi, lwork);
+ nwr = max(2,nwr);
+/* Computing MIN */
+ i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = min(i__1,i__2);
+ nwr = min(i__1,nwr);
+
+/* ==== NSR = recommended number of simultaneous shifts. */
+/* . At this point N .GT. NTINY = 11, so there is at */
+/* . enough subdiagonal workspace for NSR to be even */
+/* . and greater than or equal to two as required. ==== */
+
+ nsr = ilaenv_(&c__15, "ZLAQR4", jbcmpz, n, ilo, ihi, lwork);
+/* Computing MIN */
+ i__1 = nsr, i__2 = (*n + 6) / 9, i__1 = min(i__1,i__2), i__2 = *ihi -
+ *ilo;
+ nsr = min(i__1,i__2);
+/* Computing MAX */
+ i__1 = 2, i__2 = nsr - nsr % 2;
+ nsr = max(i__1,i__2);
+
+/* ==== Estimate optimal workspace ==== */
+
+/* ==== Workspace query call to ZLAQR2 ==== */
+
+ i__1 = nwr + 1;
+ zlaqr2_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz,
+ ihiz, &z__[z_offset], ldz, &ls, &ld, &w[1], &h__[h_offset],
+ ldh, n, &h__[h_offset], ldh, n, &h__[h_offset], ldh, &work[1],
+ &c_n1);
+
+/* ==== Optimal workspace = MAX(ZLAQR5, ZLAQR2) ==== */
+
+/* Computing MAX */
+ i__1 = nsr * 3 / 2, i__2 = (integer) work[1].r;
+ lwkopt = max(i__1,i__2);
+
+/* ==== Quick return in case of workspace query. ==== */
+
+ if (*lwork == -1) {
+ d__1 = (doublereal) lwkopt;
+ z__1.r = d__1, z__1.i = 0.;
+ work[1].r = z__1.r, work[1].i = z__1.i;
+ return 0;
+ }
+
+/* ==== ZLAHQR/ZLAQR0 crossover point ==== */
+
+ nmin = ilaenv_(&c__12, "ZLAQR4", jbcmpz, n, ilo, ihi, lwork);
+ nmin = max(11,nmin);
+
+/* ==== Nibble crossover point ==== */
+
+ nibble = ilaenv_(&c__14, "ZLAQR4", jbcmpz, n, ilo, ihi, lwork);
+ nibble = max(0,nibble);
+
+/* ==== Accumulate reflections during ttswp? Use block */
+/* . 2-by-2 structure during matrix-matrix multiply? ==== */
+
+ kacc22 = ilaenv_(&c__16, "ZLAQR4", jbcmpz, n, ilo, ihi, lwork);
+ kacc22 = max(0,kacc22);
+ kacc22 = min(2,kacc22);
+
+/* ==== NWMAX = the largest possible deflation window for */
+/* . which there is sufficient workspace. ==== */
+
+/* Computing MIN */
+ i__1 = (*n - 1) / 3, i__2 = *lwork / 2;
+ nwmax = min(i__1,i__2);
+ nw = nwmax;
+
+/* ==== NSMAX = the Largest number of simultaneous shifts */
+/* . for which there is sufficient workspace. ==== */
+
+/* Computing MIN */
+ i__1 = (*n + 6) / 9, i__2 = (*lwork << 1) / 3;
+ nsmax = min(i__1,i__2);
+ nsmax -= nsmax % 2;
+
+/* ==== NDFL: an iteration count restarted at deflation. ==== */
+
+ ndfl = 1;
+
+/* ==== ITMAX = iteration limit ==== */
+
+/* Computing MAX */
+ i__1 = 10, i__2 = *ihi - *ilo + 1;
+ itmax = max(i__1,i__2) * 30;
+
+/* ==== Last row and column in the active block ==== */
+
+ kbot = *ihi;
+
+/* ==== Main Loop ==== */
+
+ i__1 = itmax;
+ for (it = 1; it <= i__1; ++it) {
+
+/* ==== Done when KBOT falls below ILO ==== */
+
+ if (kbot < *ilo) {
+ goto L80;
+ }
+
+/* ==== Locate active block ==== */
+
+ i__2 = *ilo + 1;
+ for (k = kbot; k >= i__2; --k) {
+ i__3 = k + (k - 1) * h_dim1;
+ if (h__[i__3].r == 0. && h__[i__3].i == 0.) {
+ goto L20;
+ }
+/* L10: */
+ }
+ k = *ilo;
+L20:
+ ktop = k;
+
+/* ==== Select deflation window size: */
+/* . Typical Case: */
+/* . If possible and advisable, nibble the entire */
+/* . active block. If not, use size MIN(NWR,NWMAX) */
+/* . or MIN(NWR+1,NWMAX) depending upon which has */
+/* . the smaller corresponding subdiagonal entry */
+/* . (a heuristic). */
+/* . */
+/* . Exceptional Case: */
+/* . If there have been no deflations in KEXNW or */
+/* . more iterations, then vary the deflation window */
+/* . size. At first, because, larger windows are, */
+/* . in general, more powerful than smaller ones, */
+/* . rapidly increase the window to the maximum possible. */
+/* . Then, gradually reduce the window size. ==== */
+
+ nh = kbot - ktop + 1;
+ nwupbd = min(nh,nwmax);
+ if (ndfl < 5) {
+ nw = min(nwupbd,nwr);
+ } else {
+/* Computing MIN */
+ i__2 = nwupbd, i__3 = nw << 1;
+ nw = min(i__2,i__3);
+ }
+ if (nw < nwmax) {
+ if (nw >= nh - 1) {
+ nw = nh;
+ } else {
+ kwtop = kbot - nw + 1;
+ i__2 = kwtop + (kwtop - 1) * h_dim1;
+ i__3 = kwtop - 1 + (kwtop - 2) * h_dim1;
+ if ((d__1 = h__[i__2].r, abs(d__1)) + (d__2 = d_imag(&h__[
+ kwtop + (kwtop - 1) * h_dim1]), abs(d__2)) > (
+ d__3 = h__[i__3].r, abs(d__3)) + (d__4 = d_imag(&
+ h__[kwtop - 1 + (kwtop - 2) * h_dim1]), abs(d__4))
+ ) {
+ ++nw;
+ }
+ }
+ }
+ if (ndfl < 5) {
+ ndec = -1;
+ } else if (ndec >= 0 || nw >= nwupbd) {
+ ++ndec;
+ if (nw - ndec < 2) {
+ ndec = 0;
+ }
+ nw -= ndec;
+ }
+
+/* ==== Aggressive early deflation: */
+/* . split workspace under the subdiagonal into */
+/* . - an nw-by-nw work array V in the lower */
+/* . left-hand-corner, */
+/* . - an NW-by-at-least-NW-but-more-is-better */
+/* . (NW-by-NHO) horizontal work array along */
+/* . the bottom edge, */
+/* . - an at-least-NW-but-more-is-better (NHV-by-NW) */
+/* . vertical work array along the left-hand-edge. */
+/* . ==== */
+
+ kv = *n - nw + 1;
+ kt = nw + 1;
+ nho = *n - nw - 1 - kt + 1;
+ kwv = nw + 2;
+ nve = *n - nw - kwv + 1;
+
+/* ==== Aggressive early deflation ==== */
+
+ zlaqr2_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh,
+ iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &w[1], &h__[kv
+ + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1], ldh, &nve, &
+ h__[kwv + h_dim1], ldh, &work[1], lwork);
+
+/* ==== Adjust KBOT accounting for new deflations. ==== */
+
+ kbot -= ld;
+
+/* ==== KS points to the shifts. ==== */
+
+ ks = kbot - ls + 1;
+
+/* ==== Skip an expensive QR sweep if there is a (partly */
+/* . heuristic) reason to expect that many eigenvalues */
+/* . will deflate without it. Here, the QR sweep is */
+/* . skipped if many eigenvalues have just been deflated */
+/* . or if the remaining active block is small. */
+
+ if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > min(
+ nmin,nwmax)) {
+
+/* ==== NS = nominal number of simultaneous shifts. */
+/* . This may be lowered (slightly) if ZLAQR2 */
+/* . did not provide that many shifts. ==== */
+
+/* Computing MIN */
+/* Computing MAX */
+ i__4 = 2, i__5 = kbot - ktop;
+ i__2 = min(nsmax,nsr), i__3 = max(i__4,i__5);
+ ns = min(i__2,i__3);
+ ns -= ns % 2;
+
+/* ==== If there have been no deflations */
+/* . in a multiple of KEXSH iterations, */
+/* . then try exceptional shifts. */
+/* . Otherwise use shifts provided by */
+/* . ZLAQR2 above or from the eigenvalues */
+/* . of a trailing principal submatrix. ==== */
+
+ if (ndfl % 6 == 0) {
+ ks = kbot - ns + 1;
+ i__2 = ks + 1;
+ for (i__ = kbot; i__ >= i__2; i__ += -2) {
+ i__3 = i__;
+ i__4 = i__ + i__ * h_dim1;
+ i__5 = i__ + (i__ - 1) * h_dim1;
+ d__3 = ((d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
+ d_imag(&h__[i__ + (i__ - 1) * h_dim1]), abs(
+ d__2))) * .75;
+ z__1.r = h__[i__4].r + d__3, z__1.i = h__[i__4].i;
+ w[i__3].r = z__1.r, w[i__3].i = z__1.i;
+ i__3 = i__ - 1;
+ i__4 = i__;
+ w[i__3].r = w[i__4].r, w[i__3].i = w[i__4].i;
+/* L30: */
+ }
+ } else {
+
+/* ==== Got NS/2 or fewer shifts? Use ZLAHQR */
+/* . on a trailing principal submatrix to */
+/* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9, */
+/* . there is enough space below the subdiagonal */
+/* . to fit an NS-by-NS scratch array.) ==== */
+
+ if (kbot - ks + 1 <= ns / 2) {
+ ks = kbot - ns + 1;
+ kt = *n - ns + 1;
+ zlacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, &
+ h__[kt + h_dim1], ldh);
+ zlahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[kt
+ + h_dim1], ldh, &w[ks], &c__1, &c__1, zdum, &
+ c__1, &inf);
+ ks += inf;
+
+/* ==== In case of a rare QR failure use */
+/* . eigenvalues of the trailing 2-by-2 */
+/* . principal submatrix. Scale to avoid */
+/* . overflows, underflows and subnormals. */
+/* . (The scale factor S can not be zero, */
+/* . because H(KBOT,KBOT-1) is nonzero.) ==== */
+
+ if (ks >= kbot) {
+ i__2 = kbot - 1 + (kbot - 1) * h_dim1;
+ i__3 = kbot + (kbot - 1) * h_dim1;
+ i__4 = kbot - 1 + kbot * h_dim1;
+ i__5 = kbot + kbot * h_dim1;
+ s = (d__1 = h__[i__2].r, abs(d__1)) + (d__2 =
+ d_imag(&h__[kbot - 1 + (kbot - 1) *
+ h_dim1]), abs(d__2)) + ((d__3 = h__[i__3]
+ .r, abs(d__3)) + (d__4 = d_imag(&h__[kbot
+ + (kbot - 1) * h_dim1]), abs(d__4))) + ((
+ d__5 = h__[i__4].r, abs(d__5)) + (d__6 =
+ d_imag(&h__[kbot - 1 + kbot * h_dim1]),
+ abs(d__6))) + ((d__7 = h__[i__5].r, abs(
+ d__7)) + (d__8 = d_imag(&h__[kbot + kbot *
+ h_dim1]), abs(d__8)));
+ i__2 = kbot - 1 + (kbot - 1) * h_dim1;
+ z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i /
+ s;
+ aa.r = z__1.r, aa.i = z__1.i;
+ i__2 = kbot + (kbot - 1) * h_dim1;
+ z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i /
+ s;
+ cc.r = z__1.r, cc.i = z__1.i;
+ i__2 = kbot - 1 + kbot * h_dim1;
+ z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i /
+ s;
+ bb.r = z__1.r, bb.i = z__1.i;
+ i__2 = kbot + kbot * h_dim1;
+ z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i /
+ s;
+ dd.r = z__1.r, dd.i = z__1.i;
+ z__2.r = aa.r + dd.r, z__2.i = aa.i + dd.i;
+ z__1.r = z__2.r / 2., z__1.i = z__2.i / 2.;
+ tr2.r = z__1.r, tr2.i = z__1.i;
+ z__3.r = aa.r - tr2.r, z__3.i = aa.i - tr2.i;
+ z__4.r = dd.r - tr2.r, z__4.i = dd.i - tr2.i;
+ z__2.r = z__3.r * z__4.r - z__3.i * z__4.i,
+ z__2.i = z__3.r * z__4.i + z__3.i *
+ z__4.r;
+ z__5.r = bb.r * cc.r - bb.i * cc.i, z__5.i = bb.r
+ * cc.i + bb.i * cc.r;
+ z__1.r = z__2.r - z__5.r, z__1.i = z__2.i -
+ z__5.i;
+ det.r = z__1.r, det.i = z__1.i;
+ z__2.r = -det.r, z__2.i = -det.i;
+ z_sqrt(&z__1, &z__2);
+ rtdisc.r = z__1.r, rtdisc.i = z__1.i;
+ i__2 = kbot - 1;
+ z__2.r = tr2.r + rtdisc.r, z__2.i = tr2.i +
+ rtdisc.i;
+ z__1.r = s * z__2.r, z__1.i = s * z__2.i;
+ w[i__2].r = z__1.r, w[i__2].i = z__1.i;
+ i__2 = kbot;
+ z__2.r = tr2.r - rtdisc.r, z__2.i = tr2.i -
+ rtdisc.i;
+ z__1.r = s * z__2.r, z__1.i = s * z__2.i;
+ w[i__2].r = z__1.r, w[i__2].i = z__1.i;
+
+ ks = kbot - 1;
+ }
+ }
+
+ if (kbot - ks + 1 > ns) {
+
+/* ==== Sort the shifts (Helps a little) ==== */
+
+ sorted = FALSE_;
+ i__2 = ks + 1;
+ for (k = kbot; k >= i__2; --k) {
+ if (sorted) {
+ goto L60;
+ }
+ sorted = TRUE_;
+ i__3 = k - 1;
+ for (i__ = ks; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__ + 1;
+ if ((d__1 = w[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&w[i__]), abs(d__2)) < (d__3 =
+ w[i__5].r, abs(d__3)) + (d__4 =
+ d_imag(&w[i__ + 1]), abs(d__4))) {
+ sorted = FALSE_;
+ i__4 = i__;
+ swap.r = w[i__4].r, swap.i = w[i__4].i;
+ i__4 = i__;
+ i__5 = i__ + 1;
+ w[i__4].r = w[i__5].r, w[i__4].i = w[i__5]
+ .i;
+ i__4 = i__ + 1;
+ w[i__4].r = swap.r, w[i__4].i = swap.i;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+L60:
+ ;
+ }
+ }
+
+/* ==== If there are only two shifts, then use */
+/* . only one. ==== */
+
+ if (kbot - ks + 1 == 2) {
+ i__2 = kbot;
+ i__3 = kbot + kbot * h_dim1;
+ z__2.r = w[i__2].r - h__[i__3].r, z__2.i = w[i__2].i -
+ h__[i__3].i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ i__4 = kbot - 1;
+ i__5 = kbot + kbot * h_dim1;
+ z__4.r = w[i__4].r - h__[i__5].r, z__4.i = w[i__4].i -
+ h__[i__5].i;
+ z__3.r = z__4.r, z__3.i = z__4.i;
+ if ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
+ abs(d__2)) < (d__3 = z__3.r, abs(d__3)) + (d__4 =
+ d_imag(&z__3), abs(d__4))) {
+ i__2 = kbot - 1;
+ i__3 = kbot;
+ w[i__2].r = w[i__3].r, w[i__2].i = w[i__3].i;
+ } else {
+ i__2 = kbot;
+ i__3 = kbot - 1;
+ w[i__2].r = w[i__3].r, w[i__2].i = w[i__3].i;
+ }
+ }
+
+/* ==== Use up to NS of the the smallest magnatiude */
+/* . shifts. If there aren't NS shifts available, */
+/* . then use them all, possibly dropping one to */
+/* . make the number of shifts even. ==== */
+
+/* Computing MIN */
+ i__2 = ns, i__3 = kbot - ks + 1;
+ ns = min(i__2,i__3);
+ ns -= ns % 2;
+ ks = kbot - ns + 1;
+
+/* ==== Small-bulge multi-shift QR sweep: */
+/* . split workspace under the subdiagonal into */
+/* . - a KDU-by-KDU work array U in the lower */
+/* . left-hand-corner, */
+/* . - a KDU-by-at-least-KDU-but-more-is-better */
+/* . (KDU-by-NHo) horizontal work array WH along */
+/* . the bottom edge, */
+/* . - and an at-least-KDU-but-more-is-better-by-KDU */
+/* . (NVE-by-KDU) vertical work WV arrow along */
+/* . the left-hand-edge. ==== */
+
+ kdu = ns * 3 - 3;
+ ku = *n - kdu + 1;
+ kwh = kdu + 1;
+ nho = *n - kdu - 3 - (kdu + 1) + 1;
+ kwv = kdu + 4;
+ nve = *n - kdu - kwv + 1;
+
+/* ==== Small-bulge multi-shift QR sweep ==== */
+
+ zlaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &w[ks], &
+ h__[h_offset], ldh, iloz, ihiz, &z__[z_offset], ldz, &
+ work[1], &c__3, &h__[ku + h_dim1], ldh, &nve, &h__[
+ kwv + h_dim1], ldh, &nho, &h__[ku + kwh * h_dim1],
+ ldh);
+ }
+
+/* ==== Note progress (or the lack of it). ==== */
+
+ if (ld > 0) {
+ ndfl = 1;
+ } else {
+ ++ndfl;
+ }
+
+/* ==== End of main loop ==== */
+/* L70: */
+ }
+
+/* ==== Iteration limit exceeded. Set INFO to show where */
+/* . the problem occurred and exit. ==== */
+
+ *info = kbot;
+L80:
+ ;
+ }
+
+/* ==== Return the optimal value of LWORK. ==== */
+
+ d__1 = (doublereal) lwkopt;
+ z__1.r = d__1, z__1.i = 0.;
+ work[1].r = z__1.r, work[1].i = z__1.i;
+
+/* ==== End of ZLAQR4 ==== */
+
+ return 0;
+} /* zlaqr4_ */
diff --git a/SRC/zlaqr5.c b/SRC/zlaqr5.c
new file mode 100644
index 0000000..ad61b76
--- /dev/null
+++ b/SRC/zlaqr5.c
@@ -0,0 +1,1349 @@
+/* zlaqr5.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int zlaqr5_(logical *wantt, logical *wantz, integer *kacc22,
+ integer *n, integer *ktop, integer *kbot, integer *nshfts,
+ doublecomplex *s, doublecomplex *h__, integer *ldh, integer *iloz,
+ integer *ihiz, doublecomplex *z__, integer *ldz, doublecomplex *v,
+ integer *ldv, doublecomplex *u, integer *ldu, integer *nv,
+ doublecomplex *wv, integer *ldwv, integer *nh, doublecomplex *wh,
+ integer *ldwh)
+{
+ /* System generated locals */
+ integer h_dim1, h_offset, u_dim1, u_offset, v_dim1, v_offset, wh_dim1,
+ wh_offset, wv_dim1, wv_offset, z_dim1, z_offset, i__1, i__2, i__3,
+ i__4, i__5, i__6, i__7, i__8, i__9, i__10, i__11;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10;
+ doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer j, k, m, i2, j2, i4, j4, k1;
+ doublereal h11, h12, h21, h22;
+ integer m22, ns, nu;
+ doublecomplex vt[3];
+ doublereal scl;
+ integer kdu, kms;
+ doublereal ulp;
+ integer knz, kzs;
+ doublereal tst1, tst2;
+ doublecomplex beta;
+ logical blk22, bmp22;
+ integer mend, jcol, jlen, jbot, mbot, jtop, jrow, mtop;
+ doublecomplex alpha;
+ logical accum;
+ integer ndcol, incol, krcol, nbmps;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), ztrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *
+, doublecomplex *, integer *),
+ dlabad_(doublereal *, doublereal *), zlaqr1_(integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin, safmax;
+ extern /* Subroutine */ int zlarfg_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *);
+ doublecomplex refsum;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *);
+ integer mstart;
+ doublereal smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* This auxiliary subroutine called by ZLAQR0 performs a */
+/* single small-bulge multi-shift QR sweep. */
+
+/* WANTT (input) logical scalar */
+/* WANTT = .true. if the triangular Schur factor */
+/* is being computed. WANTT is set to .false. otherwise. */
+
+/* WANTZ (input) logical scalar */
+/* WANTZ = .true. if the unitary Schur factor is being */
+/* computed. WANTZ is set to .false. otherwise. */
+
+/* KACC22 (input) integer with value 0, 1, or 2. */
+/* Specifies the computation mode of far-from-diagonal */
+/* orthogonal updates. */
+/* = 0: ZLAQR5 does not accumulate reflections and does not */
+/* use matrix-matrix multiply to update far-from-diagonal */
+/* matrix entries. */
+/* = 1: ZLAQR5 accumulates reflections and uses matrix-matrix */
+/* multiply to update the far-from-diagonal matrix entries. */
+/* = 2: ZLAQR5 accumulates reflections, uses matrix-matrix */
+/* multiply to update the far-from-diagonal matrix entries, */
+/* and takes advantage of 2-by-2 block structure during */
+/* matrix multiplies. */
+
+/* N (input) integer scalar */
+/* N is the order of the Hessenberg matrix H upon which this */
+/* subroutine operates. */
+
+/* KTOP (input) integer scalar */
+/* KBOT (input) integer scalar */
+/* These are the first and last rows and columns of an */
+/* isolated diagonal block upon which the QR sweep is to be */
+/* applied. It is assumed without a check that */
+/* either KTOP = 1 or H(KTOP,KTOP-1) = 0 */
+/* and */
+/* either KBOT = N or H(KBOT+1,KBOT) = 0. */
+
+/* NSHFTS (input) integer scalar */
+/* NSHFTS gives the number of simultaneous shifts. NSHFTS */
+/* must be positive and even. */
+
+/* S (input/output) COMPLEX*16 array of size (NSHFTS) */
+/* S contains the shifts of origin that define the multi- */
+/* shift QR sweep. On output S may be reordered. */
+
+/* H (input/output) COMPLEX*16 array of size (LDH,N) */
+/* On input H contains a Hessenberg matrix. On output a */
+/* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied */
+/* to the isolated diagonal block in rows and columns KTOP */
+/* through KBOT. */
+
+/* LDH (input) integer scalar */
+/* LDH is the leading dimension of H just as declared in the */
+/* calling procedure. LDH.GE.MAX(1,N). */
+
+/* ILOZ (input) INTEGER */
+/* IHIZ (input) INTEGER */
+/* Specify the rows of Z to which transformations must be */
+/* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N */
+
+/* Z (input/output) COMPLEX*16 array of size (LDZ,IHI) */
+/* If WANTZ = .TRUE., then the QR Sweep unitary */
+/* similarity transformation is accumulated into */
+/* Z(ILOZ:IHIZ,ILO:IHI) from the right. */
+/* If WANTZ = .FALSE., then Z is unreferenced. */
+
+/* LDZ (input) integer scalar */
+/* LDA is the leading dimension of Z just as declared in */
+/* the calling procedure. LDZ.GE.N. */
+
+/* V (workspace) COMPLEX*16 array of size (LDV,NSHFTS/2) */
+
+/* LDV (input) integer scalar */
+/* LDV is the leading dimension of V as declared in the */
+/* calling procedure. LDV.GE.3. */
+
+/* U (workspace) COMPLEX*16 array of size */
+/* (LDU,3*NSHFTS-3) */
+
+/* LDU (input) integer scalar */
+/* LDU is the leading dimension of U just as declared in the */
+/* in the calling subroutine. LDU.GE.3*NSHFTS-3. */
+
+/* NH (input) integer scalar */
+/* NH is the number of columns in array WH available for */
+/* workspace. NH.GE.1. */
+
+/* WH (workspace) COMPLEX*16 array of size (LDWH,NH) */
+
+/* LDWH (input) integer scalar */
+/* Leading dimension of WH just as declared in the */
+/* calling procedure. LDWH.GE.3*NSHFTS-3. */
+
+/* NV (input) integer scalar */
+/* NV is the number of rows in WV agailable for workspace. */
+/* NV.GE.1. */
+
+/* WV (workspace) COMPLEX*16 array of size */
+/* (LDWV,3*NSHFTS-3) */
+
+/* LDWV (input) integer scalar */
+/* LDWV is the leading dimension of WV as declared in the */
+/* in the calling subroutine. LDWV.GE.NV. */
+
+/* ================================================================ */
+/* Based on contributions by */
+/* Karen Braman and Ralph Byers, Department of Mathematics, */
+/* University of Kansas, USA */
+
+/* ================================================================ */
+/* Reference: */
+
+/* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */
+/* Algorithm Part I: Maintaining Well Focused Shifts, and */
+/* Level 3 Performance, SIAM Journal of Matrix Analysis, */
+/* volume 23, pages 929--947, 2002. */
+
+/* ================================================================ */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* ==== If there are no shifts, then there is nothing to do. ==== */
+
+ /* Parameter adjustments */
+ --s;
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ wv_dim1 = *ldwv;
+ wv_offset = 1 + wv_dim1;
+ wv -= wv_offset;
+ wh_dim1 = *ldwh;
+ wh_offset = 1 + wh_dim1;
+ wh -= wh_offset;
+
+ /* Function Body */
+ if (*nshfts < 2) {
+ return 0;
+ }
+
+/* ==== If the active block is empty or 1-by-1, then there */
+/* . is nothing to do. ==== */
+
+ if (*ktop >= *kbot) {
+ return 0;
+ }
+
+/* ==== NSHFTS is supposed to be even, but if it is odd, */
+/* . then simply reduce it by one. ==== */
+
+ ns = *nshfts - *nshfts % 2;
+
+/* ==== Machine constants for deflation ==== */
+
+ safmin = dlamch_("SAFE MINIMUM");
+ safmax = 1. / safmin;
+ dlabad_(&safmin, &safmax);
+ ulp = dlamch_("PRECISION");
+ smlnum = safmin * ((doublereal) (*n) / ulp);
+
+/* ==== Use accumulated reflections to update far-from-diagonal */
+/* . entries ? ==== */
+
+ accum = *kacc22 == 1 || *kacc22 == 2;
+
+/* ==== If so, exploit the 2-by-2 block structure? ==== */
+
+ blk22 = ns > 2 && *kacc22 == 2;
+
+/* ==== clear trash ==== */
+
+ if (*ktop + 2 <= *kbot) {
+ i__1 = *ktop + 2 + *ktop * h_dim1;
+ h__[i__1].r = 0., h__[i__1].i = 0.;
+ }
+
+/* ==== NBMPS = number of 2-shift bulges in the chain ==== */
+
+ nbmps = ns / 2;
+
+/* ==== KDU = width of slab ==== */
+
+ kdu = nbmps * 6 - 3;
+
+/* ==== Create and chase chains of NBMPS bulges ==== */
+
+ i__1 = *kbot - 2;
+ i__2 = nbmps * 3 - 2;
+ for (incol = (1 - nbmps) * 3 + *ktop - 1; i__2 < 0 ? incol >= i__1 :
+ incol <= i__1; incol += i__2) {
+ ndcol = incol + kdu;
+ if (accum) {
+ zlaset_("ALL", &kdu, &kdu, &c_b1, &c_b2, &u[u_offset], ldu);
+ }
+
+/* ==== Near-the-diagonal bulge chase. The following loop */
+/* . performs the near-the-diagonal part of a small bulge */
+/* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal */
+/* . chunk extends from column INCOL to column NDCOL */
+/* . (including both column INCOL and column NDCOL). The */
+/* . following loop chases a 3*NBMPS column long chain of */
+/* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL */
+/* . may be less than KTOP and and NDCOL may be greater than */
+/* . KBOT indicating phantom columns from which to chase */
+/* . bulges before they are actually introduced or to which */
+/* . to chase bulges beyond column KBOT.) ==== */
+
+/* Computing MIN */
+ i__4 = incol + nbmps * 3 - 3, i__5 = *kbot - 2;
+ i__3 = min(i__4,i__5);
+ for (krcol = incol; krcol <= i__3; ++krcol) {
+
+/* ==== Bulges number MTOP to MBOT are active double implicit */
+/* . shift bulges. There may or may not also be small */
+/* . 2-by-2 bulge, if there is room. The inactive bulges */
+/* . (if any) must wait until the active bulges have moved */
+/* . down the diagonal to make room. The phantom matrix */
+/* . paradigm described above helps keep track. ==== */
+
+/* Computing MAX */
+ i__4 = 1, i__5 = (*ktop - 1 - krcol + 2) / 3 + 1;
+ mtop = max(i__4,i__5);
+/* Computing MIN */
+ i__4 = nbmps, i__5 = (*kbot - krcol) / 3;
+ mbot = min(i__4,i__5);
+ m22 = mbot + 1;
+ bmp22 = mbot < nbmps && krcol + (m22 - 1) * 3 == *kbot - 2;
+
+/* ==== Generate reflections to chase the chain right */
+/* . one column. (The minimum value of K is KTOP-1.) ==== */
+
+ i__4 = mbot;
+ for (m = mtop; m <= i__4; ++m) {
+ k = krcol + (m - 1) * 3;
+ if (k == *ktop - 1) {
+ zlaqr1_(&c__3, &h__[*ktop + *ktop * h_dim1], ldh, &s[(m <<
+ 1) - 1], &s[m * 2], &v[m * v_dim1 + 1]);
+ i__5 = m * v_dim1 + 1;
+ alpha.r = v[i__5].r, alpha.i = v[i__5].i;
+ zlarfg_(&c__3, &alpha, &v[m * v_dim1 + 2], &c__1, &v[m *
+ v_dim1 + 1]);
+ } else {
+ i__5 = k + 1 + k * h_dim1;
+ beta.r = h__[i__5].r, beta.i = h__[i__5].i;
+ i__5 = m * v_dim1 + 2;
+ i__6 = k + 2 + k * h_dim1;
+ v[i__5].r = h__[i__6].r, v[i__5].i = h__[i__6].i;
+ i__5 = m * v_dim1 + 3;
+ i__6 = k + 3 + k * h_dim1;
+ v[i__5].r = h__[i__6].r, v[i__5].i = h__[i__6].i;
+ zlarfg_(&c__3, &beta, &v[m * v_dim1 + 2], &c__1, &v[m *
+ v_dim1 + 1]);
+
+/* ==== A Bulge may collapse because of vigilant */
+/* . deflation or destructive underflow. In the */
+/* . underflow case, try the two-small-subdiagonals */
+/* . trick to try to reinflate the bulge. ==== */
+
+ i__5 = k + 3 + k * h_dim1;
+ i__6 = k + 3 + (k + 1) * h_dim1;
+ i__7 = k + 3 + (k + 2) * h_dim1;
+ if (h__[i__5].r != 0. || h__[i__5].i != 0. || (h__[i__6]
+ .r != 0. || h__[i__6].i != 0.) || h__[i__7].r ==
+ 0. && h__[i__7].i == 0.) {
+
+/* ==== Typical case: not collapsed (yet). ==== */
+
+ i__5 = k + 1 + k * h_dim1;
+ h__[i__5].r = beta.r, h__[i__5].i = beta.i;
+ i__5 = k + 2 + k * h_dim1;
+ h__[i__5].r = 0., h__[i__5].i = 0.;
+ i__5 = k + 3 + k * h_dim1;
+ h__[i__5].r = 0., h__[i__5].i = 0.;
+ } else {
+
+/* ==== Atypical case: collapsed. Attempt to */
+/* . reintroduce ignoring H(K+1,K) and H(K+2,K). */
+/* . If the fill resulting from the new */
+/* . reflector is too large, then abandon it. */
+/* . Otherwise, use the new one. ==== */
+
+ zlaqr1_(&c__3, &h__[k + 1 + (k + 1) * h_dim1], ldh, &
+ s[(m << 1) - 1], &s[m * 2], vt);
+ alpha.r = vt[0].r, alpha.i = vt[0].i;
+ zlarfg_(&c__3, &alpha, &vt[1], &c__1, vt);
+ d_cnjg(&z__2, vt);
+ i__5 = k + 1 + k * h_dim1;
+ d_cnjg(&z__5, &vt[1]);
+ i__6 = k + 2 + k * h_dim1;
+ z__4.r = z__5.r * h__[i__6].r - z__5.i * h__[i__6].i,
+ z__4.i = z__5.r * h__[i__6].i + z__5.i * h__[
+ i__6].r;
+ z__3.r = h__[i__5].r + z__4.r, z__3.i = h__[i__5].i +
+ z__4.i;
+ z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i =
+ z__2.r * z__3.i + z__2.i * z__3.r;
+ refsum.r = z__1.r, refsum.i = z__1.i;
+
+ i__5 = k + 2 + k * h_dim1;
+ z__3.r = refsum.r * vt[1].r - refsum.i * vt[1].i,
+ z__3.i = refsum.r * vt[1].i + refsum.i * vt[1]
+ .r;
+ z__2.r = h__[i__5].r - z__3.r, z__2.i = h__[i__5].i -
+ z__3.i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ z__5.r = refsum.r * vt[2].r - refsum.i * vt[2].i,
+ z__5.i = refsum.r * vt[2].i + refsum.i * vt[2]
+ .r;
+ z__4.r = z__5.r, z__4.i = z__5.i;
+ i__6 = k + k * h_dim1;
+ i__7 = k + 1 + (k + 1) * h_dim1;
+ i__8 = k + 2 + (k + 2) * h_dim1;
+ if ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1)
+ , abs(d__2)) + ((d__3 = z__4.r, abs(d__3)) + (
+ d__4 = d_imag(&z__4), abs(d__4))) > ulp * ((
+ d__5 = h__[i__6].r, abs(d__5)) + (d__6 =
+ d_imag(&h__[k + k * h_dim1]), abs(d__6)) + ((
+ d__7 = h__[i__7].r, abs(d__7)) + (d__8 =
+ d_imag(&h__[k + 1 + (k + 1) * h_dim1]), abs(
+ d__8))) + ((d__9 = h__[i__8].r, abs(d__9)) + (
+ d__10 = d_imag(&h__[k + 2 + (k + 2) * h_dim1])
+ , abs(d__10))))) {
+
+/* ==== Starting a new bulge here would */
+/* . create non-negligible fill. Use */
+/* . the old one with trepidation. ==== */
+
+ i__5 = k + 1 + k * h_dim1;
+ h__[i__5].r = beta.r, h__[i__5].i = beta.i;
+ i__5 = k + 2 + k * h_dim1;
+ h__[i__5].r = 0., h__[i__5].i = 0.;
+ i__5 = k + 3 + k * h_dim1;
+ h__[i__5].r = 0., h__[i__5].i = 0.;
+ } else {
+
+/* ==== Stating a new bulge here would */
+/* . create only negligible fill. */
+/* . Replace the old reflector with */
+/* . the new one. ==== */
+
+ i__5 = k + 1 + k * h_dim1;
+ i__6 = k + 1 + k * h_dim1;
+ z__1.r = h__[i__6].r - refsum.r, z__1.i = h__[
+ i__6].i - refsum.i;
+ h__[i__5].r = z__1.r, h__[i__5].i = z__1.i;
+ i__5 = k + 2 + k * h_dim1;
+ h__[i__5].r = 0., h__[i__5].i = 0.;
+ i__5 = k + 3 + k * h_dim1;
+ h__[i__5].r = 0., h__[i__5].i = 0.;
+ i__5 = m * v_dim1 + 1;
+ v[i__5].r = vt[0].r, v[i__5].i = vt[0].i;
+ i__5 = m * v_dim1 + 2;
+ v[i__5].r = vt[1].r, v[i__5].i = vt[1].i;
+ i__5 = m * v_dim1 + 3;
+ v[i__5].r = vt[2].r, v[i__5].i = vt[2].i;
+ }
+ }
+ }
+/* L10: */
+ }
+
+/* ==== Generate a 2-by-2 reflection, if needed. ==== */
+
+ k = krcol + (m22 - 1) * 3;
+ if (bmp22) {
+ if (k == *ktop - 1) {
+ zlaqr1_(&c__2, &h__[k + 1 + (k + 1) * h_dim1], ldh, &s[(
+ m22 << 1) - 1], &s[m22 * 2], &v[m22 * v_dim1 + 1])
+ ;
+ i__4 = m22 * v_dim1 + 1;
+ beta.r = v[i__4].r, beta.i = v[i__4].i;
+ zlarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22
+ * v_dim1 + 1]);
+ } else {
+ i__4 = k + 1 + k * h_dim1;
+ beta.r = h__[i__4].r, beta.i = h__[i__4].i;
+ i__4 = m22 * v_dim1 + 2;
+ i__5 = k + 2 + k * h_dim1;
+ v[i__4].r = h__[i__5].r, v[i__4].i = h__[i__5].i;
+ zlarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22
+ * v_dim1 + 1]);
+ i__4 = k + 1 + k * h_dim1;
+ h__[i__4].r = beta.r, h__[i__4].i = beta.i;
+ i__4 = k + 2 + k * h_dim1;
+ h__[i__4].r = 0., h__[i__4].i = 0.;
+ }
+ }
+
+/* ==== Multiply H by reflections from the left ==== */
+
+ if (accum) {
+ jbot = min(ndcol,*kbot);
+ } else if (*wantt) {
+ jbot = *n;
+ } else {
+ jbot = *kbot;
+ }
+ i__4 = jbot;
+ for (j = max(*ktop,krcol); j <= i__4; ++j) {
+/* Computing MIN */
+ i__5 = mbot, i__6 = (j - krcol + 2) / 3;
+ mend = min(i__5,i__6);
+ i__5 = mend;
+ for (m = mtop; m <= i__5; ++m) {
+ k = krcol + (m - 1) * 3;
+ d_cnjg(&z__2, &v[m * v_dim1 + 1]);
+ i__6 = k + 1 + j * h_dim1;
+ d_cnjg(&z__6, &v[m * v_dim1 + 2]);
+ i__7 = k + 2 + j * h_dim1;
+ z__5.r = z__6.r * h__[i__7].r - z__6.i * h__[i__7].i,
+ z__5.i = z__6.r * h__[i__7].i + z__6.i * h__[i__7]
+ .r;
+ z__4.r = h__[i__6].r + z__5.r, z__4.i = h__[i__6].i +
+ z__5.i;
+ d_cnjg(&z__8, &v[m * v_dim1 + 3]);
+ i__8 = k + 3 + j * h_dim1;
+ z__7.r = z__8.r * h__[i__8].r - z__8.i * h__[i__8].i,
+ z__7.i = z__8.r * h__[i__8].i + z__8.i * h__[i__8]
+ .r;
+ z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
+ z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i =
+ z__2.r * z__3.i + z__2.i * z__3.r;
+ refsum.r = z__1.r, refsum.i = z__1.i;
+ i__6 = k + 1 + j * h_dim1;
+ i__7 = k + 1 + j * h_dim1;
+ z__1.r = h__[i__7].r - refsum.r, z__1.i = h__[i__7].i -
+ refsum.i;
+ h__[i__6].r = z__1.r, h__[i__6].i = z__1.i;
+ i__6 = k + 2 + j * h_dim1;
+ i__7 = k + 2 + j * h_dim1;
+ i__8 = m * v_dim1 + 2;
+ z__2.r = refsum.r * v[i__8].r - refsum.i * v[i__8].i,
+ z__2.i = refsum.r * v[i__8].i + refsum.i * v[i__8]
+ .r;
+ z__1.r = h__[i__7].r - z__2.r, z__1.i = h__[i__7].i -
+ z__2.i;
+ h__[i__6].r = z__1.r, h__[i__6].i = z__1.i;
+ i__6 = k + 3 + j * h_dim1;
+ i__7 = k + 3 + j * h_dim1;
+ i__8 = m * v_dim1 + 3;
+ z__2.r = refsum.r * v[i__8].r - refsum.i * v[i__8].i,
+ z__2.i = refsum.r * v[i__8].i + refsum.i * v[i__8]
+ .r;
+ z__1.r = h__[i__7].r - z__2.r, z__1.i = h__[i__7].i -
+ z__2.i;
+ h__[i__6].r = z__1.r, h__[i__6].i = z__1.i;
+/* L20: */
+ }
+/* L30: */
+ }
+ if (bmp22) {
+ k = krcol + (m22 - 1) * 3;
+/* Computing MAX */
+ i__4 = k + 1;
+ i__5 = jbot;
+ for (j = max(i__4,*ktop); j <= i__5; ++j) {
+ d_cnjg(&z__2, &v[m22 * v_dim1 + 1]);
+ i__4 = k + 1 + j * h_dim1;
+ d_cnjg(&z__5, &v[m22 * v_dim1 + 2]);
+ i__6 = k + 2 + j * h_dim1;
+ z__4.r = z__5.r * h__[i__6].r - z__5.i * h__[i__6].i,
+ z__4.i = z__5.r * h__[i__6].i + z__5.i * h__[i__6]
+ .r;
+ z__3.r = h__[i__4].r + z__4.r, z__3.i = h__[i__4].i +
+ z__4.i;
+ z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i =
+ z__2.r * z__3.i + z__2.i * z__3.r;
+ refsum.r = z__1.r, refsum.i = z__1.i;
+ i__4 = k + 1 + j * h_dim1;
+ i__6 = k + 1 + j * h_dim1;
+ z__1.r = h__[i__6].r - refsum.r, z__1.i = h__[i__6].i -
+ refsum.i;
+ h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
+ i__4 = k + 2 + j * h_dim1;
+ i__6 = k + 2 + j * h_dim1;
+ i__7 = m22 * v_dim1 + 2;
+ z__2.r = refsum.r * v[i__7].r - refsum.i * v[i__7].i,
+ z__2.i = refsum.r * v[i__7].i + refsum.i * v[i__7]
+ .r;
+ z__1.r = h__[i__6].r - z__2.r, z__1.i = h__[i__6].i -
+ z__2.i;
+ h__[i__4].r = z__1.r, h__[i__4].i = z__1.i;
+/* L40: */
+ }
+ }
+
+/* ==== Multiply H by reflections from the right. */
+/* . Delay filling in the last row until the */
+/* . vigilant deflation check is complete. ==== */
+
+ if (accum) {
+ jtop = max(*ktop,incol);
+ } else if (*wantt) {
+ jtop = 1;
+ } else {
+ jtop = *ktop;
+ }
+ i__5 = mbot;
+ for (m = mtop; m <= i__5; ++m) {
+ i__4 = m * v_dim1 + 1;
+ if (v[i__4].r != 0. || v[i__4].i != 0.) {
+ k = krcol + (m - 1) * 3;
+/* Computing MIN */
+ i__6 = *kbot, i__7 = k + 3;
+ i__4 = min(i__6,i__7);
+ for (j = jtop; j <= i__4; ++j) {
+ i__6 = m * v_dim1 + 1;
+ i__7 = j + (k + 1) * h_dim1;
+ i__8 = m * v_dim1 + 2;
+ i__9 = j + (k + 2) * h_dim1;
+ z__4.r = v[i__8].r * h__[i__9].r - v[i__8].i * h__[
+ i__9].i, z__4.i = v[i__8].r * h__[i__9].i + v[
+ i__8].i * h__[i__9].r;
+ z__3.r = h__[i__7].r + z__4.r, z__3.i = h__[i__7].i +
+ z__4.i;
+ i__10 = m * v_dim1 + 3;
+ i__11 = j + (k + 3) * h_dim1;
+ z__5.r = v[i__10].r * h__[i__11].r - v[i__10].i * h__[
+ i__11].i, z__5.i = v[i__10].r * h__[i__11].i
+ + v[i__10].i * h__[i__11].r;
+ z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
+ z__1.r = v[i__6].r * z__2.r - v[i__6].i * z__2.i,
+ z__1.i = v[i__6].r * z__2.i + v[i__6].i *
+ z__2.r;
+ refsum.r = z__1.r, refsum.i = z__1.i;
+ i__6 = j + (k + 1) * h_dim1;
+ i__7 = j + (k + 1) * h_dim1;
+ z__1.r = h__[i__7].r - refsum.r, z__1.i = h__[i__7].i
+ - refsum.i;
+ h__[i__6].r = z__1.r, h__[i__6].i = z__1.i;
+ i__6 = j + (k + 2) * h_dim1;
+ i__7 = j + (k + 2) * h_dim1;
+ d_cnjg(&z__3, &v[m * v_dim1 + 2]);
+ z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
+ z__2.i = refsum.r * z__3.i + refsum.i *
+ z__3.r;
+ z__1.r = h__[i__7].r - z__2.r, z__1.i = h__[i__7].i -
+ z__2.i;
+ h__[i__6].r = z__1.r, h__[i__6].i = z__1.i;
+ i__6 = j + (k + 3) * h_dim1;
+ i__7 = j + (k + 3) * h_dim1;
+ d_cnjg(&z__3, &v[m * v_dim1 + 3]);
+ z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
+ z__2.i = refsum.r * z__3.i + refsum.i *
+ z__3.r;
+ z__1.r = h__[i__7].r - z__2.r, z__1.i = h__[i__7].i -
+ z__2.i;
+ h__[i__6].r = z__1.r, h__[i__6].i = z__1.i;
+/* L50: */
+ }
+
+ if (accum) {
+
+/* ==== Accumulate U. (If necessary, update Z later */
+/* . with with an efficient matrix-matrix */
+/* . multiply.) ==== */
+
+ kms = k - incol;
+/* Computing MAX */
+ i__4 = 1, i__6 = *ktop - incol;
+ i__7 = kdu;
+ for (j = max(i__4,i__6); j <= i__7; ++j) {
+ i__4 = m * v_dim1 + 1;
+ i__6 = j + (kms + 1) * u_dim1;
+ i__8 = m * v_dim1 + 2;
+ i__9 = j + (kms + 2) * u_dim1;
+ z__4.r = v[i__8].r * u[i__9].r - v[i__8].i * u[
+ i__9].i, z__4.i = v[i__8].r * u[i__9].i +
+ v[i__8].i * u[i__9].r;
+ z__3.r = u[i__6].r + z__4.r, z__3.i = u[i__6].i +
+ z__4.i;
+ i__10 = m * v_dim1 + 3;
+ i__11 = j + (kms + 3) * u_dim1;
+ z__5.r = v[i__10].r * u[i__11].r - v[i__10].i * u[
+ i__11].i, z__5.i = v[i__10].r * u[i__11]
+ .i + v[i__10].i * u[i__11].r;
+ z__2.r = z__3.r + z__5.r, z__2.i = z__3.i +
+ z__5.i;
+ z__1.r = v[i__4].r * z__2.r - v[i__4].i * z__2.i,
+ z__1.i = v[i__4].r * z__2.i + v[i__4].i *
+ z__2.r;
+ refsum.r = z__1.r, refsum.i = z__1.i;
+ i__4 = j + (kms + 1) * u_dim1;
+ i__6 = j + (kms + 1) * u_dim1;
+ z__1.r = u[i__6].r - refsum.r, z__1.i = u[i__6].i
+ - refsum.i;
+ u[i__4].r = z__1.r, u[i__4].i = z__1.i;
+ i__4 = j + (kms + 2) * u_dim1;
+ i__6 = j + (kms + 2) * u_dim1;
+ d_cnjg(&z__3, &v[m * v_dim1 + 2]);
+ z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
+ z__2.i = refsum.r * z__3.i + refsum.i *
+ z__3.r;
+ z__1.r = u[i__6].r - z__2.r, z__1.i = u[i__6].i -
+ z__2.i;
+ u[i__4].r = z__1.r, u[i__4].i = z__1.i;
+ i__4 = j + (kms + 3) * u_dim1;
+ i__6 = j + (kms + 3) * u_dim1;
+ d_cnjg(&z__3, &v[m * v_dim1 + 3]);
+ z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
+ z__2.i = refsum.r * z__3.i + refsum.i *
+ z__3.r;
+ z__1.r = u[i__6].r - z__2.r, z__1.i = u[i__6].i -
+ z__2.i;
+ u[i__4].r = z__1.r, u[i__4].i = z__1.i;
+/* L60: */
+ }
+ } else if (*wantz) {
+
+/* ==== U is not accumulated, so update Z */
+/* . now by multiplying by reflections */
+/* . from the right. ==== */
+
+ i__7 = *ihiz;
+ for (j = *iloz; j <= i__7; ++j) {
+ i__4 = m * v_dim1 + 1;
+ i__6 = j + (k + 1) * z_dim1;
+ i__8 = m * v_dim1 + 2;
+ i__9 = j + (k + 2) * z_dim1;
+ z__4.r = v[i__8].r * z__[i__9].r - v[i__8].i *
+ z__[i__9].i, z__4.i = v[i__8].r * z__[
+ i__9].i + v[i__8].i * z__[i__9].r;
+ z__3.r = z__[i__6].r + z__4.r, z__3.i = z__[i__6]
+ .i + z__4.i;
+ i__10 = m * v_dim1 + 3;
+ i__11 = j + (k + 3) * z_dim1;
+ z__5.r = v[i__10].r * z__[i__11].r - v[i__10].i *
+ z__[i__11].i, z__5.i = v[i__10].r * z__[
+ i__11].i + v[i__10].i * z__[i__11].r;
+ z__2.r = z__3.r + z__5.r, z__2.i = z__3.i +
+ z__5.i;
+ z__1.r = v[i__4].r * z__2.r - v[i__4].i * z__2.i,
+ z__1.i = v[i__4].r * z__2.i + v[i__4].i *
+ z__2.r;
+ refsum.r = z__1.r, refsum.i = z__1.i;
+ i__4 = j + (k + 1) * z_dim1;
+ i__6 = j + (k + 1) * z_dim1;
+ z__1.r = z__[i__6].r - refsum.r, z__1.i = z__[
+ i__6].i - refsum.i;
+ z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
+ i__4 = j + (k + 2) * z_dim1;
+ i__6 = j + (k + 2) * z_dim1;
+ d_cnjg(&z__3, &v[m * v_dim1 + 2]);
+ z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
+ z__2.i = refsum.r * z__3.i + refsum.i *
+ z__3.r;
+ z__1.r = z__[i__6].r - z__2.r, z__1.i = z__[i__6]
+ .i - z__2.i;
+ z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
+ i__4 = j + (k + 3) * z_dim1;
+ i__6 = j + (k + 3) * z_dim1;
+ d_cnjg(&z__3, &v[m * v_dim1 + 3]);
+ z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
+ z__2.i = refsum.r * z__3.i + refsum.i *
+ z__3.r;
+ z__1.r = z__[i__6].r - z__2.r, z__1.i = z__[i__6]
+ .i - z__2.i;
+ z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
+/* L70: */
+ }
+ }
+ }
+/* L80: */
+ }
+
+/* ==== Special case: 2-by-2 reflection (if needed) ==== */
+
+ k = krcol + (m22 - 1) * 3;
+ i__5 = m22 * v_dim1 + 1;
+ if (bmp22 && (v[i__5].r != 0. || v[i__5].i != 0.)) {
+/* Computing MIN */
+ i__7 = *kbot, i__4 = k + 3;
+ i__5 = min(i__7,i__4);
+ for (j = jtop; j <= i__5; ++j) {
+ i__7 = m22 * v_dim1 + 1;
+ i__4 = j + (k + 1) * h_dim1;
+ i__6 = m22 * v_dim1 + 2;
+ i__8 = j + (k + 2) * h_dim1;
+ z__3.r = v[i__6].r * h__[i__8].r - v[i__6].i * h__[i__8]
+ .i, z__3.i = v[i__6].r * h__[i__8].i + v[i__6].i *
+ h__[i__8].r;
+ z__2.r = h__[i__4].r + z__3.r, z__2.i = h__[i__4].i +
+ z__3.i;
+ z__1.r = v[i__7].r * z__2.r - v[i__7].i * z__2.i, z__1.i =
+ v[i__7].r * z__2.i + v[i__7].i * z__2.r;
+ refsum.r = z__1.r, refsum.i = z__1.i;
+ i__7 = j + (k + 1) * h_dim1;
+ i__4 = j + (k + 1) * h_dim1;
+ z__1.r = h__[i__4].r - refsum.r, z__1.i = h__[i__4].i -
+ refsum.i;
+ h__[i__7].r = z__1.r, h__[i__7].i = z__1.i;
+ i__7 = j + (k + 2) * h_dim1;
+ i__4 = j + (k + 2) * h_dim1;
+ d_cnjg(&z__3, &v[m22 * v_dim1 + 2]);
+ z__2.r = refsum.r * z__3.r - refsum.i * z__3.i, z__2.i =
+ refsum.r * z__3.i + refsum.i * z__3.r;
+ z__1.r = h__[i__4].r - z__2.r, z__1.i = h__[i__4].i -
+ z__2.i;
+ h__[i__7].r = z__1.r, h__[i__7].i = z__1.i;
+/* L90: */
+ }
+
+ if (accum) {
+ kms = k - incol;
+/* Computing MAX */
+ i__5 = 1, i__7 = *ktop - incol;
+ i__4 = kdu;
+ for (j = max(i__5,i__7); j <= i__4; ++j) {
+ i__5 = m22 * v_dim1 + 1;
+ i__7 = j + (kms + 1) * u_dim1;
+ i__6 = m22 * v_dim1 + 2;
+ i__8 = j + (kms + 2) * u_dim1;
+ z__3.r = v[i__6].r * u[i__8].r - v[i__6].i * u[i__8]
+ .i, z__3.i = v[i__6].r * u[i__8].i + v[i__6]
+ .i * u[i__8].r;
+ z__2.r = u[i__7].r + z__3.r, z__2.i = u[i__7].i +
+ z__3.i;
+ z__1.r = v[i__5].r * z__2.r - v[i__5].i * z__2.i,
+ z__1.i = v[i__5].r * z__2.i + v[i__5].i *
+ z__2.r;
+ refsum.r = z__1.r, refsum.i = z__1.i;
+ i__5 = j + (kms + 1) * u_dim1;
+ i__7 = j + (kms + 1) * u_dim1;
+ z__1.r = u[i__7].r - refsum.r, z__1.i = u[i__7].i -
+ refsum.i;
+ u[i__5].r = z__1.r, u[i__5].i = z__1.i;
+ i__5 = j + (kms + 2) * u_dim1;
+ i__7 = j + (kms + 2) * u_dim1;
+ d_cnjg(&z__3, &v[m22 * v_dim1 + 2]);
+ z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
+ z__2.i = refsum.r * z__3.i + refsum.i *
+ z__3.r;
+ z__1.r = u[i__7].r - z__2.r, z__1.i = u[i__7].i -
+ z__2.i;
+ u[i__5].r = z__1.r, u[i__5].i = z__1.i;
+/* L100: */
+ }
+ } else if (*wantz) {
+ i__4 = *ihiz;
+ for (j = *iloz; j <= i__4; ++j) {
+ i__5 = m22 * v_dim1 + 1;
+ i__7 = j + (k + 1) * z_dim1;
+ i__6 = m22 * v_dim1 + 2;
+ i__8 = j + (k + 2) * z_dim1;
+ z__3.r = v[i__6].r * z__[i__8].r - v[i__6].i * z__[
+ i__8].i, z__3.i = v[i__6].r * z__[i__8].i + v[
+ i__6].i * z__[i__8].r;
+ z__2.r = z__[i__7].r + z__3.r, z__2.i = z__[i__7].i +
+ z__3.i;
+ z__1.r = v[i__5].r * z__2.r - v[i__5].i * z__2.i,
+ z__1.i = v[i__5].r * z__2.i + v[i__5].i *
+ z__2.r;
+ refsum.r = z__1.r, refsum.i = z__1.i;
+ i__5 = j + (k + 1) * z_dim1;
+ i__7 = j + (k + 1) * z_dim1;
+ z__1.r = z__[i__7].r - refsum.r, z__1.i = z__[i__7].i
+ - refsum.i;
+ z__[i__5].r = z__1.r, z__[i__5].i = z__1.i;
+ i__5 = j + (k + 2) * z_dim1;
+ i__7 = j + (k + 2) * z_dim1;
+ d_cnjg(&z__3, &v[m22 * v_dim1 + 2]);
+ z__2.r = refsum.r * z__3.r - refsum.i * z__3.i,
+ z__2.i = refsum.r * z__3.i + refsum.i *
+ z__3.r;
+ z__1.r = z__[i__7].r - z__2.r, z__1.i = z__[i__7].i -
+ z__2.i;
+ z__[i__5].r = z__1.r, z__[i__5].i = z__1.i;
+/* L110: */
+ }
+ }
+ }
+
+/* ==== Vigilant deflation check ==== */
+
+ mstart = mtop;
+ if (krcol + (mstart - 1) * 3 < *ktop) {
+ ++mstart;
+ }
+ mend = mbot;
+ if (bmp22) {
+ ++mend;
+ }
+ if (krcol == *kbot - 2) {
+ ++mend;
+ }
+ i__4 = mend;
+ for (m = mstart; m <= i__4; ++m) {
+/* Computing MIN */
+ i__5 = *kbot - 1, i__7 = krcol + (m - 1) * 3;
+ k = min(i__5,i__7);
+
+/* ==== The following convergence test requires that */
+/* . the tradition small-compared-to-nearby-diagonals */
+/* . criterion and the Ahues & Tisseur (LAWN 122, 1997) */
+/* . criteria both be satisfied. The latter improves */
+/* . accuracy in some examples. Falling back on an */
+/* . alternate convergence criterion when TST1 or TST2 */
+/* . is zero (as done here) is traditional but probably */
+/* . unnecessary. ==== */
+
+ i__5 = k + 1 + k * h_dim1;
+ if (h__[i__5].r != 0. || h__[i__5].i != 0.) {
+ i__5 = k + k * h_dim1;
+ i__7 = k + 1 + (k + 1) * h_dim1;
+ tst1 = (d__1 = h__[i__5].r, abs(d__1)) + (d__2 = d_imag(&
+ h__[k + k * h_dim1]), abs(d__2)) + ((d__3 = h__[
+ i__7].r, abs(d__3)) + (d__4 = d_imag(&h__[k + 1 +
+ (k + 1) * h_dim1]), abs(d__4)));
+ if (tst1 == 0.) {
+ if (k >= *ktop + 1) {
+ i__5 = k + (k - 1) * h_dim1;
+ tst1 += (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
+ d_imag(&h__[k + (k - 1) * h_dim1]), abs(
+ d__2));
+ }
+ if (k >= *ktop + 2) {
+ i__5 = k + (k - 2) * h_dim1;
+ tst1 += (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
+ d_imag(&h__[k + (k - 2) * h_dim1]), abs(
+ d__2));
+ }
+ if (k >= *ktop + 3) {
+ i__5 = k + (k - 3) * h_dim1;
+ tst1 += (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
+ d_imag(&h__[k + (k - 3) * h_dim1]), abs(
+ d__2));
+ }
+ if (k <= *kbot - 2) {
+ i__5 = k + 2 + (k + 1) * h_dim1;
+ tst1 += (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
+ d_imag(&h__[k + 2 + (k + 1) * h_dim1]),
+ abs(d__2));
+ }
+ if (k <= *kbot - 3) {
+ i__5 = k + 3 + (k + 1) * h_dim1;
+ tst1 += (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
+ d_imag(&h__[k + 3 + (k + 1) * h_dim1]),
+ abs(d__2));
+ }
+ if (k <= *kbot - 4) {
+ i__5 = k + 4 + (k + 1) * h_dim1;
+ tst1 += (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
+ d_imag(&h__[k + 4 + (k + 1) * h_dim1]),
+ abs(d__2));
+ }
+ }
+ i__5 = k + 1 + k * h_dim1;
+/* Computing MAX */
+ d__3 = smlnum, d__4 = ulp * tst1;
+ if ((d__1 = h__[i__5].r, abs(d__1)) + (d__2 = d_imag(&h__[
+ k + 1 + k * h_dim1]), abs(d__2)) <= max(d__3,d__4)
+ ) {
+/* Computing MAX */
+ i__5 = k + 1 + k * h_dim1;
+ i__7 = k + (k + 1) * h_dim1;
+ d__5 = (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
+ d_imag(&h__[k + 1 + k * h_dim1]), abs(d__2)),
+ d__6 = (d__3 = h__[i__7].r, abs(d__3)) + (
+ d__4 = d_imag(&h__[k + (k + 1) * h_dim1]),
+ abs(d__4));
+ h12 = max(d__5,d__6);
+/* Computing MIN */
+ i__5 = k + 1 + k * h_dim1;
+ i__7 = k + (k + 1) * h_dim1;
+ d__5 = (d__1 = h__[i__5].r, abs(d__1)) + (d__2 =
+ d_imag(&h__[k + 1 + k * h_dim1]), abs(d__2)),
+ d__6 = (d__3 = h__[i__7].r, abs(d__3)) + (
+ d__4 = d_imag(&h__[k + (k + 1) * h_dim1]),
+ abs(d__4));
+ h21 = min(d__5,d__6);
+ i__5 = k + k * h_dim1;
+ i__7 = k + 1 + (k + 1) * h_dim1;
+ z__2.r = h__[i__5].r - h__[i__7].r, z__2.i = h__[i__5]
+ .i - h__[i__7].i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+/* Computing MAX */
+ i__6 = k + 1 + (k + 1) * h_dim1;
+ d__5 = (d__1 = h__[i__6].r, abs(d__1)) + (d__2 =
+ d_imag(&h__[k + 1 + (k + 1) * h_dim1]), abs(
+ d__2)), d__6 = (d__3 = z__1.r, abs(d__3)) + (
+ d__4 = d_imag(&z__1), abs(d__4));
+ h11 = max(d__5,d__6);
+ i__5 = k + k * h_dim1;
+ i__7 = k + 1 + (k + 1) * h_dim1;
+ z__2.r = h__[i__5].r - h__[i__7].r, z__2.i = h__[i__5]
+ .i - h__[i__7].i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+/* Computing MIN */
+ i__6 = k + 1 + (k + 1) * h_dim1;
+ d__5 = (d__1 = h__[i__6].r, abs(d__1)) + (d__2 =
+ d_imag(&h__[k + 1 + (k + 1) * h_dim1]), abs(
+ d__2)), d__6 = (d__3 = z__1.r, abs(d__3)) + (
+ d__4 = d_imag(&z__1), abs(d__4));
+ h22 = min(d__5,d__6);
+ scl = h11 + h12;
+ tst2 = h22 * (h11 / scl);
+
+/* Computing MAX */
+ d__1 = smlnum, d__2 = ulp * tst2;
+ if (tst2 == 0. || h21 * (h12 / scl) <= max(d__1,d__2))
+ {
+ i__5 = k + 1 + k * h_dim1;
+ h__[i__5].r = 0., h__[i__5].i = 0.;
+ }
+ }
+ }
+/* L120: */
+ }
+
+/* ==== Fill in the last row of each bulge. ==== */
+
+/* Computing MIN */
+ i__4 = nbmps, i__5 = (*kbot - krcol - 1) / 3;
+ mend = min(i__4,i__5);
+ i__4 = mend;
+ for (m = mtop; m <= i__4; ++m) {
+ k = krcol + (m - 1) * 3;
+ i__5 = m * v_dim1 + 1;
+ i__7 = m * v_dim1 + 3;
+ z__2.r = v[i__5].r * v[i__7].r - v[i__5].i * v[i__7].i,
+ z__2.i = v[i__5].r * v[i__7].i + v[i__5].i * v[i__7]
+ .r;
+ i__6 = k + 4 + (k + 3) * h_dim1;
+ z__1.r = z__2.r * h__[i__6].r - z__2.i * h__[i__6].i, z__1.i =
+ z__2.r * h__[i__6].i + z__2.i * h__[i__6].r;
+ refsum.r = z__1.r, refsum.i = z__1.i;
+ i__5 = k + 4 + (k + 1) * h_dim1;
+ z__1.r = -refsum.r, z__1.i = -refsum.i;
+ h__[i__5].r = z__1.r, h__[i__5].i = z__1.i;
+ i__5 = k + 4 + (k + 2) * h_dim1;
+ z__2.r = -refsum.r, z__2.i = -refsum.i;
+ d_cnjg(&z__3, &v[m * v_dim1 + 2]);
+ z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r *
+ z__3.i + z__2.i * z__3.r;
+ h__[i__5].r = z__1.r, h__[i__5].i = z__1.i;
+ i__5 = k + 4 + (k + 3) * h_dim1;
+ i__7 = k + 4 + (k + 3) * h_dim1;
+ d_cnjg(&z__3, &v[m * v_dim1 + 3]);
+ z__2.r = refsum.r * z__3.r - refsum.i * z__3.i, z__2.i =
+ refsum.r * z__3.i + refsum.i * z__3.r;
+ z__1.r = h__[i__7].r - z__2.r, z__1.i = h__[i__7].i - z__2.i;
+ h__[i__5].r = z__1.r, h__[i__5].i = z__1.i;
+/* L130: */
+ }
+
+/* ==== End of near-the-diagonal bulge chase. ==== */
+
+/* L140: */
+ }
+
+/* ==== Use U (if accumulated) to update far-from-diagonal */
+/* . entries in H. If required, use U to update Z as */
+/* . well. ==== */
+
+ if (accum) {
+ if (*wantt) {
+ jtop = 1;
+ jbot = *n;
+ } else {
+ jtop = *ktop;
+ jbot = *kbot;
+ }
+ if (! blk22 || incol < *ktop || ndcol > *kbot || ns <= 2) {
+
+/* ==== Updates not exploiting the 2-by-2 block */
+/* . structure of U. K1 and NU keep track of */
+/* . the location and size of U in the special */
+/* . cases of introducing bulges and chasing */
+/* . bulges off the bottom. In these special */
+/* . cases and in case the number of shifts */
+/* . is NS = 2, there is no 2-by-2 block */
+/* . structure to exploit. ==== */
+
+/* Computing MAX */
+ i__3 = 1, i__4 = *ktop - incol;
+ k1 = max(i__3,i__4);
+/* Computing MAX */
+ i__3 = 0, i__4 = ndcol - *kbot;
+ nu = kdu - max(i__3,i__4) - k1 + 1;
+
+/* ==== Horizontal Multiply ==== */
+
+ i__3 = jbot;
+ i__4 = *nh;
+ for (jcol = min(ndcol,*kbot) + 1; i__4 < 0 ? jcol >= i__3 :
+ jcol <= i__3; jcol += i__4) {
+/* Computing MIN */
+ i__5 = *nh, i__7 = jbot - jcol + 1;
+ jlen = min(i__5,i__7);
+ zgemm_("C", "N", &nu, &jlen, &nu, &c_b2, &u[k1 + k1 *
+ u_dim1], ldu, &h__[incol + k1 + jcol * h_dim1],
+ ldh, &c_b1, &wh[wh_offset], ldwh);
+ zlacpy_("ALL", &nu, &jlen, &wh[wh_offset], ldwh, &h__[
+ incol + k1 + jcol * h_dim1], ldh);
+/* L150: */
+ }
+
+/* ==== Vertical multiply ==== */
+
+ i__4 = max(*ktop,incol) - 1;
+ i__3 = *nv;
+ for (jrow = jtop; i__3 < 0 ? jrow >= i__4 : jrow <= i__4;
+ jrow += i__3) {
+/* Computing MIN */
+ i__5 = *nv, i__7 = max(*ktop,incol) - jrow;
+ jlen = min(i__5,i__7);
+ zgemm_("N", "N", &jlen, &nu, &nu, &c_b2, &h__[jrow + (
+ incol + k1) * h_dim1], ldh, &u[k1 + k1 * u_dim1],
+ ldu, &c_b1, &wv[wv_offset], ldwv);
+ zlacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &h__[
+ jrow + (incol + k1) * h_dim1], ldh);
+/* L160: */
+ }
+
+/* ==== Z multiply (also vertical) ==== */
+
+ if (*wantz) {
+ i__3 = *ihiz;
+ i__4 = *nv;
+ for (jrow = *iloz; i__4 < 0 ? jrow >= i__3 : jrow <= i__3;
+ jrow += i__4) {
+/* Computing MIN */
+ i__5 = *nv, i__7 = *ihiz - jrow + 1;
+ jlen = min(i__5,i__7);
+ zgemm_("N", "N", &jlen, &nu, &nu, &c_b2, &z__[jrow + (
+ incol + k1) * z_dim1], ldz, &u[k1 + k1 *
+ u_dim1], ldu, &c_b1, &wv[wv_offset], ldwv);
+ zlacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &z__[
+ jrow + (incol + k1) * z_dim1], ldz)
+ ;
+/* L170: */
+ }
+ }
+ } else {
+
+/* ==== Updates exploiting U's 2-by-2 block structure. */
+/* . (I2, I4, J2, J4 are the last rows and columns */
+/* . of the blocks.) ==== */
+
+ i2 = (kdu + 1) / 2;
+ i4 = kdu;
+ j2 = i4 - i2;
+ j4 = kdu;
+
+/* ==== KZS and KNZ deal with the band of zeros */
+/* . along the diagonal of one of the triangular */
+/* . blocks. ==== */
+
+ kzs = j4 - j2 - (ns + 1);
+ knz = ns + 1;
+
+/* ==== Horizontal multiply ==== */
+
+ i__4 = jbot;
+ i__3 = *nh;
+ for (jcol = min(ndcol,*kbot) + 1; i__3 < 0 ? jcol >= i__4 :
+ jcol <= i__4; jcol += i__3) {
+/* Computing MIN */
+ i__5 = *nh, i__7 = jbot - jcol + 1;
+ jlen = min(i__5,i__7);
+
+/* ==== Copy bottom of H to top+KZS of scratch ==== */
+/* (The first KZS rows get multiplied by zero.) ==== */
+
+ zlacpy_("ALL", &knz, &jlen, &h__[incol + 1 + j2 + jcol *
+ h_dim1], ldh, &wh[kzs + 1 + wh_dim1], ldwh);
+
+/* ==== Multiply by U21' ==== */
+
+ zlaset_("ALL", &kzs, &jlen, &c_b1, &c_b1, &wh[wh_offset],
+ ldwh);
+ ztrmm_("L", "U", "C", "N", &knz, &jlen, &c_b2, &u[j2 + 1
+ + (kzs + 1) * u_dim1], ldu, &wh[kzs + 1 + wh_dim1]
+, ldwh);
+
+/* ==== Multiply top of H by U11' ==== */
+
+ zgemm_("C", "N", &i2, &jlen, &j2, &c_b2, &u[u_offset],
+ ldu, &h__[incol + 1 + jcol * h_dim1], ldh, &c_b2,
+ &wh[wh_offset], ldwh);
+
+/* ==== Copy top of H to bottom of WH ==== */
+
+ zlacpy_("ALL", &j2, &jlen, &h__[incol + 1 + jcol * h_dim1]
+, ldh, &wh[i2 + 1 + wh_dim1], ldwh);
+
+/* ==== Multiply by U21' ==== */
+
+ ztrmm_("L", "L", "C", "N", &j2, &jlen, &c_b2, &u[(i2 + 1)
+ * u_dim1 + 1], ldu, &wh[i2 + 1 + wh_dim1], ldwh);
+
+/* ==== Multiply by U22 ==== */
+
+ i__5 = i4 - i2;
+ i__7 = j4 - j2;
+ zgemm_("C", "N", &i__5, &jlen, &i__7, &c_b2, &u[j2 + 1 + (
+ i2 + 1) * u_dim1], ldu, &h__[incol + 1 + j2 +
+ jcol * h_dim1], ldh, &c_b2, &wh[i2 + 1 + wh_dim1],
+ ldwh);
+
+/* ==== Copy it back ==== */
+
+ zlacpy_("ALL", &kdu, &jlen, &wh[wh_offset], ldwh, &h__[
+ incol + 1 + jcol * h_dim1], ldh);
+/* L180: */
+ }
+
+/* ==== Vertical multiply ==== */
+
+ i__3 = max(incol,*ktop) - 1;
+ i__4 = *nv;
+ for (jrow = jtop; i__4 < 0 ? jrow >= i__3 : jrow <= i__3;
+ jrow += i__4) {
+/* Computing MIN */
+ i__5 = *nv, i__7 = max(incol,*ktop) - jrow;
+ jlen = min(i__5,i__7);
+
+/* ==== Copy right of H to scratch (the first KZS */
+/* . columns get multiplied by zero) ==== */
+
+ zlacpy_("ALL", &jlen, &knz, &h__[jrow + (incol + 1 + j2) *
+ h_dim1], ldh, &wv[(kzs + 1) * wv_dim1 + 1], ldwv);
+
+/* ==== Multiply by U21 ==== */
+
+ zlaset_("ALL", &jlen, &kzs, &c_b1, &c_b1, &wv[wv_offset],
+ ldwv);
+ ztrmm_("R", "U", "N", "N", &jlen, &knz, &c_b2, &u[j2 + 1
+ + (kzs + 1) * u_dim1], ldu, &wv[(kzs + 1) *
+ wv_dim1 + 1], ldwv);
+
+/* ==== Multiply by U11 ==== */
+
+ zgemm_("N", "N", &jlen, &i2, &j2, &c_b2, &h__[jrow + (
+ incol + 1) * h_dim1], ldh, &u[u_offset], ldu, &
+ c_b2, &wv[wv_offset], ldwv);
+
+/* ==== Copy left of H to right of scratch ==== */
+
+ zlacpy_("ALL", &jlen, &j2, &h__[jrow + (incol + 1) *
+ h_dim1], ldh, &wv[(i2 + 1) * wv_dim1 + 1], ldwv);
+
+/* ==== Multiply by U21 ==== */
+
+ i__5 = i4 - i2;
+ ztrmm_("R", "L", "N", "N", &jlen, &i__5, &c_b2, &u[(i2 +
+ 1) * u_dim1 + 1], ldu, &wv[(i2 + 1) * wv_dim1 + 1]
+, ldwv);
+
+/* ==== Multiply by U22 ==== */
+
+ i__5 = i4 - i2;
+ i__7 = j4 - j2;
+ zgemm_("N", "N", &jlen, &i__5, &i__7, &c_b2, &h__[jrow + (
+ incol + 1 + j2) * h_dim1], ldh, &u[j2 + 1 + (i2 +
+ 1) * u_dim1], ldu, &c_b2, &wv[(i2 + 1) * wv_dim1
+ + 1], ldwv);
+
+/* ==== Copy it back ==== */
+
+ zlacpy_("ALL", &jlen, &kdu, &wv[wv_offset], ldwv, &h__[
+ jrow + (incol + 1) * h_dim1], ldh);
+/* L190: */
+ }
+
+/* ==== Multiply Z (also vertical) ==== */
+
+ if (*wantz) {
+ i__4 = *ihiz;
+ i__3 = *nv;
+ for (jrow = *iloz; i__3 < 0 ? jrow >= i__4 : jrow <= i__4;
+ jrow += i__3) {
+/* Computing MIN */
+ i__5 = *nv, i__7 = *ihiz - jrow + 1;
+ jlen = min(i__5,i__7);
+
+/* ==== Copy right of Z to left of scratch (first */
+/* . KZS columns get multiplied by zero) ==== */
+
+ zlacpy_("ALL", &jlen, &knz, &z__[jrow + (incol + 1 +
+ j2) * z_dim1], ldz, &wv[(kzs + 1) * wv_dim1 +
+ 1], ldwv);
+
+/* ==== Multiply by U12 ==== */
+
+ zlaset_("ALL", &jlen, &kzs, &c_b1, &c_b1, &wv[
+ wv_offset], ldwv);
+ ztrmm_("R", "U", "N", "N", &jlen, &knz, &c_b2, &u[j2
+ + 1 + (kzs + 1) * u_dim1], ldu, &wv[(kzs + 1)
+ * wv_dim1 + 1], ldwv);
+
+/* ==== Multiply by U11 ==== */
+
+ zgemm_("N", "N", &jlen, &i2, &j2, &c_b2, &z__[jrow + (
+ incol + 1) * z_dim1], ldz, &u[u_offset], ldu,
+ &c_b2, &wv[wv_offset], ldwv);
+
+/* ==== Copy left of Z to right of scratch ==== */
+
+ zlacpy_("ALL", &jlen, &j2, &z__[jrow + (incol + 1) *
+ z_dim1], ldz, &wv[(i2 + 1) * wv_dim1 + 1],
+ ldwv);
+
+/* ==== Multiply by U21 ==== */
+
+ i__5 = i4 - i2;
+ ztrmm_("R", "L", "N", "N", &jlen, &i__5, &c_b2, &u[(
+ i2 + 1) * u_dim1 + 1], ldu, &wv[(i2 + 1) *
+ wv_dim1 + 1], ldwv);
+
+/* ==== Multiply by U22 ==== */
+
+ i__5 = i4 - i2;
+ i__7 = j4 - j2;
+ zgemm_("N", "N", &jlen, &i__5, &i__7, &c_b2, &z__[
+ jrow + (incol + 1 + j2) * z_dim1], ldz, &u[j2
+ + 1 + (i2 + 1) * u_dim1], ldu, &c_b2, &wv[(i2
+ + 1) * wv_dim1 + 1], ldwv);
+
+/* ==== Copy the result back to Z ==== */
+
+ zlacpy_("ALL", &jlen, &kdu, &wv[wv_offset], ldwv, &
+ z__[jrow + (incol + 1) * z_dim1], ldz);
+/* L200: */
+ }
+ }
+ }
+ }
+/* L210: */
+ }
+
+/* ==== End of ZLAQR5 ==== */
+
+ return 0;
+} /* zlaqr5_ */
diff --git a/SRC/zlaqsb.c b/SRC/zlaqsb.c
new file mode 100644
index 0000000..0db4349
--- /dev/null
+++ b/SRC/zlaqsb.c
@@ -0,0 +1,193 @@
+/* zlaqsb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlaqsb_(char *uplo, integer *n, integer *kd,
+ doublecomplex *ab, integer *ldab, doublereal *s, doublereal *scond,
+ doublereal *amax, char *equed)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal cj, large;
+ extern logical lsame_(char *, char *);
+ doublereal small;
+ extern doublereal dlamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAQSB equilibrates a symmetric band matrix A using the scaling */
+/* factors in the vector S. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the symmetric band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, if INFO = 0, the triangular factor U or L from the */
+/* Cholesky factorization A = U'*U or A = L*L' of the band */
+/* matrix A, in the same storage format as A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* S (input) DOUBLE PRECISION array, dimension (N) */
+/* The scale factors for A. */
+
+/* SCOND (input) DOUBLE PRECISION */
+/* Ratio of the smallest S(i) to the largest S(i). */
+
+/* AMAX (input) DOUBLE PRECISION */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies whether or not equilibration was done. */
+/* = 'N': No equilibration. */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if scaling should be done */
+/* based on the ratio of the scaling factors. If SCOND < THRESH, */
+/* scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if scaling should */
+/* be done based on the absolute size of the largest matrix element. */
+/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --s;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = dlamch_("Safe minimum") / dlamch_("Precision");
+ large = 1. / small;
+
+ if (*scond >= .1 && *amax >= small && *amax <= large) {
+
+/* No equilibration */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Replace A by diag(S) * A * diag(S). */
+
+ if (lsame_(uplo, "U")) {
+
+/* Upper triangle of A is stored in band format. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *kd;
+ i__4 = j;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ i__2 = *kd + 1 + i__ - j + j * ab_dim1;
+ d__1 = cj * s[i__];
+ i__3 = *kd + 1 + i__ - j + j * ab_dim1;
+ z__1.r = d__1 * ab[i__3].r, z__1.i = d__1 * ab[i__3].i;
+ ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+
+/* Lower triangle of A is stored. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+/* Computing MIN */
+ i__2 = *n, i__3 = j + *kd;
+ i__4 = min(i__2,i__3);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__2 = i__ + 1 - j + j * ab_dim1;
+ d__1 = cj * s[i__];
+ i__3 = i__ + 1 - j + j * ab_dim1;
+ z__1.r = d__1 * ab[i__3].r, z__1.i = d__1 * ab[i__3].i;
+ ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ *(unsigned char *)equed = 'Y';
+ }
+
+ return 0;
+
+/* End of ZLAQSB */
+
+} /* zlaqsb_ */
diff --git a/SRC/zlaqsp.c b/SRC/zlaqsp.c
new file mode 100644
index 0000000..545b88e
--- /dev/null
+++ b/SRC/zlaqsp.c
@@ -0,0 +1,179 @@
+/* zlaqsp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlaqsp_(char *uplo, integer *n, doublecomplex *ap,
+ doublereal *s, doublereal *scond, doublereal *amax, char *equed)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j, jc;
+ doublereal cj, large;
+ extern logical lsame_(char *, char *);
+ doublereal small;
+ extern doublereal dlamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAQSP equilibrates a symmetric matrix A using the scaling factors */
+/* in the vector S. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the equilibrated matrix: diag(S) * A * diag(S), in */
+/* the same storage format as A. */
+
+/* S (input) DOUBLE PRECISION array, dimension (N) */
+/* The scale factors for A. */
+
+/* SCOND (input) DOUBLE PRECISION */
+/* Ratio of the smallest S(i) to the largest S(i). */
+
+/* AMAX (input) DOUBLE PRECISION */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies whether or not equilibration was done. */
+/* = 'N': No equilibration. */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if scaling should be done */
+/* based on the ratio of the scaling factors. If SCOND < THRESH, */
+/* scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if scaling should */
+/* be done based on the absolute size of the largest matrix element. */
+/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --s;
+ --ap;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = dlamch_("Safe minimum") / dlamch_("Precision");
+ large = 1. / small;
+
+ if (*scond >= .1 && *amax >= small && *amax <= large) {
+
+/* No equilibration */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Replace A by diag(S) * A * diag(S). */
+
+ if (lsame_(uplo, "U")) {
+
+/* Upper triangle of A is stored. */
+
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - 1;
+ d__1 = cj * s[i__];
+ i__4 = jc + i__ - 1;
+ z__1.r = d__1 * ap[i__4].r, z__1.i = d__1 * ap[i__4].i;
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+/* L10: */
+ }
+ jc += j;
+/* L20: */
+ }
+ } else {
+
+/* Lower triangle of A is stored. */
+
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - j;
+ d__1 = cj * s[i__];
+ i__4 = jc + i__ - j;
+ z__1.r = d__1 * ap[i__4].r, z__1.i = d__1 * ap[i__4].i;
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+/* L30: */
+ }
+ jc = jc + *n - j + 1;
+/* L40: */
+ }
+ }
+ *(unsigned char *)equed = 'Y';
+ }
+
+ return 0;
+
+/* End of ZLAQSP */
+
+} /* zlaqsp_ */
diff --git a/SRC/zlaqsy.c b/SRC/zlaqsy.c
new file mode 100644
index 0000000..8dc634e
--- /dev/null
+++ b/SRC/zlaqsy.c
@@ -0,0 +1,183 @@
+/* zlaqsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlaqsy_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublereal *s, doublereal *scond, doublereal *amax,
+ char *equed)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal cj, large;
+ extern logical lsame_(char *, char *);
+ doublereal small;
+ extern doublereal dlamch_(char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAQSY equilibrates a symmetric matrix A using the scaling factors */
+/* in the vector S. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n by n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n by n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if EQUED = 'Y', the equilibrated matrix: */
+/* diag(S) * A * diag(S). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(N,1). */
+
+/* S (input) DOUBLE PRECISION array, dimension (N) */
+/* The scale factors for A. */
+
+/* SCOND (input) DOUBLE PRECISION */
+/* Ratio of the smallest S(i) to the largest S(i). */
+
+/* AMAX (input) DOUBLE PRECISION */
+/* Absolute value of largest matrix entry. */
+
+/* EQUED (output) CHARACTER*1 */
+/* Specifies whether or not equilibration was done. */
+/* = 'N': No equilibration. */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+
+/* Internal Parameters */
+/* =================== */
+
+/* THRESH is a threshold value used to decide if scaling should be done */
+/* based on the ratio of the scaling factors. If SCOND < THRESH, */
+/* scaling is done. */
+
+/* LARGE and SMALL are threshold values used to decide if scaling should */
+/* be done based on the absolute size of the largest matrix element. */
+/* If AMAX > LARGE or AMAX < SMALL, scaling is done. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *(unsigned char *)equed = 'N';
+ return 0;
+ }
+
+/* Initialize LARGE and SMALL. */
+
+ small = dlamch_("Safe minimum") / dlamch_("Precision");
+ large = 1. / small;
+
+ if (*scond >= .1 && *amax >= small && *amax <= large) {
+
+/* No equilibration */
+
+ *(unsigned char *)equed = 'N';
+ } else {
+
+/* Replace A by diag(S) * A * diag(S). */
+
+ if (lsame_(uplo, "U")) {
+
+/* Upper triangle of A is stored. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ d__1 = cj * s[i__];
+ i__4 = i__ + j * a_dim1;
+ z__1.r = d__1 * a[i__4].r, z__1.i = d__1 * a[i__4].i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+
+/* Lower triangle of A is stored. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ cj = s[j];
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ d__1 = cj * s[i__];
+ i__4 = i__ + j * a_dim1;
+ z__1.r = d__1 * a[i__4].r, z__1.i = d__1 * a[i__4].i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ *(unsigned char *)equed = 'Y';
+ }
+
+ return 0;
+
+/* End of ZLAQSY */
+
+} /* zlaqsy_ */
diff --git a/SRC/zlar1v.c b/SRC/zlar1v.c
new file mode 100644
index 0000000..15231c9
--- /dev/null
+++ b/SRC/zlar1v.c
@@ -0,0 +1,501 @@
+/* zlar1v.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlar1v_(integer *n, integer *b1, integer *bn, doublereal
+ *lambda, doublereal *d__, doublereal *l, doublereal *ld, doublereal *
+ lld, doublereal *pivmin, doublereal *gaptol, doublecomplex *z__,
+ logical *wantnc, integer *negcnt, doublereal *ztz, doublereal *mingma,
+ integer *r__, integer *isuppz, doublereal *nrminv, doublereal *resid,
+ doublereal *rqcorr, doublereal *work)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublereal d__1;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal s;
+ integer r1, r2;
+ doublereal eps, tmp;
+ integer neg1, neg2, indp, inds;
+ doublereal dplus;
+ extern doublereal dlamch_(char *);
+ extern logical disnan_(doublereal *);
+ integer indlpl, indumn;
+ doublereal dminus;
+ logical sawnan1, sawnan2;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAR1V computes the (scaled) r-th column of the inverse of */
+/* the sumbmatrix in rows B1 through BN of the tridiagonal matrix */
+/* L D L^T - sigma I. When sigma is close to an eigenvalue, the */
+/* computed vector is an accurate eigenvector. Usually, r corresponds */
+/* to the index where the eigenvector is largest in magnitude. */
+/* The following steps accomplish this computation : */
+/* (a) Stationary qd transform, L D L^T - sigma I = L(+) D(+) L(+)^T, */
+/* (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T, */
+/* (c) Computation of the diagonal elements of the inverse of */
+/* L D L^T - sigma I by combining the above transforms, and choosing */
+/* r as the index where the diagonal of the inverse is (one of the) */
+/* largest in magnitude. */
+/* (d) Computation of the (scaled) r-th column of the inverse using the */
+/* twisted factorization obtained by combining the top part of the */
+/* the stationary and the bottom part of the progressive transform. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix L D L^T. */
+
+/* B1 (input) INTEGER */
+/* First index of the submatrix of L D L^T. */
+
+/* BN (input) INTEGER */
+/* Last index of the submatrix of L D L^T. */
+
+/* LAMBDA (input) DOUBLE PRECISION */
+/* The shift. In order to compute an accurate eigenvector, */
+/* LAMBDA should be a good approximation to an eigenvalue */
+/* of L D L^T. */
+
+/* L (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the unit bidiagonal matrix */
+/* L, in elements 1 to N-1. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the diagonal matrix D. */
+
+/* LD (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The n-1 elements L(i)*D(i). */
+
+/* LLD (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The n-1 elements L(i)*L(i)*D(i). */
+
+/* PIVMIN (input) DOUBLE PRECISION */
+/* The minimum pivot in the Sturm sequence. */
+
+/* GAPTOL (input) DOUBLE PRECISION */
+/* Tolerance that indicates when eigenvector entries are negligible */
+/* w.r.t. their contribution to the residual. */
+
+/* Z (input/output) COMPLEX*16 array, dimension (N) */
+/* On input, all entries of Z must be set to 0. */
+/* On output, Z contains the (scaled) r-th column of the */
+/* inverse. The scaling is such that Z(R) equals 1. */
+
+/* WANTNC (input) LOGICAL */
+/* Specifies whether NEGCNT has to be computed. */
+
+/* NEGCNT (output) INTEGER */
+/* If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin */
+/* in the matrix factorization L D L^T, and NEGCNT = -1 otherwise. */
+
+/* ZTZ (output) DOUBLE PRECISION */
+/* The square of the 2-norm of Z. */
+
+/* MINGMA (output) DOUBLE PRECISION */
+/* The reciprocal of the largest (in magnitude) diagonal */
+/* element of the inverse of L D L^T - sigma I. */
+
+/* R (input/output) INTEGER */
+/* The twist index for the twisted factorization used to */
+/* compute Z. */
+/* On input, 0 <= R <= N. If R is input as 0, R is set to */
+/* the index where (L D L^T - sigma I)^{-1} is largest */
+/* in magnitude. If 1 <= R <= N, R is unchanged. */
+/* On output, R contains the twist index used to compute Z. */
+/* Ideally, R designates the position of the maximum entry in the */
+/* eigenvector. */
+
+/* ISUPPZ (output) INTEGER array, dimension (2) */
+/* The support of the vector in Z, i.e., the vector Z is */
+/* nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ). */
+
+/* NRMINV (output) DOUBLE PRECISION */
+/* NRMINV = 1/SQRT( ZTZ ) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The residual of the FP vector. */
+/* RESID = ABS( MINGMA )/SQRT( ZTZ ) */
+
+/* RQCORR (output) DOUBLE PRECISION */
+/* The Rayleigh Quotient correction to LAMBDA. */
+/* RQCORR = MINGMA*TMP */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --isuppz;
+ --z__;
+ --lld;
+ --ld;
+ --l;
+ --d__;
+
+ /* Function Body */
+ eps = dlamch_("Precision");
+ if (*r__ == 0) {
+ r1 = *b1;
+ r2 = *bn;
+ } else {
+ r1 = *r__;
+ r2 = *r__;
+ }
+/* Storage for LPLUS */
+ indlpl = 0;
+/* Storage for UMINUS */
+ indumn = *n;
+ inds = (*n << 1) + 1;
+ indp = *n * 3 + 1;
+ if (*b1 == 1) {
+ work[inds] = 0.;
+ } else {
+ work[inds + *b1 - 1] = lld[*b1 - 1];
+ }
+
+/* Compute the stationary transform (using the differential form) */
+/* until the index R2. */
+
+ sawnan1 = FALSE_;
+ neg1 = 0;
+ s = work[inds + *b1 - 1] - *lambda;
+ i__1 = r1 - 1;
+ for (i__ = *b1; i__ <= i__1; ++i__) {
+ dplus = d__[i__] + s;
+ work[indlpl + i__] = ld[i__] / dplus;
+ if (dplus < 0.) {
+ ++neg1;
+ }
+ work[inds + i__] = s * work[indlpl + i__] * l[i__];
+ s = work[inds + i__] - *lambda;
+/* L50: */
+ }
+ sawnan1 = disnan_(&s);
+ if (sawnan1) {
+ goto L60;
+ }
+ i__1 = r2 - 1;
+ for (i__ = r1; i__ <= i__1; ++i__) {
+ dplus = d__[i__] + s;
+ work[indlpl + i__] = ld[i__] / dplus;
+ work[inds + i__] = s * work[indlpl + i__] * l[i__];
+ s = work[inds + i__] - *lambda;
+/* L51: */
+ }
+ sawnan1 = disnan_(&s);
+
+L60:
+ if (sawnan1) {
+/* Runs a slower version of the above loop if a NaN is detected */
+ neg1 = 0;
+ s = work[inds + *b1 - 1] - *lambda;
+ i__1 = r1 - 1;
+ for (i__ = *b1; i__ <= i__1; ++i__) {
+ dplus = d__[i__] + s;
+ if (abs(dplus) < *pivmin) {
+ dplus = -(*pivmin);
+ }
+ work[indlpl + i__] = ld[i__] / dplus;
+ if (dplus < 0.) {
+ ++neg1;
+ }
+ work[inds + i__] = s * work[indlpl + i__] * l[i__];
+ if (work[indlpl + i__] == 0.) {
+ work[inds + i__] = lld[i__];
+ }
+ s = work[inds + i__] - *lambda;
+/* L70: */
+ }
+ i__1 = r2 - 1;
+ for (i__ = r1; i__ <= i__1; ++i__) {
+ dplus = d__[i__] + s;
+ if (abs(dplus) < *pivmin) {
+ dplus = -(*pivmin);
+ }
+ work[indlpl + i__] = ld[i__] / dplus;
+ work[inds + i__] = s * work[indlpl + i__] * l[i__];
+ if (work[indlpl + i__] == 0.) {
+ work[inds + i__] = lld[i__];
+ }
+ s = work[inds + i__] - *lambda;
+/* L71: */
+ }
+ }
+
+/* Compute the progressive transform (using the differential form) */
+/* until the index R1 */
+
+ sawnan2 = FALSE_;
+ neg2 = 0;
+ work[indp + *bn - 1] = d__[*bn] - *lambda;
+ i__1 = r1;
+ for (i__ = *bn - 1; i__ >= i__1; --i__) {
+ dminus = lld[i__] + work[indp + i__];
+ tmp = d__[i__] / dminus;
+ if (dminus < 0.) {
+ ++neg2;
+ }
+ work[indumn + i__] = l[i__] * tmp;
+ work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda;
+/* L80: */
+ }
+ tmp = work[indp + r1 - 1];
+ sawnan2 = disnan_(&tmp);
+ if (sawnan2) {
+/* Runs a slower version of the above loop if a NaN is detected */
+ neg2 = 0;
+ i__1 = r1;
+ for (i__ = *bn - 1; i__ >= i__1; --i__) {
+ dminus = lld[i__] + work[indp + i__];
+ if (abs(dminus) < *pivmin) {
+ dminus = -(*pivmin);
+ }
+ tmp = d__[i__] / dminus;
+ if (dminus < 0.) {
+ ++neg2;
+ }
+ work[indumn + i__] = l[i__] * tmp;
+ work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda;
+ if (tmp == 0.) {
+ work[indp + i__ - 1] = d__[i__] - *lambda;
+ }
+/* L100: */
+ }
+ }
+
+/* Find the index (from R1 to R2) of the largest (in magnitude) */
+/* diagonal element of the inverse */
+
+ *mingma = work[inds + r1 - 1] + work[indp + r1 - 1];
+ if (*mingma < 0.) {
+ ++neg1;
+ }
+ if (*wantnc) {
+ *negcnt = neg1 + neg2;
+ } else {
+ *negcnt = -1;
+ }
+ if (abs(*mingma) == 0.) {
+ *mingma = eps * work[inds + r1 - 1];
+ }
+ *r__ = r1;
+ i__1 = r2 - 1;
+ for (i__ = r1; i__ <= i__1; ++i__) {
+ tmp = work[inds + i__] + work[indp + i__];
+ if (tmp == 0.) {
+ tmp = eps * work[inds + i__];
+ }
+ if (abs(tmp) <= abs(*mingma)) {
+ *mingma = tmp;
+ *r__ = i__ + 1;
+ }
+/* L110: */
+ }
+
+/* Compute the FP vector: solve N^T v = e_r */
+
+ isuppz[1] = *b1;
+ isuppz[2] = *bn;
+ i__1 = *r__;
+ z__[i__1].r = 1., z__[i__1].i = 0.;
+ *ztz = 1.;
+
+/* Compute the FP vector upwards from R */
+
+ if (! sawnan1 && ! sawnan2) {
+ i__1 = *b1;
+ for (i__ = *r__ - 1; i__ >= i__1; --i__) {
+ i__2 = i__;
+ i__3 = indlpl + i__;
+ i__4 = i__ + 1;
+ z__2.r = work[i__3] * z__[i__4].r, z__2.i = work[i__3] * z__[i__4]
+ .i;
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ z__[i__2].r = z__1.r, z__[i__2].i = z__1.i;
+ if ((z_abs(&z__[i__]) + z_abs(&z__[i__ + 1])) * (d__1 = ld[i__],
+ abs(d__1)) < *gaptol) {
+ i__2 = i__;
+ z__[i__2].r = 0., z__[i__2].i = 0.;
+ isuppz[1] = i__ + 1;
+ goto L220;
+ }
+ i__2 = i__;
+ i__3 = i__;
+ z__1.r = z__[i__2].r * z__[i__3].r - z__[i__2].i * z__[i__3].i,
+ z__1.i = z__[i__2].r * z__[i__3].i + z__[i__2].i * z__[
+ i__3].r;
+ *ztz += z__1.r;
+/* L210: */
+ }
+L220:
+ ;
+ } else {
+/* Run slower loop if NaN occurred. */
+ i__1 = *b1;
+ for (i__ = *r__ - 1; i__ >= i__1; --i__) {
+ i__2 = i__ + 1;
+ if (z__[i__2].r == 0. && z__[i__2].i == 0.) {
+ i__2 = i__;
+ d__1 = -(ld[i__ + 1] / ld[i__]);
+ i__3 = i__ + 2;
+ z__1.r = d__1 * z__[i__3].r, z__1.i = d__1 * z__[i__3].i;
+ z__[i__2].r = z__1.r, z__[i__2].i = z__1.i;
+ } else {
+ i__2 = i__;
+ i__3 = indlpl + i__;
+ i__4 = i__ + 1;
+ z__2.r = work[i__3] * z__[i__4].r, z__2.i = work[i__3] * z__[
+ i__4].i;
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ z__[i__2].r = z__1.r, z__[i__2].i = z__1.i;
+ }
+ if ((z_abs(&z__[i__]) + z_abs(&z__[i__ + 1])) * (d__1 = ld[i__],
+ abs(d__1)) < *gaptol) {
+ i__2 = i__;
+ z__[i__2].r = 0., z__[i__2].i = 0.;
+ isuppz[1] = i__ + 1;
+ goto L240;
+ }
+ i__2 = i__;
+ i__3 = i__;
+ z__1.r = z__[i__2].r * z__[i__3].r - z__[i__2].i * z__[i__3].i,
+ z__1.i = z__[i__2].r * z__[i__3].i + z__[i__2].i * z__[
+ i__3].r;
+ *ztz += z__1.r;
+/* L230: */
+ }
+L240:
+ ;
+ }
+/* Compute the FP vector downwards from R in blocks of size BLKSIZ */
+ if (! sawnan1 && ! sawnan2) {
+ i__1 = *bn - 1;
+ for (i__ = *r__; i__ <= i__1; ++i__) {
+ i__2 = i__ + 1;
+ i__3 = indumn + i__;
+ i__4 = i__;
+ z__2.r = work[i__3] * z__[i__4].r, z__2.i = work[i__3] * z__[i__4]
+ .i;
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ z__[i__2].r = z__1.r, z__[i__2].i = z__1.i;
+ if ((z_abs(&z__[i__]) + z_abs(&z__[i__ + 1])) * (d__1 = ld[i__],
+ abs(d__1)) < *gaptol) {
+ i__2 = i__ + 1;
+ z__[i__2].r = 0., z__[i__2].i = 0.;
+ isuppz[2] = i__;
+ goto L260;
+ }
+ i__2 = i__ + 1;
+ i__3 = i__ + 1;
+ z__1.r = z__[i__2].r * z__[i__3].r - z__[i__2].i * z__[i__3].i,
+ z__1.i = z__[i__2].r * z__[i__3].i + z__[i__2].i * z__[
+ i__3].r;
+ *ztz += z__1.r;
+/* L250: */
+ }
+L260:
+ ;
+ } else {
+/* Run slower loop if NaN occurred. */
+ i__1 = *bn - 1;
+ for (i__ = *r__; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ if (z__[i__2].r == 0. && z__[i__2].i == 0.) {
+ i__2 = i__ + 1;
+ d__1 = -(ld[i__ - 1] / ld[i__]);
+ i__3 = i__ - 1;
+ z__1.r = d__1 * z__[i__3].r, z__1.i = d__1 * z__[i__3].i;
+ z__[i__2].r = z__1.r, z__[i__2].i = z__1.i;
+ } else {
+ i__2 = i__ + 1;
+ i__3 = indumn + i__;
+ i__4 = i__;
+ z__2.r = work[i__3] * z__[i__4].r, z__2.i = work[i__3] * z__[
+ i__4].i;
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ z__[i__2].r = z__1.r, z__[i__2].i = z__1.i;
+ }
+ if ((z_abs(&z__[i__]) + z_abs(&z__[i__ + 1])) * (d__1 = ld[i__],
+ abs(d__1)) < *gaptol) {
+ i__2 = i__ + 1;
+ z__[i__2].r = 0., z__[i__2].i = 0.;
+ isuppz[2] = i__;
+ goto L280;
+ }
+ i__2 = i__ + 1;
+ i__3 = i__ + 1;
+ z__1.r = z__[i__2].r * z__[i__3].r - z__[i__2].i * z__[i__3].i,
+ z__1.i = z__[i__2].r * z__[i__3].i + z__[i__2].i * z__[
+ i__3].r;
+ *ztz += z__1.r;
+/* L270: */
+ }
+L280:
+ ;
+ }
+
+/* Compute quantities for convergence test */
+
+ tmp = 1. / *ztz;
+ *nrminv = sqrt(tmp);
+ *resid = abs(*mingma) * *nrminv;
+ *rqcorr = *mingma * tmp;
+
+
+ return 0;
+
+/* End of ZLAR1V */
+
+} /* zlar1v_ */
diff --git a/SRC/zlar2v.c b/SRC/zlar2v.c
new file mode 100644
index 0000000..ce51144
--- /dev/null
+++ b/SRC/zlar2v.c
@@ -0,0 +1,160 @@
+/* zlar2v.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlar2v_(integer *n, doublecomplex *x, doublecomplex *y,
+ doublecomplex *z__, integer *incx, doublereal *c__, doublecomplex *s,
+ integer *incc)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1;
+ doublecomplex z__1, z__2, z__3, z__4, z__5;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__;
+ doublecomplex t2, t3, t4;
+ doublereal t5, t6;
+ integer ic;
+ doublereal ci;
+ doublecomplex si;
+ integer ix;
+ doublereal xi, yi;
+ doublecomplex zi;
+ doublereal t1i, t1r, sii, zii, sir, zir;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAR2V applies a vector of complex plane rotations with real cosines */
+/* from both sides to a sequence of 2-by-2 complex Hermitian matrices, */
+/* defined by the elements of the vectors x, y and z. For i = 1,2,...,n */
+
+/* ( x(i) z(i) ) := */
+/* ( conjg(z(i)) y(i) ) */
+
+/* ( c(i) conjg(s(i)) ) ( x(i) z(i) ) ( c(i) -conjg(s(i)) ) */
+/* ( -s(i) c(i) ) ( conjg(z(i)) y(i) ) ( s(i) c(i) ) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of plane rotations to be applied. */
+
+/* X (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX) */
+/* The vector x; the elements of x are assumed to be real. */
+
+/* Y (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX) */
+/* The vector y; the elements of y are assumed to be real. */
+
+/* Z (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX) */
+/* The vector z. */
+
+/* INCX (input) INTEGER */
+/* The increment between elements of X, Y and Z. INCX > 0. */
+
+/* C (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC) */
+/* The cosines of the plane rotations. */
+
+/* S (input) COMPLEX*16 array, dimension (1+(N-1)*INCC) */
+/* The sines of the plane rotations. */
+
+/* INCC (input) INTEGER */
+/* The increment between elements of C and S. INCC > 0. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --s;
+ --c__;
+ --z__;
+ --y;
+ --x;
+
+ /* Function Body */
+ ix = 1;
+ ic = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ix;
+ xi = x[i__2].r;
+ i__2 = ix;
+ yi = y[i__2].r;
+ i__2 = ix;
+ zi.r = z__[i__2].r, zi.i = z__[i__2].i;
+ zir = zi.r;
+ zii = d_imag(&zi);
+ ci = c__[ic];
+ i__2 = ic;
+ si.r = s[i__2].r, si.i = s[i__2].i;
+ sir = si.r;
+ sii = d_imag(&si);
+ t1r = sir * zir - sii * zii;
+ t1i = sir * zii + sii * zir;
+ z__1.r = ci * zi.r, z__1.i = ci * zi.i;
+ t2.r = z__1.r, t2.i = z__1.i;
+ d_cnjg(&z__3, &si);
+ z__2.r = xi * z__3.r, z__2.i = xi * z__3.i;
+ z__1.r = t2.r - z__2.r, z__1.i = t2.i - z__2.i;
+ t3.r = z__1.r, t3.i = z__1.i;
+ d_cnjg(&z__2, &t2);
+ z__3.r = yi * si.r, z__3.i = yi * si.i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ t4.r = z__1.r, t4.i = z__1.i;
+ t5 = ci * xi + t1r;
+ t6 = ci * yi - t1r;
+ i__2 = ix;
+ d__1 = ci * t5 + (sir * t4.r + sii * d_imag(&t4));
+ x[i__2].r = d__1, x[i__2].i = 0.;
+ i__2 = ix;
+ d__1 = ci * t6 - (sir * t3.r - sii * d_imag(&t3));
+ y[i__2].r = d__1, y[i__2].i = 0.;
+ i__2 = ix;
+ z__2.r = ci * t3.r, z__2.i = ci * t3.i;
+ d_cnjg(&z__4, &si);
+ z__5.r = t6, z__5.i = t1i;
+ z__3.r = z__4.r * z__5.r - z__4.i * z__5.i, z__3.i = z__4.r * z__5.i
+ + z__4.i * z__5.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ z__[i__2].r = z__1.r, z__[i__2].i = z__1.i;
+ ix += *incx;
+ ic += *incc;
+/* L10: */
+ }
+ return 0;
+
+/* End of ZLAR2V */
+
+} /* zlar2v_ */
diff --git a/SRC/zlarcm.c b/SRC/zlarcm.c
new file mode 100644
index 0000000..2dd2f0e
--- /dev/null
+++ b/SRC/zlarcm.c
@@ -0,0 +1,177 @@
+/* zlarcm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b6 = 1.;
+static doublereal c_b7 = 0.;
+
+/* Subroutine */ int zlarcm_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublecomplex *b, integer *ldb, doublecomplex *c__, integer *ldc,
+ doublereal *rwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4, i__5;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, l;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLARCM performs a very simple matrix-matrix multiplication: */
+/* C := A * B, */
+/* where A is M by M and real; B is M by N and complex; */
+/* C is M by N and complex. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A and of the matrix C. */
+/* M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns and rows of the matrix B and */
+/* the number of columns of the matrix C. */
+/* N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA, M) */
+/* A contains the M by M matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >=max(1,M). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB, N) */
+/* B contains the M by N matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >=max(1,M). */
+
+/* C (input) COMPLEX*16 array, dimension (LDC, N) */
+/* C contains the M by N matrix C. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >=max(1,M). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*M*N) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[(j - 1) * *m + i__] = b[i__3].r;
+/* L10: */
+ }
+/* L20: */
+ }
+
+ l = *m * *n + 1;
+ dgemm_("N", "N", m, n, m, &c_b6, &a[a_offset], lda, &rwork[1], m, &c_b7, &
+ rwork[l], m);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = l + (j - 1) * *m + i__ - 1;
+ c__[i__3].r = rwork[i__4], c__[i__3].i = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ rwork[(j - 1) * *m + i__] = d_imag(&b[i__ + j * b_dim1]);
+/* L50: */
+ }
+/* L60: */
+ }
+ dgemm_("N", "N", m, n, m, &c_b6, &a[a_offset], lda, &rwork[1], m, &c_b7, &
+ rwork[l], m);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ d__1 = c__[i__4].r;
+ i__5 = l + (j - 1) * *m + i__ - 1;
+ z__1.r = d__1, z__1.i = rwork[i__5];
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+
+ return 0;
+
+/* End of ZLARCM */
+
+} /* zlarcm_ */
diff --git a/SRC/zlarf.c b/SRC/zlarf.c
new file mode 100644
index 0000000..0b8ad02
--- /dev/null
+++ b/SRC/zlarf.c
@@ -0,0 +1,200 @@
+/* zlarf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static doublecomplex c_b2 = {0.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zlarf_(char *side, integer *m, integer *n, doublecomplex
+ *v, integer *incv, doublecomplex *tau, doublecomplex *c__, integer *
+ ldc, doublecomplex *work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__;
+ logical applyleft;
+ extern logical lsame_(char *, char *);
+ integer lastc;
+ extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ integer lastv;
+ extern integer ilazlc_(integer *, integer *, doublecomplex *, integer *),
+ ilazlr_(integer *, integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLARF applies a complex elementary reflector H to a complex M-by-N */
+/* matrix C, from either the left or the right. H is represented in the */
+/* form */
+
+/* H = I - tau * v * v' */
+
+/* where tau is a complex scalar and v is a complex vector. */
+
+/* If tau = 0, then H is taken to be the unit matrix. */
+
+/* To apply H' (the conjugate transpose of H), supply conjg(tau) instead */
+/* tau. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': form H * C */
+/* = 'R': form C * H */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* V (input) COMPLEX*16 array, dimension */
+/* (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
+/* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
+/* The vector v in the representation of H. V is not used if */
+/* TAU = 0. */
+
+/* INCV (input) INTEGER */
+/* The increment between elements of v. INCV <> 0. */
+
+/* TAU (input) COMPLEX*16 */
+/* The value tau in the representation of H. */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
+/* or C * H if SIDE = 'R'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (N) if SIDE = 'L' */
+/* or (M) if SIDE = 'R' */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ applyleft = lsame_(side, "L");
+ lastv = 0;
+ lastc = 0;
+ if (tau->r != 0. || tau->i != 0.) {
+/* Set up variables for scanning V. LASTV begins pointing to the end */
+/* of V. */
+ if (applyleft) {
+ lastv = *m;
+ } else {
+ lastv = *n;
+ }
+ if (*incv > 0) {
+ i__ = (lastv - 1) * *incv + 1;
+ } else {
+ i__ = 1;
+ }
+/* Look for the last non-zero row in V. */
+ for(;;) { /* while(complicated condition) */
+ i__1 = i__;
+ if (!(lastv > 0 && (v[i__1].r == 0. && v[i__1].i == 0.)))
+ break;
+ --lastv;
+ i__ -= *incv;
+ }
+ if (applyleft) {
+/* Scan for the last non-zero column in C(1:lastv,:). */
+ lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc);
+ } else {
+/* Scan for the last non-zero row in C(:,1:lastv). */
+ lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc);
+ }
+ }
+/* Note that lastc.eq.0 renders the BLAS operations null; no special */
+/* case is needed at this level. */
+ if (applyleft) {
+
+/* Form H * C */
+
+ if (lastv > 0) {
+
+/* w(1:lastc,1) := C(1:lastv,1:lastc)' * v(1:lastv,1) */
+
+ zgemv_("Conjugate transpose", &lastv, &lastc, &c_b1, &c__[
+ c_offset], ldc, &v[1], incv, &c_b2, &work[1], &c__1);
+
+/* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)' */
+
+ z__1.r = -tau->r, z__1.i = -tau->i;
+ zgerc_(&lastv, &lastc, &z__1, &v[1], incv, &work[1], &c__1, &c__[
+ c_offset], ldc);
+ }
+ } else {
+
+/* Form C * H */
+
+ if (lastv > 0) {
+
+/* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) */
+
+ zgemv_("No transpose", &lastc, &lastv, &c_b1, &c__[c_offset], ldc,
+ &v[1], incv, &c_b2, &work[1], &c__1);
+
+/* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)' */
+
+ z__1.r = -tau->r, z__1.i = -tau->i;
+ zgerc_(&lastc, &lastv, &z__1, &work[1], &c__1, &v[1], incv, &c__[
+ c_offset], ldc);
+ }
+ }
+ return 0;
+
+/* End of ZLARF */
+
+} /* zlarf_ */
diff --git a/SRC/zlarfb.c b/SRC/zlarfb.c
new file mode 100644
index 0000000..cdd584e
--- /dev/null
+++ b/SRC/zlarfb.c
@@ -0,0 +1,839 @@
+/* zlarfb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zlarfb_(char *side, char *trans, char *direct, char *
+ storev, integer *m, integer *n, integer *k, doublecomplex *v, integer
+ *ldv, doublecomplex *t, integer *ldt, doublecomplex *c__, integer *
+ ldc, doublecomplex *work, integer *ldwork)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1,
+ work_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ extern logical lsame_(char *, char *);
+ integer lastc;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer lastv;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), ztrmm_(char *, char *, char *, char *
+, integer *, integer *, doublecomplex *, doublecomplex *, integer
+ *, doublecomplex *, integer *);
+ extern integer ilazlc_(integer *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zlacgv_(integer *, doublecomplex *, integer *)
+ ;
+ extern integer ilazlr_(integer *, integer *, doublecomplex *, integer *);
+ char transt[1];
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLARFB applies a complex block reflector H or its transpose H' to a */
+/* complex M-by-N matrix C, from either the left or the right. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply H or H' from the Left */
+/* = 'R': apply H or H' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply H (No transpose) */
+/* = 'C': apply H' (Conjugate transpose) */
+
+/* DIRECT (input) CHARACTER*1 */
+/* Indicates how H is formed from a product of elementary */
+/* reflectors */
+/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */
+/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
+
+/* STOREV (input) CHARACTER*1 */
+/* Indicates how the vectors which define the elementary */
+/* reflectors are stored: */
+/* = 'C': Columnwise */
+/* = 'R': Rowwise */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* K (input) INTEGER */
+/* The order of the matrix T (= the number of elementary */
+/* reflectors whose product defines the block reflector). */
+
+/* V (input) COMPLEX*16 array, dimension */
+/* (LDV,K) if STOREV = 'C' */
+/* (LDV,M) if STOREV = 'R' and SIDE = 'L' */
+/* (LDV,N) if STOREV = 'R' and SIDE = 'R' */
+/* The matrix V. See further details. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. */
+/* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); */
+/* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); */
+/* if STOREV = 'R', LDV >= K. */
+
+/* T (input) COMPLEX*16 array, dimension (LDT,K) */
+/* The triangular K-by-K matrix T in the representation of the */
+/* block reflector. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= K. */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,K) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. */
+/* If SIDE = 'L', LDWORK >= max(1,N); */
+/* if SIDE = 'R', LDWORK >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+ if (lsame_(trans, "N")) {
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+ if (lsame_(storev, "C")) {
+
+ if (lsame_(direct, "F")) {
+
+/* Let V = ( V1 ) (first K rows) */
+/* ( V2 ) */
+/* where V1 is unit lower triangular. */
+
+ if (lsame_(side, "L")) {
+
+/* Form H * C or H' * C where C = ( C1 ) */
+/* ( C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilazlr_(m, k, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc);
+
+/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */
+
+/* W := C1' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1
+ + 1], &c__1);
+ zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1);
+/* L10: */
+ }
+
+/* W := W * V1 */
+
+ ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
+ c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C2'*V2 */
+
+ i__1 = lastv - *k;
+ zgemm_("Conjugate transpose", "No transpose", &lastc, k, &
+ i__1, &c_b1, &c__[*k + 1 + c_dim1], ldc, &v[*k +
+ 1 + v_dim1], ldv, &c_b1, &work[work_offset],
+ ldwork);
+ }
+
+/* W := W * T' or W * T */
+
+ ztrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &c_b1,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - V * W' */
+
+ if (*m > *k) {
+
+/* C2 := C2 - V2 * W' */
+
+ i__1 = lastv - *k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "Conjugate transpose", &i__1, &
+ lastc, k, &z__1, &v[*k + 1 + v_dim1], ldv, &work[
+ work_offset], ldwork, &c_b1, &c__[*k + 1 + c_dim1]
+, ldc);
+ }
+
+/* W := W * V1' */
+
+ ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &
+ lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset]
+, ldwork)
+ ;
+
+/* C1 := C1 - W' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * c_dim1;
+ i__4 = j + i__ * c_dim1;
+ d_cnjg(&z__2, &work[i__ + j * work_dim1]);
+ z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i -
+ z__2.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L20: */
+ }
+/* L30: */
+ }
+
+ } else if (lsame_(side, "R")) {
+
+/* Form C * H or C * H' where C = ( C1 C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilazlr_(n, k, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc);
+
+/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */
+
+/* W := C1 */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j *
+ work_dim1 + 1], &c__1);
+/* L40: */
+ }
+
+/* W := W * V1 */
+
+ ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
+ c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C2 * V2 */
+
+ i__1 = lastv - *k;
+ zgemm_("No transpose", "No transpose", &lastc, k, &i__1, &
+ c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + 1
+ + v_dim1], ldv, &c_b1, &work[work_offset], ldwork);
+ }
+
+/* W := W * T or W * T' */
+
+ ztrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b1,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - W * V' */
+
+ if (lastv > *k) {
+
+/* C2 := C2 - W * V2' */
+
+ i__1 = lastv - *k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "Conjugate transpose", &lastc, &
+ i__1, k, &z__1, &work[work_offset], ldwork, &v[*k
+ + 1 + v_dim1], ldv, &c_b1, &c__[(*k + 1) * c_dim1
+ + 1], ldc);
+ }
+
+/* W := W * V1' */
+
+ ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &
+ lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset]
+, ldwork)
+ ;
+
+/* C1 := C1 - W */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * work_dim1;
+ z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[
+ i__4].i - work[i__5].i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+
+ } else {
+
+/* Let V = ( V1 ) */
+/* ( V2 ) (last K rows) */
+/* where V2 is unit upper triangular. */
+
+ if (lsame_(side, "L")) {
+
+/* Form H * C or H' * C where C = ( C1 ) */
+/* ( C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilazlr_(m, k, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc);
+
+/* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) */
+
+/* W := C2' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[
+ j * work_dim1 + 1], &c__1);
+ zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1);
+/* L70: */
+ }
+
+/* W := W * V2 */
+
+ ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
+ c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &work[
+ work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C1'*V1 */
+
+ i__1 = lastv - *k;
+ zgemm_("Conjugate transpose", "No transpose", &lastc, k, &
+ i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset],
+ ldv, &c_b1, &work[work_offset], ldwork);
+ }
+
+/* W := W * T' or W * T */
+
+ ztrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &c_b1,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - V * W' */
+
+ if (lastv > *k) {
+
+/* C1 := C1 - V1 * W' */
+
+ i__1 = lastv - *k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "Conjugate transpose", &i__1, &
+ lastc, k, &z__1, &v[v_offset], ldv, &work[
+ work_offset], ldwork, &c_b1, &c__[c_offset], ldc);
+ }
+
+/* W := W * V2' */
+
+ ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", &
+ lastc, k, &c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &
+ work[work_offset], ldwork);
+
+/* C2 := C2 - W' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = lastv - *k + j + i__ * c_dim1;
+ i__4 = lastv - *k + j + i__ * c_dim1;
+ d_cnjg(&z__2, &work[i__ + j * work_dim1]);
+ z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i -
+ z__2.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L80: */
+ }
+/* L90: */
+ }
+
+ } else if (lsame_(side, "R")) {
+
+/* Form C * H or C * H' where C = ( C1 C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilazlr_(n, k, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc);
+
+/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */
+
+/* W := C2 */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1,
+ &work[j * work_dim1 + 1], &c__1);
+/* L100: */
+ }
+
+/* W := W * V2 */
+
+ ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
+ c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &work[
+ work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C1 * V1 */
+
+ i__1 = lastv - *k;
+ zgemm_("No transpose", "No transpose", &lastc, k, &i__1, &
+ c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, &
+ c_b1, &work[work_offset], ldwork);
+ }
+
+/* W := W * T or W * T' */
+
+ ztrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b1,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - W * V' */
+
+ if (lastv > *k) {
+
+/* C1 := C1 - W * V1' */
+
+ i__1 = lastv - *k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "Conjugate transpose", &lastc, &
+ i__1, k, &z__1, &work[work_offset], ldwork, &v[
+ v_offset], ldv, &c_b1, &c__[c_offset], ldc);
+ }
+
+/* W := W * V2' */
+
+ ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", &
+ lastc, k, &c_b1, &v[lastv - *k + 1 + v_dim1], ldv, &
+ work[work_offset], ldwork);
+
+/* C2 := C2 - W */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (lastv - *k + j) * c_dim1;
+ i__4 = i__ + (lastv - *k + j) * c_dim1;
+ i__5 = i__ + j * work_dim1;
+ z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[
+ i__4].i - work[i__5].i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L110: */
+ }
+/* L120: */
+ }
+ }
+ }
+
+ } else if (lsame_(storev, "R")) {
+
+ if (lsame_(direct, "F")) {
+
+/* Let V = ( V1 V2 ) (V1: first K columns) */
+/* where V1 is unit upper triangular. */
+
+ if (lsame_(side, "L")) {
+
+/* Form H * C or H' * C where C = ( C1 ) */
+/* ( C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilazlc_(k, m, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc);
+
+/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */
+
+/* W := C1' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1
+ + 1], &c__1);
+ zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1);
+/* L130: */
+ }
+
+/* W := W * V1' */
+
+ ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", &
+ lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset]
+, ldwork)
+ ;
+ if (lastv > *k) {
+
+/* W := W + C2'*V2' */
+
+ i__1 = lastv - *k;
+ zgemm_("Conjugate transpose", "Conjugate transpose", &
+ lastc, k, &i__1, &c_b1, &c__[*k + 1 + c_dim1],
+ ldc, &v[(*k + 1) * v_dim1 + 1], ldv, &c_b1, &work[
+ work_offset], ldwork);
+ }
+
+/* W := W * T' or W * T */
+
+ ztrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &c_b1,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - V' * W' */
+
+ if (lastv > *k) {
+
+/* C2 := C2 - V2' * W' */
+
+ i__1 = lastv - *k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("Conjugate transpose", "Conjugate transpose", &
+ i__1, &lastc, k, &z__1, &v[(*k + 1) * v_dim1 + 1],
+ ldv, &work[work_offset], ldwork, &c_b1, &c__[*k
+ + 1 + c_dim1], ldc);
+ }
+
+/* W := W * V1 */
+
+ ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
+ c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
+
+/* C1 := C1 - W' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * c_dim1;
+ i__4 = j + i__ * c_dim1;
+ d_cnjg(&z__2, &work[i__ + j * work_dim1]);
+ z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i -
+ z__2.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L140: */
+ }
+/* L150: */
+ }
+
+ } else if (lsame_(side, "R")) {
+
+/* Form C * H or C * H' where C = ( C1 C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilazlc_(k, n, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc);
+
+/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */
+
+/* W := C1 */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j *
+ work_dim1 + 1], &c__1);
+/* L160: */
+ }
+
+/* W := W * V1' */
+
+ ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", &
+ lastc, k, &c_b1, &v[v_offset], ldv, &work[work_offset]
+, ldwork)
+ ;
+ if (lastv > *k) {
+
+/* W := W + C2 * V2' */
+
+ i__1 = lastv - *k;
+ zgemm_("No transpose", "Conjugate transpose", &lastc, k, &
+ i__1, &c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[
+ (*k + 1) * v_dim1 + 1], ldv, &c_b1, &work[
+ work_offset], ldwork);
+ }
+
+/* W := W * T or W * T' */
+
+ ztrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b1,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - W * V */
+
+ if (lastv > *k) {
+
+/* C2 := C2 - W * V2 */
+
+ i__1 = lastv - *k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "No transpose", &lastc, &i__1, k, &
+ z__1, &work[work_offset], ldwork, &v[(*k + 1) *
+ v_dim1 + 1], ldv, &c_b1, &c__[(*k + 1) * c_dim1 +
+ 1], ldc);
+ }
+
+/* W := W * V1 */
+
+ ztrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
+ c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
+
+/* C1 := C1 - W */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * work_dim1;
+ z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[
+ i__4].i - work[i__5].i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L170: */
+ }
+/* L180: */
+ }
+
+ }
+
+ } else {
+
+/* Let V = ( V1 V2 ) (V2: last K columns) */
+/* where V2 is unit lower triangular. */
+
+ if (lsame_(side, "L")) {
+
+/* Form H * C or H' * C where C = ( C1 ) */
+/* ( C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilazlc_(k, m, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc);
+
+/* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) */
+
+/* W := C2' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[
+ j * work_dim1 + 1], &c__1);
+ zlacgv_(&lastc, &work[j * work_dim1 + 1], &c__1);
+/* L190: */
+ }
+
+/* W := W * V2' */
+
+ ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &
+ lastc, k, &c_b1, &v[(lastv - *k + 1) * v_dim1 + 1],
+ ldv, &work[work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C1'*V1' */
+
+ i__1 = lastv - *k;
+ zgemm_("Conjugate transpose", "Conjugate transpose", &
+ lastc, k, &i__1, &c_b1, &c__[c_offset], ldc, &v[
+ v_offset], ldv, &c_b1, &work[work_offset], ldwork);
+ }
+
+/* W := W * T' or W * T */
+
+ ztrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &c_b1,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - V' * W' */
+
+ if (lastv > *k) {
+
+/* C1 := C1 - V1' * W' */
+
+ i__1 = lastv - *k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("Conjugate transpose", "Conjugate transpose", &
+ i__1, &lastc, k, &z__1, &v[v_offset], ldv, &work[
+ work_offset], ldwork, &c_b1, &c__[c_offset], ldc);
+ }
+
+/* W := W * V2 */
+
+ ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
+ c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
+ work_offset], ldwork);
+
+/* C2 := C2 - W' */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = lastv - *k + j + i__ * c_dim1;
+ i__4 = lastv - *k + j + i__ * c_dim1;
+ d_cnjg(&z__2, &work[i__ + j * work_dim1]);
+ z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i -
+ z__2.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L200: */
+ }
+/* L210: */
+ }
+
+ } else if (lsame_(side, "R")) {
+
+/* Form C * H or C * H' where C = ( C1 C2 ) */
+
+/* Computing MAX */
+ i__1 = *k, i__2 = ilazlc_(k, n, &v[v_offset], ldv);
+ lastv = max(i__1,i__2);
+ lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc);
+
+/* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) */
+
+/* W := C2 */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1,
+ &work[j * work_dim1 + 1], &c__1);
+/* L220: */
+ }
+
+/* W := W * V2' */
+
+ ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &
+ lastc, k, &c_b1, &v[(lastv - *k + 1) * v_dim1 + 1],
+ ldv, &work[work_offset], ldwork);
+ if (lastv > *k) {
+
+/* W := W + C1 * V1' */
+
+ i__1 = lastv - *k;
+ zgemm_("No transpose", "Conjugate transpose", &lastc, k, &
+ i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset],
+ ldv, &c_b1, &work[work_offset], ldwork);
+ }
+
+/* W := W * T or W * T' */
+
+ ztrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b1,
+ &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/* C := C - W * V */
+
+ if (lastv > *k) {
+
+/* C1 := C1 - W * V1 */
+
+ i__1 = lastv - *k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "No transpose", &lastc, &i__1, k, &
+ z__1, &work[work_offset], ldwork, &v[v_offset],
+ ldv, &c_b1, &c__[c_offset], ldc);
+ }
+
+/* W := W * V2 */
+
+ ztrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
+ c_b1, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
+ work_offset], ldwork);
+
+/* C1 := C1 - W */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = lastc;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (lastv - *k + j) * c_dim1;
+ i__4 = i__ + (lastv - *k + j) * c_dim1;
+ i__5 = i__ + j * work_dim1;
+ z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[
+ i__4].i - work[i__5].i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L230: */
+ }
+/* L240: */
+ }
+
+ }
+
+ }
+ }
+
+ return 0;
+
+/* End of ZLARFB */
+
+} /* zlarfb_ */
diff --git a/SRC/zlarfg.c b/SRC/zlarfg.c
new file mode 100644
index 0000000..d18efe5
--- /dev/null
+++ b/SRC/zlarfg.c
@@ -0,0 +1,191 @@
+/* zlarfg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b5 = {1.,0.};
+
+/* Subroutine */ int zlarfg_(integer *n, doublecomplex *alpha, doublecomplex *
+ x, integer *incx, doublecomplex *tau)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer j, knt;
+ doublereal beta, alphi, alphr;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ doublereal xnorm;
+ extern doublereal dlapy3_(doublereal *, doublereal *, doublereal *),
+ dznrm2_(integer *, doublecomplex *, integer *), dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ doublereal rsafmn;
+ extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
+ doublecomplex *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLARFG generates a complex elementary reflector H of order n, such */
+/* that */
+
+/* H' * ( alpha ) = ( beta ), H' * H = I. */
+/* ( x ) ( 0 ) */
+
+/* where alpha and beta are scalars, with beta real, and x is an */
+/* (n-1)-element complex vector. H is represented in the form */
+
+/* H = I - tau * ( 1 ) * ( 1 v' ) , */
+/* ( v ) */
+
+/* where tau is a complex scalar and v is a complex (n-1)-element */
+/* vector. Note that H is not hermitian. */
+
+/* If the elements of x are all zero and alpha is real, then tau = 0 */
+/* and H is taken to be the unit matrix. */
+
+/* Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the elementary reflector. */
+
+/* ALPHA (input/output) COMPLEX*16 */
+/* On entry, the value alpha. */
+/* On exit, it is overwritten with the value beta. */
+
+/* X (input/output) COMPLEX*16 array, dimension */
+/* (1+(N-2)*abs(INCX)) */
+/* On entry, the vector x. */
+/* On exit, it is overwritten with the vector v. */
+
+/* INCX (input) INTEGER */
+/* The increment between elements of X. INCX > 0. */
+
+/* TAU (output) COMPLEX*16 */
+/* The value tau. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --x;
+
+ /* Function Body */
+ if (*n <= 0) {
+ tau->r = 0., tau->i = 0.;
+ return 0;
+ }
+
+ i__1 = *n - 1;
+ xnorm = dznrm2_(&i__1, &x[1], incx);
+ alphr = alpha->r;
+ alphi = d_imag(alpha);
+
+ if (xnorm == 0. && alphi == 0.) {
+
+/* H = I */
+
+ tau->r = 0., tau->i = 0.;
+ } else {
+
+/* general case */
+
+ d__1 = dlapy3_(&alphr, &alphi, &xnorm);
+ beta = -d_sign(&d__1, &alphr);
+ safmin = dlamch_("S") / dlamch_("E");
+ rsafmn = 1. / safmin;
+
+ knt = 0;
+ if (abs(beta) < safmin) {
+
+/* XNORM, BETA may be inaccurate; scale X and recompute them */
+
+L10:
+ ++knt;
+ i__1 = *n - 1;
+ zdscal_(&i__1, &rsafmn, &x[1], incx);
+ beta *= rsafmn;
+ alphi *= rsafmn;
+ alphr *= rsafmn;
+ if (abs(beta) < safmin) {
+ goto L10;
+ }
+
+/* New BETA is at most 1, at least SAFMIN */
+
+ i__1 = *n - 1;
+ xnorm = dznrm2_(&i__1, &x[1], incx);
+ z__1.r = alphr, z__1.i = alphi;
+ alpha->r = z__1.r, alpha->i = z__1.i;
+ d__1 = dlapy3_(&alphr, &alphi, &xnorm);
+ beta = -d_sign(&d__1, &alphr);
+ }
+ d__1 = (beta - alphr) / beta;
+ d__2 = -alphi / beta;
+ z__1.r = d__1, z__1.i = d__2;
+ tau->r = z__1.r, tau->i = z__1.i;
+ z__2.r = alpha->r - beta, z__2.i = alpha->i;
+ zladiv_(&z__1, &c_b5, &z__2);
+ alpha->r = z__1.r, alpha->i = z__1.i;
+ i__1 = *n - 1;
+ zscal_(&i__1, alpha, &x[1], incx);
+
+/* If ALPHA is subnormal, it may lose relative accuracy */
+
+ i__1 = knt;
+ for (j = 1; j <= i__1; ++j) {
+ beta *= safmin;
+/* L20: */
+ }
+ alpha->r = beta, alpha->i = 0.;
+ }
+
+ return 0;
+
+/* End of ZLARFG */
+
+} /* zlarfg_ */
diff --git a/SRC/zlarfp.c b/SRC/zlarfp.c
new file mode 100644
index 0000000..38fda66
--- /dev/null
+++ b/SRC/zlarfp.c
@@ -0,0 +1,236 @@
+/* zlarfp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b5 = {1.,0.};
+
+/* Subroutine */ int zlarfp_(integer *n, doublecomplex *alpha, doublecomplex *
+ x, integer *incx, doublecomplex *tau)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer j, knt;
+ doublereal beta, alphi, alphr;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ doublereal xnorm;
+ extern doublereal dlapy2_(doublereal *, doublereal *), dlapy3_(doublereal
+ *, doublereal *, doublereal *), dznrm2_(integer *, doublecomplex *
+, integer *), dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ doublereal rsafmn;
+ extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
+ doublecomplex *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLARFP generates a complex elementary reflector H of order n, such */
+/* that */
+
+/* H' * ( alpha ) = ( beta ), H' * H = I. */
+/* ( x ) ( 0 ) */
+
+/* where alpha and beta are scalars, beta is real and non-negative, and */
+/* x is an (n-1)-element complex vector. H is represented in the form */
+
+/* H = I - tau * ( 1 ) * ( 1 v' ) , */
+/* ( v ) */
+
+/* where tau is a complex scalar and v is a complex (n-1)-element */
+/* vector. Note that H is not hermitian. */
+
+/* If the elements of x are all zero and alpha is real, then tau = 0 */
+/* and H is taken to be the unit matrix. */
+
+/* Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the elementary reflector. */
+
+/* ALPHA (input/output) COMPLEX*16 */
+/* On entry, the value alpha. */
+/* On exit, it is overwritten with the value beta. */
+
+/* X (input/output) COMPLEX*16 array, dimension */
+/* (1+(N-2)*abs(INCX)) */
+/* On entry, the vector x. */
+/* On exit, it is overwritten with the vector v. */
+
+/* INCX (input) INTEGER */
+/* The increment between elements of X. INCX > 0. */
+
+/* TAU (output) COMPLEX*16 */
+/* The value tau. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --x;
+
+ /* Function Body */
+ if (*n <= 0) {
+ tau->r = 0., tau->i = 0.;
+ return 0;
+ }
+
+ i__1 = *n - 1;
+ xnorm = dznrm2_(&i__1, &x[1], incx);
+ alphr = alpha->r;
+ alphi = d_imag(alpha);
+
+ if (xnorm == 0. && alphi == 0.) {
+
+/* H = [1-alpha/abs(alpha) 0; 0 I], sign chosen so ALPHA >= 0. */
+
+ if (alphi == 0.) {
+ if (alphr >= 0.) {
+/* When TAU.eq.ZERO, the vector is special-cased to be */
+/* all zeros in the application routines. We do not need */
+/* to clear it. */
+ tau->r = 0., tau->i = 0.;
+ } else {
+/* However, the application routines rely on explicit */
+/* zero checks when TAU.ne.ZERO, and we must clear X. */
+ tau->r = 2., tau->i = 0.;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (j - 1) * *incx + 1;
+ x[i__2].r = 0., x[i__2].i = 0.;
+ }
+ z__1.r = -alpha->r, z__1.i = -alpha->i;
+ alpha->r = z__1.r, alpha->i = z__1.i;
+ }
+ } else {
+/* Only "reflecting" the diagonal entry to be real and non-negative. */
+ xnorm = dlapy2_(&alphr, &alphi);
+ d__1 = 1. - alphr / xnorm;
+ d__2 = -alphi / xnorm;
+ z__1.r = d__1, z__1.i = d__2;
+ tau->r = z__1.r, tau->i = z__1.i;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (j - 1) * *incx + 1;
+ x[i__2].r = 0., x[i__2].i = 0.;
+ }
+ alpha->r = xnorm, alpha->i = 0.;
+ }
+ } else {
+
+/* general case */
+
+ d__1 = dlapy3_(&alphr, &alphi, &xnorm);
+ beta = d_sign(&d__1, &alphr);
+ safmin = dlamch_("S") / dlamch_("E");
+ rsafmn = 1. / safmin;
+
+ knt = 0;
+ if (abs(beta) < safmin) {
+
+/* XNORM, BETA may be inaccurate; scale X and recompute them */
+
+L10:
+ ++knt;
+ i__1 = *n - 1;
+ zdscal_(&i__1, &rsafmn, &x[1], incx);
+ beta *= rsafmn;
+ alphi *= rsafmn;
+ alphr *= rsafmn;
+ if (abs(beta) < safmin) {
+ goto L10;
+ }
+
+/* New BETA is at most 1, at least SAFMIN */
+
+ i__1 = *n - 1;
+ xnorm = dznrm2_(&i__1, &x[1], incx);
+ z__1.r = alphr, z__1.i = alphi;
+ alpha->r = z__1.r, alpha->i = z__1.i;
+ d__1 = dlapy3_(&alphr, &alphi, &xnorm);
+ beta = d_sign(&d__1, &alphr);
+ }
+ z__1.r = alpha->r + beta, z__1.i = alpha->i;
+ alpha->r = z__1.r, alpha->i = z__1.i;
+ if (beta < 0.) {
+ beta = -beta;
+ z__2.r = -alpha->r, z__2.i = -alpha->i;
+ z__1.r = z__2.r / beta, z__1.i = z__2.i / beta;
+ tau->r = z__1.r, tau->i = z__1.i;
+ } else {
+ alphr = alphi * (alphi / alpha->r);
+ alphr += xnorm * (xnorm / alpha->r);
+ d__1 = alphr / beta;
+ d__2 = -alphi / beta;
+ z__1.r = d__1, z__1.i = d__2;
+ tau->r = z__1.r, tau->i = z__1.i;
+ d__1 = -alphr;
+ z__1.r = d__1, z__1.i = alphi;
+ alpha->r = z__1.r, alpha->i = z__1.i;
+ }
+ zladiv_(&z__1, &c_b5, alpha);
+ alpha->r = z__1.r, alpha->i = z__1.i;
+ i__1 = *n - 1;
+ zscal_(&i__1, alpha, &x[1], incx);
+
+/* If BETA is subnormal, it may lose relative accuracy */
+
+ i__1 = knt;
+ for (j = 1; j <= i__1; ++j) {
+ beta *= safmin;
+/* L20: */
+ }
+ alpha->r = beta, alpha->i = 0.;
+ }
+
+ return 0;
+
+/* End of ZLARFP */
+
+} /* zlarfp_ */
diff --git a/SRC/zlarft.c b/SRC/zlarft.c
new file mode 100644
index 0000000..b55adc2
--- /dev/null
+++ b/SRC/zlarft.c
@@ -0,0 +1,362 @@
+/* zlarft.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b2 = {0.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zlarft_(char *direct, char *storev, integer *n, integer *
+ k, doublecomplex *v, integer *ldv, doublecomplex *tau, doublecomplex *
+ t, integer *ldt)
+{
+ /* System generated locals */
+ integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j, prevlastv;
+ doublecomplex vii;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ integer lastv;
+ extern /* Subroutine */ int ztrmv_(char *, char *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *), zlacgv_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLARFT forms the triangular factor T of a complex block reflector H */
+/* of order n, which is defined as a product of k elementary reflectors. */
+
+/* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */
+
+/* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */
+
+/* If STOREV = 'C', the vector which defines the elementary reflector */
+/* H(i) is stored in the i-th column of the array V, and */
+
+/* H = I - V * T * V' */
+
+/* If STOREV = 'R', the vector which defines the elementary reflector */
+/* H(i) is stored in the i-th row of the array V, and */
+
+/* H = I - V' * T * V */
+
+/* Arguments */
+/* ========= */
+
+/* DIRECT (input) CHARACTER*1 */
+/* Specifies the order in which the elementary reflectors are */
+/* multiplied to form the block reflector: */
+/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */
+/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
+
+/* STOREV (input) CHARACTER*1 */
+/* Specifies how the vectors which define the elementary */
+/* reflectors are stored (see also Further Details): */
+/* = 'C': columnwise */
+/* = 'R': rowwise */
+
+/* N (input) INTEGER */
+/* The order of the block reflector H. N >= 0. */
+
+/* K (input) INTEGER */
+/* The order of the triangular factor T (= the number of */
+/* elementary reflectors). K >= 1. */
+
+/* V (input/output) COMPLEX*16 array, dimension */
+/* (LDV,K) if STOREV = 'C' */
+/* (LDV,N) if STOREV = 'R' */
+/* The matrix V. See further details. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. */
+/* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */
+
+/* TAU (input) COMPLEX*16 array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i). */
+
+/* T (output) COMPLEX*16 array, dimension (LDT,K) */
+/* The k by k triangular factor T of the block reflector. */
+/* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */
+/* lower triangular. The rest of the array is not used. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= K. */
+
+/* Further Details */
+/* =============== */
+
+/* The shape of the matrix V and the storage of the vectors which define */
+/* the H(i) is best illustrated by the following example with n = 5 and */
+/* k = 3. The elements equal to 1 are not stored; the corresponding */
+/* array elements are modified but restored on exit. The rest of the */
+/* array is not used. */
+
+/* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */
+
+/* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */
+/* ( v1 1 ) ( 1 v2 v2 v2 ) */
+/* ( v1 v2 1 ) ( 1 v3 v3 ) */
+/* ( v1 v2 v3 ) */
+/* ( v1 v2 v3 ) */
+
+/* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */
+
+/* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */
+/* ( v1 v2 v3 ) ( v2 v2 v2 1 ) */
+/* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */
+/* ( 1 v3 ) */
+/* ( 1 ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --tau;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+
+ /* Function Body */
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (lsame_(direct, "F")) {
+ prevlastv = *n;
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ prevlastv = max(prevlastv,i__);
+ i__2 = i__;
+ if (tau[i__2].r == 0. && tau[i__2].i == 0.) {
+
+/* H(i) = I */
+
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * t_dim1;
+ t[i__3].r = 0., t[i__3].i = 0.;
+/* L10: */
+ }
+ } else {
+
+/* general case */
+
+ i__2 = i__ + i__ * v_dim1;
+ vii.r = v[i__2].r, vii.i = v[i__2].i;
+ i__2 = i__ + i__ * v_dim1;
+ v[i__2].r = 1., v[i__2].i = 0.;
+ if (lsame_(storev, "C")) {
+/* Skip any trailing zeros. */
+ i__2 = i__ + 1;
+ for (lastv = *n; lastv >= i__2; --lastv) {
+ i__3 = lastv + i__ * v_dim1;
+ if (v[i__3].r != 0. || v[i__3].i != 0.) {
+ break;
+ }
+ }
+ j = min(lastv,prevlastv);
+
+/* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i) */
+
+ i__2 = j - i__ + 1;
+ i__3 = i__ - 1;
+ i__4 = i__;
+ z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i;
+ zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &v[i__
+ + v_dim1], ldv, &v[i__ + i__ * v_dim1], &c__1, &
+ c_b2, &t[i__ * t_dim1 + 1], &c__1);
+ } else {
+/* Skip any trailing zeros. */
+ i__2 = i__ + 1;
+ for (lastv = *n; lastv >= i__2; --lastv) {
+ i__3 = i__ + lastv * v_dim1;
+ if (v[i__3].r != 0. || v[i__3].i != 0.) {
+ break;
+ }
+ }
+ j = min(lastv,prevlastv);
+
+/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)' */
+
+ if (i__ < j) {
+ i__2 = j - i__;
+ zlacgv_(&i__2, &v[i__ + (i__ + 1) * v_dim1], ldv);
+ }
+ i__2 = i__ - 1;
+ i__3 = j - i__ + 1;
+ i__4 = i__;
+ z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i;
+ zgemv_("No transpose", &i__2, &i__3, &z__1, &v[i__ *
+ v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, &
+ c_b2, &t[i__ * t_dim1 + 1], &c__1);
+ if (i__ < j) {
+ i__2 = j - i__;
+ zlacgv_(&i__2, &v[i__ + (i__ + 1) * v_dim1], ldv);
+ }
+ }
+ i__2 = i__ + i__ * v_dim1;
+ v[i__2].r = vii.r, v[i__2].i = vii.i;
+
+/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */
+
+ i__2 = i__ - 1;
+ ztrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[
+ t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1);
+ i__2 = i__ + i__ * t_dim1;
+ i__3 = i__;
+ t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i;
+ if (i__ > 1) {
+ prevlastv = max(prevlastv,lastv);
+ } else {
+ prevlastv = lastv;
+ }
+ }
+/* L20: */
+ }
+ } else {
+ prevlastv = 1;
+ for (i__ = *k; i__ >= 1; --i__) {
+ i__1 = i__;
+ if (tau[i__1].r == 0. && tau[i__1].i == 0.) {
+
+/* H(i) = I */
+
+ i__1 = *k;
+ for (j = i__; j <= i__1; ++j) {
+ i__2 = j + i__ * t_dim1;
+ t[i__2].r = 0., t[i__2].i = 0.;
+/* L30: */
+ }
+ } else {
+
+/* general case */
+
+ if (i__ < *k) {
+ if (lsame_(storev, "C")) {
+ i__1 = *n - *k + i__ + i__ * v_dim1;
+ vii.r = v[i__1].r, vii.i = v[i__1].i;
+ i__1 = *n - *k + i__ + i__ * v_dim1;
+ v[i__1].r = 1., v[i__1].i = 0.;
+/* Skip any leading zeros. */
+ i__1 = i__ - 1;
+ for (lastv = 1; lastv <= i__1; ++lastv) {
+ i__2 = lastv + i__ * v_dim1;
+ if (v[i__2].r != 0. || v[i__2].i != 0.) {
+ break;
+ }
+ }
+ j = max(lastv,prevlastv);
+
+/* T(i+1:k,i) := */
+/* - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i) */
+
+ i__1 = *n - *k + i__ - j + 1;
+ i__2 = *k - i__;
+ i__3 = i__;
+ z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i;
+ zgemv_("Conjugate transpose", &i__1, &i__2, &z__1, &v[
+ j + (i__ + 1) * v_dim1], ldv, &v[j + i__ *
+ v_dim1], &c__1, &c_b2, &t[i__ + 1 + i__ *
+ t_dim1], &c__1);
+ i__1 = *n - *k + i__ + i__ * v_dim1;
+ v[i__1].r = vii.r, v[i__1].i = vii.i;
+ } else {
+ i__1 = i__ + (*n - *k + i__) * v_dim1;
+ vii.r = v[i__1].r, vii.i = v[i__1].i;
+ i__1 = i__ + (*n - *k + i__) * v_dim1;
+ v[i__1].r = 1., v[i__1].i = 0.;
+/* Skip any leading zeros. */
+ i__1 = i__ - 1;
+ for (lastv = 1; lastv <= i__1; ++lastv) {
+ i__2 = i__ + lastv * v_dim1;
+ if (v[i__2].r != 0. || v[i__2].i != 0.) {
+ break;
+ }
+ }
+ j = max(lastv,prevlastv);
+
+/* T(i+1:k,i) := */
+/* - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)' */
+
+ i__1 = *n - *k + i__ - 1 - j + 1;
+ zlacgv_(&i__1, &v[i__ + j * v_dim1], ldv);
+ i__1 = *k - i__;
+ i__2 = *n - *k + i__ - j + 1;
+ i__3 = i__;
+ z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i;
+ zgemv_("No transpose", &i__1, &i__2, &z__1, &v[i__ +
+ 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1],
+ ldv, &c_b2, &t[i__ + 1 + i__ * t_dim1], &c__1);
+ i__1 = *n - *k + i__ - 1 - j + 1;
+ zlacgv_(&i__1, &v[i__ + j * v_dim1], ldv);
+ i__1 = i__ + (*n - *k + i__) * v_dim1;
+ v[i__1].r = vii.r, v[i__1].i = vii.i;
+ }
+
+/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */
+
+ i__1 = *k - i__;
+ ztrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__
+ + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ *
+ t_dim1], &c__1)
+ ;
+ if (i__ > 1) {
+ prevlastv = min(prevlastv,lastv);
+ } else {
+ prevlastv = lastv;
+ }
+ }
+ i__1 = i__ + i__ * t_dim1;
+ i__2 = i__;
+ t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i;
+ }
+/* L40: */
+ }
+ }
+ return 0;
+
+/* End of ZLARFT */
+
+} /* zlarft_ */
diff --git a/SRC/zlarfx.c b/SRC/zlarfx.c
new file mode 100644
index 0000000..1da9e3e
--- /dev/null
+++ b/SRC/zlarfx.c
@@ -0,0 +1,2050 @@
+/* zlarfx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zlarfx_(char *side, integer *m, integer *n,
+ doublecomplex *v, doublecomplex *tau, doublecomplex *c__, integer *
+ ldc, doublecomplex *work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
+ i__9, i__10, i__11;
+ doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8, z__9, z__10,
+ z__11, z__12, z__13, z__14, z__15, z__16, z__17, z__18, z__19;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer j;
+ doublecomplex t1, t2, t3, t4, t5, t6, t7, t8, t9, v1, v2, v3, v4, v5, v6,
+ v7, v8, v9, t10, v10, sum;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLARFX applies a complex elementary reflector H to a complex m by n */
+/* matrix C, from either the left or the right. H is represented in the */
+/* form */
+
+/* H = I - tau * v * v' */
+
+/* where tau is a complex scalar and v is a complex vector. */
+
+/* If tau = 0, then H is taken to be the unit matrix */
+
+/* This version uses inline code if H has order < 11. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': form H * C */
+/* = 'R': form C * H */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* V (input) COMPLEX*16 array, dimension (M) if SIDE = 'L' */
+/* or (N) if SIDE = 'R' */
+/* The vector v in the representation of H. */
+
+/* TAU (input) COMPLEX*16 */
+/* The value tau in the representation of H. */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
+/* On entry, the m by n matrix C. */
+/* On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
+/* or C * H if SIDE = 'R'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDA >= max(1,M). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) if SIDE = 'L' */
+/* or (M) if SIDE = 'R' */
+/* WORK is not referenced if H has order < 11. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ if (tau->r == 0. && tau->i == 0.) {
+ return 0;
+ }
+ if (lsame_(side, "L")) {
+
+/* Form H * C, where H has order m. */
+
+ switch (*m) {
+ case 1: goto L10;
+ case 2: goto L30;
+ case 3: goto L50;
+ case 4: goto L70;
+ case 5: goto L90;
+ case 6: goto L110;
+ case 7: goto L130;
+ case 8: goto L150;
+ case 9: goto L170;
+ case 10: goto L190;
+ }
+
+/* Code for general M */
+
+ zlarf_(side, m, n, &v[1], &c__1, tau, &c__[c_offset], ldc, &work[1]);
+ goto L410;
+L10:
+
+/* Special code for 1 x 1 Householder */
+
+ z__3.r = tau->r * v[1].r - tau->i * v[1].i, z__3.i = tau->r * v[1].i
+ + tau->i * v[1].r;
+ d_cnjg(&z__4, &v[1]);
+ z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r * z__4.i
+ + z__3.i * z__4.r;
+ z__1.r = 1. - z__2.r, z__1.i = 0. - z__2.i;
+ t1.r = z__1.r, t1.i = z__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j * c_dim1 + 1;
+ i__3 = j * c_dim1 + 1;
+ z__1.r = t1.r * c__[i__3].r - t1.i * c__[i__3].i, z__1.i = t1.r *
+ c__[i__3].i + t1.i * c__[i__3].r;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+/* L20: */
+ }
+ goto L410;
+L30:
+
+/* Special code for 2 x 2 Householder */
+
+ d_cnjg(&z__1, &v[1]);
+ v1.r = z__1.r, v1.i = z__1.i;
+ d_cnjg(&z__2, &v1);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t1.r = z__1.r, t1.i = z__1.i;
+ d_cnjg(&z__1, &v[2]);
+ v2.r = z__1.r, v2.i = z__1.i;
+ d_cnjg(&z__2, &v2);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t2.r = z__1.r, t2.i = z__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j * c_dim1 + 1;
+ z__2.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__2.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j * c_dim1 + 2;
+ z__3.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__3.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ sum.r = z__1.r, sum.i = z__1.i;
+ i__2 = j * c_dim1 + 1;
+ i__3 = j * c_dim1 + 1;
+ z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 2;
+ i__3 = j * c_dim1 + 2;
+ z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+/* L40: */
+ }
+ goto L410;
+L50:
+
+/* Special code for 3 x 3 Householder */
+
+ d_cnjg(&z__1, &v[1]);
+ v1.r = z__1.r, v1.i = z__1.i;
+ d_cnjg(&z__2, &v1);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t1.r = z__1.r, t1.i = z__1.i;
+ d_cnjg(&z__1, &v[2]);
+ v2.r = z__1.r, v2.i = z__1.i;
+ d_cnjg(&z__2, &v2);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t2.r = z__1.r, t2.i = z__1.i;
+ d_cnjg(&z__1, &v[3]);
+ v3.r = z__1.r, v3.i = z__1.i;
+ d_cnjg(&z__2, &v3);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t3.r = z__1.r, t3.i = z__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j * c_dim1 + 1;
+ z__3.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__3.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j * c_dim1 + 2;
+ z__4.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__4.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
+ i__4 = j * c_dim1 + 3;
+ z__5.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__5.i = v3.r *
+ c__[i__4].i + v3.i * c__[i__4].r;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+ sum.r = z__1.r, sum.i = z__1.i;
+ i__2 = j * c_dim1 + 1;
+ i__3 = j * c_dim1 + 1;
+ z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 2;
+ i__3 = j * c_dim1 + 2;
+ z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 3;
+ i__3 = j * c_dim1 + 3;
+ z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+/* L60: */
+ }
+ goto L410;
+L70:
+
+/* Special code for 4 x 4 Householder */
+
+ d_cnjg(&z__1, &v[1]);
+ v1.r = z__1.r, v1.i = z__1.i;
+ d_cnjg(&z__2, &v1);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t1.r = z__1.r, t1.i = z__1.i;
+ d_cnjg(&z__1, &v[2]);
+ v2.r = z__1.r, v2.i = z__1.i;
+ d_cnjg(&z__2, &v2);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t2.r = z__1.r, t2.i = z__1.i;
+ d_cnjg(&z__1, &v[3]);
+ v3.r = z__1.r, v3.i = z__1.i;
+ d_cnjg(&z__2, &v3);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t3.r = z__1.r, t3.i = z__1.i;
+ d_cnjg(&z__1, &v[4]);
+ v4.r = z__1.r, v4.i = z__1.i;
+ d_cnjg(&z__2, &v4);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t4.r = z__1.r, t4.i = z__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j * c_dim1 + 1;
+ z__4.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__4.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j * c_dim1 + 2;
+ z__5.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__5.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
+ i__4 = j * c_dim1 + 3;
+ z__6.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__6.i = v3.r *
+ c__[i__4].i + v3.i * c__[i__4].r;
+ z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
+ i__5 = j * c_dim1 + 4;
+ z__7.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__7.i = v4.r *
+ c__[i__5].i + v4.i * c__[i__5].r;
+ z__1.r = z__2.r + z__7.r, z__1.i = z__2.i + z__7.i;
+ sum.r = z__1.r, sum.i = z__1.i;
+ i__2 = j * c_dim1 + 1;
+ i__3 = j * c_dim1 + 1;
+ z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 2;
+ i__3 = j * c_dim1 + 2;
+ z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 3;
+ i__3 = j * c_dim1 + 3;
+ z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 4;
+ i__3 = j * c_dim1 + 4;
+ z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+/* L80: */
+ }
+ goto L410;
+L90:
+
+/* Special code for 5 x 5 Householder */
+
+ d_cnjg(&z__1, &v[1]);
+ v1.r = z__1.r, v1.i = z__1.i;
+ d_cnjg(&z__2, &v1);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t1.r = z__1.r, t1.i = z__1.i;
+ d_cnjg(&z__1, &v[2]);
+ v2.r = z__1.r, v2.i = z__1.i;
+ d_cnjg(&z__2, &v2);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t2.r = z__1.r, t2.i = z__1.i;
+ d_cnjg(&z__1, &v[3]);
+ v3.r = z__1.r, v3.i = z__1.i;
+ d_cnjg(&z__2, &v3);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t3.r = z__1.r, t3.i = z__1.i;
+ d_cnjg(&z__1, &v[4]);
+ v4.r = z__1.r, v4.i = z__1.i;
+ d_cnjg(&z__2, &v4);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t4.r = z__1.r, t4.i = z__1.i;
+ d_cnjg(&z__1, &v[5]);
+ v5.r = z__1.r, v5.i = z__1.i;
+ d_cnjg(&z__2, &v5);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t5.r = z__1.r, t5.i = z__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j * c_dim1 + 1;
+ z__5.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__5.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j * c_dim1 + 2;
+ z__6.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__6.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
+ i__4 = j * c_dim1 + 3;
+ z__7.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__7.i = v3.r *
+ c__[i__4].i + v3.i * c__[i__4].r;
+ z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
+ i__5 = j * c_dim1 + 4;
+ z__8.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__8.i = v4.r *
+ c__[i__5].i + v4.i * c__[i__5].r;
+ z__2.r = z__3.r + z__8.r, z__2.i = z__3.i + z__8.i;
+ i__6 = j * c_dim1 + 5;
+ z__9.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__9.i = v5.r *
+ c__[i__6].i + v5.i * c__[i__6].r;
+ z__1.r = z__2.r + z__9.r, z__1.i = z__2.i + z__9.i;
+ sum.r = z__1.r, sum.i = z__1.i;
+ i__2 = j * c_dim1 + 1;
+ i__3 = j * c_dim1 + 1;
+ z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 2;
+ i__3 = j * c_dim1 + 2;
+ z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 3;
+ i__3 = j * c_dim1 + 3;
+ z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 4;
+ i__3 = j * c_dim1 + 4;
+ z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 5;
+ i__3 = j * c_dim1 + 5;
+ z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+/* L100: */
+ }
+ goto L410;
+L110:
+
+/* Special code for 6 x 6 Householder */
+
+ d_cnjg(&z__1, &v[1]);
+ v1.r = z__1.r, v1.i = z__1.i;
+ d_cnjg(&z__2, &v1);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t1.r = z__1.r, t1.i = z__1.i;
+ d_cnjg(&z__1, &v[2]);
+ v2.r = z__1.r, v2.i = z__1.i;
+ d_cnjg(&z__2, &v2);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t2.r = z__1.r, t2.i = z__1.i;
+ d_cnjg(&z__1, &v[3]);
+ v3.r = z__1.r, v3.i = z__1.i;
+ d_cnjg(&z__2, &v3);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t3.r = z__1.r, t3.i = z__1.i;
+ d_cnjg(&z__1, &v[4]);
+ v4.r = z__1.r, v4.i = z__1.i;
+ d_cnjg(&z__2, &v4);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t4.r = z__1.r, t4.i = z__1.i;
+ d_cnjg(&z__1, &v[5]);
+ v5.r = z__1.r, v5.i = z__1.i;
+ d_cnjg(&z__2, &v5);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t5.r = z__1.r, t5.i = z__1.i;
+ d_cnjg(&z__1, &v[6]);
+ v6.r = z__1.r, v6.i = z__1.i;
+ d_cnjg(&z__2, &v6);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t6.r = z__1.r, t6.i = z__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j * c_dim1 + 1;
+ z__6.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__6.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j * c_dim1 + 2;
+ z__7.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__7.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ z__5.r = z__6.r + z__7.r, z__5.i = z__6.i + z__7.i;
+ i__4 = j * c_dim1 + 3;
+ z__8.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__8.i = v3.r *
+ c__[i__4].i + v3.i * c__[i__4].r;
+ z__4.r = z__5.r + z__8.r, z__4.i = z__5.i + z__8.i;
+ i__5 = j * c_dim1 + 4;
+ z__9.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__9.i = v4.r *
+ c__[i__5].i + v4.i * c__[i__5].r;
+ z__3.r = z__4.r + z__9.r, z__3.i = z__4.i + z__9.i;
+ i__6 = j * c_dim1 + 5;
+ z__10.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__10.i = v5.r
+ * c__[i__6].i + v5.i * c__[i__6].r;
+ z__2.r = z__3.r + z__10.r, z__2.i = z__3.i + z__10.i;
+ i__7 = j * c_dim1 + 6;
+ z__11.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__11.i = v6.r
+ * c__[i__7].i + v6.i * c__[i__7].r;
+ z__1.r = z__2.r + z__11.r, z__1.i = z__2.i + z__11.i;
+ sum.r = z__1.r, sum.i = z__1.i;
+ i__2 = j * c_dim1 + 1;
+ i__3 = j * c_dim1 + 1;
+ z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 2;
+ i__3 = j * c_dim1 + 2;
+ z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 3;
+ i__3 = j * c_dim1 + 3;
+ z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 4;
+ i__3 = j * c_dim1 + 4;
+ z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 5;
+ i__3 = j * c_dim1 + 5;
+ z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 6;
+ i__3 = j * c_dim1 + 6;
+ z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i +
+ sum.i * t6.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+/* L120: */
+ }
+ goto L410;
+L130:
+
+/* Special code for 7 x 7 Householder */
+
+ d_cnjg(&z__1, &v[1]);
+ v1.r = z__1.r, v1.i = z__1.i;
+ d_cnjg(&z__2, &v1);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t1.r = z__1.r, t1.i = z__1.i;
+ d_cnjg(&z__1, &v[2]);
+ v2.r = z__1.r, v2.i = z__1.i;
+ d_cnjg(&z__2, &v2);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t2.r = z__1.r, t2.i = z__1.i;
+ d_cnjg(&z__1, &v[3]);
+ v3.r = z__1.r, v3.i = z__1.i;
+ d_cnjg(&z__2, &v3);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t3.r = z__1.r, t3.i = z__1.i;
+ d_cnjg(&z__1, &v[4]);
+ v4.r = z__1.r, v4.i = z__1.i;
+ d_cnjg(&z__2, &v4);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t4.r = z__1.r, t4.i = z__1.i;
+ d_cnjg(&z__1, &v[5]);
+ v5.r = z__1.r, v5.i = z__1.i;
+ d_cnjg(&z__2, &v5);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t5.r = z__1.r, t5.i = z__1.i;
+ d_cnjg(&z__1, &v[6]);
+ v6.r = z__1.r, v6.i = z__1.i;
+ d_cnjg(&z__2, &v6);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t6.r = z__1.r, t6.i = z__1.i;
+ d_cnjg(&z__1, &v[7]);
+ v7.r = z__1.r, v7.i = z__1.i;
+ d_cnjg(&z__2, &v7);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t7.r = z__1.r, t7.i = z__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j * c_dim1 + 1;
+ z__7.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__7.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j * c_dim1 + 2;
+ z__8.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__8.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ z__6.r = z__7.r + z__8.r, z__6.i = z__7.i + z__8.i;
+ i__4 = j * c_dim1 + 3;
+ z__9.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__9.i = v3.r *
+ c__[i__4].i + v3.i * c__[i__4].r;
+ z__5.r = z__6.r + z__9.r, z__5.i = z__6.i + z__9.i;
+ i__5 = j * c_dim1 + 4;
+ z__10.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__10.i = v4.r
+ * c__[i__5].i + v4.i * c__[i__5].r;
+ z__4.r = z__5.r + z__10.r, z__4.i = z__5.i + z__10.i;
+ i__6 = j * c_dim1 + 5;
+ z__11.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__11.i = v5.r
+ * c__[i__6].i + v5.i * c__[i__6].r;
+ z__3.r = z__4.r + z__11.r, z__3.i = z__4.i + z__11.i;
+ i__7 = j * c_dim1 + 6;
+ z__12.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__12.i = v6.r
+ * c__[i__7].i + v6.i * c__[i__7].r;
+ z__2.r = z__3.r + z__12.r, z__2.i = z__3.i + z__12.i;
+ i__8 = j * c_dim1 + 7;
+ z__13.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__13.i = v7.r
+ * c__[i__8].i + v7.i * c__[i__8].r;
+ z__1.r = z__2.r + z__13.r, z__1.i = z__2.i + z__13.i;
+ sum.r = z__1.r, sum.i = z__1.i;
+ i__2 = j * c_dim1 + 1;
+ i__3 = j * c_dim1 + 1;
+ z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 2;
+ i__3 = j * c_dim1 + 2;
+ z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 3;
+ i__3 = j * c_dim1 + 3;
+ z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 4;
+ i__3 = j * c_dim1 + 4;
+ z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 5;
+ i__3 = j * c_dim1 + 5;
+ z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 6;
+ i__3 = j * c_dim1 + 6;
+ z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i +
+ sum.i * t6.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 7;
+ i__3 = j * c_dim1 + 7;
+ z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i +
+ sum.i * t7.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+/* L140: */
+ }
+ goto L410;
+L150:
+
+/* Special code for 8 x 8 Householder */
+
+ d_cnjg(&z__1, &v[1]);
+ v1.r = z__1.r, v1.i = z__1.i;
+ d_cnjg(&z__2, &v1);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t1.r = z__1.r, t1.i = z__1.i;
+ d_cnjg(&z__1, &v[2]);
+ v2.r = z__1.r, v2.i = z__1.i;
+ d_cnjg(&z__2, &v2);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t2.r = z__1.r, t2.i = z__1.i;
+ d_cnjg(&z__1, &v[3]);
+ v3.r = z__1.r, v3.i = z__1.i;
+ d_cnjg(&z__2, &v3);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t3.r = z__1.r, t3.i = z__1.i;
+ d_cnjg(&z__1, &v[4]);
+ v4.r = z__1.r, v4.i = z__1.i;
+ d_cnjg(&z__2, &v4);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t4.r = z__1.r, t4.i = z__1.i;
+ d_cnjg(&z__1, &v[5]);
+ v5.r = z__1.r, v5.i = z__1.i;
+ d_cnjg(&z__2, &v5);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t5.r = z__1.r, t5.i = z__1.i;
+ d_cnjg(&z__1, &v[6]);
+ v6.r = z__1.r, v6.i = z__1.i;
+ d_cnjg(&z__2, &v6);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t6.r = z__1.r, t6.i = z__1.i;
+ d_cnjg(&z__1, &v[7]);
+ v7.r = z__1.r, v7.i = z__1.i;
+ d_cnjg(&z__2, &v7);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t7.r = z__1.r, t7.i = z__1.i;
+ d_cnjg(&z__1, &v[8]);
+ v8.r = z__1.r, v8.i = z__1.i;
+ d_cnjg(&z__2, &v8);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t8.r = z__1.r, t8.i = z__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j * c_dim1 + 1;
+ z__8.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__8.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j * c_dim1 + 2;
+ z__9.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__9.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ z__7.r = z__8.r + z__9.r, z__7.i = z__8.i + z__9.i;
+ i__4 = j * c_dim1 + 3;
+ z__10.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__10.i = v3.r
+ * c__[i__4].i + v3.i * c__[i__4].r;
+ z__6.r = z__7.r + z__10.r, z__6.i = z__7.i + z__10.i;
+ i__5 = j * c_dim1 + 4;
+ z__11.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__11.i = v4.r
+ * c__[i__5].i + v4.i * c__[i__5].r;
+ z__5.r = z__6.r + z__11.r, z__5.i = z__6.i + z__11.i;
+ i__6 = j * c_dim1 + 5;
+ z__12.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__12.i = v5.r
+ * c__[i__6].i + v5.i * c__[i__6].r;
+ z__4.r = z__5.r + z__12.r, z__4.i = z__5.i + z__12.i;
+ i__7 = j * c_dim1 + 6;
+ z__13.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__13.i = v6.r
+ * c__[i__7].i + v6.i * c__[i__7].r;
+ z__3.r = z__4.r + z__13.r, z__3.i = z__4.i + z__13.i;
+ i__8 = j * c_dim1 + 7;
+ z__14.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__14.i = v7.r
+ * c__[i__8].i + v7.i * c__[i__8].r;
+ z__2.r = z__3.r + z__14.r, z__2.i = z__3.i + z__14.i;
+ i__9 = j * c_dim1 + 8;
+ z__15.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__15.i = v8.r
+ * c__[i__9].i + v8.i * c__[i__9].r;
+ z__1.r = z__2.r + z__15.r, z__1.i = z__2.i + z__15.i;
+ sum.r = z__1.r, sum.i = z__1.i;
+ i__2 = j * c_dim1 + 1;
+ i__3 = j * c_dim1 + 1;
+ z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 2;
+ i__3 = j * c_dim1 + 2;
+ z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 3;
+ i__3 = j * c_dim1 + 3;
+ z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 4;
+ i__3 = j * c_dim1 + 4;
+ z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 5;
+ i__3 = j * c_dim1 + 5;
+ z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 6;
+ i__3 = j * c_dim1 + 6;
+ z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i +
+ sum.i * t6.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 7;
+ i__3 = j * c_dim1 + 7;
+ z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i +
+ sum.i * t7.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 8;
+ i__3 = j * c_dim1 + 8;
+ z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i +
+ sum.i * t8.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+/* L160: */
+ }
+ goto L410;
+L170:
+
+/* Special code for 9 x 9 Householder */
+
+ d_cnjg(&z__1, &v[1]);
+ v1.r = z__1.r, v1.i = z__1.i;
+ d_cnjg(&z__2, &v1);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t1.r = z__1.r, t1.i = z__1.i;
+ d_cnjg(&z__1, &v[2]);
+ v2.r = z__1.r, v2.i = z__1.i;
+ d_cnjg(&z__2, &v2);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t2.r = z__1.r, t2.i = z__1.i;
+ d_cnjg(&z__1, &v[3]);
+ v3.r = z__1.r, v3.i = z__1.i;
+ d_cnjg(&z__2, &v3);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t3.r = z__1.r, t3.i = z__1.i;
+ d_cnjg(&z__1, &v[4]);
+ v4.r = z__1.r, v4.i = z__1.i;
+ d_cnjg(&z__2, &v4);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t4.r = z__1.r, t4.i = z__1.i;
+ d_cnjg(&z__1, &v[5]);
+ v5.r = z__1.r, v5.i = z__1.i;
+ d_cnjg(&z__2, &v5);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t5.r = z__1.r, t5.i = z__1.i;
+ d_cnjg(&z__1, &v[6]);
+ v6.r = z__1.r, v6.i = z__1.i;
+ d_cnjg(&z__2, &v6);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t6.r = z__1.r, t6.i = z__1.i;
+ d_cnjg(&z__1, &v[7]);
+ v7.r = z__1.r, v7.i = z__1.i;
+ d_cnjg(&z__2, &v7);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t7.r = z__1.r, t7.i = z__1.i;
+ d_cnjg(&z__1, &v[8]);
+ v8.r = z__1.r, v8.i = z__1.i;
+ d_cnjg(&z__2, &v8);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t8.r = z__1.r, t8.i = z__1.i;
+ d_cnjg(&z__1, &v[9]);
+ v9.r = z__1.r, v9.i = z__1.i;
+ d_cnjg(&z__2, &v9);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t9.r = z__1.r, t9.i = z__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j * c_dim1 + 1;
+ z__9.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__9.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j * c_dim1 + 2;
+ z__10.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__10.i = v2.r
+ * c__[i__3].i + v2.i * c__[i__3].r;
+ z__8.r = z__9.r + z__10.r, z__8.i = z__9.i + z__10.i;
+ i__4 = j * c_dim1 + 3;
+ z__11.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__11.i = v3.r
+ * c__[i__4].i + v3.i * c__[i__4].r;
+ z__7.r = z__8.r + z__11.r, z__7.i = z__8.i + z__11.i;
+ i__5 = j * c_dim1 + 4;
+ z__12.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__12.i = v4.r
+ * c__[i__5].i + v4.i * c__[i__5].r;
+ z__6.r = z__7.r + z__12.r, z__6.i = z__7.i + z__12.i;
+ i__6 = j * c_dim1 + 5;
+ z__13.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__13.i = v5.r
+ * c__[i__6].i + v5.i * c__[i__6].r;
+ z__5.r = z__6.r + z__13.r, z__5.i = z__6.i + z__13.i;
+ i__7 = j * c_dim1 + 6;
+ z__14.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__14.i = v6.r
+ * c__[i__7].i + v6.i * c__[i__7].r;
+ z__4.r = z__5.r + z__14.r, z__4.i = z__5.i + z__14.i;
+ i__8 = j * c_dim1 + 7;
+ z__15.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__15.i = v7.r
+ * c__[i__8].i + v7.i * c__[i__8].r;
+ z__3.r = z__4.r + z__15.r, z__3.i = z__4.i + z__15.i;
+ i__9 = j * c_dim1 + 8;
+ z__16.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__16.i = v8.r
+ * c__[i__9].i + v8.i * c__[i__9].r;
+ z__2.r = z__3.r + z__16.r, z__2.i = z__3.i + z__16.i;
+ i__10 = j * c_dim1 + 9;
+ z__17.r = v9.r * c__[i__10].r - v9.i * c__[i__10].i, z__17.i =
+ v9.r * c__[i__10].i + v9.i * c__[i__10].r;
+ z__1.r = z__2.r + z__17.r, z__1.i = z__2.i + z__17.i;
+ sum.r = z__1.r, sum.i = z__1.i;
+ i__2 = j * c_dim1 + 1;
+ i__3 = j * c_dim1 + 1;
+ z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 2;
+ i__3 = j * c_dim1 + 2;
+ z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 3;
+ i__3 = j * c_dim1 + 3;
+ z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 4;
+ i__3 = j * c_dim1 + 4;
+ z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 5;
+ i__3 = j * c_dim1 + 5;
+ z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 6;
+ i__3 = j * c_dim1 + 6;
+ z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i +
+ sum.i * t6.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 7;
+ i__3 = j * c_dim1 + 7;
+ z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i +
+ sum.i * t7.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 8;
+ i__3 = j * c_dim1 + 8;
+ z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i +
+ sum.i * t8.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 9;
+ i__3 = j * c_dim1 + 9;
+ z__2.r = sum.r * t9.r - sum.i * t9.i, z__2.i = sum.r * t9.i +
+ sum.i * t9.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+/* L180: */
+ }
+ goto L410;
+L190:
+
+/* Special code for 10 x 10 Householder */
+
+ d_cnjg(&z__1, &v[1]);
+ v1.r = z__1.r, v1.i = z__1.i;
+ d_cnjg(&z__2, &v1);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t1.r = z__1.r, t1.i = z__1.i;
+ d_cnjg(&z__1, &v[2]);
+ v2.r = z__1.r, v2.i = z__1.i;
+ d_cnjg(&z__2, &v2);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t2.r = z__1.r, t2.i = z__1.i;
+ d_cnjg(&z__1, &v[3]);
+ v3.r = z__1.r, v3.i = z__1.i;
+ d_cnjg(&z__2, &v3);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t3.r = z__1.r, t3.i = z__1.i;
+ d_cnjg(&z__1, &v[4]);
+ v4.r = z__1.r, v4.i = z__1.i;
+ d_cnjg(&z__2, &v4);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t4.r = z__1.r, t4.i = z__1.i;
+ d_cnjg(&z__1, &v[5]);
+ v5.r = z__1.r, v5.i = z__1.i;
+ d_cnjg(&z__2, &v5);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t5.r = z__1.r, t5.i = z__1.i;
+ d_cnjg(&z__1, &v[6]);
+ v6.r = z__1.r, v6.i = z__1.i;
+ d_cnjg(&z__2, &v6);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t6.r = z__1.r, t6.i = z__1.i;
+ d_cnjg(&z__1, &v[7]);
+ v7.r = z__1.r, v7.i = z__1.i;
+ d_cnjg(&z__2, &v7);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t7.r = z__1.r, t7.i = z__1.i;
+ d_cnjg(&z__1, &v[8]);
+ v8.r = z__1.r, v8.i = z__1.i;
+ d_cnjg(&z__2, &v8);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t8.r = z__1.r, t8.i = z__1.i;
+ d_cnjg(&z__1, &v[9]);
+ v9.r = z__1.r, v9.i = z__1.i;
+ d_cnjg(&z__2, &v9);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t9.r = z__1.r, t9.i = z__1.i;
+ d_cnjg(&z__1, &v[10]);
+ v10.r = z__1.r, v10.i = z__1.i;
+ d_cnjg(&z__2, &v10);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t10.r = z__1.r, t10.i = z__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j * c_dim1 + 1;
+ z__10.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__10.i = v1.r
+ * c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j * c_dim1 + 2;
+ z__11.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__11.i = v2.r
+ * c__[i__3].i + v2.i * c__[i__3].r;
+ z__9.r = z__10.r + z__11.r, z__9.i = z__10.i + z__11.i;
+ i__4 = j * c_dim1 + 3;
+ z__12.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__12.i = v3.r
+ * c__[i__4].i + v3.i * c__[i__4].r;
+ z__8.r = z__9.r + z__12.r, z__8.i = z__9.i + z__12.i;
+ i__5 = j * c_dim1 + 4;
+ z__13.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__13.i = v4.r
+ * c__[i__5].i + v4.i * c__[i__5].r;
+ z__7.r = z__8.r + z__13.r, z__7.i = z__8.i + z__13.i;
+ i__6 = j * c_dim1 + 5;
+ z__14.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__14.i = v5.r
+ * c__[i__6].i + v5.i * c__[i__6].r;
+ z__6.r = z__7.r + z__14.r, z__6.i = z__7.i + z__14.i;
+ i__7 = j * c_dim1 + 6;
+ z__15.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__15.i = v6.r
+ * c__[i__7].i + v6.i * c__[i__7].r;
+ z__5.r = z__6.r + z__15.r, z__5.i = z__6.i + z__15.i;
+ i__8 = j * c_dim1 + 7;
+ z__16.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__16.i = v7.r
+ * c__[i__8].i + v7.i * c__[i__8].r;
+ z__4.r = z__5.r + z__16.r, z__4.i = z__5.i + z__16.i;
+ i__9 = j * c_dim1 + 8;
+ z__17.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__17.i = v8.r
+ * c__[i__9].i + v8.i * c__[i__9].r;
+ z__3.r = z__4.r + z__17.r, z__3.i = z__4.i + z__17.i;
+ i__10 = j * c_dim1 + 9;
+ z__18.r = v9.r * c__[i__10].r - v9.i * c__[i__10].i, z__18.i =
+ v9.r * c__[i__10].i + v9.i * c__[i__10].r;
+ z__2.r = z__3.r + z__18.r, z__2.i = z__3.i + z__18.i;
+ i__11 = j * c_dim1 + 10;
+ z__19.r = v10.r * c__[i__11].r - v10.i * c__[i__11].i, z__19.i =
+ v10.r * c__[i__11].i + v10.i * c__[i__11].r;
+ z__1.r = z__2.r + z__19.r, z__1.i = z__2.i + z__19.i;
+ sum.r = z__1.r, sum.i = z__1.i;
+ i__2 = j * c_dim1 + 1;
+ i__3 = j * c_dim1 + 1;
+ z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 2;
+ i__3 = j * c_dim1 + 2;
+ z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 3;
+ i__3 = j * c_dim1 + 3;
+ z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 4;
+ i__3 = j * c_dim1 + 4;
+ z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 5;
+ i__3 = j * c_dim1 + 5;
+ z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 6;
+ i__3 = j * c_dim1 + 6;
+ z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i +
+ sum.i * t6.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 7;
+ i__3 = j * c_dim1 + 7;
+ z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i +
+ sum.i * t7.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 8;
+ i__3 = j * c_dim1 + 8;
+ z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i +
+ sum.i * t8.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 9;
+ i__3 = j * c_dim1 + 9;
+ z__2.r = sum.r * t9.r - sum.i * t9.i, z__2.i = sum.r * t9.i +
+ sum.i * t9.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j * c_dim1 + 10;
+ i__3 = j * c_dim1 + 10;
+ z__2.r = sum.r * t10.r - sum.i * t10.i, z__2.i = sum.r * t10.i +
+ sum.i * t10.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+/* L200: */
+ }
+ goto L410;
+ } else {
+
+/* Form C * H, where H has order n. */
+
+ switch (*n) {
+ case 1: goto L210;
+ case 2: goto L230;
+ case 3: goto L250;
+ case 4: goto L270;
+ case 5: goto L290;
+ case 6: goto L310;
+ case 7: goto L330;
+ case 8: goto L350;
+ case 9: goto L370;
+ case 10: goto L390;
+ }
+
+/* Code for general N */
+
+ zlarf_(side, m, n, &v[1], &c__1, tau, &c__[c_offset], ldc, &work[1]);
+ goto L410;
+L210:
+
+/* Special code for 1 x 1 Householder */
+
+ z__3.r = tau->r * v[1].r - tau->i * v[1].i, z__3.i = tau->r * v[1].i
+ + tau->i * v[1].r;
+ d_cnjg(&z__4, &v[1]);
+ z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r * z__4.i
+ + z__3.i * z__4.r;
+ z__1.r = 1. - z__2.r, z__1.i = 0. - z__2.i;
+ t1.r = z__1.r, t1.i = z__1.i;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + c_dim1;
+ i__3 = j + c_dim1;
+ z__1.r = t1.r * c__[i__3].r - t1.i * c__[i__3].i, z__1.i = t1.r *
+ c__[i__3].i + t1.i * c__[i__3].r;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+/* L220: */
+ }
+ goto L410;
+L230:
+
+/* Special code for 2 x 2 Householder */
+
+ v1.r = v[1].r, v1.i = v[1].i;
+ d_cnjg(&z__2, &v1);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t1.r = z__1.r, t1.i = z__1.i;
+ v2.r = v[2].r, v2.i = v[2].i;
+ d_cnjg(&z__2, &v2);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t2.r = z__1.r, t2.i = z__1.i;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + c_dim1;
+ z__2.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__2.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j + (c_dim1 << 1);
+ z__3.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__3.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ sum.r = z__1.r, sum.i = z__1.i;
+ i__2 = j + c_dim1;
+ i__3 = j + c_dim1;
+ z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + (c_dim1 << 1);
+ i__3 = j + (c_dim1 << 1);
+ z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+/* L240: */
+ }
+ goto L410;
+L250:
+
+/* Special code for 3 x 3 Householder */
+
+ v1.r = v[1].r, v1.i = v[1].i;
+ d_cnjg(&z__2, &v1);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t1.r = z__1.r, t1.i = z__1.i;
+ v2.r = v[2].r, v2.i = v[2].i;
+ d_cnjg(&z__2, &v2);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t2.r = z__1.r, t2.i = z__1.i;
+ v3.r = v[3].r, v3.i = v[3].i;
+ d_cnjg(&z__2, &v3);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t3.r = z__1.r, t3.i = z__1.i;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + c_dim1;
+ z__3.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__3.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j + (c_dim1 << 1);
+ z__4.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__4.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
+ i__4 = j + c_dim1 * 3;
+ z__5.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__5.i = v3.r *
+ c__[i__4].i + v3.i * c__[i__4].r;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+ sum.r = z__1.r, sum.i = z__1.i;
+ i__2 = j + c_dim1;
+ i__3 = j + c_dim1;
+ z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + (c_dim1 << 1);
+ i__3 = j + (c_dim1 << 1);
+ z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 3;
+ i__3 = j + c_dim1 * 3;
+ z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+/* L260: */
+ }
+ goto L410;
+L270:
+
+/* Special code for 4 x 4 Householder */
+
+ v1.r = v[1].r, v1.i = v[1].i;
+ d_cnjg(&z__2, &v1);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t1.r = z__1.r, t1.i = z__1.i;
+ v2.r = v[2].r, v2.i = v[2].i;
+ d_cnjg(&z__2, &v2);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t2.r = z__1.r, t2.i = z__1.i;
+ v3.r = v[3].r, v3.i = v[3].i;
+ d_cnjg(&z__2, &v3);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t3.r = z__1.r, t3.i = z__1.i;
+ v4.r = v[4].r, v4.i = v[4].i;
+ d_cnjg(&z__2, &v4);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t4.r = z__1.r, t4.i = z__1.i;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + c_dim1;
+ z__4.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__4.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j + (c_dim1 << 1);
+ z__5.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__5.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
+ i__4 = j + c_dim1 * 3;
+ z__6.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__6.i = v3.r *
+ c__[i__4].i + v3.i * c__[i__4].r;
+ z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
+ i__5 = j + (c_dim1 << 2);
+ z__7.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__7.i = v4.r *
+ c__[i__5].i + v4.i * c__[i__5].r;
+ z__1.r = z__2.r + z__7.r, z__1.i = z__2.i + z__7.i;
+ sum.r = z__1.r, sum.i = z__1.i;
+ i__2 = j + c_dim1;
+ i__3 = j + c_dim1;
+ z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + (c_dim1 << 1);
+ i__3 = j + (c_dim1 << 1);
+ z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 3;
+ i__3 = j + c_dim1 * 3;
+ z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + (c_dim1 << 2);
+ i__3 = j + (c_dim1 << 2);
+ z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+/* L280: */
+ }
+ goto L410;
+L290:
+
+/* Special code for 5 x 5 Householder */
+
+ v1.r = v[1].r, v1.i = v[1].i;
+ d_cnjg(&z__2, &v1);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t1.r = z__1.r, t1.i = z__1.i;
+ v2.r = v[2].r, v2.i = v[2].i;
+ d_cnjg(&z__2, &v2);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t2.r = z__1.r, t2.i = z__1.i;
+ v3.r = v[3].r, v3.i = v[3].i;
+ d_cnjg(&z__2, &v3);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t3.r = z__1.r, t3.i = z__1.i;
+ v4.r = v[4].r, v4.i = v[4].i;
+ d_cnjg(&z__2, &v4);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t4.r = z__1.r, t4.i = z__1.i;
+ v5.r = v[5].r, v5.i = v[5].i;
+ d_cnjg(&z__2, &v5);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t5.r = z__1.r, t5.i = z__1.i;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + c_dim1;
+ z__5.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__5.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j + (c_dim1 << 1);
+ z__6.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__6.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
+ i__4 = j + c_dim1 * 3;
+ z__7.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__7.i = v3.r *
+ c__[i__4].i + v3.i * c__[i__4].r;
+ z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
+ i__5 = j + (c_dim1 << 2);
+ z__8.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__8.i = v4.r *
+ c__[i__5].i + v4.i * c__[i__5].r;
+ z__2.r = z__3.r + z__8.r, z__2.i = z__3.i + z__8.i;
+ i__6 = j + c_dim1 * 5;
+ z__9.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__9.i = v5.r *
+ c__[i__6].i + v5.i * c__[i__6].r;
+ z__1.r = z__2.r + z__9.r, z__1.i = z__2.i + z__9.i;
+ sum.r = z__1.r, sum.i = z__1.i;
+ i__2 = j + c_dim1;
+ i__3 = j + c_dim1;
+ z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + (c_dim1 << 1);
+ i__3 = j + (c_dim1 << 1);
+ z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 3;
+ i__3 = j + c_dim1 * 3;
+ z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + (c_dim1 << 2);
+ i__3 = j + (c_dim1 << 2);
+ z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 5;
+ i__3 = j + c_dim1 * 5;
+ z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+/* L300: */
+ }
+ goto L410;
+L310:
+
+/* Special code for 6 x 6 Householder */
+
+ v1.r = v[1].r, v1.i = v[1].i;
+ d_cnjg(&z__2, &v1);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t1.r = z__1.r, t1.i = z__1.i;
+ v2.r = v[2].r, v2.i = v[2].i;
+ d_cnjg(&z__2, &v2);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t2.r = z__1.r, t2.i = z__1.i;
+ v3.r = v[3].r, v3.i = v[3].i;
+ d_cnjg(&z__2, &v3);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t3.r = z__1.r, t3.i = z__1.i;
+ v4.r = v[4].r, v4.i = v[4].i;
+ d_cnjg(&z__2, &v4);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t4.r = z__1.r, t4.i = z__1.i;
+ v5.r = v[5].r, v5.i = v[5].i;
+ d_cnjg(&z__2, &v5);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t5.r = z__1.r, t5.i = z__1.i;
+ v6.r = v[6].r, v6.i = v[6].i;
+ d_cnjg(&z__2, &v6);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t6.r = z__1.r, t6.i = z__1.i;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + c_dim1;
+ z__6.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__6.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j + (c_dim1 << 1);
+ z__7.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__7.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ z__5.r = z__6.r + z__7.r, z__5.i = z__6.i + z__7.i;
+ i__4 = j + c_dim1 * 3;
+ z__8.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__8.i = v3.r *
+ c__[i__4].i + v3.i * c__[i__4].r;
+ z__4.r = z__5.r + z__8.r, z__4.i = z__5.i + z__8.i;
+ i__5 = j + (c_dim1 << 2);
+ z__9.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__9.i = v4.r *
+ c__[i__5].i + v4.i * c__[i__5].r;
+ z__3.r = z__4.r + z__9.r, z__3.i = z__4.i + z__9.i;
+ i__6 = j + c_dim1 * 5;
+ z__10.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__10.i = v5.r
+ * c__[i__6].i + v5.i * c__[i__6].r;
+ z__2.r = z__3.r + z__10.r, z__2.i = z__3.i + z__10.i;
+ i__7 = j + c_dim1 * 6;
+ z__11.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__11.i = v6.r
+ * c__[i__7].i + v6.i * c__[i__7].r;
+ z__1.r = z__2.r + z__11.r, z__1.i = z__2.i + z__11.i;
+ sum.r = z__1.r, sum.i = z__1.i;
+ i__2 = j + c_dim1;
+ i__3 = j + c_dim1;
+ z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + (c_dim1 << 1);
+ i__3 = j + (c_dim1 << 1);
+ z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 3;
+ i__3 = j + c_dim1 * 3;
+ z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + (c_dim1 << 2);
+ i__3 = j + (c_dim1 << 2);
+ z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 5;
+ i__3 = j + c_dim1 * 5;
+ z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 6;
+ i__3 = j + c_dim1 * 6;
+ z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i +
+ sum.i * t6.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+/* L320: */
+ }
+ goto L410;
+L330:
+
+/* Special code for 7 x 7 Householder */
+
+ v1.r = v[1].r, v1.i = v[1].i;
+ d_cnjg(&z__2, &v1);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t1.r = z__1.r, t1.i = z__1.i;
+ v2.r = v[2].r, v2.i = v[2].i;
+ d_cnjg(&z__2, &v2);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t2.r = z__1.r, t2.i = z__1.i;
+ v3.r = v[3].r, v3.i = v[3].i;
+ d_cnjg(&z__2, &v3);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t3.r = z__1.r, t3.i = z__1.i;
+ v4.r = v[4].r, v4.i = v[4].i;
+ d_cnjg(&z__2, &v4);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t4.r = z__1.r, t4.i = z__1.i;
+ v5.r = v[5].r, v5.i = v[5].i;
+ d_cnjg(&z__2, &v5);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t5.r = z__1.r, t5.i = z__1.i;
+ v6.r = v[6].r, v6.i = v[6].i;
+ d_cnjg(&z__2, &v6);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t6.r = z__1.r, t6.i = z__1.i;
+ v7.r = v[7].r, v7.i = v[7].i;
+ d_cnjg(&z__2, &v7);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t7.r = z__1.r, t7.i = z__1.i;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + c_dim1;
+ z__7.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__7.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j + (c_dim1 << 1);
+ z__8.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__8.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ z__6.r = z__7.r + z__8.r, z__6.i = z__7.i + z__8.i;
+ i__4 = j + c_dim1 * 3;
+ z__9.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__9.i = v3.r *
+ c__[i__4].i + v3.i * c__[i__4].r;
+ z__5.r = z__6.r + z__9.r, z__5.i = z__6.i + z__9.i;
+ i__5 = j + (c_dim1 << 2);
+ z__10.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__10.i = v4.r
+ * c__[i__5].i + v4.i * c__[i__5].r;
+ z__4.r = z__5.r + z__10.r, z__4.i = z__5.i + z__10.i;
+ i__6 = j + c_dim1 * 5;
+ z__11.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__11.i = v5.r
+ * c__[i__6].i + v5.i * c__[i__6].r;
+ z__3.r = z__4.r + z__11.r, z__3.i = z__4.i + z__11.i;
+ i__7 = j + c_dim1 * 6;
+ z__12.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__12.i = v6.r
+ * c__[i__7].i + v6.i * c__[i__7].r;
+ z__2.r = z__3.r + z__12.r, z__2.i = z__3.i + z__12.i;
+ i__8 = j + c_dim1 * 7;
+ z__13.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__13.i = v7.r
+ * c__[i__8].i + v7.i * c__[i__8].r;
+ z__1.r = z__2.r + z__13.r, z__1.i = z__2.i + z__13.i;
+ sum.r = z__1.r, sum.i = z__1.i;
+ i__2 = j + c_dim1;
+ i__3 = j + c_dim1;
+ z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + (c_dim1 << 1);
+ i__3 = j + (c_dim1 << 1);
+ z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 3;
+ i__3 = j + c_dim1 * 3;
+ z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + (c_dim1 << 2);
+ i__3 = j + (c_dim1 << 2);
+ z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 5;
+ i__3 = j + c_dim1 * 5;
+ z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 6;
+ i__3 = j + c_dim1 * 6;
+ z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i +
+ sum.i * t6.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 7;
+ i__3 = j + c_dim1 * 7;
+ z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i +
+ sum.i * t7.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+/* L340: */
+ }
+ goto L410;
+L350:
+
+/* Special code for 8 x 8 Householder */
+
+ v1.r = v[1].r, v1.i = v[1].i;
+ d_cnjg(&z__2, &v1);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t1.r = z__1.r, t1.i = z__1.i;
+ v2.r = v[2].r, v2.i = v[2].i;
+ d_cnjg(&z__2, &v2);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t2.r = z__1.r, t2.i = z__1.i;
+ v3.r = v[3].r, v3.i = v[3].i;
+ d_cnjg(&z__2, &v3);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t3.r = z__1.r, t3.i = z__1.i;
+ v4.r = v[4].r, v4.i = v[4].i;
+ d_cnjg(&z__2, &v4);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t4.r = z__1.r, t4.i = z__1.i;
+ v5.r = v[5].r, v5.i = v[5].i;
+ d_cnjg(&z__2, &v5);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t5.r = z__1.r, t5.i = z__1.i;
+ v6.r = v[6].r, v6.i = v[6].i;
+ d_cnjg(&z__2, &v6);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t6.r = z__1.r, t6.i = z__1.i;
+ v7.r = v[7].r, v7.i = v[7].i;
+ d_cnjg(&z__2, &v7);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t7.r = z__1.r, t7.i = z__1.i;
+ v8.r = v[8].r, v8.i = v[8].i;
+ d_cnjg(&z__2, &v8);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t8.r = z__1.r, t8.i = z__1.i;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + c_dim1;
+ z__8.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__8.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j + (c_dim1 << 1);
+ z__9.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__9.i = v2.r *
+ c__[i__3].i + v2.i * c__[i__3].r;
+ z__7.r = z__8.r + z__9.r, z__7.i = z__8.i + z__9.i;
+ i__4 = j + c_dim1 * 3;
+ z__10.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__10.i = v3.r
+ * c__[i__4].i + v3.i * c__[i__4].r;
+ z__6.r = z__7.r + z__10.r, z__6.i = z__7.i + z__10.i;
+ i__5 = j + (c_dim1 << 2);
+ z__11.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__11.i = v4.r
+ * c__[i__5].i + v4.i * c__[i__5].r;
+ z__5.r = z__6.r + z__11.r, z__5.i = z__6.i + z__11.i;
+ i__6 = j + c_dim1 * 5;
+ z__12.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__12.i = v5.r
+ * c__[i__6].i + v5.i * c__[i__6].r;
+ z__4.r = z__5.r + z__12.r, z__4.i = z__5.i + z__12.i;
+ i__7 = j + c_dim1 * 6;
+ z__13.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__13.i = v6.r
+ * c__[i__7].i + v6.i * c__[i__7].r;
+ z__3.r = z__4.r + z__13.r, z__3.i = z__4.i + z__13.i;
+ i__8 = j + c_dim1 * 7;
+ z__14.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__14.i = v7.r
+ * c__[i__8].i + v7.i * c__[i__8].r;
+ z__2.r = z__3.r + z__14.r, z__2.i = z__3.i + z__14.i;
+ i__9 = j + (c_dim1 << 3);
+ z__15.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__15.i = v8.r
+ * c__[i__9].i + v8.i * c__[i__9].r;
+ z__1.r = z__2.r + z__15.r, z__1.i = z__2.i + z__15.i;
+ sum.r = z__1.r, sum.i = z__1.i;
+ i__2 = j + c_dim1;
+ i__3 = j + c_dim1;
+ z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + (c_dim1 << 1);
+ i__3 = j + (c_dim1 << 1);
+ z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 3;
+ i__3 = j + c_dim1 * 3;
+ z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + (c_dim1 << 2);
+ i__3 = j + (c_dim1 << 2);
+ z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 5;
+ i__3 = j + c_dim1 * 5;
+ z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 6;
+ i__3 = j + c_dim1 * 6;
+ z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i +
+ sum.i * t6.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 7;
+ i__3 = j + c_dim1 * 7;
+ z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i +
+ sum.i * t7.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + (c_dim1 << 3);
+ i__3 = j + (c_dim1 << 3);
+ z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i +
+ sum.i * t8.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+/* L360: */
+ }
+ goto L410;
+L370:
+
+/* Special code for 9 x 9 Householder */
+
+ v1.r = v[1].r, v1.i = v[1].i;
+ d_cnjg(&z__2, &v1);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t1.r = z__1.r, t1.i = z__1.i;
+ v2.r = v[2].r, v2.i = v[2].i;
+ d_cnjg(&z__2, &v2);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t2.r = z__1.r, t2.i = z__1.i;
+ v3.r = v[3].r, v3.i = v[3].i;
+ d_cnjg(&z__2, &v3);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t3.r = z__1.r, t3.i = z__1.i;
+ v4.r = v[4].r, v4.i = v[4].i;
+ d_cnjg(&z__2, &v4);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t4.r = z__1.r, t4.i = z__1.i;
+ v5.r = v[5].r, v5.i = v[5].i;
+ d_cnjg(&z__2, &v5);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t5.r = z__1.r, t5.i = z__1.i;
+ v6.r = v[6].r, v6.i = v[6].i;
+ d_cnjg(&z__2, &v6);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t6.r = z__1.r, t6.i = z__1.i;
+ v7.r = v[7].r, v7.i = v[7].i;
+ d_cnjg(&z__2, &v7);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t7.r = z__1.r, t7.i = z__1.i;
+ v8.r = v[8].r, v8.i = v[8].i;
+ d_cnjg(&z__2, &v8);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t8.r = z__1.r, t8.i = z__1.i;
+ v9.r = v[9].r, v9.i = v[9].i;
+ d_cnjg(&z__2, &v9);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t9.r = z__1.r, t9.i = z__1.i;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + c_dim1;
+ z__9.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__9.i = v1.r *
+ c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j + (c_dim1 << 1);
+ z__10.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__10.i = v2.r
+ * c__[i__3].i + v2.i * c__[i__3].r;
+ z__8.r = z__9.r + z__10.r, z__8.i = z__9.i + z__10.i;
+ i__4 = j + c_dim1 * 3;
+ z__11.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__11.i = v3.r
+ * c__[i__4].i + v3.i * c__[i__4].r;
+ z__7.r = z__8.r + z__11.r, z__7.i = z__8.i + z__11.i;
+ i__5 = j + (c_dim1 << 2);
+ z__12.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__12.i = v4.r
+ * c__[i__5].i + v4.i * c__[i__5].r;
+ z__6.r = z__7.r + z__12.r, z__6.i = z__7.i + z__12.i;
+ i__6 = j + c_dim1 * 5;
+ z__13.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__13.i = v5.r
+ * c__[i__6].i + v5.i * c__[i__6].r;
+ z__5.r = z__6.r + z__13.r, z__5.i = z__6.i + z__13.i;
+ i__7 = j + c_dim1 * 6;
+ z__14.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__14.i = v6.r
+ * c__[i__7].i + v6.i * c__[i__7].r;
+ z__4.r = z__5.r + z__14.r, z__4.i = z__5.i + z__14.i;
+ i__8 = j + c_dim1 * 7;
+ z__15.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__15.i = v7.r
+ * c__[i__8].i + v7.i * c__[i__8].r;
+ z__3.r = z__4.r + z__15.r, z__3.i = z__4.i + z__15.i;
+ i__9 = j + (c_dim1 << 3);
+ z__16.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__16.i = v8.r
+ * c__[i__9].i + v8.i * c__[i__9].r;
+ z__2.r = z__3.r + z__16.r, z__2.i = z__3.i + z__16.i;
+ i__10 = j + c_dim1 * 9;
+ z__17.r = v9.r * c__[i__10].r - v9.i * c__[i__10].i, z__17.i =
+ v9.r * c__[i__10].i + v9.i * c__[i__10].r;
+ z__1.r = z__2.r + z__17.r, z__1.i = z__2.i + z__17.i;
+ sum.r = z__1.r, sum.i = z__1.i;
+ i__2 = j + c_dim1;
+ i__3 = j + c_dim1;
+ z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + (c_dim1 << 1);
+ i__3 = j + (c_dim1 << 1);
+ z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 3;
+ i__3 = j + c_dim1 * 3;
+ z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + (c_dim1 << 2);
+ i__3 = j + (c_dim1 << 2);
+ z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 5;
+ i__3 = j + c_dim1 * 5;
+ z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 6;
+ i__3 = j + c_dim1 * 6;
+ z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i +
+ sum.i * t6.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 7;
+ i__3 = j + c_dim1 * 7;
+ z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i +
+ sum.i * t7.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + (c_dim1 << 3);
+ i__3 = j + (c_dim1 << 3);
+ z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i +
+ sum.i * t8.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 9;
+ i__3 = j + c_dim1 * 9;
+ z__2.r = sum.r * t9.r - sum.i * t9.i, z__2.i = sum.r * t9.i +
+ sum.i * t9.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+/* L380: */
+ }
+ goto L410;
+L390:
+
+/* Special code for 10 x 10 Householder */
+
+ v1.r = v[1].r, v1.i = v[1].i;
+ d_cnjg(&z__2, &v1);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t1.r = z__1.r, t1.i = z__1.i;
+ v2.r = v[2].r, v2.i = v[2].i;
+ d_cnjg(&z__2, &v2);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t2.r = z__1.r, t2.i = z__1.i;
+ v3.r = v[3].r, v3.i = v[3].i;
+ d_cnjg(&z__2, &v3);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t3.r = z__1.r, t3.i = z__1.i;
+ v4.r = v[4].r, v4.i = v[4].i;
+ d_cnjg(&z__2, &v4);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t4.r = z__1.r, t4.i = z__1.i;
+ v5.r = v[5].r, v5.i = v[5].i;
+ d_cnjg(&z__2, &v5);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t5.r = z__1.r, t5.i = z__1.i;
+ v6.r = v[6].r, v6.i = v[6].i;
+ d_cnjg(&z__2, &v6);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t6.r = z__1.r, t6.i = z__1.i;
+ v7.r = v[7].r, v7.i = v[7].i;
+ d_cnjg(&z__2, &v7);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t7.r = z__1.r, t7.i = z__1.i;
+ v8.r = v[8].r, v8.i = v[8].i;
+ d_cnjg(&z__2, &v8);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t8.r = z__1.r, t8.i = z__1.i;
+ v9.r = v[9].r, v9.i = v[9].i;
+ d_cnjg(&z__2, &v9);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t9.r = z__1.r, t9.i = z__1.i;
+ v10.r = v[10].r, v10.i = v[10].i;
+ d_cnjg(&z__2, &v10);
+ z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i
+ + tau->i * z__2.r;
+ t10.r = z__1.r, t10.i = z__1.i;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + c_dim1;
+ z__10.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__10.i = v1.r
+ * c__[i__2].i + v1.i * c__[i__2].r;
+ i__3 = j + (c_dim1 << 1);
+ z__11.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__11.i = v2.r
+ * c__[i__3].i + v2.i * c__[i__3].r;
+ z__9.r = z__10.r + z__11.r, z__9.i = z__10.i + z__11.i;
+ i__4 = j + c_dim1 * 3;
+ z__12.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__12.i = v3.r
+ * c__[i__4].i + v3.i * c__[i__4].r;
+ z__8.r = z__9.r + z__12.r, z__8.i = z__9.i + z__12.i;
+ i__5 = j + (c_dim1 << 2);
+ z__13.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__13.i = v4.r
+ * c__[i__5].i + v4.i * c__[i__5].r;
+ z__7.r = z__8.r + z__13.r, z__7.i = z__8.i + z__13.i;
+ i__6 = j + c_dim1 * 5;
+ z__14.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__14.i = v5.r
+ * c__[i__6].i + v5.i * c__[i__6].r;
+ z__6.r = z__7.r + z__14.r, z__6.i = z__7.i + z__14.i;
+ i__7 = j + c_dim1 * 6;
+ z__15.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__15.i = v6.r
+ * c__[i__7].i + v6.i * c__[i__7].r;
+ z__5.r = z__6.r + z__15.r, z__5.i = z__6.i + z__15.i;
+ i__8 = j + c_dim1 * 7;
+ z__16.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__16.i = v7.r
+ * c__[i__8].i + v7.i * c__[i__8].r;
+ z__4.r = z__5.r + z__16.r, z__4.i = z__5.i + z__16.i;
+ i__9 = j + (c_dim1 << 3);
+ z__17.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__17.i = v8.r
+ * c__[i__9].i + v8.i * c__[i__9].r;
+ z__3.r = z__4.r + z__17.r, z__3.i = z__4.i + z__17.i;
+ i__10 = j + c_dim1 * 9;
+ z__18.r = v9.r * c__[i__10].r - v9.i * c__[i__10].i, z__18.i =
+ v9.r * c__[i__10].i + v9.i * c__[i__10].r;
+ z__2.r = z__3.r + z__18.r, z__2.i = z__3.i + z__18.i;
+ i__11 = j + c_dim1 * 10;
+ z__19.r = v10.r * c__[i__11].r - v10.i * c__[i__11].i, z__19.i =
+ v10.r * c__[i__11].i + v10.i * c__[i__11].r;
+ z__1.r = z__2.r + z__19.r, z__1.i = z__2.i + z__19.i;
+ sum.r = z__1.r, sum.i = z__1.i;
+ i__2 = j + c_dim1;
+ i__3 = j + c_dim1;
+ z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i +
+ sum.i * t1.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + (c_dim1 << 1);
+ i__3 = j + (c_dim1 << 1);
+ z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i +
+ sum.i * t2.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 3;
+ i__3 = j + c_dim1 * 3;
+ z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i +
+ sum.i * t3.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + (c_dim1 << 2);
+ i__3 = j + (c_dim1 << 2);
+ z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i +
+ sum.i * t4.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 5;
+ i__3 = j + c_dim1 * 5;
+ z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i +
+ sum.i * t5.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 6;
+ i__3 = j + c_dim1 * 6;
+ z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i +
+ sum.i * t6.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 7;
+ i__3 = j + c_dim1 * 7;
+ z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i +
+ sum.i * t7.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + (c_dim1 << 3);
+ i__3 = j + (c_dim1 << 3);
+ z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i +
+ sum.i * t8.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 9;
+ i__3 = j + c_dim1 * 9;
+ z__2.r = sum.r * t9.r - sum.i * t9.i, z__2.i = sum.r * t9.i +
+ sum.i * t9.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = j + c_dim1 * 10;
+ i__3 = j + c_dim1 * 10;
+ z__2.r = sum.r * t10.r - sum.i * t10.i, z__2.i = sum.r * t10.i +
+ sum.i * t10.r;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+/* L400: */
+ }
+ goto L410;
+ }
+L410:
+ return 0;
+
+/* End of ZLARFX */
+
+} /* zlarfx_ */
diff --git a/SRC/zlargv.c b/SRC/zlargv.c
new file mode 100644
index 0000000..74a4b6f
--- /dev/null
+++ b/SRC/zlargv.c
@@ -0,0 +1,336 @@
+/* zlargv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlargv_(integer *n, doublecomplex *x, integer *incx,
+ doublecomplex *y, integer *incy, doublereal *c__, integer *incc)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ double log(doublereal), pow_di(doublereal *, integer *), d_imag(
+ doublecomplex *), sqrt(doublereal);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ doublereal d__;
+ doublecomplex f, g;
+ integer i__, j;
+ doublecomplex r__;
+ doublereal f2, g2;
+ integer ic;
+ doublereal di;
+ doublecomplex ff;
+ doublereal cs, dr;
+ doublecomplex fs, gs;
+ integer ix, iy;
+ doublecomplex sn;
+ doublereal f2s, g2s, eps, scale;
+ integer count;
+ doublereal safmn2;
+ extern doublereal dlapy2_(doublereal *, doublereal *);
+ doublereal safmx2;
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLARGV generates a vector of complex plane rotations with real */
+/* cosines, determined by elements of the complex vectors x and y. */
+/* For i = 1,2,...,n */
+
+/* ( c(i) s(i) ) ( x(i) ) = ( r(i) ) */
+/* ( -conjg(s(i)) c(i) ) ( y(i) ) = ( 0 ) */
+
+/* where c(i)**2 + ABS(s(i))**2 = 1 */
+
+/* The following conventions are used (these are the same as in ZLARTG, */
+/* but differ from the BLAS1 routine ZROTG): */
+/* If y(i)=0, then c(i)=1 and s(i)=0. */
+/* If x(i)=0, then c(i)=0 and s(i) is chosen so that r(i) is real. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of plane rotations to be generated. */
+
+/* X (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX) */
+/* On entry, the vector x. */
+/* On exit, x(i) is overwritten by r(i), for i = 1,...,n. */
+
+/* INCX (input) INTEGER */
+/* The increment between elements of X. INCX > 0. */
+
+/* Y (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCY) */
+/* On entry, the vector y. */
+/* On exit, the sines of the plane rotations. */
+
+/* INCY (input) INTEGER */
+/* The increment between elements of Y. INCY > 0. */
+
+/* C (output) DOUBLE PRECISION array, dimension (1+(N-1)*INCC) */
+/* The cosines of the plane rotations. */
+
+/* INCC (input) INTEGER */
+/* The increment between elements of C. INCC > 0. */
+
+/* Further Details */
+/* ======= ======= */
+
+/* 6-6-96 - Modified with a new algorithm by W. Kahan and J. Demmel */
+
+/* This version has a few statements commented out for thread safety */
+/* (machine parameters are computed on each entry). 10 feb 03, SJH. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* LOGICAL FIRST */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Save statement .. */
+/* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 */
+/* .. */
+/* .. Data statements .. */
+/* DATA FIRST / .TRUE. / */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* IF( FIRST ) THEN */
+/* FIRST = .FALSE. */
+ /* Parameter adjustments */
+ --c__;
+ --y;
+ --x;
+
+ /* Function Body */
+ safmin = dlamch_("S");
+ eps = dlamch_("E");
+ d__1 = dlamch_("B");
+ i__1 = (integer) (log(safmin / eps) / log(dlamch_("B")) / 2.);
+ safmn2 = pow_di(&d__1, &i__1);
+ safmx2 = 1. / safmn2;
+/* END IF */
+ ix = 1;
+ iy = 1;
+ ic = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ix;
+ f.r = x[i__2].r, f.i = x[i__2].i;
+ i__2 = iy;
+ g.r = y[i__2].r, g.i = y[i__2].i;
+
+/* Use identical algorithm as in ZLARTG */
+
+/* Computing MAX */
+/* Computing MAX */
+ d__7 = (d__1 = f.r, abs(d__1)), d__8 = (d__2 = d_imag(&f), abs(d__2));
+/* Computing MAX */
+ d__9 = (d__3 = g.r, abs(d__3)), d__10 = (d__4 = d_imag(&g), abs(d__4))
+ ;
+ d__5 = max(d__7,d__8), d__6 = max(d__9,d__10);
+ scale = max(d__5,d__6);
+ fs.r = f.r, fs.i = f.i;
+ gs.r = g.r, gs.i = g.i;
+ count = 0;
+ if (scale >= safmx2) {
+L10:
+ ++count;
+ z__1.r = safmn2 * fs.r, z__1.i = safmn2 * fs.i;
+ fs.r = z__1.r, fs.i = z__1.i;
+ z__1.r = safmn2 * gs.r, z__1.i = safmn2 * gs.i;
+ gs.r = z__1.r, gs.i = z__1.i;
+ scale *= safmn2;
+ if (scale >= safmx2) {
+ goto L10;
+ }
+ } else if (scale <= safmn2) {
+ if (g.r == 0. && g.i == 0.) {
+ cs = 1.;
+ sn.r = 0., sn.i = 0.;
+ r__.r = f.r, r__.i = f.i;
+ goto L50;
+ }
+L20:
+ --count;
+ z__1.r = safmx2 * fs.r, z__1.i = safmx2 * fs.i;
+ fs.r = z__1.r, fs.i = z__1.i;
+ z__1.r = safmx2 * gs.r, z__1.i = safmx2 * gs.i;
+ gs.r = z__1.r, gs.i = z__1.i;
+ scale *= safmx2;
+ if (scale <= safmn2) {
+ goto L20;
+ }
+ }
+/* Computing 2nd power */
+ d__1 = fs.r;
+/* Computing 2nd power */
+ d__2 = d_imag(&fs);
+ f2 = d__1 * d__1 + d__2 * d__2;
+/* Computing 2nd power */
+ d__1 = gs.r;
+/* Computing 2nd power */
+ d__2 = d_imag(&gs);
+ g2 = d__1 * d__1 + d__2 * d__2;
+ if (f2 <= max(g2,1.) * safmin) {
+
+/* This is a rare case: F is very small. */
+
+ if (f.r == 0. && f.i == 0.) {
+ cs = 0.;
+ d__2 = g.r;
+ d__3 = d_imag(&g);
+ d__1 = dlapy2_(&d__2, &d__3);
+ r__.r = d__1, r__.i = 0.;
+/* Do complex/real division explicitly with two real */
+/* divisions */
+ d__1 = gs.r;
+ d__2 = d_imag(&gs);
+ d__ = dlapy2_(&d__1, &d__2);
+ d__1 = gs.r / d__;
+ d__2 = -d_imag(&gs) / d__;
+ z__1.r = d__1, z__1.i = d__2;
+ sn.r = z__1.r, sn.i = z__1.i;
+ goto L50;
+ }
+ d__1 = fs.r;
+ d__2 = d_imag(&fs);
+ f2s = dlapy2_(&d__1, &d__2);
+/* G2 and G2S are accurate */
+/* G2 is at least SAFMIN, and G2S is at least SAFMN2 */
+ g2s = sqrt(g2);
+/* Error in CS from underflow in F2S is at most */
+/* UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS */
+/* If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN, */
+/* and so CS .lt. sqrt(SAFMIN) */
+/* If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN */
+/* and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS) */
+/* Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S */
+ cs = f2s / g2s;
+/* Make sure abs(FF) = 1 */
+/* Do complex/real division explicitly with 2 real divisions */
+/* Computing MAX */
+ d__3 = (d__1 = f.r, abs(d__1)), d__4 = (d__2 = d_imag(&f), abs(
+ d__2));
+ if (max(d__3,d__4) > 1.) {
+ d__1 = f.r;
+ d__2 = d_imag(&f);
+ d__ = dlapy2_(&d__1, &d__2);
+ d__1 = f.r / d__;
+ d__2 = d_imag(&f) / d__;
+ z__1.r = d__1, z__1.i = d__2;
+ ff.r = z__1.r, ff.i = z__1.i;
+ } else {
+ dr = safmx2 * f.r;
+ di = safmx2 * d_imag(&f);
+ d__ = dlapy2_(&dr, &di);
+ d__1 = dr / d__;
+ d__2 = di / d__;
+ z__1.r = d__1, z__1.i = d__2;
+ ff.r = z__1.r, ff.i = z__1.i;
+ }
+ d__1 = gs.r / g2s;
+ d__2 = -d_imag(&gs) / g2s;
+ z__2.r = d__1, z__2.i = d__2;
+ z__1.r = ff.r * z__2.r - ff.i * z__2.i, z__1.i = ff.r * z__2.i +
+ ff.i * z__2.r;
+ sn.r = z__1.r, sn.i = z__1.i;
+ z__2.r = cs * f.r, z__2.i = cs * f.i;
+ z__3.r = sn.r * g.r - sn.i * g.i, z__3.i = sn.r * g.i + sn.i *
+ g.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ r__.r = z__1.r, r__.i = z__1.i;
+ } else {
+
+/* This is the most common case. */
+/* Neither F2 nor F2/G2 are less than SAFMIN */
+/* F2S cannot overflow, and it is accurate */
+
+ f2s = sqrt(g2 / f2 + 1.);
+/* Do the F2S(real)*FS(complex) multiply with two real */
+/* multiplies */
+ d__1 = f2s * fs.r;
+ d__2 = f2s * d_imag(&fs);
+ z__1.r = d__1, z__1.i = d__2;
+ r__.r = z__1.r, r__.i = z__1.i;
+ cs = 1. / f2s;
+ d__ = f2 + g2;
+/* Do complex/real division explicitly with two real divisions */
+ d__1 = r__.r / d__;
+ d__2 = d_imag(&r__) / d__;
+ z__1.r = d__1, z__1.i = d__2;
+ sn.r = z__1.r, sn.i = z__1.i;
+ d_cnjg(&z__2, &gs);
+ z__1.r = sn.r * z__2.r - sn.i * z__2.i, z__1.i = sn.r * z__2.i +
+ sn.i * z__2.r;
+ sn.r = z__1.r, sn.i = z__1.i;
+ if (count != 0) {
+ if (count > 0) {
+ i__2 = count;
+ for (j = 1; j <= i__2; ++j) {
+ z__1.r = safmx2 * r__.r, z__1.i = safmx2 * r__.i;
+ r__.r = z__1.r, r__.i = z__1.i;
+/* L30: */
+ }
+ } else {
+ i__2 = -count;
+ for (j = 1; j <= i__2; ++j) {
+ z__1.r = safmn2 * r__.r, z__1.i = safmn2 * r__.i;
+ r__.r = z__1.r, r__.i = z__1.i;
+/* L40: */
+ }
+ }
+ }
+ }
+L50:
+ c__[ic] = cs;
+ i__2 = iy;
+ y[i__2].r = sn.r, y[i__2].i = sn.i;
+ i__2 = ix;
+ x[i__2].r = r__.r, x[i__2].i = r__.i;
+ ic += *incc;
+ iy += *incy;
+ ix += *incx;
+/* L60: */
+ }
+ return 0;
+
+/* End of ZLARGV */
+
+} /* zlargv_ */
diff --git a/SRC/zlarnv.c b/SRC/zlarnv.c
new file mode 100644
index 0000000..2e4e257
--- /dev/null
+++ b/SRC/zlarnv.c
@@ -0,0 +1,190 @@
+/* zlarnv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlarnv_(integer *idist, integer *iseed, integer *n,
+ doublecomplex *x)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ double log(doublereal), sqrt(doublereal);
+ void z_exp(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__;
+ doublereal u[128];
+ integer il, iv;
+ extern /* Subroutine */ int dlaruv_(integer *, integer *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLARNV returns a vector of n random complex numbers from a uniform or */
+/* normal distribution. */
+
+/* Arguments */
+/* ========= */
+
+/* IDIST (input) INTEGER */
+/* Specifies the distribution of the random numbers: */
+/* = 1: real and imaginary parts each uniform (0,1) */
+/* = 2: real and imaginary parts each uniform (-1,1) */
+/* = 3: real and imaginary parts each normal (0,1) */
+/* = 4: uniformly distributed on the disc abs(z) < 1 */
+/* = 5: uniformly distributed on the circle abs(z) = 1 */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* N (input) INTEGER */
+/* The number of random numbers to be generated. */
+
+/* X (output) COMPLEX*16 array, dimension (N) */
+/* The generated random numbers. */
+
+/* Further Details */
+/* =============== */
+
+/* This routine calls the auxiliary routine DLARUV to generate random */
+/* real numbers from a uniform (0,1) distribution, in batches of up to */
+/* 128 using vectorisable code. The Box-Muller method is used to */
+/* transform numbers from a uniform to a normal distribution. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --x;
+ --iseed;
+
+ /* Function Body */
+ i__1 = *n;
+ for (iv = 1; iv <= i__1; iv += 64) {
+/* Computing MIN */
+ i__2 = 64, i__3 = *n - iv + 1;
+ il = min(i__2,i__3);
+
+/* Call DLARUV to generate 2*IL real numbers from a uniform (0,1) */
+/* distribution (2*IL <= LV) */
+
+ i__2 = il << 1;
+ dlaruv_(&iseed[1], &i__2, u);
+
+ if (*idist == 1) {
+
+/* Copy generated numbers */
+
+ i__2 = il;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = iv + i__ - 1;
+ i__4 = (i__ << 1) - 2;
+ i__5 = (i__ << 1) - 1;
+ z__1.r = u[i__4], z__1.i = u[i__5];
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+/* L10: */
+ }
+ } else if (*idist == 2) {
+
+/* Convert generated numbers to uniform (-1,1) distribution */
+
+ i__2 = il;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = iv + i__ - 1;
+ d__1 = u[(i__ << 1) - 2] * 2. - 1.;
+ d__2 = u[(i__ << 1) - 1] * 2. - 1.;
+ z__1.r = d__1, z__1.i = d__2;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+/* L20: */
+ }
+ } else if (*idist == 3) {
+
+/* Convert generated numbers to normal (0,1) distribution */
+
+ i__2 = il;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = iv + i__ - 1;
+ d__1 = sqrt(log(u[(i__ << 1) - 2]) * -2.);
+ d__2 = u[(i__ << 1) - 1] * 6.2831853071795864769252867663;
+ z__3.r = 0., z__3.i = d__2;
+ z_exp(&z__2, &z__3);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+/* L30: */
+ }
+ } else if (*idist == 4) {
+
+/* Convert generated numbers to complex numbers uniformly */
+/* distributed on the unit disk */
+
+ i__2 = il;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = iv + i__ - 1;
+ d__1 = sqrt(u[(i__ << 1) - 2]);
+ d__2 = u[(i__ << 1) - 1] * 6.2831853071795864769252867663;
+ z__3.r = 0., z__3.i = d__2;
+ z_exp(&z__2, &z__3);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+/* L40: */
+ }
+ } else if (*idist == 5) {
+
+/* Convert generated numbers to complex numbers uniformly */
+/* distributed on the unit circle */
+
+ i__2 = il;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = iv + i__ - 1;
+ d__1 = u[(i__ << 1) - 1] * 6.2831853071795864769252867663;
+ z__2.r = 0., z__2.i = d__1;
+ z_exp(&z__1, &z__2);
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ return 0;
+
+/* End of ZLARNV */
+
+} /* zlarnv_ */
diff --git a/SRC/zlarrv.c b/SRC/zlarrv.c
new file mode 100644
index 0000000..2edf451
--- /dev/null
+++ b/SRC/zlarrv.c
@@ -0,0 +1,1022 @@
+/* zlarrv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static integer c__1 = 1;
+static integer c__2 = 2;
+static doublereal c_b28 = 0.;
+
+/* Subroutine */ int zlarrv_(integer *n, doublereal *vl, doublereal *vu,
+ doublereal *d__, doublereal *l, doublereal *pivmin, integer *isplit,
+ integer *m, integer *dol, integer *dou, doublereal *minrgp,
+ doublereal *rtol1, doublereal *rtol2, doublereal *w, doublereal *werr,
+ doublereal *wgap, integer *iblock, integer *indexw, doublereal *gers,
+ doublecomplex *z__, integer *ldz, integer *isuppz, doublereal *work,
+ integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+ logical L__1;
+
+ /* Builtin functions */
+ double log(doublereal);
+
+ /* Local variables */
+ integer minwsize, i__, j, k, p, q, miniwsize, ii;
+ doublereal gl;
+ integer im, in;
+ doublereal gu, gap, eps, tau, tol, tmp;
+ integer zto;
+ doublereal ztz;
+ integer iend, jblk;
+ doublereal lgap;
+ integer done;
+ doublereal rgap, left;
+ integer wend, iter;
+ doublereal bstw;
+ integer itmp1, indld;
+ doublereal fudge;
+ integer idone;
+ doublereal sigma;
+ integer iinfo, iindr;
+ doublereal resid;
+ logical eskip;
+ doublereal right;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer nclus, zfrom;
+ doublereal rqtol;
+ integer iindc1, iindc2, indin1, indin2;
+ logical stp2ii;
+ extern /* Subroutine */ int zlar1v_(integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublecomplex *,
+ logical *, integer *, doublereal *, doublereal *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *)
+ ;
+ doublereal lambda;
+ extern doublereal dlamch_(char *);
+ integer ibegin, indeig;
+ logical needbs;
+ integer indlld;
+ doublereal sgndef, mingma;
+ extern /* Subroutine */ int dlarrb_(integer *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *);
+ integer oldien, oldncl, wbegin;
+ doublereal spdiam;
+ integer negcnt;
+ extern /* Subroutine */ int dlarrf_(integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *);
+ integer oldcls;
+ doublereal savgap;
+ integer ndepth;
+ doublereal ssigma;
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ logical usedbs;
+ integer iindwk, offset;
+ doublereal gaptol;
+ integer newcls, oldfst, indwrk, windex, oldlst;
+ logical usedrq;
+ integer newfst, newftt, parity, windmn, windpl, isupmn, newlst, zusedl;
+ doublereal bstres;
+ integer newsiz, zusedu, zusedw;
+ doublereal nrminv;
+ logical tryrqc;
+ integer isupmx;
+ doublereal rqcorr;
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLARRV computes the eigenvectors of the tridiagonal matrix */
+/* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T. */
+/* The input eigenvalues should have been computed by DLARRE. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* Lower and upper bounds of the interval that contains the desired */
+/* eigenvalues. VL < VU. Needed to compute gaps on the left or right */
+/* end of the extremal eigenvalues in the desired RANGE. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the N diagonal elements of the diagonal matrix D. */
+/* On exit, D may be overwritten. */
+
+/* L (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the (N-1) subdiagonal elements of the unit */
+/* bidiagonal matrix L are in elements 1 to N-1 of L */
+/* (if the matrix is not splitted.) At the end of each block */
+/* is stored the corresponding shift as given by DLARRE. */
+/* On exit, L is overwritten. */
+
+/* PIVMIN (in) DOUBLE PRECISION */
+/* The minimum pivot allowed in the Sturm sequence. */
+
+/* ISPLIT (input) INTEGER array, dimension (N) */
+/* The splitting points, at which T breaks up into blocks. */
+/* The first block consists of rows/columns 1 to */
+/* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 */
+/* through ISPLIT( 2 ), etc. */
+
+/* M (input) INTEGER */
+/* The total number of input eigenvalues. 0 <= M <= N. */
+
+/* DOL (input) INTEGER */
+/* DOU (input) INTEGER */
+/* If the user wants to compute only selected eigenvectors from all */
+/* the eigenvalues supplied, he can specify an index range DOL:DOU. */
+/* Or else the setting DOL=1, DOU=M should be applied. */
+/* Note that DOL and DOU refer to the order in which the eigenvalues */
+/* are stored in W. */
+/* If the user wants to compute only selected eigenpairs, then */
+/* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the */
+/* computed eigenvectors. All other columns of Z are set to zero. */
+
+/* MINRGP (input) DOUBLE PRECISION */
+
+/* RTOL1 (input) DOUBLE PRECISION */
+/* RTOL2 (input) DOUBLE PRECISION */
+/* Parameters for bisection. */
+/* An interval [LEFT,RIGHT] has converged if */
+/* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */
+
+/* W (input/output) DOUBLE PRECISION array, dimension (N) */
+/* The first M elements of W contain the APPROXIMATE eigenvalues for */
+/* which eigenvectors are to be computed. The eigenvalues */
+/* should be grouped by split-off block and ordered from */
+/* smallest to largest within the block ( The output array */
+/* W from DLARRE is expected here ). Furthermore, they are with */
+/* respect to the shift of the corresponding root representation */
+/* for their block. On exit, W holds the eigenvalues of the */
+/* UNshifted matrix. */
+
+/* WERR (input/output) DOUBLE PRECISION array, dimension (N) */
+/* The first M elements contain the semiwidth of the uncertainty */
+/* interval of the corresponding eigenvalue in W */
+
+/* WGAP (input/output) DOUBLE PRECISION array, dimension (N) */
+/* The separation from the right neighbor eigenvalue in W. */
+
+/* IBLOCK (input) INTEGER array, dimension (N) */
+/* The indices of the blocks (submatrices) associated with the */
+/* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue */
+/* W(i) belongs to the first block from the top, =2 if W(i) */
+/* belongs to the second block, etc. */
+
+/* INDEXW (input) INTEGER array, dimension (N) */
+/* The indices of the eigenvalues within each block (submatrix); */
+/* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the */
+/* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block. */
+
+/* GERS (input) DOUBLE PRECISION array, dimension (2*N) */
+/* The N Gerschgorin intervals (the i-th Gerschgorin interval */
+/* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should */
+/* be computed from the original UNshifted matrix. */
+
+/* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M) ) */
+/* If INFO = 0, the first M columns of Z contain the */
+/* orthonormal eigenvectors of the matrix T */
+/* corresponding to the input eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', LDZ >= max(1,N). */
+
+/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */
+/* The support of the eigenvectors in Z, i.e., the indices */
+/* indicating the nonzero elements in Z. The I-th eigenvector */
+/* is nonzero only in elements ISUPPZ( 2*I-1 ) through */
+/* ISUPPZ( 2*I ). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (12*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (7*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+
+/* > 0: A problem occured in ZLARRV. */
+/* < 0: One of the called subroutines signaled an internal problem. */
+/* Needs inspection of the corresponding parameter IINFO */
+/* for further information. */
+
+/* =-1: Problem in DLARRB when refining a child's eigenvalues. */
+/* =-2: Problem in DLARRF when computing the RRR of a child. */
+/* When a child is inside a tight cluster, it can be difficult */
+/* to find an RRR. A partial remedy from the user's point of */
+/* view is to make the parameter MINRGP smaller and recompile. */
+/* However, as the orthogonality of the computed vectors is */
+/* proportional to 1/MINRGP, the user should be aware that */
+/* he might be trading in precision when he decreases MINRGP. */
+/* =-3: Problem in DLARRB when refining a single eigenvalue */
+/* after the Rayleigh correction was rejected. */
+/* = 5: The Rayleigh Quotient Iteration failed to converge to */
+/* full accuracy in MAXITR steps. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+/* .. */
+/* The first N entries of WORK are reserved for the eigenvalues */
+ /* Parameter adjustments */
+ --d__;
+ --l;
+ --isplit;
+ --w;
+ --werr;
+ --wgap;
+ --iblock;
+ --indexw;
+ --gers;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --isuppz;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ indld = *n + 1;
+ indlld = (*n << 1) + 1;
+ indin1 = *n * 3 + 1;
+ indin2 = (*n << 2) + 1;
+ indwrk = *n * 5 + 1;
+ minwsize = *n * 12;
+ i__1 = minwsize;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L5: */
+ }
+/* IWORK(IINDR+1:IINDR+N) hold the twist indices R for the */
+/* factorization used to compute the FP vector */
+ iindr = 0;
+/* IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current */
+/* layer and the one above. */
+ iindc1 = *n;
+ iindc2 = *n << 1;
+ iindwk = *n * 3 + 1;
+ miniwsize = *n * 7;
+ i__1 = miniwsize;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ iwork[i__] = 0;
+/* L10: */
+ }
+ zusedl = 1;
+ if (*dol > 1) {
+/* Set lower bound for use of Z */
+ zusedl = *dol - 1;
+ }
+ zusedu = *m;
+ if (*dou < *m) {
+/* Set lower bound for use of Z */
+ zusedu = *dou + 1;
+ }
+/* The width of the part of Z that is used */
+ zusedw = zusedu - zusedl + 1;
+ zlaset_("Full", n, &zusedw, &c_b1, &c_b1, &z__[zusedl * z_dim1 + 1], ldz);
+ eps = dlamch_("Precision");
+ rqtol = eps * 2.;
+
+/* Set expert flags for standard code. */
+ tryrqc = TRUE_;
+ if (*dol == 1 && *dou == *m) {
+ } else {
+/* Only selected eigenpairs are computed. Since the other evalues */
+/* are not refined by RQ iteration, bisection has to compute to full */
+/* accuracy. */
+ *rtol1 = eps * 4.;
+ *rtol2 = eps * 4.;
+ }
+/* The entries WBEGIN:WEND in W, WERR, WGAP correspond to the */
+/* desired eigenvalues. The support of the nonzero eigenvector */
+/* entries is contained in the interval IBEGIN:IEND. */
+/* Remark that if k eigenpairs are desired, then the eigenvectors */
+/* are stored in k contiguous columns of Z. */
+/* DONE is the number of eigenvectors already computed */
+ done = 0;
+ ibegin = 1;
+ wbegin = 1;
+ i__1 = iblock[*m];
+ for (jblk = 1; jblk <= i__1; ++jblk) {
+ iend = isplit[jblk];
+ sigma = l[iend];
+/* Find the eigenvectors of the submatrix indexed IBEGIN */
+/* through IEND. */
+ wend = wbegin - 1;
+L15:
+ if (wend < *m) {
+ if (iblock[wend + 1] == jblk) {
+ ++wend;
+ goto L15;
+ }
+ }
+ if (wend < wbegin) {
+ ibegin = iend + 1;
+ goto L170;
+ } else if (wend < *dol || wbegin > *dou) {
+ ibegin = iend + 1;
+ wbegin = wend + 1;
+ goto L170;
+ }
+/* Find local spectral diameter of the block */
+ gl = gers[(ibegin << 1) - 1];
+ gu = gers[ibegin * 2];
+ i__2 = iend;
+ for (i__ = ibegin + 1; i__ <= i__2; ++i__) {
+/* Computing MIN */
+ d__1 = gers[(i__ << 1) - 1];
+ gl = min(d__1,gl);
+/* Computing MAX */
+ d__1 = gers[i__ * 2];
+ gu = max(d__1,gu);
+/* L20: */
+ }
+ spdiam = gu - gl;
+/* OLDIEN is the last index of the previous block */
+ oldien = ibegin - 1;
+/* Calculate the size of the current block */
+ in = iend - ibegin + 1;
+/* The number of eigenvalues in the current block */
+ im = wend - wbegin + 1;
+/* This is for a 1x1 block */
+ if (ibegin == iend) {
+ ++done;
+ i__2 = ibegin + wbegin * z_dim1;
+ z__[i__2].r = 1., z__[i__2].i = 0.;
+ isuppz[(wbegin << 1) - 1] = ibegin;
+ isuppz[wbegin * 2] = ibegin;
+ w[wbegin] += sigma;
+ work[wbegin] = w[wbegin];
+ ibegin = iend + 1;
+ ++wbegin;
+ goto L170;
+ }
+/* The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND) */
+/* Note that these can be approximations, in this case, the corresp. */
+/* entries of WERR give the size of the uncertainty interval. */
+/* The eigenvalue approximations will be refined when necessary as */
+/* high relative accuracy is required for the computation of the */
+/* corresponding eigenvectors. */
+ dcopy_(&im, &w[wbegin], &c__1, &work[wbegin], &c__1);
+/* We store in W the eigenvalue approximations w.r.t. the original */
+/* matrix T. */
+ i__2 = im;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ w[wbegin + i__ - 1] += sigma;
+/* L30: */
+ }
+/* NDEPTH is the current depth of the representation tree */
+ ndepth = 0;
+/* PARITY is either 1 or 0 */
+ parity = 1;
+/* NCLUS is the number of clusters for the next level of the */
+/* representation tree, we start with NCLUS = 1 for the root */
+ nclus = 1;
+ iwork[iindc1 + 1] = 1;
+ iwork[iindc1 + 2] = im;
+/* IDONE is the number of eigenvectors already computed in the current */
+/* block */
+ idone = 0;
+/* loop while( IDONE.LT.IM ) */
+/* generate the representation tree for the current block and */
+/* compute the eigenvectors */
+L40:
+ if (idone < im) {
+/* This is a crude protection against infinitely deep trees */
+ if (ndepth > *m) {
+ *info = -2;
+ return 0;
+ }
+/* breadth first processing of the current level of the representation */
+/* tree: OLDNCL = number of clusters on current level */
+ oldncl = nclus;
+/* reset NCLUS to count the number of child clusters */
+ nclus = 0;
+
+ parity = 1 - parity;
+ if (parity == 0) {
+ oldcls = iindc1;
+ newcls = iindc2;
+ } else {
+ oldcls = iindc2;
+ newcls = iindc1;
+ }
+/* Process the clusters on the current level */
+ i__2 = oldncl;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ j = oldcls + (i__ << 1);
+/* OLDFST, OLDLST = first, last index of current cluster. */
+/* cluster indices start with 1 and are relative */
+/* to WBEGIN when accessing W, WGAP, WERR, Z */
+ oldfst = iwork[j - 1];
+ oldlst = iwork[j];
+ if (ndepth > 0) {
+/* Retrieve relatively robust representation (RRR) of cluster */
+/* that has been computed at the previous level */
+/* The RRR is stored in Z and overwritten once the eigenvectors */
+/* have been computed or when the cluster is refined */
+ if (*dol == 1 && *dou == *m) {
+/* Get representation from location of the leftmost evalue */
+/* of the cluster */
+ j = wbegin + oldfst - 1;
+ } else {
+ if (wbegin + oldfst - 1 < *dol) {
+/* Get representation from the left end of Z array */
+ j = *dol - 1;
+ } else if (wbegin + oldfst - 1 > *dou) {
+/* Get representation from the right end of Z array */
+ j = *dou;
+ } else {
+ j = wbegin + oldfst - 1;
+ }
+ }
+ i__3 = in - 1;
+ for (k = 1; k <= i__3; ++k) {
+ i__4 = ibegin + k - 1 + j * z_dim1;
+ d__[ibegin + k - 1] = z__[i__4].r;
+ i__4 = ibegin + k - 1 + (j + 1) * z_dim1;
+ l[ibegin + k - 1] = z__[i__4].r;
+/* L45: */
+ }
+ i__3 = iend + j * z_dim1;
+ d__[iend] = z__[i__3].r;
+ i__3 = iend + (j + 1) * z_dim1;
+ sigma = z__[i__3].r;
+/* Set the corresponding entries in Z to zero */
+ zlaset_("Full", &in, &c__2, &c_b1, &c_b1, &z__[ibegin + j
+ * z_dim1], ldz);
+ }
+/* Compute DL and DLL of current RRR */
+ i__3 = iend - 1;
+ for (j = ibegin; j <= i__3; ++j) {
+ tmp = d__[j] * l[j];
+ work[indld - 1 + j] = tmp;
+ work[indlld - 1 + j] = tmp * l[j];
+/* L50: */
+ }
+ if (ndepth > 0) {
+/* P and Q are index of the first and last eigenvalue to compute */
+/* within the current block */
+ p = indexw[wbegin - 1 + oldfst];
+ q = indexw[wbegin - 1 + oldlst];
+/* Offset for the arrays WORK, WGAP and WERR, i.e., th P-OFFSET */
+/* thru' Q-OFFSET elements of these arrays are to be used. */
+/* OFFSET = P-OLDFST */
+ offset = indexw[wbegin] - 1;
+/* perform limited bisection (if necessary) to get approximate */
+/* eigenvalues to the precision needed. */
+ dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin - 1], &p,
+ &q, rtol1, rtol2, &offset, &work[wbegin], &wgap[
+ wbegin], &werr[wbegin], &work[indwrk], &iwork[
+ iindwk], pivmin, &spdiam, &in, &iinfo);
+ if (iinfo != 0) {
+ *info = -1;
+ return 0;
+ }
+/* We also recompute the extremal gaps. W holds all eigenvalues */
+/* of the unshifted matrix and must be used for computation */
+/* of WGAP, the entries of WORK might stem from RRRs with */
+/* different shifts. The gaps from WBEGIN-1+OLDFST to */
+/* WBEGIN-1+OLDLST are correctly computed in DLARRB. */
+/* However, we only allow the gaps to become greater since */
+/* this is what should happen when we decrease WERR */
+ if (oldfst > 1) {
+/* Computing MAX */
+ d__1 = wgap[wbegin + oldfst - 2], d__2 = w[wbegin +
+ oldfst - 1] - werr[wbegin + oldfst - 1] - w[
+ wbegin + oldfst - 2] - werr[wbegin + oldfst -
+ 2];
+ wgap[wbegin + oldfst - 2] = max(d__1,d__2);
+ }
+ if (wbegin + oldlst - 1 < wend) {
+/* Computing MAX */
+ d__1 = wgap[wbegin + oldlst - 1], d__2 = w[wbegin +
+ oldlst] - werr[wbegin + oldlst] - w[wbegin +
+ oldlst - 1] - werr[wbegin + oldlst - 1];
+ wgap[wbegin + oldlst - 1] = max(d__1,d__2);
+ }
+/* Each time the eigenvalues in WORK get refined, we store */
+/* the newly found approximation with all shifts applied in W */
+ i__3 = oldlst;
+ for (j = oldfst; j <= i__3; ++j) {
+ w[wbegin + j - 1] = work[wbegin + j - 1] + sigma;
+/* L53: */
+ }
+ }
+/* Process the current node. */
+ newfst = oldfst;
+ i__3 = oldlst;
+ for (j = oldfst; j <= i__3; ++j) {
+ if (j == oldlst) {
+/* we are at the right end of the cluster, this is also the */
+/* boundary of the child cluster */
+ newlst = j;
+ } else if (wgap[wbegin + j - 1] >= *minrgp * (d__1 = work[
+ wbegin + j - 1], abs(d__1))) {
+/* the right relative gap is big enough, the child cluster */
+/* (NEWFST,..,NEWLST) is well separated from the following */
+ newlst = j;
+ } else {
+/* inside a child cluster, the relative gap is not */
+/* big enough. */
+ goto L140;
+ }
+/* Compute size of child cluster found */
+ newsiz = newlst - newfst + 1;
+/* NEWFTT is the place in Z where the new RRR or the computed */
+/* eigenvector is to be stored */
+ if (*dol == 1 && *dou == *m) {
+/* Store representation at location of the leftmost evalue */
+/* of the cluster */
+ newftt = wbegin + newfst - 1;
+ } else {
+ if (wbegin + newfst - 1 < *dol) {
+/* Store representation at the left end of Z array */
+ newftt = *dol - 1;
+ } else if (wbegin + newfst - 1 > *dou) {
+/* Store representation at the right end of Z array */
+ newftt = *dou;
+ } else {
+ newftt = wbegin + newfst - 1;
+ }
+ }
+ if (newsiz > 1) {
+
+/* Current child is not a singleton but a cluster. */
+/* Compute and store new representation of child. */
+
+
+/* Compute left and right cluster gap. */
+
+/* LGAP and RGAP are not computed from WORK because */
+/* the eigenvalue approximations may stem from RRRs */
+/* different shifts. However, W hold all eigenvalues */
+/* of the unshifted matrix. Still, the entries in WGAP */
+/* have to be computed from WORK since the entries */
+/* in W might be of the same order so that gaps are not */
+/* exhibited correctly for very close eigenvalues. */
+ if (newfst == 1) {
+/* Computing MAX */
+ d__1 = 0., d__2 = w[wbegin] - werr[wbegin] - *vl;
+ lgap = max(d__1,d__2);
+ } else {
+ lgap = wgap[wbegin + newfst - 2];
+ }
+ rgap = wgap[wbegin + newlst - 1];
+
+/* Compute left- and rightmost eigenvalue of child */
+/* to high precision in order to shift as close */
+/* as possible and obtain as large relative gaps */
+/* as possible */
+
+ for (k = 1; k <= 2; ++k) {
+ if (k == 1) {
+ p = indexw[wbegin - 1 + newfst];
+ } else {
+ p = indexw[wbegin - 1 + newlst];
+ }
+ offset = indexw[wbegin] - 1;
+ dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin
+ - 1], &p, &p, &rqtol, &rqtol, &offset, &
+ work[wbegin], &wgap[wbegin], &werr[wbegin]
+, &work[indwrk], &iwork[iindwk], pivmin, &
+ spdiam, &in, &iinfo);
+/* L55: */
+ }
+
+ if (wbegin + newlst - 1 < *dol || wbegin + newfst - 1
+ > *dou) {
+/* if the cluster contains no desired eigenvalues */
+/* skip the computation of that branch of the rep. tree */
+
+/* We could skip before the refinement of the extremal */
+/* eigenvalues of the child, but then the representation */
+/* tree could be different from the one when nothing is */
+/* skipped. For this reason we skip at this place. */
+ idone = idone + newlst - newfst + 1;
+ goto L139;
+ }
+
+/* Compute RRR of child cluster. */
+/* Note that the new RRR is stored in Z */
+
+/* DLARRF needs LWORK = 2*N */
+ dlarrf_(&in, &d__[ibegin], &l[ibegin], &work[indld +
+ ibegin - 1], &newfst, &newlst, &work[wbegin],
+ &wgap[wbegin], &werr[wbegin], &spdiam, &lgap,
+ &rgap, pivmin, &tau, &work[indin1], &work[
+ indin2], &work[indwrk], &iinfo);
+/* In the complex case, DLARRF cannot write */
+/* the new RRR directly into Z and needs an intermediate */
+/* workspace */
+ i__4 = in - 1;
+ for (k = 1; k <= i__4; ++k) {
+ i__5 = ibegin + k - 1 + newftt * z_dim1;
+ i__6 = indin1 + k - 1;
+ z__1.r = work[i__6], z__1.i = 0.;
+ z__[i__5].r = z__1.r, z__[i__5].i = z__1.i;
+ i__5 = ibegin + k - 1 + (newftt + 1) * z_dim1;
+ i__6 = indin2 + k - 1;
+ z__1.r = work[i__6], z__1.i = 0.;
+ z__[i__5].r = z__1.r, z__[i__5].i = z__1.i;
+/* L56: */
+ }
+ i__4 = iend + newftt * z_dim1;
+ i__5 = indin1 + in - 1;
+ z__1.r = work[i__5], z__1.i = 0.;
+ z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
+ if (iinfo == 0) {
+/* a new RRR for the cluster was found by DLARRF */
+/* update shift and store it */
+ ssigma = sigma + tau;
+ i__4 = iend + (newftt + 1) * z_dim1;
+ z__1.r = ssigma, z__1.i = 0.;
+ z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
+/* WORK() are the midpoints and WERR() the semi-width */
+/* Note that the entries in W are unchanged. */
+ i__4 = newlst;
+ for (k = newfst; k <= i__4; ++k) {
+ fudge = eps * 3. * (d__1 = work[wbegin + k -
+ 1], abs(d__1));
+ work[wbegin + k - 1] -= tau;
+ fudge += eps * 4. * (d__1 = work[wbegin + k -
+ 1], abs(d__1));
+/* Fudge errors */
+ werr[wbegin + k - 1] += fudge;
+/* Gaps are not fudged. Provided that WERR is small */
+/* when eigenvalues are close, a zero gap indicates */
+/* that a new representation is needed for resolving */
+/* the cluster. A fudge could lead to a wrong decision */
+/* of judging eigenvalues 'separated' which in */
+/* reality are not. This could have a negative impact */
+/* on the orthogonality of the computed eigenvectors. */
+/* L116: */
+ }
+ ++nclus;
+ k = newcls + (nclus << 1);
+ iwork[k - 1] = newfst;
+ iwork[k] = newlst;
+ } else {
+ *info = -2;
+ return 0;
+ }
+ } else {
+
+/* Compute eigenvector of singleton */
+
+ iter = 0;
+
+ tol = log((doublereal) in) * 4. * eps;
+
+ k = newfst;
+ windex = wbegin + k - 1;
+/* Computing MAX */
+ i__4 = windex - 1;
+ windmn = max(i__4,1);
+/* Computing MIN */
+ i__4 = windex + 1;
+ windpl = min(i__4,*m);
+ lambda = work[windex];
+ ++done;
+/* Check if eigenvector computation is to be skipped */
+ if (windex < *dol || windex > *dou) {
+ eskip = TRUE_;
+ goto L125;
+ } else {
+ eskip = FALSE_;
+ }
+ left = work[windex] - werr[windex];
+ right = work[windex] + werr[windex];
+ indeig = indexw[windex];
+/* Note that since we compute the eigenpairs for a child, */
+/* all eigenvalue approximations are w.r.t the same shift. */
+/* In this case, the entries in WORK should be used for */
+/* computing the gaps since they exhibit even very small */
+/* differences in the eigenvalues, as opposed to the */
+/* entries in W which might "look" the same. */
+ if (k == 1) {
+/* In the case RANGE='I' and with not much initial */
+/* accuracy in LAMBDA and VL, the formula */
+/* LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA ) */
+/* can lead to an overestimation of the left gap and */
+/* thus to inadequately early RQI 'convergence'. */
+/* Prevent this by forcing a small left gap. */
+/* Computing MAX */
+ d__1 = abs(left), d__2 = abs(right);
+ lgap = eps * max(d__1,d__2);
+ } else {
+ lgap = wgap[windmn];
+ }
+ if (k == im) {
+/* In the case RANGE='I' and with not much initial */
+/* accuracy in LAMBDA and VU, the formula */
+/* can lead to an overestimation of the right gap and */
+/* thus to inadequately early RQI 'convergence'. */
+/* Prevent this by forcing a small right gap. */
+/* Computing MAX */
+ d__1 = abs(left), d__2 = abs(right);
+ rgap = eps * max(d__1,d__2);
+ } else {
+ rgap = wgap[windex];
+ }
+ gap = min(lgap,rgap);
+ if (k == 1 || k == im) {
+/* The eigenvector support can become wrong */
+/* because significant entries could be cut off due to a */
+/* large GAPTOL parameter in LAR1V. Prevent this. */
+ gaptol = 0.;
+ } else {
+ gaptol = gap * eps;
+ }
+ isupmn = in;
+ isupmx = 1;
+/* Update WGAP so that it holds the minimum gap */
+/* to the left or the right. This is crucial in the */
+/* case where bisection is used to ensure that the */
+/* eigenvalue is refined up to the required precision. */
+/* The correct value is restored afterwards. */
+ savgap = wgap[windex];
+ wgap[windex] = gap;
+/* We want to use the Rayleigh Quotient Correction */
+/* as often as possible since it converges quadratically */
+/* when we are close enough to the desired eigenvalue. */
+/* However, the Rayleigh Quotient can have the wrong sign */
+/* and lead us away from the desired eigenvalue. In this */
+/* case, the best we can do is to use bisection. */
+ usedbs = FALSE_;
+ usedrq = FALSE_;
+/* Bisection is initially turned off unless it is forced */
+ needbs = ! tryrqc;
+L120:
+/* Check if bisection should be used to refine eigenvalue */
+ if (needbs) {
+/* Take the bisection as new iterate */
+ usedbs = TRUE_;
+ itmp1 = iwork[iindr + windex];
+ offset = indexw[wbegin] - 1;
+ d__1 = eps * 2.;
+ dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin
+ - 1], &indeig, &indeig, &c_b28, &d__1, &
+ offset, &work[wbegin], &wgap[wbegin], &
+ werr[wbegin], &work[indwrk], &iwork[
+ iindwk], pivmin, &spdiam, &itmp1, &iinfo);
+ if (iinfo != 0) {
+ *info = -3;
+ return 0;
+ }
+ lambda = work[windex];
+/* Reset twist index from inaccurate LAMBDA to */
+/* force computation of true MINGMA */
+ iwork[iindr + windex] = 0;
+ }
+/* Given LAMBDA, compute the eigenvector. */
+ L__1 = ! usedbs;
+ zlar1v_(&in, &c__1, &in, &lambda, &d__[ibegin], &l[
+ ibegin], &work[indld + ibegin - 1], &work[
+ indlld + ibegin - 1], pivmin, &gaptol, &z__[
+ ibegin + windex * z_dim1], &L__1, &negcnt, &
+ ztz, &mingma, &iwork[iindr + windex], &isuppz[
+ (windex << 1) - 1], &nrminv, &resid, &rqcorr,
+ &work[indwrk]);
+ if (iter == 0) {
+ bstres = resid;
+ bstw = lambda;
+ } else if (resid < bstres) {
+ bstres = resid;
+ bstw = lambda;
+ }
+/* Computing MIN */
+ i__4 = isupmn, i__5 = isuppz[(windex << 1) - 1];
+ isupmn = min(i__4,i__5);
+/* Computing MAX */
+ i__4 = isupmx, i__5 = isuppz[windex * 2];
+ isupmx = max(i__4,i__5);
+ ++iter;
+/* sin alpha <= |resid|/gap */
+/* Note that both the residual and the gap are */
+/* proportional to the matrix, so ||T|| doesn't play */
+/* a role in the quotient */
+
+/* Convergence test for Rayleigh-Quotient iteration */
+/* (omitted when Bisection has been used) */
+
+ if (resid > tol * gap && abs(rqcorr) > rqtol * abs(
+ lambda) && ! usedbs) {
+/* We need to check that the RQCORR update doesn't */
+/* move the eigenvalue away from the desired one and */
+/* towards a neighbor. -> protection with bisection */
+ if (indeig <= negcnt) {
+/* The wanted eigenvalue lies to the left */
+ sgndef = -1.;
+ } else {
+/* The wanted eigenvalue lies to the right */
+ sgndef = 1.;
+ }
+/* We only use the RQCORR if it improves the */
+/* the iterate reasonably. */
+ if (rqcorr * sgndef >= 0. && lambda + rqcorr <=
+ right && lambda + rqcorr >= left) {
+ usedrq = TRUE_;
+/* Store new midpoint of bisection interval in WORK */
+ if (sgndef == 1.) {
+/* The current LAMBDA is on the left of the true */
+/* eigenvalue */
+ left = lambda;
+/* We prefer to assume that the error estimate */
+/* is correct. We could make the interval not */
+/* as a bracket but to be modified if the RQCORR */
+/* chooses to. In this case, the RIGHT side should */
+/* be modified as follows: */
+/* RIGHT = MAX(RIGHT, LAMBDA + RQCORR) */
+ } else {
+/* The current LAMBDA is on the right of the true */
+/* eigenvalue */
+ right = lambda;
+/* See comment about assuming the error estimate is */
+/* correct above. */
+/* LEFT = MIN(LEFT, LAMBDA + RQCORR) */
+ }
+ work[windex] = (right + left) * .5;
+/* Take RQCORR since it has the correct sign and */
+/* improves the iterate reasonably */
+ lambda += rqcorr;
+/* Update width of error interval */
+ werr[windex] = (right - left) * .5;
+ } else {
+ needbs = TRUE_;
+ }
+ if (right - left < rqtol * abs(lambda)) {
+/* The eigenvalue is computed to bisection accuracy */
+/* compute eigenvector and stop */
+ usedbs = TRUE_;
+ goto L120;
+ } else if (iter < 10) {
+ goto L120;
+ } else if (iter == 10) {
+ needbs = TRUE_;
+ goto L120;
+ } else {
+ *info = 5;
+ return 0;
+ }
+ } else {
+ stp2ii = FALSE_;
+ if (usedrq && usedbs && bstres <= resid) {
+ lambda = bstw;
+ stp2ii = TRUE_;
+ }
+ if (stp2ii) {
+/* improve error angle by second step */
+ L__1 = ! usedbs;
+ zlar1v_(&in, &c__1, &in, &lambda, &d__[ibegin]
+, &l[ibegin], &work[indld + ibegin -
+ 1], &work[indlld + ibegin - 1],
+ pivmin, &gaptol, &z__[ibegin + windex
+ * z_dim1], &L__1, &negcnt, &ztz, &
+ mingma, &iwork[iindr + windex], &
+ isuppz[(windex << 1) - 1], &nrminv, &
+ resid, &rqcorr, &work[indwrk]);
+ }
+ work[windex] = lambda;
+ }
+
+/* Compute FP-vector support w.r.t. whole matrix */
+
+ isuppz[(windex << 1) - 1] += oldien;
+ isuppz[windex * 2] += oldien;
+ zfrom = isuppz[(windex << 1) - 1];
+ zto = isuppz[windex * 2];
+ isupmn += oldien;
+ isupmx += oldien;
+/* Ensure vector is ok if support in the RQI has changed */
+ if (isupmn < zfrom) {
+ i__4 = zfrom - 1;
+ for (ii = isupmn; ii <= i__4; ++ii) {
+ i__5 = ii + windex * z_dim1;
+ z__[i__5].r = 0., z__[i__5].i = 0.;
+/* L122: */
+ }
+ }
+ if (isupmx > zto) {
+ i__4 = isupmx;
+ for (ii = zto + 1; ii <= i__4; ++ii) {
+ i__5 = ii + windex * z_dim1;
+ z__[i__5].r = 0., z__[i__5].i = 0.;
+/* L123: */
+ }
+ }
+ i__4 = zto - zfrom + 1;
+ zdscal_(&i__4, &nrminv, &z__[zfrom + windex * z_dim1],
+ &c__1);
+L125:
+/* Update W */
+ w[windex] = lambda + sigma;
+/* Recompute the gaps on the left and right */
+/* But only allow them to become larger and not */
+/* smaller (which can only happen through "bad" */
+/* cancellation and doesn't reflect the theory */
+/* where the initial gaps are underestimated due */
+/* to WERR being too crude.) */
+ if (! eskip) {
+ if (k > 1) {
+/* Computing MAX */
+ d__1 = wgap[windmn], d__2 = w[windex] - werr[
+ windex] - w[windmn] - werr[windmn];
+ wgap[windmn] = max(d__1,d__2);
+ }
+ if (windex < wend) {
+/* Computing MAX */
+ d__1 = savgap, d__2 = w[windpl] - werr[windpl]
+ - w[windex] - werr[windex];
+ wgap[windex] = max(d__1,d__2);
+ }
+ }
+ ++idone;
+ }
+/* here ends the code for the current child */
+
+L139:
+/* Proceed to any remaining child nodes */
+ newfst = j + 1;
+L140:
+ ;
+ }
+/* L150: */
+ }
+ ++ndepth;
+ goto L40;
+ }
+ ibegin = iend + 1;
+ wbegin = wend + 1;
+L170:
+ ;
+ }
+
+ return 0;
+
+/* End of ZLARRV */
+
+} /* zlarrv_ */
diff --git a/SRC/zlarscl2.c b/SRC/zlarscl2.c
new file mode 100644
index 0000000..a96e65b
--- /dev/null
+++ b/SRC/zlarscl2.c
@@ -0,0 +1,95 @@
+/* zlarscl2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlarscl2_(integer *m, integer *n, doublereal *d__,
+ doublecomplex *x, integer *ldx)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLARSCL2 performs a reciprocal diagonal scaling on an vector: */
+/* x <-- inv(D) * x */
+/* where the DOUBLE PRECISION diagonal matrix D is stored as a vector. */
+
+/* Eventually to be replaced by BLAS_zge_diag_scale in the new BLAS */
+/* standard. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of D and X. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of D and X. N >= 0. */
+
+/* D (input) DOUBLE PRECISION array, length M */
+/* Diagonal matrix D, stored as a vector of length M. */
+
+/* X (input/output) COMPLEX*16 array, dimension (LDX,N) */
+/* On entry, the vector X to be scaled by D. */
+/* On exit, the scaled vector. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the vector X. LDX >= 0. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --d__;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+
+ /* Function Body */
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * x_dim1;
+ i__5 = i__;
+ z__1.r = x[i__4].r / d__[i__5], z__1.i = x[i__4].i / d__[i__5];
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ }
+ }
+ return 0;
+} /* zlarscl2_ */
diff --git a/SRC/zlartg.c b/SRC/zlartg.c
new file mode 100644
index 0000000..5afdbb9
--- /dev/null
+++ b/SRC/zlartg.c
@@ -0,0 +1,285 @@
+/* zlartg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlartg_(doublecomplex *f, doublecomplex *g, doublereal *
+ cs, doublecomplex *sn, doublecomplex *r__)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ double log(doublereal), pow_di(doublereal *, integer *), d_imag(
+ doublecomplex *), sqrt(doublereal);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ doublereal d__;
+ integer i__;
+ doublereal f2, g2;
+ doublecomplex ff;
+ doublereal di, dr;
+ doublecomplex fs, gs;
+ doublereal f2s, g2s, eps, scale;
+ integer count;
+ doublereal safmn2;
+ extern doublereal dlapy2_(doublereal *, doublereal *);
+ doublereal safmx2;
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLARTG generates a plane rotation so that */
+
+/* [ CS SN ] [ F ] [ R ] */
+/* [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1. */
+/* [ -SN CS ] [ G ] [ 0 ] */
+
+/* This is a faster version of the BLAS1 routine ZROTG, except for */
+/* the following differences: */
+/* F and G are unchanged on return. */
+/* If G=0, then CS=1 and SN=0. */
+/* If F=0, then CS=0 and SN is chosen so that R is real. */
+
+/* Arguments */
+/* ========= */
+
+/* F (input) COMPLEX*16 */
+/* The first component of vector to be rotated. */
+
+/* G (input) COMPLEX*16 */
+/* The second component of vector to be rotated. */
+
+/* CS (output) DOUBLE PRECISION */
+/* The cosine of the rotation. */
+
+/* SN (output) COMPLEX*16 */
+/* The sine of the rotation. */
+
+/* R (output) COMPLEX*16 */
+/* The nonzero component of the rotated vector. */
+
+/* Further Details */
+/* ======= ======= */
+
+/* 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel */
+
+/* This version has a few statements commented out for thread safety */
+/* (machine parameters are computed on each entry). 10 feb 03, SJH. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* LOGICAL FIRST */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Save statement .. */
+/* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 */
+/* .. */
+/* .. Data statements .. */
+/* DATA FIRST / .TRUE. / */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* IF( FIRST ) THEN */
+ safmin = dlamch_("S");
+ eps = dlamch_("E");
+ d__1 = dlamch_("B");
+ i__1 = (integer) (log(safmin / eps) / log(dlamch_("B")) / 2.);
+ safmn2 = pow_di(&d__1, &i__1);
+ safmx2 = 1. / safmn2;
+/* FIRST = .FALSE. */
+/* END IF */
+/* Computing MAX */
+/* Computing MAX */
+ d__7 = (d__1 = f->r, abs(d__1)), d__8 = (d__2 = d_imag(f), abs(d__2));
+/* Computing MAX */
+ d__9 = (d__3 = g->r, abs(d__3)), d__10 = (d__4 = d_imag(g), abs(d__4));
+ d__5 = max(d__7,d__8), d__6 = max(d__9,d__10);
+ scale = max(d__5,d__6);
+ fs.r = f->r, fs.i = f->i;
+ gs.r = g->r, gs.i = g->i;
+ count = 0;
+ if (scale >= safmx2) {
+L10:
+ ++count;
+ z__1.r = safmn2 * fs.r, z__1.i = safmn2 * fs.i;
+ fs.r = z__1.r, fs.i = z__1.i;
+ z__1.r = safmn2 * gs.r, z__1.i = safmn2 * gs.i;
+ gs.r = z__1.r, gs.i = z__1.i;
+ scale *= safmn2;
+ if (scale >= safmx2) {
+ goto L10;
+ }
+ } else if (scale <= safmn2) {
+ if (g->r == 0. && g->i == 0.) {
+ *cs = 1.;
+ sn->r = 0., sn->i = 0.;
+ r__->r = f->r, r__->i = f->i;
+ return 0;
+ }
+L20:
+ --count;
+ z__1.r = safmx2 * fs.r, z__1.i = safmx2 * fs.i;
+ fs.r = z__1.r, fs.i = z__1.i;
+ z__1.r = safmx2 * gs.r, z__1.i = safmx2 * gs.i;
+ gs.r = z__1.r, gs.i = z__1.i;
+ scale *= safmx2;
+ if (scale <= safmn2) {
+ goto L20;
+ }
+ }
+/* Computing 2nd power */
+ d__1 = fs.r;
+/* Computing 2nd power */
+ d__2 = d_imag(&fs);
+ f2 = d__1 * d__1 + d__2 * d__2;
+/* Computing 2nd power */
+ d__1 = gs.r;
+/* Computing 2nd power */
+ d__2 = d_imag(&gs);
+ g2 = d__1 * d__1 + d__2 * d__2;
+ if (f2 <= max(g2,1.) * safmin) {
+
+/* This is a rare case: F is very small. */
+
+ if (f->r == 0. && f->i == 0.) {
+ *cs = 0.;
+ d__2 = g->r;
+ d__3 = d_imag(g);
+ d__1 = dlapy2_(&d__2, &d__3);
+ r__->r = d__1, r__->i = 0.;
+/* Do complex/real division explicitly with two real divisions */
+ d__1 = gs.r;
+ d__2 = d_imag(&gs);
+ d__ = dlapy2_(&d__1, &d__2);
+ d__1 = gs.r / d__;
+ d__2 = -d_imag(&gs) / d__;
+ z__1.r = d__1, z__1.i = d__2;
+ sn->r = z__1.r, sn->i = z__1.i;
+ return 0;
+ }
+ d__1 = fs.r;
+ d__2 = d_imag(&fs);
+ f2s = dlapy2_(&d__1, &d__2);
+/* G2 and G2S are accurate */
+/* G2 is at least SAFMIN, and G2S is at least SAFMN2 */
+ g2s = sqrt(g2);
+/* Error in CS from underflow in F2S is at most */
+/* UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS */
+/* If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN, */
+/* and so CS .lt. sqrt(SAFMIN) */
+/* If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN */
+/* and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS) */
+/* Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S */
+ *cs = f2s / g2s;
+/* Make sure abs(FF) = 1 */
+/* Do complex/real division explicitly with 2 real divisions */
+/* Computing MAX */
+ d__3 = (d__1 = f->r, abs(d__1)), d__4 = (d__2 = d_imag(f), abs(d__2));
+ if (max(d__3,d__4) > 1.) {
+ d__1 = f->r;
+ d__2 = d_imag(f);
+ d__ = dlapy2_(&d__1, &d__2);
+ d__1 = f->r / d__;
+ d__2 = d_imag(f) / d__;
+ z__1.r = d__1, z__1.i = d__2;
+ ff.r = z__1.r, ff.i = z__1.i;
+ } else {
+ dr = safmx2 * f->r;
+ di = safmx2 * d_imag(f);
+ d__ = dlapy2_(&dr, &di);
+ d__1 = dr / d__;
+ d__2 = di / d__;
+ z__1.r = d__1, z__1.i = d__2;
+ ff.r = z__1.r, ff.i = z__1.i;
+ }
+ d__1 = gs.r / g2s;
+ d__2 = -d_imag(&gs) / g2s;
+ z__2.r = d__1, z__2.i = d__2;
+ z__1.r = ff.r * z__2.r - ff.i * z__2.i, z__1.i = ff.r * z__2.i + ff.i
+ * z__2.r;
+ sn->r = z__1.r, sn->i = z__1.i;
+ z__2.r = *cs * f->r, z__2.i = *cs * f->i;
+ z__3.r = sn->r * g->r - sn->i * g->i, z__3.i = sn->r * g->i + sn->i *
+ g->r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ r__->r = z__1.r, r__->i = z__1.i;
+ } else {
+
+/* This is the most common case. */
+/* Neither F2 nor F2/G2 are less than SAFMIN */
+/* F2S cannot overflow, and it is accurate */
+
+ f2s = sqrt(g2 / f2 + 1.);
+/* Do the F2S(real)*FS(complex) multiply with two real multiplies */
+ d__1 = f2s * fs.r;
+ d__2 = f2s * d_imag(&fs);
+ z__1.r = d__1, z__1.i = d__2;
+ r__->r = z__1.r, r__->i = z__1.i;
+ *cs = 1. / f2s;
+ d__ = f2 + g2;
+/* Do complex/real division explicitly with two real divisions */
+ d__1 = r__->r / d__;
+ d__2 = d_imag(r__) / d__;
+ z__1.r = d__1, z__1.i = d__2;
+ sn->r = z__1.r, sn->i = z__1.i;
+ d_cnjg(&z__2, &gs);
+ z__1.r = sn->r * z__2.r - sn->i * z__2.i, z__1.i = sn->r * z__2.i +
+ sn->i * z__2.r;
+ sn->r = z__1.r, sn->i = z__1.i;
+ if (count != 0) {
+ if (count > 0) {
+ i__1 = count;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ z__1.r = safmx2 * r__->r, z__1.i = safmx2 * r__->i;
+ r__->r = z__1.r, r__->i = z__1.i;
+/* L30: */
+ }
+ } else {
+ i__1 = -count;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ z__1.r = safmn2 * r__->r, z__1.i = safmn2 * r__->i;
+ r__->r = z__1.r, r__->i = z__1.i;
+/* L40: */
+ }
+ }
+ }
+ }
+ return 0;
+
+/* End of ZLARTG */
+
+} /* zlartg_ */
diff --git a/SRC/zlartv.c b/SRC/zlartv.c
new file mode 100644
index 0000000..1cb3607
--- /dev/null
+++ b/SRC/zlartv.c
@@ -0,0 +1,126 @@
+/* zlartv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlartv_(integer *n, doublecomplex *x, integer *incx,
+ doublecomplex *y, integer *incy, doublereal *c__, doublecomplex *s,
+ integer *incc)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, ic, ix, iy;
+ doublecomplex xi, yi;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLARTV applies a vector of complex plane rotations with real cosines */
+/* to elements of the complex vectors x and y. For i = 1,2,...,n */
+
+/* ( x(i) ) := ( c(i) s(i) ) ( x(i) ) */
+/* ( y(i) ) ( -conjg(s(i)) c(i) ) ( y(i) ) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of plane rotations to be applied. */
+
+/* X (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX) */
+/* The vector x. */
+
+/* INCX (input) INTEGER */
+/* The increment between elements of X. INCX > 0. */
+
+/* Y (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCY) */
+/* The vector y. */
+
+/* INCY (input) INTEGER */
+/* The increment between elements of Y. INCY > 0. */
+
+/* C (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC) */
+/* The cosines of the plane rotations. */
+
+/* S (input) COMPLEX*16 array, dimension (1+(N-1)*INCC) */
+/* The sines of the plane rotations. */
+
+/* INCC (input) INTEGER */
+/* The increment between elements of C and S. INCC > 0. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --s;
+ --c__;
+ --y;
+ --x;
+
+ /* Function Body */
+ ix = 1;
+ iy = 1;
+ ic = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ix;
+ xi.r = x[i__2].r, xi.i = x[i__2].i;
+ i__2 = iy;
+ yi.r = y[i__2].r, yi.i = y[i__2].i;
+ i__2 = ix;
+ i__3 = ic;
+ z__2.r = c__[i__3] * xi.r, z__2.i = c__[i__3] * xi.i;
+ i__4 = ic;
+ z__3.r = s[i__4].r * yi.r - s[i__4].i * yi.i, z__3.i = s[i__4].r *
+ yi.i + s[i__4].i * yi.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ i__2 = iy;
+ i__3 = ic;
+ z__2.r = c__[i__3] * yi.r, z__2.i = c__[i__3] * yi.i;
+ d_cnjg(&z__4, &s[ic]);
+ z__3.r = z__4.r * xi.r - z__4.i * xi.i, z__3.i = z__4.r * xi.i +
+ z__4.i * xi.r;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ ix += *incx;
+ iy += *incy;
+ ic += *incc;
+/* L10: */
+ }
+ return 0;
+
+/* End of ZLARTV */
+
+} /* zlartv_ */
diff --git a/SRC/zlarz.c b/SRC/zlarz.c
new file mode 100644
index 0000000..78b8a56
--- /dev/null
+++ b/SRC/zlarz.c
@@ -0,0 +1,200 @@
+/* zlarz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zlarz_(char *side, integer *m, integer *n, integer *l,
+ doublecomplex *v, integer *incv, doublecomplex *tau, doublecomplex *
+ c__, integer *ldc, doublecomplex *work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset;
+ doublecomplex z__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zgeru_(integer *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *)
+ , zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *), zlacgv_(integer *,
+ doublecomplex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLARZ applies a complex elementary reflector H to a complex */
+/* M-by-N matrix C, from either the left or the right. H is represented */
+/* in the form */
+
+/* H = I - tau * v * v' */
+
+/* where tau is a complex scalar and v is a complex vector. */
+
+/* If tau = 0, then H is taken to be the unit matrix. */
+
+/* To apply H' (the conjugate transpose of H), supply conjg(tau) instead */
+/* tau. */
+
+/* H is a product of k elementary reflectors as returned by ZTZRZF. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': form H * C */
+/* = 'R': form C * H */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* L (input) INTEGER */
+/* The number of entries of the vector V containing */
+/* the meaningful part of the Householder vectors. */
+/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */
+
+/* V (input) COMPLEX*16 array, dimension (1+(L-1)*abs(INCV)) */
+/* The vector v in the representation of H as returned by */
+/* ZTZRZF. V is not used if TAU = 0. */
+
+/* INCV (input) INTEGER */
+/* The increment between elements of v. INCV <> 0. */
+
+/* TAU (input) COMPLEX*16 */
+/* The value tau in the representation of H. */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
+/* or C * H if SIDE = 'R'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (N) if SIDE = 'L' */
+/* or (M) if SIDE = 'R' */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ if (lsame_(side, "L")) {
+
+/* Form H * C */
+
+ if (tau->r != 0. || tau->i != 0.) {
+
+/* w( 1:n ) = conjg( C( 1, 1:n ) ) */
+
+ zcopy_(n, &c__[c_offset], ldc, &work[1], &c__1);
+ zlacgv_(n, &work[1], &c__1);
+
+/* w( 1:n ) = conjg( w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l ) ) */
+
+ zgemv_("Conjugate transpose", l, n, &c_b1, &c__[*m - *l + 1 +
+ c_dim1], ldc, &v[1], incv, &c_b1, &work[1], &c__1);
+ zlacgv_(n, &work[1], &c__1);
+
+/* C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n ) */
+
+ z__1.r = -tau->r, z__1.i = -tau->i;
+ zaxpy_(n, &z__1, &work[1], &c__1, &c__[c_offset], ldc);
+
+/* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... */
+/* tau * v( 1:l ) * conjg( w( 1:n )' ) */
+
+ z__1.r = -tau->r, z__1.i = -tau->i;
+ zgeru_(l, n, &z__1, &v[1], incv, &work[1], &c__1, &c__[*m - *l +
+ 1 + c_dim1], ldc);
+ }
+
+ } else {
+
+/* Form C * H */
+
+ if (tau->r != 0. || tau->i != 0.) {
+
+/* w( 1:m ) = C( 1:m, 1 ) */
+
+ zcopy_(m, &c__[c_offset], &c__1, &work[1], &c__1);
+
+/* w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l ) */
+
+ zgemv_("No transpose", m, l, &c_b1, &c__[(*n - *l + 1) * c_dim1 +
+ 1], ldc, &v[1], incv, &c_b1, &work[1], &c__1);
+
+/* C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m ) */
+
+ z__1.r = -tau->r, z__1.i = -tau->i;
+ zaxpy_(m, &z__1, &work[1], &c__1, &c__[c_offset], &c__1);
+
+/* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... */
+/* tau * w( 1:m ) * v( 1:l )' */
+
+ z__1.r = -tau->r, z__1.i = -tau->i;
+ zgerc_(m, l, &z__1, &work[1], &c__1, &v[1], incv, &c__[(*n - *l +
+ 1) * c_dim1 + 1], ldc);
+
+ }
+
+ }
+
+ return 0;
+
+/* End of ZLARZ */
+
+} /* zlarz_ */
diff --git a/SRC/zlarzb.c b/SRC/zlarzb.c
new file mode 100644
index 0000000..624b671
--- /dev/null
+++ b/SRC/zlarzb.c
@@ -0,0 +1,323 @@
+/* zlarzb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zlarzb_(char *side, char *trans, char *direct, char *
+ storev, integer *m, integer *n, integer *k, integer *l, doublecomplex
+ *v, integer *ldv, doublecomplex *t, integer *ldt, doublecomplex *c__,
+ integer *ldc, doublecomplex *work, integer *ldwork)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1,
+ work_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j, info;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zcopy_(integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), ztrmm_(char *, char *,
+ char *, char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *),
+ zlacgv_(integer *, doublecomplex *, integer *);
+ char transt[1];
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLARZB applies a complex block reflector H or its transpose H**H */
+/* to a complex distributed M-by-N C from the left or the right. */
+
+/* Currently, only STOREV = 'R' and DIRECT = 'B' are supported. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply H or H' from the Left */
+/* = 'R': apply H or H' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply H (No transpose) */
+/* = 'C': apply H' (Conjugate transpose) */
+
+/* DIRECT (input) CHARACTER*1 */
+/* Indicates how H is formed from a product of elementary */
+/* reflectors */
+/* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet) */
+/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
+
+/* STOREV (input) CHARACTER*1 */
+/* Indicates how the vectors which define the elementary */
+/* reflectors are stored: */
+/* = 'C': Columnwise (not supported yet) */
+/* = 'R': Rowwise */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* K (input) INTEGER */
+/* The order of the matrix T (= the number of elementary */
+/* reflectors whose product defines the block reflector). */
+
+/* L (input) INTEGER */
+/* The number of columns of the matrix V containing the */
+/* meaningful part of the Householder reflectors. */
+/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */
+
+/* V (input) COMPLEX*16 array, dimension (LDV,NV). */
+/* If STOREV = 'C', NV = K; if STOREV = 'R', NV = L. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. */
+/* If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K. */
+
+/* T (input) COMPLEX*16 array, dimension (LDT,K) */
+/* The triangular K-by-K matrix T in the representation of the */
+/* block reflector. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= K. */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,K) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. */
+/* If SIDE = 'L', LDWORK >= max(1,N); */
+/* if SIDE = 'R', LDWORK >= max(1,M). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+/* Check for currently supported options */
+
+ info = 0;
+ if (! lsame_(direct, "B")) {
+ info = -3;
+ } else if (! lsame_(storev, "R")) {
+ info = -4;
+ }
+ if (info != 0) {
+ i__1 = -info;
+ xerbla_("ZLARZB", &i__1);
+ return 0;
+ }
+
+ if (lsame_(trans, "N")) {
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+ if (lsame_(side, "L")) {
+
+/* Form H * C or H' * C */
+
+/* W( 1:n, 1:k ) = conjg( C( 1:k, 1:n )' ) */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1);
+/* L10: */
+ }
+
+/* W( 1:n, 1:k ) = W( 1:n, 1:k ) + ... */
+/* conjg( C( m-l+1:m, 1:n )' ) * V( 1:k, 1:l )' */
+
+ if (*l > 0) {
+ zgemm_("Transpose", "Conjugate transpose", n, k, l, &c_b1, &c__[*
+ m - *l + 1 + c_dim1], ldc, &v[v_offset], ldv, &c_b1, &
+ work[work_offset], ldwork);
+ }
+
+/* W( 1:n, 1:k ) = W( 1:n, 1:k ) * T' or W( 1:m, 1:k ) * T */
+
+ ztrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b1, &t[t_offset]
+, ldt, &work[work_offset], ldwork);
+
+/* C( 1:k, 1:n ) = C( 1:k, 1:n ) - conjg( W( 1:n, 1:k )' ) */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *k;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = j + i__ * work_dim1;
+ z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[i__4].i -
+ work[i__5].i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... */
+/* conjg( V( 1:k, 1:l )' ) * conjg( W( 1:n, 1:k )' ) */
+
+ if (*l > 0) {
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("Transpose", "Transpose", l, n, k, &z__1, &v[v_offset],
+ ldv, &work[work_offset], ldwork, &c_b1, &c__[*m - *l + 1
+ + c_dim1], ldc);
+ }
+
+ } else if (lsame_(side, "R")) {
+
+/* Form C * H or C * H' */
+
+/* W( 1:m, 1:k ) = C( 1:m, 1:k ) */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &
+ c__1);
+/* L40: */
+ }
+
+/* W( 1:m, 1:k ) = W( 1:m, 1:k ) + ... */
+/* C( 1:m, n-l+1:n ) * conjg( V( 1:k, 1:l )' ) */
+
+ if (*l > 0) {
+ zgemm_("No transpose", "Transpose", m, k, l, &c_b1, &c__[(*n - *l
+ + 1) * c_dim1 + 1], ldc, &v[v_offset], ldv, &c_b1, &work[
+ work_offset], ldwork);
+ }
+
+/* W( 1:m, 1:k ) = W( 1:m, 1:k ) * conjg( T ) or */
+/* W( 1:m, 1:k ) * conjg( T' ) */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *k - j + 1;
+ zlacgv_(&i__2, &t[j + j * t_dim1], &c__1);
+/* L50: */
+ }
+ ztrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b1, &t[t_offset],
+ ldt, &work[work_offset], ldwork);
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *k - j + 1;
+ zlacgv_(&i__2, &t[j + j * t_dim1], &c__1);
+/* L60: */
+ }
+
+/* C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k ) */
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * work_dim1;
+ z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[i__4].i -
+ work[i__5].i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+
+/* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... */
+/* W( 1:m, 1:k ) * conjg( V( 1:k, 1:l ) ) */
+
+ i__1 = *l;
+ for (j = 1; j <= i__1; ++j) {
+ zlacgv_(k, &v[j * v_dim1 + 1], &c__1);
+/* L90: */
+ }
+ if (*l > 0) {
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "No transpose", m, l, k, &z__1, &work[
+ work_offset], ldwork, &v[v_offset], ldv, &c_b1, &c__[(*n
+ - *l + 1) * c_dim1 + 1], ldc);
+ }
+ i__1 = *l;
+ for (j = 1; j <= i__1; ++j) {
+ zlacgv_(k, &v[j * v_dim1 + 1], &c__1);
+/* L100: */
+ }
+
+ }
+
+ return 0;
+
+/* End of ZLARZB */
+
+} /* zlarzb_ */
diff --git a/SRC/zlarzt.c b/SRC/zlarzt.c
new file mode 100644
index 0000000..f9e6a47
--- /dev/null
+++ b/SRC/zlarzt.c
@@ -0,0 +1,238 @@
+/* zlarzt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zlarzt_(char *direct, char *storev, integer *n, integer *
+ k, doublecomplex *v, integer *ldv, doublecomplex *tau, doublecomplex *
+ t, integer *ldt)
+{
+ /* System generated locals */
+ integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j, info;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ ztrmv_(char *, char *, char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *),
+ xerbla_(char *, integer *), zlacgv_(integer *,
+ doublecomplex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLARZT forms the triangular factor T of a complex block reflector */
+/* H of order > n, which is defined as a product of k elementary */
+/* reflectors. */
+
+/* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */
+
+/* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */
+
+/* If STOREV = 'C', the vector which defines the elementary reflector */
+/* H(i) is stored in the i-th column of the array V, and */
+
+/* H = I - V * T * V' */
+
+/* If STOREV = 'R', the vector which defines the elementary reflector */
+/* H(i) is stored in the i-th row of the array V, and */
+
+/* H = I - V' * T * V */
+
+/* Currently, only STOREV = 'R' and DIRECT = 'B' are supported. */
+
+/* Arguments */
+/* ========= */
+
+/* DIRECT (input) CHARACTER*1 */
+/* Specifies the order in which the elementary reflectors are */
+/* multiplied to form the block reflector: */
+/* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet) */
+/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
+
+/* STOREV (input) CHARACTER*1 */
+/* Specifies how the vectors which define the elementary */
+/* reflectors are stored (see also Further Details): */
+/* = 'C': columnwise (not supported yet) */
+/* = 'R': rowwise */
+
+/* N (input) INTEGER */
+/* The order of the block reflector H. N >= 0. */
+
+/* K (input) INTEGER */
+/* The order of the triangular factor T (= the number of */
+/* elementary reflectors). K >= 1. */
+
+/* V (input/output) COMPLEX*16 array, dimension */
+/* (LDV,K) if STOREV = 'C' */
+/* (LDV,N) if STOREV = 'R' */
+/* The matrix V. See further details. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. */
+/* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */
+
+/* TAU (input) COMPLEX*16 array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i). */
+
+/* T (output) COMPLEX*16 array, dimension (LDT,K) */
+/* The k by k triangular factor T of the block reflector. */
+/* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */
+/* lower triangular. The rest of the array is not used. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= K. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* The shape of the matrix V and the storage of the vectors which define */
+/* the H(i) is best illustrated by the following example with n = 5 and */
+/* k = 3. The elements equal to 1 are not stored; the corresponding */
+/* array elements are modified but restored on exit. The rest of the */
+/* array is not used. */
+
+/* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */
+
+/* ______V_____ */
+/* ( v1 v2 v3 ) / \ */
+/* ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 ) */
+/* V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 ) */
+/* ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 ) */
+/* ( v1 v2 v3 ) */
+/* . . . */
+/* . . . */
+/* 1 . . */
+/* 1 . */
+/* 1 */
+
+/* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */
+
+/* ______V_____ */
+/* 1 / \ */
+/* . 1 ( 1 . . . . v1 v1 v1 v1 v1 ) */
+/* . . 1 ( . 1 . . . v2 v2 v2 v2 v2 ) */
+/* . . . ( . . 1 . . v3 v3 v3 v3 v3 ) */
+/* . . . */
+/* ( v1 v2 v3 ) */
+/* ( v1 v2 v3 ) */
+/* V = ( v1 v2 v3 ) */
+/* ( v1 v2 v3 ) */
+/* ( v1 v2 v3 ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for currently supported options */
+
+ /* Parameter adjustments */
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --tau;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(direct, "B")) {
+ info = -1;
+ } else if (! lsame_(storev, "R")) {
+ info = -2;
+ }
+ if (info != 0) {
+ i__1 = -info;
+ xerbla_("ZLARZT", &i__1);
+ return 0;
+ }
+
+ for (i__ = *k; i__ >= 1; --i__) {
+ i__1 = i__;
+ if (tau[i__1].r == 0. && tau[i__1].i == 0.) {
+
+/* H(i) = I */
+
+ i__1 = *k;
+ for (j = i__; j <= i__1; ++j) {
+ i__2 = j + i__ * t_dim1;
+ t[i__2].r = 0., t[i__2].i = 0.;
+/* L10: */
+ }
+ } else {
+
+/* general case */
+
+ if (i__ < *k) {
+
+/* T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)' */
+
+ zlacgv_(n, &v[i__ + v_dim1], ldv);
+ i__1 = *k - i__;
+ i__2 = i__;
+ z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i;
+ zgemv_("No transpose", &i__1, n, &z__1, &v[i__ + 1 + v_dim1],
+ ldv, &v[i__ + v_dim1], ldv, &c_b1, &t[i__ + 1 + i__ *
+ t_dim1], &c__1);
+ zlacgv_(n, &v[i__ + v_dim1], ldv);
+
+/* T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i) */
+
+ i__1 = *k - i__;
+ ztrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ + 1
+ + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * t_dim1]
+, &c__1);
+ }
+ i__1 = i__ + i__ * t_dim1;
+ i__2 = i__;
+ t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i;
+ }
+/* L20: */
+ }
+ return 0;
+
+/* End of ZLARZT */
+
+} /* zlarzt_ */
diff --git a/SRC/zlascl.c b/SRC/zlascl.c
new file mode 100644
index 0000000..f0023c0
--- /dev/null
+++ b/SRC/zlascl.c
@@ -0,0 +1,376 @@
+/* zlascl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlascl_(char *type__, integer *kl, integer *ku,
+ doublereal *cfrom, doublereal *cto, integer *m, integer *n,
+ doublecomplex *a, integer *lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j, k1, k2, k3, k4;
+ doublereal mul, cto1;
+ logical done;
+ doublereal ctoc;
+ extern logical lsame_(char *, char *);
+ integer itype;
+ doublereal cfrom1;
+ extern doublereal dlamch_(char *);
+ doublereal cfromc;
+ extern logical disnan_(doublereal *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum, smlnum;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLASCL multiplies the M by N complex matrix A by the real scalar */
+/* CTO/CFROM. This is done without over/underflow as long as the final */
+/* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that */
+/* A may be full, upper triangular, lower triangular, upper Hessenberg, */
+/* or banded. */
+
+/* Arguments */
+/* ========= */
+
+/* TYPE (input) CHARACTER*1 */
+/* TYPE indices the storage type of the input matrix. */
+/* = 'G': A is a full matrix. */
+/* = 'L': A is a lower triangular matrix. */
+/* = 'U': A is an upper triangular matrix. */
+/* = 'H': A is an upper Hessenberg matrix. */
+/* = 'B': A is a symmetric band matrix with lower bandwidth KL */
+/* and upper bandwidth KU and with the only the lower */
+/* half stored. */
+/* = 'Q': A is a symmetric band matrix with lower bandwidth KL */
+/* and upper bandwidth KU and with the only the upper */
+/* half stored. */
+/* = 'Z': A is a band matrix with lower bandwidth KL and upper */
+/* bandwidth KU. */
+
+/* KL (input) INTEGER */
+/* The lower bandwidth of A. Referenced only if TYPE = 'B', */
+/* 'Q' or 'Z'. */
+
+/* KU (input) INTEGER */
+/* The upper bandwidth of A. Referenced only if TYPE = 'B', */
+/* 'Q' or 'Z'. */
+
+/* CFROM (input) DOUBLE PRECISION */
+/* CTO (input) DOUBLE PRECISION */
+/* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed */
+/* without over/underflow if the final result CTO*A(I,J)/CFROM */
+/* can be represented without over/underflow. CFROM must be */
+/* nonzero. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* The matrix to be multiplied by CTO/CFROM. See TYPE for the */
+/* storage type. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* INFO (output) INTEGER */
+/* 0 - successful exit */
+/* <0 - if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+
+ if (lsame_(type__, "G")) {
+ itype = 0;
+ } else if (lsame_(type__, "L")) {
+ itype = 1;
+ } else if (lsame_(type__, "U")) {
+ itype = 2;
+ } else if (lsame_(type__, "H")) {
+ itype = 3;
+ } else if (lsame_(type__, "B")) {
+ itype = 4;
+ } else if (lsame_(type__, "Q")) {
+ itype = 5;
+ } else if (lsame_(type__, "Z")) {
+ itype = 6;
+ } else {
+ itype = -1;
+ }
+
+ if (itype == -1) {
+ *info = -1;
+ } else if (*cfrom == 0. || disnan_(cfrom)) {
+ *info = -4;
+ } else if (disnan_(cto)) {
+ *info = -5;
+ } else if (*m < 0) {
+ *info = -6;
+ } else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) {
+ *info = -7;
+ } else if (itype <= 3 && *lda < max(1,*m)) {
+ *info = -9;
+ } else if (itype >= 4) {
+/* Computing MAX */
+ i__1 = *m - 1;
+ if (*kl < 0 || *kl > max(i__1,0)) {
+ *info = -2;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = *n - 1;
+ if (*ku < 0 || *ku > max(i__1,0) || (itype == 4 || itype == 5) &&
+ *kl != *ku) {
+ *info = -3;
+ } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < *
+ ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) {
+ *info = -9;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLASCL", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *m == 0) {
+ return 0;
+ }
+
+/* Get machine parameters */
+
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+
+ cfromc = *cfrom;
+ ctoc = *cto;
+
+L10:
+ cfrom1 = cfromc * smlnum;
+ if (cfrom1 == cfromc) {
+/* CFROMC is an inf. Multiply by a correctly signed zero for */
+/* finite CTOC, or a NaN if CTOC is infinite. */
+ mul = ctoc / cfromc;
+ done = TRUE_;
+ cto1 = ctoc;
+ } else {
+ cto1 = ctoc / bignum;
+ if (cto1 == ctoc) {
+/* CTOC is either 0 or an inf. In both cases, CTOC itself */
+/* serves as the correct multiplication factor. */
+ mul = ctoc;
+ done = TRUE_;
+ cfromc = 1.;
+ } else if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) {
+ mul = smlnum;
+ done = FALSE_;
+ cfromc = cfrom1;
+ } else if (abs(cto1) > abs(cfromc)) {
+ mul = bignum;
+ done = FALSE_;
+ ctoc = cto1;
+ } else {
+ mul = ctoc / cfromc;
+ done = TRUE_;
+ }
+ }
+
+ if (itype == 0) {
+
+/* Full matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L20: */
+ }
+/* L30: */
+ }
+
+ } else if (itype == 1) {
+
+/* Lower triangular matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L40: */
+ }
+/* L50: */
+ }
+
+ } else if (itype == 2) {
+
+/* Upper triangular matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(j,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L60: */
+ }
+/* L70: */
+ }
+
+ } else if (itype == 3) {
+
+/* Upper Hessenberg matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j + 1;
+ i__2 = min(i__3,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L80: */
+ }
+/* L90: */
+ }
+
+ } else if (itype == 4) {
+
+/* Lower half of a symmetric band matrix */
+
+ k3 = *kl + 1;
+ k4 = *n + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = k3, i__4 = k4 - j;
+ i__2 = min(i__3,i__4);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L100: */
+ }
+/* L110: */
+ }
+
+ } else if (itype == 5) {
+
+/* Upper half of a symmetric band matrix */
+
+ k1 = *ku + 2;
+ k3 = *ku + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = k1 - j;
+ i__3 = k3;
+ for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+ i__2 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L120: */
+ }
+/* L130: */
+ }
+
+ } else if (itype == 6) {
+
+/* Band matrix */
+
+ k1 = *kl + *ku + 2;
+ k2 = *kl + 1;
+ k3 = (*kl << 1) + *ku + 1;
+ k4 = *kl + *ku + 1 + *m;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__3 = k1 - j;
+/* Computing MIN */
+ i__4 = k3, i__5 = k4 - j;
+ i__2 = min(i__4,i__5);
+ for (i__ = max(i__3,k2); i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L140: */
+ }
+/* L150: */
+ }
+
+ }
+
+ if (! done) {
+ goto L10;
+ }
+
+ return 0;
+
+/* End of ZLASCL */
+
+} /* zlascl_ */
diff --git a/SRC/zlascl2.c b/SRC/zlascl2.c
new file mode 100644
index 0000000..4169fc0
--- /dev/null
+++ b/SRC/zlascl2.c
@@ -0,0 +1,95 @@
+/* zlascl2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlascl2_(integer *m, integer *n, doublereal *d__,
+ doublecomplex *x, integer *ldx)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLASCL2 performs a diagonal scaling on a vector: */
+/* x <-- D * x */
+/* where the DOUBLE PRECISION diagonal matrix D is stored as a vector. */
+
+/* Eventually to be replaced by BLAS_zge_diag_scale in the new BLAS */
+/* standard. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of D and X. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of D and X. N >= 0. */
+
+/* D (input) DOUBLE PRECISION array, length M */
+/* Diagonal matrix D, stored as a vector of length M. */
+
+/* X (input/output) COMPLEX*16 array, dimension (LDX,N) */
+/* On entry, the vector X to be scaled by D. */
+/* On exit, the scaled vector. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the vector X. LDX >= 0. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --d__;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+
+ /* Function Body */
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * x_dim1;
+ i__5 = i__;
+ z__1.r = d__[i__5] * x[i__4].r, z__1.i = d__[i__5] * x[i__4].i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ }
+ }
+ return 0;
+} /* zlascl2_ */
diff --git a/SRC/zlaset.c b/SRC/zlaset.c
new file mode 100644
index 0000000..6e07daf
--- /dev/null
+++ b/SRC/zlaset.c
@@ -0,0 +1,163 @@
+/* zlaset.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlaset_(char *uplo, integer *m, integer *n,
+ doublecomplex *alpha, doublecomplex *beta, doublecomplex *a, integer *
+ lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j;
+ extern logical lsame_(char *, char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLASET initializes a 2-D array A to BETA on the diagonal and */
+/* ALPHA on the offdiagonals. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies the part of the matrix A to be set. */
+/* = 'U': Upper triangular part is set. The lower triangle */
+/* is unchanged. */
+/* = 'L': Lower triangular part is set. The upper triangle */
+/* is unchanged. */
+/* Otherwise: All of the matrix A is set. */
+
+/* M (input) INTEGER */
+/* On entry, M specifies the number of rows of A. */
+
+/* N (input) INTEGER */
+/* On entry, N specifies the number of columns of A. */
+
+/* ALPHA (input) COMPLEX*16 */
+/* All the offdiagonal array elements are set to ALPHA. */
+
+/* BETA (input) COMPLEX*16 */
+/* All the diagonal array elements are set to BETA. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the m by n matrix A. */
+/* On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j; */
+/* A(i,i) = BETA , 1 <= i <= min(m,n) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ if (lsame_(uplo, "U")) {
+
+/* Set the diagonal to BETA and the strictly upper triangular */
+/* part of the array to ALPHA. */
+
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j - 1;
+ i__2 = min(i__3,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = alpha->r, a[i__3].i = alpha->i;
+/* L10: */
+ }
+/* L20: */
+ }
+ i__1 = min(*n,*m);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = beta->r, a[i__2].i = beta->i;
+/* L30: */
+ }
+
+ } else if (lsame_(uplo, "L")) {
+
+/* Set the diagonal to BETA and the strictly lower triangular */
+/* part of the array to ALPHA. */
+
+ i__1 = min(*m,*n);
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = alpha->r, a[i__3].i = alpha->i;
+/* L40: */
+ }
+/* L50: */
+ }
+ i__1 = min(*n,*m);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = beta->r, a[i__2].i = beta->i;
+/* L60: */
+ }
+
+ } else {
+
+/* Set the array to BETA on the diagonal and ALPHA on the */
+/* offdiagonal. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = alpha->r, a[i__3].i = alpha->i;
+/* L70: */
+ }
+/* L80: */
+ }
+ i__1 = min(*m,*n);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = beta->r, a[i__2].i = beta->i;
+/* L90: */
+ }
+ }
+
+ return 0;
+
+/* End of ZLASET */
+
+} /* zlaset_ */
diff --git a/SRC/zlasr.c b/SRC/zlasr.c
new file mode 100644
index 0000000..5fa4701
--- /dev/null
+++ b/SRC/zlasr.c
@@ -0,0 +1,610 @@
+/* zlasr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlasr_(char *side, char *pivot, char *direct, integer *m,
+ integer *n, doublereal *c__, doublereal *s, doublecomplex *a,
+ integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Local variables */
+ integer i__, j, info;
+ doublecomplex temp;
+ extern logical lsame_(char *, char *);
+ doublereal ctemp, stemp;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLASR applies a sequence of real plane rotations to a complex matrix */
+/* A, from either the left or the right. */
+
+/* When SIDE = 'L', the transformation takes the form */
+
+/* A := P*A */
+
+/* and when SIDE = 'R', the transformation takes the form */
+
+/* A := A*P**T */
+
+/* where P is an orthogonal matrix consisting of a sequence of z plane */
+/* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', */
+/* and P**T is the transpose of P. */
+
+/* When DIRECT = 'F' (Forward sequence), then */
+
+/* P = P(z-1) * ... * P(2) * P(1) */
+
+/* and when DIRECT = 'B' (Backward sequence), then */
+
+/* P = P(1) * P(2) * ... * P(z-1) */
+
+/* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation */
+
+/* R(k) = ( c(k) s(k) ) */
+/* = ( -s(k) c(k) ). */
+
+/* When PIVOT = 'V' (Variable pivot), the rotation is performed */
+/* for the plane (k,k+1), i.e., P(k) has the form */
+
+/* P(k) = ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+/* ( c(k) s(k) ) */
+/* ( -s(k) c(k) ) */
+/* ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+
+/* where R(k) appears as a rank-2 modification to the identity matrix in */
+/* rows and columns k and k+1. */
+
+/* When PIVOT = 'T' (Top pivot), the rotation is performed for the */
+/* plane (1,k+1), so P(k) has the form */
+
+/* P(k) = ( c(k) s(k) ) */
+/* ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+/* ( -s(k) c(k) ) */
+/* ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+
+/* where R(k) appears in rows and columns 1 and k+1. */
+
+/* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is */
+/* performed for the plane (k,z), giving P(k) the form */
+
+/* P(k) = ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+/* ( c(k) s(k) ) */
+/* ( 1 ) */
+/* ( ... ) */
+/* ( 1 ) */
+/* ( -s(k) c(k) ) */
+
+/* where R(k) appears in rows and columns k and z. The rotations are */
+/* performed without ever forming P(k) explicitly. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* Specifies whether the plane rotation matrix P is applied to */
+/* A on the left or the right. */
+/* = 'L': Left, compute A := P*A */
+/* = 'R': Right, compute A:= A*P**T */
+
+/* PIVOT (input) CHARACTER*1 */
+/* Specifies the plane for which P(k) is a plane rotation */
+/* matrix. */
+/* = 'V': Variable pivot, the plane (k,k+1) */
+/* = 'T': Top pivot, the plane (1,k+1) */
+/* = 'B': Bottom pivot, the plane (k,z) */
+
+/* DIRECT (input) CHARACTER*1 */
+/* Specifies whether P is a forward or backward sequence of */
+/* plane rotations. */
+/* = 'F': Forward, P = P(z-1)*...*P(2)*P(1) */
+/* = 'B': Backward, P = P(1)*P(2)*...*P(z-1) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. If m <= 1, an immediate */
+/* return is effected. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. If n <= 1, an */
+/* immediate return is effected. */
+
+/* C (input) DOUBLE PRECISION array, dimension */
+/* (M-1) if SIDE = 'L' */
+/* (N-1) if SIDE = 'R' */
+/* The cosines c(k) of the plane rotations. */
+
+/* S (input) DOUBLE PRECISION array, dimension */
+/* (M-1) if SIDE = 'L' */
+/* (N-1) if SIDE = 'R' */
+/* The sines s(k) of the plane rotations. The 2-by-2 plane */
+/* rotation part of the matrix P(k), R(k), has the form */
+/* R(k) = ( c(k) s(k) ) */
+/* ( -s(k) c(k) ). */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* The M-by-N matrix A. On exit, A is overwritten by P*A if */
+/* SIDE = 'R' or by A*P**T if SIDE = 'L'. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ --c__;
+ --s;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ info = 0;
+ if (! (lsame_(side, "L") || lsame_(side, "R"))) {
+ info = 1;
+ } else if (! (lsame_(pivot, "V") || lsame_(pivot,
+ "T") || lsame_(pivot, "B"))) {
+ info = 2;
+ } else if (! (lsame_(direct, "F") || lsame_(direct,
+ "B"))) {
+ info = 3;
+ } else if (*m < 0) {
+ info = 4;
+ } else if (*n < 0) {
+ info = 5;
+ } else if (*lda < max(1,*m)) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("ZLASR ", &info);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+ if (lsame_(side, "L")) {
+
+/* Form P * A */
+
+ if (lsame_(pivot, "V")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1. || stemp != 0.) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = j + 1 + i__ * a_dim1;
+ temp.r = a[i__3].r, temp.i = a[i__3].i;
+ i__3 = j + 1 + i__ * a_dim1;
+ z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i;
+ i__4 = j + i__ * a_dim1;
+ z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[
+ i__4].i;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
+ z__3.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ i__3 = j + i__ * a_dim1;
+ z__2.r = stemp * temp.r, z__2.i = stemp * temp.i;
+ i__4 = j + i__ * a_dim1;
+ z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[
+ i__4].i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
+ z__3.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L10: */
+ }
+ }
+/* L20: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *m - 1; j >= 1; --j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1. || stemp != 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = j + 1 + i__ * a_dim1;
+ temp.r = a[i__2].r, temp.i = a[i__2].i;
+ i__2 = j + 1 + i__ * a_dim1;
+ z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i;
+ i__3 = j + i__ * a_dim1;
+ z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[
+ i__3].i;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
+ z__3.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ i__2 = j + i__ * a_dim1;
+ z__2.r = stemp * temp.r, z__2.i = stemp * temp.i;
+ i__3 = j + i__ * a_dim1;
+ z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[
+ i__3].i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
+ z__3.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L30: */
+ }
+ }
+/* L40: */
+ }
+ }
+ } else if (lsame_(pivot, "T")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *m;
+ for (j = 2; j <= i__1; ++j) {
+ ctemp = c__[j - 1];
+ stemp = s[j - 1];
+ if (ctemp != 1. || stemp != 0.) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * a_dim1;
+ temp.r = a[i__3].r, temp.i = a[i__3].i;
+ i__3 = j + i__ * a_dim1;
+ z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i;
+ i__4 = i__ * a_dim1 + 1;
+ z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[
+ i__4].i;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
+ z__3.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ i__3 = i__ * a_dim1 + 1;
+ z__2.r = stemp * temp.r, z__2.i = stemp * temp.i;
+ i__4 = i__ * a_dim1 + 1;
+ z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[
+ i__4].i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
+ z__3.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *m; j >= 2; --j) {
+ ctemp = c__[j - 1];
+ stemp = s[j - 1];
+ if (ctemp != 1. || stemp != 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = j + i__ * a_dim1;
+ temp.r = a[i__2].r, temp.i = a[i__2].i;
+ i__2 = j + i__ * a_dim1;
+ z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i;
+ i__3 = i__ * a_dim1 + 1;
+ z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[
+ i__3].i;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
+ z__3.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ i__2 = i__ * a_dim1 + 1;
+ z__2.r = stemp * temp.r, z__2.i = stemp * temp.i;
+ i__3 = i__ * a_dim1 + 1;
+ z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[
+ i__3].i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
+ z__3.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L70: */
+ }
+ }
+/* L80: */
+ }
+ }
+ } else if (lsame_(pivot, "B")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1. || stemp != 0.) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * a_dim1;
+ temp.r = a[i__3].r, temp.i = a[i__3].i;
+ i__3 = j + i__ * a_dim1;
+ i__4 = *m + i__ * a_dim1;
+ z__2.r = stemp * a[i__4].r, z__2.i = stemp * a[
+ i__4].i;
+ z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
+ z__3.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ i__3 = *m + i__ * a_dim1;
+ i__4 = *m + i__ * a_dim1;
+ z__2.r = ctemp * a[i__4].r, z__2.i = ctemp * a[
+ i__4].i;
+ z__3.r = stemp * temp.r, z__3.i = stemp * temp.i;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
+ z__3.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L90: */
+ }
+ }
+/* L100: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *m - 1; j >= 1; --j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1. || stemp != 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = j + i__ * a_dim1;
+ temp.r = a[i__2].r, temp.i = a[i__2].i;
+ i__2 = j + i__ * a_dim1;
+ i__3 = *m + i__ * a_dim1;
+ z__2.r = stemp * a[i__3].r, z__2.i = stemp * a[
+ i__3].i;
+ z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
+ z__3.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ i__2 = *m + i__ * a_dim1;
+ i__3 = *m + i__ * a_dim1;
+ z__2.r = ctemp * a[i__3].r, z__2.i = ctemp * a[
+ i__3].i;
+ z__3.r = stemp * temp.r, z__3.i = stemp * temp.i;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
+ z__3.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L110: */
+ }
+ }
+/* L120: */
+ }
+ }
+ }
+ } else if (lsame_(side, "R")) {
+
+/* Form A * P' */
+
+ if (lsame_(pivot, "V")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1. || stemp != 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j + 1) * a_dim1;
+ temp.r = a[i__3].r, temp.i = a[i__3].i;
+ i__3 = i__ + (j + 1) * a_dim1;
+ z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i;
+ i__4 = i__ + j * a_dim1;
+ z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[
+ i__4].i;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
+ z__3.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ i__3 = i__ + j * a_dim1;
+ z__2.r = stemp * temp.r, z__2.i = stemp * temp.i;
+ i__4 = i__ + j * a_dim1;
+ z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[
+ i__4].i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
+ z__3.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L130: */
+ }
+ }
+/* L140: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *n - 1; j >= 1; --j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1. || stemp != 0.) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + (j + 1) * a_dim1;
+ temp.r = a[i__2].r, temp.i = a[i__2].i;
+ i__2 = i__ + (j + 1) * a_dim1;
+ z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i;
+ i__3 = i__ + j * a_dim1;
+ z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[
+ i__3].i;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
+ z__3.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ i__2 = i__ + j * a_dim1;
+ z__2.r = stemp * temp.r, z__2.i = stemp * temp.i;
+ i__3 = i__ + j * a_dim1;
+ z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[
+ i__3].i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
+ z__3.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L150: */
+ }
+ }
+/* L160: */
+ }
+ }
+ } else if (lsame_(pivot, "T")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ ctemp = c__[j - 1];
+ stemp = s[j - 1];
+ if (ctemp != 1. || stemp != 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ temp.r = a[i__3].r, temp.i = a[i__3].i;
+ i__3 = i__ + j * a_dim1;
+ z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i;
+ i__4 = i__ + a_dim1;
+ z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[
+ i__4].i;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
+ z__3.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ i__3 = i__ + a_dim1;
+ z__2.r = stemp * temp.r, z__2.i = stemp * temp.i;
+ i__4 = i__ + a_dim1;
+ z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[
+ i__4].i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
+ z__3.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L170: */
+ }
+ }
+/* L180: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *n; j >= 2; --j) {
+ ctemp = c__[j - 1];
+ stemp = s[j - 1];
+ if (ctemp != 1. || stemp != 0.) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * a_dim1;
+ temp.r = a[i__2].r, temp.i = a[i__2].i;
+ i__2 = i__ + j * a_dim1;
+ z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i;
+ i__3 = i__ + a_dim1;
+ z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[
+ i__3].i;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
+ z__3.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ i__2 = i__ + a_dim1;
+ z__2.r = stemp * temp.r, z__2.i = stemp * temp.i;
+ i__3 = i__ + a_dim1;
+ z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[
+ i__3].i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
+ z__3.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L190: */
+ }
+ }
+/* L200: */
+ }
+ }
+ } else if (lsame_(pivot, "B")) {
+ if (lsame_(direct, "F")) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1. || stemp != 0.) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ temp.r = a[i__3].r, temp.i = a[i__3].i;
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + *n * a_dim1;
+ z__2.r = stemp * a[i__4].r, z__2.i = stemp * a[
+ i__4].i;
+ z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
+ z__3.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ i__3 = i__ + *n * a_dim1;
+ i__4 = i__ + *n * a_dim1;
+ z__2.r = ctemp * a[i__4].r, z__2.i = ctemp * a[
+ i__4].i;
+ z__3.r = stemp * temp.r, z__3.i = stemp * temp.i;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
+ z__3.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L210: */
+ }
+ }
+/* L220: */
+ }
+ } else if (lsame_(direct, "B")) {
+ for (j = *n - 1; j >= 1; --j) {
+ ctemp = c__[j];
+ stemp = s[j];
+ if (ctemp != 1. || stemp != 0.) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * a_dim1;
+ temp.r = a[i__2].r, temp.i = a[i__2].i;
+ i__2 = i__ + j * a_dim1;
+ i__3 = i__ + *n * a_dim1;
+ z__2.r = stemp * a[i__3].r, z__2.i = stemp * a[
+ i__3].i;
+ z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i +
+ z__3.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ i__2 = i__ + *n * a_dim1;
+ i__3 = i__ + *n * a_dim1;
+ z__2.r = ctemp * a[i__3].r, z__2.i = ctemp * a[
+ i__3].i;
+ z__3.r = stemp * temp.r, z__3.i = stemp * temp.i;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i -
+ z__3.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L230: */
+ }
+ }
+/* L240: */
+ }
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZLASR */
+
+} /* zlasr_ */
diff --git a/SRC/zlassq.c b/SRC/zlassq.c
new file mode 100644
index 0000000..0c0f42a
--- /dev/null
+++ b/SRC/zlassq.c
@@ -0,0 +1,138 @@
+/* zlassq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlassq_(integer *n, doublecomplex *x, integer *incx,
+ doublereal *scale, doublereal *sumsq)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer ix;
+ doublereal temp1;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLASSQ returns the values scl and ssq such that */
+
+/* ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, */
+
+/* where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is */
+/* assumed to be at least unity and the value of ssq will then satisfy */
+
+/* 1.0 .le. ssq .le. ( sumsq + 2*n ). */
+
+/* scale is assumed to be non-negative and scl returns the value */
+
+/* scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ), */
+/* i */
+
+/* scale and sumsq must be supplied in SCALE and SUMSQ respectively. */
+/* SCALE and SUMSQ are overwritten by scl and ssq respectively. */
+
+/* The routine makes only one pass through the vector X. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of elements to be used from the vector X. */
+
+/* X (input) COMPLEX*16 array, dimension (N) */
+/* The vector x as described above. */
+/* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. */
+
+/* INCX (input) INTEGER */
+/* The increment between successive values of the vector X. */
+/* INCX > 0. */
+
+/* SCALE (input/output) DOUBLE PRECISION */
+/* On entry, the value scale in the equation above. */
+/* On exit, SCALE is overwritten with the value scl . */
+
+/* SUMSQ (input/output) DOUBLE PRECISION */
+/* On entry, the value sumsq in the equation above. */
+/* On exit, SUMSQ is overwritten with the value ssq . */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --x;
+
+ /* Function Body */
+ if (*n > 0) {
+ i__1 = (*n - 1) * *incx + 1;
+ i__2 = *incx;
+ for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
+ i__3 = ix;
+ if (x[i__3].r != 0.) {
+ i__3 = ix;
+ temp1 = (d__1 = x[i__3].r, abs(d__1));
+ if (*scale < temp1) {
+/* Computing 2nd power */
+ d__1 = *scale / temp1;
+ *sumsq = *sumsq * (d__1 * d__1) + 1;
+ *scale = temp1;
+ } else {
+/* Computing 2nd power */
+ d__1 = temp1 / *scale;
+ *sumsq += d__1 * d__1;
+ }
+ }
+ if (d_imag(&x[ix]) != 0.) {
+ temp1 = (d__1 = d_imag(&x[ix]), abs(d__1));
+ if (*scale < temp1) {
+/* Computing 2nd power */
+ d__1 = *scale / temp1;
+ *sumsq = *sumsq * (d__1 * d__1) + 1;
+ *scale = temp1;
+ } else {
+/* Computing 2nd power */
+ d__1 = temp1 / *scale;
+ *sumsq += d__1 * d__1;
+ }
+ }
+/* L10: */
+ }
+ }
+
+ return 0;
+
+/* End of ZLASSQ */
+
+} /* zlassq_ */
diff --git a/SRC/zlaswp.c b/SRC/zlaswp.c
new file mode 100644
index 0000000..3956e40
--- /dev/null
+++ b/SRC/zlaswp.c
@@ -0,0 +1,166 @@
+/* zlaswp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlaswp_(integer *n, doublecomplex *a, integer *lda,
+ integer *k1, integer *k2, integer *ipiv, integer *incx)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+
+ /* Local variables */
+ integer i__, j, k, i1, i2, n32, ip, ix, ix0, inc;
+ doublecomplex temp;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLASWP performs a series of row interchanges on the matrix A. */
+/* One row interchange is initiated for each of rows K1 through K2 of A. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the matrix of column dimension N to which the row */
+/* interchanges will be applied. */
+/* On exit, the permuted matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* K1 (input) INTEGER */
+/* The first element of IPIV for which a row interchange will */
+/* be done. */
+
+/* K2 (input) INTEGER */
+/* The last element of IPIV for which a row interchange will */
+/* be done. */
+
+/* IPIV (input) INTEGER array, dimension (K2*abs(INCX)) */
+/* The vector of pivot indices. Only the elements in positions */
+/* K1 through K2 of IPIV are accessed. */
+/* IPIV(K) = L implies rows K and L are to be interchanged. */
+
+/* INCX (input) INTEGER */
+/* The increment between successive values of IPIV. If IPIV */
+/* is negative, the pivots are applied in reverse order. */
+
+/* Further Details */
+/* =============== */
+
+/* Modified by */
+/* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Interchange row I with row IPIV(I) for each of rows K1 through K2. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ if (*incx > 0) {
+ ix0 = *k1;
+ i1 = *k1;
+ i2 = *k2;
+ inc = 1;
+ } else if (*incx < 0) {
+ ix0 = (1 - *k2) * *incx + 1;
+ i1 = *k2;
+ i2 = *k1;
+ inc = -1;
+ } else {
+ return 0;
+ }
+
+ n32 = *n / 32 << 5;
+ if (n32 != 0) {
+ i__1 = n32;
+ for (j = 1; j <= i__1; j += 32) {
+ ix = ix0;
+ i__2 = i2;
+ i__3 = inc;
+ for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3)
+ {
+ ip = ipiv[ix];
+ if (ip != i__) {
+ i__4 = j + 31;
+ for (k = j; k <= i__4; ++k) {
+ i__5 = i__ + k * a_dim1;
+ temp.r = a[i__5].r, temp.i = a[i__5].i;
+ i__5 = i__ + k * a_dim1;
+ i__6 = ip + k * a_dim1;
+ a[i__5].r = a[i__6].r, a[i__5].i = a[i__6].i;
+ i__5 = ip + k * a_dim1;
+ a[i__5].r = temp.r, a[i__5].i = temp.i;
+/* L10: */
+ }
+ }
+ ix += *incx;
+/* L20: */
+ }
+/* L30: */
+ }
+ }
+ if (n32 != *n) {
+ ++n32;
+ ix = ix0;
+ i__1 = i2;
+ i__3 = inc;
+ for (i__ = i1; i__3 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__3) {
+ ip = ipiv[ix];
+ if (ip != i__) {
+ i__2 = *n;
+ for (k = n32; k <= i__2; ++k) {
+ i__4 = i__ + k * a_dim1;
+ temp.r = a[i__4].r, temp.i = a[i__4].i;
+ i__4 = i__ + k * a_dim1;
+ i__5 = ip + k * a_dim1;
+ a[i__4].r = a[i__5].r, a[i__4].i = a[i__5].i;
+ i__4 = ip + k * a_dim1;
+ a[i__4].r = temp.r, a[i__4].i = temp.i;
+/* L40: */
+ }
+ }
+ ix += *incx;
+/* L50: */
+ }
+ }
+
+ return 0;
+
+/* End of ZLASWP */
+
+} /* zlaswp_ */
diff --git a/SRC/zlasyf.c b/SRC/zlasyf.c
new file mode 100644
index 0000000..e55fc2c
--- /dev/null
+++ b/SRC/zlasyf.c
@@ -0,0 +1,831 @@
+/* zlasyf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zlasyf_(char *uplo, integer *n, integer *nb, integer *kb,
+ doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *w,
+ integer *ldw, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_imag(doublecomplex *);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer j, k;
+ doublecomplex t, r1, d11, d21, d22;
+ integer jb, jj, kk, jp, kp, kw, kkw, imax, jmax;
+ doublereal alpha;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zgemm_(char *, char *, integer *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer kstep;
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zswap_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ doublereal absakk, colmax;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ doublereal rowmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLASYF computes a partial factorization of a complex symmetric matrix */
+/* A using the Bunch-Kaufman 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' U22' ) */
+
+/* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) 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. */
+/* Note that U' denotes the transpose of U. */
+
+/* ZLASYF is an auxiliary routine called by ZSYTRF. It uses blocked code */
+/* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or */
+/* A22 (if UPLO = 'L'). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NB (input) 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. */
+
+/* KB (output) INTEGER */
+/* The number of columns of A that were actually factored. */
+/* KB is either NB-1 or NB, or N if N <= NB. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n-by-n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n-by-n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+/* On exit, A contains details of the partial factorization. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If UPLO = 'U', only the last KB elements of IPIV are set; */
+/* if UPLO = 'L', only the first KB elements are set. */
+
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* W (workspace) COMPLEX*16 array, dimension (LDW,NB) */
+
+/* LDW (input) INTEGER */
+/* The leading dimension of the array W. LDW >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* > 0: if INFO = k, D(k,k) is exactly zero. The factorization */
+/* has been completed, but the block diagonal matrix D is */
+/* exactly singular. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ w_dim1 = *ldw;
+ w_offset = 1 + w_dim1;
+ w -= w_offset;
+
+ /* Function Body */
+ *info = 0;
+
+/* Initialize ALPHA for use in choosing pivot block size. */
+
+ alpha = (sqrt(17.) + 1.) / 8.;
+
+ if (lsame_(uplo, "U")) {
+
+/* 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 */
+
+/* K is the main loop index, decreasing from N in steps of 1 or 2 */
+
+/* KW is the column of W which corresponds to column K of A */
+
+ k = *n;
+L10:
+ kw = *nb + k - *n;
+
+/* Exit from loop */
+
+ if (k <= *n - *nb + 1 && *nb < *n || k < 1) {
+ goto L30;
+ }
+
+/* Copy column K of A to column KW of W and update it */
+
+ zcopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1);
+ if (k < *n) {
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * a_dim1 + 1],
+ lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw *
+ w_dim1 + 1], &c__1);
+ }
+
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = k + kw * w_dim1;
+ absakk = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[k + kw *
+ w_dim1]), abs(d__2));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ imax = izamax_(&i__1, &w[kw * w_dim1 + 1], &c__1);
+ i__1 = imax + kw * w_dim1;
+ colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax +
+ kw * w_dim1]), abs(d__2));
+ } else {
+ colmax = 0.;
+ }
+
+ if (max(absakk,colmax) == 0.) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* Copy column IMAX to column KW-1 of W and update it */
+
+ zcopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) *
+ w_dim1 + 1], &c__1);
+ i__1 = k - imax;
+ zcopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax +
+ 1 + (kw - 1) * w_dim1], &c__1);
+ if (k < *n) {
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) *
+ a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1],
+ ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1);
+ }
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = k - imax;
+ jmax = imax + izamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1],
+ &c__1);
+ i__1 = jmax + (kw - 1) * w_dim1;
+ rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[
+ jmax + (kw - 1) * w_dim1]), abs(d__2));
+ if (imax > 1) {
+ i__1 = imax - 1;
+ jmax = izamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__1 = jmax + (kw - 1) * w_dim1;
+ d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) + (
+ d__2 = d_imag(&w[jmax + (kw - 1) * w_dim1]), abs(
+ d__2));
+ rowmax = max(d__3,d__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = imax + (kw - 1) * w_dim1;
+ if ((d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[
+ imax + (kw - 1) * w_dim1]), abs(d__2)) >= alpha *
+ rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+
+/* copy column KW-1 of W to column KW */
+
+ zcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw *
+ w_dim1 + 1], &c__1);
+ } else {
+
+/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k - kstep + 1;
+ kkw = *nb + kk - *n;
+
+/* Updated column KP is already stored in column KKW of W */
+
+ if (kp != kk) {
+
+/* Copy non-updated column KK to column KP */
+
+ i__1 = kp + k * a_dim1;
+ i__2 = kk + k * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = k - 1 - kp;
+ zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp +
+ 1) * a_dim1], lda);
+ zcopy_(&kp, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &
+ c__1);
+
+/* Interchange rows KK and KP in last KK columns of A and W */
+
+ i__1 = *n - kk + 1;
+ zswap_(&i__1, &a[kk + kk * a_dim1], lda, &a[kp + kk * a_dim1],
+ lda);
+ i__1 = *n - kk + 1;
+ zswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw *
+ w_dim1], ldw);
+ }
+
+ if (kstep == 1) {
+
+/* 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 */
+
+ zcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &
+ c__1);
+ z_div(&z__1, &c_b1, &a[k + k * a_dim1]);
+ r1.r = z__1.r, r1.i = z__1.i;
+ i__1 = k - 1;
+ zscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
+ } 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 > 2) {
+
+/* Store U(k) and U(k-1) in columns k and k-1 of A */
+
+ i__1 = k - 1 + kw * w_dim1;
+ d21.r = w[i__1].r, d21.i = w[i__1].i;
+ z_div(&z__1, &w[k + kw * w_dim1], &d21);
+ d11.r = z__1.r, d11.i = z__1.i;
+ z_div(&z__1, &w[k - 1 + (kw - 1) * w_dim1], &d21);
+ d22.r = z__1.r, d22.i = z__1.i;
+ z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r *
+ d22.i + d11.i * d22.r;
+ z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.;
+ z_div(&z__1, &c_b1, &z__2);
+ t.r = z__1.r, t.i = z__1.i;
+ z_div(&z__1, &t, &d21);
+ d21.r = z__1.r, d21.i = z__1.i;
+ i__1 = k - 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + (k - 1) * a_dim1;
+ i__3 = j + (kw - 1) * w_dim1;
+ z__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
+ z__3.i = d11.r * w[i__3].i + d11.i * w[i__3]
+ .r;
+ i__4 = j + kw * w_dim1;
+ z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4]
+ .i;
+ z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i =
+ d21.r * z__2.i + d21.i * z__2.r;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ i__2 = j + k * a_dim1;
+ i__3 = j + kw * w_dim1;
+ z__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
+ z__3.i = d22.r * w[i__3].i + d22.i * w[i__3]
+ .r;
+ i__4 = j + (kw - 1) * w_dim1;
+ z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4]
+ .i;
+ z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i =
+ d21.r * z__2.i + d21.i * z__2.r;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L20: */
+ }
+ }
+
+/* Copy D(k) to A */
+
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ i__2 = k - 1 + (kw - 1) * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+ i__1 = k - 1 + k * a_dim1;
+ i__2 = k - 1 + kw * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+ i__1 = k + k * a_dim1;
+ i__2 = k + kw * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k - 1] = -kp;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kstep;
+ goto L10;
+
+L30:
+
+/* Update the upper triangle of A11 (= A(1:k,1:k)) as */
+
+/* A11 := A11 - U12*D*U12' = A11 - U12*W' */
+
+/* computing blocks of NB columns at a time */
+
+ i__1 = -(*nb);
+ for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j +=
+ i__1) {
+/* Computing MIN */
+ i__2 = *nb, i__3 = k - j + 1;
+ jb = min(i__2,i__3);
+
+/* Update the upper triangle of the diagonal block */
+
+ i__2 = j + jb - 1;
+ for (jj = j; jj <= i__2; ++jj) {
+ i__3 = jj - j + 1;
+ i__4 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__3, &i__4, &z__1, &a[j + (k + 1) *
+ a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b1,
+ &a[j + jj * a_dim1], &c__1);
+/* L40: */
+ }
+
+/* Update the rectangular superdiagonal block */
+
+ i__2 = j - 1;
+ i__3 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &z__1, &a[(
+ k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * w_dim1], ldw,
+ &c_b1, &a[j * a_dim1 + 1], lda);
+/* L50: */
+ }
+
+/* Put U12 in standard form by partially undoing the interchanges */
+/* in columns k+1:n */
+
+ j = k + 1;
+L60:
+ jj = j;
+ jp = ipiv[j];
+ if (jp < 0) {
+ jp = -jp;
+ ++j;
+ }
+ ++j;
+ if (jp != jj && j <= *n) {
+ i__1 = *n - j + 1;
+ zswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda);
+ }
+ if (j <= *n) {
+ goto L60;
+ }
+
+/* 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 */
+
+/* K is the main loop index, increasing from 1 in steps of 1 or 2 */
+
+ k = 1;
+L70:
+
+/* Exit from loop */
+
+ if (k >= *nb && *nb < *n || k > *n) {
+ goto L90;
+ }
+
+/* Copy column K of A to column K of W and update it */
+
+ i__1 = *n - k + 1;
+ zcopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1);
+ i__1 = *n - k + 1;
+ i__2 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], lda, &w[k
+ + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1);
+
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = k + k * w_dim1;
+ absakk = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[k + k *
+ w_dim1]), abs(d__2));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ imax = k + izamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1);
+ i__1 = imax + k * w_dim1;
+ colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax +
+ k * w_dim1]), abs(d__2));
+ } else {
+ colmax = 0.;
+ }
+
+ if (max(absakk,colmax) == 0.) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* Copy column IMAX to column K+1 of W and update it */
+
+ i__1 = imax - k;
+ zcopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) *
+ w_dim1], &c__1);
+ i__1 = *n - imax + 1;
+ zcopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k +
+ 1) * w_dim1], &c__1);
+ i__1 = *n - k + 1;
+ i__2 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1],
+ lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + 1) *
+ w_dim1], &c__1);
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = imax - k;
+ jmax = k - 1 + izamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1)
+ ;
+ i__1 = jmax + (k + 1) * w_dim1;
+ rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[
+ jmax + (k + 1) * w_dim1]), abs(d__2));
+ if (imax < *n) {
+ i__1 = *n - imax;
+ jmax = imax + izamax_(&i__1, &w[imax + 1 + (k + 1) *
+ w_dim1], &c__1);
+/* Computing MAX */
+ i__1 = jmax + (k + 1) * w_dim1;
+ d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) + (
+ d__2 = d_imag(&w[jmax + (k + 1) * w_dim1]), abs(
+ d__2));
+ rowmax = max(d__3,d__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = imax + (k + 1) * w_dim1;
+ if ((d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[
+ imax + (k + 1) * w_dim1]), abs(d__2)) >= alpha *
+ rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+
+/* copy column K+1 of W to column K */
+
+ i__1 = *n - k + 1;
+ zcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k +
+ k * w_dim1], &c__1);
+ } else {
+
+/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k + kstep - 1;
+
+/* Updated column KP is already stored in column KK of W */
+
+ if (kp != kk) {
+
+/* Copy non-updated column KK to column KP */
+
+ i__1 = kp + k * a_dim1;
+ i__2 = kk + k * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp - k - 1;
+ zcopy_(&i__1, &a[k + 1 + kk * a_dim1], &c__1, &a[kp + (k + 1)
+ * a_dim1], lda);
+ i__1 = *n - kp + 1;
+ zcopy_(&i__1, &a[kp + kk * a_dim1], &c__1, &a[kp + kp *
+ a_dim1], &c__1);
+
+/* Interchange rows KK and KP in first KK columns of A and W */
+
+ zswap_(&kk, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda);
+ zswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw);
+ }
+
+ if (kstep == 1) {
+
+/* 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 */
+
+ i__1 = *n - k + 1;
+ zcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], &
+ c__1);
+ if (k < *n) {
+ z_div(&z__1, &c_b1, &a[k + k * a_dim1]);
+ r1.r = z__1.r, r1.i = z__1.i;
+ i__1 = *n - k;
+ zscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1);
+ }
+ } 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 < *n - 1) {
+
+/* Store L(k) and L(k+1) in columns k and k+1 of A */
+
+ i__1 = k + 1 + k * w_dim1;
+ d21.r = w[i__1].r, d21.i = w[i__1].i;
+ z_div(&z__1, &w[k + 1 + (k + 1) * w_dim1], &d21);
+ d11.r = z__1.r, d11.i = z__1.i;
+ z_div(&z__1, &w[k + k * w_dim1], &d21);
+ d22.r = z__1.r, d22.i = z__1.i;
+ z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r *
+ d22.i + d11.i * d22.r;
+ z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.;
+ z_div(&z__1, &c_b1, &z__2);
+ t.r = z__1.r, t.i = z__1.i;
+ z_div(&z__1, &t, &d21);
+ d21.r = z__1.r, d21.i = z__1.i;
+ i__1 = *n;
+ for (j = k + 2; j <= i__1; ++j) {
+ i__2 = j + k * a_dim1;
+ i__3 = j + k * w_dim1;
+ z__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i,
+ z__3.i = d11.r * w[i__3].i + d11.i * w[i__3]
+ .r;
+ i__4 = j + (k + 1) * w_dim1;
+ z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4]
+ .i;
+ z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i =
+ d21.r * z__2.i + d21.i * z__2.r;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ i__2 = j + (k + 1) * a_dim1;
+ i__3 = j + (k + 1) * w_dim1;
+ z__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i,
+ z__3.i = d22.r * w[i__3].i + d22.i * w[i__3]
+ .r;
+ i__4 = j + k * w_dim1;
+ z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4]
+ .i;
+ z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i =
+ d21.r * z__2.i + d21.i * z__2.r;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L80: */
+ }
+ }
+
+/* Copy D(k) to A */
+
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+ i__1 = k + 1 + k * a_dim1;
+ i__2 = k + 1 + k * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ i__2 = k + 1 + (k + 1) * w_dim1;
+ a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i;
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k + 1] = -kp;
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kstep;
+ goto L70;
+
+L90:
+
+/* Update the lower triangle of A22 (= A(k:n,k:n)) as */
+
+/* A22 := A22 - L21*D*L21' = A22 - L21*W' */
+
+/* computing blocks of NB columns at a time */
+
+ i__1 = *n;
+ i__2 = *nb;
+ for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = *nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+
+/* Update the lower triangle of the diagonal block */
+
+ i__3 = j + jb - 1;
+ for (jj = j; jj <= i__3; ++jj) {
+ i__4 = j + jb - jj;
+ i__5 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__4, &i__5, &z__1, &a[jj + a_dim1],
+ lda, &w[jj + w_dim1], ldw, &c_b1, &a[jj + jj * a_dim1]
+, &c__1);
+/* L100: */
+ }
+
+/* Update the rectangular subdiagonal block */
+
+ if (j + jb <= *n) {
+ i__3 = *n - j - jb + 1;
+ i__4 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &z__1,
+ &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b1,
+ &a[j + jb + j * a_dim1], lda);
+ }
+/* L110: */
+ }
+
+/* Put L21 in standard form by partially undoing the interchanges */
+/* in columns 1:k-1 */
+
+ j = k - 1;
+L120:
+ jj = j;
+ jp = ipiv[j];
+ if (jp < 0) {
+ jp = -jp;
+ --j;
+ }
+ --j;
+ if (jp != jj && j >= 1) {
+ zswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda);
+ }
+ if (j >= 1) {
+ goto L120;
+ }
+
+/* Set KB to the number of columns factorized */
+
+ *kb = k - 1;
+
+ }
+ return 0;
+
+/* End of ZLASYF */
+
+} /* zlasyf_ */
diff --git a/SRC/zlat2c.c b/SRC/zlat2c.c
new file mode 100644
index 0000000..d7a943d
--- /dev/null
+++ b/SRC/zlat2c.c
@@ -0,0 +1,152 @@
+/* zlat2c.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlat2c_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, complex *sa, integer *ldsa, integer *info)
+{
+ /* System generated locals */
+ integer sa_dim1, sa_offset, a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal rmax;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK PROTOTYPE auxiliary routine (version 3.1.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* May 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAT2C converts a COMPLEX*16 triangular matrix, SA, to a COMPLEX */
+/* triangular matrix, A. */
+
+/* RMAX is the overflow for the SINGLE PRECISION arithmetic */
+/* ZLAT2C checks that all the entries of A are between -RMAX and */
+/* RMAX. If not the convertion is aborted and a flag is raised. */
+
+/* This is an auxiliary routine so there is no argument checking. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the N-by-N triangular coefficient matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* SA (output) COMPLEX array, dimension (LDSA,N) */
+/* Only the UPLO part of SA is referenced. On exit, if INFO=0, */
+/* the N-by-N coefficient matrix SA; if INFO>0, the content of */
+/* the UPLO part of SA is unspecified. */
+
+/* LDSA (input) INTEGER */
+/* The leading dimension of the array SA. LDSA >= max(1,M). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* = 1: an entry of the matrix A is greater than the SINGLE */
+/* PRECISION overflow threshold, in this case, the content */
+/* of the UPLO part of SA in exit is unspecified. */
+
+/* ========= */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ sa_dim1 = *ldsa;
+ sa_offset = 1 + sa_dim1;
+ sa -= sa_offset;
+
+ /* Function Body */
+ rmax = slamch_("O");
+ upper = lsame_(uplo, "U");
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ if (a[i__3].r < -rmax || a[i__4].r > rmax || d_imag(&a[i__ +
+ j * a_dim1]) < -rmax || d_imag(&a[i__ + j * a_dim1])
+ > rmax) {
+ *info = 1;
+ goto L50;
+ }
+ i__3 = i__ + j * sa_dim1;
+ i__4 = i__ + j * a_dim1;
+ sa[i__3].r = a[i__4].r, sa[i__3].i = a[i__4].i;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ if (a[i__3].r < -rmax || a[i__4].r > rmax || d_imag(&a[i__ +
+ j * a_dim1]) < -rmax || d_imag(&a[i__ + j * a_dim1])
+ > rmax) {
+ *info = 1;
+ goto L50;
+ }
+ i__3 = i__ + j * sa_dim1;
+ i__4 = i__ + j * a_dim1;
+ sa[i__3].r = a[i__4].r, sa[i__3].i = a[i__4].i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+L50:
+
+ return 0;
+
+/* End of ZLAT2C */
+
+} /* zlat2c_ */
diff --git a/SRC/zlatbs.c b/SRC/zlatbs.c
new file mode 100644
index 0000000..f9629aa
--- /dev/null
+++ b/SRC/zlatbs.c
@@ -0,0 +1,1195 @@
+/* zlatbs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b36 = .5;
+
+/* Subroutine */ int zlatbs_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, integer *kd, doublecomplex *ab, integer *ldab,
+ doublecomplex *x, doublereal *scale, doublereal *cnorm, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal xj, rec, tjj;
+ integer jinc, jlen;
+ doublereal xbnd;
+ integer imax;
+ doublereal tmax;
+ doublecomplex tjjs;
+ doublereal xmax, grow;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ integer maind;
+ extern logical lsame_(char *, char *);
+ doublereal tscal;
+ doublecomplex uscal;
+ integer jlast;
+ doublecomplex csumj;
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ logical upper;
+ extern /* Double Complex */ VOID zdotu_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int ztbsv_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), dlabad_(
+ doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
+ integer *, doublereal *, doublecomplex *, integer *);
+ doublereal bignum;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
+ doublecomplex *);
+ logical notran;
+ integer jfirst;
+ extern doublereal dzasum_(integer *, doublecomplex *, integer *);
+ doublereal smlnum;
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLATBS solves one of the triangular systems */
+
+/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */
+
+/* with scaling to prevent overflow, where A is an upper or lower */
+/* triangular band matrix. Here A' denotes the transpose of A, x and b */
+/* are n-element vectors, and s is a scaling factor, usually less than */
+/* or equal to 1, chosen so that the components of x will be less than */
+/* the overflow threshold. If the unscaled problem will not cause */
+/* overflow, the Level 2 BLAS routine ZTBSV is called. If the matrix A */
+/* is singular (A(j,j) = 0 for some j), then s is set to 0 and a */
+/* non-trivial solution to A*x = 0 is returned. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': Solve A * x = s*b (No transpose) */
+/* = 'T': Solve A**T * x = s*b (Transpose) */
+/* = 'C': Solve A**H * x = s*b (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* NORMIN (input) CHARACTER*1 */
+/* Specifies whether CNORM has been set or not. */
+/* = 'Y': CNORM contains the column norms on entry */
+/* = 'N': CNORM is not set on entry. On exit, the norms will */
+/* be computed and stored in CNORM. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of subdiagonals or superdiagonals in the */
+/* triangular matrix A. KD >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first KD+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* X (input/output) COMPLEX*16 array, dimension (N) */
+/* On entry, the right hand side b of the triangular system. */
+/* On exit, X is overwritten by the solution vector x. */
+
+/* SCALE (output) DOUBLE PRECISION */
+/* The scaling factor s for the triangular system */
+/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b. */
+/* If SCALE = 0, the matrix A is singular or badly scaled, and */
+/* the vector x is an exact or approximate solution to A*x = 0. */
+
+/* CNORM (input or output) DOUBLE PRECISION array, dimension (N) */
+
+/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
+/* contains the norm of the off-diagonal part of the j-th column */
+/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */
+/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
+/* must be greater than or equal to the 1-norm. */
+
+/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
+/* returns the 1-norm of the offdiagonal part of the j-th column */
+/* of A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* Further Details */
+/* ======= ======= */
+
+/* A rough bound on x is computed; if that is less than overflow, ZTBSV */
+/* is called, otherwise, specific code is used which checks for possible */
+/* overflow or divide-by-zero at every operation. */
+
+/* A columnwise scheme is used for solving A*x = b. The basic algorithm */
+/* if A is lower triangular is */
+
+/* x[1:n] := b[1:n] */
+/* for j = 1, ..., n */
+/* x(j) := x(j) / A(j,j) */
+/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
+/* end */
+
+/* Define bounds on the components of x after j iterations of the loop: */
+/* M(j) = bound on x[1:j] */
+/* G(j) = bound on x[j+1:n] */
+/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */
+
+/* Then for iteration j+1 we have */
+/* M(j+1) <= G(j) / | A(j+1,j+1) | */
+/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
+/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
+
+/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
+/* column j+1 of A, not counting the diagonal. Hence */
+
+/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
+/* 1<=i<=j */
+/* and */
+
+/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
+/* 1<=i< j */
+
+/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTBSV if the */
+/* reciprocal of the largest M(j), j=1,..,n, is larger than */
+/* max(underflow, 1/overflow). */
+
+/* The bound on x(j) is also used to determine when a step in the */
+/* columnwise method can be performed without fear of overflow. If */
+/* the computed bound is greater than a large constant, x is scaled to */
+/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
+/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
+
+/* Similarly, a row-wise scheme is used to solve A**T *x = b or */
+/* A**H *x = b. The basic algorithm for A upper triangular is */
+
+/* for j = 1, ..., n */
+/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
+/* end */
+
+/* We simultaneously compute two bounds */
+/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
+/* M(j) = bound on x(i), 1<=i<=j */
+
+/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */
+/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
+/* Then the bound on x(j) is */
+
+/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
+
+/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
+/* 1<=i<=j */
+
+/* and we can safely call ZTBSV if 1/M(n) and 1/G(n) are both greater */
+/* than max(underflow, 1/overflow). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --x;
+ --cnorm;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+/* Test the input parameters. */
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (! lsame_(normin, "Y") && ! lsame_(normin,
+ "N")) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*kd < 0) {
+ *info = -6;
+ } else if (*ldab < *kd + 1) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLATBS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine machine dependent parameters to control overflow. */
+
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ smlnum /= dlamch_("Precision");
+ bignum = 1. / smlnum;
+ *scale = 1.;
+
+ if (lsame_(normin, "N")) {
+
+/* Compute the 1-norm of each column, not including the diagonal. */
+
+ if (upper) {
+
+/* A is upper triangular. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *kd, i__3 = j - 1;
+ jlen = min(i__2,i__3);
+ cnorm[j] = dzasum_(&jlen, &ab[*kd + 1 - jlen + j * ab_dim1], &
+ c__1);
+/* L10: */
+ }
+ } else {
+
+/* A is lower triangular. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *kd, i__3 = *n - j;
+ jlen = min(i__2,i__3);
+ if (jlen > 0) {
+ cnorm[j] = dzasum_(&jlen, &ab[j * ab_dim1 + 2], &c__1);
+ } else {
+ cnorm[j] = 0.;
+ }
+/* L20: */
+ }
+ }
+ }
+
+/* Scale the column norms by TSCAL if the maximum element in CNORM is */
+/* greater than BIGNUM/2. */
+
+ imax = idamax_(n, &cnorm[1], &c__1);
+ tmax = cnorm[imax];
+ if (tmax <= bignum * .5) {
+ tscal = 1.;
+ } else {
+ tscal = .5 / (smlnum * tmax);
+ dscal_(n, &tscal, &cnorm[1], &c__1);
+ }
+
+/* Compute a bound on the computed solution vector to see if the */
+/* Level 2 BLAS routine ZTBSV can be used. */
+
+ xmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j;
+ d__3 = xmax, d__4 = (d__1 = x[i__2].r / 2., abs(d__1)) + (d__2 =
+ d_imag(&x[j]) / 2., abs(d__2));
+ xmax = max(d__3,d__4);
+/* L30: */
+ }
+ xbnd = xmax;
+ if (notran) {
+
+/* Compute the growth in A * x = b. */
+
+ if (upper) {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ maind = *kd + 1;
+ } else {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ maind = 1;
+ }
+
+ if (tscal != 1.) {
+ grow = 0.;
+ goto L60;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, G(0) = max{x(i), i=1,...,n}. */
+
+ grow = .5 / max(xbnd,smlnum);
+ xbnd = grow;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L60;
+ }
+
+ i__3 = maind + j * ab_dim1;
+ tjjs.r = ab[i__3].r, tjjs.i = ab[i__3].i;
+ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
+ d__2));
+
+ if (tjj >= smlnum) {
+
+/* M(j) = G(j-1) / abs(A(j,j)) */
+
+/* Computing MIN */
+ d__1 = xbnd, d__2 = min(1.,tjj) * grow;
+ xbnd = min(d__1,d__2);
+ } else {
+
+/* M(j) could overflow, set XBND to 0. */
+
+ xbnd = 0.;
+ }
+
+ if (tjj + cnorm[j] >= smlnum) {
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
+
+ grow *= tjj / (tjj + cnorm[j]);
+ } else {
+
+/* G(j) could overflow, set GROW to 0. */
+
+ grow = 0.;
+ }
+/* L40: */
+ }
+ grow = xbnd;
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
+ grow = min(d__1,d__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L60;
+ }
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
+
+ grow *= 1. / (cnorm[j] + 1.);
+/* L50: */
+ }
+ }
+L60:
+
+ ;
+ } else {
+
+/* Compute the growth in A**T * x = b or A**H * x = b. */
+
+ if (upper) {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ maind = *kd + 1;
+ } else {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ maind = 1;
+ }
+
+ if (tscal != 1.) {
+ grow = 0.;
+ goto L90;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, M(0) = max{x(i), i=1,...,n}. */
+
+ grow = .5 / max(xbnd,smlnum);
+ xbnd = grow;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L90;
+ }
+
+/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
+
+ xj = cnorm[j] + 1.;
+/* Computing MIN */
+ d__1 = grow, d__2 = xbnd / xj;
+ grow = min(d__1,d__2);
+
+ i__3 = maind + j * ab_dim1;
+ tjjs.r = ab[i__3].r, tjjs.i = ab[i__3].i;
+ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
+ d__2));
+
+ if (tjj >= smlnum) {
+
+/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
+
+ if (xj > tjj) {
+ xbnd *= tjj / xj;
+ }
+ } else {
+
+/* M(j) could overflow, set XBND to 0. */
+
+ xbnd = 0.;
+ }
+/* L70: */
+ }
+ grow = min(grow,xbnd);
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
+ grow = min(d__1,d__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L90;
+ }
+
+/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
+
+ xj = cnorm[j] + 1.;
+ grow /= xj;
+/* L80: */
+ }
+ }
+L90:
+ ;
+ }
+
+ if (grow * tscal > smlnum) {
+
+/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
+/* elements of X is not too small. */
+
+ ztbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &x[1], &c__1);
+ } else {
+
+/* Use a Level 1 BLAS solve, scaling intermediate results. */
+
+ if (xmax > bignum * .5) {
+
+/* Scale X so that its components are less than or equal to */
+/* BIGNUM in absolute value. */
+
+ *scale = bignum * .5 / xmax;
+ zdscal_(n, scale, &x[1], &c__1);
+ xmax = bignum;
+ } else {
+ xmax *= 2.;
+ }
+
+ if (notran) {
+
+/* Solve A * x = b */
+
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
+
+ i__3 = j;
+ xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
+ abs(d__2));
+ if (nounit) {
+ i__3 = maind + j * ab_dim1;
+ z__1.r = tscal * ab[i__3].r, z__1.i = tscal * ab[i__3].i;
+ tjjs.r = z__1.r, tjjs.i = z__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.;
+ if (tscal == 1.) {
+ goto L110;
+ }
+ }
+ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
+ d__2));
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.) {
+ if (xj > tjj * bignum) {
+
+/* Scale x by 1/b(j). */
+
+ rec = 1. / xj;
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ i__3 = j;
+ zladiv_(&z__1, &x[j], &tjjs);
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ i__3 = j;
+ xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
+ , abs(d__2));
+ } else if (tjj > 0.) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
+/* to avoid overflow when dividing by A(j,j). */
+
+ rec = tjj * bignum / xj;
+ if (cnorm[j] > 1.) {
+
+/* Scale by 1/CNORM(j) to avoid overflow when */
+/* multiplying x(j) times column j. */
+
+ rec /= cnorm[j];
+ }
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ i__3 = j;
+ zladiv_(&z__1, &x[j], &tjjs);
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ i__3 = j;
+ xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
+ , abs(d__2));
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0, and compute a solution to A*x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ x[i__4].r = 0., x[i__4].i = 0.;
+/* L100: */
+ }
+ i__3 = j;
+ x[i__3].r = 1., x[i__3].i = 0.;
+ xj = 1.;
+ *scale = 0.;
+ xmax = 0.;
+ }
+L110:
+
+/* Scale x if necessary to avoid overflow when adding a */
+/* multiple of column j of A. */
+
+ if (xj > 1.) {
+ rec = 1. / xj;
+ if (cnorm[j] > (bignum - xmax) * rec) {
+
+/* Scale x by 1/(2*abs(x(j))). */
+
+ rec *= .5;
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ }
+ } else if (xj * cnorm[j] > bignum - xmax) {
+
+/* Scale x by 1/2. */
+
+ zdscal_(n, &c_b36, &x[1], &c__1);
+ *scale *= .5;
+ }
+
+ if (upper) {
+ if (j > 1) {
+
+/* Compute the update */
+/* x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) - */
+/* x(j)* A(max(1,j-kd):j-1,j) */
+
+/* Computing MIN */
+ i__3 = *kd, i__4 = j - 1;
+ jlen = min(i__3,i__4);
+ i__3 = j;
+ z__2.r = -x[i__3].r, z__2.i = -x[i__3].i;
+ z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
+ zaxpy_(&jlen, &z__1, &ab[*kd + 1 - jlen + j * ab_dim1]
+, &c__1, &x[j - jlen], &c__1);
+ i__3 = j - 1;
+ i__ = izamax_(&i__3, &x[1], &c__1);
+ i__3 = i__;
+ xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
+ &x[i__]), abs(d__2));
+ }
+ } else if (j < *n) {
+
+/* Compute the update */
+/* x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) - */
+/* x(j) * A(j+1:min(j+kd,n),j) */
+
+/* Computing MIN */
+ i__3 = *kd, i__4 = *n - j;
+ jlen = min(i__3,i__4);
+ if (jlen > 0) {
+ i__3 = j;
+ z__2.r = -x[i__3].r, z__2.i = -x[i__3].i;
+ z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
+ zaxpy_(&jlen, &z__1, &ab[j * ab_dim1 + 2], &c__1, &x[
+ j + 1], &c__1);
+ }
+ i__3 = *n - j;
+ i__ = j + izamax_(&i__3, &x[j + 1], &c__1);
+ i__3 = i__;
+ xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[
+ i__]), abs(d__2));
+ }
+/* L120: */
+ }
+
+ } else if (lsame_(trans, "T")) {
+
+/* Solve A**T * x = b */
+
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
+/* k<>j */
+
+ i__3 = j;
+ xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
+ abs(d__2));
+ uscal.r = tscal, uscal.i = 0.;
+ rec = 1. / max(xmax,1.);
+ if (cnorm[j] > (bignum - xj) * rec) {
+
+/* If x(j) could overflow, scale x by 1/(2*XMAX). */
+
+ rec *= .5;
+ if (nounit) {
+ i__3 = maind + j * ab_dim1;
+ z__1.r = tscal * ab[i__3].r, z__1.i = tscal * ab[i__3]
+ .i;
+ tjjs.r = z__1.r, tjjs.i = z__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.;
+ }
+ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
+ abs(d__2));
+ if (tjj > 1.) {
+
+/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
+
+/* Computing MIN */
+ d__1 = 1., d__2 = rec * tjj;
+ rec = min(d__1,d__2);
+ zladiv_(&z__1, &uscal, &tjjs);
+ uscal.r = z__1.r, uscal.i = z__1.i;
+ }
+ if (rec < 1.) {
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ csumj.r = 0., csumj.i = 0.;
+ if (uscal.r == 1. && uscal.i == 0.) {
+
+/* If the scaling needed for A in the dot product is 1, */
+/* call ZDOTU to perform the dot product. */
+
+ if (upper) {
+/* Computing MIN */
+ i__3 = *kd, i__4 = j - 1;
+ jlen = min(i__3,i__4);
+ zdotu_(&z__1, &jlen, &ab[*kd + 1 - jlen + j * ab_dim1]
+, &c__1, &x[j - jlen], &c__1);
+ csumj.r = z__1.r, csumj.i = z__1.i;
+ } else {
+/* Computing MIN */
+ i__3 = *kd, i__4 = *n - j;
+ jlen = min(i__3,i__4);
+ if (jlen > 1) {
+ zdotu_(&z__1, &jlen, &ab[j * ab_dim1 + 2], &c__1,
+ &x[j + 1], &c__1);
+ csumj.r = z__1.r, csumj.i = z__1.i;
+ }
+ }
+ } else {
+
+/* Otherwise, use in-line code for the dot product. */
+
+ if (upper) {
+/* Computing MIN */
+ i__3 = *kd, i__4 = j - 1;
+ jlen = min(i__3,i__4);
+ i__3 = jlen;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = *kd + i__ - jlen + j * ab_dim1;
+ z__3.r = ab[i__4].r * uscal.r - ab[i__4].i *
+ uscal.i, z__3.i = ab[i__4].r * uscal.i +
+ ab[i__4].i * uscal.r;
+ i__5 = j - jlen - 1 + i__;
+ z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i,
+ z__2.i = z__3.r * x[i__5].i + z__3.i * x[
+ i__5].r;
+ z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
+ z__2.i;
+ csumj.r = z__1.r, csumj.i = z__1.i;
+/* L130: */
+ }
+ } else {
+/* Computing MIN */
+ i__3 = *kd, i__4 = *n - j;
+ jlen = min(i__3,i__4);
+ i__3 = jlen;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + 1 + j * ab_dim1;
+ z__3.r = ab[i__4].r * uscal.r - ab[i__4].i *
+ uscal.i, z__3.i = ab[i__4].r * uscal.i +
+ ab[i__4].i * uscal.r;
+ i__5 = j + i__;
+ z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i,
+ z__2.i = z__3.r * x[i__5].i + z__3.i * x[
+ i__5].r;
+ z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
+ z__2.i;
+ csumj.r = z__1.r, csumj.i = z__1.i;
+/* L140: */
+ }
+ }
+ }
+
+ z__1.r = tscal, z__1.i = 0.;
+ if (uscal.r == z__1.r && uscal.i == z__1.i) {
+
+/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
+/* was not used to scale the dotproduct. */
+
+ i__3 = j;
+ i__4 = j;
+ z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i -
+ csumj.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ i__3 = j;
+ xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
+ , abs(d__2));
+ if (nounit) {
+
+/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
+
+ i__3 = maind + j * ab_dim1;
+ z__1.r = tscal * ab[i__3].r, z__1.i = tscal * ab[i__3]
+ .i;
+ tjjs.r = z__1.r, tjjs.i = z__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.;
+ if (tscal == 1.) {
+ goto L160;
+ }
+ }
+ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
+ abs(d__2));
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.) {
+ if (xj > tjj * bignum) {
+
+/* Scale X by 1/abs(x(j)). */
+
+ rec = 1. / xj;
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ i__3 = j;
+ zladiv_(&z__1, &x[j], &tjjs);
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ } else if (tjj > 0.) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
+
+ rec = tjj * bignum / xj;
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ i__3 = j;
+ zladiv_(&z__1, &x[j], &tjjs);
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0 and compute a solution to A**T *x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ x[i__4].r = 0., x[i__4].i = 0.;
+/* L150: */
+ }
+ i__3 = j;
+ x[i__3].r = 1., x[i__3].i = 0.;
+ *scale = 0.;
+ xmax = 0.;
+ }
+L160:
+ ;
+ } else {
+
+/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
+/* product has already been divided by 1/A(j,j). */
+
+ i__3 = j;
+ zladiv_(&z__2, &x[j], &tjjs);
+ z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ }
+/* Computing MAX */
+ i__3 = j;
+ d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&x[j]), abs(d__2));
+ xmax = max(d__3,d__4);
+/* L170: */
+ }
+
+ } else {
+
+/* Solve A**H * x = b */
+
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
+/* k<>j */
+
+ i__3 = j;
+ xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
+ abs(d__2));
+ uscal.r = tscal, uscal.i = 0.;
+ rec = 1. / max(xmax,1.);
+ if (cnorm[j] > (bignum - xj) * rec) {
+
+/* If x(j) could overflow, scale x by 1/(2*XMAX). */
+
+ rec *= .5;
+ if (nounit) {
+ d_cnjg(&z__2, &ab[maind + j * ab_dim1]);
+ z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
+ tjjs.r = z__1.r, tjjs.i = z__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.;
+ }
+ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
+ abs(d__2));
+ if (tjj > 1.) {
+
+/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
+
+/* Computing MIN */
+ d__1 = 1., d__2 = rec * tjj;
+ rec = min(d__1,d__2);
+ zladiv_(&z__1, &uscal, &tjjs);
+ uscal.r = z__1.r, uscal.i = z__1.i;
+ }
+ if (rec < 1.) {
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ csumj.r = 0., csumj.i = 0.;
+ if (uscal.r == 1. && uscal.i == 0.) {
+
+/* If the scaling needed for A in the dot product is 1, */
+/* call ZDOTC to perform the dot product. */
+
+ if (upper) {
+/* Computing MIN */
+ i__3 = *kd, i__4 = j - 1;
+ jlen = min(i__3,i__4);
+ zdotc_(&z__1, &jlen, &ab[*kd + 1 - jlen + j * ab_dim1]
+, &c__1, &x[j - jlen], &c__1);
+ csumj.r = z__1.r, csumj.i = z__1.i;
+ } else {
+/* Computing MIN */
+ i__3 = *kd, i__4 = *n - j;
+ jlen = min(i__3,i__4);
+ if (jlen > 1) {
+ zdotc_(&z__1, &jlen, &ab[j * ab_dim1 + 2], &c__1,
+ &x[j + 1], &c__1);
+ csumj.r = z__1.r, csumj.i = z__1.i;
+ }
+ }
+ } else {
+
+/* Otherwise, use in-line code for the dot product. */
+
+ if (upper) {
+/* Computing MIN */
+ i__3 = *kd, i__4 = j - 1;
+ jlen = min(i__3,i__4);
+ i__3 = jlen;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d_cnjg(&z__4, &ab[*kd + i__ - jlen + j * ab_dim1])
+ ;
+ z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
+ z__3.i = z__4.r * uscal.i + z__4.i *
+ uscal.r;
+ i__4 = j - jlen - 1 + i__;
+ z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i,
+ z__2.i = z__3.r * x[i__4].i + z__3.i * x[
+ i__4].r;
+ z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
+ z__2.i;
+ csumj.r = z__1.r, csumj.i = z__1.i;
+/* L180: */
+ }
+ } else {
+/* Computing MIN */
+ i__3 = *kd, i__4 = *n - j;
+ jlen = min(i__3,i__4);
+ i__3 = jlen;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d_cnjg(&z__4, &ab[i__ + 1 + j * ab_dim1]);
+ z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
+ z__3.i = z__4.r * uscal.i + z__4.i *
+ uscal.r;
+ i__4 = j + i__;
+ z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i,
+ z__2.i = z__3.r * x[i__4].i + z__3.i * x[
+ i__4].r;
+ z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
+ z__2.i;
+ csumj.r = z__1.r, csumj.i = z__1.i;
+/* L190: */
+ }
+ }
+ }
+
+ z__1.r = tscal, z__1.i = 0.;
+ if (uscal.r == z__1.r && uscal.i == z__1.i) {
+
+/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
+/* was not used to scale the dotproduct. */
+
+ i__3 = j;
+ i__4 = j;
+ z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i -
+ csumj.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ i__3 = j;
+ xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
+ , abs(d__2));
+ if (nounit) {
+
+/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
+
+ d_cnjg(&z__2, &ab[maind + j * ab_dim1]);
+ z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
+ tjjs.r = z__1.r, tjjs.i = z__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.;
+ if (tscal == 1.) {
+ goto L210;
+ }
+ }
+ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
+ abs(d__2));
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.) {
+ if (xj > tjj * bignum) {
+
+/* Scale X by 1/abs(x(j)). */
+
+ rec = 1. / xj;
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ i__3 = j;
+ zladiv_(&z__1, &x[j], &tjjs);
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ } else if (tjj > 0.) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
+
+ rec = tjj * bignum / xj;
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ i__3 = j;
+ zladiv_(&z__1, &x[j], &tjjs);
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0 and compute a solution to A**H *x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ x[i__4].r = 0., x[i__4].i = 0.;
+/* L200: */
+ }
+ i__3 = j;
+ x[i__3].r = 1., x[i__3].i = 0.;
+ *scale = 0.;
+ xmax = 0.;
+ }
+L210:
+ ;
+ } else {
+
+/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
+/* product has already been divided by 1/A(j,j). */
+
+ i__3 = j;
+ zladiv_(&z__2, &x[j], &tjjs);
+ z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ }
+/* Computing MAX */
+ i__3 = j;
+ d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&x[j]), abs(d__2));
+ xmax = max(d__3,d__4);
+/* L220: */
+ }
+ }
+ *scale /= tscal;
+ }
+
+/* Scale the column norms by 1/TSCAL for return. */
+
+ if (tscal != 1.) {
+ d__1 = 1. / tscal;
+ dscal_(n, &d__1, &cnorm[1], &c__1);
+ }
+
+ return 0;
+
+/* End of ZLATBS */
+
+} /* zlatbs_ */
diff --git a/SRC/zlatdf.c b/SRC/zlatdf.c
new file mode 100644
index 0000000..4bb8ddb
--- /dev/null
+++ b/SRC/zlatdf.c
@@ -0,0 +1,359 @@
+/* zlatdf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b24 = 1.;
+
+/* Subroutine */ int zlatdf_(integer *ijob, integer *n, doublecomplex *z__,
+ integer *ldz, doublecomplex *rhs, doublereal *rdsum, doublereal *
+ rdscal, integer *ipiv, integer *jpiv)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+ double z_abs(doublecomplex *);
+ void z_sqrt(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublecomplex bm, bp, xm[2], xp[2];
+ integer info;
+ doublecomplex temp, work[8];
+ doublereal scale;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ doublecomplex pmone;
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal rtemp, sminu, rwork[2];
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ doublereal splus;
+ extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), zgesc2_(
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *, doublereal *), zgecon_(char *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *);
+ extern doublereal dzasum_(integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *), zlaswp_(integer *, doublecomplex *,
+ integer *, integer *, integer *, integer *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLATDF computes the contribution to the reciprocal Dif-estimate */
+/* by solving for x in Z * x = b, where b is chosen such that the norm */
+/* of x is as large as possible. It is assumed that LU decomposition */
+/* of Z has been computed by ZGETC2. On entry RHS = f holds the */
+/* contribution from earlier solved sub-systems, and on return RHS = x. */
+
+/* The factorization of Z returned by ZGETC2 has the form */
+/* Z = P * L * U * Q, where P and Q are permutation matrices. L is lower */
+/* triangular with unit diagonal elements and U is upper triangular. */
+
+/* Arguments */
+/* ========= */
+
+/* IJOB (input) INTEGER */
+/* IJOB = 2: First compute an approximative null-vector e */
+/* of Z using ZGECON, e is normalized and solve for */
+/* Zx = +-e - f with the sign giving the greater value of */
+/* 2-norm(x). About 5 times as expensive as Default. */
+/* IJOB .ne. 2: Local look ahead strategy where */
+/* all entries of the r.h.s. b is choosen as either +1 or */
+/* -1. Default. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Z. */
+
+/* Z (input) DOUBLE PRECISION array, dimension (LDZ, N) */
+/* On entry, the LU part of the factorization of the n-by-n */
+/* matrix Z computed by ZGETC2: Z = P * L * U * Q */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDA >= max(1, N). */
+
+/* RHS (input/output) DOUBLE PRECISION array, dimension (N). */
+/* On entry, RHS contains contributions from other subsystems. */
+/* On exit, RHS contains the solution of the subsystem with */
+/* entries according to the value of IJOB (see above). */
+
+/* RDSUM (input/output) DOUBLE PRECISION */
+/* On entry, the sum of squares of computed contributions to */
+/* the Dif-estimate under computation by ZTGSYL, where the */
+/* scaling factor RDSCAL (see below) has been factored out. */
+/* On exit, the corresponding sum of squares updated with the */
+/* contributions from the current sub-system. */
+/* If TRANS = 'T' RDSUM is not touched. */
+/* NOTE: RDSUM only makes sense when ZTGSY2 is called by CTGSYL. */
+
+/* RDSCAL (input/output) DOUBLE PRECISION */
+/* On entry, scaling factor used to prevent overflow in RDSUM. */
+/* On exit, RDSCAL is updated w.r.t. the current contributions */
+/* in RDSUM. */
+/* If TRANS = 'T', RDSCAL is not touched. */
+/* NOTE: RDSCAL only makes sense when ZTGSY2 is called by */
+/* ZTGSYL. */
+
+/* IPIV (input) INTEGER array, dimension (N). */
+/* The pivot indices; for 1 <= i <= N, row i of the */
+/* matrix has been interchanged with row IPIV(i). */
+
+/* JPIV (input) INTEGER array, dimension (N). */
+/* The pivot indices; for 1 <= j <= N, column j of the */
+/* matrix has been interchanged with column JPIV(j). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* This routine is a further developed implementation of algorithm */
+/* BSOLVE in [1] using complete pivoting in the LU factorization. */
+
+/* [1] Bo Kagstrom and Lars Westin, */
+/* Generalized Schur Methods with Condition Estimators for */
+/* Solving the Generalized Sylvester Equation, IEEE Transactions */
+/* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. */
+
+/* [2] Peter Poromaa, */
+/* On Efficient and Robust Estimators for the Separation */
+/* between two Regular Matrix Pairs with Applications in */
+/* Condition Estimation. Report UMINF-95.05, Department of */
+/* Computing Science, Umea University, S-901 87 Umea, Sweden, */
+/* 1995. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --rhs;
+ --ipiv;
+ --jpiv;
+
+ /* Function Body */
+ if (*ijob != 2) {
+
+/* Apply permutations IPIV to RHS */
+
+ i__1 = *n - 1;
+ zlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &ipiv[1], &c__1);
+
+/* Solve for L-part choosing RHS either to +1 or -1. */
+
+ z__1.r = -1., z__1.i = -0.;
+ pmone.r = z__1.r, pmone.i = z__1.i;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ z__1.r = rhs[i__2].r + 1., z__1.i = rhs[i__2].i + 0.;
+ bp.r = z__1.r, bp.i = z__1.i;
+ i__2 = j;
+ z__1.r = rhs[i__2].r - 1., z__1.i = rhs[i__2].i - 0.;
+ bm.r = z__1.r, bm.i = z__1.i;
+ splus = 1.;
+
+/* Lockahead for L- part RHS(1:N-1) = +-1 */
+/* SPLUS and SMIN computed more efficiently than in BSOLVE[1]. */
+
+ i__2 = *n - j;
+ zdotc_(&z__1, &i__2, &z__[j + 1 + j * z_dim1], &c__1, &z__[j + 1
+ + j * z_dim1], &c__1);
+ splus += z__1.r;
+ i__2 = *n - j;
+ zdotc_(&z__1, &i__2, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1],
+ &c__1);
+ sminu = z__1.r;
+ i__2 = j;
+ splus *= rhs[i__2].r;
+ if (splus > sminu) {
+ i__2 = j;
+ rhs[i__2].r = bp.r, rhs[i__2].i = bp.i;
+ } else if (sminu > splus) {
+ i__2 = j;
+ rhs[i__2].r = bm.r, rhs[i__2].i = bm.i;
+ } else {
+
+/* In this case the updating sums are equal and we can */
+/* choose RHS(J) +1 or -1. The first time this happens we */
+/* choose -1, thereafter +1. This is a simple way to get */
+/* good estimates of matrices like Byers well-known example */
+/* (see [1]). (Not done in BSOLVE.) */
+
+ i__2 = j;
+ i__3 = j;
+ z__1.r = rhs[i__3].r + pmone.r, z__1.i = rhs[i__3].i +
+ pmone.i;
+ rhs[i__2].r = z__1.r, rhs[i__2].i = z__1.i;
+ pmone.r = 1., pmone.i = 0.;
+ }
+
+/* Compute the remaining r.h.s. */
+
+ i__2 = j;
+ z__1.r = -rhs[i__2].r, z__1.i = -rhs[i__2].i;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__2 = *n - j;
+ zaxpy_(&i__2, &temp, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1],
+ &c__1);
+/* L10: */
+ }
+
+/* Solve for U- part, lockahead for RHS(N) = +-1. This is not done */
+/* In BSOLVE and will hopefully give us a better estimate because */
+/* any ill-conditioning of the original matrix is transfered to U */
+/* and not to L. U(N, N) is an approximation to sigma_min(LU). */
+
+ i__1 = *n - 1;
+ zcopy_(&i__1, &rhs[1], &c__1, work, &c__1);
+ i__1 = *n - 1;
+ i__2 = *n;
+ z__1.r = rhs[i__2].r + 1., z__1.i = rhs[i__2].i + 0.;
+ work[i__1].r = z__1.r, work[i__1].i = z__1.i;
+ i__1 = *n;
+ i__2 = *n;
+ z__1.r = rhs[i__2].r - 1., z__1.i = rhs[i__2].i - 0.;
+ rhs[i__1].r = z__1.r, rhs[i__1].i = z__1.i;
+ splus = 0.;
+ sminu = 0.;
+ for (i__ = *n; i__ >= 1; --i__) {
+ z_div(&z__1, &c_b1, &z__[i__ + i__ * z_dim1]);
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__1 = i__ - 1;
+ i__2 = i__ - 1;
+ z__1.r = work[i__2].r * temp.r - work[i__2].i * temp.i, z__1.i =
+ work[i__2].r * temp.i + work[i__2].i * temp.r;
+ work[i__1].r = z__1.r, work[i__1].i = z__1.i;
+ i__1 = i__;
+ i__2 = i__;
+ z__1.r = rhs[i__2].r * temp.r - rhs[i__2].i * temp.i, z__1.i =
+ rhs[i__2].r * temp.i + rhs[i__2].i * temp.r;
+ rhs[i__1].r = z__1.r, rhs[i__1].i = z__1.i;
+ i__1 = *n;
+ for (k = i__ + 1; k <= i__1; ++k) {
+ i__2 = i__ - 1;
+ i__3 = i__ - 1;
+ i__4 = k - 1;
+ i__5 = i__ + k * z_dim1;
+ z__3.r = z__[i__5].r * temp.r - z__[i__5].i * temp.i, z__3.i =
+ z__[i__5].r * temp.i + z__[i__5].i * temp.r;
+ z__2.r = work[i__4].r * z__3.r - work[i__4].i * z__3.i,
+ z__2.i = work[i__4].r * z__3.i + work[i__4].i *
+ z__3.r;
+ z__1.r = work[i__3].r - z__2.r, z__1.i = work[i__3].i -
+ z__2.i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ i__2 = i__;
+ i__3 = i__;
+ i__4 = k;
+ i__5 = i__ + k * z_dim1;
+ z__3.r = z__[i__5].r * temp.r - z__[i__5].i * temp.i, z__3.i =
+ z__[i__5].r * temp.i + z__[i__5].i * temp.r;
+ z__2.r = rhs[i__4].r * z__3.r - rhs[i__4].i * z__3.i, z__2.i =
+ rhs[i__4].r * z__3.i + rhs[i__4].i * z__3.r;
+ z__1.r = rhs[i__3].r - z__2.r, z__1.i = rhs[i__3].i - z__2.i;
+ rhs[i__2].r = z__1.r, rhs[i__2].i = z__1.i;
+/* L20: */
+ }
+ splus += z_abs(&work[i__ - 1]);
+ sminu += z_abs(&rhs[i__]);
+/* L30: */
+ }
+ if (splus > sminu) {
+ zcopy_(n, work, &c__1, &rhs[1], &c__1);
+ }
+
+/* Apply the permutations JPIV to the computed solution (RHS) */
+
+ i__1 = *n - 1;
+ zlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &jpiv[1], &c_n1);
+
+/* Compute the sum of squares */
+
+ zlassq_(n, &rhs[1], &c__1, rdscal, rdsum);
+ return 0;
+ }
+
+/* ENTRY IJOB = 2 */
+
+/* Compute approximate nullvector XM of Z */
+
+ zgecon_("I", n, &z__[z_offset], ldz, &c_b24, &rtemp, work, rwork, &info);
+ zcopy_(n, &work[*n], &c__1, xm, &c__1);
+
+/* Compute RHS */
+
+ i__1 = *n - 1;
+ zlaswp_(&c__1, xm, ldz, &c__1, &i__1, &ipiv[1], &c_n1);
+ zdotc_(&z__3, n, xm, &c__1, xm, &c__1);
+ z_sqrt(&z__2, &z__3);
+ z_div(&z__1, &c_b1, &z__2);
+ temp.r = z__1.r, temp.i = z__1.i;
+ zscal_(n, &temp, xm, &c__1);
+ zcopy_(n, xm, &c__1, xp, &c__1);
+ zaxpy_(n, &c_b1, &rhs[1], &c__1, xp, &c__1);
+ z__1.r = -1., z__1.i = -0.;
+ zaxpy_(n, &z__1, xm, &c__1, &rhs[1], &c__1);
+ zgesc2_(n, &z__[z_offset], ldz, &rhs[1], &ipiv[1], &jpiv[1], &scale);
+ zgesc2_(n, &z__[z_offset], ldz, xp, &ipiv[1], &jpiv[1], &scale);
+ if (dzasum_(n, xp, &c__1) > dzasum_(n, &rhs[1], &c__1)) {
+ zcopy_(n, xp, &c__1, &rhs[1], &c__1);
+ }
+
+/* Compute the sum of squares */
+
+ zlassq_(n, &rhs[1], &c__1, rdscal, rdsum);
+ return 0;
+
+/* End of ZLATDF */
+
+} /* zlatdf_ */
diff --git a/SRC/zlatps.c b/SRC/zlatps.c
new file mode 100644
index 0000000..be62296
--- /dev/null
+++ b/SRC/zlatps.c
@@ -0,0 +1,1163 @@
+/* zlatps.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b36 = .5;
+
+/* Subroutine */ int zlatps_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, doublecomplex *ap, doublecomplex *x, doublereal *
+ scale, doublereal *cnorm, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, ip;
+ doublereal xj, rec, tjj;
+ integer jinc, jlen;
+ doublereal xbnd;
+ integer imax;
+ doublereal tmax;
+ doublecomplex tjjs;
+ doublereal xmax, grow;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ doublereal tscal;
+ doublecomplex uscal;
+ integer jlast;
+ doublecomplex csumj;
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ logical upper;
+ extern /* Double Complex */ VOID zdotu_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), ztpsv_(
+ char *, char *, char *, integer *, doublecomplex *, doublecomplex
+ *, integer *), dlabad_(doublereal *,
+ doublereal *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
+ integer *, doublereal *, doublecomplex *, integer *);
+ doublereal bignum;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
+ doublecomplex *);
+ logical notran;
+ integer jfirst;
+ extern doublereal dzasum_(integer *, doublecomplex *, integer *);
+ doublereal smlnum;
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLATPS solves one of the triangular systems */
+
+/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */
+
+/* with scaling to prevent overflow, where A is an upper or lower */
+/* triangular matrix stored in packed form. Here A**T denotes the */
+/* transpose of A, A**H denotes the conjugate transpose of A, x and b */
+/* are n-element vectors, and s is a scaling factor, usually less than */
+/* or equal to 1, chosen so that the components of x will be less than */
+/* the overflow threshold. If the unscaled problem will not cause */
+/* overflow, the Level 2 BLAS routine ZTPSV is called. If the matrix A */
+/* is singular (A(j,j) = 0 for some j), then s is set to 0 and a */
+/* non-trivial solution to A*x = 0 is returned. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': Solve A * x = s*b (No transpose) */
+/* = 'T': Solve A**T * x = s*b (Transpose) */
+/* = 'C': Solve A**H * x = s*b (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* NORMIN (input) CHARACTER*1 */
+/* Specifies whether CNORM has been set or not. */
+/* = 'Y': CNORM contains the column norms on entry */
+/* = 'N': CNORM is not set on entry. On exit, the norms will */
+/* be computed and stored in CNORM. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* X (input/output) COMPLEX*16 array, dimension (N) */
+/* On entry, the right hand side b of the triangular system. */
+/* On exit, X is overwritten by the solution vector x. */
+
+/* SCALE (output) DOUBLE PRECISION */
+/* The scaling factor s for the triangular system */
+/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b. */
+/* If SCALE = 0, the matrix A is singular or badly scaled, and */
+/* the vector x is an exact or approximate solution to A*x = 0. */
+
+/* CNORM (input or output) DOUBLE PRECISION array, dimension (N) */
+
+/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
+/* contains the norm of the off-diagonal part of the j-th column */
+/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */
+/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
+/* must be greater than or equal to the 1-norm. */
+
+/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
+/* returns the 1-norm of the offdiagonal part of the j-th column */
+/* of A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* Further Details */
+/* ======= ======= */
+
+/* A rough bound on x is computed; if that is less than overflow, ZTPSV */
+/* is called, otherwise, specific code is used which checks for possible */
+/* overflow or divide-by-zero at every operation. */
+
+/* A columnwise scheme is used for solving A*x = b. The basic algorithm */
+/* if A is lower triangular is */
+
+/* x[1:n] := b[1:n] */
+/* for j = 1, ..., n */
+/* x(j) := x(j) / A(j,j) */
+/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
+/* end */
+
+/* Define bounds on the components of x after j iterations of the loop: */
+/* M(j) = bound on x[1:j] */
+/* G(j) = bound on x[j+1:n] */
+/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */
+
+/* Then for iteration j+1 we have */
+/* M(j+1) <= G(j) / | A(j+1,j+1) | */
+/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
+/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
+
+/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
+/* column j+1 of A, not counting the diagonal. Hence */
+
+/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
+/* 1<=i<=j */
+/* and */
+
+/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
+/* 1<=i< j */
+
+/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTPSV if the */
+/* reciprocal of the largest M(j), j=1,..,n, is larger than */
+/* max(underflow, 1/overflow). */
+
+/* The bound on x(j) is also used to determine when a step in the */
+/* columnwise method can be performed without fear of overflow. If */
+/* the computed bound is greater than a large constant, x is scaled to */
+/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
+/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
+
+/* Similarly, a row-wise scheme is used to solve A**T *x = b or */
+/* A**H *x = b. The basic algorithm for A upper triangular is */
+
+/* for j = 1, ..., n */
+/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
+/* end */
+
+/* We simultaneously compute two bounds */
+/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
+/* M(j) = bound on x(i), 1<=i<=j */
+
+/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */
+/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
+/* Then the bound on x(j) is */
+
+/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
+
+/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
+/* 1<=i<=j */
+
+/* and we can safely call ZTPSV if 1/M(n) and 1/G(n) are both greater */
+/* than max(underflow, 1/overflow). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --cnorm;
+ --x;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+/* Test the input parameters. */
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (! lsame_(normin, "Y") && ! lsame_(normin,
+ "N")) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLATPS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine machine dependent parameters to control overflow. */
+
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ smlnum /= dlamch_("Precision");
+ bignum = 1. / smlnum;
+ *scale = 1.;
+
+ if (lsame_(normin, "N")) {
+
+/* Compute the 1-norm of each column, not including the diagonal. */
+
+ if (upper) {
+
+/* A is upper triangular. */
+
+ ip = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ cnorm[j] = dzasum_(&i__2, &ap[ip], &c__1);
+ ip += j;
+/* L10: */
+ }
+ } else {
+
+/* A is lower triangular. */
+
+ ip = 1;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ cnorm[j] = dzasum_(&i__2, &ap[ip + 1], &c__1);
+ ip = ip + *n - j + 1;
+/* L20: */
+ }
+ cnorm[*n] = 0.;
+ }
+ }
+
+/* Scale the column norms by TSCAL if the maximum element in CNORM is */
+/* greater than BIGNUM/2. */
+
+ imax = idamax_(n, &cnorm[1], &c__1);
+ tmax = cnorm[imax];
+ if (tmax <= bignum * .5) {
+ tscal = 1.;
+ } else {
+ tscal = .5 / (smlnum * tmax);
+ dscal_(n, &tscal, &cnorm[1], &c__1);
+ }
+
+/* Compute a bound on the computed solution vector to see if the */
+/* Level 2 BLAS routine ZTPSV can be used. */
+
+ xmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j;
+ d__3 = xmax, d__4 = (d__1 = x[i__2].r / 2., abs(d__1)) + (d__2 =
+ d_imag(&x[j]) / 2., abs(d__2));
+ xmax = max(d__3,d__4);
+/* L30: */
+ }
+ xbnd = xmax;
+ if (notran) {
+
+/* Compute the growth in A * x = b. */
+
+ if (upper) {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ } else {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ }
+
+ if (tscal != 1.) {
+ grow = 0.;
+ goto L60;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, G(0) = max{x(i), i=1,...,n}. */
+
+ grow = .5 / max(xbnd,smlnum);
+ xbnd = grow;
+ ip = jfirst * (jfirst + 1) / 2;
+ jlen = *n;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L60;
+ }
+
+ i__3 = ip;
+ tjjs.r = ap[i__3].r, tjjs.i = ap[i__3].i;
+ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
+ d__2));
+
+ if (tjj >= smlnum) {
+
+/* M(j) = G(j-1) / abs(A(j,j)) */
+
+/* Computing MIN */
+ d__1 = xbnd, d__2 = min(1.,tjj) * grow;
+ xbnd = min(d__1,d__2);
+ } else {
+
+/* M(j) could overflow, set XBND to 0. */
+
+ xbnd = 0.;
+ }
+
+ if (tjj + cnorm[j] >= smlnum) {
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
+
+ grow *= tjj / (tjj + cnorm[j]);
+ } else {
+
+/* G(j) could overflow, set GROW to 0. */
+
+ grow = 0.;
+ }
+ ip += jinc * jlen;
+ --jlen;
+/* L40: */
+ }
+ grow = xbnd;
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
+ grow = min(d__1,d__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L60;
+ }
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
+
+ grow *= 1. / (cnorm[j] + 1.);
+/* L50: */
+ }
+ }
+L60:
+
+ ;
+ } else {
+
+/* Compute the growth in A**T * x = b or A**H * x = b. */
+
+ if (upper) {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ } else {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ }
+
+ if (tscal != 1.) {
+ grow = 0.;
+ goto L90;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, M(0) = max{x(i), i=1,...,n}. */
+
+ grow = .5 / max(xbnd,smlnum);
+ xbnd = grow;
+ ip = jfirst * (jfirst + 1) / 2;
+ jlen = 1;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L90;
+ }
+
+/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
+
+ xj = cnorm[j] + 1.;
+/* Computing MIN */
+ d__1 = grow, d__2 = xbnd / xj;
+ grow = min(d__1,d__2);
+
+ i__3 = ip;
+ tjjs.r = ap[i__3].r, tjjs.i = ap[i__3].i;
+ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
+ d__2));
+
+ if (tjj >= smlnum) {
+
+/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
+
+ if (xj > tjj) {
+ xbnd *= tjj / xj;
+ }
+ } else {
+
+/* M(j) could overflow, set XBND to 0. */
+
+ xbnd = 0.;
+ }
+ ++jlen;
+ ip += jinc * jlen;
+/* L70: */
+ }
+ grow = min(grow,xbnd);
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
+ grow = min(d__1,d__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L90;
+ }
+
+/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
+
+ xj = cnorm[j] + 1.;
+ grow /= xj;
+/* L80: */
+ }
+ }
+L90:
+ ;
+ }
+
+ if (grow * tscal > smlnum) {
+
+/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
+/* elements of X is not too small. */
+
+ ztpsv_(uplo, trans, diag, n, &ap[1], &x[1], &c__1);
+ } else {
+
+/* Use a Level 1 BLAS solve, scaling intermediate results. */
+
+ if (xmax > bignum * .5) {
+
+/* Scale X so that its components are less than or equal to */
+/* BIGNUM in absolute value. */
+
+ *scale = bignum * .5 / xmax;
+ zdscal_(n, scale, &x[1], &c__1);
+ xmax = bignum;
+ } else {
+ xmax *= 2.;
+ }
+
+ if (notran) {
+
+/* Solve A * x = b */
+
+ ip = jfirst * (jfirst + 1) / 2;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
+
+ i__3 = j;
+ xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
+ abs(d__2));
+ if (nounit) {
+ i__3 = ip;
+ z__1.r = tscal * ap[i__3].r, z__1.i = tscal * ap[i__3].i;
+ tjjs.r = z__1.r, tjjs.i = z__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.;
+ if (tscal == 1.) {
+ goto L110;
+ }
+ }
+ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
+ d__2));
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.) {
+ if (xj > tjj * bignum) {
+
+/* Scale x by 1/b(j). */
+
+ rec = 1. / xj;
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ i__3 = j;
+ zladiv_(&z__1, &x[j], &tjjs);
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ i__3 = j;
+ xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
+ , abs(d__2));
+ } else if (tjj > 0.) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
+/* to avoid overflow when dividing by A(j,j). */
+
+ rec = tjj * bignum / xj;
+ if (cnorm[j] > 1.) {
+
+/* Scale by 1/CNORM(j) to avoid overflow when */
+/* multiplying x(j) times column j. */
+
+ rec /= cnorm[j];
+ }
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ i__3 = j;
+ zladiv_(&z__1, &x[j], &tjjs);
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ i__3 = j;
+ xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
+ , abs(d__2));
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0, and compute a solution to A*x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ x[i__4].r = 0., x[i__4].i = 0.;
+/* L100: */
+ }
+ i__3 = j;
+ x[i__3].r = 1., x[i__3].i = 0.;
+ xj = 1.;
+ *scale = 0.;
+ xmax = 0.;
+ }
+L110:
+
+/* Scale x if necessary to avoid overflow when adding a */
+/* multiple of column j of A. */
+
+ if (xj > 1.) {
+ rec = 1. / xj;
+ if (cnorm[j] > (bignum - xmax) * rec) {
+
+/* Scale x by 1/(2*abs(x(j))). */
+
+ rec *= .5;
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ }
+ } else if (xj * cnorm[j] > bignum - xmax) {
+
+/* Scale x by 1/2. */
+
+ zdscal_(n, &c_b36, &x[1], &c__1);
+ *scale *= .5;
+ }
+
+ if (upper) {
+ if (j > 1) {
+
+/* Compute the update */
+/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */
+
+ i__3 = j - 1;
+ i__4 = j;
+ z__2.r = -x[i__4].r, z__2.i = -x[i__4].i;
+ z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
+ zaxpy_(&i__3, &z__1, &ap[ip - j + 1], &c__1, &x[1], &
+ c__1);
+ i__3 = j - 1;
+ i__ = izamax_(&i__3, &x[1], &c__1);
+ i__3 = i__;
+ xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
+ &x[i__]), abs(d__2));
+ }
+ ip -= j;
+ } else {
+ if (j < *n) {
+
+/* Compute the update */
+/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */
+
+ i__3 = *n - j;
+ i__4 = j;
+ z__2.r = -x[i__4].r, z__2.i = -x[i__4].i;
+ z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
+ zaxpy_(&i__3, &z__1, &ap[ip + 1], &c__1, &x[j + 1], &
+ c__1);
+ i__3 = *n - j;
+ i__ = j + izamax_(&i__3, &x[j + 1], &c__1);
+ i__3 = i__;
+ xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
+ &x[i__]), abs(d__2));
+ }
+ ip = ip + *n - j + 1;
+ }
+/* L120: */
+ }
+
+ } else if (lsame_(trans, "T")) {
+
+/* Solve A**T * x = b */
+
+ ip = jfirst * (jfirst + 1) / 2;
+ jlen = 1;
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
+/* k<>j */
+
+ i__3 = j;
+ xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
+ abs(d__2));
+ uscal.r = tscal, uscal.i = 0.;
+ rec = 1. / max(xmax,1.);
+ if (cnorm[j] > (bignum - xj) * rec) {
+
+/* If x(j) could overflow, scale x by 1/(2*XMAX). */
+
+ rec *= .5;
+ if (nounit) {
+ i__3 = ip;
+ z__1.r = tscal * ap[i__3].r, z__1.i = tscal * ap[i__3]
+ .i;
+ tjjs.r = z__1.r, tjjs.i = z__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.;
+ }
+ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
+ abs(d__2));
+ if (tjj > 1.) {
+
+/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
+
+/* Computing MIN */
+ d__1 = 1., d__2 = rec * tjj;
+ rec = min(d__1,d__2);
+ zladiv_(&z__1, &uscal, &tjjs);
+ uscal.r = z__1.r, uscal.i = z__1.i;
+ }
+ if (rec < 1.) {
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ csumj.r = 0., csumj.i = 0.;
+ if (uscal.r == 1. && uscal.i == 0.) {
+
+/* If the scaling needed for A in the dot product is 1, */
+/* call ZDOTU to perform the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ zdotu_(&z__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], &
+ c__1);
+ csumj.r = z__1.r, csumj.i = z__1.i;
+ } else if (j < *n) {
+ i__3 = *n - j;
+ zdotu_(&z__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], &
+ c__1);
+ csumj.r = z__1.r, csumj.i = z__1.i;
+ }
+ } else {
+
+/* Otherwise, use in-line code for the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ip - j + i__;
+ z__3.r = ap[i__4].r * uscal.r - ap[i__4].i *
+ uscal.i, z__3.i = ap[i__4].r * uscal.i +
+ ap[i__4].i * uscal.r;
+ i__5 = i__;
+ z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i,
+ z__2.i = z__3.r * x[i__5].i + z__3.i * x[
+ i__5].r;
+ z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
+ z__2.i;
+ csumj.r = z__1.r, csumj.i = z__1.i;
+/* L130: */
+ }
+ } else if (j < *n) {
+ i__3 = *n - j;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ip + i__;
+ z__3.r = ap[i__4].r * uscal.r - ap[i__4].i *
+ uscal.i, z__3.i = ap[i__4].r * uscal.i +
+ ap[i__4].i * uscal.r;
+ i__5 = j + i__;
+ z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i,
+ z__2.i = z__3.r * x[i__5].i + z__3.i * x[
+ i__5].r;
+ z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
+ z__2.i;
+ csumj.r = z__1.r, csumj.i = z__1.i;
+/* L140: */
+ }
+ }
+ }
+
+ z__1.r = tscal, z__1.i = 0.;
+ if (uscal.r == z__1.r && uscal.i == z__1.i) {
+
+/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
+/* was not used to scale the dotproduct. */
+
+ i__3 = j;
+ i__4 = j;
+ z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i -
+ csumj.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ i__3 = j;
+ xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
+ , abs(d__2));
+ if (nounit) {
+
+/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
+
+ i__3 = ip;
+ z__1.r = tscal * ap[i__3].r, z__1.i = tscal * ap[i__3]
+ .i;
+ tjjs.r = z__1.r, tjjs.i = z__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.;
+ if (tscal == 1.) {
+ goto L160;
+ }
+ }
+ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
+ abs(d__2));
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.) {
+ if (xj > tjj * bignum) {
+
+/* Scale X by 1/abs(x(j)). */
+
+ rec = 1. / xj;
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ i__3 = j;
+ zladiv_(&z__1, &x[j], &tjjs);
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ } else if (tjj > 0.) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
+
+ rec = tjj * bignum / xj;
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ i__3 = j;
+ zladiv_(&z__1, &x[j], &tjjs);
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0 and compute a solution to A**T *x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ x[i__4].r = 0., x[i__4].i = 0.;
+/* L150: */
+ }
+ i__3 = j;
+ x[i__3].r = 1., x[i__3].i = 0.;
+ *scale = 0.;
+ xmax = 0.;
+ }
+L160:
+ ;
+ } else {
+
+/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
+/* product has already been divided by 1/A(j,j). */
+
+ i__3 = j;
+ zladiv_(&z__2, &x[j], &tjjs);
+ z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ }
+/* Computing MAX */
+ i__3 = j;
+ d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&x[j]), abs(d__2));
+ xmax = max(d__3,d__4);
+ ++jlen;
+ ip += jinc * jlen;
+/* L170: */
+ }
+
+ } else {
+
+/* Solve A**H * x = b */
+
+ ip = jfirst * (jfirst + 1) / 2;
+ jlen = 1;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
+/* k<>j */
+
+ i__3 = j;
+ xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
+ abs(d__2));
+ uscal.r = tscal, uscal.i = 0.;
+ rec = 1. / max(xmax,1.);
+ if (cnorm[j] > (bignum - xj) * rec) {
+
+/* If x(j) could overflow, scale x by 1/(2*XMAX). */
+
+ rec *= .5;
+ if (nounit) {
+ d_cnjg(&z__2, &ap[ip]);
+ z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
+ tjjs.r = z__1.r, tjjs.i = z__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.;
+ }
+ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
+ abs(d__2));
+ if (tjj > 1.) {
+
+/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
+
+/* Computing MIN */
+ d__1 = 1., d__2 = rec * tjj;
+ rec = min(d__1,d__2);
+ zladiv_(&z__1, &uscal, &tjjs);
+ uscal.r = z__1.r, uscal.i = z__1.i;
+ }
+ if (rec < 1.) {
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ csumj.r = 0., csumj.i = 0.;
+ if (uscal.r == 1. && uscal.i == 0.) {
+
+/* If the scaling needed for A in the dot product is 1, */
+/* call ZDOTC to perform the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ zdotc_(&z__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], &
+ c__1);
+ csumj.r = z__1.r, csumj.i = z__1.i;
+ } else if (j < *n) {
+ i__3 = *n - j;
+ zdotc_(&z__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], &
+ c__1);
+ csumj.r = z__1.r, csumj.i = z__1.i;
+ }
+ } else {
+
+/* Otherwise, use in-line code for the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d_cnjg(&z__4, &ap[ip - j + i__]);
+ z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
+ z__3.i = z__4.r * uscal.i + z__4.i *
+ uscal.r;
+ i__4 = i__;
+ z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i,
+ z__2.i = z__3.r * x[i__4].i + z__3.i * x[
+ i__4].r;
+ z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
+ z__2.i;
+ csumj.r = z__1.r, csumj.i = z__1.i;
+/* L180: */
+ }
+ } else if (j < *n) {
+ i__3 = *n - j;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d_cnjg(&z__4, &ap[ip + i__]);
+ z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
+ z__3.i = z__4.r * uscal.i + z__4.i *
+ uscal.r;
+ i__4 = j + i__;
+ z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i,
+ z__2.i = z__3.r * x[i__4].i + z__3.i * x[
+ i__4].r;
+ z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
+ z__2.i;
+ csumj.r = z__1.r, csumj.i = z__1.i;
+/* L190: */
+ }
+ }
+ }
+
+ z__1.r = tscal, z__1.i = 0.;
+ if (uscal.r == z__1.r && uscal.i == z__1.i) {
+
+/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
+/* was not used to scale the dotproduct. */
+
+ i__3 = j;
+ i__4 = j;
+ z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i -
+ csumj.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ i__3 = j;
+ xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
+ , abs(d__2));
+ if (nounit) {
+
+/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
+
+ d_cnjg(&z__2, &ap[ip]);
+ z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
+ tjjs.r = z__1.r, tjjs.i = z__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.;
+ if (tscal == 1.) {
+ goto L210;
+ }
+ }
+ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
+ abs(d__2));
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.) {
+ if (xj > tjj * bignum) {
+
+/* Scale X by 1/abs(x(j)). */
+
+ rec = 1. / xj;
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ i__3 = j;
+ zladiv_(&z__1, &x[j], &tjjs);
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ } else if (tjj > 0.) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
+
+ rec = tjj * bignum / xj;
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ i__3 = j;
+ zladiv_(&z__1, &x[j], &tjjs);
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0 and compute a solution to A**H *x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ x[i__4].r = 0., x[i__4].i = 0.;
+/* L200: */
+ }
+ i__3 = j;
+ x[i__3].r = 1., x[i__3].i = 0.;
+ *scale = 0.;
+ xmax = 0.;
+ }
+L210:
+ ;
+ } else {
+
+/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
+/* product has already been divided by 1/A(j,j). */
+
+ i__3 = j;
+ zladiv_(&z__2, &x[j], &tjjs);
+ z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ }
+/* Computing MAX */
+ i__3 = j;
+ d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&x[j]), abs(d__2));
+ xmax = max(d__3,d__4);
+ ++jlen;
+ ip += jinc * jlen;
+/* L220: */
+ }
+ }
+ *scale /= tscal;
+ }
+
+/* Scale the column norms by 1/TSCAL for return. */
+
+ if (tscal != 1.) {
+ d__1 = 1. / tscal;
+ dscal_(n, &d__1, &cnorm[1], &c__1);
+ }
+
+ return 0;
+
+/* End of ZLATPS */
+
+} /* zlatps_ */
diff --git a/SRC/zlatrd.c b/SRC/zlatrd.c
new file mode 100644
index 0000000..231c85d
--- /dev/null
+++ b/SRC/zlatrd.c
@@ -0,0 +1,420 @@
+/* zlatrd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zlatrd_(char *uplo, integer *n, integer *nb,
+ doublecomplex *a, integer *lda, doublereal *e, doublecomplex *tau,
+ doublecomplex *w, integer *ldw)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
+ doublereal d__1;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Local variables */
+ integer i__, iw;
+ doublecomplex alpha;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zhemv_(char *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *), zaxpy_(integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zlarfg_(integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *), zlacgv_(integer *, doublecomplex *,
+ integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to */
+/* Hermitian tridiagonal form by a unitary similarity */
+/* transformation Q' * A * Q, and returns the matrices V and W which are */
+/* needed to apply the transformation to the unreduced part of A. */
+
+/* If UPLO = 'U', ZLATRD reduces the last NB rows and columns of a */
+/* matrix, of which the upper triangle is supplied; */
+/* if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a */
+/* matrix, of which the lower triangle is supplied. */
+
+/* This is an auxiliary routine called by ZHETRD. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. */
+
+/* NB (input) INTEGER */
+/* The number of rows and columns to be reduced. */
+
+/* A (input/output) 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 UPLO = 'U', the last NB columns have been reduced to */
+/* tridiagonal form, with the diagonal elements overwriting */
+/* the diagonal elements of A; the elements above the diagonal */
+/* with the array TAU, represent the unitary matrix Q as a */
+/* product of elementary reflectors; */
+/* if UPLO = 'L', the first NB columns have been reduced to */
+/* tridiagonal form, with the diagonal elements overwriting */
+/* the diagonal elements of A; the elements below the diagonal */
+/* with the array TAU, represent the unitary matrix Q as a */
+/* product of elementary reflectors. */
+/* See Further Details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* E (output) DOUBLE PRECISION array, dimension (N-1) */
+/* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal */
+/* elements of the last NB columns of the reduced matrix; */
+/* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of */
+/* the first NB columns of the reduced matrix. */
+
+/* TAU (output) COMPLEX*16 array, dimension (N-1) */
+/* The scalar factors of the elementary reflectors, stored in */
+/* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. */
+/* See Further Details. */
+
+/* W (output) COMPLEX*16 array, dimension (LDW,NB) */
+/* The n-by-nb matrix W required to update the unreduced part */
+/* of A. */
+
+/* LDW (input) INTEGER */
+/* The leading dimension of the array W. LDW >= max(1,N). */
+
+/* Further Details */
+/* =============== */
+
+/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(n) H(n-1) . . . H(n-nb+1). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), */
+/* and tau in TAU(i-1). */
+
+/* If UPLO = 'L', the matrix Q is represented as a product of elementary */
+/* reflectors */
+
+/* Q = H(1) H(2) . . . H(nb). */
+
+/* Each H(i) has the form */
+
+/* H(i) = I - tau * v * v' */
+
+/* where tau is a complex scalar, and v is a complex vector with */
+/* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */
+/* and tau in TAU(i). */
+
+/* The elements of the vectors v together form the n-by-nb matrix V */
+/* which is needed, with W, to apply the transformation to the unreduced */
+/* part of the matrix, using a Hermitian rank-2k update of the form: */
+/* A := A - V*W' - W*V'. */
+
+/* The contents of A on exit are illustrated by the following examples */
+/* with n = 5 and nb = 2: */
+
+/* if UPLO = 'U': if UPLO = 'L': */
+
+/* ( a a a v4 v5 ) ( d ) */
+/* ( a a v4 v5 ) ( 1 d ) */
+/* ( a 1 v5 ) ( v1 1 a ) */
+/* ( d 1 ) ( v1 v2 a a ) */
+/* ( d ) ( v1 v2 a a a ) */
+
+/* where d denotes a diagonal element of the reduced matrix, a denotes */
+/* an element of the original matrix that is unchanged, and vi denotes */
+/* an element of the vector defining H(i). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --e;
+ --tau;
+ w_dim1 = *ldw;
+ w_offset = 1 + w_dim1;
+ w -= w_offset;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+
+ if (lsame_(uplo, "U")) {
+
+/* Reduce last NB columns of upper triangle */
+
+ i__1 = *n - *nb + 1;
+ for (i__ = *n; i__ >= i__1; --i__) {
+ iw = i__ - *n + *nb;
+ if (i__ < *n) {
+
+/* Update A(1:i,i) */
+
+ i__2 = i__ + i__ * a_dim1;
+ i__3 = i__ + i__ * a_dim1;
+ d__1 = a[i__3].r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ i__2 = *n - i__;
+ zlacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw);
+ i__2 = *n - i__;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__, &i__2, &z__1, &a[(i__ + 1) *
+ a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, &
+ c_b2, &a[i__ * a_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ zlacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw);
+ i__2 = *n - i__;
+ zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
+ i__2 = *n - i__;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__, &i__2, &z__1, &w[(iw + 1) *
+ w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, &
+ c_b2, &a[i__ * a_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
+ i__2 = i__ + i__ * a_dim1;
+ i__3 = i__ + i__ * a_dim1;
+ d__1 = a[i__3].r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ }
+ if (i__ > 1) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* A(1:i-2,i) */
+
+ i__2 = i__ - 1 + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = i__ - 1;
+ zlarfg_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &tau[i__
+ - 1]);
+ i__2 = i__ - 1;
+ e[i__2] = alpha.r;
+ i__2 = i__ - 1 + i__ * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+
+/* Compute W(1:i-1,i) */
+
+ i__2 = i__ - 1;
+ zhemv_("Upper", &i__2, &c_b2, &a[a_offset], lda, &a[i__ *
+ a_dim1 + 1], &c__1, &c_b1, &w[iw * w_dim1 + 1], &c__1);
+ if (i__ < *n) {
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w[(iw
+ + 1) * w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], &
+ c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__2, &i__3, &z__1, &a[(i__ + 1) *
+ a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], &
+ c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[(
+ i__ + 1) * a_dim1 + 1], lda, &a[i__ * a_dim1 + 1],
+ &c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__2, &i__3, &z__1, &w[(iw + 1) *
+ w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], &
+ c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1);
+ }
+ i__2 = i__ - 1;
+ zscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1);
+ z__3.r = -.5, z__3.i = -0.;
+ i__2 = i__ - 1;
+ z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i, z__2.i =
+ z__3.r * tau[i__2].i + z__3.i * tau[i__2].r;
+ i__3 = i__ - 1;
+ zdotc_(&z__4, &i__3, &w[iw * w_dim1 + 1], &c__1, &a[i__ *
+ a_dim1 + 1], &c__1);
+ z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r *
+ z__4.i + z__2.i * z__4.r;
+ alpha.r = z__1.r, alpha.i = z__1.i;
+ i__2 = i__ - 1;
+ zaxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw *
+ w_dim1 + 1], &c__1);
+ }
+
+/* L10: */
+ }
+ } else {
+
+/* Reduce first NB columns of lower triangle */
+
+ i__1 = *nb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Update A(i:n,i) */
+
+ i__2 = i__ + i__ * a_dim1;
+ i__3 = i__ + i__ * a_dim1;
+ d__1 = a[i__3].r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ i__2 = i__ - 1;
+ zlacgv_(&i__2, &w[i__ + w_dim1], ldw);
+ i__2 = *n - i__ + 1;
+ i__3 = i__ - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + a_dim1], lda,
+ &w[i__ + w_dim1], ldw, &c_b2, &a[i__ + i__ * a_dim1], &
+ c__1);
+ i__2 = i__ - 1;
+ zlacgv_(&i__2, &w[i__ + w_dim1], ldw);
+ i__2 = i__ - 1;
+ zlacgv_(&i__2, &a[i__ + a_dim1], lda);
+ i__2 = *n - i__ + 1;
+ i__3 = i__ - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__2, &i__3, &z__1, &w[i__ + w_dim1], ldw,
+ &a[i__ + a_dim1], lda, &c_b2, &a[i__ + i__ * a_dim1], &
+ c__1);
+ i__2 = i__ - 1;
+ zlacgv_(&i__2, &a[i__ + a_dim1], lda);
+ i__2 = i__ + i__ * a_dim1;
+ i__3 = i__ + i__ * a_dim1;
+ d__1 = a[i__3].r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ if (i__ < *n) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* A(i+2:n,i) */
+
+ i__2 = i__ + 1 + i__ * a_dim1;
+ alpha.r = a[i__2].r, alpha.i = a[i__2].i;
+ i__2 = *n - i__;
+/* Computing MIN */
+ i__3 = i__ + 2;
+ zlarfg_(&i__2, &alpha, &a[min(i__3, *n)+ i__ * a_dim1], &c__1,
+ &tau[i__]);
+ i__2 = i__;
+ e[i__2] = alpha.r;
+ i__2 = i__ + 1 + i__ * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+
+/* Compute W(i+1:n,i) */
+
+ i__2 = *n - i__;
+ zhemv_("Lower", &i__2, &c_b2, &a[i__ + 1 + (i__ + 1) * a_dim1]
+, lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b1, &w[
+ i__ + 1 + i__ * w_dim1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w[i__ + 1
+ + w_dim1], ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, &
+ c_b1, &w[i__ * w_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + 1 +
+ a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[
+ i__ + 1 + i__ * w_dim1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1
+ + a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &
+ c_b1, &w[i__ * w_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__2, &i__3, &z__1, &w[i__ + 1 +
+ w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[
+ i__ + 1 + i__ * w_dim1], &c__1);
+ i__2 = *n - i__;
+ zscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1);
+ z__3.r = -.5, z__3.i = -0.;
+ i__2 = i__;
+ z__2.r = z__3.r * tau[i__2].r - z__3.i * tau[i__2].i, z__2.i =
+ z__3.r * tau[i__2].i + z__3.i * tau[i__2].r;
+ i__3 = *n - i__;
+ zdotc_(&z__4, &i__3, &w[i__ + 1 + i__ * w_dim1], &c__1, &a[
+ i__ + 1 + i__ * a_dim1], &c__1);
+ z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r *
+ z__4.i + z__2.i * z__4.r;
+ alpha.r = z__1.r, alpha.i = z__1.i;
+ i__2 = *n - i__;
+ zaxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[
+ i__ + 1 + i__ * w_dim1], &c__1);
+ }
+
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of ZLATRD */
+
+} /* zlatrd_ */
diff --git a/SRC/zlatrs.c b/SRC/zlatrs.c
new file mode 100644
index 0000000..06fe9bb
--- /dev/null
+++ b/SRC/zlatrs.c
@@ -0,0 +1,1150 @@
+/* zlatrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b36 = .5;
+
+/* Subroutine */ int zlatrs_(char *uplo, char *trans, char *diag, char *
+ normin, integer *n, doublecomplex *a, integer *lda, doublecomplex *x,
+ doublereal *scale, doublereal *cnorm, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal xj, rec, tjj;
+ integer jinc;
+ doublereal xbnd;
+ integer imax;
+ doublereal tmax;
+ doublecomplex tjjs;
+ doublereal xmax, grow;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ doublereal tscal;
+ doublecomplex uscal;
+ integer jlast;
+ doublecomplex csumj;
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ logical upper;
+ extern /* Double Complex */ VOID zdotu_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), ztrsv_(
+ char *, char *, char *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), dlabad_(
+ doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
+ integer *, doublereal *, doublecomplex *, integer *);
+ doublereal bignum;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
+ doublecomplex *);
+ logical notran;
+ integer jfirst;
+ extern doublereal dzasum_(integer *, doublecomplex *, integer *);
+ doublereal smlnum;
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLATRS solves one of the triangular systems */
+
+/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */
+
+/* with scaling to prevent overflow. Here A is an upper or lower */
+/* triangular matrix, A**T denotes the transpose of A, A**H denotes the */
+/* conjugate transpose of A, x and b are n-element vectors, and s is a */
+/* scaling factor, usually less than or equal to 1, chosen so that the */
+/* components of x will be less than the overflow threshold. If the */
+/* unscaled problem will not cause overflow, the Level 2 BLAS routine */
+/* ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j), */
+/* then s is set to 0 and a non-trivial solution to A*x = 0 is returned. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': Solve A * x = s*b (No transpose) */
+/* = 'T': Solve A**T * x = s*b (Transpose) */
+/* = 'C': Solve A**H * x = s*b (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* NORMIN (input) CHARACTER*1 */
+/* Specifies whether CNORM has been set or not. */
+/* = 'Y': CNORM contains the column norms on entry */
+/* = 'N': CNORM is not set on entry. On exit, the norms will */
+/* be computed and stored in CNORM. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max (1,N). */
+
+/* X (input/output) COMPLEX*16 array, dimension (N) */
+/* On entry, the right hand side b of the triangular system. */
+/* On exit, X is overwritten by the solution vector x. */
+
+/* SCALE (output) DOUBLE PRECISION */
+/* The scaling factor s for the triangular system */
+/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b. */
+/* If SCALE = 0, the matrix A is singular or badly scaled, and */
+/* the vector x is an exact or approximate solution to A*x = 0. */
+
+/* CNORM (input or output) DOUBLE PRECISION array, dimension (N) */
+
+/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
+/* contains the norm of the off-diagonal part of the j-th column */
+/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */
+/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
+/* must be greater than or equal to the 1-norm. */
+
+/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
+/* returns the 1-norm of the offdiagonal part of the j-th column */
+/* of A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* Further Details */
+/* ======= ======= */
+
+/* A rough bound on x is computed; if that is less than overflow, ZTRSV */
+/* is called, otherwise, specific code is used which checks for possible */
+/* overflow or divide-by-zero at every operation. */
+
+/* A columnwise scheme is used for solving A*x = b. The basic algorithm */
+/* if A is lower triangular is */
+
+/* x[1:n] := b[1:n] */
+/* for j = 1, ..., n */
+/* x(j) := x(j) / A(j,j) */
+/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
+/* end */
+
+/* Define bounds on the components of x after j iterations of the loop: */
+/* M(j) = bound on x[1:j] */
+/* G(j) = bound on x[j+1:n] */
+/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */
+
+/* Then for iteration j+1 we have */
+/* M(j+1) <= G(j) / | A(j+1,j+1) | */
+/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
+/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
+
+/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
+/* column j+1 of A, not counting the diagonal. Hence */
+
+/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
+/* 1<=i<=j */
+/* and */
+
+/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
+/* 1<=i< j */
+
+/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTRSV if the */
+/* reciprocal of the largest M(j), j=1,..,n, is larger than */
+/* max(underflow, 1/overflow). */
+
+/* The bound on x(j) is also used to determine when a step in the */
+/* columnwise method can be performed without fear of overflow. If */
+/* the computed bound is greater than a large constant, x is scaled to */
+/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
+/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
+
+/* Similarly, a row-wise scheme is used to solve A**T *x = b or */
+/* A**H *x = b. The basic algorithm for A upper triangular is */
+
+/* for j = 1, ..., n */
+/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
+/* end */
+
+/* We simultaneously compute two bounds */
+/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
+/* M(j) = bound on x(i), 1<=i<=j */
+
+/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */
+/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
+/* Then the bound on x(j) is */
+
+/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
+
+/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
+/* 1<=i<=j */
+
+/* and we can safely call ZTRSV if 1/M(n) and 1/G(n) are both greater */
+/* than max(underflow, 1/overflow). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --cnorm;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+/* Test the input parameters. */
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (! lsame_(normin, "Y") && ! lsame_(normin,
+ "N")) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLATRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine machine dependent parameters to control overflow. */
+
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ smlnum /= dlamch_("Precision");
+ bignum = 1. / smlnum;
+ *scale = 1.;
+
+ if (lsame_(normin, "N")) {
+
+/* Compute the 1-norm of each column, not including the diagonal. */
+
+ if (upper) {
+
+/* A is upper triangular. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ cnorm[j] = dzasum_(&i__2, &a[j * a_dim1 + 1], &c__1);
+/* L10: */
+ }
+ } else {
+
+/* A is lower triangular. */
+
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ cnorm[j] = dzasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1);
+/* L20: */
+ }
+ cnorm[*n] = 0.;
+ }
+ }
+
+/* Scale the column norms by TSCAL if the maximum element in CNORM is */
+/* greater than BIGNUM/2. */
+
+ imax = idamax_(n, &cnorm[1], &c__1);
+ tmax = cnorm[imax];
+ if (tmax <= bignum * .5) {
+ tscal = 1.;
+ } else {
+ tscal = .5 / (smlnum * tmax);
+ dscal_(n, &tscal, &cnorm[1], &c__1);
+ }
+
+/* Compute a bound on the computed solution vector to see if the */
+/* Level 2 BLAS routine ZTRSV can be used. */
+
+ xmax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j;
+ d__3 = xmax, d__4 = (d__1 = x[i__2].r / 2., abs(d__1)) + (d__2 =
+ d_imag(&x[j]) / 2., abs(d__2));
+ xmax = max(d__3,d__4);
+/* L30: */
+ }
+ xbnd = xmax;
+
+ if (notran) {
+
+/* Compute the growth in A * x = b. */
+
+ if (upper) {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ } else {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ }
+
+ if (tscal != 1.) {
+ grow = 0.;
+ goto L60;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, G(0) = max{x(i), i=1,...,n}. */
+
+ grow = .5 / max(xbnd,smlnum);
+ xbnd = grow;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L60;
+ }
+
+ i__3 = j + j * a_dim1;
+ tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
+ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
+ d__2));
+
+ if (tjj >= smlnum) {
+
+/* M(j) = G(j-1) / abs(A(j,j)) */
+
+/* Computing MIN */
+ d__1 = xbnd, d__2 = min(1.,tjj) * grow;
+ xbnd = min(d__1,d__2);
+ } else {
+
+/* M(j) could overflow, set XBND to 0. */
+
+ xbnd = 0.;
+ }
+
+ if (tjj + cnorm[j] >= smlnum) {
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
+
+ grow *= tjj / (tjj + cnorm[j]);
+ } else {
+
+/* G(j) could overflow, set GROW to 0. */
+
+ grow = 0.;
+ }
+/* L40: */
+ }
+ grow = xbnd;
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
+ grow = min(d__1,d__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L60;
+ }
+
+/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
+
+ grow *= 1. / (cnorm[j] + 1.);
+/* L50: */
+ }
+ }
+L60:
+
+ ;
+ } else {
+
+/* Compute the growth in A**T * x = b or A**H * x = b. */
+
+ if (upper) {
+ jfirst = 1;
+ jlast = *n;
+ jinc = 1;
+ } else {
+ jfirst = *n;
+ jlast = 1;
+ jinc = -1;
+ }
+
+ if (tscal != 1.) {
+ grow = 0.;
+ goto L90;
+ }
+
+ if (nounit) {
+
+/* A is non-unit triangular. */
+
+/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
+/* Initially, M(0) = max{x(i), i=1,...,n}. */
+
+ grow = .5 / max(xbnd,smlnum);
+ xbnd = grow;
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L90;
+ }
+
+/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
+
+ xj = cnorm[j] + 1.;
+/* Computing MIN */
+ d__1 = grow, d__2 = xbnd / xj;
+ grow = min(d__1,d__2);
+
+ i__3 = j + j * a_dim1;
+ tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
+ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
+ d__2));
+
+ if (tjj >= smlnum) {
+
+/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
+
+ if (xj > tjj) {
+ xbnd *= tjj / xj;
+ }
+ } else {
+
+/* M(j) could overflow, set XBND to 0. */
+
+ xbnd = 0.;
+ }
+/* L70: */
+ }
+ grow = min(grow,xbnd);
+ } else {
+
+/* A is unit triangular. */
+
+/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
+
+/* Computing MIN */
+ d__1 = 1., d__2 = .5 / max(xbnd,smlnum);
+ grow = min(d__1,d__2);
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Exit the loop if the growth factor is too small. */
+
+ if (grow <= smlnum) {
+ goto L90;
+ }
+
+/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
+
+ xj = cnorm[j] + 1.;
+ grow /= xj;
+/* L80: */
+ }
+ }
+L90:
+ ;
+ }
+
+ if (grow * tscal > smlnum) {
+
+/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
+/* elements of X is not too small. */
+
+ ztrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1);
+ } else {
+
+/* Use a Level 1 BLAS solve, scaling intermediate results. */
+
+ if (xmax > bignum * .5) {
+
+/* Scale X so that its components are less than or equal to */
+/* BIGNUM in absolute value. */
+
+ *scale = bignum * .5 / xmax;
+ zdscal_(n, scale, &x[1], &c__1);
+ xmax = bignum;
+ } else {
+ xmax *= 2.;
+ }
+
+ if (notran) {
+
+/* Solve A * x = b */
+
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
+
+ i__3 = j;
+ xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
+ abs(d__2));
+ if (nounit) {
+ i__3 = j + j * a_dim1;
+ z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3].i;
+ tjjs.r = z__1.r, tjjs.i = z__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.;
+ if (tscal == 1.) {
+ goto L110;
+ }
+ }
+ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs(
+ d__2));
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.) {
+ if (xj > tjj * bignum) {
+
+/* Scale x by 1/b(j). */
+
+ rec = 1. / xj;
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ i__3 = j;
+ zladiv_(&z__1, &x[j], &tjjs);
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ i__3 = j;
+ xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
+ , abs(d__2));
+ } else if (tjj > 0.) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
+/* to avoid overflow when dividing by A(j,j). */
+
+ rec = tjj * bignum / xj;
+ if (cnorm[j] > 1.) {
+
+/* Scale by 1/CNORM(j) to avoid overflow when */
+/* multiplying x(j) times column j. */
+
+ rec /= cnorm[j];
+ }
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ i__3 = j;
+ zladiv_(&z__1, &x[j], &tjjs);
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ i__3 = j;
+ xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
+ , abs(d__2));
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0, and compute a solution to A*x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ x[i__4].r = 0., x[i__4].i = 0.;
+/* L100: */
+ }
+ i__3 = j;
+ x[i__3].r = 1., x[i__3].i = 0.;
+ xj = 1.;
+ *scale = 0.;
+ xmax = 0.;
+ }
+L110:
+
+/* Scale x if necessary to avoid overflow when adding a */
+/* multiple of column j of A. */
+
+ if (xj > 1.) {
+ rec = 1. / xj;
+ if (cnorm[j] > (bignum - xmax) * rec) {
+
+/* Scale x by 1/(2*abs(x(j))). */
+
+ rec *= .5;
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ }
+ } else if (xj * cnorm[j] > bignum - xmax) {
+
+/* Scale x by 1/2. */
+
+ zdscal_(n, &c_b36, &x[1], &c__1);
+ *scale *= .5;
+ }
+
+ if (upper) {
+ if (j > 1) {
+
+/* Compute the update */
+/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */
+
+ i__3 = j - 1;
+ i__4 = j;
+ z__2.r = -x[i__4].r, z__2.i = -x[i__4].i;
+ z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
+ zaxpy_(&i__3, &z__1, &a[j * a_dim1 + 1], &c__1, &x[1],
+ &c__1);
+ i__3 = j - 1;
+ i__ = izamax_(&i__3, &x[1], &c__1);
+ i__3 = i__;
+ xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
+ &x[i__]), abs(d__2));
+ }
+ } else {
+ if (j < *n) {
+
+/* Compute the update */
+/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */
+
+ i__3 = *n - j;
+ i__4 = j;
+ z__2.r = -x[i__4].r, z__2.i = -x[i__4].i;
+ z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
+ zaxpy_(&i__3, &z__1, &a[j + 1 + j * a_dim1], &c__1, &
+ x[j + 1], &c__1);
+ i__3 = *n - j;
+ i__ = j + izamax_(&i__3, &x[j + 1], &c__1);
+ i__3 = i__;
+ xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
+ &x[i__]), abs(d__2));
+ }
+ }
+/* L120: */
+ }
+
+ } else if (lsame_(trans, "T")) {
+
+/* Solve A**T * x = b */
+
+ i__2 = jlast;
+ i__1 = jinc;
+ for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
+/* k<>j */
+
+ i__3 = j;
+ xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
+ abs(d__2));
+ uscal.r = tscal, uscal.i = 0.;
+ rec = 1. / max(xmax,1.);
+ if (cnorm[j] > (bignum - xj) * rec) {
+
+/* If x(j) could overflow, scale x by 1/(2*XMAX). */
+
+ rec *= .5;
+ if (nounit) {
+ i__3 = j + j * a_dim1;
+ z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3]
+ .i;
+ tjjs.r = z__1.r, tjjs.i = z__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.;
+ }
+ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
+ abs(d__2));
+ if (tjj > 1.) {
+
+/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
+
+/* Computing MIN */
+ d__1 = 1., d__2 = rec * tjj;
+ rec = min(d__1,d__2);
+ zladiv_(&z__1, &uscal, &tjjs);
+ uscal.r = z__1.r, uscal.i = z__1.i;
+ }
+ if (rec < 1.) {
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ csumj.r = 0., csumj.i = 0.;
+ if (uscal.r == 1. && uscal.i == 0.) {
+
+/* If the scaling needed for A in the dot product is 1, */
+/* call ZDOTU to perform the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ zdotu_(&z__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
+ &c__1);
+ csumj.r = z__1.r, csumj.i = z__1.i;
+ } else if (j < *n) {
+ i__3 = *n - j;
+ zdotu_(&z__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
+ x[j + 1], &c__1);
+ csumj.r = z__1.r, csumj.i = z__1.i;
+ }
+ } else {
+
+/* Otherwise, use in-line code for the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ z__3.r = a[i__4].r * uscal.r - a[i__4].i *
+ uscal.i, z__3.i = a[i__4].r * uscal.i + a[
+ i__4].i * uscal.r;
+ i__5 = i__;
+ z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i,
+ z__2.i = z__3.r * x[i__5].i + z__3.i * x[
+ i__5].r;
+ z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
+ z__2.i;
+ csumj.r = z__1.r, csumj.i = z__1.i;
+/* L130: */
+ }
+ } else if (j < *n) {
+ i__3 = *n;
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ z__3.r = a[i__4].r * uscal.r - a[i__4].i *
+ uscal.i, z__3.i = a[i__4].r * uscal.i + a[
+ i__4].i * uscal.r;
+ i__5 = i__;
+ z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i,
+ z__2.i = z__3.r * x[i__5].i + z__3.i * x[
+ i__5].r;
+ z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
+ z__2.i;
+ csumj.r = z__1.r, csumj.i = z__1.i;
+/* L140: */
+ }
+ }
+ }
+
+ z__1.r = tscal, z__1.i = 0.;
+ if (uscal.r == z__1.r && uscal.i == z__1.i) {
+
+/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
+/* was not used to scale the dotproduct. */
+
+ i__3 = j;
+ i__4 = j;
+ z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i -
+ csumj.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ i__3 = j;
+ xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
+ , abs(d__2));
+ if (nounit) {
+ i__3 = j + j * a_dim1;
+ z__1.r = tscal * a[i__3].r, z__1.i = tscal * a[i__3]
+ .i;
+ tjjs.r = z__1.r, tjjs.i = z__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.;
+ if (tscal == 1.) {
+ goto L160;
+ }
+ }
+
+/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
+
+ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
+ abs(d__2));
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.) {
+ if (xj > tjj * bignum) {
+
+/* Scale X by 1/abs(x(j)). */
+
+ rec = 1. / xj;
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ i__3 = j;
+ zladiv_(&z__1, &x[j], &tjjs);
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ } else if (tjj > 0.) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
+
+ rec = tjj * bignum / xj;
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ i__3 = j;
+ zladiv_(&z__1, &x[j], &tjjs);
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0 and compute a solution to A**T *x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ x[i__4].r = 0., x[i__4].i = 0.;
+/* L150: */
+ }
+ i__3 = j;
+ x[i__3].r = 1., x[i__3].i = 0.;
+ *scale = 0.;
+ xmax = 0.;
+ }
+L160:
+ ;
+ } else {
+
+/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
+/* product has already been divided by 1/A(j,j). */
+
+ i__3 = j;
+ zladiv_(&z__2, &x[j], &tjjs);
+ z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ }
+/* Computing MAX */
+ i__3 = j;
+ d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&x[j]), abs(d__2));
+ xmax = max(d__3,d__4);
+/* L170: */
+ }
+
+ } else {
+
+/* Solve A**H * x = b */
+
+ i__1 = jlast;
+ i__2 = jinc;
+ for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
+/* k<>j */
+
+ i__3 = j;
+ xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]),
+ abs(d__2));
+ uscal.r = tscal, uscal.i = 0.;
+ rec = 1. / max(xmax,1.);
+ if (cnorm[j] > (bignum - xj) * rec) {
+
+/* If x(j) could overflow, scale x by 1/(2*XMAX). */
+
+ rec *= .5;
+ if (nounit) {
+ d_cnjg(&z__2, &a[j + j * a_dim1]);
+ z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
+ tjjs.r = z__1.r, tjjs.i = z__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.;
+ }
+ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
+ abs(d__2));
+ if (tjj > 1.) {
+
+/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
+
+/* Computing MIN */
+ d__1 = 1., d__2 = rec * tjj;
+ rec = min(d__1,d__2);
+ zladiv_(&z__1, &uscal, &tjjs);
+ uscal.r = z__1.r, uscal.i = z__1.i;
+ }
+ if (rec < 1.) {
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+
+ csumj.r = 0., csumj.i = 0.;
+ if (uscal.r == 1. && uscal.i == 0.) {
+
+/* If the scaling needed for A in the dot product is 1, */
+/* call ZDOTC to perform the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ zdotc_(&z__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
+ &c__1);
+ csumj.r = z__1.r, csumj.i = z__1.i;
+ } else if (j < *n) {
+ i__3 = *n - j;
+ zdotc_(&z__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
+ x[j + 1], &c__1);
+ csumj.r = z__1.r, csumj.i = z__1.i;
+ }
+ } else {
+
+/* Otherwise, use in-line code for the dot product. */
+
+ if (upper) {
+ i__3 = j - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d_cnjg(&z__4, &a[i__ + j * a_dim1]);
+ z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
+ z__3.i = z__4.r * uscal.i + z__4.i *
+ uscal.r;
+ i__4 = i__;
+ z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i,
+ z__2.i = z__3.r * x[i__4].i + z__3.i * x[
+ i__4].r;
+ z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
+ z__2.i;
+ csumj.r = z__1.r, csumj.i = z__1.i;
+/* L180: */
+ }
+ } else if (j < *n) {
+ i__3 = *n;
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ d_cnjg(&z__4, &a[i__ + j * a_dim1]);
+ z__3.r = z__4.r * uscal.r - z__4.i * uscal.i,
+ z__3.i = z__4.r * uscal.i + z__4.i *
+ uscal.r;
+ i__4 = i__;
+ z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i,
+ z__2.i = z__3.r * x[i__4].i + z__3.i * x[
+ i__4].r;
+ z__1.r = csumj.r + z__2.r, z__1.i = csumj.i +
+ z__2.i;
+ csumj.r = z__1.r, csumj.i = z__1.i;
+/* L190: */
+ }
+ }
+ }
+
+ z__1.r = tscal, z__1.i = 0.;
+ if (uscal.r == z__1.r && uscal.i == z__1.i) {
+
+/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
+/* was not used to scale the dotproduct. */
+
+ i__3 = j;
+ i__4 = j;
+ z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i -
+ csumj.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ i__3 = j;
+ xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j])
+ , abs(d__2));
+ if (nounit) {
+ d_cnjg(&z__2, &a[j + j * a_dim1]);
+ z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
+ tjjs.r = z__1.r, tjjs.i = z__1.i;
+ } else {
+ tjjs.r = tscal, tjjs.i = 0.;
+ if (tscal == 1.) {
+ goto L210;
+ }
+ }
+
+/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
+
+ tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs),
+ abs(d__2));
+ if (tjj > smlnum) {
+
+/* abs(A(j,j)) > SMLNUM: */
+
+ if (tjj < 1.) {
+ if (xj > tjj * bignum) {
+
+/* Scale X by 1/abs(x(j)). */
+
+ rec = 1. / xj;
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ }
+ i__3 = j;
+ zladiv_(&z__1, &x[j], &tjjs);
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ } else if (tjj > 0.) {
+
+/* 0 < abs(A(j,j)) <= SMLNUM: */
+
+ if (xj > tjj * bignum) {
+
+/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
+
+ rec = tjj * bignum / xj;
+ zdscal_(n, &rec, &x[1], &c__1);
+ *scale *= rec;
+ xmax *= rec;
+ }
+ i__3 = j;
+ zladiv_(&z__1, &x[j], &tjjs);
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ } else {
+
+/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
+/* scale = 0 and compute a solution to A**H *x = 0. */
+
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ x[i__4].r = 0., x[i__4].i = 0.;
+/* L200: */
+ }
+ i__3 = j;
+ x[i__3].r = 1., x[i__3].i = 0.;
+ *scale = 0.;
+ xmax = 0.;
+ }
+L210:
+ ;
+ } else {
+
+/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
+/* product has already been divided by 1/A(j,j). */
+
+ i__3 = j;
+ zladiv_(&z__2, &x[j], &tjjs);
+ z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ }
+/* Computing MAX */
+ i__3 = j;
+ d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&x[j]), abs(d__2));
+ xmax = max(d__3,d__4);
+/* L220: */
+ }
+ }
+ *scale /= tscal;
+ }
+
+/* Scale the column norms by 1/TSCAL for return. */
+
+ if (tscal != 1.) {
+ d__1 = 1. / tscal;
+ dscal_(n, &d__1, &cnorm[1], &c__1);
+ }
+
+ return 0;
+
+/* End of ZLATRS */
+
+} /* zlatrs_ */
diff --git a/SRC/zlatrz.c b/SRC/zlatrz.c
new file mode 100644
index 0000000..21b55c1
--- /dev/null
+++ b/SRC/zlatrz.c
@@ -0,0 +1,181 @@
+/* zlatrz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlatrz_(integer *m, integer *n, integer *l,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__;
+ doublecomplex alpha;
+ extern /* Subroutine */ int zlarz_(char *, integer *, integer *, integer *
+, doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *), zlacgv_(integer *,
+ doublecomplex *, integer *), zlarfp_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLATRZ factors the M-by-(M+L) complex upper trapezoidal matrix */
+/* [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z by means */
+/* of unitary transformations, where Z is an (M+L)-by-(M+L) unitary */
+/* matrix and, R and A1 are M-by-M upper triangular matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* L (input) INTEGER */
+/* The number of columns of the matrix A containing the */
+/* meaningful part of the Householder vectors. N-M >= L >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the leading M-by-N upper trapezoidal part of the */
+/* array A must contain the matrix to be factorized. */
+/* On exit, the leading M-by-M upper triangular part of A */
+/* contains the upper triangular matrix R, and elements N-L+1 to */
+/* N of the first M rows of A, with the array TAU, represent the */
+/* unitary matrix Z as a product of M elementary reflectors. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX*16 array, dimension (M) */
+/* The scalar factors of the elementary reflectors. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (M) */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* The factorization is obtained by Householder's method. The kth */
+/* transformation matrix, Z( k ), which is used to introduce zeros into */
+/* the ( m - k + 1 )th row of A, is given in the form */
+
+/* Z( k ) = ( I 0 ), */
+/* ( 0 T( k ) ) */
+
+/* where */
+
+/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */
+/* ( 0 ) */
+/* ( z( k ) ) */
+
+/* tau is a scalar and z( k ) is an l element vector. tau and z( k ) */
+/* are chosen to annihilate the elements of the kth row of A2. */
+
+/* The scalar tau is returned in the kth element of TAU and the vector */
+/* u( k ) in the kth row of A2, such that the elements of z( k ) are */
+/* in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in */
+/* the upper triangular part of A1. */
+
+/* Z is given by */
+
+/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ if (*m == 0) {
+ return 0;
+ } else if (*m == *n) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ tau[i__2].r = 0., tau[i__2].i = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+ for (i__ = *m; i__ >= 1; --i__) {
+
+/* Generate elementary reflector H(i) to annihilate */
+/* [ A(i,i) A(i,n-l+1:n) ] */
+
+ zlacgv_(l, &a[i__ + (*n - *l + 1) * a_dim1], lda);
+ d_cnjg(&z__1, &a[i__ + i__ * a_dim1]);
+ alpha.r = z__1.r, alpha.i = z__1.i;
+ i__1 = *l + 1;
+ zlarfp_(&i__1, &alpha, &a[i__ + (*n - *l + 1) * a_dim1], lda, &tau[
+ i__]);
+ i__1 = i__;
+ d_cnjg(&z__1, &tau[i__]);
+ tau[i__1].r = z__1.r, tau[i__1].i = z__1.i;
+
+/* Apply H(i) to A(1:i-1,i:n) from the right */
+
+ i__1 = i__ - 1;
+ i__2 = *n - i__ + 1;
+ d_cnjg(&z__1, &tau[i__]);
+ zlarz_("Right", &i__1, &i__2, l, &a[i__ + (*n - *l + 1) * a_dim1],
+ lda, &z__1, &a[i__ * a_dim1 + 1], lda, &work[1]);
+ i__1 = i__ + i__ * a_dim1;
+ d_cnjg(&z__1, &alpha);
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+
+/* L20: */
+ }
+
+ return 0;
+
+/* End of ZLATRZ */
+
+} /* zlatrz_ */
diff --git a/SRC/zlatzm.c b/SRC/zlatzm.c
new file mode 100644
index 0000000..74b1114
--- /dev/null
+++ b/SRC/zlatzm.c
@@ -0,0 +1,198 @@
+/* zlatzm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zlatzm_(char *side, integer *m, integer *n,
+ doublecomplex *v, integer *incv, doublecomplex *tau, doublecomplex *
+ c1, doublecomplex *c2, integer *ldc, doublecomplex *work)
+{
+ /* System generated locals */
+ integer c1_dim1, c1_offset, c2_dim1, c2_offset, i__1;
+ doublecomplex z__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zgeru_(integer *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *)
+ , zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *), zlacgv_(integer *,
+ doublecomplex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine ZUNMRZ. */
+
+/* ZLATZM applies a Householder matrix generated by ZTZRQF to a matrix. */
+
+/* Let P = I - tau*u*u', u = ( 1 ), */
+/* ( v ) */
+/* where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if */
+/* SIDE = 'R'. */
+
+/* If SIDE equals 'L', let */
+/* C = [ C1 ] 1 */
+/* [ C2 ] m-1 */
+/* n */
+/* Then C is overwritten by P*C. */
+
+/* If SIDE equals 'R', let */
+/* C = [ C1, C2 ] m */
+/* 1 n-1 */
+/* Then C is overwritten by C*P. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': form P * C */
+/* = 'R': form C * P */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. */
+
+/* V (input) COMPLEX*16 array, dimension */
+/* (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
+/* (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
+/* The vector v in the representation of P. V is not used */
+/* if TAU = 0. */
+
+/* INCV (input) INTEGER */
+/* The increment between elements of v. INCV <> 0 */
+
+/* TAU (input) COMPLEX*16 */
+/* The value tau in the representation of P. */
+
+/* C1 (input/output) COMPLEX*16 array, dimension */
+/* (LDC,N) if SIDE = 'L' */
+/* (M,1) if SIDE = 'R' */
+/* On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1 */
+/* if SIDE = 'R'. */
+
+/* On exit, the first row of P*C if SIDE = 'L', or the first */
+/* column of C*P if SIDE = 'R'. */
+
+/* C2 (input/output) COMPLEX*16 array, dimension */
+/* (LDC, N) if SIDE = 'L' */
+/* (LDC, N-1) if SIDE = 'R' */
+/* On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the */
+/* m x (n - 1) matrix C2 if SIDE = 'R'. */
+
+/* On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P */
+/* if SIDE = 'R'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the arrays C1 and C2. */
+/* LDC >= max(1,M). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (N) if SIDE = 'L' */
+/* (M) if SIDE = 'R' */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --v;
+ c2_dim1 = *ldc;
+ c2_offset = 1 + c2_dim1;
+ c2 -= c2_offset;
+ c1_dim1 = *ldc;
+ c1_offset = 1 + c1_dim1;
+ c1 -= c1_offset;
+ --work;
+
+ /* Function Body */
+ if (min(*m,*n) == 0 || tau->r == 0. && tau->i == 0.) {
+ return 0;
+ }
+
+ if (lsame_(side, "L")) {
+
+/* w := conjg( C1 + v' * C2 ) */
+
+ zcopy_(n, &c1[c1_offset], ldc, &work[1], &c__1);
+ zlacgv_(n, &work[1], &c__1);
+ i__1 = *m - 1;
+ zgemv_("Conjugate transpose", &i__1, n, &c_b1, &c2[c2_offset], ldc, &
+ v[1], incv, &c_b1, &work[1], &c__1);
+
+/* [ C1 ] := [ C1 ] - tau* [ 1 ] * w' */
+/* [ C2 ] [ C2 ] [ v ] */
+
+ zlacgv_(n, &work[1], &c__1);
+ z__1.r = -tau->r, z__1.i = -tau->i;
+ zaxpy_(n, &z__1, &work[1], &c__1, &c1[c1_offset], ldc);
+ i__1 = *m - 1;
+ z__1.r = -tau->r, z__1.i = -tau->i;
+ zgeru_(&i__1, n, &z__1, &v[1], incv, &work[1], &c__1, &c2[c2_offset],
+ ldc);
+
+ } else if (lsame_(side, "R")) {
+
+/* w := C1 + C2 * v */
+
+ zcopy_(m, &c1[c1_offset], &c__1, &work[1], &c__1);
+ i__1 = *n - 1;
+ zgemv_("No transpose", m, &i__1, &c_b1, &c2[c2_offset], ldc, &v[1],
+ incv, &c_b1, &work[1], &c__1);
+
+/* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v'] */
+
+ z__1.r = -tau->r, z__1.i = -tau->i;
+ zaxpy_(m, &z__1, &work[1], &c__1, &c1[c1_offset], &c__1);
+ i__1 = *n - 1;
+ z__1.r = -tau->r, z__1.i = -tau->i;
+ zgerc_(m, &i__1, &z__1, &work[1], &c__1, &v[1], incv, &c2[c2_offset],
+ ldc);
+ }
+
+ return 0;
+
+/* End of ZLATZM */
+
+} /* zlatzm_ */
diff --git a/SRC/zlauu2.c b/SRC/zlauu2.c
new file mode 100644
index 0000000..e593c5a
--- /dev/null
+++ b/SRC/zlauu2.c
@@ -0,0 +1,203 @@
+/* zlauu2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zlauu2_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__;
+ doublereal aii;
+ extern logical lsame_(char *, char *);
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
+ integer *, doublereal *, doublecomplex *, integer *), zlacgv_(
+ integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAUU2 computes the product U * U' or L' * L, where the triangular */
+/* factor U or L is stored in the upper or lower triangular part of */
+/* the array A. */
+
+/* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */
+/* overwriting the factor U in A. */
+/* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */
+/* overwriting the factor L in A. */
+
+/* This is the unblocked form of the algorithm, calling Level 2 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the triangular factor stored in the array A */
+/* is upper or lower triangular: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the triangular factor U or L. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the triangular factor U or L. */
+/* On exit, if UPLO = 'U', the upper triangle of A is */
+/* overwritten with the upper triangle of the product U * U'; */
+/* if UPLO = 'L', the lower triangle of A is overwritten with */
+/* the lower triangle of the product L' * L. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLAUU2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Compute the product U * U'. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ aii = a[i__2].r;
+ if (i__ < *n) {
+ i__2 = i__ + i__ * a_dim1;
+ i__3 = *n - i__;
+ zdotc_(&z__1, &i__3, &a[i__ + (i__ + 1) * a_dim1], lda, &a[
+ i__ + (i__ + 1) * a_dim1], lda);
+ d__1 = aii * aii + z__1.r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ i__2 = *n - i__;
+ zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
+ i__2 = i__ - 1;
+ i__3 = *n - i__;
+ z__1.r = aii, z__1.i = 0.;
+ zgemv_("No transpose", &i__2, &i__3, &c_b1, &a[(i__ + 1) *
+ a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, &
+ z__1, &a[i__ * a_dim1 + 1], &c__1);
+ i__2 = *n - i__;
+ zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
+ } else {
+ zdscal_(&i__, &aii, &a[i__ * a_dim1 + 1], &c__1);
+ }
+/* L10: */
+ }
+
+ } else {
+
+/* Compute the product L' * L. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ aii = a[i__2].r;
+ if (i__ < *n) {
+ i__2 = i__ + i__ * a_dim1;
+ i__3 = *n - i__;
+ zdotc_(&z__1, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &a[
+ i__ + 1 + i__ * a_dim1], &c__1);
+ d__1 = aii * aii + z__1.r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ i__2 = i__ - 1;
+ zlacgv_(&i__2, &a[i__ + a_dim1], lda);
+ i__2 = *n - i__;
+ i__3 = i__ - 1;
+ z__1.r = aii, z__1.i = 0.;
+ zgemv_("Conjugate transpose", &i__2, &i__3, &c_b1, &a[i__ + 1
+ + a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &
+ z__1, &a[i__ + a_dim1], lda);
+ i__2 = i__ - 1;
+ zlacgv_(&i__2, &a[i__ + a_dim1], lda);
+ } else {
+ zdscal_(&i__, &aii, &a[i__ + a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of ZLAUU2 */
+
+} /* zlauu2_ */
diff --git a/SRC/zlauum.c b/SRC/zlauum.c
new file mode 100644
index 0000000..21c3789
--- /dev/null
+++ b/SRC/zlauum.c
@@ -0,0 +1,217 @@
+/* zlauum.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b21 = 1.;
+
+/* Subroutine */ int zlauum_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, ib, nb;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zherk_(char *, char *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int ztrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ zlauu2_(char *, integer *, doublecomplex *, integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAUUM computes the product U * U' or L' * L, where the triangular */
+/* factor U or L is stored in the upper or lower triangular part of */
+/* the array A. */
+
+/* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */
+/* overwriting the factor U in A. */
+/* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */
+/* overwriting the factor L in A. */
+
+/* This is the blocked form of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the triangular factor stored in the array A */
+/* is upper or lower triangular: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the triangular factor U or L. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the triangular factor U or L. */
+/* On exit, if UPLO = 'U', the upper triangle of A is */
+/* overwritten with the upper triangle of the product U * U'; */
+/* if UPLO = 'L', the lower triangle of A is overwritten with */
+/* the lower triangle of the product L' * L. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLAUUM", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "ZLAUUM", uplo, n, &c_n1, &c_n1, &c_n1);
+
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code */
+
+ zlauu2_(uplo, n, &a[a_offset], lda, info);
+ } else {
+
+/* Use blocked code */
+
+ if (upper) {
+
+/* Compute the product U * U'. */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - i__ + 1;
+ ib = min(i__3,i__4);
+ i__3 = i__ - 1;
+ ztrmm_("Right", "Upper", "Conjugate transpose", "Non-unit", &
+ i__3, &ib, &c_b1, &a[i__ + i__ * a_dim1], lda, &a[i__
+ * a_dim1 + 1], lda);
+ zlauu2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info);
+ if (i__ + ib <= *n) {
+ i__3 = i__ - 1;
+ i__4 = *n - i__ - ib + 1;
+ zgemm_("No transpose", "Conjugate transpose", &i__3, &ib,
+ &i__4, &c_b1, &a[(i__ + ib) * a_dim1 + 1], lda, &
+ a[i__ + (i__ + ib) * a_dim1], lda, &c_b1, &a[i__ *
+ a_dim1 + 1], lda);
+ i__3 = *n - i__ - ib + 1;
+ zherk_("Upper", "No transpose", &ib, &i__3, &c_b21, &a[
+ i__ + (i__ + ib) * a_dim1], lda, &c_b21, &a[i__ +
+ i__ * a_dim1], lda);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Compute the product L' * L. */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - i__ + 1;
+ ib = min(i__3,i__4);
+ i__3 = i__ - 1;
+ ztrmm_("Left", "Lower", "Conjugate transpose", "Non-unit", &
+ ib, &i__3, &c_b1, &a[i__ + i__ * a_dim1], lda, &a[i__
+ + a_dim1], lda);
+ zlauu2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info);
+ if (i__ + ib <= *n) {
+ i__3 = i__ - 1;
+ i__4 = *n - i__ - ib + 1;
+ zgemm_("Conjugate transpose", "No transpose", &ib, &i__3,
+ &i__4, &c_b1, &a[i__ + ib + i__ * a_dim1], lda, &
+ a[i__ + ib + a_dim1], lda, &c_b1, &a[i__ + a_dim1]
+, lda);
+ i__3 = *n - i__ - ib + 1;
+ zherk_("Lower", "Conjugate transpose", &ib, &i__3, &c_b21,
+ &a[i__ + ib + i__ * a_dim1], lda, &c_b21, &a[i__
+ + i__ * a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZLAUUM */
+
+} /* zlauum_ */
diff --git a/SRC/zpbcon.c b/SRC/zpbcon.c
new file mode 100644
index 0000000..bbfa6df
--- /dev/null
+++ b/SRC/zpbcon.c
@@ -0,0 +1,236 @@
+/* zpbcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zpbcon_(char *uplo, integer *n, integer *kd,
+ doublecomplex *ab, integer *ldab, doublereal *anorm, doublereal *
+ rcond, doublecomplex *work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer ix, kase;
+ doublereal scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal scalel, scaleu;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal ainvnm;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zlatbs_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *, doublereal *, integer *), zdrscl_(integer *, doublereal *, doublecomplex *,
+ integer *);
+ char normin[1];
+ doublereal smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPBCON estimates the reciprocal of the condition number (in the */
+/* 1-norm) of a complex Hermitian positive definite band matrix using */
+/* the Cholesky factorization A = U**H*U or A = L*L**H computed by */
+/* ZPBTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular factor stored in AB; */
+/* = 'L': Lower triangular factor stored in AB. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**H*U or A = L*L**H of the band matrix A, stored in the */
+/* first KD+1 rows of the array. The j-th column of U or L is */
+/* stored in the j-th column of the array AB as follows: */
+/* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* ANORM (input) DOUBLE PRECISION */
+/* The 1-norm (or infinity-norm) of the Hermitian band matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*ldab < *kd + 1) {
+ *info = -5;
+ } else if (*anorm < 0.) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPBCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.;
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ } else if (*anorm == 0.) {
+ return 0;
+ }
+
+ smlnum = dlamch_("Safe minimum");
+
+/* Estimate the 1-norm of the inverse. */
+
+ kase = 0;
+ *(unsigned char *)normin = 'N';
+L10:
+ zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (upper) {
+
+/* Multiply by inv(U'). */
+
+ zlatbs_("Upper", "Conjugate transpose", "Non-unit", normin, n, kd,
+ &ab[ab_offset], ldab, &work[1], &scalel, &rwork[1], info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(U). */
+
+ zlatbs_("Upper", "No transpose", "Non-unit", normin, n, kd, &ab[
+ ab_offset], ldab, &work[1], &scaleu, &rwork[1], info);
+ } else {
+
+/* Multiply by inv(L). */
+
+ zlatbs_("Lower", "No transpose", "Non-unit", normin, n, kd, &ab[
+ ab_offset], ldab, &work[1], &scalel, &rwork[1], info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(L'). */
+
+ zlatbs_("Lower", "Conjugate transpose", "Non-unit", normin, n, kd,
+ &ab[ab_offset], ldab, &work[1], &scaleu, &rwork[1], info);
+ }
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ scale = scalel * scaleu;
+ if (scale != 1.) {
+ ix = izamax_(n, &work[1], &c__1);
+ i__1 = ix;
+ if (scale < ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(&
+ work[ix]), abs(d__2))) * smlnum || scale == 0.) {
+ goto L20;
+ }
+ zdrscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / ainvnm / *anorm;
+ }
+
+L20:
+
+ return 0;
+
+/* End of ZPBCON */
+
+} /* zpbcon_ */
diff --git a/SRC/zpbequ.c b/SRC/zpbequ.c
new file mode 100644
index 0000000..49bbad0
--- /dev/null
+++ b/SRC/zpbequ.c
@@ -0,0 +1,205 @@
+/* zpbequ.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zpbequ_(char *uplo, integer *n, integer *kd,
+ doublecomplex *ab, integer *ldab, doublereal *s, doublereal *scond,
+ doublereal *amax, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal smin;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPBEQU computes row and column scalings intended to equilibrate a */
+/* Hermitian positive definite band matrix A and reduce its condition */
+/* number (with respect to the two-norm). S contains the scale factors, */
+/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
+/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
+/* choice of S puts the condition number of B within a factor N of the */
+/* smallest possible condition number over all possible diagonal */
+/* scalings. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular of A is stored; */
+/* = 'L': Lower triangular of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
+/* The upper or lower triangle of the Hermitian band matrix A, */
+/* stored in the first KD+1 rows of the array. The j-th column */
+/* of A is stored in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array A. LDAB >= KD+1. */
+
+/* S (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, S contains the scale factors for A. */
+
+/* SCOND (output) DOUBLE PRECISION */
+/* If INFO = 0, S contains the ratio of the smallest S(i) to */
+/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
+/* large nor too small, it is not worth scaling by S. */
+
+/* AMAX (output) DOUBLE PRECISION */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --s;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*ldab < *kd + 1) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPBEQU", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *scond = 1.;
+ *amax = 0.;
+ return 0;
+ }
+
+ if (upper) {
+ j = *kd + 1;
+ } else {
+ j = 1;
+ }
+
+/* Initialize SMIN and AMAX. */
+
+ i__1 = j + ab_dim1;
+ s[1] = ab[i__1].r;
+ smin = s[1];
+ *amax = s[1];
+
+/* Find the minimum and maximum diagonal elements. */
+
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = j + i__ * ab_dim1;
+ s[i__] = ab[i__2].r;
+/* Computing MIN */
+ d__1 = smin, d__2 = s[i__];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = *amax, d__2 = s[i__];
+ *amax = max(d__1,d__2);
+/* L10: */
+ }
+
+ if (smin <= 0.) {
+
+/* Find the first non-positive diagonal element and return. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] <= 0.) {
+ *info = i__;
+ return 0;
+ }
+/* L20: */
+ }
+ } else {
+
+/* Set the scale factors to the reciprocals */
+/* of the diagonal elements. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s[i__] = 1. / sqrt(s[i__]);
+/* L30: */
+ }
+
+/* Compute SCOND = min(S(I)) / max(S(I)) */
+
+ *scond = sqrt(smin) / sqrt(*amax);
+ }
+ return 0;
+
+/* End of ZPBEQU */
+
+} /* zpbequ_ */
diff --git a/SRC/zpbrfs.c b/SRC/zpbrfs.c
new file mode 100644
index 0000000..6df330e
--- /dev/null
+++ b/SRC/zpbrfs.c
@@ -0,0 +1,483 @@
+/* zpbrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zpbrfs_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *
+ ldafb, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
+ doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *
+ rwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, l;
+ doublereal s, xk;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Subroutine */ int zhbmv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ integer count;
+ logical upper;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), zlacn2_(
+ integer *, doublecomplex *, doublecomplex *, doublereal *,
+ integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal lstres;
+ extern /* Subroutine */ int zpbtrs_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPBRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is Hermitian positive definite */
+/* and banded, and provides error bounds and backward error estimates */
+/* for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The upper or lower triangle of the Hermitian band matrix A, */
+/* stored in the first KD+1 rows of the array. The j-th column */
+/* of A is stored in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* AFB (input) COMPLEX*16 array, dimension (LDAFB,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**H*U or A = L*L**H of the band matrix A as computed by */
+/* ZPBTRF, in the same storage format as A (see AB). */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= KD+1. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by ZPBTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldab < *kd + 1) {
+ *info = -6;
+ } else if (*ldafb < *kd + 1) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldx < max(1,*n)) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPBRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+/* Computing MIN */
+ i__1 = *n + 1, i__2 = (*kd << 1) + 2;
+ nz = min(i__1,i__2);
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ z__1.r = -1., z__1.i = -0.;
+ zhbmv_(uplo, n, kd, &z__1, &ab[ab_offset], ldab, &x[j * x_dim1 + 1], &
+ c__1, &c_b1, &work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
+ i__ + j * b_dim1]), abs(d__2));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
+ x_dim1]), abs(d__2));
+ l = *kd + 1 - k;
+/* Computing MAX */
+ i__3 = 1, i__4 = k - *kd;
+ i__5 = k - 1;
+ for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
+ i__3 = l + i__ + k * ab_dim1;
+ rwork[i__] += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&ab[l + i__ + k * ab_dim1]), abs(d__2))) *
+ xk;
+ i__3 = l + i__ + k * ab_dim1;
+ i__4 = i__ + j * x_dim1;
+ s += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 = d_imag(&ab[
+ l + i__ + k * ab_dim1]), abs(d__2))) * ((d__3 = x[
+ i__4].r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j *
+ x_dim1]), abs(d__4)));
+/* L40: */
+ }
+ i__5 = *kd + 1 + k * ab_dim1;
+ rwork[k] = rwork[k] + (d__1 = ab[i__5].r, abs(d__1)) * xk + s;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__5 = k + j * x_dim1;
+ xk = (d__1 = x[i__5].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
+ x_dim1]), abs(d__2));
+ i__5 = k * ab_dim1 + 1;
+ rwork[k] += (d__1 = ab[i__5].r, abs(d__1)) * xk;
+ l = 1 - k;
+/* Computing MIN */
+ i__3 = *n, i__4 = k + *kd;
+ i__5 = min(i__3,i__4);
+ for (i__ = k + 1; i__ <= i__5; ++i__) {
+ i__3 = l + i__ + k * ab_dim1;
+ rwork[i__] += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&ab[l + i__ + k * ab_dim1]), abs(d__2))) *
+ xk;
+ i__3 = l + i__ + k * ab_dim1;
+ i__4 = i__ + j * x_dim1;
+ s += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 = d_imag(&ab[
+ l + i__ + k * ab_dim1]), abs(d__2))) * ((d__3 = x[
+ i__4].r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j *
+ x_dim1]), abs(d__4)));
+/* L60: */
+ }
+ rwork[k] += s;
+/* L70: */
+ }
+ }
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__5 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__5].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2))) / rwork[i__];
+ s = max(d__3,d__4);
+ } else {
+/* Computing MAX */
+ i__5 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__5].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = max(d__3,d__4);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ zpbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[1], n,
+ info);
+ zaxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use ZLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__5 = i__;
+ rwork[i__] = (d__1 = work[i__5].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ ;
+ } else {
+ i__5 = i__;
+ rwork[i__] = (d__1 = work[i__5].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ zpbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[1],
+ n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__5 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__3] * work[i__4].r, z__1.i = rwork[i__3]
+ * work[i__4].i;
+ work[i__5].r = z__1.r, work[i__5].i = z__1.i;
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__5 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__3] * work[i__4].r, z__1.i = rwork[i__3]
+ * work[i__4].i;
+ work[i__5].r = z__1.r, work[i__5].i = z__1.i;
+/* L120: */
+ }
+ zpbtrs_(uplo, n, kd, &c__1, &afb[afb_offset], ldafb, &work[1],
+ n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__5 = i__ + j * x_dim1;
+ d__3 = lstres, d__4 = (d__1 = x[i__5].r, abs(d__1)) + (d__2 =
+ d_imag(&x[i__ + j * x_dim1]), abs(d__2));
+ lstres = max(d__3,d__4);
+/* L130: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of ZPBRFS */
+
+} /* zpbrfs_ */
diff --git a/SRC/zpbstf.c b/SRC/zpbstf.c
new file mode 100644
index 0000000..93481ac
--- /dev/null
+++ b/SRC/zpbstf.c
@@ -0,0 +1,334 @@
+/* zpbstf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b9 = -1.;
+
+/* Subroutine */ int zpbstf_(char *uplo, integer *n, integer *kd,
+ doublecomplex *ab, integer *ldab, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer j, m, km;
+ doublereal ajj;
+ integer kld;
+ extern /* Subroutine */ int zher_(char *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
+ integer *, doublereal *, doublecomplex *, integer *), zlacgv_(
+ integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPBSTF computes a split Cholesky factorization of a complex */
+/* Hermitian positive definite band matrix A. */
+
+/* This routine is designed to be used in conjunction with ZHBGST. */
+
+/* The factorization has the form A = S**H*S where S is a band matrix */
+/* of the same bandwidth as A and the following structure: */
+
+/* S = ( U ) */
+/* ( M L ) */
+
+/* where U is upper triangular of order m = (n+kd)/2, and L is lower */
+/* triangular of order n-m. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first kd+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, if INFO = 0, the factor S from the split Cholesky */
+/* factorization A = S**H*S. See Further Details. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the factorization could not be completed, */
+/* because the updated element a(i,i) was negative; the */
+/* matrix A is not positive definite. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* N = 7, KD = 2: */
+
+/* S = ( s11 s12 s13 ) */
+/* ( s22 s23 s24 ) */
+/* ( s33 s34 ) */
+/* ( s44 ) */
+/* ( s53 s54 s55 ) */
+/* ( s64 s65 s66 ) */
+/* ( s75 s76 s77 ) */
+
+/* If UPLO = 'U', the array AB holds: */
+
+/* on entry: on exit: */
+
+/* * * a13 a24 a35 a46 a57 * * s13 s24 s53' s64' s75' */
+/* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54' s65' s76' */
+/* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 */
+
+/* If UPLO = 'L', the array AB holds: */
+
+/* on entry: on exit: */
+
+/* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 */
+/* a21 a32 a43 a54 a65 a76 * s12' s23' s34' s54 s65 s76 * */
+/* a31 a42 a53 a64 a64 * * s13' s24' s53 s64 s75 * * */
+
+/* Array elements marked * are not used by the routine; s12' denotes */
+/* conjg(s12); the diagonal elements of S are real. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*ldab < *kd + 1) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPBSTF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *ldab - 1;
+ kld = max(i__1,i__2);
+
+/* Set the splitting point m. */
+
+ m = (*n + *kd) / 2;
+
+ if (upper) {
+
+/* Factorize A(m+1:n,m+1:n) as L**H*L, and update A(1:m,1:m). */
+
+ i__1 = m + 1;
+ for (j = *n; j >= i__1; --j) {
+
+/* Compute s(j,j) and test for non-positive-definiteness. */
+
+ i__2 = *kd + 1 + j * ab_dim1;
+ ajj = ab[i__2].r;
+ if (ajj <= 0.) {
+ i__2 = *kd + 1 + j * ab_dim1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.;
+ goto L50;
+ }
+ ajj = sqrt(ajj);
+ i__2 = *kd + 1 + j * ab_dim1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.;
+/* Computing MIN */
+ i__2 = j - 1;
+ km = min(i__2,*kd);
+
+/* Compute elements j-km:j-1 of the j-th column and update the */
+/* the leading submatrix within the band. */
+
+ d__1 = 1. / ajj;
+ zdscal_(&km, &d__1, &ab[*kd + 1 - km + j * ab_dim1], &c__1);
+ zher_("Upper", &km, &c_b9, &ab[*kd + 1 - km + j * ab_dim1], &c__1,
+ &ab[*kd + 1 + (j - km) * ab_dim1], &kld);
+/* L10: */
+ }
+
+/* Factorize the updated submatrix A(1:m,1:m) as U**H*U. */
+
+ i__1 = m;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute s(j,j) and test for non-positive-definiteness. */
+
+ i__2 = *kd + 1 + j * ab_dim1;
+ ajj = ab[i__2].r;
+ if (ajj <= 0.) {
+ i__2 = *kd + 1 + j * ab_dim1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.;
+ goto L50;
+ }
+ ajj = sqrt(ajj);
+ i__2 = *kd + 1 + j * ab_dim1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.;
+/* Computing MIN */
+ i__2 = *kd, i__3 = m - j;
+ km = min(i__2,i__3);
+
+/* Compute elements j+1:j+km of the j-th row and update the */
+/* trailing submatrix within the band. */
+
+ if (km > 0) {
+ d__1 = 1. / ajj;
+ zdscal_(&km, &d__1, &ab[*kd + (j + 1) * ab_dim1], &kld);
+ zlacgv_(&km, &ab[*kd + (j + 1) * ab_dim1], &kld);
+ zher_("Upper", &km, &c_b9, &ab[*kd + (j + 1) * ab_dim1], &kld,
+ &ab[*kd + 1 + (j + 1) * ab_dim1], &kld);
+ zlacgv_(&km, &ab[*kd + (j + 1) * ab_dim1], &kld);
+ }
+/* L20: */
+ }
+ } else {
+
+/* Factorize A(m+1:n,m+1:n) as L**H*L, and update A(1:m,1:m). */
+
+ i__1 = m + 1;
+ for (j = *n; j >= i__1; --j) {
+
+/* Compute s(j,j) and test for non-positive-definiteness. */
+
+ i__2 = j * ab_dim1 + 1;
+ ajj = ab[i__2].r;
+ if (ajj <= 0.) {
+ i__2 = j * ab_dim1 + 1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.;
+ goto L50;
+ }
+ ajj = sqrt(ajj);
+ i__2 = j * ab_dim1 + 1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.;
+/* Computing MIN */
+ i__2 = j - 1;
+ km = min(i__2,*kd);
+
+/* Compute elements j-km:j-1 of the j-th row and update the */
+/* trailing submatrix within the band. */
+
+ d__1 = 1. / ajj;
+ zdscal_(&km, &d__1, &ab[km + 1 + (j - km) * ab_dim1], &kld);
+ zlacgv_(&km, &ab[km + 1 + (j - km) * ab_dim1], &kld);
+ zher_("Lower", &km, &c_b9, &ab[km + 1 + (j - km) * ab_dim1], &kld,
+ &ab[(j - km) * ab_dim1 + 1], &kld);
+ zlacgv_(&km, &ab[km + 1 + (j - km) * ab_dim1], &kld);
+/* L30: */
+ }
+
+/* Factorize the updated submatrix A(1:m,1:m) as U**H*U. */
+
+ i__1 = m;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute s(j,j) and test for non-positive-definiteness. */
+
+ i__2 = j * ab_dim1 + 1;
+ ajj = ab[i__2].r;
+ if (ajj <= 0.) {
+ i__2 = j * ab_dim1 + 1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.;
+ goto L50;
+ }
+ ajj = sqrt(ajj);
+ i__2 = j * ab_dim1 + 1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.;
+/* Computing MIN */
+ i__2 = *kd, i__3 = m - j;
+ km = min(i__2,i__3);
+
+/* Compute elements j+1:j+km of the j-th column and update the */
+/* trailing submatrix within the band. */
+
+ if (km > 0) {
+ d__1 = 1. / ajj;
+ zdscal_(&km, &d__1, &ab[j * ab_dim1 + 2], &c__1);
+ zher_("Lower", &km, &c_b9, &ab[j * ab_dim1 + 2], &c__1, &ab[(
+ j + 1) * ab_dim1 + 1], &kld);
+ }
+/* L40: */
+ }
+ }
+ return 0;
+
+L50:
+ *info = j;
+ return 0;
+
+/* End of ZPBSTF */
+
+} /* zpbstf_ */
diff --git a/SRC/zpbsv.c b/SRC/zpbsv.c
new file mode 100644
index 0000000..bac0f83
--- /dev/null
+++ b/SRC/zpbsv.c
@@ -0,0 +1,183 @@
+/* zpbsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zpbsv_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, doublecomplex *ab, integer *ldab, doublecomplex *b, integer *
+ ldb, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), zpbtrf_(
+ char *, integer *, integer *, doublecomplex *, integer *, integer
+ *), zpbtrs_(char *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPBSV computes the solution to a complex system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N Hermitian positive definite band matrix and X */
+/* and B are N-by-NRHS matrices. */
+
+/* The Cholesky decomposition is used to factor A as */
+/* A = U**H * U, if UPLO = 'U', or */
+/* A = L * L**H, if UPLO = 'L', */
+/* where U is an upper triangular band matrix, and L is a lower */
+/* triangular band matrix, with the same number of superdiagonals or */
+/* subdiagonals as A. The factored form of A is then used to solve the */
+/* system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD). */
+/* See below for further details. */
+
+/* On exit, if INFO = 0, the triangular factor U or L from the */
+/* Cholesky factorization A = U**H*U or A = L*L**H of the band */
+/* matrix A, in the same storage format as A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i of A is not */
+/* positive definite, so the factorization could not be */
+/* completed, and the solution has not been computed. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* N = 6, KD = 2, and UPLO = 'U': */
+
+/* On entry: On exit: */
+
+/* * * a13 a24 a35 a46 * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+
+/* Similarly, if UPLO = 'L' the format of A is as follows: */
+
+/* On entry: On exit: */
+
+/* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */
+/* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */
+/* a31 a42 a53 a64 * * l31 l42 l53 l64 * * */
+
+/* Array elements marked * are not used by the routine. */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldab < *kd + 1) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPBSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ zpbtrf_(uplo, n, kd, &ab[ab_offset], ldab, info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ zpbtrs_(uplo, n, kd, nrhs, &ab[ab_offset], ldab, &b[b_offset], ldb,
+ info);
+
+ }
+ return 0;
+
+/* End of ZPBSV */
+
+} /* zpbsv_ */
diff --git a/SRC/zpbsvx.c b/SRC/zpbsvx.c
new file mode 100644
index 0000000..51e6109
--- /dev/null
+++ b/SRC/zpbsvx.c
@@ -0,0 +1,528 @@
+/* zpbsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zpbsvx_(char *fact, char *uplo, integer *n, integer *kd,
+ integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *afb,
+ integer *ldafb, char *equed, doublereal *s, doublecomplex *b, integer
+ *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *
+ ferr, doublereal *berr, doublecomplex *work, doublereal *rwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset,
+ x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j, j1, j2;
+ doublereal amax, smin, smax;
+ extern logical lsame_(char *, char *);
+ doublereal scond, anorm;
+ logical equil, rcequ, upper;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal zlanhb_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+ doublereal bignum;
+ extern /* Subroutine */ int zlaqhb_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *, char *);
+ integer infequ;
+ extern /* Subroutine */ int zpbcon_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *), zpbequ_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), zpbrfs_(char *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *
+, doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zpbtrf_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *);
+ doublereal smlnum;
+ extern /* Subroutine */ int zpbtrs_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPBSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to */
+/* compute the solution to a complex system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N Hermitian positive definite band matrix and X */
+/* and B are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+/* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
+
+/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */
+/* factor the matrix A (after equilibration if FACT = 'E') as */
+/* A = U**H * U, if UPLO = 'U', or */
+/* A = L * L**H, if UPLO = 'L', */
+/* where U is an upper triangular band matrix, and L is a lower */
+/* triangular band matrix. */
+
+/* 3. If the leading i-by-i principal minor is not positive definite, */
+/* then the routine returns with INFO = i. Otherwise, the factored */
+/* form of A is used to estimate the condition number of the matrix */
+/* A. If the reciprocal of the condition number is less than machine */
+/* precision, INFO = N+1 is returned as a warning, but the routine */
+/* still goes on to solve for X and compute error bounds as */
+/* described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(S) so that it solves the original system before */
+/* equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AFB contains the factored form of A. */
+/* If EQUED = 'Y', the matrix A has been equilibrated */
+/* with scaling factors given by S. AB and AFB will not */
+/* be modified. */
+/* = 'N': The matrix A will be copied to AFB and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AFB and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right-hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first KD+1 rows of the array, except */
+/* if FACT = 'F' and EQUED = 'Y', then A must contain the */
+/* equilibrated matrix diag(S)*A*diag(S). The j-th column of A */
+/* is stored in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD). */
+/* See below for further details. */
+
+/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
+/* diag(S)*A*diag(S). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array A. LDAB >= KD+1. */
+
+/* AFB (input or output) COMPLEX*16 array, dimension (LDAFB,N) */
+/* If FACT = 'F', then AFB is an input argument and on entry */
+/* contains the triangular factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H of the band matrix */
+/* A, in the same storage format as A (see AB). If EQUED = 'Y', */
+/* then AFB is the factored form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AFB is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H. */
+
+/* If FACT = 'E', then AFB is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H of the equilibrated */
+/* matrix A (see the description of A for the form of the */
+/* equilibrated matrix). */
+
+/* LDAFB (input) INTEGER */
+/* The leading dimension of the array AFB. LDAFB >= KD+1. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* S (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The scale factors for A; not accessed if EQUED = 'N'. S is */
+/* an input argument if FACT = 'F'; otherwise, S is an output */
+/* argument. If FACT = 'F' and EQUED = 'Y', each element of S */
+/* must be positive. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */
+/* B is overwritten by diag(S) * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */
+/* the original system of equations. Note that if EQUED = 'Y', */
+/* A and B are modified on exit, and the solution to the */
+/* equilibrated system is inv(diag(S))*X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A after equilibration (if done). If RCOND is less than the */
+/* machine precision (in particular, if RCOND = 0), the matrix */
+/* is singular to working precision. This condition is */
+/* indicated by a return code of INFO > 0. */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: the leading minor of order i of A is */
+/* not positive definite, so the factorization */
+/* could not be completed, and the solution has not */
+/* been computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* N = 6, KD = 2, and UPLO = 'U': */
+
+/* Two-dimensional storage of the Hermitian matrix A: */
+
+/* a11 a12 a13 */
+/* a22 a23 a24 */
+/* a33 a34 a35 */
+/* a44 a45 a46 */
+/* a55 a56 */
+/* (aij=conjg(aji)) a66 */
+
+/* Band storage of the upper triangle of A: */
+
+/* * * a13 a24 a35 a46 */
+/* * a12 a23 a34 a45 a56 */
+/* a11 a22 a33 a44 a55 a66 */
+
+/* Similarly, if UPLO = 'L' the format of A is as follows: */
+
+/* a11 a22 a33 a44 a55 a66 */
+/* a21 a32 a43 a54 a65 * */
+/* a31 a42 a53 a64 * * */
+
+/* Array elements marked * are not used by the routine. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ afb_dim1 = *ldafb;
+ afb_offset = 1 + afb_dim1;
+ afb -= afb_offset;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ upper = lsame_(uplo, "U");
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rcequ = FALSE_;
+ } else {
+ rcequ = lsame_(equed, "Y");
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ }
+
+/* Test the input parameters. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*kd < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*ldab < *kd + 1) {
+ *info = -7;
+ } else if (*ldafb < *kd + 1) {
+ *info = -9;
+ } else if (lsame_(fact, "F") && ! (rcequ || lsame_(
+ equed, "N"))) {
+ *info = -10;
+ } else {
+ if (rcequ) {
+ smin = bignum;
+ smax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = smin, d__2 = s[j];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = smax, d__2 = s[j];
+ smax = max(d__1,d__2);
+/* L10: */
+ }
+ if (smin <= 0.) {
+ *info = -11;
+ } else if (*n > 0) {
+ scond = max(smin,smlnum) / min(smax,bignum);
+ } else {
+ scond = 1.;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -13;
+ } else if (*ldx < max(1,*n)) {
+ *info = -15;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPBSVX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ zpbequ_(uplo, n, kd, &ab[ab_offset], ldab, &s[1], &scond, &amax, &
+ infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ zlaqhb_(uplo, n, kd, &ab[ab_offset], ldab, &s[1], &scond, &amax,
+ equed);
+ rcequ = lsame_(equed, "Y");
+ }
+ }
+
+/* Scale the right-hand side. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * b_dim1;
+ z__1.r = s[i__4] * b[i__5].r, z__1.i = s[i__4] * b[i__5].i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L20: */
+ }
+/* L30: */
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j - *kd;
+ j1 = max(i__2,1);
+ i__2 = j - j1 + 1;
+ zcopy_(&i__2, &ab[*kd + 1 - j + j1 + j * ab_dim1], &c__1, &
+ afb[*kd + 1 - j + j1 + j * afb_dim1], &c__1);
+/* L40: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = j + *kd;
+ j2 = min(i__2,*n);
+ i__2 = j2 - j + 1;
+ zcopy_(&i__2, &ab[j * ab_dim1 + 1], &c__1, &afb[j * afb_dim1
+ + 1], &c__1);
+/* L50: */
+ }
+ }
+
+ zpbtrf_(uplo, n, kd, &afb[afb_offset], ldafb, info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = zlanhb_("1", uplo, n, kd, &ab[ab_offset], ldab, &rwork[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ zpbcon_(uplo, n, kd, &afb[afb_offset], ldafb, &anorm, rcond, &work[1], &
+ rwork[1], info);
+
+/* Compute the solution matrix X. */
+
+ zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ zpbtrs_(uplo, n, kd, nrhs, &afb[afb_offset], ldafb, &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ zpbrfs_(uplo, n, kd, nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb,
+ &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1]
+, &rwork[1], info);
+
+/* Transform the solution matrix X to a solution of the original */
+/* system. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * x_dim1;
+ z__1.r = s[i__4] * x[i__5].r, z__1.i = s[i__4] * x[i__5].i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+/* L60: */
+ }
+/* L70: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= scond;
+/* L80: */
+ }
+ }
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < dlamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of ZPBSVX */
+
+} /* zpbsvx_ */
diff --git a/SRC/zpbtf2.c b/SRC/zpbtf2.c
new file mode 100644
index 0000000..de9734c
--- /dev/null
+++ b/SRC/zpbtf2.c
@@ -0,0 +1,255 @@
+/* zpbtf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b8 = -1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int zpbtf2_(char *uplo, integer *n, integer *kd,
+ doublecomplex *ab, integer *ldab, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer j, kn;
+ doublereal ajj;
+ integer kld;
+ extern /* Subroutine */ int zher_(char *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
+ integer *, doublereal *, doublecomplex *, integer *), zlacgv_(
+ integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPBTF2 computes the Cholesky factorization of a complex Hermitian */
+/* positive definite band matrix A. */
+
+/* The factorization has the form */
+/* A = U' * U , if UPLO = 'U', or */
+/* A = L * L', if UPLO = 'L', */
+/* where U is an upper triangular matrix, U' is the conjugate transpose */
+/* of U, and L is lower triangular. */
+
+/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, if INFO = 0, the triangular factor U or L from the */
+/* Cholesky factorization A = U'*U or A = L*L' of the band */
+/* matrix A, in the same storage format as A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, the leading minor of order k is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* N = 6, KD = 2, and UPLO = 'U': */
+
+/* On entry: On exit: */
+
+/* * * a13 a24 a35 a46 * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+
+/* Similarly, if UPLO = 'L' the format of A is as follows: */
+
+/* On entry: On exit: */
+
+/* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */
+/* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */
+/* a31 a42 a53 a64 * * l31 l42 l53 l64 * * */
+
+/* Array elements marked * are not used by the routine. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*ldab < *kd + 1) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPBTF2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Computing MAX */
+ i__1 = 1, i__2 = *ldab - 1;
+ kld = max(i__1,i__2);
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute U(J,J) and test for non-positive-definiteness. */
+
+ i__2 = *kd + 1 + j * ab_dim1;
+ ajj = ab[i__2].r;
+ if (ajj <= 0.) {
+ i__2 = *kd + 1 + j * ab_dim1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.;
+ goto L30;
+ }
+ ajj = sqrt(ajj);
+ i__2 = *kd + 1 + j * ab_dim1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.;
+
+/* Compute elements J+1:J+KN of row J and update the */
+/* trailing submatrix within the band. */
+
+/* Computing MIN */
+ i__2 = *kd, i__3 = *n - j;
+ kn = min(i__2,i__3);
+ if (kn > 0) {
+ d__1 = 1. / ajj;
+ zdscal_(&kn, &d__1, &ab[*kd + (j + 1) * ab_dim1], &kld);
+ zlacgv_(&kn, &ab[*kd + (j + 1) * ab_dim1], &kld);
+ zher_("Upper", &kn, &c_b8, &ab[*kd + (j + 1) * ab_dim1], &kld,
+ &ab[*kd + 1 + (j + 1) * ab_dim1], &kld);
+ zlacgv_(&kn, &ab[*kd + (j + 1) * ab_dim1], &kld);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute L(J,J) and test for non-positive-definiteness. */
+
+ i__2 = j * ab_dim1 + 1;
+ ajj = ab[i__2].r;
+ if (ajj <= 0.) {
+ i__2 = j * ab_dim1 + 1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.;
+ goto L30;
+ }
+ ajj = sqrt(ajj);
+ i__2 = j * ab_dim1 + 1;
+ ab[i__2].r = ajj, ab[i__2].i = 0.;
+
+/* Compute elements J+1:J+KN of column J and update the */
+/* trailing submatrix within the band. */
+
+/* Computing MIN */
+ i__2 = *kd, i__3 = *n - j;
+ kn = min(i__2,i__3);
+ if (kn > 0) {
+ d__1 = 1. / ajj;
+ zdscal_(&kn, &d__1, &ab[j * ab_dim1 + 2], &c__1);
+ zher_("Lower", &kn, &c_b8, &ab[j * ab_dim1 + 2], &c__1, &ab[(
+ j + 1) * ab_dim1 + 1], &kld);
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+L30:
+ *info = j;
+ return 0;
+
+/* End of ZPBTF2 */
+
+} /* zpbtf2_ */
diff --git a/SRC/zpbtrf.c b/SRC/zpbtrf.c
new file mode 100644
index 0000000..79743f3
--- /dev/null
+++ b/SRC/zpbtrf.c
@@ -0,0 +1,490 @@
+/* zpbtrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b21 = -1.;
+static doublereal c_b22 = 1.;
+static integer c__33 = 33;
+
+/* Subroutine */ int zpbtrf_(char *uplo, integer *n, integer *kd,
+ doublecomplex *ab, integer *ldab, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j, i2, i3, ib, nb, ii, jj;
+ doublecomplex work[1056] /* was [33][32] */;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zherk_(char *, char *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *), ztrsm_(char *, char
+ *, char *, char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), zpbtf2_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *), zpotf2_(char *,
+ integer *, doublecomplex *, integer *, integer *),
+ xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPBTRF computes the Cholesky factorization of a complex Hermitian */
+/* positive definite band matrix A. */
+
+/* The factorization has the form */
+/* A = U**H * U, if UPLO = 'U', or */
+/* A = L * L**H, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* AB (input/output) COMPLEX*16 array, dimension (LDAB,N) */
+/* On entry, the upper or lower triangle of the Hermitian band */
+/* matrix A, stored in the first KD+1 rows of the array. The */
+/* j-th column of A is stored in the j-th column of the array AB */
+/* as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* On exit, if INFO = 0, the triangular factor U or L from the */
+/* Cholesky factorization A = U**H*U or A = L*L**H of the band */
+/* matrix A, in the same storage format as A. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* Further Details */
+/* =============== */
+
+/* The band storage scheme is illustrated by the following example, when */
+/* N = 6, KD = 2, and UPLO = 'U': */
+
+/* On entry: On exit: */
+
+/* * * a13 a24 a35 a46 * * u13 u24 u35 u46 */
+/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
+/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
+
+/* Similarly, if UPLO = 'L' the format of A is as follows: */
+
+/* On entry: On exit: */
+
+/* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 */
+/* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * */
+/* a31 a42 a53 a64 * * l31 l42 l53 l64 * * */
+
+/* Array elements marked * are not used by the routine. */
+
+/* Contributed by */
+/* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*ldab < *kd + 1) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPBTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment */
+
+ nb = ilaenv_(&c__1, "ZPBTRF", uplo, n, kd, &c_n1, &c_n1);
+
+/* The block size must not exceed the semi-bandwidth KD, and must not */
+/* exceed the limit set by the size of the local array WORK. */
+
+ nb = min(nb,32);
+
+ if (nb <= 1 || nb > *kd) {
+
+/* Use unblocked code */
+
+ zpbtf2_(uplo, n, kd, &ab[ab_offset], ldab, info);
+ } else {
+
+/* Use blocked code */
+
+ if (lsame_(uplo, "U")) {
+
+/* Compute the Cholesky factorization of a Hermitian band */
+/* matrix, given the upper triangle of the matrix in band */
+/* storage. */
+
+/* Zero the upper triangle of the work array. */
+
+ i__1 = nb;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 33 - 34;
+ work[i__3].r = 0., work[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Process the band matrix one diagonal block at a time. */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - i__ + 1;
+ ib = min(i__3,i__4);
+
+/* Factorize the diagonal block */
+
+ i__3 = *ldab - 1;
+ zpotf2_(uplo, &ib, &ab[*kd + 1 + i__ * ab_dim1], &i__3, &ii);
+ if (ii != 0) {
+ *info = i__ + ii - 1;
+ goto L150;
+ }
+ if (i__ + ib <= *n) {
+
+/* Update the relevant part of the trailing submatrix. */
+/* If A11 denotes the diagonal block which has just been */
+/* factorized, then we need to update the remaining */
+/* blocks in the diagram: */
+
+/* A11 A12 A13 */
+/* A22 A23 */
+/* A33 */
+
+/* The numbers of rows and columns in the partitioning */
+/* are IB, I2, I3 respectively. The blocks A12, A22 and */
+/* A23 are empty if IB = KD. The upper triangle of A13 */
+/* lies outside the band. */
+
+/* Computing MIN */
+ i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
+ i2 = min(i__3,i__4);
+/* Computing MIN */
+ i__3 = ib, i__4 = *n - i__ - *kd + 1;
+ i3 = min(i__3,i__4);
+
+ if (i2 > 0) {
+
+/* Update A12 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ ztrsm_("Left", "Upper", "Conjugate transpose", "Non-"
+ "unit", &ib, &i2, &c_b1, &ab[*kd + 1 + i__ *
+ ab_dim1], &i__3, &ab[*kd + 1 - ib + (i__ + ib)
+ * ab_dim1], &i__4);
+
+/* Update A22 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ zherk_("Upper", "Conjugate transpose", &i2, &ib, &
+ c_b21, &ab[*kd + 1 - ib + (i__ + ib) *
+ ab_dim1], &i__3, &c_b22, &ab[*kd + 1 + (i__ +
+ ib) * ab_dim1], &i__4);
+ }
+
+ if (i3 > 0) {
+
+/* Copy the lower triangle of A13 into the work array. */
+
+ i__3 = i3;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = ib;
+ for (ii = jj; ii <= i__4; ++ii) {
+ i__5 = ii + jj * 33 - 34;
+ i__6 = ii - jj + 1 + (jj + i__ + *kd - 1) *
+ ab_dim1;
+ work[i__5].r = ab[i__6].r, work[i__5].i = ab[
+ i__6].i;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Update A13 (in the work array). */
+
+ i__3 = *ldab - 1;
+ ztrsm_("Left", "Upper", "Conjugate transpose", "Non-"
+ "unit", &ib, &i3, &c_b1, &ab[*kd + 1 + i__ *
+ ab_dim1], &i__3, work, &c__33);
+
+/* Update A23 */
+
+ if (i2 > 0) {
+ z__1.r = -1., z__1.i = -0.;
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ zgemm_("Conjugate transpose", "No transpose", &i2,
+ &i3, &ib, &z__1, &ab[*kd + 1 - ib + (i__
+ + ib) * ab_dim1], &i__3, work, &c__33, &
+ c_b1, &ab[ib + 1 + (i__ + *kd) * ab_dim1],
+ &i__4);
+ }
+
+/* Update A33 */
+
+ i__3 = *ldab - 1;
+ zherk_("Upper", "Conjugate transpose", &i3, &ib, &
+ c_b21, work, &c__33, &c_b22, &ab[*kd + 1 + (
+ i__ + *kd) * ab_dim1], &i__3);
+
+/* Copy the lower triangle of A13 back into place. */
+
+ i__3 = i3;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = ib;
+ for (ii = jj; ii <= i__4; ++ii) {
+ i__5 = ii - jj + 1 + (jj + i__ + *kd - 1) *
+ ab_dim1;
+ i__6 = ii + jj * 33 - 34;
+ ab[i__5].r = work[i__6].r, ab[i__5].i = work[
+ i__6].i;
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+ }
+/* L70: */
+ }
+ } else {
+
+/* Compute the Cholesky factorization of a Hermitian band */
+/* matrix, given the lower triangle of the matrix in band */
+/* storage. */
+
+/* Zero the lower triangle of the work array. */
+
+ i__2 = nb;
+ for (j = 1; j <= i__2; ++j) {
+ i__1 = nb;
+ for (i__ = j + 1; i__ <= i__1; ++i__) {
+ i__3 = i__ + j * 33 - 34;
+ work[i__3].r = 0., work[i__3].i = 0.;
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Process the band matrix one diagonal block at a time. */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - i__ + 1;
+ ib = min(i__3,i__4);
+
+/* Factorize the diagonal block */
+
+ i__3 = *ldab - 1;
+ zpotf2_(uplo, &ib, &ab[i__ * ab_dim1 + 1], &i__3, &ii);
+ if (ii != 0) {
+ *info = i__ + ii - 1;
+ goto L150;
+ }
+ if (i__ + ib <= *n) {
+
+/* Update the relevant part of the trailing submatrix. */
+/* If A11 denotes the diagonal block which has just been */
+/* factorized, then we need to update the remaining */
+/* blocks in the diagram: */
+
+/* A11 */
+/* A21 A22 */
+/* A31 A32 A33 */
+
+/* The numbers of rows and columns in the partitioning */
+/* are IB, I2, I3 respectively. The blocks A21, A22 and */
+/* A32 are empty if IB = KD. The lower triangle of A31 */
+/* lies outside the band. */
+
+/* Computing MIN */
+ i__3 = *kd - ib, i__4 = *n - i__ - ib + 1;
+ i2 = min(i__3,i__4);
+/* Computing MIN */
+ i__3 = ib, i__4 = *n - i__ - *kd + 1;
+ i3 = min(i__3,i__4);
+
+ if (i2 > 0) {
+
+/* Update A21 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ ztrsm_("Right", "Lower", "Conjugate transpose", "Non"
+ "-unit", &i2, &ib, &c_b1, &ab[i__ * ab_dim1 +
+ 1], &i__3, &ab[ib + 1 + i__ * ab_dim1], &i__4);
+
+/* Update A22 */
+
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ zherk_("Lower", "No transpose", &i2, &ib, &c_b21, &ab[
+ ib + 1 + i__ * ab_dim1], &i__3, &c_b22, &ab[(
+ i__ + ib) * ab_dim1 + 1], &i__4);
+ }
+
+ if (i3 > 0) {
+
+/* Copy the upper triangle of A31 into the work array. */
+
+ i__3 = ib;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = min(jj,i3);
+ for (ii = 1; ii <= i__4; ++ii) {
+ i__5 = ii + jj * 33 - 34;
+ i__6 = *kd + 1 - jj + ii + (jj + i__ - 1) *
+ ab_dim1;
+ work[i__5].r = ab[i__6].r, work[i__5].i = ab[
+ i__6].i;
+/* L100: */
+ }
+/* L110: */
+ }
+
+/* Update A31 (in the work array). */
+
+ i__3 = *ldab - 1;
+ ztrsm_("Right", "Lower", "Conjugate transpose", "Non"
+ "-unit", &i3, &ib, &c_b1, &ab[i__ * ab_dim1 +
+ 1], &i__3, work, &c__33);
+
+/* Update A32 */
+
+ if (i2 > 0) {
+ z__1.r = -1., z__1.i = -0.;
+ i__3 = *ldab - 1;
+ i__4 = *ldab - 1;
+ zgemm_("No transpose", "Conjugate transpose", &i3,
+ &i2, &ib, &z__1, work, &c__33, &ab[ib +
+ 1 + i__ * ab_dim1], &i__3, &c_b1, &ab[*kd
+ + 1 - ib + (i__ + ib) * ab_dim1], &i__4);
+ }
+
+/* Update A33 */
+
+ i__3 = *ldab - 1;
+ zherk_("Lower", "No transpose", &i3, &ib, &c_b21,
+ work, &c__33, &c_b22, &ab[(i__ + *kd) *
+ ab_dim1 + 1], &i__3);
+
+/* Copy the upper triangle of A31 back into place. */
+
+ i__3 = ib;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = min(jj,i3);
+ for (ii = 1; ii <= i__4; ++ii) {
+ i__5 = *kd + 1 - jj + ii + (jj + i__ - 1) *
+ ab_dim1;
+ i__6 = ii + jj * 33 - 34;
+ ab[i__5].r = work[i__6].r, ab[i__5].i = work[
+ i__6].i;
+/* L120: */
+ }
+/* L130: */
+ }
+ }
+ }
+/* L140: */
+ }
+ }
+ }
+ return 0;
+
+L150:
+ return 0;
+
+/* End of ZPBTRF */
+
+} /* zpbtrf_ */
diff --git a/SRC/zpbtrs.c b/SRC/zpbtrs.c
new file mode 100644
index 0000000..5ba99f3
--- /dev/null
+++ b/SRC/zpbtrs.c
@@ -0,0 +1,183 @@
+/* zpbtrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zpbtrs_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, doublecomplex *ab, integer *ldab, doublecomplex *b, integer *
+ ldb, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ integer j;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int ztbsv_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPBTRS solves a system of linear equations A*X = B with a Hermitian */
+/* positive definite band matrix A using the Cholesky factorization */
+/* A = U**H*U or A = L*L**H computed by ZPBTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular factor stored in AB; */
+/* = 'L': Lower triangular factor stored in AB. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**H*U or A = L*L**H of the band matrix A, stored in the */
+/* first KD+1 rows of the array. The j-th column of U or L is */
+/* stored in the j-th column of the array AB as follows: */
+/* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kd < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldab < *kd + 1) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPBTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B where A = U'*U. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve U'*X = B, overwriting B with X. */
+
+ ztbsv_("Upper", "Conjugate transpose", "Non-unit", n, kd, &ab[
+ ab_offset], ldab, &b[j * b_dim1 + 1], &c__1);
+
+/* Solve U*X = B, overwriting B with X. */
+
+ ztbsv_("Upper", "No transpose", "Non-unit", n, kd, &ab[ab_offset],
+ ldab, &b[j * b_dim1 + 1], &c__1);
+/* L10: */
+ }
+ } else {
+
+/* Solve A*X = B where A = L*L'. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve L*X = B, overwriting B with X. */
+
+ ztbsv_("Lower", "No transpose", "Non-unit", n, kd, &ab[ab_offset],
+ ldab, &b[j * b_dim1 + 1], &c__1);
+
+/* Solve L'*X = B, overwriting B with X. */
+
+ ztbsv_("Lower", "Conjugate transpose", "Non-unit", n, kd, &ab[
+ ab_offset], ldab, &b[j * b_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of ZPBTRS */
+
+} /* zpbtrs_ */
diff --git a/SRC/zpftrf.c b/SRC/zpftrf.c
new file mode 100644
index 0000000..7eae706
--- /dev/null
+++ b/SRC/zpftrf.c
@@ -0,0 +1,475 @@
+/* zpftrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static doublereal c_b15 = -1.;
+static doublereal c_b16 = 1.;
+
+/* Subroutine */ int zpftrf_(char *transr, char *uplo, integer *n,
+ doublecomplex *a, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer k, n1, n2;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zherk_(char *, char *, integer *, integer *,
+ doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *);
+ logical lower;
+ extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ xerbla_(char *, integer *);
+ logical nisodd;
+ extern /* Subroutine */ int zpotrf_(char *, integer *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPFTRF computes the Cholesky factorization of a complex Hermitian */
+/* positive definite matrix A. */
+
+/* The factorization has the form */
+/* A = U**H * U, if UPLO = 'U', or */
+/* A = L * L**H, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* This is the block version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': The Normal TRANSR of RFP A is stored; */
+/* = 'C': The Conjugate-transpose TRANSR of RFP A is stored. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': Upper triangle of RFP A is stored; */
+/* = 'L': Lower triangle of RFP A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension ( N*(N+1)/2 ); */
+/* On entry, the Hermitian matrix A in RFP format. RFP format is */
+/* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' */
+/* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */
+/* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is */
+/* the Conjugate-transpose of RFP A as defined when */
+/* TRANSR = 'N'. The contents of RFP A are defined by UPLO as */
+/* follows: If UPLO = 'U' the RFP A contains the nt elements of */
+/* upper packed A. If UPLO = 'L' the RFP A contains the elements */
+/* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = */
+/* 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N */
+/* is odd. See the Note below for more details. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization RFP A = U**H*U or RFP A = L*L**H. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* Further Notes on RFP Format: */
+/* ============================ */
+
+/* We first consider Standard Packed Format when N is even. */
+/* We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* conjugate-transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* conjugate-transpose of the last three columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- -- */
+/* 03 04 05 33 43 53 */
+/* -- -- */
+/* 13 14 15 00 44 54 */
+/* -- */
+/* 23 24 25 10 11 55 */
+
+/* 33 34 35 20 21 22 */
+/* -- */
+/* 00 44 45 30 31 32 */
+/* -- -- */
+/* 01 11 55 40 41 42 */
+/* -- -- -- */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We next consider Standard Packed Format when N is odd. */
+/* We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* conjugate-transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* conjugate-transpose of the last two columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- */
+/* 02 03 04 00 33 43 */
+/* -- */
+/* 12 13 14 10 11 44 */
+
+/* 22 23 24 20 21 22 */
+/* -- */
+/* 00 33 34 30 31 32 */
+/* -- -- */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- */
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "C")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPFTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* If N is odd, set NISODD = .TRUE. */
+/* If N is even, set K = N/2 and NISODD = .FALSE. */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ } else {
+ nisodd = TRUE_;
+ }
+
+/* Set N1 and N2 depending on LOWER */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* start execution: there are eight cases */
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */
+/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */
+/* T1 -> a(0), T2 -> a(n), S -> a(n1) */
+
+ zpotrf_("L", &n1, a, n, info);
+ if (*info > 0) {
+ return 0;
+ }
+ ztrsm_("R", "L", "C", "N", &n2, &n1, &c_b1, a, n, &a[n1], n);
+ zherk_("U", "N", &n2, &n1, &c_b15, &a[n1], n, &c_b16, &a[*n],
+ n);
+ zpotrf_("U", &n2, &a[*n], n, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */
+/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */
+/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */
+
+ zpotrf_("L", &n1, &a[n2], n, info);
+ if (*info > 0) {
+ return 0;
+ }
+ ztrsm_("L", "L", "N", "N", &n1, &n2, &c_b1, &a[n2], n, a, n);
+ zherk_("U", "C", &n2, &n1, &c_b15, a, n, &c_b16, &a[n1], n);
+ zpotrf_("U", &n2, &a[n1], n, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is odd */
+/* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */
+/* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 */
+
+ zpotrf_("U", &n1, a, &n1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ ztrsm_("L", "U", "C", "N", &n1, &n2, &c_b1, a, &n1, &a[n1 *
+ n1], &n1);
+ zherk_("L", "C", &n2, &n1, &c_b15, &a[n1 * n1], &n1, &c_b16, &
+ a[1], &n1);
+ zpotrf_("L", &n2, &a[1], &n1, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is odd */
+/* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */
+/* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 */
+
+ zpotrf_("U", &n1, &a[n2 * n2], &n2, info);
+ if (*info > 0) {
+ return 0;
+ }
+ ztrsm_("R", "U", "N", "N", &n2, &n1, &c_b1, &a[n2 * n2], &n2,
+ a, &n2);
+ zherk_("L", "N", &n2, &n1, &c_b15, a, &n2, &c_b16, &a[n1 * n2]
+, &n2);
+ zpotrf_("L", &n2, &a[n1 * n2], &n2, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
+/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */
+
+ i__1 = *n + 1;
+ zpotrf_("L", &k, &a[1], &i__1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ ztrsm_("R", "L", "C", "N", &k, &k, &c_b1, &a[1], &i__1, &a[k
+ + 1], &i__2);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ zherk_("U", "N", &k, &k, &c_b15, &a[k + 1], &i__1, &c_b16, a,
+ &i__2);
+ i__1 = *n + 1;
+ zpotrf_("U", &k, a, &i__1, info);
+ if (*info > 0) {
+ *info += k;
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
+/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */
+
+ i__1 = *n + 1;
+ zpotrf_("L", &k, &a[k + 1], &i__1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ ztrsm_("L", "L", "N", "N", &k, &k, &c_b1, &a[k + 1], &i__1, a,
+ &i__2);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ zherk_("U", "C", &k, &k, &c_b15, a, &i__1, &c_b16, &a[k], &
+ i__2);
+ i__1 = *n + 1;
+ zpotrf_("U", &k, &a[k], &i__1, info);
+ if (*info > 0) {
+ *info += k;
+ }
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */
+/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */
+
+ zpotrf_("U", &k, &a[k], &k, info);
+ if (*info > 0) {
+ return 0;
+ }
+ ztrsm_("L", "U", "C", "N", &k, &k, &c_b1, &a[k], &n1, &a[k * (
+ k + 1)], &k);
+ zherk_("L", "C", &k, &k, &c_b15, &a[k * (k + 1)], &k, &c_b16,
+ a, &k);
+ zpotrf_("L", &k, a, &k, info);
+ if (*info > 0) {
+ *info += k;
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */
+/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */
+
+ zpotrf_("U", &k, &a[k * (k + 1)], &k, info);
+ if (*info > 0) {
+ return 0;
+ }
+ ztrsm_("R", "U", "N", "N", &k, &k, &c_b1, &a[k * (k + 1)], &k,
+ a, &k);
+ zherk_("L", "N", &k, &k, &c_b15, a, &k, &c_b16, &a[k * k], &k);
+ zpotrf_("L", &k, &a[k * k], &k, info);
+ if (*info > 0) {
+ *info += k;
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of ZPFTRF */
+
+} /* zpftrf_ */
diff --git a/SRC/zpftri.c b/SRC/zpftri.c
new file mode 100644
index 0000000..c23659a
--- /dev/null
+++ b/SRC/zpftri.c
@@ -0,0 +1,426 @@
+/* zpftri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static doublereal c_b12 = 1.;
+
+/* Subroutine */ int zpftri_(char *transr, char *uplo, integer *n,
+ doublecomplex *a, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer k, n1, n2;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zherk_(char *, char *, integer *, integer *,
+ doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *);
+ logical lower;
+ extern /* Subroutine */ int ztrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ xerbla_(char *, integer *);
+ logical nisodd;
+ extern /* Subroutine */ int zlauum_(char *, integer *, doublecomplex *,
+ integer *, integer *), ztftri_(char *, char *, char *,
+ integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPFTRI computes the inverse of a complex Hermitian positive definite */
+/* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H */
+/* computed by ZPFTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': The Normal TRANSR of RFP A is stored; */
+/* = 'C': The Conjugate-transpose TRANSR of RFP A is stored. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension ( N*(N+1)/2 ); */
+/* On entry, the Hermitian matrix A in RFP format. RFP format is */
+/* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' */
+/* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */
+/* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is */
+/* the Conjugate-transpose of RFP A as defined when */
+/* TRANSR = 'N'. The contents of RFP A are defined by UPLO as */
+/* follows: If UPLO = 'U' the RFP A contains the nt elements of */
+/* upper packed A. If UPLO = 'L' the RFP A contains the elements */
+/* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = */
+/* 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N */
+/* is odd. See the Note below for more details. */
+
+/* On exit, the Hermitian inverse of the original matrix, in the */
+/* same storage format. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the (i,i) element of the factor U or L is */
+/* zero, and the inverse could not be computed. */
+
+/* Note: */
+/* ===== */
+
+/* We first consider Standard Packed Format when N is even. */
+/* We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* conjugate-transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* conjugate-transpose of the last three columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- -- */
+/* 03 04 05 33 43 53 */
+/* -- -- */
+/* 13 14 15 00 44 54 */
+/* -- */
+/* 23 24 25 10 11 55 */
+
+/* 33 34 35 20 21 22 */
+/* -- */
+/* 00 44 45 30 31 32 */
+/* -- -- */
+/* 01 11 55 40 41 42 */
+/* -- -- -- */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We next consider Standard Packed Format when N is odd. */
+/* We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* conjugate-transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* conjugate-transpose of the last two columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- */
+/* 02 03 04 00 33 43 */
+/* -- */
+/* 12 13 14 10 11 44 */
+
+/* 22 23 24 20 21 22 */
+/* -- */
+/* 00 33 34 30 31 32 */
+/* -- -- */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- */
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "C")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPFTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Invert the triangular Cholesky factor U or L. */
+
+ ztftri_(transr, uplo, "N", n, a, info);
+ if (*info > 0) {
+ return 0;
+ }
+
+/* If N is odd, set NISODD = .TRUE. */
+/* If N is even, set K = N/2 and NISODD = .FALSE. */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ } else {
+ nisodd = TRUE_;
+ }
+
+/* Set N1 and N2 depending on LOWER */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* Start execution of triangular matrix multiply: inv(U)*inv(U)^C or */
+/* inv(L)^C*inv(L). There are eight cases. */
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:N1-1) ) */
+/* T1 -> a(0,0), T2 -> a(0,1), S -> a(N1,0) */
+/* T1 -> a(0), T2 -> a(n), S -> a(N1) */
+
+ zlauum_("L", &n1, a, n, info);
+ zherk_("L", "C", &n1, &n2, &c_b12, &a[n1], n, &c_b12, a, n);
+ ztrmm_("L", "U", "N", "N", &n2, &n1, &c_b1, &a[*n], n, &a[n1],
+ n);
+ zlauum_("U", &n2, &a[*n], n, info);
+
+ } else {
+
+/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:N2-1) */
+/* T1 -> a(N1+1,0), T2 -> a(N1,0), S -> a(0,0) */
+/* T1 -> a(N2), T2 -> a(N1), S -> a(0) */
+
+ zlauum_("L", &n1, &a[n2], n, info);
+ zherk_("L", "N", &n1, &n2, &c_b12, a, n, &c_b12, &a[n2], n);
+ ztrmm_("R", "U", "C", "N", &n1, &n2, &c_b1, &a[n1], n, a, n);
+ zlauum_("U", &n2, &a[n1], n, info);
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE, and N is odd */
+/* T1 -> a(0), T2 -> a(1), S -> a(0+N1*N1) */
+
+ zlauum_("U", &n1, a, &n1, info);
+ zherk_("U", "N", &n1, &n2, &c_b12, &a[n1 * n1], &n1, &c_b12,
+ a, &n1);
+ ztrmm_("R", "L", "N", "N", &n1, &n2, &c_b1, &a[1], &n1, &a[n1
+ * n1], &n1);
+ zlauum_("L", &n2, &a[1], &n1, info);
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE, and N is odd */
+/* T1 -> a(0+N2*N2), T2 -> a(0+N1*N2), S -> a(0) */
+
+ zlauum_("U", &n1, &a[n2 * n2], &n2, info);
+ zherk_("U", "C", &n1, &n2, &c_b12, a, &n2, &c_b12, &a[n2 * n2]
+, &n2);
+ ztrmm_("L", "L", "C", "N", &n2, &n1, &c_b1, &a[n1 * n2], &n2,
+ a, &n2);
+ zlauum_("L", &n2, &a[n1 * n2], &n2, info);
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
+/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */
+
+ i__1 = *n + 1;
+ zlauum_("L", &k, &a[1], &i__1, info);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ zherk_("L", "C", &k, &k, &c_b12, &a[k + 1], &i__1, &c_b12, &a[
+ 1], &i__2);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ ztrmm_("L", "U", "N", "N", &k, &k, &c_b1, a, &i__1, &a[k + 1],
+ &i__2);
+ i__1 = *n + 1;
+ zlauum_("U", &k, a, &i__1, info);
+
+ } else {
+
+/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
+/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */
+
+ i__1 = *n + 1;
+ zlauum_("L", &k, &a[k + 1], &i__1, info);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ zherk_("L", "N", &k, &k, &c_b12, a, &i__1, &c_b12, &a[k + 1],
+ &i__2);
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ ztrmm_("R", "U", "C", "N", &k, &k, &c_b1, &a[k], &i__1, a, &
+ i__2);
+ i__1 = *n + 1;
+ zlauum_("U", &k, &a[k], &i__1, info);
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE, and N is even (see paper) */
+/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1), */
+/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */
+
+ zlauum_("U", &k, &a[k], &k, info);
+ zherk_("U", "N", &k, &k, &c_b12, &a[k * (k + 1)], &k, &c_b12,
+ &a[k], &k);
+ ztrmm_("R", "L", "N", "N", &k, &k, &c_b1, a, &k, &a[k * (k +
+ 1)], &k);
+ zlauum_("L", &k, a, &k, info);
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE, and N is even (see paper) */
+/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0), */
+/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */
+
+ zlauum_("U", &k, &a[k * (k + 1)], &k, info);
+ zherk_("U", "C", &k, &k, &c_b12, a, &k, &c_b12, &a[k * (k + 1)
+ ], &k);
+ ztrmm_("L", "L", "C", "N", &k, &k, &c_b1, &a[k * k], &k, a, &
+ k);
+ zlauum_("L", &k, &a[k * k], &k, info);
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of ZPFTRI */
+
+} /* zpftri_ */
diff --git a/SRC/zpftrs.c b/SRC/zpftrs.c
new file mode 100644
index 0000000..9e5b151
--- /dev/null
+++ b/SRC/zpftrs.c
@@ -0,0 +1,260 @@
+/* zpftrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+
+/* Subroutine */ int zpftrs_(char *transr, char *uplo, integer *n, integer *
+ nrhs, doublecomplex *a, doublecomplex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int ztfsm_(char *, char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPFTRS solves a system of linear equations A*X = B with a Hermitian */
+/* positive definite matrix A using the Cholesky factorization */
+/* A = U**H*U or A = L*L**H computed by ZPFTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': The Normal TRANSR of RFP A is stored; */
+/* = 'C': The Conjugate-transpose TRANSR of RFP A is stored. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': Upper triangle of RFP A is stored; */
+/* = 'L': Lower triangle of RFP A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ); */
+/* The triangular factor U or L from the Cholesky factorization */
+/* of RFP A = U**H*U or RFP A = L*L**H, as computed by ZPFTRF. */
+/* See note below for more details about RFP A. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Note: */
+/* ===== */
+
+/* We first consider Standard Packed Format when N is even. */
+/* We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* conjugate-transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* conjugate-transpose of the last three columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- -- */
+/* 03 04 05 33 43 53 */
+/* -- -- */
+/* 13 14 15 00 44 54 */
+/* -- */
+/* 23 24 25 10 11 55 */
+
+/* 33 34 35 20 21 22 */
+/* -- */
+/* 00 44 45 30 31 32 */
+/* -- -- */
+/* 01 11 55 40 41 42 */
+/* -- -- -- */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We next consider Standard Packed Format when N is odd. */
+/* We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* conjugate-transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* conjugate-transpose of the last two columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- */
+/* 02 03 04 00 33 43 */
+/* -- */
+/* 12 13 14 10 11 44 */
+
+/* 22 23 24 20 21 22 */
+/* -- */
+/* 00 33 34 30 31 32 */
+/* -- -- */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- */
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "C")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPFTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+/* start execution: there are two triangular solves */
+
+ if (lower) {
+ ztfsm_(transr, "L", uplo, "N", "N", n, nrhs, &c_b1, a, &b[b_offset],
+ ldb);
+ ztfsm_(transr, "L", uplo, "C", "N", n, nrhs, &c_b1, a, &b[b_offset],
+ ldb);
+ } else {
+ ztfsm_(transr, "L", uplo, "C", "N", n, nrhs, &c_b1, a, &b[b_offset],
+ ldb);
+ ztfsm_(transr, "L", uplo, "N", "N", n, nrhs, &c_b1, a, &b[b_offset],
+ ldb);
+ }
+
+ return 0;
+
+/* End of ZPFTRS */
+
+} /* zpftrs_ */
diff --git a/SRC/zpocon.c b/SRC/zpocon.c
new file mode 100644
index 0000000..f3dc04f
--- /dev/null
+++ b/SRC/zpocon.c
@@ -0,0 +1,225 @@
+/* zpocon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zpocon_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublereal *anorm, doublereal *rcond, doublecomplex *
+ work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer ix, kase;
+ doublereal scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal scalel, scaleu;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal ainvnm;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zdrscl_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ char normin[1];
+ doublereal smlnum;
+ extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *, doublereal *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPOCON estimates the reciprocal of the condition number (in the */
+/* 1-norm) of a complex Hermitian positive definite matrix using the */
+/* Cholesky factorization A = U**H*U or A = L*L**H computed by ZPOTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**H*U or A = L*L**H, as computed by ZPOTRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* ANORM (input) DOUBLE PRECISION */
+/* The 1-norm (or infinity-norm) of the Hermitian matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*anorm < 0.) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPOCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.;
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ } else if (*anorm == 0.) {
+ return 0;
+ }
+
+ smlnum = dlamch_("Safe minimum");
+
+/* Estimate the 1-norm of inv(A). */
+
+ kase = 0;
+ *(unsigned char *)normin = 'N';
+L10:
+ zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (upper) {
+
+/* Multiply by inv(U'). */
+
+ zlatrs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &a[
+ a_offset], lda, &work[1], &scalel, &rwork[1], info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(U). */
+
+ zlatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[
+ a_offset], lda, &work[1], &scaleu, &rwork[1], info);
+ } else {
+
+/* Multiply by inv(L). */
+
+ zlatrs_("Lower", "No transpose", "Non-unit", normin, n, &a[
+ a_offset], lda, &work[1], &scalel, &rwork[1], info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(L'). */
+
+ zlatrs_("Lower", "Conjugate transpose", "Non-unit", normin, n, &a[
+ a_offset], lda, &work[1], &scaleu, &rwork[1], info);
+ }
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ scale = scalel * scaleu;
+ if (scale != 1.) {
+ ix = izamax_(n, &work[1], &c__1);
+ i__1 = ix;
+ if (scale < ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(&
+ work[ix]), abs(d__2))) * smlnum || scale == 0.) {
+ goto L20;
+ }
+ zdrscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / ainvnm / *anorm;
+ }
+
+L20:
+ return 0;
+
+/* End of ZPOCON */
+
+} /* zpocon_ */
diff --git a/SRC/zpoequ.c b/SRC/zpoequ.c
new file mode 100644
index 0000000..a6eb77b
--- /dev/null
+++ b/SRC/zpoequ.c
@@ -0,0 +1,176 @@
+/* zpoequ.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zpoequ_(integer *n, doublecomplex *a, integer *lda,
+ doublereal *s, doublereal *scond, doublereal *amax, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal smin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPOEQU computes row and column scalings intended to equilibrate a */
+/* Hermitian positive definite matrix A and reduce its condition number */
+/* (with respect to the two-norm). S contains the scale factors, */
+/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
+/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
+/* choice of S puts the condition number of B within a factor N of the */
+/* smallest possible condition number over all possible diagonal */
+/* scalings. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The N-by-N Hermitian positive definite matrix whose scaling */
+/* factors are to be computed. Only the diagonal elements of A */
+/* are referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* S (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, S contains the scale factors for A. */
+
+/* SCOND (output) DOUBLE PRECISION */
+/* If INFO = 0, S contains the ratio of the smallest S(i) to */
+/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
+/* large nor too small, it is not worth scaling by S. */
+
+/* AMAX (output) DOUBLE PRECISION */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*lda < max(1,*n)) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPOEQU", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *scond = 1.;
+ *amax = 0.;
+ return 0;
+ }
+
+/* Find the minimum and maximum diagonal elements. */
+
+ i__1 = a_dim1 + 1;
+ s[1] = a[i__1].r;
+ smin = s[1];
+ *amax = s[1];
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ s[i__] = a[i__2].r;
+/* Computing MIN */
+ d__1 = smin, d__2 = s[i__];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = *amax, d__2 = s[i__];
+ *amax = max(d__1,d__2);
+/* L10: */
+ }
+
+ if (smin <= 0.) {
+
+/* Find the first non-positive diagonal element and return. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] <= 0.) {
+ *info = i__;
+ return 0;
+ }
+/* L20: */
+ }
+ } else {
+
+/* Set the scale factors to the reciprocals */
+/* of the diagonal elements. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s[i__] = 1. / sqrt(s[i__]);
+/* L30: */
+ }
+
+/* Compute SCOND = min(S(I)) / max(S(I)) */
+
+ *scond = sqrt(smin) / sqrt(*amax);
+ }
+ return 0;
+
+/* End of ZPOEQU */
+
+} /* zpoequ_ */
diff --git a/SRC/zpoequb.c b/SRC/zpoequb.c
new file mode 100644
index 0000000..e1235c7
--- /dev/null
+++ b/SRC/zpoequb.c
@@ -0,0 +1,195 @@
+/* zpoequb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zpoequb_(integer *n, doublecomplex *a, integer *lda,
+ doublereal *s, doublereal *scond, doublereal *amax, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double log(doublereal), pow_di(doublereal *, integer *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal tmp, base, smin;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPOEQUB computes row and column scalings intended to equilibrate a */
+/* symmetric positive definite matrix A and reduce its condition number */
+/* (with respect to the two-norm). S contains the scale factors, */
+/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
+/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
+/* choice of S puts the condition number of B within a factor N of the */
+/* smallest possible condition number over all possible diagonal */
+/* scalings. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The N-by-N symmetric positive definite matrix whose scaling */
+/* factors are to be computed. Only the diagonal elements of A */
+/* are referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* S (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, S contains the scale factors for A. */
+
+/* SCOND (output) DOUBLE PRECISION */
+/* If INFO = 0, S contains the ratio of the smallest S(i) to */
+/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
+/* large nor too small, it is not worth scaling by S. */
+
+/* AMAX (output) DOUBLE PRECISION */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+/* Positive definite only performs 1 pass of equilibration. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*lda < max(1,*n)) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPOEQUB", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ *scond = 1.;
+ *amax = 0.;
+ return 0;
+ }
+ base = dlamch_("B");
+ tmp = -.5 / log(base);
+
+/* Find the minimum and maximum diagonal elements. */
+
+ i__1 = a_dim1 + 1;
+ s[1] = a[i__1].r;
+ smin = s[1];
+ *amax = s[1];
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__ + i__ * a_dim1;
+ s[i__2] = a[i__3].r;
+/* Computing MIN */
+ d__1 = smin, d__2 = s[i__];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = *amax, d__2 = s[i__];
+ *amax = max(d__1,d__2);
+/* L10: */
+ }
+
+ if (smin <= 0.) {
+
+/* Find the first non-positive diagonal element and return. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] <= 0.) {
+ *info = i__;
+ return 0;
+ }
+/* L20: */
+ }
+ } else {
+
+/* Set the scale factors to the reciprocals */
+/* of the diagonal elements. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = (integer) (tmp * log(s[i__]));
+ s[i__] = pow_di(&base, &i__2);
+/* L30: */
+ }
+
+/* Compute SCOND = min(S(I)) / max(S(I)). */
+
+ *scond = sqrt(smin) / sqrt(*amax);
+ }
+
+ return 0;
+
+/* End of ZPOEQUB */
+
+} /* zpoequb_ */
diff --git a/SRC/zporfs.c b/SRC/zporfs.c
new file mode 100644
index 0000000..b42267d
--- /dev/null
+++ b/SRC/zporfs.c
@@ -0,0 +1,465 @@
+/* zporfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zporfs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf,
+ doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
+ doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *
+ rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal s, xk;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3], count;
+ extern /* Subroutine */ int zhemv_(char *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), zlacn2_(
+ integer *, doublecomplex *, doublecomplex *, doublereal *,
+ integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal lstres;
+ extern /* Subroutine */ int zpotrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPORFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is Hermitian positive definite, */
+/* and provides error bounds and backward error estimates for the */
+/* solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The 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. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**H*U or A = L*L**H, as computed by ZPOTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by ZPOTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ==================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPORFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ z__1.r = -1., z__1.i = -0.;
+ zhemv_(uplo, n, &z__1, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, &
+ c_b1, &work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
+ i__ + j * b_dim1]), abs(d__2));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
+ x_dim1]), abs(d__2));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ rwork[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + k * a_dim1]), abs(d__2))) * xk;
+ i__4 = i__ + k * a_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + k * a_dim1]), abs(d__2))) * ((d__3 = x[i__5]
+ .r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j *
+ x_dim1]), abs(d__4)));
+/* L40: */
+ }
+ i__3 = k + k * a_dim1;
+ rwork[k] = rwork[k] + (d__1 = a[i__3].r, abs(d__1)) * xk + s;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
+ x_dim1]), abs(d__2));
+ i__3 = k + k * a_dim1;
+ rwork[k] += (d__1 = a[i__3].r, abs(d__1)) * xk;
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ rwork[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + k * a_dim1]), abs(d__2))) * xk;
+ i__4 = i__ + k * a_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + k * a_dim1]), abs(d__2))) * ((d__3 = x[i__5]
+ .r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j *
+ x_dim1]), abs(d__4)));
+/* L60: */
+ }
+ rwork[k] += s;
+/* L70: */
+ }
+ }
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__3 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2))) / rwork[i__];
+ s = max(d__3,d__4);
+ } else {
+/* Computing MAX */
+ i__3 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = max(d__3,d__4);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ zpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[1], n, info);
+ zaxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use ZLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__3 = i__;
+ rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ ;
+ } else {
+ i__3 = i__;
+ rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ zpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L120: */
+ }
+ zpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[1], n,
+ info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * x_dim1;
+ d__3 = lstres, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&x[i__ + j * x_dim1]), abs(d__2));
+ lstres = max(d__3,d__4);
+/* L130: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of ZPORFS */
+
+} /* zporfs_ */
diff --git a/SRC/zporfsx.c b/SRC/zporfsx.c
new file mode 100644
index 0000000..f775b56
--- /dev/null
+++ b/SRC/zporfsx.c
@@ -0,0 +1,625 @@
+/* zporfsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int zporfsx_(char *uplo, char *equed, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, doublereal *s, doublecomplex *b, integer *ldb, doublecomplex *x,
+ integer *ldx, doublereal *rcond, doublereal *berr, integer *
+ n_err_bnds__, doublereal *err_bnds_norm__, doublereal *
+ err_bnds_comp__, integer *nparams, doublereal *params, doublecomplex *
+ work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal illrcond_thresh__, unstable_thresh__, err_lbnd__;
+ integer ref_type__;
+ integer j;
+ doublereal rcond_tmp__;
+ integer prec_type__;
+ doublereal cwise_wrong__;
+ extern /* Subroutine */ int zla_porfsx_extended__(integer *, char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, logical *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublecomplex *, doublereal *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, doublereal *,
+ doublereal *, logical *, integer *, ftnlen);
+ char norm[1];
+ logical ignore_cwise__;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ logical rcequ;
+ extern doublereal zla_porcond_c__(char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, logical *,
+ integer *, doublecomplex *, doublereal *, ftnlen),
+ zla_porcond_x__(char *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublereal *, ftnlen), dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zpocon_(char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublecomplex *,
+ doublereal *, integer *);
+ extern integer ilaprec_(char *);
+ integer ithresh, n_norms__;
+ doublereal rthresh;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPORFSX improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric positive */
+/* definite, and provides error bounds and backward error estimates */
+/* for the solution. In addition to normwise error bound, the code */
+/* provides maximum componentwise error bound if possible. See */
+/* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the */
+/* error bounds. */
+
+/* The original system of linear equations may have been equilibrated */
+/* before calling this routine, as described by arguments EQUED and S */
+/* below. In this case, the solution and error bounds returned are */
+/* for the original unequilibrated system. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* EQUED (input) CHARACTER*1 */
+/* Specifies the form of equilibration that was done to A */
+/* before calling this routine. This is needed to compute */
+/* the solution and error bounds correctly. */
+/* = 'N': No equilibration */
+/* = 'Y': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(S) * A * diag(S). */
+/* The right hand side B has been changed accordingly. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular part */
+/* of the matrix A, and the strictly lower triangular part of A */
+/* is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of A contains the lower triangular part of */
+/* the matrix A, and the strictly upper triangular part of A is */
+/* not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**T*U or A = L*L**T, as computed by DPOTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* S (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'Y', A is multiplied on */
+/* the left and right by diag(S). S is an input argument if FACT = */
+/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
+/* = 'Y', each element of S must be positive. If S is output, each */
+/* element of S is a power of the radix. If S is input, each element */
+/* of S should be a power of the radix to ensure a reliable solution */
+/* and error estimates. Scaling by powers of the radix does not cause */
+/* rounding errors unless the result underflows or overflows. */
+/* Rounding errors during scaling lead to refining with a matrix that */
+/* is not equivalent to the input matrix, producing error estimates */
+/* that may not be reliable. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by DGETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0D+0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check the input parameters. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ ref_type__ = 1;
+ if (*nparams >= 1) {
+ if (params[1] < 0.) {
+ params[1] = 1.;
+ } else {
+ ref_type__ = (integer) params[1];
+ }
+ }
+
+/* Set default parameters. */
+
+ illrcond_thresh__ = (doublereal) (*n) * dlamch_("Epsilon");
+ ithresh = 10;
+ rthresh = .5;
+ unstable_thresh__ = .25;
+ ignore_cwise__ = FALSE_;
+
+ if (*nparams >= 2) {
+ if (params[2] < 0.) {
+ params[2] = (doublereal) ithresh;
+ } else {
+ ithresh = (integer) params[2];
+ }
+ }
+ if (*nparams >= 3) {
+ if (params[3] < 0.) {
+ if (ignore_cwise__) {
+ params[3] = 0.;
+ } else {
+ params[3] = 1.;
+ }
+ } else {
+ ignore_cwise__ = params[3] == 0.;
+ }
+ }
+ if (ref_type__ == 0 || *n_err_bnds__ == 0) {
+ n_norms__ = 0;
+ } else if (ignore_cwise__) {
+ n_norms__ = 1;
+ } else {
+ n_norms__ = 2;
+ }
+
+ rcequ = lsame_(equed, "Y");
+
+/* Test input parameters. */
+
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! rcequ && ! lsame_(equed, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -11;
+ } else if (*ldx < max(1,*n)) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPORFSX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *nrhs == 0) {
+ *rcond = 1.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 0.;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.;
+ }
+ }
+ return 0;
+ }
+
+/* Default to failure. */
+
+ *rcond = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 1.;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.;
+ }
+ }
+
+/* Compute the norm of A and the reciprocal of the condition */
+/* number of A. */
+
+ *(unsigned char *)norm = 'I';
+ anorm = zlanhe_(norm, uplo, n, &a[a_offset], lda, &rwork[1]);
+ zpocon_(uplo, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &rwork[1],
+ info);
+
+/* Perform refinement on each right-hand side */
+
+ if (ref_type__ != 0) {
+ prec_type__ = ilaprec_("E");
+ zla_porfsx_extended__(&prec_type__, uplo, n, nrhs, &a[a_offset], lda,
+ &af[af_offset], ldaf, &rcequ, &s[1], &b[b_offset], ldb, &x[
+ x_offset], ldx, &berr[1], &n_norms__, &err_bnds_norm__[
+ err_bnds_norm_offset], &err_bnds_comp__[err_bnds_comp_offset],
+ &work[1], &rwork[1], &work[*n + 1], (doublecomplex *)(&rwork[1]), rcond, &ithresh, &
+ rthresh, &unstable_thresh__, &ignore_cwise__, info, (ftnlen)1)
+ ;
+ }
+/* Computing MAX */
+ d__1 = 10., d__2 = sqrt((doublereal) (*n));
+ err_lbnd__ = max(d__1,d__2) * dlamch_("Epsilon");
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {
+
+/* Compute scaled normwise condition number cond(A*C). */
+
+ if (rcequ) {
+ rcond_tmp__ = zla_porcond_c__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &s[1], &c_true, info, &work[1], &rwork[
+ 1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = zla_porcond_c__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &s[1], &c_false, info, &work[1], &rwork[
+ 1], (ftnlen)1);
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1
+ << 1)] > 1.) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 0.;
+ if (*info <= *n) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {
+
+/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
+/* each right-hand side using the current solution as an estimate of */
+/* the true solution. If the componentwise error estimate is too */
+/* large, then the solution is a lousy estimate of truth and the */
+/* estimated RCOND may be too optimistic. To avoid misleading users, */
+/* the inverse condition number is set to 0.0 when the estimated */
+/* cwise error is at least CWISE_WRONG. */
+
+ cwise_wrong__ = sqrt(dlamch_("Epsilon"));
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ cwise_wrong__) {
+ rcond_tmp__ = zla_porcond_x__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &x[j * x_dim1 + 1], info, &work[1],
+ &rwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = 0.;
+ }
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1
+ << 1)] > 1.) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 0.;
+ if (params[3] == 1. && *info < *n + j) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZPORFSX */
+
+} /* zporfsx_ */
diff --git a/SRC/zposv.c b/SRC/zposv.c
new file mode 100644
index 0000000..134b5bc
--- /dev/null
+++ b/SRC/zposv.c
@@ -0,0 +1,152 @@
+/* zposv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zposv_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), zpotrf_(
+ char *, integer *, doublecomplex *, integer *, integer *),
+ zpotrs_(char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPOSV computes the solution to a complex system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N Hermitian positive definite matrix and X and B */
+/* are N-by-NRHS matrices. */
+
+/* The Cholesky decomposition is used to factor A as */
+/* A = U**H* U, if UPLO = 'U', or */
+/* A = L * L**H, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is a lower triangular */
+/* matrix. The factored form of A is then used to solve the system of */
+/* equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input/output) 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, the factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i of A is not */
+/* positive definite, so the factorization could not be */
+/* completed, and the solution has not been computed. */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPOSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ zpotrf_(uplo, n, &a[a_offset], lda, info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ zpotrs_(uplo, n, nrhs, &a[a_offset], lda, &b[b_offset], ldb, info);
+
+ }
+ return 0;
+
+/* End of ZPOSV */
+
+} /* zposv_ */
diff --git a/SRC/zposvx.c b/SRC/zposvx.c
new file mode 100644
index 0000000..7eabf96
--- /dev/null
+++ b/SRC/zposvx.c
@@ -0,0 +1,462 @@
+/* zposvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zposvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, char *equed, doublereal *s, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr,
+ doublereal *berr, doublecomplex *work, doublereal *rwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal amax, smin, smax;
+ extern logical lsame_(char *, char *);
+ doublereal scond, anorm;
+ logical equil, rcequ;
+ extern doublereal dlamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zlaqhe_(char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *, char *);
+ integer infequ;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zpocon_(char *, integer *, doublecomplex *, integer *, doublereal
+ *, doublereal *, doublecomplex *, doublereal *, integer *)
+ ;
+ doublereal smlnum;
+ extern /* Subroutine */ int zpoequ_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *), zporfs_(
+ char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *), zpotrf_(char *,
+ integer *, doublecomplex *, integer *, integer *),
+ zpotrs_(char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPOSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to */
+/* compute the solution to a complex system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N Hermitian positive definite matrix and X and B */
+/* are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+/* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
+
+/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */
+/* factor the matrix A (after equilibration if FACT = 'E') as */
+/* A = U**H* U, if UPLO = 'U', or */
+/* A = L * L**H, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is a lower triangular */
+/* matrix. */
+
+/* 3. If the leading i-by-i principal minor is not positive definite, */
+/* then the routine returns with INFO = i. Otherwise, the factored */
+/* form of A is used to estimate the condition number of the matrix */
+/* A. If the reciprocal of the condition number is less than machine */
+/* precision, INFO = N+1 is returned as a warning, but the routine */
+/* still goes on to solve for X and compute error bounds as */
+/* described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(S) so that it solves the original system before */
+/* equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF contains the factored form of A. */
+/* If EQUED = 'Y', the matrix A has been equilibrated */
+/* with scaling factors given by S. A and AF will not */
+/* be modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the Hermitian matrix A, except if FACT = 'F' and */
+/* EQUED = 'Y', then A must contain the equilibrated matrix */
+/* diag(S)*A*diag(S). If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. A is not modified if */
+/* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
+
+/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
+/* diag(S)*A*diag(S). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) COMPLEX*16 array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the triangular factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H, in the same storage */
+/* format as A. If EQUED .ne. 'N', then AF is the factored form */
+/* of the equilibrated matrix diag(S)*A*diag(S). */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H of the original */
+/* matrix A. */
+
+/* If FACT = 'E', then AF is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H of the equilibrated */
+/* matrix A (see the description of A for the form of the */
+/* equilibrated matrix). */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* S (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The scale factors for A; not accessed if EQUED = 'N'. S is */
+/* an input argument if FACT = 'F'; otherwise, S is an output */
+/* argument. If FACT = 'F' and EQUED = 'Y', each element of S */
+/* must be positive. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS righthand side matrix B. */
+/* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */
+/* B is overwritten by diag(S) * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */
+/* the original system of equations. Note that if EQUED = 'Y', */
+/* A and B are modified on exit, and the solution to the */
+/* equilibrated system is inv(diag(S))*X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A after equilibration (if done). If RCOND is less than the */
+/* machine precision (in particular, if RCOND = 0), the matrix */
+/* is singular to working precision. This condition is */
+/* indicated by a return code of INFO > 0. */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: the leading minor of order i of A is */
+/* not positive definite, so the factorization */
+/* could not be completed, and the solution has not */
+/* been computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rcequ = FALSE_;
+ } else {
+ rcequ = lsame_(equed, "Y");
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ }
+
+/* Test the input parameters. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (lsame_(fact, "F") && ! (rcequ || lsame_(
+ equed, "N"))) {
+ *info = -9;
+ } else {
+ if (rcequ) {
+ smin = bignum;
+ smax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = smin, d__2 = s[j];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = smax, d__2 = s[j];
+ smax = max(d__1,d__2);
+/* L10: */
+ }
+ if (smin <= 0.) {
+ *info = -10;
+ } else if (*n > 0) {
+ scond = max(smin,smlnum) / min(smax,bignum);
+ } else {
+ scond = 1.;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -12;
+ } else if (*ldx < max(1,*n)) {
+ *info = -14;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPOSVX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ zpoequ_(n, &a[a_offset], lda, &s[1], &scond, &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ zlaqhe_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed);
+ rcequ = lsame_(equed, "Y");
+ }
+ }
+
+/* Scale the right hand side. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * b_dim1;
+ z__1.r = s[i__4] * b[i__5].r, z__1.i = s[i__4] * b[i__5].i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L20: */
+ }
+/* L30: */
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ zlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ zpotrf_(uplo, n, &af[af_offset], ldaf, info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = zlanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ zpocon_(uplo, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &rwork[1],
+ info);
+
+/* Compute the solution matrix X. */
+
+ zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ zpotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &x[x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ zporfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &b[
+ b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1], &
+ rwork[1], info);
+
+/* Transform the solution matrix X to a solution of the original */
+/* system. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * x_dim1;
+ z__1.r = s[i__4] * x[i__5].r, z__1.i = s[i__4] * x[i__5].i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+/* L40: */
+ }
+/* L50: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= scond;
+/* L60: */
+ }
+ }
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < dlamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of ZPOSVX */
+
+} /* zposvx_ */
diff --git a/SRC/zposvxx.c b/SRC/zposvxx.c
new file mode 100644
index 0000000..fca8f41
--- /dev/null
+++ b/SRC/zposvxx.c
@@ -0,0 +1,613 @@
+/* zposvxx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zposvxx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, char *equed, doublereal *s, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *rpvgrw,
+ doublereal *berr, integer *n_err_bnds__, doublereal *err_bnds_norm__,
+ doublereal *err_bnds_comp__, integer *nparams, doublereal *params,
+ doublecomplex *work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ doublereal amax, smin, smax;
+ extern doublereal zla_porpvgrw__(char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, ftnlen);
+ extern logical lsame_(char *, char *);
+ doublereal scond;
+ logical equil, rcequ;
+ extern doublereal dlamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int zlaqhe_(char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *, char *);
+ integer infequ;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal smlnum;
+ extern /* Subroutine */ int zpotrf_(char *, integer *, doublecomplex *,
+ integer *, integer *), zpotrs_(char *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *), zlascl2_(integer *, integer *, doublereal *,
+ doublecomplex *, integer *), zpoequb_(integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *),
+ zporfsx_(char *, char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, doublecomplex *, doublereal *, integer *
+);
+
+
+/* -- LAPACK driver routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T */
+/* to compute the solution to a complex*16 system of linear equations */
+/* A * X = B, where A is an N-by-N symmetric positive definite matrix */
+/* and X and B are N-by-NRHS matrices. */
+
+/* If requested, both normwise and maximum componentwise error bounds */
+/* are returned. ZPOSVXX will return a solution with a tiny */
+/* guaranteed error (O(eps) where eps is the working machine */
+/* precision) unless the matrix is very ill-conditioned, in which */
+/* case a warning is returned. Relevant condition numbers also are */
+/* calculated and returned. */
+
+/* ZPOSVXX accepts user-provided factorizations and equilibration */
+/* factors; see the definitions of the FACT and EQUED options. */
+/* Solving with refinement and using a factorization from a previous */
+/* ZPOSVXX call will also produce a solution with either O(eps) */
+/* errors or warnings, but we cannot make that claim for general */
+/* user-provided factorizations and equilibration factors if they */
+/* differ from what ZPOSVXX would itself produce. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate */
+/* the system: */
+
+/* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B */
+
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
+
+/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */
+/* factor the matrix A (after equilibration if FACT = 'E') as */
+/* A = U**T* U, if UPLO = 'U', or */
+/* A = L * L**T, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is a lower triangular */
+/* matrix. */
+
+/* 3. If the leading i-by-i principal minor is not positive definite, */
+/* then the routine returns with INFO = i. Otherwise, the factored */
+/* form of A is used to estimate the condition number of the matrix */
+/* A (see argument RCOND). If the reciprocal of the condition number */
+/* is less than machine precision, the routine still goes on to solve */
+/* for X and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */
+/* the routine will use iterative refinement to try to get a small */
+/* error and error bounds. Refinement calculates the residual to at */
+/* least twice the working precision. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(S) so that it solves the original system before */
+/* equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF contains the factored form of A. */
+/* If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by S. */
+/* A and AF are not modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED = */
+/* 'Y', then A must contain the equilibrated matrix */
+/* diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper */
+/* triangular part of A contains the upper triangular part of the */
+/* matrix A, and the strictly lower triangular part of A is not */
+/* referenced. If UPLO = 'L', the leading N-by-N lower triangular */
+/* part of A contains the lower triangular part of the matrix A, and */
+/* the strictly upper triangular part of A is not referenced. A is */
+/* not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED = */
+/* 'N' on exit. */
+
+/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
+/* diag(S)*A*diag(S). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) COMPLEX*16 array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T, in the same storage */
+/* format as A. If EQUED .ne. 'N', then AF is the factored */
+/* form of the equilibrated matrix diag(S)*A*diag(S). */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T of the original */
+/* matrix A. */
+
+/* If FACT = 'E', then AF is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**T*U or A = L*L**T of the equilibrated */
+/* matrix A (see the description of A for the form of the */
+/* equilibrated matrix). */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'Y': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(S) * A * diag(S). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* S (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The row scale factors for A. If EQUED = 'Y', A is multiplied on */
+/* the left and right by diag(S). S is an input argument if FACT = */
+/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
+/* = 'Y', each element of S must be positive. If S is output, each */
+/* element of S is a power of the radix. If S is input, each element */
+/* of S should be a power of the radix to ensure a reliable solution */
+/* and error estimates. Scaling by powers of the radix does not cause */
+/* rounding errors unless the result underflows or overflows. */
+/* Rounding errors during scaling lead to refining with a matrix that */
+/* is not equivalent to the input matrix, producing error estimates */
+/* that may not be reliable. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if EQUED = 'Y', B is overwritten by diag(S)*B; */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* If INFO = 0, the N-by-NRHS solution matrix X to the original */
+/* system of equations. Note that A and B are modified on exit if */
+/* EQUED .ne. 'N', and the solution to the equilibrated system is */
+/* inv(diag(S))*X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* RPVGRW (output) DOUBLE PRECISION */
+/* Reciprocal pivot growth. On exit, this contains the reciprocal */
+/* pivot growth factor norm(A)/norm(U). The "max absolute element" */
+/* norm is used. If this is much less than 1, then the stability of */
+/* the LU factorization of the (equilibrated) matrix A could be poor. */
+/* This also means that the solution X, estimated condition numbers, */
+/* and error bounds could be unreliable. If factorization fails with */
+/* 0<INFO<=N, then this contains the reciprocal pivot growth factor */
+/* for the leading INFO columns of A. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0D+0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the extra-precise refinement algorithm. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rcequ = FALSE_;
+ } else {
+ rcequ = lsame_(equed, "Y");
+ }
+
+/* Default is failure. If an input parameter is wrong or */
+/* factorization fails, make everything look horrible. Only the */
+/* pivot growth is set here, the rest is initialized in ZPORFSX. */
+
+ *rpvgrw = 0.;
+
+/* Test the input parameters. PARAMS is not tested until ZPORFSX. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (lsame_(fact, "F") && ! (rcequ || lsame_(
+ equed, "N"))) {
+ *info = -9;
+ } else {
+ if (rcequ) {
+ smin = bignum;
+ smax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = smin, d__2 = s[j];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = smax, d__2 = s[j];
+ smax = max(d__1,d__2);
+/* L10: */
+ }
+ if (smin <= 0.) {
+ *info = -10;
+ } else if (*n > 0) {
+ scond = max(smin,smlnum) / min(smax,bignum);
+ } else {
+ scond = 1.;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -12;
+ } else if (*ldx < max(1,*n)) {
+ *info = -14;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPOSVXX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ zpoequb_(n, &a[a_offset], lda, &s[1], &scond, &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ zlaqhe_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed);
+ rcequ = lsame_(equed, "Y");
+ }
+ }
+
+/* Scale the right-hand side. */
+
+ if (rcequ) {
+ zlascl2_(n, nrhs, &s[1], &b[b_offset], ldb);
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of A. */
+
+ zlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ zpotrf_(uplo, n, &af[af_offset], ldaf, info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Pivot in column INFO is exactly 0 */
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ *rpvgrw = zla_porpvgrw__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &rwork[1], (ftnlen)1);
+ return 0;
+ }
+ }
+
+/* Compute the reciprocal pivot growth factor RPVGRW. */
+
+ *rpvgrw = zla_porpvgrw__(uplo, n, &a[a_offset], lda, &af[af_offset], ldaf,
+ &rwork[1], (ftnlen)1);
+
+/* Compute the solution matrix X. */
+
+ zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ zpotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &x[x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ zporfsx_(uplo, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &
+ s[1], &b[b_offset], ldb, &x[x_offset], ldx, rcond, &berr[1],
+ n_err_bnds__, &err_bnds_norm__[err_bnds_norm_offset], &
+ err_bnds_comp__[err_bnds_comp_offset], nparams, ¶ms[1], &work[
+ 1], &rwork[1], info);
+
+/* Scale solutions. */
+
+ if (rcequ) {
+ zlascl2_(n, nrhs, &s[1], &x[x_offset], ldx);
+ }
+
+ return 0;
+
+/* End of ZPOSVXX */
+
+} /* zposvxx_ */
diff --git a/SRC/zpotf2.c b/SRC/zpotf2.c
new file mode 100644
index 0000000..ffdb708
--- /dev/null
+++ b/SRC/zpotf2.c
@@ -0,0 +1,245 @@
+/* zpotf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zpotf2_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer j;
+ doublereal ajj;
+ extern logical lsame_(char *, char *);
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ logical upper;
+ extern logical disnan_(doublereal *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
+ integer *, doublereal *, doublecomplex *, integer *), zlacgv_(
+ integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPOTF2 computes the Cholesky factorization of a complex Hermitian */
+/* positive definite matrix A. */
+
+/* The factorization has the form */
+/* A = U' * U , if UPLO = 'U', or */
+/* A = L * L', if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the 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, the factor U or L from the Cholesky */
+/* factorization A = U'*U or A = L*L'. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, the leading minor of order k is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPOTF2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute U(J,J) and test for non-positive-definiteness. */
+
+ i__2 = j + j * a_dim1;
+ d__1 = a[i__2].r;
+ i__3 = j - 1;
+ zdotc_(&z__2, &i__3, &a[j * a_dim1 + 1], &c__1, &a[j * a_dim1 + 1]
+, &c__1);
+ z__1.r = d__1 - z__2.r, z__1.i = -z__2.i;
+ ajj = z__1.r;
+ if (ajj <= 0. || disnan_(&ajj)) {
+ i__2 = j + j * a_dim1;
+ a[i__2].r = ajj, a[i__2].i = 0.;
+ goto L30;
+ }
+ ajj = sqrt(ajj);
+ i__2 = j + j * a_dim1;
+ a[i__2].r = ajj, a[i__2].i = 0.;
+
+/* Compute elements J+1:N of row J. */
+
+ if (j < *n) {
+ i__2 = j - 1;
+ zlacgv_(&i__2, &a[j * a_dim1 + 1], &c__1);
+ i__2 = j - 1;
+ i__3 = *n - j;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Transpose", &i__2, &i__3, &z__1, &a[(j + 1) * a_dim1
+ + 1], lda, &a[j * a_dim1 + 1], &c__1, &c_b1, &a[j + (
+ j + 1) * a_dim1], lda);
+ i__2 = j - 1;
+ zlacgv_(&i__2, &a[j * a_dim1 + 1], &c__1);
+ i__2 = *n - j;
+ d__1 = 1. / ajj;
+ zdscal_(&i__2, &d__1, &a[j + (j + 1) * a_dim1], lda);
+ }
+/* L10: */
+ }
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute L(J,J) and test for non-positive-definiteness. */
+
+ i__2 = j + j * a_dim1;
+ d__1 = a[i__2].r;
+ i__3 = j - 1;
+ zdotc_(&z__2, &i__3, &a[j + a_dim1], lda, &a[j + a_dim1], lda);
+ z__1.r = d__1 - z__2.r, z__1.i = -z__2.i;
+ ajj = z__1.r;
+ if (ajj <= 0. || disnan_(&ajj)) {
+ i__2 = j + j * a_dim1;
+ a[i__2].r = ajj, a[i__2].i = 0.;
+ goto L30;
+ }
+ ajj = sqrt(ajj);
+ i__2 = j + j * a_dim1;
+ a[i__2].r = ajj, a[i__2].i = 0.;
+
+/* Compute elements J+1:N of column J. */
+
+ if (j < *n) {
+ i__2 = j - 1;
+ zlacgv_(&i__2, &a[j + a_dim1], lda);
+ i__2 = *n - j;
+ i__3 = j - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No transpose", &i__2, &i__3, &z__1, &a[j + 1 + a_dim1]
+, lda, &a[j + a_dim1], lda, &c_b1, &a[j + 1 + j *
+ a_dim1], &c__1);
+ i__2 = j - 1;
+ zlacgv_(&i__2, &a[j + a_dim1], lda);
+ i__2 = *n - j;
+ d__1 = 1. / ajj;
+ zdscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1);
+ }
+/* L20: */
+ }
+ }
+ goto L40;
+
+L30:
+ *info = j;
+
+L40:
+ return 0;
+
+/* End of ZPOTF2 */
+
+} /* zpotf2_ */
diff --git a/SRC/zpotrf.c b/SRC/zpotrf.c
new file mode 100644
index 0000000..04edc40
--- /dev/null
+++ b/SRC/zpotrf.c
@@ -0,0 +1,248 @@
+/* zpotrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b14 = -1.;
+static doublereal c_b15 = 1.;
+
+/* Subroutine */ int zpotrf_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer j, jb, nb;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zherk_(char *, char *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ zpotf2_(char *, integer *, doublecomplex *, integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPOTRF computes the Cholesky factorization of a complex Hermitian */
+/* positive definite matrix A. */
+
+/* The factorization has the form */
+/* A = U**H * U, if UPLO = 'U', or */
+/* A = L * L**H, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* This is the block version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (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, the factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPOTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Determine the block size for this environment. */
+
+ nb = ilaenv_(&c__1, "ZPOTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code. */
+
+ zpotf2_(uplo, n, &a[a_offset], lda, info);
+ } else {
+
+/* Use blocked code. */
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+ i__3 = j - 1;
+ zherk_("Upper", "Conjugate transpose", &jb, &i__3, &c_b14, &a[
+ j * a_dim1 + 1], lda, &c_b15, &a[j + j * a_dim1], lda);
+ zpotf2_("Upper", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+ if (j + jb <= *n) {
+
+/* Compute the current block row. */
+
+ i__3 = *n - j - jb + 1;
+ i__4 = j - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("Conjugate transpose", "No transpose", &jb, &i__3,
+ &i__4, &z__1, &a[j * a_dim1 + 1], lda, &a[(j + jb)
+ * a_dim1 + 1], lda, &c_b1, &a[j + (j + jb) *
+ a_dim1], lda);
+ i__3 = *n - j - jb + 1;
+ ztrsm_("Left", "Upper", "Conjugate transpose", "Non-unit",
+ &jb, &i__3, &c_b1, &a[j + j * a_dim1], lda, &a[j
+ + (j + jb) * a_dim1], lda);
+ }
+/* L10: */
+ }
+
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
+
+/* Update and factorize the current diagonal block and test */
+/* for non-positive-definiteness. */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - j + 1;
+ jb = min(i__3,i__4);
+ i__3 = j - 1;
+ zherk_("Lower", "No transpose", &jb, &i__3, &c_b14, &a[j +
+ a_dim1], lda, &c_b15, &a[j + j * a_dim1], lda);
+ zpotf2_("Lower", &jb, &a[j + j * a_dim1], lda, info);
+ if (*info != 0) {
+ goto L30;
+ }
+ if (j + jb <= *n) {
+
+/* Compute the current block column. */
+
+ i__3 = *n - j - jb + 1;
+ i__4 = j - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "Conjugate transpose", &i__3, &jb,
+ &i__4, &z__1, &a[j + jb + a_dim1], lda, &a[j +
+ a_dim1], lda, &c_b1, &a[j + jb + j * a_dim1], lda);
+ i__3 = *n - j - jb + 1;
+ ztrsm_("Right", "Lower", "Conjugate transpose", "Non-unit"
+, &i__3, &jb, &c_b1, &a[j + j * a_dim1], lda, &a[
+ j + jb + j * a_dim1], lda);
+ }
+/* L20: */
+ }
+ }
+ }
+ goto L40;
+
+L30:
+ *info = *info + j - 1;
+
+L40:
+ return 0;
+
+/* End of ZPOTRF */
+
+} /* zpotrf_ */
diff --git a/SRC/zpotri.c b/SRC/zpotri.c
new file mode 100644
index 0000000..54978de
--- /dev/null
+++ b/SRC/zpotri.c
@@ -0,0 +1,125 @@
+/* zpotri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zpotri_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), zlauum_(
+ char *, integer *, doublecomplex *, integer *, integer *),
+ ztrtri_(char *, char *, integer *, doublecomplex *, integer *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPOTRI computes the inverse of a complex Hermitian positive definite */
+/* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H */
+/* computed by ZPOTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the triangular factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H, as computed by */
+/* ZPOTRF. */
+/* On exit, the upper or lower triangle of the (Hermitian) */
+/* inverse of A, overwriting the input factor U or L. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the (i,i) element of the factor U or L is */
+/* zero, and the inverse could not be computed. */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPOTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Invert the triangular Cholesky factor U or L. */
+
+ ztrtri_(uplo, "Non-unit", n, &a[a_offset], lda, info);
+ if (*info > 0) {
+ return 0;
+ }
+
+/* Form inv(U)*inv(U)' or inv(L)'*inv(L). */
+
+ zlauum_(uplo, n, &a[a_offset], lda, info);
+
+ return 0;
+
+/* End of ZPOTRI */
+
+} /* zpotri_ */
diff --git a/SRC/zpotrs.c b/SRC/zpotrs.c
new file mode 100644
index 0000000..908e25f
--- /dev/null
+++ b/SRC/zpotrs.c
@@ -0,0 +1,166 @@
+/* zpotrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+
+/* Subroutine */ int zpotrs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPOTRS solves a system of linear equations A*X = B with a Hermitian */
+/* positive definite matrix A using the Cholesky factorization */
+/* A = U**H*U or A = L*L**H computed by ZPOTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**H*U or A = L*L**H, as computed by ZPOTRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPOTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B where A = U'*U. */
+
+/* Solve U'*X = B, overwriting B with X. */
+
+ ztrsm_("Left", "Upper", "Conjugate transpose", "Non-unit", n, nrhs, &
+ c_b1, &a[a_offset], lda, &b[b_offset], ldb);
+
+/* Solve U*X = B, overwriting B with X. */
+
+ ztrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b1, &
+ a[a_offset], lda, &b[b_offset], ldb);
+ } else {
+
+/* Solve A*X = B where A = L*L'. */
+
+/* Solve L*X = B, overwriting B with X. */
+
+ ztrsm_("Left", "Lower", "No transpose", "Non-unit", n, nrhs, &c_b1, &
+ a[a_offset], lda, &b[b_offset], ldb);
+
+/* Solve L'*X = B, overwriting B with X. */
+
+ ztrsm_("Left", "Lower", "Conjugate transpose", "Non-unit", n, nrhs, &
+ c_b1, &a[a_offset], lda, &b[b_offset], ldb);
+ }
+
+ return 0;
+
+/* End of ZPOTRS */
+
+} /* zpotrs_ */
diff --git a/SRC/zppcon.c b/SRC/zppcon.c
new file mode 100644
index 0000000..026cddc
--- /dev/null
+++ b/SRC/zppcon.c
@@ -0,0 +1,223 @@
+/* zppcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zppcon_(char *uplo, integer *n, doublecomplex *ap,
+ doublereal *anorm, doublereal *rcond, doublecomplex *work, doublereal
+ *rwork, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer ix, kase;
+ doublereal scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal scalel, scaleu;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal ainvnm;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zdrscl_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ char normin[1];
+ doublereal smlnum;
+ extern /* Subroutine */ int zlatps_(char *, char *, char *, char *,
+ integer *, doublecomplex *, doublecomplex *, doublereal *,
+ doublereal *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPPCON estimates the reciprocal of the condition number (in the */
+/* 1-norm) of a complex Hermitian positive definite packed matrix using */
+/* the Cholesky factorization A = U**H*U or A = L*L**H computed by */
+/* ZPPTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**H*U or A = L*L**H, packed columnwise in a linear */
+/* array. The j-th column of U or L is stored in the array AP */
+/* as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */
+
+/* ANORM (input) DOUBLE PRECISION */
+/* The 1-norm (or infinity-norm) of the Hermitian matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*anorm < 0.) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPPCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.;
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ } else if (*anorm == 0.) {
+ return 0;
+ }
+
+ smlnum = dlamch_("Safe minimum");
+
+/* Estimate the 1-norm of the inverse. */
+
+ kase = 0;
+ *(unsigned char *)normin = 'N';
+L10:
+ zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (upper) {
+
+/* Multiply by inv(U'). */
+
+ zlatps_("Upper", "Conjugate transpose", "Non-unit", normin, n, &
+ ap[1], &work[1], &scalel, &rwork[1], info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(U). */
+
+ zlatps_("Upper", "No transpose", "Non-unit", normin, n, &ap[1], &
+ work[1], &scaleu, &rwork[1], info);
+ } else {
+
+/* Multiply by inv(L). */
+
+ zlatps_("Lower", "No transpose", "Non-unit", normin, n, &ap[1], &
+ work[1], &scalel, &rwork[1], info);
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by inv(L'). */
+
+ zlatps_("Lower", "Conjugate transpose", "Non-unit", normin, n, &
+ ap[1], &work[1], &scaleu, &rwork[1], info);
+ }
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ scale = scalel * scaleu;
+ if (scale != 1.) {
+ ix = izamax_(n, &work[1], &c__1);
+ i__1 = ix;
+ if (scale < ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(&
+ work[ix]), abs(d__2))) * smlnum || scale == 0.) {
+ goto L20;
+ }
+ zdrscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / ainvnm / *anorm;
+ }
+
+L20:
+ return 0;
+
+/* End of ZPPCON */
+
+} /* zppcon_ */
diff --git a/SRC/zppequ.c b/SRC/zppequ.c
new file mode 100644
index 0000000..d8dcefa
--- /dev/null
+++ b/SRC/zppequ.c
@@ -0,0 +1,210 @@
+/* zppequ.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zppequ_(char *uplo, integer *n, doublecomplex *ap,
+ doublereal *s, doublereal *scond, doublereal *amax, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, jj;
+ doublereal smin;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPPEQU computes row and column scalings intended to equilibrate a */
+/* Hermitian positive definite matrix A in packed storage and reduce */
+/* its condition number (with respect to the two-norm). S contains the */
+/* scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix */
+/* B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal. */
+/* This choice of S puts the condition number of B within a factor N of */
+/* the smallest possible condition number over all possible diagonal */
+/* scalings. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the Hermitian matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* S (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, S contains the scale factors for A. */
+
+/* SCOND (output) DOUBLE PRECISION */
+/* If INFO = 0, S contains the ratio of the smallest S(i) to */
+/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
+/* large nor too small, it is not worth scaling by S. */
+
+/* AMAX (output) DOUBLE PRECISION */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --s;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPPEQU", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *scond = 1.;
+ *amax = 0.;
+ return 0;
+ }
+
+/* Initialize SMIN and AMAX. */
+
+ s[1] = ap[1].r;
+ smin = s[1];
+ *amax = s[1];
+
+ if (upper) {
+
+/* UPLO = 'U': Upper triangle of A is stored. */
+/* Find the minimum and maximum diagonal elements. */
+
+ jj = 1;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ jj += i__;
+ i__2 = jj;
+ s[i__] = ap[i__2].r;
+/* Computing MIN */
+ d__1 = smin, d__2 = s[i__];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = *amax, d__2 = s[i__];
+ *amax = max(d__1,d__2);
+/* L10: */
+ }
+
+ } else {
+
+/* UPLO = 'L': Lower triangle of A is stored. */
+/* Find the minimum and maximum diagonal elements. */
+
+ jj = 1;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ jj = jj + *n - i__ + 2;
+ i__2 = jj;
+ s[i__] = ap[i__2].r;
+/* Computing MIN */
+ d__1 = smin, d__2 = s[i__];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = *amax, d__2 = s[i__];
+ *amax = max(d__1,d__2);
+/* L20: */
+ }
+ }
+
+ if (smin <= 0.) {
+
+/* Find the first non-positive diagonal element and return. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] <= 0.) {
+ *info = i__;
+ return 0;
+ }
+/* L30: */
+ }
+ } else {
+
+/* Set the scale factors to the reciprocals */
+/* of the diagonal elements. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s[i__] = 1. / sqrt(s[i__]);
+/* L40: */
+ }
+
+/* Compute SCOND = min(S(I)) / max(S(I)) */
+
+ *scond = sqrt(smin) / sqrt(*amax);
+ }
+ return 0;
+
+/* End of ZPPEQU */
+
+} /* zppequ_ */
diff --git a/SRC/zpprfs.c b/SRC/zpprfs.c
new file mode 100644
index 0000000..0ad5501
--- /dev/null
+++ b/SRC/zpprfs.c
@@ -0,0 +1,457 @@
+/* zpprfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zpprfs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *ap, doublecomplex *afp, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr,
+ doublecomplex *work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal s;
+ integer ik, kk;
+ doublereal xk;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3], count;
+ logical upper;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zhpmv_(char *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *), zaxpy_(
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal lstres;
+ extern /* Subroutine */ int zpptrs_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPPRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is Hermitian positive definite */
+/* and packed, and provides error bounds and backward error estimates */
+/* for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the Hermitian matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* AFP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**H*U or A = L*L**H, as computed by DPPTRF/ZPPTRF, */
+/* packed columnwise in a linear array in the same format as A */
+/* (see AP). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by ZPPTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ==================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --afp;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldx < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPPRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ z__1.r = -1., z__1.i = -0.;
+ zhpmv_(uplo, n, &z__1, &ap[1], &x[j * x_dim1 + 1], &c__1, &c_b1, &
+ work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
+ i__ + j * b_dim1]), abs(d__2));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ kk = 1;
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
+ x_dim1]), abs(d__2));
+ ik = kk;
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ik;
+ rwork[i__] += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&ap[ik]), abs(d__2))) * xk;
+ i__4 = ik;
+ i__5 = i__ + j * x_dim1;
+ s += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 = d_imag(&ap[
+ ik]), abs(d__2))) * ((d__3 = x[i__5].r, abs(d__3))
+ + (d__4 = d_imag(&x[i__ + j * x_dim1]), abs(d__4)
+ ));
+ ++ik;
+/* L40: */
+ }
+ i__3 = kk + k - 1;
+ rwork[k] = rwork[k] + (d__1 = ap[i__3].r, abs(d__1)) * xk + s;
+ kk += k;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
+ x_dim1]), abs(d__2));
+ i__3 = kk;
+ rwork[k] += (d__1 = ap[i__3].r, abs(d__1)) * xk;
+ ik = kk + 1;
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ i__4 = ik;
+ rwork[i__] += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&ap[ik]), abs(d__2))) * xk;
+ i__4 = ik;
+ i__5 = i__ + j * x_dim1;
+ s += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 = d_imag(&ap[
+ ik]), abs(d__2))) * ((d__3 = x[i__5].r, abs(d__3))
+ + (d__4 = d_imag(&x[i__ + j * x_dim1]), abs(d__4)
+ ));
+ ++ik;
+/* L60: */
+ }
+ rwork[k] += s;
+ kk += *n - k + 1;
+/* L70: */
+ }
+ }
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__3 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2))) / rwork[i__];
+ s = max(d__3,d__4);
+ } else {
+/* Computing MAX */
+ i__3 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = max(d__3,d__4);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ zpptrs_(uplo, n, &c__1, &afp[1], &work[1], n, info);
+ zaxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use ZLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__3 = i__;
+ rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ ;
+ } else {
+ i__3 = i__;
+ rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ zpptrs_(uplo, n, &c__1, &afp[1], &work[1], n, info)
+ ;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L120: */
+ }
+ zpptrs_(uplo, n, &c__1, &afp[1], &work[1], n, info)
+ ;
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * x_dim1;
+ d__3 = lstres, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&x[i__ + j * x_dim1]), abs(d__2));
+ lstres = max(d__3,d__4);
+/* L130: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of ZPPRFS */
+
+} /* zpprfs_ */
diff --git a/SRC/zppsv.c b/SRC/zppsv.c
new file mode 100644
index 0000000..2050474
--- /dev/null
+++ b/SRC/zppsv.c
@@ -0,0 +1,161 @@
+/* zppsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zppsv_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *ap, doublecomplex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), zpptrf_(
+ char *, integer *, doublecomplex *, integer *), zpptrs_(
+ char *, integer *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPPSV computes the solution to a complex system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N Hermitian positive definite matrix stored in */
+/* packed format and X and B are N-by-NRHS matrices. */
+
+/* The Cholesky decomposition is used to factor A as */
+/* A = U**H* U, if UPLO = 'U', or */
+/* A = L * L**H, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is a lower triangular */
+/* matrix. The factored form of A is then used to solve the system of */
+/* equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H, in the same storage */
+/* format as A. */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i of A is not */
+/* positive definite, so the factorization could not be */
+/* completed, and the solution has not been computed. */
+
+/* Further Details */
+/* =============== */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the Hermitian matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = conjg(aji)) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPPSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ zpptrf_(uplo, n, &ap[1], info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ zpptrs_(uplo, n, nrhs, &ap[1], &b[b_offset], ldb, info);
+
+ }
+ return 0;
+
+/* End of ZPPSV */
+
+} /* zppsv_ */
diff --git a/SRC/zppsvx.c b/SRC/zppsvx.c
new file mode 100644
index 0000000..30e662b
--- /dev/null
+++ b/SRC/zppsvx.c
@@ -0,0 +1,465 @@
+/* zppsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zppsvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublecomplex *ap, doublecomplex *afp, char *equed, doublereal *
+ s, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
+ doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *
+ work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal amax, smin, smax;
+ extern logical lsame_(char *, char *);
+ doublereal scond, anorm;
+ logical equil, rcequ;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ integer infequ;
+ extern doublereal zlanhp_(char *, char *, integer *, doublecomplex *,
+ doublereal *);
+ extern /* Subroutine */ int zlaqhp_(char *, integer *, doublecomplex *,
+ doublereal *, doublereal *, doublereal *, char *),
+ zlacpy_(char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zppcon_(char *, integer *,
+ doublecomplex *, doublereal *, doublereal *, doublecomplex *,
+ doublereal *, integer *);
+ doublereal smlnum;
+ extern /* Subroutine */ int zppequ_(char *, integer *, doublecomplex *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ zpprfs_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublecomplex *,
+ doublereal *, integer *), zpptrf_(char *, integer *,
+ doublecomplex *, integer *), zpptrs_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPPSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to */
+/* compute the solution to a complex system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N Hermitian positive definite matrix stored in */
+/* packed format and X and B are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
+/* the system: */
+/* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
+
+/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */
+/* factor the matrix A (after equilibration if FACT = 'E') as */
+/* A = U'* U , if UPLO = 'U', or */
+/* A = L * L', if UPLO = 'L', */
+/* where U is an upper triangular matrix, L is a lower triangular */
+/* matrix, and ' indicates conjugate transpose. */
+
+/* 3. If the leading i-by-i principal minor is not positive definite, */
+/* then the routine returns with INFO = i. Otherwise, the factored */
+/* form of A is used to estimate the condition number of the matrix */
+/* A. If the reciprocal of the condition number is less than machine */
+/* precision, INFO = N+1 is returned as a warning, but the routine */
+/* still goes on to solve for X and compute error bounds as */
+/* described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(S) so that it solves the original system before */
+/* equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AFP contains the factored form of A. */
+/* If EQUED = 'Y', the matrix A has been equilibrated */
+/* with scaling factors given by S. AP and AFP will not */
+/* be modified. */
+/* = 'N': The matrix A will be copied to AFP and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AFP and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array, except if FACT = 'F' */
+/* and EQUED = 'Y', then A must contain the equilibrated matrix */
+/* diag(S)*A*diag(S). The j-th column of A is stored in the */
+/* array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. A is not modified if */
+/* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
+
+/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
+/* diag(S)*A*diag(S). */
+
+/* AFP (input or output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* If FACT = 'F', then AFP is an input argument and on entry */
+/* contains the triangular factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H, in the same storage */
+/* format as A. If EQUED .ne. 'N', then AFP is the factored */
+/* form of the equilibrated matrix A. */
+
+/* If FACT = 'N', then AFP is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H of the original */
+/* matrix A. */
+
+/* If FACT = 'E', then AFP is an output argument and on exit */
+/* returns the triangular factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H of the equilibrated */
+/* matrix A (see the description of AP for the form of the */
+/* equilibrated matrix). */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'Y': Equilibration was done, i.e., A has been replaced by */
+/* diag(S) * A * diag(S). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* S (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The scale factors for A; not accessed if EQUED = 'N'. S is */
+/* an input argument if FACT = 'F'; otherwise, S is an output */
+/* argument. If FACT = 'F' and EQUED = 'Y', each element of S */
+/* must be positive. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */
+/* B is overwritten by diag(S) * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */
+/* the original system of equations. Note that if EQUED = 'Y', */
+/* A and B are modified on exit, and the solution to the */
+/* equilibrated system is inv(diag(S))*X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A after equilibration (if done). If RCOND is less than the */
+/* machine precision (in particular, if RCOND = 0), the matrix */
+/* is singular to working precision. This condition is */
+/* indicated by a return code of INFO > 0. */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: the leading minor of order i of A is */
+/* not positive definite, so the factorization */
+/* could not be completed, and the solution has not */
+/* been computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* Further Details */
+/* =============== */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the Hermitian matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = conjg(aji)) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ap;
+ --afp;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rcequ = FALSE_;
+ } else {
+ rcequ = lsame_(equed, "Y");
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ }
+
+/* Test the input parameters. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (lsame_(fact, "F") && ! (rcequ || lsame_(
+ equed, "N"))) {
+ *info = -7;
+ } else {
+ if (rcequ) {
+ smin = bignum;
+ smax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = smin, d__2 = s[j];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = smax, d__2 = s[j];
+ smax = max(d__1,d__2);
+/* L10: */
+ }
+ if (smin <= 0.) {
+ *info = -8;
+ } else if (*n > 0) {
+ scond = max(smin,smlnum) / min(smax,bignum);
+ } else {
+ scond = 1.;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldx < max(1,*n)) {
+ *info = -12;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPPSVX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ zppequ_(uplo, n, &ap[1], &s[1], &scond, &amax, &infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ zlaqhp_(uplo, n, &ap[1], &s[1], &scond, &amax, equed);
+ rcequ = lsame_(equed, "Y");
+ }
+ }
+
+/* Scale the right-hand side. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * b_dim1;
+ z__1.r = s[i__4] * b[i__5].r, z__1.i = s[i__4] * b[i__5].i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L20: */
+ }
+/* L30: */
+ }
+ }
+
+ if (nofact || equil) {
+
+/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
+
+ i__1 = *n * (*n + 1) / 2;
+ zcopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1);
+ zpptrf_(uplo, n, &afp[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = zlanhp_("I", uplo, n, &ap[1], &rwork[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ zppcon_(uplo, n, &afp[1], &anorm, rcond, &work[1], &rwork[1], info);
+
+/* Compute the solution matrix X. */
+
+ zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ zpptrs_(uplo, n, nrhs, &afp[1], &x[x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ zpprfs_(uplo, n, nrhs, &ap[1], &afp[1], &b[b_offset], ldb, &x[x_offset],
+ ldx, &ferr[1], &berr[1], &work[1], &rwork[1], info);
+
+/* Transform the solution matrix X to a solution of the original */
+/* system. */
+
+ if (rcequ) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__;
+ i__5 = i__ + j * x_dim1;
+ z__1.r = s[i__4] * x[i__5].r, z__1.i = s[i__4] * x[i__5].i;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+/* L40: */
+ }
+/* L50: */
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] /= scond;
+/* L60: */
+ }
+ }
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < dlamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of ZPPSVX */
+
+} /* zppsvx_ */
diff --git a/SRC/zpptrf.c b/SRC/zpptrf.c
new file mode 100644
index 0000000..cf28d0b
--- /dev/null
+++ b/SRC/zpptrf.c
@@ -0,0 +1,233 @@
+/* zpptrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b16 = -1.;
+
+/* Subroutine */ int zpptrf_(char *uplo, integer *n, doublecomplex *ap,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublereal d__1;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer j, jc, jj;
+ doublereal ajj;
+ extern /* Subroutine */ int zhpr_(char *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *);
+ extern logical lsame_(char *, char *);
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int ztpsv_(char *, char *, char *, integer *,
+ doublecomplex *, doublecomplex *, integer *), xerbla_(char *, integer *), zdscal_(integer *,
+ doublereal *, doublecomplex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPPTRF computes the Cholesky factorization of a complex Hermitian */
+/* positive definite matrix A stored in packed format. */
+
+/* The factorization has the form */
+/* A = U**H * U, if UPLO = 'U', or */
+/* A = L * L**H, if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the Hermitian matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+
+/* On exit, if INFO = 0, the triangular factor U or L from the */
+/* Cholesky factorization A = U**H*U or A = L*L**H, in the same */
+/* storage format as A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the factorization could not be */
+/* completed. */
+
+/* Further Details */
+/* =============== */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the Hermitian matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = conjg(aji)) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPPTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Compute the Cholesky factorization A = U'*U. */
+
+ jj = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ jc = jj + 1;
+ jj += j;
+
+/* Compute elements 1:J-1 of column J. */
+
+ if (j > 1) {
+ i__2 = j - 1;
+ ztpsv_("Upper", "Conjugate transpose", "Non-unit", &i__2, &ap[
+ 1], &ap[jc], &c__1);
+ }
+
+/* Compute U(J,J) and test for non-positive-definiteness. */
+
+ i__2 = jj;
+ d__1 = ap[i__2].r;
+ i__3 = j - 1;
+ zdotc_(&z__2, &i__3, &ap[jc], &c__1, &ap[jc], &c__1);
+ z__1.r = d__1 - z__2.r, z__1.i = -z__2.i;
+ ajj = z__1.r;
+ if (ajj <= 0.) {
+ i__2 = jj;
+ ap[i__2].r = ajj, ap[i__2].i = 0.;
+ goto L30;
+ }
+ i__2 = jj;
+ d__1 = sqrt(ajj);
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+/* L10: */
+ }
+ } else {
+
+/* Compute the Cholesky factorization A = L*L'. */
+
+ jj = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute L(J,J) and test for non-positive-definiteness. */
+
+ i__2 = jj;
+ ajj = ap[i__2].r;
+ if (ajj <= 0.) {
+ i__2 = jj;
+ ap[i__2].r = ajj, ap[i__2].i = 0.;
+ goto L30;
+ }
+ ajj = sqrt(ajj);
+ i__2 = jj;
+ ap[i__2].r = ajj, ap[i__2].i = 0.;
+
+/* Compute elements J+1:N of column J and update the trailing */
+/* submatrix. */
+
+ if (j < *n) {
+ i__2 = *n - j;
+ d__1 = 1. / ajj;
+ zdscal_(&i__2, &d__1, &ap[jj + 1], &c__1);
+ i__2 = *n - j;
+ zhpr_("Lower", &i__2, &c_b16, &ap[jj + 1], &c__1, &ap[jj + *n
+ - j + 1]);
+ jj = jj + *n - j + 1;
+ }
+/* L20: */
+ }
+ }
+ goto L40;
+
+L30:
+ *info = j;
+
+L40:
+ return 0;
+
+/* End of ZPPTRF */
+
+} /* zpptrf_ */
diff --git a/SRC/zpptri.c b/SRC/zpptri.c
new file mode 100644
index 0000000..b13fc3c
--- /dev/null
+++ b/SRC/zpptri.c
@@ -0,0 +1,179 @@
+/* zpptri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b8 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int zpptri_(char *uplo, integer *n, doublecomplex *ap,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer j, jc, jj;
+ doublereal ajj;
+ integer jjn;
+ extern /* Subroutine */ int zhpr_(char *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *);
+ extern logical lsame_(char *, char *);
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int ztpmv_(char *, char *, char *, integer *,
+ doublecomplex *, doublecomplex *, integer *), xerbla_(char *, integer *), zdscal_(integer *,
+ doublereal *, doublecomplex *, integer *), ztptri_(char *, char *,
+ integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPPTRI computes the inverse of a complex Hermitian positive definite */
+/* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H */
+/* computed by ZPPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular factor is stored in AP; */
+/* = 'L': Lower triangular factor is stored in AP. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the triangular factor U or L from the Cholesky */
+/* factorization A = U**H*U or A = L*L**H, packed columnwise as */
+/* a linear array. The j-th column of U or L is stored in the */
+/* array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */
+
+/* On exit, the upper or lower triangle of the (Hermitian) */
+/* inverse of A, overwriting the input factor U or L. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the (i,i) element of the factor U or L is */
+/* zero, and the inverse could not be computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPPTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Invert the triangular Cholesky factor U or L. */
+
+ ztptri_(uplo, "Non-unit", n, &ap[1], info);
+ if (*info > 0) {
+ return 0;
+ }
+ if (upper) {
+
+/* Compute the product inv(U) * inv(U)'. */
+
+ jj = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ jc = jj + 1;
+ jj += j;
+ if (j > 1) {
+ i__2 = j - 1;
+ zhpr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1]);
+ }
+ i__2 = jj;
+ ajj = ap[i__2].r;
+ zdscal_(&j, &ajj, &ap[jc], &c__1);
+/* L10: */
+ }
+
+ } else {
+
+/* Compute the product inv(L)' * inv(L). */
+
+ jj = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ jjn = jj + *n - j + 1;
+ i__2 = jj;
+ i__3 = *n - j + 1;
+ zdotc_(&z__1, &i__3, &ap[jj], &c__1, &ap[jj], &c__1);
+ d__1 = z__1.r;
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+ if (j < *n) {
+ i__2 = *n - j;
+ ztpmv_("Lower", "Conjugate transpose", "Non-unit", &i__2, &ap[
+ jjn], &ap[jj + 1], &c__1);
+ }
+ jj = jjn;
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of ZPPTRI */
+
+} /* zpptri_ */
diff --git a/SRC/zpptrs.c b/SRC/zpptrs.c
new file mode 100644
index 0000000..3999cdd
--- /dev/null
+++ b/SRC/zpptrs.c
@@ -0,0 +1,169 @@
+/* zpptrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zpptrs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *ap, doublecomplex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ integer i__;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int ztpsv_(char *, char *, char *, integer *,
+ doublecomplex *, doublecomplex *, integer *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPPTRS solves a system of linear equations A*X = B with a Hermitian */
+/* positive definite matrix A in packed storage using the Cholesky */
+/* factorization A = U**H*U or A = L*L**H computed by ZPPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The triangular factor U or L from the Cholesky factorization */
+/* A = U**H*U or A = L*L**H, packed columnwise in a linear */
+/* array. The j-th column of U or L is stored in the array AP */
+/* as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPPTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B where A = U'*U. */
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Solve U'*X = B, overwriting B with X. */
+
+ ztpsv_("Upper", "Conjugate transpose", "Non-unit", n, &ap[1], &b[
+ i__ * b_dim1 + 1], &c__1);
+
+/* Solve U*X = B, overwriting B with X. */
+
+ ztpsv_("Upper", "No transpose", "Non-unit", n, &ap[1], &b[i__ *
+ b_dim1 + 1], &c__1);
+/* L10: */
+ }
+ } else {
+
+/* Solve A*X = B where A = L*L'. */
+
+ i__1 = *nrhs;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Solve L*Y = B, overwriting B with X. */
+
+ ztpsv_("Lower", "No transpose", "Non-unit", n, &ap[1], &b[i__ *
+ b_dim1 + 1], &c__1);
+
+/* Solve L'*X = Y, overwriting B with X. */
+
+ ztpsv_("Lower", "Conjugate transpose", "Non-unit", n, &ap[1], &b[
+ i__ * b_dim1 + 1], &c__1);
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of ZPPTRS */
+
+} /* zpptrs_ */
diff --git a/SRC/zpstf2.c b/SRC/zpstf2.c
new file mode 100644
index 0000000..7aa4242
--- /dev/null
+++ b/SRC/zpstf2.c
@@ -0,0 +1,443 @@
+/* zpstf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zpstf2_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *piv, integer *rank, doublereal *tol,
+ doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, maxlocval;
+ doublereal ajj;
+ integer pvt;
+ extern logical lsame_(char *, char *);
+ doublereal dtemp;
+ integer itemp;
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ doublereal dstop;
+ logical upper;
+ doublecomplex ztemp;
+ extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ extern logical disnan_(doublereal *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
+ integer *, doublereal *, doublecomplex *, integer *), zlacgv_(
+ integer *, doublecomplex *, integer *);
+ extern integer dmaxloc_(doublereal *, integer *);
+
+
+/* -- LAPACK PROTOTYPE routine (version 3.2) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPSTF2 computes the Cholesky factorization with complete */
+/* pivoting of a complex Hermitian positive semidefinite matrix A. */
+
+/* The factorization has the form */
+/* P' * A * P = U' * U , if UPLO = 'U', */
+/* P' * A * P = L * L', if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular, and */
+/* P is stored as vector PIV. */
+
+/* This algorithm does not attempt to check that A is positive */
+/* semidefinite. This version of the algorithm calls level 2 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n by n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n by n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization as above. */
+
+/* PIV (output) INTEGER array, dimension (N) */
+/* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. */
+
+/* RANK (output) INTEGER */
+/* The rank of A given by the number of steps the algorithm */
+/* completed. */
+
+/* TOL (input) DOUBLE PRECISION */
+/* User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) ) */
+/* will be used. The algorithm terminates at the (K-1)st step */
+/* if the pivot <= TOL. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* WORK DOUBLE PRECISION array, dimension (2*N) */
+/* Work space. */
+
+/* INFO (output) INTEGER */
+/* < 0: If INFO = -K, the K-th argument had an illegal value, */
+/* = 0: algorithm completed successfully, and */
+/* > 0: the matrix A is either rank deficient with computed rank */
+/* as returned in RANK, or is indefinite. See Section 7 of */
+/* LAPACK Working Note #161 for further information. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters */
+
+ /* Parameter adjustments */
+ --work;
+ --piv;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPSTF2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Initialize PIV */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ piv[i__] = i__;
+/* L100: */
+ }
+
+/* Compute stopping value */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ work[i__] = a[i__2].r;
+/* L110: */
+ }
+ pvt = dmaxloc_(&work[1], n);
+ i__1 = pvt + pvt * a_dim1;
+ ajj = a[i__1].r;
+ if (ajj == 0. || disnan_(&ajj)) {
+ *rank = 0;
+ *info = 1;
+ goto L200;
+ }
+
+/* Compute stopping value if not supplied */
+
+ if (*tol < 0.) {
+ dstop = *n * dlamch_("Epsilon") * ajj;
+ } else {
+ dstop = *tol;
+ }
+
+/* Set first half of WORK to zero, holds dot products */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = 0.;
+/* L120: */
+ }
+
+ if (upper) {
+
+/* Compute the Cholesky factorization P' * A * P = U' * U */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Find pivot, test for exit, else swap rows and columns */
+/* Update dot products, compute possible pivots which are */
+/* stored in the second half of WORK */
+
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+
+ if (j > 1) {
+ d_cnjg(&z__2, &a[j - 1 + i__ * a_dim1]);
+ i__3 = j - 1 + i__ * a_dim1;
+ z__1.r = z__2.r * a[i__3].r - z__2.i * a[i__3].i, z__1.i =
+ z__2.r * a[i__3].i + z__2.i * a[i__3].r;
+ work[i__] += z__1.r;
+ }
+ i__3 = i__ + i__ * a_dim1;
+ work[*n + i__] = a[i__3].r - work[i__];
+
+/* L130: */
+ }
+
+ if (j > 1) {
+ maxlocval = (*n << 1) - (*n + j) + 1;
+ itemp = dmaxloc_(&work[*n + j], &maxlocval);
+ pvt = itemp + j - 1;
+ ajj = work[*n + pvt];
+ if (ajj <= dstop || disnan_(&ajj)) {
+ i__2 = j + j * a_dim1;
+ a[i__2].r = ajj, a[i__2].i = 0.;
+ goto L190;
+ }
+ }
+
+ if (j != pvt) {
+
+/* Pivot OK, so can now swap pivot rows and columns */
+
+ i__2 = pvt + pvt * a_dim1;
+ i__3 = j + j * a_dim1;
+ a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
+ i__2 = j - 1;
+ zswap_(&i__2, &a[j * a_dim1 + 1], &c__1, &a[pvt * a_dim1 + 1],
+ &c__1);
+ if (pvt < *n) {
+ i__2 = *n - pvt;
+ zswap_(&i__2, &a[j + (pvt + 1) * a_dim1], lda, &a[pvt + (
+ pvt + 1) * a_dim1], lda);
+ }
+ i__2 = pvt - 1;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ d_cnjg(&z__1, &a[j + i__ * a_dim1]);
+ ztemp.r = z__1.r, ztemp.i = z__1.i;
+ i__3 = j + i__ * a_dim1;
+ d_cnjg(&z__1, &a[i__ + pvt * a_dim1]);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ i__3 = i__ + pvt * a_dim1;
+ a[i__3].r = ztemp.r, a[i__3].i = ztemp.i;
+/* L140: */
+ }
+ i__2 = j + pvt * a_dim1;
+ d_cnjg(&z__1, &a[j + pvt * a_dim1]);
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+
+/* Swap dot products and PIV */
+
+ dtemp = work[j];
+ work[j] = work[pvt];
+ work[pvt] = dtemp;
+ itemp = piv[pvt];
+ piv[pvt] = piv[j];
+ piv[j] = itemp;
+ }
+
+ ajj = sqrt(ajj);
+ i__2 = j + j * a_dim1;
+ a[i__2].r = ajj, a[i__2].i = 0.;
+
+/* Compute elements J+1:N of row J */
+
+ if (j < *n) {
+ i__2 = j - 1;
+ zlacgv_(&i__2, &a[j * a_dim1 + 1], &c__1);
+ i__2 = j - 1;
+ i__3 = *n - j;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Trans", &i__2, &i__3, &z__1, &a[(j + 1) * a_dim1 + 1],
+ lda, &a[j * a_dim1 + 1], &c__1, &c_b1, &a[j + (j + 1)
+ * a_dim1], lda);
+ i__2 = j - 1;
+ zlacgv_(&i__2, &a[j * a_dim1 + 1], &c__1);
+ i__2 = *n - j;
+ d__1 = 1. / ajj;
+ zdscal_(&i__2, &d__1, &a[j + (j + 1) * a_dim1], lda);
+ }
+
+/* L150: */
+ }
+
+ } else {
+
+/* Compute the Cholesky factorization P' * A * P = L * L' */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Find pivot, test for exit, else swap rows and columns */
+/* Update dot products, compute possible pivots which are */
+/* stored in the second half of WORK */
+
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+
+ if (j > 1) {
+ d_cnjg(&z__2, &a[i__ + (j - 1) * a_dim1]);
+ i__3 = i__ + (j - 1) * a_dim1;
+ z__1.r = z__2.r * a[i__3].r - z__2.i * a[i__3].i, z__1.i =
+ z__2.r * a[i__3].i + z__2.i * a[i__3].r;
+ work[i__] += z__1.r;
+ }
+ i__3 = i__ + i__ * a_dim1;
+ work[*n + i__] = a[i__3].r - work[i__];
+
+/* L160: */
+ }
+
+ if (j > 1) {
+ maxlocval = (*n << 1) - (*n + j) + 1;
+ itemp = dmaxloc_(&work[*n + j], &maxlocval);
+ pvt = itemp + j - 1;
+ ajj = work[*n + pvt];
+ if (ajj <= dstop || disnan_(&ajj)) {
+ i__2 = j + j * a_dim1;
+ a[i__2].r = ajj, a[i__2].i = 0.;
+ goto L190;
+ }
+ }
+
+ if (j != pvt) {
+
+/* Pivot OK, so can now swap pivot rows and columns */
+
+ i__2 = pvt + pvt * a_dim1;
+ i__3 = j + j * a_dim1;
+ a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
+ i__2 = j - 1;
+ zswap_(&i__2, &a[j + a_dim1], lda, &a[pvt + a_dim1], lda);
+ if (pvt < *n) {
+ i__2 = *n - pvt;
+ zswap_(&i__2, &a[pvt + 1 + j * a_dim1], &c__1, &a[pvt + 1
+ + pvt * a_dim1], &c__1);
+ }
+ i__2 = pvt - 1;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ d_cnjg(&z__1, &a[i__ + j * a_dim1]);
+ ztemp.r = z__1.r, ztemp.i = z__1.i;
+ i__3 = i__ + j * a_dim1;
+ d_cnjg(&z__1, &a[pvt + i__ * a_dim1]);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ i__3 = pvt + i__ * a_dim1;
+ a[i__3].r = ztemp.r, a[i__3].i = ztemp.i;
+/* L170: */
+ }
+ i__2 = pvt + j * a_dim1;
+ d_cnjg(&z__1, &a[pvt + j * a_dim1]);
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+
+/* Swap dot products and PIV */
+
+ dtemp = work[j];
+ work[j] = work[pvt];
+ work[pvt] = dtemp;
+ itemp = piv[pvt];
+ piv[pvt] = piv[j];
+ piv[j] = itemp;
+ }
+
+ ajj = sqrt(ajj);
+ i__2 = j + j * a_dim1;
+ a[i__2].r = ajj, a[i__2].i = 0.;
+
+/* Compute elements J+1:N of column J */
+
+ if (j < *n) {
+ i__2 = j - 1;
+ zlacgv_(&i__2, &a[j + a_dim1], lda);
+ i__2 = *n - j;
+ i__3 = j - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No Trans", &i__2, &i__3, &z__1, &a[j + 1 + a_dim1],
+ lda, &a[j + a_dim1], lda, &c_b1, &a[j + 1 + j *
+ a_dim1], &c__1);
+ i__2 = j - 1;
+ zlacgv_(&i__2, &a[j + a_dim1], lda);
+ i__2 = *n - j;
+ d__1 = 1. / ajj;
+ zdscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1);
+ }
+
+/* L180: */
+ }
+
+ }
+
+/* Ran to completion, A has full rank */
+
+ *rank = *n;
+
+ goto L200;
+L190:
+
+/* Rank is number of steps completed. Set INFO = 1 to signal */
+/* that the factorization cannot be used to solve a system. */
+
+ *rank = j - 1;
+ *info = 1;
+
+L200:
+ return 0;
+
+/* End of ZPSTF2 */
+
+} /* zpstf2_ */
diff --git a/SRC/zpstrf.c b/SRC/zpstrf.c
new file mode 100644
index 0000000..ed1c778
--- /dev/null
+++ b/SRC/zpstrf.c
@@ -0,0 +1,529 @@
+/* zpstrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b29 = -1.;
+static doublereal c_b30 = 1.;
+
+/* Subroutine */ int zpstrf_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *piv, integer *rank, doublereal *tol,
+ doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, maxlocval, jb, nb;
+ doublereal ajj;
+ integer pvt;
+ extern logical lsame_(char *, char *);
+ doublereal dtemp;
+ integer itemp;
+ extern /* Subroutine */ int zherk_(char *, char *, integer *, integer *,
+ doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *), zgemv_(char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ doublereal dstop;
+ logical upper;
+ doublecomplex ztemp;
+ extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zpstf2_(char *, integer *, doublecomplex *,
+ integer *, integer *, integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical disnan_(doublereal *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *), zlacgv_(integer *, doublecomplex *,
+ integer *);
+ extern integer dmaxloc_(doublereal *, integer *);
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+
+/* -- Contributed by Craig Lucas, University of Manchester / NAG Ltd. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPSTRF computes the Cholesky factorization with complete */
+/* pivoting of a complex Hermitian positive semidefinite matrix A. */
+
+/* The factorization has the form */
+/* P' * A * P = U' * U , if UPLO = 'U', */
+/* P' * A * P = L * L', if UPLO = 'L', */
+/* where U is an upper triangular matrix and L is lower triangular, and */
+/* P is stored as vector PIV. */
+
+/* This algorithm does not attempt to check that A is positive */
+/* semidefinite. This version of the algorithm calls level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n by n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n by n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the factor U or L from the Cholesky */
+/* factorization as above. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* PIV (output) INTEGER array, dimension (N) */
+/* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. */
+
+/* RANK (output) INTEGER */
+/* The rank of A given by the number of steps the algorithm */
+/* completed. */
+
+/* TOL (input) DOUBLE PRECISION */
+/* User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) ) */
+/* will be used. The algorithm terminates at the (K-1)st step */
+/* if the pivot <= TOL. */
+
+/* WORK DOUBLE PRECISION array, dimension (2*N) */
+/* Work space. */
+
+/* INFO (output) INTEGER */
+/* < 0: If INFO = -K, the K-th argument had an illegal value, */
+/* = 0: algorithm completed successfully, and */
+/* > 0: the matrix A is either rank deficient with computed rank */
+/* as returned in RANK, or is indefinite. See Section 7 of */
+/* LAPACK Working Note #161 for further information. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --work;
+ --piv;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPSTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get block size */
+
+ nb = ilaenv_(&c__1, "ZPOTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code */
+
+ zpstf2_(uplo, n, &a[a_dim1 + 1], lda, &piv[1], rank, tol, &work[1],
+ info);
+ goto L230;
+
+ } else {
+
+/* Initialize PIV */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ piv[i__] = i__;
+/* L100: */
+ }
+
+/* Compute stopping value */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ work[i__] = a[i__2].r;
+/* L110: */
+ }
+ pvt = dmaxloc_(&work[1], n);
+ i__1 = pvt + pvt * a_dim1;
+ ajj = a[i__1].r;
+ if (ajj == 0. || disnan_(&ajj)) {
+ *rank = 0;
+ *info = 1;
+ goto L230;
+ }
+
+/* Compute stopping value if not supplied */
+
+ if (*tol < 0.) {
+ dstop = *n * dlamch_("Epsilon") * ajj;
+ } else {
+ dstop = *tol;
+ }
+
+
+ if (upper) {
+
+/* Compute the Cholesky factorization P' * A * P = U' * U */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+
+/* Account for last block not being NB wide */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - k + 1;
+ jb = min(i__3,i__4);
+
+/* Set relevant part of first half of WORK to zero, */
+/* holds dot products */
+
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ work[i__] = 0.;
+/* L120: */
+ }
+
+ i__3 = k + jb - 1;
+ for (j = k; j <= i__3; ++j) {
+
+/* Find pivot, test for exit, else swap rows and columns */
+/* Update dot products, compute possible pivots which are */
+/* stored in the second half of WORK */
+
+ i__4 = *n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+
+ if (j > k) {
+ d_cnjg(&z__2, &a[j - 1 + i__ * a_dim1]);
+ i__5 = j - 1 + i__ * a_dim1;
+ z__1.r = z__2.r * a[i__5].r - z__2.i * a[i__5].i,
+ z__1.i = z__2.r * a[i__5].i + z__2.i * a[
+ i__5].r;
+ work[i__] += z__1.r;
+ }
+ i__5 = i__ + i__ * a_dim1;
+ work[*n + i__] = a[i__5].r - work[i__];
+
+/* L130: */
+ }
+
+ if (j > 1) {
+ maxlocval = (*n << 1) - (*n + j) + 1;
+ itemp = dmaxloc_(&work[*n + j], &maxlocval);
+ pvt = itemp + j - 1;
+ ajj = work[*n + pvt];
+ if (ajj <= dstop || disnan_(&ajj)) {
+ i__4 = j + j * a_dim1;
+ a[i__4].r = ajj, a[i__4].i = 0.;
+ goto L220;
+ }
+ }
+
+ if (j != pvt) {
+
+/* Pivot OK, so can now swap pivot rows and columns */
+
+ i__4 = pvt + pvt * a_dim1;
+ i__5 = j + j * a_dim1;
+ a[i__4].r = a[i__5].r, a[i__4].i = a[i__5].i;
+ i__4 = j - 1;
+ zswap_(&i__4, &a[j * a_dim1 + 1], &c__1, &a[pvt *
+ a_dim1 + 1], &c__1);
+ if (pvt < *n) {
+ i__4 = *n - pvt;
+ zswap_(&i__4, &a[j + (pvt + 1) * a_dim1], lda, &a[
+ pvt + (pvt + 1) * a_dim1], lda);
+ }
+ i__4 = pvt - 1;
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ d_cnjg(&z__1, &a[j + i__ * a_dim1]);
+ ztemp.r = z__1.r, ztemp.i = z__1.i;
+ i__5 = j + i__ * a_dim1;
+ d_cnjg(&z__1, &a[i__ + pvt * a_dim1]);
+ a[i__5].r = z__1.r, a[i__5].i = z__1.i;
+ i__5 = i__ + pvt * a_dim1;
+ a[i__5].r = ztemp.r, a[i__5].i = ztemp.i;
+/* L140: */
+ }
+ i__4 = j + pvt * a_dim1;
+ d_cnjg(&z__1, &a[j + pvt * a_dim1]);
+ a[i__4].r = z__1.r, a[i__4].i = z__1.i;
+
+/* Swap dot products and PIV */
+
+ dtemp = work[j];
+ work[j] = work[pvt];
+ work[pvt] = dtemp;
+ itemp = piv[pvt];
+ piv[pvt] = piv[j];
+ piv[j] = itemp;
+ }
+
+ ajj = sqrt(ajj);
+ i__4 = j + j * a_dim1;
+ a[i__4].r = ajj, a[i__4].i = 0.;
+
+/* Compute elements J+1:N of row J. */
+
+ if (j < *n) {
+ i__4 = j - 1;
+ zlacgv_(&i__4, &a[j * a_dim1 + 1], &c__1);
+ i__4 = j - k;
+ i__5 = *n - j;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Trans", &i__4, &i__5, &z__1, &a[k + (j + 1) *
+ a_dim1], lda, &a[k + j * a_dim1], &c__1, &
+ c_b1, &a[j + (j + 1) * a_dim1], lda);
+ i__4 = j - 1;
+ zlacgv_(&i__4, &a[j * a_dim1 + 1], &c__1);
+ i__4 = *n - j;
+ d__1 = 1. / ajj;
+ zdscal_(&i__4, &d__1, &a[j + (j + 1) * a_dim1], lda);
+ }
+
+/* L150: */
+ }
+
+/* Update trailing matrix, J already incremented */
+
+ if (k + jb <= *n) {
+ i__3 = *n - j + 1;
+ zherk_("Upper", "Conj Trans", &i__3, &jb, &c_b29, &a[k +
+ j * a_dim1], lda, &c_b30, &a[j + j * a_dim1], lda);
+ }
+
+/* L160: */
+ }
+
+ } else {
+
+/* Compute the Cholesky factorization P' * A * P = L * L' */
+
+ i__2 = *n;
+ i__1 = nb;
+ for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+
+/* Account for last block not being NB wide */
+
+/* Computing MIN */
+ i__3 = nb, i__4 = *n - k + 1;
+ jb = min(i__3,i__4);
+
+/* Set relevant part of first half of WORK to zero, */
+/* holds dot products */
+
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ work[i__] = 0.;
+/* L170: */
+ }
+
+ i__3 = k + jb - 1;
+ for (j = k; j <= i__3; ++j) {
+
+/* Find pivot, test for exit, else swap rows and columns */
+/* Update dot products, compute possible pivots which are */
+/* stored in the second half of WORK */
+
+ i__4 = *n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+
+ if (j > k) {
+ d_cnjg(&z__2, &a[i__ + (j - 1) * a_dim1]);
+ i__5 = i__ + (j - 1) * a_dim1;
+ z__1.r = z__2.r * a[i__5].r - z__2.i * a[i__5].i,
+ z__1.i = z__2.r * a[i__5].i + z__2.i * a[
+ i__5].r;
+ work[i__] += z__1.r;
+ }
+ i__5 = i__ + i__ * a_dim1;
+ work[*n + i__] = a[i__5].r - work[i__];
+
+/* L180: */
+ }
+
+ if (j > 1) {
+ maxlocval = (*n << 1) - (*n + j) + 1;
+ itemp = dmaxloc_(&work[*n + j], &maxlocval);
+ pvt = itemp + j - 1;
+ ajj = work[*n + pvt];
+ if (ajj <= dstop || disnan_(&ajj)) {
+ i__4 = j + j * a_dim1;
+ a[i__4].r = ajj, a[i__4].i = 0.;
+ goto L220;
+ }
+ }
+
+ if (j != pvt) {
+
+/* Pivot OK, so can now swap pivot rows and columns */
+
+ i__4 = pvt + pvt * a_dim1;
+ i__5 = j + j * a_dim1;
+ a[i__4].r = a[i__5].r, a[i__4].i = a[i__5].i;
+ i__4 = j - 1;
+ zswap_(&i__4, &a[j + a_dim1], lda, &a[pvt + a_dim1],
+ lda);
+ if (pvt < *n) {
+ i__4 = *n - pvt;
+ zswap_(&i__4, &a[pvt + 1 + j * a_dim1], &c__1, &a[
+ pvt + 1 + pvt * a_dim1], &c__1);
+ }
+ i__4 = pvt - 1;
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ d_cnjg(&z__1, &a[i__ + j * a_dim1]);
+ ztemp.r = z__1.r, ztemp.i = z__1.i;
+ i__5 = i__ + j * a_dim1;
+ d_cnjg(&z__1, &a[pvt + i__ * a_dim1]);
+ a[i__5].r = z__1.r, a[i__5].i = z__1.i;
+ i__5 = pvt + i__ * a_dim1;
+ a[i__5].r = ztemp.r, a[i__5].i = ztemp.i;
+/* L190: */
+ }
+ i__4 = pvt + j * a_dim1;
+ d_cnjg(&z__1, &a[pvt + j * a_dim1]);
+ a[i__4].r = z__1.r, a[i__4].i = z__1.i;
+
+
+/* Swap dot products and PIV */
+
+ dtemp = work[j];
+ work[j] = work[pvt];
+ work[pvt] = dtemp;
+ itemp = piv[pvt];
+ piv[pvt] = piv[j];
+ piv[j] = itemp;
+ }
+
+ ajj = sqrt(ajj);
+ i__4 = j + j * a_dim1;
+ a[i__4].r = ajj, a[i__4].i = 0.;
+
+/* Compute elements J+1:N of column J. */
+
+ if (j < *n) {
+ i__4 = j - 1;
+ zlacgv_(&i__4, &a[j + a_dim1], lda);
+ i__4 = *n - j;
+ i__5 = j - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("No Trans", &i__4, &i__5, &z__1, &a[j + 1 + k *
+ a_dim1], lda, &a[j + k * a_dim1], lda, &c_b1,
+ &a[j + 1 + j * a_dim1], &c__1);
+ i__4 = j - 1;
+ zlacgv_(&i__4, &a[j + a_dim1], lda);
+ i__4 = *n - j;
+ d__1 = 1. / ajj;
+ zdscal_(&i__4, &d__1, &a[j + 1 + j * a_dim1], &c__1);
+ }
+
+/* L200: */
+ }
+
+/* Update trailing matrix, J already incremented */
+
+ if (k + jb <= *n) {
+ i__3 = *n - j + 1;
+ zherk_("Lower", "No Trans", &i__3, &jb, &c_b29, &a[j + k *
+ a_dim1], lda, &c_b30, &a[j + j * a_dim1], lda);
+ }
+
+/* L210: */
+ }
+
+ }
+ }
+
+/* Ran to completion, A has full rank */
+
+ *rank = *n;
+
+ goto L230;
+L220:
+
+/* Rank is the number of steps completed. Set INFO = 1 to signal */
+/* that the factorization cannot be used to solve a system. */
+
+ *rank = j - 1;
+ *info = 1;
+
+L230:
+ return 0;
+
+/* End of ZPSTRF */
+
+} /* zpstrf_ */
diff --git a/SRC/zptcon.c b/SRC/zptcon.c
new file mode 100644
index 0000000..3e8971c
--- /dev/null
+++ b/SRC/zptcon.c
@@ -0,0 +1,187 @@
+/* zptcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zptcon_(integer *n, doublereal *d__, doublecomplex *e,
+ doublereal *anorm, doublereal *rcond, doublereal *rwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+
+ /* Local variables */
+ integer i__, ix;
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal ainvnm;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPTCON computes the reciprocal of the condition number (in the */
+/* 1-norm) of a complex Hermitian positive definite tridiagonal matrix */
+/* using the factorization A = L*D*L**H or A = U**H*D*U computed by */
+/* ZPTTRF. */
+
+/* Norm(inv(A)) is computed by a direct method, and the reciprocal of */
+/* the condition number is computed as */
+/* RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the diagonal matrix D from the */
+/* factorization of A, as computed by ZPTTRF. */
+
+/* E (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) off-diagonal elements of the unit bidiagonal factor */
+/* U or L from the factorization of A, as computed by ZPTTRF. */
+
+/* ANORM (input) DOUBLE PRECISION */
+/* The 1-norm of the original matrix A. */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the */
+/* 1-norm of inv(A) computed in this routine. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The method used is described in Nicholas J. Higham, "Efficient */
+/* Algorithms for Computing the Condition Number of a Tridiagonal */
+/* Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --e;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*anorm < 0.) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPTCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.;
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ } else if (*anorm == 0.) {
+ return 0;
+ }
+
+/* Check that D(1:N) is positive. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (d__[i__] <= 0.) {
+ return 0;
+ }
+/* L10: */
+ }
+
+/* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by */
+
+/* m(i,j) = abs(A(i,j)), i = j, */
+/* m(i,j) = -abs(A(i,j)), i .ne. j, */
+
+/* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'. */
+
+/* Solve M(L) * x = e. */
+
+ rwork[1] = 1.;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ rwork[i__] = rwork[i__ - 1] * z_abs(&e[i__ - 1]) + 1.;
+/* L20: */
+ }
+
+/* Solve D * M(L)' * x = b. */
+
+ rwork[*n] /= d__[*n];
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ rwork[i__] = rwork[i__] / d__[i__] + rwork[i__ + 1] * z_abs(&e[i__]);
+/* L30: */
+ }
+
+/* Compute AINVNM = max(x(i)), 1<=i<=n. */
+
+ ix = idamax_(n, &rwork[1], &c__1);
+ ainvnm = (d__1 = rwork[ix], abs(d__1));
+
+/* Compute the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / ainvnm / *anorm;
+ }
+
+ return 0;
+
+/* End of ZPTCON */
+
+} /* zptcon_ */
diff --git a/SRC/zpteqr.c b/SRC/zpteqr.c
new file mode 100644
index 0000000..95584cf
--- /dev/null
+++ b/SRC/zpteqr.c
@@ -0,0 +1,243 @@
+/* zpteqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int zpteqr_(char *compz, integer *n, doublereal *d__,
+ doublereal *e, doublecomplex *z__, integer *ldz, doublereal *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublecomplex c__[1] /* was [1][1] */;
+ integer i__;
+ doublecomplex vt[1] /* was [1][1] */;
+ integer nru;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer icompz;
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), dpttrf_(integer *, doublereal *, doublereal *, integer *)
+ , zbdsqr_(char *, integer *, integer *, integer *, integer *,
+ doublereal *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPTEQR computes all eigenvalues and, optionally, eigenvectors of a */
+/* symmetric positive definite tridiagonal matrix by first factoring the */
+/* matrix using DPTTRF and then calling ZBDSQR to compute the singular */
+/* values of the bidiagonal factor. */
+
+/* This routine computes the eigenvalues of the positive definite */
+/* tridiagonal matrix to high relative accuracy. This means that if the */
+/* eigenvalues range over many orders of magnitude in size, then the */
+/* small eigenvalues and corresponding eigenvectors will be computed */
+/* more accurately than, for example, with the standard QR method. */
+
+/* The eigenvectors of a full or band positive definite Hermitian matrix */
+/* can also be found if ZHETRD, ZHPTRD, or ZHBTRD has been used to */
+/* reduce this matrix to tridiagonal form. (The reduction to */
+/* tridiagonal form, however, may preclude the possibility of obtaining */
+/* high relative accuracy in the small eigenvalues of the original */
+/* matrix, if these eigenvalues range over many orders of magnitude.) */
+
+/* Arguments */
+/* ========= */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only. */
+/* = 'V': Compute eigenvectors of original Hermitian */
+/* matrix also. Array Z contains the unitary matrix */
+/* used to reduce the original matrix to tridiagonal */
+/* form. */
+/* = 'I': Compute eigenvectors of tridiagonal matrix also. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the n diagonal elements of the tridiagonal matrix. */
+/* On normal exit, D contains the eigenvalues, in descending */
+/* order. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix. */
+/* On exit, E has been destroyed. */
+
+/* Z (input/output) COMPLEX*16 array, dimension (LDZ, N) */
+/* On entry, if COMPZ = 'V', the unitary matrix used in the */
+/* reduction to tridiagonal form. */
+/* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the */
+/* original Hermitian matrix; */
+/* if COMPZ = 'I', the orthonormal eigenvectors of the */
+/* tridiagonal matrix. */
+/* If INFO > 0 on exit, Z contains the eigenvectors associated */
+/* with only the stored eigenvalues. */
+/* If COMPZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* COMPZ = 'V' or 'I', LDZ >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: if INFO = i, and i is: */
+/* <= N the Cholesky factorization of the matrix could */
+/* not be performed because the i-th principal minor */
+/* was not positive definite. */
+/* > N the SVD algorithm failed to converge; */
+/* if INFO = N+i, i off-diagonal elements of the */
+/* bidiagonal factor did not converge to zero. */
+
+/* ==================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+ if (lsame_(compz, "N")) {
+ icompz = 0;
+ } else if (lsame_(compz, "V")) {
+ icompz = 1;
+ } else if (lsame_(compz, "I")) {
+ icompz = 2;
+ } else {
+ icompz = -1;
+ }
+ if (icompz < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPTEQR", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (icompz > 0) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1., z__[i__1].i = 0.;
+ }
+ return 0;
+ }
+ if (icompz == 2) {
+ zlaset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
+ }
+
+/* Call DPTTRF to factor the matrix. */
+
+ dpttrf_(n, &d__[1], &e[1], info);
+ if (*info != 0) {
+ return 0;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = sqrt(d__[i__]);
+/* L10: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ e[i__] *= d__[i__];
+/* L20: */
+ }
+
+/* Call ZBDSQR to compute the singular values/vectors of the */
+/* bidiagonal factor. */
+
+ if (icompz > 0) {
+ nru = *n;
+ } else {
+ nru = 0;
+ }
+ zbdsqr_("Lower", n, &c__0, &nru, &c__0, &d__[1], &e[1], vt, &c__1, &z__[
+ z_offset], ldz, c__, &c__1, &work[1], info);
+
+/* Square the singular values. */
+
+ if (*info == 0) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] *= d__[i__];
+/* L30: */
+ }
+ } else {
+ *info = *n + *info;
+ }
+
+ return 0;
+
+/* End of ZPTEQR */
+
+} /* zpteqr_ */
diff --git a/SRC/zptrfs.c b/SRC/zptrfs.c
new file mode 100644
index 0000000..b57ae48
--- /dev/null
+++ b/SRC/zptrfs.c
@@ -0,0 +1,576 @@
+/* zptrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublecomplex c_b16 = {1.,0.};
+
+/* Subroutine */ int zptrfs_(char *uplo, integer *n, integer *nrhs,
+ doublereal *d__, doublecomplex *e, doublereal *df, doublecomplex *ef,
+ doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
+ doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *
+ rwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
+ d__11, d__12;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ double z_abs(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal s;
+ doublecomplex bi, cx, dx, ex;
+ integer ix, nz;
+ doublereal eps, safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer count;
+ logical upper;
+ extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal lstres;
+ extern /* Subroutine */ int zpttrs_(char *, integer *, integer *,
+ doublereal *, doublecomplex *, doublecomplex *, integer *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPTRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is Hermitian positive definite */
+/* and tridiagonal, and provides error bounds and backward error */
+/* estimates for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the superdiagonal or the subdiagonal of the */
+/* tridiagonal matrix A is stored and the form of the */
+/* factorization: */
+/* = 'U': E is the superdiagonal of A, and A = U**H*D*U; */
+/* = 'L': E is the subdiagonal of A, and A = L*D*L**H. */
+/* (The two forms are equivalent if A is real.) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n real diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) off-diagonal elements of the tridiagonal matrix A */
+/* (see UPLO). */
+
+/* DF (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the diagonal matrix D from */
+/* the factorization computed by ZPTTRF. */
+
+/* EF (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) off-diagonal elements of the unit bidiagonal */
+/* factor U or L from the factorization computed by ZPTTRF */
+/* (see UPLO). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by ZPTTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --df;
+ --ef;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPTRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = 4;
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X. Also compute */
+/* abs(A)*abs(x) + abs(b) for use in the backward error bound. */
+
+ if (upper) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ bi.r = b[i__2].r, bi.i = b[i__2].i;
+ i__2 = j * x_dim1 + 1;
+ z__1.r = d__[1] * x[i__2].r, z__1.i = d__[1] * x[i__2].i;
+ dx.r = z__1.r, dx.i = z__1.i;
+ z__1.r = bi.r - dx.r, z__1.i = bi.i - dx.i;
+ work[1].r = z__1.r, work[1].i = z__1.i;
+ rwork[1] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&bi),
+ abs(d__2)) + ((d__3 = dx.r, abs(d__3)) + (d__4 =
+ d_imag(&dx), abs(d__4)));
+ } else {
+ i__2 = j * b_dim1 + 1;
+ bi.r = b[i__2].r, bi.i = b[i__2].i;
+ i__2 = j * x_dim1 + 1;
+ z__1.r = d__[1] * x[i__2].r, z__1.i = d__[1] * x[i__2].i;
+ dx.r = z__1.r, dx.i = z__1.i;
+ i__2 = j * x_dim1 + 2;
+ z__1.r = e[1].r * x[i__2].r - e[1].i * x[i__2].i, z__1.i = e[
+ 1].r * x[i__2].i + e[1].i * x[i__2].r;
+ ex.r = z__1.r, ex.i = z__1.i;
+ z__2.r = bi.r - dx.r, z__2.i = bi.i - dx.i;
+ z__1.r = z__2.r - ex.r, z__1.i = z__2.i - ex.i;
+ work[1].r = z__1.r, work[1].i = z__1.i;
+ i__2 = j * x_dim1 + 2;
+ rwork[1] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&bi),
+ abs(d__2)) + ((d__3 = dx.r, abs(d__3)) + (d__4 =
+ d_imag(&dx), abs(d__4))) + ((d__5 = e[1].r, abs(d__5))
+ + (d__6 = d_imag(&e[1]), abs(d__6))) * ((d__7 = x[
+ i__2].r, abs(d__7)) + (d__8 = d_imag(&x[j * x_dim1 +
+ 2]), abs(d__8)));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ bi.r = b[i__3].r, bi.i = b[i__3].i;
+ d_cnjg(&z__2, &e[i__ - 1]);
+ i__3 = i__ - 1 + j * x_dim1;
+ z__1.r = z__2.r * x[i__3].r - z__2.i * x[i__3].i, z__1.i =
+ z__2.r * x[i__3].i + z__2.i * x[i__3].r;
+ cx.r = z__1.r, cx.i = z__1.i;
+ i__3 = i__;
+ i__4 = i__ + j * x_dim1;
+ z__1.r = d__[i__3] * x[i__4].r, z__1.i = d__[i__3] * x[
+ i__4].i;
+ dx.r = z__1.r, dx.i = z__1.i;
+ i__3 = i__;
+ i__4 = i__ + 1 + j * x_dim1;
+ z__1.r = e[i__3].r * x[i__4].r - e[i__3].i * x[i__4].i,
+ z__1.i = e[i__3].r * x[i__4].i + e[i__3].i * x[
+ i__4].r;
+ ex.r = z__1.r, ex.i = z__1.i;
+ i__3 = i__;
+ z__3.r = bi.r - cx.r, z__3.i = bi.i - cx.i;
+ z__2.r = z__3.r - dx.r, z__2.i = z__3.i - dx.i;
+ z__1.r = z__2.r - ex.r, z__1.i = z__2.i - ex.i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ i__3 = i__ - 1;
+ i__4 = i__ - 1 + j * x_dim1;
+ i__5 = i__;
+ i__6 = i__ + 1 + j * x_dim1;
+ rwork[i__] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&
+ bi), abs(d__2)) + ((d__3 = e[i__3].r, abs(d__3))
+ + (d__4 = d_imag(&e[i__ - 1]), abs(d__4))) * ((
+ d__5 = x[i__4].r, abs(d__5)) + (d__6 = d_imag(&x[
+ i__ - 1 + j * x_dim1]), abs(d__6))) + ((d__7 =
+ dx.r, abs(d__7)) + (d__8 = d_imag(&dx), abs(d__8))
+ ) + ((d__9 = e[i__5].r, abs(d__9)) + (d__10 =
+ d_imag(&e[i__]), abs(d__10))) * ((d__11 = x[i__6]
+ .r, abs(d__11)) + (d__12 = d_imag(&x[i__ + 1 + j *
+ x_dim1]), abs(d__12)));
+/* L30: */
+ }
+ i__2 = *n + j * b_dim1;
+ bi.r = b[i__2].r, bi.i = b[i__2].i;
+ d_cnjg(&z__2, &e[*n - 1]);
+ i__2 = *n - 1 + j * x_dim1;
+ z__1.r = z__2.r * x[i__2].r - z__2.i * x[i__2].i, z__1.i =
+ z__2.r * x[i__2].i + z__2.i * x[i__2].r;
+ cx.r = z__1.r, cx.i = z__1.i;
+ i__2 = *n;
+ i__3 = *n + j * x_dim1;
+ z__1.r = d__[i__2] * x[i__3].r, z__1.i = d__[i__2] * x[i__3]
+ .i;
+ dx.r = z__1.r, dx.i = z__1.i;
+ i__2 = *n;
+ z__2.r = bi.r - cx.r, z__2.i = bi.i - cx.i;
+ z__1.r = z__2.r - dx.r, z__1.i = z__2.i - dx.i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ i__2 = *n - 1;
+ i__3 = *n - 1 + j * x_dim1;
+ rwork[*n] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&bi),
+ abs(d__2)) + ((d__3 = e[i__2].r, abs(d__3)) + (d__4 =
+ d_imag(&e[*n - 1]), abs(d__4))) * ((d__5 = x[i__3].r,
+ abs(d__5)) + (d__6 = d_imag(&x[*n - 1 + j * x_dim1]),
+ abs(d__6))) + ((d__7 = dx.r, abs(d__7)) + (d__8 =
+ d_imag(&dx), abs(d__8)));
+ }
+ } else {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ bi.r = b[i__2].r, bi.i = b[i__2].i;
+ i__2 = j * x_dim1 + 1;
+ z__1.r = d__[1] * x[i__2].r, z__1.i = d__[1] * x[i__2].i;
+ dx.r = z__1.r, dx.i = z__1.i;
+ z__1.r = bi.r - dx.r, z__1.i = bi.i - dx.i;
+ work[1].r = z__1.r, work[1].i = z__1.i;
+ rwork[1] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&bi),
+ abs(d__2)) + ((d__3 = dx.r, abs(d__3)) + (d__4 =
+ d_imag(&dx), abs(d__4)));
+ } else {
+ i__2 = j * b_dim1 + 1;
+ bi.r = b[i__2].r, bi.i = b[i__2].i;
+ i__2 = j * x_dim1 + 1;
+ z__1.r = d__[1] * x[i__2].r, z__1.i = d__[1] * x[i__2].i;
+ dx.r = z__1.r, dx.i = z__1.i;
+ d_cnjg(&z__2, &e[1]);
+ i__2 = j * x_dim1 + 2;
+ z__1.r = z__2.r * x[i__2].r - z__2.i * x[i__2].i, z__1.i =
+ z__2.r * x[i__2].i + z__2.i * x[i__2].r;
+ ex.r = z__1.r, ex.i = z__1.i;
+ z__2.r = bi.r - dx.r, z__2.i = bi.i - dx.i;
+ z__1.r = z__2.r - ex.r, z__1.i = z__2.i - ex.i;
+ work[1].r = z__1.r, work[1].i = z__1.i;
+ i__2 = j * x_dim1 + 2;
+ rwork[1] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&bi),
+ abs(d__2)) + ((d__3 = dx.r, abs(d__3)) + (d__4 =
+ d_imag(&dx), abs(d__4))) + ((d__5 = e[1].r, abs(d__5))
+ + (d__6 = d_imag(&e[1]), abs(d__6))) * ((d__7 = x[
+ i__2].r, abs(d__7)) + (d__8 = d_imag(&x[j * x_dim1 +
+ 2]), abs(d__8)));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ bi.r = b[i__3].r, bi.i = b[i__3].i;
+ i__3 = i__ - 1;
+ i__4 = i__ - 1 + j * x_dim1;
+ z__1.r = e[i__3].r * x[i__4].r - e[i__3].i * x[i__4].i,
+ z__1.i = e[i__3].r * x[i__4].i + e[i__3].i * x[
+ i__4].r;
+ cx.r = z__1.r, cx.i = z__1.i;
+ i__3 = i__;
+ i__4 = i__ + j * x_dim1;
+ z__1.r = d__[i__3] * x[i__4].r, z__1.i = d__[i__3] * x[
+ i__4].i;
+ dx.r = z__1.r, dx.i = z__1.i;
+ d_cnjg(&z__2, &e[i__]);
+ i__3 = i__ + 1 + j * x_dim1;
+ z__1.r = z__2.r * x[i__3].r - z__2.i * x[i__3].i, z__1.i =
+ z__2.r * x[i__3].i + z__2.i * x[i__3].r;
+ ex.r = z__1.r, ex.i = z__1.i;
+ i__3 = i__;
+ z__3.r = bi.r - cx.r, z__3.i = bi.i - cx.i;
+ z__2.r = z__3.r - dx.r, z__2.i = z__3.i - dx.i;
+ z__1.r = z__2.r - ex.r, z__1.i = z__2.i - ex.i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ i__3 = i__ - 1;
+ i__4 = i__ - 1 + j * x_dim1;
+ i__5 = i__;
+ i__6 = i__ + 1 + j * x_dim1;
+ rwork[i__] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&
+ bi), abs(d__2)) + ((d__3 = e[i__3].r, abs(d__3))
+ + (d__4 = d_imag(&e[i__ - 1]), abs(d__4))) * ((
+ d__5 = x[i__4].r, abs(d__5)) + (d__6 = d_imag(&x[
+ i__ - 1 + j * x_dim1]), abs(d__6))) + ((d__7 =
+ dx.r, abs(d__7)) + (d__8 = d_imag(&dx), abs(d__8))
+ ) + ((d__9 = e[i__5].r, abs(d__9)) + (d__10 =
+ d_imag(&e[i__]), abs(d__10))) * ((d__11 = x[i__6]
+ .r, abs(d__11)) + (d__12 = d_imag(&x[i__ + 1 + j *
+ x_dim1]), abs(d__12)));
+/* L40: */
+ }
+ i__2 = *n + j * b_dim1;
+ bi.r = b[i__2].r, bi.i = b[i__2].i;
+ i__2 = *n - 1;
+ i__3 = *n - 1 + j * x_dim1;
+ z__1.r = e[i__2].r * x[i__3].r - e[i__2].i * x[i__3].i,
+ z__1.i = e[i__2].r * x[i__3].i + e[i__2].i * x[i__3]
+ .r;
+ cx.r = z__1.r, cx.i = z__1.i;
+ i__2 = *n;
+ i__3 = *n + j * x_dim1;
+ z__1.r = d__[i__2] * x[i__3].r, z__1.i = d__[i__2] * x[i__3]
+ .i;
+ dx.r = z__1.r, dx.i = z__1.i;
+ i__2 = *n;
+ z__2.r = bi.r - cx.r, z__2.i = bi.i - cx.i;
+ z__1.r = z__2.r - dx.r, z__1.i = z__2.i - dx.i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ i__2 = *n - 1;
+ i__3 = *n - 1 + j * x_dim1;
+ rwork[*n] = (d__1 = bi.r, abs(d__1)) + (d__2 = d_imag(&bi),
+ abs(d__2)) + ((d__3 = e[i__2].r, abs(d__3)) + (d__4 =
+ d_imag(&e[*n - 1]), abs(d__4))) * ((d__5 = x[i__3].r,
+ abs(d__5)) + (d__6 = d_imag(&x[*n - 1 + j * x_dim1]),
+ abs(d__6))) + ((d__7 = dx.r, abs(d__7)) + (d__8 =
+ d_imag(&dx), abs(d__8)));
+ }
+ }
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__3 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2))) / rwork[i__];
+ s = max(d__3,d__4);
+ } else {
+/* Computing MAX */
+ i__3 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = max(d__3,d__4);
+ }
+/* L50: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ zpttrs_(uplo, n, &c__1, &df[1], &ef[1], &work[1], n, info);
+ zaxpy_(n, &c_b16, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__3 = i__;
+ rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ ;
+ } else {
+ i__3 = i__;
+ rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ + safe1;
+ }
+/* L60: */
+ }
+ ix = idamax_(n, &rwork[1], &c__1);
+ ferr[j] = rwork[ix];
+
+/* Estimate the norm of inv(A). */
+
+/* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by */
+
+/* m(i,j) = abs(A(i,j)), i = j, */
+/* m(i,j) = -abs(A(i,j)), i .ne. j, */
+
+/* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'. */
+
+/* Solve M(L) * x = e. */
+
+ rwork[1] = 1.;
+ i__2 = *n;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ rwork[i__] = rwork[i__ - 1] * z_abs(&ef[i__ - 1]) + 1.;
+/* L70: */
+ }
+
+/* Solve D * M(L)' * x = b. */
+
+ rwork[*n] /= df[*n];
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ rwork[i__] = rwork[i__] / df[i__] + rwork[i__ + 1] * z_abs(&ef[
+ i__]);
+/* L80: */
+ }
+
+/* Compute norm(inv(A)) = max(x(i)), 1<=i<=n. */
+
+ ix = idamax_(n, &rwork[1], &c__1);
+ ferr[j] *= (d__1 = rwork[ix], abs(d__1));
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = lstres, d__2 = z_abs(&x[i__ + j * x_dim1]);
+ lstres = max(d__1,d__2);
+/* L90: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L100: */
+ }
+
+ return 0;
+
+/* End of ZPTRFS */
+
+} /* zptrfs_ */
diff --git a/SRC/zptsv.c b/SRC/zptsv.c
new file mode 100644
index 0000000..a29ead4
--- /dev/null
+++ b/SRC/zptsv.c
@@ -0,0 +1,130 @@
+/* zptsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zptsv_(integer *n, integer *nrhs, doublereal *d__,
+ doublecomplex *e, doublecomplex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int xerbla_(char *, integer *), zpttrf_(
+ integer *, doublereal *, doublecomplex *, integer *), zpttrs_(
+ char *, integer *, integer *, doublereal *, doublecomplex *,
+ doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPTSV computes the solution to a complex system of linear equations */
+/* A*X = B, where A is an N-by-N Hermitian positive definite tridiagonal */
+/* matrix, and X and B are N-by-NRHS matrices. */
+
+/* A is factored as A = L*D*L**H, and the factored form of A is then */
+/* used to solve the system of equations. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the n diagonal elements of the tridiagonal matrix */
+/* A. On exit, the n diagonal elements of the diagonal matrix */
+/* D from the factorization A = L*D*L**H. */
+
+/* E (input/output) COMPLEX*16 array, dimension (N-1) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix A. On exit, the (n-1) subdiagonal elements of the */
+/* unit bidiagonal factor L from the L*D*L**H factorization of */
+/* A. E can also be regarded as the superdiagonal of the unit */
+/* bidiagonal factor U from the U**H*D*U factorization of A. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,N) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the leading minor of order i is not */
+/* positive definite, and the solution has not been */
+/* computed. The factorization has not been completed */
+/* unless i = N. */
+
+/* ===================================================================== */
+
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*ldb < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPTSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the L*D*L' (or U'*D*U) factorization of A. */
+
+ zpttrf_(n, &d__[1], &e[1], info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ zpttrs_("Lower", n, nrhs, &d__[1], &e[1], &b[b_offset], ldb, info);
+ }
+ return 0;
+
+/* End of ZPTSV */
+
+} /* zptsv_ */
diff --git a/SRC/zptsvx.c b/SRC/zptsvx.c
new file mode 100644
index 0000000..47ad812
--- /dev/null
+++ b/SRC/zptsvx.c
@@ -0,0 +1,290 @@
+/* zptsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zptsvx_(char *fact, integer *n, integer *nrhs,
+ doublereal *d__, doublecomplex *e, doublereal *df, doublecomplex *ef,
+ doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
+ doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *
+ work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), zcopy_(integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal zlanht_(char *, integer *, doublereal *, doublecomplex *
+);
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zptcon_(integer *, doublereal *, doublecomplex *, doublereal *,
+ doublereal *, doublereal *, integer *), zptrfs_(char *, integer *,
+ integer *, doublereal *, doublecomplex *, doublereal *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublecomplex *,
+ doublereal *, integer *), zpttrf_(integer *, doublereal *,
+ doublecomplex *, integer *), zpttrs_(char *, integer *, integer *
+, doublereal *, doublecomplex *, doublecomplex *, integer *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPTSVX uses the factorization A = L*D*L**H to compute the solution */
+/* to a complex system of linear equations A*X = B, where A is an */
+/* N-by-N Hermitian positive definite tridiagonal matrix and X and B */
+/* are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**H, where L */
+/* is a unit lower bidiagonal matrix and D is diagonal. The */
+/* factorization can also be regarded as having the form */
+/* A = U**H*D*U. */
+
+/* 2. If the leading i-by-i principal minor is not positive definite, */
+/* then the routine returns with INFO = i. Otherwise, the factored */
+/* form of A is used to estimate the condition number of the matrix */
+/* A. If the reciprocal of the condition number is less than machine */
+/* precision, INFO = N+1 is returned as a warning, but the routine */
+/* still goes on to solve for X and compute error bounds as */
+/* described below. */
+
+/* 3. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 4. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix */
+/* A is supplied on entry. */
+/* = 'F': On entry, DF and EF contain the factored form of A. */
+/* D, E, DF, and EF will not be modified. */
+/* = 'N': The matrix A will be copied to DF and EF and */
+/* factored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
+
+/* DF (input or output) DOUBLE PRECISION array, dimension (N) */
+/* If FACT = 'F', then DF is an input argument and on entry */
+/* contains the n diagonal elements of the diagonal matrix D */
+/* from the L*D*L**H factorization of A. */
+/* If FACT = 'N', then DF is an output argument and on exit */
+/* contains the n diagonal elements of the diagonal matrix D */
+/* from the L*D*L**H factorization of A. */
+
+/* EF (input or output) COMPLEX*16 array, dimension (N-1) */
+/* If FACT = 'F', then EF is an input argument and on entry */
+/* contains the (n-1) subdiagonal elements of the unit */
+/* bidiagonal factor L from the L*D*L**H factorization of A. */
+/* If FACT = 'N', then EF is an output argument and on exit */
+/* contains the (n-1) subdiagonal elements of the unit */
+/* bidiagonal factor L from the L*D*L**H factorization of A. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal condition number of the matrix A. If RCOND */
+/* is less than the machine precision (in particular, if */
+/* RCOND = 0), the matrix is singular to working precision. */
+/* This condition is indicated by a return code of INFO > 0. */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in any */
+/* element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: the leading minor of order i of A is */
+/* not positive definite, so the factorization */
+/* could not be completed, and the solution has not */
+/* been computed. RCOND = 0 is returned. */
+/* = N+1: U is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --df;
+ --ef;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ if (! nofact && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPTSVX", &i__1);
+ return 0;
+ }
+
+ if (nofact) {
+
+/* Compute the L*D*L' (or U'*D*U) factorization of A. */
+
+ dcopy_(n, &d__[1], &c__1, &df[1], &c__1);
+ if (*n > 1) {
+ i__1 = *n - 1;
+ zcopy_(&i__1, &e[1], &c__1, &ef[1], &c__1);
+ }
+ zpttrf_(n, &df[1], &ef[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = zlanht_("1", n, &d__[1], &e[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ zptcon_(n, &df[1], &ef[1], &anorm, rcond, &rwork[1], info);
+
+/* Compute the solution vectors X. */
+
+ zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ zpttrs_("Lower", n, nrhs, &df[1], &ef[1], &x[x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solutions and */
+/* compute error bounds and backward error estimates for them. */
+
+ zptrfs_("Lower", n, nrhs, &d__[1], &e[1], &df[1], &ef[1], &b[b_offset],
+ ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1], &rwork[1],
+ info);
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < dlamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of ZPTSVX */
+
+} /* zptsvx_ */
diff --git a/SRC/zpttrf.c b/SRC/zpttrf.c
new file mode 100644
index 0000000..9fb3b09
--- /dev/null
+++ b/SRC/zpttrf.c
@@ -0,0 +1,216 @@
+/* zpttrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zpttrf_(integer *n, doublereal *d__, doublecomplex *e,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ doublereal f, g;
+ integer i__, i4;
+ doublereal eii, eir;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPTTRF computes the L*D*L' factorization of a complex Hermitian */
+/* positive definite tridiagonal matrix A. The factorization may also */
+/* be regarded as having the form A = U'*D*U. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the n diagonal elements of the tridiagonal matrix */
+/* A. On exit, the n diagonal elements of the diagonal matrix */
+/* D from the L*D*L' factorization of A. */
+
+/* E (input/output) COMPLEX*16 array, dimension (N-1) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix A. On exit, the (n-1) subdiagonal elements of the */
+/* unit bidiagonal factor L from the L*D*L' factorization of A. */
+/* E can also be regarded as the superdiagonal of the unit */
+/* bidiagonal factor U from the U'*D*U factorization of A. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, the leading minor of order k is not */
+/* positive definite; if k < N, the factorization could not */
+/* be completed, while if k = N, the factorization was */
+/* completed, but D(N) <= 0. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --e;
+ --d__;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ i__1 = -(*info);
+ xerbla_("ZPTTRF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Compute the L*D*L' (or U'*D*U) factorization of A. */
+
+ i4 = (*n - 1) % 4;
+ i__1 = i4;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (d__[i__] <= 0.) {
+ *info = i__;
+ goto L30;
+ }
+ i__2 = i__;
+ eir = e[i__2].r;
+ eii = d_imag(&e[i__]);
+ f = eir / d__[i__];
+ g = eii / d__[i__];
+ i__2 = i__;
+ z__1.r = f, z__1.i = g;
+ e[i__2].r = z__1.r, e[i__2].i = z__1.i;
+ d__[i__ + 1] = d__[i__ + 1] - f * eir - g * eii;
+/* L10: */
+ }
+
+ i__1 = *n - 4;
+ for (i__ = i4 + 1; i__ <= i__1; i__ += 4) {
+
+/* Drop out of the loop if d(i) <= 0: the matrix is not positive */
+/* definite. */
+
+ if (d__[i__] <= 0.) {
+ *info = i__;
+ goto L30;
+ }
+
+/* Solve for e(i) and d(i+1). */
+
+ i__2 = i__;
+ eir = e[i__2].r;
+ eii = d_imag(&e[i__]);
+ f = eir / d__[i__];
+ g = eii / d__[i__];
+ i__2 = i__;
+ z__1.r = f, z__1.i = g;
+ e[i__2].r = z__1.r, e[i__2].i = z__1.i;
+ d__[i__ + 1] = d__[i__ + 1] - f * eir - g * eii;
+
+ if (d__[i__ + 1] <= 0.) {
+ *info = i__ + 1;
+ goto L30;
+ }
+
+/* Solve for e(i+1) and d(i+2). */
+
+ i__2 = i__ + 1;
+ eir = e[i__2].r;
+ eii = d_imag(&e[i__ + 1]);
+ f = eir / d__[i__ + 1];
+ g = eii / d__[i__ + 1];
+ i__2 = i__ + 1;
+ z__1.r = f, z__1.i = g;
+ e[i__2].r = z__1.r, e[i__2].i = z__1.i;
+ d__[i__ + 2] = d__[i__ + 2] - f * eir - g * eii;
+
+ if (d__[i__ + 2] <= 0.) {
+ *info = i__ + 2;
+ goto L30;
+ }
+
+/* Solve for e(i+2) and d(i+3). */
+
+ i__2 = i__ + 2;
+ eir = e[i__2].r;
+ eii = d_imag(&e[i__ + 2]);
+ f = eir / d__[i__ + 2];
+ g = eii / d__[i__ + 2];
+ i__2 = i__ + 2;
+ z__1.r = f, z__1.i = g;
+ e[i__2].r = z__1.r, e[i__2].i = z__1.i;
+ d__[i__ + 3] = d__[i__ + 3] - f * eir - g * eii;
+
+ if (d__[i__ + 3] <= 0.) {
+ *info = i__ + 3;
+ goto L30;
+ }
+
+/* Solve for e(i+3) and d(i+4). */
+
+ i__2 = i__ + 3;
+ eir = e[i__2].r;
+ eii = d_imag(&e[i__ + 3]);
+ f = eir / d__[i__ + 3];
+ g = eii / d__[i__ + 3];
+ i__2 = i__ + 3;
+ z__1.r = f, z__1.i = g;
+ e[i__2].r = z__1.r, e[i__2].i = z__1.i;
+ d__[i__ + 4] = d__[i__ + 4] - f * eir - g * eii;
+/* L20: */
+ }
+
+/* Check d(n) for positive definiteness. */
+
+ if (d__[*n] <= 0.) {
+ *info = *n;
+ }
+
+L30:
+ return 0;
+
+/* End of ZPTTRF */
+
+} /* zpttrf_ */
diff --git a/SRC/zpttrs.c b/SRC/zpttrs.c
new file mode 100644
index 0000000..ebca07e
--- /dev/null
+++ b/SRC/zpttrs.c
@@ -0,0 +1,178 @@
+/* zpttrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zpttrs_(char *uplo, integer *n, integer *nrhs,
+ doublereal *d__, doublecomplex *e, doublecomplex *b, integer *ldb,
+ integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer j, jb, nb, iuplo;
+ logical upper;
+ extern /* Subroutine */ int zptts2_(integer *, integer *, integer *,
+ doublereal *, doublecomplex *, doublecomplex *, integer *),
+ xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPTTRS solves a tridiagonal system of the form */
+/* A * X = B */
+/* using the factorization A = U'*D*U or A = L*D*L' computed by ZPTTRF. */
+/* D is a diagonal matrix specified in the vector D, U (or L) is a unit */
+/* bidiagonal matrix whose superdiagonal (subdiagonal) is specified in */
+/* the vector E, and X and B are N by NRHS matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies the form of the factorization and whether the */
+/* vector E is the superdiagonal of the upper bidiagonal factor */
+/* U or the subdiagonal of the lower bidiagonal factor L. */
+/* = 'U': A = U'*D*U, E is the superdiagonal of U */
+/* = 'L': A = L*D*L', E is the subdiagonal of L */
+
+/* N (input) INTEGER */
+/* The order of the tridiagonal matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the diagonal matrix D from the */
+/* factorization A = U'*D*U or A = L*D*L'. */
+
+/* E (input) COMPLEX*16 array, dimension (N-1) */
+/* If UPLO = 'U', the (n-1) superdiagonal elements of the unit */
+/* bidiagonal factor U from the factorization A = U'*D*U. */
+/* If UPLO = 'L', the (n-1) subdiagonal elements of the unit */
+/* bidiagonal factor L from the factorization A = L*D*L'. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors B for the system of */
+/* linear equations. */
+/* On exit, the solution vectors, X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = *(unsigned char *)uplo == 'U' || *(unsigned char *)uplo == 'u';
+ if (! upper && ! (*(unsigned char *)uplo == 'L' || *(unsigned char *)uplo
+ == 'l')) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZPTTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+/* Determine the number of right-hand sides to solve at a time. */
+
+ if (*nrhs == 1) {
+ nb = 1;
+ } else {
+/* Computing MAX */
+ i__1 = 1, i__2 = ilaenv_(&c__1, "ZPTTRS", uplo, n, nrhs, &c_n1, &c_n1);
+ nb = max(i__1,i__2);
+ }
+
+/* Decode UPLO */
+
+ if (upper) {
+ iuplo = 1;
+ } else {
+ iuplo = 0;
+ }
+
+ if (nb >= *nrhs) {
+ zptts2_(&iuplo, n, nrhs, &d__[1], &e[1], &b[b_offset], ldb);
+ } else {
+ i__1 = *nrhs;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__3 = *nrhs - j + 1;
+ jb = min(i__3,nb);
+ zptts2_(&iuplo, n, &jb, &d__[1], &e[1], &b[j * b_dim1 + 1], ldb);
+/* L10: */
+ }
+ }
+
+ return 0;
+
+/* End of ZPTTRS */
+
+} /* zpttrs_ */
diff --git a/SRC/zptts2.c b/SRC/zptts2.c
new file mode 100644
index 0000000..bcfbedc
--- /dev/null
+++ b/SRC/zptts2.c
@@ -0,0 +1,315 @@
+/* zptts2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zptts2_(integer *iuplo, integer *n, integer *nrhs,
+ doublereal *d__, doublecomplex *e, doublecomplex *b, integer *ldb)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPTTS2 solves a tridiagonal system of the form */
+/* A * X = B */
+/* using the factorization A = U'*D*U or A = L*D*L' computed by ZPTTRF. */
+/* D is a diagonal matrix specified in the vector D, U (or L) is a unit */
+/* bidiagonal matrix whose superdiagonal (subdiagonal) is specified in */
+/* the vector E, and X and B are N by NRHS matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* IUPLO (input) INTEGER */
+/* Specifies the form of the factorization and whether the */
+/* vector E is the superdiagonal of the upper bidiagonal factor */
+/* U or the subdiagonal of the lower bidiagonal factor L. */
+/* = 1: A = U'*D*U, E is the superdiagonal of U */
+/* = 0: A = L*D*L', E is the subdiagonal of L */
+
+/* N (input) INTEGER */
+/* The order of the tridiagonal matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the diagonal matrix D from the */
+/* factorization A = U'*D*U or A = L*D*L'. */
+
+/* E (input) COMPLEX*16 array, dimension (N-1) */
+/* If IUPLO = 1, the (n-1) superdiagonal elements of the unit */
+/* bidiagonal factor U from the factorization A = U'*D*U. */
+/* If IUPLO = 0, the (n-1) subdiagonal elements of the unit */
+/* bidiagonal factor L from the factorization A = L*D*L'. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors B for the system of */
+/* linear equations. */
+/* On exit, the solution vectors, X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*n <= 1) {
+ if (*n == 1) {
+ d__1 = 1. / d__[1];
+ zdscal_(nrhs, &d__1, &b[b_offset], ldb);
+ }
+ return 0;
+ }
+
+ if (*iuplo == 1) {
+
+/* Solve A * X = B using the factorization A = U'*D*U, */
+/* overwriting each right hand side vector with its solution. */
+
+ if (*nrhs <= 2) {
+ j = 1;
+L10:
+
+/* Solve U' * x = b. */
+
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ - 1 + j * b_dim1;
+ d_cnjg(&z__3, &e[i__ - 1]);
+ z__2.r = b[i__4].r * z__3.r - b[i__4].i * z__3.i, z__2.i = b[
+ i__4].r * z__3.i + b[i__4].i * z__3.r;
+ z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i - z__2.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L20: */
+ }
+
+/* Solve D * U * x = b. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ z__1.r = b[i__3].r / d__[i__4], z__1.i = b[i__3].i / d__[i__4]
+ ;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L30: */
+ }
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ i__1 = i__ + j * b_dim1;
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + 1 + j * b_dim1;
+ i__4 = i__;
+ z__2.r = b[i__3].r * e[i__4].r - b[i__3].i * e[i__4].i,
+ z__2.i = b[i__3].r * e[i__4].i + b[i__3].i * e[i__4]
+ .r;
+ z__1.r = b[i__2].r - z__2.r, z__1.i = b[i__2].i - z__2.i;
+ b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+/* L40: */
+ }
+ if (j < *nrhs) {
+ ++j;
+ goto L10;
+ }
+ } else {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve U' * x = b. */
+
+ i__2 = *n;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ - 1 + j * b_dim1;
+ d_cnjg(&z__3, &e[i__ - 1]);
+ z__2.r = b[i__5].r * z__3.r - b[i__5].i * z__3.i, z__2.i =
+ b[i__5].r * z__3.i + b[i__5].i * z__3.r;
+ z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4].i - z__2.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L50: */
+ }
+
+/* Solve D * U * x = b. */
+
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ i__4 = *n;
+ z__1.r = b[i__3].r / d__[i__4], z__1.i = b[i__3].i / d__[i__4]
+ ;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ z__2.r = b[i__3].r / d__[i__4], z__2.i = b[i__3].i / d__[
+ i__4];
+ i__5 = i__ + 1 + j * b_dim1;
+ i__6 = i__;
+ z__3.r = b[i__5].r * e[i__6].r - b[i__5].i * e[i__6].i,
+ z__3.i = b[i__5].r * e[i__6].i + b[i__5].i * e[
+ i__6].r;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L60: */
+ }
+/* L70: */
+ }
+ }
+ } else {
+
+/* Solve A * X = B using the factorization A = L*D*L', */
+/* overwriting each right hand side vector with its solution. */
+
+ if (*nrhs <= 2) {
+ j = 1;
+L80:
+
+/* Solve L * x = b. */
+
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ - 1 + j * b_dim1;
+ i__5 = i__ - 1;
+ z__2.r = b[i__4].r * e[i__5].r - b[i__4].i * e[i__5].i,
+ z__2.i = b[i__4].r * e[i__5].i + b[i__4].i * e[i__5]
+ .r;
+ z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i - z__2.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L90: */
+ }
+
+/* Solve D * L' * x = b. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ z__1.r = b[i__3].r / d__[i__4], z__1.i = b[i__3].i / d__[i__4]
+ ;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L100: */
+ }
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ i__1 = i__ + j * b_dim1;
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + 1 + j * b_dim1;
+ d_cnjg(&z__3, &e[i__]);
+ z__2.r = b[i__3].r * z__3.r - b[i__3].i * z__3.i, z__2.i = b[
+ i__3].r * z__3.i + b[i__3].i * z__3.r;
+ z__1.r = b[i__2].r - z__2.r, z__1.i = b[i__2].i - z__2.i;
+ b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+/* L110: */
+ }
+ if (j < *nrhs) {
+ ++j;
+ goto L80;
+ }
+ } else {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Solve L * x = b. */
+
+ i__2 = *n;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ - 1 + j * b_dim1;
+ i__6 = i__ - 1;
+ z__2.r = b[i__5].r * e[i__6].r - b[i__5].i * e[i__6].i,
+ z__2.i = b[i__5].r * e[i__6].i + b[i__5].i * e[
+ i__6].r;
+ z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4].i - z__2.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L120: */
+ }
+
+/* Solve D * L' * x = b. */
+
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ i__4 = *n;
+ z__1.r = b[i__3].r / d__[i__4], z__1.i = b[i__3].i / d__[i__4]
+ ;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ i__2 = i__ + j * b_dim1;
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__;
+ z__2.r = b[i__3].r / d__[i__4], z__2.i = b[i__3].i / d__[
+ i__4];
+ i__5 = i__ + 1 + j * b_dim1;
+ d_cnjg(&z__4, &e[i__]);
+ z__3.r = b[i__5].r * z__4.r - b[i__5].i * z__4.i, z__3.i =
+ b[i__5].r * z__4.i + b[i__5].i * z__4.r;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L130: */
+ }
+/* L140: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZPTTS2 */
+
+} /* zptts2_ */
diff --git a/SRC/zrot.c b/SRC/zrot.c
new file mode 100644
index 0000000..4e716e6
--- /dev/null
+++ b/SRC/zrot.c
@@ -0,0 +1,155 @@
+/* zrot.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zrot_(integer *n, doublecomplex *cx, integer *incx,
+ doublecomplex *cy, integer *incy, doublereal *c__, doublecomplex *s)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, ix, iy;
+ doublecomplex stemp;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZROT applies a plane rotation, where the cos (C) is real and the */
+/* sin (S) is complex, and the vectors CX and CY are complex. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of elements in the vectors CX and CY. */
+
+/* CX (input/output) COMPLEX*16 array, dimension (N) */
+/* On input, the vector X. */
+/* On output, CX is overwritten with C*X + S*Y. */
+
+/* INCX (input) INTEGER */
+/* The increment between successive values of CY. INCX <> 0. */
+
+/* CY (input/output) COMPLEX*16 array, dimension (N) */
+/* On input, the vector Y. */
+/* On output, CY is overwritten with -CONJG(S)*X + C*Y. */
+
+/* INCY (input) INTEGER */
+/* The increment between successive values of CY. INCX <> 0. */
+
+/* C (input) DOUBLE PRECISION */
+/* S (input) COMPLEX*16 */
+/* C and S define a rotation */
+/* [ C S ] */
+/* [ -conjg(S) C ] */
+/* where C*C + S*CONJG(S) = 1.0. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --cy;
+ --cx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* Code for unequal increments or equal increments not equal to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ix;
+ z__2.r = *c__ * cx[i__2].r, z__2.i = *c__ * cx[i__2].i;
+ i__3 = iy;
+ z__3.r = s->r * cy[i__3].r - s->i * cy[i__3].i, z__3.i = s->r * cy[
+ i__3].i + s->i * cy[i__3].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ stemp.r = z__1.r, stemp.i = z__1.i;
+ i__2 = iy;
+ i__3 = iy;
+ z__2.r = *c__ * cy[i__3].r, z__2.i = *c__ * cy[i__3].i;
+ d_cnjg(&z__4, s);
+ i__4 = ix;
+ z__3.r = z__4.r * cx[i__4].r - z__4.i * cx[i__4].i, z__3.i = z__4.r *
+ cx[i__4].i + z__4.i * cx[i__4].r;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ cy[i__2].r = z__1.r, cy[i__2].i = z__1.i;
+ i__2 = ix;
+ cx[i__2].r = stemp.r, cx[i__2].i = stemp.i;
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ return 0;
+
+/* Code for both increments equal to 1 */
+
+L20:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ z__2.r = *c__ * cx[i__2].r, z__2.i = *c__ * cx[i__2].i;
+ i__3 = i__;
+ z__3.r = s->r * cy[i__3].r - s->i * cy[i__3].i, z__3.i = s->r * cy[
+ i__3].i + s->i * cy[i__3].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ stemp.r = z__1.r, stemp.i = z__1.i;
+ i__2 = i__;
+ i__3 = i__;
+ z__2.r = *c__ * cy[i__3].r, z__2.i = *c__ * cy[i__3].i;
+ d_cnjg(&z__4, s);
+ i__4 = i__;
+ z__3.r = z__4.r * cx[i__4].r - z__4.i * cx[i__4].i, z__3.i = z__4.r *
+ cx[i__4].i + z__4.i * cx[i__4].r;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ cy[i__2].r = z__1.r, cy[i__2].i = z__1.i;
+ i__2 = i__;
+ cx[i__2].r = stemp.r, cx[i__2].i = stemp.i;
+/* L30: */
+ }
+ return 0;
+} /* zrot_ */
diff --git a/SRC/zspcon.c b/SRC/zspcon.c
new file mode 100644
index 0000000..0fc8d28
--- /dev/null
+++ b/SRC/zspcon.c
@@ -0,0 +1,197 @@
+/* zspcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zspcon_(char *uplo, integer *n, doublecomplex *ap,
+ integer *ipiv, doublereal *anorm, doublereal *rcond, doublecomplex *
+ work, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer i__, ip, kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *), xerbla_(
+ char *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int zsptrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSPCON estimates the reciprocal of the condition number (in the */
+/* 1-norm) of a complex symmetric packed matrix A using the */
+/* factorization A = U*D*U**T or A = L*D*L**T computed by ZSPTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by ZSPTRF, stored as a */
+/* packed triangular matrix. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by ZSPTRF. */
+
+/* ANORM (input) DOUBLE PRECISION */
+/* The 1-norm of the original matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --work;
+ --ipiv;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*anorm < 0.) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZSPCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.;
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ } else if (*anorm <= 0.) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ ip = *n * (*n + 1) / 2;
+ for (i__ = *n; i__ >= 1; --i__) {
+ i__1 = ip;
+ if (ipiv[i__] > 0 && (ap[i__1].r == 0. && ap[i__1].i == 0.)) {
+ return 0;
+ }
+ ip -= i__;
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ ip = 1;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ip;
+ if (ipiv[i__] > 0 && (ap[i__2].r == 0. && ap[i__2].i == 0.)) {
+ return 0;
+ }
+ ip = ip + *n - i__ + 1;
+/* L20: */
+ }
+ }
+
+/* Estimate the 1-norm of the inverse. */
+
+ kase = 0;
+L30:
+ zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+
+/* Multiply by inv(L*D*L') or inv(U*D*U'). */
+
+ zsptrs_(uplo, n, &c__1, &ap[1], &ipiv[1], &work[1], n, info);
+ goto L30;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / ainvnm / *anorm;
+ }
+
+ return 0;
+
+/* End of ZSPCON */
+
+} /* zspcon_ */
diff --git a/SRC/zspmv.c b/SRC/zspmv.c
new file mode 100644
index 0000000..128e1db
--- /dev/null
+++ b/SRC/zspmv.c
@@ -0,0 +1,428 @@
+/* zspmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zspmv_(char *uplo, integer *n, doublecomplex *alpha,
+ doublecomplex *ap, doublecomplex *x, integer *incx, doublecomplex *
+ beta, doublecomplex *y, integer *incy)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
+ doublecomplex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSPMV performs the matrix-vector operation */
+
+/* y := alpha*A*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are n element vectors and */
+/* A is an n by n symmetric matrix, supplied in packed form. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the matrix A is supplied in the packed */
+/* array AP as follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* supplied in AP. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* supplied in AP. */
+
+/* Unchanged on exit. */
+
+/* N (input) INTEGER */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA (input) COMPLEX*16 */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* AP (input) COMPLEX*16 array, dimension at least */
+/* ( ( N*( N + 1 ) )/2 ). */
+/* Before entry, with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular part of the symmetric matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
+/* and a( 2, 2 ) respectively, and so on. */
+/* Before entry, with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular part of the symmetric matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
+/* and a( 3, 1 ) respectively, and so on. */
+/* Unchanged on exit. */
+
+/* X (input) COMPLEX*16 array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the N- */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX (input) INTEGER */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA (input) COMPLEX*16 */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y (input/output) COMPLEX*16 array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. On exit, Y is overwritten by the updated */
+/* vector y. */
+
+/* INCY (input) INTEGER */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --y;
+ --x;
+ --ap;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 6;
+ } else if (*incy == 0) {
+ info = 9;
+ }
+ if (info != 0) {
+ xerbla_("ZSPMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r == 1. &&
+ beta->i == 0.)) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of the array AP */
+/* are accessed sequentially with one pass through AP. */
+
+/* First form y := beta*y. */
+
+ if (beta->r != 1. || beta->i != 0.) {
+ if (*incy == 1) {
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ y[i__2].r = 0., y[i__2].i = 0.;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ y[i__2].r = 0., y[i__2].i = 0.;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ i__3 = iy;
+ z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (alpha->r == 0. && alpha->i == 0.) {
+ return 0;
+ }
+ kk = 1;
+ if (lsame_(uplo, "U")) {
+
+/* Form y when AP contains the upper triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ k = kk;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = k;
+ z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
+ z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
+ .r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ i__3 = k;
+ i__4 = i__;
+ z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[i__4].i,
+ z__2.i = ap[i__3].r * x[i__4].i + ap[i__3].i * x[
+ i__4].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ ++k;
+/* L50: */
+ }
+ i__2 = j;
+ i__3 = j;
+ i__4 = kk + j - 1;
+ z__3.r = temp1.r * ap[i__4].r - temp1.i * ap[i__4].i, z__3.i =
+ temp1.r * ap[i__4].i + temp1.i * ap[i__4].r;
+ z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i;
+ z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ kk += j;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ ix = kx;
+ iy = ky;
+ i__2 = kk + j - 2;
+ for (k = kk; k <= i__2; ++k) {
+ i__3 = iy;
+ i__4 = iy;
+ i__5 = k;
+ z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
+ z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
+ .r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ i__3 = k;
+ i__4 = ix;
+ z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[i__4].i,
+ z__2.i = ap[i__3].r * x[i__4].i + ap[i__3].i * x[
+ i__4].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ i__2 = jy;
+ i__3 = jy;
+ i__4 = kk + j - 1;
+ z__3.r = temp1.r * ap[i__4].r - temp1.i * ap[i__4].i, z__3.i =
+ temp1.r * ap[i__4].i + temp1.i * ap[i__4].r;
+ z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i;
+ z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ jx += *incx;
+ jy += *incy;
+ kk += j;
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y when AP contains the lower triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ i__2 = j;
+ i__3 = j;
+ i__4 = kk;
+ z__2.r = temp1.r * ap[i__4].r - temp1.i * ap[i__4].i, z__2.i =
+ temp1.r * ap[i__4].i + temp1.i * ap[i__4].r;
+ z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ k = kk + 1;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = k;
+ z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
+ z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
+ .r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ i__3 = k;
+ i__4 = i__;
+ z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[i__4].i,
+ z__2.i = ap[i__3].r * x[i__4].i + ap[i__3].i * x[
+ i__4].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ ++k;
+/* L90: */
+ }
+ i__2 = j;
+ i__3 = j;
+ z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ kk += *n - j + 1;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ i__2 = jy;
+ i__3 = jy;
+ i__4 = kk;
+ z__2.r = temp1.r * ap[i__4].r - temp1.i * ap[i__4].i, z__2.i =
+ temp1.r * ap[i__4].i + temp1.i * ap[i__4].r;
+ z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ ix = jx;
+ iy = jy;
+ i__2 = kk + *n - j;
+ for (k = kk + 1; k <= i__2; ++k) {
+ ix += *incx;
+ iy += *incy;
+ i__3 = iy;
+ i__4 = iy;
+ i__5 = k;
+ z__2.r = temp1.r * ap[i__5].r - temp1.i * ap[i__5].i,
+ z__2.i = temp1.r * ap[i__5].i + temp1.i * ap[i__5]
+ .r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ i__3 = k;
+ i__4 = ix;
+ z__2.r = ap[i__3].r * x[i__4].r - ap[i__3].i * x[i__4].i,
+ z__2.i = ap[i__3].r * x[i__4].i + ap[i__3].i * x[
+ i__4].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L110: */
+ }
+ i__2 = jy;
+ i__3 = jy;
+ z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ jx += *incx;
+ jy += *incy;
+ kk += *n - j + 1;
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZSPMV */
+
+} /* zspmv_ */
diff --git a/SRC/zspr.c b/SRC/zspr.c
new file mode 100644
index 0000000..da539cd
--- /dev/null
+++ b/SRC/zspr.c
@@ -0,0 +1,339 @@
+/* zspr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zspr_(char *uplo, integer *n, doublecomplex *alpha,
+ doublecomplex *x, integer *incx, doublecomplex *ap)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1, z__2;
+
+ /* Local variables */
+ integer i__, j, k, kk, ix, jx, kx, info;
+ doublecomplex temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSPR performs the symmetric rank 1 operation */
+
+/* A := alpha*x*conjg( x' ) + A, */
+
+/* where alpha is a complex scalar, x is an n element vector and A is an */
+/* n by n symmetric matrix, supplied in packed form. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the matrix A is supplied in the packed */
+/* array AP as follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* supplied in AP. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* supplied in AP. */
+
+/* Unchanged on exit. */
+
+/* N (input) INTEGER */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA (input) COMPLEX*16 */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X (input) COMPLEX*16 array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the N- */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX (input) INTEGER */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* AP (input/output) COMPLEX*16 array, dimension at least */
+/* ( ( N*( N + 1 ) )/2 ). */
+/* Before entry, with UPLO = 'U' or 'u', the array AP must */
+/* contain the upper triangular part of the symmetric matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
+/* and a( 2, 2 ) respectively, and so on. On exit, the array */
+/* AP is overwritten by the upper triangular part of the */
+/* updated matrix. */
+/* Before entry, with UPLO = 'L' or 'l', the array AP must */
+/* contain the lower triangular part of the symmetric matrix */
+/* packed sequentially, column by column, so that AP( 1 ) */
+/* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
+/* and a( 3, 1 ) respectively, and so on. On exit, the array */
+/* AP is overwritten by the lower triangular part of the */
+/* updated matrix. */
+/* Note that the imaginary parts of the diagonal elements need */
+/* not be set, they are assumed to be zero, and on exit they */
+/* are set to zero. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --x;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ }
+ if (info != 0) {
+ xerbla_("ZSPR ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || alpha->r == 0. && alpha->i == 0.) {
+ return 0;
+ }
+
+/* Set the start point in X if the increment is not unity. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of the array AP */
+/* are accessed sequentially with one pass through AP. */
+
+ kk = 1;
+ if (lsame_(uplo, "U")) {
+
+/* Form A when upper triangle is stored in AP. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ i__2 = j;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ k = kk;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = k;
+ i__4 = k;
+ i__5 = i__;
+ z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ z__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i +
+ z__2.i;
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+ ++k;
+/* L10: */
+ }
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ i__4 = j;
+ z__2.r = x[i__4].r * temp.r - x[i__4].i * temp.i, z__2.i =
+ x[i__4].r * temp.i + x[i__4].i * temp.r;
+ z__1.r = ap[i__3].r + z__2.r, z__1.i = ap[i__3].i +
+ z__2.i;
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ } else {
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
+ }
+ kk += j;
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ i__2 = jx;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix = kx;
+ i__2 = kk + j - 2;
+ for (k = kk; k <= i__2; ++k) {
+ i__3 = k;
+ i__4 = k;
+ i__5 = ix;
+ z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ z__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i +
+ z__2.i;
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+ ix += *incx;
+/* L30: */
+ }
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ i__4 = jx;
+ z__2.r = x[i__4].r * temp.r - x[i__4].i * temp.i, z__2.i =
+ x[i__4].r * temp.i + x[i__4].i * temp.r;
+ z__1.r = ap[i__3].r + z__2.r, z__1.i = ap[i__3].i +
+ z__2.i;
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ } else {
+ i__2 = kk + j - 1;
+ i__3 = kk + j - 1;
+ ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
+ }
+ jx += *incx;
+ kk += j;
+/* L40: */
+ }
+ }
+ } else {
+
+/* Form A when lower triangle is stored in AP. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ i__2 = j;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__2 = kk;
+ i__3 = kk;
+ i__4 = j;
+ z__2.r = temp.r * x[i__4].r - temp.i * x[i__4].i, z__2.i =
+ temp.r * x[i__4].i + temp.i * x[i__4].r;
+ z__1.r = ap[i__3].r + z__2.r, z__1.i = ap[i__3].i +
+ z__2.i;
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ k = kk + 1;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = k;
+ i__4 = k;
+ i__5 = i__;
+ z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ z__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i +
+ z__2.i;
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+ ++k;
+/* L50: */
+ }
+ } else {
+ i__2 = kk;
+ i__3 = kk;
+ ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
+ }
+ kk = kk + *n - j + 1;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ i__2 = jx;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__2 = kk;
+ i__3 = kk;
+ i__4 = jx;
+ z__2.r = temp.r * x[i__4].r - temp.i * x[i__4].i, z__2.i =
+ temp.r * x[i__4].i + temp.i * x[i__4].r;
+ z__1.r = ap[i__3].r + z__2.r, z__1.i = ap[i__3].i +
+ z__2.i;
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ ix = jx;
+ i__2 = kk + *n - j;
+ for (k = kk + 1; k <= i__2; ++k) {
+ ix += *incx;
+ i__3 = k;
+ i__4 = k;
+ i__5 = ix;
+ z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ z__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ z__1.r = ap[i__4].r + z__2.r, z__1.i = ap[i__4].i +
+ z__2.i;
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+/* L70: */
+ }
+ } else {
+ i__2 = kk;
+ i__3 = kk;
+ ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
+ }
+ jx += *incx;
+ kk = kk + *n - j + 1;
+/* L80: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZSPR */
+
+} /* zspr_ */
diff --git a/SRC/zsprfs.c b/SRC/zsprfs.c
new file mode 100644
index 0000000..f322c3a
--- /dev/null
+++ b/SRC/zsprfs.c
@@ -0,0 +1,464 @@
+/* zsprfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zsprfs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *ap, doublecomplex *afp, integer *ipiv, doublecomplex *
+ b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr,
+ doublereal *berr, doublecomplex *work, doublereal *rwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal s;
+ integer ik, kk;
+ doublereal xk;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3], count;
+ logical upper;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), zspmv_(
+ char *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal lstres;
+ extern /* Subroutine */ int zsptrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSPRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric indefinite */
+/* and packed, and provides error bounds and backward error estimates */
+/* for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the symmetric matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* AFP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The factored form of the matrix A. AFP contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor U or L from the factorization A = U*D*U**T or */
+/* A = L*D*L**T as computed by ZSPTRF, stored as a packed */
+/* triangular matrix. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by ZSPTRF. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by ZSPTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --afp;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*ldx < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZSPRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ z__1.r = -1., z__1.i = -0.;
+ zspmv_(uplo, n, &z__1, &ap[1], &x[j * x_dim1 + 1], &c__1, &c_b1, &
+ work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
+ i__ + j * b_dim1]), abs(d__2));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ kk = 1;
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
+ x_dim1]), abs(d__2));
+ ik = kk;
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ik;
+ rwork[i__] += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&ap[ik]), abs(d__2))) * xk;
+ i__4 = ik;
+ i__5 = i__ + j * x_dim1;
+ s += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 = d_imag(&ap[
+ ik]), abs(d__2))) * ((d__3 = x[i__5].r, abs(d__3))
+ + (d__4 = d_imag(&x[i__ + j * x_dim1]), abs(d__4)
+ ));
+ ++ik;
+/* L40: */
+ }
+ i__3 = kk + k - 1;
+ rwork[k] = rwork[k] + ((d__1 = ap[i__3].r, abs(d__1)) + (d__2
+ = d_imag(&ap[kk + k - 1]), abs(d__2))) * xk + s;
+ kk += k;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
+ x_dim1]), abs(d__2));
+ i__3 = kk;
+ rwork[k] += ((d__1 = ap[i__3].r, abs(d__1)) + (d__2 = d_imag(&
+ ap[kk]), abs(d__2))) * xk;
+ ik = kk + 1;
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ i__4 = ik;
+ rwork[i__] += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&ap[ik]), abs(d__2))) * xk;
+ i__4 = ik;
+ i__5 = i__ + j * x_dim1;
+ s += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 = d_imag(&ap[
+ ik]), abs(d__2))) * ((d__3 = x[i__5].r, abs(d__3))
+ + (d__4 = d_imag(&x[i__ + j * x_dim1]), abs(d__4)
+ ));
+ ++ik;
+/* L60: */
+ }
+ rwork[k] += s;
+ kk += *n - k + 1;
+/* L70: */
+ }
+ }
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__3 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2))) / rwork[i__];
+ s = max(d__3,d__4);
+ } else {
+/* Computing MAX */
+ i__3 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = max(d__3,d__4);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ zsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info);
+ zaxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use ZLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__3 = i__;
+ rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ ;
+ } else {
+ i__3 = i__;
+ rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ zsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L120: */
+ }
+ zsptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * x_dim1;
+ d__3 = lstres, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&x[i__ + j * x_dim1]), abs(d__2));
+ lstres = max(d__3,d__4);
+/* L130: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of ZSPRFS */
+
+} /* zsprfs_ */
diff --git a/SRC/zspsv.c b/SRC/zspsv.c
new file mode 100644
index 0000000..1794a15
--- /dev/null
+++ b/SRC/zspsv.c
@@ -0,0 +1,177 @@
+/* zspsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zspsv_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *ap, integer *ipiv, doublecomplex *b, integer *ldb,
+ integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), zsptrf_(
+ char *, integer *, doublecomplex *, integer *, integer *),
+ zsptrs_(char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSPSV computes the solution to a complex system of linear equations */
+/* A * X = B, */
+/* where A is an N-by-N symmetric matrix stored in packed format and X */
+/* and B are N-by-NRHS matrices. */
+
+/* The diagonal pivoting method is used to factor A as */
+/* A = U * D * U**T, if UPLO = 'U', or */
+/* A = L * D * L**T, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, D is symmetric and block diagonal with 1-by-1 */
+/* and 2-by-2 diagonal blocks. The factored form of A is then used to */
+/* solve the system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+
+/* On exit, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**T or A = L*D*L**T as computed by ZSPTRF, stored as */
+/* a packed triangular matrix in the same storage format as A. */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D, as */
+/* determined by ZSPTRF. If IPIV(k) > 0, then rows and columns */
+/* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 */
+/* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, */
+/* then rows and columns k-1 and -IPIV(k) were interchanged and */
+/* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and */
+/* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and */
+/* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 */
+/* diagonal block. */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */
+/* has been completed, but the block diagonal matrix D is */
+/* exactly singular, so the solution could not be */
+/* computed. */
+
+/* Further Details */
+/* =============== */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the symmetric matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = aji) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZSPSV ", &i__1);
+ return 0;
+ }
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ zsptrf_(uplo, n, &ap[1], &ipiv[1], info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ zsptrs_(uplo, n, nrhs, &ap[1], &ipiv[1], &b[b_offset], ldb, info);
+
+ }
+ return 0;
+
+/* End of ZSPSV */
+
+} /* zspsv_ */
diff --git a/SRC/zspsvx.c b/SRC/zspsvx.c
new file mode 100644
index 0000000..b8c3d86
--- /dev/null
+++ b/SRC/zspsvx.c
@@ -0,0 +1,326 @@
+/* zspsvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zspsvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublecomplex *ap, doublecomplex *afp, integer *ipiv,
+ doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
+ doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *
+ work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *), zlacpy_(
+ char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern doublereal zlansp_(char *, char *, integer *, doublecomplex *,
+ doublereal *);
+ extern /* Subroutine */ int zspcon_(char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublecomplex *, integer *), zsprfs_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *), zsptrf_(char *,
+ integer *, doublecomplex *, integer *, integer *),
+ zsptrs_(char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSPSVX uses the diagonal pivoting factorization A = U*D*U**T or */
+/* A = L*D*L**T to compute the solution to a complex system of linear */
+/* equations A * X = B, where A is an N-by-N symmetric matrix stored */
+/* in packed format and X and B are N-by-NRHS matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as */
+/* A = U * D * U**T, if UPLO = 'U', or */
+/* A = L * D * L**T, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* 2. If some D(i,i)=0, so that D is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 3. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 4. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of A has been */
+/* supplied on entry. */
+/* = 'F': On entry, AFP and IPIV contain the factored form */
+/* of A. AP, AFP and IPIV will not be modified. */
+/* = 'N': The matrix A will be copied to AFP and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the symmetric matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+
+/* AFP (input or output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* If FACT = 'F', then AFP is an input argument and on entry */
+/* contains the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**T or A = L*D*L**T as computed by ZSPTRF, stored as */
+/* a packed triangular matrix in the same storage format as A. */
+
+/* If FACT = 'N', then AFP is an output argument and on exit */
+/* contains the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**T or A = L*D*L**T as computed by ZSPTRF, stored as */
+/* a packed triangular matrix in the same storage format as A. */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by ZSPTRF. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by ZSPTRF. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A. If RCOND is less than the machine precision (in */
+/* particular, if RCOND = 0), the matrix is singular to working */
+/* precision. This condition is indicated by a return code of */
+/* INFO > 0. */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: D(i,i) is exactly zero. The factorization */
+/* has been completed but the factor D is exactly */
+/* singular, so the solution and error bounds could */
+/* not be computed. RCOND = 0 is returned. */
+/* = N+1: D is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* Further Details */
+/* =============== */
+
+/* The packed storage scheme is illustrated by the following example */
+/* when N = 4, UPLO = 'U': */
+
+/* Two-dimensional storage of the symmetric matrix A: */
+
+/* a11 a12 a13 a14 */
+/* a22 a23 a24 */
+/* a33 a34 (aij = aji) */
+/* a44 */
+
+/* Packed storage of the upper triangle of A: */
+
+/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ --afp;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ if (! nofact && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZSPSVX", &i__1);
+ return 0;
+ }
+
+ if (nofact) {
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ i__1 = *n * (*n + 1) / 2;
+ zcopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1);
+ zsptrf_(uplo, n, &afp[1], &ipiv[1], info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = zlansp_("I", uplo, n, &ap[1], &rwork[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ zspcon_(uplo, n, &afp[1], &ipiv[1], &anorm, rcond, &work[1], info);
+
+/* Compute the solution vectors X. */
+
+ zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ zsptrs_(uplo, n, nrhs, &afp[1], &ipiv[1], &x[x_offset], ldx, info);
+
+/* Use iterative refinement to improve the computed solutions and */
+/* compute error bounds and backward error estimates for them. */
+
+ zsprfs_(uplo, n, nrhs, &ap[1], &afp[1], &ipiv[1], &b[b_offset], ldb, &x[
+ x_offset], ldx, &ferr[1], &berr[1], &work[1], &rwork[1], info);
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < dlamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ return 0;
+
+/* End of ZSPSVX */
+
+} /* zspsvx_ */
diff --git a/SRC/zsptrf.c b/SRC/zsptrf.c
new file mode 100644
index 0000000..4482665
--- /dev/null
+++ b/SRC/zsptrf.c
@@ -0,0 +1,763 @@
+/* zsptrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zsptrf_(char *uplo, integer *n, doublecomplex *ap,
+ integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_imag(doublecomplex *);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublecomplex t, r1, d11, d12, d21, d22;
+ integer kc, kk, kp;
+ doublecomplex wk;
+ integer kx, knc, kpc, npp;
+ doublecomplex wkm1, wkp1;
+ integer imax, jmax;
+ extern /* Subroutine */ int zspr_(char *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *);
+ doublereal alpha;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ integer kstep;
+ logical upper;
+ extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ doublereal absakk;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal colmax;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ doublereal rowmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSPTRF computes the factorization of a complex symmetric matrix A */
+/* stored in packed format using the Bunch-Kaufman diagonal pivoting */
+/* method: */
+
+/* A = U*D*U**T or A = L*D*L**T */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangle of the symmetric matrix */
+/* A, packed columnwise in a linear array. The j-th column of A */
+/* is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* On exit, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L, stored as a packed triangular */
+/* matrix overwriting A (see below for further details). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. 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. */
+
+/* Further Details */
+/* =============== */
+
+/* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services */
+/* Company */
+
+/* If UPLO = 'U', then A = U*D*U', where */
+/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
+/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
+/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I v 0 ) k-s */
+/* U(k) = ( 0 I 0 ) s */
+/* ( 0 0 I ) n-k */
+/* k-s s n-k */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
+/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
+/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
+
+/* If UPLO = 'L', then A = L*D*L', where */
+/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
+/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
+/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I 0 0 ) k-1 */
+/* L(k) = ( 0 I 0 ) s */
+/* ( 0 v I ) n-k-s+1 */
+/* k-1 s n-k-s+1 */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
+/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
+/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ipiv;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZSPTRF", &i__1);
+ return 0;
+ }
+
+/* Initialize ALPHA for use in choosing pivot block size. */
+
+ alpha = (sqrt(17.) + 1.) / 8.;
+
+ if (upper) {
+
+/* Factorize A as U*D*U' using the upper triangle of A */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2 */
+
+ k = *n;
+ kc = (*n - 1) * *n / 2 + 1;
+L10:
+ knc = kc;
+
+/* If K < 1, exit from loop */
+
+ if (k < 1) {
+ goto L110;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = kc + k - 1;
+ absakk = (d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[kc + k -
+ 1]), abs(d__2));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ imax = izamax_(&i__1, &ap[kc], &c__1);
+ i__1 = kc + imax - 1;
+ colmax = (d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[kc +
+ imax - 1]), abs(d__2));
+ } else {
+ colmax = 0.;
+ }
+
+ if (max(absakk,colmax) == 0.) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ rowmax = 0.;
+ jmax = imax;
+ kx = imax * (imax + 1) / 2 + imax;
+ i__1 = k;
+ for (j = imax + 1; j <= i__1; ++j) {
+ i__2 = kx;
+ if ((d__1 = ap[i__2].r, abs(d__1)) + (d__2 = d_imag(&ap[
+ kx]), abs(d__2)) > rowmax) {
+ i__2 = kx;
+ rowmax = (d__1 = ap[i__2].r, abs(d__1)) + (d__2 =
+ d_imag(&ap[kx]), abs(d__2));
+ jmax = j;
+ }
+ kx += j;
+/* L20: */
+ }
+ kpc = (imax - 1) * imax / 2 + 1;
+ if (imax > 1) {
+ i__1 = imax - 1;
+ jmax = izamax_(&i__1, &ap[kpc], &c__1);
+/* Computing MAX */
+ i__1 = kpc + jmax - 1;
+ d__3 = rowmax, d__4 = (d__1 = ap[i__1].r, abs(d__1)) + (
+ d__2 = d_imag(&ap[kpc + jmax - 1]), abs(d__2));
+ rowmax = max(d__3,d__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = kpc + imax - 1;
+ if ((d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[
+ kpc + imax - 1]), abs(d__2)) >= alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k - kstep + 1;
+ if (kstep == 2) {
+ knc = knc - k + 1;
+ }
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the leading */
+/* submatrix A(1:k,1:k) */
+
+ i__1 = kp - 1;
+ zswap_(&i__1, &ap[knc], &c__1, &ap[kpc], &c__1);
+ kx = kpc + kp - 1;
+ i__1 = kk - 1;
+ for (j = kp + 1; j <= i__1; ++j) {
+ kx = kx + j - 1;
+ i__2 = knc + j - 1;
+ t.r = ap[i__2].r, t.i = ap[i__2].i;
+ i__2 = knc + j - 1;
+ i__3 = kx;
+ ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
+ i__2 = kx;
+ ap[i__2].r = t.r, ap[i__2].i = t.i;
+/* L30: */
+ }
+ i__1 = knc + kk - 1;
+ t.r = ap[i__1].r, t.i = ap[i__1].i;
+ i__1 = knc + kk - 1;
+ i__2 = kpc + kp - 1;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kpc + kp - 1;
+ ap[i__1].r = t.r, ap[i__1].i = t.i;
+ if (kstep == 2) {
+ i__1 = kc + k - 2;
+ t.r = ap[i__1].r, t.i = ap[i__1].i;
+ i__1 = kc + k - 2;
+ i__2 = kc + kp - 1;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kc + kp - 1;
+ ap[i__1].r = t.r, ap[i__1].i = t.i;
+ }
+ }
+
+/* Update the leading submatrix */
+
+ if (kstep == 1) {
+
+/* 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 */
+
+/* Perform a rank-1 update of A(1:k-1,1:k-1) as */
+
+/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */
+
+ z_div(&z__1, &c_b1, &ap[kc + k - 1]);
+ r1.r = z__1.r, r1.i = z__1.i;
+ i__1 = k - 1;
+ z__1.r = -r1.r, z__1.i = -r1.i;
+ zspr_(uplo, &i__1, &z__1, &ap[kc], &c__1, &ap[1]);
+
+/* Store U(k) in column k */
+
+ i__1 = k - 1;
+ zscal_(&i__1, &r1, &ap[kc], &c__1);
+ } 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) )' */
+/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */
+
+ if (k > 2) {
+
+ i__1 = k - 1 + (k - 1) * k / 2;
+ d12.r = ap[i__1].r, d12.i = ap[i__1].i;
+ z_div(&z__1, &ap[k - 1 + (k - 2) * (k - 1) / 2], &d12);
+ d22.r = z__1.r, d22.i = z__1.i;
+ z_div(&z__1, &ap[k + (k - 1) * k / 2], &d12);
+ d11.r = z__1.r, d11.i = z__1.i;
+ z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r *
+ d22.i + d11.i * d22.r;
+ z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.;
+ z_div(&z__1, &c_b1, &z__2);
+ t.r = z__1.r, t.i = z__1.i;
+ z_div(&z__1, &t, &d12);
+ d12.r = z__1.r, d12.i = z__1.i;
+
+ for (j = k - 2; j >= 1; --j) {
+ i__1 = j + (k - 2) * (k - 1) / 2;
+ z__3.r = d11.r * ap[i__1].r - d11.i * ap[i__1].i,
+ z__3.i = d11.r * ap[i__1].i + d11.i * ap[i__1]
+ .r;
+ i__2 = j + (k - 1) * k / 2;
+ z__2.r = z__3.r - ap[i__2].r, z__2.i = z__3.i - ap[
+ i__2].i;
+ z__1.r = d12.r * z__2.r - d12.i * z__2.i, z__1.i =
+ d12.r * z__2.i + d12.i * z__2.r;
+ wkm1.r = z__1.r, wkm1.i = z__1.i;
+ i__1 = j + (k - 1) * k / 2;
+ z__3.r = d22.r * ap[i__1].r - d22.i * ap[i__1].i,
+ z__3.i = d22.r * ap[i__1].i + d22.i * ap[i__1]
+ .r;
+ i__2 = j + (k - 2) * (k - 1) / 2;
+ z__2.r = z__3.r - ap[i__2].r, z__2.i = z__3.i - ap[
+ i__2].i;
+ z__1.r = d12.r * z__2.r - d12.i * z__2.i, z__1.i =
+ d12.r * z__2.i + d12.i * z__2.r;
+ wk.r = z__1.r, wk.i = z__1.i;
+ for (i__ = j; i__ >= 1; --i__) {
+ i__1 = i__ + (j - 1) * j / 2;
+ i__2 = i__ + (j - 1) * j / 2;
+ i__3 = i__ + (k - 1) * k / 2;
+ z__3.r = ap[i__3].r * wk.r - ap[i__3].i * wk.i,
+ z__3.i = ap[i__3].r * wk.i + ap[i__3].i *
+ wk.r;
+ z__2.r = ap[i__2].r - z__3.r, z__2.i = ap[i__2].i
+ - z__3.i;
+ i__4 = i__ + (k - 2) * (k - 1) / 2;
+ z__4.r = ap[i__4].r * wkm1.r - ap[i__4].i *
+ wkm1.i, z__4.i = ap[i__4].r * wkm1.i + ap[
+ i__4].i * wkm1.r;
+ z__1.r = z__2.r - z__4.r, z__1.i = z__2.i -
+ z__4.i;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+/* L40: */
+ }
+ i__1 = j + (k - 1) * k / 2;
+ ap[i__1].r = wk.r, ap[i__1].i = wk.i;
+ i__1 = j + (k - 2) * (k - 1) / 2;
+ ap[i__1].r = wkm1.r, ap[i__1].i = wkm1.i;
+/* L50: */
+ }
+
+ }
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k - 1] = -kp;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kstep;
+ kc = knc - k;
+ goto L10;
+
+ } else {
+
+/* Factorize A as L*D*L' using the lower triangle of A */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2 */
+
+ k = 1;
+ kc = 1;
+ npp = *n * (*n + 1) / 2;
+L60:
+ knc = kc;
+
+/* If K > N, exit from loop */
+
+ if (k > *n) {
+ goto L110;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = kc;
+ absakk = (d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[kc]),
+ abs(d__2));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ imax = k + izamax_(&i__1, &ap[kc + 1], &c__1);
+ i__1 = kc + imax - k;
+ colmax = (d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[kc +
+ imax - k]), abs(d__2));
+ } else {
+ colmax = 0.;
+ }
+
+ if (max(absakk,colmax) == 0.) {
+
+/* Column K is zero: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ rowmax = 0.;
+ kx = kc + imax - k;
+ i__1 = imax - 1;
+ for (j = k; j <= i__1; ++j) {
+ i__2 = kx;
+ if ((d__1 = ap[i__2].r, abs(d__1)) + (d__2 = d_imag(&ap[
+ kx]), abs(d__2)) > rowmax) {
+ i__2 = kx;
+ rowmax = (d__1 = ap[i__2].r, abs(d__1)) + (d__2 =
+ d_imag(&ap[kx]), abs(d__2));
+ jmax = j;
+ }
+ kx = kx + *n - j;
+/* L70: */
+ }
+ kpc = npp - (*n - imax + 1) * (*n - imax + 2) / 2 + 1;
+ if (imax < *n) {
+ i__1 = *n - imax;
+ jmax = imax + izamax_(&i__1, &ap[kpc + 1], &c__1);
+/* Computing MAX */
+ i__1 = kpc + jmax - imax;
+ d__3 = rowmax, d__4 = (d__1 = ap[i__1].r, abs(d__1)) + (
+ d__2 = d_imag(&ap[kpc + jmax - imax]), abs(d__2));
+ rowmax = max(d__3,d__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = kpc;
+ if ((d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[
+ kpc]), abs(d__2)) >= alpha * rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k + kstep - 1;
+ if (kstep == 2) {
+ knc = knc + *n - k + 1;
+ }
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the trailing */
+/* submatrix A(k:n,k:n) */
+
+ if (kp < *n) {
+ i__1 = *n - kp;
+ zswap_(&i__1, &ap[knc + kp - kk + 1], &c__1, &ap[kpc + 1],
+ &c__1);
+ }
+ kx = knc + kp - kk;
+ i__1 = kp - 1;
+ for (j = kk + 1; j <= i__1; ++j) {
+ kx = kx + *n - j + 1;
+ i__2 = knc + j - kk;
+ t.r = ap[i__2].r, t.i = ap[i__2].i;
+ i__2 = knc + j - kk;
+ i__3 = kx;
+ ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
+ i__2 = kx;
+ ap[i__2].r = t.r, ap[i__2].i = t.i;
+/* L80: */
+ }
+ i__1 = knc;
+ t.r = ap[i__1].r, t.i = ap[i__1].i;
+ i__1 = knc;
+ i__2 = kpc;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kpc;
+ ap[i__1].r = t.r, ap[i__1].i = t.i;
+ if (kstep == 2) {
+ i__1 = kc + 1;
+ t.r = ap[i__1].r, t.i = ap[i__1].i;
+ i__1 = kc + 1;
+ i__2 = kc + kp - k;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kc + kp - k;
+ ap[i__1].r = t.r, ap[i__1].i = t.i;
+ }
+ }
+
+/* Update the trailing submatrix */
+
+ if (kstep == 1) {
+
+/* 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 < *n) {
+
+/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
+
+/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */
+
+ z_div(&z__1, &c_b1, &ap[kc]);
+ r1.r = z__1.r, r1.i = z__1.i;
+ i__1 = *n - k;
+ z__1.r = -r1.r, z__1.i = -r1.i;
+ zspr_(uplo, &i__1, &z__1, &ap[kc + 1], &c__1, &ap[kc + *n
+ - k + 1]);
+
+/* Store L(k) in column K */
+
+ i__1 = *n - k;
+ zscal_(&i__1, &r1, &ap[kc + 1], &c__1);
+ }
+ } 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 */
+
+ if (k < *n - 1) {
+
+/* 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) )' */
+/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' */
+
+/* where L(k) and L(k+1) are the k-th and (k+1)-th */
+/* columns of L */
+
+ i__1 = k + 1 + (k - 1) * ((*n << 1) - k) / 2;
+ d21.r = ap[i__1].r, d21.i = ap[i__1].i;
+ z_div(&z__1, &ap[k + 1 + k * ((*n << 1) - k - 1) / 2], &
+ d21);
+ d11.r = z__1.r, d11.i = z__1.i;
+ z_div(&z__1, &ap[k + (k - 1) * ((*n << 1) - k) / 2], &d21)
+ ;
+ d22.r = z__1.r, d22.i = z__1.i;
+ z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r *
+ d22.i + d11.i * d22.r;
+ z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.;
+ z_div(&z__1, &c_b1, &z__2);
+ t.r = z__1.r, t.i = z__1.i;
+ z_div(&z__1, &t, &d21);
+ d21.r = z__1.r, d21.i = z__1.i;
+
+ i__1 = *n;
+ for (j = k + 2; j <= i__1; ++j) {
+ i__2 = j + (k - 1) * ((*n << 1) - k) / 2;
+ z__3.r = d11.r * ap[i__2].r - d11.i * ap[i__2].i,
+ z__3.i = d11.r * ap[i__2].i + d11.i * ap[i__2]
+ .r;
+ i__3 = j + k * ((*n << 1) - k - 1) / 2;
+ z__2.r = z__3.r - ap[i__3].r, z__2.i = z__3.i - ap[
+ i__3].i;
+ z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i =
+ d21.r * z__2.i + d21.i * z__2.r;
+ wk.r = z__1.r, wk.i = z__1.i;
+ i__2 = j + k * ((*n << 1) - k - 1) / 2;
+ z__3.r = d22.r * ap[i__2].r - d22.i * ap[i__2].i,
+ z__3.i = d22.r * ap[i__2].i + d22.i * ap[i__2]
+ .r;
+ i__3 = j + (k - 1) * ((*n << 1) - k) / 2;
+ z__2.r = z__3.r - ap[i__3].r, z__2.i = z__3.i - ap[
+ i__3].i;
+ z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i =
+ d21.r * z__2.i + d21.i * z__2.r;
+ wkp1.r = z__1.r, wkp1.i = z__1.i;
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + (j - 1) * ((*n << 1) - j) / 2;
+ i__4 = i__ + (j - 1) * ((*n << 1) - j) / 2;
+ i__5 = i__ + (k - 1) * ((*n << 1) - k) / 2;
+ z__3.r = ap[i__5].r * wk.r - ap[i__5].i * wk.i,
+ z__3.i = ap[i__5].r * wk.i + ap[i__5].i *
+ wk.r;
+ z__2.r = ap[i__4].r - z__3.r, z__2.i = ap[i__4].i
+ - z__3.i;
+ i__6 = i__ + k * ((*n << 1) - k - 1) / 2;
+ z__4.r = ap[i__6].r * wkp1.r - ap[i__6].i *
+ wkp1.i, z__4.i = ap[i__6].r * wkp1.i + ap[
+ i__6].i * wkp1.r;
+ z__1.r = z__2.r - z__4.r, z__1.i = z__2.i -
+ z__4.i;
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+/* L90: */
+ }
+ i__2 = j + (k - 1) * ((*n << 1) - k) / 2;
+ ap[i__2].r = wk.r, ap[i__2].i = wk.i;
+ i__2 = j + k * ((*n << 1) - k - 1) / 2;
+ ap[i__2].r = wkp1.r, ap[i__2].i = wkp1.i;
+/* L100: */
+ }
+ }
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k + 1] = -kp;
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kstep;
+ kc = knc + *n - k + 2;
+ goto L60;
+
+ }
+
+L110:
+ return 0;
+
+/* End of ZSPTRF */
+
+} /* zsptrf_ */
diff --git a/SRC/zsptri.c b/SRC/zsptri.c
new file mode 100644
index 0000000..82a3cfc
--- /dev/null
+++ b/SRC/zsptri.c
@@ -0,0 +1,508 @@
+/* zsptri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static doublecomplex c_b2 = {0.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zsptri_(char *uplo, integer *n, doublecomplex *ap,
+ integer *ipiv, doublecomplex *work, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ doublecomplex d__;
+ integer j, k;
+ doublecomplex t, ak;
+ integer kc, kp, kx, kpc, npp;
+ doublecomplex akp1, temp, akkp1;
+ extern logical lsame_(char *, char *);
+ integer kstep;
+ logical upper;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern /* Double Complex */ VOID zdotu_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zspmv_(char *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *), xerbla_(
+ char *, integer *);
+ integer kcnext;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSPTRI computes the inverse of a complex symmetric indefinite matrix */
+/* A in packed storage using the factorization A = U*D*U**T or */
+/* A = L*D*L**T computed by ZSPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L as computed by ZSPTRF, */
+/* stored as a packed triangular matrix. */
+
+/* On exit, if INFO = 0, the (symmetric) inverse of the original */
+/* matrix, stored as a packed triangular matrix. The j-th column */
+/* of inv(A) is stored in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by ZSPTRF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* INFO (output) 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. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --work;
+ --ipiv;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZSPTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ kp = *n * (*n + 1) / 2;
+ for (*info = *n; *info >= 1; --(*info)) {
+ i__1 = kp;
+ if (ipiv[*info] > 0 && (ap[i__1].r == 0. && ap[i__1].i == 0.)) {
+ return 0;
+ }
+ kp -= *info;
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ kp = 1;
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ i__2 = kp;
+ if (ipiv[*info] > 0 && (ap[i__2].r == 0. && ap[i__2].i == 0.)) {
+ return 0;
+ }
+ kp = kp + *n - *info + 1;
+/* L20: */
+ }
+ }
+ *info = 0;
+
+ if (upper) {
+
+/* Compute inv(A) from the factorization A = U*D*U'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+ kc = 1;
+L30:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L50;
+ }
+
+ kcnext = kc + k;
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = kc + k - 1;
+ z_div(&z__1, &c_b1, &ap[kc + k - 1]);
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+
+/* Compute column K of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ zcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zspmv_(uplo, &i__1, &z__1, &ap[1], &work[1], &c__1, &c_b2, &
+ ap[kc], &c__1);
+ i__1 = kc + k - 1;
+ i__2 = kc + k - 1;
+ i__3 = k - 1;
+ zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kc], &c__1);
+ z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = kcnext + k - 1;
+ t.r = ap[i__1].r, t.i = ap[i__1].i;
+ z_div(&z__1, &ap[kc + k - 1], &t);
+ ak.r = z__1.r, ak.i = z__1.i;
+ z_div(&z__1, &ap[kcnext + k], &t);
+ akp1.r = z__1.r, akp1.i = z__1.i;
+ z_div(&z__1, &ap[kcnext + k - 1], &t);
+ akkp1.r = z__1.r, akkp1.i = z__1.i;
+ z__3.r = ak.r * akp1.r - ak.i * akp1.i, z__3.i = ak.r * akp1.i +
+ ak.i * akp1.r;
+ z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.;
+ z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + t.i
+ * z__2.r;
+ d__.r = z__1.r, d__.i = z__1.i;
+ i__1 = kc + k - 1;
+ z_div(&z__1, &akp1, &d__);
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ i__1 = kcnext + k;
+ z_div(&z__1, &ak, &d__);
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ i__1 = kcnext + k - 1;
+ z__2.r = -akkp1.r, z__2.i = -akkp1.i;
+ z_div(&z__1, &z__2, &d__);
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+
+/* Compute columns K and K+1 of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ zcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zspmv_(uplo, &i__1, &z__1, &ap[1], &work[1], &c__1, &c_b2, &
+ ap[kc], &c__1);
+ i__1 = kc + k - 1;
+ i__2 = kc + k - 1;
+ i__3 = k - 1;
+ zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kc], &c__1);
+ z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ i__1 = kcnext + k - 1;
+ i__2 = kcnext + k - 1;
+ i__3 = k - 1;
+ zdotu_(&z__2, &i__3, &ap[kc], &c__1, &ap[kcnext], &c__1);
+ z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ i__1 = k - 1;
+ zcopy_(&i__1, &ap[kcnext], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zspmv_(uplo, &i__1, &z__1, &ap[1], &work[1], &c__1, &c_b2, &
+ ap[kcnext], &c__1);
+ i__1 = kcnext + k;
+ i__2 = kcnext + k;
+ i__3 = k - 1;
+ zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kcnext], &c__1);
+ z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ }
+ kstep = 2;
+ kcnext = kcnext + k + 1;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the leading */
+/* submatrix A(1:k+1,1:k+1) */
+
+ kpc = (kp - 1) * kp / 2 + 1;
+ i__1 = kp - 1;
+ zswap_(&i__1, &ap[kc], &c__1, &ap[kpc], &c__1);
+ kx = kpc + kp - 1;
+ i__1 = k - 1;
+ for (j = kp + 1; j <= i__1; ++j) {
+ kx = kx + j - 1;
+ i__2 = kc + j - 1;
+ temp.r = ap[i__2].r, temp.i = ap[i__2].i;
+ i__2 = kc + j - 1;
+ i__3 = kx;
+ ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
+ i__2 = kx;
+ ap[i__2].r = temp.r, ap[i__2].i = temp.i;
+/* L40: */
+ }
+ i__1 = kc + k - 1;
+ temp.r = ap[i__1].r, temp.i = ap[i__1].i;
+ i__1 = kc + k - 1;
+ i__2 = kpc + kp - 1;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kpc + kp - 1;
+ ap[i__1].r = temp.r, ap[i__1].i = temp.i;
+ if (kstep == 2) {
+ i__1 = kc + k + k - 1;
+ temp.r = ap[i__1].r, temp.i = ap[i__1].i;
+ i__1 = kc + k + k - 1;
+ i__2 = kc + k + kp - 1;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kc + k + kp - 1;
+ ap[i__1].r = temp.r, ap[i__1].i = temp.i;
+ }
+ }
+
+ k += kstep;
+ kc = kcnext;
+ goto L30;
+L50:
+
+ ;
+ } else {
+
+/* Compute inv(A) from the factorization A = L*D*L'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ npp = *n * (*n + 1) / 2;
+ k = *n;
+ kc = npp;
+L60:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L80;
+ }
+
+ kcnext = kc - (*n - k + 2);
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = kc;
+ z_div(&z__1, &c_b1, &ap[kc]);
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+
+/* Compute column K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ zcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zspmv_(uplo, &i__1, &z__1, &ap[kc + *n - k + 1], &work[1], &
+ c__1, &c_b2, &ap[kc + 1], &c__1);
+ i__1 = kc;
+ i__2 = kc;
+ i__3 = *n - k;
+ zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1);
+ z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = kcnext + 1;
+ t.r = ap[i__1].r, t.i = ap[i__1].i;
+ z_div(&z__1, &ap[kcnext], &t);
+ ak.r = z__1.r, ak.i = z__1.i;
+ z_div(&z__1, &ap[kc], &t);
+ akp1.r = z__1.r, akp1.i = z__1.i;
+ z_div(&z__1, &ap[kcnext + 1], &t);
+ akkp1.r = z__1.r, akkp1.i = z__1.i;
+ z__3.r = ak.r * akp1.r - ak.i * akp1.i, z__3.i = ak.r * akp1.i +
+ ak.i * akp1.r;
+ z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.;
+ z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + t.i
+ * z__2.r;
+ d__.r = z__1.r, d__.i = z__1.i;
+ i__1 = kcnext;
+ z_div(&z__1, &akp1, &d__);
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ i__1 = kc;
+ z_div(&z__1, &ak, &d__);
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ i__1 = kcnext + 1;
+ z__2.r = -akkp1.r, z__2.i = -akkp1.i;
+ z_div(&z__1, &z__2, &d__);
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+
+/* Compute columns K-1 and K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ zcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zspmv_(uplo, &i__1, &z__1, &ap[kc + (*n - k + 1)], &work[1], &
+ c__1, &c_b2, &ap[kc + 1], &c__1);
+ i__1 = kc;
+ i__2 = kc;
+ i__3 = *n - k;
+ zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1);
+ z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ i__1 = kcnext + 1;
+ i__2 = kcnext + 1;
+ i__3 = *n - k;
+ zdotu_(&z__2, &i__3, &ap[kc + 1], &c__1, &ap[kcnext + 2], &
+ c__1);
+ z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ i__1 = *n - k;
+ zcopy_(&i__1, &ap[kcnext + 2], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zspmv_(uplo, &i__1, &z__1, &ap[kc + (*n - k + 1)], &work[1], &
+ c__1, &c_b2, &ap[kcnext + 2], &c__1);
+ i__1 = kcnext;
+ i__2 = kcnext;
+ i__3 = *n - k;
+ zdotu_(&z__2, &i__3, &work[1], &c__1, &ap[kcnext + 2], &c__1);
+ z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ }
+ kstep = 2;
+ kcnext -= *n - k + 3;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the trailing */
+/* submatrix A(k-1:n,k-1:n) */
+
+ kpc = npp - (*n - kp + 1) * (*n - kp + 2) / 2 + 1;
+ if (kp < *n) {
+ i__1 = *n - kp;
+ zswap_(&i__1, &ap[kc + kp - k + 1], &c__1, &ap[kpc + 1], &
+ c__1);
+ }
+ kx = kc + kp - k;
+ i__1 = kp - 1;
+ for (j = k + 1; j <= i__1; ++j) {
+ kx = kx + *n - j + 1;
+ i__2 = kc + j - k;
+ temp.r = ap[i__2].r, temp.i = ap[i__2].i;
+ i__2 = kc + j - k;
+ i__3 = kx;
+ ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
+ i__2 = kx;
+ ap[i__2].r = temp.r, ap[i__2].i = temp.i;
+/* L70: */
+ }
+ i__1 = kc;
+ temp.r = ap[i__1].r, temp.i = ap[i__1].i;
+ i__1 = kc;
+ i__2 = kpc;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kpc;
+ ap[i__1].r = temp.r, ap[i__1].i = temp.i;
+ if (kstep == 2) {
+ i__1 = kc - *n + k - 1;
+ temp.r = ap[i__1].r, temp.i = ap[i__1].i;
+ i__1 = kc - *n + k - 1;
+ i__2 = kc - *n + kp - 1;
+ ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
+ i__1 = kc - *n + kp - 1;
+ ap[i__1].r = temp.r, ap[i__1].i = temp.i;
+ }
+ }
+
+ k -= kstep;
+ kc = kcnext;
+ goto L60;
+L80:
+ ;
+ }
+
+ return 0;
+
+/* End of ZSPTRI */
+
+} /* zsptri_ */
diff --git a/SRC/zsptrs.c b/SRC/zsptrs.c
new file mode 100644
index 0000000..ecf7b91
--- /dev/null
+++ b/SRC/zsptrs.c
@@ -0,0 +1,503 @@
+/* zsptrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zsptrs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *ap, integer *ipiv, doublecomplex *b, integer *ldb,
+ integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer j, k;
+ doublecomplex ak, bk;
+ integer kc, kp;
+ doublecomplex akm1, bkm1, akm1k;
+ extern logical lsame_(char *, char *);
+ doublecomplex denom;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int zgeru_(integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSPTRS solves a system of linear equations A*X = B with a complex */
+/* symmetric matrix A stored in packed format using the factorization */
+/* A = U*D*U**T or A = L*D*L**T computed by ZSPTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by ZSPTRF, stored as a */
+/* packed triangular matrix. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by ZSPTRF. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ap;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZSPTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B, where A = U*D*U'. */
+
+/* First solve U*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L10:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L30;
+ }
+
+ kc -= k;
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &ap[kc], &c__1, &b[k + b_dim1], ldb, &
+ b[b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ z_div(&z__1, &c_b1, &ap[kc + k - 1]);
+ zscal_(nrhs, &z__1, &b[k + b_dim1], ldb);
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K-1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k - 1) {
+ zswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ i__1 = k - 2;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &ap[kc], &c__1, &b[k + b_dim1], ldb, &
+ b[b_dim1 + 1], ldb);
+ i__1 = k - 2;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &ap[kc - (k - 1)], &c__1, &b[k - 1 +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = kc + k - 2;
+ akm1k.r = ap[i__1].r, akm1k.i = ap[i__1].i;
+ z_div(&z__1, &ap[kc - 1], &akm1k);
+ akm1.r = z__1.r, akm1.i = z__1.i;
+ z_div(&z__1, &ap[kc + k - 1], &akm1k);
+ ak.r = z__1.r, ak.i = z__1.i;
+ z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i +
+ akm1.i * ak.r;
+ z__1.r = z__2.r - 1., z__1.i = z__2.i - 0.;
+ denom.r = z__1.r, denom.i = z__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ z_div(&z__1, &b[k - 1 + j * b_dim1], &akm1k);
+ bkm1.r = z__1.r, bkm1.i = z__1.i;
+ z_div(&z__1, &b[k + j * b_dim1], &akm1k);
+ bk.r = z__1.r, bk.i = z__1.i;
+ i__2 = k - 1 + j * b_dim1;
+ z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r *
+ bkm1.i + ak.i * bkm1.r;
+ z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i;
+ z_div(&z__1, &z__2, &denom);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + j * b_dim1;
+ z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r *
+ bk.i + akm1.i * bk.r;
+ z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i;
+ z_div(&z__1, &z__2, &denom);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L20: */
+ }
+ kc = kc - k + 1;
+ k += -2;
+ }
+
+ goto L10;
+L30:
+
+/* Next solve U'*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+ kc = 1;
+L40:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L50;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(U'(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Transpose", &i__1, nrhs, &z__1, &b[b_offset], ldb, &ap[kc]
+, &c__1, &c_b1, &b[k + b_dim1], ldb);
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ kc += k;
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Transpose", &i__1, nrhs, &z__1, &b[b_offset], ldb, &ap[kc]
+, &c__1, &c_b1, &b[k + b_dim1], ldb);
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Transpose", &i__1, nrhs, &z__1, &b[b_offset], ldb, &ap[kc
+ + k], &c__1, &c_b1, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ kc = kc + (k << 1) + 1;
+ k += 2;
+ }
+
+ goto L40;
+L50:
+
+ ;
+ } else {
+
+/* Solve A*X = B, where A = L*D*L'. */
+
+/* First solve L*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+ kc = 1;
+L60:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L80;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &ap[kc + 1], &c__1, &b[k + b_dim1],
+ ldb, &b[k + 1 + b_dim1], ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ z_div(&z__1, &c_b1, &ap[kc]);
+ zscal_(nrhs, &z__1, &b[k + b_dim1], ldb);
+ kc = kc + *n - k + 1;
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K+1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k + 1) {
+ zswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ if (k < *n - 1) {
+ i__1 = *n - k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &ap[kc + 2], &c__1, &b[k + b_dim1],
+ ldb, &b[k + 2 + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &ap[kc + *n - k + 2], &c__1, &b[k
+ + 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = kc + 1;
+ akm1k.r = ap[i__1].r, akm1k.i = ap[i__1].i;
+ z_div(&z__1, &ap[kc], &akm1k);
+ akm1.r = z__1.r, akm1.i = z__1.i;
+ z_div(&z__1, &ap[kc + *n - k + 1], &akm1k);
+ ak.r = z__1.r, ak.i = z__1.i;
+ z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i +
+ akm1.i * ak.r;
+ z__1.r = z__2.r - 1., z__1.i = z__2.i - 0.;
+ denom.r = z__1.r, denom.i = z__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ z_div(&z__1, &b[k + j * b_dim1], &akm1k);
+ bkm1.r = z__1.r, bkm1.i = z__1.i;
+ z_div(&z__1, &b[k + 1 + j * b_dim1], &akm1k);
+ bk.r = z__1.r, bk.i = z__1.i;
+ i__2 = k + j * b_dim1;
+ z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r *
+ bkm1.i + ak.i * bkm1.r;
+ z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i;
+ z_div(&z__1, &z__2, &denom);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r *
+ bk.i + akm1.i * bk.r;
+ z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i;
+ z_div(&z__1, &z__2, &denom);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L70: */
+ }
+ kc = kc + (*n - k << 1) + 1;
+ k += 2;
+ }
+
+ goto L60;
+L80:
+
+/* Next solve L'*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L90:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L100;
+ }
+
+ kc -= *n - k + 1;
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(L'(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Transpose", &i__1, nrhs, &z__1, &b[k + 1 + b_dim1],
+ ldb, &ap[kc + 1], &c__1, &c_b1, &b[k + b_dim1], ldb);
+ }
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Transpose", &i__1, nrhs, &z__1, &b[k + 1 + b_dim1],
+ ldb, &ap[kc + 1], &c__1, &c_b1, &b[k + b_dim1], ldb);
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Transpose", &i__1, nrhs, &z__1, &b[k + 1 + b_dim1],
+ ldb, &ap[kc - (*n - k)], &c__1, &c_b1, &b[k - 1 +
+ b_dim1], ldb);
+ }
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ kc -= *n - k + 2;
+ k += -2;
+ }
+
+ goto L90;
+L100:
+ ;
+ }
+
+ return 0;
+
+/* End of ZSPTRS */
+
+} /* zsptrs_ */
diff --git a/SRC/zstedc.c b/SRC/zstedc.c
new file mode 100644
index 0000000..f72c69c
--- /dev/null
+++ b/SRC/zstedc.c
@@ -0,0 +1,497 @@
+/* zstedc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__9 = 9;
+static integer c__0 = 0;
+static integer c__2 = 2;
+static doublereal c_b17 = 0.;
+static doublereal c_b18 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int zstedc_(char *compz, integer *n, doublereal *d__,
+ doublereal *e, doublecomplex *z__, integer *ldz, doublecomplex *work,
+ integer *lwork, doublereal *rwork, integer *lrwork, integer *iwork,
+ integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double log(doublereal);
+ integer pow_ii(integer *, integer *);
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, m;
+ doublereal p;
+ integer ii, ll, lgn;
+ doublereal eps, tiny;
+ extern logical lsame_(char *, char *);
+ integer lwmin, start;
+ extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zlaed0_(integer *, integer *,
+ doublereal *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), dstedc_(char *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, integer *, integer *, integer *), dlaset_(
+ char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer finish;
+ extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
+ extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
+ integer *), zlacrm_(integer *, integer *, doublecomplex *,
+ integer *, doublereal *, integer *, doublecomplex *, integer *,
+ doublereal *);
+ integer liwmin, icompz;
+ extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *);
+ doublereal orgnrm;
+ integer lrwmin;
+ logical lquery;
+ integer smlsiz;
+ extern /* Subroutine */ int zsteqr_(char *, integer *, doublereal *,
+ doublereal *, doublecomplex *, integer *, doublereal *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSTEDC computes all eigenvalues and, optionally, eigenvectors of a */
+/* symmetric tridiagonal matrix using the divide and conquer method. */
+/* The eigenvectors of a full or band complex Hermitian matrix can also */
+/* be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this */
+/* matrix to tridiagonal form. */
+
+/* This code makes very mild assumptions about floating point */
+/* arithmetic. It will work on machines with a guard digit in */
+/* add/subtract, or on those binary machines without guard digits */
+/* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */
+/* It could conceivably fail on hexadecimal or decimal machines */
+/* without guard digits, but we know of none. See DLAED3 for details. */
+
+/* Arguments */
+/* ========= */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only. */
+/* = 'I': Compute eigenvectors of tridiagonal matrix also. */
+/* = 'V': Compute eigenvectors of original Hermitian matrix */
+/* also. On entry, Z contains the unitary matrix used */
+/* to reduce the original matrix to tridiagonal form. */
+
+/* N (input) INTEGER */
+/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the diagonal elements of the tridiagonal matrix. */
+/* On exit, if INFO = 0, the eigenvalues in ascending order. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* On entry, the subdiagonal elements of the tridiagonal matrix. */
+/* On exit, E has been destroyed. */
+
+/* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) */
+/* On entry, if COMPZ = 'V', then Z contains the unitary */
+/* matrix used in the reduction to tridiagonal form. */
+/* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */
+/* orthonormal eigenvectors of the original Hermitian matrix, */
+/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */
+/* of the symmetric tridiagonal matrix. */
+/* If COMPZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1. */
+/* If eigenvectors are desired, then LDZ >= max(1,N). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If COMPZ = 'N' or 'I', or N <= 1, LWORK must be at least 1. */
+/* If COMPZ = 'V' and N > 1, LWORK must be at least N*N. */
+/* Note that for COMPZ = 'V', then if N is less than or */
+/* equal to the minimum divide size, usually 25, then LWORK need */
+/* only be 1. */
+
+/* If LWORK = -1, then a workspace query is assumed; the routine */
+/* only calculates the optimal sizes of the WORK, RWORK and */
+/* IWORK arrays, returns these values as the first entries of */
+/* the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* RWORK (workspace/output) DOUBLE PRECISION array, */
+/* dimension (LRWORK) */
+/* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. */
+
+/* LRWORK (input) INTEGER */
+/* The dimension of the array RWORK. */
+/* If COMPZ = 'N' or N <= 1, LRWORK must be at least 1. */
+/* If COMPZ = 'V' and N > 1, LRWORK must be at least */
+/* 1 + 3*N + 2*N*lg N + 3*N**2 , */
+/* where lg( N ) = smallest integer k such */
+/* that 2**k >= N. */
+/* If COMPZ = 'I' and N > 1, LRWORK must be at least */
+/* 1 + 4*N + 2*N**2 . */
+/* Note that for COMPZ = 'I' or 'V', then if N is less than or */
+/* equal to the minimum divide size, usually 25, then LRWORK */
+/* need only be max(1,2*(N-1)). */
+
+/* If LRWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. */
+/* If COMPZ = 'N' or N <= 1, LIWORK must be at least 1. */
+/* If COMPZ = 'V' or N > 1, LIWORK must be at least */
+/* 6 + 6*N + 5*N*lg N. */
+/* If COMPZ = 'I' or N > 1, LIWORK must be at least */
+/* 3 + 5*N . */
+/* Note that for COMPZ = 'I' or 'V', then if N is less than or */
+/* equal to the minimum divide size, usually 25, then LIWORK */
+/* need only be 1. */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal sizes of the WORK, RWORK */
+/* and IWORK arrays, returns these values as the first entries */
+/* of the WORK, RWORK and IWORK arrays, and no error message */
+/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: The algorithm failed to compute an eigenvalue while */
+/* working on the submatrix lying in rows and columns */
+/* INFO/(N+1) through mod(INFO,N+1). */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Jeff Rutter, Computer Science Division, University of California */
+/* at Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
+
+ if (lsame_(compz, "N")) {
+ icompz = 0;
+ } else if (lsame_(compz, "V")) {
+ icompz = 1;
+ } else if (lsame_(compz, "I")) {
+ icompz = 2;
+ } else {
+ icompz = -1;
+ }
+ if (icompz < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
+ *info = -6;
+ }
+
+ if (*info == 0) {
+
+/* Compute the workspace requirements */
+
+ smlsiz = ilaenv_(&c__9, "ZSTEDC", " ", &c__0, &c__0, &c__0, &c__0);
+ if (*n <= 1 || icompz == 0) {
+ lwmin = 1;
+ liwmin = 1;
+ lrwmin = 1;
+ } else if (*n <= smlsiz) {
+ lwmin = 1;
+ liwmin = 1;
+ lrwmin = *n - 1 << 1;
+ } else if (icompz == 1) {
+ lgn = (integer) (log((doublereal) (*n)) / log(2.));
+ if (pow_ii(&c__2, &lgn) < *n) {
+ ++lgn;
+ }
+ if (pow_ii(&c__2, &lgn) < *n) {
+ ++lgn;
+ }
+ lwmin = *n * *n;
+/* Computing 2nd power */
+ i__1 = *n;
+ lrwmin = *n * 3 + 1 + (*n << 1) * lgn + i__1 * i__1 * 3;
+ liwmin = *n * 6 + 6 + *n * 5 * lgn;
+ } else if (icompz == 2) {
+ lwmin = 1;
+/* Computing 2nd power */
+ i__1 = *n;
+ lrwmin = (*n << 2) + 1 + (i__1 * i__1 << 1);
+ liwmin = *n * 5 + 3;
+ }
+ work[1].r = (doublereal) lwmin, work[1].i = 0.;
+ rwork[1] = (doublereal) lrwmin;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -8;
+ } else if (*lrwork < lrwmin && ! lquery) {
+ *info = -10;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZSTEDC", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+ if (*n == 1) {
+ if (icompz != 0) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1., z__[i__1].i = 0.;
+ }
+ return 0;
+ }
+
+/* If the following conditional clause is removed, then the routine */
+/* will use the Divide and Conquer routine to compute only the */
+/* eigenvalues, which requires (3N + 3N**2) real workspace and */
+/* (2 + 5N + 2N lg(N)) integer workspace. */
+/* Since on many architectures DSTERF is much faster than any other */
+/* algorithm for finding eigenvalues only, it is used here */
+/* as the default. If the conditional clause is removed, then */
+/* information on the size of workspace needs to be changed. */
+
+/* If COMPZ = 'N', use DSTERF to compute the eigenvalues. */
+
+ if (icompz == 0) {
+ dsterf_(n, &d__[1], &e[1], info);
+ goto L70;
+ }
+
+/* If N is smaller than the minimum divide size (SMLSIZ+1), then */
+/* solve the problem with another solver. */
+
+ if (*n <= smlsiz) {
+
+ zsteqr_(compz, n, &d__[1], &e[1], &z__[z_offset], ldz, &rwork[1],
+ info);
+
+ } else {
+
+/* If COMPZ = 'I', we simply call DSTEDC instead. */
+
+ if (icompz == 2) {
+ dlaset_("Full", n, n, &c_b17, &c_b18, &rwork[1], n);
+ ll = *n * *n + 1;
+ i__1 = *lrwork - ll + 1;
+ dstedc_("I", n, &d__[1], &e[1], &rwork[1], n, &rwork[ll], &i__1, &
+ iwork[1], liwork, info);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * z_dim1;
+ i__4 = (j - 1) * *n + i__;
+ z__[i__3].r = rwork[i__4], z__[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ goto L70;
+ }
+
+/* From now on, only option left to be handled is COMPZ = 'V', */
+/* i.e. ICOMPZ = 1. */
+
+/* Scale. */
+
+ orgnrm = dlanst_("M", n, &d__[1], &e[1]);
+ if (orgnrm == 0.) {
+ goto L70;
+ }
+
+ eps = dlamch_("Epsilon");
+
+ start = 1;
+
+/* while ( START <= N ) */
+
+L30:
+ if (start <= *n) {
+
+/* Let FINISH be the position of the next subdiagonal entry */
+/* such that E( FINISH ) <= TINY or FINISH = N if no such */
+/* subdiagonal exists. The matrix identified by the elements */
+/* between START and FINISH constitutes an independent */
+/* sub-problem. */
+
+ finish = start;
+L40:
+ if (finish < *n) {
+ tiny = eps * sqrt((d__1 = d__[finish], abs(d__1))) * sqrt((
+ d__2 = d__[finish + 1], abs(d__2)));
+ if ((d__1 = e[finish], abs(d__1)) > tiny) {
+ ++finish;
+ goto L40;
+ }
+ }
+
+/* (Sub) Problem determined. Compute its size and solve it. */
+
+ m = finish - start + 1;
+ if (m > smlsiz) {
+
+/* Scale. */
+
+ orgnrm = dlanst_("M", &m, &d__[start], &e[start]);
+ dlascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &m, &c__1, &d__[
+ start], &m, info);
+ i__1 = m - 1;
+ i__2 = m - 1;
+ dlascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &i__1, &c__1, &e[
+ start], &i__2, info);
+
+ zlaed0_(n, &m, &d__[start], &e[start], &z__[start * z_dim1 +
+ 1], ldz, &work[1], n, &rwork[1], &iwork[1], info);
+ if (*info > 0) {
+ *info = (*info / (m + 1) + start - 1) * (*n + 1) + *info %
+ (m + 1) + start - 1;
+ goto L70;
+ }
+
+/* Scale back. */
+
+ dlascl_("G", &c__0, &c__0, &c_b18, &orgnrm, &m, &c__1, &d__[
+ start], &m, info);
+
+ } else {
+ dsteqr_("I", &m, &d__[start], &e[start], &rwork[1], &m, &
+ rwork[m * m + 1], info);
+ zlacrm_(n, &m, &z__[start * z_dim1 + 1], ldz, &rwork[1], &m, &
+ work[1], n, &rwork[m * m + 1]);
+ zlacpy_("A", n, &m, &work[1], n, &z__[start * z_dim1 + 1],
+ ldz);
+ if (*info > 0) {
+ *info = start * (*n + 1) + finish;
+ goto L70;
+ }
+ }
+
+ start = finish + 1;
+ goto L30;
+ }
+
+/* endwhile */
+
+/* If the problem split any number of times, then the eigenvalues */
+/* will not be properly ordered. Here we permute the eigenvalues */
+/* (and the associated eigenvectors) into ascending order. */
+
+ if (m != *n) {
+
+/* Use Selection Sort to minimize swaps of eigenvectors */
+
+ i__1 = *n;
+ for (ii = 2; ii <= i__1; ++ii) {
+ i__ = ii - 1;
+ k = i__;
+ p = d__[i__];
+ i__2 = *n;
+ for (j = ii; j <= i__2; ++j) {
+ if (d__[j] < p) {
+ k = j;
+ p = d__[j];
+ }
+/* L50: */
+ }
+ if (k != i__) {
+ d__[k] = d__[i__];
+ d__[i__] = p;
+ zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1
+ + 1], &c__1);
+ }
+/* L60: */
+ }
+ }
+ }
+
+L70:
+ work[1].r = (doublereal) lwmin, work[1].i = 0.;
+ rwork[1] = (doublereal) lrwmin;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of ZSTEDC */
+
+} /* zstedc_ */
diff --git a/SRC/zstegr.c b/SRC/zstegr.c
new file mode 100644
index 0000000..3b81fee
--- /dev/null
+++ b/SRC/zstegr.c
@@ -0,0 +1,211 @@
+/* zstegr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zstegr_(char *jobz, char *range, integer *n, doublereal *
+ d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il,
+ integer *iu, doublereal *abstol, integer *m, doublereal *w,
+ doublecomplex *z__, integer *ldz, integer *isuppz, doublereal *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset;
+
+ /* Local variables */
+ logical tryrac;
+ extern /* Subroutine */ int zstemr_(char *, char *, integer *, doublereal
+ *, doublereal *, doublereal *, doublereal *, integer *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *, integer *,
+ integer *, logical *, doublereal *, integer *, integer *, integer
+ *, integer *);
+
+
+
+/* -- LAPACK computational routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSTEGR computes selected eigenvalues and, optionally, eigenvectors */
+/* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */
+/* a well defined set of pairwise different real eigenvalues, the corresponding */
+/* real eigenvectors are pairwise orthogonal. */
+
+/* The spectrum may be computed either completely or partially by specifying */
+/* either an interval (VL,VU] or a range of indices IL:IU for the desired */
+/* eigenvalues. */
+
+/* ZSTEGR is a compatability wrapper around the improved ZSTEMR routine. */
+/* See DSTEMR for further details. */
+
+/* One important change is that the ABSTOL parameter no longer provides any */
+/* benefit and hence is no longer used. */
+
+/* Note : ZSTEGR and ZSTEMR work only on machines which follow */
+/* IEEE-754 floating-point standard in their handling of infinities and */
+/* NaNs. Normal execution may create these exceptiona values and hence */
+/* may abort due to a floating point exception in environments which */
+/* do not conform to the IEEE-754 standard. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the N diagonal elements of the tridiagonal matrix */
+/* T. On exit, D is overwritten. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the (N-1) subdiagonal elements of the tridiagonal */
+/* matrix T in elements 1 to N-1 of E. E(N) need not be set on */
+/* input, but is used internally as workspace. */
+/* On exit, E is overwritten. */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* ABSTOL (input) DOUBLE PRECISION */
+/* Unused. Was the absolute error tolerance for the */
+/* eigenvalues/eigenvectors in previous versions. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* The first M elements contain the selected eigenvalues in */
+/* ascending order. */
+
+/* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M) ) */
+/* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix T */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and an upper bound must be used. */
+/* Supplying N columns is always safe. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', then LDZ >= max(1,N). */
+
+/* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) ) */
+/* The support of the eigenvectors in Z, i.e., the indices */
+/* indicating the nonzero elements in Z. The i-th computed eigenvector */
+/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */
+/* ISUPPZ( 2*i ). This is relevant in the case when the matrix */
+/* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal */
+/* (and minimal) LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,18*N) */
+/* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'. */
+/* 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. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (LIWORK) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. LIWORK >= max(1,10*N) */
+/* if the eigenvectors are desired, and LIWORK >= max(1,8*N) */
+/* if only the eigenvalues are to be computed. */
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal size of the IWORK array, */
+/* returns this value as the first entry of the IWORK array, and */
+/* no error message related to LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* On exit, INFO */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = 1X, internal error in DLARRE, */
+/* if INFO = 2X, internal error in ZLARRV. */
+/* Here, the digit X = ABS( IINFO ) < 10, where IINFO is */
+/* the nonzero error code returned by DLARRE or */
+/* ZLARRV, respectively. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Inderjit Dhillon, IBM Almaden, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, LBNL/NERSC, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --isuppz;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ tryrac = FALSE_;
+ zstemr_(jobz, range, n, &d__[1], &e[1], vl, vu, il, iu, m, &w[1], &z__[
+ z_offset], ldz, n, &isuppz[1], &tryrac, &work[1], lwork, &iwork[1]
+, liwork, info);
+
+/* End of ZSTEGR */
+
+ return 0;
+} /* zstegr_ */
diff --git a/SRC/zstein.c b/SRC/zstein.c
new file mode 100644
index 0000000..0c7f08c
--- /dev/null
+++ b/SRC/zstein.c
@@ -0,0 +1,470 @@
+/* zstein.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zstein_(integer *n, doublereal *d__, doublereal *e,
+ integer *m, doublereal *w, integer *iblock, integer *isplit,
+ doublecomplex *z__, integer *ldz, doublereal *work, integer *iwork,
+ integer *ifail, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4, d__5;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, b1, j1, bn, jr;
+ doublereal xj, scl, eps, sep, nrm, tol;
+ integer its;
+ doublereal xjm, ztr, eps1;
+ integer jblk, nblk, jmax;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ integer iseed[4], gpind, iinfo;
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ doublereal ortol;
+ integer indrv1, indrv2, indrv3, indrv4, indrv5;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlagtf_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *
+, integer *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), dlagts_(
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *);
+ integer nrmchk;
+ extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *,
+ doublereal *);
+ integer blksiz;
+ doublereal onenrm, dtpcrt, pertol;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSTEIN computes the eigenvectors of a real symmetric tridiagonal */
+/* matrix T corresponding to specified eigenvalues, using inverse */
+/* iteration. */
+
+/* The maximum number of iterations allowed for each eigenvector is */
+/* specified by an internal parameter MAXITS (currently set to 5). */
+
+/* Although the eigenvectors are real, they are stored in a complex */
+/* array, which may be passed to ZUNMTR or ZUPMTR for back */
+/* transformation to the eigenvectors of a complex Hermitian matrix */
+/* which was reduced to tridiagonal form. */
+
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix T. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the tridiagonal matrix */
+/* T, stored in elements 1 to N-1. */
+
+/* M (input) INTEGER */
+/* The number of eigenvectors to be found. 0 <= M <= N. */
+
+/* W (input) DOUBLE PRECISION array, dimension (N) */
+/* The first M elements of W contain the eigenvalues for */
+/* which eigenvectors are to be computed. The eigenvalues */
+/* should be grouped by split-off block and ordered from */
+/* smallest to largest within the block. ( The output array */
+/* W from DSTEBZ with ORDER = 'B' is expected here. ) */
+
+/* IBLOCK (input) INTEGER array, dimension (N) */
+/* The submatrix indices associated with the corresponding */
+/* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to */
+/* the first submatrix from the top, =2 if W(i) belongs to */
+/* the second submatrix, etc. ( The output array IBLOCK */
+/* from DSTEBZ is expected here. ) */
+
+/* ISPLIT (input) INTEGER array, dimension (N) */
+/* The splitting points, at which T breaks up into submatrices. */
+/* The first submatrix consists of rows/columns 1 to */
+/* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 */
+/* through ISPLIT( 2 ), etc. */
+/* ( The output array ISPLIT from DSTEBZ is expected here. ) */
+
+/* Z (output) COMPLEX*16 array, dimension (LDZ, M) */
+/* The computed eigenvectors. The eigenvector associated */
+/* with the eigenvalue W(i) is stored in the i-th column of */
+/* Z. Any vector which fails to converge is set to its current */
+/* iterate after MAXITS iterations. */
+/* The imaginary parts of the eigenvectors are set to zero. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (5*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* IFAIL (output) INTEGER array, dimension (M) */
+/* On normal exit, all elements of IFAIL are zero. */
+/* If one or more eigenvectors fail to converge after */
+/* MAXITS iterations, then their indices are stored in */
+/* array IFAIL. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, then i eigenvectors failed to converge */
+/* in MAXITS iterations. Their indices are stored in */
+/* array IFAIL. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* MAXITS INTEGER, default = 5 */
+/* The maximum number of iterations performed. */
+
+/* EXTRA INTEGER, default = 2 */
+/* The number of iterations performed after norm growth */
+/* criterion is satisfied, should be at least 1. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --w;
+ --iblock;
+ --isplit;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+ --iwork;
+ --ifail;
+
+ /* Function Body */
+ *info = 0;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ifail[i__] = 0;
+/* L10: */
+ }
+
+ if (*n < 0) {
+ *info = -1;
+ } else if (*m < 0 || *m > *n) {
+ *info = -4;
+ } else if (*ldz < max(1,*n)) {
+ *info = -9;
+ } else {
+ i__1 = *m;
+ for (j = 2; j <= i__1; ++j) {
+ if (iblock[j] < iblock[j - 1]) {
+ *info = -6;
+ goto L30;
+ }
+ if (iblock[j] == iblock[j - 1] && w[j] < w[j - 1]) {
+ *info = -5;
+ goto L30;
+ }
+/* L20: */
+ }
+L30:
+ ;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZSTEIN", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *m == 0) {
+ return 0;
+ } else if (*n == 1) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1., z__[i__1].i = 0.;
+ return 0;
+ }
+
+/* Get machine constants. */
+
+ eps = dlamch_("Precision");
+
+/* Initialize seed for random number generator DLARNV. */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = 1;
+/* L40: */
+ }
+
+/* Initialize pointers. */
+
+ indrv1 = 0;
+ indrv2 = indrv1 + *n;
+ indrv3 = indrv2 + *n;
+ indrv4 = indrv3 + *n;
+ indrv5 = indrv4 + *n;
+
+/* Compute eigenvectors of matrix blocks. */
+
+ j1 = 1;
+ i__1 = iblock[*m];
+ for (nblk = 1; nblk <= i__1; ++nblk) {
+
+/* Find starting and ending indices of block nblk. */
+
+ if (nblk == 1) {
+ b1 = 1;
+ } else {
+ b1 = isplit[nblk - 1] + 1;
+ }
+ bn = isplit[nblk];
+ blksiz = bn - b1 + 1;
+ if (blksiz == 1) {
+ goto L60;
+ }
+ gpind = b1;
+
+/* Compute reorthogonalization criterion and stopping criterion. */
+
+ onenrm = (d__1 = d__[b1], abs(d__1)) + (d__2 = e[b1], abs(d__2));
+/* Computing MAX */
+ d__3 = onenrm, d__4 = (d__1 = d__[bn], abs(d__1)) + (d__2 = e[bn - 1],
+ abs(d__2));
+ onenrm = max(d__3,d__4);
+ i__2 = bn - 1;
+ for (i__ = b1 + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__4 = onenrm, d__5 = (d__1 = d__[i__], abs(d__1)) + (d__2 = e[
+ i__ - 1], abs(d__2)) + (d__3 = e[i__], abs(d__3));
+ onenrm = max(d__4,d__5);
+/* L50: */
+ }
+ ortol = onenrm * .001;
+
+ dtpcrt = sqrt(.1 / blksiz);
+
+/* Loop through eigenvalues of block nblk. */
+
+L60:
+ jblk = 0;
+ i__2 = *m;
+ for (j = j1; j <= i__2; ++j) {
+ if (iblock[j] != nblk) {
+ j1 = j;
+ goto L180;
+ }
+ ++jblk;
+ xj = w[j];
+
+/* Skip all the work if the block size is one. */
+
+ if (blksiz == 1) {
+ work[indrv1 + 1] = 1.;
+ goto L140;
+ }
+
+/* If eigenvalues j and j-1 are too close, add a relatively */
+/* small perturbation. */
+
+ if (jblk > 1) {
+ eps1 = (d__1 = eps * xj, abs(d__1));
+ pertol = eps1 * 10.;
+ sep = xj - xjm;
+ if (sep < pertol) {
+ xj = xjm + pertol;
+ }
+ }
+
+ its = 0;
+ nrmchk = 0;
+
+/* Get random starting vector. */
+
+ dlarnv_(&c__2, iseed, &blksiz, &work[indrv1 + 1]);
+
+/* Copy the matrix T so it won't be destroyed in factorization. */
+
+ dcopy_(&blksiz, &d__[b1], &c__1, &work[indrv4 + 1], &c__1);
+ i__3 = blksiz - 1;
+ dcopy_(&i__3, &e[b1], &c__1, &work[indrv2 + 2], &c__1);
+ i__3 = blksiz - 1;
+ dcopy_(&i__3, &e[b1], &c__1, &work[indrv3 + 1], &c__1);
+
+/* Compute LU factors with partial pivoting ( PT = LU ) */
+
+ tol = 0.;
+ dlagtf_(&blksiz, &work[indrv4 + 1], &xj, &work[indrv2 + 2], &work[
+ indrv3 + 1], &tol, &work[indrv5 + 1], &iwork[1], &iinfo);
+
+/* Update iteration count. */
+
+L70:
+ ++its;
+ if (its > 5) {
+ goto L120;
+ }
+
+/* Normalize and scale the righthand side vector Pb. */
+
+/* Computing MAX */
+ d__2 = eps, d__3 = (d__1 = work[indrv4 + blksiz], abs(d__1));
+ scl = blksiz * onenrm * max(d__2,d__3) / dasum_(&blksiz, &work[
+ indrv1 + 1], &c__1);
+ dscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1);
+
+/* Solve the system LU = Pb. */
+
+ dlagts_(&c_n1, &blksiz, &work[indrv4 + 1], &work[indrv2 + 2], &
+ work[indrv3 + 1], &work[indrv5 + 1], &iwork[1], &work[
+ indrv1 + 1], &tol, &iinfo);
+
+/* Reorthogonalize by modified Gram-Schmidt if eigenvalues are */
+/* close enough. */
+
+ if (jblk == 1) {
+ goto L110;
+ }
+ if ((d__1 = xj - xjm, abs(d__1)) > ortol) {
+ gpind = j;
+ }
+ if (gpind != j) {
+ i__3 = j - 1;
+ for (i__ = gpind; i__ <= i__3; ++i__) {
+ ztr = 0.;
+ i__4 = blksiz;
+ for (jr = 1; jr <= i__4; ++jr) {
+ i__5 = b1 - 1 + jr + i__ * z_dim1;
+ ztr += work[indrv1 + jr] * z__[i__5].r;
+/* L80: */
+ }
+ i__4 = blksiz;
+ for (jr = 1; jr <= i__4; ++jr) {
+ i__5 = b1 - 1 + jr + i__ * z_dim1;
+ work[indrv1 + jr] -= ztr * z__[i__5].r;
+/* L90: */
+ }
+/* L100: */
+ }
+ }
+
+/* Check the infinity norm of the iterate. */
+
+L110:
+ jmax = idamax_(&blksiz, &work[indrv1 + 1], &c__1);
+ nrm = (d__1 = work[indrv1 + jmax], abs(d__1));
+
+/* Continue for additional iterations after norm reaches */
+/* stopping criterion. */
+
+ if (nrm < dtpcrt) {
+ goto L70;
+ }
+ ++nrmchk;
+ if (nrmchk < 3) {
+ goto L70;
+ }
+
+ goto L130;
+
+/* If stopping criterion was not satisfied, update info and */
+/* store eigenvector number in array ifail. */
+
+L120:
+ ++(*info);
+ ifail[*info] = j;
+
+/* Accept iterate as jth eigenvector. */
+
+L130:
+ scl = 1. / dnrm2_(&blksiz, &work[indrv1 + 1], &c__1);
+ jmax = idamax_(&blksiz, &work[indrv1 + 1], &c__1);
+ if (work[indrv1 + jmax] < 0.) {
+ scl = -scl;
+ }
+ dscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1);
+L140:
+ i__3 = *n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * z_dim1;
+ z__[i__4].r = 0., z__[i__4].i = 0.;
+/* L150: */
+ }
+ i__3 = blksiz;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = b1 + i__ - 1 + j * z_dim1;
+ i__5 = indrv1 + i__;
+ z__1.r = work[i__5], z__1.i = 0.;
+ z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
+/* L160: */
+ }
+
+/* Save the shift to check eigenvalue spacing at next */
+/* iteration. */
+
+ xjm = xj;
+
+/* L170: */
+ }
+L180:
+ ;
+ }
+
+ return 0;
+
+/* End of ZSTEIN */
+
+} /* zstein_ */
diff --git a/SRC/zstemr.c b/SRC/zstemr.c
new file mode 100644
index 0000000..5e42fb2
--- /dev/null
+++ b/SRC/zstemr.c
@@ -0,0 +1,752 @@
+/* zstemr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b18 = .001;
+
+/* Subroutine */ int zstemr_(char *jobz, char *range, integer *n, doublereal *
+ d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il,
+ integer *iu, integer *m, doublereal *w, doublecomplex *z__, integer *
+ ldz, integer *nzc, integer *isuppz, logical *tryrac, doublereal *work,
+ integer *lwork, integer *iwork, integer *liwork, integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal r1, r2;
+ integer jj;
+ doublereal cs;
+ integer in;
+ doublereal sn, wl, wu;
+ integer iil, iiu;
+ doublereal eps, tmp;
+ integer indd, iend, jblk, wend;
+ doublereal rmin, rmax;
+ integer itmp;
+ doublereal tnrm;
+ extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
+ *, doublereal *, doublereal *);
+ integer inde2, itmp2;
+ doublereal rtol1, rtol2;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal scale;
+ integer indgp;
+ extern logical lsame_(char *, char *);
+ integer iinfo, iindw, ilast;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer lwmin;
+ logical wantz;
+ extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), dlaev2_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *);
+ extern doublereal dlamch_(char *);
+ logical alleig;
+ integer ibegin;
+ logical indeig;
+ integer iindbl;
+ logical valeig;
+ extern /* Subroutine */ int dlarrc_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *, integer *, integer *), dlarre_(char *,
+ integer *, doublereal *, doublereal *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *);
+ integer wbegin;
+ doublereal safmin;
+ extern /* Subroutine */ int dlarrj_(integer *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *), xerbla_(char *, integer *);
+ doublereal bignum;
+ integer inderr, iindwk, indgrs, offset;
+ extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
+ extern /* Subroutine */ int dlarrr_(integer *, doublereal *, doublereal *,
+ integer *), dlasrt_(char *, integer *, doublereal *, integer *);
+ doublereal thresh;
+ integer iinspl, indwrk, ifirst, liwmin, nzcmin;
+ doublereal pivmin;
+ integer nsplit;
+ doublereal smlnum;
+ extern /* Subroutine */ int zlarrv_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *,
+ doublereal *, doublecomplex *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ logical lquery, zquery;
+
+
+/* -- LAPACK computational routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSTEMR computes selected eigenvalues and, optionally, eigenvectors */
+/* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */
+/* a well defined set of pairwise different real eigenvalues, the corresponding */
+/* real eigenvectors are pairwise orthogonal. */
+
+/* The spectrum may be computed either completely or partially by specifying */
+/* either an interval (VL,VU] or a range of indices IL:IU for the desired */
+/* eigenvalues. */
+
+/* Depending on the number of desired eigenvalues, these are computed either */
+/* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are */
+/* computed by the use of various suitable L D L^T factorizations near clusters */
+/* of close eigenvalues (referred to as RRRs, Relatively Robust */
+/* Representations). An informal sketch of the algorithm follows. */
+
+/* For each unreduced block (submatrix) of T, */
+/* (a) Compute T - sigma I = L D L^T, so that L and D */
+/* define all the wanted eigenvalues to high relative accuracy. */
+/* This means that small relative changes in the entries of D and L */
+/* cause only small relative changes in the eigenvalues and */
+/* eigenvectors. The standard (unfactored) representation of the */
+/* tridiagonal matrix T does not have this property in general. */
+/* (b) Compute the eigenvalues to suitable accuracy. */
+/* If the eigenvectors are desired, the algorithm attains full */
+/* accuracy of the computed eigenvalues only right before */
+/* the corresponding vectors have to be computed, see steps c) and d). */
+/* (c) For each cluster of close eigenvalues, select a new */
+/* shift close to the cluster, find a new factorization, and refine */
+/* the shifted eigenvalues to suitable accuracy. */
+/* (d) For each eigenvalue with a large enough relative separation compute */
+/* the corresponding eigenvector by forming a rank revealing twisted */
+/* factorization. Go back to (c) for any clusters that remain. */
+
+/* For more details, see: */
+/* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */
+/* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */
+/* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */
+/* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */
+/* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */
+/* 2004. Also LAPACK Working Note 154. */
+/* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */
+/* tridiagonal eigenvalue/eigenvector problem", */
+/* Computer Science Division Technical Report No. UCB/CSD-97-971, */
+/* UC Berkeley, May 1997. */
+
+/* Notes: */
+/* 1.ZSTEMR works only on machines which follow IEEE-754 */
+/* floating-point standard in their handling of infinities and NaNs. */
+/* This permits the use of efficient inner loops avoiding a check for */
+/* zero divisors. */
+
+/* 2. LAPACK routines can be used to reduce a complex Hermitean matrix to */
+/* real symmetric tridiagonal form. */
+
+/* (Any complex Hermitean tridiagonal matrix has real values on its diagonal */
+/* and potentially complex numbers on its off-diagonals. By applying a */
+/* similarity transform with an appropriate diagonal matrix */
+/* diag(1,e^{i \phy_1}, ... , e^{i \phy_{n-1}}), the complex Hermitean */
+/* matrix can be transformed into a real symmetric matrix and complex */
+/* arithmetic can be entirely avoided.) */
+
+/* While the eigenvectors of the real symmetric tridiagonal matrix are real, */
+/* the eigenvectors of original complex Hermitean matrix have complex entries */
+/* in general. */
+/* Since LAPACK drivers overwrite the matrix data with the eigenvectors, */
+/* ZSTEMR accepts complex workspace to facilitate interoperability */
+/* with ZUNMTR or ZUPMTR. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only; */
+/* = 'V': Compute eigenvalues and eigenvectors. */
+
+/* RANGE (input) CHARACTER*1 */
+/* = 'A': all eigenvalues will be found. */
+/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* will be found. */
+/* = 'I': the IL-th through IU-th eigenvalues will be found. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the N diagonal elements of the tridiagonal matrix */
+/* T. On exit, D is overwritten. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the (N-1) subdiagonal elements of the tridiagonal */
+/* matrix T in elements 1 to N-1 of E. E(N) need not be set on */
+/* input, but is used internally as workspace. */
+/* On exit, E is overwritten. */
+
+/* VL (input) DOUBLE PRECISION */
+/* VU (input) DOUBLE PRECISION */
+/* If RANGE='V', the lower and upper bounds of the interval to */
+/* be searched for eigenvalues. VL < VU. */
+/* Not referenced if RANGE = 'A' or 'I'. */
+
+/* IL (input) INTEGER */
+/* IU (input) INTEGER */
+/* If RANGE='I', the indices (in ascending order) of the */
+/* smallest and largest eigenvalues to be returned. */
+/* 1 <= IL <= IU <= N, if N > 0. */
+/* Not referenced if RANGE = 'A' or 'V'. */
+
+/* M (output) INTEGER */
+/* The total number of eigenvalues found. 0 <= M <= N. */
+/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+
+/* W (output) DOUBLE PRECISION array, dimension (N) */
+/* The first M elements contain the selected eigenvalues in */
+/* ascending order. */
+
+/* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M) ) */
+/* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */
+/* contain the orthonormal eigenvectors of the matrix T */
+/* corresponding to the selected eigenvalues, with the i-th */
+/* column of Z holding the eigenvector associated with W(i). */
+/* If JOBZ = 'N', then Z is not referenced. */
+/* Note: the user must ensure that at least max(1,M) columns are */
+/* supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* is not known in advance and can be computed with a workspace */
+/* query by setting NZC = -1, see below. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* JOBZ = 'V', then LDZ >= max(1,N). */
+
+/* NZC (input) INTEGER */
+/* The number of eigenvectors to be held in the array Z. */
+/* If RANGE = 'A', then NZC >= max(1,N). */
+/* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU]. */
+/* If RANGE = 'I', then NZC >= IU-IL+1. */
+/* If NZC = -1, then a workspace query is assumed; the */
+/* routine calculates the number of columns of the array Z that */
+/* are needed to hold the eigenvectors. */
+/* This value is returned as the first entry of the Z array, and */
+/* no error message related to NZC is issued by XERBLA. */
+
+/* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) ) */
+/* The support of the eigenvectors in Z, i.e., the indices */
+/* indicating the nonzero elements in Z. The i-th computed eigenvector */
+/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */
+/* ISUPPZ( 2*i ). This is relevant in the case when the matrix */
+/* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */
+
+/* TRYRAC (input/output) LOGICAL */
+/* If TRYRAC.EQ..TRUE., indicates that the code should check whether */
+/* the tridiagonal matrix defines its eigenvalues to high relative */
+/* accuracy. If so, the code uses relative-accuracy preserving */
+/* algorithms that might be (a bit) slower depending on the matrix. */
+/* If the matrix does not define its eigenvalues to high relative */
+/* accuracy, the code can uses possibly faster algorithms. */
+/* If TRYRAC.EQ..FALSE., the code is not required to guarantee */
+/* relatively accurate eigenvalues and can use the fastest possible */
+/* techniques. */
+/* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix */
+/* does not define its eigenvalues to high relative accuracy. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal */
+/* (and minimal) LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,18*N) */
+/* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'. */
+/* 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. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (LIWORK) */
+/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. LIWORK >= max(1,10*N) */
+/* if the eigenvectors are desired, and LIWORK >= max(1,8*N) */
+/* if only the eigenvalues are to be computed. */
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal size of the IWORK array, */
+/* returns this value as the first entry of the IWORK array, and */
+/* no error message related to LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* On exit, INFO */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = 1X, internal error in DLARRE, */
+/* if INFO = 2X, internal error in ZLARRV. */
+/* Here, the digit X = ABS( IINFO ) < 10, where IINFO is */
+/* the nonzero error code returned by DLARRE or */
+/* ZLARRV, respectively. */
+
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Beresford Parlett, University of California, Berkeley, USA */
+/* Jim Demmel, University of California, Berkeley, USA */
+/* Inderjit Dhillon, University of Texas, Austin, USA */
+/* Osni Marques, LBNL/NERSC, USA */
+/* Christof Voemel, University of California, Berkeley, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ --w;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --isuppz;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantz = lsame_(jobz, "V");
+ alleig = lsame_(range, "A");
+ valeig = lsame_(range, "V");
+ indeig = lsame_(range, "I");
+
+ lquery = *lwork == -1 || *liwork == -1;
+ zquery = *nzc == -1;
+/* DSTEMR needs WORK of size 6*N, IWORK of size 3*N. */
+/* In addition, DLARRE needs WORK of size 6*N, IWORK of size 5*N. */
+/* Furthermore, ZLARRV needs WORK of size 12*N, IWORK of size 7*N. */
+ if (wantz) {
+ lwmin = *n * 18;
+ liwmin = *n * 10;
+ } else {
+/* need less workspace if only the eigenvalues are wanted */
+ lwmin = *n * 12;
+ liwmin = *n << 3;
+ }
+ wl = 0.;
+ wu = 0.;
+ iil = 0;
+ iiu = 0;
+ if (valeig) {
+/* We do not reference VL, VU in the cases RANGE = 'I','A' */
+/* The interval (WL, WU] contains all the wanted eigenvalues. */
+/* It is either given by the user or computed in DLARRE. */
+ wl = *vl;
+ wu = *vu;
+ } else if (indeig) {
+/* We do not reference IL, IU in the cases RANGE = 'V','A' */
+ iil = *il;
+ iiu = *iu;
+ }
+
+ *info = 0;
+ if (! (wantz || lsame_(jobz, "N"))) {
+ *info = -1;
+ } else if (! (alleig || valeig || indeig)) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (valeig && *n > 0 && wu <= wl) {
+ *info = -7;
+ } else if (indeig && (iil < 1 || iil > *n)) {
+ *info = -8;
+ } else if (indeig && (iiu < iil || iiu > *n)) {
+ *info = -9;
+ } else if (*ldz < 1 || wantz && *ldz < *n) {
+ *info = -13;
+ } else if (*lwork < lwmin && ! lquery) {
+ *info = -17;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -19;
+ }
+
+/* Get machine constants. */
+
+ safmin = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ smlnum = safmin / eps;
+ bignum = 1. / smlnum;
+ rmin = sqrt(smlnum);
+/* Computing MIN */
+ d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
+ rmax = min(d__1,d__2);
+
+ if (*info == 0) {
+ work[1] = (doublereal) lwmin;
+ iwork[1] = liwmin;
+
+ if (wantz && alleig) {
+ nzcmin = *n;
+ } else if (wantz && valeig) {
+ dlarrc_("T", n, vl, vu, &d__[1], &e[1], &safmin, &nzcmin, &itmp, &
+ itmp2, info);
+ } else if (wantz && indeig) {
+ nzcmin = iiu - iil + 1;
+ } else {
+/* WANTZ .EQ. FALSE. */
+ nzcmin = 0;
+ }
+ if (zquery && *info == 0) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = (doublereal) nzcmin, z__[i__1].i = 0.;
+ } else if (*nzc < nzcmin && ! zquery) {
+ *info = -14;
+ }
+ }
+ if (*info != 0) {
+
+ i__1 = -(*info);
+ xerbla_("ZSTEMR", &i__1);
+
+ return 0;
+ } else if (lquery || zquery) {
+ return 0;
+ }
+
+/* Handle N = 0, 1, and 2 cases immediately */
+
+ *m = 0;
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (alleig || indeig) {
+ *m = 1;
+ w[1] = d__[1];
+ } else {
+ if (wl < d__[1] && wu >= d__[1]) {
+ *m = 1;
+ w[1] = d__[1];
+ }
+ }
+ if (wantz && ! zquery) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1., z__[i__1].i = 0.;
+ isuppz[1] = 1;
+ isuppz[2] = 1;
+ }
+ return 0;
+ }
+
+ if (*n == 2) {
+ if (! wantz) {
+ dlae2_(&d__[1], &e[1], &d__[2], &r1, &r2);
+ } else if (wantz && ! zquery) {
+ dlaev2_(&d__[1], &e[1], &d__[2], &r1, &r2, &cs, &sn);
+ }
+ if (alleig || valeig && r2 > wl && r2 <= wu || indeig && iil == 1) {
+ ++(*m);
+ w[*m] = r2;
+ if (wantz && ! zquery) {
+ i__1 = *m * z_dim1 + 1;
+ d__1 = -sn;
+ z__[i__1].r = d__1, z__[i__1].i = 0.;
+ i__1 = *m * z_dim1 + 2;
+ z__[i__1].r = cs, z__[i__1].i = 0.;
+/* Note: At most one of SN and CS can be zero. */
+ if (sn != 0.) {
+ if (cs != 0.) {
+ isuppz[(*m << 1) - 1] = 1;
+ isuppz[(*m << 1) - 1] = 2;
+ } else {
+ isuppz[(*m << 1) - 1] = 1;
+ isuppz[(*m << 1) - 1] = 1;
+ }
+ } else {
+ isuppz[(*m << 1) - 1] = 2;
+ isuppz[*m * 2] = 2;
+ }
+ }
+ }
+ if (alleig || valeig && r1 > wl && r1 <= wu || indeig && iiu == 2) {
+ ++(*m);
+ w[*m] = r1;
+ if (wantz && ! zquery) {
+ i__1 = *m * z_dim1 + 1;
+ z__[i__1].r = cs, z__[i__1].i = 0.;
+ i__1 = *m * z_dim1 + 2;
+ z__[i__1].r = sn, z__[i__1].i = 0.;
+/* Note: At most one of SN and CS can be zero. */
+ if (sn != 0.) {
+ if (cs != 0.) {
+ isuppz[(*m << 1) - 1] = 1;
+ isuppz[(*m << 1) - 1] = 2;
+ } else {
+ isuppz[(*m << 1) - 1] = 1;
+ isuppz[(*m << 1) - 1] = 1;
+ }
+ } else {
+ isuppz[(*m << 1) - 1] = 2;
+ isuppz[*m * 2] = 2;
+ }
+ }
+ }
+ return 0;
+ }
+/* Continue with general N */
+ indgrs = 1;
+ inderr = (*n << 1) + 1;
+ indgp = *n * 3 + 1;
+ indd = (*n << 2) + 1;
+ inde2 = *n * 5 + 1;
+ indwrk = *n * 6 + 1;
+
+ iinspl = 1;
+ iindbl = *n + 1;
+ iindw = (*n << 1) + 1;
+ iindwk = *n * 3 + 1;
+
+/* Scale matrix to allowable range, if necessary. */
+/* The allowable range is related to the PIVMIN parameter; see the */
+/* comments in DLARRD. The preference for scaling small values */
+/* up is heuristic; we expect users' matrices not to be close to the */
+/* RMAX threshold. */
+
+ scale = 1.;
+ tnrm = dlanst_("M", n, &d__[1], &e[1]);
+ if (tnrm > 0. && tnrm < rmin) {
+ scale = rmin / tnrm;
+ } else if (tnrm > rmax) {
+ scale = rmax / tnrm;
+ }
+ if (scale != 1.) {
+ dscal_(n, &scale, &d__[1], &c__1);
+ i__1 = *n - 1;
+ dscal_(&i__1, &scale, &e[1], &c__1);
+ tnrm *= scale;
+ if (valeig) {
+/* If eigenvalues in interval have to be found, */
+/* scale (WL, WU] accordingly */
+ wl *= scale;
+ wu *= scale;
+ }
+ }
+
+/* Compute the desired eigenvalues of the tridiagonal after splitting */
+/* into smaller subblocks if the corresponding off-diagonal elements */
+/* are small */
+/* THRESH is the splitting parameter for DLARRE */
+/* A negative THRESH forces the old splitting criterion based on the */
+/* size of the off-diagonal. A positive THRESH switches to splitting */
+/* which preserves relative accuracy. */
+
+ if (*tryrac) {
+/* Test whether the matrix warrants the more expensive relative approach. */
+ dlarrr_(n, &d__[1], &e[1], &iinfo);
+ } else {
+/* The user does not care about relative accurately eigenvalues */
+ iinfo = -1;
+ }
+/* Set the splitting criterion */
+ if (iinfo == 0) {
+ thresh = eps;
+ } else {
+ thresh = -eps;
+/* relative accuracy is desired but T does not guarantee it */
+ *tryrac = FALSE_;
+ }
+
+ if (*tryrac) {
+/* Copy original diagonal, needed to guarantee relative accuracy */
+ dcopy_(n, &d__[1], &c__1, &work[indd], &c__1);
+ }
+/* Store the squares of the offdiagonal values of T */
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing 2nd power */
+ d__1 = e[j];
+ work[inde2 + j - 1] = d__1 * d__1;
+/* L5: */
+ }
+/* Set the tolerance parameters for bisection */
+ if (! wantz) {
+/* DLARRE computes the eigenvalues to full precision. */
+ rtol1 = eps * 4.;
+ rtol2 = eps * 4.;
+ } else {
+/* DLARRE computes the eigenvalues to less than full precision. */
+/* ZLARRV will refine the eigenvalue approximations, and we only */
+/* need less accurate initial bisection in DLARRE. */
+/* Note: these settings do only affect the subset case and DLARRE */
+ rtol1 = sqrt(eps);
+/* Computing MAX */
+ d__1 = sqrt(eps) * .005, d__2 = eps * 4.;
+ rtol2 = max(d__1,d__2);
+ }
+ dlarre_(range, n, &wl, &wu, &iil, &iiu, &d__[1], &e[1], &work[inde2], &
+ rtol1, &rtol2, &thresh, &nsplit, &iwork[iinspl], m, &w[1], &work[
+ inderr], &work[indgp], &iwork[iindbl], &iwork[iindw], &work[
+ indgrs], &pivmin, &work[indwrk], &iwork[iindwk], &iinfo);
+ if (iinfo != 0) {
+ *info = abs(iinfo) + 10;
+ return 0;
+ }
+/* Note that if RANGE .NE. 'V', DLARRE computes bounds on the desired */
+/* part of the spectrum. All desired eigenvalues are contained in */
+/* (WL,WU] */
+ if (wantz) {
+
+/* Compute the desired eigenvectors corresponding to the computed */
+/* eigenvalues */
+
+ zlarrv_(n, &wl, &wu, &d__[1], &e[1], &pivmin, &iwork[iinspl], m, &
+ c__1, m, &c_b18, &rtol1, &rtol2, &w[1], &work[inderr], &work[
+ indgp], &iwork[iindbl], &iwork[iindw], &work[indgrs], &z__[
+ z_offset], ldz, &isuppz[1], &work[indwrk], &iwork[iindwk], &
+ iinfo);
+ if (iinfo != 0) {
+ *info = abs(iinfo) + 20;
+ return 0;
+ }
+ } else {
+/* DLARRE computes eigenvalues of the (shifted) root representation */
+/* ZLARRV returns the eigenvalues of the unshifted matrix. */
+/* However, if the eigenvectors are not desired by the user, we need */
+/* to apply the corresponding shifts from DLARRE to obtain the */
+/* eigenvalues of the original matrix. */
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ itmp = iwork[iindbl + j - 1];
+ w[j] += e[iwork[iinspl + itmp - 1]];
+/* L20: */
+ }
+ }
+
+ if (*tryrac) {
+/* Refine computed eigenvalues so that they are relatively accurate */
+/* with respect to the original matrix T. */
+ ibegin = 1;
+ wbegin = 1;
+ i__1 = iwork[iindbl + *m - 1];
+ for (jblk = 1; jblk <= i__1; ++jblk) {
+ iend = iwork[iinspl + jblk - 1];
+ in = iend - ibegin + 1;
+ wend = wbegin - 1;
+/* check if any eigenvalues have to be refined in this block */
+L36:
+ if (wend < *m) {
+ if (iwork[iindbl + wend] == jblk) {
+ ++wend;
+ goto L36;
+ }
+ }
+ if (wend < wbegin) {
+ ibegin = iend + 1;
+ goto L39;
+ }
+ offset = iwork[iindw + wbegin - 1] - 1;
+ ifirst = iwork[iindw + wbegin - 1];
+ ilast = iwork[iindw + wend - 1];
+ rtol2 = eps * 4.;
+ dlarrj_(&in, &work[indd + ibegin - 1], &work[inde2 + ibegin - 1],
+ &ifirst, &ilast, &rtol2, &offset, &w[wbegin], &work[
+ inderr + wbegin - 1], &work[indwrk], &iwork[iindwk], &
+ pivmin, &tnrm, &iinfo);
+ ibegin = iend + 1;
+ wbegin = wend + 1;
+L39:
+ ;
+ }
+ }
+
+/* If matrix was scaled, then rescale eigenvalues appropriately. */
+
+ if (scale != 1.) {
+ d__1 = 1. / scale;
+ dscal_(m, &d__1, &w[1], &c__1);
+ }
+
+/* If eigenvalues are not in increasing order, then sort them, */
+/* possibly along with eigenvectors. */
+
+ if (nsplit > 1) {
+ if (! wantz) {
+ dlasrt_("I", m, &w[1], &iinfo);
+ if (iinfo != 0) {
+ *info = 3;
+ return 0;
+ }
+ } else {
+ i__1 = *m - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__ = 0;
+ tmp = w[j];
+ i__2 = *m;
+ for (jj = j + 1; jj <= i__2; ++jj) {
+ if (w[jj] < tmp) {
+ i__ = jj;
+ tmp = w[jj];
+ }
+/* L50: */
+ }
+ if (i__ != 0) {
+ w[i__] = w[j];
+ w[j] = tmp;
+ if (wantz) {
+ zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j *
+ z_dim1 + 1], &c__1);
+ itmp = isuppz[(i__ << 1) - 1];
+ isuppz[(i__ << 1) - 1] = isuppz[(j << 1) - 1];
+ isuppz[(j << 1) - 1] = itmp;
+ itmp = isuppz[i__ * 2];
+ isuppz[i__ * 2] = isuppz[j * 2];
+ isuppz[j * 2] = itmp;
+ }
+ }
+/* L60: */
+ }
+ }
+ }
+
+
+ work[1] = (doublereal) lwmin;
+ iwork[1] = liwmin;
+ return 0;
+
+/* End of ZSTEMR */
+
+} /* zstemr_ */
diff --git a/SRC/zsteqr.c b/SRC/zsteqr.c
new file mode 100644
index 0000000..154a20b
--- /dev/null
+++ b/SRC/zsteqr.c
@@ -0,0 +1,621 @@
+/* zsteqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static doublereal c_b41 = 1.;
+
+/* Subroutine */ int zsteqr_(char *compz, integer *n, doublereal *d__,
+ doublereal *e, doublecomplex *z__, integer *ldz, doublereal *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer z_dim1, z_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ doublereal b, c__, f, g;
+ integer i__, j, k, l, m;
+ doublereal p, r__, s;
+ integer l1, ii, mm, lm1, mm1, nm1;
+ doublereal rt1, rt2, eps;
+ integer lsv;
+ doublereal tst, eps2;
+ integer lend, jtot;
+ extern /* Subroutine */ int dlae2_(doublereal *, doublereal *, doublereal
+ *, doublereal *, doublereal *);
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int zlasr_(char *, char *, char *, integer *,
+ integer *, doublereal *, doublereal *, doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), dlaev2_(doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *);
+ integer lendm1, lendp1;
+ extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
+ integer iscale;
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ doublereal safmin;
+ extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *);
+ doublereal safmax;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
+ extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *,
+ integer *);
+ integer lendsv;
+ doublereal ssfmin;
+ integer nmaxit, icompz;
+ doublereal ssfmax;
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a */
+/* symmetric tridiagonal matrix using the implicit QL or QR method. */
+/* The eigenvectors of a full or band complex Hermitian matrix can also */
+/* be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this */
+/* matrix to tridiagonal form. */
+
+/* Arguments */
+/* ========= */
+
+/* COMPZ (input) CHARACTER*1 */
+/* = 'N': Compute eigenvalues only. */
+/* = 'V': Compute eigenvalues and eigenvectors of the original */
+/* Hermitian matrix. On entry, Z must contain the */
+/* unitary matrix used to reduce the original matrix */
+/* to tridiagonal form. */
+/* = 'I': Compute eigenvalues and eigenvectors of the */
+/* tridiagonal matrix. Z is initialized to the identity */
+/* matrix. */
+
+/* N (input) INTEGER */
+/* The order of the matrix. N >= 0. */
+
+/* D (input/output) DOUBLE PRECISION array, dimension (N) */
+/* On entry, the diagonal elements of the tridiagonal matrix. */
+/* On exit, if INFO = 0, the eigenvalues in ascending order. */
+
+/* E (input/output) DOUBLE PRECISION array, dimension (N-1) */
+/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* matrix. */
+/* On exit, E has been destroyed. */
+
+/* Z (input/output) COMPLEX*16 array, dimension (LDZ, N) */
+/* On entry, if COMPZ = 'V', then Z contains the unitary */
+/* matrix used in the reduction to tridiagonal form. */
+/* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */
+/* orthonormal eigenvectors of the original Hermitian matrix, */
+/* and if COMPZ = 'I', Z contains the orthonormal eigenvectors */
+/* of the symmetric tridiagonal matrix. */
+/* If COMPZ = 'N', then Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1, and if */
+/* eigenvectors are desired, then LDZ >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) */
+/* If COMPZ = 'N', then WORK is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: the algorithm has failed to find all the eigenvalues in */
+/* a total of 30*N iterations; if INFO = i, then i */
+/* elements of E have not converged to zero; on exit, D */
+/* and E contain the elements of a symmetric tridiagonal */
+/* matrix which is unitarily similar to the original */
+/* matrix. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+ if (lsame_(compz, "N")) {
+ icompz = 0;
+ } else if (lsame_(compz, "V")) {
+ icompz = 1;
+ } else if (lsame_(compz, "I")) {
+ icompz = 2;
+ } else {
+ icompz = -1;
+ }
+ if (icompz < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldz < 1 || icompz > 0 && *ldz < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZSTEQR", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (icompz == 2) {
+ i__1 = z_dim1 + 1;
+ z__[i__1].r = 1., z__[i__1].i = 0.;
+ }
+ return 0;
+ }
+
+/* Determine the unit roundoff and over/underflow thresholds. */
+
+ eps = dlamch_("E");
+/* Computing 2nd power */
+ d__1 = eps;
+ eps2 = d__1 * d__1;
+ safmin = dlamch_("S");
+ safmax = 1. / safmin;
+ ssfmax = sqrt(safmax) / 3.;
+ ssfmin = sqrt(safmin) / eps2;
+
+/* Compute the eigenvalues and eigenvectors of the tridiagonal */
+/* matrix. */
+
+ if (icompz == 2) {
+ zlaset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz);
+ }
+
+ nmaxit = *n * 30;
+ jtot = 0;
+
+/* Determine where the matrix splits and choose QL or QR iteration */
+/* for each block, according to whether top or bottom diagonal */
+/* element is smaller. */
+
+ l1 = 1;
+ nm1 = *n - 1;
+
+L10:
+ if (l1 > *n) {
+ goto L160;
+ }
+ if (l1 > 1) {
+ e[l1 - 1] = 0.;
+ }
+ if (l1 <= nm1) {
+ i__1 = nm1;
+ for (m = l1; m <= i__1; ++m) {
+ tst = (d__1 = e[m], abs(d__1));
+ if (tst == 0.) {
+ goto L30;
+ }
+ if (tst <= sqrt((d__1 = d__[m], abs(d__1))) * sqrt((d__2 = d__[m
+ + 1], abs(d__2))) * eps) {
+ e[m] = 0.;
+ goto L30;
+ }
+/* L20: */
+ }
+ }
+ m = *n;
+
+L30:
+ l = l1;
+ lsv = l;
+ lend = m;
+ lendsv = lend;
+ l1 = m + 1;
+ if (lend == l) {
+ goto L10;
+ }
+
+/* Scale submatrix in rows and columns L to LEND */
+
+ i__1 = lend - l + 1;
+ anorm = dlanst_("I", &i__1, &d__[l], &e[l]);
+ iscale = 0;
+ if (anorm == 0.) {
+ goto L10;
+ }
+ if (anorm > ssfmax) {
+ iscale = 1;
+ i__1 = lend - l + 1;
+ dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n,
+ info);
+ i__1 = lend - l;
+ dlascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n,
+ info);
+ } else if (anorm < ssfmin) {
+ iscale = 2;
+ i__1 = lend - l + 1;
+ dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n,
+ info);
+ i__1 = lend - l;
+ dlascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n,
+ info);
+ }
+
+/* Choose between QL and QR iteration */
+
+ if ((d__1 = d__[lend], abs(d__1)) < (d__2 = d__[l], abs(d__2))) {
+ lend = lsv;
+ l = lendsv;
+ }
+
+ if (lend > l) {
+
+/* QL Iteration */
+
+/* Look for small subdiagonal element. */
+
+L40:
+ if (l != lend) {
+ lendm1 = lend - 1;
+ i__1 = lendm1;
+ for (m = l; m <= i__1; ++m) {
+/* Computing 2nd power */
+ d__2 = (d__1 = e[m], abs(d__1));
+ tst = d__2 * d__2;
+ if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
+ + 1], abs(d__2)) + safmin) {
+ goto L60;
+ }
+/* L50: */
+ }
+ }
+
+ m = lend;
+
+L60:
+ if (m < lend) {
+ e[m] = 0.;
+ }
+ p = d__[l];
+ if (m == l) {
+ goto L80;
+ }
+
+/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */
+/* to compute its eigensystem. */
+
+ if (m == l + 1) {
+ if (icompz > 0) {
+ dlaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
+ work[l] = c__;
+ work[*n - 1 + l] = s;
+ zlasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], &
+ z__[l * z_dim1 + 1], ldz);
+ } else {
+ dlae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
+ }
+ d__[l] = rt1;
+ d__[l + 1] = rt2;
+ e[l] = 0.;
+ l += 2;
+ if (l <= lend) {
+ goto L40;
+ }
+ goto L140;
+ }
+
+ if (jtot == nmaxit) {
+ goto L140;
+ }
+ ++jtot;
+
+/* Form shift. */
+
+ g = (d__[l + 1] - p) / (e[l] * 2.);
+ r__ = dlapy2_(&g, &c_b41);
+ g = d__[m] - p + e[l] / (g + d_sign(&r__, &g));
+
+ s = 1.;
+ c__ = 1.;
+ p = 0.;
+
+/* Inner loop */
+
+ mm1 = m - 1;
+ i__1 = l;
+ for (i__ = mm1; i__ >= i__1; --i__) {
+ f = s * e[i__];
+ b = c__ * e[i__];
+ dlartg_(&g, &f, &c__, &s, &r__);
+ if (i__ != m - 1) {
+ e[i__ + 1] = r__;
+ }
+ g = d__[i__ + 1] - p;
+ r__ = (d__[i__] - g) * s + c__ * 2. * b;
+ p = s * r__;
+ d__[i__ + 1] = g + p;
+ g = c__ * r__ - b;
+
+/* If eigenvectors are desired, then save rotations. */
+
+ if (icompz > 0) {
+ work[i__] = c__;
+ work[*n - 1 + i__] = -s;
+ }
+
+/* L70: */
+ }
+
+/* If eigenvectors are desired, then apply saved rotations. */
+
+ if (icompz > 0) {
+ mm = m - l + 1;
+ zlasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &z__[l
+ * z_dim1 + 1], ldz);
+ }
+
+ d__[l] -= p;
+ e[l] = g;
+ goto L40;
+
+/* Eigenvalue found. */
+
+L80:
+ d__[l] = p;
+
+ ++l;
+ if (l <= lend) {
+ goto L40;
+ }
+ goto L140;
+
+ } else {
+
+/* QR Iteration */
+
+/* Look for small superdiagonal element. */
+
+L90:
+ if (l != lend) {
+ lendp1 = lend + 1;
+ i__1 = lendp1;
+ for (m = l; m >= i__1; --m) {
+/* Computing 2nd power */
+ d__2 = (d__1 = e[m - 1], abs(d__1));
+ tst = d__2 * d__2;
+ if (tst <= eps2 * (d__1 = d__[m], abs(d__1)) * (d__2 = d__[m
+ - 1], abs(d__2)) + safmin) {
+ goto L110;
+ }
+/* L100: */
+ }
+ }
+
+ m = lend;
+
+L110:
+ if (m > lend) {
+ e[m - 1] = 0.;
+ }
+ p = d__[l];
+ if (m == l) {
+ goto L130;
+ }
+
+/* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 */
+/* to compute its eigensystem. */
+
+ if (m == l - 1) {
+ if (icompz > 0) {
+ dlaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s)
+ ;
+ work[m] = c__;
+ work[*n - 1 + m] = s;
+ zlasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], &
+ z__[(l - 1) * z_dim1 + 1], ldz);
+ } else {
+ dlae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
+ }
+ d__[l - 1] = rt1;
+ d__[l] = rt2;
+ e[l - 1] = 0.;
+ l += -2;
+ if (l >= lend) {
+ goto L90;
+ }
+ goto L140;
+ }
+
+ if (jtot == nmaxit) {
+ goto L140;
+ }
+ ++jtot;
+
+/* Form shift. */
+
+ g = (d__[l - 1] - p) / (e[l - 1] * 2.);
+ r__ = dlapy2_(&g, &c_b41);
+ g = d__[m] - p + e[l - 1] / (g + d_sign(&r__, &g));
+
+ s = 1.;
+ c__ = 1.;
+ p = 0.;
+
+/* Inner loop */
+
+ lm1 = l - 1;
+ i__1 = lm1;
+ for (i__ = m; i__ <= i__1; ++i__) {
+ f = s * e[i__];
+ b = c__ * e[i__];
+ dlartg_(&g, &f, &c__, &s, &r__);
+ if (i__ != m) {
+ e[i__ - 1] = r__;
+ }
+ g = d__[i__] - p;
+ r__ = (d__[i__ + 1] - g) * s + c__ * 2. * b;
+ p = s * r__;
+ d__[i__] = g + p;
+ g = c__ * r__ - b;
+
+/* If eigenvectors are desired, then save rotations. */
+
+ if (icompz > 0) {
+ work[i__] = c__;
+ work[*n - 1 + i__] = s;
+ }
+
+/* L120: */
+ }
+
+/* If eigenvectors are desired, then apply saved rotations. */
+
+ if (icompz > 0) {
+ mm = l - m + 1;
+ zlasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &z__[m
+ * z_dim1 + 1], ldz);
+ }
+
+ d__[l] -= p;
+ e[lm1] = g;
+ goto L90;
+
+/* Eigenvalue found. */
+
+L130:
+ d__[l] = p;
+
+ --l;
+ if (l >= lend) {
+ goto L90;
+ }
+ goto L140;
+
+ }
+
+/* Undo scaling if necessary */
+
+L140:
+ if (iscale == 1) {
+ i__1 = lendsv - lsv + 1;
+ dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv],
+ n, info);
+ i__1 = lendsv - lsv;
+ dlascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n,
+ info);
+ } else if (iscale == 2) {
+ i__1 = lendsv - lsv + 1;
+ dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv],
+ n, info);
+ i__1 = lendsv - lsv;
+ dlascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n,
+ info);
+ }
+
+/* Check for no convergence to an eigenvalue after a total */
+/* of N*MAXIT iterations. */
+
+ if (jtot == nmaxit) {
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (e[i__] != 0.) {
+ ++(*info);
+ }
+/* L150: */
+ }
+ return 0;
+ }
+ goto L10;
+
+/* Order eigenvalues and eigenvectors. */
+
+L160:
+ if (icompz == 0) {
+
+/* Use Quick Sort */
+
+ dlasrt_("I", n, &d__[1], info);
+
+ } else {
+
+/* Use Selection Sort to minimize swaps of eigenvectors */
+
+ i__1 = *n;
+ for (ii = 2; ii <= i__1; ++ii) {
+ i__ = ii - 1;
+ k = i__;
+ p = d__[i__];
+ i__2 = *n;
+ for (j = ii; j <= i__2; ++j) {
+ if (d__[j] < p) {
+ k = j;
+ p = d__[j];
+ }
+/* L170: */
+ }
+ if (k != i__) {
+ d__[k] = d__[i__];
+ d__[i__] = p;
+ zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 + 1],
+ &c__1);
+ }
+/* L180: */
+ }
+ }
+ return 0;
+
+/* End of ZSTEQR */
+
+} /* zsteqr_ */
diff --git a/SRC/zsycon.c b/SRC/zsycon.c
new file mode 100644
index 0000000..7a74d75
--- /dev/null
+++ b/SRC/zsycon.c
@@ -0,0 +1,203 @@
+/* zsycon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zsycon_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *ipiv, doublereal *anorm, doublereal *rcond,
+ doublecomplex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, kase;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *), xerbla_(
+ char *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int zsytrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSYCON estimates the reciprocal of the condition number (in the */
+/* 1-norm) of a complex symmetric matrix A using the factorization */
+/* A = U*D*U**T or A = L*D*L**T computed by ZSYTRF. */
+
+/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by ZSYTRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by ZSYTRF. */
+
+/* ANORM (input) DOUBLE PRECISION */
+/* The 1-norm of the original matrix A. */
+
+/* RCOND (output) 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. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*anorm < 0.) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZSYCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *rcond = 0.;
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ } else if (*anorm <= 0.) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ for (i__ = *n; i__ >= 1; --i__) {
+ i__1 = i__ + i__ * a_dim1;
+ if (ipiv[i__] > 0 && (a[i__1].r == 0. && a[i__1].i == 0.)) {
+ return 0;
+ }
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ if (ipiv[i__] > 0 && (a[i__2].r == 0. && a[i__2].i == 0.)) {
+ return 0;
+ }
+/* L20: */
+ }
+ }
+
+/* Estimate the 1-norm of the inverse. */
+
+ kase = 0;
+L30:
+ zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+
+/* Multiply by inv(L*D*L') or inv(U*D*U'). */
+
+ zsytrs_(uplo, n, &c__1, &a[a_offset], lda, &ipiv[1], &work[1], n,
+ info);
+ goto L30;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / ainvnm / *anorm;
+ }
+
+ return 0;
+
+/* End of ZSYCON */
+
+} /* zsycon_ */
diff --git a/SRC/zsyequb.c b/SRC/zsyequb.c
new file mode 100644
index 0000000..3ab99c7
--- /dev/null
+++ b/SRC/zsyequb.c
@@ -0,0 +1,450 @@
+/* zsyequb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zsyequb_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublereal *s, doublereal *scond, doublereal *amax,
+ doublecomplex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *), sqrt(doublereal), log(doublereal), pow_di(
+ doublereal *, integer *);
+
+ /* Local variables */
+ doublereal d__;
+ integer i__, j;
+ doublereal t, u, c0, c1, c2, si;
+ logical up;
+ doublereal avg, std, tol, base;
+ integer iter;
+ doublereal smin, smax, scale;
+ extern logical lsame_(char *, char *);
+ doublereal sumsq;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum, smlnum;
+ extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSYEQUB computes row and column scalings intended to equilibrate a */
+/* symmetric matrix A and reduce its condition number */
+/* (with respect to the two-norm). S contains the scale factors, */
+/* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with */
+/* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This */
+/* choice of S puts the condition number of B within a factor N of the */
+/* smallest possible condition number over all possible diagonal */
+/* scalings. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The N-by-N symmetric matrix whose scaling */
+/* factors are to be computed. Only the diagonal elements of A */
+/* are referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* S (output) DOUBLE PRECISION array, dimension (N) */
+/* If INFO = 0, S contains the scale factors for A. */
+
+/* SCOND (output) DOUBLE PRECISION */
+/* If INFO = 0, S contains the ratio of the smallest S(i) to */
+/* the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
+/* large nor too small, it is not worth scaling by S. */
+
+/* AMAX (output) DOUBLE PRECISION */
+/* Absolute value of largest matrix element. If AMAX is very */
+/* close to overflow or very close to underflow, the matrix */
+/* should be scaled. */
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element is nonpositive. */
+
+/* Further Details */
+/* ======= ======= */
+
+/* Reference: Livne, O.E. and Golub, G.H., "Scaling by Binormalization", */
+/* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. */
+/* DOI 10.1023/B:NUMA.0000016606.32820.69 */
+/* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* Statement Function Definitions */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (! (lsame_(uplo, "U") || lsame_(uplo, "L"))) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZSYEQUB", &i__1);
+ return 0;
+ }
+ up = lsame_(uplo, "U");
+ *amax = 0.;
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ *scond = 1.;
+ return 0;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s[i__] = 0.;
+ }
+ *amax = 0.;
+ if (up) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = s[i__], d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2));
+ s[i__] = max(d__3,d__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = s[j], d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2));
+ s[j] = max(d__3,d__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = *amax, d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2));
+ *amax = max(d__3,d__4);
+ }
+/* Computing MAX */
+ i__2 = j + j * a_dim1;
+ d__3 = s[j], d__4 = (d__1 = a[i__2].r, abs(d__1)) + (d__2 =
+ d_imag(&a[j + j * a_dim1]), abs(d__2));
+ s[j] = max(d__3,d__4);
+/* Computing MAX */
+ i__2 = j + j * a_dim1;
+ d__3 = *amax, d__4 = (d__1 = a[i__2].r, abs(d__1)) + (d__2 =
+ d_imag(&a[j + j * a_dim1]), abs(d__2));
+ *amax = max(d__3,d__4);
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = j + j * a_dim1;
+ d__3 = s[j], d__4 = (d__1 = a[i__2].r, abs(d__1)) + (d__2 =
+ d_imag(&a[j + j * a_dim1]), abs(d__2));
+ s[j] = max(d__3,d__4);
+/* Computing MAX */
+ i__2 = j + j * a_dim1;
+ d__3 = *amax, d__4 = (d__1 = a[i__2].r, abs(d__1)) + (d__2 =
+ d_imag(&a[j + j * a_dim1]), abs(d__2));
+ *amax = max(d__3,d__4);
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = s[i__], d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2));
+ s[i__] = max(d__3,d__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = s[j], d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2));
+ s[j] = max(d__3,d__4);
+/* Computing MAX */
+ i__3 = i__ + j * a_dim1;
+ d__3 = *amax, d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2));
+ *amax = max(d__3,d__4);
+ }
+ }
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ s[j] = 1. / s[j];
+ }
+ tol = 1. / sqrt(*n * 2.);
+ for (iter = 1; iter <= 100; ++iter) {
+ scale = 0.;
+ sumsq = 0.;
+/* beta = |A|s */
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ work[i__2].r = 0., work[i__2].i = 0.;
+ }
+ if (up) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ + j * a_dim1]), abs(d__2));
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ d__3 = ((d__1 = a[i__5].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2))) * s[j];
+ z__1.r = work[i__4].r + d__3, z__1.i = work[i__4].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ i__3 = j;
+ i__4 = j;
+ i__5 = i__ + j * a_dim1;
+ d__3 = ((d__1 = a[i__5].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2))) * s[i__];
+ z__1.r = work[i__4].r + d__3, z__1.i = work[i__4].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ }
+ i__2 = j;
+ i__3 = j;
+ i__4 = j + j * a_dim1;
+ d__3 = ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[j +
+ j * a_dim1]), abs(d__2))) * s[j];
+ z__1.r = work[i__3].r + d__3, z__1.i = work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ i__3 = j;
+ i__4 = j + j * a_dim1;
+ d__3 = ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[j +
+ j * a_dim1]), abs(d__2))) * s[j];
+ z__1.r = work[i__3].r + d__3, z__1.i = work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ + j * a_dim1]), abs(d__2));
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ d__3 = ((d__1 = a[i__5].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2))) * s[j];
+ z__1.r = work[i__4].r + d__3, z__1.i = work[i__4].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ i__3 = j;
+ i__4 = j;
+ i__5 = i__ + j * a_dim1;
+ d__3 = ((d__1 = a[i__5].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2))) * s[i__];
+ z__1.r = work[i__4].r + d__3, z__1.i = work[i__4].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ }
+ }
+ }
+/* avg = s^T beta / n */
+ avg = 0.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ z__2.r = s[i__2] * work[i__3].r, z__2.i = s[i__2] * work[i__3].i;
+ z__1.r = avg + z__2.r, z__1.i = z__2.i;
+ avg = z__1.r;
+ }
+ avg /= *n;
+ std = 0.;
+ i__1 = *n << 1;
+ for (i__ = *n + 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__ - *n;
+ i__4 = i__ - *n;
+ z__2.r = s[i__3] * work[i__4].r, z__2.i = s[i__3] * work[i__4].i;
+ z__1.r = z__2.r - avg, z__1.i = z__2.i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ zlassq_(n, &work[*n + 1], &c__1, &scale, &sumsq);
+ std = scale * sqrt(sumsq / *n);
+ if (std < tol * avg) {
+ goto L999;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ t = (d__1 = a[i__2].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + i__ *
+ a_dim1]), abs(d__2));
+ si = s[i__];
+ c2 = (*n - 1) * t;
+ i__2 = *n - 2;
+ i__3 = i__;
+ d__1 = t * si;
+ z__2.r = work[i__3].r - d__1, z__2.i = work[i__3].i;
+ d__2 = (doublereal) i__2;
+ z__1.r = d__2 * z__2.r, z__1.i = d__2 * z__2.i;
+ c1 = z__1.r;
+ d__1 = -(t * si) * si;
+ i__2 = i__;
+ d__2 = 2.;
+ z__4.r = d__2 * work[i__2].r, z__4.i = d__2 * work[i__2].i;
+ z__3.r = si * z__4.r, z__3.i = si * z__4.i;
+ z__2.r = d__1 + z__3.r, z__2.i = z__3.i;
+ d__3 = *n * avg;
+ z__1.r = z__2.r - d__3, z__1.i = z__2.i;
+ c0 = z__1.r;
+ d__ = c1 * c1 - c0 * 4 * c2;
+ if (d__ <= 0.) {
+ *info = -1;
+ return 0;
+ }
+ si = c0 * -2 / (c1 + sqrt(d__));
+ d__ = si - s[i__];
+ u = 0.;
+ if (up) {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[j +
+ i__ * a_dim1]), abs(d__2));
+ u += s[j] * t;
+ i__3 = j;
+ i__4 = j;
+ d__1 = d__ * t;
+ z__1.r = work[i__4].r + d__1, z__1.i = work[i__4].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ + j * a_dim1]), abs(d__2));
+ u += s[j] * t;
+ i__3 = j;
+ i__4 = j;
+ d__1 = d__ * t;
+ z__1.r = work[i__4].r + d__1, z__1.i = work[i__4].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ }
+ } else {
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__
+ + j * a_dim1]), abs(d__2));
+ u += s[j] * t;
+ i__3 = j;
+ i__4 = j;
+ d__1 = d__ * t;
+ z__1.r = work[i__4].r + d__1, z__1.i = work[i__4].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ t = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[j +
+ i__ * a_dim1]), abs(d__2));
+ u += s[j] * t;
+ i__3 = j;
+ i__4 = j;
+ d__1 = d__ * t;
+ z__1.r = work[i__4].r + d__1, z__1.i = work[i__4].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ }
+ }
+ i__2 = i__;
+ z__4.r = u + work[i__2].r, z__4.i = work[i__2].i;
+ z__3.r = d__ * z__4.r, z__3.i = d__ * z__4.i;
+ d__1 = (doublereal) (*n);
+ z__2.r = z__3.r / d__1, z__2.i = z__3.i / d__1;
+ z__1.r = avg + z__2.r, z__1.i = z__2.i;
+ avg = z__1.r;
+ s[i__] = si;
+ }
+ }
+L999:
+ smlnum = dlamch_("SAFEMIN");
+ bignum = 1. / smlnum;
+ smin = bignum;
+ smax = 0.;
+ t = 1. / sqrt(avg);
+ base = dlamch_("B");
+ u = 1. / log(base);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = (integer) (u * log(s[i__] * t));
+ s[i__] = pow_di(&base, &i__2);
+/* Computing MIN */
+ d__1 = smin, d__2 = s[i__];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = smax, d__2 = s[i__];
+ smax = max(d__1,d__2);
+ }
+ *scond = max(smin,smlnum) / min(smax,bignum);
+
+ return 0;
+} /* zsyequb_ */
diff --git a/SRC/zsymv.c b/SRC/zsymv.c
new file mode 100644
index 0000000..826855b
--- /dev/null
+++ b/SRC/zsymv.c
@@ -0,0 +1,429 @@
+/* zsymv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zsymv_(char *uplo, integer *n, doublecomplex *alpha,
+ doublecomplex *a, integer *lda, doublecomplex *x, integer *incx,
+ doublecomplex *beta, doublecomplex *y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Local variables */
+ integer i__, j, ix, iy, jx, jy, kx, ky, info;
+ doublecomplex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSYMV performs the matrix-vector operation */
+
+/* y := alpha*A*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are n element vectors and */
+/* A is an n by n symmetric matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array A is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of A */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of A */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* N (input) INTEGER */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA (input) COMPLEX*16 */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A (input) COMPLEX*16 array, dimension ( LDA, N ) */
+/* Before entry, with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular part of the symmetric matrix and the strictly */
+/* lower triangular part of A is not referenced. */
+/* Before entry, with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular part of the symmetric matrix and the strictly */
+/* upper triangular part of A is not referenced. */
+/* Unchanged on exit. */
+
+/* LDA (input) INTEGER */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, N ). */
+/* Unchanged on exit. */
+
+/* X (input) COMPLEX*16 array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the N- */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX (input) INTEGER */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA (input) COMPLEX*16 */
+/* On entry, BETA specifies the scalar beta. When BETA is */
+/* supplied as zero then Y need not be set on input. */
+/* Unchanged on exit. */
+
+/* Y (input/output) COMPLEX*16 array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the n */
+/* element vector y. On exit, Y is overwritten by the updated */
+/* vector y. */
+
+/* INCY (input) INTEGER */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*lda < max(1,*n)) {
+ info = 5;
+ } else if (*incx == 0) {
+ info = 7;
+ } else if (*incy == 0) {
+ info = 10;
+ }
+ if (info != 0) {
+ xerbla_("ZSYMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r == 1. &&
+ beta->i == 0.)) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through the triangular part */
+/* of A. */
+
+/* First form y := beta*y. */
+
+ if (beta->r != 1. || beta->i != 0.) {
+ if (*incy == 1) {
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ y[i__2].r = 0., y[i__2].i = 0.;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ y[i__2].r = 0., y[i__2].i = 0.;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ i__3 = iy;
+ z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (alpha->r == 0. && alpha->i == 0.) {
+ return 0;
+ }
+ if (lsame_(uplo, "U")) {
+
+/* Form y when A is stored in upper triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[
+ i__4].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L50: */
+ }
+ i__2 = j;
+ i__3 = j;
+ i__4 = j + j * a_dim1;
+ z__3.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i, z__3.i =
+ temp1.r * a[i__4].i + temp1.i * a[i__4].r;
+ z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i;
+ z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ ix = kx;
+ iy = ky;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = iy;
+ i__4 = iy;
+ i__5 = i__ + j * a_dim1;
+ z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ i__3 = i__ + j * a_dim1;
+ i__4 = ix;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[
+ i__4].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ i__2 = jy;
+ i__3 = jy;
+ i__4 = j + j * a_dim1;
+ z__3.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i, z__3.i =
+ temp1.r * a[i__4].i + temp1.i * a[i__4].r;
+ z__2.r = y[i__3].r + z__3.r, z__2.i = y[i__3].i + z__3.i;
+ z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ jx += *incx;
+ jy += *incy;
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y when A is stored in lower triangle. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ i__2 = j;
+ i__3 = j;
+ i__4 = j + j * a_dim1;
+ z__2.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i, z__2.i =
+ temp1.r * a[i__4].i + temp1.i * a[i__4].r;
+ z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__ + j * a_dim1;
+ z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[
+ i__4].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L90: */
+ }
+ i__2 = j;
+ i__3 = j;
+ z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ i__2 = jy;
+ i__3 = jy;
+ i__4 = j + j * a_dim1;
+ z__2.r = temp1.r * a[i__4].r - temp1.i * a[i__4].i, z__2.i =
+ temp1.r * a[i__4].i + temp1.i * a[i__4].r;
+ z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ ix = jx;
+ iy = jy;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ ix += *incx;
+ iy += *incy;
+ i__3 = iy;
+ i__4 = iy;
+ i__5 = i__ + j * a_dim1;
+ z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ i__3 = i__ + j * a_dim1;
+ i__4 = ix;
+ z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i,
+ z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[
+ i__4].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L110: */
+ }
+ i__2 = jy;
+ i__3 = jy;
+ z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ jx += *incx;
+ jy += *incy;
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZSYMV */
+
+} /* zsymv_ */
diff --git a/SRC/zsyr.c b/SRC/zsyr.c
new file mode 100644
index 0000000..81d2ef8
--- /dev/null
+++ b/SRC/zsyr.c
@@ -0,0 +1,289 @@
+/* zsyr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zsyr_(char *uplo, integer *n, doublecomplex *alpha,
+ doublecomplex *x, integer *incx, doublecomplex *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1, z__2;
+
+ /* Local variables */
+ integer i__, j, ix, jx, kx, info;
+ doublecomplex temp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSYR performs the symmetric rank 1 operation */
+
+/* A := alpha*x*( x' ) + A, */
+
+/* where alpha is a complex scalar, x is an n element vector and A is an */
+/* n by n symmetric matrix. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the array A is to be referenced as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' Only the upper triangular part of A */
+/* is to be referenced. */
+
+/* UPLO = 'L' or 'l' Only the lower triangular part of A */
+/* is to be referenced. */
+
+/* Unchanged on exit. */
+
+/* N (input) INTEGER */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA (input) COMPLEX*16 */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* X (input) COMPLEX*16 array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the N- */
+/* element vector x. */
+/* Unchanged on exit. */
+
+/* INCX (input) INTEGER */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* A (input/output) COMPLEX*16 array, dimension ( LDA, N ) */
+/* Before entry, with UPLO = 'U' or 'u', the leading n by n */
+/* upper triangular part of the array A must contain the upper */
+/* triangular part of the symmetric matrix and the strictly */
+/* lower triangular part of A is not referenced. On exit, the */
+/* upper triangular part of the array A is overwritten by the */
+/* upper triangular part of the updated matrix. */
+/* Before entry, with UPLO = 'L' or 'l', the leading n by n */
+/* lower triangular part of the array A must contain the lower */
+/* triangular part of the symmetric matrix and the strictly */
+/* upper triangular part of A is not referenced. On exit, the */
+/* lower triangular part of the array A is overwritten by the */
+/* lower triangular part of the updated matrix. */
+
+/* LDA (input) INTEGER */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* max( 1, N ). */
+/* Unchanged on exit. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --x;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*incx == 0) {
+ info = 5;
+ } else if (*lda < max(1,*n)) {
+ info = 7;
+ }
+ if (info != 0) {
+ xerbla_("ZSYR ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || alpha->r == 0. && alpha->i == 0.) {
+ return 0;
+ }
+
+/* Set the start point in X if the increment is not unity. */
+
+ if (*incx <= 0) {
+ kx = 1 - (*n - 1) * *incx;
+ } else if (*incx != 1) {
+ kx = 1;
+ }
+
+/* Start the operations. In this version the elements of A are */
+/* accessed sequentially with one pass through the triangular part */
+/* of A. */
+
+ if (lsame_(uplo, "U")) {
+
+/* Form A when A is stored in upper triangle. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ i__2 = j;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__;
+ z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ z__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i +
+ z__2.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L10: */
+ }
+ }
+/* L20: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ i__2 = jx;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix = kx;
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = ix;
+ z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ z__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i +
+ z__2.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ ix += *incx;
+/* L30: */
+ }
+ }
+ jx += *incx;
+/* L40: */
+ }
+ }
+ } else {
+
+/* Form A when A is stored in lower triangle. */
+
+ if (*incx == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ i__2 = j;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__;
+ z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ z__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i +
+ z__2.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jx;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ i__2 = jx;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i,
+ z__1.i = alpha->r * x[i__2].i + alpha->i * x[i__2]
+ .r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ ix = jx;
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = ix;
+ z__2.r = x[i__5].r * temp.r - x[i__5].i * temp.i,
+ z__2.i = x[i__5].r * temp.i + x[i__5].i *
+ temp.r;
+ z__1.r = a[i__4].r + z__2.r, z__1.i = a[i__4].i +
+ z__2.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ ix += *incx;
+/* L70: */
+ }
+ }
+ jx += *incx;
+/* L80: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZSYR */
+
+} /* zsyr_ */
diff --git a/SRC/zsyrfs.c b/SRC/zsyrfs.c
new file mode 100644
index 0000000..f39ef25
--- /dev/null
+++ b/SRC/zsyrfs.c
@@ -0,0 +1,474 @@
+/* zsyrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zsyrfs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf,
+ integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x,
+ integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work,
+ doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal s, xk;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3], count;
+ logical upper;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), zsymv_(
+ char *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal lstres;
+ extern /* Subroutine */ int zsytrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSYRFS improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric indefinite, and */
+/* provides error bounds and backward error estimates for the solution. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular part */
+/* of the matrix A, and the strictly lower triangular part of A */
+/* is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of A contains the lower triangular part of */
+/* the matrix A, and the strictly upper triangular part of A is */
+/* not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The factored form of the matrix A. AF contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor U or L from the factorization A = U*D*U**T or */
+/* A = L*D*L**T as computed by ZSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by ZSYTRF. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by ZSYTRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Internal Parameters */
+/* =================== */
+
+/* ITMAX is the maximum number of steps of iterative refinement. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldx < max(1,*n)) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZSYRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+ count = 1;
+ lstres = 3.;
+L20:
+
+/* Loop until stopping criterion is satisfied. */
+
+/* Compute residual R = B - A * X */
+
+ zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ z__1.r = -1., z__1.i = -0.;
+ zsymv_(uplo, n, &z__1, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, &
+ c_b1, &work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
+ i__ + j * b_dim1]), abs(d__2));
+/* L30: */
+ }
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
+ x_dim1]), abs(d__2));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ rwork[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + k * a_dim1]), abs(d__2))) * xk;
+ i__4 = i__ + k * a_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + k * a_dim1]), abs(d__2))) * ((d__3 = x[i__5]
+ .r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j *
+ x_dim1]), abs(d__4)));
+/* L40: */
+ }
+ i__3 = k + k * a_dim1;
+ rwork[k] = rwork[k] + ((d__1 = a[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&a[k + k * a_dim1]), abs(d__2))) * xk + s;
+/* L50: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j *
+ x_dim1]), abs(d__2));
+ i__3 = k + k * a_dim1;
+ rwork[k] += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&
+ a[k + k * a_dim1]), abs(d__2))) * xk;
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ rwork[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + k * a_dim1]), abs(d__2))) * xk;
+ i__4 = i__ + k * a_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + k * a_dim1]), abs(d__2))) * ((d__3 = x[i__5]
+ .r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j *
+ x_dim1]), abs(d__4)));
+/* L60: */
+ }
+ rwork[k] += s;
+/* L70: */
+ }
+ }
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__3 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2))) / rwork[i__];
+ s = max(d__3,d__4);
+ } else {
+/* Computing MAX */
+ i__3 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = max(d__3,d__4);
+ }
+/* L80: */
+ }
+ berr[j] = s;
+
+/* Test stopping criterion. Continue iterating if */
+/* 1) The residual BERR(J) is larger than machine epsilon, and */
+/* 2) BERR(J) decreased by at least a factor of 2 during the */
+/* last iteration, and */
+/* 3) At most ITMAX iterations tried. */
+
+ if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) {
+
+/* Update solution and try again. */
+
+ zsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[1],
+ n, info);
+ zaxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
+ lstres = berr[j];
+ ++count;
+ goto L20;
+ }
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(A))* */
+/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(A) is the inverse of A */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use ZLACN2 to estimate the infinity-norm of the matrix */
+/* inv(A) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__3 = i__;
+ rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ ;
+ } else {
+ i__3 = i__;
+ rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ + safe1;
+ }
+/* L90: */
+ }
+
+ kase = 0;
+L100:
+ zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(A'). */
+
+ zsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L110: */
+ }
+ } else if (kase == 2) {
+
+/* Multiply by inv(A)*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L120: */
+ }
+ zsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+ 1], n, info);
+ }
+ goto L100;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * x_dim1;
+ d__3 = lstres, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&x[i__ + j * x_dim1]), abs(d__2));
+ lstres = max(d__3,d__4);
+/* L130: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L140: */
+ }
+
+ return 0;
+
+/* End of ZSYRFS */
+
+} /* zsyrfs_ */
diff --git a/SRC/zsyrfsx.c b/SRC/zsyrfsx.c
new file mode 100644
index 0000000..3dea882
--- /dev/null
+++ b/SRC/zsyrfsx.c
@@ -0,0 +1,631 @@
+/* zsyrfsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int zsyrfsx_(char *uplo, char *equed, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, integer *ipiv, doublereal *s, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *berr,
+ integer *n_err_bnds__, doublereal *err_bnds_norm__, doublereal *
+ err_bnds_comp__, integer *nparams, doublereal *params, doublecomplex *
+ work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal illrcond_thresh__, unstable_thresh__, err_lbnd__;
+ integer ref_type__;
+ integer j;
+ doublereal rcond_tmp__;
+ integer prec_type__;
+ doublereal cwise_wrong__;
+ char norm[1];
+ extern /* Subroutine */ int zla_syrfsx_extended__(integer *, char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *, logical *, doublereal *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ doublecomplex *, doublecomplex *, doublereal *, integer *,
+ doublereal *, doublereal *, logical *, integer *, ftnlen);
+ logical ignore_cwise__;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ logical rcequ;
+ extern doublereal zla_syrcond_c__(char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, doublereal *,
+ logical *, integer *, doublecomplex *, doublereal *, ftnlen),
+ zla_syrcond_x__(char *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublereal *, ftnlen), dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zsycon_(char *, integer *, doublecomplex *,
+ integer *, integer *, doublereal *, doublereal *, doublecomplex *,
+ integer *);
+ extern integer ilaprec_(char *);
+ integer ithresh, n_norms__;
+ doublereal rthresh;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSYRFSX improves the computed solution to a system of linear */
+/* equations when the coefficient matrix is symmetric indefinite, and */
+/* provides error bounds and backward error estimates for the */
+/* solution. In addition to normwise error bound, the code provides */
+/* maximum componentwise error bound if possible. See comments for */
+/* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds. */
+
+/* The original system of linear equations may have been equilibrated */
+/* before calling this routine, as described by arguments EQUED and S */
+/* below. In this case, the solution and error bounds returned are */
+/* for the original unequilibrated system. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* EQUED (input) CHARACTER*1 */
+/* Specifies the form of equilibration that was done to A */
+/* before calling this routine. This is needed to compute */
+/* the solution and error bounds correctly. */
+/* = 'N': No equilibration */
+/* = 'Y': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(S) * A * diag(S). */
+/* The right hand side B has been changed accordingly. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular */
+/* part of the matrix A, and the strictly lower triangular */
+/* part of A is not referenced. If UPLO = 'L', the leading */
+/* N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
+/* The factored form of the matrix A. AF contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor U or L from the factorization A = U*D*U**T or A = */
+/* L*D*L**T as computed by DSYTRF. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by DSYTRF. */
+
+/* S (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The scale factors for A. If EQUED = 'Y', A is multiplied on */
+/* the left and right by diag(S). S is an input argument if FACT = */
+/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
+/* = 'Y', each element of S must be positive. If S is output, each */
+/* element of S is a power of the radix. If S is input, each element */
+/* of S should be a power of the radix to ensure a reliable solution */
+/* and error estimates. Scaling by powers of the radix does not cause */
+/* rounding errors unless the result underflows or overflows. */
+/* Rounding errors during scaling lead to refining with a matrix that */
+/* is not equivalent to the input matrix, producing error estimates */
+/* that may not be reliable. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* On entry, the solution matrix X, as computed by DGETRS. */
+/* On exit, the improved solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0D+0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the double-precision refinement algorithm, */
+/* possibly with doubled-single computations if the */
+/* compilation environment does not support DOUBLE */
+/* PRECISION. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check the input parameters. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ ref_type__ = 1;
+ if (*nparams >= 1) {
+ if (params[1] < 0.) {
+ params[1] = 1.;
+ } else {
+ ref_type__ = (integer) params[1];
+ }
+ }
+
+/* Set default parameters. */
+
+ illrcond_thresh__ = (doublereal) (*n) * dlamch_("Epsilon");
+ ithresh = 10;
+ rthresh = .5;
+ unstable_thresh__ = .25;
+ ignore_cwise__ = FALSE_;
+
+ if (*nparams >= 2) {
+ if (params[2] < 0.) {
+ params[2] = (doublereal) ithresh;
+ } else {
+ ithresh = (integer) params[2];
+ }
+ }
+ if (*nparams >= 3) {
+ if (params[3] < 0.) {
+ if (ignore_cwise__) {
+ params[3] = 0.;
+ } else {
+ params[3] = 1.;
+ }
+ } else {
+ ignore_cwise__ = params[3] == 0.;
+ }
+ }
+ if (ref_type__ == 0 || *n_err_bnds__ == 0) {
+ n_norms__ = 0;
+ } else if (ignore_cwise__) {
+ n_norms__ = 1;
+ } else {
+ n_norms__ = 2;
+ }
+
+ rcequ = lsame_(equed, "Y");
+
+/* Test input parameters. */
+
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! rcequ && ! lsame_(equed, "N")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -11;
+ } else if (*ldx < max(1,*n)) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZSYRFSX", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || *nrhs == 0) {
+ *rcond = 1.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 0.;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.;
+ }
+ }
+ return 0;
+ }
+
+/* Default to failure. */
+
+ *rcond = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ berr[j] = 1.;
+ if (*n_err_bnds__ >= 1) {
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ } else if (*n_err_bnds__ >= 2) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ } else if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.;
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.;
+ }
+ }
+
+/* Compute the norm of A and the reciprocal of the condition */
+/* number of A. */
+
+ *(unsigned char *)norm = 'I';
+ anorm = zlansy_(norm, uplo, n, &a[a_offset], lda, &rwork[1]);
+ zsycon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1],
+ info);
+
+/* Perform refinement on each right-hand side */
+
+ if (ref_type__ != 0) {
+ prec_type__ = ilaprec_("E");
+ zla_syrfsx_extended__(&prec_type__, uplo, n, nrhs, &a[a_offset], lda,
+ &af[af_offset], ldaf, &ipiv[1], &rcequ, &s[1], &b[b_offset],
+ ldb, &x[x_offset], ldx, &berr[1], &n_norms__, &
+ err_bnds_norm__[err_bnds_norm_offset], &err_bnds_comp__[
+ err_bnds_comp_offset], &work[1], &rwork[1], &work[*n + 1],
+ (doublecomplex *)(&rwork[1]), rcond, &ithresh, &rthresh, &unstable_thresh__, &
+ ignore_cwise__, info, (ftnlen)1);
+ }
+/* Computing MAX */
+ d__1 = 10., d__2 = sqrt((doublereal) (*n));
+ err_lbnd__ = max(d__1,d__2) * dlamch_("Epsilon");
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {
+
+/* Compute scaled normwise condition number cond(A*C). */
+
+ if (rcequ) {
+ rcond_tmp__ = zla_syrcond_c__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &s[1], &c_true, info, &work[1]
+ , &rwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = zla_syrcond_c__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &s[1], &c_false, info, &work[
+ 1], &rwork[1], (ftnlen)1);
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1
+ << 1)] > 1.) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 0.;
+ if (*info <= *n) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
+ err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+ if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {
+
+/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
+/* each right-hand side using the current solution as an estimate of */
+/* the true solution. If the componentwise error estimate is too */
+/* large, then the solution is a lousy estimate of truth and the */
+/* estimated RCOND may be too optimistic. To avoid misleading users, */
+/* the inverse condition number is set to 0.0 when the estimated */
+/* cwise error is at least CWISE_WRONG. */
+
+ cwise_wrong__ = sqrt(dlamch_("Epsilon"));
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ cwise_wrong__) {
+ rcond_tmp__ = zla_syrcond_x__(uplo, n, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &x[j * x_dim1 + 1], info,
+ &work[1], &rwork[1], (ftnlen)1);
+ } else {
+ rcond_tmp__ = 0.;
+ }
+
+/* Cap the error at 1.0. */
+
+ if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1
+ << 1)] > 1.) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ }
+
+/* Threshold the error (see LAWN). */
+
+ if (rcond_tmp__ < illrcond_thresh__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 0.;
+ if (params[3] == 1. && *info < *n + j) {
+ *info = *n + j;
+ }
+ } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
+ err_lbnd__) {
+ err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
+ err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
+ }
+
+/* Save the condition number. */
+
+ if (*n_err_bnds__ >= 3) {
+ err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZSYRFSX */
+
+} /* zsyrfsx_ */
diff --git a/SRC/zsysv.c b/SRC/zsysv.c
new file mode 100644
index 0000000..ce08ea1
--- /dev/null
+++ b/SRC/zsysv.c
@@ -0,0 +1,213 @@
+/* zsysv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zsysv_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b,
+ integer *ldb, doublecomplex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ integer nb;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int zsytrf_(char *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *, integer *), zsytrs_(char *, integer *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSYSV 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 diagonal pivoting method is used to factor A as */
+/* A = U * D * U**T, if UPLO = 'U', or */
+/* A = L * D * L**T, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then */
+/* used to solve the system of equations A * X = B. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if INFO = 0, the block diagonal matrix D and the */
+/* multipliers used to obtain the factor U or L from the */
+/* factorization A = U*D*U**T or A = L*D*L**T as computed by */
+/* ZSYTRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D, as */
+/* determined by ZSYTRF. If IPIV(k) > 0, then rows and columns */
+/* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 */
+/* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, */
+/* then rows and columns k-1 and -IPIV(k) were interchanged and */
+/* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and */
+/* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and */
+/* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 */
+/* diagonal block. */
+
+/* B (input/output) 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. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK >= 1, and for best performance */
+/* LWORK >= max(1,N*NB), where NB is the optimal blocksize for */
+/* ZSYTRF. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */
+/* has been completed, but the block diagonal matrix D is */
+/* exactly singular, so the solution could not be computed. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*lwork < 1 && ! lquery) {
+ *info = -10;
+ }
+
+ if (*info == 0) {
+ if (*n == 0) {
+ lwkopt = 1;
+ } else {
+ nb = ilaenv_(&c__1, "ZSYTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZSYSV ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ zsytrf_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], lwork, info);
+ if (*info == 0) {
+
+/* Solve the system A*X = B, overwriting B with X. */
+
+ zsytrs_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], ldb,
+ info);
+
+ }
+
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZSYSV */
+
+} /* zsysv_ */
diff --git a/SRC/zsysvx.c b/SRC/zsysvx.c
new file mode 100644
index 0000000..cdcb775
--- /dev/null
+++ b/SRC/zsysvx.c
@@ -0,0 +1,368 @@
+/* zsysvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zsysvx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x,
+ integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr,
+ doublecomplex *work, integer *lwork, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, i__1, i__2;
+
+ /* Local variables */
+ integer nb;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern doublereal dlamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zsycon_(char *, integer *, doublecomplex *,
+ integer *, integer *, doublereal *, doublereal *, doublecomplex *,
+ integer *), zsyrfs_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zsytrf_(char *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *, integer *), zsytrs_(char *, integer *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSYSVX uses the diagonal pivoting factorization to compute the */
+/* solution to a complex system of linear equations A * X = B, */
+/* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */
+/* matrices. */
+
+/* Error bounds on the solution and a condition estimate are also */
+/* provided. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'N', the diagonal pivoting method is used to factor A. */
+/* The form of the factorization is */
+/* A = U * D * U**T, if UPLO = 'U', or */
+/* A = L * D * L**T, if UPLO = 'L', */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* 2. If some D(i,i)=0, so that D is exactly singular, then the routine */
+/* returns with INFO = i. Otherwise, the factored form of A is used */
+/* to estimate the condition number of the matrix A. If the */
+/* reciprocal of the condition number is less than machine precision, */
+/* INFO = N+1 is returned as a warning, but the routine still goes on */
+/* to solve for X and compute error bounds as described below. */
+
+/* 3. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 4. Iterative refinement is applied to improve the computed solution */
+/* matrix and calculate error bounds and backward error estimates */
+/* for it. */
+
+/* Arguments */
+/* ========= */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of A has been */
+/* supplied on entry. */
+/* = 'F': On entry, AF and IPIV contain the factored form */
+/* of A. A, AF and IPIV will not be modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular part */
+/* of the matrix A, and the strictly lower triangular part of A */
+/* is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of A contains the lower triangular part of */
+/* the matrix A, and the strictly upper triangular part of A is */
+/* not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) COMPLEX*16 array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**T or A = L*D*L**T as computed by ZSYTRF. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L from the factorization */
+/* A = U*D*U**T or A = L*D*L**T. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by ZSYTRF. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains details of the interchanges and the block structure */
+/* of D, as determined by ZSYTRF. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The N-by-NRHS right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number of the matrix */
+/* A. If RCOND is less than the machine precision (in */
+/* particular, if RCOND = 0), the matrix is singular to working */
+/* precision. This condition is indicated by a return code of */
+/* INFO > 0. */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK >= max(1,2*N), and for best */
+/* performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where */
+/* NB is the optimal blocksize for ZSYTRF. */
+
+/* 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. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, and i is */
+/* <= N: D(i,i) is exactly zero. The factorization */
+/* has been completed but the factor D is exactly */
+/* singular, so the solution and error bounds could */
+/* not be computed. RCOND = 0 is returned. */
+/* = N+1: D is nonsingular, but RCOND is less than machine */
+/* precision, meaning that the matrix is singular */
+/* to working precision. Nevertheless, the */
+/* solution and error bounds are computed because */
+/* there are a number of situations where the */
+/* computed solution can be more accurate than the */
+/* value of RCOND would suggest. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ lquery = *lwork == -1;
+ if (! nofact && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -11;
+ } else if (*ldx < max(1,*n)) {
+ *info = -13;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n << 1;
+ if (*lwork < max(i__1,i__2) && ! lquery) {
+ *info = -18;
+ }
+ }
+
+ if (*info == 0) {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n << 1;
+ lwkopt = max(i__1,i__2);
+ if (nofact) {
+ nb = ilaenv_(&c__1, "ZSYTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+/* Computing MAX */
+ i__1 = lwkopt, i__2 = *n * nb;
+ lwkopt = max(i__1,i__2);
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZSYSVX", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+ if (nofact) {
+
+/* Compute the factorization A = U*D*U' or A = L*D*L'. */
+
+ zlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ zsytrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], lwork,
+ info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+ *rcond = 0.;
+ return 0;
+ }
+ }
+
+/* Compute the norm of the matrix A. */
+
+ anorm = zlansy_("I", uplo, n, &a[a_offset], lda, &rwork[1]);
+
+/* Compute the reciprocal of the condition number of A. */
+
+ zsycon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1],
+ info);
+
+/* Compute the solution vectors X. */
+
+ zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ zsytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solutions and */
+/* compute error bounds and backward error estimates for them. */
+
+ zsyrfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1],
+ &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1]
+, &rwork[1], info);
+
+/* Set INFO = N+1 if the matrix is singular to working precision. */
+
+ if (*rcond < dlamch_("Epsilon")) {
+ *info = *n + 1;
+ }
+
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZSYSVX */
+
+} /* zsysvx_ */
diff --git a/SRC/zsysvxx.c b/SRC/zsysvxx.c
new file mode 100644
index 0000000..833f4bf
--- /dev/null
+++ b/SRC/zsysvxx.c
@@ -0,0 +1,633 @@
+/* zsysvxx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zsysvxx_(char *fact, char *uplo, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
+ ldaf, integer *ipiv, char *equed, doublereal *s, doublecomplex *b,
+ integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond,
+ doublereal *rpvgrw, doublereal *berr, integer *n_err_bnds__,
+ doublereal *err_bnds_norm__, doublereal *err_bnds_comp__, integer *
+ nparams, doublereal *params, doublecomplex *work, doublereal *rwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
+ x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
+ err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ extern /* Subroutine */ int zsyrfsx_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+, doublereal *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, doublecomplex *,
+ doublereal *, integer *);
+ integer j;
+ doublereal amax, smin, smax;
+ extern logical lsame_(char *, char *);
+ doublereal scond;
+ extern doublereal zla_syrpvgrw__(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ doublereal *, ftnlen);
+ logical equil, rcequ;
+ extern doublereal dlamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ integer infequ;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal smlnum;
+ extern /* Subroutine */ int zlaqsy_(char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *, char *), zsytrf_(char *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *, integer *), zlascl2_(integer *, integer *, doublereal *,
+ doublecomplex *, integer *), zsytrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *
+, integer *), zsyequb_(char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *,
+ doublecomplex *, integer *);
+
+
+/* -- LAPACK driver routine (version 3.2.1) -- */
+/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
+/* -- Jason Riedy of Univ. of California Berkeley. -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley and NAG Ltd. -- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSYSVXX uses the diagonal pivoting factorization to compute the */
+/* solution to a complex*16 system of linear equations A * X = B, where */
+/* A is an N-by-N symmetric matrix and X and B are N-by-NRHS */
+/* matrices. */
+
+/* If requested, both normwise and maximum componentwise error bounds */
+/* are returned. ZSYSVXX will return a solution with a tiny */
+/* guaranteed error (O(eps) where eps is the working machine */
+/* precision) unless the matrix is very ill-conditioned, in which */
+/* case a warning is returned. Relevant condition numbers also are */
+/* calculated and returned. */
+
+/* ZSYSVXX accepts user-provided factorizations and equilibration */
+/* factors; see the definitions of the FACT and EQUED options. */
+/* Solving with refinement and using a factorization from a previous */
+/* ZSYSVXX call will also produce a solution with either O(eps) */
+/* errors or warnings, but we cannot make that claim for general */
+/* user-provided factorizations and equilibration factors if they */
+/* differ from what ZSYSVXX would itself produce. */
+
+/* Description */
+/* =========== */
+
+/* The following steps are performed: */
+
+/* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate */
+/* the system: */
+
+/* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B */
+
+/* Whether or not the system will be equilibrated depends on the */
+/* scaling of the matrix A, but if equilibration is used, A is */
+/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
+
+/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */
+/* the matrix A (after equilibration if FACT = 'E') as */
+
+/* A = U * D * U**T, if UPLO = 'U', or */
+/* A = L * D * L**T, if UPLO = 'L', */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is symmetric and block diagonal with */
+/* 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* 3. If some D(i,i)=0, so that D is exactly singular, then the */
+/* routine returns with INFO = i. Otherwise, the factored form of A */
+/* is used to estimate the condition number of the matrix A (see */
+/* argument RCOND). If the reciprocal of the condition number is */
+/* less than machine precision, the routine still goes on to solve */
+/* for X and compute error bounds as described below. */
+
+/* 4. The system of equations is solved for X using the factored form */
+/* of A. */
+
+/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */
+/* the routine will use iterative refinement to try to get a small */
+/* error and error bounds. Refinement calculates the residual to at */
+/* least twice the working precision. */
+
+/* 6. If equilibration was used, the matrix X is premultiplied by */
+/* diag(R) so that it solves the original system before */
+/* equilibration. */
+
+/* Arguments */
+/* ========= */
+
+/* Some optional parameters are bundled in the PARAMS array. These */
+/* settings determine how refinement is performed, but often the */
+/* defaults are acceptable. If the defaults are acceptable, users */
+/* can pass NPARAMS = 0 which prevents the source code from accessing */
+/* the PARAMS argument. */
+
+/* FACT (input) CHARACTER*1 */
+/* Specifies whether or not the factored form of the matrix A is */
+/* supplied on entry, and if not, whether the matrix A should be */
+/* equilibrated before it is factored. */
+/* = 'F': On entry, AF and IPIV contain the factored form of A. */
+/* If EQUED is not 'N', the matrix A has been */
+/* equilibrated with scaling factors given by S. */
+/* A, AF, and IPIV are not modified. */
+/* = 'N': The matrix A will be copied to AF and factored. */
+/* = 'E': The matrix A will be equilibrated if necessary, then */
+/* copied to AF and factored. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The number of linear equations, i.e., the order of the */
+/* matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of A contains the upper triangular */
+/* part of the matrix A, and the strictly lower triangular */
+/* part of A is not referenced. If UPLO = 'L', the leading */
+/* N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
+/* diag(S)*A*diag(S). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AF (input or output) COMPLEX*16 array, dimension (LDAF,N) */
+/* If FACT = 'F', then AF is an input argument and on entry */
+/* contains the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L from the factorization A = */
+/* U*D*U**T or A = L*D*L**T as computed by DSYTRF. */
+
+/* If FACT = 'N', then AF is an output argument and on exit */
+/* returns the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L from the factorization A = */
+/* U*D*U**T or A = L*D*L**T. */
+
+/* LDAF (input) INTEGER */
+/* The leading dimension of the array AF. LDAF >= max(1,N). */
+
+/* IPIV (input or output) INTEGER array, dimension (N) */
+/* If FACT = 'F', then IPIV is an input argument and on entry */
+/* contains details of the interchanges and the block */
+/* structure of D, as determined by DSYTRF. If IPIV(k) > 0, */
+/* then rows and columns k and IPIV(k) were interchanged and */
+/* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and */
+/* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and */
+/* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 */
+/* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0, */
+/* then rows and columns k+1 and -IPIV(k) were interchanged */
+/* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* If FACT = 'N', then IPIV is an output argument and on exit */
+/* contains details of the interchanges and the block */
+/* structure of D, as determined by DSYTRF. */
+
+/* EQUED (input or output) CHARACTER*1 */
+/* Specifies the form of equilibration that was done. */
+/* = 'N': No equilibration (always true if FACT = 'N'). */
+/* = 'Y': Both row and column equilibration, i.e., A has been */
+/* replaced by diag(S) * A * diag(S). */
+/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
+/* output argument. */
+
+/* S (input or output) DOUBLE PRECISION array, dimension (N) */
+/* The scale factors for A. If EQUED = 'Y', A is multiplied on */
+/* the left and right by diag(S). S is an input argument if FACT = */
+/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
+/* = 'Y', each element of S must be positive. If S is output, each */
+/* element of S is a power of the radix. If S is input, each element */
+/* of S should be a power of the radix to ensure a reliable solution */
+/* and error estimates. Scaling by powers of the radix does not cause */
+/* rounding errors unless the result underflows or overflows. */
+/* Rounding errors during scaling lead to refining with a matrix that */
+/* is not equivalent to the input matrix, producing error estimates */
+/* that may not be reliable. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the N-by-NRHS right hand side matrix B. */
+/* On exit, */
+/* if EQUED = 'N', B is not modified; */
+/* if EQUED = 'Y', B is overwritten by diag(S)*B; */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* If INFO = 0, the N-by-NRHS solution matrix X to the original */
+/* system of equations. Note that A and B are modified on exit if */
+/* EQUED .ne. 'N', and the solution to the equilibrated system is */
+/* inv(diag(S))*X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* Reciprocal scaled condition number. This is an estimate of the */
+/* reciprocal Skeel condition number of the matrix A after */
+/* equilibration (if done). If this is less than the machine */
+/* precision (in particular, if it is zero), the matrix is singular */
+/* to working precision. Note that the error may still be small even */
+/* if this number is very small and the matrix appears ill- */
+/* conditioned. */
+
+/* RPVGRW (output) DOUBLE PRECISION */
+/* Reciprocal pivot growth. On exit, this contains the reciprocal */
+/* pivot growth factor norm(A)/norm(U). The "max absolute element" */
+/* norm is used. If this is much less than 1, then the stability of */
+/* the LU factorization of the (equilibrated) matrix A could be poor. */
+/* This also means that the solution X, estimated condition numbers, */
+/* and error bounds could be unreliable. If factorization fails with */
+/* 0<INFO<=N, then this contains the reciprocal pivot growth factor */
+/* for the leading INFO columns of A. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* Componentwise relative backward error. This is the */
+/* componentwise relative backward error of each solution vector X(j) */
+/* (i.e., the smallest relative change in any element of A or B that */
+/* makes X(j) an exact solution). */
+
+/* N_ERR_BNDS (input) INTEGER */
+/* Number of error bounds to return for each right hand side */
+/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
+/* ERR_BNDS_COMP below. */
+
+/* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* normwise relative error, which is defined as follows: */
+
+/* Normwise relative error in the ith solution vector: */
+/* max_j (abs(XTRUE(j,i) - X(j,i))) */
+/* ------------------------------ */
+/* max_j abs(X(j,i)) */
+
+/* The array is indexed by the type of error information as described */
+/* below. There currently are up to three pieces of information */
+/* returned. */
+
+/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_NORM(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated normwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*A, where S scales each row by a power of the */
+/* radix so all absolute row sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */
+/* For each right-hand side, this array contains information about */
+/* various error bounds and condition numbers corresponding to the */
+/* componentwise relative error, which is defined as follows: */
+
+/* Componentwise relative error in the ith solution vector: */
+/* abs(XTRUE(j,i) - X(j,i)) */
+/* max_j ---------------------- */
+/* abs(X(j,i)) */
+
+/* The array is indexed by the right-hand side i (on which the */
+/* componentwise relative error depends), and the type of error */
+/* information as described below. There currently are up to three */
+/* pieces of information returned for each right-hand side. If */
+/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
+/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
+/* the first (:,N_ERR_BNDS) entries are returned. */
+
+/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
+/* right-hand side. */
+
+/* The second index in ERR_BNDS_COMP(:,err) contains the following */
+/* three fields: */
+/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
+/* reciprocal condition number is less than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). */
+
+/* err = 2 "Guaranteed" error bound: The estimated forward error, */
+/* almost certainly within a factor of 10 of the true error */
+/* so long as the next entry is greater than the threshold */
+/* sqrt(n) * dlamch('Epsilon'). This error bound should only */
+/* be trusted if the previous boolean is true. */
+
+/* err = 3 Reciprocal condition number: Estimated componentwise */
+/* reciprocal condition number. Compared with the threshold */
+/* sqrt(n) * dlamch('Epsilon') to determine if the error */
+/* estimate is "guaranteed". These reciprocal condition */
+/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
+/* appropriately scaled matrix Z. */
+/* Let Z = S*(A*diag(x)), where x is the solution for the */
+/* current right-hand side and S scales each row of */
+/* A*diag(x) by a power of the radix so all absolute row */
+/* sums of Z are approximately 1. */
+
+/* See Lapack Working Note 165 for further details and extra */
+/* cautions. */
+
+/* NPARAMS (input) INTEGER */
+/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
+/* PARAMS array is never referenced and default values are used. */
+
+/* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS */
+/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
+/* that entry will be filled with default value used for that */
+/* parameter. Only positions up to NPARAMS are accessed; defaults */
+/* are used for higher-numbered parameters. */
+
+/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
+/* refinement or not. */
+/* Default: 1.0D+0 */
+/* = 0.0 : No refinement is performed, and no error bounds are */
+/* computed. */
+/* = 1.0 : Use the extra-precise refinement algorithm. */
+/* (other values are reserved for future use) */
+
+/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
+/* computations allowed for refinement. */
+/* Default: 10 */
+/* Aggressive: Set to 100 to permit convergence using approximate */
+/* factorizations or factorizations other than LU. If */
+/* the factorization uses a technique other than */
+/* Gaussian elimination, the guarantees in */
+/* err_bnds_norm and err_bnds_comp may no longer be */
+/* trustworthy. */
+
+/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
+/* will attempt to find a solution with small componentwise */
+/* relative error in the double-precision algorithm. Positive */
+/* is true, 0.0 is false. */
+/* Default: 1.0 (attempt componentwise convergence) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit. The solution to every right-hand side is */
+/* guaranteed. */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
+/* has been completed, but the factor U is exactly singular, so */
+/* the solution and error bounds could not be computed. RCOND = 0 */
+/* is returned. */
+/* = N+J: The solution corresponding to the Jth right-hand side is */
+/* not guaranteed. The solutions corresponding to other right- */
+/* hand sides K with K > J may not be guaranteed as well, but */
+/* only the first such right-hand side is reported. If a small */
+/* componentwise error is not requested (PARAMS(3) = 0.0) then */
+/* the Jth right-hand side is the first with a normwise error */
+/* bound that is not guaranteed (the smallest J such */
+/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
+/* the Jth right-hand side is the first with either a normwise or */
+/* componentwise error bound that is not guaranteed (the smallest */
+/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
+/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
+/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
+/* about all of the right-hand sides check ERR_BNDS_NORM or */
+/* ERR_BNDS_COMP. */
+
+/* ================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ err_bnds_comp_dim1 = *nrhs;
+ err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
+ err_bnds_comp__ -= err_bnds_comp_offset;
+ err_bnds_norm_dim1 = *nrhs;
+ err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
+ err_bnds_norm__ -= err_bnds_norm_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ af_dim1 = *ldaf;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --ipiv;
+ --s;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --berr;
+ --params;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ if (nofact || equil) {
+ *(unsigned char *)equed = 'N';
+ rcequ = FALSE_;
+ } else {
+ rcequ = lsame_(equed, "Y");
+ }
+
+/* Default is failure. If an input parameter is wrong or */
+/* factorization fails, make everything look horrible. Only the */
+/* pivot growth is set here, the rest is initialized in ZSYRFSX. */
+
+ *rpvgrw = 0.;
+
+/* Test the input parameters. PARAMS is not tested until ZSYRFSX. */
+
+ if (! nofact && ! equil && ! lsame_(fact, "F")) {
+ *info = -1;
+ } else if (! lsame_(uplo, "U") && ! lsame_(uplo,
+ "L")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*nrhs < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldaf < max(1,*n)) {
+ *info = -8;
+ } else if (lsame_(fact, "F") && ! (rcequ || lsame_(
+ equed, "N"))) {
+ *info = -9;
+ } else {
+ if (rcequ) {
+ smin = bignum;
+ smax = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ d__1 = smin, d__2 = s[j];
+ smin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = smax, d__2 = s[j];
+ smax = max(d__1,d__2);
+/* L10: */
+ }
+ if (smin <= 0.) {
+ *info = -10;
+ } else if (*n > 0) {
+ scond = max(smin,smlnum) / min(smax,bignum);
+ } else {
+ scond = 1.;
+ }
+ }
+ if (*info == 0) {
+ if (*ldb < max(1,*n)) {
+ *info = -12;
+ } else if (*ldx < max(1,*n)) {
+ *info = -14;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZSYSVXX", &i__1);
+ return 0;
+ }
+
+ if (equil) {
+
+/* Compute row and column scalings to equilibrate the matrix A. */
+
+ zsyequb_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, &work[1], &
+ infequ);
+ if (infequ == 0) {
+
+/* Equilibrate the matrix. */
+
+ zlaqsy_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed);
+ rcequ = lsame_(equed, "Y");
+ }
+ }
+
+/* Scale the right hand-side. */
+
+ if (rcequ) {
+ zlascl2_(n, nrhs, &s[1], &b[b_offset], ldb);
+ }
+
+ if (nofact || equil) {
+
+/* Compute the LU factorization of A. */
+
+ zlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+ i__1 = max(1,*n) * 5;
+ zsytrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], &i__1,
+ info);
+
+/* Return if INFO is non-zero. */
+
+ if (*info > 0) {
+
+/* Pivot in column INFO is exactly 0 */
+/* Compute the reciprocal pivot growth factor of the */
+/* leading rank-deficient INFO columns of A. */
+
+ if (*n > 0) {
+ *rpvgrw = zla_syrpvgrw__(uplo, n, info, &a[a_offset], lda, &
+ af[af_offset], ldaf, &ipiv[1], &rwork[1], (ftnlen)1);
+ }
+ return 0;
+ }
+ }
+
+/* Compute the reciprocal pivot growth factor RPVGRW. */
+
+ if (*n > 0) {
+ *rpvgrw = zla_syrpvgrw__(uplo, n, info, &a[a_offset], lda, &af[
+ af_offset], ldaf, &ipiv[1], &rwork[1], (ftnlen)1);
+ }
+
+/* Compute the solution matrix X. */
+
+ zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+ zsytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
+ info);
+
+/* Use iterative refinement to improve the computed solution and */
+/* compute error bounds and backward error estimates for it. */
+
+ zsyrfsx_(uplo, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &
+ ipiv[1], &s[1], &b[b_offset], ldb, &x[x_offset], ldx, rcond, &
+ berr[1], n_err_bnds__, &err_bnds_norm__[err_bnds_norm_offset], &
+ err_bnds_comp__[err_bnds_comp_offset], nparams, ¶ms[1], &work[
+ 1], &rwork[1], info);
+
+/* Scale solutions. */
+
+ if (rcequ) {
+ zlascl2_(n, nrhs, &s[1], &x[x_offset], ldx);
+ }
+
+ return 0;
+
+/* End of ZSYSVXX */
+
+} /* zsysvxx_ */
diff --git a/SRC/zsytf2.c b/SRC/zsytf2.c
new file mode 100644
index 0000000..578000f
--- /dev/null
+++ b/SRC/zsytf2.c
@@ -0,0 +1,727 @@
+/* zsytf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zsytf2_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *ipiv, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_imag(doublecomplex *);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublecomplex t, r1, d11, d12, d21, d22;
+ integer kk, kp;
+ doublecomplex wk, wkm1, wkp1;
+ integer imax, jmax;
+ extern /* Subroutine */ int zsyr_(char *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal alpha;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ integer kstep;
+ logical upper;
+ extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ doublereal absakk;
+ extern logical disnan_(doublereal *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal colmax;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ doublereal rowmax;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSYTF2 computes the factorization of a complex symmetric matrix A */
+/* using the Bunch-Kaufman diagonal pivoting method: */
+
+/* A = U*D*U' or A = L*D*L' */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, U' is the transpose of U, 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. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
+/* n-by-n upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n-by-n lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* On exit, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L (see below for further details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* > 0: if INFO = k, D(k,k) is exactly zero. 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. */
+
+/* Further Details */
+/* =============== */
+
+/* 09-29-06 - patch from */
+/* Bobby Cheng, MathWorks */
+
+/* Replace l.209 and l.377 */
+/* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN */
+/* by */
+/* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN */
+
+/* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services */
+/* Company */
+
+/* If UPLO = 'U', then A = U*D*U', where */
+/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
+/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
+/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I v 0 ) k-s */
+/* U(k) = ( 0 I 0 ) s */
+/* ( 0 0 I ) n-k */
+/* k-s s n-k */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
+/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
+/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
+
+/* If UPLO = 'L', then A = L*D*L', where */
+/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
+/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
+/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I 0 0 ) k-1 */
+/* L(k) = ( 0 I 0 ) s */
+/* ( 0 v I ) n-k-s+1 */
+/* k-1 s n-k-s+1 */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
+/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
+/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZSYTF2", &i__1);
+ return 0;
+ }
+
+/* Initialize ALPHA for use in choosing pivot block size. */
+
+ alpha = (sqrt(17.) + 1.) / 8.;
+
+ if (upper) {
+
+/* Factorize A as U*D*U' using the upper triangle of A */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2 */
+
+ k = *n;
+L10:
+
+/* If K < 1, exit from loop */
+
+ if (k < 1) {
+ goto L70;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = k + k * a_dim1;
+ absakk = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[k + k *
+ a_dim1]), abs(d__2));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ imax = izamax_(&i__1, &a[k * a_dim1 + 1], &c__1);
+ i__1 = imax + k * a_dim1;
+ colmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[imax +
+ k * a_dim1]), abs(d__2));
+ } else {
+ colmax = 0.;
+ }
+
+ if (max(absakk,colmax) == 0. || disnan_(&absakk)) {
+
+/* Column K is zero or contains a NaN: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = k - imax;
+ jmax = imax + izamax_(&i__1, &a[imax + (imax + 1) * a_dim1],
+ lda);
+ i__1 = imax + jmax * a_dim1;
+ rowmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[
+ imax + jmax * a_dim1]), abs(d__2));
+ if (imax > 1) {
+ i__1 = imax - 1;
+ jmax = izamax_(&i__1, &a[imax * a_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__1 = jmax + imax * a_dim1;
+ d__3 = rowmax, d__4 = (d__1 = a[i__1].r, abs(d__1)) + (
+ d__2 = d_imag(&a[jmax + imax * a_dim1]), abs(d__2)
+ );
+ rowmax = max(d__3,d__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = imax + imax * a_dim1;
+ if ((d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[
+ imax + imax * a_dim1]), abs(d__2)) >= alpha *
+ rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k - kstep + 1;
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the leading */
+/* submatrix A(1:k,1:k) */
+
+ i__1 = kp - 1;
+ zswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1],
+ &c__1);
+ i__1 = kk - kp - 1;
+ zswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp +
+ 1) * a_dim1], lda);
+ i__1 = kk + kk * a_dim1;
+ t.r = a[i__1].r, t.i = a[i__1].i;
+ i__1 = kk + kk * a_dim1;
+ i__2 = kp + kp * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + kp * a_dim1;
+ a[i__1].r = t.r, a[i__1].i = t.i;
+ if (kstep == 2) {
+ i__1 = k - 1 + k * a_dim1;
+ t.r = a[i__1].r, t.i = a[i__1].i;
+ i__1 = k - 1 + k * a_dim1;
+ i__2 = kp + k * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + k * a_dim1;
+ a[i__1].r = t.r, a[i__1].i = t.i;
+ }
+ }
+
+/* Update the leading submatrix */
+
+ if (kstep == 1) {
+
+/* 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 */
+
+/* Perform a rank-1 update of A(1:k-1,1:k-1) as */
+
+/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */
+
+ z_div(&z__1, &c_b1, &a[k + k * a_dim1]);
+ r1.r = z__1.r, r1.i = z__1.i;
+ i__1 = k - 1;
+ z__1.r = -r1.r, z__1.i = -r1.i;
+ zsyr_(uplo, &i__1, &z__1, &a[k * a_dim1 + 1], &c__1, &a[
+ a_offset], lda);
+
+/* Store U(k) in column k */
+
+ i__1 = k - 1;
+ zscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
+ } 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) )' */
+/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */
+
+ if (k > 2) {
+
+ i__1 = k - 1 + k * a_dim1;
+ d12.r = a[i__1].r, d12.i = a[i__1].i;
+ z_div(&z__1, &a[k - 1 + (k - 1) * a_dim1], &d12);
+ d22.r = z__1.r, d22.i = z__1.i;
+ z_div(&z__1, &a[k + k * a_dim1], &d12);
+ d11.r = z__1.r, d11.i = z__1.i;
+ z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r *
+ d22.i + d11.i * d22.r;
+ z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.;
+ z_div(&z__1, &c_b1, &z__2);
+ t.r = z__1.r, t.i = z__1.i;
+ z_div(&z__1, &t, &d12);
+ d12.r = z__1.r, d12.i = z__1.i;
+
+ for (j = k - 2; j >= 1; --j) {
+ i__1 = j + (k - 1) * a_dim1;
+ z__3.r = d11.r * a[i__1].r - d11.i * a[i__1].i,
+ z__3.i = d11.r * a[i__1].i + d11.i * a[i__1]
+ .r;
+ i__2 = j + k * a_dim1;
+ z__2.r = z__3.r - a[i__2].r, z__2.i = z__3.i - a[i__2]
+ .i;
+ z__1.r = d12.r * z__2.r - d12.i * z__2.i, z__1.i =
+ d12.r * z__2.i + d12.i * z__2.r;
+ wkm1.r = z__1.r, wkm1.i = z__1.i;
+ i__1 = j + k * a_dim1;
+ z__3.r = d22.r * a[i__1].r - d22.i * a[i__1].i,
+ z__3.i = d22.r * a[i__1].i + d22.i * a[i__1]
+ .r;
+ i__2 = j + (k - 1) * a_dim1;
+ z__2.r = z__3.r - a[i__2].r, z__2.i = z__3.i - a[i__2]
+ .i;
+ z__1.r = d12.r * z__2.r - d12.i * z__2.i, z__1.i =
+ d12.r * z__2.i + d12.i * z__2.r;
+ wk.r = z__1.r, wk.i = z__1.i;
+ for (i__ = j; i__ >= 1; --i__) {
+ i__1 = i__ + j * a_dim1;
+ i__2 = i__ + j * a_dim1;
+ i__3 = i__ + k * a_dim1;
+ z__3.r = a[i__3].r * wk.r - a[i__3].i * wk.i,
+ z__3.i = a[i__3].r * wk.i + a[i__3].i *
+ wk.r;
+ z__2.r = a[i__2].r - z__3.r, z__2.i = a[i__2].i -
+ z__3.i;
+ i__4 = i__ + (k - 1) * a_dim1;
+ z__4.r = a[i__4].r * wkm1.r - a[i__4].i * wkm1.i,
+ z__4.i = a[i__4].r * wkm1.i + a[i__4].i *
+ wkm1.r;
+ z__1.r = z__2.r - z__4.r, z__1.i = z__2.i -
+ z__4.i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+/* L20: */
+ }
+ i__1 = j + k * a_dim1;
+ a[i__1].r = wk.r, a[i__1].i = wk.i;
+ i__1 = j + (k - 1) * a_dim1;
+ a[i__1].r = wkm1.r, a[i__1].i = wkm1.i;
+/* L30: */
+ }
+
+ }
+
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k - 1] = -kp;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kstep;
+ goto L10;
+
+ } else {
+
+/* Factorize A as L*D*L' using the lower triangle of A */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2 */
+
+ k = 1;
+L40:
+
+/* If K > N, exit from loop */
+
+ if (k > *n) {
+ goto L70;
+ }
+ kstep = 1;
+
+/* Determine rows and columns to be interchanged and whether */
+/* a 1-by-1 or 2-by-2 pivot block will be used */
+
+ i__1 = k + k * a_dim1;
+ absakk = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[k + k *
+ a_dim1]), abs(d__2));
+
+/* IMAX is the row-index of the largest off-diagonal element in */
+/* column K, and COLMAX is its absolute value */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ imax = k + izamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1);
+ i__1 = imax + k * a_dim1;
+ colmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[imax +
+ k * a_dim1]), abs(d__2));
+ } else {
+ colmax = 0.;
+ }
+
+ if (max(absakk,colmax) == 0. || disnan_(&absakk)) {
+
+/* Column K is zero or contains a NaN: set INFO and continue */
+
+ if (*info == 0) {
+ *info = k;
+ }
+ kp = k;
+ } else {
+ if (absakk >= alpha * colmax) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else {
+
+/* JMAX is the column-index of the largest off-diagonal */
+/* element in row IMAX, and ROWMAX is its absolute value */
+
+ i__1 = imax - k;
+ jmax = k - 1 + izamax_(&i__1, &a[imax + k * a_dim1], lda);
+ i__1 = imax + jmax * a_dim1;
+ rowmax = (d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[
+ imax + jmax * a_dim1]), abs(d__2));
+ if (imax < *n) {
+ i__1 = *n - imax;
+ jmax = imax + izamax_(&i__1, &a[imax + 1 + imax * a_dim1],
+ &c__1);
+/* Computing MAX */
+ i__1 = jmax + imax * a_dim1;
+ d__3 = rowmax, d__4 = (d__1 = a[i__1].r, abs(d__1)) + (
+ d__2 = d_imag(&a[jmax + imax * a_dim1]), abs(d__2)
+ );
+ rowmax = max(d__3,d__4);
+ }
+
+ if (absakk >= alpha * colmax * (colmax / rowmax)) {
+
+/* no interchange, use 1-by-1 pivot block */
+
+ kp = k;
+ } else /* if(complicated condition) */ {
+ i__1 = imax + imax * a_dim1;
+ if ((d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[
+ imax + imax * a_dim1]), abs(d__2)) >= alpha *
+ rowmax) {
+
+/* interchange rows and columns K and IMAX, use 1-by-1 */
+/* pivot block */
+
+ kp = imax;
+ } else {
+
+/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
+/* pivot block */
+
+ kp = imax;
+ kstep = 2;
+ }
+ }
+ }
+
+ kk = k + kstep - 1;
+ if (kp != kk) {
+
+/* Interchange rows and columns KK and KP in the trailing */
+/* submatrix A(k:n,k:n) */
+
+ if (kp < *n) {
+ i__1 = *n - kp;
+ zswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1
+ + kp * a_dim1], &c__1);
+ }
+ i__1 = kp - kk - 1;
+ zswap_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk +
+ 1) * a_dim1], lda);
+ i__1 = kk + kk * a_dim1;
+ t.r = a[i__1].r, t.i = a[i__1].i;
+ i__1 = kk + kk * a_dim1;
+ i__2 = kp + kp * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + kp * a_dim1;
+ a[i__1].r = t.r, a[i__1].i = t.i;
+ if (kstep == 2) {
+ i__1 = k + 1 + k * a_dim1;
+ t.r = a[i__1].r, t.i = a[i__1].i;
+ i__1 = k + 1 + k * a_dim1;
+ i__2 = kp + k * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + k * a_dim1;
+ a[i__1].r = t.r, a[i__1].i = t.i;
+ }
+ }
+
+/* Update the trailing submatrix */
+
+ if (kstep == 1) {
+
+/* 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 < *n) {
+
+/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
+
+/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */
+
+ z_div(&z__1, &c_b1, &a[k + k * a_dim1]);
+ r1.r = z__1.r, r1.i = z__1.i;
+ i__1 = *n - k;
+ z__1.r = -r1.r, z__1.i = -r1.i;
+ zsyr_(uplo, &i__1, &z__1, &a[k + 1 + k * a_dim1], &c__1, &
+ a[k + 1 + (k + 1) * a_dim1], lda);
+
+/* Store L(k) in column K */
+
+ i__1 = *n - k;
+ zscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1);
+ }
+ } else {
+
+/* 2-by-2 pivot block D(k) */
+
+ if (k < *n - 1) {
+
+/* 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) )' */
+/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' */
+
+/* where L(k) and L(k+1) are the k-th and (k+1)-th */
+/* columns of L */
+
+ i__1 = k + 1 + k * a_dim1;
+ d21.r = a[i__1].r, d21.i = a[i__1].i;
+ z_div(&z__1, &a[k + 1 + (k + 1) * a_dim1], &d21);
+ d11.r = z__1.r, d11.i = z__1.i;
+ z_div(&z__1, &a[k + k * a_dim1], &d21);
+ d22.r = z__1.r, d22.i = z__1.i;
+ z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r *
+ d22.i + d11.i * d22.r;
+ z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.;
+ z_div(&z__1, &c_b1, &z__2);
+ t.r = z__1.r, t.i = z__1.i;
+ z_div(&z__1, &t, &d21);
+ d21.r = z__1.r, d21.i = z__1.i;
+
+ i__1 = *n;
+ for (j = k + 2; j <= i__1; ++j) {
+ i__2 = j + k * a_dim1;
+ z__3.r = d11.r * a[i__2].r - d11.i * a[i__2].i,
+ z__3.i = d11.r * a[i__2].i + d11.i * a[i__2]
+ .r;
+ i__3 = j + (k + 1) * a_dim1;
+ z__2.r = z__3.r - a[i__3].r, z__2.i = z__3.i - a[i__3]
+ .i;
+ z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i =
+ d21.r * z__2.i + d21.i * z__2.r;
+ wk.r = z__1.r, wk.i = z__1.i;
+ i__2 = j + (k + 1) * a_dim1;
+ z__3.r = d22.r * a[i__2].r - d22.i * a[i__2].i,
+ z__3.i = d22.r * a[i__2].i + d22.i * a[i__2]
+ .r;
+ i__3 = j + k * a_dim1;
+ z__2.r = z__3.r - a[i__3].r, z__2.i = z__3.i - a[i__3]
+ .i;
+ z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i =
+ d21.r * z__2.i + d21.i * z__2.r;
+ wkp1.r = z__1.r, wkp1.i = z__1.i;
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__ + k * a_dim1;
+ z__3.r = a[i__5].r * wk.r - a[i__5].i * wk.i,
+ z__3.i = a[i__5].r * wk.i + a[i__5].i *
+ wk.r;
+ z__2.r = a[i__4].r - z__3.r, z__2.i = a[i__4].i -
+ z__3.i;
+ i__6 = i__ + (k + 1) * a_dim1;
+ z__4.r = a[i__6].r * wkp1.r - a[i__6].i * wkp1.i,
+ z__4.i = a[i__6].r * wkp1.i + a[i__6].i *
+ wkp1.r;
+ z__1.r = z__2.r - z__4.r, z__1.i = z__2.i -
+ z__4.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L50: */
+ }
+ i__2 = j + k * a_dim1;
+ a[i__2].r = wk.r, a[i__2].i = wk.i;
+ i__2 = j + (k + 1) * a_dim1;
+ a[i__2].r = wkp1.r, a[i__2].i = wkp1.i;
+/* L60: */
+ }
+ }
+ }
+ }
+
+/* Store details of the interchanges in IPIV */
+
+ if (kstep == 1) {
+ ipiv[k] = kp;
+ } else {
+ ipiv[k] = -kp;
+ ipiv[k + 1] = -kp;
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kstep;
+ goto L40;
+
+ }
+
+L70:
+ return 0;
+
+/* End of ZSYTF2 */
+
+} /* zsytf2_ */
diff --git a/SRC/zsytrf.c b/SRC/zsytrf.c
new file mode 100644
index 0000000..43a5234
--- /dev/null
+++ b/SRC/zsytrf.c
@@ -0,0 +1,343 @@
+/* zsytrf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int zsytrf_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *ipiv, doublecomplex *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+
+ /* Local variables */
+ integer j, k, kb, nb, iws;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ logical upper;
+ extern /* Subroutine */ int zsytf2_(char *, integer *, doublecomplex *,
+ integer *, integer *, integer *), xerbla_(char *, integer
+ *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork;
+ extern /* Subroutine */ int zlasyf_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, integer *, doublecomplex *,
+ integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSYTRF computes the factorization of a complex symmetric matrix A */
+/* using the Bunch-Kaufman diagonal pivoting method. The form of the */
+/* factorization is */
+
+/* A = U*D*U**T or A = L*D*L**T */
+
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, and D is symmetric and block diagonal with */
+/* with 1-by-1 and 2-by-2 diagonal blocks. */
+
+/* This is the blocked version of the algorithm, calling Level 3 BLAS. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A is stored; */
+/* = 'L': Lower triangle of A is stored. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (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, the block diagonal matrix D and the multipliers used */
+/* to obtain the factor U or L (see below for further details). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (output) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D. */
+/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
+/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, D(i,i) is exactly zero. 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. */
+
+/* Further Details */
+/* =============== */
+
+/* If UPLO = 'U', then A = U*D*U', where */
+/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
+/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
+/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I v 0 ) k-s */
+/* U(k) = ( 0 I 0 ) s */
+/* ( 0 0 I ) n-k */
+/* k-s s n-k */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
+/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
+/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
+
+/* If UPLO = 'L', then A = L*D*L', where */
+/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
+/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
+/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
+/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
+/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+
+/* ( I 0 0 ) k-1 */
+/* L(k) = ( 0 I 0 ) s */
+/* ( 0 v I ) n-k-s+1 */
+/* k-1 s n-k-s+1 */
+
+/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
+/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
+/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1;
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else if (*lwork < 1 && ! lquery) {
+ *info = -7;
+ }
+
+ if (*info == 0) {
+
+/* Determine the block size */
+
+ nb = ilaenv_(&c__1, "ZSYTRF", uplo, n, &c_n1, &c_n1, &c_n1);
+ lwkopt = *n * nb;
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZSYTRF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = *n;
+ if (nb > 1 && nb < *n) {
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+/* Computing MAX */
+ i__1 = *lwork / ldwork;
+ nb = max(i__1,1);
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "ZSYTRF", uplo, n, &c_n1, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = 1;
+ }
+ if (nb < nbmin) {
+ nb = *n;
+ }
+
+ if (upper) {
+
+/* Factorize A as U*D*U' 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; */
+/* KB is either NB or NB-1, or K for the last block */
+
+ k = *n;
+L10:
+
+/* If K < 1, exit from loop */
+
+ if (k < 1) {
+ goto L40;
+ }
+
+ if (k > nb) {
+
+/* Factorize columns k-kb+1:k of A and use blocked code to */
+/* update columns 1:k-kb */
+
+ zlasyf_(uplo, &k, &nb, &kb, &a[a_offset], lda, &ipiv[1], &work[1],
+ n, &iinfo);
+ } else {
+
+/* Use unblocked code to factorize columns 1:k of A */
+
+ zsytf2_(uplo, &k, &a[a_offset], lda, &ipiv[1], &iinfo);
+ kb = k;
+ }
+
+/* Set INFO on the first occurrence of a zero pivot */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo;
+ }
+
+/* Decrease K and return to the start of the main loop */
+
+ k -= kb;
+ goto L10;
+
+ } else {
+
+/* Factorize A as L*D*L' 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; */
+/* KB is either NB or NB-1, or N-K+1 for the last block */
+
+ k = 1;
+L20:
+
+/* If K > N, exit from loop */
+
+ if (k > *n) {
+ goto L40;
+ }
+
+ if (k <= *n - nb) {
+
+/* Factorize columns k:k+kb-1 of A and use blocked code to */
+/* update columns k+kb:n */
+
+ i__1 = *n - k + 1;
+ zlasyf_(uplo, &i__1, &nb, &kb, &a[k + k * a_dim1], lda, &ipiv[k],
+ &work[1], n, &iinfo);
+ } else {
+
+/* Use unblocked code to factorize columns k:n of A */
+
+ i__1 = *n - k + 1;
+ zsytf2_(uplo, &i__1, &a[k + k * a_dim1], lda, &ipiv[k], &iinfo);
+ kb = *n - k + 1;
+ }
+
+/* Set INFO on the first occurrence of a zero pivot */
+
+ if (*info == 0 && iinfo > 0) {
+ *info = iinfo + k - 1;
+ }
+
+/* Adjust IPIV */
+
+ i__1 = k + kb - 1;
+ for (j = k; j <= i__1; ++j) {
+ if (ipiv[j] > 0) {
+ ipiv[j] = ipiv[j] + k - 1;
+ } else {
+ ipiv[j] = ipiv[j] - k + 1;
+ }
+/* L30: */
+ }
+
+/* Increase K and return to the start of the main loop */
+
+ k += kb;
+ goto L20;
+
+ }
+
+L40:
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ return 0;
+
+/* End of ZSYTRF */
+
+} /* zsytrf_ */
diff --git a/SRC/zsytri.c b/SRC/zsytri.c
new file mode 100644
index 0000000..020c699
--- /dev/null
+++ b/SRC/zsytri.c
@@ -0,0 +1,489 @@
+/* zsytri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static doublecomplex c_b2 = {0.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zsytri_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, integer *ipiv, doublecomplex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ doublecomplex d__;
+ integer k;
+ doublecomplex t, ak;
+ integer kp;
+ doublecomplex akp1, temp, akkp1;
+ extern logical lsame_(char *, char *);
+ integer kstep;
+ logical upper;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern /* Double Complex */ VOID zdotu_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zsymv_(char *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSYTRI computes the inverse of a complex symmetric indefinite matrix */
+/* A using the factorization A = U*D*U**T or A = L*D*L**T computed by */
+/* ZSYTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the block diagonal matrix D and the multipliers */
+/* used to obtain the factor U or L as computed by ZSYTRF. */
+
+/* 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. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by ZSYTRF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* INFO (output) 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. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZSYTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check that the diagonal matrix D is nonsingular. */
+
+ if (upper) {
+
+/* Upper triangular storage: examine D from bottom to top */
+
+ for (*info = *n; *info >= 1; --(*info)) {
+ i__1 = *info + *info * a_dim1;
+ if (ipiv[*info] > 0 && (a[i__1].r == 0. && a[i__1].i == 0.)) {
+ return 0;
+ }
+/* L10: */
+ }
+ } else {
+
+/* Lower triangular storage: examine D from top to bottom. */
+
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ i__2 = *info + *info * a_dim1;
+ if (ipiv[*info] > 0 && (a[i__2].r == 0. && a[i__2].i == 0.)) {
+ return 0;
+ }
+/* L20: */
+ }
+ }
+ *info = 0;
+
+ if (upper) {
+
+/* Compute inv(A) from the factorization A = U*D*U'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+L30:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L40;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = k + k * a_dim1;
+ z_div(&z__1, &c_b1, &a[k + k * a_dim1]);
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+
+/* Compute column K of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zsymv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1,
+ &c_b2, &a[k * a_dim1 + 1], &c__1);
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ i__3 = k - 1;
+ zdotu_(&z__2, &i__3, &work[1], &c__1, &a[k * a_dim1 + 1], &
+ c__1);
+ z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = k + (k + 1) * a_dim1;
+ t.r = a[i__1].r, t.i = a[i__1].i;
+ z_div(&z__1, &a[k + k * a_dim1], &t);
+ ak.r = z__1.r, ak.i = z__1.i;
+ z_div(&z__1, &a[k + 1 + (k + 1) * a_dim1], &t);
+ akp1.r = z__1.r, akp1.i = z__1.i;
+ z_div(&z__1, &a[k + (k + 1) * a_dim1], &t);
+ akkp1.r = z__1.r, akkp1.i = z__1.i;
+ z__3.r = ak.r * akp1.r - ak.i * akp1.i, z__3.i = ak.r * akp1.i +
+ ak.i * akp1.r;
+ z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.;
+ z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + t.i
+ * z__2.r;
+ d__.r = z__1.r, d__.i = z__1.i;
+ i__1 = k + k * a_dim1;
+ z_div(&z__1, &akp1, &d__);
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ z_div(&z__1, &ak, &d__);
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = k + (k + 1) * a_dim1;
+ z__2.r = -akkp1.r, z__2.i = -akkp1.i;
+ z_div(&z__1, &z__2, &d__);
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+
+/* Compute columns K and K+1 of the inverse. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zsymv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1,
+ &c_b2, &a[k * a_dim1 + 1], &c__1);
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ i__3 = k - 1;
+ zdotu_(&z__2, &i__3, &work[1], &c__1, &a[k * a_dim1 + 1], &
+ c__1);
+ z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = k + (k + 1) * a_dim1;
+ i__2 = k + (k + 1) * a_dim1;
+ i__3 = k - 1;
+ zdotu_(&z__2, &i__3, &a[k * a_dim1 + 1], &c__1, &a[(k + 1) *
+ a_dim1 + 1], &c__1);
+ z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = k - 1;
+ zcopy_(&i__1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], &
+ c__1);
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zsymv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1,
+ &c_b2, &a[(k + 1) * a_dim1 + 1], &c__1);
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ i__2 = k + 1 + (k + 1) * a_dim1;
+ i__3 = k - 1;
+ zdotu_(&z__2, &i__3, &work[1], &c__1, &a[(k + 1) * a_dim1 + 1]
+, &c__1);
+ z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ }
+ kstep = 2;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the leading */
+/* submatrix A(1:k+1,1:k+1) */
+
+ i__1 = kp - 1;
+ zswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &
+ c__1);
+ i__1 = k - kp - 1;
+ zswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1) *
+ a_dim1], lda);
+ i__1 = k + k * a_dim1;
+ temp.r = a[i__1].r, temp.i = a[i__1].i;
+ i__1 = k + k * a_dim1;
+ i__2 = kp + kp * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + kp * a_dim1;
+ a[i__1].r = temp.r, a[i__1].i = temp.i;
+ if (kstep == 2) {
+ i__1 = k + (k + 1) * a_dim1;
+ temp.r = a[i__1].r, temp.i = a[i__1].i;
+ i__1 = k + (k + 1) * a_dim1;
+ i__2 = kp + (k + 1) * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + (k + 1) * a_dim1;
+ a[i__1].r = temp.r, a[i__1].i = temp.i;
+ }
+ }
+
+ k += kstep;
+ goto L30;
+L40:
+
+ ;
+ } else {
+
+/* Compute inv(A) from the factorization A = L*D*L'. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+L50:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L60;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = k + k * a_dim1;
+ z_div(&z__1, &c_b1, &a[k + k * a_dim1]);
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+
+/* Compute column K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ zcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zsymv_(uplo, &i__1, &z__1, &a[k + 1 + (k + 1) * a_dim1], lda,
+ &work[1], &c__1, &c_b2, &a[k + 1 + k * a_dim1], &c__1);
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ i__3 = *n - k;
+ zdotu_(&z__2, &i__3, &work[1], &c__1, &a[k + 1 + k * a_dim1],
+ &c__1);
+ z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ }
+ kstep = 1;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Invert the diagonal block. */
+
+ i__1 = k + (k - 1) * a_dim1;
+ t.r = a[i__1].r, t.i = a[i__1].i;
+ z_div(&z__1, &a[k - 1 + (k - 1) * a_dim1], &t);
+ ak.r = z__1.r, ak.i = z__1.i;
+ z_div(&z__1, &a[k + k * a_dim1], &t);
+ akp1.r = z__1.r, akp1.i = z__1.i;
+ z_div(&z__1, &a[k + (k - 1) * a_dim1], &t);
+ akkp1.r = z__1.r, akkp1.i = z__1.i;
+ z__3.r = ak.r * akp1.r - ak.i * akp1.i, z__3.i = ak.r * akp1.i +
+ ak.i * akp1.r;
+ z__2.r = z__3.r - 1., z__2.i = z__3.i - 0.;
+ z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + t.i
+ * z__2.r;
+ d__.r = z__1.r, d__.i = z__1.i;
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ z_div(&z__1, &akp1, &d__);
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = k + k * a_dim1;
+ z_div(&z__1, &ak, &d__);
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = k + (k - 1) * a_dim1;
+ z__2.r = -akkp1.r, z__2.i = -akkp1.i;
+ z_div(&z__1, &z__2, &d__);
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+
+/* Compute columns K-1 and K of the inverse. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ zcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zsymv_(uplo, &i__1, &z__1, &a[k + 1 + (k + 1) * a_dim1], lda,
+ &work[1], &c__1, &c_b2, &a[k + 1 + k * a_dim1], &c__1);
+ i__1 = k + k * a_dim1;
+ i__2 = k + k * a_dim1;
+ i__3 = *n - k;
+ zdotu_(&z__2, &i__3, &work[1], &c__1, &a[k + 1 + k * a_dim1],
+ &c__1);
+ z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = k + (k - 1) * a_dim1;
+ i__2 = k + (k - 1) * a_dim1;
+ i__3 = *n - k;
+ zdotu_(&z__2, &i__3, &a[k + 1 + k * a_dim1], &c__1, &a[k + 1
+ + (k - 1) * a_dim1], &c__1);
+ z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = *n - k;
+ zcopy_(&i__1, &a[k + 1 + (k - 1) * a_dim1], &c__1, &work[1], &
+ c__1);
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zsymv_(uplo, &i__1, &z__1, &a[k + 1 + (k + 1) * a_dim1], lda,
+ &work[1], &c__1, &c_b2, &a[k + 1 + (k - 1) * a_dim1],
+ &c__1);
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ i__2 = k - 1 + (k - 1) * a_dim1;
+ i__3 = *n - k;
+ zdotu_(&z__2, &i__3, &work[1], &c__1, &a[k + 1 + (k - 1) *
+ a_dim1], &c__1);
+ z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ }
+ kstep = 2;
+ }
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+
+/* Interchange rows and columns K and KP in the trailing */
+/* submatrix A(k-1:n,k-1:n) */
+
+ if (kp < *n) {
+ i__1 = *n - kp;
+ zswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + kp *
+ a_dim1], &c__1);
+ }
+ i__1 = kp - k - 1;
+ zswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) *
+ a_dim1], lda);
+ i__1 = k + k * a_dim1;
+ temp.r = a[i__1].r, temp.i = a[i__1].i;
+ i__1 = k + k * a_dim1;
+ i__2 = kp + kp * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + kp * a_dim1;
+ a[i__1].r = temp.r, a[i__1].i = temp.i;
+ if (kstep == 2) {
+ i__1 = k + (k - 1) * a_dim1;
+ temp.r = a[i__1].r, temp.i = a[i__1].i;
+ i__1 = k + (k - 1) * a_dim1;
+ i__2 = kp + (k - 1) * a_dim1;
+ a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
+ i__1 = kp + (k - 1) * a_dim1;
+ a[i__1].r = temp.r, a[i__1].i = temp.i;
+ }
+ }
+
+ k -= kstep;
+ goto L50;
+L60:
+ ;
+ }
+
+ return 0;
+
+/* End of ZSYTRI */
+
+} /* zsytri_ */
diff --git a/SRC/zsytrs.c b/SRC/zsytrs.c
new file mode 100644
index 0000000..5971cff
--- /dev/null
+++ b/SRC/zsytrs.c
@@ -0,0 +1,502 @@
+/* zsytrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zsytrs_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b,
+ integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer j, k;
+ doublecomplex ak, bk;
+ integer kp;
+ doublecomplex akm1, bkm1, akm1k;
+ extern logical lsame_(char *, char *);
+ doublecomplex denom;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int zgeru_(integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSYTRS solves a system of linear equations A*X = B with a complex */
+/* symmetric matrix A using the factorization A = U*D*U**T or */
+/* A = L*D*L**T computed by ZSYTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) 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*D*U**T; */
+/* = 'L': Lower triangular, form is A = L*D*L**T. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by ZSYTRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* Details of the interchanges and the block structure of D */
+/* as determined by ZSYTRF. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZSYTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Solve A*X = B, where A = U*D*U'. */
+
+/* First solve U*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+L10:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L30;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &a[k * a_dim1 + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ z_div(&z__1, &c_b1, &a[k + k * a_dim1]);
+ zscal_(nrhs, &z__1, &b[k + b_dim1], ldb);
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K-1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k - 1) {
+ zswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(U(K)), where U(K) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ i__1 = k - 2;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &a[k * a_dim1 + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+ i__1 = k - 2;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &a[(k - 1) * a_dim1 + 1], &c__1, &b[k
+ - 1 + b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = k - 1 + k * a_dim1;
+ akm1k.r = a[i__1].r, akm1k.i = a[i__1].i;
+ z_div(&z__1, &a[k - 1 + (k - 1) * a_dim1], &akm1k);
+ akm1.r = z__1.r, akm1.i = z__1.i;
+ z_div(&z__1, &a[k + k * a_dim1], &akm1k);
+ ak.r = z__1.r, ak.i = z__1.i;
+ z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i +
+ akm1.i * ak.r;
+ z__1.r = z__2.r - 1., z__1.i = z__2.i - 0.;
+ denom.r = z__1.r, denom.i = z__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ z_div(&z__1, &b[k - 1 + j * b_dim1], &akm1k);
+ bkm1.r = z__1.r, bkm1.i = z__1.i;
+ z_div(&z__1, &b[k + j * b_dim1], &akm1k);
+ bk.r = z__1.r, bk.i = z__1.i;
+ i__2 = k - 1 + j * b_dim1;
+ z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r *
+ bkm1.i + ak.i * bkm1.r;
+ z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i;
+ z_div(&z__1, &z__2, &denom);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + j * b_dim1;
+ z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r *
+ bk.i + akm1.i * bk.r;
+ z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i;
+ z_div(&z__1, &z__2, &denom);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L20: */
+ }
+ k += -2;
+ }
+
+ goto L10;
+L30:
+
+/* Next solve U'*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+L40:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L50;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(U'(K)), where U(K) is the transformation */
+/* stored in column K of A. */
+
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Transpose", &i__1, nrhs, &z__1, &b[b_offset], ldb, &a[k *
+ a_dim1 + 1], &c__1, &c_b1, &b[k + b_dim1], ldb)
+ ;
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Transpose", &i__1, nrhs, &z__1, &b[b_offset], ldb, &a[k *
+ a_dim1 + 1], &c__1, &c_b1, &b[k + b_dim1], ldb)
+ ;
+ i__1 = k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Transpose", &i__1, nrhs, &z__1, &b[b_offset], ldb, &a[(k
+ + 1) * a_dim1 + 1], &c__1, &c_b1, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ k += 2;
+ }
+
+ goto L40;
+L50:
+
+ ;
+ } else {
+
+/* Solve A*X = B, where A = L*D*L'. */
+
+/* First solve L*D*X = B, overwriting B with X. */
+
+/* K is the main loop index, increasing from 1 to N in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = 1;
+L60:
+
+/* If K > N, exit from loop. */
+
+ if (k > *n) {
+ goto L80;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &a[k + 1 + k * a_dim1], &c__1, &b[
+ k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ z_div(&z__1, &c_b1, &a[k + k * a_dim1]);
+ zscal_(nrhs, &z__1, &b[k + b_dim1], ldb);
+ ++k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Interchange rows K+1 and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k + 1) {
+ zswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+
+/* Multiply by inv(L(K)), where L(K) is the transformation */
+/* stored in columns K and K+1 of A. */
+
+ if (k < *n - 1) {
+ i__1 = *n - k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &a[k + 2 + k * a_dim1], &c__1, &b[
+ k + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ z__1.r = -1., z__1.i = -0.;
+ zgeru_(&i__1, nrhs, &z__1, &a[k + 2 + (k + 1) * a_dim1], &
+ c__1, &b[k + 1 + b_dim1], ldb, &b[k + 2 + b_dim1],
+ ldb);
+ }
+
+/* Multiply by the inverse of the diagonal block. */
+
+ i__1 = k + 1 + k * a_dim1;
+ akm1k.r = a[i__1].r, akm1k.i = a[i__1].i;
+ z_div(&z__1, &a[k + k * a_dim1], &akm1k);
+ akm1.r = z__1.r, akm1.i = z__1.i;
+ z_div(&z__1, &a[k + 1 + (k + 1) * a_dim1], &akm1k);
+ ak.r = z__1.r, ak.i = z__1.i;
+ z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i +
+ akm1.i * ak.r;
+ z__1.r = z__2.r - 1., z__1.i = z__2.i - 0.;
+ denom.r = z__1.r, denom.i = z__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ z_div(&z__1, &b[k + j * b_dim1], &akm1k);
+ bkm1.r = z__1.r, bkm1.i = z__1.i;
+ z_div(&z__1, &b[k + 1 + j * b_dim1], &akm1k);
+ bk.r = z__1.r, bk.i = z__1.i;
+ i__2 = k + j * b_dim1;
+ z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r *
+ bkm1.i + ak.i * bkm1.r;
+ z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i;
+ z_div(&z__1, &z__2, &denom);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r *
+ bk.i + akm1.i * bk.r;
+ z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i;
+ z_div(&z__1, &z__2, &denom);
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L70: */
+ }
+ k += 2;
+ }
+
+ goto L60;
+L80:
+
+/* Next solve L'*X = B, overwriting B with X. */
+
+/* K is the main loop index, decreasing from N to 1 in steps of */
+/* 1 or 2, depending on the size of the diagonal blocks. */
+
+ k = *n;
+L90:
+
+/* If K < 1, exit from loop. */
+
+ if (k < 1) {
+ goto L100;
+ }
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 diagonal block */
+
+/* Multiply by inv(L'(K)), where L(K) is the transformation */
+/* stored in column K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Transpose", &i__1, nrhs, &z__1, &b[k + 1 + b_dim1],
+ ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, &b[k +
+ b_dim1], ldb);
+ }
+
+/* Interchange rows K and IPIV(K). */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ --k;
+ } else {
+
+/* 2 x 2 diagonal block */
+
+/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */
+/* stored in columns K-1 and K of A. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Transpose", &i__1, nrhs, &z__1, &b[k + 1 + b_dim1],
+ ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, &b[k +
+ b_dim1], ldb);
+ i__1 = *n - k;
+ z__1.r = -1., z__1.i = -0.;
+ zgemv_("Transpose", &i__1, nrhs, &z__1, &b[k + 1 + b_dim1],
+ ldb, &a[k + 1 + (k - 1) * a_dim1], &c__1, &c_b1, &b[k
+ - 1 + b_dim1], ldb);
+ }
+
+/* Interchange rows K and -IPIV(K). */
+
+ kp = -ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+ }
+ k += -2;
+ }
+
+ goto L90;
+L100:
+ ;
+ }
+
+ return 0;
+
+/* End of ZSYTRS */
+
+} /* zsytrs_ */
diff --git a/SRC/ztbcon.c b/SRC/ztbcon.c
new file mode 100644
index 0000000..186f3d5
--- /dev/null
+++ b/SRC/ztbcon.c
@@ -0,0 +1,254 @@
+/* ztbcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ztbcon_(char *norm, char *uplo, char *diag, integer *n,
+ integer *kd, doublecomplex *ab, integer *ldab, doublereal *rcond,
+ doublecomplex *work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer ix, kase, kase1;
+ doublereal scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ doublereal anorm;
+ logical upper;
+ doublereal xnorm;
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal ainvnm;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ extern doublereal zlantb_(char *, char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+ logical onenrm;
+ extern /* Subroutine */ int zlatbs_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *, doublereal *, integer *), zdrscl_(integer *, doublereal *, doublecomplex *,
+ integer *);
+ char normin[1];
+ doublereal smlnum;
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTBCON estimates the reciprocal of the condition number of a */
+/* triangular band matrix A, in either the 1-norm or the infinity-norm. */
+
+/* The norm of A is computed and an estimate is obtained for */
+/* norm(inv(A)), then the reciprocal of the condition number is */
+/* computed as */
+/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ nounit = lsame_(diag, "N");
+
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*kd < 0) {
+ *info = -5;
+ } else if (*ldab < *kd + 1) {
+ *info = -7;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTBCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ }
+
+ *rcond = 0.;
+ smlnum = dlamch_("Safe minimum") * (doublereal) max(*n,1);
+
+/* Compute the 1-norm of the triangular matrix A or A'. */
+
+ anorm = zlantb_(norm, uplo, diag, n, kd, &ab[ab_offset], ldab, &rwork[1]);
+
+/* Continue only if ANORM > 0. */
+
+ if (anorm > 0.) {
+
+/* Estimate the 1-norm of the inverse of A. */
+
+ ainvnm = 0.;
+ *(unsigned char *)normin = 'N';
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kase = 0;
+L10:
+ zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(A). */
+
+ zlatbs_(uplo, "No transpose", diag, normin, n, kd, &ab[
+ ab_offset], ldab, &work[1], &scale, &rwork[1], info);
+ } else {
+
+/* Multiply by inv(A'). */
+
+ zlatbs_(uplo, "Conjugate transpose", diag, normin, n, kd, &ab[
+ ab_offset], ldab, &work[1], &scale, &rwork[1], info);
+ }
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ if (scale != 1.) {
+ ix = izamax_(n, &work[1], &c__1);
+ i__1 = ix;
+ xnorm = (d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(&
+ work[ix]), abs(d__2));
+ if (scale < xnorm * smlnum || scale == 0.) {
+ goto L20;
+ }
+ zdrscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / anorm / ainvnm;
+ }
+ }
+
+L20:
+ return 0;
+
+/* End of ZTBCON */
+
+} /* ztbcon_ */
diff --git a/SRC/ztbrfs.c b/SRC/ztbrfs.c
new file mode 100644
index 0000000..b96354d
--- /dev/null
+++ b/SRC/ztbrfs.c
@@ -0,0 +1,586 @@
+/* ztbrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ztbrfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, doublecomplex *ab, integer *ldab,
+ doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
+ doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *
+ rwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1,
+ i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal s, xk;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int ztbmv_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *), zcopy_(integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), ztbsv_(char *, char *,
+ char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+ char transn[1], transt[1];
+ logical nounit;
+ doublereal lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTBRFS provides error bounds and backward error estimates for the */
+/* solution to a system of linear equations with a triangular band */
+/* coefficient matrix. */
+
+/* The solution matrix X must be computed by ZTBTRS or some other */
+/* means before entering this routine. ZTBRFS does not do iterative */
+/* refinement because doing so cannot improve the backward error. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*kd < 0) {
+ *info = -5;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*ldab < *kd + 1) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ } else if (*ldx < max(1,*n)) {
+ *info = -12;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTBRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transn = 'N';
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transn = 'C';
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *kd + 2;
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A, A**T, or A**H, depending on TRANS. */
+
+ zcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ztbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[1], &
+ c__1);
+ z__1.r = -1., z__1.i = -0.;
+ zaxpy_(n, &z__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
+ i__ + j * b_dim1]), abs(d__2));
+/* L20: */
+ }
+
+ if (notran) {
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&
+ x[k + j * x_dim1]), abs(d__2));
+/* Computing MAX */
+ i__3 = 1, i__4 = k - *kd;
+ i__5 = k;
+ for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
+ i__3 = *kd + 1 + i__ - k + k * ab_dim1;
+ rwork[i__] += ((d__1 = ab[i__3].r, abs(d__1)) + (
+ d__2 = d_imag(&ab[*kd + 1 + i__ - k + k *
+ ab_dim1]), abs(d__2))) * xk;
+/* L30: */
+ }
+/* L40: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__5 = k + j * x_dim1;
+ xk = (d__1 = x[i__5].r, abs(d__1)) + (d__2 = d_imag(&
+ x[k + j * x_dim1]), abs(d__2));
+/* Computing MAX */
+ i__5 = 1, i__3 = k - *kd;
+ i__4 = k - 1;
+ for (i__ = max(i__5,i__3); i__ <= i__4; ++i__) {
+ i__5 = *kd + 1 + i__ - k + k * ab_dim1;
+ rwork[i__] += ((d__1 = ab[i__5].r, abs(d__1)) + (
+ d__2 = d_imag(&ab[*kd + 1 + i__ - k + k *
+ ab_dim1]), abs(d__2))) * xk;
+/* L50: */
+ }
+ rwork[k] += xk;
+/* L60: */
+ }
+ }
+ } else {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__4 = k + j * x_dim1;
+ xk = (d__1 = x[i__4].r, abs(d__1)) + (d__2 = d_imag(&
+ x[k + j * x_dim1]), abs(d__2));
+/* Computing MIN */
+ i__5 = *n, i__3 = k + *kd;
+ i__4 = min(i__5,i__3);
+ for (i__ = k; i__ <= i__4; ++i__) {
+ i__5 = i__ + 1 - k + k * ab_dim1;
+ rwork[i__] += ((d__1 = ab[i__5].r, abs(d__1)) + (
+ d__2 = d_imag(&ab[i__ + 1 - k + k *
+ ab_dim1]), abs(d__2))) * xk;
+/* L70: */
+ }
+/* L80: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__4 = k + j * x_dim1;
+ xk = (d__1 = x[i__4].r, abs(d__1)) + (d__2 = d_imag(&
+ x[k + j * x_dim1]), abs(d__2));
+/* Computing MIN */
+ i__5 = *n, i__3 = k + *kd;
+ i__4 = min(i__5,i__3);
+ for (i__ = k + 1; i__ <= i__4; ++i__) {
+ i__5 = i__ + 1 - k + k * ab_dim1;
+ rwork[i__] += ((d__1 = ab[i__5].r, abs(d__1)) + (
+ d__2 = d_imag(&ab[i__ + 1 - k + k *
+ ab_dim1]), abs(d__2))) * xk;
+/* L90: */
+ }
+ rwork[k] += xk;
+/* L100: */
+ }
+ }
+ }
+ } else {
+
+/* Compute abs(A**H)*abs(X) + abs(B). */
+
+ if (upper) {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+/* Computing MAX */
+ i__4 = 1, i__5 = k - *kd;
+ i__3 = k;
+ for (i__ = max(i__4,i__5); i__ <= i__3; ++i__) {
+ i__4 = *kd + 1 + i__ - k + k * ab_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((d__1 = ab[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&ab[*kd + 1 + i__ - k + k *
+ ab_dim1]), abs(d__2))) * ((d__3 = x[i__5]
+ .r, abs(d__3)) + (d__4 = d_imag(&x[i__ +
+ j * x_dim1]), abs(d__4)));
+/* L110: */
+ }
+ rwork[k] += s;
+/* L120: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ s = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[
+ k + j * x_dim1]), abs(d__2));
+/* Computing MAX */
+ i__3 = 1, i__4 = k - *kd;
+ i__5 = k - 1;
+ for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) {
+ i__3 = *kd + 1 + i__ - k + k * ab_dim1;
+ i__4 = i__ + j * x_dim1;
+ s += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&ab[*kd + 1 + i__ - k + k *
+ ab_dim1]), abs(d__2))) * ((d__3 = x[i__4]
+ .r, abs(d__3)) + (d__4 = d_imag(&x[i__ +
+ j * x_dim1]), abs(d__4)));
+/* L130: */
+ }
+ rwork[k] += s;
+/* L140: */
+ }
+ }
+ } else {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+/* Computing MIN */
+ i__3 = *n, i__4 = k + *kd;
+ i__5 = min(i__3,i__4);
+ for (i__ = k; i__ <= i__5; ++i__) {
+ i__3 = i__ + 1 - k + k * ab_dim1;
+ i__4 = i__ + j * x_dim1;
+ s += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&ab[i__ + 1 - k + k * ab_dim1]),
+ abs(d__2))) * ((d__3 = x[i__4].r, abs(
+ d__3)) + (d__4 = d_imag(&x[i__ + j *
+ x_dim1]), abs(d__4)));
+/* L150: */
+ }
+ rwork[k] += s;
+/* L160: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__5 = k + j * x_dim1;
+ s = (d__1 = x[i__5].r, abs(d__1)) + (d__2 = d_imag(&x[
+ k + j * x_dim1]), abs(d__2));
+/* Computing MIN */
+ i__3 = *n, i__4 = k + *kd;
+ i__5 = min(i__3,i__4);
+ for (i__ = k + 1; i__ <= i__5; ++i__) {
+ i__3 = i__ + 1 - k + k * ab_dim1;
+ i__4 = i__ + j * x_dim1;
+ s += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&ab[i__ + 1 - k + k * ab_dim1]),
+ abs(d__2))) * ((d__3 = x[i__4].r, abs(
+ d__3)) + (d__4 = d_imag(&x[i__ + j *
+ x_dim1]), abs(d__4)));
+/* L170: */
+ }
+ rwork[k] += s;
+/* L180: */
+ }
+ }
+ }
+ }
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__5 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__5].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2))) / rwork[i__];
+ s = max(d__3,d__4);
+ } else {
+/* Computing MAX */
+ i__5 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__5].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = max(d__3,d__4);
+ }
+/* L190: */
+ }
+ berr[j] = s;
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use ZLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__5 = i__;
+ rwork[i__] = (d__1 = work[i__5].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ ;
+ } else {
+ i__5 = i__;
+ rwork[i__] = (d__1 = work[i__5].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ + safe1;
+ }
+/* L200: */
+ }
+
+ kase = 0;
+L210:
+ zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)**H). */
+
+ ztbsv_(uplo, transt, diag, n, kd, &ab[ab_offset], ldab, &work[
+ 1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__5 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__3] * work[i__4].r, z__1.i = rwork[i__3]
+ * work[i__4].i;
+ work[i__5].r = z__1.r, work[i__5].i = z__1.i;
+/* L220: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__5 = i__;
+ i__3 = i__;
+ i__4 = i__;
+ z__1.r = rwork[i__3] * work[i__4].r, z__1.i = rwork[i__3]
+ * work[i__4].i;
+ work[i__5].r = z__1.r, work[i__5].i = z__1.i;
+/* L230: */
+ }
+ ztbsv_(uplo, transn, diag, n, kd, &ab[ab_offset], ldab, &work[
+ 1], &c__1);
+ }
+ goto L210;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__5 = i__ + j * x_dim1;
+ d__3 = lstres, d__4 = (d__1 = x[i__5].r, abs(d__1)) + (d__2 =
+ d_imag(&x[i__ + j * x_dim1]), abs(d__2));
+ lstres = max(d__3,d__4);
+/* L240: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L250: */
+ }
+
+ return 0;
+
+/* End of ZTBRFS */
+
+} /* ztbrfs_ */
diff --git a/SRC/ztbtrs.c b/SRC/ztbtrs.c
new file mode 100644
index 0000000..b9ff7a7
--- /dev/null
+++ b/SRC/ztbtrs.c
@@ -0,0 +1,205 @@
+/* ztbtrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ztbtrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, doublecomplex *ab, integer *ldab,
+ doublecomplex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, i__1, i__2;
+
+ /* Local variables */
+ integer j;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int ztbsv_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *);
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTBTRS solves a triangular system of the form */
+
+/* A * X = B, A**T * X = B, or A**H * X = B, */
+
+/* where A is a triangular band matrix of order N, and B is an */
+/* N-by-NRHS matrix. A check is made to verify that A is nonsingular. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of AB. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, if INFO = 0, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element of A is zero, */
+/* indicating that the matrix is singular and the */
+/* solutions X have not been computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ nounit = lsame_(diag, "N");
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*kd < 0) {
+ *info = -5;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*ldab < *kd + 1) {
+ *info = -8;
+ } else if (*ldb < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTBTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check for singularity. */
+
+ if (nounit) {
+ if (upper) {
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ i__2 = *kd + 1 + *info * ab_dim1;
+ if (ab[i__2].r == 0. && ab[i__2].i == 0.) {
+ return 0;
+ }
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ i__2 = *info * ab_dim1 + 1;
+ if (ab[i__2].r == 0. && ab[i__2].i == 0.) {
+ return 0;
+ }
+/* L20: */
+ }
+ }
+ }
+ *info = 0;
+
+/* Solve A * X = B, A**T * X = B, or A**H * X = B. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ztbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &b[j * b_dim1
+ + 1], &c__1);
+/* L30: */
+ }
+
+ return 0;
+
+/* End of ZTBTRS */
+
+} /* ztbtrs_ */
diff --git a/SRC/ztfsm.c b/SRC/ztfsm.c
new file mode 100644
index 0000000..37d4bf9
--- /dev/null
+++ b/SRC/ztfsm.c
@@ -0,0 +1,1024 @@
+/* ztfsm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+
+/* Subroutine */ int ztfsm_(char *transr, char *side, char *uplo, char *trans,
+ char *diag, integer *m, integer *n, doublecomplex *alpha,
+ doublecomplex *a, doublecomplex *b, integer *ldb)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j, k, m1, m2, n1, n2, info;
+ logical normaltransr, lside;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ logical lower;
+ extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ xerbla_(char *, integer *);
+ logical misodd, nisodd, notrans;
+
+
+/* -- LAPACK routine (version 3.2.1) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- April 2009 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Level 3 BLAS like routine for A in RFP Format. */
+
+/* ZTFSM solves the matrix equation */
+
+/* op( A )*X = alpha*B or X*op( A ) = alpha*B */
+
+/* where alpha is a scalar, X and B are m by n matrices, A is a unit, or */
+/* non-unit, upper or lower triangular matrix and op( A ) is one of */
+
+/* op( A ) = A or op( A ) = conjg( A' ). */
+
+/* A is in Rectangular Full Packed (RFP) Format. */
+
+/* The matrix X is overwritten on B. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANSR - (input) CHARACTER */
+/* = 'N': The Normal Form of RFP A is stored; */
+/* = 'C': The Conjugate-transpose Form of RFP A is stored. */
+
+/* SIDE - (input) CHARACTER */
+/* On entry, SIDE specifies whether op( A ) appears on the left */
+/* or right of X as follows: */
+
+/* SIDE = 'L' or 'l' op( A )*X = alpha*B. */
+
+/* SIDE = 'R' or 'r' X*op( A ) = alpha*B. */
+
+/* Unchanged on exit. */
+
+/* UPLO - (input) CHARACTER */
+/* On entry, UPLO specifies whether the RFP matrix A came from */
+/* an upper or lower triangular matrix as follows: */
+/* UPLO = 'U' or 'u' RFP A came from an upper triangular matrix */
+/* UPLO = 'L' or 'l' RFP A came from a lower triangular matrix */
+
+/* Unchanged on exit. */
+
+/* TRANS - (input) CHARACTER */
+/* On entry, TRANS specifies the form of op( A ) to be used */
+/* in the matrix multiplication as follows: */
+
+/* TRANS = 'N' or 'n' op( A ) = A. */
+
+/* TRANS = 'C' or 'c' op( A ) = conjg( A' ). */
+
+/* Unchanged on exit. */
+
+/* DIAG - (input) CHARACTER */
+/* On entry, DIAG specifies whether or not RFP A is unit */
+/* triangular as follows: */
+
+/* DIAG = 'U' or 'u' A is assumed to be unit triangular. */
+
+/* DIAG = 'N' or 'n' A is not assumed to be unit */
+/* triangular. */
+
+/* Unchanged on exit. */
+
+/* M - (input) INTEGER. */
+/* On entry, M specifies the number of rows of B. M must be at */
+/* least zero. */
+/* Unchanged on exit. */
+
+/* N - (input) INTEGER. */
+/* On entry, N specifies the number of columns of B. N must be */
+/* at least zero. */
+/* Unchanged on exit. */
+
+/* ALPHA - (input) COMPLEX*16. */
+/* On entry, ALPHA specifies the scalar alpha. When alpha is */
+/* zero then A is not referenced and B need not be set before */
+/* entry. */
+/* Unchanged on exit. */
+
+/* A - (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ); */
+/* NT = N*(N+1)/2. On entry, the matrix A in RFP Format. */
+/* RFP Format is described by TRANSR, UPLO and N as follows: */
+/* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even; */
+/* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If */
+/* TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A as */
+/* defined when TRANSR = 'N'. The contents of RFP A are defined */
+/* by UPLO as follows: If UPLO = 'U' the RFP A contains the NT */
+/* elements of upper packed A either in normal or */
+/* conjugate-transpose Format. If UPLO = 'L' the RFP A contains */
+/* the NT elements of lower packed A either in normal or */
+/* conjugate-transpose Format. The LDA of RFP A is (N+1)/2 when */
+/* TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is */
+/* even and is N when is odd. */
+/* See the Note below for more details. Unchanged on exit. */
+
+/* B - (input/ouptut) COMPLEX*16 array, DIMENSION ( LDB, N) */
+/* Before entry, the leading m by n part of the array B must */
+/* contain the right-hand side matrix B, and on exit is */
+/* overwritten by the solution matrix X. */
+
+/* LDB - (input) INTEGER. */
+/* On entry, LDB specifies the first dimension of B as declared */
+/* in the calling (sub) program. LDB must be at least */
+/* max( 1, m ). */
+/* Unchanged on exit. */
+
+/* Further Details */
+/* =============== */
+
+/* We first consider Standard Packed Format when N is even. */
+/* We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* conjugate-transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* conjugate-transpose of the last three columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- -- */
+/* 03 04 05 33 43 53 */
+/* -- -- */
+/* 13 14 15 00 44 54 */
+/* -- */
+/* 23 24 25 10 11 55 */
+
+/* 33 34 35 20 21 22 */
+/* -- */
+/* 00 44 45 30 31 32 */
+/* -- -- */
+/* 01 11 55 40 41 42 */
+/* -- -- -- */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We next consider Standard Packed Format when N is odd. */
+/* We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* conjugate-transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* conjugate-transpose of the last two columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- */
+/* 02 03 04 00 33 43 */
+/* -- */
+/* 12 13 14 10 11 44 */
+
+/* 22 23 24 20 21 22 */
+/* -- */
+/* 00 33 34 30 31 32 */
+/* -- -- */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- */
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ b_dim1 = *ldb - 1 - 0 + 1;
+ b_offset = 0 + b_dim1 * 0;
+ b -= b_offset;
+
+ /* Function Body */
+ info = 0;
+ normaltransr = lsame_(transr, "N");
+ lside = lsame_(side, "L");
+ lower = lsame_(uplo, "L");
+ notrans = lsame_(trans, "N");
+ if (! normaltransr && ! lsame_(transr, "C")) {
+ info = -1;
+ } else if (! lside && ! lsame_(side, "R")) {
+ info = -2;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ info = -3;
+ } else if (! notrans && ! lsame_(trans, "C")) {
+ info = -4;
+ } else if (! lsame_(diag, "N") && ! lsame_(diag,
+ "U")) {
+ info = -5;
+ } else if (*m < 0) {
+ info = -6;
+ } else if (*n < 0) {
+ info = -7;
+ } else if (*ldb < max(1,*m)) {
+ info = -11;
+ }
+ if (info != 0) {
+ i__1 = -info;
+ xerbla_("ZTFSM ", &i__1);
+ return 0;
+ }
+
+/* Quick return when ( (N.EQ.0).OR.(M.EQ.0) ) */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Quick return when ALPHA.EQ.(0D+0,0D+0) */
+
+ if (alpha->r == 0. && alpha->i == 0.) {
+ i__1 = *n - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *m - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0., b[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ return 0;
+ }
+
+ if (lside) {
+
+/* SIDE = 'L' */
+
+/* A is M-by-M. */
+/* If M is odd, set NISODD = .TRUE., and M1 and M2. */
+/* If M is even, NISODD = .FALSE., and M. */
+
+ if (*m % 2 == 0) {
+ misodd = FALSE_;
+ k = *m / 2;
+ } else {
+ misodd = TRUE_;
+ if (lower) {
+ m2 = *m / 2;
+ m1 = *m - m2;
+ } else {
+ m1 = *m / 2;
+ m2 = *m - m1;
+ }
+ }
+
+ if (misodd) {
+
+/* SIDE = 'L' and N is odd */
+
+ if (normaltransr) {
+
+/* SIDE = 'L', N is odd, and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and */
+/* TRANS = 'N' */
+
+ if (*m == 1) {
+ ztrsm_("L", "L", "N", diag, &m1, n, alpha, a, m, &
+ b[b_offset], ldb);
+ } else {
+ ztrsm_("L", "L", "N", diag, &m1, n, alpha, a, m, &
+ b[b_offset], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("N", "N", &m2, n, &m1, &z__1, &a[m1], m, &
+ b[b_offset], ldb, alpha, &b[m1], ldb);
+ ztrsm_("L", "U", "C", diag, &m2, n, &c_b1, &a[*m],
+ m, &b[m1], ldb);
+ }
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and */
+/* TRANS = 'C' */
+
+ if (*m == 1) {
+ ztrsm_("L", "L", "C", diag, &m1, n, alpha, a, m, &
+ b[b_offset], ldb);
+ } else {
+ ztrsm_("L", "U", "N", diag, &m2, n, alpha, &a[*m],
+ m, &b[m1], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("C", "N", &m1, n, &m2, &z__1, &a[m1], m, &
+ b[m1], ldb, alpha, &b[b_offset], ldb);
+ ztrsm_("L", "L", "C", diag, &m1, n, &c_b1, a, m, &
+ b[b_offset], ldb);
+ }
+
+ }
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'U' */
+
+ if (! notrans) {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and */
+/* TRANS = 'N' */
+
+ ztrsm_("L", "L", "N", diag, &m1, n, alpha, &a[m2], m,
+ &b[b_offset], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("C", "N", &m2, n, &m1, &z__1, a, m, &b[
+ b_offset], ldb, alpha, &b[m1], ldb);
+ ztrsm_("L", "U", "C", diag, &m2, n, &c_b1, &a[m1], m,
+ &b[m1], ldb);
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and */
+/* TRANS = 'C' */
+
+ ztrsm_("L", "U", "N", diag, &m2, n, alpha, &a[m1], m,
+ &b[m1], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("N", "N", &m1, n, &m2, &z__1, a, m, &b[m1],
+ ldb, alpha, &b[b_offset], ldb);
+ ztrsm_("L", "L", "C", diag, &m1, n, &c_b1, &a[m2], m,
+ &b[b_offset], ldb);
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'L', N is odd, and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SIDE ='L', N is odd, TRANSR = 'C', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'L', and */
+/* TRANS = 'N' */
+
+ if (*m == 1) {
+ ztrsm_("L", "U", "C", diag, &m1, n, alpha, a, &m1,
+ &b[b_offset], ldb);
+ } else {
+ ztrsm_("L", "U", "C", diag, &m1, n, alpha, a, &m1,
+ &b[b_offset], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("C", "N", &m2, n, &m1, &z__1, &a[m1 * m1],
+ &m1, &b[b_offset], ldb, alpha, &b[m1],
+ ldb);
+ ztrsm_("L", "L", "N", diag, &m2, n, &c_b1, &a[1],
+ &m1, &b[m1], ldb);
+ }
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'L', and */
+/* TRANS = 'C' */
+
+ if (*m == 1) {
+ ztrsm_("L", "U", "N", diag, &m1, n, alpha, a, &m1,
+ &b[b_offset], ldb);
+ } else {
+ ztrsm_("L", "L", "C", diag, &m2, n, alpha, &a[1],
+ &m1, &b[m1], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("N", "N", &m1, n, &m2, &z__1, &a[m1 * m1],
+ &m1, &b[m1], ldb, alpha, &b[b_offset],
+ ldb);
+ ztrsm_("L", "U", "N", diag, &m1, n, &c_b1, a, &m1,
+ &b[b_offset], ldb);
+ }
+
+ }
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'C', and UPLO = 'U' */
+
+ if (! notrans) {
+
+/* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'U', and */
+/* TRANS = 'N' */
+
+ ztrsm_("L", "U", "C", diag, &m1, n, alpha, &a[m2 * m2]
+, &m2, &b[b_offset], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("N", "N", &m2, n, &m1, &z__1, a, &m2, &b[
+ b_offset], ldb, alpha, &b[m1], ldb);
+ ztrsm_("L", "L", "N", diag, &m2, n, &c_b1, &a[m1 * m2]
+, &m2, &b[m1], ldb);
+
+ } else {
+
+/* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'U', and */
+/* TRANS = 'C' */
+
+ ztrsm_("L", "L", "C", diag, &m2, n, alpha, &a[m1 * m2]
+, &m2, &b[m1], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("C", "N", &m1, n, &m2, &z__1, a, &m2, &b[m1],
+ ldb, alpha, &b[b_offset], ldb);
+ ztrsm_("L", "U", "N", diag, &m1, n, &c_b1, &a[m2 * m2]
+, &m2, &b[b_offset], ldb);
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'L' and N is even */
+
+ if (normaltransr) {
+
+/* SIDE = 'L', N is even, and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', */
+/* and TRANS = 'N' */
+
+ i__1 = *m + 1;
+ ztrsm_("L", "L", "N", diag, &k, n, alpha, &a[1], &
+ i__1, &b[b_offset], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ i__1 = *m + 1;
+ zgemm_("N", "N", &k, n, &k, &z__1, &a[k + 1], &i__1, &
+ b[b_offset], ldb, alpha, &b[k], ldb);
+ i__1 = *m + 1;
+ ztrsm_("L", "U", "C", diag, &k, n, &c_b1, a, &i__1, &
+ b[k], ldb);
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', */
+/* and TRANS = 'C' */
+
+ i__1 = *m + 1;
+ ztrsm_("L", "U", "N", diag, &k, n, alpha, a, &i__1, &
+ b[k], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ i__1 = *m + 1;
+ zgemm_("C", "N", &k, n, &k, &z__1, &a[k + 1], &i__1, &
+ b[k], ldb, alpha, &b[b_offset], ldb);
+ i__1 = *m + 1;
+ ztrsm_("L", "L", "C", diag, &k, n, &c_b1, &a[1], &
+ i__1, &b[b_offset], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'U' */
+
+ if (! notrans) {
+
+/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', */
+/* and TRANS = 'N' */
+
+ i__1 = *m + 1;
+ ztrsm_("L", "L", "N", diag, &k, n, alpha, &a[k + 1], &
+ i__1, &b[b_offset], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ i__1 = *m + 1;
+ zgemm_("C", "N", &k, n, &k, &z__1, a, &i__1, &b[
+ b_offset], ldb, alpha, &b[k], ldb);
+ i__1 = *m + 1;
+ ztrsm_("L", "U", "C", diag, &k, n, &c_b1, &a[k], &
+ i__1, &b[k], ldb);
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', */
+/* and TRANS = 'C' */
+ i__1 = *m + 1;
+ ztrsm_("L", "U", "N", diag, &k, n, alpha, &a[k], &
+ i__1, &b[k], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ i__1 = *m + 1;
+ zgemm_("N", "N", &k, n, &k, &z__1, a, &i__1, &b[k],
+ ldb, alpha, &b[b_offset], ldb);
+ i__1 = *m + 1;
+ ztrsm_("L", "L", "C", diag, &k, n, &c_b1, &a[k + 1], &
+ i__1, &b[b_offset], ldb);
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'L', N is even, and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SIDE ='L', N is even, TRANSR = 'C', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'L', */
+/* and TRANS = 'N' */
+
+ ztrsm_("L", "U", "C", diag, &k, n, alpha, &a[k], &k, &
+ b[b_offset], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("C", "N", &k, n, &k, &z__1, &a[k * (k + 1)], &
+ k, &b[b_offset], ldb, alpha, &b[k], ldb);
+ ztrsm_("L", "L", "N", diag, &k, n, &c_b1, a, &k, &b[k]
+, ldb);
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'L', */
+/* and TRANS = 'C' */
+
+ ztrsm_("L", "L", "C", diag, &k, n, alpha, a, &k, &b[k]
+, ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("N", "N", &k, n, &k, &z__1, &a[k * (k + 1)], &
+ k, &b[k], ldb, alpha, &b[b_offset], ldb);
+ ztrsm_("L", "U", "N", diag, &k, n, &c_b1, &a[k], &k, &
+ b[b_offset], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'C', and UPLO = 'U' */
+
+ if (! notrans) {
+
+/* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'U', */
+/* and TRANS = 'N' */
+
+ ztrsm_("L", "U", "C", diag, &k, n, alpha, &a[k * (k +
+ 1)], &k, &b[b_offset], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("N", "N", &k, n, &k, &z__1, a, &k, &b[b_offset]
+, ldb, alpha, &b[k], ldb);
+ ztrsm_("L", "L", "N", diag, &k, n, &c_b1, &a[k * k], &
+ k, &b[k], ldb);
+
+ } else {
+
+/* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'U', */
+/* and TRANS = 'C' */
+
+ ztrsm_("L", "L", "C", diag, &k, n, alpha, &a[k * k], &
+ k, &b[k], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("C", "N", &k, n, &k, &z__1, a, &k, &b[k], ldb,
+ alpha, &b[b_offset], ldb);
+ ztrsm_("L", "U", "N", diag, &k, n, &c_b1, &a[k * (k +
+ 1)], &k, &b[b_offset], ldb);
+
+ }
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'R' */
+
+/* A is N-by-N. */
+/* If N is odd, set NISODD = .TRUE., and N1 and N2. */
+/* If N is even, NISODD = .FALSE., and K. */
+
+ if (*n % 2 == 0) {
+ nisodd = FALSE_;
+ k = *n / 2;
+ } else {
+ nisodd = TRUE_;
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+ }
+
+ if (nisodd) {
+
+/* SIDE = 'R' and N is odd */
+
+ if (normaltransr) {
+
+/* SIDE = 'R', N is odd, and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and */
+/* TRANS = 'N' */
+
+ ztrsm_("R", "U", "C", diag, m, &n2, alpha, &a[*n], n,
+ &b[n1 * b_dim1], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("N", "N", m, &n1, &n2, &z__1, &b[n1 * b_dim1],
+ ldb, &a[n1], n, alpha, b, ldb);
+ ztrsm_("R", "L", "N", diag, m, &n1, &c_b1, a, n, b,
+ ldb);
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and */
+/* TRANS = 'C' */
+
+ ztrsm_("R", "L", "C", diag, m, &n1, alpha, a, n, b,
+ ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("N", "C", m, &n2, &n1, &z__1, b, ldb, &a[n1],
+ n, alpha, &b[n1 * b_dim1], ldb);
+ ztrsm_("R", "U", "N", diag, m, &n2, &c_b1, &a[*n], n,
+ &b[n1 * b_dim1], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and */
+/* TRANS = 'N' */
+
+ ztrsm_("R", "L", "C", diag, m, &n1, alpha, &a[n2], n,
+ b, ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("N", "N", m, &n2, &n1, &z__1, b, ldb, a, n,
+ alpha, &b[n1 * b_dim1], ldb);
+ ztrsm_("R", "U", "N", diag, m, &n2, &c_b1, &a[n1], n,
+ &b[n1 * b_dim1], ldb);
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and */
+/* TRANS = 'C' */
+
+ ztrsm_("R", "U", "C", diag, m, &n2, alpha, &a[n1], n,
+ &b[n1 * b_dim1], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("N", "C", m, &n1, &n2, &z__1, &b[n1 * b_dim1],
+ ldb, a, n, alpha, b, ldb);
+ ztrsm_("R", "L", "N", diag, m, &n1, &c_b1, &a[n2], n,
+ b, ldb);
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'R', N is odd, and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SIDE ='R', N is odd, TRANSR = 'C', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'L', and */
+/* TRANS = 'N' */
+
+ ztrsm_("R", "L", "N", diag, m, &n2, alpha, &a[1], &n1,
+ &b[n1 * b_dim1], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("N", "C", m, &n1, &n2, &z__1, &b[n1 * b_dim1],
+ ldb, &a[n1 * n1], &n1, alpha, b, ldb);
+ ztrsm_("R", "U", "C", diag, m, &n1, &c_b1, a, &n1, b,
+ ldb);
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'L', and */
+/* TRANS = 'C' */
+
+ ztrsm_("R", "U", "N", diag, m, &n1, alpha, a, &n1, b,
+ ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("N", "N", m, &n2, &n1, &z__1, b, ldb, &a[n1 *
+ n1], &n1, alpha, &b[n1 * b_dim1], ldb);
+ ztrsm_("R", "L", "C", diag, m, &n2, &c_b1, &a[1], &n1,
+ &b[n1 * b_dim1], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'C', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'U', and */
+/* TRANS = 'N' */
+
+ ztrsm_("R", "U", "N", diag, m, &n1, alpha, &a[n2 * n2]
+, &n2, b, ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("N", "C", m, &n2, &n1, &z__1, b, ldb, a, &n2,
+ alpha, &b[n1 * b_dim1], ldb);
+ ztrsm_("R", "L", "C", diag, m, &n2, &c_b1, &a[n1 * n2]
+, &n2, &b[n1 * b_dim1], ldb);
+
+ } else {
+
+/* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'U', and */
+/* TRANS = 'C' */
+
+ ztrsm_("R", "L", "N", diag, m, &n2, alpha, &a[n1 * n2]
+, &n2, &b[n1 * b_dim1], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("N", "N", m, &n1, &n2, &z__1, &b[n1 * b_dim1],
+ ldb, a, &n2, alpha, b, ldb);
+ ztrsm_("R", "U", "C", diag, m, &n1, &c_b1, &a[n2 * n2]
+, &n2, b, ldb);
+
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'R' and N is even */
+
+ if (normaltransr) {
+
+/* SIDE = 'R', N is even, and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', */
+/* and TRANS = 'N' */
+
+ i__1 = *n + 1;
+ ztrsm_("R", "U", "C", diag, m, &k, alpha, a, &i__1, &
+ b[k * b_dim1], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ i__1 = *n + 1;
+ zgemm_("N", "N", m, &k, &k, &z__1, &b[k * b_dim1],
+ ldb, &a[k + 1], &i__1, alpha, b, ldb);
+ i__1 = *n + 1;
+ ztrsm_("R", "L", "N", diag, m, &k, &c_b1, &a[1], &
+ i__1, b, ldb);
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', */
+/* and TRANS = 'C' */
+
+ i__1 = *n + 1;
+ ztrsm_("R", "L", "C", diag, m, &k, alpha, &a[1], &
+ i__1, b, ldb);
+ z__1.r = -1., z__1.i = -0.;
+ i__1 = *n + 1;
+ zgemm_("N", "C", m, &k, &k, &z__1, b, ldb, &a[k + 1],
+ &i__1, alpha, &b[k * b_dim1], ldb);
+ i__1 = *n + 1;
+ ztrsm_("R", "U", "N", diag, m, &k, &c_b1, a, &i__1, &
+ b[k * b_dim1], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', */
+/* and TRANS = 'N' */
+
+ i__1 = *n + 1;
+ ztrsm_("R", "L", "C", diag, m, &k, alpha, &a[k + 1], &
+ i__1, b, ldb);
+ z__1.r = -1., z__1.i = -0.;
+ i__1 = *n + 1;
+ zgemm_("N", "N", m, &k, &k, &z__1, b, ldb, a, &i__1,
+ alpha, &b[k * b_dim1], ldb);
+ i__1 = *n + 1;
+ ztrsm_("R", "U", "N", diag, m, &k, &c_b1, &a[k], &
+ i__1, &b[k * b_dim1], ldb);
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', */
+/* and TRANS = 'C' */
+
+ i__1 = *n + 1;
+ ztrsm_("R", "U", "C", diag, m, &k, alpha, &a[k], &
+ i__1, &b[k * b_dim1], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ i__1 = *n + 1;
+ zgemm_("N", "C", m, &k, &k, &z__1, &b[k * b_dim1],
+ ldb, a, &i__1, alpha, b, ldb);
+ i__1 = *n + 1;
+ ztrsm_("R", "L", "N", diag, m, &k, &c_b1, &a[k + 1], &
+ i__1, b, ldb);
+
+ }
+
+ }
+
+ } else {
+
+/* SIDE = 'R', N is even, and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SIDE ='R', N is even, TRANSR = 'C', and UPLO = 'L' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'L', */
+/* and TRANS = 'N' */
+
+ ztrsm_("R", "L", "N", diag, m, &k, alpha, a, &k, &b[k
+ * b_dim1], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("N", "C", m, &k, &k, &z__1, &b[k * b_dim1],
+ ldb, &a[(k + 1) * k], &k, alpha, b, ldb);
+ ztrsm_("R", "U", "C", diag, m, &k, &c_b1, &a[k], &k,
+ b, ldb);
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'L', */
+/* and TRANS = 'C' */
+
+ ztrsm_("R", "U", "N", diag, m, &k, alpha, &a[k], &k,
+ b, ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("N", "N", m, &k, &k, &z__1, b, ldb, &a[(k + 1)
+ * k], &k, alpha, &b[k * b_dim1], ldb);
+ ztrsm_("R", "L", "C", diag, m, &k, &c_b1, a, &k, &b[k
+ * b_dim1], ldb);
+
+ }
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'C', and UPLO = 'U' */
+
+ if (notrans) {
+
+/* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'U', */
+/* and TRANS = 'N' */
+
+ ztrsm_("R", "U", "N", diag, m, &k, alpha, &a[(k + 1) *
+ k], &k, b, ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("N", "C", m, &k, &k, &z__1, b, ldb, a, &k,
+ alpha, &b[k * b_dim1], ldb);
+ ztrsm_("R", "L", "C", diag, m, &k, &c_b1, &a[k * k], &
+ k, &b[k * b_dim1], ldb);
+
+ } else {
+
+/* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'U', */
+/* and TRANS = 'C' */
+
+ ztrsm_("R", "L", "N", diag, m, &k, alpha, &a[k * k], &
+ k, &b[k * b_dim1], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("N", "N", m, &k, &k, &z__1, &b[k * b_dim1],
+ ldb, a, &k, alpha, b, ldb);
+ ztrsm_("R", "U", "C", diag, m, &k, &c_b1, &a[(k + 1) *
+ k], &k, b, ldb);
+
+ }
+
+ }
+
+ }
+
+ }
+ }
+
+ return 0;
+
+/* End of ZTFSM */
+
+} /* ztfsm_ */
diff --git a/SRC/ztftri.c b/SRC/ztftri.c
new file mode 100644
index 0000000..9c028d1
--- /dev/null
+++ b/SRC/ztftri.c
@@ -0,0 +1,500 @@
+/* ztftri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+
+/* Subroutine */ int ztftri_(char *transr, char *uplo, char *diag, integer *n,
+ doublecomplex *a, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer k, n1, n2;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int ztrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ xerbla_(char *, integer *);
+ logical nisodd;
+ extern /* Subroutine */ int ztrtri_(char *, char *, integer *,
+ doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTFTRI computes the inverse of a triangular matrix A stored in RFP */
+/* format. */
+
+/* This is a Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': The Normal TRANSR of RFP A is stored; */
+/* = 'C': The Conjugate-transpose TRANSR of RFP A is stored. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension ( N*(N+1)/2 ); */
+/* On entry, the triangular matrix A in RFP format. RFP format */
+/* is described by TRANSR, UPLO, and N as follows: If TRANSR = */
+/* 'N' then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */
+/* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is */
+/* the Conjugate-transpose of RFP A as defined when */
+/* TRANSR = 'N'. The contents of RFP A are defined by UPLO as */
+/* follows: If UPLO = 'U' the RFP A contains the nt elements of */
+/* upper packed A; If UPLO = 'L' the RFP A contains the nt */
+/* elements of lower packed A. The LDA of RFP A is (N+1)/2 when */
+/* TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is */
+/* even and N is odd. See the Note below for more details. */
+
+/* On exit, the (triangular) inverse of the original matrix, in */
+/* the same storage format. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */
+/* matrix is singular and its inverse can not be computed. */
+
+/* Notes: */
+/* ====== */
+
+/* We first consider Standard Packed Format when N is even. */
+/* We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* conjugate-transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* conjugate-transpose of the last three columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- -- */
+/* 03 04 05 33 43 53 */
+/* -- -- */
+/* 13 14 15 00 44 54 */
+/* -- */
+/* 23 24 25 10 11 55 */
+
+/* 33 34 35 20 21 22 */
+/* -- */
+/* 00 44 45 30 31 32 */
+/* -- -- */
+/* 01 11 55 40 41 42 */
+/* -- -- -- */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We next consider Standard Packed Format when N is odd. */
+/* We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* conjugate-transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* conjugate-transpose of the last two columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- */
+/* 02 03 04 00 33 43 */
+/* -- */
+/* 12 13 14 10 11 44 */
+
+/* 22 23 24 20 21 22 */
+/* -- */
+/* 00 33 34 30 31 32 */
+/* -- -- */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- */
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "C")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (! lsame_(diag, "N") && ! lsame_(diag,
+ "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTFTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* If N is odd, set NISODD = .TRUE. */
+/* If N is even, set K = N/2 and NISODD = .FALSE. */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ } else {
+ nisodd = TRUE_;
+ }
+
+/* Set N1 and N2 depending on LOWER */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+
+/* start execution: there are eight cases */
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */
+/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */
+/* T1 -> a(0), T2 -> a(n), S -> a(n1) */
+
+ ztrtri_("L", diag, &n1, a, n, info);
+ if (*info > 0) {
+ return 0;
+ }
+ z__1.r = -1., z__1.i = -0.;
+ ztrmm_("R", "L", "N", diag, &n2, &n1, &z__1, a, n, &a[n1], n);
+ ztrtri_("U", diag, &n2, &a[*n], n, info)
+ ;
+ if (*info > 0) {
+ *info += n1;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ ztrmm_("L", "U", "C", diag, &n2, &n1, &c_b1, &a[*n], n, &a[n1]
+, n);
+
+ } else {
+
+/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */
+/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */
+/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */
+
+ ztrtri_("L", diag, &n1, &a[n2], n, info)
+ ;
+ if (*info > 0) {
+ return 0;
+ }
+ z__1.r = -1., z__1.i = -0.;
+ ztrmm_("L", "L", "C", diag, &n1, &n2, &z__1, &a[n2], n, a, n);
+ ztrtri_("U", diag, &n2, &a[n1], n, info)
+ ;
+ if (*info > 0) {
+ *info += n1;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ ztrmm_("R", "U", "N", diag, &n1, &n2, &c_b1, &a[n1], n, a, n);
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is odd */
+/* T1 -> a(0), T2 -> a(1), S -> a(0+n1*n1) */
+
+ ztrtri_("U", diag, &n1, a, &n1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ z__1.r = -1., z__1.i = -0.;
+ ztrmm_("L", "U", "N", diag, &n1, &n2, &z__1, a, &n1, &a[n1 *
+ n1], &n1);
+ ztrtri_("L", diag, &n2, &a[1], &n1, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ ztrmm_("R", "L", "C", diag, &n1, &n2, &c_b1, &a[1], &n1, &a[
+ n1 * n1], &n1);
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is odd */
+/* T1 -> a(0+n2*n2), T2 -> a(0+n1*n2), S -> a(0) */
+
+ ztrtri_("U", diag, &n1, &a[n2 * n2], &n2, info);
+ if (*info > 0) {
+ return 0;
+ }
+ z__1.r = -1., z__1.i = -0.;
+ ztrmm_("R", "U", "C", diag, &n2, &n1, &z__1, &a[n2 * n2], &n2,
+ a, &n2);
+ ztrtri_("L", diag, &n2, &a[n1 * n2], &n2, info);
+ if (*info > 0) {
+ *info += n1;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ ztrmm_("L", "L", "N", diag, &n2, &n1, &c_b1, &a[n1 * n2], &n2,
+ a, &n2);
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
+/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */
+
+ i__1 = *n + 1;
+ ztrtri_("L", diag, &k, &a[1], &i__1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ z__1.r = -1., z__1.i = -0.;
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ ztrmm_("R", "L", "N", diag, &k, &k, &z__1, &a[1], &i__1, &a[k
+ + 1], &i__2);
+ i__1 = *n + 1;
+ ztrtri_("U", diag, &k, a, &i__1, info);
+ if (*info > 0) {
+ *info += k;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ ztrmm_("L", "U", "C", diag, &k, &k, &c_b1, a, &i__1, &a[k + 1]
+, &i__2);
+
+ } else {
+
+/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
+/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */
+
+ i__1 = *n + 1;
+ ztrtri_("L", diag, &k, &a[k + 1], &i__1, info);
+ if (*info > 0) {
+ return 0;
+ }
+ z__1.r = -1., z__1.i = -0.;
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ ztrmm_("L", "L", "C", diag, &k, &k, &z__1, &a[k + 1], &i__1,
+ a, &i__2);
+ i__1 = *n + 1;
+ ztrtri_("U", diag, &k, &a[k], &i__1, info);
+ if (*info > 0) {
+ *info += k;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ i__1 = *n + 1;
+ i__2 = *n + 1;
+ ztrmm_("R", "U", "N", diag, &k, &k, &c_b1, &a[k], &i__1, a, &
+ i__2);
+ }
+ } else {
+
+/* N is even and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */
+/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */
+
+ ztrtri_("U", diag, &k, &a[k], &k, info);
+ if (*info > 0) {
+ return 0;
+ }
+ z__1.r = -1., z__1.i = -0.;
+ ztrmm_("L", "U", "N", diag, &k, &k, &z__1, &a[k], &k, &a[k * (
+ k + 1)], &k);
+ ztrtri_("L", diag, &k, a, &k, info);
+ if (*info > 0) {
+ *info += k;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ ztrmm_("R", "L", "C", diag, &k, &k, &c_b1, a, &k, &a[k * (k +
+ 1)], &k);
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */
+/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */
+
+ ztrtri_("U", diag, &k, &a[k * (k + 1)], &k, info);
+ if (*info > 0) {
+ return 0;
+ }
+ z__1.r = -1., z__1.i = -0.;
+ ztrmm_("R", "U", "C", diag, &k, &k, &z__1, &a[k * (k + 1)], &
+ k, a, &k);
+ ztrtri_("L", diag, &k, &a[k * k], &k, info);
+ if (*info > 0) {
+ *info += k;
+ }
+ if (*info > 0) {
+ return 0;
+ }
+ ztrmm_("L", "L", "N", diag, &k, &k, &c_b1, &a[k * k], &k, a, &
+ k);
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZTFTRI */
+
+} /* ztftri_ */
diff --git a/SRC/ztfttp.c b/SRC/ztfttp.c
new file mode 100644
index 0000000..91a07c2
--- /dev/null
+++ b/SRC/ztfttp.c
@@ -0,0 +1,575 @@
+/* ztfttp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ztfttp_(char *transr, char *uplo, integer *n,
+ doublecomplex *arf, doublecomplex *ap, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, n1, n2, ij, jp, js, nt, lda, ijp;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nisodd;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTFTTP copies a triangular matrix A from rectangular full packed */
+/* format (TF) to standard packed format (TP). */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': ARF is in Normal format; */
+/* = 'C': ARF is in Conjugate-transpose format; */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* ARF (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ), */
+/* On entry, the upper or lower triangular matrix A stored in */
+/* RFP format. For a further discussion see Notes below. */
+
+/* AP (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ), */
+/* On exit, the upper or lower triangular matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Notes: */
+/* ====== */
+
+/* We first consider Standard Packed Format when N is even. */
+/* We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* conjugate-transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* conjugate-transpose of the last three columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- -- */
+/* 03 04 05 33 43 53 */
+/* -- -- */
+/* 13 14 15 00 44 54 */
+/* -- */
+/* 23 24 25 10 11 55 */
+
+/* 33 34 35 20 21 22 */
+/* -- */
+/* 00 44 45 30 31 32 */
+/* -- -- */
+/* 01 11 55 40 41 42 */
+/* -- -- -- */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We next consider Standard Packed Format when N is odd. */
+/* We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* conjugate-transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* conjugate-transpose of the last two columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- */
+/* 02 03 04 00 33 43 */
+/* -- */
+/* 12 13 14 10 11 44 */
+
+/* 22 23 24 20 21 22 */
+/* -- */
+/* 00 33 34 30 31 32 */
+/* -- -- */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- */
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "C")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTFTTP", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (normaltransr) {
+ ap[0].r = arf[0].r, ap[0].i = arf[0].i;
+ } else {
+ d_cnjg(&z__1, arf);
+ ap[0].r = z__1.r, ap[0].i = z__1.i;
+ }
+ return 0;
+ }
+
+/* Size of array ARF(0:NT-1) */
+
+ nt = *n * (*n + 1) / 2;
+
+/* Set N1 and N2 depending on LOWER */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* If N is odd, set NISODD = .TRUE. */
+/* If N is even, set K = N/2 and NISODD = .FALSE. */
+
+/* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) */
+/* where noe = 0 if n is even, noe = 1 if n is odd */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ lda = *n + 1;
+ } else {
+ nisodd = TRUE_;
+ lda = *n;
+ }
+
+/* ARF^C has lda rows and n+1-noe cols */
+
+ if (! normaltransr) {
+ lda = (*n + 1) / 2;
+ }
+
+/* start execution: there are eight cases */
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */
+/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */
+/* T1 -> a(0), T2 -> a(n), S -> a(n1); lda = n */
+
+ ijp = 0;
+ jp = 0;
+ i__1 = n2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ij = i__ + jp;
+ i__3 = ijp;
+ i__4 = ij;
+ ap[i__3].r = arf[i__4].r, ap[i__3].i = arf[i__4].i;
+ ++ijp;
+ }
+ jp += lda;
+ }
+ i__1 = n2 - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = n2;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ ij = i__ + j * lda;
+ i__3 = ijp;
+ d_cnjg(&z__1, &arf[ij]);
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+ ++ijp;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */
+/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */
+/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */
+
+ ijp = 0;
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ ij = n2 + j;
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ijp;
+ d_cnjg(&z__1, &arf[ij]);
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+ ++ijp;
+ ij += lda;
+ }
+ }
+ js = 0;
+ i__1 = *n - 1;
+ for (j = n1; j <= i__1; ++j) {
+ ij = js;
+ i__2 = js + j;
+ for (ij = js; ij <= i__2; ++ij) {
+ i__3 = ijp;
+ i__4 = ij;
+ ap[i__3].r = arf[i__4].r, ap[i__3].i = arf[i__4].i;
+ ++ijp;
+ }
+ js += lda;
+ }
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is odd */
+/* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */
+/* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 */
+
+ ijp = 0;
+ i__1 = n2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = *n * lda - 1;
+ i__3 = lda;
+ for (ij = i__ * (lda + 1); i__3 < 0 ? ij >= i__2 : ij <=
+ i__2; ij += i__3) {
+ i__4 = ijp;
+ d_cnjg(&z__1, &arf[ij]);
+ ap[i__4].r = z__1.r, ap[i__4].i = z__1.i;
+ ++ijp;
+ }
+ }
+ js = 1;
+ i__1 = n2 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + n2 - j - 1;
+ for (ij = js; ij <= i__3; ++ij) {
+ i__2 = ijp;
+ i__4 = ij;
+ ap[i__2].r = arf[i__4].r, ap[i__2].i = arf[i__4].i;
+ ++ijp;
+ }
+ js = js + lda + 1;
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is odd */
+/* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */
+/* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 */
+
+ ijp = 0;
+ js = n2 * lda;
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + j;
+ for (ij = js; ij <= i__3; ++ij) {
+ i__2 = ijp;
+ i__4 = ij;
+ ap[i__2].r = arf[i__4].r, ap[i__2].i = arf[i__4].i;
+ ++ijp;
+ }
+ js += lda;
+ }
+ i__1 = n1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__3 = i__ + (n1 + i__) * lda;
+ i__2 = lda;
+ for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij +=
+ i__2) {
+ i__4 = ijp;
+ d_cnjg(&z__1, &arf[ij]);
+ ap[i__4].r = z__1.r, ap[i__4].i = z__1.i;
+ ++ijp;
+ }
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
+/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */
+
+ ijp = 0;
+ jp = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ij = i__ + 1 + jp;
+ i__3 = ijp;
+ i__4 = ij;
+ ap[i__3].r = arf[i__4].r, ap[i__3].i = arf[i__4].i;
+ ++ijp;
+ }
+ jp += lda;
+ }
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = k - 1;
+ for (j = i__; j <= i__2; ++j) {
+ ij = i__ + j * lda;
+ i__3 = ijp;
+ d_cnjg(&z__1, &arf[ij]);
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+ ++ijp;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
+/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */
+
+ ijp = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ ij = k + 1 + j;
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ijp;
+ d_cnjg(&z__1, &arf[ij]);
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+ ++ijp;
+ ij += lda;
+ }
+ }
+ js = 0;
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+ ij = js;
+ i__2 = js + j;
+ for (ij = js; ij <= i__2; ++ij) {
+ i__3 = ijp;
+ i__4 = ij;
+ ap[i__3].r = arf[i__4].r, ap[i__3].i = arf[i__4].i;
+ ++ijp;
+ }
+ js += lda;
+ }
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */
+/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */
+
+ ijp = 0;
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = (*n + 1) * lda - 1;
+ i__3 = lda;
+ for (ij = i__ + (i__ + 1) * lda; i__3 < 0 ? ij >= i__2 :
+ ij <= i__2; ij += i__3) {
+ i__4 = ijp;
+ d_cnjg(&z__1, &arf[ij]);
+ ap[i__4].r = z__1.r, ap[i__4].i = z__1.i;
+ ++ijp;
+ }
+ }
+ js = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + k - j - 1;
+ for (ij = js; ij <= i__3; ++ij) {
+ i__2 = ijp;
+ i__4 = ij;
+ ap[i__2].r = arf[i__4].r, ap[i__2].i = arf[i__4].i;
+ ++ijp;
+ }
+ js = js + lda + 1;
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */
+/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */
+
+ ijp = 0;
+ js = (k + 1) * lda;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + j;
+ for (ij = js; ij <= i__3; ++ij) {
+ i__2 = ijp;
+ i__4 = ij;
+ ap[i__2].r = arf[i__4].r, ap[i__2].i = arf[i__4].i;
+ ++ijp;
+ }
+ js += lda;
+ }
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__3 = i__ + (k + i__) * lda;
+ i__2 = lda;
+ for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij +=
+ i__2) {
+ i__4 = ijp;
+ d_cnjg(&z__1, &arf[ij]);
+ ap[i__4].r = z__1.r, ap[i__4].i = z__1.i;
+ ++ijp;
+ }
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of ZTFTTP */
+
+} /* ztfttp_ */
diff --git a/SRC/ztfttr.c b/SRC/ztfttr.c
new file mode 100644
index 0000000..c7e53b9
--- /dev/null
+++ b/SRC/ztfttr.c
@@ -0,0 +1,580 @@
+/* ztfttr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ztfttr_(char *transr, char *uplo, integer *n,
+ doublecomplex *arf, doublecomplex *a, integer *lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, l, n1, n2, ij, nt, nx2, np1x2;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nisodd;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTFTTR copies a triangular matrix A from rectangular full packed */
+/* format (TF) to standard full format (TR). */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': ARF is in Normal format; */
+/* = 'C': ARF is in Conjugate-transpose format; */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* ARF (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ), */
+/* On entry, the upper or lower triangular matrix A stored in */
+/* RFP format. For a further discussion see Notes below. */
+
+/* A (output) COMPLEX*16 array, dimension ( LDA, N ) */
+/* On exit, the triangular matrix A. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of the array A contains */
+/* the upper triangular matrix, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of the array A contains */
+/* the lower triangular matrix, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Notes: */
+/* ====== */
+
+/* We first consider Standard Packed Format when N is even. */
+/* We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* conjugate-transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* conjugate-transpose of the last three columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- -- */
+/* 03 04 05 33 43 53 */
+/* -- -- */
+/* 13 14 15 00 44 54 */
+/* -- */
+/* 23 24 25 10 11 55 */
+
+/* 33 34 35 20 21 22 */
+/* -- */
+/* 00 44 45 30 31 32 */
+/* -- -- */
+/* 01 11 55 40 41 42 */
+/* -- -- -- */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We next consider Standard Packed Format when N is odd. */
+/* We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* conjugate-transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* conjugate-transpose of the last two columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- */
+/* 02 03 04 00 33 43 */
+/* -- */
+/* 12 13 14 10 11 44 */
+
+/* 22 23 24 20 21 22 */
+/* -- */
+/* 00 33 34 30 31 32 */
+/* -- -- */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- */
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda - 1 - 0 + 1;
+ a_offset = 0 + a_dim1 * 0;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "C")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTFTTR", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 1) {
+ if (*n == 1) {
+ if (normaltransr) {
+ a[0].r = arf[0].r, a[0].i = arf[0].i;
+ } else {
+ d_cnjg(&z__1, arf);
+ a[0].r = z__1.r, a[0].i = z__1.i;
+ }
+ }
+ return 0;
+ }
+
+/* Size of array ARF(1:2,0:nt-1) */
+
+ nt = *n * (*n + 1) / 2;
+
+/* set N1 and N2 depending on LOWER: for N even N1=N2=K */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. */
+/* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is */
+/* N--by--(N+1)/2. */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ if (! lower) {
+ np1x2 = *n + *n + 2;
+ }
+ } else {
+ nisodd = TRUE_;
+ if (! lower) {
+ nx2 = *n + *n;
+ }
+ }
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */
+/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */
+/* T1 -> a(0), T2 -> a(n), S -> a(n1); lda=n */
+
+ ij = 0;
+ i__1 = n2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = n2 + j;
+ for (i__ = n1; i__ <= i__2; ++i__) {
+ i__3 = n2 + j + i__ * a_dim1;
+ d_cnjg(&z__1, &arf[ij]);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = ij;
+ a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i;
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */
+/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */
+/* T1 -> a(n2), T2 -> a(n1), S -> a(0); lda=n */
+
+ ij = nt - *n;
+ i__1 = n1;
+ for (j = *n - 1; j >= i__1; --j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = ij;
+ a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i;
+ ++ij;
+ }
+ i__2 = n1 - 1;
+ for (l = j - n1; l <= i__2; ++l) {
+ i__3 = j - n1 + l * a_dim1;
+ d_cnjg(&z__1, &arf[ij]);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ ++ij;
+ }
+ ij -= nx2;
+ }
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is odd */
+/* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */
+/* T1 -> A(0+0) , T2 -> A(1+0) , S -> A(0+n1*n1); lda=n1 */
+
+ ij = 0;
+ i__1 = n2 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * a_dim1;
+ d_cnjg(&z__1, &arf[ij]);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = n1 + j; i__ <= i__2; ++i__) {
+ i__3 = i__ + (n1 + j) * a_dim1;
+ i__4 = ij;
+ a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i;
+ ++ij;
+ }
+ }
+ i__1 = *n - 1;
+ for (j = n2; j <= i__1; ++j) {
+ i__2 = n1 - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * a_dim1;
+ d_cnjg(&z__1, &arf[ij]);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is odd */
+/* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */
+/* T1 -> A(n2*n2), T2 -> A(n1*n2), S -> A(0); lda = n2 */
+
+ ij = 0;
+ i__1 = n1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = n1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * a_dim1;
+ d_cnjg(&z__1, &arf[ij]);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ ++ij;
+ }
+ }
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = ij;
+ a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (l = n2 + j; l <= i__2; ++l) {
+ i__3 = n2 + j + l * a_dim1;
+ d_cnjg(&z__1, &arf[ij]);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ ++ij;
+ }
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
+/* T1 -> a(1), T2 -> a(0), S -> a(k+1); lda=n+1 */
+
+ ij = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k + j;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ i__3 = k + j + i__ * a_dim1;
+ d_cnjg(&z__1, &arf[ij]);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = ij;
+ a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i;
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
+/* T1 -> a(k+1), T2 -> a(k), S -> a(0); lda=n+1 */
+
+ ij = nt - *n - 1;
+ i__1 = k;
+ for (j = *n - 1; j >= i__1; --j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = ij;
+ a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i;
+ ++ij;
+ }
+ i__2 = k - 1;
+ for (l = j - k; l <= i__2; ++l) {
+ i__3 = j - k + l * a_dim1;
+ d_cnjg(&z__1, &arf[ij]);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ ++ij;
+ }
+ ij -= np1x2;
+ }
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is even (see paper, A=B) */
+/* T1 -> A(0,1) , T2 -> A(0,0) , S -> A(0,k+1) : */
+/* T1 -> A(0+k) , T2 -> A(0+0) , S -> A(0+k*(k+1)); lda=k */
+
+ ij = 0;
+ j = k;
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * a_dim1;
+ i__3 = ij;
+ a[i__2].r = arf[i__3].r, a[i__2].i = arf[i__3].i;
+ ++ij;
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * a_dim1;
+ d_cnjg(&z__1, &arf[ij]);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = k + 1 + j; i__ <= i__2; ++i__) {
+ i__3 = i__ + (k + 1 + j) * a_dim1;
+ i__4 = ij;
+ a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i;
+ ++ij;
+ }
+ }
+ i__1 = *n - 1;
+ for (j = k - 1; j <= i__1; ++j) {
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * a_dim1;
+ d_cnjg(&z__1, &arf[ij]);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is even (see paper, A=B) */
+/* T1 -> A(0,k+1) , T2 -> A(0,k) , S -> A(0,0) */
+/* T1 -> A(0+k*(k+1)) , T2 -> A(0+k*k) , S -> A(0+0)); lda=k */
+
+ ij = 0;
+ i__1 = k;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * a_dim1;
+ d_cnjg(&z__1, &arf[ij]);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ ++ij;
+ }
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = ij;
+ a[i__3].r = arf[i__4].r, a[i__3].i = arf[i__4].i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (l = k + 1 + j; l <= i__2; ++l) {
+ i__3 = k + 1 + j + l * a_dim1;
+ d_cnjg(&z__1, &arf[ij]);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ ++ij;
+ }
+ }
+
+/* Note that here J = K-1 */
+
+ i__1 = j;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * a_dim1;
+ i__3 = ij;
+ a[i__2].r = arf[i__3].r, a[i__2].i = arf[i__3].i;
+ ++ij;
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of ZTFTTR */
+
+} /* ztfttr_ */
diff --git a/SRC/ztgevc.c b/SRC/ztgevc.c
new file mode 100644
index 0000000..106692c
--- /dev/null
+++ b/SRC/ztgevc.c
@@ -0,0 +1,972 @@
+/* ztgevc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int ztgevc_(char *side, char *howmny, logical *select,
+ integer *n, doublecomplex *s, integer *lds, doublecomplex *p, integer
+ *ldp, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *
+ ldvr, integer *mm, integer *m, doublecomplex *work, doublereal *rwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer p_dim1, p_offset, s_dim1, s_offset, vl_dim1, vl_offset, vr_dim1,
+ vr_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ doublecomplex d__;
+ integer i__, j;
+ doublecomplex ca, cb;
+ integer je, im, jr;
+ doublereal big;
+ logical lsa, lsb;
+ doublereal ulp;
+ doublecomplex sum;
+ integer ibeg, ieig, iend;
+ doublereal dmin__;
+ integer isrc;
+ doublereal temp;
+ doublecomplex suma, sumb;
+ doublereal xmax, scale;
+ logical ilall;
+ integer iside;
+ doublereal sbeta;
+ extern logical lsame_(char *, char *);
+ doublereal small;
+ logical compl;
+ doublereal anorm, bnorm;
+ logical compr;
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ dlabad_(doublereal *, doublereal *);
+ logical ilbbad;
+ doublereal acoefa, bcoefa, acoeff;
+ doublecomplex bcoeff;
+ logical ilback;
+ doublereal ascale, bscale;
+ extern doublereal dlamch_(char *);
+ doublecomplex salpha;
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ logical ilcomp;
+ extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
+ doublecomplex *);
+ integer ihwmny;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+
+/* Purpose */
+/* ======= */
+
+/* ZTGEVC computes some or all of the right and/or left eigenvectors of */
+/* a pair of complex matrices (S,P), where S and P are upper triangular. */
+/* Matrix pairs of this type are produced by the generalized Schur */
+/* factorization of a complex matrix pair (A,B): */
+
+/* A = Q*S*Z**H, B = Q*P*Z**H */
+
+/* as computed by ZGGHRD + ZHGEQZ. */
+
+/* The right eigenvector x and the left eigenvector y of (S,P) */
+/* corresponding to an eigenvalue w are defined by: */
+
+/* S*x = w*P*x, (y**H)*S = w*(y**H)*P, */
+
+/* where y**H denotes the conjugate tranpose of y. */
+/* The eigenvalues are not input to this routine, but are computed */
+/* directly from the diagonal elements of S and P. */
+
+/* This routine returns the matrices X and/or Y of right and left */
+/* eigenvectors of (S,P), or the products Z*X and/or Q*Y, */
+/* where Z and Q are input matrices. */
+/* If Q and Z are the unitary factors from the generalized Schur */
+/* factorization of a matrix pair (A,B), then Z*X and Q*Y */
+/* are the matrices of right and left eigenvectors of (A,B). */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'R': compute right eigenvectors only; */
+/* = 'L': compute left eigenvectors only; */
+/* = 'B': compute both right and left eigenvectors. */
+
+/* HOWMNY (input) CHARACTER*1 */
+/* = 'A': compute all right and/or left eigenvectors; */
+/* = 'B': compute all right and/or left eigenvectors, */
+/* backtransformed by the matrices in VR and/or VL; */
+/* = 'S': compute selected right and/or left eigenvectors, */
+/* specified by the logical array SELECT. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* If HOWMNY='S', SELECT specifies the eigenvectors to be */
+/* computed. The eigenvector corresponding to the j-th */
+/* eigenvalue is computed if SELECT(j) = .TRUE.. */
+/* Not referenced if HOWMNY = 'A' or 'B'. */
+
+/* N (input) INTEGER */
+/* The order of the matrices S and P. N >= 0. */
+
+/* S (input) COMPLEX*16 array, dimension (LDS,N) */
+/* The upper triangular matrix S from a generalized Schur */
+/* factorization, as computed by ZHGEQZ. */
+
+/* LDS (input) INTEGER */
+/* The leading dimension of array S. LDS >= max(1,N). */
+
+/* P (input) COMPLEX*16 array, dimension (LDP,N) */
+/* The upper triangular matrix P from a generalized Schur */
+/* factorization, as computed by ZHGEQZ. P must have real */
+/* diagonal elements. */
+
+/* LDP (input) INTEGER */
+/* The leading dimension of array P. LDP >= max(1,N). */
+
+/* VL (input/output) COMPLEX*16 array, dimension (LDVL,MM) */
+/* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */
+/* contain an N-by-N matrix Q (usually the unitary matrix Q */
+/* of left Schur vectors returned by ZHGEQZ). */
+/* On exit, if SIDE = 'L' or 'B', VL contains: */
+/* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); */
+/* if HOWMNY = 'B', the matrix Q*Y; */
+/* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by */
+/* SELECT, stored consecutively in the columns of */
+/* VL, in the same order as their eigenvalues. */
+/* Not referenced if SIDE = 'R'. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of array VL. LDVL >= 1, and if */
+/* SIDE = 'L' or 'l' or 'B' or 'b', LDVL >= N. */
+
+/* VR (input/output) COMPLEX*16 array, dimension (LDVR,MM) */
+/* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */
+/* contain an N-by-N matrix Q (usually the unitary matrix Z */
+/* of right Schur vectors returned by ZHGEQZ). */
+/* On exit, if SIDE = 'R' or 'B', VR contains: */
+/* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); */
+/* if HOWMNY = 'B', the matrix Z*X; */
+/* if HOWMNY = 'S', the right eigenvectors of (S,P) specified by */
+/* SELECT, stored consecutively in the columns of */
+/* VR, in the same order as their eigenvalues. */
+/* Not referenced if SIDE = 'L'. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. LDVR >= 1, and if */
+/* SIDE = 'R' or 'B', LDVR >= N. */
+
+/* MM (input) INTEGER */
+/* The number of columns in the arrays VL and/or VR. MM >= M. */
+
+/* M (output) INTEGER */
+/* The number of columns in the arrays VL and/or VR actually */
+/* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M */
+/* is set to N. Each selected eigenvector occupies one column. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and Test the input parameters */
+
+ /* Parameter adjustments */
+ --select;
+ s_dim1 = *lds;
+ s_offset = 1 + s_dim1;
+ s -= s_offset;
+ p_dim1 = *ldp;
+ p_offset = 1 + p_dim1;
+ p -= p_offset;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ if (lsame_(howmny, "A")) {
+ ihwmny = 1;
+ ilall = TRUE_;
+ ilback = FALSE_;
+ } else if (lsame_(howmny, "S")) {
+ ihwmny = 2;
+ ilall = FALSE_;
+ ilback = FALSE_;
+ } else if (lsame_(howmny, "B")) {
+ ihwmny = 3;
+ ilall = TRUE_;
+ ilback = TRUE_;
+ } else {
+ ihwmny = -1;
+ }
+
+ if (lsame_(side, "R")) {
+ iside = 1;
+ compl = FALSE_;
+ compr = TRUE_;
+ } else if (lsame_(side, "L")) {
+ iside = 2;
+ compl = TRUE_;
+ compr = FALSE_;
+ } else if (lsame_(side, "B")) {
+ iside = 3;
+ compl = TRUE_;
+ compr = TRUE_;
+ } else {
+ iside = -1;
+ }
+
+ *info = 0;
+ if (iside < 0) {
+ *info = -1;
+ } else if (ihwmny < 0) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lds < max(1,*n)) {
+ *info = -6;
+ } else if (*ldp < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTGEVC", &i__1);
+ return 0;
+ }
+
+/* Count the number of eigenvectors */
+
+ if (! ilall) {
+ im = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (select[j]) {
+ ++im;
+ }
+/* L10: */
+ }
+ } else {
+ im = *n;
+ }
+
+/* Check diagonal of B */
+
+ ilbbad = FALSE_;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (d_imag(&p[j + j * p_dim1]) != 0.) {
+ ilbbad = TRUE_;
+ }
+/* L20: */
+ }
+
+ if (ilbbad) {
+ *info = -7;
+ } else if (compl && *ldvl < *n || *ldvl < 1) {
+ *info = -10;
+ } else if (compr && *ldvr < *n || *ldvr < 1) {
+ *info = -12;
+ } else if (*mm < im) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTGEVC", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *m = im;
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Machine Constants */
+
+ safmin = dlamch_("Safe minimum");
+ big = 1. / safmin;
+ dlabad_(&safmin, &big);
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ small = safmin * *n / ulp;
+ big = 1. / small;
+ bignum = 1. / (safmin * *n);
+
+/* Compute the 1-norm of each column of the strictly upper triangular */
+/* part of A and B to check for possible overflow in the triangular */
+/* solver. */
+
+ i__1 = s_dim1 + 1;
+ anorm = (d__1 = s[i__1].r, abs(d__1)) + (d__2 = d_imag(&s[s_dim1 + 1]),
+ abs(d__2));
+ i__1 = p_dim1 + 1;
+ bnorm = (d__1 = p[i__1].r, abs(d__1)) + (d__2 = d_imag(&p[p_dim1 + 1]),
+ abs(d__2));
+ rwork[1] = 0.;
+ rwork[*n + 1] = 0.;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ rwork[j] = 0.;
+ rwork[*n + j] = 0.;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * s_dim1;
+ rwork[j] += (d__1 = s[i__3].r, abs(d__1)) + (d__2 = d_imag(&s[i__
+ + j * s_dim1]), abs(d__2));
+ i__3 = i__ + j * p_dim1;
+ rwork[*n + j] += (d__1 = p[i__3].r, abs(d__1)) + (d__2 = d_imag(&
+ p[i__ + j * p_dim1]), abs(d__2));
+/* L30: */
+ }
+/* Computing MAX */
+ i__2 = j + j * s_dim1;
+ d__3 = anorm, d__4 = rwork[j] + ((d__1 = s[i__2].r, abs(d__1)) + (
+ d__2 = d_imag(&s[j + j * s_dim1]), abs(d__2)));
+ anorm = max(d__3,d__4);
+/* Computing MAX */
+ i__2 = j + j * p_dim1;
+ d__3 = bnorm, d__4 = rwork[*n + j] + ((d__1 = p[i__2].r, abs(d__1)) +
+ (d__2 = d_imag(&p[j + j * p_dim1]), abs(d__2)));
+ bnorm = max(d__3,d__4);
+/* L40: */
+ }
+
+ ascale = 1. / max(anorm,safmin);
+ bscale = 1. / max(bnorm,safmin);
+
+/* Left eigenvectors */
+
+ if (compl) {
+ ieig = 0;
+
+/* Main loop over eigenvalues */
+
+ i__1 = *n;
+ for (je = 1; je <= i__1; ++je) {
+ if (ilall) {
+ ilcomp = TRUE_;
+ } else {
+ ilcomp = select[je];
+ }
+ if (ilcomp) {
+ ++ieig;
+
+ i__2 = je + je * s_dim1;
+ i__3 = je + je * p_dim1;
+ if ((d__2 = s[i__2].r, abs(d__2)) + (d__3 = d_imag(&s[je + je
+ * s_dim1]), abs(d__3)) <= safmin && (d__1 = p[i__3].r,
+ abs(d__1)) <= safmin) {
+
+/* Singular matrix pencil -- return unit eigenvector */
+
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = jr + ieig * vl_dim1;
+ vl[i__3].r = 0., vl[i__3].i = 0.;
+/* L50: */
+ }
+ i__2 = ieig + ieig * vl_dim1;
+ vl[i__2].r = 1., vl[i__2].i = 0.;
+ goto L140;
+ }
+
+/* Non-singular eigenvalue: */
+/* Compute coefficients a and b in */
+/* H */
+/* y ( a A - b B ) = 0 */
+
+/* Computing MAX */
+ i__2 = je + je * s_dim1;
+ i__3 = je + je * p_dim1;
+ d__4 = ((d__2 = s[i__2].r, abs(d__2)) + (d__3 = d_imag(&s[je
+ + je * s_dim1]), abs(d__3))) * ascale, d__5 = (d__1 =
+ p[i__3].r, abs(d__1)) * bscale, d__4 = max(d__4,d__5);
+ temp = 1. / max(d__4,safmin);
+ i__2 = je + je * s_dim1;
+ z__2.r = temp * s[i__2].r, z__2.i = temp * s[i__2].i;
+ z__1.r = ascale * z__2.r, z__1.i = ascale * z__2.i;
+ salpha.r = z__1.r, salpha.i = z__1.i;
+ i__2 = je + je * p_dim1;
+ sbeta = temp * p[i__2].r * bscale;
+ acoeff = sbeta * ascale;
+ z__1.r = bscale * salpha.r, z__1.i = bscale * salpha.i;
+ bcoeff.r = z__1.r, bcoeff.i = z__1.i;
+
+/* Scale to avoid underflow */
+
+ lsa = abs(sbeta) >= safmin && abs(acoeff) < small;
+ lsb = (d__1 = salpha.r, abs(d__1)) + (d__2 = d_imag(&salpha),
+ abs(d__2)) >= safmin && (d__3 = bcoeff.r, abs(d__3))
+ + (d__4 = d_imag(&bcoeff), abs(d__4)) < small;
+
+ scale = 1.;
+ if (lsa) {
+ scale = small / abs(sbeta) * min(anorm,big);
+ }
+ if (lsb) {
+/* Computing MAX */
+ d__3 = scale, d__4 = small / ((d__1 = salpha.r, abs(d__1))
+ + (d__2 = d_imag(&salpha), abs(d__2))) * min(
+ bnorm,big);
+ scale = max(d__3,d__4);
+ }
+ if (lsa || lsb) {
+/* Computing MIN */
+/* Computing MAX */
+ d__5 = 1., d__6 = abs(acoeff), d__5 = max(d__5,d__6),
+ d__6 = (d__1 = bcoeff.r, abs(d__1)) + (d__2 =
+ d_imag(&bcoeff), abs(d__2));
+ d__3 = scale, d__4 = 1. / (safmin * max(d__5,d__6));
+ scale = min(d__3,d__4);
+ if (lsa) {
+ acoeff = ascale * (scale * sbeta);
+ } else {
+ acoeff = scale * acoeff;
+ }
+ if (lsb) {
+ z__2.r = scale * salpha.r, z__2.i = scale * salpha.i;
+ z__1.r = bscale * z__2.r, z__1.i = bscale * z__2.i;
+ bcoeff.r = z__1.r, bcoeff.i = z__1.i;
+ } else {
+ z__1.r = scale * bcoeff.r, z__1.i = scale * bcoeff.i;
+ bcoeff.r = z__1.r, bcoeff.i = z__1.i;
+ }
+ }
+
+ acoefa = abs(acoeff);
+ bcoefa = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = d_imag(&
+ bcoeff), abs(d__2));
+ xmax = 1.;
+ i__2 = *n;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = jr;
+ work[i__3].r = 0., work[i__3].i = 0.;
+/* L60: */
+ }
+ i__2 = je;
+ work[i__2].r = 1., work[i__2].i = 0.;
+/* Computing MAX */
+ d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm,
+ d__1 = max(d__1,d__2);
+ dmin__ = max(d__1,safmin);
+
+/* H */
+/* Triangular solve of (a A - b B) y = 0 */
+
+/* H */
+/* (rowwise in (a A - b B) , or columnwise in a A - b B) */
+
+ i__2 = *n;
+ for (j = je + 1; j <= i__2; ++j) {
+
+/* Compute */
+/* j-1 */
+/* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) */
+/* k=je */
+/* (Scale if necessary) */
+
+ temp = 1. / xmax;
+ if (acoefa * rwork[j] + bcoefa * rwork[*n + j] > bignum *
+ temp) {
+ i__3 = j - 1;
+ for (jr = je; jr <= i__3; ++jr) {
+ i__4 = jr;
+ i__5 = jr;
+ z__1.r = temp * work[i__5].r, z__1.i = temp *
+ work[i__5].i;
+ work[i__4].r = z__1.r, work[i__4].i = z__1.i;
+/* L70: */
+ }
+ xmax = 1.;
+ }
+ suma.r = 0., suma.i = 0.;
+ sumb.r = 0., sumb.i = 0.;
+
+ i__3 = j - 1;
+ for (jr = je; jr <= i__3; ++jr) {
+ d_cnjg(&z__3, &s[jr + j * s_dim1]);
+ i__4 = jr;
+ z__2.r = z__3.r * work[i__4].r - z__3.i * work[i__4]
+ .i, z__2.i = z__3.r * work[i__4].i + z__3.i *
+ work[i__4].r;
+ z__1.r = suma.r + z__2.r, z__1.i = suma.i + z__2.i;
+ suma.r = z__1.r, suma.i = z__1.i;
+ d_cnjg(&z__3, &p[jr + j * p_dim1]);
+ i__4 = jr;
+ z__2.r = z__3.r * work[i__4].r - z__3.i * work[i__4]
+ .i, z__2.i = z__3.r * work[i__4].i + z__3.i *
+ work[i__4].r;
+ z__1.r = sumb.r + z__2.r, z__1.i = sumb.i + z__2.i;
+ sumb.r = z__1.r, sumb.i = z__1.i;
+/* L80: */
+ }
+ z__2.r = acoeff * suma.r, z__2.i = acoeff * suma.i;
+ d_cnjg(&z__4, &bcoeff);
+ z__3.r = z__4.r * sumb.r - z__4.i * sumb.i, z__3.i =
+ z__4.r * sumb.i + z__4.i * sumb.r;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ sum.r = z__1.r, sum.i = z__1.i;
+
+/* Form x(j) = - SUM / conjg( a*S(j,j) - b*P(j,j) ) */
+
+/* with scaling and perturbation of the denominator */
+
+ i__3 = j + j * s_dim1;
+ z__3.r = acoeff * s[i__3].r, z__3.i = acoeff * s[i__3].i;
+ i__4 = j + j * p_dim1;
+ z__4.r = bcoeff.r * p[i__4].r - bcoeff.i * p[i__4].i,
+ z__4.i = bcoeff.r * p[i__4].i + bcoeff.i * p[i__4]
+ .r;
+ z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
+ d_cnjg(&z__1, &z__2);
+ d__.r = z__1.r, d__.i = z__1.i;
+ if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs(
+ d__2)) <= dmin__) {
+ z__1.r = dmin__, z__1.i = 0.;
+ d__.r = z__1.r, d__.i = z__1.i;
+ }
+
+ if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs(
+ d__2)) < 1.) {
+ if ((d__1 = sum.r, abs(d__1)) + (d__2 = d_imag(&sum),
+ abs(d__2)) >= bignum * ((d__3 = d__.r, abs(
+ d__3)) + (d__4 = d_imag(&d__), abs(d__4)))) {
+ temp = 1. / ((d__1 = sum.r, abs(d__1)) + (d__2 =
+ d_imag(&sum), abs(d__2)));
+ i__3 = j - 1;
+ for (jr = je; jr <= i__3; ++jr) {
+ i__4 = jr;
+ i__5 = jr;
+ z__1.r = temp * work[i__5].r, z__1.i = temp *
+ work[i__5].i;
+ work[i__4].r = z__1.r, work[i__4].i = z__1.i;
+/* L90: */
+ }
+ xmax = temp * xmax;
+ z__1.r = temp * sum.r, z__1.i = temp * sum.i;
+ sum.r = z__1.r, sum.i = z__1.i;
+ }
+ }
+ i__3 = j;
+ z__2.r = -sum.r, z__2.i = -sum.i;
+ zladiv_(&z__1, &z__2, &d__);
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* Computing MAX */
+ i__3 = j;
+ d__3 = xmax, d__4 = (d__1 = work[i__3].r, abs(d__1)) + (
+ d__2 = d_imag(&work[j]), abs(d__2));
+ xmax = max(d__3,d__4);
+/* L100: */
+ }
+
+/* Back transform eigenvector if HOWMNY='B'. */
+
+ if (ilback) {
+ i__2 = *n + 1 - je;
+ zgemv_("N", n, &i__2, &c_b2, &vl[je * vl_dim1 + 1], ldvl,
+ &work[je], &c__1, &c_b1, &work[*n + 1], &c__1);
+ isrc = 2;
+ ibeg = 1;
+ } else {
+ isrc = 1;
+ ibeg = je;
+ }
+
+/* Copy and scale eigenvector into column of VL */
+
+ xmax = 0.;
+ i__2 = *n;
+ for (jr = ibeg; jr <= i__2; ++jr) {
+/* Computing MAX */
+ i__3 = (isrc - 1) * *n + jr;
+ d__3 = xmax, d__4 = (d__1 = work[i__3].r, abs(d__1)) + (
+ d__2 = d_imag(&work[(isrc - 1) * *n + jr]), abs(
+ d__2));
+ xmax = max(d__3,d__4);
+/* L110: */
+ }
+
+ if (xmax > safmin) {
+ temp = 1. / xmax;
+ i__2 = *n;
+ for (jr = ibeg; jr <= i__2; ++jr) {
+ i__3 = jr + ieig * vl_dim1;
+ i__4 = (isrc - 1) * *n + jr;
+ z__1.r = temp * work[i__4].r, z__1.i = temp * work[
+ i__4].i;
+ vl[i__3].r = z__1.r, vl[i__3].i = z__1.i;
+/* L120: */
+ }
+ } else {
+ ibeg = *n + 1;
+ }
+
+ i__2 = ibeg - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = jr + ieig * vl_dim1;
+ vl[i__3].r = 0., vl[i__3].i = 0.;
+/* L130: */
+ }
+
+ }
+L140:
+ ;
+ }
+ }
+
+/* Right eigenvectors */
+
+ if (compr) {
+ ieig = im + 1;
+
+/* Main loop over eigenvalues */
+
+ for (je = *n; je >= 1; --je) {
+ if (ilall) {
+ ilcomp = TRUE_;
+ } else {
+ ilcomp = select[je];
+ }
+ if (ilcomp) {
+ --ieig;
+
+ i__1 = je + je * s_dim1;
+ i__2 = je + je * p_dim1;
+ if ((d__2 = s[i__1].r, abs(d__2)) + (d__3 = d_imag(&s[je + je
+ * s_dim1]), abs(d__3)) <= safmin && (d__1 = p[i__2].r,
+ abs(d__1)) <= safmin) {
+
+/* Singular matrix pencil -- return unit eigenvector */
+
+ i__1 = *n;
+ for (jr = 1; jr <= i__1; ++jr) {
+ i__2 = jr + ieig * vr_dim1;
+ vr[i__2].r = 0., vr[i__2].i = 0.;
+/* L150: */
+ }
+ i__1 = ieig + ieig * vr_dim1;
+ vr[i__1].r = 1., vr[i__1].i = 0.;
+ goto L250;
+ }
+
+/* Non-singular eigenvalue: */
+/* Compute coefficients a and b in */
+
+/* ( a A - b B ) x = 0 */
+
+/* Computing MAX */
+ i__1 = je + je * s_dim1;
+ i__2 = je + je * p_dim1;
+ d__4 = ((d__2 = s[i__1].r, abs(d__2)) + (d__3 = d_imag(&s[je
+ + je * s_dim1]), abs(d__3))) * ascale, d__5 = (d__1 =
+ p[i__2].r, abs(d__1)) * bscale, d__4 = max(d__4,d__5);
+ temp = 1. / max(d__4,safmin);
+ i__1 = je + je * s_dim1;
+ z__2.r = temp * s[i__1].r, z__2.i = temp * s[i__1].i;
+ z__1.r = ascale * z__2.r, z__1.i = ascale * z__2.i;
+ salpha.r = z__1.r, salpha.i = z__1.i;
+ i__1 = je + je * p_dim1;
+ sbeta = temp * p[i__1].r * bscale;
+ acoeff = sbeta * ascale;
+ z__1.r = bscale * salpha.r, z__1.i = bscale * salpha.i;
+ bcoeff.r = z__1.r, bcoeff.i = z__1.i;
+
+/* Scale to avoid underflow */
+
+ lsa = abs(sbeta) >= safmin && abs(acoeff) < small;
+ lsb = (d__1 = salpha.r, abs(d__1)) + (d__2 = d_imag(&salpha),
+ abs(d__2)) >= safmin && (d__3 = bcoeff.r, abs(d__3))
+ + (d__4 = d_imag(&bcoeff), abs(d__4)) < small;
+
+ scale = 1.;
+ if (lsa) {
+ scale = small / abs(sbeta) * min(anorm,big);
+ }
+ if (lsb) {
+/* Computing MAX */
+ d__3 = scale, d__4 = small / ((d__1 = salpha.r, abs(d__1))
+ + (d__2 = d_imag(&salpha), abs(d__2))) * min(
+ bnorm,big);
+ scale = max(d__3,d__4);
+ }
+ if (lsa || lsb) {
+/* Computing MIN */
+/* Computing MAX */
+ d__5 = 1., d__6 = abs(acoeff), d__5 = max(d__5,d__6),
+ d__6 = (d__1 = bcoeff.r, abs(d__1)) + (d__2 =
+ d_imag(&bcoeff), abs(d__2));
+ d__3 = scale, d__4 = 1. / (safmin * max(d__5,d__6));
+ scale = min(d__3,d__4);
+ if (lsa) {
+ acoeff = ascale * (scale * sbeta);
+ } else {
+ acoeff = scale * acoeff;
+ }
+ if (lsb) {
+ z__2.r = scale * salpha.r, z__2.i = scale * salpha.i;
+ z__1.r = bscale * z__2.r, z__1.i = bscale * z__2.i;
+ bcoeff.r = z__1.r, bcoeff.i = z__1.i;
+ } else {
+ z__1.r = scale * bcoeff.r, z__1.i = scale * bcoeff.i;
+ bcoeff.r = z__1.r, bcoeff.i = z__1.i;
+ }
+ }
+
+ acoefa = abs(acoeff);
+ bcoefa = (d__1 = bcoeff.r, abs(d__1)) + (d__2 = d_imag(&
+ bcoeff), abs(d__2));
+ xmax = 1.;
+ i__1 = *n;
+ for (jr = 1; jr <= i__1; ++jr) {
+ i__2 = jr;
+ work[i__2].r = 0., work[i__2].i = 0.;
+/* L160: */
+ }
+ i__1 = je;
+ work[i__1].r = 1., work[i__1].i = 0.;
+/* Computing MAX */
+ d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm,
+ d__1 = max(d__1,d__2);
+ dmin__ = max(d__1,safmin);
+
+/* Triangular solve of (a A - b B) x = 0 (columnwise) */
+
+/* WORK(1:j-1) contains sums w, */
+/* WORK(j+1:JE) contains x */
+
+ i__1 = je - 1;
+ for (jr = 1; jr <= i__1; ++jr) {
+ i__2 = jr;
+ i__3 = jr + je * s_dim1;
+ z__2.r = acoeff * s[i__3].r, z__2.i = acoeff * s[i__3].i;
+ i__4 = jr + je * p_dim1;
+ z__3.r = bcoeff.r * p[i__4].r - bcoeff.i * p[i__4].i,
+ z__3.i = bcoeff.r * p[i__4].i + bcoeff.i * p[i__4]
+ .r;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L170: */
+ }
+ i__1 = je;
+ work[i__1].r = 1., work[i__1].i = 0.;
+
+ for (j = je - 1; j >= 1; --j) {
+
+/* Form x(j) := - w(j) / d */
+/* with scaling and perturbation of the denominator */
+
+ i__1 = j + j * s_dim1;
+ z__2.r = acoeff * s[i__1].r, z__2.i = acoeff * s[i__1].i;
+ i__2 = j + j * p_dim1;
+ z__3.r = bcoeff.r * p[i__2].r - bcoeff.i * p[i__2].i,
+ z__3.i = bcoeff.r * p[i__2].i + bcoeff.i * p[i__2]
+ .r;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ d__.r = z__1.r, d__.i = z__1.i;
+ if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs(
+ d__2)) <= dmin__) {
+ z__1.r = dmin__, z__1.i = 0.;
+ d__.r = z__1.r, d__.i = z__1.i;
+ }
+
+ if ((d__1 = d__.r, abs(d__1)) + (d__2 = d_imag(&d__), abs(
+ d__2)) < 1.) {
+ i__1 = j;
+ if ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(
+ &work[j]), abs(d__2)) >= bignum * ((d__3 =
+ d__.r, abs(d__3)) + (d__4 = d_imag(&d__), abs(
+ d__4)))) {
+ i__1 = j;
+ temp = 1. / ((d__1 = work[i__1].r, abs(d__1)) + (
+ d__2 = d_imag(&work[j]), abs(d__2)));
+ i__1 = je;
+ for (jr = 1; jr <= i__1; ++jr) {
+ i__2 = jr;
+ i__3 = jr;
+ z__1.r = temp * work[i__3].r, z__1.i = temp *
+ work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L180: */
+ }
+ }
+ }
+
+ i__1 = j;
+ i__2 = j;
+ z__2.r = -work[i__2].r, z__2.i = -work[i__2].i;
+ zladiv_(&z__1, &z__2, &d__);
+ work[i__1].r = z__1.r, work[i__1].i = z__1.i;
+
+ if (j > 1) {
+
+/* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling */
+
+ i__1 = j;
+ if ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(
+ &work[j]), abs(d__2)) > 1.) {
+ i__1 = j;
+ temp = 1. / ((d__1 = work[i__1].r, abs(d__1)) + (
+ d__2 = d_imag(&work[j]), abs(d__2)));
+ if (acoefa * rwork[j] + bcoefa * rwork[*n + j] >=
+ bignum * temp) {
+ i__1 = je;
+ for (jr = 1; jr <= i__1; ++jr) {
+ i__2 = jr;
+ i__3 = jr;
+ z__1.r = temp * work[i__3].r, z__1.i =
+ temp * work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i =
+ z__1.i;
+/* L190: */
+ }
+ }
+ }
+
+ i__1 = j;
+ z__1.r = acoeff * work[i__1].r, z__1.i = acoeff *
+ work[i__1].i;
+ ca.r = z__1.r, ca.i = z__1.i;
+ i__1 = j;
+ z__1.r = bcoeff.r * work[i__1].r - bcoeff.i * work[
+ i__1].i, z__1.i = bcoeff.r * work[i__1].i +
+ bcoeff.i * work[i__1].r;
+ cb.r = z__1.r, cb.i = z__1.i;
+ i__1 = j - 1;
+ for (jr = 1; jr <= i__1; ++jr) {
+ i__2 = jr;
+ i__3 = jr;
+ i__4 = jr + j * s_dim1;
+ z__3.r = ca.r * s[i__4].r - ca.i * s[i__4].i,
+ z__3.i = ca.r * s[i__4].i + ca.i * s[i__4]
+ .r;
+ z__2.r = work[i__3].r + z__3.r, z__2.i = work[
+ i__3].i + z__3.i;
+ i__5 = jr + j * p_dim1;
+ z__4.r = cb.r * p[i__5].r - cb.i * p[i__5].i,
+ z__4.i = cb.r * p[i__5].i + cb.i * p[i__5]
+ .r;
+ z__1.r = z__2.r - z__4.r, z__1.i = z__2.i -
+ z__4.i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L200: */
+ }
+ }
+/* L210: */
+ }
+
+/* Back transform eigenvector if HOWMNY='B'. */
+
+ if (ilback) {
+ zgemv_("N", n, &je, &c_b2, &vr[vr_offset], ldvr, &work[1],
+ &c__1, &c_b1, &work[*n + 1], &c__1);
+ isrc = 2;
+ iend = *n;
+ } else {
+ isrc = 1;
+ iend = je;
+ }
+
+/* Copy and scale eigenvector into column of VR */
+
+ xmax = 0.;
+ i__1 = iend;
+ for (jr = 1; jr <= i__1; ++jr) {
+/* Computing MAX */
+ i__2 = (isrc - 1) * *n + jr;
+ d__3 = xmax, d__4 = (d__1 = work[i__2].r, abs(d__1)) + (
+ d__2 = d_imag(&work[(isrc - 1) * *n + jr]), abs(
+ d__2));
+ xmax = max(d__3,d__4);
+/* L220: */
+ }
+
+ if (xmax > safmin) {
+ temp = 1. / xmax;
+ i__1 = iend;
+ for (jr = 1; jr <= i__1; ++jr) {
+ i__2 = jr + ieig * vr_dim1;
+ i__3 = (isrc - 1) * *n + jr;
+ z__1.r = temp * work[i__3].r, z__1.i = temp * work[
+ i__3].i;
+ vr[i__2].r = z__1.r, vr[i__2].i = z__1.i;
+/* L230: */
+ }
+ } else {
+ iend = 0;
+ }
+
+ i__1 = *n;
+ for (jr = iend + 1; jr <= i__1; ++jr) {
+ i__2 = jr + ieig * vr_dim1;
+ vr[i__2].r = 0., vr[i__2].i = 0.;
+/* L240: */
+ }
+
+ }
+L250:
+ ;
+ }
+ }
+
+ return 0;
+
+/* End of ZTGEVC */
+
+} /* ztgevc_ */
diff --git a/SRC/ztgex2.c b/SRC/ztgex2.c
new file mode 100644
index 0000000..d85191c
--- /dev/null
+++ b/SRC/ztgex2.c
@@ -0,0 +1,376 @@
+/* ztgex2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* Subroutine */ int ztgex2_(logical *wantq, logical *wantz, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *q, integer *ldq, doublecomplex *z__, integer *ldz,
+ integer *j1, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
+ z_offset, i__1, i__2, i__3;
+ doublereal d__1;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal), z_abs(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ doublecomplex f, g;
+ integer i__, m;
+ doublecomplex s[4] /* was [2][2] */, t[4] /* was [2][2] */;
+ doublereal cq, sa, sb, cz;
+ doublecomplex sq;
+ doublereal ss, ws;
+ doublecomplex sz;
+ doublereal eps, sum;
+ logical weak;
+ doublecomplex cdum, work[8];
+ extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *);
+ doublereal scale;
+ extern doublereal dlamch_(char *);
+ logical dtrong;
+ doublereal thresh;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlartg_(doublecomplex *, doublecomplex *, doublereal *,
+ doublecomplex *, doublecomplex *);
+ doublereal smlnum;
+ extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTGEX2 swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22) */
+/* in an upper triangular matrix pair (A, B) by an unitary equivalence */
+/* transformation. */
+
+/* (A, B) must be in generalized Schur canonical form, that is, A and */
+/* B are both upper triangular. */
+
+/* Optionally, the matrices Q and Z of generalized Schur vectors are */
+/* updated. */
+
+/* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' */
+/* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' */
+
+
+/* Arguments */
+/* ========= */
+
+/* WANTQ (input) LOGICAL */
+/* .TRUE. : update the left transformation matrix Q; */
+/* .FALSE.: do not update Q. */
+
+/* WANTZ (input) LOGICAL */
+/* .TRUE. : update the right transformation matrix Z; */
+/* .FALSE.: do not update Z. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) COMPLEX*16 arrays, dimensions (LDA,N) */
+/* On entry, the matrix A in the pair (A, B). */
+/* On exit, the updated matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 arrays, dimensions (LDB,N) */
+/* On entry, the matrix B in the pair (A, B). */
+/* On exit, the updated matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Q (input/output) COMPLEX*16 array, dimension (LDZ,N) */
+/* If WANTQ = .TRUE, on entry, the unitary matrix Q. On exit, */
+/* the updated matrix Q. */
+/* Not referenced if WANTQ = .FALSE.. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= 1; */
+/* If WANTQ = .TRUE., LDQ >= N. */
+
+/* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) */
+/* If WANTZ = .TRUE, on entry, the unitary matrix Z. On exit, */
+/* the updated matrix Z. */
+/* Not referenced if WANTZ = .FALSE.. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1; */
+/* If WANTZ = .TRUE., LDZ >= N. */
+
+/* J1 (input) INTEGER */
+/* The index to the first block (A11, B11). */
+
+/* INFO (output) INTEGER */
+/* =0: Successful exit. */
+/* =1: The transformed matrix pair (A, B) would be too far */
+/* from generalized Schur form; the problem is ill- */
+/* conditioned. */
+
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* In the current code both weak and strong stability tests are */
+/* performed. The user can omit the strong stability test by changing */
+/* the internal logical parameter WANDS to .FALSE.. See ref. [2] for */
+/* details. */
+
+/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
+/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
+/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
+/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
+
+/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
+/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
+/* Estimation: Theory, Algorithms and Software, Report UMINF-94.04, */
+/* Department of Computing Science, Umea University, S-901 87 Umea, */
+/* Sweden, 1994. Also as LAPACK Working Note 87. To appear in */
+/* Numerical Algorithms, 1996. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n <= 1) {
+ return 0;
+ }
+
+ m = 2;
+ weak = FALSE_;
+ dtrong = FALSE_;
+
+/* Make a local copy of selected block in (A, B) */
+
+ zlacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, s, &c__2);
+ zlacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, t, &c__2);
+
+/* Compute the threshold for testing the acceptance of swapping. */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S") / eps;
+ scale = 0.;
+ sum = 1.;
+ zlacpy_("Full", &m, &m, s, &c__2, work, &m);
+ zlacpy_("Full", &m, &m, t, &c__2, &work[m * m], &m);
+ i__1 = (m << 1) * m;
+ zlassq_(&i__1, work, &c__1, &scale, &sum);
+ sa = scale * sqrt(sum);
+/* Computing MAX */
+ d__1 = eps * 10. * sa;
+ thresh = max(d__1,smlnum);
+
+/* Compute unitary QL and RQ that swap 1-by-1 and 1-by-1 blocks */
+/* using Givens rotations and perform the swap tentatively. */
+
+ z__2.r = s[3].r * t[0].r - s[3].i * t[0].i, z__2.i = s[3].r * t[0].i + s[
+ 3].i * t[0].r;
+ z__3.r = t[3].r * s[0].r - t[3].i * s[0].i, z__3.i = t[3].r * s[0].i + t[
+ 3].i * s[0].r;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ f.r = z__1.r, f.i = z__1.i;
+ z__2.r = s[3].r * t[2].r - s[3].i * t[2].i, z__2.i = s[3].r * t[2].i + s[
+ 3].i * t[2].r;
+ z__3.r = t[3].r * s[2].r - t[3].i * s[2].i, z__3.i = t[3].r * s[2].i + t[
+ 3].i * s[2].r;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ g.r = z__1.r, g.i = z__1.i;
+ sa = z_abs(&s[3]);
+ sb = z_abs(&t[3]);
+ zlartg_(&g, &f, &cz, &sz, &cdum);
+ z__1.r = -sz.r, z__1.i = -sz.i;
+ sz.r = z__1.r, sz.i = z__1.i;
+ d_cnjg(&z__1, &sz);
+ zrot_(&c__2, s, &c__1, &s[2], &c__1, &cz, &z__1);
+ d_cnjg(&z__1, &sz);
+ zrot_(&c__2, t, &c__1, &t[2], &c__1, &cz, &z__1);
+ if (sa >= sb) {
+ zlartg_(s, &s[1], &cq, &sq, &cdum);
+ } else {
+ zlartg_(t, &t[1], &cq, &sq, &cdum);
+ }
+ zrot_(&c__2, s, &c__2, &s[1], &c__2, &cq, &sq);
+ zrot_(&c__2, t, &c__2, &t[1], &c__2, &cq, &sq);
+
+/* Weak stability test: |S21| + |T21| <= O(EPS F-norm((S, T))) */
+
+ ws = z_abs(&s[1]) + z_abs(&t[1]);
+ weak = ws <= thresh;
+ if (! weak) {
+ goto L20;
+ }
+
+ if (TRUE_) {
+
+/* Strong stability test: */
+/* F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A, B))) */
+
+ zlacpy_("Full", &m, &m, s, &c__2, work, &m);
+ zlacpy_("Full", &m, &m, t, &c__2, &work[m * m], &m);
+ d_cnjg(&z__2, &sz);
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ zrot_(&c__2, work, &c__1, &work[2], &c__1, &cz, &z__1);
+ d_cnjg(&z__2, &sz);
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ zrot_(&c__2, &work[4], &c__1, &work[6], &c__1, &cz, &z__1);
+ z__1.r = -sq.r, z__1.i = -sq.i;
+ zrot_(&c__2, work, &c__2, &work[1], &c__2, &cq, &z__1);
+ z__1.r = -sq.r, z__1.i = -sq.i;
+ zrot_(&c__2, &work[4], &c__2, &work[5], &c__2, &cq, &z__1);
+ for (i__ = 1; i__ <= 2; ++i__) {
+ i__1 = i__ - 1;
+ i__2 = i__ - 1;
+ i__3 = *j1 + i__ - 1 + *j1 * a_dim1;
+ z__1.r = work[i__2].r - a[i__3].r, z__1.i = work[i__2].i - a[i__3]
+ .i;
+ work[i__1].r = z__1.r, work[i__1].i = z__1.i;
+ i__1 = i__ + 1;
+ i__2 = i__ + 1;
+ i__3 = *j1 + i__ - 1 + (*j1 + 1) * a_dim1;
+ z__1.r = work[i__2].r - a[i__3].r, z__1.i = work[i__2].i - a[i__3]
+ .i;
+ work[i__1].r = z__1.r, work[i__1].i = z__1.i;
+ i__1 = i__ + 3;
+ i__2 = i__ + 3;
+ i__3 = *j1 + i__ - 1 + *j1 * b_dim1;
+ z__1.r = work[i__2].r - b[i__3].r, z__1.i = work[i__2].i - b[i__3]
+ .i;
+ work[i__1].r = z__1.r, work[i__1].i = z__1.i;
+ i__1 = i__ + 5;
+ i__2 = i__ + 5;
+ i__3 = *j1 + i__ - 1 + (*j1 + 1) * b_dim1;
+ z__1.r = work[i__2].r - b[i__3].r, z__1.i = work[i__2].i - b[i__3]
+ .i;
+ work[i__1].r = z__1.r, work[i__1].i = z__1.i;
+/* L10: */
+ }
+ scale = 0.;
+ sum = 1.;
+ i__1 = (m << 1) * m;
+ zlassq_(&i__1, work, &c__1, &scale, &sum);
+ ss = scale * sqrt(sum);
+ dtrong = ss <= thresh;
+ if (! dtrong) {
+ goto L20;
+ }
+ }
+
+/* If the swap is accepted ("weakly" and "strongly"), apply the */
+/* equivalence transformations to the original matrix pair (A,B) */
+
+ i__1 = *j1 + 1;
+ d_cnjg(&z__1, &sz);
+ zrot_(&i__1, &a[*j1 * a_dim1 + 1], &c__1, &a[(*j1 + 1) * a_dim1 + 1], &
+ c__1, &cz, &z__1);
+ i__1 = *j1 + 1;
+ d_cnjg(&z__1, &sz);
+ zrot_(&i__1, &b[*j1 * b_dim1 + 1], &c__1, &b[(*j1 + 1) * b_dim1 + 1], &
+ c__1, &cz, &z__1);
+ i__1 = *n - *j1 + 1;
+ zrot_(&i__1, &a[*j1 + *j1 * a_dim1], lda, &a[*j1 + 1 + *j1 * a_dim1], lda,
+ &cq, &sq);
+ i__1 = *n - *j1 + 1;
+ zrot_(&i__1, &b[*j1 + *j1 * b_dim1], ldb, &b[*j1 + 1 + *j1 * b_dim1], ldb,
+ &cq, &sq);
+
+/* Set N1 by N2 (2,1) blocks to 0 */
+
+ i__1 = *j1 + 1 + *j1 * a_dim1;
+ a[i__1].r = 0., a[i__1].i = 0.;
+ i__1 = *j1 + 1 + *j1 * b_dim1;
+ b[i__1].r = 0., b[i__1].i = 0.;
+
+/* Accumulate transformations into Q and Z if requested. */
+
+ if (*wantz) {
+ d_cnjg(&z__1, &sz);
+ zrot_(n, &z__[*j1 * z_dim1 + 1], &c__1, &z__[(*j1 + 1) * z_dim1 + 1],
+ &c__1, &cz, &z__1);
+ }
+ if (*wantq) {
+ d_cnjg(&z__1, &sq);
+ zrot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[(*j1 + 1) * q_dim1 + 1], &
+ c__1, &cq, &z__1);
+ }
+
+/* Exit with INFO = 0 if swap was successfully performed. */
+
+ return 0;
+
+/* Exit with INFO = 1 if swap was rejected. */
+
+L20:
+ *info = 1;
+ return 0;
+
+/* End of ZTGEX2 */
+
+} /* ztgex2_ */
diff --git a/SRC/ztgexc.c b/SRC/ztgexc.c
new file mode 100644
index 0000000..b6c5e1d
--- /dev/null
+++ b/SRC/ztgexc.c
@@ -0,0 +1,248 @@
+/* ztgexc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ztgexc_(logical *wantq, logical *wantz, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *q, integer *ldq, doublecomplex *z__, integer *ldz,
+ integer *ifst, integer *ilst, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
+ z_offset, i__1;
+
+ /* Local variables */
+ integer here;
+ extern /* Subroutine */ int ztgex2_(logical *, logical *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ integer *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTGEXC reorders the generalized Schur decomposition of a complex */
+/* matrix pair (A,B), using an unitary equivalence transformation */
+/* (A, B) := Q * (A, B) * Z', so that the diagonal block of (A, B) with */
+/* row index IFST is moved to row ILST. */
+
+/* (A, B) must be in generalized Schur canonical form, that is, A and */
+/* B are both upper triangular. */
+
+/* Optionally, the matrices Q and Z of generalized Schur vectors are */
+/* updated. */
+
+/* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' */
+/* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' */
+
+/* Arguments */
+/* ========= */
+
+/* WANTQ (input) LOGICAL */
+/* .TRUE. : update the left transformation matrix Q; */
+/* .FALSE.: do not update Q. */
+
+/* WANTZ (input) LOGICAL */
+/* .TRUE. : update the right transformation matrix Z; */
+/* .FALSE.: do not update Z. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the upper triangular matrix A in the pair (A, B). */
+/* On exit, the updated matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,N) */
+/* On entry, the upper triangular matrix B in the pair (A, B). */
+/* On exit, the updated matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Q (input/output) COMPLEX*16 array, dimension (LDZ,N) */
+/* On entry, if WANTQ = .TRUE., the unitary matrix Q. */
+/* On exit, the updated matrix Q. */
+/* If WANTQ = .FALSE., Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= 1; */
+/* If WANTQ = .TRUE., LDQ >= N. */
+
+/* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) */
+/* On entry, if WANTZ = .TRUE., the unitary matrix Z. */
+/* On exit, the updated matrix Z. */
+/* If WANTZ = .FALSE., Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1; */
+/* If WANTZ = .TRUE., LDZ >= N. */
+
+/* IFST (input) INTEGER */
+/* ILST (input/output) INTEGER */
+/* Specify the reordering of the diagonal blocks of (A, B). */
+/* The block with row index IFST is moved to row ILST, by a */
+/* sequence of swapping between adjacent blocks. */
+
+/* INFO (output) INTEGER */
+/* =0: Successful exit. */
+/* <0: if INFO = -i, the i-th argument had an illegal value. */
+/* =1: The transformed matrix pair (A, B) would be too far */
+/* from generalized Schur form; the problem is ill- */
+/* conditioned. (A, B) may have been partially reordered, */
+/* and ILST points to the first row of the current */
+/* position of the block being moved. */
+
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
+/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
+/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
+/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
+
+/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
+/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
+/* Estimation: Theory, Algorithms and Software, Report */
+/* UMINF - 94.04, Department of Computing Science, Umea University, */
+/* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. */
+/* To appear in Numerical Algorithms, 1996. */
+
+/* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
+/* for Solving the Generalized Sylvester Equation and Estimating the */
+/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
+/* Department of Computing Science, Umea University, S-901 87 Umea, */
+/* Sweden, December 1993, Revised April 1994, Also as LAPACK working */
+/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, */
+/* 1996. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test input arguments. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -7;
+ } else if (*ldq < 1 || *wantq && *ldq < max(1,*n)) {
+ *info = -9;
+ } else if (*ldz < 1 || *wantz && *ldz < max(1,*n)) {
+ *info = -11;
+ } else if (*ifst < 1 || *ifst > *n) {
+ *info = -12;
+ } else if (*ilst < 1 || *ilst > *n) {
+ *info = -13;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTGEXC", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 1) {
+ return 0;
+ }
+ if (*ifst == *ilst) {
+ return 0;
+ }
+
+ if (*ifst < *ilst) {
+
+ here = *ifst;
+
+L10:
+
+/* Swap with next one below */
+
+ ztgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[
+ q_offset], ldq, &z__[z_offset], ldz, &here, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ ++here;
+ if (here < *ilst) {
+ goto L10;
+ }
+ --here;
+ } else {
+ here = *ifst - 1;
+
+L20:
+
+/* Swap with next one above */
+
+ ztgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[
+ q_offset], ldq, &z__[z_offset], ldz, &here, info);
+ if (*info != 0) {
+ *ilst = here;
+ return 0;
+ }
+ --here;
+ if (here >= *ilst) {
+ goto L20;
+ }
+ ++here;
+ }
+ *ilst = here;
+ return 0;
+
+/* End of ZTGEXC */
+
+} /* ztgexc_ */
diff --git a/SRC/ztgsen.c b/SRC/ztgsen.c
new file mode 100644
index 0000000..cbff260
--- /dev/null
+++ b/SRC/ztgsen.c
@@ -0,0 +1,766 @@
+/* ztgsen.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ztgsen_(integer *ijob, logical *wantq, logical *wantz,
+ logical *select, integer *n, doublecomplex *a, integer *lda,
+ doublecomplex *b, integer *ldb, doublecomplex *alpha, doublecomplex *
+ beta, doublecomplex *q, integer *ldq, doublecomplex *z__, integer *
+ ldz, integer *m, doublereal *pl, doublereal *pr, doublereal *dif,
+ doublecomplex *work, integer *lwork, integer *iwork, integer *liwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1,
+ z_offset, i__1, i__2, i__3;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), z_abs(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, k, n1, n2, ks, mn2, ijb, kase, ierr;
+ doublereal dsum;
+ logical swap;
+ doublecomplex temp1, temp2;
+ integer isave[3];
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ logical wantd;
+ integer lwmin;
+ logical wantp;
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *);
+ logical wantd1, wantd2;
+ extern doublereal dlamch_(char *);
+ doublereal dscale, rdscal, safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer liwmin;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ ztgexc_(logical *, logical *, integer *, doublecomplex *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *, integer *),
+ zlassq_(integer *, doublecomplex *, integer *, doublereal *,
+ doublereal *);
+ logical lquery;
+ extern /* Subroutine */ int ztgsyl_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, integer *, integer *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTGSEN reorders the generalized Schur decomposition of a complex */
+/* matrix pair (A, B) (in terms of an unitary equivalence trans- */
+/* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues */
+/* appears in the leading diagonal blocks of the pair (A,B). The leading */
+/* columns of Q and Z form unitary bases of the corresponding left and */
+/* right eigenspaces (deflating subspaces). (A, B) must be in */
+/* generalized Schur canonical form, that is, A and B are both upper */
+/* triangular. */
+
+/* ZTGSEN also computes the generalized eigenvalues */
+
+/* w(j)= ALPHA(j) / BETA(j) */
+
+/* of the reordered matrix pair (A, B). */
+
+/* Optionally, the routine computes estimates of reciprocal condition */
+/* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), */
+/* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) */
+/* between the matrix pairs (A11, B11) and (A22,B22) that correspond to */
+/* the selected cluster and the eigenvalues outside the cluster, resp., */
+/* and norms of "projections" onto left and right eigenspaces w.r.t. */
+/* the selected cluster in the (1,1)-block. */
+
+
+/* Arguments */
+/* ========= */
+
+/* IJOB (input) integer */
+/* Specifies whether condition numbers are required for the */
+/* cluster of eigenvalues (PL and PR) or the deflating subspaces */
+/* (Difu and Difl): */
+/* =0: Only reorder w.r.t. SELECT. No extras. */
+/* =1: Reciprocal of norms of "projections" onto left and right */
+/* eigenspaces w.r.t. the selected cluster (PL and PR). */
+/* =2: Upper bounds on Difu and Difl. F-norm-based estimate */
+/* (DIF(1:2)). */
+/* =3: Estimate of Difu and Difl. 1-norm-based estimate */
+/* (DIF(1:2)). */
+/* About 5 times as expensive as IJOB = 2. */
+/* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic */
+/* version to get it all. */
+/* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) */
+
+/* WANTQ (input) LOGICAL */
+/* .TRUE. : update the left transformation matrix Q; */
+/* .FALSE.: do not update Q. */
+
+/* WANTZ (input) LOGICAL */
+/* .TRUE. : update the right transformation matrix Z; */
+/* .FALSE.: do not update Z. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* SELECT specifies the eigenvalues in the selected cluster. To */
+/* select an eigenvalue w(j), SELECT(j) must be set to */
+/* .TRUE.. */
+
+/* N (input) INTEGER */
+/* The order of the matrices A and B. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension(LDA,N) */
+/* On entry, the upper triangular matrix A, in generalized */
+/* Schur canonical form. */
+/* On exit, A is overwritten by the reordered matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension(LDB,N) */
+/* On entry, the upper triangular matrix B, in generalized */
+/* Schur canonical form. */
+/* On exit, B is overwritten by the reordered matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* ALPHA (output) COMPLEX*16 array, dimension (N) */
+/* BETA (output) COMPLEX*16 array, dimension (N) */
+/* The diagonal elements of A and B, respectively, */
+/* when the pair (A,B) has been reduced to generalized Schur */
+/* form. ALPHA(i)/BETA(i) i=1,...,N are the generalized */
+/* eigenvalues. */
+
+/* Q (input/output) COMPLEX*16 array, dimension (LDQ,N) */
+/* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. */
+/* On exit, Q has been postmultiplied by the left unitary */
+/* transformation matrix which reorder (A, B); The leading M */
+/* columns of Q form orthonormal bases for the specified pair of */
+/* left eigenspaces (deflating subspaces). */
+/* If WANTQ = .FALSE., Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= 1. */
+/* If WANTQ = .TRUE., LDQ >= N. */
+
+/* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) */
+/* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. */
+/* On exit, Z has been postmultiplied by the left unitary */
+/* transformation matrix which reorder (A, B); The leading M */
+/* columns of Z form orthonormal bases for the specified pair of */
+/* left eigenspaces (deflating subspaces). */
+/* If WANTZ = .FALSE., Z is not referenced. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= 1. */
+/* If WANTZ = .TRUE., LDZ >= N. */
+
+/* M (output) INTEGER */
+/* The dimension of the specified pair of left and right */
+/* eigenspaces, (deflating subspaces) 0 <= M <= N. */
+
+/* PL (output) DOUBLE PRECISION */
+/* PR (output) DOUBLE PRECISION */
+/* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the */
+/* reciprocal of the norm of "projections" onto left and right */
+/* eigenspace with respect to the selected cluster. */
+/* 0 < PL, PR <= 1. */
+/* If M = 0 or M = N, PL = PR = 1. */
+/* If IJOB = 0, 2 or 3 PL, PR are not referenced. */
+
+/* DIF (output) DOUBLE PRECISION array, dimension (2). */
+/* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. */
+/* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on */
+/* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based */
+/* estimates of Difu and Difl, computed using reversed */
+/* communication with ZLACN2. */
+/* If M = 0 or N, DIF(1:2) = F-norm([A, B]). */
+/* If IJOB = 0 or 1, DIF is not referenced. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* IF IJOB = 0, WORK is not referenced. Otherwise, */
+/* on exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= 1 */
+/* If IJOB = 1, 2 or 4, LWORK >= 2*M*(N-M) */
+/* If IJOB = 3 or 5, LWORK >= 4*M*(N-M) */
+
+/* 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. */
+
+/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
+/* IF IJOB = 0, IWORK is not referenced. Otherwise, */
+/* on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. LIWORK >= 1. */
+/* If IJOB = 1, 2 or 4, LIWORK >= N+2; */
+/* If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M)); */
+
+/* If LIWORK = -1, then a workspace query is assumed; the */
+/* routine only calculates the optimal size of the IWORK array, */
+/* returns this value as the first entry of the IWORK array, and */
+/* no error message related to LIWORK is issued by XERBLA. */
+
+/* INFO (output) INTEGER */
+/* =0: Successful exit. */
+/* <0: If INFO = -i, the i-th argument had an illegal value. */
+/* =1: Reordering of (A, B) failed because the transformed */
+/* matrix pair (A, B) would be too far from generalized */
+/* Schur form; the problem is very ill-conditioned. */
+/* (A, B) may have been partially reordered. */
+/* If requested, 0 is returned in DIF(*), PL and PR. */
+
+
+/* Further Details */
+/* =============== */
+
+/* ZTGSEN first collects the selected eigenvalues by computing unitary */
+/* U and W that move them to the top left corner of (A, B). In other */
+/* words, the selected eigenvalues are the eigenvalues of (A11, B11) in */
+
+/* U'*(A, B)*W = (A11 A12) (B11 B12) n1 */
+/* ( 0 A22),( 0 B22) n2 */
+/* n1 n2 n1 n2 */
+
+/* where N = n1+n2 and U' means the conjugate transpose of U. The first */
+/* n1 columns of U and W span the specified pair of left and right */
+/* eigenspaces (deflating subspaces) of (A, B). */
+
+/* If (A, B) has been obtained from the generalized real Schur */
+/* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the */
+/* reordered generalized Schur form of (C, D) is given by */
+
+/* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)', */
+
+/* and the first n1 columns of Q*U and Z*W span the corresponding */
+/* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). */
+
+/* Note that if the selected eigenvalue is sufficiently ill-conditioned, */
+/* then its value may differ significantly from its value before */
+/* reordering. */
+
+/* The reciprocal condition numbers of the left and right eigenspaces */
+/* spanned by the first n1 columns of U and W (or Q*U and Z*W) may */
+/* be returned in DIF(1:2), corresponding to Difu and Difl, resp. */
+
+/* The Difu and Difl are defined as: */
+
+/* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu ) */
+/* and */
+/* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], */
+
+/* where sigma-min(Zu) is the smallest singular value of the */
+/* (2*n1*n2)-by-(2*n1*n2) matrix */
+
+/* Zu = [ kron(In2, A11) -kron(A22', In1) ] */
+/* [ kron(In2, B11) -kron(B22', In1) ]. */
+
+/* Here, Inx is the identity matrix of size nx and A22' is the */
+/* transpose of A22. kron(X, Y) is the Kronecker product between */
+/* the matrices X and Y. */
+
+/* When DIF(2) is small, small changes in (A, B) can cause large changes */
+/* in the deflating subspace. An approximate (asymptotic) bound on the */
+/* maximum angular error in the computed deflating subspaces is */
+
+/* EPS * norm((A, B)) / DIF(2), */
+
+/* where EPS is the machine precision. */
+
+/* The reciprocal norm of the projectors on the left and right */
+/* eigenspaces associated with (A11, B11) may be returned in PL and PR. */
+/* They are computed as follows. First we compute L and R so that */
+/* P*(A, B)*Q is block diagonal, where */
+
+/* P = ( I -L ) n1 Q = ( I R ) n1 */
+/* ( 0 I ) n2 and ( 0 I ) n2 */
+/* n1 n2 n1 n2 */
+
+/* and (L, R) is the solution to the generalized Sylvester equation */
+
+/* A11*R - L*A22 = -A12 */
+/* B11*R - L*B22 = -B12 */
+
+/* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). */
+/* An approximate (asymptotic) bound on the average absolute error of */
+/* the selected eigenvalues is */
+
+/* EPS * norm((A, B)) / PL. */
+
+/* There are also global error bounds which valid for perturbations up */
+/* to a certain restriction: A lower bound (x) on the smallest */
+/* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and */
+/* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), */
+/* (i.e. (A + E, B + F), is */
+
+/* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)). */
+
+/* An approximate bound on x can be computed from DIF(1:2), PL and PR. */
+
+/* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed */
+/* (L', R') and unperturbed (L, R) left and right deflating subspaces */
+/* associated with the selected cluster in the (1,1)-blocks can be */
+/* bounded as */
+
+/* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) */
+/* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) */
+
+/* See LAPACK User's Guide section 4.11 or the following references */
+/* for more information. */
+
+/* Note that if the default method for computing the Frobenius-norm- */
+/* based estimate DIF is not wanted (see ZLATDF), then the parameter */
+/* IDIFJB (see below) should be changed from 3 to 4 (routine ZLATDF */
+/* (IJOB = 2 will be used)). See ZTGSYL for more details. */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* References */
+/* ========== */
+
+/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
+/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
+/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
+/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
+
+/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
+/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
+/* Estimation: Theory, Algorithms and Software, Report */
+/* UMINF - 94.04, Department of Computing Science, Umea University, */
+/* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. */
+/* To appear in Numerical Algorithms, 1996. */
+
+/* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
+/* for Solving the Generalized Sylvester Equation and Estimating the */
+/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
+/* Department of Computing Science, Umea University, S-901 87 Umea, */
+/* Sweden, December 1993, Revised April 1994, Also as LAPACK working */
+/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, */
+/* 1996. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ --select;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alpha;
+ --beta;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --dif;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1 || *liwork == -1;
+
+ if (*ijob < 0 || *ijob > 5) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldq < 1 || *wantq && *ldq < *n) {
+ *info = -13;
+ } else if (*ldz < 1 || *wantz && *ldz < *n) {
+ *info = -15;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTGSEN", &i__1);
+ return 0;
+ }
+
+ ierr = 0;
+
+ wantp = *ijob == 1 || *ijob >= 4;
+ wantd1 = *ijob == 2 || *ijob == 4;
+ wantd2 = *ijob == 3 || *ijob == 5;
+ wantd = wantd1 || wantd2;
+
+/* Set M to the dimension of the specified pair of deflating */
+/* subspaces. */
+
+ *m = 0;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = k;
+ i__3 = k + k * a_dim1;
+ alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
+ i__2 = k;
+ i__3 = k + k * b_dim1;
+ beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
+ if (k < *n) {
+ if (select[k]) {
+ ++(*m);
+ }
+ } else {
+ if (select[*n]) {
+ ++(*m);
+ }
+ }
+/* L10: */
+ }
+
+ if (*ijob == 1 || *ijob == 2 || *ijob == 4) {
+/* Computing MAX */
+ i__1 = 1, i__2 = (*m << 1) * (*n - *m);
+ lwmin = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = *n + 2;
+ liwmin = max(i__1,i__2);
+ } else if (*ijob == 3 || *ijob == 5) {
+/* Computing MAX */
+ i__1 = 1, i__2 = (*m << 2) * (*n - *m);
+ lwmin = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = (*m << 1) * (*n - *m), i__1 = max(i__1,i__2), i__2 =
+ *n + 2;
+ liwmin = max(i__1,i__2);
+ } else {
+ lwmin = 1;
+ liwmin = 1;
+ }
+
+ work[1].r = (doublereal) lwmin, work[1].i = 0.;
+ iwork[1] = liwmin;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -21;
+ } else if (*liwork < liwmin && ! lquery) {
+ *info = -23;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTGSEN", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*m == *n || *m == 0) {
+ if (wantp) {
+ *pl = 1.;
+ *pr = 1.;
+ }
+ if (wantd) {
+ dscale = 0.;
+ dsum = 1.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ zlassq_(n, &a[i__ * a_dim1 + 1], &c__1, &dscale, &dsum);
+ zlassq_(n, &b[i__ * b_dim1 + 1], &c__1, &dscale, &dsum);
+/* L20: */
+ }
+ dif[1] = dscale * sqrt(dsum);
+ dif[2] = dif[1];
+ }
+ goto L70;
+ }
+
+/* Get machine constant */
+
+ safmin = dlamch_("S");
+
+/* Collect the selected blocks at the top-left corner of (A, B). */
+
+ ks = 0;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ swap = select[k];
+ if (swap) {
+ ++ks;
+
+/* Swap the K-th block to position KS. Compute unitary Q */
+/* and Z that will swap adjacent diagonal blocks in (A, B). */
+
+ if (k != ks) {
+ ztgexc_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb,
+ &q[q_offset], ldq, &z__[z_offset], ldz, &k, &ks, &
+ ierr);
+ }
+
+ if (ierr > 0) {
+
+/* Swap is rejected: exit. */
+
+ *info = 1;
+ if (wantp) {
+ *pl = 0.;
+ *pr = 0.;
+ }
+ if (wantd) {
+ dif[1] = 0.;
+ dif[2] = 0.;
+ }
+ goto L70;
+ }
+ }
+/* L30: */
+ }
+ if (wantp) {
+
+/* Solve generalized Sylvester equation for R and L: */
+/* A11 * R - L * A22 = A12 */
+/* B11 * R - L * B22 = B12 */
+
+ n1 = *m;
+ n2 = *n - *m;
+ i__ = n1 + 1;
+ zlacpy_("Full", &n1, &n2, &a[i__ * a_dim1 + 1], lda, &work[1], &n1);
+ zlacpy_("Full", &n1, &n2, &b[i__ * b_dim1 + 1], ldb, &work[n1 * n2 +
+ 1], &n1);
+ ijb = 0;
+ i__1 = *lwork - (n1 << 1) * n2;
+ ztgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ * a_dim1]
+, lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ + i__ *
+ b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &dif[1], &
+ work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &ierr);
+
+/* Estimate the reciprocal of norms of "projections" onto */
+/* left and right eigenspaces */
+
+ rdscal = 0.;
+ dsum = 1.;
+ i__1 = n1 * n2;
+ zlassq_(&i__1, &work[1], &c__1, &rdscal, &dsum);
+ *pl = rdscal * sqrt(dsum);
+ if (*pl == 0.) {
+ *pl = 1.;
+ } else {
+ *pl = dscale / (sqrt(dscale * dscale / *pl + *pl) * sqrt(*pl));
+ }
+ rdscal = 0.;
+ dsum = 1.;
+ i__1 = n1 * n2;
+ zlassq_(&i__1, &work[n1 * n2 + 1], &c__1, &rdscal, &dsum);
+ *pr = rdscal * sqrt(dsum);
+ if (*pr == 0.) {
+ *pr = 1.;
+ } else {
+ *pr = dscale / (sqrt(dscale * dscale / *pr + *pr) * sqrt(*pr));
+ }
+ }
+ if (wantd) {
+
+/* Compute estimates Difu and Difl. */
+
+ if (wantd1) {
+ n1 = *m;
+ n2 = *n - *m;
+ i__ = n1 + 1;
+ ijb = 3;
+
+/* Frobenius norm-based Difu estimate. */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ ztgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ *
+ a_dim1], lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ +
+ i__ * b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &
+ dif[1], &work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &
+ ierr);
+
+/* Frobenius norm-based Difl estimate. */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ ztgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, &a[
+ a_offset], lda, &work[1], &n2, &b[i__ + i__ * b_dim1],
+ ldb, &b[b_offset], ldb, &work[n1 * n2 + 1], &n2, &dscale,
+ &dif[2], &work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &
+ ierr);
+ } else {
+
+/* Compute 1-norm-based estimates of Difu and Difl using */
+/* reversed communication with ZLACN2. In each step a */
+/* generalized Sylvester equation or a transposed variant */
+/* is solved. */
+
+ kase = 0;
+ n1 = *m;
+ n2 = *n - *m;
+ i__ = n1 + 1;
+ ijb = 0;
+ mn2 = (n1 << 1) * n2;
+
+/* 1-norm-based estimate of Difu. */
+
+L40:
+ zlacn2_(&mn2, &work[mn2 + 1], &work[1], &dif[1], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Solve generalized Sylvester equation */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ ztgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ +
+ i__ * a_dim1], lda, &work[1], &n1, &b[b_offset],
+ ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
+ 1], &n1, &dscale, &dif[1], &work[(n1 * n2 << 1) +
+ 1], &i__1, &iwork[1], &ierr);
+ } else {
+
+/* Solve the transposed variant. */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ ztgsyl_("C", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ +
+ i__ * a_dim1], lda, &work[1], &n1, &b[b_offset],
+ ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
+ 1], &n1, &dscale, &dif[1], &work[(n1 * n2 << 1) +
+ 1], &i__1, &iwork[1], &ierr);
+ }
+ goto L40;
+ }
+ dif[1] = dscale / dif[1];
+
+/* 1-norm-based estimate of Difl. */
+
+L50:
+ zlacn2_(&mn2, &work[mn2 + 1], &work[1], &dif[2], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Solve generalized Sylvester equation */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ ztgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda,
+ &a[a_offset], lda, &work[1], &n2, &b[i__ + i__ *
+ b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 +
+ 1], &n2, &dscale, &dif[2], &work[(n1 * n2 << 1) +
+ 1], &i__1, &iwork[1], &ierr);
+ } else {
+
+/* Solve the transposed variant. */
+
+ i__1 = *lwork - (n1 << 1) * n2;
+ ztgsyl_("C", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda,
+ &a[a_offset], lda, &work[1], &n2, &b[b_offset],
+ ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 +
+ 1], &n2, &dscale, &dif[2], &work[(n1 * n2 << 1) +
+ 1], &i__1, &iwork[1], &ierr);
+ }
+ goto L50;
+ }
+ dif[2] = dscale / dif[2];
+ }
+ }
+
+/* If B(K,K) is complex, make it real and positive (normalization */
+/* of the generalized Schur form) and Store the generalized */
+/* eigenvalues of reordered pair (A, B) */
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ dscale = z_abs(&b[k + k * b_dim1]);
+ if (dscale > safmin) {
+ i__2 = k + k * b_dim1;
+ z__2.r = b[i__2].r / dscale, z__2.i = b[i__2].i / dscale;
+ d_cnjg(&z__1, &z__2);
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ i__2 = k + k * b_dim1;
+ z__1.r = b[i__2].r / dscale, z__1.i = b[i__2].i / dscale;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ i__2 = k + k * b_dim1;
+ b[i__2].r = dscale, b[i__2].i = 0.;
+ i__2 = *n - k;
+ zscal_(&i__2, &temp1, &b[k + (k + 1) * b_dim1], ldb);
+ i__2 = *n - k + 1;
+ zscal_(&i__2, &temp1, &a[k + k * a_dim1], lda);
+ if (*wantq) {
+ zscal_(n, &temp2, &q[k * q_dim1 + 1], &c__1);
+ }
+ } else {
+ i__2 = k + k * b_dim1;
+ b[i__2].r = 0., b[i__2].i = 0.;
+ }
+
+ i__2 = k;
+ i__3 = k + k * a_dim1;
+ alpha[i__2].r = a[i__3].r, alpha[i__2].i = a[i__3].i;
+ i__2 = k;
+ i__3 = k + k * b_dim1;
+ beta[i__2].r = b[i__3].r, beta[i__2].i = b[i__3].i;
+
+/* L60: */
+ }
+
+L70:
+
+ work[1].r = (doublereal) lwmin, work[1].i = 0.;
+ iwork[1] = liwmin;
+
+ return 0;
+
+/* End of ZTGSEN */
+
+} /* ztgsen_ */
diff --git a/SRC/ztgsja.c b/SRC/ztgsja.c
new file mode 100644
index 0000000..d364302
--- /dev/null
+++ b/SRC/ztgsja.c
@@ -0,0 +1,672 @@
+/* ztgsja.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+static doublereal c_b39 = -1.;
+static doublereal c_b42 = 1.;
+
+/* Subroutine */ int ztgsja_(char *jobu, char *jobv, char *jobq, integer *m,
+ integer *p, integer *n, integer *k, integer *l, doublecomplex *a,
+ integer *lda, doublecomplex *b, integer *ldb, doublereal *tola,
+ doublereal *tolb, doublereal *alpha, doublereal *beta, doublecomplex *
+ u, integer *ldu, doublecomplex *v, integer *ldv, doublecomplex *q,
+ integer *ldq, doublecomplex *work, integer *ncycle, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1,
+ u_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal a1, b1, a3, b3;
+ doublecomplex a2, b2;
+ doublereal csq, csu, csv;
+ doublecomplex snq;
+ doublereal rwk;
+ doublecomplex snu, snv;
+ extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *);
+ doublereal gamma;
+ extern logical lsame_(char *, char *);
+ logical initq, initu, initv, wantq, upper;
+ doublereal error, ssmin;
+ logical wantu, wantv;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zlags2_(logical *, doublereal *,
+ doublecomplex *, doublereal *, doublereal *, doublecomplex *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ doublecomplex *, doublereal *, doublecomplex *);
+ integer kcycle;
+ extern /* Subroutine */ int dlartg_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *), xerbla_(char *,
+ integer *), zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *), zlapll_(integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *), zlaset_(
+ char *, integer *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTGSJA computes the generalized singular value decomposition (GSVD) */
+/* of two complex upper triangular (or trapezoidal) matrices A and B. */
+
+/* On entry, it is assumed that matrices A and B have the following */
+/* forms, which may be obtained by the preprocessing subroutine ZGGSVP */
+/* from a general M-by-N matrix A and P-by-N matrix B: */
+
+/* N-K-L K L */
+/* A = K ( 0 A12 A13 ) if M-K-L >= 0; */
+/* L ( 0 0 A23 ) */
+/* M-K-L ( 0 0 0 ) */
+
+/* N-K-L K L */
+/* A = K ( 0 A12 A13 ) if M-K-L < 0; */
+/* M-K ( 0 0 A23 ) */
+
+/* N-K-L K L */
+/* B = L ( 0 0 B13 ) */
+/* P-L ( 0 0 0 ) */
+
+/* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */
+/* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */
+/* otherwise A23 is (M-K)-by-L upper trapezoidal. */
+
+/* On exit, */
+
+/* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ), */
+
+/* where U, V and Q are unitary matrices, Z' denotes the conjugate */
+/* transpose of Z, R is a nonsingular upper triangular matrix, and D1 */
+/* and D2 are ``diagonal'' matrices, which are of the following */
+/* structures: */
+
+/* If M-K-L >= 0, */
+
+/* K L */
+/* D1 = K ( I 0 ) */
+/* L ( 0 C ) */
+/* M-K-L ( 0 0 ) */
+
+/* K L */
+/* D2 = L ( 0 S ) */
+/* P-L ( 0 0 ) */
+
+/* N-K-L K L */
+/* ( 0 R ) = K ( 0 R11 R12 ) K */
+/* L ( 0 0 R22 ) L */
+
+/* where */
+
+/* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */
+/* S = diag( BETA(K+1), ... , BETA(K+L) ), */
+/* C**2 + S**2 = I. */
+
+/* R is stored in A(1:K+L,N-K-L+1:N) on exit. */
+
+/* If M-K-L < 0, */
+
+/* K M-K K+L-M */
+/* D1 = K ( I 0 0 ) */
+/* M-K ( 0 C 0 ) */
+
+/* K M-K K+L-M */
+/* D2 = M-K ( 0 S 0 ) */
+/* K+L-M ( 0 0 I ) */
+/* P-L ( 0 0 0 ) */
+
+/* N-K-L K M-K K+L-M */
+/* ( 0 R ) = K ( 0 R11 R12 R13 ) */
+/* M-K ( 0 0 R22 R23 ) */
+/* K+L-M ( 0 0 0 R33 ) */
+
+/* where */
+/* C = diag( ALPHA(K+1), ... , ALPHA(M) ), */
+/* S = diag( BETA(K+1), ... , BETA(M) ), */
+/* C**2 + S**2 = I. */
+
+/* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored */
+/* ( 0 R22 R23 ) */
+/* in B(M-K+1:L,N+M-K-L+1:N) on exit. */
+
+/* The computation of the unitary transformation matrices U, V or Q */
+/* is optional. These matrices may either be formed explicitly, or they */
+/* may be postmultiplied into input matrices U1, V1, or Q1. */
+
+/* Arguments */
+/* ========= */
+
+/* JOBU (input) CHARACTER*1 */
+/* = 'U': U must contain a unitary matrix U1 on entry, and */
+/* the product U1*U is returned; */
+/* = 'I': U is initialized to the unit matrix, and the */
+/* unitary matrix U is returned; */
+/* = 'N': U is not computed. */
+
+/* JOBV (input) CHARACTER*1 */
+/* = 'V': V must contain a unitary matrix V1 on entry, and */
+/* the product V1*V is returned; */
+/* = 'I': V is initialized to the unit matrix, and the */
+/* unitary matrix V is returned; */
+/* = 'N': V is not computed. */
+
+/* JOBQ (input) CHARACTER*1 */
+/* = 'Q': Q must contain a unitary matrix Q1 on entry, and */
+/* the product Q1*Q is returned; */
+/* = 'I': Q is initialized to the unit matrix, and the */
+/* unitary matrix Q is returned; */
+/* = 'N': Q is not computed. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* K (input) INTEGER */
+/* L (input) INTEGER */
+/* K and L specify the subblocks in the input matrices A and B: */
+/* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,,N-L+1:N) */
+/* of A and B, whose GSVD is going to be computed by ZTGSJA. */
+/* See Further details. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the M-by-N matrix A. */
+/* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular */
+/* matrix R or part of R. See Purpose for details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix B. */
+/* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains */
+/* a part of R. See Purpose for details. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,P). */
+
+/* TOLA (input) DOUBLE PRECISION */
+/* TOLB (input) DOUBLE PRECISION */
+/* TOLA and TOLB are the convergence criteria for the Jacobi- */
+/* Kogbetliantz iteration procedure. Generally, they are the */
+/* same as used in the preprocessing step, say */
+/* TOLA = MAX(M,N)*norm(A)*MAZHEPS, */
+/* TOLB = MAX(P,N)*norm(B)*MAZHEPS. */
+
+/* ALPHA (output) DOUBLE PRECISION array, dimension (N) */
+/* BETA (output) DOUBLE PRECISION array, dimension (N) */
+/* On exit, ALPHA and BETA contain the generalized singular */
+/* value pairs of A and B; */
+/* ALPHA(1:K) = 1, */
+/* BETA(1:K) = 0, */
+/* and if M-K-L >= 0, */
+/* ALPHA(K+1:K+L) = diag(C), */
+/* BETA(K+1:K+L) = diag(S), */
+/* or if M-K-L < 0, */
+/* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0 */
+/* BETA(K+1:M) = S, BETA(M+1:K+L) = 1. */
+/* Furthermore, if K+L < N, */
+/* ALPHA(K+L+1:N) = 0 */
+/* BETA(K+L+1:N) = 0. */
+
+/* U (input/output) COMPLEX*16 array, dimension (LDU,M) */
+/* On entry, if JOBU = 'U', U must contain a matrix U1 (usually */
+/* the unitary matrix returned by ZGGSVP). */
+/* On exit, */
+/* if JOBU = 'I', U contains the unitary matrix U; */
+/* if JOBU = 'U', U contains the product U1*U. */
+/* If JOBU = 'N', U is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M) if */
+/* JOBU = 'U'; LDU >= 1 otherwise. */
+
+/* V (input/output) COMPLEX*16 array, dimension (LDV,P) */
+/* On entry, if JOBV = 'V', V must contain a matrix V1 (usually */
+/* the unitary matrix returned by ZGGSVP). */
+/* On exit, */
+/* if JOBV = 'I', V contains the unitary matrix V; */
+/* if JOBV = 'V', V contains the product V1*V. */
+/* If JOBV = 'N', V is not referenced. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. LDV >= max(1,P) if */
+/* JOBV = 'V'; LDV >= 1 otherwise. */
+
+/* Q (input/output) COMPLEX*16 array, dimension (LDQ,N) */
+/* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually */
+/* the unitary matrix returned by ZGGSVP). */
+/* On exit, */
+/* if JOBQ = 'I', Q contains the unitary matrix Q; */
+/* if JOBQ = 'Q', Q contains the product Q1*Q. */
+/* If JOBQ = 'N', Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N) if */
+/* JOBQ = 'Q'; LDQ >= 1 otherwise. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* NCYCLE (output) INTEGER */
+/* The number of cycles required for convergence. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* = 1: the procedure does not converge after MAXIT cycles. */
+
+/* Internal Parameters */
+/* =================== */
+
+/* MAXIT INTEGER */
+/* MAXIT specifies the total loops that the iterative procedure */
+/* may take. If after MAXIT cycles, the routine fails to */
+/* converge, we return INFO = 1. */
+
+/* Further Details */
+/* =============== */
+
+/* ZTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce */
+/* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L */
+/* matrix B13 to the form: */
+
+/* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1, */
+
+/* where U1, V1 and Q1 are unitary matrix, and Z' is the conjugate */
+/* transpose of Z. C1 and S1 are diagonal matrices satisfying */
+
+/* C1**2 + S1**2 = I, */
+
+/* and R1 is an L-by-L nonsingular upper triangular matrix. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --alpha;
+ --beta;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+
+ /* Function Body */
+ initu = lsame_(jobu, "I");
+ wantu = initu || lsame_(jobu, "U");
+
+ initv = lsame_(jobv, "I");
+ wantv = initv || lsame_(jobv, "V");
+
+ initq = lsame_(jobq, "I");
+ wantq = initq || lsame_(jobq, "Q");
+
+ *info = 0;
+ if (! (initu || wantu || lsame_(jobu, "N"))) {
+ *info = -1;
+ } else if (! (initv || wantv || lsame_(jobv, "N")))
+ {
+ *info = -2;
+ } else if (! (initq || wantq || lsame_(jobq, "N")))
+ {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*p < 0) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (*lda < max(1,*m)) {
+ *info = -10;
+ } else if (*ldb < max(1,*p)) {
+ *info = -12;
+ } else if (*ldu < 1 || wantu && *ldu < *m) {
+ *info = -18;
+ } else if (*ldv < 1 || wantv && *ldv < *p) {
+ *info = -20;
+ } else if (*ldq < 1 || wantq && *ldq < *n) {
+ *info = -22;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTGSJA", &i__1);
+ return 0;
+ }
+
+/* Initialize U, V and Q, if necessary */
+
+ if (initu) {
+ zlaset_("Full", m, m, &c_b1, &c_b2, &u[u_offset], ldu);
+ }
+ if (initv) {
+ zlaset_("Full", p, p, &c_b1, &c_b2, &v[v_offset], ldv);
+ }
+ if (initq) {
+ zlaset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq);
+ }
+
+/* Loop until convergence */
+
+ upper = FALSE_;
+ for (kcycle = 1; kcycle <= 40; ++kcycle) {
+
+ upper = ! upper;
+
+ i__1 = *l - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *l;
+ for (j = i__ + 1; j <= i__2; ++j) {
+
+ a1 = 0.;
+ a2.r = 0., a2.i = 0.;
+ a3 = 0.;
+ if (*k + i__ <= *m) {
+ i__3 = *k + i__ + (*n - *l + i__) * a_dim1;
+ a1 = a[i__3].r;
+ }
+ if (*k + j <= *m) {
+ i__3 = *k + j + (*n - *l + j) * a_dim1;
+ a3 = a[i__3].r;
+ }
+
+ i__3 = i__ + (*n - *l + i__) * b_dim1;
+ b1 = b[i__3].r;
+ i__3 = j + (*n - *l + j) * b_dim1;
+ b3 = b[i__3].r;
+
+ if (upper) {
+ if (*k + i__ <= *m) {
+ i__3 = *k + i__ + (*n - *l + j) * a_dim1;
+ a2.r = a[i__3].r, a2.i = a[i__3].i;
+ }
+ i__3 = i__ + (*n - *l + j) * b_dim1;
+ b2.r = b[i__3].r, b2.i = b[i__3].i;
+ } else {
+ if (*k + j <= *m) {
+ i__3 = *k + j + (*n - *l + i__) * a_dim1;
+ a2.r = a[i__3].r, a2.i = a[i__3].i;
+ }
+ i__3 = j + (*n - *l + i__) * b_dim1;
+ b2.r = b[i__3].r, b2.i = b[i__3].i;
+ }
+
+ zlags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &
+ csv, &snv, &csq, &snq);
+
+/* Update (K+I)-th and (K+J)-th rows of matrix A: U'*A */
+
+ if (*k + j <= *m) {
+ d_cnjg(&z__1, &snu);
+ zrot_(l, &a[*k + j + (*n - *l + 1) * a_dim1], lda, &a[*k
+ + i__ + (*n - *l + 1) * a_dim1], lda, &csu, &z__1)
+ ;
+ }
+
+/* Update I-th and J-th rows of matrix B: V'*B */
+
+ d_cnjg(&z__1, &snv);
+ zrot_(l, &b[j + (*n - *l + 1) * b_dim1], ldb, &b[i__ + (*n - *
+ l + 1) * b_dim1], ldb, &csv, &z__1);
+
+/* Update (N-L+I)-th and (N-L+J)-th columns of matrices */
+/* A and B: A*Q and B*Q */
+
+/* Computing MIN */
+ i__4 = *k + *l;
+ i__3 = min(i__4,*m);
+ zrot_(&i__3, &a[(*n - *l + j) * a_dim1 + 1], &c__1, &a[(*n - *
+ l + i__) * a_dim1 + 1], &c__1, &csq, &snq);
+
+ zrot_(l, &b[(*n - *l + j) * b_dim1 + 1], &c__1, &b[(*n - *l +
+ i__) * b_dim1 + 1], &c__1, &csq, &snq);
+
+ if (upper) {
+ if (*k + i__ <= *m) {
+ i__3 = *k + i__ + (*n - *l + j) * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ }
+ i__3 = i__ + (*n - *l + j) * b_dim1;
+ b[i__3].r = 0., b[i__3].i = 0.;
+ } else {
+ if (*k + j <= *m) {
+ i__3 = *k + j + (*n - *l + i__) * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ }
+ i__3 = j + (*n - *l + i__) * b_dim1;
+ b[i__3].r = 0., b[i__3].i = 0.;
+ }
+
+/* Ensure that the diagonal elements of A and B are real. */
+
+ if (*k + i__ <= *m) {
+ i__3 = *k + i__ + (*n - *l + i__) * a_dim1;
+ i__4 = *k + i__ + (*n - *l + i__) * a_dim1;
+ d__1 = a[i__4].r;
+ a[i__3].r = d__1, a[i__3].i = 0.;
+ }
+ if (*k + j <= *m) {
+ i__3 = *k + j + (*n - *l + j) * a_dim1;
+ i__4 = *k + j + (*n - *l + j) * a_dim1;
+ d__1 = a[i__4].r;
+ a[i__3].r = d__1, a[i__3].i = 0.;
+ }
+ i__3 = i__ + (*n - *l + i__) * b_dim1;
+ i__4 = i__ + (*n - *l + i__) * b_dim1;
+ d__1 = b[i__4].r;
+ b[i__3].r = d__1, b[i__3].i = 0.;
+ i__3 = j + (*n - *l + j) * b_dim1;
+ i__4 = j + (*n - *l + j) * b_dim1;
+ d__1 = b[i__4].r;
+ b[i__3].r = d__1, b[i__3].i = 0.;
+
+/* Update unitary matrices U, V, Q, if desired. */
+
+ if (wantu && *k + j <= *m) {
+ zrot_(m, &u[(*k + j) * u_dim1 + 1], &c__1, &u[(*k + i__) *
+ u_dim1 + 1], &c__1, &csu, &snu);
+ }
+
+ if (wantv) {
+ zrot_(p, &v[j * v_dim1 + 1], &c__1, &v[i__ * v_dim1 + 1],
+ &c__1, &csv, &snv);
+ }
+
+ if (wantq) {
+ zrot_(n, &q[(*n - *l + j) * q_dim1 + 1], &c__1, &q[(*n - *
+ l + i__) * q_dim1 + 1], &c__1, &csq, &snq);
+ }
+
+/* L10: */
+ }
+/* L20: */
+ }
+
+ if (! upper) {
+
+/* The matrices A13 and B13 were lower triangular at the start */
+/* of the cycle, and are now upper triangular. */
+
+/* Convergence test: test the parallelism of the corresponding */
+/* rows of A and B. */
+
+ error = 0.;
+/* Computing MIN */
+ i__2 = *l, i__3 = *m - *k;
+ i__1 = min(i__2,i__3);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *l - i__ + 1;
+ zcopy_(&i__2, &a[*k + i__ + (*n - *l + i__) * a_dim1], lda, &
+ work[1], &c__1);
+ i__2 = *l - i__ + 1;
+ zcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &work[*
+ l + 1], &c__1);
+ i__2 = *l - i__ + 1;
+ zlapll_(&i__2, &work[1], &c__1, &work[*l + 1], &c__1, &ssmin);
+ error = max(error,ssmin);
+/* L30: */
+ }
+
+ if (abs(error) <= min(*tola,*tolb)) {
+ goto L50;
+ }
+ }
+
+/* End of cycle loop */
+
+/* L40: */
+ }
+
+/* The algorithm has not converged after MAXIT cycles. */
+
+ *info = 1;
+ goto L100;
+
+L50:
+
+/* If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged. */
+/* Compute the generalized singular value pairs (ALPHA, BETA), and */
+/* set the triangular matrix R to array A. */
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ alpha[i__] = 1.;
+ beta[i__] = 0.;
+/* L60: */
+ }
+
+/* Computing MIN */
+ i__2 = *l, i__3 = *m - *k;
+ i__1 = min(i__2,i__3);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+ i__2 = *k + i__ + (*n - *l + i__) * a_dim1;
+ a1 = a[i__2].r;
+ i__2 = i__ + (*n - *l + i__) * b_dim1;
+ b1 = b[i__2].r;
+
+ if (a1 != 0.) {
+ gamma = b1 / a1;
+
+ if (gamma < 0.) {
+ i__2 = *l - i__ + 1;
+ zdscal_(&i__2, &c_b39, &b[i__ + (*n - *l + i__) * b_dim1],
+ ldb);
+ if (wantv) {
+ zdscal_(p, &c_b39, &v[i__ * v_dim1 + 1], &c__1);
+ }
+ }
+
+ d__1 = abs(gamma);
+ dlartg_(&d__1, &c_b42, &beta[*k + i__], &alpha[*k + i__], &rwk);
+
+ if (alpha[*k + i__] >= beta[*k + i__]) {
+ i__2 = *l - i__ + 1;
+ d__1 = 1. / alpha[*k + i__];
+ zdscal_(&i__2, &d__1, &a[*k + i__ + (*n - *l + i__) * a_dim1],
+ lda);
+ } else {
+ i__2 = *l - i__ + 1;
+ d__1 = 1. / beta[*k + i__];
+ zdscal_(&i__2, &d__1, &b[i__ + (*n - *l + i__) * b_dim1], ldb)
+ ;
+ i__2 = *l - i__ + 1;
+ zcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k
+ + i__ + (*n - *l + i__) * a_dim1], lda);
+ }
+
+ } else {
+ alpha[*k + i__] = 0.;
+ beta[*k + i__] = 1.;
+ i__2 = *l - i__ + 1;
+ zcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k +
+ i__ + (*n - *l + i__) * a_dim1], lda);
+ }
+/* L70: */
+ }
+
+/* Post-assignment */
+
+ i__1 = *k + *l;
+ for (i__ = *m + 1; i__ <= i__1; ++i__) {
+ alpha[i__] = 0.;
+ beta[i__] = 1.;
+/* L80: */
+ }
+
+ if (*k + *l < *n) {
+ i__1 = *n;
+ for (i__ = *k + *l + 1; i__ <= i__1; ++i__) {
+ alpha[i__] = 0.;
+ beta[i__] = 0.;
+/* L90: */
+ }
+ }
+
+L100:
+ *ncycle = kcycle;
+
+ return 0;
+
+/* End of ZTGSJA */
+
+} /* ztgsja_ */
diff --git a/SRC/ztgsna.c b/SRC/ztgsna.c
new file mode 100644
index 0000000..2e8856d
--- /dev/null
+++ b/SRC/ztgsna.c
@@ -0,0 +1,487 @@
+/* ztgsna.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublecomplex c_b19 = {1.,0.};
+static doublecomplex c_b20 = {0.,0.};
+static logical c_false = FALSE_;
+static integer c__3 = 3;
+
+/* Subroutine */ int ztgsna_(char *job, char *howmny, logical *select,
+ integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer
+ *ldb, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *
+ ldvr, doublereal *s, doublereal *dif, integer *mm, integer *m,
+ doublecomplex *work, integer *lwork, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1,
+ vr_offset, i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+
+ /* Local variables */
+ integer i__, k, n1, n2, ks;
+ doublereal eps, cond;
+ integer ierr, ifst;
+ doublereal lnrm;
+ doublecomplex yhax, yhbx;
+ integer ilst;
+ doublereal rnrm, scale;
+ extern logical lsame_(char *, char *);
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ integer lwmin;
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ logical wants;
+ doublecomplex dummy[1];
+ extern doublereal dlapy2_(doublereal *, doublereal *);
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ doublecomplex dummy1[1];
+ extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
+ char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ logical wantbh, wantdf, somcon;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ ztgexc_(logical *, logical *, integer *, doublecomplex *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *, integer *);
+ doublereal smlnum;
+ logical lquery;
+ extern /* Subroutine */ int ztgsyl_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, integer *, integer *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTGSNA estimates reciprocal condition numbers for specified */
+/* eigenvalues and/or eigenvectors of a matrix pair (A, B). */
+
+/* (A, B) must be in generalized Schur canonical form, that is, A and */
+/* B are both upper triangular. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies whether condition numbers are required for */
+/* eigenvalues (S) or eigenvectors (DIF): */
+/* = 'E': for eigenvalues only (S); */
+/* = 'V': for eigenvectors only (DIF); */
+/* = 'B': for both eigenvalues and eigenvectors (S and DIF). */
+
+/* HOWMNY (input) CHARACTER*1 */
+/* = 'A': compute condition numbers for all eigenpairs; */
+/* = 'S': compute condition numbers for selected eigenpairs */
+/* specified by the array SELECT. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* If HOWMNY = 'S', SELECT specifies the eigenpairs for which */
+/* condition numbers are required. To select condition numbers */
+/* for the corresponding j-th eigenvalue and/or eigenvector, */
+/* SELECT(j) must be set to .TRUE.. */
+/* If HOWMNY = 'A', SELECT is not referenced. */
+
+/* N (input) INTEGER */
+/* The order of the square matrix pair (A, B). N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The upper triangular matrix A in the pair (A,B). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,N) */
+/* The upper triangular matrix B in the pair (A, B). */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* VL (input) COMPLEX*16 array, dimension (LDVL,M) */
+/* IF JOB = 'E' or 'B', VL must contain left eigenvectors of */
+/* (A, B), corresponding to the eigenpairs specified by HOWMNY */
+/* and SELECT. The eigenvectors must be stored in consecutive */
+/* columns of VL, as returned by ZTGEVC. */
+/* If JOB = 'V', VL is not referenced. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. LDVL >= 1; and */
+/* If JOB = 'E' or 'B', LDVL >= N. */
+
+/* VR (input) COMPLEX*16 array, dimension (LDVR,M) */
+/* IF JOB = 'E' or 'B', VR must contain right eigenvectors of */
+/* (A, B), corresponding to the eigenpairs specified by HOWMNY */
+/* and SELECT. The eigenvectors must be stored in consecutive */
+/* columns of VR, as returned by ZTGEVC. */
+/* If JOB = 'V', VR is not referenced. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. LDVR >= 1; */
+/* If JOB = 'E' or 'B', LDVR >= N. */
+
+/* S (output) DOUBLE PRECISION array, dimension (MM) */
+/* If JOB = 'E' or 'B', the reciprocal condition numbers of the */
+/* selected eigenvalues, stored in consecutive elements of the */
+/* array. */
+/* If JOB = 'V', S is not referenced. */
+
+/* DIF (output) DOUBLE PRECISION array, dimension (MM) */
+/* If JOB = 'V' or 'B', the estimated reciprocal condition */
+/* numbers of the selected eigenvectors, stored in consecutive */
+/* elements of the array. */
+/* If the eigenvalues cannot be reordered to compute DIF(j), */
+/* DIF(j) is set to 0; this can only occur when the true value */
+/* would be very small anyway. */
+/* For each eigenvalue/vector specified by SELECT, DIF stores */
+/* a Frobenius norm-based estimate of Difl. */
+/* If JOB = 'E', DIF is not referenced. */
+
+/* MM (input) INTEGER */
+/* The number of elements in the arrays S and DIF. MM >= M. */
+
+/* M (output) INTEGER */
+/* The number of elements of the arrays S and DIF used to store */
+/* the specified condition numbers; for each selected eigenvalue */
+/* one element is used. If HOWMNY = 'A', M is set to N. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* If JOB = 'V' or 'B', LWORK >= max(1,2*N*N). */
+
+/* IWORK (workspace) INTEGER array, dimension (N+2) */
+/* If JOB = 'E', IWORK is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: Successful exit */
+/* < 0: If INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The reciprocal of the condition number of the i-th generalized */
+/* eigenvalue w = (a, b) is defined as */
+
+/* S(I) = (|v'Au|**2 + |v'Bu|**2)**(1/2) / (norm(u)*norm(v)) */
+
+/* where u and v are the right and left eigenvectors of (A, B) */
+/* corresponding to w; |z| denotes the absolute value of the complex */
+/* number, and norm(u) denotes the 2-norm of the vector u. The pair */
+/* (a, b) corresponds to an eigenvalue w = a/b (= v'Au/v'Bu) of the */
+/* matrix pair (A, B). If both a and b equal zero, then (A,B) is */
+/* singular and S(I) = -1 is returned. */
+
+/* An approximate error bound on the chordal distance between the i-th */
+/* computed generalized eigenvalue w and the corresponding exact */
+/* eigenvalue lambda is */
+
+/* chord(w, lambda) <= EPS * norm(A, B) / S(I), */
+
+/* where EPS is the machine precision. */
+
+/* The reciprocal of the condition number of the right eigenvector u */
+/* and left eigenvector v corresponding to the generalized eigenvalue w */
+/* is defined as follows. Suppose */
+
+/* (A, B) = ( a * ) ( b * ) 1 */
+/* ( 0 A22 ),( 0 B22 ) n-1 */
+/* 1 n-1 1 n-1 */
+
+/* Then the reciprocal condition number DIF(I) is */
+
+/* Difl[(a, b), (A22, B22)] = sigma-min( Zl ) */
+
+/* where sigma-min(Zl) denotes the smallest singular value of */
+
+/* Zl = [ kron(a, In-1) -kron(1, A22) ] */
+/* [ kron(b, In-1) -kron(1, B22) ]. */
+
+/* Here In-1 is the identity matrix of size n-1 and X' is the conjugate */
+/* transpose of X. kron(X, Y) is the Kronecker product between the */
+/* matrices X and Y. */
+
+/* We approximate the smallest singular value of Zl with an upper */
+/* bound. This is done by ZLATDF. */
+
+/* An approximate error bound for a computed eigenvector VL(i) or */
+/* VR(i) is given by */
+
+/* EPS * norm(A, B) / DIF(i). */
+
+/* See ref. [2-3] for more details and further references. */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* References */
+/* ========== */
+
+/* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */
+/* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */
+/* M.S. Moonen et al (eds), Linear Algebra for Large Scale and */
+/* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */
+
+/* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */
+/* Eigenvalues of a Regular Matrix Pair (A, B) and Condition */
+/* Estimation: Theory, Algorithms and Software, Report */
+/* UMINF - 94.04, Department of Computing Science, Umea University, */
+/* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87. */
+/* To appear in Numerical Algorithms, 1996. */
+
+/* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
+/* for Solving the Generalized Sylvester Equation and Estimating the */
+/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
+/* Department of Computing Science, Umea University, S-901 87 Umea, */
+/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */
+/* Note 75. */
+/* To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ --select;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --s;
+ --dif;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ wantbh = lsame_(job, "B");
+ wants = lsame_(job, "E") || wantbh;
+ wantdf = lsame_(job, "V") || wantbh;
+
+ somcon = lsame_(howmny, "S");
+
+ *info = 0;
+ lquery = *lwork == -1;
+
+ if (! wants && ! wantdf) {
+ *info = -1;
+ } else if (! lsame_(howmny, "A") && ! somcon) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (wants && *ldvl < *n) {
+ *info = -10;
+ } else if (wants && *ldvr < *n) {
+ *info = -12;
+ } else {
+
+/* Set M to the number of eigenpairs for which condition numbers */
+/* are required, and test MM. */
+
+ if (somcon) {
+ *m = 0;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (select[k]) {
+ ++(*m);
+ }
+/* L10: */
+ }
+ } else {
+ *m = *n;
+ }
+
+ if (*n == 0) {
+ lwmin = 1;
+ } else if (lsame_(job, "V") || lsame_(job,
+ "B")) {
+ lwmin = (*n << 1) * *n;
+ } else {
+ lwmin = *n;
+ }
+ work[1].r = (doublereal) lwmin, work[1].i = 0.;
+
+ if (*mm < *m) {
+ *info = -15;
+ } else if (*lwork < lwmin && ! lquery) {
+ *info = -18;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTGSNA", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S") / eps;
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ ks = 0;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+/* Determine whether condition numbers are required for the k-th */
+/* eigenpair. */
+
+ if (somcon) {
+ if (! select[k]) {
+ goto L20;
+ }
+ }
+
+ ++ks;
+
+ if (wants) {
+
+/* Compute the reciprocal condition number of the k-th */
+/* eigenvalue. */
+
+ rnrm = dznrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
+ lnrm = dznrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
+ zgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[ks * vr_dim1 + 1]
+, &c__1, &c_b20, &work[1], &c__1);
+ zdotc_(&z__1, n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1);
+ yhax.r = z__1.r, yhax.i = z__1.i;
+ zgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[ks * vr_dim1 + 1]
+, &c__1, &c_b20, &work[1], &c__1);
+ zdotc_(&z__1, n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1);
+ yhbx.r = z__1.r, yhbx.i = z__1.i;
+ d__1 = z_abs(&yhax);
+ d__2 = z_abs(&yhbx);
+ cond = dlapy2_(&d__1, &d__2);
+ if (cond == 0.) {
+ s[ks] = -1.;
+ } else {
+ s[ks] = cond / (rnrm * lnrm);
+ }
+ }
+
+ if (wantdf) {
+ if (*n == 1) {
+ d__1 = z_abs(&a[a_dim1 + 1]);
+ d__2 = z_abs(&b[b_dim1 + 1]);
+ dif[ks] = dlapy2_(&d__1, &d__2);
+ } else {
+
+/* Estimate the reciprocal condition number of the k-th */
+/* eigenvectors. */
+
+/* Copy the matrix (A, B) to the array WORK and move the */
+/* (k,k)th pair to the (1,1) position. */
+
+ zlacpy_("Full", n, n, &a[a_offset], lda, &work[1], n);
+ zlacpy_("Full", n, n, &b[b_offset], ldb, &work[*n * *n + 1],
+ n);
+ ifst = k;
+ ilst = 1;
+
+ ztgexc_(&c_false, &c_false, n, &work[1], n, &work[*n * *n + 1]
+, n, dummy, &c__1, dummy1, &c__1, &ifst, &ilst, &ierr)
+ ;
+
+ if (ierr > 0) {
+
+/* Ill-conditioned problem - swap rejected. */
+
+ dif[ks] = 0.;
+ } else {
+
+/* Reordering successful, solve generalized Sylvester */
+/* equation for R and L, */
+/* A22 * R - L * A11 = A12 */
+/* B22 * R - L * B11 = B12, */
+/* and compute estimate of Difl[(A11,B11), (A22, B22)]. */
+
+ n1 = 1;
+ n2 = *n - n1;
+ i__ = *n * *n + 1;
+ ztgsyl_("N", &c__3, &n2, &n1, &work[*n * n1 + n1 + 1], n,
+ &work[1], n, &work[n1 + 1], n, &work[*n * n1 + n1
+ + i__], n, &work[i__], n, &work[n1 + i__], n, &
+ scale, &dif[ks], dummy, &c__1, &iwork[1], &ierr);
+ }
+ }
+ }
+
+L20:
+ ;
+ }
+ work[1].r = (doublereal) lwmin, work[1].i = 0.;
+ return 0;
+
+/* End of ZTGSNA */
+
+} /* ztgsna_ */
diff --git a/SRC/ztgsy2.c b/SRC/ztgsy2.c
new file mode 100644
index 0000000..4f1bbdd
--- /dev/null
+++ b/SRC/ztgsy2.c
@@ -0,0 +1,478 @@
+/* ztgsy2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* Subroutine */ int ztgsy2_(char *trans, integer *ijob, integer *m, integer *
+ n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *c__, integer *ldc, doublecomplex *d__, integer *ldd,
+ doublecomplex *e, integer *lde, doublecomplex *f, integer *ldf,
+ doublereal *scale, doublereal *rdsum, doublereal *rdscal, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
+ d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3,
+ i__4;
+ doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublecomplex z__[4] /* was [2][2] */, rhs[2];
+ integer ierr, ipiv[2], jpiv[2];
+ doublecomplex alpha;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), zgesc2_(
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *, doublereal *), zgetc2_(integer *, doublecomplex *,
+ integer *, integer *, integer *, integer *);
+ doublereal scaloc;
+ extern /* Subroutine */ int xerbla_(char *, integer *), zlatdf_(
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *, doublereal *, integer *, integer *);
+ logical notran;
+
+
+/* -- LAPACK auxiliary routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTGSY2 solves the generalized Sylvester equation */
+
+/* A * R - L * B = scale * C (1) */
+/* D * R - L * E = scale * F */
+
+/* using Level 1 and 2 BLAS, where R and L are unknown M-by-N matrices, */
+/* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M, */
+/* N-by-N and M-by-N, respectively. A, B, D and E are upper triangular */
+/* (i.e., (A,D) and (B,E) in generalized Schur form). */
+
+/* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output */
+/* scaling factor chosen to avoid overflow. */
+
+/* In matrix notation solving equation (1) corresponds to solve */
+/* Zx = scale * b, where Z is defined as */
+
+/* Z = [ kron(In, A) -kron(B', Im) ] (2) */
+/* [ kron(In, D) -kron(E', Im) ], */
+
+/* Ik is the identity matrix of size k and X' is the transpose of X. */
+/* kron(X, Y) is the Kronecker product between the matrices X and Y. */
+
+/* If TRANS = 'C', y in the conjugate transposed system Z'y = scale*b */
+/* is solved for, which is equivalent to solve for R and L in */
+
+/* A' * R + D' * L = scale * C (3) */
+/* R * B' + L * E' = scale * -F */
+
+/* This case is used to compute an estimate of Dif[(A, D), (B, E)] = */
+/* = sigma_min(Z) using reverse communicaton with ZLACON. */
+
+/* ZTGSY2 also (IJOB >= 1) contributes to the computation in ZTGSYL */
+/* of an upper bound on the separation between to matrix pairs. Then */
+/* the input (A, D), (B, E) are sub-pencils of two matrix pairs in */
+/* ZTGSYL. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N', solve the generalized Sylvester equation (1). */
+/* = 'T': solve the 'transposed' system (3). */
+
+/* IJOB (input) INTEGER */
+/* Specifies what kind of functionality to be performed. */
+/* =0: solve (1) only. */
+/* =1: A contribution from this subsystem to a Frobenius */
+/* norm-based estimate of the separation between two matrix */
+/* pairs is computed. (look ahead strategy is used). */
+/* =2: A contribution from this subsystem to a Frobenius */
+/* norm-based estimate of the separation between two matrix */
+/* pairs is computed. (DGECON on sub-systems is used.) */
+/* Not referenced if TRANS = 'T'. */
+
+/* M (input) INTEGER */
+/* On entry, M specifies the order of A and D, and the row */
+/* dimension of C, F, R and L. */
+
+/* N (input) INTEGER */
+/* On entry, N specifies the order of B and E, and the column */
+/* dimension of C, F, R and L. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA, M) */
+/* On entry, A contains an upper triangular matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the matrix A. LDA >= max(1, M). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB, N) */
+/* On entry, B contains an upper triangular matrix. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the matrix B. LDB >= max(1, N). */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC, N) */
+/* On entry, C contains the right-hand-side of the first matrix */
+/* equation in (1). */
+/* On exit, if IJOB = 0, C has been overwritten by the solution */
+/* R. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the matrix C. LDC >= max(1, M). */
+
+/* D (input) COMPLEX*16 array, dimension (LDD, M) */
+/* On entry, D contains an upper triangular matrix. */
+
+/* LDD (input) INTEGER */
+/* The leading dimension of the matrix D. LDD >= max(1, M). */
+
+/* E (input) COMPLEX*16 array, dimension (LDE, N) */
+/* On entry, E contains an upper triangular matrix. */
+
+/* LDE (input) INTEGER */
+/* The leading dimension of the matrix E. LDE >= max(1, N). */
+
+/* F (input/output) COMPLEX*16 array, dimension (LDF, N) */
+/* On entry, F contains the right-hand-side of the second matrix */
+/* equation in (1). */
+/* On exit, if IJOB = 0, F has been overwritten by the solution */
+/* L. */
+
+/* LDF (input) INTEGER */
+/* The leading dimension of the matrix F. LDF >= max(1, M). */
+
+/* SCALE (output) DOUBLE PRECISION */
+/* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions */
+/* R and L (C and F on entry) will hold the solutions to a */
+/* slightly perturbed system but the input matrices A, B, D and */
+/* E have not been changed. If SCALE = 0, R and L will hold the */
+/* solutions to the homogeneous system with C = F = 0. */
+/* Normally, SCALE = 1. */
+
+/* RDSUM (input/output) DOUBLE PRECISION */
+/* On entry, the sum of squares of computed contributions to */
+/* the Dif-estimate under computation by ZTGSYL, where the */
+/* scaling factor RDSCAL (see below) has been factored out. */
+/* On exit, the corresponding sum of squares updated with the */
+/* contributions from the current sub-system. */
+/* If TRANS = 'T' RDSUM is not touched. */
+/* NOTE: RDSUM only makes sense when ZTGSY2 is called by */
+/* ZTGSYL. */
+
+/* RDSCAL (input/output) DOUBLE PRECISION */
+/* On entry, scaling factor used to prevent overflow in RDSUM. */
+/* On exit, RDSCAL is updated w.r.t. the current contributions */
+/* in RDSUM. */
+/* If TRANS = 'T', RDSCAL is not touched. */
+/* NOTE: RDSCAL only makes sense when ZTGSY2 is called by */
+/* ZTGSYL. */
+
+/* INFO (output) INTEGER */
+/* On exit, if INFO is set to */
+/* =0: Successful exit */
+/* <0: If INFO = -i, input argument number i is illegal. */
+/* >0: The matrix pairs (A, D) and (B, E) have common or very */
+/* close eigenvalues. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ d_dim1 = *ldd;
+ d_offset = 1 + d_dim1;
+ d__ -= d_offset;
+ e_dim1 = *lde;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ f_dim1 = *ldf;
+ f_offset = 1 + f_dim1;
+ f -= f_offset;
+
+ /* Function Body */
+ *info = 0;
+ ierr = 0;
+ notran = lsame_(trans, "N");
+ if (! notran && ! lsame_(trans, "C")) {
+ *info = -1;
+ } else if (notran) {
+ if (*ijob < 0 || *ijob > 2) {
+ *info = -2;
+ }
+ }
+ if (*info == 0) {
+ if (*m <= 0) {
+ *info = -3;
+ } else if (*n <= 0) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ } else if (*ldd < max(1,*m)) {
+ *info = -12;
+ } else if (*lde < max(1,*n)) {
+ *info = -14;
+ } else if (*ldf < max(1,*m)) {
+ *info = -16;
+ }
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTGSY2", &i__1);
+ return 0;
+ }
+
+ if (notran) {
+
+/* Solve (I, J) - system */
+/* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) */
+/* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) */
+/* for I = M, M - 1, ..., 1; J = 1, 2, ..., N */
+
+ *scale = 1.;
+ scaloc = 1.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ for (i__ = *m; i__ >= 1; --i__) {
+
+/* Build 2 by 2 system */
+
+ i__2 = i__ + i__ * a_dim1;
+ z__[0].r = a[i__2].r, z__[0].i = a[i__2].i;
+ i__2 = i__ + i__ * d_dim1;
+ z__[1].r = d__[i__2].r, z__[1].i = d__[i__2].i;
+ i__2 = j + j * b_dim1;
+ z__1.r = -b[i__2].r, z__1.i = -b[i__2].i;
+ z__[2].r = z__1.r, z__[2].i = z__1.i;
+ i__2 = j + j * e_dim1;
+ z__1.r = -e[i__2].r, z__1.i = -e[i__2].i;
+ z__[3].r = z__1.r, z__[3].i = z__1.i;
+
+/* Set up right hand side(s) */
+
+ i__2 = i__ + j * c_dim1;
+ rhs[0].r = c__[i__2].r, rhs[0].i = c__[i__2].i;
+ i__2 = i__ + j * f_dim1;
+ rhs[1].r = f[i__2].r, rhs[1].i = f[i__2].i;
+
+/* Solve Z * x = RHS */
+
+ zgetc2_(&c__2, z__, &c__2, ipiv, jpiv, &ierr);
+ if (ierr > 0) {
+ *info = ierr;
+ }
+ if (*ijob == 0) {
+ zgesc2_(&c__2, z__, &c__2, rhs, ipiv, jpiv, &scaloc);
+ if (scaloc != 1.) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ z__1.r = scaloc, z__1.i = 0.;
+ zscal_(m, &z__1, &c__[k * c_dim1 + 1], &c__1);
+ z__1.r = scaloc, z__1.i = 0.;
+ zscal_(m, &z__1, &f[k * f_dim1 + 1], &c__1);
+/* L10: */
+ }
+ *scale *= scaloc;
+ }
+ } else {
+ zlatdf_(ijob, &c__2, z__, &c__2, rhs, rdsum, rdscal, ipiv,
+ jpiv);
+ }
+
+/* Unpack solution vector(s) */
+
+ i__2 = i__ + j * c_dim1;
+ c__[i__2].r = rhs[0].r, c__[i__2].i = rhs[0].i;
+ i__2 = i__ + j * f_dim1;
+ f[i__2].r = rhs[1].r, f[i__2].i = rhs[1].i;
+
+/* Substitute R(I, J) and L(I, J) into remaining equation. */
+
+ if (i__ > 1) {
+ z__1.r = -rhs[0].r, z__1.i = -rhs[0].i;
+ alpha.r = z__1.r, alpha.i = z__1.i;
+ i__2 = i__ - 1;
+ zaxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &c__[j
+ * c_dim1 + 1], &c__1);
+ i__2 = i__ - 1;
+ zaxpy_(&i__2, &alpha, &d__[i__ * d_dim1 + 1], &c__1, &f[j
+ * f_dim1 + 1], &c__1);
+ }
+ if (j < *n) {
+ i__2 = *n - j;
+ zaxpy_(&i__2, &rhs[1], &b[j + (j + 1) * b_dim1], ldb, &
+ c__[i__ + (j + 1) * c_dim1], ldc);
+ i__2 = *n - j;
+ zaxpy_(&i__2, &rhs[1], &e[j + (j + 1) * e_dim1], lde, &f[
+ i__ + (j + 1) * f_dim1], ldf);
+ }
+
+/* L20: */
+ }
+/* L30: */
+ }
+ } else {
+
+/* Solve transposed (I, J) - system: */
+/* A(I, I)' * R(I, J) + D(I, I)' * L(J, J) = C(I, J) */
+/* R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) */
+/* for I = 1, 2, ..., M, J = N, N - 1, ..., 1 */
+
+ *scale = 1.;
+ scaloc = 1.;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ for (j = *n; j >= 1; --j) {
+
+/* Build 2 by 2 system Z' */
+
+ d_cnjg(&z__1, &a[i__ + i__ * a_dim1]);
+ z__[0].r = z__1.r, z__[0].i = z__1.i;
+ d_cnjg(&z__2, &b[j + j * b_dim1]);
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ z__[1].r = z__1.r, z__[1].i = z__1.i;
+ d_cnjg(&z__1, &d__[i__ + i__ * d_dim1]);
+ z__[2].r = z__1.r, z__[2].i = z__1.i;
+ d_cnjg(&z__2, &e[j + j * e_dim1]);
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ z__[3].r = z__1.r, z__[3].i = z__1.i;
+
+
+/* Set up right hand side(s) */
+
+ i__2 = i__ + j * c_dim1;
+ rhs[0].r = c__[i__2].r, rhs[0].i = c__[i__2].i;
+ i__2 = i__ + j * f_dim1;
+ rhs[1].r = f[i__2].r, rhs[1].i = f[i__2].i;
+
+/* Solve Z' * x = RHS */
+
+ zgetc2_(&c__2, z__, &c__2, ipiv, jpiv, &ierr);
+ if (ierr > 0) {
+ *info = ierr;
+ }
+ zgesc2_(&c__2, z__, &c__2, rhs, ipiv, jpiv, &scaloc);
+ if (scaloc != 1.) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ z__1.r = scaloc, z__1.i = 0.;
+ zscal_(m, &z__1, &c__[k * c_dim1 + 1], &c__1);
+ z__1.r = scaloc, z__1.i = 0.;
+ zscal_(m, &z__1, &f[k * f_dim1 + 1], &c__1);
+/* L40: */
+ }
+ *scale *= scaloc;
+ }
+
+/* Unpack solution vector(s) */
+
+ i__2 = i__ + j * c_dim1;
+ c__[i__2].r = rhs[0].r, c__[i__2].i = rhs[0].i;
+ i__2 = i__ + j * f_dim1;
+ f[i__2].r = rhs[1].r, f[i__2].i = rhs[1].i;
+
+/* Substitute R(I, J) and L(I, J) into remaining equation. */
+
+ i__2 = j - 1;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = i__ + k * f_dim1;
+ i__4 = i__ + k * f_dim1;
+ d_cnjg(&z__4, &b[k + j * b_dim1]);
+ z__3.r = rhs[0].r * z__4.r - rhs[0].i * z__4.i, z__3.i =
+ rhs[0].r * z__4.i + rhs[0].i * z__4.r;
+ z__2.r = f[i__4].r + z__3.r, z__2.i = f[i__4].i + z__3.i;
+ d_cnjg(&z__6, &e[k + j * e_dim1]);
+ z__5.r = rhs[1].r * z__6.r - rhs[1].i * z__6.i, z__5.i =
+ rhs[1].r * z__6.i + rhs[1].i * z__6.r;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+ f[i__3].r = z__1.r, f[i__3].i = z__1.i;
+/* L50: */
+ }
+ i__2 = *m;
+ for (k = i__ + 1; k <= i__2; ++k) {
+ i__3 = k + j * c_dim1;
+ i__4 = k + j * c_dim1;
+ d_cnjg(&z__4, &a[i__ + k * a_dim1]);
+ z__3.r = z__4.r * rhs[0].r - z__4.i * rhs[0].i, z__3.i =
+ z__4.r * rhs[0].i + z__4.i * rhs[0].r;
+ z__2.r = c__[i__4].r - z__3.r, z__2.i = c__[i__4].i -
+ z__3.i;
+ d_cnjg(&z__6, &d__[i__ + k * d_dim1]);
+ z__5.r = z__6.r * rhs[1].r - z__6.i * rhs[1].i, z__5.i =
+ z__6.r * rhs[1].i + z__6.i * rhs[1].r;
+ z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - z__5.i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L60: */
+ }
+
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+ return 0;
+
+/* End of ZTGSY2 */
+
+} /* ztgsy2_ */
diff --git a/SRC/ztgsyl.c b/SRC/ztgsyl.c
new file mode 100644
index 0000000..9829b40
--- /dev/null
+++ b/SRC/ztgsyl.c
@@ -0,0 +1,695 @@
+/* ztgsyl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__5 = 5;
+static integer c__1 = 1;
+static doublecomplex c_b44 = {-1.,0.};
+static doublecomplex c_b45 = {1.,0.};
+
+/* Subroutine */ int ztgsyl_(char *trans, integer *ijob, integer *m, integer *
+ n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *c__, integer *ldc, doublecomplex *d__, integer *ldd,
+ doublecomplex *e, integer *lde, doublecomplex *f, integer *ldf,
+ doublereal *scale, doublereal *dif, doublecomplex *work, integer *
+ lwork, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
+ d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3,
+ i__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j, k, p, q, ie, je, mb, nb, is, js, pq;
+ doublereal dsum;
+ extern logical lsame_(char *, char *);
+ integer ifunc, linfo;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zgemm_(char *, char *, integer *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer lwmin;
+ doublereal scale2, dscale;
+ extern /* Subroutine */ int ztgsy2_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ doublereal scaloc;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer iround;
+ logical notran;
+ integer isolve;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *);
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTGSYL solves the generalized Sylvester equation: */
+
+/* A * R - L * B = scale * C (1) */
+/* D * R - L * E = scale * F */
+
+/* where R and L are unknown m-by-n matrices, (A, D), (B, E) and */
+/* (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n, */
+/* respectively, with complex entries. A, B, D and E are upper */
+/* triangular (i.e., (A,D) and (B,E) in generalized Schur form). */
+
+/* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 */
+/* is an output scaling factor chosen to avoid overflow. */
+
+/* In matrix notation (1) is equivalent to solve Zx = scale*b, where Z */
+/* is defined as */
+
+/* Z = [ kron(In, A) -kron(B', Im) ] (2) */
+/* [ kron(In, D) -kron(E', Im) ], */
+
+/* Here Ix is the identity matrix of size x and X' is the conjugate */
+/* transpose of X. Kron(X, Y) is the Kronecker product between the */
+/* matrices X and Y. */
+
+/* If TRANS = 'C', y in the conjugate transposed system Z'*y = scale*b */
+/* is solved for, which is equivalent to solve for R and L in */
+
+/* A' * R + D' * L = scale * C (3) */
+/* R * B' + L * E' = scale * -F */
+
+/* This case (TRANS = 'C') is used to compute an one-norm-based estimate */
+/* of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D) */
+/* and (B,E), using ZLACON. */
+
+/* If IJOB >= 1, ZTGSYL computes a Frobenius norm-based estimate of */
+/* Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the */
+/* reciprocal of the smallest singular value of Z. */
+
+/* This is a level-3 BLAS algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': solve the generalized sylvester equation (1). */
+/* = 'C': solve the "conjugate transposed" system (3). */
+
+/* IJOB (input) INTEGER */
+/* Specifies what kind of functionality to be performed. */
+/* =0: solve (1) only. */
+/* =1: The functionality of 0 and 3. */
+/* =2: The functionality of 0 and 4. */
+/* =3: Only an estimate of Dif[(A,D), (B,E)] is computed. */
+/* (look ahead strategy is used). */
+/* =4: Only an estimate of Dif[(A,D), (B,E)] is computed. */
+/* (ZGECON on sub-systems is used). */
+/* Not referenced if TRANS = 'C'. */
+
+/* M (input) INTEGER */
+/* The order of the matrices A and D, and the row dimension of */
+/* the matrices C, F, R and L. */
+
+/* N (input) INTEGER */
+/* The order of the matrices B and E, and the column dimension */
+/* of the matrices C, F, R and L. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA, M) */
+/* The upper triangular matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1, M). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB, N) */
+/* The upper triangular matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1, N). */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC, N) */
+/* On entry, C contains the right-hand-side of the first matrix */
+/* equation in (1) or (3). */
+/* On exit, if IJOB = 0, 1 or 2, C has been overwritten by */
+/* the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R, */
+/* the solution achieved during the computation of the */
+/* Dif-estimate. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1, M). */
+
+/* D (input) COMPLEX*16 array, dimension (LDD, M) */
+/* The upper triangular matrix D. */
+
+/* LDD (input) INTEGER */
+/* The leading dimension of the array D. LDD >= max(1, M). */
+
+/* E (input) COMPLEX*16 array, dimension (LDE, N) */
+/* The upper triangular matrix E. */
+
+/* LDE (input) INTEGER */
+/* The leading dimension of the array E. LDE >= max(1, N). */
+
+/* F (input/output) COMPLEX*16 array, dimension (LDF, N) */
+/* On entry, F contains the right-hand-side of the second matrix */
+/* equation in (1) or (3). */
+/* On exit, if IJOB = 0, 1 or 2, F has been overwritten by */
+/* the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L, */
+/* the solution achieved during the computation of the */
+/* Dif-estimate. */
+
+/* LDF (input) INTEGER */
+/* The leading dimension of the array F. LDF >= max(1, M). */
+
+/* DIF (output) DOUBLE PRECISION */
+/* On exit DIF is the reciprocal of a lower bound of the */
+/* reciprocal of the Dif-function, i.e. DIF is an upper bound of */
+/* Dif[(A,D), (B,E)] = sigma-min(Z), where Z as in (2). */
+/* IF IJOB = 0 or TRANS = 'C', DIF is not referenced. */
+
+/* SCALE (output) DOUBLE PRECISION */
+/* On exit SCALE is the scaling factor in (1) or (3). */
+/* If 0 < SCALE < 1, C and F hold the solutions R and L, resp., */
+/* to a slightly perturbed system but the input matrices A, B, */
+/* D and E have not been changed. If SCALE = 0, R and L will */
+/* hold the solutions to the homogenious system with C = F = 0. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK > = 1. */
+/* If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N). */
+
+/* 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. */
+
+/* IWORK (workspace) INTEGER array, dimension (M+N+2) */
+
+/* INFO (output) INTEGER */
+/* =0: successful exit */
+/* <0: If INFO = -i, the i-th argument had an illegal value. */
+/* >0: (A, D) and (B, E) have common or very close */
+/* eigenvalues. */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
+/* Umea University, S-901 87 Umea, Sweden. */
+
+/* [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */
+/* for Solving the Generalized Sylvester Equation and Estimating the */
+/* Separation between Regular Matrix Pairs, Report UMINF - 93.23, */
+/* Department of Computing Science, Umea University, S-901 87 Umea, */
+/* Sweden, December 1993, Revised April 1994, Also as LAPACK Working */
+/* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, */
+/* No 1, 1996. */
+
+/* [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester */
+/* Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal. */
+/* Appl., 15(4):1045-1060, 1994. */
+
+/* [3] B. Kagstrom and L. Westin, Generalized Schur Methods with */
+/* Condition Estimators for Solving the Generalized Sylvester */
+/* Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7, */
+/* July 1989, pp 745-751. */
+
+/* ===================================================================== */
+/* Replaced various illegal calls to CCOPY by calls to CLASET. */
+/* Sven Hammarling, 1/5/02. */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ d_dim1 = *ldd;
+ d_offset = 1 + d_dim1;
+ d__ -= d_offset;
+ e_dim1 = *lde;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ f_dim1 = *ldf;
+ f_offset = 1 + f_dim1;
+ f -= f_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+ if (! notran && ! lsame_(trans, "C")) {
+ *info = -1;
+ } else if (notran) {
+ if (*ijob < 0 || *ijob > 4) {
+ *info = -2;
+ }
+ }
+ if (*info == 0) {
+ if (*m <= 0) {
+ *info = -3;
+ } else if (*n <= 0) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ } else if (*ldd < max(1,*m)) {
+ *info = -12;
+ } else if (*lde < max(1,*n)) {
+ *info = -14;
+ } else if (*ldf < max(1,*m)) {
+ *info = -16;
+ }
+ }
+
+ if (*info == 0) {
+ if (notran) {
+ if (*ijob == 1 || *ijob == 2) {
+/* Computing MAX */
+ i__1 = 1, i__2 = (*m << 1) * *n;
+ lwmin = max(i__1,i__2);
+ } else {
+ lwmin = 1;
+ }
+ } else {
+ lwmin = 1;
+ }
+ work[1].r = (doublereal) lwmin, work[1].i = 0.;
+
+ if (*lwork < lwmin && ! lquery) {
+ *info = -20;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTGSYL", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ *scale = 1.;
+ if (notran) {
+ if (*ijob != 0) {
+ *dif = 0.;
+ }
+ }
+ return 0;
+ }
+
+/* Determine optimal block sizes MB and NB */
+
+ mb = ilaenv_(&c__2, "ZTGSYL", trans, m, n, &c_n1, &c_n1);
+ nb = ilaenv_(&c__5, "ZTGSYL", trans, m, n, &c_n1, &c_n1);
+
+ isolve = 1;
+ ifunc = 0;
+ if (notran) {
+ if (*ijob >= 3) {
+ ifunc = *ijob - 2;
+ zlaset_("F", m, n, &c_b1, &c_b1, &c__[c_offset], ldc);
+ zlaset_("F", m, n, &c_b1, &c_b1, &f[f_offset], ldf);
+ } else if (*ijob >= 1 && notran) {
+ isolve = 2;
+ }
+ }
+
+ if (mb <= 1 && nb <= 1 || mb >= *m && nb >= *n) {
+
+/* Use unblocked Level 2 solver */
+
+ i__1 = isolve;
+ for (iround = 1; iround <= i__1; ++iround) {
+
+ *scale = 1.;
+ dscale = 0.;
+ dsum = 1.;
+ pq = *m * *n;
+ ztgsy2_(trans, &ifunc, m, n, &a[a_offset], lda, &b[b_offset], ldb,
+ &c__[c_offset], ldc, &d__[d_offset], ldd, &e[e_offset],
+ lde, &f[f_offset], ldf, scale, &dsum, &dscale, info);
+ if (dscale != 0.) {
+ if (*ijob == 1 || *ijob == 3) {
+ *dif = sqrt((doublereal) ((*m << 1) * *n)) / (dscale *
+ sqrt(dsum));
+ } else {
+ *dif = sqrt((doublereal) pq) / (dscale * sqrt(dsum));
+ }
+ }
+ if (isolve == 2 && iround == 1) {
+ if (notran) {
+ ifunc = *ijob;
+ }
+ scale2 = *scale;
+ zlacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m);
+ zlacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m);
+ zlaset_("F", m, n, &c_b1, &c_b1, &c__[c_offset], ldc);
+ zlaset_("F", m, n, &c_b1, &c_b1, &f[f_offset], ldf)
+ ;
+ } else if (isolve == 2 && iround == 2) {
+ zlacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc);
+ zlacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf);
+ *scale = scale2;
+ }
+/* L30: */
+ }
+
+ return 0;
+
+ }
+
+/* Determine block structure of A */
+
+ p = 0;
+ i__ = 1;
+L40:
+ if (i__ > *m) {
+ goto L50;
+ }
+ ++p;
+ iwork[p] = i__;
+ i__ += mb;
+ if (i__ >= *m) {
+ goto L50;
+ }
+ goto L40;
+L50:
+ iwork[p + 1] = *m + 1;
+ if (iwork[p] == iwork[p + 1]) {
+ --p;
+ }
+
+/* Determine block structure of B */
+
+ q = p + 1;
+ j = 1;
+L60:
+ if (j > *n) {
+ goto L70;
+ }
+
+ ++q;
+ iwork[q] = j;
+ j += nb;
+ if (j >= *n) {
+ goto L70;
+ }
+ goto L60;
+
+L70:
+ iwork[q + 1] = *n + 1;
+ if (iwork[q] == iwork[q + 1]) {
+ --q;
+ }
+
+ if (notran) {
+ i__1 = isolve;
+ for (iround = 1; iround <= i__1; ++iround) {
+
+/* Solve (I, J) - subsystem */
+/* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) */
+/* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) */
+/* for I = P, P - 1, ..., 1; J = 1, 2, ..., Q */
+
+ pq = 0;
+ *scale = 1.;
+ dscale = 0.;
+ dsum = 1.;
+ i__2 = q;
+ for (j = p + 2; j <= i__2; ++j) {
+ js = iwork[j];
+ je = iwork[j + 1] - 1;
+ nb = je - js + 1;
+ for (i__ = p; i__ >= 1; --i__) {
+ is = iwork[i__];
+ ie = iwork[i__ + 1] - 1;
+ mb = ie - is + 1;
+ ztgsy2_(trans, &ifunc, &mb, &nb, &a[is + is * a_dim1],
+ lda, &b[js + js * b_dim1], ldb, &c__[is + js *
+ c_dim1], ldc, &d__[is + is * d_dim1], ldd, &e[js
+ + js * e_dim1], lde, &f[is + js * f_dim1], ldf, &
+ scaloc, &dsum, &dscale, &linfo);
+ if (linfo > 0) {
+ *info = linfo;
+ }
+ pq += mb * nb;
+ if (scaloc != 1.) {
+ i__3 = js - 1;
+ for (k = 1; k <= i__3; ++k) {
+ z__1.r = scaloc, z__1.i = 0.;
+ zscal_(m, &z__1, &c__[k * c_dim1 + 1], &c__1);
+ z__1.r = scaloc, z__1.i = 0.;
+ zscal_(m, &z__1, &f[k * f_dim1 + 1], &c__1);
+/* L80: */
+ }
+ i__3 = je;
+ for (k = js; k <= i__3; ++k) {
+ i__4 = is - 1;
+ z__1.r = scaloc, z__1.i = 0.;
+ zscal_(&i__4, &z__1, &c__[k * c_dim1 + 1], &c__1);
+ i__4 = is - 1;
+ z__1.r = scaloc, z__1.i = 0.;
+ zscal_(&i__4, &z__1, &f[k * f_dim1 + 1], &c__1);
+/* L90: */
+ }
+ i__3 = je;
+ for (k = js; k <= i__3; ++k) {
+ i__4 = *m - ie;
+ z__1.r = scaloc, z__1.i = 0.;
+ zscal_(&i__4, &z__1, &c__[ie + 1 + k * c_dim1], &
+ c__1);
+ i__4 = *m - ie;
+ z__1.r = scaloc, z__1.i = 0.;
+ zscal_(&i__4, &z__1, &f[ie + 1 + k * f_dim1], &
+ c__1);
+/* L100: */
+ }
+ i__3 = *n;
+ for (k = je + 1; k <= i__3; ++k) {
+ z__1.r = scaloc, z__1.i = 0.;
+ zscal_(m, &z__1, &c__[k * c_dim1 + 1], &c__1);
+ z__1.r = scaloc, z__1.i = 0.;
+ zscal_(m, &z__1, &f[k * f_dim1 + 1], &c__1);
+/* L110: */
+ }
+ *scale *= scaloc;
+ }
+
+/* Substitute R(I,J) and L(I,J) into remaining equation. */
+
+ if (i__ > 1) {
+ i__3 = is - 1;
+ zgemm_("N", "N", &i__3, &nb, &mb, &c_b44, &a[is *
+ a_dim1 + 1], lda, &c__[is + js * c_dim1], ldc,
+ &c_b45, &c__[js * c_dim1 + 1], ldc);
+ i__3 = is - 1;
+ zgemm_("N", "N", &i__3, &nb, &mb, &c_b44, &d__[is *
+ d_dim1 + 1], ldd, &c__[is + js * c_dim1], ldc,
+ &c_b45, &f[js * f_dim1 + 1], ldf);
+ }
+ if (j < q) {
+ i__3 = *n - je;
+ zgemm_("N", "N", &mb, &i__3, &nb, &c_b45, &f[is + js *
+ f_dim1], ldf, &b[js + (je + 1) * b_dim1],
+ ldb, &c_b45, &c__[is + (je + 1) * c_dim1],
+ ldc);
+ i__3 = *n - je;
+ zgemm_("N", "N", &mb, &i__3, &nb, &c_b45, &f[is + js *
+ f_dim1], ldf, &e[js + (je + 1) * e_dim1],
+ lde, &c_b45, &f[is + (je + 1) * f_dim1], ldf);
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+ if (dscale != 0.) {
+ if (*ijob == 1 || *ijob == 3) {
+ *dif = sqrt((doublereal) ((*m << 1) * *n)) / (dscale *
+ sqrt(dsum));
+ } else {
+ *dif = sqrt((doublereal) pq) / (dscale * sqrt(dsum));
+ }
+ }
+ if (isolve == 2 && iround == 1) {
+ if (notran) {
+ ifunc = *ijob;
+ }
+ scale2 = *scale;
+ zlacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m);
+ zlacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m);
+ zlaset_("F", m, n, &c_b1, &c_b1, &c__[c_offset], ldc);
+ zlaset_("F", m, n, &c_b1, &c_b1, &f[f_offset], ldf)
+ ;
+ } else if (isolve == 2 && iround == 2) {
+ zlacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc);
+ zlacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf);
+ *scale = scale2;
+ }
+/* L150: */
+ }
+ } else {
+
+/* Solve transposed (I, J)-subsystem */
+/* A(I, I)' * R(I, J) + D(I, I)' * L(I, J) = C(I, J) */
+/* R(I, J) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) */
+/* for I = 1,2,..., P; J = Q, Q-1,..., 1 */
+
+ *scale = 1.;
+ i__1 = p;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ is = iwork[i__];
+ ie = iwork[i__ + 1] - 1;
+ mb = ie - is + 1;
+ i__2 = p + 2;
+ for (j = q; j >= i__2; --j) {
+ js = iwork[j];
+ je = iwork[j + 1] - 1;
+ nb = je - js + 1;
+ ztgsy2_(trans, &ifunc, &mb, &nb, &a[is + is * a_dim1], lda, &
+ b[js + js * b_dim1], ldb, &c__[is + js * c_dim1], ldc,
+ &d__[is + is * d_dim1], ldd, &e[js + js * e_dim1],
+ lde, &f[is + js * f_dim1], ldf, &scaloc, &dsum, &
+ dscale, &linfo);
+ if (linfo > 0) {
+ *info = linfo;
+ }
+ if (scaloc != 1.) {
+ i__3 = js - 1;
+ for (k = 1; k <= i__3; ++k) {
+ z__1.r = scaloc, z__1.i = 0.;
+ zscal_(m, &z__1, &c__[k * c_dim1 + 1], &c__1);
+ z__1.r = scaloc, z__1.i = 0.;
+ zscal_(m, &z__1, &f[k * f_dim1 + 1], &c__1);
+/* L160: */
+ }
+ i__3 = je;
+ for (k = js; k <= i__3; ++k) {
+ i__4 = is - 1;
+ z__1.r = scaloc, z__1.i = 0.;
+ zscal_(&i__4, &z__1, &c__[k * c_dim1 + 1], &c__1);
+ i__4 = is - 1;
+ z__1.r = scaloc, z__1.i = 0.;
+ zscal_(&i__4, &z__1, &f[k * f_dim1 + 1], &c__1);
+/* L170: */
+ }
+ i__3 = je;
+ for (k = js; k <= i__3; ++k) {
+ i__4 = *m - ie;
+ z__1.r = scaloc, z__1.i = 0.;
+ zscal_(&i__4, &z__1, &c__[ie + 1 + k * c_dim1], &c__1)
+ ;
+ i__4 = *m - ie;
+ z__1.r = scaloc, z__1.i = 0.;
+ zscal_(&i__4, &z__1, &f[ie + 1 + k * f_dim1], &c__1);
+/* L180: */
+ }
+ i__3 = *n;
+ for (k = je + 1; k <= i__3; ++k) {
+ z__1.r = scaloc, z__1.i = 0.;
+ zscal_(m, &z__1, &c__[k * c_dim1 + 1], &c__1);
+ z__1.r = scaloc, z__1.i = 0.;
+ zscal_(m, &z__1, &f[k * f_dim1 + 1], &c__1);
+/* L190: */
+ }
+ *scale *= scaloc;
+ }
+
+/* Substitute R(I,J) and L(I,J) into remaining equation. */
+
+ if (j > p + 2) {
+ i__3 = js - 1;
+ zgemm_("N", "C", &mb, &i__3, &nb, &c_b45, &c__[is + js *
+ c_dim1], ldc, &b[js * b_dim1 + 1], ldb, &c_b45, &
+ f[is + f_dim1], ldf);
+ i__3 = js - 1;
+ zgemm_("N", "C", &mb, &i__3, &nb, &c_b45, &f[is + js *
+ f_dim1], ldf, &e[js * e_dim1 + 1], lde, &c_b45, &
+ f[is + f_dim1], ldf);
+ }
+ if (i__ < p) {
+ i__3 = *m - ie;
+ zgemm_("C", "N", &i__3, &nb, &mb, &c_b44, &a[is + (ie + 1)
+ * a_dim1], lda, &c__[is + js * c_dim1], ldc, &
+ c_b45, &c__[ie + 1 + js * c_dim1], ldc);
+ i__3 = *m - ie;
+ zgemm_("C", "N", &i__3, &nb, &mb, &c_b44, &d__[is + (ie +
+ 1) * d_dim1], ldd, &f[is + js * f_dim1], ldf, &
+ c_b45, &c__[ie + 1 + js * c_dim1], ldc);
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+ }
+
+ work[1].r = (doublereal) lwmin, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZTGSYL */
+
+} /* ztgsyl_ */
diff --git a/SRC/ztpcon.c b/SRC/ztpcon.c
new file mode 100644
index 0000000..746b731
--- /dev/null
+++ b/SRC/ztpcon.c
@@ -0,0 +1,242 @@
+/* ztpcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ztpcon_(char *norm, char *uplo, char *diag, integer *n,
+ doublecomplex *ap, doublereal *rcond, doublecomplex *work, doublereal
+ *rwork, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer ix, kase, kase1;
+ doublereal scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ doublereal anorm;
+ logical upper;
+ doublereal xnorm;
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal ainvnm;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ logical onenrm;
+ extern /* Subroutine */ int zdrscl_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ char normin[1];
+ extern doublereal zlantp_(char *, char *, char *, integer *,
+ doublecomplex *, doublereal *);
+ doublereal smlnum;
+ logical nounit;
+ extern /* Subroutine */ int zlatps_(char *, char *, char *, char *,
+ integer *, doublecomplex *, doublecomplex *, doublereal *,
+ doublereal *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTPCON estimates the reciprocal of the condition number of a packed */
+/* triangular matrix A, in either the 1-norm or the infinity-norm. */
+
+/* The norm of A is computed and an estimate is obtained for */
+/* norm(inv(A)), then the reciprocal of the condition number is */
+/* computed as */
+/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ nounit = lsame_(diag, "N");
+
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTPCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ }
+
+ *rcond = 0.;
+ smlnum = dlamch_("Safe minimum") * (doublereal) max(1,*n);
+
+/* Compute the norm of the triangular matrix A. */
+
+ anorm = zlantp_(norm, uplo, diag, n, &ap[1], &rwork[1]);
+
+/* Continue only if ANORM > 0. */
+
+ if (anorm > 0.) {
+
+/* Estimate the norm of the inverse of A. */
+
+ ainvnm = 0.;
+ *(unsigned char *)normin = 'N';
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kase = 0;
+L10:
+ zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(A). */
+
+ zlatps_(uplo, "No transpose", diag, normin, n, &ap[1], &work[
+ 1], &scale, &rwork[1], info);
+ } else {
+
+/* Multiply by inv(A'). */
+
+ zlatps_(uplo, "Conjugate transpose", diag, normin, n, &ap[1],
+ &work[1], &scale, &rwork[1], info);
+ }
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ if (scale != 1.) {
+ ix = izamax_(n, &work[1], &c__1);
+ i__1 = ix;
+ xnorm = (d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(&
+ work[ix]), abs(d__2));
+ if (scale < xnorm * smlnum || scale == 0.) {
+ goto L20;
+ }
+ zdrscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / anorm / ainvnm;
+ }
+ }
+
+L20:
+ return 0;
+
+/* End of ZTPCON */
+
+} /* ztpcon_ */
diff --git a/SRC/ztprfs.c b/SRC/ztprfs.c
new file mode 100644
index 0000000..43df67b
--- /dev/null
+++ b/SRC/ztprfs.c
@@ -0,0 +1,561 @@
+/* ztprfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ztprfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublecomplex *ap, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr,
+ doublecomplex *work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal s;
+ integer kc;
+ doublereal xk;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), ztpmv_(
+ char *, char *, char *, integer *, doublecomplex *, doublecomplex
+ *, integer *), ztpsv_(char *, char *,
+ char *, integer *, doublecomplex *, doublecomplex *, integer *), zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+ char transn[1], transt[1];
+ logical nounit;
+ doublereal lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTPRFS provides error bounds and backward error estimates for the */
+/* solution to a system of linear equations with a triangular packed */
+/* coefficient matrix. */
+
+/* The solution matrix X must be computed by ZTPTRS or some other */
+/* means before entering this routine. ZTPRFS does not do iterative */
+/* refinement because doing so cannot improve the backward error. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*ldx < max(1,*n)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTPRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transn = 'N';
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transn = 'C';
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A, A**T, or A**H, depending on TRANS. */
+
+ zcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ztpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1);
+ z__1.r = -1., z__1.i = -0.;
+ zaxpy_(n, &z__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
+ i__ + j * b_dim1]), abs(d__2));
+/* L20: */
+ }
+
+ if (notran) {
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ kc = 1;
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&
+ x[k + j * x_dim1]), abs(d__2));
+ i__3 = k;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = kc + i__ - 1;
+ rwork[i__] += ((d__1 = ap[i__4].r, abs(d__1)) + (
+ d__2 = d_imag(&ap[kc + i__ - 1]), abs(
+ d__2))) * xk;
+/* L30: */
+ }
+ kc += k;
+/* L40: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&
+ x[k + j * x_dim1]), abs(d__2));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = kc + i__ - 1;
+ rwork[i__] += ((d__1 = ap[i__4].r, abs(d__1)) + (
+ d__2 = d_imag(&ap[kc + i__ - 1]), abs(
+ d__2))) * xk;
+/* L50: */
+ }
+ rwork[k] += xk;
+ kc += k;
+/* L60: */
+ }
+ }
+ } else {
+ kc = 1;
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&
+ x[k + j * x_dim1]), abs(d__2));
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ i__4 = kc + i__ - k;
+ rwork[i__] += ((d__1 = ap[i__4].r, abs(d__1)) + (
+ d__2 = d_imag(&ap[kc + i__ - k]), abs(
+ d__2))) * xk;
+/* L70: */
+ }
+ kc = kc + *n - k + 1;
+/* L80: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&
+ x[k + j * x_dim1]), abs(d__2));
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ i__4 = kc + i__ - k;
+ rwork[i__] += ((d__1 = ap[i__4].r, abs(d__1)) + (
+ d__2 = d_imag(&ap[kc + i__ - k]), abs(
+ d__2))) * xk;
+/* L90: */
+ }
+ rwork[k] += xk;
+ kc = kc + *n - k + 1;
+/* L100: */
+ }
+ }
+ }
+ } else {
+
+/* Compute abs(A**H)*abs(X) + abs(B). */
+
+ if (upper) {
+ kc = 1;
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__3 = k;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = kc + i__ - 1;
+ i__5 = i__ + j * x_dim1;
+ s += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&ap[kc + i__ - 1]), abs(d__2))) * (
+ (d__3 = x[i__5].r, abs(d__3)) + (d__4 =
+ d_imag(&x[i__ + j * x_dim1]), abs(d__4)));
+/* L110: */
+ }
+ rwork[k] += s;
+ kc += k;
+/* L120: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ s = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[
+ k + j * x_dim1]), abs(d__2));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = kc + i__ - 1;
+ i__5 = i__ + j * x_dim1;
+ s += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&ap[kc + i__ - 1]), abs(d__2))) * (
+ (d__3 = x[i__5].r, abs(d__3)) + (d__4 =
+ d_imag(&x[i__ + j * x_dim1]), abs(d__4)));
+/* L130: */
+ }
+ rwork[k] += s;
+ kc += k;
+/* L140: */
+ }
+ }
+ } else {
+ kc = 1;
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ i__4 = kc + i__ - k;
+ i__5 = i__ + j * x_dim1;
+ s += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&ap[kc + i__ - k]), abs(d__2))) * (
+ (d__3 = x[i__5].r, abs(d__3)) + (d__4 =
+ d_imag(&x[i__ + j * x_dim1]), abs(d__4)));
+/* L150: */
+ }
+ rwork[k] += s;
+ kc = kc + *n - k + 1;
+/* L160: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ s = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[
+ k + j * x_dim1]), abs(d__2));
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ i__4 = kc + i__ - k;
+ i__5 = i__ + j * x_dim1;
+ s += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&ap[kc + i__ - k]), abs(d__2))) * (
+ (d__3 = x[i__5].r, abs(d__3)) + (d__4 =
+ d_imag(&x[i__ + j * x_dim1]), abs(d__4)));
+/* L170: */
+ }
+ rwork[k] += s;
+ kc = kc + *n - k + 1;
+/* L180: */
+ }
+ }
+ }
+ }
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__3 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2))) / rwork[i__];
+ s = max(d__3,d__4);
+ } else {
+/* Computing MAX */
+ i__3 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = max(d__3,d__4);
+ }
+/* L190: */
+ }
+ berr[j] = s;
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use ZLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__3 = i__;
+ rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ ;
+ } else {
+ i__3 = i__;
+ rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ + safe1;
+ }
+/* L200: */
+ }
+
+ kase = 0;
+L210:
+ zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)**H). */
+
+ ztpsv_(uplo, transt, diag, n, &ap[1], &work[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L220: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L230: */
+ }
+ ztpsv_(uplo, transn, diag, n, &ap[1], &work[1], &c__1);
+ }
+ goto L210;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * x_dim1;
+ d__3 = lstres, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&x[i__ + j * x_dim1]), abs(d__2));
+ lstres = max(d__3,d__4);
+/* L240: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L250: */
+ }
+
+ return 0;
+
+/* End of ZTPRFS */
+
+} /* ztprfs_ */
diff --git a/SRC/ztptri.c b/SRC/ztptri.c
new file mode 100644
index 0000000..2081845
--- /dev/null
+++ b/SRC/ztptri.c
@@ -0,0 +1,235 @@
+/* ztptri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int ztptri_(char *uplo, char *diag, integer *n,
+ doublecomplex *ap, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer j, jc, jj;
+ doublecomplex ajj;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int ztpmv_(char *, char *, char *, integer *,
+ doublecomplex *, doublecomplex *, integer *), xerbla_(char *, integer *);
+ integer jclast;
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTPTRI computes the inverse of a complex upper or lower triangular */
+/* matrix A stored in packed format. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the upper or lower triangular matrix A, stored */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n. */
+/* See below for further details. */
+/* On exit, the (triangular) inverse of the original matrix, in */
+/* the same packed storage format. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */
+/* matrix is singular and its inverse can not be computed. */
+
+/* Further Details */
+/* =============== */
+
+/* A triangular matrix A can be transferred to packed storage using one */
+/* of the following program segments: */
+
+/* UPLO = 'U': UPLO = 'L': */
+
+/* JC = 1 JC = 1 */
+/* DO 2 J = 1, N DO 2 J = 1, N */
+/* DO 1 I = 1, J DO 1 I = J, N */
+/* AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J) */
+/* 1 CONTINUE 1 CONTINUE */
+/* JC = JC + J JC = JC + N - J + 1 */
+/* 2 CONTINUE 2 CONTINUE */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ nounit = lsame_(diag, "N");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTPTRI", &i__1);
+ return 0;
+ }
+
+/* Check for singularity if non-unit. */
+
+ if (nounit) {
+ if (upper) {
+ jj = 0;
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ jj += *info;
+ i__2 = jj;
+ if (ap[i__2].r == 0. && ap[i__2].i == 0.) {
+ return 0;
+ }
+/* L10: */
+ }
+ } else {
+ jj = 1;
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ i__2 = jj;
+ if (ap[i__2].r == 0. && ap[i__2].i == 0.) {
+ return 0;
+ }
+ jj = jj + *n - *info + 1;
+/* L20: */
+ }
+ }
+ *info = 0;
+ }
+
+ if (upper) {
+
+/* Compute inverse of upper triangular matrix. */
+
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (nounit) {
+ i__2 = jc + j - 1;
+ z_div(&z__1, &c_b1, &ap[jc + j - 1]);
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ i__2 = jc + j - 1;
+ z__1.r = -ap[i__2].r, z__1.i = -ap[i__2].i;
+ ajj.r = z__1.r, ajj.i = z__1.i;
+ } else {
+ z__1.r = -1., z__1.i = -0.;
+ ajj.r = z__1.r, ajj.i = z__1.i;
+ }
+
+/* Compute elements 1:j-1 of j-th column. */
+
+ i__2 = j - 1;
+ ztpmv_("Upper", "No transpose", diag, &i__2, &ap[1], &ap[jc], &
+ c__1);
+ i__2 = j - 1;
+ zscal_(&i__2, &ajj, &ap[jc], &c__1);
+ jc += j;
+/* L30: */
+ }
+
+ } else {
+
+/* Compute inverse of lower triangular matrix. */
+
+ jc = *n * (*n + 1) / 2;
+ for (j = *n; j >= 1; --j) {
+ if (nounit) {
+ i__1 = jc;
+ z_div(&z__1, &c_b1, &ap[jc]);
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ i__1 = jc;
+ z__1.r = -ap[i__1].r, z__1.i = -ap[i__1].i;
+ ajj.r = z__1.r, ajj.i = z__1.i;
+ } else {
+ z__1.r = -1., z__1.i = -0.;
+ ajj.r = z__1.r, ajj.i = z__1.i;
+ }
+ if (j < *n) {
+
+/* Compute elements j+1:n of j-th column. */
+
+ i__1 = *n - j;
+ ztpmv_("Lower", "No transpose", diag, &i__1, &ap[jclast], &ap[
+ jc + 1], &c__1);
+ i__1 = *n - j;
+ zscal_(&i__1, &ajj, &ap[jc + 1], &c__1);
+ }
+ jclast = jc;
+ jc = jc - *n + j - 2;
+/* L40: */
+ }
+ }
+
+ return 0;
+
+/* End of ZTPTRI */
+
+} /* ztptri_ */
diff --git a/SRC/ztptrs.c b/SRC/ztptrs.c
new file mode 100644
index 0000000..a5affa8
--- /dev/null
+++ b/SRC/ztptrs.c
@@ -0,0 +1,194 @@
+/* ztptrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ztptrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublecomplex *ap, doublecomplex *b, integer *ldb,
+ integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2;
+
+ /* Local variables */
+ integer j, jc;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int ztpsv_(char *, char *, char *, integer *,
+ doublecomplex *, doublecomplex *, integer *), xerbla_(char *, integer *);
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTPTRS solves a triangular system of the form */
+
+/* A * X = B, A**T * X = B, or A**H * X = B, */
+
+/* where A is a triangular matrix of order N stored in packed format, */
+/* and B is an N-by-NRHS matrix. A check is made to verify that A is */
+/* nonsingular. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, if INFO = 0, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element of A is zero, */
+/* indicating that the matrix is singular and the */
+/* solutions X have not been computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ nounit = lsame_(diag, "N");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTPTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check for singularity. */
+
+ if (nounit) {
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ i__2 = jc + *info - 1;
+ if (ap[i__2].r == 0. && ap[i__2].i == 0.) {
+ return 0;
+ }
+ jc += *info;
+/* L10: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ i__2 = jc;
+ if (ap[i__2].r == 0. && ap[i__2].i == 0.) {
+ return 0;
+ }
+ jc = jc + *n - *info + 1;
+/* L20: */
+ }
+ }
+ }
+ *info = 0;
+
+/* Solve A * x = b, A**T * x = b, or A**H * x = b. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ztpsv_(uplo, trans, diag, n, &ap[1], &b[j * b_dim1 + 1], &c__1);
+/* L30: */
+ }
+
+ return 0;
+
+/* End of ZTPTRS */
+
+} /* ztptrs_ */
diff --git a/SRC/ztpttf.c b/SRC/ztpttf.c
new file mode 100644
index 0000000..29d2371
--- /dev/null
+++ b/SRC/ztpttf.c
@@ -0,0 +1,573 @@
+/* ztpttf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ztpttf_(char *transr, char *uplo, integer *n,
+ doublecomplex *ap, doublecomplex *arf, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, n1, n2, ij, jp, js, nt, lda, ijp;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nisodd;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTPTTF copies a triangular matrix A from standard packed format (TP) */
+/* to rectangular full packed format (TF). */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': ARF in Normal format is wanted; */
+/* = 'C': ARF in Conjugate-transpose format is wanted. */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ), */
+/* On entry, the upper or lower triangular matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* ARF (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ), */
+/* On exit, the upper or lower triangular matrix A stored in */
+/* RFP format. For a further discussion see Notes below. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Notes: */
+/* ====== */
+
+/* We first consider Standard Packed Format when N is even. */
+/* We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* conjugate-transpose of the first three columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* conjugate-transpose of the last three columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N even and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- -- */
+/* 03 04 05 33 43 53 */
+/* -- -- */
+/* 13 14 15 00 44 54 */
+/* -- */
+/* 23 24 25 10 11 55 */
+
+/* 33 34 35 20 21 22 */
+/* -- */
+/* 00 44 45 30 31 32 */
+/* -- -- */
+/* 01 11 55 40 41 42 */
+/* -- -- -- */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We next consider Standard Packed Format when N is odd. */
+/* We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = 'N'. RFP holds AP as follows: */
+/* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* conjugate-transpose of the first two columns of AP upper. */
+/* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* conjugate-transpose of the last two columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N odd and TRANSR = 'N'. */
+
+/* RFP A RFP A */
+
+/* -- -- */
+/* 02 03 04 00 33 43 */
+/* -- */
+/* 12 13 14 10 11 44 */
+
+/* 22 23 24 20 21 22 */
+/* -- */
+/* 00 33 34 30 31 32 */
+/* -- -- */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- */
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "C")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTPTTF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (normaltransr) {
+ arf[0].r = ap[0].r, arf[0].i = ap[0].i;
+ } else {
+ d_cnjg(&z__1, ap);
+ arf[0].r = z__1.r, arf[0].i = z__1.i;
+ }
+ return 0;
+ }
+
+/* Size of array ARF(0:NT-1) */
+
+ nt = *n * (*n + 1) / 2;
+
+/* Set N1 and N2 depending on LOWER */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* If N is odd, set NISODD = .TRUE. */
+/* If N is even, set K = N/2 and NISODD = .FALSE. */
+
+/* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) */
+/* where noe = 0 if n is even, noe = 1 if n is odd */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ lda = *n + 1;
+ } else {
+ nisodd = TRUE_;
+ lda = *n;
+ }
+
+/* ARF^C has lda rows and n+1-noe cols */
+
+ if (! normaltransr) {
+ lda = (*n + 1) / 2;
+ }
+
+/* start execution: there are eight cases */
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */
+/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */
+/* T1 -> a(0), T2 -> a(n), S -> a(n1); lda = n */
+
+ ijp = 0;
+ jp = 0;
+ i__1 = n2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ij = i__ + jp;
+ i__3 = ij;
+ i__4 = ijp;
+ arf[i__3].r = ap[i__4].r, arf[i__3].i = ap[i__4].i;
+ ++ijp;
+ }
+ jp += lda;
+ }
+ i__1 = n2 - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = n2;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ ij = i__ + j * lda;
+ i__3 = ij;
+ d_cnjg(&z__1, &ap[ijp]);
+ arf[i__3].r = z__1.r, arf[i__3].i = z__1.i;
+ ++ijp;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */
+/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */
+/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */
+
+ ijp = 0;
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ ij = n2 + j;
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ d_cnjg(&z__1, &ap[ijp]);
+ arf[i__3].r = z__1.r, arf[i__3].i = z__1.i;
+ ++ijp;
+ ij += lda;
+ }
+ }
+ js = 0;
+ i__1 = *n - 1;
+ for (j = n1; j <= i__1; ++j) {
+ ij = js;
+ i__2 = js + j;
+ for (ij = js; ij <= i__2; ++ij) {
+ i__3 = ij;
+ i__4 = ijp;
+ arf[i__3].r = ap[i__4].r, arf[i__3].i = ap[i__4].i;
+ ++ijp;
+ }
+ js += lda;
+ }
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is odd */
+/* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */
+/* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 */
+
+ ijp = 0;
+ i__1 = n2;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = *n * lda - 1;
+ i__3 = lda;
+ for (ij = i__ * (lda + 1); i__3 < 0 ? ij >= i__2 : ij <=
+ i__2; ij += i__3) {
+ i__4 = ij;
+ d_cnjg(&z__1, &ap[ijp]);
+ arf[i__4].r = z__1.r, arf[i__4].i = z__1.i;
+ ++ijp;
+ }
+ }
+ js = 1;
+ i__1 = n2 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + n2 - j - 1;
+ for (ij = js; ij <= i__3; ++ij) {
+ i__2 = ij;
+ i__4 = ijp;
+ arf[i__2].r = ap[i__4].r, arf[i__2].i = ap[i__4].i;
+ ++ijp;
+ }
+ js = js + lda + 1;
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is odd */
+/* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */
+/* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 */
+
+ ijp = 0;
+ js = n2 * lda;
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + j;
+ for (ij = js; ij <= i__3; ++ij) {
+ i__2 = ij;
+ i__4 = ijp;
+ arf[i__2].r = ap[i__4].r, arf[i__2].i = ap[i__4].i;
+ ++ijp;
+ }
+ js += lda;
+ }
+ i__1 = n1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__3 = i__ + (n1 + i__) * lda;
+ i__2 = lda;
+ for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij +=
+ i__2) {
+ i__4 = ij;
+ d_cnjg(&z__1, &ap[ijp]);
+ arf[i__4].r = z__1.r, arf[i__4].i = z__1.i;
+ ++ijp;
+ }
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
+/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */
+
+ ijp = 0;
+ jp = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ij = i__ + 1 + jp;
+ i__3 = ij;
+ i__4 = ijp;
+ arf[i__3].r = ap[i__4].r, arf[i__3].i = ap[i__4].i;
+ ++ijp;
+ }
+ jp += lda;
+ }
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = k - 1;
+ for (j = i__; j <= i__2; ++j) {
+ ij = i__ + j * lda;
+ i__3 = ij;
+ d_cnjg(&z__1, &ap[ijp]);
+ arf[i__3].r = z__1.r, arf[i__3].i = z__1.i;
+ ++ijp;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
+/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */
+
+ ijp = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ ij = k + 1 + j;
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ d_cnjg(&z__1, &ap[ijp]);
+ arf[i__3].r = z__1.r, arf[i__3].i = z__1.i;
+ ++ijp;
+ ij += lda;
+ }
+ }
+ js = 0;
+ i__1 = *n - 1;
+ for (j = k; j <= i__1; ++j) {
+ ij = js;
+ i__2 = js + j;
+ for (ij = js; ij <= i__2; ++ij) {
+ i__3 = ij;
+ i__4 = ijp;
+ arf[i__3].r = ap[i__4].r, arf[i__3].i = ap[i__4].i;
+ ++ijp;
+ }
+ js += lda;
+ }
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */
+/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */
+
+ ijp = 0;
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = (*n + 1) * lda - 1;
+ i__3 = lda;
+ for (ij = i__ + (i__ + 1) * lda; i__3 < 0 ? ij >= i__2 :
+ ij <= i__2; ij += i__3) {
+ i__4 = ij;
+ d_cnjg(&z__1, &ap[ijp]);
+ arf[i__4].r = z__1.r, arf[i__4].i = z__1.i;
+ ++ijp;
+ }
+ }
+ js = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + k - j - 1;
+ for (ij = js; ij <= i__3; ++ij) {
+ i__2 = ij;
+ i__4 = ijp;
+ arf[i__2].r = ap[i__4].r, arf[i__2].i = ap[i__4].i;
+ ++ijp;
+ }
+ js = js + lda + 1;
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */
+/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */
+/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */
+
+ ijp = 0;
+ js = (k + 1) * lda;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__3 = js + j;
+ for (ij = js; ij <= i__3; ++ij) {
+ i__2 = ij;
+ i__4 = ijp;
+ arf[i__2].r = ap[i__4].r, arf[i__2].i = ap[i__4].i;
+ ++ijp;
+ }
+ js += lda;
+ }
+ i__1 = k - 1;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__3 = i__ + (k + i__) * lda;
+ i__2 = lda;
+ for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij +=
+ i__2) {
+ i__4 = ij;
+ d_cnjg(&z__1, &ap[ijp]);
+ arf[i__4].r = z__1.r, arf[i__4].i = z__1.i;
+ ++ijp;
+ }
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of ZTPTTF */
+
+} /* ztpttf_ */
diff --git a/SRC/ztpttr.c b/SRC/ztpttr.c
new file mode 100644
index 0000000..9d39cca
--- /dev/null
+++ b/SRC/ztpttr.c
@@ -0,0 +1,148 @@
+/* ztpttr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ztpttr_(char *uplo, integer *n, doublecomplex *ap,
+ doublecomplex *a, integer *lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, k;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTPTTR copies a triangular matrix A from standard packed format (TP) */
+/* to standard full format (TR). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular. */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ), */
+/* On entry, the upper or lower triangular matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* A (output) COMPLEX*16 array, dimension ( LDA, N ) */
+/* On exit, the triangular matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --ap;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ lower = lsame_(uplo, "L");
+ if (! lower && ! lsame_(uplo, "U")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTPTTR", &i__1);
+ return 0;
+ }
+
+ if (lower) {
+ k = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ++k;
+ i__3 = i__ + j * a_dim1;
+ i__4 = k;
+ a[i__3].r = ap[i__4].r, a[i__3].i = ap[i__4].i;
+ }
+ }
+ } else {
+ k = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ++k;
+ i__3 = i__ + j * a_dim1;
+ i__4 = k;
+ a[i__3].r = ap[i__4].r, a[i__3].i = ap[i__4].i;
+ }
+ }
+ }
+
+
+ return 0;
+
+/* End of ZTPTTR */
+
+} /* ztpttr_ */
diff --git a/SRC/ztrcon.c b/SRC/ztrcon.c
new file mode 100644
index 0000000..01a0724
--- /dev/null
+++ b/SRC/ztrcon.c
@@ -0,0 +1,250 @@
+/* ztrcon.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ztrcon_(char *norm, char *uplo, char *diag, integer *n,
+ doublecomplex *a, integer *lda, doublereal *rcond, doublecomplex *
+ work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer ix, kase, kase1;
+ doublereal scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ doublereal anorm;
+ logical upper;
+ doublereal xnorm;
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal ainvnm;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ logical onenrm;
+ extern /* Subroutine */ int zdrscl_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ char normin[1];
+ extern doublereal zlantr_(char *, char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+ doublereal smlnum;
+ logical nounit;
+ extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *, doublereal *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTRCON estimates the reciprocal of the condition number of a */
+/* triangular matrix A, in either the 1-norm or the infinity-norm. */
+
+/* The norm of A is computed and an estimate is obtained for */
+/* norm(inv(A)), then the reciprocal of the condition number is */
+/* computed as */
+/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
+
+/* Arguments */
+/* ========= */
+
+/* NORM (input) CHARACTER*1 */
+/* Specifies whether the 1-norm condition number or the */
+/* infinity-norm condition number is required: */
+/* = '1' or 'O': 1-norm; */
+/* = 'I': Infinity-norm. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal of the condition number of the matrix A, */
+/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+ nounit = lsame_(diag, "N");
+
+ if (! onenrm && ! lsame_(norm, "I")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTRCON", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ *rcond = 1.;
+ return 0;
+ }
+
+ *rcond = 0.;
+ smlnum = dlamch_("Safe minimum") * (doublereal) max(1,*n);
+
+/* Compute the norm of the triangular matrix A. */
+
+ anorm = zlantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &rwork[1]);
+
+/* Continue only if ANORM > 0. */
+
+ if (anorm > 0.) {
+
+/* Estimate the norm of the inverse of A. */
+
+ ainvnm = 0.;
+ *(unsigned char *)normin = 'N';
+ if (onenrm) {
+ kase1 = 1;
+ } else {
+ kase1 = 2;
+ }
+ kase = 0;
+L10:
+ zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave);
+ if (kase != 0) {
+ if (kase == kase1) {
+
+/* Multiply by inv(A). */
+
+ zlatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset],
+ lda, &work[1], &scale, &rwork[1], info);
+ } else {
+
+/* Multiply by inv(A'). */
+
+ zlatrs_(uplo, "Conjugate transpose", diag, normin, n, &a[
+ a_offset], lda, &work[1], &scale, &rwork[1], info);
+ }
+ *(unsigned char *)normin = 'Y';
+
+/* Multiply by 1/SCALE if doing so will not cause overflow. */
+
+ if (scale != 1.) {
+ ix = izamax_(n, &work[1], &c__1);
+ i__1 = ix;
+ xnorm = (d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(&
+ work[ix]), abs(d__2));
+ if (scale < xnorm * smlnum || scale == 0.) {
+ goto L20;
+ }
+ zdrscl_(n, &scale, &work[1], &c__1);
+ }
+ goto L10;
+ }
+
+/* Compute the estimate of the reciprocal condition number. */
+
+ if (ainvnm != 0.) {
+ *rcond = 1. / anorm / ainvnm;
+ }
+ }
+
+L20:
+ return 0;
+
+/* End of ZTRCON */
+
+} /* ztrcon_ */
diff --git a/SRC/ztrevc.c b/SRC/ztrevc.c
new file mode 100644
index 0000000..3e4f836
--- /dev/null
+++ b/SRC/ztrevc.c
@@ -0,0 +1,533 @@
+/* ztrevc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int ztrevc_(char *side, char *howmny, logical *select,
+ integer *n, doublecomplex *t, integer *ldt, doublecomplex *vl,
+ integer *ldvl, doublecomplex *vr, integer *ldvr, integer *mm, integer
+ *m, doublecomplex *work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
+ i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, ii, ki, is;
+ doublereal ulp;
+ logical allv;
+ doublereal unfl, ovfl, smin;
+ logical over;
+ doublereal scale;
+ extern logical lsame_(char *, char *);
+ doublereal remax;
+ logical leftv, bothv;
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ logical somev;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
+ integer *, doublereal *, doublecomplex *, integer *);
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ logical rightv;
+ extern doublereal dzasum_(integer *, doublecomplex *, integer *);
+ doublereal smlnum;
+ extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *, doublereal *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTREVC computes some or all of the right and/or left eigenvectors of */
+/* a complex upper triangular matrix T. */
+/* Matrices of this type are produced by the Schur factorization of */
+/* a complex general matrix: A = Q*T*Q**H, as computed by ZHSEQR. */
+
+/* The right eigenvector x and the left eigenvector y of T corresponding */
+/* to an eigenvalue w are defined by: */
+
+/* T*x = w*x, (y**H)*T = w*(y**H) */
+
+/* where y**H denotes the conjugate transpose of the vector y. */
+/* The eigenvalues are not input to this routine, but are read directly */
+/* from the diagonal of T. */
+
+/* This routine returns the matrices X and/or Y of right and left */
+/* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an */
+/* input matrix. If Q is the unitary factor that reduces a matrix A to */
+/* Schur form T, then Q*X and Q*Y are the matrices of right and left */
+/* eigenvectors of A. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'R': compute right eigenvectors only; */
+/* = 'L': compute left eigenvectors only; */
+/* = 'B': compute both right and left eigenvectors. */
+
+/* HOWMNY (input) CHARACTER*1 */
+/* = 'A': compute all right and/or left eigenvectors; */
+/* = 'B': compute all right and/or left eigenvectors, */
+/* backtransformed using the matrices supplied in */
+/* VR and/or VL; */
+/* = 'S': compute selected right and/or left eigenvectors, */
+/* as indicated by the logical array SELECT. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* If HOWMNY = 'S', SELECT specifies the eigenvectors to be */
+/* computed. */
+/* The eigenvector corresponding to the j-th eigenvalue is */
+/* computed if SELECT(j) = .TRUE.. */
+/* Not referenced if HOWMNY = 'A' or 'B'. */
+
+/* N (input) INTEGER */
+/* The order of the matrix T. N >= 0. */
+
+/* T (input/output) COMPLEX*16 array, dimension (LDT,N) */
+/* The upper triangular matrix T. T is modified, but restored */
+/* on exit. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= max(1,N). */
+
+/* VL (input/output) COMPLEX*16 array, dimension (LDVL,MM) */
+/* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */
+/* contain an N-by-N matrix Q (usually the unitary matrix Q of */
+/* Schur vectors returned by ZHSEQR). */
+/* On exit, if SIDE = 'L' or 'B', VL contains: */
+/* if HOWMNY = 'A', the matrix Y of left eigenvectors of T; */
+/* if HOWMNY = 'B', the matrix Q*Y; */
+/* if HOWMNY = 'S', the left eigenvectors of T specified by */
+/* SELECT, stored consecutively in the columns */
+/* of VL, in the same order as their */
+/* eigenvalues. */
+/* Not referenced if SIDE = 'R'. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. LDVL >= 1, and if */
+/* SIDE = 'L' or 'B', LDVL >= N. */
+
+/* VR (input/output) COMPLEX*16 array, dimension (LDVR,MM) */
+/* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */
+/* contain an N-by-N matrix Q (usually the unitary matrix Q of */
+/* Schur vectors returned by ZHSEQR). */
+/* On exit, if SIDE = 'R' or 'B', VR contains: */
+/* if HOWMNY = 'A', the matrix X of right eigenvectors of T; */
+/* if HOWMNY = 'B', the matrix Q*X; */
+/* if HOWMNY = 'S', the right eigenvectors of T specified by */
+/* SELECT, stored consecutively in the columns */
+/* of VR, in the same order as their */
+/* eigenvalues. */
+/* Not referenced if SIDE = 'L'. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. LDVR >= 1, and if */
+/* SIDE = 'R' or 'B'; LDVR >= N. */
+
+/* MM (input) INTEGER */
+/* The number of columns in the arrays VL and/or VR. MM >= M. */
+
+/* M (output) INTEGER */
+/* The number of columns in the arrays VL and/or VR actually */
+/* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M */
+/* is set to N. Each selected eigenvector occupies one */
+/* column. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The algorithm used in this program is basically backward (forward) */
+/* substitution, with scaling to make the the code robust against */
+/* possible overflow. */
+
+/* Each eigenvector is normalized so that the element of largest */
+/* magnitude has magnitude 1; here the magnitude of a complex number */
+/* (x,y) is taken to be |x| + |y|. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ --select;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ bothv = lsame_(side, "B");
+ rightv = lsame_(side, "R") || bothv;
+ leftv = lsame_(side, "L") || bothv;
+
+ allv = lsame_(howmny, "A");
+ over = lsame_(howmny, "B");
+ somev = lsame_(howmny, "S");
+
+/* Set M to the number of columns required to store the selected */
+/* eigenvectors. */
+
+ if (somev) {
+ *m = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (select[j]) {
+ ++(*m);
+ }
+/* L10: */
+ }
+ } else {
+ *m = *n;
+ }
+
+ *info = 0;
+ if (! rightv && ! leftv) {
+ *info = -1;
+ } else if (! allv && ! over && ! somev) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldt < max(1,*n)) {
+ *info = -6;
+ } else if (*ldvl < 1 || leftv && *ldvl < *n) {
+ *info = -8;
+ } else if (*ldvr < 1 || rightv && *ldvr < *n) {
+ *info = -10;
+ } else if (*mm < *m) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTREVC", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Set the constants to control overflow. */
+
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ dlabad_(&unfl, &ovfl);
+ ulp = dlamch_("Precision");
+ smlnum = unfl * (*n / ulp);
+
+/* Store the diagonal elements of T in working array WORK. */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + *n;
+ i__3 = i__ + i__ * t_dim1;
+ work[i__2].r = t[i__3].r, work[i__2].i = t[i__3].i;
+/* L20: */
+ }
+
+/* Compute 1-norm of each column of strictly upper triangular */
+/* part of T to control overflow in triangular solver. */
+
+ rwork[1] = 0.;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ rwork[j] = dzasum_(&i__2, &t[j * t_dim1 + 1], &c__1);
+/* L30: */
+ }
+
+ if (rightv) {
+
+/* Compute right eigenvectors. */
+
+ is = *m;
+ for (ki = *n; ki >= 1; --ki) {
+
+ if (somev) {
+ if (! select[ki]) {
+ goto L80;
+ }
+ }
+/* Computing MAX */
+ i__1 = ki + ki * t_dim1;
+ d__3 = ulp * ((d__1 = t[i__1].r, abs(d__1)) + (d__2 = d_imag(&t[
+ ki + ki * t_dim1]), abs(d__2)));
+ smin = max(d__3,smlnum);
+
+ work[1].r = 1., work[1].i = 0.;
+
+/* Form right-hand side. */
+
+ i__1 = ki - 1;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = k;
+ i__3 = k + ki * t_dim1;
+ z__1.r = -t[i__3].r, z__1.i = -t[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L40: */
+ }
+
+/* Solve the triangular system: */
+/* (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK. */
+
+ i__1 = ki - 1;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = k + k * t_dim1;
+ i__3 = k + k * t_dim1;
+ i__4 = ki + ki * t_dim1;
+ z__1.r = t[i__3].r - t[i__4].r, z__1.i = t[i__3].i - t[i__4]
+ .i;
+ t[i__2].r = z__1.r, t[i__2].i = z__1.i;
+ i__2 = k + k * t_dim1;
+ if ((d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&t[k + k *
+ t_dim1]), abs(d__2)) < smin) {
+ i__3 = k + k * t_dim1;
+ t[i__3].r = smin, t[i__3].i = 0.;
+ }
+/* L50: */
+ }
+
+ if (ki > 1) {
+ i__1 = ki - 1;
+ zlatrs_("Upper", "No transpose", "Non-unit", "Y", &i__1, &t[
+ t_offset], ldt, &work[1], &scale, &rwork[1], info);
+ i__1 = ki;
+ work[i__1].r = scale, work[i__1].i = 0.;
+ }
+
+/* Copy the vector x or Q*x to VR and normalize. */
+
+ if (! over) {
+ zcopy_(&ki, &work[1], &c__1, &vr[is * vr_dim1 + 1], &c__1);
+
+ ii = izamax_(&ki, &vr[is * vr_dim1 + 1], &c__1);
+ i__1 = ii + is * vr_dim1;
+ remax = 1. / ((d__1 = vr[i__1].r, abs(d__1)) + (d__2 = d_imag(
+ &vr[ii + is * vr_dim1]), abs(d__2)));
+ zdscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1);
+
+ i__1 = *n;
+ for (k = ki + 1; k <= i__1; ++k) {
+ i__2 = k + is * vr_dim1;
+ vr[i__2].r = 0., vr[i__2].i = 0.;
+/* L60: */
+ }
+ } else {
+ if (ki > 1) {
+ i__1 = ki - 1;
+ z__1.r = scale, z__1.i = 0.;
+ zgemv_("N", n, &i__1, &c_b2, &vr[vr_offset], ldvr, &work[
+ 1], &c__1, &z__1, &vr[ki * vr_dim1 + 1], &c__1);
+ }
+
+ ii = izamax_(n, &vr[ki * vr_dim1 + 1], &c__1);
+ i__1 = ii + ki * vr_dim1;
+ remax = 1. / ((d__1 = vr[i__1].r, abs(d__1)) + (d__2 = d_imag(
+ &vr[ii + ki * vr_dim1]), abs(d__2)));
+ zdscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1);
+ }
+
+/* Set back the original diagonal elements of T. */
+
+ i__1 = ki - 1;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = k + k * t_dim1;
+ i__3 = k + *n;
+ t[i__2].r = work[i__3].r, t[i__2].i = work[i__3].i;
+/* L70: */
+ }
+
+ --is;
+L80:
+ ;
+ }
+ }
+
+ if (leftv) {
+
+/* Compute left eigenvectors. */
+
+ is = 1;
+ i__1 = *n;
+ for (ki = 1; ki <= i__1; ++ki) {
+
+ if (somev) {
+ if (! select[ki]) {
+ goto L130;
+ }
+ }
+/* Computing MAX */
+ i__2 = ki + ki * t_dim1;
+ d__3 = ulp * ((d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&t[
+ ki + ki * t_dim1]), abs(d__2)));
+ smin = max(d__3,smlnum);
+
+ i__2 = *n;
+ work[i__2].r = 1., work[i__2].i = 0.;
+
+/* Form right-hand side. */
+
+ i__2 = *n;
+ for (k = ki + 1; k <= i__2; ++k) {
+ i__3 = k;
+ d_cnjg(&z__2, &t[ki + k * t_dim1]);
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L90: */
+ }
+
+/* Solve the triangular system: */
+/* (T(KI+1:N,KI+1:N) - T(KI,KI))'*X = SCALE*WORK. */
+
+ i__2 = *n;
+ for (k = ki + 1; k <= i__2; ++k) {
+ i__3 = k + k * t_dim1;
+ i__4 = k + k * t_dim1;
+ i__5 = ki + ki * t_dim1;
+ z__1.r = t[i__4].r - t[i__5].r, z__1.i = t[i__4].i - t[i__5]
+ .i;
+ t[i__3].r = z__1.r, t[i__3].i = z__1.i;
+ i__3 = k + k * t_dim1;
+ if ((d__1 = t[i__3].r, abs(d__1)) + (d__2 = d_imag(&t[k + k *
+ t_dim1]), abs(d__2)) < smin) {
+ i__4 = k + k * t_dim1;
+ t[i__4].r = smin, t[i__4].i = 0.;
+ }
+/* L100: */
+ }
+
+ if (ki < *n) {
+ i__2 = *n - ki;
+ zlatrs_("Upper", "Conjugate transpose", "Non-unit", "Y", &
+ i__2, &t[ki + 1 + (ki + 1) * t_dim1], ldt, &work[ki +
+ 1], &scale, &rwork[1], info);
+ i__2 = ki;
+ work[i__2].r = scale, work[i__2].i = 0.;
+ }
+
+/* Copy the vector x or Q*x to VL and normalize. */
+
+ if (! over) {
+ i__2 = *n - ki + 1;
+ zcopy_(&i__2, &work[ki], &c__1, &vl[ki + is * vl_dim1], &c__1)
+ ;
+
+ i__2 = *n - ki + 1;
+ ii = izamax_(&i__2, &vl[ki + is * vl_dim1], &c__1) + ki - 1;
+ i__2 = ii + is * vl_dim1;
+ remax = 1. / ((d__1 = vl[i__2].r, abs(d__1)) + (d__2 = d_imag(
+ &vl[ii + is * vl_dim1]), abs(d__2)));
+ i__2 = *n - ki + 1;
+ zdscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1);
+
+ i__2 = ki - 1;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + is * vl_dim1;
+ vl[i__3].r = 0., vl[i__3].i = 0.;
+/* L110: */
+ }
+ } else {
+ if (ki < *n) {
+ i__2 = *n - ki;
+ z__1.r = scale, z__1.i = 0.;
+ zgemv_("N", n, &i__2, &c_b2, &vl[(ki + 1) * vl_dim1 + 1],
+ ldvl, &work[ki + 1], &c__1, &z__1, &vl[ki *
+ vl_dim1 + 1], &c__1);
+ }
+
+ ii = izamax_(n, &vl[ki * vl_dim1 + 1], &c__1);
+ i__2 = ii + ki * vl_dim1;
+ remax = 1. / ((d__1 = vl[i__2].r, abs(d__1)) + (d__2 = d_imag(
+ &vl[ii + ki * vl_dim1]), abs(d__2)));
+ zdscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1);
+ }
+
+/* Set back the original diagonal elements of T. */
+
+ i__2 = *n;
+ for (k = ki + 1; k <= i__2; ++k) {
+ i__3 = k + k * t_dim1;
+ i__4 = k + *n;
+ t[i__3].r = work[i__4].r, t[i__3].i = work[i__4].i;
+/* L120: */
+ }
+
+ ++is;
+L130:
+ ;
+ }
+ }
+
+ return 0;
+
+/* End of ZTREVC */
+
+} /* ztrevc_ */
diff --git a/SRC/ztrexc.c b/SRC/ztrexc.c
new file mode 100644
index 0000000..730babe
--- /dev/null
+++ b/SRC/ztrexc.c
@@ -0,0 +1,216 @@
+/* ztrexc.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ztrexc_(char *compq, integer *n, doublecomplex *t,
+ integer *ldt, doublecomplex *q, integer *ldq, integer *ifst, integer *
+ ilst, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, t_dim1, t_offset, i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer k, m1, m2, m3;
+ doublereal cs;
+ doublecomplex t11, t22, sn, temp;
+ extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *);
+ extern logical lsame_(char *, char *);
+ logical wantq;
+ extern /* Subroutine */ int xerbla_(char *, integer *), zlartg_(
+ doublecomplex *, doublecomplex *, doublereal *, doublecomplex *,
+ doublecomplex *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTREXC reorders the Schur factorization of a complex matrix */
+/* A = Q*T*Q**H, so that the diagonal element of T with row index IFST */
+/* is moved to row ILST. */
+
+/* The Schur form T is reordered by a unitary similarity transformation */
+/* Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by */
+/* postmultplying it with Z. */
+
+/* Arguments */
+/* ========= */
+
+/* COMPQ (input) CHARACTER*1 */
+/* = 'V': update the matrix Q of Schur vectors; */
+/* = 'N': do not update Q. */
+
+/* N (input) INTEGER */
+/* The order of the matrix T. N >= 0. */
+
+/* T (input/output) COMPLEX*16 array, dimension (LDT,N) */
+/* On entry, the upper triangular matrix T. */
+/* On exit, the reordered upper triangular matrix. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= max(1,N). */
+
+/* Q (input/output) COMPLEX*16 array, dimension (LDQ,N) */
+/* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */
+/* On exit, if COMPQ = 'V', Q has been postmultiplied by the */
+/* unitary transformation matrix Z which reorders T. */
+/* If COMPQ = 'N', Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* IFST (input) INTEGER */
+/* ILST (input) INTEGER */
+/* Specify the reordering of the diagonal elements of T: */
+/* The element with row index IFST is moved to row ILST by a */
+/* sequence of transpositions between adjacent elements. */
+/* 1 <= IFST <= N; 1 <= ILST <= N. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters. */
+
+ /* Parameter adjustments */
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+
+ /* Function Body */
+ *info = 0;
+ wantq = lsame_(compq, "V");
+ if (! lsame_(compq, "N") && ! wantq) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldt < max(1,*n)) {
+ *info = -4;
+ } else if (*ldq < 1 || wantq && *ldq < max(1,*n)) {
+ *info = -6;
+ } else if (*ifst < 1 || *ifst > *n) {
+ *info = -7;
+ } else if (*ilst < 1 || *ilst > *n) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTREXC", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 1 || *ifst == *ilst) {
+ return 0;
+ }
+
+ if (*ifst < *ilst) {
+
+/* Move the IFST-th diagonal element forward down the diagonal. */
+
+ m1 = 0;
+ m2 = -1;
+ m3 = 1;
+ } else {
+
+/* Move the IFST-th diagonal element backward up the diagonal. */
+
+ m1 = -1;
+ m2 = 0;
+ m3 = -1;
+ }
+
+ i__1 = *ilst + m2;
+ i__2 = m3;
+ for (k = *ifst + m1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+
+/* Interchange the k-th and (k+1)-th diagonal elements. */
+
+ i__3 = k + k * t_dim1;
+ t11.r = t[i__3].r, t11.i = t[i__3].i;
+ i__3 = k + 1 + (k + 1) * t_dim1;
+ t22.r = t[i__3].r, t22.i = t[i__3].i;
+
+/* Determine the transformation to perform the interchange. */
+
+ z__1.r = t22.r - t11.r, z__1.i = t22.i - t11.i;
+ zlartg_(&t[k + (k + 1) * t_dim1], &z__1, &cs, &sn, &temp);
+
+/* Apply transformation to the matrix T. */
+
+ if (k + 2 <= *n) {
+ i__3 = *n - k - 1;
+ zrot_(&i__3, &t[k + (k + 2) * t_dim1], ldt, &t[k + 1 + (k + 2) *
+ t_dim1], ldt, &cs, &sn);
+ }
+ i__3 = k - 1;
+ d_cnjg(&z__1, &sn);
+ zrot_(&i__3, &t[k * t_dim1 + 1], &c__1, &t[(k + 1) * t_dim1 + 1], &
+ c__1, &cs, &z__1);
+
+ i__3 = k + k * t_dim1;
+ t[i__3].r = t22.r, t[i__3].i = t22.i;
+ i__3 = k + 1 + (k + 1) * t_dim1;
+ t[i__3].r = t11.r, t[i__3].i = t11.i;
+
+ if (wantq) {
+
+/* Accumulate transformation in the matrix Q. */
+
+ d_cnjg(&z__1, &sn);
+ zrot_(n, &q[k * q_dim1 + 1], &c__1, &q[(k + 1) * q_dim1 + 1], &
+ c__1, &cs, &z__1);
+ }
+
+/* L10: */
+ }
+
+ return 0;
+
+/* End of ZTREXC */
+
+} /* ztrexc_ */
diff --git a/SRC/ztrrfs.c b/SRC/ztrrfs.c
new file mode 100644
index 0000000..c18131c
--- /dev/null
+++ b/SRC/ztrrfs.c
@@ -0,0 +1,565 @@
+/* ztrrfs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ztrrfs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b,
+ integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr,
+ doublereal *berr, doublecomplex *work, doublereal *rwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2,
+ i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal s, xk;
+ integer nz;
+ doublereal eps;
+ integer kase;
+ doublereal safe1, safe2;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ logical upper;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), ztrmv_(
+ char *, char *, char *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), ztrsv_(char *
+, char *, char *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zlacn2_(
+ integer *, doublecomplex *, doublecomplex *, doublereal *,
+ integer *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran;
+ char transn[1], transt[1];
+ logical nounit;
+ doublereal lstres;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTRRFS provides error bounds and backward error estimates for the */
+/* solution to a system of linear equations with a triangular */
+/* coefficient matrix. */
+
+/* The solution matrix X must be computed by ZTRTRS or some other */
+/* means before entering this routine. ZTRRFS does not do iterative */
+/* refinement because doing so cannot improve the backward error. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The solution matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bound for each solution vector */
+/* X(j) (the j-th column of the solution matrix X). */
+/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* is an estimated upper bound for the magnitude of the largest */
+/* element in (X(j) - XTRUE) divided by the magnitude of the */
+/* largest element in X(j). The estimate is as reliable as */
+/* the estimate for RCOND, and is almost always a slight */
+/* overestimate of the true error. */
+
+/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector X(j) (i.e., the smallest relative change in */
+/* any element of A or B that makes X(j) an exact solution). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --ferr;
+ --berr;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ nounit = lsame_(diag, "N");
+
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "T") && !
+ lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldx < max(1,*n)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTRRFS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ferr[j] = 0.;
+ berr[j] = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+ if (notran) {
+ *(unsigned char *)transn = 'N';
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transn = 'C';
+ *(unsigned char *)transt = 'N';
+ }
+
+/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+ nz = *n + 1;
+ eps = dlamch_("Epsilon");
+ safmin = dlamch_("Safe minimum");
+ safe1 = nz * safmin;
+ safe2 = safe1 / eps;
+
+/* Do for each right hand side */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compute residual R = B - op(A) * X, */
+/* where op(A) = A, A**T, or A**H, depending on TRANS. */
+
+ zcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ztrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
+ z__1.r = -1., z__1.i = -0.;
+ zaxpy_(n, &z__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+
+/* Compute componentwise relative backward error from formula */
+
+/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */
+
+/* where abs(Z) is the componentwise absolute value of the matrix */
+/* or vector Z. If the i-th component of the denominator is less */
+/* than SAFE2, then SAFE1 is added to the i-th components of the */
+/* numerator and denominator before dividing. */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
+ i__ + j * b_dim1]), abs(d__2));
+/* L20: */
+ }
+
+ if (notran) {
+
+/* Compute abs(A)*abs(X) + abs(B). */
+
+ if (upper) {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&
+ x[k + j * x_dim1]), abs(d__2));
+ i__3 = k;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ rwork[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (
+ d__2 = d_imag(&a[i__ + k * a_dim1]), abs(
+ d__2))) * xk;
+/* L30: */
+ }
+/* L40: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&
+ x[k + j * x_dim1]), abs(d__2));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ rwork[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (
+ d__2 = d_imag(&a[i__ + k * a_dim1]), abs(
+ d__2))) * xk;
+/* L50: */
+ }
+ rwork[k] += xk;
+/* L60: */
+ }
+ }
+ } else {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&
+ x[k + j * x_dim1]), abs(d__2));
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ rwork[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (
+ d__2 = d_imag(&a[i__ + k * a_dim1]), abs(
+ d__2))) * xk;
+/* L70: */
+ }
+/* L80: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&
+ x[k + j * x_dim1]), abs(d__2));
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ rwork[i__] += ((d__1 = a[i__4].r, abs(d__1)) + (
+ d__2 = d_imag(&a[i__ + k * a_dim1]), abs(
+ d__2))) * xk;
+/* L90: */
+ }
+ rwork[k] += xk;
+/* L100: */
+ }
+ }
+ }
+ } else {
+
+/* Compute abs(A**H)*abs(X) + abs(B). */
+
+ if (upper) {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__3 = k;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + k * a_dim1]), abs(d__2)))
+ * ((d__3 = x[i__5].r, abs(d__3)) + (d__4 =
+ d_imag(&x[i__ + j * x_dim1]), abs(d__4)))
+ ;
+/* L110: */
+ }
+ rwork[k] += s;
+/* L120: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ s = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[
+ k + j * x_dim1]), abs(d__2));
+ i__3 = k - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + k * a_dim1]), abs(d__2)))
+ * ((d__3 = x[i__5].r, abs(d__3)) + (d__4 =
+ d_imag(&x[i__ + j * x_dim1]), abs(d__4)))
+ ;
+/* L130: */
+ }
+ rwork[k] += s;
+/* L140: */
+ }
+ }
+ } else {
+ if (nounit) {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ s = 0.;
+ i__3 = *n;
+ for (i__ = k; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + k * a_dim1]), abs(d__2)))
+ * ((d__3 = x[i__5].r, abs(d__3)) + (d__4 =
+ d_imag(&x[i__ + j * x_dim1]), abs(d__4)))
+ ;
+/* L150: */
+ }
+ rwork[k] += s;
+/* L160: */
+ }
+ } else {
+ i__2 = *n;
+ for (k = 1; k <= i__2; ++k) {
+ i__3 = k + j * x_dim1;
+ s = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[
+ k + j * x_dim1]), abs(d__2));
+ i__3 = *n;
+ for (i__ = k + 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + k * a_dim1;
+ i__5 = i__ + j * x_dim1;
+ s += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + k * a_dim1]), abs(d__2)))
+ * ((d__3 = x[i__5].r, abs(d__3)) + (d__4 =
+ d_imag(&x[i__ + j * x_dim1]), abs(d__4)))
+ ;
+/* L170: */
+ }
+ rwork[k] += s;
+/* L180: */
+ }
+ }
+ }
+ }
+ s = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+/* Computing MAX */
+ i__3 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2))) / rwork[i__];
+ s = max(d__3,d__4);
+ } else {
+/* Computing MAX */
+ i__3 = i__;
+ d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__]
+ + safe1);
+ s = max(d__3,d__4);
+ }
+/* L190: */
+ }
+ berr[j] = s;
+
+/* Bound error from formula */
+
+/* norm(X - XTRUE) / norm(X) .le. FERR = */
+/* norm( abs(inv(op(A)))* */
+/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */
+
+/* where */
+/* norm(Z) is the magnitude of the largest component of Z */
+/* inv(op(A)) is the inverse of op(A) */
+/* abs(Z) is the componentwise absolute value of the matrix or */
+/* vector Z */
+/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/* EPS is machine epsilon */
+
+/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */
+/* is incremented by SAFE1 if the i-th component of */
+/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */
+
+/* Use ZLACN2 to estimate the infinity-norm of the matrix */
+/* inv(op(A)) * diag(W), */
+/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (rwork[i__] > safe2) {
+ i__3 = i__;
+ rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ ;
+ } else {
+ i__3 = i__;
+ rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__]
+ + safe1;
+ }
+/* L200: */
+ }
+
+ kase = 0;
+L210:
+ zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Multiply by diag(W)*inv(op(A)**H). */
+
+ ztrsv_(uplo, transt, diag, n, &a[a_offset], lda, &work[1], &
+ c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L220: */
+ }
+ } else {
+
+/* Multiply by inv(op(A))*diag(W). */
+
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__;
+ i__5 = i__;
+ z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4]
+ * work[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L230: */
+ }
+ ztrsv_(uplo, transn, diag, n, &a[a_offset], lda, &work[1], &
+ c__1);
+ }
+ goto L210;
+ }
+
+/* Normalize error. */
+
+ lstres = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ i__3 = i__ + j * x_dim1;
+ d__3 = lstres, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&x[i__ + j * x_dim1]), abs(d__2));
+ lstres = max(d__3,d__4);
+/* L240: */
+ }
+ if (lstres != 0.) {
+ ferr[j] /= lstres;
+ }
+
+/* L250: */
+ }
+
+ return 0;
+
+/* End of ZTRRFS */
+
+} /* ztrrfs_ */
diff --git a/SRC/ztrsen.c b/SRC/ztrsen.c
new file mode 100644
index 0000000..a301265
--- /dev/null
+++ b/SRC/ztrsen.c
@@ -0,0 +1,422 @@
+/* ztrsen.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+
+/* Subroutine */ int ztrsen_(char *job, char *compq, logical *select, integer
+ *n, doublecomplex *t, integer *ldt, doublecomplex *q, integer *ldq,
+ doublecomplex *w, integer *m, doublereal *s, doublereal *sep,
+ doublecomplex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, t_dim1, t_offset, i__1, i__2, i__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer k, n1, n2, nn, ks;
+ doublereal est;
+ integer kase, ierr;
+ doublereal scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3], lwmin;
+ logical wantq, wants;
+ doublereal rnorm, rwork[1];
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *), xerbla_(
+ char *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ logical wantbh;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ logical wantsp;
+ extern /* Subroutine */ int ztrexc_(char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, integer *,
+ integer *);
+ logical lquery;
+ extern /* Subroutine */ int ztrsyl_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTRSEN reorders the Schur factorization of a complex matrix */
+/* A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in */
+/* the leading positions on the diagonal of the upper triangular matrix */
+/* T, and the leading columns of Q form an orthonormal basis of the */
+/* corresponding right invariant subspace. */
+
+/* Optionally the routine computes the reciprocal condition numbers of */
+/* the cluster of eigenvalues and/or the invariant subspace. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies whether condition numbers are required for the */
+/* cluster of eigenvalues (S) or the invariant subspace (SEP): */
+/* = 'N': none; */
+/* = 'E': for eigenvalues only (S); */
+/* = 'V': for invariant subspace only (SEP); */
+/* = 'B': for both eigenvalues and invariant subspace (S and */
+/* SEP). */
+
+/* COMPQ (input) CHARACTER*1 */
+/* = 'V': update the matrix Q of Schur vectors; */
+/* = 'N': do not update Q. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* SELECT specifies the eigenvalues in the selected cluster. To */
+/* select the j-th eigenvalue, SELECT(j) must be set to .TRUE.. */
+
+/* N (input) INTEGER */
+/* The order of the matrix T. N >= 0. */
+
+/* T (input/output) COMPLEX*16 array, dimension (LDT,N) */
+/* On entry, the upper triangular matrix T. */
+/* On exit, T is overwritten by the reordered matrix T, with the */
+/* selected eigenvalues as the leading diagonal elements. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= max(1,N). */
+
+/* Q (input/output) COMPLEX*16 array, dimension (LDQ,N) */
+/* On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */
+/* On exit, if COMPQ = 'V', Q has been postmultiplied by the */
+/* unitary transformation matrix which reorders T; the leading M */
+/* columns of Q form an orthonormal basis for the specified */
+/* invariant subspace. */
+/* If COMPQ = 'N', Q is not referenced. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. */
+/* LDQ >= 1; and if COMPQ = 'V', LDQ >= N. */
+
+/* W (output) COMPLEX*16 array, dimension (N) */
+/* The reordered eigenvalues of T, in the same order as they */
+/* appear on the diagonal of T. */
+
+/* M (output) INTEGER */
+/* The dimension of the specified invariant subspace. */
+/* 0 <= M <= N. */
+
+/* S (output) DOUBLE PRECISION */
+/* If JOB = 'E' or 'B', S is a lower bound on the reciprocal */
+/* condition number for the selected cluster of eigenvalues. */
+/* S cannot underestimate the true reciprocal condition number */
+/* by more than a factor of sqrt(N). If M = 0 or N, S = 1. */
+/* If JOB = 'N' or 'V', S is not referenced. */
+
+/* SEP (output) DOUBLE PRECISION */
+/* If JOB = 'V' or 'B', SEP is the estimated reciprocal */
+/* condition number of the specified invariant subspace. If */
+/* M = 0 or N, SEP = norm(T). */
+/* If JOB = 'N' or 'E', SEP is not referenced. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If JOB = 'N', LWORK >= 1; */
+/* if JOB = 'E', LWORK = max(1,M*(N-M)); */
+/* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)). */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* ZTRSEN first collects the selected eigenvalues by computing a unitary */
+/* transformation Z to move them to the top left corner of T. In other */
+/* words, the selected eigenvalues are the eigenvalues of T11 in: */
+
+/* Z'*T*Z = ( T11 T12 ) n1 */
+/* ( 0 T22 ) n2 */
+/* n1 n2 */
+
+/* where N = n1+n2 and Z' means the conjugate transpose of Z. The first */
+/* n1 columns of Z span the specified invariant subspace of T. */
+
+/* If T has been obtained from the Schur factorization of a matrix */
+/* A = Q*T*Q', then the reordered Schur factorization of A is given by */
+/* A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span the */
+/* corresponding invariant subspace of A. */
+
+/* The reciprocal condition number of the average of the eigenvalues of */
+/* T11 may be returned in S. S lies between 0 (very badly conditioned) */
+/* and 1 (very well conditioned). It is computed as follows. First we */
+/* compute R so that */
+
+/* P = ( I R ) n1 */
+/* ( 0 0 ) n2 */
+/* n1 n2 */
+
+/* is the projector on the invariant subspace associated with T11. */
+/* R is the solution of the Sylvester equation: */
+
+/* T11*R - R*T22 = T12. */
+
+/* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote */
+/* the two-norm of M. Then S is computed as the lower bound */
+
+/* (1 + F-norm(R)**2)**(-1/2) */
+
+/* on the reciprocal of 2-norm(P), the true reciprocal condition number. */
+/* S cannot underestimate 1 / 2-norm(P) by more than a factor of */
+/* sqrt(N). */
+
+/* An approximate error bound for the computed average of the */
+/* eigenvalues of T11 is */
+
+/* EPS * norm(T) / S */
+
+/* where EPS is the machine precision. */
+
+/* The reciprocal condition number of the right invariant subspace */
+/* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. */
+/* SEP is defined as the separation of T11 and T22: */
+
+/* sep( T11, T22 ) = sigma-min( C ) */
+
+/* where sigma-min(C) is the smallest singular value of the */
+/* n1*n2-by-n1*n2 matrix */
+
+/* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) */
+
+/* I(m) is an m by m identity matrix, and kprod denotes the Kronecker */
+/* product. We estimate sigma-min(C) by the reciprocal of an estimate of */
+/* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) */
+/* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2). */
+
+/* When SEP is small, small changes in T can cause large changes in */
+/* the invariant subspace. An approximate bound on the maximum angular */
+/* error in the computed right invariant subspace is */
+
+/* EPS * norm(T) / SEP */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters. */
+
+ /* Parameter adjustments */
+ --select;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --w;
+ --work;
+
+ /* Function Body */
+ wantbh = lsame_(job, "B");
+ wants = lsame_(job, "E") || wantbh;
+ wantsp = lsame_(job, "V") || wantbh;
+ wantq = lsame_(compq, "V");
+
+/* Set M to the number of selected eigenvalues. */
+
+ *m = 0;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (select[k]) {
+ ++(*m);
+ }
+/* L10: */
+ }
+
+ n1 = *m;
+ n2 = *n - *m;
+ nn = n1 * n2;
+
+ *info = 0;
+ lquery = *lwork == -1;
+
+ if (wantsp) {
+/* Computing MAX */
+ i__1 = 1, i__2 = nn << 1;
+ lwmin = max(i__1,i__2);
+ } else if (lsame_(job, "N")) {
+ lwmin = 1;
+ } else if (lsame_(job, "E")) {
+ lwmin = max(1,nn);
+ }
+
+ if (! lsame_(job, "N") && ! wants && ! wantsp) {
+ *info = -1;
+ } else if (! lsame_(compq, "N") && ! wantq) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldt < max(1,*n)) {
+ *info = -6;
+ } else if (*ldq < 1 || wantq && *ldq < *n) {
+ *info = -8;
+ } else if (*lwork < lwmin && ! lquery) {
+ *info = -14;
+ }
+
+ if (*info == 0) {
+ work[1].r = (doublereal) lwmin, work[1].i = 0.;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTRSEN", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == *n || *m == 0) {
+ if (wants) {
+ *s = 1.;
+ }
+ if (wantsp) {
+ *sep = zlange_("1", n, n, &t[t_offset], ldt, rwork);
+ }
+ goto L40;
+ }
+
+/* Collect the selected eigenvalues at the top left corner of T. */
+
+ ks = 0;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (select[k]) {
+ ++ks;
+
+/* Swap the K-th eigenvalue to position KS. */
+
+ if (k != ks) {
+ ztrexc_(compq, n, &t[t_offset], ldt, &q[q_offset], ldq, &k, &
+ ks, &ierr);
+ }
+ }
+/* L20: */
+ }
+
+ if (wants) {
+
+/* Solve the Sylvester equation for R: */
+
+/* T11*R - R*T22 = scale*T12 */
+
+ zlacpy_("F", &n1, &n2, &t[(n1 + 1) * t_dim1 + 1], ldt, &work[1], &n1);
+ ztrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1
+ + 1) * t_dim1], ldt, &work[1], &n1, &scale, &ierr);
+
+/* Estimate the reciprocal of the condition number of the cluster */
+/* of eigenvalues. */
+
+ rnorm = zlange_("F", &n1, &n2, &work[1], &n1, rwork);
+ if (rnorm == 0.) {
+ *s = 1.;
+ } else {
+ *s = scale / (sqrt(scale * scale / rnorm + rnorm) * sqrt(rnorm));
+ }
+ }
+
+ if (wantsp) {
+
+/* Estimate sep(T11,T22). */
+
+ est = 0.;
+ kase = 0;
+L30:
+ zlacn2_(&nn, &work[nn + 1], &work[1], &est, &kase, isave);
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Solve T11*R - R*T22 = scale*X. */
+
+ ztrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 +
+ 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &
+ ierr);
+ } else {
+
+/* Solve T11'*R - R*T22' = scale*X. */
+
+ ztrsyl_("C", "C", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 +
+ 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, &
+ ierr);
+ }
+ goto L30;
+ }
+
+ *sep = scale / est;
+ }
+
+L40:
+
+/* Copy reordered eigenvalues to W. */
+
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = k;
+ i__3 = k + k * t_dim1;
+ w[i__2].r = t[i__3].r, w[i__2].i = t[i__3].i;
+/* L50: */
+ }
+
+ work[1].r = (doublereal) lwmin, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZTRSEN */
+
+} /* ztrsen_ */
diff --git a/SRC/ztrsna.c b/SRC/ztrsna.c
new file mode 100644
index 0000000..0230abf
--- /dev/null
+++ b/SRC/ztrsna.c
@@ -0,0 +1,446 @@
+/* ztrsna.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ztrsna_(char *job, char *howmny, logical *select,
+ integer *n, doublecomplex *t, integer *ldt, doublecomplex *vl,
+ integer *ldvl, doublecomplex *vr, integer *ldvr, doublereal *s,
+ doublereal *sep, integer *mm, integer *m, doublecomplex *work,
+ integer *ldwork, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset,
+ work_dim1, work_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *), d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, ks, ix;
+ doublereal eps, est;
+ integer kase, ierr;
+ doublecomplex prod;
+ doublereal lnrm, rnrm, scale;
+ extern logical lsame_(char *, char *);
+ integer isave[3];
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublecomplex dummy[1];
+ logical wants;
+ doublereal xnorm;
+ extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *), dlabad_(
+ doublereal *, doublereal *);
+ extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
+ char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal bignum;
+ logical wantbh;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ logical somcon;
+ extern /* Subroutine */ int zdrscl_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ char normin[1];
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal smlnum;
+ logical wantsp;
+ extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *, doublereal *, integer *), ztrexc_(char *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTRSNA estimates reciprocal condition numbers for specified */
+/* eigenvalues and/or right eigenvectors of a complex upper triangular */
+/* matrix T (or of any matrix Q*T*Q**H with Q unitary). */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER*1 */
+/* Specifies whether condition numbers are required for */
+/* eigenvalues (S) or eigenvectors (SEP): */
+/* = 'E': for eigenvalues only (S); */
+/* = 'V': for eigenvectors only (SEP); */
+/* = 'B': for both eigenvalues and eigenvectors (S and SEP). */
+
+/* HOWMNY (input) CHARACTER*1 */
+/* = 'A': compute condition numbers for all eigenpairs; */
+/* = 'S': compute condition numbers for selected eigenpairs */
+/* specified by the array SELECT. */
+
+/* SELECT (input) LOGICAL array, dimension (N) */
+/* If HOWMNY = 'S', SELECT specifies the eigenpairs for which */
+/* condition numbers are required. To select condition numbers */
+/* for the j-th eigenpair, SELECT(j) must be set to .TRUE.. */
+/* If HOWMNY = 'A', SELECT is not referenced. */
+
+/* N (input) INTEGER */
+/* The order of the matrix T. N >= 0. */
+
+/* T (input) COMPLEX*16 array, dimension (LDT,N) */
+/* The upper triangular matrix T. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of the array T. LDT >= max(1,N). */
+
+/* VL (input) COMPLEX*16 array, dimension (LDVL,M) */
+/* If JOB = 'E' or 'B', VL must contain left eigenvectors of T */
+/* (or of any Q*T*Q**H with Q unitary), corresponding to the */
+/* eigenpairs specified by HOWMNY and SELECT. The eigenvectors */
+/* must be stored in consecutive columns of VL, as returned by */
+/* ZHSEIN or ZTREVC. */
+/* If JOB = 'V', VL is not referenced. */
+
+/* LDVL (input) INTEGER */
+/* The leading dimension of the array VL. */
+/* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N. */
+
+/* VR (input) COMPLEX*16 array, dimension (LDVR,M) */
+/* If JOB = 'E' or 'B', VR must contain right eigenvectors of T */
+/* (or of any Q*T*Q**H with Q unitary), corresponding to the */
+/* eigenpairs specified by HOWMNY and SELECT. The eigenvectors */
+/* must be stored in consecutive columns of VR, as returned by */
+/* ZHSEIN or ZTREVC. */
+/* If JOB = 'V', VR is not referenced. */
+
+/* LDVR (input) INTEGER */
+/* The leading dimension of the array VR. */
+/* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N. */
+
+/* S (output) DOUBLE PRECISION array, dimension (MM) */
+/* If JOB = 'E' or 'B', the reciprocal condition numbers of the */
+/* selected eigenvalues, stored in consecutive elements of the */
+/* array. Thus S(j), SEP(j), and the j-th columns of VL and VR */
+/* all correspond to the same eigenpair (but not in general the */
+/* j-th eigenpair, unless all eigenpairs are selected). */
+/* If JOB = 'V', S is not referenced. */
+
+/* SEP (output) DOUBLE PRECISION array, dimension (MM) */
+/* If JOB = 'V' or 'B', the estimated reciprocal condition */
+/* numbers of the selected eigenvectors, stored in consecutive */
+/* elements of the array. */
+/* If JOB = 'E', SEP is not referenced. */
+
+/* MM (input) INTEGER */
+/* The number of elements in the arrays S (if JOB = 'E' or 'B') */
+/* and/or SEP (if JOB = 'V' or 'B'). MM >= M. */
+
+/* M (output) INTEGER */
+/* The number of elements of the arrays S and/or SEP actually */
+/* used to store the estimated condition numbers. */
+/* If HOWMNY = 'A', M is set to N. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,N+6) */
+/* If JOB = 'E', WORK is not referenced. */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. */
+/* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+/* If JOB = 'E', RWORK is not referenced. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The reciprocal of the condition number of an eigenvalue lambda is */
+/* defined as */
+
+/* S(lambda) = |v'*u| / (norm(u)*norm(v)) */
+
+/* where u and v are the right and left eigenvectors of T corresponding */
+/* to lambda; v' denotes the conjugate transpose of v, and norm(u) */
+/* denotes the Euclidean norm. These reciprocal condition numbers always */
+/* lie between zero (very badly conditioned) and one (very well */
+/* conditioned). If n = 1, S(lambda) is defined to be 1. */
+
+/* An approximate error bound for a computed eigenvalue W(i) is given by */
+
+/* EPS * norm(T) / S(i) */
+
+/* where EPS is the machine precision. */
+
+/* The reciprocal of the condition number of the right eigenvector u */
+/* corresponding to lambda is defined as follows. Suppose */
+
+/* T = ( lambda c ) */
+/* ( 0 T22 ) */
+
+/* Then the reciprocal condition number is */
+
+/* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I ) */
+
+/* where sigma-min denotes the smallest singular value. We approximate */
+/* the smallest singular value by the reciprocal of an estimate of the */
+/* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is */
+/* defined to be abs(T(1,1)). */
+
+/* An approximate error bound for a computed right eigenvector VR(i) */
+/* is given by */
+
+/* EPS * norm(T) / SEP(i) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and test the input parameters */
+
+ /* Parameter adjustments */
+ --select;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ --s;
+ --sep;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+
+ /* Function Body */
+ wantbh = lsame_(job, "B");
+ wants = lsame_(job, "E") || wantbh;
+ wantsp = lsame_(job, "V") || wantbh;
+
+ somcon = lsame_(howmny, "S");
+
+/* Set M to the number of eigenpairs for which condition numbers are */
+/* to be computed. */
+
+ if (somcon) {
+ *m = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (select[j]) {
+ ++(*m);
+ }
+/* L10: */
+ }
+ } else {
+ *m = *n;
+ }
+
+ *info = 0;
+ if (! wants && ! wantsp) {
+ *info = -1;
+ } else if (! lsame_(howmny, "A") && ! somcon) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldt < max(1,*n)) {
+ *info = -6;
+ } else if (*ldvl < 1 || wants && *ldvl < *n) {
+ *info = -8;
+ } else if (*ldvr < 1 || wants && *ldvr < *n) {
+ *info = -10;
+ } else if (*mm < *m) {
+ *info = -13;
+ } else if (*ldwork < 1 || wantsp && *ldwork < *n) {
+ *info = -16;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTRSNA", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*n == 1) {
+ if (somcon) {
+ if (! select[1]) {
+ return 0;
+ }
+ }
+ if (wants) {
+ s[1] = 1.;
+ }
+ if (wantsp) {
+ sep[1] = z_abs(&t[t_dim1 + 1]);
+ }
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S") / eps;
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+ ks = 1;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+
+ if (somcon) {
+ if (! select[k]) {
+ goto L50;
+ }
+ }
+
+ if (wants) {
+
+/* Compute the reciprocal condition number of the k-th */
+/* eigenvalue. */
+
+ zdotc_(&z__1, n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks * vl_dim1 +
+ 1], &c__1);
+ prod.r = z__1.r, prod.i = z__1.i;
+ rnrm = dznrm2_(n, &vr[ks * vr_dim1 + 1], &c__1);
+ lnrm = dznrm2_(n, &vl[ks * vl_dim1 + 1], &c__1);
+ s[ks] = z_abs(&prod) / (rnrm * lnrm);
+
+ }
+
+ if (wantsp) {
+
+/* Estimate the reciprocal condition number of the k-th */
+/* eigenvector. */
+
+/* Copy the matrix T to the array WORK and swap the k-th */
+/* diagonal element to the (1,1) position. */
+
+ zlacpy_("Full", n, n, &t[t_offset], ldt, &work[work_offset],
+ ldwork);
+ ztrexc_("No Q", n, &work[work_offset], ldwork, dummy, &c__1, &k, &
+ c__1, &ierr);
+
+/* Form C = T22 - lambda*I in WORK(2:N,2:N). */
+
+ i__2 = *n;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + i__ * work_dim1;
+ i__4 = i__ + i__ * work_dim1;
+ i__5 = work_dim1 + 1;
+ z__1.r = work[i__4].r - work[i__5].r, z__1.i = work[i__4].i -
+ work[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L20: */
+ }
+
+/* Estimate a lower bound for the 1-norm of inv(C'). The 1st */
+/* and (N+1)th columns of WORK are used to store work vectors. */
+
+ sep[ks] = 0.;
+ est = 0.;
+ kase = 0;
+ *(unsigned char *)normin = 'N';
+L30:
+ i__2 = *n - 1;
+ zlacn2_(&i__2, &work[(*n + 1) * work_dim1 + 1], &work[work_offset]
+, &est, &kase, isave);
+
+ if (kase != 0) {
+ if (kase == 1) {
+
+/* Solve C'*x = scale*b */
+
+ i__2 = *n - 1;
+ zlatrs_("Upper", "Conjugate transpose", "Nonunit", normin,
+ &i__2, &work[(work_dim1 << 1) + 2], ldwork, &
+ work[work_offset], &scale, &rwork[1], &ierr);
+ } else {
+
+/* Solve C*x = scale*b */
+
+ i__2 = *n - 1;
+ zlatrs_("Upper", "No transpose", "Nonunit", normin, &i__2,
+ &work[(work_dim1 << 1) + 2], ldwork, &work[
+ work_offset], &scale, &rwork[1], &ierr);
+ }
+ *(unsigned char *)normin = 'Y';
+ if (scale != 1.) {
+
+/* Multiply by 1/SCALE if doing so will not cause */
+/* overflow. */
+
+ i__2 = *n - 1;
+ ix = izamax_(&i__2, &work[work_offset], &c__1);
+ i__2 = ix + work_dim1;
+ xnorm = (d__1 = work[i__2].r, abs(d__1)) + (d__2 = d_imag(
+ &work[ix + work_dim1]), abs(d__2));
+ if (scale < xnorm * smlnum || scale == 0.) {
+ goto L40;
+ }
+ zdrscl_(n, &scale, &work[work_offset], &c__1);
+ }
+ goto L30;
+ }
+
+ sep[ks] = 1. / max(est,smlnum);
+ }
+
+L40:
+ ++ks;
+L50:
+ ;
+ }
+ return 0;
+
+/* End of ZTRSNA */
+
+} /* ztrsna_ */
diff --git a/SRC/ztrsyl.c b/SRC/ztrsyl.c
new file mode 100644
index 0000000..3ab1c31
--- /dev/null
+++ b/SRC/ztrsyl.c
@@ -0,0 +1,547 @@
+/* ztrsyl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ztrsyl_(char *trana, char *tranb, integer *isgn, integer
+ *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *b,
+ integer *ldb, doublecomplex *c__, integer *ldc, doublereal *scale,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
+ i__3, i__4;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer j, k, l;
+ doublecomplex a11;
+ doublereal db;
+ doublecomplex x11;
+ doublereal da11;
+ doublecomplex vec;
+ doublereal dum[1], eps, sgn, smin;
+ doublecomplex suml, sumr;
+ extern logical lsame_(char *, char *);
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *), zdotu_(
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ doublereal scaloc;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ doublereal bignum;
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *,
+ doublecomplex *);
+ logical notrna, notrnb;
+ doublereal smlnum;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTRSYL solves the complex Sylvester matrix equation: */
+
+/* op(A)*X + X*op(B) = scale*C or */
+/* op(A)*X - X*op(B) = scale*C, */
+
+/* where op(A) = A or A**H, and A and B are both upper triangular. A is */
+/* M-by-M and B is N-by-N; the right hand side C and the solution X are */
+/* M-by-N; and scale is an output scale factor, set <= 1 to avoid */
+/* overflow in X. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANA (input) CHARACTER*1 */
+/* Specifies the option op(A): */
+/* = 'N': op(A) = A (No transpose) */
+/* = 'C': op(A) = A**H (Conjugate transpose) */
+
+/* TRANB (input) CHARACTER*1 */
+/* Specifies the option op(B): */
+/* = 'N': op(B) = B (No transpose) */
+/* = 'C': op(B) = B**H (Conjugate transpose) */
+
+/* ISGN (input) INTEGER */
+/* Specifies the sign in the equation: */
+/* = +1: solve op(A)*X + X*op(B) = scale*C */
+/* = -1: solve op(A)*X - X*op(B) = scale*C */
+
+/* M (input) INTEGER */
+/* The order of the matrix A, and the number of rows in the */
+/* matrices X and C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The order of the matrix B, and the number of columns in the */
+/* matrices X and C. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,M) */
+/* The upper triangular matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,N) */
+/* The upper triangular matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
+/* On entry, the M-by-N right hand side matrix C. */
+/* On exit, C is overwritten by the solution matrix X. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M) */
+
+/* SCALE (output) DOUBLE PRECISION */
+/* The scale factor, scale, set <= 1 to avoid overflow in X. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* = 1: A and B have common or very close eigenvalues; perturbed */
+/* values were used to solve the equation (but the matrices */
+/* A and B are unchanged). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and Test input parameters */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+
+ /* Function Body */
+ notrna = lsame_(trana, "N");
+ notrnb = lsame_(tranb, "N");
+
+ *info = 0;
+ if (! notrna && ! lsame_(trana, "C")) {
+ *info = -1;
+ } else if (! notrnb && ! lsame_(tranb, "C")) {
+ *info = -2;
+ } else if (*isgn != 1 && *isgn != -1) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*m)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ } else if (*ldc < max(1,*m)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTRSYL", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ *scale = 1.;
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Set constants to control overflow */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ smlnum = smlnum * (doublereal) (*m * *n) / eps;
+ bignum = 1. / smlnum;
+/* Computing MAX */
+ d__1 = smlnum, d__2 = eps * zlange_("M", m, m, &a[a_offset], lda, dum), d__1 = max(d__1,d__2), d__2 = eps * zlange_("M", n, n,
+ &b[b_offset], ldb, dum);
+ smin = max(d__1,d__2);
+ sgn = (doublereal) (*isgn);
+
+ if (notrna && notrnb) {
+
+/* Solve A*X + ISGN*X*B = scale*C. */
+
+/* The (K,L)th block of X is determined starting from */
+/* bottom-left corner column by column by */
+
+/* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */
+
+/* Where */
+/* M L-1 */
+/* R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)]. */
+/* I=K+1 J=1 */
+
+ i__1 = *n;
+ for (l = 1; l <= i__1; ++l) {
+ for (k = *m; k >= 1; --k) {
+
+ i__2 = *m - k;
+/* Computing MIN */
+ i__3 = k + 1;
+/* Computing MIN */
+ i__4 = k + 1;
+ zdotu_(&z__1, &i__2, &a[k + min(i__3, *m)* a_dim1], lda, &c__[
+ min(i__4, *m)+ l * c_dim1], &c__1);
+ suml.r = z__1.r, suml.i = z__1.i;
+ i__2 = l - 1;
+ zdotu_(&z__1, &i__2, &c__[k + c_dim1], ldc, &b[l * b_dim1 + 1]
+, &c__1);
+ sumr.r = z__1.r, sumr.i = z__1.i;
+ i__2 = k + l * c_dim1;
+ z__3.r = sgn * sumr.r, z__3.i = sgn * sumr.i;
+ z__2.r = suml.r + z__3.r, z__2.i = suml.i + z__3.i;
+ z__1.r = c__[i__2].r - z__2.r, z__1.i = c__[i__2].i - z__2.i;
+ vec.r = z__1.r, vec.i = z__1.i;
+
+ scaloc = 1.;
+ i__2 = k + k * a_dim1;
+ i__3 = l + l * b_dim1;
+ z__2.r = sgn * b[i__3].r, z__2.i = sgn * b[i__3].i;
+ z__1.r = a[i__2].r + z__2.r, z__1.i = a[i__2].i + z__2.i;
+ a11.r = z__1.r, a11.i = z__1.i;
+ da11 = (d__1 = a11.r, abs(d__1)) + (d__2 = d_imag(&a11), abs(
+ d__2));
+ if (da11 <= smin) {
+ a11.r = smin, a11.i = 0.;
+ da11 = smin;
+ *info = 1;
+ }
+ db = (d__1 = vec.r, abs(d__1)) + (d__2 = d_imag(&vec), abs(
+ d__2));
+ if (da11 < 1. && db > 1.) {
+ if (db > bignum * da11) {
+ scaloc = 1. / db;
+ }
+ }
+ z__3.r = scaloc, z__3.i = 0.;
+ z__2.r = vec.r * z__3.r - vec.i * z__3.i, z__2.i = vec.r *
+ z__3.i + vec.i * z__3.r;
+ zladiv_(&z__1, &z__2, &a11);
+ x11.r = z__1.r, x11.i = z__1.i;
+
+ if (scaloc != 1.) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ zdscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L10: */
+ }
+ *scale *= scaloc;
+ }
+ i__2 = k + l * c_dim1;
+ c__[i__2].r = x11.r, c__[i__2].i = x11.i;
+
+/* L20: */
+ }
+/* L30: */
+ }
+
+ } else if (! notrna && notrnb) {
+
+/* Solve A' *X + ISGN*X*B = scale*C. */
+
+/* The (K,L)th block of X is determined starting from */
+/* upper-left corner column by column by */
+
+/* A'(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */
+
+/* Where */
+/* K-1 L-1 */
+/* R(K,L) = SUM [A'(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)] */
+/* I=1 J=1 */
+
+ i__1 = *n;
+ for (l = 1; l <= i__1; ++l) {
+ i__2 = *m;
+ for (k = 1; k <= i__2; ++k) {
+
+ i__3 = k - 1;
+ zdotc_(&z__1, &i__3, &a[k * a_dim1 + 1], &c__1, &c__[l *
+ c_dim1 + 1], &c__1);
+ suml.r = z__1.r, suml.i = z__1.i;
+ i__3 = l - 1;
+ zdotu_(&z__1, &i__3, &c__[k + c_dim1], ldc, &b[l * b_dim1 + 1]
+, &c__1);
+ sumr.r = z__1.r, sumr.i = z__1.i;
+ i__3 = k + l * c_dim1;
+ z__3.r = sgn * sumr.r, z__3.i = sgn * sumr.i;
+ z__2.r = suml.r + z__3.r, z__2.i = suml.i + z__3.i;
+ z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i;
+ vec.r = z__1.r, vec.i = z__1.i;
+
+ scaloc = 1.;
+ d_cnjg(&z__2, &a[k + k * a_dim1]);
+ i__3 = l + l * b_dim1;
+ z__3.r = sgn * b[i__3].r, z__3.i = sgn * b[i__3].i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ a11.r = z__1.r, a11.i = z__1.i;
+ da11 = (d__1 = a11.r, abs(d__1)) + (d__2 = d_imag(&a11), abs(
+ d__2));
+ if (da11 <= smin) {
+ a11.r = smin, a11.i = 0.;
+ da11 = smin;
+ *info = 1;
+ }
+ db = (d__1 = vec.r, abs(d__1)) + (d__2 = d_imag(&vec), abs(
+ d__2));
+ if (da11 < 1. && db > 1.) {
+ if (db > bignum * da11) {
+ scaloc = 1. / db;
+ }
+ }
+
+ z__3.r = scaloc, z__3.i = 0.;
+ z__2.r = vec.r * z__3.r - vec.i * z__3.i, z__2.i = vec.r *
+ z__3.i + vec.i * z__3.r;
+ zladiv_(&z__1, &z__2, &a11);
+ x11.r = z__1.r, x11.i = z__1.i;
+
+ if (scaloc != 1.) {
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ zdscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L40: */
+ }
+ *scale *= scaloc;
+ }
+ i__3 = k + l * c_dim1;
+ c__[i__3].r = x11.r, c__[i__3].i = x11.i;
+
+/* L50: */
+ }
+/* L60: */
+ }
+
+ } else if (! notrna && ! notrnb) {
+
+/* Solve A'*X + ISGN*X*B' = C. */
+
+/* The (K,L)th block of X is determined starting from */
+/* upper-right corner column by column by */
+
+/* A'(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L) */
+
+/* Where */
+/* K-1 */
+/* R(K,L) = SUM [A'(I,K)*X(I,L)] + */
+/* I=1 */
+/* N */
+/* ISGN*SUM [X(K,J)*B'(L,J)]. */
+/* J=L+1 */
+
+ for (l = *n; l >= 1; --l) {
+ i__1 = *m;
+ for (k = 1; k <= i__1; ++k) {
+
+ i__2 = k - 1;
+ zdotc_(&z__1, &i__2, &a[k * a_dim1 + 1], &c__1, &c__[l *
+ c_dim1 + 1], &c__1);
+ suml.r = z__1.r, suml.i = z__1.i;
+ i__2 = *n - l;
+/* Computing MIN */
+ i__3 = l + 1;
+/* Computing MIN */
+ i__4 = l + 1;
+ zdotc_(&z__1, &i__2, &c__[k + min(i__3, *n)* c_dim1], ldc, &b[
+ l + min(i__4, *n)* b_dim1], ldb);
+ sumr.r = z__1.r, sumr.i = z__1.i;
+ i__2 = k + l * c_dim1;
+ d_cnjg(&z__4, &sumr);
+ z__3.r = sgn * z__4.r, z__3.i = sgn * z__4.i;
+ z__2.r = suml.r + z__3.r, z__2.i = suml.i + z__3.i;
+ z__1.r = c__[i__2].r - z__2.r, z__1.i = c__[i__2].i - z__2.i;
+ vec.r = z__1.r, vec.i = z__1.i;
+
+ scaloc = 1.;
+ i__2 = k + k * a_dim1;
+ i__3 = l + l * b_dim1;
+ z__3.r = sgn * b[i__3].r, z__3.i = sgn * b[i__3].i;
+ z__2.r = a[i__2].r + z__3.r, z__2.i = a[i__2].i + z__3.i;
+ d_cnjg(&z__1, &z__2);
+ a11.r = z__1.r, a11.i = z__1.i;
+ da11 = (d__1 = a11.r, abs(d__1)) + (d__2 = d_imag(&a11), abs(
+ d__2));
+ if (da11 <= smin) {
+ a11.r = smin, a11.i = 0.;
+ da11 = smin;
+ *info = 1;
+ }
+ db = (d__1 = vec.r, abs(d__1)) + (d__2 = d_imag(&vec), abs(
+ d__2));
+ if (da11 < 1. && db > 1.) {
+ if (db > bignum * da11) {
+ scaloc = 1. / db;
+ }
+ }
+
+ z__3.r = scaloc, z__3.i = 0.;
+ z__2.r = vec.r * z__3.r - vec.i * z__3.i, z__2.i = vec.r *
+ z__3.i + vec.i * z__3.r;
+ zladiv_(&z__1, &z__2, &a11);
+ x11.r = z__1.r, x11.i = z__1.i;
+
+ if (scaloc != 1.) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ zdscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L70: */
+ }
+ *scale *= scaloc;
+ }
+ i__2 = k + l * c_dim1;
+ c__[i__2].r = x11.r, c__[i__2].i = x11.i;
+
+/* L80: */
+ }
+/* L90: */
+ }
+
+ } else if (notrna && ! notrnb) {
+
+/* Solve A*X + ISGN*X*B' = C. */
+
+/* The (K,L)th block of X is determined starting from */
+/* bottom-left corner column by column by */
+
+/* A(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L) */
+
+/* Where */
+/* M N */
+/* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B'(L,J)] */
+/* I=K+1 J=L+1 */
+
+ for (l = *n; l >= 1; --l) {
+ for (k = *m; k >= 1; --k) {
+
+ i__1 = *m - k;
+/* Computing MIN */
+ i__2 = k + 1;
+/* Computing MIN */
+ i__3 = k + 1;
+ zdotu_(&z__1, &i__1, &a[k + min(i__2, *m)* a_dim1], lda, &c__[
+ min(i__3, *m)+ l * c_dim1], &c__1);
+ suml.r = z__1.r, suml.i = z__1.i;
+ i__1 = *n - l;
+/* Computing MIN */
+ i__2 = l + 1;
+/* Computing MIN */
+ i__3 = l + 1;
+ zdotc_(&z__1, &i__1, &c__[k + min(i__2, *n)* c_dim1], ldc, &b[
+ l + min(i__3, *n)* b_dim1], ldb);
+ sumr.r = z__1.r, sumr.i = z__1.i;
+ i__1 = k + l * c_dim1;
+ d_cnjg(&z__4, &sumr);
+ z__3.r = sgn * z__4.r, z__3.i = sgn * z__4.i;
+ z__2.r = suml.r + z__3.r, z__2.i = suml.i + z__3.i;
+ z__1.r = c__[i__1].r - z__2.r, z__1.i = c__[i__1].i - z__2.i;
+ vec.r = z__1.r, vec.i = z__1.i;
+
+ scaloc = 1.;
+ i__1 = k + k * a_dim1;
+ d_cnjg(&z__3, &b[l + l * b_dim1]);
+ z__2.r = sgn * z__3.r, z__2.i = sgn * z__3.i;
+ z__1.r = a[i__1].r + z__2.r, z__1.i = a[i__1].i + z__2.i;
+ a11.r = z__1.r, a11.i = z__1.i;
+ da11 = (d__1 = a11.r, abs(d__1)) + (d__2 = d_imag(&a11), abs(
+ d__2));
+ if (da11 <= smin) {
+ a11.r = smin, a11.i = 0.;
+ da11 = smin;
+ *info = 1;
+ }
+ db = (d__1 = vec.r, abs(d__1)) + (d__2 = d_imag(&vec), abs(
+ d__2));
+ if (da11 < 1. && db > 1.) {
+ if (db > bignum * da11) {
+ scaloc = 1. / db;
+ }
+ }
+
+ z__3.r = scaloc, z__3.i = 0.;
+ z__2.r = vec.r * z__3.r - vec.i * z__3.i, z__2.i = vec.r *
+ z__3.i + vec.i * z__3.r;
+ zladiv_(&z__1, &z__2, &a11);
+ x11.r = z__1.r, x11.i = z__1.i;
+
+ if (scaloc != 1.) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ zdscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
+/* L100: */
+ }
+ *scale *= scaloc;
+ }
+ i__1 = k + l * c_dim1;
+ c__[i__1].r = x11.r, c__[i__1].i = x11.i;
+
+/* L110: */
+ }
+/* L120: */
+ }
+
+ }
+
+ return 0;
+
+/* End of ZTRSYL */
+
+} /* ztrsyl_ */
diff --git a/SRC/ztrti2.c b/SRC/ztrti2.c
new file mode 100644
index 0000000..43e436c
--- /dev/null
+++ b/SRC/ztrti2.c
@@ -0,0 +1,198 @@
+/* ztrti2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int ztrti2_(char *uplo, char *diag, integer *n,
+ doublecomplex *a, integer *lda, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer j;
+ doublecomplex ajj;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ logical upper;
+ extern /* Subroutine */ int ztrmv_(char *, char *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *);
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTRTI2 computes the inverse of a complex upper or lower triangular */
+/* matrix. */
+
+/* This is the Level 2 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the triangular matrix A. If UPLO = 'U', the */
+/* leading n by n upper triangular part of the array A contains */
+/* the upper triangular matrix, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading n by n lower triangular part of the array A contains */
+/* the lower triangular matrix, and the strictly upper */
+/* triangular part of A is not referenced. If DIAG = 'U', the */
+/* diagonal elements of A are also not referenced and are */
+/* assumed to be 1. */
+
+/* On exit, the (triangular) inverse of the original matrix, in */
+/* the same storage format. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ nounit = lsame_(diag, "N");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTRTI2", &i__1);
+ return 0;
+ }
+
+ if (upper) {
+
+/* Compute inverse of upper triangular matrix. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (nounit) {
+ i__2 = j + j * a_dim1;
+ z_div(&z__1, &c_b1, &a[j + j * a_dim1]);
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ i__2 = j + j * a_dim1;
+ z__1.r = -a[i__2].r, z__1.i = -a[i__2].i;
+ ajj.r = z__1.r, ajj.i = z__1.i;
+ } else {
+ z__1.r = -1., z__1.i = -0.;
+ ajj.r = z__1.r, ajj.i = z__1.i;
+ }
+
+/* Compute elements 1:j-1 of j-th column. */
+
+ i__2 = j - 1;
+ ztrmv_("Upper", "No transpose", diag, &i__2, &a[a_offset], lda, &
+ a[j * a_dim1 + 1], &c__1);
+ i__2 = j - 1;
+ zscal_(&i__2, &ajj, &a[j * a_dim1 + 1], &c__1);
+/* L10: */
+ }
+ } else {
+
+/* Compute inverse of lower triangular matrix. */
+
+ for (j = *n; j >= 1; --j) {
+ if (nounit) {
+ i__1 = j + j * a_dim1;
+ z_div(&z__1, &c_b1, &a[j + j * a_dim1]);
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = j + j * a_dim1;
+ z__1.r = -a[i__1].r, z__1.i = -a[i__1].i;
+ ajj.r = z__1.r, ajj.i = z__1.i;
+ } else {
+ z__1.r = -1., z__1.i = -0.;
+ ajj.r = z__1.r, ajj.i = z__1.i;
+ }
+ if (j < *n) {
+
+/* Compute elements j+1:n of j-th column. */
+
+ i__1 = *n - j;
+ ztrmv_("Lower", "No transpose", diag, &i__1, &a[j + 1 + (j +
+ 1) * a_dim1], lda, &a[j + 1 + j * a_dim1], &c__1);
+ i__1 = *n - j;
+ zscal_(&i__1, &ajj, &a[j + 1 + j * a_dim1], &c__1);
+ }
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of ZTRTI2 */
+
+} /* ztrti2_ */
diff --git a/SRC/ztrtri.c b/SRC/ztrtri.c
new file mode 100644
index 0000000..1fede0c
--- /dev/null
+++ b/SRC/ztrtri.c
@@ -0,0 +1,244 @@
+/* ztrtri.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int ztrtri_(char *uplo, char *diag, integer *n,
+ doublecomplex *a, integer *lda, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, i__1, i__2, i__3[2], i__4, i__5;
+ doublecomplex z__1;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer j, jb, nb, nn;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ extern /* Subroutine */ int ztrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ ztrsm_(char *, char *, char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *), ztrti2_(char *, char *
+, integer *, doublecomplex *, integer *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTRTRI computes the inverse of a complex upper or lower triangular */
+/* matrix A. */
+
+/* This is the Level 3 BLAS version of the algorithm. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the triangular matrix A. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of the array A contains */
+/* the upper triangular matrix, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of the array A contains */
+/* the lower triangular matrix, and the strictly upper */
+/* triangular part of A is not referenced. If DIAG = 'U', the */
+/* diagonal elements of A are also not referenced and are */
+/* assumed to be 1. */
+/* On exit, the (triangular) inverse of the original matrix, in */
+/* the same storage format. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, A(i,i) is exactly zero. The triangular */
+/* matrix is singular and its inverse can not be computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ nounit = lsame_(diag, "N");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTRTRI", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check for singularity if non-unit. */
+
+ if (nounit) {
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ i__2 = *info + *info * a_dim1;
+ if (a[i__2].r == 0. && a[i__2].i == 0.) {
+ return 0;
+ }
+/* L10: */
+ }
+ *info = 0;
+ }
+
+/* Determine the block size for this environment. */
+
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = uplo;
+ i__3[1] = 1, a__1[1] = diag;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ nb = ilaenv_(&c__1, "ZTRTRI", ch__1, n, &c_n1, &c_n1, &c_n1);
+ if (nb <= 1 || nb >= *n) {
+
+/* Use unblocked code */
+
+ ztrti2_(uplo, diag, n, &a[a_offset], lda, info);
+ } else {
+
+/* Use blocked code */
+
+ if (upper) {
+
+/* Compute inverse of upper triangular matrix */
+
+ i__1 = *n;
+ i__2 = nb;
+ for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *n - j + 1;
+ jb = min(i__4,i__5);
+
+/* Compute rows 1:j-1 of current block column */
+
+ i__4 = j - 1;
+ ztrmm_("Left", "Upper", "No transpose", diag, &i__4, &jb, &
+ c_b1, &a[a_offset], lda, &a[j * a_dim1 + 1], lda);
+ i__4 = j - 1;
+ z__1.r = -1., z__1.i = -0.;
+ ztrsm_("Right", "Upper", "No transpose", diag, &i__4, &jb, &
+ z__1, &a[j + j * a_dim1], lda, &a[j * a_dim1 + 1],
+ lda);
+
+/* Compute inverse of current diagonal block */
+
+ ztrti2_("Upper", diag, &jb, &a[j + j * a_dim1], lda, info);
+/* L20: */
+ }
+ } else {
+
+/* Compute inverse of lower triangular matrix */
+
+ nn = (*n - 1) / nb * nb + 1;
+ i__2 = -nb;
+ for (j = nn; i__2 < 0 ? j >= 1 : j <= 1; j += i__2) {
+/* Computing MIN */
+ i__1 = nb, i__4 = *n - j + 1;
+ jb = min(i__1,i__4);
+ if (j + jb <= *n) {
+
+/* Compute rows j+jb:n of current block column */
+
+ i__1 = *n - j - jb + 1;
+ ztrmm_("Left", "Lower", "No transpose", diag, &i__1, &jb,
+ &c_b1, &a[j + jb + (j + jb) * a_dim1], lda, &a[j
+ + jb + j * a_dim1], lda);
+ i__1 = *n - j - jb + 1;
+ z__1.r = -1., z__1.i = -0.;
+ ztrsm_("Right", "Lower", "No transpose", diag, &i__1, &jb,
+ &z__1, &a[j + j * a_dim1], lda, &a[j + jb + j *
+ a_dim1], lda);
+ }
+
+/* Compute inverse of current diagonal block */
+
+ ztrti2_("Lower", diag, &jb, &a[j + j * a_dim1], lda, info);
+/* L30: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZTRTRI */
+
+} /* ztrtri_ */
diff --git a/SRC/ztrtrs.c b/SRC/ztrtrs.c
new file mode 100644
index 0000000..1174f9c
--- /dev/null
+++ b/SRC/ztrtrs.c
@@ -0,0 +1,184 @@
+/* ztrtrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b2 = {1.,0.};
+
+/* Subroutine */ int ztrtrs_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b,
+ integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+
+ /* Local variables */
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ xerbla_(char *, integer *);
+ logical nounit;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTRTRS solves a triangular system of the form */
+
+/* A * X = B, A**T * X = B, or A**H * X = B, */
+
+/* where A is a triangular matrix of order N, and B is an N-by-NRHS */
+/* matrix. A check is made to verify that A is nonsingular. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* = 'N': A is non-unit triangular; */
+/* = 'U': A is unit triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrix B. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side matrix B. */
+/* On exit, if INFO = 0, the solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: if INFO = i, the i-th diagonal element of A is zero, */
+/* indicating that the matrix is singular and the solutions */
+/* X have not been computed. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ nounit = lsame_(diag, "N");
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! nounit && ! lsame_(diag, "U")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -5;
+ } else if (*lda < max(1,*n)) {
+ *info = -7;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTRTRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Check for singularity. */
+
+ if (nounit) {
+ i__1 = *n;
+ for (*info = 1; *info <= i__1; ++(*info)) {
+ i__2 = *info + *info * a_dim1;
+ if (a[i__2].r == 0. && a[i__2].i == 0.) {
+ return 0;
+ }
+/* L10: */
+ }
+ }
+ *info = 0;
+
+/* Solve A * x = b, A**T * x = b, or A**H * x = b. */
+
+ ztrsm_("Left", uplo, trans, diag, n, nrhs, &c_b2, &a[a_offset], lda, &b[
+ b_offset], ldb);
+
+ return 0;
+
+/* End of ZTRTRS */
+
+} /* ztrtrs_ */
diff --git a/SRC/ztrttf.c b/SRC/ztrttf.c
new file mode 100644
index 0000000..b15f625
--- /dev/null
+++ b/SRC/ztrttf.c
@@ -0,0 +1,580 @@
+/* ztrttf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ztrttf_(char *transr, char *uplo, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *arf, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, l, n1, n2, ij, nt, nx2, np1x2;
+ logical normaltransr;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical nisodd;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTRTTF copies a triangular matrix A from standard full format (TR) */
+/* to rectangular full packed format (TF) . */
+
+/* Arguments */
+/* ========= */
+
+/* TRANSR (input) CHARACTER */
+/* = 'N': ARF in Normal mode is wanted; */
+/* = 'C': ARF in Conjugate Transpose mode is wanted; */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension ( LDA, N ) */
+/* On entry, the triangular matrix A. If UPLO = 'U', the */
+/* leading N-by-N upper triangular part of the array A contains */
+/* the upper triangular matrix, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of the array A contains */
+/* the lower triangular matrix, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the matrix A. LDA >= max(1,N). */
+
+/* ARF (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ), */
+/* On exit, the upper or lower triangular matrix A stored in */
+/* RFP format. For a further discussion see Notes below. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Notes */
+/* ===== */
+
+/* We first consider Standard Packed Format when N is even. */
+/* We give an example where N = 6. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 05 00 */
+/* 11 12 13 14 15 10 11 */
+/* 22 23 24 25 20 21 22 */
+/* 33 34 35 30 31 32 33 */
+/* 44 45 40 41 42 43 44 */
+/* 55 50 51 52 53 54 55 */
+
+
+/* Let TRANSR = `N'. RFP holds AP as follows: */
+/* For UPLO = `U' the upper trapezoid A(0:5,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */
+/* conjugate-transpose of the first three columns of AP upper. */
+/* For UPLO = `L' the lower trapezoid A(1:6,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */
+/* conjugate-transpose of the last three columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N even and TRANSR = `N'. */
+
+/* RFP A RFP A */
+
+/* -- -- -- */
+/* 03 04 05 33 43 53 */
+/* -- -- */
+/* 13 14 15 00 44 54 */
+/* -- */
+/* 23 24 25 10 11 55 */
+
+/* 33 34 35 20 21 22 */
+/* -- */
+/* 00 44 45 30 31 32 */
+/* -- -- */
+/* 01 11 55 40 41 42 */
+/* -- -- -- */
+/* 02 12 22 50 51 52 */
+
+/* Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- -- */
+/* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */
+
+
+/* We next consider Standard Packed Format when N is odd. */
+/* We give an example where N = 5. */
+
+/* AP is Upper AP is Lower */
+
+/* 00 01 02 03 04 00 */
+/* 11 12 13 14 10 11 */
+/* 22 23 24 20 21 22 */
+/* 33 34 30 31 32 33 */
+/* 44 40 41 42 43 44 */
+
+
+/* Let TRANSR = `N'. RFP holds AP as follows: */
+/* For UPLO = `U' the upper trapezoid A(0:4,0:2) consists of the last */
+/* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */
+/* conjugate-transpose of the first two columns of AP upper. */
+/* For UPLO = `L' the lower trapezoid A(0:4,0:2) consists of the first */
+/* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */
+/* conjugate-transpose of the last two columns of AP lower. */
+/* To denote conjugate we place -- above the element. This covers the */
+/* case N odd and TRANSR = `N'. */
+
+/* RFP A RFP A */
+
+/* -- -- */
+/* 02 03 04 00 33 43 */
+/* -- */
+/* 12 13 14 10 11 44 */
+
+/* 22 23 24 20 21 22 */
+/* -- */
+/* 00 33 34 30 31 32 */
+/* -- -- */
+/* 01 11 44 40 41 42 */
+
+/* Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate- */
+/* transpose of RFP A above. One therefore gets: */
+
+
+/* RFP A RFP A */
+
+/* -- -- -- -- -- -- -- -- -- */
+/* 02 12 22 00 01 00 10 20 30 40 50 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 03 13 23 33 11 33 11 21 31 41 51 */
+/* -- -- -- -- -- -- -- -- -- */
+/* 04 14 24 34 44 43 44 22 32 42 52 */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda - 1 - 0 + 1;
+ a_offset = 0 + a_dim1 * 0;
+ a -= a_offset;
+
+ /* Function Body */
+ *info = 0;
+ normaltransr = lsame_(transr, "N");
+ lower = lsame_(uplo, "L");
+ if (! normaltransr && ! lsame_(transr, "C")) {
+ *info = -1;
+ } else if (! lower && ! lsame_(uplo, "U")) {
+ *info = -2;
+ } else if (*n < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTRTTF", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 1) {
+ if (*n == 1) {
+ if (normaltransr) {
+ arf[0].r = a[0].r, arf[0].i = a[0].i;
+ } else {
+ d_cnjg(&z__1, a);
+ arf[0].r = z__1.r, arf[0].i = z__1.i;
+ }
+ }
+ return 0;
+ }
+
+/* Size of array ARF(1:2,0:nt-1) */
+
+ nt = *n * (*n + 1) / 2;
+
+/* set N1 and N2 depending on LOWER: for N even N1=N2=K */
+
+ if (lower) {
+ n2 = *n / 2;
+ n1 = *n - n2;
+ } else {
+ n1 = *n / 2;
+ n2 = *n - n1;
+ }
+
+/* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. */
+/* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is */
+/* N--by--(N+1)/2. */
+
+ if (*n % 2 == 0) {
+ k = *n / 2;
+ nisodd = FALSE_;
+ if (! lower) {
+ np1x2 = *n + *n + 2;
+ }
+ } else {
+ nisodd = TRUE_;
+ if (! lower) {
+ nx2 = *n + *n;
+ }
+ }
+
+ if (nisodd) {
+
+/* N is odd */
+
+ if (normaltransr) {
+
+/* N is odd and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */
+/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */
+/* T1 -> a(0), T2 -> a(n), S -> a(n1); lda=n */
+
+ ij = 0;
+ i__1 = n2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = n2 + j;
+ for (i__ = n1; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ d_cnjg(&z__1, &a[n2 + j + i__ * a_dim1]);
+ arf[i__3].r = z__1.r, arf[i__3].i = z__1.i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ i__4 = i__ + j * a_dim1;
+ arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i;
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */
+/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */
+/* T1 -> a(n2), T2 -> a(n1), S -> a(0); lda=n */
+
+ ij = nt - *n;
+ i__1 = n1;
+ for (j = *n - 1; j >= i__1; --j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ i__4 = i__ + j * a_dim1;
+ arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i;
+ ++ij;
+ }
+ i__2 = n1 - 1;
+ for (l = j - n1; l <= i__2; ++l) {
+ i__3 = ij;
+ d_cnjg(&z__1, &a[j - n1 + l * a_dim1]);
+ arf[i__3].r = z__1.r, arf[i__3].i = z__1.i;
+ ++ij;
+ }
+ ij -= nx2;
+ }
+
+ }
+
+ } else {
+
+/* N is odd and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is odd */
+/* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */
+/* T1 -> A(0+0) , T2 -> A(1+0) , S -> A(0+n1*n1); lda=n1 */
+
+ ij = 0;
+ i__1 = n2 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ d_cnjg(&z__1, &a[j + i__ * a_dim1]);
+ arf[i__3].r = z__1.r, arf[i__3].i = z__1.i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = n1 + j; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ i__4 = i__ + (n1 + j) * a_dim1;
+ arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i;
+ ++ij;
+ }
+ }
+ i__1 = *n - 1;
+ for (j = n2; j <= i__1; ++j) {
+ i__2 = n1 - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ d_cnjg(&z__1, &a[j + i__ * a_dim1]);
+ arf[i__3].r = z__1.r, arf[i__3].i = z__1.i;
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is odd */
+/* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */
+/* T1 -> A(n2*n2), T2 -> A(n1*n2), S -> A(0); lda=n2 */
+
+ ij = 0;
+ i__1 = n1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = n1; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ d_cnjg(&z__1, &a[j + i__ * a_dim1]);
+ arf[i__3].r = z__1.r, arf[i__3].i = z__1.i;
+ ++ij;
+ }
+ }
+ i__1 = n1 - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ i__4 = i__ + j * a_dim1;
+ arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (l = n2 + j; l <= i__2; ++l) {
+ i__3 = ij;
+ d_cnjg(&z__1, &a[n2 + j + l * a_dim1]);
+ arf[i__3].r = z__1.r, arf[i__3].i = z__1.i;
+ ++ij;
+ }
+ }
+
+ }
+
+ }
+
+ } else {
+
+/* N is even */
+
+ if (normaltransr) {
+
+/* N is even and TRANSR = 'N' */
+
+ if (lower) {
+
+/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */
+/* T1 -> a(1), T2 -> a(0), S -> a(k+1); lda=n+1 */
+
+ ij = 0;
+ i__1 = k - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = k + j;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ d_cnjg(&z__1, &a[k + j + i__ * a_dim1]);
+ arf[i__3].r = z__1.r, arf[i__3].i = z__1.i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ i__4 = i__ + j * a_dim1;
+ arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i;
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */
+/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */
+/* T1 -> a(k+1), T2 -> a(k), S -> a(0); lda=n+1 */
+
+ ij = nt - *n - 1;
+ i__1 = k;
+ for (j = *n - 1; j >= i__1; --j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ i__4 = i__ + j * a_dim1;
+ arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i;
+ ++ij;
+ }
+ i__2 = k - 1;
+ for (l = j - k; l <= i__2; ++l) {
+ i__3 = ij;
+ d_cnjg(&z__1, &a[j - k + l * a_dim1]);
+ arf[i__3].r = z__1.r, arf[i__3].i = z__1.i;
+ ++ij;
+ }
+ ij -= np1x2;
+ }
+
+ }
+
+ } else {
+
+/* N is even and TRANSR = 'C' */
+
+ if (lower) {
+
+/* SRPA for LOWER, TRANSPOSE and N is even (see paper, A=B) */
+/* T1 -> A(0,1) , T2 -> A(0,0) , S -> A(0,k+1) : */
+/* T1 -> A(0+k) , T2 -> A(0+0) , S -> A(0+k*(k+1)); lda=k */
+
+ ij = 0;
+ j = k;
+ i__1 = *n - 1;
+ for (i__ = k; i__ <= i__1; ++i__) {
+ i__2 = ij;
+ i__3 = i__ + j * a_dim1;
+ arf[i__2].r = a[i__3].r, arf[i__2].i = a[i__3].i;
+ ++ij;
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ d_cnjg(&z__1, &a[j + i__ * a_dim1]);
+ arf[i__3].r = z__1.r, arf[i__3].i = z__1.i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (i__ = k + 1 + j; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ i__4 = i__ + (k + 1 + j) * a_dim1;
+ arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i;
+ ++ij;
+ }
+ }
+ i__1 = *n - 1;
+ for (j = k - 1; j <= i__1; ++j) {
+ i__2 = k - 1;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ d_cnjg(&z__1, &a[j + i__ * a_dim1]);
+ arf[i__3].r = z__1.r, arf[i__3].i = z__1.i;
+ ++ij;
+ }
+ }
+
+ } else {
+
+/* SRPA for UPPER, TRANSPOSE and N is even (see paper, A=B) */
+/* T1 -> A(0,k+1) , T2 -> A(0,k) , S -> A(0,0) */
+/* T1 -> A(0+k*(k+1)) , T2 -> A(0+k*k) , S -> A(0+0)); lda=k */
+
+ ij = 0;
+ i__1 = k;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = *n - 1;
+ for (i__ = k; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ d_cnjg(&z__1, &a[j + i__ * a_dim1]);
+ arf[i__3].r = z__1.r, arf[i__3].i = z__1.i;
+ ++ij;
+ }
+ }
+ i__1 = k - 2;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 0; i__ <= i__2; ++i__) {
+ i__3 = ij;
+ i__4 = i__ + j * a_dim1;
+ arf[i__3].r = a[i__4].r, arf[i__3].i = a[i__4].i;
+ ++ij;
+ }
+ i__2 = *n - 1;
+ for (l = k + 1 + j; l <= i__2; ++l) {
+ i__3 = ij;
+ d_cnjg(&z__1, &a[k + 1 + j + l * a_dim1]);
+ arf[i__3].r = z__1.r, arf[i__3].i = z__1.i;
+ ++ij;
+ }
+ }
+
+/* Note that here J = K-1 */
+
+ i__1 = j;
+ for (i__ = 0; i__ <= i__1; ++i__) {
+ i__2 = ij;
+ i__3 = i__ + j * a_dim1;
+ arf[i__2].r = a[i__3].r, arf[i__2].i = a[i__3].i;
+ ++ij;
+ }
+
+ }
+
+ }
+
+ }
+
+ return 0;
+
+/* End of ZTRTTF */
+
+} /* ztrttf_ */
diff --git a/SRC/ztrttp.c b/SRC/ztrttp.c
new file mode 100644
index 0000000..7ac99cc
--- /dev/null
+++ b/SRC/ztrttp.c
@@ -0,0 +1,149 @@
+/* ztrttp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ztrttp_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *ap, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, k;
+ extern logical lsame_(char *, char *);
+ logical lower;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+
+/* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */
+/* -- and Julien Langou of the Univ. of Colorado Denver -- */
+/* -- November 2008 -- */
+
+/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
+/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTRTTP copies a triangular matrix A from full format (TR) to standard */
+/* packed format (TP). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER */
+/* = 'U': A is upper triangular; */
+/* = 'L': A is lower triangular. */
+
+/* N (input) INTEGER */
+/* The order of the matrices AP and A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the triangular matrix A. If UPLO = 'U', the leading */
+/* N-by-N upper triangular part of A contains the upper */
+/* triangular part of the matrix A, and the strictly lower */
+/* triangular part of A is not referenced. If UPLO = 'L', the */
+/* leading N-by-N lower triangular part of A contains the lower */
+/* triangular part of the matrix A, and the strictly upper */
+/* triangular part of A is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AP (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ), */
+/* On exit, the upper or lower triangular matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ap;
+
+ /* Function Body */
+ *info = 0;
+ lower = lsame_(uplo, "L");
+ if (! lower && ! lsame_(uplo, "U")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTRTTP", &i__1);
+ return 0;
+ }
+
+ if (lower) {
+ k = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ++k;
+ i__3 = k;
+ i__4 = i__ + j * a_dim1;
+ ap[i__3].r = a[i__4].r, ap[i__3].i = a[i__4].i;
+ }
+ }
+ } else {
+ k = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ++k;
+ i__3 = k;
+ i__4 = i__ + j * a_dim1;
+ ap[i__3].r = a[i__4].r, ap[i__3].i = a[i__4].i;
+ }
+ }
+ }
+
+
+ return 0;
+
+/* End of ZTRTTP */
+
+} /* ztrttp_ */
diff --git a/SRC/ztzrqf.c b/SRC/ztzrqf.c
new file mode 100644
index 0000000..c096d8f
--- /dev/null
+++ b/SRC/ztzrqf.c
@@ -0,0 +1,241 @@
+/* ztzrqf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int ztzrqf_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *tau, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, k, m1;
+ doublecomplex alpha;
+ extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *), xerbla_(char *, integer *), zlacgv_(integer *, doublecomplex *, integer *), zlarfp_(
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This routine is deprecated and has been replaced by routine ZTZRZF. */
+
+/* ZTZRQF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A */
+/* to upper triangular form by means of unitary transformations. */
+
+/* The upper trapezoidal matrix A is factored as */
+
+/* A = ( R 0 ) * Z, */
+
+/* where Z is an N-by-N unitary matrix and R is an M-by-M upper */
+/* triangular matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= M. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the leading M-by-N upper trapezoidal part of the */
+/* array A must contain the matrix to be factorized. */
+/* On exit, the leading M-by-M upper triangular part of A */
+/* contains the upper triangular matrix R, and elements M+1 to */
+/* N of the first M rows of A, with the array TAU, represent the */
+/* unitary matrix Z as a product of M elementary reflectors. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX*16 array, dimension (M) */
+/* The scalar factors of the elementary reflectors. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* The factorization is obtained by Householder's method. The kth */
+/* transformation matrix, Z( k ), whose conjugate transpose is used to */
+/* introduce zeros into the (m - k + 1)th row of A, is given in the form */
+
+/* Z( k ) = ( I 0 ), */
+/* ( 0 T( k ) ) */
+
+/* where */
+
+/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */
+/* ( 0 ) */
+/* ( z( k ) ) */
+
+/* tau is a scalar and z( k ) is an ( n - m ) element vector. */
+/* tau and z( k ) are chosen to annihilate the elements of the kth row */
+/* of X. */
+
+/* The scalar tau is returned in the kth element of TAU and the vector */
+/* u( k ) in the kth row of A, such that the elements of z( k ) are */
+/* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */
+/* the upper triangular part of A. */
+
+/* Z is given by */
+
+/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTZRQF", &i__1);
+ return 0;
+ }
+
+/* Perform the factorization. */
+
+ if (*m == 0) {
+ return 0;
+ }
+ if (*m == *n) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ tau[i__2].r = 0., tau[i__2].i = 0.;
+/* L10: */
+ }
+ } else {
+/* Computing MIN */
+ i__1 = *m + 1;
+ m1 = min(i__1,*n);
+ for (k = *m; k >= 1; --k) {
+
+/* Use a Householder reflection to zero the kth row of A. */
+/* First set up the reflection. */
+
+ i__1 = k + k * a_dim1;
+ d_cnjg(&z__1, &a[k + k * a_dim1]);
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = *n - *m;
+ zlacgv_(&i__1, &a[k + m1 * a_dim1], lda);
+ i__1 = k + k * a_dim1;
+ alpha.r = a[i__1].r, alpha.i = a[i__1].i;
+ i__1 = *n - *m + 1;
+ zlarfp_(&i__1, &alpha, &a[k + m1 * a_dim1], lda, &tau[k]);
+ i__1 = k + k * a_dim1;
+ a[i__1].r = alpha.r, a[i__1].i = alpha.i;
+ i__1 = k;
+ d_cnjg(&z__1, &tau[k]);
+ tau[i__1].r = z__1.r, tau[i__1].i = z__1.i;
+
+ i__1 = k;
+ if ((tau[i__1].r != 0. || tau[i__1].i != 0.) && k > 1) {
+
+/* We now perform the operation A := A*P( k )'. */
+
+/* Use the first ( k - 1 ) elements of TAU to store a( k ), */
+/* where a( k ) consists of the first ( k - 1 ) elements of */
+/* the kth column of A. Also let B denote the first */
+/* ( k - 1 ) rows of the last ( n - m ) columns of A. */
+
+ i__1 = k - 1;
+ zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &tau[1], &c__1);
+
+/* Form w = a( k ) + B*z( k ) in TAU. */
+
+ i__1 = k - 1;
+ i__2 = *n - *m;
+ zgemv_("No transpose", &i__1, &i__2, &c_b1, &a[m1 * a_dim1 +
+ 1], lda, &a[k + m1 * a_dim1], lda, &c_b1, &tau[1], &
+ c__1);
+
+/* Now form a( k ) := a( k ) - conjg(tau)*w */
+/* and B := B - conjg(tau)*w*z( k )'. */
+
+ i__1 = k - 1;
+ d_cnjg(&z__2, &tau[k]);
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ zaxpy_(&i__1, &z__1, &tau[1], &c__1, &a[k * a_dim1 + 1], &
+ c__1);
+ i__1 = k - 1;
+ i__2 = *n - *m;
+ d_cnjg(&z__2, &tau[k]);
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ zgerc_(&i__1, &i__2, &z__1, &tau[1], &c__1, &a[k + m1 *
+ a_dim1], lda, &a[m1 * a_dim1 + 1], lda);
+ }
+/* L20: */
+ }
+ }
+
+ return 0;
+
+/* End of ZTZRQF */
+
+} /* ztzrqf_ */
diff --git a/SRC/ztzrzf.c b/SRC/ztzrzf.c
new file mode 100644
index 0000000..b18feeb
--- /dev/null
+++ b/SRC/ztzrzf.c
@@ -0,0 +1,313 @@
+/* ztzrzf.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int ztzrzf_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+
+ /* Local variables */
+ integer i__, m1, ib, nb, ki, kk, mu, nx, iws, nbmin;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer ldwork;
+ extern /* Subroutine */ int zlarzb_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int zlarzt_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zlatrz_(integer *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, doublecomplex *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTZRZF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A */
+/* to upper triangular form by means of unitary transformations. */
+
+/* The upper trapezoidal matrix A is factored as */
+
+/* A = ( R 0 ) * Z, */
+
+/* where Z is an N-by-N unitary matrix and R is an M-by-M upper */
+/* triangular matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= M. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the leading M-by-N upper trapezoidal part of the */
+/* array A must contain the matrix to be factorized. */
+/* On exit, the leading M-by-M upper triangular part of A */
+/* contains the upper triangular matrix R, and elements M+1 to */
+/* N of the first M rows of A, with the array TAU, represent the */
+/* unitary matrix Z as a product of M elementary reflectors. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (output) COMPLEX*16 array, dimension (M) */
+/* The scalar factors of the elementary reflectors. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M). */
+/* For optimum performance LWORK >= M*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* The factorization is obtained by Householder's method. The kth */
+/* transformation matrix, Z( k ), which is used to introduce zeros into */
+/* the ( m - k + 1 )th row of A, is given in the form */
+
+/* Z( k ) = ( I 0 ), */
+/* ( 0 T( k ) ) */
+
+/* where */
+
+/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */
+/* ( 0 ) */
+/* ( z( k ) ) */
+
+/* tau is a scalar and z( k ) is an ( n - m ) element vector. */
+/* tau and z( k ) are chosen to annihilate the elements of the kth row */
+/* of X. */
+
+/* The scalar tau is returned in the kth element of TAU and the vector */
+/* u( k ) in the kth row of A, such that the elements of z( k ) are */
+/* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */
+/* the upper triangular part of A. */
+
+/* Z is given by */
+
+/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*lda < max(1,*m)) {
+ *info = -4;
+ }
+
+ if (*info == 0) {
+ if (*m == 0 || *m == *n) {
+ lwkopt = 1;
+ } else {
+
+/* Determine the block size. */
+
+ nb = ilaenv_(&c__1, "ZGERQF", " ", m, n, &c_n1, &c_n1);
+ lwkopt = *m * nb;
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ if (*lwork < max(1,*m) && ! lquery) {
+ *info = -7;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZTZRZF", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0) {
+ return 0;
+ } else if (*m == *n) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ tau[i__2].r = 0., tau[i__2].i = 0.;
+/* L10: */
+ }
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 1;
+ iws = *m;
+ if (nb > 1 && nb < *m) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "ZGERQF", " ", m, n, &c_n1, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *m) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *m;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "ZGERQF", " ", m, n, &c_n1, &
+ c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < *m && nx < *m) {
+
+/* Use blocked code initially. */
+/* The last kk rows are handled by the block method. */
+
+/* Computing MIN */
+ i__1 = *m + 1;
+ m1 = min(i__1,*n);
+ ki = (*m - nx - 1) / nb * nb;
+/* Computing MIN */
+ i__1 = *m, i__2 = ki + nb;
+ kk = min(i__1,i__2);
+
+ i__1 = *m - kk + 1;
+ i__2 = -nb;
+ for (i__ = *m - kk + ki + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1;
+ i__ += i__2) {
+/* Computing MIN */
+ i__3 = *m - i__ + 1;
+ ib = min(i__3,nb);
+
+/* Compute the TZ factorization of the current block */
+/* A(i:i+ib-1,i:n) */
+
+ i__3 = *n - i__ + 1;
+ i__4 = *n - *m;
+ zlatrz_(&ib, &i__3, &i__4, &a[i__ + i__ * a_dim1], lda, &tau[i__],
+ &work[1]);
+ if (i__ > 1) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__3 = *n - *m;
+ zlarzt_("Backward", "Rowwise", &i__3, &ib, &a[i__ + m1 *
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H to A(1:i-1,i:n) from the right */
+
+ i__3 = i__ - 1;
+ i__4 = *n - i__ + 1;
+ i__5 = *n - *m;
+ zlarzb_("Right", "No transpose", "Backward", "Rowwise", &i__3,
+ &i__4, &ib, &i__5, &a[i__ + m1 * a_dim1], lda, &work[
+ 1], &ldwork, &a[i__ * a_dim1 + 1], lda, &work[ib + 1],
+ &ldwork)
+ ;
+ }
+/* L20: */
+ }
+ mu = i__ + nb - 1;
+ } else {
+ mu = *m;
+ }
+
+/* Use unblocked code to factor the last or only block */
+
+ if (mu > 0) {
+ i__2 = *n - *m;
+ zlatrz_(&mu, n, &i__2, &a[a_offset], lda, &tau[1], &work[1]);
+ }
+
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZTZRZF */
+
+} /* ztzrzf_ */
diff --git a/SRC/zung2l.c b/SRC/zung2l.c
new file mode 100644
index 0000000..1c75899
--- /dev/null
+++ b/SRC/zung2l.c
@@ -0,0 +1,183 @@
+/* zung2l.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zung2l_(integer *m, integer *n, integer *k,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j, l, ii;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zlarf_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNG2L generates an m by n complex matrix Q with orthonormal columns, */
+/* which is defined as the last n columns of a product of k elementary */
+/* reflectors of order m */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by ZGEQLF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the (n-k+i)-th column must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by ZGEQLF in the last k columns of its array */
+/* argument A. */
+/* On exit, the m-by-n matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) COMPLEX*16 array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZGEQLF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUNG2L", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Initialise columns 1:n-k to columns of the unit matrix */
+
+ i__1 = *n - *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = l + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L10: */
+ }
+ i__2 = *m - *n + j + j * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+/* L20: */
+ }
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ii = *n - *k + i__;
+
+/* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left */
+
+ i__2 = *m - *n + ii + ii * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+ i__2 = *m - *n + ii;
+ i__3 = ii - 1;
+ zlarf_("Left", &i__2, &i__3, &a[ii * a_dim1 + 1], &c__1, &tau[i__], &
+ a[a_offset], lda, &work[1]);
+ i__2 = *m - *n + ii - 1;
+ i__3 = i__;
+ z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i;
+ zscal_(&i__2, &z__1, &a[ii * a_dim1 + 1], &c__1);
+ i__2 = *m - *n + ii + ii * a_dim1;
+ i__3 = i__;
+ z__1.r = 1. - tau[i__3].r, z__1.i = 0. - tau[i__3].i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+
+/* Set A(m-k+i+1:m,n-k+i) to zero */
+
+ i__2 = *m;
+ for (l = *m - *n + ii + 1; l <= i__2; ++l) {
+ i__3 = l + ii * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+ return 0;
+
+/* End of ZUNG2L */
+
+} /* zung2l_ */
diff --git a/SRC/zung2r.c b/SRC/zung2r.c
new file mode 100644
index 0000000..9acf7f7
--- /dev/null
+++ b/SRC/zung2r.c
@@ -0,0 +1,185 @@
+/* zung2r.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zung2r_(integer *m, integer *n, integer *k,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j, l;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zlarf_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNG2R generates an m by n complex matrix Q with orthonormal columns, */
+/* which is defined as the first n columns of a product of k elementary */
+/* reflectors of order m */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by ZGEQRF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the i-th column must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by ZGEQRF in the first k columns of its array */
+/* argument A. */
+/* On exit, the m by n matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) COMPLEX*16 array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZGEQRF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUNG2R", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Initialise columns k+1:n to columns of the unit matrix */
+
+ i__1 = *n;
+ for (j = *k + 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = l + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L10: */
+ }
+ i__2 = j + j * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+/* L20: */
+ }
+
+ for (i__ = *k; i__ >= 1; --i__) {
+
+/* Apply H(i) to A(i:m,i:n) from the left */
+
+ if (i__ < *n) {
+ i__1 = i__ + i__ * a_dim1;
+ a[i__1].r = 1., a[i__1].i = 0.;
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__;
+ zlarf_("Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[
+ i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
+ }
+ if (i__ < *m) {
+ i__1 = *m - i__;
+ i__2 = i__;
+ z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i;
+ zscal_(&i__1, &z__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
+ }
+ i__1 = i__ + i__ * a_dim1;
+ i__2 = i__;
+ z__1.r = 1. - tau[i__2].r, z__1.i = 0. - tau[i__2].i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+
+/* Set A(1:i-1,i) to zero */
+
+ i__1 = i__ - 1;
+ for (l = 1; l <= i__1; ++l) {
+ i__2 = l + i__ * a_dim1;
+ a[i__2].r = 0., a[i__2].i = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+ return 0;
+
+/* End of ZUNG2R */
+
+} /* zung2r_ */
diff --git a/SRC/zungbr.c b/SRC/zungbr.c
new file mode 100644
index 0000000..f620c41
--- /dev/null
+++ b/SRC/zungbr.c
@@ -0,0 +1,310 @@
+/* zungbr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zungbr_(char *vect, integer *m, integer *n, integer *k,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, nb, mn;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical wantq;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int zunglq_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *), zungqr_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNGBR generates one of the complex unitary matrices Q or P**H */
+/* determined by ZGEBRD when reducing a complex matrix A to bidiagonal */
+/* form: A = Q * B * P**H. Q and P**H are defined as products of */
+/* elementary reflectors H(i) or G(i) respectively. */
+
+/* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q */
+/* is of order M: */
+/* if m >= k, Q = H(1) H(2) . . . H(k) and ZUNGBR returns the first n */
+/* columns of Q, where m >= n >= k; */
+/* if m < k, Q = H(1) H(2) . . . H(m-1) and ZUNGBR returns Q as an */
+/* M-by-M matrix. */
+
+/* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H */
+/* is of order N: */
+/* if k < n, P**H = G(k) . . . G(2) G(1) and ZUNGBR returns the first m */
+/* rows of P**H, where n >= m >= k; */
+/* if k >= n, P**H = G(n-1) . . . G(2) G(1) and ZUNGBR returns P**H as */
+/* an N-by-N matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* VECT (input) CHARACTER*1 */
+/* Specifies whether the matrix Q or the matrix P**H is */
+/* required, as defined in the transformation applied by ZGEBRD: */
+/* = 'Q': generate Q; */
+/* = 'P': generate P**H. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q or P**H to be returned. */
+/* M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q or P**H to be returned. */
+/* N >= 0. */
+/* If VECT = 'Q', M >= N >= min(M,K); */
+/* if VECT = 'P', N >= M >= min(N,K). */
+
+/* K (input) INTEGER */
+/* If VECT = 'Q', the number of columns in the original M-by-K */
+/* matrix reduced by ZGEBRD. */
+/* If VECT = 'P', the number of rows in the original K-by-N */
+/* matrix reduced by ZGEBRD. */
+/* K >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the vectors which define the elementary reflectors, */
+/* as returned by ZGEBRD. */
+/* On exit, the M-by-N matrix Q or P**H. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* TAU (input) COMPLEX*16 array, dimension */
+/* (min(M,K)) if VECT = 'Q' */
+/* (min(N,K)) if VECT = 'P' */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i) or G(i), which determines Q or P**H, as */
+/* returned by ZGEBRD in its array argument TAUQ or TAUP. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,min(M,N)). */
+/* For optimum performance LWORK >= min(M,N)*NB, where NB */
+/* is the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ wantq = lsame_(vect, "Q");
+ mn = min(*m,*n);
+ lquery = *lwork == -1;
+ if (! wantq && ! lsame_(vect, "P")) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -2;
+ } else if (*n < 0 || wantq && (*n > *m || *n < min(*m,*k)) || ! wantq && (
+ *m > *n || *m < min(*n,*k))) {
+ *info = -3;
+ } else if (*k < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -6;
+ } else if (*lwork < max(1,mn) && ! lquery) {
+ *info = -9;
+ }
+
+ if (*info == 0) {
+ if (wantq) {
+ nb = ilaenv_(&c__1, "ZUNGQR", " ", m, n, k, &c_n1);
+ } else {
+ nb = ilaenv_(&c__1, "ZUNGLQ", " ", m, n, k, &c_n1);
+ }
+ lwkopt = max(1,mn) * nb;
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUNGBR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ work[1].r = 1., work[1].i = 0.;
+ return 0;
+ }
+
+ if (wantq) {
+
+/* Form Q, determined by a call to ZGEBRD to reduce an m-by-k */
+/* matrix */
+
+ if (*m >= *k) {
+
+/* If m >= k, assume m >= n >= k */
+
+ zungqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
+ iinfo);
+
+ } else {
+
+/* If m < k, assume m = n */
+
+/* Shift the vectors which define the elementary reflectors one */
+/* column to the right, and set the first row and column of Q */
+/* to those of the unit matrix */
+
+ for (j = *m; j >= 2; --j) {
+ i__1 = j * a_dim1 + 1;
+ a[i__1].r = 0., a[i__1].i = 0.;
+ i__1 = *m;
+ for (i__ = j + 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * a_dim1;
+ i__3 = i__ + (j - 1) * a_dim1;
+ a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
+/* L10: */
+ }
+/* L20: */
+ }
+ i__1 = a_dim1 + 1;
+ a[i__1].r = 1., a[i__1].i = 0.;
+ i__1 = *m;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__ + a_dim1;
+ a[i__2].r = 0., a[i__2].i = 0.;
+/* L30: */
+ }
+ if (*m > 1) {
+
+/* Form Q(2:m,2:m) */
+
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ zungqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[
+ 1], &work[1], lwork, &iinfo);
+ }
+ }
+ } else {
+
+/* Form P', determined by a call to ZGEBRD to reduce a k-by-n */
+/* matrix */
+
+ if (*k < *n) {
+
+/* If k < n, assume k <= m <= n */
+
+ zunglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
+ iinfo);
+
+ } else {
+
+/* If k >= n, assume m = n */
+
+/* Shift the vectors which define the elementary reflectors one */
+/* row downward, and set the first row and column of P' to */
+/* those of the unit matrix */
+
+ i__1 = a_dim1 + 1;
+ a[i__1].r = 1., a[i__1].i = 0.;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__ + a_dim1;
+ a[i__2].r = 0., a[i__2].i = 0.;
+/* L40: */
+ }
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ for (i__ = j - 1; i__ >= 2; --i__) {
+ i__2 = i__ + j * a_dim1;
+ i__3 = i__ - 1 + j * a_dim1;
+ a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
+/* L50: */
+ }
+ i__2 = j * a_dim1 + 1;
+ a[i__2].r = 0., a[i__2].i = 0.;
+/* L60: */
+ }
+ if (*n > 1) {
+
+/* Form P'(2:n,2:n) */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ zunglq_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[
+ 1], &work[1], lwork, &iinfo);
+ }
+ }
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ return 0;
+
+/* End of ZUNGBR */
+
+} /* zungbr_ */
diff --git a/SRC/zunghr.c b/SRC/zunghr.c
new file mode 100644
index 0000000..b78c018
--- /dev/null
+++ b/SRC/zunghr.c
@@ -0,0 +1,224 @@
+/* zunghr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zunghr_(integer *n, integer *ilo, integer *ihi,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, nb, nh, iinfo;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int zungqr_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNGHR generates a complex unitary matrix Q which is defined as the */
+/* product of IHI-ILO elementary reflectors of order N, as returned by */
+/* ZGEHRD: */
+
+/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix Q. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* ILO and IHI must have the same values as in the previous call */
+/* of ZGEHRD. Q is equal to the unit matrix except in the */
+/* submatrix Q(ilo+1:ihi,ilo+1:ihi). */
+/* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the vectors which define the elementary reflectors, */
+/* as returned by ZGEHRD. */
+/* On exit, the N-by-N unitary matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* TAU (input) COMPLEX*16 array, dimension (N-1) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZGEHRD. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= IHI-ILO. */
+/* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nh = *ihi - *ilo;
+ lquery = *lwork == -1;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*ilo < 1 || *ilo > max(1,*n)) {
+ *info = -2;
+ } else if (*ihi < min(*ilo,*n) || *ihi > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ } else if (*lwork < max(1,nh) && ! lquery) {
+ *info = -8;
+ }
+
+ if (*info == 0) {
+ nb = ilaenv_(&c__1, "ZUNGQR", " ", &nh, &nh, &nh, &c_n1);
+ lwkopt = max(1,nh) * nb;
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUNGHR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ work[1].r = 1., work[1].i = 0.;
+ return 0;
+ }
+
+/* Shift the vectors which define the elementary reflectors one */
+/* column to the right, and set the first ilo and the last n-ihi */
+/* rows and columns to those of the unit matrix */
+
+ i__1 = *ilo + 1;
+ for (j = *ihi; j >= i__1; --j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L10: */
+ }
+ i__2 = *ihi;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + (j - 1) * a_dim1;
+ a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
+/* L20: */
+ }
+ i__2 = *n;
+ for (i__ = *ihi + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+ i__1 = *ilo;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L50: */
+ }
+ i__2 = j + j * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+/* L60: */
+ }
+ i__1 = *n;
+ for (j = *ihi + 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L70: */
+ }
+ i__2 = j + j * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+/* L80: */
+ }
+
+ if (nh > 0) {
+
+/* Generate Q(ilo+1:ihi,ilo+1:ihi) */
+
+ zungqr_(&nh, &nh, &nh, &a[*ilo + 1 + (*ilo + 1) * a_dim1], lda, &tau[*
+ ilo], &work[1], lwork, &iinfo);
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ return 0;
+
+/* End of ZUNGHR */
+
+} /* zunghr_ */
diff --git a/SRC/zungl2.c b/SRC/zungl2.c
new file mode 100644
index 0000000..ead7974
--- /dev/null
+++ b/SRC/zungl2.c
@@ -0,0 +1,193 @@
+/* zungl2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zungl2_(integer *m, integer *n, integer *k,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, l;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zlarf_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *), xerbla_(char *, integer *), zlacgv_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNGL2 generates an m-by-n complex matrix Q with orthonormal rows, */
+/* which is defined as the first m rows of a product of k elementary */
+/* reflectors of order n */
+
+/* Q = H(k)' . . . H(2)' H(1)' */
+
+/* as returned by ZGELQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. N >= M. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the i-th row must contain the vector which defines */
+/* the elementary reflector H(i), for i = 1,2,...,k, as returned */
+/* by ZGELQF in the first k rows of its array argument A. */
+/* On exit, the m by n matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) COMPLEX*16 array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZGELQF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (M) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *m) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUNGL2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0) {
+ return 0;
+ }
+
+ if (*k < *m) {
+
+/* Initialise rows k+1:m to rows of the unit matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (l = *k + 1; l <= i__2; ++l) {
+ i__3 = l + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L10: */
+ }
+ if (j > *k && j <= *m) {
+ i__2 = j + j * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+ }
+/* L20: */
+ }
+ }
+
+ for (i__ = *k; i__ >= 1; --i__) {
+
+/* Apply H(i)' to A(i:m,i:n) from the right */
+
+ if (i__ < *n) {
+ i__1 = *n - i__;
+ zlacgv_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda);
+ if (i__ < *m) {
+ i__1 = i__ + i__ * a_dim1;
+ a[i__1].r = 1., a[i__1].i = 0.;
+ i__1 = *m - i__;
+ i__2 = *n - i__ + 1;
+ d_cnjg(&z__1, &tau[i__]);
+ zlarf_("Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &
+ z__1, &a[i__ + 1 + i__ * a_dim1], lda, &work[1]);
+ }
+ i__1 = *n - i__;
+ i__2 = i__;
+ z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i;
+ zscal_(&i__1, &z__1, &a[i__ + (i__ + 1) * a_dim1], lda);
+ i__1 = *n - i__;
+ zlacgv_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda);
+ }
+ i__1 = i__ + i__ * a_dim1;
+ d_cnjg(&z__2, &tau[i__]);
+ z__1.r = 1. - z__2.r, z__1.i = 0. - z__2.i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+
+/* Set A(i,1:i-1) to zero */
+
+ i__1 = i__ - 1;
+ for (l = 1; l <= i__1; ++l) {
+ i__2 = i__ + l * a_dim1;
+ a[i__2].r = 0., a[i__2].i = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+ return 0;
+
+/* End of ZUNGL2 */
+
+} /* zungl2_ */
diff --git a/SRC/zunglq.c b/SRC/zunglq.c
new file mode 100644
index 0000000..d871b62
--- /dev/null
+++ b/SRC/zunglq.c
@@ -0,0 +1,287 @@
+/* zunglq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int zunglq_(integer *m, integer *n, integer *k,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int zungl2_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ integer ldwork;
+ extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ logical lquery;
+ integer lwkopt;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNGLQ generates an M-by-N complex matrix Q with orthonormal rows, */
+/* which is defined as the first M rows of a product of K elementary */
+/* reflectors of order N */
+
+/* Q = H(k)' . . . H(2)' H(1)' */
+
+/* as returned by ZGELQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. N >= M. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the i-th row must contain the vector which defines */
+/* the elementary reflector H(i), for i = 1,2,...,k, as returned */
+/* by ZGELQF in the first k rows of its array argument A. */
+/* On exit, the M-by-N matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) COMPLEX*16 array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZGELQF. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M). */
+/* For optimum performance LWORK >= M*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit; */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb = ilaenv_(&c__1, "ZUNGLQ", " ", m, n, k, &c_n1);
+ lwkopt = max(1,*m) * nb;
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *m) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*lwork < max(1,*m) && ! lquery) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUNGLQ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0) {
+ work[1].r = 1., work[1].i = 0.;
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *m;
+ if (nb > 1 && nb < *k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "ZUNGLQ", " ", m, n, k, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *m;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "ZUNGLQ", " ", m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < *k && nx < *k) {
+
+/* Use blocked code after the last block. */
+/* The first kk rows are handled by the block method. */
+
+ ki = (*k - nx - 1) / nb * nb;
+/* Computing MIN */
+ i__1 = *k, i__2 = ki + nb;
+ kk = min(i__1,i__2);
+
+/* Set A(kk+1:m,1:kk) to zero. */
+
+ i__1 = kk;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = kk + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ kk = 0;
+ }
+
+/* Use unblocked code for the last or only block. */
+
+ if (kk < *m) {
+ i__1 = *m - kk;
+ i__2 = *n - kk;
+ i__3 = *k - kk;
+ zungl2_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, &
+ tau[kk + 1], &work[1], &iinfo);
+ }
+
+ if (kk > 0) {
+
+/* Use blocked code */
+
+ i__1 = -nb;
+ for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) {
+/* Computing MIN */
+ i__2 = nb, i__3 = *k - i__ + 1;
+ ib = min(i__2,i__3);
+ if (i__ + ib <= *m) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__2 = *n - i__ + 1;
+ zlarft_("Forward", "Rowwise", &i__2, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H' to A(i+ib:m,i:n) from the right */
+
+ i__2 = *m - i__ - ib + 1;
+ i__3 = *n - i__ + 1;
+ zlarfb_("Right", "Conjugate transpose", "Forward", "Rowwise",
+ &i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[
+ 1], &ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[
+ ib + 1], &ldwork);
+ }
+
+/* Apply H' to columns i:n of current block */
+
+ i__2 = *n - i__ + 1;
+ zungl2_(&ib, &i__2, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
+ work[1], &iinfo);
+
+/* Set columns 1:i-1 of current block to zero */
+
+ i__2 = i__ - 1;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + ib - 1;
+ for (l = i__; l <= i__3; ++l) {
+ i__4 = l + j * a_dim1;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+ work[1].r = (doublereal) iws, work[1].i = 0.;
+ return 0;
+
+/* End of ZUNGLQ */
+
+} /* zunglq_ */
diff --git a/SRC/zungql.c b/SRC/zungql.c
new file mode 100644
index 0000000..19906cf
--- /dev/null
+++ b/SRC/zungql.c
@@ -0,0 +1,296 @@
+/* zungql.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int zungql_(integer *m, integer *n, integer *k,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+
+ /* Local variables */
+ integer i__, j, l, ib, nb, kk, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int zung2l_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ integer ldwork;
+ extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ logical lquery;
+ integer lwkopt;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNGQL generates an M-by-N complex matrix Q with orthonormal columns, */
+/* which is defined as the last N columns of a product of K elementary */
+/* reflectors of order M */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by ZGEQLF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the (n-k+i)-th column must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by ZGEQLF in the last k columns of its array */
+/* argument A. */
+/* On exit, the M-by-N matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) COMPLEX*16 array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZGEQLF. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* For optimum performance LWORK >= N*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+
+ if (*info == 0) {
+ if (*n == 0) {
+ lwkopt = 1;
+ } else {
+ nb = ilaenv_(&c__1, "ZUNGQL", " ", m, n, k, &c_n1);
+ lwkopt = *n * nb;
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ if (*lwork < max(1,*n) && ! lquery) {
+ *info = -8;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUNGQL", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *n;
+ if (nb > 1 && nb < *k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "ZUNGQL", " ", m, n, k, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *n;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "ZUNGQL", " ", m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < *k && nx < *k) {
+
+/* Use blocked code after the first block. */
+/* The last kk columns are handled by the block method. */
+
+/* Computing MIN */
+ i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb;
+ kk = min(i__1,i__2);
+
+/* Set A(m-kk+1:m,1:n-kk) to zero. */
+
+ i__1 = *n - kk;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = *m - kk + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ kk = 0;
+ }
+
+/* Use unblocked code for the first or only block. */
+
+ i__1 = *m - kk;
+ i__2 = *n - kk;
+ i__3 = *k - kk;
+ zung2l_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &iinfo)
+ ;
+
+ if (kk > 0) {
+
+/* Use blocked code */
+
+ i__1 = *k;
+ i__2 = nb;
+ for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *k - i__ + 1;
+ ib = min(i__3,i__4);
+ if (*n - *k + i__ > 1) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__3 = *m - *k + i__ + ib - 1;
+ zlarft_("Backward", "Columnwise", &i__3, &ib, &a[(*n - *k +
+ i__) * a_dim1 + 1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left */
+
+ i__3 = *m - *k + i__ + ib - 1;
+ i__4 = *n - *k + i__ - 1;
+ zlarfb_("Left", "No transpose", "Backward", "Columnwise", &
+ i__3, &i__4, &ib, &a[(*n - *k + i__) * a_dim1 + 1],
+ lda, &work[1], &ldwork, &a[a_offset], lda, &work[ib +
+ 1], &ldwork);
+ }
+
+/* Apply H to rows 1:m-k+i+ib-1 of current block */
+
+ i__3 = *m - *k + i__ + ib - 1;
+ zung2l_(&i__3, &ib, &ib, &a[(*n - *k + i__) * a_dim1 + 1], lda, &
+ tau[i__], &work[1], &iinfo);
+
+/* Set rows m-k+i+ib:m of current block to zero */
+
+ i__3 = *n - *k + i__ + ib - 1;
+ for (j = *n - *k + i__; j <= i__3; ++j) {
+ i__4 = *m;
+ for (l = *m - *k + i__ + ib; l <= i__4; ++l) {
+ i__5 = l + j * a_dim1;
+ a[i__5].r = 0., a[i__5].i = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+ work[1].r = (doublereal) iws, work[1].i = 0.;
+ return 0;
+
+/* End of ZUNGQL */
+
+} /* zungql_ */
diff --git a/SRC/zungqr.c b/SRC/zungqr.c
new file mode 100644
index 0000000..b3036a5
--- /dev/null
+++ b/SRC/zungqr.c
@@ -0,0 +1,288 @@
+/* zungqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int zungqr_(integer *m, integer *n, integer *k,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, l, ib, nb, ki, kk, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int zung2r_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ integer ldwork;
+ extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns, */
+/* which is defined as the first N columns of a product of K elementary */
+/* reflectors of order M */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by ZGEQRF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the i-th column must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by ZGEQRF in the first k columns of its array */
+/* argument A. */
+/* On exit, the M-by-N matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) COMPLEX*16 array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZGEQRF. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,N). */
+/* For optimum performance LWORK >= N*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nb = ilaenv_(&c__1, "ZUNGQR", " ", m, n, k, &c_n1);
+ lwkopt = max(1,*n) * nb;
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *n) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*lwork < max(1,*n) && ! lquery) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUNGQR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n <= 0) {
+ work[1].r = 1., work[1].i = 0.;
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *n;
+ if (nb > 1 && nb < *k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "ZUNGQR", " ", m, n, k, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *n;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "ZUNGQR", " ", m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < *k && nx < *k) {
+
+/* Use blocked code after the last block. */
+/* The first kk columns are handled by the block method. */
+
+ ki = (*k - nx - 1) / nb * nb;
+/* Computing MIN */
+ i__1 = *k, i__2 = ki + nb;
+ kk = min(i__1,i__2);
+
+/* Set A(1:kk,kk+1:n) to zero. */
+
+ i__1 = *n;
+ for (j = kk + 1; j <= i__1; ++j) {
+ i__2 = kk;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ kk = 0;
+ }
+
+/* Use unblocked code for the last or only block. */
+
+ if (kk < *n) {
+ i__1 = *m - kk;
+ i__2 = *n - kk;
+ i__3 = *k - kk;
+ zung2r_(&i__1, &i__2, &i__3, &a[kk + 1 + (kk + 1) * a_dim1], lda, &
+ tau[kk + 1], &work[1], &iinfo);
+ }
+
+ if (kk > 0) {
+
+/* Use blocked code */
+
+ i__1 = -nb;
+ for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) {
+/* Computing MIN */
+ i__2 = nb, i__3 = *k - i__ + 1;
+ ib = min(i__2,i__3);
+ if (i__ + ib <= *n) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__2 = *m - i__ + 1;
+ zlarft_("Forward", "Columnwise", &i__2, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H to A(i:m,i+ib:n) from the left */
+
+ i__2 = *m - i__ + 1;
+ i__3 = *n - i__ - ib + 1;
+ zlarfb_("Left", "No transpose", "Forward", "Columnwise", &
+ i__2, &i__3, &ib, &a[i__ + i__ * a_dim1], lda, &work[
+ 1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &
+ work[ib + 1], &ldwork);
+ }
+
+/* Apply H to rows i:m of current block */
+
+ i__2 = *m - i__ + 1;
+ zung2r_(&i__2, &ib, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &
+ work[1], &iinfo);
+
+/* Set rows 1:i-1 of current block to zero */
+
+ i__2 = i__ + ib - 1;
+ for (j = i__; j <= i__2; ++j) {
+ i__3 = i__ - 1;
+ for (l = 1; l <= i__3; ++l) {
+ i__4 = l + j * a_dim1;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+ work[1].r = (doublereal) iws, work[1].i = 0.;
+ return 0;
+
+/* End of ZUNGQR */
+
+} /* zungqr_ */
diff --git a/SRC/zungr2.c b/SRC/zungr2.c
new file mode 100644
index 0000000..f1d3c6f
--- /dev/null
+++ b/SRC/zungr2.c
@@ -0,0 +1,192 @@
+/* zungr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zungr2_(integer *m, integer *n, integer *k,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, l, ii;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zlarf_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *), xerbla_(char *, integer *), zlacgv_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNGR2 generates an m by n complex matrix Q with orthonormal rows, */
+/* which is defined as the last m rows of a product of k elementary */
+/* reflectors of order n */
+
+/* Q = H(1)' H(2)' . . . H(k)' */
+
+/* as returned by ZGERQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. N >= M. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the (m-k+i)-th row must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by ZGERQF in the last k rows of its array argument */
+/* A. */
+/* On exit, the m-by-n matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) COMPLEX*16 array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZGERQF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (M) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *m) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUNGR2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0) {
+ return 0;
+ }
+
+ if (*k < *m) {
+
+/* Initialise rows 1:m-k to rows of the unit matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m - *k;
+ for (l = 1; l <= i__2; ++l) {
+ i__3 = l + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L10: */
+ }
+ if (j > *n - *m && j <= *n - *k) {
+ i__2 = *m - *n + j + j * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+ }
+/* L20: */
+ }
+ }
+
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ii = *m - *k + i__;
+
+/* Apply H(i)' to A(1:m-k+i,1:n-k+i) from the right */
+
+ i__2 = *n - *m + ii - 1;
+ zlacgv_(&i__2, &a[ii + a_dim1], lda);
+ i__2 = ii + (*n - *m + ii) * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+ i__2 = ii - 1;
+ i__3 = *n - *m + ii;
+ d_cnjg(&z__1, &tau[i__]);
+ zlarf_("Right", &i__2, &i__3, &a[ii + a_dim1], lda, &z__1, &a[
+ a_offset], lda, &work[1]);
+ i__2 = *n - *m + ii - 1;
+ i__3 = i__;
+ z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i;
+ zscal_(&i__2, &z__1, &a[ii + a_dim1], lda);
+ i__2 = *n - *m + ii - 1;
+ zlacgv_(&i__2, &a[ii + a_dim1], lda);
+ i__2 = ii + (*n - *m + ii) * a_dim1;
+ d_cnjg(&z__2, &tau[i__]);
+ z__1.r = 1. - z__2.r, z__1.i = 0. - z__2.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+
+/* Set A(m-k+i,n-k+i+1:n) to zero */
+
+ i__2 = *n;
+ for (l = *n - *m + ii + 1; l <= i__2; ++l) {
+ i__3 = ii + l * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+ return 0;
+
+/* End of ZUNGR2 */
+
+} /* zungr2_ */
diff --git a/SRC/zungrq.c b/SRC/zungrq.c
new file mode 100644
index 0000000..1d52575
--- /dev/null
+++ b/SRC/zungrq.c
@@ -0,0 +1,296 @@
+/* zungrq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int zungrq_(integer *m, integer *n, integer *k,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+
+ /* Local variables */
+ integer i__, j, l, ib, nb, ii, kk, nx, iws, nbmin, iinfo;
+ extern /* Subroutine */ int zungr2_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ integer ldwork;
+ extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNGRQ generates an M-by-N complex matrix Q with orthonormal rows, */
+/* which is defined as the last M rows of a product of K elementary */
+/* reflectors of order N */
+
+/* Q = H(1)' H(2)' . . . H(k)' */
+
+/* as returned by ZGERQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q. N >= M. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the (m-k+i)-th row must contain the vector which */
+/* defines the elementary reflector H(i), for i = 1,2,...,k, as */
+/* returned by ZGERQF in the last k rows of its array argument */
+/* A. */
+/* On exit, the M-by-N matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The first dimension of the array A. LDA >= max(1,M). */
+
+/* TAU (input) COMPLEX*16 array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZGERQF. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= max(1,M). */
+/* For optimum performance LWORK >= M*NB, where NB is the */
+/* optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument has an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < *m) {
+ *info = -2;
+ } else if (*k < 0 || *k > *m) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ }
+
+ if (*info == 0) {
+ if (*m <= 0) {
+ lwkopt = 1;
+ } else {
+ nb = ilaenv_(&c__1, "ZUNGRQ", " ", m, n, k, &c_n1);
+ lwkopt = *m * nb;
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ if (*lwork < max(1,*m) && ! lquery) {
+ *info = -8;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUNGRQ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ nx = 0;
+ iws = *m;
+ if (nb > 1 && nb < *k) {
+
+/* Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+ i__1 = 0, i__2 = ilaenv_(&c__3, "ZUNGRQ", " ", m, n, k, &c_n1);
+ nx = max(i__1,i__2);
+ if (nx < *k) {
+
+/* Determine if workspace is large enough for blocked code. */
+
+ ldwork = *m;
+ iws = ldwork * nb;
+ if (*lwork < iws) {
+
+/* Not enough workspace to use optimal NB: reduce NB and */
+/* determine the minimum value of NB. */
+
+ nb = *lwork / ldwork;
+/* Computing MAX */
+ i__1 = 2, i__2 = ilaenv_(&c__2, "ZUNGRQ", " ", m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ }
+ }
+
+ if (nb >= nbmin && nb < *k && nx < *k) {
+
+/* Use blocked code after the first block. */
+/* The last kk rows are handled by the block method. */
+
+/* Computing MIN */
+ i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb;
+ kk = min(i__1,i__2);
+
+/* Set A(1:m-kk,n-kk+1:n) to zero. */
+
+ i__1 = *n;
+ for (j = *n - kk + 1; j <= i__1; ++j) {
+ i__2 = *m - kk;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ kk = 0;
+ }
+
+/* Use unblocked code for the first or only block. */
+
+ i__1 = *m - kk;
+ i__2 = *n - kk;
+ i__3 = *k - kk;
+ zungr2_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &iinfo)
+ ;
+
+ if (kk > 0) {
+
+/* Use blocked code */
+
+ i__1 = *k;
+ i__2 = nb;
+ for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ +=
+ i__2) {
+/* Computing MIN */
+ i__3 = nb, i__4 = *k - i__ + 1;
+ ib = min(i__3,i__4);
+ ii = *m - *k + i__;
+ if (ii > 1) {
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__3 = *n - *k + i__ + ib - 1;
+ zlarft_("Backward", "Rowwise", &i__3, &ib, &a[ii + a_dim1],
+ lda, &tau[i__], &work[1], &ldwork);
+
+/* Apply H' to A(1:m-k+i-1,1:n-k+i+ib-1) from the right */
+
+ i__3 = ii - 1;
+ i__4 = *n - *k + i__ + ib - 1;
+ zlarfb_("Right", "Conjugate transpose", "Backward", "Rowwise",
+ &i__3, &i__4, &ib, &a[ii + a_dim1], lda, &work[1], &
+ ldwork, &a[a_offset], lda, &work[ib + 1], &ldwork);
+ }
+
+/* Apply H' to columns 1:n-k+i+ib-1 of current block */
+
+ i__3 = *n - *k + i__ + ib - 1;
+ zungr2_(&ib, &i__3, &ib, &a[ii + a_dim1], lda, &tau[i__], &work[1]
+, &iinfo);
+
+/* Set columns n-k+i+ib:n of current block to zero */
+
+ i__3 = *n;
+ for (l = *n - *k + i__ + ib; l <= i__3; ++l) {
+ i__4 = ii + ib - 1;
+ for (j = ii; j <= i__4; ++j) {
+ i__5 = j + l * a_dim1;
+ a[i__5].r = 0., a[i__5].i = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+ work[1].r = (doublereal) iws, work[1].i = 0.;
+ return 0;
+
+/* End of ZUNGRQ */
+
+} /* zungrq_ */
diff --git a/SRC/zungtr.c b/SRC/zungtr.c
new file mode 100644
index 0000000..1000fb8
--- /dev/null
+++ b/SRC/zungtr.c
@@ -0,0 +1,262 @@
+/* zungtr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zungtr_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, nb;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int zungql_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *), zungqr_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNGTR generates a complex unitary matrix Q which is defined as the */
+/* product of n-1 elementary reflectors of order N, as returned by */
+/* ZHETRD: */
+
+/* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), */
+
+/* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A contains elementary reflectors */
+/* from ZHETRD; */
+/* = 'L': Lower triangle of A contains elementary reflectors */
+/* from ZHETRD. */
+
+/* N (input) INTEGER */
+/* The order of the matrix Q. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the vectors which define the elementary reflectors, */
+/* as returned by ZHETRD. */
+/* On exit, the N-by-N unitary matrix Q. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= N. */
+
+/* TAU (input) COMPLEX*16 array, dimension (N-1) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZHETRD. */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= N-1. */
+/* For optimum performance LWORK >= (N-1)*NB, where NB is */
+/* the optimal blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ lquery = *lwork == -1;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -4;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = 1, i__2 = *n - 1;
+ if (*lwork < max(i__1,i__2) && ! lquery) {
+ *info = -7;
+ }
+ }
+
+ if (*info == 0) {
+ if (upper) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ nb = ilaenv_(&c__1, "ZUNGQL", " ", &i__1, &i__2, &i__3, &c_n1);
+ } else {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ nb = ilaenv_(&c__1, "ZUNGQR", " ", &i__1, &i__2, &i__3, &c_n1);
+ }
+/* Computing MAX */
+ i__1 = 1, i__2 = *n - 1;
+ lwkopt = max(i__1,i__2) * nb;
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUNGTR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ work[1].r = 1., work[1].i = 0.;
+ return 0;
+ }
+
+ if (upper) {
+
+/* Q was determined by a call to ZHETRD with UPLO = 'U' */
+
+/* Shift the vectors which define the elementary reflectors one */
+/* column to the left, and set the last row and column of Q to */
+/* those of the unit matrix */
+
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + (j + 1) * a_dim1;
+ a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
+/* L10: */
+ }
+ i__2 = *n + j * a_dim1;
+ a[i__2].r = 0., a[i__2].i = 0.;
+/* L20: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + *n * a_dim1;
+ a[i__2].r = 0., a[i__2].i = 0.;
+/* L30: */
+ }
+ i__1 = *n + *n * a_dim1;
+ a[i__1].r = 1., a[i__1].i = 0.;
+
+/* Generate Q(1:n-1,1:n-1) */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ zungql_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1],
+ lwork, &iinfo);
+
+ } else {
+
+/* Q was determined by a call to ZHETRD with UPLO = 'L'. */
+
+/* Shift the vectors which define the elementary reflectors one */
+/* column to the right, and set the first row and column of Q to */
+/* those of the unit matrix */
+
+ for (j = *n; j >= 2; --j) {
+ i__1 = j * a_dim1 + 1;
+ a[i__1].r = 0., a[i__1].i = 0.;
+ i__1 = *n;
+ for (i__ = j + 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * a_dim1;
+ i__3 = i__ + (j - 1) * a_dim1;
+ a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
+/* L40: */
+ }
+/* L50: */
+ }
+ i__1 = a_dim1 + 1;
+ a[i__1].r = 1., a[i__1].i = 0.;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__ + a_dim1;
+ a[i__2].r = 0., a[i__2].i = 0.;
+/* L60: */
+ }
+ if (*n > 1) {
+
+/* Generate Q(2:n,2:n) */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ zungqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[1],
+ &work[1], lwork, &iinfo);
+ }
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ return 0;
+
+/* End of ZUNGTR */
+
+} /* zungtr_ */
diff --git a/SRC/zunm2l.c b/SRC/zunm2l.c
new file mode 100644
index 0000000..4a49f63
--- /dev/null
+++ b/SRC/zunm2l.c
@@ -0,0 +1,245 @@
+/* zunm2l.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zunm2l_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublecomplex *a, integer *lda, doublecomplex *tau,
+ doublecomplex *c__, integer *ldc, doublecomplex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, i1, i2, i3, mi, ni, nq;
+ doublecomplex aii;
+ logical left;
+ doublecomplex taui;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *), xerbla_(char *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNM2L overwrites the general complex m-by-n matrix C with */
+
+/* Q * C if SIDE = 'L' and TRANS = 'N', or */
+
+/* Q'* C if SIDE = 'L' and TRANS = 'C', or */
+
+/* C * Q if SIDE = 'R' and TRANS = 'N', or */
+
+/* C * Q' if SIDE = 'R' and TRANS = 'C', */
+
+/* where Q is a complex unitary matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by ZGEQLF. Q is of order m if SIDE = 'L' and of order n */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q' from the Left */
+/* = 'R': apply Q or Q' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply Q (No transpose) */
+/* = 'C': apply Q' (Conjugate transpose) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,K) */
+/* The i-th column must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* ZGEQLF in the last k columns of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If SIDE = 'L', LDA >= max(1,M); */
+/* if SIDE = 'R', LDA >= max(1,N). */
+
+/* TAU (input) COMPLEX*16 array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZGEQLF. */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
+/* On entry, the m-by-n matrix C. */
+/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (N) if SIDE = 'L', */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,nq)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUNM2L", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ return 0;
+ }
+
+ if (left && notran || ! left && ! notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = 1;
+ } else {
+ i1 = *k;
+ i2 = 1;
+ i3 = -1;
+ }
+
+ if (left) {
+ ni = *n;
+ } else {
+ mi = *m;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) or H(i)' is applied to C(1:m-k+i,1:n) */
+
+ mi = *m - *k + i__;
+ } else {
+
+/* H(i) or H(i)' is applied to C(1:m,1:n-k+i) */
+
+ ni = *n - *k + i__;
+ }
+
+/* Apply H(i) or H(i)' */
+
+ if (notran) {
+ i__3 = i__;
+ taui.r = tau[i__3].r, taui.i = tau[i__3].i;
+ } else {
+ d_cnjg(&z__1, &tau[i__]);
+ taui.r = z__1.r, taui.i = z__1.i;
+ }
+ i__3 = nq - *k + i__ + i__ * a_dim1;
+ aii.r = a[i__3].r, aii.i = a[i__3].i;
+ i__3 = nq - *k + i__ + i__ * a_dim1;
+ a[i__3].r = 1., a[i__3].i = 0.;
+ zlarf_(side, &mi, &ni, &a[i__ * a_dim1 + 1], &c__1, &taui, &c__[
+ c_offset], ldc, &work[1]);
+ i__3 = nq - *k + i__ + i__ * a_dim1;
+ a[i__3].r = aii.r, a[i__3].i = aii.i;
+/* L10: */
+ }
+ return 0;
+
+/* End of ZUNM2L */
+
+} /* zunm2l_ */
diff --git a/SRC/zunm2r.c b/SRC/zunm2r.c
new file mode 100644
index 0000000..a551863
--- /dev/null
+++ b/SRC/zunm2r.c
@@ -0,0 +1,249 @@
+/* zunm2r.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zunm2r_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublecomplex *a, integer *lda, doublecomplex *tau,
+ doublecomplex *c__, integer *ldc, doublecomplex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, i1, i2, i3, ic, jc, mi, ni, nq;
+ doublecomplex aii;
+ logical left;
+ doublecomplex taui;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *), xerbla_(char *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNM2R overwrites the general complex m-by-n matrix C with */
+
+/* Q * C if SIDE = 'L' and TRANS = 'N', or */
+
+/* Q'* C if SIDE = 'L' and TRANS = 'C', or */
+
+/* C * Q if SIDE = 'R' and TRANS = 'N', or */
+
+/* C * Q' if SIDE = 'R' and TRANS = 'C', */
+
+/* where Q is a complex unitary matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q' from the Left */
+/* = 'R': apply Q or Q' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply Q (No transpose) */
+/* = 'C': apply Q' (Conjugate transpose) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,K) */
+/* The i-th column must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* ZGEQRF in the first k columns of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If SIDE = 'L', LDA >= max(1,M); */
+/* if SIDE = 'R', LDA >= max(1,N). */
+
+/* TAU (input) COMPLEX*16 array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZGEQRF. */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
+/* On entry, the m-by-n matrix C. */
+/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (N) if SIDE = 'L', */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,nq)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUNM2R", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ return 0;
+ }
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = 1;
+ } else {
+ i1 = *k;
+ i2 = 1;
+ i3 = -1;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) or H(i)' is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H(i) or H(i)' is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H(i) or H(i)' */
+
+ if (notran) {
+ i__3 = i__;
+ taui.r = tau[i__3].r, taui.i = tau[i__3].i;
+ } else {
+ d_cnjg(&z__1, &tau[i__]);
+ taui.r = z__1.r, taui.i = z__1.i;
+ }
+ i__3 = i__ + i__ * a_dim1;
+ aii.r = a[i__3].r, aii.i = a[i__3].i;
+ i__3 = i__ + i__ * a_dim1;
+ a[i__3].r = 1., a[i__3].i = 0.;
+ zlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &taui, &c__[ic
+ + jc * c_dim1], ldc, &work[1]);
+ i__3 = i__ + i__ * a_dim1;
+ a[i__3].r = aii.r, a[i__3].i = aii.i;
+/* L10: */
+ }
+ return 0;
+
+/* End of ZUNM2R */
+
+} /* zunm2r_ */
diff --git a/SRC/zunmbr.c b/SRC/zunmbr.c
new file mode 100644
index 0000000..0179f82
--- /dev/null
+++ b/SRC/zunmbr.c
@@ -0,0 +1,371 @@
+/* zunmbr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int zunmbr_(char *vect, char *side, char *trans, integer *m,
+ integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex
+ *tau, doublecomplex *c__, integer *ldc, doublecomplex *work, integer *
+ lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i1, i2, nb, mi, ni, nq, nw;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical notran, applyq;
+ char transt[1];
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int zunmlq_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *), zunmqr_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* If VECT = 'Q', ZUNMBR overwrites the general complex M-by-N matrix C */
+/* with */
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'C': Q**H * C C * Q**H */
+
+/* If VECT = 'P', ZUNMBR overwrites the general complex M-by-N matrix C */
+/* with */
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': P * C C * P */
+/* TRANS = 'C': P**H * C C * P**H */
+
+/* Here Q and P**H are the unitary matrices determined by ZGEBRD when */
+/* reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q */
+/* and P**H are defined as products of elementary reflectors H(i) and */
+/* G(i) respectively. */
+
+/* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the */
+/* order of the unitary matrix Q or P**H that is applied. */
+
+/* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: */
+/* if nq >= k, Q = H(1) H(2) . . . H(k); */
+/* if nq < k, Q = H(1) H(2) . . . H(nq-1). */
+
+/* If VECT = 'P', A is assumed to have been a K-by-NQ matrix: */
+/* if k < nq, P = G(1) G(2) . . . G(k); */
+/* if k >= nq, P = G(1) G(2) . . . G(nq-1). */
+
+/* Arguments */
+/* ========= */
+
+/* VECT (input) CHARACTER*1 */
+/* = 'Q': apply Q or Q**H; */
+/* = 'P': apply P or P**H. */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q, Q**H, P or P**H from the Left; */
+/* = 'R': apply Q, Q**H, P or P**H from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q or P; */
+/* = 'C': Conjugate transpose, apply Q**H or P**H. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* If VECT = 'Q', the number of columns in the original */
+/* matrix reduced by ZGEBRD. */
+/* If VECT = 'P', the number of rows in the original */
+/* matrix reduced by ZGEBRD. */
+/* K >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension */
+/* (LDA,min(nq,K)) if VECT = 'Q' */
+/* (LDA,nq) if VECT = 'P' */
+/* The vectors which define the elementary reflectors H(i) and */
+/* G(i), whose products determine the matrices Q and P, as */
+/* returned by ZGEBRD. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If VECT = 'Q', LDA >= max(1,nq); */
+/* if VECT = 'P', LDA >= max(1,min(nq,K)). */
+
+/* TAU (input) COMPLEX*16 array, dimension (min(nq,K)) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i) or G(i) which determines Q or P, as returned */
+/* by ZGEBRD in the array argument TAUQ or TAUP. */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q */
+/* or P*C or P**H*C or C*P or C*P**H. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M); */
+/* if N = 0 or M = 0, LWORK >= 1. */
+/* For optimum performance LWORK >= max(1,N*NB) if SIDE = 'L', */
+/* and LWORK >= max(1,M*NB) if SIDE = 'R', where NB is the */
+/* optimal blocksize. (NB = 0 if M = 0 or N = 0.) */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ applyq = lsame_(vect, "Q");
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q or P and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = *n;
+ } else {
+ nq = *n;
+ nw = *m;
+ }
+ if (*m == 0 || *n == 0) {
+ nw = 0;
+ }
+ if (! applyq && ! lsame_(vect, "P")) {
+ *info = -1;
+ } else if (! left && ! lsame_(side, "R")) {
+ *info = -2;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*k < 0) {
+ *info = -6;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+ i__1 = 1, i__2 = min(nq,*k);
+ if (applyq && *lda < max(1,nq) || ! applyq && *lda < max(i__1,i__2)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -11;
+ } else if (*lwork < max(1,nw) && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info == 0) {
+ if (nw > 0) {
+ if (applyq) {
+ if (left) {
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ nb = ilaenv_(&c__1, "ZUNMQR", ch__1, &i__1, n, &i__2, &
+ c_n1);
+ } else {
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ nb = ilaenv_(&c__1, "ZUNMQR", ch__1, m, &i__1, &i__2, &
+ c_n1);
+ }
+ } else {
+ if (left) {
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ nb = ilaenv_(&c__1, "ZUNMLQ", ch__1, &i__1, n, &i__2, &
+ c_n1);
+ } else {
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ nb = ilaenv_(&c__1, "ZUNMLQ", ch__1, m, &i__1, &i__2, &
+ c_n1);
+ }
+ }
+/* Computing MAX */
+ i__1 = 1, i__2 = nw * nb;
+ lwkopt = max(i__1,i__2);
+ } else {
+ lwkopt = 1;
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUNMBR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ if (applyq) {
+
+/* Apply Q */
+
+ if (nq >= *k) {
+
+/* Q was determined by a call to ZGEBRD with nq >= k */
+
+ zunmqr_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], lwork, &iinfo);
+ } else if (nq > 1) {
+
+/* Q was determined by a call to ZGEBRD with nq < k */
+
+ if (left) {
+ mi = *m - 1;
+ ni = *n;
+ i1 = 2;
+ i2 = 1;
+ } else {
+ mi = *m;
+ ni = *n - 1;
+ i1 = 1;
+ i2 = 2;
+ }
+ i__1 = nq - 1;
+ zunmqr_(side, trans, &mi, &ni, &i__1, &a[a_dim1 + 2], lda, &tau[1]
+, &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo);
+ }
+ } else {
+
+/* Apply P */
+
+ if (notran) {
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+ if (nq > *k) {
+
+/* P was determined by a call to ZGEBRD with nq > k */
+
+ zunmlq_(side, transt, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], lwork, &iinfo);
+ } else if (nq > 1) {
+
+/* P was determined by a call to ZGEBRD with nq <= k */
+
+ if (left) {
+ mi = *m - 1;
+ ni = *n;
+ i1 = 2;
+ i2 = 1;
+ } else {
+ mi = *m;
+ ni = *n - 1;
+ i1 = 1;
+ i2 = 2;
+ }
+ i__1 = nq - 1;
+ zunmlq_(side, transt, &mi, &ni, &i__1, &a[(a_dim1 << 1) + 1], lda,
+ &tau[1], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &
+ iinfo);
+ }
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ return 0;
+
+/* End of ZUNMBR */
+
+} /* zunmbr_ */
diff --git a/SRC/zunmhr.c b/SRC/zunmhr.c
new file mode 100644
index 0000000..c67935a
--- /dev/null
+++ b/SRC/zunmhr.c
@@ -0,0 +1,257 @@
+/* zunmhr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int zunmhr_(char *side, char *trans, integer *m, integer *n,
+ integer *ilo, integer *ihi, doublecomplex *a, integer *lda,
+ doublecomplex *tau, doublecomplex *c__, integer *ldc, doublecomplex *
+ work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i1, i2, nb, mi, nh, ni, nq, nw;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int zunmqr_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNMHR overwrites the general complex M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'C': Q**H * C C * Q**H */
+
+/* where Q is a complex unitary matrix of order nq, with nq = m if */
+/* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */
+/* IHI-ILO elementary reflectors, as returned by ZGEHRD: */
+
+/* Q = H(ilo) H(ilo+1) . . . H(ihi-1). */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**H from the Left; */
+/* = 'R': apply Q or Q**H from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply Q (No transpose) */
+/* = 'C': apply Q**H (Conjugate transpose) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* ILO and IHI must have the same values as in the previous call */
+/* of ZGEHRD. Q is equal to the unit matrix except in the */
+/* submatrix Q(ilo+1:ihi,ilo+1:ihi). */
+/* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and */
+/* ILO = 1 and IHI = 0, if M = 0; */
+/* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and */
+/* ILO = 1 and IHI = 0, if N = 0. */
+
+/* A (input) COMPLEX*16 array, dimension */
+/* (LDA,M) if SIDE = 'L' */
+/* (LDA,N) if SIDE = 'R' */
+/* The vectors which define the elementary reflectors, as */
+/* returned by ZGEHRD. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. */
+
+/* TAU (input) COMPLEX*16 array, dimension */
+/* (M-1) if SIDE = 'L' */
+/* (N-1) if SIDE = 'R' */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZGEHRD. */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ nh = *ihi - *ilo;
+ left = lsame_(side, "L");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = *n;
+ } else {
+ nq = *n;
+ nw = *m;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "C")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ilo < 1 || *ilo > max(1,nq)) {
+ *info = -5;
+ } else if (*ihi < min(*ilo,nq) || *ihi > nq) {
+ *info = -6;
+ } else if (*lda < max(1,nq)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -11;
+ } else if (*lwork < max(1,nw) && ! lquery) {
+ *info = -13;
+ }
+
+ if (*info == 0) {
+ if (left) {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ nb = ilaenv_(&c__1, "ZUNMQR", ch__1, &nh, n, &nh, &c_n1);
+ } else {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ nb = ilaenv_(&c__1, "ZUNMQR", ch__1, m, &nh, &nh, &c_n1);
+ }
+ lwkopt = max(1,nw) * nb;
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ }
+
+ if (*info != 0) {
+ i__2 = -(*info);
+ xerbla_("ZUNMHR", &i__2);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || nh == 0) {
+ work[1].r = 1., work[1].i = 0.;
+ return 0;
+ }
+
+ if (left) {
+ mi = nh;
+ ni = *n;
+ i1 = *ilo + 1;
+ i2 = 1;
+ } else {
+ mi = *m;
+ ni = nh;
+ i1 = 1;
+ i2 = *ilo + 1;
+ }
+
+ zunmqr_(side, trans, &mi, &ni, &nh, &a[*ilo + 1 + *ilo * a_dim1], lda, &
+ tau[*ilo], &c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo);
+
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ return 0;
+
+/* End of ZUNMHR */
+
+} /* zunmhr_ */
diff --git a/SRC/zunml2.c b/SRC/zunml2.c
new file mode 100644
index 0000000..10899a5
--- /dev/null
+++ b/SRC/zunml2.c
@@ -0,0 +1,253 @@
+/* zunml2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zunml2_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublecomplex *a, integer *lda, doublecomplex *tau,
+ doublecomplex *c__, integer *ldc, doublecomplex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, i1, i2, i3, ic, jc, mi, ni, nq;
+ doublecomplex aii;
+ logical left;
+ doublecomplex taui;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *), xerbla_(char *, integer *), zlacgv_(integer *, doublecomplex *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNML2 overwrites the general complex m-by-n matrix C with */
+
+/* Q * C if SIDE = 'L' and TRANS = 'N', or */
+
+/* Q'* C if SIDE = 'L' and TRANS = 'C', or */
+
+/* C * Q if SIDE = 'R' and TRANS = 'N', or */
+
+/* C * Q' if SIDE = 'R' and TRANS = 'C', */
+
+/* where Q is a complex unitary matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(k)' . . . H(2)' H(1)' */
+
+/* as returned by ZGELQF. Q is of order m if SIDE = 'L' and of order n */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q' from the Left */
+/* = 'R': apply Q or Q' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply Q (No transpose) */
+/* = 'C': apply Q' (Conjugate transpose) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* ZGELQF in the first k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) COMPLEX*16 array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZGELQF. */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
+/* On entry, the m-by-n matrix C. */
+/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (N) if SIDE = 'L', */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,*k)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUNML2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ return 0;
+ }
+
+ if (left && notran || ! left && ! notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = 1;
+ } else {
+ i1 = *k;
+ i2 = 1;
+ i3 = -1;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) or H(i)' is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H(i) or H(i)' is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H(i) or H(i)' */
+
+ if (notran) {
+ d_cnjg(&z__1, &tau[i__]);
+ taui.r = z__1.r, taui.i = z__1.i;
+ } else {
+ i__3 = i__;
+ taui.r = tau[i__3].r, taui.i = tau[i__3].i;
+ }
+ if (i__ < nq) {
+ i__3 = nq - i__;
+ zlacgv_(&i__3, &a[i__ + (i__ + 1) * a_dim1], lda);
+ }
+ i__3 = i__ + i__ * a_dim1;
+ aii.r = a[i__3].r, aii.i = a[i__3].i;
+ i__3 = i__ + i__ * a_dim1;
+ a[i__3].r = 1., a[i__3].i = 0.;
+ zlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &taui, &c__[ic +
+ jc * c_dim1], ldc, &work[1]);
+ i__3 = i__ + i__ * a_dim1;
+ a[i__3].r = aii.r, a[i__3].i = aii.i;
+ if (i__ < nq) {
+ i__3 = nq - i__;
+ zlacgv_(&i__3, &a[i__ + (i__ + 1) * a_dim1], lda);
+ }
+/* L10: */
+ }
+ return 0;
+
+/* End of ZUNML2 */
+
+} /* zunml2_ */
diff --git a/SRC/zunmlq.c b/SRC/zunmlq.c
new file mode 100644
index 0000000..a231596
--- /dev/null
+++ b/SRC/zunmlq.c
@@ -0,0 +1,338 @@
+/* zunmlq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int zunmlq_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublecomplex *a, integer *lda, doublecomplex *tau,
+ doublecomplex *c__, integer *ldc, doublecomplex *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
+ i__5;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ doublecomplex t[4160] /* was [65][64] */;
+ integer i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iws;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int zunml2_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ logical notran;
+ integer ldwork;
+ extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ char transt[1];
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNMLQ overwrites the general complex M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'C': Q**H * C C * Q**H */
+
+/* where Q is a complex unitary matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(k)' . . . H(2)' H(1)' */
+
+/* as returned by ZGELQF. Q is of order M if SIDE = 'L' and of order N */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**H from the Left; */
+/* = 'R': apply Q or Q**H from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'C': Conjugate transpose, apply Q**H. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* ZGELQF in the first k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) COMPLEX*16 array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZGELQF. */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = *n;
+ } else {
+ nq = *n;
+ nw = *m;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,*k)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ } else if (*lwork < max(1,nw) && ! lquery) {
+ *info = -12;
+ }
+
+ if (*info == 0) {
+
+/* Determine the block size. NB may be at most NBMAX, where NBMAX */
+/* is used to define the local array T. */
+
+/* Computing MIN */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 64, i__2 = ilaenv_(&c__1, "ZUNMLQ", ch__1, m, n, k, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = max(1,nw) * nb;
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUNMLQ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ work[1].r = 1., work[1].i = 0.;
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = nw;
+ if (nb > 1 && nb < *k) {
+ iws = nw * nb;
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 2, i__2 = ilaenv_(&c__2, "ZUNMLQ", ch__1, m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = nw;
+ }
+
+ if (nb < nbmin || nb >= *k) {
+
+/* Use unblocked code */
+
+ zunml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], &iinfo);
+ } else {
+
+/* Use blocked code */
+
+ if (left && notran || ! left && ! notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = nb;
+ } else {
+ i1 = (*k - 1) / nb * nb + 1;
+ i2 = 1;
+ i3 = -nb;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ }
+
+ if (notran) {
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *k - i__ + 1;
+ ib = min(i__4,i__5);
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__4 = nq - i__ + 1;
+ zlarft_("Forward", "Rowwise", &i__4, &ib, &a[i__ + i__ * a_dim1],
+ lda, &tau[i__], t, &c__65);
+ if (left) {
+
+/* H or H' is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H or H' is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H or H' */
+
+ zlarfb_(side, transt, "Forward", "Rowwise", &mi, &ni, &ib, &a[i__
+ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1],
+ ldc, &work[1], &ldwork);
+/* L10: */
+ }
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ return 0;
+
+/* End of ZUNMLQ */
+
+} /* zunmlq_ */
diff --git a/SRC/zunmql.c b/SRC/zunmql.c
new file mode 100644
index 0000000..f159164
--- /dev/null
+++ b/SRC/zunmql.c
@@ -0,0 +1,332 @@
+/* zunmql.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int zunmql_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublecomplex *a, integer *lda, doublecomplex *tau,
+ doublecomplex *c__, integer *ldc, doublecomplex *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
+ i__5;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ doublecomplex t[4160] /* was [65][64] */;
+ integer i1, i2, i3, ib, nb, mi, ni, nq, nw, iws;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int zunm2l_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ logical notran;
+ integer ldwork;
+ extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNMQL overwrites the general complex M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'C': Q**H * C C * Q**H */
+
+/* where Q is a complex unitary matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(k) . . . H(2) H(1) */
+
+/* as returned by ZGEQLF. Q is of order M if SIDE = 'L' and of order N */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**H from the Left; */
+/* = 'R': apply Q or Q**H from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'C': Transpose, apply Q**H. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,K) */
+/* The i-th column must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* ZGEQLF in the last k columns of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If SIDE = 'L', LDA >= max(1,M); */
+/* if SIDE = 'R', LDA >= max(1,N). */
+
+/* TAU (input) COMPLEX*16 array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZGEQLF. */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = max(1,*n);
+ } else {
+ nq = *n;
+ nw = max(1,*m);
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,nq)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+
+ if (*info == 0) {
+ if (*m == 0 || *n == 0) {
+ lwkopt = 1;
+ } else {
+
+/* Determine the block size. NB may be at most NBMAX, where */
+/* NBMAX is used to define the local array T. */
+
+/* Computing MIN */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 64, i__2 = ilaenv_(&c__1, "ZUNMQL", ch__1, m, n, k, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = nw * nb;
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ if (*lwork < nw && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUNMQL", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = nw;
+ if (nb > 1 && nb < *k) {
+ iws = nw * nb;
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 2, i__2 = ilaenv_(&c__2, "ZUNMQL", ch__1, m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = nw;
+ }
+
+ if (nb < nbmin || nb >= *k) {
+
+/* Use unblocked code */
+
+ zunm2l_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], &iinfo);
+ } else {
+
+/* Use blocked code */
+
+ if (left && notran || ! left && ! notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = nb;
+ } else {
+ i1 = (*k - 1) / nb * nb + 1;
+ i2 = 1;
+ i3 = -nb;
+ }
+
+ if (left) {
+ ni = *n;
+ } else {
+ mi = *m;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *k - i__ + 1;
+ ib = min(i__4,i__5);
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__4 = nq - *k + i__ + ib - 1;
+ zlarft_("Backward", "Columnwise", &i__4, &ib, &a[i__ * a_dim1 + 1]
+, lda, &tau[i__], t, &c__65);
+ if (left) {
+
+/* H or H' is applied to C(1:m-k+i+ib-1,1:n) */
+
+ mi = *m - *k + i__ + ib - 1;
+ } else {
+
+/* H or H' is applied to C(1:m,1:n-k+i+ib-1) */
+
+ ni = *n - *k + i__ + ib - 1;
+ }
+
+/* Apply H or H' */
+
+ zlarfb_(side, trans, "Backward", "Columnwise", &mi, &ni, &ib, &a[
+ i__ * a_dim1 + 1], lda, t, &c__65, &c__[c_offset], ldc, &
+ work[1], &ldwork);
+/* L10: */
+ }
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ return 0;
+
+/* End of ZUNMQL */
+
+} /* zunmql_ */
diff --git a/SRC/zunmqr.c b/SRC/zunmqr.c
new file mode 100644
index 0000000..1074b2a
--- /dev/null
+++ b/SRC/zunmqr.c
@@ -0,0 +1,332 @@
+/* zunmqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int zunmqr_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublecomplex *a, integer *lda, doublecomplex *tau,
+ doublecomplex *c__, integer *ldc, doublecomplex *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
+ i__5;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ doublecomplex t[4160] /* was [65][64] */;
+ integer i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iws;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ logical notran;
+ integer ldwork;
+ extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNMQR overwrites the general complex M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'C': Q**H * C C * Q**H */
+
+/* where Q is a complex unitary matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by ZGEQRF. Q is of order M if SIDE = 'L' and of order N */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**H from the Left; */
+/* = 'R': apply Q or Q**H from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'C': Conjugate transpose, apply Q**H. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,K) */
+/* The i-th column must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* ZGEQRF in the first k columns of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If SIDE = 'L', LDA >= max(1,M); */
+/* if SIDE = 'R', LDA >= max(1,N). */
+
+/* TAU (input) COMPLEX*16 array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZGEQRF. */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = *n;
+ } else {
+ nq = *n;
+ nw = *m;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,nq)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ } else if (*lwork < max(1,nw) && ! lquery) {
+ *info = -12;
+ }
+
+ if (*info == 0) {
+
+/* Determine the block size. NB may be at most NBMAX, where NBMAX */
+/* is used to define the local array T. */
+
+/* Computing MIN */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 64, i__2 = ilaenv_(&c__1, "ZUNMQR", ch__1, m, n, k, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = max(1,nw) * nb;
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUNMQR", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ work[1].r = 1., work[1].i = 0.;
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = nw;
+ if (nb > 1 && nb < *k) {
+ iws = nw * nb;
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 2, i__2 = ilaenv_(&c__2, "ZUNMQR", ch__1, m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = nw;
+ }
+
+ if (nb < nbmin || nb >= *k) {
+
+/* Use unblocked code */
+
+ zunm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], &iinfo);
+ } else {
+
+/* Use blocked code */
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = nb;
+ } else {
+ i1 = (*k - 1) / nb * nb + 1;
+ i2 = 1;
+ i3 = -nb;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *k - i__ + 1;
+ ib = min(i__4,i__5);
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i) H(i+1) . . . H(i+ib-1) */
+
+ i__4 = nq - i__ + 1;
+ zlarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ *
+ a_dim1], lda, &tau[i__], t, &c__65)
+ ;
+ if (left) {
+
+/* H or H' is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H or H' is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H or H' */
+
+ zlarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &a[
+ i__ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc *
+ c_dim1], ldc, &work[1], &ldwork);
+/* L10: */
+ }
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ return 0;
+
+/* End of ZUNMQR */
+
+} /* zunmqr_ */
diff --git a/SRC/zunmr2.c b/SRC/zunmr2.c
new file mode 100644
index 0000000..e3ab2fe
--- /dev/null
+++ b/SRC/zunmr2.c
@@ -0,0 +1,245 @@
+/* zunmr2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zunmr2_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublecomplex *a, integer *lda, doublecomplex *tau,
+ doublecomplex *c__, integer *ldc, doublecomplex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, i1, i2, i3, mi, ni, nq;
+ doublecomplex aii;
+ logical left;
+ doublecomplex taui;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *), xerbla_(char *, integer *), zlacgv_(integer *, doublecomplex *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNMR2 overwrites the general complex m-by-n matrix C with */
+
+/* Q * C if SIDE = 'L' and TRANS = 'N', or */
+
+/* Q'* C if SIDE = 'L' and TRANS = 'C', or */
+
+/* C * Q if SIDE = 'R' and TRANS = 'N', or */
+
+/* C * Q' if SIDE = 'R' and TRANS = 'C', */
+
+/* where Q is a complex unitary matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1)' H(2)' . . . H(k)' */
+
+/* as returned by ZGERQF. Q is of order m if SIDE = 'L' and of order n */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q' from the Left */
+/* = 'R': apply Q or Q' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply Q (No transpose) */
+/* = 'C': apply Q' (Conjugate transpose) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* ZGERQF in the last k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) COMPLEX*16 array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZGERQF. */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
+/* On entry, the m-by-n matrix C. */
+/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (N) if SIDE = 'L', */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,*k)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUNMR2", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ return 0;
+ }
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = 1;
+ } else {
+ i1 = *k;
+ i2 = 1;
+ i3 = -1;
+ }
+
+ if (left) {
+ ni = *n;
+ } else {
+ mi = *m;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) or H(i)' is applied to C(1:m-k+i,1:n) */
+
+ mi = *m - *k + i__;
+ } else {
+
+/* H(i) or H(i)' is applied to C(1:m,1:n-k+i) */
+
+ ni = *n - *k + i__;
+ }
+
+/* Apply H(i) or H(i)' */
+
+ if (notran) {
+ d_cnjg(&z__1, &tau[i__]);
+ taui.r = z__1.r, taui.i = z__1.i;
+ } else {
+ i__3 = i__;
+ taui.r = tau[i__3].r, taui.i = tau[i__3].i;
+ }
+ i__3 = nq - *k + i__ - 1;
+ zlacgv_(&i__3, &a[i__ + a_dim1], lda);
+ i__3 = i__ + (nq - *k + i__) * a_dim1;
+ aii.r = a[i__3].r, aii.i = a[i__3].i;
+ i__3 = i__ + (nq - *k + i__) * a_dim1;
+ a[i__3].r = 1., a[i__3].i = 0.;
+ zlarf_(side, &mi, &ni, &a[i__ + a_dim1], lda, &taui, &c__[c_offset],
+ ldc, &work[1]);
+ i__3 = i__ + (nq - *k + i__) * a_dim1;
+ a[i__3].r = aii.r, a[i__3].i = aii.i;
+ i__3 = nq - *k + i__ - 1;
+ zlacgv_(&i__3, &a[i__ + a_dim1], lda);
+/* L10: */
+ }
+ return 0;
+
+/* End of ZUNMR2 */
+
+} /* zunmr2_ */
diff --git a/SRC/zunmr3.c b/SRC/zunmr3.c
new file mode 100644
index 0000000..bd39c0b
--- /dev/null
+++ b/SRC/zunmr3.c
@@ -0,0 +1,254 @@
+/* zunmr3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zunmr3_(char *side, char *trans, integer *m, integer *n,
+ integer *k, integer *l, doublecomplex *a, integer *lda, doublecomplex
+ *tau, doublecomplex *c__, integer *ldc, doublecomplex *work, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, i1, i2, i3, ja, ic, jc, mi, ni, nq;
+ logical left;
+ doublecomplex taui;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zlarz_(char *, integer *, integer *, integer *
+, doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *), xerbla_(char *, integer *);
+ logical notran;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNMR3 overwrites the general complex m by n matrix C with */
+
+/* Q * C if SIDE = 'L' and TRANS = 'N', or */
+
+/* Q'* C if SIDE = 'L' and TRANS = 'C', or */
+
+/* C * Q if SIDE = 'R' and TRANS = 'N', or */
+
+/* C * Q' if SIDE = 'R' and TRANS = 'C', */
+
+/* where Q is a complex unitary matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by ZTZRZF. Q is of order m if SIDE = 'L' and of order n */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q' from the Left */
+/* = 'R': apply Q or Q' from the Right */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': apply Q (No transpose) */
+/* = 'C': apply Q' (Conjugate transpose) */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* L (input) INTEGER */
+/* The number of columns of the matrix A containing */
+/* the meaningful part of the Householder reflectors. */
+/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* ZTZRZF in the last k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) COMPLEX*16 array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZTZRZF. */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
+/* On entry, the m-by-n matrix C. */
+/* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (N) if SIDE = 'L', */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*l < 0 || left && *l > *m || ! left && *l > *n) {
+ *info = -6;
+ } else if (*lda < max(1,*k)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -11;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUNMR3", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || *k == 0) {
+ return 0;
+ }
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = 1;
+ } else {
+ i1 = *k;
+ i2 = 1;
+ i3 = -1;
+ }
+
+ if (left) {
+ ni = *n;
+ ja = *m - *l + 1;
+ jc = 1;
+ } else {
+ mi = *m;
+ ja = *n - *l + 1;
+ ic = 1;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) or H(i)' is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H(i) or H(i)' is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H(i) or H(i)' */
+
+ if (notran) {
+ i__3 = i__;
+ taui.r = tau[i__3].r, taui.i = tau[i__3].i;
+ } else {
+ d_cnjg(&z__1, &tau[i__]);
+ taui.r = z__1.r, taui.i = z__1.i;
+ }
+ zlarz_(side, &mi, &ni, l, &a[i__ + ja * a_dim1], lda, &taui, &c__[ic
+ + jc * c_dim1], ldc, &work[1]);
+
+/* L10: */
+ }
+
+ return 0;
+
+/* End of ZUNMR3 */
+
+} /* zunmr3_ */
diff --git a/SRC/zunmrq.c b/SRC/zunmrq.c
new file mode 100644
index 0000000..5cd6d34
--- /dev/null
+++ b/SRC/zunmrq.c
@@ -0,0 +1,339 @@
+/* zunmrq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int zunmrq_(char *side, char *trans, integer *m, integer *n,
+ integer *k, doublecomplex *a, integer *lda, doublecomplex *tau,
+ doublecomplex *c__, integer *ldc, doublecomplex *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
+ i__5;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ doublecomplex t[4160] /* was [65][64] */;
+ integer i1, i2, i3, ib, nb, mi, ni, nq, nw, iws;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int zunmr2_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ logical notran;
+ integer ldwork;
+ extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ char transt[1];
+ integer lwkopt;
+ logical lquery;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNMRQ overwrites the general complex M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'C': Q**H * C C * Q**H */
+
+/* where Q is a complex unitary matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1)' H(2)' . . . H(k)' */
+
+/* as returned by ZGERQF. Q is of order M if SIDE = 'L' and of order N */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**H from the Left; */
+/* = 'R': apply Q or Q**H from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'C': Transpose, apply Q**H. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* ZGERQF in the last k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) COMPLEX*16 array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZGERQF. */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = max(1,*n);
+ } else {
+ nq = *n;
+ nw = max(1,*m);
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*lda < max(1,*k)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ }
+
+ if (*info == 0) {
+ if (*m == 0 || *n == 0) {
+ lwkopt = 1;
+ } else {
+
+/* Determine the block size. NB may be at most NBMAX, where */
+/* NBMAX is used to define the local array T. */
+
+/* Computing MIN */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 64, i__2 = ilaenv_(&c__1, "ZUNMRQ", ch__1, m, n, k, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = nw * nb;
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ if (*lwork < nw && ! lquery) {
+ *info = -12;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUNMRQ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ nbmin = 2;
+ ldwork = nw;
+ if (nb > 1 && nb < *k) {
+ iws = nw * nb;
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 2, i__2 = ilaenv_(&c__2, "ZUNMRQ", ch__1, m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = nw;
+ }
+
+ if (nb < nbmin || nb >= *k) {
+
+/* Use unblocked code */
+
+ zunmr2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], &iinfo);
+ } else {
+
+/* Use blocked code */
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = nb;
+ } else {
+ i1 = (*k - 1) / nb * nb + 1;
+ i2 = 1;
+ i3 = -nb;
+ }
+
+ if (left) {
+ ni = *n;
+ } else {
+ mi = *m;
+ }
+
+ if (notran) {
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *k - i__ + 1;
+ ib = min(i__4,i__5);
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ i__4 = nq - *k + i__ + ib - 1;
+ zlarft_("Backward", "Rowwise", &i__4, &ib, &a[i__ + a_dim1], lda,
+ &tau[i__], t, &c__65);
+ if (left) {
+
+/* H or H' is applied to C(1:m-k+i+ib-1,1:n) */
+
+ mi = *m - *k + i__ + ib - 1;
+ } else {
+
+/* H or H' is applied to C(1:m,1:n-k+i+ib-1) */
+
+ ni = *n - *k + i__ + ib - 1;
+ }
+
+/* Apply H or H' */
+
+ zlarfb_(side, transt, "Backward", "Rowwise", &mi, &ni, &ib, &a[
+ i__ + a_dim1], lda, t, &c__65, &c__[c_offset], ldc, &work[
+ 1], &ldwork);
+/* L10: */
+ }
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ return 0;
+
+/* End of ZUNMRQ */
+
+} /* zunmrq_ */
diff --git a/SRC/zunmrz.c b/SRC/zunmrz.c
new file mode 100644
index 0000000..8cc2089
--- /dev/null
+++ b/SRC/zunmrz.c
@@ -0,0 +1,371 @@
+/* zunmrz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int zunmrz_(char *side, char *trans, integer *m, integer *n,
+ integer *k, integer *l, doublecomplex *a, integer *lda, doublecomplex
+ *tau, doublecomplex *c__, integer *ldc, doublecomplex *work, integer *
+ lwork, integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4,
+ i__5;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__;
+ doublecomplex t[4160] /* was [65][64] */;
+ integer i1, i2, i3, ib, ic, ja, jc, nb, mi, ni, nq, nw, iws;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer nbmin, iinfo;
+ extern /* Subroutine */ int zunmr3_(char *, char *, integer *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ logical notran;
+ integer ldwork;
+ extern /* Subroutine */ int zlarzb_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ char transt[1];
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int zlarzt_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNMRZ overwrites the general complex M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'C': Q**H * C C * Q**H */
+
+/* where Q is a complex unitary matrix defined as the product of k */
+/* elementary reflectors */
+
+/* Q = H(1) H(2) . . . H(k) */
+
+/* as returned by ZTZRZF. Q is of order M if SIDE = 'L' and of order N */
+/* if SIDE = 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**H from the Left; */
+/* = 'R': apply Q or Q**H from the Right. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'C': Conjugate transpose, apply Q**H. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines */
+/* the matrix Q. */
+/* If SIDE = 'L', M >= K >= 0; */
+/* if SIDE = 'R', N >= K >= 0. */
+
+/* L (input) INTEGER */
+/* The number of columns of the matrix A containing */
+/* the meaningful part of the Householder reflectors. */
+/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension */
+/* (LDA,M) if SIDE = 'L', */
+/* (LDA,N) if SIDE = 'R' */
+/* The i-th row must contain the vector which defines the */
+/* elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/* ZTZRZF in the last k rows of its array argument A. */
+/* A is modified by the routine but restored on exit. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,K). */
+
+/* TAU (input) COMPLEX*16 array, dimension (K) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZTZRZF. */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* Further Details */
+/* =============== */
+
+/* Based on contributions by */
+/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = max(1,*n);
+ } else {
+ nq = *n;
+ nw = max(1,*m);
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > nq) {
+ *info = -5;
+ } else if (*l < 0 || left && *l > *m || ! left && *l > *n) {
+ *info = -6;
+ } else if (*lda < max(1,*k)) {
+ *info = -8;
+ } else if (*ldc < max(1,*m)) {
+ *info = -11;
+ }
+
+ if (*info == 0) {
+ if (*m == 0 || *n == 0) {
+ lwkopt = 1;
+ } else {
+
+/* Determine the block size. NB may be at most NBMAX, where */
+/* NBMAX is used to define the local array T. */
+
+/* Computing MIN */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 64, i__2 = ilaenv_(&c__1, "ZUNMRQ", ch__1, m, n, k, &c_n1);
+ nb = min(i__1,i__2);
+ lwkopt = nw * nb;
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ if (*lwork < max(1,nw) && ! lquery) {
+ *info = -13;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUNMRZ", &i__1);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Determine the block size. NB may be at most NBMAX, where NBMAX */
+/* is used to define the local array T. */
+
+/* Computing MIN */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 64, i__2 = ilaenv_(&c__1, "ZUNMRQ", ch__1, m, n, k, &c_n1);
+ nb = min(i__1,i__2);
+ nbmin = 2;
+ ldwork = nw;
+ if (nb > 1 && nb < *k) {
+ iws = nw * nb;
+ if (*lwork < iws) {
+ nb = *lwork / ldwork;
+/* Computing MAX */
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = side;
+ i__3[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ i__1 = 2, i__2 = ilaenv_(&c__2, "ZUNMRQ", ch__1, m, n, k, &c_n1);
+ nbmin = max(i__1,i__2);
+ }
+ } else {
+ iws = nw;
+ }
+
+ if (nb < nbmin || nb >= *k) {
+
+/* Use unblocked code */
+
+ zunmr3_(side, trans, m, n, k, l, &a[a_offset], lda, &tau[1], &c__[
+ c_offset], ldc, &work[1], &iinfo);
+ } else {
+
+/* Use blocked code */
+
+ if (left && ! notran || ! left && notran) {
+ i1 = 1;
+ i2 = *k;
+ i3 = nb;
+ } else {
+ i1 = (*k - 1) / nb * nb + 1;
+ i2 = 1;
+ i3 = -nb;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ ja = *m - *l + 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ ja = *n - *l + 1;
+ }
+
+ if (notran) {
+ *(unsigned char *)transt = 'C';
+ } else {
+ *(unsigned char *)transt = 'N';
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+ i__4 = nb, i__5 = *k - i__ + 1;
+ ib = min(i__4,i__5);
+
+/* Form the triangular factor of the block reflector */
+/* H = H(i+ib-1) . . . H(i+1) H(i) */
+
+ zlarzt_("Backward", "Rowwise", l, &ib, &a[i__ + ja * a_dim1], lda,
+ &tau[i__], t, &c__65);
+
+ if (left) {
+
+/* H or H' is applied to C(i:m,1:n) */
+
+ mi = *m - i__ + 1;
+ ic = i__;
+ } else {
+
+/* H or H' is applied to C(1:m,i:n) */
+
+ ni = *n - i__ + 1;
+ jc = i__;
+ }
+
+/* Apply H or H' */
+
+ zlarzb_(side, transt, "Backward", "Rowwise", &mi, &ni, &ib, l, &a[
+ i__ + ja * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1]
+, ldc, &work[1], &ldwork);
+/* L10: */
+ }
+
+ }
+
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+
+ return 0;
+
+/* End of ZUNMRZ */
+
+} /* zunmrz_ */
diff --git a/SRC/zunmtr.c b/SRC/zunmtr.c
new file mode 100644
index 0000000..012737a
--- /dev/null
+++ b/SRC/zunmtr.c
@@ -0,0 +1,295 @@
+/* zunmtr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int zunmtr_(char *side, char *uplo, char *trans, integer *m,
+ integer *n, doublecomplex *a, integer *lda, doublecomplex *tau,
+ doublecomplex *c__, integer *ldc, doublecomplex *work, integer *lwork,
+ integer *info)
+{
+ /* System generated locals */
+ address a__1[2];
+ integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2, i__3;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i1, i2, nb, mi, ni, nq, nw;
+ logical left;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer lwkopt;
+ logical lquery;
+ extern /* Subroutine */ int zunmql_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *), zunmqr_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNMTR overwrites the general complex M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'C': Q**H * C C * Q**H */
+
+/* where Q is a complex unitary matrix of order nq, with nq = m if */
+/* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */
+/* nq-1 elementary reflectors, as returned by ZHETRD: */
+
+/* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); */
+
+/* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**H from the Left; */
+/* = 'R': apply Q or Q**H from the Right. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangle of A contains elementary reflectors */
+/* from ZHETRD; */
+/* = 'L': Lower triangle of A contains elementary reflectors */
+/* from ZHETRD. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'C': Conjugate transpose, apply Q**H. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension */
+/* (LDA,M) if SIDE = 'L' */
+/* (LDA,N) if SIDE = 'R' */
+/* The vectors which define the elementary reflectors, as */
+/* returned by ZHETRD. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. */
+
+/* TAU (input) COMPLEX*16 array, dimension */
+/* (M-1) if SIDE = 'L' */
+/* (N-1) if SIDE = 'R' */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZHETRD. */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
+/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* If SIDE = 'L', LWORK >= max(1,N); */
+/* if SIDE = 'R', LWORK >= max(1,M). */
+/* For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/* LWORK >=M*NB if SIDE = 'R', where NB is the optimal */
+/* blocksize. */
+
+/* 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. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ upper = lsame_(uplo, "U");
+ lquery = *lwork == -1;
+
+/* NQ is the order of Q and NW is the minimum dimension of WORK */
+
+ if (left) {
+ nq = *m;
+ nw = *n;
+ } else {
+ nq = *n;
+ nw = *m;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "C")) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*lda < max(1,nq)) {
+ *info = -7;
+ } else if (*ldc < max(1,*m)) {
+ *info = -10;
+ } else if (*lwork < max(1,nw) && ! lquery) {
+ *info = -12;
+ }
+
+ if (*info == 0) {
+ if (upper) {
+ if (left) {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ nb = ilaenv_(&c__1, "ZUNMQL", ch__1, &i__2, n, &i__3, &c_n1);
+ } else {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ nb = ilaenv_(&c__1, "ZUNMQL", ch__1, m, &i__2, &i__3, &c_n1);
+ }
+ } else {
+ if (left) {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ i__2 = *m - 1;
+ i__3 = *m - 1;
+ nb = ilaenv_(&c__1, "ZUNMQR", ch__1, &i__2, n, &i__3, &c_n1);
+ } else {
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = side;
+ i__1[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ nb = ilaenv_(&c__1, "ZUNMQR", ch__1, m, &i__2, &i__3, &c_n1);
+ }
+ }
+ lwkopt = max(1,nw) * nb;
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ }
+
+ if (*info != 0) {
+ i__2 = -(*info);
+ xerbla_("ZUNMTR", &i__2);
+ return 0;
+ } else if (lquery) {
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0 || nq == 1) {
+ work[1].r = 1., work[1].i = 0.;
+ return 0;
+ }
+
+ if (left) {
+ mi = *m - 1;
+ ni = *n;
+ } else {
+ mi = *m;
+ ni = *n - 1;
+ }
+
+ if (upper) {
+
+/* Q was determined by a call to ZHETRD with UPLO = 'U' */
+
+ i__2 = nq - 1;
+ zunmql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, &
+ tau[1], &c__[c_offset], ldc, &work[1], lwork, &iinfo);
+ } else {
+
+/* Q was determined by a call to ZHETRD with UPLO = 'L' */
+
+ if (left) {
+ i1 = 2;
+ i2 = 1;
+ } else {
+ i1 = 1;
+ i2 = 2;
+ }
+ i__2 = nq - 1;
+ zunmqr_(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], &
+ c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo);
+ }
+ work[1].r = (doublereal) lwkopt, work[1].i = 0.;
+ return 0;
+
+/* End of ZUNMTR */
+
+} /* zunmtr_ */
diff --git a/SRC/zupgtr.c b/SRC/zupgtr.c
new file mode 100644
index 0000000..2954727
--- /dev/null
+++ b/SRC/zupgtr.c
@@ -0,0 +1,221 @@
+/* zupgtr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zupgtr_(char *uplo, integer *n, doublecomplex *ap,
+ doublecomplex *tau, doublecomplex *q, integer *ldq, doublecomplex *
+ work, integer *info)
+{
+ /* System generated locals */
+ integer q_dim1, q_offset, i__1, i__2, i__3, i__4;
+
+ /* Local variables */
+ integer i__, j, ij;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ logical upper;
+ extern /* Subroutine */ int zung2l_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zung2r_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), xerbla_(char *, integer *);
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUPGTR generates a complex unitary matrix Q which is defined as the */
+/* product of n-1 elementary reflectors H(i) of order n, as returned by */
+/* ZHPTRD using packed storage: */
+
+/* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), */
+
+/* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular packed storage used in previous */
+/* call to ZHPTRD; */
+/* = 'L': Lower triangular packed storage used in previous */
+/* call to ZHPTRD. */
+
+/* N (input) INTEGER */
+/* The order of the matrix Q. N >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The vectors which define the elementary reflectors, as */
+/* returned by ZHPTRD. */
+
+/* TAU (input) COMPLEX*16 array, dimension (N-1) */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZHPTRD. */
+
+/* Q (output) COMPLEX*16 array, dimension (LDQ,N) */
+/* The N-by-N unitary matrix Q. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N-1) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --ap;
+ --tau;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ upper = lsame_(uplo, "U");
+ if (! upper && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*ldq < max(1,*n)) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUPGTR", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Q was determined by a call to ZHPTRD with UPLO = 'U' */
+
+/* Unpack the vectors which define the elementary reflectors and */
+/* set the last row and column of Q equal to those of the unit */
+/* matrix */
+
+ ij = 2;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * q_dim1;
+ i__4 = ij;
+ q[i__3].r = ap[i__4].r, q[i__3].i = ap[i__4].i;
+ ++ij;
+/* L10: */
+ }
+ ij += 2;
+ i__2 = *n + j * q_dim1;
+ q[i__2].r = 0., q[i__2].i = 0.;
+/* L20: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + *n * q_dim1;
+ q[i__2].r = 0., q[i__2].i = 0.;
+/* L30: */
+ }
+ i__1 = *n + *n * q_dim1;
+ q[i__1].r = 1., q[i__1].i = 0.;
+
+/* Generate Q(1:n-1,1:n-1) */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ zung2l_(&i__1, &i__2, &i__3, &q[q_offset], ldq, &tau[1], &work[1], &
+ iinfo);
+
+ } else {
+
+/* Q was determined by a call to ZHPTRD with UPLO = 'L'. */
+
+/* Unpack the vectors which define the elementary reflectors and */
+/* set the first row and column of Q equal to those of the unit */
+/* matrix */
+
+ i__1 = q_dim1 + 1;
+ q[i__1].r = 1., q[i__1].i = 0.;
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__ + q_dim1;
+ q[i__2].r = 0., q[i__2].i = 0.;
+/* L40: */
+ }
+ ij = 3;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j * q_dim1 + 1;
+ q[i__2].r = 0., q[i__2].i = 0.;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * q_dim1;
+ i__4 = ij;
+ q[i__3].r = ap[i__4].r, q[i__3].i = ap[i__4].i;
+ ++ij;
+/* L50: */
+ }
+ ij += 2;
+/* L60: */
+ }
+ if (*n > 1) {
+
+/* Generate Q(2:n,2:n) */
+
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ i__3 = *n - 1;
+ zung2r_(&i__1, &i__2, &i__3, &q[(q_dim1 << 1) + 2], ldq, &tau[1],
+ &work[1], &iinfo);
+ }
+ }
+ return 0;
+
+/* End of ZUPGTR */
+
+} /* zupgtr_ */
diff --git a/SRC/zupmtr.c b/SRC/zupmtr.c
new file mode 100644
index 0000000..5d10cea
--- /dev/null
+++ b/SRC/zupmtr.c
@@ -0,0 +1,321 @@
+/* zupmtr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zupmtr_(char *side, char *uplo, char *trans, integer *m,
+ integer *n, doublecomplex *ap, doublecomplex *tau, doublecomplex *c__,
+ integer *ldc, doublecomplex *work, integer *info)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, i1, i2, i3, ic, jc, ii, mi, ni, nq;
+ doublecomplex aii;
+ logical left;
+ doublecomplex taui;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *);
+ logical upper;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical notran, forwrd;
+
+
+/* -- LAPACK routine (version 3.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUPMTR overwrites the general complex M-by-N matrix C with */
+
+/* SIDE = 'L' SIDE = 'R' */
+/* TRANS = 'N': Q * C C * Q */
+/* TRANS = 'C': Q**H * C C * Q**H */
+
+/* where Q is a complex unitary matrix of order nq, with nq = m if */
+/* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */
+/* nq-1 elementary reflectors, as returned by ZHPTRD using packed */
+/* storage: */
+
+/* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); */
+
+/* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* = 'L': apply Q or Q**H from the Left; */
+/* = 'R': apply Q or Q**H from the Right. */
+
+/* UPLO (input) CHARACTER*1 */
+/* = 'U': Upper triangular packed storage used in previous */
+/* call to ZHPTRD; */
+/* = 'L': Lower triangular packed storage used in previous */
+/* call to ZHPTRD. */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, apply Q; */
+/* = 'C': Conjugate transpose, apply Q**H. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix C. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix C. N >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension */
+/* (M*(M+1)/2) if SIDE = 'L' */
+/* (N*(N+1)/2) if SIDE = 'R' */
+/* The vectors which define the elementary reflectors, as */
+/* returned by ZHPTRD. AP is modified by the routine but */
+/* restored on exit. */
+
+/* TAU (input) COMPLEX*16 array, dimension (M-1) if SIDE = 'L' */
+/* or (N-1) if SIDE = 'R' */
+/* TAU(i) must contain the scalar factor of the elementary */
+/* reflector H(i), as returned by ZHPTRD. */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC,N) */
+/* On entry, the M-by-N matrix C. */
+/* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (N) if SIDE = 'L' */
+/* (M) if SIDE = 'R' */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --ap;
+ --tau;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ left = lsame_(side, "L");
+ notran = lsame_(trans, "N");
+ upper = lsame_(uplo, "U");
+
+/* NQ is the order of Q */
+
+ if (left) {
+ nq = *m;
+ } else {
+ nq = *n;
+ }
+ if (! left && ! lsame_(side, "R")) {
+ *info = -1;
+ } else if (! upper && ! lsame_(uplo, "L")) {
+ *info = -2;
+ } else if (! notran && ! lsame_(trans, "C")) {
+ *info = -3;
+ } else if (*m < 0) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -5;
+ } else if (*ldc < max(1,*m)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUPMTR", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+ if (upper) {
+
+/* Q was determined by a call to ZHPTRD with UPLO = 'U' */
+
+ forwrd = left && notran || ! left && ! notran;
+
+ if (forwrd) {
+ i1 = 1;
+ i2 = nq - 1;
+ i3 = 1;
+ ii = 2;
+ } else {
+ i1 = nq - 1;
+ i2 = 1;
+ i3 = -1;
+ ii = nq * (nq + 1) / 2 - 1;
+ }
+
+ if (left) {
+ ni = *n;
+ } else {
+ mi = *m;
+ }
+
+ i__1 = i2;
+ i__2 = i3;
+ for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+ if (left) {
+
+/* H(i) or H(i)' is applied to C(1:i,1:n) */
+
+ mi = i__;
+ } else {
+
+/* H(i) or H(i)' is applied to C(1:m,1:i) */
+
+ ni = i__;
+ }
+
+/* Apply H(i) or H(i)' */
+
+ if (notran) {
+ i__3 = i__;
+ taui.r = tau[i__3].r, taui.i = tau[i__3].i;
+ } else {
+ d_cnjg(&z__1, &tau[i__]);
+ taui.r = z__1.r, taui.i = z__1.i;
+ }
+ i__3 = ii;
+ aii.r = ap[i__3].r, aii.i = ap[i__3].i;
+ i__3 = ii;
+ ap[i__3].r = 1., ap[i__3].i = 0.;
+ zlarf_(side, &mi, &ni, &ap[ii - i__ + 1], &c__1, &taui, &c__[
+ c_offset], ldc, &work[1]);
+ i__3 = ii;
+ ap[i__3].r = aii.r, ap[i__3].i = aii.i;
+
+ if (forwrd) {
+ ii = ii + i__ + 2;
+ } else {
+ ii = ii - i__ - 1;
+ }
+/* L10: */
+ }
+ } else {
+
+/* Q was determined by a call to ZHPTRD with UPLO = 'L'. */
+
+ forwrd = left && ! notran || ! left && notran;
+
+ if (forwrd) {
+ i1 = 1;
+ i2 = nq - 1;
+ i3 = 1;
+ ii = 2;
+ } else {
+ i1 = nq - 1;
+ i2 = 1;
+ i3 = -1;
+ ii = nq * (nq + 1) / 2 - 1;
+ }
+
+ if (left) {
+ ni = *n;
+ jc = 1;
+ } else {
+ mi = *m;
+ ic = 1;
+ }
+
+ i__2 = i2;
+ i__1 = i3;
+ for (i__ = i1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
+ i__3 = ii;
+ aii.r = ap[i__3].r, aii.i = ap[i__3].i;
+ i__3 = ii;
+ ap[i__3].r = 1., ap[i__3].i = 0.;
+ if (left) {
+
+/* H(i) or H(i)' is applied to C(i+1:m,1:n) */
+
+ mi = *m - i__;
+ ic = i__ + 1;
+ } else {
+
+/* H(i) or H(i)' is applied to C(1:m,i+1:n) */
+
+ ni = *n - i__;
+ jc = i__ + 1;
+ }
+
+/* Apply H(i) or H(i)' */
+
+ if (notran) {
+ i__3 = i__;
+ taui.r = tau[i__3].r, taui.i = tau[i__3].i;
+ } else {
+ d_cnjg(&z__1, &tau[i__]);
+ taui.r = z__1.r, taui.i = z__1.i;
+ }
+ zlarf_(side, &mi, &ni, &ap[ii], &c__1, &taui, &c__[ic + jc *
+ c_dim1], ldc, &work[1]);
+ i__3 = ii;
+ ap[i__3].r = aii.r, ap[i__3].i = aii.i;
+
+ if (forwrd) {
+ ii = ii + nq - i__ + 1;
+ } else {
+ ii = ii - nq + i__ - 2;
+ }
+/* L20: */
+ }
+ }
+ return 0;
+
+/* End of ZUPMTR */
+
+} /* zupmtr_ */
diff --git a/TESTING/CMakeLists.txt b/TESTING/CMakeLists.txt
new file mode 100644
index 0000000..d59359d
--- /dev/null
+++ b/TESTING/CMakeLists.txt
@@ -0,0 +1,296 @@
+if(MSVC_VERSION)
+# string(REPLACE "/STACK:10000000" "/STACK:900000000000000000"
+# CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS}")
+ string(REGEX REPLACE "(.*)/STACK:(.*) (.*)" "\\1/STACK:900000000000000000 \\3"
+ CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS}")
+endif()
+add_subdirectory(MATGEN)
+add_subdirectory(LIN)
+add_subdirectory(EIG)
+macro(add_lapack_test output input target)
+ set(TEST_INPUT "${CLAPACK_SOURCE_DIR}/TESTING/${input}")
+ set(TEST_OUTPUT "${CLAPACK_BINARY_DIR}/TESTING/${output}")
+ get_target_property(TEST_LOC ${target} LOCATION)
+ string(REPLACE "." "_" input_name ${input})
+ set(testName "${target}_${input_name}")
+ if(EXISTS "${TEST_INPUT}")
+ add_test(${testName} "${CMAKE_COMMAND}"
+ -DTEST=${TEST_LOC}
+ -DINPUT=${TEST_INPUT}
+ -DOUTPUT=${TEST_OUTPUT}
+ -DINTDIR=${CMAKE_CFG_INTDIR}
+ -P "${CLAPACK_SOURCE_DIR}/TESTING/runtest.cmake")
+ endif()
+endmacro(add_lapack_test)
+
+add_lapack_test(stest.out stest.in xlintsts)
+
+add_lapack_test(ctest.out ctest.in xlintstc)
+#
+# ======== DOUBLE LIN TESTS ===========================
+
+add_lapack_test(dtest.out dtest.in xlintstd)
+
+#
+# ======== COMPLEX16 LIN TESTS ========================
+
+add_lapack_test(ztest.out ztest.in xlintstz)
+
+#
+# ======== SINGLE-DOUBLE PROTO LIN TESTS ==============
+
+add_lapack_test(dstest.out dstest.in xlintstds)
+
+#
+# ======== COMPLEX-COMPLEX16 LIN TESTS ========================
+
+add_lapack_test(zctest.out zctest.in xlintstzc)
+
+#
+# ======== SINGLE RFP LIN TESTS ========================
+
+add_lapack_test(stest_rfp.out stest_rfp.in xlintstrfs)
+
+#
+# ======== COMPLEX16 RFP LIN TESTS ========================
+
+add_lapack_test(dtest_rfp.out dtest_rfp.in xlintstrfd)
+
+#
+# ======== COMPLEX16 RFP LIN TESTS ========================
+
+add_lapack_test(ctest_rfp.out ctest_rfp.in xlintstrfc)
+
+#
+# ======== COMPLEX16 RFP LIN TESTS ========================
+
+add_lapack_test(ztest_rfp.out ztest_rfp.in xlintstrfz)
+
+#
+#
+# ======== SINGLE EIG TESTS ===========================
+#
+
+add_lapack_test(snep.out nep.in xeigtsts)
+
+
+add_lapack_test(ssep.out sep.in xeigtsts)
+
+
+add_lapack_test(ssvd.out svd.in xeigtsts)
+
+
+add_lapack_test(sec.out sec.in xeigtsts)
+
+
+add_lapack_test(sed.out sed.in xeigtsts)
+
+
+add_lapack_test(sgg.out sgg.in xeigtsts)
+
+
+add_lapack_test(sgd.out sgd.in xeigtsts)
+
+
+add_lapack_test(ssb.out ssb.in xeigtsts)
+
+
+add_lapack_test(ssg.out ssg.in xeigtsts)
+
+
+add_lapack_test(sbal.out sbal.in xeigtsts)
+
+
+add_lapack_test(sbak.out sbak.in xeigtsts)
+
+
+add_lapack_test(sgbal.out sgbal.in xeigtsts)
+
+
+add_lapack_test(sgbak.out sgbak.in xeigtsts)
+
+
+add_lapack_test(sbb.out sbb.in xeigtsts)
+
+
+add_lapack_test(sglm.out glm.in xeigtsts)
+
+
+add_lapack_test(sgqr.out gqr.in xeigtsts)
+
+
+add_lapack_test(sgsv.out gsv.in xeigtsts)
+
+
+add_lapack_test(slse.out lse.in xeigtsts)
+
+#
+# ======== COMPLEX EIG TESTS ===========================
+
+add_lapack_test(cnep.out nep.in xeigtstc)
+
+
+add_lapack_test(csep.out sep.in xeigtstc)
+
+
+add_lapack_test(csvd.out svd.in xeigtstc)
+
+
+add_lapack_test(cec.out cec.in xeigtstc)
+
+
+add_lapack_test(ced.out ced.in xeigtstc)
+
+
+add_lapack_test(cgg.out cgg.in xeigtstc)
+
+
+add_lapack_test(cgd.out cgd.in xeigtstc)
+
+
+add_lapack_test(csb.out csb.in xeigtstc)
+
+
+add_lapack_test(csg.out csg.in xeigtstc)
+
+
+add_lapack_test(cbal.out cbal.in xeigtstc)
+
+
+add_lapack_test(cbak.out cbak.in xeigtstc)
+
+
+add_lapack_test(cgbal.out cgbal.in xeigtstc)
+
+
+add_lapack_test(cgbak.out cgbak.in xeigtstc)
+
+
+add_lapack_test(cbb.out cbb.in xeigtstc)
+
+
+add_lapack_test(cglm.out glm.in xeigtstc)
+
+
+add_lapack_test(cgqr.out gqr.in xeigtstc)
+
+
+add_lapack_test(cgsv.out gsv.in xeigtstc)
+
+
+add_lapack_test(clse.out lse.in xeigtstc)
+
+#
+# ======== DOUBLE EIG TESTS ===========================
+
+add_lapack_test(dnep.out nep.in xeigtstd)
+
+
+add_lapack_test(dsep.out sep.in xeigtstd)
+
+
+add_lapack_test(dsvd.out svd.in xeigtstd)
+
+
+add_lapack_test(dec.out dec.in xeigtstd)
+
+
+add_lapack_test(ded.out ded.in xeigtstd)
+
+
+add_lapack_test(dgg.out dgg.in xeigtstd)
+
+
+add_lapack_test(dgd.out dgd.in xeigtstd)
+
+
+add_lapack_test(dsb.out dsb.in xeigtstd)
+
+
+add_lapack_test(dsg.out dsg.in xeigtstd)
+
+
+add_lapack_test(dbal.out dbal.in xeigtstd)
+
+
+add_lapack_test(dbak.out dbak.in xeigtstd)
+
+
+add_lapack_test(dgbal.out dgbal.in xeigtstd)
+
+
+add_lapack_test(dgbak.out dgbak.in xeigtstd)
+
+
+add_lapack_test(dbb.out dbb.in xeigtstd)
+
+
+add_lapack_test(dglm.out glm.in xeigtstd)
+
+
+add_lapack_test(dgqr.out gqr.in xeigtstd)
+
+
+add_lapack_test(dgsv.out gsv.in xeigtstd)
+
+
+add_lapack_test(dlse.out lse.in xeigtstd)
+
+#
+# ======== COMPLEX16 EIG TESTS ===========================
+
+add_lapack_test(znep.out nep.in xeigtstz)
+
+
+add_lapack_test(zsep.out sep.in xeigtstz)
+
+
+add_lapack_test(zsvd.out svd.in xeigtstz)
+
+
+add_lapack_test(zec.out zec.in xeigtstz)
+
+
+add_lapack_test(zed.out zed.in xeigtstz)
+
+
+add_lapack_test(zgg.out zgg.in xeigtstz)
+
+
+add_lapack_test(zgd.out zgd.in xeigtstz)
+
+
+add_lapack_test(zsb.out zsb.in xeigtstz)
+
+
+add_lapack_test(zsg.out zsg.in xeigtstz)
+
+
+add_lapack_test(zbal.out zbal.in xeigtstz)
+
+
+add_lapack_test(zbak.out zbak.in xeigtstz)
+
+
+add_lapack_test(zgbal.out zgbal.in xeigtstz)
+
+
+add_lapack_test(zgbak.out zgbak.in xeigtstz)
+
+
+add_lapack_test(zbb.out zbb.in xeigtstz)
+
+
+add_lapack_test(zglm.out glm.in xeigtstz)
+
+
+add_lapack_test(zgqr.out gqr.in xeigtstz)
+
+
+add_lapack_test(zgsv.out gsv.in xeigtstz)
+
+
+add_lapack_test(zlse.out lse.in xeigtstz)
+
+# ==============================================================================
+
diff --git a/TESTING/EIG/CMakeLists.txt b/TESTING/EIG/CMakeLists.txt
new file mode 100644
index 0000000..5549573
--- /dev/null
+++ b/TESTING/EIG/CMakeLists.txt
@@ -0,0 +1,135 @@
+########################################################################
+# This is the makefile for the eigenvalue test program from LAPACK.
+# The test files are organized as follows:
+#
+# AEIGTST -- Auxiliary test routines used in all precisions
+# SCIGTST -- Auxiliary test routines used in REAL and COMPLEX
+# DZIGTST -- Auxiliary test routines used in DOUBLE PRECISION and
+# COMPLEX*16
+# SEIGTST -- Single precision real test routines
+# CEIGTST -- Single precision complex test routines
+# DEIGTST -- Double precision real test routines
+# ZEIGTST -- Double precision complex test routines
+#
+# Test programs can be generated for all or some of the four different
+# precisions. Enter make followed by one or more of the data types
+# desired. Some examples:
+# make single
+# make single complex
+# make single double complex complex16
+# Alternatively, the command
+# make
+# without any arguments creates all four test programs.
+# The executable files are called
+# xeigtsts, xeigtstd, xeigtstc, and xeigtstz
+# and are created in the next higher directory level.
+#
+# To remove the object files after the executable files have been
+# created, enter
+# make clean
+# On some systems, you can force the source files to be recompiled by
+# entering (for example)
+# make single FRC=FRC
+#
+########################################################################
+
+set(AEIGTST
+ alahdg.c
+ alasum.c
+ alasvm.c
+ alareq.c
+ ilaenv.c
+ xerbla.c
+ xlaenv.c
+ chkxer.c)
+
+set(SCIGTST slafts.c slahd2.c slasum.c slatb9.c sstech.c sstect.c
+ ssvdch.c ssvdct.c ssxt1.c)
+
+set(SEIGTST schkee.c
+ sbdt01.c sbdt02.c sbdt03.c
+ schkbb.c schkbd.c schkbk.c schkbl.c schkec.c
+ schkgg.c schkgk.c schkgl.c schkhs.c schksb.c schkst.c
+ sckglm.c sckgqr.c sckgsv.c scklse.c
+ sdrges.c sdrgev.c sdrgsx.c sdrgvx.c
+ sdrvbd.c sdrves.c sdrvev.c sdrvgg.c sdrvsg.c
+ sdrvst.c sdrvsx.c sdrvvx.c
+ serrbd.c serrec.c serred.c serrgg.c serrhs.c serrst.c
+ sget02.c sget10.c sget22.c sget23.c sget24.c sget31.c
+ sget32.c sget33.c sget34.c sget35.c sget36.c
+ sget37.c sget38.c sget39.c sget51.c sget52.c sget53.c
+ sget54.c sglmts.c sgqrts.c sgrqts.c sgsvts.c
+ shst01.c slarfy.c slarhs.c slatm4.c slctes.c slctsx.c slsets.c sort01.c
+ sort03.c ssbt21.c ssgt01.c sslect.c sspt21.c sstt21.c
+ sstt22.c ssyt21.c ssyt22.c)
+
+set(CEIGTST cchkee.c
+ cbdt01.c cbdt02.c cbdt03.c
+ cchkbb.c cchkbd.c cchkbk.c cchkbl.c cchkec.c
+ cchkgg.c cchkgk.c cchkgl.c cchkhb.c cchkhs.c cchkst.c
+ cckglm.c cckgqr.c cckgsv.c ccklse.c
+ cdrges.c cdrgev.c cdrgsx.c cdrgvx.c
+ cdrvbd.c cdrves.c cdrvev.c cdrvgg.c cdrvsg.c
+ cdrvst.c cdrvsx.c cdrvvx.c
+ cerrbd.c cerrec.c cerred.c cerrgg.c cerrhs.c cerrst.c
+ cget02.c cget10.c cget22.c cget23.c cget24.c
+ cget35.c cget36.c cget37.c cget38.c cget51.c cget52.c
+ cget54.c cglmts.c cgqrts.c cgrqts.c cgsvts.c
+ chbt21.c chet21.c chet22.c chpt21.c chst01.c
+ clarfy.c clarhs.c clatm4.c clctes.c clctsx.c clsets.c csbmv.c
+ csgt01.c cslect.c
+ cstt21.c cstt22.c cunt01.c cunt03.c)
+
+set(DZIGTST dlafts.c dlahd2.c dlasum.c dlatb9.c dstech.c dstect.c
+ dsvdch.c dsvdct.c dsxt1.c)
+
+set(DEIGTST dchkee.c
+ dbdt01.c dbdt02.c dbdt03.c
+ dchkbb.c dchkbd.c dchkbk.c dchkbl.c dchkec.c
+ dchkgg.c dchkgk.c dchkgl.c dchkhs.c dchksb.c dchkst.c
+ dckglm.c dckgqr.c dckgsv.c dcklse.c
+ ddrges.c ddrgev.c ddrgsx.c ddrgvx.c
+ ddrvbd.c ddrves.c ddrvev.c ddrvgg.c ddrvsg.c
+ ddrvst.c ddrvsx.c ddrvvx.c
+ derrbd.c derrec.c derred.c derrgg.c derrhs.c derrst.c
+ dget02.c dget10.c dget22.c dget23.c dget24.c dget31.c
+ dget32.c dget33.c dget34.c dget35.c dget36.c
+ dget37.c dget38.c dget39.c dget51.c dget52.c dget53.c
+ dget54.c dglmts.c dgqrts.c dgrqts.c dgsvts.c
+ dhst01.c dlarfy.c dlarhs.c dlatm4.c dlctes.c dlctsx.c dlsets.c dort01.c
+ dort03.c dsbt21.c dsgt01.c dslect.c dspt21.c dstt21.c
+ dstt22.c dsyt21.c dsyt22.c)
+
+set(ZEIGTST zchkee.c
+ zbdt01.c zbdt02.c zbdt03.c
+ zchkbb.c zchkbd.c zchkbk.c zchkbl.c zchkec.c
+ zchkgg.c zchkgk.c zchkgl.c zchkhb.c zchkhs.c zchkst.c
+ zckglm.c zckgqr.c zckgsv.c zcklse.c
+ zdrges.c zdrgev.c zdrgsx.c zdrgvx.c
+ zdrvbd.c zdrves.c zdrvev.c zdrvgg.c zdrvsg.c
+ zdrvst.c zdrvsx.c zdrvvx.c
+ zerrbd.c zerrec.c zerred.c zerrgg.c zerrhs.c zerrst.c
+ zget02.c zget10.c zget22.c zget23.c zget24.c
+ zget35.c zget36.c zget37.c zget38.c zget51.c zget52.c
+ zget54.c zglmts.c zgqrts.c zgrqts.c zgsvts.c
+ zhbt21.c zhet21.c zhet22.c zhpt21.c zhst01.c
+ zlarfy.c zlarhs.c zlatm4.c zlctes.c zlctsx.c zlsets.c zsbmv.c
+ zsgt01.c zslect.c
+ zstt21.c zstt22.c zunt01.c zunt03.c)
+
+macro(add_eig_executable name )
+ add_executable(${name} ${ARGN})
+ target_link_libraries(${name} tmglib lapack )
+endmacro(add_eig_executable)
+
+add_eig_executable(xeigtsts ${SEIGTST} ${SCIGTST} ${AEIGTST}
+ ${SECOND_SRC} )
+
+add_eig_executable(xeigtstc ${CEIGTST} ${SCIGTST} ${AEIGTST}
+ ${SECOND_SRC} )
+
+add_eig_executable(xeigtstd ${DEIGTST} ${DZIGTST} ${AEIGTST}
+ ${DSECOND_SRC} )
+
+add_eig_executable(xeigtstz ${ZEIGTST} ${DZIGTST} ${AEIGTST}
+ ${DSECOND_SRC} )
diff --git a/TESTING/EIG/Makefile b/TESTING/EIG/Makefile
new file mode 100644
index 0000000..24e5781
--- /dev/null
+++ b/TESTING/EIG/Makefile
@@ -0,0 +1,176 @@
+include ../../make.inc
+
+########################################################################
+# This is the makefile for the eigenvalue test program from LAPACK.
+# The test files are organized as follows:
+#
+# AEIGTST -- Auxiliary test routines used in all precisions
+# SCIGTST -- Auxiliary test routines used in REAL and COMPLEX
+# DZIGTST -- Auxiliary test routines used in DOUBLE PRECISION and
+# COMPLEX*16
+# SEIGTST -- Single precision real test routines
+# CEIGTST -- Single precision complex test routines
+# DEIGTST -- Double precision real test routines
+# ZEIGTST -- Double precision complex test routines
+#
+# Test programs can be generated for all or some of the four different
+# precisions. Enter make followed by one or more of the data types
+# desired. Some examples:
+# make single
+# make single complex
+# make single double complex complex16
+# Alternatively, the command
+# make
+# without any arguments creates all four test programs.
+# The executable files are called
+# xeigtsts, xeigtstd, xeigtstc, and xeigtstz
+# and are created in the next higher directory level.
+#
+# To remove the object files after the executable files have been
+# created, enter
+# make clean
+# On some systems, you can force the source files to be recompiled by
+# entering (for example)
+# make single FRC=FRC
+#
+########################################################################
+
+AEIGTST = \
+ alahdg.o \
+ alasum.o \
+ alasvm.o \
+ alareq.o \
+ ilaenv.o \
+ xerbla.o \
+ xlaenv.o \
+ chkxer.o
+
+SCIGTST = slafts.o slahd2.o slasum.o slatb9.o sstech.o sstect.o \
+ ssvdch.o ssvdct.o ssxt1.o
+
+SEIGTST = schkee.o \
+ sbdt01.o sbdt02.o sbdt03.o \
+ schkbb.o schkbd.o schkbk.o schkbl.o schkec.o \
+ schkgg.o schkgk.o schkgl.o schkhs.o schksb.o schkst.o \
+ sckglm.o sckgqr.o sckgsv.o scklse.o \
+ sdrges.o sdrgev.o sdrgsx.o sdrgvx.o \
+ sdrvbd.o sdrves.o sdrvev.o sdrvgg.o sdrvsg.o \
+ sdrvst.o sdrvsx.o sdrvvx.o \
+ serrbd.o serrec.o serred.o serrgg.o serrhs.o serrst.o \
+ sget02.o sget10.o sget22.o sget23.o sget24.o sget31.o \
+ sget32.o sget33.o sget34.o sget35.o sget36.o \
+ sget37.o sget38.o sget39.o sget51.o sget52.o sget53.o \
+ sget54.o sglmts.o sgqrts.o sgrqts.o sgsvts.o \
+ shst01.o slarfy.o slarhs.o slatm4.o slctes.o slctsx.o slsets.o sort01.o \
+ sort03.o ssbt21.o ssgt01.o sslect.o sspt21.o sstt21.o \
+ sstt22.o ssyt21.o ssyt22.o
+
+CEIGTST = cchkee.o \
+ cbdt01.o cbdt02.o cbdt03.o \
+ cchkbb.o cchkbd.o cchkbk.o cchkbl.o cchkec.o \
+ cchkgg.o cchkgk.o cchkgl.o cchkhb.o cchkhs.o cchkst.o \
+ cckglm.o cckgqr.o cckgsv.o ccklse.o \
+ cdrges.o cdrgev.o cdrgsx.o cdrgvx.o \
+ cdrvbd.o cdrves.o cdrvev.o cdrvgg.o cdrvsg.o \
+ cdrvst.o cdrvsx.o cdrvvx.o \
+ cerrbd.o cerrec.o cerred.o cerrgg.o cerrhs.o cerrst.o \
+ cget02.o cget10.o cget22.o cget23.o cget24.o \
+ cget35.o cget36.o cget37.o cget38.o cget51.o cget52.o \
+ cget54.o cglmts.o cgqrts.o cgrqts.o cgsvts.o \
+ chbt21.o chet21.o chet22.o chpt21.o chst01.o \
+ clarfy.o clarhs.o clatm4.o clctes.o clctsx.o clsets.o csbmv.o \
+ csgt01.o cslect.o \
+ cstt21.o cstt22.o cunt01.o cunt03.o
+
+DZIGTST = dlafts.o dlahd2.o dlasum.o dlatb9.o dstech.o dstect.o \
+ dsvdch.o dsvdct.o dsxt1.o
+
+DEIGTST = dchkee.o \
+ dbdt01.o dbdt02.o dbdt03.o \
+ dchkbb.o dchkbd.o dchkbk.o dchkbl.o dchkec.o \
+ dchkgg.o dchkgk.o dchkgl.o dchkhs.o dchksb.o dchkst.o \
+ dckglm.o dckgqr.o dckgsv.o dcklse.o \
+ ddrges.o ddrgev.o ddrgsx.o ddrgvx.o \
+ ddrvbd.o ddrves.o ddrvev.o ddrvgg.o ddrvsg.o \
+ ddrvst.o ddrvsx.o ddrvvx.o \
+ derrbd.o derrec.o derred.o derrgg.o derrhs.o derrst.o \
+ dget02.o dget10.o dget22.o dget23.o dget24.o dget31.o \
+ dget32.o dget33.o dget34.o dget35.o dget36.o \
+ dget37.o dget38.o dget39.o dget51.o dget52.o dget53.o \
+ dget54.o dglmts.o dgqrts.o dgrqts.o dgsvts.o \
+ dhst01.o dlarfy.o dlarhs.o dlatm4.o dlctes.o dlctsx.o dlsets.o dort01.o \
+ dort03.o dsbt21.o dsgt01.o dslect.o dspt21.o dstt21.o \
+ dstt22.o dsyt21.o dsyt22.o
+
+ZEIGTST = zchkee.o \
+ zbdt01.o zbdt02.o zbdt03.o \
+ zchkbb.o zchkbd.o zchkbk.o zchkbl.o zchkec.o \
+ zchkgg.o zchkgk.o zchkgl.o zchkhb.o zchkhs.o zchkst.o \
+ zckglm.o zckgqr.o zckgsv.o zcklse.o \
+ zdrges.o zdrgev.o zdrgsx.o zdrgvx.o \
+ zdrvbd.o zdrves.o zdrvev.o zdrvgg.o zdrvsg.o \
+ zdrvst.o zdrvsx.o zdrvvx.o \
+ zerrbd.o zerrec.o zerred.o zerrgg.o zerrhs.o zerrst.o \
+ zget02.o zget10.o zget22.o zget23.o zget24.o \
+ zget35.o zget36.o zget37.o zget38.o zget51.o zget52.o \
+ zget54.o zglmts.o zgqrts.o zgrqts.o zgsvts.o \
+ zhbt21.o zhet21.o zhet22.o zhpt21.o zhst01.o \
+ zlarfy.o zlarhs.o zlatm4.o zlctes.o zlctsx.o zlsets.o zsbmv.o \
+ zsgt01.o zslect.o \
+ zstt21.o zstt22.o zunt01.o zunt03.o
+
+all: single complex double complex16
+
+single: ../xeigtsts
+complex: ../xeigtstc
+double: ../xeigtstd
+complex16: ../xeigtstz
+
+../xeigtsts: $(SEIGTST) $(SCIGTST) $(AEIGTST) ; \
+ $(CC) $(LOADOPTS) -o xeigtsts \
+ $(SEIGTST) $(SCIGTST) $(AEIGTST) ../../$(TMGLIB) \
+ ../../INSTALL/second.o \
+ ../../$(LAPACKLIB) $(BLASLIB) $(F2CLIB) -lm && mv xeigtsts $@
+
+../xeigtstc: $(CEIGTST) $(SCIGTST) $(AEIGTST) ; \
+ $(CC) $(LOADOPTS) -o xeigtstc \
+ $(CEIGTST) $(SCIGTST) $(AEIGTST) ../../$(TMGLIB) \
+ ../../INSTALL/second.o \
+ ../../$(LAPACKLIB) $(BLASLIB) $(F2CLIB) -lm && mv xeigtstc $@
+
+../xeigtstd: $(DEIGTST) $(DZIGTST) $(AEIGTST) ; \
+ $(CC) $(LOADOPTS) -o xeigtstd \
+ $(DEIGTST) $(DZIGTST) $(AEIGTST) ../../$(TMGLIB) \
+ ../../INSTALL/dsecnd.o \
+ ../../$(LAPACKLIB) $(BLASLIB) $(F2CLIB) -lm && mv xeigtstd $@
+
+../xeigtstz: $(ZEIGTST) $(DZIGTST) $(AEIGTST) ; \
+ $(CC) $(LOADOPTS) -o xeigtstz \
+ $(ZEIGTST) $(DZIGTST) $(AEIGTST) ../../$(TMGLIB) \
+ ../../INSTALL/dsecnd.o \
+ ../../$(LAPACKLIB) $(BLASLIB) $(F2CLIB) -lm && mv xeigtstz $@
+
+$(AEIGTST): $(FRC)
+$(SCIGTST): $(FRC)
+$(DZIGTST): $(FRC)
+$(SEIGTST): $(FRC)
+$(CEIGTST): $(FRC)
+$(DEIGTST): $(FRC)
+$(ZEIGTST): $(FRC)
+
+FRC:
+ @FRC=$(FRC)
+
+clean:
+ rm -f *.o
+
+schkee.o: schkee.c
+ $(CC) $(DRVCFLAGS) -I../../INCLUDE -c $< -o $@
+dchkee.o: dchkee.c
+ $(CC) $(DRVCFLAGS) -I../../INCLUDE -c $< -o $@
+cchkee.o: cchkee.c
+ $(CC) $(DRVCFLAGS) -I../../INCLUDE -c $< -o $@
+zchkee.o: zchkee.c
+ $(CC) $(DRVCFLAGS) -I../../INCLUDE -c $< -o $@
+
+.c.o : ; $(CC) $(CFLAGS) -I../../INCLUDE -c $<
diff --git a/TESTING/EIG/alahdg.c b/TESTING/EIG/alahdg.c
new file mode 100644
index 0000000..c577b7b
--- /dev/null
+++ b/TESTING/EIG/alahdg.c
@@ -0,0 +1,534 @@
+/* alahdg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__4 = 4;
+static integer c__5 = 5;
+static integer c__6 = 6;
+static integer c__7 = 7;
+static integer c__8 = 8;
+
+/* Subroutine */ int alahdg_(integer *iounit, char *path)
+{
+ /* Format strings */
+ static char fmt_9991[] = "(/1x,a3,\002: GQR factorization of general mat"
+ "rices\002)";
+ static char fmt_9992[] = "(/1x,a3,\002: GRQ factorization of general mat"
+ "rices\002)";
+ static char fmt_9993[] = "(/1x,a3,\002: LSE Problem\002)";
+ static char fmt_9994[] = "(/1x,a3,\002: GLM Problem\002)";
+ static char fmt_9995[] = "(/1x,a3,\002: Generalized Singular Value Decom"
+ "position\002)";
+ static char fmt_9999[] = "(1x,a)";
+ static char fmt_9950[] = "(3x,i2,\002: A-diagonal matrix B-upper triang"
+ "ular\002)";
+ static char fmt_9952[] = "(3x,i2,\002: A-upper triangular B-upper triang"
+ "ular\002)";
+ static char fmt_9954[] = "(3x,i2,\002: A-lower triangular B-upper triang"
+ "ular\002)";
+ static char fmt_9955[] = "(3x,i2,\002: Random matrices cond(A)=100, cond"
+ "(B)=10,\002)";
+ static char fmt_9956[] = "(3x,i2,\002: Random matrices cond(A)= sqrt( 0."
+ "1/EPS ) \002,\002cond(B)= sqrt( 0.1/EPS )\002)";
+ static char fmt_9957[] = "(3x,i2,\002: Random matrices cond(A)= 0.1/EPS"
+ " \002,\002cond(B)= 0.1/EPS\002)";
+ static char fmt_9961[] = "(3x,i2,\002: Matrix scaled near underflow li"
+ "mit\002)";
+ static char fmt_9962[] = "(3x,i2,\002: Matrix scaled near overflow limi"
+ "t\002)";
+ static char fmt_9951[] = "(3x,i2,\002: A-diagonal matrix B-lower triang"
+ "ular\002)";
+ static char fmt_9953[] = "(3x,i2,\002: A-lower triangular B-diagonal tri"
+ "angular\002)";
+ static char fmt_9959[] = "(3x,i2,\002: Random matrices cond(A)= sqrt( 0."
+ "1/EPS ) \002,\002cond(B)= 0.1/EPS \002)";
+ static char fmt_9960[] = "(3x,i2,\002: Random matrices cond(A)= 0.1/EPS"
+ " \002,\002cond(B)= sqrt( 0.1/EPS )\002)";
+ static char fmt_9930[] = "(3x,i2,\002: norm( R - Q' * A ) / ( min( N, M "
+ ")*norm( A )\002,\002* EPS )\002)";
+ static char fmt_9931[] = "(3x,i2,\002: norm( T * Z - Q' * B ) / ( min(P"
+ ",N)*norm(B)\002,\002* EPS )\002)";
+ static char fmt_9932[] = "(3x,i2,\002: norm( I - Q'*Q ) / ( N * EPS "
+ ")\002)";
+ static char fmt_9933[] = "(3x,i2,\002: norm( I - Z'*Z ) / ( P * EPS "
+ ")\002)";
+ static char fmt_9934[] = "(3x,i2,\002: norm( R - A * Q' ) / ( min( N,M )"
+ "*norm(A) * \002,\002EPS )\002)";
+ static char fmt_9935[] = "(3x,i2,\002: norm( T * Q - Z' * B ) / ( min( "
+ "P,N ) * nor\002,\002m(B)*EPS )\002)";
+ static char fmt_9937[] = "(3x,i2,\002: norm( A*x - c ) / ( norm(A)*norm"
+ "(x) * EPS )\002)";
+ static char fmt_9938[] = "(3x,i2,\002: norm( B*x - d ) / ( norm(B)*norm"
+ "(x) * EPS )\002)";
+ static char fmt_9939[] = "(3x,i2,\002: norm( d - A*x - B*y ) / ( (norm(A"
+ ")+norm(B) )*\002,\002(norm(x)+norm(y))*EPS )\002)";
+ static char fmt_9940[] = "(3x,i2,\002: norm( U' * A * Q - D1 * R ) / ( m"
+ "in( M, N )*\002,\002norm( A ) * EPS )\002)";
+ static char fmt_9941[] = "(3x,i2,\002: norm( V' * B * Q - D2 * R ) / ( m"
+ "in( P, N )*\002,\002norm( B ) * EPS )\002)";
+ static char fmt_9942[] = "(3x,i2,\002: norm( I - U'*U ) / ( M * EPS "
+ ")\002)";
+ static char fmt_9943[] = "(3x,i2,\002: norm( I - V'*V ) / ( P * EPS "
+ ")\002)";
+ static char fmt_9944[] = "(3x,i2,\002: norm( I - Q'*Q ) / ( N * EPS "
+ ")\002)";
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ char c2[3];
+ integer itype;
+ extern logical lsamen_(integer *, char *, char *);
+
+ /* Fortran I/O blocks */
+ static cilist io___3 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___4 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___5 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___6 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___7 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___8 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___9 = { 0, 0, 0, fmt_9950, 0 };
+ static cilist io___10 = { 0, 0, 0, fmt_9952, 0 };
+ static cilist io___11 = { 0, 0, 0, fmt_9954, 0 };
+ static cilist io___12 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___13 = { 0, 0, 0, fmt_9956, 0 };
+ static cilist io___14 = { 0, 0, 0, fmt_9957, 0 };
+ static cilist io___15 = { 0, 0, 0, fmt_9961, 0 };
+ static cilist io___16 = { 0, 0, 0, fmt_9962, 0 };
+ static cilist io___17 = { 0, 0, 0, fmt_9951, 0 };
+ static cilist io___18 = { 0, 0, 0, fmt_9953, 0 };
+ static cilist io___19 = { 0, 0, 0, fmt_9954, 0 };
+ static cilist io___20 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___21 = { 0, 0, 0, fmt_9956, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9957, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9961, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9962, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9950, 0 };
+ static cilist io___26 = { 0, 0, 0, fmt_9952, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9954, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9951, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9953, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9954, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9950, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9952, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9954, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9956, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9957, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9959, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9960, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9930, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9931, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9932, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9933, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9934, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9935, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9932, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9933, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9937, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9938, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9939, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9940, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9941, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9942, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9943, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9944, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ALAHDG prints header information for the different test paths. */
+
+/* Arguments */
+/* ========= */
+
+/* IOUNIT (input) INTEGER */
+/* The unit number to which the header information should be */
+/* printed. */
+
+/* PATH (input) CHARACTER*3 */
+/* The name of the path for which the header information is to */
+/* be printed. Current paths are */
+/* GQR: GQR (general matrices) */
+/* GRQ: GRQ (general matrices) */
+/* LSE: LSE Problem */
+/* GLM: GLM Problem */
+/* GSV: Generalized Singular Value Decomposition */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (*iounit <= 0) {
+ return 0;
+ }
+ s_copy(c2, path, (ftnlen)3, (ftnlen)3);
+
+/* First line describing matrices in this path */
+
+ if (lsamen_(&c__3, c2, "GQR")) {
+ itype = 1;
+ io___3.ciunit = *iounit;
+ s_wsfe(&io___3);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ } else if (lsamen_(&c__3, c2, "GRQ")) {
+ itype = 2;
+ io___4.ciunit = *iounit;
+ s_wsfe(&io___4);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ } else if (lsamen_(&c__3, c2, "LSE")) {
+ itype = 3;
+ io___5.ciunit = *iounit;
+ s_wsfe(&io___5);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ } else if (lsamen_(&c__3, c2, "GLM")) {
+ itype = 4;
+ io___6.ciunit = *iounit;
+ s_wsfe(&io___6);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ } else if (lsamen_(&c__3, c2, "GSV")) {
+ itype = 5;
+ io___7.ciunit = *iounit;
+ s_wsfe(&io___7);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+/* Matrix types */
+
+ io___8.ciunit = *iounit;
+ s_wsfe(&io___8);
+ do_fio(&c__1, "Matrix types: ", (ftnlen)14);
+ e_wsfe();
+
+ if (itype == 1) {
+ io___9.ciunit = *iounit;
+ s_wsfe(&io___9);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___10.ciunit = *iounit;
+ s_wsfe(&io___10);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___11.ciunit = *iounit;
+ s_wsfe(&io___11);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___12.ciunit = *iounit;
+ s_wsfe(&io___12);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___13.ciunit = *iounit;
+ s_wsfe(&io___13);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___14.ciunit = *iounit;
+ s_wsfe(&io___14);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___15.ciunit = *iounit;
+ s_wsfe(&io___15);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___16.ciunit = *iounit;
+ s_wsfe(&io___16);
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (itype == 2) {
+ io___17.ciunit = *iounit;
+ s_wsfe(&io___17);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___18.ciunit = *iounit;
+ s_wsfe(&io___18);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___19.ciunit = *iounit;
+ s_wsfe(&io___19);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___20.ciunit = *iounit;
+ s_wsfe(&io___20);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___21.ciunit = *iounit;
+ s_wsfe(&io___21);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___22.ciunit = *iounit;
+ s_wsfe(&io___22);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___23.ciunit = *iounit;
+ s_wsfe(&io___23);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___24.ciunit = *iounit;
+ s_wsfe(&io___24);
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (itype == 3) {
+ io___25.ciunit = *iounit;
+ s_wsfe(&io___25);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___26.ciunit = *iounit;
+ s_wsfe(&io___26);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___27.ciunit = *iounit;
+ s_wsfe(&io___27);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___28.ciunit = *iounit;
+ s_wsfe(&io___28);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___29.ciunit = *iounit;
+ s_wsfe(&io___29);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___30.ciunit = *iounit;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___31.ciunit = *iounit;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___32.ciunit = *iounit;
+ s_wsfe(&io___32);
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (itype == 4) {
+ io___33.ciunit = *iounit;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___34.ciunit = *iounit;
+ s_wsfe(&io___34);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___35.ciunit = *iounit;
+ s_wsfe(&io___35);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___36.ciunit = *iounit;
+ s_wsfe(&io___36);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___37.ciunit = *iounit;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___38.ciunit = *iounit;
+ s_wsfe(&io___38);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___39.ciunit = *iounit;
+ s_wsfe(&io___39);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___40.ciunit = *iounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (itype == 5) {
+ io___41.ciunit = *iounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___42.ciunit = *iounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___43.ciunit = *iounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___44.ciunit = *iounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___45.ciunit = *iounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___46.ciunit = *iounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___47.ciunit = *iounit;
+ s_wsfe(&io___47);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___48.ciunit = *iounit;
+ s_wsfe(&io___48);
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Tests performed */
+
+ io___49.ciunit = *iounit;
+ s_wsfe(&io___49);
+ do_fio(&c__1, "Test ratios: ", (ftnlen)13);
+ e_wsfe();
+
+ if (itype == 1) {
+
+/* GQR decomposition of rectangular matrices */
+
+ io___50.ciunit = *iounit;
+ s_wsfe(&io___50);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___51.ciunit = *iounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___52.ciunit = *iounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___53.ciunit = *iounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (itype == 2) {
+
+/* GRQ decomposition of rectangular matrices */
+
+ io___54.ciunit = *iounit;
+ s_wsfe(&io___54);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___55.ciunit = *iounit;
+ s_wsfe(&io___55);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___56.ciunit = *iounit;
+ s_wsfe(&io___56);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___57.ciunit = *iounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (itype == 3) {
+
+/* LSE Problem */
+
+ io___58.ciunit = *iounit;
+ s_wsfe(&io___58);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___59.ciunit = *iounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (itype == 4) {
+
+/* GLM Problem */
+
+ io___60.ciunit = *iounit;
+ s_wsfe(&io___60);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (itype == 5) {
+
+/* GSVD */
+
+ io___61.ciunit = *iounit;
+ s_wsfe(&io___61);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___62.ciunit = *iounit;
+ s_wsfe(&io___62);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___63.ciunit = *iounit;
+ s_wsfe(&io___63);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___64.ciunit = *iounit;
+ s_wsfe(&io___64);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___65.ciunit = *iounit;
+ s_wsfe(&io___65);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+
+
+
+
+
+
+/* GQR test ratio */
+
+
+/* GRQ test ratio */
+
+
+/* LSE test ratio */
+
+
+/* GLM test ratio */
+
+
+/* GSVD test ratio */
+
+ return 0;
+
+/* End of ALAHDG */
+
+} /* alahdg_ */
diff --git a/TESTING/EIG/alareq.c b/TESTING/EIG/alareq.c
new file mode 100644
index 0000000..1b87394
--- /dev/null
+++ b/TESTING/EIG/alareq.c
@@ -0,0 +1,277 @@
+/* alareq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int alareq_(char *path, integer *nmats, logical *dotype,
+ integer *ntypes, integer *nin, integer *nout)
+{
+ /* Initialized data */
+
+ static char intstr[10] = "0123456789";
+
+ /* Format strings */
+ static char fmt_9995[] = "(//\002 *** Not enough matrix types on input l"
+ "ine\002,/a79)";
+ static char fmt_9994[] = "(\002 ==> Specify \002,i4,\002 matrix types on"
+ " this line or \002,\002adjust NTYPES on previous line\002)";
+ static char fmt_9996[] = "(//\002 *** Invalid integer value in column"
+ " \002,i2,\002 of input\002,\002 line:\002,/a79)";
+ static char fmt_9997[] = "(\002 *** Warning: duplicate request of matri"
+ "x type \002,i2,\002 for \002,a3)";
+ static char fmt_9999[] = "(\002 *** Invalid type request for \002,a3,"
+ "\002, type \002,i4,\002: must satisfy 1 <= type <= \002,i2)";
+ static char fmt_9998[] = "(/\002 *** End of file reached when trying to "
+ "read matrix \002,\002types for \002,a3,/\002 *** Check that you "
+ "are requesting the\002,\002 right number of types for each pat"
+ "h\002,/)";
+
+ /* System generated locals */
+ integer i__1;
+ cilist ci__1;
+
+ /* Builtin functions */
+ integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
+ i_len(char *, ftnlen), s_wsfe(cilist *), e_wsfe(void), s_wsle(
+ cilist *), e_wsle(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k;
+ char c1[1];
+ integer i1, ic, nt;
+ char line[80];
+ integer lenp, nreq[100];
+ logical firstt;
+
+ /* Fortran I/O blocks */
+ static cilist io___9 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___10 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___14 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___15 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___17 = { 0, 0, 0, 0, 0 };
+ static cilist io___18 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___19 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___20 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___21 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ALAREQ handles input for the LAPACK test program. It is called */
+/* to evaluate the input line which requested NMATS matrix types for */
+/* PATH. The flow of control is as follows: */
+
+/* If NMATS = NTYPES then */
+/* DOTYPE(1:NTYPES) = .TRUE. */
+/* else */
+/* Read the next input line for NMATS matrix types */
+/* Set DOTYPE(I) = .TRUE. for each valid type I */
+/* endif */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* An LAPACK path name for testing. */
+
+/* NMATS (input) INTEGER */
+/* The number of matrix types to be used in testing this path. */
+
+/* DOTYPE (output) LOGICAL array, dimension (NTYPES) */
+/* The vector of flags indicating if each type will be tested. */
+
+/* NTYPES (input) INTEGER */
+/* The maximum number of matrix types for this path. */
+
+/* NIN (input) INTEGER */
+/* The unit number for input. NIN >= 1. */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. NOUT >= 1. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (*nmats >= *ntypes) {
+
+/* Test everything if NMATS >= NTYPES. */
+
+ i__1 = *ntypes;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dotype[i__] = TRUE_;
+/* L10: */
+ }
+ } else {
+ i__1 = *ntypes;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dotype[i__] = FALSE_;
+/* L20: */
+ }
+ firstt = TRUE_;
+
+/* Read a line of matrix types if 0 < NMATS < NTYPES. */
+
+ if (*nmats > 0) {
+ ci__1.cierr = 0;
+ ci__1.ciend = 1;
+ ci__1.ciunit = *nin;
+ ci__1.cifmt = "(A80)";
+ i__1 = s_rsfe(&ci__1);
+ if (i__1 != 0) {
+ goto L90;
+ }
+ i__1 = do_fio(&c__1, line, (ftnlen)80);
+ if (i__1 != 0) {
+ goto L90;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L90;
+ }
+ lenp = i_len(line, (ftnlen)80);
+ i__ = 0;
+ i__1 = *nmats;
+ for (j = 1; j <= i__1; ++j) {
+ nreq[j - 1] = 0;
+ i1 = 0;
+L30:
+ ++i__;
+ if (i__ > lenp) {
+ if (j == *nmats && i1 > 0) {
+ goto L60;
+ } else {
+ io___9.ciunit = *nout;
+ s_wsfe(&io___9);
+ do_fio(&c__1, line, (ftnlen)80);
+ e_wsfe();
+ io___10.ciunit = *nout;
+ s_wsfe(&io___10);
+ do_fio(&c__1, (char *)&(*nmats), (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ goto L80;
+ }
+ }
+ if (*(unsigned char *)&line[i__ - 1] != ' ' && *(unsigned
+ char *)&line[i__ - 1] != ',') {
+ i1 = i__;
+ *(unsigned char *)c1 = *(unsigned char *)&line[i1 - 1];
+
+/* Check that a valid integer was read */
+
+ for (k = 1; k <= 10; ++k) {
+ if (*(unsigned char *)c1 == *(unsigned char *)&intstr[
+ k - 1]) {
+ ic = k - 1;
+ goto L50;
+ }
+/* L40: */
+ }
+ io___14.ciunit = *nout;
+ s_wsfe(&io___14);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, line, (ftnlen)80);
+ e_wsfe();
+ io___15.ciunit = *nout;
+ s_wsfe(&io___15);
+ do_fio(&c__1, (char *)&(*nmats), (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L80;
+L50:
+ nreq[j - 1] = nreq[j - 1] * 10 + ic;
+ goto L30;
+ } else if (i1 > 0) {
+ goto L60;
+ } else {
+ goto L30;
+ }
+L60:
+ ;
+ }
+ }
+ i__1 = *nmats;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nt = nreq[i__ - 1];
+ if (nt > 0 && nt <= *ntypes) {
+ if (dotype[nt]) {
+ if (firstt) {
+ io___17.ciunit = *nout;
+ s_wsle(&io___17);
+ e_wsle();
+ }
+ firstt = FALSE_;
+ io___18.ciunit = *nout;
+ s_wsfe(&io___18);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+ dotype[nt] = TRUE_;
+ } else {
+ io___19.ciunit = *nout;
+ s_wsfe(&io___19);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ntypes), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L70: */
+ }
+L80:
+ ;
+ }
+ return 0;
+
+L90:
+ io___20.ciunit = *nout;
+ s_wsfe(&io___20);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___21.ciunit = *nout;
+ s_wsle(&io___21);
+ e_wsle();
+ s_stop("", (ftnlen)0);
+
+/* End of ALAREQ */
+
+ return 0;
+} /* alareq_ */
diff --git a/TESTING/EIG/alarqg.c b/TESTING/EIG/alarqg.c
new file mode 100644
index 0000000..5e8d3c5
--- /dev/null
+++ b/TESTING/EIG/alarqg.c
@@ -0,0 +1,277 @@
+/* alarqg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int alarqg_(char *path, integer *nmats, logical *dotype,
+ integer *ntypes, integer *nin, integer *nout)
+{
+ /* Initialized data */
+
+ static char intstr[10] = "0123456789";
+
+ /* Format strings */
+ static char fmt_9995[] = "(//\002 *** Not enough matrix types on input l"
+ "ine\002,/a79)";
+ static char fmt_9994[] = "(\002 ==> Specify \002,i4,\002 matrix types on"
+ " this line or \002,\002adjust NTYPES on previous line\002)";
+ static char fmt_9996[] = "(//\002 *** Invalid integer value in column"
+ " \002,i2,\002 of input\002,\002 line:\002,/a79)";
+ static char fmt_9997[] = "(\002 *** Warning: duplicate request of matri"
+ "x type \002,i2,\002 for \002,a3)";
+ static char fmt_9999[] = "(\002 *** Invalid type request for \002,a3,"
+ "\002, type \002,i4,\002: must satisfy 1 <= type <= \002,i2)";
+ static char fmt_9998[] = "(/\002 *** End of file reached when trying to "
+ "read matrix \002,\002types for \002,a3,/\002 *** Check that you "
+ "are requesting the\002,\002 right number of types for each pat"
+ "h\002,/)";
+
+ /* System generated locals */
+ integer i__1;
+ cilist ci__1;
+
+ /* Builtin functions */
+ integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
+ i_len(char *, ftnlen), s_wsfe(cilist *), e_wsfe(void), s_wsle(
+ cilist *), e_wsle(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k;
+ char c1[1];
+ integer i1, ic, nt;
+ char line[80];
+ integer lenp, nreq[100];
+ logical firstt;
+
+ /* Fortran I/O blocks */
+ static cilist io___9 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___10 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___14 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___15 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___17 = { 0, 0, 0, 0, 0 };
+ static cilist io___18 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___19 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___20 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___21 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ALARQG handles input for the LAPACK test program. It is called */
+/* to evaluate the input line which requested NMATS matrix types for */
+/* PATH. The flow of control is as follows: */
+
+/* If NMATS = NTYPES then */
+/* DOTYPE(1:NTYPES) = .TRUE. */
+/* else */
+/* Read the next input line for NMATS matrix types */
+/* Set DOTYPE(I) = .TRUE. for each valid type I */
+/* endif */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* An LAPACK path name for testing. */
+
+/* NMATS (input) INTEGER */
+/* The number of matrix types to be used in testing this path. */
+
+/* DOTYPE (output) LOGICAL array, dimension (NTYPES) */
+/* The vector of flags indicating if each type will be tested. */
+
+/* NTYPES (input) INTEGER */
+/* The maximum number of matrix types for this path. */
+
+/* NIN (input) INTEGER */
+/* The unit number for input. NIN >= 1. */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. NOUT >= 1. */
+
+/* ====================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (*nmats >= *ntypes) {
+
+/* Test everything if NMATS >= NTYPES. */
+
+ i__1 = *ntypes;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dotype[i__] = TRUE_;
+/* L10: */
+ }
+ } else {
+ i__1 = *ntypes;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dotype[i__] = FALSE_;
+/* L20: */
+ }
+ firstt = TRUE_;
+
+/* Read a line of matrix types if 0 < NMATS < NTYPES. */
+
+ if (*nmats > 0) {
+ ci__1.cierr = 0;
+ ci__1.ciend = 1;
+ ci__1.ciunit = *nin;
+ ci__1.cifmt = "(A80)";
+ i__1 = s_rsfe(&ci__1);
+ if (i__1 != 0) {
+ goto L90;
+ }
+ i__1 = do_fio(&c__1, line, (ftnlen)80);
+ if (i__1 != 0) {
+ goto L90;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L90;
+ }
+ lenp = i_len(line, (ftnlen)80);
+ i__ = 0;
+ i__1 = *nmats;
+ for (j = 1; j <= i__1; ++j) {
+ nreq[j - 1] = 0;
+ i1 = 0;
+L30:
+ ++i__;
+ if (i__ > lenp) {
+ if (j == *nmats && i1 > 0) {
+ goto L60;
+ } else {
+ io___9.ciunit = *nout;
+ s_wsfe(&io___9);
+ do_fio(&c__1, line, (ftnlen)80);
+ e_wsfe();
+ io___10.ciunit = *nout;
+ s_wsfe(&io___10);
+ do_fio(&c__1, (char *)&(*nmats), (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ goto L80;
+ }
+ }
+ if (*(unsigned char *)&line[i__ - 1] != ' ' && *(unsigned
+ char *)&line[i__ - 1] != ',') {
+ i1 = i__;
+ *(unsigned char *)c1 = *(unsigned char *)&line[i1 - 1];
+
+/* Check that a valid integer was read */
+
+ for (k = 1; k <= 10; ++k) {
+ if (*(unsigned char *)c1 == *(unsigned char *)&intstr[
+ k - 1]) {
+ ic = k - 1;
+ goto L50;
+ }
+/* L40: */
+ }
+ io___14.ciunit = *nout;
+ s_wsfe(&io___14);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, line, (ftnlen)80);
+ e_wsfe();
+ io___15.ciunit = *nout;
+ s_wsfe(&io___15);
+ do_fio(&c__1, (char *)&(*nmats), (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L80;
+L50:
+ nreq[j - 1] = nreq[j - 1] * 10 + ic;
+ goto L30;
+ } else if (i1 > 0) {
+ goto L60;
+ } else {
+ goto L30;
+ }
+L60:
+ ;
+ }
+ }
+ i__1 = *nmats;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nt = nreq[i__ - 1];
+ if (nt > 0 && nt <= *ntypes) {
+ if (dotype[nt]) {
+ if (firstt) {
+ io___17.ciunit = *nout;
+ s_wsle(&io___17);
+ e_wsle();
+ }
+ firstt = FALSE_;
+ io___18.ciunit = *nout;
+ s_wsfe(&io___18);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+ dotype[nt] = TRUE_;
+ } else {
+ io___19.ciunit = *nout;
+ s_wsfe(&io___19);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ntypes), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L70: */
+ }
+L80:
+ ;
+ }
+ return 0;
+
+L90:
+ io___20.ciunit = *nout;
+ s_wsfe(&io___20);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___21.ciunit = *nout;
+ s_wsle(&io___21);
+ e_wsle();
+ s_stop("", (ftnlen)0);
+
+/* End of ALARQG */
+
+ return 0;
+} /* alarqg_ */
diff --git a/TESTING/EIG/alasmg.c b/TESTING/EIG/alasmg.c
new file mode 100644
index 0000000..47ea369
--- /dev/null
+++ b/TESTING/EIG/alasmg.c
@@ -0,0 +1,100 @@
+/* alasmg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int alasmg_(char *type__, integer *nout, integer *nfail,
+ integer *nrun, integer *nerrs)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002: \002,i6,\002 out of \002,i6,\002 "
+ "tests failed to pass the threshold\002)";
+ static char fmt_9998[] = "(/1x,\002All tests for \002,a3,\002 routines p"
+ "assed the threshold (\002,i6,\002 tests run)\002)";
+ static char fmt_9997[] = "(6x,i6,\002 error messages recorded\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___2 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___3 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ALASMG prints a summary of results from one of the -CHK- routines. */
+
+/* Arguments */
+/* ========= */
+
+/* TYPE (input) CHARACTER*3 */
+/* The LAPACK path name. */
+
+/* NOUT (input) INTEGER */
+/* The unit number on which results are to be printed. */
+/* NOUT >= 0. */
+
+/* NFAIL (input) INTEGER */
+/* The number of tests which did not pass the threshold ratio. */
+
+/* NRUN (input) INTEGER */
+/* The total number of tests. */
+
+/* NERRS (input) INTEGER */
+/* The number of error messages recorded. */
+
+/* ====================================================================== */
+
+/* .. Executable Statements .. */
+
+ if (*nfail > 0) {
+ io___1.ciunit = *nout;
+ s_wsfe(&io___1);
+ do_fio(&c__1, type__, (ftnlen)3);
+ do_fio(&c__1, (char *)&(*nfail), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*nrun), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___2.ciunit = *nout;
+ s_wsfe(&io___2);
+ do_fio(&c__1, type__, (ftnlen)3);
+ do_fio(&c__1, (char *)&(*nrun), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*nerrs > 0) {
+ io___3.ciunit = *nout;
+ s_wsfe(&io___3);
+ do_fio(&c__1, (char *)&(*nerrs), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ return 0;
+
+/* End of ALASMG */
+
+} /* alasmg_ */
diff --git a/TESTING/EIG/alasum.c b/TESTING/EIG/alasum.c
new file mode 100644
index 0000000..1337db7
--- /dev/null
+++ b/TESTING/EIG/alasum.c
@@ -0,0 +1,100 @@
+/* alasum.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int alasum_(char *type__, integer *nout, integer *nfail,
+ integer *nrun, integer *nerrs)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002: \002,i6,\002 out of \002,i6,\002 "
+ "tests failed to pass the threshold\002)";
+ static char fmt_9998[] = "(/1x,\002All tests for \002,a3,\002 routines p"
+ "assed the threshold (\002,i6,\002 tests run)\002)";
+ static char fmt_9997[] = "(6x,i6,\002 error messages recorded\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___2 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___3 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ALASUM prints a summary of results from one of the -CHK- routines. */
+
+/* Arguments */
+/* ========= */
+
+/* TYPE (input) CHARACTER*3 */
+/* The LAPACK path name. */
+
+/* NOUT (input) INTEGER */
+/* The unit number on which results are to be printed. */
+/* NOUT >= 0. */
+
+/* NFAIL (input) INTEGER */
+/* The number of tests which did not pass the threshold ratio. */
+
+/* NRUN (input) INTEGER */
+/* The total number of tests. */
+
+/* NERRS (input) INTEGER */
+/* The number of error messages recorded. */
+
+/* ===================================================================== */
+
+/* .. Executable Statements .. */
+
+ if (*nfail > 0) {
+ io___1.ciunit = *nout;
+ s_wsfe(&io___1);
+ do_fio(&c__1, type__, (ftnlen)3);
+ do_fio(&c__1, (char *)&(*nfail), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*nrun), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___2.ciunit = *nout;
+ s_wsfe(&io___2);
+ do_fio(&c__1, type__, (ftnlen)3);
+ do_fio(&c__1, (char *)&(*nrun), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*nerrs > 0) {
+ io___3.ciunit = *nout;
+ s_wsfe(&io___3);
+ do_fio(&c__1, (char *)&(*nerrs), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ return 0;
+
+/* End of ALASUM */
+
+} /* alasum_ */
diff --git a/TESTING/EIG/alasvm.c b/TESTING/EIG/alasvm.c
new file mode 100644
index 0000000..980e9c7
--- /dev/null
+++ b/TESTING/EIG/alasvm.c
@@ -0,0 +1,100 @@
+/* alasvm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int alasvm_(char *type__, integer *nout, integer *nfail,
+ integer *nrun, integer *nerrs)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 drivers: \002,i6,\002 out of \002,"
+ "i6,\002 tests failed to pass the threshold\002)";
+ static char fmt_9998[] = "(/1x,\002All tests for \002,a3,\002 drivers p"
+ "assed the \002,\002threshold (\002,i6,\002 tests run)\002)";
+ static char fmt_9997[] = "(14x,i6,\002 error messages recorded\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___2 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___3 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ALASVM prints a summary of results from one of the -DRV- routines. */
+
+/* Arguments */
+/* ========= */
+
+/* TYPE (input) CHARACTER*3 */
+/* The LAPACK path name. */
+
+/* NOUT (input) INTEGER */
+/* The unit number on which results are to be printed. */
+/* NOUT >= 0. */
+
+/* NFAIL (input) INTEGER */
+/* The number of tests which did not pass the threshold ratio. */
+
+/* NRUN (input) INTEGER */
+/* The total number of tests. */
+
+/* NERRS (input) INTEGER */
+/* The number of error messages recorded. */
+
+/* ===================================================================== */
+
+/* .. Executable Statements .. */
+
+ if (*nfail > 0) {
+ io___1.ciunit = *nout;
+ s_wsfe(&io___1);
+ do_fio(&c__1, type__, (ftnlen)3);
+ do_fio(&c__1, (char *)&(*nfail), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*nrun), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___2.ciunit = *nout;
+ s_wsfe(&io___2);
+ do_fio(&c__1, type__, (ftnlen)3);
+ do_fio(&c__1, (char *)&(*nrun), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*nerrs > 0) {
+ io___3.ciunit = *nout;
+ s_wsfe(&io___3);
+ do_fio(&c__1, (char *)&(*nerrs), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ return 0;
+
+/* End of ALASVM */
+
+} /* alasvm_ */
diff --git a/TESTING/EIG/cbdt01.c b/TESTING/EIG/cbdt01.c
new file mode 100644
index 0000000..daa0d02
--- /dev/null
+++ b/TESTING/EIG/cbdt01.c
@@ -0,0 +1,344 @@
+/* cbdt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static complex c_b7 = {-1.f,-0.f};
+static complex c_b10 = {1.f,0.f};
+
+/* Subroutine */ int cbdt01_(integer *m, integer *n, integer *kd, complex *a,
+ integer *lda, complex *q, integer *ldq, real *d__, real *e, complex *
+ pt, integer *ldpt, complex *work, real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, pt_dim1, pt_offset, q_dim1, q_offset, i__1,
+ i__2, i__3, i__4, i__5, i__6, i__7;
+ real r__1, r__2;
+ complex q__1, q__2, q__3;
+
+ /* Local variables */
+ integer i__, j;
+ real eps;
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *);
+ real anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *), scasum_(
+ integer *, complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CBDT01 reconstructs a general matrix A from its bidiagonal form */
+/* A = Q * B * P' */
+/* where Q (m by min(m,n)) and P' (min(m,n) by n) are unitary */
+/* matrices and B is bidiagonal. */
+
+/* The test ratio to test the reduction is */
+/* RESID = norm( A - Q * B * PT ) / ( n * norm(A) * EPS ) */
+/* where PT = P' and EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices A and Q. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and P'. */
+
+/* KD (input) INTEGER */
+/* If KD = 0, B is diagonal and the array E is not referenced. */
+/* If KD = 1, the reduction was performed by xGEBRD; B is upper */
+/* bidiagonal if M >= N, and lower bidiagonal if M < N. */
+/* If KD = -1, the reduction was performed by xGBBRD; B is */
+/* always upper bidiagonal. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* Q (input) COMPLEX array, dimension (LDQ,N) */
+/* The m by min(m,n) unitary matrix Q in the reduction */
+/* A = Q * B * P'. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,M). */
+
+/* D (input) REAL array, dimension (min(M,N)) */
+/* The diagonal elements of the bidiagonal matrix B. */
+
+/* E (input) REAL array, dimension (min(M,N)-1) */
+/* The superdiagonal elements of the bidiagonal matrix B if */
+/* m >= n, or the subdiagonal elements of B if m < n. */
+
+/* PT (input) COMPLEX array, dimension (LDPT,N) */
+/* The min(m,n) by n unitary matrix P' in the reduction */
+/* A = Q * B * P'. */
+
+/* LDPT (input) INTEGER */
+/* The leading dimension of the array PT. */
+/* LDPT >= max(1,min(M,N)). */
+
+/* WORK (workspace) COMPLEX array, dimension (M+N) */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESID (output) REAL */
+/* The test ratio: norm(A - Q * B * P') / ( n * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --d__;
+ --e;
+ pt_dim1 = *ldpt;
+ pt_offset = 1 + pt_dim1;
+ pt -= pt_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Compute A - Q * B * P' one column at a time. */
+
+ *resid = 0.f;
+ if (*kd != 0) {
+
+/* B is bidiagonal. */
+
+ if (*kd != 0 && *m >= *n) {
+
+/* B is upper bidiagonal and M >= N. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__2 = *n - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = *m + i__;
+ i__4 = i__;
+ i__5 = i__ + j * pt_dim1;
+ q__2.r = d__[i__4] * pt[i__5].r, q__2.i = d__[i__4] * pt[
+ i__5].i;
+ i__6 = i__;
+ i__7 = i__ + 1 + j * pt_dim1;
+ q__3.r = e[i__6] * pt[i__7].r, q__3.i = e[i__6] * pt[i__7]
+ .i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L10: */
+ }
+ i__2 = *m + *n;
+ i__3 = *n;
+ i__4 = *n + j * pt_dim1;
+ q__1.r = d__[i__3] * pt[i__4].r, q__1.i = d__[i__3] * pt[i__4]
+ .i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ cgemv_("No transpose", m, n, &c_b7, &q[q_offset], ldq, &work[*
+ m + 1], &c__1, &c_b10, &work[1], &c__1);
+/* Computing MAX */
+ r__1 = *resid, r__2 = scasum_(m, &work[1], &c__1);
+ *resid = dmax(r__1,r__2);
+/* L20: */
+ }
+ } else if (*kd < 0) {
+
+/* B is upper bidiagonal and M < N. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__2 = *m - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = *m + i__;
+ i__4 = i__;
+ i__5 = i__ + j * pt_dim1;
+ q__2.r = d__[i__4] * pt[i__5].r, q__2.i = d__[i__4] * pt[
+ i__5].i;
+ i__6 = i__;
+ i__7 = i__ + 1 + j * pt_dim1;
+ q__3.r = e[i__6] * pt[i__7].r, q__3.i = e[i__6] * pt[i__7]
+ .i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L30: */
+ }
+ i__2 = *m + *m;
+ i__3 = *m;
+ i__4 = *m + j * pt_dim1;
+ q__1.r = d__[i__3] * pt[i__4].r, q__1.i = d__[i__3] * pt[i__4]
+ .i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ cgemv_("No transpose", m, m, &c_b7, &q[q_offset], ldq, &work[*
+ m + 1], &c__1, &c_b10, &work[1], &c__1);
+/* Computing MAX */
+ r__1 = *resid, r__2 = scasum_(m, &work[1], &c__1);
+ *resid = dmax(r__1,r__2);
+/* L40: */
+ }
+ } else {
+
+/* B is lower bidiagonal. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__2 = *m + 1;
+ i__3 = j * pt_dim1 + 1;
+ q__1.r = d__[1] * pt[i__3].r, q__1.i = d__[1] * pt[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ i__2 = *m;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = *m + i__;
+ i__4 = i__ - 1;
+ i__5 = i__ - 1 + j * pt_dim1;
+ q__2.r = e[i__4] * pt[i__5].r, q__2.i = e[i__4] * pt[i__5]
+ .i;
+ i__6 = i__;
+ i__7 = i__ + j * pt_dim1;
+ q__3.r = d__[i__6] * pt[i__7].r, q__3.i = d__[i__6] * pt[
+ i__7].i;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L50: */
+ }
+ cgemv_("No transpose", m, m, &c_b7, &q[q_offset], ldq, &work[*
+ m + 1], &c__1, &c_b10, &work[1], &c__1);
+/* Computing MAX */
+ r__1 = *resid, r__2 = scasum_(m, &work[1], &c__1);
+ *resid = dmax(r__1,r__2);
+/* L60: */
+ }
+ }
+ } else {
+
+/* B is diagonal. */
+
+ if (*m >= *n) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = *m + i__;
+ i__4 = i__;
+ i__5 = i__ + j * pt_dim1;
+ q__1.r = d__[i__4] * pt[i__5].r, q__1.i = d__[i__4] * pt[
+ i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L70: */
+ }
+ cgemv_("No transpose", m, n, &c_b7, &q[q_offset], ldq, &work[*
+ m + 1], &c__1, &c_b10, &work[1], &c__1);
+/* Computing MAX */
+ r__1 = *resid, r__2 = scasum_(m, &work[1], &c__1);
+ *resid = dmax(r__1,r__2);
+/* L80: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = *m + i__;
+ i__4 = i__;
+ i__5 = i__ + j * pt_dim1;
+ q__1.r = d__[i__4] * pt[i__5].r, q__1.i = d__[i__4] * pt[
+ i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L90: */
+ }
+ cgemv_("No transpose", m, m, &c_b7, &q[q_offset], ldq, &work[*
+ m + 1], &c__1, &c_b10, &work[1], &c__1);
+/* Computing MAX */
+ r__1 = *resid, r__2 = scasum_(m, &work[1], &c__1);
+ *resid = dmax(r__1,r__2);
+/* L100: */
+ }
+ }
+ }
+
+/* Compute norm(A - Q * B * P') / ( n * norm(A) * EPS ) */
+
+ anorm = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ eps = slamch_("Precision");
+
+ if (anorm <= 0.f) {
+ if (*resid != 0.f) {
+ *resid = 1.f / eps;
+ }
+ } else {
+ if (anorm >= *resid) {
+ *resid = *resid / anorm / ((real) (*n) * eps);
+ } else {
+ if (anorm < 1.f) {
+/* Computing MIN */
+ r__1 = *resid, r__2 = (real) (*n) * anorm;
+ *resid = dmin(r__1,r__2) / anorm / ((real) (*n) * eps);
+ } else {
+/* Computing MIN */
+ r__1 = *resid / anorm, r__2 = (real) (*n);
+ *resid = dmin(r__1,r__2) / ((real) (*n) * eps);
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CBDT01 */
+
+} /* cbdt01_ */
diff --git a/TESTING/EIG/cbdt02.c b/TESTING/EIG/cbdt02.c
new file mode 100644
index 0000000..1b4f417
--- /dev/null
+++ b/TESTING/EIG/cbdt02.c
@@ -0,0 +1,176 @@
+/* cbdt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static complex c_b7 = {-1.f,-0.f};
+static complex c_b10 = {1.f,0.f};
+
+/* Subroutine */ int cbdt02_(integer *m, integer *n, complex *b, integer *ldb,
+ complex *c__, integer *ldc, complex *u, integer *ldu, complex *work,
+ real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, c_dim1, c_offset, u_dim1, u_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j;
+ real eps;
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *);
+ real bnorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ real realmn;
+ extern doublereal scasum_(integer *, complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CBDT02 tests the change of basis C = U' * B by computing the residual */
+
+/* RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ), */
+
+/* where B and C are M by N matrices, U is an M by M orthogonal matrix, */
+/* and EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices B and C and the order of */
+/* the matrix Q. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices B and C. */
+
+/* B (input) COMPLEX array, dimension (LDB,N) */
+/* The m by n matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M). */
+
+/* C (input) COMPLEX array, dimension (LDC,N) */
+/* The m by n matrix C, assumed to contain U' * B. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* U (input) COMPLEX array, dimension (LDU,M) */
+/* The m by m orthogonal matrix U. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M). */
+
+/* WORK (workspace) COMPLEX array, dimension (M) */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESID (output) REAL */
+/* RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ), */
+
+/* ====================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *resid = 0.f;
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+ realmn = (real) max(*m,*n);
+ eps = slamch_("Precision");
+
+/* Compute norm( B - U * C ) */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(m, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ cgemv_("No transpose", m, m, &c_b7, &u[u_offset], ldu, &c__[j *
+ c_dim1 + 1], &c__1, &c_b10, &work[1], &c__1);
+/* Computing MAX */
+ r__1 = *resid, r__2 = scasum_(m, &work[1], &c__1);
+ *resid = dmax(r__1,r__2);
+/* L10: */
+ }
+
+/* Compute norm of B. */
+
+ bnorm = clange_("1", m, n, &b[b_offset], ldb, &rwork[1]);
+
+ if (bnorm <= 0.f) {
+ if (*resid != 0.f) {
+ *resid = 1.f / eps;
+ }
+ } else {
+ if (bnorm >= *resid) {
+ *resid = *resid / bnorm / (realmn * eps);
+ } else {
+ if (bnorm < 1.f) {
+/* Computing MIN */
+ r__1 = *resid, r__2 = realmn * bnorm;
+ *resid = dmin(r__1,r__2) / bnorm / (realmn * eps);
+ } else {
+/* Computing MIN */
+ r__1 = *resid / bnorm;
+ *resid = dmin(r__1,realmn) / (realmn * eps);
+ }
+ }
+ }
+ return 0;
+
+/* End of CBDT02 */
+
+} /* cbdt02_ */
diff --git a/TESTING/EIG/cbdt03.c b/TESTING/EIG/cbdt03.c
new file mode 100644
index 0000000..c1fba3c
--- /dev/null
+++ b/TESTING/EIG/cbdt03.c
@@ -0,0 +1,299 @@
+/* cbdt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b6 = {-1.f,-0.f};
+static integer c__1 = 1;
+static complex c_b9 = {0.f,0.f};
+
+/* Subroutine */ int cbdt03_(char *uplo, integer *n, integer *kd, real *d__,
+ real *e, complex *u, integer *ldu, real *s, complex *vt, integer *
+ ldvt, complex *work, real *resid)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2, i__3, i__4,
+ i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j;
+ real eps;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *);
+ real bnorm;
+ extern doublereal slamch_(char *);
+ extern integer isamax_(integer *, real *, integer *);
+ extern doublereal scasum_(integer *, complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CBDT03 reconstructs a bidiagonal matrix B from its SVD: */
+/* S = U' * B * V */
+/* where U and V are orthogonal matrices and S is diagonal. */
+
+/* The test ratio to test the singular value decomposition is */
+/* RESID = norm( B - U * S * VT ) / ( n * norm(B) * EPS ) */
+/* where VT = V' and EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix B is upper or lower bidiagonal. */
+/* = 'U': Upper bidiagonal */
+/* = 'L': Lower bidiagonal */
+
+/* N (input) INTEGER */
+/* The order of the matrix B. */
+
+/* KD (input) INTEGER */
+/* The bandwidth of the bidiagonal matrix B. If KD = 1, the */
+/* matrix B is bidiagonal, and if KD = 0, B is diagonal and E is */
+/* not referenced. If KD is greater than 1, it is assumed to be */
+/* 1, and if KD is less than 0, it is assumed to be 0. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the bidiagonal matrix B. */
+
+/* E (input) REAL array, dimension (N-1) */
+/* The (n-1) superdiagonal elements of the bidiagonal matrix B */
+/* if UPLO = 'U', or the (n-1) subdiagonal elements of B if */
+/* UPLO = 'L'. */
+
+/* U (input) COMPLEX array, dimension (LDU,N) */
+/* The n by n orthogonal matrix U in the reduction B = U'*A*P. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,N) */
+
+/* S (input) REAL array, dimension (N) */
+/* The singular values from the SVD of B, sorted in decreasing */
+/* order. */
+
+/* VT (input) COMPLEX array, dimension (LDVT,N) */
+/* The n by n orthogonal matrix V' in the reduction */
+/* B = U * S * V'. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RESID (output) REAL */
+/* The test ratio: norm(B - U * S * V') / ( n * norm(A) * EPS ) */
+
+/* ====================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --s;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --work;
+
+ /* Function Body */
+ *resid = 0.f;
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Compute B - U * S * V' one column at a time. */
+
+ bnorm = 0.f;
+ if (*kd >= 1) {
+
+/* B is bidiagonal. */
+
+ if (lsame_(uplo, "U")) {
+
+/* B is upper bidiagonal. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = *n + i__;
+ i__4 = i__;
+ i__5 = i__ + j * vt_dim1;
+ q__1.r = s[i__4] * vt[i__5].r, q__1.i = s[i__4] * vt[i__5]
+ .i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L10: */
+ }
+ cgemv_("No transpose", n, n, &c_b6, &u[u_offset], ldu, &work[*
+ n + 1], &c__1, &c_b9, &work[1], &c__1);
+ i__2 = j;
+ i__3 = j;
+ i__4 = j;
+ q__1.r = work[i__3].r + d__[i__4], q__1.i = work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ if (j > 1) {
+ i__2 = j - 1;
+ i__3 = j - 1;
+ i__4 = j - 1;
+ q__1.r = work[i__3].r + e[i__4], q__1.i = work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* Computing MAX */
+ r__3 = bnorm, r__4 = (r__1 = d__[j], dabs(r__1)) + (r__2 =
+ e[j - 1], dabs(r__2));
+ bnorm = dmax(r__3,r__4);
+ } else {
+/* Computing MAX */
+ r__2 = bnorm, r__3 = (r__1 = d__[j], dabs(r__1));
+ bnorm = dmax(r__2,r__3);
+ }
+/* Computing MAX */
+ r__1 = *resid, r__2 = scasum_(n, &work[1], &c__1);
+ *resid = dmax(r__1,r__2);
+/* L20: */
+ }
+ } else {
+
+/* B is lower bidiagonal. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = *n + i__;
+ i__4 = i__;
+ i__5 = i__ + j * vt_dim1;
+ q__1.r = s[i__4] * vt[i__5].r, q__1.i = s[i__4] * vt[i__5]
+ .i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L30: */
+ }
+ cgemv_("No transpose", n, n, &c_b6, &u[u_offset], ldu, &work[*
+ n + 1], &c__1, &c_b9, &work[1], &c__1);
+ i__2 = j;
+ i__3 = j;
+ i__4 = j;
+ q__1.r = work[i__3].r + d__[i__4], q__1.i = work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ if (j < *n) {
+ i__2 = j + 1;
+ i__3 = j + 1;
+ i__4 = j;
+ q__1.r = work[i__3].r + e[i__4], q__1.i = work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* Computing MAX */
+ r__3 = bnorm, r__4 = (r__1 = d__[j], dabs(r__1)) + (r__2 =
+ e[j], dabs(r__2));
+ bnorm = dmax(r__3,r__4);
+ } else {
+/* Computing MAX */
+ r__2 = bnorm, r__3 = (r__1 = d__[j], dabs(r__1));
+ bnorm = dmax(r__2,r__3);
+ }
+/* Computing MAX */
+ r__1 = *resid, r__2 = scasum_(n, &work[1], &c__1);
+ *resid = dmax(r__1,r__2);
+/* L40: */
+ }
+ }
+ } else {
+
+/* B is diagonal. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = *n + i__;
+ i__4 = i__;
+ i__5 = i__ + j * vt_dim1;
+ q__1.r = s[i__4] * vt[i__5].r, q__1.i = s[i__4] * vt[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L50: */
+ }
+ cgemv_("No transpose", n, n, &c_b6, &u[u_offset], ldu, &work[*n +
+ 1], &c__1, &c_b9, &work[1], &c__1);
+ i__2 = j;
+ i__3 = j;
+ i__4 = j;
+ q__1.r = work[i__3].r + d__[i__4], q__1.i = work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* Computing MAX */
+ r__1 = *resid, r__2 = scasum_(n, &work[1], &c__1);
+ *resid = dmax(r__1,r__2);
+/* L60: */
+ }
+ j = isamax_(n, &d__[1], &c__1);
+ bnorm = (r__1 = d__[j], dabs(r__1));
+ }
+
+/* Compute norm(B - U * S * V') / ( n * norm(B) * EPS ) */
+
+ eps = slamch_("Precision");
+
+ if (bnorm <= 0.f) {
+ if (*resid != 0.f) {
+ *resid = 1.f / eps;
+ }
+ } else {
+ if (bnorm >= *resid) {
+ *resid = *resid / bnorm / ((real) (*n) * eps);
+ } else {
+ if (bnorm < 1.f) {
+/* Computing MIN */
+ r__1 = *resid, r__2 = (real) (*n) * bnorm;
+ *resid = dmin(r__1,r__2) / bnorm / ((real) (*n) * eps);
+ } else {
+/* Computing MIN */
+ r__1 = *resid / bnorm, r__2 = (real) (*n);
+ *resid = dmin(r__1,r__2) / ((real) (*n) * eps);
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CBDT03 */
+
+} /* cbdt03_ */
diff --git a/TESTING/EIG/cchkbb.c b/TESTING/EIG/cchkbb.c
new file mode 100644
index 0000000..5706ff4
--- /dev/null
+++ b/TESTING/EIG/cchkbb.c
@@ -0,0 +1,775 @@
+/* cchkbb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__0 = 0;
+static integer c__6 = 6;
+static real c_b33 = 1.f;
+static integer c__1 = 1;
+static real c_b41 = 0.f;
+static integer c__4 = 4;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cchkbb_(integer *nsizes, integer *mval, integer *nval,
+ integer *nwdths, integer *kk, integer *ntypes, logical *dotype,
+ integer *nrhs, integer *iseed, real *thresh, integer *nounit, complex
+ *a, integer *lda, complex *ab, integer *ldab, real *bd, real *be,
+ complex *q, integer *ldq, complex *p, integer *ldp, complex *c__,
+ integer *ldc, complex *cc, complex *work, integer *lwork, real *rwork,
+ real *result, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[15] = { 1,2,4,4,4,4,4,6,6,6,6,6,9,9,9 };
+ static integer kmagn[15] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3 };
+ static integer kmode[15] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 CCHKBB: \002,a,\002 returned INFO=\002,i"
+ "5,\002.\002,/9x,\002M=\002,i5,\002 N=\002,i5,\002 K=\002,i5,\002"
+ ", JTYPE=\002,i5,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 M =\002,i4,\002 N=\002,i4,\002, K=\002,i"
+ "3,\002, seed=\002,4(i4,\002,\002),\002 type \002,i2,\002, test"
+ "(\002,i2,\002)=\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, ab_dim1, ab_offset, c_dim1, c_offset, cc_dim1,
+ cc_offset, p_dim1, p_offset, q_dim1, q_offset, i__1, i__2, i__3,
+ i__4, i__5, i__6, i__7, i__8, i__9;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, m, n, kl, jr, ku;
+ real ulp, cond;
+ integer jcol, kmax, mmax, nmax;
+ real unfl, ovfl;
+ extern /* Subroutine */ int cbdt01_(integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, real *, real *,
+ complex *, integer *, complex *, real *, real *), cbdt02_(integer
+ *, integer *, complex *, integer *, complex *, integer *, complex
+ *, integer *, complex *, real *, real *);
+ logical badmm, badnn;
+ integer imode, iinfo;
+ extern /* Subroutine */ int cunt01_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, real *, real *);
+ real anorm;
+ integer mnmin, mnmax, nmats, jsize, nerrs, itype, jtype, ntest;
+ extern /* Subroutine */ int slahd2_(integer *, char *), cgbbrd_(
+ char *, integer *, integer *, integer *, integer *, integer *,
+ complex *, integer *, real *, real *, complex *, integer *,
+ complex *, integer *, complex *, integer *, complex *, real *,
+ integer *);
+ logical badnnb;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *);
+ integer idumma[1];
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int xerbla_(char *, integer *), clatmr_(
+ integer *, integer *, char *, integer *, char *, complex *,
+ integer *, real *, complex *, char *, char *, complex *, integer *
+, real *, complex *, integer *, real *, char *, integer *,
+ integer *, integer *, real *, real *, char *, complex *, integer *
+, integer *, integer *), clatms_(integer *, integer *, char *, integer *, char *,
+ real *, integer *, real *, real *, integer *, integer *, char *,
+ complex *, integer *, complex *, integer *);
+ real amninv;
+ integer jwidth;
+ extern /* Subroutine */ int slasum_(char *, integer *, integer *, integer
+ *);
+ real rtunfl, rtovfl, ulpinv;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (new routine for release 2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKBB tests the reduction of a general complex rectangular band */
+/* matrix to real bidiagonal form. */
+
+/* CGBBRD factors a general band matrix A as Q B P* , where * means */
+/* conjugate transpose, B is upper bidiagonal, and Q and P are unitary; */
+/* CGBBRD can also overwrite a given matrix C with Q* C . */
+
+/* For each pair of matrix dimensions (M,N) and each selected matrix */
+/* type, an M by N matrix A and an M by NRHS matrix C are generated. */
+/* The problem dimensions are as follows */
+/* A: M x N */
+/* Q: M x M */
+/* P: N x N */
+/* B: min(M,N) x min(M,N) */
+/* C: M x NRHS */
+
+/* For each generated matrix, 4 tests are performed: */
+
+/* (1) | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P' */
+
+/* (2) | I - Q' Q | / ( M ulp ) */
+
+/* (3) | I - PT PT' | / ( N ulp ) */
+
+/* (4) | Y - Q' C | / ( |Y| max(M,NRHS) ulp ), where Y = Q' C. */
+
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* The possible matrix types are */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (6) Same as (3), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (3), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) Rectangular matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of values of M and N contained in the vectors */
+/* MVAL and NVAL. The matrix sizes are used in pairs (M,N). */
+/* If NSIZES is zero, CCHKBB does nothing. NSIZES must be at */
+/* least zero. */
+
+/* MVAL (input) INTEGER array, dimension (NSIZES) */
+/* The values of the matrix row dimension M. */
+
+/* NVAL (input) INTEGER array, dimension (NSIZES) */
+/* The values of the matrix column dimension N. */
+
+/* NWDTHS (input) INTEGER */
+/* The number of bandwidths to use. If it is zero, */
+/* CCHKBB does nothing. It must be at least zero. */
+
+/* KK (input) INTEGER array, dimension (NWDTHS) */
+/* An array containing the bandwidths to be used for the band */
+/* matrices. The values must be at least zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, CCHKBB */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns in the "right-hand side" matrix C. */
+/* If NRHS = 0, then the operations on the right-hand side will */
+/* not be tested. NRHS must be at least 0. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to CCHKBB to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace) REAL array, dimension */
+/* (LDA, max(NN)) */
+/* Used to hold the matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* AB (workspace) REAL array, dimension (LDAB, max(NN)) */
+/* Used to hold A in band storage format. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of AB. It must be at least 2 (not 1!) */
+/* and at least max( KK )+1. */
+
+/* BD (workspace) REAL array, dimension (max(NN)) */
+/* Used to hold the diagonal of the bidiagonal matrix computed */
+/* by CGBBRD. */
+
+/* BE (workspace) REAL array, dimension (max(NN)) */
+/* Used to hold the off-diagonal of the bidiagonal matrix */
+/* computed by CGBBRD. */
+
+/* Q (workspace) COMPLEX array, dimension (LDQ, max(NN)) */
+/* Used to hold the unitary matrix Q computed by CGBBRD. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of Q. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* P (workspace) COMPLEX array, dimension (LDP, max(NN)) */
+/* Used to hold the unitary matrix P computed by CGBBRD. */
+
+/* LDP (input) INTEGER */
+/* The leading dimension of P. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* C (workspace) COMPLEX array, dimension (LDC, max(NN)) */
+/* Used to hold the matrix C updated by CGBBRD. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of U. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* CC (workspace) COMPLEX array, dimension (LDC, max(NN)) */
+/* Used to hold a copy of the matrix C. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* max( LDA+1, max(NN)+1 )*max(NN). */
+
+/* RWORK (workspace) REAL array, dimension (max(NN)) */
+
+/* RESULT (output) REAL array, dimension (4) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests performed, or which can */
+/* be performed so far, for the current matrix. */
+/* NTESTT The total number of tests performed so far. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far. */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --mval;
+ --nval;
+ --kk;
+ --dotype;
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --bd;
+ --be;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ p_dim1 = *ldp;
+ p_offset = 1 + p_dim1;
+ p -= p_offset;
+ cc_dim1 = *ldc;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badmm = FALSE_;
+ badnn = FALSE_;
+ mmax = 1;
+ nmax = 1;
+ mnmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = mmax, i__3 = mval[j];
+ mmax = max(i__2,i__3);
+ if (mval[j] < 0) {
+ badmm = TRUE_;
+ }
+/* Computing MAX */
+ i__2 = nmax, i__3 = nval[j];
+ nmax = max(i__2,i__3);
+ if (nval[j] < 0) {
+ badnn = TRUE_;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__4 = mval[j], i__5 = nval[j];
+ i__2 = mnmax, i__3 = min(i__4,i__5);
+ mnmax = max(i__2,i__3);
+/* L10: */
+ }
+
+ badnnb = FALSE_;
+ kmax = 0;
+ i__1 = *nwdths;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = kmax, i__3 = kk[j];
+ kmax = max(i__2,i__3);
+ if (kk[j] < 0) {
+ badnnb = TRUE_;
+ }
+/* L20: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badmm) {
+ *info = -2;
+ } else if (badnn) {
+ *info = -3;
+ } else if (*nwdths < 0) {
+ *info = -4;
+ } else if (badnnb) {
+ *info = -5;
+ } else if (*ntypes < 0) {
+ *info = -6;
+ } else if (*nrhs < 0) {
+ *info = -8;
+ } else if (*lda < nmax) {
+ *info = -13;
+ } else if (*ldab < (kmax << 1) + 1) {
+ *info = -15;
+ } else if (*ldq < nmax) {
+ *info = -19;
+ } else if (*ldp < nmax) {
+ *info = -21;
+ } else if (*ldc < nmax) {
+ *info = -23;
+ } else if ((max(*lda,nmax) + 1) * nmax > *lwork) {
+ *info = -26;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CCHKBB", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0 || *nwdths == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ ulpinv = 1.f / ulp;
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+
+/* Loop over sizes, widths, types */
+
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ m = mval[jsize];
+ n = nval[jsize];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__2 = max(1,m);
+ amninv = 1.f / (real) max(i__2,n);
+
+ i__2 = *nwdths;
+ for (jwidth = 1; jwidth <= i__2; ++jwidth) {
+ k = kk[jwidth];
+ if (k >= m && k >= n) {
+ goto L150;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__5 = m - 1;
+ i__3 = 0, i__4 = min(i__5,k);
+ kl = max(i__3,i__4);
+/* Computing MAX */
+/* Computing MIN */
+ i__5 = n - 1;
+ i__3 = 0, i__4 = min(i__5,k);
+ ku = max(i__3,i__4);
+
+ if (*nsizes != 1) {
+ mtypes = min(15,*ntypes);
+ } else {
+ mtypes = min(16,*ntypes);
+ }
+
+ i__3 = mtypes;
+ for (jtype = 1; jtype <= i__3; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L140;
+ }
+ ++nmats;
+ ntest = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L30: */
+ }
+
+/* Compute "A". */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, (w/ singular values) */
+/* =5 random log (none) */
+/* =6 random nonhermitian, w/ singular values */
+/* =7 (none) */
+/* =8 (none) */
+/* =9 random nonhermitian */
+
+ if (mtypes > 15) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.f;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * amninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * max(m,n) * ulpinv;
+ goto L70;
+
+L70:
+
+ claset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ claset_("Full", ldab, &n, &c_b1, &c_b1, &ab[ab_offset], ldab);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__4 = n;
+ for (jcol = 1; jcol <= i__4; ++jcol) {
+ i__5 = jcol + jcol * a_dim1;
+ a[i__5].r = anorm, a[i__5].i = 0.f;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, singular values specified */
+
+ clatms_(&m, &n, "S", &iseed[1], "N", &rwork[1], &imode, &
+ cond, &anorm, &c__0, &c__0, "N", &a[a_offset],
+ lda, &work[1], &iinfo);
+
+ } else if (itype == 6) {
+
+/* Nonhermitian, singular values specified */
+
+ clatms_(&m, &n, "S", &iseed[1], "N", &rwork[1], &imode, &
+ cond, &anorm, &kl, &ku, "N", &a[a_offset], lda, &
+ work[1], &iinfo);
+
+ } else if (itype == 9) {
+
+/* Nonhermitian, random entries */
+
+ clatmr_(&m, &n, "S", &iseed[1], "N", &work[1], &c__6, &
+ c_b33, &c_b2, "T", "N", &work[n + 1], &c__1, &
+ c_b33, &work[(n << 1) + 1], &c__1, &c_b33, "N",
+ idumma, &kl, &ku, &c_b41, &anorm, "N", &a[
+ a_offset], lda, idumma, &iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+/* Generate Right-Hand Side */
+
+ clatmr_(&m, nrhs, "S", &iseed[1], "N", &work[1], &c__6, &
+ c_b33, &c_b2, "T", "N", &work[m + 1], &c__1, &c_b33, &
+ work[(m << 1) + 1], &c__1, &c_b33, "N", idumma, &m,
+ nrhs, &c_b41, &c_b33, "NO", &c__[c_offset], ldc,
+ idumma, &iinfo);
+
+ if (iinfo != 0) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+/* Copy A to band storage. */
+
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__6 = j - ku;
+/* Computing MIN */
+ i__8 = m, i__9 = j + kl;
+ i__7 = min(i__8,i__9);
+ for (i__ = max(i__5,i__6); i__ <= i__7; ++i__) {
+ i__5 = ku + 1 + i__ - j + j * ab_dim1;
+ i__6 = i__ + j * a_dim1;
+ ab[i__5].r = a[i__6].r, ab[i__5].i = a[i__6].i;
+/* L100: */
+ }
+/* L110: */
+ }
+
+/* Copy C */
+
+ clacpy_("Full", &m, nrhs, &c__[c_offset], ldc, &cc[cc_offset],
+ ldc);
+
+/* Call CGBBRD to compute B, Q and P, and to update C. */
+
+ cgbbrd_("B", &m, &n, nrhs, &kl, &ku, &ab[ab_offset], ldab, &
+ bd[1], &be[1], &q[q_offset], ldq, &p[p_offset], ldp, &
+ cc[cc_offset], ldc, &work[1], &rwork[1], &iinfo);
+
+ if (iinfo != 0) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "CGBBRD", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[1] = ulpinv;
+ goto L120;
+ }
+ }
+
+/* Test 1: Check the decomposition A := Q * B * P' */
+/* 2: Check the orthogonality of Q */
+/* 3: Check the orthogonality of P */
+/* 4: Check the computation of Q' * C */
+
+ cbdt01_(&m, &n, &c_n1, &a[a_offset], lda, &q[q_offset], ldq, &
+ bd[1], &be[1], &p[p_offset], ldp, &work[1], &rwork[1],
+ &result[1]);
+ cunt01_("Columns", &m, &m, &q[q_offset], ldq, &work[1], lwork,
+ &rwork[1], &result[2]);
+ cunt01_("Rows", &n, &n, &p[p_offset], ldp, &work[1], lwork, &
+ rwork[1], &result[3]);
+ cbdt02_(&m, nrhs, &c__[c_offset], ldc, &cc[cc_offset], ldc, &
+ q[q_offset], ldq, &work[1], &rwork[1], &result[4]);
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+ ntest = 4;
+L120:
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__4 = ntest;
+ for (jr = 1; jr <= i__4; ++jr) {
+ if (result[jr] >= *thresh) {
+ if (nerrs == 0) {
+ slahd2_(nounit, "CBB");
+ }
+ ++nerrs;
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ }
+/* L130: */
+ }
+
+L140:
+ ;
+ }
+L150:
+ ;
+ }
+/* L160: */
+ }
+
+/* Summary */
+
+ slasum_("CBB", nounit, &nerrs, &ntestt);
+ return 0;
+
+
+/* End of CCHKBB */
+
+} /* cchkbb_ */
diff --git a/TESTING/EIG/cchkbd.c b/TESTING/EIG/cchkbd.c
new file mode 100644
index 0000000..6754e84
--- /dev/null
+++ b/TESTING/EIG/cchkbd.c
@@ -0,0 +1,1123 @@
+/* cchkbd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__0 = 0;
+static integer c__6 = 6;
+static real c_b37 = 1.f;
+static integer c__1 = 1;
+static real c_b47 = 0.f;
+static integer c__2 = 2;
+static integer c__4 = 4;
+
+/* Subroutine */ int cchkbd_(integer *nsizes, integer *mval, integer *nval,
+ integer *ntypes, logical *dotype, integer *nrhs, integer *iseed, real
+ *thresh, complex *a, integer *lda, real *bd, real *be, real *s1, real
+ *s2, complex *x, integer *ldx, complex *y, complex *z__, complex *q,
+ integer *ldq, complex *pt, integer *ldpt, complex *u, complex *vt,
+ complex *work, integer *lwork, real *rwork, integer *nout, integer *
+ info)
+{
+ /* Initialized data */
+
+ static integer ktype[16] = { 1,2,4,4,4,4,4,6,6,6,6,6,9,9,9,10 };
+ static integer kmagn[16] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3,0 };
+ static integer kmode[16] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9998[] = "(\002 CCHKBD: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002M=\002,i6,\002, N=\002,i6,\002, JTYPE=\002,i"
+ "6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, type "
+ "\002,i2,\002, seed=\002,4(i4,\002,\002),\002 test(\002,i2,\002)"
+ "=\002,g11.4)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, pt_dim1, pt_offset, q_dim1, q_offset, u_dim1,
+ u_offset, vt_dim1, vt_offset, x_dim1, x_offset, y_dim1, y_offset,
+ z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+ real r__1, r__2, r__3, r__4, r__5, r__6, r__7;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double log(doublereal), sqrt(doublereal), exp(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, m, n, mq;
+ real ulp, cond;
+ integer jcol;
+ char path[3];
+ integer mmax, nmax;
+ real unfl, ovfl;
+ char uplo[1];
+ real temp1, temp2;
+ extern /* Subroutine */ int cbdt01_(integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, real *, real *,
+ complex *, integer *, complex *, real *, real *), cbdt02_(integer
+ *, integer *, complex *, integer *, complex *, integer *, complex
+ *, integer *, complex *, real *, real *), cbdt03_(char *, integer
+ *, integer *, real *, real *, complex *, integer *, real *,
+ complex *, integer *, complex *, real *);
+ logical badmm, badnn;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ integer nfail, imode;
+ real dumma[1];
+ integer iinfo;
+ extern /* Subroutine */ int cunt01_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, real *, real *);
+ real anorm;
+ integer mnmin, mnmax, jsize, itype, jtype, iwork[1], ntest;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), slahd2_(integer *, char *);
+ integer log2ui;
+ logical bidiag;
+ extern /* Subroutine */ int cgebrd_(integer *, integer *, complex *,
+ integer *, real *, real *, complex *, complex *, complex *,
+ integer *, integer *), slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), xerbla_(char *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int cbdsqr_(char *, integer *, integer *, integer
+ *, integer *, real *, real *, complex *, integer *, complex *,
+ integer *, complex *, integer *, real *, integer *),
+ cungbr_(char *, integer *, integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *),
+ alasum_(char *, integer *, integer *, integer *, integer *);
+ extern doublereal slarnd_(integer *, integer *);
+ extern /* Subroutine */ int clatmr_(integer *, integer *, char *, integer
+ *, char *, complex *, integer *, real *, complex *, char *, char *
+, complex *, integer *, real *, complex *, integer *, real *,
+ char *, integer *, integer *, integer *, real *, real *, char *,
+ complex *, integer *, integer *, integer *), clatms_(integer *, integer *,
+ char *, integer *, char *, real *, integer *, real *, real *,
+ integer *, integer *, char *, complex *, integer *, complex *,
+ integer *);
+ real amninv;
+ extern /* Subroutine */ int ssvdch_(integer *, real *, real *, real *,
+ real *, integer *);
+ integer minwrk;
+ real rtunfl, rtovfl, ulpinv, result[14];
+ integer mtypes;
+
+ /* Fortran I/O blocks */
+ static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKBD checks the singular value decomposition (SVD) routines. */
+
+/* CGEBRD reduces a complex general m by n matrix A to real upper or */
+/* lower bidiagonal form by an orthogonal transformation: Q' * A * P = B */
+/* (or A = Q * B * P'). The matrix B is upper bidiagonal if m >= n */
+/* and lower bidiagonal if m < n. */
+
+/* CUNGBR generates the orthogonal matrices Q and P' from CGEBRD. */
+/* Note that Q and P are not necessarily square. */
+
+/* CBDSQR computes the singular value decomposition of the bidiagonal */
+/* matrix B as B = U S V'. It is called three times to compute */
+/* 1) B = U S1 V', where S1 is the diagonal matrix of singular */
+/* values and the columns of the matrices U and V are the left */
+/* and right singular vectors, respectively, of B. */
+/* 2) Same as 1), but the singular values are stored in S2 and the */
+/* singular vectors are not computed. */
+/* 3) A = (UQ) S (P'V'), the SVD of the original matrix A. */
+/* In addition, CBDSQR has an option to apply the left orthogonal matrix */
+/* U to a matrix X, useful in least squares applications. */
+
+/* For each pair of matrix dimensions (M,N) and each selected matrix */
+/* type, an M by N matrix A and an M by NRHS matrix X are generated. */
+/* The problem dimensions are as follows */
+/* A: M x N */
+/* Q: M x min(M,N) (but M x M if NRHS > 0) */
+/* P: min(M,N) x N */
+/* B: min(M,N) x min(M,N) */
+/* U, V: min(M,N) x min(M,N) */
+/* S1, S2 diagonal, order min(M,N) */
+/* X: M x NRHS */
+
+/* For each generated matrix, 14 tests are performed: */
+
+/* Test CGEBRD and CUNGBR */
+
+/* (1) | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P' */
+
+/* (2) | I - Q' Q | / ( M ulp ) */
+
+/* (3) | I - PT PT' | / ( N ulp ) */
+
+/* Test CBDSQR on bidiagonal matrix B */
+
+/* (4) | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V' */
+
+/* (5) | Y - U Z | / ( |Y| max(min(M,N),k) ulp ), where Y = Q' X */
+/* and Z = U' Y. */
+/* (6) | I - U' U | / ( min(M,N) ulp ) */
+
+/* (7) | I - VT VT' | / ( min(M,N) ulp ) */
+
+/* (8) S1 contains min(M,N) nonnegative values in decreasing order. */
+/* (Return 0 if true, 1/ULP if false.) */
+
+/* (9) 0 if the true singular values of B are within THRESH of */
+/* those in S1. 2*THRESH if they are not. (Tested using */
+/* SSVDCH) */
+
+/* (10) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without */
+/* computing U and V. */
+
+/* Test CBDSQR on matrix A */
+
+/* (11) | A - (QU) S (VT PT) | / ( |A| max(M,N) ulp ) */
+
+/* (12) | X - (QU) Z | / ( |X| max(M,k) ulp ) */
+
+/* (13) | I - (QU)'(QU) | / ( M ulp ) */
+
+/* (14) | I - (VT PT) (PT'VT') | / ( N ulp ) */
+
+/* The possible matrix types are */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (6) Same as (3), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (3), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) Rectangular matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
+
+/* Special case: */
+/* (16) A bidiagonal matrix with random entries chosen from a */
+/* logarithmic distribution on [ulp^2,ulp^(-2)] (I.e., each */
+/* entry is e^x, where x is chosen uniformly on */
+/* [ 2 log(ulp), -2 log(ulp) ] .) For *this* type: */
+/* (a) CGEBRD is not called to reduce it to bidiagonal form. */
+/* (b) the bidiagonal is min(M,N) x min(M,N); if M<N, the */
+/* matrix will be lower bidiagonal, otherwise upper. */
+/* (c) only tests 5--8 and 14 are performed. */
+
+/* A subset of the full set of matrix types may be selected through */
+/* the logical array DOTYPE. */
+
+/* Arguments */
+/* ========== */
+
+/* NSIZES (input) INTEGER */
+/* The number of values of M and N contained in the vectors */
+/* MVAL and NVAL. The matrix sizes are used in pairs (M,N). */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix column dimension N. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, CCHKBD */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrices are in A and B. */
+/* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size (m,n), a matrix */
+/* of type j will be generated. If NTYPES is smaller than the */
+/* maximum number of types defined (PARAMETER MAXTYP), then */
+/* types NTYPES+1 through MAXTYP will not be generated. If */
+/* NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through */
+/* DOTYPE(NTYPES) will be ignored. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns in the "right-hand side" matrices X, Y, */
+/* and Z, used in testing CBDSQR. If NRHS = 0, then the */
+/* operations on the right-hand side will not be tested. */
+/* NRHS must be at least 0. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The values of ISEED are changed on exit, and can be */
+/* used in the next call to CCHKBD to continue the same random */
+/* number sequence. */
+
+/* THRESH (input) 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. Note that the */
+/* expected value of the test ratios is O(1), so THRESH should */
+/* be a reasonably small multiple of 1, e.g., 10 or 100. */
+
+/* A (workspace) COMPLEX array, dimension (LDA,NMAX) */
+/* where NMAX is the maximum value of N in NVAL. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,MMAX), */
+/* where MMAX is the maximum value of M in MVAL. */
+
+/* BD (workspace) REAL array, dimension */
+/* (max(min(MVAL(j),NVAL(j)))) */
+
+/* BE (workspace) REAL array, dimension */
+/* (max(min(MVAL(j),NVAL(j)))) */
+
+/* S1 (workspace) REAL array, dimension */
+/* (max(min(MVAL(j),NVAL(j)))) */
+
+/* S2 (workspace) REAL array, dimension */
+/* (max(min(MVAL(j),NVAL(j)))) */
+
+/* X (workspace) COMPLEX array, dimension (LDX,NRHS) */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the arrays X, Y, and Z. */
+/* LDX >= max(1,MMAX). */
+
+/* Y (workspace) COMPLEX array, dimension (LDX,NRHS) */
+
+/* Z (workspace) COMPLEX array, dimension (LDX,NRHS) */
+
+/* Q (workspace) COMPLEX array, dimension (LDQ,MMAX) */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,MMAX). */
+
+/* PT (workspace) COMPLEX array, dimension (LDPT,NMAX) */
+
+/* LDPT (input) INTEGER */
+/* The leading dimension of the arrays PT, U, and V. */
+/* LDPT >= max(1, max(min(MVAL(j),NVAL(j)))). */
+
+/* U (workspace) COMPLEX array, dimension */
+/* (LDPT,max(min(MVAL(j),NVAL(j)))) */
+
+/* V (workspace) COMPLEX array, dimension */
+/* (LDPT,max(min(MVAL(j),NVAL(j)))) */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 3(M+N) and M(M + max(M,N,k) + 1) + N*min(M,N) for all */
+/* pairs (M,N)=(MM(j),NN(j)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (5*max(min(M,N))) */
+
+/* NOUT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some MM(j) < 0 */
+/* -3: Some NN(j) < 0 */
+/* -4: NTYPES < 0 */
+/* -6: NRHS < 0 */
+/* -8: THRESH < 0 */
+/* -11: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ). */
+/* -17: LDB < 1 or LDB < MMAX. */
+/* -21: LDQ < 1 or LDQ < MMAX. */
+/* -23: LDP < 1 or LDP < MNMAX. */
+/* -27: LWORK too small. */
+/* If CLATMR, CLATMS, CGEBRD, CUNGBR, or CBDSQR, */
+/* returns an error code, the */
+/* absolute value of it is returned. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests performed, or which can */
+/* be performed so far, for the current matrix. */
+/* MMAX Largest value in NN. */
+/* NMAX Largest value in NN. */
+/* MNMIN min(MM(j), NN(j)) (the dimension of the bidiagonal */
+/* matrix.) */
+/* MNMAX The maximum value of MNMIN for j=1,...,NSIZES. */
+/* NFAIL The number of tests which have exceeded THRESH */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* ====================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --mval;
+ --nval;
+ --dotype;
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --bd;
+ --be;
+ --s1;
+ --s2;
+ z_dim1 = *ldx;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ y_dim1 = *ldx;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ vt_dim1 = *ldpt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ u_dim1 = *ldpt;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ pt_dim1 = *ldpt;
+ pt_offset = 1 + pt_dim1;
+ pt -= pt_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+
+ badmm = FALSE_;
+ badnn = FALSE_;
+ mmax = 1;
+ nmax = 1;
+ mnmax = 1;
+ minwrk = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = mmax, i__3 = mval[j];
+ mmax = max(i__2,i__3);
+ if (mval[j] < 0) {
+ badmm = TRUE_;
+ }
+/* Computing MAX */
+ i__2 = nmax, i__3 = nval[j];
+ nmax = max(i__2,i__3);
+ if (nval[j] < 0) {
+ badnn = TRUE_;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__4 = mval[j], i__5 = nval[j];
+ i__2 = mnmax, i__3 = min(i__4,i__5);
+ mnmax = max(i__2,i__3);
+/* Computing MAX */
+/* Computing MAX */
+ i__4 = mval[j], i__5 = nval[j], i__4 = max(i__4,i__5);
+/* Computing MIN */
+ i__6 = nval[j], i__7 = mval[j];
+ i__2 = minwrk, i__3 = (mval[j] + nval[j]) * 3, i__2 = max(i__2,i__3),
+ i__3 = mval[j] * (mval[j] + max(i__4,*nrhs) + 1) + nval[j] *
+ min(i__6,i__7);
+ minwrk = max(i__2,i__3);
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badmm) {
+ *info = -2;
+ } else if (badnn) {
+ *info = -3;
+ } else if (*ntypes < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*lda < mmax) {
+ *info = -11;
+ } else if (*ldx < mmax) {
+ *info = -17;
+ } else if (*ldq < mmax) {
+ *info = -21;
+ } else if (*ldpt < mnmax) {
+ *info = -23;
+ } else if (minwrk > *lwork) {
+ *info = -27;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CCHKBD", &i__1);
+ return 0;
+ }
+
+/* Initialize constants */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "BD", (ftnlen)2, (ftnlen)2);
+ nfail = 0;
+ ntest = 0;
+ unfl = slamch_("Safe minimum");
+ ovfl = slamch_("Overflow");
+ slabad_(&unfl, &ovfl);
+ ulp = slamch_("Precision");
+ ulpinv = 1.f / ulp;
+ log2ui = (integer) (log(ulpinv) / log(2.f));
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+ infoc_1.infot = 0;
+
+/* Loop over sizes, types */
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ m = mval[jsize];
+ n = nval[jsize];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__2 = max(m,n);
+ amninv = 1.f / max(i__2,1);
+
+ if (*nsizes != 1) {
+ mtypes = min(16,*ntypes);
+ } else {
+ mtypes = min(17,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L170;
+ }
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+ for (j = 1; j <= 14; ++j) {
+ result[j - 1] = -1.f;
+/* L30: */
+ }
+
+ *(unsigned char *)uplo = ' ';
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random symmetric, w/ eigenvalues */
+/* =6 nonsymmetric, w/ singular values */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 random nonsymmetric */
+/* =10 random bidiagonal (log. distrib.) */
+
+ if (mtypes > 16) {
+ goto L100;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.f;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * amninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * max(m,n) * ulpinv;
+ goto L70;
+
+L70:
+
+ claset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+ bidiag = FALSE_;
+ if (itype == 1) {
+
+/* Zero matrix */
+
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = mnmin;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ a[i__4].r = anorm, a[i__4].i = 0.f;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ clatms_(&mnmin, &mnmin, "S", &iseed[1], "N", &rwork[1], &
+ imode, &cond, &anorm, &c__0, &c__0, "N", &a[a_offset],
+ lda, &work[1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ clatms_(&mnmin, &mnmin, "S", &iseed[1], "S", &rwork[1], &
+ imode, &cond, &anorm, &m, &n, "N", &a[a_offset], lda,
+ &work[1], &iinfo);
+
+ } else if (itype == 6) {
+
+/* Nonsymmetric, singular values specified */
+
+ clatms_(&m, &n, "S", &iseed[1], "N", &rwork[1], &imode, &cond,
+ &anorm, &m, &n, "N", &a[a_offset], lda, &work[1], &
+ iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random entries */
+
+ clatmr_(&mnmin, &mnmin, "S", &iseed[1], "N", &work[1], &c__6,
+ &c_b37, &c_b2, "T", "N", &work[mnmin + 1], &c__1, &
+ c_b37, &work[(mnmin << 1) + 1], &c__1, &c_b37, "N",
+ iwork, &c__0, &c__0, &c_b47, &anorm, "NO", &a[
+ a_offset], lda, iwork, &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random entries */
+
+ clatmr_(&mnmin, &mnmin, "S", &iseed[1], "S", &work[1], &c__6,
+ &c_b37, &c_b2, "T", "N", &work[mnmin + 1], &c__1, &
+ c_b37, &work[m + mnmin + 1], &c__1, &c_b37, "N",
+ iwork, &m, &n, &c_b47, &anorm, "NO", &a[a_offset],
+ lda, iwork, &iinfo);
+
+ } else if (itype == 9) {
+
+/* Nonsymmetric, random entries */
+
+ clatmr_(&m, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b37,
+ &c_b2, "T", "N", &work[mnmin + 1], &c__1, &c_b37, &
+ work[m + mnmin + 1], &c__1, &c_b37, "N", iwork, &m, &
+ n, &c_b47, &anorm, "NO", &a[a_offset], lda, iwork, &
+ iinfo);
+
+ } else if (itype == 10) {
+
+/* Bidiagonal, random entries */
+
+ temp1 = log(ulp) * -2.f;
+ i__3 = mnmin;
+ for (j = 1; j <= i__3; ++j) {
+ bd[j] = exp(temp1 * slarnd_(&c__2, &iseed[1]));
+ if (j < mnmin) {
+ be[j] = exp(temp1 * slarnd_(&c__2, &iseed[1]));
+ }
+/* L90: */
+ }
+
+ iinfo = 0;
+ bidiag = TRUE_;
+ if (m >= n) {
+ *(unsigned char *)uplo = 'U';
+ } else {
+ *(unsigned char *)uplo = 'L';
+ }
+ } else {
+ iinfo = 1;
+ }
+
+ if (iinfo == 0) {
+
+/* Generate Right-Hand Side */
+
+ if (bidiag) {
+ clatmr_(&mnmin, nrhs, "S", &iseed[1], "N", &work[1], &
+ c__6, &c_b37, &c_b2, "T", "N", &work[mnmin + 1], &
+ c__1, &c_b37, &work[(mnmin << 1) + 1], &c__1, &
+ c_b37, "N", iwork, &mnmin, nrhs, &c_b47, &c_b37,
+ "NO", &y[y_offset], ldx, iwork, &iinfo);
+ } else {
+ clatmr_(&m, nrhs, "S", &iseed[1], "N", &work[1], &c__6, &
+ c_b37, &c_b2, "T", "N", &work[m + 1], &c__1, &
+ c_b37, &work[(m << 1) + 1], &c__1, &c_b37, "N",
+ iwork, &m, nrhs, &c_b47, &c_b37, "NO", &x[
+ x_offset], ldx, iwork, &iinfo);
+ }
+ }
+
+/* Error Exit */
+
+ if (iinfo != 0) {
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L100:
+
+/* Call CGEBRD and CUNGBR to compute B, Q, and P, do tests. */
+
+ if (! bidiag) {
+
+/* Compute transformations to reduce A to bidiagonal form: */
+/* B := Q' * A * P. */
+
+ clacpy_(" ", &m, &n, &a[a_offset], lda, &q[q_offset], ldq);
+ i__3 = *lwork - (mnmin << 1);
+ cgebrd_(&m, &n, &q[q_offset], ldq, &bd[1], &be[1], &work[1], &
+ work[mnmin + 1], &work[(mnmin << 1) + 1], &i__3, &
+ iinfo);
+
+/* Check error code from CGEBRD. */
+
+ if (iinfo != 0) {
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "CGEBRD", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+ clacpy_(" ", &m, &n, &q[q_offset], ldq, &pt[pt_offset], ldpt);
+ if (m >= n) {
+ *(unsigned char *)uplo = 'U';
+ } else {
+ *(unsigned char *)uplo = 'L';
+ }
+
+/* Generate Q */
+
+ mq = m;
+ if (*nrhs <= 0) {
+ mq = mnmin;
+ }
+ i__3 = *lwork - (mnmin << 1);
+ cungbr_("Q", &m, &mq, &n, &q[q_offset], ldq, &work[1], &work[(
+ mnmin << 1) + 1], &i__3, &iinfo);
+
+/* Check error code from CUNGBR. */
+
+ if (iinfo != 0) {
+ io___43.ciunit = *nout;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "CUNGBR(Q)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Generate P' */
+
+ i__3 = *lwork - (mnmin << 1);
+ cungbr_("P", &mnmin, &n, &m, &pt[pt_offset], ldpt, &work[
+ mnmin + 1], &work[(mnmin << 1) + 1], &i__3, &iinfo);
+
+/* Check error code from CUNGBR. */
+
+ if (iinfo != 0) {
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "CUNGBR(P)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Apply Q' to an M by NRHS matrix X: Y := Q' * X. */
+
+ cgemm_("Conjugate transpose", "No transpose", &m, nrhs, &m, &
+ c_b2, &q[q_offset], ldq, &x[x_offset], ldx, &c_b1, &y[
+ y_offset], ldx);
+
+/* Test 1: Check the decomposition A := Q * B * PT */
+/* 2: Check the orthogonality of Q */
+/* 3: Check the orthogonality of PT */
+
+ cbdt01_(&m, &n, &c__1, &a[a_offset], lda, &q[q_offset], ldq, &
+ bd[1], &be[1], &pt[pt_offset], ldpt, &work[1], &rwork[
+ 1], result);
+ cunt01_("Columns", &m, &mq, &q[q_offset], ldq, &work[1],
+ lwork, &rwork[1], &result[1]);
+ cunt01_("Rows", &mnmin, &n, &pt[pt_offset], ldpt, &work[1],
+ lwork, &rwork[1], &result[2]);
+ }
+
+/* Use CBDSQR to form the SVD of the bidiagonal matrix B: */
+/* B := U * S1 * VT, and compute Z = U' * Y. */
+
+ scopy_(&mnmin, &bd[1], &c__1, &s1[1], &c__1);
+ if (mnmin > 0) {
+ i__3 = mnmin - 1;
+ scopy_(&i__3, &be[1], &c__1, &rwork[1], &c__1);
+ }
+ clacpy_(" ", &m, nrhs, &y[y_offset], ldx, &z__[z_offset], ldx);
+ claset_("Full", &mnmin, &mnmin, &c_b1, &c_b2, &u[u_offset], ldpt);
+ claset_("Full", &mnmin, &mnmin, &c_b1, &c_b2, &vt[vt_offset],
+ ldpt);
+
+ cbdsqr_(uplo, &mnmin, &mnmin, &mnmin, nrhs, &s1[1], &rwork[1], &
+ vt[vt_offset], ldpt, &u[u_offset], ldpt, &z__[z_offset],
+ ldx, &rwork[mnmin + 1], &iinfo);
+
+/* Check error code from CBDSQR. */
+
+ if (iinfo != 0) {
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "CBDSQR(vects)", (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[3] = ulpinv;
+ goto L150;
+ }
+ }
+
+/* Use CBDSQR to compute only the singular values of the */
+/* bidiagonal matrix B; U, VT, and Z should not be modified. */
+
+ scopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
+ if (mnmin > 0) {
+ i__3 = mnmin - 1;
+ scopy_(&i__3, &be[1], &c__1, &rwork[1], &c__1);
+ }
+
+ cbdsqr_(uplo, &mnmin, &c__0, &c__0, &c__0, &s2[1], &rwork[1], &vt[
+ vt_offset], ldpt, &u[u_offset], ldpt, &z__[z_offset], ldx,
+ &rwork[mnmin + 1], &iinfo);
+
+/* Check error code from CBDSQR. */
+
+ if (iinfo != 0) {
+ io___46.ciunit = *nout;
+ s_wsfe(&io___46);
+ do_fio(&c__1, "CBDSQR(values)", (ftnlen)14);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[8] = ulpinv;
+ goto L150;
+ }
+ }
+
+/* Test 4: Check the decomposition B := U * S1 * VT */
+/* 5: Check the computation Z := U' * Y */
+/* 6: Check the orthogonality of U */
+/* 7: Check the orthogonality of VT */
+
+ cbdt03_(uplo, &mnmin, &c__1, &bd[1], &be[1], &u[u_offset], ldpt, &
+ s1[1], &vt[vt_offset], ldpt, &work[1], &result[3]);
+ cbdt02_(&mnmin, nrhs, &y[y_offset], ldx, &z__[z_offset], ldx, &u[
+ u_offset], ldpt, &work[1], &rwork[1], &result[4]);
+ cunt01_("Columns", &mnmin, &mnmin, &u[u_offset], ldpt, &work[1],
+ lwork, &rwork[1], &result[5]);
+ cunt01_("Rows", &mnmin, &mnmin, &vt[vt_offset], ldpt, &work[1],
+ lwork, &rwork[1], &result[6]);
+
+/* Test 8: Check that the singular values are sorted in */
+/* non-increasing order and are non-negative */
+
+ result[7] = 0.f;
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (s1[i__] < s1[i__ + 1]) {
+ result[7] = ulpinv;
+ }
+ if (s1[i__] < 0.f) {
+ result[7] = ulpinv;
+ }
+/* L110: */
+ }
+ if (mnmin >= 1) {
+ if (s1[mnmin] < 0.f) {
+ result[7] = ulpinv;
+ }
+ }
+
+/* Test 9: Compare CBDSQR with and without singular vectors */
+
+ temp2 = 0.f;
+
+ i__3 = mnmin;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+/* Computing MAX */
+ r__6 = (r__1 = s1[j], dabs(r__1)), r__7 = (r__2 = s2[j], dabs(
+ r__2));
+ r__4 = sqrt(unfl) * dmax(s1[1],1.f), r__5 = ulp * dmax(r__6,
+ r__7);
+ temp1 = (r__3 = s1[j] - s2[j], dabs(r__3)) / dmax(r__4,r__5);
+ temp2 = dmax(temp1,temp2);
+/* L120: */
+ }
+
+ result[8] = temp2;
+
+/* Test 10: Sturm sequence test of singular values */
+/* Go up by factors of two until it succeeds */
+
+ temp1 = *thresh * (.5f - ulp);
+
+ i__3 = log2ui;
+ for (j = 0; j <= i__3; ++j) {
+ ssvdch_(&mnmin, &bd[1], &be[1], &s1[1], &temp1, &iinfo);
+ if (iinfo == 0) {
+ goto L140;
+ }
+ temp1 *= 2.f;
+/* L130: */
+ }
+
+L140:
+ result[9] = temp1;
+
+/* Use CBDSQR to form the decomposition A := (QU) S (VT PT) */
+/* from the bidiagonal form A := Q B PT. */
+
+ if (! bidiag) {
+ scopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
+ if (mnmin > 0) {
+ i__3 = mnmin - 1;
+ scopy_(&i__3, &be[1], &c__1, &rwork[1], &c__1);
+ }
+
+ cbdsqr_(uplo, &mnmin, &n, &m, nrhs, &s2[1], &rwork[1], &pt[
+ pt_offset], ldpt, &q[q_offset], ldq, &y[y_offset],
+ ldx, &rwork[mnmin + 1], &iinfo);
+
+/* Test 11: Check the decomposition A := Q*U * S2 * VT*PT */
+/* 12: Check the computation Z := U' * Q' * X */
+/* 13: Check the orthogonality of Q*U */
+/* 14: Check the orthogonality of VT*PT */
+
+ cbdt01_(&m, &n, &c__0, &a[a_offset], lda, &q[q_offset], ldq, &
+ s2[1], dumma, &pt[pt_offset], ldpt, &work[1], &rwork[
+ 1], &result[10]);
+ cbdt02_(&m, nrhs, &x[x_offset], ldx, &y[y_offset], ldx, &q[
+ q_offset], ldq, &work[1], &rwork[1], &result[11]);
+ cunt01_("Columns", &m, &mq, &q[q_offset], ldq, &work[1],
+ lwork, &rwork[1], &result[12]);
+ cunt01_("Rows", &mnmin, &n, &pt[pt_offset], ldpt, &work[1],
+ lwork, &rwork[1], &result[13]);
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L150:
+ for (j = 1; j <= 14; ++j) {
+ if (result[j - 1] >= *thresh) {
+ if (nfail == 0) {
+ slahd2_(nout, path);
+ }
+ io___50.ciunit = *nout;
+ s_wsfe(&io___50);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ ++nfail;
+ }
+/* L160: */
+ }
+ if (! bidiag) {
+ ntest += 14;
+ } else {
+ ntest += 5;
+ }
+
+L170:
+ ;
+ }
+/* L180: */
+ }
+
+/* Summary */
+
+ alasum_(path, nout, &nfail, &ntest, &c__0);
+
+ return 0;
+
+/* End of CCHKBD */
+
+
+} /* cchkbd_ */
diff --git a/TESTING/EIG/cchkbk.c b/TESTING/EIG/cchkbk.c
new file mode 100644
index 0000000..b4c088b
--- /dev/null
+++ b/TESTING/EIG/cchkbk.c
@@ -0,0 +1,247 @@
+/* cchkbk.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c__6 = 6;
+static integer c__20 = 20;
+
+/* Subroutine */ int cchkbk_(integer *nin, integer *nout)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002.. test output of CGEBAK .. \002)";
+ static char fmt_9998[] = "(1x,\002value of largest test error "
+ " = \002,e12.3)";
+ static char fmt_9997[] = "(1x,\002example number where info is not zero "
+ " = \002,i4)";
+ static char fmt_9996[] = "(1x,\002example number having largest error "
+ " = \002,i4)";
+ static char fmt_9995[] = "(1x,\002number of examples where info is not 0"
+ " = \002,i4)";
+ static char fmt_9994[] = "(1x,\002total number of examples tested "
+ " = \002,i4)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+ double r_imag(complex *);
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ complex e[400] /* was [20][20] */;
+ integer i__, j, n;
+ real x;
+ integer ihi;
+ complex ein[400] /* was [20][20] */;
+ integer ilo;
+ real eps;
+ integer knt, info, lmax[2];
+ real rmax, vmax, scale[20];
+ integer ninfo;
+ extern /* Subroutine */ int cgebak_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+
+ /* Fortran I/O blocks */
+ static cilist io___7 = { 0, 0, 0, 0, 0 };
+ static cilist io___11 = { 0, 0, 0, 0, 0 };
+ static cilist io___14 = { 0, 0, 0, 0, 0 };
+ static cilist io___17 = { 0, 0, 0, 0, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___26 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKBK tests CGEBAK, a routine for backward transformation of */
+/* the computed right or left eigenvectors if the orginal matrix */
+/* was preprocessed by balance subroutine CGEBAL. */
+
+/* Arguments */
+/* ========= */
+
+/* NIN (input) INTEGER */
+/* The logical unit number for input. NIN > 0. */
+
+/* NOUT (input) INTEGER */
+/* The logical unit number for output. NOUT > 0. */
+
+/* ====================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ lmax[0] = 0;
+ lmax[1] = 0;
+ ninfo = 0;
+ knt = 0;
+ rmax = 0.f;
+ eps = slamch_("E");
+ safmin = slamch_("S");
+
+L10:
+
+ io___7.ciunit = *nin;
+ s_rsle(&io___7);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ilo, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ihi, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ goto L60;
+ }
+
+ io___11.ciunit = *nin;
+ s_rsle(&io___11);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__4, &c__1, (char *)&scale[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_rsle();
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___14.ciunit = *nin;
+ s_rsle(&io___14);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&e[i__ + j * 20 - 21], (ftnlen)
+ sizeof(complex));
+ }
+ e_rsle();
+/* L20: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___17.ciunit = *nin;
+ s_rsle(&io___17);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&ein[i__ + j * 20 - 21], (ftnlen)
+ sizeof(complex));
+ }
+ e_rsle();
+/* L30: */
+ }
+
+ ++knt;
+ cgebak_("B", "R", &n, &ilo, &ihi, scale, &n, e, &c__20, &info);
+
+ if (info != 0) {
+ ++ninfo;
+ lmax[0] = knt;
+ }
+
+ vmax = 0.f;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ q__2.r = e[i__3].r - ein[i__4].r, q__2.i = e[i__3].i - ein[i__4]
+ .i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ x = ((r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1), dabs(
+ r__2))) / eps;
+ i__3 = i__ + j * 20 - 21;
+ if ((r__1 = e[i__3].r, dabs(r__1)) + (r__2 = r_imag(&e[i__ + j *
+ 20 - 21]), dabs(r__2)) > safmin) {
+ i__4 = i__ + j * 20 - 21;
+ x /= (r__3 = e[i__4].r, dabs(r__3)) + (r__4 = r_imag(&e[i__ +
+ j * 20 - 21]), dabs(r__4));
+ }
+ vmax = dmax(vmax,x);
+/* L40: */
+ }
+/* L50: */
+ }
+
+ if (vmax > rmax) {
+ lmax[1] = knt;
+ rmax = vmax;
+ }
+
+ goto L10;
+
+L60:
+
+ io___22.ciunit = *nout;
+ s_wsfe(&io___22);
+ e_wsfe();
+
+ io___23.ciunit = *nout;
+ s_wsfe(&io___23);
+ do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ io___24.ciunit = *nout;
+ s_wsfe(&io___24);
+ do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___25.ciunit = *nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ return 0;
+
+/* End of CCHKBK */
+
+} /* cchkbk_ */
diff --git a/TESTING/EIG/cchkbl.c b/TESTING/EIG/cchkbl.c
new file mode 100644
index 0000000..b5437db
--- /dev/null
+++ b/TESTING/EIG/cchkbl.c
@@ -0,0 +1,277 @@
+/* cchkbl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__6 = 6;
+static integer c__4 = 4;
+static integer c__20 = 20;
+
+/* Subroutine */ int cchkbl_(integer *nin, integer *nout)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002.. test output of CGEBAL .. \002)";
+ static char fmt_9998[] = "(1x,\002value of largest test error "
+ " = \002,e12.3)";
+ static char fmt_9997[] = "(1x,\002example number where info is not zero "
+ " = \002,i4)";
+ static char fmt_9996[] = "(1x,\002example number where ILO or IHI wrong "
+ " = \002,i4)";
+ static char fmt_9995[] = "(1x,\002example number having largest error "
+ " = \002,i4)";
+ static char fmt_9994[] = "(1x,\002number of examples where info is not 0"
+ " = \002,i4)";
+ static char fmt_9993[] = "(1x,\002total number of examples tested "
+ " = \002,i4)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4, r__5, r__6;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+ double r_imag(complex *);
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ complex a[400] /* was [20][20] */;
+ integer i__, j, n;
+ complex ain[400] /* was [20][20] */;
+ integer ihi, ilo, knt, info, lmax[3];
+ real meps, temp, rmax, vmax, scale[20];
+ integer ihiin, ninfo, iloin;
+ real anorm, sfmin, dummy[1];
+ extern /* Subroutine */ int cgebal_(char *, integer *, complex *, integer
+ *, integer *, integer *, real *, integer *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ real scalin[20];
+
+ /* Fortran I/O blocks */
+ static cilist io___8 = { 0, 0, 0, 0, 0 };
+ static cilist io___11 = { 0, 0, 0, 0, 0 };
+ static cilist io___14 = { 0, 0, 0, 0, 0 };
+ static cilist io___17 = { 0, 0, 0, 0, 0 };
+ static cilist io___19 = { 0, 0, 0, 0, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKBL tests CGEBAL, a routine for balancing a general complex */
+/* matrix and isolating some of its eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* NIN (input) INTEGER */
+/* The logical unit number for input. NIN > 0. */
+
+/* NOUT (input) INTEGER */
+/* The logical unit number for output. NOUT > 0. */
+
+/* ====================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ lmax[0] = 0;
+ lmax[1] = 0;
+ lmax[2] = 0;
+ ninfo = 0;
+ knt = 0;
+ rmax = 0.f;
+ vmax = 0.f;
+ sfmin = slamch_("S");
+ meps = slamch_("E");
+
+L10:
+
+ io___8.ciunit = *nin;
+ s_rsle(&io___8);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ goto L70;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___11.ciunit = *nin;
+ s_rsle(&io___11);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&a[i__ + j * 20 - 21], (ftnlen)
+ sizeof(complex));
+ }
+ e_rsle();
+/* L20: */
+ }
+
+ io___14.ciunit = *nin;
+ s_rsle(&io___14);
+ do_lio(&c__3, &c__1, (char *)&iloin, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ihiin, (ftnlen)sizeof(integer));
+ e_rsle();
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___17.ciunit = *nin;
+ s_rsle(&io___17);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&ain[i__ + j * 20 - 21], (ftnlen)
+ sizeof(complex));
+ }
+ e_rsle();
+/* L30: */
+ }
+ io___19.ciunit = *nin;
+ s_rsle(&io___19);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__4, &c__1, (char *)&scalin[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_rsle();
+
+ anorm = clange_("M", &n, &n, a, &c__20, dummy);
+ ++knt;
+ cgebal_("B", &n, a, &c__20, &ilo, &ihi, scale, &info);
+
+ if (info != 0) {
+ ++ninfo;
+ lmax[0] = knt;
+ }
+
+ if (ilo != iloin || ihi != ihiin) {
+ ++ninfo;
+ lmax[1] = knt;
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ r__5 = (r__1 = a[i__3].r, dabs(r__1)) + (r__2 = r_imag(&a[i__ + j
+ * 20 - 21]), dabs(r__2)), r__6 = (r__3 = ain[i__4].r,
+ dabs(r__3)) + (r__4 = r_imag(&ain[i__ + j * 20 - 21]),
+ dabs(r__4));
+ temp = dmax(r__5,r__6);
+ temp = dmax(temp,sfmin);
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ q__2.r = a[i__3].r - ain[i__4].r, q__2.i = a[i__3].i - ain[i__4]
+ .i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+/* Computing MAX */
+ r__3 = vmax, r__4 = ((r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(
+ &q__1), dabs(r__2))) / temp;
+ vmax = dmax(r__3,r__4);
+/* L40: */
+ }
+/* L50: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = scale[i__ - 1], r__2 = scalin[i__ - 1];
+ temp = dmax(r__1,r__2);
+ temp = dmax(temp,sfmin);
+/* Computing MAX */
+ r__2 = vmax, r__3 = (r__1 = scale[i__ - 1] - scalin[i__ - 1], dabs(
+ r__1)) / temp;
+ vmax = dmax(r__2,r__3);
+/* L60: */
+ }
+
+ if (vmax > rmax) {
+ lmax[2] = knt;
+ rmax = vmax;
+ }
+
+ goto L10;
+
+L70:
+
+ io___28.ciunit = *nout;
+ s_wsfe(&io___28);
+ e_wsfe();
+
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ return 0;
+
+/* End of CCHKBL */
+
+} /* cchkbl_ */
diff --git a/TESTING/EIG/cchkec.c b/TESTING/EIG/cchkec.c
new file mode 100644
index 0000000..b4ffcce
--- /dev/null
+++ b/TESTING/EIG/cchkec.c
@@ -0,0 +1,212 @@
+/* cchkec.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int cchkec_(real *thresh, logical *tsterr, integer *nin,
+ integer *nout)
+{
+ /* Format strings */
+ static char fmt_9994[] = "(\002 Tests of the Nonsymmetric eigenproblem c"
+ "ondition\002,\002 estimation routines\002,/\002 CTRSYL, CTREXC, "
+ "CTRSNA, CTRSEN\002,/)";
+ static char fmt_9993[] = "(\002 Relative machine precision (EPS) = \002,"
+ "e16.6,/\002 Safe minimum (SFMIN) = \002,e16.6,/)";
+ static char fmt_9992[] = "(\002 Routines pass computational tests if tes"
+ "t ratio is \002,\002less than\002,f8.2,//)";
+ static char fmt_9999[] = "(\002 Error in CTRSYL: RMAX =\002,e12.3,/\002 "
+ "LMAX = \002,i8,\002 NINFO=\002,i8,\002 KNT=\002,i8)";
+ static char fmt_9998[] = "(\002 Error in CTREXC: RMAX =\002,e12.3,/\002 "
+ "LMAX = \002,i8,\002 NINFO=\002,i8,\002 KNT=\002,i8)";
+ static char fmt_9997[] = "(\002 Error in CTRSNA: RMAX =\002,3e12.3,/\002"
+ " LMAX = \002,3i8,\002 NINFO=\002,3i8,\002 KNT=\002,i8)";
+ static char fmt_9996[] = "(\002 Error in CTRSEN: RMAX =\002,3e12.3,/\002"
+ " LMAX = \002,3i8,\002 NINFO=\002,3i8,\002 KNT=\002,i8)";
+ static char fmt_9995[] = "(/1x,\002All tests for \002,a3,\002 routines p"
+ "assed the threshold (\002,i6,\002 tests run)\002)";
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ logical ok;
+ real eps;
+ char path[3];
+ extern /* Subroutine */ int cget35_(real *, integer *, integer *, integer
+ *, integer *), cget36_(real *, integer *, integer *, integer *,
+ integer *), cget37_(real *, integer *, integer *, integer *,
+ integer *), cget38_(real *, integer *, integer *, integer *,
+ integer *);
+ real sfmin;
+ extern /* Subroutine */ int cerrec_(char *, integer *);
+ extern doublereal slamch_(char *);
+ integer ktrexc, ltrexc, ktrsna, ntrexc, ltrsna[3], ntrsna[3], ktrsen;
+ real rtrexc;
+ integer ltrsen[3], ntrsen[3];
+ real rtrsna[3], rtrsen[3];
+ integer ntests, ktrsyl, ltrsyl, ntrsyl;
+ real rtrsyl;
+
+ /* Fortran I/O blocks */
+ static cilist io___4 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___5 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___6 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___12 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___17 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKEC tests eigen- condition estimation routines */
+/* CTRSYL, CTREXC, CTRSNA, CTRSEN */
+
+/* In all cases, the routine runs through a fixed set of numerical */
+/* examples, subjects them to various tests, and compares the test */
+/* results to a threshold THRESH. In addition, CTRSNA and CTRSEN are */
+/* tested by reading in precomputed examples from a file (on input unit */
+/* NIN). Output is written to output unit NOUT. */
+
+/* Arguments */
+/* ========= */
+
+/* THRESH (input) REAL */
+/* Threshold for residual tests. A computed test ratio passes */
+/* the threshold if it is less than THRESH. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NIN (input) INTEGER */
+/* The logical unit number for input. */
+
+/* NOUT (input) INTEGER */
+/* The logical unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "EC", (ftnlen)2, (ftnlen)2);
+ eps = slamch_("P");
+ sfmin = slamch_("S");
+ io___4.ciunit = *nout;
+ s_wsfe(&io___4);
+ e_wsfe();
+ io___5.ciunit = *nout;
+ s_wsfe(&io___5);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&sfmin, (ftnlen)sizeof(real));
+ e_wsfe();
+ io___6.ciunit = *nout;
+ s_wsfe(&io___6);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
+ e_wsfe();
+
+/* Test error exits if TSTERR is .TRUE. */
+
+ if (*tsterr) {
+ cerrec_(path, nout);
+ }
+
+ ok = TRUE_;
+ cget35_(&rtrsyl, <rsyl, &ntrsyl, &ktrsyl, nin);
+ if (rtrsyl > *thresh) {
+ ok = FALSE_;
+ io___12.ciunit = *nout;
+ s_wsfe(&io___12);
+ do_fio(&c__1, (char *)&rtrsyl, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)<rsyl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ntrsyl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ktrsyl, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ cget36_(&rtrexc, <rexc, &ntrexc, &ktrexc, nin);
+ if (rtrexc > *thresh || ntrexc > 0) {
+ ok = FALSE_;
+ io___17.ciunit = *nout;
+ s_wsfe(&io___17);
+ do_fio(&c__1, (char *)&rtrexc, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)<rexc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ntrexc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ktrexc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ cget37_(rtrsna, ltrsna, ntrsna, &ktrsna, nin);
+ if (rtrsna[0] > *thresh || rtrsna[1] > *thresh || ntrsna[0] != 0 ||
+ ntrsna[1] != 0 || ntrsna[2] != 0) {
+ ok = FALSE_;
+ io___22.ciunit = *nout;
+ s_wsfe(&io___22);
+ do_fio(&c__3, (char *)&rtrsna[0], (ftnlen)sizeof(real));
+ do_fio(&c__3, (char *)<rsna[0], (ftnlen)sizeof(integer));
+ do_fio(&c__3, (char *)&ntrsna[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ktrsna, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ cget38_(rtrsen, ltrsen, ntrsen, &ktrsen, nin);
+ if (rtrsen[0] > *thresh || rtrsen[1] > *thresh || ntrsen[0] != 0 ||
+ ntrsen[1] != 0 || ntrsen[2] != 0) {
+ ok = FALSE_;
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__3, (char *)&rtrsen[0], (ftnlen)sizeof(real));
+ do_fio(&c__3, (char *)<rsen[0], (ftnlen)sizeof(integer));
+ do_fio(&c__3, (char *)&ntrsen[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ktrsen, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ ntests = ktrsyl + ktrexc + ktrsna + ktrsen;
+ if (ok) {
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&ntests, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ return 0;
+
+/* End of CCHKEC */
+
+} /* cchkec_ */
diff --git a/TESTING/EIG/cchkee.c b/TESTING/EIG/cchkee.c
new file mode 100644
index 0000000..2aed468
--- /dev/null
+++ b/TESTING/EIG/cchkee.c
@@ -0,0 +1,3480 @@
+/* cchkee.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer nproc, nshift, maxb;
+} cenvir_;
+
+#define cenvir_1 cenvir_
+
+struct {
+ integer iparms[100];
+} claenv_;
+
+#define claenv_1 claenv_
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ real selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__5 = 5;
+static integer c__6 = 6;
+static integer c__4 = 4;
+static integer c__20 = 20;
+static integer c__0 = 0;
+static integer c__132 = 132;
+static integer c__2 = 2;
+static integer c__12 = 12;
+static integer c__13 = 13;
+static integer c__14 = 14;
+static integer c__15 = 15;
+static integer c__16 = 16;
+static integer c__8 = 8;
+static integer c__89760 = 89760;
+static integer c__9 = 9;
+static integer c__25 = 25;
+static integer c__20064 = 20064;
+static integer c__18 = 18;
+static integer c__400 = 400;
+static integer c__20062 = 20062;
+static integer c__264 = 264;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Initialized data */
+
+ static char intstr[10] = "0123456789";
+ static integer ioldsd[4] = { 0,0,0,1 };
+
+ /* Format strings */
+ static char fmt_9987[] = "(\002 Tests of the Nonsymmetric Eigenvalue Pro"
+ "blem routines\002)";
+ static char fmt_9986[] = "(\002 Tests of the Hermitian Eigenvalue Proble"
+ "m routines\002)";
+ static char fmt_9985[] = "(\002 Tests of the Singular Value Decompositio"
+ "n routines\002)";
+ static char fmt_9979[] = "(/\002 Tests of the Nonsymmetric Eigenvalue Pr"
+ "oblem Driver\002,/\002 CGEEV (eigenvalues and eigevectors)"
+ "\002)";
+ static char fmt_9978[] = "(/\002 Tests of the Nonsymmetric Eigenvalue Pr"
+ "oblem Driver\002,/\002 CGEES (Schur form)\002)";
+ static char fmt_9977[] = "(/\002 Tests of the Nonsymmetric Eigenvalue Pr"
+ "oblem Expert\002,\002 Driver\002,/\002 CGEEVX (eigenvalues, e"
+ "igenvectors and\002,\002 condition numbers)\002)";
+ static char fmt_9976[] = "(/\002 Tests of the Nonsymmetric Eigenvalue Pr"
+ "oblem Expert\002,\002 Driver\002,/\002 CGEESX (Schur form and"
+ " condition\002,\002 numbers)\002)";
+ static char fmt_9975[] = "(/\002 Tests of the Generalized Nonsymmetric E"
+ "igenvalue \002,\002Problem routines\002)";
+ static char fmt_9964[] = "(/\002 Tests of the Generalized Nonsymmetric E"
+ "igenvalue \002,\002Problem Driver CGGES\002)";
+ static char fmt_9965[] = "(/\002 Tests of the Generalized Nonsymmetric E"
+ "igenvalue \002,\002Problem Expert Driver CGGESX\002)";
+ static char fmt_9963[] = "(/\002 Tests of the Generalized Nonsymmetric E"
+ "igenvalue \002,\002Problem Driver CGGEV\002)";
+ static char fmt_9962[] = "(/\002 Tests of the Generalized Nonsymmetric E"
+ "igenvalue \002,\002Problem Expert Driver CGGEVX\002)";
+ static char fmt_9974[] = "(\002 Tests of CHBTRD\002,/\002 (reduction of "
+ "a Hermitian band \002,\002matrix to real tridiagonal form)\002)";
+ static char fmt_9967[] = "(\002 Tests of CGBBRD\002,/\002 (reduction of "
+ "a general band \002,\002matrix to real bidiagonal form)\002)";
+ static char fmt_9971[] = "(/\002 Tests of the Generalized Linear Regress"
+ "ion Model \002,\002routines\002)";
+ static char fmt_9970[] = "(/\002 Tests of the Generalized QR and RQ rout"
+ "ines\002)";
+ static char fmt_9969[] = "(/\002 Tests of the Generalized Singular Valu"
+ "e\002,\002 Decomposition routines\002)";
+ static char fmt_9968[] = "(/\002 Tests of the Linear Least Squares routi"
+ "nes\002)";
+ static char fmt_9992[] = "(1x,a3,\002: Unrecognized path name\002)";
+ static char fmt_9972[] = "(/\002 LAPACK VERSION \002,i1,\002.\002,i1,"
+ "\002.\002,i1)";
+ static char fmt_9984[] = "(/\002 The following parameter values will be "
+ "used:\002)";
+ static char fmt_9989[] = "(\002 Invalid input value: \002,a,\002=\002,"
+ "i6,\002; must be >=\002,i6)";
+ static char fmt_9988[] = "(\002 Invalid input value: \002,a,\002=\002,"
+ "i6,\002; must be <=\002,i6)";
+ static char fmt_9983[] = "(4x,a,10i6,/10x,10i6)";
+ static char fmt_9981[] = "(\002 Relative machine \002,a,\002 is taken to"
+ " be\002,e16.6)";
+ static char fmt_9982[] = "(/\002 Routines pass computational tests if te"
+ "st ratio is \002,\002less than\002,f8.2,/)";
+ static char fmt_9999[] = "(/\002 Execution not attempted due to input er"
+ "rors\002)";
+ static char fmt_9991[] = "(//\002 *** Invalid integer value in column"
+ " \002,i2,\002 of input\002,\002 line:\002,/a79)";
+ static char fmt_9990[] = "(//1x,a3,\002 routines were not tested\002)";
+ static char fmt_9961[] = "(//1x,a3,\002: NB =\002,i4,\002, NBMIN =\002,"
+ "i4,\002, NX =\002,i4,\002, INMIN=\002,i4,\002, INWIN =\002,i4"
+ ",\002, INIBL =\002,i4,\002, ISHFTS =\002,i4,\002, IACC22 =\002,i"
+ "4)";
+ static char fmt_9980[] = "(\002 *** Error code from \002,a,\002 = \002,i"
+ "4)";
+ static char fmt_9997[] = "(//1x,a3,\002: NB =\002,i4,\002, NBMIN =\002,"
+ "i4,\002, NX =\002,i4)";
+ static char fmt_9995[] = "(//1x,a3,\002: NB =\002,i4,\002, NBMIN =\002,"
+ "i4,\002, NX =\002,i4,\002, NRHS =\002,i4)";
+ static char fmt_9973[] = "(/1x,71(\002-\002))";
+ static char fmt_9996[] = "(//1x,a3,\002: NB =\002,i4,\002, NBMIN =\002,"
+ "i4,\002, NS =\002,i4,\002, MAXB =\002,i4,\002, NBCOL =\002,i4)";
+ static char fmt_9966[] = "(//1x,a3,\002: NRHS =\002,i4)";
+ static char fmt_9994[] = "(//\002 End of tests\002)";
+ static char fmt_9993[] = "(\002 Total time used = \002,f12.2,\002 seco"
+ "nds\002,/)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1;
+ cilist ci__1;
+
+ /* Builtin functions */
+ integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), e_wsfe(
+ void), s_rsle(cilist *), do_lio(integer *, integer *, char *,
+ ftnlen), e_rsle(void), s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+ integer i_len(char *, ftnlen);
+
+ /* Local variables */
+ complex a[243936] /* was [17424][14] */, b[87120] /* was [17424][5] */,
+ c__[160000] /* was [400][400] */;
+ integer i__, k;
+ real s[17424];
+ complex x[660];
+ char c1[1], c3[3];
+ integer i1;
+ real s1, s2;
+ complex dc[792] /* was [132][6] */;
+ integer ic;
+ real dr[1584] /* was [132][12] */;
+ integer nk, nn, vers_patch__, vers_major__, vers_minor__;
+ logical cbb, chb, cbk, cbl, cgg, cgk, cgl, ces, cgs, cev, cgv, glm, cgx,
+ nep, lse, sep;
+ real eps;
+ logical gqr, svd, csx, gsv, cvx, cxv;
+ real beta[132];
+ char line[80];
+ complex taua[132];
+ integer info;
+ char path[3];
+ integer kval[20], lenp, mval[20], nval[20];
+ complex taub[132];
+ integer pval[20], itmp, nrhs;
+ complex work[89760];
+ integer iacc22[20];
+ real alpha[132];
+ logical fatal;
+ integer iseed[4], nbcol[20], inibl[20], nbval[20], nbmin[20];
+ char vname[32];
+ integer inmin[20], newsd, nsval[20], inwin[20], nxval[20], iwork[20064];
+ real rwork[89760];
+ extern /* Subroutine */ int cchkbb_(integer *, integer *, integer *,
+ integer *, integer *, integer *, logical *, integer *, integer *,
+ real *, integer *, complex *, integer *, complex *, integer *,
+ real *, real *, complex *, integer *, complex *, integer *,
+ complex *, integer *, complex *, complex *, integer *, real *,
+ real *, integer *), cchkbd_(integer *, integer *, integer *,
+ integer *, logical *, integer *, integer *, real *, complex *,
+ integer *, real *, real *, real *, real *, complex *, integer *,
+ complex *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, complex *, integer *, real *, integer *,
+ integer *), cchkec_(real *, logical *, integer *, integer *),
+ cchkhb_(integer *, integer *, integer *, integer *, integer *,
+ logical *, integer *, real *, integer *, complex *, integer *,
+ real *, real *, complex *, integer *, complex *, integer *, real *
+, real *, integer *), cchkbk_(integer *, integer *), cchkbl_(
+ integer *, integer *), cchkgg_(integer *, integer *, integer *,
+ logical *, integer *, real *, logical *, real *, integer *,
+ complex *, integer *, complex *, complex *, complex *, complex *,
+ complex *, complex *, complex *, complex *, integer *, complex *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ complex *, complex *, complex *, integer *, real *, logical *,
+ real *, integer *), cchkgk_(integer *, integer *), cchkgl_(
+ integer *, integer *), cckglm_(integer *, integer *, integer *,
+ integer *, integer *, integer *, real *, integer *, complex *,
+ complex *, complex *, complex *, complex *, complex *, real *,
+ integer *, integer *, integer *), cerrbd_(char *, integer *), cchkhs_(integer *, integer *, integer *, logical *,
+ integer *, real *, integer *, complex *, integer *, complex *,
+ complex *, complex *, complex *, integer *, complex *, complex *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ complex *, complex *, complex *, integer *, real *, integer *,
+ logical *, real *, integer *), ccklse_(integer *, integer *,
+ integer *, integer *, integer *, integer *, real *, integer *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ real *, integer *, integer *, integer *), alareq_(char *, integer
+ *, logical *, integer *, integer *, integer *), cdrvbd_(
+ integer *, integer *, integer *, integer *, logical *, integer *,
+ real *, complex *, integer *, complex *, integer *, complex *,
+ integer *, complex *, complex *, complex *, real *, real *, real *
+, complex *, integer *, real *, integer *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int cdrges_(integer *, integer *, integer *,
+ logical *, integer *, real *, integer *, complex *, integer *,
+ complex *, complex *, complex *, complex *, integer *, complex *,
+ complex *, complex *, complex *, integer *, real *, real *,
+ logical *, integer *), cerred_(char *, integer *),
+ cckgqr_(integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, real *, integer *, complex *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ complex *, complex *, complex *, complex *, complex *, real *,
+ integer *, integer *, integer *);
+ extern doublereal second_(void);
+ extern /* Subroutine */ int cdrgev_(integer *, integer *, integer *,
+ logical *, integer *, real *, integer *, complex *, integer *,
+ complex *, complex *, complex *, complex *, integer *, complex *,
+ complex *, integer *, complex *, complex *, complex *, complex *,
+ complex *, integer *, real *, real *, integer *), cdrvgg_(integer
+ *, integer *, integer *, logical *, integer *, real *, real *,
+ integer *, complex *, integer *, complex *, complex *, complex *,
+ complex *, complex *, complex *, integer *, complex *, complex *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ integer *, real *, real *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int cchkst_(integer *, integer *, integer *,
+ logical *, integer *, real *, integer *, complex *, integer *,
+ complex *, real *, real *, real *, real *, real *, real *, real *,
+ real *, real *, real *, real *, complex *, integer *, complex *,
+ complex *, complex *, complex *, complex *, integer *, real *,
+ integer *, integer *, integer *, real *, integer *), cckgsv_(
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ real *, integer *, complex *, complex *, complex *, complex *,
+ complex *, complex *, complex *, real *, real *, complex *,
+ integer *, complex *, real *, integer *, integer *, integer *),
+ cerrgg_(char *, integer *), ilaver_(integer *, integer *,
+ integer *), cdrves_(integer *, integer *, integer *, logical *,
+ integer *, real *, integer *, complex *, integer *, complex *,
+ complex *, complex *, complex *, complex *, integer *, real *,
+ complex *, integer *, real *, integer *, logical *, integer *),
+ cerrhs_(char *, integer *), cdrvsg_(integer *, integer *,
+ integer *, logical *, integer *, real *, integer *, complex *,
+ integer *, complex *, integer *, real *, complex *, integer *,
+ complex *, complex *, complex *, complex *, complex *, integer *,
+ real *, integer *, integer *, integer *, real *, integer *);
+ integer mxbval[20];
+ extern /* Subroutine */ int cdrgsx_(integer *, integer *, real *, integer
+ *, integer *, complex *, integer *, complex *, complex *, complex
+ *, complex *, complex *, complex *, complex *, complex *, integer
+ *, real *, complex *, integer *, real *, integer *, integer *,
+ logical *, integer *), cdrvev_(integer *, integer *, integer *,
+ logical *, integer *, real *, integer *, complex *, integer *,
+ complex *, complex *, complex *, complex *, integer *, complex *,
+ integer *, complex *, integer *, real *, complex *, integer *,
+ real *, integer *, integer *);
+ logical tstdif;
+ real thresh;
+ extern /* Subroutine */ int cdrgvx_(integer *, real *, integer *, integer
+ *, complex *, integer *, complex *, complex *, complex *, complex
+ *, complex *, complex *, complex *, integer *, integer *, real *,
+ real *, real *, real *, real *, real *, complex *, integer *,
+ real *, integer *, integer *, real *, logical *, integer *);
+ logical tstchk;
+ integer nparms, ishfts[20];
+ extern /* Subroutine */ int cerrst_(char *, integer *);
+ logical dotype[30], logwrk[132];
+ real thrshn;
+ extern /* Subroutine */ int cdrvst_(integer *, integer *, integer *,
+ logical *, integer *, real *, integer *, complex *, integer *,
+ real *, real *, real *, real *, real *, real *, complex *,
+ integer *, complex *, complex *, complex *, complex *, integer *,
+ real *, integer *, integer *, integer *, real *, integer *),
+ cdrvsx_(integer *, integer *, integer *, logical *, integer *,
+ real *, integer *, integer *, complex *, integer *, complex *,
+ complex *, complex *, complex *, complex *, complex *, integer *,
+ complex *, real *, complex *, integer *, real *, logical *,
+ integer *), xlaenv_(integer *, integer *), cdrvvx_(integer *,
+ integer *, integer *, logical *, integer *, real *, integer *,
+ integer *, complex *, integer *, complex *, complex *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ real *, real *, real *, real *, real *, real *, real *, real *,
+ real *, complex *, integer *, real *, integer *);
+ real result[500];
+ integer maxtyp;
+ logical tsterr;
+ integer ntypes;
+ logical tstdrv;
+
+ /* Fortran I/O blocks */
+ static cilist io___29 = { 0, 6, 0, fmt_9987, 0 };
+ static cilist io___30 = { 0, 6, 0, fmt_9986, 0 };
+ static cilist io___31 = { 0, 6, 0, fmt_9985, 0 };
+ static cilist io___32 = { 0, 6, 0, fmt_9979, 0 };
+ static cilist io___33 = { 0, 6, 0, fmt_9978, 0 };
+ static cilist io___34 = { 0, 6, 0, fmt_9977, 0 };
+ static cilist io___35 = { 0, 6, 0, fmt_9976, 0 };
+ static cilist io___36 = { 0, 6, 0, fmt_9975, 0 };
+ static cilist io___37 = { 0, 6, 0, fmt_9964, 0 };
+ static cilist io___38 = { 0, 6, 0, fmt_9965, 0 };
+ static cilist io___39 = { 0, 6, 0, fmt_9963, 0 };
+ static cilist io___40 = { 0, 6, 0, fmt_9962, 0 };
+ static cilist io___41 = { 0, 6, 0, fmt_9974, 0 };
+ static cilist io___42 = { 0, 6, 0, fmt_9967, 0 };
+ static cilist io___43 = { 0, 6, 0, fmt_9971, 0 };
+ static cilist io___44 = { 0, 6, 0, fmt_9970, 0 };
+ static cilist io___45 = { 0, 6, 0, fmt_9969, 0 };
+ static cilist io___46 = { 0, 6, 0, fmt_9968, 0 };
+ static cilist io___47 = { 0, 5, 0, 0, 0 };
+ static cilist io___50 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___54 = { 0, 6, 0, fmt_9972, 0 };
+ static cilist io___55 = { 0, 6, 0, fmt_9984, 0 };
+ static cilist io___56 = { 0, 5, 0, 0, 0 };
+ static cilist io___58 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___59 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___60 = { 0, 5, 0, 0, 0 };
+ static cilist io___64 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___65 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___66 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___67 = { 0, 5, 0, 0, 0 };
+ static cilist io___69 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___70 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___71 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___72 = { 0, 5, 0, 0, 0 };
+ static cilist io___74 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___75 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___76 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___77 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___78 = { 0, 5, 0, 0, 0 };
+ static cilist io___80 = { 0, 5, 0, 0, 0 };
+ static cilist io___82 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___83 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___84 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___85 = { 0, 5, 0, 0, 0 };
+ static cilist io___94 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___95 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___96 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___97 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___98 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___99 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___100 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___101 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___102 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___103 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___104 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___105 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___106 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___107 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___108 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___109 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___110 = { 0, 5, 0, 0, 0 };
+ static cilist io___113 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___114 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___115 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___116 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___117 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___118 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___119 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___120 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___121 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___122 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___123 = { 0, 5, 0, 0, 0 };
+ static cilist io___125 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___126 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___127 = { 0, 5, 0, 0, 0 };
+ static cilist io___128 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___129 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___130 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___131 = { 0, 5, 0, 0, 0 };
+ static cilist io___132 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___133 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___134 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___135 = { 0, 5, 0, 0, 0 };
+ static cilist io___136 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___137 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___138 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___139 = { 0, 5, 0, 0, 0 };
+ static cilist io___140 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___141 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___142 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___143 = { 0, 5, 0, 0, 0 };
+ static cilist io___144 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___145 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___146 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___147 = { 0, 5, 0, 0, 0 };
+ static cilist io___148 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___149 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___150 = { 0, 5, 0, 0, 0 };
+ static cilist io___151 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___152 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___153 = { 0, 5, 0, 0, 0 };
+ static cilist io___154 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___155 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___156 = { 0, 5, 0, 0, 0 };
+ static cilist io___157 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___158 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___159 = { 0, 5, 0, 0, 0 };
+ static cilist io___160 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___161 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___162 = { 0, 5, 0, 0, 0 };
+ static cilist io___164 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___165 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___166 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___167 = { 0, 6, 0, 0, 0 };
+ static cilist io___169 = { 0, 6, 0, fmt_9981, 0 };
+ static cilist io___170 = { 0, 6, 0, fmt_9981, 0 };
+ static cilist io___171 = { 0, 6, 0, fmt_9981, 0 };
+ static cilist io___172 = { 0, 5, 0, 0, 0 };
+ static cilist io___173 = { 0, 6, 0, fmt_9982, 0 };
+ static cilist io___174 = { 0, 5, 0, 0, 0 };
+ static cilist io___176 = { 0, 5, 0, 0, 0 };
+ static cilist io___178 = { 0, 5, 0, 0, 0 };
+ static cilist io___179 = { 0, 5, 0, 0, 0 };
+ static cilist io___181 = { 0, 5, 0, 0, 0 };
+ static cilist io___183 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___192 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___193 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___196 = { 0, 6, 0, fmt_9961, 0 };
+ static cilist io___205 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___206 = { 0, 6, 0, fmt_9997, 0 };
+ static cilist io___208 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___209 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___210 = { 0, 6, 0, fmt_9997, 0 };
+ static cilist io___211 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___213 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___214 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___215 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___216 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___217 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___218 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___219 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___220 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___221 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___222 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___223 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___224 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___225 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___226 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___227 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___230 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___231 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___232 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___233 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___234 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___235 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___238 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___239 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___240 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___241 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___242 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___243 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___244 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___245 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___246 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___247 = { 0, 6, 0, fmt_9966, 0 };
+ static cilist io___248 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___251 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___254 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___257 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___258 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___259 = { 0, 6, 0, 0, 0 };
+ static cilist io___260 = { 0, 6, 0, 0, 0 };
+ static cilist io___261 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___262 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___264 = { 0, 6, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2007 */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKEE tests the COMPLEX LAPACK subroutines for the matrix */
+/* eigenvalue problem. The test paths in this version are */
+
+/* NEP (Nonsymmetric Eigenvalue Problem): */
+/* Test CGEHRD, CUNGHR, CHSEQR, CTREVC, CHSEIN, and CUNMHR */
+
+/* SEP (Hermitian Eigenvalue Problem): */
+/* Test CHETRD, CUNGTR, CSTEQR, CSTERF, CSTEIN, CSTEDC, */
+/* and drivers CHEEV(X), CHBEV(X), CHPEV(X), */
+/* CHEEVD, CHBEVD, CHPEVD */
+
+/* SVD (Singular Value Decomposition): */
+/* Test CGEBRD, CUNGBR, and CBDSQR */
+/* and the drivers CGESVD, CGESDD */
+
+/* CEV (Nonsymmetric Eigenvalue/eigenvector Driver): */
+/* Test CGEEV */
+
+/* CES (Nonsymmetric Schur form Driver): */
+/* Test CGEES */
+
+/* CVX (Nonsymmetric Eigenvalue/eigenvector Expert Driver): */
+/* Test CGEEVX */
+
+/* CSX (Nonsymmetric Schur form Expert Driver): */
+/* Test CGEESX */
+
+/* CGG (Generalized Nonsymmetric Eigenvalue Problem): */
+/* Test CGGHRD, CGGBAL, CGGBAK, CHGEQZ, and CTGEVC */
+/* and the driver routines CGEGS and CGEGV */
+
+/* CGS (Generalized Nonsymmetric Schur form Driver): */
+/* Test CGGES */
+
+/* CGV (Generalized Nonsymmetric Eigenvalue/eigenvector Driver): */
+/* Test CGGEV */
+
+/* CGX (Generalized Nonsymmetric Schur form Expert Driver): */
+/* Test CGGESX */
+
+/* CXV (Generalized Nonsymmetric Eigenvalue/eigenvector Expert Driver): */
+/* Test CGGEVX */
+
+/* CSG (Hermitian Generalized Eigenvalue Problem): */
+/* Test CHEGST, CHEGV, CHEGVD, CHEGVX, CHPGST, CHPGV, CHPGVD, */
+/* CHPGVX, CHBGST, CHBGV, CHBGVD, and CHBGVX */
+
+/* CHB (Hermitian Band Eigenvalue Problem): */
+/* Test CHBTRD */
+
+/* CBB (Band Singular Value Decomposition): */
+/* Test CGBBRD */
+
+/* CEC (Eigencondition estimation): */
+/* Test CTRSYL, CTREXC, CTRSNA, and CTRSEN */
+
+/* CBL (Balancing a general matrix) */
+/* Test CGEBAL */
+
+/* CBK (Back transformation on a balanced matrix) */
+/* Test CGEBAK */
+
+/* CGL (Balancing a matrix pair) */
+/* Test CGGBAL */
+
+/* CGK (Back transformation on a matrix pair) */
+/* Test CGGBAK */
+
+/* GLM (Generalized Linear Regression Model): */
+/* Tests CGGGLM */
+
+/* GQR (Generalized QR and RQ factorizations): */
+/* Tests CGGQRF and CGGRQF */
+
+/* GSV (Generalized Singular Value Decomposition): */
+/* Tests CGGSVD, CGGSVP, CTGSJA, CLAGS2, CLAPLL, and CLAPMT */
+
+/* LSE (Constrained Linear Least Squares): */
+/* Tests CGGLSE */
+
+/* Each test path has a different set of inputs, but the data sets for */
+/* the driver routines xEV, xES, xVX, and xSX can be concatenated in a */
+/* single input file. The first line of input should contain one of the */
+/* 3-character path names in columns 1-3. The number of remaining lines */
+/* depends on what is found on the first line. */
+
+/* The number of matrix types used in testing is often controllable from */
+/* the input file. The number of matrix types for each path, and the */
+/* test routine that describes them, is as follows: */
+
+/* Path name(s) Types Test routine */
+
+/* CHS or NEP 21 CCHKHS */
+/* CST or SEP 21 CCHKST (routines) */
+/* 18 CDRVST (drivers) */
+/* CBD or SVD 16 CCHKBD (routines) */
+/* 5 CDRVBD (drivers) */
+/* CEV 21 CDRVEV */
+/* CES 21 CDRVES */
+/* CVX 21 CDRVVX */
+/* CSX 21 CDRVSX */
+/* CGG 26 CCHKGG (routines) */
+/* 26 CDRVGG (drivers) */
+/* CGS 26 CDRGES */
+/* CGX 5 CDRGSX */
+/* CGV 26 CDRGEV */
+/* CXV 2 CDRGVX */
+/* CSG 21 CDRVSG */
+/* CHB 15 CCHKHB */
+/* CBB 15 CCHKBB */
+/* CEC - CCHKEC */
+/* CBL - CCHKBL */
+/* CBK - CCHKBK */
+/* CGL - CCHKGL */
+/* CGK - CCHKGK */
+/* GLM 8 CCKGLM */
+/* GQR 8 CCKGQR */
+/* GSV 8 CCKGSV */
+/* LSE 8 CCKLSE */
+
+/* ----------------------------------------------------------------------- */
+
+/* NEP input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of N. */
+
+/* line 3: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix dimension N. */
+
+/* line 4: NPARMS, INTEGER */
+/* Number of values of the parameters NB, NBMIN, NX, NS, and */
+/* MAXB. */
+
+/* line 5: NBVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the blocksize NB. */
+
+/* line 6: NBMIN, INTEGER array, dimension (NPARMS) */
+/* The values for the minimum blocksize NBMIN. */
+
+/* line 7: NXVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the crossover point NX. */
+
+/* line 8: INMIN, INTEGER array, dimension (NPARMS) */
+/* LAHQR vs TTQRE crossover point, >= 11 */
+
+/* line 9: INWIN, INTEGER array, dimension (NPARMS) */
+/* recommended deflation window size */
+
+/* line 10: INIBL, INTEGER array, dimension (NPARMS) */
+/* nibble crossover point */
+
+/* line 11: ISHFTS, INTEGER array, dimension (NPARMS) */
+/* number of simultaneous shifts) */
+
+/* line 12: IACC22, INTEGER array, dimension (NPARMS) */
+/* select structured matrix multiply: 0, 1 or 2) */
+
+/* line 13: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. To have all of the test */
+/* ratios printed, use THRESH = 0.0 . */
+
+/* line 14: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 14 was 2: */
+
+/* line 15: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 15-EOF: The remaining lines occur in sets of 1 or 2 and allow */
+/* the user to specify the matrix types. Each line contains */
+/* a 3-character path name in columns 1-3, and the number */
+/* of matrix types must be the first nonblank item in columns */
+/* 4-80. If the number of matrix types is at least 1 but is */
+/* less than the maximum number of possible types, a second */
+/* line will be read to get the numbers of the matrix types to */
+/* be used. For example, */
+/* NEP 21 */
+/* requests all of the matrix types for the nonsymmetric */
+/* eigenvalue problem, while */
+/* NEP 4 */
+/* 9 10 11 12 */
+/* requests only matrices of type 9, 10, 11, and 12. */
+
+/* The valid 3-character path names are 'NEP' or 'CHS' for the */
+/* nonsymmetric eigenvalue routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* SEP or CSG input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of N. */
+
+/* line 3: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix dimension N. */
+
+/* line 4: NPARMS, INTEGER */
+/* Number of values of the parameters NB, NBMIN, and NX. */
+
+/* line 5: NBVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the blocksize NB. */
+
+/* line 6: NBMIN, INTEGER array, dimension (NPARMS) */
+/* The values for the minimum blocksize NBMIN. */
+
+/* line 7: NXVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the crossover point NX. */
+
+/* line 8: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 9: TSTCHK, LOGICAL */
+/* Flag indicating whether or not to test the LAPACK routines. */
+
+/* line 10: TSTDRV, LOGICAL */
+/* Flag indicating whether or not to test the driver routines. */
+
+/* line 11: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 12: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 12 was 2: */
+
+/* line 13: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 13-EOF: Lines specifying matrix types, as for NEP. */
+/* The valid 3-character path names are 'SEP' or 'CST' for the */
+/* Hermitian eigenvalue routines and driver routines, and */
+/* 'CSG' for the routines for the Hermitian generalized */
+/* eigenvalue problem. */
+
+/* ----------------------------------------------------------------------- */
+
+/* SVD input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M and N. */
+
+/* line 3: MVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix row dimension M. */
+
+/* line 4: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix column dimension N. */
+
+/* line 5: NPARMS, INTEGER */
+/* Number of values of the parameter NB, NBMIN, NX, and NRHS. */
+
+/* line 6: NBVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the blocksize NB. */
+
+/* line 7: NBMIN, INTEGER array, dimension (NPARMS) */
+/* The values for the minimum blocksize NBMIN. */
+
+/* line 8: NXVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the crossover point NX. */
+
+/* line 9: NSVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the number of right hand sides NRHS. */
+
+/* line 10: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 11: TSTCHK, LOGICAL */
+/* Flag indicating whether or not to test the LAPACK routines. */
+
+/* line 12: TSTDRV, LOGICAL */
+/* Flag indicating whether or not to test the driver routines. */
+
+/* line 13: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 14: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 14 was 2: */
+
+/* line 15: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 15-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path names are 'SVD' or 'CBD' for both the */
+/* SVD routines and the SVD driver routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* CEV and CES data files: */
+
+/* line 1: 'CEV' or 'CES' in columns 1 to 3. */
+
+/* line 2: NSIZES, INTEGER */
+/* Number of sizes of matrices to use. Should be at least 0 */
+/* and at most 20. If NSIZES = 0, no testing is done */
+/* (although the remaining 3 lines are still read). */
+
+/* line 3: NN, INTEGER array, dimension(NSIZES) */
+/* Dimensions of matrices to be tested. */
+
+/* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+/* These integer parameters determine how blocking is done */
+/* (see ILAENV for details) */
+/* NB : block size */
+/* NBMIN : minimum block size */
+/* NX : minimum dimension for blocking */
+/* NS : number of shifts in xHSEQR */
+/* NBCOL : minimum column dimension for blocking */
+
+/* line 5: THRESH, REAL */
+/* The test threshold against which computed residuals are */
+/* compared. Should generally be in the range from 10. to 20. */
+/* If it is 0., all test case data will be printed. */
+
+/* line 6: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 6 was 2: */
+
+/* line 7: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 8 and following: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'CEV' to test CGEEV, or */
+/* 'CES' to test CGEES. */
+
+/* ----------------------------------------------------------------------- */
+
+/* The CVX data has two parts. The first part is identical to CEV, */
+/* and the second part consists of test matrices with precomputed */
+/* solutions. */
+
+/* line 1: 'CVX' in columns 1-3. */
+
+/* line 2: NSIZES, INTEGER */
+/* If NSIZES = 0, no testing of randomly generated examples */
+/* is done, but any precomputed examples are tested. */
+
+/* line 3: NN, INTEGER array, dimension(NSIZES) */
+
+/* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+
+/* line 5: THRESH, REAL */
+
+/* line 6: NEWSD, INTEGER */
+
+/* If line 6 was 2: */
+
+/* line 7: INTEGER array, dimension (4) */
+
+/* lines 8 and following: The first line contains 'CVX' in columns 1-3 */
+/* followed by the number of matrix types, possibly with */
+/* a second line to specify certain matrix types. */
+/* If the number of matrix types = 0, no testing of randomly */
+/* generated examples is done, but any precomputed examples */
+/* are tested. */
+
+/* remaining lines : Each matrix is stored on 1+N+N**2 lines, where N is */
+/* its dimension. The first line contains the dimension N and */
+/* ISRT (two integers). ISRT indicates whether the last N lines */
+/* are sorted by increasing real part of the eigenvalue */
+/* (ISRT=0) or by increasing imaginary part (ISRT=1). The next */
+/* N**2 lines contain the matrix rowwise, one entry per line. */
+/* The last N lines correspond to each eigenvalue. Each of */
+/* these last N lines contains 4 real values: the real part of */
+/* the eigenvalues, the imaginary part of the eigenvalue, the */
+/* reciprocal condition number of the eigenvalues, and the */
+/* reciprocal condition number of the vector eigenvector. The */
+/* end of data is indicated by dimension N=0. Even if no data */
+/* is to be tested, there must be at least one line containing */
+/* N=0. */
+
+/* ----------------------------------------------------------------------- */
+
+/* The CSX data is like CVX. The first part is identical to CEV, and the */
+/* second part consists of test matrices with precomputed solutions. */
+
+/* line 1: 'CSX' in columns 1-3. */
+
+/* line 2: NSIZES, INTEGER */
+/* If NSIZES = 0, no testing of randomly generated examples */
+/* is done, but any precomputed examples are tested. */
+
+/* line 3: NN, INTEGER array, dimension(NSIZES) */
+
+/* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+
+/* line 5: THRESH, REAL */
+
+/* line 6: NEWSD, INTEGER */
+
+/* If line 6 was 2: */
+
+/* line 7: INTEGER array, dimension (4) */
+
+/* lines 8 and following: The first line contains 'CSX' in columns 1-3 */
+/* followed by the number of matrix types, possibly with */
+/* a second line to specify certain matrix types. */
+/* If the number of matrix types = 0, no testing of randomly */
+/* generated examples is done, but any precomputed examples */
+/* are tested. */
+
+/* remaining lines : Each matrix is stored on 3+N**2 lines, where N is */
+/* its dimension. The first line contains the dimension N, the */
+/* dimension M of an invariant subspace, and ISRT. The second */
+/* line contains M integers, identifying the eigenvalues in the */
+/* invariant subspace (by their position in a list of */
+/* eigenvalues ordered by increasing real part (if ISRT=0) or */
+/* by increasing imaginary part (if ISRT=1)). The next N**2 */
+/* lines contain the matrix rowwise. The last line contains the */
+/* reciprocal condition number for the average of the selected */
+/* eigenvalues, and the reciprocal condition number for the */
+/* corresponding right invariant subspace. The end of data in */
+/* indicated by a line containing N=0, M=0, and ISRT = 0. Even */
+/* if no data is to be tested, there must be at least one line */
+/* containing N=0, M=0 and ISRT=0. */
+
+/* ----------------------------------------------------------------------- */
+
+/* CGG input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of N. */
+
+/* line 3: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix dimension N. */
+
+/* line 4: NPARMS, INTEGER */
+/* Number of values of the parameters NB, NBMIN, NBCOL, NS, and */
+/* MAXB. */
+
+/* line 5: NBVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the blocksize NB. */
+
+/* line 6: NBMIN, INTEGER array, dimension (NPARMS) */
+/* The values for NBMIN, the minimum row dimension for blocks. */
+
+/* line 7: NSVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the number of shifts. */
+
+/* line 8: MXBVAL, INTEGER array, dimension (NPARMS) */
+/* The values for MAXB, used in determining minimum blocksize. */
+
+/* line 9: NBCOL, INTEGER array, dimension (NPARMS) */
+/* The values for NBCOL, the minimum column dimension for */
+/* blocks. */
+
+/* line 10: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 11: TSTCHK, LOGICAL */
+/* Flag indicating whether or not to test the LAPACK routines. */
+
+/* line 12: TSTDRV, LOGICAL */
+/* Flag indicating whether or not to test the driver routines. */
+
+/* line 13: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 14: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 14 was 2: */
+
+/* line 15: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 16-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'CGG' for the generalized */
+/* eigenvalue problem routines and driver routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* CGS and CGV input files: */
+
+/* line 1: 'CGS' or 'CGV' in columns 1 to 3. */
+
+/* line 2: NN, INTEGER */
+/* Number of values of N. */
+
+/* line 3: NVAL, INTEGER array, dimension(NN) */
+/* Dimensions of matrices to be tested. */
+
+/* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+/* These integer parameters determine how blocking is done */
+/* (see ILAENV for details) */
+/* NB : block size */
+/* NBMIN : minimum block size */
+/* NX : minimum dimension for blocking */
+/* NS : number of shifts in xHGEQR */
+/* NBCOL : minimum column dimension for blocking */
+
+/* line 5: THRESH, REAL */
+/* The test threshold against which computed residuals are */
+/* compared. Should generally be in the range from 10. to 20. */
+/* If it is 0., all test case data will be printed. */
+
+/* line 6: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits. */
+
+/* line 7: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 17 was 2: */
+
+/* line 7: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 7-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'CGS' for the generalized */
+/* eigenvalue problem routines and driver routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* CGX input file: */
+/* line 1: 'CGX' in columns 1 to 3. */
+
+/* line 2: N, INTEGER */
+/* Value of N. */
+
+/* line 3: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+/* These integer parameters determine how blocking is done */
+/* (see ILAENV for details) */
+/* NB : block size */
+/* NBMIN : minimum block size */
+/* NX : minimum dimension for blocking */
+/* NS : number of shifts in xHGEQR */
+/* NBCOL : minimum column dimension for blocking */
+
+/* line 4: THRESH, REAL */
+/* The test threshold against which computed residuals are */
+/* compared. Should generally be in the range from 10. to 20. */
+/* Information will be printed about each test for which the */
+/* test ratio is greater than or equal to the threshold. */
+
+/* line 5: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 6: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 6 was 2: */
+
+/* line 7: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* If line 2 was 0: */
+
+/* line 7-EOF: Precomputed examples are tested. */
+
+/* remaining lines : Each example is stored on 3+2*N*N lines, where N is */
+/* its dimension. The first line contains the dimension (a */
+/* single integer). The next line contains an integer k such */
+/* that only the last k eigenvalues will be selected and appear */
+/* in the leading diagonal blocks of $A$ and $B$. The next N*N */
+/* lines contain the matrix A, one element per line. The next N*N */
+/* lines contain the matrix B. The last line contains the */
+/* reciprocal of the eigenvalue cluster condition number and the */
+/* reciprocal of the deflating subspace (associated with the */
+/* selected eigencluster) condition number. The end of data is */
+/* indicated by dimension N=0. Even if no data is to be tested, */
+/* there must be at least one line containing N=0. */
+
+/* ----------------------------------------------------------------------- */
+
+/* CXV input files: */
+/* line 1: 'CXV' in columns 1 to 3. */
+
+/* line 2: N, INTEGER */
+/* Value of N. */
+
+/* line 3: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+/* These integer parameters determine how blocking is done */
+/* (see ILAENV for details) */
+/* NB : block size */
+/* NBMIN : minimum block size */
+/* NX : minimum dimension for blocking */
+/* NS : number of shifts in xHGEQR */
+/* NBCOL : minimum column dimension for blocking */
+
+/* line 4: THRESH, REAL */
+/* The test threshold against which computed residuals are */
+/* compared. Should generally be in the range from 10. to 20. */
+/* Information will be printed about each test for which the */
+/* test ratio is greater than or equal to the threshold. */
+
+/* line 5: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 6: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 6 was 2: */
+
+/* line 7: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* If line 2 was 0: */
+
+/* line 7-EOF: Precomputed examples are tested. */
+
+/* remaining lines : Each example is stored on 3+2*N*N lines, where N is */
+/* its dimension. The first line contains the dimension (a */
+/* single integer). The next N*N lines contain the matrix A, one */
+/* element per line. The next N*N lines contain the matrix B. */
+/* The next line contains the reciprocals of the eigenvalue */
+/* condition numbers. The last line contains the reciprocals of */
+/* the eigenvector condition numbers. The end of data is */
+/* indicated by dimension N=0. Even if no data is to be tested, */
+/* there must be at least one line containing N=0. */
+
+/* ----------------------------------------------------------------------- */
+
+/* CHB input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of N. */
+
+/* line 3: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix dimension N. */
+
+/* line 4: NK, INTEGER */
+/* Number of values of K. */
+
+/* line 5: KVAL, INTEGER array, dimension (NK) */
+/* The values for the matrix dimension K. */
+
+/* line 6: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 7: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 7 was 2: */
+
+/* line 8: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 8-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'CHB'. */
+
+/* ----------------------------------------------------------------------- */
+
+/* CBB input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M and N. */
+
+/* line 3: MVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix row dimension M. */
+
+/* line 4: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix column dimension N. */
+
+/* line 4: NK, INTEGER */
+/* Number of values of K. */
+
+/* line 5: KVAL, INTEGER array, dimension (NK) */
+/* The values for the matrix bandwidth K. */
+
+/* line 6: NPARMS, INTEGER */
+/* Number of values of the parameter NRHS */
+
+/* line 7: NSVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the number of right hand sides NRHS. */
+
+/* line 8: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 9: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 9 was 2: */
+
+/* line 10: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 10-EOF: Lines specifying matrix types, as for SVD. */
+/* The 3-character path name is 'CBB'. */
+
+/* ----------------------------------------------------------------------- */
+
+/* CEC input file: */
+
+/* line 2: THRESH, REAL */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* lines 3-EOF: */
+
+/* Input for testing the eigencondition routines consists of a set of */
+/* specially constructed test cases and their solutions. The data */
+/* format is not intended to be modified by the user. */
+
+/* ----------------------------------------------------------------------- */
+
+/* CBL and CBK input files: */
+
+/* line 1: 'CBL' in columns 1-3 to test CGEBAL, or 'CBK' in */
+/* columns 1-3 to test CGEBAK. */
+
+/* The remaining lines consist of specially constructed test cases. */
+
+/* ----------------------------------------------------------------------- */
+
+/* CGL and CGK input files: */
+
+/* line 1: 'CGL' in columns 1-3 to test CGGBAL, or 'CGK' in */
+/* columns 1-3 to test CGGBAK. */
+
+/* The remaining lines consist of specially constructed test cases. */
+
+/* ----------------------------------------------------------------------- */
+
+/* GLM data file: */
+
+/* line 1: 'GLM' in columns 1 to 3. */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M, P, and N. */
+
+/* line 3: MVAL, INTEGER array, dimension(NN) */
+/* Values of M (row dimension). */
+
+/* line 4: PVAL, INTEGER array, dimension(NN) */
+/* Values of P (row dimension). */
+
+/* line 5: NVAL, INTEGER array, dimension(NN) */
+/* Values of N (column dimension), note M <= N <= M+P. */
+
+/* line 6: THRESH, REAL */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 7: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 8: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 8 was 2: */
+
+/* line 9: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 9-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'GLM' for the generalized */
+/* linear regression model routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* GQR data file: */
+
+/* line 1: 'GQR' in columns 1 to 3. */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M, P, and N. */
+
+/* line 3: MVAL, INTEGER array, dimension(NN) */
+/* Values of M. */
+
+/* line 4: PVAL, INTEGER array, dimension(NN) */
+/* Values of P. */
+
+/* line 5: NVAL, INTEGER array, dimension(NN) */
+/* Values of N. */
+
+/* line 6: THRESH, REAL */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 7: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 8: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 8 was 2: */
+
+/* line 9: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 9-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'GQR' for the generalized */
+/* QR and RQ routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* GSV data file: */
+
+/* line 1: 'GSV' in columns 1 to 3. */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M, P, and N. */
+
+/* line 3: MVAL, INTEGER array, dimension(NN) */
+/* Values of M (row dimension). */
+
+/* line 4: PVAL, INTEGER array, dimension(NN) */
+/* Values of P (row dimension). */
+
+/* line 5: NVAL, INTEGER array, dimension(NN) */
+/* Values of N (column dimension). */
+
+/* line 6: THRESH, REAL */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 7: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 8: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 8 was 2: */
+
+/* line 9: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 9-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'GSV' for the generalized */
+/* SVD routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* LSE data file: */
+
+/* line 1: 'LSE' in columns 1 to 3. */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M, P, and N. */
+
+/* line 3: MVAL, INTEGER array, dimension(NN) */
+/* Values of M. */
+
+/* line 4: PVAL, INTEGER array, dimension(NN) */
+/* Values of P. */
+
+/* line 5: NVAL, INTEGER array, dimension(NN) */
+/* Values of N, note P <= N <= P+M. */
+
+/* line 6: THRESH, REAL */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 7: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 8: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 8 was 2: */
+
+/* line 9: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 9-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'GSV' for the generalized */
+/* SVD routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* NMAX is currently set to 132 and must be at least 12 for some of the */
+/* precomputed examples, and LWORK = NMAX*(5*NMAX+20) in the parameter */
+/* statements below. For SVD, we assume NRHS may be as big as N. The */
+/* parameter NEED is set to 14 to allow for 14 N-by-N matrices for CGG. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ s1 = second_();
+ fatal = FALSE_;
+ infoc_1.nunit = 6;
+
+/* Return to here to read multiple sets of data */
+
+L10:
+
+/* Read the first line and set the 3-character test path */
+
+ ci__1.cierr = 0;
+ ci__1.ciend = 1;
+ ci__1.ciunit = 5;
+ ci__1.cifmt = "(A80)";
+ i__1 = s_rsfe(&ci__1);
+ if (i__1 != 0) {
+ goto L380;
+ }
+ i__1 = do_fio(&c__1, line, (ftnlen)80);
+ if (i__1 != 0) {
+ goto L380;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L380;
+ }
+ s_copy(path, line, (ftnlen)3, (ftnlen)3);
+ nep = lsamen_(&c__3, path, "NEP") || lsamen_(&c__3,
+ path, "CHS");
+ sep = lsamen_(&c__3, path, "SEP") || lsamen_(&c__3,
+ path, "CST") || lsamen_(&c__3, path, "CSG");
+ svd = lsamen_(&c__3, path, "SVD") || lsamen_(&c__3,
+ path, "CBD");
+ cev = lsamen_(&c__3, path, "CEV");
+ ces = lsamen_(&c__3, path, "CES");
+ cvx = lsamen_(&c__3, path, "CVX");
+ csx = lsamen_(&c__3, path, "CSX");
+ cgg = lsamen_(&c__3, path, "CGG");
+ cgs = lsamen_(&c__3, path, "CGS");
+ cgx = lsamen_(&c__3, path, "CGX");
+ cgv = lsamen_(&c__3, path, "CGV");
+ cxv = lsamen_(&c__3, path, "CXV");
+ chb = lsamen_(&c__3, path, "CHB");
+ cbb = lsamen_(&c__3, path, "CBB");
+ glm = lsamen_(&c__3, path, "GLM");
+ gqr = lsamen_(&c__3, path, "GQR") || lsamen_(&c__3,
+ path, "GRQ");
+ gsv = lsamen_(&c__3, path, "GSV");
+ lse = lsamen_(&c__3, path, "LSE");
+ cbl = lsamen_(&c__3, path, "CBL");
+ cbk = lsamen_(&c__3, path, "CBK");
+ cgl = lsamen_(&c__3, path, "CGL");
+ cgk = lsamen_(&c__3, path, "CGK");
+
+/* Report values of parameters. */
+
+ if (s_cmp(path, " ", (ftnlen)3, (ftnlen)3) == 0) {
+ goto L10;
+ } else if (nep) {
+ s_wsfe(&io___29);
+ e_wsfe();
+ } else if (sep) {
+ s_wsfe(&io___30);
+ e_wsfe();
+ } else if (svd) {
+ s_wsfe(&io___31);
+ e_wsfe();
+ } else if (cev) {
+ s_wsfe(&io___32);
+ e_wsfe();
+ } else if (ces) {
+ s_wsfe(&io___33);
+ e_wsfe();
+ } else if (cvx) {
+ s_wsfe(&io___34);
+ e_wsfe();
+ } else if (csx) {
+ s_wsfe(&io___35);
+ e_wsfe();
+ } else if (cgg) {
+ s_wsfe(&io___36);
+ e_wsfe();
+ } else if (cgs) {
+ s_wsfe(&io___37);
+ e_wsfe();
+ } else if (cgx) {
+ s_wsfe(&io___38);
+ e_wsfe();
+ } else if (cgv) {
+ s_wsfe(&io___39);
+ e_wsfe();
+ } else if (cxv) {
+ s_wsfe(&io___40);
+ e_wsfe();
+ } else if (chb) {
+ s_wsfe(&io___41);
+ e_wsfe();
+ } else if (cbb) {
+ s_wsfe(&io___42);
+ e_wsfe();
+ } else if (glm) {
+ s_wsfe(&io___43);
+ e_wsfe();
+ } else if (gqr) {
+ s_wsfe(&io___44);
+ e_wsfe();
+ } else if (gsv) {
+ s_wsfe(&io___45);
+ e_wsfe();
+ } else if (lse) {
+ s_wsfe(&io___46);
+ e_wsfe();
+ } else if (cbl) {
+
+/* CGEBAL: Balancing */
+
+ cchkbl_(&c__5, &c__6);
+ goto L380;
+ } else if (cbk) {
+
+/* CGEBAK: Back transformation */
+
+ cchkbk_(&c__5, &c__6);
+ goto L380;
+ } else if (cgl) {
+
+/* CGGBAL: Balancing */
+
+ cchkgl_(&c__5, &c__6);
+ goto L380;
+ } else if (cgk) {
+
+/* CGGBAK: Back transformation */
+
+ cchkgk_(&c__5, &c__6);
+ goto L380;
+ } else if (lsamen_(&c__3, path, "CEC")) {
+
+/* CEC: Eigencondition estimation */
+
+ s_rsle(&io___47);
+ do_lio(&c__4, &c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_rsle();
+ xlaenv_(&c__1, &c__1);
+ tsterr = TRUE_;
+ cchkec_(&thresh, &tsterr, &c__5, &c__6);
+ goto L380;
+ } else {
+ s_wsfe(&io___50);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ goto L380;
+ }
+ ilaver_(&vers_major__, &vers_minor__, &vers_patch__);
+ s_wsfe(&io___54);
+ do_fio(&c__1, (char *)&vers_major__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_minor__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_patch__, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___55);
+ e_wsfe();
+
+/* Read the number of values of M, P, and N. */
+
+ s_rsle(&io___56);
+ do_lio(&c__3, &c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nn < 0) {
+ s_wsfe(&io___58);
+ do_fio(&c__1, " NN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ } else if (nn > 20) {
+ s_wsfe(&io___59);
+ do_fio(&c__1, " NN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__20, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ }
+
+/* Read the values of M */
+
+ if (! (cgx || cxv)) {
+ s_rsle(&io___60);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ if (svd) {
+ s_copy(vname, " M ", (ftnlen)32, (ftnlen)6);
+ } else {
+ s_copy(vname, " N ", (ftnlen)32, (ftnlen)6);
+ }
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (mval[i__ - 1] < 0) {
+ s_wsfe(&io___64);
+ do_fio(&c__1, vname, (ftnlen)32);
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (mval[i__ - 1] > 132) {
+ s_wsfe(&io___65);
+ do_fio(&c__1, vname, (ftnlen)32);
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L20: */
+ }
+ s_wsfe(&io___66);
+ do_fio(&c__1, "M: ", (ftnlen)6);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of P */
+
+ if (glm || gqr || gsv || lse) {
+ s_rsle(&io___67);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&pval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (pval[i__ - 1] < 0) {
+ s_wsfe(&io___69);
+ do_fio(&c__1, " P ", (ftnlen)4);
+ do_fio(&c__1, (char *)&pval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (pval[i__ - 1] > 132) {
+ s_wsfe(&io___70);
+ do_fio(&c__1, " P ", (ftnlen)4);
+ do_fio(&c__1, (char *)&pval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L30: */
+ }
+ s_wsfe(&io___71);
+ do_fio(&c__1, "P: ", (ftnlen)6);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&pval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of N */
+
+ if (svd || cbb || glm || gqr || gsv || lse) {
+ s_rsle(&io___72);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nval[i__ - 1] < 0) {
+ s_wsfe(&io___74);
+ do_fio(&c__1, " N ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nval[i__ - 1] > 132) {
+ s_wsfe(&io___75);
+ do_fio(&c__1, " N ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L40: */
+ }
+ } else {
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nval[i__ - 1] = mval[i__ - 1];
+/* L50: */
+ }
+ }
+ if (! (cgx || cxv)) {
+ s_wsfe(&io___76);
+ do_fio(&c__1, "N: ", (ftnlen)6);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ } else {
+ s_wsfe(&io___77);
+ do_fio(&c__1, "N: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Read the number of values of K, followed by the values of K */
+
+ if (chb || cbb) {
+ s_rsle(&io___78);
+ do_lio(&c__3, &c__1, (char *)&nk, (ftnlen)sizeof(integer));
+ e_rsle();
+ s_rsle(&io___80);
+ i__1 = nk;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&kval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nk;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (kval[i__ - 1] < 0) {
+ s_wsfe(&io___82);
+ do_fio(&c__1, " K ", (ftnlen)6);
+ do_fio(&c__1, (char *)&kval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (kval[i__ - 1] > 132) {
+ s_wsfe(&io___83);
+ do_fio(&c__1, " K ", (ftnlen)6);
+ do_fio(&c__1, (char *)&kval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L60: */
+ }
+ s_wsfe(&io___84);
+ do_fio(&c__1, "K: ", (ftnlen)6);
+ i__1 = nk;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&kval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+ if (cev || ces || cvx || csx) {
+
+/* For the nonsymmetric QR driver routines, only one set of */
+/* parameters is allowed. */
+
+ s_rsle(&io___85);
+ do_lio(&c__3, &c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&inmin[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&inwin[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&inibl[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ishfts[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&iacc22[0], (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nbval[0] < 1) {
+ s_wsfe(&io___94);
+ do_fio(&c__1, " NB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nbmin[0] < 1) {
+ s_wsfe(&io___95);
+ do_fio(&c__1, "NBMIN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nxval[0] < 1) {
+ s_wsfe(&io___96);
+ do_fio(&c__1, " NX ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (inmin[0] < 1) {
+ s_wsfe(&io___97);
+ do_fio(&c__1, " INMIN ", (ftnlen)9);
+ do_fio(&c__1, (char *)&inmin[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (inwin[0] < 1) {
+ s_wsfe(&io___98);
+ do_fio(&c__1, " INWIN ", (ftnlen)9);
+ do_fio(&c__1, (char *)&inwin[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (inibl[0] < 1) {
+ s_wsfe(&io___99);
+ do_fio(&c__1, " INIBL ", (ftnlen)9);
+ do_fio(&c__1, (char *)&inibl[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (ishfts[0] < 1) {
+ s_wsfe(&io___100);
+ do_fio(&c__1, " ISHFTS ", (ftnlen)10);
+ do_fio(&c__1, (char *)&ishfts[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (iacc22[0] < 0) {
+ s_wsfe(&io___101);
+ do_fio(&c__1, " IACC22 ", (ftnlen)10);
+ do_fio(&c__1, (char *)&iacc22[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+ xlaenv_(&c__1, nbval);
+ xlaenv_(&c__2, nbmin);
+ xlaenv_(&c__3, nxval);
+ i__1 = max(11,inmin[0]);
+ xlaenv_(&c__12, &i__1);
+ xlaenv_(&c__13, inwin);
+ xlaenv_(&c__14, inibl);
+ xlaenv_(&c__15, ishfts);
+ xlaenv_(&c__16, iacc22);
+ s_wsfe(&io___102);
+ do_fio(&c__1, "NB: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___103);
+ do_fio(&c__1, "NBMIN:", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___104);
+ do_fio(&c__1, "NX: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___105);
+ do_fio(&c__1, "INMIN: ", (ftnlen)9);
+ do_fio(&c__1, (char *)&inmin[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___106);
+ do_fio(&c__1, "INWIN: ", (ftnlen)7);
+ do_fio(&c__1, (char *)&inwin[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___107);
+ do_fio(&c__1, "INIBL: ", (ftnlen)7);
+ do_fio(&c__1, (char *)&inibl[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___108);
+ do_fio(&c__1, "ISHFTS: ", (ftnlen)8);
+ do_fio(&c__1, (char *)&ishfts[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___109);
+ do_fio(&c__1, "IACC22: ", (ftnlen)8);
+ do_fio(&c__1, (char *)&iacc22[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ } else if (cgs || cgx || cgv || cxv) {
+
+/* For the nonsymmetric generalized driver routines, only one set of */
+/* parameters is allowed. */
+
+ s_rsle(&io___110);
+ do_lio(&c__3, &c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&nsval[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&mxbval[0], (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nbval[0] < 1) {
+ s_wsfe(&io___113);
+ do_fio(&c__1, " NB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nbmin[0] < 1) {
+ s_wsfe(&io___114);
+ do_fio(&c__1, "NBMIN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nxval[0] < 1) {
+ s_wsfe(&io___115);
+ do_fio(&c__1, " NX ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nsval[0] < 2) {
+ s_wsfe(&io___116);
+ do_fio(&c__1, " NS ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nsval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (mxbval[0] < 1) {
+ s_wsfe(&io___117);
+ do_fio(&c__1, " MAXB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&mxbval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+ xlaenv_(&c__1, nbval);
+ xlaenv_(&c__2, nbmin);
+ xlaenv_(&c__3, nxval);
+ xlaenv_(&c__4, nsval);
+ xlaenv_(&c__8, mxbval);
+ s_wsfe(&io___118);
+ do_fio(&c__1, "NB: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___119);
+ do_fio(&c__1, "NBMIN:", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___120);
+ do_fio(&c__1, "NX: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___121);
+ do_fio(&c__1, "NS: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nsval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___122);
+ do_fio(&c__1, "MAXB: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&mxbval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (! chb && ! glm && ! gqr && ! gsv && ! lse) {
+
+/* For the other paths, the number of parameters can be varied */
+/* from the input file. Read the number of parameter values. */
+
+ s_rsle(&io___123);
+ do_lio(&c__3, &c__1, (char *)&nparms, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nparms < 1) {
+ s_wsfe(&io___125);
+ do_fio(&c__1, "NPARMS", (ftnlen)6);
+ do_fio(&c__1, (char *)&nparms, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nparms = 0;
+ fatal = TRUE_;
+ } else if (nparms > 20) {
+ s_wsfe(&io___126);
+ do_fio(&c__1, "NPARMS", (ftnlen)6);
+ do_fio(&c__1, (char *)&nparms, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__20, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nparms = 0;
+ fatal = TRUE_;
+ }
+
+/* Read the values of NB */
+
+ if (! cbb) {
+ s_rsle(&io___127);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nbval[i__ - 1] < 0) {
+ s_wsfe(&io___128);
+ do_fio(&c__1, " NB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nbval[i__ - 1] > 132) {
+ s_wsfe(&io___129);
+ do_fio(&c__1, " NB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L70: */
+ }
+ s_wsfe(&io___130);
+ do_fio(&c__1, "NB: ", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ }
+
+/* Read the values of NBMIN */
+
+ if (nep || sep || svd || cgg) {
+ s_rsle(&io___131);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nbmin[i__ - 1] < 0) {
+ s_wsfe(&io___132);
+ do_fio(&c__1, "NBMIN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nbmin[i__ - 1] > 132) {
+ s_wsfe(&io___133);
+ do_fio(&c__1, "NBMIN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L80: */
+ }
+ s_wsfe(&io___134);
+ do_fio(&c__1, "NBMIN:", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nbmin[i__ - 1] = 1;
+/* L90: */
+ }
+ }
+
+/* Read the values of NX */
+
+ if (nep || sep || svd) {
+ s_rsle(&io___135);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nxval[i__ - 1] < 0) {
+ s_wsfe(&io___136);
+ do_fio(&c__1, " NX ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nxval[i__ - 1] > 132) {
+ s_wsfe(&io___137);
+ do_fio(&c__1, " NX ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L100: */
+ }
+ s_wsfe(&io___138);
+ do_fio(&c__1, "NX: ", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nxval[i__ - 1] = 1;
+/* L110: */
+ }
+ }
+
+/* Read the values of NSHIFT (if CGG) or NRHS (if SVD */
+/* or CBB). */
+
+ if (svd || cbb || cgg) {
+ s_rsle(&io___139);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nsval[i__ - 1] < 0) {
+ s_wsfe(&io___140);
+ do_fio(&c__1, " NS ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nsval[i__ - 1] > 132) {
+ s_wsfe(&io___141);
+ do_fio(&c__1, " NS ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L120: */
+ }
+ s_wsfe(&io___142);
+ do_fio(&c__1, "NS: ", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nsval[i__ - 1] = 1;
+/* L130: */
+ }
+ }
+
+/* Read the values for MAXB. */
+
+ if (cgg) {
+ s_rsle(&io___143);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (mxbval[i__ - 1] < 0) {
+ s_wsfe(&io___144);
+ do_fio(&c__1, " MAXB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (mxbval[i__ - 1] > 132) {
+ s_wsfe(&io___145);
+ do_fio(&c__1, " MAXB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L140: */
+ }
+ s_wsfe(&io___146);
+ do_fio(&c__1, "MAXB: ", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ mxbval[i__ - 1] = 1;
+/* L150: */
+ }
+ }
+
+/* Read the values for INMIN. */
+
+ if (nep) {
+ s_rsle(&io___147);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&inmin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (inmin[i__ - 1] < 0) {
+ s_wsfe(&io___148);
+ do_fio(&c__1, " INMIN ", (ftnlen)7);
+ do_fio(&c__1, (char *)&inmin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L540: */
+ }
+ s_wsfe(&io___149);
+ do_fio(&c__1, "INMIN: ", (ftnlen)7);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&inmin[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ inmin[i__ - 1] = 1;
+/* L550: */
+ }
+ }
+
+/* Read the values for INWIN. */
+
+ if (nep) {
+ s_rsle(&io___150);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&inwin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (inwin[i__ - 1] < 0) {
+ s_wsfe(&io___151);
+ do_fio(&c__1, " INWIN ", (ftnlen)7);
+ do_fio(&c__1, (char *)&inwin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L560: */
+ }
+ s_wsfe(&io___152);
+ do_fio(&c__1, "INWIN: ", (ftnlen)7);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&inwin[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ inwin[i__ - 1] = 1;
+/* L570: */
+ }
+ }
+
+/* Read the values for INIBL. */
+
+ if (nep) {
+ s_rsle(&io___153);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&inibl[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (inibl[i__ - 1] < 0) {
+ s_wsfe(&io___154);
+ do_fio(&c__1, " INIBL ", (ftnlen)7);
+ do_fio(&c__1, (char *)&inibl[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L580: */
+ }
+ s_wsfe(&io___155);
+ do_fio(&c__1, "INIBL: ", (ftnlen)7);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&inibl[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ inibl[i__ - 1] = 1;
+/* L590: */
+ }
+ }
+
+/* Read the values for ISHFTS. */
+
+ if (nep) {
+ s_rsle(&io___156);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&ishfts[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (ishfts[i__ - 1] < 0) {
+ s_wsfe(&io___157);
+ do_fio(&c__1, " ISHFTS ", (ftnlen)8);
+ do_fio(&c__1, (char *)&ishfts[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L600: */
+ }
+ s_wsfe(&io___158);
+ do_fio(&c__1, "ISHFTS: ", (ftnlen)8);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&ishfts[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ishfts[i__ - 1] = 1;
+/* L610: */
+ }
+ }
+
+/* Read the values for IACC22. */
+
+ if (nep) {
+ s_rsle(&io___159);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&iacc22[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (iacc22[i__ - 1] < 0) {
+ s_wsfe(&io___160);
+ do_fio(&c__1, " IACC22 ", (ftnlen)8);
+ do_fio(&c__1, (char *)&iacc22[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L620: */
+ }
+ s_wsfe(&io___161);
+ do_fio(&c__1, "IACC22: ", (ftnlen)8);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&iacc22[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ iacc22[i__ - 1] = 1;
+/* L630: */
+ }
+ }
+
+/* Read the values for NBCOL. */
+
+ if (cgg) {
+ s_rsle(&io___162);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nbcol[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nbcol[i__ - 1] < 0) {
+ s_wsfe(&io___164);
+ do_fio(&c__1, "NBCOL ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbcol[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nbcol[i__ - 1] > 132) {
+ s_wsfe(&io___165);
+ do_fio(&c__1, "NBCOL ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbcol[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L160: */
+ }
+ s_wsfe(&io___166);
+ do_fio(&c__1, "NBCOL:", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nbcol[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nbcol[i__ - 1] = 1;
+/* L170: */
+ }
+ }
+ }
+
+/* Calculate and print the machine dependent constants. */
+
+ s_wsle(&io___167);
+ e_wsle();
+ eps = slamch_("Underflow threshold");
+ s_wsfe(&io___169);
+ do_fio(&c__1, "underflow", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+ eps = slamch_("Overflow threshold");
+ s_wsfe(&io___170);
+ do_fio(&c__1, "overflow ", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+ eps = slamch_("Epsilon");
+ s_wsfe(&io___171);
+ do_fio(&c__1, "precision", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+
+/* Read the threshold value for the test ratios. */
+
+ s_rsle(&io___172);
+ do_lio(&c__4, &c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_rsle();
+ s_wsfe(&io___173);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_wsfe();
+ if (sep || svd || cgg) {
+
+/* Read the flag that indicates whether to test LAPACK routines. */
+
+ s_rsle(&io___174);
+ do_lio(&c__8, &c__1, (char *)&tstchk, (ftnlen)sizeof(logical));
+ e_rsle();
+
+/* Read the flag that indicates whether to test driver routines. */
+
+ s_rsle(&io___176);
+ do_lio(&c__8, &c__1, (char *)&tstdrv, (ftnlen)sizeof(logical));
+ e_rsle();
+ }
+
+/* Read the flag that indicates whether to test the error exits. */
+
+ s_rsle(&io___178);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+
+/* Read the code describing how to set the random number seed. */
+
+ s_rsle(&io___179);
+ do_lio(&c__3, &c__1, (char *)&newsd, (ftnlen)sizeof(integer));
+ e_rsle();
+
+/* If NEWSD = 2, read another line with 4 integers for the seed. */
+
+ if (newsd == 2) {
+ s_rsle(&io___181);
+ for (i__ = 1; i__ <= 4; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&ioldsd[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ }
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = ioldsd[i__ - 1];
+/* L180: */
+ }
+
+ if (fatal) {
+ s_wsfe(&io___183);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Read the input lines indicating the test path and its parameters. */
+/* The first three characters indicate the test path, and the number */
+/* of test matrix types must be the first nonblank item in columns */
+/* 4-80. */
+
+L190:
+
+ if (! (cgx || cxv)) {
+
+L200:
+ ci__1.cierr = 0;
+ ci__1.ciend = 1;
+ ci__1.ciunit = 5;
+ ci__1.cifmt = "(A80)";
+ i__1 = s_rsfe(&ci__1);
+ if (i__1 != 0) {
+ goto L380;
+ }
+ i__1 = do_fio(&c__1, line, (ftnlen)80);
+ if (i__1 != 0) {
+ goto L380;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L380;
+ }
+ s_copy(c3, line, (ftnlen)3, (ftnlen)3);
+ lenp = i_len(line, (ftnlen)80);
+ i__ = 3;
+ itmp = 0;
+ i1 = 0;
+L210:
+ ++i__;
+ if (i__ > lenp) {
+ if (i1 > 0) {
+ goto L240;
+ } else {
+ ntypes = 30;
+ goto L240;
+ }
+ }
+ if (*(unsigned char *)&line[i__ - 1] != ' ' && *(unsigned char *)&
+ line[i__ - 1] != ',') {
+ i1 = i__;
+ *(unsigned char *)c1 = *(unsigned char *)&line[i1 - 1];
+
+/* Check that a valid integer was read */
+
+ for (k = 1; k <= 10; ++k) {
+ if (*(unsigned char *)c1 == *(unsigned char *)&intstr[k - 1])
+ {
+ ic = k - 1;
+ goto L230;
+ }
+/* L220: */
+ }
+ s_wsfe(&io___192);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, line, (ftnlen)80);
+ e_wsfe();
+ goto L200;
+L230:
+ itmp = itmp * 10 + ic;
+ goto L210;
+ } else if (i1 > 0) {
+ goto L240;
+ } else {
+ goto L210;
+ }
+L240:
+ ntypes = itmp;
+
+/* Skip the tests if NTYPES is <= 0. */
+
+ if (! (cev || ces || cvx || csx || cgv || cgs) && ntypes <= 0) {
+ s_wsfe(&io___193);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ goto L200;
+ }
+
+ } else {
+ if (cgx) {
+ s_copy(c3, "CGX", (ftnlen)3, (ftnlen)3);
+ }
+ if (cxv) {
+ s_copy(c3, "CXV", (ftnlen)3, (ftnlen)3);
+ }
+ }
+
+/* Reset the random number seed. */
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L250: */
+ }
+ }
+
+ if (lsamen_(&c__3, c3, "CHS") || lsamen_(&c__3, c3,
+ "NEP")) {
+
+/* ------------------------------------- */
+/* NEP: Nonsymmetric Eigenvalue Problem */
+/* ------------------------------------- */
+/* Vary the parameters */
+/* NB = block size */
+/* NBMIN = minimum block size */
+/* NX = crossover point */
+/* NS = number of shifts */
+/* MAXB = minimum submatrix size */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ xlaenv_(&c__1, &c__1);
+ if (tsterr) {
+ cerrhs_("CHSEQR", &c__6);
+ }
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xlaenv_(&c__1, &nbval[i__ - 1]);
+ xlaenv_(&c__2, &nbmin[i__ - 1]);
+ xlaenv_(&c__3, &nxval[i__ - 1]);
+/* Computing MAX */
+ i__3 = 11, i__4 = inmin[i__ - 1];
+ i__2 = max(i__3,i__4);
+ xlaenv_(&c__12, &i__2);
+ xlaenv_(&c__13, &inwin[i__ - 1]);
+ xlaenv_(&c__14, &inibl[i__ - 1]);
+ xlaenv_(&c__15, &ishfts[i__ - 1]);
+ xlaenv_(&c__16, &iacc22[i__ - 1]);
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L260: */
+ }
+ }
+ s_wsfe(&io___196);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+/* Computing MAX */
+ i__3 = 11, i__4 = inmin[i__ - 1];
+ i__2 = max(i__3,i__4);
+ do_fio(&c__1, (char *)&i__2, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&inwin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&inibl[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ishfts[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iacc22[i__ - 1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ cchkhs_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &a[17424], &a[34848], &a[52272], &a[69696], &
+ c__132, &a[87120], &a[104544], dc, &dc[132], &a[121968], &
+ a[139392], &a[156816], &a[174240], &a[191664], &dc[264],
+ work, &c__89760, rwork, iwork, logwrk, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___205);
+ do_fio(&c__1, "CCHKHS", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L270: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "CST") || lsamen_(&
+ c__3, c3, "SEP")) {
+
+/* ---------------------------------- */
+/* SEP: Symmetric Eigenvalue Problem */
+/* ---------------------------------- */
+/* Vary the parameters */
+/* NB = block size */
+/* NBMIN = minimum block size */
+/* NX = crossover point */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ xlaenv_(&c__1, &c__1);
+ xlaenv_(&c__9, &c__25);
+ if (tsterr) {
+ cerrst_("CST", &c__6);
+ }
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xlaenv_(&c__1, &nbval[i__ - 1]);
+ xlaenv_(&c__2, &nbmin[i__ - 1]);
+ xlaenv_(&c__3, &nxval[i__ - 1]);
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L280: */
+ }
+ }
+ s_wsfe(&io___206);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ if (tstchk) {
+ cchkst_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &c__6, a,
+ &c__132, &a[17424], dr, &dr[132], &dr[264], &dr[396],
+ &dr[528], &dr[660], &dr[792], &dr[924], &dr[1056], &
+ dr[1188], &dr[1320], &a[34848], &c__132, &a[52272], &
+ a[69696], dc, &a[87120], work, &c__89760, rwork, &
+ c__89760, iwork, &c__20064, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___208);
+ do_fio(&c__1, "CCHKST", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ if (tstdrv) {
+ cdrvst_(&nn, nval, &c__18, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &dr[264], &dr[396], &dr[528], &dr[924], &dr[
+ 1056], &dr[1188], &a[17424], &c__132, &a[34848], dc, &
+ a[52272], work, &c__89760, rwork, &c__89760, iwork, &
+ c__20064, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___209);
+ do_fio(&c__1, "CDRVST", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+/* L290: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "CSG")) {
+
+/* ---------------------------------------------- */
+/* CSG: Hermitian Generalized Eigenvalue Problem */
+/* ---------------------------------------------- */
+/* Vary the parameters */
+/* NB = block size */
+/* NBMIN = minimum block size */
+/* NX = crossover point */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ xlaenv_(&c__9, &c__25);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xlaenv_(&c__1, &nbval[i__ - 1]);
+ xlaenv_(&c__2, &nbmin[i__ - 1]);
+ xlaenv_(&c__3, &nxval[i__ - 1]);
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L300: */
+ }
+ }
+ s_wsfe(&io___210);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ if (tstchk) {
+ cdrvsg_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &c__6, a,
+ &c__132, &a[17424], &c__132, &dr[264], &a[34848], &
+ c__132, &a[52272], &a[69696], &a[87120], &a[104544],
+ work, &c__89760, rwork, &c__89760, iwork, &c__20064,
+ result, &info);
+ if (info != 0) {
+ s_wsfe(&io___211);
+ do_fio(&c__1, "CDRVSG", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+/* L310: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "CBD") || lsamen_(&
+ c__3, c3, "SVD")) {
+
+/* ---------------------------------- */
+/* SVD: Singular Value Decomposition */
+/* ---------------------------------- */
+/* Vary the parameters */
+/* NB = block size */
+/* NBMIN = minimum block size */
+/* NX = crossover point */
+/* NRHS = number of right hand sides */
+
+ maxtyp = 16;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ xlaenv_(&c__9, &c__25);
+
+/* Test the error exits */
+
+ xlaenv_(&c__1, &c__1);
+ if (tsterr && tstchk) {
+ cerrbd_("CBD", &c__6);
+ }
+ if (tsterr && tstdrv) {
+ cerred_("CBD", &c__6);
+ }
+
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nrhs = nsval[i__ - 1];
+ xlaenv_(&c__1, &nbval[i__ - 1]);
+ xlaenv_(&c__2, &nbmin[i__ - 1]);
+ xlaenv_(&c__3, &nxval[i__ - 1]);
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L320: */
+ }
+ }
+ s_wsfe(&io___213);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(integer));
+ e_wsfe();
+ if (tstchk) {
+ cchkbd_(&nn, mval, nval, &maxtyp, dotype, &nrhs, iseed, &
+ thresh, a, &c__132, dr, &dr[132], &dr[264], &dr[396],
+ &a[17424], &c__132, &a[34848], &a[52272], &a[69696], &
+ c__132, &a[87120], &c__132, &a[104544], &a[121968],
+ work, &c__89760, rwork, &c__6, &info);
+ if (info != 0) {
+ s_wsfe(&io___214);
+ do_fio(&c__1, "CCHKBD", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ if (tstdrv) {
+ cdrvbd_(&nn, mval, nval, &maxtyp, dotype, iseed, &thresh, a, &
+ c__132, &a[17424], &c__132, &a[34848], &c__132, &a[
+ 52272], &a[69696], &a[87120], dr, &dr[132], &dr[264],
+ work, &c__89760, rwork, iwork, &c__6, &info);
+ }
+/* L330: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "CEV")) {
+
+/* -------------------------------------------- */
+/* CEV: Nonsymmetric Eigenvalue Problem Driver */
+/* CGEEV (eigenvalues and eigenvectors) */
+/* -------------------------------------------- */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes <= 0) {
+ s_wsfe(&io___215);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ cerred_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ cdrvev_(&nn, nval, &ntypes, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &a[17424], dc, &dc[132], &a[34848], &c__132, &a[
+ 52272], &c__132, &a[69696], &c__132, result, work, &
+ c__89760, rwork, iwork, &info);
+ if (info != 0) {
+ s_wsfe(&io___216);
+ do_fio(&c__1, "CGEEV", (ftnlen)5);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___217);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "CES")) {
+
+/* -------------------------------------------- */
+/* CES: Nonsymmetric Eigenvalue Problem Driver */
+/* CGEES (Schur form) */
+/* -------------------------------------------- */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes <= 0) {
+ s_wsfe(&io___218);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ cerred_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ cdrves_(&nn, nval, &ntypes, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &a[17424], &a[34848], dc, &dc[132], &a[52272], &
+ c__132, result, work, &c__89760, rwork, iwork, logwrk, &
+ info);
+ if (info != 0) {
+ s_wsfe(&io___219);
+ do_fio(&c__1, "CGEES", (ftnlen)5);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___220);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "CVX")) {
+
+/* -------------------------------------------------------------- */
+/* CVX: Nonsymmetric Eigenvalue Problem Expert Driver */
+/* CGEEVX (eigenvalues, eigenvectors and condition numbers) */
+/* -------------------------------------------------------------- */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes < 0) {
+ s_wsfe(&io___221);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ cerred_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ cdrvvx_(&nn, nval, &ntypes, dotype, iseed, &thresh, &c__5, &c__6,
+ a, &c__132, &a[17424], dc, &dc[132], &a[34848], &c__132, &
+ a[52272], &c__132, &a[69696], &c__132, dr, &dr[132], &dr[
+ 264], &dr[396], &dr[528], &dr[660], &dr[792], &dr[924],
+ result, work, &c__89760, rwork, &info);
+ if (info != 0) {
+ s_wsfe(&io___222);
+ do_fio(&c__1, "CGEEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___223);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "CSX")) {
+
+/* --------------------------------------------------- */
+/* CSX: Nonsymmetric Eigenvalue Problem Expert Driver */
+/* CGEESX (Schur form and condition numbers) */
+/* --------------------------------------------------- */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes < 0) {
+ s_wsfe(&io___224);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ cerred_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ cdrvsx_(&nn, nval, &ntypes, dotype, iseed, &thresh, &c__5, &c__6,
+ a, &c__132, &a[17424], &a[34848], dc, &dc[132], &dc[264],
+ &a[52272], &c__132, &a[69696], result, work, &c__89760,
+ rwork, logwrk, &info);
+ if (info != 0) {
+ s_wsfe(&io___225);
+ do_fio(&c__1, "CGEESX", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___226);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "CGG")) {
+
+/* ------------------------------------------------- */
+/* CGG: Generalized Nonsymmetric Eigenvalue Problem */
+/* ------------------------------------------------- */
+/* Vary the parameters */
+/* NB = block size */
+/* NBMIN = minimum block size */
+/* NS = number of shifts */
+/* MAXB = minimum submatrix size */
+/* NBCOL = minimum column dimension for blocks */
+
+ maxtyp = 26;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ if (tstchk && tsterr) {
+ cerrgg_(c3, &c__6);
+ }
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xlaenv_(&c__1, &nbval[i__ - 1]);
+ xlaenv_(&c__2, &nbmin[i__ - 1]);
+ xlaenv_(&c__4, &nsval[i__ - 1]);
+ xlaenv_(&c__8, &mxbval[i__ - 1]);
+ xlaenv_(&c__5, &nbcol[i__ - 1]);
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L340: */
+ }
+ }
+ s_wsfe(&io___227);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbcol[i__ - 1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ tstdif = FALSE_;
+ thrshn = 10.f;
+ if (tstchk) {
+ cchkgg_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &tstdif, &
+ thrshn, &c__6, a, &c__132, &a[17424], &a[34848], &a[
+ 52272], &a[69696], &a[87120], &a[104544], &a[121968],
+ &a[139392], &c__132, &a[156816], &a[174240], &a[
+ 191664], dc, &dc[132], &dc[264], &dc[396], &a[209088],
+ &a[226512], work, &c__89760, rwork, logwrk, result, &
+ info);
+ if (info != 0) {
+ s_wsfe(&io___230);
+ do_fio(&c__1, "CCHKGG", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ xlaenv_(&c__1, &c__1);
+ if (tstdrv) {
+ cdrvgg_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &thrshn, &
+ c__6, a, &c__132, &a[17424], &a[34848], &a[52272], &a[
+ 69696], &a[87120], &a[104544], &c__132, &a[121968],
+ dc, &dc[132], &dc[264], &dc[396], &a[121968], &a[
+ 139392], work, &c__89760, rwork, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___231);
+ do_fio(&c__1, "CDRVGG", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+/* L350: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "CGS")) {
+
+/* ------------------------------------------------- */
+/* CGS: Generalized Nonsymmetric Eigenvalue Problem */
+/* CGGES (Schur form) */
+/* ------------------------------------------------- */
+
+ maxtyp = 26;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes <= 0) {
+ s_wsfe(&io___232);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ cerrgg_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ cdrges_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &a[17424], &a[34848], &a[52272], &a[104544], &
+ c__132, &a[121968], dc, &dc[132], work, &c__89760, rwork,
+ result, logwrk, &info);
+
+ if (info != 0) {
+ s_wsfe(&io___233);
+ do_fio(&c__1, "CDRGES", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___234);
+ e_wsfe();
+ goto L10;
+
+ } else if (cgx) {
+
+/* ------------------------------------------------- */
+/* CGX Generalized Nonsymmetric Eigenvalue Problem */
+/* CGGESX (Schur form and condition numbers) */
+/* ------------------------------------------------- */
+
+ maxtyp = 5;
+ ntypes = maxtyp;
+ if (nn < 0) {
+ s_wsfe(&io___235);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ cerrgg_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ xlaenv_(&c__5, &c__2);
+ cdrgsx_(&nn, &c__20, &thresh, &c__5, &c__6, a, &c__132, &a[17424],
+ &a[34848], &a[52272], &a[69696], &a[87120], dc, &dc[132],
+ c__, &c__400, s, work, &c__89760, rwork, iwork, &
+ c__20064, logwrk, &info);
+ if (info != 0) {
+ s_wsfe(&io___238);
+ do_fio(&c__1, "CDRGSX", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___239);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "CGV")) {
+
+/* ------------------------------------------------- */
+/* CGV: Generalized Nonsymmetric Eigenvalue Problem */
+/* CGGEV (Eigenvalue/vector form) */
+/* ------------------------------------------------- */
+
+ maxtyp = 26;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes <= 0) {
+ s_wsfe(&io___240);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ cerrgg_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ cdrgev_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &a[17424], &a[34848], &a[52272], &a[104544], &
+ c__132, &a[121968], &a[139392], &c__132, dc, &dc[132], &
+ dc[264], &dc[396], work, &c__89760, rwork, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___241);
+ do_fio(&c__1, "CDRGEV", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___242);
+ e_wsfe();
+ goto L10;
+
+ } else if (cxv) {
+
+/* ------------------------------------------------- */
+/* CXV: Generalized Nonsymmetric Eigenvalue Problem */
+/* CGGEVX (eigenvalue/vector with condition numbers) */
+/* ------------------------------------------------- */
+
+ maxtyp = 2;
+ ntypes = maxtyp;
+ if (nn < 0) {
+ s_wsfe(&io___243);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ cerrgg_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ cdrgvx_(&nn, &thresh, &c__5, &c__6, a, &c__132, &a[17424], &a[
+ 34848], &a[52272], dc, &dc[132], &a[69696], &a[87120],
+ iwork, &iwork[1], dr, &dr[132], &dr[264], &dr[396], &dr[
+ 528], &dr[660], work, &c__89760, rwork, &iwork[2], &
+ c__20062, result, logwrk, &info);
+
+ if (info != 0) {
+ s_wsfe(&io___244);
+ do_fio(&c__1, "CDRGVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___245);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "CHB")) {
+
+/* ------------------------------ */
+/* CHB: Hermitian Band Reduction */
+/* ------------------------------ */
+
+ maxtyp = 15;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ if (tsterr) {
+ cerrst_("CHB", &c__6);
+ }
+ cchkhb_(&nn, nval, &nk, kval, &maxtyp, dotype, iseed, &thresh, &c__6,
+ a, &c__132, dr, &dr[132], &a[17424], &c__132, work, &c__89760,
+ rwork, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___246);
+ do_fio(&c__1, "CCHKHB", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "CBB")) {
+
+/* ------------------------------ */
+/* CBB: General Band Reduction */
+/* ------------------------------ */
+
+ maxtyp = 15;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nrhs = nsval[i__ - 1];
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L360: */
+ }
+ }
+ s_wsfe(&io___247);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(integer));
+ e_wsfe();
+ cchkbb_(&nn, mval, nval, &nk, kval, &maxtyp, dotype, &nrhs, iseed,
+ &thresh, &c__6, a, &c__132, &a[17424], &c__264, dr, &dr[
+ 132], &a[52272], &c__132, &a[69696], &c__132, &a[87120], &
+ c__132, &a[104544], work, &c__89760, rwork, result, &info)
+ ;
+ if (info != 0) {
+ s_wsfe(&io___248);
+ do_fio(&c__1, "CCHKBB", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L370: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "GLM")) {
+
+/* ----------------------------------------- */
+/* GLM: Generalized Linear Regression Model */
+/* ----------------------------------------- */
+
+ xlaenv_(&c__1, &c__1);
+ if (tsterr) {
+ cerrgg_("GLM", &c__6);
+ }
+ cckglm_(&nn, nval, mval, pval, &ntypes, iseed, &thresh, &c__132, a, &
+ a[17424], b, &b[17424], x, work, dr, &c__5, &c__6, &info);
+ if (info != 0) {
+ s_wsfe(&io___251);
+ do_fio(&c__1, "CCKGLM", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "GQR")) {
+
+/* ------------------------------------------ */
+/* GQR: Generalized QR and RQ factorizations */
+/* ------------------------------------------ */
+
+ xlaenv_(&c__1, &c__1);
+ if (tsterr) {
+ cerrgg_("GQR", &c__6);
+ }
+ cckgqr_(&nn, mval, &nn, pval, &nn, nval, &ntypes, iseed, &thresh, &
+ c__132, a, &a[17424], &a[34848], &a[52272], taua, b, &b[17424]
+, &b[34848], &b[52272], &b[69696], taub, work, dr, &c__5, &
+ c__6, &info);
+ if (info != 0) {
+ s_wsfe(&io___254);
+ do_fio(&c__1, "CCKGQR", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "GSV")) {
+
+/* ---------------------------------------------- */
+/* GSV: Generalized Singular Value Decomposition */
+/* ---------------------------------------------- */
+
+ if (tsterr) {
+ cerrgg_("GSV", &c__6);
+ }
+ cckgsv_(&nn, mval, pval, nval, &ntypes, iseed, &thresh, &c__132, a, &
+ a[17424], b, &b[17424], &a[34848], &b[34848], &a[52272],
+ alpha, beta, &b[52272], iwork, work, dr, &c__5, &c__6, &info);
+ if (info != 0) {
+ s_wsfe(&io___257);
+ do_fio(&c__1, "CCKGSV", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "LSE")) {
+
+/* -------------------------------------- */
+/* LSE: Constrained Linear Least Squares */
+/* -------------------------------------- */
+
+ xlaenv_(&c__1, &c__1);
+ if (tsterr) {
+ cerrgg_("LSE", &c__6);
+ }
+ ccklse_(&nn, mval, pval, nval, &ntypes, iseed, &thresh, &c__132, a, &
+ a[17424], b, &b[17424], x, work, dr, &c__5, &c__6, &info);
+ if (info != 0) {
+ s_wsfe(&io___258);
+ do_fio(&c__1, "CCKLSE", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ s_wsle(&io___259);
+ e_wsle();
+ s_wsle(&io___260);
+ e_wsle();
+ s_wsfe(&io___261);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ }
+ if (! (cgx || cxv)) {
+ goto L190;
+ }
+L380:
+ s_wsfe(&io___262);
+ e_wsfe();
+ s2 = second_();
+ s_wsfe(&io___264);
+ r__1 = s2 - s1;
+ do_fio(&c__1, (char *)&r__1, (ftnlen)sizeof(real));
+ e_wsfe();
+
+/* L9998: */
+
+/* End of CCHKEE */
+
+ return 0;
+} /* MAIN__ */
+
+/* Main program alias */ int cchkee_ () { MAIN__ (); return 0; }
diff --git a/TESTING/EIG/cchkgg.c b/TESTING/EIG/cchkgg.c
new file mode 100644
index 0000000..f7f07d9
--- /dev/null
+++ b/TESTING/EIG/cchkgg.c
@@ -0,0 +1,1541 @@
+/* cchkgg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__4 = 4;
+static real c_b17 = 1.f;
+static integer c__3 = 3;
+static integer c__1 = 1;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+static integer c__2 = 2;
+
+/* Subroutine */ int cchkgg_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, logical *tstdif, real *
+ thrshn, integer *nounit, complex *a, integer *lda, complex *b,
+ complex *h__, complex *t, complex *s1, complex *s2, complex *p1,
+ complex *p2, complex *u, integer *ldu, complex *v, complex *q,
+ complex *z__, complex *alpha1, complex *beta1, complex *alpha3,
+ complex *beta3, complex *evectl, complex *evectr, complex *work,
+ integer *lwork, real *rwork, logical *llwork, real *result, integer *
+ info)
+{
+ /* Initialized data */
+
+ static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
+ 2,2,2,3 };
+ static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
+ 2,3,2,1 };
+ static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
+ 1,1,1,1 };
+ static logical lasign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ TRUE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,FALSE_,
+ TRUE_,FALSE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_ };
+ static logical lbsign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ FALSE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,FALSE_,
+ TRUE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ FALSE_ };
+ static integer kz1[6] = { 0,1,2,1,3,3 };
+ static integer kz2[6] = { 0,0,1,2,1,1 };
+ static integer kadd[6] = { 0,0,0,0,3,2 };
+ static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
+ 4,4,4,0 };
+ static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
+ 8,8,8,8,8,0 };
+ static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
+ 3,3,3,1 };
+ static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
+ 4,4,4,1 };
+ static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
+ 3,3,2,1 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 CCHKGG: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 CCHKGG: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
+ "i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9997[] = "(1x,a3,\002 -- Complex Generalized eigenvalue "
+ "problem\002)";
+ static char fmt_9996[] = "(\002 Matrix types (see CCHKGG for details):"
+ " \002)";
+ static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
+ "osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
+ ") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
+ "onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
+ "I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
+ "arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
+ "(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
+ "=(D, reversed D)\002)";
+ static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
+ "atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
+ " 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
+ "ha&beta \002,\002 20=arithmetic alpha, beta=0,"
+ "1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
+ "=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
+ "/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
+ "l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
+ ".\002)";
+ static char fmt_9993[] = "(/\002 Tests performed: (H is Hessenberg, S "
+ "is Schur, B, \002,\002T, P are triangular,\002,/20x,\002U, V, Q,"
+ " and Z are \002,a,\002, l and r are the\002,/20x,\002appropriate"
+ " left and right eigenvectors, resp., a is\002,/20x,\002alpha, b "
+ "is beta, and \002,a,\002 means \002,a,\002.)\002,/\002 1 = | A -"
+ " U H V\002,a,\002 | / ( |A| n ulp ) 2 = | B - U T V\002,a"
+ ",\002 | / ( |B| n ulp )\002,/\002 3 = | I - UU\002,a,\002 | / ( "
+ "n ulp ) 4 = | I - VV\002,a,\002 | / ( n ulp )\002,"
+ "/\002 5 = | H - Q S Z\002,a,\002 | / ( |H| n ulp )\002,6x,\0026 "
+ "= | T - Q P Z\002,a,\002 | / ( |T| n ulp )\002,/\002 7 = | I - QQ"
+ "\002,a,\002 | / ( n ulp ) 8 = | I - ZZ\002,a,\002 | "
+ "/ ( n ulp )\002,/\002 9 = max | ( b S - a P )\002,a,\002 l | / c"
+ "onst. 10 = max | ( b H - a T )\002,a,\002 l | / const.\002,/"
+ "\002 11= max | ( b S - a P ) r | / const. 12 = max | ( b H\002,"
+ "\002 - a T ) r | / const.\002,/1x)";
+ static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",0p,f8.2)";
+ static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",1p,e10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, evectl_dim1, evectl_offset,
+ evectr_dim1, evectr_offset, h_dim1, h_offset, p1_dim1, p1_offset,
+ p2_dim1, p2_offset, q_dim1, q_offset, s1_dim1, s1_offset, s2_dim1,
+ s2_offset, t_dim1, t_offset, u_dim1, u_offset, v_dim1, v_offset,
+ z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+ real r__1, r__2;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ double r_sign(real *, real *), c_abs(complex *);
+ void r_cnjg(complex *, complex *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer j, n, i1, n1, jc, in, jr;
+ real ulp;
+ integer iadd, nmax;
+ real temp1, temp2;
+ logical badnn;
+ extern /* Subroutine */ int cget51_(integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, complex *, real *, real *), cget52_(logical *, integer
+ *, complex *, integer *, complex *, integer *, complex *, integer
+ *, complex *, complex *, complex *, real *, real *);
+ real dumma[4];
+ integer iinfo;
+ real rmagn[4];
+ complex ctemp;
+ real anorm, bnorm;
+ integer nmats, jsize, nerrs, jtype, ntest;
+ extern /* Subroutine */ int cgeqr2_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *), clatm4_(integer *,
+ integer *, integer *, integer *, logical *, real *, real *, real *
+, integer *, integer *, complex *, integer *), cunm2r_(char *,
+ char *, integer *, integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *, complex *, integer *), slabad_(real *, real *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int cgghrd_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, complex *, integer *, integer *),
+ clarfg_(integer *, complex *, complex *, integer *, complex *);
+ extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+ complex cdumma[4];
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *);
+ real safmin, safmax;
+ integer ioldsd[4];
+ extern /* Subroutine */ int chgeqz_(char *, char *, char *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ complex *, complex *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, integer *),
+ ctgevc_(char *, char *, logical *, integer *, complex *, integer *
+, complex *, integer *, complex *, integer *, complex *, integer *
+, integer *, integer *, complex *, real *, integer *), xerbla_(char *, integer *), slasum_(char *,
+ integer *, integer *, integer *);
+ real ulpinv;
+ integer lwkopt, mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___68 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___69 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___70 = { 0, 0, 0, fmt_9991, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKGG checks the nonsymmetric generalized eigenvalue problem */
+/* routines. */
+/* H H H */
+/* CGGHRD factors A and B as U H V and U T V , where means conjugate */
+/* transpose, H is hessenberg, T is triangular and U and V are unitary. */
+
+/* H H */
+/* CHGEQZ factors H and T as Q S Z and Q P Z , where P and S are upper */
+/* triangular and Q and Z are unitary. It also computes the generalized */
+/* eigenvalues (alpha(1),beta(1)),...,(alpha(n),beta(n)), where */
+/* alpha(j)=S(j,j) and beta(j)=P(j,j) -- thus, w(j) = alpha(j)/beta(j) */
+/* is a root of the generalized eigenvalue problem */
+
+/* det( A - w(j) B ) = 0 */
+
+/* and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent */
+/* problem */
+
+/* det( m(j) A - B ) = 0 */
+
+/* CTGEVC computes the matrix L of left eigenvectors and the matrix R */
+/* of right eigenvectors for the matrix pair ( S, P ). In the */
+/* description below, l and r are left and right eigenvectors */
+/* corresponding to the generalized eigenvalues (alpha,beta). */
+
+/* When CCHKGG is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 13 */
+/* tests will be performed. The first twelve "test ratios" should be */
+/* small -- O(1). They will be compared with the threshhold THRESH: */
+
+/* H */
+/* (1) | A - U H V | / ( |A| n ulp ) */
+
+/* H */
+/* (2) | B - U T V | / ( |B| n ulp ) */
+
+/* H */
+/* (3) | I - UU | / ( n ulp ) */
+
+/* H */
+/* (4) | I - VV | / ( n ulp ) */
+
+/* H */
+/* (5) | H - Q S Z | / ( |H| n ulp ) */
+
+/* H */
+/* (6) | T - Q P Z | / ( |T| n ulp ) */
+
+/* H */
+/* (7) | I - QQ | / ( n ulp ) */
+
+/* H */
+/* (8) | I - ZZ | / ( n ulp ) */
+
+/* (9) max over all left eigenvalue/-vector pairs (beta/alpha,l) of */
+/* H */
+/* | (beta A - alpha B) l | / ( ulp max( |beta A|, |alpha B| ) ) */
+
+/* (10) max over all left eigenvalue/-vector pairs (beta/alpha,l') of */
+/* H */
+/* | (beta H - alpha T) l' | / ( ulp max( |beta H|, |alpha T| ) ) */
+
+/* where the eigenvectors l' are the result of passing Q to */
+/* STGEVC and back transforming (JOB='B'). */
+
+/* (11) max over all right eigenvalue/-vector pairs (beta/alpha,r) of */
+
+/* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) ) */
+
+/* (12) max over all right eigenvalue/-vector pairs (beta/alpha,r') of */
+
+/* | (beta H - alpha T) r' | / ( ulp max( |beta H|, |alpha T| ) ) */
+
+/* where the eigenvectors r' are the result of passing Z to */
+/* STGEVC and back transforming (JOB='B'). */
+
+/* The last three test ratios will usually be small, but there is no */
+/* mathematical requirement that they be so. They are therefore */
+/* compared with THRESH only if TSTDIF is .TRUE. */
+
+/* (13) | S(Q,Z computed) - S(Q,Z not computed) | / ( |S| ulp ) */
+
+/* (14) | P(Q,Z computed) - P(Q,Z not computed) | / ( |P| ulp ) */
+
+/* (15) max( |alpha(Q,Z computed) - alpha(Q,Z not computed)|/|S| , */
+/* |beta(Q,Z computed) - beta(Q,Z not computed)|/|P| ) / ulp */
+
+/* In addition, the normalization of L and R are checked, and compared */
+/* with the threshhold THRSHN. */
+
+/* Test Matrices */
+/* ---- -------- */
+
+/* The sizes of the test matrices are specified by an array */
+/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
+/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) ( 0, 0 ) (a pair of zero matrices) */
+
+/* (2) ( I, 0 ) (an identity and a zero matrix) */
+
+/* (3) ( 0, I ) (an identity and a zero matrix) */
+
+/* (4) ( I, I ) (a pair of identity matrices) */
+
+/* t t */
+/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
+
+/* t ( I 0 ) */
+/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
+/* ( 0 I ) ( 0 J ) */
+/* and I is a k x k identity and J a (k+1)x(k+1) */
+/* Jordan block; k=(N-1)/2 */
+
+/* (7) ( D, I ) where D is P*D1, P is a random unitary diagonal */
+/* matrix (i.e., with random magnitude 1 entries */
+/* on the diagonal), and D1=diag( 0, 1,..., N-1 ) */
+/* (i.e., a diagonal matrix with D1(1,1)=0, */
+/* D1(2,2)=1, ..., D1(N,N)=N-1.) */
+/* (8) ( I, D ) */
+
+/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
+
+/* (10) ( small*D, big*I ) */
+
+/* (11) ( big*I, small*D ) */
+
+/* (12) ( small*I, big*D ) */
+
+/* (13) ( big*D, big*I ) */
+
+/* (14) ( small*D, small*I ) */
+
+/* (15) ( D1, D2 ) where D1=P*diag( 0, 0, 1, ..., N-3, 0 ) and */
+/* D2=Q*diag( 0, N-3, N-4,..., 1, 0, 0 ), and */
+/* P and Q are random unitary diagonal matrices. */
+/* t t */
+/* (16) U ( J , J ) V where U and V are random unitary matrices. */
+
+/* (17) U ( T1, T2 ) V where T1 and T2 are upper triangular matrices */
+/* with random O(1) entries above the diagonal */
+/* and diagonal entries diag(T1) = */
+/* P*( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
+/* Q*( 0, N-3, N-4,..., 1, 0, 0 ) */
+
+/* (18) U ( T1, T2 ) V diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
+/* s = machine precision. */
+
+/* (19) U ( T1, T2 ) V diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
+
+/* N-5 */
+/* (20) U ( T1, T2 ) V diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+
+/* (21) U ( T1, T2 ) V diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+/* where r1,..., r(N-4) are random. */
+
+/* (22) U ( big*T1, small*T2 ) V diag(T1) = P*( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (23) U ( small*T1, big*T2 ) V diag(T1) = P*( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (24) U ( small*T1, small*T2 ) V diag(T1) = P*( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (25) U ( big*T1, big*T2 ) V diag(T1) = P*( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (26) U ( T1, T2 ) V where T1 and T2 are random upper-triangular */
+/* matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* CCHKGG does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, CCHKGG */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to CCHKGG to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* TSTDIF (input) LOGICAL */
+/* Specifies whether test ratios 13-15 will be computed and */
+/* compared with THRESH. */
+/* = .FALSE.: Only test ratios 1-12 will be computed and tested. */
+/* Ratios 13-15 will be set to zero. */
+/* = .TRUE.: All the test ratios 1-15 will be computed and */
+/* tested. */
+
+/* THRSHN (input) REAL */
+/* Threshhold for reporting eigenvector normalization error. */
+/* If the normalization of any eigenvector differs from 1 by */
+/* more than THRSHN*ulp, then a special error message will be */
+/* printed. (This is handled separately from the other tests, */
+/* since only a compiler or programming error should cause an */
+/* error message, at least if THRSHN is at least 5--10.) */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* Used to hold the original A matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, H, T, S1, P1, S2, and P2. */
+/* It must be at least 1 and at least max( NN ). */
+
+/* B (input/workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* Used to hold the original B matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* H (workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* The upper Hessenberg matrix computed from A by CGGHRD. */
+
+/* T (workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from B by CGGHRD. */
+
+/* S1 (workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* The Schur (upper triangular) matrix computed from H by CHGEQZ */
+/* when Q and Z are also computed. */
+
+/* S2 (workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* The Schur (upper triangular) matrix computed from H by CHGEQZ */
+/* when Q and Z are not computed. */
+
+/* P1 (workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from T by CHGEQZ */
+/* when Q and Z are also computed. */
+
+/* P2 (workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from T by CHGEQZ */
+/* when Q and Z are not computed. */
+
+/* U (workspace) COMPLEX array, dimension (LDU, max(NN)) */
+/* The (left) unitary matrix computed by CGGHRD. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U, V, Q, Z, EVECTL, and EVECTR. It */
+/* must be at least 1 and at least max( NN ). */
+
+/* V (workspace) COMPLEX array, dimension (LDU, max(NN)) */
+/* The (right) unitary matrix computed by CGGHRD. */
+
+/* Q (workspace) COMPLEX array, dimension (LDU, max(NN)) */
+/* The (left) unitary matrix computed by CHGEQZ. */
+
+/* Z (workspace) COMPLEX array, dimension (LDU, max(NN)) */
+/* The (left) unitary matrix computed by CHGEQZ. */
+
+/* ALPHA1 (workspace) COMPLEX array, dimension (max(NN)) */
+/* BETA1 (workspace) COMPLEX array, dimension (max(NN)) */
+/* The generalized eigenvalues of (A,B) computed by CHGEQZ */
+/* when Q, Z, and the full Schur matrices are computed. */
+
+/* ALPHA3 (workspace) COMPLEX array, dimension (max(NN)) */
+/* BETA3 (workspace) COMPLEX array, dimension (max(NN)) */
+/* The generalized eigenvalues of (A,B) computed by CHGEQZ */
+/* when neither Q, Z, nor the Schur matrices are computed. */
+
+/* EVECTL (workspace) COMPLEX array, dimension (LDU, max(NN)) */
+/* The (lower triangular) left eigenvector matrix for the */
+/* matrices in S1 and P1. */
+
+/* EVECTR (workspace) COMPLEX array, dimension (LDU, max(NN)) */
+/* The (upper triangular) right eigenvector matrix for the */
+/* matrices in S1 and P1. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* max( 4*N, 2 * N**2, 1 ), for all N=NN(j). */
+
+/* RWORK (workspace) REAL array, dimension (2*max(NN)) */
+
+/* LLWORK (workspace) LOGICAL array, dimension (max(NN)) */
+
+/* RESULT (output) REAL array, dimension (15) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: A routine returned an error code. INFO is the */
+/* absolute value of the INFO value returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ p2_dim1 = *lda;
+ p2_offset = 1 + p2_dim1;
+ p2 -= p2_offset;
+ p1_dim1 = *lda;
+ p1_offset = 1 + p1_dim1;
+ p1 -= p1_offset;
+ s2_dim1 = *lda;
+ s2_offset = 1 + s2_dim1;
+ s2 -= s2_offset;
+ s1_dim1 = *lda;
+ s1_offset = 1 + s1_dim1;
+ s1 -= s1_offset;
+ t_dim1 = *lda;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ evectr_dim1 = *ldu;
+ evectr_offset = 1 + evectr_dim1;
+ evectr -= evectr_offset;
+ evectl_dim1 = *ldu;
+ evectl_offset = 1 + evectl_dim1;
+ evectl -= evectl_offset;
+ z_dim1 = *ldu;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ q_dim1 = *ldu;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ v_dim1 = *ldu;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --alpha1;
+ --beta1;
+ --alpha3;
+ --beta3;
+ --work;
+ --rwork;
+ --llwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Computing MAX */
+ i__1 = (nmax << 1) * nmax, i__2 = nmax << 2, i__1 = max(i__1,i__2);
+ lwkopt = max(i__1,1);
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.f) {
+ *info = -6;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -10;
+ } else if (*ldu <= 1 || *ldu < nmax) {
+ *info = -19;
+ } else if (lwkopt > *lwork) {
+ *info = -30;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CCHKGG", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+ safmin = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ safmin /= ulp;
+ safmax = 1.f / safmin;
+ slabad_(&safmin, &safmax);
+ ulpinv = 1.f / ulp;
+
+/* The values RMAGN(2:3) depend on N, see below. */
+
+ rmagn[0] = 0.f;
+ rmagn[1] = 1.f;
+
+/* Loop over sizes, types */
+
+ ntestt = 0;
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ n1 = max(1,n);
+ rmagn[2] = safmax * ulp / (real) n1;
+ rmagn[3] = safmin * ulpinv * n1;
+
+ if (*nsizes != 1) {
+ mtypes = min(26,*ntypes);
+ } else {
+ mtypes = min(27,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L230;
+ }
+ ++nmats;
+ ntest = 0;
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 15; ++j) {
+ result[j] = 0.f;
+/* L30: */
+ }
+
+/* Compute A and B */
+
+/* Description of control parameters: */
+
+/* KCLASS: =1 means w/o rotation, =2 means w/ rotation, */
+/* =3 means random. */
+/* KATYPE: the "type" to be passed to CLATM4 for computing A. */
+/* KAZERO: the pattern of zeros on the diagonal for A: */
+/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
+/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
+/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
+/* non-zero entries.) */
+/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
+/* =2: large, =3: small. */
+/* LASIGN: .TRUE. if the diagonal elements of A are to be */
+/* multiplied by a random magnitude 1 number. */
+/* KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B. */
+/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
+/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
+/* RMAGN: used to implement KAMAGN and KBMAGN. */
+
+ if (mtypes > 26) {
+ goto L110;
+ }
+ iinfo = 0;
+ if (kclass[jtype - 1] < 3) {
+
+/* Generate A (w/o rotation) */
+
+ if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ claset_("Full", &n, &n, &c_b1, &c_b1, &a[a_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ clatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
+ &kz2[kazero[jtype - 1] - 1], &lasign[jtype - 1], &
+ rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
+ 1] * kamagn[jtype - 1]], &c__4, &iseed[1], &a[
+ a_offset], lda);
+ iadd = kadd[kazero[jtype - 1] - 1];
+ if (iadd > 0 && iadd <= n) {
+ i__3 = iadd + iadd * a_dim1;
+ i__4 = kamagn[jtype - 1];
+ a[i__3].r = rmagn[i__4], a[i__3].i = 0.f;
+ }
+
+/* Generate B (w/o rotation) */
+
+ if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ claset_("Full", &n, &n, &c_b1, &c_b1, &b[b_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ clatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
+ &kz2[kbzero[jtype - 1] - 1], &lbsign[jtype - 1], &
+ rmagn[kbmagn[jtype - 1]], &c_b17, &rmagn[ktrian[jtype
+ - 1] * kbmagn[jtype - 1]], &c__4, &iseed[1], &b[
+ b_offset], lda);
+ iadd = kadd[kbzero[jtype - 1] - 1];
+ if (iadd != 0) {
+ i__3 = iadd + iadd * b_dim1;
+ i__4 = kbmagn[jtype - 1];
+ b[i__3].r = rmagn[i__4], b[i__3].i = 0.f;
+ }
+
+ if (kclass[jtype - 1] == 2 && n > 0) {
+
+/* Include rotations */
+
+/* Generate U, V as Householder transformations times a */
+/* diagonal matrix. (Note that CLARFG makes U(j,j) and */
+/* V(j,j) real.) */
+
+ i__3 = n - 1;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = jc; jr <= i__4; ++jr) {
+ i__5 = jr + jc * u_dim1;
+ clarnd_(&q__1, &c__3, &iseed[1]);
+ u[i__5].r = q__1.r, u[i__5].i = q__1.i;
+ i__5 = jr + jc * v_dim1;
+ clarnd_(&q__1, &c__3, &iseed[1]);
+ v[i__5].r = q__1.r, v[i__5].i = q__1.i;
+/* L40: */
+ }
+ i__4 = n + 1 - jc;
+ clarfg_(&i__4, &u[jc + jc * u_dim1], &u[jc + 1 + jc *
+ u_dim1], &c__1, &work[jc]);
+ i__4 = (n << 1) + jc;
+ i__5 = jc + jc * u_dim1;
+ r__2 = u[i__5].r;
+ r__1 = r_sign(&c_b17, &r__2);
+ work[i__4].r = r__1, work[i__4].i = 0.f;
+ i__4 = jc + jc * u_dim1;
+ u[i__4].r = 1.f, u[i__4].i = 0.f;
+ i__4 = n + 1 - jc;
+ clarfg_(&i__4, &v[jc + jc * v_dim1], &v[jc + 1 + jc *
+ v_dim1], &c__1, &work[n + jc]);
+ i__4 = n * 3 + jc;
+ i__5 = jc + jc * v_dim1;
+ r__2 = v[i__5].r;
+ r__1 = r_sign(&c_b17, &r__2);
+ work[i__4].r = r__1, work[i__4].i = 0.f;
+ i__4 = jc + jc * v_dim1;
+ v[i__4].r = 1.f, v[i__4].i = 0.f;
+/* L50: */
+ }
+ clarnd_(&q__1, &c__3, &iseed[1]);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__3 = n + n * u_dim1;
+ u[i__3].r = 1.f, u[i__3].i = 0.f;
+ i__3 = n;
+ work[i__3].r = 0.f, work[i__3].i = 0.f;
+ i__3 = n * 3;
+ r__1 = c_abs(&ctemp);
+ q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ clarnd_(&q__1, &c__3, &iseed[1]);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__3 = n + n * v_dim1;
+ v[i__3].r = 1.f, v[i__3].i = 0.f;
+ i__3 = n << 1;
+ work[i__3].r = 0.f, work[i__3].i = 0.f;
+ i__3 = n << 2;
+ r__1 = c_abs(&ctemp);
+ q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+
+/* Apply the diagonal matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ i__5 = jr + jc * a_dim1;
+ i__6 = (n << 1) + jr;
+ r_cnjg(&q__3, &work[n * 3 + jc]);
+ q__2.r = work[i__6].r * q__3.r - work[i__6].i *
+ q__3.i, q__2.i = work[i__6].r * q__3.i +
+ work[i__6].i * q__3.r;
+ i__7 = jr + jc * a_dim1;
+ q__1.r = q__2.r * a[i__7].r - q__2.i * a[i__7].i,
+ q__1.i = q__2.r * a[i__7].i + q__2.i * a[
+ i__7].r;
+ a[i__5].r = q__1.r, a[i__5].i = q__1.i;
+ i__5 = jr + jc * b_dim1;
+ i__6 = (n << 1) + jr;
+ r_cnjg(&q__3, &work[n * 3 + jc]);
+ q__2.r = work[i__6].r * q__3.r - work[i__6].i *
+ q__3.i, q__2.i = work[i__6].r * q__3.i +
+ work[i__6].i * q__3.r;
+ i__7 = jr + jc * b_dim1;
+ q__1.r = q__2.r * b[i__7].r - q__2.i * b[i__7].i,
+ q__1.i = q__2.r * b[i__7].i + q__2.i * b[
+ i__7].r;
+ b[i__5].r = q__1.r, b[i__5].i = q__1.i;
+/* L60: */
+ }
+/* L70: */
+ }
+ i__3 = n - 1;
+ cunm2r_("L", "N", &n, &n, &i__3, &u[u_offset], ldu, &work[
+ 1], &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ cunm2r_("R", "C", &n, &n, &i__3, &v[v_offset], ldu, &work[
+ n + 1], &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ cunm2r_("L", "N", &n, &n, &i__3, &u[u_offset], ldu, &work[
+ 1], &b[b_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ cunm2r_("R", "C", &n, &n, &i__3, &v[v_offset], ldu, &work[
+ n + 1], &b[b_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ }
+ } else {
+
+/* Random matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ i__5 = jr + jc * a_dim1;
+ i__6 = kamagn[jtype - 1];
+ clarnd_(&q__2, &c__4, &iseed[1]);
+ q__1.r = rmagn[i__6] * q__2.r, q__1.i = rmagn[i__6] *
+ q__2.i;
+ a[i__5].r = q__1.r, a[i__5].i = q__1.i;
+ i__5 = jr + jc * b_dim1;
+ i__6 = kbmagn[jtype - 1];
+ clarnd_(&q__2, &c__4, &iseed[1]);
+ q__1.r = rmagn[i__6] * q__2.r, q__1.i = rmagn[i__6] *
+ q__2.i;
+ b[i__5].r = q__1.r, b[i__5].i = q__1.i;
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+
+ anorm = clange_("1", &n, &n, &a[a_offset], lda, &rwork[1]);
+ bnorm = clange_("1", &n, &n, &b[b_offset], lda, &rwork[1]);
+
+L100:
+
+ if (iinfo != 0) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L110:
+
+/* Call CGEQR2, CUNM2R, and CGGHRD to compute H, T, U, and V */
+
+ clacpy_(" ", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+ clacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ ntest = 1;
+ result[1] = ulpinv;
+
+ cgeqr2_(&n, &n, &t[t_offset], lda, &work[1], &work[n + 1], &iinfo)
+ ;
+ if (iinfo != 0) {
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "CGEQR2", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ cunm2r_("L", "C", &n, &n, &n, &t[t_offset], lda, &work[1], &h__[
+ h_offset], lda, &work[n + 1], &iinfo);
+ if (iinfo != 0) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "CUNM2R", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ claset_("Full", &n, &n, &c_b1, &c_b2, &u[u_offset], ldu);
+ cunm2r_("R", "N", &n, &n, &n, &t[t_offset], lda, &work[1], &u[
+ u_offset], ldu, &work[n + 1], &iinfo);
+ if (iinfo != 0) {
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "CUNM2R", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ cgghrd_("V", "I", &n, &c__1, &n, &h__[h_offset], lda, &t[t_offset]
+, lda, &u[u_offset], ldu, &v[v_offset], ldu, &iinfo);
+ if (iinfo != 0) {
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "CGGHRD", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+ ntest = 4;
+
+/* Do tests 1--4 */
+
+ cget51_(&c__1, &n, &a[a_offset], lda, &h__[h_offset], lda, &u[
+ u_offset], ldu, &v[v_offset], ldu, &work[1], &rwork[1], &
+ result[1]);
+ cget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &u[
+ u_offset], ldu, &v[v_offset], ldu, &work[1], &rwork[1], &
+ result[2]);
+ cget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &u[
+ u_offset], ldu, &u[u_offset], ldu, &work[1], &rwork[1], &
+ result[3]);
+ cget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &v[
+ v_offset], ldu, &v[v_offset], ldu, &work[1], &rwork[1], &
+ result[4]);
+
+/* Call CHGEQZ to compute S1, P1, S2, P2, Q, and Z, do tests. */
+
+/* Compute T1 and UZ */
+
+/* Eigenvalues only */
+
+ clacpy_(" ", &n, &n, &h__[h_offset], lda, &s2[s2_offset], lda);
+ clacpy_(" ", &n, &n, &t[t_offset], lda, &p2[p2_offset], lda);
+ ntest = 5;
+ result[5] = ulpinv;
+
+ chgeqz_("E", "N", "N", &n, &c__1, &n, &s2[s2_offset], lda, &p2[
+ p2_offset], lda, &alpha3[1], &beta3[1], &q[q_offset], ldu,
+ &z__[z_offset], ldu, &work[1], lwork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, "CHGEQZ(E)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+/* Eigenvalues and Full Schur Form */
+
+ clacpy_(" ", &n, &n, &h__[h_offset], lda, &s2[s2_offset], lda);
+ clacpy_(" ", &n, &n, &t[t_offset], lda, &p2[p2_offset], lda);
+
+ chgeqz_("S", "N", "N", &n, &c__1, &n, &s2[s2_offset], lda, &p2[
+ p2_offset], lda, &alpha1[1], &beta1[1], &q[q_offset], ldu,
+ &z__[z_offset], ldu, &work[1], lwork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ do_fio(&c__1, "CHGEQZ(S)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+/* Eigenvalues, Schur Form, and Schur Vectors */
+
+ clacpy_(" ", &n, &n, &h__[h_offset], lda, &s1[s1_offset], lda);
+ clacpy_(" ", &n, &n, &t[t_offset], lda, &p1[p1_offset], lda);
+
+ chgeqz_("S", "I", "I", &n, &c__1, &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, &alpha1[1], &beta1[1], &q[q_offset], ldu,
+ &z__[z_offset], ldu, &work[1], lwork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___48.ciunit = *nounit;
+ s_wsfe(&io___48);
+ do_fio(&c__1, "CHGEQZ(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ ntest = 8;
+
+/* Do Tests 5--8 */
+
+ cget51_(&c__1, &n, &h__[h_offset], lda, &s1[s1_offset], lda, &q[
+ q_offset], ldu, &z__[z_offset], ldu, &work[1], &rwork[1],
+ &result[5]);
+ cget51_(&c__1, &n, &t[t_offset], lda, &p1[p1_offset], lda, &q[
+ q_offset], ldu, &z__[z_offset], ldu, &work[1], &rwork[1],
+ &result[6]);
+ cget51_(&c__3, &n, &t[t_offset], lda, &p1[p1_offset], lda, &q[
+ q_offset], ldu, &q[q_offset], ldu, &work[1], &rwork[1], &
+ result[7]);
+ cget51_(&c__3, &n, &t[t_offset], lda, &p1[p1_offset], lda, &z__[
+ z_offset], ldu, &z__[z_offset], ldu, &work[1], &rwork[1],
+ &result[8]);
+
+/* Compute the Left and Right Eigenvectors of (S1,P1) */
+
+/* 9: Compute the left eigenvector Matrix without */
+/* back transforming: */
+
+ ntest = 9;
+ result[9] = ulpinv;
+
+/* To test "SELECT" option, compute half of the eigenvectors */
+/* in one call, and half in another */
+
+ i1 = n / 2;
+ i__3 = i1;
+ for (j = 1; j <= i__3; ++j) {
+ llwork[j] = TRUE_;
+/* L120: */
+ }
+ i__3 = n;
+ for (j = i1 + 1; j <= i__3; ++j) {
+ llwork[j] = FALSE_;
+/* L130: */
+ }
+
+ ctgevc_("L", "S", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, &evectl[evectl_offset], ldu, cdumma, ldu,
+ &n, &in, &work[1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "CTGEVC(L,S1)", (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ i1 = in;
+ i__3 = i1;
+ for (j = 1; j <= i__3; ++j) {
+ llwork[j] = FALSE_;
+/* L140: */
+ }
+ i__3 = n;
+ for (j = i1 + 1; j <= i__3; ++j) {
+ llwork[j] = TRUE_;
+/* L150: */
+ }
+
+ ctgevc_("L", "S", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, &evectl[(i1 + 1) * evectl_dim1 + 1], ldu,
+ cdumma, ldu, &n, &in, &work[1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "CTGEVC(L,S2)", (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ cget52_(&c_true, &n, &s1[s1_offset], lda, &p1[p1_offset], lda, &
+ evectl[evectl_offset], ldu, &alpha1[1], &beta1[1], &work[
+ 1], &rwork[1], dumma);
+ result[9] = dumma[0];
+ if (dumma[1] > *thrshn) {
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "CTGEVC(HOWMNY=S)", (ftnlen)16);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* 10: Compute the left eigenvector Matrix with */
+/* back transforming: */
+
+ ntest = 10;
+ result[10] = ulpinv;
+ clacpy_("F", &n, &n, &q[q_offset], ldu, &evectl[evectl_offset],
+ ldu);
+ ctgevc_("L", "B", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, &evectl[evectl_offset], ldu, cdumma, ldu,
+ &n, &in, &work[1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+ do_fio(&c__1, "CTGEVC(L,B)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ cget52_(&c_true, &n, &h__[h_offset], lda, &t[t_offset], lda, &
+ evectl[evectl_offset], ldu, &alpha1[1], &beta1[1], &work[
+ 1], &rwork[1], dumma);
+ result[10] = dumma[0];
+ if (dumma[1] > *thrshn) {
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "CTGEVC(HOWMNY=B)", (ftnlen)16);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* 11: Compute the right eigenvector Matrix without */
+/* back transforming: */
+
+ ntest = 11;
+ result[11] = ulpinv;
+
+/* To test "SELECT" option, compute half of the eigenvectors */
+/* in one call, and half in another */
+
+ i1 = n / 2;
+ i__3 = i1;
+ for (j = 1; j <= i__3; ++j) {
+ llwork[j] = TRUE_;
+/* L160: */
+ }
+ i__3 = n;
+ for (j = i1 + 1; j <= i__3; ++j) {
+ llwork[j] = FALSE_;
+/* L170: */
+ }
+
+ ctgevc_("R", "S", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, cdumma, ldu, &evectr[evectr_offset], ldu,
+ &n, &in, &work[1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, "CTGEVC(R,S1)", (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ i1 = in;
+ i__3 = i1;
+ for (j = 1; j <= i__3; ++j) {
+ llwork[j] = FALSE_;
+/* L180: */
+ }
+ i__3 = n;
+ for (j = i1 + 1; j <= i__3; ++j) {
+ llwork[j] = TRUE_;
+/* L190: */
+ }
+
+ ctgevc_("R", "S", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, cdumma, ldu, &evectr[(i1 + 1) *
+ evectr_dim1 + 1], ldu, &n, &in, &work[1], &rwork[1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ do_fio(&c__1, "CTGEVC(R,S2)", (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ cget52_(&c_false, &n, &s1[s1_offset], lda, &p1[p1_offset], lda, &
+ evectr[evectr_offset], ldu, &alpha1[1], &beta1[1], &work[
+ 1], &rwork[1], dumma);
+ result[11] = dumma[0];
+ if (dumma[1] > *thresh) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "CTGEVC(HOWMNY=S)", (ftnlen)16);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* 12: Compute the right eigenvector Matrix with */
+/* back transforming: */
+
+ ntest = 12;
+ result[12] = ulpinv;
+ clacpy_("F", &n, &n, &z__[z_offset], ldu, &evectr[evectr_offset],
+ ldu);
+ ctgevc_("R", "B", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, cdumma, ldu, &evectr[evectr_offset], ldu,
+ &n, &in, &work[1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___60.ciunit = *nounit;
+ s_wsfe(&io___60);
+ do_fio(&c__1, "CTGEVC(R,B)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ cget52_(&c_false, &n, &h__[h_offset], lda, &t[t_offset], lda, &
+ evectr[evectr_offset], ldu, &alpha1[1], &beta1[1], &work[
+ 1], &rwork[1], dumma);
+ result[12] = dumma[0];
+ if (dumma[1] > *thresh) {
+ io___61.ciunit = *nounit;
+ s_wsfe(&io___61);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "CTGEVC(HOWMNY=B)", (ftnlen)16);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Tests 13--15 are done only on request */
+
+ if (*tstdif) {
+
+/* Do Tests 13--14 */
+
+ cget51_(&c__2, &n, &s1[s1_offset], lda, &s2[s2_offset], lda, &
+ q[q_offset], ldu, &z__[z_offset], ldu, &work[1], &
+ rwork[1], &result[13]);
+ cget51_(&c__2, &n, &p1[p1_offset], lda, &p2[p2_offset], lda, &
+ q[q_offset], ldu, &z__[z_offset], ldu, &work[1], &
+ rwork[1], &result[14]);
+
+/* Do Test 15 */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = j;
+ i__5 = j;
+ q__1.r = alpha1[i__4].r - alpha3[i__5].r, q__1.i = alpha1[
+ i__4].i - alpha3[i__5].i;
+ r__1 = temp1, r__2 = c_abs(&q__1);
+ temp1 = dmax(r__1,r__2);
+/* Computing MAX */
+ i__4 = j;
+ i__5 = j;
+ q__1.r = beta1[i__4].r - beta3[i__5].r, q__1.i = beta1[
+ i__4].i - beta3[i__5].i;
+ r__1 = temp2, r__2 = c_abs(&q__1);
+ temp2 = dmax(r__1,r__2);
+/* L200: */
+ }
+
+/* Computing MAX */
+ r__1 = safmin, r__2 = ulp * dmax(temp1,anorm);
+ temp1 /= dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = safmin, r__2 = ulp * dmax(temp2,bnorm);
+ temp2 /= dmax(r__1,r__2);
+ result[15] = dmax(temp1,temp2);
+ ntest = 15;
+ } else {
+ result[13] = 0.f;
+ result[14] = 0.f;
+ result[15] = 0.f;
+ ntest = 12;
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L210:
+
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__3 = ntest;
+ for (jr = 1; jr <= i__3; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___64.ciunit = *nounit;
+ s_wsfe(&io___64);
+ do_fio(&c__1, "CGG", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___65.ciunit = *nounit;
+ s_wsfe(&io___65);
+ e_wsfe();
+ io___66.ciunit = *nounit;
+ s_wsfe(&io___66);
+ e_wsfe();
+ io___67.ciunit = *nounit;
+ s_wsfe(&io___67);
+ do_fio(&c__1, "Unitary", (ftnlen)7);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___68.ciunit = *nounit;
+ s_wsfe(&io___68);
+ do_fio(&c__1, "unitary", (ftnlen)7);
+ do_fio(&c__1, "*", (ftnlen)1);
+ do_fio(&c__1, "conjugate transpose", (ftnlen)19);
+ for (j = 1; j <= 10; ++j) {
+ do_fio(&c__1, "*", (ftnlen)1);
+ }
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[jr] < 1e4f) {
+ io___69.ciunit = *nounit;
+ s_wsfe(&io___69);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ } else {
+ io___70.ciunit = *nounit;
+ s_wsfe(&io___70);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ }
+ }
+/* L220: */
+ }
+
+L230:
+ ;
+ }
+/* L240: */
+ }
+
+/* Summary */
+
+ slasum_("CGG", nounit, &nerrs, &ntestt);
+ return 0;
+
+
+
+
+
+
+
+
+/* End of CCHKGG */
+
+} /* cchkgg_ */
diff --git a/TESTING/EIG/cchkgk.c b/TESTING/EIG/cchkgk.c
new file mode 100644
index 0000000..f5a85b7
--- /dev/null
+++ b/TESTING/EIG/cchkgk.c
@@ -0,0 +1,362 @@
+/* cchkgk.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__6 = 6;
+static integer c__50 = 50;
+
+/* Subroutine */ int cchkgk_(integer *nin, integer *nout)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002.. test output of CGGBAK .. \002)";
+ static char fmt_9998[] = "(\002 value of largest test error "
+ " =\002,e12.3)";
+ static char fmt_9997[] = "(\002 example number where CGGBAL info is not "
+ "0 =\002,i4)";
+ static char fmt_9996[] = "(\002 example number where CGGBAK(L) info is n"
+ "ot 0 =\002,i4)";
+ static char fmt_9995[] = "(\002 example number where CGGBAK(R) info is n"
+ "ot 0 =\002,i4)";
+ static char fmt_9994[] = "(\002 example number having largest error "
+ " =\002,i4)";
+ static char fmt_9992[] = "(\002 number of examples where info is not 0 "
+ " =\002,i4)";
+ static char fmt_9991[] = "(\002 total number of examples tested "
+ " =\002,i4)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+ double r_imag(complex *);
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ complex a[2500] /* was [50][50] */, b[2500] /* was [50][50] */, e[
+ 2500] /* was [50][50] */, f[2500] /* was [50][50] */;
+ integer i__, j, m, n;
+ complex af[2500] /* was [50][50] */, bf[2500] /* was [50][50] */,
+ vl[2500] /* was [50][50] */, vr[2500] /* was [50][50] */;
+ integer ihi, ilo;
+ real eps;
+ complex vlf[2500] /* was [50][50] */;
+ integer knt;
+ complex vrf[2500] /* was [50][50] */;
+ integer info, lmax[4];
+ real rmax, vmax;
+ complex work[2500] /* was [50][50] */;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ integer ninfo;
+ real anorm, bnorm, rwork[300];
+ extern /* Subroutine */ int cggbak_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, complex *, integer *,
+ integer *), cggbal_(char *, integer *, complex *,
+ integer *, complex *, integer *, integer *, integer *, real *,
+ real *, real *, integer *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ real lscale[50];
+ extern doublereal slamch_(char *);
+ real rscale[50];
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 0, 0, 0, 0 };
+ static cilist io___10 = { 0, 0, 0, 0, 0 };
+ static cilist io___13 = { 0, 0, 0, 0, 0 };
+ static cilist io___15 = { 0, 0, 0, 0, 0 };
+ static cilist io___17 = { 0, 0, 0, 0, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9991, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKGK tests CGGBAK, a routine for backward balancing of */
+/* a matrix pair (A, B). */
+
+/* Arguments */
+/* ========= */
+
+/* NIN (input) INTEGER */
+/* The logical unit number for input. NIN > 0. */
+
+/* NOUT (input) INTEGER */
+/* The logical unit number for output. NOUT > 0. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ lmax[0] = 0;
+ lmax[1] = 0;
+ lmax[2] = 0;
+ lmax[3] = 0;
+ ninfo = 0;
+ knt = 0;
+ rmax = 0.f;
+
+ eps = slamch_("Precision");
+
+L10:
+ io___6.ciunit = *nin;
+ s_rsle(&io___6);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&m, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ goto L100;
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___10.ciunit = *nin;
+ s_rsle(&io___10);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&a[i__ + j * 50 - 51], (ftnlen)
+ sizeof(complex));
+ }
+ e_rsle();
+/* L20: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___13.ciunit = *nin;
+ s_rsle(&io___13);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&b[i__ + j * 50 - 51], (ftnlen)
+ sizeof(complex));
+ }
+ e_rsle();
+/* L30: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___15.ciunit = *nin;
+ s_rsle(&io___15);
+ i__2 = m;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&vl[i__ + j * 50 - 51], (ftnlen)
+ sizeof(complex));
+ }
+ e_rsle();
+/* L40: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___17.ciunit = *nin;
+ s_rsle(&io___17);
+ i__2 = m;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&vr[i__ + j * 50 - 51], (ftnlen)
+ sizeof(complex));
+ }
+ e_rsle();
+/* L50: */
+ }
+
+ ++knt;
+
+ anorm = clange_("M", &n, &n, a, &c__50, rwork);
+ bnorm = clange_("M", &n, &n, b, &c__50, rwork);
+
+ clacpy_("FULL", &n, &n, a, &c__50, af, &c__50);
+ clacpy_("FULL", &n, &n, b, &c__50, bf, &c__50);
+
+ cggbal_("B", &n, a, &c__50, b, &c__50, &ilo, &ihi, lscale, rscale, rwork,
+ &info);
+ if (info != 0) {
+ ++ninfo;
+ lmax[0] = knt;
+ }
+
+ clacpy_("FULL", &n, &m, vl, &c__50, vlf, &c__50);
+ clacpy_("FULL", &n, &m, vr, &c__50, vrf, &c__50);
+
+ cggbak_("B", "L", &n, &ilo, &ihi, lscale, rscale, &m, vl, &c__50, &info);
+ if (info != 0) {
+ ++ninfo;
+ lmax[1] = knt;
+ }
+
+ cggbak_("B", "R", &n, &ilo, &ihi, lscale, rscale, &m, vr, &c__50, &info);
+ if (info != 0) {
+ ++ninfo;
+ lmax[2] = knt;
+ }
+
+/* Test of CGGBAK */
+
+/* Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR */
+/* where tilde(A) denotes the transformed matrix. */
+
+ cgemm_("N", "N", &n, &m, &n, &c_b2, af, &c__50, vr, &c__50, &c_b1, work, &
+ c__50);
+ cgemm_("C", "N", &m, &m, &n, &c_b2, vl, &c__50, work, &c__50, &c_b1, e, &
+ c__50);
+
+ cgemm_("N", "N", &n, &m, &n, &c_b2, a, &c__50, vrf, &c__50, &c_b1, work, &
+ c__50);
+ cgemm_("C", "N", &m, &m, &n, &c_b2, vlf, &c__50, work, &c__50, &c_b1, f, &
+ c__50);
+
+ vmax = 0.f;
+ i__1 = m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 50 - 51;
+ i__4 = i__ + j * 50 - 51;
+ q__2.r = e[i__3].r - f[i__4].r, q__2.i = e[i__3].i - f[i__4].i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+/* Computing MAX */
+ r__3 = vmax, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
+ q__1), dabs(r__2));
+ vmax = dmax(r__3,r__4);
+/* L60: */
+ }
+/* L70: */
+ }
+ vmax /= eps * dmax(anorm,bnorm);
+ if (vmax > rmax) {
+ lmax[3] = knt;
+ rmax = vmax;
+ }
+
+/* Check tilde(VL)'*B*tilde(VR) - VL'*tilde(B)*VR */
+
+ cgemm_("N", "N", &n, &m, &n, &c_b2, bf, &c__50, vr, &c__50, &c_b1, work, &
+ c__50);
+ cgemm_("C", "N", &m, &m, &n, &c_b2, vl, &c__50, work, &c__50, &c_b1, e, &
+ c__50);
+
+ cgemm_("n", "n", &n, &m, &n, &c_b2, b, &c__50, vrf, &c__50, &c_b1, work, &
+ c__50);
+ cgemm_("C", "N", &m, &m, &n, &c_b2, vlf, &c__50, work, &c__50, &c_b1, f, &
+ c__50);
+
+ vmax = 0.f;
+ i__1 = m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 50 - 51;
+ i__4 = i__ + j * 50 - 51;
+ q__2.r = e[i__3].r - f[i__4].r, q__2.i = e[i__3].i - f[i__4].i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+/* Computing MAX */
+ r__3 = vmax, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
+ q__1), dabs(r__2));
+ vmax = dmax(r__3,r__4);
+/* L80: */
+ }
+/* L90: */
+ }
+ vmax /= eps * dmax(anorm,bnorm);
+ if (vmax > rmax) {
+ lmax[3] = knt;
+ rmax = vmax;
+ }
+
+ goto L10;
+
+L100:
+
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ e_wsfe();
+
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, (char *)&lmax[3], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ return 0;
+
+/* End of CCHKGK */
+
+} /* cchkgk_ */
diff --git a/TESTING/EIG/cchkgl.c b/TESTING/EIG/cchkgl.c
new file mode 100644
index 0000000..48e1dc7
--- /dev/null
+++ b/TESTING/EIG/cchkgl.c
@@ -0,0 +1,315 @@
+/* cchkgl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__6 = 6;
+static integer c__4 = 4;
+static integer c__20 = 20;
+
+/* Subroutine */ int cchkgl_(integer *nin, integer *nout)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 .. test output of CGGBAL .. \002)";
+ static char fmt_9998[] = "(\002 ratio of largest test error "
+ " = \002,e12.3)";
+ static char fmt_9997[] = "(\002 example number where info is not zero "
+ " = \002,i4)";
+ static char fmt_9996[] = "(\002 example number where ILO or IHI is wrong"
+ " = \002,i4)";
+ static char fmt_9995[] = "(\002 example number having largest error "
+ " = \002,i4)";
+ static char fmt_9994[] = "(\002 number of examples where info is not 0 "
+ " = \002,i4)";
+ static char fmt_9993[] = "(\002 total number of examples tested "
+ " = \002,i4)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3;
+ complex q__1;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+ double c_abs(complex *);
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ complex a[400] /* was [20][20] */, b[400] /* was [20][20] */;
+ integer i__, j, n;
+ complex ain[400] /* was [20][20] */, bin[400] /* was [20][20] */;
+ integer ihi, ilo;
+ real eps;
+ integer knt, info, lmax[3];
+ real rmax, vmax, work[120];
+ integer ihiin, ninfo, iloin;
+ real anorm, bnorm;
+ extern /* Subroutine */ int cggbal_(char *, integer *, complex *, integer
+ *, complex *, integer *, integer *, integer *, real *, real *,
+ real *, integer *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ real lscale[20];
+ extern doublereal slamch_(char *);
+ real rscale[20], lsclin[20], rsclin[20];
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 0, 0, 0, 0 };
+ static cilist io___9 = { 0, 0, 0, 0, 0 };
+ static cilist io___12 = { 0, 0, 0, 0, 0 };
+ static cilist io___14 = { 0, 0, 0, 0, 0 };
+ static cilist io___17 = { 0, 0, 0, 0, 0 };
+ static cilist io___19 = { 0, 0, 0, 0, 0 };
+ static cilist io___21 = { 0, 0, 0, 0, 0 };
+ static cilist io___23 = { 0, 0, 0, 0, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKGL tests CGGBAL, a routine for balancing a matrix pair (A, B). */
+
+/* Arguments */
+/* ========= */
+
+/* NIN (input) INTEGER */
+/* The logical unit number for input. NIN > 0. */
+
+/* NOUT (input) INTEGER */
+/* The logical unit number for output. NOUT > 0. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ lmax[0] = 0;
+ lmax[1] = 0;
+ lmax[2] = 0;
+ ninfo = 0;
+ knt = 0;
+ rmax = 0.f;
+
+ eps = slamch_("Precision");
+
+L10:
+
+ io___6.ciunit = *nin;
+ s_rsle(&io___6);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ goto L90;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___9.ciunit = *nin;
+ s_rsle(&io___9);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&a[i__ + j * 20 - 21], (ftnlen)
+ sizeof(complex));
+ }
+ e_rsle();
+/* L20: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___12.ciunit = *nin;
+ s_rsle(&io___12);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&b[i__ + j * 20 - 21], (ftnlen)
+ sizeof(complex));
+ }
+ e_rsle();
+/* L30: */
+ }
+
+ io___14.ciunit = *nin;
+ s_rsle(&io___14);
+ do_lio(&c__3, &c__1, (char *)&iloin, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ihiin, (ftnlen)sizeof(integer));
+ e_rsle();
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___17.ciunit = *nin;
+ s_rsle(&io___17);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&ain[i__ + j * 20 - 21], (ftnlen)
+ sizeof(complex));
+ }
+ e_rsle();
+/* L40: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___19.ciunit = *nin;
+ s_rsle(&io___19);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&bin[i__ + j * 20 - 21], (ftnlen)
+ sizeof(complex));
+ }
+ e_rsle();
+/* L50: */
+ }
+
+ io___21.ciunit = *nin;
+ s_rsle(&io___21);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__4, &c__1, (char *)&lsclin[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_rsle();
+ io___23.ciunit = *nin;
+ s_rsle(&io___23);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__4, &c__1, (char *)&rsclin[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_rsle();
+
+ anorm = clange_("M", &n, &n, a, &c__20, work);
+ bnorm = clange_("M", &n, &n, b, &c__20, work);
+
+ ++knt;
+
+ cggbal_("B", &n, a, &c__20, b, &c__20, &ilo, &ihi, lscale, rscale, work, &
+ info);
+
+ if (info != 0) {
+ ++ninfo;
+ lmax[0] = knt;
+ }
+
+ if (ilo != iloin || ihi != ihiin) {
+ ++ninfo;
+ lmax[1] = knt;
+ }
+
+ vmax = 0.f;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ q__1.r = a[i__3].r - ain[i__4].r, q__1.i = a[i__3].i - ain[i__4]
+ .i;
+ r__1 = vmax, r__2 = c_abs(&q__1);
+ vmax = dmax(r__1,r__2);
+/* Computing MAX */
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ q__1.r = b[i__3].r - bin[i__4].r, q__1.i = b[i__3].i - bin[i__4]
+ .i;
+ r__1 = vmax, r__2 = c_abs(&q__1);
+ vmax = dmax(r__1,r__2);
+/* L60: */
+ }
+/* L70: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = vmax, r__3 = (r__1 = lscale[i__ - 1] - lsclin[i__ - 1], dabs(
+ r__1));
+ vmax = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = vmax, r__3 = (r__1 = rscale[i__ - 1] - rsclin[i__ - 1], dabs(
+ r__1));
+ vmax = dmax(r__2,r__3);
+/* L80: */
+ }
+
+ vmax /= eps * dmax(anorm,bnorm);
+
+ if (vmax > rmax) {
+ lmax[2] = knt;
+ rmax = vmax;
+ }
+
+ goto L10;
+
+L90:
+
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ e_wsfe();
+
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ return 0;
+
+/* End of CCHKGL */
+
+} /* cchkgl_ */
diff --git a/TESTING/EIG/cchkhb.c b/TESTING/EIG/cchkhb.c
new file mode 100644
index 0000000..bdc44c5
--- /dev/null
+++ b/TESTING/EIG/cchkhb.c
@@ -0,0 +1,827 @@
+/* cchkhb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__0 = 0;
+static integer c__6 = 6;
+static real c_b32 = 1.f;
+static integer c__1 = 1;
+static real c_b42 = 0.f;
+static integer c__4 = 4;
+
+/* Subroutine */ int cchkhb_(integer *nsizes, integer *nn, integer *nwdths,
+ integer *kk, integer *ntypes, logical *dotype, integer *iseed, real *
+ thresh, integer *nounit, complex *a, integer *lda, real *sd, real *se,
+ complex *u, integer *ldu, complex *work, integer *lwork, real *rwork,
+ real *result, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[15] = { 1,2,4,4,4,4,4,5,5,5,5,5,8,8,8 };
+ static integer kmagn[15] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3 };
+ static integer kmode[15] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 CCHKHB: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(/1x,a3,\002 -- Complex Hermitian Banded Tridi"
+ "agonal Reduction Routines\002)";
+ static char fmt_9997[] = "(\002 Matrix types (see SCHK23 for details):"
+ " \002)";
+ static char fmt_9996[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 5=Diagonal: clustered ent"
+ "ries.\002,/\002 2=Identity matrix. \002,\002"
+ " 6=Diagonal: large, evenly spaced.\002,/\002 3=Diagonal: evenl"
+ "y spaced entries. \002,\002 7=Diagonal: small, evenly spaced."
+ "\002,/\002 4=Diagonal: geometr. spaced entries.\002)";
+ static char fmt_9995[] = "(\002 Dense \002,a,\002 Banded Matrices:\002,"
+ "/\002 8=Evenly spaced eigenvals. \002,\002 12=Small,"
+ " evenly spaced eigenvals.\002,/\002 9=Geometrically spaced eige"
+ "nvals. \002,\002 13=Matrix with random O(1) entries.\002,"
+ "/\002 10=Clustered eigenvalues. \002,\002 14=Matrix"
+ " with large random entries.\002,/\002 11=Large, evenly spaced ei"
+ "genvals. \002,\002 15=Matrix with small random entries.\002)";
+ static char fmt_9994[] = "(/\002 Tests performed: (S is Tridiag, U "
+ "is \002,a,\002,\002,/20x,a,\002 means \002,a,\002.\002,/\002 UPL"
+ "O='U':\002,/\002 1= | A - U S U\002,a1,\002 | / ( |A| n ulp ) "
+ " \002,\002 2= | I - U U\002,a1,\002 | / ( n ulp )\002,/\002 U"
+ "PLO='L':\002,/\002 3= | A - U S U\002,a1,\002 | / ( |A| n ulp )"
+ " \002,\002 4= | I - U U\002,a1,\002 | / ( n ulp )\002)";
+ static char fmt_9993[] = "(\002 N=\002,i5,\002, K=\002,i4,\002, seed="
+ "\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)"
+ "=\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6, i__7;
+ real r__1;
+ complex q__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal), c_abs(complex *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k, n, jc, jr;
+ real ulp, cond;
+ integer jcol, kmax, nmax;
+ real unfl, ovfl, temp1;
+ logical badnn;
+ extern /* Subroutine */ int chbt21_(char *, integer *, integer *, integer
+ *, complex *, integer *, real *, real *, complex *, integer *,
+ complex *, real *, real *);
+ integer imode, iinfo;
+ real aninv, anorm;
+ integer nmats, jsize, nerrs, itype, jtype, ntest;
+ logical badnnb;
+ extern /* Subroutine */ int chbtrd_(char *, char *, integer *, integer *,
+ complex *, integer *, real *, real *, complex *, integer *,
+ complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *);
+ integer idumma[1];
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int xerbla_(char *, integer *), clatmr_(
+ integer *, integer *, char *, integer *, char *, complex *,
+ integer *, real *, complex *, char *, char *, complex *, integer *
+, real *, complex *, integer *, real *, char *, integer *,
+ integer *, integer *, real *, real *, char *, complex *, integer *
+, integer *, integer *), clatms_(integer *, integer *, char *, integer *, char *,
+ real *, integer *, real *, real *, integer *, integer *, char *,
+ complex *, integer *, complex *, integer *);
+ integer jwidth;
+ extern /* Subroutine */ int slasum_(char *, integer *, integer *, integer
+ *);
+ real rtunfl, rtovfl, ulpinv;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKHB tests the reduction of a Hermitian band matrix to tridiagonal */
+/* from, used with the Hermitian eigenvalue problem. */
+
+/* CHBTRD factors a Hermitian band matrix A as U S U* , where * means */
+/* conjugate transpose, S is symmetric tridiagonal, and U is unitary. */
+/* CHBTRD can use either just the lower or just the upper triangle */
+/* of A; CCHKHB checks both cases. */
+
+/* When CCHKHB is called, a number of matrix "sizes" ("n's"), a number */
+/* of bandwidths ("k's"), and a number of matrix "types" are */
+/* specified. For each size ("n"), each bandwidth ("k") less than or */
+/* equal to "n", and each type of matrix, one matrix will be generated */
+/* and used to test the hermitian banded reduction routine. For each */
+/* matrix, a number of tests will be performed: */
+
+/* (1) | A - V S V* | / ( |A| n ulp ) computed by CHBTRD with */
+/* UPLO='U' */
+
+/* (2) | I - UU* | / ( n ulp ) */
+
+/* (3) | A - V S V* | / ( |A| n ulp ) computed by CHBTRD with */
+/* UPLO='L' */
+
+/* (4) | I - UU* | / ( n ulp ) */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (6) Same as (4), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (4), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U* D U, where U is unitary and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U* D U, where U is unitary and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U* D U, where U is unitary and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) Hermitian matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* CCHKHB does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NWDTHS (input) INTEGER */
+/* The number of bandwidths to use. If it is zero, */
+/* CCHKHB does nothing. It must be at least zero. */
+
+/* KK (input) INTEGER array, dimension (NWDTHS) */
+/* An array containing the bandwidths to be used for the band */
+/* matrices. The values must be at least zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, CCHKHB */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to CCHKHB to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace) REAL array, dimension */
+/* (LDA, max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 2 (not 1!) */
+/* and at least max( KK )+1. */
+
+/* SD (workspace) REAL array, dimension (max(NN)) */
+/* Used to hold the diagonal of the tridiagonal matrix computed */
+/* by CHBTRD. */
+
+/* SE (workspace) REAL array, dimension (max(NN)) */
+/* Used to hold the off-diagonal of the tridiagonal matrix */
+/* computed by CHBTRD. */
+
+/* U (workspace) REAL array, dimension (LDU, max(NN)) */
+/* Used to hold the unitary matrix computed by CHBTRD. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* max( LDA+1, max(NN)+1 )*max(NN). */
+
+/* RESULT (output) REAL array, dimension (4) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests performed, or which can */
+/* be performed so far, for the current matrix. */
+/* NTESTT The total number of tests performed so far. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far. */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --kk;
+ --dotype;
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --sd;
+ --se;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+ badnnb = FALSE_;
+ kmax = 0;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = kmax, i__3 = kk[j];
+ kmax = max(i__2,i__3);
+ if (kk[j] < 0) {
+ badnnb = TRUE_;
+ }
+/* L20: */
+ }
+/* Computing MIN */
+ i__1 = nmax - 1;
+ kmax = min(i__1,kmax);
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*nwdths < 0) {
+ *info = -3;
+ } else if (badnnb) {
+ *info = -4;
+ } else if (*ntypes < 0) {
+ *info = -5;
+ } else if (*lda < kmax + 1) {
+ *info = -11;
+ } else if (*ldu < nmax) {
+ *info = -15;
+ } else if ((max(*lda,nmax) + 1) * nmax > *lwork) {
+ *info = -17;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CCHKHB", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0 || *nwdths == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ ulpinv = 1.f / ulp;
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ aninv = 1.f / (real) max(1,n);
+
+ i__2 = *nwdths;
+ for (jwidth = 1; jwidth <= i__2; ++jwidth) {
+ k = kk[jwidth];
+ if (k > n) {
+ goto L180;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__5 = n - 1;
+ i__3 = 0, i__4 = min(i__5,k);
+ k = max(i__3,i__4);
+
+ if (*nsizes != 1) {
+ mtypes = min(15,*ntypes);
+ } else {
+ mtypes = min(16,*ntypes);
+ }
+
+ i__3 = mtypes;
+ for (jtype = 1; jtype <= i__3; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L170;
+ }
+ ++nmats;
+ ntest = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L30: */
+ }
+
+/* Compute "A". */
+/* Store as "Upper"; later, we will copy to other format. */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log hermitian, w/ eigenvalues */
+/* =6 random (none) */
+/* =7 random diagonal */
+/* =8 random hermitian */
+/* =9 positive definite */
+/* =10 diagonally dominant tridiagonal */
+
+ if (mtypes > 15) {
+ goto L100;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.f;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * aninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * n * ulpinv;
+ goto L70;
+
+L70:
+
+ claset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ iinfo = 0;
+ if (jtype <= 15) {
+ cond = ulpinv;
+ } else {
+ cond = ulpinv * aninv / 10.f;
+ }
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__4 = n;
+ for (jcol = 1; jcol <= i__4; ++jcol) {
+ i__5 = k + 1 + jcol * a_dim1;
+ a[i__5].r = anorm, a[i__5].i = 0.f;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &
+ cond, &anorm, &c__0, &c__0, "Q", &a[k + 1 +
+ a_dim1], lda, &work[1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Hermitian, eigenvalues specified */
+
+ clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &
+ cond, &anorm, &k, &k, "Q", &a[a_offset], lda, &
+ work[1], &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ clatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &
+ c_b32, &c_b2, "T", "N", &work[n + 1], &c__1, &
+ c_b32, &work[(n << 1) + 1], &c__1, &c_b32, "N",
+ idumma, &c__0, &c__0, &c_b42, &anorm, "Q", &a[k +
+ 1 + a_dim1], lda, idumma, &iinfo);
+
+ } else if (itype == 8) {
+
+/* Hermitian, random eigenvalues */
+
+ clatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &
+ c_b32, &c_b2, "T", "N", &work[n + 1], &c__1, &
+ c_b32, &work[(n << 1) + 1], &c__1, &c_b32, "N",
+ idumma, &k, &k, &c_b42, &anorm, "Q", &a[a_offset],
+ lda, idumma, &iinfo);
+
+ } else if (itype == 9) {
+
+/* Positive definite, eigenvalues specified. */
+
+ clatms_(&n, &n, "S", &iseed[1], "P", &rwork[1], &imode, &
+ cond, &anorm, &k, &k, "Q", &a[a_offset], lda, &
+ work[n + 1], &iinfo);
+
+ } else if (itype == 10) {
+
+/* Positive definite tridiagonal, eigenvalues specified. */
+
+ if (n > 1) {
+ k = max(1,k);
+ }
+ clatms_(&n, &n, "S", &iseed[1], "P", &rwork[1], &imode, &
+ cond, &anorm, &c__1, &c__1, "Q", &a[k + a_dim1],
+ lda, &work[1], &iinfo);
+ i__4 = n;
+ for (i__ = 2; i__ <= i__4; ++i__) {
+ i__5 = k + 1 + (i__ - 1) * a_dim1;
+ i__6 = k + 1 + i__ * a_dim1;
+ q__1.r = a[i__5].r * a[i__6].r - a[i__5].i * a[i__6]
+ .i, q__1.i = a[i__5].r * a[i__6].i + a[i__5]
+ .i * a[i__6].r;
+ temp1 = c_abs(&a[k + i__ * a_dim1]) / sqrt(c_abs(&
+ q__1));
+ if (temp1 > .5f) {
+ i__5 = k + i__ * a_dim1;
+ i__6 = k + 1 + (i__ - 1) * a_dim1;
+ i__7 = k + 1 + i__ * a_dim1;
+ q__1.r = a[i__6].r * a[i__7].r - a[i__6].i * a[
+ i__7].i, q__1.i = a[i__6].r * a[i__7].i +
+ a[i__6].i * a[i__7].r;
+ r__1 = sqrt(c_abs(&q__1)) * .5f;
+ a[i__5].r = r__1, a[i__5].i = 0.f;
+ }
+/* L90: */
+ }
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___36.ciunit = *nounit;
+ s_wsfe(&io___36);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L100:
+
+/* Call CHBTRD to compute S and U from upper triangle. */
+
+ i__4 = k + 1;
+ clacpy_(" ", &i__4, &n, &a[a_offset], lda, &work[1], lda);
+
+ ntest = 1;
+ chbtrd_("V", "U", &n, &k, &work[1], lda, &sd[1], &se[1], &u[
+ u_offset], ldu, &work[*lda * n + 1], &iinfo);
+
+ if (iinfo != 0) {
+ io___37.ciunit = *nounit;
+ s_wsfe(&io___37);
+ do_fio(&c__1, "CHBTRD(U)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[1] = ulpinv;
+ goto L150;
+ }
+ }
+
+/* Do tests 1 and 2 */
+
+ chbt21_("Upper", &n, &k, &c__1, &a[a_offset], lda, &sd[1], &
+ se[1], &u[u_offset], ldu, &work[1], &rwork[1], &
+ result[1]);
+
+/* Convert A from Upper-Triangle-Only storage to */
+/* Lower-Triangle-Only storage. */
+
+ i__4 = n;
+ for (jc = 1; jc <= i__4; ++jc) {
+/* Computing MIN */
+ i__6 = k, i__7 = n - jc;
+ i__5 = min(i__6,i__7);
+ for (jr = 0; jr <= i__5; ++jr) {
+ i__6 = jr + 1 + jc * a_dim1;
+ r_cnjg(&q__1, &a[k + 1 - jr + (jc + jr) * a_dim1]);
+ a[i__6].r = q__1.r, a[i__6].i = q__1.i;
+/* L110: */
+ }
+/* L120: */
+ }
+ i__4 = n;
+ for (jc = n + 1 - k; jc <= i__4; ++jc) {
+/* Computing MIN */
+ i__5 = k, i__6 = n - jc;
+ i__7 = k;
+ for (jr = min(i__5,i__6) + 1; jr <= i__7; ++jr) {
+ i__5 = jr + 1 + jc * a_dim1;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+/* L130: */
+ }
+/* L140: */
+ }
+
+/* Call CHBTRD to compute S and U from lower triangle */
+
+ i__4 = k + 1;
+ clacpy_(" ", &i__4, &n, &a[a_offset], lda, &work[1], lda);
+
+ ntest = 3;
+ chbtrd_("V", "L", &n, &k, &work[1], lda, &sd[1], &se[1], &u[
+ u_offset], ldu, &work[*lda * n + 1], &iinfo);
+
+ if (iinfo != 0) {
+ io___40.ciunit = *nounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "CHBTRD(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[3] = ulpinv;
+ goto L150;
+ }
+ }
+ ntest = 4;
+
+/* Do tests 3 and 4 */
+
+ chbt21_("Lower", &n, &k, &c__1, &a[a_offset], lda, &sd[1], &
+ se[1], &u[u_offset], ldu, &work[1], &rwork[1], &
+ result[3]);
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L150:
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__4 = ntest;
+ for (jr = 1; jr <= i__4; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "CHB", (ftnlen)3);
+ e_wsfe();
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ e_wsfe();
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ e_wsfe();
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "Hermitian", (ftnlen)9);
+ e_wsfe();
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "unitary", (ftnlen)7);
+ do_fio(&c__1, "*", (ftnlen)1);
+ do_fio(&c__1, "conjugate transpose", (ftnlen)19);
+ for (j = 1; j <= 4; ++j) {
+ do_fio(&c__1, "*", (ftnlen)1);
+ }
+ e_wsfe();
+ }
+ ++nerrs;
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ }
+/* L160: */
+ }
+
+L170:
+ ;
+ }
+L180:
+ ;
+ }
+/* L190: */
+ }
+
+/* Summary */
+
+ slasum_("CHB", nounit, &nerrs, &ntestt);
+ return 0;
+
+
+
+
+/* End of CCHKHB */
+
+} /* cchkhb_ */
diff --git a/TESTING/EIG/cchkhs.c b/TESTING/EIG/cchkhs.c
new file mode 100644
index 0000000..28bcef7
--- /dev/null
+++ b/TESTING/EIG/cchkhs.c
@@ -0,0 +1,1425 @@
+/* cchkhs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+static real c_b27 = 1.f;
+static integer c__0 = 0;
+static real c_b33 = 0.f;
+static integer c__4 = 4;
+static integer c__6 = 6;
+
+/* Subroutine */ int cchkhs_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, integer *nounit,
+ complex *a, integer *lda, complex *h__, complex *t1, complex *t2,
+ complex *u, integer *ldu, complex *z__, complex *uz, complex *w1,
+ complex *w3, complex *evectl, complex *evectr, complex *evecty,
+ complex *evectx, complex *uu, complex *tau, complex *work, integer *
+ nwork, real *rwork, integer *iwork, logical *select, real *result,
+ integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
+ static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
+ static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 CCHKHS: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 CCHKHS: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
+ "i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9997[] = "(\002 CCHKHS: Selected \002,a,\002 Eigenvector"
+ "s from \002,a,\002 do not match other eigenvectors \002,9x,\002N="
+ "\002,i6,\002, JTYPE=\002,i6,\002, ISEED=(\002,3(i5,\002,\002),i5,"
+ "\002)\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, evectl_dim1, evectl_offset, evectr_dim1,
+ evectr_offset, evectx_dim1, evectx_offset, evecty_dim1,
+ evecty_offset, h_dim1, h_offset, t1_dim1, t1_offset, t2_dim1,
+ t2_offset, u_dim1, u_offset, uu_dim1, uu_offset, uz_dim1,
+ uz_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double c_abs(complex *);
+
+ /* Local variables */
+ integer i__, j, k, n, n1, jj, in, ihi, ilo;
+ real ulp, cond;
+ integer jcol, nmax;
+ real unfl, ovfl, temp1, temp2;
+ logical badnn;
+ extern /* Subroutine */ int cget10_(integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, real *, real *),
+ cget22_(char *, char *, char *, integer *, complex *, integer *,
+ complex *, integer *, complex *, complex *, real *, real *), cgemm_(char *, char *, integer *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *, complex *, complex *, integer *);
+ logical match;
+ integer imode;
+ extern /* Subroutine */ int chst01_(integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, real *);
+ real dumma[4];
+ integer iinfo;
+ real conds, aninv, anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer nmats, jsize, nerrs, itype, jtype, ntest;
+ real rtulp;
+ extern /* Subroutine */ int slabad_(real *, real *), cgehrd_(integer *,
+ integer *, integer *, complex *, integer *, complex *, complex *,
+ integer *, integer *), clatme_(integer *, char *, integer *,
+ complex *, integer *, real *, complex *, char *, char *, char *,
+ char *, real *, integer *, real *, integer *, integer *, real *,
+ complex *, integer *, complex *, integer *);
+ complex cdumma[4];
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int chsein_(char *, char *, char *, logical *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *, integer *, complex *, real *,
+ integer *, integer *, integer *), clacpy_(
+ char *, integer *, integer *, complex *, integer *, complex *,
+ integer *);
+ integer idumma[1];
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int xerbla_(char *, integer *), clatmr_(
+ integer *, integer *, char *, integer *, char *, complex *,
+ integer *, real *, complex *, char *, char *, complex *, integer *
+, real *, complex *, integer *, real *, char *, integer *,
+ integer *, integer *, real *, real *, char *, complex *, integer *
+, integer *, integer *), clatms_(integer *, integer *, char *, integer *, char *,
+ real *, integer *, real *, real *, integer *, integer *, char *,
+ complex *, integer *, complex *, integer *), chseqr_(char *, char *, integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, complex *,
+ integer *, integer *), ctrevc_(char *, char *,
+ logical *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, integer *, integer *, complex *, real *,
+ integer *), cunghr_(integer *, integer *, integer
+ *, complex *, integer *, complex *, complex *, integer *, integer
+ *), cunmhr_(char *, char *, integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *), slafts_(char *,
+ integer *, integer *, integer *, integer *, real *, integer *,
+ real *, integer *, integer *), slasum_(char *, integer *,
+ integer *, integer *);
+ real rtunfl, rtovfl, rtulpi, ulpinv;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKHS checks the nonsymmetric eigenvalue problem routines. */
+
+/* CGEHRD factors A as U H U' , where ' means conjugate */
+/* transpose, H is hessenberg, and U is unitary. */
+
+/* CUNGHR generates the unitary matrix U. */
+
+/* CUNMHR multiplies a matrix by the unitary matrix U. */
+
+/* CHSEQR factors H as Z T Z' , where Z is unitary and T */
+/* is upper triangular. It also computes the eigenvalues, */
+/* w(1), ..., w(n); we define a diagonal matrix W whose */
+/* (diagonal) entries are the eigenvalues. */
+
+/* CTREVC computes the left eigenvector matrix L and the */
+/* right eigenvector matrix R for the matrix T. The */
+/* columns of L are the complex conjugates of the left */
+/* eigenvectors of T. The columns of R are the right */
+/* eigenvectors of T. L is lower triangular, and R is */
+/* upper triangular. */
+
+/* CHSEIN computes the left eigenvector matrix Y and the */
+/* right eigenvector matrix X for the matrix H. The */
+/* columns of Y are the complex conjugates of the left */
+/* eigenvectors of H. The columns of X are the right */
+/* eigenvectors of H. Y is lower triangular, and X is */
+/* upper triangular. */
+
+/* When CCHKHS is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 14 */
+/* tests will be performed: */
+
+/* (1) | A - U H U**H | / ( |A| n ulp ) */
+
+/* (2) | I - UU**H | / ( n ulp ) */
+
+/* (3) | H - Z T Z**H | / ( |H| n ulp ) */
+
+/* (4) | I - ZZ**H | / ( n ulp ) */
+
+/* (5) | A - UZ H (UZ)**H | / ( |A| n ulp ) */
+
+/* (6) | I - UZ (UZ)**H | / ( n ulp ) */
+
+/* (7) | T(Z computed) - T(Z not computed) | / ( |T| ulp ) */
+
+/* (8) | W(Z computed) - W(Z not computed) | / ( |W| ulp ) */
+
+/* (9) | TR - RW | / ( |T| |R| ulp ) */
+
+/* (10) | L**H T - W**H L | / ( |T| |L| ulp ) */
+
+/* (11) | HX - XW | / ( |H| |X| ulp ) */
+
+/* (12) | Y**H H - W**H Y | / ( |H| |Y| ulp ) */
+
+/* (13) | AX - XW | / ( |A| |X| ulp ) */
+
+/* (14) | Y**H A - W**H Y | / ( |A| |Y| ulp ) */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
+
+/* (4) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random complex angles. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (5) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random complex angles. */
+/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random complex angles. */
+
+/* (7) Same as (4), but multiplied by SQRT( overflow threshold ) */
+/* (8) Same as (4), but multiplied by SQRT( underflow threshold ) */
+
+/* (9) A matrix of the form U' T U, where U is unitary and */
+/* T has evenly spaced entries 1, ..., ULP with random complex */
+/* angles on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (10) A matrix of the form U' T U, where U is unitary and */
+/* T has geometrically spaced entries 1, ..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (11) A matrix of the form U' T U, where U is unitary and */
+/* T has "clustered" entries 1, ULP,..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (12) A matrix of the form U' T U, where U is unitary and */
+/* T has complex eigenvalues randomly chosen from */
+/* ULP < |z| < 1 and random O(1) entries in the upper */
+/* triangle. */
+
+/* (13) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
+/* with random complex angles on the diagonal and random O(1) */
+/* entries in the upper triangle. */
+
+/* (14) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has geometrically spaced entries */
+/* 1, ..., ULP with random complex angles on the diagonal */
+/* and random O(1) entries in the upper triangle. */
+
+/* (15) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
+/* with random complex angles on the diagonal and random O(1) */
+/* entries in the upper triangle. */
+
+/* (16) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has complex eigenvalues randomly chosen */
+/* from ULP < |z| < 1 and random O(1) entries in the upper */
+/* triangle. */
+
+/* (17) Same as (16), but multiplied by SQRT( overflow threshold ) */
+/* (18) Same as (16), but multiplied by SQRT( underflow threshold ) */
+
+/* (19) Nonsymmetric matrix with random entries chosen from |z| < 1 */
+/* (20) Same as (19), but multiplied by SQRT( overflow threshold ) */
+/* (21) Same as (19), but multiplied by SQRT( underflow threshold ) */
+
+/* Arguments */
+/* ========== */
+
+/* NSIZES - INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* CCHKHS does nothing. It must be at least zero. */
+/* Not modified. */
+
+/* NN - INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+/* Not modified. */
+
+/* NTYPES - INTEGER */
+/* The number of elements in DOTYPE. If it is zero, CCHKHS */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+/* Not modified. */
+
+/* DOTYPE - LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to CCHKHS to continue the same random number */
+/* sequence. */
+/* Modified. */
+
+/* THRESH - REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+/* Not modified. */
+
+/* NOUNIT - INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+/* Not modified. */
+
+/* A - COMPLEX array, dimension (LDA,max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually */
+/* used. */
+/* Modified. */
+
+/* LDA - INTEGER */
+/* The leading dimension of A, H, T1 and T2. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* H - COMPLEX array, dimension (LDA,max(NN)) */
+/* The upper hessenberg matrix computed by CGEHRD. On exit, */
+/* H contains the Hessenberg form of the matrix in A. */
+/* Modified. */
+
+/* T1 - COMPLEX array, dimension (LDA,max(NN)) */
+/* The Schur (="quasi-triangular") matrix computed by CHSEQR */
+/* if Z is computed. On exit, T1 contains the Schur form of */
+/* the matrix in A. */
+/* Modified. */
+
+/* T2 - COMPLEX array, dimension (LDA,max(NN)) */
+/* The Schur matrix computed by CHSEQR when Z is not computed. */
+/* This should be identical to T1. */
+/* Modified. */
+
+/* LDU - INTEGER */
+/* The leading dimension of U, Z, UZ and UU. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* U - COMPLEX array, dimension (LDU,max(NN)) */
+/* The unitary matrix computed by CGEHRD. */
+/* Modified. */
+
+/* Z - COMPLEX array, dimension (LDU,max(NN)) */
+/* The unitary matrix computed by CHSEQR. */
+/* Modified. */
+
+/* UZ - COMPLEX array, dimension (LDU,max(NN)) */
+/* The product of U times Z. */
+/* Modified. */
+
+/* W1 - COMPLEX array, dimension (max(NN)) */
+/* The eigenvalues of A, as computed by a full Schur */
+/* decomposition H = Z T Z'. On exit, W1 contains the */
+/* eigenvalues of the matrix in A. */
+/* Modified. */
+
+/* W3 - COMPLEX array, dimension (max(NN)) */
+/* The eigenvalues of A, as computed by a partial Schur */
+/* decomposition (Z not computed, T only computed as much */
+/* as is necessary for determining eigenvalues). On exit, */
+/* W3 contains the eigenvalues of the matrix in A, possibly */
+/* perturbed by CHSEIN. */
+/* Modified. */
+
+/* EVECTL - COMPLEX array, dimension (LDU,max(NN)) */
+/* The conjugate transpose of the (upper triangular) left */
+/* eigenvector matrix for the matrix in T1. */
+/* Modified. */
+
+/* EVECTR - COMPLEX array, dimension (LDU,max(NN)) */
+/* The (upper triangular) right eigenvector matrix for the */
+/* matrix in T1. */
+/* Modified. */
+
+/* EVECTY - COMPLEX array, dimension (LDU,max(NN)) */
+/* The conjugate transpose of the left eigenvector matrix */
+/* for the matrix in H. */
+/* Modified. */
+
+/* EVECTX - COMPLEX array, dimension (LDU,max(NN)) */
+/* The right eigenvector matrix for the matrix in H. */
+/* Modified. */
+
+/* UU - COMPLEX array, dimension (LDU,max(NN)) */
+/* Details of the unitary matrix computed by CGEHRD. */
+/* Modified. */
+
+/* TAU - COMPLEX array, dimension (max(NN)) */
+/* Further details of the unitary matrix computed by CGEHRD. */
+/* Modified. */
+
+/* WORK - COMPLEX array, dimension (NWORK) */
+/* Workspace. */
+/* Modified. */
+
+/* NWORK - INTEGER */
+/* The number of entries in WORK. NWORK >= 4*NN(j)*NN(j) + 2. */
+
+/* RWORK - REAL array, dimension (max(NN)) */
+/* Workspace. Could be equivalenced to IWORK, but not SELECT. */
+/* Modified. */
+
+/* IWORK - INTEGER array, dimension (max(NN)) */
+/* Workspace. */
+/* Modified. */
+
+/* SELECT - LOGICAL array, dimension (max(NN)) */
+/* Workspace. Could be equivalenced to IWORK, but not RWORK. */
+/* Modified. */
+
+/* RESULT - REAL array, dimension (14) */
+/* The values computed by the fourteen tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+/* Modified. */
+
+/* INFO - INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -6: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -14: LDU < 1 or LDU < NMAX. */
+/* -26: NWORK too small. */
+/* If CLATMR, CLATMS, or CLATME returns an error code, the */
+/* absolute value of it is returned. */
+/* If 1, then CHSEQR could not find all the shifts. */
+/* If 2, then the EISPACK code (for small blocks) failed. */
+/* If >2, then 30*N iterations were not enough to find an */
+/* eigenvalue or to decompose the problem. */
+/* Modified. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* MTEST The number of tests defined: care must be taken */
+/* that (1) the size of RESULT, (2) the number of */
+/* tests actually performed, and (3) MTEST agree. */
+/* NTEST The number of tests performed on this matrix */
+/* so far. This should be less than MTEST, and */
+/* equal to it by the last test. It will be less */
+/* if any of the routines being tested indicates */
+/* that it could not compute the matrices that */
+/* would be tested. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far (computed by SLAFTS). */
+/* COND, CONDS, */
+/* IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL, */
+/* RTULP, RTULPI Square roots of the previous 4 values. */
+
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+/* KCONDS(j) Selects whether CONDS is to be 1 or */
+/* 1/sqrt(ulp). (0 means irrelevant.) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ t2_dim1 = *lda;
+ t2_offset = 1 + t2_dim1;
+ t2 -= t2_offset;
+ t1_dim1 = *lda;
+ t1_offset = 1 + t1_dim1;
+ t1 -= t1_offset;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ uu_dim1 = *ldu;
+ uu_offset = 1 + uu_dim1;
+ uu -= uu_offset;
+ evectx_dim1 = *ldu;
+ evectx_offset = 1 + evectx_dim1;
+ evectx -= evectx_offset;
+ evecty_dim1 = *ldu;
+ evecty_offset = 1 + evecty_dim1;
+ evecty -= evecty_offset;
+ evectr_dim1 = *ldu;
+ evectr_offset = 1 + evectr_dim1;
+ evectr -= evectr_offset;
+ evectl_dim1 = *ldu;
+ evectl_offset = 1 + evectl_dim1;
+ evectl -= evectl_offset;
+ uz_dim1 = *ldu;
+ uz_offset = 1 + uz_dim1;
+ uz -= uz_offset;
+ z_dim1 = *ldu;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --w1;
+ --w3;
+ --tau;
+ --work;
+ --rwork;
+ --iwork;
+ --select;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 0;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.f) {
+ *info = -6;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldu <= 1 || *ldu < nmax) {
+ *info = -14;
+ } else if ((nmax << 2) * nmax + 2 > *nwork) {
+ *info = -26;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CCHKHS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More important constants */
+
+ unfl = slamch_("Safe minimum");
+ ovfl = slamch_("Overflow");
+ slabad_(&unfl, &ovfl);
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ ulpinv = 1.f / ulp;
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+ rtulp = sqrt(ulp);
+ rtulpi = 1.f / rtulp;
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ n1 = max(1,n);
+ aninv = 1.f / (real) n1;
+
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L250;
+ }
+ ++nmats;
+ ntest = 0;
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 14; ++j) {
+ result[j] = 0.f;
+/* L30: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KCONDS KMODE KTYPE */
+/* =1 O(1) 1 clustered 1 zero */
+/* =2 large large clustered 2 identity */
+/* =3 small exponential Jordan */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log hermitian, w/ eigenvalues */
+/* =6 random general, w/ eigenvalues */
+/* =7 random diagonal */
+/* =8 random hermitian */
+/* =9 random general */
+/* =10 random triangular */
+
+ if (mtypes > 21) {
+ goto L100;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.f;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * aninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * n * ulpinv;
+ goto L70;
+
+L70:
+
+ claset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices */
+
+ if (itype == 1) {
+
+/* Zero */
+
+ iinfo = 0;
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ a[i__4].r = anorm, a[i__4].i = 0.f;
+/* L80: */
+ }
+
+ } else if (itype == 3) {
+
+/* Jordan Block */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ a[i__4].r = anorm, a[i__4].i = 0.f;
+ if (jcol > 1) {
+ i__4 = jcol + (jcol - 1) * a_dim1;
+ a[i__4].r = 1.f, a[i__4].i = 0.f;
+ }
+/* L90: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &imode, &cond,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
+ n << 1) + 1], &c__1, &c_b27, "N", idumma, &c__0, &
+ c__0, &c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Hermitian, eigenvalues specified */
+
+ clatms_(&n, &n, "D", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[1], &
+ iinfo);
+
+ } else if (itype == 6) {
+
+/* General, eigenvalues specified */
+
+ if (kconds[jtype - 1] == 1) {
+ conds = 1.f;
+ } else if (kconds[jtype - 1] == 2) {
+ conds = rtulpi;
+ } else {
+ conds = 0.f;
+ }
+
+ clatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2,
+ " ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n,
+ &anorm, &a[a_offset], lda, &work[n + 1], &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
+ n << 1) + 1], &c__1, &c_b27, "N", idumma, &c__0, &
+ c__0, &c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Hermitian, random eigenvalues */
+
+ clatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b27,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
+ n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &n, &
+ c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* General, random eigenvalues */
+
+ clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
+ n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &n, &
+ c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 10) {
+
+/* Triangular, random eigenvalues */
+
+ clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
+ n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &c__0, &
+ c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___35.ciunit = *nounit;
+ s_wsfe(&io___35);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L100:
+
+/* Call CGEHRD to compute H and U, do tests. */
+
+ clacpy_(" ", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+ ntest = 1;
+
+ ilo = 1;
+ ihi = n;
+
+ i__3 = *nwork - n;
+ cgehrd_(&n, &ilo, &ihi, &h__[h_offset], lda, &work[1], &work[n +
+ 1], &i__3, &iinfo);
+
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___38.ciunit = *nounit;
+ s_wsfe(&io___38);
+ do_fio(&c__1, "CGEHRD", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L240;
+ }
+
+ i__3 = n - 1;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j + 1 + j * uu_dim1;
+ uu[i__4].r = 0.f, uu[i__4].i = 0.f;
+ i__4 = n;
+ for (i__ = j + 2; i__ <= i__4; ++i__) {
+ i__5 = i__ + j * u_dim1;
+ i__6 = i__ + j * h_dim1;
+ u[i__5].r = h__[i__6].r, u[i__5].i = h__[i__6].i;
+ i__5 = i__ + j * uu_dim1;
+ i__6 = i__ + j * h_dim1;
+ uu[i__5].r = h__[i__6].r, uu[i__5].i = h__[i__6].i;
+ i__5 = i__ + j * h_dim1;
+ h__[i__5].r = 0.f, h__[i__5].i = 0.f;
+/* L110: */
+ }
+/* L120: */
+ }
+ i__3 = n - 1;
+ ccopy_(&i__3, &work[1], &c__1, &tau[1], &c__1);
+ i__3 = *nwork - n;
+ cunghr_(&n, &ilo, &ihi, &u[u_offset], ldu, &work[1], &work[n + 1],
+ &i__3, &iinfo);
+ ntest = 2;
+
+ chst01_(&n, &ilo, &ihi, &a[a_offset], lda, &h__[h_offset], lda, &
+ u[u_offset], ldu, &work[1], nwork, &rwork[1], &result[1]);
+
+/* Call CHSEQR to compute T1, T2 and Z, do tests. */
+
+/* Eigenvalues only (W3) */
+
+ clacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
+ ntest = 3;
+ result[3] = ulpinv;
+
+ chseqr_("E", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &w3[1], &
+ uz[uz_offset], ldu, &work[1], nwork, &iinfo);
+ if (iinfo != 0) {
+ io___40.ciunit = *nounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "CHSEQR(E)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ if (iinfo <= n + 2) {
+ *info = abs(iinfo);
+ goto L240;
+ }
+ }
+
+/* Eigenvalues (W1) and Full Schur Form (T2) */
+
+ clacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
+
+ chseqr_("S", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &w1[1], &
+ uz[uz_offset], ldu, &work[1], nwork, &iinfo);
+ if (iinfo != 0 && iinfo <= n + 2) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "CHSEQR(S)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L240;
+ }
+
+/* Eigenvalues (W1), Schur Form (T1), and Schur Vectors (UZ) */
+
+ clacpy_(" ", &n, &n, &h__[h_offset], lda, &t1[t1_offset], lda);
+ clacpy_(" ", &n, &n, &u[u_offset], ldu, &uz[uz_offset], ldu);
+
+ chseqr_("S", "V", &n, &ilo, &ihi, &t1[t1_offset], lda, &w1[1], &
+ uz[uz_offset], ldu, &work[1], nwork, &iinfo);
+ if (iinfo != 0 && iinfo <= n + 2) {
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "CHSEQR(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L240;
+ }
+
+/* Compute Z = U' UZ */
+
+ cgemm_("C", "N", &n, &n, &n, &c_b2, &u[u_offset], ldu, &uz[
+ uz_offset], ldu, &c_b1, &z__[z_offset], ldu);
+ ntest = 8;
+
+/* Do Tests 3: | H - Z T Z' | / ( |H| n ulp ) */
+/* and 4: | I - Z Z' | / ( n ulp ) */
+
+ chst01_(&n, &ilo, &ihi, &h__[h_offset], lda, &t1[t1_offset], lda,
+ &z__[z_offset], ldu, &work[1], nwork, &rwork[1], &result[
+ 3]);
+
+/* Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp ) */
+/* and 6: | I - UZ (UZ)' | / ( n ulp ) */
+
+ chst01_(&n, &ilo, &ihi, &a[a_offset], lda, &t1[t1_offset], lda, &
+ uz[uz_offset], ldu, &work[1], nwork, &rwork[1], &result[5]
+);
+
+/* Do Test 7: | T2 - T1 | / ( |T| n ulp ) */
+
+ cget10_(&n, &n, &t2[t2_offset], lda, &t1[t1_offset], lda, &work[1]
+, &rwork[1], &result[7]);
+
+/* Do Test 8: | W3 - W1 | / ( max(|W1|,|W3|) ulp ) */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__1 = temp1, r__2 = c_abs(&w1[j]), r__1 = max(r__1,r__2),
+ r__2 = c_abs(&w3[j]);
+ temp1 = dmax(r__1,r__2);
+/* Computing MAX */
+ i__4 = j;
+ i__5 = j;
+ q__1.r = w1[i__4].r - w3[i__5].r, q__1.i = w1[i__4].i - w3[
+ i__5].i;
+ r__1 = temp2, r__2 = c_abs(&q__1);
+ temp2 = dmax(r__1,r__2);
+/* L130: */
+ }
+
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[8] = temp2 / dmax(r__1,r__2);
+
+/* Compute the Left and Right Eigenvectors of T */
+
+/* Compute the Right eigenvector Matrix: */
+
+ ntest = 9;
+ result[9] = ulpinv;
+
+/* Select every other eigenvector */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ select[j] = FALSE_;
+/* L140: */
+ }
+ i__3 = n;
+ for (j = 1; j <= i__3; j += 2) {
+ select[j] = TRUE_;
+/* L150: */
+ }
+ ctrevc_("Right", "All", &select[1], &n, &t1[t1_offset], lda,
+ cdumma, ldu, &evectr[evectr_offset], ldu, &n, &in, &work[
+ 1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ do_fio(&c__1, "CTREVC(R,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L240;
+ }
+
+/* Test 9: | TR - RW | / ( |T| |R| ulp ) */
+
+ cget22_("N", "N", "N", &n, &t1[t1_offset], lda, &evectr[
+ evectr_offset], ldu, &w1[1], &work[1], &rwork[1], dumma);
+ result[9] = dumma[0];
+ if (dumma[1] > *thresh) {
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "CTREVC", (ftnlen)6);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Compute selected right eigenvectors and confirm that */
+/* they agree with previous right eigenvectors */
+
+ ctrevc_("Right", "Some", &select[1], &n, &t1[t1_offset], lda,
+ cdumma, ldu, &evectl[evectl_offset], ldu, &n, &in, &work[
+ 1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ do_fio(&c__1, "CTREVC(R,S)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L240;
+ }
+
+ k = 1;
+ match = TRUE_;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ if (select[j]) {
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ i__5 = jj + j * evectr_dim1;
+ i__6 = jj + k * evectl_dim1;
+ if (evectr[i__5].r != evectl[i__6].r || evectr[i__5]
+ .i != evectl[i__6].i) {
+ match = FALSE_;
+ goto L180;
+ }
+/* L160: */
+ }
+ ++k;
+ }
+/* L170: */
+ }
+L180:
+ if (! match) {
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "CTREVC", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Compute the Left eigenvector Matrix: */
+
+ ntest = 10;
+ result[10] = ulpinv;
+ ctrevc_("Left", "All", &select[1], &n, &t1[t1_offset], lda, &
+ evectl[evectl_offset], ldu, cdumma, ldu, &n, &in, &work[1]
+, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+ do_fio(&c__1, "CTREVC(L,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L240;
+ }
+
+/* Test 10: | LT - WL | / ( |T| |L| ulp ) */
+
+ cget22_("C", "N", "C", &n, &t1[t1_offset], lda, &evectl[
+ evectl_offset], ldu, &w1[1], &work[1], &rwork[1], &dumma[
+ 2]);
+ result[10] = dumma[2];
+ if (dumma[3] > *thresh) {
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "CTREVC", (ftnlen)6);
+ do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Compute selected left eigenvectors and confirm that */
+/* they agree with previous left eigenvectors */
+
+ ctrevc_("Left", "Some", &select[1], &n, &t1[t1_offset], lda, &
+ evectr[evectr_offset], ldu, cdumma, ldu, &n, &in, &work[1]
+, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, "CTREVC(L,S)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L240;
+ }
+
+ k = 1;
+ match = TRUE_;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ if (select[j]) {
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ i__5 = jj + j * evectl_dim1;
+ i__6 = jj + k * evectr_dim1;
+ if (evectl[i__5].r != evectr[i__6].r || evectl[i__5]
+ .i != evectr[i__6].i) {
+ match = FALSE_;
+ goto L210;
+ }
+/* L190: */
+ }
+ ++k;
+ }
+/* L200: */
+ }
+L210:
+ if (! match) {
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "CTREVC", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Call CHSEIN for Right eigenvectors of H, do test 11 */
+
+ ntest = 11;
+ result[11] = ulpinv;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ select[j] = TRUE_;
+/* L220: */
+ }
+
+ chsein_("Right", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
+ lda, &w3[1], cdumma, ldu, &evectx[evectx_offset], ldu, &
+ n1, &in, &work[1], &rwork[1], &iwork[1], &iwork[1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, "CHSEIN(R)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ goto L240;
+ }
+ } else {
+
+/* Test 11: | HX - XW | / ( |H| |X| ulp ) */
+
+/* (from inverse iteration) */
+
+ cget22_("N", "N", "N", &n, &h__[h_offset], lda, &evectx[
+ evectx_offset], ldu, &w3[1], &work[1], &rwork[1],
+ dumma);
+ if (dumma[0] < ulpinv) {
+ result[11] = dumma[0] * aninv;
+ }
+ if (dumma[1] > *thresh) {
+ io___60.ciunit = *nounit;
+ s_wsfe(&io___60);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "CHSEIN", (ftnlen)6);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ }
+ }
+
+/* Call CHSEIN for Left eigenvectors of H, do test 12 */
+
+ ntest = 12;
+ result[12] = ulpinv;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ select[j] = TRUE_;
+/* L230: */
+ }
+
+ chsein_("Left", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
+ lda, &w3[1], &evecty[evecty_offset], ldu, cdumma, ldu, &
+ n1, &in, &work[1], &rwork[1], &iwork[1], &iwork[1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___61.ciunit = *nounit;
+ s_wsfe(&io___61);
+ do_fio(&c__1, "CHSEIN(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ goto L240;
+ }
+ } else {
+
+/* Test 12: | YH - WY | / ( |H| |Y| ulp ) */
+
+/* (from inverse iteration) */
+
+ cget22_("C", "N", "C", &n, &h__[h_offset], lda, &evecty[
+ evecty_offset], ldu, &w3[1], &work[1], &rwork[1], &
+ dumma[2]);
+ if (dumma[2] < ulpinv) {
+ result[12] = dumma[2] * aninv;
+ }
+ if (dumma[3] > *thresh) {
+ io___62.ciunit = *nounit;
+ s_wsfe(&io___62);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "CHSEIN", (ftnlen)6);
+ do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ }
+ }
+
+/* Call CUNMHR for Right eigenvectors of A, do test 13 */
+
+ ntest = 13;
+ result[13] = ulpinv;
+
+ cunmhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
+, ldu, &tau[1], &evectx[evectx_offset], ldu, &work[1],
+ nwork, &iinfo);
+ if (iinfo != 0) {
+ io___63.ciunit = *nounit;
+ s_wsfe(&io___63);
+ do_fio(&c__1, "CUNMHR(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ goto L240;
+ }
+ } else {
+
+/* Test 13: | AX - XW | / ( |A| |X| ulp ) */
+
+/* (from inverse iteration) */
+
+ cget22_("N", "N", "N", &n, &a[a_offset], lda, &evectx[
+ evectx_offset], ldu, &w3[1], &work[1], &rwork[1],
+ dumma);
+ if (dumma[0] < ulpinv) {
+ result[13] = dumma[0] * aninv;
+ }
+ }
+
+/* Call CUNMHR for Left eigenvectors of A, do test 14 */
+
+ ntest = 14;
+ result[14] = ulpinv;
+
+ cunmhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
+, ldu, &tau[1], &evecty[evecty_offset], ldu, &work[1],
+ nwork, &iinfo);
+ if (iinfo != 0) {
+ io___64.ciunit = *nounit;
+ s_wsfe(&io___64);
+ do_fio(&c__1, "CUNMHR(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ goto L240;
+ }
+ } else {
+
+/* Test 14: | YA - WY | / ( |A| |Y| ulp ) */
+
+/* (from inverse iteration) */
+
+ cget22_("C", "N", "C", &n, &a[a_offset], lda, &evecty[
+ evecty_offset], ldu, &w3[1], &work[1], &rwork[1], &
+ dumma[2]);
+ if (dumma[2] < ulpinv) {
+ result[14] = dumma[2] * aninv;
+ }
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L240:
+
+ ntestt += ntest;
+ slafts_("CHS", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh,
+ nounit, &nerrs);
+
+L250:
+ ;
+ }
+/* L260: */
+ }
+
+/* Summary */
+
+ slasum_("CHS", nounit, &nerrs, &ntestt);
+
+ return 0;
+
+
+/* End of CCHKHS */
+
+} /* cchkhs_ */
diff --git a/TESTING/EIG/cchkst.c b/TESTING/EIG/cchkst.c
new file mode 100644
index 0000000..b2b378d
--- /dev/null
+++ b/TESTING/EIG/cchkst.c
@@ -0,0 +1,2454 @@
+/* cchkst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__6 = 6;
+static real c_b39 = 1.f;
+static real c_b49 = 0.f;
+static integer c__4 = 4;
+static integer c__3 = 3;
+static integer c__10 = 10;
+static integer c__11 = 11;
+
+/* Subroutine */ int cchkst_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, integer *nounit,
+ complex *a, integer *lda, complex *ap, real *sd, real *se, real *d1,
+ real *d2, real *d3, real *d4, real *d5, real *wa1, real *wa2, real *
+ wa3, real *wr, complex *u, integer *ldu, complex *v, complex *vp,
+ complex *tau, complex *z__, complex *work, integer *lwork, real *
+ rwork, integer *lrwork, integer *iwork, integer *liwork, real *result,
+ integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,4,4,4,4,4,5,5,5,5,5,8,8,8,9,9,9,9,9,10 };
+ static integer kmagn[21] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3,1,1,1,2,3,1 };
+ static integer kmode[21] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0,4,3,1,4,4,3 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 CCHKST: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(/1x,a3,\002 -- Complex Hermitian eigenvalue p"
+ "roblem\002)";
+ static char fmt_9997[] = "(\002 Matrix types (see CCHKST for details):"
+ " \002)";
+ static char fmt_9996[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 5=Diagonal: clustered ent"
+ "ries.\002,/\002 2=Identity matrix. \002,\002"
+ " 6=Diagonal: large, evenly spaced.\002,/\002 3=Diagonal: evenl"
+ "y spaced entries. \002,\002 7=Diagonal: small, evenly spaced."
+ "\002,/\002 4=Diagonal: geometr. spaced entries.\002)";
+ static char fmt_9995[] = "(\002 Dense \002,a,\002 Matrices:\002,/\002 8"
+ "=Evenly spaced eigenvals. \002,\002 12=Small, evenly "
+ "spaced eigenvals.\002,/\002 9=Geometrically spaced eigenvals. "
+ " \002,\002 13=Matrix with random O(1) entries.\002,/\002 10=Cl"
+ "ustered eigenvalues. \002,\002 14=Matrix with large"
+ " random entries.\002,/\002 11=Large, evenly spaced eigenvals. "
+ " \002,\002 15=Matrix with small random entries.\002)";
+ static char fmt_9994[] = "(\002 16=Positive definite, evenly spaced eige"
+ "nvalues\002,/\002 17=Positive definite, geometrically spaced eig"
+ "envlaues\002,/\002 18=Positive definite, clustered eigenvalue"
+ "s\002,/\002 19=Positive definite, small evenly spaced eigenvalues"
+ "\002,/\002 20=Positive definite, large evenly spaced eigenvalue"
+ "s\002,/\002 21=Diagonally dominant tridiagonal, geometrically"
+ "\002,\002 spaced eigenvalues\002)";
+ static char fmt_9987[] = "(/\002Test performed: see CCHKST for details"
+ ".\002,/)";
+ static char fmt_9989[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
+ ",0p,f8.2)";
+ static char fmt_9988[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
+ ",1p,e10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, z_dim1,
+ z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1, r__2, r__3, r__4;
+ complex q__1;
+
+ /* Builtin functions */
+ double log(doublereal), sqrt(doublereal);
+ integer pow_ii(integer *, integer *);
+ double c_abs(complex *);
+ void r_cnjg(complex *, complex *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, m, n, m2, m3, jc, il, jr, iu;
+ real vl, vu;
+ integer nap, lgn;
+ real ulp;
+ integer inde;
+ real cond;
+ integer nmax;
+ real unfl, ovfl, temp1, temp2, temp3, temp4;
+ logical badnn;
+ extern doublereal ssxt1_(integer *, real *, integer *, real *, integer *,
+ real *, real *, real *);
+ extern /* Subroutine */ int chet21_(integer *, char *, integer *, integer
+ *, complex *, integer *, real *, real *, complex *, integer *,
+ complex *, integer *, complex *, complex *, real *, real *);
+ integer imode, lwedc;
+ extern /* Subroutine */ int chpt21_(integer *, char *, integer *, integer
+ *, complex *, real *, real *, complex *, integer *, complex *,
+ complex *, complex *, real *, real *);
+ real dumma[1];
+ integer iinfo;
+ real aninv, anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer itemp;
+ extern /* Subroutine */ int cstt21_(integer *, integer *, real *, real *,
+ real *, real *, complex *, integer *, complex *, real *, real *),
+ cstt22_(integer *, integer *, integer *, real *, real *, real *,
+ real *, complex *, integer *, complex *, integer *, real *, real *
+);
+ integer nmats, jsize, nerrs, itype, jtype, ntest;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ integer iseed2[4], log2ui;
+ extern /* Subroutine */ int slabad_(real *, real *), cstedc_(char *,
+ integer *, real *, real *, complex *, integer *, complex *,
+ integer *, real *, integer *, integer *, integer *, integer *);
+ integer liwedc, nblock;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int chetrd_(char *, integer *, complex *, integer
+ *, real *, real *, complex *, complex *, integer *, integer *), clacpy_(char *, integer *, integer *, complex *, integer
+ *, complex *, integer *);
+ integer idumma[1];
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *);
+ integer ioldsd[4], lrwedc;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int clatmr_(integer *, integer *, char *, integer
+ *, char *, complex *, integer *, real *, complex *, char *, char *
+, complex *, integer *, real *, complex *, integer *, real *,
+ char *, integer *, integer *, integer *, real *, real *, char *,
+ complex *, integer *, integer *, integer *);
+ extern doublereal slarnd_(integer *, integer *);
+ real abstol;
+ extern /* Subroutine */ int chptrd_(char *, integer *, complex *, real *,
+ real *, complex *, integer *), clatms_(integer *, integer
+ *, char *, integer *, char *, real *, integer *, real *, real *,
+ integer *, integer *, char *, complex *, integer *, complex *,
+ integer *), cstein_(integer *, real *,
+ real *, integer *, real *, integer *, integer *, complex *,
+ integer *, real *, integer *, integer *, integer *), xerbla_(char
+ *, integer *), sstech_(integer *, real *, real *, real *,
+ real *, real *, integer *);
+ integer indrwk;
+ extern /* Subroutine */ int cpteqr_(char *, integer *, real *, real *,
+ complex *, integer *, real *, integer *), cstemr_(char *,
+ char *, integer *, real *, real *, real *, real *, integer *,
+ integer *, integer *, real *, complex *, integer *, integer *,
+ integer *, logical *, real *, integer *, integer *, integer *,
+ integer *), csteqr_(char *, integer *, real *,
+ real *, complex *, integer *, real *, integer *), cungtr_(
+ char *, integer *, complex *, integer *, complex *, complex *,
+ integer *, integer *);
+ logical tryrac;
+ extern /* Subroutine */ int cupgtr_(char *, integer *, complex *, complex
+ *, complex *, integer *, complex *, integer *), slasum_(
+ char *, integer *, integer *, integer *);
+ integer nsplit;
+ real rtunfl, rtovfl, ulpinv;
+ integer mtypes, ntestt;
+ extern /* Subroutine */ int sstebz_(char *, char *, integer *, real *,
+ real *, integer *, integer *, real *, real *, real *, integer *,
+ integer *, real *, integer *, integer *, real *, integer *,
+ integer *), ssterf_(integer *, real *, real *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___68 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___71 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___73 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___74 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___75 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___80 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___81 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___82 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___83 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___84 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___85 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___86 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___87 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___88 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___89 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___90 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___91 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___92 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___93 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___94 = { 0, 0, 0, fmt_9987, 0 };
+ static cilist io___95 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___96 = { 0, 0, 0, fmt_9988, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKST checks the Hermitian eigenvalue problem routines. */
+
+/* CHETRD factors A as U S U* , where * means conjugate transpose, */
+/* S is real symmetric tridiagonal, and U is unitary. */
+/* CHETRD can use either just the lower or just the upper triangle */
+/* of A; CCHKST checks both cases. */
+/* U is represented as a product of Householder */
+/* transformations, whose vectors are stored in the first */
+/* n-1 columns of V, and whose scale factors are in TAU. */
+
+/* CHPTRD does the same as CHETRD, except that A and V are stored */
+/* in "packed" format. */
+
+/* CUNGTR constructs the matrix U from the contents of V and TAU. */
+
+/* CUPGTR constructs the matrix U from the contents of VP and TAU. */
+
+/* CSTEQR factors S as Z D1 Z* , where Z is the unitary */
+/* matrix of eigenvectors and D1 is a diagonal matrix with */
+/* the eigenvalues on the diagonal. D2 is the matrix of */
+/* eigenvalues computed when Z is not computed. */
+
+/* SSTERF computes D3, the matrix of eigenvalues, by the */
+/* PWK method, which does not yield eigenvectors. */
+
+/* CPTEQR factors S as Z4 D4 Z4* , for a */
+/* Hermitian positive definite tridiagonal matrix. */
+/* D5 is the matrix of eigenvalues computed when Z is not */
+/* computed. */
+
+/* SSTEBZ computes selected eigenvalues. WA1, WA2, and */
+/* WA3 will denote eigenvalues computed to high */
+/* absolute accuracy, with different range options. */
+/* WR will denote eigenvalues computed to high relative */
+/* accuracy. */
+
+/* CSTEIN computes Y, the eigenvectors of S, given the */
+/* eigenvalues. */
+
+/* CSTEDC factors S as Z D1 Z* , where Z is the unitary */
+/* matrix of eigenvectors and D1 is a diagonal matrix with */
+/* the eigenvalues on the diagonal ('I' option). It may also */
+/* update an input unitary matrix, usually the output */
+/* from CHETRD/CUNGTR or CHPTRD/CUPGTR ('V' option). It may */
+/* also just compute eigenvalues ('N' option). */
+
+/* CSTEMR factors S as Z D1 Z* , where Z is the unitary */
+/* matrix of eigenvectors and D1 is a diagonal matrix with */
+/* the eigenvalues on the diagonal ('I' option). CSTEMR */
+/* uses the Relatively Robust Representation whenever possible. */
+
+/* When CCHKST is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the Hermitian eigenroutines. For each matrix, a number */
+/* of tests will be performed: */
+
+/* (1) | A - V S V* | / ( |A| n ulp ) CHETRD( UPLO='U', ... ) */
+
+/* (2) | I - UV* | / ( n ulp ) CUNGTR( UPLO='U', ... ) */
+
+/* (3) | A - V S V* | / ( |A| n ulp ) CHETRD( UPLO='L', ... ) */
+
+/* (4) | I - UV* | / ( n ulp ) CUNGTR( UPLO='L', ... ) */
+
+/* (5-8) Same as 1-4, but for CHPTRD and CUPGTR. */
+
+/* (9) | S - Z D Z* | / ( |S| n ulp ) CSTEQR('V',...) */
+
+/* (10) | I - ZZ* | / ( n ulp ) CSTEQR('V',...) */
+
+/* (11) | D1 - D2 | / ( |D1| ulp ) CSTEQR('N',...) */
+
+/* (12) | D1 - D3 | / ( |D1| ulp ) SSTERF */
+
+/* (13) 0 if the true eigenvalues (computed by sturm count) */
+/* of S are within THRESH of */
+/* those in D1. 2*THRESH if they are not. (Tested using */
+/* SSTECH) */
+
+/* For S positive definite, */
+
+/* (14) | S - Z4 D4 Z4* | / ( |S| n ulp ) CPTEQR('V',...) */
+
+/* (15) | I - Z4 Z4* | / ( n ulp ) CPTEQR('V',...) */
+
+/* (16) | D4 - D5 | / ( 100 |D4| ulp ) CPTEQR('N',...) */
+
+/* When S is also diagonally dominant by the factor gamma < 1, */
+
+/* (17) max | D4(i) - WR(i) | / ( |D4(i)| omega ) , */
+/* i */
+/* omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 */
+/* SSTEBZ( 'A', 'E', ...) */
+
+/* (18) | WA1 - D3 | / ( |D3| ulp ) SSTEBZ( 'A', 'E', ...) */
+
+/* (19) ( max { min | WA2(i)-WA3(j) | } + */
+/* i j */
+/* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) */
+/* i j */
+/* SSTEBZ( 'I', 'E', ...) */
+
+/* (20) | S - Y WA1 Y* | / ( |S| n ulp ) SSTEBZ, CSTEIN */
+
+/* (21) | I - Y Y* | / ( n ulp ) SSTEBZ, CSTEIN */
+
+/* (22) | S - Z D Z* | / ( |S| n ulp ) CSTEDC('I') */
+
+/* (23) | I - ZZ* | / ( n ulp ) CSTEDC('I') */
+
+/* (24) | S - Z D Z* | / ( |S| n ulp ) CSTEDC('V') */
+
+/* (25) | I - ZZ* | / ( n ulp ) CSTEDC('V') */
+
+/* (26) | D1 - D2 | / ( |D1| ulp ) CSTEDC('V') and */
+/* CSTEDC('N') */
+
+/* Test 27 is disabled at the moment because CSTEMR does not */
+/* guarantee high relatvie accuracy. */
+
+/* (27) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , */
+/* i */
+/* omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 */
+/* CSTEMR('V', 'A') */
+
+/* (28) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , */
+/* i */
+/* omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 */
+/* CSTEMR('V', 'I') */
+
+/* Tests 29 through 34 are disable at present because CSTEMR */
+/* does not handle partial specturm requests. */
+
+/* (29) | S - Z D Z* | / ( |S| n ulp ) CSTEMR('V', 'I') */
+
+/* (30) | I - ZZ* | / ( n ulp ) CSTEMR('V', 'I') */
+
+/* (31) ( max { min | WA2(i)-WA3(j) | } + */
+/* i j */
+/* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) */
+/* i j */
+/* CSTEMR('N', 'I') vs. CSTEMR('V', 'I') */
+
+/* (32) | S - Z D Z* | / ( |S| n ulp ) CSTEMR('V', 'V') */
+
+/* (33) | I - ZZ* | / ( n ulp ) CSTEMR('V', 'V') */
+
+/* (34) ( max { min | WA2(i)-WA3(j) | } + */
+/* i j */
+/* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) */
+/* i j */
+/* CSTEMR('N', 'V') vs. CSTEMR('V', 'V') */
+
+/* (35) | S - Z D Z* | / ( |S| n ulp ) CSTEMR('V', 'A') */
+
+/* (36) | I - ZZ* | / ( n ulp ) CSTEMR('V', 'A') */
+
+/* (37) ( max { min | WA2(i)-WA3(j) | } + */
+/* i j */
+/* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) */
+/* i j */
+/* CSTEMR('N', 'A') vs. CSTEMR('V', 'A') */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (6) Same as (4), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (4), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U* D U, where U is unitary and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U* D U, where U is unitary and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U* D U, where U is unitary and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) Hermitian matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
+/* (16) Same as (8), but diagonal elements are all positive. */
+/* (17) Same as (9), but diagonal elements are all positive. */
+/* (18) Same as (10), but diagonal elements are all positive. */
+/* (19) Same as (16), but multiplied by SQRT( overflow threshold ) */
+/* (20) Same as (16), but multiplied by SQRT( underflow threshold ) */
+/* (21) A diagonally dominant tridiagonal matrix with geometrically */
+/* spaced diagonal entries 1, ..., ULP. */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* CCHKST does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, CCHKST */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to CCHKST to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace/output) COMPLEX array of */
+/* dimension ( LDA , max(NN) ) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually */
+/* used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at */
+/* least 1 and at least max( NN ). */
+
+/* AP (workspace) COMPLEX array of */
+/* dimension( max(NN)*max(NN+1)/2 ) */
+/* The matrix A stored in packed format. */
+
+/* SD (workspace/output) REAL array of */
+/* dimension( max(NN) ) */
+/* The diagonal of the tridiagonal matrix computed by CHETRD. */
+/* On exit, SD and SE contain the tridiagonal form of the */
+/* matrix in A. */
+
+/* SE (workspace/output) REAL array of */
+/* dimension( max(NN) ) */
+/* The off-diagonal of the tridiagonal matrix computed by */
+/* CHETRD. On exit, SD and SE contain the tridiagonal form of */
+/* the matrix in A. */
+
+/* D1 (workspace/output) REAL array of */
+/* dimension( max(NN) ) */
+/* The eigenvalues of A, as computed by CSTEQR simlutaneously */
+/* with Z. On exit, the eigenvalues in D1 correspond with the */
+/* matrix in A. */
+
+/* D2 (workspace/output) REAL array of */
+/* dimension( max(NN) ) */
+/* The eigenvalues of A, as computed by CSTEQR if Z is not */
+/* computed. On exit, the eigenvalues in D2 correspond with */
+/* the matrix in A. */
+
+/* D3 (workspace/output) REAL array of */
+/* dimension( max(NN) ) */
+/* The eigenvalues of A, as computed by SSTERF. On exit, the */
+/* eigenvalues in D3 correspond with the matrix in A. */
+
+/* U (workspace/output) COMPLEX array of */
+/* dimension( LDU, max(NN) ). */
+/* The unitary matrix computed by CHETRD + CUNGTR. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U, Z, and V. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* V (workspace/output) COMPLEX array of */
+/* dimension( LDU, max(NN) ). */
+/* The Housholder vectors computed by CHETRD in reducing A to */
+/* tridiagonal form. The vectors computed with UPLO='U' are */
+/* in the upper triangle, and the vectors computed with UPLO='L' */
+/* are in the lower triangle. (As described in CHETRD, the */
+/* sub- and superdiagonal are not set to 1, although the */
+/* true Householder vector has a 1 in that position. The */
+/* routines that use V, such as CUNGTR, set those entries to */
+/* 1 before using them, and then restore them later.) */
+
+/* VP (workspace) COMPLEX array of */
+/* dimension( max(NN)*max(NN+1)/2 ) */
+/* The matrix V stored in packed format. */
+
+/* TAU (workspace/output) COMPLEX array of */
+/* dimension( max(NN) ) */
+/* The Householder factors computed by CHETRD in reducing A */
+/* to tridiagonal form. */
+
+/* Z (workspace/output) COMPLEX array of */
+/* dimension( LDU, max(NN) ). */
+/* The unitary matrix of eigenvectors computed by CSTEQR, */
+/* CPTEQR, and CSTEIN. */
+
+/* WORK (workspace/output) COMPLEX array of */
+/* dimension( LWORK ) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 3 * Nmax**2 */
+/* where Nmax = max( NN(j), 2 ) and lg = log base 2. */
+
+/* IWORK (workspace/output) INTEGER array, */
+/* dimension (6 + 6*Nmax + 5 * Nmax * lg Nmax ) */
+/* where Nmax = max( NN(j), 2 ) and lg = log base 2. */
+/* Workspace. */
+
+/* RWORK (workspace/output) REAL array of */
+/* dimension( ??? ) */
+
+/* RESULT (output) REAL array, dimension (26) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -5: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -23: LDU < 1 or LDU < NMAX. */
+/* -29: LWORK too small. */
+/* If CLATMR, CLATMS, CHETRD, CUNGTR, CSTEQR, SSTERF, */
+/* or CUNMC2 returns an error code, the */
+/* absolute value of it is returned. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests performed, or which can */
+/* be performed so far, for the current matrix. */
+/* NTESTT The total number of tests performed so far. */
+/* NBLOCK Blocksize as returned by ENVIR. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far. */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ap;
+ --sd;
+ --se;
+ --d1;
+ --d2;
+ --d3;
+ --d4;
+ --d5;
+ --wa1;
+ --wa2;
+ --wa3;
+ --wr;
+ z_dim1 = *ldu;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ v_dim1 = *ldu;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --vp;
+ --tau;
+ --work;
+ --rwork;
+ --iwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Keep ftnchek happy */
+ idumma[0] = 1;
+
+/* Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+ tryrac = TRUE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+ nblock = ilaenv_(&c__1, "CHETRD", "L", &nmax, &c_n1, &c_n1, &c_n1);
+/* Computing MIN */
+ i__1 = nmax, i__2 = max(1,nblock);
+ nblock = min(i__1,i__2);
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*lda < nmax) {
+ *info = -9;
+ } else if (*ldu < nmax) {
+ *info = -23;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = max(2,nmax);
+ if (i__1 * i__1 << 1 > *lwork) {
+ *info = -29;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CCHKST", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ slabad_(&unfl, &ovfl);
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ ulpinv = 1.f / ulp;
+ log2ui = (integer) (log(ulpinv) / log(2.f));
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+
+/* Loop over sizes, types */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed2[i__ - 1] = iseed[i__];
+/* L20: */
+ }
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (n > 0) {
+ lgn = (integer) (log((real) n) / log(2.f));
+ if (pow_ii(&c__2, &lgn) < n) {
+ ++lgn;
+ }
+ if (pow_ii(&c__2, &lgn) < n) {
+ ++lgn;
+ }
+/* Computing 2nd power */
+ i__2 = n;
+ lwedc = (n << 2) + 1 + (n << 1) * lgn + i__2 * i__2 * 3;
+/* Computing 2nd power */
+ i__2 = n;
+ lrwedc = n * 3 + 1 + (n << 1) * lgn + i__2 * i__2 * 3;
+ liwedc = n * 6 + 6 + n * 5 * lgn;
+ } else {
+ lwedc = 8;
+ lrwedc = 7;
+ liwedc = 12;
+ }
+ nap = n * (n + 1) / 2;
+ aninv = 1.f / (real) max(1,n);
+
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L300;
+ }
+ ++nmats;
+ ntest = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L30: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log Hermitian, w/ eigenvalues */
+/* =6 random (none) */
+/* =7 random diagonal */
+/* =8 random Hermitian */
+/* =9 positive definite */
+/* =10 diagonally dominant tridiagonal */
+
+ if (mtypes > 21) {
+ goto L100;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.f;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * aninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * n * ulpinv;
+ goto L70;
+
+L70:
+
+ claset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ iinfo = 0;
+ if (jtype <= 15) {
+ cond = ulpinv;
+ } else {
+ cond = ulpinv * aninv / 10.f;
+ }
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = jc + jc * a_dim1;
+ a[i__4].r = anorm, a[i__4].i = 0.f;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[
+ 1], &iinfo);
+
+
+ } else if (itype == 5) {
+
+/* Hermitian, eigenvalues specified */
+
+ clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[1], &
+ iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ clatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &c_b39,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &c__0, &
+ c__0, &c_b49, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Hermitian, random eigenvalues */
+
+ clatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &c_b39,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &n, &
+ c_b49, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* Positive definite, eigenvalues specified. */
+
+ clatms_(&n, &n, "S", &iseed[1], "P", &rwork[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[1], &
+ iinfo);
+
+ } else if (itype == 10) {
+
+/* Positive definite tridiagonal, eigenvalues specified. */
+
+ clatms_(&n, &n, "S", &iseed[1], "P", &rwork[1], &imode, &cond,
+ &anorm, &c__1, &c__1, "N", &a[a_offset], lda, &work[
+ 1], &iinfo);
+ i__3 = n;
+ for (i__ = 2; i__ <= i__3; ++i__) {
+ temp1 = c_abs(&a[i__ - 1 + i__ * a_dim1]);
+ i__4 = i__ - 1 + (i__ - 1) * a_dim1;
+ i__5 = i__ + i__ * a_dim1;
+ q__1.r = a[i__4].r * a[i__5].r - a[i__4].i * a[i__5].i,
+ q__1.i = a[i__4].r * a[i__5].i + a[i__4].i * a[
+ i__5].r;
+ temp2 = sqrt(c_abs(&q__1));
+ if (temp1 > temp2 * .5f) {
+ i__4 = i__ - 1 + i__ * a_dim1;
+ i__5 = i__ - 1 + i__ * a_dim1;
+ r__1 = temp2 * .5f / (unfl + temp1);
+ q__1.r = r__1 * a[i__5].r, q__1.i = r__1 * a[i__5].i;
+ a[i__4].r = q__1.r, a[i__4].i = q__1.i;
+ i__4 = i__ + (i__ - 1) * a_dim1;
+ r_cnjg(&q__1, &a[i__ - 1 + i__ * a_dim1]);
+ a[i__4].r = q__1.r, a[i__4].i = q__1.i;
+ }
+/* L90: */
+ }
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L100:
+
+/* Call CHETRD and CUNGTR to compute S and U from */
+/* upper triangle. */
+
+ clacpy_("U", &n, &n, &a[a_offset], lda, &v[v_offset], ldu);
+
+ ntest = 1;
+ chetrd_("U", &n, &v[v_offset], ldu, &sd[1], &se[1], &tau[1], &
+ work[1], lwork, &iinfo);
+
+ if (iinfo != 0) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "CHETRD(U)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[1] = ulpinv;
+ goto L280;
+ }
+ }
+
+ clacpy_("U", &n, &n, &v[v_offset], ldu, &u[u_offset], ldu);
+
+ ntest = 2;
+ cungtr_("U", &n, &u[u_offset], ldu, &tau[1], &work[1], lwork, &
+ iinfo);
+ if (iinfo != 0) {
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "CUNGTR(U)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[2] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do tests 1 and 2 */
+
+ chet21_(&c__2, "Upper", &n, &c__1, &a[a_offset], lda, &sd[1], &se[
+ 1], &u[u_offset], ldu, &v[v_offset], ldu, &tau[1], &work[
+ 1], &rwork[1], &result[1]);
+ chet21_(&c__3, "Upper", &n, &c__1, &a[a_offset], lda, &sd[1], &se[
+ 1], &u[u_offset], ldu, &v[v_offset], ldu, &tau[1], &work[
+ 1], &rwork[1], &result[2]);
+
+/* Call CHETRD and CUNGTR to compute S and U from */
+/* lower triangle, do tests. */
+
+ clacpy_("L", &n, &n, &a[a_offset], lda, &v[v_offset], ldu);
+
+ ntest = 3;
+ chetrd_("L", &n, &v[v_offset], ldu, &sd[1], &se[1], &tau[1], &
+ work[1], lwork, &iinfo);
+
+ if (iinfo != 0) {
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "CHETRD(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[3] = ulpinv;
+ goto L280;
+ }
+ }
+
+ clacpy_("L", &n, &n, &v[v_offset], ldu, &u[u_offset], ldu);
+
+ ntest = 4;
+ cungtr_("L", &n, &u[u_offset], ldu, &tau[1], &work[1], lwork, &
+ iinfo);
+ if (iinfo != 0) {
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, "CUNGTR(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[4] = ulpinv;
+ goto L280;
+ }
+ }
+
+ chet21_(&c__2, "Lower", &n, &c__1, &a[a_offset], lda, &sd[1], &se[
+ 1], &u[u_offset], ldu, &v[v_offset], ldu, &tau[1], &work[
+ 1], &rwork[1], &result[3]);
+ chet21_(&c__3, "Lower", &n, &c__1, &a[a_offset], lda, &sd[1], &se[
+ 1], &u[u_offset], ldu, &v[v_offset], ldu, &tau[1], &work[
+ 1], &rwork[1], &result[4]);
+
+/* Store the upper triangle of A in AP */
+
+ i__ = 0;
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = jc;
+ for (jr = 1; jr <= i__4; ++jr) {
+ ++i__;
+ i__5 = i__;
+ i__6 = jr + jc * a_dim1;
+ ap[i__5].r = a[i__6].r, ap[i__5].i = a[i__6].i;
+/* L110: */
+ }
+/* L120: */
+ }
+
+/* Call CHPTRD and CUPGTR to compute S and U from AP */
+
+ ccopy_(&nap, &ap[1], &c__1, &vp[1], &c__1);
+
+ ntest = 5;
+ chptrd_("U", &n, &vp[1], &sd[1], &se[1], &tau[1], &iinfo);
+
+ if (iinfo != 0) {
+ io___48.ciunit = *nounit;
+ s_wsfe(&io___48);
+ do_fio(&c__1, "CHPTRD(U)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[5] = ulpinv;
+ goto L280;
+ }
+ }
+
+ ntest = 6;
+ cupgtr_("U", &n, &vp[1], &tau[1], &u[u_offset], ldu, &work[1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ do_fio(&c__1, "CUPGTR(U)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[6] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do tests 5 and 6 */
+
+ chpt21_(&c__2, "Upper", &n, &c__1, &ap[1], &sd[1], &se[1], &u[
+ u_offset], ldu, &vp[1], &tau[1], &work[1], &rwork[1], &
+ result[5]);
+ chpt21_(&c__3, "Upper", &n, &c__1, &ap[1], &sd[1], &se[1], &u[
+ u_offset], ldu, &vp[1], &tau[1], &work[1], &rwork[1], &
+ result[6]);
+
+/* Store the lower triangle of A in AP */
+
+ i__ = 0;
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = jc; jr <= i__4; ++jr) {
+ ++i__;
+ i__5 = i__;
+ i__6 = jr + jc * a_dim1;
+ ap[i__5].r = a[i__6].r, ap[i__5].i = a[i__6].i;
+/* L130: */
+ }
+/* L140: */
+ }
+
+/* Call CHPTRD and CUPGTR to compute S and U from AP */
+
+ ccopy_(&nap, &ap[1], &c__1, &vp[1], &c__1);
+
+ ntest = 7;
+ chptrd_("L", &n, &vp[1], &sd[1], &se[1], &tau[1], &iinfo);
+
+ if (iinfo != 0) {
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ do_fio(&c__1, "CHPTRD(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[7] = ulpinv;
+ goto L280;
+ }
+ }
+
+ ntest = 8;
+ cupgtr_("L", &n, &vp[1], &tau[1], &u[u_offset], ldu, &work[1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "CUPGTR(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[8] = ulpinv;
+ goto L280;
+ }
+ }
+
+ chpt21_(&c__2, "Lower", &n, &c__1, &ap[1], &sd[1], &se[1], &u[
+ u_offset], ldu, &vp[1], &tau[1], &work[1], &rwork[1], &
+ result[7]);
+ chpt21_(&c__3, "Lower", &n, &c__1, &ap[1], &sd[1], &se[1], &u[
+ u_offset], ldu, &vp[1], &tau[1], &work[1], &rwork[1], &
+ result[8]);
+
+/* Call CSTEQR to compute D1, D2, and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ scopy_(&n, &sd[1], &c__1, &d1[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &rwork[1], &c__1);
+ }
+ claset_("Full", &n, &n, &c_b1, &c_b2, &z__[z_offset], ldu);
+
+ ntest = 9;
+ csteqr_("V", &n, &d1[1], &rwork[1], &z__[z_offset], ldu, &rwork[n
+ + 1], &iinfo);
+ if (iinfo != 0) {
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "CSTEQR(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[9] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Compute D2 */
+
+ scopy_(&n, &sd[1], &c__1, &d2[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &rwork[1], &c__1);
+ }
+
+ ntest = 11;
+ csteqr_("N", &n, &d2[1], &rwork[1], &work[1], ldu, &rwork[n + 1],
+ &iinfo);
+ if (iinfo != 0) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, "CSTEQR(N)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[11] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Compute D3 (using PWK method) */
+
+ scopy_(&n, &sd[1], &c__1, &d3[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &rwork[1], &c__1);
+ }
+
+ ntest = 12;
+ ssterf_(&n, &d3[1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ do_fio(&c__1, "SSTERF", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[12] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 9 and 10 */
+
+ cstt21_(&n, &c__0, &sd[1], &se[1], &d1[1], dumma, &z__[z_offset],
+ ldu, &work[1], &rwork[1], &result[9]);
+
+/* Do Tests 11 and 12 */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ temp3 = 0.f;
+ temp4 = 0.f;
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d1[j], dabs(r__1)), r__3 = max(
+ r__3,r__4), r__4 = (r__2 = d2[j], dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d1[j] - d2[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* Computing MAX */
+ r__3 = temp3, r__4 = (r__1 = d1[j], dabs(r__1)), r__3 = max(
+ r__3,r__4), r__4 = (r__2 = d3[j], dabs(r__2));
+ temp3 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp4, r__3 = (r__1 = d1[j] - d3[j], dabs(r__1));
+ temp4 = dmax(r__2,r__3);
+/* L150: */
+ }
+
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[11] = temp2 / dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp3,temp4);
+ result[12] = temp4 / dmax(r__1,r__2);
+
+/* Do Test 13 -- Sturm Sequence Test of Eigenvalues */
+/* Go up by factors of two until it succeeds */
+
+ ntest = 13;
+ temp1 = *thresh * (.5f - ulp);
+
+ i__3 = log2ui;
+ for (j = 0; j <= i__3; ++j) {
+ sstech_(&n, &sd[1], &se[1], &d1[1], &temp1, &rwork[1], &iinfo)
+ ;
+ if (iinfo == 0) {
+ goto L170;
+ }
+ temp1 *= 2.f;
+/* L160: */
+ }
+
+L170:
+ result[13] = temp1;
+
+/* For positive definite matrices ( JTYPE.GT.15 ) call CPTEQR */
+/* and do tests 14, 15, and 16 . */
+
+ if (jtype > 15) {
+
+/* Compute D4 and Z4 */
+
+ scopy_(&n, &sd[1], &c__1, &d4[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &rwork[1], &c__1);
+ }
+ claset_("Full", &n, &n, &c_b1, &c_b2, &z__[z_offset], ldu);
+
+ ntest = 14;
+ cpteqr_("V", &n, &d4[1], &rwork[1], &z__[z_offset], ldu, &
+ rwork[n + 1], &iinfo);
+ if (iinfo != 0) {
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ do_fio(&c__1, "CPTEQR(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[14] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 14 and 15 */
+
+ cstt21_(&n, &c__0, &sd[1], &se[1], &d4[1], dumma, &z__[
+ z_offset], ldu, &work[1], &rwork[1], &result[14]);
+
+/* Compute D5 */
+
+ scopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &rwork[1], &c__1);
+ }
+
+ ntest = 16;
+ cpteqr_("N", &n, &d5[1], &rwork[1], &z__[z_offset], ldu, &
+ rwork[n + 1], &iinfo);
+ if (iinfo != 0) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, "CPTEQR(N)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[16] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Test 16 */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d4[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = d5[j], dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d4[j] - d5[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L180: */
+ }
+
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * 100.f * dmax(temp1,temp2);
+ result[16] = temp2 / dmax(r__1,r__2);
+ } else {
+ result[14] = 0.f;
+ result[15] = 0.f;
+ result[16] = 0.f;
+ }
+
+/* Call SSTEBZ with different options and do tests 17-18. */
+
+/* If S is positive definite and diagonally dominant, */
+/* ask for all eigenvalues with high relative accuracy. */
+
+ vl = 0.f;
+ vu = 0.f;
+ il = 0;
+ iu = 0;
+ if (jtype == 21) {
+ ntest = 17;
+ abstol = unfl + unfl;
+ sstebz_("A", "E", &n, &vl, &vu, &il, &iu, &abstol, &sd[1], &
+ se[1], &m, &nsplit, &wr[1], &iwork[1], &iwork[n + 1],
+ &rwork[1], &iwork[(n << 1) + 1], &iinfo);
+ if (iinfo != 0) {
+ io___67.ciunit = *nounit;
+ s_wsfe(&io___67);
+ do_fio(&c__1, "SSTEBZ(A,rel)", (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[17] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do test 17 */
+
+ temp2 = (n * 2.f - 1.f) * 2.f * ulp * 3.f / .0625f;
+
+ temp1 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__2 = d4[j] - wr[n - j + 1], dabs(
+ r__2)) / (abstol + (r__1 = d4[j], dabs(r__1)));
+ temp1 = dmax(r__3,r__4);
+/* L190: */
+ }
+
+ result[17] = temp1 / temp2;
+ } else {
+ result[17] = 0.f;
+ }
+
+/* Now ask for all eigenvalues with high absolute accuracy. */
+
+ ntest = 18;
+ abstol = unfl + unfl;
+ sstebz_("A", "E", &n, &vl, &vu, &il, &iu, &abstol, &sd[1], &se[1],
+ &m, &nsplit, &wa1[1], &iwork[1], &iwork[n + 1], &rwork[1]
+, &iwork[(n << 1) + 1], &iinfo);
+ if (iinfo != 0) {
+ io___68.ciunit = *nounit;
+ s_wsfe(&io___68);
+ do_fio(&c__1, "SSTEBZ(A)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[18] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do test 18 */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d3[j], dabs(r__1)), r__3 = max(
+ r__3,r__4), r__4 = (r__2 = wa1[j], dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d3[j] - wa1[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L200: */
+ }
+
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[18] = temp2 / dmax(r__1,r__2);
+
+/* Choose random values for IL and IU, and ask for the */
+/* IL-th through IU-th eigenvalues. */
+
+ ntest = 19;
+ if (n <= 1) {
+ il = 1;
+ iu = n;
+ } else {
+ il = (n - 1) * (integer) slarnd_(&c__1, iseed2) + 1;
+ iu = (n - 1) * (integer) slarnd_(&c__1, iseed2) + 1;
+ if (iu < il) {
+ itemp = iu;
+ iu = il;
+ il = itemp;
+ }
+ }
+
+ sstebz_("I", "E", &n, &vl, &vu, &il, &iu, &abstol, &sd[1], &se[1],
+ &m2, &nsplit, &wa2[1], &iwork[1], &iwork[n + 1], &rwork[
+ 1], &iwork[(n << 1) + 1], &iinfo);
+ if (iinfo != 0) {
+ io___71.ciunit = *nounit;
+ s_wsfe(&io___71);
+ do_fio(&c__1, "SSTEBZ(I)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[19] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Determine the values VL and VU of the IL-th and IU-th */
+/* eigenvalues and ask for all eigenvalues in this range. */
+
+ if (n > 0) {
+ if (il != 1) {
+/* Computing MAX */
+ r__1 = (wa1[il] - wa1[il - 1]) * .5f, r__2 = ulp * anorm,
+ r__1 = max(r__1,r__2), r__2 = rtunfl * 2.f;
+ vl = wa1[il] - dmax(r__1,r__2);
+ } else {
+/* Computing MAX */
+ r__1 = (wa1[n] - wa1[1]) * .5f, r__2 = ulp * anorm, r__1 =
+ max(r__1,r__2), r__2 = rtunfl * 2.f;
+ vl = wa1[1] - dmax(r__1,r__2);
+ }
+ if (iu != n) {
+/* Computing MAX */
+ r__1 = (wa1[iu + 1] - wa1[iu]) * .5f, r__2 = ulp * anorm,
+ r__1 = max(r__1,r__2), r__2 = rtunfl * 2.f;
+ vu = wa1[iu] + dmax(r__1,r__2);
+ } else {
+/* Computing MAX */
+ r__1 = (wa1[n] - wa1[1]) * .5f, r__2 = ulp * anorm, r__1 =
+ max(r__1,r__2), r__2 = rtunfl * 2.f;
+ vu = wa1[n] + dmax(r__1,r__2);
+ }
+ } else {
+ vl = 0.f;
+ vu = 1.f;
+ }
+
+ sstebz_("V", "E", &n, &vl, &vu, &il, &iu, &abstol, &sd[1], &se[1],
+ &m3, &nsplit, &wa3[1], &iwork[1], &iwork[n + 1], &rwork[
+ 1], &iwork[(n << 1) + 1], &iinfo);
+ if (iinfo != 0) {
+ io___73.ciunit = *nounit;
+ s_wsfe(&io___73);
+ do_fio(&c__1, "SSTEBZ(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[19] = ulpinv;
+ goto L280;
+ }
+ }
+
+ if (m3 == 0 && n != 0) {
+ result[19] = ulpinv;
+ goto L280;
+ }
+
+/* Do test 19 */
+
+ temp1 = ssxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &ulp, &
+ unfl);
+ temp2 = ssxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &ulp, &
+ unfl);
+ if (n > 0) {
+/* Computing MAX */
+ r__2 = (r__1 = wa1[n], dabs(r__1)), r__3 = dabs(wa1[1]);
+ temp3 = dmax(r__2,r__3);
+ } else {
+ temp3 = 0.f;
+ }
+
+/* Computing MAX */
+ r__1 = unfl, r__2 = temp3 * ulp;
+ result[19] = (temp1 + temp2) / dmax(r__1,r__2);
+
+/* Call CSTEIN to compute eigenvectors corresponding to */
+/* eigenvalues in WA1. (First call SSTEBZ again, to make sure */
+/* it returns these eigenvalues in the correct order.) */
+
+ ntest = 21;
+ sstebz_("A", "B", &n, &vl, &vu, &il, &iu, &abstol, &sd[1], &se[1],
+ &m, &nsplit, &wa1[1], &iwork[1], &iwork[n + 1], &rwork[1]
+, &iwork[(n << 1) + 1], &iinfo);
+ if (iinfo != 0) {
+ io___74.ciunit = *nounit;
+ s_wsfe(&io___74);
+ do_fio(&c__1, "SSTEBZ(A,B)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[20] = ulpinv;
+ result[21] = ulpinv;
+ goto L280;
+ }
+ }
+
+ cstein_(&n, &sd[1], &se[1], &m, &wa1[1], &iwork[1], &iwork[n + 1],
+ &z__[z_offset], ldu, &rwork[1], &iwork[(n << 1) + 1], &
+ iwork[n * 3 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___75.ciunit = *nounit;
+ s_wsfe(&io___75);
+ do_fio(&c__1, "CSTEIN", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[20] = ulpinv;
+ result[21] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do tests 20 and 21 */
+
+ cstt21_(&n, &c__0, &sd[1], &se[1], &wa1[1], dumma, &z__[z_offset],
+ ldu, &work[1], &rwork[1], &result[20]);
+
+/* Call CSTEDC(I) to compute D1 and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ inde = 1;
+ indrwk = inde + n;
+ scopy_(&n, &sd[1], &c__1, &d1[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &rwork[inde], &c__1);
+ }
+ claset_("Full", &n, &n, &c_b1, &c_b2, &z__[z_offset], ldu);
+
+ ntest = 22;
+ cstedc_("I", &n, &d1[1], &rwork[inde], &z__[z_offset], ldu, &work[
+ 1], &lwedc, &rwork[indrwk], &lrwedc, &iwork[1], &liwedc, &
+ iinfo);
+ if (iinfo != 0) {
+ io___78.ciunit = *nounit;
+ s_wsfe(&io___78);
+ do_fio(&c__1, "CSTEDC(I)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[22] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 22 and 23 */
+
+ cstt21_(&n, &c__0, &sd[1], &se[1], &d1[1], dumma, &z__[z_offset],
+ ldu, &work[1], &rwork[1], &result[22]);
+
+/* Call CSTEDC(V) to compute D1 and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ scopy_(&n, &sd[1], &c__1, &d1[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &rwork[inde], &c__1);
+ }
+ claset_("Full", &n, &n, &c_b1, &c_b2, &z__[z_offset], ldu);
+
+ ntest = 24;
+ cstedc_("V", &n, &d1[1], &rwork[inde], &z__[z_offset], ldu, &work[
+ 1], &lwedc, &rwork[indrwk], &lrwedc, &iwork[1], &liwedc, &
+ iinfo);
+ if (iinfo != 0) {
+ io___79.ciunit = *nounit;
+ s_wsfe(&io___79);
+ do_fio(&c__1, "CSTEDC(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[24] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 24 and 25 */
+
+ cstt21_(&n, &c__0, &sd[1], &se[1], &d1[1], dumma, &z__[z_offset],
+ ldu, &work[1], &rwork[1], &result[24]);
+
+/* Call CSTEDC(N) to compute D2, do tests. */
+
+/* Compute D2 */
+
+ scopy_(&n, &sd[1], &c__1, &d2[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &rwork[inde], &c__1);
+ }
+ claset_("Full", &n, &n, &c_b1, &c_b2, &z__[z_offset], ldu);
+
+ ntest = 26;
+ cstedc_("N", &n, &d2[1], &rwork[inde], &z__[z_offset], ldu, &work[
+ 1], &lwedc, &rwork[indrwk], &lrwedc, &iwork[1], &liwedc, &
+ iinfo);
+ if (iinfo != 0) {
+ io___80.ciunit = *nounit;
+ s_wsfe(&io___80);
+ do_fio(&c__1, "CSTEDC(N)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[26] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Test 26 */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d1[j], dabs(r__1)), r__3 = max(
+ r__3,r__4), r__4 = (r__2 = d2[j], dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d1[j] - d2[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L210: */
+ }
+
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[26] = temp2 / dmax(r__1,r__2);
+
+/* Only test CSTEMR if IEEE compliant */
+
+ if (ilaenv_(&c__10, "CSTEMR", "VA", &c__1, &c__0, &c__0, &c__0) == 1 && ilaenv_(&c__11, "CSTEMR",
+ "VA", &c__1, &c__0, &c__0, &c__0) ==
+ 1) {
+
+/* Call CSTEMR, do test 27 (relative eigenvalue accuracy) */
+
+/* If S is positive definite and diagonally dominant, */
+/* ask for all eigenvalues with high relative accuracy. */
+
+ vl = 0.f;
+ vu = 0.f;
+ il = 0;
+ iu = 0;
+ if (FALSE_) {
+ ntest = 27;
+ abstol = unfl + unfl;
+ i__3 = *lwork - (n << 1);
+ cstemr_("V", "A", &n, &sd[1], &se[1], &vl, &vu, &il, &iu,
+ &m, &wr[1], &z__[z_offset], ldu, &n, &iwork[1], &
+ tryrac, &rwork[1], lrwork, &iwork[(n << 1) + 1], &
+ i__3, &iinfo);
+ if (iinfo != 0) {
+ io___81.ciunit = *nounit;
+ s_wsfe(&io___81);
+ do_fio(&c__1, "CSTEMR(V,A,rel)", (ftnlen)15);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[27] = ulpinv;
+ goto L270;
+ }
+ }
+
+/* Do test 27 */
+
+ temp2 = (n * 2.f - 1.f) * 2.f * ulp * 3.f / .0625f;
+
+ temp1 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__2 = d4[j] - wr[n - j + 1],
+ dabs(r__2)) / (abstol + (r__1 = d4[j], dabs(
+ r__1)));
+ temp1 = dmax(r__3,r__4);
+/* L220: */
+ }
+
+ result[27] = temp1 / temp2;
+
+ il = (n - 1) * (integer) slarnd_(&c__1, iseed2) + 1;
+ iu = (n - 1) * (integer) slarnd_(&c__1, iseed2) + 1;
+ if (iu < il) {
+ itemp = iu;
+ iu = il;
+ il = itemp;
+ }
+
+ if (FALSE_) {
+ ntest = 28;
+ abstol = unfl + unfl;
+ i__3 = *lwork - (n << 1);
+ cstemr_("V", "I", &n, &sd[1], &se[1], &vl, &vu, &il, &
+ iu, &m, &wr[1], &z__[z_offset], ldu, &n, &
+ iwork[1], &tryrac, &rwork[1], lrwork, &iwork[(
+ n << 1) + 1], &i__3, &iinfo);
+
+ if (iinfo != 0) {
+ io___82.ciunit = *nounit;
+ s_wsfe(&io___82);
+ do_fio(&c__1, "CSTEMR(V,I,rel)", (ftnlen)15);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[28] = ulpinv;
+ goto L270;
+ }
+ }
+
+
+/* Do test 28 */
+
+ temp2 = (n * 2.f - 1.f) * 2.f * ulp * 3.f / .0625f;
+
+ temp1 = 0.f;
+ i__3 = iu;
+ for (j = il; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__2 = wr[j - il + 1] - d4[
+ n - j + 1], dabs(r__2)) / (abstol + (r__1
+ = wr[j - il + 1], dabs(r__1)));
+ temp1 = dmax(r__3,r__4);
+/* L230: */
+ }
+
+ result[28] = temp1 / temp2;
+ } else {
+ result[28] = 0.f;
+ }
+ } else {
+ result[27] = 0.f;
+ result[28] = 0.f;
+ }
+
+/* Call CSTEMR(V,I) to compute D1 and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ scopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &rwork[1], &c__1);
+ }
+ claset_("Full", &n, &n, &c_b1, &c_b2, &z__[z_offset], ldu);
+
+ if (FALSE_) {
+ ntest = 29;
+ il = (n - 1) * (integer) slarnd_(&c__1, iseed2) + 1;
+ iu = (n - 1) * (integer) slarnd_(&c__1, iseed2) + 1;
+ if (iu < il) {
+ itemp = iu;
+ iu = il;
+ il = itemp;
+ }
+ i__3 = *lrwork - n;
+ i__4 = *liwork - (n << 1);
+ cstemr_("V", "I", &n, &d5[1], &rwork[1], &vl, &vu, &il, &
+ iu, &m, &d1[1], &z__[z_offset], ldu, &n, &iwork[1]
+, &tryrac, &rwork[n + 1], &i__3, &iwork[(n << 1)
+ + 1], &i__4, &iinfo);
+ if (iinfo != 0) {
+ io___83.ciunit = *nounit;
+ s_wsfe(&io___83);
+ do_fio(&c__1, "CSTEMR(V,I)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[29] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 29 and 30 */
+
+
+/* Call CSTEMR to compute D2, do tests. */
+
+/* Compute D2 */
+
+ scopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &rwork[1], &c__1);
+ }
+
+ ntest = 31;
+ i__3 = *lrwork - n;
+ i__4 = *liwork - (n << 1);
+ cstemr_("N", "I", &n, &d5[1], &rwork[1], &vl, &vu, &il, &
+ iu, &m, &d2[1], &z__[z_offset], ldu, &n, &iwork[1]
+, &tryrac, &rwork[n + 1], &i__3, &iwork[(n << 1)
+ + 1], &i__4, &iinfo);
+ if (iinfo != 0) {
+ io___84.ciunit = *nounit;
+ s_wsfe(&io___84);
+ do_fio(&c__1, "CSTEMR(N,I)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[31] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Test 31 */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+
+ i__3 = iu - il + 1;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d1[j], dabs(r__1)), r__3
+ = max(r__3,r__4), r__4 = (r__2 = d2[j], dabs(
+ r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d1[j] - d2[j], dabs(r__1)
+ );
+ temp2 = dmax(r__2,r__3);
+/* L240: */
+ }
+
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[31] = temp2 / dmax(r__1,r__2);
+
+
+/* Call CSTEMR(V,V) to compute D1 and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ scopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &rwork[1], &c__1);
+ }
+ claset_("Full", &n, &n, &c_b1, &c_b2, &z__[z_offset], ldu);
+
+ ntest = 32;
+
+ if (n > 0) {
+ if (il != 1) {
+/* Computing MAX */
+ r__1 = (d2[il] - d2[il - 1]) * .5f, r__2 = ulp *
+ anorm, r__1 = max(r__1,r__2), r__2 =
+ rtunfl * 2.f;
+ vl = d2[il] - dmax(r__1,r__2);
+ } else {
+/* Computing MAX */
+ r__1 = (d2[n] - d2[1]) * .5f, r__2 = ulp * anorm,
+ r__1 = max(r__1,r__2), r__2 = rtunfl *
+ 2.f;
+ vl = d2[1] - dmax(r__1,r__2);
+ }
+ if (iu != n) {
+/* Computing MAX */
+ r__1 = (d2[iu + 1] - d2[iu]) * .5f, r__2 = ulp *
+ anorm, r__1 = max(r__1,r__2), r__2 =
+ rtunfl * 2.f;
+ vu = d2[iu] + dmax(r__1,r__2);
+ } else {
+/* Computing MAX */
+ r__1 = (d2[n] - d2[1]) * .5f, r__2 = ulp * anorm,
+ r__1 = max(r__1,r__2), r__2 = rtunfl *
+ 2.f;
+ vu = d2[n] + dmax(r__1,r__2);
+ }
+ } else {
+ vl = 0.f;
+ vu = 1.f;
+ }
+
+ i__3 = *lrwork - n;
+ i__4 = *liwork - (n << 1);
+ cstemr_("V", "V", &n, &d5[1], &rwork[1], &vl, &vu, &il, &
+ iu, &m, &d1[1], &z__[z_offset], ldu, &n, &iwork[1]
+, &tryrac, &rwork[n + 1], &i__3, &iwork[(n << 1)
+ + 1], &i__4, &iinfo);
+ if (iinfo != 0) {
+ io___85.ciunit = *nounit;
+ s_wsfe(&io___85);
+ do_fio(&c__1, "CSTEMR(V,V)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[32] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 32 and 33 */
+
+ cstt22_(&n, &m, &c__0, &sd[1], &se[1], &d1[1], dumma, &
+ z__[z_offset], ldu, &work[1], &m, &rwork[1], &
+ result[32]);
+
+/* Call CSTEMR to compute D2, do tests. */
+
+/* Compute D2 */
+
+ scopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &rwork[1], &c__1);
+ }
+
+ ntest = 34;
+ i__3 = *lrwork - n;
+ i__4 = *liwork - (n << 1);
+ cstemr_("N", "V", &n, &d5[1], &rwork[1], &vl, &vu, &il, &
+ iu, &m, &d2[1], &z__[z_offset], ldu, &n, &iwork[1]
+, &tryrac, &rwork[n + 1], &i__3, &iwork[(n << 1)
+ + 1], &i__4, &iinfo);
+ if (iinfo != 0) {
+ io___86.ciunit = *nounit;
+ s_wsfe(&io___86);
+ do_fio(&c__1, "CSTEMR(N,V)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[34] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Test 34 */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+
+ i__3 = iu - il + 1;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d1[j], dabs(r__1)), r__3
+ = max(r__3,r__4), r__4 = (r__2 = d2[j], dabs(
+ r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d1[j] - d2[j], dabs(r__1)
+ );
+ temp2 = dmax(r__2,r__3);
+/* L250: */
+ }
+
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[34] = temp2 / dmax(r__1,r__2);
+ } else {
+ result[29] = 0.f;
+ result[30] = 0.f;
+ result[31] = 0.f;
+ result[32] = 0.f;
+ result[33] = 0.f;
+ result[34] = 0.f;
+ }
+
+
+/* Call CSTEMR(V,A) to compute D1 and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ scopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &rwork[1], &c__1);
+ }
+
+ ntest = 35;
+
+ i__3 = *lrwork - n;
+ i__4 = *liwork - (n << 1);
+ cstemr_("V", "A", &n, &d5[1], &rwork[1], &vl, &vu, &il, &iu, &
+ m, &d1[1], &z__[z_offset], ldu, &n, &iwork[1], &
+ tryrac, &rwork[n + 1], &i__3, &iwork[(n << 1) + 1], &
+ i__4, &iinfo);
+ if (iinfo != 0) {
+ io___87.ciunit = *nounit;
+ s_wsfe(&io___87);
+ do_fio(&c__1, "CSTEMR(V,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[35] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 35 and 36 */
+
+ cstt22_(&n, &m, &c__0, &sd[1], &se[1], &d1[1], dumma, &z__[
+ z_offset], ldu, &work[1], &m, &rwork[1], &result[35]);
+
+/* Call CSTEMR to compute D2, do tests. */
+
+/* Compute D2 */
+
+ scopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &rwork[1], &c__1);
+ }
+
+ ntest = 37;
+ i__3 = *lrwork - n;
+ i__4 = *liwork - (n << 1);
+ cstemr_("N", "A", &n, &d5[1], &rwork[1], &vl, &vu, &il, &iu, &
+ m, &d2[1], &z__[z_offset], ldu, &n, &iwork[1], &
+ tryrac, &rwork[n + 1], &i__3, &iwork[(n << 1) + 1], &
+ i__4, &iinfo);
+ if (iinfo != 0) {
+ io___88.ciunit = *nounit;
+ s_wsfe(&io___88);
+ do_fio(&c__1, "CSTEMR(N,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[37] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Test 34 */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d1[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = d2[j], dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d1[j] - d2[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L260: */
+ }
+
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[37] = temp2 / dmax(r__1,r__2);
+ }
+L270:
+L280:
+ ntestt += ntest;
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+
+/* Print out tests which fail. */
+
+ i__3 = ntest;
+ for (jr = 1; jr <= i__3; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___89.ciunit = *nounit;
+ s_wsfe(&io___89);
+ do_fio(&c__1, "CST", (ftnlen)3);
+ e_wsfe();
+ io___90.ciunit = *nounit;
+ s_wsfe(&io___90);
+ e_wsfe();
+ io___91.ciunit = *nounit;
+ s_wsfe(&io___91);
+ e_wsfe();
+ io___92.ciunit = *nounit;
+ s_wsfe(&io___92);
+ do_fio(&c__1, "Hermitian", (ftnlen)9);
+ e_wsfe();
+ io___93.ciunit = *nounit;
+ s_wsfe(&io___93);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___94.ciunit = *nounit;
+ s_wsfe(&io___94);
+ e_wsfe();
+ }
+ ++nerrs;
+ if (result[jr] < 1e4f) {
+ io___95.ciunit = *nounit;
+ s_wsfe(&io___95);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ } else {
+ io___96.ciunit = *nounit;
+ s_wsfe(&io___96);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ }
+ }
+/* L290: */
+ }
+L300:
+ ;
+ }
+/* L310: */
+ }
+
+/* Summary */
+
+ slasum_("CST", nounit, &nerrs, &ntestt);
+ return 0;
+
+
+
+
+/* L9993: */
+/* L9992: */
+/* L9991: */
+/* L9990: */
+
+/* End of CCHKST */
+
+} /* cchkst_ */
diff --git a/TESTING/EIG/cckglm.c b/TESTING/EIG/cckglm.c
new file mode 100644
index 0000000..8e91925
--- /dev/null
+++ b/TESTING/EIG/cckglm.c
@@ -0,0 +1,328 @@
+/* cckglm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+
+/* Subroutine */ int cckglm_(integer *nn, integer *nval, integer *mval,
+ integer *pval, integer *nmats, integer *iseed, real *thresh, integer *
+ nmax, complex *a, complex *af, complex *b, complex *bf, complex *x,
+ complex *work, real *rwork, integer *nin, integer *nout, integer *
+ info)
+{
+ /* Format strings */
+ static char fmt_9997[] = "(\002 *** Invalid input for GLM: M = \002,"
+ "i6,\002, P = \002,i6,\002, N = \002,i6,\002;\002,/\002 must "
+ "satisfy M <= N <= M+P \002,\002(this set of values will be skip"
+ "ped)\002)";
+ static char fmt_9999[] = "(\002 CLATMS in CCKGLM INFO = \002,i5)";
+ static char fmt_9998[] = "(\002 N=\002,i4,\002 M=\002,i4,\002, P=\002,"
+ "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ complex q__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), do_fio(integer *
+ , char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, m, n, p, ik, lda, ldb, kla, klb, kua, kub, imat;
+ char path[3], type__[1];
+ integer nrun, modea, modeb, nfail;
+ char dista[1], distb[1];
+ integer iinfo;
+ real resid, anorm, bnorm;
+ integer lwork;
+ extern /* Subroutine */ int slatb9_(char *, integer *, integer *, integer
+ *, integer *, char *, integer *, integer *, integer *, integer *,
+ real *, real *, integer *, integer *, real *, real *, char *,
+ char *), alahdg_(integer *, char *
+);
+ real cndnma, cndnmb;
+ extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+ extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
+ *, integer *, integer *), alasum_(char *, integer *,
+ integer *, integer *, integer *), clatms_(integer *,
+ integer *, char *, integer *, char *, real *, integer *, real *,
+ real *, integer *, integer *, char *, complex *, integer *,
+ complex *, integer *), cglmts_(integer *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ complex *, integer *, complex *, complex *, complex *, complex *,
+ complex *, integer *, real *, real *);
+ logical dotype[8], firstt;
+
+ /* Fortran I/O blocks */
+ static cilist io___13 = { 0, 0, 0, 0, 0 };
+ static cilist io___14 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCKGLM tests CGGGLM - subroutine for solving generalized linear */
+/* model problem. */
+
+/* Arguments */
+/* ========= */
+
+/* NN (input) INTEGER */
+/* The number of values of N, M and P contained in the vectors */
+/* NVAL, MVAL and PVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix row dimension N. */
+
+/* MVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension M. */
+
+/* PVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension P. */
+
+/* NMATS (input) INTEGER */
+/* The number of matrix types to be tested for each combination */
+/* of matrix dimensions. If NMATS >= NTYPES (the maximum */
+/* number of matrix types), then all the different types are */
+/* generated for testing. If NMATS < NTYPES, another input line */
+/* is read to get the numbers of the matrix types to be used. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator. The array */
+/* elements should be between 0 and 4095, otherwise they will be */
+/* reduced mod 4096, and ISEED(4) must be odd. */
+/* On exit, the next seed in the random number sequence after */
+/* all the test matrices have been generated. */
+
+/* THRESH (input) REAL */
+/* The threshold value for the test ratios. A result is */
+/* included in the output file if RESID >= THRESH. To have */
+/* every test ratio printed, use THRESH = 0. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* BF (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* X (workspace) COMPLEX array, dimension (4*NMAX) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* NIN (input) INTEGER */
+/* The unit number for input. */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit */
+/* > 0 : If CLATMS returns an error code, the absolute value */
+/* of it is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --x;
+ --bf;
+ --b;
+ --af;
+ --a;
+ --iseed;
+ --pval;
+ --mval;
+ --nval;
+
+ /* Function Body */
+ s_copy(path, "GLM", (ftnlen)3, (ftnlen)3);
+ *info = 0;
+ nrun = 0;
+ nfail = 0;
+ firstt = TRUE_;
+ alareq_(path, nmats, dotype, &c__8, nin, nout);
+ lda = *nmax;
+ ldb = *nmax;
+ lwork = *nmax * *nmax;
+
+/* Check for valid input values. */
+
+ i__1 = *nn;
+ for (ik = 1; ik <= i__1; ++ik) {
+ m = mval[ik];
+ p = pval[ik];
+ n = nval[ik];
+ if (m > n || n > m + p) {
+ if (firstt) {
+ io___13.ciunit = *nout;
+ s_wsle(&io___13);
+ e_wsle();
+ firstt = FALSE_;
+ }
+ io___14.ciunit = *nout;
+ s_wsfe(&io___14);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L10: */
+ }
+ firstt = TRUE_;
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nn;
+ for (ik = 1; ik <= i__1; ++ik) {
+ m = mval[ik];
+ p = pval[ik];
+ n = nval[ik];
+ if (m > n || n > m + p) {
+ goto L40;
+ }
+
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat - 1]) {
+ goto L30;
+ }
+
+/* Set up parameters with SLATB9 and generate test */
+/* matrices A and B with CLATMS. */
+
+ slatb9_(path, &imat, &m, &p, &n, type__, &kla, &kua, &klb, &kub, &
+ anorm, &bnorm, &modea, &modeb, &cndnma, &cndnmb, dista,
+ distb);
+
+ clatms_(&n, &m, dista, &iseed[1], type__, &rwork[1], &modea, &
+ cndnma, &anorm, &kla, &kua, "No packing", &a[1], &lda, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+ clatms_(&n, &p, distb, &iseed[1], type__, &rwork[1], &modeb, &
+ cndnmb, &bnorm, &klb, &kub, "No packing", &b[1], &ldb, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+/* Generate random left hand side vector of GLM */
+
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+/* L20: */
+ }
+
+ cglmts_(&n, &m, &p, &a[1], &af[1], &lda, &b[1], &bf[1], &ldb, &x[
+ 1], &x[*nmax + 1], &x[(*nmax << 1) + 1], &x[*nmax * 3 + 1]
+, &work[1], &lwork, &rwork[1], &resid);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ if (resid >= *thresh) {
+ if (nfail == 0 && firstt) {
+ firstt = FALSE_;
+ alahdg_(nout, path);
+ }
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&resid, (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+L30:
+ ;
+ }
+L40:
+ ;
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &c__0);
+
+ return 0;
+
+/* End of CCKGLM */
+
+} /* cckglm_ */
diff --git a/TESTING/EIG/cckgqr.c b/TESTING/EIG/cckgqr.c
new file mode 100644
index 0000000..7e224e3
--- /dev/null
+++ b/TESTING/EIG/cckgqr.c
@@ -0,0 +1,420 @@
+/* cckgqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static integer c__1 = 1;
+static integer c__0 = 0;
+
+/* Subroutine */ int cckgqr_(integer *nm, integer *mval, integer *np, integer
+ *pval, integer *nn, integer *nval, integer *nmats, integer *iseed,
+ real *thresh, integer *nmax, complex *a, complex *af, complex *aq,
+ complex *ar, complex *taua, complex *b, complex *bf, complex *bz,
+ complex *bt, complex *bwk, complex *taub, complex *work, real *rwork,
+ integer *nin, integer *nout, integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 CLATMS in CCKGQR: INFO = \002,i5)";
+ static char fmt_9998[] = "(\002 M=\002,i4,\002 P=\002,i4,\002, N=\002,"
+ "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
+ static char fmt_9997[] = "(\002 N=\002,i4,\002 M=\002,i4,\002, P=\002,"
+ "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, m, n, p, im, in, ip, nt, lda, ldb, kla, klb, kua, kub;
+ char path[3];
+ integer imat;
+ char type__[1];
+ integer nrun, modea, modeb, nfail;
+ char dista[1], distb[1];
+ integer iinfo;
+ real anorm, bnorm;
+ integer lwork;
+ extern /* Subroutine */ int slatb9_(char *, integer *, integer *, integer
+ *, integer *, char *, integer *, integer *, integer *, integer *,
+ real *, real *, integer *, integer *, real *, real *, char *,
+ char *), alahdg_(integer *, char *
+);
+ real cndnma, cndnmb;
+ extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
+ *, integer *, integer *), alasum_(char *, integer *,
+ integer *, integer *, integer *), clatms_(integer *,
+ integer *, char *, integer *, char *, real *, integer *, real *,
+ real *, integer *, integer *, char *, complex *, integer *,
+ complex *, integer *), cgqrts_(integer *,
+ integer *, integer *, complex *, complex *, complex *, complex *,
+ integer *, complex *, complex *, complex *, complex *, complex *,
+ complex *, integer *, complex *, complex *, integer *, real *,
+ real *);
+ logical dotype[8];
+ extern /* Subroutine */ int cgrqts_(integer *, integer *, integer *,
+ complex *, complex *, complex *, complex *, integer *, complex *,
+ complex *, complex *, complex *, complex *, complex *, integer *,
+ complex *, complex *, integer *, real *, real *);
+ logical firstt;
+ real result[7];
+
+ /* Fortran I/O blocks */
+ static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCKGQR tests */
+/* CGGQRF: GQR factorization for N-by-M matrix A and N-by-P matrix B, */
+/* CGGRQF: GRQ factorization for M-by-N matrix A and P-by-N matrix B. */
+
+/* Arguments */
+/* ========= */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row(column) dimension M. */
+
+/* NP (input) INTEGER */
+/* The number of values of P contained in the vector PVAL. */
+
+/* PVAL (input) INTEGER array, dimension (NP) */
+/* The values of the matrix row(column) dimension P. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column(row) dimension N. */
+
+/* NMATS (input) INTEGER */
+/* The number of matrix types to be tested for each combination */
+/* of matrix dimensions. If NMATS >= NTYPES (the maximum */
+/* number of matrix types), then all the different types are */
+/* generated for testing. If NMATS < NTYPES, another input line */
+/* is read to get the numbers of the matrix types to be used. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator. The array */
+/* elements should be between 0 and 4095, otherwise they will be */
+/* reduced mod 4096, and ISEED(4) must be odd. */
+/* On exit, the next seed in the random number sequence after */
+/* all the test matrices have been generated. */
+
+/* THRESH (input) 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. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AQ (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AR (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* TAUA (workspace) COMPLEX array, dimension (NMAX) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* BF (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* BZ (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* BT (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* BWK (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* TAUB (workspace) COMPLEX array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX) */
+
+/* NIN (input) INTEGER */
+/* The unit number for input. */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit */
+/* > 0 : If CLATMS returns an error code, the absolute value */
+/* of it is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --taub;
+ --bwk;
+ --bt;
+ --bz;
+ --bf;
+ --b;
+ --taua;
+ --ar;
+ --aq;
+ --af;
+ --a;
+ --iseed;
+ --nval;
+ --pval;
+ --mval;
+
+ /* Function Body */
+ s_copy(path, "GQR", (ftnlen)3, (ftnlen)3);
+ *info = 0;
+ nrun = 0;
+ nfail = 0;
+ firstt = TRUE_;
+ alareq_(path, nmats, dotype, &c__8, nin, nout);
+ lda = *nmax;
+ ldb = *nmax;
+ lwork = *nmax * *nmax;
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Do for each value of P in PVAL. */
+
+ i__2 = *np;
+ for (ip = 1; ip <= i__2; ++ip) {
+ p = pval[ip];
+
+/* Do for each value of N in NVAL. */
+
+ i__3 = *nn;
+ for (in = 1; in <= i__3; ++in) {
+ n = nval[in];
+
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat - 1]) {
+ goto L30;
+ }
+
+/* Test CGGRQF */
+
+/* Set up parameters with SLATB9 and generate test */
+/* matrices A and B with CLATMS. */
+
+ slatb9_("GRQ", &imat, &m, &p, &n, type__, &kla, &kua, &
+ klb, &kub, &anorm, &bnorm, &modea, &modeb, &
+ cndnma, &cndnmb, dista, distb);
+
+ clatms_(&m, &n, dista, &iseed[1], type__, &rwork[1], &
+ modea, &cndnma, &anorm, &kla, &kua, "No packing",
+ &a[1], &lda, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+ clatms_(&p, &n, distb, &iseed[1], type__, &rwork[1], &
+ modeb, &cndnmb, &bnorm, &klb, &kub, "No packing",
+ &b[1], &ldb, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+ nt = 4;
+
+ cgrqts_(&m, &p, &n, &a[1], &af[1], &aq[1], &ar[1], &lda, &
+ taua[1], &b[1], &bf[1], &bz[1], &bt[1], &bwk[1], &
+ ldb, &taub[1], &work[1], &lwork, &rwork[1],
+ result);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && firstt) {
+ firstt = FALSE_;
+ alahdg_(nout, "GRQ");
+ }
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L10: */
+ }
+ nrun += nt;
+
+/* Test CGGQRF */
+
+/* Set up parameters with SLATB9 and generate test */
+/* matrices A and B with CLATMS. */
+
+ slatb9_("GQR", &imat, &m, &p, &n, type__, &kla, &kua, &
+ klb, &kub, &anorm, &bnorm, &modea, &modeb, &
+ cndnma, &cndnmb, dista, distb);
+
+ clatms_(&n, &m, dista, &iseed[1], type__, &rwork[1], &
+ modea, &cndnma, &anorm, &kla, &kua, "No packing",
+ &a[1], &lda, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+ clatms_(&n, &p, distb, &iseed[1], type__, &rwork[1], &
+ modea, &cndnma, &bnorm, &klb, &kub, "No packing",
+ &b[1], &ldb, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+ nt = 4;
+
+ cgqrts_(&n, &m, &p, &a[1], &af[1], &aq[1], &ar[1], &lda, &
+ taua[1], &b[1], &bf[1], &bz[1], &bt[1], &bwk[1], &
+ ldb, &taub[1], &work[1], &lwork, &rwork[1],
+ result);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && firstt) {
+ firstt = FALSE_;
+ alahdg_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+
+L30:
+ ;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &c__0);
+
+ return 0;
+
+/* End of CCKGQR */
+
+} /* cckgqr_ */
diff --git a/TESTING/EIG/cckgsv.c b/TESTING/EIG/cckgsv.c
new file mode 100644
index 0000000..4090c60
--- /dev/null
+++ b/TESTING/EIG/cckgsv.c
@@ -0,0 +1,316 @@
+/* cckgsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static integer c__1 = 1;
+static integer c__0 = 0;
+
+/* Subroutine */ int cckgsv_(integer *nm, integer *mval, integer *pval,
+ integer *nval, integer *nmats, integer *iseed, real *thresh, integer *
+ nmax, complex *a, complex *af, complex *b, complex *bf, complex *u,
+ complex *v, complex *q, real *alpha, real *beta, complex *r__,
+ integer *iwork, complex *work, real *rwork, integer *nin, integer *
+ nout, integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 CLATMS in CCKGSV INFO = \002,i5)";
+ static char fmt_9998[] = "(\002 M=\002,i4,\002 P=\002,i4,\002, N=\002,"
+ "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
+
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, m, n, p, im, nt, lda, ldb, kla, klb, kua, kub, ldq, ldr, ldu,
+ ldv, imat;
+ char path[3], type__[1];
+ integer nrun, modea, modeb, nfail;
+ char dista[1], distb[1];
+ integer iinfo;
+ real anorm, bnorm;
+ integer lwork;
+ extern /* Subroutine */ int slatb9_(char *, integer *, integer *, integer
+ *, integer *, char *, integer *, integer *, integer *, integer *,
+ real *, real *, integer *, integer *, real *, real *, char *,
+ char *), alahdg_(integer *, char *
+);
+ real cndnma, cndnmb;
+ extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
+ *, integer *, integer *), alasum_(char *, integer *,
+ integer *, integer *, integer *), clatms_(integer *,
+ integer *, char *, integer *, char *, real *, integer *, real *,
+ real *, integer *, integer *, char *, complex *, integer *,
+ complex *, integer *);
+ logical dotype[8];
+ extern /* Subroutine */ int cgsvts_(integer *, integer *, integer *,
+ complex *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ real *, real *, complex *, integer *, integer *, complex *,
+ integer *, real *, real *);
+ logical firstt;
+ real result[7];
+
+ /* Fortran I/O blocks */
+ static cilist io___32 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCKGSV tests CGGSVD: */
+/* the GSVD for M-by-N matrix A and P-by-N matrix B. */
+
+/* Arguments */
+/* ========= */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* PVAL (input) INTEGER array, dimension (NP) */
+/* The values of the matrix row dimension P. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NMATS (input) INTEGER */
+/* The number of matrix types to be tested for each combination */
+/* of matrix dimensions. If NMATS >= NTYPES (the maximum */
+/* number of matrix types), then all the different types are */
+/* generated for testing. If NMATS < NTYPES, another input line */
+/* is read to get the numbers of the matrix types to be used. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator. The array */
+/* elements should be between 0 and 4095, otherwise they will be */
+/* reduced mod 4096, and ISEED(4) must be odd. */
+/* On exit, the next seed in the random number sequence after */
+/* all the test matrices have been generated. */
+
+/* THRESH (input) 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. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* BF (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* U (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* V (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* Q (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* ALPHA (workspace) REAL array, dimension (NMAX) */
+
+/* BETA (workspace) REAL array, dimension (NMAX) */
+
+/* R (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX) */
+
+/* NIN (input) INTEGER */
+/* The unit number for input. */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit */
+/* > 0 : If CLATMS returns an error code, the absolute value */
+/* of it is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --iwork;
+ --r__;
+ --beta;
+ --alpha;
+ --q;
+ --v;
+ --u;
+ --bf;
+ --b;
+ --af;
+ --a;
+ --iseed;
+ --nval;
+ --pval;
+ --mval;
+
+ /* Function Body */
+ s_copy(path, "GSV", (ftnlen)3, (ftnlen)3);
+ *info = 0;
+ nrun = 0;
+ nfail = 0;
+ firstt = TRUE_;
+ alareq_(path, nmats, dotype, &c__8, nin, nout);
+ lda = *nmax;
+ ldb = *nmax;
+ ldu = *nmax;
+ ldv = *nmax;
+ ldq = *nmax;
+ ldr = *nmax;
+ lwork = *nmax * *nmax;
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+ p = pval[im];
+ n = nval[im];
+
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat - 1]) {
+ goto L20;
+ }
+
+/* Set up parameters with SLATB9 and generate test */
+/* matrices A and B with CLATMS. */
+
+ slatb9_(path, &imat, &m, &p, &n, type__, &kla, &kua, &klb, &kub, &
+ anorm, &bnorm, &modea, &modeb, &cndnma, &cndnmb, dista,
+ distb);
+
+/* Generate M by N matrix A */
+
+ clatms_(&m, &n, dista, &iseed[1], type__, &rwork[1], &modea, &
+ cndnma, &anorm, &kla, &kua, "No packing", &a[1], &lda, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L20;
+ }
+
+/* Generate P by N matrix B */
+
+ clatms_(&p, &n, distb, &iseed[1], type__, &rwork[1], &modeb, &
+ cndnmb, &bnorm, &klb, &kub, "No packing", &b[1], &ldb, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L20;
+ }
+
+ nt = 6;
+
+ cgsvts_(&m, &p, &n, &a[1], &af[1], &lda, &b[1], &bf[1], &ldb, &u[
+ 1], &ldu, &v[1], &ldv, &q[1], &ldq, &alpha[1], &beta[1], &
+ r__[1], &ldr, &iwork[1], &work[1], &lwork, &rwork[1],
+ result);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__2 = nt;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && firstt) {
+ firstt = FALSE_;
+ alahdg_(nout, path);
+ }
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L10: */
+ }
+ nrun += nt;
+
+L20:
+ ;
+ }
+/* L30: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &c__0);
+
+ return 0;
+
+/* End of CCKGSV */
+
+} /* cckgsv_ */
diff --git a/TESTING/EIG/ccklse.c b/TESTING/EIG/ccklse.c
new file mode 100644
index 0000000..6c815ec
--- /dev/null
+++ b/TESTING/EIG/ccklse.c
@@ -0,0 +1,352 @@
+/* ccklse.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static integer c__1 = 1;
+static integer c__0 = 0;
+
+/* Subroutine */ int ccklse_(integer *nn, integer *mval, integer *pval,
+ integer *nval, integer *nmats, integer *iseed, real *thresh, integer *
+ nmax, complex *a, complex *af, complex *b, complex *bf, complex *x,
+ complex *work, real *rwork, integer *nin, integer *nout, integer *
+ info)
+{
+ /* Format strings */
+ static char fmt_9997[] = "(\002 *** Invalid input for LSE: M = \002,"
+ "i6,\002, P = \002,i6,\002, N = \002,i6,\002;\002,/\002 must "
+ "satisfy P <= N <= P+M \002,\002(this set of values will be skip"
+ "ped)\002)";
+ static char fmt_9999[] = "(\002 CLATMS in CCKLSE INFO = \002,i5)";
+ static char fmt_9998[] = "(\002 M=\002,i4,\002 P=\002,i4,\002, N=\002,"
+ "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), do_fio(integer *
+ , char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, m, n, p, ik, nt, lda, ldb, kla, klb, kua, kub, imat;
+ char path[3], type__[1];
+ integer nrun, modea, modeb, nfail;
+ char dista[1], distb[1];
+ integer iinfo;
+ real anorm, bnorm;
+ integer lwork;
+ extern /* Subroutine */ int slatb9_(char *, integer *, integer *, integer
+ *, integer *, char *, integer *, integer *, integer *, integer *,
+ real *, real *, integer *, integer *, real *, real *, char *,
+ char *), alahdg_(integer *, char *
+);
+ real cndnma, cndnmb;
+ extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
+ *, integer *, integer *), clarhs_(char *, char *, char *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ integer *, integer *), alasum_(
+ char *, integer *, integer *, integer *, integer *),
+ clatms_(integer *, integer *, char *, integer *, char *, real *,
+ integer *, real *, real *, integer *, integer *, char *, complex *
+, integer *, complex *, integer *),
+ clsets_(integer *, integer *, integer *, complex *, complex *,
+ integer *, complex *, complex *, integer *, complex *, complex *,
+ complex *, complex *, complex *, complex *, integer *, real *,
+ real *);
+ logical dotype[8], firstt;
+ real result[7];
+
+ /* Fortran I/O blocks */
+ static cilist io___13 = { 0, 0, 0, 0, 0 };
+ static cilist io___14 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCKLSE tests CGGLSE - a subroutine for solving linear equality */
+/* constrained least square problem (LSE). */
+
+/* Arguments */
+/* ========= */
+
+/* NN (input) INTEGER */
+/* The number of values of (M,P,N) contained in the vectors */
+/* (MVAL, PVAL, NVAL). */
+
+/* MVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix row(column) dimension M. */
+
+/* PVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix row(column) dimension P. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column(row) dimension N. */
+
+/* NMATS (input) INTEGER */
+/* The number of matrix types to be tested for each combination */
+/* of matrix dimensions. If NMATS >= NTYPES (the maximum */
+/* number of matrix types), then all the different types are */
+/* generated for testing. If NMATS < NTYPES, another input line */
+/* is read to get the numbers of the matrix types to be used. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator. The array */
+/* elements should be between 0 and 4095, otherwise they will be */
+/* reduced mod 4096, and ISEED(4) must be odd. */
+/* On exit, the next seed in the random number sequence after */
+/* all the test matrices have been generated. */
+
+/* THRESH (input) 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. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* BF (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* X (workspace) COMPLEX array, dimension (5*NMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX) */
+
+/* NIN (input) INTEGER */
+/* The unit number for input. */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit */
+/* > 0 : If CLATMS returns an error code, the absolute value */
+/* of it is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --x;
+ --bf;
+ --b;
+ --af;
+ --a;
+ --iseed;
+ --nval;
+ --pval;
+ --mval;
+
+ /* Function Body */
+ s_copy(path, "LSE", (ftnlen)3, (ftnlen)3);
+ *info = 0;
+ nrun = 0;
+ nfail = 0;
+ firstt = TRUE_;
+ alareq_(path, nmats, dotype, &c__8, nin, nout);
+ lda = *nmax;
+ ldb = *nmax;
+ lwork = *nmax * *nmax;
+
+/* Check for valid input values. */
+
+ i__1 = *nn;
+ for (ik = 1; ik <= i__1; ++ik) {
+ m = mval[ik];
+ p = pval[ik];
+ n = nval[ik];
+ if (p > n || n > m + p) {
+ if (firstt) {
+ io___13.ciunit = *nout;
+ s_wsle(&io___13);
+ e_wsle();
+ firstt = FALSE_;
+ }
+ io___14.ciunit = *nout;
+ s_wsfe(&io___14);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L10: */
+ }
+ firstt = TRUE_;
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nn;
+ for (ik = 1; ik <= i__1; ++ik) {
+ m = mval[ik];
+ p = pval[ik];
+ n = nval[ik];
+ if (p > n || n > m + p) {
+ goto L40;
+ }
+
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat - 1]) {
+ goto L30;
+ }
+
+/* Set up parameters with SLATB9 and generate test */
+/* matrices A and B with CLATMS. */
+
+ slatb9_(path, &imat, &m, &p, &n, type__, &kla, &kua, &klb, &kub, &
+ anorm, &bnorm, &modea, &modeb, &cndnma, &cndnmb, dista,
+ distb);
+
+ clatms_(&m, &n, dista, &iseed[1], type__, &rwork[1], &modea, &
+ cndnma, &anorm, &kla, &kua, "No packing", &a[1], &lda, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+ clatms_(&p, &n, distb, &iseed[1], type__, &rwork[1], &modeb, &
+ cndnmb, &bnorm, &klb, &kub, "No packing", &b[1], &ldb, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+/* Generate the right-hand sides C and D for the LSE. */
+
+/* Computing MAX */
+ i__3 = m - 1;
+ i__2 = max(i__3,0);
+/* Computing MAX */
+ i__5 = n - 1;
+ i__4 = max(i__5,0);
+ i__6 = max(n,1);
+ i__7 = max(m,1);
+ clarhs_("CGE", "New solution", "Upper", "N", &m, &n, &i__2, &i__4,
+ &c__1, &a[1], &lda, &x[(*nmax << 2) + 1], &i__6, &x[1], &
+ i__7, &iseed[1], &iinfo);
+
+/* Computing MAX */
+ i__3 = p - 1;
+ i__2 = max(i__3,0);
+/* Computing MAX */
+ i__5 = n - 1;
+ i__4 = max(i__5,0);
+ i__6 = max(n,1);
+ i__7 = max(p,1);
+ clarhs_("CGE", "Computed", "Upper", "N", &p, &n, &i__2, &i__4, &
+ c__1, &b[1], &ldb, &x[(*nmax << 2) + 1], &i__6, &x[(*nmax
+ << 1) + 1], &i__7, &iseed[1], &iinfo);
+
+ nt = 2;
+
+ clsets_(&m, &p, &n, &a[1], &af[1], &lda, &b[1], &bf[1], &ldb, &x[
+ 1], &x[*nmax + 1], &x[(*nmax << 1) + 1], &x[*nmax * 3 + 1]
+, &x[(*nmax << 2) + 1], &work[1], &lwork, &rwork[1],
+ result);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__2 = nt;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && firstt) {
+ firstt = FALSE_;
+ alahdg_(nout, path);
+ }
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+
+L30:
+ ;
+ }
+L40:
+ ;
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &c__0);
+
+ return 0;
+
+/* End of CCKLSE */
+
+} /* ccklse_ */
diff --git a/TESTING/EIG/cdrges.c b/TESTING/EIG/cdrges.c
new file mode 100644
index 0000000..dbc2f12
--- /dev/null
+++ b/TESTING/EIG/cdrges.c
@@ -0,0 +1,1131 @@
+/* cdrges.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static real c_b29 = 1.f;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static integer c__0 = 0;
+
+/* Subroutine */ int cdrges_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, integer *nounit,
+ complex *a, integer *lda, complex *b, complex *s, complex *t, complex
+ *q, integer *ldq, complex *z__, complex *alpha, complex *beta,
+ complex *work, integer *lwork, real *rwork, real *result, logical *
+ bwork, integer *info)
+{
+ /* Initialized data */
+
+ static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
+ 2,2,2,3 };
+ static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
+ 2,3,2,1 };
+ static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
+ 1,1,1,1 };
+ static logical lasign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ TRUE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,FALSE_,
+ TRUE_,FALSE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_ };
+ static logical lbsign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ FALSE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,FALSE_,
+ TRUE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ FALSE_ };
+ static integer kz1[6] = { 0,1,2,1,3,3 };
+ static integer kz2[6] = { 0,0,1,2,1,1 };
+ static integer kadd[6] = { 0,0,0,0,3,2 };
+ static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
+ 4,4,4,0 };
+ static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
+ 8,8,8,8,8,0 };
+ static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
+ 3,3,3,1 };
+ static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
+ 4,4,4,1 };
+ static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
+ 3,3,2,1 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 CDRGES: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,4(i4,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 CDRGES: S not in Schur form at eigenvalu"
+ "e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, "
+ "ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9997[] = "(/1x,a3,\002 -- Complex Generalized Schur from"
+ " problem \002,\002driver\002)";
+ static char fmt_9996[] = "(\002 Matrix types (see CDRGES for details):"
+ " \002)";
+ static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
+ "osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
+ ") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
+ "onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
+ "I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
+ "arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
+ "(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
+ "=(D, reversed D)\002)";
+ static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
+ "atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
+ " 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
+ "ha&beta \002,\002 20=arithmetic alpha, beta=0,"
+ "1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
+ "=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
+ "/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
+ "l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
+ ".\002)";
+ static char fmt_9993[] = "(/\002 Tests performed: (S is Schur, T is tri"
+ "angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002l and r "
+ "are the appropriate left and right\002,/19x,\002eigenvectors, re"
+ "sp., a is alpha, b is beta, and\002,/19x,a,\002 means \002,a,"
+ "\002.)\002,/\002 Without ordering: \002,/\002 1 = | A - Q S "
+ "Z\002,a,\002 | / ( |A| n ulp ) 2 = | B - Q T Z\002,a,\002 |"
+ " / ( |B| n ulp )\002,/\002 3 = | I - QQ\002,a,\002 | / ( n ulp "
+ ") 4 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 5"
+ " = A is in Schur form S\002,/\002 6 = difference between (alpha"
+ ",beta)\002,\002 and diagonals of (S,T)\002,/\002 With ordering:"
+ " \002,/\002 7 = | (A,B) - Q (S,T) Z\002,a,\002 | / ( |(A,B)| n "
+ "ulp )\002,/\002 8 = | I - QQ\002,a,\002 | / ( n ulp ) "
+ " 9 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 10 = A is in "
+ "Schur form S\002,/\002 11 = difference between (alpha,beta) and "
+ "diagonals\002,\002 of (S,T)\002,/\002 12 = SDIM is the correct n"
+ "umber of \002,\002selected eigenvalues\002,/)";
+ static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",0p,f8.2)";
+ static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",1p,e10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1,
+ s_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2, i__3,
+ i__4, i__5, i__6, i__7, i__8, i__9, i__10, i__11;
+ real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10, r__11,
+ r__12, r__13, r__14, r__15, r__16;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ double r_sign(real *, real *), c_abs(complex *);
+ void r_cnjg(complex *, complex *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, n, n1, jc, nb, in, jr;
+ real ulp;
+ integer iadd, sdim, nmax, rsub;
+ char sort[1];
+ real temp1, temp2;
+ logical badnn;
+ extern /* Subroutine */ int cget51_(integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, complex *, real *, real *), cgges_(char *, char *,
+ char *, L_fp, integer *, complex *, integer *, complex *, integer
+ *, integer *, complex *, complex *, complex *, integer *, complex
+ *, integer *, complex *, integer *, real *, logical *, integer *), cget54_(integer *, complex *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, complex *, integer *, complex *, real *);
+ integer iinfo;
+ real rmagn[4];
+ complex ctemp;
+ integer nmats, jsize, nerrs, jtype, ntest, isort;
+ extern /* Subroutine */ int clatm4_(integer *, integer *, integer *,
+ integer *, logical *, real *, real *, real *, integer *, integer *
+, complex *, integer *), cunm2r_(char *, char *, integer *,
+ integer *, integer *, complex *, integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ logical ilabad;
+ extern /* Subroutine */ int slabad_(real *, real *), clarfg_(integer *,
+ complex *, complex *, integer *, complex *);
+ extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *);
+ real safmin, safmax;
+ integer knteig, ioldsd[4];
+ extern logical clctes_(complex *, complex *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *), xerbla_(char *, integer *);
+ integer minwrk, maxwrk;
+ real ulpinv;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9991, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRGES checks the nonsymmetric generalized eigenvalue (Schur form) */
+/* problem driver CGGES. */
+
+/* CGGES factors A and B as Q*S*Z' and Q*T*Z' , where ' means conjugate */
+/* transpose, S and T are upper triangular (i.e., in generalized Schur */
+/* form), and Q and Z are unitary. It also computes the generalized */
+/* eigenvalues (alpha(j),beta(j)), j=1,...,n. Thus, */
+/* w(j) = alpha(j)/beta(j) is a root of the characteristic equation */
+
+/* det( A - w(j) B ) = 0 */
+
+/* Optionally it also reorder the eigenvalues so that a selected */
+/* cluster of eigenvalues appears in the leading diagonal block of the */
+/* Schur forms. */
+
+/* When CDRGES is called, a number of matrix "sizes" ("N's") and a */
+/* number of matrix "TYPES" are specified. For each size ("N") */
+/* and each TYPE of matrix, a pair of matrices (A, B) will be generated */
+/* and used for testing. For each matrix pair, the following 13 tests */
+/* will be performed and compared with the threshhold THRESH except */
+/* the tests (5), (11) and (13). */
+
+
+/* (1) | A - Q S Z' | / ( |A| n ulp ) (no sorting of eigenvalues) */
+
+
+/* (2) | B - Q T Z' | / ( |B| n ulp ) (no sorting of eigenvalues) */
+
+
+/* (3) | I - QQ' | / ( n ulp ) (no sorting of eigenvalues) */
+
+
+/* (4) | I - ZZ' | / ( n ulp ) (no sorting of eigenvalues) */
+
+/* (5) if A is in Schur form (i.e. triangular form) (no sorting of */
+/* eigenvalues) */
+
+/* (6) if eigenvalues = diagonal elements of the Schur form (S, T), */
+/* i.e., test the maximum over j of D(j) where: */
+
+/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
+/* D(j) = ------------------------ + ----------------------- */
+/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
+
+/* (no sorting of eigenvalues) */
+
+/* (7) | (A,B) - Q (S,T) Z' | / ( |(A,B)| n ulp ) */
+/* (with sorting of eigenvalues). */
+
+/* (8) | I - QQ' | / ( n ulp ) (with sorting of eigenvalues). */
+
+/* (9) | I - ZZ' | / ( n ulp ) (with sorting of eigenvalues). */
+
+/* (10) if A is in Schur form (i.e. quasi-triangular form) */
+/* (with sorting of eigenvalues). */
+
+/* (11) if eigenvalues = diagonal elements of the Schur form (S, T), */
+/* i.e. test the maximum over j of D(j) where: */
+
+/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
+/* D(j) = ------------------------ + ----------------------- */
+/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
+
+/* (with sorting of eigenvalues). */
+
+/* (12) if sorting worked and SDIM is the number of eigenvalues */
+/* which were CELECTed. */
+
+/* Test Matrices */
+/* ============= */
+
+/* The sizes of the test matrices are specified by an array */
+/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
+/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) ( 0, 0 ) (a pair of zero matrices) */
+
+/* (2) ( I, 0 ) (an identity and a zero matrix) */
+
+/* (3) ( 0, I ) (an identity and a zero matrix) */
+
+/* (4) ( I, I ) (a pair of identity matrices) */
+
+/* t t */
+/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
+
+/* t ( I 0 ) */
+/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
+/* ( 0 I ) ( 0 J ) */
+/* and I is a k x k identity and J a (k+1)x(k+1) */
+/* Jordan block; k=(N-1)/2 */
+
+/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
+/* matrix with those diagonal entries.) */
+/* (8) ( I, D ) */
+
+/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
+
+/* (10) ( small*D, big*I ) */
+
+/* (11) ( big*I, small*D ) */
+
+/* (12) ( small*I, big*D ) */
+
+/* (13) ( big*D, big*I ) */
+
+/* (14) ( small*D, small*I ) */
+
+/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
+/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
+/* t t */
+/* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. */
+
+/* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices */
+/* with random O(1) entries above the diagonal */
+/* and diagonal entries diag(T1) = */
+/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
+/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
+
+/* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
+/* s = machine precision. */
+
+/* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
+
+/* N-5 */
+/* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+
+/* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+/* where r1,..., r(N-4) are random. */
+
+/* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular */
+/* matrices. */
+
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* SDRGES does nothing. NSIZES >= 0. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. NN >= 0. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, SDRGES */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A on input. */
+/* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to SDRGES to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error is */
+/* scaled to be O(1), so THRESH should be a reasonably small */
+/* multiple of 1, e.g., 10 or 100. In particular, it should */
+/* not depend on the precision (single vs. double) or the size */
+/* of the matrix. THRESH >= 0. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace) COMPLEX array, dimension(LDA, max(NN)) */
+/* Used to hold the original A matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, S, and T. */
+/* It must be at least 1 and at least max( NN ). */
+
+/* B (input/workspace) COMPLEX array, dimension(LDA, max(NN)) */
+/* Used to hold the original B matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* S (workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* The Schur form matrix computed from A by CGGES. On exit, S */
+/* contains the Schur form matrix corresponding to the matrix */
+/* in A. */
+
+/* T (workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from B by CGGES. */
+
+/* Q (workspace) COMPLEX array, dimension (LDQ, max(NN)) */
+/* The (left) orthogonal matrix computed by CGGES. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of Q and Z. It must */
+/* be at least 1 and at least max( NN ). */
+
+/* Z (workspace) COMPLEX array, dimension( LDQ, max(NN) ) */
+/* The (right) orthogonal matrix computed by CGGES. */
+
+/* ALPHA (workspace) COMPLEX array, dimension (max(NN)) */
+/* BETA (workspace) COMPLEX array, dimension (max(NN)) */
+/* The generalized eigenvalues of (A,B) computed by CGGES. */
+/* ALPHA(k) / BETA(k) is the k-th generalized eigenvalue of A */
+/* and B. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= 3*N*N. */
+
+/* RWORK (workspace) REAL array, dimension ( 8*N ) */
+/* Real workspace. */
+
+/* RESULT (output) REAL array, dimension (15) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid overflow. */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: A routine returned an error code. INFO is the */
+/* absolute value of the INFO value returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ t_dim1 = *lda;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ s_dim1 = *lda;
+ s_offset = 1 + s_dim1;
+ s -= s_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ z_dim1 = *ldq;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --alpha;
+ --beta;
+ --work;
+ --rwork;
+ --result;
+ --bwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.f) {
+ *info = -6;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldq <= 1 || *ldq < nmax) {
+ *info = -14;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. */
+
+ minwrk = 1;
+ if (*info == 0 && *lwork >= 1) {
+ minwrk = nmax * 3 * nmax;
+/* Computing MAX */
+ i__1 = 1, i__2 = ilaenv_(&c__1, "CGEQRF", " ", &nmax, &nmax, &c_n1, &
+ c_n1), i__1 = max(i__1,i__2), i__2 =
+ ilaenv_(&c__1, "CUNMQR", "LC", &nmax, &nmax, &nmax, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
+ c__1, "CUNGQR", " ", &nmax, &nmax, &nmax, &c_n1);
+ nb = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = nmax + nmax * nb, i__2 = nmax * 3 * nmax;
+ maxwrk = max(i__1,i__2);
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+ }
+
+ if (*lwork < minwrk) {
+ *info = -19;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CDRGES", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+ ulp = slamch_("Precision");
+ safmin = slamch_("Safe minimum");
+ safmin /= ulp;
+ safmax = 1.f / safmin;
+ slabad_(&safmin, &safmax);
+ ulpinv = 1.f / ulp;
+
+/* The values RMAGN(2:3) depend on N, see below. */
+
+ rmagn[0] = 0.f;
+ rmagn[1] = 1.f;
+
+/* Loop over matrix sizes */
+
+ ntestt = 0;
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ n1 = max(1,n);
+ rmagn[2] = safmax * ulp / (real) n1;
+ rmagn[3] = safmin * ulpinv * (real) n1;
+
+ if (*nsizes != 1) {
+ mtypes = min(26,*ntypes);
+ } else {
+ mtypes = min(27,*ntypes);
+ }
+
+/* Loop over matrix types */
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L180;
+ }
+ ++nmats;
+ ntest = 0;
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 13; ++j) {
+ result[j] = 0.f;
+/* L30: */
+ }
+
+/* Generate test matrices A and B */
+
+/* Description of control parameters: */
+
+/* KCLASS: =1 means w/o rotation, =2 means w/ rotation, */
+/* =3 means random. */
+/* KATYPE: the "type" to be passed to CLATM4 for computing A. */
+/* KAZERO: the pattern of zeros on the diagonal for A: */
+/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
+/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
+/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
+/* non-zero entries.) */
+/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
+/* =2: large, =3: small. */
+/* LASIGN: .TRUE. if the diagonal elements of A are to be */
+/* multiplied by a random magnitude 1 number. */
+/* KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B. */
+/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
+/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
+/* RMAGN: used to implement KAMAGN and KBMAGN. */
+
+ if (mtypes > 26) {
+ goto L110;
+ }
+ iinfo = 0;
+ if (kclass[jtype - 1] < 3) {
+
+/* Generate A (w/o rotation) */
+
+ if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ claset_("Full", &n, &n, &c_b1, &c_b1, &a[a_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ clatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
+ &kz2[kazero[jtype - 1] - 1], &lasign[jtype - 1], &
+ rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
+ 1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
+ a_offset], lda);
+ iadd = kadd[kazero[jtype - 1] - 1];
+ if (iadd > 0 && iadd <= n) {
+ i__3 = iadd + iadd * a_dim1;
+ i__4 = kamagn[jtype - 1];
+ a[i__3].r = rmagn[i__4], a[i__3].i = 0.f;
+ }
+
+/* Generate B (w/o rotation) */
+
+ if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ claset_("Full", &n, &n, &c_b1, &c_b1, &b[b_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ clatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
+ &kz2[kbzero[jtype - 1] - 1], &lbsign[jtype - 1], &
+ rmagn[kbmagn[jtype - 1]], &c_b29, &rmagn[ktrian[jtype
+ - 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
+ b_offset], lda);
+ iadd = kadd[kbzero[jtype - 1] - 1];
+ if (iadd != 0 && iadd <= n) {
+ i__3 = iadd + iadd * b_dim1;
+ i__4 = kbmagn[jtype - 1];
+ b[i__3].r = rmagn[i__4], b[i__3].i = 0.f;
+ }
+
+ if (kclass[jtype - 1] == 2 && n > 0) {
+
+/* Include rotations */
+
+/* Generate Q, Z as Householder transformations times */
+/* a diagonal matrix. */
+
+ i__3 = n - 1;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = jc; jr <= i__4; ++jr) {
+ i__5 = jr + jc * q_dim1;
+ clarnd_(&q__1, &c__3, &iseed[1]);
+ q[i__5].r = q__1.r, q[i__5].i = q__1.i;
+ i__5 = jr + jc * z_dim1;
+ clarnd_(&q__1, &c__3, &iseed[1]);
+ z__[i__5].r = q__1.r, z__[i__5].i = q__1.i;
+/* L40: */
+ }
+ i__4 = n + 1 - jc;
+ clarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc *
+ q_dim1], &c__1, &work[jc]);
+ i__4 = (n << 1) + jc;
+ i__5 = jc + jc * q_dim1;
+ r__2 = q[i__5].r;
+ r__1 = r_sign(&c_b29, &r__2);
+ work[i__4].r = r__1, work[i__4].i = 0.f;
+ i__4 = jc + jc * q_dim1;
+ q[i__4].r = 1.f, q[i__4].i = 0.f;
+ i__4 = n + 1 - jc;
+ clarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 +
+ jc * z_dim1], &c__1, &work[n + jc]);
+ i__4 = n * 3 + jc;
+ i__5 = jc + jc * z_dim1;
+ r__2 = z__[i__5].r;
+ r__1 = r_sign(&c_b29, &r__2);
+ work[i__4].r = r__1, work[i__4].i = 0.f;
+ i__4 = jc + jc * z_dim1;
+ z__[i__4].r = 1.f, z__[i__4].i = 0.f;
+/* L50: */
+ }
+ clarnd_(&q__1, &c__3, &iseed[1]);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__3 = n + n * q_dim1;
+ q[i__3].r = 1.f, q[i__3].i = 0.f;
+ i__3 = n;
+ work[i__3].r = 0.f, work[i__3].i = 0.f;
+ i__3 = n * 3;
+ r__1 = c_abs(&ctemp);
+ q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ clarnd_(&q__1, &c__3, &iseed[1]);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__3 = n + n * z_dim1;
+ z__[i__3].r = 1.f, z__[i__3].i = 0.f;
+ i__3 = n << 1;
+ work[i__3].r = 0.f, work[i__3].i = 0.f;
+ i__3 = n << 2;
+ r__1 = c_abs(&ctemp);
+ q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+
+/* Apply the diagonal matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ i__5 = jr + jc * a_dim1;
+ i__6 = (n << 1) + jr;
+ r_cnjg(&q__3, &work[n * 3 + jc]);
+ q__2.r = work[i__6].r * q__3.r - work[i__6].i *
+ q__3.i, q__2.i = work[i__6].r * q__3.i +
+ work[i__6].i * q__3.r;
+ i__7 = jr + jc * a_dim1;
+ q__1.r = q__2.r * a[i__7].r - q__2.i * a[i__7].i,
+ q__1.i = q__2.r * a[i__7].i + q__2.i * a[
+ i__7].r;
+ a[i__5].r = q__1.r, a[i__5].i = q__1.i;
+ i__5 = jr + jc * b_dim1;
+ i__6 = (n << 1) + jr;
+ r_cnjg(&q__3, &work[n * 3 + jc]);
+ q__2.r = work[i__6].r * q__3.r - work[i__6].i *
+ q__3.i, q__2.i = work[i__6].r * q__3.i +
+ work[i__6].i * q__3.r;
+ i__7 = jr + jc * b_dim1;
+ q__1.r = q__2.r * b[i__7].r - q__2.i * b[i__7].i,
+ q__1.i = q__2.r * b[i__7].i + q__2.i * b[
+ i__7].r;
+ b[i__5].r = q__1.r, b[i__5].i = q__1.i;
+/* L60: */
+ }
+/* L70: */
+ }
+ i__3 = n - 1;
+ cunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ cunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &a[a_offset], lda, &work[(n << 1) +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ cunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &b[b_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ cunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &b[b_offset], lda, &work[(n << 1) +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ }
+ } else {
+
+/* Random matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ i__5 = jr + jc * a_dim1;
+ i__6 = kamagn[jtype - 1];
+ clarnd_(&q__2, &c__4, &iseed[1]);
+ q__1.r = rmagn[i__6] * q__2.r, q__1.i = rmagn[i__6] *
+ q__2.i;
+ a[i__5].r = q__1.r, a[i__5].i = q__1.i;
+ i__5 = jr + jc * b_dim1;
+ i__6 = kbmagn[jtype - 1];
+ clarnd_(&q__2, &c__4, &iseed[1]);
+ q__1.r = rmagn[i__6] * q__2.r, q__1.i = rmagn[i__6] *
+ q__2.i;
+ b[i__5].r = q__1.r, b[i__5].i = q__1.i;
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+
+L100:
+
+ if (iinfo != 0) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L110:
+
+ for (i__ = 1; i__ <= 13; ++i__) {
+ result[i__] = -1.f;
+/* L120: */
+ }
+
+/* Test with and without sorting of eigenvalues */
+
+ for (isort = 0; isort <= 1; ++isort) {
+ if (isort == 0) {
+ *(unsigned char *)sort = 'N';
+ rsub = 0;
+ } else {
+ *(unsigned char *)sort = 'S';
+ rsub = 5;
+ }
+
+/* Call CGGES to compute H, T, Q, Z, alpha, and beta. */
+
+ clacpy_("Full", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ clacpy_("Full", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ ntest = rsub + 1 + isort;
+ result[rsub + 1 + isort] = ulpinv;
+ cgges_("V", "V", sort, (L_fp)clctes_, &n, &s[s_offset], lda, &
+ t[t_offset], lda, &sdim, &alpha[1], &beta[1], &q[
+ q_offset], ldq, &z__[z_offset], ldq, &work[1], lwork,
+ &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != n + 2) {
+ result[rsub + 1 + isort] = ulpinv;
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ do_fio(&c__1, "CGGES", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L160;
+ }
+
+ ntest = rsub + 4;
+
+/* Do tests 1--4 (or tests 7--9 when reordering ) */
+
+ if (isort == 0) {
+ cget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, &
+ q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
+ rwork[1], &result[1]);
+ cget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &
+ q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
+ rwork[1], &result[2]);
+ } else {
+ cget54_(&n, &a[a_offset], lda, &b[b_offset], lda, &s[
+ s_offset], lda, &t[t_offset], lda, &q[q_offset],
+ ldq, &z__[z_offset], ldq, &work[1], &result[rsub
+ + 2]);
+ }
+
+ cget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
+ q_offset], ldq, &q[q_offset], ldq, &work[1], &rwork[1]
+, &result[rsub + 3]);
+ cget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[
+ z_offset], ldq, &z__[z_offset], ldq, &work[1], &rwork[
+ 1], &result[rsub + 4]);
+
+/* Do test 5 and 6 (or Tests 10 and 11 when reordering): */
+/* check Schur form of A and compare eigenvalues with */
+/* diagonals. */
+
+ ntest = rsub + 6;
+ temp1 = 0.f;
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ ilabad = FALSE_;
+ i__4 = j;
+ i__5 = j + j * s_dim1;
+ q__2.r = alpha[i__4].r - s[i__5].r, q__2.i = alpha[i__4]
+ .i - s[i__5].i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ i__6 = j;
+ i__7 = j + j * t_dim1;
+ q__4.r = beta[i__6].r - t[i__7].r, q__4.i = beta[i__6].i
+ - t[i__7].i;
+ q__3.r = q__4.r, q__3.i = q__4.i;
+/* Computing MAX */
+ i__8 = j;
+ i__9 = j + j * s_dim1;
+ r__13 = safmin, r__14 = (r__1 = alpha[i__8].r, dabs(r__1))
+ + (r__2 = r_imag(&alpha[j]), dabs(r__2)), r__13 =
+ max(r__13,r__14), r__14 = (r__3 = s[i__9].r,
+ dabs(r__3)) + (r__4 = r_imag(&s[j + j * s_dim1]),
+ dabs(r__4));
+/* Computing MAX */
+ i__10 = j;
+ i__11 = j + j * t_dim1;
+ r__15 = safmin, r__16 = (r__5 = beta[i__10].r, dabs(r__5))
+ + (r__6 = r_imag(&beta[j]), dabs(r__6)), r__15 =
+ max(r__15,r__16), r__16 = (r__7 = t[i__11].r,
+ dabs(r__7)) + (r__8 = r_imag(&t[j + j * t_dim1]),
+ dabs(r__8));
+ temp2 = (((r__9 = q__1.r, dabs(r__9)) + (r__10 = r_imag(&
+ q__1), dabs(r__10))) / dmax(r__13,r__14) + ((
+ r__11 = q__3.r, dabs(r__11)) + (r__12 = r_imag(&
+ q__3), dabs(r__12))) / dmax(r__15,r__16)) / ulp;
+
+ if (j < n) {
+ i__4 = j + 1 + j * s_dim1;
+ if (s[i__4].r != 0.f || s[i__4].i != 0.f) {
+ ilabad = TRUE_;
+ result[rsub + 5] = ulpinv;
+ }
+ }
+ if (j > 1) {
+ i__4 = j + (j - 1) * s_dim1;
+ if (s[i__4].r != 0.f || s[i__4].i != 0.f) {
+ ilabad = TRUE_;
+ result[rsub + 5] = ulpinv;
+ }
+ }
+ temp1 = dmax(temp1,temp2);
+ if (ilabad) {
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+/* L130: */
+ }
+ result[rsub + 6] = temp1;
+
+ if (isort >= 1) {
+
+/* Do test 12 */
+
+ ntest = 12;
+ result[12] = 0.f;
+ knteig = 0;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (clctes_(&alpha[i__], &beta[i__])) {
+ ++knteig;
+ }
+/* L140: */
+ }
+ if (sdim != knteig) {
+ result[13] = ulpinv;
+ }
+ }
+
+/* L150: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L160:
+
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__3 = ntest;
+ for (jr = 1; jr <= i__3; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, "CGS", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ e_wsfe();
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+ e_wsfe();
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ do_fio(&c__1, "Unitary", (ftnlen)7);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, "unitary", (ftnlen)7);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ for (j = 1; j <= 8; ++j) {
+ do_fio(&c__1, "'", (ftnlen)1);
+ }
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[jr] < 1e4f) {
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ } else {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ }
+ }
+/* L170: */
+ }
+
+L180:
+ ;
+ }
+/* L190: */
+ }
+
+/* Summary */
+
+ alasvm_("CGS", nounit, &nerrs, &ntestt, &c__0);
+
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+
+ return 0;
+
+
+
+
+
+
+
+/* End of CDRGES */
+
+} /* cdrges_ */
diff --git a/TESTING/EIG/cdrgev.c b/TESTING/EIG/cdrgev.c
new file mode 100644
index 0000000..a8c1aa5
--- /dev/null
+++ b/TESTING/EIG/cdrgev.c
@@ -0,0 +1,1143 @@
+/* cdrgev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static real c_b28 = 1.f;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+static integer c__0 = 0;
+
+/* Subroutine */ int cdrgev_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, integer *nounit,
+ complex *a, integer *lda, complex *b, complex *s, complex *t, complex
+ *q, integer *ldq, complex *z__, complex *qe, integer *ldqe, complex *
+ alpha, complex *beta, complex *alpha1, complex *beta1, complex *work,
+ integer *lwork, real *rwork, real *result, integer *info)
+{
+ /* Initialized data */
+
+ static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
+ 2,2,2,3 };
+ static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
+ 2,3,2,1 };
+ static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
+ 1,1,1,1 };
+ static logical lasign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ TRUE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,FALSE_,
+ TRUE_,FALSE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_ };
+ static logical lbsign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ FALSE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,FALSE_,
+ TRUE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ FALSE_ };
+ static integer kz1[6] = { 0,1,2,1,3,3 };
+ static integer kz2[6] = { 0,0,1,2,1,1 };
+ static integer kadd[6] = { 0,0,0,0,3,2 };
+ static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
+ 4,4,4,0 };
+ static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
+ 8,8,8,8,8,0 };
+ static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
+ 3,3,3,1 };
+ static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
+ 4,4,4,1 };
+ static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
+ 3,3,2,1 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 CDRGEV: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/3x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 CDRGEV: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,3x,\002N=\002,i4,\002, JTYPE=\002,"
+ "i3,\002, ISEED=(\002,3(i4,\002,\002),i5,\002)\002)";
+ static char fmt_9997[] = "(/1x,a3,\002 -- Complex Generalized eigenvalue"
+ " problem \002,\002driver\002)";
+ static char fmt_9996[] = "(\002 Matrix types (see CDRGEV for details):"
+ " \002)";
+ static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
+ "osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
+ ") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
+ "onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
+ "I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
+ "arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
+ "(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
+ "=(D, reversed D)\002)";
+ static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
+ "atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
+ " 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
+ "ha&beta \002,\002 20=arithmetic alpha, beta=0,"
+ "1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
+ "=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
+ "/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
+ "l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
+ ".\002)";
+ static char fmt_9993[] = "(/\002 Tests performed: \002,/\002 1 = max "
+ "| ( b A - a B )'*l | / const.,\002,/\002 2 = | |VR(i)| - 1 | / u"
+ "lp,\002,/\002 3 = max | ( b A - a B )*r | / const.\002,/\002 4 ="
+ " | |VL(i)| - 1 | / ulp,\002,/\002 5 = 0 if W same no matter if r"
+ " or l computed,\002,/\002 6 = 0 if l same no matter if l compute"
+ "d,\002,/\002 7 = 0 if r same no matter if r computed,\002,/1x)";
+ static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",0p,f8.2)";
+ static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",1p,e10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, qe_dim1,
+ qe_offset, s_dim1, s_offset, t_dim1, t_offset, z_dim1, z_offset,
+ i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+ real r__1, r__2;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ double r_sign(real *, real *), c_abs(complex *);
+ void r_cnjg(complex *, complex *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, n, n1, jc, nb, in, jr;
+ real ulp;
+ integer iadd, ierr, nmax;
+ logical badnn;
+ extern /* Subroutine */ int cget52_(logical *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ complex *, complex *, real *, real *), cggev_(char *, char *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ complex *, complex *, integer *, complex *, integer *, complex *,
+ integer *, real *, integer *);
+ real rmagn[4];
+ complex ctemp;
+ integer nmats, jsize, nerrs, jtype;
+ extern /* Subroutine */ int clatm4_(integer *, integer *, integer *,
+ integer *, logical *, real *, real *, real *, integer *, integer *
+, complex *, integer *), cunm2r_(char *, char *, integer *,
+ integer *, integer *, complex *, integer *, complex *, complex *,
+ integer *, complex *, integer *), slabad_(real *,
+ real *), clarfg_(integer *, complex *, complex *, integer *,
+ complex *);
+ extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *);
+ real safmin, safmax;
+ integer ioldsd[4];
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *), xerbla_(char *, integer *);
+ integer minwrk, maxwrk;
+ real ulpinv;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9991, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRGEV checks the nonsymmetric generalized eigenvalue problem driver */
+/* routine CGGEV. */
+
+/* CGGEV computes for a pair of n-by-n nonsymmetric matrices (A,B) the */
+/* generalized eigenvalues and, optionally, the left and right */
+/* eigenvectors. */
+
+/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w */
+/* or a ratio alpha/beta = w, such that A - w*B is singular. It is */
+/* usually represented as the pair (alpha,beta), as there is reasonalbe */
+/* interpretation for beta=0, and even for both being zero. */
+
+/* A right generalized eigenvector corresponding to a generalized */
+/* eigenvalue w for a pair of matrices (A,B) is a vector r such that */
+/* (A - wB) * r = 0. A left generalized eigenvector is a vector l such */
+/* that l**H * (A - wB) = 0, where l**H is the conjugate-transpose of l. */
+
+/* When CDRGEV is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, a pair of matrices (A, B) will be generated */
+/* and used for testing. For each matrix pair, the following tests */
+/* will be performed and compared with the threshhold THRESH. */
+
+/* Results from CGGEV: */
+
+/* (1) max over all left eigenvalue/-vector pairs (alpha/beta,l) of */
+
+/* | VL**H * (beta A - alpha B) |/( ulp max(|beta A|, |alpha B|) ) */
+
+/* where VL**H is the conjugate-transpose of VL. */
+
+/* (2) | |VL(i)| - 1 | / ulp and whether largest component real */
+
+/* VL(i) denotes the i-th column of VL. */
+
+/* (3) max over all left eigenvalue/-vector pairs (alpha/beta,r) of */
+
+/* | (beta A - alpha B) * VR | / ( ulp max(|beta A|, |alpha B|) ) */
+
+/* (4) | |VR(i)| - 1 | / ulp and whether largest component real */
+
+/* VR(i) denotes the i-th column of VR. */
+
+/* (5) W(full) = W(partial) */
+/* W(full) denotes the eigenvalues computed when both l and r */
+/* are also computed, and W(partial) denotes the eigenvalues */
+/* computed when only W, only W and r, or only W and l are */
+/* computed. */
+
+/* (6) VL(full) = VL(partial) */
+/* VL(full) denotes the left eigenvectors computed when both l */
+/* and r are computed, and VL(partial) denotes the result */
+/* when only l is computed. */
+
+/* (7) VR(full) = VR(partial) */
+/* VR(full) denotes the right eigenvectors computed when both l */
+/* and r are also computed, and VR(partial) denotes the result */
+/* when only l is computed. */
+
+
+/* Test Matrices */
+/* ---- -------- */
+
+/* The sizes of the test matrices are specified by an array */
+/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
+/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) ( 0, 0 ) (a pair of zero matrices) */
+
+/* (2) ( I, 0 ) (an identity and a zero matrix) */
+
+/* (3) ( 0, I ) (an identity and a zero matrix) */
+
+/* (4) ( I, I ) (a pair of identity matrices) */
+
+/* t t */
+/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
+
+/* t ( I 0 ) */
+/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
+/* ( 0 I ) ( 0 J ) */
+/* and I is a k x k identity and J a (k+1)x(k+1) */
+/* Jordan block; k=(N-1)/2 */
+
+/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
+/* matrix with those diagonal entries.) */
+/* (8) ( I, D ) */
+
+/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
+
+/* (10) ( small*D, big*I ) */
+
+/* (11) ( big*I, small*D ) */
+
+/* (12) ( small*I, big*D ) */
+
+/* (13) ( big*D, big*I ) */
+
+/* (14) ( small*D, small*I ) */
+
+/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
+/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
+/* t t */
+/* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. */
+
+/* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices */
+/* with random O(1) entries above the diagonal */
+/* and diagonal entries diag(T1) = */
+/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
+/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
+
+/* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
+/* s = machine precision. */
+
+/* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
+
+/* N-5 */
+/* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+
+/* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+/* where r1,..., r(N-4) are random. */
+
+/* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular */
+/* matrices. */
+
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* CDRGES does nothing. NSIZES >= 0. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. NN >= 0. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, CDRGEV */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to CDRGES to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error is */
+/* scaled to be O(1), so THRESH should be a reasonably small */
+/* multiple of 1, e.g., 10 or 100. In particular, it should */
+/* not depend on the precision (single vs. double) or the size */
+/* of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IERR not equal to 0.) */
+
+/* A (input/workspace) COMPLEX array, dimension(LDA, max(NN)) */
+/* Used to hold the original A matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, S, and T. */
+/* It must be at least 1 and at least max( NN ). */
+
+/* B (input/workspace) COMPLEX array, dimension(LDA, max(NN)) */
+/* Used to hold the original B matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* S (workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* The Schur form matrix computed from A by CGGEV. On exit, S */
+/* contains the Schur form matrix corresponding to the matrix */
+/* in A. */
+
+/* T (workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from B by CGGEV. */
+
+/* Q (workspace) COMPLEX array, dimension (LDQ, max(NN)) */
+/* The (left) eigenvectors matrix computed by CGGEV. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of Q and Z. It must */
+/* be at least 1 and at least max( NN ). */
+
+/* Z (workspace) COMPLEX array, dimension( LDQ, max(NN) ) */
+/* The (right) orthogonal matrix computed by CGGEV. */
+
+/* QE (workspace) COMPLEX array, dimension( LDQ, max(NN) ) */
+/* QE holds the computed right or left eigenvectors. */
+
+/* LDQE (input) INTEGER */
+/* The leading dimension of QE. LDQE >= max(1,max(NN)). */
+
+/* ALPHA (workspace) COMPLEX array, dimension (max(NN)) */
+/* BETA (workspace) COMPLEX array, dimension (max(NN)) */
+/* The generalized eigenvalues of (A,B) computed by CGGEV. */
+/* ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th */
+/* generalized eigenvalue of A and B. */
+
+/* ALPHA1 (workspace) COMPLEX array, dimension (max(NN)) */
+/* BETA1 (workspace) COMPLEX array, dimension (max(NN)) */
+/* Like ALPHAR, ALPHAI, BETA, these arrays contain the */
+/* eigenvalues of A and B, but those computed when CGGEV only */
+/* computes a partial eigendecomposition, i.e. not the */
+/* eigenvalues and left and right eigenvectors. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. LWORK >= N*(N+1) */
+
+/* RWORK (workspace) REAL array, dimension (8*N) */
+/* Real workspace. */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid overflow. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: A routine returned an error code. INFO is the */
+/* absolute value of the INFO value returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ t_dim1 = *lda;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ s_dim1 = *lda;
+ s_offset = 1 + s_dim1;
+ s -= s_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ z_dim1 = *ldq;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ qe_dim1 = *ldqe;
+ qe_offset = 1 + qe_dim1;
+ qe -= qe_offset;
+ --alpha;
+ --beta;
+ --alpha1;
+ --beta1;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.f) {
+ *info = -6;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldq <= 1 || *ldq < nmax) {
+ *info = -14;
+ } else if (*ldqe <= 1 || *ldqe < nmax) {
+ *info = -17;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. */
+
+ minwrk = 1;
+ if (*info == 0 && *lwork >= 1) {
+ minwrk = nmax * (nmax + 1);
+/* Computing MAX */
+ i__1 = 1, i__2 = ilaenv_(&c__1, "CGEQRF", " ", &nmax, &nmax, &c_n1, &
+ c_n1), i__1 = max(i__1,i__2), i__2 =
+ ilaenv_(&c__1, "CUNMQR", "LC", &nmax, &nmax, &nmax, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
+ c__1, "CUNGQR", " ", &nmax, &nmax, &nmax, &c_n1);
+ nb = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = nmax << 1, i__2 = nmax * (nb + 1), i__1 = max(i__1,i__2), i__2
+ = nmax * (nmax + 1);
+ maxwrk = max(i__1,i__2);
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+ }
+
+ if (*lwork < minwrk) {
+ *info = -23;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CDRGEV", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+ ulp = slamch_("Precision");
+ safmin = slamch_("Safe minimum");
+ safmin /= ulp;
+ safmax = 1.f / safmin;
+ slabad_(&safmin, &safmax);
+ ulpinv = 1.f / ulp;
+
+/* The values RMAGN(2:3) depend on N, see below. */
+
+ rmagn[0] = 0.f;
+ rmagn[1] = 1.f;
+
+/* Loop over sizes, types */
+
+ ntestt = 0;
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ n1 = max(1,n);
+ rmagn[2] = safmax * ulp / (real) n1;
+ rmagn[3] = safmin * ulpinv * n1;
+
+ if (*nsizes != 1) {
+ mtypes = min(26,*ntypes);
+ } else {
+ mtypes = min(27,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L210;
+ }
+ ++nmats;
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Generate test matrices A and B */
+
+/* Description of control parameters: */
+
+/* KCLASS: =1 means w/o rotation, =2 means w/ rotation, */
+/* =3 means random. */
+/* KATYPE: the "type" to be passed to CLATM4 for computing A. */
+/* KAZERO: the pattern of zeros on the diagonal for A: */
+/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
+/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
+/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
+/* non-zero entries.) */
+/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
+/* =2: large, =3: small. */
+/* LASIGN: .TRUE. if the diagonal elements of A are to be */
+/* multiplied by a random magnitude 1 number. */
+/* KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B. */
+/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
+/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
+/* RMAGN: used to implement KAMAGN and KBMAGN. */
+
+ if (mtypes > 26) {
+ goto L100;
+ }
+ ierr = 0;
+ if (kclass[jtype - 1] < 3) {
+
+/* Generate A (w/o rotation) */
+
+ if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ claset_("Full", &n, &n, &c_b1, &c_b1, &a[a_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ clatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
+ &kz2[kazero[jtype - 1] - 1], &lasign[jtype - 1], &
+ rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
+ 1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
+ a_offset], lda);
+ iadd = kadd[kazero[jtype - 1] - 1];
+ if (iadd > 0 && iadd <= n) {
+ i__3 = iadd + iadd * a_dim1;
+ i__4 = kamagn[jtype - 1];
+ a[i__3].r = rmagn[i__4], a[i__3].i = 0.f;
+ }
+
+/* Generate B (w/o rotation) */
+
+ if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ claset_("Full", &n, &n, &c_b1, &c_b1, &b[b_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ clatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
+ &kz2[kbzero[jtype - 1] - 1], &lbsign[jtype - 1], &
+ rmagn[kbmagn[jtype - 1]], &c_b28, &rmagn[ktrian[jtype
+ - 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
+ b_offset], lda);
+ iadd = kadd[kbzero[jtype - 1] - 1];
+ if (iadd != 0 && iadd <= n) {
+ i__3 = iadd + iadd * b_dim1;
+ i__4 = kbmagn[jtype - 1];
+ b[i__3].r = rmagn[i__4], b[i__3].i = 0.f;
+ }
+
+ if (kclass[jtype - 1] == 2 && n > 0) {
+
+/* Include rotations */
+
+/* Generate Q, Z as Householder transformations times */
+/* a diagonal matrix. */
+
+ i__3 = n - 1;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = jc; jr <= i__4; ++jr) {
+ i__5 = jr + jc * q_dim1;
+ clarnd_(&q__1, &c__3, &iseed[1]);
+ q[i__5].r = q__1.r, q[i__5].i = q__1.i;
+ i__5 = jr + jc * z_dim1;
+ clarnd_(&q__1, &c__3, &iseed[1]);
+ z__[i__5].r = q__1.r, z__[i__5].i = q__1.i;
+/* L30: */
+ }
+ i__4 = n + 1 - jc;
+ clarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc *
+ q_dim1], &c__1, &work[jc]);
+ i__4 = (n << 1) + jc;
+ i__5 = jc + jc * q_dim1;
+ r__2 = q[i__5].r;
+ r__1 = r_sign(&c_b28, &r__2);
+ work[i__4].r = r__1, work[i__4].i = 0.f;
+ i__4 = jc + jc * q_dim1;
+ q[i__4].r = 1.f, q[i__4].i = 0.f;
+ i__4 = n + 1 - jc;
+ clarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 +
+ jc * z_dim1], &c__1, &work[n + jc]);
+ i__4 = n * 3 + jc;
+ i__5 = jc + jc * z_dim1;
+ r__2 = z__[i__5].r;
+ r__1 = r_sign(&c_b28, &r__2);
+ work[i__4].r = r__1, work[i__4].i = 0.f;
+ i__4 = jc + jc * z_dim1;
+ z__[i__4].r = 1.f, z__[i__4].i = 0.f;
+/* L40: */
+ }
+ clarnd_(&q__1, &c__3, &iseed[1]);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__3 = n + n * q_dim1;
+ q[i__3].r = 1.f, q[i__3].i = 0.f;
+ i__3 = n;
+ work[i__3].r = 0.f, work[i__3].i = 0.f;
+ i__3 = n * 3;
+ r__1 = c_abs(&ctemp);
+ q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ clarnd_(&q__1, &c__3, &iseed[1]);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__3 = n + n * z_dim1;
+ z__[i__3].r = 1.f, z__[i__3].i = 0.f;
+ i__3 = n << 1;
+ work[i__3].r = 0.f, work[i__3].i = 0.f;
+ i__3 = n << 2;
+ r__1 = c_abs(&ctemp);
+ q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+
+/* Apply the diagonal matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ i__5 = jr + jc * a_dim1;
+ i__6 = (n << 1) + jr;
+ r_cnjg(&q__3, &work[n * 3 + jc]);
+ q__2.r = work[i__6].r * q__3.r - work[i__6].i *
+ q__3.i, q__2.i = work[i__6].r * q__3.i +
+ work[i__6].i * q__3.r;
+ i__7 = jr + jc * a_dim1;
+ q__1.r = q__2.r * a[i__7].r - q__2.i * a[i__7].i,
+ q__1.i = q__2.r * a[i__7].i + q__2.i * a[
+ i__7].r;
+ a[i__5].r = q__1.r, a[i__5].i = q__1.i;
+ i__5 = jr + jc * b_dim1;
+ i__6 = (n << 1) + jr;
+ r_cnjg(&q__3, &work[n * 3 + jc]);
+ q__2.r = work[i__6].r * q__3.r - work[i__6].i *
+ q__3.i, q__2.i = work[i__6].r * q__3.i +
+ work[i__6].i * q__3.r;
+ i__7 = jr + jc * b_dim1;
+ q__1.r = q__2.r * b[i__7].r - q__2.i * b[i__7].i,
+ q__1.i = q__2.r * b[i__7].i + q__2.i * b[
+ i__7].r;
+ b[i__5].r = q__1.r, b[i__5].i = q__1.i;
+/* L50: */
+ }
+/* L60: */
+ }
+ i__3 = n - 1;
+ cunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &a[a_offset], lda, &work[(n << 1) + 1], &ierr);
+ if (ierr != 0) {
+ goto L90;
+ }
+ i__3 = n - 1;
+ cunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &a[a_offset], lda, &work[(n << 1) +
+ 1], &ierr);
+ if (ierr != 0) {
+ goto L90;
+ }
+ i__3 = n - 1;
+ cunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &b[b_offset], lda, &work[(n << 1) + 1], &ierr);
+ if (ierr != 0) {
+ goto L90;
+ }
+ i__3 = n - 1;
+ cunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &b[b_offset], lda, &work[(n << 1) +
+ 1], &ierr);
+ if (ierr != 0) {
+ goto L90;
+ }
+ }
+ } else {
+
+/* Random matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ i__5 = jr + jc * a_dim1;
+ i__6 = kamagn[jtype - 1];
+ clarnd_(&q__2, &c__4, &iseed[1]);
+ q__1.r = rmagn[i__6] * q__2.r, q__1.i = rmagn[i__6] *
+ q__2.i;
+ a[i__5].r = q__1.r, a[i__5].i = q__1.i;
+ i__5 = jr + jc * b_dim1;
+ i__6 = kbmagn[jtype - 1];
+ clarnd_(&q__2, &c__4, &iseed[1]);
+ q__1.r = rmagn[i__6] * q__2.r, q__1.i = rmagn[i__6] *
+ q__2.i;
+ b[i__5].r = q__1.r, b[i__5].i = q__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+
+L90:
+
+ if (ierr != 0) {
+ io___40.ciunit = *nounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(ierr);
+ return 0;
+ }
+
+L100:
+
+ for (i__ = 1; i__ <= 7; ++i__) {
+ result[i__] = -1.f;
+/* L110: */
+ }
+
+/* Call CGGEV to compute eigenvalues and eigenvectors. */
+
+ clacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ clacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ cggev_("V", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &alpha[
+ 1], &beta[1], &q[q_offset], ldq, &z__[z_offset], ldq, &
+ work[1], lwork, &rwork[1], &ierr);
+ if (ierr != 0 && ierr != n + 1) {
+ result[1] = ulpinv;
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "CGGEV1", (ftnlen)6);
+ do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(ierr);
+ goto L190;
+ }
+
+/* Do the tests (1) and (2) */
+
+ cget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &q[
+ q_offset], ldq, &alpha[1], &beta[1], &work[1], &rwork[1],
+ &result[1]);
+ if (result[2] > *thresh) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "CGGEV1", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Do the tests (3) and (4) */
+
+ cget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &z__[
+ z_offset], ldq, &alpha[1], &beta[1], &work[1], &rwork[1],
+ &result[3]);
+ if (result[4] > *thresh) {
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "CGGEV1", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[4], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Do test (5) */
+
+ clacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ clacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ cggev_("N", "N", &n, &s[s_offset], lda, &t[t_offset], lda, &
+ alpha1[1], &beta1[1], &q[q_offset], ldq, &z__[z_offset],
+ ldq, &work[1], lwork, &rwork[1], &ierr);
+ if (ierr != 0 && ierr != n + 1) {
+ result[1] = ulpinv;
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "CGGEV2", (ftnlen)6);
+ do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(ierr);
+ goto L190;
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ i__5 = j;
+ i__6 = j;
+ i__7 = j;
+ if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i !=
+ alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r ||
+ beta[i__6].i != beta1[i__7].i)) {
+ result[5] = ulpinv;
+ }
+/* L120: */
+ }
+
+/* Do test (6): Compute eigenvalues and left eigenvectors, */
+/* and test them */
+
+ clacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ clacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ cggev_("V", "N", &n, &s[s_offset], lda, &t[t_offset], lda, &
+ alpha1[1], &beta1[1], &qe[qe_offset], ldqe, &z__[z_offset]
+, ldq, &work[1], lwork, &rwork[1], &ierr);
+ if (ierr != 0 && ierr != n + 1) {
+ result[1] = ulpinv;
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, "CGGEV3", (ftnlen)6);
+ do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(ierr);
+ goto L190;
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ i__5 = j;
+ i__6 = j;
+ i__7 = j;
+ if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i !=
+ alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r ||
+ beta[i__6].i != beta1[i__7].i)) {
+ result[6] = ulpinv;
+ }
+/* L130: */
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (jc = 1; jc <= i__4; ++jc) {
+ i__5 = j + jc * q_dim1;
+ i__6 = j + jc * qe_dim1;
+ if (q[i__5].r != qe[i__6].r || q[i__5].i != qe[i__6].i) {
+ result[6] = ulpinv;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+/* Do test (7): Compute eigenvalues and right eigenvectors, */
+/* and test them */
+
+ clacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ clacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ cggev_("N", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
+ alpha1[1], &beta1[1], &q[q_offset], ldq, &qe[qe_offset],
+ ldqe, &work[1], lwork, &rwork[1], &ierr);
+ if (ierr != 0 && ierr != n + 1) {
+ result[1] = ulpinv;
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ do_fio(&c__1, "CGGEV4", (ftnlen)6);
+ do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(ierr);
+ goto L190;
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ i__5 = j;
+ i__6 = j;
+ i__7 = j;
+ if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i !=
+ alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r ||
+ beta[i__6].i != beta1[i__7].i)) {
+ result[7] = ulpinv;
+ }
+/* L160: */
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (jc = 1; jc <= i__4; ++jc) {
+ i__5 = j + jc * z_dim1;
+ i__6 = j + jc * qe_dim1;
+ if (z__[i__5].r != qe[i__6].r || z__[i__5].i != qe[i__6]
+ .i) {
+ result[7] = ulpinv;
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L190:
+
+ ntestt += 7;
+
+/* Print out tests which fail. */
+
+ for (jr = 1; jr <= 7; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___48.ciunit = *nounit;
+ s_wsfe(&io___48);
+ do_fio(&c__1, "CGV", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ e_wsfe();
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ e_wsfe();
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "Orthogonal", (ftnlen)10);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[jr] < 1e4f) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ } else {
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ }
+ }
+/* L200: */
+ }
+
+L210:
+ ;
+ }
+/* L220: */
+ }
+
+/* Summary */
+
+ alasvm_("CGV", nounit, &nerrs, &ntestt, &c__0);
+
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+
+ return 0;
+
+
+
+
+
+
+
+/* End of CDRGEV */
+
+} /* cdrgev_ */
diff --git a/TESTING/EIG/cdrgsx.c b/TESTING/EIG/cdrgsx.c
new file mode 100644
index 0000000..cbdd280
--- /dev/null
+++ b/TESTING/EIG/cdrgsx.c
@@ -0,0 +1,1209 @@
+/* cdrgsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer m, n, mplusn, k;
+ logical fs;
+} mn_;
+
+#define mn_1 mn_
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__6 = 6;
+static integer c__4 = 4;
+
+/* Subroutine */ int cdrgsx_(integer *nsize, integer *ncmax, real *thresh,
+ integer *nin, integer *nout, complex *a, integer *lda, complex *b,
+ complex *ai, complex *bi, complex *z__, complex *q, complex *alpha,
+ complex *beta, complex *c__, integer *ldc, real *s, complex *work,
+ integer *lwork, real *rwork, integer *iwork, integer *liwork, logical
+ *bwork, integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 CDRGSX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002)\002)";
+ static char fmt_9997[] = "(\002 CDRGSX: S not in Schur form at eigenvalu"
+ "e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002"
+ ")\002)";
+ static char fmt_9996[] = "(/1x,a3,\002 -- Complex Expert Generalized Sch"
+ "ur form\002,\002 problem driver\002)";
+ static char fmt_9994[] = "(\002 Matrix types: \002,/\002 1: A is a blo"
+ "ck diagonal matrix of Jordan blocks \002,\002and B is the identi"
+ "ty \002,/\002 matrix, \002,/\002 2: A and B are upper tri"
+ "angular matrices, \002,/\002 3: A and B are as type 2, but eac"
+ "h second diagonal \002,\002block in A_11 and \002,/\002 eac"
+ "h third diaongal block in A_22 are 2x2 blocks,\002,/\002 4: A "
+ "and B are block diagonal matrices, \002,/\002 5: (A,B) has pot"
+ "entially close or common \002,\002eigenvalues.\002,/)";
+ static char fmt_9993[] = "(/\002 Tests performed: (S is Schur, T is tri"
+ "angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002 a is al"
+ "pha, b is beta, and \002,a,\002 means \002,a,\002.)\002,/\002 1"
+ " = | A - Q S Z\002,a,\002 | / ( |A| n ulp ) 2 = | B - Q T "
+ "Z\002,a,\002 | / ( |B| n ulp )\002,/\002 3 = | I - QQ\002,a,"
+ "\002 | / ( n ulp ) 4 = | I - ZZ\002,a,\002 | / ( n u"
+ "lp )\002,/\002 5 = 1/ULP if A is not in \002,\002Schur form "
+ "S\002,/\002 6 = difference between (alpha,beta)\002,\002 and di"
+ "agonals of (S,T)\002,/\002 7 = 1/ULP if SDIM is not the correc"
+ "t number of \002,\002selected eigenvalues\002,/\002 8 = 1/ULP "
+ "if DIFEST/DIFTRU > 10*THRESH or \002,\002DIFTRU/DIFEST > 10*THRE"
+ "SH\002,/\002 9 = 1/ULP if DIFEST <> 0 or DIFTRU > ULP*norm(A,B"
+ ") \002,\002when reordering fails\002,/\002 10 = 1/ULP if PLEST/"
+ "PLTRU > THRESH or \002,\002PLTRU/PLEST > THRESH\002,/\002 ( T"
+ "est 10 is only for input examples )\002,/)";
+ static char fmt_9992[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
+ ",\002, a=\002,e10.4,\002, order(A_11)=\002,i2,\002, result \002,"
+ "i2,\002 is \002,0p,f8.2)";
+ static char fmt_9991[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
+ ",\002, a=\002,e10.4,\002, order(A_11)=\002,i2,\002, result \002,"
+ "i2,\002 is \002,0p,e10.4)";
+ static char fmt_9998[] = "(\002 CDRGSX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, Input Example #\002,i2,\002"
+ ")\002)";
+ static char fmt_9995[] = "(\002Input Example\002)";
+ static char fmt_9990[] = "(\002 Input example #\002,i2,\002, matrix orde"
+ "r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,0p,f8.2)";
+ static char fmt_9989[] = "(\002 Input example #\002,i2,\002, matrix orde"
+ "r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,1p,e10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, ai_dim1, ai_offset, b_dim1, b_offset, bi_dim1,
+ bi_offset, c_dim1, c_offset, q_dim1, q_offset, z_dim1, z_offset,
+ i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10,
+ i__11;
+ real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10, r__11,
+ r__12, r__13, r__14, r__15, r__16;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double r_imag(complex *);
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+
+ /* Local variables */
+ integer i__, j, mm;
+ real pl[2];
+ integer mn2, qba, qbb;
+ real ulp, temp1, temp2;
+ extern /* Subroutine */ int cget51_(integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, complex *, real *, real *);
+ real abnrm;
+ integer ifunc, linfo;
+ char sense[1];
+ integer nerrs, ntest;
+ extern /* Subroutine */ int clakf2_(integer *, integer *, complex *,
+ integer *, complex *, complex *, complex *, complex *, integer *);
+ real pltru;
+ extern /* Subroutine */ int clatm5_(integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, complex *, integer *, real *, integer *,
+ integer *);
+ real thrsh2;
+ logical ilabad;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ integer bdspac;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int cgesvd_(char *, char *, integer *, integer *,
+ complex *, integer *, real *, complex *, integer *, complex *,
+ integer *, complex *, integer *, real *, integer *), clacpy_(char *, integer *, integer *, complex *, integer
+ *, complex *, integer *), claset_(char *, integer *,
+ integer *, complex *, complex *, complex *, integer *);
+ real difest[2];
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int cggesx_(char *, char *, char *, L_fp, char *,
+ integer *, complex *, integer *, complex *, integer *, integer *,
+ complex *, complex *, complex *, integer *, complex *, integer *,
+ real *, real *, complex *, integer *, real *, integer *, integer *
+, logical *, integer *);
+ real bignum;
+ extern /* Subroutine */ int xerbla_(char *, integer *), alasvm_(
+ char *, integer *, integer *, integer *, integer *);
+ real weight, diftru;
+ extern logical clctsx_();
+ integer minwrk, maxwrk;
+ real smlnum, ulpinv;
+ integer nptknt;
+ real result[10];
+ integer ntestt, prtype;
+
+ /* Fortran I/O blocks */
+ static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___39 = { 0, 0, 1, 0, 0 };
+ static cilist io___40 = { 0, 0, 1, 0, 0 };
+ static cilist io___41 = { 0, 0, 0, 0, 0 };
+ static cilist io___42 = { 0, 0, 0, 0, 0 };
+ static cilist io___43 = { 0, 0, 0, 0, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9989, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRGSX checks the nonsymmetric generalized eigenvalue (Schur form) */
+/* problem expert driver CGGESX. */
+
+/* CGGES factors A and B as Q*S*Z' and Q*T*Z' , where ' means conjugate */
+/* transpose, S and T are upper triangular (i.e., in generalized Schur */
+/* form), and Q and Z are unitary. It also computes the generalized */
+/* eigenvalues (alpha(j),beta(j)), j=1,...,n. Thus, */
+/* w(j) = alpha(j)/beta(j) is a root of the characteristic equation */
+
+/* det( A - w(j) B ) = 0 */
+
+/* Optionally it also reorders the eigenvalues so that a selected */
+/* cluster of eigenvalues appears in the leading diagonal block of the */
+/* Schur forms; computes a reciprocal condition number for the average */
+/* of the selected eigenvalues; and computes a reciprocal condition */
+/* number for the right and left deflating subspaces corresponding to */
+/* the selected eigenvalues. */
+
+/* When CDRGSX is called with NSIZE > 0, five (5) types of built-in */
+/* matrix pairs are used to test the routine CGGESX. */
+
+/* When CDRGSX is called with NSIZE = 0, it reads in test matrix data */
+/* to test CGGESX. */
+/* (need more details on what kind of read-in data are needed). */
+
+/* For each matrix pair, the following tests will be performed and */
+/* compared with the threshhold THRESH except for the tests (7) and (9): */
+
+/* (1) | A - Q S Z' | / ( |A| n ulp ) */
+
+/* (2) | B - Q T Z' | / ( |B| n ulp ) */
+
+/* (3) | I - QQ' | / ( n ulp ) */
+
+/* (4) | I - ZZ' | / ( n ulp ) */
+
+/* (5) if A is in Schur form (i.e. triangular form) */
+
+/* (6) maximum over j of D(j) where: */
+
+/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
+/* D(j) = ------------------------ + ----------------------- */
+/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
+
+/* (7) if sorting worked and SDIM is the number of eigenvalues */
+/* which were selected. */
+
+/* (8) the estimated value DIF does not differ from the true values of */
+/* Difu and Difl more than a factor 10*THRESH. If the estimate DIF */
+/* equals zero the corresponding true values of Difu and Difl */
+/* should be less than EPS*norm(A, B). If the true value of Difu */
+/* and Difl equal zero, the estimate DIF should be less than */
+/* EPS*norm(A, B). */
+
+/* (9) If INFO = N+3 is returned by CGGESX, the reordering "failed" */
+/* and we check that DIF = PL = PR = 0 and that the true value of */
+/* Difu and Difl is < EPS*norm(A, B). We count the events when */
+/* INFO=N+3. */
+
+/* For read-in test matrices, the same tests are run except that the */
+/* exact value for DIF (and PL) is input data. Additionally, there is */
+/* one more test run for read-in test matrices: */
+
+/* (10) the estimated value PL does not differ from the true value of */
+/* PLTRU more than a factor THRESH. If the estimate PL equals */
+/* zero the corresponding true value of PLTRU should be less than */
+/* EPS*norm(A, B). If the true value of PLTRU equal zero, the */
+/* estimate PL should be less than EPS*norm(A, B). */
+
+/* Note that for the built-in tests, a total of 10*NSIZE*(NSIZE-1) */
+/* matrix pairs are generated and tested. NSIZE should be kept small. */
+
+/* SVD (routine CGESVD) is used for computing the true value of DIF_u */
+/* and DIF_l when testing the built-in test problems. */
+
+/* Built-in Test Matrices */
+/* ====================== */
+
+/* All built-in test matrices are the 2 by 2 block of triangular */
+/* matrices */
+
+/* A = [ A11 A12 ] and B = [ B11 B12 ] */
+/* [ A22 ] [ B22 ] */
+
+/* where for different type of A11 and A22 are given as the following. */
+/* A12 and B12 are chosen so that the generalized Sylvester equation */
+
+/* A11*R - L*A22 = -A12 */
+/* B11*R - L*B22 = -B12 */
+
+/* have prescribed solution R and L. */
+
+/* Type 1: A11 = J_m(1,-1) and A_22 = J_k(1-a,1). */
+/* B11 = I_m, B22 = I_k */
+/* where J_k(a,b) is the k-by-k Jordan block with ``a'' on */
+/* diagonal and ``b'' on superdiagonal. */
+
+/* Type 2: A11 = (a_ij) = ( 2(.5-sin(i)) ) and */
+/* B11 = (b_ij) = ( 2(.5-sin(ij)) ) for i=1,...,m, j=i,...,m */
+/* A22 = (a_ij) = ( 2(.5-sin(i+j)) ) and */
+/* B22 = (b_ij) = ( 2(.5-sin(ij)) ) for i=m+1,...,k, j=i,...,k */
+
+/* Type 3: A11, A22 and B11, B22 are chosen as for Type 2, but each */
+/* second diagonal block in A_11 and each third diagonal block */
+/* in A_22 are made as 2 by 2 blocks. */
+
+/* Type 4: A11 = ( 20(.5 - sin(ij)) ) and B22 = ( 2(.5 - sin(i+j)) ) */
+/* for i=1,...,m, j=1,...,m and */
+/* A22 = ( 20(.5 - sin(i+j)) ) and B22 = ( 2(.5 - sin(ij)) ) */
+/* for i=m+1,...,k, j=m+1,...,k */
+
+/* Type 5: (A,B) and have potentially close or common eigenvalues and */
+/* very large departure from block diagonality A_11 is chosen */
+/* as the m x m leading submatrix of A_1: */
+/* | 1 b | */
+/* | -b 1 | */
+/* | 1+d b | */
+/* | -b 1+d | */
+/* A_1 = | d 1 | */
+/* | -1 d | */
+/* | -d 1 | */
+/* | -1 -d | */
+/* | 1 | */
+/* and A_22 is chosen as the k x k leading submatrix of A_2: */
+/* | -1 b | */
+/* | -b -1 | */
+/* | 1-d b | */
+/* | -b 1-d | */
+/* A_2 = | d 1+b | */
+/* | -1-b d | */
+/* | -d 1+b | */
+/* | -1+b -d | */
+/* | 1-d | */
+/* and matrix B are chosen as identity matrices (see SLATM5). */
+
+
+/* Arguments */
+/* ========= */
+
+/* NSIZE (input) INTEGER */
+/* The maximum size of the matrices to use. NSIZE >= 0. */
+/* If NSIZE = 0, no built-in tests matrices are used, but */
+/* read-in test matrices are used to test SGGESX. */
+
+/* NCMAX (input) INTEGER */
+/* Maximum allowable NMAX for generating Kroneker matrix */
+/* in call to CLAKF2 */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. THRESH >= 0. */
+
+/* NIN (input) INTEGER */
+/* The FORTRAN unit number for reading in the data file of */
+/* problems to solve. */
+
+/* NOUT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* A (workspace) COMPLEX array, dimension (LDA, NSIZE) */
+/* Used to store the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, AI, BI, Z and Q, */
+/* LDA >= max( 1, NSIZE ). For the read-in test, */
+/* LDA >= max( 1, N ), N is the size of the test matrices. */
+
+/* B (workspace) COMPLEX array, dimension (LDA, NSIZE) */
+/* Used to store the matrix whose eigenvalues are to be */
+/* computed. On exit, B contains the last matrix actually used. */
+
+/* AI (workspace) COMPLEX array, dimension (LDA, NSIZE) */
+/* Copy of A, modified by CGGESX. */
+
+/* BI (workspace) COMPLEX array, dimension (LDA, NSIZE) */
+/* Copy of B, modified by CGGESX. */
+
+/* Z (workspace) COMPLEX array, dimension (LDA, NSIZE) */
+/* Z holds the left Schur vectors computed by CGGESX. */
+
+/* Q (workspace) COMPLEX array, dimension (LDA, NSIZE) */
+/* Q holds the right Schur vectors computed by CGGESX. */
+
+/* ALPHA (workspace) COMPLEX array, dimension (NSIZE) */
+/* BETA (workspace) COMPLEX array, dimension (NSIZE) */
+/* On exit, ALPHA/BETA are the eigenvalues. */
+
+/* C (workspace) COMPLEX array, dimension (LDC, LDC) */
+/* Store the matrix generated by subroutine CLAKF2, this is the */
+/* matrix formed by Kronecker products used for estimating */
+/* DIF. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of C. LDC >= max(1, LDA*LDA/2 ). */
+
+/* S (workspace) REAL array, dimension (LDC) */
+/* Singular values of C */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= 3*NSIZE*NSIZE/2 */
+
+/* RWORK (workspace) REAL array, */
+/* dimension (5*NSIZE*NSIZE/2 - 4) */
+
+/* IWORK (workspace) INTEGER array, dimension (LIWORK) */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. LIWORK >= NSIZE + 2. */
+
+/* BWORK (workspace) LOGICAL array, dimension (NSIZE) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: A routine returned an error code. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ /* Parameter adjustments */
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *lda;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ bi_dim1 = *lda;
+ bi_offset = 1 + bi_dim1;
+ bi -= bi_offset;
+ ai_dim1 = *lda;
+ ai_offset = 1 + ai_dim1;
+ ai -= ai_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --alpha;
+ --beta;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --s;
+ --work;
+ --rwork;
+ --iwork;
+ --bwork;
+
+ /* Function Body */
+ if (*nsize < 0) {
+ *info = -1;
+ } else if (*thresh < 0.f) {
+ *info = -2;
+ } else if (*nin <= 0) {
+ *info = -3;
+ } else if (*nout <= 0) {
+ *info = -4;
+ } else if (*lda < 1 || *lda < *nsize) {
+ *info = -6;
+ } else if (*ldc < 1 || *ldc < *nsize * *nsize / 2) {
+ *info = -15;
+ } else if (*liwork < *nsize + 2) {
+ *info = -21;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ minwrk = 1;
+ if (*info == 0 && *lwork >= 1) {
+ minwrk = *nsize * 3 * *nsize / 2;
+
+/* workspace for cggesx */
+
+ maxwrk = *nsize * (ilaenv_(&c__1, "CGEQRF", " ", nsize, &c__1, nsize,
+ &c__0) + 1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *nsize * (ilaenv_(&c__1, "CUNGQR", " ", nsize, &
+ c__1, nsize, &c_n1) + 1);
+ maxwrk = max(i__1,i__2);
+
+/* workspace for cgesvd */
+
+ bdspac = *nsize * 3 * *nsize / 2;
+/* Computing MAX */
+ i__3 = *nsize * *nsize / 2;
+ i__4 = *nsize * *nsize / 2;
+ i__1 = maxwrk, i__2 = *nsize * *nsize * (ilaenv_(&c__1, "CGEBRD",
+ " ", &i__3, &i__4, &c_n1, &c_n1) + 1);
+ maxwrk = max(i__1,i__2);
+ maxwrk = max(maxwrk,bdspac);
+
+ maxwrk = max(maxwrk,minwrk);
+
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+ }
+
+ if (*lwork < minwrk) {
+ *info = -18;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CDRGSX", &i__1);
+ return 0;
+ }
+
+/* Important constants */
+
+ ulp = slamch_("P");
+ ulpinv = 1.f / ulp;
+ smlnum = slamch_("S") / ulp;
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ thrsh2 = *thresh * 10.f;
+ ntestt = 0;
+ nerrs = 0;
+
+/* Go to the tests for read-in matrix pairs */
+
+ ifunc = 0;
+ if (*nsize == 0) {
+ goto L70;
+ }
+
+/* Test the built-in matrix pairs. */
+/* Loop over different functions (IFUNC) of CGGESX, types (PRTYPE) */
+/* of test matrices, different size (M+N) */
+
+ prtype = 0;
+ qba = 3;
+ qbb = 4;
+ weight = sqrt(ulp);
+
+ for (ifunc = 0; ifunc <= 3; ++ifunc) {
+ for (prtype = 1; prtype <= 5; ++prtype) {
+ i__1 = *nsize - 1;
+ for (mn_1.m = 1; mn_1.m <= i__1; ++mn_1.m) {
+ i__2 = *nsize - mn_1.m;
+ for (mn_1.n = 1; mn_1.n <= i__2; ++mn_1.n) {
+
+ weight = 1.f / weight;
+ mn_1.mplusn = mn_1.m + mn_1.n;
+
+/* Generate test matrices */
+
+ mn_1.fs = TRUE_;
+ mn_1.k = 0;
+
+ claset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b1, &c_b1,
+ &ai[ai_offset], lda);
+ claset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b1, &c_b1,
+ &bi[bi_offset], lda);
+
+ clatm5_(&prtype, &mn_1.m, &mn_1.n, &ai[ai_offset], lda, &
+ ai[mn_1.m + 1 + (mn_1.m + 1) * ai_dim1], lda, &ai[
+ (mn_1.m + 1) * ai_dim1 + 1], lda, &bi[bi_offset],
+ lda, &bi[mn_1.m + 1 + (mn_1.m + 1) * bi_dim1],
+ lda, &bi[(mn_1.m + 1) * bi_dim1 + 1], lda, &q[
+ q_offset], lda, &z__[z_offset], lda, &weight, &
+ qba, &qbb);
+
+/* Compute the Schur factorization and swapping the */
+/* m-by-m (1,1)-blocks with n-by-n (2,2)-blocks. */
+/* Swapping is accomplished via the function CLCTSX */
+/* which is supplied below. */
+
+ if (ifunc == 0) {
+ *(unsigned char *)sense = 'N';
+ } else if (ifunc == 1) {
+ *(unsigned char *)sense = 'E';
+ } else if (ifunc == 2) {
+ *(unsigned char *)sense = 'V';
+ } else if (ifunc == 3) {
+ *(unsigned char *)sense = 'B';
+ }
+
+ clacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
+, lda, &a[a_offset], lda);
+ clacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
+, lda, &b[b_offset], lda);
+
+ cggesx_("V", "V", "S", (L_fp)clctsx_, sense, &mn_1.mplusn,
+ &ai[ai_offset], lda, &bi[bi_offset], lda, &mm, &
+ alpha[1], &beta[1], &q[q_offset], lda, &z__[
+ z_offset], lda, pl, difest, &work[1], lwork, &
+ rwork[1], &iwork[1], liwork, &bwork[1], &linfo);
+
+ if (linfo != 0 && linfo != mn_1.mplusn + 2) {
+ result[0] = ulpinv;
+ io___22.ciunit = *nout;
+ s_wsfe(&io___22);
+ do_fio(&c__1, "CGGESX", (ftnlen)6);
+ do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(integer)
+ );
+ e_wsfe();
+ *info = linfo;
+ goto L30;
+ }
+
+/* Compute the norm(A, B) */
+
+ clacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
+, lda, &work[1], &mn_1.mplusn);
+ clacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
+, lda, &work[mn_1.mplusn * mn_1.mplusn + 1], &
+ mn_1.mplusn);
+ i__3 = mn_1.mplusn << 1;
+ abnrm = clange_("Fro", &mn_1.mplusn, &i__3, &work[1], &
+ mn_1.mplusn, &rwork[1]);
+
+/* Do tests (1) to (4) */
+
+ result[1] = 0.f;
+ cget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[
+ ai_offset], lda, &q[q_offset], lda, &z__[z_offset]
+, lda, &work[1], &rwork[1], result);
+ cget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[
+ bi_offset], lda, &q[q_offset], lda, &z__[z_offset]
+, lda, &work[1], &rwork[1], &result[1]);
+ cget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
+ bi_offset], lda, &q[q_offset], lda, &q[q_offset],
+ lda, &work[1], &rwork[1], &result[2]);
+ cget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
+ bi_offset], lda, &z__[z_offset], lda, &z__[
+ z_offset], lda, &work[1], &rwork[1], &result[3]);
+ ntest = 4;
+
+/* Do tests (5) and (6): check Schur form of A and */
+/* compare eigenvalues with diagonals. */
+
+ temp1 = 0.f;
+ result[4] = 0.f;
+ result[5] = 0.f;
+
+ i__3 = mn_1.mplusn;
+ for (j = 1; j <= i__3; ++j) {
+ ilabad = FALSE_;
+ i__4 = j;
+ i__5 = j + j * ai_dim1;
+ q__2.r = alpha[i__4].r - ai[i__5].r, q__2.i = alpha[
+ i__4].i - ai[i__5].i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ i__6 = j;
+ i__7 = j + j * bi_dim1;
+ q__4.r = beta[i__6].r - bi[i__7].r, q__4.i = beta[
+ i__6].i - bi[i__7].i;
+ q__3.r = q__4.r, q__3.i = q__4.i;
+/* Computing MAX */
+ i__8 = j;
+ i__9 = j + j * ai_dim1;
+ r__13 = smlnum, r__14 = (r__1 = alpha[i__8].r, dabs(
+ r__1)) + (r__2 = r_imag(&alpha[j]), dabs(r__2)
+ ), r__13 = max(r__13,r__14), r__14 = (r__3 =
+ ai[i__9].r, dabs(r__3)) + (r__4 = r_imag(&ai[
+ j + j * ai_dim1]), dabs(r__4));
+/* Computing MAX */
+ i__10 = j;
+ i__11 = j + j * bi_dim1;
+ r__15 = smlnum, r__16 = (r__5 = beta[i__10].r, dabs(
+ r__5)) + (r__6 = r_imag(&beta[j]), dabs(r__6))
+ , r__15 = max(r__15,r__16), r__16 = (r__7 =
+ bi[i__11].r, dabs(r__7)) + (r__8 = r_imag(&bi[
+ j + j * bi_dim1]), dabs(r__8));
+ temp2 = (((r__9 = q__1.r, dabs(r__9)) + (r__10 =
+ r_imag(&q__1), dabs(r__10))) / dmax(r__13,
+ r__14) + ((r__11 = q__3.r, dabs(r__11)) + (
+ r__12 = r_imag(&q__3), dabs(r__12))) / dmax(
+ r__15,r__16)) / ulp;
+ if (j < mn_1.mplusn) {
+ i__4 = j + 1 + j * ai_dim1;
+ if (ai[i__4].r != 0.f || ai[i__4].i != 0.f) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ }
+ if (j > 1) {
+ i__4 = j + (j - 1) * ai_dim1;
+ if (ai[i__4].r != 0.f || ai[i__4].i != 0.f) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ }
+ temp1 = dmax(temp1,temp2);
+ if (ilabad) {
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+/* L10: */
+ }
+ result[5] = temp1;
+ ntest += 2;
+
+/* Test (7) (if sorting worked) */
+
+ result[6] = 0.f;
+ if (linfo == mn_1.mplusn + 3) {
+ result[6] = ulpinv;
+ } else if (mm != mn_1.n) {
+ result[6] = ulpinv;
+ }
+ ++ntest;
+
+/* Test (8): compare the estimated value DIF and its */
+/* value. first, compute the exact DIF. */
+
+ result[7] = 0.f;
+ mn2 = mm * (mn_1.mplusn - mm) << 1;
+ if (ifunc >= 2 && mn2 <= *ncmax * *ncmax) {
+
+/* Note: for either following two cases, there are */
+/* almost same number of test cases fail the test. */
+
+ i__3 = mn_1.mplusn - mm;
+ clakf2_(&mm, &i__3, &ai[ai_offset], lda, &ai[mm + 1 +
+ (mm + 1) * ai_dim1], &bi[bi_offset], &bi[mm +
+ 1 + (mm + 1) * bi_dim1], &c__[c_offset], ldc);
+
+ i__3 = *lwork - 2;
+ cgesvd_("N", "N", &mn2, &mn2, &c__[c_offset], ldc, &s[
+ 1], &work[1], &c__1, &work[2], &c__1, &work[3]
+, &i__3, &rwork[1], info);
+ diftru = s[mn2];
+
+ if (difest[1] == 0.f) {
+ if (diftru > abnrm * ulp) {
+ result[7] = ulpinv;
+ }
+ } else if (diftru == 0.f) {
+ if (difest[1] > abnrm * ulp) {
+ result[7] = ulpinv;
+ }
+ } else if (diftru > thrsh2 * difest[1] || diftru *
+ thrsh2 < difest[1]) {
+/* Computing MAX */
+ r__1 = diftru / difest[1], r__2 = difest[1] /
+ diftru;
+ result[7] = dmax(r__1,r__2);
+ }
+ ++ntest;
+ }
+
+/* Test (9) */
+
+ result[8] = 0.f;
+ if (linfo == mn_1.mplusn + 2) {
+ if (diftru > abnrm * ulp) {
+ result[8] = ulpinv;
+ }
+ if (ifunc > 1 && difest[1] != 0.f) {
+ result[8] = ulpinv;
+ }
+ if (ifunc == 1 && pl[0] != 0.f) {
+ result[8] = ulpinv;
+ }
+ ++ntest;
+ }
+
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ for (j = 1; j <= 9; ++j) {
+ if (result[j - 1] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "CGX", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "unitary", (ftnlen)7);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ for (i__ = 1; i__ <= 4; ++i__) {
+ do_fio(&c__1, "'", (ftnlen)1);
+ }
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[j - 1] < 1e4f) {
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
+ real));
+ do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
+ real));
+ do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ }
+/* L20: */
+ }
+
+L30:
+ ;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+
+ goto L150;
+
+L70:
+
+/* Read in data from file to check accuracy of condition estimation */
+/* Read input data until N=0 */
+
+ nptknt = 0;
+
+L80:
+ io___39.ciunit = *nin;
+ i__1 = s_rsle(&io___39);
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer))
+ ;
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = e_rsle();
+ if (i__1 != 0) {
+ goto L140;
+ }
+ if (mn_1.mplusn == 0) {
+ goto L140;
+ }
+ io___40.ciunit = *nin;
+ i__1 = s_rsle(&io___40);
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.n, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = e_rsle();
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = mn_1.mplusn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___41.ciunit = *nin;
+ s_rsle(&io___41);
+ i__2 = mn_1.mplusn;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&ai[i__ + j * ai_dim1], (ftnlen)
+ sizeof(complex));
+ }
+ e_rsle();
+/* L90: */
+ }
+ i__1 = mn_1.mplusn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___42.ciunit = *nin;
+ s_rsle(&io___42);
+ i__2 = mn_1.mplusn;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&bi[i__ + j * bi_dim1], (ftnlen)
+ sizeof(complex));
+ }
+ e_rsle();
+/* L100: */
+ }
+ io___43.ciunit = *nin;
+ s_rsle(&io___43);
+ do_lio(&c__4, &c__1, (char *)&pltru, (ftnlen)sizeof(real));
+ do_lio(&c__4, &c__1, (char *)&diftru, (ftnlen)sizeof(real));
+ e_rsle();
+
+ ++nptknt;
+ mn_1.fs = TRUE_;
+ mn_1.k = 0;
+ mn_1.m = mn_1.mplusn - mn_1.n;
+
+ clacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &a[
+ a_offset], lda);
+ clacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &b[
+ b_offset], lda);
+
+/* Compute the Schur factorization while swaping the */
+/* m-by-m (1,1)-blocks with n-by-n (2,2)-blocks. */
+
+ cggesx_("V", "V", "S", (L_fp)clctsx_, "B", &mn_1.mplusn, &ai[ai_offset],
+ lda, &bi[bi_offset], lda, &mm, &alpha[1], &beta[1], &q[q_offset],
+ lda, &z__[z_offset], lda, pl, difest, &work[1], lwork, &rwork[1],
+ &iwork[1], liwork, &bwork[1], &linfo);
+
+ if (linfo != 0 && linfo != mn_1.mplusn + 2) {
+ result[0] = ulpinv;
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "CGGESX", (ftnlen)6);
+ do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L130;
+ }
+
+/* Compute the norm(A, B) */
+/* (should this be norm of (A,B) or (AI,BI)?) */
+
+ clacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &work[1],
+ &mn_1.mplusn);
+ clacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &work[
+ mn_1.mplusn * mn_1.mplusn + 1], &mn_1.mplusn);
+ i__1 = mn_1.mplusn << 1;
+ abnrm = clange_("Fro", &mn_1.mplusn, &i__1, &work[1], &mn_1.mplusn, &
+ rwork[1]);
+
+/* Do tests (1) to (4) */
+
+ cget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[ai_offset], lda, &q[
+ q_offset], lda, &z__[z_offset], lda, &work[1], &rwork[1], result);
+ cget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
+ q_offset], lda, &z__[z_offset], lda, &work[1], &rwork[1], &result[
+ 1]);
+ cget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
+ q_offset], lda, &q[q_offset], lda, &work[1], &rwork[1], &result[2]
+);
+ cget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &z__[
+ z_offset], lda, &z__[z_offset], lda, &work[1], &rwork[1], &result[
+ 3]);
+
+/* Do tests (5) and (6): check Schur form of A and compare */
+/* eigenvalues with diagonals. */
+
+ ntest = 6;
+ temp1 = 0.f;
+ result[4] = 0.f;
+ result[5] = 0.f;
+
+ i__1 = mn_1.mplusn;
+ for (j = 1; j <= i__1; ++j) {
+ ilabad = FALSE_;
+ i__2 = j;
+ i__3 = j + j * ai_dim1;
+ q__2.r = alpha[i__2].r - ai[i__3].r, q__2.i = alpha[i__2].i - ai[i__3]
+ .i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ i__4 = j;
+ i__5 = j + j * bi_dim1;
+ q__4.r = beta[i__4].r - bi[i__5].r, q__4.i = beta[i__4].i - bi[i__5]
+ .i;
+ q__3.r = q__4.r, q__3.i = q__4.i;
+/* Computing MAX */
+ i__6 = j;
+ i__7 = j + j * ai_dim1;
+ r__13 = smlnum, r__14 = (r__1 = alpha[i__6].r, dabs(r__1)) + (r__2 =
+ r_imag(&alpha[j]), dabs(r__2)), r__13 = max(r__13,r__14),
+ r__14 = (r__3 = ai[i__7].r, dabs(r__3)) + (r__4 = r_imag(&ai[
+ j + j * ai_dim1]), dabs(r__4));
+/* Computing MAX */
+ i__8 = j;
+ i__9 = j + j * bi_dim1;
+ r__15 = smlnum, r__16 = (r__5 = beta[i__8].r, dabs(r__5)) + (r__6 =
+ r_imag(&beta[j]), dabs(r__6)), r__15 = max(r__15,r__16),
+ r__16 = (r__7 = bi[i__9].r, dabs(r__7)) + (r__8 = r_imag(&bi[
+ j + j * bi_dim1]), dabs(r__8));
+ temp2 = (((r__9 = q__1.r, dabs(r__9)) + (r__10 = r_imag(&q__1), dabs(
+ r__10))) / dmax(r__13,r__14) + ((r__11 = q__3.r, dabs(r__11))
+ + (r__12 = r_imag(&q__3), dabs(r__12))) / dmax(r__15,r__16)) /
+ ulp;
+ if (j < mn_1.mplusn) {
+ i__2 = j + 1 + j * ai_dim1;
+ if (ai[i__2].r != 0.f || ai[i__2].i != 0.f) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ }
+ if (j > 1) {
+ i__2 = j + (j - 1) * ai_dim1;
+ if (ai[i__2].r != 0.f || ai[i__2].i != 0.f) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ }
+ temp1 = dmax(temp1,temp2);
+ if (ilabad) {
+ io___46.ciunit = *nout;
+ s_wsfe(&io___46);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L110: */
+ }
+ result[5] = temp1;
+
+/* Test (7) (if sorting worked) <--------- need to be checked. */
+
+ ntest = 7;
+ result[6] = 0.f;
+ if (linfo == mn_1.mplusn + 3) {
+ result[6] = ulpinv;
+ }
+
+/* Test (8): compare the estimated value of DIF and its true value. */
+
+ ntest = 8;
+ result[7] = 0.f;
+ if (difest[1] == 0.f) {
+ if (diftru > abnrm * ulp) {
+ result[7] = ulpinv;
+ }
+ } else if (diftru == 0.f) {
+ if (difest[1] > abnrm * ulp) {
+ result[7] = ulpinv;
+ }
+ } else if (diftru > thrsh2 * difest[1] || diftru * thrsh2 < difest[1]) {
+/* Computing MAX */
+ r__1 = diftru / difest[1], r__2 = difest[1] / diftru;
+ result[7] = dmax(r__1,r__2);
+ }
+
+/* Test (9) */
+
+ ntest = 9;
+ result[8] = 0.f;
+ if (linfo == mn_1.mplusn + 2) {
+ if (diftru > abnrm * ulp) {
+ result[8] = ulpinv;
+ }
+ if (ifunc > 1 && difest[1] != 0.f) {
+ result[8] = ulpinv;
+ }
+ if (ifunc == 1 && pl[0] != 0.f) {
+ result[8] = ulpinv;
+ }
+ }
+
+/* Test (10): compare the estimated value of PL and it true value. */
+
+ ntest = 10;
+ result[9] = 0.f;
+ if (pl[0] == 0.f) {
+ if (pltru > abnrm * ulp) {
+ result[9] = ulpinv;
+ }
+ } else if (pltru == 0.f) {
+ if (pl[0] > abnrm * ulp) {
+ result[9] = ulpinv;
+ }
+ } else if (pltru > *thresh * pl[0] || pltru * *thresh < pl[0]) {
+ result[9] = ulpinv;
+ }
+
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__1 = ntest;
+ for (j = 1; j <= i__1; ++j) {
+ if (result[j - 1] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___47.ciunit = *nout;
+ s_wsfe(&io___47);
+ do_fio(&c__1, "CGX", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___48.ciunit = *nout;
+ s_wsfe(&io___48);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___49.ciunit = *nout;
+ s_wsfe(&io___49);
+ do_fio(&c__1, "unitary", (ftnlen)7);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ for (i__ = 1; i__ <= 4; ++i__) {
+ do_fio(&c__1, "'", (ftnlen)1);
+ }
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[j - 1] < 1e4f) {
+ io___50.ciunit = *nout;
+ s_wsfe(&io___50);
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___51.ciunit = *nout;
+ s_wsfe(&io___51);
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ }
+
+/* L120: */
+ }
+
+L130:
+ goto L80;
+L140:
+
+L150:
+
+/* Summary */
+
+ alasvm_("CGX", nout, &nerrs, &ntestt, &c__0);
+
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+
+ return 0;
+
+
+
+
+
+
+
+
+/* End of CDRGSX */
+
+} /* cdrgsx_ */
diff --git a/TESTING/EIG/cdrgvx.c b/TESTING/EIG/cdrgvx.c
new file mode 100644
index 0000000..3878af4
--- /dev/null
+++ b/TESTING/EIG/cdrgvx.c
@@ -0,0 +1,979 @@
+/* cdrgvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static complex c_b11 = {1.f,0.f};
+static integer c__5 = 5;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+static integer c__3 = 3;
+static integer c__6 = 6;
+static integer c__4 = 4;
+
+/* Subroutine */ int cdrgvx_(integer *nsize, real *thresh, integer *nin,
+ integer *nout, complex *a, integer *lda, complex *b, complex *ai,
+ complex *bi, complex *alpha, complex *beta, complex *vl, complex *vr,
+ integer *ilo, integer *ihi, real *lscale, real *rscale, real *s, real
+ *stru, real *dif, real *diftru, complex *work, integer *lwork, real *
+ rwork, integer *iwork, integer *liwork, real *result, logical *bwork,
+ integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 CDRGVX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002)\002)";
+ static char fmt_9998[] = "(\002 CDRGVX: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
+ "i6,\002, IWA=\002,i5,\002, IWB=\002,i5,\002, IWX=\002,i5,\002, I"
+ "WY=\002,i5)";
+ static char fmt_9997[] = "(/1x,a3,\002 -- Complex Expert Eigenvalue/vect"
+ "or\002,\002 problem driver\002)";
+ static char fmt_9995[] = "(\002 Matrix types: \002,/)";
+ static char fmt_9994[] = "(\002 TYPE 1: Da is diagonal, Db is identity,"
+ " \002,/\002 A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1) \002,/"
+ "\002 YH and X are left and right eigenvectors. \002,/)";
+ static char fmt_9993[] = "(\002 TYPE 2: Da is quasi-diagonal, Db is iden"
+ "tity, \002,/\002 A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1)"
+ " \002,/\002 YH and X are left and right eigenvectors. \002,/)"
+ ;
+ static char fmt_9992[] = "(/\002 Tests performed: \002,/4x,\002 a is al"
+ "pha, b is beta, l is a left eigenvector, \002,/4x,\002 r is a ri"
+ "ght eigenvector and \002,a,\002 means \002,a,\002.\002,/\002 1 ="
+ " max | ( b A - a B )\002,a,\002 l | / const.\002,/\002 2 = max |"
+ " ( b A - a B ) r | / const.\002,/\002 3 = max ( Sest/Stru, Stru/"
+ "Sest ) \002,\002 over all eigenvalues\002,/\002 4 = max( DIFest/"
+ "DIFtru, DIFtru/DIFest ) \002,\002 over the 1st and 5th eigenvect"
+ "ors\002,/)";
+ static char fmt_9991[] = "(\002 Type=\002,i2,\002,\002,\002 IWA=\002,i2"
+ ",\002, IWB=\002,i2,\002, IWX=\002,i2,\002, IWY=\002,i2,\002, res"
+ "ult \002,i2,\002 is\002,0p,f8.2)";
+ static char fmt_9990[] = "(\002 Type=\002,i2,\002,\002,\002 IWA=\002,i2"
+ ",\002, IWB=\002,i2,\002, IWX=\002,i2,\002, IWY=\002,i2,\002, res"
+ "ult \002,i2,\002 is\002,1p,e10.3)";
+ static char fmt_9987[] = "(\002 CDRGVX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, Input example #\002,i2,\002"
+ ")\002)";
+ static char fmt_9986[] = "(\002 CDRGVX: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, Input Examp"
+ "le #\002,i2,\002)\002)";
+ static char fmt_9996[] = "(\002Input Example\002)";
+ static char fmt_9989[] = "(\002 Input example #\002,i2,\002, matrix orde"
+ "r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,0p,f8.2)";
+ static char fmt_9988[] = "(\002 Input example #\002,i2,\002, matrix orde"
+ "r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,1p,e10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, ai_dim1, ai_offset, b_dim1, b_offset, bi_dim1,
+ bi_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2;
+ real r__1, r__2, r__3, r__4;
+ complex q__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ void c_div(complex *, complex *, complex *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+
+ /* Local variables */
+ integer i__, j, n, iwa, iwb;
+ real ulp;
+ integer iwx, iwy, nmax;
+ extern /* Subroutine */ int cget52_(logical *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ complex *, complex *, real *, real *);
+ integer linfo;
+ real anorm, bnorm;
+ integer nerrs;
+ extern /* Subroutine */ int clatm6_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, complex *, complex *, real *, real *);
+ real ratio1, ratio2, thrsh2;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), xerbla_(char *,
+ integer *);
+ real abnorm;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *), cggevx_(char *, char *, char *, char *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ complex *, complex *, integer *, complex *, integer *, integer *,
+ integer *, real *, real *, real *, real *, real *, real *,
+ complex *, integer *, real *, integer *, logical *, integer *);
+ complex weight[5];
+ integer minwrk, maxwrk, iptype;
+ real ulpinv;
+ integer nptknt, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___20 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___35 = { 0, 0, 1, 0, 0 };
+ static cilist io___36 = { 0, 0, 0, 0, 0 };
+ static cilist io___37 = { 0, 0, 0, 0, 0 };
+ static cilist io___38 = { 0, 0, 0, 0, 0 };
+ static cilist io___39 = { 0, 0, 0, 0, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9987, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9986, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9986, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9988, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRGVX checks the nonsymmetric generalized eigenvalue problem */
+/* expert driver CGGEVX. */
+
+/* CGGEVX computes the generalized eigenvalues, (optionally) the left */
+/* and/or right eigenvectors, (optionally) computes a balancing */
+/* transformation to improve the conditioning, and (optionally) */
+/* reciprocal condition numbers for the eigenvalues and eigenvectors. */
+
+/* When CDRGVX is called with NSIZE > 0, two types of test matrix pairs */
+/* are generated by the subroutine SLATM6 and test the driver CGGEVX. */
+/* The test matrices have the known exact condition numbers for */
+/* eigenvalues. For the condition numbers of the eigenvectors */
+/* corresponding the first and last eigenvalues are also know */
+/* ``exactly'' (see CLATM6). */
+/* For each matrix pair, the following tests will be performed and */
+/* compared with the threshhold THRESH. */
+
+/* (1) max over all left eigenvalue/-vector pairs (beta/alpha,l) of */
+
+/* | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) ) */
+
+/* where l**H is the conjugate tranpose of l. */
+
+/* (2) max over all right eigenvalue/-vector pairs (beta/alpha,r) of */
+
+/* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) ) */
+
+/* (3) The condition number S(i) of eigenvalues computed by CGGEVX */
+/* differs less than a factor THRESH from the exact S(i) (see */
+/* CLATM6). */
+
+/* (4) DIF(i) computed by CTGSNA differs less than a factor 10*THRESH */
+/* from the exact value (for the 1st and 5th vectors only). */
+
+/* Test Matrices */
+/* ============= */
+
+/* Two kinds of test matrix pairs */
+/* (A, B) = inverse(YH) * (Da, Db) * inverse(X) */
+/* are used in the tests: */
+
+/* 1: Da = 1+a 0 0 0 0 Db = 1 0 0 0 0 */
+/* 0 2+a 0 0 0 0 1 0 0 0 */
+/* 0 0 3+a 0 0 0 0 1 0 0 */
+/* 0 0 0 4+a 0 0 0 0 1 0 */
+/* 0 0 0 0 5+a , 0 0 0 0 1 , and */
+
+/* 2: Da = 1 -1 0 0 0 Db = 1 0 0 0 0 */
+/* 1 1 0 0 0 0 1 0 0 0 */
+/* 0 0 1 0 0 0 0 1 0 0 */
+/* 0 0 0 1+a 1+b 0 0 0 1 0 */
+/* 0 0 0 -1-b 1+a , 0 0 0 0 1 . */
+
+/* In both cases the same inverse(YH) and inverse(X) are used to compute */
+/* (A, B), giving the exact eigenvectors to (A,B) as (YH, X): */
+
+/* YH: = 1 0 -y y -y X = 1 0 -x -x x */
+/* 0 1 -y y -y 0 1 x -x -x */
+/* 0 0 1 0 0 0 0 1 0 0 */
+/* 0 0 0 1 0 0 0 0 1 0 */
+/* 0 0 0 0 1, 0 0 0 0 1 , where */
+
+/* a, b, x and y will have all values independently of each other from */
+/* { sqrt(sqrt(ULP)), 0.1, 1, 10, 1/sqrt(sqrt(ULP)) }. */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZE (input) INTEGER */
+/* The number of sizes of matrices to use. NSIZE must be at */
+/* least zero. If it is zero, no randomly generated matrices */
+/* are tested, but any test matrices read from NIN will be */
+/* tested. If it is not zero, then N = 5. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NIN (input) INTEGER */
+/* The FORTRAN unit number for reading in the data file of */
+/* problems to solve. */
+
+/* NOUT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (workspace) COMPLEX array, dimension (LDA, NSIZE) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, AI, BI, Ao, and Bo. */
+/* It must be at least 1 and at least NSIZE. */
+
+/* B (workspace) COMPLEX array, dimension (LDA, NSIZE) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, B contains the last matrix actually used. */
+
+/* AI (workspace) COMPLEX array, dimension (LDA, NSIZE) */
+/* Copy of A, modified by CGGEVX. */
+
+/* BI (workspace) COMPLEX array, dimension (LDA, NSIZE) */
+/* Copy of B, modified by CGGEVX. */
+
+/* ALPHA (workspace) COMPLEX array, dimension (NSIZE) */
+/* BETA (workspace) COMPLEX array, dimension (NSIZE) */
+/* On exit, ALPHA/BETA are the eigenvalues. */
+
+/* VL (workspace) COMPLEX array, dimension (LDA, NSIZE) */
+/* VL holds the left eigenvectors computed by CGGEVX. */
+
+/* VR (workspace) COMPLEX array, dimension (LDA, NSIZE) */
+/* VR holds the right eigenvectors computed by CGGEVX. */
+
+/* ILO (output/workspace) INTEGER */
+
+/* IHI (output/workspace) INTEGER */
+
+/* LSCALE (output/workspace) REAL array, dimension (N) */
+
+/* RSCALE (output/workspace) REAL array, dimension (N) */
+
+/* S (output/workspace) REAL array, dimension (N) */
+
+/* STRU (output/workspace) REAL array, dimension (N) */
+
+/* DIF (output/workspace) REAL array, dimension (N) */
+
+/* DIFTRU (output/workspace) REAL array, dimension (N) */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* Leading dimension of WORK. LWORK >= 2*N*N + 2*N */
+
+/* RWORK (workspace) REAL array, dimension (6*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (LIWORK) */
+
+/* LIWORK (input) INTEGER */
+/* Leading dimension of IWORK. LIWORK >= N+2. */
+
+/* RESULT (output/workspace) REAL array, dimension (4) */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: A routine returned an error code. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ /* Parameter adjustments */
+ vr_dim1 = *lda;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ vl_dim1 = *lda;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ bi_dim1 = *lda;
+ bi_offset = 1 + bi_dim1;
+ bi -= bi_offset;
+ ai_dim1 = *lda;
+ ai_offset = 1 + ai_dim1;
+ ai -= ai_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --alpha;
+ --beta;
+ --lscale;
+ --rscale;
+ --s;
+ --stru;
+ --dif;
+ --diftru;
+ --work;
+ --rwork;
+ --iwork;
+ --result;
+ --bwork;
+
+ /* Function Body */
+ *info = 0;
+
+ nmax = 5;
+
+ if (*nsize < 0) {
+ *info = -1;
+ } else if (*thresh < 0.f) {
+ *info = -2;
+ } else if (*nin <= 0) {
+ *info = -3;
+ } else if (*nout <= 0) {
+ *info = -4;
+ } else if (*lda < 1 || *lda < nmax) {
+ *info = -6;
+ } else if (*liwork < nmax + 2) {
+ *info = -26;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ minwrk = 1;
+ if (*info == 0 && *lwork >= 1) {
+ minwrk = (nmax << 1) * (nmax + 1);
+ maxwrk = nmax * (ilaenv_(&c__1, "CGEQRF", " ", &nmax, &c__1, &nmax, &
+ c__0) + 1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (nmax << 1) * (nmax + 1);
+ maxwrk = max(i__1,i__2);
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+ }
+
+ if (*lwork < minwrk) {
+ *info = -23;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CDRGVX", &i__1);
+ return 0;
+ }
+
+ n = 5;
+ ulp = slamch_("P");
+ ulpinv = 1.f / ulp;
+ thrsh2 = *thresh * 10.f;
+ nerrs = 0;
+ nptknt = 0;
+ ntestt = 0;
+
+ if (*nsize == 0) {
+ goto L90;
+ }
+
+/* Parameters used for generating test matrices. */
+
+ r__1 = sqrt(sqrt(ulp));
+ q__1.r = r__1, q__1.i = 0.f;
+ weight[0].r = q__1.r, weight[0].i = q__1.i;
+ weight[1].r = .1f, weight[1].i = 0.f;
+ weight[2].r = 1.f, weight[2].i = 0.f;
+ c_div(&q__1, &c_b11, &weight[1]);
+ weight[3].r = q__1.r, weight[3].i = q__1.i;
+ c_div(&q__1, &c_b11, weight);
+ weight[4].r = q__1.r, weight[4].i = q__1.i;
+
+ for (iptype = 1; iptype <= 2; ++iptype) {
+ for (iwa = 1; iwa <= 5; ++iwa) {
+ for (iwb = 1; iwb <= 5; ++iwb) {
+ for (iwx = 1; iwx <= 5; ++iwx) {
+ for (iwy = 1; iwy <= 5; ++iwy) {
+
+/* generated a pair of test matrix */
+
+ clatm6_(&iptype, &c__5, &a[a_offset], lda, &b[
+ b_offset], &vr[vr_offset], lda, &vl[vl_offset]
+, lda, &weight[iwa - 1], &weight[iwb - 1], &
+ weight[iwx - 1], &weight[iwy - 1], &stru[1], &
+ diftru[1]);
+
+/* Compute eigenvalues/eigenvectors of (A, B). */
+/* Compute eigenvalue/eigenvector condition numbers */
+/* using computed eigenvectors. */
+
+ clacpy_("F", &n, &n, &a[a_offset], lda, &ai[ai_offset]
+, lda);
+ clacpy_("F", &n, &n, &b[b_offset], lda, &bi[bi_offset]
+, lda);
+
+ cggevx_("N", "V", "V", "B", &n, &ai[ai_offset], lda, &
+ bi[bi_offset], lda, &alpha[1], &beta[1], &vl[
+ vl_offset], lda, &vr[vr_offset], lda, ilo,
+ ihi, &lscale[1], &rscale[1], &anorm, &bnorm, &
+ s[1], &dif[1], &work[1], lwork, &rwork[1], &
+ iwork[1], &bwork[1], &linfo);
+ if (linfo != 0) {
+ io___20.ciunit = *nout;
+ s_wsfe(&io___20);
+ do_fio(&c__1, "CGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ goto L30;
+ }
+
+/* Compute the norm(A, B) */
+
+ clacpy_("Full", &n, &n, &ai[ai_offset], lda, &work[1],
+ &n);
+ clacpy_("Full", &n, &n, &bi[bi_offset], lda, &work[n *
+ n + 1], &n);
+ i__1 = n << 1;
+ abnorm = clange_("Fro", &n, &i__1, &work[1], &n, &
+ rwork[1]);
+
+/* Tests (1) and (2) */
+
+ result[1] = 0.f;
+ cget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset],
+ lda, &vl[vl_offset], lda, &alpha[1], &beta[1],
+ &work[1], &rwork[1], &result[1]);
+ if (result[2] > *thresh) {
+ io___22.ciunit = *nout;
+ s_wsfe(&io___22);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "CGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(
+ real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+
+ result[2] = 0.f;
+ cget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset],
+ lda, &vr[vr_offset], lda, &alpha[1], &beta[1]
+, &work[1], &rwork[1], &result[2]);
+ if (result[3] > *thresh) {
+ io___23.ciunit = *nout;
+ s_wsfe(&io___23);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "CGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[3], (ftnlen)sizeof(
+ real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+
+/* Test (3) */
+
+ result[3] = 0.f;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] == 0.f) {
+ if (stru[i__] > abnorm * ulp) {
+ result[3] = ulpinv;
+ }
+ } else if (stru[i__] == 0.f) {
+ if (s[i__] > abnorm * ulp) {
+ result[3] = ulpinv;
+ }
+ } else {
+/* Computing MAX */
+ r__3 = (r__1 = stru[i__] / s[i__], dabs(r__1))
+ , r__4 = (r__2 = s[i__] / stru[i__],
+ dabs(r__2));
+ rwork[i__] = dmax(r__3,r__4);
+/* Computing MAX */
+ r__1 = result[3], r__2 = rwork[i__];
+ result[3] = dmax(r__1,r__2);
+ }
+/* L10: */
+ }
+
+/* Test (4) */
+
+ result[4] = 0.f;
+ if (dif[1] == 0.f) {
+ if (diftru[1] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (diftru[1] == 0.f) {
+ if (dif[1] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (dif[5] == 0.f) {
+ if (diftru[5] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (diftru[5] == 0.f) {
+ if (dif[5] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else {
+/* Computing MAX */
+ r__3 = (r__1 = diftru[1] / dif[1], dabs(r__1)),
+ r__4 = (r__2 = dif[1] / diftru[1], dabs(
+ r__2));
+ ratio1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__3 = (r__1 = diftru[5] / dif[5], dabs(r__1)),
+ r__4 = (r__2 = dif[5] / diftru[5], dabs(
+ r__2));
+ ratio2 = dmax(r__3,r__4);
+ result[4] = dmax(ratio1,ratio2);
+ }
+
+ ntestt += 4;
+
+/* Print out tests which fail. */
+
+ for (j = 1; j <= 4; ++j) {
+ if (result[j] >= thrsh2 && j >= 4 || result[j] >=
+ *thresh && j <= 3) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___28.ciunit = *nout;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "CXV", (ftnlen)3);
+ e_wsfe();
+
+/* Print out messages for built-in examples */
+
+/* Matrix types */
+
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ e_wsfe();
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ e_wsfe();
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ do_fio(&c__1, "'", (ftnlen)1);
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[j] < 1e4f) {
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&iptype, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwa, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwb, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwx, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwy, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, (char *)&iptype, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwa, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwb, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwx, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwy, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ }
+/* L20: */
+ }
+
+L30:
+
+/* L40: */
+ ;
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+
+ goto L150;
+
+L90:
+
+/* Read in data from file to check accuracy of condition estimation */
+/* Read input data until N=0 */
+
+ io___35.ciunit = *nin;
+ i__1 = s_rsle(&io___35);
+ if (i__1 != 0) {
+ goto L150;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L150;
+ }
+ i__1 = e_rsle();
+ if (i__1 != 0) {
+ goto L150;
+ }
+ if (n == 0) {
+ goto L150;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___36.ciunit = *nin;
+ s_rsle(&io___36);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
+ complex));
+ }
+ e_rsle();
+/* L100: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___37.ciunit = *nin;
+ s_rsle(&io___37);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&b[i__ + j * b_dim1], (ftnlen)sizeof(
+ complex));
+ }
+ e_rsle();
+/* L110: */
+ }
+ io___38.ciunit = *nin;
+ s_rsle(&io___38);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__4, &c__1, (char *)&stru[i__], (ftnlen)sizeof(real));
+ }
+ e_rsle();
+ io___39.ciunit = *nin;
+ s_rsle(&io___39);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__4, &c__1, (char *)&diftru[i__], (ftnlen)sizeof(real));
+ }
+ e_rsle();
+
+ ++nptknt;
+
+/* Compute eigenvalues/eigenvectors of (A, B). */
+/* Compute eigenvalue/eigenvector condition numbers */
+/* using computed eigenvectors. */
+
+ clacpy_("F", &n, &n, &a[a_offset], lda, &ai[ai_offset], lda);
+ clacpy_("F", &n, &n, &b[b_offset], lda, &bi[bi_offset], lda);
+
+ cggevx_("N", "V", "V", "B", &n, &ai[ai_offset], lda, &bi[bi_offset], lda,
+ &alpha[1], &beta[1], &vl[vl_offset], lda, &vr[vr_offset], lda,
+ ilo, ihi, &lscale[1], &rscale[1], &anorm, &bnorm, &s[1], &dif[1],
+ &work[1], lwork, &rwork[1], &iwork[1], &bwork[1], &linfo);
+
+ if (linfo != 0) {
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "CGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L140;
+ }
+
+/* Compute the norm(A, B) */
+
+ clacpy_("Full", &n, &n, &ai[ai_offset], lda, &work[1], &n);
+ clacpy_("Full", &n, &n, &bi[bi_offset], lda, &work[n * n + 1], &n);
+ i__1 = n << 1;
+ abnorm = clange_("Fro", &n, &i__1, &work[1], &n, &rwork[1]);
+
+/* Tests (1) and (2) */
+
+ result[1] = 0.f;
+ cget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &vl[vl_offset],
+ lda, &alpha[1], &beta[1], &work[1], &rwork[1], &result[1]);
+ if (result[2] > *thresh) {
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "CGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ result[2] = 0.f;
+ cget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &vr[vr_offset]
+, lda, &alpha[1], &beta[1], &work[1], &rwork[1], &result[2]);
+ if (result[3] > *thresh) {
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "CGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[3], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Test (3) */
+
+ result[3] = 0.f;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] == 0.f) {
+ if (stru[i__] > abnorm * ulp) {
+ result[3] = ulpinv;
+ }
+ } else if (stru[i__] == 0.f) {
+ if (s[i__] > abnorm * ulp) {
+ result[3] = ulpinv;
+ }
+ } else {
+/* Computing MAX */
+ r__3 = (r__1 = stru[i__] / s[i__], dabs(r__1)), r__4 = (r__2 = s[
+ i__] / stru[i__], dabs(r__2));
+ rwork[i__] = dmax(r__3,r__4);
+/* Computing MAX */
+ r__1 = result[3], r__2 = rwork[i__];
+ result[3] = dmax(r__1,r__2);
+ }
+/* L120: */
+ }
+
+/* Test (4) */
+
+ result[4] = 0.f;
+ if (dif[1] == 0.f) {
+ if (diftru[1] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (diftru[1] == 0.f) {
+ if (dif[1] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (dif[5] == 0.f) {
+ if (diftru[5] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (diftru[5] == 0.f) {
+ if (dif[5] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else {
+/* Computing MAX */
+ r__3 = (r__1 = diftru[1] / dif[1], dabs(r__1)), r__4 = (r__2 = dif[1]
+ / diftru[1], dabs(r__2));
+ ratio1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__3 = (r__1 = diftru[5] / dif[5], dabs(r__1)), r__4 = (r__2 = dif[5]
+ / diftru[5], dabs(r__2));
+ ratio2 = dmax(r__3,r__4);
+ result[4] = dmax(ratio1,ratio2);
+ }
+
+ ntestt += 4;
+
+/* Print out tests which fail. */
+
+ for (j = 1; j <= 4; ++j) {
+ if (result[j] >= thrsh2) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___43.ciunit = *nout;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "CXV", (ftnlen)3);
+ e_wsfe();
+
+/* Print out messages for built-in examples */
+
+/* Matrix types */
+
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ do_fio(&c__1, "'", (ftnlen)1);
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[j] < 1e4f) {
+ io___46.ciunit = *nout;
+ s_wsfe(&io___46);
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___47.ciunit = *nout;
+ s_wsfe(&io___47);
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ }
+/* L130: */
+ }
+
+L140:
+
+ goto L90;
+L150:
+
+/* Summary */
+
+ alasvm_("CXV", nout, &nerrs, &ntestt, &c__0);
+
+ work[1].r = (real) maxwrk, work[1].i = 0.f;
+
+ return 0;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+/* End of CDRGVX */
+
+} /* cdrgvx_ */
diff --git a/TESTING/EIG/cdrvbd.c b/TESTING/EIG/cdrvbd.c
new file mode 100644
index 0000000..61e1cdc
--- /dev/null
+++ b/TESTING/EIG/cdrvbd.c
@@ -0,0 +1,969 @@
+/* cdrvbd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__4 = 4;
+static integer c__1 = 1;
+static integer c__0 = 0;
+
+/* Subroutine */ int cdrvbd_(integer *nsizes, integer *mm, integer *nn,
+ integer *ntypes, logical *dotype, integer *iseed, real *thresh,
+ complex *a, integer *lda, complex *u, integer *ldu, complex *vt,
+ integer *ldvt, complex *asav, complex *usav, complex *vtsav, real *s,
+ real *ssav, real *e, complex *work, integer *lwork, real *rwork,
+ integer *iwork, integer *nounit, integer *info)
+{
+ /* Initialized data */
+
+ static char cjob[1*4] = "N" "O" "S" "A";
+
+ /* Format strings */
+ static char fmt_9996[] = "(\002 CDRVBD: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002M=\002,i6,\002, N=\002,i6,\002, JTYPE=\002,i"
+ "6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9995[] = "(\002 CDRVBD: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002M=\002,i6,\002, N=\002,i6,\002, JTYPE=\002,i"
+ "6,\002, LSWORK=\002,i6,/9x,\002ISEED=(\002,3(i5,\002,\002),i5"
+ ",\002)\002)";
+ static char fmt_9999[] = "(\002 SVD -- Complex Singular Value Decomposit"
+ "ion Driver \002,/\002 Matrix types (see CDRVBD for details):\002"
+ ",//\002 1 = Zero matrix\002,/\002 2 = Identity matrix\002,/\002 "
+ "3 = Evenly spaced singular values near 1\002,/\002 4 = Evenly sp"
+ "aced singular values near underflow\002,/\002 5 = Evenly spaced "
+ "singular values near overflow\002,//\002 Tests performed: ( A is"
+ " dense, U and V are unitary,\002,/19x,\002 S is an array, and Up"
+ "artial, VTpartial, and\002,/19x,\002 Spartial are partially comp"
+ "uted U, VT and S),\002,/)";
+ static char fmt_9998[] = "(\002 Tests performed with Test Threshold ="
+ " \002,f8.2,/\002 CGESVD: \002,/\002 1 = | A - U diag(S) VT | / ("
+ " |A| max(M,N) ulp ) \002,/\002 2 = | I - U**T U | / ( M ulp )"
+ " \002,/\002 3 = | I - VT VT**T | / ( N ulp ) \002,/\002 4 = 0 if"
+ " S contains min(M,N) nonnegative values in\002,\002 decreasing o"
+ "rder, else 1/ulp\002,/\002 5 = | U - Upartial | / ( M ulp )\002,/"
+ "\002 6 = | VT - VTpartial | / ( N ulp )\002,/\002 7 = | S - Spar"
+ "tial | / ( min(M,N) ulp |S| )\002,/\002 CGESDD: \002,/\002 8 = |"
+ " A - U diag(S) VT | / ( |A| max(M,N) ulp ) \002,/\002 9 = | I - "
+ "U**T U | / ( M ulp ) \002,/\00210 = | I - VT VT**T | / ( N ulp ) "
+ "\002,/\00211 = 0 if S contains min(M,N) nonnegative values in"
+ "\002,\002 decreasing order, else 1/ulp\002,/\00212 = | U - Upart"
+ "ial | / ( M ulp )\002,/\00213 = | VT - VTpartial | / ( N ulp "
+ ")\002,/\00214 = | S - Spartial | / ( min(M,N) ulp |S| )\002,//)";
+ static char fmt_9997[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, type "
+ "\002,i1,\002, IWS=\002,i1,\002, seed=\002,4(i4,\002,\002),\002 t"
+ "est(\002,i1,\002)=\002,g11.4)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, asav_dim1, asav_offset, u_dim1, u_offset,
+ usav_dim1, usav_offset, vt_dim1, vt_offset, vtsav_dim1,
+ vtsav_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
+ i__9, i__10, i__11, i__12, i__13, i__14;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, m, n;
+ real dif, div;
+ integer ijq, iju;
+ real ulp;
+ char jobq[1], jobu[1];
+ integer mmax, nmax;
+ real unfl, ovfl;
+ integer ijvt;
+ extern /* Subroutine */ int cbdt01_(integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, real *, real *,
+ complex *, integer *, complex *, real *, real *);
+ logical badmm, badnn;
+ integer nfail, iinfo;
+ extern /* Subroutine */ int cunt01_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, real *, real *);
+ real anorm;
+ extern /* Subroutine */ int cunt03_(char *, integer *, integer *, integer
+ *, integer *, complex *, integer *, complex *, integer *, complex
+ *, integer *, real *, real *, integer *);
+ integer mnmin, mnmax;
+ char jobvt[1];
+ integer iwspc, jsize, nerrs, jtype, ntest, iwtmp;
+ extern /* Subroutine */ int cgesdd_(char *, integer *, integer *, complex
+ *, integer *, real *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int cgesvd_(char *, char *, integer *, integer *,
+ complex *, integer *, real *, complex *, integer *, complex *,
+ integer *, complex *, integer *, real *, integer *), clacpy_(char *, integer *, integer *, complex *, integer
+ *, complex *, integer *), claset_(char *, integer *,
+ integer *, complex *, complex *, complex *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int xerbla_(char *, integer *), alasvm_(
+ char *, integer *, integer *, integer *, integer *),
+ clatms_(integer *, integer *, char *, integer *, char *, real *,
+ integer *, real *, real *, integer *, integer *, char *, complex *
+, integer *, complex *, integer *);
+ integer ntestf, minwrk;
+ real ulpinv, result[14];
+ integer lswork, mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___27 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVBD checks the singular value decomposition (SVD) driver CGESVD */
+/* and CGESDD. */
+/* CGESVD and CGESDD factors A = U diag(S) VT, where U and VT are */
+/* unitary and diag(S) is diagonal with the entries of the array S on */
+/* its diagonal. The entries of S are the singular values, nonnegative */
+/* and stored in decreasing order. U and VT can be optionally not */
+/* computed, overwritten on A, or computed partially. */
+
+/* A is M by N. Let MNMIN = min( M, N ). S has dimension MNMIN. */
+/* U can be M by M or M by MNMIN. VT can be N by N or MNMIN by N. */
+
+/* When CDRVBD is called, a number of matrix "sizes" (M's and N's) */
+/* and a number of matrix "types" are specified. For each size (M,N) */
+/* and each type of matrix, and for the minimal workspace as well as */
+/* workspace adequate to permit blocking, an M x N matrix "A" will be */
+/* generated and used to test the SVD routines. For each matrix, A will */
+/* be factored as A = U diag(S) VT and the following 12 tests computed: */
+
+/* Test for CGESVD: */
+
+/* (1) | A - U diag(S) VT | / ( |A| max(M,N) ulp ) */
+
+/* (2) | I - U'U | / ( M ulp ) */
+
+/* (3) | I - VT VT' | / ( N ulp ) */
+
+/* (4) S contains MNMIN nonnegative values in decreasing order. */
+/* (Return 0 if true, 1/ULP if false.) */
+
+/* (5) | U - Upartial | / ( M ulp ) where Upartial is a partially */
+/* computed U. */
+
+/* (6) | VT - VTpartial | / ( N ulp ) where VTpartial is a partially */
+/* computed VT. */
+
+/* (7) | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the */
+/* vector of singular values from the partial SVD */
+
+/* Test for CGESDD: */
+
+/* (1) | A - U diag(S) VT | / ( |A| max(M,N) ulp ) */
+
+/* (2) | I - U'U | / ( M ulp ) */
+
+/* (3) | I - VT VT' | / ( N ulp ) */
+
+/* (4) S contains MNMIN nonnegative values in decreasing order. */
+/* (Return 0 if true, 1/ULP if false.) */
+
+/* (5) | U - Upartial | / ( M ulp ) where Upartial is a partially */
+/* computed U. */
+
+/* (6) | VT - VTpartial | / ( N ulp ) where VTpartial is a partially */
+/* computed VT. */
+
+/* (7) | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the */
+/* vector of singular values from the partial SVD */
+
+/* The "sizes" are specified by the arrays MM(1:NSIZES) and */
+/* NN(1:NSIZES); the value of each element pair (MM(j),NN(j)) */
+/* specifies one size. The "types" are specified by a logical array */
+/* DOTYPE( 1:NTYPES ); if DOTYPE(j) is .TRUE., then matrix type "j" */
+/* will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A matrix of the form U D V, where U and V are unitary and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+/* (4) Same as (3), but multiplied by the underflow-threshold / ULP. */
+/* (5) Same as (3), but multiplied by the overflow-threshold * ULP. */
+
+/* Arguments */
+/* ========== */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* CDRVBD does nothing. It must be at least zero. */
+
+/* MM (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the matrix "heights" to be used. For */
+/* each j=1,...,NSIZES, if MM(j) is zero, then MM(j) and NN(j) */
+/* will be ignored. The MM(j) values must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the matrix "widths" to be used. For */
+/* each j=1,...,NSIZES, if NN(j) is zero, then MM(j) and NN(j) */
+/* will be ignored. The NN(j) values must be at least zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, CDRVBD */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrices are in A and B. */
+/* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size (m,n), a matrix */
+/* of type j will be generated. If NTYPES is smaller than the */
+/* maximum number of types defined (PARAMETER MAXTYP), then */
+/* types NTYPES+1 through MAXTYP will not be generated. If */
+/* NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through */
+/* DOTYPE(NTYPES) will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to CDRVBD to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (output) COMPLEX array, dimension (LDA,max(NN)) */
+/* Used to hold the matrix whose singular values are to be */
+/* computed. On exit, A contains the last matrix actually */
+/* used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at */
+/* least 1 and at least max( MM ). */
+
+/* U (output) COMPLEX array, dimension (LDU,max(MM)) */
+/* Used to hold the computed matrix of right singular vectors. */
+/* On exit, U contains the last such vectors actually computed. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. It must be at */
+/* least 1 and at least max( MM ). */
+
+/* VT (output) COMPLEX array, dimension (LDVT,max(NN)) */
+/* Used to hold the computed matrix of left singular vectors. */
+/* On exit, VT contains the last such vectors actually computed. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of VT. It must be at */
+/* least 1 and at least max( NN ). */
+
+/* ASAV (output) COMPLEX array, dimension (LDA,max(NN)) */
+/* Used to hold a different copy of the matrix whose singular */
+/* values are to be computed. On exit, A contains the last */
+/* matrix actually used. */
+
+/* USAV (output) COMPLEX array, dimension (LDU,max(MM)) */
+/* Used to hold a different copy of the computed matrix of */
+/* right singular vectors. On exit, USAV contains the last such */
+/* vectors actually computed. */
+
+/* VTSAV (output) COMPLEX array, dimension (LDVT,max(NN)) */
+/* Used to hold a different copy of the computed matrix of */
+/* left singular vectors. On exit, VTSAV contains the last such */
+/* vectors actually computed. */
+
+/* S (output) REAL array, dimension (max(min(MM,NN))) */
+/* Contains the computed singular values. */
+
+/* SSAV (output) REAL array, dimension (max(min(MM,NN))) */
+/* Contains another copy of the computed singular values. */
+
+/* E (output) REAL array, dimension (max(min(MM,NN))) */
+/* Workspace for CGESVD. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* MAX(3*MIN(M,N)+MAX(M,N)**2,5*MIN(M,N),3*MAX(M,N)) for all */
+/* pairs (M,N)=(MM(j),NN(j)) */
+
+/* RWORK (workspace) REAL array, */
+/* dimension ( 5*max(max(MM,NN)) ) */
+
+/* IWORK (workspace) INTEGER array, dimension at least 8*min(M,N) */
+
+/* RESULT (output) REAL array, dimension (7) */
+/* The values computed by the 7 tests described above. */
+/* The values are currently limited to 1/ULP, to avoid */
+/* overflow. */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some MM(j) < 0 */
+/* -3: Some NN(j) < 0 */
+/* -4: NTYPES < 0 */
+/* -7: THRESH < 0 */
+/* -10: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ). */
+/* -12: LDU < 1 or LDU < MMAX. */
+/* -14: LDVT < 1 or LDVT < NMAX, where NMAX is max( NN(j) ). */
+/* -21: LWORK too small. */
+/* If CLATMS, or CGESVD returns an error code, the */
+/* absolute value of it is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --mm;
+ --nn;
+ --dotype;
+ --iseed;
+ asav_dim1 = *lda;
+ asav_offset = 1 + asav_dim1;
+ asav -= asav_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ usav_dim1 = *ldu;
+ usav_offset = 1 + usav_dim1;
+ usav -= usav_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ vtsav_dim1 = *ldvt;
+ vtsav_offset = 1 + vtsav_dim1;
+ vtsav -= vtsav_offset;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --s;
+ --ssav;
+ --e;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+
+/* Important constants */
+
+ nerrs = 0;
+ ntestt = 0;
+ ntestf = 0;
+ badmm = FALSE_;
+ badnn = FALSE_;
+ mmax = 1;
+ nmax = 1;
+ mnmax = 1;
+ minwrk = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = mmax, i__3 = mm[j];
+ mmax = max(i__2,i__3);
+ if (mm[j] < 0) {
+ badmm = TRUE_;
+ }
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__4 = mm[j], i__5 = nn[j];
+ i__2 = mnmax, i__3 = min(i__4,i__5);
+ mnmax = max(i__2,i__3);
+/* Computing MAX */
+/* Computing MAX */
+/* Computing MIN */
+ i__6 = mm[j], i__7 = nn[j];
+/* Computing MAX */
+ i__9 = mm[j], i__10 = nn[j];
+/* Computing 2nd power */
+ i__8 = max(i__9,i__10);
+/* Computing MIN */
+ i__11 = mm[j], i__12 = nn[j];
+/* Computing MAX */
+ i__13 = mm[j], i__14 = nn[j];
+ i__4 = min(i__6,i__7) * 3 + i__8 * i__8, i__5 = min(i__11,i__12) * 5,
+ i__4 = max(i__4,i__5), i__5 = max(i__13,i__14) * 3;
+ i__2 = minwrk, i__3 = max(i__4,i__5);
+ minwrk = max(i__2,i__3);
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badmm) {
+ *info = -2;
+ } else if (badnn) {
+ *info = -3;
+ } else if (*ntypes < 0) {
+ *info = -4;
+ } else if (*lda < max(1,mmax)) {
+ *info = -10;
+ } else if (*ldu < max(1,mmax)) {
+ *info = -12;
+ } else if (*ldvt < max(1,nmax)) {
+ *info = -14;
+ } else if (minwrk > *lwork) {
+ *info = -21;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CDRVBD", &i__1);
+ return 0;
+ }
+
+/* Quick return if nothing to do */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = slamch_("S");
+ ovfl = 1.f / unfl;
+ ulp = slamch_("E");
+ ulpinv = 1.f / ulp;
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ m = mm[jsize];
+ n = nn[jsize];
+ mnmin = min(m,n);
+
+ if (*nsizes != 1) {
+ mtypes = min(5,*ntypes);
+ } else {
+ mtypes = min(6,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L170;
+ }
+ ntest = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Compute "A" */
+
+ if (mtypes > 5) {
+ goto L50;
+ }
+
+ if (jtype == 1) {
+
+/* Zero matrix */
+
+ claset_("Full", &m, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ i__3 = min(m,n);
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ s[i__] = 0.f;
+/* L30: */
+ }
+
+ } else if (jtype == 2) {
+
+/* Identity matrix */
+
+ claset_("Full", &m, &n, &c_b1, &c_b2, &a[a_offset], lda);
+ i__3 = min(m,n);
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ s[i__] = 1.f;
+/* L40: */
+ }
+
+ } else {
+
+/* (Scaled) random matrix */
+
+ if (jtype == 3) {
+ anorm = 1.f;
+ }
+ if (jtype == 4) {
+ anorm = unfl / ulp;
+ }
+ if (jtype == 5) {
+ anorm = ovfl * ulp;
+ }
+ r__1 = (real) mnmin;
+ i__3 = m - 1;
+ i__4 = n - 1;
+ clatms_(&m, &n, "U", &iseed[1], "N", &s[1], &c__4, &r__1, &
+ anorm, &i__3, &i__4, "N", &a[a_offset], lda, &work[1],
+ &iinfo);
+ if (iinfo != 0) {
+ io___27.ciunit = *nounit;
+ s_wsfe(&io___27);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+ }
+
+L50:
+ clacpy_("F", &m, &n, &a[a_offset], lda, &asav[asav_offset], lda);
+
+/* Do for minimal and adequate (for blocking) workspace */
+
+ for (iwspc = 1; iwspc <= 4; ++iwspc) {
+
+/* Test for CGESVD */
+
+ iwtmp = (min(m,n) << 1) + max(m,n);
+ lswork = iwtmp + (iwspc - 1) * (*lwork - iwtmp) / 3;
+ lswork = min(lswork,*lwork);
+ lswork = max(lswork,1);
+ if (iwspc == 4) {
+ lswork = *lwork;
+ }
+
+ for (j = 1; j <= 14; ++j) {
+ result[j - 1] = -1.f;
+/* L60: */
+ }
+
+/* Factorize A */
+
+ if (iwspc > 1) {
+ clacpy_("F", &m, &n, &asav[asav_offset], lda, &a[a_offset]
+, lda);
+ }
+ cgesvd_("A", "A", &m, &n, &a[a_offset], lda, &ssav[1], &usav[
+ usav_offset], ldu, &vtsav[vtsav_offset], ldvt, &work[
+ 1], &lswork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___32.ciunit = *nounit;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "GESVD", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lswork, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Do tests 1--4 */
+
+ cbdt01_(&m, &n, &c__0, &asav[asav_offset], lda, &usav[
+ usav_offset], ldu, &ssav[1], &e[1], &vtsav[
+ vtsav_offset], ldvt, &work[1], &rwork[1], result);
+ if (m != 0 && n != 0) {
+ cunt01_("Columns", &mnmin, &m, &usav[usav_offset], ldu, &
+ work[1], lwork, &rwork[1], &result[1]);
+ cunt01_("Rows", &mnmin, &n, &vtsav[vtsav_offset], ldvt, &
+ work[1], lwork, &rwork[1], &result[2]);
+ }
+ result[3] = 0.f;
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (ssav[i__] < ssav[i__ + 1]) {
+ result[3] = ulpinv;
+ }
+ if (ssav[i__] < 0.f) {
+ result[3] = ulpinv;
+ }
+/* L70: */
+ }
+ if (mnmin >= 1) {
+ if (ssav[mnmin] < 0.f) {
+ result[3] = ulpinv;
+ }
+ }
+
+/* Do partial SVDs, comparing to SSAV, USAV, and VTSAV */
+
+ result[4] = 0.f;
+ result[5] = 0.f;
+ result[6] = 0.f;
+ for (iju = 0; iju <= 3; ++iju) {
+ for (ijvt = 0; ijvt <= 3; ++ijvt) {
+ if (iju == 3 && ijvt == 3 || iju == 1 && ijvt == 1) {
+ goto L90;
+ }
+ *(unsigned char *)jobu = *(unsigned char *)&cjob[iju];
+ *(unsigned char *)jobvt = *(unsigned char *)&cjob[
+ ijvt];
+ clacpy_("F", &m, &n, &asav[asav_offset], lda, &a[
+ a_offset], lda);
+ cgesvd_(jobu, jobvt, &m, &n, &a[a_offset], lda, &s[1],
+ &u[u_offset], ldu, &vt[vt_offset], ldvt, &
+ work[1], &lswork, &rwork[1], &iinfo);
+
+/* Compare U */
+
+ dif = 0.f;
+ if (m > 0 && n > 0) {
+ if (iju == 1) {
+ cunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
+ usav_offset], ldu, &a[a_offset], lda,
+ &work[1], lwork, &rwork[1], &dif, &
+ iinfo);
+ } else if (iju == 2) {
+ cunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
+ usav_offset], ldu, &u[u_offset], ldu,
+ &work[1], lwork, &rwork[1], &dif, &
+ iinfo);
+ } else if (iju == 3) {
+ cunt03_("C", &m, &m, &m, &mnmin, &usav[
+ usav_offset], ldu, &u[u_offset], ldu,
+ &work[1], lwork, &rwork[1], &dif, &
+ iinfo);
+ }
+ }
+ result[4] = dmax(result[4],dif);
+
+/* Compare VT */
+
+ dif = 0.f;
+ if (m > 0 && n > 0) {
+ if (ijvt == 1) {
+ cunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &a[a_offset],
+ lda, &work[1], lwork, &rwork[1], &dif,
+ &iinfo);
+ } else if (ijvt == 2) {
+ cunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &vt[vt_offset],
+ ldvt, &work[1], lwork, &rwork[1], &
+ dif, &iinfo);
+ } else if (ijvt == 3) {
+ cunt03_("R", &n, &n, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &vt[vt_offset],
+ ldvt, &work[1], lwork, &rwork[1], &
+ dif, &iinfo);
+ }
+ }
+ result[5] = dmax(result[5],dif);
+
+/* Compare S */
+
+ dif = 0.f;
+/* Computing MAX */
+ r__1 = (real) mnmin * ulp * s[1], r__2 = slamch_(
+ "Safe minimum");
+ div = dmax(r__1,r__2);
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (ssav[i__] < ssav[i__ + 1]) {
+ dif = ulpinv;
+ }
+ if (ssav[i__] < 0.f) {
+ dif = ulpinv;
+ }
+/* Computing MAX */
+ r__2 = dif, r__3 = (r__1 = ssav[i__] - s[i__],
+ dabs(r__1)) / div;
+ dif = dmax(r__2,r__3);
+/* L80: */
+ }
+ result[6] = dmax(result[6],dif);
+L90:
+ ;
+ }
+/* L100: */
+ }
+
+/* Test for CGESDD */
+
+ iwtmp = (mnmin << 1) * mnmin + (mnmin << 1) + max(m,n);
+ lswork = iwtmp + (iwspc - 1) * (*lwork - iwtmp) / 3;
+ lswork = min(lswork,*lwork);
+ lswork = max(lswork,1);
+ if (iwspc == 4) {
+ lswork = *lwork;
+ }
+
+/* Factorize A */
+
+ clacpy_("F", &m, &n, &asav[asav_offset], lda, &a[a_offset],
+ lda);
+ cgesdd_("A", &m, &n, &a[a_offset], lda, &ssav[1], &usav[
+ usav_offset], ldu, &vtsav[vtsav_offset], ldvt, &work[
+ 1], &lswork, &rwork[1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___39.ciunit = *nounit;
+ s_wsfe(&io___39);
+ do_fio(&c__1, "GESDD", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lswork, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Do tests 1--4 */
+
+ cbdt01_(&m, &n, &c__0, &asav[asav_offset], lda, &usav[
+ usav_offset], ldu, &ssav[1], &e[1], &vtsav[
+ vtsav_offset], ldvt, &work[1], &rwork[1], &result[7]);
+ if (m != 0 && n != 0) {
+ cunt01_("Columns", &mnmin, &m, &usav[usav_offset], ldu, &
+ work[1], lwork, &rwork[1], &result[8]);
+ cunt01_("Rows", &mnmin, &n, &vtsav[vtsav_offset], ldvt, &
+ work[1], lwork, &rwork[1], &result[9]);
+ }
+ result[10] = 0.f;
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (ssav[i__] < ssav[i__ + 1]) {
+ result[10] = ulpinv;
+ }
+ if (ssav[i__] < 0.f) {
+ result[10] = ulpinv;
+ }
+/* L110: */
+ }
+ if (mnmin >= 1) {
+ if (ssav[mnmin] < 0.f) {
+ result[10] = ulpinv;
+ }
+ }
+
+/* Do partial SVDs, comparing to SSAV, USAV, and VTSAV */
+
+ result[11] = 0.f;
+ result[12] = 0.f;
+ result[13] = 0.f;
+ for (ijq = 0; ijq <= 2; ++ijq) {
+ *(unsigned char *)jobq = *(unsigned char *)&cjob[ijq];
+ clacpy_("F", &m, &n, &asav[asav_offset], lda, &a[a_offset]
+, lda);
+ cgesdd_(jobq, &m, &n, &a[a_offset], lda, &s[1], &u[
+ u_offset], ldu, &vt[vt_offset], ldvt, &work[1], &
+ lswork, &rwork[1], &iwork[1], &iinfo);
+
+/* Compare U */
+
+ dif = 0.f;
+ if (m > 0 && n > 0) {
+ if (ijq == 1) {
+ if (m >= n) {
+ cunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
+ usav_offset], ldu, &a[a_offset], lda,
+ &work[1], lwork, &rwork[1], &dif, &
+ iinfo);
+ } else {
+ cunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
+ usav_offset], ldu, &u[u_offset], ldu,
+ &work[1], lwork, &rwork[1], &dif, &
+ iinfo);
+ }
+ } else if (ijq == 2) {
+ cunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
+ usav_offset], ldu, &u[u_offset], ldu, &
+ work[1], lwork, &rwork[1], &dif, &iinfo);
+ }
+ }
+ result[11] = dmax(result[11],dif);
+
+/* Compare VT */
+
+ dif = 0.f;
+ if (m > 0 && n > 0) {
+ if (ijq == 1) {
+ if (m >= n) {
+ cunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &vt[vt_offset],
+ ldvt, &work[1], lwork, &rwork[1], &
+ dif, &iinfo);
+ } else {
+ cunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &a[a_offset],
+ lda, &work[1], lwork, &rwork[1], &dif,
+ &iinfo);
+ }
+ } else if (ijq == 2) {
+ cunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &vt[vt_offset], ldvt,
+ &work[1], lwork, &rwork[1], &dif, &iinfo);
+ }
+ }
+ result[12] = dmax(result[12],dif);
+
+/* Compare S */
+
+ dif = 0.f;
+/* Computing MAX */
+ r__1 = (real) mnmin * ulp * s[1], r__2 = slamch_("Safe m"
+ "inimum");
+ div = dmax(r__1,r__2);
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (ssav[i__] < ssav[i__ + 1]) {
+ dif = ulpinv;
+ }
+ if (ssav[i__] < 0.f) {
+ dif = ulpinv;
+ }
+/* Computing MAX */
+ r__2 = dif, r__3 = (r__1 = ssav[i__] - s[i__], dabs(
+ r__1)) / div;
+ dif = dmax(r__2,r__3);
+/* L120: */
+ }
+ result[13] = dmax(result[13],dif);
+/* L130: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 14; ++j) {
+ if (result[j - 1] >= 0.f) {
+ ++ntest;
+ }
+ if (result[j - 1] >= *thresh) {
+ ++nfail;
+ }
+/* L140: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ e_wsfe();
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
+ e_wsfe();
+ ntestf = 2;
+ }
+
+ for (j = 1; j <= 14; ++j) {
+ if (result[j - 1] >= *thresh) {
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iwspc, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ }
+/* L150: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+
+/* L160: */
+ }
+
+L170:
+ ;
+ }
+/* L180: */
+ }
+
+/* Summary */
+
+ alasvm_("CBD", nounit, &nerrs, &ntestt, &c__0);
+
+
+ return 0;
+
+/* End of CDRVBD */
+
+} /* cdrvbd_ */
diff --git a/TESTING/EIG/cdrves.c b/TESTING/EIG/cdrves.c
new file mode 100644
index 0000000..10ed402
--- /dev/null
+++ b/TESTING/EIG/cdrves.c
@@ -0,0 +1,1044 @@
+/* cdrves.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ real selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__0 = 0;
+static integer c__4 = 4;
+static integer c__6 = 6;
+static real c_b38 = 1.f;
+static integer c__1 = 1;
+static real c_b48 = 0.f;
+static integer c__2 = 2;
+
+/* Subroutine */ int cdrves_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, integer *nounit,
+ complex *a, integer *lda, complex *h__, complex *ht, complex *w,
+ complex *wt, complex *vs, integer *ldvs, real *result, complex *work,
+ integer *nwork, real *rwork, integer *iwork, logical *bwork, integer *
+ info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
+ static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
+ static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9992[] = "(\002 CDRVES: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(/1x,a3,\002 -- Complex Schur Form Decompositi"
+ "on Driver\002,/\002 Matrix types (see CDRVES for details): \002)";
+ static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 \002,\002 5=Diagonal: geom"
+ "etr. spaced entries.\002,/\002 2=Identity matrix. "
+ " \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
+ "/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
+ " 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
+ "l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
+ "ll, evenly spaced.\002)";
+ static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
+ " 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
+ "l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
+ "d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
+ "red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
+ "vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,a6,"
+ "/\002 12=Well-cond., random complex \002,a6,\002 \002,\002 17="
+ "Ill-cond., large rand. complx \002,a4,/\002 13=Ill-condi\002,"
+ "\002tioned, evenly spaced. \002,\002 18=Ill-cond., small ran"
+ "d.\002,\002 complx \002,a4)";
+ static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
+ " \002,\002 21=Matrix \002,\002with small random entries.\002,"
+ "/\002 20=Matrix with large ran\002,\002dom entries. \002,/)";
+ static char fmt_9995[] = "(\002 Tests performed with test threshold ="
+ "\002,f8.2,/\002 ( A denotes A on input and T denotes A on output)"
+ "\002,//\002 1 = 0 if T in Schur form (no sort), \002,\002 1/ulp"
+ " otherwise\002,/\002 2 = | A - VS T transpose(VS) | / ( n |A| ul"
+ "p ) (no sort)\002,/\002 3 = | I - VS transpose(VS) | / ( n ulp )"
+ " (no sort) \002,/\002 4 = 0 if W are eigenvalues of T (no sort)"
+ ",\002,\002 1/ulp otherwise\002,/\002 5 = 0 if T same no matter "
+ "if VS computed (no sort),\002,\002 1/ulp otherwise\002,/\002 6 "
+ "= 0 if W same no matter if VS computed (no sort)\002,\002, 1/ul"
+ "p otherwise\002)";
+ static char fmt_9994[] = "(\002 7 = 0 if T in Schur form (sort), \002"
+ ",\002 1/ulp otherwise\002,/\002 8 = | A - VS T transpose(VS) | "
+ "/ ( n |A| ulp ) (sort)\002,/\002 9 = | I - VS transpose(VS) | / "
+ "( n ulp ) (sort) \002,/\002 10 = 0 if W are eigenvalues of T (so"
+ "rt),\002,\002 1/ulp otherwise\002,/\002 11 = 0 if T same no mat"
+ "ter if VS computed (sort),\002,\002 1/ulp otherwise\002,/\002 1"
+ "2 = 0 if W same no matter if VS computed (sort),\002,\002 1/ulp"
+ " otherwise\002,/\002 13 = 0 if sorting succesful, 1/ulp otherwise"
+ "\002,/)";
+ static char fmt_9993[] = "(\002 N=\002,i5,\002, IWK=\002,i2,\002, seed"
+ "=\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)="
+ "\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, ht_dim1, ht_offset, vs_dim1,
+ vs_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ complex q__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, n;
+ real res[2];
+ integer iwk;
+ real ulp, cond;
+ integer jcol;
+ char path[3];
+ integer sdim, nmax;
+ real unfl, ovfl;
+ integer rsub;
+ char sort[1];
+ logical badnn;
+ extern /* Subroutine */ int cgees_(char *, char *, L_fp, integer *,
+ complex *, integer *, integer *, complex *, complex *, integer *,
+ complex *, integer *, real *, logical *, integer *);
+ integer nfail, imode;
+ extern /* Subroutine */ int chst01_(integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, real *);
+ integer iinfo;
+ real conds, anorm;
+ integer jsize, nerrs, itype, jtype, ntest, lwork, isort;
+ real rtulp;
+ extern /* Subroutine */ int slabad_(real *, real *), clatme_(integer *,
+ char *, integer *, complex *, integer *, real *, complex *, char *
+, char *, char *, char *, real *, integer *, real *, integer *,
+ integer *, real *, complex *, integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *);
+ integer idumma[1], ioldsd[4];
+ extern logical cslect_(complex *);
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *);
+ integer knteig;
+ extern /* Subroutine */ int clatmr_(integer *, integer *, char *, integer
+ *, char *, complex *, integer *, real *, complex *, char *, char *
+, complex *, integer *, real *, complex *, integer *, real *,
+ char *, integer *, integer *, integer *, real *, real *, char *,
+ complex *, integer *, integer *, integer *), clatms_(integer *, integer *,
+ char *, integer *, char *, real *, integer *, real *, real *,
+ integer *, integer *, char *, complex *, integer *, complex *,
+ integer *), xerbla_(char *, integer *);
+ integer ntestf;
+ extern /* Subroutine */ int slasum_(char *, integer *, integer *, integer
+ *);
+ real ulpinv;
+ integer nnwork;
+ real rtulpi;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___31 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVES checks the nonsymmetric eigenvalue (Schur form) problem */
+/* driver CGEES. */
+
+/* When CDRVES is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 13 */
+/* tests will be performed: */
+
+/* (1) 0 if T is in Schur form, 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (2) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (no sorting of eigenvalues). */
+
+/* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues). */
+
+/* (4) 0 if W are eigenvalues of T */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (5) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (7) 0 if T is in Schur form, 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (8) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (with sorting of eigenvalues). */
+
+/* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues). */
+
+/* (10) 0 if W are eigenvalues of T */
+/* 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (11) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (13) if sorting worked and SDIM is the number of */
+/* eigenvalues which were SELECTed */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
+
+/* (4) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random complex angles. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (5) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random complex angles. */
+/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random complex angles. */
+
+/* (7) Same as (4), but multiplied by a constant near */
+/* the overflow threshold */
+/* (8) Same as (4), but multiplied by a constant near */
+/* the underflow threshold */
+
+/* (9) A matrix of the form U' T U, where U is unitary and */
+/* T has evenly spaced entries 1, ..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (10) A matrix of the form U' T U, where U is unitary and */
+/* T has geometrically spaced entries 1, ..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (11) A matrix of the form U' T U, where U is orthogonal and */
+/* T has "clustered" entries 1, ULP,..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (12) A matrix of the form U' T U, where U is unitary and */
+/* T has complex eigenvalues randomly chosen from */
+/* ULP < |z| < 1 and random O(1) entries in the upper */
+/* triangle. */
+
+/* (13) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
+/* with random complex angles on the diagonal and random O(1) */
+/* entries in the upper triangle. */
+
+/* (14) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has geometrically spaced entries */
+/* 1, ..., ULP with random complex angles on the diagonal */
+/* and random O(1) entries in the upper triangle. */
+
+/* (15) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
+/* with random complex angles on the diagonal and random O(1) */
+/* entries in the upper triangle. */
+
+/* (16) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has complex eigenvalues randomly chosen */
+/* from ULP < |z| < 1 and random O(1) entries in the upper */
+/* triangle. */
+
+/* (17) Same as (16), but multiplied by a constant */
+/* near the overflow threshold */
+/* (18) Same as (16), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* (19) Nonsymmetric matrix with random entries chosen from (-1,1). */
+/* If N is at least 4, all entries in first two rows and last */
+/* row, and first column and last two columns are zero. */
+/* (20) Same as (19), but multiplied by a constant */
+/* near the overflow threshold */
+/* (21) Same as (19), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* CDRVES does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, CDRVES */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to CDRVES to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* A (workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, and H. LDA must be at */
+/* least 1 and at least max( NN ). */
+
+/* H (workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* Another copy of the test matrix A, modified by CGEES. */
+
+/* HT (workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* Yet another copy of the test matrix A, modified by CGEES. */
+
+/* W (workspace) COMPLEX array, dimension (max(NN)) */
+/* The computed eigenvalues of A. */
+
+/* WT (workspace) COMPLEX array, dimension (max(NN)) */
+/* Like W, this array contains the eigenvalues of A, */
+/* but those computed when CGEES only computes a partial */
+/* eigendecomposition, i.e. not Schur vectors */
+
+/* VS (workspace) COMPLEX array, dimension (LDVS, max(NN)) */
+/* VS holds the computed Schur vectors. */
+
+/* LDVS (input) INTEGER */
+/* Leading dimension of VS. Must be at least max(1,max(NN)). */
+
+/* RESULT (output) REAL array, dimension (13) */
+/* The values computed by the 13 tests described above. */
+/* The values are currently limited to 1/ulp, to avoid overflow. */
+
+/* WORK (workspace) COMPLEX array, dimension (NWORK) */
+
+/* NWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 5*NN(j)+2*NN(j)**2 for all j. */
+
+/* RWORK (workspace) REAL array, dimension (max(NN)) */
+
+/* IWORK (workspace) INTEGER array, dimension (max(NN)) */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -6: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -15: LDVS < 1 or LDVS < NMAX, where NMAX is max( NN(j) ). */
+/* -18: NWORK too small. */
+/* If CLATMR, CLATMS, CLATME or CGEES returns an error code, */
+/* the absolute value of it is returned. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NMAX Largest value in NN. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* COND, CONDS, */
+/* IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTULP, RTULPI Square roots of the previous 4 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+/* KCONDS(j) Select whether CONDS is to be 1 or */
+/* 1/sqrt(ulp). (0 means irrelevant.) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ ht_dim1 = *lda;
+ ht_offset = 1 + ht_dim1;
+ ht -= ht_offset;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ --wt;
+ vs_dim1 = *ldvs;
+ vs_offset = 1 + vs_dim1;
+ vs -= vs_offset;
+ --result;
+ --work;
+ --rwork;
+ --iwork;
+ --bwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "ES", (ftnlen)2, (ftnlen)2);
+
+/* Check for errors */
+
+ ntestt = 0;
+ ntestf = 0;
+ *info = 0;
+ sslct_1.selopt = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+ nmax = 0;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.f) {
+ *info = -6;
+ } else if (*nounit <= 0) {
+ *info = -7;
+ } else if (*lda < 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldvs < 1 || *ldvs < nmax) {
+ *info = -15;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = nmax;
+ if (nmax * 5 + (i__1 * i__1 << 1) > *nwork) {
+ *info = -18;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CDRVES", &i__1);
+ return 0;
+ }
+
+/* Quick return if nothing to do */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ slabad_(&unfl, &ovfl);
+ ulp = slamch_("Precision");
+ ulpinv = 1.f / ulp;
+ rtulp = sqrt(ulp);
+ rtulpi = 1.f / rtulp;
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L230;
+ }
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KCONDS KMODE KTYPE */
+/* =1 O(1) 1 clustered 1 zero */
+/* =2 large large clustered 2 identity */
+/* =3 small exponential Jordan */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random general, w/ eigenvalues */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 random general */
+/* =10 random triangular */
+
+ if (mtypes > 21) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L30;
+ case 2: goto L40;
+ case 3: goto L50;
+ }
+
+L30:
+ anorm = 1.f;
+ goto L60;
+
+L40:
+ anorm = ovfl * ulp;
+ goto L60;
+
+L50:
+ anorm = unfl * ulpinv;
+ goto L60;
+
+L60:
+
+ claset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+ if (itype == 1) {
+
+/* Zero */
+
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ q__1.r = anorm, q__1.i = 0.f;
+ a[i__4].r = q__1.r, a[i__4].i = q__1.i;
+/* L70: */
+ }
+
+ } else if (itype == 3) {
+
+/* Jordan Block */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ q__1.r = anorm, q__1.i = 0.f;
+ a[i__4].r = q__1.r, a[i__4].i = q__1.i;
+ if (jcol > 1) {
+ i__4 = jcol + (jcol - 1) * a_dim1;
+ a[i__4].r = 1.f, a[i__4].i = 0.f;
+ }
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[
+ n + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 6) {
+
+/* General, eigenvalues specified */
+
+ if (kconds[jtype - 1] == 1) {
+ conds = 1.f;
+ } else if (kconds[jtype - 1] == 2) {
+ conds = rtulpi;
+ } else {
+ conds = 0.f;
+ }
+
+ clatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2,
+ " ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n,
+ &anorm, &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
+ n << 1) + 1], &c__1, &c_b38, "N", idumma, &c__0, &
+ c__0, &c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ clatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b38,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
+ n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &n, &
+ c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* General, random eigenvalues */
+
+ clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
+ n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &n, &
+ c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+ if (n >= 4) {
+ claset_("Full", &c__2, &n, &c_b1, &c_b1, &a[a_offset],
+ lda);
+ i__3 = n - 3;
+ claset_("Full", &i__3, &c__1, &c_b1, &c_b1, &a[a_dim1 + 3]
+, lda);
+ i__3 = n - 3;
+ claset_("Full", &i__3, &c__2, &c_b1, &c_b1, &a[(n - 1) *
+ a_dim1 + 3], lda);
+ claset_("Full", &c__1, &n, &c_b1, &c_b1, &a[n + a_dim1],
+ lda);
+ }
+
+ } else if (itype == 10) {
+
+/* Triangular, random eigenvalues */
+
+ clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
+ n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &c__0, &
+ c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___31.ciunit = *nounit;
+ s_wsfe(&io___31);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+/* Test for minimal and generous workspace */
+
+ for (iwk = 1; iwk <= 2; ++iwk) {
+ if (iwk == 1) {
+ nnwork = n * 3;
+ } else {
+/* Computing 2nd power */
+ i__3 = n;
+ nnwork = n * 5 + (i__3 * i__3 << 1);
+ }
+ nnwork = max(nnwork,1);
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 13; ++j) {
+ result[j] = -1.f;
+/* L100: */
+ }
+
+/* Test with and without sorting of eigenvalues */
+
+ for (isort = 0; isort <= 1; ++isort) {
+ if (isort == 0) {
+ *(unsigned char *)sort = 'N';
+ rsub = 0;
+ } else {
+ *(unsigned char *)sort = 'S';
+ rsub = 6;
+ }
+
+/* Compute Schur form and Schur vectors, and test them */
+
+ clacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset],
+ lda);
+ cgees_("V", sort, (L_fp)cslect_, &n, &h__[h_offset], lda,
+ &sdim, &w[1], &vs[vs_offset], ldvs, &work[1], &
+ nnwork, &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[rsub + 1] = ulpinv;
+ io___38.ciunit = *nounit;
+ s_wsfe(&io___38);
+ do_fio(&c__1, "CGEES1", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L190;
+ }
+
+/* Do Test (1) or Test (7) */
+
+ result[rsub + 1] = 0.f;
+ i__3 = n - 1;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ i__5 = i__ + j * h_dim1;
+ if (h__[i__5].r != 0.f || h__[i__5].i != 0.f) {
+ result[rsub + 1] = ulpinv;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+
+/* Do Tests (2) and (3) or Tests (8) and (9) */
+
+/* Computing MAX */
+ i__3 = 1, i__4 = (n << 1) * n;
+ lwork = max(i__3,i__4);
+ chst01_(&n, &c__1, &n, &a[a_offset], lda, &h__[h_offset],
+ lda, &vs[vs_offset], ldvs, &work[1], &lwork, &
+ rwork[1], res);
+ result[rsub + 2] = res[0];
+ result[rsub + 3] = res[1];
+
+/* Do Test (4) or Test (10) */
+
+ result[rsub + 4] = 0.f;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + i__ * h_dim1;
+ i__5 = i__;
+ if (h__[i__4].r != w[i__5].r || h__[i__4].i != w[i__5]
+ .i) {
+ result[rsub + 4] = ulpinv;
+ }
+/* L130: */
+ }
+
+/* Do Test (5) or Test (11) */
+
+ clacpy_("F", &n, &n, &a[a_offset], lda, &ht[ht_offset],
+ lda);
+ cgees_("N", sort, (L_fp)cslect_, &n, &ht[ht_offset], lda,
+ &sdim, &wt[1], &vs[vs_offset], ldvs, &work[1], &
+ nnwork, &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[rsub + 5] = ulpinv;
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "CGEES2", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L190;
+ }
+
+ result[rsub + 5] = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__ + j * h_dim1;
+ i__6 = i__ + j * ht_dim1;
+ if (h__[i__5].r != ht[i__6].r || h__[i__5].i !=
+ ht[i__6].i) {
+ result[rsub + 5] = ulpinv;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+/* Do Test (6) or Test (12) */
+
+ result[rsub + 6] = 0.f;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ if (w[i__4].r != wt[i__5].r || w[i__4].i != wt[i__5]
+ .i) {
+ result[rsub + 6] = ulpinv;
+ }
+/* L160: */
+ }
+
+/* Do Test (13) */
+
+ if (isort == 1) {
+ result[13] = 0.f;
+ knteig = 0;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (cslect_(&w[i__])) {
+ ++knteig;
+ }
+ if (i__ < n) {
+ if (cslect_(&w[i__ + 1]) && ! cslect_(&w[i__])
+ ) {
+ result[13] = ulpinv;
+ }
+ }
+/* L170: */
+ }
+ if (sdim != knteig) {
+ result[13] = ulpinv;
+ }
+ }
+
+/* L180: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L190:
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 13; ++j) {
+ if (result[j] >= 0.f) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L200: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ e_wsfe();
+ io___48.ciunit = *nounit;
+ s_wsfe(&io___48);
+ e_wsfe();
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ e_wsfe();
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
+ e_wsfe();
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ e_wsfe();
+ ntestf = 2;
+ }
+
+ for (j = 1; j <= 13; ++j) {
+ if (result[j] >= *thresh) {
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ }
+/* L210: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+
+/* L220: */
+ }
+L230:
+ ;
+ }
+/* L240: */
+ }
+
+/* Summary */
+
+ slasum_(path, nounit, &nerrs, &ntestt);
+
+
+
+ return 0;
+
+/* End of CDRVES */
+
+} /* cdrves_ */
diff --git a/TESTING/EIG/cdrvev.c b/TESTING/EIG/cdrvev.c
new file mode 100644
index 0000000..2c6235b
--- /dev/null
+++ b/TESTING/EIG/cdrvev.c
@@ -0,0 +1,1103 @@
+/* cdrvev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__0 = 0;
+static integer c__4 = 4;
+static integer c__6 = 6;
+static real c_b38 = 1.f;
+static integer c__1 = 1;
+static real c_b48 = 0.f;
+static integer c__2 = 2;
+
+/* Subroutine */ int cdrvev_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, integer *nounit,
+ complex *a, integer *lda, complex *h__, complex *w, complex *w1,
+ complex *vl, integer *ldvl, complex *vr, integer *ldvr, complex *lre,
+ integer *ldlre, real *result, complex *work, integer *nwork, real *
+ rwork, integer *iwork, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
+ static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
+ static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9993[] = "(\002 CDRVEV: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(/1x,a3,\002 -- Complex Eigenvalue-Eigenvect"
+ "or \002,\002Decomposition Driver\002,/\002 Matrix types (see CDR"
+ "VEV for details): \002)";
+ static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 \002,\002 5=Diagonal: geom"
+ "etr. spaced entries.\002,/\002 2=Identity matrix. "
+ " \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
+ "/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
+ " 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
+ "l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
+ "ll, evenly spaced.\002)";
+ static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
+ " 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
+ "l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
+ "d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
+ "red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
+ "vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,a6,"
+ "/\002 12=Well-cond., random complex \002,a6,\002 \002,\002 17="
+ "Ill-cond., large rand. complx \002,a4,/\002 13=Ill-condi\002,"
+ "\002tioned, evenly spaced. \002,\002 18=Ill-cond., small ran"
+ "d.\002,\002 complx \002,a4)";
+ static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
+ " \002,\002 21=Matrix \002,\002with small random entries.\002,"
+ "/\002 20=Matrix with large ran\002,\002dom entries. \002,/)";
+ static char fmt_9995[] = "(\002 Tests performed with test threshold ="
+ "\002,f8.2,//\002 1 = | A VR - VR W | / ( n |A| ulp ) \002,/\002 "
+ "2 = | conj-trans(A) VL - VL conj-trans(W) | /\002,\002 ( n |A| u"
+ "lp ) \002,/\002 3 = | |VR(i)| - 1 | / ulp \002,/\002 4 = | |VL(i"
+ ")| - 1 | / ulp \002,/\002 5 = 0 if W same no matter if VR or VL "
+ "computed,\002,\002 1/ulp otherwise\002,/\002 6 = 0 if VR same no"
+ " matter if VL computed,\002,\002 1/ulp otherwise\002,/\002 7 = "
+ "0 if VL same no matter if VR computed,\002,\002 1/ulp otherwis"
+ "e\002,/)";
+ static char fmt_9994[] = "(\002 N=\002,i5,\002, IWK=\002,i2,\002, seed"
+ "=\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)="
+ "\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1,
+ vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6;
+ real r__1, r__2, r__3, r__4, r__5;
+ complex q__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double c_abs(complex *), r_imag(complex *);
+
+ /* Local variables */
+ integer j, n, jj;
+ complex dum[1];
+ real res[2];
+ integer iwk;
+ real ulp, vmx, cond;
+ integer jcol;
+ char path[3];
+ integer nmax;
+ real unfl, ovfl, tnrm, vrmx, vtst;
+ logical badnn;
+ extern /* Subroutine */ int cget22_(char *, char *, char *, integer *,
+ complex *, integer *, complex *, integer *, complex *, complex *,
+ real *, real *);
+ integer nfail;
+ extern /* Subroutine */ int cgeev_(char *, char *, integer *, complex *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, integer *);
+ integer imode, iinfo;
+ real conds, anorm;
+ integer jsize, nerrs, itype, jtype, ntest;
+ real rtulp;
+ extern doublereal scnrm2_(integer *, complex *, integer *);
+ extern /* Subroutine */ int slabad_(real *, real *), clatme_(integer *,
+ char *, integer *, complex *, integer *, real *, complex *, char *
+, char *, char *, char *, real *, integer *, real *, integer *,
+ integer *, real *, complex *, integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *);
+ integer idumma[1];
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int xerbla_(char *, integer *), clatmr_(
+ integer *, integer *, char *, integer *, char *, complex *,
+ integer *, real *, complex *, char *, char *, complex *, integer *
+, real *, complex *, integer *, real *, char *, integer *,
+ integer *, integer *, real *, real *, char *, complex *, integer *
+, integer *, integer *), clatms_(integer *, integer *, char *, integer *, char *,
+ real *, integer *, real *, real *, integer *, integer *, char *,
+ complex *, integer *, complex *, integer *);
+ integer ntestf;
+ extern /* Subroutine */ int slasum_(char *, integer *, integer *, integer
+ *);
+ real ulpinv;
+ integer nnwork;
+ real rtulpi;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___31 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVEV checks the nonsymmetric eigenvalue problem driver CGEEV. */
+
+/* When CDRVEV is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 7 */
+/* tests will be performed: */
+
+/* (1) | A * VR - VR * W | / ( n |A| ulp ) */
+
+/* Here VR is the matrix of unit right eigenvectors. */
+/* W is a diagonal matrix with diagonal entries W(j). */
+
+/* (2) | A**H * VL - VL * W**H | / ( n |A| ulp ) */
+
+/* Here VL is the matrix of unit left eigenvectors, A**H is the */
+/* conjugate-transpose of A, and W is as above. */
+
+/* (3) | |VR(i)| - 1 | / ulp and whether largest component real */
+
+/* VR(i) denotes the i-th column of VR. */
+
+/* (4) | |VL(i)| - 1 | / ulp and whether largest component real */
+
+/* VL(i) denotes the i-th column of VL. */
+
+/* (5) W(full) = W(partial) */
+
+/* W(full) denotes the eigenvalues computed when both VR and VL */
+/* are also computed, and W(partial) denotes the eigenvalues */
+/* computed when only W, only W and VR, or only W and VL are */
+/* computed. */
+
+/* (6) VR(full) = VR(partial) */
+
+/* VR(full) denotes the right eigenvectors computed when both VR */
+/* and VL are computed, and VR(partial) denotes the result */
+/* when only VR is computed. */
+
+/* (7) VL(full) = VL(partial) */
+
+/* VL(full) denotes the left eigenvectors computed when both VR */
+/* and VL are also computed, and VL(partial) denotes the result */
+/* when only VL is computed. */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
+
+/* (4) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random complex angles. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (5) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random complex angles. */
+/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random complex angles. */
+
+/* (7) Same as (4), but multiplied by a constant near */
+/* the overflow threshold */
+/* (8) Same as (4), but multiplied by a constant near */
+/* the underflow threshold */
+
+/* (9) A matrix of the form U' T U, where U is unitary and */
+/* T has evenly spaced entries 1, ..., ULP with random complex */
+/* angles on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (10) A matrix of the form U' T U, where U is unitary and */
+/* T has geometrically spaced entries 1, ..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (11) A matrix of the form U' T U, where U is unitary and */
+/* T has "clustered" entries 1, ULP,..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (12) A matrix of the form U' T U, where U is unitary and */
+/* T has complex eigenvalues randomly chosen from */
+/* ULP < |z| < 1 and random O(1) entries in the upper */
+/* triangle. */
+
+/* (13) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
+/* with random complex angles on the diagonal and random O(1) */
+/* entries in the upper triangle. */
+
+/* (14) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has geometrically spaced entries */
+/* 1, ..., ULP with random complex angles on the diagonal */
+/* and random O(1) entries in the upper triangle. */
+
+/* (15) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
+/* with random complex angles on the diagonal and random O(1) */
+/* entries in the upper triangle. */
+
+/* (16) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has complex eigenvalues randomly chosen */
+/* from ULP < |z| < 1 and random O(1) entries in the upper */
+/* triangle. */
+
+/* (17) Same as (16), but multiplied by a constant */
+/* near the overflow threshold */
+/* (18) Same as (16), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* (19) Nonsymmetric matrix with random entries chosen from |z| < 1 */
+/* If N is at least 4, all entries in first two rows and last */
+/* row, and first column and last two columns are zero. */
+/* (20) Same as (19), but multiplied by a constant */
+/* near the overflow threshold */
+/* (21) Same as (19), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* Arguments */
+/* ========== */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* CDRVEV does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, CDRVEV */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to CDRVEV to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* A (workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, and H. LDA must be at */
+/* least 1 and at least max(NN). */
+
+/* H (workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* Another copy of the test matrix A, modified by CGEEV. */
+
+/* W (workspace) COMPLEX array, dimension (max(NN)) */
+/* The eigenvalues of A. On exit, W are the eigenvalues of */
+/* the matrix in A. */
+
+/* W1 (workspace) COMPLEX array, dimension (max(NN)) */
+/* Like W, this array contains the eigenvalues of A, */
+/* but those computed when CGEEV only computes a partial */
+/* eigendecomposition, i.e. not the eigenvalues and left */
+/* and right eigenvectors. */
+
+/* VL (workspace) COMPLEX array, dimension (LDVL, max(NN)) */
+/* VL holds the computed left eigenvectors. */
+
+/* LDVL (input) INTEGER */
+/* Leading dimension of VL. Must be at least max(1,max(NN)). */
+
+/* VR (workspace) COMPLEX array, dimension (LDVR, max(NN)) */
+/* VR holds the computed right eigenvectors. */
+
+/* LDVR (input) INTEGER */
+/* Leading dimension of VR. Must be at least max(1,max(NN)). */
+
+/* LRE (workspace) COMPLEX array, dimension (LDLRE, max(NN)) */
+/* LRE holds the computed right or left eigenvectors. */
+
+/* LDLRE (input) INTEGER */
+/* Leading dimension of LRE. Must be at least max(1,max(NN)). */
+
+/* RESULT (output) REAL array, dimension (7) */
+/* The values computed by the seven tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* WORK (workspace) COMPLEX array, dimension (NWORK) */
+
+/* NWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 5*NN(j)+2*NN(j)**2 for all j. */
+
+/* RWORK (workspace) REAL array, dimension (2*max(NN)) */
+
+/* IWORK (workspace) INTEGER array, dimension (max(NN)) */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -6: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -14: LDVL < 1 or LDVL < NMAX, where NMAX is max( NN(j) ). */
+/* -16: LDVR < 1 or LDVR < NMAX, where NMAX is max( NN(j) ). */
+/* -18: LDLRE < 1 or LDLRE < NMAX, where NMAX is max( NN(j) ). */
+/* -21: NWORK too small. */
+/* If CLATMR, CLATMS, CLATME or CGEEV returns an error code, */
+/* the absolute value of it is returned. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NMAX Largest value in NN. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* COND, CONDS, */
+/* IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTULP, RTULPI Square roots of the previous 4 values. */
+
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+/* KCONDS(j) Selectw whether CONDS is to be 1 or */
+/* 1/sqrt(ulp). (0 means irrelevant.) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ --w1;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ lre_dim1 = *ldlre;
+ lre_offset = 1 + lre_dim1;
+ lre -= lre_offset;
+ --result;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "EV", (ftnlen)2, (ftnlen)2);
+
+/* Check for errors */
+
+ ntestt = 0;
+ ntestf = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+ nmax = 0;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.f) {
+ *info = -6;
+ } else if (*nounit <= 0) {
+ *info = -7;
+ } else if (*lda < 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldvl < 1 || *ldvl < nmax) {
+ *info = -14;
+ } else if (*ldvr < 1 || *ldvr < nmax) {
+ *info = -16;
+ } else if (*ldlre < 1 || *ldlre < nmax) {
+ *info = -28;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = nmax;
+ if (nmax * 5 + (i__1 * i__1 << 1) > *nwork) {
+ *info = -21;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CDRVEV", &i__1);
+ return 0;
+ }
+
+/* Quick return if nothing to do */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ slabad_(&unfl, &ovfl);
+ ulp = slamch_("Precision");
+ ulpinv = 1.f / ulp;
+ rtulp = sqrt(ulp);
+ rtulpi = 1.f / rtulp;
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L260;
+ }
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KCONDS KMODE KTYPE */
+/* =1 O(1) 1 clustered 1 zero */
+/* =2 large large clustered 2 identity */
+/* =3 small exponential Jordan */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random general, w/ eigenvalues */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 random general */
+/* =10 random triangular */
+
+ if (mtypes > 21) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L30;
+ case 2: goto L40;
+ case 3: goto L50;
+ }
+
+L30:
+ anorm = 1.f;
+ goto L60;
+
+L40:
+ anorm = ovfl * ulp;
+ goto L60;
+
+L50:
+ anorm = unfl * ulpinv;
+ goto L60;
+
+L60:
+
+ claset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ q__1.r = anorm, q__1.i = 0.f;
+ a[i__4].r = q__1.r, a[i__4].i = q__1.i;
+/* L70: */
+ }
+
+ } else if (itype == 3) {
+
+/* Jordan Block */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ q__1.r = anorm, q__1.i = 0.f;
+ a[i__4].r = q__1.r, a[i__4].i = q__1.i;
+ if (jcol > 1) {
+ i__4 = jcol + (jcol - 1) * a_dim1;
+ a[i__4].r = 1.f, a[i__4].i = 0.f;
+ }
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[
+ n + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Hermitian, eigenvalues specified */
+
+ clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 6) {
+
+/* General, eigenvalues specified */
+
+ if (kconds[jtype - 1] == 1) {
+ conds = 1.f;
+ } else if (kconds[jtype - 1] == 2) {
+ conds = rtulpi;
+ } else {
+ conds = 0.f;
+ }
+
+ clatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2,
+ " ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n,
+ &anorm, &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
+ n << 1) + 1], &c__1, &c_b38, "N", idumma, &c__0, &
+ c__0, &c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ clatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b38,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
+ n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &n, &
+ c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* General, random eigenvalues */
+
+ clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
+ n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &n, &
+ c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+ if (n >= 4) {
+ claset_("Full", &c__2, &n, &c_b1, &c_b1, &a[a_offset],
+ lda);
+ i__3 = n - 3;
+ claset_("Full", &i__3, &c__1, &c_b1, &c_b1, &a[a_dim1 + 3]
+, lda);
+ i__3 = n - 3;
+ claset_("Full", &i__3, &c__2, &c_b1, &c_b1, &a[(n - 1) *
+ a_dim1 + 3], lda);
+ claset_("Full", &c__1, &n, &c_b1, &c_b1, &a[n + a_dim1],
+ lda);
+ }
+
+ } else if (itype == 10) {
+
+/* Triangular, random eigenvalues */
+
+ clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
+ n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &c__0, &
+ c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___31.ciunit = *nounit;
+ s_wsfe(&io___31);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+/* Test for minimal and generous workspace */
+
+ for (iwk = 1; iwk <= 2; ++iwk) {
+ if (iwk == 1) {
+ nnwork = n << 1;
+ } else {
+/* Computing 2nd power */
+ i__3 = n;
+ nnwork = n * 5 + (i__3 * i__3 << 1);
+ }
+ nnwork = max(nnwork,1);
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 7; ++j) {
+ result[j] = -1.f;
+/* L100: */
+ }
+
+/* Compute eigenvalues and eigenvectors, and test them */
+
+ clacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+ cgeev_("V", "V", &n, &h__[h_offset], lda, &w[1], &vl[
+ vl_offset], ldvl, &vr[vr_offset], ldvr, &work[1], &
+ nnwork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___34.ciunit = *nounit;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "CGEEV1", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Do Test (1) */
+
+ cget22_("N", "N", "N", &n, &a[a_offset], lda, &vr[vr_offset],
+ ldvr, &w[1], &work[1], &rwork[1], res);
+ result[1] = res[0];
+
+/* Do Test (2) */
+
+ cget22_("C", "N", "C", &n, &a[a_offset], lda, &vl[vl_offset],
+ ldvl, &w[1], &work[1], &rwork[1], res);
+ result[2] = res[0];
+
+/* Do Test (3) */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ tnrm = scnrm2_(&n, &vr[j * vr_dim1 + 1], &c__1);
+/* Computing MAX */
+/* Computing MIN */
+ r__4 = ulpinv, r__5 = (r__1 = tnrm - 1.f, dabs(r__1)) /
+ ulp;
+ r__2 = result[3], r__3 = dmin(r__4,r__5);
+ result[3] = dmax(r__2,r__3);
+ vmx = 0.f;
+ vrmx = 0.f;
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ vtst = c_abs(&vr[jj + j * vr_dim1]);
+ if (vtst > vmx) {
+ vmx = vtst;
+ }
+ i__5 = jj + j * vr_dim1;
+ if (r_imag(&vr[jj + j * vr_dim1]) == 0.f && (r__1 =
+ vr[i__5].r, dabs(r__1)) > vrmx) {
+ i__6 = jj + j * vr_dim1;
+ vrmx = (r__2 = vr[i__6].r, dabs(r__2));
+ }
+/* L110: */
+ }
+ if (vrmx / vmx < 1.f - ulp * 2.f) {
+ result[3] = ulpinv;
+ }
+/* L120: */
+ }
+
+/* Do Test (4) */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ tnrm = scnrm2_(&n, &vl[j * vl_dim1 + 1], &c__1);
+/* Computing MAX */
+/* Computing MIN */
+ r__4 = ulpinv, r__5 = (r__1 = tnrm - 1.f, dabs(r__1)) /
+ ulp;
+ r__2 = result[4], r__3 = dmin(r__4,r__5);
+ result[4] = dmax(r__2,r__3);
+ vmx = 0.f;
+ vrmx = 0.f;
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ vtst = c_abs(&vl[jj + j * vl_dim1]);
+ if (vtst > vmx) {
+ vmx = vtst;
+ }
+ i__5 = jj + j * vl_dim1;
+ if (r_imag(&vl[jj + j * vl_dim1]) == 0.f && (r__1 =
+ vl[i__5].r, dabs(r__1)) > vrmx) {
+ i__6 = jj + j * vl_dim1;
+ vrmx = (r__2 = vl[i__6].r, dabs(r__2));
+ }
+/* L130: */
+ }
+ if (vrmx / vmx < 1.f - ulp * 2.f) {
+ result[4] = ulpinv;
+ }
+/* L140: */
+ }
+
+/* Compute eigenvalues only, and test them */
+
+ clacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+ cgeev_("N", "N", &n, &h__[h_offset], lda, &w1[1], dum, &c__1,
+ dum, &c__1, &work[1], &nnwork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "CGEEV2", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Do Test (5) */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ i__5 = j;
+ if (w[i__4].r != w1[i__5].r || w[i__4].i != w1[i__5].i) {
+ result[5] = ulpinv;
+ }
+/* L150: */
+ }
+
+/* Compute eigenvalues and right eigenvectors, and test them */
+
+ clacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+ cgeev_("N", "V", &n, &h__[h_offset], lda, &w1[1], dum, &c__1,
+ &lre[lre_offset], ldlre, &work[1], &nnwork, &rwork[1],
+ &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "CGEEV3", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Do Test (5) again */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ i__5 = j;
+ if (w[i__4].r != w1[i__5].r || w[i__4].i != w1[i__5].i) {
+ result[5] = ulpinv;
+ }
+/* L160: */
+ }
+
+/* Do Test (6) */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ i__5 = j + jj * vr_dim1;
+ i__6 = j + jj * lre_dim1;
+ if (vr[i__5].r != lre[i__6].r || vr[i__5].i != lre[
+ i__6].i) {
+ result[6] = ulpinv;
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+
+/* Compute eigenvalues and left eigenvectors, and test them */
+
+ clacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+ cgeev_("V", "N", &n, &h__[h_offset], lda, &w1[1], &lre[
+ lre_offset], ldlre, dum, &c__1, &work[1], &nnwork, &
+ rwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "CGEEV4", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Do Test (5) again */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ i__5 = j;
+ if (w[i__4].r != w1[i__5].r || w[i__4].i != w1[i__5].i) {
+ result[5] = ulpinv;
+ }
+/* L190: */
+ }
+
+/* Do Test (7) */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ i__5 = j + jj * vl_dim1;
+ i__6 = j + jj * lre_dim1;
+ if (vl[i__5].r != lre[i__6].r || vl[i__5].i != lre[
+ i__6].i) {
+ result[7] = ulpinv;
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L220:
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 7; ++j) {
+ if (result[j] >= 0.f) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L230: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___48.ciunit = *nounit;
+ s_wsfe(&io___48);
+ e_wsfe();
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ e_wsfe();
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ e_wsfe();
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
+ e_wsfe();
+ ntestf = 2;
+ }
+
+ for (j = 1; j <= 7; ++j) {
+ if (result[j] >= *thresh) {
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ }
+/* L240: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+
+/* L250: */
+ }
+L260:
+ ;
+ }
+/* L270: */
+ }
+
+/* Summary */
+
+ slasum_(path, nounit, &nerrs, &ntestt);
+
+
+
+ return 0;
+
+/* End of CDRVEV */
+
+} /* cdrvev_ */
diff --git a/TESTING/EIG/cdrvgg.c b/TESTING/EIG/cdrvgg.c
new file mode 100644
index 0000000..3a1b796
--- /dev/null
+++ b/TESTING/EIG/cdrvgg.c
@@ -0,0 +1,1144 @@
+/* cdrvgg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__4 = 4;
+static integer c__2 = 2;
+static real c_b39 = 1.f;
+static integer c__3 = 3;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int cdrvgg_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, real *thrshn, integer *
+ nounit, complex *a, integer *lda, complex *b, complex *s, complex *t,
+ complex *s2, complex *t2, complex *q, integer *ldq, complex *z__,
+ complex *alpha1, complex *beta1, complex *alpha2, complex *beta2,
+ complex *vl, complex *vr, complex *work, integer *lwork, real *rwork,
+ real *result, integer *info)
+{
+ /* Initialized data */
+
+ static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
+ 2,2,2,3 };
+ static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
+ 2,3,2,1 };
+ static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
+ 1,1,1,1 };
+ static logical lasign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ TRUE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,FALSE_,
+ TRUE_,FALSE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_ };
+ static logical lbsign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ FALSE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,FALSE_,
+ TRUE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ FALSE_ };
+ static integer kz1[6] = { 0,1,2,1,3,3 };
+ static integer kz2[6] = { 0,0,1,2,1,1 };
+ static integer kadd[6] = { 0,0,0,0,3,2 };
+ static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
+ 4,4,4,0 };
+ static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
+ 8,8,8,8,8,0 };
+ static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
+ 3,3,3,1 };
+ static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
+ 4,4,4,1 };
+ static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
+ 3,3,2,1 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 CDRVGG: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 CDRVGG: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
+ "i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9997[] = "(/1x,a3,\002 -- Complex Generalized eigenvalue"
+ " problem driver\002)";
+ static char fmt_9996[] = "(\002 Matrix types (see CDRVGG for details):"
+ " \002)";
+ static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
+ "osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
+ ") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
+ "onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
+ "I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
+ "arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
+ "(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
+ "=(D, reversed D)\002)";
+ static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
+ "atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
+ " 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
+ "ha&beta \002,\002 20=arithmetic alpha, beta=0,"
+ "1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
+ "=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
+ "/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
+ "l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
+ ".\002)";
+ static char fmt_9993[] = "(/\002 Tests performed: (S is Schur, T is tri"
+ "angular, \002,\002Q and Z are \002,a,\002,\002,/20x,\002l and r "
+ "are the appropriate left and right\002,/19x,\002eigenvectors, re"
+ "sp., a is alpha, b is beta, and\002,/19x,a,\002 means \002,a,"
+ "\002.)\002,/\002 1 = | A - Q S Z\002,a,\002 | / ( |A| n ulp ) "
+ " 2 = | B - Q T Z\002,a,\002 | / ( |B| n ulp )\002,/\002 3 = | "
+ "I - QQ\002,a,\002 | / ( n ulp ) 4 = | I - ZZ\002,a"
+ ",\002 | / ( n ulp )\002,/\002 5 = difference between (alpha,beta"
+ ") and diagonals of\002,\002 (S,T)\002,/\002 6 = max | ( b A - a "
+ "B )\002,a,\002 l | / const. 7 = max | ( b A - a B ) r | / cons"
+ "t.\002,/1x)";
+ static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
+ ",0p,f8.2)";
+ static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
+ ",1p,e10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1,
+ s_offset, s2_dim1, s2_offset, t_dim1, t_offset, t2_dim1,
+ t2_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, z_dim1,
+ z_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9,
+ i__10, i__11;
+ real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10, r__11,
+ r__12, r__13, r__14, r__15, r__16;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ double r_sign(real *, real *), c_abs(complex *);
+ void r_cnjg(complex *, complex *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer j, n, i1, n1, jc, nb, in, jr, ns, nbz;
+ real ulp;
+ integer iadd, nmax;
+ real temp1, temp2;
+ logical badnn;
+ extern /* Subroutine */ int cgegs_(char *, char *, integer *, complex *,
+ integer *, complex *, integer *, complex *, complex *, complex *,
+ integer *, complex *, integer *, complex *, integer *, real *,
+ integer *), cget51_(integer *, integer *, complex
+ *, integer *, complex *, integer *, complex *, integer *, complex
+ *, integer *, complex *, real *, real *), cgegv_(char *, char *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ complex *, complex *, integer *, complex *, integer *, complex *,
+ integer *, real *, integer *), cget52_(logical *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, complex *, complex *, complex *, real *, real *);
+ real dumma[4];
+ integer iinfo;
+ real rmagn[4];
+ complex ctemp;
+ integer nmats, jsize, nerrs, jtype, ntest;
+ extern /* Subroutine */ int clatm4_(integer *, integer *, integer *,
+ integer *, logical *, real *, real *, real *, integer *, integer *
+, complex *, integer *), cunm2r_(char *, char *, integer *,
+ integer *, integer *, complex *, integer *, complex *, complex *,
+ integer *, complex *, integer *), slabad_(real *,
+ real *), clarfg_(integer *, complex *, complex *, integer *,
+ complex *);
+ extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *);
+ real safmin, safmax;
+ integer ioldsd[4];
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *), claset_(char *, integer *, integer *,
+ complex *, complex *, complex *, integer *), xerbla_(char
+ *, integer *);
+ real ulpinv;
+ integer lwkopt, mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9991, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVGG checks the nonsymmetric generalized eigenvalue driver */
+/* routines. */
+/* T T T */
+/* CGEGS factors A and B as Q S Z and Q T Z , where means */
+/* transpose, T is upper triangular, S is in generalized Schur form */
+/* (upper triangular), and Q and Z are unitary. It also */
+/* computes the generalized eigenvalues (alpha(1),beta(1)), ..., */
+/* (alpha(n),beta(n)), where alpha(j)=S(j,j) and beta(j)=T(j,j) -- */
+/* thus, w(j) = alpha(j)/beta(j) is a root of the generalized */
+/* eigenvalue problem */
+
+/* det( A - w(j) B ) = 0 */
+
+/* and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent */
+/* problem */
+
+/* det( m(j) A - B ) = 0 */
+
+/* CGEGV computes the generalized eigenvalues (alpha(1),beta(1)), ..., */
+/* (alpha(n),beta(n)), the matrix L whose columns contain the */
+/* generalized left eigenvectors l, and the matrix R whose columns */
+/* contain the generalized right eigenvectors r for the pair (A,B). */
+
+/* When CDRVGG is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 7 */
+/* tests will be performed and compared with the threshhold THRESH: */
+
+/* Results from CGEGS: */
+
+/* H */
+/* (1) | A - Q S Z | / ( |A| n ulp ) */
+
+/* H */
+/* (2) | B - Q T Z | / ( |B| n ulp ) */
+
+/* H */
+/* (3) | I - QQ | / ( n ulp ) */
+
+/* H */
+/* (4) | I - ZZ | / ( n ulp ) */
+
+/* (5) maximum over j of D(j) where: */
+
+/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
+/* D(j) = ------------------------ + ----------------------- */
+/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
+
+/* Results from CGEGV: */
+
+/* (6) max over all left eigenvalue/-vector pairs (beta/alpha,l) of */
+
+/* | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) ) */
+
+/* where l**H is the conjugate tranpose of l. */
+
+/* (7) max over all right eigenvalue/-vector pairs (beta/alpha,r) of */
+
+/* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) ) */
+
+/* Test Matrices */
+/* ---- -------- */
+
+/* The sizes of the test matrices are specified by an array */
+/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
+/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) ( 0, 0 ) (a pair of zero matrices) */
+
+/* (2) ( I, 0 ) (an identity and a zero matrix) */
+
+/* (3) ( 0, I ) (an identity and a zero matrix) */
+
+/* (4) ( I, I ) (a pair of identity matrices) */
+
+/* t t */
+/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
+
+/* t ( I 0 ) */
+/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
+/* ( 0 I ) ( 0 J ) */
+/* and I is a k x k identity and J a (k+1)x(k+1) */
+/* Jordan block; k=(N-1)/2 */
+
+/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
+/* matrix with those diagonal entries.) */
+/* (8) ( I, D ) */
+
+/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
+
+/* (10) ( small*D, big*I ) */
+
+/* (11) ( big*I, small*D ) */
+
+/* (12) ( small*I, big*D ) */
+
+/* (13) ( big*D, big*I ) */
+
+/* (14) ( small*D, small*I ) */
+
+/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
+/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
+/* t t */
+/* (16) Q ( J , J ) Z where Q and Z are random unitary matrices. */
+
+/* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices */
+/* with random O(1) entries above the diagonal */
+/* and diagonal entries diag(T1) = */
+/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
+/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
+
+/* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
+/* s = machine precision. */
+
+/* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
+
+/* N-5 */
+/* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+
+/* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+/* where r1,..., r(N-4) are random. */
+
+/* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular */
+/* matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* CDRVGG does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, CDRVGG */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to CDRVGG to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error is */
+/* scaled to be O(1), so THRESH should be a reasonably small */
+/* multiple of 1, e.g., 10 or 100. In particular, it should */
+/* not depend on the precision (single vs. double) or the size */
+/* of the matrix. It must be at least zero. */
+
+/* THRSHN (input) REAL */
+/* Threshhold for reporting eigenvector normalization error. */
+/* If the normalization of any eigenvector differs from 1 by */
+/* more than THRSHN*ulp, then a special error message will be */
+/* printed. (This is handled separately from the other tests, */
+/* since only a compiler or programming error should cause an */
+/* error message, at least if THRSHN is at least 5--10.) */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* Used to hold the original A matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, S, T, S2, and T2. */
+/* It must be at least 1 and at least max( NN ). */
+
+/* B (input/workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* Used to hold the original B matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* S (workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from A by CGEGS. */
+
+/* T (workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from B by CGEGS. */
+
+/* S2 (workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* The matrix computed from A by CGEGV. This will be the */
+/* Schur (upper triangular) form of some matrix related to A, */
+/* but will not, in general, be the same as S. */
+
+/* T2 (workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* The matrix computed from B by CGEGV. This will be the */
+/* Schur form of some matrix related to B, but will not, in */
+/* general, be the same as T. */
+
+/* Q (workspace) COMPLEX array, dimension (LDQ, max(NN)) */
+/* The (left) unitary matrix computed by CGEGS. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of Q, Z, VL, and VR. It must */
+/* be at least 1 and at least max( NN ). */
+
+/* Z (workspace) COMPLEX array, dimension (LDQ, max(NN)) */
+/* The (right) unitary matrix computed by CGEGS. */
+
+/* ALPHA1 (workspace) COMPLEX array, dimension (max(NN)) */
+/* BETA1 (workspace) COMPLEX array, dimension (max(NN)) */
+/* The generalized eigenvalues of (A,B) computed by CGEGS. */
+/* ALPHA1(k) / BETA1(k) is the k-th generalized eigenvalue of */
+/* the matrices in A and B. */
+
+/* ALPHA2 (workspace) COMPLEX array, dimension (max(NN)) */
+/* BETA2 (workspace) COMPLEX array, dimension (max(NN)) */
+/* The generalized eigenvalues of (A,B) computed by CGEGV. */
+/* ALPHA2(k) / BETA2(k) is the k-th generalized eigenvalue of */
+/* the matrices in A and B. */
+
+/* VL (workspace) COMPLEX array, dimension (LDQ, max(NN)) */
+/* The (lower triangular) left eigenvector matrix for the */
+/* matrices in A and B. */
+
+/* VR (workspace) COMPLEX array, dimension (LDQ, max(NN)) */
+/* The (upper triangular) right eigenvector matrix for the */
+/* matrices in A and B. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* MAX( 2*N, N*(NB+1), (k+1)*(2*k+N+1) ), where "k" is the */
+/* sum of the blocksize and number-of-shifts for CHGEQZ, and */
+/* NB is the greatest of the blocksizes for CGEQRF, CUNMQR, */
+/* and CUNGQR. (The blocksizes and the number-of-shifts are */
+/* retrieved through calls to ILAENV.) */
+
+/* RWORK (workspace) REAL array, dimension (8*N) */
+
+/* RESULT (output) REAL array, dimension (7) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: A routine returned an error code. INFO is the */
+/* absolute value of the INFO value returned. */
+
+/* ===================================================================== */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ t2_dim1 = *lda;
+ t2_offset = 1 + t2_dim1;
+ t2 -= t2_offset;
+ s2_dim1 = *lda;
+ s2_offset = 1 + s2_dim1;
+ s2 -= s2_offset;
+ t_dim1 = *lda;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ s_dim1 = *lda;
+ s_offset = 1 + s_dim1;
+ s -= s_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ vr_dim1 = *ldq;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ vl_dim1 = *ldq;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ z_dim1 = *ldq;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --alpha1;
+ --beta1;
+ --alpha2;
+ --beta2;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Maximum blocksize and shift -- we assume that blocksize and number */
+/* of shifts are monotone increasing functions of N. */
+
+/* Computing MAX */
+ i__1 = 1, i__2 = ilaenv_(&c__1, "CGEQRF", " ", &nmax, &nmax, &c_n1, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
+ c__1, "CUNMQR", "LC", &nmax, &nmax, &nmax, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&c__1, "CUNGQR",
+ " ", &nmax, &nmax, &nmax, &c_n1);
+ nb = max(i__1,i__2);
+ nbz = ilaenv_(&c__1, "CHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0);
+ ns = ilaenv_(&c__4, "CHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0);
+ i1 = nbz + ns;
+/* Computing MAX */
+ i__1 = nmax << 1, i__2 = nmax * (nb + 1), i__1 = max(i__1,i__2), i__2 = ((
+ i1 << 1) + nmax + 1) * (i1 + 1);
+ lwkopt = max(i__1,i__2);
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.f) {
+ *info = -6;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -10;
+ } else if (*ldq <= 1 || *ldq < nmax) {
+ *info = -19;
+ } else if (lwkopt > *lwork) {
+ *info = -30;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CDRVGG", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+ ulp = slamch_("Precision");
+ safmin = slamch_("Safe minimum");
+ safmin /= ulp;
+ safmax = 1.f / safmin;
+ slabad_(&safmin, &safmax);
+ ulpinv = 1.f / ulp;
+
+/* The values RMAGN(2:3) depend on N, see below. */
+
+ rmagn[0] = 0.f;
+ rmagn[1] = 1.f;
+
+/* Loop over sizes, types */
+
+ ntestt = 0;
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ n1 = max(1,n);
+ rmagn[2] = safmax * ulp / (real) n1;
+ rmagn[3] = safmin * ulpinv * n1;
+
+ if (*nsizes != 1) {
+ mtypes = min(26,*ntypes);
+ } else {
+ mtypes = min(27,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L150;
+ }
+ ++nmats;
+ ntest = 0;
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 7; ++j) {
+ result[j] = 0.f;
+/* L30: */
+ }
+
+/* Compute A and B */
+
+/* Description of control parameters: */
+
+/* KCLASS: =1 means w/o rotation, =2 means w/ rotation, */
+/* =3 means random. */
+/* KATYPE: the "type" to be passed to CLATM4 for computing A. */
+/* KAZERO: the pattern of zeros on the diagonal for A: */
+/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
+/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
+/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
+/* non-zero entries.) */
+/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
+/* =2: large, =3: small. */
+/* LASIGN: .TRUE. if the diagonal elements of A are to be */
+/* multiplied by a random magnitude 1 number. */
+/* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B. */
+/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
+/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
+/* RMAGN: used to implement KAMAGN and KBMAGN. */
+
+ if (mtypes > 26) {
+ goto L110;
+ }
+ iinfo = 0;
+ if (kclass[jtype - 1] < 3) {
+
+/* Generate A (w/o rotation) */
+
+ if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ claset_("Full", &n, &n, &c_b1, &c_b1, &a[a_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ clatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
+ &kz2[kazero[jtype - 1] - 1], &lasign[jtype - 1], &
+ rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
+ 1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
+ a_offset], lda);
+ iadd = kadd[kazero[jtype - 1] - 1];
+ if (iadd > 0 && iadd <= n) {
+ i__3 = iadd + iadd * a_dim1;
+ i__4 = kamagn[jtype - 1];
+ a[i__3].r = rmagn[i__4], a[i__3].i = 0.f;
+ }
+
+/* Generate B (w/o rotation) */
+
+ if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ claset_("Full", &n, &n, &c_b1, &c_b1, &b[b_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ clatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
+ &kz2[kbzero[jtype - 1] - 1], &lbsign[jtype - 1], &
+ rmagn[kbmagn[jtype - 1]], &c_b39, &rmagn[ktrian[jtype
+ - 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
+ b_offset], lda);
+ iadd = kadd[kbzero[jtype - 1] - 1];
+ if (iadd != 0 && iadd <= n) {
+ i__3 = iadd + iadd * b_dim1;
+ i__4 = kbmagn[jtype - 1];
+ b[i__3].r = rmagn[i__4], b[i__3].i = 0.f;
+ }
+
+ if (kclass[jtype - 1] == 2 && n > 0) {
+
+/* Include rotations */
+
+/* Generate Q, Z as Householder transformations times */
+/* a diagonal matrix. */
+
+ i__3 = n - 1;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = jc; jr <= i__4; ++jr) {
+ i__5 = jr + jc * q_dim1;
+ clarnd_(&q__1, &c__3, &iseed[1]);
+ q[i__5].r = q__1.r, q[i__5].i = q__1.i;
+ i__5 = jr + jc * z_dim1;
+ clarnd_(&q__1, &c__3, &iseed[1]);
+ z__[i__5].r = q__1.r, z__[i__5].i = q__1.i;
+/* L40: */
+ }
+ i__4 = n + 1 - jc;
+ clarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc *
+ q_dim1], &c__1, &work[jc]);
+ i__4 = (n << 1) + jc;
+ i__5 = jc + jc * q_dim1;
+ r__2 = q[i__5].r;
+ r__1 = r_sign(&c_b39, &r__2);
+ work[i__4].r = r__1, work[i__4].i = 0.f;
+ i__4 = jc + jc * q_dim1;
+ q[i__4].r = 1.f, q[i__4].i = 0.f;
+ i__4 = n + 1 - jc;
+ clarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 +
+ jc * z_dim1], &c__1, &work[n + jc]);
+ i__4 = n * 3 + jc;
+ i__5 = jc + jc * z_dim1;
+ r__2 = z__[i__5].r;
+ r__1 = r_sign(&c_b39, &r__2);
+ work[i__4].r = r__1, work[i__4].i = 0.f;
+ i__4 = jc + jc * z_dim1;
+ z__[i__4].r = 1.f, z__[i__4].i = 0.f;
+/* L50: */
+ }
+ clarnd_(&q__1, &c__3, &iseed[1]);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__3 = n + n * q_dim1;
+ q[i__3].r = 1.f, q[i__3].i = 0.f;
+ i__3 = n;
+ work[i__3].r = 0.f, work[i__3].i = 0.f;
+ i__3 = n * 3;
+ r__1 = c_abs(&ctemp);
+ q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+ clarnd_(&q__1, &c__3, &iseed[1]);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__3 = n + n * z_dim1;
+ z__[i__3].r = 1.f, z__[i__3].i = 0.f;
+ i__3 = n << 1;
+ work[i__3].r = 0.f, work[i__3].i = 0.f;
+ i__3 = n << 2;
+ r__1 = c_abs(&ctemp);
+ q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+
+/* Apply the diagonal matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ i__5 = jr + jc * a_dim1;
+ i__6 = (n << 1) + jr;
+ r_cnjg(&q__3, &work[n * 3 + jc]);
+ q__2.r = work[i__6].r * q__3.r - work[i__6].i *
+ q__3.i, q__2.i = work[i__6].r * q__3.i +
+ work[i__6].i * q__3.r;
+ i__7 = jr + jc * a_dim1;
+ q__1.r = q__2.r * a[i__7].r - q__2.i * a[i__7].i,
+ q__1.i = q__2.r * a[i__7].i + q__2.i * a[
+ i__7].r;
+ a[i__5].r = q__1.r, a[i__5].i = q__1.i;
+ i__5 = jr + jc * b_dim1;
+ i__6 = (n << 1) + jr;
+ r_cnjg(&q__3, &work[n * 3 + jc]);
+ q__2.r = work[i__6].r * q__3.r - work[i__6].i *
+ q__3.i, q__2.i = work[i__6].r * q__3.i +
+ work[i__6].i * q__3.r;
+ i__7 = jr + jc * b_dim1;
+ q__1.r = q__2.r * b[i__7].r - q__2.i * b[i__7].i,
+ q__1.i = q__2.r * b[i__7].i + q__2.i * b[
+ i__7].r;
+ b[i__5].r = q__1.r, b[i__5].i = q__1.i;
+/* L60: */
+ }
+/* L70: */
+ }
+ i__3 = n - 1;
+ cunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ cunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &a[a_offset], lda, &work[(n << 1) +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ cunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &b[b_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ cunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &b[b_offset], lda, &work[(n << 1) +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ }
+ } else {
+
+/* Random matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ i__5 = jr + jc * a_dim1;
+ i__6 = kamagn[jtype - 1];
+ clarnd_(&q__2, &c__4, &iseed[1]);
+ q__1.r = rmagn[i__6] * q__2.r, q__1.i = rmagn[i__6] *
+ q__2.i;
+ a[i__5].r = q__1.r, a[i__5].i = q__1.i;
+ i__5 = jr + jc * b_dim1;
+ i__6 = kbmagn[jtype - 1];
+ clarnd_(&q__2, &c__4, &iseed[1]);
+ q__1.r = rmagn[i__6] * q__2.r, q__1.i = rmagn[i__6] *
+ q__2.i;
+ b[i__5].r = q__1.r, b[i__5].i = q__1.i;
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+
+L100:
+
+ if (iinfo != 0) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L110:
+
+/* Call CGEGS to compute H, T, Q, Z, alpha, and beta. */
+
+ clacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ clacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ ntest = 1;
+ result[1] = ulpinv;
+
+ cgegs_("V", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
+ alpha1[1], &beta1[1], &q[q_offset], ldq, &z__[z_offset],
+ ldq, &work[1], lwork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "CGEGS", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L130;
+ }
+
+ ntest = 4;
+
+/* Do tests 1--4 */
+
+ cget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, &q[
+ q_offset], ldq, &z__[z_offset], ldq, &work[1], &rwork[1],
+ &result[1]);
+ cget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
+ q_offset], ldq, &z__[z_offset], ldq, &work[1], &rwork[1],
+ &result[2]);
+ cget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
+ q_offset], ldq, &q[q_offset], ldq, &work[1], &rwork[1], &
+ result[3]);
+ cget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[
+ z_offset], ldq, &z__[z_offset], ldq, &work[1], &rwork[1],
+ &result[4]);
+
+/* Do test 5: compare eigenvalues with diagonals. */
+
+ temp1 = 0.f;
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ i__5 = j + j * s_dim1;
+ q__2.r = alpha1[i__4].r - s[i__5].r, q__2.i = alpha1[i__4].i
+ - s[i__5].i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ i__6 = j;
+ i__7 = j + j * t_dim1;
+ q__4.r = beta1[i__6].r - t[i__7].r, q__4.i = beta1[i__6].i -
+ t[i__7].i;
+ q__3.r = q__4.r, q__3.i = q__4.i;
+/* Computing MAX */
+ i__8 = j;
+ i__9 = j + j * s_dim1;
+ r__13 = safmin, r__14 = (r__1 = alpha1[i__8].r, dabs(r__1)) +
+ (r__2 = r_imag(&alpha1[j]), dabs(r__2)), r__13 = max(
+ r__13,r__14), r__14 = (r__3 = s[i__9].r, dabs(r__3))
+ + (r__4 = r_imag(&s[j + j * s_dim1]), dabs(r__4));
+/* Computing MAX */
+ i__10 = j;
+ i__11 = j + j * t_dim1;
+ r__15 = safmin, r__16 = (r__5 = beta1[i__10].r, dabs(r__5)) +
+ (r__6 = r_imag(&beta1[j]), dabs(r__6)), r__15 = max(
+ r__15,r__16), r__16 = (r__7 = t[i__11].r, dabs(r__7))
+ + (r__8 = r_imag(&t[j + j * t_dim1]), dabs(r__8));
+ temp2 = (((r__9 = q__1.r, dabs(r__9)) + (r__10 = r_imag(&q__1)
+ , dabs(r__10))) / dmax(r__13,r__14) + ((r__11 =
+ q__3.r, dabs(r__11)) + (r__12 = r_imag(&q__3), dabs(
+ r__12))) / dmax(r__15,r__16)) / ulp;
+ temp1 = dmax(temp1,temp2);
+/* L120: */
+ }
+ result[5] = temp1;
+
+/* Call CGEGV to compute S2, T2, VL, and VR, do tests. */
+
+/* Eigenvalues and Eigenvectors */
+
+ clacpy_(" ", &n, &n, &a[a_offset], lda, &s2[s2_offset], lda);
+ clacpy_(" ", &n, &n, &b[b_offset], lda, &t2[t2_offset], lda);
+ ntest = 6;
+ result[6] = ulpinv;
+
+ cgegv_("V", "V", &n, &s2[s2_offset], lda, &t2[t2_offset], lda, &
+ alpha2[1], &beta2[1], &vl[vl_offset], ldq, &vr[vr_offset],
+ ldq, &work[1], lwork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ do_fio(&c__1, "CGEGV", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L130;
+ }
+
+ ntest = 7;
+
+/* Do Tests 6 and 7 */
+
+ cget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &vl[
+ vl_offset], ldq, &alpha2[1], &beta2[1], &work[1], &rwork[
+ 1], dumma);
+ result[6] = dumma[0];
+ if (dumma[1] > *thrshn) {
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "CGEGV", (ftnlen)5);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ cget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &vr[
+ vr_offset], ldq, &alpha2[1], &beta2[1], &work[1], &rwork[
+ 1], dumma);
+ result[7] = dumma[0];
+ if (dumma[1] > *thresh) {
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "CGEGV", (ftnlen)5);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L130:
+
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__3 = ntest;
+ for (jr = 1; jr <= i__3; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "CGG", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ e_wsfe();
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ e_wsfe();
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ do_fio(&c__1, "Unitary", (ftnlen)7);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+ do_fio(&c__1, "unitary", (ftnlen)7);
+ do_fio(&c__1, "*", (ftnlen)1);
+ do_fio(&c__1, "conjugate transpose", (ftnlen)19);
+ for (j = 1; j <= 5; ++j) {
+ do_fio(&c__1, "*", (ftnlen)1);
+ }
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[jr] < 1e4f) {
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ } else {
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ }
+ }
+/* L140: */
+ }
+
+L150:
+ ;
+ }
+/* L160: */
+ }
+
+/* Summary */
+
+ alasvm_("CGG", nounit, &nerrs, &ntestt, &c__0);
+ return 0;
+
+
+
+
+
+
+
+/* End of CDRVGG */
+
+} /* cdrvgg_ */
diff --git a/TESTING/EIG/cdrvsg.c b/TESTING/EIG/cdrvsg.c
new file mode 100644
index 0000000..172d5a3
--- /dev/null
+++ b/TESTING/EIG/cdrvsg.c
@@ -0,0 +1,2007 @@
+/* cdrvsg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__0 = 0;
+static integer c__6 = 6;
+static real c_b33 = 1.f;
+static integer c__1 = 1;
+static real c_b43 = 0.f;
+static integer c__4 = 4;
+static integer c__5 = 5;
+static real c_b78 = 10.f;
+static integer c__3 = 3;
+
+/* Subroutine */ int cdrvsg_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, integer *nounit,
+ complex *a, integer *lda, complex *b, integer *ldb, real *d__,
+ complex *z__, integer *ldz, complex *ab, complex *bb, complex *ap,
+ complex *bp, complex *work, integer *nwork, real *rwork, integer *
+ lrwork, integer *iwork, integer *liwork, real *result, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,4,4,4,4,4,5,5,5,5,5,8,8,8,9,9,9,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3,1,1,1,1,1,1 };
+ static integer kmode[21] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0,4,4,4,4,4,4 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 CDRVSG: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+
+ /* System generated locals */
+ address a__1[3];
+ integer a_dim1, a_offset, ab_dim1, ab_offset, b_dim1, b_offset, bb_dim1,
+ bb_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6[3]
+ , i__7;
+ char ch__1[10], ch__2[11], ch__3[12], ch__4[13];
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, m, n, ka, kb, ij, il, iu;
+ real vl, vu;
+ integer ka9, kb9;
+ real ulp, cond;
+ integer jcol, nmax;
+ real unfl, ovfl;
+ char uplo[1];
+ logical badnn;
+ extern /* Subroutine */ int chbgv_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, real *,
+ complex *, integer *, complex *, real *, integer *), chegv_(integer *, char *, char *, integer *, complex *,
+ integer *, complex *, integer *, real *, complex *, integer *,
+ real *, integer *);
+ integer imode;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int csgt01_(integer *, char *, integer *, integer
+ *, complex *, integer *, complex *, integer *, complex *, integer
+ *, real *, complex *, real *, real *);
+ integer iinfo;
+ extern /* Subroutine */ int chpgv_(integer *, char *, char *, integer *,
+ complex *, complex *, real *, complex *, integer *, complex *,
+ real *, integer *);
+ real aninv, anorm;
+ integer itemp, nmats, jsize, nerrs, itype, jtype, ntest, iseed2[4];
+ extern /* Subroutine */ int slabad_(real *, real *), chbgvd_(char *, char
+ *, integer *, integer *, integer *, complex *, integer *, complex
+ *, integer *, real *, complex *, integer *, complex *, integer *,
+ real *, integer *, integer *, integer *, integer *), chegvd_(integer *, char *, char *, integer *, complex *,
+ integer *, complex *, integer *, real *, complex *, integer *,
+ real *, integer *, integer *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int chpgvd_(integer *, char *, char *, integer *,
+ complex *, complex *, real *, complex *, integer *, complex *,
+ integer *, real *, integer *, integer *, integer *, integer *);
+ integer idumma[1];
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), xerbla_(char *,
+ integer *), chbgvx_(char *, char *, char *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, real *, integer *, integer *, real *
+, integer *, real *, complex *, integer *, complex *, real *,
+ integer *, integer *, integer *), clatmr_(
+ integer *, integer *, char *, integer *, char *, complex *,
+ integer *, real *, complex *, char *, char *, complex *, integer *
+, real *, complex *, integer *, real *, char *, integer *,
+ integer *, integer *, real *, real *, char *, complex *, integer *
+, integer *, integer *);
+ extern doublereal slarnd_(integer *, integer *);
+ real abstol;
+ extern /* Subroutine */ int chegvx_(integer *, char *, char *, char *,
+ integer *, complex *, integer *, complex *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, real *, complex *
+, integer *, complex *, integer *, real *, integer *, integer *,
+ integer *), clatms_(integer *, integer *,
+ char *, integer *, char *, real *, integer *, real *, real *,
+ integer *, integer *, char *, complex *, integer *, complex *,
+ integer *);
+ integer ibuplo, ibtype;
+ extern /* Subroutine */ int slafts_(char *, integer *, integer *, integer
+ *, integer *, real *, integer *, real *, integer *, integer *), chpgvx_(integer *, char *, char *, char *, integer *,
+ complex *, complex *, real *, real *, integer *, integer *, real *
+, integer *, real *, complex *, integer *, complex *, real *,
+ integer *, integer *, integer *), slasum_(
+ char *, integer *, integer *, integer *);
+ real rtunfl, rtovfl, ulpinv;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* ********************************************************************* */
+
+/* modified August 1997, a new parameter LRWORK and LIWORK are */
+/* added in the calling sequence. */
+
+/* test routine CSGT01 is also modified */
+
+/* ********************************************************************* */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVSG checks the complex Hermitian generalized eigenproblem */
+/* drivers. */
+
+/* CHEGV computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian-definite generalized */
+/* eigenproblem. */
+
+/* CHEGVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian-definite generalized */
+/* eigenproblem using a divide and conquer algorithm. */
+
+/* CHEGVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian-definite generalized */
+/* eigenproblem. */
+
+/* CHPGV computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian-definite generalized */
+/* eigenproblem in packed storage. */
+
+/* CHPGVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian-definite generalized */
+/* eigenproblem in packed storage using a divide and */
+/* conquer algorithm. */
+
+/* CHPGVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian-definite generalized */
+/* eigenproblem in packed storage. */
+
+/* CHBGV computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian-definite banded */
+/* generalized eigenproblem. */
+
+/* CHBGVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian-definite banded */
+/* generalized eigenproblem using a divide and conquer */
+/* algorithm. */
+
+/* CHBGVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian-definite banded */
+/* generalized eigenproblem. */
+
+/* When CDRVSG is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix A of the given type will be */
+/* generated; a random well-conditioned matrix B is also generated */
+/* and the pair (A,B) is used to test the drivers. */
+
+/* For each pair (A,B), the following tests are performed: */
+
+/* (1) CHEGV with ITYPE = 1 and UPLO ='U': */
+
+/* | A Z - B Z D | / ( |A| |Z| n ulp ) */
+
+/* (2) as (1) but calling CHPGV */
+/* (3) as (1) but calling CHBGV */
+/* (4) as (1) but with UPLO = 'L' */
+/* (5) as (4) but calling CHPGV */
+/* (6) as (4) but calling CHBGV */
+
+/* (7) CHEGV with ITYPE = 2 and UPLO ='U': */
+
+/* | A B Z - Z D | / ( |A| |Z| n ulp ) */
+
+/* (8) as (7) but calling CHPGV */
+/* (9) as (7) but with UPLO = 'L' */
+/* (10) as (9) but calling CHPGV */
+
+/* (11) CHEGV with ITYPE = 3 and UPLO ='U': */
+
+/* | B A Z - Z D | / ( |A| |Z| n ulp ) */
+
+/* (12) as (11) but calling CHPGV */
+/* (13) as (11) but with UPLO = 'L' */
+/* (14) as (13) but calling CHPGV */
+
+/* CHEGVD, CHPGVD and CHBGVD performed the same 14 tests. */
+
+/* CHEGVX, CHPGVX and CHBGVX performed the above 14 tests with */
+/* the parameter RANGE = 'A', 'N' and 'I', respectively. */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* This type is used for the matrix A which has half-bandwidth KA. */
+/* B is generated as a well-conditioned positive definite matrix */
+/* with half-bandwidth KB (<= KA). */
+/* Currently, the list of possible types for A is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (6) Same as (4), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (4), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U* D U, where U is unitary and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U* D U, where U is unitary and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U* D U, where U is unitary and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) Hermitian matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
+
+/* (16) Same as (8), but with KA = 1 and KB = 1 */
+/* (17) Same as (8), but with KA = 2 and KB = 1 */
+/* (18) Same as (8), but with KA = 2 and KB = 2 */
+/* (19) Same as (8), but with KA = 3 and KB = 1 */
+/* (20) Same as (8), but with KA = 3 and KB = 2 */
+/* (21) Same as (8), but with KA = 3 and KB = 3 */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* CDRVSG does nothing. It must be at least zero. */
+/* Not modified. */
+
+/* NN INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+/* Not modified. */
+
+/* NTYPES INTEGER */
+/* The number of elements in DOTYPE. If it is zero, CDRVSG */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+/* Not modified. */
+
+/* DOTYPE LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+/* Not modified. */
+
+/* ISEED INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to CDRVSG to continue the same random number */
+/* sequence. */
+/* Modified. */
+
+/* THRESH REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+/* Not modified. */
+
+/* NOUNIT INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+/* Not modified. */
+
+/* A COMPLEX array, dimension (LDA , max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually */
+/* used. */
+/* Modified. */
+
+/* LDA INTEGER */
+/* The leading dimension of A. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* B COMPLEX array, dimension (LDB , max(NN)) */
+/* Used to hold the Hermitian positive definite matrix for */
+/* the generailzed problem. */
+/* On exit, B contains the last matrix actually */
+/* used. */
+/* Modified. */
+
+/* LDB INTEGER */
+/* The leading dimension of B. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* D REAL array, dimension (max(NN)) */
+/* The eigenvalues of A. On exit, the eigenvalues in D */
+/* correspond with the matrix in A. */
+/* Modified. */
+
+/* Z COMPLEX array, dimension (LDZ, max(NN)) */
+/* The matrix of eigenvectors. */
+/* Modified. */
+
+/* LDZ INTEGER */
+/* The leading dimension of ZZ. It must be at least 1 and */
+/* at least max( NN ). */
+/* Not modified. */
+
+/* AB COMPLEX array, dimension (LDA, max(NN)) */
+/* Workspace. */
+/* Modified. */
+
+/* BB COMPLEX array, dimension (LDB, max(NN)) */
+/* Workspace. */
+/* Modified. */
+
+/* AP COMPLEX array, dimension (max(NN)**2) */
+/* Workspace. */
+/* Modified. */
+
+/* BP COMPLEX array, dimension (max(NN)**2) */
+/* Workspace. */
+/* Modified. */
+
+/* WORK COMPLEX array, dimension (NWORK) */
+/* Workspace. */
+/* Modified. */
+
+/* NWORK INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 2*N + N**2 where N = max( NN(j), 2 ). */
+/* Not modified. */
+
+/* RWORK REAL array, dimension (LRWORK) */
+/* Workspace. */
+/* Modified. */
+
+/* LRWORK INTEGER */
+/* The number of entries in RWORK. This must be at least */
+/* max( 7*N, 1 + 4*N + 2*N*lg(N) + 3*N**2 ) where */
+/* N = max( NN(j) ) and lg( N ) = smallest integer k such */
+/* that 2**k >= N . */
+/* Not modified. */
+
+/* IWORK INTEGER array, dimension (LIWORK)) */
+/* Workspace. */
+/* Modified. */
+
+/* LIWORK INTEGER */
+/* The number of entries in IWORK. This must be at least */
+/* 2 + 5*max( NN(j) ). */
+/* Not modified. */
+
+/* RESULT REAL array, dimension (70) */
+/* The values computed by the 70 tests described above. */
+/* Modified. */
+
+/* INFO INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -5: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -16: LDZ < 1 or LDZ < NMAX. */
+/* -21: NWORK too small. */
+/* -23: LRWORK too small. */
+/* -25: LIWORK too small. */
+/* If CLATMR, CLATMS, CHEGV, CHPGV, CHBGV, CHEGVD, CHPGVD, */
+/* CHPGVD, CHEGVX, CHPGVX, CHBGVX returns an error code, */
+/* the absolute value of it is returned. */
+/* Modified. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests that have been run */
+/* on this matrix. */
+/* NTESTT The total number of tests for this call. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far (computed by SLAFTS). */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ ab_dim1 = *lda;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ bb_dim1 = *ldb;
+ bb_offset = 1 + bb_dim1;
+ bb -= bb_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --d__;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --ap;
+ --bp;
+ --work;
+ --rwork;
+ --iwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 0;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldz <= 1 || *ldz < nmax) {
+ *info = -16;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = max(nmax,2);
+ if (i__1 * i__1 << 1 > *nwork) {
+ *info = -21;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = max(nmax,2);
+ if (i__1 * i__1 << 1 > *lrwork) {
+ *info = -23;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = max(nmax,2);
+ if (i__1 * i__1 << 1 > *liwork) {
+ *info = -25;
+ }
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CDRVSG", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = slamch_("Safe minimum");
+ ovfl = slamch_("Overflow");
+ slabad_(&unfl, &ovfl);
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ ulpinv = 1.f / ulp;
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed2[i__ - 1] = iseed[i__];
+/* L20: */
+ }
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ aninv = 1.f / (real) max(1,n);
+
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ ka9 = 0;
+ kb9 = 0;
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L640;
+ }
+ ++nmats;
+ ntest = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L30: */
+ }
+
+/* 2) Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, w/ eigenvalues */
+/* =5 random log hermitian, w/ eigenvalues */
+/* =6 random (none) */
+/* =7 random diagonal */
+/* =8 random hermitian */
+/* =9 banded, w/ eigenvalues */
+
+ if (mtypes > 21) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.f;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * aninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * n * ulpinv;
+ goto L70;
+
+L70:
+
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+ if (itype == 1) {
+
+/* Zero */
+
+ ka = 0;
+ kb = 0;
+ claset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ ka = 0;
+ kb = 0;
+ claset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ a[i__4].r = anorm, a[i__4].i = 0.f;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ ka = 0;
+ kb = 0;
+ clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[
+ 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Hermitian, eigenvalues specified */
+
+/* Computing MAX */
+ i__3 = 0, i__4 = n - 1;
+ ka = max(i__3,i__4);
+ kb = ka;
+ clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[1], &
+ iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ ka = 0;
+ kb = 0;
+ clatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &c_b33,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b33, &work[(
+ n << 1) + 1], &c__1, &c_b33, "N", idumma, &c__0, &
+ c__0, &c_b43, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Hermitian, random eigenvalues */
+
+/* Computing MAX */
+ i__3 = 0, i__4 = n - 1;
+ ka = max(i__3,i__4);
+ kb = ka;
+ clatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &c_b33,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b33, &work[(
+ n << 1) + 1], &c__1, &c_b33, "N", idumma, &n, &n, &
+ c_b43, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* Hermitian banded, eigenvalues specified */
+
+/* The following values are used for the half-bandwidths: */
+
+/* ka = 1 kb = 1 */
+/* ka = 2 kb = 1 */
+/* ka = 2 kb = 2 */
+/* ka = 3 kb = 1 */
+/* ka = 3 kb = 2 */
+/* ka = 3 kb = 3 */
+
+ ++kb9;
+ if (kb9 > ka9) {
+ ++ka9;
+ kb9 = 1;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__5 = n - 1;
+ i__3 = 0, i__4 = min(i__5,ka9);
+ ka = max(i__3,i__4);
+/* Computing MAX */
+/* Computing MIN */
+ i__5 = n - 1;
+ i__3 = 0, i__4 = min(i__5,kb9);
+ kb = max(i__3,i__4);
+ clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &ka, &ka, "N", &a[a_offset], lda, &work[1], &
+ iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___36.ciunit = *nounit;
+ s_wsfe(&io___36);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+ abstol = unfl + unfl;
+ if (n <= 1) {
+ il = 1;
+ iu = n;
+ } else {
+ il = (n - 1) * slarnd_(&c__1, iseed2) + 1;
+ iu = (n - 1) * slarnd_(&c__1, iseed2) + 1;
+ if (il > iu) {
+ itemp = il;
+ il = iu;
+ iu = itemp;
+ }
+ }
+
+/* 3) Call CHEGV, CHPGV, CHBGV, CHEGVD, CHPGVD, CHBGVD, */
+/* CHEGVX, CHPGVX and CHBGVX, do tests. */
+
+/* loop over the three generalized problems */
+/* IBTYPE = 1: A*x = (lambda)*B*x */
+/* IBTYPE = 2: A*B*x = (lambda)*x */
+/* IBTYPE = 3: B*A*x = (lambda)*x */
+
+ for (ibtype = 1; ibtype <= 3; ++ibtype) {
+
+/* loop over the setting UPLO */
+
+ for (ibuplo = 1; ibuplo <= 2; ++ibuplo) {
+ if (ibuplo == 1) {
+ *(unsigned char *)uplo = 'U';
+ }
+ if (ibuplo == 2) {
+ *(unsigned char *)uplo = 'L';
+ }
+
+/* Generate random well-conditioned positive definite */
+/* matrix B, of bandwidth not greater than that of A. */
+
+ clatms_(&n, &n, "U", &iseed[1], "P", &rwork[1], &c__5, &
+ c_b78, &c_b33, &kb, &kb, uplo, &b[b_offset], ldb,
+ &work[n + 1], &iinfo);
+
+/* Test CHEGV */
+
+ ++ntest;
+
+ clacpy_(" ", &n, &n, &a[a_offset], lda, &z__[z_offset],
+ ldz);
+ clacpy_(uplo, &n, &n, &b[b_offset], ldb, &bb[bb_offset],
+ ldb);
+
+ chegv_(&ibtype, "V", uplo, &n, &z__[z_offset], ldz, &bb[
+ bb_offset], ldb, &d__[1], &work[1], nwork, &rwork[
+ 1], &iinfo);
+ if (iinfo != 0) {
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "CHEGV(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L100;
+ }
+ }
+
+/* Do Test */
+
+ csgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &rwork[1], &result[ntest]);
+
+/* Test CHEGVD */
+
+ ++ntest;
+
+ clacpy_(" ", &n, &n, &a[a_offset], lda, &z__[z_offset],
+ ldz);
+ clacpy_(uplo, &n, &n, &b[b_offset], ldb, &bb[bb_offset],
+ ldb);
+
+ chegvd_(&ibtype, "V", uplo, &n, &z__[z_offset], ldz, &bb[
+ bb_offset], ldb, &d__[1], &work[1], nwork, &rwork[
+ 1], lrwork, &iwork[1], liwork, &iinfo);
+ if (iinfo != 0) {
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "CHEGVD(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__2, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L100;
+ }
+ }
+
+/* Do Test */
+
+ csgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &rwork[1], &result[ntest]);
+
+/* Test CHEGVX */
+
+ ++ntest;
+
+ clacpy_(" ", &n, &n, &a[a_offset], lda, &ab[ab_offset],
+ lda);
+ clacpy_(uplo, &n, &n, &b[b_offset], ldb, &bb[bb_offset],
+ ldb);
+
+ chegvx_(&ibtype, "V", "A", uplo, &n, &ab[ab_offset], lda,
+ &bb[bb_offset], ldb, &vl, &vu, &il, &iu, &abstol,
+ &m, &d__[1], &z__[z_offset], ldz, &work[1], nwork,
+ &rwork[1], &iwork[n + 1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "CHEGVX(V,A";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L100;
+ }
+ }
+
+/* Do Test */
+
+ csgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &rwork[1], &result[ntest]);
+
+ ++ntest;
+
+ clacpy_(" ", &n, &n, &a[a_offset], lda, &ab[ab_offset],
+ lda);
+ clacpy_(uplo, &n, &n, &b[b_offset], ldb, &bb[bb_offset],
+ ldb);
+
+/* since we do not know the exact eigenvalues of this */
+/* eigenpair, we just set VL and VU as constants. */
+/* It is quite possible that there are no eigenvalues */
+/* in this interval. */
+
+ vl = 0.f;
+ vu = anorm;
+ chegvx_(&ibtype, "V", "V", uplo, &n, &ab[ab_offset], lda,
+ &bb[bb_offset], ldb, &vl, &vu, &il, &iu, &abstol,
+ &m, &d__[1], &z__[z_offset], ldz, &work[1], nwork,
+ &rwork[1], &iwork[n + 1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "CHEGVX(V,V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__4, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__4, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L100;
+ }
+ }
+
+/* Do Test */
+
+ csgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &rwork[1], &result[ntest]);
+
+ ++ntest;
+
+ clacpy_(" ", &n, &n, &a[a_offset], lda, &ab[ab_offset],
+ lda);
+ clacpy_(uplo, &n, &n, &b[b_offset], ldb, &bb[bb_offset],
+ ldb);
+
+ chegvx_(&ibtype, "V", "I", uplo, &n, &ab[ab_offset], lda,
+ &bb[bb_offset], ldb, &vl, &vu, &il, &iu, &abstol,
+ &m, &d__[1], &z__[z_offset], ldz, &work[1], nwork,
+ &rwork[1], &iwork[n + 1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "CHEGVX(V,I,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__4, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__4, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L100;
+ }
+ }
+
+/* Do Test */
+
+ csgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &rwork[1], &result[ntest]);
+
+L100:
+
+/* Test CHPGV */
+
+ ++ntest;
+
+/* Copy the matrices into packed storage. */
+
+ if (lsame_(uplo, "U")) {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ij;
+ i__7 = i__ + j * a_dim1;
+ ap[i__5].r = a[i__7].r, ap[i__5].i = a[i__7]
+ .i;
+ i__5 = ij;
+ i__7 = i__ + j * b_dim1;
+ bp[i__5].r = b[i__7].r, bp[i__5].i = b[i__7]
+ .i;
+ ++ij;
+/* L110: */
+ }
+/* L120: */
+ }
+ } else {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = ij;
+ i__7 = i__ + j * a_dim1;
+ ap[i__5].r = a[i__7].r, ap[i__5].i = a[i__7]
+ .i;
+ i__5 = ij;
+ i__7 = i__ + j * b_dim1;
+ bp[i__5].r = b[i__7].r, bp[i__5].i = b[i__7]
+ .i;
+ ++ij;
+/* L130: */
+ }
+/* L140: */
+ }
+ }
+
+ chpgv_(&ibtype, "V", uplo, &n, &ap[1], &bp[1], &d__[1], &
+ z__[z_offset], ldz, &work[1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "CHPGV(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L310;
+ }
+ }
+
+/* Do Test */
+
+ csgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &rwork[1], &result[ntest]);
+
+/* Test CHPGVD */
+
+ ++ntest;
+
+/* Copy the matrices into packed storage. */
+
+ if (lsame_(uplo, "U")) {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ij;
+ i__7 = i__ + j * a_dim1;
+ ap[i__5].r = a[i__7].r, ap[i__5].i = a[i__7]
+ .i;
+ i__5 = ij;
+ i__7 = i__ + j * b_dim1;
+ bp[i__5].r = b[i__7].r, bp[i__5].i = b[i__7]
+ .i;
+ ++ij;
+/* L150: */
+ }
+/* L160: */
+ }
+ } else {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = ij;
+ i__7 = i__ + j * a_dim1;
+ ap[i__5].r = a[i__7].r, ap[i__5].i = a[i__7]
+ .i;
+ i__5 = ij;
+ i__7 = i__ + j * b_dim1;
+ bp[i__5].r = b[i__7].r, bp[i__5].i = b[i__7]
+ .i;
+ ++ij;
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+
+ chpgvd_(&ibtype, "V", uplo, &n, &ap[1], &bp[1], &d__[1], &
+ z__[z_offset], ldz, &work[1], nwork, &rwork[1],
+ lrwork, &iwork[1], liwork, &iinfo);
+ if (iinfo != 0) {
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "CHPGVD(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__2, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L310;
+ }
+ }
+
+/* Do Test */
+
+ csgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &rwork[1], &result[ntest]);
+
+/* Test CHPGVX */
+
+ ++ntest;
+
+/* Copy the matrices into packed storage. */
+
+ if (lsame_(uplo, "U")) {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ij;
+ i__7 = i__ + j * a_dim1;
+ ap[i__5].r = a[i__7].r, ap[i__5].i = a[i__7]
+ .i;
+ i__5 = ij;
+ i__7 = i__ + j * b_dim1;
+ bp[i__5].r = b[i__7].r, bp[i__5].i = b[i__7]
+ .i;
+ ++ij;
+/* L190: */
+ }
+/* L200: */
+ }
+ } else {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = ij;
+ i__7 = i__ + j * a_dim1;
+ ap[i__5].r = a[i__7].r, ap[i__5].i = a[i__7]
+ .i;
+ i__5 = ij;
+ i__7 = i__ + j * b_dim1;
+ bp[i__5].r = b[i__7].r, bp[i__5].i = b[i__7]
+ .i;
+ ++ij;
+/* L210: */
+ }
+/* L220: */
+ }
+ }
+
+ chpgvx_(&ibtype, "V", "A", uplo, &n, &ap[1], &bp[1], &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &rwork[1], &iwork[n + 1]
+, &iwork[1], info);
+ if (iinfo != 0) {
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "CHPGVX(V,A";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L310;
+ }
+ }
+
+/* Do Test */
+
+ csgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &rwork[1], &result[ntest]);
+
+ ++ntest;
+
+/* Copy the matrices into packed storage. */
+
+ if (lsame_(uplo, "U")) {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ij;
+ i__7 = i__ + j * a_dim1;
+ ap[i__5].r = a[i__7].r, ap[i__5].i = a[i__7]
+ .i;
+ i__5 = ij;
+ i__7 = i__ + j * b_dim1;
+ bp[i__5].r = b[i__7].r, bp[i__5].i = b[i__7]
+ .i;
+ ++ij;
+/* L230: */
+ }
+/* L240: */
+ }
+ } else {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = ij;
+ i__7 = i__ + j * a_dim1;
+ ap[i__5].r = a[i__7].r, ap[i__5].i = a[i__7]
+ .i;
+ i__5 = ij;
+ i__7 = i__ + j * b_dim1;
+ bp[i__5].r = b[i__7].r, bp[i__5].i = b[i__7]
+ .i;
+ ++ij;
+/* L250: */
+ }
+/* L260: */
+ }
+ }
+
+ vl = 0.f;
+ vu = anorm;
+ chpgvx_(&ibtype, "V", "V", uplo, &n, &ap[1], &bp[1], &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &rwork[1], &iwork[n + 1]
+, &iwork[1], info);
+ if (iinfo != 0) {
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "CHPGVX(V,V";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L310;
+ }
+ }
+
+/* Do Test */
+
+ csgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &rwork[1], &result[ntest]);
+
+ ++ntest;
+
+/* Copy the matrices into packed storage. */
+
+ if (lsame_(uplo, "U")) {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ij;
+ i__7 = i__ + j * a_dim1;
+ ap[i__5].r = a[i__7].r, ap[i__5].i = a[i__7]
+ .i;
+ i__5 = ij;
+ i__7 = i__ + j * b_dim1;
+ bp[i__5].r = b[i__7].r, bp[i__5].i = b[i__7]
+ .i;
+ ++ij;
+/* L270: */
+ }
+/* L280: */
+ }
+ } else {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = ij;
+ i__7 = i__ + j * a_dim1;
+ ap[i__5].r = a[i__7].r, ap[i__5].i = a[i__7]
+ .i;
+ i__5 = ij;
+ i__7 = i__ + j * b_dim1;
+ bp[i__5].r = b[i__7].r, bp[i__5].i = b[i__7]
+ .i;
+ ++ij;
+/* L290: */
+ }
+/* L300: */
+ }
+ }
+
+ chpgvx_(&ibtype, "V", "I", uplo, &n, &ap[1], &bp[1], &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &rwork[1], &iwork[n + 1]
+, &iwork[1], info);
+ if (iinfo != 0) {
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "CHPGVX(V,I";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L310;
+ }
+ }
+
+/* Do Test */
+
+ csgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &rwork[1], &result[ntest]);
+
+L310:
+
+ if (ibtype == 1) {
+
+/* TEST CHBGV */
+
+ ++ntest;
+
+/* Copy the matrices into band storage. */
+
+ if (lsame_(uplo, "U")) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - ka;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__)
+ {
+ i__4 = ka + 1 + i__ - j + j * ab_dim1;
+ i__5 = i__ + j * a_dim1;
+ ab[i__4].r = a[i__5].r, ab[i__4].i = a[
+ i__5].i;
+/* L320: */
+ }
+/* Computing MAX */
+ i__7 = 1, i__4 = j - kb;
+ i__5 = j;
+ for (i__ = max(i__7,i__4); i__ <= i__5; ++i__)
+ {
+ i__7 = kb + 1 + i__ - j + j * bb_dim1;
+ i__4 = i__ + j * b_dim1;
+ bb[i__7].r = b[i__4].r, bb[i__7].i = b[
+ i__4].i;
+/* L330: */
+ }
+/* L340: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__7 = n, i__4 = j + ka;
+ i__5 = min(i__7,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ i__7 = i__ + 1 - j + j * ab_dim1;
+ i__4 = i__ + j * a_dim1;
+ ab[i__7].r = a[i__4].r, ab[i__7].i = a[
+ i__4].i;
+/* L350: */
+ }
+/* Computing MIN */
+ i__7 = n, i__4 = j + kb;
+ i__5 = min(i__7,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ i__7 = i__ + 1 - j + j * bb_dim1;
+ i__4 = i__ + j * b_dim1;
+ bb[i__7].r = b[i__4].r, bb[i__7].i = b[
+ i__4].i;
+/* L360: */
+ }
+/* L370: */
+ }
+ }
+
+ chbgv_("V", uplo, &n, &ka, &kb, &ab[ab_offset], lda, &
+ bb[bb_offset], ldb, &d__[1], &z__[z_offset],
+ ldz, &work[1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "CHBGV(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L620;
+ }
+ }
+
+/* Do Test */
+
+ csgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1],
+ &work[1], &rwork[1], &result[ntest]);
+
+/* TEST CHBGVD */
+
+ ++ntest;
+
+/* Copy the matrices into band storage. */
+
+ if (lsame_(uplo, "U")) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__7 = j - ka;
+ i__4 = j;
+ for (i__ = max(i__5,i__7); i__ <= i__4; ++i__)
+ {
+ i__5 = ka + 1 + i__ - j + j * ab_dim1;
+ i__7 = i__ + j * a_dim1;
+ ab[i__5].r = a[i__7].r, ab[i__5].i = a[
+ i__7].i;
+/* L380: */
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kb;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__)
+ {
+ i__4 = kb + 1 + i__ - j + j * bb_dim1;
+ i__5 = i__ + j * b_dim1;
+ bb[i__4].r = b[i__5].r, bb[i__4].i = b[
+ i__5].i;
+/* L390: */
+ }
+/* L400: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + ka;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ i__4 = i__ + 1 - j + j * ab_dim1;
+ i__5 = i__ + j * a_dim1;
+ ab[i__4].r = a[i__5].r, ab[i__4].i = a[
+ i__5].i;
+/* L410: */
+ }
+/* Computing MIN */
+ i__4 = n, i__5 = j + kb;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ i__4 = i__ + 1 - j + j * bb_dim1;
+ i__5 = i__ + j * b_dim1;
+ bb[i__4].r = b[i__5].r, bb[i__4].i = b[
+ i__5].i;
+/* L420: */
+ }
+/* L430: */
+ }
+ }
+
+ chbgvd_("V", uplo, &n, &ka, &kb, &ab[ab_offset], lda,
+ &bb[bb_offset], ldb, &d__[1], &z__[z_offset],
+ ldz, &work[1], nwork, &rwork[1], lrwork, &
+ iwork[1], liwork, &iinfo);
+ if (iinfo != 0) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "CHBGVD(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__2, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L620;
+ }
+ }
+
+/* Do Test */
+
+ csgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1],
+ &work[1], &rwork[1], &result[ntest]);
+
+/* Test CHBGVX */
+
+ ++ntest;
+
+/* Copy the matrices into band storage. */
+
+ if (lsame_(uplo, "U")) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__7 = 1, i__4 = j - ka;
+ i__5 = j;
+ for (i__ = max(i__7,i__4); i__ <= i__5; ++i__)
+ {
+ i__7 = ka + 1 + i__ - j + j * ab_dim1;
+ i__4 = i__ + j * a_dim1;
+ ab[i__7].r = a[i__4].r, ab[i__7].i = a[
+ i__4].i;
+/* L440: */
+ }
+/* Computing MAX */
+ i__5 = 1, i__7 = j - kb;
+ i__4 = j;
+ for (i__ = max(i__5,i__7); i__ <= i__4; ++i__)
+ {
+ i__5 = kb + 1 + i__ - j + j * bb_dim1;
+ i__7 = i__ + j * b_dim1;
+ bb[i__5].r = b[i__7].r, bb[i__5].i = b[
+ i__7].i;
+/* L450: */
+ }
+/* L460: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__5 = n, i__7 = j + ka;
+ i__4 = min(i__5,i__7);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = i__ + 1 - j + j * ab_dim1;
+ i__7 = i__ + j * a_dim1;
+ ab[i__5].r = a[i__7].r, ab[i__5].i = a[
+ i__7].i;
+/* L470: */
+ }
+/* Computing MIN */
+ i__5 = n, i__7 = j + kb;
+ i__4 = min(i__5,i__7);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = i__ + 1 - j + j * bb_dim1;
+ i__7 = i__ + j * b_dim1;
+ bb[i__5].r = b[i__7].r, bb[i__5].i = b[
+ i__7].i;
+/* L480: */
+ }
+/* L490: */
+ }
+ }
+
+ i__3 = max(1,n);
+ chbgvx_("V", "A", uplo, &n, &ka, &kb, &ab[ab_offset],
+ lda, &bb[bb_offset], ldb, &bp[1], &i__3, &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &rwork[1], &iwork[n
+ + 1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___60.ciunit = *nounit;
+ s_wsfe(&io___60);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "CHBGVX(V,A";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L620;
+ }
+ }
+
+/* Do Test */
+
+ csgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1],
+ &work[1], &rwork[1], &result[ntest]);
+
+ ++ntest;
+
+/* Copy the matrices into band storage. */
+
+ if (lsame_(uplo, "U")) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - ka;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__)
+ {
+ i__4 = ka + 1 + i__ - j + j * ab_dim1;
+ i__5 = i__ + j * a_dim1;
+ ab[i__4].r = a[i__5].r, ab[i__4].i = a[
+ i__5].i;
+/* L500: */
+ }
+/* Computing MAX */
+ i__7 = 1, i__4 = j - kb;
+ i__5 = j;
+ for (i__ = max(i__7,i__4); i__ <= i__5; ++i__)
+ {
+ i__7 = kb + 1 + i__ - j + j * bb_dim1;
+ i__4 = i__ + j * b_dim1;
+ bb[i__7].r = b[i__4].r, bb[i__7].i = b[
+ i__4].i;
+/* L510: */
+ }
+/* L520: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__7 = n, i__4 = j + ka;
+ i__5 = min(i__7,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ i__7 = i__ + 1 - j + j * ab_dim1;
+ i__4 = i__ + j * a_dim1;
+ ab[i__7].r = a[i__4].r, ab[i__7].i = a[
+ i__4].i;
+/* L530: */
+ }
+/* Computing MIN */
+ i__7 = n, i__4 = j + kb;
+ i__5 = min(i__7,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ i__7 = i__ + 1 - j + j * bb_dim1;
+ i__4 = i__ + j * b_dim1;
+ bb[i__7].r = b[i__4].r, bb[i__7].i = b[
+ i__4].i;
+/* L540: */
+ }
+/* L550: */
+ }
+ }
+
+ vl = 0.f;
+ vu = anorm;
+ i__3 = max(1,n);
+ chbgvx_("V", "V", uplo, &n, &ka, &kb, &ab[ab_offset],
+ lda, &bb[bb_offset], ldb, &bp[1], &i__3, &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &rwork[1], &iwork[n
+ + 1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___61.ciunit = *nounit;
+ s_wsfe(&io___61);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "CHBGVX(V,V";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L620;
+ }
+ }
+
+/* Do Test */
+
+ csgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1],
+ &work[1], &rwork[1], &result[ntest]);
+
+ ++ntest;
+
+/* Copy the matrices into band storage. */
+
+ if (lsame_(uplo, "U")) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__7 = j - ka;
+ i__4 = j;
+ for (i__ = max(i__5,i__7); i__ <= i__4; ++i__)
+ {
+ i__5 = ka + 1 + i__ - j + j * ab_dim1;
+ i__7 = i__ + j * a_dim1;
+ ab[i__5].r = a[i__7].r, ab[i__5].i = a[
+ i__7].i;
+/* L560: */
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kb;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__)
+ {
+ i__4 = kb + 1 + i__ - j + j * bb_dim1;
+ i__5 = i__ + j * b_dim1;
+ bb[i__4].r = b[i__5].r, bb[i__4].i = b[
+ i__5].i;
+/* L570: */
+ }
+/* L580: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + ka;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ i__4 = i__ + 1 - j + j * ab_dim1;
+ i__5 = i__ + j * a_dim1;
+ ab[i__4].r = a[i__5].r, ab[i__4].i = a[
+ i__5].i;
+/* L590: */
+ }
+/* Computing MIN */
+ i__4 = n, i__5 = j + kb;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ i__4 = i__ + 1 - j + j * bb_dim1;
+ i__5 = i__ + j * b_dim1;
+ bb[i__4].r = b[i__5].r, bb[i__4].i = b[
+ i__5].i;
+/* L600: */
+ }
+/* L610: */
+ }
+ }
+
+ i__3 = max(1,n);
+ chbgvx_("V", "I", uplo, &n, &ka, &kb, &ab[ab_offset],
+ lda, &bb[bb_offset], ldb, &bp[1], &i__3, &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &rwork[1], &iwork[n
+ + 1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___62.ciunit = *nounit;
+ s_wsfe(&io___62);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "CHBGVX(V,I";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L620;
+ }
+ }
+
+/* Do Test */
+
+ csgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1],
+ &work[1], &rwork[1], &result[ntest]);
+
+ }
+
+L620:
+ ;
+ }
+/* L630: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+ ntestt += ntest;
+ slafts_("CSG", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh,
+ nounit, &nerrs);
+L640:
+ ;
+ }
+/* L650: */
+ }
+
+/* Summary */
+
+ slasum_("CSG", nounit, &nerrs, &ntestt);
+
+ return 0;
+
+
+/* End of CDRVSG */
+
+} /* cdrvsg_ */
diff --git a/TESTING/EIG/cdrvst.c b/TESTING/EIG/cdrvst.c
new file mode 100644
index 0000000..2f6e2eb
--- /dev/null
+++ b/TESTING/EIG/cdrvst.c
@@ -0,0 +1,3200 @@
+/* cdrvst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__6 = 6;
+static real c_b34 = 1.f;
+static integer c__1 = 1;
+static real c_b44 = 0.f;
+static integer c__4 = 4;
+static integer c__3 = 3;
+
+/* Subroutine */ int cdrvst_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, integer *nounit,
+ complex *a, integer *lda, real *d1, real *d2, real *d3, real *wa1,
+ real *wa2, real *wa3, complex *u, integer *ldu, complex *v, complex *
+ tau, complex *z__, complex *work, integer *lwork, real *rwork,
+ integer *lrwork, integer *iwork, integer *liwork, real *result,
+ integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[18] = { 1,2,4,4,4,4,4,5,5,5,5,5,8,8,8,9,9,9 };
+ static integer kmagn[18] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3,1,2,3 };
+ static integer kmode[18] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0,4,4,4 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 CDRVST: \002,a,\002 returned INFO=\002,i"
+ "6,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED=(\002,3(i5"
+ ",\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 CDRVST: \002,a,\002 returned INFO=\002,i"
+ "6,/9x,\002N=\002,i6,\002, KD=\002,i6,\002, JTYPE=\002,i6,\002, I"
+ "SEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+
+ /* System generated locals */
+ address a__1[3];
+ integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, z_dim1,
+ z_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7[3];
+ real r__1, r__2, r__3, r__4;
+ char ch__1[11], ch__2[13], ch__3[10];
+
+ /* Builtin functions */
+ double sqrt(doublereal), log(doublereal);
+ integer pow_ii(integer *, integer *), s_wsfe(cilist *), do_fio(integer *,
+ char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, m, n, j1, j2, m2, m3, kd, il, iu;
+ real vl, vu;
+ integer lgn;
+ real ulp, cond;
+ integer jcol, ihbw, indx, nmax;
+ real unfl, ovfl;
+ char uplo[1];
+ integer irow;
+ real temp1, temp2, temp3;
+ integer idiag;
+ logical badnn;
+ extern doublereal ssxt1_(integer *, real *, integer *, real *, integer *,
+ real *, real *, real *);
+ extern /* Subroutine */ int chet21_(integer *, char *, integer *, integer
+ *, complex *, integer *, real *, real *, complex *, integer *,
+ complex *, integer *, complex *, complex *, real *, real *), chbev_(char *, char *, integer *, integer *, complex *,
+ integer *, real *, complex *, integer *, complex *, real *,
+ integer *), chet22_(integer *, char *, integer *,
+ integer *, integer *, complex *, integer *, real *, real *,
+ complex *, integer *, complex *, integer *, complex *, complex *,
+ real *, real *), cheev_(char *, char *, integer *,
+ complex *, integer *, real *, complex *, integer *, real *,
+ integer *);
+ integer imode, lwedc, iinfo;
+ extern /* Subroutine */ int chpev_(char *, char *, integer *, complex *,
+ real *, complex *, integer *, complex *, real *, integer *);
+ real aninv, anorm;
+ integer itemp, nmats, jsize, iuplo, nerrs, itype, jtype, ntest, iseed2[4],
+ iseed3[4];
+ extern /* Subroutine */ int slabad_(real *, real *), chbevd_(char *, char
+ *, integer *, integer *, complex *, integer *, real *, complex *,
+ integer *, complex *, integer *, real *, integer *, integer *,
+ integer *, integer *), cheevd_(char *, char *,
+ integer *, complex *, integer *, real *, complex *, integer *,
+ real *, integer *, integer *, integer *, integer *);
+ integer liwedc;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int chpevd_(char *, char *, integer *, complex *,
+ real *, complex *, integer *, complex *, integer *, real *,
+ integer *, integer *, integer *, integer *),
+ clacpy_(char *, integer *, integer *, complex *, integer *,
+ complex *, integer *);
+ integer idumma[1];
+ extern /* Subroutine */ int cheevr_(char *, char *, char *, integer *,
+ complex *, integer *, real *, real *, integer *, integer *, real *
+, integer *, real *, complex *, integer *, integer *, complex *,
+ integer *, real *, integer *, integer *, integer *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int chbevx_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, real *, complex *
+, integer *, complex *, real *, integer *, integer *, integer *);
+ integer lrwedc;
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), cheevx_(char *, char
+ *, char *, integer *, complex *, integer *, real *, real *,
+ integer *, integer *, real *, integer *, real *, complex *,
+ integer *, complex *, integer *, real *, integer *, integer *,
+ integer *);
+ extern doublereal slarnd_(integer *, integer *);
+ real abstol;
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *), clatmr_(integer *, integer *, char *,
+ integer *, char *, complex *, integer *, real *, complex *, char *
+, char *, complex *, integer *, real *, complex *, integer *,
+ real *, char *, integer *, integer *, integer *, real *, real *,
+ char *, complex *, integer *, integer *, integer *), clatms_(integer *,
+ integer *, char *, integer *, char *, real *, integer *, real *,
+ real *, integer *, integer *, char *, complex *, integer *,
+ complex *, integer *), xerbla_(char *,
+ integer *), slafts_(char *, integer *, integer *, integer
+ *, integer *, real *, integer *, real *, integer *, integer *);
+ integer indwrk;
+ extern /* Subroutine */ int chpevx_(char *, char *, char *, integer *,
+ complex *, real *, real *, integer *, integer *, real *, integer *
+, real *, complex *, integer *, complex *, real *, integer *,
+ integer *, integer *);
+ real rtunfl, rtovfl, ulpinv;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___68 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___69 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___70 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___71 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___72 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___73 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___74 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___76 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___77 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___80 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___81 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___82 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___83 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___84 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___85 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___86 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___87 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___88 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___89 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___90 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___91 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___92 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___93 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___94 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___95 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVST checks the Hermitian eigenvalue problem drivers. */
+
+/* CHEEVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian matrix, */
+/* using a divide-and-conquer algorithm. */
+
+/* CHEEVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian matrix. */
+
+/* CHEEVR computes selected eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian matrix */
+/* using the Relatively Robust Representation where it can. */
+
+/* CHPEVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian matrix in packed */
+/* storage, using a divide-and-conquer algorithm. */
+
+/* CHPEVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian matrix in packed */
+/* storage. */
+
+/* CHBEVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian band matrix, */
+/* using a divide-and-conquer algorithm. */
+
+/* CHBEVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian band matrix. */
+
+/* CHEEV computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian matrix. */
+
+/* CHPEV computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian matrix in packed */
+/* storage. */
+
+/* CHBEV computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian band matrix. */
+
+/* When CDRVST is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the appropriate drivers. For each matrix and each */
+/* driver routine called, the following tests will be performed: */
+
+/* (1) | A - Z D Z' | / ( |A| n ulp ) */
+
+/* (2) | I - Z Z' | / ( n ulp ) */
+
+/* (3) | D1 - D2 | / ( |D1| ulp ) */
+
+/* where Z is the matrix of eigenvectors returned when the */
+/* eigenvector option is given and D1 and D2 are the eigenvalues */
+/* returned with and without the eigenvector option. */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (6) Same as (4), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (4), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U* D U, where U is unitary and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U* D U, where U is unitary and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U* D U, where U is unitary and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) Symmetric matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
+/* (16) A band matrix with half bandwidth randomly chosen between */
+/* 0 and N-1, with evenly spaced eigenvalues 1, ..., ULP */
+/* with random signs. */
+/* (17) Same as (16), but multiplied by SQRT( overflow threshold ) */
+/* (18) Same as (16), but multiplied by SQRT( underflow threshold ) */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* CDRVST does nothing. It must be at least zero. */
+/* Not modified. */
+
+/* NN INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+/* Not modified. */
+
+/* NTYPES INTEGER */
+/* The number of elements in DOTYPE. If it is zero, CDRVST */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+/* Not modified. */
+
+/* DOTYPE LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+/* Not modified. */
+
+/* ISEED INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to CDRVST to continue the same random number */
+/* sequence. */
+/* Modified. */
+
+/* THRESH REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+/* Not modified. */
+
+/* NOUNIT INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+/* Not modified. */
+
+/* A COMPLEX array, dimension (LDA , max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually */
+/* used. */
+/* Modified. */
+
+/* LDA INTEGER */
+/* The leading dimension of A. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* D1 REAL array, dimension (max(NN)) */
+/* The eigenvalues of A, as computed by CSTEQR simlutaneously */
+/* with Z. On exit, the eigenvalues in D1 correspond with the */
+/* matrix in A. */
+/* Modified. */
+
+/* D2 REAL array, dimension (max(NN)) */
+/* The eigenvalues of A, as computed by CSTEQR if Z is not */
+/* computed. On exit, the eigenvalues in D2 correspond with */
+/* the matrix in A. */
+/* Modified. */
+
+/* D3 REAL array, dimension (max(NN)) */
+/* The eigenvalues of A, as computed by SSTERF. On exit, the */
+/* eigenvalues in D3 correspond with the matrix in A. */
+/* Modified. */
+
+/* WA1 REAL array, dimension */
+
+/* WA2 REAL array, dimension */
+
+/* WA3 REAL array, dimension */
+
+/* U COMPLEX array, dimension (LDU, max(NN)) */
+/* The unitary matrix computed by CHETRD + CUNGC3. */
+/* Modified. */
+
+/* LDU INTEGER */
+/* The leading dimension of U, Z, and V. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* V COMPLEX array, dimension (LDU, max(NN)) */
+/* The Housholder vectors computed by CHETRD in reducing A to */
+/* tridiagonal form. */
+/* Modified. */
+
+/* TAU COMPLEX array, dimension (max(NN)) */
+/* The Householder factors computed by CHETRD in reducing A */
+/* to tridiagonal form. */
+/* Modified. */
+
+/* Z COMPLEX array, dimension (LDU, max(NN)) */
+/* The unitary matrix of eigenvectors computed by CHEEVD, */
+/* CHEEVX, CHPEVD, CHPEVX, CHBEVD, and CHBEVX. */
+/* Modified. */
+
+/* WORK - COMPLEX array of dimension ( LWORK ) */
+/* Workspace. */
+/* Modified. */
+
+/* LWORK - INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 2*max( NN(j), 2 )**2. */
+/* Not modified. */
+
+/* RWORK REAL array, dimension (3*max(NN)) */
+/* Workspace. */
+/* Modified. */
+
+/* LRWORK - INTEGER */
+/* The number of entries in RWORK. */
+
+/* IWORK INTEGER array, dimension (6*max(NN)) */
+/* Workspace. */
+/* Modified. */
+
+/* LIWORK - INTEGER */
+/* The number of entries in IWORK. */
+
+/* RESULT REAL array, dimension (??) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+/* Modified. */
+
+/* INFO INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -5: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -16: LDU < 1 or LDU < NMAX. */
+/* -21: LWORK too small. */
+/* If SLATMR, SLATMS, CHETRD, SORGC3, CSTEQR, SSTERF, */
+/* or SORMC2 returns an error code, the */
+/* absolute value of it is returned. */
+/* Modified. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests performed, or which can */
+/* be performed so far, for the current matrix. */
+/* NTESTT The total number of tests performed so far. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far (computed by SLAFTS). */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* ===================================================================== */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d1;
+ --d2;
+ --d3;
+ --wa1;
+ --wa2;
+ --wa3;
+ z_dim1 = *ldu;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ v_dim1 = *ldu;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --tau;
+ --work;
+ --rwork;
+ --iwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*lda < nmax) {
+ *info = -9;
+ } else if (*ldu < nmax) {
+ *info = -16;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = max(2,nmax);
+ if (i__1 * i__1 << 1 > *lwork) {
+ *info = -22;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CDRVST", &i__1);
+ return 0;
+ }
+
+/* Quick return if nothing to do */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = slamch_("Safe minimum");
+ ovfl = slamch_("Overflow");
+ slabad_(&unfl, &ovfl);
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ ulpinv = 1.f / ulp;
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+
+/* Loop over sizes, types */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed2[i__ - 1] = iseed[i__];
+ iseed3[i__ - 1] = iseed[i__];
+/* L20: */
+ }
+
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (n > 0) {
+ lgn = (integer) (log((real) n) / log(2.f));
+ if (pow_ii(&c__2, &lgn) < n) {
+ ++lgn;
+ }
+ if (pow_ii(&c__2, &lgn) < n) {
+ ++lgn;
+ }
+/* Computing MAX */
+ i__2 = (n << 1) + n * n, i__3 = (n << 1) * n;
+ lwedc = max(i__2,i__3);
+/* Computing 2nd power */
+ i__2 = n;
+ lrwedc = (n << 2) + 1 + (n << 1) * lgn + i__2 * i__2 * 3;
+ liwedc = n * 5 + 3;
+ } else {
+ lwedc = 2;
+ lrwedc = 8;
+ liwedc = 8;
+ }
+ aninv = 1.f / (real) max(1,n);
+
+ if (*nsizes != 1) {
+ mtypes = min(18,*ntypes);
+ } else {
+ mtypes = min(19,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L1210;
+ }
+ ++nmats;
+ ntest = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L30: */
+ }
+
+/* 2) Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log Hermitian, w/ eigenvalues */
+/* =6 random (none) */
+/* =7 random diagonal */
+/* =8 random Hermitian */
+/* =9 band Hermitian, w/ eigenvalues */
+
+ if (mtypes > 18) {
+ goto L110;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.f;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * aninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * n * ulpinv;
+ goto L70;
+
+L70:
+
+ claset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ a[i__4].r = anorm, a[i__4].i = 0.f;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[
+ 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Hermitian, eigenvalues specified */
+
+ clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[1], &
+ iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ clatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &c_b34,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b34, &work[(
+ n << 1) + 1], &c__1, &c_b34, "N", idumma, &c__0, &
+ c__0, &c_b44, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Hermitian, random eigenvalues */
+
+ clatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &c_b34,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b34, &work[(
+ n << 1) + 1], &c__1, &c_b34, "N", idumma, &n, &n, &
+ c_b44, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* Hermitian banded, eigenvalues specified */
+
+ ihbw = (integer) ((n - 1) * slarnd_(&c__1, iseed3));
+ clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &ihbw, &ihbw, "Z", &u[u_offset], ldu, &work[
+ 1], &iinfo);
+
+/* Store as dense matrix for most routines. */
+
+ claset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ i__3 = ihbw;
+ for (idiag = -ihbw; idiag <= i__3; ++idiag) {
+ irow = ihbw - idiag + 1;
+/* Computing MAX */
+ i__4 = 1, i__5 = idiag + 1;
+ j1 = max(i__4,i__5);
+/* Computing MIN */
+ i__4 = n, i__5 = n + idiag;
+ j2 = min(i__4,i__5);
+ i__4 = j2;
+ for (j = j1; j <= i__4; ++j) {
+ i__ = j - idiag;
+ i__5 = i__ + j * a_dim1;
+ i__6 = irow + j * u_dim1;
+ a[i__5].r = u[i__6].r, a[i__5].i = u[i__6].i;
+/* L90: */
+ }
+/* L100: */
+ }
+ } else {
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L110:
+
+ abstol = unfl + unfl;
+ if (n <= 1) {
+ il = 1;
+ iu = n;
+ } else {
+ il = (integer) ((n - 1) * slarnd_(&c__1, iseed2)) + 1;
+ iu = (integer) ((n - 1) * slarnd_(&c__1, iseed2)) + 1;
+ if (il > iu) {
+ itemp = il;
+ il = iu;
+ iu = itemp;
+ }
+ }
+
+/* Perform tests storing upper or lower triangular */
+/* part of matrix. */
+
+ for (iuplo = 0; iuplo <= 1; ++iuplo) {
+ if (iuplo == 0) {
+ *(unsigned char *)uplo = 'L';
+ } else {
+ *(unsigned char *)uplo = 'U';
+ }
+
+/* Call CHEEVD and CHEEVX. */
+
+ clacpy_(" ", &n, &n, &a[a_offset], lda, &v[v_offset], ldu);
+
+ ++ntest;
+ cheevd_("V", uplo, &n, &a[a_offset], ldu, &d1[1], &work[1], &
+ lwedc, &rwork[1], &lrwedc, &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+/* Writing concatenation */
+ i__7[0] = 9, a__1[0] = "CHEEVD(V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__7, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__1, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L130;
+ }
+ }
+
+/* Do tests 1 and 2. */
+
+ chet21_(&c__1, uplo, &n, &c__0, &v[v_offset], ldu, &d1[1], &
+ d2[1], &a[a_offset], ldu, &z__[z_offset], ldu, &tau[1]
+, &work[1], &rwork[1], &result[ntest]);
+
+ clacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ ntest += 2;
+ cheevd_("N", uplo, &n, &a[a_offset], ldu, &d3[1], &work[1], &
+ lwedc, &rwork[1], &lrwedc, &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+/* Writing concatenation */
+ i__7[0] = 9, a__1[0] = "CHEEVD(N,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__7, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__1, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L130;
+ }
+ }
+
+/* Do test 3. */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d1[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = d3[j], dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d1[j] - d3[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L120: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[ntest] = temp2 / dmax(r__1,r__2);
+
+L130:
+ clacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ ++ntest;
+
+ if (n > 0) {
+/* Computing MAX */
+ r__2 = dabs(d1[1]), r__3 = (r__1 = d1[n], dabs(r__1));
+ temp3 = dmax(r__2,r__3);
+ if (il != 1) {
+/* Computing MAX */
+ r__1 = (d1[il] - d1[il - 1]) * .5f, r__2 = ulp * 10.f
+ * temp3, r__1 = max(r__1,r__2), r__2 = rtunfl
+ * 10.f;
+ vl = d1[il] - dmax(r__1,r__2);
+ } else if (n > 0) {
+/* Computing MAX */
+ r__1 = (d1[n] - d1[1]) * .5f, r__2 = ulp * 10.f *
+ temp3, r__1 = max(r__1,r__2), r__2 = rtunfl *
+ 10.f;
+ vl = d1[1] - dmax(r__1,r__2);
+ }
+ if (iu != n) {
+/* Computing MAX */
+ r__1 = (d1[iu + 1] - d1[iu]) * .5f, r__2 = ulp * 10.f
+ * temp3, r__1 = max(r__1,r__2), r__2 = rtunfl
+ * 10.f;
+ vu = d1[iu] + dmax(r__1,r__2);
+ } else if (n > 0) {
+/* Computing MAX */
+ r__1 = (d1[n] - d1[1]) * .5f, r__2 = ulp * 10.f *
+ temp3, r__1 = max(r__1,r__2), r__2 = rtunfl *
+ 10.f;
+ vu = d1[n] + dmax(r__1,r__2);
+ }
+ } else {
+ temp3 = 0.f;
+ vl = 0.f;
+ vu = 1.f;
+ }
+
+ cheevx_("V", "A", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m, &wa1[1], &z__[z_offset], ldu, &work[
+ 1], lwork, &rwork[1], &iwork[1], &iwork[n * 5 + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHEEVX(V,A,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L150;
+ }
+ }
+
+/* Do tests 4 and 5. */
+
+ clacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ chet21_(&c__1, uplo, &n, &c__0, &a[a_offset], ldu, &wa1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+ cheevx_("N", "A", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ work[1], lwork, &rwork[1], &iwork[1], &iwork[n * 5 +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHEEVX(N,A,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L150;
+ }
+ }
+
+/* Do test 6. */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = wa1[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = wa2[j], dabs(r__2))
+ ;
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = wa1[j] - wa2[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L140: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[ntest] = temp2 / dmax(r__1,r__2);
+
+L150:
+ clacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ ++ntest;
+
+ cheevx_("V", "I", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ work[1], lwork, &rwork[1], &iwork[1], &iwork[n * 5 +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ io___60.ciunit = *nounit;
+ s_wsfe(&io___60);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHEEVX(V,I,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L160;
+ }
+ }
+
+/* Do tests 7 and 8. */
+
+ clacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ chet22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+
+ cheevx_("N", "I", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m3, &wa3[1], &z__[z_offset], ldu, &
+ work[1], lwork, &rwork[1], &iwork[1], &iwork[n * 5 +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ io___62.ciunit = *nounit;
+ s_wsfe(&io___62);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHEEVX(N,I,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L160;
+ }
+ }
+
+/* Do test 9. */
+
+ temp1 = ssxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = ssxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ r__2 = dabs(wa1[1]), r__3 = (r__1 = wa1[n], dabs(r__1));
+ temp3 = dmax(r__2,r__3);
+ } else {
+ temp3 = 0.f;
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / dmax(r__1,r__2);
+
+L160:
+ clacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ ++ntest;
+
+ cheevx_("V", "V", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ work[1], lwork, &rwork[1], &iwork[1], &iwork[n * 5 +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ io___63.ciunit = *nounit;
+ s_wsfe(&io___63);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHEEVX(V,V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L170;
+ }
+ }
+
+/* Do tests 10 and 11. */
+
+ clacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ chet22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+
+ cheevx_("N", "V", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m3, &wa3[1], &z__[z_offset], ldu, &
+ work[1], lwork, &rwork[1], &iwork[1], &iwork[n * 5 +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ io___64.ciunit = *nounit;
+ s_wsfe(&io___64);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHEEVX(N,V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L170;
+ }
+ }
+
+ if (m3 == 0 && n > 0) {
+ result[ntest] = ulpinv;
+ goto L170;
+ }
+
+/* Do test 12. */
+
+ temp1 = ssxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = ssxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ r__2 = dabs(wa1[1]), r__3 = (r__1 = wa1[n], dabs(r__1));
+ temp3 = dmax(r__2,r__3);
+ } else {
+ temp3 = 0.f;
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / dmax(r__1,r__2);
+
+L170:
+
+/* Call CHPEVD and CHPEVX. */
+
+ clacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+/* Load array WORK with the upper or lower triangular */
+/* part of the matrix in packed form. */
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L180: */
+ }
+/* L190: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L200: */
+ }
+/* L210: */
+ }
+ }
+
+ ++ntest;
+ indwrk = n * (n + 1) / 2 + 1;
+ chpevd_("V", uplo, &n, &work[1], &d1[1], &z__[z_offset], ldu,
+ &work[indwrk], &lwedc, &rwork[1], &lrwedc, &iwork[1],
+ &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___67.ciunit = *nounit;
+ s_wsfe(&io___67);
+/* Writing concatenation */
+ i__7[0] = 9, a__1[0] = "CHPEVD(V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__7, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__1, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L270;
+ }
+ }
+
+/* Do tests 13 and 14. */
+
+ chet21_(&c__1, uplo, &n, &c__0, &a[a_offset], lda, &d1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &rwork[1], &result[ntest]);
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L220: */
+ }
+/* L230: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L240: */
+ }
+/* L250: */
+ }
+ }
+
+ ntest += 2;
+ indwrk = n * (n + 1) / 2 + 1;
+ chpevd_("N", uplo, &n, &work[1], &d3[1], &z__[z_offset], ldu,
+ &work[indwrk], &lwedc, &rwork[1], &lrwedc, &iwork[1],
+ &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___68.ciunit = *nounit;
+ s_wsfe(&io___68);
+/* Writing concatenation */
+ i__7[0] = 9, a__1[0] = "CHPEVD(N,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__7, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__1, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L270;
+ }
+ }
+
+/* Do test 15. */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d1[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = d3[j], dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d1[j] - d3[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L260: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[ntest] = temp2 / dmax(r__1,r__2);
+
+/* Load array WORK with the upper or lower triangular part */
+/* of the matrix in packed form. */
+
+L270:
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L280: */
+ }
+/* L290: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L300: */
+ }
+/* L310: */
+ }
+ }
+
+ ++ntest;
+
+ if (n > 0) {
+/* Computing MAX */
+ r__2 = dabs(d1[1]), r__3 = (r__1 = d1[n], dabs(r__1));
+ temp3 = dmax(r__2,r__3);
+ if (il != 1) {
+/* Computing MAX */
+ r__1 = (d1[il] - d1[il - 1]) * .5f, r__2 = ulp * 10.f
+ * temp3, r__1 = max(r__1,r__2), r__2 = rtunfl
+ * 10.f;
+ vl = d1[il] - dmax(r__1,r__2);
+ } else if (n > 0) {
+/* Computing MAX */
+ r__1 = (d1[n] - d1[1]) * .5f, r__2 = ulp * 10.f *
+ temp3, r__1 = max(r__1,r__2), r__2 = rtunfl *
+ 10.f;
+ vl = d1[1] - dmax(r__1,r__2);
+ }
+ if (iu != n) {
+/* Computing MAX */
+ r__1 = (d1[iu + 1] - d1[iu]) * .5f, r__2 = ulp * 10.f
+ * temp3, r__1 = max(r__1,r__2), r__2 = rtunfl
+ * 10.f;
+ vu = d1[iu] + dmax(r__1,r__2);
+ } else if (n > 0) {
+/* Computing MAX */
+ r__1 = (d1[n] - d1[1]) * .5f, r__2 = ulp * 10.f *
+ temp3, r__1 = max(r__1,r__2), r__2 = rtunfl *
+ 10.f;
+ vu = d1[n] + dmax(r__1,r__2);
+ }
+ } else {
+ temp3 = 0.f;
+ vl = 0.f;
+ vu = 1.f;
+ }
+
+ chpevx_("V", "A", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m, &wa1[1], &z__[z_offset], ldu, &v[v_offset]
+, &rwork[1], &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___69.ciunit = *nounit;
+ s_wsfe(&io___69);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHPEVX(V,A,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L370;
+ }
+ }
+
+/* Do tests 16 and 17. */
+
+ chet21_(&c__1, uplo, &n, &c__0, &a[a_offset], ldu, &wa1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L320: */
+ }
+/* L330: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L340: */
+ }
+/* L350: */
+ }
+ }
+
+ chpevx_("N", "A", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &v[
+ v_offset], &rwork[1], &iwork[1], &iwork[n * 5 + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___70.ciunit = *nounit;
+ s_wsfe(&io___70);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHPEVX(N,A,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L370;
+ }
+ }
+
+/* Do test 18. */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = wa1[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = wa2[j], dabs(r__2))
+ ;
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = wa1[j] - wa2[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L360: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[ntest] = temp2 / dmax(r__1,r__2);
+
+L370:
+ ++ntest;
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L380: */
+ }
+/* L390: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L400: */
+ }
+/* L410: */
+ }
+ }
+
+ chpevx_("V", "I", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &v[
+ v_offset], &rwork[1], &iwork[1], &iwork[n * 5 + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___71.ciunit = *nounit;
+ s_wsfe(&io___71);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHPEVX(V,I,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L460;
+ }
+ }
+
+/* Do tests 19 and 20. */
+
+ chet22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L420: */
+ }
+/* L430: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L440: */
+ }
+/* L450: */
+ }
+ }
+
+ chpevx_("N", "I", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m3, &wa3[1], &z__[z_offset], ldu, &v[
+ v_offset], &rwork[1], &iwork[1], &iwork[n * 5 + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___72.ciunit = *nounit;
+ s_wsfe(&io___72);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHPEVX(N,I,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L460;
+ }
+ }
+
+/* Do test 21. */
+
+ temp1 = ssxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = ssxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ r__2 = dabs(wa1[1]), r__3 = (r__1 = wa1[n], dabs(r__1));
+ temp3 = dmax(r__2,r__3);
+ } else {
+ temp3 = 0.f;
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / dmax(r__1,r__2);
+
+L460:
+ ++ntest;
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L470: */
+ }
+/* L480: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L490: */
+ }
+/* L500: */
+ }
+ }
+
+ chpevx_("V", "V", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &v[
+ v_offset], &rwork[1], &iwork[1], &iwork[n * 5 + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___73.ciunit = *nounit;
+ s_wsfe(&io___73);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHPEVX(V,V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L550;
+ }
+ }
+
+/* Do tests 22 and 23. */
+
+ chet22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L510: */
+ }
+/* L520: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L530: */
+ }
+/* L540: */
+ }
+ }
+
+ chpevx_("N", "V", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m3, &wa3[1], &z__[z_offset], ldu, &v[
+ v_offset], &rwork[1], &iwork[1], &iwork[n * 5 + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___74.ciunit = *nounit;
+ s_wsfe(&io___74);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHPEVX(N,V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L550;
+ }
+ }
+
+ if (m3 == 0 && n > 0) {
+ result[ntest] = ulpinv;
+ goto L550;
+ }
+
+/* Do test 24. */
+
+ temp1 = ssxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = ssxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ r__2 = dabs(wa1[1]), r__3 = (r__1 = wa1[n], dabs(r__1));
+ temp3 = dmax(r__2,r__3);
+ } else {
+ temp3 = 0.f;
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / dmax(r__1,r__2);
+
+L550:
+
+/* Call CHBEVD and CHBEVX. */
+
+ if (jtype <= 7) {
+ kd = 0;
+ } else if (jtype >= 8 && jtype <= 15) {
+/* Computing MAX */
+ i__3 = n - 1;
+ kd = max(i__3,0);
+ } else {
+ kd = ihbw;
+ }
+
+/* Load array V with the upper or lower triangular part */
+/* of the matrix in band form. */
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kd;
+ i__6 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__6; ++i__) {
+ i__4 = kd + 1 + i__ - j + j * v_dim1;
+ i__5 = i__ + j * a_dim1;
+ v[i__4].r = a[i__5].r, v[i__4].i = a[i__5].i;
+/* L560: */
+ }
+/* L570: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + kd;
+ i__6 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__6; ++i__) {
+ i__4 = i__ + 1 - j + j * v_dim1;
+ i__5 = i__ + j * a_dim1;
+ v[i__4].r = a[i__5].r, v[i__4].i = a[i__5].i;
+/* L580: */
+ }
+/* L590: */
+ }
+ }
+
+ ++ntest;
+ chbevd_("V", uplo, &n, &kd, &v[v_offset], ldu, &d1[1], &z__[
+ z_offset], ldu, &work[1], &lwedc, &rwork[1], &lrwedc,
+ &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___76.ciunit = *nounit;
+ s_wsfe(&io___76);
+/* Writing concatenation */
+ i__7[0] = 9, a__1[0] = "CHBEVD(V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__7, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__1, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L650;
+ }
+ }
+
+/* Do tests 25 and 26. */
+
+ chet21_(&c__1, uplo, &n, &c__0, &a[a_offset], lda, &d1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &rwork[1], &result[ntest]);
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__6 = 1, i__4 = j - kd;
+ i__5 = j;
+ for (i__ = max(i__6,i__4); i__ <= i__5; ++i__) {
+ i__6 = kd + 1 + i__ - j + j * v_dim1;
+ i__4 = i__ + j * a_dim1;
+ v[i__6].r = a[i__4].r, v[i__6].i = a[i__4].i;
+/* L600: */
+ }
+/* L610: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__6 = n, i__4 = j + kd;
+ i__5 = min(i__6,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ i__6 = i__ + 1 - j + j * v_dim1;
+ i__4 = i__ + j * a_dim1;
+ v[i__6].r = a[i__4].r, v[i__6].i = a[i__4].i;
+/* L620: */
+ }
+/* L630: */
+ }
+ }
+
+ ntest += 2;
+ chbevd_("N", uplo, &n, &kd, &v[v_offset], ldu, &d3[1], &z__[
+ z_offset], ldu, &work[1], &lwedc, &rwork[1], &lrwedc,
+ &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___77.ciunit = *nounit;
+ s_wsfe(&io___77);
+/* Writing concatenation */
+ i__7[0] = 9, a__1[0] = "CHBEVD(N,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__7, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__1, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L650;
+ }
+ }
+
+/* Do test 27. */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d1[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = d3[j], dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d1[j] - d3[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L640: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[ntest] = temp2 / dmax(r__1,r__2);
+
+/* Load array V with the upper or lower triangular part */
+/* of the matrix in band form. */
+
+L650:
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__6 = j - kd;
+ i__4 = j;
+ for (i__ = max(i__5,i__6); i__ <= i__4; ++i__) {
+ i__5 = kd + 1 + i__ - j + j * v_dim1;
+ i__6 = i__ + j * a_dim1;
+ v[i__5].r = a[i__6].r, v[i__5].i = a[i__6].i;
+/* L660: */
+ }
+/* L670: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__5 = n, i__6 = j + kd;
+ i__4 = min(i__5,i__6);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = i__ + 1 - j + j * v_dim1;
+ i__6 = i__ + j * a_dim1;
+ v[i__5].r = a[i__6].r, v[i__5].i = a[i__6].i;
+/* L680: */
+ }
+/* L690: */
+ }
+ }
+
+ ++ntest;
+ chbevx_("V", "A", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m, &wa1[
+ 1], &z__[z_offset], ldu, &work[1], &rwork[1], &iwork[
+ 1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___78.ciunit = *nounit;
+ s_wsfe(&io___78);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHBEVX(V,A,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L750;
+ }
+ }
+
+/* Do tests 28 and 29. */
+
+ chet21_(&c__1, uplo, &n, &c__0, &a[a_offset], ldu, &wa1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kd;
+ i__6 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__6; ++i__) {
+ i__4 = kd + 1 + i__ - j + j * v_dim1;
+ i__5 = i__ + j * a_dim1;
+ v[i__4].r = a[i__5].r, v[i__4].i = a[i__5].i;
+/* L700: */
+ }
+/* L710: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + kd;
+ i__6 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__6; ++i__) {
+ i__4 = i__ + 1 - j + j * v_dim1;
+ i__5 = i__ + j * a_dim1;
+ v[i__4].r = a[i__5].r, v[i__4].i = a[i__5].i;
+/* L720: */
+ }
+/* L730: */
+ }
+ }
+
+ chbevx_("N", "A", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m2, &
+ wa2[1], &z__[z_offset], ldu, &work[1], &rwork[1], &
+ iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___79.ciunit = *nounit;
+ s_wsfe(&io___79);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHBEVX(N,A,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L750;
+ }
+ }
+
+/* Do test 30. */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = wa1[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = wa2[j], dabs(r__2))
+ ;
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = wa1[j] - wa2[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L740: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[ntest] = temp2 / dmax(r__1,r__2);
+
+/* Load array V with the upper or lower triangular part */
+/* of the matrix in band form. */
+
+L750:
+ ++ntest;
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__6 = 1, i__4 = j - kd;
+ i__5 = j;
+ for (i__ = max(i__6,i__4); i__ <= i__5; ++i__) {
+ i__6 = kd + 1 + i__ - j + j * v_dim1;
+ i__4 = i__ + j * a_dim1;
+ v[i__6].r = a[i__4].r, v[i__6].i = a[i__4].i;
+/* L760: */
+ }
+/* L770: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__6 = n, i__4 = j + kd;
+ i__5 = min(i__6,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ i__6 = i__ + 1 - j + j * v_dim1;
+ i__4 = i__ + j * a_dim1;
+ v[i__6].r = a[i__4].r, v[i__6].i = a[i__4].i;
+/* L780: */
+ }
+/* L790: */
+ }
+ }
+
+ chbevx_("V", "I", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m2, &
+ wa2[1], &z__[z_offset], ldu, &work[1], &rwork[1], &
+ iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___80.ciunit = *nounit;
+ s_wsfe(&io___80);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHBEVX(V,I,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L840;
+ }
+ }
+
+/* Do tests 31 and 32. */
+
+ chet22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__6 = j - kd;
+ i__4 = j;
+ for (i__ = max(i__5,i__6); i__ <= i__4; ++i__) {
+ i__5 = kd + 1 + i__ - j + j * v_dim1;
+ i__6 = i__ + j * a_dim1;
+ v[i__5].r = a[i__6].r, v[i__5].i = a[i__6].i;
+/* L800: */
+ }
+/* L810: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__5 = n, i__6 = j + kd;
+ i__4 = min(i__5,i__6);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = i__ + 1 - j + j * v_dim1;
+ i__6 = i__ + j * a_dim1;
+ v[i__5].r = a[i__6].r, v[i__5].i = a[i__6].i;
+/* L820: */
+ }
+/* L830: */
+ }
+ }
+ chbevx_("N", "I", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m3, &
+ wa3[1], &z__[z_offset], ldu, &work[1], &rwork[1], &
+ iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___81.ciunit = *nounit;
+ s_wsfe(&io___81);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHBEVX(N,I,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L840;
+ }
+ }
+
+/* Do test 33. */
+
+ temp1 = ssxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = ssxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ r__2 = dabs(wa1[1]), r__3 = (r__1 = wa1[n], dabs(r__1));
+ temp3 = dmax(r__2,r__3);
+ } else {
+ temp3 = 0.f;
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / dmax(r__1,r__2);
+
+/* Load array V with the upper or lower triangular part */
+/* of the matrix in band form. */
+
+L840:
+ ++ntest;
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kd;
+ i__6 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__6; ++i__) {
+ i__4 = kd + 1 + i__ - j + j * v_dim1;
+ i__5 = i__ + j * a_dim1;
+ v[i__4].r = a[i__5].r, v[i__4].i = a[i__5].i;
+/* L850: */
+ }
+/* L860: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + kd;
+ i__6 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__6; ++i__) {
+ i__4 = i__ + 1 - j + j * v_dim1;
+ i__5 = i__ + j * a_dim1;
+ v[i__4].r = a[i__5].r, v[i__4].i = a[i__5].i;
+/* L870: */
+ }
+/* L880: */
+ }
+ }
+ chbevx_("V", "V", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m2, &
+ wa2[1], &z__[z_offset], ldu, &work[1], &rwork[1], &
+ iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___82.ciunit = *nounit;
+ s_wsfe(&io___82);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHBEVX(V,V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L930;
+ }
+ }
+
+/* Do tests 34 and 35. */
+
+ chet22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__6 = 1, i__4 = j - kd;
+ i__5 = j;
+ for (i__ = max(i__6,i__4); i__ <= i__5; ++i__) {
+ i__6 = kd + 1 + i__ - j + j * v_dim1;
+ i__4 = i__ + j * a_dim1;
+ v[i__6].r = a[i__4].r, v[i__6].i = a[i__4].i;
+/* L890: */
+ }
+/* L900: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__6 = n, i__4 = j + kd;
+ i__5 = min(i__6,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ i__6 = i__ + 1 - j + j * v_dim1;
+ i__4 = i__ + j * a_dim1;
+ v[i__6].r = a[i__4].r, v[i__6].i = a[i__4].i;
+/* L910: */
+ }
+/* L920: */
+ }
+ }
+ chbevx_("N", "V", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m3, &
+ wa3[1], &z__[z_offset], ldu, &work[1], &rwork[1], &
+ iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___83.ciunit = *nounit;
+ s_wsfe(&io___83);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHBEVX(N,V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L930;
+ }
+ }
+
+ if (m3 == 0 && n > 0) {
+ result[ntest] = ulpinv;
+ goto L930;
+ }
+
+/* Do test 36. */
+
+ temp1 = ssxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = ssxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ r__2 = dabs(wa1[1]), r__3 = (r__1 = wa1[n], dabs(r__1));
+ temp3 = dmax(r__2,r__3);
+ } else {
+ temp3 = 0.f;
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / dmax(r__1,r__2);
+
+L930:
+
+/* Call CHEEV */
+
+ clacpy_(" ", &n, &n, &a[a_offset], lda, &v[v_offset], ldu);
+
+ ++ntest;
+ cheev_("V", uplo, &n, &a[a_offset], ldu, &d1[1], &work[1],
+ lwork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___84.ciunit = *nounit;
+ s_wsfe(&io___84);
+/* Writing concatenation */
+ i__7[0] = 8, a__1[0] = "CHEEV(V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__7, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__3, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L950;
+ }
+ }
+
+/* Do tests 37 and 38 */
+
+ chet21_(&c__1, uplo, &n, &c__0, &v[v_offset], ldu, &d1[1], &
+ d2[1], &a[a_offset], ldu, &z__[z_offset], ldu, &tau[1]
+, &work[1], &rwork[1], &result[ntest]);
+
+ clacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ ntest += 2;
+ cheev_("N", uplo, &n, &a[a_offset], ldu, &d3[1], &work[1],
+ lwork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___85.ciunit = *nounit;
+ s_wsfe(&io___85);
+/* Writing concatenation */
+ i__7[0] = 8, a__1[0] = "CHEEV(N,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__7, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__3, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L950;
+ }
+ }
+
+/* Do test 39 */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d1[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = d3[j], dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d1[j] - d3[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L940: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[ntest] = temp2 / dmax(r__1,r__2);
+
+L950:
+
+ clacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+/* Call CHPEV */
+
+/* Load array WORK with the upper or lower triangular */
+/* part of the matrix in packed form. */
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__5 = j;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = indx;
+ i__4 = i__ + j * a_dim1;
+ work[i__6].r = a[i__4].r, work[i__6].i = a[i__4]
+ .i;
+ ++indx;
+/* L960: */
+ }
+/* L970: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__5 = n;
+ for (i__ = j; i__ <= i__5; ++i__) {
+ i__6 = indx;
+ i__4 = i__ + j * a_dim1;
+ work[i__6].r = a[i__4].r, work[i__6].i = a[i__4]
+ .i;
+ ++indx;
+/* L980: */
+ }
+/* L990: */
+ }
+ }
+
+ ++ntest;
+ indwrk = n * (n + 1) / 2 + 1;
+ chpev_("V", uplo, &n, &work[1], &d1[1], &z__[z_offset], ldu, &
+ work[indwrk], &rwork[1], &iinfo)
+ ;
+ if (iinfo != 0) {
+ io___86.ciunit = *nounit;
+ s_wsfe(&io___86);
+/* Writing concatenation */
+ i__7[0] = 8, a__1[0] = "CHPEV(V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__7, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__3, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1050;
+ }
+ }
+
+/* Do tests 40 and 41. */
+
+ chet21_(&c__1, uplo, &n, &c__0, &a[a_offset], lda, &d1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &rwork[1], &result[ntest]);
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__5 = j;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = indx;
+ i__4 = i__ + j * a_dim1;
+ work[i__6].r = a[i__4].r, work[i__6].i = a[i__4]
+ .i;
+ ++indx;
+/* L1000: */
+ }
+/* L1010: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__5 = n;
+ for (i__ = j; i__ <= i__5; ++i__) {
+ i__6 = indx;
+ i__4 = i__ + j * a_dim1;
+ work[i__6].r = a[i__4].r, work[i__6].i = a[i__4]
+ .i;
+ ++indx;
+/* L1020: */
+ }
+/* L1030: */
+ }
+ }
+
+ ntest += 2;
+ indwrk = n * (n + 1) / 2 + 1;
+ chpev_("N", uplo, &n, &work[1], &d3[1], &z__[z_offset], ldu, &
+ work[indwrk], &rwork[1], &iinfo)
+ ;
+ if (iinfo != 0) {
+ io___87.ciunit = *nounit;
+ s_wsfe(&io___87);
+/* Writing concatenation */
+ i__7[0] = 8, a__1[0] = "CHPEV(N,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__7, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__3, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1050;
+ }
+ }
+
+/* Do test 42 */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d1[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = d3[j], dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d1[j] - d3[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L1040: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[ntest] = temp2 / dmax(r__1,r__2);
+
+L1050:
+
+/* Call CHBEV */
+
+ if (jtype <= 7) {
+ kd = 0;
+ } else if (jtype >= 8 && jtype <= 15) {
+/* Computing MAX */
+ i__3 = n - 1;
+ kd = max(i__3,0);
+ } else {
+ kd = ihbw;
+ }
+
+/* Load array V with the upper or lower triangular part */
+/* of the matrix in band form. */
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__6 = j - kd;
+ i__4 = j;
+ for (i__ = max(i__5,i__6); i__ <= i__4; ++i__) {
+ i__5 = kd + 1 + i__ - j + j * v_dim1;
+ i__6 = i__ + j * a_dim1;
+ v[i__5].r = a[i__6].r, v[i__5].i = a[i__6].i;
+/* L1060: */
+ }
+/* L1070: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__5 = n, i__6 = j + kd;
+ i__4 = min(i__5,i__6);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = i__ + 1 - j + j * v_dim1;
+ i__6 = i__ + j * a_dim1;
+ v[i__5].r = a[i__6].r, v[i__5].i = a[i__6].i;
+/* L1080: */
+ }
+/* L1090: */
+ }
+ }
+
+ ++ntest;
+ chbev_("V", uplo, &n, &kd, &v[v_offset], ldu, &d1[1], &z__[
+ z_offset], ldu, &work[1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___88.ciunit = *nounit;
+ s_wsfe(&io___88);
+/* Writing concatenation */
+ i__7[0] = 8, a__1[0] = "CHBEV(V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__7, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__3, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1140;
+ }
+ }
+
+/* Do tests 43 and 44. */
+
+ chet21_(&c__1, uplo, &n, &c__0, &a[a_offset], lda, &d1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &rwork[1], &result[ntest]);
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kd;
+ i__6 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__6; ++i__) {
+ i__4 = kd + 1 + i__ - j + j * v_dim1;
+ i__5 = i__ + j * a_dim1;
+ v[i__4].r = a[i__5].r, v[i__4].i = a[i__5].i;
+/* L1100: */
+ }
+/* L1110: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + kd;
+ i__6 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__6; ++i__) {
+ i__4 = i__ + 1 - j + j * v_dim1;
+ i__5 = i__ + j * a_dim1;
+ v[i__4].r = a[i__5].r, v[i__4].i = a[i__5].i;
+/* L1120: */
+ }
+/* L1130: */
+ }
+ }
+
+ ntest += 2;
+ chbev_("N", uplo, &n, &kd, &v[v_offset], ldu, &d3[1], &z__[
+ z_offset], ldu, &work[1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___89.ciunit = *nounit;
+ s_wsfe(&io___89);
+/* Writing concatenation */
+ i__7[0] = 8, a__1[0] = "CHBEV(N,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__7, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__3, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1140;
+ }
+ }
+
+L1140:
+
+/* Do test 45. */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d1[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = d3[j], dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d1[j] - d3[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L1150: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[ntest] = temp2 / dmax(r__1,r__2);
+
+ clacpy_(" ", &n, &n, &a[a_offset], lda, &v[v_offset], ldu);
+ ++ntest;
+ i__3 = *liwork - (n << 1);
+ cheevr_("V", "A", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m, &wa1[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &rwork[1], lrwork, &iwork[(
+ n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___90.ciunit = *nounit;
+ s_wsfe(&io___90);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHEEVR(V,A,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1170;
+ }
+ }
+
+/* Do tests 45 and 46 (or ... ) */
+
+ clacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ chet21_(&c__1, uplo, &n, &c__0, &a[a_offset], ldu, &wa1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+ i__3 = *liwork - (n << 1);
+ cheevr_("N", "A", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &rwork[1], lrwork, &iwork[(
+ n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___91.ciunit = *nounit;
+ s_wsfe(&io___91);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHEEVR(N,A,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1170;
+ }
+ }
+
+/* Do test 47 (or ... ) */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = wa1[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = wa2[j], dabs(r__2))
+ ;
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = wa1[j] - wa2[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L1160: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[ntest] = temp2 / dmax(r__1,r__2);
+
+L1170:
+
+ ++ntest;
+ clacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ i__3 = *liwork - (n << 1);
+ cheevr_("V", "I", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &rwork[1], lrwork, &iwork[(
+ n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___92.ciunit = *nounit;
+ s_wsfe(&io___92);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHEEVR(V,I,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1180;
+ }
+ }
+
+/* Do tests 48 and 49 (or +??) */
+
+ clacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ chet22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+ clacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ i__3 = *liwork - (n << 1);
+ cheevr_("N", "I", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m3, &wa3[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &rwork[1], lrwork, &iwork[(
+ n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___93.ciunit = *nounit;
+ s_wsfe(&io___93);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHEEVR(N,I,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1180;
+ }
+ }
+
+/* Do test 50 (or +??) */
+
+ temp1 = ssxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = ssxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * temp3;
+ result[ntest] = (temp1 + temp2) / dmax(r__1,r__2);
+L1180:
+
+ ++ntest;
+ clacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ i__3 = *liwork - (n << 1);
+ cheevr_("V", "V", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &rwork[1], lrwork, &iwork[(
+ n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___94.ciunit = *nounit;
+ s_wsfe(&io___94);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHEEVR(V,V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1190;
+ }
+ }
+
+/* Do tests 51 and 52 (or +??) */
+
+ clacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ chet22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+ clacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ i__3 = *liwork - (n << 1);
+ cheevr_("N", "V", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m3, &wa3[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &rwork[1], lrwork, &iwork[(
+ n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___95.ciunit = *nounit;
+ s_wsfe(&io___95);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "CHEEVR(N,V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1190;
+ }
+ }
+
+ if (m3 == 0 && n > 0) {
+ result[ntest] = ulpinv;
+ goto L1190;
+ }
+
+/* Do test 52 (or +??) */
+
+ temp1 = ssxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = ssxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ r__2 = dabs(wa1[1]), r__3 = (r__1 = wa1[n], dabs(r__1));
+ temp3 = dmax(r__2,r__3);
+ } else {
+ temp3 = 0.f;
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / dmax(r__1,r__2);
+
+ clacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+
+
+
+/* Load array V with the upper or lower triangular part */
+/* of the matrix in band form. */
+
+L1190:
+
+/* L1200: */
+ ;
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+ ntestt += ntest;
+ slafts_("CST", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh,
+ nounit, &nerrs);
+
+L1210:
+ ;
+ }
+/* L1220: */
+ }
+
+/* Summary */
+
+ alasvm_("CST", nounit, &nerrs, &ntestt, &c__0);
+
+
+ return 0;
+
+/* End of CDRVST */
+
+} /* cdrvst_ */
diff --git a/TESTING/EIG/cdrvsx.c b/TESTING/EIG/cdrvsx.c
new file mode 100644
index 0000000..042ebad
--- /dev/null
+++ b/TESTING/EIG/cdrvsx.c
@@ -0,0 +1,1081 @@
+/* cdrvsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ real selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__0 = 0;
+static integer c__4 = 4;
+static integer c__6 = 6;
+static real c_b39 = 1.f;
+static integer c__1 = 1;
+static real c_b49 = 0.f;
+static integer c__2 = 2;
+static logical c_false = FALSE_;
+static integer c__3 = 3;
+static logical c_true = TRUE_;
+static integer c__22 = 22;
+
+/* Subroutine */ int cdrvsx_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, integer *niunit,
+ integer *nounit, complex *a, integer *lda, complex *h__, complex *ht,
+ complex *w, complex *wt, complex *wtmp, complex *vs, integer *ldvs,
+ complex *vs1, real *result, complex *work, integer *lwork, real *
+ rwork, logical *bwork, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
+ static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
+ static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9991[] = "(\002 CDRVSX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(/1x,a3,\002 -- Complex Schur Form Decompositi"
+ "on Expert \002,\002Driver\002,/\002 Matrix types (see CDRVSX for"
+ " details): \002)";
+ static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 \002,\002 5=Diagonal: geom"
+ "etr. spaced entries.\002,/\002 2=Identity matrix. "
+ " \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
+ "/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
+ " 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
+ "l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
+ "ll, evenly spaced.\002)";
+ static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
+ " 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
+ "l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
+ "d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
+ "red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
+ "vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
+ " 12=Well-cond., random complex \002,\002 \002,\002 17=Il"
+ "l-cond., large rand. complx \002,/\002 13=Ill-condi\002,\002tion"
+ "ed, evenly spaced. \002,\002 18=Ill-cond., small rand.\002"
+ ",\002 complx \002)";
+ static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
+ " \002,\002 21=Matrix \002,\002with small random entries.\002,"
+ "/\002 20=Matrix with large ran\002,\002dom entries. \002,/)";
+ static char fmt_9995[] = "(\002 Tests performed with test threshold ="
+ "\002,f8.2,/\002 ( A denotes A on input and T denotes A on output)"
+ "\002,//\002 1 = 0 if T in Schur form (no sort), \002,\002 1/ulp"
+ " otherwise\002,/\002 2 = | A - VS T transpose(VS) | / ( n |A| ul"
+ "p ) (no sort)\002,/\002 3 = | I - VS transpose(VS) | / ( n ulp )"
+ " (no sort) \002,/\002 4 = 0 if W are eigenvalues of T (no sort)"
+ ",\002,\002 1/ulp otherwise\002,/\002 5 = 0 if T same no matter "
+ "if VS computed (no sort),\002,\002 1/ulp otherwise\002,/\002 6 "
+ "= 0 if W same no matter if VS computed (no sort)\002,\002, 1/ul"
+ "p otherwise\002)";
+ static char fmt_9994[] = "(\002 7 = 0 if T in Schur form (sort), \002"
+ ",\002 1/ulp otherwise\002,/\002 8 = | A - VS T transpose(VS) | "
+ "/ ( n |A| ulp ) (sort)\002,/\002 9 = | I - VS transpose(VS) | / "
+ "( n ulp ) (sort) \002,/\002 10 = 0 if W are eigenvalues of T (so"
+ "rt),\002,\002 1/ulp otherwise\002,/\002 11 = 0 if T same no mat"
+ "ter what else computed (sort),\002,\002 1/ulp otherwise\002,"
+ "/\002 12 = 0 if W same no matter what else computed \002,\002(so"
+ "rt), 1/ulp otherwise\002,/\002 13 = 0 if sorting succesful, 1/ul"
+ "p otherwise\002,/\002 14 = 0 if RCONDE same no matter what else "
+ "computed,\002,\002 1/ulp otherwise\002,/\002 15 = 0 if RCONDv sa"
+ "me no matter what else computed,\002,\002 1/ulp otherwise\002,"
+ "/\002 16 = | RCONDE - RCONDE(precomputed) | / cond(RCONDE),\002,/"
+ "\002 17 = | RCONDV - RCONDV(precomputed) | / cond(RCONDV),\002)";
+ static char fmt_9993[] = "(\002 N=\002,i5,\002, IWK=\002,i2,\002, seed"
+ "=\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)="
+ "\002,g10.3)";
+ static char fmt_9992[] = "(\002 N=\002,i5,\002, input example =\002,i3"
+ ",\002, test(\002,i2,\002)=\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, ht_dim1, ht_offset, vs_dim1,
+ vs_offset, vs1_dim1, vs1_offset, i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+
+ /* Local variables */
+ integer i__, j, n, iwk;
+ real ulp, cond;
+ integer jcol;
+ char path[3];
+ integer nmax;
+ real unfl, ovfl;
+ integer isrt;
+ logical badnn;
+ extern /* Subroutine */ int cget24_(logical *, integer *, real *, integer
+ *, integer *, integer *, complex *, integer *, complex *, complex
+ *, complex *, complex *, complex *, complex *, integer *, complex
+ *, real *, real *, integer *, integer *, integer *, real *,
+ complex *, integer *, real *, logical *, integer *);
+ integer nfail, imode, iinfo;
+ real conds, anorm;
+ integer islct[20], nslct, jsize, nerrs, itype, jtype, ntest;
+ real rtulp;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ real rcdein;
+ extern /* Subroutine */ int clatme_(integer *, char *, integer *, complex
+ *, integer *, real *, complex *, char *, char *, char *, char *,
+ real *, integer *, real *, integer *, integer *, real *, complex *
+, integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *);
+ integer idumma[1], ioldsd[4];
+ extern /* Subroutine */ int xerbla_(char *, integer *), clatmr_(
+ integer *, integer *, char *, integer *, char *, complex *,
+ integer *, real *, complex *, char *, char *, complex *, integer *
+, real *, complex *, integer *, real *, char *, integer *,
+ integer *, integer *, real *, real *, char *, complex *, integer *
+, integer *, integer *), clatms_(integer *, integer *, char *, integer *, char *,
+ real *, integer *, real *, real *, integer *, integer *, char *,
+ complex *, integer *, complex *, integer *);
+ real rcdvin;
+ integer ntestf;
+ extern /* Subroutine */ int slasum_(char *, integer *, integer *, integer
+ *);
+ real ulpinv;
+ integer nnwork;
+ real rtulpi;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___31 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___47 = { 0, 0, 1, 0, 0 };
+ static cilist io___49 = { 0, 0, 0, 0, 0 };
+ static cilist io___51 = { 0, 0, 0, 0, 0 };
+ static cilist io___52 = { 0, 0, 0, 0, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9992, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVSX checks the nonsymmetric eigenvalue (Schur form) problem */
+/* expert driver CGEESX. */
+
+/* CDRVSX uses both test matrices generated randomly depending on */
+/* data supplied in the calling sequence, as well as on data */
+/* read from an input file and including precomputed condition */
+/* numbers to which it compares the ones it computes. */
+
+/* When CDRVSX is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 15 */
+/* tests will be performed: */
+
+/* (1) 0 if T is in Schur form, 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (2) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (no sorting of eigenvalues). */
+
+/* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues). */
+
+/* (4) 0 if W are eigenvalues of T */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (5) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (7) 0 if T is in Schur form, 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (8) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (with sorting of eigenvalues). */
+
+/* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues). */
+
+/* (10) 0 if W are eigenvalues of T */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare W with and */
+/* without reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (11) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare T with and without */
+/* reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare VS with and without */
+/* reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (13) if sorting worked and SDIM is the number of */
+/* eigenvalues which were SELECTed */
+/* If workspace sufficient, also compare SDIM with and */
+/* without reciprocal condition numbers */
+
+/* (14) if RCONDE the same no matter if VS and/or RCONDV computed */
+
+/* (15) if RCONDV the same no matter if VS and/or RCONDE computed */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
+
+/* (4) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random complex angles. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (5) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random complex angles. */
+/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random complex angles. */
+
+/* (7) Same as (4), but multiplied by a constant near */
+/* the overflow threshold */
+/* (8) Same as (4), but multiplied by a constant near */
+/* the underflow threshold */
+
+/* (9) A matrix of the form U' T U, where U is unitary and */
+/* T has evenly spaced entries 1, ..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (10) A matrix of the form U' T U, where U is unitary and */
+/* T has geometrically spaced entries 1, ..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (11) A matrix of the form U' T U, where U is orthogonal and */
+/* T has "clustered" entries 1, ULP,..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (12) A matrix of the form U' T U, where U is unitary and */
+/* T has complex eigenvalues randomly chosen from */
+/* ULP < |z| < 1 and random O(1) entries in the upper */
+/* triangle. */
+
+/* (13) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
+/* with random complex angles on the diagonal and random O(1) */
+/* entries in the upper triangle. */
+
+/* (14) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has geometrically spaced entries */
+/* 1, ..., ULP with random complex angles on the diagonal */
+/* and random O(1) entries in the upper triangle. */
+
+/* (15) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
+/* with random complex angles on the diagonal and random O(1) */
+/* entries in the upper triangle. */
+
+/* (16) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has complex eigenvalues randomly chosen */
+/* from ULP < |z| < 1 and random O(1) entries in the upper */
+/* triangle. */
+
+/* (17) Same as (16), but multiplied by a constant */
+/* near the overflow threshold */
+/* (18) Same as (16), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* (19) Nonsymmetric matrix with random entries chosen from (-1,1). */
+/* If N is at least 4, all entries in first two rows and last */
+/* row, and first column and last two columns are zero. */
+/* (20) Same as (19), but multiplied by a constant */
+/* near the overflow threshold */
+/* (21) Same as (19), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* In addition, an input file will be read from logical unit number */
+/* NIUNIT. The file contains matrices along with precomputed */
+/* eigenvalues and reciprocal condition numbers for the eigenvalue */
+/* average and right invariant subspace. For these matrices, in */
+/* addition to tests (1) to (15) we will compute the following two */
+/* tests: */
+
+/* (16) |RCONDE - RCDEIN| / cond(RCONDE) */
+
+/* RCONDE is the reciprocal average eigenvalue condition number */
+/* computed by CGEESX and RCDEIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDE) is the condition number */
+/* of RCONDE, and takes errors in computing RCONDE into account, */
+/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
+/* is essentially given by norm(A)/RCONDV. */
+
+/* (17) |RCONDV - RCDVIN| / cond(RCONDV) */
+
+/* RCONDV is the reciprocal right invariant subspace condition */
+/* number computed by CGEESX and RCDVIN (the precomputed true */
+/* value) is supplied as input. cond(RCONDV) is the condition */
+/* number of RCONDV, and takes errors in computing RCONDV into */
+/* account, so that the resulting quantity should be O(ULP). */
+/* cond(RCONDV) is essentially given by norm(A)/RCONDE. */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. NSIZES must be at */
+/* least zero. If it is zero, no randomly generated matrices */
+/* are tested, but any test matrices read from NIUNIT will be */
+/* tested. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. NTYPES must be at least */
+/* zero. If it is zero, no randomly generated test matrices */
+/* are tested, but and test matrices read from NIUNIT will be */
+/* tested. If it is MAXTYP+1 and NSIZES is 1, then an */
+/* additional type, MAXTYP+1 is defined, which is to use */
+/* whatever matrix is in A. This is only useful if */
+/* DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to CDRVSX to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NIUNIT (input) INTEGER */
+/* The FORTRAN unit number for reading in the data file of */
+/* problems to solve. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* A (workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, and H. LDA must be at */
+/* least 1 and at least max( NN ). */
+
+/* H (workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* Another copy of the test matrix A, modified by CGEESX. */
+
+/* HT (workspace) COMPLEX array, dimension (LDA, max(NN)) */
+/* Yet another copy of the test matrix A, modified by CGEESX. */
+
+/* W (workspace) COMPLEX array, dimension (max(NN)) */
+/* The computed eigenvalues of A. */
+
+/* WT (workspace) COMPLEX array, dimension (max(NN)) */
+/* Like W, this array contains the eigenvalues of A, */
+/* but those computed when CGEESX only computes a partial */
+/* eigendecomposition, i.e. not Schur vectors */
+
+/* WTMP (workspace) COMPLEX array, dimension (max(NN)) */
+/* More temporary storage for eigenvalues. */
+
+/* VS (workspace) COMPLEX array, dimension (LDVS, max(NN)) */
+/* VS holds the computed Schur vectors. */
+
+/* LDVS (input) INTEGER */
+/* Leading dimension of VS. Must be at least max(1,max(NN)). */
+
+/* VS1 (workspace) COMPLEX array, dimension (LDVS, max(NN)) */
+/* VS1 holds another copy of the computed Schur vectors. */
+
+/* RESULT (output) REAL array, dimension (17) */
+/* The values computed by the 17 tests described above. */
+/* The values are currently limited to 1/ulp, to avoid overflow. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* max(1,2*NN(j)**2) for all j. */
+
+/* RWORK (workspace) REAL array, dimension (max(NN)) */
+
+/* BWORK (workspace) LOGICAL array, dimension (max(NN)) */
+
+/* INFO (output) INTEGER */
+/* If 0, successful exit. */
+/* <0, input parameter -INFO is incorrect */
+/* >0, CLATMR, CLATMS, CLATME or CGET24 returned an error */
+/* code and INFO is its absolute value */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NMAX Largest value in NN. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* COND, CONDS, */
+/* IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTULP, RTULPI Square roots of the previous 4 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+/* KCONDS(j) Selectw whether CONDS is to be 1 or */
+/* 1/sqrt(ulp). (0 means irrelevant.) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ ht_dim1 = *lda;
+ ht_offset = 1 + ht_dim1;
+ ht -= ht_offset;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ --wt;
+ --wtmp;
+ vs1_dim1 = *ldvs;
+ vs1_offset = 1 + vs1_dim1;
+ vs1 -= vs1_offset;
+ vs_dim1 = *ldvs;
+ vs_offset = 1 + vs_dim1;
+ vs -= vs_offset;
+ --result;
+ --work;
+ --rwork;
+ --bwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "SX", (ftnlen)2, (ftnlen)2);
+
+/* Check for errors */
+
+ ntestt = 0;
+ ntestf = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+
+/* 8 is the largest dimension in the input file of precomputed */
+/* problems */
+
+ nmax = 8;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.f) {
+ *info = -6;
+ } else if (*niunit <= 0) {
+ *info = -7;
+ } else if (*nounit <= 0) {
+ *info = -8;
+ } else if (*lda < 1 || *lda < nmax) {
+ *info = -10;
+ } else if (*ldvs < 1 || *ldvs < nmax) {
+ *info = -20;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+/* Computing 2nd power */
+ i__3 = nmax;
+ i__1 = nmax * 3, i__2 = i__3 * i__3 << 1;
+ if (max(i__1,i__2) > *lwork) {
+ *info = -24;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CDRVSX", &i__1);
+ return 0;
+ }
+
+/* If nothing to do check on NIUNIT */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ goto L150;
+ }
+
+/* More Important constants */
+
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ slabad_(&unfl, &ovfl);
+ ulp = slamch_("Precision");
+ ulpinv = 1.f / ulp;
+ rtulp = sqrt(ulp);
+ rtulpi = 1.f / rtulp;
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L130;
+ }
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KCONDS KMODE KTYPE */
+/* =1 O(1) 1 clustered 1 zero */
+/* =2 large large clustered 2 identity */
+/* =3 small exponential Jordan */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random general, w/ eigenvalues */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 random general */
+/* =10 random triangular */
+
+ if (mtypes > 21) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L30;
+ case 2: goto L40;
+ case 3: goto L50;
+ }
+
+L30:
+ anorm = 1.f;
+ goto L60;
+
+L40:
+ anorm = ovfl * ulp;
+ goto L60;
+
+L50:
+ anorm = unfl * ulpinv;
+ goto L60;
+
+L60:
+
+ claset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+ if (itype == 1) {
+
+/* Zero */
+
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ a[i__4].r = anorm, a[i__4].i = 0.f;
+/* L70: */
+ }
+
+ } else if (itype == 3) {
+
+/* Jordan Block */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ a[i__4].r = anorm, a[i__4].i = 0.f;
+ if (jcol > 1) {
+ i__4 = jcol + (jcol - 1) * a_dim1;
+ a[i__4].r = 1.f, a[i__4].i = 0.f;
+ }
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[
+ n + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 6) {
+
+/* General, eigenvalues specified */
+
+ if (kconds[jtype - 1] == 1) {
+ conds = 1.f;
+ } else if (kconds[jtype - 1] == 2) {
+ conds = rtulpi;
+ } else {
+ conds = 0.f;
+ }
+
+ clatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2,
+ " ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n,
+ &anorm, &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b39,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &c__0, &
+ c__0, &c_b49, &anorm, "NO", &a[a_offset], lda, idumma,
+ &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ clatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b39,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &n, &
+ c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* General, random eigenvalues */
+
+ clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b39,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &n, &
+ c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
+ iinfo);
+ if (n >= 4) {
+ claset_("Full", &c__2, &n, &c_b1, &c_b1, &a[a_offset],
+ lda);
+ i__3 = n - 3;
+ claset_("Full", &i__3, &c__1, &c_b1, &c_b1, &a[a_dim1 + 3]
+, lda);
+ i__3 = n - 3;
+ claset_("Full", &i__3, &c__2, &c_b1, &c_b1, &a[(n - 1) *
+ a_dim1 + 3], lda);
+ claset_("Full", &c__1, &n, &c_b1, &c_b1, &a[n + a_dim1],
+ lda);
+ }
+
+ } else if (itype == 10) {
+
+/* Triangular, random eigenvalues */
+
+ clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b39,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &c__0, &
+ c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
+ iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___31.ciunit = *nounit;
+ s_wsfe(&io___31);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+/* Test for minimal and generous workspace */
+
+ for (iwk = 1; iwk <= 2; ++iwk) {
+ if (iwk == 1) {
+ nnwork = n << 1;
+ } else {
+/* Computing MAX */
+ i__3 = n << 1, i__4 = n * (n + 1) / 2;
+ nnwork = max(i__3,i__4);
+ }
+ nnwork = max(nnwork,1);
+
+ cget24_(&c_false, &jtype, thresh, ioldsd, nounit, &n, &a[
+ a_offset], lda, &h__[h_offset], &ht[ht_offset], &w[1],
+ &wt[1], &wtmp[1], &vs[vs_offset], ldvs, &vs1[
+ vs1_offset], &rcdein, &rcdvin, &nslct, islct, &c__0, &
+ result[1], &work[1], &nnwork, &rwork[1], &bwork[1],
+ info);
+
+/* Check for RESULT(j) > THRESH */
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 15; ++j) {
+ if (result[j] >= 0.f) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L100: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___40.ciunit = *nounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ e_wsfe();
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ e_wsfe();
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ e_wsfe();
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
+ e_wsfe();
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ e_wsfe();
+ ntestf = 2;
+ }
+
+ for (j = 1; j <= 15; ++j) {
+ if (result[j] >= *thresh) {
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ }
+/* L110: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+
+/* L120: */
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+
+L150:
+
+/* Read in data from file to check accuracy of condition estimation */
+/* Read input data until N=0 */
+
+ jtype = 0;
+L160:
+ io___47.ciunit = *niunit;
+ i__1 = s_rsle(&io___47);
+ if (i__1 != 0) {
+ goto L200;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L200;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&nslct, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L200;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&isrt, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L200;
+ }
+ i__1 = e_rsle();
+ if (i__1 != 0) {
+ goto L200;
+ }
+ if (n == 0) {
+ goto L200;
+ }
+ ++jtype;
+ iseed[1] = jtype;
+ io___49.ciunit = *niunit;
+ s_rsle(&io___49);
+ i__1 = nslct;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&islct[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___51.ciunit = *niunit;
+ s_rsle(&io___51);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
+ complex));
+ }
+ e_rsle();
+/* L170: */
+ }
+ io___52.ciunit = *niunit;
+ s_rsle(&io___52);
+ do_lio(&c__4, &c__1, (char *)&rcdein, (ftnlen)sizeof(real));
+ do_lio(&c__4, &c__1, (char *)&rcdvin, (ftnlen)sizeof(real));
+ e_rsle();
+
+ cget24_(&c_true, &c__22, thresh, &iseed[1], nounit, &n, &a[a_offset], lda,
+ &h__[h_offset], &ht[ht_offset], &w[1], &wt[1], &wtmp[1], &vs[
+ vs_offset], ldvs, &vs1[vs1_offset], &rcdein, &rcdvin, &nslct,
+ islct, &isrt, &result[1], &work[1], lwork, &rwork[1], &bwork[1],
+ info);
+
+/* Check for RESULT(j) > THRESH */
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 17; ++j) {
+ if (result[j] >= 0.f) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L180: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ e_wsfe();
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+ e_wsfe();
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ e_wsfe();
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
+ e_wsfe();
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ e_wsfe();
+ ntestf = 2;
+ }
+ for (j = 1; j <= 17; ++j) {
+ if (result[j] >= *thresh) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+/* L190: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+ goto L160;
+L200:
+
+/* Summary */
+
+ slasum_(path, nounit, &nerrs, &ntestt);
+
+
+
+ return 0;
+
+/* End of CDRVSX */
+
+} /* cdrvsx_ */
diff --git a/TESTING/EIG/cdrvvx.c b/TESTING/EIG/cdrvvx.c
new file mode 100644
index 0000000..3445b21
--- /dev/null
+++ b/TESTING/EIG/cdrvvx.c
@@ -0,0 +1,1083 @@
+/* cdrvvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__0 = 0;
+static integer c__4 = 4;
+static integer c__6 = 6;
+static real c_b39 = 1.f;
+static integer c__1 = 1;
+static real c_b49 = 0.f;
+static integer c__2 = 2;
+static logical c_false = FALSE_;
+static integer c__3 = 3;
+static logical c_true = TRUE_;
+static integer c__22 = 22;
+
+/* Subroutine */ int cdrvvx_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, integer *niunit,
+ integer *nounit, complex *a, integer *lda, complex *h__, complex *w,
+ complex *w1, complex *vl, integer *ldvl, complex *vr, integer *ldvr,
+ complex *lre, integer *ldlre, real *rcondv, real *rcndv1, real *
+ rcdvin, real *rconde, real *rcnde1, real *rcdein, real *scale, real *
+ scale1, real *result, complex *work, integer *nwork, real *rwork,
+ integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
+ static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
+ static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
+ static char bal[1*4] = "N" "P" "S" "B";
+
+ /* Format strings */
+ static char fmt_9992[] = "(\002 CDRVVX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(/1x,a3,\002 -- Complex Eigenvalue-Eigenvect"
+ "or \002,\002Decomposition Expert Driver\002,/\002 Matrix types ("
+ "see CDRVVX for details): \002)";
+ static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 \002,\002 5=Diagonal: geom"
+ "etr. spaced entries.\002,/\002 2=Identity matrix. "
+ " \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
+ "/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
+ " 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
+ "l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
+ "ll, evenly spaced.\002)";
+ static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
+ " 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
+ "l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
+ "d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
+ "red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
+ "vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
+ " 12=Well-cond., random complex \002,\002 \002,\002 17=Il"
+ "l-cond., large rand. complx \002,/\002 13=Ill-condi\002,\002tion"
+ "ed, evenly spaced. \002,\002 18=Ill-cond., small rand.\002"
+ ",\002 complx \002)";
+ static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
+ " \002,\002 21=Matrix \002,\002with small random entries.\002,"
+ "/\002 20=Matrix with large ran\002,\002dom entries. \002,\002 "
+ "22=Matrix read from input file\002,/)";
+ static char fmt_9995[] = "(\002 Tests performed with test threshold ="
+ "\002,f8.2,//\002 1 = | A VR - VR W | / ( n |A| ulp ) \002,/\002 "
+ "2 = | transpose(A) VL - VL W | / ( n |A| ulp ) \002,/\002 3 = | "
+ "|VR(i)| - 1 | / ulp \002,/\002 4 = | |VL(i)| - 1 | / ulp \002,"
+ "/\002 5 = 0 if W same no matter if VR or VL computed,\002,\002 1"
+ "/ulp otherwise\002,/\002 6 = 0 if VR same no matter what else co"
+ "mputed,\002,\002 1/ulp otherwise\002,/\002 7 = 0 if VL same no "
+ "matter what else computed,\002,\002 1/ulp otherwise\002,/\002 8"
+ " = 0 if RCONDV same no matter what else computed,\002,\002 1/ul"
+ "p otherwise\002,/\002 9 = 0 if SCALE, ILO, IHI, ABNRM same no ma"
+ "tter what else\002,\002 computed, 1/ulp otherwise\002,/\002 10 "
+ "= | RCONDV - RCONDV(precomputed) | / cond(RCONDV),\002,/\002 11 "
+ "= | RCONDE - RCONDE(precomputed) | / cond(RCONDE),\002)";
+ static char fmt_9994[] = "(\002 BALANC='\002,a1,\002',N=\002,i4,\002,I"
+ "WK=\002,i1,\002, seed=\002,4(i4,\002,\002),\002 type \002,i2,"
+ "\002, test(\002,i2,\002)=\002,g10.3)";
+ static char fmt_9993[] = "(\002 N=\002,i5,\002, input example =\002,i3"
+ ",\002, test(\002,i2,\002)=\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1,
+ vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4;
+ complex q__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+
+ /* Local variables */
+ integer i__, j, n;
+ real wi, wr;
+ integer iwk;
+ real ulp;
+ integer ibal;
+ real cond;
+ integer jcol;
+ char path[3];
+ integer nmax;
+ real unfl, ovfl;
+ integer isrt;
+ logical badnn;
+ extern /* Subroutine */ int cget23_(logical *, integer *, char *, integer
+ *, real *, integer *, integer *, integer *, complex *, integer *,
+ complex *, complex *, complex *, complex *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *, real *, real *,
+ real *, real *, real *, real *, real *, complex *, integer *,
+ real *, integer *);
+ integer nfail, imode, iinfo;
+ real conds, anorm;
+ integer jsize, nerrs, itype, jtype, ntest;
+ real rtulp;
+ char balanc[1];
+ extern /* Subroutine */ int slabad_(real *, real *), clatme_(integer *,
+ char *, integer *, complex *, integer *, real *, complex *, char *
+, char *, char *, char *, real *, integer *, real *, integer *,
+ integer *, real *, complex *, integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *);
+ integer idumma[1];
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int clatmr_(integer *, integer *, char *, integer
+ *, char *, complex *, integer *, real *, complex *, char *, char *
+, complex *, integer *, real *, complex *, integer *, real *,
+ char *, integer *, integer *, integer *, real *, real *, char *,
+ complex *, integer *, integer *, integer *), clatms_(integer *, integer *,
+ char *, integer *, char *, real *, integer *, real *, real *,
+ integer *, integer *, char *, complex *, integer *, complex *,
+ integer *);
+ integer ntestf;
+ extern /* Subroutine */ int slasum_(char *, integer *, integer *, integer
+ *);
+ integer nnwork;
+ real rtulpi;
+ integer mtypes, ntestt;
+ real ulpinv;
+
+ /* Fortran I/O blocks */
+ static cilist io___32 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___45 = { 0, 0, 1, 0, 0 };
+ static cilist io___48 = { 0, 0, 0, 0, 0 };
+ static cilist io___49 = { 0, 0, 0, 0, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVVX checks the nonsymmetric eigenvalue problem expert driver */
+/* CGEEVX. */
+
+/* CDRVVX uses both test matrices generated randomly depending on */
+/* data supplied in the calling sequence, as well as on data */
+/* read from an input file and including precomputed condition */
+/* numbers to which it compares the ones it computes. */
+
+/* When CDRVVX is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified in the calling sequence. */
+/* For each size ("n") and each type of matrix, one matrix will be */
+/* generated and used to test the nonsymmetric eigenroutines. For */
+/* each matrix, 9 tests will be performed: */
+
+/* (1) | A * VR - VR * W | / ( n |A| ulp ) */
+
+/* Here VR is the matrix of unit right eigenvectors. */
+/* W is a diagonal matrix with diagonal entries W(j). */
+
+/* (2) | A**H * VL - VL * W**H | / ( n |A| ulp ) */
+
+/* Here VL is the matrix of unit left eigenvectors, A**H is the */
+/* conjugate transpose of A, and W is as above. */
+
+/* (3) | |VR(i)| - 1 | / ulp and largest component real */
+
+/* VR(i) denotes the i-th column of VR. */
+
+/* (4) | |VL(i)| - 1 | / ulp and largest component real */
+
+/* VL(i) denotes the i-th column of VL. */
+
+/* (5) W(full) = W(partial) */
+
+/* W(full) denotes the eigenvalues computed when VR, VL, RCONDV */
+/* and RCONDE are also computed, and W(partial) denotes the */
+/* eigenvalues computed when only some of VR, VL, RCONDV, and */
+/* RCONDE are computed. */
+
+/* (6) VR(full) = VR(partial) */
+
+/* VR(full) denotes the right eigenvectors computed when VL, RCONDV */
+/* and RCONDE are computed, and VR(partial) denotes the result */
+/* when only some of VL and RCONDV are computed. */
+
+/* (7) VL(full) = VL(partial) */
+
+/* VL(full) denotes the left eigenvectors computed when VR, RCONDV */
+/* and RCONDE are computed, and VL(partial) denotes the result */
+/* when only some of VR and RCONDV are computed. */
+
+/* (8) 0 if SCALE, ILO, IHI, ABNRM (full) = */
+/* SCALE, ILO, IHI, ABNRM (partial) */
+/* 1/ulp otherwise */
+
+/* SCALE, ILO, IHI and ABNRM describe how the matrix is balanced. */
+/* (full) is when VR, VL, RCONDE and RCONDV are also computed, and */
+/* (partial) is when some are not computed. */
+
+/* (9) RCONDV(full) = RCONDV(partial) */
+
+/* RCONDV(full) denotes the reciprocal condition numbers of the */
+/* right eigenvectors computed when VR, VL and RCONDE are also */
+/* computed. RCONDV(partial) denotes the reciprocal condition */
+/* numbers when only some of VR, VL and RCONDE are computed. */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
+
+/* (4) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random complex angles. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (5) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random complex angles. */
+/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random complex angles. */
+
+/* (7) Same as (4), but multiplied by a constant near */
+/* the overflow threshold */
+/* (8) Same as (4), but multiplied by a constant near */
+/* the underflow threshold */
+
+/* (9) A matrix of the form U' T U, where U is unitary and */
+/* T has evenly spaced entries 1, ..., ULP with random complex */
+/* angles on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (10) A matrix of the form U' T U, where U is unitary and */
+/* T has geometrically spaced entries 1, ..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (11) A matrix of the form U' T U, where U is unitary and */
+/* T has "clustered" entries 1, ULP,..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (12) A matrix of the form U' T U, where U is unitary and */
+/* T has complex eigenvalues randomly chosen from */
+/* ULP < |z| < 1 and random O(1) entries in the upper */
+/* triangle. */
+
+/* (13) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
+/* with random complex angles on the diagonal and random O(1) */
+/* entries in the upper triangle. */
+
+/* (14) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has geometrically spaced entries */
+/* 1, ..., ULP with random complex angles on the diagonal */
+/* and random O(1) entries in the upper triangle. */
+
+/* (15) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
+/* with random complex angles on the diagonal and random O(1) */
+/* entries in the upper triangle. */
+
+/* (16) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has complex eigenvalues randomly chosen */
+/* from ULP < |z| < 1 and random O(1) entries in the upper */
+/* triangle. */
+
+/* (17) Same as (16), but multiplied by a constant */
+/* near the overflow threshold */
+/* (18) Same as (16), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* (19) Nonsymmetric matrix with random entries chosen from |z| < 1 */
+/* If N is at least 4, all entries in first two rows and last */
+/* row, and first column and last two columns are zero. */
+/* (20) Same as (19), but multiplied by a constant */
+/* near the overflow threshold */
+/* (21) Same as (19), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* In addition, an input file will be read from logical unit number */
+/* NIUNIT. The file contains matrices along with precomputed */
+/* eigenvalues and reciprocal condition numbers for the eigenvalues */
+/* and right eigenvectors. For these matrices, in addition to tests */
+/* (1) to (9) we will compute the following two tests: */
+
+/* (10) |RCONDV - RCDVIN| / cond(RCONDV) */
+
+/* RCONDV is the reciprocal right eigenvector condition number */
+/* computed by CGEEVX and RCDVIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDV) is the condition number of */
+/* RCONDV, and takes errors in computing RCONDV into account, so */
+/* that the resulting quantity should be O(ULP). cond(RCONDV) is */
+/* essentially given by norm(A)/RCONDE. */
+
+/* (11) |RCONDE - RCDEIN| / cond(RCONDE) */
+
+/* RCONDE is the reciprocal eigenvalue condition number */
+/* computed by CGEEVX and RCDEIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDE) is the condition number */
+/* of RCONDE, and takes errors in computing RCONDE into account, */
+/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
+/* is essentially given by norm(A)/RCONDV. */
+
+/* Arguments */
+/* ========== */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. NSIZES must be at */
+/* least zero. If it is zero, no randomly generated matrices */
+/* are tested, but any test matrices read from NIUNIT will be */
+/* tested. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. NTYPES must be at least */
+/* zero. If it is zero, no randomly generated test matrices */
+/* are tested, but and test matrices read from NIUNIT will be */
+/* tested. If it is MAXTYP+1 and NSIZES is 1, then an */
+/* additional type, MAXTYP+1 is defined, which is to use */
+/* whatever matrix is in A. This is only useful if */
+/* DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to CDRVVX to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NIUNIT (input) INTEGER */
+/* The FORTRAN unit number for reading in the data file of */
+/* problems to solve. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* A (workspace) COMPLEX array, dimension (LDA, max(NN,12)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, and H. LDA must be at */
+/* least 1 and at least max( NN, 12 ). (12 is the */
+/* dimension of the largest matrix on the precomputed */
+/* input file.) */
+
+/* H (workspace) COMPLEX array, dimension (LDA, max(NN,12)) */
+/* Another copy of the test matrix A, modified by CGEEVX. */
+
+/* W (workspace) COMPLEX array, dimension (max(NN,12)) */
+/* Contains the eigenvalues of A. */
+
+/* W1 (workspace) COMPLEX array, dimension (max(NN,12)) */
+/* Like W, this array contains the eigenvalues of A, */
+/* but those computed when CGEEVX only computes a partial */
+/* eigendecomposition, i.e. not the eigenvalues and left */
+/* and right eigenvectors. */
+
+/* VL (workspace) COMPLEX array, dimension (LDVL, max(NN,12)) */
+/* VL holds the computed left eigenvectors. */
+
+/* LDVL (input) INTEGER */
+/* Leading dimension of VL. Must be at least max(1,max(NN,12)). */
+
+/* VR (workspace) COMPLEX array, dimension (LDVR, max(NN,12)) */
+/* VR holds the computed right eigenvectors. */
+
+/* LDVR (input) INTEGER */
+/* Leading dimension of VR. Must be at least max(1,max(NN,12)). */
+
+/* LRE (workspace) COMPLEX array, dimension (LDLRE, max(NN,12)) */
+/* LRE holds the computed right or left eigenvectors. */
+
+/* LDLRE (input) INTEGER */
+/* Leading dimension of LRE. Must be at least max(1,max(NN,12)) */
+
+/* RESULT (output) REAL array, dimension (11) */
+/* The values computed by the seven tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* WORK (workspace) COMPLEX array, dimension (NWORK) */
+
+/* NWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* max(6*12+2*12**2,6*NN(j)+2*NN(j)**2) = */
+/* max( 360 ,6*NN(j)+2*NN(j)**2) for all j. */
+
+/* RWORK (workspace) REAL array, dimension (2*max(NN,12)) */
+
+/* INFO (output) INTEGER */
+/* If 0, then successful exit. */
+/* If <0, then input paramter -INFO is incorrect. */
+/* If >0, CLATMR, CLATMS, CLATME or CGET23 returned an error */
+/* code, and INFO is its absolute value. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NMAX Largest value in NN or 12. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* COND, CONDS, */
+/* IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTULP, RTULPI Square roots of the previous 4 values. */
+
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+/* KCONDS(j) Selectw whether CONDS is to be 1 or */
+/* 1/sqrt(ulp). (0 means irrelevant.) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ --w1;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ lre_dim1 = *ldlre;
+ lre_offset = 1 + lre_dim1;
+ lre -= lre_offset;
+ --rcondv;
+ --rcndv1;
+ --rcdvin;
+ --rconde;
+ --rcnde1;
+ --rcdein;
+ --scale;
+ --scale1;
+ --result;
+ --work;
+ --rwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "VX", (ftnlen)2, (ftnlen)2);
+
+/* Check for errors */
+
+ ntestt = 0;
+ ntestf = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+
+/* 7 is the largest dimension in the input file of precomputed */
+/* problems */
+
+ nmax = 7;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.f) {
+ *info = -6;
+ } else if (*lda < 1 || *lda < nmax) {
+ *info = -10;
+ } else if (*ldvl < 1 || *ldvl < nmax) {
+ *info = -15;
+ } else if (*ldvr < 1 || *ldvr < nmax) {
+ *info = -17;
+ } else if (*ldlre < 1 || *ldlre < nmax) {
+ *info = -19;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = nmax;
+ if (nmax * 6 + (i__1 * i__1 << 1) > *nwork) {
+ *info = -30;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CDRVVX", &i__1);
+ return 0;
+ }
+
+/* If nothing to do check on NIUNIT */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ goto L160;
+ }
+
+/* More Important constants */
+
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ slabad_(&unfl, &ovfl);
+ ulp = slamch_("Precision");
+ ulpinv = 1.f / ulp;
+ rtulp = sqrt(ulp);
+ rtulpi = 1.f / rtulp;
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L140;
+ }
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KCONDS KMODE KTYPE */
+/* =1 O(1) 1 clustered 1 zero */
+/* =2 large large clustered 2 identity */
+/* =3 small exponential Jordan */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random general, w/ eigenvalues */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 random general */
+/* =10 random triangular */
+
+ if (mtypes > 21) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L30;
+ case 2: goto L40;
+ case 3: goto L50;
+ }
+
+L30:
+ anorm = 1.f;
+ goto L60;
+
+L40:
+ anorm = ovfl * ulp;
+ goto L60;
+
+L50:
+ anorm = unfl * ulpinv;
+ goto L60;
+
+L60:
+
+ claset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ a[i__4].r = anorm, a[i__4].i = 0.f;
+/* L70: */
+ }
+
+ } else if (itype == 3) {
+
+/* Jordan Block */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ a[i__4].r = anorm, a[i__4].i = 0.f;
+ if (jcol > 1) {
+ i__4 = jcol + (jcol - 1) * a_dim1;
+ a[i__4].r = 1.f, a[i__4].i = 0.f;
+ }
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[
+ n + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 6) {
+
+/* General, eigenvalues specified */
+
+ if (kconds[jtype - 1] == 1) {
+ conds = 1.f;
+ } else if (kconds[jtype - 1] == 2) {
+ conds = rtulpi;
+ } else {
+ conds = 0.f;
+ }
+
+ clatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2,
+ " ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n,
+ &anorm, &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ clatmr_(&n, &n, "D", &iseed[1], "S", &work[1], &c__6, &c_b39,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &c__0, &
+ c__0, &c_b49, &anorm, "NO", &a[a_offset], lda, idumma,
+ &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ clatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b39,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &n, &
+ c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* General, random eigenvalues */
+
+ clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b39,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &n, &
+ c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
+ iinfo);
+ if (n >= 4) {
+ claset_("Full", &c__2, &n, &c_b1, &c_b1, &a[a_offset],
+ lda);
+ i__3 = n - 3;
+ claset_("Full", &i__3, &c__1, &c_b1, &c_b1, &a[a_dim1 + 3]
+, lda);
+ i__3 = n - 3;
+ claset_("Full", &i__3, &c__2, &c_b1, &c_b1, &a[(n - 1) *
+ a_dim1 + 3], lda);
+ claset_("Full", &c__1, &n, &c_b1, &c_b1, &a[n + a_dim1],
+ lda);
+ }
+
+ } else if (itype == 10) {
+
+/* Triangular, random eigenvalues */
+
+ clatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b39,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &c__0, &
+ c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
+ iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___32.ciunit = *nounit;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+/* Test for minimal and generous workspace */
+
+ for (iwk = 1; iwk <= 3; ++iwk) {
+ if (iwk == 1) {
+ nnwork = n << 1;
+ } else if (iwk == 2) {
+/* Computing 2nd power */
+ i__3 = n;
+ nnwork = (n << 1) + i__3 * i__3;
+ } else {
+/* Computing 2nd power */
+ i__3 = n;
+ nnwork = n * 6 + (i__3 * i__3 << 1);
+ }
+ nnwork = max(nnwork,1);
+
+/* Test for all balancing options */
+
+ for (ibal = 1; ibal <= 4; ++ibal) {
+ *(unsigned char *)balanc = *(unsigned char *)&bal[ibal -
+ 1];
+
+/* Perform tests */
+
+ cget23_(&c_false, &c__0, balanc, &jtype, thresh, ioldsd,
+ nounit, &n, &a[a_offset], lda, &h__[h_offset], &w[
+ 1], &w1[1], &vl[vl_offset], ldvl, &vr[vr_offset],
+ ldvr, &lre[lre_offset], ldlre, &rcondv[1], &
+ rcndv1[1], &rcdvin[1], &rconde[1], &rcnde1[1], &
+ rcdein[1], &scale[1], &scale1[1], &result[1], &
+ work[1], &nnwork, &rwork[1], info);
+
+/* Check for RESULT(j) > THRESH */
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 9; ++j) {
+ if (result[j] >= 0.f) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L100: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___39.ciunit = *nounit;
+ s_wsfe(&io___39);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___40.ciunit = *nounit;
+ s_wsfe(&io___40);
+ e_wsfe();
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ e_wsfe();
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ e_wsfe();
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ ntestf = 2;
+ }
+
+ for (j = 1; j <= 9; ++j) {
+ if (result[j] >= *thresh) {
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, balanc, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ }
+/* L110: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+
+/* L120: */
+ }
+/* L130: */
+ }
+L140:
+ ;
+ }
+/* L150: */
+ }
+
+L160:
+
+/* Read in data from file to check accuracy of condition estimation. */
+/* Assume input eigenvalues are sorted lexicographically (increasing */
+/* by real part, then decreasing by imaginary part) */
+
+ jtype = 0;
+L170:
+ io___45.ciunit = *niunit;
+ i__1 = s_rsle(&io___45);
+ if (i__1 != 0) {
+ goto L220;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L220;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&isrt, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L220;
+ }
+ i__1 = e_rsle();
+ if (i__1 != 0) {
+ goto L220;
+ }
+
+/* Read input data until N=0 */
+
+ if (n == 0) {
+ goto L220;
+ }
+ ++jtype;
+ iseed[1] = jtype;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___48.ciunit = *niunit;
+ s_rsle(&io___48);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
+ complex));
+ }
+ e_rsle();
+/* L180: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___49.ciunit = *niunit;
+ s_rsle(&io___49);
+ do_lio(&c__4, &c__1, (char *)&wr, (ftnlen)sizeof(real));
+ do_lio(&c__4, &c__1, (char *)&wi, (ftnlen)sizeof(real));
+ do_lio(&c__4, &c__1, (char *)&rcdein[i__], (ftnlen)sizeof(real));
+ do_lio(&c__4, &c__1, (char *)&rcdvin[i__], (ftnlen)sizeof(real));
+ e_rsle();
+ i__2 = i__;
+ q__1.r = wr, q__1.i = wi;
+ w1[i__2].r = q__1.r, w1[i__2].i = q__1.i;
+/* L190: */
+ }
+/* Computing 2nd power */
+ i__2 = n;
+ i__1 = n * 6 + (i__2 * i__2 << 1);
+ cget23_(&c_true, &isrt, "N", &c__22, thresh, &iseed[1], nounit, &n, &a[
+ a_offset], lda, &h__[h_offset], &w[1], &w1[1], &vl[vl_offset],
+ ldvl, &vr[vr_offset], ldvr, &lre[lre_offset], ldlre, &rcondv[1], &
+ rcndv1[1], &rcdvin[1], &rconde[1], &rcnde1[1], &rcdein[1], &scale[
+ 1], &scale1[1], &result[1], &work[1], &i__1, &rwork[1], info);
+
+/* Check for RESULT(j) > THRESH */
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 11; ++j) {
+ if (result[j] >= 0.f) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L200: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ e_wsfe();
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ e_wsfe();
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+ e_wsfe();
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
+ e_wsfe();
+ ntestf = 2;
+ }
+
+ for (j = 1; j <= 11; ++j) {
+ if (result[j] >= *thresh) {
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+/* L210: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+ goto L170;
+L220:
+
+/* Summary */
+
+ slasum_(path, nounit, &nerrs, &ntestt);
+
+
+
+ return 0;
+
+/* End of CDRVVX */
+
+} /* cdrvvx_ */
diff --git a/TESTING/EIG/cerrbd.c b/TESTING/EIG/cerrbd.c
new file mode 100644
index 0000000..641e13e
--- /dev/null
+++ b/TESTING/EIG/cerrbd.c
@@ -0,0 +1,352 @@
+/* cerrbd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int cerrbd_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
+ "rror exits (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
+ "ts of the error \002,\002exits ***\002)";
+
+ /* System generated locals */
+ integer i__1;
+ real r__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ complex a[16] /* was [4][4] */;
+ real d__[4], e[4];
+ integer i__, j;
+ complex u[16] /* was [4][4] */, v[16] /* was [4][4] */, w[4];
+ char c2[2];
+ integer nt;
+ complex tp[4], tq[4];
+ real rw[16];
+ integer info;
+ extern /* Subroutine */ int cgebrd_(integer *, integer *, complex *,
+ integer *, real *, real *, complex *, complex *, complex *,
+ integer *, integer *), cbdsqr_(char *, integer *, integer *,
+ integer *, integer *, real *, real *, complex *, integer *,
+ complex *, integer *, complex *, integer *, real *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int cungbr_(char *, integer *, integer *, integer
+ *, complex *, integer *, complex *, complex *, integer *, integer
+ *), chkxer_(char *, integer *, integer *, logical *,
+ logical *), cunmbr_(char *, char *, char *, integer *,
+ integer *, integer *, complex *, integer *, complex *, complex *,
+ integer *, complex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___16 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___17 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERRBD tests the error exits for CGEBRD, CUNGBR, CUNMBR, and CBDSQR. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ r__1 = 1.f / (real) (i__ + j);
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+ nt = 0;
+
+/* Test error exits of the SVD routines. */
+
+ if (lsamen_(&c__2, c2, "BD")) {
+
+/* CGEBRD */
+
+ s_copy(srnamc_1.srnamt, "CGEBRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgebrd_(&c_n1, &c__0, a, &c__1, d__, e, tq, tp, w, &c__1, &info);
+ chkxer_("CGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgebrd_(&c__0, &c_n1, a, &c__1, d__, e, tq, tp, w, &c__1, &info);
+ chkxer_("CGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgebrd_(&c__2, &c__1, a, &c__1, d__, e, tq, tp, w, &c__2, &info);
+ chkxer_("CGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cgebrd_(&c__2, &c__1, a, &c__2, d__, e, tq, tp, w, &c__1, &info);
+ chkxer_("CGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 4;
+
+/* CUNGBR */
+
+ s_copy(srnamc_1.srnamt, "CUNGBR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cungbr_("/", &c__0, &c__0, &c__0, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("CUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cungbr_("Q", &c_n1, &c__0, &c__0, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("CUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cungbr_("Q", &c__0, &c_n1, &c__0, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("CUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cungbr_("Q", &c__0, &c__1, &c__0, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("CUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cungbr_("Q", &c__1, &c__0, &c__1, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("CUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cungbr_("P", &c__1, &c__0, &c__0, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("CUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cungbr_("P", &c__0, &c__1, &c__1, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("CUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cungbr_("Q", &c__0, &c__0, &c_n1, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("CUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cungbr_("Q", &c__2, &c__1, &c__1, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("CUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ cungbr_("Q", &c__2, &c__2, &c__1, a, &c__2, tq, w, &c__1, &info);
+ chkxer_("CUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* CUNMBR */
+
+ s_copy(srnamc_1.srnamt, "CUNMBR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cunmbr_("/", "L", "T", &c__0, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("CUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cunmbr_("Q", "/", "T", &c__0, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("CUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cunmbr_("Q", "L", "/", &c__0, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("CUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cunmbr_("Q", "L", "C", &c_n1, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("CUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunmbr_("Q", "L", "C", &c__0, &c_n1, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("CUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cunmbr_("Q", "L", "C", &c__0, &c__0, &c_n1, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("CUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cunmbr_("Q", "L", "C", &c__2, &c__0, &c__0, a, &c__1, tq, u, &c__2, w,
+ &c__1, &info);
+ chkxer_("CUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cunmbr_("Q", "R", "C", &c__0, &c__2, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("CUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cunmbr_("P", "L", "C", &c__2, &c__0, &c__2, a, &c__1, tq, u, &c__2, w,
+ &c__1, &info);
+ chkxer_("CUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cunmbr_("P", "R", "C", &c__0, &c__2, &c__2, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("CUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ cunmbr_("Q", "R", "C", &c__2, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("CUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ cunmbr_("Q", "L", "C", &c__0, &c__2, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__0, &info);
+ chkxer_("CUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ cunmbr_("Q", "R", "C", &c__2, &c__0, &c__0, a, &c__1, tq, u, &c__2, w,
+ &c__0, &info);
+ chkxer_("CUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 13;
+
+/* CBDSQR */
+
+ s_copy(srnamc_1.srnamt, "CBDSQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cbdsqr_("/", &c__0, &c__0, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, rw, &info);
+ chkxer_("CBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cbdsqr_("U", &c_n1, &c__0, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, rw, &info);
+ chkxer_("CBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cbdsqr_("U", &c__0, &c_n1, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, rw, &info);
+ chkxer_("CBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cbdsqr_("U", &c__0, &c__0, &c_n1, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, rw, &info);
+ chkxer_("CBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cbdsqr_("U", &c__0, &c__0, &c__0, &c_n1, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, rw, &info);
+ chkxer_("CBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ cbdsqr_("U", &c__2, &c__1, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, rw, &info);
+ chkxer_("CBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ cbdsqr_("U", &c__0, &c__0, &c__2, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, rw, &info);
+ chkxer_("CBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ cbdsqr_("U", &c__2, &c__0, &c__0, &c__1, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, rw, &info);
+ chkxer_("CBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+ }
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___16.ciunit = infoc_1.nout;
+ s_wsfe(&io___16);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___17.ciunit = infoc_1.nout;
+ s_wsfe(&io___17);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of CERRBD */
+
+} /* cerrbd_ */
diff --git a/TESTING/EIG/cerrec.c b/TESTING/EIG/cerrec.c
new file mode 100644
index 0000000..a16a08b
--- /dev/null
+++ b/TESTING/EIG/cerrec.c
@@ -0,0 +1,352 @@
+/* cerrec.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+
+/* Subroutine */ int cerrec_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
+ "rror exits (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
+ "ts of the error \002,\002exits ***\002)";
+
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ complex a[16] /* was [4][4] */, b[16] /* was [4][4] */, c__[16]
+ /* was [4][4] */;
+ integer i__, j, m;
+ real s[4];
+ complex x[4];
+ integer nt;
+ real rw[24];
+ logical sel[4];
+ real sep[4];
+ integer info, ifst, ilst;
+ complex work[24];
+ real scale;
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), ctrexc_(char *, integer *, complex *,
+ integer *, complex *, integer *, integer *, integer *, integer *), ctrsna_(char *, char *, logical *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, real *,
+ real *, integer *, integer *, complex *, integer *, real *,
+ integer *), ctrsen_(char *, char *, logical *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, real *, real *, complex *, integer *, integer *), ctrsyl_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___18 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___19 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERREC tests the error exits for the routines for eigen- condition */
+/* estimation for REAL matrices: */
+/* CTRSYL, CTREXC, CTRSNA and CTRSEN. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ infoc_1.ok = TRUE_;
+ nt = 0;
+
+/* Initialize A, B and SEL */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ a[i__1].r = 0.f, a[i__1].i = 0.f;
+ i__1 = i__ + (j << 2) - 5;
+ b[i__1].r = 0.f, b[i__1].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (i__ << 2) - 5;
+ a[i__1].r = 1.f, a[i__1].i = 0.f;
+ sel[i__ - 1] = TRUE_;
+/* L30: */
+ }
+
+/* Test CTRSYL */
+
+ s_copy(srnamc_1.srnamt, "CTRSYL", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctrsyl_("X", "N", &c__1, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("CTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctrsyl_("N", "X", &c__1, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("CTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ctrsyl_("N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("CTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ctrsyl_("N", "N", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("CTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrsyl_("N", "N", &c__1, &c__0, &c_n1, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("CTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ctrsyl_("N", "N", &c__1, &c__2, &c__0, a, &c__1, b, &c__1, c__, &c__2, &
+ scale, &info);
+ chkxer_("CTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrsyl_("N", "N", &c__1, &c__0, &c__2, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("CTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrsyl_("N", "N", &c__1, &c__2, &c__0, a, &c__2, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("CTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Test CTREXC */
+
+ s_copy(srnamc_1.srnamt, "CTREXC", (ftnlen)32, (ftnlen)6);
+ ifst = 1;
+ ilst = 1;
+ infoc_1.infot = 1;
+ ctrexc_("X", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
+ chkxer_("CTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ctrexc_("N", &c__0, a, &c__1, b, &c__1, &ifst, &ilst, &info);
+ chkxer_("CTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ilst = 2;
+ ctrexc_("N", &c__2, a, &c__1, b, &c__1, &ifst, &ilst, &info);
+ chkxer_("CTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrexc_("V", &c__2, a, &c__2, b, &c__1, &ifst, &ilst, &info);
+ chkxer_("CTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ifst = 0;
+ ilst = 1;
+ ctrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
+ chkxer_("CTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ifst = 2;
+ ctrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
+ chkxer_("CTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ifst = 1;
+ ilst = 0;
+ ctrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
+ chkxer_("CTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ilst = 2;
+ ctrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
+ chkxer_("CTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Test CTRSNA */
+
+ s_copy(srnamc_1.srnamt, "CTRSNA", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctrsna_("X", "A", sel, &c__0, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
+ c__1, &m, work, &c__1, rw, &info);
+ chkxer_("CTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctrsna_("B", "X", sel, &c__0, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
+ c__1, &m, work, &c__1, rw, &info);
+ chkxer_("CTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ctrsna_("B", "A", sel, &c_n1, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
+ c__1, &m, work, &c__1, rw, &info);
+ chkxer_("CTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrsna_("V", "A", sel, &c__2, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
+ c__2, &m, work, &c__2, rw, &info);
+ chkxer_("CTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ctrsna_("B", "A", sel, &c__2, a, &c__2, b, &c__1, c__, &c__2, s, sep, &
+ c__2, &m, work, &c__2, rw, &info);
+ chkxer_("CTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ctrsna_("B", "A", sel, &c__2, a, &c__2, b, &c__2, c__, &c__1, s, sep, &
+ c__2, &m, work, &c__2, rw, &info);
+ chkxer_("CTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ ctrsna_("B", "A", sel, &c__1, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
+ c__0, &m, work, &c__1, rw, &info);
+ chkxer_("CTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ ctrsna_("B", "S", sel, &c__2, a, &c__2, b, &c__2, c__, &c__2, s, sep, &
+ c__1, &m, work, &c__1, rw, &info);
+ chkxer_("CTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ ctrsna_("B", "A", sel, &c__2, a, &c__2, b, &c__2, c__, &c__2, s, sep, &
+ c__2, &m, work, &c__1, rw, &info);
+ chkxer_("CTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* Test CTRSEN */
+
+ sel[0] = FALSE_;
+ s_copy(srnamc_1.srnamt, "CTRSEN", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctrsen_("X", "N", sel, &c__0, a, &c__1, b, &c__1, x, &m, s, sep, work, &
+ c__1, &info);
+ chkxer_("CTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctrsen_("N", "X", sel, &c__0, a, &c__1, b, &c__1, x, &m, s, sep, work, &
+ c__1, &info);
+ chkxer_("CTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ctrsen_("N", "N", sel, &c_n1, a, &c__1, b, &c__1, x, &m, s, sep, work, &
+ c__1, &info);
+ chkxer_("CTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrsen_("N", "N", sel, &c__2, a, &c__1, b, &c__1, x, &m, s, sep, work, &
+ c__2, &info);
+ chkxer_("CTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ctrsen_("N", "V", sel, &c__2, a, &c__2, b, &c__1, x, &m, s, sep, work, &
+ c__1, &info);
+ chkxer_("CTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ ctrsen_("N", "V", sel, &c__2, a, &c__2, b, &c__2, x, &m, s, sep, work, &
+ c__0, &info);
+ chkxer_("CTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ ctrsen_("E", "V", sel, &c__3, a, &c__3, b, &c__3, x, &m, s, sep, work, &
+ c__1, &info);
+ chkxer_("CTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ ctrsen_("V", "V", sel, &c__3, a, &c__3, b, &c__3, x, &m, s, sep, work, &
+ c__3, &info);
+ chkxer_("CTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___18.ciunit = infoc_1.nout;
+ s_wsfe(&io___18);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___19.ciunit = infoc_1.nout;
+ s_wsfe(&io___19);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ return 0;
+
+/* End of CERREC */
+
+} /* cerrec_ */
diff --git a/TESTING/EIG/cerred.c b/TESTING/EIG/cerred.c
new file mode 100644
index 0000000..7d88ce1
--- /dev/null
+++ b/TESTING/EIG/cerred.c
@@ -0,0 +1,497 @@
+/* cerred.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ real selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__4 = 4;
+static integer c__5 = 5;
+
+/* Subroutine */ int cerred_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002 passed the tests of the error exits"
+ " (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a,\002 failed the tests of the "
+ "error exits ***\002)";
+
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), i_len_trim(char *, ftnlen), do_fio(integer *,
+ char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ complex a[16] /* was [4][4] */;
+ logical b[4];
+ integer i__, j;
+ real s[4];
+ complex u[16] /* was [4][4] */, w[16], x[4];
+ char c2[2];
+ real r1[4], r2[4];
+ integer iw[16], nt;
+ complex vl[16] /* was [4][4] */, vr[16] /* was [4][4] */;
+ real rw[20];
+ complex vt[16] /* was [4][4] */;
+ integer ihi, ilo, info, sdim;
+ extern /* Subroutine */ int cgees_(char *, char *, L_fp, integer *,
+ complex *, integer *, integer *, complex *, complex *, integer *,
+ complex *, integer *, real *, logical *, integer *), cgeev_(char *, char *, integer *, complex *, integer *,
+ complex *, complex *, integer *, complex *, integer *, complex *,
+ integer *, real *, integer *);
+ real abnrm;
+ extern /* Subroutine */ int cgesdd_(char *, integer *, integer *, complex
+ *, integer *, real *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, integer *, integer *),
+ cgesvd_(char *, char *, integer *, integer *, complex *, integer *
+, real *, complex *, integer *, complex *, integer *, complex *,
+ integer *, real *, integer *);
+ extern logical cslect_();
+ extern /* Subroutine */ int cgeesx_(char *, char *, L_fp, char *, integer
+ *, complex *, integer *, integer *, complex *, complex *, integer
+ *, real *, real *, complex *, integer *, real *, logical *,
+ integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int cgeevx_(char *, char *, char *, char *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *, integer *, real *, real *, real *
+, real *, complex *, integer *, real *, integer *), chkxer_(char *, integer *, integer *, logical *,
+ logical *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERRED tests the error exits for the eigenvalue driver routines for */
+/* REAL matrices: */
+
+/* PATH driver description */
+/* ---- ------ ----------- */
+/* CEV CGEEV find eigenvalues/eigenvectors for nonsymmetric A */
+/* CES CGEES find eigenvalues/Schur form for nonsymmetric A */
+/* CVX CGEEVX CGEEV + balancing and condition estimation */
+/* CSX CGEESX CGEES + balancing and condition estimation */
+/* CBD CGESVD compute SVD of an M-by-N matrix A */
+/* CGESDD compute SVD of an M-by-N matrix A(by divide and */
+/* conquer) */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Initialize A */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ a[i__1].r = 0.f, a[i__1].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (i__ << 2) - 5;
+ a[i__1].r = 1.f, a[i__1].i = 0.f;
+/* L30: */
+ }
+ infoc_1.ok = TRUE_;
+ nt = 0;
+
+ if (lsamen_(&c__2, c2, "EV")) {
+
+/* Test CGEEV */
+
+ s_copy(srnamc_1.srnamt, "CGEEV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgeev_("X", "N", &c__0, a, &c__1, x, vl, &c__1, vr, &c__1, w, &c__1,
+ rw, &info);
+ chkxer_("CGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgeev_("N", "X", &c__0, a, &c__1, x, vl, &c__1, vr, &c__1, w, &c__1,
+ rw, &info);
+ chkxer_("CGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgeev_("N", "N", &c_n1, a, &c__1, x, vl, &c__1, vr, &c__1, w, &c__1,
+ rw, &info);
+ chkxer_("CGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgeev_("N", "N", &c__2, a, &c__1, x, vl, &c__1, vr, &c__1, w, &c__4,
+ rw, &info);
+ chkxer_("CGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cgeev_("V", "N", &c__2, a, &c__2, x, vl, &c__1, vr, &c__1, w, &c__4,
+ rw, &info);
+ chkxer_("CGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cgeev_("N", "V", &c__2, a, &c__2, x, vl, &c__1, vr, &c__1, w, &c__4,
+ rw, &info);
+ chkxer_("CGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cgeev_("V", "V", &c__1, a, &c__1, x, vl, &c__1, vr, &c__1, w, &c__1,
+ rw, &info);
+ chkxer_("CGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+
+ } else if (lsamen_(&c__2, c2, "ES")) {
+
+/* Test CGEES */
+
+ s_copy(srnamc_1.srnamt, "CGEES ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgees_("X", "N", (L_fp)cslect_, &c__0, a, &c__1, &sdim, x, vl, &c__1,
+ w, &c__1, rw, b, &info);
+ chkxer_("CGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgees_("N", "X", (L_fp)cslect_, &c__0, a, &c__1, &sdim, x, vl, &c__1,
+ w, &c__1, rw, b, &info);
+ chkxer_("CGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgees_("N", "S", (L_fp)cslect_, &c_n1, a, &c__1, &sdim, x, vl, &c__1,
+ w, &c__1, rw, b, &info);
+ chkxer_("CGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cgees_("N", "S", (L_fp)cslect_, &c__2, a, &c__1, &sdim, x, vl, &c__1,
+ w, &c__4, rw, b, &info);
+ chkxer_("CGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cgees_("V", "S", (L_fp)cslect_, &c__2, a, &c__2, &sdim, x, vl, &c__1,
+ w, &c__4, rw, b, &info);
+ chkxer_("CGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cgees_("N", "S", (L_fp)cslect_, &c__1, a, &c__1, &sdim, x, vl, &c__1,
+ w, &c__1, rw, b, &info);
+ chkxer_("CGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+ } else if (lsamen_(&c__2, c2, "VX")) {
+
+/* Test CGEEVX */
+
+ s_copy(srnamc_1.srnamt, "CGEEVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgeevx_("X", "N", "N", "N", &c__0, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, rw, &info);
+ chkxer_("CGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgeevx_("N", "X", "N", "N", &c__0, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, rw, &info);
+ chkxer_("CGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgeevx_("N", "N", "X", "N", &c__0, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, rw, &info);
+ chkxer_("CGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgeevx_("N", "N", "N", "X", &c__0, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, rw, &info);
+ chkxer_("CGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgeevx_("N", "N", "N", "N", &c_n1, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, rw, &info);
+ chkxer_("CGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cgeevx_("N", "N", "N", "N", &c__2, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &ilo, &ihi, s, &abnrm, r1, r2, w, &c__4, rw, &info);
+ chkxer_("CGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cgeevx_("N", "V", "N", "N", &c__2, a, &c__2, x, vl, &c__1, vr, &c__1,
+ &ilo, &ihi, s, &abnrm, r1, r2, w, &c__4, rw, &info);
+ chkxer_("CGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cgeevx_("N", "N", "V", "N", &c__2, a, &c__2, x, vl, &c__1, vr, &c__1,
+ &ilo, &ihi, s, &abnrm, r1, r2, w, &c__4, rw, &info);
+ chkxer_("CGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ cgeevx_("N", "N", "N", "N", &c__1, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, rw, &info);
+ chkxer_("CGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ cgeevx_("N", "N", "V", "V", &c__1, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &ilo, &ihi, s, &abnrm, r1, r2, w, &c__2, rw, &info);
+ chkxer_("CGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+ } else if (lsamen_(&c__2, c2, "SX")) {
+
+/* Test CGEESX */
+
+ s_copy(srnamc_1.srnamt, "CGEESX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgeesx_("X", "N", (L_fp)cslect_, "N", &c__0, a, &c__1, &sdim, x, vl, &
+ c__1, r1, r2, w, &c__1, rw, b, &info);
+ chkxer_("CGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgeesx_("N", "X", (L_fp)cslect_, "N", &c__0, a, &c__1, &sdim, x, vl, &
+ c__1, r1, r2, w, &c__1, rw, b, &info);
+ chkxer_("CGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgeesx_("N", "N", (L_fp)cslect_, "X", &c__0, a, &c__1, &sdim, x, vl, &
+ c__1, r1, r2, w, &c__1, rw, b, &info);
+ chkxer_("CGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgeesx_("N", "N", (L_fp)cslect_, "N", &c_n1, a, &c__1, &sdim, x, vl, &
+ c__1, r1, r2, w, &c__1, rw, b, &info);
+ chkxer_("CGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cgeesx_("N", "N", (L_fp)cslect_, "N", &c__2, a, &c__1, &sdim, x, vl, &
+ c__1, r1, r2, w, &c__4, rw, b, &info);
+ chkxer_("CGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ cgeesx_("V", "N", (L_fp)cslect_, "N", &c__2, a, &c__2, &sdim, x, vl, &
+ c__1, r1, r2, w, &c__4, rw, b, &info);
+ chkxer_("CGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ cgeesx_("N", "N", (L_fp)cslect_, "N", &c__1, a, &c__1, &sdim, x, vl, &
+ c__1, r1, r2, w, &c__1, rw, b, &info);
+ chkxer_("CGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+
+ } else if (lsamen_(&c__2, c2, "BD")) {
+
+/* Test CGESVD */
+
+ s_copy(srnamc_1.srnamt, "CGESVD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgesvd_("X", "N", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__1, rw, &info);
+ chkxer_("CGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgesvd_("N", "X", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__1, rw, &info);
+ chkxer_("CGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgesvd_("O", "O", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__1, rw, &info);
+ chkxer_("CGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgesvd_("N", "N", &c_n1, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__1, rw, &info);
+ chkxer_("CGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgesvd_("N", "N", &c__0, &c_n1, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__1, rw, &info);
+ chkxer_("CGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cgesvd_("N", "N", &c__2, &c__1, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__5, rw, &info);
+ chkxer_("CGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ cgesvd_("A", "N", &c__2, &c__1, a, &c__2, s, u, &c__1, vt, &c__1, w, &
+ c__5, rw, &info);
+ chkxer_("CGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ cgesvd_("N", "A", &c__1, &c__2, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__5, rw, &info);
+ chkxer_("CGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+ if (infoc_1.ok) {
+ io___23.ciunit = infoc_1.nout;
+ s_wsfe(&io___23);
+ do_fio(&c__1, srnamc_1.srnamt, i_len_trim(srnamc_1.srnamt, (
+ ftnlen)32));
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___24.ciunit = infoc_1.nout;
+ s_wsfe(&io___24);
+ e_wsfe();
+ }
+
+/* Test CGESDD */
+
+ s_copy(srnamc_1.srnamt, "CGESDD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgesdd_("X", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
+ rw, iw, &info);
+ chkxer_("CGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgesdd_("N", &c_n1, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
+ rw, iw, &info);
+ chkxer_("CGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgesdd_("N", &c__0, &c_n1, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
+ rw, iw, &info);
+ chkxer_("CGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgesdd_("N", &c__2, &c__1, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__5,
+ rw, iw, &info);
+ chkxer_("CGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cgesdd_("A", &c__2, &c__1, a, &c__2, s, u, &c__1, vt, &c__1, w, &c__5,
+ rw, iw, &info);
+ chkxer_("CGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cgesdd_("A", &c__1, &c__2, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__5,
+ rw, iw, &info);
+ chkxer_("CGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += -2;
+ if (infoc_1.ok) {
+ io___26.ciunit = infoc_1.nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, srnamc_1.srnamt, i_len_trim(srnamc_1.srnamt, (
+ ftnlen)32));
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___27.ciunit = infoc_1.nout;
+ s_wsfe(&io___27);
+ e_wsfe();
+ }
+ }
+
+/* Print a summary line. */
+
+ if (! lsamen_(&c__2, c2, "BD")) {
+ if (infoc_1.ok) {
+ io___28.ciunit = infoc_1.nout;
+ s_wsfe(&io___28);
+ do_fio(&c__1, srnamc_1.srnamt, i_len_trim(srnamc_1.srnamt, (
+ ftnlen)32));
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___29.ciunit = infoc_1.nout;
+ s_wsfe(&io___29);
+ e_wsfe();
+ }
+ }
+
+ return 0;
+
+/* End of CERRED */
+
+} /* cerred_ */
diff --git a/TESTING/EIG/cerrgg.c b/TESTING/EIG/cerrgg.c
new file mode 100644
index 0000000..f74f4b1
--- /dev/null
+++ b/TESTING/EIG/cerrgg.c
@@ -0,0 +1,1294 @@
+/* cerrgg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__18 = 18;
+static integer c__32 = 32;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+static integer c_n5 = -5;
+static integer c__20 = 20;
+static integer c__5 = 5;
+
+/* Subroutine */ int cerrgg_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
+ "rror exits (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
+ "ts of the error \002,\002exits ***\002)";
+
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ complex a[9] /* was [3][3] */, b[9] /* was [3][3] */;
+ integer i__, j, m;
+ complex q[9] /* was [3][3] */, u[9] /* was [3][3] */, v[9] /*
+ was [3][3] */, w[18], z__[9] /* was [3][3] */;
+ char c2[2];
+ real r1[3], r2[3];
+ logical bw[3];
+ real ls[3];
+ integer iw[18], nt;
+ real rs[3], rw[18], dif, rce[3];
+ logical sel[3];
+ complex tau[3];
+ real rcv[3];
+ complex beta[3];
+ integer info, sdim;
+ real anrm, bnrm, tola, tolb;
+ integer ifst, ilst;
+ complex alpha[3];
+ real scale;
+ extern /* Subroutine */ int cgges_(char *, char *, char *, L_fp, integer *
+, complex *, integer *, complex *, integer *, integer *, complex *
+, complex *, complex *, integer *, complex *, integer *, complex *
+, integer *, real *, logical *, integer *)
+ , cggev_(char *, char *, integer *, complex *, integer *, complex
+ *, integer *, complex *, complex *, complex *, integer *, complex
+ *, integer *, complex *, integer *, real *, integer *), cgghrd_(char *, char *, integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, integer *), cggglm_(integer
+ *, integer *, integer *, complex *, integer *, complex *, integer
+ *, complex *, complex *, complex *, complex *, integer *, integer
+ *), cgglse_(integer *, integer *, integer *, complex *, integer *,
+ complex *, integer *, complex *, complex *, complex *, complex *,
+ integer *, integer *), cggqrf_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, complex *,
+ complex *, integer *, integer *), cggrqf_(integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, complex *, integer *, integer *), ctgevc_(char *, char
+ *, logical *, integer *, complex *, integer *, complex *, integer
+ *, complex *, integer *, complex *, integer *, integer *, integer
+ *, complex *, real *, integer *);
+ integer ncycle;
+ extern logical clctes_(), lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int cggesx_(char *, char *, char *, L_fp, char *,
+ integer *, complex *, integer *, complex *, integer *, integer *,
+ complex *, complex *, complex *, integer *, complex *, integer *,
+ real *, real *, complex *, integer *, real *, integer *, integer *
+, logical *, integer *), cggsvd_(
+ char *, char *, char *, integer *, integer *, integer *, integer *
+, integer *, complex *, integer *, complex *, integer *, real *,
+ real *, complex *, integer *, complex *, integer *, complex *,
+ integer *, complex *, real *, integer *, integer *), chgeqz_(char *, char *, char *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ complex *, complex *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, integer *),
+ cggevx_(char *, char *, char *, char *, integer *, complex *,
+ integer *, complex *, integer *, complex *, complex *, complex *,
+ integer *, complex *, integer *, integer *, integer *, real *,
+ real *, real *, real *, real *, real *, complex *, integer *,
+ real *, integer *, logical *, integer *), chkxer_(char *, integer *, integer *, logical *, logical
+ *), ctgexc_(logical *, logical *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, integer *, integer *, integer *), ctgsen_(integer *,
+ logical *, logical *, logical *, integer *, complex *, integer *,
+ complex *, integer *, complex *, complex *, complex *, integer *,
+ complex *, integer *, integer *, real *, real *, real *, complex *
+, integer *, integer *, integer *, integer *), ctgsja_(char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, real *,
+ real *, real *, real *, complex *, integer *, complex *, integer *
+, complex *, integer *, complex *, integer *, integer *), ctgsna_(char *, char *, logical *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, real *, integer *, integer *,
+ complex *, integer *, integer *, integer *),
+ cggsvp_(char *, char *, char *, integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, real *, real *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, integer *, real *, complex *, complex *,
+ integer *);
+ extern logical clctsx_();
+ extern /* Subroutine */ int ctgsyl_(char *, integer *, integer *, integer
+ *, complex *, integer *, complex *, integer *, complex *, integer
+ *, complex *, integer *, complex *, integer *, complex *, integer
+ *, real *, real *, complex *, integer *, integer *, integer *);
+ integer dummyk, dummyl;
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERRGG tests the error exits for CGGES, CGGESX, CGGEV, CGGEVX, */
+/* CGGGLM, CGGHRD, CGGLSE, CGGQRF, CGGRQF, CGGSVD, CGGSVP, CHGEQZ, */
+/* CTGEVC, CTGEXC, CTGSEN, CTGSJA, CTGSNA, and CTGSYL. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 3; ++j) {
+ sel[j - 1] = TRUE_;
+ for (i__ = 1; i__ <= 3; ++i__) {
+ i__1 = i__ + j * 3 - 4;
+ a[i__1].r = 0.f, a[i__1].i = 0.f;
+ i__1 = i__ + j * 3 - 4;
+ b[i__1].r = 0.f, b[i__1].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ for (i__ = 1; i__ <= 3; ++i__) {
+ i__1 = i__ + i__ * 3 - 4;
+ a[i__1].r = 1.f, a[i__1].i = 0.f;
+ i__1 = i__ + i__ * 3 - 4;
+ b[i__1].r = 1.f, b[i__1].i = 0.f;
+/* L30: */
+ }
+ infoc_1.ok = TRUE_;
+ tola = 1.f;
+ tolb = 1.f;
+ ifst = 1;
+ ilst = 1;
+ nt = 0;
+
+/* Test error exits for the GG path. */
+
+ if (lsamen_(&c__2, c2, "GG")) {
+
+/* CGGHRD */
+
+ s_copy(srnamc_1.srnamt, "CGGHRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgghrd_("/", "N", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("CGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgghrd_("N", "/", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("CGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgghrd_("N", "N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("CGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgghrd_("N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("CGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgghrd_("N", "N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("CGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cgghrd_("N", "N", &c__2, &c__1, &c__1, a, &c__1, b, &c__2, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("CGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ cgghrd_("N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("CGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ cgghrd_("V", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("CGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ cgghrd_("N", "V", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("CGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* CHGEQZ */
+
+ s_copy(srnamc_1.srnamt, "CHGEQZ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chgeqz_("/", "N", "N", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, alpha,
+ beta, q, &c__1, z__, &c__1, w, &c__1, rw, &info);
+ chkxer_("CHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chgeqz_("E", "/", "N", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, alpha,
+ beta, q, &c__1, z__, &c__1, w, &c__1, rw, &info);
+ chkxer_("CHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ chgeqz_("E", "N", "/", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, alpha,
+ beta, q, &c__1, z__, &c__1, w, &c__1, rw, &info);
+ chkxer_("CHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ chgeqz_("E", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, alpha,
+ beta, q, &c__1, z__, &c__1, w, &c__1, rw, &info);
+ chkxer_("CHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ chgeqz_("E", "N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, alpha,
+ beta, q, &c__1, z__, &c__1, w, &c__1, rw, &info);
+ chkxer_("CHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ chgeqz_("E", "N", "N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, alpha,
+ beta, q, &c__1, z__, &c__1, w, &c__1, rw, &info);
+ chkxer_("CHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ chgeqz_("E", "N", "N", &c__2, &c__1, &c__1, a, &c__1, b, &c__2, alpha,
+ beta, q, &c__1, z__, &c__1, w, &c__1, rw, &info);
+ chkxer_("CHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ chgeqz_("E", "N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__1, alpha,
+ beta, q, &c__1, z__, &c__1, w, &c__1, rw, &info);
+ chkxer_("CHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ chgeqz_("E", "V", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, alpha,
+ beta, q, &c__1, z__, &c__1, w, &c__1, rw, &info);
+ chkxer_("CHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ chgeqz_("E", "N", "V", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, alpha,
+ beta, q, &c__1, z__, &c__1, w, &c__1, rw, &info);
+ chkxer_("CHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* CTGEVC */
+
+ s_copy(srnamc_1.srnamt, "CTGEVC", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctgevc_("/", "A", sel, &c__0, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__1, &c__0, &m, w, rw, &info);
+ chkxer_("CTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctgevc_("R", "/", sel, &c__0, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__1, &c__0, &m, w, rw, &info);
+ chkxer_("CTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ctgevc_("R", "A", sel, &c_n1, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__1, &c__0, &m, w, rw, &info);
+ chkxer_("CTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ctgevc_("R", "A", sel, &c__2, a, &c__1, b, &c__2, q, &c__1, z__, &
+ c__2, &c__0, &m, w, rw, &info);
+ chkxer_("CTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ctgevc_("R", "A", sel, &c__2, a, &c__2, b, &c__1, q, &c__1, z__, &
+ c__2, &c__0, &m, w, rw, &info);
+ chkxer_("CTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ctgevc_("L", "A", sel, &c__2, a, &c__2, b, &c__2, q, &c__1, z__, &
+ c__1, &c__0, &m, w, rw, &info);
+ chkxer_("CTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ ctgevc_("R", "A", sel, &c__2, a, &c__2, b, &c__2, q, &c__1, z__, &
+ c__1, &c__0, &m, w, rw, &info);
+ chkxer_("CTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ ctgevc_("R", "A", sel, &c__2, a, &c__2, b, &c__2, q, &c__1, z__, &
+ c__2, &c__1, &m, w, rw, &info);
+ chkxer_("CTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Test error exits for the GSV path. */
+
+ } else if (lsamen_(&c__3, path, "GSV")) {
+
+/* CGGSVD */
+
+ s_copy(srnamc_1.srnamt, "CGGSVD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cggsvd_("/", "N", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, rw,
+ iw, &info);
+ chkxer_("CGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cggsvd_("N", "/", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, rw,
+ iw, &info);
+ chkxer_("CGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cggsvd_("N", "N", "/", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, rw,
+ iw, &info);
+ chkxer_("CGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cggsvd_("N", "N", "N", &c_n1, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, rw,
+ iw, &info);
+ chkxer_("CGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cggsvd_("N", "N", "N", &c__0, &c_n1, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, rw,
+ iw, &info);
+ chkxer_("CGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cggsvd_("N", "N", "N", &c__0, &c__0, &c_n1, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, rw,
+ iw, &info);
+ chkxer_("CGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cggsvd_("N", "N", "N", &c__2, &c__1, &c__1, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, rw,
+ iw, &info);
+ chkxer_("CGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cggsvd_("N", "N", "N", &c__1, &c__1, &c__2, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, rw,
+ iw, &info);
+ chkxer_("CGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ cggsvd_("U", "N", "N", &c__2, &c__2, &c__2, &dummyk, &dummyl, a, &
+ c__2, b, &c__2, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, rw,
+ iw, &info);
+ chkxer_("CGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ cggsvd_("N", "V", "N", &c__2, &c__2, &c__2, &dummyk, &dummyl, a, &
+ c__2, b, &c__2, r1, r2, u, &c__2, v, &c__1, q, &c__1, w, rw,
+ iw, &info);
+ chkxer_("CGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ cggsvd_("N", "N", "Q", &c__2, &c__2, &c__2, &dummyk, &dummyl, a, &
+ c__2, b, &c__2, r1, r2, u, &c__2, v, &c__2, q, &c__1, w, rw,
+ iw, &info);
+ chkxer_("CGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* CGGSVP */
+
+ s_copy(srnamc_1.srnamt, "CGGSVP", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cggsvp_("/", "N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ rw, tau, w, &info);
+ chkxer_("CGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cggsvp_("N", "/", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ rw, tau, w, &info);
+ chkxer_("CGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cggsvp_("N", "N", "/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ rw, tau, w, &info);
+ chkxer_("CGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cggsvp_("N", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ rw, tau, w, &info);
+ chkxer_("CGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cggsvp_("N", "N", "N", &c__0, &c_n1, &c__0, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ rw, tau, w, &info);
+ chkxer_("CGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cggsvp_("N", "N", "N", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ rw, tau, w, &info);
+ chkxer_("CGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cggsvp_("N", "N", "N", &c__2, &c__1, &c__1, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ rw, tau, w, &info);
+ chkxer_("CGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cggsvp_("N", "N", "N", &c__1, &c__2, &c__1, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ rw, tau, w, &info);
+ chkxer_("CGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ cggsvp_("U", "N", "N", &c__2, &c__2, &c__2, a, &c__2, b, &c__2, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ rw, tau, w, &info);
+ chkxer_("CGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ cggsvp_("N", "V", "N", &c__2, &c__2, &c__2, a, &c__2, b, &c__2, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__2, v, &c__1, q, &c__1, iw,
+ rw, tau, w, &info);
+ chkxer_("CGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ cggsvp_("N", "N", "Q", &c__2, &c__2, &c__2, a, &c__2, b, &c__2, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__2, v, &c__2, q, &c__1, iw,
+ rw, tau, w, &info);
+ chkxer_("CGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* CTGSJA */
+
+ s_copy(srnamc_1.srnamt, "CTGSJA", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctgsja_("/", "N", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("CTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctgsja_("N", "/", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("CTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ctgsja_("N", "N", "/", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("CTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ctgsja_("N", "N", "N", &c_n1, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("CTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ctgsja_("N", "N", "N", &c__0, &c_n1, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("CTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ctgsja_("N", "N", "N", &c__0, &c__0, &c_n1, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("CTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ctgsja_("N", "N", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__0, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("CTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ ctgsja_("N", "N", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__0, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("CTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ ctgsja_("U", "N", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__0, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("CTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ ctgsja_("N", "V", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__0, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("CTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 22;
+ ctgsja_("N", "N", "Q", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__0, w, &ncycle, &info);
+ chkxer_("CTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* Test error exits for the GLM path. */
+
+ } else if (lsamen_(&c__3, path, "GLM")) {
+
+/* CGGGLM */
+
+ s_copy(srnamc_1.srnamt, "CGGGLM", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cggglm_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("CGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cggglm_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("CGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cggglm_(&c__0, &c__1, &c__0, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("CGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cggglm_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("CGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cggglm_(&c__1, &c__0, &c__0, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("CGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cggglm_(&c__0, &c__0, &c__0, a, &c__0, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("CGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cggglm_(&c__0, &c__0, &c__0, a, &c__1, b, &c__0, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("CGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cggglm_(&c__1, &c__1, &c__1, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__1, &info);
+ chkxer_("CGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Test error exits for the LSE path. */
+
+ } else if (lsamen_(&c__3, path, "LSE")) {
+
+/* CGGLSE */
+
+ s_copy(srnamc_1.srnamt, "CGGLSE", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgglse_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("CGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgglse_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("CGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgglse_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("CGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgglse_(&c__0, &c__0, &c__1, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("CGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgglse_(&c__0, &c__1, &c__0, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("CGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgglse_(&c__0, &c__0, &c__0, a, &c__0, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("CGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cgglse_(&c__0, &c__0, &c__0, a, &c__1, b, &c__0, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("CGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cgglse_(&c__1, &c__1, &c__1, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__1, &info);
+ chkxer_("CGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Test error exits for the GQR path. */
+
+ } else if (lsamen_(&c__3, path, "GQR")) {
+
+/* CGGQRF */
+
+ s_copy(srnamc_1.srnamt, "CGGQRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cggqrf_(&c_n1, &c__0, &c__0, a, &c__1, alpha, b, &c__1, beta, w, &
+ c__18, &info);
+ chkxer_("CGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cggqrf_(&c__0, &c_n1, &c__0, a, &c__1, alpha, b, &c__1, beta, w, &
+ c__18, &info);
+ chkxer_("CGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cggqrf_(&c__0, &c__0, &c_n1, a, &c__1, alpha, b, &c__1, beta, w, &
+ c__18, &info);
+ chkxer_("CGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cggqrf_(&c__0, &c__0, &c__0, a, &c__0, alpha, b, &c__1, beta, w, &
+ c__18, &info);
+ chkxer_("CGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cggqrf_(&c__0, &c__0, &c__0, a, &c__1, alpha, b, &c__0, beta, w, &
+ c__18, &info);
+ chkxer_("CGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ cggqrf_(&c__1, &c__1, &c__2, a, &c__1, alpha, b, &c__1, beta, w, &
+ c__1, &info);
+ chkxer_("CGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+/* CGGRQF */
+
+ s_copy(srnamc_1.srnamt, "CGGRQF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cggrqf_(&c_n1, &c__0, &c__0, a, &c__1, alpha, b, &c__1, beta, w, &
+ c__18, &info);
+ chkxer_("CGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cggrqf_(&c__0, &c_n1, &c__0, a, &c__1, alpha, b, &c__1, beta, w, &
+ c__18, &info);
+ chkxer_("CGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cggrqf_(&c__0, &c__0, &c_n1, a, &c__1, alpha, b, &c__1, beta, w, &
+ c__18, &info);
+ chkxer_("CGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cggrqf_(&c__0, &c__0, &c__0, a, &c__0, alpha, b, &c__1, beta, w, &
+ c__18, &info);
+ chkxer_("CGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cggrqf_(&c__0, &c__0, &c__0, a, &c__1, alpha, b, &c__0, beta, w, &
+ c__18, &info);
+ chkxer_("CGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ cggrqf_(&c__1, &c__1, &c__2, a, &c__1, alpha, b, &c__1, beta, w, &
+ c__1, &info);
+ chkxer_("CGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+/* Test error exits for the CGS, CGV, CGX, and CXV paths. */
+
+ } else if (lsamen_(&c__3, path, "CGS") || lsamen_(&
+ c__3, path, "CGV") || lsamen_(&c__3, path,
+ "CGX") || lsamen_(&c__3, path, "CXV")) {
+
+/* CGGES */
+
+ s_copy(srnamc_1.srnamt, "CGGES ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgges_("/", "N", "S", (L_fp)clctes_, &c__1, a, &c__1, b, &c__1, &sdim,
+ alpha, beta, q, &c__1, u, &c__1, w, &c__1, rw, bw, &info);
+ chkxer_("CGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgges_("N", "/", "S", (L_fp)clctes_, &c__1, a, &c__1, b, &c__1, &sdim,
+ alpha, beta, q, &c__1, u, &c__1, w, &c__1, rw, bw, &info);
+ chkxer_("CGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgges_("N", "V", "/", (L_fp)clctes_, &c__1, a, &c__1, b, &c__1, &sdim,
+ alpha, beta, q, &c__1, u, &c__1, w, &c__1, rw, bw, &info);
+ chkxer_("CGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgges_("N", "V", "S", (L_fp)clctes_, &c_n1, a, &c__1, b, &c__1, &sdim,
+ alpha, beta, q, &c__1, u, &c__1, w, &c__1, rw, bw, &info);
+ chkxer_("CGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cgges_("N", "V", "S", (L_fp)clctes_, &c__1, a, &c__0, b, &c__1, &sdim,
+ alpha, beta, q, &c__1, u, &c__1, w, &c__1, rw, bw, &info);
+ chkxer_("CGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ cgges_("N", "V", "S", (L_fp)clctes_, &c__1, a, &c__1, b, &c__0, &sdim,
+ alpha, beta, q, &c__1, u, &c__1, w, &c__1, rw, bw, &info);
+ chkxer_("CGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ cgges_("N", "V", "S", (L_fp)clctes_, &c__1, a, &c__1, b, &c__1, &sdim,
+ alpha, beta, q, &c__0, u, &c__1, w, &c__1, rw, bw, &info);
+ chkxer_("CGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ cgges_("V", "V", "S", (L_fp)clctes_, &c__2, a, &c__2, b, &c__2, &sdim,
+ alpha, beta, q, &c__1, u, &c__2, w, &c__1, rw, bw, &info);
+ chkxer_("CGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ cgges_("N", "V", "S", (L_fp)clctes_, &c__1, a, &c__1, b, &c__1, &sdim,
+ alpha, beta, q, &c__1, u, &c__0, w, &c__1, rw, bw, &info);
+ chkxer_("CGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ cgges_("V", "V", "S", (L_fp)clctes_, &c__2, a, &c__2, b, &c__2, &sdim,
+ alpha, beta, q, &c__2, u, &c__1, w, &c__1, rw, bw, &info);
+ chkxer_("CGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ cgges_("V", "V", "S", (L_fp)clctes_, &c__2, a, &c__2, b, &c__2, &sdim,
+ alpha, beta, q, &c__2, u, &c__2, w, &c__1, rw, bw, &info);
+ chkxer_("CGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* CGGESX */
+
+ s_copy(srnamc_1.srnamt, "CGGESX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cggesx_("/", "N", "S", (L_fp)clctsx_, "N", &c__1, a, &c__1, b, &c__1,
+ &sdim, alpha, beta, q, &c__1, u, &c__1, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("CGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cggesx_("N", "/", "S", (L_fp)clctsx_, "N", &c__1, a, &c__1, b, &c__1,
+ &sdim, alpha, beta, q, &c__1, u, &c__1, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("CGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cggesx_("V", "V", "/", (L_fp)clctsx_, "N", &c__1, a, &c__1, b, &c__1,
+ &sdim, alpha, beta, q, &c__1, u, &c__1, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("CGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cggesx_("V", "V", "S", (L_fp)clctsx_, "/", &c__1, a, &c__1, b, &c__1,
+ &sdim, alpha, beta, q, &c__1, u, &c__1, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("CGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cggesx_("V", "V", "S", (L_fp)clctsx_, "B", &c_n1, a, &c__1, b, &c__1,
+ &sdim, alpha, beta, q, &c__1, u, &c__1, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("CGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cggesx_("V", "V", "S", (L_fp)clctsx_, "B", &c__1, a, &c__0, b, &c__1,
+ &sdim, alpha, beta, q, &c__1, u, &c__1, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("CGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cggesx_("V", "V", "S", (L_fp)clctsx_, "B", &c__1, a, &c__1, b, &c__0,
+ &sdim, alpha, beta, q, &c__1, u, &c__1, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("CGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ cggesx_("V", "V", "S", (L_fp)clctsx_, "B", &c__1, a, &c__1, b, &c__1,
+ &sdim, alpha, beta, q, &c__0, u, &c__1, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("CGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ cggesx_("V", "V", "S", (L_fp)clctsx_, "B", &c__2, a, &c__2, b, &c__2,
+ &sdim, alpha, beta, q, &c__1, u, &c__1, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("CGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 17;
+ cggesx_("V", "V", "S", (L_fp)clctsx_, "B", &c__1, a, &c__1, b, &c__1,
+ &sdim, alpha, beta, q, &c__1, u, &c__0, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("CGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 17;
+ cggesx_("V", "V", "S", (L_fp)clctsx_, "B", &c__2, a, &c__2, b, &c__2,
+ &sdim, alpha, beta, q, &c__2, u, &c__1, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("CGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 21;
+ cggesx_("V", "V", "S", (L_fp)clctsx_, "B", &c__2, a, &c__2, b, &c__2,
+ &sdim, alpha, beta, q, &c__2, u, &c__2, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("CGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 24;
+ cggesx_("V", "V", "S", (L_fp)clctsx_, "V", &c__1, a, &c__1, b, &c__1,
+ &sdim, alpha, beta, q, &c__1, u, &c__1, rce, rcv, w, &c__32,
+ rw, iw, &c__0, bw, &info);
+ chkxer_("CGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 13;
+
+/* CGGEV */
+
+ s_copy(srnamc_1.srnamt, "CGGEV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cggev_("/", "N", &c__1, a, &c__1, b, &c__1, alpha, beta, q, &c__1, u,
+ &c__1, w, &c__1, rw, &info);
+ chkxer_("CGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cggev_("N", "/", &c__1, a, &c__1, b, &c__1, alpha, beta, q, &c__1, u,
+ &c__1, w, &c__1, rw, &info);
+ chkxer_("CGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cggev_("V", "V", &c_n1, a, &c__1, b, &c__1, alpha, beta, q, &c__1, u,
+ &c__1, w, &c__1, rw, &info);
+ chkxer_("CGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cggev_("V", "V", &c__1, a, &c__0, b, &c__1, alpha, beta, q, &c__1, u,
+ &c__1, w, &c__1, rw, &info);
+ chkxer_("CGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cggev_("V", "V", &c__1, a, &c__1, b, &c__0, alpha, beta, q, &c__1, u,
+ &c__1, w, &c__1, rw, &info);
+ chkxer_("CGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ cggev_("N", "V", &c__1, a, &c__1, b, &c__1, alpha, beta, q, &c__0, u,
+ &c__1, w, &c__1, rw, &info);
+ chkxer_("CGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ cggev_("V", "V", &c__2, a, &c__2, b, &c__2, alpha, beta, q, &c__1, u,
+ &c__2, w, &c__1, rw, &info);
+ chkxer_("CGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ cggev_("V", "N", &c__2, a, &c__2, b, &c__2, alpha, beta, q, &c__2, u,
+ &c__0, w, &c__1, rw, &info);
+ chkxer_("CGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ cggev_("V", "V", &c__2, a, &c__2, b, &c__2, alpha, beta, q, &c__2, u,
+ &c__1, w, &c__1, rw, &info);
+ chkxer_("CGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ cggev_("V", "V", &c__1, a, &c__1, b, &c__1, alpha, beta, q, &c__1, u,
+ &c__1, w, &c__1, rw, &info);
+ chkxer_("CGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* CGGEVX */
+
+ s_copy(srnamc_1.srnamt, "CGGEVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cggevx_("/", "N", "N", "N", &c__1, a, &c__1, b, &c__1, alpha, beta, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__1, rw, iw, bw, &info);
+ chkxer_("CGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cggevx_("N", "/", "N", "N", &c__1, a, &c__1, b, &c__1, alpha, beta, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__1, rw, iw, bw, &info);
+ chkxer_("CGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cggevx_("N", "N", "/", "N", &c__1, a, &c__1, b, &c__1, alpha, beta, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__1, rw, iw, bw, &info);
+ chkxer_("CGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cggevx_("N", "N", "N", "/", &c__1, a, &c__1, b, &c__1, alpha, beta, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__1, rw, iw, bw, &info);
+ chkxer_("CGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cggevx_("N", "N", "N", "N", &c_n1, a, &c__1, b, &c__1, alpha, beta, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__1, rw, iw, bw, &info);
+ chkxer_("CGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cggevx_("N", "N", "N", "N", &c__1, a, &c__0, b, &c__1, alpha, beta, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__1, rw, iw, bw, &info);
+ chkxer_("CGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ cggevx_("N", "N", "N", "N", &c__1, a, &c__1, b, &c__0, alpha, beta, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__1, rw, iw, bw, &info);
+ chkxer_("CGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ cggevx_("N", "N", "N", "N", &c__1, a, &c__1, b, &c__1, alpha, beta, q,
+ &c__0, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__1, rw, iw, bw, &info);
+ chkxer_("CGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ cggevx_("N", "V", "N", "N", &c__2, a, &c__2, b, &c__2, alpha, beta, q,
+ &c__1, u, &c__2, &c__1, &c__2, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__1, rw, iw, bw, &info);
+ chkxer_("CGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ cggevx_("N", "N", "N", "N", &c__1, a, &c__1, b, &c__1, alpha, beta, q,
+ &c__1, u, &c__0, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__1, rw, iw, bw, &info);
+ chkxer_("CGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ cggevx_("N", "N", "V", "N", &c__2, a, &c__2, b, &c__2, alpha, beta, q,
+ &c__2, u, &c__1, &c__1, &c__2, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__1, rw, iw, bw, &info);
+ chkxer_("CGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 25;
+ cggevx_("N", "N", "V", "N", &c__2, a, &c__2, b, &c__2, alpha, beta, q,
+ &c__2, u, &c__2, &c__1, &c__2, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__0, rw, iw, bw, &info);
+ chkxer_("CGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 12;
+
+/* CTGEXC */
+
+ s_copy(srnamc_1.srnamt, "CTGEXC", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 3;
+ ctgexc_(&c_true, &c_true, &c_n1, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__1, &ifst, &ilst, &info);
+ chkxer_("CTGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ctgexc_(&c_true, &c_true, &c__1, a, &c__0, b, &c__1, q, &c__1, z__, &
+ c__1, &ifst, &ilst, &info);
+ chkxer_("CTGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ctgexc_(&c_true, &c_true, &c__1, a, &c__1, b, &c__0, q, &c__1, z__, &
+ c__1, &ifst, &ilst, &info);
+ chkxer_("CTGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ ctgexc_(&c_false, &c_true, &c__1, a, &c__1, b, &c__1, q, &c__0, z__, &
+ c__1, &ifst, &ilst, &info);
+ chkxer_("CTGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ ctgexc_(&c_true, &c_true, &c__1, a, &c__1, b, &c__1, q, &c__0, z__, &
+ c__1, &ifst, &ilst, &info);
+ chkxer_("CTGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ ctgexc_(&c_true, &c_false, &c__1, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__0, &ifst, &ilst, &info);
+ chkxer_("CTGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ ctgexc_(&c_true, &c_true, &c__1, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__0, &ifst, &ilst, &info);
+ chkxer_("CTGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+
+/* CTGSEN */
+
+ s_copy(srnamc_1.srnamt, "CTGSEN", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctgsen_(&c_n1, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1,
+ alpha, beta, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c__1, iw, &c__1, &info);
+ chkxer_("CTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ctgsen_(&c__1, &c_true, &c_true, sel, &c_n1, a, &c__1, b, &c__1,
+ alpha, beta, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c__1, iw, &c__1, &info);
+ chkxer_("CTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ctgsen_(&c__1, &c_true, &c_true, sel, &c__1, a, &c__0, b, &c__1,
+ alpha, beta, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c__1, iw, &c__1, &info);
+ chkxer_("CTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ ctgsen_(&c__1, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__0,
+ alpha, beta, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c__1, iw, &c__1, &info);
+ chkxer_("CTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ ctgsen_(&c__1, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1,
+ alpha, beta, q, &c__0, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c__1, iw, &c__1, &info);
+ chkxer_("CTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ ctgsen_(&c__1, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1,
+ alpha, beta, q, &c__1, z__, &c__0, &m, &tola, &tolb, rcv, w, &
+ c__1, iw, &c__1, &info);
+ chkxer_("CTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 21;
+ ctgsen_(&c__3, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1,
+ alpha, beta, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c_n5, iw, &c__1, &info);
+ chkxer_("CTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 23;
+ ctgsen_(&c__0, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1,
+ alpha, beta, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c__20, iw, &c__0, &info);
+ chkxer_("CTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 23;
+ ctgsen_(&c__1, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1,
+ alpha, beta, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c__20, iw, &c__0, &info);
+ chkxer_("CTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 23;
+ ctgsen_(&c__5, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1,
+ alpha, beta, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c__20, iw, &c__1, &info);
+ chkxer_("CTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* CTGSNA */
+
+ s_copy(srnamc_1.srnamt, "CTGSNA", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctgsna_("/", "A", sel, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("CTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctgsna_("B", "/", sel, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("CTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ctgsna_("B", "A", sel, &c_n1, a, &c__1, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("CTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ctgsna_("B", "A", sel, &c__1, a, &c__0, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("CTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ctgsna_("B", "A", sel, &c__1, a, &c__1, b, &c__0, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("CTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ctgsna_("E", "A", sel, &c__1, a, &c__1, b, &c__1, q, &c__0, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("CTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ ctgsna_("E", "A", sel, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &c__0,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("CTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ ctgsna_("E", "A", sel, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__0, &m, w, &c__1, iw, &info);
+ chkxer_("CTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ ctgsna_("E", "A", sel, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__0, iw, &info);
+ chkxer_("CTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* CTGSYL */
+
+ s_copy(srnamc_1.srnamt, "CTGSYL", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctgsyl_("/", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("CTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctgsyl_("N", &c_n1, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("CTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ctgsyl_("N", &c__0, &c__0, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("CTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ctgsyl_("N", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("CTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ctgsyl_("N", &c__0, &c__1, &c__1, a, &c__0, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("CTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ctgsyl_("N", &c__0, &c__1, &c__1, a, &c__1, b, &c__0, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("CTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ctgsyl_("N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__0, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("CTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ ctgsyl_("N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__0, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("CTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ ctgsyl_("N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__0, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("CTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ ctgsyl_("N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__0, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("CTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ ctgsyl_("N", &c__1, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("CTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ ctgsyl_("N", &c__2, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("CTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 12;
+ }
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___40.ciunit = infoc_1.nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___41.ciunit = infoc_1.nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of CERRGG */
+
+} /* cerrgg_ */
diff --git a/TESTING/EIG/cerrhs.c b/TESTING/EIG/cerrhs.c
new file mode 100644
index 0000000..5482561
--- /dev/null
+++ b/TESTING/EIG/cerrhs.c
@@ -0,0 +1,531 @@
+/* cerrhs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__4 = 4;
+
+/* Subroutine */ int cerrhs_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
+ "rror exits\002,\002 (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
+ "ts of the error \002,\002exits ***\002)";
+
+ /* System generated locals */
+ integer i__1;
+ real r__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ complex a[9] /* was [3][3] */, c__[9] /* was [3][3] */;
+ integer i__, j, m;
+ real s[3];
+ complex w[9], x[3];
+ char c2[2];
+ integer nt;
+ complex vl[9] /* was [3][3] */, vr[9] /* was [3][3] */;
+ real rw[3];
+ integer ihi, ilo;
+ logical sel[3];
+ complex tau[3];
+ integer info;
+ extern /* Subroutine */ int cgebak_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, complex *, integer *, integer *), cgebal_(char *, integer *, complex *, integer *,
+ integer *, integer *, real *, integer *), cgehrd_(integer
+ *, integer *, integer *, complex *, integer *, complex *, complex
+ *, integer *, integer *);
+ integer ifaill[3], ifailr[3];
+ extern /* Subroutine */ int chsein_(char *, char *, char *, logical *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *, integer *, complex *, real *,
+ integer *, integer *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), chseqr_(char *, char *, integer *, integer
+ *, integer *, complex *, integer *, complex *, complex *, integer
+ *, complex *, integer *, integer *), cunghr_(
+ integer *, integer *, integer *, complex *, integer *, complex *,
+ complex *, integer *, integer *), ctrevc_(char *, char *, logical
+ *, integer *, complex *, integer *, complex *, integer *, complex
+ *, integer *, integer *, integer *, complex *, real *, integer *), cunmhr_(char *, char *, integer *, integer *,
+ integer *, integer *, complex *, integer *, complex *, complex *,
+ integer *, complex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERRHS tests the error exits for CGEBAK, CGEBAL, CGEHRD, CUNGHR, */
+/* CUNMHR, CHSEQR, CHSEIN, and CTREVC. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 3; ++j) {
+ for (i__ = 1; i__ <= 3; ++i__) {
+ i__1 = i__ + j * 3 - 4;
+ r__1 = 1.f / (real) (i__ + j);
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+/* L10: */
+ }
+ sel[j - 1] = TRUE_;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+ nt = 0;
+
+/* Test error exits of the nonsymmetric eigenvalue routines. */
+
+ if (lsamen_(&c__2, c2, "HS")) {
+
+/* CGEBAL */
+
+ s_copy(srnamc_1.srnamt, "CGEBAL", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgebal_("/", &c__0, a, &c__1, &ilo, &ihi, s, &info);
+ chkxer_("CGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgebal_("N", &c_n1, a, &c__1, &ilo, &ihi, s, &info);
+ chkxer_("CGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgebal_("N", &c__2, a, &c__1, &ilo, &ihi, s, &info);
+ chkxer_("CGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 3;
+
+/* CGEBAK */
+
+ s_copy(srnamc_1.srnamt, "CGEBAK", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgebak_("/", "R", &c__0, &c__1, &c__0, s, &c__0, a, &c__1, &info);
+ chkxer_("CGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgebak_("N", "/", &c__0, &c__1, &c__0, s, &c__0, a, &c__1, &info);
+ chkxer_("CGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgebak_("N", "R", &c_n1, &c__1, &c__0, s, &c__0, a, &c__1, &info);
+ chkxer_("CGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgebak_("N", "R", &c__0, &c__0, &c__0, s, &c__0, a, &c__1, &info);
+ chkxer_("CGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgebak_("N", "R", &c__0, &c__2, &c__0, s, &c__0, a, &c__1, &info);
+ chkxer_("CGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgebak_("N", "R", &c__2, &c__2, &c__1, s, &c__0, a, &c__2, &info);
+ chkxer_("CGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgebak_("N", "R", &c__0, &c__1, &c__1, s, &c__0, a, &c__1, &info);
+ chkxer_("CGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cgebak_("N", "R", &c__0, &c__1, &c__0, s, &c_n1, a, &c__1, &info);
+ chkxer_("CGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ cgebak_("N", "R", &c__2, &c__1, &c__2, s, &c__0, a, &c__1, &info);
+ chkxer_("CGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* CGEHRD */
+
+ s_copy(srnamc_1.srnamt, "CGEHRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgehrd_(&c_n1, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("CGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgehrd_(&c__0, &c__0, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("CGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgehrd_(&c__0, &c__2, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("CGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgehrd_(&c__1, &c__1, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("CGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgehrd_(&c__0, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("CGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgehrd_(&c__2, &c__1, &c__1, a, &c__1, tau, w, &c__2, &info);
+ chkxer_("CGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cgehrd_(&c__2, &c__1, &c__2, a, &c__2, tau, w, &c__1, &info);
+ chkxer_("CGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+
+/* CUNGHR */
+
+ s_copy(srnamc_1.srnamt, "CUNGHR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cunghr_(&c_n1, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("CUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cunghr_(&c__0, &c__0, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("CUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cunghr_(&c__0, &c__2, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("CUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cunghr_(&c__1, &c__1, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("CUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cunghr_(&c__0, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("CUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunghr_(&c__2, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("CUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cunghr_(&c__3, &c__1, &c__3, a, &c__3, tau, w, &c__1, &info);
+ chkxer_("CUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+
+/* CUNMHR */
+
+ s_copy(srnamc_1.srnamt, "CUNMHR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cunmhr_("/", "N", &c__0, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("CUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cunmhr_("L", "/", &c__0, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("CUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cunmhr_("L", "N", &c_n1, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("CUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cunmhr_("L", "N", &c__0, &c_n1, &c__1, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("CUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunmhr_("L", "N", &c__0, &c__0, &c__0, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("CUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunmhr_("L", "N", &c__0, &c__0, &c__2, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("CUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunmhr_("L", "N", &c__1, &c__2, &c__2, &c__1, a, &c__1, tau, c__, &
+ c__1, w, &c__2, &info);
+ chkxer_("CUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunmhr_("R", "N", &c__2, &c__1, &c__2, &c__1, a, &c__1, tau, c__, &
+ c__2, w, &c__2, &info);
+ chkxer_("CUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cunmhr_("L", "N", &c__1, &c__1, &c__1, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("CUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cunmhr_("L", "N", &c__0, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("CUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cunmhr_("R", "N", &c__1, &c__0, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("CUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cunmhr_("L", "N", &c__2, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__2, w, &c__1, &info);
+ chkxer_("CUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cunmhr_("R", "N", &c__1, &c__2, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("CUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ cunmhr_("L", "N", &c__2, &c__1, &c__1, &c__1, a, &c__2, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("CUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ cunmhr_("L", "N", &c__1, &c__2, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("CUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ cunmhr_("R", "N", &c__2, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__2, w, &c__1, &info);
+ chkxer_("CUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 16;
+
+/* CHSEQR */
+
+ s_copy(srnamc_1.srnamt, "CHSEQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chseqr_("/", "N", &c__0, &c__1, &c__0, a, &c__1, x, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("CHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chseqr_("E", "/", &c__0, &c__1, &c__0, a, &c__1, x, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("CHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ chseqr_("E", "N", &c_n1, &c__1, &c__0, a, &c__1, x, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("CHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ chseqr_("E", "N", &c__0, &c__0, &c__0, a, &c__1, x, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("CHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ chseqr_("E", "N", &c__0, &c__2, &c__0, a, &c__1, x, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("CHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ chseqr_("E", "N", &c__1, &c__1, &c__0, a, &c__1, x, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("CHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ chseqr_("E", "N", &c__1, &c__1, &c__2, a, &c__1, x, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("CHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ chseqr_("E", "N", &c__2, &c__1, &c__2, a, &c__1, x, c__, &c__2, w, &
+ c__1, &info);
+ chkxer_("CHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ chseqr_("E", "V", &c__2, &c__1, &c__2, a, &c__2, x, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("CHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* CHSEIN */
+
+ s_copy(srnamc_1.srnamt, "CHSEIN", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chsein_("/", "N", "N", sel, &c__0, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &c__0, &m, w, rw, ifaill, ifailr, &info);
+ chkxer_("CHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chsein_("R", "/", "N", sel, &c__0, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &c__0, &m, w, rw, ifaill, ifailr, &info);
+ chkxer_("CHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ chsein_("R", "N", "/", sel, &c__0, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &c__0, &m, w, rw, ifaill, ifailr, &info);
+ chkxer_("CHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ chsein_("R", "N", "N", sel, &c_n1, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &c__0, &m, w, rw, ifaill, ifailr, &info);
+ chkxer_("CHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ chsein_("R", "N", "N", sel, &c__2, a, &c__1, x, vl, &c__1, vr, &c__2,
+ &c__4, &m, w, rw, ifaill, ifailr, &info);
+ chkxer_("CHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ chsein_("L", "N", "N", sel, &c__2, a, &c__2, x, vl, &c__1, vr, &c__1,
+ &c__4, &m, w, rw, ifaill, ifailr, &info);
+ chkxer_("CHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ chsein_("R", "N", "N", sel, &c__2, a, &c__2, x, vl, &c__1, vr, &c__1,
+ &c__4, &m, w, rw, ifaill, ifailr, &info);
+ chkxer_("CHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ chsein_("R", "N", "N", sel, &c__2, a, &c__2, x, vl, &c__1, vr, &c__2,
+ &c__1, &m, w, rw, ifaill, ifailr, &info);
+ chkxer_("CHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* CTREVC */
+
+ s_copy(srnamc_1.srnamt, "CTREVC", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctrevc_("/", "A", sel, &c__0, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
+ m, w, rw, &info);
+ chkxer_("CTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctrevc_("L", "/", sel, &c__0, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
+ m, w, rw, &info);
+ chkxer_("CTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ctrevc_("L", "A", sel, &c_n1, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
+ m, w, rw, &info);
+ chkxer_("CTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrevc_("L", "A", sel, &c__2, a, &c__1, vl, &c__2, vr, &c__1, &c__4, &
+ m, w, rw, &info);
+ chkxer_("CTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ctrevc_("L", "A", sel, &c__2, a, &c__2, vl, &c__1, vr, &c__1, &c__4, &
+ m, w, rw, &info);
+ chkxer_("CTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ctrevc_("R", "A", sel, &c__2, a, &c__2, vl, &c__1, vr, &c__1, &c__4, &
+ m, w, rw, &info);
+ chkxer_("CTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrevc_("L", "A", sel, &c__2, a, &c__2, vl, &c__2, vr, &c__1, &c__1, &
+ m, w, rw, &info);
+ chkxer_("CTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+ }
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___22.ciunit = infoc_1.nout;
+ s_wsfe(&io___22);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___23.ciunit = infoc_1.nout;
+ s_wsfe(&io___23);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of CERRHS */
+
+} /* cerrhs_ */
diff --git a/TESTING/EIG/cerrst.c b/TESTING/EIG/cerrst.c
new file mode 100644
index 0000000..ced37a8
--- /dev/null
+++ b/TESTING/EIG/cerrst.c
@@ -0,0 +1,1124 @@
+/* cerrst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static integer c__23 = 23;
+static integer c__28 = 28;
+static integer c__12 = 12;
+static integer c__25 = 25;
+static integer c__8 = 8;
+static integer c__18 = 18;
+static integer c__11 = 11;
+static real c_b458 = 0.f;
+static real c_b472 = 1.f;
+
+/* Subroutine */ int cerrst_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
+ "rror exits\002,\002 (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
+ "ts of the error \002,\002exits ***\002)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real r__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ complex a[9] /* was [3][3] */, c__[9] /* was [3][3] */;
+ real d__[3], e[3];
+ integer i__, j, m, n;
+ complex q[9] /* was [3][3] */;
+ real r__[60];
+ complex w[60];
+ real x[3];
+ complex z__[9] /* was [3][3] */;
+ char c2[2];
+ integer i1[3], i2[3], i3[3], iw[36], nt;
+ real rw[60];
+ complex tau[3];
+ integer info;
+ extern /* Subroutine */ int chbev_(char *, char *, integer *, integer *,
+ complex *, integer *, real *, complex *, integer *, complex *,
+ real *, integer *), cheev_(char *, char *,
+ integer *, complex *, integer *, real *, complex *, integer *,
+ real *, integer *), chpev_(char *, char *,
+ integer *, complex *, real *, complex *, integer *, complex *,
+ real *, integer *), chbevd_(char *, char *,
+ integer *, integer *, complex *, integer *, real *, complex *,
+ integer *, complex *, integer *, real *, integer *, integer *,
+ integer *, integer *), cheevd_(char *, char *,
+ integer *, complex *, integer *, real *, complex *, integer *,
+ real *, integer *, integer *, integer *, integer *), cstedc_(char *, integer *, real *, real *, complex *,
+ integer *, complex *, integer *, real *, integer *, integer *,
+ integer *, integer *), chbtrd_(char *, char *, integer *,
+ integer *, complex *, integer *, real *, real *, complex *,
+ integer *, complex *, integer *), chetrd_(char *,
+ integer *, complex *, integer *, real *, real *, complex *,
+ complex *, integer *, integer *), chpevd_(char *, char *,
+ integer *, complex *, real *, complex *, integer *, complex *,
+ integer *, real *, integer *, integer *, integer *, integer *), cheevr_(char *, char *, char *, integer *,
+ complex *, integer *, real *, real *, integer *, integer *, real *
+, integer *, real *, complex *, integer *, integer *, complex *,
+ integer *, real *, integer *, integer *, integer *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chbevx_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, real *, complex *
+, integer *, complex *, real *, integer *, integer *, integer *), cheevx_(char *, char *, char *, integer *
+, complex *, integer *, real *, real *, integer *, integer *,
+ real *, integer *, real *, complex *, integer *, complex *,
+ integer *, real *, integer *, integer *, integer *), chkxer_(char *, integer *, integer *, logical *,
+ logical *), chptrd_(char *, integer *, complex *, real *,
+ real *, complex *, integer *), cstein_(integer *, real *,
+ real *, integer *, real *, integer *, integer *, complex *,
+ integer *, real *, integer *, integer *, integer *), chpevx_(char
+ *, char *, char *, integer *, complex *, real *, real *, integer *
+, integer *, real *, integer *, real *, complex *, integer *,
+ complex *, real *, integer *, integer *, integer *), cpteqr_(char *, integer *, real *, real *,
+ complex *, integer *, real *, integer *), csteqr_(char *,
+ integer *, real *, real *, complex *, integer *, real *, integer *
+), cungtr_(char *, integer *, complex *, integer *,
+ complex *, complex *, integer *, integer *), cupgtr_(char
+ *, integer *, complex *, complex *, complex *, integer *, complex
+ *, integer *), cunmtr_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *), cupmtr_(
+ char *, char *, char *, integer *, integer *, complex *, complex *
+, complex *, integer *, complex *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERRST tests the error exits for CHETRD, CUNGTR, CUNMTR, CHPTRD, */
+/* CUNGTR, CUPMTR, CSTEQR, CSTEIN, CPTEQR, CHBTRD, */
+/* CHEEV, CHEEVX, CHEEVD, CHBEV, CHBEVX, CHBEVD, */
+/* CHPEV, CHPEVX, CHPEVD, and CSTEDC. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 3; ++j) {
+ for (i__ = 1; i__ <= 3; ++i__) {
+ i__1 = i__ + j * 3 - 4;
+ r__1 = 1.f / (real) (i__ + j);
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ for (j = 1; j <= 3; ++j) {
+ d__[j - 1] = (real) j;
+ e[j - 1] = 0.f;
+ i1[j - 1] = j;
+ i2[j - 1] = j;
+ i__1 = j - 1;
+ tau[i__1].r = 1.f, tau[i__1].i = 0.f;
+/* L30: */
+ }
+ infoc_1.ok = TRUE_;
+ nt = 0;
+
+/* Test error exits for the ST path. */
+
+ if (lsamen_(&c__2, c2, "ST")) {
+
+/* CHETRD */
+
+ s_copy(srnamc_1.srnamt, "CHETRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chetrd_("/", &c__0, a, &c__1, d__, e, tau, w, &c__1, &info)
+ ;
+ chkxer_("CHETRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chetrd_("U", &c_n1, a, &c__1, d__, e, tau, w, &c__1, &info)
+ ;
+ chkxer_("CHETRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ chetrd_("U", &c__2, a, &c__1, d__, e, tau, w, &c__1, &info)
+ ;
+ chkxer_("CHETRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ chetrd_("U", &c__0, a, &c__1, d__, e, tau, w, &c__0, &info)
+ ;
+ chkxer_("CHETRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 4;
+
+/* CUNGTR */
+
+ s_copy(srnamc_1.srnamt, "CUNGTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cungtr_("/", &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("CUNGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cungtr_("U", &c_n1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("CUNGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cungtr_("U", &c__2, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("CUNGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cungtr_("U", &c__3, a, &c__3, tau, w, &c__1, &info);
+ chkxer_("CUNGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 4;
+
+/* CUNMTR */
+
+ s_copy(srnamc_1.srnamt, "CUNMTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cunmtr_("/", "U", "N", &c__0, &c__0, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("CUNMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cunmtr_("L", "/", "N", &c__0, &c__0, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("CUNMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cunmtr_("L", "U", "/", &c__0, &c__0, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("CUNMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cunmtr_("L", "U", "N", &c_n1, &c__0, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("CUNMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunmtr_("L", "U", "N", &c__0, &c_n1, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("CUNMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cunmtr_("L", "U", "N", &c__2, &c__0, a, &c__1, tau, c__, &c__2, w, &
+ c__1, &info);
+ chkxer_("CUNMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cunmtr_("R", "U", "N", &c__0, &c__2, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("CUNMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cunmtr_("L", "U", "N", &c__2, &c__0, a, &c__2, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("CUNMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cunmtr_("L", "U", "N", &c__0, &c__2, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("CUNMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cunmtr_("R", "U", "N", &c__2, &c__0, a, &c__1, tau, c__, &c__2, w, &
+ c__1, &info);
+ chkxer_("CUNMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* CHPTRD */
+
+ s_copy(srnamc_1.srnamt, "CHPTRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chptrd_("/", &c__0, a, d__, e, tau, &info);
+ chkxer_("CHPTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chptrd_("U", &c_n1, a, d__, e, tau, &info);
+ chkxer_("CHPTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 2;
+
+/* CUPGTR */
+
+ s_copy(srnamc_1.srnamt, "CUPGTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cupgtr_("/", &c__0, a, tau, z__, &c__1, w, &info);
+ chkxer_("CUPGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cupgtr_("U", &c_n1, a, tau, z__, &c__1, w, &info);
+ chkxer_("CUPGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cupgtr_("U", &c__2, a, tau, z__, &c__1, w, &info);
+ chkxer_("CUPGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 3;
+
+/* CUPMTR */
+
+ s_copy(srnamc_1.srnamt, "CUPMTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cupmtr_("/", "U", "N", &c__0, &c__0, a, tau, c__, &c__1, w, &info);
+ chkxer_("CUPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cupmtr_("L", "/", "N", &c__0, &c__0, a, tau, c__, &c__1, w, &info);
+ chkxer_("CUPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cupmtr_("L", "U", "/", &c__0, &c__0, a, tau, c__, &c__1, w, &info);
+ chkxer_("CUPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cupmtr_("L", "U", "N", &c_n1, &c__0, a, tau, c__, &c__1, w, &info);
+ chkxer_("CUPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cupmtr_("L", "U", "N", &c__0, &c_n1, a, tau, c__, &c__1, w, &info);
+ chkxer_("CUPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ cupmtr_("L", "U", "N", &c__2, &c__0, a, tau, c__, &c__1, w, &info);
+ chkxer_("CUPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+/* CPTEQR */
+
+ s_copy(srnamc_1.srnamt, "CPTEQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpteqr_("/", &c__0, d__, e, z__, &c__1, rw, &info);
+ chkxer_("CPTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpteqr_("N", &c_n1, d__, e, z__, &c__1, rw, &info);
+ chkxer_("CPTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cpteqr_("V", &c__2, d__, e, z__, &c__1, rw, &info);
+ chkxer_("CPTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 3;
+
+/* CSTEIN */
+
+ s_copy(srnamc_1.srnamt, "CSTEIN", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cstein_(&c_n1, d__, e, &c__0, x, i1, i2, z__, &c__1, rw, iw, i3, &
+ info);
+ chkxer_("CSTEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cstein_(&c__0, d__, e, &c_n1, x, i1, i2, z__, &c__1, rw, iw, i3, &
+ info);
+ chkxer_("CSTEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cstein_(&c__0, d__, e, &c__1, x, i1, i2, z__, &c__1, rw, iw, i3, &
+ info);
+ chkxer_("CSTEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ cstein_(&c__2, d__, e, &c__0, x, i1, i2, z__, &c__1, rw, iw, i3, &
+ info);
+ chkxer_("CSTEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 4;
+
+/* CSTEQR */
+
+ s_copy(srnamc_1.srnamt, "CSTEQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ csteqr_("/", &c__0, d__, e, z__, &c__1, rw, &info);
+ chkxer_("CSTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ csteqr_("N", &c_n1, d__, e, z__, &c__1, rw, &info);
+ chkxer_("CSTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ csteqr_("V", &c__2, d__, e, z__, &c__1, rw, &info);
+ chkxer_("CSTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 3;
+
+/* CSTEDC */
+
+ s_copy(srnamc_1.srnamt, "CSTEDC", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cstedc_("/", &c__0, d__, e, z__, &c__1, w, &c__1, rw, &c__1, iw, &
+ c__1, &info);
+ chkxer_("CSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cstedc_("N", &c_n1, d__, e, z__, &c__1, w, &c__1, rw, &c__1, iw, &
+ c__1, &info);
+ chkxer_("CSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cstedc_("V", &c__2, d__, e, z__, &c__1, w, &c__4, rw, &c__23, iw, &
+ c__28, &info);
+ chkxer_("CSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cstedc_("N", &c__2, d__, e, z__, &c__1, w, &c__0, rw, &c__1, iw, &
+ c__1, &info);
+ chkxer_("CSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cstedc_("V", &c__2, d__, e, z__, &c__2, w, &c__0, rw, &c__23, iw, &
+ c__28, &info);
+ chkxer_("CSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cstedc_("N", &c__2, d__, e, z__, &c__1, w, &c__1, rw, &c__0, iw, &
+ c__1, &info);
+ chkxer_("CSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cstedc_("I", &c__2, d__, e, z__, &c__2, w, &c__1, rw, &c__1, iw, &
+ c__12, &info);
+ chkxer_("CSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cstedc_("V", &c__2, d__, e, z__, &c__2, w, &c__4, rw, &c__1, iw, &
+ c__28, &info);
+ chkxer_("CSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cstedc_("N", &c__2, d__, e, z__, &c__1, w, &c__1, rw, &c__1, iw, &
+ c__0, &info);
+ chkxer_("CSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cstedc_("I", &c__2, d__, e, z__, &c__2, w, &c__1, rw, &c__23, iw, &
+ c__0, &info);
+ chkxer_("CSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cstedc_("V", &c__2, d__, e, z__, &c__2, w, &c__4, rw, &c__23, iw, &
+ c__0, &info);
+ chkxer_("CSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* CHEEVD */
+
+ s_copy(srnamc_1.srnamt, "CHEEVD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cheevd_("/", "U", &c__0, a, &c__1, x, w, &c__1, rw, &c__1, iw, &c__1,
+ &info);
+ chkxer_("CHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cheevd_("N", "/", &c__0, a, &c__1, x, w, &c__1, rw, &c__1, iw, &c__1,
+ &info);
+ chkxer_("CHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cheevd_("N", "U", &c_n1, a, &c__1, x, w, &c__1, rw, &c__1, iw, &c__1,
+ &info);
+ chkxer_("CHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cheevd_("N", "U", &c__2, a, &c__1, x, w, &c__3, rw, &c__2, iw, &c__1,
+ &info);
+ chkxer_("CHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cheevd_("N", "U", &c__1, a, &c__1, x, w, &c__0, rw, &c__1, iw, &c__1,
+ &info);
+ chkxer_("CHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cheevd_("N", "U", &c__2, a, &c__2, x, w, &c__2, rw, &c__2, iw, &c__1,
+ &info);
+ chkxer_("CHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cheevd_("V", "U", &c__2, a, &c__2, x, w, &c__3, rw, &c__25, iw, &
+ c__12, &info);
+ chkxer_("CHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cheevd_("N", "U", &c__1, a, &c__1, x, w, &c__1, rw, &c__0, iw, &c__1,
+ &info);
+ chkxer_("CHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cheevd_("N", "U", &c__2, a, &c__2, x, w, &c__3, rw, &c__1, iw, &c__1,
+ &info);
+ chkxer_("CHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cheevd_("V", "U", &c__2, a, &c__2, x, w, &c__8, rw, &c__18, iw, &
+ c__12, &info);
+ chkxer_("CHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cheevd_("N", "U", &c__1, a, &c__1, x, w, &c__1, rw, &c__1, iw, &c__0,
+ &info);
+ chkxer_("CHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cheevd_("V", "U", &c__2, a, &c__2, x, w, &c__8, rw, &c__25, iw, &
+ c__11, &info);
+ chkxer_("CHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 12;
+
+/* CHEEV */
+
+ s_copy(srnamc_1.srnamt, "CHEEV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cheev_("/", "U", &c__0, a, &c__1, x, w, &c__1, rw, &info);
+ chkxer_("CHEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cheev_("N", "/", &c__0, a, &c__1, x, w, &c__1, rw, &info);
+ chkxer_("CHEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cheev_("N", "U", &c_n1, a, &c__1, x, w, &c__1, rw, &info);
+ chkxer_("CHEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cheev_("N", "U", &c__2, a, &c__1, x, w, &c__3, rw, &info);
+ chkxer_("CHEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cheev_("N", "U", &c__2, a, &c__2, x, w, &c__2, rw, &info);
+ chkxer_("CHEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 5;
+
+/* CHEEVX */
+
+ s_copy(srnamc_1.srnamt, "CHEEVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cheevx_("/", "A", "U", &c__0, a, &c__1, &c_b458, &c_b458, &c__0, &
+ c__0, &c_b458, &m, x, z__, &c__1, w, &c__1, rw, iw, i3, &info);
+ chkxer_("CHEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cheevx_("V", "/", "U", &c__0, a, &c__1, &c_b458, &c_b472, &c__1, &
+ c__0, &c_b458, &m, x, z__, &c__1, w, &c__1, rw, iw, i3, &info);
+ chkxer_("CHEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cheevx_("V", "A", "/", &c__0, a, &c__1, &c_b458, &c_b458, &c__0, &
+ c__0, &c_b458, &m, x, z__, &c__1, w, &c__1, rw, iw, i3, &info);
+ infoc_1.infot = 4;
+ cheevx_("V", "A", "U", &c_n1, a, &c__1, &c_b458, &c_b458, &c__0, &
+ c__0, &c_b458, &m, x, z__, &c__1, w, &c__1, rw, iw, i3, &info);
+ chkxer_("CHEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cheevx_("V", "A", "U", &c__2, a, &c__1, &c_b458, &c_b458, &c__0, &
+ c__0, &c_b458, &m, x, z__, &c__2, w, &c__3, rw, iw, i3, &info);
+ chkxer_("CHEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cheevx_("V", "V", "U", &c__1, a, &c__1, &c_b458, &c_b458, &c__0, &
+ c__0, &c_b458, &m, x, z__, &c__1, w, &c__1, rw, iw, i3, &info);
+ chkxer_("CHEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ cheevx_("V", "I", "U", &c__1, a, &c__1, &c_b458, &c_b458, &c__0, &
+ c__0, &c_b458, &m, x, z__, &c__1, w, &c__1, rw, iw, i3, &info);
+ chkxer_("CHEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cheevx_("V", "I", "U", &c__2, a, &c__2, &c_b458, &c_b458, &c__2, &
+ c__1, &c_b458, &m, x, z__, &c__2, w, &c__3, rw, iw, i3, &info);
+ chkxer_("CHEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ cheevx_("V", "A", "U", &c__2, a, &c__2, &c_b458, &c_b458, &c__0, &
+ c__0, &c_b458, &m, x, z__, &c__1, w, &c__3, rw, iw, i3, &info);
+ chkxer_("CHEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 17;
+ cheevx_("V", "A", "U", &c__2, a, &c__2, &c_b458, &c_b458, &c__0, &
+ c__0, &c_b458, &m, x, z__, &c__2, w, &c__2, rw, iw, i1, &info);
+ chkxer_("CHEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* CHEEVR */
+
+ s_copy(srnamc_1.srnamt, "CHEEVR", (ftnlen)32, (ftnlen)6);
+ n = 1;
+ infoc_1.infot = 1;
+ i__1 = n << 1;
+ i__2 = n * 24;
+ i__3 = n * 10;
+ cheevr_("/", "A", "U", &c__0, a, &c__1, &c_b458, &c_b458, &c__1, &
+ c__1, &c_b458, &m, r__, z__, &c__1, iw, q, &i__1, rw, &i__2, &
+ iw[n * 2], &i__3, &info);
+ chkxer_("CHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ i__1 = n << 1;
+ i__2 = n * 24;
+ i__3 = n * 10;
+ cheevr_("V", "/", "U", &c__0, a, &c__1, &c_b458, &c_b458, &c__1, &
+ c__1, &c_b458, &m, r__, z__, &c__1, iw, q, &i__1, rw, &i__2, &
+ iw[n * 2], &i__3, &info);
+ chkxer_("CHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ i__1 = n << 1;
+ i__2 = n * 24;
+ i__3 = n * 10;
+ cheevr_("V", "A", "/", &c_n1, a, &c__1, &c_b458, &c_b458, &c__1, &
+ c__1, &c_b458, &m, r__, z__, &c__1, iw, q, &i__1, rw, &i__2, &
+ iw[n * 2], &i__3, &info);
+ chkxer_("CHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ i__1 = n << 1;
+ i__2 = n * 24;
+ i__3 = n * 10;
+ cheevr_("V", "A", "U", &c_n1, a, &c__1, &c_b458, &c_b458, &c__1, &
+ c__1, &c_b458, &m, r__, z__, &c__1, iw, q, &i__1, rw, &i__2, &
+ iw[n * 2], &i__3, &info);
+ chkxer_("CHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ i__1 = n << 1;
+ i__2 = n * 24;
+ i__3 = n * 10;
+ cheevr_("V", "A", "U", &c__2, a, &c__1, &c_b458, &c_b458, &c__1, &
+ c__1, &c_b458, &m, r__, z__, &c__1, iw, q, &i__1, rw, &i__2, &
+ iw[n * 2], &i__3, &info);
+ chkxer_("CHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ i__1 = n << 1;
+ i__2 = n * 24;
+ i__3 = n * 10;
+ cheevr_("V", "V", "U", &c__1, a, &c__1, &c_b458, &c_b458, &c__1, &
+ c__1, &c_b458, &m, r__, z__, &c__1, iw, q, &i__1, rw, &i__2, &
+ iw[n * 2], &i__3, &info);
+ chkxer_("CHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ i__1 = n << 1;
+ i__2 = n * 24;
+ i__3 = n * 10;
+ cheevr_("V", "I", "U", &c__1, a, &c__1, &c_b458, &c_b458, &c__0, &
+ c__1, &c_b458, &m, r__, z__, &c__1, iw, q, &i__1, rw, &i__2, &
+ iw[n * 2], &i__3, &info);
+ chkxer_("CHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+
+ i__1 = n << 1;
+ i__2 = n * 24;
+ i__3 = n * 10;
+ cheevr_("V", "I", "U", &c__2, a, &c__2, &c_b458, &c_b458, &c__2, &
+ c__1, &c_b458, &m, r__, z__, &c__1, iw, q, &i__1, rw, &i__2, &
+ iw[n * 2], &i__3, &info);
+ chkxer_("CHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ i__1 = n << 1;
+ i__2 = n * 24;
+ i__3 = n * 10;
+ cheevr_("V", "I", "U", &c__1, a, &c__1, &c_b458, &c_b458, &c__1, &
+ c__1, &c_b458, &m, r__, z__, &c__0, iw, q, &i__1, rw, &i__2, &
+ iw[n * 2], &i__3, &info);
+ chkxer_("CHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ i__1 = (n << 1) - 1;
+ i__2 = n * 24;
+ i__3 = n * 10;
+ cheevr_("V", "I", "U", &c__1, a, &c__1, &c_b458, &c_b458, &c__1, &
+ c__1, &c_b458, &m, r__, z__, &c__1, iw, q, &i__1, rw, &i__2, &
+ iw[n * 2], &i__3, &info);
+ chkxer_("CHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ i__1 = n << 1;
+ i__2 = n * 24 - 1;
+ i__3 = n * 10;
+ cheevr_("V", "I", "U", &c__1, a, &c__1, &c_b458, &c_b458, &c__1, &
+ c__1, &c_b458, &m, r__, z__, &c__1, iw, q, &i__1, rw, &i__2, &
+ iw[(n << 1) - 2], &i__3, &info);
+ chkxer_("CHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 22;
+ i__1 = n << 1;
+ i__2 = n * 24;
+ i__3 = n * 10 - 1;
+ cheevr_("V", "I", "U", &c__1, a, &c__1, &c_b458, &c_b458, &c__1, &
+ c__1, &c_b458, &m, r__, z__, &c__1, iw, q, &i__1, rw, &i__2,
+ iw, &i__3, &info);
+ chkxer_("CHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 12;
+
+/* CHPEVD */
+
+ s_copy(srnamc_1.srnamt, "CHPEVD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chpevd_("/", "U", &c__0, a, x, z__, &c__1, w, &c__1, rw, &c__1, iw, &
+ c__1, &info);
+ chkxer_("CHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chpevd_("N", "/", &c__0, a, x, z__, &c__1, w, &c__1, rw, &c__1, iw, &
+ c__1, &info);
+ chkxer_("CHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ chpevd_("N", "U", &c_n1, a, x, z__, &c__1, w, &c__1, rw, &c__1, iw, &
+ c__1, &info);
+ chkxer_("CHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ chpevd_("V", "U", &c__2, a, x, z__, &c__1, w, &c__4, rw, &c__25, iw, &
+ c__12, &info);
+ chkxer_("CHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ chpevd_("N", "U", &c__1, a, x, z__, &c__1, w, &c__0, rw, &c__1, iw, &
+ c__1, &info);
+ chkxer_("CHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ chpevd_("N", "U", &c__2, a, x, z__, &c__2, w, &c__1, rw, &c__2, iw, &
+ c__1, &info);
+ chkxer_("CHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ chpevd_("V", "U", &c__2, a, x, z__, &c__2, w, &c__2, rw, &c__25, iw, &
+ c__12, &info);
+ chkxer_("CHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ chpevd_("N", "U", &c__1, a, x, z__, &c__1, w, &c__1, rw, &c__0, iw, &
+ c__1, &info);
+ chkxer_("CHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ chpevd_("N", "U", &c__2, a, x, z__, &c__2, w, &c__2, rw, &c__1, iw, &
+ c__1, &info);
+ chkxer_("CHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ chpevd_("V", "U", &c__2, a, x, z__, &c__2, w, &c__4, rw, &c__18, iw, &
+ c__12, &info);
+ chkxer_("CHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ chpevd_("N", "U", &c__1, a, x, z__, &c__1, w, &c__1, rw, &c__1, iw, &
+ c__0, &info);
+ chkxer_("CHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ chpevd_("N", "U", &c__2, a, x, z__, &c__2, w, &c__2, rw, &c__2, iw, &
+ c__0, &info);
+ chkxer_("CHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ chpevd_("V", "U", &c__2, a, x, z__, &c__2, w, &c__4, rw, &c__25, iw, &
+ c__2, &info);
+ chkxer_("CHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 13;
+
+/* CHPEV */
+
+ s_copy(srnamc_1.srnamt, "CHPEV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chpev_("/", "U", &c__0, a, x, z__, &c__1, w, rw, &info);
+ chkxer_("CHPEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chpev_("N", "/", &c__0, a, x, z__, &c__1, w, rw, &info);
+ chkxer_("CHPEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ chpev_("N", "U", &c_n1, a, x, z__, &c__1, w, rw, &info);
+ chkxer_("CHPEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ chpev_("V", "U", &c__2, a, x, z__, &c__1, w, rw, &info);
+ chkxer_("CHPEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 4;
+
+/* CHPEVX */
+
+ s_copy(srnamc_1.srnamt, "CHPEVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chpevx_("/", "A", "U", &c__0, a, &c_b458, &c_b458, &c__0, &c__0, &
+ c_b458, &m, x, z__, &c__1, w, rw, iw, i3, &info);
+ chkxer_("CHPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chpevx_("V", "/", "U", &c__0, a, &c_b458, &c_b472, &c__1, &c__0, &
+ c_b458, &m, x, z__, &c__1, w, rw, iw, i3, &info);
+ chkxer_("CHPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ chpevx_("V", "A", "/", &c__0, a, &c_b458, &c_b458, &c__0, &c__0, &
+ c_b458, &m, x, z__, &c__1, w, rw, iw, i3, &info);
+ chkxer_("CHPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ chpevx_("V", "A", "U", &c_n1, a, &c_b458, &c_b458, &c__0, &c__0, &
+ c_b458, &m, x, z__, &c__1, w, rw, iw, i3, &info);
+ chkxer_("CHPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ chpevx_("V", "V", "U", &c__1, a, &c_b458, &c_b458, &c__0, &c__0, &
+ c_b458, &m, x, z__, &c__1, w, rw, iw, i3, &info);
+ chkxer_("CHPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ chpevx_("V", "I", "U", &c__1, a, &c_b458, &c_b458, &c__0, &c__0, &
+ c_b458, &m, x, z__, &c__1, w, rw, iw, i3, &info);
+ chkxer_("CHPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ chpevx_("V", "I", "U", &c__2, a, &c_b458, &c_b458, &c__2, &c__1, &
+ c_b458, &m, x, z__, &c__2, w, rw, iw, i3, &info);
+ chkxer_("CHPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ chpevx_("V", "A", "U", &c__2, a, &c_b458, &c_b458, &c__0, &c__0, &
+ c_b458, &m, x, z__, &c__1, w, rw, iw, i3, &info);
+ chkxer_("CHPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Test error exits for the HB path. */
+
+ } else if (lsamen_(&c__2, c2, "HB")) {
+
+/* CHBTRD */
+
+ s_copy(srnamc_1.srnamt, "CHBTRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chbtrd_("/", "U", &c__0, &c__0, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("CHBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chbtrd_("N", "/", &c__0, &c__0, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("CHBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ chbtrd_("N", "U", &c_n1, &c__0, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("CHBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ chbtrd_("N", "U", &c__0, &c_n1, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("CHBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ chbtrd_("N", "U", &c__1, &c__1, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("CHBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ chbtrd_("V", "U", &c__2, &c__0, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("CHBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+/* CHBEVD */
+
+ s_copy(srnamc_1.srnamt, "CHBEVD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chbevd_("/", "U", &c__0, &c__0, a, &c__1, x, z__, &c__1, w, &c__1, rw,
+ &c__1, iw, &c__1, &info);
+ chkxer_("CHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chbevd_("N", "/", &c__0, &c__0, a, &c__1, x, z__, &c__1, w, &c__1, rw,
+ &c__1, iw, &c__1, &info);
+ chkxer_("CHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ chbevd_("N", "U", &c_n1, &c__0, a, &c__1, x, z__, &c__1, w, &c__1, rw,
+ &c__1, iw, &c__1, &info);
+ chkxer_("CHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ chbevd_("N", "U", &c__0, &c_n1, a, &c__1, x, z__, &c__1, w, &c__1, rw,
+ &c__1, iw, &c__1, &info);
+ chkxer_("CHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ chbevd_("N", "U", &c__2, &c__1, a, &c__1, x, z__, &c__1, w, &c__2, rw,
+ &c__2, iw, &c__1, &info);
+ chkxer_("CHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ chbevd_("V", "U", &c__2, &c__1, a, &c__2, x, z__, &c__1, w, &c__8, rw,
+ &c__25, iw, &c__12, &info);
+ chkxer_("CHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ chbevd_("N", "U", &c__1, &c__0, a, &c__1, x, z__, &c__1, w, &c__0, rw,
+ &c__1, iw, &c__1, &info);
+ chkxer_("CHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ chbevd_("N", "U", &c__2, &c__1, a, &c__2, x, z__, &c__2, w, &c__1, rw,
+ &c__2, iw, &c__1, &info);
+ chkxer_("CHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ chbevd_("V", "U", &c__2, &c__1, a, &c__2, x, z__, &c__2, w, &c__2, rw,
+ &c__25, iw, &c__12, &info);
+ chkxer_("CHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ chbevd_("N", "U", &c__1, &c__0, a, &c__1, x, z__, &c__1, w, &c__1, rw,
+ &c__0, iw, &c__1, &info);
+ chkxer_("CHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ chbevd_("N", "U", &c__2, &c__1, a, &c__2, x, z__, &c__2, w, &c__2, rw,
+ &c__1, iw, &c__1, &info);
+ chkxer_("CHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ chbevd_("V", "U", &c__2, &c__1, a, &c__2, x, z__, &c__2, w, &c__8, rw,
+ &c__2, iw, &c__12, &info);
+ chkxer_("CHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ chbevd_("N", "U", &c__1, &c__0, a, &c__1, x, z__, &c__1, w, &c__1, rw,
+ &c__1, iw, &c__0, &info);
+ chkxer_("CHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ chbevd_("N", "U", &c__2, &c__1, a, &c__2, x, z__, &c__2, w, &c__2, rw,
+ &c__2, iw, &c__0, &info);
+ chkxer_("CHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ chbevd_("V", "U", &c__2, &c__1, a, &c__2, x, z__, &c__2, w, &c__8, rw,
+ &c__25, iw, &c__2, &info);
+ chkxer_("CHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 15;
+
+/* CHBEV */
+
+ s_copy(srnamc_1.srnamt, "CHBEV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chbev_("/", "U", &c__0, &c__0, a, &c__1, x, z__, &c__1, w, rw, &info);
+ chkxer_("CHBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chbev_("N", "/", &c__0, &c__0, a, &c__1, x, z__, &c__1, w, rw, &info);
+ chkxer_("CHBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ chbev_("N", "U", &c_n1, &c__0, a, &c__1, x, z__, &c__1, w, rw, &info);
+ chkxer_("CHBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ chbev_("N", "U", &c__0, &c_n1, a, &c__1, x, z__, &c__1, w, rw, &info);
+ chkxer_("CHBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ chbev_("N", "U", &c__2, &c__1, a, &c__1, x, z__, &c__1, w, rw, &info);
+ chkxer_("CHBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ chbev_("V", "U", &c__2, &c__0, a, &c__1, x, z__, &c__1, w, rw, &info);
+ chkxer_("CHBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+/* CHBEVX */
+
+ s_copy(srnamc_1.srnamt, "CHBEVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chbevx_("/", "A", "U", &c__0, &c__0, a, &c__1, q, &c__1, &c_b458, &
+ c_b458, &c__0, &c__0, &c_b458, &m, x, z__, &c__1, w, rw, iw,
+ i3, &info);
+ chkxer_("CHBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chbevx_("V", "/", "U", &c__0, &c__0, a, &c__1, q, &c__1, &c_b458, &
+ c_b472, &c__1, &c__0, &c_b458, &m, x, z__, &c__1, w, rw, iw,
+ i3, &info);
+ chkxer_("CHBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ chbevx_("V", "A", "/", &c__0, &c__0, a, &c__1, q, &c__1, &c_b458, &
+ c_b458, &c__0, &c__0, &c_b458, &m, x, z__, &c__1, w, rw, iw,
+ i3, &info);
+ infoc_1.infot = 4;
+ chbevx_("V", "A", "U", &c_n1, &c__0, a, &c__1, q, &c__1, &c_b458, &
+ c_b458, &c__0, &c__0, &c_b458, &m, x, z__, &c__1, w, rw, iw,
+ i3, &info);
+ chkxer_("CHBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ chbevx_("V", "A", "U", &c__0, &c_n1, a, &c__1, q, &c__1, &c_b458, &
+ c_b458, &c__0, &c__0, &c_b458, &m, x, z__, &c__1, w, rw, iw,
+ i3, &info);
+ chkxer_("CHBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ chbevx_("V", "A", "U", &c__2, &c__1, a, &c__1, q, &c__2, &c_b458, &
+ c_b458, &c__0, &c__0, &c_b458, &m, x, z__, &c__2, w, rw, iw,
+ i3, &info);
+ chkxer_("CHBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ chbevx_("V", "A", "U", &c__2, &c__0, a, &c__1, q, &c__1, &c_b458, &
+ c_b458, &c__0, &c__0, &c_b458, &m, x, z__, &c__2, w, rw, iw,
+ i3, &info);
+ chkxer_("CHBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ chbevx_("V", "V", "U", &c__1, &c__0, a, &c__1, q, &c__1, &c_b458, &
+ c_b458, &c__0, &c__0, &c_b458, &m, x, z__, &c__1, w, rw, iw,
+ i3, &info);
+ chkxer_("CHBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ chbevx_("V", "I", "U", &c__1, &c__0, a, &c__1, q, &c__1, &c_b458, &
+ c_b458, &c__0, &c__0, &c_b458, &m, x, z__, &c__1, w, rw, iw,
+ i3, &info);
+ chkxer_("CHBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ chbevx_("V", "I", "U", &c__1, &c__0, a, &c__1, q, &c__1, &c_b458, &
+ c_b458, &c__1, &c__2, &c_b458, &m, x, z__, &c__1, w, rw, iw,
+ i3, &info);
+ chkxer_("CHBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ chbevx_("V", "A", "U", &c__2, &c__0, a, &c__1, q, &c__2, &c_b458, &
+ c_b458, &c__0, &c__0, &c_b458, &m, x, z__, &c__1, w, rw, iw,
+ i3, &info);
+ chkxer_("CHBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+ }
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___24.ciunit = infoc_1.nout;
+ s_wsfe(&io___24);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___25.ciunit = infoc_1.nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of CERRST */
+
+} /* cerrst_ */
diff --git a/TESTING/EIG/cget02.c b/TESTING/EIG/cget02.c
new file mode 100644
index 0000000..ad42d9e
--- /dev/null
+++ b/TESTING/EIG/cget02.c
@@ -0,0 +1,187 @@
+/* cget02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b7 = {-1.f,-0.f};
+static complex c_b8 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cget02_(char *trans, integer *m, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *x, integer *ldx, complex *b,
+ integer *ldb, real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j, n1, n2;
+ real eps;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ real anorm, bnorm, xnorm;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *), scasum_(
+ integer *, complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGET02 computes the residual for a solution of a system of linear */
+/* equations A*x = b or A'*x = b: */
+/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A *x = b */
+/* = 'T': A^T*x = b, where A^T is the transpose of A */
+/* = 'C': A^H*x = b, where A^H is the conjugate transpose of A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The original M x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. IF TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if M = 0 or N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0 || *nrhs == 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+ if (lsame_(trans, "T") || lsame_(trans, "C")) {
+ n1 = *n;
+ n2 = *m;
+ } else {
+ n1 = *m;
+ n2 = *n;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = clange_("1", &n1, &n2, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute B - A*X (or B - A'*X ) and store in B. */
+
+ cgemm_(trans, "No transpose", &n1, nrhs, &n2, &c_b7, &a[a_offset], lda, &
+ x[x_offset], ldx, &c_b8, &b[b_offset], ldb)
+ ;
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = scasum_(&n1, &b[j * b_dim1 + 1], &c__1);
+ xnorm = scasum_(&n2, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of CGET02 */
+
+} /* cget02_ */
diff --git a/TESTING/EIG/cget10.c b/TESTING/EIG/cget10.c
new file mode 100644
index 0000000..5853fca
--- /dev/null
+++ b/TESTING/EIG/cget10.c
@@ -0,0 +1,151 @@
+/* cget10.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static complex c_b9 = {-1.f,0.f};
+
+/* Subroutine */ int cget10_(integer *m, integer *n, complex *a, integer *lda,
+ complex *b, integer *ldb, complex *work, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j;
+ real eps, unfl, anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ real wnorm;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *), scasum_(
+ integer *, complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGET10 compares two matrices A and B and computes the ratio */
+/* RESULT = norm( A - B ) / ( norm(A) * M * EPS ) */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices A and B. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input) COMPLEX array, dimension (LDB,N) */
+/* The m by n matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M). */
+
+/* WORK (workspace) COMPLEX array, dimension (M) */
+
+/* RWORK (workspace) COMPLEX array, dimension (M) */
+
+/* RESULT (output) REAL */
+/* RESULT = norm( A - B ) / ( norm(A) * M * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ *result = 0.f;
+ return 0;
+ }
+
+ unfl = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+
+ wnorm = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ caxpy_(m, &c_b9, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+/* Computing MAX */
+ r__1 = wnorm, r__2 = scasum_(n, &work[1], &c__1);
+ wnorm = dmax(r__1,r__2);
+/* L10: */
+ }
+
+/* Computing MAX */
+ r__1 = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ anorm = dmax(r__1,unfl);
+
+ if (anorm > wnorm) {
+ *result = wnorm / anorm / (*m * eps);
+ } else {
+ if (anorm < 1.f) {
+/* Computing MIN */
+ r__1 = wnorm, r__2 = *m * anorm;
+ *result = dmin(r__1,r__2) / anorm / (*m * eps);
+ } else {
+/* Computing MIN */
+ r__1 = wnorm / anorm, r__2 = (real) (*m);
+ *result = dmin(r__1,r__2) / (*m * eps);
+ }
+ }
+
+ return 0;
+
+/* End of CGET10 */
+
+} /* cget10_ */
diff --git a/TESTING/EIG/cget22.c b/TESTING/EIG/cget22.c
new file mode 100644
index 0000000..7d7f219
--- /dev/null
+++ b/TESTING/EIG/cget22.c
@@ -0,0 +1,344 @@
+/* cget22.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+
+/* Subroutine */ int cget22_(char *transa, char *transe, char *transw,
+ integer *n, complex *a, integer *lda, complex *e, integer *lde,
+ complex *w, complex *work, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, e_dim1, e_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer j;
+ real ulp;
+ integer joff, jcol, jvec;
+ real unfl;
+ integer jrow;
+ real temp1;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ char norma[1];
+ real anorm;
+ char norme[1];
+ real enorm;
+ complex wtemp;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *);
+ real enrmin, enrmax;
+ integer itrnse;
+ real errnrm;
+ integer itrnsw;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGET22 does an eigenvector check. */
+
+/* The basic test is: */
+
+/* RESULT(1) = | A E - E W | / ( |A| |E| ulp ) */
+
+/* using the 1-norm. It also tests the normalization of E: */
+
+/* RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp ) */
+/* j */
+
+/* where E(j) is the j-th eigenvector, and m-norm is the max-norm of a */
+/* vector. The max-norm of a complex n-vector x in this case is the */
+/* maximum of |re(x(i)| + |im(x(i)| over i = 1, ..., n. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANSA (input) CHARACTER*1 */
+/* Specifies whether or not A is transposed. */
+/* = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose */
+
+/* TRANSE (input) CHARACTER*1 */
+/* Specifies whether or not E is transposed. */
+/* = 'N': No transpose, eigenvectors are in columns of E */
+/* = 'T': Transpose, eigenvectors are in rows of E */
+/* = 'C': Conjugate transpose, eigenvectors are in rows of E */
+
+/* TRANSW (input) CHARACTER*1 */
+/* Specifies whether or not W is transposed. */
+/* = 'N': No transpose */
+/* = 'T': Transpose, same as TRANSW = 'N' */
+/* = 'C': Conjugate transpose, use -WI(j) instead of WI(j) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The matrix whose eigenvectors are in E. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* E (input) COMPLEX array, dimension (LDE,N) */
+/* The matrix of eigenvectors. If TRANSE = 'N', the eigenvectors */
+/* are stored in the columns of E, if TRANSE = 'T' or 'C', the */
+/* eigenvectors are stored in the rows of E. */
+
+/* LDE (input) INTEGER */
+/* The leading dimension of the array E. LDE >= max(1,N). */
+
+/* W (input) COMPLEX array, dimension (N) */
+/* The eigenvalues of A. */
+
+/* WORK (workspace) COMPLEX array, dimension (N*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* RESULT(1) = | A E - E W | / ( |A| |E| ulp ) */
+/* RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp ) */
+/* j */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize RESULT (in case N=0) */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ e_dim1 = *lde;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ --w;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.f;
+ result[2] = 0.f;
+ if (*n <= 0) {
+ return 0;
+ }
+
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Precision");
+
+ itrnse = 0;
+ itrnsw = 0;
+ *(unsigned char *)norma = 'O';
+ *(unsigned char *)norme = 'O';
+
+ if (lsame_(transa, "T") || lsame_(transa, "C")) {
+ *(unsigned char *)norma = 'I';
+ }
+
+ if (lsame_(transe, "T")) {
+ itrnse = 1;
+ *(unsigned char *)norme = 'I';
+ } else if (lsame_(transe, "C")) {
+ itrnse = 2;
+ *(unsigned char *)norme = 'I';
+ }
+
+ if (lsame_(transw, "C")) {
+ itrnsw = 1;
+ }
+
+/* Normalization of E: */
+
+ enrmin = 1.f / ulp;
+ enrmax = 0.f;
+ if (itrnse == 0) {
+ i__1 = *n;
+ for (jvec = 1; jvec <= i__1; ++jvec) {
+ temp1 = 0.f;
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ i__3 = j + jvec * e_dim1;
+ r__3 = temp1, r__4 = (r__1 = e[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&e[j + jvec * e_dim1]), dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* L10: */
+ }
+ enrmin = dmin(enrmin,temp1);
+ enrmax = dmax(enrmax,temp1);
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (jvec = 1; jvec <= i__1; ++jvec) {
+ rwork[jvec] = 0.f;
+/* L30: */
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (jvec = 1; jvec <= i__2; ++jvec) {
+/* Computing MAX */
+ i__3 = jvec + j * e_dim1;
+ r__3 = rwork[jvec], r__4 = (r__1 = e[i__3].r, dabs(r__1)) + (
+ r__2 = r_imag(&e[jvec + j * e_dim1]), dabs(r__2));
+ rwork[jvec] = dmax(r__3,r__4);
+/* L40: */
+ }
+/* L50: */
+ }
+
+ i__1 = *n;
+ for (jvec = 1; jvec <= i__1; ++jvec) {
+/* Computing MIN */
+ r__1 = enrmin, r__2 = rwork[jvec];
+ enrmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = enrmax, r__2 = rwork[jvec];
+ enrmax = dmax(r__1,r__2);
+/* L60: */
+ }
+ }
+
+/* Norm of A: */
+
+/* Computing MAX */
+ r__1 = clange_(norma, n, n, &a[a_offset], lda, &rwork[1]);
+ anorm = dmax(r__1,unfl);
+
+/* Norm of E: */
+
+/* Computing MAX */
+ r__1 = clange_(norme, n, n, &e[e_offset], lde, &rwork[1]);
+ enorm = dmax(r__1,ulp);
+
+/* Norm of error: */
+
+/* Error = AE - EW */
+
+ claset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
+
+ joff = 0;
+ i__1 = *n;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ if (itrnsw == 0) {
+ i__2 = jcol;
+ wtemp.r = w[i__2].r, wtemp.i = w[i__2].i;
+ } else {
+ r_cnjg(&q__1, &w[jcol]);
+ wtemp.r = q__1.r, wtemp.i = q__1.i;
+ }
+
+ if (itrnse == 0) {
+ i__2 = *n;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ i__3 = joff + jrow;
+ i__4 = jrow + jcol * e_dim1;
+ q__1.r = e[i__4].r * wtemp.r - e[i__4].i * wtemp.i, q__1.i =
+ e[i__4].r * wtemp.i + e[i__4].i * wtemp.r;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L70: */
+ }
+ } else if (itrnse == 1) {
+ i__2 = *n;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ i__3 = joff + jrow;
+ i__4 = jcol + jrow * e_dim1;
+ q__1.r = e[i__4].r * wtemp.r - e[i__4].i * wtemp.i, q__1.i =
+ e[i__4].r * wtemp.i + e[i__4].i * wtemp.r;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L80: */
+ }
+ } else {
+ i__2 = *n;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ i__3 = joff + jrow;
+ r_cnjg(&q__2, &e[jcol + jrow * e_dim1]);
+ q__1.r = q__2.r * wtemp.r - q__2.i * wtemp.i, q__1.i = q__2.r
+ * wtemp.i + q__2.i * wtemp.r;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L90: */
+ }
+ }
+ joff += *n;
+/* L100: */
+ }
+
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_(transa, transe, n, n, n, &c_b2, &a[a_offset], lda, &e[e_offset],
+ lde, &q__1, &work[1], n);
+
+ errnrm = clange_("One", n, n, &work[1], n, &rwork[1]) / enorm;
+
+/* Compute RESULT(1) (avoiding under/overflow) */
+
+ if (anorm > errnrm) {
+ result[1] = errnrm / anorm / ulp;
+ } else {
+ if (anorm < 1.f) {
+ result[1] = dmin(errnrm,anorm) / anorm / ulp;
+ } else {
+/* Computing MIN */
+ r__1 = errnrm / anorm;
+ result[1] = dmin(r__1,1.f) / ulp;
+ }
+ }
+
+/* Compute RESULT(2) : the normalization error in E. */
+
+/* Computing MAX */
+ r__3 = (r__1 = enrmax - 1.f, dabs(r__1)), r__4 = (r__2 = enrmin - 1.f,
+ dabs(r__2));
+ result[2] = dmax(r__3,r__4) / ((real) (*n) * ulp);
+
+ return 0;
+
+/* End of CGET22 */
+
+} /* cget22_ */
diff --git a/TESTING/EIG/cget23.c b/TESTING/EIG/cget23.c
new file mode 100644
index 0000000..43fdeed
--- /dev/null
+++ b/TESTING/EIG/cget23.c
@@ -0,0 +1,964 @@
+/* cget23.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__4 = 4;
+
+/* Subroutine */ int cget23_(logical *comp, integer *isrt, char *balanc,
+ integer *jtype, real *thresh, integer *iseed, integer *nounit,
+ integer *n, complex *a, integer *lda, complex *h__, complex *w,
+ complex *w1, complex *vl, integer *ldvl, complex *vr, integer *ldvr,
+ complex *lre, integer *ldlre, real *rcondv, real *rcndv1, real *
+ rcdvin, real *rconde, real *rcnde1, real *rcdein, real *scale, real *
+ scale1, real *result, complex *work, integer *lwork, real *rwork,
+ integer *info)
+{
+ /* Initialized data */
+
+ static char sens[1*2] = "N" "V";
+
+ /* Format strings */
+ static char fmt_9998[] = "(\002 CGET23: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, BALANC = "
+ "\002,a,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(\002 CGET23: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, INPUT EXAMPLE NUMBER = \002,"
+ "i4)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1,
+ vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4, r__5;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double c_abs(complex *), r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j;
+ real v;
+ integer jj, ihi, ilo;
+ real eps, res[2], tol, ulp, vmx;
+ integer ihi1, ilo1;
+ complex cdum[1];
+ integer kmin;
+ complex ctmp;
+ real vmax, tnrm, vrmx, vtst;
+ extern /* Subroutine */ int cget22_(char *, char *, char *, integer *,
+ complex *, integer *, complex *, integer *, complex *, complex *,
+ real *, real *);
+ logical balok, nobal;
+ real abnrm;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ char sense[1];
+ integer isens;
+ real tolin, abnrm1;
+ extern doublereal scnrm2_(integer *, complex *, integer *), slamch_(char *
+);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), xerbla_(char *,
+ integer *), cgeevx_(char *, char *, char *, char *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *, integer *, real *, real *, real *
+, real *, complex *, integer *, real *, integer *);
+ integer isensm;
+ real vricmp, vrimin, smlnum, ulpinv;
+
+ /* Fortran I/O blocks */
+ static cilist io___14 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___15 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGET23 checks the nonsymmetric eigenvalue problem driver CGEEVX. */
+/* If COMP = .FALSE., the first 8 of the following tests will be */
+/* performed on the input matrix A, and also test 9 if LWORK is */
+/* sufficiently large. */
+/* if COMP is .TRUE. all 11 tests will be performed. */
+
+/* (1) | A * VR - VR * W | / ( n |A| ulp ) */
+
+/* Here VR is the matrix of unit right eigenvectors. */
+/* W is a diagonal matrix with diagonal entries W(j). */
+
+/* (2) | A**H * VL - VL * W**H | / ( n |A| ulp ) */
+
+/* Here VL is the matrix of unit left eigenvectors, A**H is the */
+/* conjugate transpose of A, and W is as above. */
+
+/* (3) | |VR(i)| - 1 | / ulp and largest component real */
+
+/* VR(i) denotes the i-th column of VR. */
+
+/* (4) | |VL(i)| - 1 | / ulp and largest component real */
+
+/* VL(i) denotes the i-th column of VL. */
+
+/* (5) 0 if W(full) = W(partial), 1/ulp otherwise */
+
+/* W(full) denotes the eigenvalues computed when VR, VL, RCONDV */
+/* and RCONDE are also computed, and W(partial) denotes the */
+/* eigenvalues computed when only some of VR, VL, RCONDV, and */
+/* RCONDE are computed. */
+
+/* (6) 0 if VR(full) = VR(partial), 1/ulp otherwise */
+
+/* VR(full) denotes the right eigenvectors computed when VL, RCONDV */
+/* and RCONDE are computed, and VR(partial) denotes the result */
+/* when only some of VL and RCONDV are computed. */
+
+/* (7) 0 if VL(full) = VL(partial), 1/ulp otherwise */
+
+/* VL(full) denotes the left eigenvectors computed when VR, RCONDV */
+/* and RCONDE are computed, and VL(partial) denotes the result */
+/* when only some of VR and RCONDV are computed. */
+
+/* (8) 0 if SCALE, ILO, IHI, ABNRM (full) = */
+/* SCALE, ILO, IHI, ABNRM (partial) */
+/* 1/ulp otherwise */
+
+/* SCALE, ILO, IHI and ABNRM describe how the matrix is balanced. */
+/* (full) is when VR, VL, RCONDE and RCONDV are also computed, and */
+/* (partial) is when some are not computed. */
+
+/* (9) 0 if RCONDV(full) = RCONDV(partial), 1/ulp otherwise */
+
+/* RCONDV(full) denotes the reciprocal condition numbers of the */
+/* right eigenvectors computed when VR, VL and RCONDE are also */
+/* computed. RCONDV(partial) denotes the reciprocal condition */
+/* numbers when only some of VR, VL and RCONDE are computed. */
+
+/* (10) |RCONDV - RCDVIN| / cond(RCONDV) */
+
+/* RCONDV is the reciprocal right eigenvector condition number */
+/* computed by CGEEVX and RCDVIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDV) is the condition number of */
+/* RCONDV, and takes errors in computing RCONDV into account, so */
+/* that the resulting quantity should be O(ULP). cond(RCONDV) is */
+/* essentially given by norm(A)/RCONDE. */
+
+/* (11) |RCONDE - RCDEIN| / cond(RCONDE) */
+
+/* RCONDE is the reciprocal eigenvalue condition number */
+/* computed by CGEEVX and RCDEIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDE) is the condition number */
+/* of RCONDE, and takes errors in computing RCONDE into account, */
+/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
+/* is essentially given by norm(A)/RCONDV. */
+
+/* Arguments */
+/* ========= */
+
+/* COMP (input) LOGICAL */
+/* COMP describes which input tests to perform: */
+/* = .FALSE. if the computed condition numbers are not to */
+/* be tested against RCDVIN and RCDEIN */
+/* = .TRUE. if they are to be compared */
+
+/* ISRT (input) INTEGER */
+/* If COMP = .TRUE., ISRT indicates in how the eigenvalues */
+/* corresponding to values in RCDVIN and RCDEIN are ordered: */
+/* = 0 means the eigenvalues are sorted by */
+/* increasing real part */
+/* = 1 means the eigenvalues are sorted by */
+/* increasing imaginary part */
+/* If COMP = .FALSE., ISRT is not referenced. */
+
+/* BALANC (input) CHARACTER */
+/* Describes the balancing option to be tested. */
+/* = 'N' for no permuting or diagonal scaling */
+/* = 'P' for permuting but no diagonal scaling */
+/* = 'S' for no permuting but diagonal scaling */
+/* = 'B' for permuting and diagonal scaling */
+
+/* JTYPE (input) INTEGER */
+/* Type of input matrix. Used to label output if error occurs. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* ISEED (input) INTEGER array, dimension (4) */
+/* If COMP = .FALSE., the random number generator seed */
+/* used to produce matrix. */
+/* If COMP = .TRUE., ISEED(1) = the number of the example. */
+/* Used to label output if error occurs. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* N (input) INTEGER */
+/* The dimension of A. N must be at least 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, and H. LDA must be at */
+/* least 1 and at least N. */
+
+/* H (workspace) COMPLEX array, dimension (LDA,N) */
+/* Another copy of the test matrix A, modified by CGEEVX. */
+
+/* W (workspace) COMPLEX array, dimension (N) */
+/* Contains the eigenvalues of A. */
+
+/* W1 (workspace) COMPLEX array, dimension (N) */
+/* Like W, this array contains the eigenvalues of A, */
+/* but those computed when CGEEVX only computes a partial */
+/* eigendecomposition, i.e. not the eigenvalues and left */
+/* and right eigenvectors. */
+
+/* VL (workspace) COMPLEX array, dimension (LDVL,N) */
+/* VL holds the computed left eigenvectors. */
+
+/* LDVL (input) INTEGER */
+/* Leading dimension of VL. Must be at least max(1,N). */
+
+/* VR (workspace) COMPLEX array, dimension (LDVR,N) */
+/* VR holds the computed right eigenvectors. */
+
+/* LDVR (input) INTEGER */
+/* Leading dimension of VR. Must be at least max(1,N). */
+
+/* LRE (workspace) COMPLEX array, dimension (LDLRE,N) */
+/* LRE holds the computed right or left eigenvectors. */
+
+/* LDLRE (input) INTEGER */
+/* Leading dimension of LRE. Must be at least max(1,N). */
+
+/* RCONDV (workspace) REAL array, dimension (N) */
+/* RCONDV holds the computed reciprocal condition numbers */
+/* for eigenvectors. */
+
+/* RCNDV1 (workspace) REAL array, dimension (N) */
+/* RCNDV1 holds more computed reciprocal condition numbers */
+/* for eigenvectors. */
+
+/* RCDVIN (input) REAL array, dimension (N) */
+/* When COMP = .TRUE. RCDVIN holds the precomputed reciprocal */
+/* condition numbers for eigenvectors to be compared with */
+/* RCONDV. */
+
+/* RCONDE (workspace) REAL array, dimension (N) */
+/* RCONDE holds the computed reciprocal condition numbers */
+/* for eigenvalues. */
+
+/* RCNDE1 (workspace) REAL array, dimension (N) */
+/* RCNDE1 holds more computed reciprocal condition numbers */
+/* for eigenvalues. */
+
+/* RCDEIN (input) REAL array, dimension (N) */
+/* When COMP = .TRUE. RCDEIN holds the precomputed reciprocal */
+/* condition numbers for eigenvalues to be compared with */
+/* RCONDE. */
+
+/* SCALE (workspace) REAL array, dimension (N) */
+/* Holds information describing balancing of matrix. */
+
+/* SCALE1 (workspace) REAL array, dimension (N) */
+/* Holds information describing balancing of matrix. */
+
+/* RESULT (output) REAL array, dimension (11) */
+/* The values computed by the 11 tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 2*N, and 2*N+N**2 if tests 9, 10 or 11 are to be performed. */
+
+/* RWORK (workspace) REAL array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* If 0, successful exit. */
+/* If <0, input parameter -INFO had an incorrect value. */
+/* If >0, CGEEVX returned an error code, the absolute */
+/* value of which is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iseed;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ --w1;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ lre_dim1 = *ldlre;
+ lre_offset = 1 + lre_dim1;
+ lre -= lre_offset;
+ --rcondv;
+ --rcndv1;
+ --rcdvin;
+ --rconde;
+ --rcnde1;
+ --rcdein;
+ --scale;
+ --scale1;
+ --result;
+ --work;
+ --rwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ nobal = lsame_(balanc, "N");
+ balok = nobal || lsame_(balanc, "P") || lsame_(
+ balanc, "S") || lsame_(balanc, "B");
+ *info = 0;
+ if (*isrt != 0 && *isrt != 1) {
+ *info = -2;
+ } else if (! balok) {
+ *info = -3;
+ } else if (*thresh < 0.f) {
+ *info = -5;
+ } else if (*nounit <= 0) {
+ *info = -7;
+ } else if (*n < 0) {
+ *info = -8;
+ } else if (*lda < 1 || *lda < *n) {
+ *info = -10;
+ } else if (*ldvl < 1 || *ldvl < *n) {
+ *info = -15;
+ } else if (*ldvr < 1 || *ldvr < *n) {
+ *info = -17;
+ } else if (*ldlre < 1 || *ldlre < *n) {
+ *info = -19;
+ } else if (*lwork < *n << 1 || *comp && *lwork < (*n << 1) + *n * *n) {
+ *info = -30;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGET23", &i__1);
+ return 0;
+ }
+
+/* Quick return if nothing to do */
+
+ for (i__ = 1; i__ <= 11; ++i__) {
+ result[i__] = -1.f;
+/* L10: */
+ }
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ ulp = slamch_("Precision");
+ smlnum = slamch_("S");
+ ulpinv = 1.f / ulp;
+
+/* Compute eigenvalues and eigenvectors, and test them */
+
+ if (*lwork >= (*n << 1) + *n * *n) {
+ *(unsigned char *)sense = 'B';
+ isensm = 2;
+ } else {
+ *(unsigned char *)sense = 'E';
+ isensm = 1;
+ }
+ clacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ cgeevx_(balanc, "V", "V", sense, n, &h__[h_offset], lda, &w[1], &vl[
+ vl_offset], ldvl, &vr[vr_offset], ldvr, &ilo, &ihi, &scale[1], &
+ abnrm, &rconde[1], &rcondv[1], &work[1], lwork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ if (*jtype != 22) {
+ io___14.ciunit = *nounit;
+ s_wsfe(&io___14);
+ do_fio(&c__1, "CGEEVX1", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__1, balanc, (ftnlen)1);
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___15.ciunit = *nounit;
+ s_wsfe(&io___15);
+ do_fio(&c__1, "CGEEVX1", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Do Test (1) */
+
+ cget22_("N", "N", "N", n, &a[a_offset], lda, &vr[vr_offset], ldvr, &w[1],
+ &work[1], &rwork[1], res);
+ result[1] = res[0];
+
+/* Do Test (2) */
+
+ cget22_("C", "N", "C", n, &a[a_offset], lda, &vl[vl_offset], ldvl, &w[1],
+ &work[1], &rwork[1], res);
+ result[2] = res[0];
+
+/* Do Test (3) */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ tnrm = scnrm2_(n, &vr[j * vr_dim1 + 1], &c__1);
+/* Computing MAX */
+/* Computing MIN */
+ r__4 = ulpinv, r__5 = (r__1 = tnrm - 1.f, dabs(r__1)) / ulp;
+ r__2 = result[3], r__3 = dmin(r__4,r__5);
+ result[3] = dmax(r__2,r__3);
+ vmx = 0.f;
+ vrmx = 0.f;
+ i__2 = *n;
+ for (jj = 1; jj <= i__2; ++jj) {
+ vtst = c_abs(&vr[jj + j * vr_dim1]);
+ if (vtst > vmx) {
+ vmx = vtst;
+ }
+ i__3 = jj + j * vr_dim1;
+ if (r_imag(&vr[jj + j * vr_dim1]) == 0.f && (r__1 = vr[i__3].r,
+ dabs(r__1)) > vrmx) {
+ i__4 = jj + j * vr_dim1;
+ vrmx = (r__2 = vr[i__4].r, dabs(r__2));
+ }
+/* L20: */
+ }
+ if (vrmx / vmx < 1.f - ulp * 2.f) {
+ result[3] = ulpinv;
+ }
+/* L30: */
+ }
+
+/* Do Test (4) */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ tnrm = scnrm2_(n, &vl[j * vl_dim1 + 1], &c__1);
+/* Computing MAX */
+/* Computing MIN */
+ r__4 = ulpinv, r__5 = (r__1 = tnrm - 1.f, dabs(r__1)) / ulp;
+ r__2 = result[4], r__3 = dmin(r__4,r__5);
+ result[4] = dmax(r__2,r__3);
+ vmx = 0.f;
+ vrmx = 0.f;
+ i__2 = *n;
+ for (jj = 1; jj <= i__2; ++jj) {
+ vtst = c_abs(&vl[jj + j * vl_dim1]);
+ if (vtst > vmx) {
+ vmx = vtst;
+ }
+ i__3 = jj + j * vl_dim1;
+ if (r_imag(&vl[jj + j * vl_dim1]) == 0.f && (r__1 = vl[i__3].r,
+ dabs(r__1)) > vrmx) {
+ i__4 = jj + j * vl_dim1;
+ vrmx = (r__2 = vl[i__4].r, dabs(r__2));
+ }
+/* L40: */
+ }
+ if (vrmx / vmx < 1.f - ulp * 2.f) {
+ result[4] = ulpinv;
+ }
+/* L50: */
+ }
+
+/* Test for all options of computing condition numbers */
+
+ i__1 = isensm;
+ for (isens = 1; isens <= i__1; ++isens) {
+
+ *(unsigned char *)sense = *(unsigned char *)&sens[isens - 1];
+
+/* Compute eigenvalues only, and test them */
+
+ clacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ cgeevx_(balanc, "N", "N", sense, n, &h__[h_offset], lda, &w1[1], cdum,
+ &c__1, cdum, &c__1, &ilo1, &ihi1, &scale1[1], &abnrm1, &
+ rcnde1[1], &rcndv1[1], &work[1], lwork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ if (*jtype != 22) {
+ io___28.ciunit = *nounit;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "CGEEVX2", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__1, balanc, (ftnlen)1);
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___29.ciunit = *nounit;
+ s_wsfe(&io___29);
+ do_fio(&c__1, "CGEEVX2", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L190;
+ }
+
+/* Do Test (5) */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j;
+ i__4 = j;
+ if (w[i__3].r != w1[i__4].r || w[i__3].i != w1[i__4].i) {
+ result[5] = ulpinv;
+ }
+/* L60: */
+ }
+
+/* Do Test (8) */
+
+ if (! nobal) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (scale[j] != scale1[j]) {
+ result[8] = ulpinv;
+ }
+/* L70: */
+ }
+ if (ilo != ilo1) {
+ result[8] = ulpinv;
+ }
+ if (ihi != ihi1) {
+ result[8] = ulpinv;
+ }
+ if (abnrm != abnrm1) {
+ result[8] = ulpinv;
+ }
+ }
+
+/* Do Test (9) */
+
+ if (isens == 2 && *n > 1) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (rcondv[j] != rcndv1[j]) {
+ result[9] = ulpinv;
+ }
+/* L80: */
+ }
+ }
+
+/* Compute eigenvalues and right eigenvectors, and test them */
+
+ clacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ cgeevx_(balanc, "N", "V", sense, n, &h__[h_offset], lda, &w1[1], cdum,
+ &c__1, &lre[lre_offset], ldlre, &ilo1, &ihi1, &scale1[1], &
+ abnrm1, &rcnde1[1], &rcndv1[1], &work[1], lwork, &rwork[1], &
+ iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ if (*jtype != 22) {
+ io___30.ciunit = *nounit;
+ s_wsfe(&io___30);
+ do_fio(&c__1, "CGEEVX3", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__1, balanc, (ftnlen)1);
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___31.ciunit = *nounit;
+ s_wsfe(&io___31);
+ do_fio(&c__1, "CGEEVX3", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L190;
+ }
+
+/* Do Test (5) again */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j;
+ i__4 = j;
+ if (w[i__3].r != w1[i__4].r || w[i__3].i != w1[i__4].i) {
+ result[5] = ulpinv;
+ }
+/* L90: */
+ }
+
+/* Do Test (6) */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = *n;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = j + jj * vr_dim1;
+ i__5 = j + jj * lre_dim1;
+ if (vr[i__4].r != lre[i__5].r || vr[i__4].i != lre[i__5].i) {
+ result[6] = ulpinv;
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+
+/* Do Test (8) again */
+
+ if (! nobal) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (scale[j] != scale1[j]) {
+ result[8] = ulpinv;
+ }
+/* L120: */
+ }
+ if (ilo != ilo1) {
+ result[8] = ulpinv;
+ }
+ if (ihi != ihi1) {
+ result[8] = ulpinv;
+ }
+ if (abnrm != abnrm1) {
+ result[8] = ulpinv;
+ }
+ }
+
+/* Do Test (9) again */
+
+ if (isens == 2 && *n > 1) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (rcondv[j] != rcndv1[j]) {
+ result[9] = ulpinv;
+ }
+/* L130: */
+ }
+ }
+
+/* Compute eigenvalues and left eigenvectors, and test them */
+
+ clacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ cgeevx_(balanc, "V", "N", sense, n, &h__[h_offset], lda, &w1[1], &lre[
+ lre_offset], ldlre, cdum, &c__1, &ilo1, &ihi1, &scale1[1], &
+ abnrm1, &rcnde1[1], &rcndv1[1], &work[1], lwork, &rwork[1], &
+ iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ if (*jtype != 22) {
+ io___32.ciunit = *nounit;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "CGEEVX4", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__1, balanc, (ftnlen)1);
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___33.ciunit = *nounit;
+ s_wsfe(&io___33);
+ do_fio(&c__1, "CGEEVX4", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L190;
+ }
+
+/* Do Test (5) again */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j;
+ i__4 = j;
+ if (w[i__3].r != w1[i__4].r || w[i__3].i != w1[i__4].i) {
+ result[5] = ulpinv;
+ }
+/* L140: */
+ }
+
+/* Do Test (7) */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = *n;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = j + jj * vl_dim1;
+ i__5 = j + jj * lre_dim1;
+ if (vl[i__4].r != lre[i__5].r || vl[i__4].i != lre[i__5].i) {
+ result[7] = ulpinv;
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+
+/* Do Test (8) again */
+
+ if (! nobal) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (scale[j] != scale1[j]) {
+ result[8] = ulpinv;
+ }
+/* L170: */
+ }
+ if (ilo != ilo1) {
+ result[8] = ulpinv;
+ }
+ if (ihi != ihi1) {
+ result[8] = ulpinv;
+ }
+ if (abnrm != abnrm1) {
+ result[8] = ulpinv;
+ }
+ }
+
+/* Do Test (9) again */
+
+ if (isens == 2 && *n > 1) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (rcondv[j] != rcndv1[j]) {
+ result[9] = ulpinv;
+ }
+/* L180: */
+ }
+ }
+
+L190:
+
+/* L200: */
+ ;
+ }
+
+/* If COMP, compare condition numbers to precomputed ones */
+
+ if (*comp) {
+ clacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ cgeevx_("N", "V", "V", "B", n, &h__[h_offset], lda, &w[1], &vl[
+ vl_offset], ldvl, &vr[vr_offset], ldvr, &ilo, &ihi, &scale[1],
+ &abnrm, &rconde[1], &rcondv[1], &work[1], lwork, &rwork[1], &
+ iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___34.ciunit = *nounit;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "CGEEVX5", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Sort eigenvalues and condition numbers lexicographically */
+/* to compare with inputs */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ kmin = i__;
+ if (*isrt == 0) {
+ i__2 = i__;
+ vrimin = w[i__2].r;
+ } else {
+ vrimin = r_imag(&w[i__]);
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (*isrt == 0) {
+ i__3 = j;
+ vricmp = w[i__3].r;
+ } else {
+ vricmp = r_imag(&w[j]);
+ }
+ if (vricmp < vrimin) {
+ kmin = j;
+ vrimin = vricmp;
+ }
+/* L210: */
+ }
+ i__2 = kmin;
+ ctmp.r = w[i__2].r, ctmp.i = w[i__2].i;
+ i__2 = kmin;
+ i__3 = i__;
+ w[i__2].r = w[i__3].r, w[i__2].i = w[i__3].i;
+ i__2 = i__;
+ w[i__2].r = ctmp.r, w[i__2].i = ctmp.i;
+ vrimin = rconde[kmin];
+ rconde[kmin] = rconde[i__];
+ rconde[i__] = vrimin;
+ vrimin = rcondv[kmin];
+ rcondv[kmin] = rcondv[i__];
+ rcondv[i__] = vrimin;
+/* L220: */
+ }
+
+/* Compare condition numbers for eigenvectors */
+/* taking their condition numbers into account */
+
+ result[10] = 0.f;
+ eps = dmax(5.9605e-8f,ulp);
+/* Computing MAX */
+ r__1 = (real) (*n) * eps * abnrm;
+ v = dmax(r__1,smlnum);
+ if (abnrm == 0.f) {
+ v = 1.f;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (v > rcondv[i__] * rconde[i__]) {
+ tol = rcondv[i__];
+ } else {
+ tol = v / rconde[i__];
+ }
+ if (v > rcdvin[i__] * rcdein[i__]) {
+ tolin = rcdvin[i__];
+ } else {
+ tolin = v / rcdein[i__];
+ }
+/* Computing MAX */
+ r__1 = tol, r__2 = smlnum / eps;
+ tol = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = tolin, r__2 = smlnum / eps;
+ tolin = dmax(r__1,r__2);
+ if (eps * (rcdvin[i__] - tolin) > rcondv[i__] + tol) {
+ vmax = 1.f / eps;
+ } else if (rcdvin[i__] - tolin > rcondv[i__] + tol) {
+ vmax = (rcdvin[i__] - tolin) / (rcondv[i__] + tol);
+ } else if (rcdvin[i__] + tolin < eps * (rcondv[i__] - tol)) {
+ vmax = 1.f / eps;
+ } else if (rcdvin[i__] + tolin < rcondv[i__] - tol) {
+ vmax = (rcondv[i__] - tol) / (rcdvin[i__] + tolin);
+ } else {
+ vmax = 1.f;
+ }
+ result[10] = dmax(result[10],vmax);
+/* L230: */
+ }
+
+/* Compare condition numbers for eigenvalues */
+/* taking their condition numbers into account */
+
+ result[11] = 0.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (v > rcondv[i__]) {
+ tol = 1.f;
+ } else {
+ tol = v / rcondv[i__];
+ }
+ if (v > rcdvin[i__]) {
+ tolin = 1.f;
+ } else {
+ tolin = v / rcdvin[i__];
+ }
+/* Computing MAX */
+ r__1 = tol, r__2 = smlnum / eps;
+ tol = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = tolin, r__2 = smlnum / eps;
+ tolin = dmax(r__1,r__2);
+ if (eps * (rcdein[i__] - tolin) > rconde[i__] + tol) {
+ vmax = 1.f / eps;
+ } else if (rcdein[i__] - tolin > rconde[i__] + tol) {
+ vmax = (rcdein[i__] - tolin) / (rconde[i__] + tol);
+ } else if (rcdein[i__] + tolin < eps * (rconde[i__] - tol)) {
+ vmax = 1.f / eps;
+ } else if (rcdein[i__] + tolin < rconde[i__] - tol) {
+ vmax = (rconde[i__] - tol) / (rcdein[i__] + tolin);
+ } else {
+ vmax = 1.f;
+ }
+ result[11] = dmax(result[11],vmax);
+/* L240: */
+ }
+L250:
+
+ ;
+ }
+
+
+ return 0;
+
+/* End of CGET23 */
+
+} /* cget23_ */
diff --git a/TESTING/EIG/cget24.c b/TESTING/EIG/cget24.c
new file mode 100644
index 0000000..abfb122
--- /dev/null
+++ b/TESTING/EIG/cget24.c
@@ -0,0 +1,1175 @@
+/* cget24.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ real selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c__4 = 4;
+
+/* Subroutine */ int cget24_(logical *comp, integer *jtype, real *thresh,
+ integer *iseed, integer *nounit, integer *n, complex *a, integer *lda,
+ complex *h__, complex *ht, complex *w, complex *wt, complex *wtmp,
+ complex *vs, integer *ldvs, complex *vs1, real *rcdein, real *rcdvin,
+ integer *nslct, integer *islct, integer *isrt, real *result, complex *
+ work, integer *lwork, real *rwork, logical *bwork, integer *info)
+{
+ /* Format strings */
+ static char fmt_9998[] = "(\002 CGET24: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(\002 CGET24: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, INPUT EXAMPLE NUMBER = \002,"
+ "i4)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, ht_dim1, ht_offset, vs_dim1,
+ vs_offset, vs1_dim1, vs1_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j;
+ real v, eps, tol, ulp;
+ integer sdim, kmin;
+ complex ctmp;
+ integer itmp, ipnt[20], rsub;
+ char sort[1];
+ integer sdim1;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ integer iinfo;
+ extern /* Subroutine */ int cunt01_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, real *, real *);
+ real anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ real tolin;
+ integer isort;
+ real wnorm, rcnde1, rcndv1;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ real rconde;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *);
+ extern logical cslect_(complex *);
+ extern /* Subroutine */ int cgeesx_(char *, char *, L_fp, char *, integer
+ *, complex *, integer *, integer *, complex *, complex *, integer
+ *, real *, real *, complex *, integer *, real *, logical *,
+ integer *), xerbla_(char *, integer *);
+ integer knteig;
+ real rcondv, vricmp, vrimin, smlnum, ulpinv;
+
+ /* Fortran I/O blocks */
+ static cilist io___12 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___13 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___17 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___18 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___21 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGET24 checks the nonsymmetric eigenvalue (Schur form) problem */
+/* expert driver CGEESX. */
+
+/* If COMP = .FALSE., the first 13 of the following tests will be */
+/* be performed on the input matrix A, and also tests 14 and 15 */
+/* if LWORK is sufficiently large. */
+/* If COMP = .TRUE., all 17 test will be performed. */
+
+/* (1) 0 if T is in Schur form, 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (2) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (no sorting of eigenvalues). */
+
+/* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues). */
+
+/* (4) 0 if W are eigenvalues of T */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (5) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (7) 0 if T is in Schur form, 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (8) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (with sorting of eigenvalues). */
+
+/* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues). */
+
+/* (10) 0 if W are eigenvalues of T */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare W with and */
+/* without reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (11) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare T with and without */
+/* reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare VS with and without */
+/* reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (13) if sorting worked and SDIM is the number of */
+/* eigenvalues which were SELECTed */
+/* If workspace sufficient, also compare SDIM with and */
+/* without reciprocal condition numbers */
+
+/* (14) if RCONDE the same no matter if VS and/or RCONDV computed */
+
+/* (15) if RCONDV the same no matter if VS and/or RCONDE computed */
+
+/* (16) |RCONDE - RCDEIN| / cond(RCONDE) */
+
+/* RCONDE is the reciprocal average eigenvalue condition number */
+/* computed by CGEESX and RCDEIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDE) is the condition number */
+/* of RCONDE, and takes errors in computing RCONDE into account, */
+/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
+/* is essentially given by norm(A)/RCONDV. */
+
+/* (17) |RCONDV - RCDVIN| / cond(RCONDV) */
+
+/* RCONDV is the reciprocal right invariant subspace condition */
+/* number computed by CGEESX and RCDVIN (the precomputed true */
+/* value) is supplied as input. cond(RCONDV) is the condition */
+/* number of RCONDV, and takes errors in computing RCONDV into */
+/* account, so that the resulting quantity should be O(ULP). */
+/* cond(RCONDV) is essentially given by norm(A)/RCONDE. */
+
+/* Arguments */
+/* ========= */
+
+/* COMP (input) LOGICAL */
+/* COMP describes which input tests to perform: */
+/* = .FALSE. if the computed condition numbers are not to */
+/* be tested against RCDVIN and RCDEIN */
+/* = .TRUE. if they are to be compared */
+
+/* JTYPE (input) INTEGER */
+/* Type of input matrix. Used to label output if error occurs. */
+
+/* ISEED (input) INTEGER array, dimension (4) */
+/* If COMP = .FALSE., the random number generator seed */
+/* used to produce matrix. */
+/* If COMP = .TRUE., ISEED(1) = the number of the example. */
+/* Used to label output if error occurs. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* N (input) INTEGER */
+/* The dimension of A. N must be at least 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA, N) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, and H. LDA must be at */
+/* least 1 and at least N. */
+
+/* H (workspace) COMPLEX array, dimension (LDA, N) */
+/* Another copy of the test matrix A, modified by CGEESX. */
+
+/* HT (workspace) COMPLEX array, dimension (LDA, N) */
+/* Yet another copy of the test matrix A, modified by CGEESX. */
+
+/* W (workspace) COMPLEX array, dimension (N) */
+/* The computed eigenvalues of A. */
+
+/* WT (workspace) COMPLEX array, dimension (N) */
+/* Like W, this array contains the eigenvalues of A, */
+/* but those computed when CGEESX only computes a partial */
+/* eigendecomposition, i.e. not Schur vectors */
+
+/* WTMP (workspace) COMPLEX array, dimension (N) */
+/* Like W, this array contains the eigenvalues of A, */
+/* but sorted by increasing real or imaginary part. */
+
+/* VS (workspace) COMPLEX array, dimension (LDVS, N) */
+/* VS holds the computed Schur vectors. */
+
+/* LDVS (input) INTEGER */
+/* Leading dimension of VS. Must be at least max(1, N). */
+
+/* VS1 (workspace) COMPLEX array, dimension (LDVS, N) */
+/* VS1 holds another copy of the computed Schur vectors. */
+
+/* RCDEIN (input) REAL */
+/* When COMP = .TRUE. RCDEIN holds the precomputed reciprocal */
+/* condition number for the average of selected eigenvalues. */
+
+/* RCDVIN (input) REAL */
+/* When COMP = .TRUE. RCDVIN holds the precomputed reciprocal */
+/* condition number for the selected right invariant subspace. */
+
+/* NSLCT (input) INTEGER */
+/* When COMP = .TRUE. the number of selected eigenvalues */
+/* corresponding to the precomputed values RCDEIN and RCDVIN. */
+
+/* ISLCT (input) INTEGER array, dimension (NSLCT) */
+/* When COMP = .TRUE. ISLCT selects the eigenvalues of the */
+/* input matrix corresponding to the precomputed values RCDEIN */
+/* and RCDVIN. For I=1, ... ,NSLCT, if ISLCT(I) = J, then the */
+/* eigenvalue with the J-th largest real or imaginary part is */
+/* selected. The real part is used if ISRT = 0, and the */
+/* imaginary part if ISRT = 1. */
+/* Not referenced if COMP = .FALSE. */
+
+/* ISRT (input) INTEGER */
+/* When COMP = .TRUE., ISRT describes how ISLCT is used to */
+/* choose a subset of the spectrum. */
+/* Not referenced if COMP = .FALSE. */
+
+/* RESULT (output) REAL array, dimension (17) */
+/* The values computed by the 17 tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N*N) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK to be passed to CGEESX. This */
+/* must be at least 2*N, and N*(N+1)/2 if tests 14--16 are to */
+/* be performed. */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* If 0, successful exit. */
+/* If <0, input parameter -INFO had an incorrect value. */
+/* If >0, CGEESX returned an error code, the absolute */
+/* value of which is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ /* Parameter adjustments */
+ --iseed;
+ ht_dim1 = *lda;
+ ht_offset = 1 + ht_dim1;
+ ht -= ht_offset;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ --wt;
+ --wtmp;
+ vs1_dim1 = *ldvs;
+ vs1_offset = 1 + vs1_dim1;
+ vs1 -= vs1_offset;
+ vs_dim1 = *ldvs;
+ vs_offset = 1 + vs_dim1;
+ vs -= vs_offset;
+ --islct;
+ --result;
+ --work;
+ --rwork;
+ --bwork;
+
+ /* Function Body */
+ *info = 0;
+ if (*thresh < 0.f) {
+ *info = -3;
+ } else if (*nounit <= 0) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (*lda < 1 || *lda < *n) {
+ *info = -8;
+ } else if (*ldvs < 1 || *ldvs < *n) {
+ *info = -15;
+ } else if (*lwork < *n << 1) {
+ *info = -24;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGET24", &i__1);
+ return 0;
+ }
+
+/* Quick return if nothing to do */
+
+ for (i__ = 1; i__ <= 17; ++i__) {
+ result[i__] = -1.f;
+/* L10: */
+ }
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Important constants */
+
+ smlnum = slamch_("Safe minimum");
+ ulp = slamch_("Precision");
+ ulpinv = 1.f / ulp;
+
+/* Perform tests (1)-(13) */
+
+ sslct_1.selopt = 0;
+ for (isort = 0; isort <= 1; ++isort) {
+ if (isort == 0) {
+ *(unsigned char *)sort = 'N';
+ rsub = 0;
+ } else {
+ *(unsigned char *)sort = 'S';
+ rsub = 6;
+ }
+
+/* Compute Schur form and Schur vectors, and test them */
+
+ clacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ cgeesx_("V", sort, (L_fp)cslect_, "N", n, &h__[h_offset], lda, &sdim,
+ &w[1], &vs[vs_offset], ldvs, &rconde, &rcondv, &work[1],
+ lwork, &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[rsub + 1] = ulpinv;
+ if (*jtype != 22) {
+ io___12.ciunit = *nounit;
+ s_wsfe(&io___12);
+ do_fio(&c__1, "CGEESX1", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___13.ciunit = *nounit;
+ s_wsfe(&io___13);
+ do_fio(&c__1, "CGEESX1", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ return 0;
+ }
+ if (isort == 0) {
+ ccopy_(n, &w[1], &c__1, &wtmp[1], &c__1);
+ }
+
+/* Do Test (1) or Test (7) */
+
+ result[rsub + 1] = 0.f;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * h_dim1;
+ if (h__[i__3].r != 0.f || h__[i__3].i != 0.f) {
+ result[rsub + 1] = ulpinv;
+ }
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* Test (2) or (8): Compute norm(A - Q*H*Q') / (norm(A) * N * ULP) */
+
+/* Copy A to VS1, used as workspace */
+
+ clacpy_(" ", n, n, &a[a_offset], lda, &vs1[vs1_offset], ldvs);
+
+/* Compute Q*H and store in HT. */
+
+ cgemm_("No transpose", "No transpose", n, n, n, &c_b2, &vs[vs_offset],
+ ldvs, &h__[h_offset], lda, &c_b1, &ht[ht_offset], lda);
+
+/* Compute A - Q*H*Q' */
+
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "Conjugate transpose", n, n, n, &q__1, &ht[
+ ht_offset], lda, &vs[vs_offset], ldvs, &c_b2, &vs1[vs1_offset]
+, ldvs);
+
+/* Computing MAX */
+ r__1 = clange_("1", n, n, &a[a_offset], lda, &rwork[1]);
+ anorm = dmax(r__1,smlnum);
+ wnorm = clange_("1", n, n, &vs1[vs1_offset], ldvs, &rwork[1]);
+
+ if (anorm > wnorm) {
+ result[rsub + 2] = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.f) {
+/* Computing MIN */
+ r__1 = wnorm, r__2 = *n * anorm;
+ result[rsub + 2] = dmin(r__1,r__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ r__1 = wnorm / anorm, r__2 = (real) (*n);
+ result[rsub + 2] = dmin(r__1,r__2) / (*n * ulp);
+ }
+ }
+
+/* Test (3) or (9): Compute norm( I - Q'*Q ) / ( N * ULP ) */
+
+ cunt01_("Columns", n, n, &vs[vs_offset], ldvs, &work[1], lwork, &
+ rwork[1], &result[rsub + 3]);
+
+/* Do Test (4) or Test (10) */
+
+ result[rsub + 4] = 0.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * h_dim1;
+ i__3 = i__;
+ if (h__[i__2].r != w[i__3].r || h__[i__2].i != w[i__3].i) {
+ result[rsub + 4] = ulpinv;
+ }
+/* L40: */
+ }
+
+/* Do Test (5) or Test (11) */
+
+ clacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ cgeesx_("N", sort, (L_fp)cslect_, "N", n, &ht[ht_offset], lda, &sdim,
+ &wt[1], &vs[vs_offset], ldvs, &rconde, &rcondv, &work[1],
+ lwork, &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[rsub + 5] = ulpinv;
+ if (*jtype != 22) {
+ io___17.ciunit = *nounit;
+ s_wsfe(&io___17);
+ do_fio(&c__1, "CGEESX2", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___18.ciunit = *nounit;
+ s_wsfe(&io___18);
+ do_fio(&c__1, "CGEESX2", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+ result[rsub + 5] = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * h_dim1;
+ i__4 = i__ + j * ht_dim1;
+ if (h__[i__3].r != ht[i__4].r || h__[i__3].i != ht[i__4].i) {
+ result[rsub + 5] = ulpinv;
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* Do Test (6) or Test (12) */
+
+ result[rsub + 6] = 0.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ if (w[i__2].r != wt[i__3].r || w[i__2].i != wt[i__3].i) {
+ result[rsub + 6] = ulpinv;
+ }
+/* L70: */
+ }
+
+/* Do Test (13) */
+
+ if (isort == 1) {
+ result[13] = 0.f;
+ knteig = 0;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (cslect_(&w[i__])) {
+ ++knteig;
+ }
+ if (i__ < *n) {
+ if (cslect_(&w[i__ + 1]) && ! cslect_(&w[i__])) {
+ result[13] = ulpinv;
+ }
+ }
+/* L80: */
+ }
+ if (sdim != knteig) {
+ result[13] = ulpinv;
+ }
+ }
+
+/* L90: */
+ }
+
+/* If there is enough workspace, perform tests (14) and (15) */
+/* as well as (10) through (13) */
+
+ if (*lwork >= *n * (*n + 1) / 2) {
+
+/* Compute both RCONDE and RCONDV with VS */
+
+ *(unsigned char *)sort = 'S';
+ result[14] = 0.f;
+ result[15] = 0.f;
+ clacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ cgeesx_("V", sort, (L_fp)cslect_, "B", n, &ht[ht_offset], lda, &sdim1,
+ &wt[1], &vs1[vs1_offset], ldvs, &rconde, &rcondv, &work[1],
+ lwork, &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[14] = ulpinv;
+ result[15] = ulpinv;
+ if (*jtype != 22) {
+ io___21.ciunit = *nounit;
+ s_wsfe(&io___21);
+ do_fio(&c__1, "CGEESX3", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___22.ciunit = *nounit;
+ s_wsfe(&io___22);
+ do_fio(&c__1, "CGEESX3", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ if (w[i__2].r != wt[i__3].r || w[i__2].i != wt[i__3].i) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * h_dim1;
+ i__4 = i__ + j * ht_dim1;
+ if (h__[i__3].r != ht[i__4].r || h__[i__3].i != ht[i__4].i) {
+ result[11] = ulpinv;
+ }
+ i__3 = i__ + j * vs_dim1;
+ i__4 = i__ + j * vs1_dim1;
+ if (vs[i__3].r != vs1[i__4].r || vs[i__3].i != vs1[i__4].i) {
+ result[12] = ulpinv;
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+/* Compute both RCONDE and RCONDV without VS, and compare */
+
+ clacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ cgeesx_("N", sort, (L_fp)cslect_, "B", n, &ht[ht_offset], lda, &sdim1,
+ &wt[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &work[1],
+ lwork, &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[14] = ulpinv;
+ result[15] = ulpinv;
+ if (*jtype != 22) {
+ io___25.ciunit = *nounit;
+ s_wsfe(&io___25);
+ do_fio(&c__1, "CGEESX4", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___26.ciunit = *nounit;
+ s_wsfe(&io___26);
+ do_fio(&c__1, "CGEESX4", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Perform tests (14) and (15) */
+
+ if (rcnde1 != rconde) {
+ result[14] = ulpinv;
+ }
+ if (rcndv1 != rcondv) {
+ result[15] = ulpinv;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ if (w[i__2].r != wt[i__3].r || w[i__2].i != wt[i__3].i) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * h_dim1;
+ i__4 = i__ + j * ht_dim1;
+ if (h__[i__3].r != ht[i__4].r || h__[i__3].i != ht[i__4].i) {
+ result[11] = ulpinv;
+ }
+ i__3 = i__ + j * vs_dim1;
+ i__4 = i__ + j * vs1_dim1;
+ if (vs[i__3].r != vs1[i__4].r || vs[i__3].i != vs1[i__4].i) {
+ result[12] = ulpinv;
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+/* Compute RCONDE with VS, and compare */
+
+ clacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ cgeesx_("V", sort, (L_fp)cslect_, "E", n, &ht[ht_offset], lda, &sdim1,
+ &wt[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &work[1],
+ lwork, &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[14] = ulpinv;
+ if (*jtype != 22) {
+ io___27.ciunit = *nounit;
+ s_wsfe(&io___27);
+ do_fio(&c__1, "CGEESX5", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___28.ciunit = *nounit;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "CGEESX5", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Perform test (14) */
+
+ if (rcnde1 != rconde) {
+ result[14] = ulpinv;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ if (w[i__2].r != wt[i__3].r || w[i__2].i != wt[i__3].i) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * h_dim1;
+ i__4 = i__ + j * ht_dim1;
+ if (h__[i__3].r != ht[i__4].r || h__[i__3].i != ht[i__4].i) {
+ result[11] = ulpinv;
+ }
+ i__3 = i__ + j * vs_dim1;
+ i__4 = i__ + j * vs1_dim1;
+ if (vs[i__3].r != vs1[i__4].r || vs[i__3].i != vs1[i__4].i) {
+ result[12] = ulpinv;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+/* Compute RCONDE without VS, and compare */
+
+ clacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ cgeesx_("N", sort, (L_fp)cslect_, "E", n, &ht[ht_offset], lda, &sdim1,
+ &wt[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &work[1],
+ lwork, &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[14] = ulpinv;
+ if (*jtype != 22) {
+ io___29.ciunit = *nounit;
+ s_wsfe(&io___29);
+ do_fio(&c__1, "CGEESX6", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___30.ciunit = *nounit;
+ s_wsfe(&io___30);
+ do_fio(&c__1, "CGEESX6", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Perform test (14) */
+
+ if (rcnde1 != rconde) {
+ result[14] = ulpinv;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ if (w[i__2].r != wt[i__3].r || w[i__2].i != wt[i__3].i) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * h_dim1;
+ i__4 = i__ + j * ht_dim1;
+ if (h__[i__3].r != ht[i__4].r || h__[i__3].i != ht[i__4].i) {
+ result[11] = ulpinv;
+ }
+ i__3 = i__ + j * vs_dim1;
+ i__4 = i__ + j * vs1_dim1;
+ if (vs[i__3].r != vs1[i__4].r || vs[i__3].i != vs1[i__4].i) {
+ result[12] = ulpinv;
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+/* Compute RCONDV with VS, and compare */
+
+ clacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ cgeesx_("V", sort, (L_fp)cslect_, "V", n, &ht[ht_offset], lda, &sdim1,
+ &wt[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &work[1],
+ lwork, &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[15] = ulpinv;
+ if (*jtype != 22) {
+ io___31.ciunit = *nounit;
+ s_wsfe(&io___31);
+ do_fio(&c__1, "CGEESX7", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___32.ciunit = *nounit;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "CGEESX7", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Perform test (15) */
+
+ if (rcndv1 != rcondv) {
+ result[15] = ulpinv;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ if (w[i__2].r != wt[i__3].r || w[i__2].i != wt[i__3].i) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * h_dim1;
+ i__4 = i__ + j * ht_dim1;
+ if (h__[i__3].r != ht[i__4].r || h__[i__3].i != ht[i__4].i) {
+ result[11] = ulpinv;
+ }
+ i__3 = i__ + j * vs_dim1;
+ i__4 = i__ + j * vs1_dim1;
+ if (vs[i__3].r != vs1[i__4].r || vs[i__3].i != vs1[i__4].i) {
+ result[12] = ulpinv;
+ }
+/* L180: */
+ }
+/* L190: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+/* Compute RCONDV without VS, and compare */
+
+ clacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ cgeesx_("N", sort, (L_fp)cslect_, "V", n, &ht[ht_offset], lda, &sdim1,
+ &wt[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &work[1],
+ lwork, &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[15] = ulpinv;
+ if (*jtype != 22) {
+ io___33.ciunit = *nounit;
+ s_wsfe(&io___33);
+ do_fio(&c__1, "CGEESX8", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___34.ciunit = *nounit;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "CGEESX8", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Perform test (15) */
+
+ if (rcndv1 != rcondv) {
+ result[15] = ulpinv;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ if (w[i__2].r != wt[i__3].r || w[i__2].i != wt[i__3].i) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * h_dim1;
+ i__4 = i__ + j * ht_dim1;
+ if (h__[i__3].r != ht[i__4].r || h__[i__3].i != ht[i__4].i) {
+ result[11] = ulpinv;
+ }
+ i__3 = i__ + j * vs_dim1;
+ i__4 = i__ + j * vs1_dim1;
+ if (vs[i__3].r != vs1[i__4].r || vs[i__3].i != vs1[i__4].i) {
+ result[12] = ulpinv;
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+ }
+
+L220:
+
+/* If there are precomputed reciprocal condition numbers, compare */
+/* computed values with them. */
+
+ if (*comp) {
+
+/* First set up SELOPT, SELDIM, SELVAL, SELWR and SELWI so that */
+/* the logical function CSLECT selects the eigenvalues specified */
+/* by NSLCT, ISLCT and ISRT. */
+
+ sslct_1.seldim = *n;
+ sslct_1.selopt = 1;
+ eps = dmax(ulp,5.9605e-8f);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ipnt[i__ - 1] = i__;
+ sslct_1.selval[i__ - 1] = FALSE_;
+ i__2 = i__;
+ sslct_1.selwr[i__ - 1] = wtmp[i__2].r;
+ sslct_1.selwi[i__ - 1] = r_imag(&wtmp[i__]);
+/* L230: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ kmin = i__;
+ if (*isrt == 0) {
+ i__2 = i__;
+ vrimin = wtmp[i__2].r;
+ } else {
+ vrimin = r_imag(&wtmp[i__]);
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (*isrt == 0) {
+ i__3 = j;
+ vricmp = wtmp[i__3].r;
+ } else {
+ vricmp = r_imag(&wtmp[j]);
+ }
+ if (vricmp < vrimin) {
+ kmin = j;
+ vrimin = vricmp;
+ }
+/* L240: */
+ }
+ i__2 = kmin;
+ ctmp.r = wtmp[i__2].r, ctmp.i = wtmp[i__2].i;
+ i__2 = kmin;
+ i__3 = i__;
+ wtmp[i__2].r = wtmp[i__3].r, wtmp[i__2].i = wtmp[i__3].i;
+ i__2 = i__;
+ wtmp[i__2].r = ctmp.r, wtmp[i__2].i = ctmp.i;
+ itmp = ipnt[i__ - 1];
+ ipnt[i__ - 1] = ipnt[kmin - 1];
+ ipnt[kmin - 1] = itmp;
+/* L250: */
+ }
+ i__1 = *nslct;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sslct_1.selval[ipnt[islct[i__] - 1] - 1] = TRUE_;
+/* L260: */
+ }
+
+/* Compute condition numbers */
+
+ clacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ cgeesx_("N", "S", (L_fp)cslect_, "B", n, &ht[ht_offset], lda, &sdim1,
+ &wt[1], &vs1[vs1_offset], ldvs, &rconde, &rcondv, &work[1],
+ lwork, &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[16] = ulpinv;
+ result[17] = ulpinv;
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "CGEESX9", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L270;
+ }
+
+/* Compare condition number for average of selected eigenvalues */
+/* taking its condition number into account */
+
+ anorm = clange_("1", n, n, &a[a_offset], lda, &rwork[1]);
+/* Computing MAX */
+ r__1 = (real) (*n) * eps * anorm;
+ v = dmax(r__1,smlnum);
+ if (anorm == 0.f) {
+ v = 1.f;
+ }
+ if (v > rcondv) {
+ tol = 1.f;
+ } else {
+ tol = v / rcondv;
+ }
+ if (v > *rcdvin) {
+ tolin = 1.f;
+ } else {
+ tolin = v / *rcdvin;
+ }
+/* Computing MAX */
+ r__1 = tol, r__2 = smlnum / eps;
+ tol = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = tolin, r__2 = smlnum / eps;
+ tolin = dmax(r__1,r__2);
+ if (eps * (*rcdein - tolin) > rconde + tol) {
+ result[16] = ulpinv;
+ } else if (*rcdein - tolin > rconde + tol) {
+ result[16] = (*rcdein - tolin) / (rconde + tol);
+ } else if (*rcdein + tolin < eps * (rconde - tol)) {
+ result[16] = ulpinv;
+ } else if (*rcdein + tolin < rconde - tol) {
+ result[16] = (rconde - tol) / (*rcdein + tolin);
+ } else {
+ result[16] = 1.f;
+ }
+
+/* Compare condition numbers for right invariant subspace */
+/* taking its condition number into account */
+
+ if (v > rcondv * rconde) {
+ tol = rcondv;
+ } else {
+ tol = v / rconde;
+ }
+ if (v > *rcdvin * *rcdein) {
+ tolin = *rcdvin;
+ } else {
+ tolin = v / *rcdein;
+ }
+/* Computing MAX */
+ r__1 = tol, r__2 = smlnum / eps;
+ tol = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = tolin, r__2 = smlnum / eps;
+ tolin = dmax(r__1,r__2);
+ if (eps * (*rcdvin - tolin) > rcondv + tol) {
+ result[17] = ulpinv;
+ } else if (*rcdvin - tolin > rcondv + tol) {
+ result[17] = (*rcdvin - tolin) / (rcondv + tol);
+ } else if (*rcdvin + tolin < eps * (rcondv - tol)) {
+ result[17] = ulpinv;
+ } else if (*rcdvin + tolin < rcondv - tol) {
+ result[17] = (rcondv - tol) / (*rcdvin + tolin);
+ } else {
+ result[17] = 1.f;
+ }
+
+L270:
+
+ ;
+ }
+
+
+ return 0;
+
+/* End of CGET24 */
+
+} /* cget24_ */
diff --git a/TESTING/EIG/cget35.c b/TESTING/EIG/cget35.c
new file mode 100644
index 0000000..cfca402
--- /dev/null
+++ b/TESTING/EIG/cget35.c
@@ -0,0 +1,351 @@
+/* cget35.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__6 = 6;
+static integer c__10 = 10;
+static complex c_b43 = {1.f,0.f};
+
+/* Subroutine */ int cget35_(real *rmax, integer *lmax, integer *ninfo,
+ integer *knt, integer *nin)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+ double c_abs(complex *);
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ complex a[100] /* was [10][10] */, b[100] /* was [10][10] */,
+ c__[100] /* was [10][10] */;
+ integer i__, j, m, n;
+ real vm1[3], vm2[3], dum[1], eps, res, res1;
+ integer imla, imlb, imlc, info;
+ complex csav[100] /* was [10][10] */;
+ integer isgn;
+ complex atmp[100] /* was [10][10] */, btmp[100] /* was [10][10] */,
+ ctmp[100] /* was [10][10] */;
+ real tnrm;
+ complex rmul;
+ real xnrm;
+ integer imlad;
+ real scale;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ char trana[1], tranb[1];
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ integer itrana, itranb;
+ real bignum, smlnum;
+ extern /* Subroutine */ int ctrsyl_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 0, 0, 0, 0 };
+ static cilist io___10 = { 0, 0, 0, 0, 0 };
+ static cilist io___13 = { 0, 0, 0, 0, 0 };
+ static cilist io___15 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGET35 tests CTRSYL, a routine for solving the Sylvester matrix */
+/* equation */
+
+/* op(A)*X + ISGN*X*op(B) = scale*C, */
+
+/* A and B are assumed to be in Schur canonical form, op() represents an */
+/* optional transpose, and ISGN can be -1 or +1. Scale is an output */
+/* less than or equal to 1, chosen to avoid overflow in X. */
+
+/* The test code verifies that the following residual is order 1: */
+
+/* norm(op(A)*X + ISGN*X*op(B) - scale*C) / */
+/* (EPS*max(norm(A),norm(B))*norm(X)) */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) REAL */
+/* Value of the largest test ratio. */
+
+/* LMAX (output) INTEGER */
+/* Example number where largest test ratio achieved. */
+
+/* NINFO (output) INTEGER */
+/* Number of examples where INFO is nonzero. */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* NIN (input) INTEGER */
+/* Input logical unit number. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Get machine parameters */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S") / eps;
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Set up test case parameters */
+
+ vm1[0] = sqrt(smlnum);
+ vm1[1] = 1.f;
+ vm1[2] = 1e6f;
+ vm2[0] = 1.f;
+ vm2[1] = eps * 2.f + 1.f;
+ vm2[2] = 2.f;
+
+ *knt = 0;
+ *ninfo = 0;
+ *lmax = 0;
+ *rmax = 0.f;
+
+/* Begin test loop */
+
+L10:
+ io___6.ciunit = *nin;
+ s_rsle(&io___6);
+ do_lio(&c__3, &c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ return 0;
+ }
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___10.ciunit = *nin;
+ s_rsle(&io___10);
+ i__2 = m;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&atmp[i__ + j * 10 - 11], (ftnlen)
+ sizeof(complex));
+ }
+ e_rsle();
+/* L20: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___13.ciunit = *nin;
+ s_rsle(&io___13);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&btmp[i__ + j * 10 - 11], (ftnlen)
+ sizeof(complex));
+ }
+ e_rsle();
+/* L30: */
+ }
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___15.ciunit = *nin;
+ s_rsle(&io___15);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&ctmp[i__ + j * 10 - 11], (ftnlen)
+ sizeof(complex));
+ }
+ e_rsle();
+/* L40: */
+ }
+ for (imla = 1; imla <= 3; ++imla) {
+ for (imlad = 1; imlad <= 3; ++imlad) {
+ for (imlb = 1; imlb <= 3; ++imlb) {
+ for (imlc = 1; imlc <= 3; ++imlc) {
+ for (itrana = 1; itrana <= 2; ++itrana) {
+ for (itranb = 1; itranb <= 2; ++itranb) {
+ for (isgn = -1; isgn <= 1; isgn += 2) {
+ if (itrana == 1) {
+ *(unsigned char *)trana = 'N';
+ }
+ if (itrana == 2) {
+ *(unsigned char *)trana = 'C';
+ }
+ if (itranb == 1) {
+ *(unsigned char *)tranb = 'N';
+ }
+ if (itranb == 2) {
+ *(unsigned char *)tranb = 'C';
+ }
+ tnrm = 0.f;
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = m;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * 10 - 11;
+ i__4 = i__ + j * 10 - 11;
+ i__5 = imla - 1;
+ q__1.r = vm1[i__5] * atmp[i__4].r,
+ q__1.i = vm1[i__5] * atmp[
+ i__4].i;
+ a[i__3].r = q__1.r, a[i__3].i =
+ q__1.i;
+/* Computing MAX */
+ r__1 = tnrm, r__2 = c_abs(&a[i__ + j *
+ 10 - 11]);
+ tnrm = dmax(r__1,r__2);
+/* L50: */
+ }
+ i__2 = i__ + i__ * 10 - 11;
+ i__3 = i__ + i__ * 10 - 11;
+ i__4 = imlad - 1;
+ q__1.r = vm2[i__4] * a[i__3].r, q__1.i =
+ vm2[i__4] * a[i__3].i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* Computing MAX */
+ r__1 = tnrm, r__2 = c_abs(&a[i__ + i__ *
+ 10 - 11]);
+ tnrm = dmax(r__1,r__2);
+/* L60: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * 10 - 11;
+ i__4 = i__ + j * 10 - 11;
+ i__5 = imlb - 1;
+ q__1.r = vm1[i__5] * btmp[i__4].r,
+ q__1.i = vm1[i__5] * btmp[
+ i__4].i;
+ b[i__3].r = q__1.r, b[i__3].i =
+ q__1.i;
+/* Computing MAX */
+ r__1 = tnrm, r__2 = c_abs(&b[i__ + j *
+ 10 - 11]);
+ tnrm = dmax(r__1,r__2);
+/* L70: */
+ }
+/* L80: */
+ }
+ if (tnrm == 0.f) {
+ tnrm = 1.f;
+ }
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * 10 - 11;
+ i__4 = i__ + j * 10 - 11;
+ i__5 = imlc - 1;
+ q__1.r = vm1[i__5] * ctmp[i__4].r,
+ q__1.i = vm1[i__5] * ctmp[
+ i__4].i;
+ c__[i__3].r = q__1.r, c__[i__3].i =
+ q__1.i;
+ i__3 = i__ + j * 10 - 11;
+ i__4 = i__ + j * 10 - 11;
+ csav[i__3].r = c__[i__4].r, csav[i__3]
+ .i = c__[i__4].i;
+/* L90: */
+ }
+/* L100: */
+ }
+ ++(*knt);
+ ctrsyl_(trana, tranb, &isgn, &m, &n, a, &
+ c__10, b, &c__10, c__, &c__10, &scale,
+ &info);
+ if (info != 0) {
+ ++(*ninfo);
+ }
+ xnrm = clange_("M", &m, &n, c__, &c__10, dum);
+ rmul.r = 1.f, rmul.i = 0.f;
+ if (xnrm > 1.f && tnrm > 1.f) {
+ if (xnrm > bignum / tnrm) {
+ r__1 = dmax(xnrm,tnrm);
+ rmul.r = r__1, rmul.i = 0.f;
+ c_div(&q__1, &c_b43, &rmul);
+ rmul.r = q__1.r, rmul.i = q__1.i;
+ }
+ }
+ r__1 = -scale;
+ q__1.r = r__1 * rmul.r, q__1.i = r__1 *
+ rmul.i;
+ cgemm_(trana, "N", &m, &n, &m, &rmul, a, &
+ c__10, c__, &c__10, &q__1, csav, &
+ c__10);
+ r__1 = (real) isgn;
+ q__1.r = r__1 * rmul.r, q__1.i = r__1 *
+ rmul.i;
+ cgemm_("N", tranb, &m, &n, &n, &q__1, c__, &
+ c__10, b, &c__10, &c_b43, csav, &
+ c__10);
+ res1 = clange_("M", &m, &n, csav, &c__10, dum);
+/* Computing MAX */
+ r__1 = smlnum, r__2 = smlnum * xnrm, r__1 =
+ max(r__1,r__2), r__2 = c_abs(&rmul) *
+ tnrm * eps * xnrm;
+ res = res1 / dmax(r__1,r__2);
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+ goto L10;
+
+/* End of CGET35 */
+
+} /* cget35_ */
diff --git a/TESTING/EIG/cget36.c b/TESTING/EIG/cget36.c
new file mode 100644
index 0000000..301e088
--- /dev/null
+++ b/TESTING/EIG/cget36.c
@@ -0,0 +1,272 @@
+/* cget36.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__6 = 6;
+static integer c__10 = 10;
+static integer c__11 = 11;
+static integer c__200 = 200;
+
+/* Subroutine */ int cget36_(real *rmax, integer *lmax, integer *ninfo,
+ integer *knt, integer *nin)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+
+ /* Local variables */
+ integer i__, j, n;
+ complex q[100] /* was [10][10] */, t1[100] /* was [10][10] */,
+ t2[100] /* was [10][10] */;
+ real eps, res;
+ complex tmp[100] /* was [10][10] */, diag[10];
+ integer ifst, ilst;
+ complex work[200];
+ integer info1, info2;
+ extern /* Subroutine */ int chst01_(integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, real *);
+ complex ctemp;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ real rwork[10];
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), ctrexc_(char *, integer *, complex *, integer *, complex
+ *, integer *, integer *, integer *, integer *);
+ real result[2];
+
+ /* Fortran I/O blocks */
+ static cilist io___2 = { 0, 0, 0, 0, 0 };
+ static cilist io___7 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGET36 tests CTREXC, a routine for reordering diagonal entries of a */
+/* matrix in complex Schur form. Thus, CLAEXC computes a unitary matrix */
+/* Q such that */
+
+/* Q' * T1 * Q = T2 */
+
+/* and where one of the diagonal blocks of T1 (the one at row IFST) has */
+/* been moved to position ILST. */
+
+/* The test code verifies that the residual Q'*T1*Q-T2 is small, that T2 */
+/* is in Schur form, and that the final position of the IFST block is */
+/* ILST. */
+
+/* The test matrices are read from a file with logical unit number NIN. */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) REAL */
+/* Value of the largest test ratio. */
+
+/* LMAX (output) INTEGER */
+/* Example number where largest test ratio achieved. */
+
+/* NINFO (output) INTEGER */
+/* Number of examples where INFO is nonzero. */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* NIN (input) INTEGER */
+/* Input logical unit number. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = slamch_("P");
+ *rmax = 0.f;
+ *lmax = 0;
+ *knt = 0;
+ *ninfo = 0;
+
+/* Read input data until N=0 */
+
+L10:
+ io___2.ciunit = *nin;
+ s_rsle(&io___2);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ifst, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ilst, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ return 0;
+ }
+ ++(*knt);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___7.ciunit = *nin;
+ s_rsle(&io___7);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&tmp[i__ + j * 10 - 11], (ftnlen)
+ sizeof(complex));
+ }
+ e_rsle();
+/* L20: */
+ }
+ clacpy_("F", &n, &n, tmp, &c__10, t1, &c__10);
+ clacpy_("F", &n, &n, tmp, &c__10, t2, &c__10);
+ res = 0.f;
+
+/* Test without accumulating Q */
+
+ claset_("Full", &n, &n, &c_b1, &c_b2, q, &c__10);
+ ctrexc_("N", &n, t1, &c__10, q, &c__10, &ifst, &ilst, &info1);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * 10 - 11;
+ if (i__ == j && (q[i__3].r != 1.f || q[i__3].i != 0.f)) {
+ res += 1.f / eps;
+ }
+ i__3 = i__ + j * 10 - 11;
+ if (i__ != j && (q[i__3].r != 0.f || q[i__3].i != 0.f)) {
+ res += 1.f / eps;
+ }
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Test with accumulating Q */
+
+ claset_("Full", &n, &n, &c_b1, &c_b2, q, &c__10);
+ ctrexc_("V", &n, t2, &c__10, q, &c__10, &ifst, &ilst, &info2);
+
+/* Compare T1 with T2 */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * 10 - 11;
+ i__4 = i__ + j * 10 - 11;
+ if (t1[i__3].r != t2[i__4].r || t1[i__3].i != t2[i__4].i) {
+ res += 1.f / eps;
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+ if (info1 != 0 || info2 != 0) {
+ ++(*ninfo);
+ }
+ if (info1 != info2) {
+ res += 1.f / eps;
+ }
+
+/* Test for successful reordering of T2 */
+
+ ccopy_(&n, tmp, &c__11, diag, &c__1);
+ if (ifst < ilst) {
+ i__1 = ilst;
+ for (i__ = ifst + 1; i__ <= i__1; ++i__) {
+ i__2 = i__ - 1;
+ ctemp.r = diag[i__2].r, ctemp.i = diag[i__2].i;
+ i__2 = i__ - 1;
+ i__3 = i__ - 2;
+ diag[i__2].r = diag[i__3].r, diag[i__2].i = diag[i__3].i;
+ i__2 = i__ - 2;
+ diag[i__2].r = ctemp.r, diag[i__2].i = ctemp.i;
+/* L70: */
+ }
+ } else if (ifst > ilst) {
+ i__1 = ilst;
+ for (i__ = ifst - 1; i__ >= i__1; --i__) {
+ i__2 = i__;
+ ctemp.r = diag[i__2].r, ctemp.i = diag[i__2].i;
+ i__2 = i__;
+ i__3 = i__ - 1;
+ diag[i__2].r = diag[i__3].r, diag[i__2].i = diag[i__3].i;
+ i__2 = i__ - 1;
+ diag[i__2].r = ctemp.r, diag[i__2].i = ctemp.i;
+/* L80: */
+ }
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * 10 - 11;
+ i__3 = i__ - 1;
+ if (t2[i__2].r != diag[i__3].r || t2[i__2].i != diag[i__3].i) {
+ res += 1.f / eps;
+ }
+/* L90: */
+ }
+
+/* Test for small residual, and orthogonality of Q */
+
+ chst01_(&n, &c__1, &n, tmp, &c__10, t2, &c__10, q, &c__10, work, &c__200,
+ rwork, result);
+ res = res + result[0] + result[1];
+
+/* Test for T2 being in Schur form */
+
+ i__1 = n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 10 - 11;
+ if (t2[i__3].r != 0.f || t2[i__3].i != 0.f) {
+ res += 1.f / eps;
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+ if (res > *rmax) {
+ *rmax = res;
+ *lmax = *knt;
+ }
+ goto L10;
+
+/* End of CGET36 */
+
+} /* cget36_ */
diff --git a/TESTING/EIG/cget37.c b/TESTING/EIG/cget37.c
new file mode 100644
index 0000000..6afa3a3
--- /dev/null
+++ b/TESTING/EIG/cget37.c
@@ -0,0 +1,724 @@
+/* cget37.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__6 = 6;
+static integer c__4 = 4;
+static integer c__20 = 20;
+static integer c__1200 = 1200;
+static integer c__0 = 0;
+
+/* Subroutine */ int cget37_(real *rmax, integer *lmax, integer *ninfo,
+ integer *knt, integer *nin)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, m, n;
+ real s[20];
+ complex t[400] /* was [20][20] */;
+ real v;
+ complex w[20], le[400] /* was [20][20] */, re[400] /* was [20][
+ 20] */;
+ real val[3], dum[1], eps, sep[20], sin__[20], tol;
+ complex tmp[400] /* was [20][20] */;
+ integer icmp;
+ complex cdum[1];
+ integer iscl, info, lcmp[3], kmin;
+ real wiin[20], vmin, vmax, tnrm;
+ integer isrt;
+ real wrin[20], vmul, stmp[20];
+ complex work[1200], wtmp[20];
+ real wsrt[20];
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real vcmin;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ real sepin[20], tolin;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ real rwork[40];
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int cgehrd_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), clacpy_(char *, integer *, integer *, complex *, integer *,
+ complex *, integer *);
+ logical select[20];
+ real bignum;
+ extern /* Subroutine */ int chseqr_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *), ctrevc_(char *,
+ char *, logical *, integer *, complex *, integer *, complex *,
+ integer *, complex *, integer *, integer *, integer *, complex *,
+ real *, integer *), ctrsna_(char *, char *,
+ logical *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, real *, integer *, integer *,
+ complex *, integer *, real *, integer *);
+ real septmp[20], smlnum;
+
+ /* Fortran I/O blocks */
+ static cilist io___5 = { 0, 0, 0, 0, 0 };
+ static cilist io___9 = { 0, 0, 0, 0, 0 };
+ static cilist io___12 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGET37 tests CTRSNA, a routine for estimating condition numbers of */
+/* eigenvalues and/or right eigenvectors of a matrix. */
+
+/* The test matrices are read from a file with logical unit number NIN. */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) REAL array, dimension (3) */
+/* Value of the largest test ratio. */
+/* RMAX(1) = largest ratio comparing different calls to CTRSNA */
+/* RMAX(2) = largest error in reciprocal condition */
+/* numbers taking their conditioning into account */
+/* RMAX(3) = largest error in reciprocal condition */
+/* numbers not taking their conditioning into */
+/* account (may be larger than RMAX(2)) */
+
+/* LMAX (output) INTEGER array, dimension (3) */
+/* LMAX(i) is example number where largest test ratio */
+/* RMAX(i) is achieved. Also: */
+/* If CGEHRD returns INFO nonzero on example i, LMAX(1)=i */
+/* If CHSEQR returns INFO nonzero on example i, LMAX(2)=i */
+/* If CTRSNA returns INFO nonzero on example i, LMAX(3)=i */
+
+/* NINFO (output) INTEGER array, dimension (3) */
+/* NINFO(1) = No. of times CGEHRD returned INFO nonzero */
+/* NINFO(2) = No. of times CHSEQR returned INFO nonzero */
+/* NINFO(3) = No. of times CTRSNA returned INFO nonzero */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* NIN (input) INTEGER */
+/* Input logical unit number */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ninfo;
+ --lmax;
+ --rmax;
+
+ /* Function Body */
+ eps = slamch_("P");
+ smlnum = slamch_("S") / eps;
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* EPSIN = 2**(-24) = precision to which input data computed */
+
+ eps = dmax(eps,5.9605e-8f);
+ rmax[1] = 0.f;
+ rmax[2] = 0.f;
+ rmax[3] = 0.f;
+ lmax[1] = 0;
+ lmax[2] = 0;
+ lmax[3] = 0;
+ *knt = 0;
+ ninfo[1] = 0;
+ ninfo[2] = 0;
+ ninfo[3] = 0;
+ val[0] = sqrt(smlnum);
+ val[1] = 1.f;
+ val[2] = sqrt(bignum);
+
+/* Read input data until N=0. Assume input eigenvalues are sorted */
+/* lexicographically (increasing by real part if ISRT = 0, */
+/* increasing by imaginary part if ISRT = 1) */
+
+L10:
+ io___5.ciunit = *nin;
+ s_rsle(&io___5);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&isrt, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ return 0;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___9.ciunit = *nin;
+ s_rsle(&io___9);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&tmp[i__ + j * 20 - 21], (ftnlen)
+ sizeof(complex));
+ }
+ e_rsle();
+/* L20: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___12.ciunit = *nin;
+ s_rsle(&io___12);
+ do_lio(&c__4, &c__1, (char *)&wrin[i__ - 1], (ftnlen)sizeof(real));
+ do_lio(&c__4, &c__1, (char *)&wiin[i__ - 1], (ftnlen)sizeof(real));
+ do_lio(&c__4, &c__1, (char *)&sin__[i__ - 1], (ftnlen)sizeof(real));
+ do_lio(&c__4, &c__1, (char *)&sepin[i__ - 1], (ftnlen)sizeof(real));
+ e_rsle();
+/* L30: */
+ }
+ tnrm = clange_("M", &n, &n, tmp, &c__20, rwork);
+ for (iscl = 1; iscl <= 3; ++iscl) {
+
+/* Scale input matrix */
+
+ ++(*knt);
+ clacpy_("F", &n, &n, tmp, &c__20, t, &c__20);
+ vmul = val[iscl - 1];
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ csscal_(&n, &vmul, &t[i__ * 20 - 20], &c__1);
+/* L40: */
+ }
+ if (tnrm == 0.f) {
+ vmul = 1.f;
+ }
+
+/* Compute eigenvalues and eigenvectors */
+
+ i__1 = 1200 - n;
+ cgehrd_(&n, &c__1, &n, t, &c__20, work, &work[n], &i__1, &info);
+ if (info != 0) {
+ lmax[1] = *knt;
+ ++ninfo[1];
+ goto L260;
+ }
+ i__1 = n - 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = n;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 20 - 21;
+ t[i__3].r = 0.f, t[i__3].i = 0.f;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* Compute Schur form */
+
+ chseqr_("S", "N", &n, &c__1, &n, t, &c__20, w, cdum, &c__1, work, &
+ c__1200, &info);
+ if (info != 0) {
+ lmax[2] = *knt;
+ ++ninfo[2];
+ goto L260;
+ }
+
+/* Compute eigenvectors */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ select[i__ - 1] = TRUE_;
+/* L70: */
+ }
+ ctrevc_("B", "A", select, &n, t, &c__20, le, &c__20, re, &c__20, &n, &
+ m, work, rwork, &info);
+
+/* Compute condition numbers */
+
+ ctrsna_("B", "A", select, &n, t, &c__20, le, &c__20, re, &c__20, s,
+ sep, &n, &m, work, &n, rwork, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L260;
+ }
+
+/* Sort eigenvalues and condition numbers lexicographically */
+/* to compare with inputs */
+
+ ccopy_(&n, w, &c__1, wtmp, &c__1);
+ if (isrt == 0) {
+
+/* Sort by increasing real part */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ - 1;
+ wsrt[i__ - 1] = w[i__2].r;
+/* L80: */
+ }
+ } else {
+
+/* Sort by increasing imaginary part */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ wsrt[i__ - 1] = r_imag(&w[i__ - 1]);
+/* L90: */
+ }
+ }
+ scopy_(&n, s, &c__1, stmp, &c__1);
+ scopy_(&n, sep, &c__1, septmp, &c__1);
+ r__1 = 1.f / vmul;
+ sscal_(&n, &r__1, septmp, &c__1);
+ i__1 = n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ kmin = i__;
+ vmin = wsrt[i__ - 1];
+ i__2 = n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (wsrt[j - 1] < vmin) {
+ kmin = j;
+ vmin = wsrt[j - 1];
+ }
+/* L100: */
+ }
+ wsrt[kmin - 1] = wsrt[i__ - 1];
+ wsrt[i__ - 1] = vmin;
+ i__2 = i__ - 1;
+ vcmin = wtmp[i__2].r;
+ i__2 = i__ - 1;
+ i__3 = kmin - 1;
+ wtmp[i__2].r = w[i__3].r, wtmp[i__2].i = w[i__3].i;
+ i__2 = kmin - 1;
+ wtmp[i__2].r = vcmin, wtmp[i__2].i = 0.f;
+ vmin = stmp[kmin - 1];
+ stmp[kmin - 1] = stmp[i__ - 1];
+ stmp[i__ - 1] = vmin;
+ vmin = septmp[kmin - 1];
+ septmp[kmin - 1] = septmp[i__ - 1];
+ septmp[i__ - 1] = vmin;
+/* L110: */
+ }
+
+/* Compare condition numbers for eigenvalues */
+/* taking their condition numbers into account */
+
+/* Computing MAX */
+ r__1 = (real) n * 2.f * eps * tnrm;
+ v = dmax(r__1,smlnum);
+ if (tnrm == 0.f) {
+ v = 1.f;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (v > septmp[i__ - 1]) {
+ tol = 1.f;
+ } else {
+ tol = v / septmp[i__ - 1];
+ }
+ if (v > sepin[i__ - 1]) {
+ tolin = 1.f;
+ } else {
+ tolin = v / sepin[i__ - 1];
+ }
+/* Computing MAX */
+ r__1 = tol, r__2 = smlnum / eps;
+ tol = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = tolin, r__2 = smlnum / eps;
+ tolin = dmax(r__1,r__2);
+ if (eps * (sin__[i__ - 1] - tolin) > stmp[i__ - 1] + tol) {
+ vmax = 1.f / eps;
+ } else if (sin__[i__ - 1] - tolin > stmp[i__ - 1] + tol) {
+ vmax = (sin__[i__ - 1] - tolin) / (stmp[i__ - 1] + tol);
+ } else if (sin__[i__ - 1] + tolin < eps * (stmp[i__ - 1] - tol)) {
+ vmax = 1.f / eps;
+ } else if (sin__[i__ - 1] + tolin < stmp[i__ - 1] - tol) {
+ vmax = (stmp[i__ - 1] - tol) / (sin__[i__ - 1] + tolin);
+ } else {
+ vmax = 1.f;
+ }
+ if (vmax > rmax[2]) {
+ rmax[2] = vmax;
+ if (ninfo[2] == 0) {
+ lmax[2] = *knt;
+ }
+ }
+/* L120: */
+ }
+
+/* Compare condition numbers for eigenvectors */
+/* taking their condition numbers into account */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (v > septmp[i__ - 1] * stmp[i__ - 1]) {
+ tol = septmp[i__ - 1];
+ } else {
+ tol = v / stmp[i__ - 1];
+ }
+ if (v > sepin[i__ - 1] * sin__[i__ - 1]) {
+ tolin = sepin[i__ - 1];
+ } else {
+ tolin = v / sin__[i__ - 1];
+ }
+/* Computing MAX */
+ r__1 = tol, r__2 = smlnum / eps;
+ tol = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = tolin, r__2 = smlnum / eps;
+ tolin = dmax(r__1,r__2);
+ if (eps * (sepin[i__ - 1] - tolin) > septmp[i__ - 1] + tol) {
+ vmax = 1.f / eps;
+ } else if (sepin[i__ - 1] - tolin > septmp[i__ - 1] + tol) {
+ vmax = (sepin[i__ - 1] - tolin) / (septmp[i__ - 1] + tol);
+ } else if (sepin[i__ - 1] + tolin < eps * (septmp[i__ - 1] - tol))
+ {
+ vmax = 1.f / eps;
+ } else if (sepin[i__ - 1] + tolin < septmp[i__ - 1] - tol) {
+ vmax = (septmp[i__ - 1] - tol) / (sepin[i__ - 1] + tolin);
+ } else {
+ vmax = 1.f;
+ }
+ if (vmax > rmax[2]) {
+ rmax[2] = vmax;
+ if (ninfo[2] == 0) {
+ lmax[2] = *knt;
+ }
+ }
+/* L130: */
+ }
+
+/* Compare condition numbers for eigenvalues */
+/* without taking their condition numbers into account */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (sin__[i__ - 1] <= (real) (n << 1) * eps && stmp[i__ - 1] <= (
+ real) (n << 1) * eps) {
+ vmax = 1.f;
+ } else if (eps * sin__[i__ - 1] > stmp[i__ - 1]) {
+ vmax = 1.f / eps;
+ } else if (sin__[i__ - 1] > stmp[i__ - 1]) {
+ vmax = sin__[i__ - 1] / stmp[i__ - 1];
+ } else if (sin__[i__ - 1] < eps * stmp[i__ - 1]) {
+ vmax = 1.f / eps;
+ } else if (sin__[i__ - 1] < stmp[i__ - 1]) {
+ vmax = stmp[i__ - 1] / sin__[i__ - 1];
+ } else {
+ vmax = 1.f;
+ }
+ if (vmax > rmax[3]) {
+ rmax[3] = vmax;
+ if (ninfo[3] == 0) {
+ lmax[3] = *knt;
+ }
+ }
+/* L140: */
+ }
+
+/* Compare condition numbers for eigenvectors */
+/* without taking their condition numbers into account */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (sepin[i__ - 1] <= v && septmp[i__ - 1] <= v) {
+ vmax = 1.f;
+ } else if (eps * sepin[i__ - 1] > septmp[i__ - 1]) {
+ vmax = 1.f / eps;
+ } else if (sepin[i__ - 1] > septmp[i__ - 1]) {
+ vmax = sepin[i__ - 1] / septmp[i__ - 1];
+ } else if (sepin[i__ - 1] < eps * septmp[i__ - 1]) {
+ vmax = 1.f / eps;
+ } else if (sepin[i__ - 1] < septmp[i__ - 1]) {
+ vmax = septmp[i__ - 1] / sepin[i__ - 1];
+ } else {
+ vmax = 1.f;
+ }
+ if (vmax > rmax[3]) {
+ rmax[3] = vmax;
+ if (ninfo[3] == 0) {
+ lmax[3] = *knt;
+ }
+ }
+/* L150: */
+ }
+
+/* Compute eigenvalue condition numbers only and compare */
+
+ vmax = 0.f;
+ dum[0] = -1.f;
+ scopy_(&n, dum, &c__0, stmp, &c__1);
+ scopy_(&n, dum, &c__0, septmp, &c__1);
+ ctrsna_("E", "A", select, &n, t, &c__20, le, &c__20, re, &c__20, stmp,
+ septmp, &n, &m, work, &n, rwork, &info)
+ ;
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L260;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (stmp[i__ - 1] != s[i__ - 1]) {
+ vmax = 1.f / eps;
+ }
+ if (septmp[i__ - 1] != dum[0]) {
+ vmax = 1.f / eps;
+ }
+/* L160: */
+ }
+
+/* Compute eigenvector condition numbers only and compare */
+
+ scopy_(&n, dum, &c__0, stmp, &c__1);
+ scopy_(&n, dum, &c__0, septmp, &c__1);
+ ctrsna_("V", "A", select, &n, t, &c__20, le, &c__20, re, &c__20, stmp,
+ septmp, &n, &m, work, &n, rwork, &info)
+ ;
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L260;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (stmp[i__ - 1] != dum[0]) {
+ vmax = 1.f / eps;
+ }
+ if (septmp[i__ - 1] != sep[i__ - 1]) {
+ vmax = 1.f / eps;
+ }
+/* L170: */
+ }
+
+/* Compute all condition numbers using SELECT and compare */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ select[i__ - 1] = TRUE_;
+/* L180: */
+ }
+ scopy_(&n, dum, &c__0, stmp, &c__1);
+ scopy_(&n, dum, &c__0, septmp, &c__1);
+ ctrsna_("B", "S", select, &n, t, &c__20, le, &c__20, re, &c__20, stmp,
+ septmp, &n, &m, work, &n, rwork, &info)
+ ;
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L260;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (septmp[i__ - 1] != sep[i__ - 1]) {
+ vmax = 1.f / eps;
+ }
+ if (stmp[i__ - 1] != s[i__ - 1]) {
+ vmax = 1.f / eps;
+ }
+/* L190: */
+ }
+
+/* Compute eigenvalue condition numbers using SELECT and compare */
+
+ scopy_(&n, dum, &c__0, stmp, &c__1);
+ scopy_(&n, dum, &c__0, septmp, &c__1);
+ ctrsna_("E", "S", select, &n, t, &c__20, le, &c__20, re, &c__20, stmp,
+ septmp, &n, &m, work, &n, rwork, &info)
+ ;
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L260;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (stmp[i__ - 1] != s[i__ - 1]) {
+ vmax = 1.f / eps;
+ }
+ if (septmp[i__ - 1] != dum[0]) {
+ vmax = 1.f / eps;
+ }
+/* L200: */
+ }
+
+/* Compute eigenvector condition numbers using SELECT and compare */
+
+ scopy_(&n, dum, &c__0, stmp, &c__1);
+ scopy_(&n, dum, &c__0, septmp, &c__1);
+ ctrsna_("V", "S", select, &n, t, &c__20, le, &c__20, re, &c__20, stmp,
+ septmp, &n, &m, work, &n, rwork, &info)
+ ;
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L260;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (stmp[i__ - 1] != dum[0]) {
+ vmax = 1.f / eps;
+ }
+ if (septmp[i__ - 1] != sep[i__ - 1]) {
+ vmax = 1.f / eps;
+ }
+/* L210: */
+ }
+ if (vmax > rmax[1]) {
+ rmax[1] = vmax;
+ if (ninfo[1] == 0) {
+ lmax[1] = *knt;
+ }
+ }
+
+/* Select second and next to last eigenvalues */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ select[i__ - 1] = FALSE_;
+/* L220: */
+ }
+ icmp = 0;
+ if (n > 1) {
+ icmp = 1;
+ lcmp[0] = 2;
+ select[1] = TRUE_;
+ ccopy_(&n, &re[20], &c__1, re, &c__1);
+ ccopy_(&n, &le[20], &c__1, le, &c__1);
+ }
+ if (n > 3) {
+ icmp = 2;
+ lcmp[1] = n - 1;
+ select[n - 2] = TRUE_;
+ ccopy_(&n, &re[(n - 1) * 20 - 20], &c__1, &re[20], &c__1);
+ ccopy_(&n, &le[(n - 1) * 20 - 20], &c__1, &le[20], &c__1);
+ }
+
+/* Compute all selected condition numbers */
+
+ scopy_(&icmp, dum, &c__0, stmp, &c__1);
+ scopy_(&icmp, dum, &c__0, septmp, &c__1);
+ ctrsna_("B", "S", select, &n, t, &c__20, le, &c__20, re, &c__20, stmp,
+ septmp, &n, &m, work, &n, rwork, &info)
+ ;
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L260;
+ }
+ i__1 = icmp;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ j = lcmp[i__ - 1];
+ if (septmp[i__ - 1] != sep[j - 1]) {
+ vmax = 1.f / eps;
+ }
+ if (stmp[i__ - 1] != s[j - 1]) {
+ vmax = 1.f / eps;
+ }
+/* L230: */
+ }
+
+/* Compute selected eigenvalue condition numbers */
+
+ scopy_(&icmp, dum, &c__0, stmp, &c__1);
+ scopy_(&icmp, dum, &c__0, septmp, &c__1);
+ ctrsna_("E", "S", select, &n, t, &c__20, le, &c__20, re, &c__20, stmp,
+ septmp, &n, &m, work, &n, rwork, &info)
+ ;
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L260;
+ }
+ i__1 = icmp;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ j = lcmp[i__ - 1];
+ if (stmp[i__ - 1] != s[j - 1]) {
+ vmax = 1.f / eps;
+ }
+ if (septmp[i__ - 1] != dum[0]) {
+ vmax = 1.f / eps;
+ }
+/* L240: */
+ }
+
+/* Compute selected eigenvector condition numbers */
+
+ scopy_(&icmp, dum, &c__0, stmp, &c__1);
+ scopy_(&icmp, dum, &c__0, septmp, &c__1);
+ ctrsna_("V", "S", select, &n, t, &c__20, le, &c__20, re, &c__20, stmp,
+ septmp, &n, &m, work, &n, rwork, &info)
+ ;
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L260;
+ }
+ i__1 = icmp;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ j = lcmp[i__ - 1];
+ if (stmp[i__ - 1] != dum[0]) {
+ vmax = 1.f / eps;
+ }
+ if (septmp[i__ - 1] != sep[j - 1]) {
+ vmax = 1.f / eps;
+ }
+/* L250: */
+ }
+ if (vmax > rmax[1]) {
+ rmax[1] = vmax;
+ if (ninfo[1] == 0) {
+ lmax[1] = *knt;
+ }
+ }
+L260:
+ ;
+ }
+ goto L10;
+
+/* End of CGET37 */
+
+} /* cget37_ */
diff --git a/TESTING/EIG/cget38.c b/TESTING/EIG/cget38.c
new file mode 100644
index 0000000..1bfa0de
--- /dev/null
+++ b/TESTING/EIG/cget38.c
@@ -0,0 +1,647 @@
+/* cget38.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__6 = 6;
+static integer c__4 = 4;
+static integer c__20 = 20;
+static integer c__1200 = 1200;
+
+/* Subroutine */ int cget38_(real *rmax, integer *lmax, integer *ninfo,
+ integer *knt, integer *nin)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, m, n;
+ complex q[400] /* was [20][20] */;
+ real s;
+ complex t[400] /* was [20][20] */;
+ real v;
+ complex w[20];
+ real val[3], eps, sep, sin__, tol;
+ complex tmp[400] /* was [20][20] */;
+ integer ndim, iscl, info, kmin, itmp;
+ real vmin, vmax;
+ integer ipnt[20];
+ complex qsav[400] /* was [20][20] */, tsav[400] /* was [20][20] */;
+ real tnrm;
+ integer isrt;
+ complex qtmp[400] /* was [20][20] */;
+ real stmp, vmul;
+ complex ttmp[400] /* was [20][20] */, work[1200], wtmp[20];
+ real wsrt[20];
+ complex tsav1[400] /* was [20][20] */;
+ extern /* Subroutine */ int chst01_(integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, real *);
+ real sepin, tolin, rwork[20];
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int cgehrd_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *);
+ integer iselec[20];
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), clacpy_(char *, integer *, integer *, complex *, integer *,
+ complex *, integer *);
+ logical select[20];
+ real bignum;
+ extern /* Subroutine */ int chseqr_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *), cunghr_(integer
+ *, integer *, integer *, complex *, integer *, complex *, complex
+ *, integer *, integer *), ctrsen_(char *, char *, logical *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, real *, real *, complex *, integer *, integer *);
+ real septmp, smlnum, result[2];
+
+ /* Fortran I/O blocks */
+ static cilist io___5 = { 0, 0, 0, 0, 0 };
+ static cilist io___9 = { 0, 0, 0, 0, 0 };
+ static cilist io___12 = { 0, 0, 0, 0, 0 };
+ static cilist io___15 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGET38 tests CTRSEN, a routine for estimating condition numbers of a */
+/* cluster of eigenvalues and/or its associated right invariant subspace */
+
+/* The test matrices are read from a file with logical unit number NIN. */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) REAL array, dimension (3) */
+/* Values of the largest test ratios. */
+/* RMAX(1) = largest residuals from CHST01 or comparing */
+/* different calls to CTRSEN */
+/* RMAX(2) = largest error in reciprocal condition */
+/* numbers taking their conditioning into account */
+/* RMAX(3) = largest error in reciprocal condition */
+/* numbers not taking their conditioning into */
+/* account (may be larger than RMAX(2)) */
+
+/* LMAX (output) INTEGER array, dimension (3) */
+/* LMAX(i) is example number where largest test ratio */
+/* RMAX(i) is achieved. Also: */
+/* If CGEHRD returns INFO nonzero on example i, LMAX(1)=i */
+/* If CHSEQR returns INFO nonzero on example i, LMAX(2)=i */
+/* If CTRSEN returns INFO nonzero on example i, LMAX(3)=i */
+
+/* NINFO (output) INTEGER array, dimension (3) */
+/* NINFO(1) = No. of times CGEHRD returned INFO nonzero */
+/* NINFO(2) = No. of times CHSEQR returned INFO nonzero */
+/* NINFO(3) = No. of times CTRSEN returned INFO nonzero */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* NIN (input) INTEGER */
+/* Input logical unit number. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ninfo;
+ --lmax;
+ --rmax;
+
+ /* Function Body */
+ eps = slamch_("P");
+ smlnum = slamch_("S") / eps;
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* EPSIN = 2**(-24) = precision to which input data computed */
+
+ eps = dmax(eps,5.9605e-8f);
+ rmax[1] = 0.f;
+ rmax[2] = 0.f;
+ rmax[3] = 0.f;
+ lmax[1] = 0;
+ lmax[2] = 0;
+ lmax[3] = 0;
+ *knt = 0;
+ ninfo[1] = 0;
+ ninfo[2] = 0;
+ ninfo[3] = 0;
+ val[0] = sqrt(smlnum);
+ val[1] = 1.f;
+ val[2] = sqrt(sqrt(bignum));
+
+/* Read input data until N=0. Assume input eigenvalues are sorted */
+/* lexicographically (increasing by real part, then decreasing by */
+/* imaginary part) */
+
+L10:
+ io___5.ciunit = *nin;
+ s_rsle(&io___5);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ndim, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&isrt, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ return 0;
+ }
+ io___9.ciunit = *nin;
+ s_rsle(&io___9);
+ i__1 = ndim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&iselec[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_rsle();
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___12.ciunit = *nin;
+ s_rsle(&io___12);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__6, &c__1, (char *)&tmp[i__ + j * 20 - 21], (ftnlen)
+ sizeof(complex));
+ }
+ e_rsle();
+/* L20: */
+ }
+ io___15.ciunit = *nin;
+ s_rsle(&io___15);
+ do_lio(&c__4, &c__1, (char *)&sin__, (ftnlen)sizeof(real));
+ do_lio(&c__4, &c__1, (char *)&sepin, (ftnlen)sizeof(real));
+ e_rsle();
+
+ tnrm = clange_("M", &n, &n, tmp, &c__20, rwork);
+ for (iscl = 1; iscl <= 3; ++iscl) {
+
+/* Scale input matrix */
+
+ ++(*knt);
+ clacpy_("F", &n, &n, tmp, &c__20, t, &c__20);
+ vmul = val[iscl - 1];
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ csscal_(&n, &vmul, &t[i__ * 20 - 20], &c__1);
+/* L30: */
+ }
+ if (tnrm == 0.f) {
+ vmul = 1.f;
+ }
+ clacpy_("F", &n, &n, t, &c__20, tsav, &c__20);
+
+/* Compute Schur form */
+
+ i__1 = 1200 - n;
+ cgehrd_(&n, &c__1, &n, t, &c__20, work, &work[n], &i__1, &info);
+ if (info != 0) {
+ lmax[1] = *knt;
+ ++ninfo[1];
+ goto L200;
+ }
+
+/* Generate unitary matrix */
+
+ clacpy_("L", &n, &n, t, &c__20, q, &c__20);
+ i__1 = 1200 - n;
+ cunghr_(&n, &c__1, &n, q, &c__20, work, &work[n], &i__1, &info);
+
+/* Compute Schur form */
+
+ i__1 = n - 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = n;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 20 - 21;
+ t[i__3].r = 0.f, t[i__3].i = 0.f;
+/* L40: */
+ }
+/* L50: */
+ }
+ chseqr_("S", "V", &n, &c__1, &n, t, &c__20, w, q, &c__20, work, &
+ c__1200, &info);
+ if (info != 0) {
+ lmax[2] = *knt;
+ ++ninfo[2];
+ goto L200;
+ }
+
+/* Sort, select eigenvalues */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ipnt[i__ - 1] = i__;
+ select[i__ - 1] = FALSE_;
+/* L60: */
+ }
+ if (isrt == 0) {
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ - 1;
+ wsrt[i__ - 1] = w[i__2].r;
+/* L70: */
+ }
+ } else {
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ wsrt[i__ - 1] = r_imag(&w[i__ - 1]);
+/* L80: */
+ }
+ }
+ i__1 = n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ kmin = i__;
+ vmin = wsrt[i__ - 1];
+ i__2 = n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (wsrt[j - 1] < vmin) {
+ kmin = j;
+ vmin = wsrt[j - 1];
+ }
+/* L90: */
+ }
+ wsrt[kmin - 1] = wsrt[i__ - 1];
+ wsrt[i__ - 1] = vmin;
+ itmp = ipnt[i__ - 1];
+ ipnt[i__ - 1] = ipnt[kmin - 1];
+ ipnt[kmin - 1] = itmp;
+/* L100: */
+ }
+ i__1 = ndim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ select[ipnt[iselec[i__ - 1] - 1] - 1] = TRUE_;
+/* L110: */
+ }
+
+/* Compute condition numbers */
+
+ clacpy_("F", &n, &n, q, &c__20, qsav, &c__20);
+ clacpy_("F", &n, &n, t, &c__20, tsav1, &c__20);
+ ctrsen_("B", "V", select, &n, t, &c__20, q, &c__20, wtmp, &m, &s, &
+ sep, work, &c__1200, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L200;
+ }
+ septmp = sep / vmul;
+ stmp = s;
+
+/* Compute residuals */
+
+ chst01_(&n, &c__1, &n, tsav, &c__20, t, &c__20, q, &c__20, work, &
+ c__1200, rwork, result);
+ vmax = dmax(result[0],result[1]);
+ if (vmax > rmax[1]) {
+ rmax[1] = vmax;
+ if (ninfo[1] == 0) {
+ lmax[1] = *knt;
+ }
+ }
+
+/* Compare condition number for eigenvalue cluster */
+/* taking its condition number into account */
+
+/* Computing MAX */
+ r__1 = (real) n * 2.f * eps * tnrm;
+ v = dmax(r__1,smlnum);
+ if (tnrm == 0.f) {
+ v = 1.f;
+ }
+ if (v > septmp) {
+ tol = 1.f;
+ } else {
+ tol = v / septmp;
+ }
+ if (v > sepin) {
+ tolin = 1.f;
+ } else {
+ tolin = v / sepin;
+ }
+/* Computing MAX */
+ r__1 = tol, r__2 = smlnum / eps;
+ tol = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = tolin, r__2 = smlnum / eps;
+ tolin = dmax(r__1,r__2);
+ if (eps * (sin__ - tolin) > stmp + tol) {
+ vmax = 1.f / eps;
+ } else if (sin__ - tolin > stmp + tol) {
+ vmax = (sin__ - tolin) / (stmp + tol);
+ } else if (sin__ + tolin < eps * (stmp - tol)) {
+ vmax = 1.f / eps;
+ } else if (sin__ + tolin < stmp - tol) {
+ vmax = (stmp - tol) / (sin__ + tolin);
+ } else {
+ vmax = 1.f;
+ }
+ if (vmax > rmax[2]) {
+ rmax[2] = vmax;
+ if (ninfo[2] == 0) {
+ lmax[2] = *knt;
+ }
+ }
+
+/* Compare condition numbers for invariant subspace */
+/* taking its condition number into account */
+
+ if (v > septmp * stmp) {
+ tol = septmp;
+ } else {
+ tol = v / stmp;
+ }
+ if (v > sepin * sin__) {
+ tolin = sepin;
+ } else {
+ tolin = v / sin__;
+ }
+/* Computing MAX */
+ r__1 = tol, r__2 = smlnum / eps;
+ tol = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = tolin, r__2 = smlnum / eps;
+ tolin = dmax(r__1,r__2);
+ if (eps * (sepin - tolin) > septmp + tol) {
+ vmax = 1.f / eps;
+ } else if (sepin - tolin > septmp + tol) {
+ vmax = (sepin - tolin) / (septmp + tol);
+ } else if (sepin + tolin < eps * (septmp - tol)) {
+ vmax = 1.f / eps;
+ } else if (sepin + tolin < septmp - tol) {
+ vmax = (septmp - tol) / (sepin + tolin);
+ } else {
+ vmax = 1.f;
+ }
+ if (vmax > rmax[2]) {
+ rmax[2] = vmax;
+ if (ninfo[2] == 0) {
+ lmax[2] = *knt;
+ }
+ }
+
+/* Compare condition number for eigenvalue cluster */
+/* without taking its condition number into account */
+
+ if (sin__ <= (real) (n << 1) * eps && stmp <= (real) (n << 1) * eps) {
+ vmax = 1.f;
+ } else if (eps * sin__ > stmp) {
+ vmax = 1.f / eps;
+ } else if (sin__ > stmp) {
+ vmax = sin__ / stmp;
+ } else if (sin__ < eps * stmp) {
+ vmax = 1.f / eps;
+ } else if (sin__ < stmp) {
+ vmax = stmp / sin__;
+ } else {
+ vmax = 1.f;
+ }
+ if (vmax > rmax[3]) {
+ rmax[3] = vmax;
+ if (ninfo[3] == 0) {
+ lmax[3] = *knt;
+ }
+ }
+
+/* Compare condition numbers for invariant subspace */
+/* without taking its condition number into account */
+
+ if (sepin <= v && septmp <= v) {
+ vmax = 1.f;
+ } else if (eps * sepin > septmp) {
+ vmax = 1.f / eps;
+ } else if (sepin > septmp) {
+ vmax = sepin / septmp;
+ } else if (sepin < eps * septmp) {
+ vmax = 1.f / eps;
+ } else if (sepin < septmp) {
+ vmax = septmp / sepin;
+ } else {
+ vmax = 1.f;
+ }
+ if (vmax > rmax[3]) {
+ rmax[3] = vmax;
+ if (ninfo[3] == 0) {
+ lmax[3] = *knt;
+ }
+ }
+
+/* Compute eigenvalue condition number only and compare */
+/* Update Q */
+
+ vmax = 0.f;
+ clacpy_("F", &n, &n, tsav1, &c__20, ttmp, &c__20);
+ clacpy_("F", &n, &n, qsav, &c__20, qtmp, &c__20);
+ septmp = -1.f;
+ stmp = -1.f;
+ ctrsen_("E", "V", select, &n, ttmp, &c__20, qtmp, &c__20, wtmp, &m, &
+ stmp, &septmp, work, &c__1200, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L200;
+ }
+ if (s != stmp) {
+ vmax = 1.f / eps;
+ }
+ if (-1.f != septmp) {
+ vmax = 1.f / eps;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ if (ttmp[i__3].r != t[i__4].r || ttmp[i__3].i != t[i__4].i) {
+ vmax = 1.f / eps;
+ }
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ if (qtmp[i__3].r != q[i__4].r || qtmp[i__3].i != q[i__4].i) {
+ vmax = 1.f / eps;
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+
+/* Compute invariant subspace condition number only and compare */
+/* Update Q */
+
+ clacpy_("F", &n, &n, tsav1, &c__20, ttmp, &c__20);
+ clacpy_("F", &n, &n, qsav, &c__20, qtmp, &c__20);
+ septmp = -1.f;
+ stmp = -1.f;
+ ctrsen_("V", "V", select, &n, ttmp, &c__20, qtmp, &c__20, wtmp, &m, &
+ stmp, &septmp, work, &c__1200, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L200;
+ }
+ if (-1.f != stmp) {
+ vmax = 1.f / eps;
+ }
+ if (sep != septmp) {
+ vmax = 1.f / eps;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ if (ttmp[i__3].r != t[i__4].r || ttmp[i__3].i != t[i__4].i) {
+ vmax = 1.f / eps;
+ }
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ if (qtmp[i__3].r != q[i__4].r || qtmp[i__3].i != q[i__4].i) {
+ vmax = 1.f / eps;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+/* Compute eigenvalue condition number only and compare */
+/* Do not update Q */
+
+ clacpy_("F", &n, &n, tsav1, &c__20, ttmp, &c__20);
+ clacpy_("F", &n, &n, qsav, &c__20, qtmp, &c__20);
+ septmp = -1.f;
+ stmp = -1.f;
+ ctrsen_("E", "N", select, &n, ttmp, &c__20, qtmp, &c__20, wtmp, &m, &
+ stmp, &septmp, work, &c__1200, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L200;
+ }
+ if (s != stmp) {
+ vmax = 1.f / eps;
+ }
+ if (-1.f != septmp) {
+ vmax = 1.f / eps;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ if (ttmp[i__3].r != t[i__4].r || ttmp[i__3].i != t[i__4].i) {
+ vmax = 1.f / eps;
+ }
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ if (qtmp[i__3].r != qsav[i__4].r || qtmp[i__3].i != qsav[i__4]
+ .i) {
+ vmax = 1.f / eps;
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+
+/* Compute invariant subspace condition number only and compare */
+/* Do not update Q */
+
+ clacpy_("F", &n, &n, tsav1, &c__20, ttmp, &c__20);
+ clacpy_("F", &n, &n, qsav, &c__20, qtmp, &c__20);
+ septmp = -1.f;
+ stmp = -1.f;
+ ctrsen_("V", "N", select, &n, ttmp, &c__20, qtmp, &c__20, wtmp, &m, &
+ stmp, &septmp, work, &c__1200, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L200;
+ }
+ if (-1.f != stmp) {
+ vmax = 1.f / eps;
+ }
+ if (sep != septmp) {
+ vmax = 1.f / eps;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ if (ttmp[i__3].r != t[i__4].r || ttmp[i__3].i != t[i__4].i) {
+ vmax = 1.f / eps;
+ }
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ if (qtmp[i__3].r != qsav[i__4].r || qtmp[i__3].i != qsav[i__4]
+ .i) {
+ vmax = 1.f / eps;
+ }
+/* L180: */
+ }
+/* L190: */
+ }
+ if (vmax > rmax[1]) {
+ rmax[1] = vmax;
+ if (ninfo[1] == 0) {
+ lmax[1] = *knt;
+ }
+ }
+L200:
+ ;
+ }
+ goto L10;
+
+/* End of CGET38 */
+
+} /* cget38_ */
diff --git a/TESTING/EIG/cget51.c b/TESTING/EIG/cget51.c
new file mode 100644
index 0000000..efb6836
--- /dev/null
+++ b/TESTING/EIG/cget51.c
@@ -0,0 +1,270 @@
+/* cget51.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+
+/* Subroutine */ int cget51_(integer *itype, integer *n, complex *a, integer *
+ lda, complex *b, integer *ldb, complex *u, integer *ldu, complex *v,
+ integer *ldv, complex *work, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, u_dim1, u_offset, v_dim1,
+ v_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Local variables */
+ real ulp;
+ integer jcol;
+ real unfl;
+ integer jrow, jdiag;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ real anorm, wnorm;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGET51 generally checks a decomposition of the form */
+
+/* A = U B V* */
+
+/* where * means conjugate transpose and U and V are unitary. */
+
+/* Specifically, if ITYPE=1 */
+
+/* RESULT = | A - U B V* | / ( |A| n ulp ) */
+
+/* If ITYPE=2, then: */
+
+/* RESULT = | A - B | / ( |A| n ulp ) */
+
+/* If ITYPE=3, then: */
+
+/* RESULT = | I - UU* | / ( n ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the type of tests to be performed. */
+/* =1: RESULT = | A - U B V* | / ( |A| n ulp ) */
+/* =2: RESULT = | A - B | / ( |A| n ulp ) */
+/* =3: RESULT = | I - UU* | / ( n ulp ) */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, CGET51 does nothing. */
+/* It must be at least zero. */
+
+/* A (input) COMPLEX array, dimension (LDA, N) */
+/* The original (unfactored) matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least N. */
+
+/* B (input) COMPLEX array, dimension (LDB, N) */
+/* The factored matrix. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. It must be at least 1 */
+/* and at least N. */
+
+/* U (input) COMPLEX array, dimension (LDU, N) */
+/* The unitary matrix on the left-hand side in the */
+/* decomposition. */
+/* Not referenced if ITYPE=2 */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+
+/* V (input) COMPLEX array, dimension (LDV, N) */
+/* The unitary matrix on the left-hand side in the */
+/* decomposition. */
+/* Not referenced if ITYPE=2 */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of V. LDV must be at least N and */
+/* at least 1. */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N**2) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESULT (output) REAL */
+/* The values computed by the test specified by ITYPE. The */
+/* value is currently limited to 1/ulp, to avoid overflow. */
+/* Errors are flagged by RESULT=10/ulp. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *result = 0.f;
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Constants */
+
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon") * slamch_("Base");
+
+/* Some Error Checks */
+
+ if (*itype < 1 || *itype > 3) {
+ *result = 10.f / ulp;
+ return 0;
+ }
+
+ if (*itype <= 2) {
+
+/* Tests scaled by the norm(A) */
+
+/* Computing MAX */
+ r__1 = clange_("1", n, n, &a[a_offset], lda, &rwork[1]);
+ anorm = dmax(r__1,unfl);
+
+ if (*itype == 1) {
+
+/* ITYPE=1: Compute W = A - UBV' */
+
+ clacpy_(" ", n, n, &a[a_offset], lda, &work[1], n);
+/* Computing 2nd power */
+ i__1 = *n;
+ cgemm_("N", "N", n, n, n, &c_b2, &u[u_offset], ldu, &b[b_offset],
+ ldb, &c_b1, &work[i__1 * i__1 + 1], n);
+
+ q__1.r = -1.f, q__1.i = -0.f;
+/* Computing 2nd power */
+ i__1 = *n;
+ cgemm_("N", "C", n, n, n, &q__1, &work[i__1 * i__1 + 1], n, &v[
+ v_offset], ldv, &c_b2, &work[1], n);
+
+ } else {
+
+/* ITYPE=2: Compute W = A - B */
+
+ clacpy_(" ", n, n, &b[b_offset], ldb, &work[1], n);
+
+ i__1 = *n;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ i__2 = *n;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ i__3 = jrow + *n * (jcol - 1);
+ i__4 = jrow + *n * (jcol - 1);
+ i__5 = jrow + jcol * a_dim1;
+ q__1.r = work[i__4].r - a[i__5].r, q__1.i = work[i__4].i
+ - a[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L10: */
+ }
+/* L20: */
+ }
+ }
+
+/* Compute norm(W)/ ( ulp*norm(A) ) */
+
+ wnorm = clange_("1", n, n, &work[1], n, &rwork[1]);
+
+ if (anorm > wnorm) {
+ *result = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.f) {
+/* Computing MIN */
+ r__1 = wnorm, r__2 = *n * anorm;
+ *result = dmin(r__1,r__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ r__1 = wnorm / anorm, r__2 = (real) (*n);
+ *result = dmin(r__1,r__2) / (*n * ulp);
+ }
+ }
+
+ } else {
+
+/* Tests not scaled by norm(A) */
+
+/* ITYPE=3: Compute UU' - I */
+
+ cgemm_("N", "C", n, n, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu,
+ &c_b1, &work[1], n);
+
+ i__1 = *n;
+ for (jdiag = 1; jdiag <= i__1; ++jdiag) {
+ i__2 = (*n + 1) * (jdiag - 1) + 1;
+ i__3 = (*n + 1) * (jdiag - 1) + 1;
+ q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i - 0.f;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L30: */
+ }
+
+/* Computing MIN */
+ r__1 = clange_("1", n, n, &work[1], n, &rwork[1]), r__2 = (
+ real) (*n);
+ *result = dmin(r__1,r__2) / (*n * ulp);
+ }
+
+ return 0;
+
+/* End of CGET51 */
+
+} /* cget51_ */
diff --git a/TESTING/EIG/cget52.c b/TESTING/EIG/cget52.c
new file mode 100644
index 0000000..a9afefd
--- /dev/null
+++ b/TESTING/EIG/cget52.c
@@ -0,0 +1,296 @@
+/* cget52.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cget52_(logical *left, integer *n, complex *a, integer *
+ lda, complex *b, integer *ldb, complex *e, integer *lde, complex *
+ alpha, complex *beta, complex *work, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, e_dim1, e_offset, i__1, i__2,
+ i__3;
+ real r__1, r__2, r__3, r__4, r__5, r__6;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer j;
+ real ulp;
+ integer jvec;
+ real temp1;
+ complex betai;
+ real scale, abmax;
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *);
+ real anorm, bnorm, enorm;
+ char trans[1];
+ complex acoeff, bcoeff;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ complex alphai;
+ extern doublereal slamch_(char *);
+ real alfmax, safmin;
+ char normab[1];
+ real safmax, betmax, enrmer, errnrm;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGET52 does an eigenvector check for the generalized eigenvalue */
+/* problem. */
+
+/* The basic test for right eigenvectors is: */
+
+/* | b(i) A E(i) - a(i) B E(i) | */
+/* RESULT(1) = max ------------------------------- */
+/* i n ulp max( |b(i) A|, |a(i) B| ) */
+
+/* using the 1-norm. Here, a(i)/b(i) = w is the i-th generalized */
+/* eigenvalue of A - w B, or, equivalently, b(i)/a(i) = m is the i-th */
+/* generalized eigenvalue of m A - B. */
+
+/* H H _ _ */
+/* For left eigenvectors, A , B , a, and b are used. */
+
+/* CGET52 also tests the normalization of E. Each eigenvector is */
+/* supposed to be normalized so that the maximum "absolute value" */
+/* of its elements is 1, where in this case, "absolute value" */
+/* of a complex value x is |Re(x)| + |Im(x)| ; let us call this */
+/* maximum "absolute value" norm of a vector v M(v). */
+/* if a(i)=b(i)=0, then the eigenvector is set to be the jth coordinate */
+/* vector. The normalization test is: */
+
+/* RESULT(2) = max | M(v(i)) - 1 | / ( n ulp ) */
+/* eigenvectors v(i) */
+
+/* Arguments */
+/* ========= */
+
+/* LEFT (input) LOGICAL */
+/* =.TRUE.: The eigenvectors in the columns of E are assumed */
+/* to be *left* eigenvectors. */
+/* =.FALSE.: The eigenvectors in the columns of E are assumed */
+/* to be *right* eigenvectors. */
+
+/* N (input) INTEGER */
+/* The size of the matrices. If it is zero, CGET52 does */
+/* nothing. It must be at least zero. */
+
+/* A (input) COMPLEX array, dimension (LDA, N) */
+/* The matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least N. */
+
+/* B (input) COMPLEX array, dimension (LDB, N) */
+/* The matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. It must be at least 1 */
+/* and at least N. */
+
+/* E (input) COMPLEX array, dimension (LDE, N) */
+/* The matrix of eigenvectors. It must be O( 1 ). */
+
+/* LDE (input) INTEGER */
+/* The leading dimension of E. It must be at least 1 and at */
+/* least N. */
+
+/* ALPHA (input) COMPLEX array, dimension (N) */
+/* The values a(i) as described above, which, along with b(i), */
+/* define the generalized eigenvalues. */
+
+/* BETA (input) COMPLEX array, dimension (N) */
+/* The values b(i) as described above, which, along with a(i), */
+/* define the generalized eigenvalues. */
+
+/* WORK (workspace) COMPLEX array, dimension (N**2) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The values computed by the test described above. If A E or */
+/* B E is likely to overflow, then RESULT(1:2) is set to */
+/* 10 / ulp. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ e_dim1 = *lde;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ --alpha;
+ --beta;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.f;
+ result[2] = 0.f;
+ if (*n <= 0) {
+ return 0;
+ }
+
+ safmin = slamch_("Safe minimum");
+ safmax = 1.f / safmin;
+ ulp = slamch_("Epsilon") * slamch_("Base");
+
+ if (*left) {
+ *(unsigned char *)trans = 'C';
+ *(unsigned char *)normab = 'I';
+ } else {
+ *(unsigned char *)trans = 'N';
+ *(unsigned char *)normab = 'O';
+ }
+
+/* Norm of A, B, and E: */
+
+/* Computing MAX */
+ r__1 = clange_(normab, n, n, &a[a_offset], lda, &rwork[1]);
+ anorm = dmax(r__1,safmin);
+/* Computing MAX */
+ r__1 = clange_(normab, n, n, &b[b_offset], ldb, &rwork[1]);
+ bnorm = dmax(r__1,safmin);
+/* Computing MAX */
+ r__1 = clange_("O", n, n, &e[e_offset], lde, &rwork[1]);
+ enorm = dmax(r__1,ulp);
+ alfmax = safmax / dmax(1.f,bnorm);
+ betmax = safmax / dmax(1.f,anorm);
+
+/* Compute error matrix. */
+/* Column i = ( b(i) A - a(i) B ) E(i) / max( |a(i) B| |b(i) A| ) */
+
+ i__1 = *n;
+ for (jvec = 1; jvec <= i__1; ++jvec) {
+ i__2 = jvec;
+ alphai.r = alpha[i__2].r, alphai.i = alpha[i__2].i;
+ i__2 = jvec;
+ betai.r = beta[i__2].r, betai.i = beta[i__2].i;
+/* Computing MAX */
+ r__5 = (r__1 = alphai.r, dabs(r__1)) + (r__2 = r_imag(&alphai), dabs(
+ r__2)), r__6 = (r__3 = betai.r, dabs(r__3)) + (r__4 = r_imag(&
+ betai), dabs(r__4));
+ abmax = dmax(r__5,r__6);
+ if ((r__1 = alphai.r, dabs(r__1)) + (r__2 = r_imag(&alphai), dabs(
+ r__2)) > alfmax || (r__3 = betai.r, dabs(r__3)) + (r__4 =
+ r_imag(&betai), dabs(r__4)) > betmax || abmax < 1.f) {
+ scale = 1.f / dmax(abmax,safmin);
+ q__1.r = scale * alphai.r, q__1.i = scale * alphai.i;
+ alphai.r = q__1.r, alphai.i = q__1.i;
+ q__1.r = scale * betai.r, q__1.i = scale * betai.i;
+ betai.r = q__1.r, betai.i = q__1.i;
+ }
+/* Computing MAX */
+ r__5 = ((r__1 = alphai.r, dabs(r__1)) + (r__2 = r_imag(&alphai), dabs(
+ r__2))) * bnorm, r__6 = ((r__3 = betai.r, dabs(r__3)) + (r__4
+ = r_imag(&betai), dabs(r__4))) * anorm, r__5 = max(r__5,r__6);
+ scale = 1.f / dmax(r__5,safmin);
+ q__1.r = scale * betai.r, q__1.i = scale * betai.i;
+ acoeff.r = q__1.r, acoeff.i = q__1.i;
+ q__1.r = scale * alphai.r, q__1.i = scale * alphai.i;
+ bcoeff.r = q__1.r, bcoeff.i = q__1.i;
+ if (*left) {
+ r_cnjg(&q__1, &acoeff);
+ acoeff.r = q__1.r, acoeff.i = q__1.i;
+ r_cnjg(&q__1, &bcoeff);
+ bcoeff.r = q__1.r, bcoeff.i = q__1.i;
+ }
+ cgemv_(trans, n, n, &acoeff, &a[a_offset], lda, &e[jvec * e_dim1 + 1],
+ &c__1, &c_b1, &work[*n * (jvec - 1) + 1], &c__1);
+ q__1.r = -bcoeff.r, q__1.i = -bcoeff.i;
+ cgemv_(trans, n, n, &q__1, &b[b_offset], lda, &e[jvec * e_dim1 + 1], &
+ c__1, &c_b2, &work[*n * (jvec - 1) + 1], &c__1);
+/* L10: */
+ }
+
+ errnrm = clange_("One", n, n, &work[1], n, &rwork[1]) / enorm;
+
+/* Compute RESULT(1) */
+
+ result[1] = errnrm / ulp;
+
+/* Normalization of E: */
+
+ enrmer = 0.f;
+ i__1 = *n;
+ for (jvec = 1; jvec <= i__1; ++jvec) {
+ temp1 = 0.f;
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ i__3 = j + jvec * e_dim1;
+ r__3 = temp1, r__4 = (r__1 = e[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&e[j + jvec * e_dim1]), dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* L20: */
+ }
+/* Computing MAX */
+ r__1 = enrmer, r__2 = temp1 - 1.f;
+ enrmer = dmax(r__1,r__2);
+/* L30: */
+ }
+
+/* Compute RESULT(2) : the normalization error in E. */
+
+ result[2] = enrmer / ((real) (*n) * ulp);
+
+ return 0;
+
+/* End of CGET52 */
+
+} /* cget52_ */
diff --git a/TESTING/EIG/cget54.c b/TESTING/EIG/cget54.c
new file mode 100644
index 0000000..fbaff57
--- /dev/null
+++ b/TESTING/EIG/cget54.c
@@ -0,0 +1,225 @@
+/* cget54.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+
+/* Subroutine */ int cget54_(integer *n, complex *a, integer *lda, complex *b,
+ integer *ldb, complex *s, integer *lds, complex *t, integer *ldt,
+ complex *u, integer *ldu, complex *v, integer *ldv, complex *work,
+ real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, s_dim1, s_offset, t_dim1,
+ t_offset, u_dim1, u_offset, v_dim1, v_offset, i__1;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Local variables */
+ real dum[1], ulp, unfl;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ real wnorm;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *);
+ real abnorm;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGET54 checks a generalized decomposition of the form */
+
+/* A = U*S*V' and B = U*T* V' */
+
+/* where ' means conjugate transpose and U and V are unitary. */
+
+/* Specifically, */
+
+/* RESULT = ||( A - U*S*V', B - U*T*V' )|| / (||( A, B )||*n*ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, SGET54 does nothing. */
+/* It must be at least zero. */
+
+/* A (input) COMPLEX array, dimension (LDA, N) */
+/* The original (unfactored) matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least N. */
+
+/* B (input) COMPLEX array, dimension (LDB, N) */
+/* The original (unfactored) matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. It must be at least 1 */
+/* and at least N. */
+
+/* S (input) COMPLEX array, dimension (LDS, N) */
+/* The factored matrix S. */
+
+/* LDS (input) INTEGER */
+/* The leading dimension of S. It must be at least 1 */
+/* and at least N. */
+
+/* T (input) COMPLEX array, dimension (LDT, N) */
+/* The factored matrix T. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of T. It must be at least 1 */
+/* and at least N. */
+
+/* U (input) COMPLEX array, dimension (LDU, N) */
+/* The orthogonal matrix on the left-hand side in the */
+/* decomposition. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+
+/* V (input) COMPLEX array, dimension (LDV, N) */
+/* The orthogonal matrix on the left-hand side in the */
+/* decomposition. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of V. LDV must be at least N and */
+/* at least 1. */
+
+/* WORK (workspace) COMPLEX array, dimension (3*N**2) */
+
+/* RESULT (output) REAL */
+/* The value RESULT, It is currently limited to 1/ulp, to */
+/* avoid overflow. Errors are flagged by RESULT=10/ulp. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ s_dim1 = *lds;
+ s_offset = 1 + s_dim1;
+ s -= s_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --work;
+
+ /* Function Body */
+ *result = 0.f;
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Constants */
+
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon") * slamch_("Base");
+
+/* compute the norm of (A,B) */
+
+ clacpy_("Full", n, n, &a[a_offset], lda, &work[1], n);
+ clacpy_("Full", n, n, &b[b_offset], ldb, &work[*n * *n + 1], n)
+ ;
+/* Computing MAX */
+ i__1 = *n << 1;
+ r__1 = clange_("1", n, &i__1, &work[1], n, dum);
+ abnorm = dmax(r__1,unfl);
+
+/* Compute W1 = A - U*S*V', and put in the array WORK(1:N*N) */
+
+ clacpy_(" ", n, n, &a[a_offset], lda, &work[1], n);
+ cgemm_("N", "N", n, n, n, &c_b2, &u[u_offset], ldu, &s[s_offset], lds, &
+ c_b1, &work[*n * *n + 1], n);
+
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("N", "C", n, n, n, &q__1, &work[*n * *n + 1], n, &v[v_offset], ldv,
+ &c_b2, &work[1], n);
+
+/* Compute W2 = B - U*T*V', and put in the workarray W(N*N+1:2*N*N) */
+
+ clacpy_(" ", n, n, &b[b_offset], ldb, &work[*n * *n + 1], n);
+ cgemm_("N", "N", n, n, n, &c_b2, &u[u_offset], ldu, &t[t_offset], ldt, &
+ c_b1, &work[(*n << 1) * *n + 1], n);
+
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("N", "C", n, n, n, &q__1, &work[(*n << 1) * *n + 1], n, &v[
+ v_offset], ldv, &c_b2, &work[*n * *n + 1], n);
+
+/* Compute norm(W)/ ( ulp*norm((A,B)) ) */
+
+ i__1 = *n << 1;
+ wnorm = clange_("1", n, &i__1, &work[1], n, dum);
+
+ if (abnorm > wnorm) {
+ *result = wnorm / abnorm / ((*n << 1) * ulp);
+ } else {
+ if (abnorm < 1.f) {
+/* Computing MIN */
+ r__1 = wnorm, r__2 = (*n << 1) * abnorm;
+ *result = dmin(r__1,r__2) / abnorm / ((*n << 1) * ulp);
+ } else {
+/* Computing MIN */
+ r__1 = wnorm / abnorm, r__2 = (real) (*n << 1);
+ *result = dmin(r__1,r__2) / ((*n << 1) * ulp);
+ }
+ }
+
+ return 0;
+
+/* End of CGET54 */
+
+} /* cget54_ */
diff --git a/TESTING/EIG/cglmts.c b/TESTING/EIG/cglmts.c
new file mode 100644
index 0000000..1f48a6e
--- /dev/null
+++ b/TESTING/EIG/cglmts.c
@@ -0,0 +1,203 @@
+/* cglmts.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static complex c_b13 = {-1.f,-0.f};
+static complex c_b15 = {1.f,0.f};
+
+/* Subroutine */ int cglmts_(integer *n, integer *m, integer *p, complex *a,
+ complex *af, integer *lda, complex *b, complex *bf, integer *ldb,
+ complex *d__, complex *df, complex *x, complex *u, complex *work,
+ integer *lwork, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1,
+ bf_offset;
+ real r__1;
+
+ /* Local variables */
+ real eps;
+ integer info;
+ real unfl;
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *);
+ real anorm, bnorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ real dnorm, xnorm, ynorm;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int cggglm_(integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, complex *, complex *,
+ complex *, complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *);
+ extern doublereal scasum_(integer *, complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGLMTS tests CGGGLM - a subroutine for solving the generalized */
+/* linear model problem. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices A and B. N >= 0. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of columns of the matrix B. P >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,M) */
+/* The N-by-M matrix A. */
+
+/* AF (workspace) COMPLEX array, dimension (LDA,M) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF. LDA >= max(M,N). */
+
+/* B (input) COMPLEX array, dimension (LDB,P) */
+/* The N-by-P matrix A. */
+
+/* BF (workspace) COMPLEX array, dimension (LDB,P) */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the arrays B, BF. LDB >= max(P,N). */
+
+/* D (input) COMPLEX array, dimension( N ) */
+/* On input, the left hand side of the GLM. */
+
+/* DF (workspace) COMPLEX array, dimension( N ) */
+
+/* X (output) COMPLEX array, dimension( M ) */
+/* solution vector X in the GLM problem. */
+
+/* U (output) COMPLEX array, dimension( P ) */
+/* solution vector U in the GLM problem. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL */
+/* The test ratio: */
+/* norm( d - A*x - B*u ) */
+/* RESULT = ----------------------------------------- */
+/* (norm(A)+norm(B))*(norm(x)+norm(u))*EPS */
+
+/* ==================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ bf_dim1 = *ldb;
+ bf_offset = 1 + bf_dim1;
+ bf -= bf_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --d__;
+ --df;
+ --x;
+ --u;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+/* Computing MAX */
+ r__1 = clange_("1", n, m, &a[a_offset], lda, &rwork[1]);
+ anorm = dmax(r__1,unfl);
+/* Computing MAX */
+ r__1 = clange_("1", n, p, &b[b_offset], ldb, &rwork[1]);
+ bnorm = dmax(r__1,unfl);
+
+/* Copy the matrices A and B to the arrays AF and BF, */
+/* and the vector D the array DF. */
+
+ clacpy_("Full", n, m, &a[a_offset], lda, &af[af_offset], lda);
+ clacpy_("Full", n, p, &b[b_offset], ldb, &bf[bf_offset], ldb);
+ ccopy_(n, &d__[1], &c__1, &df[1], &c__1);
+
+/* Solve GLM problem */
+
+ cggglm_(n, m, p, &af[af_offset], lda, &bf[bf_offset], ldb, &df[1], &x[1],
+ &u[1], &work[1], lwork, &info);
+
+/* Test the residual for the solution of LSE */
+
+/* norm( d - A*x - B*u ) */
+/* RESULT = ----------------------------------------- */
+/* (norm(A)+norm(B))*(norm(x)+norm(u))*EPS */
+
+ ccopy_(n, &d__[1], &c__1, &df[1], &c__1);
+ cgemv_("No transpose", n, m, &c_b13, &a[a_offset], lda, &x[1], &c__1, &
+ c_b15, &df[1], &c__1);
+
+ cgemv_("No transpose", n, p, &c_b13, &b[b_offset], ldb, &u[1], &c__1, &
+ c_b15, &df[1], &c__1);
+
+ dnorm = scasum_(n, &df[1], &c__1);
+ xnorm = scasum_(m, &x[1], &c__1) + scasum_(p, &u[1], &c__1);
+ ynorm = anorm + bnorm;
+
+ if (xnorm <= 0.f) {
+ *result = 0.f;
+ } else {
+ *result = dnorm / ynorm / xnorm / eps;
+ }
+
+ return 0;
+
+/* End of CGLMTS */
+
+} /* cglmts_ */
diff --git a/TESTING/EIG/cgqrts.c b/TESTING/EIG/cgqrts.c
new file mode 100644
index 0000000..bd1f5e0
--- /dev/null
+++ b/TESTING/EIG/cgqrts.c
@@ -0,0 +1,328 @@
+/* cgqrts.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static complex c_b3 = {-1e10f,0.f};
+static real c_b34 = -1.f;
+static real c_b35 = 1.f;
+
+/* Subroutine */ int cgqrts_(integer *n, integer *m, integer *p, complex *a,
+ complex *af, complex *q, complex *r__, integer *lda, complex *taua,
+ complex *b, complex *bf, complex *z__, complex *t, complex *bwk,
+ integer *ldb, complex *taub, complex *work, integer *lwork, real *
+ rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, r_dim1, r_offset, q_dim1,
+ q_offset, b_dim1, b_offset, bf_dim1, bf_offset, t_dim1, t_offset,
+ z_dim1, z_offset, bwk_dim1, bwk_offset, i__1, i__2;
+ real r__1;
+ complex q__1;
+
+ /* Local variables */
+ real ulp;
+ integer info;
+ real unfl;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), cherk_(char *,
+ char *, integer *, integer *, real *, complex *, integer *, real *
+, complex *, integer *);
+ real resid, anorm, bnorm;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), clanhe_(char *, char *, integer *,
+ complex *, integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int cggqrf_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, complex *,
+ complex *, integer *, integer *), clacpy_(char *, integer *,
+ integer *, complex *, integer *, complex *, integer *),
+ claset_(char *, integer *, integer *, complex *, complex *,
+ complex *, integer *), cungqr_(integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ integer *), cungrq_(integer *, integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGQRTS tests CGGQRF, which computes the GQR factorization of an */
+/* N-by-M matrix A and a N-by-P matrix B: A = Q*R and B = Q*T*Z. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices A and B. N >= 0. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of columns of the matrix B. P >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,M) */
+/* The N-by-M matrix A. */
+
+/* AF (output) COMPLEX array, dimension (LDA,N) */
+/* Details of the GQR factorization of A and B, as returned */
+/* by CGGQRF, see CGGQRF for further details. */
+
+/* Q (output) COMPLEX array, dimension (LDA,N) */
+/* The M-by-M unitary matrix Q. */
+
+/* R (workspace) COMPLEX array, dimension (LDA,MAX(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, R and Q. */
+/* LDA >= max(M,N). */
+
+/* TAUA (output) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by CGGQRF. */
+
+/* B (input) COMPLEX array, dimension (LDB,P) */
+/* On entry, the N-by-P matrix A. */
+
+/* BF (output) COMPLEX array, dimension (LDB,N) */
+/* Details of the GQR factorization of A and B, as returned */
+/* by CGGQRF, see CGGQRF for further details. */
+
+/* Z (output) COMPLEX array, dimension (LDB,P) */
+/* The P-by-P unitary matrix Z. */
+
+/* T (workspace) COMPLEX array, dimension (LDB,max(P,N)) */
+
+/* BWK (workspace) COMPLEX array, dimension (LDB,N) */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the arrays B, BF, Z and T. */
+/* LDB >= max(P,N). */
+
+/* TAUB (output) COMPLEX array, dimension (min(P,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by SGGRQF. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK, LWORK >= max(N,M,P)**2. */
+
+/* RWORK (workspace) REAL array, dimension (max(N,M,P)) */
+
+/* RESULT (output) REAL array, dimension (4) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP) */
+/* RESULT(2) = norm( T*Z - Q'*B ) / (MAX(P,N)*norm(B)*ULP) */
+/* RESULT(3) = norm( I - Q'*Q ) / ( M*ULP ) */
+/* RESULT(4) = norm( I - Z'*Z ) / ( P*ULP ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --taua;
+ bwk_dim1 = *ldb;
+ bwk_offset = 1 + bwk_dim1;
+ bwk -= bwk_offset;
+ t_dim1 = *ldb;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ z_dim1 = *ldb;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ bf_dim1 = *ldb;
+ bf_offset = 1 + bf_dim1;
+ bf -= bf_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --taub;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ ulp = slamch_("Precision");
+ unfl = slamch_("Safe minimum");
+
+/* Copy the matrix A to the array AF. */
+
+ clacpy_("Full", n, m, &a[a_offset], lda, &af[af_offset], lda);
+ clacpy_("Full", n, p, &b[b_offset], ldb, &bf[bf_offset], ldb);
+
+/* Computing MAX */
+ r__1 = clange_("1", n, m, &a[a_offset], lda, &rwork[1]);
+ anorm = dmax(r__1,unfl);
+/* Computing MAX */
+ r__1 = clange_("1", n, p, &b[b_offset], ldb, &rwork[1]);
+ bnorm = dmax(r__1,unfl);
+
+/* Factorize the matrices A and B in the arrays AF and BF. */
+
+ cggqrf_(n, m, p, &af[af_offset], lda, &taua[1], &bf[bf_offset], ldb, &
+ taub[1], &work[1], lwork, &info);
+
+/* Generate the N-by-N matrix Q */
+
+ claset_("Full", n, n, &c_b3, &c_b3, &q[q_offset], lda);
+ i__1 = *n - 1;
+ clacpy_("Lower", &i__1, m, &af[af_dim1 + 2], lda, &q[q_dim1 + 2], lda);
+ i__1 = min(*n,*m);
+ cungqr_(n, n, &i__1, &q[q_offset], lda, &taua[1], &work[1], lwork, &info);
+
+/* Generate the P-by-P matrix Z */
+
+ claset_("Full", p, p, &c_b3, &c_b3, &z__[z_offset], ldb);
+ if (*n <= *p) {
+ if (*n > 0 && *n < *p) {
+ i__1 = *p - *n;
+ clacpy_("Full", n, &i__1, &bf[bf_offset], ldb, &z__[*p - *n + 1 +
+ z_dim1], ldb);
+ }
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ clacpy_("Lower", &i__1, &i__2, &bf[(*p - *n + 1) * bf_dim1 + 2],
+ ldb, &z__[*p - *n + 2 + (*p - *n + 1) * z_dim1], ldb);
+ }
+ } else {
+ if (*p > 1) {
+ i__1 = *p - 1;
+ i__2 = *p - 1;
+ clacpy_("Lower", &i__1, &i__2, &bf[*n - *p + 2 + bf_dim1], ldb, &
+ z__[z_dim1 + 2], ldb);
+ }
+ }
+ i__1 = min(*n,*p);
+ cungrq_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, &
+ info);
+
+/* Copy R */
+
+ claset_("Full", n, m, &c_b1, &c_b1, &r__[r_offset], lda);
+ clacpy_("Upper", n, m, &af[af_offset], lda, &r__[r_offset], lda);
+
+/* Copy T */
+
+ claset_("Full", n, p, &c_b1, &c_b1, &t[t_offset], ldb);
+ if (*n <= *p) {
+ clacpy_("Upper", n, n, &bf[(*p - *n + 1) * bf_dim1 + 1], ldb, &t[(*p
+ - *n + 1) * t_dim1 + 1], ldb);
+ } else {
+ i__1 = *n - *p;
+ clacpy_("Full", &i__1, p, &bf[bf_offset], ldb, &t[t_offset], ldb);
+ clacpy_("Upper", p, p, &bf[*n - *p + 1 + bf_dim1], ldb, &t[*n - *p +
+ 1 + t_dim1], ldb);
+ }
+
+/* Compute R - Q'*A */
+
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("Conjugate transpose", "No transpose", n, m, n, &q__1, &q[q_offset]
+, lda, &a[a_offset], lda, &c_b2, &r__[r_offset], lda);
+
+/* Compute norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP ) . */
+
+ resid = clange_("1", n, m, &r__[r_offset], lda, &rwork[1]);
+ if (anorm > 0.f) {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ result[1] = resid / (real) max(i__1,*n) / anorm / ulp;
+ } else {
+ result[1] = 0.f;
+ }
+
+/* Compute T*Z - Q'*B */
+
+ cgemm_("No Transpose", "No transpose", n, p, p, &c_b2, &t[t_offset], ldb,
+ &z__[z_offset], ldb, &c_b1, &bwk[bwk_offset], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("Conjugate transpose", "No transpose", n, p, n, &q__1, &q[q_offset]
+, lda, &b[b_offset], ldb, &c_b2, &bwk[bwk_offset], ldb);
+
+/* Compute norm( T*Z - Q'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */
+
+ resid = clange_("1", n, p, &bwk[bwk_offset], ldb, &rwork[1]);
+ if (bnorm > 0.f) {
+/* Computing MAX */
+ i__1 = max(1,*p);
+ result[2] = resid / (real) max(i__1,*n) / bnorm / ulp;
+ } else {
+ result[2] = 0.f;
+ }
+
+/* Compute I - Q'*Q */
+
+ claset_("Full", n, n, &c_b1, &c_b2, &r__[r_offset], lda);
+ cherk_("Upper", "Conjugate transpose", n, n, &c_b34, &q[q_offset], lda, &
+ c_b35, &r__[r_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( N * ULP ) . */
+
+ resid = clanhe_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
+ result[3] = resid / (real) max(1,*n) / ulp;
+
+/* Compute I - Z'*Z */
+
+ claset_("Full", p, p, &c_b1, &c_b2, &t[t_offset], ldb);
+ cherk_("Upper", "Conjugate transpose", p, p, &c_b34, &z__[z_offset], ldb,
+ &c_b35, &t[t_offset], ldb);
+
+/* Compute norm( I - Z'*Z ) / ( P*ULP ) . */
+
+ resid = clanhe_("1", "Upper", p, &t[t_offset], ldb, &rwork[1]);
+ result[4] = resid / (real) max(1,*p) / ulp;
+
+ return 0;
+
+/* End of CGQRTS */
+
+} /* cgqrts_ */
diff --git a/TESTING/EIG/cgrqts.c b/TESTING/EIG/cgrqts.c
new file mode 100644
index 0000000..1c9d5e6
--- /dev/null
+++ b/TESTING/EIG/cgrqts.c
@@ -0,0 +1,331 @@
+/* cgrqts.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static complex c_b3 = {-1e10f,0.f};
+static real c_b34 = -1.f;
+static real c_b35 = 1.f;
+
+/* Subroutine */ int cgrqts_(integer *m, integer *p, integer *n, complex *a,
+ complex *af, complex *q, complex *r__, integer *lda, complex *taua,
+ complex *b, complex *bf, complex *z__, complex *t, complex *bwk,
+ integer *ldb, complex *taub, complex *work, integer *lwork, real *
+ rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, r_dim1, r_offset, q_dim1,
+ q_offset, b_dim1, b_offset, bf_dim1, bf_offset, t_dim1, t_offset,
+ z_dim1, z_offset, bwk_dim1, bwk_offset, i__1, i__2;
+ real r__1;
+ complex q__1;
+
+ /* Local variables */
+ real ulp;
+ integer info;
+ real unfl;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), cherk_(char *,
+ char *, integer *, integer *, real *, complex *, integer *, real *
+, complex *, integer *);
+ real resid, anorm, bnorm;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), clanhe_(char *, char *, integer *,
+ complex *, integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int cggrqf_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, complex *,
+ complex *, integer *, integer *), clacpy_(char *, integer *,
+ integer *, complex *, integer *, complex *, integer *),
+ claset_(char *, integer *, integer *, complex *, complex *,
+ complex *, integer *), cungqr_(integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ integer *), cungrq_(integer *, integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGRQTS tests CGGRQF, which computes the GRQ factorization of an */
+/* M-by-N matrix A and a P-by-N matrix B: A = R*Q and B = Z*T*Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The M-by-N matrix A. */
+
+/* AF (output) COMPLEX array, dimension (LDA,N) */
+/* Details of the GRQ factorization of A and B, as returned */
+/* by CGGRQF, see CGGRQF for further details. */
+
+/* Q (output) COMPLEX array, dimension (LDA,N) */
+/* The N-by-N unitary matrix Q. */
+
+/* R (workspace) COMPLEX array, dimension (LDA,MAX(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, R and Q. */
+/* LDA >= max(M,N). */
+
+/* TAUA (output) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by SGGQRC. */
+
+/* B (input) COMPLEX array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix A. */
+
+/* BF (output) COMPLEX array, dimension (LDB,N) */
+/* Details of the GQR factorization of A and B, as returned */
+/* by CGGRQF, see CGGRQF for further details. */
+
+/* Z (output) REAL array, dimension (LDB,P) */
+/* The P-by-P unitary matrix Z. */
+
+/* T (workspace) COMPLEX array, dimension (LDB,max(P,N)) */
+
+/* BWK (workspace) COMPLEX array, dimension (LDB,N) */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the arrays B, BF, Z and T. */
+/* LDB >= max(P,N). */
+
+/* TAUB (output) COMPLEX array, dimension (min(P,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by SGGRQF. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK, LWORK >= max(M,P,N)**2. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (4) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP) */
+/* RESULT(2) = norm( T*Q - Z'*B ) / (MAX(P,N)*norm(B)*ULP) */
+/* RESULT(3) = norm( I - Q'*Q ) / ( N*ULP ) */
+/* RESULT(4) = norm( I - Z'*Z ) / ( P*ULP ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --taua;
+ bwk_dim1 = *ldb;
+ bwk_offset = 1 + bwk_dim1;
+ bwk -= bwk_offset;
+ t_dim1 = *ldb;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ z_dim1 = *ldb;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ bf_dim1 = *ldb;
+ bf_offset = 1 + bf_dim1;
+ bf -= bf_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --taub;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ ulp = slamch_("Precision");
+ unfl = slamch_("Safe minimum");
+
+/* Copy the matrix A to the array AF. */
+
+ clacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+ clacpy_("Full", p, n, &b[b_offset], ldb, &bf[bf_offset], ldb);
+
+/* Computing MAX */
+ r__1 = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ anorm = dmax(r__1,unfl);
+/* Computing MAX */
+ r__1 = clange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
+ bnorm = dmax(r__1,unfl);
+
+/* Factorize the matrices A and B in the arrays AF and BF. */
+
+ cggrqf_(m, p, n, &af[af_offset], lda, &taua[1], &bf[bf_offset], ldb, &
+ taub[1], &work[1], lwork, &info);
+
+/* Generate the N-by-N matrix Q */
+
+ claset_("Full", n, n, &c_b3, &c_b3, &q[q_offset], lda);
+ if (*m <= *n) {
+ if (*m > 0 && *m < *n) {
+ i__1 = *n - *m;
+ clacpy_("Full", m, &i__1, &af[af_offset], lda, &q[*n - *m + 1 +
+ q_dim1], lda);
+ }
+ if (*m > 1) {
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ clacpy_("Lower", &i__1, &i__2, &af[(*n - *m + 1) * af_dim1 + 2],
+ lda, &q[*n - *m + 2 + (*n - *m + 1) * q_dim1], lda);
+ }
+ } else {
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ clacpy_("Lower", &i__1, &i__2, &af[*m - *n + 2 + af_dim1], lda, &
+ q[q_dim1 + 2], lda);
+ }
+ }
+ i__1 = min(*m,*n);
+ cungrq_(n, n, &i__1, &q[q_offset], lda, &taua[1], &work[1], lwork, &info);
+
+/* Generate the P-by-P matrix Z */
+
+ claset_("Full", p, p, &c_b3, &c_b3, &z__[z_offset], ldb);
+ if (*p > 1) {
+ i__1 = *p - 1;
+ clacpy_("Lower", &i__1, n, &bf[bf_dim1 + 2], ldb, &z__[z_dim1 + 2],
+ ldb);
+ }
+ i__1 = min(*p,*n);
+ cungqr_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, &
+ info);
+
+/* Copy R */
+
+ claset_("Full", m, n, &c_b1, &c_b1, &r__[r_offset], lda);
+ if (*m <= *n) {
+ clacpy_("Upper", m, m, &af[(*n - *m + 1) * af_dim1 + 1], lda, &r__[(*
+ n - *m + 1) * r_dim1 + 1], lda);
+ } else {
+ i__1 = *m - *n;
+ clacpy_("Full", &i__1, n, &af[af_offset], lda, &r__[r_offset], lda);
+ clacpy_("Upper", n, n, &af[*m - *n + 1 + af_dim1], lda, &r__[*m - *n
+ + 1 + r_dim1], lda);
+ }
+
+/* Copy T */
+
+ claset_("Full", p, n, &c_b1, &c_b1, &t[t_offset], ldb);
+ clacpy_("Upper", p, n, &bf[bf_offset], ldb, &t[t_offset], ldb);
+
+/* Compute R - A*Q' */
+
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "Conjugate transpose", m, n, n, &q__1, &a[a_offset]
+, lda, &q[q_offset], lda, &c_b2, &r__[r_offset], lda);
+
+/* Compute norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP ) . */
+
+ resid = clange_("1", m, n, &r__[r_offset], lda, &rwork[1]);
+ if (anorm > 0.f) {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ result[1] = resid / (real) max(i__1,*n) / anorm / ulp;
+ } else {
+ result[1] = 0.f;
+ }
+
+/* Compute T*Q - Z'*B */
+
+ cgemm_("Conjugate transpose", "No transpose", p, n, p, &c_b2, &z__[
+ z_offset], ldb, &b[b_offset], ldb, &c_b1, &bwk[bwk_offset], ldb);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "No transpose", p, n, n, &c_b2, &t[t_offset], ldb,
+ &q[q_offset], lda, &q__1, &bwk[bwk_offset], ldb);
+
+/* Compute norm( T*Q - Z'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */
+
+ resid = clange_("1", p, n, &bwk[bwk_offset], ldb, &rwork[1]);
+ if (bnorm > 0.f) {
+/* Computing MAX */
+ i__1 = max(1,*p);
+ result[2] = resid / (real) max(i__1,*m) / bnorm / ulp;
+ } else {
+ result[2] = 0.f;
+ }
+
+/* Compute I - Q*Q' */
+
+ claset_("Full", n, n, &c_b1, &c_b2, &r__[r_offset], lda);
+ cherk_("Upper", "No Transpose", n, n, &c_b34, &q[q_offset], lda, &c_b35, &
+ r__[r_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( N * ULP ) . */
+
+ resid = clanhe_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
+ result[3] = resid / (real) max(1,*n) / ulp;
+
+/* Compute I - Z'*Z */
+
+ claset_("Full", p, p, &c_b1, &c_b2, &t[t_offset], ldb);
+ cherk_("Upper", "Conjugate transpose", p, p, &c_b34, &z__[z_offset], ldb,
+ &c_b35, &t[t_offset], ldb);
+
+/* Compute norm( I - Z'*Z ) / ( P*ULP ) . */
+
+ resid = clanhe_("1", "Upper", p, &t[t_offset], ldb, &rwork[1]);
+ result[4] = resid / (real) max(1,*p) / ulp;
+
+ return 0;
+
+/* End of CGRQTS */
+
+} /* cgrqts_ */
diff --git a/TESTING/EIG/cgsvts.c b/TESTING/EIG/cgsvts.c
new file mode 100644
index 0000000..c4df147
--- /dev/null
+++ b/TESTING/EIG/cgsvts.c
@@ -0,0 +1,417 @@
+/* cgsvts.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static real c_b36 = -1.f;
+static real c_b37 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int cgsvts_(integer *m, integer *p, integer *n, complex *a,
+ complex *af, integer *lda, complex *b, complex *bf, integer *ldb,
+ complex *u, integer *ldu, complex *v, integer *ldv, complex *q,
+ integer *ldq, real *alpha, real *beta, complex *r__, integer *ldr,
+ integer *iwork, complex *work, integer *lwork, real *rwork, real *
+ result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1,
+ bf_offset, q_dim1, q_offset, r_dim1, r_offset, u_dim1, u_offset,
+ v_dim1, v_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1;
+ complex q__1, q__2;
+
+ /* Local variables */
+ integer i__, j, k, l;
+ real ulp;
+ integer info;
+ real unfl, temp;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), cherk_(char *,
+ char *, integer *, integer *, real *, complex *, integer *, real *
+, complex *, integer *);
+ real resid, anorm, bnorm;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), clanhe_(char *, char *, integer *,
+ complex *, integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), cggsvd_(char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, complex *, integer *, complex *,
+ integer *, real *, real *, complex *, integer *, complex *,
+ integer *, complex *, integer *, complex *, real *, integer *,
+ integer *);
+ real ulpinv;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGSVTS tests CGGSVD, which computes the GSVD of an M-by-N matrix A */
+/* and a P-by-N matrix B: */
+/* U'*A*Q = D1*R and V'*B*Q = D2*R. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,M) */
+/* The M-by-N matrix A. */
+
+/* AF (output) COMPLEX array, dimension (LDA,N) */
+/* Details of the GSVD of A and B, as returned by CGGSVD, */
+/* see CGGSVD for further details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A and AF. */
+/* LDA >= max( 1,M ). */
+
+/* B (input) COMPLEX array, dimension (LDB,P) */
+/* On entry, the P-by-N matrix B. */
+
+/* BF (output) COMPLEX array, dimension (LDB,N) */
+/* Details of the GSVD of A and B, as returned by CGGSVD, */
+/* see CGGSVD for further details. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the arrays B and BF. */
+/* LDB >= max(1,P). */
+
+/* U (output) COMPLEX array, dimension(LDU,M) */
+/* The M by M unitary matrix U. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M). */
+
+/* V (output) COMPLEX array, dimension(LDV,M) */
+/* The P by P unitary matrix V. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. LDV >= max(1,P). */
+
+/* Q (output) COMPLEX array, dimension(LDQ,N) */
+/* The N by N unitary matrix Q. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* ALPHA (output) REAL array, dimension (N) */
+/* BETA (output) REAL array, dimension (N) */
+/* The generalized singular value pairs of A and B, the */
+/* ``diagonal'' matrices D1 and D2 are constructed from */
+/* ALPHA and BETA, see subroutine CGGSVD for details. */
+
+/* R (output) COMPLEX array, dimension(LDQ,N) */
+/* The upper triangular matrix R. */
+
+/* LDR (input) INTEGER */
+/* The leading dimension of the array R. LDR >= max(1,N). */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK, */
+/* LWORK >= max(M,P,N)*max(M,P,N). */
+
+/* RWORK (workspace) REAL array, dimension (max(M,P,N)) */
+
+/* RESULT (output) REAL array, dimension (5) */
+/* The test ratios: */
+/* RESULT(1) = norm( U'*A*Q - D1*R ) / ( MAX(M,N)*norm(A)*ULP) */
+/* RESULT(2) = norm( V'*B*Q - D2*R ) / ( MAX(P,N)*norm(B)*ULP) */
+/* RESULT(3) = norm( I - U'*U ) / ( M*ULP ) */
+/* RESULT(4) = norm( I - V'*V ) / ( P*ULP ) */
+/* RESULT(5) = norm( I - Q'*Q ) / ( N*ULP ) */
+/* RESULT(6) = 0 if ALPHA is in decreasing order; */
+/* = ULPINV otherwise. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ bf_dim1 = *ldb;
+ bf_offset = 1 + bf_dim1;
+ bf -= bf_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --alpha;
+ --beta;
+ r_dim1 = *ldr;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ --iwork;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ ulp = slamch_("Precision");
+ ulpinv = 1.f / ulp;
+ unfl = slamch_("Safe minimum");
+
+/* Copy the matrix A to the array AF. */
+
+ clacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+ clacpy_("Full", p, n, &b[b_offset], ldb, &bf[bf_offset], ldb);
+
+/* Computing MAX */
+ r__1 = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ anorm = dmax(r__1,unfl);
+/* Computing MAX */
+ r__1 = clange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
+ bnorm = dmax(r__1,unfl);
+
+/* Factorize the matrices A and B in the arrays AF and BF. */
+
+ cggsvd_("U", "V", "Q", m, n, p, &k, &l, &af[af_offset], lda, &bf[
+ bf_offset], ldb, &alpha[1], &beta[1], &u[u_offset], ldu, &v[
+ v_offset], ldv, &q[q_offset], ldq, &work[1], &rwork[1], &iwork[1],
+ &info);
+
+/* Copy R */
+
+/* Computing MIN */
+ i__2 = k + l;
+ i__1 = min(i__2,*m);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = k + l;
+ for (j = i__; j <= i__2; ++j) {
+ i__3 = i__ + j * r_dim1;
+ i__4 = i__ + (*n - k - l + j) * af_dim1;
+ r__[i__3].r = af[i__4].r, r__[i__3].i = af[i__4].i;
+/* L10: */
+ }
+/* L20: */
+ }
+
+ if (*m - k - l < 0) {
+ i__1 = k + l;
+ for (i__ = *m + 1; i__ <= i__1; ++i__) {
+ i__2 = k + l;
+ for (j = i__; j <= i__2; ++j) {
+ i__3 = i__ + j * r_dim1;
+ i__4 = i__ - k + (*n - k - l + j) * bf_dim1;
+ r__[i__3].r = bf[i__4].r, r__[i__3].i = bf[i__4].i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+/* Compute A:= U'*A*Q - D1*R */
+
+ cgemm_("No transpose", "No transpose", m, n, n, &c_b2, &a[a_offset], lda,
+ &q[q_offset], ldq, &c_b1, &work[1], lda);
+
+ cgemm_("Conjugate transpose", "No transpose", m, n, m, &c_b2, &u[u_offset]
+, ldu, &work[1], lda, &c_b1, &a[a_offset], lda);
+
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = k + l;
+ for (j = i__; j <= i__2; ++j) {
+ i__3 = i__ + (*n - k - l + j) * a_dim1;
+ i__4 = i__ + (*n - k - l + j) * a_dim1;
+ i__5 = i__ + j * r_dim1;
+ q__1.r = a[i__4].r - r__[i__5].r, q__1.i = a[i__4].i - r__[i__5]
+ .i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* Computing MIN */
+ i__2 = k + l;
+ i__1 = min(i__2,*m);
+ for (i__ = k + 1; i__ <= i__1; ++i__) {
+ i__2 = k + l;
+ for (j = i__; j <= i__2; ++j) {
+ i__3 = i__ + (*n - k - l + j) * a_dim1;
+ i__4 = i__ + (*n - k - l + j) * a_dim1;
+ i__5 = i__;
+ i__6 = i__ + j * r_dim1;
+ q__2.r = alpha[i__5] * r__[i__6].r, q__2.i = alpha[i__5] * r__[
+ i__6].i;
+ q__1.r = a[i__4].r - q__2.r, q__1.i = a[i__4].i - q__2.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+
+/* Compute norm( U'*A*Q - D1*R ) / ( MAX(1,M,N)*norm(A)*ULP ) . */
+
+ resid = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ if (anorm > 0.f) {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ result[1] = resid / (real) max(i__1,*n) / anorm / ulp;
+ } else {
+ result[1] = 0.f;
+ }
+
+/* Compute B := V'*B*Q - D2*R */
+
+ cgemm_("No transpose", "No transpose", p, n, n, &c_b2, &b[b_offset], ldb,
+ &q[q_offset], ldq, &c_b1, &work[1], ldb);
+
+ cgemm_("Conjugate transpose", "No transpose", p, n, p, &c_b2, &v[v_offset]
+, ldv, &work[1], ldb, &c_b1, &b[b_offset], ldb);
+
+ i__1 = l;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = l;
+ for (j = i__; j <= i__2; ++j) {
+ i__3 = i__ + (*n - l + j) * b_dim1;
+ i__4 = i__ + (*n - l + j) * b_dim1;
+ i__5 = k + i__;
+ i__6 = k + i__ + (k + j) * r_dim1;
+ q__2.r = beta[i__5] * r__[i__6].r, q__2.i = beta[i__5] * r__[i__6]
+ .i;
+ q__1.r = b[i__4].r - q__2.r, q__1.i = b[i__4].i - q__2.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L90: */
+ }
+/* L100: */
+ }
+
+/* Compute norm( V'*B*Q - D2*R ) / ( MAX(P,N)*norm(B)*ULP ) . */
+
+ resid = clange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
+ if (bnorm > 0.f) {
+/* Computing MAX */
+ i__1 = max(1,*p);
+ result[2] = resid / (real) max(i__1,*n) / bnorm / ulp;
+ } else {
+ result[2] = 0.f;
+ }
+
+/* Compute I - U'*U */
+
+ claset_("Full", m, m, &c_b1, &c_b2, &work[1], ldq);
+ cherk_("Upper", "Conjugate transpose", m, m, &c_b36, &u[u_offset], ldu, &
+ c_b37, &work[1], ldu);
+
+/* Compute norm( I - U'*U ) / ( M * ULP ) . */
+
+ resid = clanhe_("1", "Upper", m, &work[1], ldu, &rwork[1]);
+ result[3] = resid / (real) max(1,*m) / ulp;
+
+/* Compute I - V'*V */
+
+ claset_("Full", p, p, &c_b1, &c_b2, &work[1], ldv);
+ cherk_("Upper", "Conjugate transpose", p, p, &c_b36, &v[v_offset], ldv, &
+ c_b37, &work[1], ldv);
+
+/* Compute norm( I - V'*V ) / ( P * ULP ) . */
+
+ resid = clanhe_("1", "Upper", p, &work[1], ldv, &rwork[1]);
+ result[4] = resid / (real) max(1,*p) / ulp;
+
+/* Compute I - Q'*Q */
+
+ claset_("Full", n, n, &c_b1, &c_b2, &work[1], ldq);
+ cherk_("Upper", "Conjugate transpose", n, n, &c_b36, &q[q_offset], ldq, &
+ c_b37, &work[1], ldq);
+
+/* Compute norm( I - Q'*Q ) / ( N * ULP ) . */
+
+ resid = clanhe_("1", "Upper", n, &work[1], ldq, &rwork[1]);
+ result[5] = resid / (real) max(1,*n) / ulp;
+
+/* Check sorting */
+
+ scopy_(n, &alpha[1], &c__1, &rwork[1], &c__1);
+/* Computing MIN */
+ i__2 = k + l;
+ i__1 = min(i__2,*m);
+ for (i__ = k + 1; i__ <= i__1; ++i__) {
+ j = iwork[i__];
+ if (i__ != j) {
+ temp = rwork[i__];
+ rwork[i__] = rwork[j];
+ rwork[j] = temp;
+ }
+/* L110: */
+ }
+
+ result[6] = 0.f;
+/* Computing MIN */
+ i__2 = k + l;
+ i__1 = min(i__2,*m) - 1;
+ for (i__ = k + 1; i__ <= i__1; ++i__) {
+ if (rwork[i__] < rwork[i__ + 1]) {
+ result[6] = ulpinv;
+ }
+/* L120: */
+ }
+
+ return 0;
+
+/* End of CGSVTS */
+
+} /* cgsvts_ */
diff --git a/TESTING/EIG/chbt21.c b/TESTING/EIG/chbt21.c
new file mode 100644
index 0000000..7d627f2
--- /dev/null
+++ b/TESTING/EIG/chbt21.c
@@ -0,0 +1,305 @@
+/* chbt21.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int chbt21_(char *uplo, integer *n, integer *ka, integer *ks,
+ complex *a, integer *lda, real *d__, real *e, complex *u, integer *
+ ldu, complex *work, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2;
+ complex q__1, q__2;
+
+ /* Local variables */
+ integer j, jc, jr, ika;
+ real ulp;
+ extern /* Subroutine */ int chpr_(char *, integer *, real *, complex *,
+ integer *, complex *);
+ real unfl;
+ extern /* Subroutine */ int chpr2_(char *, integer *, complex *, complex *
+, integer *, complex *, integer *, complex *), cgemm_(
+ char *, char *, integer *, integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, complex *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ real anorm;
+ char cuplo[1];
+ logical lower;
+ real wnorm;
+ extern doublereal clanhb_(char *, char *, integer *, integer *, complex *,
+ integer *, real *), clange_(char *, integer *,
+ integer *, complex *, integer *, real *), clanhp_(char *,
+ char *, integer *, complex *, real *), slamch_(
+ char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHBT21 generally checks a decomposition of the form */
+
+/* A = U S U* */
+
+/* where * means conjugate transpose, A is hermitian banded, U is */
+/* unitary, and S is diagonal (if KS=0) or symmetric */
+/* tridiagonal (if KS=1). */
+
+/* Specifically: */
+
+/* RESULT(1) = | A - U S U* | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU* | / ( n ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER */
+/* If UPLO='U', the upper triangle of A and V will be used and */
+/* the (strictly) lower triangle will not be referenced. */
+/* If UPLO='L', the lower triangle of A and V will be used and */
+/* the (strictly) upper triangle will not be referenced. */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, CHBT21 does nothing. */
+/* It must be at least zero. */
+
+/* KA (input) INTEGER */
+/* The bandwidth of the matrix A. It must be at least zero. If */
+/* it is larger than N-1, then max( 0, N-1 ) will be used. */
+
+/* KS (input) INTEGER */
+/* The bandwidth of the matrix S. It may only be zero or one. */
+/* If zero, then S is diagonal, and E is not referenced. If */
+/* one, then S is symmetric tri-diagonal. */
+
+/* A (input) COMPLEX array, dimension (LDA, N) */
+/* The original (unfactored) matrix. It is assumed to be */
+/* hermitian, and only the upper (UPLO='U') or only the lower */
+/* (UPLO='L') will be referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least min( KA, N-1 ). */
+
+/* D (input) REAL array, dimension (N) */
+/* The diagonal of the (symmetric tri-) diagonal matrix S. */
+
+/* E (input) REAL array, dimension (N-1) */
+/* The off-diagonal of the (symmetric tri-) diagonal matrix S. */
+/* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and */
+/* (3,2) element, etc. */
+/* Not referenced if KS=0. */
+
+/* U (input) COMPLEX array, dimension (LDU, N) */
+/* The unitary matrix in the decomposition, expressed as a */
+/* dense matrix (i.e., not as a product of Householder */
+/* transformations, Givens transformations, etc.) */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+
+/* WORK (workspace) COMPLEX array, dimension (N**2) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Constants */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.f;
+ result[2] = 0.f;
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Computing MAX */
+/* Computing MIN */
+ i__3 = *n - 1;
+ i__1 = 0, i__2 = min(i__3,*ka);
+ ika = max(i__1,i__2);
+
+ if (lsame_(uplo, "U")) {
+ lower = FALSE_;
+ *(unsigned char *)cuplo = 'U';
+ } else {
+ lower = TRUE_;
+ *(unsigned char *)cuplo = 'L';
+ }
+
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon") * slamch_("Base");
+
+/* Some Error Checks */
+
+/* Do Test 1 */
+
+/* Norm of A: */
+
+/* Computing MAX */
+ r__1 = clanhb_("1", cuplo, n, &ika, &a[a_offset], lda, &rwork[1]);
+ anorm = dmax(r__1,unfl);
+
+/* Compute error matrix: Error = A - U S U* */
+
+/* Copy A from SB to SP storage format. */
+
+ j = 0;
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ if (lower) {
+/* Computing MIN */
+ i__3 = ika + 1, i__4 = *n + 1 - jc;
+ i__2 = min(i__3,i__4);
+ for (jr = 1; jr <= i__2; ++jr) {
+ ++j;
+ i__3 = j;
+ i__4 = jr + jc * a_dim1;
+ work[i__3].r = a[i__4].r, work[i__3].i = a[i__4].i;
+/* L10: */
+ }
+ i__2 = *n + 1 - jc;
+ for (jr = ika + 2; jr <= i__2; ++jr) {
+ ++j;
+ i__3 = j;
+ work[i__3].r = 0.f, work[i__3].i = 0.f;
+/* L20: */
+ }
+ } else {
+ i__2 = jc;
+ for (jr = ika + 2; jr <= i__2; ++jr) {
+ ++j;
+ i__3 = j;
+ work[i__3].r = 0.f, work[i__3].i = 0.f;
+/* L30: */
+ }
+/* Computing MIN */
+ i__2 = ika, i__3 = jc - 1;
+ for (jr = min(i__2,i__3); jr >= 0; --jr) {
+ ++j;
+ i__2 = j;
+ i__3 = ika + 1 - jr + jc * a_dim1;
+ work[i__2].r = a[i__3].r, work[i__2].i = a[i__3].i;
+/* L40: */
+ }
+ }
+/* L50: */
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ r__1 = -d__[j];
+ chpr_(cuplo, n, &r__1, &u[j * u_dim1 + 1], &c__1, &work[1])
+ ;
+/* L60: */
+ }
+
+ if (*n > 1 && *ks == 1) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ q__2.r = e[i__2], q__2.i = 0.f;
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ chpr2_(cuplo, n, &q__1, &u[j * u_dim1 + 1], &c__1, &u[(j + 1) *
+ u_dim1 + 1], &c__1, &work[1]);
+/* L70: */
+ }
+ }
+ wnorm = clanhp_("1", cuplo, n, &work[1], &rwork[1]);
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.f) {
+/* Computing MIN */
+ r__1 = wnorm, r__2 = *n * anorm;
+ result[1] = dmin(r__1,r__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ r__1 = wnorm / anorm, r__2 = (real) (*n);
+ result[1] = dmin(r__1,r__2) / (*n * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute UU* - I */
+
+ cgemm_("N", "C", n, n, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu, &
+ c_b1, &work[1], n);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (*n + 1) * (j - 1) + 1;
+ i__3 = (*n + 1) * (j - 1) + 1;
+ q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i - 0.f;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L80: */
+ }
+
+/* Computing MIN */
+ r__1 = clange_("1", n, n, &work[1], n, &rwork[1]), r__2 = (
+ real) (*n);
+ result[2] = dmin(r__1,r__2) / (*n * ulp);
+
+ return 0;
+
+/* End of CHBT21 */
+
+} /* chbt21_ */
diff --git a/TESTING/EIG/chet21.c b/TESTING/EIG/chet21.c
new file mode 100644
index 0000000..634deb6
--- /dev/null
+++ b/TESTING/EIG/chet21.c
@@ -0,0 +1,506 @@
+/* chet21.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int chet21_(integer *itype, char *uplo, integer *n, integer *
+ kband, complex *a, integer *lda, real *d__, real *e, complex *u,
+ integer *ldu, complex *v, integer *ldv, complex *tau, complex *work,
+ real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6;
+ real r__1, r__2;
+ complex q__1, q__2, q__3;
+
+ /* Local variables */
+ integer j, jr;
+ real ulp;
+ extern /* Subroutine */ int cher_(char *, integer *, real *, complex *,
+ integer *, complex *, integer *);
+ integer jcol;
+ real unfl;
+ integer jrow;
+ extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex *
+, integer *, complex *, integer *, complex *, integer *),
+ cgemm_(char *, char *, integer *, integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, complex *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ real anorm;
+ char cuplo[1];
+ complex vsave;
+ logical lower;
+ real wnorm;
+ extern /* Subroutine */ int cunm2l_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *), cunm2r_(char *, char *,
+ integer *, integer *, integer *, complex *, integer *, complex *,
+ complex *, integer *, complex *, integer *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), clanhe_(char *, char *, integer *,
+ complex *, integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), clarfy_(char *, integer *, complex *, integer *, complex
+ *, complex *, integer *, complex *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHET21 generally checks a decomposition of the form */
+
+/* A = U S U* */
+
+/* where * means conjugate transpose, A is hermitian, U is unitary, and */
+/* S is diagonal (if KBAND=0) or (real) symmetric tridiagonal (if */
+/* KBAND=1). */
+
+/* If ITYPE=1, then U is represented as a dense matrix; otherwise U is */
+/* expressed as a product of Householder transformations, whose vectors */
+/* are stored in the array "V" and whose scaling constants are in "TAU". */
+/* We shall use the letter "V" to refer to the product of Householder */
+/* transformations (which should be equal to U). */
+
+/* Specifically, if ITYPE=1, then: */
+
+/* RESULT(1) = | A - U S U* | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU* | / ( n ulp ) */
+
+/* If ITYPE=2, then: */
+
+/* RESULT(1) = | A - V S V* | / ( |A| n ulp ) */
+
+/* If ITYPE=3, then: */
+
+/* RESULT(1) = | I - UV* | / ( n ulp ) */
+
+/* For ITYPE > 1, the transformation U is expressed as a product */
+/* V = H(1)...H(n-2), where H(j) = I - tau(j) v(j) v(j)* and each */
+/* vector v(j) has its first j elements 0 and the remaining n-j elements */
+/* stored in V(j+1:n,j). */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the type of tests to be performed. */
+/* 1: U expressed as a dense unitary matrix: */
+/* RESULT(1) = | A - U S U* | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU* | / ( n ulp ) */
+
+/* 2: U expressed as a product V of Housholder transformations: */
+/* RESULT(1) = | A - V S V* | / ( |A| n ulp ) */
+
+/* 3: U expressed both as a dense unitary matrix and */
+/* as a product of Housholder transformations: */
+/* RESULT(1) = | I - UV* | / ( n ulp ) */
+
+/* UPLO (input) CHARACTER */
+/* If UPLO='U', the upper triangle of A and V will be used and */
+/* the (strictly) lower triangle will not be referenced. */
+/* If UPLO='L', the lower triangle of A and V will be used and */
+/* the (strictly) upper triangle will not be referenced. */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, CHET21 does nothing. */
+/* It must be at least zero. */
+
+/* KBAND (input) INTEGER */
+/* The bandwidth of the matrix. It may only be zero or one. */
+/* If zero, then S is diagonal, and E is not referenced. If */
+/* one, then S is symmetric tri-diagonal. */
+
+/* A (input) COMPLEX array, dimension (LDA, N) */
+/* The original (unfactored) matrix. It is assumed to be */
+/* hermitian, and only the upper (UPLO='U') or only the lower */
+/* (UPLO='L') will be referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least N. */
+
+/* D (input) REAL array, dimension (N) */
+/* The diagonal of the (symmetric tri-) diagonal matrix. */
+
+/* E (input) REAL array, dimension (N-1) */
+/* The off-diagonal of the (symmetric tri-) diagonal matrix. */
+/* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and */
+/* (3,2) element, etc. */
+/* Not referenced if KBAND=0. */
+
+/* U (input) COMPLEX array, dimension (LDU, N) */
+/* If ITYPE=1 or 3, this contains the unitary matrix in */
+/* the decomposition, expressed as a dense matrix. If ITYPE=2, */
+/* then it is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+
+/* V (input) COMPLEX array, dimension (LDV, N) */
+/* If ITYPE=2 or 3, the columns of this array contain the */
+/* Householder vectors used to describe the unitary matrix */
+/* in the decomposition. If UPLO='L', then the vectors are in */
+/* the lower triangle, if UPLO='U', then in the upper */
+/* triangle. */
+/* *NOTE* If ITYPE=2 or 3, V is modified and restored. The */
+/* subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U') */
+/* is set to one, and later reset to its original value, during */
+/* the course of the calculation. */
+/* If ITYPE=1, then it is neither referenced nor modified. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of V. LDV must be at least N and */
+/* at least 1. */
+
+/* TAU (input) COMPLEX array, dimension (N) */
+/* If ITYPE >= 2, then TAU(j) is the scalar factor of */
+/* v(j) v(j)* in the Householder transformation H(j) of */
+/* the product U = H(1)...H(n-2) */
+/* If ITYPE < 2, then TAU is not referenced. */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N**2) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+/* RESULT(1) is always modified. RESULT(2) is modified only */
+/* if ITYPE=1. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.f;
+ if (*itype == 1) {
+ result[2] = 0.f;
+ }
+ if (*n <= 0) {
+ return 0;
+ }
+
+ if (lsame_(uplo, "U")) {
+ lower = FALSE_;
+ *(unsigned char *)cuplo = 'U';
+ } else {
+ lower = TRUE_;
+ *(unsigned char *)cuplo = 'L';
+ }
+
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon") * slamch_("Base");
+
+/* Some Error Checks */
+
+ if (*itype < 1 || *itype > 3) {
+ result[1] = 10.f / ulp;
+ return 0;
+ }
+
+/* Do Test 1 */
+
+/* Norm of A: */
+
+ if (*itype == 3) {
+ anorm = 1.f;
+ } else {
+/* Computing MAX */
+ r__1 = clanhe_("1", cuplo, n, &a[a_offset], lda, &rwork[1]);
+ anorm = dmax(r__1,unfl);
+ }
+
+/* Compute error matrix: */
+
+ if (*itype == 1) {
+
+/* ITYPE=1: error = A - U S U* */
+
+ claset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
+ clacpy_(cuplo, n, n, &a[a_offset], lda, &work[1], n);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ r__1 = -d__[j];
+ cher_(cuplo, n, &r__1, &u[j * u_dim1 + 1], &c__1, &work[1], n);
+/* L10: */
+ }
+
+ if (*n > 1 && *kband == 1) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ q__2.r = e[i__2], q__2.i = 0.f;
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ cher2_(cuplo, n, &q__1, &u[j * u_dim1 + 1], &c__1, &u[(j - 1)
+ * u_dim1 + 1], &c__1, &work[1], n);
+/* L20: */
+ }
+ }
+ wnorm = clanhe_("1", cuplo, n, &work[1], n, &rwork[1]);
+
+ } else if (*itype == 2) {
+
+/* ITYPE=2: error = V S V* - A */
+
+ claset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
+
+ if (lower) {
+/* Computing 2nd power */
+ i__2 = *n;
+ i__1 = i__2 * i__2;
+ i__3 = *n;
+ work[i__1].r = d__[i__3], work[i__1].i = 0.f;
+ for (j = *n - 1; j >= 1; --j) {
+ if (*kband == 1) {
+ i__1 = (*n + 1) * (j - 1) + 2;
+ i__2 = j;
+ q__2.r = 1.f - tau[i__2].r, q__2.i = 0.f - tau[i__2].i;
+ i__3 = j;
+ q__1.r = e[i__3] * q__2.r, q__1.i = e[i__3] * q__2.i;
+ work[i__1].r = q__1.r, work[i__1].i = q__1.i;
+ i__1 = *n;
+ for (jr = j + 2; jr <= i__1; ++jr) {
+ i__2 = (j - 1) * *n + jr;
+ i__3 = j;
+ q__3.r = -tau[i__3].r, q__3.i = -tau[i__3].i;
+ i__4 = j;
+ q__2.r = e[i__4] * q__3.r, q__2.i = e[i__4] * q__3.i;
+ i__5 = jr + j * v_dim1;
+ q__1.r = q__2.r * v[i__5].r - q__2.i * v[i__5].i,
+ q__1.i = q__2.r * v[i__5].i + q__2.i * v[i__5]
+ .r;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L30: */
+ }
+ }
+
+ i__1 = j + 1 + j * v_dim1;
+ vsave.r = v[i__1].r, vsave.i = v[i__1].i;
+ i__1 = j + 1 + j * v_dim1;
+ v[i__1].r = 1.f, v[i__1].i = 0.f;
+ i__1 = *n - j;
+/* Computing 2nd power */
+ i__2 = *n;
+ clarfy_("L", &i__1, &v[j + 1 + j * v_dim1], &c__1, &tau[j], &
+ work[(*n + 1) * j + 1], n, &work[i__2 * i__2 + 1]);
+ i__1 = j + 1 + j * v_dim1;
+ v[i__1].r = vsave.r, v[i__1].i = vsave.i;
+ i__1 = (*n + 1) * (j - 1) + 1;
+ i__2 = j;
+ work[i__1].r = d__[i__2], work[i__1].i = 0.f;
+/* L40: */
+ }
+ } else {
+ work[1].r = d__[1], work[1].i = 0.f;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ if (*kband == 1) {
+ i__2 = (*n + 1) * j;
+ i__3 = j;
+ q__2.r = 1.f - tau[i__3].r, q__2.i = 0.f - tau[i__3].i;
+ i__4 = j;
+ q__1.r = e[i__4] * q__2.r, q__1.i = e[i__4] * q__2.i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ i__2 = j - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = j * *n + jr;
+ i__4 = j;
+ q__3.r = -tau[i__4].r, q__3.i = -tau[i__4].i;
+ i__5 = j;
+ q__2.r = e[i__5] * q__3.r, q__2.i = e[i__5] * q__3.i;
+ i__6 = jr + (j + 1) * v_dim1;
+ q__1.r = q__2.r * v[i__6].r - q__2.i * v[i__6].i,
+ q__1.i = q__2.r * v[i__6].i + q__2.i * v[i__6]
+ .r;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L50: */
+ }
+ }
+
+ i__2 = j + (j + 1) * v_dim1;
+ vsave.r = v[i__2].r, vsave.i = v[i__2].i;
+ i__2 = j + (j + 1) * v_dim1;
+ v[i__2].r = 1.f, v[i__2].i = 0.f;
+/* Computing 2nd power */
+ i__2 = *n;
+ clarfy_("U", &j, &v[(j + 1) * v_dim1 + 1], &c__1, &tau[j], &
+ work[1], n, &work[i__2 * i__2 + 1]);
+ i__2 = j + (j + 1) * v_dim1;
+ v[i__2].r = vsave.r, v[i__2].i = vsave.i;
+ i__2 = (*n + 1) * j + 1;
+ i__3 = j + 1;
+ work[i__2].r = d__[i__3], work[i__2].i = 0.f;
+/* L60: */
+ }
+ }
+
+ i__1 = *n;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ if (lower) {
+ i__2 = *n;
+ for (jrow = jcol; jrow <= i__2; ++jrow) {
+ i__3 = jrow + *n * (jcol - 1);
+ i__4 = jrow + *n * (jcol - 1);
+ i__5 = jrow + jcol * a_dim1;
+ q__1.r = work[i__4].r - a[i__5].r, q__1.i = work[i__4].i
+ - a[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L70: */
+ }
+ } else {
+ i__2 = jcol;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ i__3 = jrow + *n * (jcol - 1);
+ i__4 = jrow + *n * (jcol - 1);
+ i__5 = jrow + jcol * a_dim1;
+ q__1.r = work[i__4].r - a[i__5].r, q__1.i = work[i__4].i
+ - a[i__5].i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L80: */
+ }
+ }
+/* L90: */
+ }
+ wnorm = clanhe_("1", cuplo, n, &work[1], n, &rwork[1]);
+
+ } else if (*itype == 3) {
+
+/* ITYPE=3: error = U V* - I */
+
+ if (*n < 2) {
+ return 0;
+ }
+ clacpy_(" ", n, n, &u[u_offset], ldu, &work[1], n);
+ if (lower) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+/* Computing 2nd power */
+ i__3 = *n;
+ cunm2r_("R", "C", n, &i__1, &i__2, &v[v_dim1 + 2], ldv, &tau[1], &
+ work[*n + 1], n, &work[i__3 * i__3 + 1], &iinfo);
+ } else {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+/* Computing 2nd power */
+ i__3 = *n;
+ cunm2l_("R", "C", n, &i__1, &i__2, &v[(v_dim1 << 1) + 1], ldv, &
+ tau[1], &work[1], n, &work[i__3 * i__3 + 1], &iinfo);
+ }
+ if (iinfo != 0) {
+ result[1] = 10.f / ulp;
+ return 0;
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (*n + 1) * (j - 1) + 1;
+ i__3 = (*n + 1) * (j - 1) + 1;
+ q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i - 0.f;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L100: */
+ }
+
+ wnorm = clange_("1", n, n, &work[1], n, &rwork[1]);
+ }
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.f) {
+/* Computing MIN */
+ r__1 = wnorm, r__2 = *n * anorm;
+ result[1] = dmin(r__1,r__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ r__1 = wnorm / anorm, r__2 = (real) (*n);
+ result[1] = dmin(r__1,r__2) / (*n * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute UU* - I */
+
+ if (*itype == 1) {
+ cgemm_("N", "C", n, n, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu,
+ &c_b1, &work[1], n);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (*n + 1) * (j - 1) + 1;
+ i__3 = (*n + 1) * (j - 1) + 1;
+ q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i - 0.f;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L110: */
+ }
+
+/* Computing MIN */
+ r__1 = clange_("1", n, n, &work[1], n, &rwork[1]), r__2 = (
+ real) (*n);
+ result[2] = dmin(r__1,r__2) / (*n * ulp);
+ }
+
+ return 0;
+
+/* End of CHET21 */
+
+} /* chet21_ */
diff --git a/TESTING/EIG/chet22.c b/TESTING/EIG/chet22.c
new file mode 100644
index 0000000..39b8a1b
--- /dev/null
+++ b/TESTING/EIG/chet22.c
@@ -0,0 +1,292 @@
+/* chet22.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+
+/* Subroutine */ int chet22_(integer *itype, char *uplo, integer *n, integer *
+ m, integer *kband, complex *a, integer *lda, real *d__, real *e,
+ complex *u, integer *ldu, complex *v, integer *ldv, complex *tau,
+ complex *work, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2,
+ i__3, i__4;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Local variables */
+ integer j, jj, nn, jj1, jj2;
+ real ulp;
+ integer nnp1;
+ real unfl;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), chemm_(char *,
+ char *, integer *, integer *, complex *, complex *, integer *,
+ complex *, integer *, complex *, complex *, integer *), cunt01_(char *, integer *, integer *, complex *, integer
+ *, complex *, integer *, real *, real *);
+ real anorm, wnorm;
+ extern doublereal clanhe_(char *, char *, integer *, complex *, integer *,
+ real *), slamch_(char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHET22 generally checks a decomposition of the form */
+
+/* A U = U S */
+
+/* where A is complex Hermitian, the columns of U are orthonormal, */
+/* and S is diagonal (if KBAND=0) or symmetric tridiagonal (if */
+/* KBAND=1). If ITYPE=1, then U is represented as a dense matrix, */
+/* otherwise the U is expressed as a product of Householder */
+/* transformations, whose vectors are stored in the array "V" and */
+/* whose scaling constants are in "TAU"; we shall use the letter */
+/* "V" to refer to the product of Householder transformations */
+/* (which should be equal to U). */
+
+/* Specifically, if ITYPE=1, then: */
+
+/* RESULT(1) = | U' A U - S | / ( |A| m ulp ) *and* */
+/* RESULT(2) = | I - U'U | / ( m ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE INTEGER */
+/* Specifies the type of tests to be performed. */
+/* 1: U expressed as a dense orthogonal matrix: */
+/* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU' | / ( n ulp ) */
+
+/* UPLO CHARACTER */
+/* If UPLO='U', the upper triangle of A will be used and the */
+/* (strictly) lower triangle will not be referenced. If */
+/* UPLO='L', the lower triangle of A will be used and the */
+/* (strictly) upper triangle will not be referenced. */
+/* Not modified. */
+
+/* N INTEGER */
+/* The size of the matrix. If it is zero, CHET22 does nothing. */
+/* It must be at least zero. */
+/* Not modified. */
+
+/* M INTEGER */
+/* The number of columns of U. If it is zero, CHET22 does */
+/* nothing. It must be at least zero. */
+/* Not modified. */
+
+/* KBAND INTEGER */
+/* The bandwidth of the matrix. It may only be zero or one. */
+/* If zero, then S is diagonal, and E is not referenced. If */
+/* one, then S is symmetric tri-diagonal. */
+/* Not modified. */
+
+/* A COMPLEX array, dimension (LDA , N) */
+/* The original (unfactored) matrix. It is assumed to be */
+/* symmetric, and only the upper (UPLO='U') or only the lower */
+/* (UPLO='L') will be referenced. */
+/* Not modified. */
+
+/* LDA INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least N. */
+/* Not modified. */
+
+/* D REAL array, dimension (N) */
+/* The diagonal of the (symmetric tri-) diagonal matrix. */
+/* Not modified. */
+
+/* E REAL array, dimension (N) */
+/* The off-diagonal of the (symmetric tri-) diagonal matrix. */
+/* E(1) is ignored, E(2) is the (1,2) and (2,1) element, etc. */
+/* Not referenced if KBAND=0. */
+/* Not modified. */
+
+/* U COMPLEX array, dimension (LDU, N) */
+/* If ITYPE=1, this contains the orthogonal matrix in */
+/* the decomposition, expressed as a dense matrix. */
+/* Not modified. */
+
+/* LDU INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+/* Not modified. */
+
+/* V COMPLEX array, dimension (LDV, N) */
+/* If ITYPE=2 or 3, the lower triangle of this array contains */
+/* the Householder vectors used to describe the orthogonal */
+/* matrix in the decomposition. If ITYPE=1, then it is not */
+/* referenced. */
+/* Not modified. */
+
+/* LDV INTEGER */
+/* The leading dimension of V. LDV must be at least N and */
+/* at least 1. */
+/* Not modified. */
+
+/* TAU COMPLEX array, dimension (N) */
+/* If ITYPE >= 2, then TAU(j) is the scalar factor of */
+/* v(j) v(j)' in the Householder transformation H(j) of */
+/* the product U = H(1)...H(n-2) */
+/* If ITYPE < 2, then TAU is not referenced. */
+/* Not modified. */
+
+/* WORK COMPLEX array, dimension (2*N**2) */
+/* Workspace. */
+/* Modified. */
+
+/* RWORK REAL array, dimension (N) */
+/* Workspace. */
+/* Modified. */
+
+/* RESULT REAL array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+/* RESULT(1) is always modified. RESULT(2) is modified only */
+/* if LDU is at least N. */
+/* Modified. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.f;
+ result[2] = 0.f;
+ if (*n <= 0 || *m <= 0) {
+ return 0;
+ }
+
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Precision");
+
+/* Do Test 1 */
+
+/* Norm of A: */
+
+/* Computing MAX */
+ r__1 = clanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+ anorm = dmax(r__1,unfl);
+
+/* Compute error matrix: */
+
+/* ITYPE=1: error = U' A U - S */
+
+ chemm_("L", uplo, n, m, &c_b2, &a[a_offset], lda, &u[u_offset], ldu, &
+ c_b1, &work[1], n);
+ nn = *n * *n;
+ nnp1 = nn + 1;
+ cgemm_("C", "N", m, m, n, &c_b2, &u[u_offset], ldu, &work[1], n, &c_b1, &
+ work[nnp1], n);
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ jj = nn + (j - 1) * *n + j;
+ i__2 = jj;
+ i__3 = jj;
+ i__4 = j;
+ q__1.r = work[i__3].r - d__[i__4], q__1.i = work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L10: */
+ }
+ if (*kband == 1 && *n > 1) {
+ i__1 = *m;
+ for (j = 2; j <= i__1; ++j) {
+ jj1 = nn + (j - 1) * *n + j - 1;
+ jj2 = nn + (j - 2) * *n + j;
+ i__2 = jj1;
+ i__3 = jj1;
+ i__4 = j - 1;
+ q__1.r = work[i__3].r - e[i__4], q__1.i = work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ i__2 = jj2;
+ i__3 = jj2;
+ i__4 = j - 1;
+ q__1.r = work[i__3].r - e[i__4], q__1.i = work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L20: */
+ }
+ }
+ wnorm = clanhe_("1", uplo, m, &work[nnp1], n, &rwork[1]);
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*m * ulp);
+ } else {
+ if (anorm < 1.f) {
+/* Computing MIN */
+ r__1 = wnorm, r__2 = *m * anorm;
+ result[1] = dmin(r__1,r__2) / anorm / (*m * ulp);
+ } else {
+/* Computing MIN */
+ r__1 = wnorm / anorm, r__2 = (real) (*m);
+ result[1] = dmin(r__1,r__2) / (*m * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute U'U - I */
+
+ if (*itype == 1) {
+ i__1 = (*n << 1) * *n;
+ cunt01_("Columns", n, m, &u[u_offset], ldu, &work[1], &i__1, &rwork[1]
+, &result[2]);
+ }
+
+ return 0;
+
+/* End of CHET22 */
+
+} /* chet22_ */
diff --git a/TESTING/EIG/chkxer.c b/TESTING/EIG/chkxer.c
new file mode 100644
index 0000000..6de0e7c
--- /dev/null
+++ b/TESTING/EIG/chkxer.c
@@ -0,0 +1,68 @@
+/* chkxer.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+#include "string.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int chkxer_(char *srnamt, integer *infot, integer *nout,
+ logical *lerr, logical *ok)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 *** Illegal value of parameter number"
+ " \002,i2,\002 not detected by \002,a6,\002 ***\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), i_len_trim(
+ char *, ftnlen), e_wsfe(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, fmt_9999, 0 };
+
+ int srnamt_len;
+
+ srnamt_len = strlen(srnamt);
+
+
+
+/* Tests whether XERBLA has detected an error when it should. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ if (! (*lerr)) {
+ io___1.ciunit = *nout;
+ s_wsfe(&io___1);
+ do_fio(&c__1, (char *)&(*infot), (ftnlen)sizeof(integer));
+ do_fio(&c__1, srnamt, i_len_trim(srnamt, srnamt_len));
+ e_wsfe();
+ *ok = FALSE_;
+ }
+ *lerr = FALSE_;
+ return 0;
+
+
+/* End of CHKXER. */
+
+} /* chkxer_ */
diff --git a/TESTING/EIG/chpt21.c b/TESTING/EIG/chpt21.c
new file mode 100644
index 0000000..7830e0a
--- /dev/null
+++ b/TESTING/EIG/chpt21.c
@@ -0,0 +1,532 @@
+/* chpt21.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int chpt21_(integer *itype, char *uplo, integer *n, integer *
+ kband, complex *ap, real *d__, real *e, complex *u, integer *ldu,
+ complex *vp, complex *tau, complex *work, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1, r__2;
+ complex q__1, q__2, q__3;
+
+ /* Local variables */
+ integer j, jp, jr, jp1, lap;
+ real ulp;
+ extern /* Subroutine */ int chpr_(char *, integer *, real *, complex *,
+ integer *, complex *);
+ real unfl;
+ complex temp;
+ extern /* Subroutine */ int chpr2_(char *, integer *, complex *, complex *
+, integer *, complex *, integer *, complex *), cgemm_(
+ char *, char *, integer *, integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, complex *,
+ integer *);
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ real anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), chpmv_(char *, integer *, complex *,
+ complex *, complex *, integer *, complex *, complex *, integer *);
+ char cuplo[1];
+ complex vsave;
+ extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ logical lower;
+ real wnorm;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), clanhp_(char *, char *, integer *,
+ complex *, real *), slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), cupmtr_(char *, char *, char *, integer *, integer *,
+ complex *, complex *, complex *, integer *, complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHPT21 generally checks a decomposition of the form */
+
+/* A = U S U* */
+
+/* where * means conjugate transpose, A is hermitian, U is */
+/* unitary, and S is diagonal (if KBAND=0) or (real) symmetric */
+/* tridiagonal (if KBAND=1). If ITYPE=1, then U is represented as */
+/* a dense matrix, otherwise the U is expressed as a product of */
+/* Householder transformations, whose vectors are stored in the */
+/* array "V" and whose scaling constants are in "TAU"; we shall */
+/* use the letter "V" to refer to the product of Householder */
+/* transformations (which should be equal to U). */
+
+/* Specifically, if ITYPE=1, then: */
+
+/* RESULT(1) = | A - U S U* | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU* | / ( n ulp ) */
+
+/* If ITYPE=2, then: */
+
+/* RESULT(1) = | A - V S V* | / ( |A| n ulp ) */
+
+/* If ITYPE=3, then: */
+
+/* RESULT(1) = | I - UV* | / ( n ulp ) */
+
+/* Packed storage means that, for example, if UPLO='U', then the columns */
+/* of the upper triangle of A are stored one after another, so that */
+/* A(1,j+1) immediately follows A(j,j) in the array AP. Similarly, if */
+/* UPLO='L', then the columns of the lower triangle of A are stored one */
+/* after another in AP, so that A(j+1,j+1) immediately follows A(n,j) */
+/* in the array AP. This means that A(i,j) is stored in: */
+
+/* AP( i + j*(j-1)/2 ) if UPLO='U' */
+
+/* AP( i + (2*n-j)*(j-1)/2 ) if UPLO='L' */
+
+/* The array VP bears the same relation to the matrix V that A does to */
+/* AP. */
+
+/* For ITYPE > 1, the transformation U is expressed as a product */
+/* of Householder transformations: */
+
+/* If UPLO='U', then V = H(n-1)...H(1), where */
+
+/* H(j) = I - tau(j) v(j) v(j)* */
+
+/* and the first j-1 elements of v(j) are stored in V(1:j-1,j+1), */
+/* (i.e., VP( j*(j+1)/2 + 1 : j*(j+1)/2 + j-1 ) ), */
+/* the j-th element is 1, and the last n-j elements are 0. */
+
+/* If UPLO='L', then V = H(1)...H(n-1), where */
+
+/* H(j) = I - tau(j) v(j) v(j)* */
+
+/* and the first j elements of v(j) are 0, the (j+1)-st is 1, and the */
+/* (j+2)-nd through n-th elements are stored in V(j+2:n,j) (i.e., */
+/* in VP( (2*n-j)*(j-1)/2 + j+2 : (2*n-j)*(j-1)/2 + n ) .) */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the type of tests to be performed. */
+/* 1: U expressed as a dense unitary matrix: */
+/* RESULT(1) = | A - U S U* | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU* | / ( n ulp ) */
+
+/* 2: U expressed as a product V of Housholder transformations: */
+/* RESULT(1) = | A - V S V* | / ( |A| n ulp ) */
+
+/* 3: U expressed both as a dense unitary matrix and */
+/* as a product of Housholder transformations: */
+/* RESULT(1) = | I - UV* | / ( n ulp ) */
+
+/* UPLO (input) CHARACTER */
+/* If UPLO='U', the upper triangle of A and V will be used and */
+/* the (strictly) lower triangle will not be referenced. */
+/* If UPLO='L', the lower triangle of A and V will be used and */
+/* the (strictly) upper triangle will not be referenced. */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, CHPT21 does nothing. */
+/* It must be at least zero. */
+
+/* KBAND (input) INTEGER */
+/* The bandwidth of the matrix. It may only be zero or one. */
+/* If zero, then S is diagonal, and E is not referenced. If */
+/* one, then S is symmetric tri-diagonal. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The original (unfactored) matrix. It is assumed to be */
+/* hermitian, and contains the columns of just the upper */
+/* triangle (UPLO='U') or only the lower triangle (UPLO='L'), */
+/* packed one after another. */
+
+/* D (input) REAL array, dimension (N) */
+/* The diagonal of the (symmetric tri-) diagonal matrix. */
+
+/* E (input) REAL array, dimension (N) */
+/* The off-diagonal of the (symmetric tri-) diagonal matrix. */
+/* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and */
+/* (3,2) element, etc. */
+/* Not referenced if KBAND=0. */
+
+/* U (input) COMPLEX array, dimension (LDU, N) */
+/* If ITYPE=1 or 3, this contains the unitary matrix in */
+/* the decomposition, expressed as a dense matrix. If ITYPE=2, */
+/* then it is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+
+/* VP (input) REAL array, dimension (N*(N+1)/2) */
+/* If ITYPE=2 or 3, the columns of this array contain the */
+/* Householder vectors used to describe the unitary matrix */
+/* in the decomposition, as described in purpose. */
+/* *NOTE* If ITYPE=2 or 3, V is modified and restored. The */
+/* subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U') */
+/* is set to one, and later reset to its original value, during */
+/* the course of the calculation. */
+/* If ITYPE=1, then it is neither referenced nor modified. */
+
+/* TAU (input) COMPLEX array, dimension (N) */
+/* If ITYPE >= 2, then TAU(j) is the scalar factor of */
+/* v(j) v(j)* in the Householder transformation H(j) of */
+/* the product U = H(1)...H(n-2) */
+/* If ITYPE < 2, then TAU is not referenced. */
+
+/* WORK (workspace) COMPLEX array, dimension (N**2) */
+/* Workspace. */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+/* Workspace. */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+/* RESULT(1) is always modified. RESULT(2) is modified only */
+/* if ITYPE=1. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Constants */
+
+ /* Parameter adjustments */
+ --ap;
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --vp;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.f;
+ if (*itype == 1) {
+ result[2] = 0.f;
+ }
+ if (*n <= 0) {
+ return 0;
+ }
+
+ lap = *n * (*n + 1) / 2;
+
+ if (lsame_(uplo, "U")) {
+ lower = FALSE_;
+ *(unsigned char *)cuplo = 'U';
+ } else {
+ lower = TRUE_;
+ *(unsigned char *)cuplo = 'L';
+ }
+
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon") * slamch_("Base");
+
+/* Some Error Checks */
+
+ if (*itype < 1 || *itype > 3) {
+ result[1] = 10.f / ulp;
+ return 0;
+ }
+
+/* Do Test 1 */
+
+/* Norm of A: */
+
+ if (*itype == 3) {
+ anorm = 1.f;
+ } else {
+/* Computing MAX */
+ r__1 = clanhp_("1", cuplo, n, &ap[1], &rwork[1])
+ ;
+ anorm = dmax(r__1,unfl);
+ }
+
+/* Compute error matrix: */
+
+ if (*itype == 1) {
+
+/* ITYPE=1: error = A - U S U* */
+
+ claset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
+ ccopy_(&lap, &ap[1], &c__1, &work[1], &c__1);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ r__1 = -d__[j];
+ chpr_(cuplo, n, &r__1, &u[j * u_dim1 + 1], &c__1, &work[1]);
+/* L10: */
+ }
+
+ if (*n > 1 && *kband == 1) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ q__2.r = e[i__2], q__2.i = 0.f;
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ chpr2_(cuplo, n, &q__1, &u[j * u_dim1 + 1], &c__1, &u[(j - 1)
+ * u_dim1 + 1], &c__1, &work[1]);
+/* L20: */
+ }
+ }
+ wnorm = clanhp_("1", cuplo, n, &work[1], &rwork[1]);
+
+ } else if (*itype == 2) {
+
+/* ITYPE=2: error = V S V* - A */
+
+ claset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
+
+ if (lower) {
+ i__1 = lap;
+ i__2 = *n;
+ work[i__1].r = d__[i__2], work[i__1].i = 0.f;
+ for (j = *n - 1; j >= 1; --j) {
+ jp = ((*n << 1) - j) * (j - 1) / 2;
+ jp1 = jp + *n - j;
+ if (*kband == 1) {
+ i__1 = jp + j + 1;
+ i__2 = j;
+ q__2.r = 1.f - tau[i__2].r, q__2.i = 0.f - tau[i__2].i;
+ i__3 = j;
+ q__1.r = e[i__3] * q__2.r, q__1.i = e[i__3] * q__2.i;
+ work[i__1].r = q__1.r, work[i__1].i = q__1.i;
+ i__1 = *n;
+ for (jr = j + 2; jr <= i__1; ++jr) {
+ i__2 = jp + jr;
+ i__3 = j;
+ q__3.r = -tau[i__3].r, q__3.i = -tau[i__3].i;
+ i__4 = j;
+ q__2.r = e[i__4] * q__3.r, q__2.i = e[i__4] * q__3.i;
+ i__5 = jp + jr;
+ q__1.r = q__2.r * vp[i__5].r - q__2.i * vp[i__5].i,
+ q__1.i = q__2.r * vp[i__5].i + q__2.i * vp[
+ i__5].r;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L30: */
+ }
+ }
+
+ i__1 = j;
+ if (tau[i__1].r != 0.f || tau[i__1].i != 0.f) {
+ i__1 = jp + j + 1;
+ vsave.r = vp[i__1].r, vsave.i = vp[i__1].i;
+ i__1 = jp + j + 1;
+ vp[i__1].r = 1.f, vp[i__1].i = 0.f;
+ i__1 = *n - j;
+ chpmv_("L", &i__1, &c_b2, &work[jp1 + j + 1], &vp[jp + j
+ + 1], &c__1, &c_b1, &work[lap + 1], &c__1);
+ i__1 = j;
+ q__2.r = tau[i__1].r * -.5f, q__2.i = tau[i__1].i * -.5f;
+ i__2 = *n - j;
+ cdotc_(&q__3, &i__2, &work[lap + 1], &c__1, &vp[jp + j +
+ 1], &c__1);
+ q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i =
+ q__2.r * q__3.i + q__2.i * q__3.r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ i__1 = *n - j;
+ caxpy_(&i__1, &temp, &vp[jp + j + 1], &c__1, &work[lap +
+ 1], &c__1);
+ i__1 = *n - j;
+ i__2 = j;
+ q__1.r = -tau[i__2].r, q__1.i = -tau[i__2].i;
+ chpr2_("L", &i__1, &q__1, &vp[jp + j + 1], &c__1, &work[
+ lap + 1], &c__1, &work[jp1 + j + 1]);
+
+ i__1 = jp + j + 1;
+ vp[i__1].r = vsave.r, vp[i__1].i = vsave.i;
+ }
+ i__1 = jp + j;
+ i__2 = j;
+ work[i__1].r = d__[i__2], work[i__1].i = 0.f;
+/* L40: */
+ }
+ } else {
+ work[1].r = d__[1], work[1].i = 0.f;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ jp = j * (j - 1) / 2;
+ jp1 = jp + j;
+ if (*kband == 1) {
+ i__2 = jp1 + j;
+ i__3 = j;
+ q__2.r = 1.f - tau[i__3].r, q__2.i = 0.f - tau[i__3].i;
+ i__4 = j;
+ q__1.r = e[i__4] * q__2.r, q__1.i = e[i__4] * q__2.i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ i__2 = j - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = jp1 + jr;
+ i__4 = j;
+ q__3.r = -tau[i__4].r, q__3.i = -tau[i__4].i;
+ i__5 = j;
+ q__2.r = e[i__5] * q__3.r, q__2.i = e[i__5] * q__3.i;
+ i__6 = jp1 + jr;
+ q__1.r = q__2.r * vp[i__6].r - q__2.i * vp[i__6].i,
+ q__1.i = q__2.r * vp[i__6].i + q__2.i * vp[
+ i__6].r;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L50: */
+ }
+ }
+
+ i__2 = j;
+ if (tau[i__2].r != 0.f || tau[i__2].i != 0.f) {
+ i__2 = jp1 + j;
+ vsave.r = vp[i__2].r, vsave.i = vp[i__2].i;
+ i__2 = jp1 + j;
+ vp[i__2].r = 1.f, vp[i__2].i = 0.f;
+ chpmv_("U", &j, &c_b2, &work[1], &vp[jp1 + 1], &c__1, &
+ c_b1, &work[lap + 1], &c__1);
+ i__2 = j;
+ q__2.r = tau[i__2].r * -.5f, q__2.i = tau[i__2].i * -.5f;
+ cdotc_(&q__3, &j, &work[lap + 1], &c__1, &vp[jp1 + 1], &
+ c__1);
+ q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i =
+ q__2.r * q__3.i + q__2.i * q__3.r;
+ temp.r = q__1.r, temp.i = q__1.i;
+ caxpy_(&j, &temp, &vp[jp1 + 1], &c__1, &work[lap + 1], &
+ c__1);
+ i__2 = j;
+ q__1.r = -tau[i__2].r, q__1.i = -tau[i__2].i;
+ chpr2_("U", &j, &q__1, &vp[jp1 + 1], &c__1, &work[lap + 1]
+, &c__1, &work[1]);
+ i__2 = jp1 + j;
+ vp[i__2].r = vsave.r, vp[i__2].i = vsave.i;
+ }
+ i__2 = jp1 + j + 1;
+ i__3 = j + 1;
+ work[i__2].r = d__[i__3], work[i__2].i = 0.f;
+/* L60: */
+ }
+ }
+
+ i__1 = lap;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ i__3 = j;
+ i__4 = j;
+ q__1.r = work[i__3].r - ap[i__4].r, q__1.i = work[i__3].i - ap[
+ i__4].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L70: */
+ }
+ wnorm = clanhp_("1", cuplo, n, &work[1], &rwork[1]);
+
+ } else if (*itype == 3) {
+
+/* ITYPE=3: error = U V* - I */
+
+ if (*n < 2) {
+ return 0;
+ }
+ clacpy_(" ", n, n, &u[u_offset], ldu, &work[1], n);
+/* Computing 2nd power */
+ i__1 = *n;
+ cupmtr_("R", cuplo, "C", n, n, &vp[1], &tau[1], &work[1], n, &work[
+ i__1 * i__1 + 1], &iinfo);
+ if (iinfo != 0) {
+ result[1] = 10.f / ulp;
+ return 0;
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (*n + 1) * (j - 1) + 1;
+ i__3 = (*n + 1) * (j - 1) + 1;
+ q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i - 0.f;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L80: */
+ }
+
+ wnorm = clange_("1", n, n, &work[1], n, &rwork[1]);
+ }
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.f) {
+/* Computing MIN */
+ r__1 = wnorm, r__2 = *n * anorm;
+ result[1] = dmin(r__1,r__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ r__1 = wnorm / anorm, r__2 = (real) (*n);
+ result[1] = dmin(r__1,r__2) / (*n * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute UU* - I */
+
+ if (*itype == 1) {
+ cgemm_("N", "C", n, n, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu,
+ &c_b1, &work[1], n);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (*n + 1) * (j - 1) + 1;
+ i__3 = (*n + 1) * (j - 1) + 1;
+ q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i - 0.f;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L90: */
+ }
+
+/* Computing MIN */
+ r__1 = clange_("1", n, n, &work[1], n, &rwork[1]), r__2 = (
+ real) (*n);
+ result[2] = dmin(r__1,r__2) / (*n * ulp);
+ }
+
+ return 0;
+
+/* End of CHPT21 */
+
+} /* chpt21_ */
diff --git a/TESTING/EIG/chst01.c b/TESTING/EIG/chst01.c
new file mode 100644
index 0000000..1350d8d
--- /dev/null
+++ b/TESTING/EIG/chst01.c
@@ -0,0 +1,196 @@
+/* chst01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b7 = {1.f,0.f};
+static complex c_b8 = {0.f,0.f};
+static complex c_b11 = {-1.f,0.f};
+
+/* Subroutine */ int chst01_(integer *n, integer *ilo, integer *ihi, complex *
+ a, integer *lda, complex *h__, integer *ldh, complex *q, integer *ldq,
+ complex *work, integer *lwork, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, q_dim1, q_offset;
+ real r__1, r__2;
+
+ /* Local variables */
+ real eps, unfl, ovfl;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), cunt01_(char *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ real *, real *);
+ real anorm, wnorm;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *);
+ integer ldwork;
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHST01 tests the reduction of a general matrix A to upper Hessenberg */
+/* form: A = Q*H*Q'. Two test ratios are computed; */
+
+/* RESULT(1) = norm( A - Q*H*Q' ) / ( norm(A) * N * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( N * EPS ) */
+
+/* The matrix Q is assumed to be given explicitly as it would be */
+/* following CGEHRD + CUNGHR. */
+
+/* In this version, ILO and IHI are not used, but they could be used */
+/* to save some work if this is desired. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* A is assumed to be upper triangular in rows and columns */
+/* 1:ILO-1 and IHI+1:N, so Q differs from the identity only in */
+/* rows and columns ILO+1:IHI. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The original n by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* H (input) COMPLEX array, dimension (LDH,N) */
+/* The upper Hessenberg matrix H from the reduction A = Q*H*Q' */
+/* as computed by CGEHRD. H is assumed to be zero below the */
+/* first subdiagonal. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH >= max(1,N). */
+
+/* Q (input) COMPLEX array, dimension (LDQ,N) */
+/* The orthogonal matrix Q from the reduction A = Q*H*Q' as */
+/* computed by CGEHRD + CUNGHR. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= 2*N*N. */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* RESULT(1) = norm( A - Q*H*Q' ) / ( norm(A) * N * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( N * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ if (*n <= 0) {
+ result[1] = 0.f;
+ result[2] = 0.f;
+ return 0;
+ }
+
+ unfl = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ ovfl = 1.f / unfl;
+ slabad_(&unfl, &ovfl);
+ smlnum = unfl * *n / eps;
+
+/* Test 1: Compute norm( A - Q*H*Q' ) / ( norm(A) * N * EPS ) */
+
+/* Copy A to WORK */
+
+ ldwork = max(1,*n);
+ clacpy_(" ", n, n, &a[a_offset], lda, &work[1], &ldwork);
+
+/* Compute Q*H */
+
+ cgemm_("No transpose", "No transpose", n, n, n, &c_b7, &q[q_offset], ldq,
+ &h__[h_offset], ldh, &c_b8, &work[ldwork * *n + 1], &ldwork);
+
+/* Compute A - Q*H*Q' */
+
+ cgemm_("No transpose", "Conjugate transpose", n, n, n, &c_b11, &work[
+ ldwork * *n + 1], &ldwork, &q[q_offset], ldq, &c_b7, &work[1], &
+ ldwork);
+
+/* Computing MAX */
+ r__1 = clange_("1", n, n, &a[a_offset], lda, &rwork[1]);
+ anorm = dmax(r__1,unfl);
+ wnorm = clange_("1", n, n, &work[1], &ldwork, &rwork[1]);
+
+/* Note that RESULT(1) cannot overflow and is bounded by 1/(N*EPS) */
+
+/* Computing MAX */
+ r__1 = smlnum, r__2 = anorm * eps;
+ result[1] = dmin(wnorm,anorm) / dmax(r__1,r__2) / *n;
+
+/* Test 2: Compute norm( I - Q'*Q ) / ( N * EPS ) */
+
+ cunt01_("Columns", n, n, &q[q_offset], ldq, &work[1], lwork, &rwork[1], &
+ result[2]);
+
+ return 0;
+
+/* End of CHST01 */
+
+} /* chst01_ */
diff --git a/TESTING/EIG/clarfy.c b/TESTING/EIG/clarfy.c
new file mode 100644
index 0000000..0563619
--- /dev/null
+++ b/TESTING/EIG/clarfy.c
@@ -0,0 +1,143 @@
+/* clarfy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static complex c_b2 = {0.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int clarfy_(char *uplo, integer *n, complex *v, integer *
+ incv, complex *tau, complex *c__, integer *ldc, complex *work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Local variables */
+ extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex *
+, integer *, complex *, integer *, complex *, integer *);
+ complex alpha;
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern /* Subroutine */ int chemv_(char *, integer *, complex *, complex *
+, integer *, complex *, integer *, complex *, complex *, integer *
+), caxpy_(integer *, complex *, complex *, integer *,
+ complex *, integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLARFY applies an elementary reflector, or Householder matrix, H, */
+/* to an n x n Hermitian matrix C, from both the left and the right. */
+
+/* H is represented in the form */
+
+/* H = I - tau * v * v' */
+
+/* where tau is a scalar and v is a vector. */
+
+/* If tau is zero, then H is taken to be the unit matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix C is stored. */
+/* = 'U': Upper triangle */
+/* = 'L': Lower triangle */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix C. N >= 0. */
+
+/* V (input) COMPLEX array, dimension */
+/* (1 + (N-1)*abs(INCV)) */
+/* The vector v as described above. */
+
+/* INCV (input) INTEGER */
+/* The increment between successive elements of v. INCV must */
+/* not be zero. */
+
+/* TAU (input) COMPLEX */
+/* The value tau as described above. */
+
+/* C (input/output) COMPLEX array, dimension (LDC, N) */
+/* On entry, the matrix C. */
+/* On exit, C is overwritten by H * C * H'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max( 1, N ). */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ if (tau->r == 0.f && tau->i == 0.f) {
+ return 0;
+ }
+
+/* Form w:= C * v */
+
+ chemv_(uplo, n, &c_b1, &c__[c_offset], ldc, &v[1], incv, &c_b2, &work[1],
+ &c__1);
+
+ q__3.r = -.5f, q__3.i = -0.f;
+ q__2.r = q__3.r * tau->r - q__3.i * tau->i, q__2.i = q__3.r * tau->i +
+ q__3.i * tau->r;
+ cdotc_(&q__4, n, &work[1], &c__1, &v[1], incv);
+ q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i +
+ q__2.i * q__4.r;
+ alpha.r = q__1.r, alpha.i = q__1.i;
+ caxpy_(n, &alpha, &v[1], incv, &work[1], &c__1);
+
+/* C := C - v * w' - w * v' */
+
+ q__1.r = -tau->r, q__1.i = -tau->i;
+ cher2_(uplo, n, &q__1, &v[1], incv, &work[1], &c__1, &c__[c_offset], ldc);
+
+ return 0;
+
+/* End of CLARFY */
+
+} /* clarfy_ */
diff --git a/TESTING/EIG/clarhs.c b/TESTING/EIG/clarhs.c
new file mode 100644
index 0000000..b7af2e9
--- /dev/null
+++ b/TESTING/EIG/clarhs.c
@@ -0,0 +1,433 @@
+/* clarhs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static complex c_b2 = {0.f,0.f};
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* Subroutine */ int clarhs_(char *path, char *xtype, char *uplo, char *trans,
+ integer *m, integer *n, integer *kl, integer *ku, integer *nrhs,
+ complex *a, integer *lda, complex *x, integer *ldx, complex *b,
+ integer *ldb, integer *iseed, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j;
+ char c1[1], c2[2];
+ integer mb, nx;
+ logical gen, tri, qrs, sym, band;
+ char diag[1];
+ logical tran;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), chemm_(char *,
+ char *, integer *, integer *, complex *, complex *, integer *,
+ complex *, integer *, complex *, complex *, integer *), cgbmv_(char *, integer *, integer *, integer *, integer *
+, complex *, complex *, integer *, complex *, integer *, complex *
+, complex *, integer *), chbmv_(char *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int csbmv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *), ctbmv_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *), chpmv_(char *, integer *, complex *, complex *,
+ complex *, integer *, complex *, complex *, integer *),
+ ctrmm_(char *, char *, char *, char *, integer *, integer *,
+ complex *, complex *, integer *, complex *, integer *), cspmv_(char *, integer *, complex *,
+ complex *, complex *, integer *, complex *, complex *, integer *), csymm_(char *, char *, integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, complex *,
+ integer *), ctpmv_(char *, char *, char *,
+ integer *, complex *, complex *, integer *), clacpy_(char *, integer *, integer *, complex *, integer
+ *, complex *, integer *), xerbla_(char *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int clarnv_(integer *, integer *, integer *,
+ complex *);
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLARHS chooses a set of NRHS random solution vectors and sets */
+/* up the right hand sides for the linear system */
+/* op( A ) * X = B, */
+/* where op( A ) may be A, A**T (transpose of A), or A**H (conjugate */
+/* transpose of A). */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The type of the complex matrix A. PATH may be given in any */
+/* combination of upper and lower case. Valid paths include */
+/* xGE: General m x n matrix */
+/* xGB: General banded matrix */
+/* xPO: Hermitian positive definite, 2-D storage */
+/* xPP: Hermitian positive definite packed */
+/* xPB: Hermitian positive definite banded */
+/* xHE: Hermitian indefinite, 2-D storage */
+/* xHP: Hermitian indefinite packed */
+/* xHB: Hermitian indefinite banded */
+/* xSY: Symmetric indefinite, 2-D storage */
+/* xSP: Symmetric indefinite packed */
+/* xSB: Symmetric indefinite banded */
+/* xTR: Triangular */
+/* xTP: Triangular packed */
+/* xTB: Triangular banded */
+/* xQR: General m x n matrix */
+/* xLQ: General m x n matrix */
+/* xQL: General m x n matrix */
+/* xRQ: General m x n matrix */
+/* where the leading character indicates the precision. */
+
+/* XTYPE (input) CHARACTER*1 */
+/* Specifies how the exact solution X will be determined: */
+/* = 'N': New solution; generate a random X. */
+/* = 'C': Computed; use value of X on entry. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Used only if A is symmetric or triangular; specifies whether */
+/* the upper or lower triangular part of the matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Used only if A is nonsymmetric; specifies the operation */
+/* applied to the matrix A. */
+/* = 'N': B := A * X */
+/* = 'T': B := A**T * X */
+/* = 'C': B := A**H * X */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* Used only if A is a band matrix; specifies the number of */
+/* subdiagonals of A if A is a general band matrix or if A is */
+/* symmetric or triangular and UPLO = 'L'; specifies the number */
+/* of superdiagonals of A if A is symmetric or triangular and */
+/* UPLO = 'U'. 0 <= KL <= M-1. */
+
+/* KU (input) INTEGER */
+/* Used only if A is a general band matrix or if A is */
+/* triangular. */
+
+/* If PATH = xGB, specifies the number of superdiagonals of A, */
+/* and 0 <= KU <= N-1. */
+
+/* If PATH = xTR, xTP, or xTB, specifies whether or not the */
+/* matrix has unit diagonal: */
+/* = 1: matrix has non-unit diagonal (default) */
+/* = 2: matrix has unit diagonal */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors in the system A*X = B. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The test matrix whose type is given by PATH. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If PATH = xGB, LDA >= KL+KU+1. */
+/* If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1. */
+/* Otherwise, LDA >= max(1,M). */
+
+/* X (input or output) COMPLEX array, dimension (LDX,NRHS) */
+/* On entry, if XTYPE = 'C' (for 'Computed'), then X contains */
+/* the exact solution to the system of linear equations. */
+/* On exit, if XTYPE = 'N' (for 'New'), then X is initialized */
+/* with random values. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M). */
+
+/* B (output) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side vector(s) for the system of equations, */
+/* computed from B = op(A) * X, where op(A) is determined by */
+/* TRANS. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. If TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N). */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* The seed vector for the random number generator (used in */
+/* CLATMS). Modified on exit. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --iseed;
+
+ /* Function Body */
+ *info = 0;
+ *(unsigned char *)c1 = *(unsigned char *)path;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ tran = lsame_(trans, "T") || lsame_(trans, "C");
+ notran = ! tran;
+ gen = lsame_(path + 1, "G");
+ qrs = lsame_(path + 1, "Q") || lsame_(path + 2,
+ "Q");
+ sym = lsame_(path + 1, "P") || lsame_(path + 1,
+ "S") || lsame_(path + 1, "H");
+ tri = lsame_(path + 1, "T");
+ band = lsame_(path + 2, "B");
+ if (! lsame_(c1, "Complex precision")) {
+ *info = -1;
+ } else if (! (lsame_(xtype, "N") || lsame_(xtype,
+ "C"))) {
+ *info = -2;
+ } else if ((sym || tri) && ! (lsame_(uplo, "U") ||
+ lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if ((gen || qrs) && ! (tran || lsame_(trans, "N"))) {
+ *info = -4;
+ } else if (*m < 0) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (band && *kl < 0) {
+ *info = -7;
+ } else if (band && *ku < 0) {
+ *info = -8;
+ } else if (*nrhs < 0) {
+ *info = -9;
+ } else if (! band && *lda < max(1,*m) || band && (sym || tri) && *lda < *
+ kl + 1 || band && gen && *lda < *kl + *ku + 1) {
+ *info = -11;
+ } else if (notran && *ldx < max(1,*n) || tran && *ldx < max(1,*m)) {
+ *info = -13;
+ } else if (notran && *ldb < max(1,*m) || tran && *ldb < max(1,*n)) {
+ *info = -15;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLARHS", &i__1);
+ return 0;
+ }
+
+/* Initialize X to NRHS random vectors unless XTYPE = 'C'. */
+
+ if (tran) {
+ nx = *m;
+ mb = *n;
+ } else {
+ nx = *n;
+ mb = *m;
+ }
+ if (! lsame_(xtype, "C")) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ clarnv_(&c__2, &iseed[1], n, &x[j * x_dim1 + 1]);
+/* L10: */
+ }
+ }
+
+/* Multiply X by op( A ) using an appropriate */
+/* matrix multiply routine. */
+
+ if (lsamen_(&c__2, c2, "GE") || lsamen_(&c__2, c2,
+ "QR") || lsamen_(&c__2, c2, "LQ") || lsamen_(&c__2, c2, "QL") ||
+ lsamen_(&c__2, c2, "RQ")) {
+
+/* General matrix */
+
+ cgemm_(trans, "N", &mb, nrhs, &nx, &c_b1, &a[a_offset], lda, &x[
+ x_offset], ldx, &c_b2, &b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "PO") || lsamen_(&
+ c__2, c2, "HE")) {
+
+/* Hermitian matrix, 2-D storage */
+
+ chemm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset],
+ ldx, &c_b2, &b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "SY")) {
+
+/* Symmetric matrix, 2-D storage */
+
+ csymm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset],
+ ldx, &c_b2, &b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* General matrix, band storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ cgbmv_(trans, m, n, kl, ku, &c_b1, &a[a_offset], lda, &x[j *
+ x_dim1 + 1], &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
+/* L20: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "PB") || lsamen_(&
+ c__2, c2, "HB")) {
+
+/* Hermitian matrix, band storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ chbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1],
+ &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
+/* L30: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "SB")) {
+
+/* Symmetric matrix, band storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ csbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1],
+ &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
+/* L40: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "PP") || lsamen_(&
+ c__2, c2, "HP")) {
+
+/* Hermitian matrix, packed storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ chpmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
+ c_b2, &b[j * b_dim1 + 1], &c__1);
+/* L50: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "SP")) {
+
+/* Symmetric matrix, packed storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ cspmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
+ c_b2, &b[j * b_dim1 + 1], &c__1);
+/* L60: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "TR")) {
+
+/* Triangular matrix. Note that for triangular matrices, */
+/* KU = 1 => non-unit triangular */
+/* KU = 2 => unit triangular */
+
+ clacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ ctrmm_("Left", uplo, trans, diag, n, nrhs, &c_b1, &a[a_offset], lda, &
+ b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "TP")) {
+
+/* Triangular matrix, packed storage */
+
+ clacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ctpmv_(uplo, trans, diag, n, &a[a_offset], &b[j * b_dim1 + 1], &
+ c__1);
+/* L70: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "TB")) {
+
+/* Triangular matrix, banded storage */
+
+ clacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ctbmv_(uplo, trans, diag, n, kl, &a[a_offset], lda, &b[j * b_dim1
+ + 1], &c__1);
+/* L80: */
+ }
+
+ } else {
+
+/* If none of the above, set INFO = -1 and return */
+
+ *info = -1;
+ i__1 = -(*info);
+ xerbla_("CLARHS", &i__1);
+ }
+
+ return 0;
+
+/* End of CLARHS */
+
+} /* clarhs_ */
diff --git a/TESTING/EIG/clatm4.c b/TESTING/EIG/clatm4.c
new file mode 100644
index 0000000..21720ef
--- /dev/null
+++ b/TESTING/EIG/clatm4.c
@@ -0,0 +1,477 @@
+/* clatm4.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static integer c__3 = 3;
+
+/* Subroutine */ int clatm4_(integer *itype, integer *n, integer *nz1,
+ integer *nz2, logical *rsign, real *amagn, real *rcond, real *triang,
+ integer *idist, integer *iseed, complex *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ real r__1;
+ doublereal d__1, d__2;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double pow_dd(doublereal *, doublereal *), log(doublereal), exp(
+ doublereal), c_abs(complex *);
+
+ /* Local variables */
+ integer i__, k, jc, jd, jr, kbeg, isdb, kend, isde, klen;
+ real alpha;
+ complex ctemp;
+ extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *);
+ extern doublereal slaran_(integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLATM4 generates basic square matrices, which may later be */
+/* multiplied by others in order to produce test matrices. It is */
+/* intended mainly to be used to test the generalized eigenvalue */
+/* routines. */
+
+/* It first generates the diagonal and (possibly) subdiagonal, */
+/* according to the value of ITYPE, NZ1, NZ2, RSIGN, AMAGN, and RCOND. */
+/* It then fills in the upper triangle with random numbers, if TRIANG is */
+/* non-zero. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* The "type" of matrix on the diagonal and sub-diagonal. */
+/* If ITYPE < 0, then type abs(ITYPE) is generated and then */
+/* swapped end for end (A(I,J) := A'(N-J,N-I).) See also */
+/* the description of AMAGN and RSIGN. */
+
+/* Special types: */
+/* = 0: the zero matrix. */
+/* = 1: the identity. */
+/* = 2: a transposed Jordan block. */
+/* = 3: If N is odd, then a k+1 x k+1 transposed Jordan block */
+/* followed by a k x k identity block, where k=(N-1)/2. */
+/* If N is even, then k=(N-2)/2, and a zero diagonal entry */
+/* is tacked onto the end. */
+
+/* Diagonal types. The diagonal consists of NZ1 zeros, then */
+/* k=N-NZ1-NZ2 nonzeros. The subdiagonal is zero. ITYPE */
+/* specifies the nonzero diagonal entries as follows: */
+/* = 4: 1, ..., k */
+/* = 5: 1, RCOND, ..., RCOND */
+/* = 6: 1, ..., 1, RCOND */
+/* = 7: 1, a, a^2, ..., a^(k-1)=RCOND */
+/* = 8: 1, 1-d, 1-2*d, ..., 1-(k-1)*d=RCOND */
+/* = 9: random numbers chosen from (RCOND,1) */
+/* = 10: random numbers with distribution IDIST (see CLARND.) */
+
+/* N (input) INTEGER */
+/* The order of the matrix. */
+
+/* NZ1 (input) INTEGER */
+/* If abs(ITYPE) > 3, then the first NZ1 diagonal entries will */
+/* be zero. */
+
+/* NZ2 (input) INTEGER */
+/* If abs(ITYPE) > 3, then the last NZ2 diagonal entries will */
+/* be zero. */
+
+/* RSIGN (input) LOGICAL */
+/* = .TRUE.: The diagonal and subdiagonal entries will be */
+/* multiplied by random numbers of magnitude 1. */
+/* = .FALSE.: The diagonal and subdiagonal entries will be */
+/* left as they are (usually non-negative real.) */
+
+/* AMAGN (input) REAL */
+/* The diagonal and subdiagonal entries will be multiplied by */
+/* AMAGN. */
+
+/* RCOND (input) REAL */
+/* If abs(ITYPE) > 4, then the smallest diagonal entry will be */
+/* RCOND. RCOND must be between 0 and 1. */
+
+/* TRIANG (input) REAL */
+/* The entries above the diagonal will be random numbers with */
+/* magnitude bounded by TRIANG (i.e., random numbers multiplied */
+/* by TRIANG.) */
+
+/* IDIST (input) INTEGER */
+/* On entry, DIST specifies the type of distribution to be used */
+/* to generate a random matrix . */
+/* = 1: real and imaginary parts each UNIFORM( 0, 1 ) */
+/* = 2: real and imaginary parts each UNIFORM( -1, 1 ) */
+/* = 3: real and imaginary parts each NORMAL( 0, 1 ) */
+/* = 4: complex number uniform in DISK( 0, 1 ) */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The values of ISEED are changed on exit, and can */
+/* be used in the next call to CLATM4 to continue the same */
+/* random number sequence. */
+/* Note: ISEED(4) should be odd, for the random number generator */
+/* used at present. */
+
+/* A (output) COMPLEX array, dimension (LDA, N) */
+/* Array to be computed. */
+
+/* LDA (input) INTEGER */
+/* Leading dimension of A. Must be at least 1 and at least N. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ claset_("Full", n, n, &c_b1, &c_b1, &a[a_offset], lda);
+
+/* Insure a correct ISEED */
+
+ if (iseed[4] % 2 != 1) {
+ ++iseed[4];
+ }
+
+/* Compute diagonal and subdiagonal according to ITYPE, NZ1, NZ2, */
+/* and RCOND */
+
+ if (*itype != 0) {
+ if (abs(*itype) >= 4) {
+/* Computing MAX */
+/* Computing MIN */
+ i__3 = *n, i__4 = *nz1 + 1;
+ i__1 = 1, i__2 = min(i__3,i__4);
+ kbeg = max(i__1,i__2);
+/* Computing MAX */
+/* Computing MIN */
+ i__3 = *n, i__4 = *n - *nz2;
+ i__1 = kbeg, i__2 = min(i__3,i__4);
+ kend = max(i__1,i__2);
+ klen = kend + 1 - kbeg;
+ } else {
+ kbeg = 1;
+ kend = *n;
+ klen = *n;
+ }
+ isdb = 1;
+ isde = 0;
+ switch (abs(*itype)) {
+ case 1: goto L10;
+ case 2: goto L30;
+ case 3: goto L50;
+ case 4: goto L80;
+ case 5: goto L100;
+ case 6: goto L120;
+ case 7: goto L140;
+ case 8: goto L160;
+ case 9: goto L180;
+ case 10: goto L200;
+ }
+
+/* abs(ITYPE) = 1: Identity */
+
+L10:
+ i__1 = *n;
+ for (jd = 1; jd <= i__1; ++jd) {
+ i__2 = jd + jd * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+/* L20: */
+ }
+ goto L220;
+
+/* abs(ITYPE) = 2: Transposed Jordan block */
+
+L30:
+ i__1 = *n - 1;
+ for (jd = 1; jd <= i__1; ++jd) {
+ i__2 = jd + 1 + jd * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+/* L40: */
+ }
+ isdb = 1;
+ isde = *n - 1;
+ goto L220;
+
+/* abs(ITYPE) = 3: Transposed Jordan block, followed by the */
+/* identity. */
+
+L50:
+ k = (*n - 1) / 2;
+ i__1 = k;
+ for (jd = 1; jd <= i__1; ++jd) {
+ i__2 = jd + 1 + jd * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+/* L60: */
+ }
+ isdb = 1;
+ isde = k;
+ i__1 = (k << 1) + 1;
+ for (jd = k + 2; jd <= i__1; ++jd) {
+ i__2 = jd + jd * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+/* L70: */
+ }
+ goto L220;
+
+/* abs(ITYPE) = 4: 1,...,k */
+
+L80:
+ i__1 = kend;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ i__2 = jd + jd * a_dim1;
+ i__3 = jd - *nz1;
+ q__1.r = (real) i__3, q__1.i = 0.f;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L90: */
+ }
+ goto L220;
+
+/* abs(ITYPE) = 5: One large D value: */
+
+L100:
+ i__1 = kend;
+ for (jd = kbeg + 1; jd <= i__1; ++jd) {
+ i__2 = jd + jd * a_dim1;
+ q__1.r = *rcond, q__1.i = 0.f;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L110: */
+ }
+ i__1 = kbeg + kbeg * a_dim1;
+ a[i__1].r = 1.f, a[i__1].i = 0.f;
+ goto L220;
+
+/* abs(ITYPE) = 6: One small D value: */
+
+L120:
+ i__1 = kend - 1;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ i__2 = jd + jd * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+/* L130: */
+ }
+ i__1 = kend + kend * a_dim1;
+ q__1.r = *rcond, q__1.i = 0.f;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ goto L220;
+
+/* abs(ITYPE) = 7: Exponentially distributed D values: */
+
+L140:
+ i__1 = kbeg + kbeg * a_dim1;
+ a[i__1].r = 1.f, a[i__1].i = 0.f;
+ if (klen > 1) {
+ d__1 = (doublereal) (*rcond);
+ d__2 = (doublereal) (1.f / (real) (klen - 1));
+ alpha = pow_dd(&d__1, &d__2);
+ i__1 = klen;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = *nz1 + i__ + (*nz1 + i__) * a_dim1;
+ d__1 = (doublereal) alpha;
+ d__2 = (doublereal) ((real) (i__ - 1));
+ r__1 = pow_dd(&d__1, &d__2);
+ q__1.r = r__1, q__1.i = 0.f;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L150: */
+ }
+ }
+ goto L220;
+
+/* abs(ITYPE) = 8: Arithmetically distributed D values: */
+
+L160:
+ i__1 = kbeg + kbeg * a_dim1;
+ a[i__1].r = 1.f, a[i__1].i = 0.f;
+ if (klen > 1) {
+ alpha = (1.f - *rcond) / (real) (klen - 1);
+ i__1 = klen;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = *nz1 + i__ + (*nz1 + i__) * a_dim1;
+ r__1 = (real) (klen - i__) * alpha + *rcond;
+ q__1.r = r__1, q__1.i = 0.f;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L170: */
+ }
+ }
+ goto L220;
+
+/* abs(ITYPE) = 9: Randomly distributed D values on ( RCOND, 1): */
+
+L180:
+ alpha = log(*rcond);
+ i__1 = kend;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ i__2 = jd + jd * a_dim1;
+ r__1 = exp(alpha * slaran_(&iseed[1]));
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+/* L190: */
+ }
+ goto L220;
+
+/* abs(ITYPE) = 10: Randomly distributed D values from DIST */
+
+L200:
+ i__1 = kend;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ i__2 = jd + jd * a_dim1;
+ clarnd_(&q__1, idist, &iseed[1]);
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L210: */
+ }
+
+L220:
+
+/* Scale by AMAGN */
+
+ i__1 = kend;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ i__2 = jd + jd * a_dim1;
+ i__3 = jd + jd * a_dim1;
+ r__1 = *amagn * a[i__3].r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+/* L230: */
+ }
+ i__1 = isde;
+ for (jd = isdb; jd <= i__1; ++jd) {
+ i__2 = jd + 1 + jd * a_dim1;
+ i__3 = jd + 1 + jd * a_dim1;
+ r__1 = *amagn * a[i__3].r;
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+/* L240: */
+ }
+
+/* If RSIGN = .TRUE., assign random signs to diagonal and */
+/* subdiagonal */
+
+ if (*rsign) {
+ i__1 = kend;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ i__2 = jd + jd * a_dim1;
+ if (a[i__2].r != 0.f) {
+ clarnd_(&q__1, &c__3, &iseed[1]);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ r__1 = c_abs(&ctemp);
+ q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__2 = jd + jd * a_dim1;
+ i__3 = jd + jd * a_dim1;
+ r__1 = a[i__3].r;
+ q__1.r = r__1 * ctemp.r, q__1.i = r__1 * ctemp.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ }
+/* L250: */
+ }
+ i__1 = isde;
+ for (jd = isdb; jd <= i__1; ++jd) {
+ i__2 = jd + 1 + jd * a_dim1;
+ if (a[i__2].r != 0.f) {
+ clarnd_(&q__1, &c__3, &iseed[1]);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ r__1 = c_abs(&ctemp);
+ q__1.r = ctemp.r / r__1, q__1.i = ctemp.i / r__1;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__2 = jd + 1 + jd * a_dim1;
+ i__3 = jd + 1 + jd * a_dim1;
+ r__1 = a[i__3].r;
+ q__1.r = r__1 * ctemp.r, q__1.i = r__1 * ctemp.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ }
+/* L260: */
+ }
+ }
+
+/* Reverse if ITYPE < 0 */
+
+ if (*itype < 0) {
+ i__1 = (kbeg + kend - 1) / 2;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ i__2 = jd + jd * a_dim1;
+ ctemp.r = a[i__2].r, ctemp.i = a[i__2].i;
+ i__2 = jd + jd * a_dim1;
+ i__3 = kbeg + kend - jd + (kbeg + kend - jd) * a_dim1;
+ a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
+ i__2 = kbeg + kend - jd + (kbeg + kend - jd) * a_dim1;
+ a[i__2].r = ctemp.r, a[i__2].i = ctemp.i;
+/* L270: */
+ }
+ i__1 = (*n - 1) / 2;
+ for (jd = 1; jd <= i__1; ++jd) {
+ i__2 = jd + 1 + jd * a_dim1;
+ ctemp.r = a[i__2].r, ctemp.i = a[i__2].i;
+ i__2 = jd + 1 + jd * a_dim1;
+ i__3 = *n + 1 - jd + (*n - jd) * a_dim1;
+ a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
+ i__2 = *n + 1 - jd + (*n - jd) * a_dim1;
+ a[i__2].r = ctemp.r, a[i__2].i = ctemp.i;
+/* L280: */
+ }
+ }
+
+ }
+
+/* Fill in upper triangle */
+
+ if (*triang != 0.f) {
+ i__1 = *n;
+ for (jc = 2; jc <= i__1; ++jc) {
+ i__2 = jc - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = jr + jc * a_dim1;
+ clarnd_(&q__2, idist, &iseed[1]);
+ q__1.r = *triang * q__2.r, q__1.i = *triang * q__2.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L290: */
+ }
+/* L300: */
+ }
+ }
+
+ return 0;
+
+/* End of CLATM4 */
+
+} /* clatm4_ */
diff --git a/TESTING/EIG/clctes.c b/TESTING/EIG/clctes.c
new file mode 100644
index 0000000..4404579
--- /dev/null
+++ b/TESTING/EIG/clctes.c
@@ -0,0 +1,95 @@
+/* clctes.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b3 = 1.f;
+
+logical clctes_(complex *z__, complex *d__)
+{
+ /* System generated locals */
+ real r__1, r__2, r__3, r__4;
+ logical ret_val;
+
+ /* Builtin functions */
+ double r_imag(complex *), r_sign(real *, real *);
+
+ /* Local variables */
+ real zmax;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLCTES returns .TRUE. if the eigenvalue Z/D is to be selected */
+/* (specifically, in this subroutine, if the real part of the */
+/* eigenvalue is negative), and otherwise it returns .FALSE.. */
+
+/* It is used by the test routine CDRGES to test whether the driver */
+/* routine CGGES succesfully sorts eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* Z (input) COMPLEX */
+/* The numerator part of a complex eigenvalue Z/D. */
+
+/* D (input) COMPLEX */
+/* The denominator part of a complex eigenvalue Z/D. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (d__->r == 0.f && d__->i == 0.f) {
+ ret_val = z__->r < 0.f;
+ } else {
+ if (z__->r == 0.f || d__->r == 0.f) {
+ r__1 = r_imag(z__);
+ r__2 = r_imag(d__);
+ ret_val = r_sign(&c_b3, &r__1) != r_sign(&c_b3, &r__2);
+ } else if (r_imag(z__) == 0.f || r_imag(d__) == 0.f) {
+ r__1 = z__->r;
+ r__2 = d__->r;
+ ret_val = r_sign(&c_b3, &r__1) != r_sign(&c_b3, &r__2);
+ } else {
+/* Computing MAX */
+ r__3 = (r__1 = z__->r, dabs(r__1)), r__4 = (r__2 = r_imag(z__),
+ dabs(r__2));
+ zmax = dmax(r__3,r__4);
+ ret_val = z__->r / zmax * d__->r + r_imag(z__) / zmax * r_imag(
+ d__) < 0.f;
+ }
+ }
+
+ return ret_val;
+
+/* End of CLCTES */
+
+} /* clctes_ */
diff --git a/TESTING/EIG/clctsx.c b/TESTING/EIG/clctsx.c
new file mode 100644
index 0000000..61f0df6
--- /dev/null
+++ b/TESTING/EIG/clctsx.c
@@ -0,0 +1,104 @@
+/* clctsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer m, n, mplusn, i__;
+ logical fs;
+} mn_;
+
+#define mn_1 mn_
+
+logical clctsx_(complex *alpha, complex *beta)
+{
+ /* System generated locals */
+ logical ret_val;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This function is used to determine what eigenvalues will be */
+/* selected. If this is part of the test driver CDRGSX, do not */
+/* change the code UNLESS you are testing input examples and not */
+/* using the built-in examples. */
+
+/* Arguments */
+/* ========= */
+
+/* ALPHA (input) COMPLEX */
+/* BETA (input) COMPLEX */
+/* parameters to decide whether the pair (ALPHA, BETA) is */
+/* selected. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* REAL ZERO */
+/* PARAMETER ( ZERO = 0.0E+0 ) */
+/* COMPLEX CZERO */
+/* PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (mn_1.fs) {
+ ++mn_1.i__;
+ if (mn_1.i__ <= mn_1.m) {
+ ret_val = FALSE_;
+ } else {
+ ret_val = TRUE_;
+ }
+ if (mn_1.i__ == mn_1.mplusn) {
+ mn_1.fs = FALSE_;
+ mn_1.i__ = 0;
+ }
+ } else {
+ ++mn_1.i__;
+ if (mn_1.i__ <= mn_1.n) {
+ ret_val = TRUE_;
+ } else {
+ ret_val = FALSE_;
+ }
+ if (mn_1.i__ == mn_1.mplusn) {
+ mn_1.fs = TRUE_;
+ mn_1.i__ = 0;
+ }
+ }
+
+/* IF( BETA.EQ.CZERO ) THEN */
+/* CLCTSX = ( REAL( ALPHA ).GT.ZERO ) */
+/* ELSE */
+/* CLCTSX = ( REAL( ALPHA/BETA ).GT.ZERO ) */
+/* END IF */
+
+ return ret_val;
+
+/* End of CLCTSX */
+
+} /* clctsx_ */
diff --git a/TESTING/EIG/clsets.c b/TESTING/EIG/clsets.c
new file mode 100644
index 0000000..5a990a8
--- /dev/null
+++ b/TESTING/EIG/clsets.c
@@ -0,0 +1,172 @@
+/* clsets.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int clsets_(integer *m, integer *p, integer *n, complex *a,
+ complex *af, integer *lda, complex *b, complex *bf, integer *ldb,
+ complex *c__, complex *cf, complex *d__, complex *df, complex *x,
+ complex *work, integer *lwork, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1,
+ bf_offset;
+
+ /* Local variables */
+ integer info;
+ extern /* Subroutine */ int cget02_(char *, integer *, integer *, integer
+ *, complex *, integer *, complex *, integer *, complex *, integer
+ *, real *, real *), ccopy_(integer *, complex *, integer *
+, complex *, integer *), cgglse_(integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, complex *, complex *,
+ complex *, complex *, integer *, integer *), clacpy_(char *,
+ integer *, integer *, complex *, integer *, complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLSETS tests CGGLSE - a subroutine for solving linear equality */
+/* constrained least square problem (LSE). */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The M-by-N matrix A. */
+
+/* AF (workspace) COMPLEX array, dimension (LDA,N) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and R. */
+/* LDA >= max(M,N). */
+
+/* B (input) COMPLEX array, dimension (LDB,N) */
+/* The P-by-N matrix A. */
+
+/* BF (workspace) COMPLEX array, dimension (LDB,N) */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the arrays B, BF, V and S. */
+/* LDB >= max(P,N). */
+
+/* C (input) COMPLEX array, dimension( M ) */
+/* the vector C in the LSE problem. */
+
+/* CF (workspace) COMPLEX array, dimension( M ) */
+
+/* D (input) COMPLEX array, dimension( P ) */
+/* the vector D in the LSE problem. */
+
+/* DF (workspace) COMPLEX array, dimension( P ) */
+
+/* X (output) COMPLEX array, dimension( N ) */
+/* solution vector X in the LSE problem. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( A*x - c )/ norm(A)*norm(X)*EPS */
+/* RESULT(2) = norm( B*x - d )/ norm(B)*norm(X)*EPS */
+
+/* ==================================================================== */
+
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Copy the matrices A and B to the arrays AF and BF, */
+/* and the vectors C and D to the arrays CF and DF, */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ bf_dim1 = *ldb;
+ bf_offset = 1 + bf_dim1;
+ bf -= bf_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --c__;
+ --cf;
+ --d__;
+ --df;
+ --x;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ clacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+ clacpy_("Full", p, n, &b[b_offset], ldb, &bf[bf_offset], ldb);
+ ccopy_(m, &c__[1], &c__1, &cf[1], &c__1);
+ ccopy_(p, &d__[1], &c__1, &df[1], &c__1);
+
+/* Solve LSE problem */
+
+ cgglse_(m, n, p, &af[af_offset], lda, &bf[bf_offset], ldb, &cf[1], &df[1],
+ &x[1], &work[1], lwork, &info);
+
+/* Test the residual for the solution of LSE */
+
+/* Compute RESULT(1) = norm( A*x - c ) / norm(A)*norm(X)*EPS */
+
+ ccopy_(m, &c__[1], &c__1, &cf[1], &c__1);
+ ccopy_(p, &d__[1], &c__1, &df[1], &c__1);
+ cget02_("No transpose", m, n, &c__1, &a[a_offset], lda, &x[1], n, &cf[1],
+ m, &rwork[1], &result[1]);
+
+/* Compute result(2) = norm( B*x - d ) / norm(B)*norm(X)*EPS */
+
+ cget02_("No transpose", p, n, &c__1, &b[b_offset], ldb, &x[1], n, &df[1],
+ p, &rwork[1], &result[2]);
+
+ return 0;
+
+/* End of CLSETS */
+
+} /* clsets_ */
diff --git a/TESTING/EIG/csbmv.c b/TESTING/EIG/csbmv.c
new file mode 100644
index 0000000..09fcad9
--- /dev/null
+++ b/TESTING/EIG/csbmv.c
@@ -0,0 +1,479 @@
+/* csbmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int csbmv_(char *uplo, integer *n, integer *k, complex *
+ alpha, complex *a, integer *lda, complex *x, integer *incx, complex *
+ beta, complex *y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Local variables */
+ integer i__, j, l, ix, iy, jx, jy, kx, ky, info;
+ complex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ integer kplus1;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSBMV performs the matrix-vector operation */
+
+/* y := alpha*A*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are n element vectors and */
+/* A is an n by n symmetric band matrix, with k super-diagonals. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1 */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the band matrix A is being supplied as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* being supplied. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* being supplied. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER */
+/* On entry, K specifies the number of super-diagonals of the */
+/* matrix A. K must satisfy 0 .le. K. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array, dimension( LDA, N ) */
+/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
+/* by n part of the array A must contain the upper triangular */
+/* band part of the symmetric matrix, supplied column by */
+/* column, with the leading diagonal of the matrix in row */
+/* ( k + 1 ) of the array, the first super-diagonal starting at */
+/* position 2 in row k, and so on. The top left k by k triangle */
+/* of the array A is not referenced. */
+/* The following program segment will transfer the upper */
+/* triangular part of a symmetric band matrix from conventional */
+/* full matrix storage to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = K + 1 - J */
+/* DO 10, I = MAX( 1, J - K ), J */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
+/* by n part of the array A must contain the lower triangular */
+/* band part of the symmetric matrix, supplied column by */
+/* column, with the leading diagonal of the matrix in row 1 of */
+/* the array, the first sub-diagonal starting at position 1 in */
+/* row 2, and so on. The bottom right k by k triangle of the */
+/* array A is not referenced. */
+/* The following program segment will transfer the lower */
+/* triangular part of a symmetric band matrix from conventional */
+/* full matrix storage to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = 1 - J */
+/* DO 10, I = J, MIN( N, J + K ) */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Unchanged on exit. */
+
+/* LDA - INTEGER */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* ( k + 1 ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+/* Y - COMPLEX array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the */
+/* vector y. On exit, Y is overwritten by the updated vector y. */
+
+/* INCY - INTEGER */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*k < 0) {
+ info = 3;
+ } else if (*lda < *k + 1) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ } else if (*incy == 0) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("CSBMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f &&
+ beta->i == 0.f)) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of the array A */
+/* are accessed sequentially with one pass through A. */
+
+/* First form y := beta*y. */
+
+ if (beta->r != 1.f || beta->i != 0.f) {
+ if (*incy == 1) {
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ y[i__2].r = 0.f, y[i__2].i = 0.f;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ y[i__2].r = 0.f, y[i__2].i = 0.f;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ i__3 = iy;
+ q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (alpha->r == 0.f && alpha->i == 0.f) {
+ return 0;
+ }
+ if (lsame_(uplo, "U")) {
+
+/* Form y when upper triangle of A is stored. */
+
+ kplus1 = *k + 1;
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__5 = l + i__ + j * a_dim1;
+ q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ i__2 = l + i__ + j * a_dim1;
+ i__3 = i__;
+ q__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[i__3].i,
+ q__2.i = a[i__2].r * x[i__3].i + a[i__2].i * x[
+ i__3].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L50: */
+ }
+ i__4 = j;
+ i__2 = j;
+ i__3 = kplus1 + j * a_dim1;
+ q__3.r = temp1.r * a[i__3].r - temp1.i * a[i__3].i, q__3.i =
+ temp1.r * a[i__3].i + temp1.i * a[i__3].r;
+ q__2.r = y[i__2].r + q__3.r, q__2.i = y[i__2].i + q__3.i;
+ q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ y[i__4].r = q__1.r, y[i__4].i = q__1.i;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = jx;
+ q__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i, q__1.i =
+ alpha->r * x[i__4].i + alpha->i * x[i__4].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ ix = kx;
+ iy = ky;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *k;
+ i__3 = j - 1;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ i__4 = iy;
+ i__2 = iy;
+ i__5 = l + i__ + j * a_dim1;
+ q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
+ y[i__4].r = q__1.r, y[i__4].i = q__1.i;
+ i__4 = l + i__ + j * a_dim1;
+ i__2 = ix;
+ q__2.r = a[i__4].r * x[i__2].r - a[i__4].i * x[i__2].i,
+ q__2.i = a[i__4].r * x[i__2].i + a[i__4].i * x[
+ i__2].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ i__3 = jy;
+ i__4 = jy;
+ i__2 = kplus1 + j * a_dim1;
+ q__3.r = temp1.r * a[i__2].r - temp1.i * a[i__2].i, q__3.i =
+ temp1.r * a[i__2].i + temp1.i * a[i__2].r;
+ q__2.r = y[i__4].r + q__3.r, q__2.i = y[i__4].i + q__3.i;
+ q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ jx += *incx;
+ jy += *incy;
+ if (j > *k) {
+ kx += *incx;
+ ky += *incy;
+ }
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y when lower triangle of A is stored. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = j;
+ q__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, q__1.i =
+ alpha->r * x[i__3].i + alpha->i * x[i__3].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__3 = j;
+ i__4 = j;
+ i__2 = j * a_dim1 + 1;
+ q__2.r = temp1.r * a[i__2].r - temp1.i * a[i__2].i, q__2.i =
+ temp1.r * a[i__2].i + temp1.i * a[i__2].r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ l = 1 - j;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__2 = i__;
+ i__5 = l + i__ + j * a_dim1;
+ q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
+ y[i__4].r = q__1.r, y[i__4].i = q__1.i;
+ i__4 = l + i__ + j * a_dim1;
+ i__2 = i__;
+ q__2.r = a[i__4].r * x[i__2].r - a[i__4].i * x[i__2].i,
+ q__2.i = a[i__4].r * x[i__2].i + a[i__4].i * x[
+ i__2].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L90: */
+ }
+ i__3 = j;
+ i__4 = j;
+ q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = jx;
+ q__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, q__1.i =
+ alpha->r * x[i__3].i + alpha->i * x[i__3].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__3 = jy;
+ i__4 = jy;
+ i__2 = j * a_dim1 + 1;
+ q__2.r = temp1.r * a[i__2].r - temp1.i * a[i__2].i, q__2.i =
+ temp1.r * a[i__2].i + temp1.i * a[i__2].r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ l = 1 - j;
+ ix = jx;
+ iy = jy;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ ix += *incx;
+ iy += *incy;
+ i__4 = iy;
+ i__2 = iy;
+ i__5 = l + i__ + j * a_dim1;
+ q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
+ y[i__4].r = q__1.r, y[i__4].i = q__1.i;
+ i__4 = l + i__ + j * a_dim1;
+ i__2 = ix;
+ q__2.r = a[i__4].r * x[i__2].r - a[i__4].i * x[i__2].i,
+ q__2.i = a[i__4].r * x[i__2].i + a[i__4].i * x[
+ i__2].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L110: */
+ }
+ i__3 = jy;
+ i__4 = jy;
+ q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ jx += *incx;
+ jy += *incy;
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CSBMV */
+
+} /* csbmv_ */
diff --git a/TESTING/EIG/csgt01.c b/TESTING/EIG/csgt01.c
new file mode 100644
index 0000000..65253d9
--- /dev/null
+++ b/TESTING/EIG/csgt01.c
@@ -0,0 +1,224 @@
+/* csgt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int csgt01_(integer *itype, char *uplo, integer *n, integer *
+ m, complex *a, integer *lda, complex *b, integer *ldb, complex *z__,
+ integer *ldz, real *d__, complex *work, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1;
+ complex q__1;
+
+ /* Local variables */
+ integer i__;
+ real ulp;
+ extern /* Subroutine */ int chemm_(char *, char *, integer *, integer *,
+ complex *, complex *, integer *, complex *, integer *, complex *,
+ complex *, integer *);
+ real anorm;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), clanhe_(char *, char *, integer *,
+ complex *, integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* modified August 1997, a new parameter M is added to the calling */
+/* sequence. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSGT01 checks a decomposition of the form */
+
+/* A Z = B Z D or */
+/* A B Z = Z D or */
+/* B A Z = Z D */
+
+/* where A is a Hermitian matrix, B is Hermitian positive definite, */
+/* Z is unitary, and D is diagonal. */
+
+/* One of the following test ratios is computed: */
+
+/* ITYPE = 1: RESULT(1) = | A Z - B Z D | / ( |A| |Z| n ulp ) */
+
+/* ITYPE = 2: RESULT(1) = | A B Z - Z D | / ( |A| |Z| n ulp ) */
+
+/* ITYPE = 3: RESULT(1) = | B A Z - Z D | / ( |A| |Z| n ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* The form of the Hermitian generalized eigenproblem. */
+/* = 1: A*z = (lambda)*B*z */
+/* = 2: A*B*z = (lambda)*z */
+/* = 3: B*A*z = (lambda)*z */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrices A and B is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* M (input) INTEGER */
+/* The number of eigenvalues found. M >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA, N) */
+/* The original Hermitian matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) COMPLEX array, dimension (LDB, N) */
+/* The original Hermitian positive definite matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Z (input) COMPLEX array, dimension (LDZ, M) */
+/* The computed eigenvectors of the generalized eigenproblem. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= max(1,N). */
+
+/* D (input) REAL array, dimension (M) */
+/* The computed eigenvalues of the generalized eigenproblem. */
+
+/* WORK (workspace) COMPLEX array, dimension (N*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESULT (output) REAL array, dimension (1) */
+/* The test ratio as described above. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --d__;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.f;
+ if (*n <= 0) {
+ return 0;
+ }
+
+ ulp = slamch_("Epsilon");
+
+/* Compute product of 1-norms of A and Z. */
+
+ anorm = clanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]) * clange_("1", n, m, &z__[z_offset], ldz, &rwork[1]);
+ if (anorm == 0.f) {
+ anorm = 1.f;
+ }
+
+ if (*itype == 1) {
+
+/* Norm of AZ - BZD */
+
+ chemm_("Left", uplo, n, m, &c_b2, &a[a_offset], lda, &z__[z_offset],
+ ldz, &c_b1, &work[1], n);
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ csscal_(n, &d__[i__], &z__[i__ * z_dim1 + 1], &c__1);
+/* L10: */
+ }
+ q__1.r = -1.f, q__1.i = -0.f;
+ chemm_("Left", uplo, n, m, &c_b2, &b[b_offset], ldb, &z__[z_offset],
+ ldz, &q__1, &work[1], n);
+
+ result[1] = clange_("1", n, m, &work[1], n, &rwork[1]) /
+ anorm / (*n * ulp);
+
+ } else if (*itype == 2) {
+
+/* Norm of ABZ - ZD */
+
+ chemm_("Left", uplo, n, m, &c_b2, &b[b_offset], ldb, &z__[z_offset],
+ ldz, &c_b1, &work[1], n);
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ csscal_(n, &d__[i__], &z__[i__ * z_dim1 + 1], &c__1);
+/* L20: */
+ }
+ q__1.r = -1.f, q__1.i = -0.f;
+ chemm_("Left", uplo, n, m, &c_b2, &a[a_offset], lda, &work[1], n, &
+ q__1, &z__[z_offset], ldz);
+
+ result[1] = clange_("1", n, m, &z__[z_offset], ldz, &rwork[1]) / anorm / (*n * ulp);
+
+ } else if (*itype == 3) {
+
+/* Norm of BAZ - ZD */
+
+ chemm_("Left", uplo, n, m, &c_b2, &a[a_offset], lda, &z__[z_offset],
+ ldz, &c_b1, &work[1], n);
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ csscal_(n, &d__[i__], &z__[i__ * z_dim1 + 1], &c__1);
+/* L30: */
+ }
+ q__1.r = -1.f, q__1.i = -0.f;
+ chemm_("Left", uplo, n, m, &c_b2, &b[b_offset], ldb, &work[1], n, &
+ q__1, &z__[z_offset], ldz);
+
+ result[1] = clange_("1", n, m, &z__[z_offset], ldz, &rwork[1]) / anorm / (*n * ulp);
+ }
+
+ return 0;
+
+/* End of CSGT01 */
+
+} /* csgt01_ */
diff --git a/TESTING/EIG/cslect.c b/TESTING/EIG/cslect.c
new file mode 100644
index 0000000..34db7ab
--- /dev/null
+++ b/TESTING/EIG/cslect.c
@@ -0,0 +1,109 @@
+/* cslect.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ real selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+logical cslect_(complex *z__)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ complex q__1, q__2;
+ logical ret_val;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+
+ /* Local variables */
+ integer i__;
+ real x, rmin;
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSLECT returns .TRUE. if the eigenvalue Z is to be selected, */
+/* otherwise it returns .FALSE. */
+/* It is used by CCHK41 to test if CGEES succesfully sorts eigenvalues, */
+/* and by CCHK43 to test if CGEESX succesfully sorts eigenvalues. */
+
+/* The common block /SSLCT/ controls how eigenvalues are selected. */
+/* If SELOPT = 0, then CSLECT return .TRUE. when real(Z) is less than */
+/* zero, and .FALSE. otherwise. */
+/* If SELOPT is at least 1, CSLECT returns SELVAL(SELOPT) and adds 1 */
+/* to SELOPT, cycling back to 1 at SELMAX. */
+
+/* Arguments */
+/* ========= */
+
+/* Z (input) COMPLEX */
+/* The eigenvalue Z. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (sslct_1.selopt == 0) {
+ ret_val = z__->r < 0.f;
+ } else {
+ q__2.r = sslct_1.selwr[0], q__2.i = sslct_1.selwi[0];
+ q__1.r = z__->r - q__2.r, q__1.i = z__->i - q__2.i;
+ rmin = c_abs(&q__1);
+ ret_val = sslct_1.selval[0];
+ i__1 = sslct_1.seldim;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__ - 1;
+ i__3 = i__ - 1;
+ q__2.r = sslct_1.selwr[i__2], q__2.i = sslct_1.selwi[i__3];
+ q__1.r = z__->r - q__2.r, q__1.i = z__->i - q__2.i;
+ x = c_abs(&q__1);
+ if (x <= rmin) {
+ rmin = x;
+ ret_val = sslct_1.selval[i__ - 1];
+ }
+/* L10: */
+ }
+ }
+ return ret_val;
+
+/* End of CSLECT */
+
+} /* cslect_ */
diff --git a/TESTING/EIG/cstt21.c b/TESTING/EIG/cstt21.c
new file mode 100644
index 0000000..accb557
--- /dev/null
+++ b/TESTING/EIG/cstt21.c
@@ -0,0 +1,255 @@
+/* cstt21.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cstt21_(integer *n, integer *kband, real *ad, real *ae,
+ real *sd, real *se, complex *u, integer *ldu, complex *work, real *
+ rwork, real *result)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, i__1, i__2, i__3;
+ real r__1, r__2, r__3;
+ complex q__1, q__2;
+
+ /* Local variables */
+ integer j;
+ real ulp;
+ extern /* Subroutine */ int cher_(char *, integer *, real *, complex *,
+ integer *, complex *, integer *);
+ real unfl;
+ extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex *
+, integer *, complex *, integer *, complex *, integer *);
+ real temp1, temp2;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ real anorm, wnorm;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), clanhe_(char *, char *, integer *,
+ complex *, integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSTT21 checks a decomposition of the form */
+
+/* A = U S U* */
+
+/* where * means conjugate transpose, A is real symmetric tridiagonal, */
+/* U is unitary, and S is real and diagonal (if KBAND=0) or symmetric */
+/* tridiagonal (if KBAND=1). Two tests are performed: */
+
+/* RESULT(1) = | A - U S U* | / ( |A| n ulp ) */
+
+/* RESULT(2) = | I - UU* | / ( n ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, CSTT21 does nothing. */
+/* It must be at least zero. */
+
+/* KBAND (input) INTEGER */
+/* The bandwidth of the matrix S. It may only be zero or one. */
+/* If zero, then S is diagonal, and SE is not referenced. If */
+/* one, then S is symmetric tri-diagonal. */
+
+/* AD (input) REAL array, dimension (N) */
+/* The diagonal of the original (unfactored) matrix A. A is */
+/* assumed to be real symmetric tridiagonal. */
+
+/* AE (input) REAL array, dimension (N-1) */
+/* The off-diagonal of the original (unfactored) matrix A. A */
+/* is assumed to be symmetric tridiagonal. AE(1) is the (1,2) */
+/* and (2,1) element, AE(2) is the (2,3) and (3,2) element, etc. */
+
+/* SD (input) REAL array, dimension (N) */
+/* The diagonal of the real (symmetric tri-) diagonal matrix S. */
+
+/* SE (input) REAL array, dimension (N-1) */
+/* The off-diagonal of the (symmetric tri-) diagonal matrix S. */
+/* Not referenced if KBSND=0. If KBAND=1, then AE(1) is the */
+/* (1,2) and (2,1) element, SE(2) is the (2,3) and (3,2) */
+/* element, etc. */
+
+/* U (input) COMPLEX array, dimension (LDU, N) */
+/* The unitary matrix in the decomposition. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N. */
+
+/* WORK (workspace) COMPLEX array, dimension (N**2) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+/* RESULT(1) is always modified. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Constants */
+
+ /* Parameter adjustments */
+ --ad;
+ --ae;
+ --sd;
+ --se;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.f;
+ result[2] = 0.f;
+ if (*n <= 0) {
+ return 0;
+ }
+
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Precision");
+
+/* Do Test 1 */
+
+/* Copy A & Compute its 1-Norm: */
+
+ claset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
+
+ anorm = 0.f;
+ temp1 = 0.f;
+
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (*n + 1) * (j - 1) + 1;
+ i__3 = j;
+ work[i__2].r = ad[i__3], work[i__2].i = 0.f;
+ i__2 = (*n + 1) * (j - 1) + 2;
+ i__3 = j;
+ work[i__2].r = ae[i__3], work[i__2].i = 0.f;
+ temp2 = (r__1 = ae[j], dabs(r__1));
+/* Computing MAX */
+ r__2 = anorm, r__3 = (r__1 = ad[j], dabs(r__1)) + temp1 + temp2;
+ anorm = dmax(r__2,r__3);
+ temp1 = temp2;
+/* L10: */
+ }
+
+/* Computing 2nd power */
+ i__2 = *n;
+ i__1 = i__2 * i__2;
+ i__3 = *n;
+ work[i__1].r = ad[i__3], work[i__1].i = 0.f;
+/* Computing MAX */
+ r__2 = anorm, r__3 = (r__1 = ad[*n], dabs(r__1)) + temp1, r__2 = max(r__2,
+ r__3);
+ anorm = dmax(r__2,unfl);
+
+/* Norm of A - USU* */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ r__1 = -sd[j];
+ cher_("L", n, &r__1, &u[j * u_dim1 + 1], &c__1, &work[1], n);
+/* L20: */
+ }
+
+ if (*n > 1 && *kband == 1) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ q__2.r = se[i__2], q__2.i = 0.f;
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ cher2_("L", n, &q__1, &u[j * u_dim1 + 1], &c__1, &u[(j + 1) *
+ u_dim1 + 1], &c__1, &work[1], n);
+/* L30: */
+ }
+ }
+
+ wnorm = clanhe_("1", "L", n, &work[1], n, &rwork[1])
+ ;
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.f) {
+/* Computing MIN */
+ r__1 = wnorm, r__2 = *n * anorm;
+ result[1] = dmin(r__1,r__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ r__1 = wnorm / anorm, r__2 = (real) (*n);
+ result[1] = dmin(r__1,r__2) / (*n * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute UU* - I */
+
+ cgemm_("N", "C", n, n, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu, &
+ c_b1, &work[1], n);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (*n + 1) * (j - 1) + 1;
+ i__3 = (*n + 1) * (j - 1) + 1;
+ q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i - 0.f;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L40: */
+ }
+
+/* Computing MIN */
+ r__1 = (real) (*n), r__2 = clange_("1", n, n, &work[1], n, &rwork[1]);
+ result[2] = dmin(r__1,r__2) / (*n * ulp);
+
+ return 0;
+
+/* End of CSTT21 */
+
+} /* cstt21_ */
diff --git a/TESTING/EIG/cstt22.c b/TESTING/EIG/cstt22.c
new file mode 100644
index 0000000..70ef4c9
--- /dev/null
+++ b/TESTING/EIG/cstt22.c
@@ -0,0 +1,288 @@
+/* cstt22.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+
+/* Subroutine */ int cstt22_(integer *n, integer *m, integer *kband, real *ad,
+ real *ae, real *sd, real *se, complex *u, integer *ldu, complex *
+ work, integer *ldwork, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, work_dim1, work_offset, i__1, i__2, i__3, i__4,
+ i__5, i__6;
+ real r__1, r__2, r__3, r__4, r__5;
+ complex q__1, q__2;
+
+ /* Local variables */
+ integer i__, j, k;
+ real ulp;
+ complex aukj;
+ real unfl;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ real anorm, wnorm;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *), clansy_(char
+ *, char *, integer *, complex *, integer *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSTT22 checks a set of M eigenvalues and eigenvectors, */
+
+/* A U = U S */
+
+/* where A is Hermitian tridiagonal, the columns of U are unitary, */
+/* and S is diagonal (if KBAND=0) or Hermitian tridiagonal (if KBAND=1). */
+/* Two tests are performed: */
+
+/* RESULT(1) = | U* A U - S | / ( |A| m ulp ) */
+
+/* RESULT(2) = | I - U*U | / ( m ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, CSTT22 does nothing. */
+/* It must be at least zero. */
+
+/* M (input) INTEGER */
+/* The number of eigenpairs to check. If it is zero, CSTT22 */
+/* does nothing. It must be at least zero. */
+
+/* KBAND (input) INTEGER */
+/* The bandwidth of the matrix S. It may only be zero or one. */
+/* If zero, then S is diagonal, and SE is not referenced. If */
+/* one, then S is Hermitian tri-diagonal. */
+
+/* AD (input) REAL array, dimension (N) */
+/* The diagonal of the original (unfactored) matrix A. A is */
+/* assumed to be Hermitian tridiagonal. */
+
+/* AE (input) REAL array, dimension (N) */
+/* The off-diagonal of the original (unfactored) matrix A. A */
+/* is assumed to be Hermitian tridiagonal. AE(1) is ignored, */
+/* AE(2) is the (1,2) and (2,1) element, etc. */
+
+/* SD (input) REAL array, dimension (N) */
+/* The diagonal of the (Hermitian tri-) diagonal matrix S. */
+
+/* SE (input) REAL array, dimension (N) */
+/* The off-diagonal of the (Hermitian tri-) diagonal matrix S. */
+/* Not referenced if KBSND=0. If KBAND=1, then AE(1) is */
+/* ignored, SE(2) is the (1,2) and (2,1) element, etc. */
+
+/* U (input) REAL array, dimension (LDU, N) */
+/* The unitary matrix in the decomposition. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N. */
+
+/* WORK (workspace) COMPLEX array, dimension (LDWORK, M+1) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of WORK. LDWORK must be at least */
+/* max(1,M). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ad;
+ --ae;
+ --sd;
+ --se;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.f;
+ result[2] = 0.f;
+ if (*n <= 0 || *m <= 0) {
+ return 0;
+ }
+
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon");
+
+/* Do Test 1 */
+
+/* Compute the 1-norm of A. */
+
+ if (*n > 1) {
+ anorm = dabs(ad[1]) + dabs(ae[1]);
+ i__1 = *n - 1;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MAX */
+ r__4 = anorm, r__5 = (r__1 = ad[j], dabs(r__1)) + (r__2 = ae[j],
+ dabs(r__2)) + (r__3 = ae[j - 1], dabs(r__3));
+ anorm = dmax(r__4,r__5);
+/* L10: */
+ }
+/* Computing MAX */
+ r__3 = anorm, r__4 = (r__1 = ad[*n], dabs(r__1)) + (r__2 = ae[*n - 1],
+ dabs(r__2));
+ anorm = dmax(r__3,r__4);
+ } else {
+ anorm = dabs(ad[1]);
+ }
+ anorm = dmax(anorm,unfl);
+
+/* Norm of U*AU - S */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *m;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * work_dim1;
+ work[i__3].r = 0.f, work[i__3].i = 0.f;
+ i__3 = *n;
+ for (k = 1; k <= i__3; ++k) {
+ i__4 = k;
+ i__5 = k + j * u_dim1;
+ q__1.r = ad[i__4] * u[i__5].r, q__1.i = ad[i__4] * u[i__5].i;
+ aukj.r = q__1.r, aukj.i = q__1.i;
+ if (k != *n) {
+ i__4 = k;
+ i__5 = k + 1 + j * u_dim1;
+ q__2.r = ae[i__4] * u[i__5].r, q__2.i = ae[i__4] * u[i__5]
+ .i;
+ q__1.r = aukj.r + q__2.r, q__1.i = aukj.i + q__2.i;
+ aukj.r = q__1.r, aukj.i = q__1.i;
+ }
+ if (k != 1) {
+ i__4 = k - 1;
+ i__5 = k - 1 + j * u_dim1;
+ q__2.r = ae[i__4] * u[i__5].r, q__2.i = ae[i__4] * u[i__5]
+ .i;
+ q__1.r = aukj.r + q__2.r, q__1.i = aukj.i + q__2.i;
+ aukj.r = q__1.r, aukj.i = q__1.i;
+ }
+ i__4 = i__ + j * work_dim1;
+ i__5 = i__ + j * work_dim1;
+ i__6 = k + i__ * u_dim1;
+ q__2.r = u[i__6].r * aukj.r - u[i__6].i * aukj.i, q__2.i = u[
+ i__6].r * aukj.i + u[i__6].i * aukj.r;
+ q__1.r = work[i__5].r + q__2.r, q__1.i = work[i__5].i +
+ q__2.i;
+ work[i__4].r = q__1.r, work[i__4].i = q__1.i;
+/* L20: */
+ }
+/* L30: */
+ }
+ i__2 = i__ + i__ * work_dim1;
+ i__3 = i__ + i__ * work_dim1;
+ i__4 = i__;
+ q__1.r = work[i__3].r - sd[i__4], q__1.i = work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ if (*kband == 1) {
+ if (i__ != 1) {
+ i__2 = i__ + (i__ - 1) * work_dim1;
+ i__3 = i__ + (i__ - 1) * work_dim1;
+ i__4 = i__ - 1;
+ q__1.r = work[i__3].r - se[i__4], q__1.i = work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ if (i__ != *n) {
+ i__2 = i__ + (i__ + 1) * work_dim1;
+ i__3 = i__ + (i__ + 1) * work_dim1;
+ i__4 = i__;
+ q__1.r = work[i__3].r - se[i__4], q__1.i = work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ }
+ }
+/* L40: */
+ }
+
+ wnorm = clansy_("1", "L", m, &work[work_offset], m, &rwork[1]);
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*m * ulp);
+ } else {
+ if (anorm < 1.f) {
+/* Computing MIN */
+ r__1 = wnorm, r__2 = *m * anorm;
+ result[1] = dmin(r__1,r__2) / anorm / (*m * ulp);
+ } else {
+/* Computing MIN */
+ r__1 = wnorm / anorm, r__2 = (real) (*m);
+ result[1] = dmin(r__1,r__2) / (*m * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute U*U - I */
+
+ cgemm_("T", "N", m, m, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu, &
+ c_b1, &work[work_offset], m);
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * work_dim1;
+ i__3 = j + j * work_dim1;
+ q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L50: */
+ }
+
+/* Computing MIN */
+ r__1 = (real) (*m), r__2 = clange_("1", m, m, &work[work_offset], m, &
+ rwork[1]);
+ result[2] = dmin(r__1,r__2) / (*m * ulp);
+
+ return 0;
+
+/* End of CSTT22 */
+
+} /* cstt22_ */
diff --git a/TESTING/EIG/cunt01.c b/TESTING/EIG/cunt01.c
new file mode 100644
index 0000000..de8a4b9
--- /dev/null
+++ b/TESTING/EIG/cunt01.c
@@ -0,0 +1,239 @@
+/* cunt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b7 = {0.f,0.f};
+static complex c_b8 = {1.f,0.f};
+static real c_b10 = -1.f;
+static real c_b11 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int cunt01_(char *rowcol, integer *m, integer *n, complex *u,
+ integer *ldu, complex *work, integer *lwork, real *rwork, real *
+ resid)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, i__1, i__2;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ real eps;
+ complex tmp;
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern /* Subroutine */ int cherk_(char *, char *, integer *, integer *,
+ real *, complex *, integer *, real *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ integer mnmin;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *);
+ extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
+ real *);
+ integer ldwork;
+ char transu[1];
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNT01 checks that the matrix U is unitary by computing the ratio */
+
+/* RESID = norm( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R', */
+/* or */
+/* RESID = norm( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'. */
+
+/* Alternatively, if there isn't sufficient workspace to form */
+/* I - U*U' or I - U'*U, the ratio is computed as */
+
+/* RESID = abs( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R', */
+/* or */
+/* RESID = abs( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'. */
+
+/* where EPS is the machine precision. ROWCOL is used only if m = n; */
+/* if m > n, ROWCOL is assumed to be 'C', and if m < n, ROWCOL is */
+/* assumed to be 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* ROWCOL (input) CHARACTER */
+/* Specifies whether the rows or columns of U should be checked */
+/* for orthogonality. Used only if M = N. */
+/* = 'R': Check for orthogonal rows of U */
+/* = 'C': Check for orthogonal columns of U */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix U. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix U. */
+
+/* U (input) COMPLEX array, dimension (LDU,N) */
+/* The unitary matrix U. U is checked for orthogonal columns */
+/* if m > n or if m = n and ROWCOL = 'C'. U is checked for */
+/* orthogonal rows if m < n or if m = n and ROWCOL = 'R'. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M). */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. For best performance, LWORK */
+/* should be at least N*N if ROWCOL = 'C' or M*M if */
+/* ROWCOL = 'R', but the test will be done even if LWORK is 0. */
+
+/* RWORK (workspace) REAL array, dimension (min(M,N)) */
+/* Used only if LWORK is large enough to use the Level 3 BLAS */
+/* code. */
+
+/* RESID (output) REAL */
+/* RESID = norm( I - U * U' ) / ( n * EPS ), if ROWCOL = 'R', or */
+/* RESID = norm( I - U' * U ) / ( m * EPS ), if ROWCOL = 'C'. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *resid = 0.f;
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+ eps = slamch_("Precision");
+ if (*m < *n || *m == *n && lsame_(rowcol, "R")) {
+ *(unsigned char *)transu = 'N';
+ k = *n;
+ } else {
+ *(unsigned char *)transu = 'C';
+ k = *m;
+ }
+ mnmin = min(*m,*n);
+
+ if ((mnmin + 1) * mnmin <= *lwork) {
+ ldwork = mnmin;
+ } else {
+ ldwork = 0;
+ }
+ if (ldwork > 0) {
+
+/* Compute I - U*U' or I - U'*U. */
+
+ claset_("Upper", &mnmin, &mnmin, &c_b7, &c_b8, &work[1], &ldwork);
+ cherk_("Upper", transu, &mnmin, &k, &c_b10, &u[u_offset], ldu, &c_b11,
+ &work[1], &ldwork);
+
+/* Compute norm( I - U*U' ) / ( K * EPS ) . */
+
+ *resid = clansy_("1", "Upper", &mnmin, &work[1], &ldwork, &rwork[1]);
+ *resid = *resid / (real) k / eps;
+ } else if (*(unsigned char *)transu == 'C') {
+
+/* Find the maximum element in abs( I - U'*U ) / ( m * EPS ) */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (i__ != j) {
+ tmp.r = 0.f, tmp.i = 0.f;
+ } else {
+ tmp.r = 1.f, tmp.i = 0.f;
+ }
+ cdotc_(&q__2, m, &u[i__ * u_dim1 + 1], &c__1, &u[j * u_dim1 +
+ 1], &c__1);
+ q__1.r = tmp.r - q__2.r, q__1.i = tmp.i - q__2.i;
+ tmp.r = q__1.r, tmp.i = q__1.i;
+/* Computing MAX */
+ r__3 = *resid, r__4 = (r__1 = tmp.r, dabs(r__1)) + (r__2 =
+ r_imag(&tmp), dabs(r__2));
+ *resid = dmax(r__3,r__4);
+/* L10: */
+ }
+/* L20: */
+ }
+ *resid = *resid / (real) (*m) / eps;
+ } else {
+
+/* Find the maximum element in abs( I - U*U' ) / ( n * EPS ) */
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (i__ != j) {
+ tmp.r = 0.f, tmp.i = 0.f;
+ } else {
+ tmp.r = 1.f, tmp.i = 0.f;
+ }
+ cdotc_(&q__2, n, &u[j + u_dim1], ldu, &u[i__ + u_dim1], ldu);
+ q__1.r = tmp.r - q__2.r, q__1.i = tmp.i - q__2.i;
+ tmp.r = q__1.r, tmp.i = q__1.i;
+/* Computing MAX */
+ r__3 = *resid, r__4 = (r__1 = tmp.r, dabs(r__1)) + (r__2 =
+ r_imag(&tmp), dabs(r__2));
+ *resid = dmax(r__3,r__4);
+/* L30: */
+ }
+/* L40: */
+ }
+ *resid = *resid / (real) (*n) / eps;
+ }
+ return 0;
+
+/* End of CUNT01 */
+
+} /* cunt01_ */
diff --git a/TESTING/EIG/cunt03.c b/TESTING/EIG/cunt03.c
new file mode 100644
index 0000000..ccd929b
--- /dev/null
+++ b/TESTING/EIG/cunt03.c
@@ -0,0 +1,311 @@
+/* cunt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cunt03_(char *rc, integer *mu, integer *mv, integer *n,
+ integer *k, complex *u, integer *ldu, complex *v, integer *ldv,
+ complex *work, integer *lwork, real *rwork, real *result, integer *
+ info)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer i__, j;
+ complex s, su, sv;
+ integer irc, lmx;
+ real ulp, res1, res2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cunt01_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, real *, real *);
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CUNT03 compares two unitary matrices U and V to see if their */
+/* corresponding rows or columns span the same spaces. The rows are */
+/* checked if RC = 'R', and the columns are checked if RC = 'C'. */
+
+/* RESULT is the maximum of */
+
+/* | V*V' - I | / ( MV ulp ), if RC = 'R', or */
+
+/* | V'*V - I | / ( MV ulp ), if RC = 'C', */
+
+/* and the maximum over rows (or columns) 1 to K of */
+
+/* | U(i) - S*V(i) |/ ( N ulp ) */
+
+/* where abs(S) = 1 (chosen to minimize the expression), U(i) is the */
+/* i-th row (column) of U, and V(i) is the i-th row (column) of V. */
+
+/* Arguments */
+/* ========== */
+
+/* RC (input) CHARACTER*1 */
+/* If RC = 'R' the rows of U and V are to be compared. */
+/* If RC = 'C' the columns of U and V are to be compared. */
+
+/* MU (input) INTEGER */
+/* The number of rows of U if RC = 'R', and the number of */
+/* columns if RC = 'C'. If MU = 0 CUNT03 does nothing. */
+/* MU must be at least zero. */
+
+/* MV (input) INTEGER */
+/* The number of rows of V if RC = 'R', and the number of */
+/* columns if RC = 'C'. If MV = 0 CUNT03 does nothing. */
+/* MV must be at least zero. */
+
+/* N (input) INTEGER */
+/* If RC = 'R', the number of columns in the matrices U and V, */
+/* and if RC = 'C', the number of rows in U and V. If N = 0 */
+/* CUNT03 does nothing. N must be at least zero. */
+
+/* K (input) INTEGER */
+/* The number of rows or columns of U and V to compare. */
+/* 0 <= K <= max(MU,MV). */
+
+/* U (input) COMPLEX array, dimension (LDU,N) */
+/* The first matrix to compare. If RC = 'R', U is MU by N, and */
+/* if RC = 'C', U is N by MU. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. If RC = 'R', LDU >= max(1,MU), */
+/* and if RC = 'C', LDU >= max(1,N). */
+
+/* V (input) COMPLEX array, dimension (LDV,N) */
+/* The second matrix to compare. If RC = 'R', V is MV by N, and */
+/* if RC = 'C', V is N by MV. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of V. If RC = 'R', LDV >= max(1,MV), */
+/* and if RC = 'C', LDV >= max(1,N). */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. For best performance, LWORK */
+/* should be at least N*N if RC = 'C' or M*M if RC = 'R', but */
+/* the tests will be done even if LWORK is 0. */
+
+/* RWORK (workspace) REAL array, dimension (max(MV,N)) */
+
+/* RESULT (output) REAL */
+/* The value computed by the test described above. RESULT is */
+/* limited to 1/ulp to avoid overflow. */
+
+/* INFO (output) INTEGER */
+/* 0 indicates a successful exit */
+/* -k indicates the k-th parameter had an illegal value */
+
+/* ===================================================================== */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check inputs */
+
+ /* Parameter adjustments */
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ if (lsame_(rc, "R")) {
+ irc = 0;
+ } else if (lsame_(rc, "C")) {
+ irc = 1;
+ } else {
+ irc = -1;
+ }
+ if (irc == -1) {
+ *info = -1;
+ } else if (*mu < 0) {
+ *info = -2;
+ } else if (*mv < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > max(*mu,*mv)) {
+ *info = -5;
+ } else if (irc == 0 && *ldu < max(1,*mu) || irc == 1 && *ldu < max(1,*n))
+ {
+ *info = -7;
+ } else if (irc == 0 && *ldv < max(1,*mv) || irc == 1 && *ldv < max(1,*n))
+ {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CUNT03", &i__1);
+ return 0;
+ }
+
+/* Initialize result */
+
+ *result = 0.f;
+ if (*mu == 0 || *mv == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Machine constants */
+
+ ulp = slamch_("Precision");
+
+ if (irc == 0) {
+
+/* Compare rows */
+
+ res1 = 0.f;
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ lmx = icamax_(n, &u[i__ + u_dim1], ldu);
+ i__2 = i__ + lmx * v_dim1;
+ if (v[i__2].r == 0.f && v[i__2].i == 0.f) {
+ sv.r = 1.f, sv.i = 0.f;
+ } else {
+ r__1 = c_abs(&v[i__ + lmx * v_dim1]);
+ q__2.r = r__1, q__2.i = 0.f;
+ c_div(&q__1, &q__2, &v[i__ + lmx * v_dim1]);
+ sv.r = q__1.r, sv.i = q__1.i;
+ }
+ i__2 = i__ + lmx * u_dim1;
+ if (u[i__2].r == 0.f && u[i__2].i == 0.f) {
+ su.r = 1.f, su.i = 0.f;
+ } else {
+ r__1 = c_abs(&u[i__ + lmx * u_dim1]);
+ q__2.r = r__1, q__2.i = 0.f;
+ c_div(&q__1, &q__2, &u[i__ + lmx * u_dim1]);
+ su.r = q__1.r, su.i = q__1.i;
+ }
+ c_div(&q__1, &sv, &su);
+ s.r = q__1.r, s.i = q__1.i;
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ i__3 = i__ + j * u_dim1;
+ i__4 = i__ + j * v_dim1;
+ q__2.r = s.r * v[i__4].r - s.i * v[i__4].i, q__2.i = s.r * v[
+ i__4].i + s.i * v[i__4].r;
+ q__1.r = u[i__3].r - q__2.r, q__1.i = u[i__3].i - q__2.i;
+ r__1 = res1, r__2 = c_abs(&q__1);
+ res1 = dmax(r__1,r__2);
+/* L10: */
+ }
+/* L20: */
+ }
+ res1 /= (real) (*n) * ulp;
+
+/* Compute orthogonality of rows of V. */
+
+ cunt01_("Rows", mv, n, &v[v_offset], ldv, &work[1], lwork, &rwork[1],
+ &res2);
+
+ } else {
+
+/* Compare columns */
+
+ res1 = 0.f;
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ lmx = icamax_(n, &u[i__ * u_dim1 + 1], &c__1);
+ i__2 = lmx + i__ * v_dim1;
+ if (v[i__2].r == 0.f && v[i__2].i == 0.f) {
+ sv.r = 1.f, sv.i = 0.f;
+ } else {
+ r__1 = c_abs(&v[lmx + i__ * v_dim1]);
+ q__2.r = r__1, q__2.i = 0.f;
+ c_div(&q__1, &q__2, &v[lmx + i__ * v_dim1]);
+ sv.r = q__1.r, sv.i = q__1.i;
+ }
+ i__2 = lmx + i__ * u_dim1;
+ if (u[i__2].r == 0.f && u[i__2].i == 0.f) {
+ su.r = 1.f, su.i = 0.f;
+ } else {
+ r__1 = c_abs(&u[lmx + i__ * u_dim1]);
+ q__2.r = r__1, q__2.i = 0.f;
+ c_div(&q__1, &q__2, &u[lmx + i__ * u_dim1]);
+ su.r = q__1.r, su.i = q__1.i;
+ }
+ c_div(&q__1, &sv, &su);
+ s.r = q__1.r, s.i = q__1.i;
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ i__3 = j + i__ * u_dim1;
+ i__4 = j + i__ * v_dim1;
+ q__2.r = s.r * v[i__4].r - s.i * v[i__4].i, q__2.i = s.r * v[
+ i__4].i + s.i * v[i__4].r;
+ q__1.r = u[i__3].r - q__2.r, q__1.i = u[i__3].i - q__2.i;
+ r__1 = res1, r__2 = c_abs(&q__1);
+ res1 = dmax(r__1,r__2);
+/* L30: */
+ }
+/* L40: */
+ }
+ res1 /= (real) (*n) * ulp;
+
+/* Compute orthogonality of columns of V. */
+
+ cunt01_("Columns", n, mv, &v[v_offset], ldv, &work[1], lwork, &rwork[
+ 1], &res2);
+ }
+
+/* Computing MIN */
+ r__1 = dmax(res1,res2), r__2 = 1.f / ulp;
+ *result = dmin(r__1,r__2);
+ return 0;
+
+/* End of CUNT03 */
+
+} /* cunt03_ */
diff --git a/TESTING/EIG/dbdt01.c b/TESTING/EIG/dbdt01.c
new file mode 100644
index 0000000..34848d1
--- /dev/null
+++ b/TESTING/EIG/dbdt01.c
@@ -0,0 +1,291 @@
+/* dbdt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b7 = -1.;
+static doublereal c_b9 = 1.;
+
+/* Subroutine */ int dbdt01_(integer *m, integer *n, integer *kd, doublereal *
+ a, integer *lda, doublereal *q, integer *ldq, doublereal *d__,
+ doublereal *e, doublereal *pt, integer *ldpt, doublereal *work,
+ doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, pt_dim1, pt_offset, q_dim1, q_offset, i__1,
+ i__2;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal eps;
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal anorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DBDT01 reconstructs a general matrix A from its bidiagonal form */
+/* A = Q * B * P' */
+/* where Q (m by min(m,n)) and P' (min(m,n) by n) are orthogonal */
+/* matrices and B is bidiagonal. */
+
+/* The test ratio to test the reduction is */
+/* RESID = norm( A - Q * B * PT ) / ( n * norm(A) * EPS ) */
+/* where PT = P' and EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices A and Q. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and P'. */
+
+/* KD (input) INTEGER */
+/* If KD = 0, B is diagonal and the array E is not referenced. */
+/* If KD = 1, the reduction was performed by xGEBRD; B is upper */
+/* bidiagonal if M >= N, and lower bidiagonal if M < N. */
+/* If KD = -1, the reduction was performed by xGBBRD; B is */
+/* always upper bidiagonal. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* Q (input) DOUBLE PRECISION array, dimension (LDQ,N) */
+/* The m by min(m,n) orthogonal matrix Q in the reduction */
+/* A = Q * B * P'. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,M). */
+
+/* D (input) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The diagonal elements of the bidiagonal matrix B. */
+
+/* E (input) DOUBLE PRECISION array, dimension (min(M,N)-1) */
+/* The superdiagonal elements of the bidiagonal matrix B if */
+/* m >= n, or the subdiagonal elements of B if m < n. */
+
+/* PT (input) DOUBLE PRECISION array, dimension (LDPT,N) */
+/* The min(m,n) by n orthogonal matrix P' in the reduction */
+/* A = Q * B * P'. */
+
+/* LDPT (input) INTEGER */
+/* The leading dimension of the array PT. */
+/* LDPT >= max(1,min(M,N)). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (M+N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The test ratio: norm(A - Q * B * P') / ( n * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --d__;
+ --e;
+ pt_dim1 = *ldpt;
+ pt_offset = 1 + pt_dim1;
+ pt -= pt_offset;
+ --work;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Compute A - Q * B * P' one column at a time. */
+
+ *resid = 0.;
+ if (*kd != 0) {
+
+/* B is bidiagonal. */
+
+ if (*kd != 0 && *m >= *n) {
+
+/* B is upper bidiagonal and M >= N. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__2 = *n - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*m + i__] = d__[i__] * pt[i__ + j * pt_dim1] + e[i__]
+ * pt[i__ + 1 + j * pt_dim1];
+/* L10: */
+ }
+ work[*m + *n] = d__[*n] * pt[*n + j * pt_dim1];
+ dgemv_("No transpose", m, n, &c_b7, &q[q_offset], ldq, &work[*
+ m + 1], &c__1, &c_b9, &work[1], &c__1);
+/* Computing MAX */
+ d__1 = *resid, d__2 = dasum_(m, &work[1], &c__1);
+ *resid = max(d__1,d__2);
+/* L20: */
+ }
+ } else if (*kd < 0) {
+
+/* B is upper bidiagonal and M < N. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__2 = *m - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*m + i__] = d__[i__] * pt[i__ + j * pt_dim1] + e[i__]
+ * pt[i__ + 1 + j * pt_dim1];
+/* L30: */
+ }
+ work[*m + *m] = d__[*m] * pt[*m + j * pt_dim1];
+ dgemv_("No transpose", m, m, &c_b7, &q[q_offset], ldq, &work[*
+ m + 1], &c__1, &c_b9, &work[1], &c__1);
+/* Computing MAX */
+ d__1 = *resid, d__2 = dasum_(m, &work[1], &c__1);
+ *resid = max(d__1,d__2);
+/* L40: */
+ }
+ } else {
+
+/* B is lower bidiagonal. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ work[*m + 1] = d__[1] * pt[j * pt_dim1 + 1];
+ i__2 = *m;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ work[*m + i__] = e[i__ - 1] * pt[i__ - 1 + j * pt_dim1] +
+ d__[i__] * pt[i__ + j * pt_dim1];
+/* L50: */
+ }
+ dgemv_("No transpose", m, m, &c_b7, &q[q_offset], ldq, &work[*
+ m + 1], &c__1, &c_b9, &work[1], &c__1);
+/* Computing MAX */
+ d__1 = *resid, d__2 = dasum_(m, &work[1], &c__1);
+ *resid = max(d__1,d__2);
+/* L60: */
+ }
+ }
+ } else {
+
+/* B is diagonal. */
+
+ if (*m >= *n) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*m + i__] = d__[i__] * pt[i__ + j * pt_dim1];
+/* L70: */
+ }
+ dgemv_("No transpose", m, n, &c_b7, &q[q_offset], ldq, &work[*
+ m + 1], &c__1, &c_b9, &work[1], &c__1);
+/* Computing MAX */
+ d__1 = *resid, d__2 = dasum_(m, &work[1], &c__1);
+ *resid = max(d__1,d__2);
+/* L80: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*m + i__] = d__[i__] * pt[i__ + j * pt_dim1];
+/* L90: */
+ }
+ dgemv_("No transpose", m, m, &c_b7, &q[q_offset], ldq, &work[*
+ m + 1], &c__1, &c_b9, &work[1], &c__1);
+/* Computing MAX */
+ d__1 = *resid, d__2 = dasum_(m, &work[1], &c__1);
+ *resid = max(d__1,d__2);
+/* L100: */
+ }
+ }
+ }
+
+/* Compute norm(A - Q * B * P') / ( n * norm(A) * EPS ) */
+
+ anorm = dlange_("1", m, n, &a[a_offset], lda, &work[1]);
+ eps = dlamch_("Precision");
+
+ if (anorm <= 0.) {
+ if (*resid != 0.) {
+ *resid = 1. / eps;
+ }
+ } else {
+ if (anorm >= *resid) {
+ *resid = *resid / anorm / ((doublereal) (*n) * eps);
+ } else {
+ if (anorm < 1.) {
+/* Computing MIN */
+ d__1 = *resid, d__2 = (doublereal) (*n) * anorm;
+ *resid = min(d__1,d__2) / anorm / ((doublereal) (*n) * eps);
+ } else {
+/* Computing MIN */
+ d__1 = *resid / anorm, d__2 = (doublereal) (*n);
+ *resid = min(d__1,d__2) / ((doublereal) (*n) * eps);
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DBDT01 */
+
+} /* dbdt01_ */
diff --git a/TESTING/EIG/dbdt02.c b/TESTING/EIG/dbdt02.c
new file mode 100644
index 0000000..3f7ce38
--- /dev/null
+++ b/TESTING/EIG/dbdt02.c
@@ -0,0 +1,173 @@
+/* dbdt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b7 = -1.;
+static doublereal c_b9 = 1.;
+
+/* Subroutine */ int dbdt02_(integer *m, integer *n, doublereal *b, integer *
+ ldb, doublereal *c__, integer *ldc, doublereal *u, integer *ldu,
+ doublereal *work, doublereal *resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, c_dim1, c_offset, u_dim1, u_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ doublereal eps;
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal bnorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ doublereal realmn;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DBDT02 tests the change of basis C = U' * B by computing the residual */
+
+/* RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ), */
+
+/* where B and C are M by N matrices, U is an M by M orthogonal matrix, */
+/* and EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices B and C and the order of */
+/* the matrix Q. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices B and C. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,N) */
+/* The m by n matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M). */
+
+/* C (input) DOUBLE PRECISION array, dimension (LDC,N) */
+/* The m by n matrix C, assumed to contain U' * B. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* U (input) DOUBLE PRECISION array, dimension (LDU,M) */
+/* The m by m orthogonal matrix U. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ), */
+
+/* ====================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --work;
+
+ /* Function Body */
+ *resid = 0.;
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+ realmn = (doublereal) max(*m,*n);
+ eps = dlamch_("Precision");
+
+/* Compute norm( B - U * C ) */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(m, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ dgemv_("No transpose", m, m, &c_b7, &u[u_offset], ldu, &c__[j *
+ c_dim1 + 1], &c__1, &c_b9, &work[1], &c__1);
+/* Computing MAX */
+ d__1 = *resid, d__2 = dasum_(m, &work[1], &c__1);
+ *resid = max(d__1,d__2);
+/* L10: */
+ }
+
+/* Compute norm of B. */
+
+ bnorm = dlange_("1", m, n, &b[b_offset], ldb, &work[1]);
+
+ if (bnorm <= 0.) {
+ if (*resid != 0.) {
+ *resid = 1. / eps;
+ }
+ } else {
+ if (bnorm >= *resid) {
+ *resid = *resid / bnorm / (realmn * eps);
+ } else {
+ if (bnorm < 1.) {
+/* Computing MIN */
+ d__1 = *resid, d__2 = realmn * bnorm;
+ *resid = min(d__1,d__2) / bnorm / (realmn * eps);
+ } else {
+/* Computing MIN */
+ d__1 = *resid / bnorm;
+ *resid = min(d__1,realmn) / (realmn * eps);
+ }
+ }
+ }
+ return 0;
+
+/* End of DBDT02 */
+
+} /* dbdt02_ */
diff --git a/TESTING/EIG/dbdt03.c b/TESTING/EIG/dbdt03.c
new file mode 100644
index 0000000..0c94ebf
--- /dev/null
+++ b/TESTING/EIG/dbdt03.c
@@ -0,0 +1,263 @@
+/* dbdt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b6 = -1.;
+static integer c__1 = 1;
+static doublereal c_b8 = 0.;
+
+/* Subroutine */ int dbdt03_(char *uplo, integer *n, integer *kd, doublereal *
+ d__, doublereal *e, doublereal *u, integer *ldu, doublereal *s,
+ doublereal *vt, integer *ldvt, doublereal *work, doublereal *resid)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal bnorm;
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DBDT03 reconstructs a bidiagonal matrix B from its SVD: */
+/* S = U' * B * V */
+/* where U and V are orthogonal matrices and S is diagonal. */
+
+/* The test ratio to test the singular value decomposition is */
+/* RESID = norm( B - U * S * VT ) / ( n * norm(B) * EPS ) */
+/* where VT = V' and EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix B is upper or lower bidiagonal. */
+/* = 'U': Upper bidiagonal */
+/* = 'L': Lower bidiagonal */
+
+/* N (input) INTEGER */
+/* The order of the matrix B. */
+
+/* KD (input) INTEGER */
+/* The bandwidth of the bidiagonal matrix B. If KD = 1, the */
+/* matrix B is bidiagonal, and if KD = 0, B is diagonal and E is */
+/* not referenced. If KD is greater than 1, it is assumed to be */
+/* 1, and if KD is less than 0, it is assumed to be 0. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the bidiagonal matrix B. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) superdiagonal elements of the bidiagonal matrix B */
+/* if UPLO = 'U', or the (n-1) subdiagonal elements of B if */
+/* UPLO = 'L'. */
+
+/* U (input) DOUBLE PRECISION array, dimension (LDU,N) */
+/* The n by n orthogonal matrix U in the reduction B = U'*A*P. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,N) */
+
+/* S (input) DOUBLE PRECISION array, dimension (N) */
+/* The singular values from the SVD of B, sorted in decreasing */
+/* order. */
+
+/* VT (input) DOUBLE PRECISION array, dimension (LDVT,N) */
+/* The n by n orthogonal matrix V' in the reduction */
+/* B = U * S * V'. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The test ratio: norm(B - U * S * V') / ( n * norm(A) * EPS ) */
+
+/* ====================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --s;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --work;
+
+ /* Function Body */
+ *resid = 0.;
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Compute B - U * S * V' one column at a time. */
+
+ bnorm = 0.;
+ if (*kd >= 1) {
+
+/* B is bidiagonal. */
+
+ if (lsame_(uplo, "U")) {
+
+/* B is upper bidiagonal. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = s[i__] * vt[i__ + j * vt_dim1];
+/* L10: */
+ }
+ dgemv_("No transpose", n, n, &c_b6, &u[u_offset], ldu, &work[*
+ n + 1], &c__1, &c_b8, &work[1], &c__1);
+ work[j] += d__[j];
+ if (j > 1) {
+ work[j - 1] += e[j - 1];
+/* Computing MAX */
+ d__3 = bnorm, d__4 = (d__1 = d__[j], abs(d__1)) + (d__2 =
+ e[j - 1], abs(d__2));
+ bnorm = max(d__3,d__4);
+ } else {
+/* Computing MAX */
+ d__2 = bnorm, d__3 = (d__1 = d__[j], abs(d__1));
+ bnorm = max(d__2,d__3);
+ }
+/* Computing MAX */
+ d__1 = *resid, d__2 = dasum_(n, &work[1], &c__1);
+ *resid = max(d__1,d__2);
+/* L20: */
+ }
+ } else {
+
+/* B is lower bidiagonal. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = s[i__] * vt[i__ + j * vt_dim1];
+/* L30: */
+ }
+ dgemv_("No transpose", n, n, &c_b6, &u[u_offset], ldu, &work[*
+ n + 1], &c__1, &c_b8, &work[1], &c__1);
+ work[j] += d__[j];
+ if (j < *n) {
+ work[j + 1] += e[j];
+/* Computing MAX */
+ d__3 = bnorm, d__4 = (d__1 = d__[j], abs(d__1)) + (d__2 =
+ e[j], abs(d__2));
+ bnorm = max(d__3,d__4);
+ } else {
+/* Computing MAX */
+ d__2 = bnorm, d__3 = (d__1 = d__[j], abs(d__1));
+ bnorm = max(d__2,d__3);
+ }
+/* Computing MAX */
+ d__1 = *resid, d__2 = dasum_(n, &work[1], &c__1);
+ *resid = max(d__1,d__2);
+/* L40: */
+ }
+ }
+ } else {
+
+/* B is diagonal. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = s[i__] * vt[i__ + j * vt_dim1];
+/* L50: */
+ }
+ dgemv_("No transpose", n, n, &c_b6, &u[u_offset], ldu, &work[*n +
+ 1], &c__1, &c_b8, &work[1], &c__1);
+ work[j] += d__[j];
+/* Computing MAX */
+ d__1 = *resid, d__2 = dasum_(n, &work[1], &c__1);
+ *resid = max(d__1,d__2);
+/* L60: */
+ }
+ j = idamax_(n, &d__[1], &c__1);
+ bnorm = (d__1 = d__[j], abs(d__1));
+ }
+
+/* Compute norm(B - U * S * V') / ( n * norm(B) * EPS ) */
+
+ eps = dlamch_("Precision");
+
+ if (bnorm <= 0.) {
+ if (*resid != 0.) {
+ *resid = 1. / eps;
+ }
+ } else {
+ if (bnorm >= *resid) {
+ *resid = *resid / bnorm / ((doublereal) (*n) * eps);
+ } else {
+ if (bnorm < 1.) {
+/* Computing MIN */
+ d__1 = *resid, d__2 = (doublereal) (*n) * bnorm;
+ *resid = min(d__1,d__2) / bnorm / ((doublereal) (*n) * eps);
+ } else {
+/* Computing MIN */
+ d__1 = *resid / bnorm, d__2 = (doublereal) (*n);
+ *resid = min(d__1,d__2) / ((doublereal) (*n) * eps);
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DBDT03 */
+
+} /* dbdt03_ */
diff --git a/TESTING/EIG/dchkbb.c b/TESTING/EIG/dchkbb.c
new file mode 100644
index 0000000..77dc415
--- /dev/null
+++ b/TESTING/EIG/dchkbb.c
@@ -0,0 +1,771 @@
+/* dchkbb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b18 = 0.;
+static integer c__0 = 0;
+static integer c__6 = 6;
+static doublereal c_b35 = 1.;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dchkbb_(integer *nsizes, integer *mval, integer *nval,
+ integer *nwdths, integer *kk, integer *ntypes, logical *dotype,
+ integer *nrhs, integer *iseed, doublereal *thresh, integer *nounit,
+ doublereal *a, integer *lda, doublereal *ab, integer *ldab,
+ doublereal *bd, doublereal *be, doublereal *q, integer *ldq,
+ doublereal *p, integer *ldp, doublereal *c__, integer *ldc,
+ doublereal *cc, doublereal *work, integer *lwork, doublereal *result,
+ integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[15] = { 1,2,4,4,4,4,4,6,6,6,6,6,9,9,9 };
+ static integer kmagn[15] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3 };
+ static integer kmode[15] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 DCHKBB: \002,a,\002 returned INFO=\002,i"
+ "5,\002.\002,/9x,\002M=\002,i5,\002 N=\002,i5,\002 K=\002,i5,\002"
+ ", JTYPE=\002,i5,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 M =\002,i4,\002 N=\002,i4,\002, K=\002,i"
+ "3,\002, seed=\002,4(i4,\002,\002),\002 type \002,i2,\002, test"
+ "(\002,i2,\002)=\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, ab_dim1, ab_offset, c_dim1, c_offset, cc_dim1,
+ cc_offset, p_dim1, p_offset, q_dim1, q_offset, i__1, i__2, i__3,
+ i__4, i__5, i__6, i__7, i__8, i__9;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, m, n, kl, jr, ku;
+ doublereal ulp, cond;
+ integer jcol, kmax, mmax, nmax;
+ doublereal unfl, ovfl;
+ extern /* Subroutine */ int dbdt01_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *)
+ , dbdt02_(integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *);
+ logical badmm, badnn;
+ integer imode, iinfo;
+ extern /* Subroutine */ int dort01_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *);
+ doublereal anorm;
+ integer mnmin, mnmax, nmats, jsize, nerrs, itype, jtype, ntest;
+ extern /* Subroutine */ int dlahd2_(integer *, char *);
+ logical badnnb;
+ extern /* Subroutine */ int dgbbrd_(char *, integer *, integer *, integer
+ *, integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ extern doublereal dlamch_(char *);
+ integer idumma[1];
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *), dlatmr_(integer *, integer *,
+ char *, integer *, char *, doublereal *, integer *, doublereal *,
+ doublereal *, char *, char *, doublereal *, integer *, doublereal
+ *, doublereal *, integer *, doublereal *, char *, integer *,
+ integer *, integer *, doublereal *, doublereal *, char *,
+ doublereal *, integer *, integer *, integer *), dlatms_(integer *, integer *,
+ char *, integer *, char *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *, char *, doublereal *, integer
+ *, doublereal *, integer *), dlasum_(char
+ *, integer *, integer *, integer *);
+ doublereal amninv;
+ integer jwidth;
+ doublereal rtunfl, rtovfl, ulpinv;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (release 2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKBB tests the reduction of a general real rectangular band */
+/* matrix to bidiagonal form. */
+
+/* DGBBRD factors a general band matrix A as Q B P* , where * means */
+/* transpose, B is upper bidiagonal, and Q and P are orthogonal; */
+/* DGBBRD can also overwrite a given matrix C with Q* C . */
+
+/* For each pair of matrix dimensions (M,N) and each selected matrix */
+/* type, an M by N matrix A and an M by NRHS matrix C are generated. */
+/* The problem dimensions are as follows */
+/* A: M x N */
+/* Q: M x M */
+/* P: N x N */
+/* B: min(M,N) x min(M,N) */
+/* C: M x NRHS */
+
+/* For each generated matrix, 4 tests are performed: */
+
+/* (1) | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P' */
+
+/* (2) | I - Q' Q | / ( M ulp ) */
+
+/* (3) | I - PT PT' | / ( N ulp ) */
+
+/* (4) | Y - Q' C | / ( |Y| max(M,NRHS) ulp ), where Y = Q' C. */
+
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* The possible matrix types are */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (6) Same as (3), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (3), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) Rectangular matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of values of M and N contained in the vectors */
+/* MVAL and NVAL. The matrix sizes are used in pairs (M,N). */
+/* If NSIZES is zero, DCHKBB does nothing. NSIZES must be at */
+/* least zero. */
+
+/* MVAL (input) INTEGER array, dimension (NSIZES) */
+/* The values of the matrix row dimension M. */
+
+/* NVAL (input) INTEGER array, dimension (NSIZES) */
+/* The values of the matrix column dimension N. */
+
+/* NWDTHS (input) INTEGER */
+/* The number of bandwidths to use. If it is zero, */
+/* DCHKBB does nothing. It must be at least zero. */
+
+/* KK (input) INTEGER array, dimension (NWDTHS) */
+/* An array containing the bandwidths to be used for the band */
+/* matrices. The values must be at least zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, DCHKBB */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns in the "right-hand side" matrix C. */
+/* If NRHS = 0, then the operations on the right-hand side will */
+/* not be tested. NRHS must be at least 0. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to DCHKBB to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace) DOUBLE PRECISION array, dimension */
+/* (LDA, max(NN)) */
+/* Used to hold the matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* AB (workspace) DOUBLE PRECISION array, dimension (LDAB, max(NN)) */
+/* Used to hold A in band storage format. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of AB. It must be at least 2 (not 1!) */
+/* and at least max( KK )+1. */
+
+/* BD (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* Used to hold the diagonal of the bidiagonal matrix computed */
+/* by DGBBRD. */
+
+/* BE (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* Used to hold the off-diagonal of the bidiagonal matrix */
+/* computed by DGBBRD. */
+
+/* Q (workspace) DOUBLE PRECISION array, dimension (LDQ, max(NN)) */
+/* Used to hold the orthogonal matrix Q computed by DGBBRD. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of Q. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* P (workspace) DOUBLE PRECISION array, dimension (LDP, max(NN)) */
+/* Used to hold the orthogonal matrix P computed by DGBBRD. */
+
+/* LDP (input) INTEGER */
+/* The leading dimension of P. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* C (workspace) DOUBLE PRECISION array, dimension (LDC, max(NN)) */
+/* Used to hold the matrix C updated by DGBBRD. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of U. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* CC (workspace) DOUBLE PRECISION array, dimension (LDC, max(NN)) */
+/* Used to hold a copy of the matrix C. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* max( LDA+1, max(NN)+1 )*max(NN). */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests performed, or which can */
+/* be performed so far, for the current matrix. */
+/* NTESTT The total number of tests performed so far. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far. */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --mval;
+ --nval;
+ --kk;
+ --dotype;
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --bd;
+ --be;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ p_dim1 = *ldp;
+ p_offset = 1 + p_dim1;
+ p -= p_offset;
+ cc_dim1 = *ldc;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badmm = FALSE_;
+ badnn = FALSE_;
+ mmax = 1;
+ nmax = 1;
+ mnmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = mmax, i__3 = mval[j];
+ mmax = max(i__2,i__3);
+ if (mval[j] < 0) {
+ badmm = TRUE_;
+ }
+/* Computing MAX */
+ i__2 = nmax, i__3 = nval[j];
+ nmax = max(i__2,i__3);
+ if (nval[j] < 0) {
+ badnn = TRUE_;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__4 = mval[j], i__5 = nval[j];
+ i__2 = mnmax, i__3 = min(i__4,i__5);
+ mnmax = max(i__2,i__3);
+/* L10: */
+ }
+
+ badnnb = FALSE_;
+ kmax = 0;
+ i__1 = *nwdths;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = kmax, i__3 = kk[j];
+ kmax = max(i__2,i__3);
+ if (kk[j] < 0) {
+ badnnb = TRUE_;
+ }
+/* L20: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badmm) {
+ *info = -2;
+ } else if (badnn) {
+ *info = -3;
+ } else if (*nwdths < 0) {
+ *info = -4;
+ } else if (badnnb) {
+ *info = -5;
+ } else if (*ntypes < 0) {
+ *info = -6;
+ } else if (*nrhs < 0) {
+ *info = -8;
+ } else if (*lda < nmax) {
+ *info = -13;
+ } else if (*ldab < (kmax << 1) + 1) {
+ *info = -15;
+ } else if (*ldq < nmax) {
+ *info = -19;
+ } else if (*ldp < nmax) {
+ *info = -21;
+ } else if (*ldc < nmax) {
+ *info = -23;
+ } else if ((max(*lda,nmax) + 1) * nmax > *lwork) {
+ *info = -26;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DCHKBB", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0 || *nwdths == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ ulpinv = 1. / ulp;
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+
+/* Loop over sizes, widths, types */
+
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ m = mval[jsize];
+ n = nval[jsize];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__2 = max(1,m);
+ amninv = 1. / (doublereal) max(i__2,n);
+
+ i__2 = *nwdths;
+ for (jwidth = 1; jwidth <= i__2; ++jwidth) {
+ k = kk[jwidth];
+ if (k >= m && k >= n) {
+ goto L150;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__5 = m - 1;
+ i__3 = 0, i__4 = min(i__5,k);
+ kl = max(i__3,i__4);
+/* Computing MAX */
+/* Computing MIN */
+ i__5 = n - 1;
+ i__3 = 0, i__4 = min(i__5,k);
+ ku = max(i__3,i__4);
+
+ if (*nsizes != 1) {
+ mtypes = min(15,*ntypes);
+ } else {
+ mtypes = min(16,*ntypes);
+ }
+
+ i__3 = mtypes;
+ for (jtype = 1; jtype <= i__3; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L140;
+ }
+ ++nmats;
+ ntest = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L30: */
+ }
+
+/* Compute "A". */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, (w/ singular values) */
+/* =5 random log (none) */
+/* =6 random nonhermitian, w/ singular values */
+/* =7 (none) */
+/* =8 (none) */
+/* =9 random nonhermitian */
+
+ if (mtypes > 15) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * amninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * max(m,n) * ulpinv;
+ goto L70;
+
+L70:
+
+ dlaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
+ dlaset_("Full", ldab, &n, &c_b18, &c_b18, &ab[ab_offset],
+ ldab);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__4 = n;
+ for (jcol = 1; jcol <= i__4; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, singular values specified */
+
+ dlatms_(&m, &n, "S", &iseed[1], "N", &work[1], &imode, &
+ cond, &anorm, &c__0, &c__0, "N", &a[a_offset],
+ lda, &work[m + 1], &iinfo);
+
+ } else if (itype == 6) {
+
+/* Nonhermitian, singular values specified */
+
+ dlatms_(&m, &n, "S", &iseed[1], "N", &work[1], &imode, &
+ cond, &anorm, &kl, &ku, "N", &a[a_offset], lda, &
+ work[m + 1], &iinfo);
+
+ } else if (itype == 9) {
+
+/* Nonhermitian, random entries */
+
+ dlatmr_(&m, &n, "S", &iseed[1], "N", &work[1], &c__6, &
+ c_b35, &c_b35, "T", "N", &work[n + 1], &c__1, &
+ c_b35, &work[(n << 1) + 1], &c__1, &c_b35, "N",
+ idumma, &kl, &ku, &c_b18, &anorm, "N", &a[
+ a_offset], lda, idumma, &iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+/* Generate Right-Hand Side */
+
+ dlatmr_(&m, nrhs, "S", &iseed[1], "N", &work[1], &c__6, &
+ c_b35, &c_b35, "T", "N", &work[m + 1], &c__1, &c_b35,
+ &work[(m << 1) + 1], &c__1, &c_b35, "N", idumma, &m,
+ nrhs, &c_b18, &c_b35, "NO", &c__[c_offset], ldc,
+ idumma, &iinfo);
+
+ if (iinfo != 0) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+/* Copy A to band storage. */
+
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__6 = j - ku;
+/* Computing MIN */
+ i__8 = m, i__9 = j + kl;
+ i__7 = min(i__8,i__9);
+ for (i__ = max(i__5,i__6); i__ <= i__7; ++i__) {
+ ab[ku + 1 + i__ - j + j * ab_dim1] = a[i__ + j *
+ a_dim1];
+/* L100: */
+ }
+/* L110: */
+ }
+
+/* Copy C */
+
+ dlacpy_("Full", &m, nrhs, &c__[c_offset], ldc, &cc[cc_offset],
+ ldc);
+
+/* Call DGBBRD to compute B, Q and P, and to update C. */
+
+ dgbbrd_("B", &m, &n, nrhs, &kl, &ku, &ab[ab_offset], ldab, &
+ bd[1], &be[1], &q[q_offset], ldq, &p[p_offset], ldp, &
+ cc[cc_offset], ldc, &work[1], &iinfo);
+
+ if (iinfo != 0) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "DGBBRD", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[1] = ulpinv;
+ goto L120;
+ }
+ }
+
+/* Test 1: Check the decomposition A := Q * B * P' */
+/* 2: Check the orthogonality of Q */
+/* 3: Check the orthogonality of P */
+/* 4: Check the computation of Q' * C */
+
+ dbdt01_(&m, &n, &c_n1, &a[a_offset], lda, &q[q_offset], ldq, &
+ bd[1], &be[1], &p[p_offset], ldp, &work[1], &result[1]
+);
+ dort01_("Columns", &m, &m, &q[q_offset], ldq, &work[1], lwork,
+ &result[2]);
+ dort01_("Rows", &n, &n, &p[p_offset], ldp, &work[1], lwork, &
+ result[3]);
+ dbdt02_(&m, nrhs, &c__[c_offset], ldc, &cc[cc_offset], ldc, &
+ q[q_offset], ldq, &work[1], &result[4]);
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+ ntest = 4;
+L120:
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__4 = ntest;
+ for (jr = 1; jr <= i__4; ++jr) {
+ if (result[jr] >= *thresh) {
+ if (nerrs == 0) {
+ dlahd2_(nounit, "DBB");
+ }
+ ++nerrs;
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+/* L130: */
+ }
+
+L140:
+ ;
+ }
+L150:
+ ;
+ }
+/* L160: */
+ }
+
+/* Summary */
+
+ dlasum_("DBB", nounit, &nerrs, &ntestt);
+ return 0;
+
+
+/* End of DCHKBB */
+
+} /* dchkbb_ */
diff --git a/TESTING/EIG/dchkbd.c b/TESTING/EIG/dchkbd.c
new file mode 100644
index 0000000..46e1924
--- /dev/null
+++ b/TESTING/EIG/dchkbd.c
@@ -0,0 +1,1274 @@
+/* dchkbd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublereal c_b20 = 0.;
+static integer c__0 = 0;
+static integer c__6 = 6;
+static doublereal c_b37 = 1.;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__4 = 4;
+
+/* Subroutine */ int dchkbd_(integer *nsizes, integer *mval, integer *nval,
+ integer *ntypes, logical *dotype, integer *nrhs, integer *iseed,
+ doublereal *thresh, doublereal *a, integer *lda, doublereal *bd,
+ doublereal *be, doublereal *s1, doublereal *s2, doublereal *x,
+ integer *ldx, doublereal *y, doublereal *z__, doublereal *q, integer *
+ ldq, doublereal *pt, integer *ldpt, doublereal *u, doublereal *vt,
+ doublereal *work, integer *lwork, integer *iwork, integer *nout,
+ integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[16] = { 1,2,4,4,4,4,4,6,6,6,6,6,9,9,9,10 };
+ static integer kmagn[16] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3,0 };
+ static integer kmode[16] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9998[] = "(\002 DCHKBD: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002M=\002,i6,\002, N=\002,i6,\002, JTYPE=\002,i"
+ "6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, type "
+ "\002,i2,\002, seed=\002,4(i4,\002,\002),\002 test(\002,i2,\002)"
+ "=\002,g11.4)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, pt_dim1, pt_offset, q_dim1, q_offset, u_dim1,
+ u_offset, vt_dim1, vt_offset, x_dim1, x_offset, y_dim1, y_offset,
+ z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double log(doublereal), sqrt(doublereal), exp(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, m, n, mq;
+ doublereal dum[1], ulp, cond;
+ integer jcol;
+ char path[3];
+ integer idum[1], mmax, nmax;
+ doublereal unfl, ovfl;
+ char uplo[1];
+ doublereal temp1, temp2;
+ extern /* Subroutine */ int dbdt01_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *)
+ , dbdt02_(integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *);
+ logical badmm;
+ extern /* Subroutine */ int dbdt03_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ logical badnn;
+ integer nfail;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ integer imode;
+ doublereal dumma[1];
+ integer iinfo;
+ extern /* Subroutine */ int dort01_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *);
+ doublereal anorm;
+ integer mnmin;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer mnmax, jsize, itype, jtype, ntest;
+ extern /* Subroutine */ int dlahd2_(integer *, char *);
+ integer log2ui;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ logical bidiag;
+ extern /* Subroutine */ int dbdsdc_(char *, char *, integer *, doublereal
+ *, doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dgebrd_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *), dlarnd_(integer *, integer *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int dbdsqr_(char *, integer *, integer *, integer
+ *, integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dorgbr_(char *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), xerbla_(char *, integer *), alasum_(
+ char *, integer *, integer *, integer *, integer *),
+ dlatmr_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, char *, char
+ *, doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, char *, integer *, integer *, integer *,
+ doublereal *, doublereal *, char *, doublereal *, integer *,
+ integer *, integer *), dlatms_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublereal *, integer *, doublereal *, integer
+ *);
+ doublereal amninv;
+ integer minwrk;
+ doublereal rtunfl, rtovfl, ulpinv, result[19];
+ integer mtypes;
+
+ /* Fortran I/O blocks */
+ static cilist io___39 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKBD checks the singular value decomposition (SVD) routines. */
+
+/* DGEBRD reduces a real general m by n matrix A to upper or lower */
+/* bidiagonal form B by an orthogonal transformation: Q' * A * P = B */
+/* (or A = Q * B * P'). The matrix B is upper bidiagonal if m >= n */
+/* and lower bidiagonal if m < n. */
+
+/* DORGBR generates the orthogonal matrices Q and P' from DGEBRD. */
+/* Note that Q and P are not necessarily square. */
+
+/* DBDSQR computes the singular value decomposition of the bidiagonal */
+/* matrix B as B = U S V'. It is called three times to compute */
+/* 1) B = U S1 V', where S1 is the diagonal matrix of singular */
+/* values and the columns of the matrices U and V are the left */
+/* and right singular vectors, respectively, of B. */
+/* 2) Same as 1), but the singular values are stored in S2 and the */
+/* singular vectors are not computed. */
+/* 3) A = (UQ) S (P'V'), the SVD of the original matrix A. */
+/* In addition, DBDSQR has an option to apply the left orthogonal matrix */
+/* U to a matrix X, useful in least squares applications. */
+
+/* DBDSDC computes the singular value decomposition of the bidiagonal */
+/* matrix B as B = U S V' using divide-and-conquer. It is called twice */
+/* to compute */
+/* 1) B = U S1 V', where S1 is the diagonal matrix of singular */
+/* values and the columns of the matrices U and V are the left */
+/* and right singular vectors, respectively, of B. */
+/* 2) Same as 1), but the singular values are stored in S2 and the */
+/* singular vectors are not computed. */
+
+/* For each pair of matrix dimensions (M,N) and each selected matrix */
+/* type, an M by N matrix A and an M by NRHS matrix X are generated. */
+/* The problem dimensions are as follows */
+/* A: M x N */
+/* Q: M x min(M,N) (but M x M if NRHS > 0) */
+/* P: min(M,N) x N */
+/* B: min(M,N) x min(M,N) */
+/* U, V: min(M,N) x min(M,N) */
+/* S1, S2 diagonal, order min(M,N) */
+/* X: M x NRHS */
+
+/* For each generated matrix, 14 tests are performed: */
+
+/* Test DGEBRD and DORGBR */
+
+/* (1) | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P' */
+
+/* (2) | I - Q' Q | / ( M ulp ) */
+
+/* (3) | I - PT PT' | / ( N ulp ) */
+
+/* Test DBDSQR on bidiagonal matrix B */
+
+/* (4) | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V' */
+
+/* (5) | Y - U Z | / ( |Y| max(min(M,N),k) ulp ), where Y = Q' X */
+/* and Z = U' Y. */
+/* (6) | I - U' U | / ( min(M,N) ulp ) */
+
+/* (7) | I - VT VT' | / ( min(M,N) ulp ) */
+
+/* (8) S1 contains min(M,N) nonnegative values in decreasing order. */
+/* (Return 0 if true, 1/ULP if false.) */
+
+/* (9) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without */
+/* computing U and V. */
+
+/* (10) 0 if the true singular values of B are within THRESH of */
+/* those in S1. 2*THRESH if they are not. (Tested using */
+/* DSVDCH) */
+
+/* Test DBDSQR on matrix A */
+
+/* (11) | A - (QU) S (VT PT) | / ( |A| max(M,N) ulp ) */
+
+/* (12) | X - (QU) Z | / ( |X| max(M,k) ulp ) */
+
+/* (13) | I - (QU)'(QU) | / ( M ulp ) */
+
+/* (14) | I - (VT PT) (PT'VT') | / ( N ulp ) */
+
+/* Test DBDSDC on bidiagonal matrix B */
+
+/* (15) | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V' */
+
+/* (16) | I - U' U | / ( min(M,N) ulp ) */
+
+/* (17) | I - VT VT' | / ( min(M,N) ulp ) */
+
+/* (18) S1 contains min(M,N) nonnegative values in decreasing order. */
+/* (Return 0 if true, 1/ULP if false.) */
+
+/* (19) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without */
+/* computing U and V. */
+/* The possible matrix types are */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (6) Same as (3), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (3), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) Rectangular matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
+
+/* Special case: */
+/* (16) A bidiagonal matrix with random entries chosen from a */
+/* logarithmic distribution on [ulp^2,ulp^(-2)] (I.e., each */
+/* entry is e^x, where x is chosen uniformly on */
+/* [ 2 log(ulp), -2 log(ulp) ] .) For *this* type: */
+/* (a) DGEBRD is not called to reduce it to bidiagonal form. */
+/* (b) the bidiagonal is min(M,N) x min(M,N); if M<N, the */
+/* matrix will be lower bidiagonal, otherwise upper. */
+/* (c) only tests 5--8 and 14 are performed. */
+
+/* A subset of the full set of matrix types may be selected through */
+/* the logical array DOTYPE. */
+
+/* Arguments */
+/* ========== */
+
+/* NSIZES (input) INTEGER */
+/* The number of values of M and N contained in the vectors */
+/* MVAL and NVAL. The matrix sizes are used in pairs (M,N). */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix column dimension N. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, DCHKBD */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrices are in A and B. */
+/* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size (m,n), a matrix */
+/* of type j will be generated. If NTYPES is smaller than the */
+/* maximum number of types defined (PARAMETER MAXTYP), then */
+/* types NTYPES+1 through MAXTYP will not be generated. If */
+/* NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through */
+/* DOTYPE(NTYPES) will be ignored. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns in the "right-hand side" matrices X, Y, */
+/* and Z, used in testing DBDSQR. If NRHS = 0, then the */
+/* operations on the right-hand side will not be tested. */
+/* NRHS must be at least 0. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The values of ISEED are changed on exit, and can be */
+/* used in the next call to DCHKBD to continue the same random */
+/* number sequence. */
+
+/* THRESH (input) 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. Note that the */
+/* expected value of the test ratios is O(1), so THRESH should */
+/* be a reasonably small multiple of 1, e.g., 10 or 100. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) */
+/* where NMAX is the maximum value of N in NVAL. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,MMAX), */
+/* where MMAX is the maximum value of M in MVAL. */
+
+/* BD (workspace) DOUBLE PRECISION array, dimension */
+/* (max(min(MVAL(j),NVAL(j)))) */
+
+/* BE (workspace) DOUBLE PRECISION array, dimension */
+/* (max(min(MVAL(j),NVAL(j)))) */
+
+/* S1 (workspace) DOUBLE PRECISION array, dimension */
+/* (max(min(MVAL(j),NVAL(j)))) */
+
+/* S2 (workspace) DOUBLE PRECISION array, dimension */
+/* (max(min(MVAL(j),NVAL(j)))) */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the arrays X, Y, and Z. */
+/* LDX >= max(1,MMAX) */
+
+/* Y (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+
+/* Z (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+
+/* Q (workspace) DOUBLE PRECISION array, dimension (LDQ,MMAX) */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,MMAX). */
+
+/* PT (workspace) DOUBLE PRECISION array, dimension (LDPT,NMAX) */
+
+/* LDPT (input) INTEGER */
+/* The leading dimension of the arrays PT, U, and V. */
+/* LDPT >= max(1, max(min(MVAL(j),NVAL(j)))). */
+
+/* U (workspace) DOUBLE PRECISION array, dimension */
+/* (LDPT,max(min(MVAL(j),NVAL(j)))) */
+
+/* V (workspace) DOUBLE PRECISION array, dimension */
+/* (LDPT,max(min(MVAL(j),NVAL(j)))) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 3(M+N) and M(M + max(M,N,k) + 1) + N*min(M,N) for all */
+/* pairs (M,N)=(MM(j),NN(j)) */
+
+/* IWORK (workspace) INTEGER array, dimension at least 8*min(M,N) */
+
+/* NOUT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some MM(j) < 0 */
+/* -3: Some NN(j) < 0 */
+/* -4: NTYPES < 0 */
+/* -6: NRHS < 0 */
+/* -8: THRESH < 0 */
+/* -11: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ). */
+/* -17: LDB < 1 or LDB < MMAX. */
+/* -21: LDQ < 1 or LDQ < MMAX. */
+/* -23: LDPT< 1 or LDPT< MNMAX. */
+/* -27: LWORK too small. */
+/* If DLATMR, SLATMS, DGEBRD, DORGBR, or DBDSQR, */
+/* returns an error code, the */
+/* absolute value of it is returned. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests performed, or which can */
+/* be performed so far, for the current matrix. */
+/* MMAX Largest value in NN. */
+/* NMAX Largest value in NN. */
+/* MNMIN min(MM(j), NN(j)) (the dimension of the bidiagonal */
+/* matrix.) */
+/* MNMAX The maximum value of MNMIN for j=1,...,NSIZES. */
+/* NFAIL The number of tests which have exceeded THRESH */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* ====================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --mval;
+ --nval;
+ --dotype;
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --bd;
+ --be;
+ --s1;
+ --s2;
+ z_dim1 = *ldx;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ y_dim1 = *ldx;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ vt_dim1 = *ldpt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ u_dim1 = *ldpt;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ pt_dim1 = *ldpt;
+ pt_offset = 1 + pt_dim1;
+ pt -= pt_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+
+ badmm = FALSE_;
+ badnn = FALSE_;
+ mmax = 1;
+ nmax = 1;
+ mnmax = 1;
+ minwrk = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = mmax, i__3 = mval[j];
+ mmax = max(i__2,i__3);
+ if (mval[j] < 0) {
+ badmm = TRUE_;
+ }
+/* Computing MAX */
+ i__2 = nmax, i__3 = nval[j];
+ nmax = max(i__2,i__3);
+ if (nval[j] < 0) {
+ badnn = TRUE_;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__4 = mval[j], i__5 = nval[j];
+ i__2 = mnmax, i__3 = min(i__4,i__5);
+ mnmax = max(i__2,i__3);
+/* Computing MAX */
+/* Computing MAX */
+ i__4 = mval[j], i__5 = nval[j], i__4 = max(i__4,i__5);
+/* Computing MIN */
+ i__6 = nval[j], i__7 = mval[j];
+ i__2 = minwrk, i__3 = (mval[j] + nval[j]) * 3, i__2 = max(i__2,i__3),
+ i__3 = mval[j] * (mval[j] + max(i__4,*nrhs) + 1) + nval[j] *
+ min(i__6,i__7);
+ minwrk = max(i__2,i__3);
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badmm) {
+ *info = -2;
+ } else if (badnn) {
+ *info = -3;
+ } else if (*ntypes < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*lda < mmax) {
+ *info = -11;
+ } else if (*ldx < mmax) {
+ *info = -17;
+ } else if (*ldq < mmax) {
+ *info = -21;
+ } else if (*ldpt < mnmax) {
+ *info = -23;
+ } else if (minwrk > *lwork) {
+ *info = -27;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DCHKBD", &i__1);
+ return 0;
+ }
+
+/* Initialize constants */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "BD", (ftnlen)2, (ftnlen)2);
+ nfail = 0;
+ ntest = 0;
+ unfl = dlamch_("Safe minimum");
+ ovfl = dlamch_("Overflow");
+ dlabad_(&unfl, &ovfl);
+ ulp = dlamch_("Precision");
+ ulpinv = 1. / ulp;
+ log2ui = (integer) (log(ulpinv) / log(2.));
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+ infoc_1.infot = 0;
+
+/* Loop over sizes, types */
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ m = mval[jsize];
+ n = nval[jsize];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__2 = max(m,n);
+ amninv = 1. / max(i__2,1);
+
+ if (*nsizes != 1) {
+ mtypes = min(16,*ntypes);
+ } else {
+ mtypes = min(17,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L190;
+ }
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+ for (j = 1; j <= 14; ++j) {
+ result[j - 1] = -1.;
+/* L30: */
+ }
+
+ *(unsigned char *)uplo = ' ';
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random symmetric, w/ eigenvalues */
+/* =6 nonsymmetric, w/ singular values */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 random nonsymmetric */
+/* =10 random bidiagonal (log. distrib.) */
+
+ if (mtypes > 16) {
+ goto L100;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * amninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * max(m,n) * ulpinv;
+ goto L70;
+
+L70:
+
+ dlaset_("Full", lda, &n, &c_b20, &c_b20, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+ bidiag = FALSE_;
+ if (itype == 1) {
+
+/* Zero matrix */
+
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = mnmin;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ dlatms_(&mnmin, &mnmin, "S", &iseed[1], "N", &work[1], &imode,
+ &cond, &anorm, &c__0, &c__0, "N", &a[a_offset], lda,
+ &work[mnmin + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ dlatms_(&mnmin, &mnmin, "S", &iseed[1], "S", &work[1], &imode,
+ &cond, &anorm, &m, &n, "N", &a[a_offset], lda, &work[
+ mnmin + 1], &iinfo);
+
+ } else if (itype == 6) {
+
+/* Nonsymmetric, singular values specified */
+
+ dlatms_(&m, &n, "S", &iseed[1], "N", &work[1], &imode, &cond,
+ &anorm, &m, &n, "N", &a[a_offset], lda, &work[mnmin +
+ 1], &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random entries */
+
+ dlatmr_(&mnmin, &mnmin, "S", &iseed[1], "N", &work[1], &c__6,
+ &c_b37, &c_b37, "T", "N", &work[mnmin + 1], &c__1, &
+ c_b37, &work[(mnmin << 1) + 1], &c__1, &c_b37, "N", &
+ iwork[1], &c__0, &c__0, &c_b20, &anorm, "NO", &a[
+ a_offset], lda, &iwork[1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random entries */
+
+ dlatmr_(&mnmin, &mnmin, "S", &iseed[1], "S", &work[1], &c__6,
+ &c_b37, &c_b37, "T", "N", &work[mnmin + 1], &c__1, &
+ c_b37, &work[m + mnmin + 1], &c__1, &c_b37, "N", &
+ iwork[1], &m, &n, &c_b20, &anorm, "NO", &a[a_offset],
+ lda, &iwork[1], &iinfo);
+
+ } else if (itype == 9) {
+
+/* Nonsymmetric, random entries */
+
+ dlatmr_(&m, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b37,
+ &c_b37, "T", "N", &work[mnmin + 1], &c__1, &c_b37, &
+ work[m + mnmin + 1], &c__1, &c_b37, "N", &iwork[1], &
+ m, &n, &c_b20, &anorm, "NO", &a[a_offset], lda, &
+ iwork[1], &iinfo);
+
+ } else if (itype == 10) {
+
+/* Bidiagonal, random entries */
+
+ temp1 = log(ulp) * -2.;
+ i__3 = mnmin;
+ for (j = 1; j <= i__3; ++j) {
+ bd[j] = exp(temp1 * dlarnd_(&c__2, &iseed[1]));
+ if (j < mnmin) {
+ be[j] = exp(temp1 * dlarnd_(&c__2, &iseed[1]));
+ }
+/* L90: */
+ }
+
+ iinfo = 0;
+ bidiag = TRUE_;
+ if (m >= n) {
+ *(unsigned char *)uplo = 'U';
+ } else {
+ *(unsigned char *)uplo = 'L';
+ }
+ } else {
+ iinfo = 1;
+ }
+
+ if (iinfo == 0) {
+
+/* Generate Right-Hand Side */
+
+ if (bidiag) {
+ dlatmr_(&mnmin, nrhs, "S", &iseed[1], "N", &work[1], &
+ c__6, &c_b37, &c_b37, "T", "N", &work[mnmin + 1],
+ &c__1, &c_b37, &work[(mnmin << 1) + 1], &c__1, &
+ c_b37, "N", &iwork[1], &mnmin, nrhs, &c_b20, &
+ c_b37, "NO", &y[y_offset], ldx, &iwork[1], &iinfo);
+ } else {
+ dlatmr_(&m, nrhs, "S", &iseed[1], "N", &work[1], &c__6, &
+ c_b37, &c_b37, "T", "N", &work[m + 1], &c__1, &
+ c_b37, &work[(m << 1) + 1], &c__1, &c_b37, "N", &
+ iwork[1], &m, nrhs, &c_b20, &c_b37, "NO", &x[
+ x_offset], ldx, &iwork[1], &iinfo);
+ }
+ }
+
+/* Error Exit */
+
+ if (iinfo != 0) {
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L100:
+
+/* Call DGEBRD and DORGBR to compute B, Q, and P, do tests. */
+
+ if (! bidiag) {
+
+/* Compute transformations to reduce A to bidiagonal form: */
+/* B := Q' * A * P. */
+
+ dlacpy_(" ", &m, &n, &a[a_offset], lda, &q[q_offset], ldq);
+ i__3 = *lwork - (mnmin << 1);
+ dgebrd_(&m, &n, &q[q_offset], ldq, &bd[1], &be[1], &work[1], &
+ work[mnmin + 1], &work[(mnmin << 1) + 1], &i__3, &
+ iinfo);
+
+/* Check error code from DGEBRD. */
+
+ if (iinfo != 0) {
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "DGEBRD", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+ dlacpy_(" ", &m, &n, &q[q_offset], ldq, &pt[pt_offset], ldpt);
+ if (m >= n) {
+ *(unsigned char *)uplo = 'U';
+ } else {
+ *(unsigned char *)uplo = 'L';
+ }
+
+/* Generate Q */
+
+ mq = m;
+ if (*nrhs <= 0) {
+ mq = mnmin;
+ }
+ i__3 = *lwork - (mnmin << 1);
+ dorgbr_("Q", &m, &mq, &n, &q[q_offset], ldq, &work[1], &work[(
+ mnmin << 1) + 1], &i__3, &iinfo);
+
+/* Check error code from DORGBR. */
+
+ if (iinfo != 0) {
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "DORGBR(Q)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Generate P' */
+
+ i__3 = *lwork - (mnmin << 1);
+ dorgbr_("P", &mnmin, &n, &m, &pt[pt_offset], ldpt, &work[
+ mnmin + 1], &work[(mnmin << 1) + 1], &i__3, &iinfo);
+
+/* Check error code from DORGBR. */
+
+ if (iinfo != 0) {
+ io___43.ciunit = *nout;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "DORGBR(P)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Apply Q' to an M by NRHS matrix X: Y := Q' * X. */
+
+ dgemm_("Transpose", "No transpose", &m, nrhs, &m, &c_b37, &q[
+ q_offset], ldq, &x[x_offset], ldx, &c_b20, &y[
+ y_offset], ldx);
+
+/* Test 1: Check the decomposition A := Q * B * PT */
+/* 2: Check the orthogonality of Q */
+/* 3: Check the orthogonality of PT */
+
+ dbdt01_(&m, &n, &c__1, &a[a_offset], lda, &q[q_offset], ldq, &
+ bd[1], &be[1], &pt[pt_offset], ldpt, &work[1], result)
+ ;
+ dort01_("Columns", &m, &mq, &q[q_offset], ldq, &work[1],
+ lwork, &result[1]);
+ dort01_("Rows", &mnmin, &n, &pt[pt_offset], ldpt, &work[1],
+ lwork, &result[2]);
+ }
+
+/* Use DBDSQR to form the SVD of the bidiagonal matrix B: */
+/* B := U * S1 * VT, and compute Z = U' * Y. */
+
+ dcopy_(&mnmin, &bd[1], &c__1, &s1[1], &c__1);
+ if (mnmin > 0) {
+ i__3 = mnmin - 1;
+ dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
+ }
+ dlacpy_(" ", &m, nrhs, &y[y_offset], ldx, &z__[z_offset], ldx);
+ dlaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &u[u_offset],
+ ldpt);
+ dlaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &vt[vt_offset],
+ ldpt);
+
+ dbdsqr_(uplo, &mnmin, &mnmin, &mnmin, nrhs, &s1[1], &work[1], &vt[
+ vt_offset], ldpt, &u[u_offset], ldpt, &z__[z_offset], ldx,
+ &work[mnmin + 1], &iinfo);
+
+/* Check error code from DBDSQR. */
+
+ if (iinfo != 0) {
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "DBDSQR(vects)", (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[3] = ulpinv;
+ goto L170;
+ }
+ }
+
+/* Use DBDSQR to compute only the singular values of the */
+/* bidiagonal matrix B; U, VT, and Z should not be modified. */
+
+ dcopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
+ if (mnmin > 0) {
+ i__3 = mnmin - 1;
+ dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
+ }
+
+ dbdsqr_(uplo, &mnmin, &c__0, &c__0, &c__0, &s2[1], &work[1], &vt[
+ vt_offset], ldpt, &u[u_offset], ldpt, &z__[z_offset], ldx,
+ &work[mnmin + 1], &iinfo);
+
+/* Check error code from DBDSQR. */
+
+ if (iinfo != 0) {
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "DBDSQR(values)", (ftnlen)14);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[8] = ulpinv;
+ goto L170;
+ }
+ }
+
+/* Test 4: Check the decomposition B := U * S1 * VT */
+/* 5: Check the computation Z := U' * Y */
+/* 6: Check the orthogonality of U */
+/* 7: Check the orthogonality of VT */
+
+ dbdt03_(uplo, &mnmin, &c__1, &bd[1], &be[1], &u[u_offset], ldpt, &
+ s1[1], &vt[vt_offset], ldpt, &work[1], &result[3]);
+ dbdt02_(&mnmin, nrhs, &y[y_offset], ldx, &z__[z_offset], ldx, &u[
+ u_offset], ldpt, &work[1], &result[4]);
+ dort01_("Columns", &mnmin, &mnmin, &u[u_offset], ldpt, &work[1],
+ lwork, &result[5]);
+ dort01_("Rows", &mnmin, &mnmin, &vt[vt_offset], ldpt, &work[1],
+ lwork, &result[6]);
+
+/* Test 8: Check that the singular values are sorted in */
+/* non-increasing order and are non-negative */
+
+ result[7] = 0.;
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (s1[i__] < s1[i__ + 1]) {
+ result[7] = ulpinv;
+ }
+ if (s1[i__] < 0.) {
+ result[7] = ulpinv;
+ }
+/* L110: */
+ }
+ if (mnmin >= 1) {
+ if (s1[mnmin] < 0.) {
+ result[7] = ulpinv;
+ }
+ }
+
+/* Test 9: Compare DBDSQR with and without singular vectors */
+
+ temp2 = 0.;
+
+ i__3 = mnmin;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+/* Computing MAX */
+ d__6 = (d__1 = s1[j], abs(d__1)), d__7 = (d__2 = s2[j], abs(
+ d__2));
+ d__4 = sqrt(unfl) * max(s1[1],1.), d__5 = ulp * max(d__6,d__7)
+ ;
+ temp1 = (d__3 = s1[j] - s2[j], abs(d__3)) / max(d__4,d__5);
+ temp2 = max(temp1,temp2);
+/* L120: */
+ }
+
+ result[8] = temp2;
+
+/* Test 10: Sturm sequence test of singular values */
+/* Go up by factors of two until it succeeds */
+
+ temp1 = *thresh * (.5 - ulp);
+
+ i__3 = log2ui;
+ for (j = 0; j <= i__3; ++j) {
+/* CALL DSVDCH( MNMIN, BD, BE, S1, TEMP1, IINFO ) */
+ if (iinfo == 0) {
+ goto L140;
+ }
+ temp1 *= 2.;
+/* L130: */
+ }
+
+L140:
+ result[9] = temp1;
+
+/* Use DBDSQR to form the decomposition A := (QU) S (VT PT) */
+/* from the bidiagonal form A := Q B PT. */
+
+ if (! bidiag) {
+ dcopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
+ if (mnmin > 0) {
+ i__3 = mnmin - 1;
+ dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
+ }
+
+ dbdsqr_(uplo, &mnmin, &n, &m, nrhs, &s2[1], &work[1], &pt[
+ pt_offset], ldpt, &q[q_offset], ldq, &y[y_offset],
+ ldx, &work[mnmin + 1], &iinfo);
+
+/* Test 11: Check the decomposition A := Q*U * S2 * VT*PT */
+/* 12: Check the computation Z := U' * Q' * X */
+/* 13: Check the orthogonality of Q*U */
+/* 14: Check the orthogonality of VT*PT */
+
+ dbdt01_(&m, &n, &c__0, &a[a_offset], lda, &q[q_offset], ldq, &
+ s2[1], dumma, &pt[pt_offset], ldpt, &work[1], &result[
+ 10]);
+ dbdt02_(&m, nrhs, &x[x_offset], ldx, &y[y_offset], ldx, &q[
+ q_offset], ldq, &work[1], &result[11]);
+ dort01_("Columns", &m, &mq, &q[q_offset], ldq, &work[1],
+ lwork, &result[12]);
+ dort01_("Rows", &mnmin, &n, &pt[pt_offset], ldpt, &work[1],
+ lwork, &result[13]);
+ }
+
+/* Use DBDSDC to form the SVD of the bidiagonal matrix B: */
+/* B := U * S1 * VT */
+
+ dcopy_(&mnmin, &bd[1], &c__1, &s1[1], &c__1);
+ if (mnmin > 0) {
+ i__3 = mnmin - 1;
+ dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
+ }
+ dlaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &u[u_offset],
+ ldpt);
+ dlaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &vt[vt_offset],
+ ldpt);
+
+ dbdsdc_(uplo, "I", &mnmin, &s1[1], &work[1], &u[u_offset], ldpt, &
+ vt[vt_offset], ldpt, dum, idum, &work[mnmin + 1], &iwork[
+ 1], &iinfo);
+
+/* Check error code from DBDSDC. */
+
+ if (iinfo != 0) {
+ io___51.ciunit = *nout;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "DBDSDC(vects)", (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[14] = ulpinv;
+ goto L170;
+ }
+ }
+
+/* Use DBDSDC to compute only the singular values of the */
+/* bidiagonal matrix B; U and VT should not be modified. */
+
+ dcopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
+ if (mnmin > 0) {
+ i__3 = mnmin - 1;
+ dcopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
+ }
+
+ dbdsdc_(uplo, "N", &mnmin, &s2[1], &work[1], dum, &c__1, dum, &
+ c__1, dum, idum, &work[mnmin + 1], &iwork[1], &iinfo);
+
+/* Check error code from DBDSDC. */
+
+ if (iinfo != 0) {
+ io___52.ciunit = *nout;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "DBDSDC(values)", (ftnlen)14);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[17] = ulpinv;
+ goto L170;
+ }
+ }
+
+/* Test 15: Check the decomposition B := U * S1 * VT */
+/* 16: Check the orthogonality of U */
+/* 17: Check the orthogonality of VT */
+
+ dbdt03_(uplo, &mnmin, &c__1, &bd[1], &be[1], &u[u_offset], ldpt, &
+ s1[1], &vt[vt_offset], ldpt, &work[1], &result[14]);
+ dort01_("Columns", &mnmin, &mnmin, &u[u_offset], ldpt, &work[1],
+ lwork, &result[15]);
+ dort01_("Rows", &mnmin, &mnmin, &vt[vt_offset], ldpt, &work[1],
+ lwork, &result[16]);
+
+/* Test 18: Check that the singular values are sorted in */
+/* non-increasing order and are non-negative */
+
+ result[17] = 0.;
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (s1[i__] < s1[i__ + 1]) {
+ result[17] = ulpinv;
+ }
+ if (s1[i__] < 0.) {
+ result[17] = ulpinv;
+ }
+/* L150: */
+ }
+ if (mnmin >= 1) {
+ if (s1[mnmin] < 0.) {
+ result[17] = ulpinv;
+ }
+ }
+
+/* Test 19: Compare DBDSQR with and without singular vectors */
+
+ temp2 = 0.;
+
+ i__3 = mnmin;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+/* Computing MAX */
+ d__4 = abs(s1[1]), d__5 = abs(s2[1]);
+ d__2 = sqrt(unfl) * max(s1[1],1.), d__3 = ulp * max(d__4,d__5)
+ ;
+ temp1 = (d__1 = s1[j] - s2[j], abs(d__1)) / max(d__2,d__3);
+ temp2 = max(temp1,temp2);
+/* L160: */
+ }
+
+ result[18] = temp2;
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L170:
+ for (j = 1; j <= 19; ++j) {
+ if (result[j - 1] >= *thresh) {
+ if (nfail == 0) {
+ dlahd2_(nout, path);
+ }
+ io___53.ciunit = *nout;
+ s_wsfe(&io___53);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L180: */
+ }
+ if (! bidiag) {
+ ntest += 19;
+ } else {
+ ntest += 5;
+ }
+
+L190:
+ ;
+ }
+/* L200: */
+ }
+
+/* Summary */
+
+ alasum_(path, nout, &nfail, &ntest, &c__0);
+
+ return 0;
+
+/* End of DCHKBD */
+
+
+} /* dchkbd_ */
diff --git a/TESTING/EIG/dchkbk.c b/TESTING/EIG/dchkbk.c
new file mode 100644
index 0000000..2b6a347
--- /dev/null
+++ b/TESTING/EIG/dchkbk.c
@@ -0,0 +1,233 @@
+/* dchkbk.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__5 = 5;
+static integer c__20 = 20;
+
+/* Subroutine */ int dchkbk_(integer *nin, integer *nout)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002.. test output of DGEBAK .. \002)";
+ static char fmt_9998[] = "(1x,\002value of largest test error "
+ " = \002,d12.3)";
+ static char fmt_9997[] = "(1x,\002example number where info is not zero "
+ " = \002,i4)";
+ static char fmt_9996[] = "(1x,\002example number having largest error "
+ " = \002,i4)";
+ static char fmt_9995[] = "(1x,\002number of examples where info is not 0"
+ " = \002,i4)";
+ static char fmt_9994[] = "(1x,\002total number of examples tested "
+ " = \002,i4)";
+
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void), s_wsfe(cilist *), e_wsfe(void), do_fio(integer *,
+ char *, ftnlen);
+
+ /* Local variables */
+ doublereal e[400] /* was [20][20] */;
+ integer i__, j, n;
+ doublereal x;
+ integer ihi;
+ doublereal ein[400] /* was [20][20] */;
+ integer ilo;
+ doublereal eps;
+ integer knt, info, lmax[2];
+ doublereal rmax, vmax, scale[20];
+ integer ninfo;
+ extern /* Subroutine */ int dgebak_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *);
+ extern doublereal dlamch_(char *);
+ doublereal safmin;
+
+ /* Fortran I/O blocks */
+ static cilist io___7 = { 0, 0, 0, 0, 0 };
+ static cilist io___11 = { 0, 0, 0, 0, 0 };
+ static cilist io___14 = { 0, 0, 0, 0, 0 };
+ static cilist io___17 = { 0, 0, 0, 0, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___26 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKBK tests DGEBAK, a routine for backward transformation of */
+/* the computed right or left eigenvectors if the orginal matrix */
+/* was preprocessed by balance subroutine DGEBAL. */
+
+/* Arguments */
+/* ========= */
+
+/* NIN (input) INTEGER */
+/* The logical unit number for input. NIN > 0. */
+
+/* NOUT (input) INTEGER */
+/* The logical unit number for output. NOUT > 0. */
+
+/* ====================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ lmax[0] = 0;
+ lmax[1] = 0;
+ ninfo = 0;
+ knt = 0;
+ rmax = 0.;
+ eps = dlamch_("E");
+ safmin = dlamch_("S");
+
+L10:
+
+ io___7.ciunit = *nin;
+ s_rsle(&io___7);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ilo, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ihi, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ goto L60;
+ }
+
+ io___11.ciunit = *nin;
+ s_rsle(&io___11);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__5, &c__1, (char *)&scale[i__ - 1], (ftnlen)sizeof(
+ doublereal));
+ }
+ e_rsle();
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___14.ciunit = *nin;
+ s_rsle(&io___14);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__5, &c__1, (char *)&e[i__ + j * 20 - 21], (ftnlen)
+ sizeof(doublereal));
+ }
+ e_rsle();
+/* L20: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___17.ciunit = *nin;
+ s_rsle(&io___17);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__5, &c__1, (char *)&ein[i__ + j * 20 - 21], (ftnlen)
+ sizeof(doublereal));
+ }
+ e_rsle();
+/* L30: */
+ }
+
+ ++knt;
+ dgebak_("B", "R", &n, &ilo, &ihi, scale, &n, e, &c__20, &info);
+
+ if (info != 0) {
+ ++ninfo;
+ lmax[0] = knt;
+ }
+
+ vmax = 0.;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ x = (d__1 = e[i__ + j * 20 - 21] - ein[i__ + j * 20 - 21], abs(
+ d__1)) / eps;
+ if ((d__1 = e[i__ + j * 20 - 21], abs(d__1)) > safmin) {
+ x /= (d__2 = e[i__ + j * 20 - 21], abs(d__2));
+ }
+ vmax = max(vmax,x);
+/* L40: */
+ }
+/* L50: */
+ }
+
+ if (vmax > rmax) {
+ lmax[1] = knt;
+ rmax = vmax;
+ }
+
+ goto L10;
+
+L60:
+
+ io___22.ciunit = *nout;
+ s_wsfe(&io___22);
+ e_wsfe();
+
+ io___23.ciunit = *nout;
+ s_wsfe(&io___23);
+ do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ io___24.ciunit = *nout;
+ s_wsfe(&io___24);
+ do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___25.ciunit = *nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ return 0;
+
+/* End of DCHKBK */
+
+} /* dchkbk_ */
diff --git a/TESTING/EIG/dchkbl.c b/TESTING/EIG/dchkbl.c
new file mode 100644
index 0000000..bdf2c52
--- /dev/null
+++ b/TESTING/EIG/dchkbl.c
@@ -0,0 +1,263 @@
+/* dchkbl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__5 = 5;
+static integer c__20 = 20;
+
+/* Subroutine */ int dchkbl_(integer *nin, integer *nout)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002.. test output of DGEBAL .. \002)";
+ static char fmt_9998[] = "(1x,\002value of largest test error "
+ " = \002,d12.3)";
+ static char fmt_9997[] = "(1x,\002example number where info is not zero "
+ " = \002,i4)";
+ static char fmt_9996[] = "(1x,\002example number where ILO or IHI wrong "
+ " = \002,i4)";
+ static char fmt_9995[] = "(1x,\002example number having largest error "
+ " = \002,i4)";
+ static char fmt_9994[] = "(1x,\002number of examples where info is not 0"
+ " = \002,i4)";
+ static char fmt_9993[] = "(1x,\002total number of examples tested "
+ " = \002,i4)";
+
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void), s_wsfe(cilist *), e_wsfe(void), do_fio(integer *,
+ char *, ftnlen);
+
+ /* Local variables */
+ doublereal a[400] /* was [20][20] */;
+ integer i__, j, n;
+ doublereal ain[400] /* was [20][20] */;
+ integer ihi, ilo, knt, info, lmax[3];
+ doublereal meps, temp, rmax, vmax, scale[20];
+ integer ihiin, ninfo, iloin;
+ doublereal anorm, sfmin, dummy[1];
+ extern /* Subroutine */ int dgebal_(char *, integer *, doublereal *,
+ integer *, integer *, integer *, doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ doublereal scalin[20];
+
+ /* Fortran I/O blocks */
+ static cilist io___8 = { 0, 0, 0, 0, 0 };
+ static cilist io___11 = { 0, 0, 0, 0, 0 };
+ static cilist io___14 = { 0, 0, 0, 0, 0 };
+ static cilist io___17 = { 0, 0, 0, 0, 0 };
+ static cilist io___19 = { 0, 0, 0, 0, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKBL tests DGEBAL, a routine for balancing a general real */
+/* matrix and isolating some of its eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* NIN (input) INTEGER */
+/* The logical unit number for input. NIN > 0. */
+
+/* NOUT (input) INTEGER */
+/* The logical unit number for output. NOUT > 0. */
+
+/* ====================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ lmax[0] = 0;
+ lmax[1] = 0;
+ lmax[2] = 0;
+ ninfo = 0;
+ knt = 0;
+ rmax = 0.;
+ vmax = 0.;
+ sfmin = dlamch_("S");
+ meps = dlamch_("E");
+
+L10:
+
+ io___8.ciunit = *nin;
+ s_rsle(&io___8);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ goto L70;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___11.ciunit = *nin;
+ s_rsle(&io___11);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__5, &c__1, (char *)&a[i__ + j * 20 - 21], (ftnlen)
+ sizeof(doublereal));
+ }
+ e_rsle();
+/* L20: */
+ }
+
+ io___14.ciunit = *nin;
+ s_rsle(&io___14);
+ do_lio(&c__3, &c__1, (char *)&iloin, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ihiin, (ftnlen)sizeof(integer));
+ e_rsle();
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___17.ciunit = *nin;
+ s_rsle(&io___17);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__5, &c__1, (char *)&ain[i__ + j * 20 - 21], (ftnlen)
+ sizeof(doublereal));
+ }
+ e_rsle();
+/* L30: */
+ }
+ io___19.ciunit = *nin;
+ s_rsle(&io___19);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__5, &c__1, (char *)&scalin[i__ - 1], (ftnlen)sizeof(
+ doublereal));
+ }
+ e_rsle();
+
+ anorm = dlange_("M", &n, &n, a, &c__20, dummy);
+ ++knt;
+
+ dgebal_("B", &n, a, &c__20, &ilo, &ihi, scale, &info);
+
+ if (info != 0) {
+ ++ninfo;
+ lmax[0] = knt;
+ }
+
+ if (ilo != iloin || ihi != ihiin) {
+ ++ninfo;
+ lmax[1] = knt;
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ d__1 = a[i__ + j * 20 - 21], d__2 = ain[i__ + j * 20 - 21];
+ temp = max(d__1,d__2);
+ temp = max(temp,sfmin);
+/* Computing MAX */
+ d__2 = vmax, d__3 = (d__1 = a[i__ + j * 20 - 21] - ain[i__ + j *
+ 20 - 21], abs(d__1)) / temp;
+ vmax = max(d__2,d__3);
+/* L40: */
+ }
+/* L50: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = scale[i__ - 1], d__2 = scalin[i__ - 1];
+ temp = max(d__1,d__2);
+ temp = max(temp,sfmin);
+/* Computing MAX */
+ d__2 = vmax, d__3 = (d__1 = scale[i__ - 1] - scalin[i__ - 1], abs(
+ d__1)) / temp;
+ vmax = max(d__2,d__3);
+/* L60: */
+ }
+
+
+ if (vmax > rmax) {
+ lmax[2] = knt;
+ rmax = vmax;
+ }
+
+ goto L10;
+
+L70:
+
+ io___28.ciunit = *nout;
+ s_wsfe(&io___28);
+ e_wsfe();
+
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ return 0;
+
+/* End of DCHKBL */
+
+} /* dchkbl_ */
diff --git a/TESTING/EIG/dchkec.c b/TESTING/EIG/dchkec.c
new file mode 100644
index 0000000..cb818d1
--- /dev/null
+++ b/TESTING/EIG/dchkec.c
@@ -0,0 +1,309 @@
+/* dchkec.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+
+/* Subroutine */ int dchkec_(doublereal *thresh, logical *tsterr, integer *
+ nin, integer *nout)
+{
+ /* Format strings */
+ static char fmt_9989[] = "(\002 Tests of the Nonsymmetric eigenproblem c"
+ "ondition estim\002,\002ation routines\002,/\002 DLALN2, DLASY2, "
+ "DLANV2, DLAEXC, DTRS\002,\002YL, DTREXC, DTRSNA, DTRSEN, DLAQT"
+ "R\002,/)";
+ static char fmt_9988[] = "(\002 Relative machine precision (EPS) = \002,"
+ "d16.6,/\002 Safe \002,\002minimum (SFMIN) = \002,d16"
+ ".6,/)";
+ static char fmt_9987[] = "(\002 Routines pass computational tests if tes"
+ "t ratio is les\002,\002s than\002,f8.2,//)";
+ static char fmt_9999[] = "(\002 Error in DLALN2: RMAX =\002,d12.3,/\002 "
+ "LMAX = \002,i8,\002 N\002,\002INFO=\002,2i8,\002 KNT=\002,i8)";
+ static char fmt_9998[] = "(\002 Error in DLASY2: RMAX =\002,d12.3,/\002 "
+ "LMAX = \002,i8,\002 N\002,\002INFO=\002,i8,\002 KNT=\002,i8)";
+ static char fmt_9997[] = "(\002 Error in DLANV2: RMAX =\002,d12.3,/\002 "
+ "LMAX = \002,i8,\002 N\002,\002INFO=\002,i8,\002 KNT=\002,i8)";
+ static char fmt_9996[] = "(\002 Error in DLAEXC: RMAX =\002,d12.3,/\002 "
+ "LMAX = \002,i8,\002 N\002,\002INFO=\002,2i8,\002 KNT=\002,i8)";
+ static char fmt_9995[] = "(\002 Error in DTRSYL: RMAX =\002,d12.3,/\002 "
+ "LMAX = \002,i8,\002 N\002,\002INFO=\002,i8,\002 KNT=\002,i8)";
+ static char fmt_9994[] = "(\002 Error in DTREXC: RMAX =\002,d12.3,/\002 "
+ "LMAX = \002,i8,\002 N\002,\002INFO=\002,3i8,\002 KNT=\002,i8)";
+ static char fmt_9993[] = "(\002 Error in DTRSNA: RMAX =\002,3d12.3,/\002"
+ " LMAX = \002,3i8,\002 NINFO=\002,3i8,\002 KNT=\002,i8)";
+ static char fmt_9992[] = "(\002 Error in DTRSEN: RMAX =\002,3d12.3,/\002"
+ " LMAX = \002,3i8,\002 NINFO=\002,3i8,\002 KNT=\002,i8)";
+ static char fmt_9991[] = "(\002 Error in DLAQTR: RMAX =\002,d12.3,/\002 "
+ "LMAX = \002,i8,\002 N\002,\002INFO=\002,i8,\002 KNT=\002,i8)";
+ static char fmt_9990[] = "(/1x,\002All tests for \002,a3,\002 routines p"
+ "assed the thresh\002,\002old (\002,i6,\002 tests run)\002)";
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ logical ok;
+ doublereal eps;
+ char path[3];
+ extern /* Subroutine */ int dget31_(doublereal *, integer *, integer *,
+ integer *), dget32_(doublereal *, integer *, integer *, integer *)
+ , dget33_(doublereal *, integer *, integer *, integer *), dget34_(
+ doublereal *, integer *, integer *, integer *), dget35_(
+ doublereal *, integer *, integer *, integer *), dget36_(
+ doublereal *, integer *, integer *, integer *, integer *),
+ dget37_(doublereal *, integer *, integer *, integer *, integer *),
+ dget38_(doublereal *, integer *, integer *, integer *, integer *)
+ , dget39_(doublereal *, integer *, integer *, integer *);
+ doublereal sfmin;
+ integer klaln2, llaln2, nlaln2[2];
+ doublereal rlaln2;
+ integer klanv2, llanv2, nlanv2;
+ doublereal rlanv2;
+ integer klasy2, llasy2, nlasy2;
+ doublereal rlasy2;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int derrec_(char *, integer *);
+ integer klaexc, llaexc, nlaexc[2];
+ doublereal rlaexc;
+ integer klaqtr, llaqtr, ktrexc, ltrexc, ktrsna, nlaqtr, ltrsna[3];
+ doublereal rlaqtr;
+ integer ktrsen;
+ doublereal rtrexc;
+ integer ltrsen[3], ntrexc[3], ntrsen[3], ntrsna[3];
+ doublereal rtrsna[3], rtrsen[3];
+ integer ntests, ktrsyl, ltrsyl, ntrsyl;
+ doublereal rtrsyl;
+
+ /* Fortran I/O blocks */
+ static cilist io___4 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___5 = { 0, 0, 0, fmt_9988, 0 };
+ static cilist io___6 = { 0, 0, 0, fmt_9987, 0 };
+ static cilist io___12 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___17 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9990, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKEC tests eigen- condition estimation routines */
+/* DLALN2, DLASY2, DLANV2, DLAQTR, DLAEXC, */
+/* DTRSYL, DTREXC, DTRSNA, DTRSEN */
+
+/* In all cases, the routine runs through a fixed set of numerical */
+/* examples, subjects them to various tests, and compares the test */
+/* results to a threshold THRESH. In addition, DTREXC, DTRSNA and DTRSEN */
+/* are tested by reading in precomputed examples from a file (on input */
+/* unit NIN). Output is written to output unit NOUT. */
+
+/* Arguments */
+/* ========= */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* Threshold for residual tests. A computed test ratio passes */
+/* the threshold if it is less than THRESH. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NIN (input) INTEGER */
+/* The logical unit number for input. */
+
+/* NOUT (input) INTEGER */
+/* The logical unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "EC", (ftnlen)2, (ftnlen)2);
+ eps = dlamch_("P");
+ sfmin = dlamch_("S");
+
+/* Print header information */
+
+ io___4.ciunit = *nout;
+ s_wsfe(&io___4);
+ e_wsfe();
+ io___5.ciunit = *nout;
+ s_wsfe(&io___5);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&sfmin, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ io___6.ciunit = *nout;
+ s_wsfe(&io___6);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+/* Test error exits if TSTERR is .TRUE. */
+
+ if (*tsterr) {
+ derrec_(path, nout);
+ }
+
+ ok = TRUE_;
+ dget31_(&rlaln2, &llaln2, nlaln2, &klaln2);
+ if (rlaln2 > *thresh || nlaln2[0] != 0) {
+ ok = FALSE_;
+ io___12.ciunit = *nout;
+ s_wsfe(&io___12);
+ do_fio(&c__1, (char *)&rlaln2, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&llaln2, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&nlaln2[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&klaln2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ dget32_(&rlasy2, &llasy2, &nlasy2, &klasy2);
+ if (rlasy2 > *thresh) {
+ ok = FALSE_;
+ io___17.ciunit = *nout;
+ s_wsfe(&io___17);
+ do_fio(&c__1, (char *)&rlasy2, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&llasy2, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nlasy2, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&klasy2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ dget33_(&rlanv2, &llanv2, &nlanv2, &klanv2);
+ if (rlanv2 > *thresh || nlanv2 != 0) {
+ ok = FALSE_;
+ io___22.ciunit = *nout;
+ s_wsfe(&io___22);
+ do_fio(&c__1, (char *)&rlanv2, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&llanv2, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nlanv2, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&klanv2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ dget34_(&rlaexc, &llaexc, nlaexc, &klaexc);
+ if (rlaexc > *thresh || nlaexc[1] != 0) {
+ ok = FALSE_;
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__1, (char *)&rlaexc, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&llaexc, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&nlaexc[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&klaexc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ dget35_(&rtrsyl, <rsyl, &ntrsyl, &ktrsyl);
+ if (rtrsyl > *thresh) {
+ ok = FALSE_;
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, (char *)&rtrsyl, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)<rsyl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ntrsyl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ktrsyl, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ dget36_(&rtrexc, <rexc, ntrexc, &ktrexc, nin);
+ if (rtrexc > *thresh || ntrexc[2] > 0) {
+ ok = FALSE_;
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&rtrexc, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)<rexc, (ftnlen)sizeof(integer));
+ do_fio(&c__3, (char *)&ntrexc[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ktrexc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ dget37_(rtrsna, ltrsna, ntrsna, &ktrsna, nin);
+ if (rtrsna[0] > *thresh || rtrsna[1] > *thresh || ntrsna[0] != 0 ||
+ ntrsna[1] != 0 || ntrsna[2] != 0) {
+ ok = FALSE_;
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__3, (char *)&rtrsna[0], (ftnlen)sizeof(doublereal));
+ do_fio(&c__3, (char *)<rsna[0], (ftnlen)sizeof(integer));
+ do_fio(&c__3, (char *)&ntrsna[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ktrsna, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ dget38_(rtrsen, ltrsen, ntrsen, &ktrsen, nin);
+ if (rtrsen[0] > *thresh || rtrsen[1] > *thresh || ntrsen[0] != 0 ||
+ ntrsen[1] != 0 || ntrsen[2] != 0) {
+ ok = FALSE_;
+ io___47.ciunit = *nout;
+ s_wsfe(&io___47);
+ do_fio(&c__3, (char *)&rtrsen[0], (ftnlen)sizeof(doublereal));
+ do_fio(&c__3, (char *)<rsen[0], (ftnlen)sizeof(integer));
+ do_fio(&c__3, (char *)&ntrsen[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ktrsen, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ dget39_(&rlaqtr, &llaqtr, &nlaqtr, &klaqtr);
+ if (rlaqtr > *thresh) {
+ ok = FALSE_;
+ io___52.ciunit = *nout;
+ s_wsfe(&io___52);
+ do_fio(&c__1, (char *)&rlaqtr, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&llaqtr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nlaqtr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&klaqtr, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ ntests = klaln2 + klasy2 + klanv2 + klaexc + ktrsyl + ktrexc + ktrsna +
+ ktrsen + klaqtr;
+ if (ok) {
+ io___54.ciunit = *nout;
+ s_wsfe(&io___54);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&ntests, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ return 0;
+
+/* End of DCHKEC */
+
+} /* dchkec_ */
diff --git a/TESTING/EIG/dchkee.c b/TESTING/EIG/dchkee.c
new file mode 100644
index 0000000..5786d75
--- /dev/null
+++ b/TESTING/EIG/dchkee.c
@@ -0,0 +1,3517 @@
+/* dchkee.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer nproc, nshift, maxb;
+} cenvir_;
+
+#define cenvir_1 cenvir_
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ doublereal selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+struct {
+ integer iparms[100];
+} zlaenv_;
+
+#define zlaenv_1 zlaenv_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__5 = 5;
+static integer c__6 = 6;
+static integer c__12 = 12;
+static integer c__11 = 11;
+static integer c__13 = 13;
+static integer c__2 = 2;
+static integer c__14 = 14;
+static integer c__0 = 0;
+static integer c__15 = 15;
+static integer c__16 = 16;
+static integer c__20 = 20;
+static integer c__132 = 132;
+static integer c__4 = 4;
+static integer c__8 = 8;
+static integer c__87781 = 87781;
+static integer c__9 = 9;
+static integer c__25 = 25;
+static integer c__89760 = 89760;
+static integer c__18 = 18;
+static integer c__400 = 400;
+static integer c__89758 = 89758;
+static integer c__264 = 264;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Initialized data */
+
+ static char intstr[10] = "0123456789";
+ static integer ioldsd[4] = { 0,0,0,1 };
+
+ /* Format strings */
+ static char fmt_9987[] = "(\002 Tests of the Nonsymmetric Eigenvalue Pro"
+ "blem routines\002)";
+ static char fmt_9986[] = "(\002 Tests of the Symmetric Eigenvalue Proble"
+ "m routines\002)";
+ static char fmt_9985[] = "(\002 Tests of the Singular Value Decompositio"
+ "n routines\002)";
+ static char fmt_9979[] = "(/\002 Tests of the Nonsymmetric Eigenvalue Pr"
+ "oblem Driver\002,/\002 DGEEV (eigenvalues and eigevectors)"
+ "\002)";
+ static char fmt_9978[] = "(/\002 Tests of the Nonsymmetric Eigenvalue Pr"
+ "oblem Driver\002,/\002 DGEES (Schur form)\002)";
+ static char fmt_9977[] = "(/\002 Tests of the Nonsymmetric Eigenvalue Pr"
+ "oblem Expert\002,\002 Driver\002,/\002 DGEEVX (eigenvalues, e"
+ "igenvectors and\002,\002 condition numbers)\002)";
+ static char fmt_9976[] = "(/\002 Tests of the Nonsymmetric Eigenvalue Pr"
+ "oblem Expert\002,\002 Driver\002,/\002 DGEESX (Schur form and"
+ " condition\002,\002 numbers)\002)";
+ static char fmt_9975[] = "(/\002 Tests of the Generalized Nonsymmetric E"
+ "igenvalue \002,\002Problem routines\002)";
+ static char fmt_9964[] = "(/\002 Tests of the Generalized Nonsymmetric E"
+ "igenvalue \002,\002Problem Driver DGGES\002)";
+ static char fmt_9965[] = "(/\002 Tests of the Generalized Nonsymmetric E"
+ "igenvalue \002,\002Problem Expert Driver DGGESX\002)";
+ static char fmt_9963[] = "(/\002 Tests of the Generalized Nonsymmetric E"
+ "igenvalue \002,\002Problem Driver DGGEV\002)";
+ static char fmt_9962[] = "(/\002 Tests of the Generalized Nonsymmetric E"
+ "igenvalue \002,\002Problem Expert Driver DGGEVX\002)";
+ static char fmt_9974[] = "(\002 Tests of DSBTRD\002,/\002 (reduction of "
+ "a symmetric band \002,\002matrix to tridiagonal form)\002)";
+ static char fmt_9967[] = "(\002 Tests of DGBBRD\002,/\002 (reduction of "
+ "a general band \002,\002matrix to real bidiagonal form)\002)";
+ static char fmt_9971[] = "(/\002 Tests of the Generalized Linear Regress"
+ "ion Model \002,\002routines\002)";
+ static char fmt_9970[] = "(/\002 Tests of the Generalized QR and RQ rout"
+ "ines\002)";
+ static char fmt_9969[] = "(/\002 Tests of the Generalized Singular Valu"
+ "e\002,\002 Decomposition routines\002)";
+ static char fmt_9968[] = "(/\002 Tests of the Linear Least Squares routi"
+ "nes\002)";
+ static char fmt_9992[] = "(1x,a3,\002: Unrecognized path name\002)";
+ static char fmt_9972[] = "(/\002 LAPACK VERSION \002,i1,\002.\002,i1,"
+ "\002.\002,i1)";
+ static char fmt_9984[] = "(/\002 The following parameter values will be "
+ "used:\002)";
+ static char fmt_9989[] = "(\002 Invalid input value: \002,a,\002=\002,"
+ "i6,\002; must be >=\002,i6)";
+ static char fmt_9988[] = "(\002 Invalid input value: \002,a,\002=\002,"
+ "i6,\002; must be <=\002,i6)";
+ static char fmt_9983[] = "(4x,a,10i6,/10x,10i6)";
+ static char fmt_9981[] = "(\002 Relative machine \002,a,\002 is taken to"
+ " be\002,d16.6)";
+ static char fmt_9982[] = "(/\002 Routines pass computational tests if te"
+ "st ratio is \002,\002less than\002,f8.2,/)";
+ static char fmt_9999[] = "(/\002 Execution not attempted due to input er"
+ "rors\002)";
+ static char fmt_9991[] = "(//\002 *** Invalid integer value in column"
+ " \002,i2,\002 of input\002,\002 line:\002,/a79)";
+ static char fmt_9990[] = "(//1x,a3,\002 routines were not tested\002)";
+ static char fmt_9961[] = "(//1x,a3,\002: NB =\002,i4,\002, NBMIN =\002,"
+ "i4,\002, NX =\002,i4,\002, INMIN=\002,i4,\002, INWIN =\002,i4"
+ ",\002, INIBL =\002,i4,\002, ISHFTS =\002,i4,\002, IACC22 =\002,i"
+ "4)";
+ static char fmt_9980[] = "(\002 *** Error code from \002,a,\002 = \002,i"
+ "4)";
+ static char fmt_9997[] = "(//1x,a3,\002: NB =\002,i4,\002, NBMIN =\002,"
+ "i4,\002, NX =\002,i4)";
+ static char fmt_9995[] = "(//1x,a3,\002: NB =\002,i4,\002, NBMIN =\002,"
+ "i4,\002, NX =\002,i4,\002, NRHS =\002,i4)";
+ static char fmt_9973[] = "(/1x,71(\002-\002))";
+ static char fmt_9996[] = "(//1x,a3,\002: NB =\002,i4,\002, NBMIN =\002,"
+ "i4,\002, NS =\002,i4,\002, MAXB =\002,i4,\002, NBCOL =\002,i4)";
+ static char fmt_9966[] = "(//1x,a3,\002: NRHS =\002,i4)";
+ static char fmt_9994[] = "(//\002 End of tests\002)";
+ static char fmt_9993[] = "(\002 Total time used = \002,f12.2,\002 seco"
+ "nds\002,/)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublereal d__1;
+ cilist ci__1;
+
+ /* Builtin functions */
+ integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), e_wsfe(
+ void), s_rsle(cilist *), do_lio(integer *, integer *, char *,
+ ftnlen), e_rsle(void), s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+ integer i_len(char *, ftnlen);
+
+ /* Local variables */
+ doublereal a[243936] /* was [17424][14] */, b[87120] /* was [17424]
+ [5] */, c__[160000] /* was [400][400] */, d__[1584] /* was [132][
+ 12] */;
+ integer i__, k;
+ doublereal x[660];
+ char c1[1], c3[3];
+ integer i1;
+ doublereal s1, s2;
+ integer ic, nk, nn, vers_patch__, vers_major__, vers_minor__;
+ logical dbb, dbk, dgg, dbl, dgk, dgl, dsb, des, dgs, dev, glm, dgv, nep,
+ lse, dgx, sep;
+ doublereal eps;
+ logical gqr, svd, dsx, gsv, dvx, dxv;
+ char line[80];
+ doublereal taua[132];
+ integer info;
+ char path[3];
+ integer kval[20], lenp, mval[20], nval[20];
+ doublereal taub[132];
+ integer pval[20], itmp, nrhs;
+ doublereal work[87781];
+ integer iacc22[20];
+ logical fatal;
+ integer iseed[4], nbcol[20], inibl[20], nbval[20], nbmin[20];
+ char vname[32];
+ integer inmin[20], newsd, nsval[20], inwin[20], nxval[20], iwork[89760];
+ extern /* Subroutine */ int dchkbb_(integer *, integer *, integer *,
+ integer *, integer *, integer *, logical *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *), dchkbd_(
+ integer *, integer *, integer *, integer *, logical *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *
+, integer *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *, integer *, integer *), dchkec_(doublereal *, logical *,
+ integer *, integer *), dchkbk_(integer *, integer *), dchkbl_(
+ integer *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dchkgg_(integer *, integer *, integer *,
+ logical *, integer *, doublereal *, logical *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, logical *, doublereal *,
+ integer *), dchkgk_(integer *, integer *), dchkgl_(integer *,
+ integer *), dchksb_(integer *, integer *, integer *, integer *,
+ integer *, logical *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *);
+ extern doublereal dsecnd_(void);
+ extern /* Subroutine */ int dckglm_(integer *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *,
+ integer *), derrbd_(char *, integer *), dchkhs_(integer *,
+ integer *, integer *, logical *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *,
+ logical *, doublereal *, integer *), alareq_(char *, integer *,
+ logical *, integer *, integer *, integer *), dcklse_(
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *
+, integer *, integer *), ddrvbd_(integer *, integer *, integer *,
+ integer *, logical *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *,
+ integer *, integer *), ddrges_(integer *, integer *, integer *,
+ logical *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *
+, doublereal *, integer *, doublereal *, logical *, integer *),
+ derred_(char *, integer *), derrgg_(char *, integer *), dckgqr_(integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, doublereal *, integer
+ *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, integer *), ddrgev_(integer *,
+ integer *, integer *, logical *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *
+, doublereal *, doublereal *, doublereal *, integer *, doublereal
+ *, integer *), ddrvgg_(integer *, integer *, integer *, logical *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *
+, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int dchkst_(integer *, integer *, integer *,
+ logical *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *, integer *,
+ doublereal *, integer *), dckgsv_(integer *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, integer *), ilaver_(integer *, integer *,
+ integer *), ddrves_(integer *, integer *, integer *, logical *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *, logical *, integer *),
+ derrhs_(char *, integer *);
+ integer mxbval[20];
+ extern /* Subroutine */ int ddrvev_(integer *, integer *, integer *,
+ logical *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, integer *), ddrgsx_(integer *, integer *, doublereal *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *, integer *,
+ logical *, integer *), ddrvsg_(integer *, integer *, integer *,
+ logical *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, integer *, doublereal *,
+ integer *);
+ logical tstdif;
+ doublereal thresh;
+ extern /* Subroutine */ int ddrgvx_(integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *, integer *,
+ doublereal *, logical *, integer *);
+ logical tstchk;
+ integer nparms, ishfts[20];
+ extern /* Subroutine */ int derrst_(char *, integer *);
+ logical dotype[30], logwrk[132];
+ doublereal thrshn;
+ extern /* Subroutine */ int ddrvst_(integer *, integer *, integer *,
+ logical *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, integer *, doublereal *,
+ integer *), xlaenv_(integer *, integer *), ddrvsx_(integer *,
+ integer *, integer *, logical *, integer *, doublereal *, integer
+ *, integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *, logical *,
+ integer *), ddrvvx_(integer *, integer *, integer *, logical *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *,
+ integer *);
+ doublereal result[500];
+ integer maxtyp;
+ logical tsterr;
+ integer ntypes;
+ logical tstdrv;
+
+ /* Fortran I/O blocks */
+ static cilist io___29 = { 0, 6, 0, fmt_9987, 0 };
+ static cilist io___30 = { 0, 6, 0, fmt_9986, 0 };
+ static cilist io___31 = { 0, 6, 0, fmt_9985, 0 };
+ static cilist io___32 = { 0, 6, 0, fmt_9979, 0 };
+ static cilist io___33 = { 0, 6, 0, fmt_9978, 0 };
+ static cilist io___34 = { 0, 6, 0, fmt_9977, 0 };
+ static cilist io___35 = { 0, 6, 0, fmt_9976, 0 };
+ static cilist io___36 = { 0, 6, 0, fmt_9975, 0 };
+ static cilist io___37 = { 0, 6, 0, fmt_9964, 0 };
+ static cilist io___38 = { 0, 6, 0, fmt_9965, 0 };
+ static cilist io___39 = { 0, 6, 0, fmt_9963, 0 };
+ static cilist io___40 = { 0, 6, 0, fmt_9962, 0 };
+ static cilist io___41 = { 0, 6, 0, fmt_9974, 0 };
+ static cilist io___42 = { 0, 6, 0, fmt_9967, 0 };
+ static cilist io___43 = { 0, 6, 0, fmt_9971, 0 };
+ static cilist io___44 = { 0, 6, 0, fmt_9970, 0 };
+ static cilist io___45 = { 0, 6, 0, fmt_9969, 0 };
+ static cilist io___46 = { 0, 6, 0, fmt_9968, 0 };
+ static cilist io___47 = { 0, 5, 0, 0, 0 };
+ static cilist io___50 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___54 = { 0, 6, 0, fmt_9972, 0 };
+ static cilist io___55 = { 0, 6, 0, fmt_9984, 0 };
+ static cilist io___56 = { 0, 5, 0, 0, 0 };
+ static cilist io___58 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___59 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___60 = { 0, 5, 0, 0, 0 };
+ static cilist io___64 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___65 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___66 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___67 = { 0, 5, 0, 0, 0 };
+ static cilist io___69 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___70 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___71 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___72 = { 0, 5, 0, 0, 0 };
+ static cilist io___74 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___75 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___76 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___77 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___78 = { 0, 5, 0, 0, 0 };
+ static cilist io___80 = { 0, 5, 0, 0, 0 };
+ static cilist io___82 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___83 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___84 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___85 = { 0, 5, 0, 0, 0 };
+ static cilist io___94 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___95 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___96 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___97 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___98 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___99 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___100 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___101 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___102 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___103 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___104 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___105 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___106 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___107 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___108 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___109 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___110 = { 0, 5, 0, 0, 0 };
+ static cilist io___113 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___114 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___115 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___116 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___117 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___118 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___119 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___120 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___121 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___122 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___123 = { 0, 5, 0, 0, 0 };
+ static cilist io___125 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___126 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___127 = { 0, 5, 0, 0, 0 };
+ static cilist io___128 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___129 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___130 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___131 = { 0, 5, 0, 0, 0 };
+ static cilist io___132 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___133 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___134 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___135 = { 0, 5, 0, 0, 0 };
+ static cilist io___136 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___137 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___138 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___139 = { 0, 5, 0, 0, 0 };
+ static cilist io___140 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___141 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___142 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___143 = { 0, 5, 0, 0, 0 };
+ static cilist io___144 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___145 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___146 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___147 = { 0, 5, 0, 0, 0 };
+ static cilist io___148 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___149 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___150 = { 0, 5, 0, 0, 0 };
+ static cilist io___151 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___152 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___153 = { 0, 5, 0, 0, 0 };
+ static cilist io___154 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___155 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___156 = { 0, 5, 0, 0, 0 };
+ static cilist io___157 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___158 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___159 = { 0, 5, 0, 0, 0 };
+ static cilist io___160 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___161 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___162 = { 0, 5, 0, 0, 0 };
+ static cilist io___164 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___165 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___166 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___167 = { 0, 6, 0, 0, 0 };
+ static cilist io___169 = { 0, 6, 0, fmt_9981, 0 };
+ static cilist io___170 = { 0, 6, 0, fmt_9981, 0 };
+ static cilist io___171 = { 0, 6, 0, fmt_9981, 0 };
+ static cilist io___172 = { 0, 5, 0, 0, 0 };
+ static cilist io___173 = { 0, 6, 0, fmt_9982, 0 };
+ static cilist io___174 = { 0, 5, 0, 0, 0 };
+ static cilist io___176 = { 0, 5, 0, 0, 0 };
+ static cilist io___178 = { 0, 5, 0, 0, 0 };
+ static cilist io___179 = { 0, 5, 0, 0, 0 };
+ static cilist io___181 = { 0, 5, 0, 0, 0 };
+ static cilist io___183 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___192 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___193 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___196 = { 0, 6, 0, fmt_9961, 0 };
+ static cilist io___204 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___205 = { 0, 6, 0, fmt_9997, 0 };
+ static cilist io___206 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___207 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___208 = { 0, 6, 0, fmt_9997, 0 };
+ static cilist io___209 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___211 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___212 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___213 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___214 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___215 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___216 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___217 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___218 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___219 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___220 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___221 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___222 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___223 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___224 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___225 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___228 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___229 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___230 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___231 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___232 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___233 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___235 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___236 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___237 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___238 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___239 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___240 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___241 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___242 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___243 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___244 = { 0, 6, 0, fmt_9966, 0 };
+ static cilist io___245 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___248 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___251 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___252 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___253 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___254 = { 0, 6, 0, 0, 0 };
+ static cilist io___255 = { 0, 6, 0, 0, 0 };
+ static cilist io___256 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___257 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___259 = { 0, 6, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKEE tests the DOUBLE PRECISION LAPACK subroutines for the matrix */
+/* eigenvalue problem. The test paths in this version are */
+
+/* NEP (Nonsymmetric Eigenvalue Problem): */
+/* Test DGEHRD, DORGHR, DHSEQR, DTREVC, DHSEIN, and DORMHR */
+
+/* SEP (Symmetric Eigenvalue Problem): */
+/* Test DSYTRD, DORGTR, DSTEQR, DSTERF, DSTEIN, DSTEDC, */
+/* and drivers DSYEV(X), DSBEV(X), DSPEV(X), DSTEV(X), */
+/* DSYEVD, DSBEVD, DSPEVD, DSTEVD */
+
+/* SVD (Singular Value Decomposition): */
+/* Test DGEBRD, DORGBR, DBDSQR, DBDSDC */
+/* and the drivers DGESVD, DGESDD */
+
+/* DEV (Nonsymmetric Eigenvalue/eigenvector Driver): */
+/* Test DGEEV */
+
+/* DES (Nonsymmetric Schur form Driver): */
+/* Test DGEES */
+
+/* DVX (Nonsymmetric Eigenvalue/eigenvector Expert Driver): */
+/* Test DGEEVX */
+
+/* DSX (Nonsymmetric Schur form Expert Driver): */
+/* Test DGEESX */
+
+/* DGG (Generalized Nonsymmetric Eigenvalue Problem): */
+/* Test DGGHRD, DGGBAL, DGGBAK, DHGEQZ, and DTGEVC */
+/* and the driver routines DGEGS and DGEGV */
+
+/* DGS (Generalized Nonsymmetric Schur form Driver): */
+/* Test DGGES */
+
+/* DGV (Generalized Nonsymmetric Eigenvalue/eigenvector Driver): */
+/* Test DGGEV */
+
+/* DGX (Generalized Nonsymmetric Schur form Expert Driver): */
+/* Test DGGESX */
+
+/* DXV (Generalized Nonsymmetric Eigenvalue/eigenvector Expert Driver): */
+/* Test DGGEVX */
+
+/* DSG (Symmetric Generalized Eigenvalue Problem): */
+/* Test DSYGST, DSYGV, DSYGVD, DSYGVX, DSPGST, DSPGV, DSPGVD, */
+/* DSPGVX, DSBGST, DSBGV, DSBGVD, and DSBGVX */
+
+/* DSB (Symmetric Band Eigenvalue Problem): */
+/* Test DSBTRD */
+
+/* DBB (Band Singular Value Decomposition): */
+/* Test DGBBRD */
+
+/* DEC (Eigencondition estimation): */
+/* Test DLALN2, DLASY2, DLAEQU, DLAEXC, DTRSYL, DTREXC, DTRSNA, */
+/* DTRSEN, and DLAQTR */
+
+/* DBL (Balancing a general matrix) */
+/* Test DGEBAL */
+
+/* DBK (Back transformation on a balanced matrix) */
+/* Test DGEBAK */
+
+/* DGL (Balancing a matrix pair) */
+/* Test DGGBAL */
+
+/* DGK (Back transformation on a matrix pair) */
+/* Test DGGBAK */
+
+/* GLM (Generalized Linear Regression Model): */
+/* Tests DGGGLM */
+
+/* GQR (Generalized QR and RQ factorizations): */
+/* Tests DGGQRF and DGGRQF */
+
+/* GSV (Generalized Singular Value Decomposition): */
+/* Tests DGGSVD, DGGSVP, DTGSJA, DLAGS2, DLAPLL, and DLAPMT */
+
+/* LSE (Constrained Linear Least Squares): */
+/* Tests DGGLSE */
+
+/* Each test path has a different set of inputs, but the data sets for */
+/* the driver routines xEV, xES, xVX, and xSX can be concatenated in a */
+/* single input file. The first line of input should contain one of the */
+/* 3-character path names in columns 1-3. The number of remaining lines */
+/* depends on what is found on the first line. */
+
+/* The number of matrix types used in testing is often controllable from */
+/* the input file. The number of matrix types for each path, and the */
+/* test routine that describes them, is as follows: */
+
+/* Path name(s) Types Test routine */
+
+/* DHS or NEP 21 DCHKHS */
+/* DST or SEP 21 DCHKST (routines) */
+/* 18 DDRVST (drivers) */
+/* DBD or SVD 16 DCHKBD (routines) */
+/* 5 DDRVBD (drivers) */
+/* DEV 21 DDRVEV */
+/* DES 21 DDRVES */
+/* DVX 21 DDRVVX */
+/* DSX 21 DDRVSX */
+/* DGG 26 DCHKGG (routines) */
+/* 26 DDRVGG (drivers) */
+/* DGS 26 DDRGES */
+/* DGX 5 DDRGSX */
+/* DGV 26 DDRGEV */
+/* DXV 2 DDRGVX */
+/* DSG 21 DDRVSG */
+/* DSB 15 DCHKSB */
+/* DBB 15 DCHKBB */
+/* DEC - DCHKEC */
+/* DBL - DCHKBL */
+/* DBK - DCHKBK */
+/* DGL - DCHKGL */
+/* DGK - DCHKGK */
+/* GLM 8 DCKGLM */
+/* GQR 8 DCKGQR */
+/* GSV 8 DCKGSV */
+/* LSE 8 DCKLSE */
+
+/* ----------------------------------------------------------------------- */
+
+/* NEP input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of N. */
+
+/* line 3: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix dimension N. */
+
+/* line 4: NPARMS, INTEGER */
+/* Number of values of the parameters NB, NBMIN, NX, NS, and */
+/* MAXB. */
+
+/* line 5: NBVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the blocksize NB. */
+
+/* line 6: NBMIN, INTEGER array, dimension (NPARMS) */
+/* The values for the minimum blocksize NBMIN. */
+
+/* line 7: NXVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the crossover point NX. */
+
+/* line 8: INMIN, INTEGER array, dimension (NPARMS) */
+/* LAHQR vs TTQRE crossover point, >= 11 */
+
+/* line 9: INWIN, INTEGER array, dimension (NPARMS) */
+/* recommended deflation window size */
+
+/* line 10: INIBL, INTEGER array, dimension (NPARMS) */
+/* nibble crossover point */
+
+/* line 11: ISHFTS, INTEGER array, dimension (NPARMS) */
+/* number of simultaneous shifts) */
+
+/* line 12: IACC22, INTEGER array, dimension (NPARMS) */
+/* select structured matrix multiply: 0, 1 or 2) */
+
+/* line 13: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. To have all of the test */
+/* ratios printed, use THRESH = 0.0 . */
+
+/* line 14: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 14 was 2: */
+
+/* line 15: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 15-EOF: The remaining lines occur in sets of 1 or 2 and allow */
+/* the user to specify the matrix types. Each line contains */
+/* a 3-character path name in columns 1-3, and the number */
+/* of matrix types must be the first nonblank item in columns */
+/* 4-80. If the number of matrix types is at least 1 but is */
+/* less than the maximum number of possible types, a second */
+/* line will be read to get the numbers of the matrix types to */
+/* be used. For example, */
+/* NEP 21 */
+/* requests all of the matrix types for the nonsymmetric */
+/* eigenvalue problem, while */
+/* NEP 4 */
+/* 9 10 11 12 */
+/* requests only matrices of type 9, 10, 11, and 12. */
+
+/* The valid 3-character path names are 'NEP' or 'SHS' for the */
+/* nonsymmetric eigenvalue routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* SEP or DSG input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of N. */
+
+/* line 3: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix dimension N. */
+
+/* line 4: NPARMS, INTEGER */
+/* Number of values of the parameters NB, NBMIN, and NX. */
+
+/* line 5: NBVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the blocksize NB. */
+
+/* line 6: NBMIN, INTEGER array, dimension (NPARMS) */
+/* The values for the minimum blocksize NBMIN. */
+
+/* line 7: NXVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the crossover point NX. */
+
+/* line 8: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 9: TSTCHK, LOGICAL */
+/* Flag indicating whether or not to test the LAPACK routines. */
+
+/* line 10: TSTDRV, LOGICAL */
+/* Flag indicating whether or not to test the driver routines. */
+
+/* line 11: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 12: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 12 was 2: */
+
+/* line 13: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 13-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path names are 'SEP' or 'SST' for the */
+/* symmetric eigenvalue routines and driver routines, and */
+/* 'DSG' for the routines for the symmetric generalized */
+/* eigenvalue problem. */
+
+/* ----------------------------------------------------------------------- */
+
+/* SVD input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M and N. */
+
+/* line 3: MVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix row dimension M. */
+
+/* line 4: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix column dimension N. */
+
+/* line 5: NPARMS, INTEGER */
+/* Number of values of the parameter NB, NBMIN, NX, and NRHS. */
+
+/* line 6: NBVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the blocksize NB. */
+
+/* line 7: NBMIN, INTEGER array, dimension (NPARMS) */
+/* The values for the minimum blocksize NBMIN. */
+
+/* line 8: NXVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the crossover point NX. */
+
+/* line 9: NSVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the number of right hand sides NRHS. */
+
+/* line 10: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 11: TSTCHK, LOGICAL */
+/* Flag indicating whether or not to test the LAPACK routines. */
+
+/* line 12: TSTDRV, LOGICAL */
+/* Flag indicating whether or not to test the driver routines. */
+
+/* line 13: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 14: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 14 was 2: */
+
+/* line 15: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 15-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path names are 'SVD' or 'SBD' for both the */
+/* SVD routines and the SVD driver routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* DEV and DES data files: */
+
+/* line 1: 'DEV' or 'DES' in columns 1 to 3. */
+
+/* line 2: NSIZES, INTEGER */
+/* Number of sizes of matrices to use. Should be at least 0 */
+/* and at most 20. If NSIZES = 0, no testing is done */
+/* (although the remaining 3 lines are still read). */
+
+/* line 3: NN, INTEGER array, dimension(NSIZES) */
+/* Dimensions of matrices to be tested. */
+
+/* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+/* These integer parameters determine how blocking is done */
+/* (see ILAENV for details) */
+/* NB : block size */
+/* NBMIN : minimum block size */
+/* NX : minimum dimension for blocking */
+/* NS : number of shifts in xHSEQR */
+/* NBCOL : minimum column dimension for blocking */
+
+/* line 5: THRESH, REAL */
+/* The test threshold against which computed residuals are */
+/* compared. Should generally be in the range from 10. to 20. */
+/* If it is 0., all test case data will be printed. */
+
+/* line 6: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits. */
+
+/* line 7: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 7 was 2: */
+
+/* line 8: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 9 and following: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'DEV' to test SGEEV, or */
+/* 'DES' to test SGEES. */
+
+/* ----------------------------------------------------------------------- */
+
+/* The DVX data has two parts. The first part is identical to DEV, */
+/* and the second part consists of test matrices with precomputed */
+/* solutions. */
+
+/* line 1: 'DVX' in columns 1-3. */
+
+/* line 2: NSIZES, INTEGER */
+/* If NSIZES = 0, no testing of randomly generated examples */
+/* is done, but any precomputed examples are tested. */
+
+/* line 3: NN, INTEGER array, dimension(NSIZES) */
+
+/* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+
+/* line 5: THRESH, REAL */
+
+/* line 6: TSTERR, LOGICAL */
+
+/* line 7: NEWSD, INTEGER */
+
+/* If line 7 was 2: */
+
+/* line 8: INTEGER array, dimension (4) */
+
+/* lines 9 and following: The first line contains 'DVX' in columns 1-3 */
+/* followed by the number of matrix types, possibly with */
+/* a second line to specify certain matrix types. */
+/* If the number of matrix types = 0, no testing of randomly */
+/* generated examples is done, but any precomputed examples */
+/* are tested. */
+
+/* remaining lines : Each matrix is stored on 1+2*N lines, where N is */
+/* its dimension. The first line contains the dimension (a */
+/* single integer). The next N lines contain the matrix, one */
+/* row per line. The last N lines correspond to each */
+/* eigenvalue. Each of these last N lines contains 4 real */
+/* values: the real part of the eigenvalue, the imaginary */
+/* part of the eigenvalue, the reciprocal condition number of */
+/* the eigenvalues, and the reciprocal condition number of the */
+/* eigenvector. The end of data is indicated by dimension N=0. */
+/* Even if no data is to be tested, there must be at least one */
+/* line containing N=0. */
+
+/* ----------------------------------------------------------------------- */
+
+/* The DSX data is like DVX. The first part is identical to DEV, and the */
+/* second part consists of test matrices with precomputed solutions. */
+
+/* line 1: 'DSX' in columns 1-3. */
+
+/* line 2: NSIZES, INTEGER */
+/* If NSIZES = 0, no testing of randomly generated examples */
+/* is done, but any precomputed examples are tested. */
+
+/* line 3: NN, INTEGER array, dimension(NSIZES) */
+
+/* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+
+/* line 5: THRESH, REAL */
+
+/* line 6: TSTERR, LOGICAL */
+
+/* line 7: NEWSD, INTEGER */
+
+/* If line 7 was 2: */
+
+/* line 8: INTEGER array, dimension (4) */
+
+/* lines 9 and following: The first line contains 'DSX' in columns 1-3 */
+/* followed by the number of matrix types, possibly with */
+/* a second line to specify certain matrix types. */
+/* If the number of matrix types = 0, no testing of randomly */
+/* generated examples is done, but any precomputed examples */
+/* are tested. */
+
+/* remaining lines : Each matrix is stored on 3+N lines, where N is its */
+/* dimension. The first line contains the dimension N and the */
+/* dimension M of an invariant subspace. The second line */
+/* contains M integers, identifying the eigenvalues in the */
+/* invariant subspace (by their position in a list of */
+/* eigenvalues ordered by increasing real part). The next N */
+/* lines contain the matrix. The last line contains the */
+/* reciprocal condition number for the average of the selected */
+/* eigenvalues, and the reciprocal condition number for the */
+/* corresponding right invariant subspace. The end of data is */
+/* indicated by a line containing N=0 and M=0. Even if no data */
+/* is to be tested, there must be at least one line containing */
+/* N=0 and M=0. */
+
+/* ----------------------------------------------------------------------- */
+
+/* DGG input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of N. */
+
+/* line 3: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix dimension N. */
+
+/* line 4: NPARMS, INTEGER */
+/* Number of values of the parameters NB, NBMIN, NS, MAXB, and */
+/* NBCOL. */
+
+/* line 5: NBVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the blocksize NB. */
+
+/* line 6: NBMIN, INTEGER array, dimension (NPARMS) */
+/* The values for NBMIN, the minimum row dimension for blocks. */
+
+/* line 7: NSVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the number of shifts. */
+
+/* line 8: MXBVAL, INTEGER array, dimension (NPARMS) */
+/* The values for MAXB, used in determining minimum blocksize. */
+
+/* line 9: NBCOL, INTEGER array, dimension (NPARMS) */
+/* The values for NBCOL, the minimum column dimension for */
+/* blocks. */
+
+/* line 10: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 11: TSTCHK, LOGICAL */
+/* Flag indicating whether or not to test the LAPACK routines. */
+
+/* line 12: TSTDRV, LOGICAL */
+/* Flag indicating whether or not to test the driver routines. */
+
+/* line 13: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 14: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 14 was 2: */
+
+/* line 15: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 15-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'DGG' for the generalized */
+/* eigenvalue problem routines and driver routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* DGS and DGV input files: */
+
+/* line 1: 'DGS' or 'DGV' in columns 1 to 3. */
+
+/* line 2: NN, INTEGER */
+/* Number of values of N. */
+
+/* line 3: NVAL, INTEGER array, dimension(NN) */
+/* Dimensions of matrices to be tested. */
+
+/* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+/* These integer parameters determine how blocking is done */
+/* (see ILAENV for details) */
+/* NB : block size */
+/* NBMIN : minimum block size */
+/* NX : minimum dimension for blocking */
+/* NS : number of shifts in xHGEQR */
+/* NBCOL : minimum column dimension for blocking */
+
+/* line 5: THRESH, REAL */
+/* The test threshold against which computed residuals are */
+/* compared. Should generally be in the range from 10. to 20. */
+/* If it is 0., all test case data will be printed. */
+
+/* line 6: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits. */
+
+/* line 7: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 17 was 2: */
+
+/* line 7: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 7-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'DGS' for the generalized */
+/* eigenvalue problem routines and driver routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* DXV input files: */
+
+/* line 1: 'DXV' in columns 1 to 3. */
+
+/* line 2: N, INTEGER */
+/* Value of N. */
+
+/* line 3: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+/* These integer parameters determine how blocking is done */
+/* (see ILAENV for details) */
+/* NB : block size */
+/* NBMIN : minimum block size */
+/* NX : minimum dimension for blocking */
+/* NS : number of shifts in xHGEQR */
+/* NBCOL : minimum column dimension for blocking */
+
+/* line 4: THRESH, REAL */
+/* The test threshold against which computed residuals are */
+/* compared. Should generally be in the range from 10. to 20. */
+/* Information will be printed about each test for which the */
+/* test ratio is greater than or equal to the threshold. */
+
+/* line 5: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 6: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 6 was 2: */
+
+/* line 7: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* If line 2 was 0: */
+
+/* line 7-EOF: Precomputed examples are tested. */
+
+/* remaining lines : Each example is stored on 3+2*N lines, where N is */
+/* its dimension. The first line contains the dimension (a */
+/* single integer). The next N lines contain the matrix A, one */
+/* row per line. The next N lines contain the matrix B. The */
+/* next line contains the reciprocals of the eigenvalue */
+/* condition numbers. The last line contains the reciprocals of */
+/* the eigenvector condition numbers. The end of data is */
+/* indicated by dimension N=0. Even if no data is to be tested, */
+/* there must be at least one line containing N=0. */
+
+/* ----------------------------------------------------------------------- */
+
+/* DGX input files: */
+
+/* line 1: 'DGX' in columns 1 to 3. */
+
+/* line 2: N, INTEGER */
+/* Value of N. */
+
+/* line 3: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+/* These integer parameters determine how blocking is done */
+/* (see ILAENV for details) */
+/* NB : block size */
+/* NBMIN : minimum block size */
+/* NX : minimum dimension for blocking */
+/* NS : number of shifts in xHGEQR */
+/* NBCOL : minimum column dimension for blocking */
+
+/* line 4: THRESH, REAL */
+/* The test threshold against which computed residuals are */
+/* compared. Should generally be in the range from 10. to 20. */
+/* Information will be printed about each test for which the */
+/* test ratio is greater than or equal to the threshold. */
+
+/* line 5: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 6: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 6 was 2: */
+
+/* line 7: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* If line 2 was 0: */
+
+/* line 7-EOF: Precomputed examples are tested. */
+
+/* remaining lines : Each example is stored on 3+2*N lines, where N is */
+/* its dimension. The first line contains the dimension (a */
+/* single integer). The next line contains an integer k such */
+/* that only the last k eigenvalues will be selected and appear */
+/* in the leading diagonal blocks of $A$ and $B$. The next N */
+/* lines contain the matrix A, one row per line. The next N */
+/* lines contain the matrix B. The last line contains the */
+/* reciprocal of the eigenvalue cluster condition number and the */
+/* reciprocal of the deflating subspace (associated with the */
+/* selected eigencluster) condition number. The end of data is */
+/* indicated by dimension N=0. Even if no data is to be tested, */
+/* there must be at least one line containing N=0. */
+
+/* ----------------------------------------------------------------------- */
+
+/* DSB input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of N. */
+
+/* line 3: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix dimension N. */
+
+/* line 4: NK, INTEGER */
+/* Number of values of K. */
+
+/* line 5: KVAL, INTEGER array, dimension (NK) */
+/* The values for the matrix dimension K. */
+
+/* line 6: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 7: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 7 was 2: */
+
+/* line 8: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 8-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'DSB'. */
+
+/* ----------------------------------------------------------------------- */
+
+/* DBB input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M and N. */
+
+/* line 3: MVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix row dimension M. */
+
+/* line 4: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix column dimension N. */
+
+/* line 4: NK, INTEGER */
+/* Number of values of K. */
+
+/* line 5: KVAL, INTEGER array, dimension (NK) */
+/* The values for the matrix bandwidth K. */
+
+/* line 6: NPARMS, INTEGER */
+/* Number of values of the parameter NRHS */
+
+/* line 7: NSVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the number of right hand sides NRHS. */
+
+/* line 8: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 9: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 9 was 2: */
+
+/* line 10: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 10-EOF: Lines specifying matrix types, as for SVD. */
+/* The 3-character path name is 'DBB'. */
+
+/* ----------------------------------------------------------------------- */
+
+/* DEC input file: */
+
+/* line 2: THRESH, REAL */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* lines 3-EOF: */
+
+/* Input for testing the eigencondition routines consists of a set of */
+/* specially constructed test cases and their solutions. The data */
+/* format is not intended to be modified by the user. */
+
+/* ----------------------------------------------------------------------- */
+
+/* DBL and DBK input files: */
+
+/* line 1: 'DBL' in columns 1-3 to test SGEBAL, or 'DBK' in */
+/* columns 1-3 to test SGEBAK. */
+
+/* The remaining lines consist of specially constructed test cases. */
+
+/* ----------------------------------------------------------------------- */
+
+/* DGL and DGK input files: */
+
+/* line 1: 'DGL' in columns 1-3 to test DGGBAL, or 'DGK' in */
+/* columns 1-3 to test DGGBAK. */
+
+/* The remaining lines consist of specially constructed test cases. */
+
+/* ----------------------------------------------------------------------- */
+
+/* GLM data file: */
+
+/* line 1: 'GLM' in columns 1 to 3. */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M, P, and N. */
+
+/* line 3: MVAL, INTEGER array, dimension(NN) */
+/* Values of M (row dimension). */
+
+/* line 4: PVAL, INTEGER array, dimension(NN) */
+/* Values of P (row dimension). */
+
+/* line 5: NVAL, INTEGER array, dimension(NN) */
+/* Values of N (column dimension), note M <= N <= M+P. */
+
+/* line 6: THRESH, REAL */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 7: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 8: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 8 was 2: */
+
+/* line 9: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 9-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'GLM' for the generalized */
+/* linear regression model routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* GQR data file: */
+
+/* line 1: 'GQR' in columns 1 to 3. */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M, P, and N. */
+
+/* line 3: MVAL, INTEGER array, dimension(NN) */
+/* Values of M. */
+
+/* line 4: PVAL, INTEGER array, dimension(NN) */
+/* Values of P. */
+
+/* line 5: NVAL, INTEGER array, dimension(NN) */
+/* Values of N. */
+
+/* line 6: THRESH, REAL */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 7: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 8: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 8 was 2: */
+
+/* line 9: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 9-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'GQR' for the generalized */
+/* QR and RQ routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* GSV data file: */
+
+/* line 1: 'GSV' in columns 1 to 3. */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M, P, and N. */
+
+/* line 3: MVAL, INTEGER array, dimension(NN) */
+/* Values of M (row dimension). */
+
+/* line 4: PVAL, INTEGER array, dimension(NN) */
+/* Values of P (row dimension). */
+
+/* line 5: NVAL, INTEGER array, dimension(NN) */
+/* Values of N (column dimension). */
+
+/* line 6: THRESH, REAL */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 7: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 8: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 8 was 2: */
+
+/* line 9: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 9-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'GSV' for the generalized */
+/* SVD routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* LSE data file: */
+
+/* line 1: 'LSE' in columns 1 to 3. */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M, P, and N. */
+
+/* line 3: MVAL, INTEGER array, dimension(NN) */
+/* Values of M. */
+
+/* line 4: PVAL, INTEGER array, dimension(NN) */
+/* Values of P. */
+
+/* line 5: NVAL, INTEGER array, dimension(NN) */
+/* Values of N, note P <= N <= P+M. */
+
+/* line 6: THRESH, REAL */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 7: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 8: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 8 was 2: */
+
+/* line 9: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 9-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'GSV' for the generalized */
+/* SVD routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* NMAX is currently set to 132 and must be at least 12 for some of the */
+/* precomputed examples, and LWORK = NMAX*(5*NMAX+5)+1 in the parameter */
+/* statements below. For SVD, we assume NRHS may be as big as N. The */
+/* parameter NEED is set to 14 to allow for 14 N-by-N matrices for DGG. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ s1 = dsecnd_();
+ fatal = FALSE_;
+ infoc_1.nunit = 6;
+
+/* Return to here to read multiple sets of data */
+
+L10:
+
+/* Read the first line and set the 3-character test path */
+
+ ci__1.cierr = 0;
+ ci__1.ciend = 1;
+ ci__1.ciunit = 5;
+ ci__1.cifmt = "(A80)";
+ i__1 = s_rsfe(&ci__1);
+ if (i__1 != 0) {
+ goto L380;
+ }
+ i__1 = do_fio(&c__1, line, (ftnlen)80);
+ if (i__1 != 0) {
+ goto L380;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L380;
+ }
+ s_copy(path, line, (ftnlen)3, (ftnlen)3);
+ nep = lsamen_(&c__3, path, "NEP") || lsamen_(&c__3,
+ path, "DHS");
+ sep = lsamen_(&c__3, path, "SEP") || lsamen_(&c__3,
+ path, "DST") || lsamen_(&c__3, path, "DSG");
+ svd = lsamen_(&c__3, path, "SVD") || lsamen_(&c__3,
+ path, "DBD");
+ dev = lsamen_(&c__3, path, "DEV");
+ des = lsamen_(&c__3, path, "DES");
+ dvx = lsamen_(&c__3, path, "DVX");
+ dsx = lsamen_(&c__3, path, "DSX");
+ dgg = lsamen_(&c__3, path, "DGG");
+ dgs = lsamen_(&c__3, path, "DGS");
+ dgx = lsamen_(&c__3, path, "DGX");
+ dgv = lsamen_(&c__3, path, "DGV");
+ dxv = lsamen_(&c__3, path, "DXV");
+ dsb = lsamen_(&c__3, path, "DSB");
+ dbb = lsamen_(&c__3, path, "DBB");
+ glm = lsamen_(&c__3, path, "GLM");
+ gqr = lsamen_(&c__3, path, "GQR") || lsamen_(&c__3,
+ path, "GRQ");
+ gsv = lsamen_(&c__3, path, "GSV");
+ lse = lsamen_(&c__3, path, "LSE");
+ dbl = lsamen_(&c__3, path, "DBL");
+ dbk = lsamen_(&c__3, path, "DBK");
+ dgl = lsamen_(&c__3, path, "DGL");
+ dgk = lsamen_(&c__3, path, "DGK");
+
+/* Report values of parameters. */
+
+ if (s_cmp(path, " ", (ftnlen)3, (ftnlen)3) == 0) {
+ goto L10;
+ } else if (nep) {
+ s_wsfe(&io___29);
+ e_wsfe();
+ } else if (sep) {
+ s_wsfe(&io___30);
+ e_wsfe();
+ } else if (svd) {
+ s_wsfe(&io___31);
+ e_wsfe();
+ } else if (dev) {
+ s_wsfe(&io___32);
+ e_wsfe();
+ } else if (des) {
+ s_wsfe(&io___33);
+ e_wsfe();
+ } else if (dvx) {
+ s_wsfe(&io___34);
+ e_wsfe();
+ } else if (dsx) {
+ s_wsfe(&io___35);
+ e_wsfe();
+ } else if (dgg) {
+ s_wsfe(&io___36);
+ e_wsfe();
+ } else if (dgs) {
+ s_wsfe(&io___37);
+ e_wsfe();
+ } else if (dgx) {
+ s_wsfe(&io___38);
+ e_wsfe();
+ } else if (dgv) {
+ s_wsfe(&io___39);
+ e_wsfe();
+ } else if (dxv) {
+ s_wsfe(&io___40);
+ e_wsfe();
+ } else if (dsb) {
+ s_wsfe(&io___41);
+ e_wsfe();
+ } else if (dbb) {
+ s_wsfe(&io___42);
+ e_wsfe();
+ } else if (glm) {
+ s_wsfe(&io___43);
+ e_wsfe();
+ } else if (gqr) {
+ s_wsfe(&io___44);
+ e_wsfe();
+ } else if (gsv) {
+ s_wsfe(&io___45);
+ e_wsfe();
+ } else if (lse) {
+ s_wsfe(&io___46);
+ e_wsfe();
+ } else if (dbl) {
+
+/* DGEBAL: Balancing */
+
+ dchkbl_(&c__5, &c__6);
+ goto L10;
+ } else if (dbk) {
+
+/* DGEBAK: Back transformation */
+
+ dchkbk_(&c__5, &c__6);
+ goto L10;
+ } else if (dgl) {
+
+/* DGGBAL: Balancing */
+
+ dchkgl_(&c__5, &c__6);
+ goto L10;
+ } else if (dgk) {
+
+/* DGGBAK: Back transformation */
+
+ dchkgk_(&c__5, &c__6);
+ goto L10;
+ } else if (lsamen_(&c__3, path, "DEC")) {
+
+/* DEC: Eigencondition estimation */
+
+ s_rsle(&io___47);
+ do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_rsle();
+ xlaenv_(&c__1, &c__1);
+ xlaenv_(&c__12, &c__11);
+ xlaenv_(&c__13, &c__2);
+ xlaenv_(&c__14, &c__0);
+ xlaenv_(&c__15, &c__2);
+ xlaenv_(&c__16, &c__2);
+ tsterr = TRUE_;
+ dchkec_(&thresh, &tsterr, &c__5, &c__6);
+ goto L10;
+ } else {
+ s_wsfe(&io___50);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ goto L10;
+ }
+ ilaver_(&vers_major__, &vers_minor__, &vers_patch__);
+ s_wsfe(&io___54);
+ do_fio(&c__1, (char *)&vers_major__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_minor__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_patch__, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___55);
+ e_wsfe();
+
+/* Read the number of values of M, P, and N. */
+
+ s_rsle(&io___56);
+ do_lio(&c__3, &c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nn < 0) {
+ s_wsfe(&io___58);
+ do_fio(&c__1, " NN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ } else if (nn > 20) {
+ s_wsfe(&io___59);
+ do_fio(&c__1, " NN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__20, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ }
+
+/* Read the values of M */
+
+ if (! (dgx || dxv)) {
+ s_rsle(&io___60);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ if (svd) {
+ s_copy(vname, " M ", (ftnlen)32, (ftnlen)6);
+ } else {
+ s_copy(vname, " N ", (ftnlen)32, (ftnlen)6);
+ }
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (mval[i__ - 1] < 0) {
+ s_wsfe(&io___64);
+ do_fio(&c__1, vname, (ftnlen)32);
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (mval[i__ - 1] > 132) {
+ s_wsfe(&io___65);
+ do_fio(&c__1, vname, (ftnlen)32);
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L20: */
+ }
+ s_wsfe(&io___66);
+ do_fio(&c__1, "M: ", (ftnlen)6);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of P */
+
+ if (glm || gqr || gsv || lse) {
+ s_rsle(&io___67);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&pval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (pval[i__ - 1] < 0) {
+ s_wsfe(&io___69);
+ do_fio(&c__1, " P ", (ftnlen)4);
+ do_fio(&c__1, (char *)&pval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (pval[i__ - 1] > 132) {
+ s_wsfe(&io___70);
+ do_fio(&c__1, " P ", (ftnlen)4);
+ do_fio(&c__1, (char *)&pval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L30: */
+ }
+ s_wsfe(&io___71);
+ do_fio(&c__1, "P: ", (ftnlen)6);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&pval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of N */
+
+ if (svd || dbb || glm || gqr || gsv || lse) {
+ s_rsle(&io___72);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nval[i__ - 1] < 0) {
+ s_wsfe(&io___74);
+ do_fio(&c__1, " N ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nval[i__ - 1] > 132) {
+ s_wsfe(&io___75);
+ do_fio(&c__1, " N ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L40: */
+ }
+ } else {
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nval[i__ - 1] = mval[i__ - 1];
+/* L50: */
+ }
+ }
+ if (! (dgx || dxv)) {
+ s_wsfe(&io___76);
+ do_fio(&c__1, "N: ", (ftnlen)6);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ } else {
+ s_wsfe(&io___77);
+ do_fio(&c__1, "N: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Read the number of values of K, followed by the values of K */
+
+ if (dsb || dbb) {
+ s_rsle(&io___78);
+ do_lio(&c__3, &c__1, (char *)&nk, (ftnlen)sizeof(integer));
+ e_rsle();
+ s_rsle(&io___80);
+ i__1 = nk;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&kval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nk;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (kval[i__ - 1] < 0) {
+ s_wsfe(&io___82);
+ do_fio(&c__1, " K ", (ftnlen)6);
+ do_fio(&c__1, (char *)&kval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (kval[i__ - 1] > 132) {
+ s_wsfe(&io___83);
+ do_fio(&c__1, " K ", (ftnlen)6);
+ do_fio(&c__1, (char *)&kval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L60: */
+ }
+ s_wsfe(&io___84);
+ do_fio(&c__1, "K: ", (ftnlen)6);
+ i__1 = nk;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&kval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+ if (dev || des || dvx || dsx) {
+
+/* For the nonsymmetric QR driver routines, only one set of */
+/* parameters is allowed. */
+
+ s_rsle(&io___85);
+ do_lio(&c__3, &c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&inmin[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&inwin[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&inibl[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ishfts[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&iacc22[0], (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nbval[0] < 1) {
+ s_wsfe(&io___94);
+ do_fio(&c__1, " NB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nbmin[0] < 1) {
+ s_wsfe(&io___95);
+ do_fio(&c__1, "NBMIN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nxval[0] < 1) {
+ s_wsfe(&io___96);
+ do_fio(&c__1, " NX ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (inmin[0] < 1) {
+ s_wsfe(&io___97);
+ do_fio(&c__1, " INMIN ", (ftnlen)9);
+ do_fio(&c__1, (char *)&inmin[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (inwin[0] < 1) {
+ s_wsfe(&io___98);
+ do_fio(&c__1, " INWIN ", (ftnlen)9);
+ do_fio(&c__1, (char *)&inwin[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (inibl[0] < 1) {
+ s_wsfe(&io___99);
+ do_fio(&c__1, " INIBL ", (ftnlen)9);
+ do_fio(&c__1, (char *)&inibl[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (ishfts[0] < 1) {
+ s_wsfe(&io___100);
+ do_fio(&c__1, " ISHFTS ", (ftnlen)10);
+ do_fio(&c__1, (char *)&ishfts[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (iacc22[0] < 0) {
+ s_wsfe(&io___101);
+ do_fio(&c__1, " IACC22 ", (ftnlen)10);
+ do_fio(&c__1, (char *)&iacc22[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+ xlaenv_(&c__1, nbval);
+ xlaenv_(&c__2, nbmin);
+ xlaenv_(&c__3, nxval);
+ i__1 = max(11,inmin[0]);
+ xlaenv_(&c__12, &i__1);
+ xlaenv_(&c__13, inwin);
+ xlaenv_(&c__14, inibl);
+ xlaenv_(&c__15, ishfts);
+ xlaenv_(&c__16, iacc22);
+ s_wsfe(&io___102);
+ do_fio(&c__1, "NB: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___103);
+ do_fio(&c__1, "NBMIN:", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___104);
+ do_fio(&c__1, "NX: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___105);
+ do_fio(&c__1, "INMIN: ", (ftnlen)9);
+ do_fio(&c__1, (char *)&inmin[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___106);
+ do_fio(&c__1, "INWIN: ", (ftnlen)7);
+ do_fio(&c__1, (char *)&inwin[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___107);
+ do_fio(&c__1, "INIBL: ", (ftnlen)7);
+ do_fio(&c__1, (char *)&inibl[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___108);
+ do_fio(&c__1, "ISHFTS: ", (ftnlen)8);
+ do_fio(&c__1, (char *)&ishfts[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___109);
+ do_fio(&c__1, "IACC22: ", (ftnlen)8);
+ do_fio(&c__1, (char *)&iacc22[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ } else if (dgs || dgx || dgv || dxv) {
+
+/* For the nonsymmetric generalized driver routines, only one set */
+/* of parameters is allowed. */
+
+ s_rsle(&io___110);
+ do_lio(&c__3, &c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&nsval[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&mxbval[0], (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nbval[0] < 1) {
+ s_wsfe(&io___113);
+ do_fio(&c__1, " NB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nbmin[0] < 1) {
+ s_wsfe(&io___114);
+ do_fio(&c__1, "NBMIN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nxval[0] < 1) {
+ s_wsfe(&io___115);
+ do_fio(&c__1, " NX ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nsval[0] < 2) {
+ s_wsfe(&io___116);
+ do_fio(&c__1, " NS ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nsval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (mxbval[0] < 1) {
+ s_wsfe(&io___117);
+ do_fio(&c__1, " MAXB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&mxbval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+ xlaenv_(&c__1, nbval);
+ xlaenv_(&c__2, nbmin);
+ xlaenv_(&c__3, nxval);
+ xlaenv_(&c__4, nsval);
+ xlaenv_(&c__8, mxbval);
+ s_wsfe(&io___118);
+ do_fio(&c__1, "NB: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___119);
+ do_fio(&c__1, "NBMIN:", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___120);
+ do_fio(&c__1, "NX: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___121);
+ do_fio(&c__1, "NS: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nsval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___122);
+ do_fio(&c__1, "MAXB: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&mxbval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ } else if (! dsb && ! glm && ! gqr && ! gsv && ! lse) {
+
+/* For the other paths, the number of parameters can be varied */
+/* from the input file. Read the number of parameter values. */
+
+ s_rsle(&io___123);
+ do_lio(&c__3, &c__1, (char *)&nparms, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nparms < 1) {
+ s_wsfe(&io___125);
+ do_fio(&c__1, "NPARMS", (ftnlen)6);
+ do_fio(&c__1, (char *)&nparms, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nparms = 0;
+ fatal = TRUE_;
+ } else if (nparms > 20) {
+ s_wsfe(&io___126);
+ do_fio(&c__1, "NPARMS", (ftnlen)6);
+ do_fio(&c__1, (char *)&nparms, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__20, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nparms = 0;
+ fatal = TRUE_;
+ }
+
+/* Read the values of NB */
+
+ if (! dbb) {
+ s_rsle(&io___127);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nbval[i__ - 1] < 0) {
+ s_wsfe(&io___128);
+ do_fio(&c__1, " NB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nbval[i__ - 1] > 132) {
+ s_wsfe(&io___129);
+ do_fio(&c__1, " NB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L70: */
+ }
+ s_wsfe(&io___130);
+ do_fio(&c__1, "NB: ", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ }
+
+/* Read the values of NBMIN */
+
+ if (nep || sep || svd || dgg) {
+ s_rsle(&io___131);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nbmin[i__ - 1] < 0) {
+ s_wsfe(&io___132);
+ do_fio(&c__1, "NBMIN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nbmin[i__ - 1] > 132) {
+ s_wsfe(&io___133);
+ do_fio(&c__1, "NBMIN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L80: */
+ }
+ s_wsfe(&io___134);
+ do_fio(&c__1, "NBMIN:", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nbmin[i__ - 1] = 1;
+/* L90: */
+ }
+ }
+
+/* Read the values of NX */
+
+ if (nep || sep || svd) {
+ s_rsle(&io___135);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nxval[i__ - 1] < 0) {
+ s_wsfe(&io___136);
+ do_fio(&c__1, " NX ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nxval[i__ - 1] > 132) {
+ s_wsfe(&io___137);
+ do_fio(&c__1, " NX ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L100: */
+ }
+ s_wsfe(&io___138);
+ do_fio(&c__1, "NX: ", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nxval[i__ - 1] = 1;
+/* L110: */
+ }
+ }
+
+/* Read the values of NSHIFT (if DGG) or NRHS (if SVD */
+/* or DBB). */
+
+ if (svd || dbb || dgg) {
+ s_rsle(&io___139);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nsval[i__ - 1] < 0) {
+ s_wsfe(&io___140);
+ do_fio(&c__1, " NS ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nsval[i__ - 1] > 132) {
+ s_wsfe(&io___141);
+ do_fio(&c__1, " NS ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L120: */
+ }
+ s_wsfe(&io___142);
+ do_fio(&c__1, "NS: ", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nsval[i__ - 1] = 1;
+/* L130: */
+ }
+ }
+
+/* Read the values for MAXB. */
+
+ if (dgg) {
+ s_rsle(&io___143);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (mxbval[i__ - 1] < 0) {
+ s_wsfe(&io___144);
+ do_fio(&c__1, " MAXB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (mxbval[i__ - 1] > 132) {
+ s_wsfe(&io___145);
+ do_fio(&c__1, " MAXB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L140: */
+ }
+ s_wsfe(&io___146);
+ do_fio(&c__1, "MAXB: ", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ mxbval[i__ - 1] = 1;
+/* L150: */
+ }
+ }
+
+/* Read the values for INMIN. */
+
+ if (nep) {
+ s_rsle(&io___147);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&inmin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (inmin[i__ - 1] < 0) {
+ s_wsfe(&io___148);
+ do_fio(&c__1, " INMIN ", (ftnlen)7);
+ do_fio(&c__1, (char *)&inmin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L540: */
+ }
+ s_wsfe(&io___149);
+ do_fio(&c__1, "INMIN: ", (ftnlen)7);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&inmin[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ inmin[i__ - 1] = 1;
+/* L550: */
+ }
+ }
+
+/* Read the values for INWIN. */
+
+ if (nep) {
+ s_rsle(&io___150);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&inwin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (inwin[i__ - 1] < 0) {
+ s_wsfe(&io___151);
+ do_fio(&c__1, " INWIN ", (ftnlen)7);
+ do_fio(&c__1, (char *)&inwin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L560: */
+ }
+ s_wsfe(&io___152);
+ do_fio(&c__1, "INWIN: ", (ftnlen)7);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&inwin[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ inwin[i__ - 1] = 1;
+/* L570: */
+ }
+ }
+
+/* Read the values for INIBL. */
+
+ if (nep) {
+ s_rsle(&io___153);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&inibl[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (inibl[i__ - 1] < 0) {
+ s_wsfe(&io___154);
+ do_fio(&c__1, " INIBL ", (ftnlen)7);
+ do_fio(&c__1, (char *)&inibl[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L580: */
+ }
+ s_wsfe(&io___155);
+ do_fio(&c__1, "INIBL: ", (ftnlen)7);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&inibl[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ inibl[i__ - 1] = 1;
+/* L590: */
+ }
+ }
+
+/* Read the values for ISHFTS. */
+
+ if (nep) {
+ s_rsle(&io___156);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&ishfts[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (ishfts[i__ - 1] < 0) {
+ s_wsfe(&io___157);
+ do_fio(&c__1, " ISHFTS ", (ftnlen)8);
+ do_fio(&c__1, (char *)&ishfts[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L600: */
+ }
+ s_wsfe(&io___158);
+ do_fio(&c__1, "ISHFTS: ", (ftnlen)8);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&ishfts[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ishfts[i__ - 1] = 1;
+/* L610: */
+ }
+ }
+
+/* Read the values for IACC22. */
+
+ if (nep) {
+ s_rsle(&io___159);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&iacc22[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (iacc22[i__ - 1] < 0) {
+ s_wsfe(&io___160);
+ do_fio(&c__1, " IACC22 ", (ftnlen)8);
+ do_fio(&c__1, (char *)&iacc22[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L620: */
+ }
+ s_wsfe(&io___161);
+ do_fio(&c__1, "IACC22: ", (ftnlen)8);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&iacc22[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ iacc22[i__ - 1] = 1;
+/* L630: */
+ }
+ }
+
+/* Read the values for NBCOL. */
+
+ if (dgg) {
+ s_rsle(&io___162);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nbcol[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nbcol[i__ - 1] < 0) {
+ s_wsfe(&io___164);
+ do_fio(&c__1, "NBCOL ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbcol[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nbcol[i__ - 1] > 132) {
+ s_wsfe(&io___165);
+ do_fio(&c__1, "NBCOL ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbcol[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L160: */
+ }
+ s_wsfe(&io___166);
+ do_fio(&c__1, "NBCOL:", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nbcol[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nbcol[i__ - 1] = 1;
+/* L170: */
+ }
+ }
+ }
+
+/* Calculate and print the machine dependent constants. */
+
+ s_wsle(&io___167);
+ e_wsle();
+ eps = dlamch_("Underflow threshold");
+ s_wsfe(&io___169);
+ do_fio(&c__1, "underflow", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ eps = dlamch_("Overflow threshold");
+ s_wsfe(&io___170);
+ do_fio(&c__1, "overflow ", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ eps = dlamch_("Epsilon");
+ s_wsfe(&io___171);
+ do_fio(&c__1, "precision", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+/* Read the threshold value for the test ratios. */
+
+ s_rsle(&io___172);
+ do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_rsle();
+ s_wsfe(&io___173);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ if (sep || svd || dgg) {
+
+/* Read the flag that indicates whether to test LAPACK routines. */
+
+ s_rsle(&io___174);
+ do_lio(&c__8, &c__1, (char *)&tstchk, (ftnlen)sizeof(logical));
+ e_rsle();
+
+/* Read the flag that indicates whether to test driver routines. */
+
+ s_rsle(&io___176);
+ do_lio(&c__8, &c__1, (char *)&tstdrv, (ftnlen)sizeof(logical));
+ e_rsle();
+ }
+
+/* Read the flag that indicates whether to test the error exits. */
+
+ s_rsle(&io___178);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+
+/* Read the code describing how to set the random number seed. */
+
+ s_rsle(&io___179);
+ do_lio(&c__3, &c__1, (char *)&newsd, (ftnlen)sizeof(integer));
+ e_rsle();
+
+/* If NEWSD = 2, read another line with 4 integers for the seed. */
+
+ if (newsd == 2) {
+ s_rsle(&io___181);
+ for (i__ = 1; i__ <= 4; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&ioldsd[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ }
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = ioldsd[i__ - 1];
+/* L180: */
+ }
+
+ if (fatal) {
+ s_wsfe(&io___183);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Read the input lines indicating the test path and its parameters. */
+/* The first three characters indicate the test path, and the number */
+/* of test matrix types must be the first nonblank item in columns */
+/* 4-80. */
+
+L190:
+
+ if (! (dgx || dxv)) {
+
+L200:
+ ci__1.cierr = 0;
+ ci__1.ciend = 1;
+ ci__1.ciunit = 5;
+ ci__1.cifmt = "(A80)";
+ i__1 = s_rsfe(&ci__1);
+ if (i__1 != 0) {
+ goto L380;
+ }
+ i__1 = do_fio(&c__1, line, (ftnlen)80);
+ if (i__1 != 0) {
+ goto L380;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L380;
+ }
+ s_copy(c3, line, (ftnlen)3, (ftnlen)3);
+ lenp = i_len(line, (ftnlen)80);
+ i__ = 3;
+ itmp = 0;
+ i1 = 0;
+L210:
+ ++i__;
+ if (i__ > lenp) {
+ if (i1 > 0) {
+ goto L240;
+ } else {
+ ntypes = 30;
+ goto L240;
+ }
+ }
+ if (*(unsigned char *)&line[i__ - 1] != ' ' && *(unsigned char *)&
+ line[i__ - 1] != ',') {
+ i1 = i__;
+ *(unsigned char *)c1 = *(unsigned char *)&line[i1 - 1];
+
+/* Check that a valid integer was read */
+
+ for (k = 1; k <= 10; ++k) {
+ if (*(unsigned char *)c1 == *(unsigned char *)&intstr[k - 1])
+ {
+ ic = k - 1;
+ goto L230;
+ }
+/* L220: */
+ }
+ s_wsfe(&io___192);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, line, (ftnlen)80);
+ e_wsfe();
+ goto L200;
+L230:
+ itmp = itmp * 10 + ic;
+ goto L210;
+ } else if (i1 > 0) {
+ goto L240;
+ } else {
+ goto L210;
+ }
+L240:
+ ntypes = itmp;
+
+/* Skip the tests if NTYPES is <= 0. */
+
+ if (! (dev || des || dvx || dsx || dgv || dgs) && ntypes <= 0) {
+ s_wsfe(&io___193);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ goto L200;
+ }
+
+ } else {
+ if (dxv) {
+ s_copy(c3, "DXV", (ftnlen)3, (ftnlen)3);
+ }
+ if (dgx) {
+ s_copy(c3, "DGX", (ftnlen)3, (ftnlen)3);
+ }
+ }
+
+/* Reset the random number seed. */
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L250: */
+ }
+ }
+
+ if (lsamen_(&c__3, c3, "DHS") || lsamen_(&c__3, c3,
+ "NEP")) {
+
+/* ------------------------------------- */
+/* NEP: Nonsymmetric Eigenvalue Problem */
+/* ------------------------------------- */
+/* Vary the parameters */
+/* NB = block size */
+/* NBMIN = minimum block size */
+/* NX = crossover point */
+/* NS = number of shifts */
+/* MAXB = minimum submatrix size */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ xlaenv_(&c__1, &c__1);
+ if (tsterr) {
+ derrhs_("DHSEQR", &c__6);
+ }
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xlaenv_(&c__1, &nbval[i__ - 1]);
+ xlaenv_(&c__2, &nbmin[i__ - 1]);
+ xlaenv_(&c__3, &nxval[i__ - 1]);
+/* Computing MAX */
+ i__3 = 11, i__4 = inmin[i__ - 1];
+ i__2 = max(i__3,i__4);
+ xlaenv_(&c__12, &i__2);
+ xlaenv_(&c__13, &inwin[i__ - 1]);
+ xlaenv_(&c__14, &inibl[i__ - 1]);
+ xlaenv_(&c__15, &ishfts[i__ - 1]);
+ xlaenv_(&c__16, &iacc22[i__ - 1]);
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L260: */
+ }
+ }
+ s_wsfe(&io___196);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+/* Computing MAX */
+ i__3 = 11, i__4 = inmin[i__ - 1];
+ i__2 = max(i__3,i__4);
+ do_fio(&c__1, (char *)&i__2, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&inwin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&inibl[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ishfts[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iacc22[i__ - 1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ dchkhs_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &a[17424], &a[34848], &a[52272], &a[69696], &
+ c__132, &a[87120], &a[104544], d__, &d__[132], &d__[264],
+ &d__[396], &a[121968], &a[139392], &a[156816], &a[174240],
+ &a[191664], &d__[528], work, &c__87781, iwork, logwrk,
+ result, &info);
+ if (info != 0) {
+ s_wsfe(&io___204);
+ do_fio(&c__1, "DCHKHS", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L270: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "DST") || lsamen_(&
+ c__3, c3, "SEP")) {
+
+/* ---------------------------------- */
+/* SEP: Symmetric Eigenvalue Problem */
+/* ---------------------------------- */
+/* Vary the parameters */
+/* NB = block size */
+/* NBMIN = minimum block size */
+/* NX = crossover point */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ xlaenv_(&c__1, &c__1);
+ xlaenv_(&c__9, &c__25);
+ if (tsterr) {
+ derrst_("DST", &c__6);
+ }
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xlaenv_(&c__1, &nbval[i__ - 1]);
+ xlaenv_(&c__2, &nbmin[i__ - 1]);
+ xlaenv_(&c__3, &nxval[i__ - 1]);
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L280: */
+ }
+ }
+ s_wsfe(&io___205);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ if (tstchk) {
+ dchkst_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &c__6, a,
+ &c__132, &a[17424], d__, &d__[132], &d__[264], &d__[
+ 396], &d__[528], &d__[660], &d__[792], &d__[924], &
+ d__[1056], &d__[1188], &d__[1320], &a[34848], &c__132,
+ &a[52272], &a[69696], &d__[1452], &a[87120], work, &
+ c__87781, iwork, &c__89760, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___206);
+ do_fio(&c__1, "DCHKST", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ if (tstdrv) {
+ ddrvst_(&nn, nval, &c__18, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &d__[264], &d__[396], &d__[528], &d__[660], &
+ d__[924], &d__[1056], &d__[1188], &d__[1320], &a[
+ 17424], &c__132, &a[34848], &d__[1452], &a[52272],
+ work, &c__87781, iwork, &c__89760, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___207);
+ do_fio(&c__1, "DDRVST", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+/* L290: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "DSG")) {
+
+/* ---------------------------------------------- */
+/* DSG: Symmetric Generalized Eigenvalue Problem */
+/* ---------------------------------------------- */
+/* Vary the parameters */
+/* NB = block size */
+/* NBMIN = minimum block size */
+/* NX = crossover point */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ xlaenv_(&c__9, &c__25);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xlaenv_(&c__1, &nbval[i__ - 1]);
+ xlaenv_(&c__2, &nbmin[i__ - 1]);
+ xlaenv_(&c__3, &nxval[i__ - 1]);
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L300: */
+ }
+ }
+ s_wsfe(&io___208);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ if (tstchk) {
+ ddrvsg_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &c__6, a,
+ &c__132, &a[17424], &c__132, &d__[264], &a[34848], &
+ c__132, &a[52272], &a[69696], &a[87120], &a[104544],
+ work, &c__87781, iwork, &c__89760, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___209);
+ do_fio(&c__1, "DDRVSG", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+/* L310: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "DBD") || lsamen_(&
+ c__3, c3, "SVD")) {
+
+/* ---------------------------------- */
+/* SVD: Singular Value Decomposition */
+/* ---------------------------------- */
+/* Vary the parameters */
+/* NB = block size */
+/* NBMIN = minimum block size */
+/* NX = crossover point */
+/* NRHS = number of right hand sides */
+
+ maxtyp = 16;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ xlaenv_(&c__1, &c__1);
+ xlaenv_(&c__9, &c__25);
+
+/* Test the error exits */
+
+ if (tsterr && tstchk) {
+ derrbd_("DBD", &c__6);
+ }
+ if (tsterr && tstdrv) {
+ derred_("DBD", &c__6);
+ }
+
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nrhs = nsval[i__ - 1];
+ xlaenv_(&c__1, &nbval[i__ - 1]);
+ xlaenv_(&c__2, &nbmin[i__ - 1]);
+ xlaenv_(&c__3, &nxval[i__ - 1]);
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L320: */
+ }
+ }
+ s_wsfe(&io___211);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(integer));
+ e_wsfe();
+ if (tstchk) {
+ dchkbd_(&nn, mval, nval, &maxtyp, dotype, &nrhs, iseed, &
+ thresh, a, &c__132, d__, &d__[132], &d__[264], &d__[
+ 396], &a[17424], &c__132, &a[34848], &a[52272], &a[
+ 69696], &c__132, &a[87120], &c__132, &a[104544], &a[
+ 121968], work, &c__87781, iwork, &c__6, &info);
+ if (info != 0) {
+ s_wsfe(&io___212);
+ do_fio(&c__1, "DCHKBD", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ if (tstdrv) {
+ ddrvbd_(&nn, mval, nval, &maxtyp, dotype, iseed, &thresh, a, &
+ c__132, &a[17424], &c__132, &a[34848], &c__132, &a[
+ 52272], &a[69696], &a[87120], d__, &d__[132], &d__[
+ 264], work, &c__87781, iwork, &c__6, &info);
+ }
+/* L330: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "DEV")) {
+
+/* -------------------------------------------- */
+/* DEV: Nonsymmetric Eigenvalue Problem Driver */
+/* DGEEV (eigenvalues and eigenvectors) */
+/* -------------------------------------------- */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes <= 0) {
+ s_wsfe(&io___213);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ derred_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ ddrvev_(&nn, nval, &ntypes, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &a[17424], d__, &d__[132], &d__[264], &d__[396], &
+ a[34848], &c__132, &a[52272], &c__132, &a[69696], &c__132,
+ result, work, &c__87781, iwork, &info);
+ if (info != 0) {
+ s_wsfe(&io___214);
+ do_fio(&c__1, "DGEEV", (ftnlen)5);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___215);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "DES")) {
+
+/* -------------------------------------------- */
+/* DES: Nonsymmetric Eigenvalue Problem Driver */
+/* DGEES (Schur form) */
+/* -------------------------------------------- */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes <= 0) {
+ s_wsfe(&io___216);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ derred_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ ddrves_(&nn, nval, &ntypes, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &a[17424], &a[34848], d__, &d__[132], &d__[264], &
+ d__[396], &a[52272], &c__132, result, work, &c__87781,
+ iwork, logwrk, &info);
+ if (info != 0) {
+ s_wsfe(&io___217);
+ do_fio(&c__1, "DGEES", (ftnlen)5);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___218);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "DVX")) {
+
+/* -------------------------------------------------------------- */
+/* DVX: Nonsymmetric Eigenvalue Problem Expert Driver */
+/* DGEEVX (eigenvalues, eigenvectors and condition numbers) */
+/* -------------------------------------------------------------- */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes < 0) {
+ s_wsfe(&io___219);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ derred_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ ddrvvx_(&nn, nval, &ntypes, dotype, iseed, &thresh, &c__5, &c__6,
+ a, &c__132, &a[17424], d__, &d__[132], &d__[264], &d__[
+ 396], &a[34848], &c__132, &a[52272], &c__132, &a[69696], &
+ c__132, &d__[528], &d__[660], &d__[792], &d__[924], &d__[
+ 1056], &d__[1188], &d__[1320], &d__[1452], result, work, &
+ c__87781, iwork, &info);
+ if (info != 0) {
+ s_wsfe(&io___220);
+ do_fio(&c__1, "DGEEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___221);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "DSX")) {
+
+/* --------------------------------------------------- */
+/* DSX: Nonsymmetric Eigenvalue Problem Expert Driver */
+/* DGEESX (Schur form and condition numbers) */
+/* --------------------------------------------------- */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes < 0) {
+ s_wsfe(&io___222);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ derred_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ ddrvsx_(&nn, nval, &ntypes, dotype, iseed, &thresh, &c__5, &c__6,
+ a, &c__132, &a[17424], &a[34848], d__, &d__[132], &d__[
+ 264], &d__[396], &d__[528], &d__[660], &a[52272], &c__132,
+ &a[69696], result, work, &c__87781, iwork, logwrk, &info)
+ ;
+ if (info != 0) {
+ s_wsfe(&io___223);
+ do_fio(&c__1, "DGEESX", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___224);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "DGG")) {
+
+/* ------------------------------------------------- */
+/* DGG: Generalized Nonsymmetric Eigenvalue Problem */
+/* ------------------------------------------------- */
+/* Vary the parameters */
+/* NB = block size */
+/* NBMIN = minimum block size */
+/* NS = number of shifts */
+/* MAXB = minimum submatrix size */
+/* NBCOL = minimum column dimension for blocks */
+
+ maxtyp = 26;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ if (tstchk && tsterr) {
+ derrgg_(c3, &c__6);
+ }
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xlaenv_(&c__1, &nbval[i__ - 1]);
+ xlaenv_(&c__2, &nbmin[i__ - 1]);
+ xlaenv_(&c__4, &nsval[i__ - 1]);
+ xlaenv_(&c__8, &mxbval[i__ - 1]);
+ xlaenv_(&c__5, &nbcol[i__ - 1]);
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L340: */
+ }
+ }
+ s_wsfe(&io___225);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbcol[i__ - 1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ tstdif = FALSE_;
+ thrshn = 10.;
+ if (tstchk) {
+ dchkgg_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &tstdif, &
+ thrshn, &c__6, a, &c__132, &a[17424], &a[34848], &a[
+ 52272], &a[69696], &a[87120], &a[104544], &a[121968],
+ &a[139392], &c__132, &a[156816], &a[174240], &a[
+ 191664], d__, &d__[132], &d__[264], &d__[396], &d__[
+ 528], &d__[660], &a[209088], &a[226512], work, &
+ c__87781, logwrk, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___228);
+ do_fio(&c__1, "DCHKGG", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ xlaenv_(&c__1, &c__1);
+ if (tstdrv) {
+ ddrvgg_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &thrshn, &
+ c__6, a, &c__132, &a[17424], &a[34848], &a[52272], &a[
+ 69696], &a[87120], &a[104544], &c__132, &a[121968],
+ d__, &d__[132], &d__[264], &d__[396], &d__[528], &d__[
+ 660], &a[209088], &a[226512], work, &c__87781, result,
+ &info);
+ if (info != 0) {
+ s_wsfe(&io___229);
+ do_fio(&c__1, "DDRVGG", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+/* L350: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "DGS")) {
+
+/* ------------------------------------------------- */
+/* DGS: Generalized Nonsymmetric Eigenvalue Problem */
+/* DGGES (Schur form) */
+/* ------------------------------------------------- */
+
+ maxtyp = 26;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes <= 0) {
+ s_wsfe(&io___230);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ derrgg_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ ddrges_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &a[17424], &a[34848], &a[52272], &a[104544], &
+ c__132, &a[121968], d__, &d__[132], &d__[264], work, &
+ c__87781, result, logwrk, &info);
+
+ if (info != 0) {
+ s_wsfe(&io___231);
+ do_fio(&c__1, "DDRGES", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___232);
+ e_wsfe();
+ goto L10;
+
+ } else if (dgx) {
+
+/* ------------------------------------------------- */
+/* DGX: Generalized Nonsymmetric Eigenvalue Problem */
+/* DGGESX (Schur form and condition numbers) */
+/* ------------------------------------------------- */
+
+ maxtyp = 5;
+ ntypes = maxtyp;
+ if (nn < 0) {
+ s_wsfe(&io___233);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ derrgg_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ xlaenv_(&c__5, &c__2);
+ ddrgsx_(&nn, &c__20, &thresh, &c__5, &c__6, a, &c__132, &a[17424],
+ &a[34848], &a[52272], &a[69696], &a[87120], d__, &d__[
+ 132], &d__[264], c__, &c__400, &a[191664], work, &
+ c__87781, iwork, &c__89760, logwrk, &info);
+ if (info != 0) {
+ s_wsfe(&io___235);
+ do_fio(&c__1, "DDRGSX", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___236);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "DGV")) {
+
+/* ------------------------------------------------- */
+/* DGV: Generalized Nonsymmetric Eigenvalue Problem */
+/* DGGEV (Eigenvalue/vector form) */
+/* ------------------------------------------------- */
+
+ maxtyp = 26;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes <= 0) {
+ s_wsfe(&io___237);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ derrgg_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ ddrgev_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &a[17424], &a[34848], &a[52272], &a[104544], &
+ c__132, &a[121968], &a[139392], &c__132, d__, &d__[132], &
+ d__[264], &d__[396], &d__[528], &d__[660], work, &
+ c__87781, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___238);
+ do_fio(&c__1, "DDRGEV", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___239);
+ e_wsfe();
+ goto L10;
+
+ } else if (dxv) {
+
+/* ------------------------------------------------- */
+/* DXV: Generalized Nonsymmetric Eigenvalue Problem */
+/* DGGEVX (eigenvalue/vector with condition numbers) */
+/* ------------------------------------------------- */
+
+ maxtyp = 2;
+ ntypes = maxtyp;
+ if (nn < 0) {
+ s_wsfe(&io___240);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ derrgg_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ ddrgvx_(&nn, &thresh, &c__5, &c__6, a, &c__132, &a[17424], &a[
+ 34848], &a[52272], d__, &d__[132], &d__[264], &a[69696], &
+ a[87120], iwork, &iwork[1], &d__[396], &d__[528], &d__[
+ 660], &d__[792], &d__[924], &d__[1056], work, &c__87781, &
+ iwork[2], &c__89758, result, logwrk, &info);
+
+ if (info != 0) {
+ s_wsfe(&io___241);
+ do_fio(&c__1, "DDRGVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___242);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "DSB")) {
+
+/* ------------------------------ */
+/* DSB: Symmetric Band Reduction */
+/* ------------------------------ */
+
+ maxtyp = 15;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ if (tsterr) {
+ derrst_("DSB", &c__6);
+ }
+ dchksb_(&nn, nval, &nk, kval, &maxtyp, dotype, iseed, &thresh, &c__6,
+ a, &c__132, d__, &d__[132], &a[17424], &c__132, work, &
+ c__87781, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___243);
+ do_fio(&c__1, "DCHKSB", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "DBB")) {
+
+/* ------------------------------ */
+/* DBB: General Band Reduction */
+/* ------------------------------ */
+
+ maxtyp = 15;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nrhs = nsval[i__ - 1];
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L360: */
+ }
+ }
+ s_wsfe(&io___244);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(integer));
+ e_wsfe();
+ dchkbb_(&nn, mval, nval, &nk, kval, &maxtyp, dotype, &nrhs, iseed,
+ &thresh, &c__6, a, &c__132, &a[17424], &c__264, d__, &
+ d__[132], &a[52272], &c__132, &a[69696], &c__132, &a[
+ 87120], &c__132, &a[104544], work, &c__87781, result, &
+ info);
+ if (info != 0) {
+ s_wsfe(&io___245);
+ do_fio(&c__1, "DCHKBB", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L370: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "GLM")) {
+
+/* ----------------------------------------- */
+/* GLM: Generalized Linear Regression Model */
+/* ----------------------------------------- */
+
+ xlaenv_(&c__1, &c__1);
+ if (tsterr) {
+ derrgg_("GLM", &c__6);
+ }
+ dckglm_(&nn, mval, pval, nval, &ntypes, iseed, &thresh, &c__132, a, &
+ a[17424], b, &b[17424], x, work, d__, &c__5, &c__6, &info);
+ if (info != 0) {
+ s_wsfe(&io___248);
+ do_fio(&c__1, "DCKGLM", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "GQR")) {
+
+/* ------------------------------------------ */
+/* GQR: Generalized QR and RQ factorizations */
+/* ------------------------------------------ */
+
+ xlaenv_(&c__1, &c__1);
+ if (tsterr) {
+ derrgg_("GQR", &c__6);
+ }
+ dckgqr_(&nn, mval, &nn, pval, &nn, nval, &ntypes, iseed, &thresh, &
+ c__132, a, &a[17424], &a[34848], &a[52272], taua, b, &b[17424]
+, &b[34848], &b[52272], &b[69696], taub, work, d__, &c__5, &
+ c__6, &info);
+ if (info != 0) {
+ s_wsfe(&io___251);
+ do_fio(&c__1, "DCKGQR", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "GSV")) {
+
+/* ---------------------------------------------- */
+/* GSV: Generalized Singular Value Decomposition */
+/* ---------------------------------------------- */
+
+ if (tsterr) {
+ derrgg_("GSV", &c__6);
+ }
+ dckgsv_(&nn, mval, pval, nval, &ntypes, iseed, &thresh, &c__132, a, &
+ a[17424], b, &b[17424], &a[34848], &b[34848], &a[52272], taua,
+ taub, &b[52272], iwork, work, d__, &c__5, &c__6, &info);
+ if (info != 0) {
+ s_wsfe(&io___252);
+ do_fio(&c__1, "DCKGSV", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "LSE")) {
+
+/* -------------------------------------- */
+/* LSE: Constrained Linear Least Squares */
+/* -------------------------------------- */
+
+ xlaenv_(&c__1, &c__1);
+ if (tsterr) {
+ derrgg_("LSE", &c__6);
+ }
+ dcklse_(&nn, mval, pval, nval, &ntypes, iseed, &thresh, &c__132, a, &
+ a[17424], b, &b[17424], x, work, d__, &c__5, &c__6, &info);
+ if (info != 0) {
+ s_wsfe(&io___253);
+ do_fio(&c__1, "DCKLSE", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else {
+ s_wsle(&io___254);
+ e_wsle();
+ s_wsle(&io___255);
+ e_wsle();
+ s_wsfe(&io___256);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ }
+ if (! (dgx || dxv)) {
+ goto L190;
+ }
+L380:
+ s_wsfe(&io___257);
+ e_wsfe();
+ s2 = dsecnd_();
+ s_wsfe(&io___259);
+ d__1 = s2 - s1;
+ do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+/* L9998: */
+
+/* End of DCHKEE */
+
+ return 0;
+} /* MAIN__ */
+
+/* Main program alias */ int dchkee_ () { MAIN__ (); return 0; }
diff --git a/TESTING/EIG/dchkgg.c b/TESTING/EIG/dchkgg.c
new file mode 100644
index 0000000..e42c581
--- /dev/null
+++ b/TESTING/EIG/dchkgg.c
@@ -0,0 +1,1483 @@
+/* dchkgg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b13 = 0.;
+static integer c__2 = 2;
+static doublereal c_b19 = 1.;
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int dchkgg_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, logical *tstdif,
+ doublereal *thrshn, integer *nounit, doublereal *a, integer *lda,
+ doublereal *b, doublereal *h__, doublereal *t, doublereal *s1,
+ doublereal *s2, doublereal *p1, doublereal *p2, doublereal *u,
+ integer *ldu, doublereal *v, doublereal *q, doublereal *z__,
+ doublereal *alphr1, doublereal *alphi1, doublereal *beta1, doublereal
+ *alphr3, doublereal *alphi3, doublereal *beta3, doublereal *evectl,
+ doublereal *evectr, doublereal *work, integer *lwork, logical *llwork,
+ doublereal *result, integer *info)
+{
+ /* Initialized data */
+
+ static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
+ 2,2,2,3 };
+ static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
+ 2,3,2,1 };
+ static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
+ 1,1,1,1 };
+ static integer iasign[26] = { 0,0,0,0,0,0,2,0,2,2,0,0,2,2,2,0,2,0,0,0,2,2,
+ 2,2,2,0 };
+ static integer ibsign[26] = { 0,0,0,0,0,0,0,2,0,0,2,2,0,0,2,0,2,0,0,0,0,0,
+ 0,0,0,0 };
+ static integer kz1[6] = { 0,1,2,1,3,3 };
+ static integer kz2[6] = { 0,0,1,2,1,1 };
+ static integer kadd[6] = { 0,0,0,0,3,2 };
+ static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
+ 4,4,4,0 };
+ static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
+ 8,8,8,8,8,0 };
+ static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
+ 3,3,3,1 };
+ static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
+ 4,4,4,1 };
+ static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
+ 3,3,2,1 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 DCHKGG: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 DCHKGG: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
+ "i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9997[] = "(/1x,a3,\002 -- Real Generalized eigenvalue pr"
+ "oblem\002)";
+ static char fmt_9996[] = "(\002 Matrix types (see DCHKGG for details):"
+ " \002)";
+ static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
+ "osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
+ ") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
+ "onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
+ "I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
+ "arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
+ "(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
+ "=(D, reversed D)\002)";
+ static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
+ "atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
+ " 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
+ "ha&beta \002,\002 20=arithmetic alpha, beta=0,"
+ "1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
+ "=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
+ "/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
+ "l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
+ ".\002)";
+ static char fmt_9993[] = "(/\002 Tests performed: (H is Hessenberg, S "
+ "is Schur, B, \002,\002T, P are triangular,\002,/20x,\002U, V, Q,"
+ " and Z are \002,a,\002, l and r are the\002,/20x,\002appropriate"
+ " left and right eigenvectors, resp., a is\002,/20x,\002alpha, b "
+ "is beta, and \002,a,\002 means \002,a,\002.)\002,/\002 1 = | A -"
+ " U H V\002,a,\002 | / ( |A| n ulp ) 2 = | B - U T V\002,a"
+ ",\002 | / ( |B| n ulp )\002,/\002 3 = | I - UU\002,a,\002 | / ( "
+ "n ulp ) 4 = | I - VV\002,a,\002 | / ( n ulp )\002,"
+ "/\002 5 = | H - Q S Z\002,a,\002 | / ( |H| n ulp )\002,6x,\0026 "
+ "= | T - Q P Z\002,a,\002 | / ( |T| n ulp )\002,/\002 7 = | I - QQ"
+ "\002,a,\002 | / ( n ulp ) 8 = | I - ZZ\002,a,\002 | "
+ "/ ( n ulp )\002,/\002 9 = max | ( b S - a P )\002,a,\002 l | / c"
+ "onst. 10 = max | ( b H - a T )\002,a,\002 l | / const.\002,/"
+ "\002 11= max | ( b S - a P ) r | / const. 12 = max | ( b H\002,"
+ "\002 - a T ) r | / const.\002,/1x)";
+ static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",0p,f8.2)";
+ static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",1p,d10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, evectl_dim1, evectl_offset,
+ evectr_dim1, evectr_offset, h_dim1, h_offset, p1_dim1, p1_offset,
+ p2_dim1, p2_offset, q_dim1, q_offset, s1_dim1, s1_offset, s2_dim1,
+ s2_offset, t_dim1, t_offset, u_dim1, u_offset, v_dim1, v_offset,
+ z_dim1, z_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer j, n, i1, n1, jc, in, jr;
+ doublereal ulp;
+ integer iadd, nmax;
+ doublereal temp1, temp2;
+ logical badnn;
+ extern /* Subroutine */ int dget51_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *), dget52_(
+ logical *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *);
+ doublereal dumma[4];
+ integer iinfo;
+ doublereal rmagn[4], anorm, bnorm;
+ integer nmats, jsize, nerrs, jtype, ntest;
+ extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *), dlatm4_(
+ integer *, integer *, integer *, integer *, integer *, doublereal
+ *, doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *), dorm2r_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *), dlabad_(
+ doublereal *, doublereal *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dgghrd_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dlarfg_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *);
+ extern doublereal dlarnd_(integer *, integer *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ doublereal safmin;
+ integer ioldsd[4];
+ doublereal safmax;
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ dhgeqz_(char *, char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *), dtgevc_(char *, char *, logical *, integer *, doublereal
+ *, integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, integer *, integer *, doublereal *,
+ integer *), dlasum_(char *, integer *, integer *,
+ integer *), xerbla_(char *, integer *);
+ doublereal ulpinv;
+ integer lwkopt, mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___68 = { 0, 0, 0, fmt_9991, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKGG checks the nonsymmetric generalized eigenvalue problem */
+/* routines. */
+/* T T T */
+/* DGGHRD factors A and B as U H V and U T V , where means */
+/* transpose, H is hessenberg, T is triangular and U and V are */
+/* orthogonal. */
+/* T T */
+/* DHGEQZ factors H and T as Q S Z and Q P Z , where P is upper */
+/* triangular, S is in generalized Schur form (block upper triangular, */
+/* with 1x1 and 2x2 blocks on the diagonal, the 2x2 blocks */
+/* corresponding to complex conjugate pairs of generalized */
+/* eigenvalues), and Q and Z are orthogonal. It also computes the */
+/* generalized eigenvalues (alpha(1),beta(1)),...,(alpha(n),beta(n)), */
+/* where alpha(j)=S(j,j) and beta(j)=P(j,j) -- thus, */
+/* w(j) = alpha(j)/beta(j) is a root of the generalized eigenvalue */
+/* problem */
+
+/* det( A - w(j) B ) = 0 */
+
+/* and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent */
+/* problem */
+
+/* det( m(j) A - B ) = 0 */
+
+/* DTGEVC computes the matrix L of left eigenvectors and the matrix R */
+/* of right eigenvectors for the matrix pair ( S, P ). In the */
+/* description below, l and r are left and right eigenvectors */
+/* corresponding to the generalized eigenvalues (alpha,beta). */
+
+/* When DCHKGG is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 15 */
+/* tests will be performed. The first twelve "test ratios" should be */
+/* small -- O(1). They will be compared with the threshhold THRESH: */
+
+/* T */
+/* (1) | A - U H V | / ( |A| n ulp ) */
+
+/* T */
+/* (2) | B - U T V | / ( |B| n ulp ) */
+
+/* T */
+/* (3) | I - UU | / ( n ulp ) */
+
+/* T */
+/* (4) | I - VV | / ( n ulp ) */
+
+/* T */
+/* (5) | H - Q S Z | / ( |H| n ulp ) */
+
+/* T */
+/* (6) | T - Q P Z | / ( |T| n ulp ) */
+
+/* T */
+/* (7) | I - QQ | / ( n ulp ) */
+
+/* T */
+/* (8) | I - ZZ | / ( n ulp ) */
+
+/* (9) max over all left eigenvalue/-vector pairs (beta/alpha,l) of */
+
+/* | l**H * (beta S - alpha P) | / ( ulp max( |beta S|, |alpha P| ) ) */
+
+/* (10) max over all left eigenvalue/-vector pairs (beta/alpha,l') of */
+/* T */
+/* | l'**H * (beta H - alpha T) | / ( ulp max( |beta H|, |alpha T| ) ) */
+
+/* where the eigenvectors l' are the result of passing Q to */
+/* DTGEVC and back transforming (HOWMNY='B'). */
+
+/* (11) max over all right eigenvalue/-vector pairs (beta/alpha,r) of */
+
+/* | (beta S - alpha T) r | / ( ulp max( |beta S|, |alpha T| ) ) */
+
+/* (12) max over all right eigenvalue/-vector pairs (beta/alpha,r') of */
+
+/* | (beta H - alpha T) r' | / ( ulp max( |beta H|, |alpha T| ) ) */
+
+/* where the eigenvectors r' are the result of passing Z to */
+/* DTGEVC and back transforming (HOWMNY='B'). */
+
+/* The last three test ratios will usually be small, but there is no */
+/* mathematical requirement that they be so. They are therefore */
+/* compared with THRESH only if TSTDIF is .TRUE. */
+
+/* (13) | S(Q,Z computed) - S(Q,Z not computed) | / ( |S| ulp ) */
+
+/* (14) | P(Q,Z computed) - P(Q,Z not computed) | / ( |P| ulp ) */
+
+/* (15) max( |alpha(Q,Z computed) - alpha(Q,Z not computed)|/|S| , */
+/* |beta(Q,Z computed) - beta(Q,Z not computed)|/|P| ) / ulp */
+
+/* In addition, the normalization of L and R are checked, and compared */
+/* with the threshhold THRSHN. */
+
+/* Test Matrices */
+/* ---- -------- */
+
+/* The sizes of the test matrices are specified by an array */
+/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
+/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) ( 0, 0 ) (a pair of zero matrices) */
+
+/* (2) ( I, 0 ) (an identity and a zero matrix) */
+
+/* (3) ( 0, I ) (an identity and a zero matrix) */
+
+/* (4) ( I, I ) (a pair of identity matrices) */
+
+/* t t */
+/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
+
+/* t ( I 0 ) */
+/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
+/* ( 0 I ) ( 0 J ) */
+/* and I is a k x k identity and J a (k+1)x(k+1) */
+/* Jordan block; k=(N-1)/2 */
+
+/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
+/* matrix with those diagonal entries.) */
+/* (8) ( I, D ) */
+
+/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
+
+/* (10) ( small*D, big*I ) */
+
+/* (11) ( big*I, small*D ) */
+
+/* (12) ( small*I, big*D ) */
+
+/* (13) ( big*D, big*I ) */
+
+/* (14) ( small*D, small*I ) */
+
+/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
+/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
+/* t t */
+/* (16) U ( J , J ) V where U and V are random orthogonal matrices. */
+
+/* (17) U ( T1, T2 ) V where T1 and T2 are upper triangular matrices */
+/* with random O(1) entries above the diagonal */
+/* and diagonal entries diag(T1) = */
+/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
+/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
+
+/* (18) U ( T1, T2 ) V diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
+/* s = machine precision. */
+
+/* (19) U ( T1, T2 ) V diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
+
+/* N-5 */
+/* (20) U ( T1, T2 ) V diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+
+/* (21) U ( T1, T2 ) V diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+/* where r1,..., r(N-4) are random. */
+
+/* (22) U ( big*T1, small*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (23) U ( small*T1, big*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (24) U ( small*T1, small*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (25) U ( big*T1, big*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (26) U ( T1, T2 ) V where T1 and T2 are random upper-triangular */
+/* matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* DCHKGG does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, DCHKGG */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to DCHKGG to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error is */
+/* scaled to be O(1), so THRESH should be a reasonably small */
+/* multiple of 1, e.g., 10 or 100. In particular, it should */
+/* not depend on the precision (single vs. double) or the size */
+/* of the matrix. It must be at least zero. */
+
+/* TSTDIF (input) LOGICAL */
+/* Specifies whether test ratios 13-15 will be computed and */
+/* compared with THRESH. */
+/* = .FALSE.: Only test ratios 1-12 will be computed and tested. */
+/* Ratios 13-15 will be set to zero. */
+/* = .TRUE.: All the test ratios 1-15 will be computed and */
+/* tested. */
+
+/* THRSHN (input) DOUBLE PRECISION */
+/* Threshhold for reporting eigenvector normalization error. */
+/* If the normalization of any eigenvector differs from 1 by */
+/* more than THRSHN*ulp, then a special error message will be */
+/* printed. (This is handled separately from the other tests, */
+/* since only a compiler or programming error should cause an */
+/* error message, at least if THRSHN is at least 5--10.) */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace) DOUBLE PRECISION array, dimension */
+/* (LDA, max(NN)) */
+/* Used to hold the original A matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, H, T, S1, P1, S2, and P2. */
+/* It must be at least 1 and at least max( NN ). */
+
+/* B (input/workspace) DOUBLE PRECISION array, dimension */
+/* (LDA, max(NN)) */
+/* Used to hold the original B matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* H (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) */
+/* The upper Hessenberg matrix computed from A by DGGHRD. */
+
+/* T (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from B by DGGHRD. */
+
+/* S1 (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) */
+/* The Schur (block upper triangular) matrix computed from H by */
+/* DHGEQZ when Q and Z are also computed. */
+
+/* S2 (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) */
+/* The Schur (block upper triangular) matrix computed from H by */
+/* DHGEQZ when Q and Z are not computed. */
+
+/* P1 (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from T by DHGEQZ */
+/* when Q and Z are also computed. */
+
+/* P2 (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from T by DHGEQZ */
+/* when Q and Z are not computed. */
+
+/* U (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN)) */
+/* The (left) orthogonal matrix computed by DGGHRD. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U, V, Q, Z, EVECTL, and EVEZTR. It */
+/* must be at least 1 and at least max( NN ). */
+
+/* V (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN)) */
+/* The (right) orthogonal matrix computed by DGGHRD. */
+
+/* Q (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN)) */
+/* The (left) orthogonal matrix computed by DHGEQZ. */
+
+/* Z (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN)) */
+/* The (left) orthogonal matrix computed by DHGEQZ. */
+
+/* ALPHR1 (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* ALPHI1 (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* BETA1 (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+
+/* The generalized eigenvalues of (A,B) computed by DHGEQZ */
+/* when Q, Z, and the full Schur matrices are computed. */
+/* On exit, ( ALPHR1(k)+ALPHI1(k)*i ) / BETA1(k) is the k-th */
+/* generalized eigenvalue of the matrices in A and B. */
+
+/* ALPHR3 (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* ALPHI3 (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* BETA3 (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+
+/* EVECTL (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN)) */
+/* The (block lower triangular) left eigenvector matrix for */
+/* the matrices in S1 and P1. (See DTGEVC for the format.) */
+
+/* EVEZTR (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN)) */
+/* The (block upper triangular) right eigenvector matrix for */
+/* the matrices in S1 and P1. (See DTGEVC for the format.) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* max( 2 * N**2, 6*N, 1 ), for all N=NN(j). */
+
+/* LLWORK (workspace) LOGICAL array, dimension (max(NN)) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (15) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: A routine returned an error code. INFO is the */
+/* absolute value of the INFO value returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ p2_dim1 = *lda;
+ p2_offset = 1 + p2_dim1;
+ p2 -= p2_offset;
+ p1_dim1 = *lda;
+ p1_offset = 1 + p1_dim1;
+ p1 -= p1_offset;
+ s2_dim1 = *lda;
+ s2_offset = 1 + s2_dim1;
+ s2 -= s2_offset;
+ s1_dim1 = *lda;
+ s1_offset = 1 + s1_dim1;
+ s1 -= s1_offset;
+ t_dim1 = *lda;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ evectr_dim1 = *ldu;
+ evectr_offset = 1 + evectr_dim1;
+ evectr -= evectr_offset;
+ evectl_dim1 = *ldu;
+ evectl_offset = 1 + evectl_dim1;
+ evectl -= evectl_offset;
+ z_dim1 = *ldu;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ q_dim1 = *ldu;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ v_dim1 = *ldu;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --alphr1;
+ --alphi1;
+ --beta1;
+ --alphr3;
+ --alphi3;
+ --beta3;
+ --work;
+ --llwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Maximum blocksize and shift -- we assume that blocksize and number */
+/* of shifts are monotone increasing functions of N. */
+
+/* Computing MAX */
+ i__1 = nmax * 6, i__2 = (nmax << 1) * nmax, i__1 = max(i__1,i__2);
+ lwkopt = max(i__1,1);
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.) {
+ *info = -6;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -10;
+ } else if (*ldu <= 1 || *ldu < nmax) {
+ *info = -19;
+ } else if (lwkopt > *lwork) {
+ *info = -30;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DCHKGG", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+ safmin = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ safmin /= ulp;
+ safmax = 1. / safmin;
+ dlabad_(&safmin, &safmax);
+ ulpinv = 1. / ulp;
+
+/* The values RMAGN(2:3) depend on N, see below. */
+
+ rmagn[0] = 0.;
+ rmagn[1] = 1.;
+
+/* Loop over sizes, types */
+
+ ntestt = 0;
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ n1 = max(1,n);
+ rmagn[2] = safmax * ulp / (doublereal) n1;
+ rmagn[3] = safmin * ulpinv * n1;
+
+ if (*nsizes != 1) {
+ mtypes = min(26,*ntypes);
+ } else {
+ mtypes = min(27,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L230;
+ }
+ ++nmats;
+ ntest = 0;
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 15; ++j) {
+ result[j] = 0.;
+/* L30: */
+ }
+
+/* Compute A and B */
+
+/* Description of control parameters: */
+
+/* KZLASS: =1 means w/o rotation, =2 means w/ rotation, */
+/* =3 means random. */
+/* KATYPE: the "type" to be passed to DLATM4 for computing A. */
+/* KAZERO: the pattern of zeros on the diagonal for A: */
+/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
+/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
+/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
+/* non-zero entries.) */
+/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
+/* =2: large, =3: small. */
+/* IASIGN: 1 if the diagonal elements of A are to be */
+/* multiplied by a random magnitude 1 number, =2 if */
+/* randomly chosen diagonal blocks are to be rotated */
+/* to form 2x2 blocks. */
+/* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B. */
+/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
+/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
+/* RMAGN: used to implement KAMAGN and KBMAGN. */
+
+ if (mtypes > 26) {
+ goto L110;
+ }
+ iinfo = 0;
+ if (kclass[jtype - 1] < 3) {
+
+/* Generate A (w/o rotation) */
+
+ if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ dlaset_("Full", &n, &n, &c_b13, &c_b13, &a[a_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ dlatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
+ &kz2[kazero[jtype - 1] - 1], &iasign[jtype - 1], &
+ rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
+ 1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
+ a_offset], lda);
+ iadd = kadd[kazero[jtype - 1] - 1];
+ if (iadd > 0 && iadd <= n) {
+ a[iadd + iadd * a_dim1] = rmagn[kamagn[jtype - 1]];
+ }
+
+/* Generate B (w/o rotation) */
+
+ if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ dlaset_("Full", &n, &n, &c_b13, &c_b13, &b[b_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ dlatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
+ &kz2[kbzero[jtype - 1] - 1], &ibsign[jtype - 1], &
+ rmagn[kbmagn[jtype - 1]], &c_b19, &rmagn[ktrian[jtype
+ - 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
+ b_offset], lda);
+ iadd = kadd[kbzero[jtype - 1] - 1];
+ if (iadd != 0 && iadd <= n) {
+ b[iadd + iadd * b_dim1] = rmagn[kbmagn[jtype - 1]];
+ }
+
+ if (kclass[jtype - 1] == 2 && n > 0) {
+
+/* Include rotations */
+
+/* Generate U, V as Householder transformations times */
+/* a diagonal matrix. */
+
+ i__3 = n - 1;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = jc; jr <= i__4; ++jr) {
+ u[jr + jc * u_dim1] = dlarnd_(&c__3, &iseed[1]);
+ v[jr + jc * v_dim1] = dlarnd_(&c__3, &iseed[1]);
+/* L40: */
+ }
+ i__4 = n + 1 - jc;
+ dlarfg_(&i__4, &u[jc + jc * u_dim1], &u[jc + 1 + jc *
+ u_dim1], &c__1, &work[jc]);
+ work[(n << 1) + jc] = d_sign(&c_b19, &u[jc + jc *
+ u_dim1]);
+ u[jc + jc * u_dim1] = 1.;
+ i__4 = n + 1 - jc;
+ dlarfg_(&i__4, &v[jc + jc * v_dim1], &v[jc + 1 + jc *
+ v_dim1], &c__1, &work[n + jc]);
+ work[n * 3 + jc] = d_sign(&c_b19, &v[jc + jc * v_dim1]
+ );
+ v[jc + jc * v_dim1] = 1.;
+/* L50: */
+ }
+ u[n + n * u_dim1] = 1.;
+ work[n] = 0.;
+ d__1 = dlarnd_(&c__2, &iseed[1]);
+ work[n * 3] = d_sign(&c_b19, &d__1);
+ v[n + n * v_dim1] = 1.;
+ work[n * 2] = 0.;
+ d__1 = dlarnd_(&c__2, &iseed[1]);
+ work[n * 4] = d_sign(&c_b19, &d__1);
+
+/* Apply the diagonal matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ a[jr + jc * a_dim1] = work[(n << 1) + jr] * work[
+ n * 3 + jc] * a[jr + jc * a_dim1];
+ b[jr + jc * b_dim1] = work[(n << 1) + jr] * work[
+ n * 3 + jc] * b[jr + jc * b_dim1];
+/* L60: */
+ }
+/* L70: */
+ }
+ i__3 = n - 1;
+ dorm2r_("L", "N", &n, &n, &i__3, &u[u_offset], ldu, &work[
+ 1], &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ dorm2r_("R", "T", &n, &n, &i__3, &v[v_offset], ldu, &work[
+ n + 1], &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ dorm2r_("L", "N", &n, &n, &i__3, &u[u_offset], ldu, &work[
+ 1], &b[b_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ dorm2r_("R", "T", &n, &n, &i__3, &v[v_offset], ldu, &work[
+ n + 1], &b[b_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ }
+ } else {
+
+/* Random matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ a[jr + jc * a_dim1] = rmagn[kamagn[jtype - 1]] *
+ dlarnd_(&c__2, &iseed[1]);
+ b[jr + jc * b_dim1] = rmagn[kbmagn[jtype - 1]] *
+ dlarnd_(&c__2, &iseed[1]);
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+
+ anorm = dlange_("1", &n, &n, &a[a_offset], lda, &work[1]);
+ bnorm = dlange_("1", &n, &n, &b[b_offset], lda, &work[1]);
+
+L100:
+
+ if (iinfo != 0) {
+ io___40.ciunit = *nounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L110:
+
+/* Call DGEQR2, DORM2R, and DGGHRD to compute H, T, U, and V */
+
+ dlacpy_(" ", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+ dlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ ntest = 1;
+ result[1] = ulpinv;
+
+ dgeqr2_(&n, &n, &t[t_offset], lda, &work[1], &work[n + 1], &iinfo)
+ ;
+ if (iinfo != 0) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "DGEQR2", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ dorm2r_("L", "T", &n, &n, &n, &t[t_offset], lda, &work[1], &h__[
+ h_offset], lda, &work[n + 1], &iinfo);
+ if (iinfo != 0) {
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "DORM2R", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ dlaset_("Full", &n, &n, &c_b13, &c_b19, &u[u_offset], ldu);
+ dorm2r_("R", "N", &n, &n, &n, &t[t_offset], lda, &work[1], &u[
+ u_offset], ldu, &work[n + 1], &iinfo);
+ if (iinfo != 0) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "DORM2R", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ dgghrd_("V", "I", &n, &c__1, &n, &h__[h_offset], lda, &t[t_offset]
+, lda, &u[u_offset], ldu, &v[v_offset], ldu, &iinfo);
+ if (iinfo != 0) {
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "DGGHRD", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+ ntest = 4;
+
+/* Do tests 1--4 */
+
+ dget51_(&c__1, &n, &a[a_offset], lda, &h__[h_offset], lda, &u[
+ u_offset], ldu, &v[v_offset], ldu, &work[1], &result[1]);
+ dget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &u[
+ u_offset], ldu, &v[v_offset], ldu, &work[1], &result[2]);
+ dget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &u[
+ u_offset], ldu, &u[u_offset], ldu, &work[1], &result[3]);
+ dget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &v[
+ v_offset], ldu, &v[v_offset], ldu, &work[1], &result[4]);
+
+/* Call DHGEQZ to compute S1, P1, S2, P2, Q, and Z, do tests. */
+
+/* Compute T1 and UZ */
+
+/* Eigenvalues only */
+
+ dlacpy_(" ", &n, &n, &h__[h_offset], lda, &s2[s2_offset], lda);
+ dlacpy_(" ", &n, &n, &t[t_offset], lda, &p2[p2_offset], lda);
+ ntest = 5;
+ result[5] = ulpinv;
+
+ dhgeqz_("E", "N", "N", &n, &c__1, &n, &s2[s2_offset], lda, &p2[
+ p2_offset], lda, &alphr3[1], &alphi3[1], &beta3[1], &q[
+ q_offset], ldu, &z__[z_offset], ldu, &work[1], lwork, &
+ iinfo);
+ if (iinfo != 0) {
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "DHGEQZ(E)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+/* Eigenvalues and Full Schur Form */
+
+ dlacpy_(" ", &n, &n, &h__[h_offset], lda, &s2[s2_offset], lda);
+ dlacpy_(" ", &n, &n, &t[t_offset], lda, &p2[p2_offset], lda);
+
+ dhgeqz_("S", "N", "N", &n, &c__1, &n, &s2[s2_offset], lda, &p2[
+ p2_offset], lda, &alphr1[1], &alphi1[1], &beta1[1], &q[
+ q_offset], ldu, &z__[z_offset], ldu, &work[1], lwork, &
+ iinfo);
+ if (iinfo != 0) {
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, "DHGEQZ(S)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+/* Eigenvalues, Schur Form, and Schur Vectors */
+
+ dlacpy_(" ", &n, &n, &h__[h_offset], lda, &s1[s1_offset], lda);
+ dlacpy_(" ", &n, &n, &t[t_offset], lda, &p1[p1_offset], lda);
+
+ dhgeqz_("S", "I", "I", &n, &c__1, &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, &alphr1[1], &alphi1[1], &beta1[1], &q[
+ q_offset], ldu, &z__[z_offset], ldu, &work[1], lwork, &
+ iinfo);
+ if (iinfo != 0) {
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ do_fio(&c__1, "DHGEQZ(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ ntest = 8;
+
+/* Do Tests 5--8 */
+
+ dget51_(&c__1, &n, &h__[h_offset], lda, &s1[s1_offset], lda, &q[
+ q_offset], ldu, &z__[z_offset], ldu, &work[1], &result[5])
+ ;
+ dget51_(&c__1, &n, &t[t_offset], lda, &p1[p1_offset], lda, &q[
+ q_offset], ldu, &z__[z_offset], ldu, &work[1], &result[6])
+ ;
+ dget51_(&c__3, &n, &t[t_offset], lda, &p1[p1_offset], lda, &q[
+ q_offset], ldu, &q[q_offset], ldu, &work[1], &result[7]);
+ dget51_(&c__3, &n, &t[t_offset], lda, &p1[p1_offset], lda, &z__[
+ z_offset], ldu, &z__[z_offset], ldu, &work[1], &result[8])
+ ;
+
+/* Compute the Left and Right Eigenvectors of (S1,P1) */
+
+/* 9: Compute the left eigenvector Matrix without */
+/* back transforming: */
+
+ ntest = 9;
+ result[9] = ulpinv;
+
+/* To test "SELECT" option, compute half of the eigenvectors */
+/* in one call, and half in another */
+
+ i1 = n / 2;
+ i__3 = i1;
+ for (j = 1; j <= i__3; ++j) {
+ llwork[j] = TRUE_;
+/* L120: */
+ }
+ i__3 = n;
+ for (j = i1 + 1; j <= i__3; ++j) {
+ llwork[j] = FALSE_;
+/* L130: */
+ }
+
+ dtgevc_("L", "S", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, &evectl[evectl_offset], ldu, dumma, ldu,
+ &n, &in, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ do_fio(&c__1, "DTGEVC(L,S1)", (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ i1 = in;
+ i__3 = i1;
+ for (j = 1; j <= i__3; ++j) {
+ llwork[j] = FALSE_;
+/* L140: */
+ }
+ i__3 = n;
+ for (j = i1 + 1; j <= i__3; ++j) {
+ llwork[j] = TRUE_;
+/* L150: */
+ }
+
+ dtgevc_("L", "S", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, &evectl[(i1 + 1) * evectl_dim1 + 1], ldu,
+ dumma, ldu, &n, &in, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "DTGEVC(L,S2)", (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ dget52_(&c_true, &n, &s1[s1_offset], lda, &p1[p1_offset], lda, &
+ evectl[evectl_offset], ldu, &alphr1[1], &alphi1[1], &
+ beta1[1], &work[1], dumma);
+ result[9] = dumma[0];
+ if (dumma[1] > *thrshn) {
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "DTGEVC(HOWMNY=S)", (ftnlen)16);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* 10: Compute the left eigenvector Matrix with */
+/* back transforming: */
+
+ ntest = 10;
+ result[10] = ulpinv;
+ dlacpy_("F", &n, &n, &q[q_offset], ldu, &evectl[evectl_offset],
+ ldu);
+ dtgevc_("L", "B", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, &evectl[evectl_offset], ldu, dumma, ldu,
+ &n, &in, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, "DTGEVC(L,B)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ dget52_(&c_true, &n, &h__[h_offset], lda, &t[t_offset], lda, &
+ evectl[evectl_offset], ldu, &alphr1[1], &alphi1[1], &
+ beta1[1], &work[1], dumma);
+ result[10] = dumma[0];
+ if (dumma[1] > *thrshn) {
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "DTGEVC(HOWMNY=B)", (ftnlen)16);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* 11: Compute the right eigenvector Matrix without */
+/* back transforming: */
+
+ ntest = 11;
+ result[11] = ulpinv;
+
+/* To test "SELECT" option, compute half of the eigenvectors */
+/* in one call, and half in another */
+
+ i1 = n / 2;
+ i__3 = i1;
+ for (j = 1; j <= i__3; ++j) {
+ llwork[j] = TRUE_;
+/* L160: */
+ }
+ i__3 = n;
+ for (j = i1 + 1; j <= i__3; ++j) {
+ llwork[j] = FALSE_;
+/* L170: */
+ }
+
+ dtgevc_("R", "S", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, dumma, ldu, &evectr[evectr_offset], ldu,
+ &n, &in, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+ do_fio(&c__1, "DTGEVC(R,S1)", (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ i1 = in;
+ i__3 = i1;
+ for (j = 1; j <= i__3; ++j) {
+ llwork[j] = FALSE_;
+/* L180: */
+ }
+ i__3 = n;
+ for (j = i1 + 1; j <= i__3; ++j) {
+ llwork[j] = TRUE_;
+/* L190: */
+ }
+
+ dtgevc_("R", "S", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, dumma, ldu, &evectr[(i1 + 1) *
+ evectr_dim1 + 1], ldu, &n, &in, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ do_fio(&c__1, "DTGEVC(R,S2)", (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ dget52_(&c_false, &n, &s1[s1_offset], lda, &p1[p1_offset], lda, &
+ evectr[evectr_offset], ldu, &alphr1[1], &alphi1[1], &
+ beta1[1], &work[1], dumma);
+ result[11] = dumma[0];
+ if (dumma[1] > *thresh) {
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "DTGEVC(HOWMNY=S)", (ftnlen)16);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* 12: Compute the right eigenvector Matrix with */
+/* back transforming: */
+
+ ntest = 12;
+ result[12] = ulpinv;
+ dlacpy_("F", &n, &n, &z__[z_offset], ldu, &evectr[evectr_offset],
+ ldu);
+ dtgevc_("R", "B", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, dumma, ldu, &evectr[evectr_offset], ldu,
+ &n, &in, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ do_fio(&c__1, "DTGEVC(R,B)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ dget52_(&c_false, &n, &h__[h_offset], lda, &t[t_offset], lda, &
+ evectr[evectr_offset], ldu, &alphr1[1], &alphi1[1], &
+ beta1[1], &work[1], dumma);
+ result[12] = dumma[0];
+ if (dumma[1] > *thresh) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "DTGEVC(HOWMNY=B)", (ftnlen)16);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Tests 13--15 are done only on request */
+
+ if (*tstdif) {
+
+/* Do Tests 13--14 */
+
+ dget51_(&c__2, &n, &s1[s1_offset], lda, &s2[s2_offset], lda, &
+ q[q_offset], ldu, &z__[z_offset], ldu, &work[1], &
+ result[13]);
+ dget51_(&c__2, &n, &p1[p1_offset], lda, &p2[p2_offset], lda, &
+ q[q_offset], ldu, &z__[z_offset], ldu, &work[1], &
+ result[14]);
+
+/* Do Test 15 */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = alphr1[j] - alphr3[j], abs(
+ d__1)) + (d__2 = alphi1[j] - alphi3[j], abs(d__2))
+ ;
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = beta1[j] - beta3[j], abs(
+ d__1));
+ temp2 = max(d__2,d__3);
+/* L200: */
+ }
+
+/* Computing MAX */
+ d__1 = safmin, d__2 = ulp * max(temp1,anorm);
+ temp1 /= max(d__1,d__2);
+/* Computing MAX */
+ d__1 = safmin, d__2 = ulp * max(temp2,bnorm);
+ temp2 /= max(d__1,d__2);
+ result[15] = max(temp1,temp2);
+ ntest = 15;
+ } else {
+ result[13] = 0.;
+ result[14] = 0.;
+ result[15] = 0.;
+ ntest = 12;
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L210:
+
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__3 = ntest;
+ for (jr = 1; jr <= i__3; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___62.ciunit = *nounit;
+ s_wsfe(&io___62);
+ do_fio(&c__1, "DGG", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___63.ciunit = *nounit;
+ s_wsfe(&io___63);
+ e_wsfe();
+ io___64.ciunit = *nounit;
+ s_wsfe(&io___64);
+ e_wsfe();
+ io___65.ciunit = *nounit;
+ s_wsfe(&io___65);
+ do_fio(&c__1, "Orthogonal", (ftnlen)10);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___66.ciunit = *nounit;
+ s_wsfe(&io___66);
+ do_fio(&c__1, "orthogonal", (ftnlen)10);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ for (j = 1; j <= 10; ++j) {
+ do_fio(&c__1, "'", (ftnlen)1);
+ }
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[jr] < 1e4) {
+ io___67.ciunit = *nounit;
+ s_wsfe(&io___67);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ } else {
+ io___68.ciunit = *nounit;
+ s_wsfe(&io___68);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+ }
+/* L220: */
+ }
+
+L230:
+ ;
+ }
+/* L240: */
+ }
+
+/* Summary */
+
+ dlasum_("DGG", nounit, &nerrs, &ntestt);
+ return 0;
+
+
+
+
+
+
+
+
+/* End of DCHKGG */
+
+} /* dchkgg_ */
diff --git a/TESTING/EIG/dchkgk.c b/TESTING/EIG/dchkgk.c
new file mode 100644
index 0000000..4e97a5d
--- /dev/null
+++ b/TESTING/EIG/dchkgk.c
@@ -0,0 +1,346 @@
+/* dchkgk.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__5 = 5;
+static integer c__50 = 50;
+static doublereal c_b52 = 1.;
+static doublereal c_b55 = 0.;
+
+/* Subroutine */ int dchkgk_(integer *nin, integer *nout)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002.. test output of DGGBAK .. \002)";
+ static char fmt_9998[] = "(\002 value of largest test error "
+ " =\002,d12.3)";
+ static char fmt_9997[] = "(\002 example number where DGGBAL info is not "
+ "0 =\002,i4)";
+ static char fmt_9996[] = "(\002 example number where DGGBAK(L) info is n"
+ "ot 0 =\002,i4)";
+ static char fmt_9995[] = "(\002 example number where DGGBAK(R) info is n"
+ "ot 0 =\002,i4)";
+ static char fmt_9994[] = "(\002 example number having largest error "
+ " =\002,i4)";
+ static char fmt_9993[] = "(\002 number of examples where info is not 0 "
+ " =\002,i4)";
+ static char fmt_9992[] = "(\002 total number of examples tested "
+ " =\002,i4)";
+
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void), s_wsfe(cilist *), e_wsfe(void), do_fio(integer *,
+ char *, ftnlen);
+
+ /* Local variables */
+ doublereal a[2500] /* was [50][50] */, b[2500] /* was [50][50] */, e[
+ 2500] /* was [50][50] */, f[2500] /* was [50][50] */;
+ integer i__, j, m, n;
+ doublereal af[2500] /* was [50][50] */, bf[2500] /* was [50][50] */,
+ vl[2500] /* was [50][50] */, vr[2500] /* was [50][50] */;
+ integer ihi, ilo;
+ doublereal eps, vlf[2500] /* was [50][50] */;
+ integer knt;
+ doublereal vrf[2500] /* was [50][50] */;
+ integer info, lmax[4];
+ doublereal rmax, vmax, work[2500] /* was [50][50] */;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ integer ninfo;
+ doublereal anorm, bnorm;
+ extern /* Subroutine */ int dggbak_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, integer *), dggbal_(char *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ doublereal lscale[50], rscale[50];
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 0, 0, 0, 0 };
+ static cilist io___10 = { 0, 0, 0, 0, 0 };
+ static cilist io___13 = { 0, 0, 0, 0, 0 };
+ static cilist io___15 = { 0, 0, 0, 0, 0 };
+ static cilist io___17 = { 0, 0, 0, 0, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9992, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKGK tests DGGBAK, a routine for backward balancing of */
+/* a matrix pair (A, B). */
+
+/* Arguments */
+/* ========= */
+
+/* NIN (input) INTEGER */
+/* The logical unit number for input. NIN > 0. */
+
+/* NOUT (input) INTEGER */
+/* The logical unit number for output. NOUT > 0. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialization */
+
+ lmax[0] = 0;
+ lmax[1] = 0;
+ lmax[2] = 0;
+ lmax[3] = 0;
+ ninfo = 0;
+ knt = 0;
+ rmax = 0.;
+
+ eps = dlamch_("Precision");
+
+L10:
+ io___6.ciunit = *nin;
+ s_rsle(&io___6);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&m, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ goto L100;
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___10.ciunit = *nin;
+ s_rsle(&io___10);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__5, &c__1, (char *)&a[i__ + j * 50 - 51], (ftnlen)
+ sizeof(doublereal));
+ }
+ e_rsle();
+/* L20: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___13.ciunit = *nin;
+ s_rsle(&io___13);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__5, &c__1, (char *)&b[i__ + j * 50 - 51], (ftnlen)
+ sizeof(doublereal));
+ }
+ e_rsle();
+/* L30: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___15.ciunit = *nin;
+ s_rsle(&io___15);
+ i__2 = m;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__5, &c__1, (char *)&vl[i__ + j * 50 - 51], (ftnlen)
+ sizeof(doublereal));
+ }
+ e_rsle();
+/* L40: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___17.ciunit = *nin;
+ s_rsle(&io___17);
+ i__2 = m;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__5, &c__1, (char *)&vr[i__ + j * 50 - 51], (ftnlen)
+ sizeof(doublereal));
+ }
+ e_rsle();
+/* L50: */
+ }
+
+ ++knt;
+
+ anorm = dlange_("M", &n, &n, a, &c__50, work);
+ bnorm = dlange_("M", &n, &n, b, &c__50, work);
+
+ dlacpy_("FULL", &n, &n, a, &c__50, af, &c__50);
+ dlacpy_("FULL", &n, &n, b, &c__50, bf, &c__50);
+
+ dggbal_("B", &n, a, &c__50, b, &c__50, &ilo, &ihi, lscale, rscale, work, &
+ info);
+ if (info != 0) {
+ ++ninfo;
+ lmax[0] = knt;
+ }
+
+ dlacpy_("FULL", &n, &m, vl, &c__50, vlf, &c__50);
+ dlacpy_("FULL", &n, &m, vr, &c__50, vrf, &c__50);
+
+ dggbak_("B", "L", &n, &ilo, &ihi, lscale, rscale, &m, vl, &c__50, &info);
+ if (info != 0) {
+ ++ninfo;
+ lmax[1] = knt;
+ }
+
+ dggbak_("B", "R", &n, &ilo, &ihi, lscale, rscale, &m, vr, &c__50, &info);
+ if (info != 0) {
+ ++ninfo;
+ lmax[2] = knt;
+ }
+
+/* Test of DGGBAK */
+
+/* Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR */
+/* where tilde(A) denotes the transformed matrix. */
+
+ dgemm_("N", "N", &n, &m, &n, &c_b52, af, &c__50, vr, &c__50, &c_b55, work,
+ &c__50);
+ dgemm_("T", "N", &m, &m, &n, &c_b52, vl, &c__50, work, &c__50, &c_b55, e,
+ &c__50);
+
+ dgemm_("N", "N", &n, &m, &n, &c_b52, a, &c__50, vrf, &c__50, &c_b55, work,
+ &c__50);
+ dgemm_("T", "N", &m, &m, &n, &c_b52, vlf, &c__50, work, &c__50, &c_b55, f,
+ &c__50);
+
+ vmax = 0.;
+ i__1 = m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = vmax, d__3 = (d__1 = e[i__ + j * 50 - 51] - f[i__ + j * 50
+ - 51], abs(d__1));
+ vmax = max(d__2,d__3);
+/* L60: */
+ }
+/* L70: */
+ }
+ vmax /= eps * max(anorm,bnorm);
+ if (vmax > rmax) {
+ lmax[3] = knt;
+ rmax = vmax;
+ }
+
+/* Check tilde(VL)'*B*tilde(VR) - VL'*tilde(B)*VR */
+
+ dgemm_("N", "N", &n, &m, &n, &c_b52, bf, &c__50, vr, &c__50, &c_b55, work,
+ &c__50);
+ dgemm_("T", "N", &m, &m, &n, &c_b52, vl, &c__50, work, &c__50, &c_b55, e,
+ &c__50);
+
+ dgemm_("N", "N", &n, &m, &n, &c_b52, b, &c__50, vrf, &c__50, &c_b55, work,
+ &c__50);
+ dgemm_("T", "N", &m, &m, &n, &c_b52, vlf, &c__50, work, &c__50, &c_b55, f,
+ &c__50);
+
+ vmax = 0.;
+ i__1 = m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = vmax, d__3 = (d__1 = e[i__ + j * 50 - 51] - f[i__ + j * 50
+ - 51], abs(d__1));
+ vmax = max(d__2,d__3);
+/* L80: */
+ }
+/* L90: */
+ }
+ vmax /= eps * max(anorm,bnorm);
+ if (vmax > rmax) {
+ lmax[3] = knt;
+ rmax = vmax;
+ }
+
+ goto L10;
+
+L100:
+
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ e_wsfe();
+
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, (char *)&lmax[3], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ return 0;
+
+/* End of DCHKGK */
+
+} /* dchkgk_ */
diff --git a/TESTING/EIG/dchkgl.c b/TESTING/EIG/dchkgl.c
new file mode 100644
index 0000000..883d54b
--- /dev/null
+++ b/TESTING/EIG/dchkgl.c
@@ -0,0 +1,306 @@
+/* dchkgl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__5 = 5;
+static integer c__20 = 20;
+
+/* Subroutine */ int dchkgl_(integer *nin, integer *nout)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002.. test output of DGGBAL .. \002)";
+ static char fmt_9998[] = "(1x,\002value of largest test error "
+ " = \002,d12.3)";
+ static char fmt_9997[] = "(1x,\002example number where info is not zero "
+ " = \002,i4)";
+ static char fmt_9996[] = "(1x,\002example number where ILO or IHI wrong "
+ " = \002,i4)";
+ static char fmt_9995[] = "(1x,\002example number having largest error "
+ " = \002,i4)";
+ static char fmt_9994[] = "(1x,\002number of examples where info is not 0"
+ " = \002,i4)";
+ static char fmt_9993[] = "(1x,\002total number of examples tested "
+ " = \002,i4)";
+
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void), s_wsfe(cilist *), e_wsfe(void), do_fio(integer *,
+ char *, ftnlen);
+
+ /* Local variables */
+ doublereal a[400] /* was [20][20] */, b[400] /* was [20][20] */;
+ integer i__, j, n;
+ doublereal ain[400] /* was [20][20] */, bin[400] /* was [20][20] */;
+ integer ihi, ilo;
+ doublereal eps;
+ integer knt, info, lmax[5];
+ doublereal rmax, vmax, work[120];
+ integer ihiin, ninfo, iloin;
+ doublereal anorm, bnorm;
+ extern /* Subroutine */ int dggbal_(char *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ doublereal lscale[20], rscale[20], lsclin[20], rsclin[20];
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 0, 0, 0, 0 };
+ static cilist io___9 = { 0, 0, 0, 0, 0 };
+ static cilist io___12 = { 0, 0, 0, 0, 0 };
+ static cilist io___14 = { 0, 0, 0, 0, 0 };
+ static cilist io___17 = { 0, 0, 0, 0, 0 };
+ static cilist io___19 = { 0, 0, 0, 0, 0 };
+ static cilist io___21 = { 0, 0, 0, 0, 0 };
+ static cilist io___23 = { 0, 0, 0, 0, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKGL tests DGGBAL, a routine for balancing a matrix pair (A, B). */
+
+/* Arguments */
+/* ========= */
+
+/* NIN (input) INTEGER */
+/* The logical unit number for input. NIN > 0. */
+
+/* NOUT (input) INTEGER */
+/* The logical unit number for output. NOUT > 0. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ lmax[0] = 0;
+ lmax[1] = 0;
+ lmax[2] = 0;
+ ninfo = 0;
+ knt = 0;
+ rmax = 0.;
+
+ eps = dlamch_("Precision");
+
+L10:
+
+ io___6.ciunit = *nin;
+ s_rsle(&io___6);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ goto L90;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___9.ciunit = *nin;
+ s_rsle(&io___9);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__5, &c__1, (char *)&a[i__ + j * 20 - 21], (ftnlen)
+ sizeof(doublereal));
+ }
+ e_rsle();
+/* L20: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___12.ciunit = *nin;
+ s_rsle(&io___12);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__5, &c__1, (char *)&b[i__ + j * 20 - 21], (ftnlen)
+ sizeof(doublereal));
+ }
+ e_rsle();
+/* L30: */
+ }
+
+ io___14.ciunit = *nin;
+ s_rsle(&io___14);
+ do_lio(&c__3, &c__1, (char *)&iloin, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ihiin, (ftnlen)sizeof(integer));
+ e_rsle();
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___17.ciunit = *nin;
+ s_rsle(&io___17);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__5, &c__1, (char *)&ain[i__ + j * 20 - 21], (ftnlen)
+ sizeof(doublereal));
+ }
+ e_rsle();
+/* L40: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___19.ciunit = *nin;
+ s_rsle(&io___19);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__5, &c__1, (char *)&bin[i__ + j * 20 - 21], (ftnlen)
+ sizeof(doublereal));
+ }
+ e_rsle();
+/* L50: */
+ }
+
+ io___21.ciunit = *nin;
+ s_rsle(&io___21);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__5, &c__1, (char *)&lsclin[i__ - 1], (ftnlen)sizeof(
+ doublereal));
+ }
+ e_rsle();
+ io___23.ciunit = *nin;
+ s_rsle(&io___23);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__5, &c__1, (char *)&rsclin[i__ - 1], (ftnlen)sizeof(
+ doublereal));
+ }
+ e_rsle();
+
+ anorm = dlange_("M", &n, &n, a, &c__20, work);
+ bnorm = dlange_("M", &n, &n, b, &c__20, work);
+
+ ++knt;
+
+ dggbal_("B", &n, a, &c__20, b, &c__20, &ilo, &ihi, lscale, rscale, work, &
+ info);
+
+ if (info != 0) {
+ ++ninfo;
+ lmax[0] = knt;
+ }
+
+ if (ilo != iloin || ihi != ihiin) {
+ ++ninfo;
+ lmax[1] = knt;
+ }
+
+ vmax = 0.;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ d__2 = vmax, d__3 = (d__1 = a[i__ + j * 20 - 21] - ain[i__ + j *
+ 20 - 21], abs(d__1));
+ vmax = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = vmax, d__3 = (d__1 = b[i__ + j * 20 - 21] - bin[i__ + j *
+ 20 - 21], abs(d__1));
+ vmax = max(d__2,d__3);
+/* L60: */
+ }
+/* L70: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = vmax, d__3 = (d__1 = lscale[i__ - 1] - lsclin[i__ - 1], abs(
+ d__1));
+ vmax = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = vmax, d__3 = (d__1 = rscale[i__ - 1] - rsclin[i__ - 1], abs(
+ d__1));
+ vmax = max(d__2,d__3);
+/* L80: */
+ }
+
+ vmax /= eps * max(anorm,bnorm);
+
+ if (vmax > rmax) {
+ lmax[2] = knt;
+ rmax = vmax;
+ }
+
+ goto L10;
+
+L90:
+
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ e_wsfe();
+
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ return 0;
+
+/* End of DCHKGL */
+
+} /* dchkgl_ */
diff --git a/TESTING/EIG/dchkhs.c b/TESTING/EIG/dchkhs.c
new file mode 100644
index 0000000..1bb23f7
--- /dev/null
+++ b/TESTING/EIG/dchkhs.c
@@ -0,0 +1,1461 @@
+/* dchkhs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b18 = 0.;
+static integer c__0 = 0;
+static doublereal c_b32 = 1.;
+static integer c__4 = 4;
+static integer c__6 = 6;
+static integer c__1 = 1;
+
+/* Subroutine */ int dchkhs_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
+ doublereal *a, integer *lda, doublereal *h__, doublereal *t1,
+ doublereal *t2, doublereal *u, integer *ldu, doublereal *z__,
+ doublereal *uz, doublereal *wr1, doublereal *wi1, doublereal *wr3,
+ doublereal *wi3, doublereal *evectl, doublereal *evectr, doublereal *
+ evecty, doublereal *evectx, doublereal *uu, doublereal *tau,
+ doublereal *work, integer *nwork, integer *iwork, logical *select,
+ doublereal *result, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
+ static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
+ static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 DCHKHS: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 DCHKHS: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
+ "i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9997[] = "(\002 DCHKHS: Selected \002,a,\002 Eigenvector"
+ "s from \002,a,\002 do not match other eigenvectors \002,9x,\002N="
+ "\002,i6,\002, JTYPE=\002,i6,\002, ISEED=(\002,3(i5,\002,\002),i5,"
+ "\002)\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, evectl_dim1, evectl_offset, evectr_dim1,
+ evectr_offset, evectx_dim1, evectx_offset, evecty_dim1,
+ evecty_offset, h_dim1, h_offset, t1_dim1, t1_offset, t2_dim1,
+ t2_offset, u_dim1, u_offset, uu_dim1, uu_offset, uz_dim1,
+ uz_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n, n1, jj, in, ihi, ilo;
+ doublereal ulp, cond;
+ integer jcol, nmax;
+ doublereal unfl, ovfl, temp1, temp2;
+ logical badnn;
+ extern /* Subroutine */ int dget10_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *),
+ dget22_(char *, char *, char *, integer *, doublereal *, integer *
+, doublereal *, integer *, doublereal *, doublereal *, doublereal
+ *, doublereal *), dgemm_(char *, char *,
+ integer *, integer *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ logical match;
+ integer imode;
+ doublereal dumma[6];
+ integer iinfo, nselc;
+ doublereal conds;
+ extern /* Subroutine */ int dhst01_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *);
+ doublereal aninv, anorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer nmats, nselr, jsize, nerrs, itype, jtype, ntest;
+ doublereal rtulp;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dgehrd_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+ char adumma[1*1];
+ extern /* Subroutine */ int dlatme_(integer *, char *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, char *, char
+ *, char *, char *, doublereal *, integer *, doublereal *, integer
+ *, integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *), dhsein_(char
+ *, char *, char *, logical *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ integer *, integer *);
+ integer idumma[1];
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int dlafts_(char *, integer *, integer *, integer
+ *, integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *), dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ dlatmr_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, char *, char
+ *, doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, char *, integer *, integer *, integer *,
+ doublereal *, doublereal *, char *, doublereal *, integer *,
+ integer *, integer *), dlasum_(char *, integer *, integer *, integer *),
+ dhseqr_(char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *),
+ dlatms_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublereal *, integer *, doublereal *, integer
+ *), dorghr_(integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dtrevc_(char *, char *, logical *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *, integer *, doublereal *, integer *), dormhr_(char *, char *, integer *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *),
+ xerbla_(char *, integer *);
+ doublereal rtunfl, rtovfl, rtulpi, ulpinv;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKHS checks the nonsymmetric eigenvalue problem routines. */
+
+/* DGEHRD factors A as U H U' , where ' means transpose, */
+/* H is hessenberg, and U is an orthogonal matrix. */
+
+/* DORGHR generates the orthogonal matrix U. */
+
+/* DORMHR multiplies a matrix by the orthogonal matrix U. */
+
+/* DHSEQR factors H as Z T Z' , where Z is orthogonal and */
+/* T is "quasi-triangular", and the eigenvalue vector W. */
+
+/* DTREVC computes the left and right eigenvector matrices */
+/* L and R for T. */
+
+/* DHSEIN computes the left and right eigenvector matrices */
+/* Y and X for H, using inverse iteration. */
+
+/* When DCHKHS is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 14 */
+/* tests will be performed: */
+
+/* (1) | A - U H U**T | / ( |A| n ulp ) */
+
+/* (2) | I - UU**T | / ( n ulp ) */
+
+/* (3) | H - Z T Z**T | / ( |H| n ulp ) */
+
+/* (4) | I - ZZ**T | / ( n ulp ) */
+
+/* (5) | A - UZ H (UZ)**T | / ( |A| n ulp ) */
+
+/* (6) | I - UZ (UZ)**T | / ( n ulp ) */
+
+/* (7) | T(Z computed) - T(Z not computed) | / ( |T| ulp ) */
+
+/* (8) | W(Z computed) - W(Z not computed) | / ( |W| ulp ) */
+
+/* (9) | TR - RW | / ( |T| |R| ulp ) */
+
+/* (10) | L**H T - W**H L | / ( |T| |L| ulp ) */
+
+/* (11) | HX - XW | / ( |H| |X| ulp ) */
+
+/* (12) | Y**H H - W**H Y | / ( |H| |Y| ulp ) */
+
+/* (13) | AX - XW | / ( |A| |X| ulp ) */
+
+/* (14) | Y**H A - W**H Y | / ( |A| |Y| ulp ) */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
+
+/* (4) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (5) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (7) Same as (4), but multiplied by SQRT( overflow threshold ) */
+/* (8) Same as (4), but multiplied by SQRT( underflow threshold ) */
+
+/* (9) A matrix of the form U' T U, where U is orthogonal and */
+/* T has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (10) A matrix of the form U' T U, where U is orthogonal and */
+/* T has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (11) A matrix of the form U' T U, where U is orthogonal and */
+/* T has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (12) A matrix of the form U' T U, where U is orthogonal and */
+/* T has real or complex conjugate paired eigenvalues randomly */
+/* chosen from ( ULP, 1 ) and random O(1) entries in the upper */
+/* triangle. */
+
+/* (13) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
+/* with random signs on the diagonal and random O(1) entries */
+/* in the upper triangle. */
+
+/* (14) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has geometrically spaced entries */
+/* 1, ..., ULP with random signs on the diagonal and random */
+/* O(1) entries in the upper triangle. */
+
+/* (15) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
+/* with random signs on the diagonal and random O(1) entries */
+/* in the upper triangle. */
+
+/* (16) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has real or complex conjugate paired */
+/* eigenvalues randomly chosen from ( ULP, 1 ) and random */
+/* O(1) entries in the upper triangle. */
+
+/* (17) Same as (16), but multiplied by SQRT( overflow threshold ) */
+/* (18) Same as (16), but multiplied by SQRT( underflow threshold ) */
+
+/* (19) Nonsymmetric matrix with random entries chosen from (-1,1). */
+/* (20) Same as (19), but multiplied by SQRT( overflow threshold ) */
+/* (21) Same as (19), but multiplied by SQRT( underflow threshold ) */
+
+/* Arguments */
+/* ========== */
+
+/* NSIZES - INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* DCHKHS does nothing. It must be at least zero. */
+/* Not modified. */
+
+/* NN - INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+/* Not modified. */
+
+/* NTYPES - INTEGER */
+/* The number of elements in DOTYPE. If it is zero, DCHKHS */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+/* Not modified. */
+
+/* DOTYPE - LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to DCHKHS to continue the same random number */
+/* sequence. */
+/* Modified. */
+
+/* THRESH - DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+/* Not modified. */
+
+/* NOUNIT - INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+/* Not modified. */
+
+/* A - DOUBLE PRECISION array, dimension (LDA,max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually */
+/* used. */
+/* Modified. */
+
+/* LDA - INTEGER */
+/* The leading dimension of A, H, T1 and T2. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* H - DOUBLE PRECISION array, dimension (LDA,max(NN)) */
+/* The upper hessenberg matrix computed by DGEHRD. On exit, */
+/* H contains the Hessenberg form of the matrix in A. */
+/* Modified. */
+
+/* T1 - DOUBLE PRECISION array, dimension (LDA,max(NN)) */
+/* The Schur (="quasi-triangular") matrix computed by DHSEQR */
+/* if Z is computed. On exit, T1 contains the Schur form of */
+/* the matrix in A. */
+/* Modified. */
+
+/* T2 - DOUBLE PRECISION array, dimension (LDA,max(NN)) */
+/* The Schur matrix computed by DHSEQR when Z is not computed. */
+/* This should be identical to T1. */
+/* Modified. */
+
+/* LDU - INTEGER */
+/* The leading dimension of U, Z, UZ and UU. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* U - DOUBLE PRECISION array, dimension (LDU,max(NN)) */
+/* The orthogonal matrix computed by DGEHRD. */
+/* Modified. */
+
+/* Z - DOUBLE PRECISION array, dimension (LDU,max(NN)) */
+/* The orthogonal matrix computed by DHSEQR. */
+/* Modified. */
+
+/* UZ - DOUBLE PRECISION array, dimension (LDU,max(NN)) */
+/* The product of U times Z. */
+/* Modified. */
+
+/* WR1 - DOUBLE PRECISION array, dimension (max(NN)) */
+/* WI1 - DOUBLE PRECISION array, dimension (max(NN)) */
+/* The real and imaginary parts of the eigenvalues of A, */
+/* as computed when Z is computed. */
+/* On exit, WR1 + WI1*i are the eigenvalues of the matrix in A. */
+/* Modified. */
+
+/* WR3 - DOUBLE PRECISION array, dimension (max(NN)) */
+/* WI3 - DOUBLE PRECISION array, dimension (max(NN)) */
+/* Like WR1, WI1, these arrays contain the eigenvalues of A, */
+/* but those computed when DHSEQR only computes the */
+/* eigenvalues, i.e., not the Schur vectors and no more of the */
+/* Schur form than is necessary for computing the */
+/* eigenvalues. */
+/* Modified. */
+
+/* EVECTL - DOUBLE PRECISION array, dimension (LDU,max(NN)) */
+/* The (upper triangular) left eigenvector matrix for the */
+/* matrix in T1. For complex conjugate pairs, the real part */
+/* is stored in one row and the imaginary part in the next. */
+/* Modified. */
+
+/* EVEZTR - DOUBLE PRECISION array, dimension (LDU,max(NN)) */
+/* The (upper triangular) right eigenvector matrix for the */
+/* matrix in T1. For complex conjugate pairs, the real part */
+/* is stored in one column and the imaginary part in the next. */
+/* Modified. */
+
+/* EVECTY - DOUBLE PRECISION array, dimension (LDU,max(NN)) */
+/* The left eigenvector matrix for the */
+/* matrix in H. For complex conjugate pairs, the real part */
+/* is stored in one row and the imaginary part in the next. */
+/* Modified. */
+
+/* EVECTX - DOUBLE PRECISION array, dimension (LDU,max(NN)) */
+/* The right eigenvector matrix for the */
+/* matrix in H. For complex conjugate pairs, the real part */
+/* is stored in one column and the imaginary part in the next. */
+/* Modified. */
+
+/* UU - DOUBLE PRECISION array, dimension (LDU,max(NN)) */
+/* Details of the orthogonal matrix computed by DGEHRD. */
+/* Modified. */
+
+/* TAU - DOUBLE PRECISION array, dimension(max(NN)) */
+/* Further details of the orthogonal matrix computed by DGEHRD. */
+/* Modified. */
+
+/* WORK - DOUBLE PRECISION array, dimension (NWORK) */
+/* Workspace. */
+/* Modified. */
+
+/* NWORK - INTEGER */
+/* The number of entries in WORK. NWORK >= 4*NN(j)*NN(j) + 2. */
+
+/* IWORK - INTEGER array, dimension (max(NN)) */
+/* Workspace. */
+/* Modified. */
+
+/* SELECT - LOGICAL array, dimension (max(NN)) */
+/* Workspace. */
+/* Modified. */
+
+/* RESULT - DOUBLE PRECISION array, dimension (14) */
+/* The values computed by the fourteen tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+/* Modified. */
+
+/* INFO - INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -6: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -14: LDU < 1 or LDU < NMAX. */
+/* -28: NWORK too small. */
+/* If DLATMR, SLATMS, or SLATME returns an error code, the */
+/* absolute value of it is returned. */
+/* If 1, then DHSEQR could not find all the shifts. */
+/* If 2, then the EISPACK code (for small blocks) failed. */
+/* If >2, then 30*N iterations were not enough to find an */
+/* eigenvalue or to decompose the problem. */
+/* Modified. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* MTEST The number of tests defined: care must be taken */
+/* that (1) the size of RESULT, (2) the number of */
+/* tests actually performed, and (3) MTEST agree. */
+/* NTEST The number of tests performed on this matrix */
+/* so far. This should be less than MTEST, and */
+/* equal to it by the last test. It will be less */
+/* if any of the routines being tested indicates */
+/* that it could not compute the matrices that */
+/* would be tested. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far (computed by DLAFTS). */
+/* COND, CONDS, */
+/* IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL, */
+/* RTULP, RTULPI Square roots of the previous 4 values. */
+
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+/* KCONDS(j) Selects whether CONDS is to be 1 or */
+/* 1/sqrt(ulp). (0 means irrelevant.) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ t2_dim1 = *lda;
+ t2_offset = 1 + t2_dim1;
+ t2 -= t2_offset;
+ t1_dim1 = *lda;
+ t1_offset = 1 + t1_dim1;
+ t1 -= t1_offset;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ uu_dim1 = *ldu;
+ uu_offset = 1 + uu_dim1;
+ uu -= uu_offset;
+ evectx_dim1 = *ldu;
+ evectx_offset = 1 + evectx_dim1;
+ evectx -= evectx_offset;
+ evecty_dim1 = *ldu;
+ evecty_offset = 1 + evecty_dim1;
+ evecty -= evecty_offset;
+ evectr_dim1 = *ldu;
+ evectr_offset = 1 + evectr_dim1;
+ evectr -= evectr_offset;
+ evectl_dim1 = *ldu;
+ evectl_offset = 1 + evectl_dim1;
+ evectl -= evectl_offset;
+ uz_dim1 = *ldu;
+ uz_offset = 1 + uz_dim1;
+ uz -= uz_offset;
+ z_dim1 = *ldu;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --wr1;
+ --wi1;
+ --wr3;
+ --wi3;
+ --tau;
+ --work;
+ --iwork;
+ --select;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 0;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.) {
+ *info = -6;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldu <= 1 || *ldu < nmax) {
+ *info = -14;
+ } else if ((nmax << 2) * nmax + 2 > *nwork) {
+ *info = -28;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DCHKHS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More important constants */
+
+ unfl = dlamch_("Safe minimum");
+ ovfl = dlamch_("Overflow");
+ dlabad_(&unfl, &ovfl);
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ ulpinv = 1. / ulp;
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+ rtulp = sqrt(ulp);
+ rtulpi = 1. / rtulp;
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (n == 0) {
+ goto L270;
+ }
+ n1 = max(1,n);
+ aninv = 1. / (doublereal) n1;
+
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L260;
+ }
+ ++nmats;
+ ntest = 0;
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 14; ++j) {
+ result[j] = 0.;
+/* L30: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KCONDS KMODE KTYPE */
+/* =1 O(1) 1 clustered 1 zero */
+/* =2 large large clustered 2 identity */
+/* =3 small exponential Jordan */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random general, w/ eigenvalues */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 random general */
+/* =10 random triangular */
+
+ if (mtypes > 21) {
+ goto L100;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * aninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * n * ulpinv;
+ goto L70;
+
+L70:
+
+ dlaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices */
+
+ if (itype == 1) {
+
+/* Zero */
+
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+/* L80: */
+ }
+
+ } else if (itype == 3) {
+
+/* Jordan Block */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+ if (jcol > 1) {
+ a[jcol + (jcol - 1) * a_dim1] = 1.;
+ }
+/* L90: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 6) {
+
+/* General, eigenvalues specified */
+
+ if (kconds[jtype - 1] == 1) {
+ conds = 1.;
+ } else if (kconds[jtype - 1] == 2) {
+ conds = rtulpi;
+ } else {
+ conds = 0.;
+ }
+
+ *(unsigned char *)&adumma[0] = ' ';
+ dlatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b32,
+ adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
+ n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
+ &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &c__0, &
+ c__0, &c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
+ c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* General, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
+ c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 10) {
+
+/* Triangular, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &c__0, &
+ c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___36.ciunit = *nounit;
+ s_wsfe(&io___36);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L100:
+
+/* Call DGEHRD to compute H and U, do tests. */
+
+ dlacpy_(" ", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+
+ ntest = 1;
+
+ ilo = 1;
+ ihi = n;
+
+ i__3 = *nwork - n;
+ dgehrd_(&n, &ilo, &ihi, &h__[h_offset], lda, &work[1], &work[n +
+ 1], &i__3, &iinfo);
+
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___39.ciunit = *nounit;
+ s_wsfe(&io___39);
+ do_fio(&c__1, "DGEHRD", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+ i__3 = n - 1;
+ for (j = 1; j <= i__3; ++j) {
+ uu[j + 1 + j * uu_dim1] = 0.;
+ i__4 = n;
+ for (i__ = j + 2; i__ <= i__4; ++i__) {
+ u[i__ + j * u_dim1] = h__[i__ + j * h_dim1];
+ uu[i__ + j * uu_dim1] = h__[i__ + j * h_dim1];
+ h__[i__ + j * h_dim1] = 0.;
+/* L110: */
+ }
+/* L120: */
+ }
+ i__3 = n - 1;
+ dcopy_(&i__3, &work[1], &c__1, &tau[1], &c__1);
+ i__3 = *nwork - n;
+ dorghr_(&n, &ilo, &ihi, &u[u_offset], ldu, &work[1], &work[n + 1],
+ &i__3, &iinfo);
+ ntest = 2;
+
+ dhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &h__[h_offset], lda, &
+ u[u_offset], ldu, &work[1], nwork, &result[1]);
+
+/* Call DHSEQR to compute T1, T2 and Z, do tests. */
+
+/* Eigenvalues only (WR3,WI3) */
+
+ dlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
+ ntest = 3;
+ result[3] = ulpinv;
+
+ dhseqr_("E", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &wr3[1], &
+ wi3[1], &uz[uz_offset], ldu, &work[1], nwork, &iinfo);
+ if (iinfo != 0) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "DHSEQR(E)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ if (iinfo <= n + 2) {
+ *info = abs(iinfo);
+ goto L250;
+ }
+ }
+
+/* Eigenvalues (WR1,WI1) and Full Schur Form (T2) */
+
+ dlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
+
+ dhseqr_("S", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &wr1[1], &
+ wi1[1], &uz[uz_offset], ldu, &work[1], nwork, &iinfo);
+ if (iinfo != 0 && iinfo <= n + 2) {
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "DHSEQR(S)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Eigenvalues (WR1,WI1), Schur Form (T1), and Schur vectors */
+/* (UZ) */
+
+ dlacpy_(" ", &n, &n, &h__[h_offset], lda, &t1[t1_offset], lda);
+ dlacpy_(" ", &n, &n, &u[u_offset], ldu, &uz[uz_offset], lda);
+
+ dhseqr_("S", "V", &n, &ilo, &ihi, &t1[t1_offset], lda, &wr1[1], &
+ wi1[1], &uz[uz_offset], ldu, &work[1], nwork, &iinfo);
+ if (iinfo != 0 && iinfo <= n + 2) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "DHSEQR(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Compute Z = U' UZ */
+
+ dgemm_("T", "N", &n, &n, &n, &c_b32, &u[u_offset], ldu, &uz[
+ uz_offset], ldu, &c_b18, &z__[z_offset], ldu);
+ ntest = 8;
+
+/* Do Tests 3: | H - Z T Z' | / ( |H| n ulp ) */
+/* and 4: | I - Z Z' | / ( n ulp ) */
+
+ dhst01_(&n, &ilo, &ihi, &h__[h_offset], lda, &t1[t1_offset], lda,
+ &z__[z_offset], ldu, &work[1], nwork, &result[3]);
+
+/* Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp ) */
+/* and 6: | I - UZ (UZ)' | / ( n ulp ) */
+
+ dhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &t1[t1_offset], lda, &
+ uz[uz_offset], ldu, &work[1], nwork, &result[5]);
+
+/* Do Test 7: | T2 - T1 | / ( |T| n ulp ) */
+
+ dget10_(&n, &n, &t2[t2_offset], lda, &t1[t1_offset], lda, &work[1]
+, &result[7]);
+
+/* Do Test 8: | W3 - W1 | / ( max(|W1|,|W3|) ulp ) */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__5 = temp1, d__6 = (d__1 = wr1[j], abs(d__1)) + (d__2 = wi1[
+ j], abs(d__2)), d__5 = max(d__5,d__6), d__6 = (d__3 =
+ wr3[j], abs(d__3)) + (d__4 = wi3[j], abs(d__4));
+ temp1 = max(d__5,d__6);
+/* Computing MAX */
+ d__3 = temp2, d__4 = (d__1 = wr1[j] - wr3[j], abs(d__1)) + (
+ d__2 = wr1[j] - wr3[j], abs(d__2));
+ temp2 = max(d__3,d__4);
+/* L130: */
+ }
+
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[8] = temp2 / max(d__1,d__2);
+
+/* Compute the Left and Right Eigenvectors of T */
+
+/* Compute the Right eigenvector Matrix: */
+
+ ntest = 9;
+ result[9] = ulpinv;
+
+/* Select last max(N/4,1) real, max(N/4,1) complex eigenvectors */
+
+ nselc = 0;
+ nselr = 0;
+ j = n;
+L140:
+ if (wi1[j] == 0.) {
+/* Computing MAX */
+ i__3 = n / 4;
+ if (nselr < max(i__3,1)) {
+ ++nselr;
+ select[j] = TRUE_;
+ } else {
+ select[j] = FALSE_;
+ }
+ --j;
+ } else {
+/* Computing MAX */
+ i__3 = n / 4;
+ if (nselc < max(i__3,1)) {
+ ++nselc;
+ select[j] = TRUE_;
+ select[j - 1] = FALSE_;
+ } else {
+ select[j] = FALSE_;
+ select[j - 1] = FALSE_;
+ }
+ j += -2;
+ }
+ if (j > 0) {
+ goto L140;
+ }
+
+ dtrevc_("Right", "All", &select[1], &n, &t1[t1_offset], lda,
+ dumma, ldu, &evectr[evectr_offset], ldu, &n, &in, &work[1]
+, &iinfo);
+ if (iinfo != 0) {
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ do_fio(&c__1, "DTREVC(R,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Test 9: | TR - RW | / ( |T| |R| ulp ) */
+
+ dget22_("N", "N", "N", &n, &t1[t1_offset], lda, &evectr[
+ evectr_offset], ldu, &wr1[1], &wi1[1], &work[1], dumma);
+ result[9] = dumma[0];
+ if (dumma[1] > *thresh) {
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "DTREVC", (ftnlen)6);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Compute selected right eigenvectors and confirm that */
+/* they agree with previous right eigenvectors */
+
+ dtrevc_("Right", "Some", &select[1], &n, &t1[t1_offset], lda,
+ dumma, ldu, &evectl[evectl_offset], ldu, &n, &in, &work[1]
+, &iinfo);
+ if (iinfo != 0) {
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "DTREVC(R,S)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+ k = 1;
+ match = TRUE_;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ if (select[j] && wi1[j] == 0.) {
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ if (evectr[jj + j * evectr_dim1] != evectl[jj + k *
+ evectl_dim1]) {
+ match = FALSE_;
+ goto L180;
+ }
+/* L150: */
+ }
+ ++k;
+ } else if (select[j] && wi1[j] != 0.) {
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ if (evectr[jj + j * evectr_dim1] != evectl[jj + k *
+ evectl_dim1] || evectr[jj + (j + 1) *
+ evectr_dim1] != evectl[jj + (k + 1) *
+ evectl_dim1]) {
+ match = FALSE_;
+ goto L180;
+ }
+/* L160: */
+ }
+ k += 2;
+ }
+/* L170: */
+ }
+L180:
+ if (! match) {
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "DTREVC", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Compute the Left eigenvector Matrix: */
+
+ ntest = 10;
+ result[10] = ulpinv;
+ dtrevc_("Left", "All", &select[1], &n, &t1[t1_offset], lda, &
+ evectl[evectl_offset], ldu, dumma, ldu, &n, &in, &work[1],
+ &iinfo);
+ if (iinfo != 0) {
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, "DTREVC(L,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Test 10: | LT - WL | / ( |T| |L| ulp ) */
+
+ dget22_("Trans", "N", "Conj", &n, &t1[t1_offset], lda, &evectl[
+ evectl_offset], ldu, &wr1[1], &wi1[1], &work[1], &dumma[2]
+);
+ result[10] = dumma[2];
+ if (dumma[3] > *thresh) {
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "DTREVC", (ftnlen)6);
+ do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Compute selected left eigenvectors and confirm that */
+/* they agree with previous left eigenvectors */
+
+ dtrevc_("Left", "Some", &select[1], &n, &t1[t1_offset], lda, &
+ evectr[evectr_offset], ldu, dumma, ldu, &n, &in, &work[1],
+ &iinfo);
+ if (iinfo != 0) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, "DTREVC(L,S)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+ k = 1;
+ match = TRUE_;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ if (select[j] && wi1[j] == 0.) {
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ if (evectl[jj + j * evectl_dim1] != evectr[jj + k *
+ evectr_dim1]) {
+ match = FALSE_;
+ goto L220;
+ }
+/* L190: */
+ }
+ ++k;
+ } else if (select[j] && wi1[j] != 0.) {
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ if (evectl[jj + j * evectl_dim1] != evectr[jj + k *
+ evectr_dim1] || evectl[jj + (j + 1) *
+ evectl_dim1] != evectr[jj + (k + 1) *
+ evectr_dim1]) {
+ match = FALSE_;
+ goto L220;
+ }
+/* L200: */
+ }
+ k += 2;
+ }
+/* L210: */
+ }
+L220:
+ if (! match) {
+ io___60.ciunit = *nounit;
+ s_wsfe(&io___60);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "DTREVC", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Call DHSEIN for Right eigenvectors of H, do test 11 */
+
+ ntest = 11;
+ result[11] = ulpinv;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ select[j] = TRUE_;
+/* L230: */
+ }
+
+ dhsein_("Right", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
+ lda, &wr3[1], &wi3[1], dumma, ldu, &evectx[evectx_offset],
+ ldu, &n1, &in, &work[1], &iwork[1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___61.ciunit = *nounit;
+ s_wsfe(&io___61);
+ do_fio(&c__1, "DHSEIN(R)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ goto L250;
+ }
+ } else {
+
+/* Test 11: | HX - XW | / ( |H| |X| ulp ) */
+
+/* (from inverse iteration) */
+
+ dget22_("N", "N", "N", &n, &h__[h_offset], lda, &evectx[
+ evectx_offset], ldu, &wr3[1], &wi3[1], &work[1],
+ dumma);
+ if (dumma[0] < ulpinv) {
+ result[11] = dumma[0] * aninv;
+ }
+ if (dumma[1] > *thresh) {
+ io___62.ciunit = *nounit;
+ s_wsfe(&io___62);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "DHSEIN", (ftnlen)6);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ }
+ }
+
+/* Call DHSEIN for Left eigenvectors of H, do test 12 */
+
+ ntest = 12;
+ result[12] = ulpinv;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ select[j] = TRUE_;
+/* L240: */
+ }
+
+ dhsein_("Left", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
+ lda, &wr3[1], &wi3[1], &evecty[evecty_offset], ldu, dumma,
+ ldu, &n1, &in, &work[1], &iwork[1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___63.ciunit = *nounit;
+ s_wsfe(&io___63);
+ do_fio(&c__1, "DHSEIN(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ goto L250;
+ }
+ } else {
+
+/* Test 12: | YH - WY | / ( |H| |Y| ulp ) */
+
+/* (from inverse iteration) */
+
+ dget22_("C", "N", "C", &n, &h__[h_offset], lda, &evecty[
+ evecty_offset], ldu, &wr3[1], &wi3[1], &work[1], &
+ dumma[2]);
+ if (dumma[2] < ulpinv) {
+ result[12] = dumma[2] * aninv;
+ }
+ if (dumma[3] > *thresh) {
+ io___64.ciunit = *nounit;
+ s_wsfe(&io___64);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "DHSEIN", (ftnlen)6);
+ do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ }
+ }
+
+/* Call DORMHR for Right eigenvectors of A, do test 13 */
+
+ ntest = 13;
+ result[13] = ulpinv;
+
+ dormhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
+, ldu, &tau[1], &evectx[evectx_offset], ldu, &work[1],
+ nwork, &iinfo);
+ if (iinfo != 0) {
+ io___65.ciunit = *nounit;
+ s_wsfe(&io___65);
+ do_fio(&c__1, "DORMHR(R)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ goto L250;
+ }
+ } else {
+
+/* Test 13: | AX - XW | / ( |A| |X| ulp ) */
+
+/* (from inverse iteration) */
+
+ dget22_("N", "N", "N", &n, &a[a_offset], lda, &evectx[
+ evectx_offset], ldu, &wr3[1], &wi3[1], &work[1],
+ dumma);
+ if (dumma[0] < ulpinv) {
+ result[13] = dumma[0] * aninv;
+ }
+ }
+
+/* Call DORMHR for Left eigenvectors of A, do test 14 */
+
+ ntest = 14;
+ result[14] = ulpinv;
+
+ dormhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
+, ldu, &tau[1], &evecty[evecty_offset], ldu, &work[1],
+ nwork, &iinfo);
+ if (iinfo != 0) {
+ io___66.ciunit = *nounit;
+ s_wsfe(&io___66);
+ do_fio(&c__1, "DORMHR(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ goto L250;
+ }
+ } else {
+
+/* Test 14: | YA - WY | / ( |A| |Y| ulp ) */
+
+/* (from inverse iteration) */
+
+ dget22_("C", "N", "C", &n, &a[a_offset], lda, &evecty[
+ evecty_offset], ldu, &wr3[1], &wi3[1], &work[1], &
+ dumma[2]);
+ if (dumma[2] < ulpinv) {
+ result[14] = dumma[2] * aninv;
+ }
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L250:
+
+ ntestt += ntest;
+ dlafts_("DHS", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh,
+ nounit, &nerrs);
+
+L260:
+ ;
+ }
+L270:
+ ;
+ }
+
+/* Summary */
+
+ dlasum_("DHS", nounit, &nerrs, &ntestt);
+
+ return 0;
+
+
+/* End of DCHKHS */
+
+} /* dchkhs_ */
diff --git a/TESTING/EIG/dchksb.c b/TESTING/EIG/dchksb.c
new file mode 100644
index 0000000..80b20c6
--- /dev/null
+++ b/TESTING/EIG/dchksb.c
@@ -0,0 +1,809 @@
+/* dchksb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b18 = 0.;
+static integer c__0 = 0;
+static integer c__6 = 6;
+static doublereal c_b32 = 1.;
+static integer c__1 = 1;
+static integer c__4 = 4;
+
+/* Subroutine */ int dchksb_(integer *nsizes, integer *nn, integer *nwdths,
+ integer *kk, integer *ntypes, logical *dotype, integer *iseed,
+ doublereal *thresh, integer *nounit, doublereal *a, integer *lda,
+ doublereal *sd, doublereal *se, doublereal *u, integer *ldu,
+ doublereal *work, integer *lwork, doublereal *result, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[15] = { 1,2,4,4,4,4,4,5,5,5,5,5,8,8,8 };
+ static integer kmagn[15] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3 };
+ static integer kmode[15] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 DCHKSB: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(/1x,a3,\002 -- Real Symmetric Banded Tridiago"
+ "nal Reduction Routines\002)";
+ static char fmt_9997[] = "(\002 Matrix types (see DCHKSB for details):"
+ " \002)";
+ static char fmt_9996[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 5=Diagonal: clustered ent"
+ "ries.\002,/\002 2=Identity matrix. \002,\002"
+ " 6=Diagonal: large, evenly spaced.\002,/\002 3=Diagonal: evenl"
+ "y spaced entries. \002,\002 7=Diagonal: small, evenly spaced."
+ "\002,/\002 4=Diagonal: geometr. spaced entries.\002)";
+ static char fmt_9995[] = "(\002 Dense \002,a,\002 Banded Matrices:\002,"
+ "/\002 8=Evenly spaced eigenvals. \002,\002 12=Small,"
+ " evenly spaced eigenvals.\002,/\002 9=Geometrically spaced eige"
+ "nvals. \002,\002 13=Matrix with random O(1) entries.\002,"
+ "/\002 10=Clustered eigenvalues. \002,\002 14=Matrix"
+ " with large random entries.\002,/\002 11=Large, evenly spaced ei"
+ "genvals. \002,\002 15=Matrix with small random entries.\002)";
+ static char fmt_9994[] = "(/\002 Tests performed: (S is Tridiag, U "
+ "is \002,a,\002,\002,/20x,a,\002 means \002,a,\002.\002,/\002 UPL"
+ "O='U':\002,/\002 1= | A - U S U\002,a1,\002 | / ( |A| n ulp ) "
+ " \002,\002 2= | I - U U\002,a1,\002 | / ( n ulp )\002,/\002 U"
+ "PLO='L':\002,/\002 3= | A - U S U\002,a1,\002 | / ( |A| n ulp )"
+ " \002,\002 4= | I - U U\002,a1,\002 | / ( n ulp )\002)";
+ static char fmt_9993[] = "(\002 N=\002,i5,\002, K=\002,i4,\002, seed="
+ "\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)"
+ "=\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6, i__7;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n, jc, jr;
+ doublereal ulp, cond;
+ integer jcol, kmax, nmax;
+ doublereal unfl, ovfl, temp1;
+ logical badnn;
+ integer imode;
+ extern /* Subroutine */ int dsbt21_(char *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ integer iinfo;
+ doublereal aninv, anorm;
+ integer nmats, jsize, nerrs, itype, jtype, ntest;
+ logical badnnb;
+ extern doublereal dlamch_(char *);
+ integer idumma[1];
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *), dsbtrd_(char *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *), dlatmr_(integer *, integer *, char *, integer *,
+ char *, doublereal *, integer *, doublereal *, doublereal *, char
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, char *, integer *, integer *, integer *,
+ doublereal *, doublereal *, char *, doublereal *, integer *,
+ integer *, integer *), dlatms_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublereal *, integer *, doublereal *, integer
+ *), dlasum_(char *, integer *, integer *,
+ integer *);
+ integer jwidth;
+ doublereal rtunfl, rtovfl, ulpinv;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKSB tests the reduction of a symmetric band matrix to tridiagonal */
+/* form, used with the symmetric eigenvalue problem. */
+
+/* DSBTRD factors a symmetric band matrix A as U S U' , where ' means */
+/* transpose, S is symmetric tridiagonal, and U is orthogonal. */
+/* DSBTRD can use either just the lower or just the upper triangle */
+/* of A; DCHKSB checks both cases. */
+
+/* When DCHKSB is called, a number of matrix "sizes" ("n's"), a number */
+/* of bandwidths ("k's"), and a number of matrix "types" are */
+/* specified. For each size ("n"), each bandwidth ("k") less than or */
+/* equal to "n", and each type of matrix, one matrix will be generated */
+/* and used to test the symmetric banded reduction routine. For each */
+/* matrix, a number of tests will be performed: */
+
+/* (1) | A - V S V' | / ( |A| n ulp ) computed by DSBTRD with */
+/* UPLO='U' */
+
+/* (2) | I - UU' | / ( n ulp ) */
+
+/* (3) | A - V S V' | / ( |A| n ulp ) computed by DSBTRD with */
+/* UPLO='L' */
+
+/* (4) | I - UU' | / ( n ulp ) */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (6) Same as (4), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (4), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U' D U, where U is orthogonal and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U' D U, where U is orthogonal and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U' D U, where U is orthogonal and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) Symmetric matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* DCHKSB does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NWDTHS (input) INTEGER */
+/* The number of bandwidths to use. If it is zero, */
+/* DCHKSB does nothing. It must be at least zero. */
+
+/* KK (input) INTEGER array, dimension (NWDTHS) */
+/* An array containing the bandwidths to be used for the band */
+/* matrices. The values must be at least zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, DCHKSB */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to DCHKSB to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace) DOUBLE PRECISION array, dimension */
+/* (LDA, max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 2 (not 1!) */
+/* and at least max( KK )+1. */
+
+/* SD (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* Used to hold the diagonal of the tridiagonal matrix computed */
+/* by DSBTRD. */
+
+/* SE (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* Used to hold the off-diagonal of the tridiagonal matrix */
+/* computed by DSBTRD. */
+
+/* U (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN)) */
+/* Used to hold the orthogonal matrix computed by DSBTRD. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* max( LDA+1, max(NN)+1 )*max(NN). */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests performed, or which can */
+/* be performed so far, for the current matrix. */
+/* NTESTT The total number of tests performed so far. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far. */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --kk;
+ --dotype;
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --sd;
+ --se;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --work;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+ badnnb = FALSE_;
+ kmax = 0;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = kmax, i__3 = kk[j];
+ kmax = max(i__2,i__3);
+ if (kk[j] < 0) {
+ badnnb = TRUE_;
+ }
+/* L20: */
+ }
+/* Computing MIN */
+ i__1 = nmax - 1;
+ kmax = min(i__1,kmax);
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*nwdths < 0) {
+ *info = -3;
+ } else if (badnnb) {
+ *info = -4;
+ } else if (*ntypes < 0) {
+ *info = -5;
+ } else if (*lda < kmax + 1) {
+ *info = -11;
+ } else if (*ldu < nmax) {
+ *info = -15;
+ } else if ((max(*lda,nmax) + 1) * nmax > *lwork) {
+ *info = -17;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DCHKSB", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0 || *nwdths == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ ulpinv = 1. / ulp;
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ aninv = 1. / (doublereal) max(1,n);
+
+ i__2 = *nwdths;
+ for (jwidth = 1; jwidth <= i__2; ++jwidth) {
+ k = kk[jwidth];
+ if (k > n) {
+ goto L180;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__5 = n - 1;
+ i__3 = 0, i__4 = min(i__5,k);
+ k = max(i__3,i__4);
+
+ if (*nsizes != 1) {
+ mtypes = min(15,*ntypes);
+ } else {
+ mtypes = min(16,*ntypes);
+ }
+
+ i__3 = mtypes;
+ for (jtype = 1; jtype <= i__3; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L170;
+ }
+ ++nmats;
+ ntest = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L30: */
+ }
+
+/* Compute "A". */
+/* Store as "Upper"; later, we will copy to other format. */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random (none) */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 positive definite */
+/* =10 diagonally dominant tridiagonal */
+
+ if (mtypes > 15) {
+ goto L100;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * aninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * n * ulpinv;
+ goto L70;
+
+L70:
+
+ dlaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
+ iinfo = 0;
+ if (jtype <= 15) {
+ cond = ulpinv;
+ } else {
+ cond = ulpinv * aninv / 10.;
+ }
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__4 = n;
+ for (jcol = 1; jcol <= i__4; ++jcol) {
+ a[k + 1 + jcol * a_dim1] = anorm;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &
+ cond, &anorm, &c__0, &c__0, "Q", &a[k + 1 +
+ a_dim1], lda, &work[n + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &
+ cond, &anorm, &k, &k, "Q", &a[a_offset], lda, &
+ work[n + 1], &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &
+ c_b32, &c_b32, "T", "N", &work[n + 1], &c__1, &
+ c_b32, &work[(n << 1) + 1], &c__1, &c_b32, "N",
+ idumma, &c__0, &c__0, &c_b18, &anorm, "Q", &a[k +
+ 1 + a_dim1], lda, idumma, &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &
+ c_b32, &c_b32, "T", "N", &work[n + 1], &c__1, &
+ c_b32, &work[(n << 1) + 1], &c__1, &c_b32, "N",
+ idumma, &k, &k, &c_b18, &anorm, "Q", &a[a_offset],
+ lda, idumma, &iinfo);
+
+ } else if (itype == 9) {
+
+/* Positive definite, eigenvalues specified. */
+
+ dlatms_(&n, &n, "S", &iseed[1], "P", &work[1], &imode, &
+ cond, &anorm, &k, &k, "Q", &a[a_offset], lda, &
+ work[n + 1], &iinfo);
+
+ } else if (itype == 10) {
+
+/* Positive definite tridiagonal, eigenvalues specified. */
+
+ if (n > 1) {
+ k = max(1,k);
+ }
+ dlatms_(&n, &n, "S", &iseed[1], "P", &work[1], &imode, &
+ cond, &anorm, &c__1, &c__1, "Q", &a[k + a_dim1],
+ lda, &work[n + 1], &iinfo);
+ i__4 = n;
+ for (i__ = 2; i__ <= i__4; ++i__) {
+ temp1 = (d__1 = a[k + i__ * a_dim1], abs(d__1)) /
+ sqrt((d__2 = a[k + 1 + (i__ - 1) * a_dim1] *
+ a[k + 1 + i__ * a_dim1], abs(d__2)));
+ if (temp1 > .5) {
+ a[k + i__ * a_dim1] = sqrt((d__1 = a[k + 1 + (i__
+ - 1) * a_dim1] * a[k + 1 + i__ * a_dim1],
+ abs(d__1))) * .5;
+ }
+/* L90: */
+ }
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___36.ciunit = *nounit;
+ s_wsfe(&io___36);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L100:
+
+/* Call DSBTRD to compute S and U from upper triangle. */
+
+ i__4 = k + 1;
+ dlacpy_(" ", &i__4, &n, &a[a_offset], lda, &work[1], lda);
+
+ ntest = 1;
+ dsbtrd_("V", "U", &n, &k, &work[1], lda, &sd[1], &se[1], &u[
+ u_offset], ldu, &work[*lda * n + 1], &iinfo);
+
+ if (iinfo != 0) {
+ io___37.ciunit = *nounit;
+ s_wsfe(&io___37);
+ do_fio(&c__1, "DSBTRD(U)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[1] = ulpinv;
+ goto L150;
+ }
+ }
+
+/* Do tests 1 and 2 */
+
+ dsbt21_("Upper", &n, &k, &c__1, &a[a_offset], lda, &sd[1], &
+ se[1], &u[u_offset], ldu, &work[1], &result[1]);
+
+/* Convert A from Upper-Triangle-Only storage to */
+/* Lower-Triangle-Only storage. */
+
+ i__4 = n;
+ for (jc = 1; jc <= i__4; ++jc) {
+/* Computing MIN */
+ i__6 = k, i__7 = n - jc;
+ i__5 = min(i__6,i__7);
+ for (jr = 0; jr <= i__5; ++jr) {
+ a[jr + 1 + jc * a_dim1] = a[k + 1 - jr + (jc + jr) *
+ a_dim1];
+/* L110: */
+ }
+/* L120: */
+ }
+ i__4 = n;
+ for (jc = n + 1 - k; jc <= i__4; ++jc) {
+/* Computing MIN */
+ i__5 = k, i__6 = n - jc;
+ i__7 = k;
+ for (jr = min(i__5,i__6) + 1; jr <= i__7; ++jr) {
+ a[jr + 1 + jc * a_dim1] = 0.;
+/* L130: */
+ }
+/* L140: */
+ }
+
+/* Call DSBTRD to compute S and U from lower triangle */
+
+ i__4 = k + 1;
+ dlacpy_(" ", &i__4, &n, &a[a_offset], lda, &work[1], lda);
+
+ ntest = 3;
+ dsbtrd_("V", "L", &n, &k, &work[1], lda, &sd[1], &se[1], &u[
+ u_offset], ldu, &work[*lda * n + 1], &iinfo);
+
+ if (iinfo != 0) {
+ io___40.ciunit = *nounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "DSBTRD(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[3] = ulpinv;
+ goto L150;
+ }
+ }
+ ntest = 4;
+
+/* Do tests 3 and 4 */
+
+ dsbt21_("Lower", &n, &k, &c__1, &a[a_offset], lda, &sd[1], &
+ se[1], &u[u_offset], ldu, &work[1], &result[3]);
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L150:
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__4 = ntest;
+ for (jr = 1; jr <= i__4; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "DSB", (ftnlen)3);
+ e_wsfe();
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ e_wsfe();
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ e_wsfe();
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "Symmetric", (ftnlen)9);
+ e_wsfe();
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "orthogonal", (ftnlen)10);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ for (j = 1; j <= 4; ++j) {
+ do_fio(&c__1, "'", (ftnlen)1);
+ }
+ e_wsfe();
+ }
+ ++nerrs;
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+/* L160: */
+ }
+
+L170:
+ ;
+ }
+L180:
+ ;
+ }
+/* L190: */
+ }
+
+/* Summary */
+
+ dlasum_("DSB", nounit, &nerrs, &ntestt);
+ return 0;
+
+
+
+
+
+/* End of DCHKSB */
+
+} /* dchksb_ */
diff --git a/TESTING/EIG/dchkst.c b/TESTING/EIG/dchkst.c
new file mode 100644
index 0000000..c2952b0
--- /dev/null
+++ b/TESTING/EIG/dchkst.c
@@ -0,0 +1,2404 @@
+/* dchkst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static doublereal c_b25 = 0.;
+static integer c__0 = 0;
+static integer c__6 = 6;
+static doublereal c_b39 = 1.;
+static integer c__4 = 4;
+static integer c__3 = 3;
+static integer c__10 = 10;
+static integer c__11 = 11;
+
+/* Subroutine */ int dchkst_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
+ doublereal *a, integer *lda, doublereal *ap, doublereal *sd,
+ doublereal *se, doublereal *d1, doublereal *d2, doublereal *d3,
+ doublereal *d4, doublereal *d5, doublereal *wa1, doublereal *wa2,
+ doublereal *wa3, doublereal *wr, doublereal *u, integer *ldu,
+ doublereal *v, doublereal *vp, doublereal *tau, doublereal *z__,
+ doublereal *work, integer *lwork, integer *iwork, integer *liwork,
+ doublereal *result, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,4,4,4,4,4,5,5,5,5,5,8,8,8,9,9,9,9,9,10 };
+ static integer kmagn[21] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3,1,1,1,2,3,1 };
+ static integer kmode[21] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0,4,3,1,4,4,3 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 DCHKST: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(/1x,a3,\002 -- Real Symmetric eigenvalue prob"
+ "lem\002)";
+ static char fmt_9997[] = "(\002 Matrix types (see DCHKST for details):"
+ " \002)";
+ static char fmt_9996[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 5=Diagonal: clustered ent"
+ "ries.\002,/\002 2=Identity matrix. \002,\002"
+ " 6=Diagonal: large, evenly spaced.\002,/\002 3=Diagonal: evenl"
+ "y spaced entries. \002,\002 7=Diagonal: small, evenly spaced."
+ "\002,/\002 4=Diagonal: geometr. spaced entries.\002)";
+ static char fmt_9995[] = "(\002 Dense \002,a,\002 Matrices:\002,/\002 8"
+ "=Evenly spaced eigenvals. \002,\002 12=Small, evenly "
+ "spaced eigenvals.\002,/\002 9=Geometrically spaced eigenvals. "
+ " \002,\002 13=Matrix with random O(1) entries.\002,/\002 10=Cl"
+ "ustered eigenvalues. \002,\002 14=Matrix with large"
+ " random entries.\002,/\002 11=Large, evenly spaced eigenvals. "
+ " \002,\002 15=Matrix with small random entries.\002)";
+ static char fmt_9994[] = "(\002 16=Positive definite, evenly spaced eige"
+ "nvalues\002,/\002 17=Positive definite, geometrically spaced eig"
+ "envlaues\002,/\002 18=Positive definite, clustered eigenvalue"
+ "s\002,/\002 19=Positive definite, small evenly spaced eigenvalues"
+ "\002,/\002 20=Positive definite, large evenly spaced eigenvalue"
+ "s\002,/\002 21=Diagonally dominant tridiagonal, geometrically"
+ "\002,\002 spaced eigenvalues\002)";
+ static char fmt_9988[] = "(/\002Test performed: see DCHKST for details"
+ ".\002,/)";
+ static char fmt_9990[] = "(\002 N=\002,i5,\002, seed=\002,4(i4,\002,\002"
+ "),\002 type \002,i2,\002, test(\002,i2,\002)=\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, z_dim1,
+ z_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double log(doublereal), sqrt(doublereal);
+ integer pow_ii(integer *, integer *), s_wsfe(cilist *), do_fio(integer *,
+ char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, m, n, m2, m3, jc, il, jr, iu;
+ doublereal vl, vu;
+ integer nap, lgn;
+ doublereal ulp, cond;
+ integer nmax;
+ doublereal unfl, ovfl, temp1, temp2, temp3, temp4;
+ extern doublereal dsxt1_(integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *);
+ logical badnn;
+ integer imode, lwedc;
+ doublereal dumma[1];
+ integer iinfo;
+ doublereal aninv, anorm;
+ extern /* Subroutine */ int dspt21_(integer *, char *, integer *, integer
+ *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *);
+ integer itemp;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dstt21_(integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ integer nmats;
+ extern /* Subroutine */ int dstt22_(integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *);
+ integer jsize;
+ extern /* Subroutine */ int dsyt21_(integer *, char *, integer *, integer
+ *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *);
+ integer nerrs, itype, jtype, ntest, iseed2[4], log2ui;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *), dlarnd_(integer *, integer *);
+ extern /* Subroutine */ int dstedc_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *, integer *);
+ integer liwedc, nblock;
+ extern /* Subroutine */ int dstech_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ integer idumma[1];
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ integer ioldsd[4];
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ dlatmr_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, char *, char
+ *, doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, char *, integer *, integer *, integer *,
+ doublereal *, doublereal *, char *, doublereal *, integer *,
+ integer *, integer *);
+ doublereal abstol;
+ extern /* Subroutine */ int dlasum_(char *, integer *, integer *, integer
+ *), dlatms_(integer *, integer *, char *, integer *, char
+ *, doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublereal *, integer *, doublereal *,
+ integer *), dstein_(integer *, doublereal
+ *, doublereal *, integer *, doublereal *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *), dsterf_(integer *, doublereal *, doublereal *,
+ integer *), xerbla_(char *, integer *), dstebz_(char *,
+ char *, integer *, doublereal *, doublereal *, integer *, integer
+ *, doublereal *, doublereal *, doublereal *, integer *, integer *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *), dstemr_(char *, char *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ integer *, integer *, logical *, doublereal *, integer *, integer
+ *, integer *, integer *), dopgtr_(char *, integer
+ *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), dpteqr_(char *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *), dorgtr_(char *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *), dsptrd_(char *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *), dsteqr_(char *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical tryrac;
+ integer nsplit;
+ doublereal rtunfl, rtovfl, ulpinv;
+ extern /* Subroutine */ int dsytrd_(char *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *);
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___70 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___72 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___73 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___74 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___75 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___76 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___77 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___80 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___81 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___82 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___83 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___84 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___85 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___86 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___87 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___88 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___89 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___90 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___91 = { 0, 0, 0, fmt_9988, 0 };
+ static cilist io___92 = { 0, 0, 0, fmt_9990, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKST checks the symmetric eigenvalue problem routines. */
+
+/* DSYTRD factors A as U S U' , where ' means transpose, */
+/* S is symmetric tridiagonal, and U is orthogonal. */
+/* DSYTRD can use either just the lower or just the upper triangle */
+/* of A; DCHKST checks both cases. */
+/* U is represented as a product of Householder */
+/* transformations, whose vectors are stored in the first */
+/* n-1 columns of V, and whose scale factors are in TAU. */
+
+/* DSPTRD does the same as DSYTRD, except that A and V are stored */
+/* in "packed" format. */
+
+/* DORGTR constructs the matrix U from the contents of V and TAU. */
+
+/* DOPGTR constructs the matrix U from the contents of VP and TAU. */
+
+/* DSTEQR factors S as Z D1 Z' , where Z is the orthogonal */
+/* matrix of eigenvectors and D1 is a diagonal matrix with */
+/* the eigenvalues on the diagonal. D2 is the matrix of */
+/* eigenvalues computed when Z is not computed. */
+
+/* DSTERF computes D3, the matrix of eigenvalues, by the */
+/* PWK method, which does not yield eigenvectors. */
+
+/* DPTEQR factors S as Z4 D4 Z4' , for a */
+/* symmetric positive definite tridiagonal matrix. */
+/* D5 is the matrix of eigenvalues computed when Z is not */
+/* computed. */
+
+/* DSTEBZ computes selected eigenvalues. WA1, WA2, and */
+/* WA3 will denote eigenvalues computed to high */
+/* absolute accuracy, with different range options. */
+/* WR will denote eigenvalues computed to high relative */
+/* accuracy. */
+
+/* DSTEIN computes Y, the eigenvectors of S, given the */
+/* eigenvalues. */
+
+/* DSTEDC factors S as Z D1 Z' , where Z is the orthogonal */
+/* matrix of eigenvectors and D1 is a diagonal matrix with */
+/* the eigenvalues on the diagonal ('I' option). It may also */
+/* update an input orthogonal matrix, usually the output */
+/* from DSYTRD/DORGTR or DSPTRD/DOPGTR ('V' option). It may */
+/* also just compute eigenvalues ('N' option). */
+
+/* DSTEMR factors S as Z D1 Z' , where Z is the orthogonal */
+/* matrix of eigenvectors and D1 is a diagonal matrix with */
+/* the eigenvalues on the diagonal ('I' option). DSTEMR */
+/* uses the Relatively Robust Representation whenever possible. */
+
+/* When DCHKST is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the symmetric eigenroutines. For each matrix, a number */
+/* of tests will be performed: */
+
+/* (1) | A - V S V' | / ( |A| n ulp ) DSYTRD( UPLO='U', ... ) */
+
+/* (2) | I - UV' | / ( n ulp ) DORGTR( UPLO='U', ... ) */
+
+/* (3) | A - V S V' | / ( |A| n ulp ) DSYTRD( UPLO='L', ... ) */
+
+/* (4) | I - UV' | / ( n ulp ) DORGTR( UPLO='L', ... ) */
+
+/* (5-8) Same as 1-4, but for DSPTRD and DOPGTR. */
+
+/* (9) | S - Z D Z' | / ( |S| n ulp ) DSTEQR('V',...) */
+
+/* (10) | I - ZZ' | / ( n ulp ) DSTEQR('V',...) */
+
+/* (11) | D1 - D2 | / ( |D1| ulp ) DSTEQR('N',...) */
+
+/* (12) | D1 - D3 | / ( |D1| ulp ) DSTERF */
+
+/* (13) 0 if the true eigenvalues (computed by sturm count) */
+/* of S are within THRESH of */
+/* those in D1. 2*THRESH if they are not. (Tested using */
+/* DSTECH) */
+
+/* For S positive definite, */
+
+/* (14) | S - Z4 D4 Z4' | / ( |S| n ulp ) DPTEQR('V',...) */
+
+/* (15) | I - Z4 Z4' | / ( n ulp ) DPTEQR('V',...) */
+
+/* (16) | D4 - D5 | / ( 100 |D4| ulp ) DPTEQR('N',...) */
+
+/* When S is also diagonally dominant by the factor gamma < 1, */
+
+/* (17) max | D4(i) - WR(i) | / ( |D4(i)| omega ) , */
+/* i */
+/* omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 */
+/* DSTEBZ( 'A', 'E', ...) */
+
+/* (18) | WA1 - D3 | / ( |D3| ulp ) DSTEBZ( 'A', 'E', ...) */
+
+/* (19) ( max { min | WA2(i)-WA3(j) | } + */
+/* i j */
+/* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) */
+/* i j */
+/* DSTEBZ( 'I', 'E', ...) */
+
+/* (20) | S - Y WA1 Y' | / ( |S| n ulp ) DSTEBZ, SSTEIN */
+
+/* (21) | I - Y Y' | / ( n ulp ) DSTEBZ, SSTEIN */
+
+/* (22) | S - Z D Z' | / ( |S| n ulp ) DSTEDC('I') */
+
+/* (23) | I - ZZ' | / ( n ulp ) DSTEDC('I') */
+
+/* (24) | S - Z D Z' | / ( |S| n ulp ) DSTEDC('V') */
+
+/* (25) | I - ZZ' | / ( n ulp ) DSTEDC('V') */
+
+/* (26) | D1 - D2 | / ( |D1| ulp ) DSTEDC('V') and */
+/* DSTEDC('N') */
+
+/* Test 27 is disabled at the moment because DSTEMR does not */
+/* guarantee high relatvie accuracy. */
+
+/* (27) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , */
+/* i */
+/* omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 */
+/* DSTEMR('V', 'A') */
+
+/* (28) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , */
+/* i */
+/* omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 */
+/* DSTEMR('V', 'I') */
+
+/* Tests 29 through 34 are disable at present because DSTEMR */
+/* does not handle partial specturm requests. */
+
+/* (29) | S - Z D Z' | / ( |S| n ulp ) DSTEMR('V', 'I') */
+
+/* (30) | I - ZZ' | / ( n ulp ) DSTEMR('V', 'I') */
+
+/* (31) ( max { min | WA2(i)-WA3(j) | } + */
+/* i j */
+/* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) */
+/* i j */
+/* DSTEMR('N', 'I') vs. SSTEMR('V', 'I') */
+
+/* (32) | S - Z D Z' | / ( |S| n ulp ) DSTEMR('V', 'V') */
+
+/* (33) | I - ZZ' | / ( n ulp ) DSTEMR('V', 'V') */
+
+/* (34) ( max { min | WA2(i)-WA3(j) | } + */
+/* i j */
+/* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) */
+/* i j */
+/* DSTEMR('N', 'V') vs. SSTEMR('V', 'V') */
+
+/* (35) | S - Z D Z' | / ( |S| n ulp ) DSTEMR('V', 'A') */
+
+/* (36) | I - ZZ' | / ( n ulp ) DSTEMR('V', 'A') */
+
+/* (37) ( max { min | WA2(i)-WA3(j) | } + */
+/* i j */
+/* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) */
+/* i j */
+/* DSTEMR('N', 'A') vs. SSTEMR('V', 'A') */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (6) Same as (4), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (4), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U' D U, where U is orthogonal and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U' D U, where U is orthogonal and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U' D U, where U is orthogonal and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) Symmetric matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
+/* (16) Same as (8), but diagonal elements are all positive. */
+/* (17) Same as (9), but diagonal elements are all positive. */
+/* (18) Same as (10), but diagonal elements are all positive. */
+/* (19) Same as (16), but multiplied by SQRT( overflow threshold ) */
+/* (20) Same as (16), but multiplied by SQRT( underflow threshold ) */
+/* (21) A diagonally dominant tridiagonal matrix with geometrically */
+/* spaced diagonal entries 1, ..., ULP. */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* DCHKST does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, DCHKST */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to DCHKST to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace/output) DOUBLE PRECISION array of */
+/* dimension ( LDA , max(NN) ) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually */
+/* used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at */
+/* least 1 and at least max( NN ). */
+
+/* AP (workspace) DOUBLE PRECISION array of */
+/* dimension( max(NN)*max(NN+1)/2 ) */
+/* The matrix A stored in packed format. */
+
+/* SD (workspace/output) DOUBLE PRECISION array of */
+/* dimension( max(NN) ) */
+/* The diagonal of the tridiagonal matrix computed by DSYTRD. */
+/* On exit, SD and SE contain the tridiagonal form of the */
+/* matrix in A. */
+
+/* SE (workspace/output) DOUBLE PRECISION array of */
+/* dimension( max(NN) ) */
+/* The off-diagonal of the tridiagonal matrix computed by */
+/* DSYTRD. On exit, SD and SE contain the tridiagonal form of */
+/* the matrix in A. */
+
+/* D1 (workspace/output) DOUBLE PRECISION array of */
+/* dimension( max(NN) ) */
+/* The eigenvalues of A, as computed by DSTEQR simlutaneously */
+/* with Z. On exit, the eigenvalues in D1 correspond with the */
+/* matrix in A. */
+
+/* D2 (workspace/output) DOUBLE PRECISION array of */
+/* dimension( max(NN) ) */
+/* The eigenvalues of A, as computed by DSTEQR if Z is not */
+/* computed. On exit, the eigenvalues in D2 correspond with */
+/* the matrix in A. */
+
+/* D3 (workspace/output) DOUBLE PRECISION array of */
+/* dimension( max(NN) ) */
+/* The eigenvalues of A, as computed by DSTERF. On exit, the */
+/* eigenvalues in D3 correspond with the matrix in A. */
+
+/* U (workspace/output) DOUBLE PRECISION array of */
+/* dimension( LDU, max(NN) ). */
+/* The orthogonal matrix computed by DSYTRD + DORGTR. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U, Z, and V. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* V (workspace/output) DOUBLE PRECISION array of */
+/* dimension( LDU, max(NN) ). */
+/* The Housholder vectors computed by DSYTRD in reducing A to */
+/* tridiagonal form. The vectors computed with UPLO='U' are */
+/* in the upper triangle, and the vectors computed with UPLO='L' */
+/* are in the lower triangle. (As described in DSYTRD, the */
+/* sub- and superdiagonal are not set to 1, although the */
+/* true Householder vector has a 1 in that position. The */
+/* routines that use V, such as DORGTR, set those entries to */
+/* 1 before using them, and then restore them later.) */
+
+/* VP (workspace) DOUBLE PRECISION array of */
+/* dimension( max(NN)*max(NN+1)/2 ) */
+/* The matrix V stored in packed format. */
+
+/* TAU (workspace/output) DOUBLE PRECISION array of */
+/* dimension( max(NN) ) */
+/* The Householder factors computed by DSYTRD in reducing A */
+/* to tridiagonal form. */
+
+/* Z (workspace/output) DOUBLE PRECISION array of */
+/* dimension( LDU, max(NN) ). */
+/* The orthogonal matrix of eigenvectors computed by DSTEQR, */
+/* DPTEQR, and DSTEIN. */
+
+/* WORK (workspace/output) DOUBLE PRECISION array of */
+/* dimension( LWORK ) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 3 * Nmax**2 */
+/* where Nmax = max( NN(j), 2 ) and lg = log base 2. */
+
+/* IWORK (workspace/output) INTEGER array, */
+/* dimension (6 + 6*Nmax + 5 * Nmax * lg Nmax ) */
+/* where Nmax = max( NN(j), 2 ) and lg = log base 2. */
+/* Workspace. */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (26) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -5: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -23: LDU < 1 or LDU < NMAX. */
+/* -29: LWORK too small. */
+/* If DLATMR, SLATMS, DSYTRD, DORGTR, DSTEQR, SSTERF, */
+/* or DORMC2 returns an error code, the */
+/* absolute value of it is returned. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests performed, or which can */
+/* be performed so far, for the current matrix. */
+/* NTESTT The total number of tests performed so far. */
+/* NBLOCK Blocksize as returned by ENVIR. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far. */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ap;
+ --sd;
+ --se;
+ --d1;
+ --d2;
+ --d3;
+ --d4;
+ --d5;
+ --wa1;
+ --wa2;
+ --wa3;
+ --wr;
+ z_dim1 = *ldu;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ v_dim1 = *ldu;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --vp;
+ --tau;
+ --work;
+ --iwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Keep ftnchek happy */
+ idumma[0] = 1;
+
+/* Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+ tryrac = TRUE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+ nblock = ilaenv_(&c__1, "DSYTRD", "L", &nmax, &c_n1, &c_n1, &c_n1);
+/* Computing MIN */
+ i__1 = nmax, i__2 = max(1,nblock);
+ nblock = min(i__1,i__2);
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*lda < nmax) {
+ *info = -9;
+ } else if (*ldu < nmax) {
+ *info = -23;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = max(2,nmax);
+ if (i__1 * i__1 << 1 > *lwork) {
+ *info = -29;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DCHKST", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ dlabad_(&unfl, &ovfl);
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ ulpinv = 1. / ulp;
+ log2ui = (integer) (log(ulpinv) / log(2.));
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+
+/* Loop over sizes, types */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed2[i__ - 1] = iseed[i__];
+/* L20: */
+ }
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (n > 0) {
+ lgn = (integer) (log((doublereal) n) / log(2.));
+ if (pow_ii(&c__2, &lgn) < n) {
+ ++lgn;
+ }
+ if (pow_ii(&c__2, &lgn) < n) {
+ ++lgn;
+ }
+/* Computing 2nd power */
+ i__2 = n;
+ lwedc = (n << 2) + 1 + (n << 1) * lgn + i__2 * i__2 * 3;
+ liwedc = n * 6 + 6 + n * 5 * lgn;
+ } else {
+ lwedc = 8;
+ liwedc = 12;
+ }
+ nap = n * (n + 1) / 2;
+ aninv = 1. / (doublereal) max(1,n);
+
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L300;
+ }
+ ++nmats;
+ ntest = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L30: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random (none) */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 positive definite */
+/* =10 diagonally dominant tridiagonal */
+
+ if (mtypes > 21) {
+ goto L100;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * aninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * n * ulpinv;
+ goto L70;
+
+L70:
+
+ dlaset_("Full", lda, &n, &c_b25, &c_b25, &a[a_offset], lda);
+ iinfo = 0;
+ if (jtype <= 15) {
+ cond = ulpinv;
+ } else {
+ cond = ulpinv * aninv / 10.;
+ }
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ a[jc + jc * a_dim1] = anorm;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ + 1], &iinfo);
+
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b39,
+ &c_b39, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &c__0, &
+ c__0, &c_b25, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b39,
+ &c_b39, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &n, &
+ c_b25, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* Positive definite, eigenvalues specified. */
+
+ dlatms_(&n, &n, "S", &iseed[1], "P", &work[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 10) {
+
+/* Positive definite tridiagonal, eigenvalues specified. */
+
+ dlatms_(&n, &n, "S", &iseed[1], "P", &work[1], &imode, &cond,
+ &anorm, &c__1, &c__1, "N", &a[a_offset], lda, &work[n
+ + 1], &iinfo);
+ i__3 = n;
+ for (i__ = 2; i__ <= i__3; ++i__) {
+ temp1 = (d__1 = a[i__ - 1 + i__ * a_dim1], abs(d__1)) /
+ sqrt((d__2 = a[i__ - 1 + (i__ - 1) * a_dim1] * a[
+ i__ + i__ * a_dim1], abs(d__2)));
+ if (temp1 > .5) {
+ a[i__ - 1 + i__ * a_dim1] = sqrt((d__1 = a[i__ - 1 + (
+ i__ - 1) * a_dim1] * a[i__ + i__ * a_dim1],
+ abs(d__1))) * .5;
+ a[i__ + (i__ - 1) * a_dim1] = a[i__ - 1 + i__ *
+ a_dim1];
+ }
+/* L90: */
+ }
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___40.ciunit = *nounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L100:
+
+/* Call DSYTRD and DORGTR to compute S and U from */
+/* upper triangle. */
+
+ dlacpy_("U", &n, &n, &a[a_offset], lda, &v[v_offset], ldu);
+
+ ntest = 1;
+ dsytrd_("U", &n, &v[v_offset], ldu, &sd[1], &se[1], &tau[1], &
+ work[1], lwork, &iinfo);
+
+ if (iinfo != 0) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "DSYTRD(U)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[1] = ulpinv;
+ goto L280;
+ }
+ }
+
+ dlacpy_("U", &n, &n, &v[v_offset], ldu, &u[u_offset], ldu);
+
+ ntest = 2;
+ dorgtr_("U", &n, &u[u_offset], ldu, &tau[1], &work[1], lwork, &
+ iinfo);
+ if (iinfo != 0) {
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "DORGTR(U)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[2] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do tests 1 and 2 */
+
+ dsyt21_(&c__2, "Upper", &n, &c__1, &a[a_offset], lda, &sd[1], &se[
+ 1], &u[u_offset], ldu, &v[v_offset], ldu, &tau[1], &work[
+ 1], &result[1]);
+ dsyt21_(&c__3, "Upper", &n, &c__1, &a[a_offset], lda, &sd[1], &se[
+ 1], &u[u_offset], ldu, &v[v_offset], ldu, &tau[1], &work[
+ 1], &result[2]);
+
+/* Call DSYTRD and DORGTR to compute S and U from */
+/* lower triangle, do tests. */
+
+ dlacpy_("L", &n, &n, &a[a_offset], lda, &v[v_offset], ldu);
+
+ ntest = 3;
+ dsytrd_("L", &n, &v[v_offset], ldu, &sd[1], &se[1], &tau[1], &
+ work[1], lwork, &iinfo);
+
+ if (iinfo != 0) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "DSYTRD(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[3] = ulpinv;
+ goto L280;
+ }
+ }
+
+ dlacpy_("L", &n, &n, &v[v_offset], ldu, &u[u_offset], ldu);
+
+ ntest = 4;
+ dorgtr_("L", &n, &u[u_offset], ldu, &tau[1], &work[1], lwork, &
+ iinfo);
+ if (iinfo != 0) {
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "DORGTR(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[4] = ulpinv;
+ goto L280;
+ }
+ }
+
+ dsyt21_(&c__2, "Lower", &n, &c__1, &a[a_offset], lda, &sd[1], &se[
+ 1], &u[u_offset], ldu, &v[v_offset], ldu, &tau[1], &work[
+ 1], &result[3]);
+ dsyt21_(&c__3, "Lower", &n, &c__1, &a[a_offset], lda, &sd[1], &se[
+ 1], &u[u_offset], ldu, &v[v_offset], ldu, &tau[1], &work[
+ 1], &result[4]);
+
+/* Store the upper triangle of A in AP */
+
+ i__ = 0;
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = jc;
+ for (jr = 1; jr <= i__4; ++jr) {
+ ++i__;
+ ap[i__] = a[jr + jc * a_dim1];
+/* L110: */
+ }
+/* L120: */
+ }
+
+/* Call DSPTRD and DOPGTR to compute S and U from AP */
+
+ dcopy_(&nap, &ap[1], &c__1, &vp[1], &c__1);
+
+ ntest = 5;
+ dsptrd_("U", &n, &vp[1], &sd[1], &se[1], &tau[1], &iinfo);
+
+ if (iinfo != 0) {
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, "DSPTRD(U)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[5] = ulpinv;
+ goto L280;
+ }
+ }
+
+ ntest = 6;
+ dopgtr_("U", &n, &vp[1], &tau[1], &u[u_offset], ldu, &work[1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ do_fio(&c__1, "DOPGTR(U)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[6] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do tests 5 and 6 */
+
+ dspt21_(&c__2, "Upper", &n, &c__1, &ap[1], &sd[1], &se[1], &u[
+ u_offset], ldu, &vp[1], &tau[1], &work[1], &result[5]);
+ dspt21_(&c__3, "Upper", &n, &c__1, &ap[1], &sd[1], &se[1], &u[
+ u_offset], ldu, &vp[1], &tau[1], &work[1], &result[6]);
+
+/* Store the lower triangle of A in AP */
+
+ i__ = 0;
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = jc; jr <= i__4; ++jr) {
+ ++i__;
+ ap[i__] = a[jr + jc * a_dim1];
+/* L130: */
+ }
+/* L140: */
+ }
+
+/* Call DSPTRD and DOPGTR to compute S and U from AP */
+
+ dcopy_(&nap, &ap[1], &c__1, &vp[1], &c__1);
+
+ ntest = 7;
+ dsptrd_("L", &n, &vp[1], &sd[1], &se[1], &tau[1], &iinfo);
+
+ if (iinfo != 0) {
+ io___48.ciunit = *nounit;
+ s_wsfe(&io___48);
+ do_fio(&c__1, "DSPTRD(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[7] = ulpinv;
+ goto L280;
+ }
+ }
+
+ ntest = 8;
+ dopgtr_("L", &n, &vp[1], &tau[1], &u[u_offset], ldu, &work[1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ do_fio(&c__1, "DOPGTR(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[8] = ulpinv;
+ goto L280;
+ }
+ }
+
+ dspt21_(&c__2, "Lower", &n, &c__1, &ap[1], &sd[1], &se[1], &u[
+ u_offset], ldu, &vp[1], &tau[1], &work[1], &result[7]);
+ dspt21_(&c__3, "Lower", &n, &c__1, &ap[1], &sd[1], &se[1], &u[
+ u_offset], ldu, &vp[1], &tau[1], &work[1], &result[8]);
+
+/* Call DSTEQR to compute D1, D2, and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ dcopy_(&n, &sd[1], &c__1, &d1[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+ dlaset_("Full", &n, &n, &c_b25, &c_b39, &z__[z_offset], ldu);
+
+ ntest = 9;
+ dsteqr_("V", &n, &d1[1], &work[1], &z__[z_offset], ldu, &work[n +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ do_fio(&c__1, "DSTEQR(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[9] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Compute D2 */
+
+ dcopy_(&n, &sd[1], &c__1, &d2[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+
+ ntest = 11;
+ dsteqr_("N", &n, &d2[1], &work[1], &work[n + 1], ldu, &work[n + 1]
+, &iinfo);
+ if (iinfo != 0) {
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "DSTEQR(N)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[11] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Compute D3 (using PWK method) */
+
+ dcopy_(&n, &sd[1], &c__1, &d3[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+
+ ntest = 12;
+ dsterf_(&n, &d3[1], &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "DSTERF", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[12] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 9 and 10 */
+
+ dstt21_(&n, &c__0, &sd[1], &se[1], &d1[1], dumma, &z__[z_offset],
+ ldu, &work[1], &result[9]);
+
+/* Do Tests 11 and 12 */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ temp3 = 0.;
+ temp4 = 0.;
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d1[j], abs(d__1)), d__3 = max(
+ d__3,d__4), d__4 = (d__2 = d2[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d1[j] - d2[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* Computing MAX */
+ d__3 = temp3, d__4 = (d__1 = d1[j], abs(d__1)), d__3 = max(
+ d__3,d__4), d__4 = (d__2 = d3[j], abs(d__2));
+ temp3 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp4, d__3 = (d__1 = d1[j] - d3[j], abs(d__1));
+ temp4 = max(d__2,d__3);
+/* L150: */
+ }
+
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[11] = temp2 / max(d__1,d__2);
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp3,temp4);
+ result[12] = temp4 / max(d__1,d__2);
+
+/* Do Test 13 -- Sturm Sequence Test of Eigenvalues */
+/* Go up by factors of two until it succeeds */
+
+ ntest = 13;
+ temp1 = *thresh * (.5 - ulp);
+
+ i__3 = log2ui;
+ for (j = 0; j <= i__3; ++j) {
+ dstech_(&n, &sd[1], &se[1], &d1[1], &temp1, &work[1], &iinfo);
+ if (iinfo == 0) {
+ goto L170;
+ }
+ temp1 *= 2.;
+/* L160: */
+ }
+
+L170:
+ result[13] = temp1;
+
+/* For positive definite matrices ( JTYPE.GT.15 ) call DPTEQR */
+/* and do tests 14, 15, and 16 . */
+
+ if (jtype > 15) {
+
+/* Compute D4 and Z4 */
+
+ dcopy_(&n, &sd[1], &c__1, &d4[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+ dlaset_("Full", &n, &n, &c_b25, &c_b39, &z__[z_offset], ldu);
+
+ ntest = 14;
+ dpteqr_("V", &n, &d4[1], &work[1], &z__[z_offset], ldu, &work[
+ n + 1], &iinfo);
+ if (iinfo != 0) {
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, "DPTEQR(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[14] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 14 and 15 */
+
+ dstt21_(&n, &c__0, &sd[1], &se[1], &d4[1], dumma, &z__[
+ z_offset], ldu, &work[1], &result[14]);
+
+/* Compute D5 */
+
+ dcopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+
+ ntest = 16;
+ dpteqr_("N", &n, &d5[1], &work[1], &z__[z_offset], ldu, &work[
+ n + 1], &iinfo);
+ if (iinfo != 0) {
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ do_fio(&c__1, "DPTEQR(N)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[16] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Test 16 */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d4[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = d5[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d4[j] - d5[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L180: */
+ }
+
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * 100. * max(temp1,temp2);
+ result[16] = temp2 / max(d__1,d__2);
+ } else {
+ result[14] = 0.;
+ result[15] = 0.;
+ result[16] = 0.;
+ }
+
+/* Call DSTEBZ with different options and do tests 17-18. */
+
+/* If S is positive definite and diagonally dominant, */
+/* ask for all eigenvalues with high relative accuracy. */
+
+ vl = 0.;
+ vu = 0.;
+ il = 0;
+ iu = 0;
+ if (jtype == 21) {
+ ntest = 17;
+ abstol = unfl + unfl;
+ dstebz_("A", "E", &n, &vl, &vu, &il, &iu, &abstol, &sd[1], &
+ se[1], &m, &nsplit, &wr[1], &iwork[1], &iwork[n + 1],
+ &work[1], &iwork[(n << 1) + 1], &iinfo);
+ if (iinfo != 0) {
+ io___66.ciunit = *nounit;
+ s_wsfe(&io___66);
+ do_fio(&c__1, "DSTEBZ(A,rel)", (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[17] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do test 17 */
+
+ temp2 = (n * 2. - 1.) * 2. * ulp * 3. / .0625;
+
+ temp1 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__2 = d4[j] - wr[n - j + 1], abs(
+ d__2)) / (abstol + (d__1 = d4[j], abs(d__1)));
+ temp1 = max(d__3,d__4);
+/* L190: */
+ }
+
+ result[17] = temp1 / temp2;
+ } else {
+ result[17] = 0.;
+ }
+
+/* Now ask for all eigenvalues with high absolute accuracy. */
+
+ ntest = 18;
+ abstol = unfl + unfl;
+ dstebz_("A", "E", &n, &vl, &vu, &il, &iu, &abstol, &sd[1], &se[1],
+ &m, &nsplit, &wa1[1], &iwork[1], &iwork[n + 1], &work[1],
+ &iwork[(n << 1) + 1], &iinfo);
+ if (iinfo != 0) {
+ io___67.ciunit = *nounit;
+ s_wsfe(&io___67);
+ do_fio(&c__1, "DSTEBZ(A)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[18] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do test 18 */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d3[j], abs(d__1)), d__3 = max(
+ d__3,d__4), d__4 = (d__2 = wa1[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d3[j] - wa1[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L200: */
+ }
+
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[18] = temp2 / max(d__1,d__2);
+
+/* Choose random values for IL and IU, and ask for the */
+/* IL-th through IU-th eigenvalues. */
+
+ ntest = 19;
+ if (n <= 1) {
+ il = 1;
+ iu = n;
+ } else {
+ il = (n - 1) * (integer) dlarnd_(&c__1, iseed2) + 1;
+ iu = (n - 1) * (integer) dlarnd_(&c__1, iseed2) + 1;
+ if (iu < il) {
+ itemp = iu;
+ iu = il;
+ il = itemp;
+ }
+ }
+
+ dstebz_("I", "E", &n, &vl, &vu, &il, &iu, &abstol, &sd[1], &se[1],
+ &m2, &nsplit, &wa2[1], &iwork[1], &iwork[n + 1], &work[1]
+, &iwork[(n << 1) + 1], &iinfo);
+ if (iinfo != 0) {
+ io___70.ciunit = *nounit;
+ s_wsfe(&io___70);
+ do_fio(&c__1, "DSTEBZ(I)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[19] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Determine the values VL and VU of the IL-th and IU-th */
+/* eigenvalues and ask for all eigenvalues in this range. */
+
+ if (n > 0) {
+ if (il != 1) {
+/* Computing MAX */
+ d__1 = (wa1[il] - wa1[il - 1]) * .5, d__2 = ulp * anorm,
+ d__1 = max(d__1,d__2), d__2 = rtunfl * 2.;
+ vl = wa1[il] - max(d__1,d__2);
+ } else {
+/* Computing MAX */
+ d__1 = (wa1[n] - wa1[1]) * .5, d__2 = ulp * anorm, d__1 =
+ max(d__1,d__2), d__2 = rtunfl * 2.;
+ vl = wa1[1] - max(d__1,d__2);
+ }
+ if (iu != n) {
+/* Computing MAX */
+ d__1 = (wa1[iu + 1] - wa1[iu]) * .5, d__2 = ulp * anorm,
+ d__1 = max(d__1,d__2), d__2 = rtunfl * 2.;
+ vu = wa1[iu] + max(d__1,d__2);
+ } else {
+/* Computing MAX */
+ d__1 = (wa1[n] - wa1[1]) * .5, d__2 = ulp * anorm, d__1 =
+ max(d__1,d__2), d__2 = rtunfl * 2.;
+ vu = wa1[n] + max(d__1,d__2);
+ }
+ } else {
+ vl = 0.;
+ vu = 1.;
+ }
+
+ dstebz_("V", "E", &n, &vl, &vu, &il, &iu, &abstol, &sd[1], &se[1],
+ &m3, &nsplit, &wa3[1], &iwork[1], &iwork[n + 1], &work[1]
+, &iwork[(n << 1) + 1], &iinfo);
+ if (iinfo != 0) {
+ io___72.ciunit = *nounit;
+ s_wsfe(&io___72);
+ do_fio(&c__1, "DSTEBZ(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[19] = ulpinv;
+ goto L280;
+ }
+ }
+
+ if (m3 == 0 && n != 0) {
+ result[19] = ulpinv;
+ goto L280;
+ }
+
+/* Do test 19 */
+
+ temp1 = dsxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &ulp, &
+ unfl);
+ temp2 = dsxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &ulp, &
+ unfl);
+ if (n > 0) {
+/* Computing MAX */
+ d__2 = (d__1 = wa1[n], abs(d__1)), d__3 = abs(wa1[1]);
+ temp3 = max(d__2,d__3);
+ } else {
+ temp3 = 0.;
+ }
+
+/* Computing MAX */
+ d__1 = unfl, d__2 = temp3 * ulp;
+ result[19] = (temp1 + temp2) / max(d__1,d__2);
+
+/* Call DSTEIN to compute eigenvectors corresponding to */
+/* eigenvalues in WA1. (First call DSTEBZ again, to make sure */
+/* it returns these eigenvalues in the correct order.) */
+
+ ntest = 21;
+ dstebz_("A", "B", &n, &vl, &vu, &il, &iu, &abstol, &sd[1], &se[1],
+ &m, &nsplit, &wa1[1], &iwork[1], &iwork[n + 1], &work[1],
+ &iwork[(n << 1) + 1], &iinfo);
+ if (iinfo != 0) {
+ io___73.ciunit = *nounit;
+ s_wsfe(&io___73);
+ do_fio(&c__1, "DSTEBZ(A,B)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[20] = ulpinv;
+ result[21] = ulpinv;
+ goto L280;
+ }
+ }
+
+ dstein_(&n, &sd[1], &se[1], &m, &wa1[1], &iwork[1], &iwork[n + 1],
+ &z__[z_offset], ldu, &work[1], &iwork[(n << 1) + 1], &
+ iwork[n * 3 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___74.ciunit = *nounit;
+ s_wsfe(&io___74);
+ do_fio(&c__1, "DSTEIN", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[20] = ulpinv;
+ result[21] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do tests 20 and 21 */
+
+ dstt21_(&n, &c__0, &sd[1], &se[1], &wa1[1], dumma, &z__[z_offset],
+ ldu, &work[1], &result[20]);
+
+/* Call DSTEDC(I) to compute D1 and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ dcopy_(&n, &sd[1], &c__1, &d1[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+ dlaset_("Full", &n, &n, &c_b25, &c_b39, &z__[z_offset], ldu);
+
+ ntest = 22;
+ i__3 = lwedc - n;
+ dstedc_("I", &n, &d1[1], &work[1], &z__[z_offset], ldu, &work[n +
+ 1], &i__3, &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___75.ciunit = *nounit;
+ s_wsfe(&io___75);
+ do_fio(&c__1, "DSTEDC(I)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[22] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 22 and 23 */
+
+ dstt21_(&n, &c__0, &sd[1], &se[1], &d1[1], dumma, &z__[z_offset],
+ ldu, &work[1], &result[22]);
+
+/* Call DSTEDC(V) to compute D1 and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ dcopy_(&n, &sd[1], &c__1, &d1[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+ dlaset_("Full", &n, &n, &c_b25, &c_b39, &z__[z_offset], ldu);
+
+ ntest = 24;
+ i__3 = lwedc - n;
+ dstedc_("V", &n, &d1[1], &work[1], &z__[z_offset], ldu, &work[n +
+ 1], &i__3, &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___76.ciunit = *nounit;
+ s_wsfe(&io___76);
+ do_fio(&c__1, "DSTEDC(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[24] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 24 and 25 */
+
+ dstt21_(&n, &c__0, &sd[1], &se[1], &d1[1], dumma, &z__[z_offset],
+ ldu, &work[1], &result[24]);
+
+/* Call DSTEDC(N) to compute D2, do tests. */
+
+/* Compute D2 */
+
+ dcopy_(&n, &sd[1], &c__1, &d2[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+ dlaset_("Full", &n, &n, &c_b25, &c_b39, &z__[z_offset], ldu);
+
+ ntest = 26;
+ i__3 = lwedc - n;
+ dstedc_("N", &n, &d2[1], &work[1], &z__[z_offset], ldu, &work[n +
+ 1], &i__3, &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___77.ciunit = *nounit;
+ s_wsfe(&io___77);
+ do_fio(&c__1, "DSTEDC(N)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[26] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Test 26 */
+
+ temp1 = 0.;
+ temp2 = 0.;
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d1[j], abs(d__1)), d__3 = max(
+ d__3,d__4), d__4 = (d__2 = d2[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d1[j] - d2[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L210: */
+ }
+
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[26] = temp2 / max(d__1,d__2);
+
+/* Only test DSTEMR if IEEE compliant */
+
+ if (ilaenv_(&c__10, "DSTEMR", "VA", &c__1, &c__0, &c__0, &c__0) == 1 && ilaenv_(&c__11, "DSTEMR",
+ "VA", &c__1, &c__0, &c__0, &c__0) ==
+ 1) {
+
+/* Call DSTEMR, do test 27 (relative eigenvalue accuracy) */
+
+/* If S is positive definite and diagonally dominant, */
+/* ask for all eigenvalues with high relative accuracy. */
+
+ vl = 0.;
+ vu = 0.;
+ il = 0;
+ iu = 0;
+ if (FALSE_) {
+ ntest = 27;
+ abstol = unfl + unfl;
+ i__3 = *lwork - (n << 1);
+ dstemr_("V", "A", &n, &sd[1], &se[1], &vl, &vu, &il, &iu,
+ &m, &wr[1], &z__[z_offset], ldu, &n, &iwork[1], &
+ tryrac, &work[1], lwork, &iwork[(n << 1) + 1], &
+ i__3, &iinfo);
+ if (iinfo != 0) {
+ io___78.ciunit = *nounit;
+ s_wsfe(&io___78);
+ do_fio(&c__1, "DSTEMR(V,A,rel)", (ftnlen)15);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[27] = ulpinv;
+ goto L270;
+ }
+ }
+
+/* Do test 27 */
+
+ temp2 = (n * 2. - 1.) * 2. * ulp * 3. / .0625;
+
+ temp1 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__2 = d4[j] - wr[n - j + 1],
+ abs(d__2)) / (abstol + (d__1 = d4[j], abs(
+ d__1)));
+ temp1 = max(d__3,d__4);
+/* L220: */
+ }
+
+ result[27] = temp1 / temp2;
+
+ il = (n - 1) * (integer) dlarnd_(&c__1, iseed2) + 1;
+ iu = (n - 1) * (integer) dlarnd_(&c__1, iseed2) + 1;
+ if (iu < il) {
+ itemp = iu;
+ iu = il;
+ il = itemp;
+ }
+
+ if (FALSE_) {
+ ntest = 28;
+ abstol = unfl + unfl;
+ i__3 = *lwork - (n << 1);
+ dstemr_("V", "I", &n, &sd[1], &se[1], &vl, &vu, &il, &
+ iu, &m, &wr[1], &z__[z_offset], ldu, &n, &
+ iwork[1], &tryrac, &work[1], lwork, &iwork[(n
+ << 1) + 1], &i__3, &iinfo);
+
+ if (iinfo != 0) {
+ io___79.ciunit = *nounit;
+ s_wsfe(&io___79);
+ do_fio(&c__1, "DSTEMR(V,I,rel)", (ftnlen)15);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[28] = ulpinv;
+ goto L270;
+ }
+ }
+
+
+/* Do test 28 */
+
+ temp2 = (n * 2. - 1.) * 2. * ulp * 3. / .0625;
+
+ temp1 = 0.;
+ i__3 = iu;
+ for (j = il; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__2 = wr[j - il + 1] - d4[
+ n - j + 1], abs(d__2)) / (abstol + (d__1 =
+ wr[j - il + 1], abs(d__1)));
+ temp1 = max(d__3,d__4);
+/* L230: */
+ }
+
+ result[28] = temp1 / temp2;
+ } else {
+ result[28] = 0.;
+ }
+ } else {
+ result[27] = 0.;
+ result[28] = 0.;
+ }
+
+/* Call DSTEMR(V,I) to compute D1 and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ dcopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+ dlaset_("Full", &n, &n, &c_b25, &c_b39, &z__[z_offset], ldu);
+
+ if (FALSE_) {
+ ntest = 29;
+ il = (n - 1) * (integer) dlarnd_(&c__1, iseed2) + 1;
+ iu = (n - 1) * (integer) dlarnd_(&c__1, iseed2) + 1;
+ if (iu < il) {
+ itemp = iu;
+ iu = il;
+ il = itemp;
+ }
+ i__3 = *lwork - n;
+ i__4 = *liwork - (n << 1);
+ dstemr_("V", "I", &n, &d5[1], &work[1], &vl, &vu, &il, &
+ iu, &m, &d1[1], &z__[z_offset], ldu, &n, &iwork[1]
+, &tryrac, &work[n + 1], &i__3, &iwork[(n << 1) +
+ 1], &i__4, &iinfo);
+ if (iinfo != 0) {
+ io___80.ciunit = *nounit;
+ s_wsfe(&io___80);
+ do_fio(&c__1, "DSTEMR(V,I)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[29] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 29 and 30 */
+
+ dstt22_(&n, &m, &c__0, &sd[1], &se[1], &d1[1], dumma, &
+ z__[z_offset], ldu, &work[1], &m, &result[29]);
+
+/* Call DSTEMR to compute D2, do tests. */
+
+/* Compute D2 */
+
+ dcopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+
+ ntest = 31;
+ i__3 = *lwork - n;
+ i__4 = *liwork - (n << 1);
+ dstemr_("N", "I", &n, &d5[1], &work[1], &vl, &vu, &il, &
+ iu, &m, &d2[1], &z__[z_offset], ldu, &n, &iwork[1]
+, &tryrac, &work[n + 1], &i__3, &iwork[(n << 1) +
+ 1], &i__4, &iinfo);
+ if (iinfo != 0) {
+ io___81.ciunit = *nounit;
+ s_wsfe(&io___81);
+ do_fio(&c__1, "DSTEMR(N,I)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[31] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Test 31 */
+
+ temp1 = 0.;
+ temp2 = 0.;
+
+ i__3 = iu - il + 1;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = d2[j], abs(
+ d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d1[j] - d2[j], abs(d__1))
+ ;
+ temp2 = max(d__2,d__3);
+/* L240: */
+ }
+
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[31] = temp2 / max(d__1,d__2);
+
+
+/* Call DSTEMR(V,V) to compute D1 and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ dcopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+ dlaset_("Full", &n, &n, &c_b25, &c_b39, &z__[z_offset],
+ ldu);
+
+ ntest = 32;
+
+ if (n > 0) {
+ if (il != 1) {
+/* Computing MAX */
+ d__1 = (d2[il] - d2[il - 1]) * .5, d__2 = ulp *
+ anorm, d__1 = max(d__1,d__2), d__2 =
+ rtunfl * 2.;
+ vl = d2[il] - max(d__1,d__2);
+ } else {
+/* Computing MAX */
+ d__1 = (d2[n] - d2[1]) * .5, d__2 = ulp * anorm,
+ d__1 = max(d__1,d__2), d__2 = rtunfl * 2.;
+ vl = d2[1] - max(d__1,d__2);
+ }
+ if (iu != n) {
+/* Computing MAX */
+ d__1 = (d2[iu + 1] - d2[iu]) * .5, d__2 = ulp *
+ anorm, d__1 = max(d__1,d__2), d__2 =
+ rtunfl * 2.;
+ vu = d2[iu] + max(d__1,d__2);
+ } else {
+/* Computing MAX */
+ d__1 = (d2[n] - d2[1]) * .5, d__2 = ulp * anorm,
+ d__1 = max(d__1,d__2), d__2 = rtunfl * 2.;
+ vu = d2[n] + max(d__1,d__2);
+ }
+ } else {
+ vl = 0.;
+ vu = 1.;
+ }
+
+ i__3 = *lwork - n;
+ i__4 = *liwork - (n << 1);
+ dstemr_("V", "V", &n, &d5[1], &work[1], &vl, &vu, &il, &
+ iu, &m, &d1[1], &z__[z_offset], ldu, &n, &iwork[1]
+, &tryrac, &work[n + 1], &i__3, &iwork[(n << 1) +
+ 1], &i__4, &iinfo);
+ if (iinfo != 0) {
+ io___82.ciunit = *nounit;
+ s_wsfe(&io___82);
+ do_fio(&c__1, "DSTEMR(V,V)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[32] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 32 and 33 */
+
+ dstt22_(&n, &m, &c__0, &sd[1], &se[1], &d1[1], dumma, &
+ z__[z_offset], ldu, &work[1], &m, &result[32]);
+
+/* Call DSTEMR to compute D2, do tests. */
+
+/* Compute D2 */
+
+ dcopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+
+ ntest = 34;
+ i__3 = *lwork - n;
+ i__4 = *liwork - (n << 1);
+ dstemr_("N", "V", &n, &d5[1], &work[1], &vl, &vu, &il, &
+ iu, &m, &d2[1], &z__[z_offset], ldu, &n, &iwork[1]
+, &tryrac, &work[n + 1], &i__3, &iwork[(n << 1) +
+ 1], &i__4, &iinfo);
+ if (iinfo != 0) {
+ io___83.ciunit = *nounit;
+ s_wsfe(&io___83);
+ do_fio(&c__1, "DSTEMR(N,V)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[34] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Test 34 */
+
+ temp1 = 0.;
+ temp2 = 0.;
+
+ i__3 = iu - il + 1;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = d2[j], abs(
+ d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d1[j] - d2[j], abs(d__1))
+ ;
+ temp2 = max(d__2,d__3);
+/* L250: */
+ }
+
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[34] = temp2 / max(d__1,d__2);
+ } else {
+ result[29] = 0.;
+ result[30] = 0.;
+ result[31] = 0.;
+ result[32] = 0.;
+ result[33] = 0.;
+ result[34] = 0.;
+ }
+
+
+/* Call DSTEMR(V,A) to compute D1 and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ dcopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+
+ ntest = 35;
+
+ i__3 = *lwork - n;
+ i__4 = *liwork - (n << 1);
+ dstemr_("V", "A", &n, &d5[1], &work[1], &vl, &vu, &il, &iu, &
+ m, &d1[1], &z__[z_offset], ldu, &n, &iwork[1], &
+ tryrac, &work[n + 1], &i__3, &iwork[(n << 1) + 1], &
+ i__4, &iinfo);
+ if (iinfo != 0) {
+ io___84.ciunit = *nounit;
+ s_wsfe(&io___84);
+ do_fio(&c__1, "DSTEMR(V,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[35] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 35 and 36 */
+
+ dstt22_(&n, &m, &c__0, &sd[1], &se[1], &d1[1], dumma, &z__[
+ z_offset], ldu, &work[1], &m, &result[35]);
+
+/* Call DSTEMR to compute D2, do tests. */
+
+/* Compute D2 */
+
+ dcopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+
+ ntest = 37;
+ i__3 = *lwork - n;
+ i__4 = *liwork - (n << 1);
+ dstemr_("N", "A", &n, &d5[1], &work[1], &vl, &vu, &il, &iu, &
+ m, &d2[1], &z__[z_offset], ldu, &n, &iwork[1], &
+ tryrac, &work[n + 1], &i__3, &iwork[(n << 1) + 1], &
+ i__4, &iinfo);
+ if (iinfo != 0) {
+ io___85.ciunit = *nounit;
+ s_wsfe(&io___85);
+ do_fio(&c__1, "DSTEMR(N,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[37] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Test 34 */
+
+ temp1 = 0.;
+ temp2 = 0.;
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = d2[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d1[j] - d2[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L260: */
+ }
+
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[37] = temp2 / max(d__1,d__2);
+ }
+L270:
+L280:
+ ntestt += ntest;
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+
+/* Print out tests which fail. */
+
+ i__3 = ntest;
+ for (jr = 1; jr <= i__3; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___86.ciunit = *nounit;
+ s_wsfe(&io___86);
+ do_fio(&c__1, "DST", (ftnlen)3);
+ e_wsfe();
+ io___87.ciunit = *nounit;
+ s_wsfe(&io___87);
+ e_wsfe();
+ io___88.ciunit = *nounit;
+ s_wsfe(&io___88);
+ e_wsfe();
+ io___89.ciunit = *nounit;
+ s_wsfe(&io___89);
+ do_fio(&c__1, "Symmetric", (ftnlen)9);
+ e_wsfe();
+ io___90.ciunit = *nounit;
+ s_wsfe(&io___90);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___91.ciunit = *nounit;
+ s_wsfe(&io___91);
+ e_wsfe();
+ }
+ ++nerrs;
+ io___92.ciunit = *nounit;
+ s_wsfe(&io___92);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+/* L290: */
+ }
+L300:
+ ;
+ }
+/* L310: */
+ }
+
+/* Summary */
+
+ dlasum_("DST", nounit, &nerrs, &ntestt);
+ return 0;
+
+
+
+
+/* L9993: */
+/* L9992: */
+/* L9991: */
+/* L9989: */
+
+/* End of DCHKST */
+
+} /* dchkst_ */
diff --git a/TESTING/EIG/dckglm.c b/TESTING/EIG/dckglm.c
new file mode 100644
index 0000000..8f23087
--- /dev/null
+++ b/TESTING/EIG/dckglm.c
@@ -0,0 +1,325 @@
+/* dckglm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+
+/* Subroutine */ int dckglm_(integer *nn, integer *mval, integer *pval,
+ integer *nval, integer *nmats, integer *iseed, doublereal *thresh,
+ integer *nmax, doublereal *a, doublereal *af, doublereal *b,
+ doublereal *bf, doublereal *x, doublereal *work, doublereal *rwork,
+ integer *nin, integer *nout, integer *info)
+{
+ /* Format strings */
+ static char fmt_9997[] = "(\002 *** Invalid input for GLM: M = \002,"
+ "i6,\002, P = \002,i6,\002, N = \002,i6,\002;\002,/\002 must "
+ "satisfy M <= N <= M+P \002,\002(this set of values will be skip"
+ "ped)\002)";
+ static char fmt_9999[] = "(\002 DLATMS in DCKGLM INFO = \002,i5)";
+ static char fmt_9998[] = "(\002 N=\002,i4,\002 M=\002,i4,\002, P=\002,"
+ "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
+
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), do_fio(integer *
+ , char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, m, n, p, ik, lda, ldb, kla, klb, kua, kub, imat;
+ char path[3], type__[1];
+ integer nrun, modea, modeb, nfail;
+ char dista[1], distb[1];
+ integer iinfo;
+ doublereal resid, anorm, bnorm;
+ integer lwork;
+ extern /* Subroutine */ int dlatb9_(char *, integer *, integer *, integer
+ *, integer *, char *, integer *, integer *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ doublereal *, char *, char *),
+ alahdg_(integer *, char *);
+ doublereal cndnma, cndnmb;
+ extern doublereal dlarnd_(integer *, integer *);
+ extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
+ *, integer *, integer *), alasum_(char *, integer *,
+ integer *, integer *, integer *), dlatms_(integer *,
+ integer *, char *, integer *, char *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *, char *,
+ doublereal *, integer *, doublereal *, integer *), dglmts_(integer *, integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ logical dotype[8], firstt;
+
+ /* Fortran I/O blocks */
+ static cilist io___13 = { 0, 0, 0, 0, 0 };
+ static cilist io___14 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCKGLM tests DGGGLM - subroutine for solving generalized linear */
+/* model problem. */
+
+/* Arguments */
+/* ========= */
+
+/* NN (input) INTEGER */
+/* The number of values of N, M and P contained in the vectors */
+/* NVAL, MVAL and PVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension M. */
+
+/* PVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension P. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix row dimension N. */
+
+/* NMATS (input) INTEGER */
+/* The number of matrix types to be tested for each combination */
+/* of matrix dimensions. If NMATS >= NTYPES (the maximum */
+/* number of matrix types), then all the different types are */
+/* generated for testing. If NMATS < NTYPES, another input line */
+/* is read to get the numbers of the matrix types to be used. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator. The array */
+/* elements should be between 0 and 4095, otherwise they will be */
+/* reduced mod 4096, and ISEED(4) must be odd. */
+/* On exit, the next seed in the random number sequence after */
+/* all the test matrices have been generated. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* The threshold value for the test ratios. A result is */
+/* included in the output file if RESID >= THRESH. To have */
+/* every test ratio printed, use THRESH = 0. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* BF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (4*NMAX) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* NIN (input) INTEGER */
+/* The unit number for input. */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit */
+/* > 0 : If DLATMS returns an error code, the absolute value */
+/* of it is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --x;
+ --bf;
+ --b;
+ --af;
+ --a;
+ --iseed;
+ --nval;
+ --pval;
+ --mval;
+
+ /* Function Body */
+ s_copy(path, "GLM", (ftnlen)3, (ftnlen)3);
+ *info = 0;
+ nrun = 0;
+ nfail = 0;
+ firstt = TRUE_;
+ alareq_(path, nmats, dotype, &c__8, nin, nout);
+ lda = *nmax;
+ ldb = *nmax;
+ lwork = *nmax * *nmax;
+
+/* Check for valid input values. */
+
+ i__1 = *nn;
+ for (ik = 1; ik <= i__1; ++ik) {
+ m = mval[ik];
+ p = pval[ik];
+ n = nval[ik];
+ if (m > n || n > m + p) {
+ if (firstt) {
+ io___13.ciunit = *nout;
+ s_wsle(&io___13);
+ e_wsle();
+ firstt = FALSE_;
+ }
+ io___14.ciunit = *nout;
+ s_wsfe(&io___14);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L10: */
+ }
+ firstt = TRUE_;
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nn;
+ for (ik = 1; ik <= i__1; ++ik) {
+ m = mval[ik];
+ p = pval[ik];
+ n = nval[ik];
+ if (m > n || n > m + p) {
+ goto L40;
+ }
+
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat - 1]) {
+ goto L30;
+ }
+
+/* Set up parameters with DLATB9 and generate test */
+/* matrices A and B with DLATMS. */
+
+ dlatb9_(path, &imat, &m, &p, &n, type__, &kla, &kua, &klb, &kub, &
+ anorm, &bnorm, &modea, &modeb, &cndnma, &cndnmb, dista,
+ distb);
+
+ dlatms_(&n, &m, dista, &iseed[1], type__, &rwork[1], &modea, &
+ cndnma, &anorm, &kla, &kua, "No packing", &a[1], &lda, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+ dlatms_(&n, &p, distb, &iseed[1], type__, &rwork[1], &modeb, &
+ cndnmb, &bnorm, &klb, &kub, "No packing", &b[1], &ldb, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+/* Generate random left hand side vector of GLM */
+
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__] = dlarnd_(&c__2, &iseed[1]);
+/* L20: */
+ }
+
+ dglmts_(&n, &m, &p, &a[1], &af[1], &lda, &b[1], &bf[1], &ldb, &x[
+ 1], &x[*nmax + 1], &x[(*nmax << 1) + 1], &x[*nmax * 3 + 1]
+, &work[1], &lwork, &rwork[1], &resid);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ if (resid >= *thresh) {
+ if (nfail == 0 && firstt) {
+ firstt = FALSE_;
+ alahdg_(nout, path);
+ }
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&resid, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+L30:
+ ;
+ }
+L40:
+ ;
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &c__0);
+
+ return 0;
+
+/* End of DCKGLM */
+
+} /* dckglm_ */
diff --git a/TESTING/EIG/dckgqr.c b/TESTING/EIG/dckgqr.c
new file mode 100644
index 0000000..b409ad8
--- /dev/null
+++ b/TESTING/EIG/dckgqr.c
@@ -0,0 +1,430 @@
+/* dckgqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static integer c__1 = 1;
+static integer c__0 = 0;
+
+/* Subroutine */ int dckgqr_(integer *nm, integer *mval, integer *np, integer
+ *pval, integer *nn, integer *nval, integer *nmats, integer *iseed,
+ doublereal *thresh, integer *nmax, doublereal *a, doublereal *af,
+ doublereal *aq, doublereal *ar, doublereal *taua, doublereal *b,
+ doublereal *bf, doublereal *bz, doublereal *bt, doublereal *bwk,
+ doublereal *taub, doublereal *work, doublereal *rwork, integer *nin,
+ integer *nout, integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 DLATMS in DCKGQR: INFO = \002,i5)";
+ static char fmt_9998[] = "(\002 M=\002,i4,\002 P=\002,i4,\002, N=\002,"
+ "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
+ static char fmt_9997[] = "(\002 N=\002,i4,\002 M=\002,i4,\002, P=\002,"
+ "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, m, n, p, im, in, ip, nt, lda, ldb, kla, klb, kua, kub;
+ char path[3];
+ integer imat;
+ char type__[1];
+ integer nrun, modea, modeb, nfail;
+ char dista[1], distb[1];
+ integer iinfo;
+ doublereal anorm, bnorm;
+ integer lwork;
+ extern /* Subroutine */ int dlatb9_(char *, integer *, integer *, integer
+ *, integer *, char *, integer *, integer *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ doublereal *, char *, char *),
+ alahdg_(integer *, char *);
+ doublereal cndnma, cndnmb;
+ extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
+ *, integer *, integer *), alasum_(char *, integer *,
+ integer *, integer *, integer *), dlatms_(integer *,
+ integer *, char *, integer *, char *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *, char *,
+ doublereal *, integer *, doublereal *, integer *);
+ logical dotype[8];
+ extern /* Subroutine */ int dgqrts_(integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, doublereal *), dgrqts_(integer *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *
+, doublereal *, integer *, doublereal *, doublereal *);
+ logical firstt;
+ doublereal result[7];
+
+ /* Fortran I/O blocks */
+ static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCKGQR tests */
+/* DGGQRF: GQR factorization for N-by-M matrix A and N-by-P matrix B, */
+/* DGGRQF: GRQ factorization for M-by-N matrix A and P-by-N matrix B. */
+
+/* Arguments */
+/* ========= */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row(column) dimension M. */
+
+/* NP (input) INTEGER */
+/* The number of values of P contained in the vector PVAL. */
+
+/* PVAL (input) INTEGER array, dimension (NP) */
+/* The values of the matrix row(column) dimension P. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column(row) dimension N. */
+
+/* NMATS (input) INTEGER */
+/* The number of matrix types to be tested for each combination */
+/* of matrix dimensions. If NMATS >= NTYPES (the maximum */
+/* number of matrix types), then all the different types are */
+/* generated for testing. If NMATS < NTYPES, another input line */
+/* is read to get the numbers of the matrix types to be used. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator. The array */
+/* elements should be between 0 and 4095, otherwise they will be */
+/* reduced mod 4096, and ISEED(4) must be odd. */
+/* On exit, the next seed in the random number sequence after */
+/* all the test matrices have been generated. */
+
+/* THRESH (input) 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. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AQ (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AR (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* TAUA (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* BF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* BZ (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* BT (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* BWK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* TAUB (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* NIN (input) INTEGER */
+/* The unit number for input. */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit */
+/* > 0 : If DLATMS returns an error code, the absolute value */
+/* of it is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --taub;
+ --bwk;
+ --bt;
+ --bz;
+ --bf;
+ --b;
+ --taua;
+ --ar;
+ --aq;
+ --af;
+ --a;
+ --iseed;
+ --nval;
+ --pval;
+ --mval;
+
+ /* Function Body */
+ s_copy(path, "GQR", (ftnlen)3, (ftnlen)3);
+ *info = 0;
+ nrun = 0;
+ nfail = 0;
+ firstt = TRUE_;
+ alareq_(path, nmats, dotype, &c__8, nin, nout);
+ lda = *nmax;
+ ldb = *nmax;
+ lwork = *nmax * *nmax;
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Do for each value of P in PVAL. */
+
+ i__2 = *np;
+ for (ip = 1; ip <= i__2; ++ip) {
+ p = pval[ip];
+
+/* Do for each value of N in NVAL. */
+
+ i__3 = *nn;
+ for (in = 1; in <= i__3; ++in) {
+ n = nval[in];
+
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat - 1]) {
+ goto L30;
+ }
+
+/* Test DGGRQF */
+
+/* Set up parameters with DLATB9 and generate test */
+/* matrices A and B with DLATMS. */
+
+ dlatb9_("GRQ", &imat, &m, &p, &n, type__, &kla, &kua, &
+ klb, &kub, &anorm, &bnorm, &modea, &modeb, &
+ cndnma, &cndnmb, dista, distb);
+
+/* Generate M by N matrix A */
+
+ dlatms_(&m, &n, dista, &iseed[1], type__, &rwork[1], &
+ modea, &cndnma, &anorm, &kla, &kua, "No packing",
+ &a[1], &lda, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+/* Generate P by N matrix B */
+
+ dlatms_(&p, &n, distb, &iseed[1], type__, &rwork[1], &
+ modeb, &cndnmb, &bnorm, &klb, &kub, "No packing",
+ &b[1], &ldb, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+ nt = 4;
+
+ dgrqts_(&m, &p, &n, &a[1], &af[1], &aq[1], &ar[1], &lda, &
+ taua[1], &b[1], &bf[1], &bz[1], &bt[1], &bwk[1], &
+ ldb, &taub[1], &work[1], &lwork, &rwork[1],
+ result);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && firstt) {
+ firstt = FALSE_;
+ alahdg_(nout, "GRQ");
+ }
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L10: */
+ }
+ nrun += nt;
+
+/* Test DGGQRF */
+
+/* Set up parameters with DLATB9 and generate test */
+/* matrices A and B with DLATMS. */
+
+ dlatb9_("GQR", &imat, &m, &p, &n, type__, &kla, &kua, &
+ klb, &kub, &anorm, &bnorm, &modea, &modeb, &
+ cndnma, &cndnmb, dista, distb);
+
+/* Generate N-by-M matrix A */
+
+ dlatms_(&n, &m, dista, &iseed[1], type__, &rwork[1], &
+ modea, &cndnma, &anorm, &kla, &kua, "No packing",
+ &a[1], &lda, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+/* Generate N-by-P matrix B */
+
+ dlatms_(&n, &p, distb, &iseed[1], type__, &rwork[1], &
+ modea, &cndnma, &bnorm, &klb, &kub, "No packing",
+ &b[1], &ldb, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+ nt = 4;
+
+ dgqrts_(&n, &m, &p, &a[1], &af[1], &aq[1], &ar[1], &lda, &
+ taua[1], &b[1], &bf[1], &bz[1], &bt[1], &bwk[1], &
+ ldb, &taub[1], &work[1], &lwork, &rwork[1],
+ result);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && firstt) {
+ firstt = FALSE_;
+ alahdg_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+
+L30:
+ ;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &c__0);
+
+ return 0;
+
+/* End of DCKGQR */
+
+} /* dckgqr_ */
diff --git a/TESTING/EIG/dckgsv.c b/TESTING/EIG/dckgsv.c
new file mode 100644
index 0000000..70042d0
--- /dev/null
+++ b/TESTING/EIG/dckgsv.c
@@ -0,0 +1,315 @@
+/* dckgsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static integer c__1 = 1;
+static integer c__0 = 0;
+
+/* Subroutine */ int dckgsv_(integer *nm, integer *mval, integer *pval,
+ integer *nval, integer *nmats, integer *iseed, doublereal *thresh,
+ integer *nmax, doublereal *a, doublereal *af, doublereal *b,
+ doublereal *bf, doublereal *u, doublereal *v, doublereal *q,
+ doublereal *alpha, doublereal *beta, doublereal *r__, integer *iwork,
+ doublereal *work, doublereal *rwork, integer *nin, integer *nout,
+ integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 DLATMS in DCKGSV INFO = \002,i5)";
+ static char fmt_9998[] = "(\002 M=\002,i4,\002 P=\002,i4,\002, N=\002,"
+ "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
+
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, m, n, p, im, nt, lda, ldb, kla, klb, kua, kub, ldq, ldr, ldu,
+ ldv, imat;
+ char path[3], type__[1];
+ integer nrun, modea, modeb, nfail;
+ char dista[1], distb[1];
+ integer iinfo;
+ doublereal anorm, bnorm;
+ integer lwork;
+ extern /* Subroutine */ int dlatb9_(char *, integer *, integer *, integer
+ *, integer *, char *, integer *, integer *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ doublereal *, char *, char *),
+ alahdg_(integer *, char *);
+ doublereal cndnma, cndnmb;
+ extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
+ *, integer *, integer *), alasum_(char *, integer *,
+ integer *, integer *, integer *), dlatms_(integer *,
+ integer *, char *, integer *, char *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *, char *,
+ doublereal *, integer *, doublereal *, integer *);
+ logical dotype[8];
+ extern /* Subroutine */ int dgsvts_(integer *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *);
+ logical firstt;
+ doublereal result[7];
+
+ /* Fortran I/O blocks */
+ static cilist io___32 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCKGSV tests DGGSVD: */
+/* the GSVD for M-by-N matrix A and P-by-N matrix B. */
+
+/* Arguments */
+/* ========= */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* PVAL (input) INTEGER array, dimension (NP) */
+/* The values of the matrix row dimension P. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NMATS (input) INTEGER */
+/* The number of matrix types to be tested for each combination */
+/* of matrix dimensions. If NMATS >= NTYPES (the maximum */
+/* number of matrix types), then all the different types are */
+/* generated for testing. If NMATS < NTYPES, another input line */
+/* is read to get the numbers of the matrix types to be used. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator. The array */
+/* elements should be between 0 and 4095, otherwise they will be */
+/* reduced mod 4096, and ISEED(4) must be odd. */
+/* On exit, the next seed in the random number sequence after */
+/* all the test matrices have been generated. */
+
+/* THRESH (input) 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. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* BF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* U (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* V (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* Q (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* ALPHA (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* BETA (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* R (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* NIN (input) INTEGER */
+/* The unit number for input. */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit */
+/* > 0 : If DLATMS returns an error code, the absolute value */
+/* of it is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --iwork;
+ --r__;
+ --beta;
+ --alpha;
+ --q;
+ --v;
+ --u;
+ --bf;
+ --b;
+ --af;
+ --a;
+ --iseed;
+ --nval;
+ --pval;
+ --mval;
+
+ /* Function Body */
+ s_copy(path, "GSV", (ftnlen)3, (ftnlen)3);
+ *info = 0;
+ nrun = 0;
+ nfail = 0;
+ firstt = TRUE_;
+ alareq_(path, nmats, dotype, &c__8, nin, nout);
+ lda = *nmax;
+ ldb = *nmax;
+ ldu = *nmax;
+ ldv = *nmax;
+ ldq = *nmax;
+ ldr = *nmax;
+ lwork = *nmax * *nmax;
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+ p = pval[im];
+ n = nval[im];
+
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat - 1]) {
+ goto L20;
+ }
+
+/* Set up parameters with DLATB9 and generate test */
+/* matrices A and B with DLATMS. */
+
+ dlatb9_(path, &imat, &m, &p, &n, type__, &kla, &kua, &klb, &kub, &
+ anorm, &bnorm, &modea, &modeb, &cndnma, &cndnmb, dista,
+ distb);
+
+/* Generate M by N matrix A */
+
+ dlatms_(&m, &n, dista, &iseed[1], type__, &rwork[1], &modea, &
+ cndnma, &anorm, &kla, &kua, "No packing", &a[1], &lda, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L20;
+ }
+
+ dlatms_(&p, &n, distb, &iseed[1], type__, &rwork[1], &modeb, &
+ cndnmb, &bnorm, &klb, &kub, "No packing", &b[1], &ldb, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L20;
+ }
+
+ nt = 6;
+
+ dgsvts_(&m, &p, &n, &a[1], &af[1], &lda, &b[1], &bf[1], &ldb, &u[
+ 1], &ldu, &v[1], &ldv, &q[1], &ldq, &alpha[1], &beta[1], &
+ r__[1], &ldr, &iwork[1], &work[1], &lwork, &rwork[1],
+ result);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__2 = nt;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && firstt) {
+ firstt = FALSE_;
+ alahdg_(nout, path);
+ }
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L10: */
+ }
+ nrun += nt;
+L20:
+ ;
+ }
+/* L30: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &c__0);
+
+ return 0;
+
+/* End of DCKGSV */
+
+} /* dckgsv_ */
diff --git a/TESTING/EIG/dcklse.c b/TESTING/EIG/dcklse.c
new file mode 100644
index 0000000..23f4990
--- /dev/null
+++ b/TESTING/EIG/dcklse.c
@@ -0,0 +1,352 @@
+/* dcklse.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static integer c__1 = 1;
+static integer c__0 = 0;
+
+/* Subroutine */ int dcklse_(integer *nn, integer *mval, integer *pval,
+ integer *nval, integer *nmats, integer *iseed, doublereal *thresh,
+ integer *nmax, doublereal *a, doublereal *af, doublereal *b,
+ doublereal *bf, doublereal *x, doublereal *work, doublereal *rwork,
+ integer *nin, integer *nout, integer *info)
+{
+ /* Format strings */
+ static char fmt_9997[] = "(\002 *** Invalid input for LSE: M = \002,"
+ "i6,\002, P = \002,i6,\002, N = \002,i6,\002;\002,/\002 must "
+ "satisfy P <= N <= P+M \002,\002(this set of values will be skip"
+ "ped)\002)";
+ static char fmt_9999[] = "(\002 DLATMS in DCKLSE INFO = \002,i5)";
+ static char fmt_9998[] = "(\002 M=\002,i4,\002 P=\002,i4,\002, N=\002,"
+ "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), do_fio(integer *
+ , char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, m, n, p, ik, nt, lda, ldb, kla, klb, kua, kub, imat;
+ char path[3], type__[1];
+ integer nrun, modea, modeb, nfail;
+ char dista[1], distb[1];
+ integer iinfo;
+ doublereal anorm, bnorm;
+ integer lwork;
+ extern /* Subroutine */ int dlatb9_(char *, integer *, integer *, integer
+ *, integer *, char *, integer *, integer *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ doublereal *, char *, char *),
+ alahdg_(integer *, char *);
+ doublereal cndnma, cndnmb;
+ extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
+ *, integer *, integer *), dlarhs_(char *, char *, char *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *, integer *),
+ alasum_(char *, integer *, integer *, integer *, integer *), dlatms_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublereal *, integer *, doublereal *, integer
+ *), dlsets_(integer *, integer *, integer
+ *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *
+, doublereal *);
+ logical dotype[8], firstt;
+ doublereal result[7];
+
+ /* Fortran I/O blocks */
+ static cilist io___13 = { 0, 0, 0, 0, 0 };
+ static cilist io___14 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCKLSE tests DGGLSE - a subroutine for solving linear equality */
+/* constrained least square problem (LSE). */
+
+/* Arguments */
+/* ========= */
+
+/* NN (input) INTEGER */
+/* The number of values of (M,P,N) contained in the vectors */
+/* (MVAL, PVAL, NVAL). */
+
+/* MVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix row(column) dimension M. */
+
+/* PVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix row(column) dimension P. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column(row) dimension N. */
+
+/* NMATS (input) INTEGER */
+/* The number of matrix types to be tested for each combination */
+/* of matrix dimensions. If NMATS >= NTYPES (the maximum */
+/* number of matrix types), then all the different types are */
+/* generated for testing. If NMATS < NTYPES, another input line */
+/* is read to get the numbers of the matrix types to be used. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator. The array */
+/* elements should be between 0 and 4095, otherwise they will be */
+/* reduced mod 4096, and ISEED(4) must be odd. */
+/* On exit, the next seed in the random number sequence after */
+/* all the test matrices have been generated. */
+
+/* THRESH (input) 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. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* BF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (5*NMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* NIN (input) INTEGER */
+/* The unit number for input. */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit */
+/* > 0 : If DLATMS returns an error code, the absolute value */
+/* of it is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --x;
+ --bf;
+ --b;
+ --af;
+ --a;
+ --iseed;
+ --nval;
+ --pval;
+ --mval;
+
+ /* Function Body */
+ s_copy(path, "LSE", (ftnlen)3, (ftnlen)3);
+ *info = 0;
+ nrun = 0;
+ nfail = 0;
+ firstt = TRUE_;
+ alareq_(path, nmats, dotype, &c__8, nin, nout);
+ lda = *nmax;
+ ldb = *nmax;
+ lwork = *nmax * *nmax;
+
+/* Check for valid input values. */
+
+ i__1 = *nn;
+ for (ik = 1; ik <= i__1; ++ik) {
+ m = mval[ik];
+ p = pval[ik];
+ n = nval[ik];
+ if (p > n || n > m + p) {
+ if (firstt) {
+ io___13.ciunit = *nout;
+ s_wsle(&io___13);
+ e_wsle();
+ firstt = FALSE_;
+ }
+ io___14.ciunit = *nout;
+ s_wsfe(&io___14);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L10: */
+ }
+ firstt = TRUE_;
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nn;
+ for (ik = 1; ik <= i__1; ++ik) {
+ m = mval[ik];
+ p = pval[ik];
+ n = nval[ik];
+ if (p > n || n > m + p) {
+ goto L40;
+ }
+
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat - 1]) {
+ goto L30;
+ }
+
+/* Set up parameters with DLATB9 and generate test */
+/* matrices A and B with DLATMS. */
+
+ dlatb9_(path, &imat, &m, &p, &n, type__, &kla, &kua, &klb, &kub, &
+ anorm, &bnorm, &modea, &modeb, &cndnma, &cndnmb, dista,
+ distb);
+
+ dlatms_(&m, &n, dista, &iseed[1], type__, &rwork[1], &modea, &
+ cndnma, &anorm, &kla, &kua, "No packing", &a[1], &lda, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+ dlatms_(&p, &n, distb, &iseed[1], type__, &rwork[1], &modeb, &
+ cndnmb, &bnorm, &klb, &kub, "No packing", &b[1], &ldb, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+/* Generate the right-hand sides C and D for the LSE. */
+
+/* Computing MAX */
+ i__3 = m - 1;
+ i__2 = max(i__3,0);
+/* Computing MAX */
+ i__5 = n - 1;
+ i__4 = max(i__5,0);
+ i__6 = max(n,1);
+ i__7 = max(m,1);
+ dlarhs_("DGE", "New solution", "Upper", "N", &m, &n, &i__2, &i__4,
+ &c__1, &a[1], &lda, &x[(*nmax << 2) + 1], &i__6, &x[1], &
+ i__7, &iseed[1], &iinfo);
+
+/* Computing MAX */
+ i__3 = p - 1;
+ i__2 = max(i__3,0);
+/* Computing MAX */
+ i__5 = n - 1;
+ i__4 = max(i__5,0);
+ i__6 = max(n,1);
+ i__7 = max(p,1);
+ dlarhs_("DGE", "Computed", "Upper", "N", &p, &n, &i__2, &i__4, &
+ c__1, &b[1], &ldb, &x[(*nmax << 2) + 1], &i__6, &x[(*nmax
+ << 1) + 1], &i__7, &iseed[1], &iinfo);
+
+ nt = 2;
+
+ dlsets_(&m, &p, &n, &a[1], &af[1], &lda, &b[1], &bf[1], &ldb, &x[
+ 1], &x[*nmax + 1], &x[(*nmax << 1) + 1], &x[*nmax * 3 + 1]
+, &x[(*nmax << 2) + 1], &work[1], &lwork, &rwork[1],
+ result);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__2 = nt;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && firstt) {
+ firstt = FALSE_;
+ alahdg_(nout, path);
+ }
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+
+L30:
+ ;
+ }
+L40:
+ ;
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &c__0);
+
+ return 0;
+
+/* End of DCKLSE */
+
+} /* dcklse_ */
diff --git a/TESTING/EIG/ddrges.c b/TESTING/EIG/ddrges.c
new file mode 100644
index 0000000..1517b9a
--- /dev/null
+++ b/TESTING/EIG/ddrges.c
@@ -0,0 +1,1139 @@
+/* ddrges.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b26 = 0.;
+static integer c__2 = 2;
+static doublereal c_b32 = 1.;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static integer c__0 = 0;
+
+/* Subroutine */ int ddrges_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
+ doublereal *a, integer *lda, doublereal *b, doublereal *s, doublereal
+ *t, doublereal *q, integer *ldq, doublereal *z__, doublereal *alphar,
+ doublereal *alphai, doublereal *beta, doublereal *work, integer *
+ lwork, doublereal *result, logical *bwork, integer *info)
+{
+ /* Initialized data */
+
+ static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
+ 2,2,2,3 };
+ static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
+ 2,3,2,1 };
+ static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
+ 1,1,1,1 };
+ static integer iasign[26] = { 0,0,0,0,0,0,2,0,2,2,0,0,2,2,2,0,2,0,0,0,2,2,
+ 2,2,2,0 };
+ static integer ibsign[26] = { 0,0,0,0,0,0,0,2,0,0,2,2,0,0,2,0,2,0,0,0,0,0,
+ 0,0,0,0 };
+ static integer kz1[6] = { 0,1,2,1,3,3 };
+ static integer kz2[6] = { 0,0,1,2,1,1 };
+ static integer kadd[6] = { 0,0,0,0,3,2 };
+ static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
+ 4,4,4,0 };
+ static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
+ 8,8,8,8,8,0 };
+ static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
+ 3,3,3,1 };
+ static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
+ 4,4,4,1 };
+ static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
+ 3,3,2,1 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 DDRGES: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,4(i4,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 DDRGES: DGET53 returned INFO=\002,i1,"
+ "\002 for eigenvalue \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JT"
+ "YPE=\002,i6,\002, ISEED=(\002,4(i4,\002,\002),i5,\002)\002)";
+ static char fmt_9997[] = "(\002 DDRGES: S not in Schur form at eigenvalu"
+ "e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, "
+ "ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9996[] = "(/1x,a3,\002 -- Real Generalized Schur form dr"
+ "iver\002)";
+ static char fmt_9995[] = "(\002 Matrix types (see DDRGES for details):"
+ " \002)";
+ static char fmt_9994[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
+ "osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
+ ") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
+ "onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
+ "I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
+ "arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
+ "(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
+ "=(D, reversed D)\002)";
+ static char fmt_9993[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
+ "atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
+ " 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
+ "ha&beta \002,\002 20=arithmetic alpha, beta=0,"
+ "1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
+ "=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
+ "/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
+ "l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
+ ".\002)";
+ static char fmt_9992[] = "(/\002 Tests performed: (S is Schur, T is tri"
+ "angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002l and r "
+ "are the appropriate left and right\002,/19x,\002eigenvectors, re"
+ "sp., a is alpha, b is beta, and\002,/19x,a,\002 means \002,a,"
+ "\002.)\002,/\002 Without ordering: \002,/\002 1 = | A - Q S "
+ "Z\002,a,\002 | / ( |A| n ulp ) 2 = | B - Q T Z\002,a,\002 |"
+ " / ( |B| n ulp )\002,/\002 3 = | I - QQ\002,a,\002 | / ( n ulp "
+ ") 4 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 5"
+ " = A is in Schur form S\002,/\002 6 = difference between (alpha"
+ ",beta)\002,\002 and diagonals of (S,T)\002,/\002 With ordering:"
+ " \002,/\002 7 = | (A,B) - Q (S,T) Z\002,a,\002 | / ( |(A,B)| n "
+ "ulp ) \002,/\002 8 = | I - QQ\002,a,\002 | / ( n ulp ) "
+ " 9 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 10 = A is in"
+ " Schur form S\002,/\002 11 = difference between (alpha,beta) and"
+ " diagonals\002,\002 of (S,T)\002,/\002 12 = SDIM is the correct "
+ "number of \002,\002selected eigenvalues\002,/)";
+ static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",0p,f8.2)";
+ static char fmt_9990[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",1p,d10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1,
+ s_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2, i__3,
+ i__4;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, n, i1, n1, jc, nb, in, jr;
+ doublereal ulp;
+ integer iadd, sdim, ierr, nmax, rsub;
+ char sort[1];
+ doublereal temp1, temp2;
+ logical badnn;
+ extern /* Subroutine */ int dget51_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *), dget53_(
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *), dget54_(
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *),
+ dgges_(char *, char *, char *, L_fp, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, logical *, integer *);
+ integer iinfo;
+ doublereal rmagn[4];
+ integer nmats, jsize, nerrs, jtype, ntest, isort;
+ extern /* Subroutine */ int dlatm4_(integer *, integer *, integer *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, integer *), dorm2r_(char *,
+ char *, integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *), dlabad_(doublereal *, doublereal *);
+ logical ilabad;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *);
+ extern doublereal dlarnd_(integer *, integer *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ doublereal safmin;
+ integer ioldsd[4];
+ doublereal safmax;
+ integer knteig;
+ extern logical dlctes_(doublereal *, doublereal *, doublereal *);
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *), dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ integer minwrk, maxwrk;
+ doublereal ulpinv;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9990, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRGES checks the nonsymmetric generalized eigenvalue (Schur form) */
+/* problem driver DGGES. */
+
+/* DGGES factors A and B as Q S Z' and Q T Z' , where ' means */
+/* transpose, T is upper triangular, S is in generalized Schur form */
+/* (block upper triangular, with 1x1 and 2x2 blocks on the diagonal, */
+/* the 2x2 blocks corresponding to complex conjugate pairs of */
+/* generalized eigenvalues), and Q and Z are orthogonal. It also */
+/* computes the generalized eigenvalues (alpha(j),beta(j)), j=1,...,n, */
+/* Thus, w(j) = alpha(j)/beta(j) is a root of the characteristic */
+/* equation */
+/* det( A - w(j) B ) = 0 */
+/* Optionally it also reorder the eigenvalues so that a selected */
+/* cluster of eigenvalues appears in the leading diagonal block of the */
+/* Schur forms. */
+
+/* When DDRGES is called, a number of matrix "sizes" ("N's") and a */
+/* number of matrix "TYPES" are specified. For each size ("N") */
+/* and each TYPE of matrix, a pair of matrices (A, B) will be generated */
+/* and used for testing. For each matrix pair, the following 13 tests */
+/* will be performed and compared with the threshhold THRESH except */
+/* the tests (5), (11) and (13). */
+
+
+/* (1) | A - Q S Z' | / ( |A| n ulp ) (no sorting of eigenvalues) */
+
+
+/* (2) | B - Q T Z' | / ( |B| n ulp ) (no sorting of eigenvalues) */
+
+
+/* (3) | I - QQ' | / ( n ulp ) (no sorting of eigenvalues) */
+
+
+/* (4) | I - ZZ' | / ( n ulp ) (no sorting of eigenvalues) */
+
+/* (5) if A is in Schur form (i.e. quasi-triangular form) */
+/* (no sorting of eigenvalues) */
+
+/* (6) if eigenvalues = diagonal blocks of the Schur form (S, T), */
+/* i.e., test the maximum over j of D(j) where: */
+
+/* if alpha(j) is real: */
+/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
+/* D(j) = ------------------------ + ----------------------- */
+/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
+
+/* if alpha(j) is complex: */
+/* | det( s S - w T ) | */
+/* D(j) = --------------------------------------------------- */
+/* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T ) */
+
+/* and S and T are here the 2 x 2 diagonal blocks of S and T */
+/* corresponding to the j-th and j+1-th eigenvalues. */
+/* (no sorting of eigenvalues) */
+
+/* (7) | (A,B) - Q (S,T) Z' | / ( | (A,B) | n ulp ) */
+/* (with sorting of eigenvalues). */
+
+/* (8) | I - QQ' | / ( n ulp ) (with sorting of eigenvalues). */
+
+/* (9) | I - ZZ' | / ( n ulp ) (with sorting of eigenvalues). */
+
+/* (10) if A is in Schur form (i.e. quasi-triangular form) */
+/* (with sorting of eigenvalues). */
+
+/* (11) if eigenvalues = diagonal blocks of the Schur form (S, T), */
+/* i.e. test the maximum over j of D(j) where: */
+
+/* if alpha(j) is real: */
+/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
+/* D(j) = ------------------------ + ----------------------- */
+/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
+
+/* if alpha(j) is complex: */
+/* | det( s S - w T ) | */
+/* D(j) = --------------------------------------------------- */
+/* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T ) */
+
+/* and S and T are here the 2 x 2 diagonal blocks of S and T */
+/* corresponding to the j-th and j+1-th eigenvalues. */
+/* (with sorting of eigenvalues). */
+
+/* (12) if sorting worked and SDIM is the number of eigenvalues */
+/* which were SELECTed. */
+
+/* Test Matrices */
+/* ============= */
+
+/* The sizes of the test matrices are specified by an array */
+/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
+/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) ( 0, 0 ) (a pair of zero matrices) */
+
+/* (2) ( I, 0 ) (an identity and a zero matrix) */
+
+/* (3) ( 0, I ) (an identity and a zero matrix) */
+
+/* (4) ( I, I ) (a pair of identity matrices) */
+
+/* t t */
+/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
+
+/* t ( I 0 ) */
+/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
+/* ( 0 I ) ( 0 J ) */
+/* and I is a k x k identity and J a (k+1)x(k+1) */
+/* Jordan block; k=(N-1)/2 */
+
+/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
+/* matrix with those diagonal entries.) */
+/* (8) ( I, D ) */
+
+/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
+
+/* (10) ( small*D, big*I ) */
+
+/* (11) ( big*I, small*D ) */
+
+/* (12) ( small*I, big*D ) */
+
+/* (13) ( big*D, big*I ) */
+
+/* (14) ( small*D, small*I ) */
+
+/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
+/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
+/* t t */
+/* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. */
+
+/* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices */
+/* with random O(1) entries above the diagonal */
+/* and diagonal entries diag(T1) = */
+/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
+/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
+
+/* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
+/* s = machine precision. */
+
+/* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
+
+/* N-5 */
+/* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+
+/* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+/* where r1,..., r(N-4) are random. */
+
+/* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular */
+/* matrices. */
+
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* DDRGES does nothing. NSIZES >= 0. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. NN >= 0. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, DDRGES */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A on input. */
+/* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to DDRGES to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error is */
+/* scaled to be O(1), so THRESH should be a reasonably small */
+/* multiple of 1, e.g., 10 or 100. In particular, it should */
+/* not depend on the precision (single vs. double) or the size */
+/* of the matrix. THRESH >= 0. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace) DOUBLE PRECISION array, */
+/* dimension(LDA, max(NN)) */
+/* Used to hold the original A matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, S, and T. */
+/* It must be at least 1 and at least max( NN ). */
+
+/* B (input/workspace) DOUBLE PRECISION array, */
+/* dimension(LDA, max(NN)) */
+/* Used to hold the original B matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* S (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) */
+/* The Schur form matrix computed from A by DGGES. On exit, S */
+/* contains the Schur form matrix corresponding to the matrix */
+/* in A. */
+
+/* T (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from B by DGGES. */
+
+/* Q (workspace) DOUBLE PRECISION array, dimension (LDQ, max(NN)) */
+/* The (left) orthogonal matrix computed by DGGES. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of Q and Z. It must */
+/* be at least 1 and at least max( NN ). */
+
+/* Z (workspace) DOUBLE PRECISION array, dimension( LDQ, max(NN) ) */
+/* The (right) orthogonal matrix computed by DGGES. */
+
+/* ALPHAR (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* ALPHAI (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* BETA (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* The generalized eigenvalues of (A,B) computed by DGGES. */
+/* ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th */
+/* generalized eigenvalue of A and B. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* LWORK >= MAX( 10*(N+1), 3*N*N ), where N is the largest */
+/* matrix dimension. */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (15) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid overflow. */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: A routine returned an error code. INFO is the */
+/* absolute value of the INFO value returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ t_dim1 = *lda;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ s_dim1 = *lda;
+ s_offset = 1 + s_dim1;
+ s -= s_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ z_dim1 = *ldq;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ --work;
+ --result;
+ --bwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.) {
+ *info = -6;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldq <= 1 || *ldq < nmax) {
+ *info = -14;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. */
+
+ minwrk = 1;
+ if (*info == 0 && *lwork >= 1) {
+/* Computing MAX */
+ i__1 = (nmax + 1) * 10, i__2 = nmax * 3 * nmax;
+ minwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = ilaenv_(&c__1, "DGEQRF", " ", &nmax, &nmax, &c_n1, &
+ c_n1), i__1 = max(i__1,i__2), i__2 =
+ ilaenv_(&c__1, "DORMQR", "LT", &nmax, &nmax, &nmax, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
+ c__1, "DORGQR", " ", &nmax, &nmax, &nmax, &c_n1);
+ nb = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = (nmax + 1) * 10, i__2 = (nmax << 1) + nmax * nb, i__1 = max(
+ i__1,i__2), i__2 = nmax * 3 * nmax;
+ maxwrk = max(i__1,i__2);
+ work[1] = (doublereal) maxwrk;
+ }
+
+ if (*lwork < minwrk) {
+ *info = -20;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DDRGES", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+ safmin = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ safmin /= ulp;
+ safmax = 1. / safmin;
+ dlabad_(&safmin, &safmax);
+ ulpinv = 1. / ulp;
+
+/* The values RMAGN(2:3) depend on N, see below. */
+
+ rmagn[0] = 0.;
+ rmagn[1] = 1.;
+
+/* Loop over matrix sizes */
+
+ ntestt = 0;
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ n1 = max(1,n);
+ rmagn[2] = safmax * ulp / (doublereal) n1;
+ rmagn[3] = safmin * ulpinv * (doublereal) n1;
+
+ if (*nsizes != 1) {
+ mtypes = min(26,*ntypes);
+ } else {
+ mtypes = min(27,*ntypes);
+ }
+
+/* Loop over matrix types */
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L180;
+ }
+ ++nmats;
+ ntest = 0;
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 13; ++j) {
+ result[j] = 0.;
+/* L30: */
+ }
+
+/* Generate test matrices A and B */
+
+/* Description of control parameters: */
+
+/* KZLASS: =1 means w/o rotation, =2 means w/ rotation, */
+/* =3 means random. */
+/* KATYPE: the "type" to be passed to DLATM4 for computing A. */
+/* KAZERO: the pattern of zeros on the diagonal for A: */
+/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
+/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
+/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
+/* non-zero entries.) */
+/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
+/* =2: large, =3: small. */
+/* IASIGN: 1 if the diagonal elements of A are to be */
+/* multiplied by a random magnitude 1 number, =2 if */
+/* randomly chosen diagonal blocks are to be rotated */
+/* to form 2x2 blocks. */
+/* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B. */
+/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
+/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
+/* RMAGN: used to implement KAMAGN and KBMAGN. */
+
+ if (mtypes > 26) {
+ goto L110;
+ }
+ iinfo = 0;
+ if (kclass[jtype - 1] < 3) {
+
+/* Generate A (w/o rotation) */
+
+ if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ dlaset_("Full", &n, &n, &c_b26, &c_b26, &a[a_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ dlatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
+ &kz2[kazero[jtype - 1] - 1], &iasign[jtype - 1], &
+ rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
+ 1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
+ a_offset], lda);
+ iadd = kadd[kazero[jtype - 1] - 1];
+ if (iadd > 0 && iadd <= n) {
+ a[iadd + iadd * a_dim1] = 1.;
+ }
+
+/* Generate B (w/o rotation) */
+
+ if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ dlaset_("Full", &n, &n, &c_b26, &c_b26, &b[b_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ dlatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
+ &kz2[kbzero[jtype - 1] - 1], &ibsign[jtype - 1], &
+ rmagn[kbmagn[jtype - 1]], &c_b32, &rmagn[ktrian[jtype
+ - 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
+ b_offset], lda);
+ iadd = kadd[kbzero[jtype - 1] - 1];
+ if (iadd != 0 && iadd <= n) {
+ b[iadd + iadd * b_dim1] = 1.;
+ }
+
+ if (kclass[jtype - 1] == 2 && n > 0) {
+
+/* Include rotations */
+
+/* Generate Q, Z as Householder transformations times */
+/* a diagonal matrix. */
+
+ i__3 = n - 1;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = jc; jr <= i__4; ++jr) {
+ q[jr + jc * q_dim1] = dlarnd_(&c__3, &iseed[1]);
+ z__[jr + jc * z_dim1] = dlarnd_(&c__3, &iseed[1]);
+/* L40: */
+ }
+ i__4 = n + 1 - jc;
+ dlarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc *
+ q_dim1], &c__1, &work[jc]);
+ work[(n << 1) + jc] = d_sign(&c_b32, &q[jc + jc *
+ q_dim1]);
+ q[jc + jc * q_dim1] = 1.;
+ i__4 = n + 1 - jc;
+ dlarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 +
+ jc * z_dim1], &c__1, &work[n + jc]);
+ work[n * 3 + jc] = d_sign(&c_b32, &z__[jc + jc *
+ z_dim1]);
+ z__[jc + jc * z_dim1] = 1.;
+/* L50: */
+ }
+ q[n + n * q_dim1] = 1.;
+ work[n] = 0.;
+ d__1 = dlarnd_(&c__2, &iseed[1]);
+ work[n * 3] = d_sign(&c_b32, &d__1);
+ z__[n + n * z_dim1] = 1.;
+ work[n * 2] = 0.;
+ d__1 = dlarnd_(&c__2, &iseed[1]);
+ work[n * 4] = d_sign(&c_b32, &d__1);
+
+/* Apply the diagonal matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ a[jr + jc * a_dim1] = work[(n << 1) + jr] * work[
+ n * 3 + jc] * a[jr + jc * a_dim1];
+ b[jr + jc * b_dim1] = work[(n << 1) + jr] * work[
+ n * 3 + jc] * b[jr + jc * b_dim1];
+/* L60: */
+ }
+/* L70: */
+ }
+ i__3 = n - 1;
+ dorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ dorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &a[a_offset], lda, &work[(n << 1) +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ dorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &b[b_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ dorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &b[b_offset], lda, &work[(n << 1) +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ }
+ } else {
+
+/* Random matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ a[jr + jc * a_dim1] = rmagn[kamagn[jtype - 1]] *
+ dlarnd_(&c__2, &iseed[1]);
+ b[jr + jc * b_dim1] = rmagn[kbmagn[jtype - 1]] *
+ dlarnd_(&c__2, &iseed[1]);
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+
+L100:
+
+ if (iinfo != 0) {
+ io___40.ciunit = *nounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L110:
+
+ for (i__ = 1; i__ <= 13; ++i__) {
+ result[i__] = -1.;
+/* L120: */
+ }
+
+/* Test with and without sorting of eigenvalues */
+
+ for (isort = 0; isort <= 1; ++isort) {
+ if (isort == 0) {
+ *(unsigned char *)sort = 'N';
+ rsub = 0;
+ } else {
+ *(unsigned char *)sort = 'S';
+ rsub = 5;
+ }
+
+/* Call DGGES to compute H, T, Q, Z, alpha, and beta. */
+
+ dlacpy_("Full", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ dlacpy_("Full", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ ntest = rsub + 1 + isort;
+ result[rsub + 1 + isort] = ulpinv;
+ dgges_("V", "V", sort, (L_fp)dlctes_, &n, &s[s_offset], lda, &
+ t[t_offset], lda, &sdim, &alphar[1], &alphai[1], &
+ beta[1], &q[q_offset], ldq, &z__[z_offset], ldq, &
+ work[1], lwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != n + 2) {
+ result[rsub + 1 + isort] = ulpinv;
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, "DGGES", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L160;
+ }
+
+ ntest = rsub + 4;
+
+/* Do tests 1--4 (or tests 7--9 when reordering ) */
+
+ if (isort == 0) {
+ dget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, &
+ q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
+ result[1]);
+ dget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &
+ q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
+ result[2]);
+ } else {
+ dget54_(&n, &a[a_offset], lda, &b[b_offset], lda, &s[
+ s_offset], lda, &t[t_offset], lda, &q[q_offset],
+ ldq, &z__[z_offset], ldq, &work[1], &result[7]);
+ }
+ dget51_(&c__3, &n, &a[a_offset], lda, &t[t_offset], lda, &q[
+ q_offset], ldq, &q[q_offset], ldq, &work[1], &result[
+ rsub + 3]);
+ dget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[
+ z_offset], ldq, &z__[z_offset], ldq, &work[1], &
+ result[rsub + 4]);
+
+/* Do test 5 and 6 (or Tests 10 and 11 when reordering): */
+/* check Schur form of A and compare eigenvalues with */
+/* diagonals. */
+
+ ntest = rsub + 6;
+ temp1 = 0.;
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ ilabad = FALSE_;
+ if (alphai[j] == 0.) {
+/* Computing MAX */
+ d__7 = safmin, d__8 = (d__2 = alphar[j], abs(d__2)),
+ d__7 = max(d__7,d__8), d__8 = (d__3 = s[j + j
+ * s_dim1], abs(d__3));
+/* Computing MAX */
+ d__9 = safmin, d__10 = (d__5 = beta[j], abs(d__5)),
+ d__9 = max(d__9,d__10), d__10 = (d__6 = t[j +
+ j * t_dim1], abs(d__6));
+ temp2 = ((d__1 = alphar[j] - s[j + j * s_dim1], abs(
+ d__1)) / max(d__7,d__8) + (d__4 = beta[j] - t[
+ j + j * t_dim1], abs(d__4)) / max(d__9,d__10))
+ / ulp;
+
+ if (j < n) {
+ if (s[j + 1 + j * s_dim1] != 0.) {
+ ilabad = TRUE_;
+ result[rsub + 5] = ulpinv;
+ }
+ }
+ if (j > 1) {
+ if (s[j + (j - 1) * s_dim1] != 0.) {
+ ilabad = TRUE_;
+ result[rsub + 5] = ulpinv;
+ }
+ }
+
+ } else {
+ if (alphai[j] > 0.) {
+ i1 = j;
+ } else {
+ i1 = j - 1;
+ }
+ if (i1 <= 0 || i1 >= n) {
+ ilabad = TRUE_;
+ } else if (i1 < n - 1) {
+ if (s[i1 + 2 + (i1 + 1) * s_dim1] != 0.) {
+ ilabad = TRUE_;
+ result[rsub + 5] = ulpinv;
+ }
+ } else if (i1 > 1) {
+ if (s[i1 + (i1 - 1) * s_dim1] != 0.) {
+ ilabad = TRUE_;
+ result[rsub + 5] = ulpinv;
+ }
+ }
+ if (! ilabad) {
+ dget53_(&s[i1 + i1 * s_dim1], lda, &t[i1 + i1 *
+ t_dim1], lda, &beta[j], &alphar[j], &
+ alphai[j], &temp2, &ierr);
+ if (ierr >= 3) {
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ *info = abs(ierr);
+ }
+ } else {
+ temp2 = ulpinv;
+ }
+
+ }
+ temp1 = max(temp1,temp2);
+ if (ilabad) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+/* L130: */
+ }
+ result[rsub + 6] = temp1;
+
+ if (isort >= 1) {
+
+/* Do test 12 */
+
+ ntest = 12;
+ result[12] = 0.;
+ knteig = 0;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d__1 = -alphai[i__];
+ if (dlctes_(&alphar[i__], &alphai[i__], &beta[i__]) ||
+ dlctes_(&alphar[i__], &d__1, &beta[i__])) {
+ ++knteig;
+ }
+ if (i__ < n) {
+ d__1 = -alphai[i__ + 1];
+ d__2 = -alphai[i__];
+ if ((dlctes_(&alphar[i__ + 1], &alphai[i__ + 1], &
+ beta[i__ + 1]) || dlctes_(&alphar[i__ + 1]
+, &d__1, &beta[i__ + 1])) && ! (dlctes_(&
+ alphar[i__], &alphai[i__], &beta[i__]) ||
+ dlctes_(&alphar[i__], &d__2, &beta[i__]))
+ && iinfo != n + 2) {
+ result[12] = ulpinv;
+ }
+ }
+/* L140: */
+ }
+ if (sdim != knteig) {
+ result[12] = ulpinv;
+ }
+ }
+
+/* L150: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L160:
+
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__3 = ntest;
+ for (jr = 1; jr <= i__3; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+ do_fio(&c__1, "DGS", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ e_wsfe();
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ e_wsfe();
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ do_fio(&c__1, "Orthogonal", (ftnlen)10);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, "orthogonal", (ftnlen)10);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ for (j = 1; j <= 8; ++j) {
+ do_fio(&c__1, "'", (ftnlen)1);
+ }
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[jr] < 1e4) {
+ io___60.ciunit = *nounit;
+ s_wsfe(&io___60);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ } else {
+ io___61.ciunit = *nounit;
+ s_wsfe(&io___61);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+ }
+/* L170: */
+ }
+
+L180:
+ ;
+ }
+/* L190: */
+ }
+
+/* Summary */
+
+ alasvm_("DGS", nounit, &nerrs, &ntestt, &c__0);
+
+ work[1] = (doublereal) maxwrk;
+
+ return 0;
+
+
+
+
+
+
+
+
+/* End of DDRGES */
+
+} /* ddrges_ */
diff --git a/TESTING/EIG/ddrgev.c b/TESTING/EIG/ddrgev.c
new file mode 100644
index 0000000..3856863
--- /dev/null
+++ b/TESTING/EIG/ddrgev.c
@@ -0,0 +1,1070 @@
+/* ddrgev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static doublereal c_b17 = 0.;
+static integer c__2 = 2;
+static doublereal c_b23 = 1.;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int ddrgev_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
+ doublereal *a, integer *lda, doublereal *b, doublereal *s, doublereal
+ *t, doublereal *q, integer *ldq, doublereal *z__, doublereal *qe,
+ integer *ldqe, doublereal *alphar, doublereal *alphai, doublereal *
+ beta, doublereal *alphr1, doublereal *alphi1, doublereal *beta1,
+ doublereal *work, integer *lwork, doublereal *result, integer *info)
+{
+ /* Initialized data */
+
+ static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
+ 2,2,2,3 };
+ static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
+ 2,3,2,1 };
+ static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
+ 1,1,1,1 };
+ static integer iasign[26] = { 0,0,0,0,0,0,2,0,2,2,0,0,2,2,2,0,2,0,0,0,2,2,
+ 2,2,2,0 };
+ static integer ibsign[26] = { 0,0,0,0,0,0,0,2,0,0,2,2,0,0,2,0,2,0,0,0,0,0,
+ 0,0,0,0 };
+ static integer kz1[6] = { 0,1,2,1,3,3 };
+ static integer kz2[6] = { 0,0,1,2,1,1 };
+ static integer kadd[6] = { 0,0,0,0,3,2 };
+ static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
+ 4,4,4,0 };
+ static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
+ 8,8,8,8,8,0 };
+ static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
+ 3,3,3,1 };
+ static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
+ 4,4,4,1 };
+ static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
+ 3,3,2,1 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 DDRGEV: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/3x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,4(i4,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 DDRGEV: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,3x,\002N=\002,i4,\002, JTYPE=\002,"
+ "i3,\002, ISEED=(\002,4(i4,\002,\002),i5,\002)\002)";
+ static char fmt_9997[] = "(/1x,a3,\002 -- Real Generalized eigenvalue pr"
+ "oblem driver\002)";
+ static char fmt_9996[] = "(\002 Matrix types (see DDRGEV for details):"
+ " \002)";
+ static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
+ "osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
+ ") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
+ "onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
+ "I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
+ "arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
+ "(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
+ "=(D, reversed D)\002)";
+ static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
+ "atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
+ " 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
+ "ha&beta \002,\002 20=arithmetic alpha, beta=0,"
+ "1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
+ "=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
+ "/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
+ "l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
+ ".\002)";
+ static char fmt_9993[] = "(/\002 Tests performed: \002,/\002 1 = max "
+ "| ( b A - a B )'*l | / const.,\002,/\002 2 = | |VR(i)| - 1 | / u"
+ "lp,\002,/\002 3 = max | ( b A - a B )*r | / const.\002,/\002 4 ="
+ " | |VL(i)| - 1 | / ulp,\002,/\002 5 = 0 if W same no matter if r"
+ " or l computed,\002,/\002 6 = 0 if l same no matter if l compute"
+ "d,\002,/\002 7 = 0 if r same no matter if r computed,\002,/1x)";
+ static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",0p,f8.2)";
+ static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",1p,d10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, qe_dim1,
+ qe_offset, s_dim1, s_offset, t_dim1, t_offset, z_dim1, z_offset,
+ i__1, i__2, i__3, i__4;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, n, n1, jc, in, jr;
+ doublereal ulp;
+ integer iadd, ierr, nmax;
+ logical badnn;
+ extern /* Subroutine */ int dget52_(logical *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *), dggev_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, integer *);
+ doublereal rmagn[4];
+ integer nmats, jsize, nerrs, jtype;
+ extern /* Subroutine */ int dlatm4_(integer *, integer *, integer *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, integer *), dorm2r_(char *,
+ char *, integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *), dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *);
+ extern doublereal dlarnd_(integer *, integer *);
+ doublereal safmin;
+ integer ioldsd[4];
+ doublereal safmax;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ alasvm_(char *, integer *, integer *, integer *, integer *), dlaset_(char *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *), xerbla_(char *,
+ integer *);
+ integer minwrk, maxwrk;
+ doublereal ulpinv;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___38 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9991, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRGEV checks the nonsymmetric generalized eigenvalue problem driver */
+/* routine DGGEV. */
+
+/* DGGEV computes for a pair of n-by-n nonsymmetric matrices (A,B) the */
+/* generalized eigenvalues and, optionally, the left and right */
+/* eigenvectors. */
+
+/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w */
+/* or a ratio alpha/beta = w, such that A - w*B is singular. It is */
+/* usually represented as the pair (alpha,beta), as there is reasonalbe */
+/* interpretation for beta=0, and even for both being zero. */
+
+/* A right generalized eigenvector corresponding to a generalized */
+/* eigenvalue w for a pair of matrices (A,B) is a vector r such that */
+/* (A - wB) * r = 0. A left generalized eigenvector is a vector l such */
+/* that l**H * (A - wB) = 0, where l**H is the conjugate-transpose of l. */
+
+/* When DDRGEV is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, a pair of matrices (A, B) will be generated */
+/* and used for testing. For each matrix pair, the following tests */
+/* will be performed and compared with the threshhold THRESH. */
+
+/* Results from DGGEV: */
+
+/* (1) max over all left eigenvalue/-vector pairs (alpha/beta,l) of */
+
+/* | VL**H * (beta A - alpha B) |/( ulp max(|beta A|, |alpha B|) ) */
+
+/* where VL**H is the conjugate-transpose of VL. */
+
+/* (2) | |VL(i)| - 1 | / ulp and whether largest component real */
+
+/* VL(i) denotes the i-th column of VL. */
+
+/* (3) max over all left eigenvalue/-vector pairs (alpha/beta,r) of */
+
+/* | (beta A - alpha B) * VR | / ( ulp max(|beta A|, |alpha B|) ) */
+
+/* (4) | |VR(i)| - 1 | / ulp and whether largest component real */
+
+/* VR(i) denotes the i-th column of VR. */
+
+/* (5) W(full) = W(partial) */
+/* W(full) denotes the eigenvalues computed when both l and r */
+/* are also computed, and W(partial) denotes the eigenvalues */
+/* computed when only W, only W and r, or only W and l are */
+/* computed. */
+
+/* (6) VL(full) = VL(partial) */
+/* VL(full) denotes the left eigenvectors computed when both l */
+/* and r are computed, and VL(partial) denotes the result */
+/* when only l is computed. */
+
+/* (7) VR(full) = VR(partial) */
+/* VR(full) denotes the right eigenvectors computed when both l */
+/* and r are also computed, and VR(partial) denotes the result */
+/* when only l is computed. */
+
+
+/* Test Matrices */
+/* ---- -------- */
+
+/* The sizes of the test matrices are specified by an array */
+/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
+/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) ( 0, 0 ) (a pair of zero matrices) */
+
+/* (2) ( I, 0 ) (an identity and a zero matrix) */
+
+/* (3) ( 0, I ) (an identity and a zero matrix) */
+
+/* (4) ( I, I ) (a pair of identity matrices) */
+
+/* t t */
+/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
+
+/* t ( I 0 ) */
+/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
+/* ( 0 I ) ( 0 J ) */
+/* and I is a k x k identity and J a (k+1)x(k+1) */
+/* Jordan block; k=(N-1)/2 */
+
+/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
+/* matrix with those diagonal entries.) */
+/* (8) ( I, D ) */
+
+/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
+
+/* (10) ( small*D, big*I ) */
+
+/* (11) ( big*I, small*D ) */
+
+/* (12) ( small*I, big*D ) */
+
+/* (13) ( big*D, big*I ) */
+
+/* (14) ( small*D, small*I ) */
+
+/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
+/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
+/* t t */
+/* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. */
+
+/* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices */
+/* with random O(1) entries above the diagonal */
+/* and diagonal entries diag(T1) = */
+/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
+/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
+
+/* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
+/* s = machine precision. */
+
+/* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
+
+/* N-5 */
+/* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+
+/* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+/* where r1,..., r(N-4) are random. */
+
+/* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular */
+/* matrices. */
+
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* DDRGES does nothing. NSIZES >= 0. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. NN >= 0. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, DDRGES */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to DDRGES to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error is */
+/* scaled to be O(1), so THRESH should be a reasonably small */
+/* multiple of 1, e.g., 10 or 100. In particular, it should */
+/* not depend on the precision (single vs. double) or the size */
+/* of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IERR not equal to 0.) */
+
+/* A (input/workspace) DOUBLE PRECISION array, */
+/* dimension(LDA, max(NN)) */
+/* Used to hold the original A matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, S, and T. */
+/* It must be at least 1 and at least max( NN ). */
+
+/* B (input/workspace) DOUBLE PRECISION array, */
+/* dimension(LDA, max(NN)) */
+/* Used to hold the original B matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* S (workspace) DOUBLE PRECISION array, */
+/* dimension (LDA, max(NN)) */
+/* The Schur form matrix computed from A by DGGES. On exit, S */
+/* contains the Schur form matrix corresponding to the matrix */
+/* in A. */
+
+/* T (workspace) DOUBLE PRECISION array, */
+/* dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from B by DGGES. */
+
+/* Q (workspace) DOUBLE PRECISION array, */
+/* dimension (LDQ, max(NN)) */
+/* The (left) eigenvectors matrix computed by DGGEV. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of Q and Z. It must */
+/* be at least 1 and at least max( NN ). */
+
+/* Z (workspace) DOUBLE PRECISION array, dimension( LDQ, max(NN) ) */
+/* The (right) orthogonal matrix computed by DGGES. */
+
+/* QE (workspace) DOUBLE PRECISION array, dimension( LDQ, max(NN) ) */
+/* QE holds the computed right or left eigenvectors. */
+
+/* LDQE (input) INTEGER */
+/* The leading dimension of QE. LDQE >= max(1,max(NN)). */
+
+/* ALPHAR (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* ALPHAI (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* BETA (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* The generalized eigenvalues of (A,B) computed by DGGEV. */
+/* ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th */
+/* generalized eigenvalue of A and B. */
+
+/* ALPHR1 (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* ALPHI1 (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* BETA1 (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* Like ALPHAR, ALPHAI, BETA, these arrays contain the */
+/* eigenvalues of A and B, but those computed when DGGEV only */
+/* computes a partial eigendecomposition, i.e. not the */
+/* eigenvalues and left and right eigenvectors. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. LWORK >= MAX( 8*N, N*(N+1) ). */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid overflow. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: A routine returned an error code. INFO is the */
+/* absolute value of the INFO value returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ t_dim1 = *lda;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ s_dim1 = *lda;
+ s_offset = 1 + s_dim1;
+ s -= s_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ z_dim1 = *ldq;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ qe_dim1 = *ldqe;
+ qe_offset = 1 + qe_dim1;
+ qe -= qe_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ --alphr1;
+ --alphi1;
+ --beta1;
+ --work;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.) {
+ *info = -6;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldq <= 1 || *ldq < nmax) {
+ *info = -14;
+ } else if (*ldqe <= 1 || *ldqe < nmax) {
+ *info = -17;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. */
+
+ minwrk = 1;
+ if (*info == 0 && *lwork >= 1) {
+/* Computing MAX */
+ i__1 = 1, i__2 = nmax << 3, i__1 = max(i__1,i__2), i__2 = nmax * (
+ nmax + 1);
+ minwrk = max(i__1,i__2);
+ maxwrk = nmax * 7 + nmax * ilaenv_(&c__1, "DGEQRF", " ", &nmax, &c__1,
+ &nmax, &c__0);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = nmax * (nmax + 1);
+ maxwrk = max(i__1,i__2);
+ work[1] = (doublereal) maxwrk;
+ }
+
+ if (*lwork < minwrk) {
+ *info = -25;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DDRGEV", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+ safmin = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ safmin /= ulp;
+ safmax = 1. / safmin;
+ dlabad_(&safmin, &safmax);
+ ulpinv = 1. / ulp;
+
+/* The values RMAGN(2:3) depend on N, see below. */
+
+ rmagn[0] = 0.;
+ rmagn[1] = 1.;
+
+/* Loop over sizes, types */
+
+ ntestt = 0;
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ n1 = max(1,n);
+ rmagn[2] = safmax * ulp / (doublereal) n1;
+ rmagn[3] = safmin * ulpinv * n1;
+
+ if (*nsizes != 1) {
+ mtypes = min(26,*ntypes);
+ } else {
+ mtypes = min(27,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L210;
+ }
+ ++nmats;
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Generate test matrices A and B */
+
+/* Description of control parameters: */
+
+/* KZLASS: =1 means w/o rotation, =2 means w/ rotation, */
+/* =3 means random. */
+/* KATYPE: the "type" to be passed to DLATM4 for computing A. */
+/* KAZERO: the pattern of zeros on the diagonal for A: */
+/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
+/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
+/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
+/* non-zero entries.) */
+/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
+/* =2: large, =3: small. */
+/* IASIGN: 1 if the diagonal elements of A are to be */
+/* multiplied by a random magnitude 1 number, =2 if */
+/* randomly chosen diagonal blocks are to be rotated */
+/* to form 2x2 blocks. */
+/* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B. */
+/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
+/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
+/* RMAGN: used to implement KAMAGN and KBMAGN. */
+
+ if (mtypes > 26) {
+ goto L100;
+ }
+ ierr = 0;
+ if (kclass[jtype - 1] < 3) {
+
+/* Generate A (w/o rotation) */
+
+ if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ dlaset_("Full", &n, &n, &c_b17, &c_b17, &a[a_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ dlatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
+ &kz2[kazero[jtype - 1] - 1], &iasign[jtype - 1], &
+ rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
+ 1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
+ a_offset], lda);
+ iadd = kadd[kazero[jtype - 1] - 1];
+ if (iadd > 0 && iadd <= n) {
+ a[iadd + iadd * a_dim1] = 1.;
+ }
+
+/* Generate B (w/o rotation) */
+
+ if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ dlaset_("Full", &n, &n, &c_b17, &c_b17, &b[b_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ dlatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
+ &kz2[kbzero[jtype - 1] - 1], &ibsign[jtype - 1], &
+ rmagn[kbmagn[jtype - 1]], &c_b23, &rmagn[ktrian[jtype
+ - 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
+ b_offset], lda);
+ iadd = kadd[kbzero[jtype - 1] - 1];
+ if (iadd != 0 && iadd <= n) {
+ b[iadd + iadd * b_dim1] = 1.;
+ }
+
+ if (kclass[jtype - 1] == 2 && n > 0) {
+
+/* Include rotations */
+
+/* Generate Q, Z as Householder transformations times */
+/* a diagonal matrix. */
+
+ i__3 = n - 1;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = jc; jr <= i__4; ++jr) {
+ q[jr + jc * q_dim1] = dlarnd_(&c__3, &iseed[1]);
+ z__[jr + jc * z_dim1] = dlarnd_(&c__3, &iseed[1]);
+/* L30: */
+ }
+ i__4 = n + 1 - jc;
+ dlarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc *
+ q_dim1], &c__1, &work[jc]);
+ work[(n << 1) + jc] = d_sign(&c_b23, &q[jc + jc *
+ q_dim1]);
+ q[jc + jc * q_dim1] = 1.;
+ i__4 = n + 1 - jc;
+ dlarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 +
+ jc * z_dim1], &c__1, &work[n + jc]);
+ work[n * 3 + jc] = d_sign(&c_b23, &z__[jc + jc *
+ z_dim1]);
+ z__[jc + jc * z_dim1] = 1.;
+/* L40: */
+ }
+ q[n + n * q_dim1] = 1.;
+ work[n] = 0.;
+ d__1 = dlarnd_(&c__2, &iseed[1]);
+ work[n * 3] = d_sign(&c_b23, &d__1);
+ z__[n + n * z_dim1] = 1.;
+ work[n * 2] = 0.;
+ d__1 = dlarnd_(&c__2, &iseed[1]);
+ work[n * 4] = d_sign(&c_b23, &d__1);
+
+/* Apply the diagonal matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ a[jr + jc * a_dim1] = work[(n << 1) + jr] * work[
+ n * 3 + jc] * a[jr + jc * a_dim1];
+ b[jr + jc * b_dim1] = work[(n << 1) + jr] * work[
+ n * 3 + jc] * b[jr + jc * b_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+ i__3 = n - 1;
+ dorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &a[a_offset], lda, &work[(n << 1) + 1], &ierr);
+ if (ierr != 0) {
+ goto L90;
+ }
+ i__3 = n - 1;
+ dorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &a[a_offset], lda, &work[(n << 1) +
+ 1], &ierr);
+ if (ierr != 0) {
+ goto L90;
+ }
+ i__3 = n - 1;
+ dorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &b[b_offset], lda, &work[(n << 1) + 1], &ierr);
+ if (ierr != 0) {
+ goto L90;
+ }
+ i__3 = n - 1;
+ dorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &b[b_offset], lda, &work[(n << 1) +
+ 1], &ierr);
+ if (ierr != 0) {
+ goto L90;
+ }
+ }
+ } else {
+
+/* Random matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ a[jr + jc * a_dim1] = rmagn[kamagn[jtype - 1]] *
+ dlarnd_(&c__2, &iseed[1]);
+ b[jr + jc * b_dim1] = rmagn[kbmagn[jtype - 1]] *
+ dlarnd_(&c__2, &iseed[1]);
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+
+L90:
+
+ if (ierr != 0) {
+ io___38.ciunit = *nounit;
+ s_wsfe(&io___38);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(ierr);
+ return 0;
+ }
+
+L100:
+
+ for (i__ = 1; i__ <= 7; ++i__) {
+ result[i__] = -1.;
+/* L110: */
+ }
+
+/* Call DGGEV to compute eigenvalues and eigenvectors. */
+
+ dlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ dlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ dggev_("V", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
+ alphar[1], &alphai[1], &beta[1], &q[q_offset], ldq, &z__[
+ z_offset], ldq, &work[1], lwork, &ierr);
+ if (ierr != 0 && ierr != n + 1) {
+ result[1] = ulpinv;
+ io___40.ciunit = *nounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "DGGEV1", (ftnlen)6);
+ do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(ierr);
+ goto L190;
+ }
+
+/* Do the tests (1) and (2) */
+
+ dget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &q[
+ q_offset], ldq, &alphar[1], &alphai[1], &beta[1], &work[1]
+, &result[1]);
+ if (result[2] > *thresh) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "DGGEV1", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Do the tests (3) and (4) */
+
+ dget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &z__[
+ z_offset], ldq, &alphar[1], &alphai[1], &beta[1], &work[1]
+, &result[3]);
+ if (result[4] > *thresh) {
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "DGGEV1", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[4], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Do the test (5) */
+
+ dlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ dlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ dggev_("N", "N", &n, &s[s_offset], lda, &t[t_offset], lda, &
+ alphr1[1], &alphi1[1], &beta1[1], &q[q_offset], ldq, &z__[
+ z_offset], ldq, &work[1], lwork, &ierr);
+ if (ierr != 0 && ierr != n + 1) {
+ result[1] = ulpinv;
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "DGGEV2", (ftnlen)6);
+ do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(ierr);
+ goto L190;
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ if (alphar[j] != alphr1[j] || alphai[j] != alphi1[j] || beta[
+ j] != beta1[j]) {
+ result[5] = ulpinv;
+ }
+/* L120: */
+ }
+
+/* Do the test (6): Compute eigenvalues and left eigenvectors, */
+/* and test them */
+
+ dlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ dlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ dggev_("V", "N", &n, &s[s_offset], lda, &t[t_offset], lda, &
+ alphr1[1], &alphi1[1], &beta1[1], &qe[qe_offset], ldqe, &
+ z__[z_offset], ldq, &work[1], lwork, &ierr);
+ if (ierr != 0 && ierr != n + 1) {
+ result[1] = ulpinv;
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "DGGEV3", (ftnlen)6);
+ do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(ierr);
+ goto L190;
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ if (alphar[j] != alphr1[j] || alphai[j] != alphi1[j] || beta[
+ j] != beta1[j]) {
+ result[6] = ulpinv;
+ }
+/* L130: */
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (jc = 1; jc <= i__4; ++jc) {
+ if (q[j + jc * q_dim1] != qe[j + jc * qe_dim1]) {
+ result[6] = ulpinv;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+/* DO the test (7): Compute eigenvalues and right eigenvectors, */
+/* and test them */
+
+ dlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ dlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ dggev_("N", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
+ alphr1[1], &alphi1[1], &beta1[1], &q[q_offset], ldq, &qe[
+ qe_offset], ldqe, &work[1], lwork, &ierr);
+ if (ierr != 0 && ierr != n + 1) {
+ result[1] = ulpinv;
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "DGGEV4", (ftnlen)6);
+ do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(ierr);
+ goto L190;
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ if (alphar[j] != alphr1[j] || alphai[j] != alphi1[j] || beta[
+ j] != beta1[j]) {
+ result[7] = ulpinv;
+ }
+/* L160: */
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (jc = 1; jc <= i__4; ++jc) {
+ if (z__[j + jc * z_dim1] != qe[j + jc * qe_dim1]) {
+ result[7] = ulpinv;
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L190:
+
+ ntestt += 7;
+
+/* Print out tests which fail. */
+
+ for (jr = 1; jr <= 7; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, "DGV", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ e_wsfe();
+ io___48.ciunit = *nounit;
+ s_wsfe(&io___48);
+ e_wsfe();
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ do_fio(&c__1, "Orthogonal", (ftnlen)10);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[jr] < 1e4) {
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ } else {
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+ }
+/* L200: */
+ }
+
+L210:
+ ;
+ }
+/* L220: */
+ }
+
+/* Summary */
+
+ alasvm_("DGV", nounit, &nerrs, &ntestt, &c__0);
+
+ work[1] = (doublereal) maxwrk;
+
+ return 0;
+
+
+
+
+
+
+
+/* End of DDRGEV */
+
+} /* ddrgev_ */
diff --git a/TESTING/EIG/ddrgsx.c b/TESTING/EIG/ddrgsx.c
new file mode 100644
index 0000000..2ab3d4f
--- /dev/null
+++ b/TESTING/EIG/ddrgsx.c
@@ -0,0 +1,1262 @@
+/* ddrgsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer m, n, mplusn, k;
+ logical fs;
+} mn_;
+
+#define mn_1 mn_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublereal c_b26 = 0.;
+static integer c__3 = 3;
+static integer c__5 = 5;
+
+/* Subroutine */ int ddrgsx_(integer *nsize, integer *ncmax, doublereal *
+ thresh, integer *nin, integer *nout, doublereal *a, integer *lda,
+ doublereal *b, doublereal *ai, doublereal *bi, doublereal *z__,
+ doublereal *q, doublereal *alphar, doublereal *alphai, doublereal *
+ beta, doublereal *c__, integer *ldc, doublereal *s, doublereal *work,
+ integer *lwork, integer *iwork, integer *liwork, logical *bwork,
+ integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 DDRGSX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002)\002)";
+ static char fmt_9997[] = "(\002 DDRGSX: DGET53 returned INFO=\002,i1,"
+ "\002 for eigenvalue \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JT"
+ "YPE=\002,i6,\002)\002)";
+ static char fmt_9996[] = "(\002 DDRGSX: S not in Schur form at eigenvalu"
+ "e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002"
+ ")\002)";
+ static char fmt_9995[] = "(/1x,a3,\002 -- Real Expert Generalized Schur "
+ "form\002,\002 problem driver\002)";
+ static char fmt_9993[] = "(\002 Matrix types: \002,/\002 1: A is a blo"
+ "ck diagonal matrix of Jordan blocks \002,\002and B is the identi"
+ "ty \002,/\002 matrix, \002,/\002 2: A and B are upper tri"
+ "angular matrices, \002,/\002 3: A and B are as type 2, but eac"
+ "h second diagonal \002,\002block in A_11 and \002,/\002 eac"
+ "h third diaongal block in A_22 are 2x2 blocks,\002,/\002 4: A "
+ "and B are block diagonal matrices, \002,/\002 5: (A,B) has pot"
+ "entially close or common \002,\002eigenvalues.\002,/)";
+ static char fmt_9992[] = "(/\002 Tests performed: (S is Schur, T is tri"
+ "angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002 a is al"
+ "pha, b is beta, and \002,a,\002 means \002,a,\002.)\002,/\002 1"
+ " = | A - Q S Z\002,a,\002 | / ( |A| n ulp ) 2 = | B - Q T "
+ "Z\002,a,\002 | / ( |B| n ulp )\002,/\002 3 = | I - QQ\002,a,"
+ "\002 | / ( n ulp ) 4 = | I - ZZ\002,a,\002 | / ( n u"
+ "lp )\002,/\002 5 = 1/ULP if A is not in \002,\002Schur form "
+ "S\002,/\002 6 = difference between (alpha,beta)\002,\002 and di"
+ "agonals of (S,T)\002,/\002 7 = 1/ULP if SDIM is not the correc"
+ "t number of \002,\002selected eigenvalues\002,/\002 8 = 1/ULP "
+ "if DIFEST/DIFTRU > 10*THRESH or \002,\002DIFTRU/DIFEST > 10*THRE"
+ "SH\002,/\002 9 = 1/ULP if DIFEST <> 0 or DIFTRU > ULP*norm(A,B"
+ ") \002,\002when reordering fails\002,/\002 10 = 1/ULP if PLEST/"
+ "PLTRU > THRESH or \002,\002PLTRU/PLEST > THRESH\002,/\002 ( T"
+ "est 10 is only for input examples )\002,/)";
+ static char fmt_9991[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
+ ",\002, a=\002,d10.4,\002, order(A_11)=\002,i2,\002, result \002,"
+ "i2,\002 is \002,0p,f8.2)";
+ static char fmt_9990[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
+ ",\002, a=\002,d10.4,\002, order(A_11)=\002,i2,\002, result \002,"
+ "i2,\002 is \002,0p,d10.4)";
+ static char fmt_9998[] = "(\002 DDRGSX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, Input Example #\002,i2,\002"
+ ")\002)";
+ static char fmt_9994[] = "(\002Input Example\002)";
+ static char fmt_9989[] = "(\002 Input example #\002,i2,\002, matrix orde"
+ "r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,0p,f8.2)";
+ static char fmt_9988[] = "(\002 Input example #\002,i2,\002, matrix orde"
+ "r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,1p,d10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, ai_dim1, ai_offset, b_dim1, b_offset, bi_dim1,
+ bi_offset, c_dim1, c_offset, q_dim1, q_offset, z_dim1, z_offset,
+ i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+
+ /* Local variables */
+ integer i__, j, i1, mm;
+ doublereal pl[2];
+ integer mn2, qba, qbb;
+ doublereal ulp, temp1, temp2;
+ extern /* Subroutine */ int dget51_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *), dget53_(
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ doublereal abnrm;
+ integer ifunc, iinfo, linfo;
+ char sense[1];
+ integer nerrs, ntest;
+ extern /* Subroutine */ int dlakf2_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *);
+ doublereal pltru;
+ extern /* Subroutine */ int dlatm5_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *), dlabad_(
+ doublereal *, doublereal *);
+ doublereal thrsh2;
+ logical ilabad;
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ integer bdspac;
+ extern /* Subroutine */ int dgesvd_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dlacpy_(char *, integer *, integer *, doublereal
+ *, integer *, doublereal *, integer *);
+ doublereal difest[2];
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dggesx_(char *, char *, char *, L_fp, char *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, integer *, logical *, integer
+ *), alasvm_(char *, integer *,
+ integer *, integer *, integer *), xerbla_(char *, integer
+ *);
+ doublereal weight, diftru;
+ extern logical dlctsx_();
+ integer minwrk, maxwrk;
+ doublereal smlnum, ulpinv;
+ integer nptknt;
+ doublereal result[10];
+ integer ntestt, prtype;
+
+ /* Fortran I/O blocks */
+ static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___42 = { 0, 0, 1, 0, 0 };
+ static cilist io___43 = { 0, 0, 1, 0, 0 };
+ static cilist io___44 = { 0, 0, 0, 0, 0 };
+ static cilist io___45 = { 0, 0, 0, 0, 0 };
+ static cilist io___46 = { 0, 0, 0, 0, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9988, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRGSX checks the nonsymmetric generalized eigenvalue (Schur form) */
+/* problem expert driver DGGESX. */
+
+/* DGGESX factors A and B as Q S Z' and Q T Z', where ' means */
+/* transpose, T is upper triangular, S is in generalized Schur form */
+/* (block upper triangular, with 1x1 and 2x2 blocks on the diagonal, */
+/* the 2x2 blocks corresponding to complex conjugate pairs of */
+/* generalized eigenvalues), and Q and Z are orthogonal. It also */
+/* computes the generalized eigenvalues (alpha(1),beta(1)), ..., */
+/* (alpha(n),beta(n)). Thus, w(j) = alpha(j)/beta(j) is a root of the */
+/* characteristic equation */
+
+/* det( A - w(j) B ) = 0 */
+
+/* Optionally it also reorders the eigenvalues so that a selected */
+/* cluster of eigenvalues appears in the leading diagonal block of the */
+/* Schur forms; computes a reciprocal condition number for the average */
+/* of the selected eigenvalues; and computes a reciprocal condition */
+/* number for the right and left deflating subspaces corresponding to */
+/* the selected eigenvalues. */
+
+/* When DDRGSX is called with NSIZE > 0, five (5) types of built-in */
+/* matrix pairs are used to test the routine DGGESX. */
+
+/* When DDRGSX is called with NSIZE = 0, it reads in test matrix data */
+/* to test DGGESX. */
+
+/* For each matrix pair, the following tests will be performed and */
+/* compared with the threshhold THRESH except for the tests (7) and (9): */
+
+/* (1) | A - Q S Z' | / ( |A| n ulp ) */
+
+/* (2) | B - Q T Z' | / ( |B| n ulp ) */
+
+/* (3) | I - QQ' | / ( n ulp ) */
+
+/* (4) | I - ZZ' | / ( n ulp ) */
+
+/* (5) if A is in Schur form (i.e. quasi-triangular form) */
+
+/* (6) maximum over j of D(j) where: */
+
+/* if alpha(j) is real: */
+/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
+/* D(j) = ------------------------ + ----------------------- */
+/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
+
+/* if alpha(j) is complex: */
+/* | det( s S - w T ) | */
+/* D(j) = --------------------------------------------------- */
+/* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T ) */
+
+/* and S and T are here the 2 x 2 diagonal blocks of S and T */
+/* corresponding to the j-th and j+1-th eigenvalues. */
+
+/* (7) if sorting worked and SDIM is the number of eigenvalues */
+/* which were selected. */
+
+/* (8) the estimated value DIF does not differ from the true values of */
+/* Difu and Difl more than a factor 10*THRESH. If the estimate DIF */
+/* equals zero the corresponding true values of Difu and Difl */
+/* should be less than EPS*norm(A, B). If the true value of Difu */
+/* and Difl equal zero, the estimate DIF should be less than */
+/* EPS*norm(A, B). */
+
+/* (9) If INFO = N+3 is returned by DGGESX, the reordering "failed" */
+/* and we check that DIF = PL = PR = 0 and that the true value of */
+/* Difu and Difl is < EPS*norm(A, B). We count the events when */
+/* INFO=N+3. */
+
+/* For read-in test matrices, the above tests are run except that the */
+/* exact value for DIF (and PL) is input data. Additionally, there is */
+/* one more test run for read-in test matrices: */
+
+/* (10) the estimated value PL does not differ from the true value of */
+/* PLTRU more than a factor THRESH. If the estimate PL equals */
+/* zero the corresponding true value of PLTRU should be less than */
+/* EPS*norm(A, B). If the true value of PLTRU equal zero, the */
+/* estimate PL should be less than EPS*norm(A, B). */
+
+/* Note that for the built-in tests, a total of 10*NSIZE*(NSIZE-1) */
+/* matrix pairs are generated and tested. NSIZE should be kept small. */
+
+/* SVD (routine DGESVD) is used for computing the true value of DIF_u */
+/* and DIF_l when testing the built-in test problems. */
+
+/* Built-in Test Matrices */
+/* ====================== */
+
+/* All built-in test matrices are the 2 by 2 block of triangular */
+/* matrices */
+
+/* A = [ A11 A12 ] and B = [ B11 B12 ] */
+/* [ A22 ] [ B22 ] */
+
+/* where for different type of A11 and A22 are given as the following. */
+/* A12 and B12 are chosen so that the generalized Sylvester equation */
+
+/* A11*R - L*A22 = -A12 */
+/* B11*R - L*B22 = -B12 */
+
+/* have prescribed solution R and L. */
+
+/* Type 1: A11 = J_m(1,-1) and A_22 = J_k(1-a,1). */
+/* B11 = I_m, B22 = I_k */
+/* where J_k(a,b) is the k-by-k Jordan block with ``a'' on */
+/* diagonal and ``b'' on superdiagonal. */
+
+/* Type 2: A11 = (a_ij) = ( 2(.5-sin(i)) ) and */
+/* B11 = (b_ij) = ( 2(.5-sin(ij)) ) for i=1,...,m, j=i,...,m */
+/* A22 = (a_ij) = ( 2(.5-sin(i+j)) ) and */
+/* B22 = (b_ij) = ( 2(.5-sin(ij)) ) for i=m+1,...,k, j=i,...,k */
+
+/* Type 3: A11, A22 and B11, B22 are chosen as for Type 2, but each */
+/* second diagonal block in A_11 and each third diagonal block */
+/* in A_22 are made as 2 by 2 blocks. */
+
+/* Type 4: A11 = ( 20(.5 - sin(ij)) ) and B22 = ( 2(.5 - sin(i+j)) ) */
+/* for i=1,...,m, j=1,...,m and */
+/* A22 = ( 20(.5 - sin(i+j)) ) and B22 = ( 2(.5 - sin(ij)) ) */
+/* for i=m+1,...,k, j=m+1,...,k */
+
+/* Type 5: (A,B) and have potentially close or common eigenvalues and */
+/* very large departure from block diagonality A_11 is chosen */
+/* as the m x m leading submatrix of A_1: */
+/* | 1 b | */
+/* | -b 1 | */
+/* | 1+d b | */
+/* | -b 1+d | */
+/* A_1 = | d 1 | */
+/* | -1 d | */
+/* | -d 1 | */
+/* | -1 -d | */
+/* | 1 | */
+/* and A_22 is chosen as the k x k leading submatrix of A_2: */
+/* | -1 b | */
+/* | -b -1 | */
+/* | 1-d b | */
+/* | -b 1-d | */
+/* A_2 = | d 1+b | */
+/* | -1-b d | */
+/* | -d 1+b | */
+/* | -1+b -d | */
+/* | 1-d | */
+/* and matrix B are chosen as identity matrices (see DLATM5). */
+
+
+/* Arguments */
+/* ========= */
+
+/* NSIZE (input) INTEGER */
+/* The maximum size of the matrices to use. NSIZE >= 0. */
+/* If NSIZE = 0, no built-in tests matrices are used, but */
+/* read-in test matrices are used to test DGGESX. */
+
+/* NCMAX (input) INTEGER */
+/* Maximum allowable NMAX for generating Kroneker matrix */
+/* in call to DLAKF2 */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. THRESH >= 0. */
+
+/* NIN (input) INTEGER */
+/* The FORTRAN unit number for reading in the data file of */
+/* problems to solve. */
+
+/* NOUT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
+/* Used to store the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, AI, BI, Z and Q, */
+/* LDA >= max( 1, NSIZE ). For the read-in test, */
+/* LDA >= max( 1, N ), N is the size of the test matrices. */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
+/* Used to store the matrix whose eigenvalues are to be */
+/* computed. On exit, B contains the last matrix actually used. */
+
+/* AI (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
+/* Copy of A, modified by DGGESX. */
+
+/* BI (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
+/* Copy of B, modified by DGGESX. */
+
+/* Z (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
+/* Z holds the left Schur vectors computed by DGGESX. */
+
+/* Q (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
+/* Q holds the right Schur vectors computed by DGGESX. */
+
+/* ALPHAR (workspace) DOUBLE PRECISION array, dimension (NSIZE) */
+/* ALPHAI (workspace) DOUBLE PRECISION array, dimension (NSIZE) */
+/* BETA (workspace) DOUBLE PRECISION array, dimension (NSIZE) */
+/* On exit, (ALPHAR + ALPHAI*i)/BETA are the eigenvalues. */
+
+/* C (workspace) DOUBLE PRECISION array, dimension (LDC, LDC) */
+/* Store the matrix generated by subroutine DLAKF2, this is the */
+/* matrix formed by Kronecker products used for estimating */
+/* DIF. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of C. LDC >= max(1, LDA*LDA/2 ). */
+
+/* S (workspace) DOUBLE PRECISION array, dimension (LDC) */
+/* Singular values of C */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* LWORK >= MAX( 5*NSIZE*NSIZE/2 - 2, 10*(NSIZE+1) ) */
+
+/* IWORK (workspace) INTEGER array, dimension (LIWORK) */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. LIWORK >= NSIZE + 6. */
+
+/* BWORK (workspace) LOGICAL array, dimension (LDA) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: A routine returned an error code. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ /* Parameter adjustments */
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *lda;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ bi_dim1 = *lda;
+ bi_offset = 1 + bi_dim1;
+ bi -= bi_offset;
+ ai_dim1 = *lda;
+ ai_offset = 1 + ai_dim1;
+ ai -= ai_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --s;
+ --work;
+ --iwork;
+ --bwork;
+
+ /* Function Body */
+ if (*nsize < 0) {
+ *info = -1;
+ } else if (*thresh < 0.) {
+ *info = -2;
+ } else if (*nin <= 0) {
+ *info = -3;
+ } else if (*nout <= 0) {
+ *info = -4;
+ } else if (*lda < 1 || *lda < *nsize) {
+ *info = -6;
+ } else if (*ldc < 1 || *ldc < *nsize * *nsize / 2) {
+ *info = -17;
+ } else if (*liwork < *nsize + 6) {
+ *info = -21;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ minwrk = 1;
+ if (*info == 0 && *lwork >= 1) {
+/* Computing MAX */
+ i__1 = (*nsize + 1) * 10, i__2 = *nsize * 5 * *nsize / 2;
+ minwrk = max(i__1,i__2);
+
+/* workspace for sggesx */
+
+ maxwrk = (*nsize + 1) * 9 + *nsize * ilaenv_(&c__1, "DGEQRF", " ",
+ nsize, &c__1, nsize, &c__0);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*nsize + 1) * 9 + *nsize * ilaenv_(&c__1,
+ "DORGQR", " ", nsize, &c__1, nsize, &c_n1);
+ maxwrk = max(i__1,i__2);
+
+/* workspace for dgesvd */
+
+ bdspac = *nsize * 5 * *nsize / 2;
+/* Computing MAX */
+ i__3 = *nsize * *nsize / 2;
+ i__4 = *nsize * *nsize / 2;
+ i__1 = maxwrk, i__2 = *nsize * 3 * *nsize / 2 + *nsize * *nsize *
+ ilaenv_(&c__1, "DGEBRD", " ", &i__3, &i__4, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+ maxwrk = max(maxwrk,bdspac);
+
+ maxwrk = max(maxwrk,minwrk);
+
+ work[1] = (doublereal) maxwrk;
+ }
+
+ if (*lwork < minwrk) {
+ *info = -19;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DDRGSX", &i__1);
+ return 0;
+ }
+
+/* Important constants */
+
+ ulp = dlamch_("P");
+ ulpinv = 1. / ulp;
+ smlnum = dlamch_("S") / ulp;
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ thrsh2 = *thresh * 10.;
+ ntestt = 0;
+ nerrs = 0;
+
+/* Go to the tests for read-in matrix pairs */
+
+ ifunc = 0;
+ if (*nsize == 0) {
+ goto L70;
+ }
+
+/* Test the built-in matrix pairs. */
+/* Loop over different functions (IFUNC) of DGGESX, types (PRTYPE) */
+/* of test matrices, different size (M+N) */
+
+ prtype = 0;
+ qba = 3;
+ qbb = 4;
+ weight = sqrt(ulp);
+
+ for (ifunc = 0; ifunc <= 3; ++ifunc) {
+ for (prtype = 1; prtype <= 5; ++prtype) {
+ i__1 = *nsize - 1;
+ for (mn_1.m = 1; mn_1.m <= i__1; ++mn_1.m) {
+ i__2 = *nsize - mn_1.m;
+ for (mn_1.n = 1; mn_1.n <= i__2; ++mn_1.n) {
+
+ weight = 1. / weight;
+ mn_1.mplusn = mn_1.m + mn_1.n;
+
+/* Generate test matrices */
+
+ mn_1.fs = TRUE_;
+ mn_1.k = 0;
+
+ dlaset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b26, &
+ c_b26, &ai[ai_offset], lda);
+ dlaset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b26, &
+ c_b26, &bi[bi_offset], lda);
+
+ dlatm5_(&prtype, &mn_1.m, &mn_1.n, &ai[ai_offset], lda, &
+ ai[mn_1.m + 1 + (mn_1.m + 1) * ai_dim1], lda, &ai[
+ (mn_1.m + 1) * ai_dim1 + 1], lda, &bi[bi_offset],
+ lda, &bi[mn_1.m + 1 + (mn_1.m + 1) * bi_dim1],
+ lda, &bi[(mn_1.m + 1) * bi_dim1 + 1], lda, &q[
+ q_offset], lda, &z__[z_offset], lda, &weight, &
+ qba, &qbb);
+
+/* Compute the Schur factorization and swapping the */
+/* m-by-m (1,1)-blocks with n-by-n (2,2)-blocks. */
+/* Swapping is accomplished via the function DLCTSX */
+/* which is supplied below. */
+
+ if (ifunc == 0) {
+ *(unsigned char *)sense = 'N';
+ } else if (ifunc == 1) {
+ *(unsigned char *)sense = 'E';
+ } else if (ifunc == 2) {
+ *(unsigned char *)sense = 'V';
+ } else if (ifunc == 3) {
+ *(unsigned char *)sense = 'B';
+ }
+
+ dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
+, lda, &a[a_offset], lda);
+ dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
+, lda, &b[b_offset], lda);
+
+ dggesx_("V", "V", "S", (L_fp)dlctsx_, sense, &mn_1.mplusn,
+ &ai[ai_offset], lda, &bi[bi_offset], lda, &mm, &
+ alphar[1], &alphai[1], &beta[1], &q[q_offset],
+ lda, &z__[z_offset], lda, pl, difest, &work[1],
+ lwork, &iwork[1], liwork, &bwork[1], &linfo);
+
+ if (linfo != 0 && linfo != mn_1.mplusn + 2) {
+ result[0] = ulpinv;
+ io___22.ciunit = *nout;
+ s_wsfe(&io___22);
+ do_fio(&c__1, "DGGESX", (ftnlen)6);
+ do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(integer)
+ );
+ e_wsfe();
+ *info = linfo;
+ goto L30;
+ }
+
+/* Compute the norm(A, B) */
+
+ dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
+, lda, &work[1], &mn_1.mplusn);
+ dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
+, lda, &work[mn_1.mplusn * mn_1.mplusn + 1], &
+ mn_1.mplusn);
+ i__3 = mn_1.mplusn << 1;
+ abnrm = dlange_("Fro", &mn_1.mplusn, &i__3, &work[1], &
+ mn_1.mplusn, &work[1]);
+
+/* Do tests (1) to (4) */
+
+ dget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[
+ ai_offset], lda, &q[q_offset], lda, &z__[z_offset]
+, lda, &work[1], result);
+ dget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[
+ bi_offset], lda, &q[q_offset], lda, &z__[z_offset]
+, lda, &work[1], &result[1]);
+ dget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
+ bi_offset], lda, &q[q_offset], lda, &q[q_offset],
+ lda, &work[1], &result[2]);
+ dget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
+ bi_offset], lda, &z__[z_offset], lda, &z__[
+ z_offset], lda, &work[1], &result[3]);
+ ntest = 4;
+
+/* Do tests (5) and (6): check Schur form of A and */
+/* compare eigenvalues with diagonals. */
+
+ temp1 = 0.;
+ result[4] = 0.;
+ result[5] = 0.;
+
+ i__3 = mn_1.mplusn;
+ for (j = 1; j <= i__3; ++j) {
+ ilabad = FALSE_;
+ if (alphai[j] == 0.) {
+/* Computing MAX */
+ d__7 = smlnum, d__8 = (d__2 = alphar[j], abs(d__2)
+ ), d__7 = max(d__7,d__8), d__8 = (d__3 =
+ ai[j + j * ai_dim1], abs(d__3));
+/* Computing MAX */
+ d__9 = smlnum, d__10 = (d__5 = beta[j], abs(d__5))
+ , d__9 = max(d__9,d__10), d__10 = (d__6 =
+ bi[j + j * bi_dim1], abs(d__6));
+ temp2 = ((d__1 = alphar[j] - ai[j + j * ai_dim1],
+ abs(d__1)) / max(d__7,d__8) + (d__4 =
+ beta[j] - bi[j + j * bi_dim1], abs(d__4))
+ / max(d__9,d__10)) / ulp;
+ if (j < mn_1.mplusn) {
+ if (ai[j + 1 + j * ai_dim1] != 0.) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ }
+ if (j > 1) {
+ if (ai[j + (j - 1) * ai_dim1] != 0.) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ }
+ } else {
+ if (alphai[j] > 0.) {
+ i1 = j;
+ } else {
+ i1 = j - 1;
+ }
+ if (i1 <= 0 || i1 >= mn_1.mplusn) {
+ ilabad = TRUE_;
+ } else if (i1 < mn_1.mplusn - 1) {
+ if (ai[i1 + 2 + (i1 + 1) * ai_dim1] != 0.) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ } else if (i1 > 1) {
+ if (ai[i1 + (i1 - 1) * ai_dim1] != 0.) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ }
+ if (! ilabad) {
+ dget53_(&ai[i1 + i1 * ai_dim1], lda, &bi[i1 +
+ i1 * bi_dim1], lda, &beta[j], &alphar[
+ j], &alphai[j], &temp2, &iinfo);
+ if (iinfo >= 3) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&mn_1.mplusn, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&prtype, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ }
+ } else {
+ temp2 = ulpinv;
+ }
+ }
+ temp1 = max(temp1,temp2);
+ if (ilabad) {
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+/* L10: */
+ }
+ result[5] = temp1;
+ ntest += 2;
+
+/* Test (7) (if sorting worked) */
+
+ result[6] = 0.;
+ if (linfo == mn_1.mplusn + 3) {
+ result[6] = ulpinv;
+ } else if (mm != mn_1.n) {
+ result[6] = ulpinv;
+ }
+ ++ntest;
+
+/* Test (8): compare the estimated value DIF and its */
+/* value. first, compute the exact DIF. */
+
+ result[7] = 0.;
+ mn2 = mm * (mn_1.mplusn - mm) << 1;
+ if (ifunc >= 2 && mn2 <= *ncmax * *ncmax) {
+
+/* Note: for either following two causes, there are */
+/* almost same number of test cases fail the test. */
+
+ i__3 = mn_1.mplusn - mm;
+ dlakf2_(&mm, &i__3, &ai[ai_offset], lda, &ai[mm + 1 +
+ (mm + 1) * ai_dim1], &bi[bi_offset], &bi[mm +
+ 1 + (mm + 1) * bi_dim1], &c__[c_offset], ldc);
+
+ i__3 = *lwork - 2;
+ dgesvd_("N", "N", &mn2, &mn2, &c__[c_offset], ldc, &s[
+ 1], &work[1], &c__1, &work[2], &c__1, &work[3]
+, &i__3, info);
+ diftru = s[mn2];
+
+ if (difest[1] == 0.) {
+ if (diftru > abnrm * ulp) {
+ result[7] = ulpinv;
+ }
+ } else if (diftru == 0.) {
+ if (difest[1] > abnrm * ulp) {
+ result[7] = ulpinv;
+ }
+ } else if (diftru > thrsh2 * difest[1] || diftru *
+ thrsh2 < difest[1]) {
+/* Computing MAX */
+ d__1 = diftru / difest[1], d__2 = difest[1] /
+ diftru;
+ result[7] = max(d__1,d__2);
+ }
+ ++ntest;
+ }
+
+/* Test (9) */
+
+ result[8] = 0.;
+ if (linfo == mn_1.mplusn + 2) {
+ if (diftru > abnrm * ulp) {
+ result[8] = ulpinv;
+ }
+ if (ifunc > 1 && difest[1] != 0.) {
+ result[8] = ulpinv;
+ }
+ if (ifunc == 1 && pl[0] != 0.) {
+ result[8] = ulpinv;
+ }
+ ++ntest;
+ }
+
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ for (j = 1; j <= 9; ++j) {
+ if (result[j - 1] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, "SGX", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, "orthogonal", (ftnlen)10);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ for (i__ = 1; i__ <= 4; ++i__) {
+ do_fio(&c__1, "'", (ftnlen)1);
+ }
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[j - 1] < 1e4) {
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ }
+/* L20: */
+ }
+
+L30:
+ ;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+
+ goto L150;
+
+L70:
+
+/* Read in data from file to check accuracy of condition estimation */
+/* Read input data until N=0 */
+
+ nptknt = 0;
+
+L80:
+ io___42.ciunit = *nin;
+ i__1 = s_rsle(&io___42);
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer))
+ ;
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = e_rsle();
+ if (i__1 != 0) {
+ goto L140;
+ }
+ if (mn_1.mplusn == 0) {
+ goto L140;
+ }
+ io___43.ciunit = *nin;
+ i__1 = s_rsle(&io___43);
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.n, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = e_rsle();
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = mn_1.mplusn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___44.ciunit = *nin;
+ s_rsle(&io___44);
+ i__2 = mn_1.mplusn;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__5, &c__1, (char *)&ai[i__ + j * ai_dim1], (ftnlen)
+ sizeof(doublereal));
+ }
+ e_rsle();
+/* L90: */
+ }
+ i__1 = mn_1.mplusn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___45.ciunit = *nin;
+ s_rsle(&io___45);
+ i__2 = mn_1.mplusn;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__5, &c__1, (char *)&bi[i__ + j * bi_dim1], (ftnlen)
+ sizeof(doublereal));
+ }
+ e_rsle();
+/* L100: */
+ }
+ io___46.ciunit = *nin;
+ s_rsle(&io___46);
+ do_lio(&c__5, &c__1, (char *)&pltru, (ftnlen)sizeof(doublereal));
+ do_lio(&c__5, &c__1, (char *)&diftru, (ftnlen)sizeof(doublereal));
+ e_rsle();
+
+ ++nptknt;
+ mn_1.fs = TRUE_;
+ mn_1.k = 0;
+ mn_1.m = mn_1.mplusn - mn_1.n;
+
+ dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &a[
+ a_offset], lda);
+ dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &b[
+ b_offset], lda);
+
+/* Compute the Schur factorization while swaping the */
+/* m-by-m (1,1)-blocks with n-by-n (2,2)-blocks. */
+
+ dggesx_("V", "V", "S", (L_fp)dlctsx_, "B", &mn_1.mplusn, &ai[ai_offset],
+ lda, &bi[bi_offset], lda, &mm, &alphar[1], &alphai[1], &beta[1], &
+ q[q_offset], lda, &z__[z_offset], lda, pl, difest, &work[1],
+ lwork, &iwork[1], liwork, &bwork[1], &linfo);
+
+ if (linfo != 0 && linfo != mn_1.mplusn + 2) {
+ result[0] = ulpinv;
+ io___48.ciunit = *nout;
+ s_wsfe(&io___48);
+ do_fio(&c__1, "DGGESX", (ftnlen)6);
+ do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L130;
+ }
+
+/* Compute the norm(A, B) */
+/* (should this be norm of (A,B) or (AI,BI)?) */
+
+ dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &work[1],
+ &mn_1.mplusn);
+ dlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &work[
+ mn_1.mplusn * mn_1.mplusn + 1], &mn_1.mplusn);
+ i__1 = mn_1.mplusn << 1;
+ abnrm = dlange_("Fro", &mn_1.mplusn, &i__1, &work[1], &mn_1.mplusn, &work[
+ 1]);
+
+/* Do tests (1) to (4) */
+
+ dget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[ai_offset], lda, &q[
+ q_offset], lda, &z__[z_offset], lda, &work[1], result);
+ dget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
+ q_offset], lda, &z__[z_offset], lda, &work[1], &result[1]);
+ dget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
+ q_offset], lda, &q[q_offset], lda, &work[1], &result[2]);
+ dget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &z__[
+ z_offset], lda, &z__[z_offset], lda, &work[1], &result[3]);
+
+/* Do tests (5) and (6): check Schur form of A and compare */
+/* eigenvalues with diagonals. */
+
+ ntest = 6;
+ temp1 = 0.;
+ result[4] = 0.;
+ result[5] = 0.;
+
+ i__1 = mn_1.mplusn;
+ for (j = 1; j <= i__1; ++j) {
+ ilabad = FALSE_;
+ if (alphai[j] == 0.) {
+/* Computing MAX */
+ d__7 = smlnum, d__8 = (d__2 = alphar[j], abs(d__2)), d__7 = max(
+ d__7,d__8), d__8 = (d__3 = ai[j + j * ai_dim1], abs(d__3))
+ ;
+/* Computing MAX */
+ d__9 = smlnum, d__10 = (d__5 = beta[j], abs(d__5)), d__9 = max(
+ d__9,d__10), d__10 = (d__6 = bi[j + j * bi_dim1], abs(
+ d__6));
+ temp2 = ((d__1 = alphar[j] - ai[j + j * ai_dim1], abs(d__1)) /
+ max(d__7,d__8) + (d__4 = beta[j] - bi[j + j * bi_dim1],
+ abs(d__4)) / max(d__9,d__10)) / ulp;
+ if (j < mn_1.mplusn) {
+ if (ai[j + 1 + j * ai_dim1] != 0.) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ }
+ if (j > 1) {
+ if (ai[j + (j - 1) * ai_dim1] != 0.) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ }
+ } else {
+ if (alphai[j] > 0.) {
+ i1 = j;
+ } else {
+ i1 = j - 1;
+ }
+ if (i1 <= 0 || i1 >= mn_1.mplusn) {
+ ilabad = TRUE_;
+ } else if (i1 < mn_1.mplusn - 1) {
+ if (ai[i1 + 2 + (i1 + 1) * ai_dim1] != 0.) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ } else if (i1 > 1) {
+ if (ai[i1 + (i1 - 1) * ai_dim1] != 0.) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ }
+ if (! ilabad) {
+ dget53_(&ai[i1 + i1 * ai_dim1], lda, &bi[i1 + i1 * bi_dim1],
+ lda, &beta[j], &alphar[j], &alphai[j], &temp2, &iinfo)
+ ;
+ if (iinfo >= 3) {
+ io___49.ciunit = *nout;
+ s_wsfe(&io___49);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ }
+ } else {
+ temp2 = ulpinv;
+ }
+ }
+ temp1 = max(temp1,temp2);
+ if (ilabad) {
+ io___50.ciunit = *nout;
+ s_wsfe(&io___50);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L110: */
+ }
+ result[5] = temp1;
+
+/* Test (7) (if sorting worked) <--------- need to be checked. */
+
+ ntest = 7;
+ result[6] = 0.;
+ if (linfo == mn_1.mplusn + 3) {
+ result[6] = ulpinv;
+ }
+
+/* Test (8): compare the estimated value of DIF and its true value. */
+
+ ntest = 8;
+ result[7] = 0.;
+ if (difest[1] == 0.) {
+ if (diftru > abnrm * ulp) {
+ result[7] = ulpinv;
+ }
+ } else if (diftru == 0.) {
+ if (difest[1] > abnrm * ulp) {
+ result[7] = ulpinv;
+ }
+ } else if (diftru > thrsh2 * difest[1] || diftru * thrsh2 < difest[1]) {
+/* Computing MAX */
+ d__1 = diftru / difest[1], d__2 = difest[1] / diftru;
+ result[7] = max(d__1,d__2);
+ }
+
+/* Test (9) */
+
+ ntest = 9;
+ result[8] = 0.;
+ if (linfo == mn_1.mplusn + 2) {
+ if (diftru > abnrm * ulp) {
+ result[8] = ulpinv;
+ }
+ if (ifunc > 1 && difest[1] != 0.) {
+ result[8] = ulpinv;
+ }
+ if (ifunc == 1 && pl[0] != 0.) {
+ result[8] = ulpinv;
+ }
+ }
+
+/* Test (10): compare the estimated value of PL and it true value. */
+
+ ntest = 10;
+ result[9] = 0.;
+ if (pl[0] == 0.) {
+ if (pltru > abnrm * ulp) {
+ result[9] = ulpinv;
+ }
+ } else if (pltru == 0.) {
+ if (pl[0] > abnrm * ulp) {
+ result[9] = ulpinv;
+ }
+ } else if (pltru > *thresh * pl[0] || pltru * *thresh < pl[0]) {
+ result[9] = ulpinv;
+ }
+
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__1 = ntest;
+ for (j = 1; j <= i__1; ++j) {
+ if (result[j - 1] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___51.ciunit = *nout;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "SGX", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___52.ciunit = *nout;
+ s_wsfe(&io___52);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___53.ciunit = *nout;
+ s_wsfe(&io___53);
+ do_fio(&c__1, "orthogonal", (ftnlen)10);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ for (i__ = 1; i__ <= 4; ++i__) {
+ do_fio(&c__1, "'", (ftnlen)1);
+ }
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[j - 1] < 1e4) {
+ io___54.ciunit = *nout;
+ s_wsfe(&io___54);
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ } else {
+ io___55.ciunit = *nout;
+ s_wsfe(&io___55);
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+ }
+
+/* L120: */
+ }
+
+L130:
+ goto L80;
+L140:
+
+L150:
+
+/* Summary */
+
+ alasvm_("SGX", nout, &nerrs, &ntestt, &c__0);
+
+ work[1] = (doublereal) maxwrk;
+
+ return 0;
+
+
+
+
+
+
+
+
+
+/* End of DDRGSX */
+
+} /* ddrgsx_ */
diff --git a/TESTING/EIG/ddrgvx.c b/TESTING/EIG/ddrgvx.c
new file mode 100644
index 0000000..1aad026
--- /dev/null
+++ b/TESTING/EIG/ddrgvx.c
@@ -0,0 +1,969 @@
+/* ddrgvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c__5 = 5;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+static integer c__3 = 3;
+
+/* Subroutine */ int ddrgvx_(integer *nsize, doublereal *thresh, integer *nin,
+ integer *nout, doublereal *a, integer *lda, doublereal *b,
+ doublereal *ai, doublereal *bi, doublereal *alphar, doublereal *
+ alphai, doublereal *beta, doublereal *vl, doublereal *vr, integer *
+ ilo, integer *ihi, doublereal *lscale, doublereal *rscale, doublereal
+ *s, doublereal *dtru, doublereal *dif, doublereal *diftru, doublereal
+ *work, integer *lwork, integer *iwork, integer *liwork, doublereal *
+ result, logical *bwork, integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 DDRGVX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002)\002)";
+ static char fmt_9998[] = "(\002 DDRGVX: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
+ "i6,\002, IWA=\002,i5,\002, IWB=\002,i5,\002, IWX=\002,i5,\002, I"
+ "WY=\002,i5)";
+ static char fmt_9997[] = "(/1x,a3,\002 -- Real Expert Eigenvalue/vecto"
+ "r\002,\002 problem driver\002)";
+ static char fmt_9995[] = "(\002 Matrix types: \002,/)";
+ static char fmt_9994[] = "(\002 TYPE 1: Da is diagonal, Db is identity,"
+ " \002,/\002 A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1) \002,/"
+ "\002 YH and X are left and right eigenvectors. \002,/)";
+ static char fmt_9993[] = "(\002 TYPE 2: Da is quasi-diagonal, Db is iden"
+ "tity, \002,/\002 A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1)"
+ " \002,/\002 YH and X are left and right eigenvectors. \002,/)"
+ ;
+ static char fmt_9992[] = "(/\002 Tests performed: \002,/4x,\002 a is al"
+ "pha, b is beta, l is a left eigenvector, \002,/4x,\002 r is a ri"
+ "ght eigenvector and \002,a,\002 means \002,a,\002.\002,/\002 1 ="
+ " max | ( b A - a B )\002,a,\002 l | / const.\002,/\002 2 = max |"
+ " ( b A - a B ) r | / const.\002,/\002 3 = max ( Sest/Stru, Stru/"
+ "Sest ) \002,\002 over all eigenvalues\002,/\002 4 = max( DIFest/"
+ "DIFtru, DIFtru/DIFest ) \002,\002 over the 1st and 5th eigenvect"
+ "ors\002,/)";
+ static char fmt_9991[] = "(\002 Type=\002,i2,\002,\002,\002 IWA=\002,i2"
+ ",\002, IWB=\002,i2,\002, IWX=\002,i2,\002, IWY=\002,i2,\002, res"
+ "ult \002,i2,\002 is\002,0p,f8.2)";
+ static char fmt_9990[] = "(\002 Type=\002,i2,\002,\002,\002 IWA=\002,i2"
+ ",\002, IWB=\002,i2,\002, IWX=\002,i2,\002, IWY=\002,i2,\002, res"
+ "ult \002,i2,\002 is\002,1p,d10.3)";
+ static char fmt_9987[] = "(\002 DDRGVX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, Input example #\002,i2,\002"
+ ")\002)";
+ static char fmt_9986[] = "(\002 DDRGVX: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, Input Examp"
+ "le #\002,i2,\002)\002)";
+ static char fmt_9996[] = "(\002 Input Example\002)";
+ static char fmt_9989[] = "(\002 Input example #\002,i2,\002, matrix orde"
+ "r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,0p,f8.2)";
+ static char fmt_9988[] = "(\002 Input example #\002,i2,\002, matrix orde"
+ "r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,1p,d10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, ai_dim1, ai_offset, b_dim1, b_offset, bi_dim1,
+ bi_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+
+ /* Local variables */
+ integer i__, j, n, iwa, iwb;
+ doublereal ulp;
+ integer iwx, iwy, nmax;
+ extern /* Subroutine */ int dget52_(logical *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *);
+ integer linfo;
+ doublereal anorm, bnorm;
+ integer nerrs;
+ extern /* Subroutine */ int dlatm6_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *);
+ doublereal ratio1, ratio2, thrsh2;
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ doublereal abnorm;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *), dggevx_(char *, char *, char *, char *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *, logical *,
+ integer *);
+ doublereal weight[5];
+ integer minwrk, maxwrk, iptype;
+ doublereal ulpinv;
+ integer nptknt, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___20 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___35 = { 0, 0, 1, 0, 0 };
+ static cilist io___36 = { 0, 0, 0, 0, 0 };
+ static cilist io___37 = { 0, 0, 0, 0, 0 };
+ static cilist io___38 = { 0, 0, 0, 0, 0 };
+ static cilist io___39 = { 0, 0, 0, 0, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9987, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9986, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9986, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9988, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRGVX checks the nonsymmetric generalized eigenvalue problem */
+/* expert driver DGGEVX. */
+
+/* DGGEVX computes the generalized eigenvalues, (optionally) the left */
+/* and/or right eigenvectors, (optionally) computes a balancing */
+/* transformation to improve the conditioning, and (optionally) */
+/* reciprocal condition numbers for the eigenvalues and eigenvectors. */
+
+/* When DDRGVX is called with NSIZE > 0, two types of test matrix pairs */
+/* are generated by the subroutine DLATM6 and test the driver DGGEVX. */
+/* The test matrices have the known exact condition numbers for */
+/* eigenvalues. For the condition numbers of the eigenvectors */
+/* corresponding the first and last eigenvalues are also know */
+/* ``exactly'' (see DLATM6). */
+
+/* For each matrix pair, the following tests will be performed and */
+/* compared with the threshhold THRESH. */
+
+/* (1) max over all left eigenvalue/-vector pairs (beta/alpha,l) of */
+
+/* | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) ) */
+
+/* where l**H is the conjugate tranpose of l. */
+
+/* (2) max over all right eigenvalue/-vector pairs (beta/alpha,r) of */
+
+/* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) ) */
+
+/* (3) The condition number S(i) of eigenvalues computed by DGGEVX */
+/* differs less than a factor THRESH from the exact S(i) (see */
+/* DLATM6). */
+
+/* (4) DIF(i) computed by DTGSNA differs less than a factor 10*THRESH */
+/* from the exact value (for the 1st and 5th vectors only). */
+
+/* Test Matrices */
+/* ============= */
+
+/* Two kinds of test matrix pairs */
+
+/* (A, B) = inverse(YH) * (Da, Db) * inverse(X) */
+
+/* are used in the tests: */
+
+/* 1: Da = 1+a 0 0 0 0 Db = 1 0 0 0 0 */
+/* 0 2+a 0 0 0 0 1 0 0 0 */
+/* 0 0 3+a 0 0 0 0 1 0 0 */
+/* 0 0 0 4+a 0 0 0 0 1 0 */
+/* 0 0 0 0 5+a , 0 0 0 0 1 , and */
+
+/* 2: Da = 1 -1 0 0 0 Db = 1 0 0 0 0 */
+/* 1 1 0 0 0 0 1 0 0 0 */
+/* 0 0 1 0 0 0 0 1 0 0 */
+/* 0 0 0 1+a 1+b 0 0 0 1 0 */
+/* 0 0 0 -1-b 1+a , 0 0 0 0 1 . */
+
+/* In both cases the same inverse(YH) and inverse(X) are used to compute */
+/* (A, B), giving the exact eigenvectors to (A,B) as (YH, X): */
+
+/* YH: = 1 0 -y y -y X = 1 0 -x -x x */
+/* 0 1 -y y -y 0 1 x -x -x */
+/* 0 0 1 0 0 0 0 1 0 0 */
+/* 0 0 0 1 0 0 0 0 1 0 */
+/* 0 0 0 0 1, 0 0 0 0 1 , where */
+
+/* a, b, x and y will have all values independently of each other from */
+/* { sqrt(sqrt(ULP)), 0.1, 1, 10, 1/sqrt(sqrt(ULP)) }. */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZE (input) INTEGER */
+/* The number of sizes of matrices to use. NSIZE must be at */
+/* least zero. If it is zero, no randomly generated matrices */
+/* are tested, but any test matrices read from NIN will be */
+/* tested. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NIN (input) INTEGER */
+/* The FORTRAN unit number for reading in the data file of */
+/* problems to solve. */
+
+/* NOUT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, AI, BI, Ao, and Bo. */
+/* It must be at least 1 and at least NSIZE. */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, B contains the last matrix actually used. */
+
+/* AI (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
+/* Copy of A, modified by DGGEVX. */
+
+/* BI (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
+/* Copy of B, modified by DGGEVX. */
+
+/* ALPHAR (workspace) DOUBLE PRECISION array, dimension (NSIZE) */
+/* ALPHAI (workspace) DOUBLE PRECISION array, dimension (NSIZE) */
+/* BETA (workspace) DOUBLE PRECISION array, dimension (NSIZE) */
+/* On exit, (ALPHAR + ALPHAI*i)/BETA are the eigenvalues. */
+
+/* VL (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
+/* VL holds the left eigenvectors computed by DGGEVX. */
+
+/* VR (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE) */
+/* VR holds the right eigenvectors computed by DGGEVX. */
+
+/* ILO (output/workspace) INTEGER */
+
+/* IHI (output/workspace) INTEGER */
+
+/* LSCALE (output/workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RSCALE (output/workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* S (output/workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* DTRU (output/workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* DIF (output/workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* DIFTRU (output/workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* Leading dimension of WORK. LWORK >= 2*N*N+12*N+16. */
+
+/* IWORK (workspace) INTEGER array, dimension (LIWORK) */
+
+/* LIWORK (input) INTEGER */
+/* Leading dimension of IWORK. Must be at least N+6. */
+
+/* RESULT (output/workspace) DOUBLE PRECISION array, dimension (4) */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: A routine returned an error code. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ /* Parameter adjustments */
+ vr_dim1 = *lda;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ vl_dim1 = *lda;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ bi_dim1 = *lda;
+ bi_offset = 1 + bi_dim1;
+ bi -= bi_offset;
+ ai_dim1 = *lda;
+ ai_offset = 1 + ai_dim1;
+ ai -= ai_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ --lscale;
+ --rscale;
+ --s;
+ --dtru;
+ --dif;
+ --diftru;
+ --work;
+ --iwork;
+ --result;
+ --bwork;
+
+ /* Function Body */
+ *info = 0;
+
+ nmax = 5;
+
+ if (*nsize < 0) {
+ *info = -1;
+ } else if (*thresh < 0.) {
+ *info = -2;
+ } else if (*nin <= 0) {
+ *info = -3;
+ } else if (*nout <= 0) {
+ *info = -4;
+ } else if (*lda < 1 || *lda < nmax) {
+ *info = -6;
+ } else if (*liwork < nmax + 6) {
+ *info = -26;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ minwrk = 1;
+ if (*info == 0 && *lwork >= 1) {
+ minwrk = (nmax << 1) * nmax + nmax * 12 + 16;
+ maxwrk = nmax * 6 + nmax * ilaenv_(&c__1, "DGEQRF", " ", &nmax, &c__1,
+ &nmax, &c__0);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (nmax << 1) * nmax + nmax * 12 + 16;
+ maxwrk = max(i__1,i__2);
+ work[1] = (doublereal) maxwrk;
+ }
+
+ if (*lwork < minwrk) {
+ *info = -24;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DDRGVX", &i__1);
+ return 0;
+ }
+
+ n = 5;
+ ulp = dlamch_("P");
+ ulpinv = 1. / ulp;
+ thrsh2 = *thresh * 10.;
+ nerrs = 0;
+ nptknt = 0;
+ ntestt = 0;
+
+ if (*nsize == 0) {
+ goto L90;
+ }
+
+/* Parameters used for generating test matrices. */
+
+ weight[0] = sqrt(sqrt(ulp));
+ weight[1] = .1;
+ weight[2] = 1.;
+ weight[3] = 1. / weight[1];
+ weight[4] = 1. / weight[0];
+
+ for (iptype = 1; iptype <= 2; ++iptype) {
+ for (iwa = 1; iwa <= 5; ++iwa) {
+ for (iwb = 1; iwb <= 5; ++iwb) {
+ for (iwx = 1; iwx <= 5; ++iwx) {
+ for (iwy = 1; iwy <= 5; ++iwy) {
+
+/* generated a test matrix pair */
+
+ dlatm6_(&iptype, &c__5, &a[a_offset], lda, &b[
+ b_offset], &vr[vr_offset], lda, &vl[vl_offset]
+, lda, &weight[iwa - 1], &weight[iwb - 1], &
+ weight[iwx - 1], &weight[iwy - 1], &dtru[1], &
+ diftru[1]);
+
+/* Compute eigenvalues/eigenvectors of (A, B). */
+/* Compute eigenvalue/eigenvector condition numbers */
+/* using computed eigenvectors. */
+
+ dlacpy_("F", &n, &n, &a[a_offset], lda, &ai[ai_offset]
+, lda);
+ dlacpy_("F", &n, &n, &b[b_offset], lda, &bi[bi_offset]
+, lda);
+
+ dggevx_("N", "V", "V", "B", &n, &ai[ai_offset], lda, &
+ bi[bi_offset], lda, &alphar[1], &alphai[1], &
+ beta[1], &vl[vl_offset], lda, &vr[vr_offset],
+ lda, ilo, ihi, &lscale[1], &rscale[1], &anorm,
+ &bnorm, &s[1], &dif[1], &work[1], lwork, &
+ iwork[1], &bwork[1], &linfo);
+ if (linfo != 0) {
+ result[1] = ulpinv;
+ io___20.ciunit = *nout;
+ s_wsfe(&io___20);
+ do_fio(&c__1, "DGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ goto L30;
+ }
+
+/* Compute the norm(A, B) */
+
+ dlacpy_("Full", &n, &n, &ai[ai_offset], lda, &work[1],
+ &n);
+ dlacpy_("Full", &n, &n, &bi[bi_offset], lda, &work[n *
+ n + 1], &n);
+ i__1 = n << 1;
+ abnorm = dlange_("Fro", &n, &i__1, &work[1], &n, &
+ work[1]);
+
+/* Tests (1) and (2) */
+
+ result[1] = 0.;
+ dget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset],
+ lda, &vl[vl_offset], lda, &alphar[1], &alphai[
+ 1], &beta[1], &work[1], &result[1]);
+ if (result[2] > *thresh) {
+ io___22.ciunit = *nout;
+ s_wsfe(&io___22);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "DGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+
+ result[2] = 0.;
+ dget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset],
+ lda, &vr[vr_offset], lda, &alphar[1], &
+ alphai[1], &beta[1], &work[1], &result[2]);
+ if (result[3] > *thresh) {
+ io___23.ciunit = *nout;
+ s_wsfe(&io___23);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "DGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[3], (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+
+/* Test (3) */
+
+ result[3] = 0.;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] == 0.) {
+ if (dtru[i__] > abnorm * ulp) {
+ result[3] = ulpinv;
+ }
+ } else if (dtru[i__] == 0.) {
+ if (s[i__] > abnorm * ulp) {
+ result[3] = ulpinv;
+ }
+ } else {
+/* Computing MAX */
+ d__3 = (d__1 = dtru[i__] / s[i__], abs(d__1)),
+ d__4 = (d__2 = s[i__] / dtru[i__],
+ abs(d__2));
+ work[i__] = max(d__3,d__4);
+/* Computing MAX */
+ d__1 = result[3], d__2 = work[i__];
+ result[3] = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+/* Test (4) */
+
+ result[4] = 0.;
+ if (dif[1] == 0.) {
+ if (diftru[1] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (diftru[1] == 0.) {
+ if (dif[1] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (dif[5] == 0.) {
+ if (diftru[5] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (diftru[5] == 0.) {
+ if (dif[5] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else {
+/* Computing MAX */
+ d__3 = (d__1 = diftru[1] / dif[1], abs(d__1)),
+ d__4 = (d__2 = dif[1] / diftru[1], abs(
+ d__2));
+ ratio1 = max(d__3,d__4);
+/* Computing MAX */
+ d__3 = (d__1 = diftru[5] / dif[5], abs(d__1)),
+ d__4 = (d__2 = dif[5] / diftru[5], abs(
+ d__2));
+ ratio2 = max(d__3,d__4);
+ result[4] = max(ratio1,ratio2);
+ }
+
+ ntestt += 4;
+
+/* Print out tests which fail. */
+
+ for (j = 1; j <= 4; ++j) {
+ if (result[j] >= thrsh2 && j >= 4 || result[j] >=
+ *thresh && j <= 3) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___28.ciunit = *nout;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "DXV", (ftnlen)3);
+ e_wsfe();
+
+/* Print out messages for built-in examples */
+
+/* Matrix types */
+
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ e_wsfe();
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ e_wsfe();
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ do_fio(&c__1, "'", (ftnlen)1);
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[j] < 1e4) {
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&iptype, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwa, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwb, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwx, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwy, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, (char *)&iptype, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwa, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwb, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwx, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwy, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ }
+/* L20: */
+ }
+
+L30:
+
+/* L40: */
+ ;
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+
+ goto L150;
+
+L90:
+
+/* Read in data from file to check accuracy of condition estimation */
+/* Read input data until N=0 */
+
+ io___35.ciunit = *nin;
+ i__1 = s_rsle(&io___35);
+ if (i__1 != 0) {
+ goto L150;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L150;
+ }
+ i__1 = e_rsle();
+ if (i__1 != 0) {
+ goto L150;
+ }
+ if (n == 0) {
+ goto L150;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___36.ciunit = *nin;
+ s_rsle(&io___36);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__5, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
+ doublereal));
+ }
+ e_rsle();
+/* L100: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___37.ciunit = *nin;
+ s_rsle(&io___37);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__5, &c__1, (char *)&b[i__ + j * b_dim1], (ftnlen)sizeof(
+ doublereal));
+ }
+ e_rsle();
+/* L110: */
+ }
+ io___38.ciunit = *nin;
+ s_rsle(&io___38);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__5, &c__1, (char *)&dtru[i__], (ftnlen)sizeof(doublereal));
+ }
+ e_rsle();
+ io___39.ciunit = *nin;
+ s_rsle(&io___39);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__5, &c__1, (char *)&diftru[i__], (ftnlen)sizeof(doublereal))
+ ;
+ }
+ e_rsle();
+
+ ++nptknt;
+
+/* Compute eigenvalues/eigenvectors of (A, B). */
+/* Compute eigenvalue/eigenvector condition numbers */
+/* using computed eigenvectors. */
+
+ dlacpy_("F", &n, &n, &a[a_offset], lda, &ai[ai_offset], lda);
+ dlacpy_("F", &n, &n, &b[b_offset], lda, &bi[bi_offset], lda);
+
+ dggevx_("N", "V", "V", "B", &n, &ai[ai_offset], lda, &bi[bi_offset], lda,
+ &alphar[1], &alphai[1], &beta[1], &vl[vl_offset], lda, &vr[
+ vr_offset], lda, ilo, ihi, &lscale[1], &rscale[1], &anorm, &bnorm,
+ &s[1], &dif[1], &work[1], lwork, &iwork[1], &bwork[1], &linfo);
+
+ if (linfo != 0) {
+ result[1] = ulpinv;
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "DGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L140;
+ }
+
+/* Compute the norm(A, B) */
+
+ dlacpy_("Full", &n, &n, &ai[ai_offset], lda, &work[1], &n);
+ dlacpy_("Full", &n, &n, &bi[bi_offset], lda, &work[n * n + 1], &n);
+ i__1 = n << 1;
+ abnorm = dlange_("Fro", &n, &i__1, &work[1], &n, &work[1]);
+
+/* Tests (1) and (2) */
+
+ result[1] = 0.;
+ dget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &vl[vl_offset],
+ lda, &alphar[1], &alphai[1], &beta[1], &work[1], &result[1]);
+ if (result[2] > *thresh) {
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "DGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ result[2] = 0.;
+ dget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &vr[vr_offset]
+, lda, &alphar[1], &alphai[1], &beta[1], &work[1], &result[2]);
+ if (result[3] > *thresh) {
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "DGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[3], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Test (3) */
+
+ result[3] = 0.;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] == 0.) {
+ if (dtru[i__] > abnorm * ulp) {
+ result[3] = ulpinv;
+ }
+ } else if (dtru[i__] == 0.) {
+ if (s[i__] > abnorm * ulp) {
+ result[3] = ulpinv;
+ }
+ } else {
+/* Computing MAX */
+ d__3 = (d__1 = dtru[i__] / s[i__], abs(d__1)), d__4 = (d__2 = s[
+ i__] / dtru[i__], abs(d__2));
+ work[i__] = max(d__3,d__4);
+/* Computing MAX */
+ d__1 = result[3], d__2 = work[i__];
+ result[3] = max(d__1,d__2);
+ }
+/* L120: */
+ }
+
+/* Test (4) */
+
+ result[4] = 0.;
+ if (dif[1] == 0.) {
+ if (diftru[1] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (diftru[1] == 0.) {
+ if (dif[1] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (dif[5] == 0.) {
+ if (diftru[5] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (diftru[5] == 0.) {
+ if (dif[5] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else {
+/* Computing MAX */
+ d__3 = (d__1 = diftru[1] / dif[1], abs(d__1)), d__4 = (d__2 = dif[1] /
+ diftru[1], abs(d__2));
+ ratio1 = max(d__3,d__4);
+/* Computing MAX */
+ d__3 = (d__1 = diftru[5] / dif[5], abs(d__1)), d__4 = (d__2 = dif[5] /
+ diftru[5], abs(d__2));
+ ratio2 = max(d__3,d__4);
+ result[4] = max(ratio1,ratio2);
+ }
+
+ ntestt += 4;
+
+/* Print out tests which fail. */
+
+ for (j = 1; j <= 4; ++j) {
+ if (result[j] >= thrsh2) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___43.ciunit = *nout;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "DXV", (ftnlen)3);
+ e_wsfe();
+
+/* Print out messages for built-in examples */
+
+/* Matrix types */
+
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ do_fio(&c__1, "'", (ftnlen)1);
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[j] < 1e4) {
+ io___46.ciunit = *nout;
+ s_wsfe(&io___46);
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___47.ciunit = *nout;
+ s_wsfe(&io___47);
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ }
+/* L130: */
+ }
+
+L140:
+
+ goto L90;
+L150:
+
+/* Summary */
+
+ alasvm_("DXV", nout, &nerrs, &ntestt, &c__0);
+
+ work[1] = (doublereal) maxwrk;
+
+ return 0;
+
+
+
+
+
+
+
+
+
+
+
+
+/* End of DDRGVX */
+
+} /* ddrgvx_ */
diff --git a/TESTING/EIG/ddrvbd.c b/TESTING/EIG/ddrvbd.c
new file mode 100644
index 0000000..77d9962
--- /dev/null
+++ b/TESTING/EIG/ddrvbd.c
@@ -0,0 +1,1110 @@
+/* ddrvbd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublereal c_b13 = 0.;
+static doublereal c_b17 = 1.;
+static integer c__4 = 4;
+static integer c__1 = 1;
+static integer c__0 = 0;
+
+/* Subroutine */ int ddrvbd_(integer *nsizes, integer *mm, integer *nn,
+ integer *ntypes, logical *dotype, integer *iseed, doublereal *thresh,
+ doublereal *a, integer *lda, doublereal *u, integer *ldu, doublereal *
+ vt, integer *ldvt, doublereal *asav, doublereal *usav, doublereal *
+ vtsav, doublereal *s, doublereal *ssav, doublereal *e, doublereal *
+ work, integer *lwork, integer *iwork, integer *nout, integer *info)
+{
+ /* Initialized data */
+
+ static char cjob[1*4] = "N" "O" "S" "A";
+
+ /* Format strings */
+ static char fmt_9996[] = "(\002 DDRVBD: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002M=\002,i6,\002, N=\002,i6,\002, JTYPE=\002,i"
+ "6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9995[] = "(\002 DDRVBD: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002M=\002,i6,\002, N=\002,i6,\002, JTYPE=\002,i"
+ "6,\002, LSWORK=\002,i6,/9x,\002ISEED=(\002,3(i5,\002,\002),i5"
+ ",\002)\002)";
+ static char fmt_9999[] = "(\002 SVD -- Real Singular Value Decomposition"
+ " Driver \002,/\002 Matrix types (see DDRVBD for details):\002,/"
+ "/\002 1 = Zero matrix\002,/\002 2 = Identity matrix\002,/\002 3 "
+ "= Evenly spaced singular values near 1\002,/\002 4 = Evenly spac"
+ "ed singular values near underflow\002,/\002 5 = Evenly spaced si"
+ "ngular values near overflow\002,//\002 Tests performed: ( A is d"
+ "ense, U and V are orthogonal,\002,/19x,\002 S is an array, and U"
+ "partial, VTpartial, and\002,/19x,\002 Spartial are partially com"
+ "puted U, VT and S),\002,/)";
+ static char fmt_9998[] = "(\002 1 = | A - U diag(S) VT | / ( |A| max(M,N"
+ ") ulp ) \002,/\002 2 = | I - U**T U | / ( M ulp ) \002,/\002 3 ="
+ " | I - VT VT**T | / ( N ulp ) \002,/\002 4 = 0 if S contains min"
+ "(M,N) nonnegative values in\002,\002 decreasing order, else 1/ulp"
+ "\002,/\002 5 = | U - Upartial | / ( M ulp )\002,/\002 6 = | VT -"
+ " VTpartial | / ( N ulp )\002,/\002 7 = | S - Spartial | / ( min("
+ "M,N) ulp |S| )\002,/\002 8 = | A - U diag(S) VT | / ( |A| max(M,"
+ "N) ulp ) \002,/\002 9 = | I - U**T U | / ( M ulp ) \002,/\00210 "
+ "= | I - VT VT**T | / ( N ulp ) \002,/\00211 = 0 if S contains mi"
+ "n(M,N) nonnegative values in\002,\002 decreasing order, else 1/u"
+ "lp\002,/\00212 = | U - Upartial | / ( M ulp )\002,/\00213 = | VT"
+ " - VTpartial | / ( N ulp )\002,/\00214 = | S - Spartial | / ( mi"
+ "n(M,N) ulp |S| )\002,/\00215 = | A - U diag(S) VT | / ( |A| max("
+ "M,N) ulp ) \002,/\00216 = | I - U**T U | / ( M ulp ) \002,/\0021"
+ "7 = | I - VT VT**T | / ( N ulp ) \002,/\00218 = 0 if S contains "
+ "min(M,N) nonnegative values in\002,\002 decreasing order, else 1"
+ "/ulp\002,/\00219 = | U - Upartial | / ( M ulp )\002,/\00220 = | "
+ "VT - VTpartial | / ( N ulp )\002,/\00221 = | S - Spartial | / ( "
+ "min(M,N) ulp |S| )\002,//)";
+ static char fmt_9997[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, type "
+ "\002,i1,\002, IWS=\002,i1,\002, seed=\002,4(i4,\002,\002),\002 t"
+ "est(\002,i2,\002)=\002,g11.4)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, asav_dim1, asav_offset, u_dim1, u_offset,
+ usav_dim1, usav_offset, vt_dim1, vt_offset, vtsav_dim1,
+ vtsav_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
+ i__9, i__10, i__11, i__12, i__13, i__14;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, m, n;
+ doublereal dif, div;
+ integer ijq, iju;
+ doublereal ulp;
+ integer iws;
+ char jobq[1], path[3], jobu[1];
+ integer mmax, nmax;
+ doublereal unfl, ovfl;
+ integer ijvt;
+ extern /* Subroutine */ int dbdt01_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *)
+ ;
+ logical badmm, badnn;
+ integer nfail, iinfo;
+ extern /* Subroutine */ int dort01_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *), dort03_(char *, integer *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *);
+ doublereal anorm;
+ integer mnmin, mnmax;
+ char jobvt[1];
+ integer jsize, jtype, ntest, iwtmp;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dgesdd_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *), dgesvd_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dlacpy_(char *, integer *, integer *, doublereal
+ *, integer *, doublereal *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *), dgesvj_(char *, char *, char *
+, integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *), alasvm_(char *, integer *,
+ integer *, integer *, integer *), dlatms_(integer *,
+ integer *, char *, integer *, char *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *, char *,
+ doublereal *, integer *, doublereal *, integer *), dgejsv_(char *, char *, char *, char *, char *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *, integer *);
+ integer minwrk;
+ doublereal ulpinv, result[22];
+ integer lswork, mtypes;
+
+ /* Fortran I/O blocks */
+ static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVBD checks the singular value decomposition (SVD) drivers */
+/* DGESVD, DGESDD, DGESVJ, and DGEJSV. */
+
+/* Both DGESVD and DGESDD factor A = U diag(S) VT, where U and VT are */
+/* orthogonal and diag(S) is diagonal with the entries of the array S */
+/* on its diagonal. The entries of S are the singular values, */
+/* nonnegative and stored in decreasing order. U and VT can be */
+/* optionally not computed, overwritten on A, or computed partially. */
+
+/* A is M by N. Let MNMIN = min( M, N ). S has dimension MNMIN. */
+/* U can be M by M or M by MNMIN. VT can be N by N or MNMIN by N. */
+
+/* When DDRVBD is called, a number of matrix "sizes" (M's and N's) */
+/* and a number of matrix "types" are specified. For each size (M,N) */
+/* and each type of matrix, and for the minimal workspace as well as */
+/* workspace adequate to permit blocking, an M x N matrix "A" will be */
+/* generated and used to test the SVD routines. For each matrix, A will */
+/* be factored as A = U diag(S) VT and the following 12 tests computed: */
+
+/* Test for DGESVD: */
+
+/* (1) | A - U diag(S) VT | / ( |A| max(M,N) ulp ) */
+
+/* (2) | I - U'U | / ( M ulp ) */
+
+/* (3) | I - VT VT' | / ( N ulp ) */
+
+/* (4) S contains MNMIN nonnegative values in decreasing order. */
+/* (Return 0 if true, 1/ULP if false.) */
+
+/* (5) | U - Upartial | / ( M ulp ) where Upartial is a partially */
+/* computed U. */
+
+/* (6) | VT - VTpartial | / ( N ulp ) where VTpartial is a partially */
+/* computed VT. */
+
+/* (7) | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the */
+/* vector of singular values from the partial SVD */
+
+/* Test for DGESDD: */
+
+/* (8) | A - U diag(S) VT | / ( |A| max(M,N) ulp ) */
+
+/* (9) | I - U'U | / ( M ulp ) */
+
+/* (10) | I - VT VT' | / ( N ulp ) */
+
+/* (11) S contains MNMIN nonnegative values in decreasing order. */
+/* (Return 0 if true, 1/ULP if false.) */
+
+/* (12) | U - Upartial | / ( M ulp ) where Upartial is a partially */
+/* computed U. */
+
+/* (13) | VT - VTpartial | / ( N ulp ) where VTpartial is a partially */
+/* computed VT. */
+
+/* (14) | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the */
+/* vector of singular values from the partial SVD */
+
+/* Test for SGESVJ: */
+
+/* (15) | A - U diag(S) VT | / ( |A| max(M,N) ulp ) */
+
+/* (16) | I - U'U | / ( M ulp ) */
+
+/* (17) | I - VT VT' | / ( N ulp ) */
+
+/* (18) S contains MNMIN nonnegative values in decreasing order. */
+/* (Return 0 if true, 1/ULP if false.) */
+
+/* Test for SGEJSV: */
+
+/* (19) | A - U diag(S) VT | / ( |A| max(M,N) ulp ) */
+
+/* (20) | I - U'U | / ( M ulp ) */
+
+/* (21) | I - VT VT' | / ( N ulp ) */
+
+/* (22) S contains MNMIN nonnegative values in decreasing order. */
+/* (Return 0 if true, 1/ULP if false.) */
+
+/* The "sizes" are specified by the arrays MM(1:NSIZES) and */
+/* NN(1:NSIZES); the value of each element pair (MM(j),NN(j)) */
+/* specifies one size. The "types" are specified by a logical array */
+/* DOTYPE( 1:NTYPES ); if DOTYPE(j) is .TRUE., then matrix type "j" */
+/* will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+/* (4) Same as (3), but multiplied by the underflow-threshold / ULP. */
+/* (5) Same as (3), but multiplied by the overflow-threshold * ULP. */
+
+/* Arguments */
+/* ========== */
+
+/* NSIZES (input) INTEGER */
+/* The number of matrix sizes (M,N) contained in the vectors */
+/* MM and NN. */
+
+/* MM (input) INTEGER array, dimension (NSIZES) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* The values of the matrix column dimension N. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, DDRVBD */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrices are in A and B. */
+/* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size (m,n), a matrix */
+/* of type j will be generated. If NTYPES is smaller than the */
+/* maximum number of types defined (PARAMETER MAXTYP), then */
+/* types NTYPES+1 through MAXTYP will not be generated. If */
+/* NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through */
+/* DOTYPE(NTYPES) will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator. The array */
+/* elements should be between 0 and 4095; if not they will be */
+/* reduced mod 4096. Also, ISEED(4) must be odd. */
+/* On exit, ISEED is changed and can be used in the next call to */
+/* DDRVBD to continue the same random number sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* The threshold value for the test ratios. A result is */
+/* included in the output file if RESULT >= THRESH. The test */
+/* ratios are scaled to be O(1), so THRESH should be a small */
+/* multiple of 1, e.g., 10 or 100. To have every test ratio */
+/* printed, use THRESH = 0. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) */
+/* where NMAX is the maximum value of N in NN. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,MMAX), */
+/* where MMAX is the maximum value of M in MM. */
+
+/* U (workspace) DOUBLE PRECISION array, dimension (LDU,MMAX) */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,MMAX). */
+
+/* VT (workspace) DOUBLE PRECISION array, dimension (LDVT,NMAX) */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. LDVT >= max(1,NMAX). */
+
+/* ASAV (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) */
+
+/* USAV (workspace) DOUBLE PRECISION array, dimension (LDU,MMAX) */
+
+/* VTSAV (workspace) DOUBLE PRECISION array, dimension (LDVT,NMAX) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension */
+/* (max(min(MM,NN))) */
+
+/* SSAV (workspace) DOUBLE PRECISION array, dimension */
+/* (max(min(MM,NN))) */
+
+/* E (workspace) DOUBLE PRECISION array, dimension */
+/* (max(min(MM,NN))) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* max(3*MN+MX,5*MN-4)+2*MN**2 for all pairs */
+/* pairs (MN,MX)=( min(MM(j),NN(j), max(MM(j),NN(j)) ) */
+
+/* IWORK (workspace) INTEGER array, dimension at least 8*min(M,N) */
+
+/* NOUT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some MM(j) < 0 */
+/* -3: Some NN(j) < 0 */
+/* -4: NTYPES < 0 */
+/* -7: THRESH < 0 */
+/* -10: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ). */
+/* -12: LDU < 1 or LDU < MMAX. */
+/* -14: LDVT < 1 or LDVT < NMAX, where NMAX is max( NN(j) ). */
+/* -21: LWORK too small. */
+/* If DLATMS, or DGESVD returns an error code, the */
+/* absolute value of it is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --mm;
+ --nn;
+ --dotype;
+ --iseed;
+ asav_dim1 = *lda;
+ asav_offset = 1 + asav_dim1;
+ asav -= asav_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ usav_dim1 = *ldu;
+ usav_offset = 1 + usav_dim1;
+ usav -= usav_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ vtsav_dim1 = *ldvt;
+ vtsav_offset = 1 + vtsav_dim1;
+ vtsav -= vtsav_offset;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --s;
+ --ssav;
+ --e;
+ --work;
+ --iwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+ badmm = FALSE_;
+ badnn = FALSE_;
+ mmax = 1;
+ nmax = 1;
+ mnmax = 1;
+ minwrk = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = mmax, i__3 = mm[j];
+ mmax = max(i__2,i__3);
+ if (mm[j] < 0) {
+ badmm = TRUE_;
+ }
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__4 = mm[j], i__5 = nn[j];
+ i__2 = mnmax, i__3 = min(i__4,i__5);
+ mnmax = max(i__2,i__3);
+/* Computing MAX */
+/* Computing MAX */
+/* Computing MIN */
+ i__6 = mm[j], i__7 = nn[j];
+/* Computing MAX */
+ i__8 = mm[j], i__9 = nn[j];
+/* Computing MIN */
+ i__10 = mm[j], i__11 = nn[j] - 4;
+ i__4 = min(i__6,i__7) * 3 + max(i__8,i__9), i__5 = min(i__10,i__11) *
+ 5;
+/* Computing MIN */
+ i__13 = mm[j], i__14 = nn[j];
+/* Computing 2nd power */
+ i__12 = min(i__13,i__14);
+ i__2 = minwrk, i__3 = max(i__4,i__5) + (i__12 * i__12 << 1);
+ minwrk = max(i__2,i__3);
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badmm) {
+ *info = -2;
+ } else if (badnn) {
+ *info = -3;
+ } else if (*ntypes < 0) {
+ *info = -4;
+ } else if (*lda < max(1,mmax)) {
+ *info = -10;
+ } else if (*ldu < max(1,mmax)) {
+ *info = -12;
+ } else if (*ldvt < max(1,nmax)) {
+ *info = -14;
+ } else if (minwrk > *lwork) {
+ *info = -21;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DDRVBD", &i__1);
+ return 0;
+ }
+
+/* Initialize constants */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "BD", (ftnlen)2, (ftnlen)2);
+ nfail = 0;
+ ntest = 0;
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ dlabad_(&unfl, &ovfl);
+ ulp = dlamch_("Precision");
+ ulpinv = 1. / ulp;
+ infoc_1.infot = 0;
+
+/* Loop over sizes, types */
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ m = mm[jsize];
+ n = nn[jsize];
+ mnmin = min(m,n);
+
+ if (*nsizes != 1) {
+ mtypes = min(5,*ntypes);
+ } else {
+ mtypes = min(6,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L140;
+ }
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Compute "A" */
+
+ if (mtypes > 5) {
+ goto L30;
+ }
+
+ if (jtype == 1) {
+
+/* Zero matrix */
+
+ dlaset_("Full", &m, &n, &c_b13, &c_b13, &a[a_offset], lda);
+
+ } else if (jtype == 2) {
+
+/* Identity matrix */
+
+ dlaset_("Full", &m, &n, &c_b13, &c_b17, &a[a_offset], lda);
+
+ } else {
+
+/* (Scaled) random matrix */
+
+ if (jtype == 3) {
+ anorm = 1.;
+ }
+ if (jtype == 4) {
+ anorm = unfl / ulp;
+ }
+ if (jtype == 5) {
+ anorm = ovfl * ulp;
+ }
+ d__1 = (doublereal) mnmin;
+ i__3 = m - 1;
+ i__4 = n - 1;
+ dlatms_(&m, &n, "U", &iseed[1], "N", &s[1], &c__4, &d__1, &
+ anorm, &i__3, &i__4, "N", &a[a_offset], lda, &work[1],
+ &iinfo);
+ if (iinfo != 0) {
+ io___25.ciunit = *nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+ }
+
+L30:
+ dlacpy_("F", &m, &n, &a[a_offset], lda, &asav[asav_offset], lda);
+
+/* Do for minimal and adequate (for blocking) workspace */
+
+ for (iws = 1; iws <= 4; ++iws) {
+
+ for (j = 1; j <= 14; ++j) {
+ result[j - 1] = -1.;
+/* L40: */
+ }
+
+/* Test DGESVD: Factorize A */
+
+/* Computing MAX */
+ i__3 = min(m,n) * 3 + max(m,n), i__4 = min(m,n) * 5;
+ iwtmp = max(i__3,i__4);
+ lswork = iwtmp + (iws - 1) * (*lwork - iwtmp) / 3;
+ lswork = min(lswork,*lwork);
+ lswork = max(lswork,1);
+ if (iws == 4) {
+ lswork = *lwork;
+ }
+
+ if (iws > 1) {
+ dlacpy_("F", &m, &n, &asav[asav_offset], lda, &a[a_offset]
+, lda);
+ }
+ s_copy(srnamc_1.srnamt, "DGESVD", (ftnlen)32, (ftnlen)6);
+ dgesvd_("A", "A", &m, &n, &a[a_offset], lda, &ssav[1], &usav[
+ usav_offset], ldu, &vtsav[vtsav_offset], ldvt, &work[
+ 1], &lswork, &iinfo);
+ if (iinfo != 0) {
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, "GESVD", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lswork, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Do tests 1--4 */
+
+ dbdt01_(&m, &n, &c__0, &asav[asav_offset], lda, &usav[
+ usav_offset], ldu, &ssav[1], &e[1], &vtsav[
+ vtsav_offset], ldvt, &work[1], result);
+ if (m != 0 && n != 0) {
+ dort01_("Columns", &m, &m, &usav[usav_offset], ldu, &work[
+ 1], lwork, &result[1]);
+ dort01_("Rows", &n, &n, &vtsav[vtsav_offset], ldvt, &work[
+ 1], lwork, &result[2]);
+ }
+ result[3] = 0.;
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (ssav[i__] < ssav[i__ + 1]) {
+ result[3] = ulpinv;
+ }
+ if (ssav[i__] < 0.) {
+ result[3] = ulpinv;
+ }
+/* L50: */
+ }
+ if (mnmin >= 1) {
+ if (ssav[mnmin] < 0.) {
+ result[3] = ulpinv;
+ }
+ }
+
+/* Do partial SVDs, comparing to SSAV, USAV, and VTSAV */
+
+ result[4] = 0.;
+ result[5] = 0.;
+ result[6] = 0.;
+ for (iju = 0; iju <= 3; ++iju) {
+ for (ijvt = 0; ijvt <= 3; ++ijvt) {
+ if (iju == 3 && ijvt == 3 || iju == 1 && ijvt == 1) {
+ goto L70;
+ }
+ *(unsigned char *)jobu = *(unsigned char *)&cjob[iju];
+ *(unsigned char *)jobvt = *(unsigned char *)&cjob[
+ ijvt];
+ dlacpy_("F", &m, &n, &asav[asav_offset], lda, &a[
+ a_offset], lda);
+ s_copy(srnamc_1.srnamt, "DGESVD", (ftnlen)32, (ftnlen)
+ 6);
+ dgesvd_(jobu, jobvt, &m, &n, &a[a_offset], lda, &s[1],
+ &u[u_offset], ldu, &vt[vt_offset], ldvt, &
+ work[1], &lswork, &iinfo);
+
+/* Compare U */
+
+ dif = 0.;
+ if (m > 0 && n > 0) {
+ if (iju == 1) {
+ dort03_("C", &m, &mnmin, &m, &mnmin, &usav[
+ usav_offset], ldu, &a[a_offset], lda,
+ &work[1], lwork, &dif, &iinfo);
+ } else if (iju == 2) {
+ dort03_("C", &m, &mnmin, &m, &mnmin, &usav[
+ usav_offset], ldu, &u[u_offset], ldu,
+ &work[1], lwork, &dif, &iinfo);
+ } else if (iju == 3) {
+ dort03_("C", &m, &m, &m, &mnmin, &usav[
+ usav_offset], ldu, &u[u_offset], ldu,
+ &work[1], lwork, &dif, &iinfo);
+ }
+ }
+ result[4] = max(result[4],dif);
+
+/* Compare VT */
+
+ dif = 0.;
+ if (m > 0 && n > 0) {
+ if (ijvt == 1) {
+ dort03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &a[a_offset],
+ lda, &work[1], lwork, &dif, &iinfo);
+ } else if (ijvt == 2) {
+ dort03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &vt[vt_offset],
+ ldvt, &work[1], lwork, &dif, &iinfo);
+ } else if (ijvt == 3) {
+ dort03_("R", &n, &n, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &vt[vt_offset],
+ ldvt, &work[1], lwork, &dif, &iinfo);
+ }
+ }
+ result[5] = max(result[5],dif);
+
+/* Compare S */
+
+ dif = 0.;
+/* Computing MAX */
+ d__1 = (doublereal) mnmin * ulp * s[1];
+ div = max(d__1,unfl);
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (ssav[i__] < ssav[i__ + 1]) {
+ dif = ulpinv;
+ }
+ if (ssav[i__] < 0.) {
+ dif = ulpinv;
+ }
+/* Computing MAX */
+ d__2 = dif, d__3 = (d__1 = ssav[i__] - s[i__],
+ abs(d__1)) / div;
+ dif = max(d__2,d__3);
+/* L60: */
+ }
+ result[6] = max(result[6],dif);
+L70:
+ ;
+ }
+/* L80: */
+ }
+
+/* Test DGESDD: Factorize A */
+
+ iwtmp = mnmin * 5 * mnmin + mnmin * 9 + max(m,n);
+ lswork = iwtmp + (iws - 1) * (*lwork - iwtmp) / 3;
+ lswork = min(lswork,*lwork);
+ lswork = max(lswork,1);
+ if (iws == 4) {
+ lswork = *lwork;
+ }
+
+ dlacpy_("F", &m, &n, &asav[asav_offset], lda, &a[a_offset],
+ lda);
+ s_copy(srnamc_1.srnamt, "DGESDD", (ftnlen)32, (ftnlen)6);
+ dgesdd_("A", &m, &n, &a[a_offset], lda, &ssav[1], &usav[
+ usav_offset], ldu, &vtsav[vtsav_offset], ldvt, &work[
+ 1], &lswork, &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, "GESDD", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lswork, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Do tests 8--11 */
+
+ dbdt01_(&m, &n, &c__0, &asav[asav_offset], lda, &usav[
+ usav_offset], ldu, &ssav[1], &e[1], &vtsav[
+ vtsav_offset], ldvt, &work[1], &result[7]);
+ if (m != 0 && n != 0) {
+ dort01_("Columns", &m, &m, &usav[usav_offset], ldu, &work[
+ 1], lwork, &result[8]);
+ dort01_("Rows", &n, &n, &vtsav[vtsav_offset], ldvt, &work[
+ 1], lwork, &result[9]);
+ }
+ result[10] = 0.;
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (ssav[i__] < ssav[i__ + 1]) {
+ result[10] = ulpinv;
+ }
+ if (ssav[i__] < 0.) {
+ result[10] = ulpinv;
+ }
+/* L90: */
+ }
+ if (mnmin >= 1) {
+ if (ssav[mnmin] < 0.) {
+ result[10] = ulpinv;
+ }
+ }
+
+/* Do partial SVDs, comparing to SSAV, USAV, and VTSAV */
+
+ result[11] = 0.;
+ result[12] = 0.;
+ result[13] = 0.;
+ for (ijq = 0; ijq <= 2; ++ijq) {
+ *(unsigned char *)jobq = *(unsigned char *)&cjob[ijq];
+ dlacpy_("F", &m, &n, &asav[asav_offset], lda, &a[a_offset]
+, lda);
+ s_copy(srnamc_1.srnamt, "DGESDD", (ftnlen)32, (ftnlen)6);
+ dgesdd_(jobq, &m, &n, &a[a_offset], lda, &s[1], &u[
+ u_offset], ldu, &vt[vt_offset], ldvt, &work[1], &
+ lswork, &iwork[1], &iinfo);
+
+/* Compare U */
+
+ dif = 0.;
+ if (m > 0 && n > 0) {
+ if (ijq == 1) {
+ if (m >= n) {
+ dort03_("C", &m, &mnmin, &m, &mnmin, &usav[
+ usav_offset], ldu, &a[a_offset], lda,
+ &work[1], lwork, &dif, info);
+ } else {
+ dort03_("C", &m, &mnmin, &m, &mnmin, &usav[
+ usav_offset], ldu, &u[u_offset], ldu,
+ &work[1], lwork, &dif, info);
+ }
+ } else if (ijq == 2) {
+ dort03_("C", &m, &mnmin, &m, &mnmin, &usav[
+ usav_offset], ldu, &u[u_offset], ldu, &
+ work[1], lwork, &dif, info);
+ }
+ }
+ result[11] = max(result[11],dif);
+
+/* Compare VT */
+
+ dif = 0.;
+ if (m > 0 && n > 0) {
+ if (ijq == 1) {
+ if (m >= n) {
+ dort03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &vt[vt_offset],
+ ldvt, &work[1], lwork, &dif, info);
+ } else {
+ dort03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &a[a_offset],
+ lda, &work[1], lwork, &dif, info);
+ }
+ } else if (ijq == 2) {
+ dort03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &vt[vt_offset], ldvt,
+ &work[1], lwork, &dif, info);
+ }
+ }
+ result[12] = max(result[12],dif);
+
+/* Compare S */
+
+ dif = 0.;
+/* Computing MAX */
+ d__1 = (doublereal) mnmin * ulp * s[1];
+ div = max(d__1,unfl);
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (ssav[i__] < ssav[i__ + 1]) {
+ dif = ulpinv;
+ }
+ if (ssav[i__] < 0.) {
+ dif = ulpinv;
+ }
+/* Computing MAX */
+ d__2 = dif, d__3 = (d__1 = ssav[i__] - s[i__], abs(
+ d__1)) / div;
+ dif = max(d__2,d__3);
+/* L100: */
+ }
+ result[13] = max(result[13],dif);
+/* L110: */
+ }
+
+/* Test DGESVJ: Factorize A */
+/* Note: DGESVJ does not work for M < N */
+
+ result[14] = 0.;
+ result[15] = 0.;
+ result[16] = 0.;
+ result[17] = 0.;
+
+ if (m >= n) {
+ iwtmp = mnmin * 5 * mnmin + mnmin * 9 + max(m,n);
+ lswork = iwtmp + (iws - 1) * (*lwork - iwtmp) / 3;
+ lswork = min(lswork,*lwork);
+ lswork = max(lswork,1);
+ if (iws == 4) {
+ lswork = *lwork;
+ }
+
+ dlacpy_("F", &m, &n, &asav[asav_offset], lda, &usav[
+ usav_offset], lda);
+ s_copy(srnamc_1.srnamt, "DGESVJ", (ftnlen)32, (ftnlen)6);
+ dgesvj_("G", "U", "V", &m, &n, &usav[usav_offset], lda, &
+ ssav[1], &c__0, &a[a_offset], ldvt, &work[1],
+ lwork, info);
+
+/* DGESVJ retuns V not VT, so we transpose to use the same */
+/* test suite. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ vtsav[j + i__ * vtsav_dim1] = a[i__ + j * a_dim1];
+ }
+ }
+
+ if (iinfo != 0) {
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "GESVJ", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&lswork, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Do tests 15--18 */
+
+ dbdt01_(&m, &n, &c__0, &asav[asav_offset], lda, &usav[
+ usav_offset], ldu, &ssav[1], &e[1], &vtsav[
+ vtsav_offset], ldvt, &work[1], &result[14]);
+ if (m != 0 && n != 0) {
+ dort01_("Columns", &m, &m, &usav[usav_offset], ldu, &
+ work[1], lwork, &result[15]);
+ dort01_("Rows", &n, &n, &vtsav[vtsav_offset], ldvt, &
+ work[1], lwork, &result[16]);
+ }
+ result[17] = 0.;
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (ssav[i__] < ssav[i__ + 1]) {
+ result[17] = ulpinv;
+ }
+ if (ssav[i__] < 0.) {
+ result[17] = ulpinv;
+ }
+/* L200: */
+ }
+ if (mnmin >= 1) {
+ if (ssav[mnmin] < 0.) {
+ result[17] = ulpinv;
+ }
+ }
+ }
+
+/* Test DGEJSV: Factorize A */
+/* Note: DGEJSV does not work for M < N */
+
+ result[18] = 0.;
+ result[19] = 0.;
+ result[20] = 0.;
+ result[21] = 0.;
+ if (m >= n) {
+ iwtmp = mnmin * 5 * mnmin + mnmin * 9 + max(m,n);
+ lswork = iwtmp + (iws - 1) * (*lwork - iwtmp) / 3;
+ lswork = min(lswork,*lwork);
+ lswork = max(lswork,1);
+ if (iws == 4) {
+ lswork = *lwork;
+ }
+
+ dlacpy_("F", &m, &n, &asav[asav_offset], lda, &vtsav[
+ vtsav_offset], lda);
+ s_copy(srnamc_1.srnamt, "DGEJSV", (ftnlen)32, (ftnlen)6);
+ dgejsv_("G", "U", "V", "R", "N", "N", &m, &n, &vtsav[
+ vtsav_offset], lda, &ssav[1], &usav[usav_offset],
+ ldu, &a[a_offset], ldvt, &work[1], lwork, &iwork[
+ 1], info);
+
+/* DGEJSV retuns V not VT, so we transpose to use the same */
+/* test suite. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ vtsav[j + i__ * vtsav_dim1] = a[i__ + j * a_dim1];
+ }
+ }
+
+ if (iinfo != 0) {
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "GESVJ", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&lswork, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Do tests 19--22 */
+
+ dbdt01_(&m, &n, &c__0, &asav[asav_offset], lda, &usav[
+ usav_offset], ldu, &ssav[1], &e[1], &vtsav[
+ vtsav_offset], ldvt, &work[1], &result[18]);
+ if (m != 0 && n != 0) {
+ dort01_("Columns", &m, &m, &usav[usav_offset], ldu, &
+ work[1], lwork, &result[19]);
+ dort01_("Rows", &n, &n, &vtsav[vtsav_offset], ldvt, &
+ work[1], lwork, &result[20]);
+ }
+ result[21] = 0.;
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (ssav[i__] < ssav[i__ + 1]) {
+ result[21] = ulpinv;
+ }
+ if (ssav[i__] < 0.) {
+ result[21] = ulpinv;
+ }
+/* L300: */
+ }
+ if (mnmin >= 1) {
+ if (ssav[mnmin] < 0.) {
+ result[21] = ulpinv;
+ }
+ }
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+ for (j = 1; j <= 22; ++j) {
+ if (result[j - 1] >= *thresh) {
+ if (nfail == 0) {
+ io___43.ciunit = *nout;
+ s_wsfe(&io___43);
+ e_wsfe();
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ e_wsfe();
+ }
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iws, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L120: */
+ }
+ ntest += 22;
+
+/* L130: */
+ }
+L140:
+ ;
+ }
+/* L150: */
+ }
+
+/* Summary */
+
+ alasvm_(path, nout, &nfail, &ntest, &c__0);
+
+
+ return 0;
+
+/* End of DDRVBD */
+
+} /* ddrvbd_ */
diff --git a/TESTING/EIG/ddrves.c b/TESTING/EIG/ddrves.c
new file mode 100644
index 0000000..510c965
--- /dev/null
+++ b/TESTING/EIG/ddrves.c
@@ -0,0 +1,1099 @@
+/* ddrves.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ doublereal selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+/* Table of constant values */
+
+static doublereal c_b17 = 0.;
+static integer c__0 = 0;
+static doublereal c_b31 = 1.;
+static integer c__4 = 4;
+static integer c__6 = 6;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int ddrves_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
+ doublereal *a, integer *lda, doublereal *h__, doublereal *ht,
+ doublereal *wr, doublereal *wi, doublereal *wrt, doublereal *wit,
+ doublereal *vs, integer *ldvs, doublereal *result, doublereal *work,
+ integer *nwork, integer *iwork, logical *bwork, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
+ static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
+ static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9992[] = "(\002 DDRVES: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(/1x,a3,\002 -- Real Schur Form Decomposition "
+ "Driver\002,/\002 Matrix types (see DDRVES for details): \002)";
+ static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 \002,\002 5=Diagonal: geom"
+ "etr. spaced entries.\002,/\002 2=Identity matrix. "
+ " \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
+ "/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
+ " 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
+ "l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
+ "ll, evenly spaced.\002)";
+ static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
+ " 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
+ "l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
+ "d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
+ "red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
+ "vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
+ " 12=Well-cond., random complex \002,6x,\002 \002,\002 17=Ill-c"
+ "ond., large rand. complx \002,/\002 13=Ill-condi\002,\002tioned,"
+ " evenly spaced. \002,\002 18=Ill-cond., small rand.\002,\002"
+ " complx \002)";
+ static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
+ " \002,\002 21=Matrix \002,\002with small random entries.\002,"
+ "/\002 20=Matrix with large ran\002,\002dom entries. \002,/)";
+ static char fmt_9995[] = "(\002 Tests performed with test threshold ="
+ "\002,f8.2,/\002 ( A denotes A on input and T denotes A on output)"
+ "\002,//\002 1 = 0 if T in Schur form (no sort), \002,\002 1/ulp"
+ " otherwise\002,/\002 2 = | A - VS T transpose(VS) | / ( n |A| ul"
+ "p ) (no sort)\002,/\002 3 = | I - VS transpose(VS) | / ( n ulp )"
+ " (no sort) \002,/\002 4 = 0 if WR+sqrt(-1)*WI are eigenvalues of"
+ " T (no sort),\002,\002 1/ulp otherwise\002,/\002 5 = 0 if T sam"
+ "e no matter if VS computed (no sort),\002,\002 1/ulp otherwis"
+ "e\002,/\002 6 = 0 if WR, WI same no matter if VS computed (no so"
+ "rt)\002,\002, 1/ulp otherwise\002)";
+ static char fmt_9994[] = "(\002 7 = 0 if T in Schur form (sort), \002"
+ ",\002 1/ulp otherwise\002,/\002 8 = | A - VS T transpose(VS) | "
+ "/ ( n |A| ulp ) (sort)\002,/\002 9 = | I - VS transpose(VS) | / "
+ "( n ulp ) (sort) \002,/\002 10 = 0 if WR+sqrt(-1)*WI are eigenva"
+ "lues of T (sort),\002,\002 1/ulp otherwise\002,/\002 11 = 0 if "
+ "T same no matter if VS computed (sort),\002,\002 1/ulp otherwise"
+ "\002,/\002 12 = 0 if WR, WI same no matter if VS computed (sort),"
+ "\002,\002 1/ulp otherwise\002,/\002 13 = 0 if sorting succesful"
+ ", 1/ulp otherwise\002,/)";
+ static char fmt_9993[] = "(\002 N=\002,i5,\002, IWK=\002,i2,\002, seed"
+ "=\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)="
+ "\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, ht_dim1, ht_offset, vs_dim1,
+ vs_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer i__, j, n;
+ doublereal res[2];
+ integer iwk;
+ doublereal tmp, ulp, cond;
+ integer jcol;
+ char path[3];
+ integer sdim, nmax;
+ doublereal unfl, ovfl;
+ integer rsub;
+ char sort[1];
+ logical badnn;
+ extern /* Subroutine */ int dgees_(char *, char *, L_fp, integer *,
+ doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, logical *,
+ integer *);
+ integer nfail, imode;
+ extern /* Subroutine */ int dhst01_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *);
+ integer iinfo;
+ doublereal conds, anorm;
+ integer jsize, nerrs, itype, jtype, ntest, lwork, isort;
+ doublereal rtulp;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ char adumma[1*1];
+ extern /* Subroutine */ int dlatme_(integer *, char *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, char *, char
+ *, char *, char *, doublereal *, integer *, doublereal *, integer
+ *, integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer idumma[1], ioldsd[4];
+ extern logical dslect_(doublereal *, doublereal *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ integer knteig;
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ dlatmr_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, char *, char
+ *, doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, char *, integer *, integer *, integer *,
+ doublereal *, doublereal *, char *, doublereal *, integer *,
+ integer *, integer *), dlasum_(char *, integer *, integer *, integer *),
+ dlatms_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublereal *, integer *, doublereal *, integer
+ *), xerbla_(char *, integer *);
+ integer ntestf;
+ doublereal ulpinv;
+ integer nnwork;
+ doublereal rtulpi;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___32 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVES checks the nonsymmetric eigenvalue (Schur form) problem */
+/* driver DGEES. */
+
+/* When DDRVES is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 13 */
+/* tests will be performed: */
+
+/* (1) 0 if T is in Schur form, 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (2) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (no sorting of eigenvalues). */
+
+/* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues). */
+
+/* (4) 0 if WR+sqrt(-1)*WI are eigenvalues of T */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (5) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (7) 0 if T is in Schur form, 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (8) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (with sorting of eigenvalues). */
+
+/* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues). */
+
+/* (10) 0 if WR+sqrt(-1)*WI are eigenvalues of T */
+/* 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (11) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (13) if sorting worked and SDIM is the number of */
+/* eigenvalues which were SELECTed */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
+
+/* (4) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (5) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (7) Same as (4), but multiplied by a constant near */
+/* the overflow threshold */
+/* (8) Same as (4), but multiplied by a constant near */
+/* the underflow threshold */
+
+/* (9) A matrix of the form U' T U, where U is orthogonal and */
+/* T has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (10) A matrix of the form U' T U, where U is orthogonal and */
+/* T has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (11) A matrix of the form U' T U, where U is orthogonal and */
+/* T has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (12) A matrix of the form U' T U, where U is orthogonal and */
+/* T has real or complex conjugate paired eigenvalues randomly */
+/* chosen from ( ULP, 1 ) and random O(1) entries in the upper */
+/* triangle. */
+
+/* (13) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
+/* with random signs on the diagonal and random O(1) entries */
+/* in the upper triangle. */
+
+/* (14) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has geometrically spaced entries */
+/* 1, ..., ULP with random signs on the diagonal and random */
+/* O(1) entries in the upper triangle. */
+
+/* (15) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
+/* with random signs on the diagonal and random O(1) entries */
+/* in the upper triangle. */
+
+/* (16) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has real or complex conjugate paired */
+/* eigenvalues randomly chosen from ( ULP, 1 ) and random */
+/* O(1) entries in the upper triangle. */
+
+/* (17) Same as (16), but multiplied by a constant */
+/* near the overflow threshold */
+/* (18) Same as (16), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* (19) Nonsymmetric matrix with random entries chosen from (-1,1). */
+/* If N is at least 4, all entries in first two rows and last */
+/* row, and first column and last two columns are zero. */
+/* (20) Same as (19), but multiplied by a constant */
+/* near the overflow threshold */
+/* (21) Same as (19), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* DDRVES does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, DDRVES */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to DDRVES to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, and H. LDA must be at */
+/* least 1 and at least max(NN). */
+
+/* H (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) */
+/* Another copy of the test matrix A, modified by DGEES. */
+
+/* HT (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) */
+/* Yet another copy of the test matrix A, modified by DGEES. */
+
+/* WR (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* WI (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* The real and imaginary parts of the eigenvalues of A. */
+/* On exit, WR + WI*i are the eigenvalues of the matrix in A. */
+
+/* WRT (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* WIT (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* Like WR, WI, these arrays contain the eigenvalues of A, */
+/* but those computed when DGEES only computes a partial */
+/* eigendecomposition, i.e. not Schur vectors */
+
+/* VS (workspace) DOUBLE PRECISION array, dimension (LDVS, max(NN)) */
+/* VS holds the computed Schur vectors. */
+
+/* LDVS (input) INTEGER */
+/* Leading dimension of VS. Must be at least max(1,max(NN)). */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (13) */
+/* The values computed by the 13 tests described above. */
+/* The values are currently limited to 1/ulp, to avoid overflow. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (NWORK) */
+
+/* NWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 5*NN(j)+2*NN(j)**2 for all j. */
+
+/* IWORK (workspace) INTEGER array, dimension (max(NN)) */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -6: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -17: LDVS < 1 or LDVS < NMAX, where NMAX is max( NN(j) ). */
+/* -20: NWORK too small. */
+/* If DLATMR, SLATMS, SLATME or DGEES returns an error code, */
+/* the absolute value of it is returned. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NMAX Largest value in NN. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* COND, CONDS, */
+/* IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTULP, RTULPI Square roots of the previous 4 values. */
+
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+/* KCONDS(j) Selectw whether CONDS is to be 1 or */
+/* 1/sqrt(ulp). (0 means irrelevant.) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ ht_dim1 = *lda;
+ ht_offset = 1 + ht_dim1;
+ ht -= ht_offset;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --wr;
+ --wi;
+ --wrt;
+ --wit;
+ vs_dim1 = *ldvs;
+ vs_offset = 1 + vs_dim1;
+ vs -= vs_offset;
+ --result;
+ --work;
+ --iwork;
+ --bwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "ES", (ftnlen)2, (ftnlen)2);
+
+/* Check for errors */
+
+ ntestt = 0;
+ ntestf = 0;
+ *info = 0;
+ sslct_1.selopt = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+ nmax = 0;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.) {
+ *info = -6;
+ } else if (*nounit <= 0) {
+ *info = -7;
+ } else if (*lda < 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldvs < 1 || *ldvs < nmax) {
+ *info = -17;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = nmax;
+ if (nmax * 5 + (i__1 * i__1 << 1) > *nwork) {
+ *info = -20;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DDRVES", &i__1);
+ return 0;
+ }
+
+/* Quick return if nothing to do */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ dlabad_(&unfl, &ovfl);
+ ulp = dlamch_("Precision");
+ ulpinv = 1. / ulp;
+ rtulp = sqrt(ulp);
+ rtulpi = 1. / rtulp;
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ mtypes = 21;
+ if (*nsizes == 1 && *ntypes == 22) {
+ ++mtypes;
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L260;
+ }
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KCONDS KMODE KTYPE */
+/* =1 O(1) 1 clustered 1 zero */
+/* =2 large large clustered 2 identity */
+/* =3 small exponential Jordan */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random general, w/ eigenvalues */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 random general */
+/* =10 random triangular */
+
+ if (mtypes > 21) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L30;
+ case 2: goto L40;
+ case 3: goto L50;
+ }
+
+L30:
+ anorm = 1.;
+ goto L60;
+
+L40:
+ anorm = ovfl * ulp;
+ goto L60;
+
+L50:
+ anorm = unfl * ulpinv;
+ goto L60;
+
+L60:
+
+ dlaset_("Full", lda, &n, &c_b17, &c_b17, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+/* L70: */
+ }
+
+ } else if (itype == 3) {
+
+/* Jordan Block */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+ if (jcol > 1) {
+ a[jcol + (jcol - 1) * a_dim1] = 1.;
+ }
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 6) {
+
+/* General, eigenvalues specified */
+
+ if (kconds[jtype - 1] == 1) {
+ conds = 1.;
+ } else if (kconds[jtype - 1] == 2) {
+ conds = rtulpi;
+ } else {
+ conds = 0.;
+ }
+
+ *(unsigned char *)&adumma[0] = ' ';
+ dlatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b31,
+ adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
+ n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
+ &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b31,
+ &c_b31, "T", "N", &work[n + 1], &c__1, &c_b31, &work[(
+ n << 1) + 1], &c__1, &c_b31, "N", idumma, &c__0, &
+ c__0, &c_b17, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b31,
+ &c_b31, "T", "N", &work[n + 1], &c__1, &c_b31, &work[(
+ n << 1) + 1], &c__1, &c_b31, "N", idumma, &n, &n, &
+ c_b17, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* General, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b31,
+ &c_b31, "T", "N", &work[n + 1], &c__1, &c_b31, &work[(
+ n << 1) + 1], &c__1, &c_b31, "N", idumma, &n, &n, &
+ c_b17, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+ if (n >= 4) {
+ dlaset_("Full", &c__2, &n, &c_b17, &c_b17, &a[a_offset],
+ lda);
+ i__3 = n - 3;
+ dlaset_("Full", &i__3, &c__1, &c_b17, &c_b17, &a[a_dim1 +
+ 3], lda);
+ i__3 = n - 3;
+ dlaset_("Full", &i__3, &c__2, &c_b17, &c_b17, &a[(n - 1) *
+ a_dim1 + 3], lda);
+ dlaset_("Full", &c__1, &n, &c_b17, &c_b17, &a[n + a_dim1],
+ lda);
+ }
+
+ } else if (itype == 10) {
+
+/* Triangular, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b31,
+ &c_b31, "T", "N", &work[n + 1], &c__1, &c_b31, &work[(
+ n << 1) + 1], &c__1, &c_b31, "N", idumma, &n, &c__0, &
+ c_b17, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___32.ciunit = *nounit;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+/* Test for minimal and generous workspace */
+
+ for (iwk = 1; iwk <= 2; ++iwk) {
+ if (iwk == 1) {
+ nnwork = n * 3;
+ } else {
+/* Computing 2nd power */
+ i__3 = n;
+ nnwork = n * 5 + (i__3 * i__3 << 1);
+ }
+ nnwork = max(nnwork,1);
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 13; ++j) {
+ result[j] = -1.;
+/* L100: */
+ }
+
+/* Test with and without sorting of eigenvalues */
+
+ for (isort = 0; isort <= 1; ++isort) {
+ if (isort == 0) {
+ *(unsigned char *)sort = 'N';
+ rsub = 0;
+ } else {
+ *(unsigned char *)sort = 'S';
+ rsub = 6;
+ }
+
+/* Compute Schur form and Schur vectors, and test them */
+
+ dlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset],
+ lda);
+ dgees_("V", sort, (L_fp)dslect_, &n, &h__[h_offset], lda,
+ &sdim, &wr[1], &wi[1], &vs[vs_offset], ldvs, &
+ work[1], &nnwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != n + 2) {
+ result[rsub + 1] = ulpinv;
+ io___39.ciunit = *nounit;
+ s_wsfe(&io___39);
+ do_fio(&c__1, "DGEES1", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Do Test (1) or Test (7) */
+
+ result[rsub + 1] = 0.;
+ i__3 = n - 2;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j + 2; i__ <= i__4; ++i__) {
+ if (h__[i__ + j * h_dim1] != 0.) {
+ result[rsub + 1] = ulpinv;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+ i__3 = n - 2;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (h__[i__ + 1 + i__ * h_dim1] != 0. && h__[i__ + 2
+ + (i__ + 1) * h_dim1] != 0.) {
+ result[rsub + 1] = ulpinv;
+ }
+/* L130: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (h__[i__ + 1 + i__ * h_dim1] != 0.) {
+ if (h__[i__ + i__ * h_dim1] != h__[i__ + 1 + (i__
+ + 1) * h_dim1] || h__[i__ + (i__ + 1) *
+ h_dim1] == 0. || d_sign(&c_b31, &h__[i__
+ + 1 + i__ * h_dim1]) == d_sign(&c_b31, &
+ h__[i__ + (i__ + 1) * h_dim1])) {
+ result[rsub + 1] = ulpinv;
+ }
+ }
+/* L140: */
+ }
+
+/* Do Tests (2) and (3) or Tests (8) and (9) */
+
+/* Computing MAX */
+ i__3 = 1, i__4 = (n << 1) * n;
+ lwork = max(i__3,i__4);
+ dhst01_(&n, &c__1, &n, &a[a_offset], lda, &h__[h_offset],
+ lda, &vs[vs_offset], ldvs, &work[1], &lwork, res);
+ result[rsub + 2] = res[0];
+ result[rsub + 3] = res[1];
+
+/* Do Test (4) or Test (10) */
+
+ result[rsub + 4] = 0.;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (h__[i__ + i__ * h_dim1] != wr[i__]) {
+ result[rsub + 4] = ulpinv;
+ }
+/* L150: */
+ }
+ if (n > 1) {
+ if (h__[h_dim1 + 2] == 0. && wi[1] != 0.) {
+ result[rsub + 4] = ulpinv;
+ }
+ if (h__[n + (n - 1) * h_dim1] == 0. && wi[n] != 0.) {
+ result[rsub + 4] = ulpinv;
+ }
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (h__[i__ + 1 + i__ * h_dim1] != 0.) {
+ tmp = sqrt((d__1 = h__[i__ + 1 + i__ * h_dim1],
+ abs(d__1))) * sqrt((d__2 = h__[i__ + (i__
+ + 1) * h_dim1], abs(d__2)));
+/* Computing MAX */
+/* Computing MAX */
+ d__4 = ulp * tmp;
+ d__2 = result[rsub + 4], d__3 = (d__1 = wi[i__] -
+ tmp, abs(d__1)) / max(d__4,unfl);
+ result[rsub + 4] = max(d__2,d__3);
+/* Computing MAX */
+/* Computing MAX */
+ d__4 = ulp * tmp;
+ d__2 = result[rsub + 4], d__3 = (d__1 = wi[i__ +
+ 1] + tmp, abs(d__1)) / max(d__4,unfl);
+ result[rsub + 4] = max(d__2,d__3);
+ } else if (i__ > 1) {
+ if (h__[i__ + 1 + i__ * h_dim1] == 0. && h__[i__
+ + (i__ - 1) * h_dim1] == 0. && wi[i__] !=
+ 0.) {
+ result[rsub + 4] = ulpinv;
+ }
+ }
+/* L160: */
+ }
+
+/* Do Test (5) or Test (11) */
+
+ dlacpy_("F", &n, &n, &a[a_offset], lda, &ht[ht_offset],
+ lda);
+ dgees_("N", sort, (L_fp)dslect_, &n, &ht[ht_offset], lda,
+ &sdim, &wrt[1], &wit[1], &vs[vs_offset], ldvs, &
+ work[1], &nnwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != n + 2) {
+ result[rsub + 5] = ulpinv;
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "DGEES2", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+ result[rsub + 5] = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ if (h__[i__ + j * h_dim1] != ht[i__ + j * ht_dim1]
+ ) {
+ result[rsub + 5] = ulpinv;
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+
+/* Do Test (6) or Test (12) */
+
+ result[rsub + 6] = 0.;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (wr[i__] != wrt[i__] || wi[i__] != wit[i__]) {
+ result[rsub + 6] = ulpinv;
+ }
+/* L190: */
+ }
+
+/* Do Test (13) */
+
+ if (isort == 1) {
+ result[13] = 0.;
+ knteig = 0;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d__1 = -wi[i__];
+ if (dslect_(&wr[i__], &wi[i__]) || dslect_(&wr[
+ i__], &d__1)) {
+ ++knteig;
+ }
+ if (i__ < n) {
+ d__1 = -wi[i__ + 1];
+ d__2 = -wi[i__];
+ if ((dslect_(&wr[i__ + 1], &wi[i__ + 1]) ||
+ dslect_(&wr[i__ + 1], &d__1)) && ! (
+ dslect_(&wr[i__], &wi[i__]) ||
+ dslect_(&wr[i__], &d__2)) && iinfo !=
+ n + 2) {
+ result[13] = ulpinv;
+ }
+ }
+/* L200: */
+ }
+ if (sdim != knteig) {
+ result[13] = ulpinv;
+ }
+ }
+
+/* L210: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L220:
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 13; ++j) {
+ if (result[j] >= 0.) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L230: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___48.ciunit = *nounit;
+ s_wsfe(&io___48);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ e_wsfe();
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ e_wsfe();
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ e_wsfe();
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ e_wsfe();
+ ntestf = 2;
+ }
+
+ for (j = 1; j <= 13; ++j) {
+ if (result[j] >= *thresh) {
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+/* L240: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+
+/* L250: */
+ }
+L260:
+ ;
+ }
+/* L270: */
+ }
+
+/* Summary */
+
+ dlasum_(path, nounit, &nerrs, &ntestt);
+
+
+
+ return 0;
+
+/* End of DDRVES */
+
+} /* ddrves_ */
diff --git a/TESTING/EIG/ddrvev.c b/TESTING/EIG/ddrvev.c
new file mode 100644
index 0000000..e508070
--- /dev/null
+++ b/TESTING/EIG/ddrvev.c
@@ -0,0 +1,1112 @@
+/* ddrvev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b17 = 0.;
+static integer c__0 = 0;
+static doublereal c_b31 = 1.;
+static integer c__4 = 4;
+static integer c__6 = 6;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int ddrvev_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
+ doublereal *a, integer *lda, doublereal *h__, doublereal *wr,
+ doublereal *wi, doublereal *wr1, doublereal *wi1, doublereal *vl,
+ integer *ldvl, doublereal *vr, integer *ldvr, doublereal *lre,
+ integer *ldlre, doublereal *result, doublereal *work, integer *nwork,
+ integer *iwork, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
+ static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
+ static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9993[] = "(\002 DDRVEV: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(/1x,a3,\002 -- Real Eigenvalue-Eigenvector De"
+ "composition\002,\002 Driver\002,/\002 Matrix types (see DDRVEV f"
+ "or details): \002)";
+ static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 \002,\002 5=Diagonal: geom"
+ "etr. spaced entries.\002,/\002 2=Identity matrix. "
+ " \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
+ "/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
+ " 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
+ "l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
+ "ll, evenly spaced.\002)";
+ static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
+ " 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
+ "l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
+ "d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
+ "red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
+ "vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
+ " 12=Well-cond., random complex \002,6x,\002 \002,\002 17=Ill-c"
+ "ond., large rand. complx \002,/\002 13=Ill-condi\002,\002tioned,"
+ " evenly spaced. \002,\002 18=Ill-cond., small rand.\002,\002"
+ " complx \002)";
+ static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
+ " \002,\002 21=Matrix \002,\002with small random entries.\002,"
+ "/\002 20=Matrix with large ran\002,\002dom entries. \002,/)";
+ static char fmt_9995[] = "(\002 Tests performed with test threshold ="
+ "\002,f8.2,//\002 1 = | A VR - VR W | / ( n |A| ulp ) \002,/\002 "
+ "2 = | transpose(A) VL - VL W | / ( n |A| ulp ) \002,/\002 3 = | "
+ "|VR(i)| - 1 | / ulp \002,/\002 4 = | |VL(i)| - 1 | / ulp \002,"
+ "/\002 5 = 0 if W same no matter if VR or VL computed,\002,\002 1"
+ "/ulp otherwise\002,/\002 6 = 0 if VR same no matter if VL comput"
+ "ed,\002,\002 1/ulp otherwise\002,/\002 7 = 0 if VL same no matt"
+ "er if VR computed,\002,\002 1/ulp otherwise\002,/)";
+ static char fmt_9994[] = "(\002 N=\002,i5,\002, IWK=\002,i2,\002, seed"
+ "=\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)="
+ "\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1,
+ vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4, d__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer j, n, jj;
+ doublereal dum[1], res[2];
+ integer iwk;
+ doublereal ulp, vmx, cond;
+ integer jcol;
+ char path[3];
+ integer nmax;
+ doublereal unfl, ovfl, tnrm, vrmx, vtst;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ logical badnn;
+ extern /* Subroutine */ int dget22_(char *, char *, char *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *);
+ integer nfail;
+ extern /* Subroutine */ int dgeev_(char *, char *, integer *, doublereal *
+, integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+ integer imode, iinfo;
+ doublereal conds, anorm;
+ integer jsize, nerrs, itype, jtype, ntest;
+ doublereal rtulp;
+ extern doublereal dlapy2_(doublereal *, doublereal *);
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ char adumma[1*1];
+ extern /* Subroutine */ int dlatme_(integer *, char *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, char *, char
+ *, char *, char *, doublereal *, integer *, doublereal *, integer
+ *, integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer idumma[1];
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *), dlatmr_(integer *, integer *,
+ char *, integer *, char *, doublereal *, integer *, doublereal *,
+ doublereal *, char *, char *, doublereal *, integer *, doublereal
+ *, doublereal *, integer *, doublereal *, char *, integer *,
+ integer *, integer *, doublereal *, doublereal *, char *,
+ doublereal *, integer *, integer *, integer *), dlatms_(integer *, integer *,
+ char *, integer *, char *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *, char *, doublereal *, integer
+ *, doublereal *, integer *), dlasum_(char
+ *, integer *, integer *, integer *);
+ integer ntestf;
+ doublereal ulpinv;
+ integer nnwork;
+ doublereal rtulpi;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___32 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVEV checks the nonsymmetric eigenvalue problem driver DGEEV. */
+
+/* When DDRVEV is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 7 */
+/* tests will be performed: */
+
+/* (1) | A * VR - VR * W | / ( n |A| ulp ) */
+
+/* Here VR is the matrix of unit right eigenvectors. */
+/* W is a block diagonal matrix, with a 1x1 block for each */
+/* real eigenvalue and a 2x2 block for each complex conjugate */
+/* pair. If eigenvalues j and j+1 are a complex conjugate pair, */
+/* so WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the */
+/* 2 x 2 block corresponding to the pair will be: */
+
+/* ( wr wi ) */
+/* ( -wi wr ) */
+
+/* Such a block multiplying an n x 2 matrix ( ur ui ) on the */
+/* right will be the same as multiplying ur + i*ui by wr + i*wi. */
+
+/* (2) | A**H * VL - VL * W**H | / ( n |A| ulp ) */
+
+/* Here VL is the matrix of unit left eigenvectors, A**H is the */
+/* conjugate transpose of A, and W is as above. */
+
+/* (3) | |VR(i)| - 1 | / ulp and whether largest component real */
+
+/* VR(i) denotes the i-th column of VR. */
+
+/* (4) | |VL(i)| - 1 | / ulp and whether largest component real */
+
+/* VL(i) denotes the i-th column of VL. */
+
+/* (5) W(full) = W(partial) */
+
+/* W(full) denotes the eigenvalues computed when both VR and VL */
+/* are also computed, and W(partial) denotes the eigenvalues */
+/* computed when only W, only W and VR, or only W and VL are */
+/* computed. */
+
+/* (6) VR(full) = VR(partial) */
+
+/* VR(full) denotes the right eigenvectors computed when both VR */
+/* and VL are computed, and VR(partial) denotes the result */
+/* when only VR is computed. */
+
+/* (7) VL(full) = VL(partial) */
+
+/* VL(full) denotes the left eigenvectors computed when both VR */
+/* and VL are also computed, and VL(partial) denotes the result */
+/* when only VL is computed. */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
+
+/* (4) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (5) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (7) Same as (4), but multiplied by a constant near */
+/* the overflow threshold */
+/* (8) Same as (4), but multiplied by a constant near */
+/* the underflow threshold */
+
+/* (9) A matrix of the form U' T U, where U is orthogonal and */
+/* T has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (10) A matrix of the form U' T U, where U is orthogonal and */
+/* T has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (11) A matrix of the form U' T U, where U is orthogonal and */
+/* T has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (12) A matrix of the form U' T U, where U is orthogonal and */
+/* T has real or complex conjugate paired eigenvalues randomly */
+/* chosen from ( ULP, 1 ) and random O(1) entries in the upper */
+/* triangle. */
+
+/* (13) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
+/* with random signs on the diagonal and random O(1) entries */
+/* in the upper triangle. */
+
+/* (14) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has geometrically spaced entries */
+/* 1, ..., ULP with random signs on the diagonal and random */
+/* O(1) entries in the upper triangle. */
+
+/* (15) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
+/* with random signs on the diagonal and random O(1) entries */
+/* in the upper triangle. */
+
+/* (16) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has real or complex conjugate paired */
+/* eigenvalues randomly chosen from ( ULP, 1 ) and random */
+/* O(1) entries in the upper triangle. */
+
+/* (17) Same as (16), but multiplied by a constant */
+/* near the overflow threshold */
+/* (18) Same as (16), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* (19) Nonsymmetric matrix with random entries chosen from (-1,1). */
+/* If N is at least 4, all entries in first two rows and last */
+/* row, and first column and last two columns are zero. */
+/* (20) Same as (19), but multiplied by a constant */
+/* near the overflow threshold */
+/* (21) Same as (19), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* Arguments */
+/* ========== */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* DDRVEV does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, DDRVEV */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to DDRVEV to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, and H. LDA must be at */
+/* least 1 and at least max(NN). */
+
+/* H (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) */
+/* Another copy of the test matrix A, modified by DGEEV. */
+
+/* WR (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* WI (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* The real and imaginary parts of the eigenvalues of A. */
+/* On exit, WR + WI*i are the eigenvalues of the matrix in A. */
+
+/* WR1 (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* WI1 (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* Like WR, WI, these arrays contain the eigenvalues of A, */
+/* but those computed when DGEEV only computes a partial */
+/* eigendecomposition, i.e. not the eigenvalues and left */
+/* and right eigenvectors. */
+
+/* VL (workspace) DOUBLE PRECISION array, dimension (LDVL, max(NN)) */
+/* VL holds the computed left eigenvectors. */
+
+/* LDVL (input) INTEGER */
+/* Leading dimension of VL. Must be at least max(1,max(NN)). */
+
+/* VR (workspace) DOUBLE PRECISION array, dimension (LDVR, max(NN)) */
+/* VR holds the computed right eigenvectors. */
+
+/* LDVR (input) INTEGER */
+/* Leading dimension of VR. Must be at least max(1,max(NN)). */
+
+/* LRE (workspace) DOUBLE PRECISION array, dimension (LDLRE,max(NN)) */
+/* LRE holds the computed right or left eigenvectors. */
+
+/* LDLRE (input) INTEGER */
+/* Leading dimension of LRE. Must be at least max(1,max(NN)). */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (7) */
+/* The values computed by the seven tests described above. */
+/* The values are currently limited to 1/ulp, to avoid overflow. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (NWORK) */
+
+/* NWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 5*NN(j)+2*NN(j)**2 for all j. */
+
+/* IWORK (workspace) INTEGER array, dimension (max(NN)) */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -6: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -16: LDVL < 1 or LDVL < NMAX, where NMAX is max( NN(j) ). */
+/* -18: LDVR < 1 or LDVR < NMAX, where NMAX is max( NN(j) ). */
+/* -20: LDLRE < 1 or LDLRE < NMAX, where NMAX is max( NN(j) ). */
+/* -23: NWORK too small. */
+/* If DLATMR, SLATMS, SLATME or DGEEV returns an error code, */
+/* the absolute value of it is returned. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NMAX Largest value in NN. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* COND, CONDS, */
+/* IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTULP, RTULPI Square roots of the previous 4 values. */
+
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+/* KCONDS(j) Selectw whether CONDS is to be 1 or */
+/* 1/sqrt(ulp). (0 means irrelevant.) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --wr;
+ --wi;
+ --wr1;
+ --wi1;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ lre_dim1 = *ldlre;
+ lre_offset = 1 + lre_dim1;
+ lre -= lre_offset;
+ --result;
+ --work;
+ --iwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "EV", (ftnlen)2, (ftnlen)2);
+
+/* Check for errors */
+
+ ntestt = 0;
+ ntestf = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+ nmax = 0;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.) {
+ *info = -6;
+ } else if (*nounit <= 0) {
+ *info = -7;
+ } else if (*lda < 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldvl < 1 || *ldvl < nmax) {
+ *info = -16;
+ } else if (*ldvr < 1 || *ldvr < nmax) {
+ *info = -18;
+ } else if (*ldlre < 1 || *ldlre < nmax) {
+ *info = -20;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = nmax;
+ if (nmax * 5 + (i__1 * i__1 << 1) > *nwork) {
+ *info = -23;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DDRVEV", &i__1);
+ return 0;
+ }
+
+/* Quick return if nothing to do */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ dlabad_(&unfl, &ovfl);
+ ulp = dlamch_("Precision");
+ ulpinv = 1. / ulp;
+ rtulp = sqrt(ulp);
+ rtulpi = 1. / rtulp;
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L260;
+ }
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KCONDS KMODE KTYPE */
+/* =1 O(1) 1 clustered 1 zero */
+/* =2 large large clustered 2 identity */
+/* =3 small exponential Jordan */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random general, w/ eigenvalues */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 random general */
+/* =10 random triangular */
+
+ if (mtypes > 21) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L30;
+ case 2: goto L40;
+ case 3: goto L50;
+ }
+
+L30:
+ anorm = 1.;
+ goto L60;
+
+L40:
+ anorm = ovfl * ulp;
+ goto L60;
+
+L50:
+ anorm = unfl * ulpinv;
+ goto L60;
+
+L60:
+
+ dlaset_("Full", lda, &n, &c_b17, &c_b17, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+/* L70: */
+ }
+
+ } else if (itype == 3) {
+
+/* Jordan Block */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+ if (jcol > 1) {
+ a[jcol + (jcol - 1) * a_dim1] = 1.;
+ }
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 6) {
+
+/* General, eigenvalues specified */
+
+ if (kconds[jtype - 1] == 1) {
+ conds = 1.;
+ } else if (kconds[jtype - 1] == 2) {
+ conds = rtulpi;
+ } else {
+ conds = 0.;
+ }
+
+ *(unsigned char *)&adumma[0] = ' ';
+ dlatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b31,
+ adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
+ n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
+ &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b31,
+ &c_b31, "T", "N", &work[n + 1], &c__1, &c_b31, &work[(
+ n << 1) + 1], &c__1, &c_b31, "N", idumma, &c__0, &
+ c__0, &c_b17, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b31,
+ &c_b31, "T", "N", &work[n + 1], &c__1, &c_b31, &work[(
+ n << 1) + 1], &c__1, &c_b31, "N", idumma, &n, &n, &
+ c_b17, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* General, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b31,
+ &c_b31, "T", "N", &work[n + 1], &c__1, &c_b31, &work[(
+ n << 1) + 1], &c__1, &c_b31, "N", idumma, &n, &n, &
+ c_b17, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+ if (n >= 4) {
+ dlaset_("Full", &c__2, &n, &c_b17, &c_b17, &a[a_offset],
+ lda);
+ i__3 = n - 3;
+ dlaset_("Full", &i__3, &c__1, &c_b17, &c_b17, &a[a_dim1 +
+ 3], lda);
+ i__3 = n - 3;
+ dlaset_("Full", &i__3, &c__2, &c_b17, &c_b17, &a[(n - 1) *
+ a_dim1 + 3], lda);
+ dlaset_("Full", &c__1, &n, &c_b17, &c_b17, &a[n + a_dim1],
+ lda);
+ }
+
+ } else if (itype == 10) {
+
+/* Triangular, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b31,
+ &c_b31, "T", "N", &work[n + 1], &c__1, &c_b31, &work[(
+ n << 1) + 1], &c__1, &c_b31, "N", idumma, &n, &c__0, &
+ c_b17, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___32.ciunit = *nounit;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+/* Test for minimal and generous workspace */
+
+ for (iwk = 1; iwk <= 2; ++iwk) {
+ if (iwk == 1) {
+ nnwork = n << 2;
+ } else {
+/* Computing 2nd power */
+ i__3 = n;
+ nnwork = n * 5 + (i__3 * i__3 << 1);
+ }
+ nnwork = max(nnwork,1);
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 7; ++j) {
+ result[j] = -1.;
+/* L100: */
+ }
+
+/* Compute eigenvalues and eigenvectors, and test them */
+
+ dlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+ dgeev_("V", "V", &n, &h__[h_offset], lda, &wr[1], &wi[1], &vl[
+ vl_offset], ldvl, &vr[vr_offset], ldvr, &work[1], &
+ nnwork, &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___35.ciunit = *nounit;
+ s_wsfe(&io___35);
+ do_fio(&c__1, "DGEEV1", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Do Test (1) */
+
+ dget22_("N", "N", "N", &n, &a[a_offset], lda, &vr[vr_offset],
+ ldvr, &wr[1], &wi[1], &work[1], res);
+ result[1] = res[0];
+
+/* Do Test (2) */
+
+ dget22_("T", "N", "T", &n, &a[a_offset], lda, &vl[vl_offset],
+ ldvl, &wr[1], &wi[1], &work[1], res);
+ result[2] = res[0];
+
+/* Do Test (3) */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ tnrm = 1.;
+ if (wi[j] == 0.) {
+ tnrm = dnrm2_(&n, &vr[j * vr_dim1 + 1], &c__1);
+ } else if (wi[j] > 0.) {
+ d__1 = dnrm2_(&n, &vr[j * vr_dim1 + 1], &c__1);
+ d__2 = dnrm2_(&n, &vr[(j + 1) * vr_dim1 + 1], &c__1);
+ tnrm = dlapy2_(&d__1, &d__2);
+ }
+/* Computing MAX */
+/* Computing MIN */
+ d__4 = ulpinv, d__5 = (d__1 = tnrm - 1., abs(d__1)) / ulp;
+ d__2 = result[3], d__3 = min(d__4,d__5);
+ result[3] = max(d__2,d__3);
+ if (wi[j] > 0.) {
+ vmx = 0.;
+ vrmx = 0.;
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ vtst = dlapy2_(&vr[jj + j * vr_dim1], &vr[jj + (j
+ + 1) * vr_dim1]);
+ if (vtst > vmx) {
+ vmx = vtst;
+ }
+ if (vr[jj + (j + 1) * vr_dim1] == 0. && (d__1 =
+ vr[jj + j * vr_dim1], abs(d__1)) > vrmx) {
+ vrmx = (d__2 = vr[jj + j * vr_dim1], abs(d__2)
+ );
+ }
+/* L110: */
+ }
+ if (vrmx / vmx < 1. - ulp * 2.) {
+ result[3] = ulpinv;
+ }
+ }
+/* L120: */
+ }
+
+/* Do Test (4) */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ tnrm = 1.;
+ if (wi[j] == 0.) {
+ tnrm = dnrm2_(&n, &vl[j * vl_dim1 + 1], &c__1);
+ } else if (wi[j] > 0.) {
+ d__1 = dnrm2_(&n, &vl[j * vl_dim1 + 1], &c__1);
+ d__2 = dnrm2_(&n, &vl[(j + 1) * vl_dim1 + 1], &c__1);
+ tnrm = dlapy2_(&d__1, &d__2);
+ }
+/* Computing MAX */
+/* Computing MIN */
+ d__4 = ulpinv, d__5 = (d__1 = tnrm - 1., abs(d__1)) / ulp;
+ d__2 = result[4], d__3 = min(d__4,d__5);
+ result[4] = max(d__2,d__3);
+ if (wi[j] > 0.) {
+ vmx = 0.;
+ vrmx = 0.;
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ vtst = dlapy2_(&vl[jj + j * vl_dim1], &vl[jj + (j
+ + 1) * vl_dim1]);
+ if (vtst > vmx) {
+ vmx = vtst;
+ }
+ if (vl[jj + (j + 1) * vl_dim1] == 0. && (d__1 =
+ vl[jj + j * vl_dim1], abs(d__1)) > vrmx) {
+ vrmx = (d__2 = vl[jj + j * vl_dim1], abs(d__2)
+ );
+ }
+/* L130: */
+ }
+ if (vrmx / vmx < 1. - ulp * 2.) {
+ result[4] = ulpinv;
+ }
+ }
+/* L140: */
+ }
+
+/* Compute eigenvalues only, and test them */
+
+ dlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+ dgeev_("N", "N", &n, &h__[h_offset], lda, &wr1[1], &wi1[1],
+ dum, &c__1, dum, &c__1, &work[1], &nnwork, &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "DGEEV2", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Do Test (5) */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ if (wr[j] != wr1[j] || wi[j] != wi1[j]) {
+ result[5] = ulpinv;
+ }
+/* L150: */
+ }
+
+/* Compute eigenvalues and right eigenvectors, and test them */
+
+ dlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+ dgeev_("N", "V", &n, &h__[h_offset], lda, &wr1[1], &wi1[1],
+ dum, &c__1, &lre[lre_offset], ldlre, &work[1], &
+ nnwork, &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "DGEEV3", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Do Test (5) again */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ if (wr[j] != wr1[j] || wi[j] != wi1[j]) {
+ result[5] = ulpinv;
+ }
+/* L160: */
+ }
+
+/* Do Test (6) */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ if (vr[j + jj * vr_dim1] != lre[j + jj * lre_dim1]) {
+ result[6] = ulpinv;
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+
+/* Compute eigenvalues and left eigenvectors, and test them */
+
+ dlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+ dgeev_("V", "N", &n, &h__[h_offset], lda, &wr1[1], &wi1[1], &
+ lre[lre_offset], ldlre, dum, &c__1, &work[1], &nnwork,
+ &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "DGEEV4", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Do Test (5) again */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ if (wr[j] != wr1[j] || wi[j] != wi1[j]) {
+ result[5] = ulpinv;
+ }
+/* L190: */
+ }
+
+/* Do Test (7) */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ if (vl[j + jj * vl_dim1] != lre[j + jj * lre_dim1]) {
+ result[7] = ulpinv;
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L220:
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 7; ++j) {
+ if (result[j] >= 0.) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L230: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___48.ciunit = *nounit;
+ s_wsfe(&io___48);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ e_wsfe();
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ e_wsfe();
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ e_wsfe();
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ntestf = 2;
+ }
+
+ for (j = 1; j <= 7; ++j) {
+ if (result[j] >= *thresh) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+/* L240: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+
+/* L250: */
+ }
+L260:
+ ;
+ }
+/* L270: */
+ }
+
+/* Summary */
+
+ dlasum_(path, nounit, &nerrs, &ntestt);
+
+
+
+ return 0;
+
+/* End of DDRVEV */
+
+} /* ddrvev_ */
diff --git a/TESTING/EIG/ddrvgg.c b/TESTING/EIG/ddrvgg.c
new file mode 100644
index 0000000..f8da8f1
--- /dev/null
+++ b/TESTING/EIG/ddrvgg.c
@@ -0,0 +1,1192 @@
+/* ddrvgg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__4 = 4;
+static doublereal c_b36 = 0.;
+static integer c__2 = 2;
+static doublereal c_b42 = 1.;
+static integer c__3 = 3;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int ddrvgg_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, doublereal *
+ thrshn, integer *nounit, doublereal *a, integer *lda, doublereal *b,
+ doublereal *s, doublereal *t, doublereal *s2, doublereal *t2,
+ doublereal *q, integer *ldq, doublereal *z__, doublereal *alphr1,
+ doublereal *alphi1, doublereal *beta1, doublereal *alphr2, doublereal
+ *alphi2, doublereal *beta2, doublereal *vl, doublereal *vr,
+ doublereal *work, integer *lwork, doublereal *result, integer *info)
+{
+ /* Initialized data */
+
+ static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
+ 2,2,2,3 };
+ static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
+ 2,3,2,1 };
+ static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
+ 1,1,1,1 };
+ static integer iasign[26] = { 0,0,0,0,0,0,2,0,2,2,0,0,2,2,2,0,2,0,0,0,2,2,
+ 2,2,2,0 };
+ static integer ibsign[26] = { 0,0,0,0,0,0,0,2,0,0,2,2,0,0,2,0,2,0,0,0,0,0,
+ 0,0,0,0 };
+ static integer kz1[6] = { 0,1,2,1,3,3 };
+ static integer kz2[6] = { 0,0,1,2,1,1 };
+ static integer kadd[6] = { 0,0,0,0,3,2 };
+ static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
+ 4,4,4,0 };
+ static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
+ 8,8,8,8,8,0 };
+ static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
+ 3,3,3,1 };
+ static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
+ 4,4,4,1 };
+ static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
+ 3,3,2,1 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 DDRVGG: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9997[] = "(\002 DDRVGG: DGET53 returned INFO=\002,i1,"
+ "\002 for eigenvalue \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JT"
+ "YPE=\002,i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9996[] = "(\002 DDRVGG: S not in Schur form at eigenvalu"
+ "e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, "
+ "ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 DDRVGG: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
+ "i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9995[] = "(/1x,a3,\002 -- Real Generalized eigenvalue pr"
+ "oblem driver\002)";
+ static char fmt_9994[] = "(\002 Matrix types (see DDRVGG for details):"
+ " \002)";
+ static char fmt_9993[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
+ "osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
+ ") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
+ "onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
+ "I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
+ "arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
+ "(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
+ "=(D, reversed D)\002)";
+ static char fmt_9992[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
+ "atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
+ " 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
+ "ha&beta \002,\002 20=arithmetic alpha, beta=0,"
+ "1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
+ "=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
+ "/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
+ "l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
+ ".\002)";
+ static char fmt_9991[] = "(/\002 Tests performed: (S is Schur, T is tri"
+ "angular, \002,\002Q and Z are \002,a,\002,\002,/20x,\002l and r "
+ "are the appropriate left and right\002,/19x,\002eigenvectors, re"
+ "sp., a is alpha, b is beta, and\002,/19x,a,\002 means \002,a,"
+ "\002.)\002,/\002 1 = | A - Q S Z\002,a,\002 | / ( |A| n ulp ) "
+ " 2 = | B - Q T Z\002,a,\002 | / ( |B| n ulp )\002,/\002 3 = | "
+ "I - QQ\002,a,\002 | / ( n ulp ) 4 = | I - ZZ\002,a"
+ ",\002 | / ( n ulp )\002,/\002 5 = difference between (alpha,beta"
+ ") and diagonals of\002,\002 (S,T)\002,/\002 6 = max | ( b A - a "
+ "B )\002,a,\002 l | / const. 7 = max | ( b A - a B ) r | / cons"
+ "t.\002,/1x)";
+ static char fmt_9990[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
+ ",0p,f8.2)";
+ static char fmt_9989[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
+ ",1p,d10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1,
+ s_offset, s2_dim1, s2_offset, t_dim1, t_offset, t2_dim1,
+ t2_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, z_dim1,
+ z_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer j, n, i1, n1, jc, nb, in, jr, ns, nbz;
+ doublereal ulp;
+ integer iadd, nmax;
+ doublereal temp1, temp2;
+ logical badnn;
+ extern /* Subroutine */ int dgegs_(char *, char *, integer *, doublereal *
+, integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, integer *), dget51_(
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *), dgegv_(char *, char *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *),
+ dget52_(logical *, integer *, doublereal *, integer *, doublereal
+ *, integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *), dget53_(doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *);
+ doublereal dumma[4];
+ integer iinfo;
+ doublereal rmagn[4];
+ integer nmats, jsize, nerrs, jtype, ntest;
+ extern /* Subroutine */ int dlatm4_(integer *, integer *, integer *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, integer *), dorm2r_(char *,
+ char *, integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *), dlabad_(doublereal *, doublereal *);
+ logical ilabad;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *);
+ extern doublereal dlarnd_(integer *, integer *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ doublereal safmin, safmax;
+ integer ioldsd[4];
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *), dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ doublereal ulpinv;
+ integer lwkopt, mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9989, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVGG checks the nonsymmetric generalized eigenvalue driver */
+/* routines. */
+/* T T T */
+/* DGEGS factors A and B as Q S Z and Q T Z , where means */
+/* transpose, T is upper triangular, S is in generalized Schur form */
+/* (block upper triangular, with 1x1 and 2x2 blocks on the diagonal, */
+/* the 2x2 blocks corresponding to complex conjugate pairs of */
+/* generalized eigenvalues), and Q and Z are orthogonal. It also */
+/* computes the generalized eigenvalues (alpha(1),beta(1)), ..., */
+/* (alpha(n),beta(n)), where alpha(j)=S(j,j) and beta(j)=P(j,j) -- */
+/* thus, w(j) = alpha(j)/beta(j) is a root of the generalized */
+/* eigenvalue problem */
+
+/* det( A - w(j) B ) = 0 */
+
+/* and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent */
+/* problem */
+
+/* det( m(j) A - B ) = 0 */
+
+/* DGEGV computes the generalized eigenvalues (alpha(1),beta(1)), ..., */
+/* (alpha(n),beta(n)), the matrix L whose columns contain the */
+/* generalized left eigenvectors l, and the matrix R whose columns */
+/* contain the generalized right eigenvectors r for the pair (A,B). */
+
+/* When DDRVGG is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 7 */
+/* tests will be performed and compared with the threshhold THRESH: */
+
+/* Results from DGEGS: */
+
+/* T */
+/* (1) | A - Q S Z | / ( |A| n ulp ) */
+
+/* T */
+/* (2) | B - Q T Z | / ( |B| n ulp ) */
+
+/* T */
+/* (3) | I - QQ | / ( n ulp ) */
+
+/* T */
+/* (4) | I - ZZ | / ( n ulp ) */
+
+/* (5) maximum over j of D(j) where: */
+
+/* if alpha(j) is real: */
+/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
+/* D(j) = ------------------------ + ----------------------- */
+/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
+
+/* if alpha(j) is complex: */
+/* | det( s S - w T ) | */
+/* D(j) = --------------------------------------------------- */
+/* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T ) */
+
+/* and S and T are here the 2 x 2 diagonal blocks of S and T */
+/* corresponding to the j-th eigenvalue. */
+
+/* Results from DGEGV: */
+
+/* (6) max over all left eigenvalue/-vector pairs (beta/alpha,l) of */
+
+/* | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) ) */
+
+/* where l**H is the conjugate tranpose of l. */
+
+/* (7) max over all right eigenvalue/-vector pairs (beta/alpha,r) of */
+
+/* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) ) */
+
+/* Test Matrices */
+/* ---- -------- */
+
+/* The sizes of the test matrices are specified by an array */
+/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
+/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) ( 0, 0 ) (a pair of zero matrices) */
+
+/* (2) ( I, 0 ) (an identity and a zero matrix) */
+
+/* (3) ( 0, I ) (an identity and a zero matrix) */
+
+/* (4) ( I, I ) (a pair of identity matrices) */
+
+/* t t */
+/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
+
+/* t ( I 0 ) */
+/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
+/* ( 0 I ) ( 0 J ) */
+/* and I is a k x k identity and J a (k+1)x(k+1) */
+/* Jordan block; k=(N-1)/2 */
+
+/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
+/* matrix with those diagonal entries.) */
+/* (8) ( I, D ) */
+
+/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
+
+/* (10) ( small*D, big*I ) */
+
+/* (11) ( big*I, small*D ) */
+
+/* (12) ( small*I, big*D ) */
+
+/* (13) ( big*D, big*I ) */
+
+/* (14) ( small*D, small*I ) */
+
+/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
+/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
+/* t t */
+/* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. */
+
+/* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices */
+/* with random O(1) entries above the diagonal */
+/* and diagonal entries diag(T1) = */
+/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
+/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
+
+/* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
+/* s = machine precision. */
+
+/* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
+
+/* N-5 */
+/* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+
+/* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+/* where r1,..., r(N-4) are random. */
+
+/* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular */
+/* matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* DDRVGG does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, DDRVGG */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to DDRVGG to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error is */
+/* scaled to be O(1), so THRESH should be a reasonably small */
+/* multiple of 1, e.g., 10 or 100. In particular, it should */
+/* not depend on the precision (single vs. double) or the size */
+/* of the matrix. It must be at least zero. */
+
+/* THRSHN (input) DOUBLE PRECISION */
+/* Threshhold for reporting eigenvector normalization error. */
+/* If the normalization of any eigenvector differs from 1 by */
+/* more than THRSHN*ulp, then a special error message will be */
+/* printed. (This is handled separately from the other tests, */
+/* since only a compiler or programming error should cause an */
+/* error message, at least if THRSHN is at least 5--10.) */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace) DOUBLE PRECISION array, dimension */
+/* (LDA, max(NN)) */
+/* Used to hold the original A matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, S, T, S2, and T2. */
+/* It must be at least 1 and at least max( NN ). */
+
+/* B (input/workspace) DOUBLE PRECISION array, dimension */
+/* (LDA, max(NN)) */
+/* Used to hold the original B matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* S (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) */
+/* The Schur form matrix computed from A by DGEGS. On exit, S */
+/* contains the Schur form matrix corresponding to the matrix */
+/* in A. */
+
+/* T (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from B by DGEGS. */
+
+/* S2 (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) */
+/* The matrix computed from A by DGEGV. This will be the */
+/* Schur form of some matrix related to A, but will not, in */
+/* general, be the same as S. */
+
+/* T2 (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) */
+/* The matrix computed from B by DGEGV. This will be the */
+/* Schur form of some matrix related to B, but will not, in */
+/* general, be the same as T. */
+
+/* Q (workspace) DOUBLE PRECISION array, dimension (LDQ, max(NN)) */
+/* The (left) orthogonal matrix computed by DGEGS. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of Q, Z, VL, and VR. It must */
+/* be at least 1 and at least max( NN ). */
+
+/* Z (workspace) DOUBLE PRECISION array of */
+/* dimension( LDQ, max(NN) ) */
+/* The (right) orthogonal matrix computed by DGEGS. */
+
+/* ALPHR1 (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* ALPHI1 (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* BETA1 (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+
+/* The generalized eigenvalues of (A,B) computed by DGEGS. */
+/* ( ALPHR1(k)+ALPHI1(k)*i ) / BETA1(k) is the k-th */
+/* generalized eigenvalue of the matrices in A and B. */
+
+/* ALPHR2 (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* ALPHI2 (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* BETA2 (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+
+/* The generalized eigenvalues of (A,B) computed by DGEGV. */
+/* ( ALPHR2(k)+ALPHI2(k)*i ) / BETA2(k) is the k-th */
+/* generalized eigenvalue of the matrices in A and B. */
+
+/* VL (workspace) DOUBLE PRECISION array, dimension (LDQ, max(NN)) */
+/* The (block lower triangular) left eigenvector matrix for */
+/* the matrices in A and B. (See DTGEVC for the format.) */
+
+/* VR (workspace) DOUBLE PRECISION array, dimension (LDQ, max(NN)) */
+/* The (block upper triangular) right eigenvector matrix for */
+/* the matrices in A and B. (See DTGEVC for the format.) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 2*N + MAX( 6*N, N*(NB+1), (k+1)*(2*k+N+1) ), where */
+/* "k" is the sum of the blocksize and number-of-shifts for */
+/* DHGEQZ, and NB is the greatest of the blocksizes for */
+/* DGEQRF, DORMQR, and DORGQR. (The blocksizes and the */
+/* number-of-shifts are retrieved through calls to ILAENV.) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (15) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: A routine returned an error code. INFO is the */
+/* absolute value of the INFO value returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ t2_dim1 = *lda;
+ t2_offset = 1 + t2_dim1;
+ t2 -= t2_offset;
+ s2_dim1 = *lda;
+ s2_offset = 1 + s2_dim1;
+ s2 -= s2_offset;
+ t_dim1 = *lda;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ s_dim1 = *lda;
+ s_offset = 1 + s_dim1;
+ s -= s_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ vr_dim1 = *ldq;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ vl_dim1 = *ldq;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ z_dim1 = *ldq;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --alphr1;
+ --alphi1;
+ --beta1;
+ --alphr2;
+ --alphi2;
+ --beta2;
+ --work;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Maximum blocksize and shift -- we assume that blocksize and number */
+/* of shifts are monotone increasing functions of N. */
+
+/* Computing MAX */
+ i__1 = 1, i__2 = ilaenv_(&c__1, "DGEQRF", " ", &nmax, &nmax, &c_n1, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
+ c__1, "DORMQR", "LT", &nmax, &nmax, &nmax, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&c__1, "DORGQR",
+ " ", &nmax, &nmax, &nmax, &c_n1);
+ nb = max(i__1,i__2);
+ nbz = ilaenv_(&c__1, "DHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0);
+ ns = ilaenv_(&c__4, "DHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0);
+ i1 = nbz + ns;
+/* Computing MAX */
+ i__1 = nmax * 6, i__2 = nmax * (nb + 1), i__1 = max(i__1,i__2), i__2 = ((
+ i1 << 1) + nmax + 1) * (i1 + 1);
+ lwkopt = (nmax << 1) + max(i__1,i__2);
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.) {
+ *info = -6;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -10;
+ } else if (*ldq <= 1 || *ldq < nmax) {
+ *info = -19;
+ } else if (lwkopt > *lwork) {
+ *info = -30;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DDRVGG", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+ safmin = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ safmin /= ulp;
+ safmax = 1. / safmin;
+ dlabad_(&safmin, &safmax);
+ ulpinv = 1. / ulp;
+
+/* The values RMAGN(2:3) depend on N, see below. */
+
+ rmagn[0] = 0.;
+ rmagn[1] = 1.;
+
+/* Loop over sizes, types */
+
+ ntestt = 0;
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ n1 = max(1,n);
+ rmagn[2] = safmax * ulp / (doublereal) n1;
+ rmagn[3] = safmin * ulpinv * n1;
+
+ if (*nsizes != 1) {
+ mtypes = min(26,*ntypes);
+ } else {
+ mtypes = min(27,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L160;
+ }
+ ++nmats;
+ ntest = 0;
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 15; ++j) {
+ result[j] = 0.;
+/* L30: */
+ }
+
+/* Compute A and B */
+
+/* Description of control parameters: */
+
+/* KZLASS: =1 means w/o rotation, =2 means w/ rotation, */
+/* =3 means random. */
+/* KATYPE: the "type" to be passed to DLATM4 for computing A. */
+/* KAZERO: the pattern of zeros on the diagonal for A: */
+/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
+/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
+/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
+/* non-zero entries.) */
+/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
+/* =2: large, =3: small. */
+/* IASIGN: 1 if the diagonal elements of A are to be */
+/* multiplied by a random magnitude 1 number, =2 if */
+/* randomly chosen diagonal blocks are to be rotated */
+/* to form 2x2 blocks. */
+/* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B. */
+/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
+/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
+/* RMAGN: used to implement KAMAGN and KBMAGN. */
+
+ if (mtypes > 26) {
+ goto L110;
+ }
+ iinfo = 0;
+ if (kclass[jtype - 1] < 3) {
+
+/* Generate A (w/o rotation) */
+
+ if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ dlaset_("Full", &n, &n, &c_b36, &c_b36, &a[a_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ dlatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
+ &kz2[kazero[jtype - 1] - 1], &iasign[jtype - 1], &
+ rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
+ 1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
+ a_offset], lda);
+ iadd = kadd[kazero[jtype - 1] - 1];
+ if (iadd > 0 && iadd <= n) {
+ a[iadd + iadd * a_dim1] = 1.;
+ }
+
+/* Generate B (w/o rotation) */
+
+ if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ dlaset_("Full", &n, &n, &c_b36, &c_b36, &b[b_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ dlatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
+ &kz2[kbzero[jtype - 1] - 1], &ibsign[jtype - 1], &
+ rmagn[kbmagn[jtype - 1]], &c_b42, &rmagn[ktrian[jtype
+ - 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
+ b_offset], lda);
+ iadd = kadd[kbzero[jtype - 1] - 1];
+ if (iadd != 0 && iadd <= n) {
+ b[iadd + iadd * b_dim1] = 1.;
+ }
+
+ if (kclass[jtype - 1] == 2 && n > 0) {
+
+/* Include rotations */
+
+/* Generate Q, Z as Householder transformations times */
+/* a diagonal matrix. */
+
+ i__3 = n - 1;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = jc; jr <= i__4; ++jr) {
+ q[jr + jc * q_dim1] = dlarnd_(&c__3, &iseed[1]);
+ z__[jr + jc * z_dim1] = dlarnd_(&c__3, &iseed[1]);
+/* L40: */
+ }
+ i__4 = n + 1 - jc;
+ dlarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc *
+ q_dim1], &c__1, &work[jc]);
+ work[(n << 1) + jc] = d_sign(&c_b42, &q[jc + jc *
+ q_dim1]);
+ q[jc + jc * q_dim1] = 1.;
+ i__4 = n + 1 - jc;
+ dlarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 +
+ jc * z_dim1], &c__1, &work[n + jc]);
+ work[n * 3 + jc] = d_sign(&c_b42, &z__[jc + jc *
+ z_dim1]);
+ z__[jc + jc * z_dim1] = 1.;
+/* L50: */
+ }
+ q[n + n * q_dim1] = 1.;
+ work[n] = 0.;
+ d__1 = dlarnd_(&c__2, &iseed[1]);
+ work[n * 3] = d_sign(&c_b42, &d__1);
+ z__[n + n * z_dim1] = 1.;
+ work[n * 2] = 0.;
+ d__1 = dlarnd_(&c__2, &iseed[1]);
+ work[n * 4] = d_sign(&c_b42, &d__1);
+
+/* Apply the diagonal matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ a[jr + jc * a_dim1] = work[(n << 1) + jr] * work[
+ n * 3 + jc] * a[jr + jc * a_dim1];
+ b[jr + jc * b_dim1] = work[(n << 1) + jr] * work[
+ n * 3 + jc] * b[jr + jc * b_dim1];
+/* L60: */
+ }
+/* L70: */
+ }
+ i__3 = n - 1;
+ dorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ dorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &a[a_offset], lda, &work[(n << 1) +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ dorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &b[b_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ dorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &b[b_offset], lda, &work[(n << 1) +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ }
+ } else {
+
+/* Random matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ a[jr + jc * a_dim1] = rmagn[kamagn[jtype - 1]] *
+ dlarnd_(&c__2, &iseed[1]);
+ b[jr + jc * b_dim1] = rmagn[kbmagn[jtype - 1]] *
+ dlarnd_(&c__2, &iseed[1]);
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+
+L100:
+
+ if (iinfo != 0) {
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L110:
+
+/* Call DGEGS to compute H, T, Q, Z, alpha, and beta. */
+
+ dlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ dlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ ntest = 1;
+ result[1] = ulpinv;
+
+ dgegs_("V", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
+ alphr1[1], &alphi1[1], &beta1[1], &q[q_offset], ldq, &z__[
+ z_offset], ldq, &work[1], lwork, &iinfo);
+ if (iinfo != 0) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "DGEGS", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L140;
+ }
+
+ ntest = 4;
+
+/* Do tests 1--4 */
+
+ dget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, &q[
+ q_offset], ldq, &z__[z_offset], ldq, &work[1], &result[1])
+ ;
+ dget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
+ q_offset], ldq, &z__[z_offset], ldq, &work[1], &result[2])
+ ;
+ dget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
+ q_offset], ldq, &q[q_offset], ldq, &work[1], &result[3]);
+ dget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[
+ z_offset], ldq, &z__[z_offset], ldq, &work[1], &result[4])
+ ;
+
+/* Do test 5: compare eigenvalues with diagonals. */
+/* Also check Schur form of A. */
+
+ temp1 = 0.;
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ ilabad = FALSE_;
+ if (alphi1[j] == 0.) {
+/* Computing MAX */
+ d__7 = safmin, d__8 = (d__2 = alphr1[j], abs(d__2)), d__7
+ = max(d__7,d__8), d__8 = (d__3 = s[j + j * s_dim1]
+ , abs(d__3));
+/* Computing MAX */
+ d__9 = safmin, d__10 = (d__5 = beta1[j], abs(d__5)), d__9
+ = max(d__9,d__10), d__10 = (d__6 = t[j + j *
+ t_dim1], abs(d__6));
+ temp2 = ((d__1 = alphr1[j] - s[j + j * s_dim1], abs(d__1))
+ / max(d__7,d__8) + (d__4 = beta1[j] - t[j + j *
+ t_dim1], abs(d__4)) / max(d__9,d__10)) / ulp;
+ if (j < n) {
+ if (s[j + 1 + j * s_dim1] != 0.) {
+ ilabad = TRUE_;
+ }
+ }
+ if (j > 1) {
+ if (s[j + (j - 1) * s_dim1] != 0.) {
+ ilabad = TRUE_;
+ }
+ }
+ } else {
+ if (alphi1[j] > 0.) {
+ i1 = j;
+ } else {
+ i1 = j - 1;
+ }
+ if (i1 <= 0 || i1 >= n) {
+ ilabad = TRUE_;
+ } else if (i1 < n - 1) {
+ if (s[i1 + 2 + (i1 + 1) * s_dim1] != 0.) {
+ ilabad = TRUE_;
+ }
+ } else if (i1 > 1) {
+ if (s[i1 + (i1 - 1) * s_dim1] != 0.) {
+ ilabad = TRUE_;
+ }
+ }
+ if (! ilabad) {
+ dget53_(&s[i1 + i1 * s_dim1], lda, &t[i1 + i1 *
+ t_dim1], lda, &beta1[j], &alphr1[j], &alphi1[
+ j], &temp2, &iinfo);
+ if (iinfo >= 3) {
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ }
+ } else {
+ temp2 = ulpinv;
+ }
+ }
+ temp1 = max(temp1,temp2);
+ if (ilabad) {
+ io___48.ciunit = *nounit;
+ s_wsfe(&io___48);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ }
+/* L120: */
+ }
+ result[5] = temp1;
+
+/* Call DGEGV to compute S2, T2, VL, and VR, do tests. */
+
+/* Eigenvalues and Eigenvectors */
+
+ dlacpy_(" ", &n, &n, &a[a_offset], lda, &s2[s2_offset], lda);
+ dlacpy_(" ", &n, &n, &b[b_offset], lda, &t2[t2_offset], lda);
+ ntest = 6;
+ result[6] = ulpinv;
+
+ dgegv_("V", "V", &n, &s2[s2_offset], lda, &t2[t2_offset], lda, &
+ alphr2[1], &alphi2[1], &beta2[1], &vl[vl_offset], ldq, &
+ vr[vr_offset], ldq, &work[1], lwork, &iinfo);
+ if (iinfo != 0) {
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ do_fio(&c__1, "DGEGV", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L140;
+ }
+
+ ntest = 7;
+
+/* Do Tests 6 and 7 */
+
+ dget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &vl[
+ vl_offset], ldq, &alphr2[1], &alphi2[1], &beta2[1], &work[
+ 1], dumma);
+ result[6] = dumma[0];
+ if (dumma[1] > *thrshn) {
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "DGEGV", (ftnlen)5);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ dget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &vr[
+ vr_offset], ldq, &alphr2[1], &alphi2[1], &beta2[1], &work[
+ 1], dumma);
+ result[7] = dumma[0];
+ if (dumma[1] > *thresh) {
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "DGEGV", (ftnlen)5);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Check form of Complex eigenvalues. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ ilabad = FALSE_;
+ if (alphi2[j] > 0.) {
+ if (j == n) {
+ ilabad = TRUE_;
+ } else if (alphi2[j + 1] >= 0.) {
+ ilabad = TRUE_;
+ }
+ } else if (alphi2[j] < 0.) {
+ if (j == 1) {
+ ilabad = TRUE_;
+ } else if (alphi2[j - 1] <= 0.) {
+ ilabad = TRUE_;
+ }
+ }
+ if (ilabad) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ }
+/* L130: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L140:
+
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__3 = ntest;
+ for (jr = 1; jr <= i__3; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ do_fio(&c__1, "DGG", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+ e_wsfe();
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ e_wsfe();
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, "Orthogonal", (ftnlen)10);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ do_fio(&c__1, "orthogonal", (ftnlen)10);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ for (j = 1; j <= 5; ++j) {
+ do_fio(&c__1, "'", (ftnlen)1);
+ }
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[jr] < 1e4) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ } else {
+ io___60.ciunit = *nounit;
+ s_wsfe(&io___60);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+ }
+/* L150: */
+ }
+
+L160:
+ ;
+ }
+/* L170: */
+ }
+
+/* Summary */
+
+ alasvm_("DGG", nounit, &nerrs, &ntestt, &c__0);
+ return 0;
+
+
+
+
+
+
+
+
+
+/* End of DDRVGG */
+
+} /* ddrvgg_ */
diff --git a/TESTING/EIG/ddrvsg.c b/TESTING/EIG/ddrvsg.c
new file mode 100644
index 0000000..e50b28d
--- /dev/null
+++ b/TESTING/EIG/ddrvsg.c
@@ -0,0 +1,1893 @@
+/* ddrvsg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b18 = 0.;
+static integer c__0 = 0;
+static integer c__6 = 6;
+static doublereal c_b35 = 1.;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c__5 = 5;
+static doublereal c_b82 = 10.;
+static integer c__3 = 3;
+
+/* Subroutine */ int ddrvsg_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
+ d__, doublereal *z__, integer *ldz, doublereal *ab, doublereal *bb,
+ doublereal *ap, doublereal *bp, doublereal *work, integer *nwork,
+ integer *iwork, integer *liwork, doublereal *result, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,4,4,4,4,4,5,5,5,5,5,8,8,8,9,9,9,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3,1,1,1,1,1,1 };
+ static integer kmode[21] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0,4,4,4,4,4,4 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 DDRVSG: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+
+ /* System generated locals */
+ address a__1[3];
+ integer a_dim1, a_offset, ab_dim1, ab_offset, b_dim1, b_offset, bb_dim1,
+ bb_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6[3]
+ , i__7;
+ char ch__1[10], ch__2[11], ch__3[12], ch__4[13];
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, m, n, ka, kb, ij, il, iu;
+ doublereal vl, vu;
+ integer ka9, kb9;
+ doublereal ulp, cond;
+ integer jcol, nmax;
+ doublereal unfl, ovfl;
+ char uplo[1];
+ logical badnn;
+ integer imode;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dsgt01_(integer *, char *, integer *, integer
+ *, doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *);
+ integer iinfo;
+ extern /* Subroutine */ int dsbgv_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *);
+ doublereal aninv, anorm;
+ integer itemp, nmats;
+ extern /* Subroutine */ int dspgv_(integer *, char *, char *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer jsize, nerrs, itype, jtype, ntest;
+ extern /* Subroutine */ int dsygv_(integer *, char *, char *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *);
+ integer iseed2[4];
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *), dlarnd_(integer *, integer *);
+ extern /* Subroutine */ int dsbgvd_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *, integer *);
+ integer idumma[1];
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int dlafts_(char *, integer *, integer *, integer
+ *, integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *), dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *), dlatmr_(integer *, integer *,
+ char *, integer *, char *, doublereal *, integer *, doublereal *,
+ doublereal *, char *, char *, doublereal *, integer *, doublereal
+ *, doublereal *, integer *, doublereal *, char *, integer *,
+ integer *, integer *, doublereal *, doublereal *, char *,
+ doublereal *, integer *, integer *, integer *);
+ doublereal abstol;
+ extern /* Subroutine */ int dlasum_(char *, integer *, integer *, integer
+ *), dlatms_(integer *, integer *, char *, integer *, char
+ *, doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublereal *, integer *, doublereal *,
+ integer *), dspgvd_(integer *, char *,
+ char *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *, integer *);
+ integer ibuplo, ibtype;
+ extern /* Subroutine */ int dsbgvx_(char *, char *, char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *), dsygvd_(integer *, char *,
+ char *, integer *, doublereal *, integer *, doublereal *, integer
+ *, doublereal *, doublereal *, integer *, integer *, integer *,
+ integer *);
+ doublereal rtunfl, rtovfl, ulpinv;
+ extern /* Subroutine */ int dspgvx_(integer *, char *, char *, char *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *);
+ integer mtypes, ntestt;
+ extern /* Subroutine */ int dsygvx_(integer *, char *, char *, char *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, integer *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* ****************************************************************** */
+
+/* modified August 1997, a new parameter LIWORK is added */
+/* in the calling sequence. */
+
+/* test routine DDGT01 is also modified */
+
+/* ****************************************************************** */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVSG checks the real symmetric generalized eigenproblem */
+/* drivers. */
+
+/* DSYGV computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric-definite generalized */
+/* eigenproblem. */
+
+/* DSYGVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric-definite generalized */
+/* eigenproblem using a divide and conquer algorithm. */
+
+/* DSYGVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric-definite generalized */
+/* eigenproblem. */
+
+/* DSPGV computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric-definite generalized */
+/* eigenproblem in packed storage. */
+
+/* DSPGVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric-definite generalized */
+/* eigenproblem in packed storage using a divide and */
+/* conquer algorithm. */
+
+/* DSPGVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric-definite generalized */
+/* eigenproblem in packed storage. */
+
+/* DSBGV computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric-definite banded */
+/* generalized eigenproblem. */
+
+/* DSBGVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric-definite banded */
+/* generalized eigenproblem using a divide and conquer */
+/* algorithm. */
+
+/* DSBGVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric-definite banded */
+/* generalized eigenproblem. */
+
+/* When DDRVSG is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix A of the given type will be */
+/* generated; a random well-conditioned matrix B is also generated */
+/* and the pair (A,B) is used to test the drivers. */
+
+/* For each pair (A,B), the following tests are performed: */
+
+/* (1) DSYGV with ITYPE = 1 and UPLO ='U': */
+
+/* | A Z - B Z D | / ( |A| |Z| n ulp ) */
+
+/* (2) as (1) but calling DSPGV */
+/* (3) as (1) but calling DSBGV */
+/* (4) as (1) but with UPLO = 'L' */
+/* (5) as (4) but calling DSPGV */
+/* (6) as (4) but calling DSBGV */
+
+/* (7) DSYGV with ITYPE = 2 and UPLO ='U': */
+
+/* | A B Z - Z D | / ( |A| |Z| n ulp ) */
+
+/* (8) as (7) but calling DSPGV */
+/* (9) as (7) but with UPLO = 'L' */
+/* (10) as (9) but calling DSPGV */
+
+/* (11) DSYGV with ITYPE = 3 and UPLO ='U': */
+
+/* | B A Z - Z D | / ( |A| |Z| n ulp ) */
+
+/* (12) as (11) but calling DSPGV */
+/* (13) as (11) but with UPLO = 'L' */
+/* (14) as (13) but calling DSPGV */
+
+/* DSYGVD, DSPGVD and DSBGVD performed the same 14 tests. */
+
+/* DSYGVX, DSPGVX and DSBGVX performed the above 14 tests with */
+/* the parameter RANGE = 'A', 'N' and 'I', respectively. */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value */
+/* of each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* This type is used for the matrix A which has half-bandwidth KA. */
+/* B is generated as a well-conditioned positive definite matrix */
+/* with half-bandwidth KB (<= KA). */
+/* Currently, the list of possible types for A is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" entries */
+/* 1, ULP, ..., ULP and random signs. */
+
+/* (6) Same as (4), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (4), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U* D U, where U is orthogonal and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U* D U, where U is orthogonal and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U* D U, where U is orthogonal and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) symmetric matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold) */
+
+/* (16) Same as (8), but with KA = 1 and KB = 1 */
+/* (17) Same as (8), but with KA = 2 and KB = 1 */
+/* (18) Same as (8), but with KA = 2 and KB = 2 */
+/* (19) Same as (8), but with KA = 3 and KB = 1 */
+/* (20) Same as (8), but with KA = 3 and KB = 2 */
+/* (21) Same as (8), but with KA = 3 and KB = 3 */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* DDRVSG does nothing. It must be at least zero. */
+/* Not modified. */
+
+/* NN INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+/* Not modified. */
+
+/* NTYPES INTEGER */
+/* The number of elements in DOTYPE. If it is zero, DDRVSG */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+/* Not modified. */
+
+/* DOTYPE LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+/* Not modified. */
+
+/* ISEED INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to DDRVSG to continue the same random number */
+/* sequence. */
+/* Modified. */
+
+/* THRESH DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+/* Not modified. */
+
+/* NOUNIT INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+/* Not modified. */
+
+/* A DOUBLE PRECISION array, dimension (LDA , max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually */
+/* used. */
+/* Modified. */
+
+/* LDA INTEGER */
+/* The leading dimension of A and AB. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* B DOUBLE PRECISION array, dimension (LDB , max(NN)) */
+/* Used to hold the symmetric positive definite matrix for */
+/* the generailzed problem. */
+/* On exit, B contains the last matrix actually */
+/* used. */
+/* Modified. */
+
+/* LDB INTEGER */
+/* The leading dimension of B and BB. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* D DOUBLE PRECISION array, dimension (max(NN)) */
+/* The eigenvalues of A. On exit, the eigenvalues in D */
+/* correspond with the matrix in A. */
+/* Modified. */
+
+/* Z DOUBLE PRECISION array, dimension (LDZ, max(NN)) */
+/* The matrix of eigenvectors. */
+/* Modified. */
+
+/* LDZ INTEGER */
+/* The leading dimension of Z. It must be at least 1 and */
+/* at least max( NN ). */
+/* Not modified. */
+
+/* AB DOUBLE PRECISION array, dimension (LDA, max(NN)) */
+/* Workspace. */
+/* Modified. */
+
+/* BB DOUBLE PRECISION array, dimension (LDB, max(NN)) */
+/* Workspace. */
+/* Modified. */
+
+/* AP DOUBLE PRECISION array, dimension (max(NN)**2) */
+/* Workspace. */
+/* Modified. */
+
+/* BP DOUBLE PRECISION array, dimension (max(NN)**2) */
+/* Workspace. */
+/* Modified. */
+
+/* WORK DOUBLE PRECISION array, dimension (NWORK) */
+/* Workspace. */
+/* Modified. */
+
+/* NWORK INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 1+5*N+2*N*lg(N)+3*N**2 where N = max( NN(j) ) and */
+/* lg( N ) = smallest integer k such that 2**k >= N. */
+/* Not modified. */
+
+/* IWORK INTEGER array, dimension (LIWORK) */
+/* Workspace. */
+/* Modified. */
+
+/* LIWORK INTEGER */
+/* The number of entries in WORK. This must be at least 6*N. */
+/* Not modified. */
+
+/* RESULT DOUBLE PRECISION array, dimension (70) */
+/* The values computed by the 70 tests described above. */
+/* Modified. */
+
+/* INFO INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -5: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -16: LDZ < 1 or LDZ < NMAX. */
+/* -21: NWORK too small. */
+/* -23: LIWORK too small. */
+/* If DLATMR, SLATMS, DSYGV, DSPGV, DSBGV, SSYGVD, SSPGVD, */
+/* DSBGVD, DSYGVX, DSPGVX or SSBGVX returns an error code, */
+/* the absolute value of it is returned. */
+/* Modified. */
+
+/* ---------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests that have been run */
+/* on this matrix. */
+/* NTESTT The total number of tests for this call. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far (computed by DLAFTS). */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ ab_dim1 = *lda;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ bb_dim1 = *ldb;
+ bb_offset = 1 + bb_dim1;
+ bb -= bb_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --d__;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --ap;
+ --bp;
+ --work;
+ --iwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 0;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldz <= 1 || *ldz < nmax) {
+ *info = -16;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = max(nmax,3);
+ if (i__1 * i__1 << 1 > *nwork) {
+ *info = -21;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = max(nmax,3);
+ if (i__1 * i__1 << 1 > *liwork) {
+ *info = -23;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DDRVSG", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = dlamch_("Safe minimum");
+ ovfl = dlamch_("Overflow");
+ dlabad_(&unfl, &ovfl);
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ ulpinv = 1. / ulp;
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed2[i__ - 1] = iseed[i__];
+/* L20: */
+ }
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ aninv = 1. / (doublereal) max(1,n);
+
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ ka9 = 0;
+ kb9 = 0;
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L640;
+ }
+ ++nmats;
+ ntest = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L30: */
+ }
+
+/* 2) Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, w/ eigenvalues */
+/* =5 random log hermitian, w/ eigenvalues */
+/* =6 random (none) */
+/* =7 random diagonal */
+/* =8 random hermitian */
+/* =9 banded, w/ eigenvalues */
+
+ if (mtypes > 21) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * aninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * n * ulpinv;
+ goto L70;
+
+L70:
+
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+ if (itype == 1) {
+
+/* Zero */
+
+ ka = 0;
+ kb = 0;
+ dlaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ ka = 0;
+ kb = 0;
+ dlaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ ka = 0;
+ kb = 0;
+ dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* symmetric, eigenvalues specified */
+
+/* Computing MAX */
+ i__3 = 0, i__4 = n - 1;
+ ka = max(i__3,i__4);
+ kb = ka;
+ dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ ka = 0;
+ kb = 0;
+ dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b35,
+ &c_b35, "T", "N", &work[n + 1], &c__1, &c_b35, &work[(
+ n << 1) + 1], &c__1, &c_b35, "N", idumma, &c__0, &
+ c__0, &c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* symmetric, random eigenvalues */
+
+/* Computing MAX */
+ i__3 = 0, i__4 = n - 1;
+ ka = max(i__3,i__4);
+ kb = ka;
+ dlatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &c_b35,
+ &c_b35, "T", "N", &work[n + 1], &c__1, &c_b35, &work[(
+ n << 1) + 1], &c__1, &c_b35, "N", idumma, &n, &n, &
+ c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* symmetric banded, eigenvalues specified */
+
+/* The following values are used for the half-bandwidths: */
+
+/* ka = 1 kb = 1 */
+/* ka = 2 kb = 1 */
+/* ka = 2 kb = 2 */
+/* ka = 3 kb = 1 */
+/* ka = 3 kb = 2 */
+/* ka = 3 kb = 3 */
+
+ ++kb9;
+ if (kb9 > ka9) {
+ ++ka9;
+ kb9 = 1;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__5 = n - 1;
+ i__3 = 0, i__4 = min(i__5,ka9);
+ ka = max(i__3,i__4);
+/* Computing MAX */
+/* Computing MIN */
+ i__5 = n - 1;
+ i__3 = 0, i__4 = min(i__5,kb9);
+ kb = max(i__3,i__4);
+ dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &ka, &ka, "N", &a[a_offset], lda, &work[n + 1]
+, &iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___36.ciunit = *nounit;
+ s_wsfe(&io___36);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+ abstol = unfl + unfl;
+ if (n <= 1) {
+ il = 1;
+ iu = n;
+ } else {
+ il = (integer) ((n - 1) * dlarnd_(&c__1, iseed2) + 1);
+ iu = (integer) ((n - 1) * dlarnd_(&c__1, iseed2) + 1);
+ if (il > iu) {
+ itemp = il;
+ il = iu;
+ iu = itemp;
+ }
+ }
+
+/* 3) Call DSYGV, DSPGV, DSBGV, SSYGVD, SSPGVD, SSBGVD, */
+/* DSYGVX, DSPGVX, and DSBGVX, do tests. */
+
+/* loop over the three generalized problems */
+/* IBTYPE = 1: A*x = (lambda)*B*x */
+/* IBTYPE = 2: A*B*x = (lambda)*x */
+/* IBTYPE = 3: B*A*x = (lambda)*x */
+
+ for (ibtype = 1; ibtype <= 3; ++ibtype) {
+
+/* loop over the setting UPLO */
+
+ for (ibuplo = 1; ibuplo <= 2; ++ibuplo) {
+ if (ibuplo == 1) {
+ *(unsigned char *)uplo = 'U';
+ }
+ if (ibuplo == 2) {
+ *(unsigned char *)uplo = 'L';
+ }
+
+/* Generate random well-conditioned positive definite */
+/* matrix B, of bandwidth not greater than that of A. */
+
+ dlatms_(&n, &n, "U", &iseed[1], "P", &work[1], &c__5, &
+ c_b82, &c_b35, &kb, &kb, uplo, &b[b_offset], ldb,
+ &work[n + 1], &iinfo);
+
+/* Test DSYGV */
+
+ ++ntest;
+
+ dlacpy_(" ", &n, &n, &a[a_offset], lda, &z__[z_offset],
+ ldz);
+ dlacpy_(uplo, &n, &n, &b[b_offset], ldb, &bb[bb_offset],
+ ldb);
+
+ dsygv_(&ibtype, "V", uplo, &n, &z__[z_offset], ldz, &bb[
+ bb_offset], ldb, &d__[1], &work[1], nwork, &iinfo);
+ if (iinfo != 0) {
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "DSYGV(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L100;
+ }
+ }
+
+/* Do Test */
+
+ dsgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &result[ntest]);
+
+/* Test DSYGVD */
+
+ ++ntest;
+
+ dlacpy_(" ", &n, &n, &a[a_offset], lda, &z__[z_offset],
+ ldz);
+ dlacpy_(uplo, &n, &n, &b[b_offset], ldb, &bb[bb_offset],
+ ldb);
+
+ dsygvd_(&ibtype, "V", uplo, &n, &z__[z_offset], ldz, &bb[
+ bb_offset], ldb, &d__[1], &work[1], nwork, &iwork[
+ 1], liwork, &iinfo);
+ if (iinfo != 0) {
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "DSYGVD(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__2, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L100;
+ }
+ }
+
+/* Do Test */
+
+ dsgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &result[ntest]);
+
+/* Test DSYGVX */
+
+ ++ntest;
+
+ dlacpy_(" ", &n, &n, &a[a_offset], lda, &ab[ab_offset],
+ lda);
+ dlacpy_(uplo, &n, &n, &b[b_offset], ldb, &bb[bb_offset],
+ ldb);
+
+ dsygvx_(&ibtype, "V", "A", uplo, &n, &ab[ab_offset], lda,
+ &bb[bb_offset], ldb, &vl, &vu, &il, &iu, &abstol,
+ &m, &d__[1], &z__[z_offset], ldz, &work[1], nwork,
+ &iwork[n + 1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "DSYGVX(V,A";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L100;
+ }
+ }
+
+/* Do Test */
+
+ dsgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &result[ntest]);
+
+ ++ntest;
+
+ dlacpy_(" ", &n, &n, &a[a_offset], lda, &ab[ab_offset],
+ lda);
+ dlacpy_(uplo, &n, &n, &b[b_offset], ldb, &bb[bb_offset],
+ ldb);
+
+/* since we do not know the exact eigenvalues of this */
+/* eigenpair, we just set VL and VU as constants. */
+/* It is quite possible that there are no eigenvalues */
+/* in this interval. */
+
+ vl = 0.;
+ vu = anorm;
+ dsygvx_(&ibtype, "V", "V", uplo, &n, &ab[ab_offset], lda,
+ &bb[bb_offset], ldb, &vl, &vu, &il, &iu, &abstol,
+ &m, &d__[1], &z__[z_offset], ldz, &work[1], nwork,
+ &iwork[n + 1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSYGVX(V,V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__4, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__4, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L100;
+ }
+ }
+
+/* Do Test */
+
+ dsgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &result[ntest]);
+
+ ++ntest;
+
+ dlacpy_(" ", &n, &n, &a[a_offset], lda, &ab[ab_offset],
+ lda);
+ dlacpy_(uplo, &n, &n, &b[b_offset], ldb, &bb[bb_offset],
+ ldb);
+
+ dsygvx_(&ibtype, "V", "I", uplo, &n, &ab[ab_offset], lda,
+ &bb[bb_offset], ldb, &vl, &vu, &il, &iu, &abstol,
+ &m, &d__[1], &z__[z_offset], ldz, &work[1], nwork,
+ &iwork[n + 1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSYGVX(V,I,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__4, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__4, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L100;
+ }
+ }
+
+/* Do Test */
+
+ dsgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &result[ntest]);
+
+L100:
+
+/* Test DSPGV */
+
+ ++ntest;
+
+/* Copy the matrices into packed storage. */
+
+ if (lsame_(uplo, "U")) {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ ap[ij] = a[i__ + j * a_dim1];
+ bp[ij] = b[i__ + j * b_dim1];
+ ++ij;
+/* L110: */
+ }
+/* L120: */
+ }
+ } else {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ ap[ij] = a[i__ + j * a_dim1];
+ bp[ij] = b[i__ + j * b_dim1];
+ ++ij;
+/* L130: */
+ }
+/* L140: */
+ }
+ }
+
+ dspgv_(&ibtype, "V", uplo, &n, &ap[1], &bp[1], &d__[1], &
+ z__[z_offset], ldz, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "DSPGV(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L310;
+ }
+ }
+
+/* Do Test */
+
+ dsgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &result[ntest]);
+
+/* Test DSPGVD */
+
+ ++ntest;
+
+/* Copy the matrices into packed storage. */
+
+ if (lsame_(uplo, "U")) {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ ap[ij] = a[i__ + j * a_dim1];
+ bp[ij] = b[i__ + j * b_dim1];
+ ++ij;
+/* L150: */
+ }
+/* L160: */
+ }
+ } else {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ ap[ij] = a[i__ + j * a_dim1];
+ bp[ij] = b[i__ + j * b_dim1];
+ ++ij;
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+
+ dspgvd_(&ibtype, "V", uplo, &n, &ap[1], &bp[1], &d__[1], &
+ z__[z_offset], ldz, &work[1], nwork, &iwork[1],
+ liwork, &iinfo);
+ if (iinfo != 0) {
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "DSPGVD(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__2, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L310;
+ }
+ }
+
+/* Do Test */
+
+ dsgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &result[ntest]);
+
+/* Test DSPGVX */
+
+ ++ntest;
+
+/* Copy the matrices into packed storage. */
+
+ if (lsame_(uplo, "U")) {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ ap[ij] = a[i__ + j * a_dim1];
+ bp[ij] = b[i__ + j * b_dim1];
+ ++ij;
+/* L190: */
+ }
+/* L200: */
+ }
+ } else {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ ap[ij] = a[i__ + j * a_dim1];
+ bp[ij] = b[i__ + j * b_dim1];
+ ++ij;
+/* L210: */
+ }
+/* L220: */
+ }
+ }
+
+ dspgvx_(&ibtype, "V", "A", uplo, &n, &ap[1], &bp[1], &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &iwork[n + 1], &iwork[1]
+, info);
+ if (iinfo != 0) {
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "DSPGVX(V,A";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L310;
+ }
+ }
+
+/* Do Test */
+
+ dsgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &result[ntest]);
+
+ ++ntest;
+
+/* Copy the matrices into packed storage. */
+
+ if (lsame_(uplo, "U")) {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ ap[ij] = a[i__ + j * a_dim1];
+ bp[ij] = b[i__ + j * b_dim1];
+ ++ij;
+/* L230: */
+ }
+/* L240: */
+ }
+ } else {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ ap[ij] = a[i__ + j * a_dim1];
+ bp[ij] = b[i__ + j * b_dim1];
+ ++ij;
+/* L250: */
+ }
+/* L260: */
+ }
+ }
+
+ vl = 0.;
+ vu = anorm;
+ dspgvx_(&ibtype, "V", "V", uplo, &n, &ap[1], &bp[1], &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &iwork[n + 1], &iwork[1]
+, info);
+ if (iinfo != 0) {
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "DSPGVX(V,V";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L310;
+ }
+ }
+
+/* Do Test */
+
+ dsgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &result[ntest]);
+
+ ++ntest;
+
+/* Copy the matrices into packed storage. */
+
+ if (lsame_(uplo, "U")) {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ ap[ij] = a[i__ + j * a_dim1];
+ bp[ij] = b[i__ + j * b_dim1];
+ ++ij;
+/* L270: */
+ }
+/* L280: */
+ }
+ } else {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ ap[ij] = a[i__ + j * a_dim1];
+ bp[ij] = b[i__ + j * b_dim1];
+ ++ij;
+/* L290: */
+ }
+/* L300: */
+ }
+ }
+
+ dspgvx_(&ibtype, "V", "I", uplo, &n, &ap[1], &bp[1], &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &iwork[n + 1], &iwork[1]
+, info);
+ if (iinfo != 0) {
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "DSPGVX(V,I";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L310;
+ }
+ }
+
+/* Do Test */
+
+ dsgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &result[ntest]);
+
+L310:
+
+ if (ibtype == 1) {
+
+/* TEST DSBGV */
+
+ ++ntest;
+
+/* Copy the matrices into band storage. */
+
+ if (lsame_(uplo, "U")) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - ka;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__)
+ {
+ ab[ka + 1 + i__ - j + j * ab_dim1] = a[
+ i__ + j * a_dim1];
+/* L320: */
+ }
+/* Computing MAX */
+ i__7 = 1, i__4 = j - kb;
+ i__5 = j;
+ for (i__ = max(i__7,i__4); i__ <= i__5; ++i__)
+ {
+ bb[kb + 1 + i__ - j + j * bb_dim1] = b[
+ i__ + j * b_dim1];
+/* L330: */
+ }
+/* L340: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__7 = n, i__4 = j + ka;
+ i__5 = min(i__7,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ ab[i__ + 1 - j + j * ab_dim1] = a[i__ + j
+ * a_dim1];
+/* L350: */
+ }
+/* Computing MIN */
+ i__7 = n, i__4 = j + kb;
+ i__5 = min(i__7,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ bb[i__ + 1 - j + j * bb_dim1] = b[i__ + j
+ * b_dim1];
+/* L360: */
+ }
+/* L370: */
+ }
+ }
+
+ dsbgv_("V", uplo, &n, &ka, &kb, &ab[ab_offset], lda, &
+ bb[bb_offset], ldb, &d__[1], &z__[z_offset],
+ ldz, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "DSBGV(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L620;
+ }
+ }
+
+/* Do Test */
+
+ dsgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1],
+ &work[1], &result[ntest]);
+
+/* TEST DSBGVD */
+
+ ++ntest;
+
+/* Copy the matrices into band storage. */
+
+ if (lsame_(uplo, "U")) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__7 = j - ka;
+ i__4 = j;
+ for (i__ = max(i__5,i__7); i__ <= i__4; ++i__)
+ {
+ ab[ka + 1 + i__ - j + j * ab_dim1] = a[
+ i__ + j * a_dim1];
+/* L380: */
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kb;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__)
+ {
+ bb[kb + 1 + i__ - j + j * bb_dim1] = b[
+ i__ + j * b_dim1];
+/* L390: */
+ }
+/* L400: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + ka;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ ab[i__ + 1 - j + j * ab_dim1] = a[i__ + j
+ * a_dim1];
+/* L410: */
+ }
+/* Computing MIN */
+ i__4 = n, i__5 = j + kb;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ bb[i__ + 1 - j + j * bb_dim1] = b[i__ + j
+ * b_dim1];
+/* L420: */
+ }
+/* L430: */
+ }
+ }
+
+ dsbgvd_("V", uplo, &n, &ka, &kb, &ab[ab_offset], lda,
+ &bb[bb_offset], ldb, &d__[1], &z__[z_offset],
+ ldz, &work[1], nwork, &iwork[1], liwork, &
+ iinfo);
+ if (iinfo != 0) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "DSBGVD(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__2, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L620;
+ }
+ }
+
+/* Do Test */
+
+ dsgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1],
+ &work[1], &result[ntest]);
+
+/* Test DSBGVX */
+
+ ++ntest;
+
+/* Copy the matrices into band storage. */
+
+ if (lsame_(uplo, "U")) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__7 = 1, i__4 = j - ka;
+ i__5 = j;
+ for (i__ = max(i__7,i__4); i__ <= i__5; ++i__)
+ {
+ ab[ka + 1 + i__ - j + j * ab_dim1] = a[
+ i__ + j * a_dim1];
+/* L440: */
+ }
+/* Computing MAX */
+ i__5 = 1, i__7 = j - kb;
+ i__4 = j;
+ for (i__ = max(i__5,i__7); i__ <= i__4; ++i__)
+ {
+ bb[kb + 1 + i__ - j + j * bb_dim1] = b[
+ i__ + j * b_dim1];
+/* L450: */
+ }
+/* L460: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__5 = n, i__7 = j + ka;
+ i__4 = min(i__5,i__7);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ ab[i__ + 1 - j + j * ab_dim1] = a[i__ + j
+ * a_dim1];
+/* L470: */
+ }
+/* Computing MIN */
+ i__5 = n, i__7 = j + kb;
+ i__4 = min(i__5,i__7);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ bb[i__ + 1 - j + j * bb_dim1] = b[i__ + j
+ * b_dim1];
+/* L480: */
+ }
+/* L490: */
+ }
+ }
+
+ i__3 = max(1,n);
+ dsbgvx_("V", "A", uplo, &n, &ka, &kb, &ab[ab_offset],
+ lda, &bb[bb_offset], ldb, &bp[1], &i__3, &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &iwork[n + 1], &
+ iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___60.ciunit = *nounit;
+ s_wsfe(&io___60);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "DSBGVX(V,A";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L620;
+ }
+ }
+
+/* Do Test */
+
+ dsgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1],
+ &work[1], &result[ntest]);
+
+
+ ++ntest;
+
+/* Copy the matrices into band storage. */
+
+ if (lsame_(uplo, "U")) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - ka;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__)
+ {
+ ab[ka + 1 + i__ - j + j * ab_dim1] = a[
+ i__ + j * a_dim1];
+/* L500: */
+ }
+/* Computing MAX */
+ i__7 = 1, i__4 = j - kb;
+ i__5 = j;
+ for (i__ = max(i__7,i__4); i__ <= i__5; ++i__)
+ {
+ bb[kb + 1 + i__ - j + j * bb_dim1] = b[
+ i__ + j * b_dim1];
+/* L510: */
+ }
+/* L520: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__7 = n, i__4 = j + ka;
+ i__5 = min(i__7,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ ab[i__ + 1 - j + j * ab_dim1] = a[i__ + j
+ * a_dim1];
+/* L530: */
+ }
+/* Computing MIN */
+ i__7 = n, i__4 = j + kb;
+ i__5 = min(i__7,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ bb[i__ + 1 - j + j * bb_dim1] = b[i__ + j
+ * b_dim1];
+/* L540: */
+ }
+/* L550: */
+ }
+ }
+
+ vl = 0.;
+ vu = anorm;
+ i__3 = max(1,n);
+ dsbgvx_("V", "V", uplo, &n, &ka, &kb, &ab[ab_offset],
+ lda, &bb[bb_offset], ldb, &bp[1], &i__3, &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &iwork[n + 1], &
+ iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___61.ciunit = *nounit;
+ s_wsfe(&io___61);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "DSBGVX(V,V";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L620;
+ }
+ }
+
+/* Do Test */
+
+ dsgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1],
+ &work[1], &result[ntest]);
+
+ ++ntest;
+
+/* Copy the matrices into band storage. */
+
+ if (lsame_(uplo, "U")) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__7 = j - ka;
+ i__4 = j;
+ for (i__ = max(i__5,i__7); i__ <= i__4; ++i__)
+ {
+ ab[ka + 1 + i__ - j + j * ab_dim1] = a[
+ i__ + j * a_dim1];
+/* L560: */
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kb;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__)
+ {
+ bb[kb + 1 + i__ - j + j * bb_dim1] = b[
+ i__ + j * b_dim1];
+/* L570: */
+ }
+/* L580: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + ka;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ ab[i__ + 1 - j + j * ab_dim1] = a[i__ + j
+ * a_dim1];
+/* L590: */
+ }
+/* Computing MIN */
+ i__4 = n, i__5 = j + kb;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ bb[i__ + 1 - j + j * bb_dim1] = b[i__ + j
+ * b_dim1];
+/* L600: */
+ }
+/* L610: */
+ }
+ }
+
+ i__3 = max(1,n);
+ dsbgvx_("V", "I", uplo, &n, &ka, &kb, &ab[ab_offset],
+ lda, &bb[bb_offset], ldb, &bp[1], &i__3, &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &iwork[n + 1], &
+ iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___62.ciunit = *nounit;
+ s_wsfe(&io___62);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "DSBGVX(V,I";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L620;
+ }
+ }
+
+/* Do Test */
+
+ dsgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1],
+ &work[1], &result[ntest]);
+
+ }
+
+L620:
+ ;
+ }
+/* L630: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+ ntestt += ntest;
+ dlafts_("DSG", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh,
+ nounit, &nerrs);
+L640:
+ ;
+ }
+/* L650: */
+ }
+
+/* Summary */
+
+ dlasum_("DSG", nounit, &nerrs, &ntestt);
+
+ return 0;
+
+/* End of DDRVSG */
+
+} /* ddrvsg_ */
diff --git a/TESTING/EIG/ddrvst.c b/TESTING/EIG/ddrvst.c
new file mode 100644
index 0000000..52e268d
--- /dev/null
+++ b/TESTING/EIG/ddrvst.c
@@ -0,0 +1,4161 @@
+/* ddrvst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static doublereal c_b20 = 0.;
+static integer c__0 = 0;
+static integer c__6 = 6;
+static doublereal c_b34 = 1.;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c__3 = 3;
+
+/* Subroutine */ int ddrvst_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
+ doublereal *a, integer *lda, doublereal *d1, doublereal *d2,
+ doublereal *d3, doublereal *d4, doublereal *eveigs, doublereal *wa1,
+ doublereal *wa2, doublereal *wa3, doublereal *u, integer *ldu,
+ doublereal *v, doublereal *tau, doublereal *z__, doublereal *work,
+ integer *lwork, integer *iwork, integer *liwork, doublereal *result,
+ integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[18] = { 1,2,4,4,4,4,4,5,5,5,5,5,8,8,8,9,9,9 };
+ static integer kmagn[18] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3,1,2,3 };
+ static integer kmode[18] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0,4,4,4 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 DDRVST: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+
+ /* System generated locals */
+ address a__1[3];
+ integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, z_dim1,
+ z_offset, i__1, i__2, i__3, i__4, i__5, i__6[3], i__7;
+ doublereal d__1, d__2, d__3, d__4;
+ char ch__1[10], ch__2[13], ch__3[11];
+
+ /* Builtin functions */
+ double sqrt(doublereal), log(doublereal);
+ integer pow_ii(integer *, integer *), s_wsfe(cilist *), do_fio(integer *,
+ char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
+ char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, m, n, j1, j2, m2, m3, kd, il, iu;
+ doublereal vl, vu;
+ integer lgn;
+ doublereal ulp, cond;
+ integer jcol, ihbw, indx, nmax;
+ doublereal unfl, ovfl;
+ char uplo[1];
+ integer irow;
+ doublereal temp1, temp2, temp3;
+ extern doublereal dsxt1_(integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *);
+ integer idiag;
+ logical badnn;
+ integer imode, lwedc;
+ extern /* Subroutine */ int dsbev_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer iinfo;
+ doublereal aninv, anorm;
+ integer itemp;
+ extern /* Subroutine */ int dspev_(char *, char *, integer *, doublereal *
+, doublereal *, doublereal *, integer *, doublereal *, integer *);
+ integer nmats;
+ extern /* Subroutine */ int dstt21_(integer *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *);
+ integer jsize;
+ extern /* Subroutine */ int dstev_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *), dstt22_(integer *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *), dsyt21_(integer *, char *
+, integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *);
+ integer iuplo, nerrs, itype, jtype, ntest;
+ extern /* Subroutine */ int dsyev_(char *, char *, integer *, doublereal *
+, integer *, doublereal *, doublereal *, integer *, integer *), dsyt22_(integer *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *);
+ integer iseed2[4], iseed3[4];
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *), dlarnd_(integer *, integer *);
+ integer liwedc;
+ extern /* Subroutine */ int dsbevd_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *, integer *, integer *);
+ integer idumma[1];
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int dlafts_(char *, integer *, integer *, integer
+ *, integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *), dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *), alasvm_(char *, integer *,
+ integer *, integer *, integer *);
+ doublereal abstol;
+ extern /* Subroutine */ int dlatmr_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ char *, char *, doublereal *, integer *, doublereal *, doublereal
+ *, integer *, doublereal *, char *, integer *, integer *, integer
+ *, doublereal *, doublereal *, char *, doublereal *, integer *,
+ integer *, integer *), dlatms_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublereal *, integer *, doublereal *, integer
+ *), dspevd_(char *, char *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, integer *, integer *, integer *),
+ dstevd_(char *, integer *, doublereal *, doublereal *, doublereal
+ *, integer *, doublereal *, integer *, integer *, integer *,
+ integer *), dsbevx_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, integer *, integer *), dsyevd_(
+ char *, char *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *, integer *, integer *), dstevr_(char *, char *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, doublereal *, integer *, integer *, integer *, integer
+ *), dspevx_(char *, char *, char *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *, integer *);
+ doublereal rtunfl, rtovfl, ulpinv;
+ extern /* Subroutine */ int dstevx_(char *, char *, integer *, doublereal
+ *, doublereal *, doublereal *, doublereal *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *, integer *);
+ integer mtypes, ntestt;
+ extern /* Subroutine */ int dsyevr_(char *, char *, char *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, integer *, integer *, integer
+ *, integer *), dsyevx_(char *, char *,
+ char *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___68 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___69 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___72 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___73 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___74 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___75 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___76 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___77 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___81 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___82 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___83 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___84 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___85 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___86 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___87 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___88 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___90 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___91 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___92 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___93 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___94 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___95 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___96 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___97 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___98 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___99 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___100 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___101 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___102 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___103 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___104 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___105 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___106 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___107 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___108 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___109 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVST checks the symmetric eigenvalue problem drivers. */
+
+/* DSTEV computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric tridiagonal matrix. */
+
+/* DSTEVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric tridiagonal matrix. */
+
+/* DSTEVR computes selected eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric tridiagonal matrix */
+/* using the Relatively Robust Representation where it can. */
+
+/* DSYEV computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric matrix. */
+
+/* DSYEVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric matrix. */
+
+/* DSYEVR computes selected eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric matrix */
+/* using the Relatively Robust Representation where it can. */
+
+/* DSPEV computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric matrix in packed */
+/* storage. */
+
+/* DSPEVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric matrix in packed */
+/* storage. */
+
+/* DSBEV computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric band matrix. */
+
+/* DSBEVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric band matrix. */
+
+/* DSYEVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric matrix using */
+/* a divide and conquer algorithm. */
+
+/* DSPEVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric matrix in packed */
+/* storage, using a divide and conquer algorithm. */
+
+/* DSBEVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric band matrix, */
+/* using a divide and conquer algorithm. */
+
+/* When DDRVST is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the appropriate drivers. For each matrix and each */
+/* driver routine called, the following tests will be performed: */
+
+/* (1) | A - Z D Z' | / ( |A| n ulp ) */
+
+/* (2) | I - Z Z' | / ( n ulp ) */
+
+/* (3) | D1 - D2 | / ( |D1| ulp ) */
+
+/* where Z is the matrix of eigenvectors returned when the */
+/* eigenvector option is given and D1 and D2 are the eigenvalues */
+/* returned with and without the eigenvector option. */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced eigenvalues */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced eigenvalues */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" eigenvalues */
+/* 1, ULP, ..., ULP and random signs. */
+
+/* (6) Same as (4), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (4), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U' D U, where U is orthogonal and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U' D U, where U is orthogonal and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U' D U, where U is orthogonal and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) Symmetric matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
+/* (16) A band matrix with half bandwidth randomly chosen between */
+/* 0 and N-1, with evenly spaced eigenvalues 1, ..., ULP */
+/* with random signs. */
+/* (17) Same as (16), but multiplied by SQRT( overflow threshold ) */
+/* (18) Same as (16), but multiplied by SQRT( underflow threshold ) */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* DDRVST does nothing. It must be at least zero. */
+/* Not modified. */
+
+/* NN INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+/* Not modified. */
+
+/* NTYPES INTEGER */
+/* The number of elements in DOTYPE. If it is zero, DDRVST */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+/* Not modified. */
+
+/* DOTYPE LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+/* Not modified. */
+
+/* ISEED INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to DDRVST to continue the same random number */
+/* sequence. */
+/* Modified. */
+
+/* THRESH DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+/* Not modified. */
+
+/* NOUNIT INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+/* Not modified. */
+
+/* A DOUBLE PRECISION array, dimension (LDA , max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually */
+/* used. */
+/* Modified. */
+
+/* LDA INTEGER */
+/* The leading dimension of A. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* D1 DOUBLE PRECISION array, dimension (max(NN)) */
+/* The eigenvalues of A, as computed by DSTEQR simlutaneously */
+/* with Z. On exit, the eigenvalues in D1 correspond with the */
+/* matrix in A. */
+/* Modified. */
+
+/* D2 DOUBLE PRECISION array, dimension (max(NN)) */
+/* The eigenvalues of A, as computed by DSTEQR if Z is not */
+/* computed. On exit, the eigenvalues in D2 correspond with */
+/* the matrix in A. */
+/* Modified. */
+
+/* D3 DOUBLE PRECISION array, dimension (max(NN)) */
+/* The eigenvalues of A, as computed by DSTERF. On exit, the */
+/* eigenvalues in D3 correspond with the matrix in A. */
+/* Modified. */
+
+/* D4 DOUBLE PRECISION array, dimension */
+
+/* EVEIGS DOUBLE PRECISION array, dimension (max(NN)) */
+/* The eigenvalues as computed by DSTEV('N', ... ) */
+/* (I reserve the right to change this to the output of */
+/* whichever algorithm computes the most accurate eigenvalues). */
+
+/* WA1 DOUBLE PRECISION array, dimension */
+
+/* WA2 DOUBLE PRECISION array, dimension */
+
+/* WA3 DOUBLE PRECISION array, dimension */
+
+/* U DOUBLE PRECISION array, dimension (LDU, max(NN)) */
+/* The orthogonal matrix computed by DSYTRD + DORGTR. */
+/* Modified. */
+
+/* LDU INTEGER */
+/* The leading dimension of U, Z, and V. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* V DOUBLE PRECISION array, dimension (LDU, max(NN)) */
+/* The Housholder vectors computed by DSYTRD in reducing A to */
+/* tridiagonal form. */
+/* Modified. */
+
+/* TAU DOUBLE PRECISION array, dimension (max(NN)) */
+/* The Householder factors computed by DSYTRD in reducing A */
+/* to tridiagonal form. */
+/* Modified. */
+
+/* Z DOUBLE PRECISION array, dimension (LDU, max(NN)) */
+/* The orthogonal matrix of eigenvectors computed by DSTEQR, */
+/* DPTEQR, and DSTEIN. */
+/* Modified. */
+
+/* WORK DOUBLE PRECISION array, dimension (LWORK) */
+/* Workspace. */
+/* Modified. */
+
+/* LWORK INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 4 * Nmax**2 */
+/* where Nmax = max( NN(j), 2 ) and lg = log base 2. */
+/* Not modified. */
+
+/* IWORK INTEGER array, */
+/* dimension (6 + 6*Nmax + 5 * Nmax * lg Nmax ) */
+/* where Nmax = max( NN(j), 2 ) and lg = log base 2. */
+/* Workspace. */
+/* Modified. */
+
+/* RESULT DOUBLE PRECISION array, dimension (105) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+/* Modified. */
+
+/* INFO INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -5: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -16: LDU < 1 or LDU < NMAX. */
+/* -21: LWORK too small. */
+/* If DLATMR, DLATMS, DSYTRD, DORGTR, DSTEQR, DSTERF, */
+/* or DORMTR returns an error code, the */
+/* absolute value of it is returned. */
+/* Modified. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests performed, or which can */
+/* be performed so far, for the current matrix. */
+/* NTESTT The total number of tests performed so far. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far (computed by DLAFTS). */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* The tests performed are: Routine tested */
+/* 1= | A - U S U' | / ( |A| n ulp ) DSTEV('V', ... ) */
+/* 2= | I - U U' | / ( n ulp ) DSTEV('V', ... ) */
+/* 3= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEV('N', ... ) */
+/* 4= | A - U S U' | / ( |A| n ulp ) DSTEVX('V','A', ... ) */
+/* 5= | I - U U' | / ( n ulp ) DSTEVX('V','A', ... ) */
+/* 6= |D(with Z) - EVEIGS| / (|D| ulp) DSTEVX('N','A', ... ) */
+/* 7= | A - U S U' | / ( |A| n ulp ) DSTEVR('V','A', ... ) */
+/* 8= | I - U U' | / ( n ulp ) DSTEVR('V','A', ... ) */
+/* 9= |D(with Z) - EVEIGS| / (|D| ulp) DSTEVR('N','A', ... ) */
+/* 10= | A - U S U' | / ( |A| n ulp ) DSTEVX('V','I', ... ) */
+/* 11= | I - U U' | / ( n ulp ) DSTEVX('V','I', ... ) */
+/* 12= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEVX('N','I', ... ) */
+/* 13= | A - U S U' | / ( |A| n ulp ) DSTEVX('V','V', ... ) */
+/* 14= | I - U U' | / ( n ulp ) DSTEVX('V','V', ... ) */
+/* 15= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEVX('N','V', ... ) */
+/* 16= | A - U S U' | / ( |A| n ulp ) DSTEVD('V', ... ) */
+/* 17= | I - U U' | / ( n ulp ) DSTEVD('V', ... ) */
+/* 18= |D(with Z) - EVEIGS| / (|D| ulp) DSTEVD('N', ... ) */
+/* 19= | A - U S U' | / ( |A| n ulp ) DSTEVR('V','I', ... ) */
+/* 20= | I - U U' | / ( n ulp ) DSTEVR('V','I', ... ) */
+/* 21= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEVR('N','I', ... ) */
+/* 22= | A - U S U' | / ( |A| n ulp ) DSTEVR('V','V', ... ) */
+/* 23= | I - U U' | / ( n ulp ) DSTEVR('V','V', ... ) */
+/* 24= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEVR('N','V', ... ) */
+
+/* 25= | A - U S U' | / ( |A| n ulp ) DSYEV('L','V', ... ) */
+/* 26= | I - U U' | / ( n ulp ) DSYEV('L','V', ... ) */
+/* 27= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEV('L','N', ... ) */
+/* 28= | A - U S U' | / ( |A| n ulp ) DSYEVX('L','V','A', ... ) */
+/* 29= | I - U U' | / ( n ulp ) DSYEVX('L','V','A', ... ) */
+/* 30= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVX('L','N','A', ... ) */
+/* 31= | A - U S U' | / ( |A| n ulp ) DSYEVX('L','V','I', ... ) */
+/* 32= | I - U U' | / ( n ulp ) DSYEVX('L','V','I', ... ) */
+/* 33= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVX('L','N','I', ... ) */
+/* 34= | A - U S U' | / ( |A| n ulp ) DSYEVX('L','V','V', ... ) */
+/* 35= | I - U U' | / ( n ulp ) DSYEVX('L','V','V', ... ) */
+/* 36= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVX('L','N','V', ... ) */
+/* 37= | A - U S U' | / ( |A| n ulp ) DSPEV('L','V', ... ) */
+/* 38= | I - U U' | / ( n ulp ) DSPEV('L','V', ... ) */
+/* 39= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEV('L','N', ... ) */
+/* 40= | A - U S U' | / ( |A| n ulp ) DSPEVX('L','V','A', ... ) */
+/* 41= | I - U U' | / ( n ulp ) DSPEVX('L','V','A', ... ) */
+/* 42= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVX('L','N','A', ... ) */
+/* 43= | A - U S U' | / ( |A| n ulp ) DSPEVX('L','V','I', ... ) */
+/* 44= | I - U U' | / ( n ulp ) DSPEVX('L','V','I', ... ) */
+/* 45= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVX('L','N','I', ... ) */
+/* 46= | A - U S U' | / ( |A| n ulp ) DSPEVX('L','V','V', ... ) */
+/* 47= | I - U U' | / ( n ulp ) DSPEVX('L','V','V', ... ) */
+/* 48= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVX('L','N','V', ... ) */
+/* 49= | A - U S U' | / ( |A| n ulp ) DSBEV('L','V', ... ) */
+/* 50= | I - U U' | / ( n ulp ) DSBEV('L','V', ... ) */
+/* 51= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEV('L','N', ... ) */
+/* 52= | A - U S U' | / ( |A| n ulp ) DSBEVX('L','V','A', ... ) */
+/* 53= | I - U U' | / ( n ulp ) DSBEVX('L','V','A', ... ) */
+/* 54= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVX('L','N','A', ... ) */
+/* 55= | A - U S U' | / ( |A| n ulp ) DSBEVX('L','V','I', ... ) */
+/* 56= | I - U U' | / ( n ulp ) DSBEVX('L','V','I', ... ) */
+/* 57= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVX('L','N','I', ... ) */
+/* 58= | A - U S U' | / ( |A| n ulp ) DSBEVX('L','V','V', ... ) */
+/* 59= | I - U U' | / ( n ulp ) DSBEVX('L','V','V', ... ) */
+/* 60= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVX('L','N','V', ... ) */
+/* 61= | A - U S U' | / ( |A| n ulp ) DSYEVD('L','V', ... ) */
+/* 62= | I - U U' | / ( n ulp ) DSYEVD('L','V', ... ) */
+/* 63= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVD('L','N', ... ) */
+/* 64= | A - U S U' | / ( |A| n ulp ) DSPEVD('L','V', ... ) */
+/* 65= | I - U U' | / ( n ulp ) DSPEVD('L','V', ... ) */
+/* 66= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVD('L','N', ... ) */
+/* 67= | A - U S U' | / ( |A| n ulp ) DSBEVD('L','V', ... ) */
+/* 68= | I - U U' | / ( n ulp ) DSBEVD('L','V', ... ) */
+/* 69= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVD('L','N', ... ) */
+/* 70= | A - U S U' | / ( |A| n ulp ) DSYEVR('L','V','A', ... ) */
+/* 71= | I - U U' | / ( n ulp ) DSYEVR('L','V','A', ... ) */
+/* 72= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVR('L','N','A', ... ) */
+/* 73= | A - U S U' | / ( |A| n ulp ) DSYEVR('L','V','I', ... ) */
+/* 74= | I - U U' | / ( n ulp ) DSYEVR('L','V','I', ... ) */
+/* 75= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVR('L','N','I', ... ) */
+/* 76= | A - U S U' | / ( |A| n ulp ) DSYEVR('L','V','V', ... ) */
+/* 77= | I - U U' | / ( n ulp ) DSYEVR('L','V','V', ... ) */
+/* 78= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVR('L','N','V', ... ) */
+
+/* Tests 25 through 78 are repeated (as tests 79 through 132) */
+/* with UPLO='U' */
+
+/* To be added in 1999 */
+
+/* 79= | A - U S U' | / ( |A| n ulp ) DSPEVR('L','V','A', ... ) */
+/* 80= | I - U U' | / ( n ulp ) DSPEVR('L','V','A', ... ) */
+/* 81= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVR('L','N','A', ... ) */
+/* 82= | A - U S U' | / ( |A| n ulp ) DSPEVR('L','V','I', ... ) */
+/* 83= | I - U U' | / ( n ulp ) DSPEVR('L','V','I', ... ) */
+/* 84= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVR('L','N','I', ... ) */
+/* 85= | A - U S U' | / ( |A| n ulp ) DSPEVR('L','V','V', ... ) */
+/* 86= | I - U U' | / ( n ulp ) DSPEVR('L','V','V', ... ) */
+/* 87= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVR('L','N','V', ... ) */
+/* 88= | A - U S U' | / ( |A| n ulp ) DSBEVR('L','V','A', ... ) */
+/* 89= | I - U U' | / ( n ulp ) DSBEVR('L','V','A', ... ) */
+/* 90= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVR('L','N','A', ... ) */
+/* 91= | A - U S U' | / ( |A| n ulp ) DSBEVR('L','V','I', ... ) */
+/* 92= | I - U U' | / ( n ulp ) DSBEVR('L','V','I', ... ) */
+/* 93= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVR('L','N','I', ... ) */
+/* 94= | A - U S U' | / ( |A| n ulp ) DSBEVR('L','V','V', ... ) */
+/* 95= | I - U U' | / ( n ulp ) DSBEVR('L','V','V', ... ) */
+/* 96= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVR('L','N','V', ... ) */
+
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d1;
+ --d2;
+ --d3;
+ --d4;
+ --eveigs;
+ --wa1;
+ --wa2;
+ --wa3;
+ z_dim1 = *ldu;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ v_dim1 = *ldu;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --tau;
+ --work;
+ --iwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Keep ftrnchek happy */
+
+ vl = 0.;
+ vu = 0.;
+
+/* 1) Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*lda < nmax) {
+ *info = -9;
+ } else if (*ldu < nmax) {
+ *info = -16;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = max(2,nmax);
+ if (i__1 * i__1 << 1 > *lwork) {
+ *info = -21;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DDRVST", &i__1);
+ return 0;
+ }
+
+/* Quick return if nothing to do */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = dlamch_("Safe minimum");
+ ovfl = dlamch_("Overflow");
+ dlabad_(&unfl, &ovfl);
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ ulpinv = 1. / ulp;
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+
+/* Loop over sizes, types */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed2[i__ - 1] = iseed[i__];
+ iseed3[i__ - 1] = iseed[i__];
+/* L20: */
+ }
+
+ nerrs = 0;
+ nmats = 0;
+
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (n > 0) {
+ lgn = (integer) (log((doublereal) n) / log(2.));
+ if (pow_ii(&c__2, &lgn) < n) {
+ ++lgn;
+ }
+ if (pow_ii(&c__2, &lgn) < n) {
+ ++lgn;
+ }
+/* Computing 2nd power */
+ i__2 = n;
+ lwedc = (n << 2) + 1 + (n << 1) * lgn + (i__2 * i__2 << 2);
+/* LIWEDC = 6 + 6*N + 5*N*LGN */
+ liwedc = n * 5 + 3;
+ } else {
+ lwedc = 9;
+/* LIWEDC = 12 */
+ liwedc = 8;
+ }
+ aninv = 1. / (doublereal) max(1,n);
+
+ if (*nsizes != 1) {
+ mtypes = min(18,*ntypes);
+ } else {
+ mtypes = min(19,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+
+ if (! dotype[jtype]) {
+ goto L1730;
+ }
+ ++nmats;
+ ntest = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L30: */
+ }
+
+/* 2) Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random (none) */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 band symmetric, w/ eigenvalues */
+
+ if (mtypes > 18) {
+ goto L110;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * aninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * n * ulpinv;
+ goto L70;
+
+L70:
+
+ dlaset_("Full", lda, &n, &c_b20, &c_b20, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ idumma[0] = 1;
+ dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b34,
+ &c_b34, "T", "N", &work[n + 1], &c__1, &c_b34, &work[(
+ n << 1) + 1], &c__1, &c_b34, "N", idumma, &c__0, &
+ c__0, &c_b20, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ idumma[0] = 1;
+ dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b34,
+ &c_b34, "T", "N", &work[n + 1], &c__1, &c_b34, &work[(
+ n << 1) + 1], &c__1, &c_b34, "N", idumma, &n, &n, &
+ c_b20, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* Symmetric banded, eigenvalues specified */
+
+ ihbw = (integer) ((n - 1) * dlarnd_(&c__1, iseed3));
+ dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &ihbw, &ihbw, "Z", &u[u_offset], ldu, &work[n
+ + 1], &iinfo);
+
+/* Store as dense matrix for most routines. */
+
+ dlaset_("Full", lda, &n, &c_b20, &c_b20, &a[a_offset], lda);
+ i__3 = ihbw;
+ for (idiag = -ihbw; idiag <= i__3; ++idiag) {
+ irow = ihbw - idiag + 1;
+/* Computing MAX */
+ i__4 = 1, i__5 = idiag + 1;
+ j1 = max(i__4,i__5);
+/* Computing MIN */
+ i__4 = n, i__5 = n + idiag;
+ j2 = min(i__4,i__5);
+ i__4 = j2;
+ for (j = j1; j <= i__4; ++j) {
+ i__ = j - idiag;
+ a[i__ + j * a_dim1] = u[irow + j * u_dim1];
+/* L90: */
+ }
+/* L100: */
+ }
+ } else {
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L110:
+
+ abstol = unfl + unfl;
+ if (n <= 1) {
+ il = 1;
+ iu = n;
+ } else {
+ il = (n - 1) * (integer) dlarnd_(&c__1, iseed2) + 1;
+ iu = (n - 1) * (integer) dlarnd_(&c__1, iseed2) + 1;
+ if (il > iu) {
+ itemp = il;
+ il = iu;
+ iu = itemp;
+ }
+ }
+
+/* 3) If matrix is tridiagonal, call DSTEV and DSTEVX. */
+
+ if (jtype <= 7) {
+ ntest = 1;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d1[i__] = a[i__ + i__ * a_dim1];
+/* L120: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d2[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L130: */
+ }
+ s_copy(srnamc_1.srnamt, "DSTEV", (ftnlen)32, (ftnlen)5);
+ dstev_("V", &n, &d1[1], &d2[1], &z__[z_offset], ldu, &work[1],
+ &iinfo);
+ if (iinfo != 0) {
+ io___48.ciunit = *nounit;
+ s_wsfe(&io___48);
+ do_fio(&c__1, "DSTEV(V)", (ftnlen)8);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[1] = ulpinv;
+ result[2] = ulpinv;
+ result[3] = ulpinv;
+ goto L180;
+ }
+ }
+
+/* Do tests 1 and 2. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d3[i__] = a[i__ + i__ * a_dim1];
+/* L140: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L150: */
+ }
+ dstt21_(&n, &c__0, &d3[1], &d4[1], &d1[1], &d2[1], &z__[
+ z_offset], ldu, &work[1], &result[1]);
+
+ ntest = 3;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L160: */
+ }
+ s_copy(srnamc_1.srnamt, "DSTEV", (ftnlen)32, (ftnlen)5);
+ dstev_("N", &n, &d3[1], &d4[1], &z__[z_offset], ldu, &work[1],
+ &iinfo);
+ if (iinfo != 0) {
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ do_fio(&c__1, "DSTEV(N)", (ftnlen)8);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[3] = ulpinv;
+ goto L180;
+ }
+ }
+
+/* Do test 3. */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = d3[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d1[j] - d3[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L170: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[3] = temp2 / max(d__1,d__2);
+
+L180:
+
+ ntest = 4;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ eveigs[i__] = d3[i__];
+ d1[i__] = a[i__ + i__ * a_dim1];
+/* L190: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d2[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L200: */
+ }
+ s_copy(srnamc_1.srnamt, "DSTEVX", (ftnlen)32, (ftnlen)6);
+ dstevx_("V", "A", &n, &d1[1], &d2[1], &vl, &vu, &il, &iu, &
+ abstol, &m, &wa1[1], &z__[z_offset], ldu, &work[1], &
+ iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, "DSTEVX(V,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[4] = ulpinv;
+ result[5] = ulpinv;
+ result[6] = ulpinv;
+ goto L250;
+ }
+ }
+ if (n > 0) {
+/* Computing MAX */
+ d__2 = abs(wa1[1]), d__3 = (d__1 = wa1[n], abs(d__1));
+ temp3 = max(d__2,d__3);
+ } else {
+ temp3 = 0.;
+ }
+
+/* Do tests 4 and 5. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d3[i__] = a[i__ + i__ * a_dim1];
+/* L210: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L220: */
+ }
+ dstt21_(&n, &c__0, &d3[1], &d4[1], &wa1[1], &d2[1], &z__[
+ z_offset], ldu, &work[1], &result[4]);
+
+ ntest = 6;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L230: */
+ }
+ s_copy(srnamc_1.srnamt, "DSTEVX", (ftnlen)32, (ftnlen)6);
+ dstevx_("N", "A", &n, &d3[1], &d4[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &work[1], &
+ iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ do_fio(&c__1, "DSTEVX(N,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[6] = ulpinv;
+ goto L250;
+ }
+ }
+
+/* Do test 6. */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = wa2[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = eveigs[j], abs(
+ d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = wa2[j] - eveigs[j], abs(d__1)
+ );
+ temp2 = max(d__2,d__3);
+/* L240: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[6] = temp2 / max(d__1,d__2);
+
+L250:
+
+ ntest = 7;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d1[i__] = a[i__ + i__ * a_dim1];
+/* L260: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d2[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L270: */
+ }
+ s_copy(srnamc_1.srnamt, "DSTEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ dstevr_("V", "A", &n, &d1[1], &d2[1], &vl, &vu, &il, &iu, &
+ abstol, &m, &wa1[1], &z__[z_offset], ldu, &iwork[1], &
+ work[1], lwork, &iwork[(n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, "DSTEVR(V,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[7] = ulpinv;
+ result[8] = ulpinv;
+ goto L320;
+ }
+ }
+ if (n > 0) {
+/* Computing MAX */
+ d__2 = abs(wa1[1]), d__3 = (d__1 = wa1[n], abs(d__1));
+ temp3 = max(d__2,d__3);
+ } else {
+ temp3 = 0.;
+ }
+
+/* Do tests 7 and 8. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d3[i__] = a[i__ + i__ * a_dim1];
+/* L280: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L290: */
+ }
+ dstt21_(&n, &c__0, &d3[1], &d4[1], &wa1[1], &d2[1], &z__[
+ z_offset], ldu, &work[1], &result[7]);
+
+ ntest = 9;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L300: */
+ }
+ s_copy(srnamc_1.srnamt, "DSTEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ dstevr_("N", "A", &n, &d3[1], &d4[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &iwork[1],
+ &work[1], lwork, &iwork[(n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ do_fio(&c__1, "DSTEVR(N,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[9] = ulpinv;
+ goto L320;
+ }
+ }
+
+/* Do test 9. */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = wa2[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = eveigs[j], abs(
+ d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = wa2[j] - eveigs[j], abs(d__1)
+ );
+ temp2 = max(d__2,d__3);
+/* L310: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[9] = temp2 / max(d__1,d__2);
+
+L320:
+
+
+ ntest = 10;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d1[i__] = a[i__ + i__ * a_dim1];
+/* L330: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d2[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L340: */
+ }
+ s_copy(srnamc_1.srnamt, "DSTEVX", (ftnlen)32, (ftnlen)6);
+ dstevx_("V", "I", &n, &d1[1], &d2[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &work[1], &
+ iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, "DSTEVX(V,I)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[10] = ulpinv;
+ result[11] = ulpinv;
+ result[12] = ulpinv;
+ goto L380;
+ }
+ }
+
+/* Do tests 10 and 11. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d3[i__] = a[i__ + i__ * a_dim1];
+/* L350: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L360: */
+ }
+ i__3 = max(1,m2);
+ dstt22_(&n, &m2, &c__0, &d3[1], &d4[1], &wa2[1], &d2[1], &z__[
+ z_offset], ldu, &work[1], &i__3, &result[10]);
+
+
+ ntest = 12;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L370: */
+ }
+ s_copy(srnamc_1.srnamt, "DSTEVX", (ftnlen)32, (ftnlen)6);
+ dstevx_("N", "I", &n, &d3[1], &d4[1], &vl, &vu, &il, &iu, &
+ abstol, &m3, &wa3[1], &z__[z_offset], ldu, &work[1], &
+ iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___61.ciunit = *nounit;
+ s_wsfe(&io___61);
+ do_fio(&c__1, "DSTEVX(N,I)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[12] = ulpinv;
+ goto L380;
+ }
+ }
+
+/* Do test 12. */
+
+ temp1 = dsxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = dsxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * temp3;
+ result[12] = (temp1 + temp2) / max(d__1,d__2);
+
+L380:
+
+ ntest = 12;
+ if (n > 0) {
+ if (il != 1) {
+/* Computing MAX */
+ d__1 = (wa1[il] - wa1[il - 1]) * .5, d__2 = ulp * 10.
+ * temp3, d__1 = max(d__1,d__2), d__2 = rtunfl
+ * 10.;
+ vl = wa1[il] - max(d__1,d__2);
+ } else {
+/* Computing MAX */
+ d__1 = (wa1[n] - wa1[1]) * .5, d__2 = ulp * 10. *
+ temp3, d__1 = max(d__1,d__2), d__2 = rtunfl *
+ 10.;
+ vl = wa1[1] - max(d__1,d__2);
+ }
+ if (iu != n) {
+/* Computing MAX */
+ d__1 = (wa1[iu + 1] - wa1[iu]) * .5, d__2 = ulp * 10.
+ * temp3, d__1 = max(d__1,d__2), d__2 = rtunfl
+ * 10.;
+ vu = wa1[iu] + max(d__1,d__2);
+ } else {
+/* Computing MAX */
+ d__1 = (wa1[n] - wa1[1]) * .5, d__2 = ulp * 10. *
+ temp3, d__1 = max(d__1,d__2), d__2 = rtunfl *
+ 10.;
+ vu = wa1[n] + max(d__1,d__2);
+ }
+ } else {
+ vl = 0.;
+ vu = 1.;
+ }
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d1[i__] = a[i__ + i__ * a_dim1];
+/* L390: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d2[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L400: */
+ }
+ s_copy(srnamc_1.srnamt, "DSTEVX", (ftnlen)32, (ftnlen)6);
+ dstevx_("V", "V", &n, &d1[1], &d2[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &work[1], &
+ iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___62.ciunit = *nounit;
+ s_wsfe(&io___62);
+ do_fio(&c__1, "DSTEVX(V,V)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[13] = ulpinv;
+ result[14] = ulpinv;
+ result[15] = ulpinv;
+ goto L440;
+ }
+ }
+
+ if (m2 == 0 && n > 0) {
+ result[13] = ulpinv;
+ result[14] = ulpinv;
+ result[15] = ulpinv;
+ goto L440;
+ }
+
+/* Do tests 13 and 14. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d3[i__] = a[i__ + i__ * a_dim1];
+/* L410: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L420: */
+ }
+ i__3 = max(1,m2);
+ dstt22_(&n, &m2, &c__0, &d3[1], &d4[1], &wa2[1], &d2[1], &z__[
+ z_offset], ldu, &work[1], &i__3, &result[13]);
+
+ ntest = 15;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L430: */
+ }
+ s_copy(srnamc_1.srnamt, "DSTEVX", (ftnlen)32, (ftnlen)6);
+ dstevx_("N", "V", &n, &d3[1], &d4[1], &vl, &vu, &il, &iu, &
+ abstol, &m3, &wa3[1], &z__[z_offset], ldu, &work[1], &
+ iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___63.ciunit = *nounit;
+ s_wsfe(&io___63);
+ do_fio(&c__1, "DSTEVX(N,V)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[15] = ulpinv;
+ goto L440;
+ }
+ }
+
+/* Do test 15. */
+
+ temp1 = dsxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = dsxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+/* Computing MAX */
+ d__1 = unfl, d__2 = temp3 * ulp;
+ result[15] = (temp1 + temp2) / max(d__1,d__2);
+
+L440:
+
+ ntest = 16;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d1[i__] = a[i__ + i__ * a_dim1];
+/* L450: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d2[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L460: */
+ }
+ s_copy(srnamc_1.srnamt, "DSTEVD", (ftnlen)32, (ftnlen)6);
+ dstevd_("V", &n, &d1[1], &d2[1], &z__[z_offset], ldu, &work[1]
+, &lwedc, &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___64.ciunit = *nounit;
+ s_wsfe(&io___64);
+ do_fio(&c__1, "DSTEVD(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[16] = ulpinv;
+ result[17] = ulpinv;
+ result[18] = ulpinv;
+ goto L510;
+ }
+ }
+
+/* Do tests 16 and 17. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d3[i__] = a[i__ + i__ * a_dim1];
+/* L470: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L480: */
+ }
+ dstt21_(&n, &c__0, &d3[1], &d4[1], &d1[1], &d2[1], &z__[
+ z_offset], ldu, &work[1], &result[16]);
+
+ ntest = 18;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L490: */
+ }
+ s_copy(srnamc_1.srnamt, "DSTEVD", (ftnlen)32, (ftnlen)6);
+ dstevd_("N", &n, &d3[1], &d4[1], &z__[z_offset], ldu, &work[1]
+, &lwedc, &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___65.ciunit = *nounit;
+ s_wsfe(&io___65);
+ do_fio(&c__1, "DSTEVD(N)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[18] = ulpinv;
+ goto L510;
+ }
+ }
+
+/* Do test 18. */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = eveigs[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = d3[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = eveigs[j] - d3[j], abs(d__1))
+ ;
+ temp2 = max(d__2,d__3);
+/* L500: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[18] = temp2 / max(d__1,d__2);
+
+L510:
+
+ ntest = 19;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d1[i__] = a[i__ + i__ * a_dim1];
+/* L520: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d2[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L530: */
+ }
+ s_copy(srnamc_1.srnamt, "DSTEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ dstevr_("V", "I", &n, &d1[1], &d2[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &iwork[1],
+ &work[1], lwork, &iwork[(n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___66.ciunit = *nounit;
+ s_wsfe(&io___66);
+ do_fio(&c__1, "DSTEVR(V,I)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[19] = ulpinv;
+ result[20] = ulpinv;
+ result[21] = ulpinv;
+ goto L570;
+ }
+ }
+
+/* DO tests 19 and 20. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d3[i__] = a[i__ + i__ * a_dim1];
+/* L540: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L550: */
+ }
+ i__3 = max(1,m2);
+ dstt22_(&n, &m2, &c__0, &d3[1], &d4[1], &wa2[1], &d2[1], &z__[
+ z_offset], ldu, &work[1], &i__3, &result[19]);
+
+
+ ntest = 21;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L560: */
+ }
+ s_copy(srnamc_1.srnamt, "DSTEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ dstevr_("N", "I", &n, &d3[1], &d4[1], &vl, &vu, &il, &iu, &
+ abstol, &m3, &wa3[1], &z__[z_offset], ldu, &iwork[1],
+ &work[1], lwork, &iwork[(n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___67.ciunit = *nounit;
+ s_wsfe(&io___67);
+ do_fio(&c__1, "DSTEVR(N,I)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[21] = ulpinv;
+ goto L570;
+ }
+ }
+
+/* Do test 21. */
+
+ temp1 = dsxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = dsxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * temp3;
+ result[21] = (temp1 + temp2) / max(d__1,d__2);
+
+L570:
+
+ ntest = 21;
+ if (n > 0) {
+ if (il != 1) {
+/* Computing MAX */
+ d__1 = (wa1[il] - wa1[il - 1]) * .5, d__2 = ulp * 10.
+ * temp3, d__1 = max(d__1,d__2), d__2 = rtunfl
+ * 10.;
+ vl = wa1[il] - max(d__1,d__2);
+ } else {
+/* Computing MAX */
+ d__1 = (wa1[n] - wa1[1]) * .5, d__2 = ulp * 10. *
+ temp3, d__1 = max(d__1,d__2), d__2 = rtunfl *
+ 10.;
+ vl = wa1[1] - max(d__1,d__2);
+ }
+ if (iu != n) {
+/* Computing MAX */
+ d__1 = (wa1[iu + 1] - wa1[iu]) * .5, d__2 = ulp * 10.
+ * temp3, d__1 = max(d__1,d__2), d__2 = rtunfl
+ * 10.;
+ vu = wa1[iu] + max(d__1,d__2);
+ } else {
+/* Computing MAX */
+ d__1 = (wa1[n] - wa1[1]) * .5, d__2 = ulp * 10. *
+ temp3, d__1 = max(d__1,d__2), d__2 = rtunfl *
+ 10.;
+ vu = wa1[n] + max(d__1,d__2);
+ }
+ } else {
+ vl = 0.;
+ vu = 1.;
+ }
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d1[i__] = a[i__ + i__ * a_dim1];
+/* L580: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d2[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L590: */
+ }
+ s_copy(srnamc_1.srnamt, "DSTEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ dstevr_("V", "V", &n, &d1[1], &d2[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &iwork[1],
+ &work[1], lwork, &iwork[(n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___68.ciunit = *nounit;
+ s_wsfe(&io___68);
+ do_fio(&c__1, "DSTEVR(V,V)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[22] = ulpinv;
+ result[23] = ulpinv;
+ result[24] = ulpinv;
+ goto L630;
+ }
+ }
+
+ if (m2 == 0 && n > 0) {
+ result[22] = ulpinv;
+ result[23] = ulpinv;
+ result[24] = ulpinv;
+ goto L630;
+ }
+
+/* Do tests 22 and 23. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d3[i__] = a[i__ + i__ * a_dim1];
+/* L600: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L610: */
+ }
+ i__3 = max(1,m2);
+ dstt22_(&n, &m2, &c__0, &d3[1], &d4[1], &wa2[1], &d2[1], &z__[
+ z_offset], ldu, &work[1], &i__3, &result[22]);
+
+ ntest = 24;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L620: */
+ }
+ s_copy(srnamc_1.srnamt, "DSTEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ dstevr_("N", "V", &n, &d3[1], &d4[1], &vl, &vu, &il, &iu, &
+ abstol, &m3, &wa3[1], &z__[z_offset], ldu, &iwork[1],
+ &work[1], lwork, &iwork[(n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___69.ciunit = *nounit;
+ s_wsfe(&io___69);
+ do_fio(&c__1, "DSTEVR(N,V)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[24] = ulpinv;
+ goto L630;
+ }
+ }
+
+/* Do test 24. */
+
+ temp1 = dsxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = dsxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+/* Computing MAX */
+ d__1 = unfl, d__2 = temp3 * ulp;
+ result[24] = (temp1 + temp2) / max(d__1,d__2);
+
+L630:
+
+
+
+ ;
+ } else {
+
+ for (i__ = 1; i__ <= 24; ++i__) {
+ result[i__] = 0.;
+/* L640: */
+ }
+ ntest = 24;
+ }
+
+/* Perform remaining tests storing upper or lower triangular */
+/* part of matrix. */
+
+ for (iuplo = 0; iuplo <= 1; ++iuplo) {
+ if (iuplo == 0) {
+ *(unsigned char *)uplo = 'L';
+ } else {
+ *(unsigned char *)uplo = 'U';
+ }
+
+/* 4) Call DSYEV and DSYEVX. */
+
+ dlacpy_(" ", &n, &n, &a[a_offset], lda, &v[v_offset], ldu);
+
+ ++ntest;
+ s_copy(srnamc_1.srnamt, "DSYEV", (ftnlen)32, (ftnlen)5);
+ dsyev_("V", uplo, &n, &a[a_offset], ldu, &d1[1], &work[1],
+ lwork, &iinfo);
+ if (iinfo != 0) {
+ io___72.ciunit = *nounit;
+ s_wsfe(&io___72);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "DSYEV(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L660;
+ }
+ }
+
+/* Do tests 25 and 26 (or +54) */
+
+ dsyt21_(&c__1, uplo, &n, &c__0, &v[v_offset], ldu, &d1[1], &
+ d2[1], &a[a_offset], ldu, &z__[z_offset], ldu, &tau[1]
+, &work[1], &result[ntest]);
+
+ dlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ ntest += 2;
+ s_copy(srnamc_1.srnamt, "DSYEV", (ftnlen)32, (ftnlen)5);
+ dsyev_("N", uplo, &n, &a[a_offset], ldu, &d3[1], &work[1],
+ lwork, &iinfo);
+ if (iinfo != 0) {
+ io___73.ciunit = *nounit;
+ s_wsfe(&io___73);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "DSYEV(N,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L660;
+ }
+ }
+
+/* Do test 27 (or +54) */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = d3[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d1[j] - d3[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L650: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[ntest] = temp2 / max(d__1,d__2);
+
+L660:
+ dlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ ++ntest;
+
+ if (n > 0) {
+/* Computing MAX */
+ d__2 = abs(d1[1]), d__3 = (d__1 = d1[n], abs(d__1));
+ temp3 = max(d__2,d__3);
+ if (il != 1) {
+/* Computing MAX */
+ d__1 = (d1[il] - d1[il - 1]) * .5, d__2 = ulp * 10. *
+ temp3, d__1 = max(d__1,d__2), d__2 = rtunfl *
+ 10.;
+ vl = d1[il] - max(d__1,d__2);
+ } else if (n > 0) {
+/* Computing MAX */
+ d__1 = (d1[n] - d1[1]) * .5, d__2 = ulp * 10. * temp3,
+ d__1 = max(d__1,d__2), d__2 = rtunfl * 10.;
+ vl = d1[1] - max(d__1,d__2);
+ }
+ if (iu != n) {
+/* Computing MAX */
+ d__1 = (d1[iu + 1] - d1[iu]) * .5, d__2 = ulp * 10. *
+ temp3, d__1 = max(d__1,d__2), d__2 = rtunfl *
+ 10.;
+ vu = d1[iu] + max(d__1,d__2);
+ } else if (n > 0) {
+/* Computing MAX */
+ d__1 = (d1[n] - d1[1]) * .5, d__2 = ulp * 10. * temp3,
+ d__1 = max(d__1,d__2), d__2 = rtunfl * 10.;
+ vu = d1[n] + max(d__1,d__2);
+ }
+ } else {
+ temp3 = 0.;
+ vl = 0.;
+ vu = 1.;
+ }
+
+ s_copy(srnamc_1.srnamt, "DSYEVX", (ftnlen)32, (ftnlen)6);
+ dsyevx_("V", "A", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m, &wa1[1], &z__[z_offset], ldu, &work[
+ 1], lwork, &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___74.ciunit = *nounit;
+ s_wsfe(&io___74);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSYEVX(V,A,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L680;
+ }
+ }
+
+/* Do tests 28 and 29 (or +54) */
+
+ dlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ dsyt21_(&c__1, uplo, &n, &c__0, &a[a_offset], ldu, &d1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &result[ntest]);
+
+ ntest += 2;
+ s_copy(srnamc_1.srnamt, "DSYEVX", (ftnlen)32, (ftnlen)6);
+ dsyevx_("N", "A", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ work[1], lwork, &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___75.ciunit = *nounit;
+ s_wsfe(&io___75);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSYEVX(N,A,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L680;
+ }
+ }
+
+/* Do test 30 (or +54) */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = wa1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = wa2[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = wa1[j] - wa2[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L670: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[ntest] = temp2 / max(d__1,d__2);
+
+L680:
+
+ ++ntest;
+ dlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ s_copy(srnamc_1.srnamt, "DSYEVX", (ftnlen)32, (ftnlen)6);
+ dsyevx_("V", "I", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ work[1], lwork, &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___76.ciunit = *nounit;
+ s_wsfe(&io___76);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSYEVX(V,I,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L690;
+ }
+ }
+
+/* Do tests 31 and 32 (or +54) */
+
+ dlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ dsyt22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &result[ntest]);
+
+ ntest += 2;
+ dlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ s_copy(srnamc_1.srnamt, "DSYEVX", (ftnlen)32, (ftnlen)6);
+ dsyevx_("N", "I", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m3, &wa3[1], &z__[z_offset], ldu, &
+ work[1], lwork, &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___77.ciunit = *nounit;
+ s_wsfe(&io___77);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSYEVX(N,I,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L690;
+ }
+ }
+
+/* Do test 33 (or +54) */
+
+ temp1 = dsxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = dsxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * temp3;
+ result[ntest] = (temp1 + temp2) / max(d__1,d__2);
+L690:
+
+ ++ntest;
+ dlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ s_copy(srnamc_1.srnamt, "DSYEVX", (ftnlen)32, (ftnlen)6);
+ dsyevx_("V", "V", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ work[1], lwork, &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___78.ciunit = *nounit;
+ s_wsfe(&io___78);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSYEVX(V,V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L700;
+ }
+ }
+
+/* Do tests 34 and 35 (or +54) */
+
+ dlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ dsyt22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &result[ntest]);
+
+ ntest += 2;
+ dlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ s_copy(srnamc_1.srnamt, "DSYEVX", (ftnlen)32, (ftnlen)6);
+ dsyevx_("N", "V", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m3, &wa3[1], &z__[z_offset], ldu, &
+ work[1], lwork, &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___79.ciunit = *nounit;
+ s_wsfe(&io___79);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSYEVX(N,V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L700;
+ }
+ }
+
+ if (m3 == 0 && n > 0) {
+ result[ntest] = ulpinv;
+ goto L700;
+ }
+
+/* Do test 36 (or +54) */
+
+ temp1 = dsxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = dsxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ d__2 = abs(wa1[1]), d__3 = (d__1 = wa1[n], abs(d__1));
+ temp3 = max(d__2,d__3);
+ } else {
+ temp3 = 0.;
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / max(d__1,d__2);
+
+L700:
+
+/* 5) Call DSPEV and DSPEVX. */
+
+ dlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+/* Load array WORK with the upper or lower triangular */
+/* part of the matrix in packed form. */
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L710: */
+ }
+/* L720: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L730: */
+ }
+/* L740: */
+ }
+ }
+
+ ++ntest;
+ s_copy(srnamc_1.srnamt, "DSPEV", (ftnlen)32, (ftnlen)5);
+ dspev_("V", uplo, &n, &work[1], &d1[1], &z__[z_offset], ldu, &
+ v[v_offset], &iinfo);
+ if (iinfo != 0) {
+ io___81.ciunit = *nounit;
+ s_wsfe(&io___81);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "DSPEV(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L800;
+ }
+ }
+
+/* Do tests 37 and 38 (or +54) */
+
+ dsyt21_(&c__1, uplo, &n, &c__0, &a[a_offset], lda, &d1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &result[ntest]);
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L750: */
+ }
+/* L760: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L770: */
+ }
+/* L780: */
+ }
+ }
+
+ ntest += 2;
+ s_copy(srnamc_1.srnamt, "DSPEV", (ftnlen)32, (ftnlen)5);
+ dspev_("N", uplo, &n, &work[1], &d3[1], &z__[z_offset], ldu, &
+ v[v_offset], &iinfo);
+ if (iinfo != 0) {
+ io___82.ciunit = *nounit;
+ s_wsfe(&io___82);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "DSPEV(N,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L800;
+ }
+ }
+
+/* Do test 39 (or +54) */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = d3[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d1[j] - d3[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L790: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[ntest] = temp2 / max(d__1,d__2);
+
+/* Load array WORK with the upper or lower triangular part */
+/* of the matrix in packed form. */
+
+L800:
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L810: */
+ }
+/* L820: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L830: */
+ }
+/* L840: */
+ }
+ }
+
+ ++ntest;
+
+ if (n > 0) {
+/* Computing MAX */
+ d__2 = abs(d1[1]), d__3 = (d__1 = d1[n], abs(d__1));
+ temp3 = max(d__2,d__3);
+ if (il != 1) {
+/* Computing MAX */
+ d__1 = (d1[il] - d1[il - 1]) * .5, d__2 = ulp * 10. *
+ temp3, d__1 = max(d__1,d__2), d__2 = rtunfl *
+ 10.;
+ vl = d1[il] - max(d__1,d__2);
+ } else if (n > 0) {
+/* Computing MAX */
+ d__1 = (d1[n] - d1[1]) * .5, d__2 = ulp * 10. * temp3,
+ d__1 = max(d__1,d__2), d__2 = rtunfl * 10.;
+ vl = d1[1] - max(d__1,d__2);
+ }
+ if (iu != n) {
+/* Computing MAX */
+ d__1 = (d1[iu + 1] - d1[iu]) * .5, d__2 = ulp * 10. *
+ temp3, d__1 = max(d__1,d__2), d__2 = rtunfl *
+ 10.;
+ vu = d1[iu] + max(d__1,d__2);
+ } else if (n > 0) {
+/* Computing MAX */
+ d__1 = (d1[n] - d1[1]) * .5, d__2 = ulp * 10. * temp3,
+ d__1 = max(d__1,d__2), d__2 = rtunfl * 10.;
+ vu = d1[n] + max(d__1,d__2);
+ }
+ } else {
+ temp3 = 0.;
+ vl = 0.;
+ vu = 1.;
+ }
+
+ s_copy(srnamc_1.srnamt, "DSPEVX", (ftnlen)32, (ftnlen)6);
+ dspevx_("V", "A", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m, &wa1[1], &z__[z_offset], ldu, &v[v_offset]
+, &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___83.ciunit = *nounit;
+ s_wsfe(&io___83);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSPEVX(V,A,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L900;
+ }
+ }
+
+/* Do tests 40 and 41 (or +54) */
+
+ dsyt21_(&c__1, uplo, &n, &c__0, &a[a_offset], ldu, &wa1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L850: */
+ }
+/* L860: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L870: */
+ }
+/* L880: */
+ }
+ }
+
+ s_copy(srnamc_1.srnamt, "DSPEVX", (ftnlen)32, (ftnlen)6);
+ dspevx_("N", "A", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &v[
+ v_offset], &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___84.ciunit = *nounit;
+ s_wsfe(&io___84);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSPEVX(N,A,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L900;
+ }
+ }
+
+/* Do test 42 (or +54) */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = wa1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = wa2[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = wa1[j] - wa2[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L890: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[ntest] = temp2 / max(d__1,d__2);
+
+L900:
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L910: */
+ }
+/* L920: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L930: */
+ }
+/* L940: */
+ }
+ }
+
+ ++ntest;
+
+ s_copy(srnamc_1.srnamt, "DSPEVX", (ftnlen)32, (ftnlen)6);
+ dspevx_("V", "I", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &v[
+ v_offset], &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___85.ciunit = *nounit;
+ s_wsfe(&io___85);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSPEVX(V,I,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L990;
+ }
+ }
+
+/* Do tests 43 and 44 (or +54) */
+
+ dsyt22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L950: */
+ }
+/* L960: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L970: */
+ }
+/* L980: */
+ }
+ }
+
+ s_copy(srnamc_1.srnamt, "DSPEVX", (ftnlen)32, (ftnlen)6);
+ dspevx_("N", "I", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m3, &wa3[1], &z__[z_offset], ldu, &v[
+ v_offset], &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___86.ciunit = *nounit;
+ s_wsfe(&io___86);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSPEVX(N,I,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L990;
+ }
+ }
+
+ if (m3 == 0 && n > 0) {
+ result[ntest] = ulpinv;
+ goto L990;
+ }
+
+/* Do test 45 (or +54) */
+
+ temp1 = dsxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = dsxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ d__2 = abs(wa1[1]), d__3 = (d__1 = wa1[n], abs(d__1));
+ temp3 = max(d__2,d__3);
+ } else {
+ temp3 = 0.;
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / max(d__1,d__2);
+
+L990:
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L1000: */
+ }
+/* L1010: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L1020: */
+ }
+/* L1030: */
+ }
+ }
+
+ ++ntest;
+
+ s_copy(srnamc_1.srnamt, "DSPEVX", (ftnlen)32, (ftnlen)6);
+ dspevx_("V", "V", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &v[
+ v_offset], &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___87.ciunit = *nounit;
+ s_wsfe(&io___87);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSPEVX(V,V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1080;
+ }
+ }
+
+/* Do tests 46 and 47 (or +54) */
+
+ dsyt22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L1040: */
+ }
+/* L1050: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L1060: */
+ }
+/* L1070: */
+ }
+ }
+
+ s_copy(srnamc_1.srnamt, "DSPEVX", (ftnlen)32, (ftnlen)6);
+ dspevx_("N", "V", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m3, &wa3[1], &z__[z_offset], ldu, &v[
+ v_offset], &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___88.ciunit = *nounit;
+ s_wsfe(&io___88);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSPEVX(N,V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1080;
+ }
+ }
+
+ if (m3 == 0 && n > 0) {
+ result[ntest] = ulpinv;
+ goto L1080;
+ }
+
+/* Do test 48 (or +54) */
+
+ temp1 = dsxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = dsxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ d__2 = abs(wa1[1]), d__3 = (d__1 = wa1[n], abs(d__1));
+ temp3 = max(d__2,d__3);
+ } else {
+ temp3 = 0.;
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / max(d__1,d__2);
+
+L1080:
+
+/* 6) Call DSBEV and DSBEVX. */
+
+ if (jtype <= 7) {
+ kd = 1;
+ } else if (jtype >= 8 && jtype <= 15) {
+/* Computing MAX */
+ i__3 = n - 1;
+ kd = max(i__3,0);
+ } else {
+ kd = ihbw;
+ }
+
+/* Load array V with the upper or lower triangular part */
+/* of the matrix in band form. */
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kd;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__) {
+ v[kd + 1 + i__ - j + j * v_dim1] = a[i__ + j *
+ a_dim1];
+/* L1090: */
+ }
+/* L1100: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + kd;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ v[i__ + 1 - j + j * v_dim1] = a[i__ + j * a_dim1];
+/* L1110: */
+ }
+/* L1120: */
+ }
+ }
+
+ ++ntest;
+ s_copy(srnamc_1.srnamt, "DSBEV", (ftnlen)32, (ftnlen)5);
+ dsbev_("V", uplo, &n, &kd, &v[v_offset], ldu, &d1[1], &z__[
+ z_offset], ldu, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___90.ciunit = *nounit;
+ s_wsfe(&io___90);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "DSBEV(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1180;
+ }
+ }
+
+/* Do tests 49 and 50 (or ... ) */
+
+ dsyt21_(&c__1, uplo, &n, &c__0, &a[a_offset], lda, &d1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &result[ntest]);
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__7 = 1, i__4 = j - kd;
+ i__5 = j;
+ for (i__ = max(i__7,i__4); i__ <= i__5; ++i__) {
+ v[kd + 1 + i__ - j + j * v_dim1] = a[i__ + j *
+ a_dim1];
+/* L1130: */
+ }
+/* L1140: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__7 = n, i__4 = j + kd;
+ i__5 = min(i__7,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ v[i__ + 1 - j + j * v_dim1] = a[i__ + j * a_dim1];
+/* L1150: */
+ }
+/* L1160: */
+ }
+ }
+
+ ntest += 2;
+ s_copy(srnamc_1.srnamt, "DSBEV", (ftnlen)32, (ftnlen)5);
+ dsbev_("N", uplo, &n, &kd, &v[v_offset], ldu, &d3[1], &z__[
+ z_offset], ldu, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___91.ciunit = *nounit;
+ s_wsfe(&io___91);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "DSBEV(N,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1180;
+ }
+ }
+
+/* Do test 51 (or +54) */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = d3[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d1[j] - d3[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L1170: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[ntest] = temp2 / max(d__1,d__2);
+
+/* Load array V with the upper or lower triangular part */
+/* of the matrix in band form. */
+
+L1180:
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__7 = j - kd;
+ i__4 = j;
+ for (i__ = max(i__5,i__7); i__ <= i__4; ++i__) {
+ v[kd + 1 + i__ - j + j * v_dim1] = a[i__ + j *
+ a_dim1];
+/* L1190: */
+ }
+/* L1200: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__5 = n, i__7 = j + kd;
+ i__4 = min(i__5,i__7);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ v[i__ + 1 - j + j * v_dim1] = a[i__ + j * a_dim1];
+/* L1210: */
+ }
+/* L1220: */
+ }
+ }
+
+ ++ntest;
+ s_copy(srnamc_1.srnamt, "DSBEVX", (ftnlen)32, (ftnlen)6);
+ dsbevx_("V", "A", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m, &wa2[
+ 1], &z__[z_offset], ldu, &work[1], &iwork[1], &iwork[
+ n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___92.ciunit = *nounit;
+ s_wsfe(&io___92);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSBEVX(V,A,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1280;
+ }
+ }
+
+/* Do tests 52 and 53 (or +54) */
+
+ dsyt21_(&c__1, uplo, &n, &c__0, &a[a_offset], ldu, &wa2[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kd;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__) {
+ v[kd + 1 + i__ - j + j * v_dim1] = a[i__ + j *
+ a_dim1];
+/* L1230: */
+ }
+/* L1240: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + kd;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ v[i__ + 1 - j + j * v_dim1] = a[i__ + j * a_dim1];
+/* L1250: */
+ }
+/* L1260: */
+ }
+ }
+
+ s_copy(srnamc_1.srnamt, "DSBEVX", (ftnlen)32, (ftnlen)6);
+ dsbevx_("N", "A", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m3, &
+ wa3[1], &z__[z_offset], ldu, &work[1], &iwork[1], &
+ iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___93.ciunit = *nounit;
+ s_wsfe(&io___93);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSBEVX(N,A,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1280;
+ }
+ }
+
+/* Do test 54 (or +54) */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = wa2[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = wa3[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = wa2[j] - wa3[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L1270: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[ntest] = temp2 / max(d__1,d__2);
+
+L1280:
+ ++ntest;
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__7 = 1, i__4 = j - kd;
+ i__5 = j;
+ for (i__ = max(i__7,i__4); i__ <= i__5; ++i__) {
+ v[kd + 1 + i__ - j + j * v_dim1] = a[i__ + j *
+ a_dim1];
+/* L1290: */
+ }
+/* L1300: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__7 = n, i__4 = j + kd;
+ i__5 = min(i__7,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ v[i__ + 1 - j + j * v_dim1] = a[i__ + j * a_dim1];
+/* L1310: */
+ }
+/* L1320: */
+ }
+ }
+
+ s_copy(srnamc_1.srnamt, "DSBEVX", (ftnlen)32, (ftnlen)6);
+ dsbevx_("V", "I", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m2, &
+ wa2[1], &z__[z_offset], ldu, &work[1], &iwork[1], &
+ iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___94.ciunit = *nounit;
+ s_wsfe(&io___94);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSBEVX(V,I,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1370;
+ }
+ }
+
+/* Do tests 55 and 56 (or +54) */
+
+ dsyt22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__7 = j - kd;
+ i__4 = j;
+ for (i__ = max(i__5,i__7); i__ <= i__4; ++i__) {
+ v[kd + 1 + i__ - j + j * v_dim1] = a[i__ + j *
+ a_dim1];
+/* L1330: */
+ }
+/* L1340: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__5 = n, i__7 = j + kd;
+ i__4 = min(i__5,i__7);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ v[i__ + 1 - j + j * v_dim1] = a[i__ + j * a_dim1];
+/* L1350: */
+ }
+/* L1360: */
+ }
+ }
+
+ s_copy(srnamc_1.srnamt, "DSBEVX", (ftnlen)32, (ftnlen)6);
+ dsbevx_("N", "I", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m3, &
+ wa3[1], &z__[z_offset], ldu, &work[1], &iwork[1], &
+ iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___95.ciunit = *nounit;
+ s_wsfe(&io___95);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSBEVX(N,I,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1370;
+ }
+ }
+
+/* Do test 57 (or +54) */
+
+ temp1 = dsxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = dsxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ d__2 = abs(wa1[1]), d__3 = (d__1 = wa1[n], abs(d__1));
+ temp3 = max(d__2,d__3);
+ } else {
+ temp3 = 0.;
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / max(d__1,d__2);
+
+L1370:
+ ++ntest;
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kd;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__) {
+ v[kd + 1 + i__ - j + j * v_dim1] = a[i__ + j *
+ a_dim1];
+/* L1380: */
+ }
+/* L1390: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + kd;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ v[i__ + 1 - j + j * v_dim1] = a[i__ + j * a_dim1];
+/* L1400: */
+ }
+/* L1410: */
+ }
+ }
+
+ s_copy(srnamc_1.srnamt, "DSBEVX", (ftnlen)32, (ftnlen)6);
+ dsbevx_("V", "V", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m2, &
+ wa2[1], &z__[z_offset], ldu, &work[1], &iwork[1], &
+ iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___96.ciunit = *nounit;
+ s_wsfe(&io___96);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSBEVX(V,V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1460;
+ }
+ }
+
+/* Do tests 58 and 59 (or +54) */
+
+ dsyt22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__7 = 1, i__4 = j - kd;
+ i__5 = j;
+ for (i__ = max(i__7,i__4); i__ <= i__5; ++i__) {
+ v[kd + 1 + i__ - j + j * v_dim1] = a[i__ + j *
+ a_dim1];
+/* L1420: */
+ }
+/* L1430: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__7 = n, i__4 = j + kd;
+ i__5 = min(i__7,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ v[i__ + 1 - j + j * v_dim1] = a[i__ + j * a_dim1];
+/* L1440: */
+ }
+/* L1450: */
+ }
+ }
+
+ s_copy(srnamc_1.srnamt, "DSBEVX", (ftnlen)32, (ftnlen)6);
+ dsbevx_("N", "V", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m3, &
+ wa3[1], &z__[z_offset], ldu, &work[1], &iwork[1], &
+ iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___97.ciunit = *nounit;
+ s_wsfe(&io___97);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSBEVX(N,V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1460;
+ }
+ }
+
+ if (m3 == 0 && n > 0) {
+ result[ntest] = ulpinv;
+ goto L1460;
+ }
+
+/* Do test 60 (or +54) */
+
+ temp1 = dsxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = dsxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ d__2 = abs(wa1[1]), d__3 = (d__1 = wa1[n], abs(d__1));
+ temp3 = max(d__2,d__3);
+ } else {
+ temp3 = 0.;
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / max(d__1,d__2);
+
+L1460:
+
+/* 7) Call DSYEVD */
+
+ dlacpy_(" ", &n, &n, &a[a_offset], lda, &v[v_offset], ldu);
+
+ ++ntest;
+ s_copy(srnamc_1.srnamt, "DSYEVD", (ftnlen)32, (ftnlen)6);
+ dsyevd_("V", uplo, &n, &a[a_offset], ldu, &d1[1], &work[1], &
+ lwedc, &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___98.ciunit = *nounit;
+ s_wsfe(&io___98);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "DSYEVD(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__3, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1480;
+ }
+ }
+
+/* Do tests 61 and 62 (or +54) */
+
+ dsyt21_(&c__1, uplo, &n, &c__0, &v[v_offset], ldu, &d1[1], &
+ d2[1], &a[a_offset], ldu, &z__[z_offset], ldu, &tau[1]
+, &work[1], &result[ntest]);
+
+ dlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ ntest += 2;
+ s_copy(srnamc_1.srnamt, "DSYEVD", (ftnlen)32, (ftnlen)6);
+ dsyevd_("N", uplo, &n, &a[a_offset], ldu, &d3[1], &work[1], &
+ lwedc, &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___99.ciunit = *nounit;
+ s_wsfe(&io___99);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "DSYEVD(N,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__3, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1480;
+ }
+ }
+
+/* Do test 63 (or +54) */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = d3[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d1[j] - d3[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L1470: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[ntest] = temp2 / max(d__1,d__2);
+
+L1480:
+
+/* 8) Call DSPEVD. */
+
+ dlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+/* Load array WORK with the upper or lower triangular */
+/* part of the matrix in packed form. */
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__5 = j;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L1490: */
+ }
+/* L1500: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__5 = n;
+ for (i__ = j; i__ <= i__5; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L1510: */
+ }
+/* L1520: */
+ }
+ }
+
+ ++ntest;
+ s_copy(srnamc_1.srnamt, "DSPEVD", (ftnlen)32, (ftnlen)6);
+ i__3 = lwedc - indx + 1;
+ dspevd_("V", uplo, &n, &work[1], &d1[1], &z__[z_offset], ldu,
+ &work[indx], &i__3, &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___100.ciunit = *nounit;
+ s_wsfe(&io___100);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "DSPEVD(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__3, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1580;
+ }
+ }
+
+/* Do tests 64 and 65 (or +54) */
+
+ dsyt21_(&c__1, uplo, &n, &c__0, &a[a_offset], lda, &d1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &result[ntest]);
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__5 = j;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L1530: */
+ }
+/* L1540: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__5 = n;
+ for (i__ = j; i__ <= i__5; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L1550: */
+ }
+/* L1560: */
+ }
+ }
+
+ ntest += 2;
+ s_copy(srnamc_1.srnamt, "DSPEVD", (ftnlen)32, (ftnlen)6);
+ i__3 = lwedc - indx + 1;
+ dspevd_("N", uplo, &n, &work[1], &d3[1], &z__[z_offset], ldu,
+ &work[indx], &i__3, &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___101.ciunit = *nounit;
+ s_wsfe(&io___101);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "DSPEVD(N,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__3, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1580;
+ }
+ }
+
+/* Do test 66 (or +54) */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = d3[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d1[j] - d3[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L1570: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[ntest] = temp2 / max(d__1,d__2);
+L1580:
+
+/* 9) Call DSBEVD. */
+
+ if (jtype <= 7) {
+ kd = 1;
+ } else if (jtype >= 8 && jtype <= 15) {
+/* Computing MAX */
+ i__3 = n - 1;
+ kd = max(i__3,0);
+ } else {
+ kd = ihbw;
+ }
+
+/* Load array V with the upper or lower triangular part */
+/* of the matrix in band form. */
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__7 = j - kd;
+ i__4 = j;
+ for (i__ = max(i__5,i__7); i__ <= i__4; ++i__) {
+ v[kd + 1 + i__ - j + j * v_dim1] = a[i__ + j *
+ a_dim1];
+/* L1590: */
+ }
+/* L1600: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__5 = n, i__7 = j + kd;
+ i__4 = min(i__5,i__7);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ v[i__ + 1 - j + j * v_dim1] = a[i__ + j * a_dim1];
+/* L1610: */
+ }
+/* L1620: */
+ }
+ }
+
+ ++ntest;
+ s_copy(srnamc_1.srnamt, "DSBEVD", (ftnlen)32, (ftnlen)6);
+ dsbevd_("V", uplo, &n, &kd, &v[v_offset], ldu, &d1[1], &z__[
+ z_offset], ldu, &work[1], &lwedc, &iwork[1], &liwedc,
+ &iinfo);
+ if (iinfo != 0) {
+ io___102.ciunit = *nounit;
+ s_wsfe(&io___102);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "DSBEVD(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__3, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1680;
+ }
+ }
+
+/* Do tests 67 and 68 (or +54) */
+
+ dsyt21_(&c__1, uplo, &n, &c__0, &a[a_offset], lda, &d1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &result[ntest]);
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kd;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__) {
+ v[kd + 1 + i__ - j + j * v_dim1] = a[i__ + j *
+ a_dim1];
+/* L1630: */
+ }
+/* L1640: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + kd;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ v[i__ + 1 - j + j * v_dim1] = a[i__ + j * a_dim1];
+/* L1650: */
+ }
+/* L1660: */
+ }
+ }
+
+ ntest += 2;
+ s_copy(srnamc_1.srnamt, "DSBEVD", (ftnlen)32, (ftnlen)6);
+ dsbevd_("N", uplo, &n, &kd, &v[v_offset], ldu, &d3[1], &z__[
+ z_offset], ldu, &work[1], &lwedc, &iwork[1], &liwedc,
+ &iinfo);
+ if (iinfo != 0) {
+ io___103.ciunit = *nounit;
+ s_wsfe(&io___103);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "DSBEVD(N,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__3, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1680;
+ }
+ }
+
+/* Do test 69 (or +54) */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = d3[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d1[j] - d3[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L1670: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[ntest] = temp2 / max(d__1,d__2);
+
+L1680:
+
+
+ dlacpy_(" ", &n, &n, &a[a_offset], lda, &v[v_offset], ldu);
+ ++ntest;
+ s_copy(srnamc_1.srnamt, "DSYEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ dsyevr_("V", "A", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m, &wa1[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &iwork[(n << 1) + 1], &
+ i__3, &iinfo);
+ if (iinfo != 0) {
+ io___104.ciunit = *nounit;
+ s_wsfe(&io___104);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSYEVR(V,A,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1700;
+ }
+ }
+
+/* Do tests 70 and 71 (or ... ) */
+
+ dlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ dsyt21_(&c__1, uplo, &n, &c__0, &a[a_offset], ldu, &wa1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &result[ntest]);
+
+ ntest += 2;
+ s_copy(srnamc_1.srnamt, "DSYEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ dsyevr_("N", "A", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &iwork[(n << 1) + 1], &
+ i__3, &iinfo);
+ if (iinfo != 0) {
+ io___105.ciunit = *nounit;
+ s_wsfe(&io___105);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSYEVR(N,A,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1700;
+ }
+ }
+
+/* Do test 72 (or ... ) */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = wa1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = wa2[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = wa1[j] - wa2[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L1690: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[ntest] = temp2 / max(d__1,d__2);
+
+L1700:
+
+ ++ntest;
+ dlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ s_copy(srnamc_1.srnamt, "DSYEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ dsyevr_("V", "I", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &iwork[(n << 1) + 1], &
+ i__3, &iinfo);
+ if (iinfo != 0) {
+ io___106.ciunit = *nounit;
+ s_wsfe(&io___106);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSYEVR(V,I,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1710;
+ }
+ }
+
+/* Do tests 73 and 74 (or +54) */
+
+ dlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ dsyt22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &result[ntest]);
+
+ ntest += 2;
+ dlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ s_copy(srnamc_1.srnamt, "DSYEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ dsyevr_("N", "I", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m3, &wa3[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &iwork[(n << 1) + 1], &
+ i__3, &iinfo);
+ if (iinfo != 0) {
+ io___107.ciunit = *nounit;
+ s_wsfe(&io___107);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSYEVR(N,I,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1710;
+ }
+ }
+
+/* Do test 75 (or +54) */
+
+ temp1 = dsxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = dsxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * temp3;
+ result[ntest] = (temp1 + temp2) / max(d__1,d__2);
+L1710:
+
+ ++ntest;
+ dlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ s_copy(srnamc_1.srnamt, "DSYEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ dsyevr_("V", "V", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &iwork[(n << 1) + 1], &
+ i__3, &iinfo);
+ if (iinfo != 0) {
+ io___108.ciunit = *nounit;
+ s_wsfe(&io___108);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSYEVR(V,V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L700;
+ }
+ }
+
+/* Do tests 76 and 77 (or +54) */
+
+ dlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ dsyt22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &result[ntest]);
+
+ ntest += 2;
+ dlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ s_copy(srnamc_1.srnamt, "DSYEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ dsyevr_("N", "V", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m3, &wa3[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &iwork[(n << 1) + 1], &
+ i__3, &iinfo);
+ if (iinfo != 0) {
+ io___109.ciunit = *nounit;
+ s_wsfe(&io___109);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "DSYEVR(N,V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L700;
+ }
+ }
+
+ if (m3 == 0 && n > 0) {
+ result[ntest] = ulpinv;
+ goto L700;
+ }
+
+/* Do test 78 (or +54) */
+
+ temp1 = dsxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = dsxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ d__2 = abs(wa1[1]), d__3 = (d__1 = wa1[n], abs(d__1));
+ temp3 = max(d__2,d__3);
+ } else {
+ temp3 = 0.;
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / max(d__1,d__2);
+
+ dlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+/* L1720: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+ ntestt += ntest;
+
+ dlafts_("DST", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh,
+ nounit, &nerrs);
+
+L1730:
+ ;
+ }
+/* L1740: */
+ }
+
+/* Summary */
+
+ alasvm_("DST", nounit, &nerrs, &ntestt, &c__0);
+
+
+ return 0;
+
+/* End of DDRVST */
+
+} /* ddrvst_ */
diff --git a/TESTING/EIG/ddrvsx.c b/TESTING/EIG/ddrvsx.c
new file mode 100644
index 0000000..386c648
--- /dev/null
+++ b/TESTING/EIG/ddrvsx.c
@@ -0,0 +1,1088 @@
+/* ddrvsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ doublereal selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+/* Table of constant values */
+
+static doublereal c_b18 = 0.;
+static integer c__0 = 0;
+static doublereal c_b32 = 1.;
+static integer c__4 = 4;
+static integer c__6 = 6;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static logical c_false = FALSE_;
+static integer c__3 = 3;
+static integer c__5 = 5;
+static logical c_true = TRUE_;
+static integer c__22 = 22;
+
+/* Subroutine */ int ddrvsx_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, integer *niunit,
+ integer *nounit, doublereal *a, integer *lda, doublereal *h__,
+ doublereal *ht, doublereal *wr, doublereal *wi, doublereal *wrt,
+ doublereal *wit, doublereal *wrtmp, doublereal *witmp, doublereal *vs,
+ integer *ldvs, doublereal *vs1, doublereal *result, doublereal *work,
+ integer *lwork, integer *iwork, logical *bwork, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
+ static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
+ static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9991[] = "(\002 DDRVSX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(/1x,a3,\002 -- Real Schur Form Decomposition "
+ "Expert \002,\002Driver\002,/\002 Matrix types (see DDRVSX for de"
+ "tails):\002)";
+ static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 \002,\002 5=Diagonal: geom"
+ "etr. spaced entries.\002,/\002 2=Identity matrix. "
+ " \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
+ "/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
+ " 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
+ "l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
+ "ll, evenly spaced.\002)";
+ static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
+ " 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
+ "l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
+ "d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
+ "red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
+ "vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
+ " 12=Well-cond., random complex \002,\002 \002,\002 17=Il"
+ "l-cond., large rand. complx \002,/\002 13=Ill-condi\002,\002tion"
+ "ed, evenly spaced. \002,\002 18=Ill-cond., small rand.\002"
+ ",\002 complx \002)";
+ static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
+ " \002,\002 21=Matrix \002,\002with small random entries.\002,"
+ "/\002 20=Matrix with large ran\002,\002dom entries. \002,/)";
+ static char fmt_9995[] = "(\002 Tests performed with test threshold ="
+ "\002,f8.2,/\002 ( A denotes A on input and T denotes A on output)"
+ "\002,//\002 1 = 0 if T in Schur form (no sort), \002,\002 1/ulp"
+ " otherwise\002,/\002 2 = | A - VS T transpose(VS) | / ( n |A| ul"
+ "p ) (no sort)\002,/\002 3 = | I - VS transpose(VS) | / ( n ulp )"
+ " (no sort) \002,/\002 4 = 0 if WR+sqrt(-1)*WI are eigenvalues of"
+ " T (no sort),\002,\002 1/ulp otherwise\002,/\002 5 = 0 if T sam"
+ "e no matter if VS computed (no sort),\002,\002 1/ulp otherwis"
+ "e\002,/\002 6 = 0 if WR, WI same no matter if VS computed (no so"
+ "rt)\002,\002, 1/ulp otherwise\002)";
+ static char fmt_9994[] = "(\002 7 = 0 if T in Schur form (sort), \002"
+ ",\002 1/ulp otherwise\002,/\002 8 = | A - VS T transpose(VS) | "
+ "/ ( n |A| ulp ) (sort)\002,/\002 9 = | I - VS transpose(VS) | / "
+ "( n ulp ) (sort) \002,/\002 10 = 0 if WR+sqrt(-1)*WI are eigenva"
+ "lues of T (sort),\002,\002 1/ulp otherwise\002,/\002 11 = 0 if "
+ "T same no matter what else computed (sort),\002,\002 1/ulp othe"
+ "rwise\002,/\002 12 = 0 if WR, WI same no matter what else comput"
+ "ed \002,\002(sort), 1/ulp otherwise\002,/\002 13 = 0 if sorting "
+ "succesful, 1/ulp otherwise\002,/\002 14 = 0 if RCONDE same no ma"
+ "tter what else computed,\002,\002 1/ulp otherwise\002,/\002 15 ="
+ " 0 if RCONDv same no matter what else computed,\002,\002 1/ulp o"
+ "therwise\002,/\002 16 = | RCONDE - RCONDE(precomputed) | / cond("
+ "RCONDE),\002,/\002 17 = | RCONDV - RCONDV(precomputed) | / cond("
+ "RCONDV),\002)";
+ static char fmt_9993[] = "(\002 N=\002,i5,\002, IWK=\002,i2,\002, seed"
+ "=\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)="
+ "\002,g10.3)";
+ static char fmt_9992[] = "(\002 N=\002,i5,\002, input example =\002,i3"
+ ",\002, test(\002,i2,\002)=\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, ht_dim1, ht_offset, vs_dim1,
+ vs_offset, vs1_dim1, vs1_offset, i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+
+ /* Local variables */
+ integer i__, j, n, iwk;
+ doublereal ulp, cond;
+ integer jcol;
+ char path[3];
+ integer nmax;
+ doublereal unfl, ovfl;
+ logical badnn;
+ integer nfail;
+ extern /* Subroutine */ int dget24_(logical *, integer *, doublereal *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ integer *, logical *, integer *);
+ integer imode, iinfo;
+ doublereal conds, anorm;
+ integer islct[20], nslct, jsize, nerrs, itype, jtype, ntest;
+ doublereal rtulp;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ doublereal rcdein;
+ char adumma[1*1];
+ extern /* Subroutine */ int dlatme_(integer *, char *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, char *, char
+ *, char *, char *, doublereal *, integer *, doublereal *, integer
+ *, integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer idumma[1], ioldsd[4];
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *), dlatmr_(integer *, integer *,
+ char *, integer *, char *, doublereal *, integer *, doublereal *,
+ doublereal *, char *, char *, doublereal *, integer *, doublereal
+ *, doublereal *, integer *, doublereal *, char *, integer *,
+ integer *, integer *, doublereal *, doublereal *, char *,
+ doublereal *, integer *, integer *, integer *), dlatms_(integer *, integer *,
+ char *, integer *, char *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *, char *, doublereal *, integer
+ *, doublereal *, integer *);
+ doublereal rcdvin;
+ extern /* Subroutine */ int dlasum_(char *, integer *, integer *, integer
+ *);
+ integer ntestf;
+ doublereal ulpinv;
+ integer nnwork;
+ doublereal rtulpi;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___32 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___48 = { 0, 0, 1, 0, 0 };
+ static cilist io___49 = { 0, 0, 0, 0, 0 };
+ static cilist io___51 = { 0, 0, 0, 0, 0 };
+ static cilist io___52 = { 0, 0, 0, 0, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9992, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVSX checks the nonsymmetric eigenvalue (Schur form) problem */
+/* expert driver DGEESX. */
+
+/* DDRVSX uses both test matrices generated randomly depending on */
+/* data supplied in the calling sequence, as well as on data */
+/* read from an input file and including precomputed condition */
+/* numbers to which it compares the ones it computes. */
+
+/* When DDRVSX is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 15 */
+/* tests will be performed: */
+
+/* (1) 0 if T is in Schur form, 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (2) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (no sorting of eigenvalues). */
+
+/* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues). */
+
+/* (4) 0 if WR+sqrt(-1)*WI are eigenvalues of T */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (5) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (7) 0 if T is in Schur form, 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (8) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (with sorting of eigenvalues). */
+
+/* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues). */
+
+/* (10) 0 if WR+sqrt(-1)*WI are eigenvalues of T */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare WR, WI with and */
+/* without reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (11) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare T with and without */
+/* reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare VS with and without */
+/* reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (13) if sorting worked and SDIM is the number of */
+/* eigenvalues which were SELECTed */
+/* If workspace sufficient, also compare SDIM with and */
+/* without reciprocal condition numbers */
+
+/* (14) if RCONDE the same no matter if VS and/or RCONDV computed */
+
+/* (15) if RCONDV the same no matter if VS and/or RCONDE computed */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
+
+/* (4) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (5) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (7) Same as (4), but multiplied by a constant near */
+/* the overflow threshold */
+/* (8) Same as (4), but multiplied by a constant near */
+/* the underflow threshold */
+
+/* (9) A matrix of the form U' T U, where U is orthogonal and */
+/* T has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (10) A matrix of the form U' T U, where U is orthogonal and */
+/* T has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (11) A matrix of the form U' T U, where U is orthogonal and */
+/* T has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (12) A matrix of the form U' T U, where U is orthogonal and */
+/* T has real or complex conjugate paired eigenvalues randomly */
+/* chosen from ( ULP, 1 ) and random O(1) entries in the upper */
+/* triangle. */
+
+/* (13) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
+/* with random signs on the diagonal and random O(1) entries */
+/* in the upper triangle. */
+
+/* (14) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has geometrically spaced entries */
+/* 1, ..., ULP with random signs on the diagonal and random */
+/* O(1) entries in the upper triangle. */
+
+/* (15) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
+/* with random signs on the diagonal and random O(1) entries */
+/* in the upper triangle. */
+
+/* (16) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has real or complex conjugate paired */
+/* eigenvalues randomly chosen from ( ULP, 1 ) and random */
+/* O(1) entries in the upper triangle. */
+
+/* (17) Same as (16), but multiplied by a constant */
+/* near the overflow threshold */
+/* (18) Same as (16), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* (19) Nonsymmetric matrix with random entries chosen from (-1,1). */
+/* If N is at least 4, all entries in first two rows and last */
+/* row, and first column and last two columns are zero. */
+/* (20) Same as (19), but multiplied by a constant */
+/* near the overflow threshold */
+/* (21) Same as (19), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* In addition, an input file will be read from logical unit number */
+/* NIUNIT. The file contains matrices along with precomputed */
+/* eigenvalues and reciprocal condition numbers for the eigenvalue */
+/* average and right invariant subspace. For these matrices, in */
+/* addition to tests (1) to (15) we will compute the following two */
+/* tests: */
+
+/* (16) |RCONDE - RCDEIN| / cond(RCONDE) */
+
+/* RCONDE is the reciprocal average eigenvalue condition number */
+/* computed by DGEESX and RCDEIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDE) is the condition number */
+/* of RCONDE, and takes errors in computing RCONDE into account, */
+/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
+/* is essentially given by norm(A)/RCONDV. */
+
+/* (17) |RCONDV - RCDVIN| / cond(RCONDV) */
+
+/* RCONDV is the reciprocal right invariant subspace condition */
+/* number computed by DGEESX and RCDVIN (the precomputed true */
+/* value) is supplied as input. cond(RCONDV) is the condition */
+/* number of RCONDV, and takes errors in computing RCONDV into */
+/* account, so that the resulting quantity should be O(ULP). */
+/* cond(RCONDV) is essentially given by norm(A)/RCONDE. */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. NSIZES must be at */
+/* least zero. If it is zero, no randomly generated matrices */
+/* are tested, but any test matrices read from NIUNIT will be */
+/* tested. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. NTYPES must be at least */
+/* zero. If it is zero, no randomly generated test matrices */
+/* are tested, but and test matrices read from NIUNIT will be */
+/* tested. If it is MAXTYP+1 and NSIZES is 1, then an */
+/* additional type, MAXTYP+1 is defined, which is to use */
+/* whatever matrix is in A. This is only useful if */
+/* DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to DDRVSX to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NIUNIT (input) INTEGER */
+/* The FORTRAN unit number for reading in the data file of */
+/* problems to solve. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, and H. LDA must be at */
+/* least 1 and at least max( NN ). */
+
+/* H (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) */
+/* Another copy of the test matrix A, modified by DGEESX. */
+
+/* HT (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN)) */
+/* Yet another copy of the test matrix A, modified by DGEESX. */
+
+/* WR (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* WI (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* The real and imaginary parts of the eigenvalues of A. */
+/* On exit, WR + WI*i are the eigenvalues of the matrix in A. */
+
+/* WRT (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* WIT (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* Like WR, WI, these arrays contain the eigenvalues of A, */
+/* but those computed when DGEESX only computes a partial */
+/* eigendecomposition, i.e. not Schur vectors */
+
+/* WRTMP (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* WITMP (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* More temporary storage for eigenvalues. */
+
+/* VS (workspace) DOUBLE PRECISION array, dimension (LDVS, max(NN)) */
+/* VS holds the computed Schur vectors. */
+
+/* LDVS (input) INTEGER */
+/* Leading dimension of VS. Must be at least max(1,max(NN)). */
+
+/* VS1 (workspace) DOUBLE PRECISION array, dimension (LDVS, max(NN)) */
+/* VS1 holds another copy of the computed Schur vectors. */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (17) */
+/* The values computed by the 17 tests described above. */
+/* The values are currently limited to 1/ulp, to avoid overflow. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* max(3*NN(j),2*NN(j)**2) for all j. */
+
+/* IWORK (workspace) INTEGER array, dimension (max(NN)*max(NN)) */
+
+/* INFO (output) INTEGER */
+/* If 0, successful exit. */
+/* <0, input parameter -INFO is incorrect */
+/* >0, DLATMR, SLATMS, SLATME or DGET24 returned an error */
+/* code and INFO is its absolute value */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NMAX Largest value in NN. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* COND, CONDS, */
+/* IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTULP, RTULPI Square roots of the previous 4 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+/* KCONDS(j) Selectw whether CONDS is to be 1 or */
+/* 1/sqrt(ulp). (0 means irrelevant.) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ ht_dim1 = *lda;
+ ht_offset = 1 + ht_dim1;
+ ht -= ht_offset;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --wr;
+ --wi;
+ --wrt;
+ --wit;
+ --wrtmp;
+ --witmp;
+ vs1_dim1 = *ldvs;
+ vs1_offset = 1 + vs1_dim1;
+ vs1 -= vs1_offset;
+ vs_dim1 = *ldvs;
+ vs_offset = 1 + vs_dim1;
+ vs -= vs_offset;
+ --result;
+ --work;
+ --iwork;
+ --bwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "SX", (ftnlen)2, (ftnlen)2);
+
+/* Check for errors */
+
+ ntestt = 0;
+ ntestf = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+
+/* 12 is the largest dimension in the input file of precomputed */
+/* problems */
+
+ nmax = 12;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.) {
+ *info = -6;
+ } else if (*niunit <= 0) {
+ *info = -7;
+ } else if (*nounit <= 0) {
+ *info = -8;
+ } else if (*lda < 1 || *lda < nmax) {
+ *info = -10;
+ } else if (*ldvs < 1 || *ldvs < nmax) {
+ *info = -20;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+/* Computing 2nd power */
+ i__3 = nmax;
+ i__1 = nmax * 3, i__2 = i__3 * i__3 << 1;
+ if (max(i__1,i__2) > *lwork) {
+ *info = -24;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DDRVSX", &i__1);
+ return 0;
+ }
+
+/* If nothing to do check on NIUNIT */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ goto L150;
+ }
+
+/* More Important constants */
+
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ dlabad_(&unfl, &ovfl);
+ ulp = dlamch_("Precision");
+ ulpinv = 1. / ulp;
+ rtulp = sqrt(ulp);
+ rtulpi = 1. / rtulp;
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L130;
+ }
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KCONDS KMODE KTYPE */
+/* =1 O(1) 1 clustered 1 zero */
+/* =2 large large clustered 2 identity */
+/* =3 small exponential Jordan */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random general, w/ eigenvalues */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 random general */
+/* =10 random triangular */
+
+ if (mtypes > 21) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L30;
+ case 2: goto L40;
+ case 3: goto L50;
+ }
+
+L30:
+ anorm = 1.;
+ goto L60;
+
+L40:
+ anorm = ovfl * ulp;
+ goto L60;
+
+L50:
+ anorm = unfl * ulpinv;
+ goto L60;
+
+L60:
+
+ dlaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+/* L70: */
+ }
+
+ } else if (itype == 3) {
+
+/* Jordan Block */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+ if (jcol > 1) {
+ a[jcol + (jcol - 1) * a_dim1] = 1.;
+ }
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 6) {
+
+/* General, eigenvalues specified */
+
+ if (kconds[jtype - 1] == 1) {
+ conds = 1.;
+ } else if (kconds[jtype - 1] == 2) {
+ conds = rtulpi;
+ } else {
+ conds = 0.;
+ }
+
+ *(unsigned char *)&adumma[0] = ' ';
+ dlatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b32,
+ adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
+ n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
+ &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &c__0, &
+ c__0, &c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
+ c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* General, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
+ c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+ if (n >= 4) {
+ dlaset_("Full", &c__2, &n, &c_b18, &c_b18, &a[a_offset],
+ lda);
+ i__3 = n - 3;
+ dlaset_("Full", &i__3, &c__1, &c_b18, &c_b18, &a[a_dim1 +
+ 3], lda);
+ i__3 = n - 3;
+ dlaset_("Full", &i__3, &c__2, &c_b18, &c_b18, &a[(n - 1) *
+ a_dim1 + 3], lda);
+ dlaset_("Full", &c__1, &n, &c_b18, &c_b18, &a[n + a_dim1],
+ lda);
+ }
+
+ } else if (itype == 10) {
+
+/* Triangular, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &c__0, &
+ c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___32.ciunit = *nounit;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+/* Test for minimal and generous workspace */
+
+ for (iwk = 1; iwk <= 2; ++iwk) {
+ if (iwk == 1) {
+ nnwork = n * 3;
+ } else {
+/* Computing MAX */
+ i__3 = n * 3, i__4 = (n << 1) * n;
+ nnwork = max(i__3,i__4);
+ }
+ nnwork = max(nnwork,1);
+
+ dget24_(&c_false, &jtype, thresh, ioldsd, nounit, &n, &a[
+ a_offset], lda, &h__[h_offset], &ht[ht_offset], &wr[1]
+, &wi[1], &wrt[1], &wit[1], &wrtmp[1], &witmp[1], &vs[
+ vs_offset], ldvs, &vs1[vs1_offset], &rcdein, &rcdvin,
+ &nslct, islct, &result[1], &work[1], &nnwork, &iwork[
+ 1], &bwork[1], info);
+
+/* Check for RESULT(j) > THRESH */
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 15; ++j) {
+ if (result[j] >= 0.) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L100: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ e_wsfe();
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ e_wsfe();
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ e_wsfe();
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ e_wsfe();
+ ntestf = 2;
+ }
+
+ for (j = 1; j <= 15; ++j) {
+ if (result[j] >= *thresh) {
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+/* L110: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+
+/* L120: */
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+
+L150:
+
+/* Read in data from file to check accuracy of condition estimation */
+/* Read input data until N=0 */
+
+ jtype = 0;
+L160:
+ io___48.ciunit = *niunit;
+ i__1 = s_rsle(&io___48);
+ if (i__1 != 0) {
+ goto L200;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L200;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&nslct, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L200;
+ }
+ i__1 = e_rsle();
+ if (i__1 != 0) {
+ goto L200;
+ }
+ if (n == 0) {
+ goto L200;
+ }
+ ++jtype;
+ iseed[1] = jtype;
+ if (nslct > 0) {
+ io___49.ciunit = *niunit;
+ s_rsle(&io___49);
+ i__1 = nslct;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&islct[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___51.ciunit = *niunit;
+ s_rsle(&io___51);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__5, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
+ doublereal));
+ }
+ e_rsle();
+/* L170: */
+ }
+ io___52.ciunit = *niunit;
+ s_rsle(&io___52);
+ do_lio(&c__5, &c__1, (char *)&rcdein, (ftnlen)sizeof(doublereal));
+ do_lio(&c__5, &c__1, (char *)&rcdvin, (ftnlen)sizeof(doublereal));
+ e_rsle();
+
+ dget24_(&c_true, &c__22, thresh, &iseed[1], nounit, &n, &a[a_offset], lda,
+ &h__[h_offset], &ht[ht_offset], &wr[1], &wi[1], &wrt[1], &wit[1],
+ &wrtmp[1], &witmp[1], &vs[vs_offset], ldvs, &vs1[vs1_offset], &
+ rcdein, &rcdvin, &nslct, islct, &result[1], &work[1], lwork, &
+ iwork[1], &bwork[1], info);
+
+/* Check for RESULT(j) > THRESH */
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 17; ++j) {
+ if (result[j] >= 0.) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L180: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ e_wsfe();
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+ e_wsfe();
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ e_wsfe();
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ e_wsfe();
+ ntestf = 2;
+ }
+ for (j = 1; j <= 17; ++j) {
+ if (result[j] >= *thresh) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+/* L190: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+ goto L160;
+L200:
+
+/* Summary */
+
+ dlasum_(path, nounit, &nerrs, &ntestt);
+
+
+
+ return 0;
+
+/* End of DDRVSX */
+
+} /* ddrvsx_ */
diff --git a/TESTING/EIG/ddrvvx.c b/TESTING/EIG/ddrvvx.c
new file mode 100644
index 0000000..4682607
--- /dev/null
+++ b/TESTING/EIG/ddrvvx.c
@@ -0,0 +1,1121 @@
+/* ddrvvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b18 = 0.;
+static integer c__0 = 0;
+static doublereal c_b32 = 1.;
+static integer c__4 = 4;
+static integer c__6 = 6;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static logical c_false = FALSE_;
+static integer c__3 = 3;
+static integer c__5 = 5;
+static logical c_true = TRUE_;
+static integer c__22 = 22;
+
+/* Subroutine */ int ddrvvx_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, integer *niunit,
+ integer *nounit, doublereal *a, integer *lda, doublereal *h__,
+ doublereal *wr, doublereal *wi, doublereal *wr1, doublereal *wi1,
+ doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr,
+ doublereal *lre, integer *ldlre, doublereal *rcondv, doublereal *
+ rcndv1, doublereal *rcdvin, doublereal *rconde, doublereal *rcnde1,
+ doublereal *rcdein, doublereal *scale, doublereal *scale1, doublereal
+ *result, doublereal *work, integer *nwork, integer *iwork, integer *
+ info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
+ static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
+ static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
+ static char bal[1*4] = "N" "P" "S" "B";
+
+ /* Format strings */
+ static char fmt_9992[] = "(\002 DDRVVX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(/1x,a3,\002 -- Real Eigenvalue-Eigenvector De"
+ "composition\002,\002 Expert Driver\002,/\002 Matrix types (see D"
+ "DRVVX for details): \002)";
+ static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 \002,\002 5=Diagonal: geom"
+ "etr. spaced entries.\002,/\002 2=Identity matrix. "
+ " \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
+ "/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
+ " 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
+ "l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
+ "ll, evenly spaced.\002)";
+ static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
+ " 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
+ "l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
+ "d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
+ "red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
+ "vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
+ " 12=Well-cond., random complex \002,\002 \002,\002 17=Il"
+ "l-cond., large rand. complx \002,/\002 13=Ill-condi\002,\002tion"
+ "ed, evenly spaced. \002,\002 18=Ill-cond., small rand.\002"
+ ",\002 complx \002)";
+ static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
+ " \002,\002 21=Matrix \002,\002with small random entries.\002,"
+ "/\002 20=Matrix with large ran\002,\002dom entries. \002,\002 "
+ "22=Matrix read from input file\002,/)";
+ static char fmt_9995[] = "(\002 Tests performed with test threshold ="
+ "\002,f8.2,//\002 1 = | A VR - VR W | / ( n |A| ulp ) \002,/\002 "
+ "2 = | transpose(A) VL - VL W | / ( n |A| ulp ) \002,/\002 3 = | "
+ "|VR(i)| - 1 | / ulp \002,/\002 4 = | |VL(i)| - 1 | / ulp \002,"
+ "/\002 5 = 0 if W same no matter if VR or VL computed,\002,\002 1"
+ "/ulp otherwise\002,/\002 6 = 0 if VR same no matter what else co"
+ "mputed,\002,\002 1/ulp otherwise\002,/\002 7 = 0 if VL same no "
+ "matter what else computed,\002,\002 1/ulp otherwise\002,/\002 8"
+ " = 0 if RCONDV same no matter what else computed,\002,\002 1/ul"
+ "p otherwise\002,/\002 9 = 0 if SCALE, ILO, IHI, ABNRM same no ma"
+ "tter what else\002,\002 computed, 1/ulp otherwise\002,/\002 10 "
+ "= | RCONDV - RCONDV(precomputed) | / cond(RCONDV),\002,/\002 11 "
+ "= | RCONDE - RCONDE(precomputed) | / cond(RCONDE),\002)";
+ static char fmt_9994[] = "(\002 BALANC='\002,a1,\002',N=\002,i4,\002,I"
+ "WK=\002,i1,\002, seed=\002,4(i4,\002,\002),\002 type \002,i2,"
+ "\002, test(\002,i2,\002)=\002,g10.3)";
+ static char fmt_9993[] = "(\002 N=\002,i5,\002, input example =\002,i3"
+ ",\002, test(\002,i2,\002)=\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1,
+ vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+
+ /* Local variables */
+ integer i__, j, n, iwk;
+ doublereal ulp;
+ integer ibal;
+ doublereal cond;
+ integer jcol;
+ char path[3];
+ integer nmax;
+ doublereal unfl, ovfl;
+ logical badnn;
+ extern /* Subroutine */ int dget23_(logical *, char *, integer *,
+ doublereal *, integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *,
+ integer *);
+ integer nfail, imode, iinfo;
+ doublereal conds, anorm;
+ integer jsize, nerrs, itype, jtype, ntest;
+ doublereal rtulp;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ char balanc[1];
+ extern doublereal dlamch_(char *);
+ char adumma[1*1];
+ extern /* Subroutine */ int dlatme_(integer *, char *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, char *, char
+ *, char *, char *, doublereal *, integer *, doublereal *, integer
+ *, integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer idumma[1];
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int xerbla_(char *, integer *), dlatmr_(
+ integer *, integer *, char *, integer *, char *, doublereal *,
+ integer *, doublereal *, doublereal *, char *, char *, doublereal
+ *, integer *, doublereal *, doublereal *, integer *, doublereal *,
+ char *, integer *, integer *, integer *, doublereal *,
+ doublereal *, char *, doublereal *, integer *, integer *, integer
+ *), dlatms_(
+ integer *, integer *, char *, integer *, char *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *, char
+ *, doublereal *, integer *, doublereal *, integer *), dlasum_(char *, integer *, integer *, integer *);
+ integer ntestf, nnwork;
+ doublereal rtulpi;
+ integer mtypes, ntestt;
+ doublereal ulpinv;
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___46 = { 0, 0, 1, 0, 0 };
+ static cilist io___48 = { 0, 0, 0, 0, 0 };
+ static cilist io___49 = { 0, 0, 0, 0, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVVX checks the nonsymmetric eigenvalue problem expert driver */
+/* DGEEVX. */
+
+/* DDRVVX uses both test matrices generated randomly depending on */
+/* data supplied in the calling sequence, as well as on data */
+/* read from an input file and including precomputed condition */
+/* numbers to which it compares the ones it computes. */
+
+/* When DDRVVX is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified in the calling sequence. */
+/* For each size ("n") and each type of matrix, one matrix will be */
+/* generated and used to test the nonsymmetric eigenroutines. For */
+/* each matrix, 9 tests will be performed: */
+
+/* (1) | A * VR - VR * W | / ( n |A| ulp ) */
+
+/* Here VR is the matrix of unit right eigenvectors. */
+/* W is a block diagonal matrix, with a 1x1 block for each */
+/* real eigenvalue and a 2x2 block for each complex conjugate */
+/* pair. If eigenvalues j and j+1 are a complex conjugate pair, */
+/* so WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the */
+/* 2 x 2 block corresponding to the pair will be: */
+
+/* ( wr wi ) */
+/* ( -wi wr ) */
+
+/* Such a block multiplying an n x 2 matrix ( ur ui ) on the */
+/* right will be the same as multiplying ur + i*ui by wr + i*wi. */
+
+/* (2) | A**H * VL - VL * W**H | / ( n |A| ulp ) */
+
+/* Here VL is the matrix of unit left eigenvectors, A**H is the */
+/* conjugate transpose of A, and W is as above. */
+
+/* (3) | |VR(i)| - 1 | / ulp and largest component real */
+
+/* VR(i) denotes the i-th column of VR. */
+
+/* (4) | |VL(i)| - 1 | / ulp and largest component real */
+
+/* VL(i) denotes the i-th column of VL. */
+
+/* (5) W(full) = W(partial) */
+
+/* W(full) denotes the eigenvalues computed when VR, VL, RCONDV */
+/* and RCONDE are also computed, and W(partial) denotes the */
+/* eigenvalues computed when only some of VR, VL, RCONDV, and */
+/* RCONDE are computed. */
+
+/* (6) VR(full) = VR(partial) */
+
+/* VR(full) denotes the right eigenvectors computed when VL, RCONDV */
+/* and RCONDE are computed, and VR(partial) denotes the result */
+/* when only some of VL and RCONDV are computed. */
+
+/* (7) VL(full) = VL(partial) */
+
+/* VL(full) denotes the left eigenvectors computed when VR, RCONDV */
+/* and RCONDE are computed, and VL(partial) denotes the result */
+/* when only some of VR and RCONDV are computed. */
+
+/* (8) 0 if SCALE, ILO, IHI, ABNRM (full) = */
+/* SCALE, ILO, IHI, ABNRM (partial) */
+/* 1/ulp otherwise */
+
+/* SCALE, ILO, IHI and ABNRM describe how the matrix is balanced. */
+/* (full) is when VR, VL, RCONDE and RCONDV are also computed, and */
+/* (partial) is when some are not computed. */
+
+/* (9) RCONDV(full) = RCONDV(partial) */
+
+/* RCONDV(full) denotes the reciprocal condition numbers of the */
+/* right eigenvectors computed when VR, VL and RCONDE are also */
+/* computed. RCONDV(partial) denotes the reciprocal condition */
+/* numbers when only some of VR, VL and RCONDE are computed. */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
+
+/* (4) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (5) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (7) Same as (4), but multiplied by a constant near */
+/* the overflow threshold */
+/* (8) Same as (4), but multiplied by a constant near */
+/* the underflow threshold */
+
+/* (9) A matrix of the form U' T U, where U is orthogonal and */
+/* T has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (10) A matrix of the form U' T U, where U is orthogonal and */
+/* T has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (11) A matrix of the form U' T U, where U is orthogonal and */
+/* T has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (12) A matrix of the form U' T U, where U is orthogonal and */
+/* T has real or complex conjugate paired eigenvalues randomly */
+/* chosen from ( ULP, 1 ) and random O(1) entries in the upper */
+/* triangle. */
+
+/* (13) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
+/* with random signs on the diagonal and random O(1) entries */
+/* in the upper triangle. */
+
+/* (14) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has geometrically spaced entries */
+/* 1, ..., ULP with random signs on the diagonal and random */
+/* O(1) entries in the upper triangle. */
+
+/* (15) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
+/* with random signs on the diagonal and random O(1) entries */
+/* in the upper triangle. */
+
+/* (16) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has real or complex conjugate paired */
+/* eigenvalues randomly chosen from ( ULP, 1 ) and random */
+/* O(1) entries in the upper triangle. */
+
+/* (17) Same as (16), but multiplied by a constant */
+/* near the overflow threshold */
+/* (18) Same as (16), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* (19) Nonsymmetric matrix with random entries chosen from (-1,1). */
+/* If N is at least 4, all entries in first two rows and last */
+/* row, and first column and last two columns are zero. */
+/* (20) Same as (19), but multiplied by a constant */
+/* near the overflow threshold */
+/* (21) Same as (19), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* In addition, an input file will be read from logical unit number */
+/* NIUNIT. The file contains matrices along with precomputed */
+/* eigenvalues and reciprocal condition numbers for the eigenvalues */
+/* and right eigenvectors. For these matrices, in addition to tests */
+/* (1) to (9) we will compute the following two tests: */
+
+/* (10) |RCONDV - RCDVIN| / cond(RCONDV) */
+
+/* RCONDV is the reciprocal right eigenvector condition number */
+/* computed by DGEEVX and RCDVIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDV) is the condition number of */
+/* RCONDV, and takes errors in computing RCONDV into account, so */
+/* that the resulting quantity should be O(ULP). cond(RCONDV) is */
+/* essentially given by norm(A)/RCONDE. */
+
+/* (11) |RCONDE - RCDEIN| / cond(RCONDE) */
+
+/* RCONDE is the reciprocal eigenvalue condition number */
+/* computed by DGEEVX and RCDEIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDE) is the condition number */
+/* of RCONDE, and takes errors in computing RCONDE into account, */
+/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
+/* is essentially given by norm(A)/RCONDV. */
+
+/* Arguments */
+/* ========== */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. NSIZES must be at */
+/* least zero. If it is zero, no randomly generated matrices */
+/* are tested, but any test matrices read from NIUNIT will be */
+/* tested. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. NTYPES must be at least */
+/* zero. If it is zero, no randomly generated test matrices */
+/* are tested, but and test matrices read from NIUNIT will be */
+/* tested. If it is MAXTYP+1 and NSIZES is 1, then an */
+/* additional type, MAXTYP+1 is defined, which is to use */
+/* whatever matrix is in A. This is only useful if */
+/* DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to DDRVVX to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NIUNIT (input) INTEGER */
+/* The FORTRAN unit number for reading in the data file of */
+/* problems to solve. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* A (workspace) DOUBLE PRECISION array, dimension */
+/* (LDA, max(NN,12)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A and H. */
+/* LDA >= max(NN,12), since 12 is the dimension of the largest */
+/* matrix in the precomputed input file. */
+
+/* H (workspace) DOUBLE PRECISION array, dimension */
+/* (LDA, max(NN,12)) */
+/* Another copy of the test matrix A, modified by DGEEVX. */
+
+/* WR (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* WI (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* The real and imaginary parts of the eigenvalues of A. */
+/* On exit, WR + WI*i are the eigenvalues of the matrix in A. */
+
+/* WR1 (workspace) DOUBLE PRECISION array, dimension (max(NN,12)) */
+/* WI1 (workspace) DOUBLE PRECISION array, dimension (max(NN,12)) */
+/* Like WR, WI, these arrays contain the eigenvalues of A, */
+/* but those computed when DGEEVX only computes a partial */
+/* eigendecomposition, i.e. not the eigenvalues and left */
+/* and right eigenvectors. */
+
+/* VL (workspace) DOUBLE PRECISION array, dimension */
+/* (LDVL, max(NN,12)) */
+/* VL holds the computed left eigenvectors. */
+
+/* LDVL (input) INTEGER */
+/* Leading dimension of VL. Must be at least max(1,max(NN,12)). */
+
+/* VR (workspace) DOUBLE PRECISION array, dimension */
+/* (LDVR, max(NN,12)) */
+/* VR holds the computed right eigenvectors. */
+
+/* LDVR (input) INTEGER */
+/* Leading dimension of VR. Must be at least max(1,max(NN,12)). */
+
+/* LRE (workspace) DOUBLE PRECISION array, dimension */
+/* (LDLRE, max(NN,12)) */
+/* LRE holds the computed right or left eigenvectors. */
+
+/* LDLRE (input) INTEGER */
+/* Leading dimension of LRE. Must be at least max(1,max(NN,12)) */
+
+/* RCONDV (workspace) DOUBLE PRECISION array, dimension (N) */
+/* RCONDV holds the computed reciprocal condition numbers */
+/* for eigenvectors. */
+
+/* RCNDV1 (workspace) DOUBLE PRECISION array, dimension (N) */
+/* RCNDV1 holds more computed reciprocal condition numbers */
+/* for eigenvectors. */
+
+/* RCDVIN (workspace) DOUBLE PRECISION array, dimension (N) */
+/* When COMP = .TRUE. RCDVIN holds the precomputed reciprocal */
+/* condition numbers for eigenvectors to be compared with */
+/* RCONDV. */
+
+/* RCONDE (workspace) DOUBLE PRECISION array, dimension (N) */
+/* RCONDE holds the computed reciprocal condition numbers */
+/* for eigenvalues. */
+
+/* RCNDE1 (workspace) DOUBLE PRECISION array, dimension (N) */
+/* RCNDE1 holds more computed reciprocal condition numbers */
+/* for eigenvalues. */
+
+/* RCDEIN (workspace) DOUBLE PRECISION array, dimension (N) */
+/* When COMP = .TRUE. RCDEIN holds the precomputed reciprocal */
+/* condition numbers for eigenvalues to be compared with */
+/* RCONDE. */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (11) */
+/* The values computed by the seven tests described above. */
+/* The values are currently limited to 1/ulp, to avoid overflow. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (NWORK) */
+
+/* NWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* max(6*12+2*12**2,6*NN(j)+2*NN(j)**2) = */
+/* max( 360 ,6*NN(j)+2*NN(j)**2) for all j. */
+
+/* IWORK (workspace) INTEGER array, dimension (2*max(NN,12)) */
+
+/* INFO (output) INTEGER */
+/* If 0, then successful exit. */
+/* If <0, then input paramter -INFO is incorrect. */
+/* If >0, DLATMR, SLATMS, SLATME or DGET23 returned an error */
+/* code, and INFO is its absolute value. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NMAX Largest value in NN or 12. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* COND, CONDS, */
+/* IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTULP, RTULPI Square roots of the previous 4 values. */
+
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+/* KCONDS(j) Selectw whether CONDS is to be 1 or */
+/* 1/sqrt(ulp). (0 means irrelevant.) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --wr;
+ --wi;
+ --wr1;
+ --wi1;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ lre_dim1 = *ldlre;
+ lre_offset = 1 + lre_dim1;
+ lre -= lre_offset;
+ --rcondv;
+ --rcndv1;
+ --rcdvin;
+ --rconde;
+ --rcnde1;
+ --rcdein;
+ --scale;
+ --scale1;
+ --result;
+ --work;
+ --iwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "VX", (ftnlen)2, (ftnlen)2);
+
+/* Check for errors */
+
+ ntestt = 0;
+ ntestf = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+
+/* 12 is the largest dimension in the input file of precomputed */
+/* problems */
+
+ nmax = 12;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.) {
+ *info = -6;
+ } else if (*lda < 1 || *lda < nmax) {
+ *info = -10;
+ } else if (*ldvl < 1 || *ldvl < nmax) {
+ *info = -17;
+ } else if (*ldvr < 1 || *ldvr < nmax) {
+ *info = -19;
+ } else if (*ldlre < 1 || *ldlre < nmax) {
+ *info = -21;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = nmax;
+ if (nmax * 6 + (i__1 * i__1 << 1) > *nwork) {
+ *info = -32;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DDRVVX", &i__1);
+ return 0;
+ }
+
+/* If nothing to do check on NIUNIT */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ goto L160;
+ }
+
+/* More Important constants */
+
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ dlabad_(&unfl, &ovfl);
+ ulp = dlamch_("Precision");
+ ulpinv = 1. / ulp;
+ rtulp = sqrt(ulp);
+ rtulpi = 1. / rtulp;
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L140;
+ }
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KCONDS KMODE KTYPE */
+/* =1 O(1) 1 clustered 1 zero */
+/* =2 large large clustered 2 identity */
+/* =3 small exponential Jordan */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random general, w/ eigenvalues */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 random general */
+/* =10 random triangular */
+
+ if (mtypes > 21) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L30;
+ case 2: goto L40;
+ case 3: goto L50;
+ }
+
+L30:
+ anorm = 1.;
+ goto L60;
+
+L40:
+ anorm = ovfl * ulp;
+ goto L60;
+
+L50:
+ anorm = unfl * ulpinv;
+ goto L60;
+
+L60:
+
+ dlaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+/* L70: */
+ }
+
+ } else if (itype == 3) {
+
+/* Jordan Block */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+ if (jcol > 1) {
+ a[jcol + (jcol - 1) * a_dim1] = 1.;
+ }
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 6) {
+
+/* General, eigenvalues specified */
+
+ if (kconds[jtype - 1] == 1) {
+ conds = 1.;
+ } else if (kconds[jtype - 1] == 2) {
+ conds = rtulpi;
+ } else {
+ conds = 0.;
+ }
+
+ *(unsigned char *)&adumma[0] = ' ';
+ dlatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b32,
+ adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
+ n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
+ &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &c__0, &
+ c__0, &c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
+ c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* General, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
+ c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+ if (n >= 4) {
+ dlaset_("Full", &c__2, &n, &c_b18, &c_b18, &a[a_offset],
+ lda);
+ i__3 = n - 3;
+ dlaset_("Full", &i__3, &c__1, &c_b18, &c_b18, &a[a_dim1 +
+ 3], lda);
+ i__3 = n - 3;
+ dlaset_("Full", &i__3, &c__2, &c_b18, &c_b18, &a[(n - 1) *
+ a_dim1 + 3], lda);
+ dlaset_("Full", &c__1, &n, &c_b18, &c_b18, &a[n + a_dim1],
+ lda);
+ }
+
+ } else if (itype == 10) {
+
+/* Triangular, random eigenvalues */
+
+ dlatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &c__0, &
+ c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___33.ciunit = *nounit;
+ s_wsfe(&io___33);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+/* Test for minimal and generous workspace */
+
+ for (iwk = 1; iwk <= 3; ++iwk) {
+ if (iwk == 1) {
+ nnwork = n * 3;
+ } else if (iwk == 2) {
+/* Computing 2nd power */
+ i__3 = n;
+ nnwork = n * 6 + i__3 * i__3;
+ } else {
+/* Computing 2nd power */
+ i__3 = n;
+ nnwork = n * 6 + (i__3 * i__3 << 1);
+ }
+ nnwork = max(nnwork,1);
+
+/* Test for all balancing options */
+
+ for (ibal = 1; ibal <= 4; ++ibal) {
+ *(unsigned char *)balanc = *(unsigned char *)&bal[ibal -
+ 1];
+
+/* Perform tests */
+
+ dget23_(&c_false, balanc, &jtype, thresh, ioldsd, nounit,
+ &n, &a[a_offset], lda, &h__[h_offset], &wr[1], &
+ wi[1], &wr1[1], &wi1[1], &vl[vl_offset], ldvl, &
+ vr[vr_offset], ldvr, &lre[lre_offset], ldlre, &
+ rcondv[1], &rcndv1[1], &rcdvin[1], &rconde[1], &
+ rcnde1[1], &rcdein[1], &scale[1], &scale1[1], &
+ result[1], &work[1], &nnwork, &iwork[1], info);
+
+/* Check for RESULT(j) > THRESH */
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 9; ++j) {
+ if (result[j] >= 0.) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L100: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___40.ciunit = *nounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ e_wsfe();
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ e_wsfe();
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ e_wsfe();
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ntestf = 2;
+ }
+
+ for (j = 1; j <= 9; ++j) {
+ if (result[j] >= *thresh) {
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, balanc, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+/* L110: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+
+/* L120: */
+ }
+/* L130: */
+ }
+L140:
+ ;
+ }
+/* L150: */
+ }
+
+L160:
+
+/* Read in data from file to check accuracy of condition estimation. */
+/* Assume input eigenvalues are sorted lexicographically (increasing */
+/* by real part, then decreasing by imaginary part) */
+
+ jtype = 0;
+L170:
+ io___46.ciunit = *niunit;
+ i__1 = s_rsle(&io___46);
+ if (i__1 != 0) {
+ goto L220;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L220;
+ }
+ i__1 = e_rsle();
+ if (i__1 != 0) {
+ goto L220;
+ }
+
+/* Read input data until N=0 */
+
+ if (n == 0) {
+ goto L220;
+ }
+ ++jtype;
+ iseed[1] = jtype;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___48.ciunit = *niunit;
+ s_rsle(&io___48);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__5, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
+ doublereal));
+ }
+ e_rsle();
+/* L180: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___49.ciunit = *niunit;
+ s_rsle(&io___49);
+ do_lio(&c__5, &c__1, (char *)&wr1[i__], (ftnlen)sizeof(doublereal));
+ do_lio(&c__5, &c__1, (char *)&wi1[i__], (ftnlen)sizeof(doublereal));
+ do_lio(&c__5, &c__1, (char *)&rcdein[i__], (ftnlen)sizeof(doublereal))
+ ;
+ do_lio(&c__5, &c__1, (char *)&rcdvin[i__], (ftnlen)sizeof(doublereal))
+ ;
+ e_rsle();
+/* L190: */
+ }
+/* Computing 2nd power */
+ i__2 = n;
+ i__1 = n * 6 + (i__2 * i__2 << 1);
+ dget23_(&c_true, "N", &c__22, thresh, &iseed[1], nounit, &n, &a[a_offset],
+ lda, &h__[h_offset], &wr[1], &wi[1], &wr1[1], &wi1[1], &vl[
+ vl_offset], ldvl, &vr[vr_offset], ldvr, &lre[lre_offset], ldlre, &
+ rcondv[1], &rcndv1[1], &rcdvin[1], &rconde[1], &rcnde1[1], &
+ rcdein[1], &scale[1], &scale1[1], &result[1], &work[1], &i__1, &
+ iwork[1], info);
+
+/* Check for RESULT(j) > THRESH */
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 11; ++j) {
+ if (result[j] >= 0.) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L200: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ e_wsfe();
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ e_wsfe();
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ e_wsfe();
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ntestf = 2;
+ }
+
+ for (j = 1; j <= 11; ++j) {
+ if (result[j] >= *thresh) {
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+/* L210: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+ goto L170;
+L220:
+
+/* Summary */
+
+ dlasum_(path, nounit, &nerrs, &ntestt);
+
+
+
+ return 0;
+
+/* End of DDRVVX */
+
+} /* ddrvvx_ */
diff --git a/TESTING/EIG/derrbd.c b/TESTING/EIG/derrbd.c
new file mode 100644
index 0000000..c864b22
--- /dev/null
+++ b/TESTING/EIG/derrbd.c
@@ -0,0 +1,400 @@
+/* derrbd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int derrbd_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
+ "rror exits\002,\002 (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
+ "ts of the error \002,\002exits ***\002)";
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublereal a[16] /* was [4][4] */, d__[4], e[4];
+ integer i__, j;
+ doublereal q[16] /* was [4][4] */, u[16] /* was [4][4] */, v[16] /*
+ was [4][4] */, w[4];
+ char c2[2];
+ integer iq[16] /* was [4][4] */, iw[4], nt;
+ doublereal tp[4], tq[4];
+ integer info;
+ extern /* Subroutine */ int dgebd2_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *), dbdsdc_(char *, char *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *), dgebrd_(integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int dbdsqr_(char *, integer *, integer *, integer
+ *, integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dorgbr_(char *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), chkxer_(char *, integer *, integer *,
+ logical *, logical *), dormbr_(char *, char *, char *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___18 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___19 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRBD tests the error exits for DGEBRD, DORGBR, DORMBR, DBDSQR and */
+/* DBDSDC. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
+/* L10: */
+ }
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+ nt = 0;
+
+/* Test error exits of the SVD routines. */
+
+ if (lsamen_(&c__2, c2, "BD")) {
+
+/* DGEBRD */
+
+ s_copy(srnamc_1.srnamt, "DGEBRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgebrd_(&c_n1, &c__0, a, &c__1, d__, e, tq, tp, w, &c__1, &info);
+ chkxer_("DGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgebrd_(&c__0, &c_n1, a, &c__1, d__, e, tq, tp, w, &c__1, &info);
+ chkxer_("DGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgebrd_(&c__2, &c__1, a, &c__1, d__, e, tq, tp, w, &c__2, &info);
+ chkxer_("DGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dgebrd_(&c__2, &c__1, a, &c__2, d__, e, tq, tp, w, &c__1, &info);
+ chkxer_("DGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 4;
+
+/* DGEBD2 */
+
+ s_copy(srnamc_1.srnamt, "DGEBD2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgebd2_(&c_n1, &c__0, a, &c__1, d__, e, tq, tp, w, &info);
+ chkxer_("DGEBD2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgebd2_(&c__0, &c_n1, a, &c__1, d__, e, tq, tp, w, &info);
+ chkxer_("DGEBD2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgebd2_(&c__2, &c__1, a, &c__1, d__, e, tq, tp, w, &info);
+ chkxer_("DGEBD2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 3;
+
+/* DORGBR */
+
+ s_copy(srnamc_1.srnamt, "DORGBR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dorgbr_("/", &c__0, &c__0, &c__0, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("DORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dorgbr_("Q", &c_n1, &c__0, &c__0, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("DORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorgbr_("Q", &c__0, &c_n1, &c__0, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("DORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorgbr_("Q", &c__0, &c__1, &c__0, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("DORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorgbr_("Q", &c__1, &c__0, &c__1, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("DORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorgbr_("P", &c__1, &c__0, &c__0, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("DORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorgbr_("P", &c__0, &c__1, &c__1, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("DORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dorgbr_("Q", &c__0, &c__0, &c_n1, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("DORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dorgbr_("Q", &c__2, &c__1, &c__1, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("DORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dorgbr_("Q", &c__2, &c__2, &c__1, a, &c__2, tq, w, &c__1, &info);
+ chkxer_("DORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* DORMBR */
+
+ s_copy(srnamc_1.srnamt, "DORMBR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dormbr_("/", "L", "T", &c__0, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dormbr_("Q", "/", "T", &c__0, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dormbr_("Q", "L", "/", &c__0, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dormbr_("Q", "L", "T", &c_n1, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dormbr_("Q", "L", "T", &c__0, &c_n1, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dormbr_("Q", "L", "T", &c__0, &c__0, &c_n1, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dormbr_("Q", "L", "T", &c__2, &c__0, &c__0, a, &c__1, tq, u, &c__2, w,
+ &c__1, &info);
+ chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dormbr_("Q", "R", "T", &c__0, &c__2, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dormbr_("P", "L", "T", &c__2, &c__0, &c__2, a, &c__1, tq, u, &c__2, w,
+ &c__1, &info);
+ chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dormbr_("P", "R", "T", &c__0, &c__2, &c__2, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dormbr_("Q", "R", "T", &c__2, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ dormbr_("Q", "L", "T", &c__0, &c__2, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ dormbr_("Q", "R", "T", &c__2, &c__0, &c__0, a, &c__1, tq, u, &c__2, w,
+ &c__1, &info);
+ chkxer_("DORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 13;
+
+/* DBDSQR */
+
+ s_copy(srnamc_1.srnamt, "DBDSQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dbdsqr_("/", &c__0, &c__0, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, w, &info);
+ chkxer_("DBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dbdsqr_("U", &c_n1, &c__0, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, w, &info);
+ chkxer_("DBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dbdsqr_("U", &c__0, &c_n1, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, w, &info);
+ chkxer_("DBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dbdsqr_("U", &c__0, &c__0, &c_n1, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, w, &info);
+ chkxer_("DBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dbdsqr_("U", &c__0, &c__0, &c__0, &c_n1, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, w, &info);
+ chkxer_("DBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dbdsqr_("U", &c__2, &c__1, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, w, &info);
+ chkxer_("DBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dbdsqr_("U", &c__0, &c__0, &c__2, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, w, &info);
+ chkxer_("DBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ dbdsqr_("U", &c__2, &c__0, &c__0, &c__1, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, w, &info);
+ chkxer_("DBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* DBDSDC */
+
+ s_copy(srnamc_1.srnamt, "DBDSDC", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dbdsdc_("/", "N", &c__0, d__, e, u, &c__1, v, &c__1, q, iq, w, iw, &
+ info);
+ chkxer_("DBDSDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dbdsdc_("U", "/", &c__0, d__, e, u, &c__1, v, &c__1, q, iq, w, iw, &
+ info);
+ chkxer_("DBDSDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dbdsdc_("U", "N", &c_n1, d__, e, u, &c__1, v, &c__1, q, iq, w, iw, &
+ info);
+ chkxer_("DBDSDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dbdsdc_("U", "I", &c__2, d__, e, u, &c__1, v, &c__1, q, iq, w, iw, &
+ info);
+ chkxer_("DBDSDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dbdsdc_("U", "I", &c__2, d__, e, u, &c__2, v, &c__1, q, iq, w, iw, &
+ info);
+ chkxer_("DBDSDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 5;
+ }
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___18.ciunit = infoc_1.nout;
+ s_wsfe(&io___18);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___19.ciunit = infoc_1.nout;
+ s_wsfe(&io___19);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of DERRBD */
+
+} /* derrbd_ */
diff --git a/TESTING/EIG/derrec.c b/TESTING/EIG/derrec.c
new file mode 100644
index 0000000..bca8bef
--- /dev/null
+++ b/TESTING/EIG/derrec.c
@@ -0,0 +1,359 @@
+/* derrec.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__4 = 4;
+
+/* Subroutine */ int derrec_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
+ "rror exits (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
+ "ts of the error ex\002,\002its ***\002)";
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublereal a[16] /* was [4][4] */, b[16] /* was [4][4] */, c__[16]
+ /* was [4][4] */;
+ integer i__, j, m;
+ doublereal s[4], wi[4];
+ integer nt;
+ doublereal wr[4];
+ logical sel[4];
+ doublereal sep[4];
+ integer info, ifst, ilst;
+ doublereal work[4], scale;
+ integer iwork[4];
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), dtrexc_(char *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, integer *,
+ doublereal *, integer *), dtrsna_(char *, char *, logical
+ *, integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, doublereal *, integer *, integer *, integer *), dtrsen_(char *, char *, logical *, integer *, doublereal
+ *, integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *, integer *, integer *), dtrsyl_(char *,
+ char *, integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___19 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___20 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERREC tests the error exits for the routines for eigen- condition */
+/* estimation for DOUBLE PRECISION matrices: */
+/* DTRSYL, STREXC, STRSNA and STRSEN. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ infoc_1.ok = TRUE_;
+ nt = 0;
+
+/* Initialize A, B and SEL */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (j << 2) - 5] = 0.;
+ b[i__ + (j << 2) - 5] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (i__ << 2) - 5] = 1.;
+ sel[i__ - 1] = TRUE_;
+/* L30: */
+ }
+
+/* Test DTRSYL */
+
+ s_copy(srnamc_1.srnamt, "DTRSYL", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtrsyl_("X", "N", &c__1, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("DTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtrsyl_("N", "X", &c__1, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("DTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dtrsyl_("N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("DTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dtrsyl_("N", "N", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("DTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dtrsyl_("N", "N", &c__1, &c__0, &c_n1, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("DTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dtrsyl_("N", "N", &c__1, &c__2, &c__0, a, &c__1, b, &c__1, c__, &c__2, &
+ scale, &info);
+ chkxer_("DTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dtrsyl_("N", "N", &c__1, &c__0, &c__2, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("DTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dtrsyl_("N", "N", &c__1, &c__2, &c__0, a, &c__2, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("DTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Test DTREXC */
+
+ s_copy(srnamc_1.srnamt, "DTREXC", (ftnlen)32, (ftnlen)6);
+ ifst = 1;
+ ilst = 1;
+ infoc_1.infot = 1;
+ dtrexc_("X", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
+ chkxer_("DTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dtrexc_("N", &c__0, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
+ chkxer_("DTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ilst = 2;
+ dtrexc_("N", &c__2, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
+ chkxer_("DTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dtrexc_("V", &c__2, a, &c__2, b, &c__1, &ifst, &ilst, work, &info);
+ chkxer_("DTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ifst = 0;
+ ilst = 1;
+ dtrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
+ chkxer_("DTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ifst = 2;
+ dtrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
+ chkxer_("DTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ifst = 1;
+ ilst = 0;
+ dtrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
+ chkxer_("DTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ilst = 2;
+ dtrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
+ chkxer_("DTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Test DTRSNA */
+
+ s_copy(srnamc_1.srnamt, "DTRSNA", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtrsna_("X", "A", sel, &c__0, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
+ c__1, &m, work, &c__1, iwork, &info);
+ chkxer_("DTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtrsna_("B", "X", sel, &c__0, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
+ c__1, &m, work, &c__1, iwork, &info);
+ chkxer_("DTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dtrsna_("B", "A", sel, &c_n1, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
+ c__1, &m, work, &c__1, iwork, &info);
+ chkxer_("DTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dtrsna_("V", "A", sel, &c__2, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
+ c__2, &m, work, &c__2, iwork, &info);
+ chkxer_("DTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dtrsna_("B", "A", sel, &c__2, a, &c__2, b, &c__1, c__, &c__2, s, sep, &
+ c__2, &m, work, &c__2, iwork, &info);
+ chkxer_("DTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dtrsna_("B", "A", sel, &c__2, a, &c__2, b, &c__2, c__, &c__1, s, sep, &
+ c__2, &m, work, &c__2, iwork, &info);
+ chkxer_("DTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ dtrsna_("B", "A", sel, &c__1, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
+ c__0, &m, work, &c__1, iwork, &info);
+ chkxer_("DTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ dtrsna_("B", "S", sel, &c__2, a, &c__2, b, &c__2, c__, &c__2, s, sep, &
+ c__1, &m, work, &c__2, iwork, &info);
+ chkxer_("DTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ dtrsna_("B", "A", sel, &c__2, a, &c__2, b, &c__2, c__, &c__2, s, sep, &
+ c__2, &m, work, &c__1, iwork, &info);
+ chkxer_("DTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* Test DTRSEN */
+
+ sel[0] = FALSE_;
+ s_copy(srnamc_1.srnamt, "DTRSEN", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtrsen_("X", "N", sel, &c__0, a, &c__1, b, &c__1, wr, wi, &m, s, sep,
+ work, &c__1, iwork, &c__1, &info);
+ chkxer_("DTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtrsen_("N", "X", sel, &c__0, a, &c__1, b, &c__1, wr, wi, &m, s, sep,
+ work, &c__1, iwork, &c__1, &info);
+ chkxer_("DTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dtrsen_("N", "N", sel, &c_n1, a, &c__1, b, &c__1, wr, wi, &m, s, sep,
+ work, &c__1, iwork, &c__1, &info);
+ chkxer_("DTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dtrsen_("N", "N", sel, &c__2, a, &c__1, b, &c__1, wr, wi, &m, s, sep,
+ work, &c__2, iwork, &c__1, &info);
+ chkxer_("DTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dtrsen_("N", "V", sel, &c__2, a, &c__2, b, &c__1, wr, wi, &m, s, sep,
+ work, &c__1, iwork, &c__1, &info);
+ chkxer_("DTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ dtrsen_("N", "V", sel, &c__2, a, &c__2, b, &c__2, wr, wi, &m, s, sep,
+ work, &c__0, iwork, &c__1, &info);
+ chkxer_("DTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ dtrsen_("E", "V", sel, &c__3, a, &c__3, b, &c__3, wr, wi, &m, s, sep,
+ work, &c__1, iwork, &c__1, &info);
+ chkxer_("DTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ dtrsen_("V", "V", sel, &c__3, a, &c__3, b, &c__3, wr, wi, &m, s, sep,
+ work, &c__3, iwork, &c__2, &info);
+ chkxer_("DTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 17;
+ dtrsen_("E", "V", sel, &c__2, a, &c__2, b, &c__2, wr, wi, &m, s, sep,
+ work, &c__1, iwork, &c__0, &info);
+ chkxer_("DTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 17;
+ dtrsen_("V", "V", sel, &c__3, a, &c__3, b, &c__3, wr, wi, &m, s, sep,
+ work, &c__4, iwork, &c__1, &info);
+ chkxer_("DTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___19.ciunit = infoc_1.nout;
+ s_wsfe(&io___19);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___20.ciunit = infoc_1.nout;
+ s_wsfe(&io___20);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ return 0;
+
+/* End of DERREC */
+
+} /* derrec_ */
diff --git a/TESTING/EIG/derred.c b/TESTING/EIG/derred.c
new file mode 100644
index 0000000..5136fb5
--- /dev/null
+++ b/TESTING/EIG/derred.c
@@ -0,0 +1,501 @@
+/* derred.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ doublereal selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__6 = 6;
+static integer c__8 = 8;
+static integer c__3 = 3;
+static integer c__5 = 5;
+
+/* Subroutine */ int derred_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002 passed the tests of the error exits"
+ " (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a,\002 failed the tests of the "
+ "error exits ***\002)";
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), i_len_trim(char *, ftnlen), do_fio(integer *,
+ char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublereal a[16] /* was [4][4] */;
+ logical b[4];
+ integer i__, j;
+ doublereal s[4], u[16] /* was [4][4] */, w[16];
+ char c2[2];
+ doublereal r1[4], r2[4];
+ integer iw[8];
+ doublereal wi[4];
+ integer nt;
+ doublereal vl[16] /* was [4][4] */, vr[16] /* was [4][4] */, wr[
+ 4], vt[16] /* was [4][4] */;
+ integer ihi, ilo, info, sdim;
+ extern /* Subroutine */ int dgees_(char *, char *, L_fp, integer *,
+ doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, logical *,
+ integer *), dgeev_(char *, char *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *);
+ doublereal abnrm;
+ extern /* Subroutine */ int dgesdd_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *), dgesvd_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+ extern logical dslect_();
+ extern /* Subroutine */ int dgeesx_(char *, char *, L_fp, char *, integer
+ *, doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *
+, integer *, integer *, integer *, logical *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int dgeevx_(char *, char *, char *, char *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, integer *), chkxer_(char *, integer *, integer *, logical *,
+ logical *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRED tests the error exits for the eigenvalue driver routines for */
+/* DOUBLE PRECISION matrices: */
+
+/* PATH driver description */
+/* ---- ------ ----------- */
+/* SEV DGEEV find eigenvalues/eigenvectors for nonsymmetric A */
+/* SES DGEES find eigenvalues/Schur form for nonsymmetric A */
+/* SVX DGEEVX SGEEV + balancing and condition estimation */
+/* SSX DGEESX SGEES + balancing and condition estimation */
+/* DBD DGESVD compute SVD of an M-by-N matrix A */
+/* DGESDD compute SVD of an M-by-N matrix A (by divide and */
+/* conquer) */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Initialize A */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (j << 2) - 5] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (i__ << 2) - 5] = 1.;
+/* L30: */
+ }
+ infoc_1.ok = TRUE_;
+ nt = 0;
+
+ if (lsamen_(&c__2, c2, "EV")) {
+
+/* Test DGEEV */
+
+ s_copy(srnamc_1.srnamt, "DGEEV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgeev_("X", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
+ c__1, &info);
+ chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgeev_("N", "X", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
+ c__1, &info);
+ chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgeev_("N", "N", &c_n1, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
+ c__1, &info);
+ chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgeev_("N", "N", &c__2, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
+ c__6, &info);
+ chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dgeev_("V", "N", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &c__1, w, &
+ c__8, &info);
+ chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dgeev_("N", "V", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &c__1, w, &
+ c__8, &info);
+ chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ dgeev_("V", "V", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
+ c__3, &info);
+ chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+
+ } else if (lsamen_(&c__2, c2, "ES")) {
+
+/* Test DGEES */
+
+ s_copy(srnamc_1.srnamt, "DGEES ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgees_("X", "N", (L_fp)dslect_, &c__0, a, &c__1, &sdim, wr, wi, vl, &
+ c__1, w, &c__1, b, &info);
+ chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgees_("N", "X", (L_fp)dslect_, &c__0, a, &c__1, &sdim, wr, wi, vl, &
+ c__1, w, &c__1, b, &info);
+ chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgees_("N", "S", (L_fp)dslect_, &c_n1, a, &c__1, &sdim, wr, wi, vl, &
+ c__1, w, &c__1, b, &info);
+ chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dgees_("N", "S", (L_fp)dslect_, &c__2, a, &c__1, &sdim, wr, wi, vl, &
+ c__1, w, &c__6, b, &info);
+ chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dgees_("V", "S", (L_fp)dslect_, &c__2, a, &c__2, &sdim, wr, wi, vl, &
+ c__1, w, &c__6, b, &info);
+ chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ dgees_("N", "S", (L_fp)dslect_, &c__1, a, &c__1, &sdim, wr, wi, vl, &
+ c__1, w, &c__2, b, &info);
+ chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+ } else if (lsamen_(&c__2, c2, "VX")) {
+
+/* Test DGEEVX */
+
+ s_copy(srnamc_1.srnamt, "DGEEVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgeevx_("X", "N", "N", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
+ chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgeevx_("N", "X", "N", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
+ chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgeevx_("N", "N", "X", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
+ chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgeevx_("N", "N", "N", "X", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
+ chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgeevx_("N", "N", "N", "N", &c_n1, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
+ chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dgeevx_("N", "N", "N", "N", &c__2, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
+ chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dgeevx_("N", "V", "N", "N", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
+ c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__6, iw, &info);
+ chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ dgeevx_("N", "N", "V", "N", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
+ c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__6, iw, &info);
+ chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 21;
+ dgeevx_("N", "N", "N", "N", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
+ chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 21;
+ dgeevx_("N", "V", "N", "N", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__2, iw, &info);
+ chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 21;
+ dgeevx_("N", "N", "V", "V", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__3, iw, &info);
+ chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+ } else if (lsamen_(&c__2, c2, "SX")) {
+
+/* Test DGEESX */
+
+ s_copy(srnamc_1.srnamt, "DGEESX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgeesx_("X", "N", (L_fp)dslect_, "N", &c__0, a, &c__1, &sdim, wr, wi,
+ vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
+ chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgeesx_("N", "X", (L_fp)dslect_, "N", &c__0, a, &c__1, &sdim, wr, wi,
+ vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
+ chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgeesx_("N", "N", (L_fp)dslect_, "X", &c__0, a, &c__1, &sdim, wr, wi,
+ vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
+ chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgeesx_("N", "N", (L_fp)dslect_, "N", &c_n1, a, &c__1, &sdim, wr, wi,
+ vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
+ chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dgeesx_("N", "N", (L_fp)dslect_, "N", &c__2, a, &c__1, &sdim, wr, wi,
+ vl, &c__1, r1, r2, w, &c__6, iw, &c__1, b, &info);
+ chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dgeesx_("V", "N", (L_fp)dslect_, "N", &c__2, a, &c__2, &sdim, wr, wi,
+ vl, &c__1, r1, r2, w, &c__6, iw, &c__1, b, &info);
+ chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ dgeesx_("N", "N", (L_fp)dslect_, "N", &c__1, a, &c__1, &sdim, wr, wi,
+ vl, &c__1, r1, r2, w, &c__2, iw, &c__1, b, &info);
+ chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+
+ } else if (lsamen_(&c__2, c2, "BD")) {
+
+/* Test DGESVD */
+
+ s_copy(srnamc_1.srnamt, "DGESVD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgesvd_("X", "N", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__1, &info);
+ chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgesvd_("N", "X", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__1, &info);
+ chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgesvd_("O", "O", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__1, &info);
+ chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgesvd_("N", "N", &c_n1, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__1, &info);
+ chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgesvd_("N", "N", &c__0, &c_n1, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__1, &info);
+ chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dgesvd_("N", "N", &c__2, &c__1, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__5, &info);
+ chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dgesvd_("A", "N", &c__2, &c__1, a, &c__2, s, u, &c__1, vt, &c__1, w, &
+ c__5, &info);
+ chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dgesvd_("N", "A", &c__1, &c__2, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__5, &info);
+ chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+ if (infoc_1.ok) {
+ io___24.ciunit = infoc_1.nout;
+ s_wsfe(&io___24);
+ do_fio(&c__1, srnamc_1.srnamt, i_len_trim(srnamc_1.srnamt, (
+ ftnlen)32));
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___25.ciunit = infoc_1.nout;
+ s_wsfe(&io___25);
+ e_wsfe();
+ }
+
+/* Test DGESDD */
+
+ s_copy(srnamc_1.srnamt, "DGESDD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgesdd_("X", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
+ iw, &info);
+ chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgesdd_("N", &c_n1, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
+ iw, &info);
+ chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgesdd_("N", &c__0, &c_n1, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
+ iw, &info);
+ chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgesdd_("N", &c__2, &c__1, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__5,
+ iw, &info);
+ chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dgesdd_("A", &c__2, &c__1, a, &c__2, s, u, &c__1, vt, &c__1, w, &c__5,
+ iw, &info);
+ chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dgesdd_("A", &c__1, &c__2, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__5,
+ iw, &info);
+ chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += -2;
+ if (infoc_1.ok) {
+ io___26.ciunit = infoc_1.nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, srnamc_1.srnamt, i_len_trim(srnamc_1.srnamt, (
+ ftnlen)32));
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___27.ciunit = infoc_1.nout;
+ s_wsfe(&io___27);
+ e_wsfe();
+ }
+ }
+
+/* Print a summary line. */
+
+ if (! lsamen_(&c__2, c2, "BD")) {
+ if (infoc_1.ok) {
+ io___28.ciunit = infoc_1.nout;
+ s_wsfe(&io___28);
+ do_fio(&c__1, srnamc_1.srnamt, i_len_trim(srnamc_1.srnamt, (
+ ftnlen)32));
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___29.ciunit = infoc_1.nout;
+ s_wsfe(&io___29);
+ e_wsfe();
+ }
+ }
+
+ return 0;
+
+/* End of DERRED */
+} /* derred_ */
diff --git a/TESTING/EIG/derrgg.c b/TESTING/EIG/derrgg.c
new file mode 100644
index 0000000..4995e34
--- /dev/null
+++ b/TESTING/EIG/derrgg.c
@@ -0,0 +1,1319 @@
+/* derrgg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__18 = 18;
+static integer c__3 = 3;
+static integer c__32 = 32;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+static integer c__20 = 20;
+
+/* Subroutine */ int derrgg_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
+ "rror exits (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
+ "ts of the error \002,\002exits ***\002)";
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublereal a[9] /* was [3][3] */, b[9] /* was [3][3] */;
+ integer i__, j, m;
+ doublereal q[9] /* was [3][3] */, u[9] /* was [3][3] */, v[9] /*
+ was [3][3] */, w[18], z__[9] /* was [3][3] */;
+ char c2[2];
+ doublereal r1[3], r2[3], r3[3];
+ logical bw[3];
+ doublereal ls[3];
+ integer iw[3], nt;
+ doublereal rs[3], dif, rce[2];
+ logical sel[3];
+ doublereal tau[3], rcv[2];
+ integer info, sdim;
+ doublereal anrm, bnrm, tola, tolb;
+ integer ifst, ilst;
+ doublereal scale;
+ extern /* Subroutine */ int dgges_(char *, char *, char *, L_fp, integer *
+, doublereal *, integer *, doublereal *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, logical *,
+ integer *), dggev_(char *, char *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dgghrd_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dggglm_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *),
+ dgglse_(integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *), dggqrf_(integer *, integer *
+, integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *),
+ dggrqf_(integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *);
+ integer ncycle;
+ extern logical dlctes_(), lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int dggsvd_(char *, char *, char *, integer *,
+ integer *, integer *, integer *, integer *, doublereal *, integer
+ *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *), dggesx_(char *, char *, char *, L_fp, char *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *
+, integer *, integer *, integer *, logical *, integer *), dhgeqz_(char *, char *, char *, integer *
+, integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *), dtgevc_(char *, char *,
+ logical *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *, doublereal *, integer *),
+ chkxer_(char *, integer *, integer *, logical *, logical *), dggevx_(char *, char *, char *, char *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, logical *, integer *), dtgexc_(logical *, logical *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, integer *,
+ doublereal *, integer *, integer *), dtgsen_(integer *, logical *,
+ logical *, logical *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *, integer *, integer *), dtgsja_(char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *), dtgsna_(char *,
+ char *, logical *, integer *, doublereal *, integer *, doublereal
+ *, integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *, integer *), dggsvp_(char *,
+ char *, char *, integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ doublereal *, integer *);
+ extern logical dlctsx_();
+ integer dummyk, dummyl;
+ extern /* Subroutine */ int dtgsyl_(char *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRGG tests the error exits for DGGES, DGGESX, DGGEV, DGGEVX, */
+/* DGGGLM, DGGHRD, DGGLSE, DGGQRF, DGGRQF, DGGSVD, DGGSVP, DHGEQZ, */
+/* DTGEVC, DTGEXC, DTGSEN, DTGSJA, DTGSNA, and DTGSYL. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 3; ++j) {
+ sel[j - 1] = TRUE_;
+ for (i__ = 1; i__ <= 3; ++i__) {
+ a[i__ + j * 3 - 4] = 0.;
+ b[i__ + j * 3 - 4] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ for (i__ = 1; i__ <= 3; ++i__) {
+ a[i__ + i__ * 3 - 4] = 1.;
+ b[i__ + i__ * 3 - 4] = 1.;
+/* L30: */
+ }
+ infoc_1.ok = TRUE_;
+ tola = 1.;
+ tolb = 1.;
+ ifst = 1;
+ ilst = 1;
+ nt = 0;
+
+/* Test error exits for the GG path. */
+
+ if (lsamen_(&c__2, c2, "GG")) {
+
+/* DGGHRD */
+
+ s_copy(srnamc_1.srnamt, "DGGHRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgghrd_("/", "N", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("DGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgghrd_("N", "/", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("DGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgghrd_("N", "N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("DGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgghrd_("N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("DGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgghrd_("N", "N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("DGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dgghrd_("N", "N", &c__2, &c__1, &c__1, a, &c__1, b, &c__2, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("DGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dgghrd_("N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("DGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dgghrd_("V", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("DGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ dgghrd_("N", "V", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("DGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* DHGEQZ */
+
+ s_copy(srnamc_1.srnamt, "DHGEQZ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dhgeqz_("/", "N", "N", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, w, &c__18, &info);
+ chkxer_("DHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dhgeqz_("E", "/", "N", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, w, &c__18, &info);
+ chkxer_("DHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dhgeqz_("E", "N", "/", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, w, &c__18, &info);
+ chkxer_("DHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dhgeqz_("E", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, w, &c__18, &info);
+ chkxer_("DHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dhgeqz_("E", "N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, w, &c__18, &info);
+ chkxer_("DHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dhgeqz_("E", "N", "N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, w, &c__18, &info);
+ chkxer_("DHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dhgeqz_("E", "N", "N", &c__2, &c__1, &c__1, a, &c__1, b, &c__2, r1,
+ r2, r3, q, &c__1, z__, &c__1, w, &c__18, &info);
+ chkxer_("DHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dhgeqz_("E", "N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, w, &c__18, &info);
+ chkxer_("DHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ dhgeqz_("E", "V", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, r1,
+ r2, r3, q, &c__1, z__, &c__1, w, &c__18, &info);
+ chkxer_("DHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 17;
+ dhgeqz_("E", "N", "V", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, r1,
+ r2, r3, q, &c__1, z__, &c__1, w, &c__18, &info);
+ chkxer_("DHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* DTGEVC */
+
+ s_copy(srnamc_1.srnamt, "DTGEVC", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtgevc_("/", "A", sel, &c__0, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__1, &c__0, &m, w, &info);
+ chkxer_("DTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtgevc_("R", "/", sel, &c__0, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__1, &c__0, &m, w, &info);
+ chkxer_("DTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dtgevc_("R", "A", sel, &c_n1, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__1, &c__0, &m, w, &info);
+ chkxer_("DTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dtgevc_("R", "A", sel, &c__2, a, &c__1, b, &c__2, q, &c__1, z__, &
+ c__2, &c__0, &m, w, &info);
+ chkxer_("DTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dtgevc_("R", "A", sel, &c__2, a, &c__2, b, &c__1, q, &c__1, z__, &
+ c__2, &c__0, &m, w, &info);
+ chkxer_("DTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dtgevc_("L", "A", sel, &c__2, a, &c__2, b, &c__2, q, &c__1, z__, &
+ c__1, &c__0, &m, w, &info);
+ chkxer_("DTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dtgevc_("R", "A", sel, &c__2, a, &c__2, b, &c__2, q, &c__1, z__, &
+ c__1, &c__0, &m, w, &info);
+ chkxer_("DTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ dtgevc_("R", "A", sel, &c__2, a, &c__2, b, &c__2, q, &c__1, z__, &
+ c__2, &c__1, &m, w, &info);
+ chkxer_("DTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Test error exits for the GSV path. */
+
+ } else if (lsamen_(&c__3, path, "GSV")) {
+
+/* DGGSVD */
+
+ s_copy(srnamc_1.srnamt, "DGGSVD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dggsvd_("/", "N", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, iw, &
+ info);
+ chkxer_("DGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dggsvd_("N", "/", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, iw, &
+ info);
+ chkxer_("DGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dggsvd_("N", "N", "/", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, iw, &
+ info);
+ chkxer_("DGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dggsvd_("N", "N", "N", &c_n1, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, iw, &
+ info);
+ chkxer_("DGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dggsvd_("N", "N", "N", &c__0, &c_n1, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, iw, &
+ info);
+ chkxer_("DGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dggsvd_("N", "N", "N", &c__0, &c__0, &c_n1, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, iw, &
+ info);
+ chkxer_("DGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dggsvd_("N", "N", "N", &c__2, &c__1, &c__1, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, iw, &
+ info);
+ chkxer_("DGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dggsvd_("N", "N", "N", &c__1, &c__1, &c__2, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, iw, &
+ info);
+ chkxer_("DGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ dggsvd_("U", "N", "N", &c__2, &c__2, &c__2, &dummyk, &dummyl, a, &
+ c__2, b, &c__2, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, iw, &
+ info);
+ chkxer_("DGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ dggsvd_("N", "V", "N", &c__1, &c__1, &c__2, &dummyk, &dummyl, a, &
+ c__1, b, &c__2, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, iw, &
+ info);
+ chkxer_("DGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ dggsvd_("N", "N", "Q", &c__1, &c__2, &c__1, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, iw, &
+ info);
+ chkxer_("DGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* DGGSVP */
+
+ s_copy(srnamc_1.srnamt, "DGGSVP", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dggsvp_("/", "N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ tau, w, &info);
+ chkxer_("DGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dggsvp_("N", "/", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ tau, w, &info);
+ chkxer_("DGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dggsvp_("N", "N", "/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ tau, w, &info);
+ chkxer_("DGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dggsvp_("N", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ tau, w, &info);
+ chkxer_("DGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dggsvp_("N", "N", "N", &c__0, &c_n1, &c__0, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ tau, w, &info);
+ chkxer_("DGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dggsvp_("N", "N", "N", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ tau, w, &info);
+ chkxer_("DGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dggsvp_("N", "N", "N", &c__2, &c__1, &c__1, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ tau, w, &info);
+ chkxer_("DGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dggsvp_("N", "N", "N", &c__1, &c__2, &c__1, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ tau, w, &info);
+ chkxer_("DGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ dggsvp_("U", "N", "N", &c__2, &c__2, &c__2, a, &c__2, b, &c__2, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ tau, w, &info);
+ chkxer_("DGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ dggsvp_("N", "V", "N", &c__1, &c__2, &c__1, a, &c__1, b, &c__2, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ tau, w, &info);
+ chkxer_("DGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ dggsvp_("N", "N", "Q", &c__1, &c__1, &c__2, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ tau, w, &info);
+ chkxer_("DGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* DTGSJA */
+
+ s_copy(srnamc_1.srnamt, "DTGSJA", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtgsja_("/", "N", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("DTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtgsja_("N", "/", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("DTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dtgsja_("N", "N", "/", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("DTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dtgsja_("N", "N", "N", &c_n1, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("DTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dtgsja_("N", "N", "N", &c__0, &c_n1, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("DTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dtgsja_("N", "N", "N", &c__0, &c__0, &c_n1, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("DTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dtgsja_("N", "N", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__0, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("DTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dtgsja_("N", "N", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__0, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("DTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ dtgsja_("U", "N", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__0, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("DTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ dtgsja_("N", "V", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__0, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("DTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 22;
+ dtgsja_("N", "N", "Q", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__0, w, &ncycle, &info);
+ chkxer_("DTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* Test error exits for the GLM path. */
+
+ } else if (lsamen_(&c__3, path, "GLM")) {
+
+/* DGGGLM */
+
+ s_copy(srnamc_1.srnamt, "DGGGLM", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dggglm_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("DGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dggglm_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("DGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dggglm_(&c__0, &c__1, &c__0, a, &c__1, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("DGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dggglm_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("DGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dggglm_(&c__1, &c__0, &c__0, a, &c__1, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("DGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dggglm_(&c__0, &c__0, &c__0, a, &c__0, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("DGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dggglm_(&c__0, &c__0, &c__0, a, &c__1, b, &c__0, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("DGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dggglm_(&c__1, &c__1, &c__1, a, &c__1, b, &c__1, r1, r2, r3, w, &c__1,
+ &info);
+ chkxer_("DGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Test error exits for the LSE path. */
+
+ } else if (lsamen_(&c__3, path, "LSE")) {
+
+/* DGGLSE */
+
+ s_copy(srnamc_1.srnamt, "DGGLSE", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgglse_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("DGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgglse_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("DGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgglse_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("DGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgglse_(&c__0, &c__0, &c__1, a, &c__1, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("DGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgglse_(&c__0, &c__1, &c__0, a, &c__1, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("DGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgglse_(&c__0, &c__0, &c__0, a, &c__0, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("DGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dgglse_(&c__0, &c__0, &c__0, a, &c__1, b, &c__0, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("DGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dgglse_(&c__1, &c__1, &c__1, a, &c__1, b, &c__1, r1, r2, r3, w, &c__1,
+ &info);
+ chkxer_("DGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Test error exits for the GQR path. */
+
+ } else if (lsamen_(&c__3, path, "GQR")) {
+
+/* DGGQRF */
+
+ s_copy(srnamc_1.srnamt, "DGGQRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dggqrf_(&c_n1, &c__0, &c__0, a, &c__1, r1, b, &c__1, r2, w, &c__18, &
+ info);
+ chkxer_("DGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dggqrf_(&c__0, &c_n1, &c__0, a, &c__1, r1, b, &c__1, r2, w, &c__18, &
+ info);
+ chkxer_("DGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dggqrf_(&c__0, &c__0, &c_n1, a, &c__1, r1, b, &c__1, r2, w, &c__18, &
+ info);
+ chkxer_("DGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dggqrf_(&c__0, &c__0, &c__0, a, &c__0, r1, b, &c__1, r2, w, &c__18, &
+ info);
+ chkxer_("DGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dggqrf_(&c__0, &c__0, &c__0, a, &c__1, r1, b, &c__0, r2, w, &c__18, &
+ info);
+ chkxer_("DGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dggqrf_(&c__1, &c__1, &c__2, a, &c__1, r1, b, &c__1, r2, w, &c__1, &
+ info);
+ chkxer_("DGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+/* DGGRQF */
+
+ s_copy(srnamc_1.srnamt, "DGGRQF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dggrqf_(&c_n1, &c__0, &c__0, a, &c__1, r1, b, &c__1, r2, w, &c__18, &
+ info);
+ chkxer_("DGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dggrqf_(&c__0, &c_n1, &c__0, a, &c__1, r1, b, &c__1, r2, w, &c__18, &
+ info);
+ chkxer_("DGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dggrqf_(&c__0, &c__0, &c_n1, a, &c__1, r1, b, &c__1, r2, w, &c__18, &
+ info);
+ chkxer_("DGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dggrqf_(&c__0, &c__0, &c__0, a, &c__0, r1, b, &c__1, r2, w, &c__18, &
+ info);
+ chkxer_("DGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dggrqf_(&c__0, &c__0, &c__0, a, &c__1, r1, b, &c__0, r2, w, &c__18, &
+ info);
+ chkxer_("DGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dggrqf_(&c__1, &c__1, &c__2, a, &c__1, r1, b, &c__1, r2, w, &c__1, &
+ info);
+ chkxer_("DGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+/* Test error exits for the DGS, DGV, DGX, and DXV paths. */
+
+ } else if (lsamen_(&c__3, path, "DGS") || lsamen_(&
+ c__3, path, "DGV") || lsamen_(&c__3, path,
+ "DGX") || lsamen_(&c__3, path, "DXV")) {
+
+/* DGGES */
+
+ s_copy(srnamc_1.srnamt, "DGGES ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgges_("/", "N", "S", (L_fp)dlctes_, &c__1, a, &c__1, b, &c__1, &sdim,
+ r1, r2, r3, q, &c__1, u, &c__1, w, &c__1, bw, &info);
+ chkxer_("DGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgges_("N", "/", "S", (L_fp)dlctes_, &c__1, a, &c__1, b, &c__1, &sdim,
+ r1, r2, r3, q, &c__1, u, &c__1, w, &c__1, bw, &info);
+ chkxer_("DGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgges_("N", "V", "/", (L_fp)dlctes_, &c__1, a, &c__1, b, &c__1, &sdim,
+ r1, r2, r3, q, &c__1, u, &c__1, w, &c__1, bw, &info);
+ chkxer_("DGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgges_("N", "V", "S", (L_fp)dlctes_, &c_n1, a, &c__1, b, &c__1, &sdim,
+ r1, r2, r3, q, &c__1, u, &c__1, w, &c__1, bw, &info);
+ chkxer_("DGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dgges_("N", "V", "S", (L_fp)dlctes_, &c__1, a, &c__0, b, &c__1, &sdim,
+ r1, r2, r3, q, &c__1, u, &c__1, w, &c__1, bw, &info);
+ chkxer_("DGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dgges_("N", "V", "S", (L_fp)dlctes_, &c__1, a, &c__1, b, &c__0, &sdim,
+ r1, r2, r3, q, &c__1, u, &c__1, w, &c__1, bw, &info);
+ chkxer_("DGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ dgges_("N", "V", "S", (L_fp)dlctes_, &c__1, a, &c__1, b, &c__1, &sdim,
+ r1, r2, r3, q, &c__0, u, &c__1, w, &c__1, bw, &info);
+ chkxer_("DGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ dgges_("V", "V", "S", (L_fp)dlctes_, &c__2, a, &c__2, b, &c__2, &sdim,
+ r1, r2, r3, q, &c__1, u, &c__2, w, &c__1, bw, &info);
+ chkxer_("DGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 17;
+ dgges_("N", "V", "S", (L_fp)dlctes_, &c__1, a, &c__1, b, &c__1, &sdim,
+ r1, r2, r3, q, &c__1, u, &c__0, w, &c__1, bw, &info);
+ chkxer_("DGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 17;
+ dgges_("V", "V", "S", (L_fp)dlctes_, &c__2, a, &c__2, b, &c__2, &sdim,
+ r1, r2, r3, q, &c__2, u, &c__1, w, &c__1, bw, &info);
+ chkxer_("DGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 19;
+ dgges_("V", "V", "S", (L_fp)dlctes_, &c__2, a, &c__2, b, &c__2, &sdim,
+ r1, r2, r3, q, &c__2, u, &c__2, w, &c__1, bw, &info);
+ chkxer_("DGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* DGGESX */
+
+ s_copy(srnamc_1.srnamt, "DGGESX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dggesx_("/", "N", "S", (L_fp)dlctsx_, "N", &c__1, a, &c__1, b, &c__1,
+ &sdim, r1, r2, r3, q, &c__1, u, &c__1, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("DGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dggesx_("N", "/", "S", (L_fp)dlctsx_, "N", &c__1, a, &c__1, b, &c__1,
+ &sdim, r1, r2, r3, q, &c__1, u, &c__1, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("DGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dggesx_("V", "V", "/", (L_fp)dlctsx_, "N", &c__1, a, &c__1, b, &c__1,
+ &sdim, r1, r2, r3, q, &c__1, u, &c__1, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("DGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dggesx_("V", "V", "S", (L_fp)dlctsx_, "/", &c__1, a, &c__1, b, &c__1,
+ &sdim, r1, r2, r3, q, &c__1, u, &c__1, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("DGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dggesx_("V", "V", "S", (L_fp)dlctsx_, "B", &c_n1, a, &c__1, b, &c__1,
+ &sdim, r1, r2, r3, q, &c__1, u, &c__1, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("DGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dggesx_("V", "V", "S", (L_fp)dlctsx_, "B", &c__1, a, &c__0, b, &c__1,
+ &sdim, r1, r2, r3, q, &c__1, u, &c__1, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("DGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dggesx_("V", "V", "S", (L_fp)dlctsx_, "B", &c__1, a, &c__1, b, &c__0,
+ &sdim, r1, r2, r3, q, &c__1, u, &c__1, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("DGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ dggesx_("V", "V", "S", (L_fp)dlctsx_, "B", &c__1, a, &c__1, b, &c__1,
+ &sdim, r1, r2, r3, q, &c__0, u, &c__1, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("DGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ dggesx_("V", "V", "S", (L_fp)dlctsx_, "B", &c__2, a, &c__2, b, &c__2,
+ &sdim, r1, r2, r3, q, &c__1, u, &c__1, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("DGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ dggesx_("V", "V", "S", (L_fp)dlctsx_, "B", &c__1, a, &c__1, b, &c__1,
+ &sdim, r1, r2, r3, q, &c__1, u, &c__0, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("DGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ dggesx_("V", "V", "S", (L_fp)dlctsx_, "B", &c__2, a, &c__2, b, &c__2,
+ &sdim, r1, r2, r3, q, &c__2, u, &c__1, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("DGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 22;
+ dggesx_("V", "V", "S", (L_fp)dlctsx_, "B", &c__2, a, &c__2, b, &c__2,
+ &sdim, r1, r2, r3, q, &c__2, u, &c__2, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("DGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 24;
+ dggesx_("V", "V", "S", (L_fp)dlctsx_, "V", &c__1, a, &c__1, b, &c__1,
+ &sdim, r1, r2, r3, q, &c__1, u, &c__1, rce, rcv, w, &c__32,
+ iw, &c__0, bw, &info);
+ chkxer_("DGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 13;
+
+/* DGGEV */
+
+ s_copy(srnamc_1.srnamt, "DGGEV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dggev_("/", "N", &c__1, a, &c__1, b, &c__1, r1, r2, r3, q, &c__1, u, &
+ c__1, w, &c__1, &info);
+ chkxer_("DGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dggev_("N", "/", &c__1, a, &c__1, b, &c__1, r1, r2, r3, q, &c__1, u, &
+ c__1, w, &c__1, &info);
+ chkxer_("DGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dggev_("V", "V", &c_n1, a, &c__1, b, &c__1, r1, r2, r3, q, &c__1, u, &
+ c__1, w, &c__1, &info);
+ chkxer_("DGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dggev_("V", "V", &c__1, a, &c__0, b, &c__1, r1, r2, r3, q, &c__1, u, &
+ c__1, w, &c__1, &info);
+ chkxer_("DGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dggev_("V", "V", &c__1, a, &c__1, b, &c__0, r1, r2, r3, q, &c__1, u, &
+ c__1, w, &c__1, &info);
+ chkxer_("DGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dggev_("N", "V", &c__1, a, &c__1, b, &c__1, r1, r2, r3, q, &c__0, u, &
+ c__1, w, &c__1, &info);
+ chkxer_("DGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dggev_("V", "V", &c__2, a, &c__2, b, &c__2, r1, r2, r3, q, &c__1, u, &
+ c__2, w, &c__1, &info);
+ chkxer_("DGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ dggev_("V", "N", &c__2, a, &c__2, b, &c__2, r1, r2, r3, q, &c__2, u, &
+ c__0, w, &c__1, &info);
+ chkxer_("DGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ dggev_("V", "V", &c__2, a, &c__2, b, &c__2, r1, r2, r3, q, &c__2, u, &
+ c__1, w, &c__1, &info);
+ chkxer_("DGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ dggev_("V", "V", &c__1, a, &c__1, b, &c__1, r1, r2, r3, q, &c__1, u, &
+ c__1, w, &c__1, &info);
+ chkxer_("DGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* DGGEVX */
+
+ s_copy(srnamc_1.srnamt, "DGGEVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dggevx_("/", "N", "N", "N", &c__1, a, &c__1, b, &c__1, r1, r2, r3, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("DGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dggevx_("N", "/", "N", "N", &c__1, a, &c__1, b, &c__1, r1, r2, r3, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("DGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dggevx_("N", "N", "/", "N", &c__1, a, &c__1, b, &c__1, r1, r2, r3, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("DGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dggevx_("N", "N", "N", "/", &c__1, a, &c__1, b, &c__1, r1, r2, r3, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("DGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dggevx_("N", "N", "N", "N", &c_n1, a, &c__1, b, &c__1, r1, r2, r3, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("DGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dggevx_("N", "N", "N", "N", &c__1, a, &c__0, b, &c__1, r1, r2, r3, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("DGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dggevx_("N", "N", "N", "N", &c__1, a, &c__1, b, &c__0, r1, r2, r3, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("DGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ dggevx_("N", "N", "N", "N", &c__1, a, &c__1, b, &c__1, r1, r2, r3, q,
+ &c__0, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("DGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ dggevx_("N", "V", "N", "N", &c__2, a, &c__2, b, &c__2, r1, r2, r3, q,
+ &c__1, u, &c__2, &c__1, &c__2, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("DGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ dggevx_("N", "N", "N", "N", &c__1, a, &c__1, b, &c__1, r1, r2, r3, q,
+ &c__1, u, &c__0, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("DGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ dggevx_("N", "N", "V", "N", &c__2, a, &c__2, b, &c__2, r1, r2, r3, q,
+ &c__2, u, &c__1, &c__1, &c__2, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("DGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 26;
+ dggevx_("N", "N", "V", "N", &c__2, a, &c__2, b, &c__2, r1, r2, r3, q,
+ &c__2, u, &c__2, &c__1, &c__2, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("DGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 12;
+
+/* DTGEXC */
+
+ s_copy(srnamc_1.srnamt, "DTGEXC", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 3;
+ dtgexc_(&c_true, &c_true, &c_n1, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__1, &ifst, &ilst, w, &c__1, &info);
+ chkxer_("DTGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dtgexc_(&c_true, &c_true, &c__1, a, &c__0, b, &c__1, q, &c__1, z__, &
+ c__1, &ifst, &ilst, w, &c__1, &info);
+ chkxer_("DTGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dtgexc_(&c_true, &c_true, &c__1, a, &c__1, b, &c__0, q, &c__1, z__, &
+ c__1, &ifst, &ilst, w, &c__1, &info);
+ chkxer_("DTGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dtgexc_(&c_false, &c_true, &c__1, a, &c__1, b, &c__1, q, &c__0, z__, &
+ c__1, &ifst, &ilst, w, &c__1, &info);
+ chkxer_("DTGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dtgexc_(&c_true, &c_true, &c__1, a, &c__1, b, &c__1, q, &c__0, z__, &
+ c__1, &ifst, &ilst, w, &c__1, &info);
+ chkxer_("DTGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dtgexc_(&c_true, &c_false, &c__1, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__0, &ifst, &ilst, w, &c__1, &info);
+ chkxer_("DTGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dtgexc_(&c_true, &c_true, &c__1, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__0, &ifst, &ilst, w, &c__1, &info);
+ chkxer_("DTGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ dtgexc_(&c_true, &c_true, &c__1, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__1, &ifst, &ilst, w, &c__0, &info);
+ chkxer_("DTGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* DTGSEN */
+
+ s_copy(srnamc_1.srnamt, "DTGSEN", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtgsen_(&c_n1, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &c__1,
+ iw, &c__1, &info);
+ chkxer_("DTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dtgsen_(&c__1, &c_true, &c_true, sel, &c_n1, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &c__1,
+ iw, &c__1, &info);
+ chkxer_("DTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dtgsen_(&c__1, &c_true, &c_true, sel, &c__1, a, &c__0, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &c__1,
+ iw, &c__1, &info);
+ chkxer_("DTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dtgsen_(&c__1, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__0, r1,
+ r2, r3, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &c__1,
+ iw, &c__1, &info);
+ chkxer_("DTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ dtgsen_(&c__1, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__0, z__, &c__1, &m, &tola, &tolb, rcv, w, &c__1,
+ iw, &c__1, &info);
+ chkxer_("DTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ dtgsen_(&c__1, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__0, &m, &tola, &tolb, rcv, w, &c__1,
+ iw, &c__1, &info);
+ chkxer_("DTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 22;
+ dtgsen_(&c__0, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &c__1,
+ iw, &c__1, &info);
+ chkxer_("DTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 22;
+ dtgsen_(&c__1, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &c__1,
+ iw, &c__1, &info);
+ chkxer_("DTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 22;
+ dtgsen_(&c__2, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &c__1,
+ iw, &c__1, &info);
+ chkxer_("DTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 24;
+ dtgsen_(&c__0, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c__20, iw, &c__0, &info);
+ chkxer_("DTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 24;
+ dtgsen_(&c__1, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c__20, iw, &c__0, &info);
+ chkxer_("DTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 24;
+ dtgsen_(&c__2, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c__20, iw, &c__1, &info);
+ chkxer_("DTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 12;
+
+/* DTGSNA */
+
+ s_copy(srnamc_1.srnamt, "DTGSNA", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtgsna_("/", "A", sel, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("DTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtgsna_("B", "/", sel, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("DTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dtgsna_("B", "A", sel, &c_n1, a, &c__1, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("DTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dtgsna_("B", "A", sel, &c__1, a, &c__0, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("DTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dtgsna_("B", "A", sel, &c__1, a, &c__1, b, &c__0, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("DTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dtgsna_("E", "A", sel, &c__1, a, &c__1, b, &c__1, q, &c__0, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("DTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dtgsna_("E", "A", sel, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &c__0,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("DTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ dtgsna_("E", "A", sel, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__0, &m, w, &c__1, iw, &info);
+ chkxer_("DTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ dtgsna_("E", "A", sel, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__0, iw, &info);
+ chkxer_("DTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* DTGSYL */
+
+ s_copy(srnamc_1.srnamt, "DTGSYL", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtgsyl_("/", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("DTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtgsyl_("N", &c_n1, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("DTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dtgsyl_("N", &c__0, &c__0, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("DTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dtgsyl_("N", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("DTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dtgsyl_("N", &c__0, &c__1, &c__1, a, &c__0, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("DTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dtgsyl_("N", &c__0, &c__1, &c__1, a, &c__1, b, &c__0, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("DTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dtgsyl_("N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__0, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("DTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dtgsyl_("N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__0, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("DTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ dtgsyl_("N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__0, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("DTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ dtgsyl_("N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__0, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("DTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ dtgsyl_("N", &c__1, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("DTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ dtgsyl_("N", &c__2, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("DTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 12;
+ }
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___38.ciunit = infoc_1.nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___39.ciunit = infoc_1.nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of DERRGG */
+
+} /* derrgg_ */
diff --git a/TESTING/EIG/derrhs.c b/TESTING/EIG/derrhs.c
new file mode 100644
index 0000000..a7face3
--- /dev/null
+++ b/TESTING/EIG/derrhs.c
@@ -0,0 +1,525 @@
+/* derrhs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__4 = 4;
+
+/* Subroutine */ int derrhs_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
+ "rror exits\002,\002 (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
+ "ts of the error \002,\002exits ***\002)";
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublereal a[9] /* was [3][3] */, c__[9] /* was [3][3] */;
+ integer i__, j, m;
+ doublereal s[3], w[28];
+ char c2[2];
+ doublereal wi[3];
+ integer nt;
+ doublereal vl[9] /* was [3][3] */, vr[9] /* was [3][3] */, wr[3];
+ integer ihi, ilo;
+ logical sel[3];
+ doublereal tau[3];
+ integer info;
+ extern /* Subroutine */ int dgebak_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *), dgebal_(char *, integer *, doublereal
+ *, integer *, integer *, integer *, doublereal *, integer *), dgehrd_(integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *);
+ integer ifaill[3], ifailr[3];
+ extern /* Subroutine */ int dhsein_(char *, char *, char *, logical *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *, doublereal *, integer *, integer *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), dorghr_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dhseqr_(char *, char *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dtrevc_(char *, char *, logical *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *, integer *, doublereal *, integer *), dormhr_(char *, char *, integer *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRHS tests the error exits for DGEBAK, SGEBAL, SGEHRD, DORGHR, */
+/* DORMHR, DHSEQR, SHSEIN, and DTREVC. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 3; ++j) {
+ for (i__ = 1; i__ <= 3; ++i__) {
+ a[i__ + j * 3 - 4] = 1. / (doublereal) (i__ + j);
+/* L10: */
+ }
+ wi[j - 1] = (doublereal) j;
+ sel[j - 1] = TRUE_;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+ nt = 0;
+
+/* Test error exits of the nonsymmetric eigenvalue routines. */
+
+ if (lsamen_(&c__2, c2, "HS")) {
+
+/* DGEBAL */
+
+ s_copy(srnamc_1.srnamt, "DGEBAL", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgebal_("/", &c__0, a, &c__1, &ilo, &ihi, s, &info);
+ chkxer_("DGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgebal_("N", &c_n1, a, &c__1, &ilo, &ihi, s, &info);
+ chkxer_("DGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgebal_("N", &c__2, a, &c__1, &ilo, &ihi, s, &info);
+ chkxer_("DGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 3;
+
+/* DGEBAK */
+
+ s_copy(srnamc_1.srnamt, "DGEBAK", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgebak_("/", "R", &c__0, &c__1, &c__0, s, &c__0, a, &c__1, &info);
+ chkxer_("DGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgebak_("N", "/", &c__0, &c__1, &c__0, s, &c__0, a, &c__1, &info);
+ chkxer_("DGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgebak_("N", "R", &c_n1, &c__1, &c__0, s, &c__0, a, &c__1, &info);
+ chkxer_("DGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgebak_("N", "R", &c__0, &c__0, &c__0, s, &c__0, a, &c__1, &info);
+ chkxer_("DGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgebak_("N", "R", &c__0, &c__2, &c__0, s, &c__0, a, &c__1, &info);
+ chkxer_("DGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgebak_("N", "R", &c__2, &c__2, &c__1, s, &c__0, a, &c__2, &info);
+ chkxer_("DGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgebak_("N", "R", &c__0, &c__1, &c__1, s, &c__0, a, &c__1, &info);
+ chkxer_("DGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dgebak_("N", "R", &c__0, &c__1, &c__0, s, &c_n1, a, &c__1, &info);
+ chkxer_("DGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dgebak_("N", "R", &c__2, &c__1, &c__2, s, &c__0, a, &c__1, &info);
+ chkxer_("DGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* DGEHRD */
+
+ s_copy(srnamc_1.srnamt, "DGEHRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgehrd_(&c_n1, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("DGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgehrd_(&c__0, &c__0, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("DGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgehrd_(&c__0, &c__2, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("DGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgehrd_(&c__1, &c__1, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("DGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgehrd_(&c__0, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("DGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgehrd_(&c__2, &c__1, &c__1, a, &c__1, tau, w, &c__2, &info);
+ chkxer_("DGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dgehrd_(&c__2, &c__1, &c__2, a, &c__2, tau, w, &c__1, &info);
+ chkxer_("DGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+
+/* DORGHR */
+
+ s_copy(srnamc_1.srnamt, "DORGHR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dorghr_(&c_n1, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("DORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dorghr_(&c__0, &c__0, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("DORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dorghr_(&c__0, &c__2, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("DORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorghr_(&c__1, &c__1, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("DORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorghr_(&c__0, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("DORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dorghr_(&c__2, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("DORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dorghr_(&c__3, &c__1, &c__3, a, &c__3, tau, w, &c__1, &info);
+ chkxer_("DORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+
+/* DORMHR */
+
+ s_copy(srnamc_1.srnamt, "DORMHR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dormhr_("/", "N", &c__0, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dormhr_("L", "/", &c__0, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dormhr_("L", "N", &c_n1, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dormhr_("L", "N", &c__0, &c_n1, &c__1, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dormhr_("L", "N", &c__0, &c__0, &c__0, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dormhr_("L", "N", &c__0, &c__0, &c__2, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dormhr_("L", "N", &c__1, &c__2, &c__2, &c__1, a, &c__1, tau, c__, &
+ c__1, w, &c__2, &info);
+ chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dormhr_("R", "N", &c__2, &c__1, &c__2, &c__1, a, &c__1, tau, c__, &
+ c__2, w, &c__2, &info);
+ chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dormhr_("L", "N", &c__1, &c__1, &c__1, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dormhr_("L", "N", &c__0, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dormhr_("R", "N", &c__1, &c__0, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dormhr_("L", "N", &c__2, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__2, w, &c__1, &info);
+ chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dormhr_("R", "N", &c__1, &c__2, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dormhr_("L", "N", &c__2, &c__1, &c__1, &c__1, a, &c__2, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ dormhr_("L", "N", &c__1, &c__2, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ dormhr_("R", "N", &c__2, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__2, w, &c__1, &info);
+ chkxer_("DORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 16;
+
+/* DHSEQR */
+
+ s_copy(srnamc_1.srnamt, "DHSEQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dhseqr_("/", "N", &c__0, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1,
+ w, &c__1, &info);
+ chkxer_("DHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dhseqr_("E", "/", &c__0, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1,
+ w, &c__1, &info);
+ chkxer_("DHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dhseqr_("E", "N", &c_n1, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1,
+ w, &c__1, &info);
+ chkxer_("DHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dhseqr_("E", "N", &c__0, &c__0, &c__0, a, &c__1, wr, wi, c__, &c__1,
+ w, &c__1, &info);
+ chkxer_("DHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dhseqr_("E", "N", &c__0, &c__2, &c__0, a, &c__1, wr, wi, c__, &c__1,
+ w, &c__1, &info);
+ chkxer_("DHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dhseqr_("E", "N", &c__1, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1,
+ w, &c__1, &info);
+ chkxer_("DHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dhseqr_("E", "N", &c__1, &c__1, &c__2, a, &c__1, wr, wi, c__, &c__1,
+ w, &c__1, &info);
+ chkxer_("DHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dhseqr_("E", "N", &c__2, &c__1, &c__2, a, &c__1, wr, wi, c__, &c__2,
+ w, &c__1, &info);
+ chkxer_("DHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dhseqr_("E", "V", &c__2, &c__1, &c__2, a, &c__2, wr, wi, c__, &c__1,
+ w, &c__1, &info);
+ chkxer_("DHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* DHSEIN */
+
+ s_copy(srnamc_1.srnamt, "DHSEIN", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dhsein_("/", "N", "N", sel, &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &c__0, &m, w, ifaill, ifailr, &info);
+ chkxer_("DHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dhsein_("R", "/", "N", sel, &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &c__0, &m, w, ifaill, ifailr, &info);
+ chkxer_("DHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dhsein_("R", "N", "/", sel, &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &c__0, &m, w, ifaill, ifailr, &info);
+ chkxer_("DHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dhsein_("R", "N", "N", sel, &c_n1, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &c__0, &m, w, ifaill, ifailr, &info);
+ chkxer_("DHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dhsein_("R", "N", "N", sel, &c__2, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__2, &c__4, &m, w, ifaill, ifailr, &info);
+ chkxer_("DHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dhsein_("L", "N", "N", sel, &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
+ c__1, &c__4, &m, w, ifaill, ifailr, &info);
+ chkxer_("DHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ dhsein_("R", "N", "N", sel, &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
+ c__1, &c__4, &m, w, ifaill, ifailr, &info);
+ chkxer_("DHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ dhsein_("R", "N", "N", sel, &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
+ c__2, &c__1, &m, w, ifaill, ifailr, &info);
+ chkxer_("DHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* DTREVC */
+
+ s_copy(srnamc_1.srnamt, "DTREVC", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtrevc_("/", "A", sel, &c__0, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
+ m, w, &info);
+ chkxer_("DTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtrevc_("L", "/", sel, &c__0, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
+ m, w, &info);
+ chkxer_("DTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dtrevc_("L", "A", sel, &c_n1, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
+ m, w, &info);
+ chkxer_("DTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dtrevc_("L", "A", sel, &c__2, a, &c__1, vl, &c__2, vr, &c__1, &c__4, &
+ m, w, &info);
+ chkxer_("DTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dtrevc_("L", "A", sel, &c__2, a, &c__2, vl, &c__1, vr, &c__1, &c__4, &
+ m, w, &info);
+ chkxer_("DTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dtrevc_("R", "A", sel, &c__2, a, &c__2, vl, &c__1, vr, &c__1, &c__4, &
+ m, w, &info);
+ chkxer_("DTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dtrevc_("L", "A", sel, &c__2, a, &c__2, vl, &c__2, vr, &c__1, &c__1, &
+ m, w, &info);
+ chkxer_("DTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+ }
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___22.ciunit = infoc_1.nout;
+ s_wsfe(&io___22);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___23.ciunit = infoc_1.nout;
+ s_wsfe(&io___23);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of DERRHS */
+
+} /* derrhs_ */
diff --git a/TESTING/EIG/derrst.c b/TESTING/EIG/derrst.c
new file mode 100644
index 0000000..6c256ec
--- /dev/null
+++ b/TESTING/EIG/derrst.c
@@ -0,0 +1,1309 @@
+/* derrst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static doublereal c_b220 = 0.;
+static doublereal c_b221 = 1.;
+static integer c__23 = 23;
+static integer c__28 = 28;
+static integer c__12 = 12;
+static integer c__19 = 19;
+static integer c__11 = 11;
+static integer c__4 = 4;
+static integer c__20 = 20;
+static integer c__5 = 5;
+static integer c__27 = 27;
+static integer c__16 = 16;
+static integer c__8 = 8;
+static integer c__25 = 25;
+static integer c__18 = 18;
+
+/* Subroutine */ int derrst_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
+ "rror exits\002,\002 (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
+ "ts of the error \002,\002exits ***\002)";
+
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublereal a[9] /* was [3][3] */, c__[9] /* was [3][3] */, d__[
+ 3], e[3];
+ integer i__, j, m, n;
+ doublereal q[9] /* was [3][3] */, r__[3], w[60], x[3], z__[9] /*
+ was [3][3] */;
+ char c2[2];
+ integer i1[3], i2[3], i3[3], iw[36], nt;
+ doublereal tau[3];
+ integer info;
+ extern /* Subroutine */ int dsbev_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), dspev_(char *, char *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), dstev_(char *, integer *
+, doublereal *, doublereal *, doublereal *, integer *, doublereal
+ *, integer *), dsyev_(char *, char *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dstedc_(char *, integer *, doublereal
+ *, doublereal *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *, integer *), dsbevd_(char *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int dsbtrd_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *), chkxer_(
+ char *, integer *, integer *, logical *, logical *),
+ dspevd_(char *, char *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *, integer *), dstein_(integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *), dsterf_(integer *, doublereal *,
+ doublereal *, integer *), dstevd_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *, integer *), dsbevx_(char *, char *,
+ char *, integer *, integer *, doublereal *, integer *, doublereal
+ *, integer *, doublereal *, doublereal *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *, integer *), dstebz_(char *, char *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, integer *),
+ dsyevd_(char *, char *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *, integer *,
+ integer *), dopgtr_(char *, integer *, doublereal
+ *, doublereal *, doublereal *, integer *, doublereal *, integer *), dpteqr_(char *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *),
+ dorgtr_(char *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *), dsptrd_(char *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *), dsteqr_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *), dopmtr_(char *, char *, char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *), dormtr_(char *, char *, char
+ *, integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dstevr_(char *, char *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, integer *, integer *, integer
+ *, integer *);
+ integer nsplit;
+ extern /* Subroutine */ int dspevx_(char *, char *, char *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *, integer *), dsytrd_(char *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *), dsyevr_(char *, char *, char *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, integer *, integer *, integer
+ *, integer *), dstevx_(char *, char *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *), dsyevx_(char *, char *, char *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRST tests the error exits for DSYTRD, DORGTR, DORMTR, DSPTRD, */
+/* DOPGTR, DOPMTR, DSTEQR, SSTERF, SSTEBZ, SSTEIN, DPTEQR, DSBTRD, */
+/* DSYEV, SSYEVX, SSYEVD, DSBEV, SSBEVX, SSBEVD, */
+/* DSPEV, SSPEVX, SSPEVD, DSTEV, SSTEVX, SSTEVD, and SSTEDC. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* NMAX has to be at least 3 or LIW may be too small */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 3; ++j) {
+ for (i__ = 1; i__ <= 3; ++i__) {
+ a[i__ + j * 3 - 4] = 1. / (doublereal) (i__ + j);
+/* L10: */
+ }
+/* L20: */
+ }
+ for (j = 1; j <= 3; ++j) {
+ d__[j - 1] = (doublereal) j;
+ e[j - 1] = 0.;
+ i1[j - 1] = j;
+ i2[j - 1] = j;
+ tau[j - 1] = 1.;
+/* L30: */
+ }
+ infoc_1.ok = TRUE_;
+ nt = 0;
+
+/* Test error exits for the ST path. */
+
+ if (lsamen_(&c__2, c2, "ST")) {
+
+/* DSYTRD */
+
+ s_copy(srnamc_1.srnamt, "DSYTRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsytrd_("/", &c__0, a, &c__1, d__, e, tau, w, &c__1, &info)
+ ;
+ chkxer_("DSYTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsytrd_("U", &c_n1, a, &c__1, d__, e, tau, w, &c__1, &info)
+ ;
+ chkxer_("DSYTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dsytrd_("U", &c__2, a, &c__1, d__, e, tau, w, &c__1, &info)
+ ;
+ chkxer_("DSYTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dsytrd_("U", &c__0, a, &c__1, d__, e, tau, w, &c__0, &info)
+ ;
+ chkxer_("DSYTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 4;
+
+/* DORGTR */
+
+ s_copy(srnamc_1.srnamt, "DORGTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dorgtr_("/", &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("DORGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dorgtr_("U", &c_n1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("DORGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dorgtr_("U", &c__2, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("DORGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dorgtr_("U", &c__3, a, &c__3, tau, w, &c__1, &info);
+ chkxer_("DORGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 4;
+
+/* DORMTR */
+
+ s_copy(srnamc_1.srnamt, "DORMTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dormtr_("/", "U", "N", &c__0, &c__0, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("DORMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dormtr_("L", "/", "N", &c__0, &c__0, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("DORMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dormtr_("L", "U", "/", &c__0, &c__0, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("DORMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dormtr_("L", "U", "N", &c_n1, &c__0, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("DORMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dormtr_("L", "U", "N", &c__0, &c_n1, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("DORMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dormtr_("L", "U", "N", &c__2, &c__0, a, &c__1, tau, c__, &c__2, w, &
+ c__1, &info);
+ chkxer_("DORMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dormtr_("R", "U", "N", &c__0, &c__2, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("DORMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dormtr_("L", "U", "N", &c__2, &c__0, a, &c__2, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("DORMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dormtr_("L", "U", "N", &c__0, &c__2, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("DORMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dormtr_("R", "U", "N", &c__2, &c__0, a, &c__1, tau, c__, &c__2, w, &
+ c__1, &info);
+ chkxer_("DORMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* DSPTRD */
+
+ s_copy(srnamc_1.srnamt, "DSPTRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsptrd_("/", &c__0, a, d__, e, tau, &info);
+ chkxer_("DSPTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsptrd_("U", &c_n1, a, d__, e, tau, &info);
+ chkxer_("DSPTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 2;
+
+/* DOPGTR */
+
+ s_copy(srnamc_1.srnamt, "DOPGTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dopgtr_("/", &c__0, a, tau, z__, &c__1, w, &info);
+ chkxer_("DOPGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dopgtr_("U", &c_n1, a, tau, z__, &c__1, w, &info);
+ chkxer_("DOPGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dopgtr_("U", &c__2, a, tau, z__, &c__1, w, &info);
+ chkxer_("DOPGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 3;
+
+/* DOPMTR */
+
+ s_copy(srnamc_1.srnamt, "DOPMTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dopmtr_("/", "U", "N", &c__0, &c__0, a, tau, c__, &c__1, w, &info);
+ chkxer_("DOPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dopmtr_("L", "/", "N", &c__0, &c__0, a, tau, c__, &c__1, w, &info);
+ chkxer_("DOPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dopmtr_("L", "U", "/", &c__0, &c__0, a, tau, c__, &c__1, w, &info);
+ chkxer_("DOPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dopmtr_("L", "U", "N", &c_n1, &c__0, a, tau, c__, &c__1, w, &info);
+ chkxer_("DOPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dopmtr_("L", "U", "N", &c__0, &c_n1, a, tau, c__, &c__1, w, &info);
+ chkxer_("DOPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dopmtr_("L", "U", "N", &c__2, &c__0, a, tau, c__, &c__1, w, &info);
+ chkxer_("DOPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+/* DPTEQR */
+
+ s_copy(srnamc_1.srnamt, "DPTEQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpteqr_("/", &c__0, d__, e, z__, &c__1, w, &info);
+ chkxer_("DPTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpteqr_("N", &c_n1, d__, e, z__, &c__1, w, &info);
+ chkxer_("DPTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dpteqr_("V", &c__2, d__, e, z__, &c__1, w, &info);
+ chkxer_("DPTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 3;
+
+/* DSTEBZ */
+
+ s_copy(srnamc_1.srnamt, "DSTEBZ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dstebz_("/", "E", &c__0, &c_b220, &c_b221, &c__1, &c__0, &c_b220, d__,
+ e, &m, &nsplit, x, i1, i2, w, iw, &info);
+ chkxer_("DSTEBZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dstebz_("A", "/", &c__0, &c_b220, &c_b220, &c__0, &c__0, &c_b220, d__,
+ e, &m, &nsplit, x, i1, i2, w, iw, &info);
+ chkxer_("DSTEBZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dstebz_("A", "E", &c_n1, &c_b220, &c_b220, &c__0, &c__0, &c_b220, d__,
+ e, &m, &nsplit, x, i1, i2, w, iw, &info);
+ chkxer_("DSTEBZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dstebz_("V", "E", &c__0, &c_b220, &c_b220, &c__0, &c__0, &c_b220, d__,
+ e, &m, &nsplit, x, i1, i2, w, iw, &info);
+ chkxer_("DSTEBZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dstebz_("I", "E", &c__0, &c_b220, &c_b220, &c__0, &c__0, &c_b220, d__,
+ e, &m, &nsplit, x, i1, i2, w, iw, &info);
+ chkxer_("DSTEBZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dstebz_("I", "E", &c__1, &c_b220, &c_b220, &c__2, &c__1, &c_b220, d__,
+ e, &m, &nsplit, x, i1, i2, w, iw, &info);
+ chkxer_("DSTEBZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dstebz_("I", "E", &c__1, &c_b220, &c_b220, &c__1, &c__0, &c_b220, d__,
+ e, &m, &nsplit, x, i1, i2, w, iw, &info);
+ chkxer_("DSTEBZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dstebz_("I", "E", &c__1, &c_b220, &c_b220, &c__1, &c__2, &c_b220, d__,
+ e, &m, &nsplit, x, i1, i2, w, iw, &info);
+ chkxer_("DSTEBZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* DSTEIN */
+
+ s_copy(srnamc_1.srnamt, "DSTEIN", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dstein_(&c_n1, d__, e, &c__0, x, i1, i2, z__, &c__1, w, iw, i3, &info)
+ ;
+ chkxer_("DSTEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dstein_(&c__0, d__, e, &c_n1, x, i1, i2, z__, &c__1, w, iw, i3, &info)
+ ;
+ chkxer_("DSTEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dstein_(&c__0, d__, e, &c__1, x, i1, i2, z__, &c__1, w, iw, i3, &info)
+ ;
+ chkxer_("DSTEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dstein_(&c__2, d__, e, &c__0, x, i1, i2, z__, &c__1, w, iw, i3, &info)
+ ;
+ chkxer_("DSTEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 4;
+
+/* DSTEQR */
+
+ s_copy(srnamc_1.srnamt, "DSTEQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsteqr_("/", &c__0, d__, e, z__, &c__1, w, &info);
+ chkxer_("DSTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsteqr_("N", &c_n1, d__, e, z__, &c__1, w, &info);
+ chkxer_("DSTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dsteqr_("V", &c__2, d__, e, z__, &c__1, w, &info);
+ chkxer_("DSTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 3;
+
+/* DSTERF */
+
+ s_copy(srnamc_1.srnamt, "DSTERF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsterf_(&c_n1, d__, e, &info);
+ chkxer_("DSTERF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ ++nt;
+
+/* DSTEDC */
+
+ s_copy(srnamc_1.srnamt, "DSTEDC", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dstedc_("/", &c__0, d__, e, z__, &c__1, w, &c__1, iw, &c__1, &info);
+ chkxer_("DSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dstedc_("N", &c_n1, d__, e, z__, &c__1, w, &c__1, iw, &c__1, &info);
+ chkxer_("DSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dstedc_("V", &c__2, d__, e, z__, &c__1, w, &c__23, iw, &c__28, &info);
+ chkxer_("DSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dstedc_("N", &c__1, d__, e, z__, &c__1, w, &c__0, iw, &c__1, &info);
+ chkxer_("DSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dstedc_("I", &c__2, d__, e, z__, &c__2, w, &c__0, iw, &c__12, &info);
+ chkxer_("DSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dstedc_("V", &c__2, d__, e, z__, &c__2, w, &c__0, iw, &c__28, &info);
+ chkxer_("DSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dstedc_("N", &c__1, d__, e, z__, &c__1, w, &c__1, iw, &c__0, &info);
+ chkxer_("DSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dstedc_("I", &c__2, d__, e, z__, &c__2, w, &c__19, iw, &c__0, &info);
+ chkxer_("DSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dstedc_("V", &c__2, d__, e, z__, &c__2, w, &c__23, iw, &c__0, &info);
+ chkxer_("DSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* DSTEVD */
+
+ s_copy(srnamc_1.srnamt, "DSTEVD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dstevd_("/", &c__0, d__, e, z__, &c__1, w, &c__1, iw, &c__1, &info);
+ chkxer_("DSTEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dstevd_("N", &c_n1, d__, e, z__, &c__1, w, &c__1, iw, &c__1, &info);
+ chkxer_("DSTEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dstevd_("V", &c__2, d__, e, z__, &c__1, w, &c__19, iw, &c__12, &info);
+ chkxer_("DSTEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dstevd_("N", &c__1, d__, e, z__, &c__1, w, &c__0, iw, &c__1, &info);
+ chkxer_("DSTEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dstevd_("V", &c__2, d__, e, z__, &c__2, w, &c__12, iw, &c__12, &info);
+ chkxer_("DSTEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dstevd_("N", &c__0, d__, e, z__, &c__1, w, &c__1, iw, &c__0, &info);
+ chkxer_("DSTEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dstevd_("V", &c__2, d__, e, z__, &c__2, w, &c__19, iw, &c__11, &info);
+ chkxer_("DSTEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+
+/* DSTEV */
+
+ s_copy(srnamc_1.srnamt, "DSTEV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dstev_("/", &c__0, d__, e, z__, &c__1, w, &info);
+ chkxer_("DSTEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dstev_("N", &c_n1, d__, e, z__, &c__1, w, &info);
+ chkxer_("DSTEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dstev_("V", &c__2, d__, e, z__, &c__1, w, &info);
+ chkxer_("DSTEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 3;
+
+/* DSTEVX */
+
+ s_copy(srnamc_1.srnamt, "DSTEVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dstevx_("/", "A", &c__0, d__, e, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("DSTEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dstevx_("N", "/", &c__0, d__, e, &c_b220, &c_b221, &c__1, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("DSTEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dstevx_("N", "A", &c_n1, d__, e, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("DSTEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dstevx_("N", "V", &c__1, d__, e, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("DSTEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dstevx_("N", "I", &c__1, d__, e, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("DSTEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dstevx_("N", "I", &c__1, d__, e, &c_b220, &c_b220, &c__2, &c__1, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("DSTEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dstevx_("N", "I", &c__2, d__, e, &c_b220, &c_b220, &c__2, &c__1, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("DSTEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dstevx_("N", "I", &c__1, d__, e, &c_b220, &c_b220, &c__1, &c__2, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("DSTEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ dstevx_("V", "A", &c__2, d__, e, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("DSTEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* DSTEVR */
+
+ n = 1;
+ s_copy(srnamc_1.srnamt, "DSTEVR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ i__1 = n * 20;
+ i__2 = n * 10;
+ dstevr_("/", "A", &c__0, d__, e, &c_b220, &c_b220, &c__1, &c__1, &
+ c_b220, &m, r__, z__, &c__1, iw, x, &i__1, &iw[n * 2], &i__2,
+ &info);
+ chkxer_("DSTEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ i__1 = n * 20;
+ i__2 = n * 10;
+ dstevr_("V", "/", &c__0, d__, e, &c_b220, &c_b220, &c__1, &c__1, &
+ c_b220, &m, r__, z__, &c__1, iw, x, &i__1, &iw[n * 2], &i__2,
+ &info);
+ chkxer_("DSTEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ i__1 = n * 20;
+ i__2 = n * 10;
+ dstevr_("V", "A", &c_n1, d__, e, &c_b220, &c_b220, &c__1, &c__1, &
+ c_b220, &m, r__, z__, &c__1, iw, x, &i__1, &iw[n * 2], &i__2,
+ &info);
+ chkxer_("DSTEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ i__1 = n * 20;
+ i__2 = n * 10;
+ dstevr_("V", "V", &c__1, d__, e, &c_b220, &c_b220, &c__1, &c__1, &
+ c_b220, &m, r__, z__, &c__1, iw, x, &i__1, &iw[n * 2], &i__2,
+ &info);
+ chkxer_("DSTEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ i__1 = n * 20;
+ i__2 = n * 10;
+ dstevr_("V", "I", &c__1, d__, e, &c_b220, &c_b220, &c__0, &c__1, &
+ c_b220, &m, w, z__, &c__1, iw, x, &i__1, &iw[n * 2], &i__2, &
+ info);
+ chkxer_("DSTEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ n = 2;
+ i__1 = n * 20;
+ i__2 = n * 10;
+ dstevr_("V", "I", &c__2, d__, e, &c_b220, &c_b220, &c__2, &c__1, &
+ c_b220, &m, w, z__, &c__1, iw, x, &i__1, &iw[n * 2], &i__2, &
+ info);
+ chkxer_("DSTEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ n = 1;
+ i__1 = n * 20;
+ i__2 = n * 10;
+ dstevr_("V", "I", &c__1, d__, e, &c_b220, &c_b220, &c__1, &c__1, &
+ c_b220, &m, w, z__, &c__0, iw, x, &i__1, &iw[n * 2], &i__2, &
+ info);
+ chkxer_("DSTEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 17;
+ i__1 = n * 20 - 1;
+ i__2 = n * 10;
+ dstevr_("V", "I", &c__1, d__, e, &c_b220, &c_b220, &c__1, &c__1, &
+ c_b220, &m, w, z__, &c__1, iw, x, &i__1, &iw[n * 2], &i__2, &
+ info);
+ chkxer_("DSTEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 19;
+ i__1 = n * 20;
+ i__2 = n * 10 - 1;
+ dstevr_("V", "I", &c__1, d__, e, &c_b220, &c_b220, &c__1, &c__1, &
+ c_b220, &m, w, z__, &c__1, iw, x, &i__1, &iw[n * 2], &i__2, &
+ info);
+ chkxer_("DSTEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* DSYEVD */
+
+ s_copy(srnamc_1.srnamt, "DSYEVD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsyevd_("/", "U", &c__0, a, &c__1, x, w, &c__1, iw, &c__1, &info);
+ chkxer_("DSYEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsyevd_("N", "/", &c__0, a, &c__1, x, w, &c__1, iw, &c__1, &info);
+ chkxer_("DSYEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dsyevd_("N", "U", &c_n1, a, &c__1, x, w, &c__1, iw, &c__1, &info);
+ chkxer_("DSYEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dsyevd_("N", "U", &c__2, a, &c__1, x, w, &c__3, iw, &c__1, &info);
+ chkxer_("DSYEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dsyevd_("N", "U", &c__1, a, &c__1, x, w, &c__0, iw, &c__1, &info);
+ chkxer_("DSYEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dsyevd_("N", "U", &c__2, a, &c__2, x, w, &c__4, iw, &c__1, &info);
+ chkxer_("DSYEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dsyevd_("V", "U", &c__2, a, &c__2, x, w, &c__20, iw, &c__12, &info);
+ chkxer_("DSYEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dsyevd_("N", "U", &c__1, a, &c__1, x, w, &c__1, iw, &c__0, &info);
+ chkxer_("DSYEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dsyevd_("N", "U", &c__2, a, &c__2, x, w, &c__5, iw, &c__0, &info);
+ chkxer_("DSYEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dsyevd_("V", "U", &c__2, a, &c__2, x, w, &c__27, iw, &c__11, &info);
+ chkxer_("DSYEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* DSYEVR */
+
+ s_copy(srnamc_1.srnamt, "DSYEVR", (ftnlen)32, (ftnlen)6);
+ n = 1;
+ infoc_1.infot = 1;
+ i__1 = n * 26;
+ i__2 = n * 10;
+ dsyevr_("/", "A", "U", &c__0, a, &c__1, &c_b220, &c_b220, &c__1, &
+ c__1, &c_b220, &m, r__, z__, &c__1, iw, q, &i__1, &iw[n * 2],
+ &i__2, &info);
+ chkxer_("DSYEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ i__1 = n * 26;
+ i__2 = n * 10;
+ dsyevr_("V", "/", "U", &c__0, a, &c__1, &c_b220, &c_b220, &c__1, &
+ c__1, &c_b220, &m, r__, z__, &c__1, iw, q, &i__1, &iw[n * 2],
+ &i__2, &info);
+ chkxer_("DSYEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ i__1 = n * 26;
+ i__2 = n * 10;
+ dsyevr_("V", "A", "/", &c_n1, a, &c__1, &c_b220, &c_b220, &c__1, &
+ c__1, &c_b220, &m, r__, z__, &c__1, iw, q, &i__1, &iw[n * 2],
+ &i__2, &info);
+ chkxer_("DSYEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ i__1 = n * 26;
+ i__2 = n * 10;
+ dsyevr_("V", "A", "U", &c_n1, a, &c__1, &c_b220, &c_b220, &c__1, &
+ c__1, &c_b220, &m, r__, z__, &c__1, iw, q, &i__1, &iw[n * 2],
+ &i__2, &info);
+ chkxer_("DSYEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ i__1 = n * 26;
+ i__2 = n * 10;
+ dsyevr_("V", "A", "U", &c__2, a, &c__1, &c_b220, &c_b220, &c__1, &
+ c__1, &c_b220, &m, r__, z__, &c__1, iw, q, &i__1, &iw[n * 2],
+ &i__2, &info);
+ chkxer_("DSYEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ i__1 = n * 26;
+ i__2 = n * 10;
+ dsyevr_("V", "V", "U", &c__1, a, &c__1, &c_b220, &c_b220, &c__1, &
+ c__1, &c_b220, &m, r__, z__, &c__1, iw, q, &i__1, &iw[n * 2],
+ &i__2, &info);
+ chkxer_("DSYEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ i__1 = n * 26;
+ i__2 = n * 10;
+ dsyevr_("V", "I", "U", &c__1, a, &c__1, &c_b220, &c_b220, &c__0, &
+ c__1, &c_b220, &m, r__, z__, &c__1, iw, q, &i__1, &iw[n * 2],
+ &i__2, &info);
+ chkxer_("DSYEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+
+ i__1 = n * 26;
+ i__2 = n * 10;
+ dsyevr_("V", "I", "U", &c__2, a, &c__2, &c_b220, &c_b220, &c__2, &
+ c__1, &c_b220, &m, r__, z__, &c__1, iw, q, &i__1, &iw[n * 2],
+ &i__2, &info);
+ chkxer_("DSYEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ i__1 = n * 26;
+ i__2 = n * 10;
+ dsyevr_("V", "I", "U", &c__1, a, &c__1, &c_b220, &c_b220, &c__1, &
+ c__1, &c_b220, &m, r__, z__, &c__0, iw, q, &i__1, &iw[n * 2],
+ &i__2, &info);
+ chkxer_("DSYEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ i__1 = n * 26 - 1;
+ i__2 = n * 10;
+ dsyevr_("V", "I", "U", &c__1, a, &c__1, &c_b220, &c_b220, &c__1, &
+ c__1, &c_b220, &m, r__, z__, &c__1, iw, q, &i__1, &iw[n * 2],
+ &i__2, &info);
+ chkxer_("DSYEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ i__1 = n * 26;
+ i__2 = n * 10 - 1;
+ dsyevr_("V", "I", "U", &c__1, a, &c__1, &c_b220, &c_b220, &c__1, &
+ c__1, &c_b220, &m, r__, z__, &c__1, iw, q, &i__1, &iw[n * 2],
+ &i__2, &info);
+ chkxer_("DSYEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* DSYEV */
+
+ s_copy(srnamc_1.srnamt, "DSYEV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsyev_("/", "U", &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("DSYEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsyev_("N", "/", &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("DSYEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dsyev_("N", "U", &c_n1, a, &c__1, x, w, &c__1, &info);
+ chkxer_("DSYEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dsyev_("N", "U", &c__2, a, &c__1, x, w, &c__3, &info);
+ chkxer_("DSYEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dsyev_("N", "U", &c__1, a, &c__1, x, w, &c__1, &info);
+ chkxer_("DSYEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 5;
+
+/* DSYEVX */
+
+ s_copy(srnamc_1.srnamt, "DSYEVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsyevx_("/", "A", "U", &c__0, a, &c__1, &c_b220, &c_b220, &c__0, &
+ c__0, &c_b220, &m, x, z__, &c__1, w, &c__1, iw, i3, &info);
+ chkxer_("DSYEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsyevx_("N", "/", "U", &c__0, a, &c__1, &c_b220, &c_b221, &c__1, &
+ c__0, &c_b220, &m, x, z__, &c__1, w, &c__1, iw, i3, &info);
+ chkxer_("DSYEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dsyevx_("N", "A", "/", &c__0, a, &c__1, &c_b220, &c_b220, &c__0, &
+ c__0, &c_b220, &m, x, z__, &c__1, w, &c__1, iw, i3, &info);
+ infoc_1.infot = 4;
+ dsyevx_("N", "A", "U", &c_n1, a, &c__1, &c_b220, &c_b220, &c__0, &
+ c__0, &c_b220, &m, x, z__, &c__1, w, &c__1, iw, i3, &info);
+ chkxer_("DSYEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dsyevx_("N", "A", "U", &c__2, a, &c__1, &c_b220, &c_b220, &c__0, &
+ c__0, &c_b220, &m, x, z__, &c__1, w, &c__16, iw, i3, &info);
+ chkxer_("DSYEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dsyevx_("N", "V", "U", &c__1, a, &c__1, &c_b220, &c_b220, &c__0, &
+ c__0, &c_b220, &m, x, z__, &c__1, w, &c__8, iw, i3, &info);
+ chkxer_("DSYEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dsyevx_("N", "I", "U", &c__1, a, &c__1, &c_b220, &c_b220, &c__0, &
+ c__0, &c_b220, &m, x, z__, &c__1, w, &c__8, iw, i3, &info);
+ chkxer_("DSYEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dsyevx_("N", "I", "U", &c__1, a, &c__1, &c_b220, &c_b220, &c__2, &
+ c__1, &c_b220, &m, x, z__, &c__1, w, &c__8, iw, i3, &info);
+ chkxer_("DSYEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dsyevx_("N", "I", "U", &c__2, a, &c__2, &c_b220, &c_b220, &c__2, &
+ c__1, &c_b220, &m, x, z__, &c__1, w, &c__16, iw, i3, &info);
+ chkxer_("DSYEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dsyevx_("N", "I", "U", &c__1, a, &c__1, &c_b220, &c_b220, &c__1, &
+ c__2, &c_b220, &m, x, z__, &c__1, w, &c__8, iw, i3, &info);
+ chkxer_("DSYEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ dsyevx_("V", "A", "U", &c__2, a, &c__2, &c_b220, &c_b220, &c__0, &
+ c__0, &c_b220, &m, x, z__, &c__1, w, &c__16, iw, i3, &info);
+ chkxer_("DSYEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 17;
+ dsyevx_("V", "A", "U", &c__1, a, &c__1, &c_b220, &c_b220, &c__0, &
+ c__0, &c_b220, &m, x, z__, &c__1, w, &c__0, iw, i3, &info);
+ chkxer_("DSYEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 12;
+
+/* DSPEVD */
+
+ s_copy(srnamc_1.srnamt, "DSPEVD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dspevd_("/", "U", &c__0, a, x, z__, &c__1, w, &c__1, iw, &c__1, &info);
+ chkxer_("DSPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dspevd_("N", "/", &c__0, a, x, z__, &c__1, w, &c__1, iw, &c__1, &info);
+ chkxer_("DSPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dspevd_("N", "U", &c_n1, a, x, z__, &c__1, w, &c__1, iw, &c__1, &info);
+ chkxer_("DSPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dspevd_("V", "U", &c__2, a, x, z__, &c__1, w, &c__23, iw, &c__12, &
+ info);
+ chkxer_("DSPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dspevd_("N", "U", &c__1, a, x, z__, &c__1, w, &c__0, iw, &c__1, &info);
+ chkxer_("DSPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dspevd_("N", "U", &c__2, a, x, z__, &c__1, w, &c__3, iw, &c__1, &info);
+ chkxer_("DSPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dspevd_("V", "U", &c__2, a, x, z__, &c__2, w, &c__16, iw, &c__12, &
+ info);
+ chkxer_("DSPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dspevd_("N", "U", &c__1, a, x, z__, &c__1, w, &c__1, iw, &c__0, &info);
+ chkxer_("DSPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dspevd_("N", "U", &c__2, a, x, z__, &c__1, w, &c__4, iw, &c__0, &info);
+ chkxer_("DSPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dspevd_("V", "U", &c__2, a, x, z__, &c__2, w, &c__23, iw, &c__11, &
+ info);
+ chkxer_("DSPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* DSPEV */
+
+ s_copy(srnamc_1.srnamt, "DSPEV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dspev_("/", "U", &c__0, a, w, z__, &c__1, x, &info);
+ chkxer_("DSPEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dspev_("N", "/", &c__0, a, w, z__, &c__1, x, &info);
+ chkxer_("DSPEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dspev_("N", "U", &c_n1, a, w, z__, &c__1, x, &info);
+ chkxer_("DSPEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dspev_("V", "U", &c__2, a, w, z__, &c__1, x, &info);
+ chkxer_("DSPEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 4;
+
+/* DSPEVX */
+
+ s_copy(srnamc_1.srnamt, "DSPEVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dspevx_("/", "A", "U", &c__0, a, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("DSPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dspevx_("N", "/", "U", &c__0, a, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("DSPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dspevx_("N", "A", "/", &c__0, a, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ infoc_1.infot = 4;
+ dspevx_("N", "A", "U", &c_n1, a, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("DSPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dspevx_("N", "V", "U", &c__1, a, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("DSPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dspevx_("N", "I", "U", &c__1, a, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("DSPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dspevx_("N", "I", "U", &c__1, a, &c_b220, &c_b220, &c__2, &c__1, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("DSPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dspevx_("N", "I", "U", &c__2, a, &c_b220, &c_b220, &c__2, &c__1, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("DSPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dspevx_("N", "I", "U", &c__1, a, &c_b220, &c_b220, &c__1, &c__2, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("DSPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ dspevx_("V", "A", "U", &c__2, a, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("DSPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* Test error exits for the SB path. */
+
+ } else if (lsamen_(&c__2, c2, "SB")) {
+
+/* DSBTRD */
+
+ s_copy(srnamc_1.srnamt, "DSBTRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsbtrd_("/", "U", &c__0, &c__0, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("DSBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsbtrd_("N", "/", &c__0, &c__0, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("DSBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dsbtrd_("N", "U", &c_n1, &c__0, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("DSBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dsbtrd_("N", "U", &c__0, &c_n1, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("DSBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dsbtrd_("N", "U", &c__1, &c__1, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("DSBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dsbtrd_("V", "U", &c__2, &c__0, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("DSBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+/* DSBEVD */
+
+ s_copy(srnamc_1.srnamt, "DSBEVD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsbevd_("/", "U", &c__0, &c__0, a, &c__1, x, z__, &c__1, w, &c__1, iw,
+ &c__1, &info);
+ chkxer_("DSBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsbevd_("N", "/", &c__0, &c__0, a, &c__1, x, z__, &c__1, w, &c__1, iw,
+ &c__1, &info);
+ chkxer_("DSBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dsbevd_("N", "U", &c_n1, &c__0, a, &c__1, x, z__, &c__1, w, &c__1, iw,
+ &c__1, &info);
+ chkxer_("DSBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dsbevd_("N", "U", &c__0, &c_n1, a, &c__1, x, z__, &c__1, w, &c__1, iw,
+ &c__1, &info);
+ chkxer_("DSBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dsbevd_("N", "U", &c__2, &c__1, a, &c__1, x, z__, &c__1, w, &c__4, iw,
+ &c__1, &info);
+ chkxer_("DSBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dsbevd_("V", "U", &c__2, &c__1, a, &c__2, x, z__, &c__1, w, &c__25,
+ iw, &c__12, &info);
+ chkxer_("DSBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dsbevd_("N", "U", &c__1, &c__0, a, &c__1, x, z__, &c__1, w, &c__0, iw,
+ &c__1, &info);
+ chkxer_("DSBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dsbevd_("N", "U", &c__2, &c__0, a, &c__1, x, z__, &c__1, w, &c__3, iw,
+ &c__1, &info);
+ chkxer_("DSBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dsbevd_("V", "U", &c__2, &c__0, a, &c__1, x, z__, &c__2, w, &c__18,
+ iw, &c__12, &info);
+ chkxer_("DSBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ dsbevd_("N", "U", &c__1, &c__0, a, &c__1, x, z__, &c__1, w, &c__1, iw,
+ &c__0, &info);
+ chkxer_("DSBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ dsbevd_("V", "U", &c__2, &c__0, a, &c__1, x, z__, &c__2, w, &c__25,
+ iw, &c__11, &info);
+ chkxer_("DSBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* DSBEV */
+
+ s_copy(srnamc_1.srnamt, "DSBEV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsbev_("/", "U", &c__0, &c__0, a, &c__1, x, z__, &c__1, w, &info);
+ chkxer_("DSBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsbev_("N", "/", &c__0, &c__0, a, &c__1, x, z__, &c__1, w, &info);
+ chkxer_("DSBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dsbev_("N", "U", &c_n1, &c__0, a, &c__1, x, z__, &c__1, w, &info);
+ chkxer_("DSBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dsbev_("N", "U", &c__0, &c_n1, a, &c__1, x, z__, &c__1, w, &info);
+ chkxer_("DSBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dsbev_("N", "U", &c__2, &c__1, a, &c__1, x, z__, &c__1, w, &info);
+ chkxer_("DSBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dsbev_("V", "U", &c__2, &c__0, a, &c__1, x, z__, &c__1, w, &info);
+ chkxer_("DSBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+/* DSBEVX */
+
+ s_copy(srnamc_1.srnamt, "DSBEVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsbevx_("/", "A", "U", &c__0, &c__0, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__0, &c__0, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ chkxer_("DSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsbevx_("N", "/", "U", &c__0, &c__0, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__0, &c__0, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ chkxer_("DSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dsbevx_("N", "A", "/", &c__0, &c__0, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__0, &c__0, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ infoc_1.infot = 4;
+ dsbevx_("N", "A", "U", &c_n1, &c__0, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__0, &c__0, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ chkxer_("DSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dsbevx_("N", "A", "U", &c__0, &c_n1, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__0, &c__0, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ chkxer_("DSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dsbevx_("N", "A", "U", &c__2, &c__1, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__0, &c__0, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ chkxer_("DSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dsbevx_("V", "A", "U", &c__2, &c__0, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__0, &c__0, &c_b220, &m, x, z__, &c__2, w, iw, i3, &
+ info);
+ chkxer_("DSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dsbevx_("N", "V", "U", &c__1, &c__0, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__0, &c__0, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ chkxer_("DSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dsbevx_("N", "I", "U", &c__1, &c__0, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__0, &c__0, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ chkxer_("DSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dsbevx_("N", "I", "U", &c__1, &c__0, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__2, &c__1, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ chkxer_("DSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ dsbevx_("N", "I", "U", &c__2, &c__0, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__2, &c__1, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ chkxer_("DSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ dsbevx_("N", "I", "U", &c__1, &c__0, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__1, &c__2, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ chkxer_("DSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ dsbevx_("V", "A", "U", &c__2, &c__0, a, &c__1, q, &c__2, &c_b220, &
+ c_b220, &c__0, &c__0, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ chkxer_("DSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 13;
+ }
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___24.ciunit = infoc_1.nout;
+ s_wsfe(&io___24);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___25.ciunit = infoc_1.nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of DERRST */
+
+} /* derrst_ */
diff --git a/TESTING/EIG/dget02.c b/TESTING/EIG/dget02.c
new file mode 100644
index 0000000..1499a49
--- /dev/null
+++ b/TESTING/EIG/dget02.c
@@ -0,0 +1,187 @@
+/* dget02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b7 = -1.;
+static doublereal c_b8 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dget02_(char *trans, integer *m, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *x, integer *ldx,
+ doublereal *b, integer *ldb, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j, n1, n2;
+ doublereal eps;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal anorm, bnorm, xnorm;
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET02 computes the residual for a solution of a system of linear */
+/* equations A*x = b or A'*x = b: */
+/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A *x = b */
+/* = 'T': A'*x = b, where A' is the transpose of A */
+/* = 'C': A'*x = b, where A' is the transpose of A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The original M x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. IF TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if M = 0 or N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0 || *nrhs == 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+ if (lsame_(trans, "T") || lsame_(trans, "C")) {
+ n1 = *n;
+ n2 = *m;
+ } else {
+ n1 = *m;
+ n2 = *n;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = dlange_("1", &n1, &n2, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute B - A*X (or B - A'*X ) and store in B. */
+
+ dgemm_(trans, "No transpose", &n1, nrhs, &n2, &c_b7, &a[a_offset], lda, &
+ x[x_offset], ldx, &c_b8, &b[b_offset], ldb)
+ ;
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = dasum_(&n1, &b[j * b_dim1 + 1], &c__1);
+ xnorm = dasum_(&n2, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of DGET02 */
+
+} /* dget02_ */
diff --git a/TESTING/EIG/dget10.c b/TESTING/EIG/dget10.c
new file mode 100644
index 0000000..8f0d953
--- /dev/null
+++ b/TESTING/EIG/dget10.c
@@ -0,0 +1,150 @@
+/* dget10.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b7 = -1.;
+
+/* Subroutine */ int dget10_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *b, integer *ldb, doublereal *work, doublereal *
+ result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ doublereal eps, unfl;
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal anorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *);
+ doublereal wnorm;
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET10 compares two matrices A and B and computes the ratio */
+/* RESULT = norm( A - B ) / ( norm(A) * M * EPS ) */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices A and B. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,N) */
+/* The m by n matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION */
+/* RESULT = norm( A - B ) / ( norm(A) * M * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ *result = 0.;
+ return 0;
+ }
+
+ unfl = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+
+ wnorm = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ daxpy_(m, &c_b7, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+/* Computing MAX */
+ d__1 = wnorm, d__2 = dasum_(n, &work[1], &c__1);
+ wnorm = max(d__1,d__2);
+/* L10: */
+ }
+
+/* Computing MAX */
+ d__1 = dlange_("1", m, n, &a[a_offset], lda, &work[1]);
+ anorm = max(d__1,unfl);
+
+ if (anorm > wnorm) {
+ *result = wnorm / anorm / (*m * eps);
+ } else {
+ if (anorm < 1.) {
+/* Computing MIN */
+ d__1 = wnorm, d__2 = *m * anorm;
+ *result = min(d__1,d__2) / anorm / (*m * eps);
+ } else {
+/* Computing MIN */
+ d__1 = wnorm / anorm, d__2 = (doublereal) (*m);
+ *result = min(d__1,d__2) / (*m * eps);
+ }
+ }
+
+ return 0;
+
+/* End of DGET10 */
+
+} /* dget10_ */
diff --git a/TESTING/EIG/dget22.c b/TESTING/EIG/dget22.c
new file mode 100644
index 0000000..f64e49f
--- /dev/null
+++ b/TESTING/EIG/dget22.c
@@ -0,0 +1,401 @@
+/* dget22.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b20 = 0.;
+static integer c__2 = 2;
+static doublereal c_b25 = 1.;
+static integer c__1 = 1;
+static doublereal c_b30 = -1.;
+
+/* Subroutine */ int dget22_(char *transa, char *transe, char *transw,
+ integer *n, doublereal *a, integer *lda, doublereal *e, integer *lde,
+ doublereal *wr, doublereal *wi, doublereal *work, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, e_dim1, e_offset, i__1, i__2;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Local variables */
+ integer j;
+ doublereal ulp;
+ integer ince, jcol, jvec;
+ doublereal unfl, wmat[4] /* was [2][2] */, temp1;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ integer iecol;
+ extern logical lsame_(char *, char *);
+ integer ipair;
+ char norma[1];
+ doublereal anorm;
+ char norme[1];
+ doublereal enorm;
+ integer ierow;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ doublereal enrmin, enrmax;
+ integer itrnse;
+ doublereal errnrm;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET22 does an eigenvector check. */
+
+/* The basic test is: */
+
+/* RESULT(1) = | A E - E W | / ( |A| |E| ulp ) */
+
+/* using the 1-norm. It also tests the normalization of E: */
+
+/* RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp ) */
+/* j */
+
+/* where E(j) is the j-th eigenvector, and m-norm is the max-norm of a */
+/* vector. If an eigenvector is complex, as determined from WI(j) */
+/* nonzero, then the max-norm of the vector ( er + i*ei ) is the maximum */
+/* of */
+/* |er(1)| + |ei(1)|, ... , |er(n)| + |ei(n)| */
+
+/* W is a block diagonal matrix, with a 1 by 1 block for each real */
+/* eigenvalue and a 2 by 2 block for each complex conjugate pair. */
+/* If eigenvalues j and j+1 are a complex conjugate pair, so that */
+/* WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the 2 by 2 */
+/* block corresponding to the pair will be: */
+
+/* ( wr wi ) */
+/* ( -wi wr ) */
+
+/* Such a block multiplying an n by 2 matrix ( ur ui ) on the right */
+/* will be the same as multiplying ur + i*ui by wr + i*wi. */
+
+/* To handle various schemes for storage of left eigenvectors, there are */
+/* options to use A-transpose instead of A, E-transpose instead of E, */
+/* and/or W-transpose instead of W. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANSA (input) CHARACTER*1 */
+/* Specifies whether or not A is transposed. */
+/* = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose (= Transpose) */
+
+/* TRANSE (input) CHARACTER*1 */
+/* Specifies whether or not E is transposed. */
+/* = 'N': No transpose, eigenvectors are in columns of E */
+/* = 'T': Transpose, eigenvectors are in rows of E */
+/* = 'C': Conjugate transpose (= Transpose) */
+
+/* TRANSW (input) CHARACTER*1 */
+/* Specifies whether or not W is transposed. */
+/* = 'N': No transpose */
+/* = 'T': Transpose, use -WI(j) instead of WI(j) */
+/* = 'C': Conjugate transpose, use -WI(j) instead of WI(j) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The matrix whose eigenvectors are in E. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* E (input) DOUBLE PRECISION array, dimension (LDE,N) */
+/* The matrix of eigenvectors. If TRANSE = 'N', the eigenvectors */
+/* are stored in the columns of E, if TRANSE = 'T' or 'C', the */
+/* eigenvectors are stored in the rows of E. */
+
+/* LDE (input) INTEGER */
+/* The leading dimension of the array E. LDE >= max(1,N). */
+
+/* WR (input) DOUBLE PRECISION array, dimension (N) */
+/* WI (input) DOUBLE PRECISION array, dimension (N) */
+/* The real and imaginary parts of the eigenvalues of A. */
+/* Purely real eigenvalues are indicated by WI(j) = 0. */
+/* Complex conjugate pairs are indicated by WR(j)=WR(j+1) and */
+/* WI(j) = - WI(j+1) non-zero; the real part is assumed to be */
+/* stored in the j-th row/column and the imaginary part in */
+/* the (j+1)-th row/column. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N*(N+1)) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* RESULT(1) = | A E - E W | / ( |A| |E| ulp ) */
+/* RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize RESULT (in case N=0) */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ e_dim1 = *lde;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ --wr;
+ --wi;
+ --work;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.;
+ result[2] = 0.;
+ if (*n <= 0) {
+ return 0;
+ }
+
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Precision");
+
+ itrnse = 0;
+ ince = 1;
+ *(unsigned char *)norma = 'O';
+ *(unsigned char *)norme = 'O';
+
+ if (lsame_(transa, "T") || lsame_(transa, "C")) {
+ *(unsigned char *)norma = 'I';
+ }
+ if (lsame_(transe, "T") || lsame_(transe, "C")) {
+ *(unsigned char *)norme = 'I';
+ itrnse = 1;
+ ince = *lde;
+ }
+
+/* Check normalization of E */
+
+ enrmin = 1. / ulp;
+ enrmax = 0.;
+ if (itrnse == 0) {
+
+/* Eigenvectors are column vectors. */
+
+ ipair = 0;
+ i__1 = *n;
+ for (jvec = 1; jvec <= i__1; ++jvec) {
+ temp1 = 0.;
+ if (ipair == 0 && jvec < *n && wi[jvec] != 0.) {
+ ipair = 1;
+ }
+ if (ipair == 1) {
+
+/* Complex eigenvector */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = e[j + jvec * e_dim1], abs(
+ d__1)) + (d__2 = e[j + (jvec + 1) * e_dim1], abs(
+ d__2));
+ temp1 = max(d__3,d__4);
+/* L10: */
+ }
+ enrmin = min(enrmin,temp1);
+ enrmax = max(enrmax,temp1);
+ ipair = 2;
+ } else if (ipair == 2) {
+ ipair = 0;
+ } else {
+
+/* Real eigenvector */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ d__2 = temp1, d__3 = (d__1 = e[j + jvec * e_dim1], abs(
+ d__1));
+ temp1 = max(d__2,d__3);
+/* L20: */
+ }
+ enrmin = min(enrmin,temp1);
+ enrmax = max(enrmax,temp1);
+ ipair = 0;
+ }
+/* L30: */
+ }
+
+ } else {
+
+/* Eigenvectors are row vectors. */
+
+ i__1 = *n;
+ for (jvec = 1; jvec <= i__1; ++jvec) {
+ work[jvec] = 0.;
+/* L40: */
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ipair = 0;
+ i__2 = *n;
+ for (jvec = 1; jvec <= i__2; ++jvec) {
+ if (ipair == 0 && jvec < *n && wi[jvec] != 0.) {
+ ipair = 1;
+ }
+ if (ipair == 1) {
+/* Computing MAX */
+ d__3 = work[jvec], d__4 = (d__1 = e[j + jvec * e_dim1],
+ abs(d__1)) + (d__2 = e[j + (jvec + 1) * e_dim1],
+ abs(d__2));
+ work[jvec] = max(d__3,d__4);
+ work[jvec + 1] = work[jvec];
+ } else if (ipair == 2) {
+ ipair = 0;
+ } else {
+/* Computing MAX */
+ d__2 = work[jvec], d__3 = (d__1 = e[j + jvec * e_dim1],
+ abs(d__1));
+ work[jvec] = max(d__2,d__3);
+ ipair = 0;
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+
+ i__1 = *n;
+ for (jvec = 1; jvec <= i__1; ++jvec) {
+/* Computing MIN */
+ d__1 = enrmin, d__2 = work[jvec];
+ enrmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = enrmax, d__2 = work[jvec];
+ enrmax = max(d__1,d__2);
+/* L70: */
+ }
+ }
+
+/* Norm of A: */
+
+/* Computing MAX */
+ d__1 = dlange_(norma, n, n, &a[a_offset], lda, &work[1]);
+ anorm = max(d__1,unfl);
+
+/* Norm of E: */
+
+/* Computing MAX */
+ d__1 = dlange_(norme, n, n, &e[e_offset], lde, &work[1]);
+ enorm = max(d__1,ulp);
+
+/* Norm of error: */
+
+/* Error = AE - EW */
+
+ dlaset_("Full", n, n, &c_b20, &c_b20, &work[1], n);
+
+ ipair = 0;
+ ierow = 1;
+ iecol = 1;
+
+ i__1 = *n;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ if (itrnse == 1) {
+ ierow = jcol;
+ } else {
+ iecol = jcol;
+ }
+
+ if (ipair == 0 && wi[jcol] != 0.) {
+ ipair = 1;
+ }
+
+ if (ipair == 1) {
+ wmat[0] = wr[jcol];
+ wmat[1] = -wi[jcol];
+ wmat[2] = wi[jcol];
+ wmat[3] = wr[jcol];
+ dgemm_(transe, transw, n, &c__2, &c__2, &c_b25, &e[ierow + iecol *
+ e_dim1], lde, wmat, &c__2, &c_b20, &work[*n * (jcol - 1)
+ + 1], n);
+ ipair = 2;
+ } else if (ipair == 2) {
+ ipair = 0;
+
+ } else {
+
+ daxpy_(n, &wr[jcol], &e[ierow + iecol * e_dim1], &ince, &work[*n *
+ (jcol - 1) + 1], &c__1);
+ ipair = 0;
+ }
+
+/* L80: */
+ }
+
+ dgemm_(transa, transe, n, n, n, &c_b25, &a[a_offset], lda, &e[e_offset],
+ lde, &c_b30, &work[1], n);
+
+ errnrm = dlange_("One", n, n, &work[1], n, &work[*n * *n + 1])
+ / enorm;
+
+/* Compute RESULT(1) (avoiding under/overflow) */
+
+ if (anorm > errnrm) {
+ result[1] = errnrm / anorm / ulp;
+ } else {
+ if (anorm < 1.) {
+ result[1] = min(errnrm,anorm) / anorm / ulp;
+ } else {
+/* Computing MIN */
+ d__1 = errnrm / anorm;
+ result[1] = min(d__1,1.) / ulp;
+ }
+ }
+
+/* Compute RESULT(2) : the normalization error in E. */
+
+/* Computing MAX */
+ d__3 = (d__1 = enrmax - 1., abs(d__1)), d__4 = (d__2 = enrmin - 1., abs(
+ d__2));
+ result[2] = max(d__3,d__4) / ((doublereal) (*n) * ulp);
+
+ return 0;
+
+/* End of DGET22 */
+
+} /* dget22_ */
diff --git a/TESTING/EIG/dget23.c b/TESTING/EIG/dget23.c
new file mode 100644
index 0000000..a1a2ec1
--- /dev/null
+++ b/TESTING/EIG/dget23.c
@@ -0,0 +1,963 @@
+/* dget23.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__4 = 4;
+
+/* Subroutine */ int dget23_(logical *comp, char *balanc, integer *jtype,
+ doublereal *thresh, integer *iseed, integer *nounit, integer *n,
+ doublereal *a, integer *lda, doublereal *h__, doublereal *wr,
+ doublereal *wi, doublereal *wr1, doublereal *wi1, doublereal *vl,
+ integer *ldvl, doublereal *vr, integer *ldvr, doublereal *lre,
+ integer *ldlre, doublereal *rcondv, doublereal *rcndv1, doublereal *
+ rcdvin, doublereal *rconde, doublereal *rcnde1, doublereal *rcdein,
+ doublereal *scale, doublereal *scale1, doublereal *result, doublereal
+ *work, integer *lwork, integer *iwork, integer *info)
+{
+ /* Initialized data */
+
+ static char sens[1*2] = "N" "V";
+
+ /* Format strings */
+ static char fmt_9998[] = "(\002 DGET23: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, BALANC = "
+ "\002,a,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(\002 DGET23: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, INPUT EXAMPLE NUMBER = \002,"
+ "i4)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1,
+ vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2, d__3, d__4, d__5;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal v;
+ integer jj, ihi, ilo;
+ doublereal dum[1], eps, res[2], tol, ulp, vmx;
+ integer ihi1, ilo1, kmin;
+ doublereal vmax, tnrm, vrmx, vtst;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ logical balok, nobal;
+ extern /* Subroutine */ int dget22_(char *, char *, char *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *);
+ doublereal abnrm;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ char sense[1];
+ integer isens;
+ doublereal vimin, tolin, vrmin, abnrm1;
+ extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *), dgeevx_(char *, char *, char *
+, char *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *, integer *);
+ integer isensm;
+ doublereal smlnum, ulpinv;
+
+ /* Fortran I/O blocks */
+ static cilist io___14 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___15 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET23 checks the nonsymmetric eigenvalue problem driver SGEEVX. */
+/* If COMP = .FALSE., the first 8 of the following tests will be */
+/* performed on the input matrix A, and also test 9 if LWORK is */
+/* sufficiently large. */
+/* if COMP is .TRUE. all 11 tests will be performed. */
+
+/* (1) | A * VR - VR * W | / ( n |A| ulp ) */
+
+/* Here VR is the matrix of unit right eigenvectors. */
+/* W is a block diagonal matrix, with a 1x1 block for each */
+/* real eigenvalue and a 2x2 block for each complex conjugate */
+/* pair. If eigenvalues j and j+1 are a complex conjugate pair, */
+/* so WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the */
+/* 2 x 2 block corresponding to the pair will be: */
+
+/* ( wr wi ) */
+/* ( -wi wr ) */
+
+/* Such a block multiplying an n x 2 matrix ( ur ui ) on the */
+/* right will be the same as multiplying ur + i*ui by wr + i*wi. */
+
+/* (2) | A**H * VL - VL * W**H | / ( n |A| ulp ) */
+
+/* Here VL is the matrix of unit left eigenvectors, A**H is the */
+/* conjugate transpose of A, and W is as above. */
+
+/* (3) | |VR(i)| - 1 | / ulp and largest component real */
+
+/* VR(i) denotes the i-th column of VR. */
+
+/* (4) | |VL(i)| - 1 | / ulp and largest component real */
+
+/* VL(i) denotes the i-th column of VL. */
+
+/* (5) 0 if W(full) = W(partial), 1/ulp otherwise */
+
+/* W(full) denotes the eigenvalues computed when VR, VL, RCONDV */
+/* and RCONDE are also computed, and W(partial) denotes the */
+/* eigenvalues computed when only some of VR, VL, RCONDV, and */
+/* RCONDE are computed. */
+
+/* (6) 0 if VR(full) = VR(partial), 1/ulp otherwise */
+
+/* VR(full) denotes the right eigenvectors computed when VL, RCONDV */
+/* and RCONDE are computed, and VR(partial) denotes the result */
+/* when only some of VL and RCONDV are computed. */
+
+/* (7) 0 if VL(full) = VL(partial), 1/ulp otherwise */
+
+/* VL(full) denotes the left eigenvectors computed when VR, RCONDV */
+/* and RCONDE are computed, and VL(partial) denotes the result */
+/* when only some of VR and RCONDV are computed. */
+
+/* (8) 0 if SCALE, ILO, IHI, ABNRM (full) = */
+/* SCALE, ILO, IHI, ABNRM (partial) */
+/* 1/ulp otherwise */
+
+/* SCALE, ILO, IHI and ABNRM describe how the matrix is balanced. */
+/* (full) is when VR, VL, RCONDE and RCONDV are also computed, and */
+/* (partial) is when some are not computed. */
+
+/* (9) 0 if RCONDV(full) = RCONDV(partial), 1/ulp otherwise */
+
+/* RCONDV(full) denotes the reciprocal condition numbers of the */
+/* right eigenvectors computed when VR, VL and RCONDE are also */
+/* computed. RCONDV(partial) denotes the reciprocal condition */
+/* numbers when only some of VR, VL and RCONDE are computed. */
+
+/* (10) |RCONDV - RCDVIN| / cond(RCONDV) */
+
+/* RCONDV is the reciprocal right eigenvector condition number */
+/* computed by DGEEVX and RCDVIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDV) is the condition number of */
+/* RCONDV, and takes errors in computing RCONDV into account, so */
+/* that the resulting quantity should be O(ULP). cond(RCONDV) is */
+/* essentially given by norm(A)/RCONDE. */
+
+/* (11) |RCONDE - RCDEIN| / cond(RCONDE) */
+
+/* RCONDE is the reciprocal eigenvalue condition number */
+/* computed by DGEEVX and RCDEIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDE) is the condition number */
+/* of RCONDE, and takes errors in computing RCONDE into account, */
+/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
+/* is essentially given by norm(A)/RCONDV. */
+
+/* Arguments */
+/* ========= */
+
+/* COMP (input) LOGICAL */
+/* COMP describes which input tests to perform: */
+/* = .FALSE. if the computed condition numbers are not to */
+/* be tested against RCDVIN and RCDEIN */
+/* = .TRUE. if they are to be compared */
+
+/* BALANC (input) CHARACTER */
+/* Describes the balancing option to be tested. */
+/* = 'N' for no permuting or diagonal scaling */
+/* = 'P' for permuting but no diagonal scaling */
+/* = 'S' for no permuting but diagonal scaling */
+/* = 'B' for permuting and diagonal scaling */
+
+/* JTYPE (input) INTEGER */
+/* Type of input matrix. Used to label output if error occurs. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* ISEED (input) INTEGER array, dimension (4) */
+/* If COMP = .FALSE., the random number generator seed */
+/* used to produce matrix. */
+/* If COMP = .TRUE., ISEED(1) = the number of the example. */
+/* Used to label output if error occurs. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* N (input) INTEGER */
+/* The dimension of A. N must be at least 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, and H. LDA must be at */
+/* least 1 and at least N. */
+
+/* H (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
+/* Another copy of the test matrix A, modified by DGEEVX. */
+
+/* WR (workspace) DOUBLE PRECISION array, dimension (N) */
+/* WI (workspace) DOUBLE PRECISION array, dimension (N) */
+/* The real and imaginary parts of the eigenvalues of A. */
+/* On exit, WR + WI*i are the eigenvalues of the matrix in A. */
+
+/* WR1 (workspace) DOUBLE PRECISION array, dimension (N) */
+/* WI1 (workspace) DOUBLE PRECISION array, dimension (N) */
+/* Like WR, WI, these arrays contain the eigenvalues of A, */
+/* but those computed when DGEEVX only computes a partial */
+/* eigendecomposition, i.e. not the eigenvalues and left */
+/* and right eigenvectors. */
+
+/* VL (workspace) DOUBLE PRECISION array, dimension (LDVL,N) */
+/* VL holds the computed left eigenvectors. */
+
+/* LDVL (input) INTEGER */
+/* Leading dimension of VL. Must be at least max(1,N). */
+
+/* VR (workspace) DOUBLE PRECISION array, dimension (LDVR,N) */
+/* VR holds the computed right eigenvectors. */
+
+/* LDVR (input) INTEGER */
+/* Leading dimension of VR. Must be at least max(1,N). */
+
+/* LRE (workspace) DOUBLE PRECISION array, dimension (LDLRE,N) */
+/* LRE holds the computed right or left eigenvectors. */
+
+/* LDLRE (input) INTEGER */
+/* Leading dimension of LRE. Must be at least max(1,N). */
+
+/* RCONDV (workspace) DOUBLE PRECISION array, dimension (N) */
+/* RCONDV holds the computed reciprocal condition numbers */
+/* for eigenvectors. */
+
+/* RCNDV1 (workspace) DOUBLE PRECISION array, dimension (N) */
+/* RCNDV1 holds more computed reciprocal condition numbers */
+/* for eigenvectors. */
+
+/* RCDVIN (input) DOUBLE PRECISION array, dimension (N) */
+/* When COMP = .TRUE. RCDVIN holds the precomputed reciprocal */
+/* condition numbers for eigenvectors to be compared with */
+/* RCONDV. */
+
+/* RCONDE (workspace) DOUBLE PRECISION array, dimension (N) */
+/* RCONDE holds the computed reciprocal condition numbers */
+/* for eigenvalues. */
+
+/* RCNDE1 (workspace) DOUBLE PRECISION array, dimension (N) */
+/* RCNDE1 holds more computed reciprocal condition numbers */
+/* for eigenvalues. */
+
+/* RCDEIN (input) DOUBLE PRECISION array, dimension (N) */
+/* When COMP = .TRUE. RCDEIN holds the precomputed reciprocal */
+/* condition numbers for eigenvalues to be compared with */
+/* RCONDE. */
+
+/* SCALE (workspace) DOUBLE PRECISION array, dimension (N) */
+/* Holds information describing balancing of matrix. */
+
+/* SCALE1 (workspace) DOUBLE PRECISION array, dimension (N) */
+/* Holds information describing balancing of matrix. */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (11) */
+/* The values computed by the 11 tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 3*N, and 6*N+N**2 if tests 9, 10 or 11 are to be performed. */
+
+/* IWORK (workspace) INTEGER array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* If 0, successful exit. */
+/* If <0, input parameter -INFO had an incorrect value. */
+/* If >0, DGEEVX returned an error code, the absolute */
+/* value of which is returned. */
+
+/* ===================================================================== */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iseed;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --wr;
+ --wi;
+ --wr1;
+ --wi1;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ lre_dim1 = *ldlre;
+ lre_offset = 1 + lre_dim1;
+ lre -= lre_offset;
+ --rcondv;
+ --rcndv1;
+ --rcdvin;
+ --rconde;
+ --rcnde1;
+ --rcdein;
+ --scale;
+ --scale1;
+ --result;
+ --work;
+ --iwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ nobal = lsame_(balanc, "N");
+ balok = nobal || lsame_(balanc, "P") || lsame_(
+ balanc, "S") || lsame_(balanc, "B");
+ *info = 0;
+ if (! balok) {
+ *info = -2;
+ } else if (*thresh < 0.) {
+ *info = -4;
+ } else if (*nounit <= 0) {
+ *info = -6;
+ } else if (*n < 0) {
+ *info = -7;
+ } else if (*lda < 1 || *lda < *n) {
+ *info = -9;
+ } else if (*ldvl < 1 || *ldvl < *n) {
+ *info = -16;
+ } else if (*ldvr < 1 || *ldvr < *n) {
+ *info = -18;
+ } else if (*ldlre < 1 || *ldlre < *n) {
+ *info = -20;
+ } else if (*lwork < *n * 3 || *comp && *lwork < *n * 6 + *n * *n) {
+ *info = -31;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGET23", &i__1);
+ return 0;
+ }
+
+/* Quick return if nothing to do */
+
+ for (i__ = 1; i__ <= 11; ++i__) {
+ result[i__] = -1.;
+/* L10: */
+ }
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ ulp = dlamch_("Precision");
+ smlnum = dlamch_("S");
+ ulpinv = 1. / ulp;
+
+/* Compute eigenvalues and eigenvectors, and test them */
+
+ if (*lwork >= *n * 6 + *n * *n) {
+ *(unsigned char *)sense = 'B';
+ isensm = 2;
+ } else {
+ *(unsigned char *)sense = 'E';
+ isensm = 1;
+ }
+ dlacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ dgeevx_(balanc, "V", "V", sense, n, &h__[h_offset], lda, &wr[1], &wi[1], &
+ vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ilo, &ihi, &scale[1],
+ &abnrm, &rconde[1], &rcondv[1], &work[1], lwork, &iwork[1], &
+ iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ if (*jtype != 22) {
+ io___14.ciunit = *nounit;
+ s_wsfe(&io___14);
+ do_fio(&c__1, "DGEEVX1", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__1, balanc, (ftnlen)1);
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___15.ciunit = *nounit;
+ s_wsfe(&io___15);
+ do_fio(&c__1, "DGEEVX1", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Do Test (1) */
+
+ dget22_("N", "N", "N", n, &a[a_offset], lda, &vr[vr_offset], ldvr, &wr[1],
+ &wi[1], &work[1], res);
+ result[1] = res[0];
+
+/* Do Test (2) */
+
+ dget22_("T", "N", "T", n, &a[a_offset], lda, &vl[vl_offset], ldvl, &wr[1],
+ &wi[1], &work[1], res);
+ result[2] = res[0];
+
+/* Do Test (3) */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ tnrm = 1.;
+ if (wi[j] == 0.) {
+ tnrm = dnrm2_(n, &vr[j * vr_dim1 + 1], &c__1);
+ } else if (wi[j] > 0.) {
+ d__1 = dnrm2_(n, &vr[j * vr_dim1 + 1], &c__1);
+ d__2 = dnrm2_(n, &vr[(j + 1) * vr_dim1 + 1], &c__1);
+ tnrm = dlapy2_(&d__1, &d__2);
+ }
+/* Computing MAX */
+/* Computing MIN */
+ d__4 = ulpinv, d__5 = (d__1 = tnrm - 1., abs(d__1)) / ulp;
+ d__2 = result[3], d__3 = min(d__4,d__5);
+ result[3] = max(d__2,d__3);
+ if (wi[j] > 0.) {
+ vmx = 0.;
+ vrmx = 0.;
+ i__2 = *n;
+ for (jj = 1; jj <= i__2; ++jj) {
+ vtst = dlapy2_(&vr[jj + j * vr_dim1], &vr[jj + (j + 1) *
+ vr_dim1]);
+ if (vtst > vmx) {
+ vmx = vtst;
+ }
+ if (vr[jj + (j + 1) * vr_dim1] == 0. && (d__1 = vr[jj + j *
+ vr_dim1], abs(d__1)) > vrmx) {
+ vrmx = (d__2 = vr[jj + j * vr_dim1], abs(d__2));
+ }
+/* L20: */
+ }
+ if (vrmx / vmx < 1. - ulp * 2.) {
+ result[3] = ulpinv;
+ }
+ }
+/* L30: */
+ }
+
+/* Do Test (4) */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ tnrm = 1.;
+ if (wi[j] == 0.) {
+ tnrm = dnrm2_(n, &vl[j * vl_dim1 + 1], &c__1);
+ } else if (wi[j] > 0.) {
+ d__1 = dnrm2_(n, &vl[j * vl_dim1 + 1], &c__1);
+ d__2 = dnrm2_(n, &vl[(j + 1) * vl_dim1 + 1], &c__1);
+ tnrm = dlapy2_(&d__1, &d__2);
+ }
+/* Computing MAX */
+/* Computing MIN */
+ d__4 = ulpinv, d__5 = (d__1 = tnrm - 1., abs(d__1)) / ulp;
+ d__2 = result[4], d__3 = min(d__4,d__5);
+ result[4] = max(d__2,d__3);
+ if (wi[j] > 0.) {
+ vmx = 0.;
+ vrmx = 0.;
+ i__2 = *n;
+ for (jj = 1; jj <= i__2; ++jj) {
+ vtst = dlapy2_(&vl[jj + j * vl_dim1], &vl[jj + (j + 1) *
+ vl_dim1]);
+ if (vtst > vmx) {
+ vmx = vtst;
+ }
+ if (vl[jj + (j + 1) * vl_dim1] == 0. && (d__1 = vl[jj + j *
+ vl_dim1], abs(d__1)) > vrmx) {
+ vrmx = (d__2 = vl[jj + j * vl_dim1], abs(d__2));
+ }
+/* L40: */
+ }
+ if (vrmx / vmx < 1. - ulp * 2.) {
+ result[4] = ulpinv;
+ }
+ }
+/* L50: */
+ }
+
+/* Test for all options of computing condition numbers */
+
+ i__1 = isensm;
+ for (isens = 1; isens <= i__1; ++isens) {
+
+ *(unsigned char *)sense = *(unsigned char *)&sens[isens - 1];
+
+/* Compute eigenvalues only, and test them */
+
+ dlacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ dgeevx_(balanc, "N", "N", sense, n, &h__[h_offset], lda, &wr1[1], &
+ wi1[1], dum, &c__1, dum, &c__1, &ilo1, &ihi1, &scale1[1], &
+ abnrm1, &rcnde1[1], &rcndv1[1], &work[1], lwork, &iwork[1], &
+ iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ if (*jtype != 22) {
+ io___28.ciunit = *nounit;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "DGEEVX2", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__1, balanc, (ftnlen)1);
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___29.ciunit = *nounit;
+ s_wsfe(&io___29);
+ do_fio(&c__1, "DGEEVX2", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L190;
+ }
+
+/* Do Test (5) */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (wr[j] != wr1[j] || wi[j] != wi1[j]) {
+ result[5] = ulpinv;
+ }
+/* L60: */
+ }
+
+/* Do Test (8) */
+
+ if (! nobal) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (scale[j] != scale1[j]) {
+ result[8] = ulpinv;
+ }
+/* L70: */
+ }
+ if (ilo != ilo1) {
+ result[8] = ulpinv;
+ }
+ if (ihi != ihi1) {
+ result[8] = ulpinv;
+ }
+ if (abnrm != abnrm1) {
+ result[8] = ulpinv;
+ }
+ }
+
+/* Do Test (9) */
+
+ if (isens == 2 && *n > 1) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (rcondv[j] != rcndv1[j]) {
+ result[9] = ulpinv;
+ }
+/* L80: */
+ }
+ }
+
+/* Compute eigenvalues and right eigenvectors, and test them */
+
+ dlacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ dgeevx_(balanc, "N", "V", sense, n, &h__[h_offset], lda, &wr1[1], &
+ wi1[1], dum, &c__1, &lre[lre_offset], ldlre, &ilo1, &ihi1, &
+ scale1[1], &abnrm1, &rcnde1[1], &rcndv1[1], &work[1], lwork, &
+ iwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ if (*jtype != 22) {
+ io___30.ciunit = *nounit;
+ s_wsfe(&io___30);
+ do_fio(&c__1, "DGEEVX3", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__1, balanc, (ftnlen)1);
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___31.ciunit = *nounit;
+ s_wsfe(&io___31);
+ do_fio(&c__1, "DGEEVX3", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L190;
+ }
+
+/* Do Test (5) again */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (wr[j] != wr1[j] || wi[j] != wi1[j]) {
+ result[5] = ulpinv;
+ }
+/* L90: */
+ }
+
+/* Do Test (6) */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = *n;
+ for (jj = 1; jj <= i__3; ++jj) {
+ if (vr[j + jj * vr_dim1] != lre[j + jj * lre_dim1]) {
+ result[6] = ulpinv;
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+
+/* Do Test (8) again */
+
+ if (! nobal) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (scale[j] != scale1[j]) {
+ result[8] = ulpinv;
+ }
+/* L120: */
+ }
+ if (ilo != ilo1) {
+ result[8] = ulpinv;
+ }
+ if (ihi != ihi1) {
+ result[8] = ulpinv;
+ }
+ if (abnrm != abnrm1) {
+ result[8] = ulpinv;
+ }
+ }
+
+/* Do Test (9) again */
+
+ if (isens == 2 && *n > 1) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (rcondv[j] != rcndv1[j]) {
+ result[9] = ulpinv;
+ }
+/* L130: */
+ }
+ }
+
+/* Compute eigenvalues and left eigenvectors, and test them */
+
+ dlacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ dgeevx_(balanc, "V", "N", sense, n, &h__[h_offset], lda, &wr1[1], &
+ wi1[1], &lre[lre_offset], ldlre, dum, &c__1, &ilo1, &ihi1, &
+ scale1[1], &abnrm1, &rcnde1[1], &rcndv1[1], &work[1], lwork, &
+ iwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ if (*jtype != 22) {
+ io___32.ciunit = *nounit;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "DGEEVX4", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__1, balanc, (ftnlen)1);
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___33.ciunit = *nounit;
+ s_wsfe(&io___33);
+ do_fio(&c__1, "DGEEVX4", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L190;
+ }
+
+/* Do Test (5) again */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (wr[j] != wr1[j] || wi[j] != wi1[j]) {
+ result[5] = ulpinv;
+ }
+/* L140: */
+ }
+
+/* Do Test (7) */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = *n;
+ for (jj = 1; jj <= i__3; ++jj) {
+ if (vl[j + jj * vl_dim1] != lre[j + jj * lre_dim1]) {
+ result[7] = ulpinv;
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+
+/* Do Test (8) again */
+
+ if (! nobal) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (scale[j] != scale1[j]) {
+ result[8] = ulpinv;
+ }
+/* L170: */
+ }
+ if (ilo != ilo1) {
+ result[8] = ulpinv;
+ }
+ if (ihi != ihi1) {
+ result[8] = ulpinv;
+ }
+ if (abnrm != abnrm1) {
+ result[8] = ulpinv;
+ }
+ }
+
+/* Do Test (9) again */
+
+ if (isens == 2 && *n > 1) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (rcondv[j] != rcndv1[j]) {
+ result[9] = ulpinv;
+ }
+/* L180: */
+ }
+ }
+
+L190:
+
+/* L200: */
+ ;
+ }
+
+/* If COMP, compare condition numbers to precomputed ones */
+
+ if (*comp) {
+ dlacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ dgeevx_("N", "V", "V", "B", n, &h__[h_offset], lda, &wr[1], &wi[1], &
+ vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ilo, &ihi, &scale[
+ 1], &abnrm, &rconde[1], &rcondv[1], &work[1], lwork, &iwork[1]
+, &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___34.ciunit = *nounit;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "DGEEVX5", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Sort eigenvalues and condition numbers lexicographically */
+/* to compare with inputs */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ kmin = i__;
+ vrmin = wr[i__];
+ vimin = wi[i__];
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (wr[j] < vrmin) {
+ kmin = j;
+ vrmin = wr[j];
+ vimin = wi[j];
+ }
+/* L210: */
+ }
+ wr[kmin] = wr[i__];
+ wi[kmin] = wi[i__];
+ wr[i__] = vrmin;
+ wi[i__] = vimin;
+ vrmin = rconde[kmin];
+ rconde[kmin] = rconde[i__];
+ rconde[i__] = vrmin;
+ vrmin = rcondv[kmin];
+ rcondv[kmin] = rcondv[i__];
+ rcondv[i__] = vrmin;
+/* L220: */
+ }
+
+/* Compare condition numbers for eigenvectors */
+/* taking their condition numbers into account */
+
+ result[10] = 0.;
+ eps = max(5.9605e-8,ulp);
+/* Computing MAX */
+ d__1 = (doublereal) (*n) * eps * abnrm;
+ v = max(d__1,smlnum);
+ if (abnrm == 0.) {
+ v = 1.;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (v > rcondv[i__] * rconde[i__]) {
+ tol = rcondv[i__];
+ } else {
+ tol = v / rconde[i__];
+ }
+ if (v > rcdvin[i__] * rcdein[i__]) {
+ tolin = rcdvin[i__];
+ } else {
+ tolin = v / rcdein[i__];
+ }
+/* Computing MAX */
+ d__1 = tol, d__2 = smlnum / eps;
+ tol = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = tolin, d__2 = smlnum / eps;
+ tolin = max(d__1,d__2);
+ if (eps * (rcdvin[i__] - tolin) > rcondv[i__] + tol) {
+ vmax = 1. / eps;
+ } else if (rcdvin[i__] - tolin > rcondv[i__] + tol) {
+ vmax = (rcdvin[i__] - tolin) / (rcondv[i__] + tol);
+ } else if (rcdvin[i__] + tolin < eps * (rcondv[i__] - tol)) {
+ vmax = 1. / eps;
+ } else if (rcdvin[i__] + tolin < rcondv[i__] - tol) {
+ vmax = (rcondv[i__] - tol) / (rcdvin[i__] + tolin);
+ } else {
+ vmax = 1.;
+ }
+ result[10] = max(result[10],vmax);
+/* L230: */
+ }
+
+/* Compare condition numbers for eigenvalues */
+/* taking their condition numbers into account */
+
+ result[11] = 0.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (v > rcondv[i__]) {
+ tol = 1.;
+ } else {
+ tol = v / rcondv[i__];
+ }
+ if (v > rcdvin[i__]) {
+ tolin = 1.;
+ } else {
+ tolin = v / rcdvin[i__];
+ }
+/* Computing MAX */
+ d__1 = tol, d__2 = smlnum / eps;
+ tol = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = tolin, d__2 = smlnum / eps;
+ tolin = max(d__1,d__2);
+ if (eps * (rcdein[i__] - tolin) > rconde[i__] + tol) {
+ vmax = 1. / eps;
+ } else if (rcdein[i__] - tolin > rconde[i__] + tol) {
+ vmax = (rcdein[i__] - tolin) / (rconde[i__] + tol);
+ } else if (rcdein[i__] + tolin < eps * (rconde[i__] - tol)) {
+ vmax = 1. / eps;
+ } else if (rcdein[i__] + tolin < rconde[i__] - tol) {
+ vmax = (rconde[i__] - tol) / (rcdein[i__] + tolin);
+ } else {
+ vmax = 1.;
+ }
+ result[11] = max(result[11],vmax);
+/* L240: */
+ }
+L250:
+
+ ;
+ }
+
+
+ return 0;
+
+/* End of DGET23 */
+
+} /* dget23_ */
diff --git a/TESTING/EIG/dget24.c b/TESTING/EIG/dget24.c
new file mode 100644
index 0000000..d7939af
--- /dev/null
+++ b/TESTING/EIG/dget24.c
@@ -0,0 +1,1181 @@
+/* dget24.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ doublereal selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__4 = 4;
+static doublereal c_b35 = 1.;
+static doublereal c_b41 = 0.;
+static doublereal c_b44 = -1.;
+
+/* Subroutine */ int dget24_(logical *comp, integer *jtype, doublereal *
+ thresh, integer *iseed, integer *nounit, integer *n, doublereal *a,
+ integer *lda, doublereal *h__, doublereal *ht, doublereal *wr,
+ doublereal *wi, doublereal *wrt, doublereal *wit, doublereal *wrtmp,
+ doublereal *witmp, doublereal *vs, integer *ldvs, doublereal *vs1,
+ doublereal *rcdein, doublereal *rcdvin, integer *nslct, integer *
+ islct, doublereal *result, doublereal *work, integer *lwork, integer *
+ iwork, logical *bwork, integer *info)
+{
+ /* Format strings */
+ static char fmt_9998[] = "(\002 DGET24: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(\002 DGET24: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, INPUT EXAMPLE NUMBER = \002,"
+ "i4)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, ht_dim1, ht_offset, vs_dim1,
+ vs_offset, vs1_dim1, vs1_offset, i__1, i__2;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double d_sign(doublereal *, doublereal *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal v, eps, tol, tmp, ulp;
+ integer sdim, kmin, itmp, ipnt[20], rsub;
+ char sort[1];
+ integer sdim1;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ integer iinfo;
+ extern /* Subroutine */ int dort01_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *);
+ doublereal anorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ doublereal vimin, tolin, vrmin;
+ integer isort;
+ doublereal wnorm, rcnde1, rcndv1;
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ doublereal rconde;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ extern logical dslect_(doublereal *, doublereal *);
+ extern /* Subroutine */ int dgeesx_(char *, char *, L_fp, char *, integer
+ *, doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *
+, integer *, integer *, integer *, logical *, integer *), xerbla_(char *, integer *);
+ integer knteig;
+ doublereal rcondv;
+ integer liwork;
+ doublereal smlnum, ulpinv;
+
+ /* Fortran I/O blocks */
+ static cilist io___13 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___14 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___19 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___20 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET24 checks the nonsymmetric eigenvalue (Schur form) problem */
+/* expert driver DGEESX. */
+
+/* If COMP = .FALSE., the first 13 of the following tests will be */
+/* be performed on the input matrix A, and also tests 14 and 15 */
+/* if LWORK is sufficiently large. */
+/* If COMP = .TRUE., all 17 test will be performed. */
+
+/* (1) 0 if T is in Schur form, 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (2) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (no sorting of eigenvalues). */
+
+/* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues). */
+
+/* (4) 0 if WR+sqrt(-1)*WI are eigenvalues of T */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (5) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (7) 0 if T is in Schur form, 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (8) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (with sorting of eigenvalues). */
+
+/* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues). */
+
+/* (10) 0 if WR+sqrt(-1)*WI are eigenvalues of T */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare WR, WI with and */
+/* without reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (11) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare T with and without */
+/* reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare VS with and without */
+/* reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (13) if sorting worked and SDIM is the number of */
+/* eigenvalues which were SELECTed */
+/* If workspace sufficient, also compare SDIM with and */
+/* without reciprocal condition numbers */
+
+/* (14) if RCONDE the same no matter if VS and/or RCONDV computed */
+
+/* (15) if RCONDV the same no matter if VS and/or RCONDE computed */
+
+/* (16) |RCONDE - RCDEIN| / cond(RCONDE) */
+
+/* RCONDE is the reciprocal average eigenvalue condition number */
+/* computed by DGEESX and RCDEIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDE) is the condition number */
+/* of RCONDE, and takes errors in computing RCONDE into account, */
+/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
+/* is essentially given by norm(A)/RCONDV. */
+
+/* (17) |RCONDV - RCDVIN| / cond(RCONDV) */
+
+/* RCONDV is the reciprocal right invariant subspace condition */
+/* number computed by DGEESX and RCDVIN (the precomputed true */
+/* value) is supplied as input. cond(RCONDV) is the condition */
+/* number of RCONDV, and takes errors in computing RCONDV into */
+/* account, so that the resulting quantity should be O(ULP). */
+/* cond(RCONDV) is essentially given by norm(A)/RCONDE. */
+
+/* Arguments */
+/* ========= */
+
+/* COMP (input) LOGICAL */
+/* COMP describes which input tests to perform: */
+/* = .FALSE. if the computed condition numbers are not to */
+/* be tested against RCDVIN and RCDEIN */
+/* = .TRUE. if they are to be compared */
+
+/* JTYPE (input) INTEGER */
+/* Type of input matrix. Used to label output if error occurs. */
+
+/* ISEED (input) INTEGER array, dimension (4) */
+/* If COMP = .FALSE., the random number generator seed */
+/* used to produce matrix. */
+/* If COMP = .TRUE., ISEED(1) = the number of the example. */
+/* Used to label output if error occurs. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* N (input) INTEGER */
+/* The dimension of A. N must be at least 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, and H. LDA must be at */
+/* least 1 and at least N. */
+
+/* H (workspace) DOUBLE PRECISION array, dimension (LDA, N) */
+/* Another copy of the test matrix A, modified by DGEESX. */
+
+/* HT (workspace) DOUBLE PRECISION array, dimension (LDA, N) */
+/* Yet another copy of the test matrix A, modified by DGEESX. */
+
+/* WR (workspace) DOUBLE PRECISION array, dimension (N) */
+/* WI (workspace) DOUBLE PRECISION array, dimension (N) */
+/* The real and imaginary parts of the eigenvalues of A. */
+/* On exit, WR + WI*i are the eigenvalues of the matrix in A. */
+
+/* WRT (workspace) DOUBLE PRECISION array, dimension (N) */
+/* WIT (workspace) DOUBLE PRECISION array, dimension (N) */
+/* Like WR, WI, these arrays contain the eigenvalues of A, */
+/* but those computed when DGEESX only computes a partial */
+/* eigendecomposition, i.e. not Schur vectors */
+
+/* WRTMP (workspace) DOUBLE PRECISION array, dimension (N) */
+/* WITMP (workspace) DOUBLE PRECISION array, dimension (N) */
+/* Like WR, WI, these arrays contain the eigenvalues of A, */
+/* but sorted by increasing real part. */
+
+/* VS (workspace) DOUBLE PRECISION array, dimension (LDVS, N) */
+/* VS holds the computed Schur vectors. */
+
+/* LDVS (input) INTEGER */
+/* Leading dimension of VS. Must be at least max(1, N). */
+
+/* VS1 (workspace) DOUBLE PRECISION array, dimension (LDVS, N) */
+/* VS1 holds another copy of the computed Schur vectors. */
+
+/* RCDEIN (input) DOUBLE PRECISION */
+/* When COMP = .TRUE. RCDEIN holds the precomputed reciprocal */
+/* condition number for the average of selected eigenvalues. */
+
+/* RCDVIN (input) DOUBLE PRECISION */
+/* When COMP = .TRUE. RCDVIN holds the precomputed reciprocal */
+/* condition number for the selected right invariant subspace. */
+
+/* NSLCT (input) INTEGER */
+/* When COMP = .TRUE. the number of selected eigenvalues */
+/* corresponding to the precomputed values RCDEIN and RCDVIN. */
+
+/* ISLCT (input) INTEGER array, dimension (NSLCT) */
+/* When COMP = .TRUE. ISLCT selects the eigenvalues of the */
+/* input matrix corresponding to the precomputed values RCDEIN */
+/* and RCDVIN. For I=1, ... ,NSLCT, if ISLCT(I) = J, then the */
+/* eigenvalue with the J-th largest real part is selected. */
+/* Not referenced if COMP = .FALSE. */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (17) */
+/* The values computed by the 17 tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK to be passed to DGEESX. This */
+/* must be at least 3*N, and N+N**2 if tests 14--16 are to */
+/* be performed. */
+
+/* IWORK (workspace) INTEGER array, dimension (N*N) */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* If 0, successful exit. */
+/* If <0, input parameter -INFO had an incorrect value. */
+/* If >0, DGEESX returned an error code, the absolute */
+/* value of which is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ /* Parameter adjustments */
+ --iseed;
+ ht_dim1 = *lda;
+ ht_offset = 1 + ht_dim1;
+ ht -= ht_offset;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --wr;
+ --wi;
+ --wrt;
+ --wit;
+ --wrtmp;
+ --witmp;
+ vs1_dim1 = *ldvs;
+ vs1_offset = 1 + vs1_dim1;
+ vs1 -= vs1_offset;
+ vs_dim1 = *ldvs;
+ vs_offset = 1 + vs_dim1;
+ vs -= vs_offset;
+ --islct;
+ --result;
+ --work;
+ --iwork;
+ --bwork;
+
+ /* Function Body */
+ *info = 0;
+ if (*thresh < 0.) {
+ *info = -3;
+ } else if (*nounit <= 0) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (*lda < 1 || *lda < *n) {
+ *info = -8;
+ } else if (*ldvs < 1 || *ldvs < *n) {
+ *info = -18;
+ } else if (*lwork < *n * 3) {
+ *info = -26;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGET24", &i__1);
+ return 0;
+ }
+
+/* Quick return if nothing to do */
+
+ for (i__ = 1; i__ <= 17; ++i__) {
+ result[i__] = -1.;
+/* L10: */
+ }
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Important constants */
+
+ smlnum = dlamch_("Safe minimum");
+ ulp = dlamch_("Precision");
+ ulpinv = 1. / ulp;
+
+/* Perform tests (1)-(13) */
+
+ sslct_1.selopt = 0;
+ liwork = *n * *n;
+ for (isort = 0; isort <= 1; ++isort) {
+ if (isort == 0) {
+ *(unsigned char *)sort = 'N';
+ rsub = 0;
+ } else {
+ *(unsigned char *)sort = 'S';
+ rsub = 6;
+ }
+
+/* Compute Schur form and Schur vectors, and test them */
+
+ dlacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ dgeesx_("V", sort, (L_fp)dslect_, "N", n, &h__[h_offset], lda, &sdim,
+ &wr[1], &wi[1], &vs[vs_offset], ldvs, &rconde, &rcondv, &work[
+ 1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != *n + 2) {
+ result[rsub + 1] = ulpinv;
+ if (*jtype != 22) {
+ io___13.ciunit = *nounit;
+ s_wsfe(&io___13);
+ do_fio(&c__1, "DGEESX1", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___14.ciunit = *nounit;
+ s_wsfe(&io___14);
+ do_fio(&c__1, "DGEESX1", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ return 0;
+ }
+ if (isort == 0) {
+ dcopy_(n, &wr[1], &c__1, &wrtmp[1], &c__1);
+ dcopy_(n, &wi[1], &c__1, &witmp[1], &c__1);
+ }
+
+/* Do Test (1) or Test (7) */
+
+ result[rsub + 1] = 0.;
+ i__1 = *n - 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+ if (h__[i__ + j * h_dim1] != 0.) {
+ result[rsub + 1] = ulpinv;
+ }
+/* L20: */
+ }
+/* L30: */
+ }
+ i__1 = *n - 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (h__[i__ + 1 + i__ * h_dim1] != 0. && h__[i__ + 2 + (i__ + 1) *
+ h_dim1] != 0.) {
+ result[rsub + 1] = ulpinv;
+ }
+/* L40: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (h__[i__ + 1 + i__ * h_dim1] != 0.) {
+ if (h__[i__ + i__ * h_dim1] != h__[i__ + 1 + (i__ + 1) *
+ h_dim1] || h__[i__ + (i__ + 1) * h_dim1] == 0. ||
+ d_sign(&c_b35, &h__[i__ + 1 + i__ * h_dim1]) ==
+ d_sign(&c_b35, &h__[i__ + (i__ + 1) * h_dim1])) {
+ result[rsub + 1] = ulpinv;
+ }
+ }
+/* L50: */
+ }
+
+/* Test (2) or (8): Compute norm(A - Q*H*Q') / (norm(A) * N * ULP) */
+
+/* Copy A to VS1, used as workspace */
+
+ dlacpy_(" ", n, n, &a[a_offset], lda, &vs1[vs1_offset], ldvs);
+
+/* Compute Q*H and store in HT. */
+
+ dgemm_("No transpose", "No transpose", n, n, n, &c_b35, &vs[vs_offset]
+, ldvs, &h__[h_offset], lda, &c_b41, &ht[ht_offset], lda);
+
+/* Compute A - Q*H*Q' */
+
+ dgemm_("No transpose", "Transpose", n, n, n, &c_b44, &ht[ht_offset],
+ lda, &vs[vs_offset], ldvs, &c_b35, &vs1[vs1_offset], ldvs);
+
+/* Computing MAX */
+ d__1 = dlange_("1", n, n, &a[a_offset], lda, &work[1]);
+ anorm = max(d__1,smlnum);
+ wnorm = dlange_("1", n, n, &vs1[vs1_offset], ldvs, &work[1]);
+
+ if (anorm > wnorm) {
+ result[rsub + 2] = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.) {
+/* Computing MIN */
+ d__1 = wnorm, d__2 = *n * anorm;
+ result[rsub + 2] = min(d__1,d__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
+ result[rsub + 2] = min(d__1,d__2) / (*n * ulp);
+ }
+ }
+
+/* Test (3) or (9): Compute norm( I - Q'*Q ) / ( N * ULP ) */
+
+ dort01_("Columns", n, n, &vs[vs_offset], ldvs, &work[1], lwork, &
+ result[rsub + 3]);
+
+/* Do Test (4) or Test (10) */
+
+ result[rsub + 4] = 0.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (h__[i__ + i__ * h_dim1] != wr[i__]) {
+ result[rsub + 4] = ulpinv;
+ }
+/* L60: */
+ }
+ if (*n > 1) {
+ if (h__[h_dim1 + 2] == 0. && wi[1] != 0.) {
+ result[rsub + 4] = ulpinv;
+ }
+ if (h__[*n + (*n - 1) * h_dim1] == 0. && wi[*n] != 0.) {
+ result[rsub + 4] = ulpinv;
+ }
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (h__[i__ + 1 + i__ * h_dim1] != 0.) {
+ tmp = sqrt((d__1 = h__[i__ + 1 + i__ * h_dim1], abs(d__1))) *
+ sqrt((d__2 = h__[i__ + (i__ + 1) * h_dim1], abs(d__2))
+ );
+/* Computing MAX */
+/* Computing MAX */
+ d__4 = ulp * tmp;
+ d__2 = result[rsub + 4], d__3 = (d__1 = wi[i__] - tmp, abs(
+ d__1)) / max(d__4,smlnum);
+ result[rsub + 4] = max(d__2,d__3);
+/* Computing MAX */
+/* Computing MAX */
+ d__4 = ulp * tmp;
+ d__2 = result[rsub + 4], d__3 = (d__1 = wi[i__ + 1] + tmp,
+ abs(d__1)) / max(d__4,smlnum);
+ result[rsub + 4] = max(d__2,d__3);
+ } else if (i__ > 1) {
+ if (h__[i__ + 1 + i__ * h_dim1] == 0. && h__[i__ + (i__ - 1) *
+ h_dim1] == 0. && wi[i__] != 0.) {
+ result[rsub + 4] = ulpinv;
+ }
+ }
+/* L70: */
+ }
+
+/* Do Test (5) or Test (11) */
+
+ dlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ dgeesx_("N", sort, (L_fp)dslect_, "N", n, &ht[ht_offset], lda, &sdim,
+ &wrt[1], &wit[1], &vs[vs_offset], ldvs, &rconde, &rcondv, &
+ work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != *n + 2) {
+ result[rsub + 5] = ulpinv;
+ if (*jtype != 22) {
+ io___19.ciunit = *nounit;
+ s_wsfe(&io___19);
+ do_fio(&c__1, "DGEESX2", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___20.ciunit = *nounit;
+ s_wsfe(&io___20);
+ do_fio(&c__1, "DGEESX2", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+ result[rsub + 5] = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (h__[i__ + j * h_dim1] != ht[i__ + j * ht_dim1]) {
+ result[rsub + 5] = ulpinv;
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Do Test (6) or Test (12) */
+
+ result[rsub + 6] = 0.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (wr[i__] != wrt[i__] || wi[i__] != wit[i__]) {
+ result[rsub + 6] = ulpinv;
+ }
+/* L100: */
+ }
+
+/* Do Test (13) */
+
+ if (isort == 1) {
+ result[13] = 0.;
+ knteig = 0;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__1 = -wi[i__];
+ if (dslect_(&wr[i__], &wi[i__]) || dslect_(&wr[i__], &d__1)) {
+ ++knteig;
+ }
+ if (i__ < *n) {
+ d__1 = -wi[i__ + 1];
+ d__2 = -wi[i__];
+ if ((dslect_(&wr[i__ + 1], &wi[i__ + 1]) || dslect_(&wr[
+ i__ + 1], &d__1)) && ! (dslect_(&wr[i__], &wi[i__]
+) || dslect_(&wr[i__], &d__2)) && iinfo != *n + 2)
+ {
+ result[13] = ulpinv;
+ }
+ }
+/* L110: */
+ }
+ if (sdim != knteig) {
+ result[13] = ulpinv;
+ }
+ }
+
+/* L120: */
+ }
+
+/* If there is enough workspace, perform tests (14) and (15) */
+/* as well as (10) through (13) */
+
+ if (*lwork >= *n + *n * *n / 2) {
+
+/* Compute both RCONDE and RCONDV with VS */
+
+ *(unsigned char *)sort = 'S';
+ result[14] = 0.;
+ result[15] = 0.;
+ dlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ dgeesx_("V", sort, (L_fp)dslect_, "B", n, &ht[ht_offset], lda, &sdim1,
+ &wrt[1], &wit[1], &vs1[vs1_offset], ldvs, &rconde, &rcondv, &
+ work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != *n + 2) {
+ result[14] = ulpinv;
+ result[15] = ulpinv;
+ if (*jtype != 22) {
+ io___23.ciunit = *nounit;
+ s_wsfe(&io___23);
+ do_fio(&c__1, "DGEESX3", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___24.ciunit = *nounit;
+ s_wsfe(&io___24);
+ do_fio(&c__1, "DGEESX3", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (wr[i__] != wrt[i__] || wi[i__] != wit[i__]) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (h__[i__ + j * h_dim1] != ht[i__ + j * ht_dim1]) {
+ result[11] = ulpinv;
+ }
+ if (vs[i__ + j * vs_dim1] != vs1[i__ + j * vs1_dim1]) {
+ result[12] = ulpinv;
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+/* Compute both RCONDE and RCONDV without VS, and compare */
+
+ dlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ dgeesx_("N", sort, (L_fp)dslect_, "B", n, &ht[ht_offset], lda, &sdim1,
+ &wrt[1], &wit[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &
+ work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != *n + 2) {
+ result[14] = ulpinv;
+ result[15] = ulpinv;
+ if (*jtype != 22) {
+ io___27.ciunit = *nounit;
+ s_wsfe(&io___27);
+ do_fio(&c__1, "DGEESX4", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___28.ciunit = *nounit;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "DGEESX4", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Perform tests (14) and (15) */
+
+ if (rcnde1 != rconde) {
+ result[14] = ulpinv;
+ }
+ if (rcndv1 != rcondv) {
+ result[15] = ulpinv;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (wr[i__] != wrt[i__] || wi[i__] != wit[i__]) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (h__[i__ + j * h_dim1] != ht[i__ + j * ht_dim1]) {
+ result[11] = ulpinv;
+ }
+ if (vs[i__ + j * vs_dim1] != vs1[i__ + j * vs1_dim1]) {
+ result[12] = ulpinv;
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+/* Compute RCONDE with VS, and compare */
+
+ dlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ dgeesx_("V", sort, (L_fp)dslect_, "E", n, &ht[ht_offset], lda, &sdim1,
+ &wrt[1], &wit[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &
+ work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != *n + 2) {
+ result[14] = ulpinv;
+ if (*jtype != 22) {
+ io___29.ciunit = *nounit;
+ s_wsfe(&io___29);
+ do_fio(&c__1, "DGEESX5", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___30.ciunit = *nounit;
+ s_wsfe(&io___30);
+ do_fio(&c__1, "DGEESX5", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Perform test (14) */
+
+ if (rcnde1 != rconde) {
+ result[14] = ulpinv;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (wr[i__] != wrt[i__] || wi[i__] != wit[i__]) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (h__[i__ + j * h_dim1] != ht[i__ + j * ht_dim1]) {
+ result[11] = ulpinv;
+ }
+ if (vs[i__ + j * vs_dim1] != vs1[i__ + j * vs1_dim1]) {
+ result[12] = ulpinv;
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+/* Compute RCONDE without VS, and compare */
+
+ dlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ dgeesx_("N", sort, (L_fp)dslect_, "E", n, &ht[ht_offset], lda, &sdim1,
+ &wrt[1], &wit[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &
+ work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != *n + 2) {
+ result[14] = ulpinv;
+ if (*jtype != 22) {
+ io___31.ciunit = *nounit;
+ s_wsfe(&io___31);
+ do_fio(&c__1, "DGEESX6", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___32.ciunit = *nounit;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "DGEESX6", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Perform test (14) */
+
+ if (rcnde1 != rconde) {
+ result[14] = ulpinv;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (wr[i__] != wrt[i__] || wi[i__] != wit[i__]) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (h__[i__ + j * h_dim1] != ht[i__ + j * ht_dim1]) {
+ result[11] = ulpinv;
+ }
+ if (vs[i__ + j * vs_dim1] != vs1[i__ + j * vs1_dim1]) {
+ result[12] = ulpinv;
+ }
+/* L190: */
+ }
+/* L200: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+/* Compute RCONDV with VS, and compare */
+
+ dlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ dgeesx_("V", sort, (L_fp)dslect_, "V", n, &ht[ht_offset], lda, &sdim1,
+ &wrt[1], &wit[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &
+ work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != *n + 2) {
+ result[15] = ulpinv;
+ if (*jtype != 22) {
+ io___33.ciunit = *nounit;
+ s_wsfe(&io___33);
+ do_fio(&c__1, "DGEESX7", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___34.ciunit = *nounit;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "DGEESX7", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Perform test (15) */
+
+ if (rcndv1 != rcondv) {
+ result[15] = ulpinv;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (wr[i__] != wrt[i__] || wi[i__] != wit[i__]) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (h__[i__ + j * h_dim1] != ht[i__ + j * ht_dim1]) {
+ result[11] = ulpinv;
+ }
+ if (vs[i__ + j * vs_dim1] != vs1[i__ + j * vs1_dim1]) {
+ result[12] = ulpinv;
+ }
+/* L210: */
+ }
+/* L220: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+/* Compute RCONDV without VS, and compare */
+
+ dlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ dgeesx_("N", sort, (L_fp)dslect_, "V", n, &ht[ht_offset], lda, &sdim1,
+ &wrt[1], &wit[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &
+ work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != *n + 2) {
+ result[15] = ulpinv;
+ if (*jtype != 22) {
+ io___35.ciunit = *nounit;
+ s_wsfe(&io___35);
+ do_fio(&c__1, "DGEESX8", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___36.ciunit = *nounit;
+ s_wsfe(&io___36);
+ do_fio(&c__1, "DGEESX8", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Perform test (15) */
+
+ if (rcndv1 != rcondv) {
+ result[15] = ulpinv;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (wr[i__] != wrt[i__] || wi[i__] != wit[i__]) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (h__[i__ + j * h_dim1] != ht[i__ + j * ht_dim1]) {
+ result[11] = ulpinv;
+ }
+ if (vs[i__ + j * vs_dim1] != vs1[i__ + j * vs1_dim1]) {
+ result[12] = ulpinv;
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+ }
+
+L250:
+
+/* If there are precomputed reciprocal condition numbers, compare */
+/* computed values with them. */
+
+ if (*comp) {
+
+/* First set up SELOPT, SELDIM, SELVAL, SELWR, and SELWI so that */
+/* the logical function DSLECT selects the eigenvalues specified */
+/* by NSLCT and ISLCT. */
+
+ sslct_1.seldim = *n;
+ sslct_1.selopt = 1;
+ eps = max(ulp,5.9605e-8);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ipnt[i__ - 1] = i__;
+ sslct_1.selval[i__ - 1] = FALSE_;
+ sslct_1.selwr[i__ - 1] = wrtmp[i__];
+ sslct_1.selwi[i__ - 1] = witmp[i__];
+/* L260: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ kmin = i__;
+ vrmin = wrtmp[i__];
+ vimin = witmp[i__];
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (wrtmp[j] < vrmin) {
+ kmin = j;
+ vrmin = wrtmp[j];
+ vimin = witmp[j];
+ }
+/* L270: */
+ }
+ wrtmp[kmin] = wrtmp[i__];
+ witmp[kmin] = witmp[i__];
+ wrtmp[i__] = vrmin;
+ witmp[i__] = vimin;
+ itmp = ipnt[i__ - 1];
+ ipnt[i__ - 1] = ipnt[kmin - 1];
+ ipnt[kmin - 1] = itmp;
+/* L280: */
+ }
+ i__1 = *nslct;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sslct_1.selval[ipnt[islct[i__] - 1] - 1] = TRUE_;
+/* L290: */
+ }
+
+/* Compute condition numbers */
+
+ dlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ dgeesx_("N", "S", (L_fp)dslect_, "B", n, &ht[ht_offset], lda, &sdim1,
+ &wrt[1], &wit[1], &vs1[vs1_offset], ldvs, &rconde, &rcondv, &
+ work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != *n + 2) {
+ result[16] = ulpinv;
+ result[17] = ulpinv;
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "DGEESX9", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L300;
+ }
+
+/* Compare condition number for average of selected eigenvalues */
+/* taking its condition number into account */
+
+ anorm = dlange_("1", n, n, &a[a_offset], lda, &work[1]);
+/* Computing MAX */
+ d__1 = (doublereal) (*n) * eps * anorm;
+ v = max(d__1,smlnum);
+ if (anorm == 0.) {
+ v = 1.;
+ }
+ if (v > rcondv) {
+ tol = 1.;
+ } else {
+ tol = v / rcondv;
+ }
+ if (v > *rcdvin) {
+ tolin = 1.;
+ } else {
+ tolin = v / *rcdvin;
+ }
+/* Computing MAX */
+ d__1 = tol, d__2 = smlnum / eps;
+ tol = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = tolin, d__2 = smlnum / eps;
+ tolin = max(d__1,d__2);
+ if (eps * (*rcdein - tolin) > rconde + tol) {
+ result[16] = ulpinv;
+ } else if (*rcdein - tolin > rconde + tol) {
+ result[16] = (*rcdein - tolin) / (rconde + tol);
+ } else if (*rcdein + tolin < eps * (rconde - tol)) {
+ result[16] = ulpinv;
+ } else if (*rcdein + tolin < rconde - tol) {
+ result[16] = (rconde - tol) / (*rcdein + tolin);
+ } else {
+ result[16] = 1.;
+ }
+
+/* Compare condition numbers for right invariant subspace */
+/* taking its condition number into account */
+
+ if (v > rcondv * rconde) {
+ tol = rcondv;
+ } else {
+ tol = v / rconde;
+ }
+ if (v > *rcdvin * *rcdein) {
+ tolin = *rcdvin;
+ } else {
+ tolin = v / *rcdein;
+ }
+/* Computing MAX */
+ d__1 = tol, d__2 = smlnum / eps;
+ tol = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = tolin, d__2 = smlnum / eps;
+ tolin = max(d__1,d__2);
+ if (eps * (*rcdvin - tolin) > rcondv + tol) {
+ result[17] = ulpinv;
+ } else if (*rcdvin - tolin > rcondv + tol) {
+ result[17] = (*rcdvin - tolin) / (rcondv + tol);
+ } else if (*rcdvin + tolin < eps * (rcondv - tol)) {
+ result[17] = ulpinv;
+ } else if (*rcdvin + tolin < rcondv - tol) {
+ result[17] = (rcondv - tol) / (*rcdvin + tolin);
+ } else {
+ result[17] = 1.;
+ }
+
+L300:
+
+ ;
+ }
+
+
+ return 0;
+
+/* End of DGET24 */
+
+} /* dget24_ */
diff --git a/TESTING/EIG/dget31.c b/TESTING/EIG/dget31.c
new file mode 100644
index 0000000..2ca07c4
--- /dev/null
+++ b/TESTING/EIG/dget31.c
@@ -0,0 +1,586 @@
+/* dget31.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+
+/* Subroutine */ int dget31_(doublereal *rmax, integer *lmax, integer *ninfo,
+ integer *knt)
+{
+ /* Initialized data */
+
+ static logical ltrans[2] = { FALSE_,TRUE_ };
+
+ /* System generated locals */
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
+ d__11, d__12, d__13;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal a[4] /* was [2][2] */, b[4] /* was [2][2] */, x[4] /*
+ was [2][2] */, d1, d2, ca;
+ integer ia, ib, na;
+ doublereal wi;
+ integer nw;
+ doublereal wr;
+ integer id1, id2, ica;
+ doublereal den, vab[3], vca[5], vdd[4], eps;
+ integer iwi;
+ doublereal res, tmp;
+ integer iwr;
+ doublereal vwi[4], vwr[4];
+ integer info;
+ doublereal unfl, smin, scale;
+ integer ismin;
+ doublereal vsmin[4], xnorm;
+ extern /* Subroutine */ int dlaln2_(logical *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *
+, doublereal *, integer *, doublereal *, doublereal *, integer *),
+ dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ doublereal bignum;
+ integer itrans;
+ doublereal smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET31 tests DLALN2, a routine for solving */
+
+/* (ca A - w D)X = sB */
+
+/* where A is an NA by NA matrix (NA=1 or 2 only), w is a real (NW=1) or */
+/* complex (NW=2) constant, ca is a real constant, D is an NA by NA real */
+/* diagonal matrix, and B is an NA by NW matrix (when NW=2 the second */
+/* column of B contains the imaginary part of the solution). The code */
+/* returns X and s, where s is a scale factor, less than or equal to 1, */
+/* which is chosen to avoid overflow in X. */
+
+/* If any singular values of ca A-w D are less than another input */
+/* parameter SMIN, they are perturbed up to SMIN. */
+
+/* The test condition is that the scaled residual */
+
+/* norm( (ca A-w D)*X - s*B ) / */
+/* ( max( ulp*norm(ca A-w D), SMIN )*norm(X) ) */
+
+/* should be on the order of 1. Here, ulp is the machine precision. */
+/* Also, it is verified that SCALE is less than or equal to 1, and that */
+/* XNORM = infinity-norm(X). */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) DOUBLE PRECISION */
+/* Value of the largest test ratio. */
+
+/* LMAX (output) INTEGER */
+/* Example number where largest test ratio achieved. */
+
+/* NINFO (output) INTEGER array, dimension (3) */
+/* NINFO(1) = number of examples with INFO less than 0 */
+/* NINFO(2) = number of examples with INFO greater than 0 */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --ninfo;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Get machine parameters */
+
+ eps = dlamch_("P");
+ unfl = dlamch_("U");
+ smlnum = dlamch_("S") / eps;
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Set up test case parameters */
+
+ vsmin[0] = smlnum;
+ vsmin[1] = eps;
+ vsmin[2] = .01;
+ vsmin[3] = 1. / eps;
+ vab[0] = sqrt(smlnum);
+ vab[1] = 1.;
+ vab[2] = sqrt(bignum);
+ vwr[0] = 0.;
+ vwr[1] = .5;
+ vwr[2] = 2.;
+ vwr[3] = 1.;
+ vwi[0] = smlnum;
+ vwi[1] = eps;
+ vwi[2] = 1.;
+ vwi[3] = 2.;
+ vdd[0] = sqrt(smlnum);
+ vdd[1] = 1.;
+ vdd[2] = 2.;
+ vdd[3] = sqrt(bignum);
+ vca[0] = 0.;
+ vca[1] = sqrt(smlnum);
+ vca[2] = eps;
+ vca[3] = .5;
+ vca[4] = 1.;
+
+ *knt = 0;
+ ninfo[1] = 0;
+ ninfo[2] = 0;
+ *lmax = 0;
+ *rmax = 0.;
+
+/* Begin test loop */
+
+ for (id1 = 1; id1 <= 4; ++id1) {
+ d1 = vdd[id1 - 1];
+ for (id2 = 1; id2 <= 4; ++id2) {
+ d2 = vdd[id2 - 1];
+ for (ica = 1; ica <= 5; ++ica) {
+ ca = vca[ica - 1];
+ for (itrans = 0; itrans <= 1; ++itrans) {
+ for (ismin = 1; ismin <= 4; ++ismin) {
+ smin = vsmin[ismin - 1];
+
+ na = 1;
+ nw = 1;
+ for (ia = 1; ia <= 3; ++ia) {
+ a[0] = vab[ia - 1];
+ for (ib = 1; ib <= 3; ++ib) {
+ b[0] = vab[ib - 1];
+ for (iwr = 1; iwr <= 4; ++iwr) {
+ if (d1 == 1. && d2 == 1. && ca == 1.) {
+ wr = vwr[iwr - 1] * a[0];
+ } else {
+ wr = vwr[iwr - 1];
+ }
+ wi = 0.;
+ dlaln2_(<rans[itrans], &na, &nw, &smin,
+ &ca, a, &c__2, &d1, &d2, b, &c__2,
+ &wr, &wi, x, &c__2, &scale, &
+ xnorm, &info);
+ if (info < 0) {
+ ++ninfo[1];
+ }
+ if (info > 0) {
+ ++ninfo[2];
+ }
+ res = (d__1 = (ca * a[0] - wr * d1) * x[0]
+ - scale * b[0], abs(d__1));
+ if (info == 0) {
+/* Computing MAX */
+ d__2 = eps * (d__1 = (ca * a[0] - wr *
+ d1) * x[0], abs(d__1));
+ den = max(d__2,smlnum);
+ } else {
+/* Computing MAX */
+ d__1 = smin * abs(x[0]);
+ den = max(d__1,smlnum);
+ }
+ res /= den;
+ if (abs(x[0]) < unfl && abs(b[0]) <=
+ smlnum * (d__1 = ca * a[0] - wr *
+ d1, abs(d__1))) {
+ res = 0.;
+ }
+ if (scale > 1.) {
+ res += 1. / eps;
+ }
+ res += (d__1 = xnorm - abs(x[0]), abs(
+ d__1)) / max(smlnum,xnorm) / eps;
+ if (info != 0 && info != 1) {
+ res += 1. / eps;
+ }
+ ++(*knt);
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+/* L30: */
+ }
+
+ na = 1;
+ nw = 2;
+ for (ia = 1; ia <= 3; ++ia) {
+ a[0] = vab[ia - 1];
+ for (ib = 1; ib <= 3; ++ib) {
+ b[0] = vab[ib - 1];
+ b[2] = vab[ib - 1] * -.5;
+ for (iwr = 1; iwr <= 4; ++iwr) {
+ if (d1 == 1. && d2 == 1. && ca == 1.) {
+ wr = vwr[iwr - 1] * a[0];
+ } else {
+ wr = vwr[iwr - 1];
+ }
+ for (iwi = 1; iwi <= 4; ++iwi) {
+ if (d1 == 1. && d2 == 1. && ca == 1.)
+ {
+ wi = vwi[iwi - 1] * a[0];
+ } else {
+ wi = vwi[iwi - 1];
+ }
+ dlaln2_(<rans[itrans], &na, &nw, &
+ smin, &ca, a, &c__2, &d1, &d2,
+ b, &c__2, &wr, &wi, x, &c__2,
+ &scale, &xnorm, &info);
+ if (info < 0) {
+ ++ninfo[1];
+ }
+ if (info > 0) {
+ ++ninfo[2];
+ }
+ res = (d__1 = (ca * a[0] - wr * d1) *
+ x[0] + wi * d1 * x[2] - scale
+ * b[0], abs(d__1));
+ res += (d__1 = -wi * d1 * x[0] + (ca *
+ a[0] - wr * d1) * x[2] -
+ scale * b[2], abs(d__1));
+ if (info == 0) {
+/* Computing MAX */
+/* Computing MAX */
+ d__4 = (d__1 = ca * a[0] - wr *
+ d1, abs(d__1)), d__5 = (
+ d__2 = d1 * wi, abs(d__2))
+ ;
+ d__3 = eps * (max(d__4,d__5) * (
+ abs(x[0]) + abs(x[2])));
+ den = max(d__3,smlnum);
+ } else {
+/* Computing MAX */
+ d__1 = smin * (abs(x[0]) + abs(x[
+ 2]));
+ den = max(d__1,smlnum);
+ }
+ res /= den;
+ if (abs(x[0]) < unfl && abs(x[2]) <
+ unfl && abs(b[0]) <= smlnum *
+ (d__1 = ca * a[0] - wr * d1,
+ abs(d__1))) {
+ res = 0.;
+ }
+ if (scale > 1.) {
+ res += 1. / eps;
+ }
+ res += (d__1 = xnorm - abs(x[0]) -
+ abs(x[2]), abs(d__1)) / max(
+ smlnum,xnorm) / eps;
+ if (info != 0 && info != 1) {
+ res += 1. / eps;
+ }
+ ++(*knt);
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+ na = 2;
+ nw = 1;
+ for (ia = 1; ia <= 3; ++ia) {
+ a[0] = vab[ia - 1];
+ a[2] = vab[ia - 1] * -3.;
+ a[1] = vab[ia - 1] * -7.;
+ a[3] = vab[ia - 1] * 21.;
+ for (ib = 1; ib <= 3; ++ib) {
+ b[0] = vab[ib - 1];
+ b[1] = vab[ib - 1] * -2.;
+ for (iwr = 1; iwr <= 4; ++iwr) {
+ if (d1 == 1. && d2 == 1. && ca == 1.) {
+ wr = vwr[iwr - 1] * a[0];
+ } else {
+ wr = vwr[iwr - 1];
+ }
+ wi = 0.;
+ dlaln2_(<rans[itrans], &na, &nw, &smin,
+ &ca, a, &c__2, &d1, &d2, b, &c__2,
+ &wr, &wi, x, &c__2, &scale, &
+ xnorm, &info);
+ if (info < 0) {
+ ++ninfo[1];
+ }
+ if (info > 0) {
+ ++ninfo[2];
+ }
+ if (itrans == 1) {
+ tmp = a[2];
+ a[2] = a[1];
+ a[1] = tmp;
+ }
+ res = (d__1 = (ca * a[0] - wr * d1) * x[0]
+ + ca * a[2] * x[1] - scale * b[0]
+ , abs(d__1));
+ res += (d__1 = ca * a[1] * x[0] + (ca * a[
+ 3] - wr * d2) * x[1] - scale * b[
+ 1], abs(d__1));
+ if (info == 0) {
+/* Computing MAX */
+/* Computing MAX */
+ d__6 = (d__1 = ca * a[0] - wr * d1,
+ abs(d__1)) + (d__2 = ca * a[2]
+ , abs(d__2)), d__7 = (d__3 =
+ ca * a[1], abs(d__3)) + (d__4
+ = ca * a[3] - wr * d2, abs(
+ d__4));
+/* Computing MAX */
+ d__8 = abs(x[0]), d__9 = abs(x[1]);
+ d__5 = eps * (max(d__6,d__7) * max(
+ d__8,d__9));
+ den = max(d__5,smlnum);
+ } else {
+/* Computing MAX */
+/* Computing MAX */
+/* Computing MAX */
+ d__8 = (d__1 = ca * a[0] - wr * d1,
+ abs(d__1)) + (d__2 = ca * a[2]
+ , abs(d__2)), d__9 = (d__3 =
+ ca * a[1], abs(d__3)) + (d__4
+ = ca * a[3] - wr * d2, abs(
+ d__4));
+ d__6 = smin / eps, d__7 = max(d__8,
+ d__9);
+/* Computing MAX */
+ d__10 = abs(x[0]), d__11 = abs(x[1]);
+ d__5 = eps * (max(d__6,d__7) * max(
+ d__10,d__11));
+ den = max(d__5,smlnum);
+ }
+ res /= den;
+ if (abs(x[0]) < unfl && abs(x[1]) < unfl
+ && abs(b[0]) + abs(b[1]) <=
+ smlnum * ((d__1 = ca * a[0] - wr *
+ d1, abs(d__1)) + (d__2 = ca * a[
+ 2], abs(d__2)) + (d__3 = ca * a[1]
+ , abs(d__3)) + (d__4 = ca * a[3]
+ - wr * d2, abs(d__4)))) {
+ res = 0.;
+ }
+ if (scale > 1.) {
+ res += 1. / eps;
+ }
+/* Computing MAX */
+ d__2 = abs(x[0]), d__3 = abs(x[1]);
+ res += (d__1 = xnorm - max(d__2,d__3),
+ abs(d__1)) / max(smlnum,xnorm) /
+ eps;
+ if (info != 0 && info != 1) {
+ res += 1. / eps;
+ }
+ ++(*knt);
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+
+ na = 2;
+ nw = 2;
+ for (ia = 1; ia <= 3; ++ia) {
+ a[0] = vab[ia - 1] * 2.;
+ a[2] = vab[ia - 1] * -3.;
+ a[1] = vab[ia - 1] * -7.;
+ a[3] = vab[ia - 1] * 21.;
+ for (ib = 1; ib <= 3; ++ib) {
+ b[0] = vab[ib - 1];
+ b[1] = vab[ib - 1] * -2.;
+ b[2] = vab[ib - 1] * 4.;
+ b[3] = vab[ib - 1] * -7.;
+ for (iwr = 1; iwr <= 4; ++iwr) {
+ if (d1 == 1. && d2 == 1. && ca == 1.) {
+ wr = vwr[iwr - 1] * a[0];
+ } else {
+ wr = vwr[iwr - 1];
+ }
+ for (iwi = 1; iwi <= 4; ++iwi) {
+ if (d1 == 1. && d2 == 1. && ca == 1.)
+ {
+ wi = vwi[iwi - 1] * a[0];
+ } else {
+ wi = vwi[iwi - 1];
+ }
+ dlaln2_(<rans[itrans], &na, &nw, &
+ smin, &ca, a, &c__2, &d1, &d2,
+ b, &c__2, &wr, &wi, x, &c__2,
+ &scale, &xnorm, &info);
+ if (info < 0) {
+ ++ninfo[1];
+ }
+ if (info > 0) {
+ ++ninfo[2];
+ }
+ if (itrans == 1) {
+ tmp = a[2];
+ a[2] = a[1];
+ a[1] = tmp;
+ }
+ res = (d__1 = (ca * a[0] - wr * d1) *
+ x[0] + ca * a[2] * x[1] + wi *
+ d1 * x[2] - scale * b[0],
+ abs(d__1));
+ res += (d__1 = (ca * a[0] - wr * d1) *
+ x[2] + ca * a[2] * x[3] - wi
+ * d1 * x[0] - scale * b[2],
+ abs(d__1));
+ res += (d__1 = ca * a[1] * x[0] + (ca
+ * a[3] - wr * d2) * x[1] + wi
+ * d2 * x[3] - scale * b[1],
+ abs(d__1));
+ res += (d__1 = ca * a[1] * x[2] + (ca
+ * a[3] - wr * d2) * x[3] - wi
+ * d2 * x[1] - scale * b[3],
+ abs(d__1));
+ if (info == 0) {
+/* Computing MAX */
+/* Computing MAX */
+ d__8 = (d__1 = ca * a[0] - wr *
+ d1, abs(d__1)) + (d__2 =
+ ca * a[2], abs(d__2)) + (
+ d__3 = wi * d1, abs(d__3))
+ , d__9 = (d__4 = ca * a[1]
+ , abs(d__4)) + (d__5 = ca
+ * a[3] - wr * d2, abs(
+ d__5)) + (d__6 = wi * d2,
+ abs(d__6));
+/* Computing MAX */
+ d__10 = abs(x[0]) + abs(x[1]),
+ d__11 = abs(x[2]) + abs(x[
+ 3]);
+ d__7 = eps * (max(d__8,d__9) *
+ max(d__10,d__11));
+ den = max(d__7,smlnum);
+ } else {
+/* Computing MAX */
+/* Computing MAX */
+/* Computing MAX */
+ d__10 = (d__1 = ca * a[0] - wr *
+ d1, abs(d__1)) + (d__2 =
+ ca * a[2], abs(d__2)) + (
+ d__3 = wi * d1, abs(d__3))
+ , d__11 = (d__4 = ca * a[
+ 1], abs(d__4)) + (d__5 =
+ ca * a[3] - wr * d2, abs(
+ d__5)) + (d__6 = wi * d2,
+ abs(d__6));
+ d__8 = smin / eps, d__9 = max(
+ d__10,d__11);
+/* Computing MAX */
+ d__12 = abs(x[0]) + abs(x[1]),
+ d__13 = abs(x[2]) + abs(x[
+ 3]);
+ d__7 = eps * (max(d__8,d__9) *
+ max(d__12,d__13));
+ den = max(d__7,smlnum);
+ }
+ res /= den;
+ if (abs(x[0]) < unfl && abs(x[1]) <
+ unfl && abs(x[2]) < unfl &&
+ abs(x[3]) < unfl && abs(b[0])
+ + abs(b[1]) <= smlnum * ((
+ d__1 = ca * a[0] - wr * d1,
+ abs(d__1)) + (d__2 = ca * a[2]
+ , abs(d__2)) + (d__3 = ca * a[
+ 1], abs(d__3)) + (d__4 = ca *
+ a[3] - wr * d2, abs(d__4)) + (
+ d__5 = wi * d2, abs(d__5)) + (
+ d__6 = wi * d1, abs(d__6)))) {
+ res = 0.;
+ }
+ if (scale > 1.) {
+ res += 1. / eps;
+ }
+/* Computing MAX */
+ d__2 = abs(x[0]) + abs(x[2]), d__3 =
+ abs(x[1]) + abs(x[3]);
+ res += (d__1 = xnorm - max(d__2,d__3),
+ abs(d__1)) / max(smlnum,
+ xnorm) / eps;
+ if (info != 0 && info != 1) {
+ res += 1. / eps;
+ }
+ ++(*knt);
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+/* L190: */
+ }
+
+ return 0;
+
+/* End of DGET31 */
+
+} /* dget31_ */
diff --git a/TESTING/EIG/dget32.c b/TESTING/EIG/dget32.c
new file mode 100644
index 0000000..4d86738
--- /dev/null
+++ b/TESTING/EIG/dget32.c
@@ -0,0 +1,448 @@
+/* dget32.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+
+/* Subroutine */ int dget32_(doublereal *rmax, integer *lmax, integer *ninfo,
+ integer *knt)
+{
+ /* Initialized data */
+
+ static integer itval[32] /* was [2][2][8] */ = { 8,4,2,1,4,8,1,2,2,1,8,
+ 4,1,2,4,8,9,4,2,1,4,9,1,2,2,1,9,4,1,2,4,9 };
+
+ /* System generated locals */
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal b[4] /* was [2][2] */, x[4] /* was [2][2] */;
+ integer n1, n2, ib;
+ doublereal tl[4] /* was [2][2] */, tr[4] /* was [2][2] */;
+ integer ib1, ib2, ib3;
+ doublereal den, val[3], eps;
+ integer itl;
+ doublereal res, sgn;
+ integer itr;
+ doublereal tmp;
+ integer info, isgn;
+ doublereal tnrm, xnrm, scale, xnorm;
+ extern /* Subroutine */ int dlasy2_(logical *, logical *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *), dlabad_(doublereal *,
+ doublereal *);
+ extern doublereal dlamch_(char *);
+ doublereal bignum;
+ integer itranl, itlscl;
+ logical ltranl;
+ integer itranr, itrscl;
+ logical ltranr;
+ doublereal smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET32 tests DLASY2, a routine for solving */
+
+/* op(TL)*X + ISGN*X*op(TR) = SCALE*B */
+
+/* where TL is N1 by N1, TR is N2 by N2, and N1,N2 =1 or 2 only. */
+/* X and B are N1 by N2, op() is an optional transpose, an */
+/* ISGN = 1 or -1. SCALE is chosen less than or equal to 1 to */
+/* avoid overflow in X. */
+
+/* The test condition is that the scaled residual */
+
+/* norm( op(TL)*X + ISGN*X*op(TR) = SCALE*B ) */
+/* / ( max( ulp*norm(TL), ulp*norm(TR)) * norm(X), SMLNUM ) */
+
+/* should be on the order of 1. Here, ulp is the machine precision. */
+/* Also, it is verified that SCALE is less than or equal to 1, and */
+/* that XNORM = infinity-norm(X). */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) DOUBLE PRECISION */
+/* Value of the largest test ratio. */
+
+/* LMAX (output) INTEGER */
+/* Example number where largest test ratio achieved. */
+
+/* NINFO (output) INTEGER */
+/* Number of examples returned with INFO.NE.0. */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Get machine parameters */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S") / eps;
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Set up test case parameters */
+
+ val[0] = sqrt(smlnum);
+ val[1] = 1.;
+ val[2] = sqrt(bignum);
+
+ *knt = 0;
+ *ninfo = 0;
+ *lmax = 0;
+ *rmax = 0.;
+
+/* Begin test loop */
+
+ for (itranl = 0; itranl <= 1; ++itranl) {
+ for (itranr = 0; itranr <= 1; ++itranr) {
+ for (isgn = -1; isgn <= 1; isgn += 2) {
+ sgn = (doublereal) isgn;
+ ltranl = itranl == 1;
+ ltranr = itranr == 1;
+
+ n1 = 1;
+ n2 = 1;
+ for (itl = 1; itl <= 3; ++itl) {
+ for (itr = 1; itr <= 3; ++itr) {
+ for (ib = 1; ib <= 3; ++ib) {
+ tl[0] = val[itl - 1];
+ tr[0] = val[itr - 1];
+ b[0] = val[ib - 1];
+ ++(*knt);
+ dlasy2_(<ranl, <ranr, &isgn, &n1, &n2, tl, &
+ c__2, tr, &c__2, b, &c__2, &scale, x, &
+ c__2, &xnorm, &info);
+ if (info != 0) {
+ ++(*ninfo);
+ }
+ res = (d__1 = (tl[0] + sgn * tr[0]) * x[0] -
+ scale * b[0], abs(d__1));
+ if (info == 0) {
+/* Computing MAX */
+ d__1 = eps * ((abs(tr[0]) + abs(tl[0])) * abs(
+ x[0]));
+ den = max(d__1,smlnum);
+ } else {
+/* Computing MAX */
+ d__1 = abs(x[0]);
+ den = smlnum * max(d__1,1.);
+ }
+ res /= den;
+ if (scale > 1.) {
+ res += 1. / eps;
+ }
+ res += (d__1 = xnorm - abs(x[0]), abs(d__1)) /
+ max(smlnum,xnorm) / eps;
+ if (info != 0 && info != 1) {
+ res += 1. / eps;
+ }
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+/* L30: */
+ }
+
+ n1 = 2;
+ n2 = 1;
+ for (itl = 1; itl <= 8; ++itl) {
+ for (itlscl = 1; itlscl <= 3; ++itlscl) {
+ for (itr = 1; itr <= 3; ++itr) {
+ for (ib1 = 1; ib1 <= 3; ++ib1) {
+ for (ib2 = 1; ib2 <= 3; ++ib2) {
+ b[0] = val[ib1 - 1];
+ b[1] = val[ib2 - 1] * -4.;
+ tl[0] = itval[((itl << 1) + 1 << 1) - 6] *
+ val[itlscl - 1];
+ tl[1] = itval[((itl << 1) + 1 << 1) - 5] *
+ val[itlscl - 1];
+ tl[2] = itval[((itl << 1) + 2 << 1) - 6] *
+ val[itlscl - 1];
+ tl[3] = itval[((itl << 1) + 2 << 1) - 5] *
+ val[itlscl - 1];
+ tr[0] = val[itr - 1];
+ ++(*knt);
+ dlasy2_(<ranl, <ranr, &isgn, &n1, &n2,
+ tl, &c__2, tr, &c__2, b, &c__2, &
+ scale, x, &c__2, &xnorm, &info);
+ if (info != 0) {
+ ++(*ninfo);
+ }
+ if (ltranl) {
+ tmp = tl[2];
+ tl[2] = tl[1];
+ tl[1] = tmp;
+ }
+ res = (d__1 = (tl[0] + sgn * tr[0]) * x[0]
+ + tl[2] * x[1] - scale * b[0],
+ abs(d__1));
+ res += (d__1 = (tl[3] + sgn * tr[0]) * x[
+ 1] + tl[1] * x[0] - scale * b[1],
+ abs(d__1));
+ tnrm = abs(tr[0]) + abs(tl[0]) + abs(tl[2]
+ ) + abs(tl[1]) + abs(tl[3]);
+/* Computing MAX */
+ d__1 = abs(x[0]), d__2 = abs(x[1]);
+ xnrm = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = smlnum, d__2 = smlnum * xnrm, d__1
+ = max(d__1,d__2), d__2 = tnrm *
+ eps * xnrm;
+ den = max(d__1,d__2);
+ res /= den;
+ if (scale > 1.) {
+ res += 1. / eps;
+ }
+ res += (d__1 = xnorm - xnrm, abs(d__1)) /
+ max(smlnum,xnorm) / eps;
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+
+ n1 = 1;
+ n2 = 2;
+ for (itr = 1; itr <= 8; ++itr) {
+ for (itrscl = 1; itrscl <= 3; ++itrscl) {
+ for (itl = 1; itl <= 3; ++itl) {
+ for (ib1 = 1; ib1 <= 3; ++ib1) {
+ for (ib2 = 1; ib2 <= 3; ++ib2) {
+ b[0] = val[ib1 - 1];
+ b[2] = val[ib2 - 1] * -2.;
+ tr[0] = itval[((itr << 1) + 1 << 1) - 6] *
+ val[itrscl - 1];
+ tr[1] = itval[((itr << 1) + 1 << 1) - 5] *
+ val[itrscl - 1];
+ tr[2] = itval[((itr << 1) + 2 << 1) - 6] *
+ val[itrscl - 1];
+ tr[3] = itval[((itr << 1) + 2 << 1) - 5] *
+ val[itrscl - 1];
+ tl[0] = val[itl - 1];
+ ++(*knt);
+ dlasy2_(<ranl, <ranr, &isgn, &n1, &n2,
+ tl, &c__2, tr, &c__2, b, &c__2, &
+ scale, x, &c__2, &xnorm, &info);
+ if (info != 0) {
+ ++(*ninfo);
+ }
+ if (ltranr) {
+ tmp = tr[2];
+ tr[2] = tr[1];
+ tr[1] = tmp;
+ }
+ tnrm = abs(tl[0]) + abs(tr[0]) + abs(tr[2]
+ ) + abs(tr[3]) + abs(tr[1]);
+ xnrm = abs(x[0]) + abs(x[2]);
+ res = (d__1 = (tl[0] + sgn * tr[0]) * x[0]
+ + sgn * tr[1] * x[2] - scale * b[
+ 0], abs(d__1));
+ res += (d__1 = (tl[0] + sgn * tr[3]) * x[
+ 2] + sgn * tr[2] * x[0] - scale *
+ b[2], abs(d__1));
+/* Computing MAX */
+ d__1 = smlnum, d__2 = smlnum * xnrm, d__1
+ = max(d__1,d__2), d__2 = tnrm *
+ eps * xnrm;
+ den = max(d__1,d__2);
+ res /= den;
+ if (scale > 1.) {
+ res += 1. / eps;
+ }
+ res += (d__1 = xnorm - xnrm, abs(d__1)) /
+ max(smlnum,xnorm) / eps;
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+
+ n1 = 2;
+ n2 = 2;
+ for (itr = 1; itr <= 8; ++itr) {
+ for (itrscl = 1; itrscl <= 3; ++itrscl) {
+ for (itl = 1; itl <= 8; ++itl) {
+ for (itlscl = 1; itlscl <= 3; ++itlscl) {
+ for (ib1 = 1; ib1 <= 3; ++ib1) {
+ for (ib2 = 1; ib2 <= 3; ++ib2) {
+ for (ib3 = 1; ib3 <= 3; ++ib3) {
+ b[0] = val[ib1 - 1];
+ b[1] = val[ib2 - 1] * -4.;
+ b[2] = val[ib3 - 1] * -2.;
+/* Computing MIN */
+ d__1 = val[ib1 - 1], d__2 = val[
+ ib2 - 1], d__1 = min(d__1,
+ d__2), d__2 = val[ib3 - 1]
+ ;
+ b[3] = min(d__1,d__2) * 8.;
+ tr[0] = itval[((itr << 1) + 1 <<
+ 1) - 6] * val[itrscl - 1];
+ tr[1] = itval[((itr << 1) + 1 <<
+ 1) - 5] * val[itrscl - 1];
+ tr[2] = itval[((itr << 1) + 2 <<
+ 1) - 6] * val[itrscl - 1];
+ tr[3] = itval[((itr << 1) + 2 <<
+ 1) - 5] * val[itrscl - 1];
+ tl[0] = itval[((itl << 1) + 1 <<
+ 1) - 6] * val[itlscl - 1];
+ tl[1] = itval[((itl << 1) + 1 <<
+ 1) - 5] * val[itlscl - 1];
+ tl[2] = itval[((itl << 1) + 2 <<
+ 1) - 6] * val[itlscl - 1];
+ tl[3] = itval[((itl << 1) + 2 <<
+ 1) - 5] * val[itlscl - 1];
+ ++(*knt);
+ dlasy2_(<ranl, <ranr, &isgn, &
+ n1, &n2, tl, &c__2, tr, &
+ c__2, b, &c__2, &scale, x,
+ &c__2, &xnorm, &info);
+ if (info != 0) {
+ ++(*ninfo);
+ }
+ if (ltranr) {
+ tmp = tr[2];
+ tr[2] = tr[1];
+ tr[1] = tmp;
+ }
+ if (ltranl) {
+ tmp = tl[2];
+ tl[2] = tl[1];
+ tl[1] = tmp;
+ }
+ tnrm = abs(tr[0]) + abs(tr[1]) +
+ abs(tr[2]) + abs(tr[3]) +
+ abs(tl[0]) + abs(tl[1]) +
+ abs(tl[2]) + abs(tl[3]);
+/* Computing MAX */
+ d__1 = abs(x[0]) + abs(x[2]),
+ d__2 = abs(x[1]) + abs(x[
+ 3]);
+ xnrm = max(d__1,d__2);
+ res = (d__1 = (tl[0] + sgn * tr[0]
+ ) * x[0] + sgn * tr[1] *
+ x[2] + tl[2] * x[1] -
+ scale * b[0], abs(d__1));
+ res += (d__1 = tl[0] * x[2] + sgn
+ * tr[2] * x[0] + sgn * tr[
+ 3] * x[2] + tl[2] * x[3]
+ - scale * b[2], abs(d__1))
+ ;
+ res += (d__1 = tl[1] * x[0] + sgn
+ * tr[0] * x[1] + sgn * tr[
+ 1] * x[3] + tl[3] * x[1]
+ - scale * b[1], abs(d__1))
+ ;
+ res += (d__1 = (tl[3] + sgn * tr[
+ 3]) * x[3] + sgn * tr[2] *
+ x[1] + tl[1] * x[2] -
+ scale * b[3], abs(d__1));
+/* Computing MAX */
+ d__1 = smlnum, d__2 = smlnum *
+ xnrm, d__1 = max(d__1,
+ d__2), d__2 = tnrm * eps *
+ xnrm;
+ den = max(d__1,d__2);
+ res /= den;
+ if (scale > 1.) {
+ res += 1. / eps;
+ }
+ res += (d__1 = xnorm - xnrm, abs(
+ d__1)) / max(smlnum,xnorm)
+ / eps;
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+/* L190: */
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+/* L220: */
+ }
+/* L230: */
+ }
+
+ return 0;
+
+/* End of DGET32 */
+
+} /* dget32_ */
diff --git a/TESTING/EIG/dget33.c b/TESTING/EIG/dget33.c
new file mode 100644
index 0000000..0faf822
--- /dev/null
+++ b/TESTING/EIG/dget33.c
@@ -0,0 +1,229 @@
+/* dget33.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b19 = 1.;
+
+/* Subroutine */ int dget33_(doublereal *rmax, integer *lmax, integer *ninfo,
+ integer *knt)
+{
+ /* System generated locals */
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ doublereal q[4] /* was [2][2] */, t[4] /* was [2][2] */;
+ integer i1, i2, i3, i4, j1, j2, j3;
+ doublereal t1[4] /* was [2][2] */, t2[4] /* was [2][2] */, cs, sn, vm[
+ 3];
+ integer im1, im2, im3, im4;
+ doublereal wi1, wi2, wr1, wr2, val[4], eps, res, sum, tnrm;
+ extern /* Subroutine */ int dlanv2_(doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *), dlabad_(
+ doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ doublereal bignum, smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET33 tests DLANV2, a routine for putting 2 by 2 blocks into */
+/* standard form. In other words, it computes a two by two rotation */
+/* [[C,S];[-S,C]] where in */
+
+/* [ C S ][T(1,1) T(1,2)][ C -S ] = [ T11 T12 ] */
+/* [-S C ][T(2,1) T(2,2)][ S C ] [ T21 T22 ] */
+
+/* either */
+/* 1) T21=0 (real eigenvalues), or */
+/* 2) T11=T22 and T21*T12<0 (complex conjugate eigenvalues). */
+/* We also verify that the residual is small. */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) DOUBLE PRECISION */
+/* Value of the largest test ratio. */
+
+/* LMAX (output) INTEGER */
+/* Example number where largest test ratio achieved. */
+
+/* NINFO (output) INTEGER */
+/* Number of examples returned with INFO .NE. 0. */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Get machine parameters */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S") / eps;
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Set up test case parameters */
+
+ val[0] = 1.;
+ val[1] = eps * 2. + 1.;
+ val[2] = 2.;
+ val[3] = 2. - eps * 4.;
+ vm[0] = smlnum;
+ vm[1] = 1.;
+ vm[2] = bignum;
+
+ *knt = 0;
+ *ninfo = 0;
+ *lmax = 0;
+ *rmax = 0.;
+
+/* Begin test loop */
+
+ for (i1 = 1; i1 <= 4; ++i1) {
+ for (i2 = 1; i2 <= 4; ++i2) {
+ for (i3 = 1; i3 <= 4; ++i3) {
+ for (i4 = 1; i4 <= 4; ++i4) {
+ for (im1 = 1; im1 <= 3; ++im1) {
+ for (im2 = 1; im2 <= 3; ++im2) {
+ for (im3 = 1; im3 <= 3; ++im3) {
+ for (im4 = 1; im4 <= 3; ++im4) {
+ t[0] = val[i1 - 1] * vm[im1 - 1];
+ t[2] = val[i2 - 1] * vm[im2 - 1];
+ t[1] = -val[i3 - 1] * vm[im3 - 1];
+ t[3] = val[i4 - 1] * vm[im4 - 1];
+/* Computing MAX */
+ d__1 = abs(t[0]), d__2 = abs(t[2]), d__1 =
+ max(d__1,d__2), d__2 = abs(t[1]),
+ d__1 = max(d__1,d__2), d__2 =
+ abs(t[3]);
+ tnrm = max(d__1,d__2);
+ t1[0] = t[0];
+ t1[2] = t[2];
+ t1[1] = t[1];
+ t1[3] = t[3];
+ q[0] = 1.;
+ q[2] = 0.;
+ q[1] = 0.;
+ q[3] = 1.;
+
+ dlanv2_(t, &t[2], &t[1], &t[3], &wr1, &
+ wi1, &wr2, &wi2, &cs, &sn);
+ for (j1 = 1; j1 <= 2; ++j1) {
+ res = q[j1 - 1] * cs + q[j1 + 1] * sn;
+ q[j1 + 1] = -q[j1 - 1] * sn + q[j1 +
+ 1] * cs;
+ q[j1 - 1] = res;
+/* L10: */
+ }
+
+ res = 0.;
+/* Computing 2nd power */
+ d__2 = q[0];
+/* Computing 2nd power */
+ d__3 = q[2];
+ res += (d__1 = d__2 * d__2 + d__3 * d__3
+ - 1., abs(d__1)) / eps;
+/* Computing 2nd power */
+ d__2 = q[3];
+/* Computing 2nd power */
+ d__3 = q[1];
+ res += (d__1 = d__2 * d__2 + d__3 * d__3
+ - 1., abs(d__1)) / eps;
+ res += (d__1 = q[0] * q[1] + q[2] * q[3],
+ abs(d__1)) / eps;
+ for (j1 = 1; j1 <= 2; ++j1) {
+ for (j2 = 1; j2 <= 2; ++j2) {
+ t2[j1 + (j2 << 1) - 3] = 0.;
+ for (j3 = 1; j3 <= 2; ++j3) {
+ t2[j1 + (j2 << 1) - 3] += t1[j1 + (j3 << 1) - 3] *
+ q[j3 + (j2 << 1) - 3];
+/* L20: */
+ }
+/* L30: */
+ }
+/* L40: */
+ }
+ for (j1 = 1; j1 <= 2; ++j1) {
+ for (j2 = 1; j2 <= 2; ++j2) {
+ sum = t[j1 + (j2 << 1) - 3];
+ for (j3 = 1; j3 <= 2; ++j3) {
+ sum -= q[j3 + (j1 << 1) - 3] * t2[j3 + (j2 << 1) -
+ 3];
+/* L50: */
+ }
+ res += abs(sum) / eps / tnrm;
+/* L60: */
+ }
+/* L70: */
+ }
+ if (t[1] != 0. && (t[0] != t[3] || d_sign(
+ &c_b19, &t[2]) * d_sign(&c_b19, &
+ t[1]) > 0.)) {
+ res += 1. / eps;
+ }
+ ++(*knt);
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+ return 0;
+
+/* End of DGET33 */
+
+} /* dget33_ */
diff --git a/TESTING/EIG/dget34.c b/TESTING/EIG/dget34.c
new file mode 100644
index 0000000..090c238
--- /dev/null
+++ b/TESTING/EIG/dget34.c
@@ -0,0 +1,461 @@
+/* dget34.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__16 = 16;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c__5 = 5;
+static logical c_true = TRUE_;
+static integer c__2 = 2;
+static integer c__32 = 32;
+static integer c__3 = 3;
+static doublereal c_b64 = 1.;
+
+/* Subroutine */ int dget34_(doublereal *rmax, integer *lmax, integer *ninfo,
+ integer *knt)
+{
+ /* System generated locals */
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal q[16] /* was [4][4] */, t[16] /* was [4][4] */, t1[16]
+ /* was [4][4] */;
+ integer ia, ib, ic;
+ doublereal vm[2];
+ integer ia11, ia12, ia21, ia22, ic11, ic12, ic21, ic22, iam, icm;
+ doublereal val[9], eps, res;
+ integer info;
+ doublereal tnrm, work[32];
+ extern /* Subroutine */ int dhst01_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *), dcopy_(integer
+ *, doublereal *, integer *, doublereal *, integer *), dlabad_(
+ doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlaexc_(logical *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, integer *, integer
+ *, doublereal *, integer *);
+ doublereal bignum, smlnum, result[2];
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET34 tests DLAEXC, a routine for swapping adjacent blocks (either */
+/* 1 by 1 or 2 by 2) on the diagonal of a matrix in real Schur form. */
+/* Thus, DLAEXC computes an orthogonal matrix Q such that */
+
+/* Q' * [ A B ] * Q = [ C1 B1 ] */
+/* [ 0 C ] [ 0 A1 ] */
+
+/* where C1 is similar to C and A1 is similar to A. Both A and C are */
+/* assumed to be in standard form (equal diagonal entries and */
+/* offdiagonal with differing signs) and A1 and C1 are returned with the */
+/* same properties. */
+
+/* The test code verifies these last last assertions, as well as that */
+/* the residual in the above equation is small. */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) DOUBLE PRECISION */
+/* Value of the largest test ratio. */
+
+/* LMAX (output) INTEGER */
+/* Example number where largest test ratio achieved. */
+
+/* NINFO (output) INTEGER array, dimension (2) */
+/* NINFO(J) is the number of examples where INFO=J occurred. */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Get machine parameters */
+
+ /* Parameter adjustments */
+ --ninfo;
+
+ /* Function Body */
+ eps = dlamch_("P");
+ smlnum = dlamch_("S") / eps;
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Set up test case parameters */
+
+ val[0] = 0.;
+ val[1] = sqrt(smlnum);
+ val[2] = 1.;
+ val[3] = 2.;
+ val[4] = sqrt(bignum);
+ val[5] = -sqrt(smlnum);
+ val[6] = -1.;
+ val[7] = -2.;
+ val[8] = -sqrt(bignum);
+ vm[0] = 1.;
+ vm[1] = eps * 2. + 1.;
+ dcopy_(&c__16, &val[3], &c__0, t, &c__1);
+
+ ninfo[1] = 0;
+ ninfo[2] = 0;
+ *knt = 0;
+ *lmax = 0;
+ *rmax = 0.;
+
+/* Begin test loop */
+
+ for (ia = 1; ia <= 9; ++ia) {
+ for (iam = 1; iam <= 2; ++iam) {
+ for (ib = 1; ib <= 9; ++ib) {
+ for (ic = 1; ic <= 9; ++ic) {
+ t[0] = val[ia - 1] * vm[iam - 1];
+ t[5] = val[ic - 1];
+ t[4] = val[ib - 1];
+ t[1] = 0.;
+/* Computing MAX */
+ d__1 = abs(t[0]), d__2 = abs(t[5]), d__1 = max(d__1,d__2),
+ d__2 = abs(t[4]);
+ tnrm = max(d__1,d__2);
+ dcopy_(&c__16, t, &c__1, t1, &c__1);
+ dcopy_(&c__16, val, &c__0, q, &c__1);
+ dcopy_(&c__4, &val[2], &c__0, q, &c__5);
+ dlaexc_(&c_true, &c__2, t, &c__4, q, &c__4, &c__1, &c__1,
+ &c__1, work, &info);
+ if (info != 0) {
+ ++ninfo[info];
+ }
+ dhst01_(&c__2, &c__1, &c__2, t1, &c__4, t, &c__4, q, &
+ c__4, work, &c__32, result);
+ res = result[0] + result[1];
+ if (info != 0) {
+ res += 1. / eps;
+ }
+ if (t[0] != t1[5]) {
+ res += 1. / eps;
+ }
+ if (t[5] != t1[0]) {
+ res += 1. / eps;
+ }
+ if (t[1] != 0.) {
+ res += 1. / eps;
+ }
+ ++(*knt);
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+/* L30: */
+ }
+/* L40: */
+ }
+
+ for (ia = 1; ia <= 5; ++ia) {
+ for (iam = 1; iam <= 2; ++iam) {
+ for (ib = 1; ib <= 5; ++ib) {
+ for (ic11 = 1; ic11 <= 5; ++ic11) {
+ for (ic12 = 2; ic12 <= 5; ++ic12) {
+ for (ic21 = 2; ic21 <= 4; ++ic21) {
+ for (ic22 = -1; ic22 <= 1; ic22 += 2) {
+ t[0] = val[ia - 1] * vm[iam - 1];
+ t[4] = val[ib - 1];
+ t[8] = val[ib - 1] * -2.;
+ t[1] = 0.;
+ t[5] = val[ic11 - 1];
+ t[9] = val[ic12 - 1];
+ t[2] = 0.;
+ t[6] = -val[ic21 - 1];
+ t[10] = val[ic11 - 1] * (doublereal) ic22;
+/* Computing MAX */
+ d__1 = abs(t[0]), d__2 = abs(t[4]), d__1 =
+ max(d__1,d__2), d__2 = abs(t[8]),
+ d__1 = max(d__1,d__2), d__2 = abs(t[5]
+ ), d__1 = max(d__1,d__2), d__2 = abs(
+ t[9]), d__1 = max(d__1,d__2), d__2 =
+ abs(t[6]), d__1 = max(d__1,d__2),
+ d__2 = abs(t[10]);
+ tnrm = max(d__1,d__2);
+ dcopy_(&c__16, t, &c__1, t1, &c__1);
+ dcopy_(&c__16, val, &c__0, q, &c__1);
+ dcopy_(&c__4, &val[2], &c__0, q, &c__5);
+ dlaexc_(&c_true, &c__3, t, &c__4, q, &c__4, &
+ c__1, &c__1, &c__2, work, &info);
+ if (info != 0) {
+ ++ninfo[info];
+ }
+ dhst01_(&c__3, &c__1, &c__3, t1, &c__4, t, &
+ c__4, q, &c__4, work, &c__32, result);
+ res = result[0] + result[1];
+ if (info == 0) {
+ if (t1[0] != t[10]) {
+ res += 1. / eps;
+ }
+ if (t[2] != 0.) {
+ res += 1. / eps;
+ }
+ if (t[6] != 0.) {
+ res += 1. / eps;
+ }
+ if (t[1] != 0. && (t[0] != t[5] || d_sign(
+ &c_b64, &t[4]) == d_sign(&c_b64, &
+ t[1]))) {
+ res += 1. / eps;
+ }
+ }
+ ++(*knt);
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+
+ for (ia11 = 1; ia11 <= 5; ++ia11) {
+ for (ia12 = 2; ia12 <= 5; ++ia12) {
+ for (ia21 = 2; ia21 <= 4; ++ia21) {
+ for (ia22 = -1; ia22 <= 1; ia22 += 2) {
+ for (icm = 1; icm <= 2; ++icm) {
+ for (ib = 1; ib <= 5; ++ib) {
+ for (ic = 1; ic <= 5; ++ic) {
+ t[0] = val[ia11 - 1];
+ t[4] = val[ia12 - 1];
+ t[8] = val[ib - 1] * -2.;
+ t[1] = -val[ia21 - 1];
+ t[5] = val[ia11 - 1] * (doublereal) ia22;
+ t[9] = val[ib - 1];
+ t[2] = 0.;
+ t[6] = 0.;
+ t[10] = val[ic - 1] * vm[icm - 1];
+/* Computing MAX */
+ d__1 = abs(t[0]), d__2 = abs(t[4]), d__1 =
+ max(d__1,d__2), d__2 = abs(t[8]),
+ d__1 = max(d__1,d__2), d__2 = abs(t[5]
+ ), d__1 = max(d__1,d__2), d__2 = abs(
+ t[9]), d__1 = max(d__1,d__2), d__2 =
+ abs(t[6]), d__1 = max(d__1,d__2),
+ d__2 = abs(t[10]);
+ tnrm = max(d__1,d__2);
+ dcopy_(&c__16, t, &c__1, t1, &c__1);
+ dcopy_(&c__16, val, &c__0, q, &c__1);
+ dcopy_(&c__4, &val[2], &c__0, q, &c__5);
+ dlaexc_(&c_true, &c__3, t, &c__4, q, &c__4, &
+ c__1, &c__2, &c__1, work, &info);
+ if (info != 0) {
+ ++ninfo[info];
+ }
+ dhst01_(&c__3, &c__1, &c__3, t1, &c__4, t, &
+ c__4, q, &c__4, work, &c__32, result);
+ res = result[0] + result[1];
+ if (info == 0) {
+ if (t1[10] != t[0]) {
+ res += 1. / eps;
+ }
+ if (t[1] != 0.) {
+ res += 1. / eps;
+ }
+ if (t[2] != 0.) {
+ res += 1. / eps;
+ }
+ if (t[6] != 0. && (t[5] != t[10] ||
+ d_sign(&c_b64, &t[9]) == d_sign(&
+ c_b64, &t[6]))) {
+ res += 1. / eps;
+ }
+ }
+ ++(*knt);
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+
+ for (ia11 = 1; ia11 <= 5; ++ia11) {
+ for (ia12 = 2; ia12 <= 5; ++ia12) {
+ for (ia21 = 2; ia21 <= 4; ++ia21) {
+ for (ia22 = -1; ia22 <= 1; ia22 += 2) {
+ for (ib = 1; ib <= 5; ++ib) {
+ for (ic11 = 3; ic11 <= 4; ++ic11) {
+ for (ic12 = 3; ic12 <= 4; ++ic12) {
+ for (ic21 = 3; ic21 <= 4; ++ic21) {
+ for (ic22 = -1; ic22 <= 1; ic22 += 2) {
+ for (icm = 5; icm <= 7; ++icm) {
+ iam = 1;
+ t[0] = val[ia11 - 1] * vm[iam - 1]
+ ;
+ t[4] = val[ia12 - 1] * vm[iam - 1]
+ ;
+ t[8] = val[ib - 1] * -2.;
+ t[12] = val[ib - 1] * .5;
+ t[1] = -t[4] * val[ia21 - 1];
+ t[5] = val[ia11 - 1] * (
+ doublereal) ia22 * vm[iam
+ - 1];
+ t[9] = val[ib - 1];
+ t[13] = val[ib - 1] * 3.;
+ t[2] = 0.;
+ t[6] = 0.;
+ t[10] = val[ic11 - 1] * (d__1 =
+ val[icm - 1], abs(d__1));
+ t[14] = val[ic12 - 1] * (d__1 =
+ val[icm - 1], abs(d__1));
+ t[3] = 0.;
+ t[7] = 0.;
+ t[11] = -t[14] * val[ic21 - 1] * (
+ d__1 = val[icm - 1], abs(
+ d__1));
+ t[15] = val[ic11 - 1] * (
+ doublereal) ic22 * (d__1 =
+ val[icm - 1], abs(d__1));
+ tnrm = 0.;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ for (j = 1; j <= 4; ++j) {
+/* Computing MAX */
+ d__2 = tnrm, d__3 = (d__1 = t[i__ + (j << 2) -
+ 5], abs(d__1));
+ tnrm = max(d__2,d__3);
+/* L190: */
+ }
+/* L200: */
+ }
+ dcopy_(&c__16, t, &c__1, t1, &
+ c__1);
+ dcopy_(&c__16, val, &c__0, q, &
+ c__1);
+ dcopy_(&c__4, &val[2], &c__0, q, &
+ c__5);
+ dlaexc_(&c_true, &c__4, t, &c__4,
+ q, &c__4, &c__1, &c__2, &
+ c__2, work, &info);
+ if (info != 0) {
+ ++ninfo[info];
+ }
+ dhst01_(&c__4, &c__1, &c__4, t1, &
+ c__4, t, &c__4, q, &c__4,
+ work, &c__32, result);
+ res = result[0] + result[1];
+ if (info == 0) {
+ if (t[2] != 0.) {
+ res += 1. / eps;
+ }
+ if (t[3] != 0.) {
+ res += 1. / eps;
+ }
+ if (t[6] != 0.) {
+ res += 1. / eps;
+ }
+ if (t[7] != 0.) {
+ res += 1. / eps;
+ }
+ if (t[1] != 0. && (t[0] != t[5] || d_sign(&c_b64, &
+ t[4]) == d_sign(&c_b64, &t[1]))) {
+ res += 1. / eps;
+ }
+ if (t[11] != 0. && (t[10] != t[15] || d_sign(&c_b64,
+ &t[14]) == d_sign(&c_b64, &t[11]))) {
+ res += 1. / eps;
+ }
+ }
+ ++(*knt);
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L210: */
+ }
+/* L220: */
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+/* L250: */
+ }
+/* L260: */
+ }
+/* L270: */
+ }
+/* L280: */
+ }
+/* L290: */
+ }
+/* L300: */
+ }
+
+ return 0;
+
+/* End of DGET34 */
+
+} /* dget34_ */
diff --git a/TESTING/EIG/dget35.c b/TESTING/EIG/dget35.c
new file mode 100644
index 0000000..c1d715e
--- /dev/null
+++ b/TESTING/EIG/dget35.c
@@ -0,0 +1,285 @@
+/* dget35.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__6 = 6;
+static doublereal c_b35 = 1.;
+
+/* Subroutine */ int dget35_(doublereal *rmax, integer *lmax, integer *ninfo,
+ integer *knt)
+{
+ /* Initialized data */
+
+ static integer idim[8] = { 1,2,3,4,3,3,6,4 };
+ static integer ival[288] /* was [6][6][8] */ = { 1,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,0,0,0,0,-2,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,
+ 0,0,5,1,2,0,0,0,-8,-2,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 3,4,0,0,0,0,-5,3,0,0,0,0,1,2,1,4,0,0,-3,-9,-1,1,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,1,0,0,0,0,0,2,3,0,0,0,0,5,6,7,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,1,0,0,0,0,0,1,3,-4,0,0,0,2,5,2,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,1,2,0,0,0,0,-2,0,0,0,0,0,5,6,3,4,0,0,-1,
+ -9,-5,2,0,0,8,8,8,8,5,6,9,9,9,9,-7,5,1,0,0,0,0,0,1,5,2,0,0,0,2,
+ -21,5,0,0,0,1,2,3,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0 };
+
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal), sin(doublereal);
+
+ /* Local variables */
+ doublereal a[36] /* was [6][6] */, b[36] /* was [6][6] */, c__[36]
+ /* was [6][6] */;
+ integer i__, j, m, n;
+ doublereal cc[36] /* was [6][6] */, vm1[3], vm2[3];
+ integer ima, imb;
+ doublereal dum[1], eps, res, res1;
+ integer info;
+ doublereal cnrm;
+ integer isgn;
+ doublereal rmul, tnrm, xnrm, scale;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ char trana[1], tranb[1];
+ integer imlda1, imlda2, imldb1;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ integer imloff, itrana, itranb;
+ doublereal bignum, smlnum;
+ extern /* Subroutine */ int dtrsyl_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET35 tests DTRSYL, a routine for solving the Sylvester matrix */
+/* equation */
+
+/* op(A)*X + ISGN*X*op(B) = scale*C, */
+
+/* A and B are assumed to be in Schur canonical form, op() represents an */
+/* optional transpose, and ISGN can be -1 or +1. Scale is an output */
+/* less than or equal to 1, chosen to avoid overflow in X. */
+
+/* The test code verifies that the following residual is order 1: */
+
+/* norm(op(A)*X + ISGN*X*op(B) - scale*C) / */
+/* (EPS*max(norm(A),norm(B))*norm(X)) */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) DOUBLE PRECISION */
+/* Value of the largest test ratio. */
+
+/* LMAX (output) INTEGER */
+/* Example number where largest test ratio achieved. */
+
+/* NINFO (output) INTEGER */
+/* Number of examples where INFO is nonzero. */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Get machine parameters */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S") * 4. / eps;
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Set up test case parameters */
+
+ vm1[0] = sqrt(smlnum);
+ vm1[1] = 1.;
+ vm1[2] = sqrt(bignum);
+ vm2[0] = 1.;
+ vm2[1] = eps * 2. + 1.;
+ vm2[2] = 2.;
+
+ *knt = 0;
+ *ninfo = 0;
+ *lmax = 0;
+ *rmax = 0.;
+
+/* Begin test loop */
+
+ for (itrana = 1; itrana <= 2; ++itrana) {
+ for (itranb = 1; itranb <= 2; ++itranb) {
+ for (isgn = -1; isgn <= 1; isgn += 2) {
+ for (ima = 1; ima <= 8; ++ima) {
+ for (imlda1 = 1; imlda1 <= 3; ++imlda1) {
+ for (imlda2 = 1; imlda2 <= 3; ++imlda2) {
+ for (imloff = 1; imloff <= 2; ++imloff) {
+ for (imb = 1; imb <= 8; ++imb) {
+ for (imldb1 = 1; imldb1 <= 3; ++imldb1) {
+ if (itrana == 1) {
+ *(unsigned char *)trana = 'N';
+ }
+ if (itrana == 2) {
+ *(unsigned char *)trana = 'T';
+ }
+ if (itranb == 1) {
+ *(unsigned char *)tranb = 'N';
+ }
+ if (itranb == 2) {
+ *(unsigned char *)tranb = 'T';
+ }
+ m = idim[ima - 1];
+ n = idim[imb - 1];
+ tnrm = 0.;
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = m;
+ for (j = 1; j <= i__2; ++j) {
+ a[i__ + j * 6 - 7] = (doublereal) ival[i__ + (j +
+ ima * 6) * 6 - 43];
+ if ((i__3 = i__ - j, abs(i__3)) <= 1) {
+ a[i__ + j * 6 - 7] *= vm1[imlda1 - 1];
+ a[i__ + j * 6 - 7] *= vm2[imlda2 - 1];
+ } else {
+ a[i__ + j * 6 - 7] *= vm1[imloff - 1];
+ }
+/* Computing MAX */
+ d__2 = tnrm, d__3 = (d__1 = a[i__ + j * 6 - 7], abs(
+ d__1));
+ tnrm = max(d__2,d__3);
+/* L10: */
+ }
+/* L20: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ b[i__ + j * 6 - 7] = (doublereal) ival[i__ + (j +
+ imb * 6) * 6 - 43];
+ if ((i__3 = i__ - j, abs(i__3)) <= 1) {
+ b[i__ + j * 6 - 7] *= vm1[imldb1 - 1];
+ } else {
+ b[i__ + j * 6 - 7] *= vm1[imloff - 1];
+ }
+/* Computing MAX */
+ d__2 = tnrm, d__3 = (d__1 = b[i__ + j * 6 - 7], abs(
+ d__1));
+ tnrm = max(d__2,d__3);
+/* L30: */
+ }
+/* L40: */
+ }
+ cnrm = 0.;
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ c__[i__ + j * 6 - 7] = sin((doublereal) (i__ * j));
+/* Computing MAX */
+ d__1 = cnrm, d__2 = c__[i__ + j * 6 - 7];
+ cnrm = max(d__1,d__2);
+ cc[i__ + j * 6 - 7] = c__[i__ + j * 6 - 7];
+/* L50: */
+ }
+/* L60: */
+ }
+ ++(*knt);
+ dtrsyl_(trana, tranb, &isgn, &m, &n,
+ a, &c__6, b, &c__6, c__, &
+ c__6, &scale, &info);
+ if (info != 0) {
+ ++(*ninfo);
+ }
+ xnrm = dlange_("M", &m, &n, c__, &
+ c__6, dum);
+ rmul = 1.;
+ if (xnrm > 1. && tnrm > 1.) {
+ if (xnrm > bignum / tnrm) {
+ rmul = 1. / max(xnrm,tnrm);
+ }
+ }
+ d__1 = -scale * rmul;
+ dgemm_(trana, "N", &m, &n, &m, &rmul,
+ a, &c__6, c__, &c__6, &d__1,
+ cc, &c__6);
+ d__1 = (doublereal) isgn * rmul;
+ dgemm_("N", tranb, &m, &n, &n, &d__1,
+ c__, &c__6, b, &c__6, &c_b35,
+ cc, &c__6);
+ res1 = dlange_("M", &m, &n, cc, &c__6,
+ dum);
+/* Computing MAX */
+ d__1 = smlnum, d__2 = smlnum * xnrm,
+ d__1 = max(d__1,d__2), d__2 =
+ rmul * tnrm * eps * xnrm;
+ res = res1 / max(d__1,d__2);
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+ return 0;
+
+/* End of DGET35 */
+
+} /* dget35_ */
diff --git a/TESTING/EIG/dget36.c b/TESTING/EIG/dget36.c
new file mode 100644
index 0000000..9ef0442
--- /dev/null
+++ b/TESTING/EIG/dget36.c
@@ -0,0 +1,289 @@
+/* dget36.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__5 = 5;
+static integer c__10 = 10;
+static doublereal c_b21 = 0.;
+static doublereal c_b22 = 1.;
+static integer c__200 = 200;
+
+/* Subroutine */ int dget36_(doublereal *rmax, integer *lmax, integer *ninfo,
+ integer *knt, integer *nin)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+ double d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer i__, j, n;
+ doublereal q[100] /* was [10][10] */, t1[100] /* was [10][10] */,
+ t2[100] /* was [10][10] */;
+ integer loc;
+ doublereal eps, res, tmp[100] /* was [10][10] */;
+ integer ifst, ilst;
+ doublereal work[200];
+ integer info1, info2, ifst1, ifst2, ilst1, ilst2;
+ extern /* Subroutine */ int dhst01_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), dtrexc_(char *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *, doublereal *, integer *);
+ integer ifstsv;
+ doublereal result[2];
+ integer ilstsv;
+
+ /* Fortran I/O blocks */
+ static cilist io___2 = { 0, 0, 0, 0, 0 };
+ static cilist io___7 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET36 tests DTREXC, a routine for moving blocks (either 1 by 1 or */
+/* 2 by 2) on the diagonal of a matrix in real Schur form. Thus, DLAEXC */
+/* computes an orthogonal matrix Q such that */
+
+/* Q' * T1 * Q = T2 */
+
+/* and where one of the diagonal blocks of T1 (the one at row IFST) has */
+/* been moved to position ILST. */
+
+/* The test code verifies that the residual Q'*T1*Q-T2 is small, that T2 */
+/* is in Schur form, and that the final position of the IFST block is */
+/* ILST (within +-1). */
+
+/* The test matrices are read from a file with logical unit number NIN. */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) DOUBLE PRECISION */
+/* Value of the largest test ratio. */
+
+/* LMAX (output) INTEGER */
+/* Example number where largest test ratio achieved. */
+
+/* NINFO (output) INTEGER array, dimension (3) */
+/* NINFO(J) is the number of examples where INFO=J. */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* NIN (input) INTEGER */
+/* Input logical unit number. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ninfo;
+
+ /* Function Body */
+ eps = dlamch_("P");
+ *rmax = 0.;
+ *lmax = 0;
+ *knt = 0;
+ ninfo[1] = 0;
+ ninfo[2] = 0;
+ ninfo[3] = 0;
+
+/* Read input data until N=0 */
+
+L10:
+ io___2.ciunit = *nin;
+ s_rsle(&io___2);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ifst, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ilst, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ return 0;
+ }
+ ++(*knt);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___7.ciunit = *nin;
+ s_rsle(&io___7);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__5, &c__1, (char *)&tmp[i__ + j * 10 - 11], (ftnlen)
+ sizeof(doublereal));
+ }
+ e_rsle();
+/* L20: */
+ }
+ dlacpy_("F", &n, &n, tmp, &c__10, t1, &c__10);
+ dlacpy_("F", &n, &n, tmp, &c__10, t2, &c__10);
+ ifstsv = ifst;
+ ilstsv = ilst;
+ ifst1 = ifst;
+ ilst1 = ilst;
+ ifst2 = ifst;
+ ilst2 = ilst;
+ res = 0.;
+
+/* Test without accumulating Q */
+
+ dlaset_("Full", &n, &n, &c_b21, &c_b22, q, &c__10);
+ dtrexc_("N", &n, t1, &c__10, q, &c__10, &ifst1, &ilst1, work, &info1);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ if (i__ == j && q[i__ + j * 10 - 11] != 1.) {
+ res += 1. / eps;
+ }
+ if (i__ != j && q[i__ + j * 10 - 11] != 0.) {
+ res += 1. / eps;
+ }
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Test with accumulating Q */
+
+ dlaset_("Full", &n, &n, &c_b21, &c_b22, q, &c__10);
+ dtrexc_("V", &n, t2, &c__10, q, &c__10, &ifst2, &ilst2, work, &info2);
+
+/* Compare T1 with T2 */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ if (t1[i__ + j * 10 - 11] != t2[i__ + j * 10 - 11]) {
+ res += 1. / eps;
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+ if (ifst1 != ifst2) {
+ res += 1. / eps;
+ }
+ if (ilst1 != ilst2) {
+ res += 1. / eps;
+ }
+ if (info1 != info2) {
+ res += 1. / eps;
+ }
+
+/* Test for successful reordering of T2 */
+
+ if (info2 != 0) {
+ ++ninfo[info2];
+ } else {
+ if ((i__1 = ifst2 - ifstsv, abs(i__1)) > 1) {
+ res += 1. / eps;
+ }
+ if ((i__1 = ilst2 - ilstsv, abs(i__1)) > 1) {
+ res += 1. / eps;
+ }
+ }
+
+/* Test for small residual, and orthogonality of Q */
+
+ dhst01_(&n, &c__1, &n, tmp, &c__10, t2, &c__10, q, &c__10, work, &c__200,
+ result);
+ res = res + result[0] + result[1];
+
+/* Test for T2 being in Schur form */
+
+ loc = 1;
+L70:
+ if (t2[loc + 1 + loc * 10 - 11] != 0.) {
+
+/* 2 by 2 block */
+
+ if (t2[loc + (loc + 1) * 10 - 11] == 0. || t2[loc + loc * 10 - 11] !=
+ t2[loc + 1 + (loc + 1) * 10 - 11] || d_sign(&c_b22, &t2[loc +
+ (loc + 1) * 10 - 11]) == d_sign(&c_b22, &t2[loc + 1 + loc *
+ 10 - 11])) {
+ res += 1. / eps;
+ }
+ i__1 = n;
+ for (i__ = loc + 2; i__ <= i__1; ++i__) {
+ if (t2[i__ + loc * 10 - 11] != 0.) {
+ res += 1. / res;
+ }
+ if (t2[i__ + (loc + 1) * 10 - 11] != 0.) {
+ res += 1. / res;
+ }
+/* L80: */
+ }
+ loc += 2;
+ } else {
+
+/* 1 by 1 block */
+
+ i__1 = n;
+ for (i__ = loc + 1; i__ <= i__1; ++i__) {
+ if (t2[i__ + loc * 10 - 11] != 0.) {
+ res += 1. / res;
+ }
+/* L90: */
+ }
+ ++loc;
+ }
+ if (loc < n) {
+ goto L70;
+ }
+ if (res > *rmax) {
+ *rmax = res;
+ *lmax = *knt;
+ }
+ goto L10;
+
+/* End of DGET36 */
+
+} /* dget36_ */
diff --git a/TESTING/EIG/dget37.c b/TESTING/EIG/dget37.c
new file mode 100644
index 0000000..9d094ac
--- /dev/null
+++ b/TESTING/EIG/dget37.c
@@ -0,0 +1,708 @@
+/* dget37.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__5 = 5;
+static integer c__20 = 20;
+static integer c__1200 = 1200;
+static integer c__0 = 0;
+
+/* Subroutine */ int dget37_(doublereal *rmax, integer *lmax, integer *ninfo,
+ integer *knt, integer *nin)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+
+ /* Local variables */
+ integer i__, j, m, n;
+ doublereal s[20], t[400] /* was [20][20] */, v, le[400] /* was [20][
+ 20] */, re[400] /* was [20][20] */, wi[20], wr[20], val[3],
+ dum[1], eps, sep[20], sin__[20], tol, tmp[400] /* was [20][
+ 20] */;
+ integer ifnd, icmp, iscl, info, lcmp[3], kmin;
+ doublereal wiin[20], vmax, tnrm, wrin[20], work[1200], vmul, stmp[20];
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal sepin[20];
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ doublereal vimin, tolin, vrmin;
+ integer iwork[40];
+ doublereal witmp[20], wrtmp[20];
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dgehrd_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dlacpy_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *);
+ logical select[20];
+ doublereal bignum;
+ extern /* Subroutine */ int dhseqr_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dtrevc_(char *, char *, logical *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *, integer *, doublereal *, integer *), dtrsna_(char *, char *, logical *, integer *, doublereal
+ *, integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *, integer *);
+ doublereal septmp[20], smlnum;
+
+ /* Fortran I/O blocks */
+ static cilist io___5 = { 0, 0, 0, 0, 0 };
+ static cilist io___8 = { 0, 0, 0, 0, 0 };
+ static cilist io___11 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET37 tests DTRSNA, a routine for estimating condition numbers of */
+/* eigenvalues and/or right eigenvectors of a matrix. */
+
+/* The test matrices are read from a file with logical unit number NIN. */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) DOUBLE PRECISION array, dimension (3) */
+/* Value of the largest test ratio. */
+/* RMAX(1) = largest ratio comparing different calls to DTRSNA */
+/* RMAX(2) = largest error in reciprocal condition */
+/* numbers taking their conditioning into account */
+/* RMAX(3) = largest error in reciprocal condition */
+/* numbers not taking their conditioning into */
+/* account (may be larger than RMAX(2)) */
+
+/* LMAX (output) INTEGER array, dimension (3) */
+/* LMAX(i) is example number where largest test ratio */
+/* RMAX(i) is achieved. Also: */
+/* If DGEHRD returns INFO nonzero on example i, LMAX(1)=i */
+/* If DHSEQR returns INFO nonzero on example i, LMAX(2)=i */
+/* If DTRSNA returns INFO nonzero on example i, LMAX(3)=i */
+
+/* NINFO (output) INTEGER array, dimension (3) */
+/* NINFO(1) = No. of times DGEHRD returned INFO nonzero */
+/* NINFO(2) = No. of times DHSEQR returned INFO nonzero */
+/* NINFO(3) = No. of times DTRSNA returned INFO nonzero */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* NIN (input) INTEGER */
+/* Input logical unit number */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ninfo;
+ --lmax;
+ --rmax;
+
+ /* Function Body */
+ eps = dlamch_("P");
+ smlnum = dlamch_("S") / eps;
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* EPSIN = 2**(-24) = precision to which input data computed */
+
+ eps = max(eps,5.9605e-8);
+ rmax[1] = 0.;
+ rmax[2] = 0.;
+ rmax[3] = 0.;
+ lmax[1] = 0;
+ lmax[2] = 0;
+ lmax[3] = 0;
+ *knt = 0;
+ ninfo[1] = 0;
+ ninfo[2] = 0;
+ ninfo[3] = 0;
+
+ val[0] = sqrt(smlnum);
+ val[1] = 1.;
+ val[2] = sqrt(bignum);
+
+/* Read input data until N=0. Assume input eigenvalues are sorted */
+/* lexicographically (increasing by real part, then decreasing by */
+/* imaginary part) */
+
+L10:
+ io___5.ciunit = *nin;
+ s_rsle(&io___5);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ return 0;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___8.ciunit = *nin;
+ s_rsle(&io___8);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__5, &c__1, (char *)&tmp[i__ + j * 20 - 21], (ftnlen)
+ sizeof(doublereal));
+ }
+ e_rsle();
+/* L20: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___11.ciunit = *nin;
+ s_rsle(&io___11);
+ do_lio(&c__5, &c__1, (char *)&wrin[i__ - 1], (ftnlen)sizeof(
+ doublereal));
+ do_lio(&c__5, &c__1, (char *)&wiin[i__ - 1], (ftnlen)sizeof(
+ doublereal));
+ do_lio(&c__5, &c__1, (char *)&sin__[i__ - 1], (ftnlen)sizeof(
+ doublereal));
+ do_lio(&c__5, &c__1, (char *)&sepin[i__ - 1], (ftnlen)sizeof(
+ doublereal));
+ e_rsle();
+/* L30: */
+ }
+ tnrm = dlange_("M", &n, &n, tmp, &c__20, work);
+
+/* Begin test */
+
+ for (iscl = 1; iscl <= 3; ++iscl) {
+
+/* Scale input matrix */
+
+ ++(*knt);
+ dlacpy_("F", &n, &n, tmp, &c__20, t, &c__20);
+ vmul = val[iscl - 1];
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dscal_(&n, &vmul, &t[i__ * 20 - 20], &c__1);
+/* L40: */
+ }
+ if (tnrm == 0.) {
+ vmul = 1.;
+ }
+
+/* Compute eigenvalues and eigenvectors */
+
+ i__1 = 1200 - n;
+ dgehrd_(&n, &c__1, &n, t, &c__20, work, &work[n], &i__1, &info);
+ if (info != 0) {
+ lmax[1] = *knt;
+ ++ninfo[1];
+ goto L240;
+ }
+ i__1 = n - 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = n;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+ t[i__ + j * 20 - 21] = 0.;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* Compute Schur form */
+
+ dhseqr_("S", "N", &n, &c__1, &n, t, &c__20, wr, wi, dum, &c__1, work,
+ &c__1200, &info);
+ if (info != 0) {
+ lmax[2] = *knt;
+ ++ninfo[2];
+ goto L240;
+ }
+
+/* Compute eigenvectors */
+
+ dtrevc_("Both", "All", select, &n, t, &c__20, le, &c__20, re, &c__20,
+ &n, &m, work, &info);
+
+/* Compute condition numbers */
+
+ dtrsna_("Both", "All", select, &n, t, &c__20, le, &c__20, re, &c__20,
+ s, sep, &n, &m, work, &n, iwork, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L240;
+ }
+
+/* Sort eigenvalues and condition numbers lexicographically */
+/* to compare with inputs */
+
+ dcopy_(&n, wr, &c__1, wrtmp, &c__1);
+ dcopy_(&n, wi, &c__1, witmp, &c__1);
+ dcopy_(&n, s, &c__1, stmp, &c__1);
+ dcopy_(&n, sep, &c__1, septmp, &c__1);
+ d__1 = 1. / vmul;
+ dscal_(&n, &d__1, septmp, &c__1);
+ i__1 = n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ kmin = i__;
+ vrmin = wrtmp[i__ - 1];
+ vimin = witmp[i__ - 1];
+ i__2 = n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (wrtmp[j - 1] < vrmin) {
+ kmin = j;
+ vrmin = wrtmp[j - 1];
+ vimin = witmp[j - 1];
+ }
+/* L70: */
+ }
+ wrtmp[kmin - 1] = wrtmp[i__ - 1];
+ witmp[kmin - 1] = witmp[i__ - 1];
+ wrtmp[i__ - 1] = vrmin;
+ witmp[i__ - 1] = vimin;
+ vrmin = stmp[kmin - 1];
+ stmp[kmin - 1] = stmp[i__ - 1];
+ stmp[i__ - 1] = vrmin;
+ vrmin = septmp[kmin - 1];
+ septmp[kmin - 1] = septmp[i__ - 1];
+ septmp[i__ - 1] = vrmin;
+/* L80: */
+ }
+
+/* Compare condition numbers for eigenvalues */
+/* taking their condition numbers into account */
+
+/* Computing MAX */
+ d__1 = (doublereal) n * 2. * eps * tnrm;
+ v = max(d__1,smlnum);
+ if (tnrm == 0.) {
+ v = 1.;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (v > septmp[i__ - 1]) {
+ tol = 1.;
+ } else {
+ tol = v / septmp[i__ - 1];
+ }
+ if (v > sepin[i__ - 1]) {
+ tolin = 1.;
+ } else {
+ tolin = v / sepin[i__ - 1];
+ }
+/* Computing MAX */
+ d__1 = tol, d__2 = smlnum / eps;
+ tol = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = tolin, d__2 = smlnum / eps;
+ tolin = max(d__1,d__2);
+ if (eps * (sin__[i__ - 1] - tolin) > stmp[i__ - 1] + tol) {
+ vmax = 1. / eps;
+ } else if (sin__[i__ - 1] - tolin > stmp[i__ - 1] + tol) {
+ vmax = (sin__[i__ - 1] - tolin) / (stmp[i__ - 1] + tol);
+ } else if (sin__[i__ - 1] + tolin < eps * (stmp[i__ - 1] - tol)) {
+ vmax = 1. / eps;
+ } else if (sin__[i__ - 1] + tolin < stmp[i__ - 1] - tol) {
+ vmax = (stmp[i__ - 1] - tol) / (sin__[i__ - 1] + tolin);
+ } else {
+ vmax = 1.;
+ }
+ if (vmax > rmax[2]) {
+ rmax[2] = vmax;
+ if (ninfo[2] == 0) {
+ lmax[2] = *knt;
+ }
+ }
+/* L90: */
+ }
+
+/* Compare condition numbers for eigenvectors */
+/* taking their condition numbers into account */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (v > septmp[i__ - 1] * stmp[i__ - 1]) {
+ tol = septmp[i__ - 1];
+ } else {
+ tol = v / stmp[i__ - 1];
+ }
+ if (v > sepin[i__ - 1] * sin__[i__ - 1]) {
+ tolin = sepin[i__ - 1];
+ } else {
+ tolin = v / sin__[i__ - 1];
+ }
+/* Computing MAX */
+ d__1 = tol, d__2 = smlnum / eps;
+ tol = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = tolin, d__2 = smlnum / eps;
+ tolin = max(d__1,d__2);
+ if (eps * (sepin[i__ - 1] - tolin) > septmp[i__ - 1] + tol) {
+ vmax = 1. / eps;
+ } else if (sepin[i__ - 1] - tolin > septmp[i__ - 1] + tol) {
+ vmax = (sepin[i__ - 1] - tolin) / (septmp[i__ - 1] + tol);
+ } else if (sepin[i__ - 1] + tolin < eps * (septmp[i__ - 1] - tol))
+ {
+ vmax = 1. / eps;
+ } else if (sepin[i__ - 1] + tolin < septmp[i__ - 1] - tol) {
+ vmax = (septmp[i__ - 1] - tol) / (sepin[i__ - 1] + tolin);
+ } else {
+ vmax = 1.;
+ }
+ if (vmax > rmax[2]) {
+ rmax[2] = vmax;
+ if (ninfo[2] == 0) {
+ lmax[2] = *knt;
+ }
+ }
+/* L100: */
+ }
+
+/* Compare condition numbers for eigenvalues */
+/* without taking their condition numbers into account */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (sin__[i__ - 1] <= (doublereal) (n << 1) * eps && stmp[i__ - 1]
+ <= (doublereal) (n << 1) * eps) {
+ vmax = 1.;
+ } else if (eps * sin__[i__ - 1] > stmp[i__ - 1]) {
+ vmax = 1. / eps;
+ } else if (sin__[i__ - 1] > stmp[i__ - 1]) {
+ vmax = sin__[i__ - 1] / stmp[i__ - 1];
+ } else if (sin__[i__ - 1] < eps * stmp[i__ - 1]) {
+ vmax = 1. / eps;
+ } else if (sin__[i__ - 1] < stmp[i__ - 1]) {
+ vmax = stmp[i__ - 1] / sin__[i__ - 1];
+ } else {
+ vmax = 1.;
+ }
+ if (vmax > rmax[3]) {
+ rmax[3] = vmax;
+ if (ninfo[3] == 0) {
+ lmax[3] = *knt;
+ }
+ }
+/* L110: */
+ }
+
+/* Compare condition numbers for eigenvectors */
+/* without taking their condition numbers into account */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (sepin[i__ - 1] <= v && septmp[i__ - 1] <= v) {
+ vmax = 1.;
+ } else if (eps * sepin[i__ - 1] > septmp[i__ - 1]) {
+ vmax = 1. / eps;
+ } else if (sepin[i__ - 1] > septmp[i__ - 1]) {
+ vmax = sepin[i__ - 1] / septmp[i__ - 1];
+ } else if (sepin[i__ - 1] < eps * septmp[i__ - 1]) {
+ vmax = 1. / eps;
+ } else if (sepin[i__ - 1] < septmp[i__ - 1]) {
+ vmax = septmp[i__ - 1] / sepin[i__ - 1];
+ } else {
+ vmax = 1.;
+ }
+ if (vmax > rmax[3]) {
+ rmax[3] = vmax;
+ if (ninfo[3] == 0) {
+ lmax[3] = *knt;
+ }
+ }
+/* L120: */
+ }
+
+/* Compute eigenvalue condition numbers only and compare */
+
+ vmax = 0.;
+ dum[0] = -1.;
+ dcopy_(&n, dum, &c__0, stmp, &c__1);
+ dcopy_(&n, dum, &c__0, septmp, &c__1);
+ dtrsna_("Eigcond", "All", select, &n, t, &c__20, le, &c__20, re, &
+ c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L240;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (stmp[i__ - 1] != s[i__ - 1]) {
+ vmax = 1. / eps;
+ }
+ if (septmp[i__ - 1] != dum[0]) {
+ vmax = 1. / eps;
+ }
+/* L130: */
+ }
+
+/* Compute eigenvector condition numbers only and compare */
+
+ dcopy_(&n, dum, &c__0, stmp, &c__1);
+ dcopy_(&n, dum, &c__0, septmp, &c__1);
+ dtrsna_("Veccond", "All", select, &n, t, &c__20, le, &c__20, re, &
+ c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L240;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (stmp[i__ - 1] != dum[0]) {
+ vmax = 1. / eps;
+ }
+ if (septmp[i__ - 1] != sep[i__ - 1]) {
+ vmax = 1. / eps;
+ }
+/* L140: */
+ }
+
+/* Compute all condition numbers using SELECT and compare */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ select[i__ - 1] = TRUE_;
+/* L150: */
+ }
+ dcopy_(&n, dum, &c__0, stmp, &c__1);
+ dcopy_(&n, dum, &c__0, septmp, &c__1);
+ dtrsna_("Bothcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
+ c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L240;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (septmp[i__ - 1] != sep[i__ - 1]) {
+ vmax = 1. / eps;
+ }
+ if (stmp[i__ - 1] != s[i__ - 1]) {
+ vmax = 1. / eps;
+ }
+/* L160: */
+ }
+
+/* Compute eigenvalue condition numbers using SELECT and compare */
+
+ dcopy_(&n, dum, &c__0, stmp, &c__1);
+ dcopy_(&n, dum, &c__0, septmp, &c__1);
+ dtrsna_("Eigcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
+ c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L240;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (stmp[i__ - 1] != s[i__ - 1]) {
+ vmax = 1. / eps;
+ }
+ if (septmp[i__ - 1] != dum[0]) {
+ vmax = 1. / eps;
+ }
+/* L170: */
+ }
+
+/* Compute eigenvector condition numbers using SELECT and compare */
+
+ dcopy_(&n, dum, &c__0, stmp, &c__1);
+ dcopy_(&n, dum, &c__0, septmp, &c__1);
+ dtrsna_("Veccond", "Some", select, &n, t, &c__20, le, &c__20, re, &
+ c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L240;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (stmp[i__ - 1] != dum[0]) {
+ vmax = 1. / eps;
+ }
+ if (septmp[i__ - 1] != sep[i__ - 1]) {
+ vmax = 1. / eps;
+ }
+/* L180: */
+ }
+ if (vmax > rmax[1]) {
+ rmax[1] = vmax;
+ if (ninfo[1] == 0) {
+ lmax[1] = *knt;
+ }
+ }
+
+/* Select first real and first complex eigenvalue */
+
+ if (wi[0] == 0.) {
+ lcmp[0] = 1;
+ ifnd = 0;
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ if (ifnd == 1 || wi[i__ - 1] == 0.) {
+ select[i__ - 1] = FALSE_;
+ } else {
+ ifnd = 1;
+ lcmp[1] = i__;
+ lcmp[2] = i__ + 1;
+ dcopy_(&n, &re[i__ * 20 - 20], &c__1, &re[20], &c__1);
+ dcopy_(&n, &re[(i__ + 1) * 20 - 20], &c__1, &re[40], &
+ c__1);
+ dcopy_(&n, &le[i__ * 20 - 20], &c__1, &le[20], &c__1);
+ dcopy_(&n, &le[(i__ + 1) * 20 - 20], &c__1, &le[40], &
+ c__1);
+ }
+/* L190: */
+ }
+ if (ifnd == 0) {
+ icmp = 1;
+ } else {
+ icmp = 3;
+ }
+ } else {
+ lcmp[0] = 1;
+ lcmp[1] = 2;
+ ifnd = 0;
+ i__1 = n;
+ for (i__ = 3; i__ <= i__1; ++i__) {
+ if (ifnd == 1 || wi[i__ - 1] != 0.) {
+ select[i__ - 1] = FALSE_;
+ } else {
+ lcmp[2] = i__;
+ ifnd = 1;
+ dcopy_(&n, &re[i__ * 20 - 20], &c__1, &re[40], &c__1);
+ dcopy_(&n, &le[i__ * 20 - 20], &c__1, &le[40], &c__1);
+ }
+/* L200: */
+ }
+ if (ifnd == 0) {
+ icmp = 2;
+ } else {
+ icmp = 3;
+ }
+ }
+
+/* Compute all selected condition numbers */
+
+ dcopy_(&icmp, dum, &c__0, stmp, &c__1);
+ dcopy_(&icmp, dum, &c__0, septmp, &c__1);
+ dtrsna_("Bothcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
+ c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L240;
+ }
+ i__1 = icmp;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ j = lcmp[i__ - 1];
+ if (septmp[i__ - 1] != sep[j - 1]) {
+ vmax = 1. / eps;
+ }
+ if (stmp[i__ - 1] != s[j - 1]) {
+ vmax = 1. / eps;
+ }
+/* L210: */
+ }
+
+/* Compute selected eigenvalue condition numbers */
+
+ dcopy_(&icmp, dum, &c__0, stmp, &c__1);
+ dcopy_(&icmp, dum, &c__0, septmp, &c__1);
+ dtrsna_("Eigcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
+ c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L240;
+ }
+ i__1 = icmp;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ j = lcmp[i__ - 1];
+ if (stmp[i__ - 1] != s[j - 1]) {
+ vmax = 1. / eps;
+ }
+ if (septmp[i__ - 1] != dum[0]) {
+ vmax = 1. / eps;
+ }
+/* L220: */
+ }
+
+/* Compute selected eigenvector condition numbers */
+
+ dcopy_(&icmp, dum, &c__0, stmp, &c__1);
+ dcopy_(&icmp, dum, &c__0, septmp, &c__1);
+ dtrsna_("Veccond", "Some", select, &n, t, &c__20, le, &c__20, re, &
+ c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L240;
+ }
+ i__1 = icmp;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ j = lcmp[i__ - 1];
+ if (stmp[i__ - 1] != dum[0]) {
+ vmax = 1. / eps;
+ }
+ if (septmp[i__ - 1] != sep[j - 1]) {
+ vmax = 1. / eps;
+ }
+/* L230: */
+ }
+ if (vmax > rmax[1]) {
+ rmax[1] = vmax;
+ if (ninfo[1] == 0) {
+ lmax[1] = *knt;
+ }
+ }
+L240:
+ ;
+ }
+ goto L10;
+
+/* End of DGET37 */
+
+} /* dget37_ */
diff --git a/TESTING/EIG/dget38.c b/TESTING/EIG/dget38.c
new file mode 100644
index 0000000..5e150d5
--- /dev/null
+++ b/TESTING/EIG/dget38.c
@@ -0,0 +1,611 @@
+/* dget38.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__5 = 5;
+static integer c__20 = 20;
+static integer c__1200 = 1200;
+static integer c__400 = 400;
+
+/* Subroutine */ int dget38_(doublereal *rmax, integer *lmax, integer *ninfo,
+ integer *knt, integer *nin)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+
+ /* Local variables */
+ integer i__, j, m, n;
+ doublereal q[400] /* was [20][20] */, s, t[400] /* was [20][20] */, v,
+ wi[20], wr[20], val[3], eps, sep, sin__, tol, tmp[400] /*
+ was [20][20] */;
+ integer ndim, iscl, info, kmin, itmp, ipnt[20];
+ doublereal vmax, qsav[400] /* was [20][20] */, tsav[400] /* was [20][
+ 20] */, tnrm, qtmp[400] /* was [20][20] */, work[1200], stmp,
+ vmul, ttmp[400] /* was [20][20] */, tsav1[400] /* was [20][
+ 20] */;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *), dhst01_(integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *);
+ doublereal sepin;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ doublereal vimin, tolin, vrmin;
+ integer iwork[400];
+ doublereal witmp[20], wrtmp[20];
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dgehrd_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+ integer iselec[20];
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ logical select[20];
+ doublereal bignum;
+ extern /* Subroutine */ int dorghr_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dhseqr_(char *, char *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dtrsen_(char *, char *, logical *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *, integer *, integer *);
+ doublereal septmp, smlnum, result[2];
+
+ /* Fortran I/O blocks */
+ static cilist io___5 = { 0, 0, 0, 0, 0 };
+ static cilist io___8 = { 0, 0, 0, 0, 0 };
+ static cilist io___11 = { 0, 0, 0, 0, 0 };
+ static cilist io___14 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET38 tests DTRSEN, a routine for estimating condition numbers of a */
+/* cluster of eigenvalues and/or its associated right invariant subspace */
+
+/* The test matrices are read from a file with logical unit number NIN. */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) DOUBLE PRECISION array, dimension (3) */
+/* Values of the largest test ratios. */
+/* RMAX(1) = largest residuals from DHST01 or comparing */
+/* different calls to DTRSEN */
+/* RMAX(2) = largest error in reciprocal condition */
+/* numbers taking their conditioning into account */
+/* RMAX(3) = largest error in reciprocal condition */
+/* numbers not taking their conditioning into */
+/* account (may be larger than RMAX(2)) */
+
+/* LMAX (output) INTEGER array, dimension (3) */
+/* LMAX(i) is example number where largest test ratio */
+/* RMAX(i) is achieved. Also: */
+/* If DGEHRD returns INFO nonzero on example i, LMAX(1)=i */
+/* If DHSEQR returns INFO nonzero on example i, LMAX(2)=i */
+/* If DTRSEN returns INFO nonzero on example i, LMAX(3)=i */
+
+/* NINFO (output) INTEGER array, dimension (3) */
+/* NINFO(1) = No. of times DGEHRD returned INFO nonzero */
+/* NINFO(2) = No. of times DHSEQR returned INFO nonzero */
+/* NINFO(3) = No. of times DTRSEN returned INFO nonzero */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* NIN (input) INTEGER */
+/* Input logical unit number. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ninfo;
+ --lmax;
+ --rmax;
+
+ /* Function Body */
+ eps = dlamch_("P");
+ smlnum = dlamch_("S") / eps;
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* EPSIN = 2**(-24) = precision to which input data computed */
+
+ eps = max(eps,5.9605e-8);
+ rmax[1] = 0.;
+ rmax[2] = 0.;
+ rmax[3] = 0.;
+ lmax[1] = 0;
+ lmax[2] = 0;
+ lmax[3] = 0;
+ *knt = 0;
+ ninfo[1] = 0;
+ ninfo[2] = 0;
+ ninfo[3] = 0;
+
+ val[0] = sqrt(smlnum);
+ val[1] = 1.;
+ val[2] = sqrt(sqrt(bignum));
+
+/* Read input data until N=0. Assume input eigenvalues are sorted */
+/* lexicographically (increasing by real part, then decreasing by */
+/* imaginary part) */
+
+L10:
+ io___5.ciunit = *nin;
+ s_rsle(&io___5);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ndim, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ return 0;
+ }
+ io___8.ciunit = *nin;
+ s_rsle(&io___8);
+ i__1 = ndim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&iselec[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_rsle();
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___11.ciunit = *nin;
+ s_rsle(&io___11);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__5, &c__1, (char *)&tmp[i__ + j * 20 - 21], (ftnlen)
+ sizeof(doublereal));
+ }
+ e_rsle();
+/* L20: */
+ }
+ io___14.ciunit = *nin;
+ s_rsle(&io___14);
+ do_lio(&c__5, &c__1, (char *)&sin__, (ftnlen)sizeof(doublereal));
+ do_lio(&c__5, &c__1, (char *)&sepin, (ftnlen)sizeof(doublereal));
+ e_rsle();
+
+ tnrm = dlange_("M", &n, &n, tmp, &c__20, work);
+ for (iscl = 1; iscl <= 3; ++iscl) {
+
+/* Scale input matrix */
+
+ ++(*knt);
+ dlacpy_("F", &n, &n, tmp, &c__20, t, &c__20);
+ vmul = val[iscl - 1];
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dscal_(&n, &vmul, &t[i__ * 20 - 20], &c__1);
+/* L30: */
+ }
+ if (tnrm == 0.) {
+ vmul = 1.;
+ }
+ dlacpy_("F", &n, &n, t, &c__20, tsav, &c__20);
+
+/* Compute Schur form */
+
+ i__1 = 1200 - n;
+ dgehrd_(&n, &c__1, &n, t, &c__20, work, &work[n], &i__1, &info);
+ if (info != 0) {
+ lmax[1] = *knt;
+ ++ninfo[1];
+ goto L160;
+ }
+
+/* Generate orthogonal matrix */
+
+ dlacpy_("L", &n, &n, t, &c__20, q, &c__20);
+ i__1 = 1200 - n;
+ dorghr_(&n, &c__1, &n, q, &c__20, work, &work[n], &i__1, &info);
+
+/* Compute Schur form */
+
+ dhseqr_("S", "V", &n, &c__1, &n, t, &c__20, wr, wi, q, &c__20, work, &
+ c__1200, &info);
+ if (info != 0) {
+ lmax[2] = *knt;
+ ++ninfo[2];
+ goto L160;
+ }
+
+/* Sort, select eigenvalues */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ipnt[i__ - 1] = i__;
+ select[i__ - 1] = FALSE_;
+/* L40: */
+ }
+ dcopy_(&n, wr, &c__1, wrtmp, &c__1);
+ dcopy_(&n, wi, &c__1, witmp, &c__1);
+ i__1 = n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ kmin = i__;
+ vrmin = wrtmp[i__ - 1];
+ vimin = witmp[i__ - 1];
+ i__2 = n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (wrtmp[j - 1] < vrmin) {
+ kmin = j;
+ vrmin = wrtmp[j - 1];
+ vimin = witmp[j - 1];
+ }
+/* L50: */
+ }
+ wrtmp[kmin - 1] = wrtmp[i__ - 1];
+ witmp[kmin - 1] = witmp[i__ - 1];
+ wrtmp[i__ - 1] = vrmin;
+ witmp[i__ - 1] = vimin;
+ itmp = ipnt[i__ - 1];
+ ipnt[i__ - 1] = ipnt[kmin - 1];
+ ipnt[kmin - 1] = itmp;
+/* L60: */
+ }
+ i__1 = ndim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ select[ipnt[iselec[i__ - 1] - 1] - 1] = TRUE_;
+/* L70: */
+ }
+
+/* Compute condition numbers */
+
+ dlacpy_("F", &n, &n, q, &c__20, qsav, &c__20);
+ dlacpy_("F", &n, &n, t, &c__20, tsav1, &c__20);
+ dtrsen_("B", "V", select, &n, t, &c__20, q, &c__20, wrtmp, witmp, &m,
+ &s, &sep, work, &c__1200, iwork, &c__400, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L160;
+ }
+ septmp = sep / vmul;
+ stmp = s;
+
+/* Compute residuals */
+
+ dhst01_(&n, &c__1, &n, tsav, &c__20, t, &c__20, q, &c__20, work, &
+ c__1200, result);
+ vmax = max(result[0],result[1]);
+ if (vmax > rmax[1]) {
+ rmax[1] = vmax;
+ if (ninfo[1] == 0) {
+ lmax[1] = *knt;
+ }
+ }
+
+/* Compare condition number for eigenvalue cluster */
+/* taking its condition number into account */
+
+/* Computing MAX */
+ d__1 = (doublereal) n * 2. * eps * tnrm;
+ v = max(d__1,smlnum);
+ if (tnrm == 0.) {
+ v = 1.;
+ }
+ if (v > septmp) {
+ tol = 1.;
+ } else {
+ tol = v / septmp;
+ }
+ if (v > sepin) {
+ tolin = 1.;
+ } else {
+ tolin = v / sepin;
+ }
+/* Computing MAX */
+ d__1 = tol, d__2 = smlnum / eps;
+ tol = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = tolin, d__2 = smlnum / eps;
+ tolin = max(d__1,d__2);
+ if (eps * (sin__ - tolin) > stmp + tol) {
+ vmax = 1. / eps;
+ } else if (sin__ - tolin > stmp + tol) {
+ vmax = (sin__ - tolin) / (stmp + tol);
+ } else if (sin__ + tolin < eps * (stmp - tol)) {
+ vmax = 1. / eps;
+ } else if (sin__ + tolin < stmp - tol) {
+ vmax = (stmp - tol) / (sin__ + tolin);
+ } else {
+ vmax = 1.;
+ }
+ if (vmax > rmax[2]) {
+ rmax[2] = vmax;
+ if (ninfo[2] == 0) {
+ lmax[2] = *knt;
+ }
+ }
+
+/* Compare condition numbers for invariant subspace */
+/* taking its condition number into account */
+
+ if (v > septmp * stmp) {
+ tol = septmp;
+ } else {
+ tol = v / stmp;
+ }
+ if (v > sepin * sin__) {
+ tolin = sepin;
+ } else {
+ tolin = v / sin__;
+ }
+/* Computing MAX */
+ d__1 = tol, d__2 = smlnum / eps;
+ tol = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = tolin, d__2 = smlnum / eps;
+ tolin = max(d__1,d__2);
+ if (eps * (sepin - tolin) > septmp + tol) {
+ vmax = 1. / eps;
+ } else if (sepin - tolin > septmp + tol) {
+ vmax = (sepin - tolin) / (septmp + tol);
+ } else if (sepin + tolin < eps * (septmp - tol)) {
+ vmax = 1. / eps;
+ } else if (sepin + tolin < septmp - tol) {
+ vmax = (septmp - tol) / (sepin + tolin);
+ } else {
+ vmax = 1.;
+ }
+ if (vmax > rmax[2]) {
+ rmax[2] = vmax;
+ if (ninfo[2] == 0) {
+ lmax[2] = *knt;
+ }
+ }
+
+/* Compare condition number for eigenvalue cluster */
+/* without taking its condition number into account */
+
+ if (sin__ <= (doublereal) (n << 1) * eps && stmp <= (doublereal) (n <<
+ 1) * eps) {
+ vmax = 1.;
+ } else if (eps * sin__ > stmp) {
+ vmax = 1. / eps;
+ } else if (sin__ > stmp) {
+ vmax = sin__ / stmp;
+ } else if (sin__ < eps * stmp) {
+ vmax = 1. / eps;
+ } else if (sin__ < stmp) {
+ vmax = stmp / sin__;
+ } else {
+ vmax = 1.;
+ }
+ if (vmax > rmax[3]) {
+ rmax[3] = vmax;
+ if (ninfo[3] == 0) {
+ lmax[3] = *knt;
+ }
+ }
+
+/* Compare condition numbers for invariant subspace */
+/* without taking its condition number into account */
+
+ if (sepin <= v && septmp <= v) {
+ vmax = 1.;
+ } else if (eps * sepin > septmp) {
+ vmax = 1. / eps;
+ } else if (sepin > septmp) {
+ vmax = sepin / septmp;
+ } else if (sepin < eps * septmp) {
+ vmax = 1. / eps;
+ } else if (sepin < septmp) {
+ vmax = septmp / sepin;
+ } else {
+ vmax = 1.;
+ }
+ if (vmax > rmax[3]) {
+ rmax[3] = vmax;
+ if (ninfo[3] == 0) {
+ lmax[3] = *knt;
+ }
+ }
+
+/* Compute eigenvalue condition number only and compare */
+/* Update Q */
+
+ vmax = 0.;
+ dlacpy_("F", &n, &n, tsav1, &c__20, ttmp, &c__20);
+ dlacpy_("F", &n, &n, qsav, &c__20, qtmp, &c__20);
+ septmp = -1.;
+ stmp = -1.;
+ dtrsen_("E", "V", select, &n, ttmp, &c__20, qtmp, &c__20, wrtmp,
+ witmp, &m, &stmp, &septmp, work, &c__1200, iwork, &c__400, &
+ info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L160;
+ }
+ if (s != stmp) {
+ vmax = 1. / eps;
+ }
+ if (-1. != septmp) {
+ vmax = 1. / eps;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ if (ttmp[i__ + j * 20 - 21] != t[i__ + j * 20 - 21]) {
+ vmax = 1. / eps;
+ }
+ if (qtmp[i__ + j * 20 - 21] != q[i__ + j * 20 - 21]) {
+ vmax = 1. / eps;
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Compute invariant subspace condition number only and compare */
+/* Update Q */
+
+ dlacpy_("F", &n, &n, tsav1, &c__20, ttmp, &c__20);
+ dlacpy_("F", &n, &n, qsav, &c__20, qtmp, &c__20);
+ septmp = -1.;
+ stmp = -1.;
+ dtrsen_("V", "V", select, &n, ttmp, &c__20, qtmp, &c__20, wrtmp,
+ witmp, &m, &stmp, &septmp, work, &c__1200, iwork, &c__400, &
+ info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L160;
+ }
+ if (-1. != stmp) {
+ vmax = 1. / eps;
+ }
+ if (sep != septmp) {
+ vmax = 1. / eps;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ if (ttmp[i__ + j * 20 - 21] != t[i__ + j * 20 - 21]) {
+ vmax = 1. / eps;
+ }
+ if (qtmp[i__ + j * 20 - 21] != q[i__ + j * 20 - 21]) {
+ vmax = 1. / eps;
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+
+/* Compute eigenvalue condition number only and compare */
+/* Do not update Q */
+
+ dlacpy_("F", &n, &n, tsav1, &c__20, ttmp, &c__20);
+ dlacpy_("F", &n, &n, qsav, &c__20, qtmp, &c__20);
+ septmp = -1.;
+ stmp = -1.;
+ dtrsen_("E", "N", select, &n, ttmp, &c__20, qtmp, &c__20, wrtmp,
+ witmp, &m, &stmp, &septmp, work, &c__1200, iwork, &c__400, &
+ info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L160;
+ }
+ if (s != stmp) {
+ vmax = 1. / eps;
+ }
+ if (-1. != septmp) {
+ vmax = 1. / eps;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ if (ttmp[i__ + j * 20 - 21] != t[i__ + j * 20 - 21]) {
+ vmax = 1. / eps;
+ }
+ if (qtmp[i__ + j * 20 - 21] != qsav[i__ + j * 20 - 21]) {
+ vmax = 1. / eps;
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+
+/* Compute invariant subspace condition number only and compare */
+/* Do not update Q */
+
+ dlacpy_("F", &n, &n, tsav1, &c__20, ttmp, &c__20);
+ dlacpy_("F", &n, &n, qsav, &c__20, qtmp, &c__20);
+ septmp = -1.;
+ stmp = -1.;
+ dtrsen_("V", "N", select, &n, ttmp, &c__20, qtmp, &c__20, wrtmp,
+ witmp, &m, &stmp, &septmp, work, &c__1200, iwork, &c__400, &
+ info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L160;
+ }
+ if (-1. != stmp) {
+ vmax = 1. / eps;
+ }
+ if (sep != septmp) {
+ vmax = 1. / eps;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ if (ttmp[i__ + j * 20 - 21] != t[i__ + j * 20 - 21]) {
+ vmax = 1. / eps;
+ }
+ if (qtmp[i__ + j * 20 - 21] != qsav[i__ + j * 20 - 21]) {
+ vmax = 1. / eps;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+ if (vmax > rmax[1]) {
+ rmax[1] = vmax;
+ if (ninfo[1] == 0) {
+ lmax[1] = *knt;
+ }
+ }
+L160:
+ ;
+ }
+ goto L10;
+
+/* End of DGET38 */
+
+} /* dget38_ */
diff --git a/TESTING/EIG/dget39.c b/TESTING/EIG/dget39.c
new file mode 100644
index 0000000..f2a2801
--- /dev/null
+++ b/TESTING/EIG/dget39.c
@@ -0,0 +1,418 @@
+/* dget39.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__10 = 10;
+static integer c__1 = 1;
+static logical c_false = FALSE_;
+static logical c_true = TRUE_;
+static doublereal c_b25 = 1.;
+static doublereal c_b59 = -1.;
+
+/* Subroutine */ int dget39_(doublereal *rmax, integer *lmax, integer *ninfo,
+ integer *knt)
+{
+ /* Initialized data */
+
+ static integer idim[6] = { 4,5,5,5,5,5 };
+ static integer ival[150] /* was [5][5][6] */ = { 3,0,0,0,0,1,1,-1,0,0,
+ 3,2,1,0,0,4,3,2,2,0,0,0,0,0,0,1,0,0,0,0,2,2,0,0,0,3,3,4,0,0,4,2,2,
+ 3,0,1,1,1,1,5,1,0,0,0,0,2,4,-2,0,0,3,3,4,0,0,4,2,2,3,0,1,1,1,1,1,
+ 1,0,0,0,0,2,1,-1,0,0,9,8,1,0,0,4,9,1,2,-1,2,2,2,2,2,9,0,0,0,0,6,4,
+ 0,0,0,3,2,1,1,0,5,1,-1,1,0,2,2,2,2,2,4,0,0,0,0,2,2,0,0,0,1,4,4,0,
+ 0,2,4,2,2,-1,2,2,2,2,2 };
+
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), cos(doublereal), sin(doublereal);
+
+ /* Local variables */
+ doublereal b[10], d__[20];
+ integer i__, j, k, n;
+ doublereal t[100] /* was [10][10] */, w, x[20], y[20], vm1[5], vm2[5],
+ vm3[5], vm4[5], vm5[3], dum[1], eps;
+ integer ivm1, ivm2, ivm3, ivm4, ivm5, ndim;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer info;
+ doublereal dumm, norm, work[10], scale;
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ doublereal domin, resid;
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ doublereal xnorm;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dlaqtr_(logical *, logical *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *);
+ doublereal normtb, smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET39 tests DLAQTR, a routine for solving the real or */
+/* special complex quasi upper triangular system */
+
+/* op(T)*p = scale*c, */
+/* or */
+/* op(T + iB)*(p+iq) = scale*(c+id), */
+
+/* in real arithmetic. T is upper quasi-triangular. */
+/* If it is complex, then the first diagonal block of T must be */
+/* 1 by 1, B has the special structure */
+
+/* B = [ b(1) b(2) ... b(n) ] */
+/* [ w ] */
+/* [ w ] */
+/* [ . ] */
+/* [ w ] */
+
+/* op(A) = A or A', where A' denotes the conjugate transpose of */
+/* the matrix A. */
+
+/* On input, X = [ c ]. On output, X = [ p ]. */
+/* [ d ] [ q ] */
+
+/* Scale is an output less than or equal to 1, chosen to avoid */
+/* overflow in X. */
+/* This subroutine is specially designed for the condition number */
+/* estimation in the eigenproblem routine DTRSNA. */
+
+/* The test code verifies that the following residual is order 1: */
+
+/* ||(T+i*B)*(x1+i*x2) - scale*(d1+i*d2)|| */
+/* ----------------------------------------- */
+/* max(ulp*(||T||+||B||)*(||x1||+||x2||), */
+/* (||T||+||B||)*smlnum/ulp, */
+/* smlnum) */
+
+/* (The (||T||+||B||)*smlnum/ulp term accounts for possible */
+/* (gradual or nongradual) underflow in x1 and x2.) */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) DOUBLE PRECISION */
+/* Value of the largest test ratio. */
+
+/* LMAX (output) INTEGER */
+/* Example number where largest test ratio achieved. */
+
+/* NINFO (output) INTEGER */
+/* Number of examples where INFO is nonzero. */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Get machine parameters */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Set up test case parameters */
+
+ vm1[0] = 1.;
+ vm1[1] = sqrt(smlnum);
+ vm1[2] = sqrt(vm1[1]);
+ vm1[3] = sqrt(bignum);
+ vm1[4] = sqrt(vm1[3]);
+
+ vm2[0] = 1.;
+ vm2[1] = sqrt(smlnum);
+ vm2[2] = sqrt(vm2[1]);
+ vm2[3] = sqrt(bignum);
+ vm2[4] = sqrt(vm2[3]);
+
+ vm3[0] = 1.;
+ vm3[1] = sqrt(smlnum);
+ vm3[2] = sqrt(vm3[1]);
+ vm3[3] = sqrt(bignum);
+ vm3[4] = sqrt(vm3[3]);
+
+ vm4[0] = 1.;
+ vm4[1] = sqrt(smlnum);
+ vm4[2] = sqrt(vm4[1]);
+ vm4[3] = sqrt(bignum);
+ vm4[4] = sqrt(vm4[3]);
+
+ vm5[0] = 1.;
+ vm5[1] = eps;
+ vm5[2] = sqrt(smlnum);
+
+/* Initalization */
+
+ *knt = 0;
+ *rmax = 0.;
+ *ninfo = 0;
+ smlnum /= eps;
+
+/* Begin test loop */
+
+ for (ivm5 = 1; ivm5 <= 3; ++ivm5) {
+ for (ivm4 = 1; ivm4 <= 5; ++ivm4) {
+ for (ivm3 = 1; ivm3 <= 5; ++ivm3) {
+ for (ivm2 = 1; ivm2 <= 5; ++ivm2) {
+ for (ivm1 = 1; ivm1 <= 5; ++ivm1) {
+ for (ndim = 1; ndim <= 6; ++ndim) {
+
+ n = idim[ndim - 1];
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ t[i__ + j * 10 - 11] = (doublereal) ival[
+ i__ + (j + ndim * 5) * 5 - 31] *
+ vm1[ivm1 - 1];
+ if (i__ >= j) {
+ t[i__ + j * 10 - 11] *= vm5[ivm5 - 1];
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+
+ w = vm2[ivm2 - 1] * 1.;
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ b[i__ - 1] = cos((doublereal) i__) * vm3[ivm3
+ - 1];
+/* L30: */
+ }
+
+ i__1 = n << 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__ - 1] = sin((doublereal) i__) * vm4[
+ ivm4 - 1];
+/* L40: */
+ }
+
+ norm = dlange_("1", &n, &n, t, &c__10, work);
+ k = idamax_(&n, b, &c__1);
+ normtb = norm + (d__1 = b[k - 1], abs(d__1)) +
+ abs(w);
+
+ dcopy_(&n, d__, &c__1, x, &c__1);
+ ++(*knt);
+ dlaqtr_(&c_false, &c_true, &n, t, &c__10, dum, &
+ dumm, &scale, x, work, &info);
+ if (info != 0) {
+ ++(*ninfo);
+ }
+
+/* || T*x - scale*d || / */
+/* max(ulp*||T||*||x||,smlnum/ulp*||T||,smlnum) */
+
+ dcopy_(&n, d__, &c__1, y, &c__1);
+ d__1 = -scale;
+ dgemv_("No transpose", &n, &n, &c_b25, t, &c__10,
+ x, &c__1, &d__1, y, &c__1);
+ xnorm = dasum_(&n, x, &c__1);
+ resid = dasum_(&n, y, &c__1);
+/* Computing MAX */
+ d__1 = smlnum, d__2 = smlnum / eps * norm, d__1 =
+ max(d__1,d__2), d__2 = norm * eps * xnorm;
+ domin = max(d__1,d__2);
+ resid /= domin;
+ if (resid > *rmax) {
+ *rmax = resid;
+ *lmax = *knt;
+ }
+
+ dcopy_(&n, d__, &c__1, x, &c__1);
+ ++(*knt);
+ dlaqtr_(&c_true, &c_true, &n, t, &c__10, dum, &
+ dumm, &scale, x, work, &info);
+ if (info != 0) {
+ ++(*ninfo);
+ }
+
+/* || T*x - scale*d || / */
+/* max(ulp*||T||*||x||,smlnum/ulp*||T||,smlnum) */
+
+ dcopy_(&n, d__, &c__1, y, &c__1);
+ d__1 = -scale;
+ dgemv_("Transpose", &n, &n, &c_b25, t, &c__10, x,
+ &c__1, &d__1, y, &c__1);
+ xnorm = dasum_(&n, x, &c__1);
+ resid = dasum_(&n, y, &c__1);
+/* Computing MAX */
+ d__1 = smlnum, d__2 = smlnum / eps * norm, d__1 =
+ max(d__1,d__2), d__2 = norm * eps * xnorm;
+ domin = max(d__1,d__2);
+ resid /= domin;
+ if (resid > *rmax) {
+ *rmax = resid;
+ *lmax = *knt;
+ }
+
+ i__1 = n << 1;
+ dcopy_(&i__1, d__, &c__1, x, &c__1);
+ ++(*knt);
+ dlaqtr_(&c_false, &c_false, &n, t, &c__10, b, &w,
+ &scale, x, work, &info);
+ if (info != 0) {
+ ++(*ninfo);
+ }
+
+/* ||(T+i*B)*(x1+i*x2) - scale*(d1+i*d2)|| / */
+/* max(ulp*(||T||+||B||)*(||x1||+||x2||), */
+/* smlnum/ulp * (||T||+||B||), smlnum ) */
+
+
+ i__1 = n << 1;
+ dcopy_(&i__1, d__, &c__1, y, &c__1);
+ y[0] = ddot_(&n, b, &c__1, &x[n], &c__1) + scale *
+ y[0];
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ y[i__ - 1] = w * x[i__ + n - 1] + scale * y[
+ i__ - 1];
+/* L50: */
+ }
+ dgemv_("No transpose", &n, &n, &c_b25, t, &c__10,
+ x, &c__1, &c_b59, y, &c__1);
+
+ y[n] = ddot_(&n, b, &c__1, x, &c__1) - scale * y[
+ n];
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ y[i__ + n - 1] = w * x[i__ - 1] - scale * y[
+ i__ + n - 1];
+/* L60: */
+ }
+ dgemv_("No transpose", &n, &n, &c_b25, t, &c__10,
+ &x[n], &c__1, &c_b25, &y[n], &c__1);
+
+ i__1 = n << 1;
+ resid = dasum_(&i__1, y, &c__1);
+/* Computing MAX */
+ i__1 = n << 1;
+ d__1 = smlnum, d__2 = smlnum / eps * normtb, d__1
+ = max(d__1,d__2), d__2 = eps * (normtb *
+ dasum_(&i__1, x, &c__1));
+ domin = max(d__1,d__2);
+ resid /= domin;
+ if (resid > *rmax) {
+ *rmax = resid;
+ *lmax = *knt;
+ }
+
+ i__1 = n << 1;
+ dcopy_(&i__1, d__, &c__1, x, &c__1);
+ ++(*knt);
+ dlaqtr_(&c_true, &c_false, &n, t, &c__10, b, &w, &
+ scale, x, work, &info);
+ if (info != 0) {
+ ++(*ninfo);
+ }
+
+/* ||(T+i*B)*(x1+i*x2) - scale*(d1+i*d2)|| / */
+/* max(ulp*(||T||+||B||)*(||x1||+||x2||), */
+/* smlnum/ulp * (||T||+||B||), smlnum ) */
+
+ i__1 = n << 1;
+ dcopy_(&i__1, d__, &c__1, y, &c__1);
+ y[0] = b[0] * x[n] - scale * y[0];
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ y[i__ - 1] = b[i__ - 1] * x[n] + w * x[i__ +
+ n - 1] - scale * y[i__ - 1];
+/* L70: */
+ }
+ dgemv_("Transpose", &n, &n, &c_b25, t, &c__10, x,
+ &c__1, &c_b25, y, &c__1);
+
+ y[n] = b[0] * x[0] + scale * y[n];
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ y[i__ + n - 1] = b[i__ - 1] * x[0] + w * x[
+ i__ - 1] + scale * y[i__ + n - 1];
+/* L80: */
+ }
+ dgemv_("Transpose", &n, &n, &c_b25, t, &c__10, &x[
+ n], &c__1, &c_b59, &y[n], &c__1);
+
+ i__1 = n << 1;
+ resid = dasum_(&i__1, y, &c__1);
+/* Computing MAX */
+ i__1 = n << 1;
+ d__1 = smlnum, d__2 = smlnum / eps * normtb, d__1
+ = max(d__1,d__2), d__2 = eps * (normtb *
+ dasum_(&i__1, x, &c__1));
+ domin = max(d__1,d__2);
+ resid /= domin;
+ if (resid > *rmax) {
+ *rmax = resid;
+ *lmax = *knt;
+ }
+
+/* L90: */
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+
+ return 0;
+
+/* End of DGET39 */
+
+} /* dget39_ */
diff --git a/TESTING/EIG/dget51.c b/TESTING/EIG/dget51.c
new file mode 100644
index 0000000..8aad14c
--- /dev/null
+++ b/TESTING/EIG/dget51.c
@@ -0,0 +1,262 @@
+/* dget51.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b9 = 1.;
+static doublereal c_b10 = 0.;
+static doublereal c_b13 = -1.;
+
+/* Subroutine */ int dget51_(integer *itype, integer *n, doublereal *a,
+ integer *lda, doublereal *b, integer *ldb, doublereal *u, integer *
+ ldu, doublereal *v, integer *ldv, doublereal *work, doublereal *
+ result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, u_dim1, u_offset, v_dim1,
+ v_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ doublereal ulp;
+ integer jcol;
+ doublereal unfl;
+ integer jrow, jdiag;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ doublereal anorm, wnorm;
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET51 generally checks a decomposition of the form */
+
+/* A = U B V' */
+
+/* where ' means transpose and U and V are orthogonal. */
+
+/* Specifically, if ITYPE=1 */
+
+/* RESULT = | A - U B V' | / ( |A| n ulp ) */
+
+/* If ITYPE=2, then: */
+
+/* RESULT = | A - B | / ( |A| n ulp ) */
+
+/* If ITYPE=3, then: */
+
+/* RESULT = | I - UU' | / ( n ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the type of tests to be performed. */
+/* =1: RESULT = | A - U B V' | / ( |A| n ulp ) */
+/* =2: RESULT = | A - B | / ( |A| n ulp ) */
+/* =3: RESULT = | I - UU' | / ( n ulp ) */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, DGET51 does nothing. */
+/* It must be at least zero. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA, N) */
+/* The original (unfactored) matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least N. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB, N) */
+/* The factored matrix. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. It must be at least 1 */
+/* and at least N. */
+
+/* U (input) DOUBLE PRECISION array, dimension (LDU, N) */
+/* The orthogonal matrix on the left-hand side in the */
+/* decomposition. */
+/* Not referenced if ITYPE=2 */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+
+/* V (input) DOUBLE PRECISION array, dimension (LDV, N) */
+/* The orthogonal matrix on the left-hand side in the */
+/* decomposition. */
+/* Not referenced if ITYPE=2 */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of V. LDV must be at least N and */
+/* at least 1. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N**2) */
+
+/* RESULT (output) DOUBLE PRECISION */
+/* The values computed by the test specified by ITYPE. The */
+/* value is currently limited to 1/ulp, to avoid overflow. */
+/* Errors are flagged by RESULT=10/ulp. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --work;
+
+ /* Function Body */
+ *result = 0.;
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Constants */
+
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+
+/* Some Error Checks */
+
+ if (*itype < 1 || *itype > 3) {
+ *result = 10. / ulp;
+ return 0;
+ }
+
+ if (*itype <= 2) {
+
+/* Tests scaled by the norm(A) */
+
+/* Computing MAX */
+ d__1 = dlange_("1", n, n, &a[a_offset], lda, &work[1]);
+ anorm = max(d__1,unfl);
+
+ if (*itype == 1) {
+
+/* ITYPE=1: Compute W = A - UBV' */
+
+ dlacpy_(" ", n, n, &a[a_offset], lda, &work[1], n);
+/* Computing 2nd power */
+ i__1 = *n;
+ dgemm_("N", "N", n, n, n, &c_b9, &u[u_offset], ldu, &b[b_offset],
+ ldb, &c_b10, &work[i__1 * i__1 + 1], n);
+
+/* Computing 2nd power */
+ i__1 = *n;
+ dgemm_("N", "C", n, n, n, &c_b13, &work[i__1 * i__1 + 1], n, &v[
+ v_offset], ldv, &c_b9, &work[1], n);
+
+ } else {
+
+/* ITYPE=2: Compute W = A - B */
+
+ dlacpy_(" ", n, n, &b[b_offset], ldb, &work[1], n);
+
+ i__1 = *n;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ i__2 = *n;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ work[jrow + *n * (jcol - 1)] -= a[jrow + jcol * a_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+ }
+
+/* Compute norm(W)/ ( ulp*norm(A) ) */
+
+/* Computing 2nd power */
+ i__1 = *n;
+ wnorm = dlange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]);
+
+ if (anorm > wnorm) {
+ *result = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.) {
+/* Computing MIN */
+ d__1 = wnorm, d__2 = *n * anorm;
+ *result = min(d__1,d__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
+ *result = min(d__1,d__2) / (*n * ulp);
+ }
+ }
+
+ } else {
+
+/* Tests not scaled by norm(A) */
+
+/* ITYPE=3: Compute UU' - I */
+
+ dgemm_("N", "C", n, n, n, &c_b9, &u[u_offset], ldu, &u[u_offset], ldu,
+ &c_b10, &work[1], n);
+
+ i__1 = *n;
+ for (jdiag = 1; jdiag <= i__1; ++jdiag) {
+ work[(*n + 1) * (jdiag - 1) + 1] += -1.;
+/* L30: */
+ }
+
+/* Computing MIN */
+/* Computing 2nd power */
+ i__1 = *n;
+ d__1 = dlange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]), d__2 = (doublereal) (*n);
+ *result = min(d__1,d__2) / (*n * ulp);
+ }
+
+ return 0;
+
+/* End of DGET51 */
+
+} /* dget51_ */
diff --git a/TESTING/EIG/dget52.c b/TESTING/EIG/dget52.c
new file mode 100644
index 0000000..f62a728
--- /dev/null
+++ b/TESTING/EIG/dget52.c
@@ -0,0 +1,397 @@
+/* dget52.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b12 = 0.;
+static doublereal c_b15 = 1.;
+
+/* Subroutine */ int dget52_(logical *left, integer *n, doublereal *a,
+ integer *lda, doublereal *b, integer *ldb, doublereal *e, integer *
+ lde, doublereal *alphar, doublereal *alphai, doublereal *beta,
+ doublereal *work, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, e_dim1, e_offset, i__1, i__2;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Local variables */
+ integer j;
+ doublereal ulp;
+ integer jvec;
+ doublereal temp1, acoef, scale, abmax, salfi, sbeta;
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ doublereal salfr, anorm, bnorm, enorm;
+ char trans[1];
+ doublereal bcoefi;
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ doublereal bcoefr, alfmax, safmin;
+ char normab[1];
+ doublereal safmax, betmax, enrmer;
+ logical ilcplx;
+ doublereal errnrm;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET52 does an eigenvector check for the generalized eigenvalue */
+/* problem. */
+
+/* The basic test for right eigenvectors is: */
+
+/* | b(j) A E(j) - a(j) B E(j) | */
+/* RESULT(1) = max ------------------------------- */
+/* j n ulp max( |b(j) A|, |a(j) B| ) */
+
+/* using the 1-norm. Here, a(j)/b(j) = w is the j-th generalized */
+/* eigenvalue of A - w B, or, equivalently, b(j)/a(j) = m is the j-th */
+/* generalized eigenvalue of m A - B. */
+
+/* For real eigenvalues, the test is straightforward. For complex */
+/* eigenvalues, E(j) and a(j) are complex, represented by */
+/* Er(j) + i*Ei(j) and ar(j) + i*ai(j), resp., so the test for that */
+/* eigenvector becomes */
+
+/* max( |Wr|, |Wi| ) */
+/* -------------------------------------------- */
+/* n ulp max( |b(j) A|, (|ar(j)|+|ai(j)|) |B| ) */
+
+/* where */
+
+/* Wr = b(j) A Er(j) - ar(j) B Er(j) + ai(j) B Ei(j) */
+
+/* Wi = b(j) A Ei(j) - ai(j) B Er(j) - ar(j) B Ei(j) */
+
+/* T T _ */
+/* For left eigenvectors, A , B , a, and b are used. */
+
+/* DGET52 also tests the normalization of E. Each eigenvector is */
+/* supposed to be normalized so that the maximum "absolute value" */
+/* of its elements is 1, where in this case, "absolute value" */
+/* of a complex value x is |Re(x)| + |Im(x)| ; let us call this */
+/* maximum "absolute value" norm of a vector v M(v). */
+/* if a(j)=b(j)=0, then the eigenvector is set to be the jth coordinate */
+/* vector. The normalization test is: */
+
+/* RESULT(2) = max | M(v(j)) - 1 | / ( n ulp ) */
+/* eigenvectors v(j) */
+
+/* Arguments */
+/* ========= */
+
+/* LEFT (input) LOGICAL */
+/* =.TRUE.: The eigenvectors in the columns of E are assumed */
+/* to be *left* eigenvectors. */
+/* =.FALSE.: The eigenvectors in the columns of E are assumed */
+/* to be *right* eigenvectors. */
+
+/* N (input) INTEGER */
+/* The size of the matrices. If it is zero, DGET52 does */
+/* nothing. It must be at least zero. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA, N) */
+/* The matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least N. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB, N) */
+/* The matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. It must be at least 1 */
+/* and at least N. */
+
+/* E (input) DOUBLE PRECISION array, dimension (LDE, N) */
+/* The matrix of eigenvectors. It must be O( 1 ). Complex */
+/* eigenvalues and eigenvectors always come in pairs, the */
+/* eigenvalue and its conjugate being stored in adjacent */
+/* elements of ALPHAR, ALPHAI, and BETA. Thus, if a(j)/b(j) */
+/* and a(j+1)/b(j+1) are a complex conjugate pair of */
+/* generalized eigenvalues, then E(,j) contains the real part */
+/* of the eigenvector and E(,j+1) contains the imaginary part. */
+/* Note that whether E(,j) is a real eigenvector or part of a */
+/* complex one is specified by whether ALPHAI(j) is zero or not. */
+
+/* LDE (input) INTEGER */
+/* The leading dimension of E. It must be at least 1 and at */
+/* least N. */
+
+/* ALPHAR (input) DOUBLE PRECISION array, dimension (N) */
+/* The real parts of the values a(j) as described above, which, */
+/* along with b(j), define the generalized eigenvalues. */
+/* Complex eigenvalues always come in complex conjugate pairs */
+/* a(j)/b(j) and a(j+1)/b(j+1), which are stored in adjacent */
+/* elements in ALPHAR, ALPHAI, and BETA. Thus, if the j-th */
+/* and (j+1)-st eigenvalues form a pair, ALPHAR(j+1)/BETA(j+1) */
+/* is assumed to be equal to ALPHAR(j)/BETA(j). */
+
+/* ALPHAI (input) DOUBLE PRECISION array, dimension (N) */
+/* The imaginary parts of the values a(j) as described above, */
+/* which, along with b(j), define the generalized eigenvalues. */
+/* If ALPHAI(j)=0, then the eigenvalue is real, otherwise it */
+/* is part of a complex conjugate pair. Complex eigenvalues */
+/* always come in complex conjugate pairs a(j)/b(j) and */
+/* a(j+1)/b(j+1), which are stored in adjacent elements in */
+/* ALPHAR, ALPHAI, and BETA. Thus, if the j-th and (j+1)-st */
+/* eigenvalues form a pair, ALPHAI(j+1)/BETA(j+1) is assumed to */
+/* be equal to -ALPHAI(j)/BETA(j). Also, nonzero values in */
+/* ALPHAI are assumed to always come in adjacent pairs. */
+
+/* BETA (input) DOUBLE PRECISION array, dimension (N) */
+/* The values b(j) as described above, which, along with a(j), */
+/* define the generalized eigenvalues. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N**2+N) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The values computed by the test described above. If A E or */
+/* B E is likely to overflow, then RESULT(1:2) is set to */
+/* 10 / ulp. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ e_dim1 = *lde;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ --work;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.;
+ result[2] = 0.;
+ if (*n <= 0) {
+ return 0;
+ }
+
+ safmin = dlamch_("Safe minimum");
+ safmax = 1. / safmin;
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+
+ if (*left) {
+ *(unsigned char *)trans = 'T';
+ *(unsigned char *)normab = 'I';
+ } else {
+ *(unsigned char *)trans = 'N';
+ *(unsigned char *)normab = 'O';
+ }
+
+/* Norm of A, B, and E: */
+
+/* Computing MAX */
+ d__1 = dlange_(normab, n, n, &a[a_offset], lda, &work[1]);
+ anorm = max(d__1,safmin);
+/* Computing MAX */
+ d__1 = dlange_(normab, n, n, &b[b_offset], ldb, &work[1]);
+ bnorm = max(d__1,safmin);
+/* Computing MAX */
+ d__1 = dlange_("O", n, n, &e[e_offset], lde, &work[1]);
+ enorm = max(d__1,ulp);
+ alfmax = safmax / max(1.,bnorm);
+ betmax = safmax / max(1.,anorm);
+
+/* Compute error matrix. */
+/* Column i = ( b(i) A - a(i) B ) E(i) / max( |a(i) B| |b(i) A| ) */
+
+ ilcplx = FALSE_;
+ i__1 = *n;
+ for (jvec = 1; jvec <= i__1; ++jvec) {
+ if (ilcplx) {
+
+/* 2nd Eigenvalue/-vector of pair -- do nothing */
+
+ ilcplx = FALSE_;
+ } else {
+ salfr = alphar[jvec];
+ salfi = alphai[jvec];
+ sbeta = beta[jvec];
+ if (salfi == 0.) {
+
+/* Real eigenvalue and -vector */
+
+/* Computing MAX */
+ d__1 = abs(salfr), d__2 = abs(sbeta);
+ abmax = max(d__1,d__2);
+ if (abs(salfr) > alfmax || abs(sbeta) > betmax || abmax < 1.)
+ {
+ scale = 1. / max(abmax,safmin);
+ salfr = scale * salfr;
+ sbeta = scale * sbeta;
+ }
+/* Computing MAX */
+ d__1 = abs(salfr) * bnorm, d__2 = abs(sbeta) * anorm, d__1 =
+ max(d__1,d__2);
+ scale = 1. / max(d__1,safmin);
+ acoef = scale * sbeta;
+ bcoefr = scale * salfr;
+ dgemv_(trans, n, n, &acoef, &a[a_offset], lda, &e[jvec *
+ e_dim1 + 1], &c__1, &c_b12, &work[*n * (jvec - 1) + 1]
+, &c__1);
+ d__1 = -bcoefr;
+ dgemv_(trans, n, n, &d__1, &b[b_offset], lda, &e[jvec *
+ e_dim1 + 1], &c__1, &c_b15, &work[*n * (jvec - 1) + 1]
+, &c__1);
+ } else {
+
+/* Complex conjugate pair */
+
+ ilcplx = TRUE_;
+ if (jvec == *n) {
+ result[1] = 10. / ulp;
+ return 0;
+ }
+/* Computing MAX */
+ d__1 = abs(salfr) + abs(salfi), d__2 = abs(sbeta);
+ abmax = max(d__1,d__2);
+ if (abs(salfr) + abs(salfi) > alfmax || abs(sbeta) > betmax ||
+ abmax < 1.) {
+ scale = 1. / max(abmax,safmin);
+ salfr = scale * salfr;
+ salfi = scale * salfi;
+ sbeta = scale * sbeta;
+ }
+/* Computing MAX */
+ d__1 = (abs(salfr) + abs(salfi)) * bnorm, d__2 = abs(sbeta) *
+ anorm, d__1 = max(d__1,d__2);
+ scale = 1. / max(d__1,safmin);
+ acoef = scale * sbeta;
+ bcoefr = scale * salfr;
+ bcoefi = scale * salfi;
+ if (*left) {
+ bcoefi = -bcoefi;
+ }
+
+ dgemv_(trans, n, n, &acoef, &a[a_offset], lda, &e[jvec *
+ e_dim1 + 1], &c__1, &c_b12, &work[*n * (jvec - 1) + 1]
+, &c__1);
+ d__1 = -bcoefr;
+ dgemv_(trans, n, n, &d__1, &b[b_offset], lda, &e[jvec *
+ e_dim1 + 1], &c__1, &c_b15, &work[*n * (jvec - 1) + 1]
+, &c__1);
+ dgemv_(trans, n, n, &bcoefi, &b[b_offset], lda, &e[(jvec + 1)
+ * e_dim1 + 1], &c__1, &c_b15, &work[*n * (jvec - 1) +
+ 1], &c__1);
+
+ dgemv_(trans, n, n, &acoef, &a[a_offset], lda, &e[(jvec + 1) *
+ e_dim1 + 1], &c__1, &c_b12, &work[*n * jvec + 1], &
+ c__1);
+ d__1 = -bcoefi;
+ dgemv_(trans, n, n, &d__1, &b[b_offset], lda, &e[jvec *
+ e_dim1 + 1], &c__1, &c_b15, &work[*n * jvec + 1], &
+ c__1);
+ d__1 = -bcoefr;
+ dgemv_(trans, n, n, &d__1, &b[b_offset], lda, &e[(jvec + 1) *
+ e_dim1 + 1], &c__1, &c_b15, &work[*n * jvec + 1], &
+ c__1);
+ }
+ }
+/* L10: */
+ }
+
+/* Computing 2nd power */
+ i__1 = *n;
+ errnrm = dlange_("One", n, n, &work[1], n, &work[i__1 * i__1 + 1]) / enorm;
+
+/* Compute RESULT(1) */
+
+ result[1] = errnrm / ulp;
+
+/* Normalization of E: */
+
+ enrmer = 0.;
+ ilcplx = FALSE_;
+ i__1 = *n;
+ for (jvec = 1; jvec <= i__1; ++jvec) {
+ if (ilcplx) {
+ ilcplx = FALSE_;
+ } else {
+ temp1 = 0.;
+ if (alphai[jvec] == 0.) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ d__2 = temp1, d__3 = (d__1 = e[j + jvec * e_dim1], abs(
+ d__1));
+ temp1 = max(d__2,d__3);
+/* L20: */
+ }
+/* Computing MAX */
+ d__1 = enrmer, d__2 = temp1 - 1.;
+ enrmer = max(d__1,d__2);
+ } else {
+ ilcplx = TRUE_;
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = e[j + jvec * e_dim1], abs(
+ d__1)) + (d__2 = e[j + (jvec + 1) * e_dim1], abs(
+ d__2));
+ temp1 = max(d__3,d__4);
+/* L30: */
+ }
+/* Computing MAX */
+ d__1 = enrmer, d__2 = temp1 - 1.;
+ enrmer = max(d__1,d__2);
+ }
+ }
+/* L40: */
+ }
+
+/* Compute RESULT(2) : the normalization error in E. */
+
+ result[2] = enrmer / ((doublereal) (*n) * ulp);
+
+ return 0;
+
+/* End of DGET52 */
+
+} /* dget52_ */
diff --git a/TESTING/EIG/dget53.c b/TESTING/EIG/dget53.c
new file mode 100644
index 0000000..3e70264
--- /dev/null
+++ b/TESTING/EIG/dget53.c
@@ -0,0 +1,232 @@
+/* dget53.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dget53_(doublereal *a, integer *lda, doublereal *b,
+ integer *ldb, doublereal *scale, doublereal *wr, doublereal *wi,
+ doublereal *result, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal s1, ci11, ci12, ci22, cr11, cr12, cr21, cr22, ulp, wis, wrs,
+ deti, absw, detr, temp, anorm, bnorm, cnorm;
+ extern doublereal dlamch_(char *);
+ doublereal cscale, scales, safmin, sigmin;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET53 checks the generalized eigenvalues computed by DLAG2. */
+
+/* The basic test for an eigenvalue is: */
+
+/* | det( s A - w B ) | */
+/* RESULT = --------------------------------------------------- */
+/* ulp max( s norm(A), |w| norm(B) )*norm( s A - w B ) */
+
+/* Two "safety checks" are performed: */
+
+/* (1) ulp*max( s*norm(A), |w|*norm(B) ) must be at least */
+/* safe_minimum. This insures that the test performed is */
+/* not essentially det(0*A + 0*B)=0. */
+
+/* (2) s*norm(A) + |w|*norm(B) must be less than 1/safe_minimum. */
+/* This insures that s*A - w*B will not overflow. */
+
+/* If these tests are not passed, then s and w are scaled and */
+/* tested anyway, if this is possible. */
+
+/* Arguments */
+/* ========= */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA, 2) */
+/* The 2x2 matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 2. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB, N) */
+/* The 2x2 upper-triangular matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. It must be at least 2. */
+
+/* SCALE (input) DOUBLE PRECISION */
+/* The "scale factor" s in the formula s A - w B . It is */
+/* assumed to be non-negative. */
+
+/* WR (input) DOUBLE PRECISION */
+/* The real part of the eigenvalue w in the formula */
+/* s A - w B . */
+
+/* WI (input) DOUBLE PRECISION */
+/* The imaginary part of the eigenvalue w in the formula */
+/* s A - w B . */
+
+/* RESULT (output) DOUBLE PRECISION */
+/* If INFO is 2 or less, the value computed by the test */
+/* described above. */
+/* If INFO=3, this will just be 1/ulp. */
+
+/* INFO (output) INTEGER */
+/* =0: The input data pass the "safety checks". */
+/* =1: s*norm(A) + |w|*norm(B) > 1/safe_minimum. */
+/* =2: ulp*max( s*norm(A), |w|*norm(B) ) < safe_minimum */
+/* =3: same as INFO=2, but s and w could not be scaled so */
+/* as to compute the test. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ *result = 0.;
+ scales = *scale;
+ wrs = *wr;
+ wis = *wi;
+
+/* Machine constants and norms */
+
+ safmin = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ absw = abs(wrs) + abs(wis);
+/* Computing MAX */
+ d__5 = (d__1 = a[a_dim1 + 1], abs(d__1)) + (d__2 = a[a_dim1 + 2], abs(
+ d__2)), d__6 = (d__3 = a[(a_dim1 << 1) + 1], abs(d__3)) + (d__4 =
+ a[(a_dim1 << 1) + 2], abs(d__4)), d__5 = max(d__5,d__6);
+ anorm = max(d__5,safmin);
+/* Computing MAX */
+ d__4 = (d__3 = b[b_dim1 + 1], abs(d__3)), d__5 = (d__1 = b[(b_dim1 << 1)
+ + 1], abs(d__1)) + (d__2 = b[(b_dim1 << 1) + 2], abs(d__2)), d__4
+ = max(d__4,d__5);
+ bnorm = max(d__4,safmin);
+
+/* Check for possible overflow. */
+
+ temp = safmin * bnorm * absw + safmin * anorm * scales;
+ if (temp >= 1.) {
+
+/* Scale down to avoid overflow */
+
+ *info = 1;
+ temp = 1. / temp;
+ scales *= temp;
+ wrs *= temp;
+ wis *= temp;
+ absw = abs(wrs) + abs(wis);
+ }
+/* Computing MAX */
+/* Computing MAX */
+ d__3 = scales * anorm, d__4 = absw * bnorm;
+ d__1 = ulp * max(d__3,d__4), d__2 = safmin * max(scales,absw);
+ s1 = max(d__1,d__2);
+
+/* Check for W and SCALE essentially zero. */
+
+ if (s1 < safmin) {
+ *info = 2;
+ if (scales < safmin && absw < safmin) {
+ *info = 3;
+ *result = 1. / ulp;
+ return 0;
+ }
+
+/* Scale up to avoid underflow */
+
+/* Computing MAX */
+ d__1 = scales * anorm + absw * bnorm;
+ temp = 1. / max(d__1,safmin);
+ scales *= temp;
+ wrs *= temp;
+ wis *= temp;
+ absw = abs(wrs) + abs(wis);
+/* Computing MAX */
+/* Computing MAX */
+ d__3 = scales * anorm, d__4 = absw * bnorm;
+ d__1 = ulp * max(d__3,d__4), d__2 = safmin * max(scales,absw);
+ s1 = max(d__1,d__2);
+ if (s1 < safmin) {
+ *info = 3;
+ *result = 1. / ulp;
+ return 0;
+ }
+ }
+
+/* Compute C = s A - w B */
+
+ cr11 = scales * a[a_dim1 + 1] - wrs * b[b_dim1 + 1];
+ ci11 = -wis * b[b_dim1 + 1];
+ cr21 = scales * a[a_dim1 + 2];
+ cr12 = scales * a[(a_dim1 << 1) + 1] - wrs * b[(b_dim1 << 1) + 1];
+ ci12 = -wis * b[(b_dim1 << 1) + 1];
+ cr22 = scales * a[(a_dim1 << 1) + 2] - wrs * b[(b_dim1 << 1) + 2];
+ ci22 = -wis * b[(b_dim1 << 1) + 2];
+
+/* Compute the smallest singular value of s A - w B: */
+
+/* |det( s A - w B )| */
+/* sigma_min = ------------------ */
+/* norm( s A - w B ) */
+
+/* Computing MAX */
+ d__1 = abs(cr11) + abs(ci11) + abs(cr21), d__2 = abs(cr12) + abs(ci12) +
+ abs(cr22) + abs(ci22), d__1 = max(d__1,d__2);
+ cnorm = max(d__1,safmin);
+ cscale = 1. / sqrt(cnorm);
+ detr = cscale * cr11 * (cscale * cr22) - cscale * ci11 * (cscale * ci22)
+ - cscale * cr12 * (cscale * cr21);
+ deti = cscale * cr11 * (cscale * ci22) + cscale * ci11 * (cscale * cr22)
+ - cscale * ci12 * (cscale * cr21);
+ sigmin = abs(detr) + abs(deti);
+ *result = sigmin / s1;
+ return 0;
+
+/* End of DGET53 */
+
+} /* dget53_ */
diff --git a/TESTING/EIG/dget54.c b/TESTING/EIG/dget54.c
new file mode 100644
index 0000000..c392639
--- /dev/null
+++ b/TESTING/EIG/dget54.c
@@ -0,0 +1,223 @@
+/* dget54.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b11 = 1.;
+static doublereal c_b12 = 0.;
+static doublereal c_b15 = -1.;
+
+/* Subroutine */ int dget54_(integer *n, doublereal *a, integer *lda,
+ doublereal *b, integer *ldb, doublereal *s, integer *lds, doublereal *
+ t, integer *ldt, doublereal *u, integer *ldu, doublereal *v, integer *
+ ldv, doublereal *work, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, s_dim1, s_offset, t_dim1,
+ t_offset, u_dim1, u_offset, v_dim1, v_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ doublereal dum[1], ulp, unfl;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ doublereal wnorm;
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ doublereal abnorm;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET54 checks a generalized decomposition of the form */
+
+/* A = U*S*V' and B = U*T* V' */
+
+/* where ' means transpose and U and V are orthogonal. */
+
+/* Specifically, */
+
+/* RESULT = ||( A - U*S*V', B - U*T*V' )|| / (||( A, B )||*n*ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, DGET54 does nothing. */
+/* It must be at least zero. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA, N) */
+/* The original (unfactored) matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least N. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB, N) */
+/* The original (unfactored) matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. It must be at least 1 */
+/* and at least N. */
+
+/* S (input) DOUBLE PRECISION array, dimension (LDS, N) */
+/* The factored matrix S. */
+
+/* LDS (input) INTEGER */
+/* The leading dimension of S. It must be at least 1 */
+/* and at least N. */
+
+/* T (input) DOUBLE PRECISION array, dimension (LDT, N) */
+/* The factored matrix T. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of T. It must be at least 1 */
+/* and at least N. */
+
+/* U (input) DOUBLE PRECISION array, dimension (LDU, N) */
+/* The orthogonal matrix on the left-hand side in the */
+/* decomposition. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+
+/* V (input) DOUBLE PRECISION array, dimension (LDV, N) */
+/* The orthogonal matrix on the left-hand side in the */
+/* decomposition. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of V. LDV must be at least N and */
+/* at least 1. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N**2) */
+
+/* RESULT (output) DOUBLE PRECISION */
+/* The value RESULT, It is currently limited to 1/ulp, to */
+/* avoid overflow. Errors are flagged by RESULT=10/ulp. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ s_dim1 = *lds;
+ s_offset = 1 + s_dim1;
+ s -= s_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --work;
+
+ /* Function Body */
+ *result = 0.;
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Constants */
+
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+
+/* compute the norm of (A,B) */
+
+ dlacpy_("Full", n, n, &a[a_offset], lda, &work[1], n);
+ dlacpy_("Full", n, n, &b[b_offset], ldb, &work[*n * *n + 1], n)
+ ;
+/* Computing MAX */
+ i__1 = *n << 1;
+ d__1 = dlange_("1", n, &i__1, &work[1], n, dum);
+ abnorm = max(d__1,unfl);
+
+/* Compute W1 = A - U*S*V', and put in the array WORK(1:N*N) */
+
+ dlacpy_(" ", n, n, &a[a_offset], lda, &work[1], n);
+ dgemm_("N", "N", n, n, n, &c_b11, &u[u_offset], ldu, &s[s_offset], lds, &
+ c_b12, &work[*n * *n + 1], n);
+
+ dgemm_("N", "C", n, n, n, &c_b15, &work[*n * *n + 1], n, &v[v_offset],
+ ldv, &c_b11, &work[1], n);
+
+/* Compute W2 = B - U*T*V', and put in the workarray W(N*N+1:2*N*N) */
+
+ dlacpy_(" ", n, n, &b[b_offset], ldb, &work[*n * *n + 1], n);
+ dgemm_("N", "N", n, n, n, &c_b11, &u[u_offset], ldu, &t[t_offset], ldt, &
+ c_b12, &work[(*n << 1) * *n + 1], n);
+
+ dgemm_("N", "C", n, n, n, &c_b15, &work[(*n << 1) * *n + 1], n, &v[
+ v_offset], ldv, &c_b11, &work[*n * *n + 1], n);
+
+/* Compute norm(W)/ ( ulp*norm((A,B)) ) */
+
+ i__1 = *n << 1;
+ wnorm = dlange_("1", n, &i__1, &work[1], n, dum);
+
+ if (abnorm > wnorm) {
+ *result = wnorm / abnorm / ((*n << 1) * ulp);
+ } else {
+ if (abnorm < 1.) {
+/* Computing MIN */
+ d__1 = wnorm, d__2 = (*n << 1) * abnorm;
+ *result = min(d__1,d__2) / abnorm / ((*n << 1) * ulp);
+ } else {
+/* Computing MIN */
+ d__1 = wnorm / abnorm, d__2 = (doublereal) (*n << 1);
+ *result = min(d__1,d__2) / ((*n << 1) * ulp);
+ }
+ }
+
+ return 0;
+
+/* End of DGET54 */
+
+} /* dget54_ */
diff --git a/TESTING/EIG/dglmts.c b/TESTING/EIG/dglmts.c
new file mode 100644
index 0000000..22e1b95
--- /dev/null
+++ b/TESTING/EIG/dglmts.c
@@ -0,0 +1,205 @@
+/* dglmts.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b13 = -1.;
+static doublereal c_b15 = 1.;
+
+/* Subroutine */ int dglmts_(integer *n, integer *m, integer *p, doublereal *
+ a, doublereal *af, integer *lda, doublereal *b, doublereal *bf,
+ integer *ldb, doublereal *d__, doublereal *df, doublereal *x,
+ doublereal *u, doublereal *work, integer *lwork, doublereal *rwork,
+ doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1,
+ bf_offset;
+ doublereal d__1;
+
+ /* Local variables */
+ doublereal eps;
+ integer info;
+ doublereal unfl;
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal anorm, bnorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ doublereal dnorm, xnorm, ynorm;
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dggglm_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *),
+ dlacpy_(char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGLMTS tests DGGGLM - a subroutine for solving the generalized */
+/* linear model problem. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices A and B. N >= 0. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of columns of the matrix B. P >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,M) */
+/* The N-by-M matrix A. */
+
+/* AF (workspace) DOUBLE PRECISION array, dimension (LDA,M) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF. LDA >= max(M,N). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,P) */
+/* The N-by-P matrix A. */
+
+/* BF (workspace) DOUBLE PRECISION array, dimension (LDB,P) */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the arrays B, BF. LDB >= max(P,N). */
+
+/* D (input) DOUBLE PRECISION array, dimension( N ) */
+/* On input, the left hand side of the GLM. */
+
+/* DF (workspace) DOUBLE PRECISION array, dimension( N ) */
+
+/* X (output) DOUBLE PRECISION array, dimension( M ) */
+/* solution vector X in the GLM problem. */
+
+/* U (output) DOUBLE PRECISION array, dimension( P ) */
+/* solution vector U in the GLM problem. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION */
+/* The test ratio: */
+/* norm( d - A*x - B*u ) */
+/* RESULT = ----------------------------------------- */
+/* (norm(A)+norm(B))*(norm(x)+norm(u))*EPS */
+
+/* ==================================================================== */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ bf_dim1 = *ldb;
+ bf_offset = 1 + bf_dim1;
+ bf -= bf_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --d__;
+ --df;
+ --x;
+ --u;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+/* Computing MAX */
+ d__1 = dlange_("1", n, m, &a[a_offset], lda, &rwork[1]);
+ anorm = max(d__1,unfl);
+/* Computing MAX */
+ d__1 = dlange_("1", n, p, &b[b_offset], ldb, &rwork[1]);
+ bnorm = max(d__1,unfl);
+
+/* Copy the matrices A and B to the arrays AF and BF, */
+/* and the vector D the array DF. */
+
+ dlacpy_("Full", n, m, &a[a_offset], lda, &af[af_offset], lda);
+ dlacpy_("Full", n, p, &b[b_offset], ldb, &bf[bf_offset], ldb);
+ dcopy_(n, &d__[1], &c__1, &df[1], &c__1);
+
+/* Solve GLM problem */
+
+ dggglm_(n, m, p, &af[af_offset], lda, &bf[bf_offset], ldb, &df[1], &x[1],
+ &u[1], &work[1], lwork, &info);
+
+/* Test the residual for the solution of LSE */
+
+/* norm( d - A*x - B*u ) */
+/* RESULT = ----------------------------------------- */
+/* (norm(A)+norm(B))*(norm(x)+norm(u))*EPS */
+
+ dcopy_(n, &d__[1], &c__1, &df[1], &c__1);
+ dgemv_("No transpose", n, m, &c_b13, &a[a_offset], lda, &x[1], &c__1, &
+ c_b15, &df[1], &c__1);
+
+ dgemv_("No transpose", n, p, &c_b13, &b[b_offset], ldb, &u[1], &c__1, &
+ c_b15, &df[1], &c__1);
+
+ dnorm = dasum_(n, &df[1], &c__1);
+ xnorm = dasum_(m, &x[1], &c__1) + dasum_(p, &u[1], &c__1);
+ ynorm = anorm + bnorm;
+
+ if (xnorm <= 0.) {
+ *result = 0.;
+ } else {
+ *result = dnorm / ynorm / xnorm / eps;
+ }
+
+ return 0;
+
+/* End of DGLMTS */
+
+} /* dglmts_ */
diff --git a/TESTING/EIG/dgqrts.c b/TESTING/EIG/dgqrts.c
new file mode 100644
index 0000000..e8b465b
--- /dev/null
+++ b/TESTING/EIG/dgqrts.c
@@ -0,0 +1,328 @@
+/* dgqrts.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b9 = -1e10;
+static doublereal c_b19 = 0.;
+static doublereal c_b30 = -1.;
+static doublereal c_b31 = 1.;
+
+/* Subroutine */ int dgqrts_(integer *n, integer *m, integer *p, doublereal *
+ a, doublereal *af, doublereal *q, doublereal *r__, integer *lda,
+ doublereal *taua, doublereal *b, doublereal *bf, doublereal *z__,
+ doublereal *t, doublereal *bwk, integer *ldb, doublereal *taub,
+ doublereal *work, integer *lwork, doublereal *rwork, doublereal *
+ result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1,
+ bf_offset, bwk_dim1, bwk_offset, q_dim1, q_offset, r_dim1,
+ r_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Local variables */
+ doublereal ulp;
+ integer info;
+ doublereal unfl;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ doublereal resid, anorm, bnorm;
+ extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dggqrf_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *), dlacpy_(char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dorgrq_(integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGQRTS tests DGGQRF, which computes the GQR factorization of an */
+/* N-by-M matrix A and a N-by-P matrix B: A = Q*R and B = Q*T*Z. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices A and B. N >= 0. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of columns of the matrix B. P >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,M) */
+/* The N-by-M matrix A. */
+
+/* AF (output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* Details of the GQR factorization of A and B, as returned */
+/* by DGGQRF, see SGGQRF for further details. */
+
+/* Q (output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The M-by-M orthogonal matrix Q. */
+
+/* R (workspace) DOUBLE PRECISION array, dimension (LDA,MAX(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, R and Q. */
+/* LDA >= max(M,N). */
+
+/* TAUA (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by DGGQRF. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,P) */
+/* On entry, the N-by-P matrix A. */
+
+/* BF (output) DOUBLE PRECISION array, dimension (LDB,N) */
+/* Details of the GQR factorization of A and B, as returned */
+/* by DGGQRF, see SGGQRF for further details. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDB,P) */
+/* The P-by-P orthogonal matrix Z. */
+
+/* T (workspace) DOUBLE PRECISION array, dimension (LDB,max(P,N)) */
+
+/* BWK (workspace) DOUBLE PRECISION array, dimension (LDB,N) */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the arrays B, BF, Z and T. */
+/* LDB >= max(P,N). */
+
+/* TAUB (output) DOUBLE PRECISION array, dimension (min(P,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by DGGRQF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK, LWORK >= max(N,M,P)**2. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(N,M,P)) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP) */
+/* RESULT(2) = norm( T*Z - Q'*B ) / (MAX(P,N)*norm(B)*ULP) */
+/* RESULT(3) = norm( I - Q'*Q ) / ( M*ULP ) */
+/* RESULT(4) = norm( I - Z'*Z ) / ( P*ULP ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --taua;
+ bwk_dim1 = *ldb;
+ bwk_offset = 1 + bwk_dim1;
+ bwk -= bwk_offset;
+ t_dim1 = *ldb;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ z_dim1 = *ldb;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ bf_dim1 = *ldb;
+ bf_offset = 1 + bf_dim1;
+ bf -= bf_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --taub;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ ulp = dlamch_("Precision");
+ unfl = dlamch_("Safe minimum");
+
+/* Copy the matrix A to the array AF. */
+
+ dlacpy_("Full", n, m, &a[a_offset], lda, &af[af_offset], lda);
+ dlacpy_("Full", n, p, &b[b_offset], ldb, &bf[bf_offset], ldb);
+
+/* Computing MAX */
+ d__1 = dlange_("1", n, m, &a[a_offset], lda, &rwork[1]);
+ anorm = max(d__1,unfl);
+/* Computing MAX */
+ d__1 = dlange_("1", n, p, &b[b_offset], ldb, &rwork[1]);
+ bnorm = max(d__1,unfl);
+
+/* Factorize the matrices A and B in the arrays AF and BF. */
+
+ dggqrf_(n, m, p, &af[af_offset], lda, &taua[1], &bf[bf_offset], ldb, &
+ taub[1], &work[1], lwork, &info);
+
+/* Generate the N-by-N matrix Q */
+
+ dlaset_("Full", n, n, &c_b9, &c_b9, &q[q_offset], lda);
+ i__1 = *n - 1;
+ dlacpy_("Lower", &i__1, m, &af[af_dim1 + 2], lda, &q[q_dim1 + 2], lda);
+ i__1 = min(*n,*m);
+ dorgqr_(n, n, &i__1, &q[q_offset], lda, &taua[1], &work[1], lwork, &info);
+
+/* Generate the P-by-P matrix Z */
+
+ dlaset_("Full", p, p, &c_b9, &c_b9, &z__[z_offset], ldb);
+ if (*n <= *p) {
+ if (*n > 0 && *n < *p) {
+ i__1 = *p - *n;
+ dlacpy_("Full", n, &i__1, &bf[bf_offset], ldb, &z__[*p - *n + 1 +
+ z_dim1], ldb);
+ }
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ dlacpy_("Lower", &i__1, &i__2, &bf[(*p - *n + 1) * bf_dim1 + 2],
+ ldb, &z__[*p - *n + 2 + (*p - *n + 1) * z_dim1], ldb);
+ }
+ } else {
+ if (*p > 1) {
+ i__1 = *p - 1;
+ i__2 = *p - 1;
+ dlacpy_("Lower", &i__1, &i__2, &bf[*n - *p + 2 + bf_dim1], ldb, &
+ z__[z_dim1 + 2], ldb);
+ }
+ }
+ i__1 = min(*n,*p);
+ dorgrq_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, &
+ info);
+
+/* Copy R */
+
+ dlaset_("Full", n, m, &c_b19, &c_b19, &r__[r_offset], lda);
+ dlacpy_("Upper", n, m, &af[af_offset], lda, &r__[r_offset], lda);
+
+/* Copy T */
+
+ dlaset_("Full", n, p, &c_b19, &c_b19, &t[t_offset], ldb);
+ if (*n <= *p) {
+ dlacpy_("Upper", n, n, &bf[(*p - *n + 1) * bf_dim1 + 1], ldb, &t[(*p
+ - *n + 1) * t_dim1 + 1], ldb);
+ } else {
+ i__1 = *n - *p;
+ dlacpy_("Full", &i__1, p, &bf[bf_offset], ldb, &t[t_offset], ldb);
+ dlacpy_("Upper", p, p, &bf[*n - *p + 1 + bf_dim1], ldb, &t[*n - *p +
+ 1 + t_dim1], ldb);
+ }
+
+/* Compute R - Q'*A */
+
+ dgemm_("Transpose", "No transpose", n, m, n, &c_b30, &q[q_offset], lda, &
+ a[a_offset], lda, &c_b31, &r__[r_offset], lda);
+
+/* Compute norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP ) . */
+
+ resid = dlange_("1", n, m, &r__[r_offset], lda, &rwork[1]);
+ if (anorm > 0.) {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ result[1] = resid / (doublereal) max(i__1,*n) / anorm / ulp;
+ } else {
+ result[1] = 0.;
+ }
+
+/* Compute T*Z - Q'*B */
+
+ dgemm_("No Transpose", "No transpose", n, p, p, &c_b31, &t[t_offset], ldb,
+ &z__[z_offset], ldb, &c_b19, &bwk[bwk_offset], ldb);
+ dgemm_("Transpose", "No transpose", n, p, n, &c_b30, &q[q_offset], lda, &
+ b[b_offset], ldb, &c_b31, &bwk[bwk_offset], ldb);
+
+/* Compute norm( T*Z - Q'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */
+
+ resid = dlange_("1", n, p, &bwk[bwk_offset], ldb, &rwork[1]);
+ if (bnorm > 0.) {
+/* Computing MAX */
+ i__1 = max(1,*p);
+ result[2] = resid / (doublereal) max(i__1,*n) / bnorm / ulp;
+ } else {
+ result[2] = 0.;
+ }
+
+/* Compute I - Q'*Q */
+
+ dlaset_("Full", n, n, &c_b19, &c_b31, &r__[r_offset], lda);
+ dsyrk_("Upper", "Transpose", n, n, &c_b30, &q[q_offset], lda, &c_b31, &
+ r__[r_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( N * ULP ) . */
+
+ resid = dlansy_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
+ result[3] = resid / (doublereal) max(1,*n) / ulp;
+
+/* Compute I - Z'*Z */
+
+ dlaset_("Full", p, p, &c_b19, &c_b31, &t[t_offset], ldb);
+ dsyrk_("Upper", "Transpose", p, p, &c_b30, &z__[z_offset], ldb, &c_b31, &
+ t[t_offset], ldb);
+
+/* Compute norm( I - Z'*Z ) / ( P*ULP ) . */
+
+ resid = dlansy_("1", "Upper", p, &t[t_offset], ldb, &rwork[1]);
+ result[4] = resid / (doublereal) max(1,*p) / ulp;
+
+ return 0;
+
+/* End of DGQRTS */
+
+} /* dgqrts_ */
diff --git a/TESTING/EIG/dgrqts.c b/TESTING/EIG/dgrqts.c
new file mode 100644
index 0000000..ac013fb
--- /dev/null
+++ b/TESTING/EIG/dgrqts.c
@@ -0,0 +1,331 @@
+/* dgrqts.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b9 = -1e10;
+static doublereal c_b19 = 0.;
+static doublereal c_b30 = -1.;
+static doublereal c_b31 = 1.;
+
+/* Subroutine */ int dgrqts_(integer *m, integer *p, integer *n, doublereal *
+ a, doublereal *af, doublereal *q, doublereal *r__, integer *lda,
+ doublereal *taua, doublereal *b, doublereal *bf, doublereal *z__,
+ doublereal *t, doublereal *bwk, integer *ldb, doublereal *taub,
+ doublereal *work, integer *lwork, doublereal *rwork, doublereal *
+ result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1,
+ bf_offset, bwk_dim1, bwk_offset, q_dim1, q_offset, r_dim1,
+ r_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Local variables */
+ doublereal ulp;
+ integer info;
+ doublereal unfl;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ doublereal resid, anorm, bnorm;
+ extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dggrqf_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *), dlacpy_(char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dorgrq_(integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGRQTS tests DGGRQF, which computes the GRQ factorization of an */
+/* M-by-N matrix A and a P-by-N matrix B: A = R*Q and B = Z*T*Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The M-by-N matrix A. */
+
+/* AF (output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* Details of the GRQ factorization of A and B, as returned */
+/* by DGGRQF, see SGGRQF for further details. */
+
+/* Q (output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The N-by-N orthogonal matrix Q. */
+
+/* R (workspace) DOUBLE PRECISION array, dimension (LDA,MAX(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, R and Q. */
+/* LDA >= max(M,N). */
+
+/* TAUA (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by DGGQRC. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix A. */
+
+/* BF (output) DOUBLE PRECISION array, dimension (LDB,N) */
+/* Details of the GQR factorization of A and B, as returned */
+/* by DGGRQF, see SGGRQF for further details. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDB,P) */
+/* The P-by-P orthogonal matrix Z. */
+
+/* T (workspace) DOUBLE PRECISION array, dimension (LDB,max(P,N)) */
+
+/* BWK (workspace) DOUBLE PRECISION array, dimension (LDB,N) */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the arrays B, BF, Z and T. */
+/* LDB >= max(P,N). */
+
+/* TAUB (output) DOUBLE PRECISION array, dimension (min(P,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by DGGRQF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK, LWORK >= max(M,P,N)**2. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP) */
+/* RESULT(2) = norm( T*Q - Z'*B ) / (MAX(P,N)*norm(B)*ULP) */
+/* RESULT(3) = norm( I - Q'*Q ) / ( N*ULP ) */
+/* RESULT(4) = norm( I - Z'*Z ) / ( P*ULP ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --taua;
+ bwk_dim1 = *ldb;
+ bwk_offset = 1 + bwk_dim1;
+ bwk -= bwk_offset;
+ t_dim1 = *ldb;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ z_dim1 = *ldb;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ bf_dim1 = *ldb;
+ bf_offset = 1 + bf_dim1;
+ bf -= bf_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --taub;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ ulp = dlamch_("Precision");
+ unfl = dlamch_("Safe minimum");
+
+/* Copy the matrix A to the array AF. */
+
+ dlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+ dlacpy_("Full", p, n, &b[b_offset], ldb, &bf[bf_offset], ldb);
+
+/* Computing MAX */
+ d__1 = dlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ anorm = max(d__1,unfl);
+/* Computing MAX */
+ d__1 = dlange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
+ bnorm = max(d__1,unfl);
+
+/* Factorize the matrices A and B in the arrays AF and BF. */
+
+ dggrqf_(m, p, n, &af[af_offset], lda, &taua[1], &bf[bf_offset], ldb, &
+ taub[1], &work[1], lwork, &info);
+
+/* Generate the N-by-N matrix Q */
+
+ dlaset_("Full", n, n, &c_b9, &c_b9, &q[q_offset], lda);
+ if (*m <= *n) {
+ if (*m > 0 && *m < *n) {
+ i__1 = *n - *m;
+ dlacpy_("Full", m, &i__1, &af[af_offset], lda, &q[*n - *m + 1 +
+ q_dim1], lda);
+ }
+ if (*m > 1) {
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ dlacpy_("Lower", &i__1, &i__2, &af[(*n - *m + 1) * af_dim1 + 2],
+ lda, &q[*n - *m + 2 + (*n - *m + 1) * q_dim1], lda);
+ }
+ } else {
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ dlacpy_("Lower", &i__1, &i__2, &af[*m - *n + 2 + af_dim1], lda, &
+ q[q_dim1 + 2], lda);
+ }
+ }
+ i__1 = min(*m,*n);
+ dorgrq_(n, n, &i__1, &q[q_offset], lda, &taua[1], &work[1], lwork, &info);
+
+/* Generate the P-by-P matrix Z */
+
+ dlaset_("Full", p, p, &c_b9, &c_b9, &z__[z_offset], ldb);
+ if (*p > 1) {
+ i__1 = *p - 1;
+ dlacpy_("Lower", &i__1, n, &bf[bf_dim1 + 2], ldb, &z__[z_dim1 + 2],
+ ldb);
+ }
+ i__1 = min(*p,*n);
+ dorgqr_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, &
+ info);
+
+/* Copy R */
+
+ dlaset_("Full", m, n, &c_b19, &c_b19, &r__[r_offset], lda);
+ if (*m <= *n) {
+ dlacpy_("Upper", m, m, &af[(*n - *m + 1) * af_dim1 + 1], lda, &r__[(*
+ n - *m + 1) * r_dim1 + 1], lda);
+ } else {
+ i__1 = *m - *n;
+ dlacpy_("Full", &i__1, n, &af[af_offset], lda, &r__[r_offset], lda);
+ dlacpy_("Upper", n, n, &af[*m - *n + 1 + af_dim1], lda, &r__[*m - *n
+ + 1 + r_dim1], lda);
+ }
+
+/* Copy T */
+
+ dlaset_("Full", p, n, &c_b19, &c_b19, &t[t_offset], ldb);
+ dlacpy_("Upper", p, n, &bf[bf_offset], ldb, &t[t_offset], ldb);
+
+/* Compute R - A*Q' */
+
+ dgemm_("No transpose", "Transpose", m, n, n, &c_b30, &a[a_offset], lda, &
+ q[q_offset], lda, &c_b31, &r__[r_offset], lda);
+
+/* Compute norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP ) . */
+
+ resid = dlange_("1", m, n, &r__[r_offset], lda, &rwork[1]);
+ if (anorm > 0.) {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ result[1] = resid / (doublereal) max(i__1,*n) / anorm / ulp;
+ } else {
+ result[1] = 0.;
+ }
+
+/* Compute T*Q - Z'*B */
+
+ dgemm_("Transpose", "No transpose", p, n, p, &c_b31, &z__[z_offset], ldb,
+ &b[b_offset], ldb, &c_b19, &bwk[bwk_offset], ldb);
+ dgemm_("No transpose", "No transpose", p, n, n, &c_b31, &t[t_offset], ldb,
+ &q[q_offset], lda, &c_b30, &bwk[bwk_offset], ldb);
+
+/* Compute norm( T*Q - Z'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */
+
+ resid = dlange_("1", p, n, &bwk[bwk_offset], ldb, &rwork[1]);
+ if (bnorm > 0.) {
+/* Computing MAX */
+ i__1 = max(1,*p);
+ result[2] = resid / (doublereal) max(i__1,*m) / bnorm / ulp;
+ } else {
+ result[2] = 0.;
+ }
+
+/* Compute I - Q*Q' */
+
+ dlaset_("Full", n, n, &c_b19, &c_b31, &r__[r_offset], lda);
+ dsyrk_("Upper", "No Transpose", n, n, &c_b30, &q[q_offset], lda, &c_b31, &
+ r__[r_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( N * ULP ) . */
+
+ resid = dlansy_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
+ result[3] = resid / (doublereal) max(1,*n) / ulp;
+
+/* Compute I - Z'*Z */
+
+ dlaset_("Full", p, p, &c_b19, &c_b31, &t[t_offset], ldb);
+ dsyrk_("Upper", "Transpose", p, p, &c_b30, &z__[z_offset], ldb, &c_b31, &
+ t[t_offset], ldb);
+
+/* Compute norm( I - Z'*Z ) / ( P*ULP ) . */
+
+ resid = dlansy_("1", "Upper", p, &t[t_offset], ldb, &rwork[1]);
+ result[4] = resid / (doublereal) max(1,*p) / ulp;
+
+ return 0;
+
+/* End of DGRQTS */
+
+} /* dgrqts_ */
diff --git a/TESTING/EIG/dgsvts.c b/TESTING/EIG/dgsvts.c
new file mode 100644
index 0000000..c2fff56
--- /dev/null
+++ b/TESTING/EIG/dgsvts.c
@@ -0,0 +1,399 @@
+/* dgsvts.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b17 = 1.;
+static doublereal c_b18 = 0.;
+static doublereal c_b44 = -1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dgsvts_(integer *m, integer *p, integer *n, doublereal *
+ a, doublereal *af, integer *lda, doublereal *b, doublereal *bf,
+ integer *ldb, doublereal *u, integer *ldu, doublereal *v, integer *
+ ldv, doublereal *q, integer *ldq, doublereal *alpha, doublereal *beta,
+ doublereal *r__, integer *ldr, integer *iwork, doublereal *work,
+ integer *lwork, doublereal *rwork, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1,
+ bf_offset, q_dim1, q_offset, r_dim1, r_offset, u_dim1, u_offset,
+ v_dim1, v_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, j, k, l;
+ doublereal ulp;
+ integer info;
+ doublereal unfl, temp;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ doublereal resid, anorm, bnorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dsyrk_(char *, char *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), dggsvd_(char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *, doublereal
+ *, integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ doublereal ulpinv;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGSVTS tests DGGSVD, which computes the GSVD of an M-by-N matrix A */
+/* and a P-by-N matrix B: */
+/* U'*A*Q = D1*R and V'*B*Q = D2*R. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,M) */
+/* The M-by-N matrix A. */
+
+/* AF (output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* Details of the GSVD of A and B, as returned by DGGSVD, */
+/* see DGGSVD for further details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A and AF. */
+/* LDA >= max( 1,M ). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,P) */
+/* On entry, the P-by-N matrix B. */
+
+/* BF (output) DOUBLE PRECISION array, dimension (LDB,N) */
+/* Details of the GSVD of A and B, as returned by DGGSVD, */
+/* see DGGSVD for further details. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the arrays B and BF. */
+/* LDB >= max(1,P). */
+
+/* U (output) DOUBLE PRECISION array, dimension(LDU,M) */
+/* The M by M orthogonal matrix U. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M). */
+
+/* V (output) DOUBLE PRECISION array, dimension(LDV,M) */
+/* The P by P orthogonal matrix V. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. LDV >= max(1,P). */
+
+/* Q (output) DOUBLE PRECISION array, dimension(LDQ,N) */
+/* The N by N orthogonal matrix Q. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* ALPHA (output) DOUBLE PRECISION array, dimension (N) */
+/* BETA (output) DOUBLE PRECISION array, dimension (N) */
+/* The generalized singular value pairs of A and B, the */
+/* ``diagonal'' matrices D1 and D2 are constructed from */
+/* ALPHA and BETA, see subroutine DGGSVD for details. */
+
+/* R (output) DOUBLE PRECISION array, dimension(LDQ,N) */
+/* The upper triangular matrix R. */
+
+/* LDR (input) INTEGER */
+/* The leading dimension of the array R. LDR >= max(1,N). */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK, */
+/* LWORK >= max(M,P,N)*max(M,P,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(M,P,N)) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (6) */
+/* The test ratios: */
+/* RESULT(1) = norm( U'*A*Q - D1*R ) / ( MAX(M,N)*norm(A)*ULP) */
+/* RESULT(2) = norm( V'*B*Q - D2*R ) / ( MAX(P,N)*norm(B)*ULP) */
+/* RESULT(3) = norm( I - U'*U ) / ( M*ULP ) */
+/* RESULT(4) = norm( I - V'*V ) / ( P*ULP ) */
+/* RESULT(5) = norm( I - Q'*Q ) / ( N*ULP ) */
+/* RESULT(6) = 0 if ALPHA is in decreasing order; */
+/* = ULPINV otherwise. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ bf_dim1 = *ldb;
+ bf_offset = 1 + bf_dim1;
+ bf -= bf_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --alpha;
+ --beta;
+ r_dim1 = *ldr;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ --iwork;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ ulp = dlamch_("Precision");
+ ulpinv = 1. / ulp;
+ unfl = dlamch_("Safe minimum");
+
+/* Copy the matrix A to the array AF. */
+
+ dlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+ dlacpy_("Full", p, n, &b[b_offset], ldb, &bf[bf_offset], ldb);
+
+/* Computing MAX */
+ d__1 = dlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ anorm = max(d__1,unfl);
+/* Computing MAX */
+ d__1 = dlange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
+ bnorm = max(d__1,unfl);
+
+/* Factorize the matrices A and B in the arrays AF and BF. */
+
+ dggsvd_("U", "V", "Q", m, n, p, &k, &l, &af[af_offset], lda, &bf[
+ bf_offset], ldb, &alpha[1], &beta[1], &u[u_offset], ldu, &v[
+ v_offset], ldv, &q[q_offset], ldq, &work[1], &iwork[1], &info);
+
+/* Copy R */
+
+/* Computing MIN */
+ i__2 = k + l;
+ i__1 = min(i__2,*m);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = k + l;
+ for (j = i__; j <= i__2; ++j) {
+ r__[i__ + j * r_dim1] = af[i__ + (*n - k - l + j) * af_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+
+ if (*m - k - l < 0) {
+ i__1 = k + l;
+ for (i__ = *m + 1; i__ <= i__1; ++i__) {
+ i__2 = k + l;
+ for (j = i__; j <= i__2; ++j) {
+ r__[i__ + j * r_dim1] = bf[i__ - k + (*n - k - l + j) *
+ bf_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+/* Compute A:= U'*A*Q - D1*R */
+
+ dgemm_("No transpose", "No transpose", m, n, n, &c_b17, &a[a_offset], lda,
+ &q[q_offset], ldq, &c_b18, &work[1], lda)
+ ;
+
+ dgemm_("Transpose", "No transpose", m, n, m, &c_b17, &u[u_offset], ldu, &
+ work[1], lda, &c_b18, &a[a_offset], lda);
+
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = k + l;
+ for (j = i__; j <= i__2; ++j) {
+ a[i__ + (*n - k - l + j) * a_dim1] -= r__[i__ + j * r_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* Computing MIN */
+ i__2 = k + l;
+ i__1 = min(i__2,*m);
+ for (i__ = k + 1; i__ <= i__1; ++i__) {
+ i__2 = k + l;
+ for (j = i__; j <= i__2; ++j) {
+ a[i__ + (*n - k - l + j) * a_dim1] -= alpha[i__] * r__[i__ + j *
+ r_dim1];
+/* L70: */
+ }
+/* L80: */
+ }
+
+/* Compute norm( U'*A*Q - D1*R ) / ( MAX(1,M,N)*norm(A)*ULP ) . */
+
+ resid = dlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+
+ if (anorm > 0.) {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ result[1] = resid / (doublereal) max(i__1,*n) / anorm / ulp;
+ } else {
+ result[1] = 0.;
+ }
+
+/* Compute B := V'*B*Q - D2*R */
+
+ dgemm_("No transpose", "No transpose", p, n, n, &c_b17, &b[b_offset], ldb,
+ &q[q_offset], ldq, &c_b18, &work[1], ldb)
+ ;
+
+ dgemm_("Transpose", "No transpose", p, n, p, &c_b17, &v[v_offset], ldv, &
+ work[1], ldb, &c_b18, &b[b_offset], ldb);
+
+ i__1 = l;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = l;
+ for (j = i__; j <= i__2; ++j) {
+ b[i__ + (*n - l + j) * b_dim1] -= beta[k + i__] * r__[k + i__ + (
+ k + j) * r_dim1];
+/* L90: */
+ }
+/* L100: */
+ }
+
+/* Compute norm( V'*B*Q - D2*R ) / ( MAX(P,N)*norm(B)*ULP ) . */
+
+ resid = dlange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
+ if (bnorm > 0.) {
+/* Computing MAX */
+ i__1 = max(1,*p);
+ result[2] = resid / (doublereal) max(i__1,*n) / bnorm / ulp;
+ } else {
+ result[2] = 0.;
+ }
+
+/* Compute I - U'*U */
+
+ dlaset_("Full", m, m, &c_b18, &c_b17, &work[1], ldq);
+ dsyrk_("Upper", "Transpose", m, m, &c_b44, &u[u_offset], ldu, &c_b17, &
+ work[1], ldu);
+
+/* Compute norm( I - U'*U ) / ( M * ULP ) . */
+
+ resid = dlansy_("1", "Upper", m, &work[1], ldu, &rwork[1]);
+ result[3] = resid / (doublereal) max(1,*m) / ulp;
+
+/* Compute I - V'*V */
+
+ dlaset_("Full", p, p, &c_b18, &c_b17, &work[1], ldv);
+ dsyrk_("Upper", "Transpose", p, p, &c_b44, &v[v_offset], ldv, &c_b17, &
+ work[1], ldv);
+
+/* Compute norm( I - V'*V ) / ( P * ULP ) . */
+
+ resid = dlansy_("1", "Upper", p, &work[1], ldv, &rwork[1]);
+ result[4] = resid / (doublereal) max(1,*p) / ulp;
+
+/* Compute I - Q'*Q */
+
+ dlaset_("Full", n, n, &c_b18, &c_b17, &work[1], ldq);
+ dsyrk_("Upper", "Transpose", n, n, &c_b44, &q[q_offset], ldq, &c_b17, &
+ work[1], ldq);
+
+/* Compute norm( I - Q'*Q ) / ( N * ULP ) . */
+
+ resid = dlansy_("1", "Upper", n, &work[1], ldq, &rwork[1]);
+ result[5] = resid / (doublereal) max(1,*n) / ulp;
+
+/* Check sorting */
+
+ dcopy_(n, &alpha[1], &c__1, &work[1], &c__1);
+/* Computing MIN */
+ i__2 = k + l;
+ i__1 = min(i__2,*m);
+ for (i__ = k + 1; i__ <= i__1; ++i__) {
+ j = iwork[i__];
+ if (i__ != j) {
+ temp = work[i__];
+ work[i__] = work[j];
+ work[j] = temp;
+ }
+/* L110: */
+ }
+
+ result[6] = 0.;
+/* Computing MIN */
+ i__2 = k + l;
+ i__1 = min(i__2,*m) - 1;
+ for (i__ = k + 1; i__ <= i__1; ++i__) {
+ if (work[i__] < work[i__ + 1]) {
+ result[6] = ulpinv;
+ }
+/* L120: */
+ }
+
+ return 0;
+
+/* End of DGSVTS */
+
+} /* dgsvts_ */
diff --git a/TESTING/EIG/dhst01.c b/TESTING/EIG/dhst01.c
new file mode 100644
index 0000000..1602ddf
--- /dev/null
+++ b/TESTING/EIG/dhst01.c
@@ -0,0 +1,192 @@
+/* dhst01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b7 = 1.;
+static doublereal c_b8 = 0.;
+static doublereal c_b11 = -1.;
+
+/* Subroutine */ int dhst01_(integer *n, integer *ilo, integer *ihi,
+ doublereal *a, integer *lda, doublereal *h__, integer *ldh,
+ doublereal *q, integer *ldq, doublereal *work, integer *lwork,
+ doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, q_dim1, q_offset;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ doublereal eps, unfl, ovfl;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *),
+ dort01_(char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *);
+ doublereal anorm, wnorm;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ integer ldwork;
+ doublereal smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DHST01 tests the reduction of a general matrix A to upper Hessenberg */
+/* form: A = Q*H*Q'. Two test ratios are computed; */
+
+/* RESULT(1) = norm( A - Q*H*Q' ) / ( norm(A) * N * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( N * EPS ) */
+
+/* The matrix Q is assumed to be given explicitly as it would be */
+/* following DGEHRD + DORGHR. */
+
+/* In this version, ILO and IHI are not used and are assumed to be 1 and */
+/* N, respectively. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* A is assumed to be upper triangular in rows and columns */
+/* 1:ILO-1 and IHI+1:N, so Q differs from the identity only in */
+/* rows and columns ILO+1:IHI. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The original n by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* H (input) DOUBLE PRECISION array, dimension (LDH,N) */
+/* The upper Hessenberg matrix H from the reduction A = Q*H*Q' */
+/* as computed by DGEHRD. H is assumed to be zero below the */
+/* first subdiagonal. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH >= max(1,N). */
+
+/* Q (input) DOUBLE PRECISION array, dimension (LDQ,N) */
+/* The orthogonal matrix Q from the reduction A = Q*H*Q' as */
+/* computed by DGEHRD + DORGHR. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= 2*N*N. */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* RESULT(1) = norm( A - Q*H*Q' ) / ( norm(A) * N * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( N * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+ --result;
+
+ /* Function Body */
+ if (*n <= 0) {
+ result[1] = 0.;
+ result[2] = 0.;
+ return 0;
+ }
+
+ unfl = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ ovfl = 1. / unfl;
+ dlabad_(&unfl, &ovfl);
+ smlnum = unfl * *n / eps;
+
+/* Test 1: Compute norm( A - Q*H*Q' ) / ( norm(A) * N * EPS ) */
+
+/* Copy A to WORK */
+
+ ldwork = max(1,*n);
+ dlacpy_(" ", n, n, &a[a_offset], lda, &work[1], &ldwork);
+
+/* Compute Q*H */
+
+ dgemm_("No transpose", "No transpose", n, n, n, &c_b7, &q[q_offset], ldq,
+ &h__[h_offset], ldh, &c_b8, &work[ldwork * *n + 1], &ldwork);
+
+/* Compute A - Q*H*Q' */
+
+ dgemm_("No transpose", "Transpose", n, n, n, &c_b11, &work[ldwork * *n +
+ 1], &ldwork, &q[q_offset], ldq, &c_b7, &work[1], &ldwork);
+
+/* Computing MAX */
+ d__1 = dlange_("1", n, n, &a[a_offset], lda, &work[ldwork * *n + 1]);
+ anorm = max(d__1,unfl);
+ wnorm = dlange_("1", n, n, &work[1], &ldwork, &work[ldwork * *n + 1]);
+
+/* Note that RESULT(1) cannot overflow and is bounded by 1/(N*EPS) */
+
+/* Computing MAX */
+ d__1 = smlnum, d__2 = anorm * eps;
+ result[1] = min(wnorm,anorm) / max(d__1,d__2) / *n;
+
+/* Test 2: Compute norm( I - Q'*Q ) / ( N * EPS ) */
+
+ dort01_("Columns", n, n, &q[q_offset], ldq, &work[1], lwork, &result[2]);
+
+ return 0;
+
+/* End of DHST01 */
+
+} /* dhst01_ */
diff --git a/TESTING/EIG/dlafts.c b/TESTING/EIG/dlafts.c
new file mode 100644
index 0000000..3b3b6f4
--- /dev/null
+++ b/TESTING/EIG/dlafts.c
@@ -0,0 +1,221 @@
+/* dlafts.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__4 = 4;
+
+/* Subroutine */ int dlafts_(char *type__, integer *m, integer *n, integer *
+ imat, integer *ntests, doublereal *result, integer *iseed, doublereal
+ *thresh, integer *iounit, integer *ie)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
+ ",0p,f8.2)";
+ static char fmt_9998[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
+ ",1p,d10.3)";
+ static char fmt_9997[] = "(1x,i5,\002 x\002,i5,\002 matrix, type=\002,"
+ "i2,\002, s\002,\002eed=\002,3(i4,\002,\002),i4,\002: result \002"
+ ",i3,\002 is\002,0p,f8.2)";
+ static char fmt_9996[] = "(1x,i5,\002 x\002,i5,\002 matrix, type=\002,"
+ "i2,\002, s\002,\002eed=\002,3(i4,\002,\002),i4,\002: result \002"
+ ",i3,\002 is\002,1p,d10.3)";
+
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer k;
+ extern /* Subroutine */ int dlahd2_(integer *, char *);
+
+ /* Fortran I/O blocks */
+ static cilist io___2 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___3 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___4 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___5 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* -- LAPACK auxiliary test routine (version 3.1.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* April 2009 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAFTS tests the result vector against the threshold value to */
+/* see which tests for this matrix type failed to pass the threshold. */
+/* Output is to the file given by unit IOUNIT. */
+
+/* Arguments */
+/* ========= */
+
+/* TYPE - CHARACTER*3 */
+/* On entry, TYPE specifies the matrix type to be used in the */
+/* printed messages. */
+/* Not modified. */
+
+/* N - INTEGER */
+/* On entry, N specifies the order of the test matrix. */
+/* Not modified. */
+
+/* IMAT - INTEGER */
+/* On entry, IMAT specifies the type of the test matrix. */
+/* A listing of the different types is printed by DLAHD2 */
+/* to the output file if a test fails to pass the threshold. */
+/* Not modified. */
+
+/* NTESTS - INTEGER */
+/* On entry, NTESTS is the number of tests performed on the */
+/* subroutines in the path given by TYPE. */
+/* Not modified. */
+
+/* RESULT - DOUBLE PRECISION array of dimension( NTESTS ) */
+/* On entry, RESULT contains the test ratios from the tests */
+/* performed in the calling program. */
+/* Not modified. */
+
+/* ISEED - INTEGER array of dimension( 4 ) */
+/* Contains the random seed that generated the matrix used */
+/* for the tests whose ratios are in RESULT. */
+/* Not modified. */
+
+/* THRESH - DOUBLE PRECISION */
+/* On entry, THRESH specifies the acceptable threshold of the */
+/* test ratios. If RESULT( K ) > THRESH, then the K-th test */
+/* did not pass the threshold and a message will be printed. */
+/* Not modified. */
+
+/* IOUNIT - INTEGER */
+/* On entry, IOUNIT specifies the unit number of the file */
+/* to which the messages are printed. */
+/* Not modified. */
+
+/* IE - INTEGER */
+/* On entry, IE contains the number of tests which have */
+/* failed to pass the threshold so far. */
+/* Updated on exit if any of the ratios in RESULT also fail. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iseed;
+ --result;
+
+ /* Function Body */
+ if (*m == *n) {
+
+/* Output for square matrices: */
+
+ i__1 = *ntests;
+ for (k = 1; k <= i__1; ++k) {
+ if (result[k] >= *thresh) {
+
+/* If this is the first test to fail, call DLAHD2 */
+/* to print a header to the data file. */
+
+ if (*ie == 0) {
+ dlahd2_(iounit, type__);
+ }
+ ++(*ie);
+ if (result[k] < 1e4) {
+ io___2.ciunit = *iounit;
+ s_wsfe(&io___2);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ } else {
+ io___3.ciunit = *iounit;
+ s_wsfe(&io___3);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+ }
+/* L10: */
+ }
+ } else {
+
+/* Output for rectangular matrices */
+
+ i__1 = *ntests;
+ for (k = 1; k <= i__1; ++k) {
+ if (result[k] >= *thresh) {
+
+/* If this is the first test to fail, call DLAHD2 */
+/* to print a header to the data file. */
+
+ if (*ie == 0) {
+ dlahd2_(iounit, type__);
+ }
+ ++(*ie);
+ if (result[k] < 1e4) {
+ io___4.ciunit = *iounit;
+ s_wsfe(&io___4);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ } else {
+ io___5.ciunit = *iounit;
+ s_wsfe(&io___5);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+ }
+/* L20: */
+ }
+
+ }
+ return 0;
+
+/* End of DLAFTS */
+
+} /* dlafts_ */
diff --git a/TESTING/EIG/dlahd2.c b/TESTING/EIG/dlahd2.c
new file mode 100644
index 0000000..d2c136b
--- /dev/null
+++ b/TESTING/EIG/dlahd2.c
@@ -0,0 +1,678 @@
+/* dlahd2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int dlahd2_(integer *iounit, char *path)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002: no header available\002)";
+ static char fmt_9998[] = "(/1x,a3,\002 -- Real Non-symmetric eigenvalue "
+ "problem\002)";
+ static char fmt_9988[] = "(\002 Matrix types (see xCHKHS for details):"
+ " \002)";
+ static char fmt_9987[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 \002,\002 5=Diagonal: geom"
+ "etr. spaced entries.\002,/\002 2=Identity matrix. "
+ " \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
+ "/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
+ " 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
+ "l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
+ "ll, evenly spaced.\002)";
+ static char fmt_9986[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
+ " 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
+ "l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
+ "d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
+ "red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
+ "vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,a6,"
+ "/\002 12=Well-cond., random complex \002,a6,\002 \002,\002 17="
+ "Ill-cond., large rand. complx \002,a4,/\002 13=Ill-condi\002,"
+ "\002tioned, evenly spaced. \002,\002 18=Ill-cond., small ran"
+ "d.\002,\002 complx \002,a4)";
+ static char fmt_9985[] = "(\002 19=Matrix with random O(1) entries. "
+ " \002,\002 21=Matrix \002,\002with small random entries.\002,"
+ "/\002 20=Matrix with large ran\002,\002dom entries. \002)";
+ static char fmt_9984[] = "(/\002 Tests performed: \002,\002(H is Hesse"
+ "nberg, T is Schur,\002,\002 U and Z are \002,a,\002,\002,/20x,a"
+ ",\002, W is a diagonal matr\002,\002ix of eigenvalues,\002,/20x"
+ ",\002L and R are the left and rig\002,\002ht eigenvector matrice"
+ "s)\002,/\002 1 = | A - U H U\002,a1,\002 |\002,\002 / ( |A| n u"
+ "lp ) \002,\002 2 = | I - U U\002,a1,\002 | / \002,\002("
+ " n ulp )\002,/\002 3 = | H - Z T Z\002,a1,\002 | / ( |H| n ulp"
+ " \002,\002) \002,\002 4 = | I - Z Z\002,a1,\002 | / ( n"
+ " ulp )\002,/\002 5 = | A - UZ T (UZ)\002,a1,\002 | / ( |A| n ul"
+ "p ) \002,\002 6 = | I - UZ (UZ)\002,a1,\002 | / ( n ulp "
+ ")\002,/\002 7 = | T(\002,\002e.vects.) - T(no e.vects.) | / ( |"
+ "T| ulp )\002,/\002 8 = | W\002,\002(e.vects.) - W(no e.vects.) "
+ "| / ( |W| ulp )\002,/\002 9 = | \002,\002TR - RW | / ( |T| |R| "
+ "ulp ) \002,\002 10 = | LT - WL | / (\002,\002 |T| |L| ulp "
+ ")\002,/\002 11= |HX - XW| / (|H| |X| ulp) (inv.\002,\002it)\002,"
+ "\002 12= |YH - WY| / (|H| |Y| ulp) (inv.it)\002)";
+ static char fmt_9997[] = "(/1x,a3,\002 -- Complex Non-symmetric eigenval"
+ "ue problem\002)";
+ static char fmt_9996[] = "(/1x,a3,\002 -- Real Symmetric eigenvalue prob"
+ "lem\002)";
+ static char fmt_9983[] = "(\002 Matrix types (see xDRVST for details):"
+ " \002)";
+ static char fmt_9982[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 \002,\002 5=Diagonal: clus"
+ "tered entries.\002,/\002 2=\002,\002Identity matrix. "
+ " \002,\002 6=Diagonal: lar\002,\002ge, evenly spaced"
+ ".\002,/\002 3=Diagonal: evenly spaced entri\002,\002es. \002,"
+ "\002 7=Diagonal: small, evenly spaced.\002,/\002 4=D\002,\002i"
+ "agonal: geometr. spaced entries.\002)";
+ static char fmt_9981[] = "(\002 Dense \002,a,\002 Matrices:\002,/\002 8"
+ "=Evenly spaced eigen\002,\002vals. \002,\002 12=Small"
+ ", evenly spaced eigenvals.\002,/\002 9=Geometrically spaced eig"
+ "envals. \002,\002 13=Matrix \002,\002with random O(1) entrie"
+ "s.\002,/\002 10=Clustered eigenvalues.\002,\002 "
+ "\002,\002 14=Matrix with large random entries.\002,/\002 11=Larg"
+ "e, evenly spaced eigenvals. \002,\002 15=Matrix \002,\002wit"
+ "h small random entries.\002)";
+ static char fmt_9968[] = "(/\002 Tests performed: See sdrvst.f\002)";
+ static char fmt_9995[] = "(/1x,a3,\002 -- Complex Hermitian eigenvalue p"
+ "roblem\002)";
+ static char fmt_9967[] = "(/\002 Tests performed: See cdrvst.f\002)";
+ static char fmt_9992[] = "(/1x,a3,\002 -- Real Symmetric Generalized eig"
+ "envalue \002,\002problem\002)";
+ static char fmt_9980[] = "(\002 Matrix types (see xDRVSG for details):"
+ " \002)";
+ static char fmt_9979[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 \002,\002 5=Diagonal: clus"
+ "tered entries.\002,/\002 2=\002,\002Identity matrix. "
+ " \002,\002 6=Diagonal: lar\002,\002ge, evenly spaced"
+ ".\002,/\002 3=Diagonal: evenly spaced entri\002,\002es. \002,"
+ "\002 7=Diagonal: small, evenly spaced.\002,/\002 4=D\002,\002i"
+ "agonal: geometr. spaced entries.\002)";
+ static char fmt_9978[] = "(\002 Dense or Banded \002,a,\002 Matrices:"
+ " \002,/\002 8=Evenly spaced eigenvals. \002,\002 15=Mat"
+ "rix with small random entries.\002,/\002 9=Geometrically spaced"
+ " eigenvals. \002,\002 16=Evenly spaced eigenvals, KA=1, KB=1"
+ ".\002,/\002 10=Clustered eigenvalues. \002,\002 17=Eve"
+ "nly spaced eigenvals, KA=2, KB=1.\002,/\002 11=Large, evenly spa"
+ "ced eigenvals. \002,\002 18=Evenly spaced eigenvals, KA=2, KB=2."
+ "\002,/\002 12=Small, evenly spaced eigenvals. \002,\002 19=Even"
+ "ly spaced eigenvals, KA=3, KB=1.\002,/\002 13=Matrix with random"
+ " O(1) entries. \002,\002 20=Evenly spaced eigenvals, KA=3, KB=2"
+ ".\002,/\002 14=Matrix with large random entries.\002,\002 21=Eve"
+ "nly spaced eigenvals, KA=3, KB=3.\002)";
+ static char fmt_9977[] = "(/\002 Tests performed: \002,/\002( For each"
+ " pair (A,B), where A is of the given type \002,/\002 and B is a "
+ "random well-conditioned matrix. D is \002,/\002 diagonal, and Z "
+ "is orthogonal. )\002,/\002 1 = DSYGV, with ITYPE=1 and UPLO='U'"
+ ":\002,\002 | A Z - B Z D | / ( |A| |Z| n ulp ) \002,/\002 2"
+ " = DSPGV, with ITYPE=1 and UPLO='U':\002,\002 | A Z - B Z D | /"
+ " ( |A| |Z| n ulp ) \002,/\002 3 = DSBGV, with ITYPE=1 and UP"
+ "LO='U':\002,\002 | A Z - B Z D | / ( |A| |Z| n ulp ) \002,"
+ "/\002 4 = DSYGV, with ITYPE=1 and UPLO='L':\002,\002 | A Z - B "
+ "Z D | / ( |A| |Z| n ulp ) \002,/\002 5 = DSPGV, with ITYPE=1"
+ " and UPLO='L':\002,\002 | A Z - B Z D | / ( |A| |Z| n ulp ) "
+ "\002,/\002 6 = DSBGV, with ITYPE=1 and UPLO='L':\002,\002 | A Z"
+ " - B Z D | / ( |A| |Z| n ulp ) \002)";
+ static char fmt_9976[] = "(\002 7 = DSYGV, with ITYPE=2 and UPLO='U':"
+ "\002,\002 | A B Z - Z D | / ( |A| |Z| n ulp ) \002,/\002 8 "
+ "= DSPGV, with ITYPE=2 and UPLO='U':\002,\002 | A B Z - Z D | / "
+ "( |A| |Z| n ulp ) \002,/\002 9 = DSPGV, with ITYPE=2 and UPL"
+ "O='L':\002,\002 | A B Z - Z D | / ( |A| |Z| n ulp ) \002,"
+ "/\00210 = DSPGV, with ITYPE=2 and UPLO='L':\002,\002 | A B Z - "
+ "Z D | / ( |A| |Z| n ulp ) \002,/\00211 = DSYGV, with ITYPE=3"
+ " and UPLO='U':\002,\002 | B A Z - Z D | / ( |A| |Z| n ulp ) "
+ "\002,/\00212 = DSPGV, with ITYPE=3 and UPLO='U':\002,\002 | B A"
+ " Z - Z D | / ( |A| |Z| n ulp ) \002,/\00213 = DSYGV, with IT"
+ "YPE=3 and UPLO='L':\002,\002 | B A Z - Z D | / ( |A| |Z| n ulp "
+ ") \002,/\00214 = DSPGV, with ITYPE=3 and UPLO='L':\002,\002 "
+ " | B A Z - Z D | / ( |A| |Z| n ulp ) \002)";
+ static char fmt_9991[] = "(/1x,a3,\002 -- Complex Hermitian Generalized "
+ "eigenvalue \002,\002problem\002)";
+ static char fmt_9975[] = "(/\002 Tests performed: \002,/\002( For each"
+ " pair (A,B), where A is of the given type \002,/\002 and B is a "
+ "random well-conditioned matrix. D is \002,/\002 diagonal, and Z "
+ "is unitary. )\002,/\002 1 = ZHEGV, with ITYPE=1 and UPLO='U':"
+ "\002,\002 | A Z - B Z D | / ( |A| |Z| n ulp ) \002,/\002 2 "
+ "= ZHPGV, with ITYPE=1 and UPLO='U':\002,\002 | A Z - B Z D | / "
+ "( |A| |Z| n ulp ) \002,/\002 3 = ZHBGV, with ITYPE=1 and UPL"
+ "O='U':\002,\002 | A Z - B Z D | / ( |A| |Z| n ulp ) \002,"
+ "/\002 4 = ZHEGV, with ITYPE=1 and UPLO='L':\002,\002 | A Z - B "
+ "Z D | / ( |A| |Z| n ulp ) \002,/\002 5 = ZHPGV, with ITYPE=1"
+ " and UPLO='L':\002,\002 | A Z - B Z D | / ( |A| |Z| n ulp ) "
+ "\002,/\002 6 = ZHBGV, with ITYPE=1 and UPLO='L':\002,\002 | A Z"
+ " - B Z D | / ( |A| |Z| n ulp ) \002)";
+ static char fmt_9974[] = "(\002 7 = ZHEGV, with ITYPE=2 and UPLO='U':"
+ "\002,\002 | A B Z - Z D | / ( |A| |Z| n ulp ) \002,/\002 8 "
+ "= ZHPGV, with ITYPE=2 and UPLO='U':\002,\002 | A B Z - Z D | / "
+ "( |A| |Z| n ulp ) \002,/\002 9 = ZHPGV, with ITYPE=2 and UPL"
+ "O='L':\002,\002 | A B Z - Z D | / ( |A| |Z| n ulp ) \002,"
+ "/\00210 = ZHPGV, with ITYPE=2 and UPLO='L':\002,\002 | A B Z - "
+ "Z D | / ( |A| |Z| n ulp ) \002,/\00211 = ZHEGV, with ITYPE=3"
+ " and UPLO='U':\002,\002 | B A Z - Z D | / ( |A| |Z| n ulp ) "
+ "\002,/\00212 = ZHPGV, with ITYPE=3 and UPLO='U':\002,\002 | B A"
+ " Z - Z D | / ( |A| |Z| n ulp ) \002,/\00213 = ZHEGV, with IT"
+ "YPE=3 and UPLO='L':\002,\002 | B A Z - Z D | / ( |A| |Z| n ulp "
+ ") \002,/\00214 = ZHPGV, with ITYPE=3 and UPLO='L':\002,\002 "
+ " | B A Z - Z D | / ( |A| |Z| n ulp ) \002)";
+ static char fmt_9994[] = "(/1x,a3,\002 -- Real Singular Value Decomposit"
+ "ion\002)";
+ static char fmt_9973[] = "(\002 Matrix types (see xCHKBD for details)"
+ ":\002,/\002 Diagonal matrices:\002,/\002 1: Zero\002,28x,\002 "
+ "5: Clustered entries\002,/\002 2: Identity\002,24x,\002 6: Lar"
+ "ge, evenly spaced entries\002,/\002 3: Evenly spaced entrie"
+ "s\002,11x,\002 7: Small, evenly spaced entries\002,/\002 4: Ge"
+ "ometrically spaced entries\002,/\002 General matrices:\002,/\002"
+ " 8: Evenly spaced sing. vals.\002,7x,\00212: Small, evenly spa"
+ "ced sing vals\002,/\002 9: Geometrically spaced sing vals "
+ "\002,\00213: Random, O(1) entries\002,/\002 10: Clustered sing."
+ " vals.\002,11x,\00214: Random, scaled near overflow\002,/\002 1"
+ "1: Large, evenly spaced sing vals \002,\00215: Random, scaled n"
+ "ear underflow\002)";
+ static char fmt_9972[] = "(/\002 Test ratios: \002,\002(B: bidiagonal, "
+ "S: diagonal, Q, P, U, and V: \002,a10,/16x,\002X: m x nrhs, Y = "
+ "Q' X, and Z = U' Y)\002,/\002 1: norm( A - Q B P' ) / ( norm(A"
+ ") max(m,n) ulp )\002,/\002 2: norm( I - Q' Q ) / ( m ulp "
+ ")\002,/\002 3: norm( I - P' P ) / ( n ulp )\002,/\002 4: n"
+ "orm( B - U S V' ) / ( norm(B) min(m,n) ulp )\002,/\002 5: norm"
+ "( Y - U Z ) / ( norm(Z) max(min(m,n),k) ulp )\002,/\002 6: "
+ "norm( I - U' U ) / ( min(m,n) ulp )\002,/\002 7: norm( I - V"
+ "' V ) / ( min(m,n) ulp )\002)";
+ static char fmt_9971[] = "(\002 8: Test ordering of S (0 if nondecrea"
+ "sing, 1/ulp \002,\002 otherwise)\002,/\002 9: norm( S - S2 ) "
+ " / ( norm(S) ulp ),\002,\002 where S2 is computed\002,/44x,"
+ "\002without computing U and V'\002,/\002 10: Sturm sequence tes"
+ "t \002,\002(0 if sing. vals of B within THRESH of S)\002,/\002 "
+ "11: norm( A - (QU) S (V' P') ) / \002,\002( norm(A) max(m,n) ulp"
+ " )\002,/\002 12: norm( X - (QU) Z ) / ( |X| max(M,k) ul"
+ "p )\002,/\002 13: norm( I - (QU)'(QU) ) / ( M ulp )\002,"
+ "/\002 14: norm( I - (V' P') (P V) ) / ( N ulp )\002)";
+ static char fmt_9993[] = "(/1x,a3,\002 -- Complex Singular Value Decompo"
+ "sition\002)";
+ static char fmt_9990[] = "(/1x,a3,\002 -- Real Band reduc. to bidiagonal"
+ " form\002)";
+ static char fmt_9970[] = "(\002 Matrix types (see xCHKBB for details)"
+ ":\002,/\002 Diagonal matrices:\002,/\002 1: Zero\002,28x,\002 "
+ "5: Clustered entries\002,/\002 2: Identity\002,24x,\002 6: Lar"
+ "ge, evenly spaced entries\002,/\002 3: Evenly spaced entrie"
+ "s\002,11x,\002 7: Small, evenly spaced entries\002,/\002 4: Ge"
+ "ometrically spaced entries\002,/\002 General matrices:\002,/\002"
+ " 8: Evenly spaced sing. vals.\002,7x,\00212: Small, evenly spa"
+ "ced sing vals\002,/\002 9: Geometrically spaced sing vals "
+ "\002,\00213: Random, O(1) entries\002,/\002 10: Clustered sing."
+ " vals.\002,11x,\00214: Random, scaled near overflow\002,/\002 1"
+ "1: Large, evenly spaced sing vals \002,\00215: Random, scaled n"
+ "ear underflow\002)";
+ static char fmt_9969[] = "(/\002 Test ratios: \002,\002(B: upper bidiag"
+ "onal, Q and P: \002,a10,/16x,\002C: m x nrhs, PT = P', Y = Q' C"
+ ")\002,/\002 1: norm( A - Q B PT ) / ( norm(A) max(m,n) ulp )\002"
+ ",/\002 2: norm( I - Q' Q ) / ( m ulp )\002,/\002 3: norm( I - "
+ "PT PT' ) / ( n ulp )\002,/\002 4: norm( Y - Q' C ) / ( norm("
+ "Y) max(m,nrhs) ulp )\002)";
+ static char fmt_9989[] = "(/1x,a3,\002 -- Complex Band reduc. to bidiago"
+ "nal form\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j;
+ char c2[2];
+ logical sord, corz;
+ extern logical lsame_(char *, char *), lsamen_(integer *,
+ char *, char *);
+
+ /* Fortran I/O blocks */
+ static cilist io___3 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___5 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___6 = { 0, 0, 0, fmt_9988, 0 };
+ static cilist io___7 = { 0, 0, 0, fmt_9987, 0 };
+ static cilist io___8 = { 0, 0, 0, fmt_9986, 0 };
+ static cilist io___9 = { 0, 0, 0, fmt_9985, 0 };
+ static cilist io___10 = { 0, 0, 0, fmt_9984, 0 };
+ static cilist io___12 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___13 = { 0, 0, 0, fmt_9988, 0 };
+ static cilist io___14 = { 0, 0, 0, fmt_9987, 0 };
+ static cilist io___15 = { 0, 0, 0, fmt_9986, 0 };
+ static cilist io___16 = { 0, 0, 0, fmt_9985, 0 };
+ static cilist io___17 = { 0, 0, 0, fmt_9984, 0 };
+ static cilist io___18 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___19 = { 0, 0, 0, fmt_9983, 0 };
+ static cilist io___20 = { 0, 0, 0, fmt_9982, 0 };
+ static cilist io___21 = { 0, 0, 0, fmt_9981, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9968, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9983, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9982, 0 };
+ static cilist io___26 = { 0, 0, 0, fmt_9981, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9967, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9980, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9979, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9978, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9977, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9976, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9980, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9979, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9978, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9975, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9974, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9973, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9972, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9971, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9973, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9972, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9971, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9970, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9969, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9970, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9969, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK auxiliary test routine (version 2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAHD2 prints header information for the different test paths. */
+
+/* Arguments */
+/* ========= */
+
+/* IOUNIT (input) INTEGER. */
+/* On entry, IOUNIT specifies the unit number to which the */
+/* header information should be printed. */
+
+/* PATH (input) CHARACTER*3. */
+/* On entry, PATH contains the name of the path for which the */
+/* header information is to be printed. Current paths are */
+
+/* DHS, ZHS: Non-symmetric eigenproblem. */
+/* DST, ZST: Symmetric eigenproblem. */
+/* DSG, ZSG: Symmetric Generalized eigenproblem. */
+/* DBD, ZBD: Singular Value Decomposition (SVD) */
+/* DBB, ZBB: General Banded reduction to bidiagonal form */
+
+/* These paths also are supplied in double precision (replace */
+/* leading S by D and leading C by Z in path names). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (*iounit <= 0) {
+ return 0;
+ }
+ sord = lsame_(path, "S") || lsame_(path, "D");
+ corz = lsame_(path, "C") || lsame_(path, "Z");
+ if (! sord && ! corz) {
+ io___3.ciunit = *iounit;
+ s_wsfe(&io___3);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+ if (lsamen_(&c__2, c2, "HS")) {
+ if (sord) {
+
+/* Real Non-symmetric Eigenvalue Problem: */
+
+ io___5.ciunit = *iounit;
+ s_wsfe(&io___5);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___6.ciunit = *iounit;
+ s_wsfe(&io___6);
+ e_wsfe();
+ io___7.ciunit = *iounit;
+ s_wsfe(&io___7);
+ e_wsfe();
+ io___8.ciunit = *iounit;
+ s_wsfe(&io___8);
+ do_fio(&c__1, "pairs ", (ftnlen)6);
+ do_fio(&c__1, "pairs ", (ftnlen)6);
+ do_fio(&c__1, "prs.", (ftnlen)4);
+ do_fio(&c__1, "prs.", (ftnlen)4);
+ e_wsfe();
+ io___9.ciunit = *iounit;
+ s_wsfe(&io___9);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___10.ciunit = *iounit;
+ s_wsfe(&io___10);
+ do_fio(&c__1, "orthogonal", (ftnlen)10);
+ do_fio(&c__1, "'=transpose", (ftnlen)11);
+ for (j = 1; j <= 6; ++j) {
+ do_fio(&c__1, "'", (ftnlen)1);
+ }
+ e_wsfe();
+
+ } else {
+
+/* Complex Non-symmetric Eigenvalue Problem: */
+
+ io___12.ciunit = *iounit;
+ s_wsfe(&io___12);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___13.ciunit = *iounit;
+ s_wsfe(&io___13);
+ e_wsfe();
+ io___14.ciunit = *iounit;
+ s_wsfe(&io___14);
+ e_wsfe();
+ io___15.ciunit = *iounit;
+ s_wsfe(&io___15);
+ do_fio(&c__1, "e.vals", (ftnlen)6);
+ do_fio(&c__1, "e.vals", (ftnlen)6);
+ do_fio(&c__1, "e.vs", (ftnlen)4);
+ do_fio(&c__1, "e.vs", (ftnlen)4);
+ e_wsfe();
+ io___16.ciunit = *iounit;
+ s_wsfe(&io___16);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___17.ciunit = *iounit;
+ s_wsfe(&io___17);
+ do_fio(&c__1, "unitary", (ftnlen)7);
+ do_fio(&c__1, "*=conj.transp.", (ftnlen)14);
+ for (j = 1; j <= 6; ++j) {
+ do_fio(&c__1, "*", (ftnlen)1);
+ }
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "ST")) {
+
+ if (sord) {
+
+/* Real Symmetric Eigenvalue Problem: */
+
+ io___18.ciunit = *iounit;
+ s_wsfe(&io___18);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___19.ciunit = *iounit;
+ s_wsfe(&io___19);
+ e_wsfe();
+ io___20.ciunit = *iounit;
+ s_wsfe(&io___20);
+ e_wsfe();
+ io___21.ciunit = *iounit;
+ s_wsfe(&io___21);
+ do_fio(&c__1, "Symmetric", (ftnlen)9);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___22.ciunit = *iounit;
+ s_wsfe(&io___22);
+ e_wsfe();
+
+ } else {
+
+/* Complex Hermitian Eigenvalue Problem: */
+
+ io___23.ciunit = *iounit;
+ s_wsfe(&io___23);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___24.ciunit = *iounit;
+ s_wsfe(&io___24);
+ e_wsfe();
+ io___25.ciunit = *iounit;
+ s_wsfe(&io___25);
+ e_wsfe();
+ io___26.ciunit = *iounit;
+ s_wsfe(&io___26);
+ do_fio(&c__1, "Hermitian", (ftnlen)9);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___27.ciunit = *iounit;
+ s_wsfe(&io___27);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "SG")) {
+
+ if (sord) {
+
+/* Real Symmetric Generalized Eigenvalue Problem: */
+
+ io___28.ciunit = *iounit;
+ s_wsfe(&io___28);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___29.ciunit = *iounit;
+ s_wsfe(&io___29);
+ e_wsfe();
+ io___30.ciunit = *iounit;
+ s_wsfe(&io___30);
+ e_wsfe();
+ io___31.ciunit = *iounit;
+ s_wsfe(&io___31);
+ do_fio(&c__1, "Symmetric", (ftnlen)9);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___32.ciunit = *iounit;
+ s_wsfe(&io___32);
+ e_wsfe();
+ io___33.ciunit = *iounit;
+ s_wsfe(&io___33);
+ e_wsfe();
+
+ } else {
+
+/* Complex Hermitian Generalized Eigenvalue Problem: */
+
+ io___34.ciunit = *iounit;
+ s_wsfe(&io___34);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___35.ciunit = *iounit;
+ s_wsfe(&io___35);
+ e_wsfe();
+ io___36.ciunit = *iounit;
+ s_wsfe(&io___36);
+ e_wsfe();
+ io___37.ciunit = *iounit;
+ s_wsfe(&io___37);
+ do_fio(&c__1, "Hermitian", (ftnlen)9);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___38.ciunit = *iounit;
+ s_wsfe(&io___38);
+ e_wsfe();
+ io___39.ciunit = *iounit;
+ s_wsfe(&io___39);
+ e_wsfe();
+
+ }
+
+ } else if (lsamen_(&c__2, c2, "BD")) {
+
+ if (sord) {
+
+/* Real Singular Value Decomposition: */
+
+ io___40.ciunit = *iounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___41.ciunit = *iounit;
+ s_wsfe(&io___41);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___42.ciunit = *iounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "orthogonal", (ftnlen)10);
+ e_wsfe();
+ io___43.ciunit = *iounit;
+ s_wsfe(&io___43);
+ e_wsfe();
+ } else {
+
+/* Complex Singular Value Decomposition: */
+
+ io___44.ciunit = *iounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___45.ciunit = *iounit;
+ s_wsfe(&io___45);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___46.ciunit = *iounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, "unitary ", (ftnlen)10);
+ e_wsfe();
+ io___47.ciunit = *iounit;
+ s_wsfe(&io___47);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "BB")) {
+
+ if (sord) {
+
+/* Real General Band reduction to bidiagonal form: */
+
+ io___48.ciunit = *iounit;
+ s_wsfe(&io___48);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___49.ciunit = *iounit;
+ s_wsfe(&io___49);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___50.ciunit = *iounit;
+ s_wsfe(&io___50);
+ do_fio(&c__1, "orthogonal", (ftnlen)10);
+ e_wsfe();
+ } else {
+
+/* Complex Band reduction to bidiagonal form: */
+
+ io___51.ciunit = *iounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___52.ciunit = *iounit;
+ s_wsfe(&io___52);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___53.ciunit = *iounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, "unitary ", (ftnlen)10);
+ e_wsfe();
+ }
+
+ } else {
+
+ io___54.ciunit = *iounit;
+ s_wsfe(&io___54);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ return 0;
+ }
+
+ return 0;
+
+
+
+
+/* Symmetric/Hermitian eigenproblem */
+
+
+
+/* Symmetric/Hermitian Generalized eigenproblem */
+
+
+
+/* Singular Value Decomposition */
+
+
+
+/* Band reduction to bidiagonal form */
+
+
+
+/* End of DLAHD2 */
+
+} /* dlahd2_ */
diff --git a/TESTING/EIG/dlarfy.c b/TESTING/EIG/dlarfy.c
new file mode 100644
index 0000000..f15ee9a
--- /dev/null
+++ b/TESTING/EIG/dlarfy.c
@@ -0,0 +1,139 @@
+/* dlarfy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b2 = 1.;
+static doublereal c_b3 = 0.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dlarfy_(char *uplo, integer *n, doublereal *v, integer *
+ incv, doublereal *tau, doublereal *c__, integer *ldc, doublereal *
+ work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset;
+ doublereal d__1;
+
+ /* Local variables */
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal alpha;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *), dsymv_(char *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARFY applies an elementary reflector, or Householder matrix, H, */
+/* to an n x n symmetric matrix C, from both the left and the right. */
+
+/* H is represented in the form */
+
+/* H = I - tau * v * v' */
+
+/* where tau is a scalar and v is a vector. */
+
+/* If tau is zero, then H is taken to be the unit matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix C is stored. */
+/* = 'U': Upper triangle */
+/* = 'L': Lower triangle */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix C. N >= 0. */
+
+/* V (input) DOUBLE PRECISION array, dimension */
+/* (1 + (N-1)*abs(INCV)) */
+/* The vector v as described above. */
+
+/* INCV (input) INTEGER */
+/* The increment between successive elements of v. INCV must */
+/* not be zero. */
+
+/* TAU (input) DOUBLE PRECISION */
+/* The value tau as described above. */
+
+/* C (input/output) DOUBLE PRECISION array, dimension (LDC, N) */
+/* On entry, the matrix C. */
+/* On exit, C is overwritten by H * C * H'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max( 1, N ). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ if (*tau == 0.) {
+ return 0;
+ }
+
+/* Form w:= C * v */
+
+ dsymv_(uplo, n, &c_b2, &c__[c_offset], ldc, &v[1], incv, &c_b3, &work[1],
+ &c__1);
+
+ alpha = *tau * -.5 * ddot_(n, &work[1], &c__1, &v[1], incv);
+ daxpy_(n, &alpha, &v[1], incv, &work[1], &c__1);
+
+/* C := C - v * w' - w * v' */
+
+ d__1 = -(*tau);
+ dsyr2_(uplo, n, &d__1, &v[1], incv, &work[1], &c__1, &c__[c_offset], ldc);
+
+ return 0;
+
+/* End of DLARFY */
+
+} /* dlarfy_ */
diff --git a/TESTING/EIG/dlarhs.c b/TESTING/EIG/dlarhs.c
new file mode 100644
index 0000000..6006e33
--- /dev/null
+++ b/TESTING/EIG/dlarhs.c
@@ -0,0 +1,398 @@
+/* dlarhs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static doublereal c_b32 = 1.;
+static doublereal c_b33 = 0.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dlarhs_(char *path, char *xtype, char *uplo, char *trans,
+ integer *m, integer *n, integer *kl, integer *ku, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *x, integer *ldx, doublereal *
+ b, integer *ldb, integer *iseed, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j;
+ char c1[1], c2[2];
+ integer mb, nx;
+ logical gen, tri, qrs, sym, band;
+ char diag[1];
+ logical tran;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *),
+ dgbmv_(char *, integer *, integer *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dsbmv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dtbmv_(char *,
+ char *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *), dtrmm_(char *,
+ char *, char *, char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *), dspmv_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *), dsymm_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dtpmv_(
+ char *, char *, char *, integer *, doublereal *, doublereal *,
+ integer *), dlacpy_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *,
+ doublereal *);
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARHS chooses a set of NRHS random solution vectors and sets */
+/* up the right hand sides for the linear system */
+/* op( A ) * X = B, */
+/* where op( A ) may be A or A' (transpose of A). */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The type of the real matrix A. PATH may be given in any */
+/* combination of upper and lower case. Valid types include */
+/* xGE: General m x n matrix */
+/* xGB: General banded matrix */
+/* xPO: Symmetric positive definite, 2-D storage */
+/* xPP: Symmetric positive definite packed */
+/* xPB: Symmetric positive definite banded */
+/* xSY: Symmetric indefinite, 2-D storage */
+/* xSP: Symmetric indefinite packed */
+/* xSB: Symmetric indefinite banded */
+/* xTR: Triangular */
+/* xTP: Triangular packed */
+/* xTB: Triangular banded */
+/* xQR: General m x n matrix */
+/* xLQ: General m x n matrix */
+/* xQL: General m x n matrix */
+/* xRQ: General m x n matrix */
+/* where the leading character indicates the precision. */
+
+/* XTYPE (input) CHARACTER*1 */
+/* Specifies how the exact solution X will be determined: */
+/* = 'N': New solution; generate a random X. */
+/* = 'C': Computed; use value of X on entry. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* matrix A is stored, if A is symmetric. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to the matrix A. */
+/* = 'N': System is A * x = b */
+/* = 'T': System is A'* x = b */
+/* = 'C': System is A'* x = b */
+
+/* M (input) INTEGER */
+/* The number or rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* Used only if A is a band matrix; specifies the number of */
+/* subdiagonals of A if A is a general band matrix or if A is */
+/* symmetric or triangular and UPLO = 'L'; specifies the number */
+/* of superdiagonals of A if A is symmetric or triangular and */
+/* UPLO = 'U'. 0 <= KL <= M-1. */
+
+/* KU (input) INTEGER */
+/* Used only if A is a general band matrix or if A is */
+/* triangular. */
+
+/* If PATH = xGB, specifies the number of superdiagonals of A, */
+/* and 0 <= KU <= N-1. */
+
+/* If PATH = xTR, xTP, or xTB, specifies whether or not the */
+/* matrix has unit diagonal: */
+/* = 1: matrix has non-unit diagonal (default) */
+/* = 2: matrix has unit diagonal */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors in the system A*X = B. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The test matrix whose type is given by PATH. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If PATH = xGB, LDA >= KL+KU+1. */
+/* If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1. */
+/* Otherwise, LDA >= max(1,M). */
+
+/* X (input or output) DOUBLE PRECISION array, dimension(LDX,NRHS) */
+/* On entry, if XTYPE = 'C' (for 'Computed'), then X contains */
+/* the exact solution to the system of linear equations. */
+/* On exit, if XTYPE = 'N' (for 'New'), then X is initialized */
+/* with random values. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M). */
+
+/* B (output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side vector(s) for the system of equations, */
+/* computed from B = op(A) * X, where op(A) is determined by */
+/* TRANS. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. If TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N). */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* The seed vector for the random number generator (used in */
+/* DLATMS). Modified on exit. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --iseed;
+
+ /* Function Body */
+ *info = 0;
+ *(unsigned char *)c1 = *(unsigned char *)path;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ tran = lsame_(trans, "T") || lsame_(trans, "C");
+ notran = ! tran;
+ gen = lsame_(path + 1, "G");
+ qrs = lsame_(path + 1, "Q") || lsame_(path + 2,
+ "Q");
+ sym = lsame_(path + 1, "P") || lsame_(path + 1,
+ "S");
+ tri = lsame_(path + 1, "T");
+ band = lsame_(path + 2, "B");
+ if (! lsame_(c1, "Double precision")) {
+ *info = -1;
+ } else if (! (lsame_(xtype, "N") || lsame_(xtype,
+ "C"))) {
+ *info = -2;
+ } else if ((sym || tri) && ! (lsame_(uplo, "U") ||
+ lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if ((gen || qrs) && ! (tran || lsame_(trans, "N"))) {
+ *info = -4;
+ } else if (*m < 0) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (band && *kl < 0) {
+ *info = -7;
+ } else if (band && *ku < 0) {
+ *info = -8;
+ } else if (*nrhs < 0) {
+ *info = -9;
+ } else if (! band && *lda < max(1,*m) || band && (sym || tri) && *lda < *
+ kl + 1 || band && gen && *lda < *kl + *ku + 1) {
+ *info = -11;
+ } else if (notran && *ldx < max(1,*n) || tran && *ldx < max(1,*m)) {
+ *info = -13;
+ } else if (notran && *ldb < max(1,*m) || tran && *ldb < max(1,*n)) {
+ *info = -15;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLARHS", &i__1);
+ return 0;
+ }
+
+/* Initialize X to NRHS random vectors unless XTYPE = 'C'. */
+
+ if (tran) {
+ nx = *m;
+ mb = *n;
+ } else {
+ nx = *n;
+ mb = *m;
+ }
+ if (! lsame_(xtype, "C")) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ dlarnv_(&c__2, &iseed[1], n, &x[j * x_dim1 + 1]);
+/* L10: */
+ }
+ }
+
+/* Multiply X by op( A ) using an appropriate */
+/* matrix multiply routine. */
+
+ if (lsamen_(&c__2, c2, "GE") || lsamen_(&c__2, c2,
+ "QR") || lsamen_(&c__2, c2, "LQ") || lsamen_(&c__2, c2, "QL") ||
+ lsamen_(&c__2, c2, "RQ")) {
+
+/* General matrix */
+
+ dgemm_(trans, "N", &mb, nrhs, &nx, &c_b32, &a[a_offset], lda, &x[
+ x_offset], ldx, &c_b33, &b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "PO") || lsamen_(&
+ c__2, c2, "SY")) {
+
+/* Symmetric matrix, 2-D storage */
+
+ dsymm_("Left", uplo, n, nrhs, &c_b32, &a[a_offset], lda, &x[x_offset],
+ ldx, &c_b33, &b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* General matrix, band storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ dgbmv_(trans, &mb, &nx, kl, ku, &c_b32, &a[a_offset], lda, &x[j *
+ x_dim1 + 1], &c__1, &c_b33, &b[j * b_dim1 + 1], &c__1);
+/* L20: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* Symmetric matrix, band storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ dsbmv_(uplo, n, kl, &c_b32, &a[a_offset], lda, &x[j * x_dim1 + 1],
+ &c__1, &c_b33, &b[j * b_dim1 + 1], &c__1);
+/* L30: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "PP") || lsamen_(&
+ c__2, c2, "SP")) {
+
+/* Symmetric matrix, packed storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ dspmv_(uplo, n, &c_b32, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
+ c_b33, &b[j * b_dim1 + 1], &c__1);
+/* L40: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "TR")) {
+
+/* Triangular matrix. Note that for triangular matrices, */
+/* KU = 1 => non-unit triangular */
+/* KU = 2 => unit triangular */
+
+ dlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ dtrmm_("Left", uplo, trans, diag, n, nrhs, &c_b32, &a[a_offset], lda,
+ &b[b_offset], ldb)
+ ;
+
+ } else if (lsamen_(&c__2, c2, "TP")) {
+
+/* Triangular matrix, packed storage */
+
+ dlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ dtpmv_(uplo, trans, diag, n, &a[a_offset], &b[j * b_dim1 + 1], &
+ c__1);
+/* L50: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "TB")) {
+
+/* Triangular matrix, banded storage */
+
+ dlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ dtbmv_(uplo, trans, diag, n, kl, &a[a_offset], lda, &b[j * b_dim1
+ + 1], &c__1);
+/* L60: */
+ }
+
+ } else {
+
+/* If PATH is none of the above, return with an error code. */
+
+ *info = -1;
+ i__1 = -(*info);
+ xerbla_("DLARHS", &i__1);
+ }
+
+ return 0;
+
+/* End of DLARHS */
+
+} /* dlarhs_ */
diff --git a/TESTING/EIG/dlasum.c b/TESTING/EIG/dlasum.c
new file mode 100644
index 0000000..38727aa
--- /dev/null
+++ b/TESTING/EIG/dlasum.c
@@ -0,0 +1,76 @@
+/* dlasum.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dlasum_(char *type__, integer *iounit, integer *ie,
+ integer *nrun)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,a2,i4,a8,i5,a35)";
+ static char fmt_9998[] = "(/1x,a14,a3,a23,i5,a11)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___2 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLASUM prints a summary of the results from one of the test routines. */
+
+/* ===================================================================== */
+
+/* .. Executable Statements .. */
+
+ if (*ie > 0) {
+ io___1.ciunit = *iounit;
+ s_wsfe(&io___1);
+ do_fio(&c__1, type__, (ftnlen)3);
+ do_fio(&c__1, ": ", (ftnlen)2);
+ do_fio(&c__1, (char *)&(*ie), (ftnlen)sizeof(integer));
+ do_fio(&c__1, " out of ", (ftnlen)8);
+ do_fio(&c__1, (char *)&(*nrun), (ftnlen)sizeof(integer));
+ do_fio(&c__1, " tests failed to pass the threshold", (ftnlen)35);
+ e_wsfe();
+ } else {
+ io___2.ciunit = *iounit;
+ s_wsfe(&io___2);
+ do_fio(&c__1, "All tests for ", (ftnlen)14);
+ do_fio(&c__1, type__, (ftnlen)3);
+ do_fio(&c__1, " passed the threshold (", (ftnlen)23);
+ do_fio(&c__1, (char *)&(*nrun), (ftnlen)sizeof(integer));
+ do_fio(&c__1, " tests run)", (ftnlen)11);
+ e_wsfe();
+ }
+ return 0;
+
+/* End of DLASUM */
+
+} /* dlasum_ */
diff --git a/TESTING/EIG/dlatb9.c b/TESTING/EIG/dlatb9.c
new file mode 100644
index 0000000..401371e
--- /dev/null
+++ b/TESTING/EIG/dlatb9.c
@@ -0,0 +1,308 @@
+/* dlatb9.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+
+/* Subroutine */ int dlatb9_(char *path, integer *imat, integer *m, integer *
+ p, integer *n, char *type__, integer *kla, integer *kua, integer *klb,
+ integer *kub, doublereal *anorm, doublereal *bnorm, integer *modea,
+ integer *modeb, doublereal *cndnma, doublereal *cndnmb, char *dista,
+ char *distb)
+{
+ /* Initialized data */
+
+ static logical first = TRUE_;
+
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ static doublereal eps, badc1, badc2, large, small;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern logical lsamen_(integer *, char *, char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLATB9 sets parameters for the matrix generator based on the type of */
+/* matrix to be generated. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name. */
+
+/* IMAT (input) INTEGER */
+/* An integer key describing which matrix to generate for this */
+/* path. */
+
+/* M (input) INTEGER */
+/* The number of rows in the matrix to be generated. */
+
+/* N (input) INTEGER */
+/* The number of columns in the matrix to be generated. */
+
+/* TYPE (output) CHARACTER*1 */
+/* The type of the matrix to be generated: */
+/* = 'S': symmetric matrix; */
+/* = 'P': symmetric positive (semi)definite matrix; */
+/* = 'N': nonsymmetric matrix. */
+
+/* KL (output) INTEGER */
+/* The lower band width of the matrix to be generated. */
+
+/* KU (output) INTEGER */
+/* The upper band width of the matrix to be generated. */
+
+/* ANORM (output) DOUBLE PRECISION */
+/* The desired norm of the matrix to be generated. The diagonal */
+/* matrix of singular values or eigenvalues is scaled by this */
+/* value. */
+
+/* MODE (output) INTEGER */
+/* A key indicating how to choose the vector of eigenvalues. */
+
+/* CNDNUM (output) DOUBLE PRECISION */
+/* The desired condition number. */
+
+/* DIST (output) CHARACTER*1 */
+/* The type of distribution to be used by the random number */
+/* generator. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Set some constants for use in the subroutine. */
+
+ if (first) {
+ first = FALSE_;
+ eps = dlamch_("Precision");
+ badc2 = .1 / eps;
+ badc1 = sqrt(badc2);
+ small = dlamch_("Safe minimum");
+ large = 1. / small;
+
+/* If it looks like we're on a Cray, take the square root of */
+/* SMALL and LARGE to avoid overflow and underflow problems. */
+
+ dlabad_(&small, &large);
+ small = small / eps * .25;
+ large = 1. / small;
+ }
+
+/* Set some parameters we don't plan to change. */
+
+ *(unsigned char *)type__ = 'N';
+ *(unsigned char *)dista = 'S';
+ *(unsigned char *)distb = 'S';
+ *modea = 3;
+ *modeb = 4;
+
+/* Set the lower and upper bandwidths. */
+
+ if (lsamen_(&c__3, path, "GRQ") || lsamen_(&c__3,
+ path, "LSE") || lsamen_(&c__3, path, "GSV")) {
+
+/* A: M by N, B: P by N */
+
+ if (*imat == 1) {
+
+/* A: diagonal, B: upper triangular */
+
+ *kla = 0;
+ *kua = 0;
+ *klb = 0;
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kub = max(i__1,0);
+
+ } else if (*imat == 2) {
+
+/* A: upper triangular, B: upper triangular */
+
+ *kla = 0;
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kua = max(i__1,0);
+ *klb = 0;
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kub = max(i__1,0);
+
+ } else if (*imat == 3) {
+
+/* A: lower triangular, B: upper triangular */
+
+/* Computing MAX */
+ i__1 = *m - 1;
+ *kla = max(i__1,0);
+ *kua = 0;
+ *klb = 0;
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kub = max(i__1,0);
+
+ } else {
+
+/* A: general dense, B: general dense */
+
+/* Computing MAX */
+ i__1 = *m - 1;
+ *kla = max(i__1,0);
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kua = max(i__1,0);
+/* Computing MAX */
+ i__1 = *p - 1;
+ *klb = max(i__1,0);
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kub = max(i__1,0);
+
+ }
+
+ } else if (lsamen_(&c__3, path, "GQR") || lsamen_(&
+ c__3, path, "GLM")) {
+
+/* A: N by M, B: N by P */
+
+ if (*imat == 1) {
+
+/* A: diagonal, B: lower triangular */
+
+ *kla = 0;
+ *kua = 0;
+/* Computing MAX */
+ i__1 = *n - 1;
+ *klb = max(i__1,0);
+ *kub = 0;
+ } else if (*imat == 2) {
+
+/* A: lower triangular, B: diagonal */
+
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kla = max(i__1,0);
+ *kua = 0;
+ *klb = 0;
+ *kub = 0;
+
+ } else if (*imat == 3) {
+
+/* A: lower triangular, B: upper triangular */
+
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kla = max(i__1,0);
+ *kua = 0;
+ *klb = 0;
+/* Computing MAX */
+ i__1 = *p - 1;
+ *kub = max(i__1,0);
+
+ } else {
+
+/* A: general dense, B: general dense */
+
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kla = max(i__1,0);
+/* Computing MAX */
+ i__1 = *m - 1;
+ *kua = max(i__1,0);
+/* Computing MAX */
+ i__1 = *n - 1;
+ *klb = max(i__1,0);
+/* Computing MAX */
+ i__1 = *p - 1;
+ *kub = max(i__1,0);
+ }
+
+ }
+
+/* Set the condition number and norm. */
+
+ *cndnma = 100.;
+ *cndnmb = 10.;
+ if (lsamen_(&c__3, path, "GQR") || lsamen_(&c__3,
+ path, "GRQ") || lsamen_(&c__3, path, "GSV")) {
+ if (*imat == 5) {
+ *cndnma = badc1;
+ *cndnmb = badc1;
+ } else if (*imat == 6) {
+ *cndnma = badc2;
+ *cndnmb = badc2;
+ } else if (*imat == 7) {
+ *cndnma = badc1;
+ *cndnmb = badc2;
+ } else if (*imat == 8) {
+ *cndnma = badc2;
+ *cndnmb = badc1;
+ }
+ }
+
+ *anorm = 10.;
+ *bnorm = 1e3;
+ if (lsamen_(&c__3, path, "GQR") || lsamen_(&c__3,
+ path, "GRQ")) {
+ if (*imat == 7) {
+ *anorm = small;
+ *bnorm = large;
+ } else if (*imat == 8) {
+ *anorm = large;
+ *bnorm = small;
+ }
+ }
+
+ if (*n <= 1) {
+ *cndnma = 1.;
+ *cndnmb = 1.;
+ }
+
+ return 0;
+
+/* End of DLATB9 */
+
+} /* dlatb9_ */
diff --git a/TESTING/EIG/dlatm4.c b/TESTING/EIG/dlatm4.c
new file mode 100644
index 0000000..e95301f
--- /dev/null
+++ b/TESTING/EIG/dlatm4.c
@@ -0,0 +1,492 @@
+/* dlatm4.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b3 = 0.;
+
+/* Subroutine */ int dlatm4_(integer *itype, integer *n, integer *nz1,
+ integer *nz2, integer *isign, doublereal *amagn, doublereal *rcond,
+ doublereal *triang, integer *idist, integer *iseed, doublereal *a,
+ integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double pow_dd(doublereal *, doublereal *), log(doublereal), exp(
+ doublereal), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, k, jc, jd;
+ doublereal cl, cr;
+ integer jr;
+ doublereal sl, sr, sv1, sv2;
+ integer kbeg, isdb, kend, ioff, isde, klen;
+ doublereal temp, alpha;
+ extern doublereal dlamch_(char *), dlaran_(integer *), dlarnd_(
+ integer *, integer *);
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ doublereal safmin;
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLATM4 generates basic square matrices, which may later be */
+/* multiplied by others in order to produce test matrices. It is */
+/* intended mainly to be used to test the generalized eigenvalue */
+/* routines. */
+
+/* It first generates the diagonal and (possibly) subdiagonal, */
+/* according to the value of ITYPE, NZ1, NZ2, ISIGN, AMAGN, and RCOND. */
+/* It then fills in the upper triangle with random numbers, if TRIANG is */
+/* non-zero. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* The "type" of matrix on the diagonal and sub-diagonal. */
+/* If ITYPE < 0, then type abs(ITYPE) is generated and then */
+/* swapped end for end (A(I,J) := A'(N-J,N-I).) See also */
+/* the description of AMAGN and ISIGN. */
+
+/* Special types: */
+/* = 0: the zero matrix. */
+/* = 1: the identity. */
+/* = 2: a transposed Jordan block. */
+/* = 3: If N is odd, then a k+1 x k+1 transposed Jordan block */
+/* followed by a k x k identity block, where k=(N-1)/2. */
+/* If N is even, then k=(N-2)/2, and a zero diagonal entry */
+/* is tacked onto the end. */
+
+/* Diagonal types. The diagonal consists of NZ1 zeros, then */
+/* k=N-NZ1-NZ2 nonzeros. The subdiagonal is zero. ITYPE */
+/* specifies the nonzero diagonal entries as follows: */
+/* = 4: 1, ..., k */
+/* = 5: 1, RCOND, ..., RCOND */
+/* = 6: 1, ..., 1, RCOND */
+/* = 7: 1, a, a^2, ..., a^(k-1)=RCOND */
+/* = 8: 1, 1-d, 1-2*d, ..., 1-(k-1)*d=RCOND */
+/* = 9: random numbers chosen from (RCOND,1) */
+/* = 10: random numbers with distribution IDIST (see DLARND.) */
+
+/* N (input) INTEGER */
+/* The order of the matrix. */
+
+/* NZ1 (input) INTEGER */
+/* If abs(ITYPE) > 3, then the first NZ1 diagonal entries will */
+/* be zero. */
+
+/* NZ2 (input) INTEGER */
+/* If abs(ITYPE) > 3, then the last NZ2 diagonal entries will */
+/* be zero. */
+
+/* ISIGN (input) INTEGER */
+/* = 0: The sign of the diagonal and subdiagonal entries will */
+/* be left unchanged. */
+/* = 1: The diagonal and subdiagonal entries will have their */
+/* sign changed at random. */
+/* = 2: If ITYPE is 2 or 3, then the same as ISIGN=1. */
+/* Otherwise, with probability 0.5, odd-even pairs of */
+/* diagonal entries A(2*j-1,2*j-1), A(2*j,2*j) will be */
+/* converted to a 2x2 block by pre- and post-multiplying */
+/* by distinct random orthogonal rotations. The remaining */
+/* diagonal entries will have their sign changed at random. */
+
+/* AMAGN (input) DOUBLE PRECISION */
+/* The diagonal and subdiagonal entries will be multiplied by */
+/* AMAGN. */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* If abs(ITYPE) > 4, then the smallest diagonal entry will be */
+/* entry will be RCOND. RCOND must be between 0 and 1. */
+
+/* TRIANG (input) DOUBLE PRECISION */
+/* The entries above the diagonal will be random numbers with */
+/* magnitude bounded by TRIANG (i.e., random numbers multiplied */
+/* by TRIANG.) */
+
+/* IDIST (input) INTEGER */
+/* Specifies the type of distribution to be used to generate a */
+/* random matrix. */
+/* = 1: UNIFORM( 0, 1 ) */
+/* = 2: UNIFORM( -1, 1 ) */
+/* = 3: NORMAL ( 0, 1 ) */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The values of ISEED are changed on exit, and can */
+/* be used in the next call to DLATM4 to continue the same */
+/* random number sequence. */
+/* Note: ISEED(4) should be odd, for the random number generator */
+/* used at present. */
+
+/* A (output) DOUBLE PRECISION array, dimension (LDA, N) */
+/* Array to be computed. */
+
+/* LDA (input) INTEGER */
+/* Leading dimension of A. Must be at least 1 and at least N. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ dlaset_("Full", n, n, &c_b3, &c_b3, &a[a_offset], lda);
+
+/* Insure a correct ISEED */
+
+ if (iseed[4] % 2 != 1) {
+ ++iseed[4];
+ }
+
+/* Compute diagonal and subdiagonal according to ITYPE, NZ1, NZ2, */
+/* and RCOND */
+
+ if (*itype != 0) {
+ if (abs(*itype) >= 4) {
+/* Computing MAX */
+/* Computing MIN */
+ i__3 = *n, i__4 = *nz1 + 1;
+ i__1 = 1, i__2 = min(i__3,i__4);
+ kbeg = max(i__1,i__2);
+/* Computing MAX */
+/* Computing MIN */
+ i__3 = *n, i__4 = *n - *nz2;
+ i__1 = kbeg, i__2 = min(i__3,i__4);
+ kend = max(i__1,i__2);
+ klen = kend + 1 - kbeg;
+ } else {
+ kbeg = 1;
+ kend = *n;
+ klen = *n;
+ }
+ isdb = 1;
+ isde = 0;
+ switch (abs(*itype)) {
+ case 1: goto L10;
+ case 2: goto L30;
+ case 3: goto L50;
+ case 4: goto L80;
+ case 5: goto L100;
+ case 6: goto L120;
+ case 7: goto L140;
+ case 8: goto L160;
+ case 9: goto L180;
+ case 10: goto L200;
+ }
+
+/* abs(ITYPE) = 1: Identity */
+
+L10:
+ i__1 = *n;
+ for (jd = 1; jd <= i__1; ++jd) {
+ a[jd + jd * a_dim1] = 1.;
+/* L20: */
+ }
+ goto L220;
+
+/* abs(ITYPE) = 2: Transposed Jordan block */
+
+L30:
+ i__1 = *n - 1;
+ for (jd = 1; jd <= i__1; ++jd) {
+ a[jd + 1 + jd * a_dim1] = 1.;
+/* L40: */
+ }
+ isdb = 1;
+ isde = *n - 1;
+ goto L220;
+
+/* abs(ITYPE) = 3: Transposed Jordan block, followed by the */
+/* identity. */
+
+L50:
+ k = (*n - 1) / 2;
+ i__1 = k;
+ for (jd = 1; jd <= i__1; ++jd) {
+ a[jd + 1 + jd * a_dim1] = 1.;
+/* L60: */
+ }
+ isdb = 1;
+ isde = k;
+ i__1 = (k << 1) + 1;
+ for (jd = k + 2; jd <= i__1; ++jd) {
+ a[jd + jd * a_dim1] = 1.;
+/* L70: */
+ }
+ goto L220;
+
+/* abs(ITYPE) = 4: 1,...,k */
+
+L80:
+ i__1 = kend;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ a[jd + jd * a_dim1] = (doublereal) (jd - *nz1);
+/* L90: */
+ }
+ goto L220;
+
+/* abs(ITYPE) = 5: One large D value: */
+
+L100:
+ i__1 = kend;
+ for (jd = kbeg + 1; jd <= i__1; ++jd) {
+ a[jd + jd * a_dim1] = *rcond;
+/* L110: */
+ }
+ a[kbeg + kbeg * a_dim1] = 1.;
+ goto L220;
+
+/* abs(ITYPE) = 6: One small D value: */
+
+L120:
+ i__1 = kend - 1;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ a[jd + jd * a_dim1] = 1.;
+/* L130: */
+ }
+ a[kend + kend * a_dim1] = *rcond;
+ goto L220;
+
+/* abs(ITYPE) = 7: Exponentially distributed D values: */
+
+L140:
+ a[kbeg + kbeg * a_dim1] = 1.;
+ if (klen > 1) {
+ d__1 = 1. / (doublereal) (klen - 1);
+ alpha = pow_dd(rcond, &d__1);
+ i__1 = klen;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ d__1 = (doublereal) (i__ - 1);
+ a[*nz1 + i__ + (*nz1 + i__) * a_dim1] = pow_dd(&alpha, &d__1);
+/* L150: */
+ }
+ }
+ goto L220;
+
+/* abs(ITYPE) = 8: Arithmetically distributed D values: */
+
+L160:
+ a[kbeg + kbeg * a_dim1] = 1.;
+ if (klen > 1) {
+ alpha = (1. - *rcond) / (doublereal) (klen - 1);
+ i__1 = klen;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ a[*nz1 + i__ + (*nz1 + i__) * a_dim1] = (doublereal) (klen -
+ i__) * alpha + *rcond;
+/* L170: */
+ }
+ }
+ goto L220;
+
+/* abs(ITYPE) = 9: Randomly distributed D values on ( RCOND, 1): */
+
+L180:
+ alpha = log(*rcond);
+ i__1 = kend;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ a[jd + jd * a_dim1] = exp(alpha * dlaran_(&iseed[1]));
+/* L190: */
+ }
+ goto L220;
+
+/* abs(ITYPE) = 10: Randomly distributed D values from DIST */
+
+L200:
+ i__1 = kend;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ a[jd + jd * a_dim1] = dlarnd_(idist, &iseed[1]);
+/* L210: */
+ }
+
+L220:
+
+/* Scale by AMAGN */
+
+ i__1 = kend;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ a[jd + jd * a_dim1] = *amagn * a[jd + jd * a_dim1];
+/* L230: */
+ }
+ i__1 = isde;
+ for (jd = isdb; jd <= i__1; ++jd) {
+ a[jd + 1 + jd * a_dim1] = *amagn * a[jd + 1 + jd * a_dim1];
+/* L240: */
+ }
+
+/* If ISIGN = 1 or 2, assign random signs to diagonal and */
+/* subdiagonal */
+
+ if (*isign > 0) {
+ i__1 = kend;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ if (a[jd + jd * a_dim1] != 0.) {
+ if (dlaran_(&iseed[1]) > .5) {
+ a[jd + jd * a_dim1] = -a[jd + jd * a_dim1];
+ }
+ }
+/* L250: */
+ }
+ i__1 = isde;
+ for (jd = isdb; jd <= i__1; ++jd) {
+ if (a[jd + 1 + jd * a_dim1] != 0.) {
+ if (dlaran_(&iseed[1]) > .5) {
+ a[jd + 1 + jd * a_dim1] = -a[jd + 1 + jd * a_dim1];
+ }
+ }
+/* L260: */
+ }
+ }
+
+/* Reverse if ITYPE < 0 */
+
+ if (*itype < 0) {
+ i__1 = (kbeg + kend - 1) / 2;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ temp = a[jd + jd * a_dim1];
+ a[jd + jd * a_dim1] = a[kbeg + kend - jd + (kbeg + kend - jd)
+ * a_dim1];
+ a[kbeg + kend - jd + (kbeg + kend - jd) * a_dim1] = temp;
+/* L270: */
+ }
+ i__1 = (*n - 1) / 2;
+ for (jd = 1; jd <= i__1; ++jd) {
+ temp = a[jd + 1 + jd * a_dim1];
+ a[jd + 1 + jd * a_dim1] = a[*n + 1 - jd + (*n - jd) * a_dim1];
+ a[*n + 1 - jd + (*n - jd) * a_dim1] = temp;
+/* L280: */
+ }
+ }
+
+/* If ISIGN = 2, and no subdiagonals already, then apply */
+/* random rotations to make 2x2 blocks. */
+
+ if (*isign == 2 && *itype != 2 && *itype != 3) {
+ safmin = dlamch_("S");
+ i__1 = kend - 1;
+ for (jd = kbeg; jd <= i__1; jd += 2) {
+ if (dlaran_(&iseed[1]) > .5) {
+
+/* Rotation on left. */
+
+ cl = dlaran_(&iseed[1]) * 2. - 1.;
+ sl = dlaran_(&iseed[1]) * 2. - 1.;
+/* Computing MAX */
+/* Computing 2nd power */
+ d__3 = cl;
+/* Computing 2nd power */
+ d__4 = sl;
+ d__1 = safmin, d__2 = sqrt(d__3 * d__3 + d__4 * d__4);
+ temp = 1. / max(d__1,d__2);
+ cl *= temp;
+ sl *= temp;
+
+/* Rotation on right. */
+
+ cr = dlaran_(&iseed[1]) * 2. - 1.;
+ sr = dlaran_(&iseed[1]) * 2. - 1.;
+/* Computing MAX */
+/* Computing 2nd power */
+ d__3 = cr;
+/* Computing 2nd power */
+ d__4 = sr;
+ d__1 = safmin, d__2 = sqrt(d__3 * d__3 + d__4 * d__4);
+ temp = 1. / max(d__1,d__2);
+ cr *= temp;
+ sr *= temp;
+
+/* Apply */
+
+ sv1 = a[jd + jd * a_dim1];
+ sv2 = a[jd + 1 + (jd + 1) * a_dim1];
+ a[jd + jd * a_dim1] = cl * cr * sv1 + sl * sr * sv2;
+ a[jd + 1 + jd * a_dim1] = -sl * cr * sv1 + cl * sr * sv2;
+ a[jd + (jd + 1) * a_dim1] = -cl * sr * sv1 + sl * cr *
+ sv2;
+ a[jd + 1 + (jd + 1) * a_dim1] = sl * sr * sv1 + cl * cr *
+ sv2;
+ }
+/* L290: */
+ }
+ }
+
+ }
+
+/* Fill in upper triangle (except for 2x2 blocks) */
+
+ if (*triang != 0.) {
+ if (*isign != 2 || *itype == 2 || *itype == 3) {
+ ioff = 1;
+ } else {
+ ioff = 2;
+ i__1 = *n - 1;
+ for (jr = 1; jr <= i__1; ++jr) {
+ if (a[jr + 1 + jr * a_dim1] == 0.) {
+ a[jr + (jr + 1) * a_dim1] = *triang * dlarnd_(idist, &
+ iseed[1]);
+ }
+/* L300: */
+ }
+ }
+
+ i__1 = *n;
+ for (jc = 2; jc <= i__1; ++jc) {
+ i__2 = jc - ioff;
+ for (jr = 1; jr <= i__2; ++jr) {
+ a[jr + jc * a_dim1] = *triang * dlarnd_(idist, &iseed[1]);
+/* L310: */
+ }
+/* L320: */
+ }
+ }
+
+ return 0;
+
+/* End of DLATM4 */
+
+} /* dlatm4_ */
diff --git a/TESTING/EIG/dlctes.c b/TESTING/EIG/dlctes.c
new file mode 100644
index 0000000..e80a276
--- /dev/null
+++ b/TESTING/EIG/dlctes.c
@@ -0,0 +1,80 @@
+/* dlctes.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b2 = 1.;
+
+logical dlctes_(doublereal *zr, doublereal *zi, doublereal *d__)
+{
+ /* System generated locals */
+ logical ret_val;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLCTES returns .TRUE. if the eigenvalue (ZR/D) + sqrt(-1)*(ZI/D) */
+/* is to be selected (specifically, in this subroutine, if the real */
+/* part of the eigenvalue is negative), and otherwise it returns */
+/* .FALSE.. */
+
+/* It is used by the test routine DDRGES to test whether the driver */
+/* routine DGGES succesfully sorts eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* ZR (input) DOUBLE PRECISION */
+/* The numerator of the real part of a complex eigenvalue */
+/* (ZR/D) + i*(ZI/D). */
+
+/* ZI (input) DOUBLE PRECISION */
+/* The numerator of the imaginary part of a complex eigenvalue */
+/* (ZR/D) + i*(ZI). */
+
+/* D (input) DOUBLE PRECISION */
+/* The denominator part of a complex eigenvalue */
+/* (ZR/D) + i*(ZI/D). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (*d__ == 0.) {
+ ret_val = *zr < 0.;
+ } else {
+ ret_val = d_sign(&c_b2, zr) != d_sign(&c_b2, d__);
+ }
+
+ return ret_val;
+
+/* End of DLCTES */
+
+} /* dlctes_ */
diff --git a/TESTING/EIG/dlctsx.c b/TESTING/EIG/dlctsx.c
new file mode 100644
index 0000000..f395328
--- /dev/null
+++ b/TESTING/EIG/dlctsx.c
@@ -0,0 +1,105 @@
+/* dlctsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer m, n, mplusn, i__;
+ logical fs;
+} mn_;
+
+#define mn_1 mn_
+
+logical dlctsx_(doublereal *ar, doublereal *ai, doublereal *beta)
+{
+ /* System generated locals */
+ logical ret_val;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This function is used to determine what eigenvalues will be */
+/* selected. If this is part of the test driver DDRGSX, do not */
+/* change the code UNLESS you are testing input examples and not */
+/* using the built-in examples. */
+
+/* Arguments */
+/* ========= */
+
+/* AR (input) DOUBLE PRECISION */
+/* The numerator of the real part of a complex eigenvalue */
+/* (AR/BETA) + i*(AI/BETA). */
+
+/* AI (input) DOUBLE PRECISION */
+/* The numerator of the imaginary part of a complex eigenvalue */
+/* (AR/BETA) + i*(AI). */
+
+/* BETA (input) DOUBLE PRECISION */
+/* The denominator part of a complex eigenvalue */
+/* (AR/BETA) + i*(AI/BETA). */
+
+/* ===================================================================== */
+
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (mn_1.fs) {
+ ++mn_1.i__;
+ if (mn_1.i__ <= mn_1.m) {
+ ret_val = FALSE_;
+ } else {
+ ret_val = TRUE_;
+ }
+ if (mn_1.i__ == mn_1.mplusn) {
+ mn_1.fs = FALSE_;
+ mn_1.i__ = 0;
+ }
+ } else {
+ ++mn_1.i__;
+ if (mn_1.i__ <= mn_1.n) {
+ ret_val = TRUE_;
+ } else {
+ ret_val = FALSE_;
+ }
+ if (mn_1.i__ == mn_1.mplusn) {
+ mn_1.fs = TRUE_;
+ mn_1.i__ = 0;
+ }
+ }
+
+/* IF( AR/BETA.GT.0.0 )THEN */
+/* DLCTSX = .TRUE. */
+/* ELSE */
+/* DLCTSX = .FALSE. */
+/* END IF */
+
+ return ret_val;
+
+/* End of DLCTSX */
+
+} /* dlctsx_ */
diff --git a/TESTING/EIG/dlsets.c b/TESTING/EIG/dlsets.c
new file mode 100644
index 0000000..3f589f2
--- /dev/null
+++ b/TESTING/EIG/dlsets.c
@@ -0,0 +1,174 @@
+/* dlsets.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dlsets_(integer *m, integer *p, integer *n, doublereal *
+ a, doublereal *af, integer *lda, doublereal *b, doublereal *bf,
+ integer *ldb, doublereal *c__, doublereal *cf, doublereal *d__,
+ doublereal *df, doublereal *x, doublereal *work, integer *lwork,
+ doublereal *rwork, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1,
+ bf_offset;
+
+ /* Local variables */
+ integer info;
+ extern /* Subroutine */ int dget02_(char *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *), dcopy_(integer *,
+ doublereal *, integer *, doublereal *, integer *), dgglse_(
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *), dlacpy_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLSETS tests DGGLSE - a subroutine for solving linear equality */
+/* constrained least square problem (LSE). */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The M-by-N matrix A. */
+
+/* AF (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and R. */
+/* LDA >= max(M,N). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,N) */
+/* The P-by-N matrix A. */
+
+/* BF (workspace) DOUBLE PRECISION array, dimension (LDB,N) */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the arrays B, BF, V and S. */
+/* LDB >= max(P,N). */
+
+/* C (input) DOUBLE PRECISION array, dimension( M ) */
+/* the vector C in the LSE problem. */
+
+/* CF (workspace) DOUBLE PRECISION array, dimension( M ) */
+
+/* D (input) DOUBLE PRECISION array, dimension( P ) */
+/* the vector D in the LSE problem. */
+
+/* DF (workspace) DOUBLE PRECISION array, dimension( P ) */
+
+/* X (output) DOUBLE PRECISION array, dimension( N ) */
+/* solution vector X in the LSE problem. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( A*x - c )/ norm(A)*norm(X)*EPS */
+/* RESULT(2) = norm( B*x - d )/ norm(B)*norm(X)*EPS */
+
+/* ==================================================================== */
+
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Copy the matrices A and B to the arrays AF and BF, */
+/* and the vectors C and D to the arrays CF and DF, */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ bf_dim1 = *ldb;
+ bf_offset = 1 + bf_dim1;
+ bf -= bf_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --c__;
+ --cf;
+ --d__;
+ --df;
+ --x;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ dlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+ dlacpy_("Full", p, n, &b[b_offset], ldb, &bf[bf_offset], ldb);
+ dcopy_(m, &c__[1], &c__1, &cf[1], &c__1);
+ dcopy_(p, &d__[1], &c__1, &df[1], &c__1);
+
+/* Solve LSE problem */
+
+ dgglse_(m, n, p, &af[af_offset], lda, &bf[bf_offset], ldb, &cf[1], &df[1],
+ &x[1], &work[1], lwork, &info);
+
+/* Test the residual for the solution of LSE */
+
+/* Compute RESULT(1) = norm( A*x - c ) / norm(A)*norm(X)*EPS */
+
+ dcopy_(m, &c__[1], &c__1, &cf[1], &c__1);
+ dcopy_(p, &d__[1], &c__1, &df[1], &c__1);
+ dget02_("No transpose", m, n, &c__1, &a[a_offset], lda, &x[1], n, &cf[1],
+ m, &rwork[1], &result[1]);
+
+/* Compute result(2) = norm( B*x - d ) / norm(B)*norm(X)*EPS */
+
+ dget02_("No transpose", p, n, &c__1, &b[b_offset], ldb, &x[1], n, &df[1],
+ p, &rwork[1], &result[2]);
+
+ return 0;
+
+/* End of DLSETS */
+
+} /* dlsets_ */
diff --git a/TESTING/EIG/dort01.c b/TESTING/EIG/dort01.c
new file mode 100644
index 0000000..8ee2d3e
--- /dev/null
+++ b/TESTING/EIG/dort01.c
@@ -0,0 +1,219 @@
+/* dort01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b7 = 0.;
+static doublereal c_b8 = 1.;
+static doublereal c_b10 = -1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dort01_(char *rowcol, integer *m, integer *n, doublereal
+ *u, integer *ldu, doublereal *work, integer *lwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal eps, tmp;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ integer mnmin;
+ extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ integer ldwork;
+ char transu[1];
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORT01 checks that the matrix U is orthogonal by computing the ratio */
+
+/* RESID = norm( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R', */
+/* or */
+/* RESID = norm( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'. */
+
+/* Alternatively, if there isn't sufficient workspace to form */
+/* I - U*U' or I - U'*U, the ratio is computed as */
+
+/* RESID = abs( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R', */
+/* or */
+/* RESID = abs( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'. */
+
+/* where EPS is the machine precision. ROWCOL is used only if m = n; */
+/* if m > n, ROWCOL is assumed to be 'C', and if m < n, ROWCOL is */
+/* assumed to be 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* ROWCOL (input) CHARACTER */
+/* Specifies whether the rows or columns of U should be checked */
+/* for orthogonality. Used only if M = N. */
+/* = 'R': Check for orthogonal rows of U */
+/* = 'C': Check for orthogonal columns of U */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix U. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix U. */
+
+/* U (input) DOUBLE PRECISION array, dimension (LDU,N) */
+/* The orthogonal matrix U. U is checked for orthogonal columns */
+/* if m > n or if m = n and ROWCOL = 'C'. U is checked for */
+/* orthogonal rows if m < n or if m = n and ROWCOL = 'R'. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. For best performance, LWORK */
+/* should be at least N*(N+1) if ROWCOL = 'C' or M*(M+1) if */
+/* ROWCOL = 'R', but the test will be done even if LWORK is 0. */
+
+/* RESID (output) DOUBLE PRECISION */
+/* RESID = norm( I - U * U' ) / ( n * EPS ), if ROWCOL = 'R', or */
+/* RESID = norm( I - U' * U ) / ( m * EPS ), if ROWCOL = 'C'. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --work;
+
+ /* Function Body */
+ *resid = 0.;
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+ eps = dlamch_("Precision");
+ if (*m < *n || *m == *n && lsame_(rowcol, "R")) {
+ *(unsigned char *)transu = 'N';
+ k = *n;
+ } else {
+ *(unsigned char *)transu = 'T';
+ k = *m;
+ }
+ mnmin = min(*m,*n);
+
+ if ((mnmin + 1) * mnmin <= *lwork) {
+ ldwork = mnmin;
+ } else {
+ ldwork = 0;
+ }
+ if (ldwork > 0) {
+
+/* Compute I - U*U' or I - U'*U. */
+
+ dlaset_("Upper", &mnmin, &mnmin, &c_b7, &c_b8, &work[1], &ldwork);
+ dsyrk_("Upper", transu, &mnmin, &k, &c_b10, &u[u_offset], ldu, &c_b8,
+ &work[1], &ldwork);
+
+/* Compute norm( I - U*U' ) / ( K * EPS ) . */
+
+ *resid = dlansy_("1", "Upper", &mnmin, &work[1], &ldwork, &work[
+ ldwork * mnmin + 1]);
+ *resid = *resid / (doublereal) k / eps;
+ } else if (*(unsigned char *)transu == 'T') {
+
+/* Find the maximum element in abs( I - U'*U ) / ( m * EPS ) */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (i__ != j) {
+ tmp = 0.;
+ } else {
+ tmp = 1.;
+ }
+ tmp -= ddot_(m, &u[i__ * u_dim1 + 1], &c__1, &u[j * u_dim1 +
+ 1], &c__1);
+/* Computing MAX */
+ d__1 = *resid, d__2 = abs(tmp);
+ *resid = max(d__1,d__2);
+/* L10: */
+ }
+/* L20: */
+ }
+ *resid = *resid / (doublereal) (*m) / eps;
+ } else {
+
+/* Find the maximum element in abs( I - U*U' ) / ( n * EPS ) */
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (i__ != j) {
+ tmp = 0.;
+ } else {
+ tmp = 1.;
+ }
+ tmp -= ddot_(n, &u[j + u_dim1], ldu, &u[i__ + u_dim1], ldu);
+/* Computing MAX */
+ d__1 = *resid, d__2 = abs(tmp);
+ *resid = max(d__1,d__2);
+/* L30: */
+ }
+/* L40: */
+ }
+ *resid = *resid / (doublereal) (*n) / eps;
+ }
+ return 0;
+
+/* End of DORT01 */
+
+} /* dort01_ */
diff --git a/TESTING/EIG/dort03.c b/TESTING/EIG/dort03.c
new file mode 100644
index 0000000..b3987d0
--- /dev/null
+++ b/TESTING/EIG/dort03.c
@@ -0,0 +1,259 @@
+/* dort03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b7 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dort03_(char *rc, integer *mu, integer *mv, integer *n,
+ integer *k, doublereal *u, integer *ldu, doublereal *v, integer *ldv,
+ doublereal *work, integer *lwork, doublereal *result, integer *info)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, v_dim1, v_offset, i__1, i__2;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal s;
+ integer irc, lmx;
+ doublereal ulp, res1, res2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dort01_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DORT03 compares two orthogonal matrices U and V to see if their */
+/* corresponding rows or columns span the same spaces. The rows are */
+/* checked if RC = 'R', and the columns are checked if RC = 'C'. */
+
+/* RESULT is the maximum of */
+
+/* | V*V' - I | / ( MV ulp ), if RC = 'R', or */
+
+/* | V'*V - I | / ( MV ulp ), if RC = 'C', */
+
+/* and the maximum over rows (or columns) 1 to K of */
+
+/* | U(i) - S*V(i) |/ ( N ulp ) */
+
+/* where S is +-1 (chosen to minimize the expression), U(i) is the i-th */
+/* row (column) of U, and V(i) is the i-th row (column) of V. */
+
+/* Arguments */
+/* ========== */
+
+/* RC (input) CHARACTER*1 */
+/* If RC = 'R' the rows of U and V are to be compared. */
+/* If RC = 'C' the columns of U and V are to be compared. */
+
+/* MU (input) INTEGER */
+/* The number of rows of U if RC = 'R', and the number of */
+/* columns if RC = 'C'. If MU = 0 DORT03 does nothing. */
+/* MU must be at least zero. */
+
+/* MV (input) INTEGER */
+/* The number of rows of V if RC = 'R', and the number of */
+/* columns if RC = 'C'. If MV = 0 DORT03 does nothing. */
+/* MV must be at least zero. */
+
+/* N (input) INTEGER */
+/* If RC = 'R', the number of columns in the matrices U and V, */
+/* and if RC = 'C', the number of rows in U and V. If N = 0 */
+/* DORT03 does nothing. N must be at least zero. */
+
+/* K (input) INTEGER */
+/* The number of rows or columns of U and V to compare. */
+/* 0 <= K <= max(MU,MV). */
+
+/* U (input) DOUBLE PRECISION array, dimension (LDU,N) */
+/* The first matrix to compare. If RC = 'R', U is MU by N, and */
+/* if RC = 'C', U is N by MU. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. If RC = 'R', LDU >= max(1,MU), */
+/* and if RC = 'C', LDU >= max(1,N). */
+
+/* V (input) DOUBLE PRECISION array, dimension (LDV,N) */
+/* The second matrix to compare. If RC = 'R', V is MV by N, and */
+/* if RC = 'C', V is N by MV. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of V. If RC = 'R', LDV >= max(1,MV), */
+/* and if RC = 'C', LDV >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. For best performance, LWORK */
+/* should be at least N*N if RC = 'C' or M*M if RC = 'R', but */
+/* the tests will be done even if LWORK is 0. */
+
+/* RESULT (output) DOUBLE PRECISION */
+/* The value computed by the test described above. RESULT is */
+/* limited to 1/ulp to avoid overflow. */
+
+/* INFO (output) INTEGER */
+/* 0 indicates a successful exit */
+/* -k indicates the k-th parameter had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check inputs */
+
+ /* Parameter adjustments */
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (lsame_(rc, "R")) {
+ irc = 0;
+ } else if (lsame_(rc, "C")) {
+ irc = 1;
+ } else {
+ irc = -1;
+ }
+ if (irc == -1) {
+ *info = -1;
+ } else if (*mu < 0) {
+ *info = -2;
+ } else if (*mv < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > max(*mu,*mv)) {
+ *info = -5;
+ } else if (irc == 0 && *ldu < max(1,*mu) || irc == 1 && *ldu < max(1,*n))
+ {
+ *info = -7;
+ } else if (irc == 0 && *ldv < max(1,*mv) || irc == 1 && *ldv < max(1,*n))
+ {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DORT03", &i__1);
+ return 0;
+ }
+
+/* Initialize result */
+
+ *result = 0.;
+ if (*mu == 0 || *mv == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Machine constants */
+
+ ulp = dlamch_("Precision");
+
+ if (irc == 0) {
+
+/* Compare rows */
+
+ res1 = 0.;
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ lmx = idamax_(n, &u[i__ + u_dim1], ldu);
+ s = d_sign(&c_b7, &u[i__ + lmx * u_dim1]) * d_sign(&c_b7, &v[i__
+ + lmx * v_dim1]);
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ d__2 = res1, d__3 = (d__1 = u[i__ + j * u_dim1] - s * v[i__ +
+ j * v_dim1], abs(d__1));
+ res1 = max(d__2,d__3);
+/* L10: */
+ }
+/* L20: */
+ }
+ res1 /= (doublereal) (*n) * ulp;
+
+/* Compute orthogonality of rows of V. */
+
+ dort01_("Rows", mv, n, &v[v_offset], ldv, &work[1], lwork, &res2);
+
+ } else {
+
+/* Compare columns */
+
+ res1 = 0.;
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ lmx = idamax_(n, &u[i__ * u_dim1 + 1], &c__1);
+ s = d_sign(&c_b7, &u[lmx + i__ * u_dim1]) * d_sign(&c_b7, &v[lmx
+ + i__ * v_dim1]);
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ d__2 = res1, d__3 = (d__1 = u[j + i__ * u_dim1] - s * v[j +
+ i__ * v_dim1], abs(d__1));
+ res1 = max(d__2,d__3);
+/* L30: */
+ }
+/* L40: */
+ }
+ res1 /= (doublereal) (*n) * ulp;
+
+/* Compute orthogonality of columns of V. */
+
+ dort01_("Columns", n, mv, &v[v_offset], ldv, &work[1], lwork, &res2);
+ }
+
+/* Computing MIN */
+ d__1 = max(res1,res2), d__2 = 1. / ulp;
+ *result = min(d__1,d__2);
+ return 0;
+
+/* End of DORT03 */
+
+} /* dort03_ */
diff --git a/TESTING/EIG/dsbt21.c b/TESTING/EIG/dsbt21.c
new file mode 100644
index 0000000..3547110
--- /dev/null
+++ b/TESTING/EIG/dsbt21.c
@@ -0,0 +1,291 @@
+/* dsbt21.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b22 = 1.;
+static doublereal c_b23 = 0.;
+
+/* Subroutine */ int dsbt21_(char *uplo, integer *n, integer *ka, integer *ks,
+ doublereal *a, integer *lda, doublereal *d__, doublereal *e,
+ doublereal *u, integer *ldu, doublereal *work, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j, jc, jr, lw, ika;
+ doublereal ulp, unfl;
+ extern /* Subroutine */ int dspr_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *), dspr2_(char *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *), dgemm_(char *, char *, integer *
+, integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ char cuplo[1];
+ logical lower;
+ doublereal wnorm;
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *),
+ dlansb_(char *, char *, integer *, integer *, doublereal *,
+ integer *, doublereal *), dlansp_(char *, char *,
+ integer *, doublereal *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSBT21 generally checks a decomposition of the form */
+
+/* A = U S U' */
+
+/* where ' means transpose, A is symmetric banded, U is */
+/* orthogonal, and S is diagonal (if KS=0) or symmetric */
+/* tridiagonal (if KS=1). */
+
+/* Specifically: */
+
+/* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU' | / ( n ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER */
+/* If UPLO='U', the upper triangle of A and V will be used and */
+/* the (strictly) lower triangle will not be referenced. */
+/* If UPLO='L', the lower triangle of A and V will be used and */
+/* the (strictly) upper triangle will not be referenced. */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, DSBT21 does nothing. */
+/* It must be at least zero. */
+
+/* KA (input) INTEGER */
+/* The bandwidth of the matrix A. It must be at least zero. If */
+/* it is larger than N-1, then max( 0, N-1 ) will be used. */
+
+/* KS (input) INTEGER */
+/* The bandwidth of the matrix S. It may only be zero or one. */
+/* If zero, then S is diagonal, and E is not referenced. If */
+/* one, then S is symmetric tri-diagonal. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA, N) */
+/* The original (unfactored) matrix. It is assumed to be */
+/* symmetric, and only the upper (UPLO='U') or only the lower */
+/* (UPLO='L') will be referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least min( KA, N-1 ). */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal of the (symmetric tri-) diagonal matrix S. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The off-diagonal of the (symmetric tri-) diagonal matrix S. */
+/* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and */
+/* (3,2) element, etc. */
+/* Not referenced if KS=0. */
+
+/* U (input) DOUBLE PRECISION array, dimension (LDU, N) */
+/* The orthogonal matrix in the decomposition, expressed as a */
+/* dense matrix (i.e., not as a product of Householder */
+/* transformations, Givens transformations, etc.) */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N**2+N) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Constants */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --work;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.;
+ result[2] = 0.;
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Computing MAX */
+/* Computing MIN */
+ i__3 = *n - 1;
+ i__1 = 0, i__2 = min(i__3,*ka);
+ ika = max(i__1,i__2);
+ lw = *n * (*n + 1) / 2;
+
+ if (lsame_(uplo, "U")) {
+ lower = FALSE_;
+ *(unsigned char *)cuplo = 'U';
+ } else {
+ lower = TRUE_;
+ *(unsigned char *)cuplo = 'L';
+ }
+
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+
+/* Some Error Checks */
+
+/* Do Test 1 */
+
+/* Norm of A: */
+
+/* Computing MAX */
+ d__1 = dlansb_("1", cuplo, n, &ika, &a[a_offset], lda, &work[1]);
+ anorm = max(d__1,unfl);
+
+/* Compute error matrix: Error = A - U S U' */
+
+/* Copy A from SB to SP storage format. */
+
+ j = 0;
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ if (lower) {
+/* Computing MIN */
+ i__3 = ika + 1, i__4 = *n + 1 - jc;
+ i__2 = min(i__3,i__4);
+ for (jr = 1; jr <= i__2; ++jr) {
+ ++j;
+ work[j] = a[jr + jc * a_dim1];
+/* L10: */
+ }
+ i__2 = *n + 1 - jc;
+ for (jr = ika + 2; jr <= i__2; ++jr) {
+ ++j;
+ work[j] = 0.;
+/* L20: */
+ }
+ } else {
+ i__2 = jc;
+ for (jr = ika + 2; jr <= i__2; ++jr) {
+ ++j;
+ work[j] = 0.;
+/* L30: */
+ }
+/* Computing MIN */
+ i__2 = ika, i__3 = jc - 1;
+ for (jr = min(i__2,i__3); jr >= 0; --jr) {
+ ++j;
+ work[j] = a[ika + 1 - jr + jc * a_dim1];
+/* L40: */
+ }
+ }
+/* L50: */
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ d__1 = -d__[j];
+ dspr_(cuplo, n, &d__1, &u[j * u_dim1 + 1], &c__1, &work[1])
+ ;
+/* L60: */
+ }
+
+ if (*n > 1 && *ks == 1) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ d__1 = -e[j];
+ dspr2_(cuplo, n, &d__1, &u[j * u_dim1 + 1], &c__1, &u[(j + 1) *
+ u_dim1 + 1], &c__1, &work[1]);
+/* L70: */
+ }
+ }
+ wnorm = dlansp_("1", cuplo, n, &work[1], &work[lw + 1]);
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.) {
+/* Computing MIN */
+ d__1 = wnorm, d__2 = *n * anorm;
+ result[1] = min(d__1,d__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
+ result[1] = min(d__1,d__2) / (*n * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute UU' - I */
+
+ dgemm_("N", "C", n, n, n, &c_b22, &u[u_offset], ldu, &u[u_offset], ldu, &
+ c_b23, &work[1], n);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[(*n + 1) * (j - 1) + 1] += -1.;
+/* L80: */
+ }
+
+/* Computing MIN */
+/* Computing 2nd power */
+ i__1 = *n;
+ d__1 = dlange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]),
+ d__2 = (doublereal) (*n);
+ result[2] = min(d__1,d__2) / (*n * ulp);
+
+ return 0;
+
+/* End of DSBT21 */
+
+} /* dsbt21_ */
diff --git a/TESTING/EIG/dsgt01.c b/TESTING/EIG/dsgt01.c
new file mode 100644
index 0000000..af5b9f6
--- /dev/null
+++ b/TESTING/EIG/dsgt01.c
@@ -0,0 +1,220 @@
+/* dsgt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b6 = 1.;
+static doublereal c_b7 = 0.;
+static integer c__1 = 1;
+static doublereal c_b12 = -1.;
+
+/* Subroutine */ int dsgt01_(integer *itype, char *uplo, integer *n, integer *
+ m, doublereal *a, integer *lda, doublereal *b, integer *ldb,
+ doublereal *z__, integer *ldz, doublereal *d__, doublereal *work,
+ doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1;
+
+ /* Local variables */
+ integer i__;
+ doublereal ulp;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal anorm;
+ extern /* Subroutine */ int dsymm_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *),
+ dlansy_(char *, char *, integer *, doublereal *, integer *,
+ doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* modified August 1997, a new parameter M is added to the calling */
+/* sequence. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDGT01 checks a decomposition of the form */
+
+/* A Z = B Z D or */
+/* A B Z = Z D or */
+/* B A Z = Z D */
+
+/* where A is a symmetric matrix, B is */
+/* symmetric positive definite, Z is orthogonal, and D is diagonal. */
+
+/* One of the following test ratios is computed: */
+
+/* ITYPE = 1: RESULT(1) = | A Z - B Z D | / ( |A| |Z| n ulp ) */
+
+/* ITYPE = 2: RESULT(1) = | A B Z - Z D | / ( |A| |Z| n ulp ) */
+
+/* ITYPE = 3: RESULT(1) = | B A Z - Z D | / ( |A| |Z| n ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* The form of the symmetric generalized eigenproblem. */
+/* = 1: A*z = (lambda)*B*z */
+/* = 2: A*B*z = (lambda)*z */
+/* = 3: B*A*z = (lambda)*z */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrices A and B is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* M (input) INTEGER */
+/* The number of eigenvalues found. 0 <= M <= N. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA, N) */
+/* The original symmetric matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB, N) */
+/* The original symmetric positive definite matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Z (input) DOUBLE PRECISION array, dimension (LDZ, M) */
+/* The computed eigenvectors of the generalized eigenproblem. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= max(1,N). */
+
+/* D (input) DOUBLE PRECISION array, dimension (M) */
+/* The computed eigenvalues of the generalized eigenproblem. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N*N) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (1) */
+/* The test ratio as described above. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --d__;
+ --work;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.;
+ if (*n <= 0) {
+ return 0;
+ }
+
+ ulp = dlamch_("Epsilon");
+
+/* Compute product of 1-norms of A and Z. */
+
+ anorm = dlansy_("1", uplo, n, &a[a_offset], lda, &work[1]) * dlange_("1", n, m, &z__[z_offset], ldz, &work[1]);
+ if (anorm == 0.) {
+ anorm = 1.;
+ }
+
+ if (*itype == 1) {
+
+/* Norm of AZ - BZD */
+
+ dsymm_("Left", uplo, n, m, &c_b6, &a[a_offset], lda, &z__[z_offset],
+ ldz, &c_b7, &work[1], n);
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dscal_(n, &d__[i__], &z__[i__ * z_dim1 + 1], &c__1);
+/* L10: */
+ }
+ dsymm_("Left", uplo, n, m, &c_b6, &b[b_offset], ldb, &z__[z_offset],
+ ldz, &c_b12, &work[1], n);
+
+ result[1] = dlange_("1", n, m, &work[1], n, &work[1]) /
+ anorm / (*n * ulp);
+
+ } else if (*itype == 2) {
+
+/* Norm of ABZ - ZD */
+
+ dsymm_("Left", uplo, n, m, &c_b6, &b[b_offset], ldb, &z__[z_offset],
+ ldz, &c_b7, &work[1], n);
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dscal_(n, &d__[i__], &z__[i__ * z_dim1 + 1], &c__1);
+/* L20: */
+ }
+ dsymm_("Left", uplo, n, m, &c_b6, &a[a_offset], lda, &work[1], n, &
+ c_b12, &z__[z_offset], ldz);
+
+ result[1] = dlange_("1", n, m, &z__[z_offset], ldz, &work[1]) / anorm / (*n * ulp);
+
+ } else if (*itype == 3) {
+
+/* Norm of BAZ - ZD */
+
+ dsymm_("Left", uplo, n, m, &c_b6, &a[a_offset], lda, &z__[z_offset],
+ ldz, &c_b7, &work[1], n);
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dscal_(n, &d__[i__], &z__[i__ * z_dim1 + 1], &c__1);
+/* L30: */
+ }
+ dsymm_("Left", uplo, n, m, &c_b6, &b[b_offset], ldb, &work[1], n, &
+ c_b12, &z__[z_offset], ldz);
+
+ result[1] = dlange_("1", n, m, &z__[z_offset], ldz, &work[1]) / anorm / (*n * ulp);
+ }
+
+ return 0;
+
+/* End of DDGT01 */
+
+} /* dsgt01_ */
diff --git a/TESTING/EIG/dslect.c b/TESTING/EIG/dslect.c
new file mode 100644
index 0000000..0512589
--- /dev/null
+++ b/TESTING/EIG/dslect.c
@@ -0,0 +1,108 @@
+/* dslect.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ doublereal selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+logical dslect_(doublereal *zr, doublereal *zi)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+ logical ret_val;
+
+ /* Local variables */
+ integer i__;
+ doublereal x, rmin;
+ extern doublereal dlapy2_(doublereal *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSLECT returns .TRUE. if the eigenvalue ZR+sqrt(-1)*ZI is to be */
+/* selected, and otherwise it returns .FALSE. */
+/* It is used by DCHK41 to test if DGEES succesfully sorts eigenvalues, */
+/* and by DCHK43 to test if DGEESX succesfully sorts eigenvalues. */
+
+/* The common block /SSLCT/ controls how eigenvalues are selected. */
+/* If SELOPT = 0, then DSLECT return .TRUE. when ZR is less than zero, */
+/* and .FALSE. otherwise. */
+/* If SELOPT is at least 1, DSLECT returns SELVAL(SELOPT) and adds 1 */
+/* to SELOPT, cycling back to 1 at SELMAX. */
+
+/* Arguments */
+/* ========= */
+
+/* ZR (input) DOUBLE PRECISION */
+/* The real part of a complex eigenvalue ZR + i*ZI. */
+
+/* ZI (input) DOUBLE PRECISION */
+/* The imaginary part of a complex eigenvalue ZR + i*ZI. */
+
+/* ===================================================================== */
+
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (sslct_1.selopt == 0) {
+ ret_val = *zr < 0.;
+ } else {
+ d__1 = *zr - sslct_1.selwr[0];
+ d__2 = *zi - sslct_1.selwi[0];
+ rmin = dlapy2_(&d__1, &d__2);
+ ret_val = sslct_1.selval[0];
+ i__1 = sslct_1.seldim;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ d__1 = *zr - sslct_1.selwr[i__ - 1];
+ d__2 = *zi - sslct_1.selwi[i__ - 1];
+ x = dlapy2_(&d__1, &d__2);
+ if (x <= rmin) {
+ rmin = x;
+ ret_val = sslct_1.selval[i__ - 1];
+ }
+/* L10: */
+ }
+ }
+ return ret_val;
+
+/* End of DSLECT */
+
+} /* dslect_ */
diff --git a/TESTING/EIG/dspt21.c b/TESTING/EIG/dspt21.c
new file mode 100644
index 0000000..c55b004
--- /dev/null
+++ b/TESTING/EIG/dspt21.c
@@ -0,0 +1,468 @@
+/* dspt21.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b10 = 0.;
+static integer c__1 = 1;
+static doublereal c_b26 = 1.;
+
+/* Subroutine */ int dspt21_(integer *itype, char *uplo, integer *n, integer *
+ kband, doublereal *ap, doublereal *d__, doublereal *e, doublereal *u,
+ integer *ldu, doublereal *vp, doublereal *tau, doublereal *work,
+ doublereal *result)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j, jp, jr, jp1, lap;
+ doublereal ulp;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal unfl, temp;
+ extern /* Subroutine */ int dspr_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *), dspr2_(char *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *), dgemm_(char *, char *, integer *
+, integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ doublereal anorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ char cuplo[1];
+ doublereal vsave;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *);
+ logical lower;
+ extern /* Subroutine */ int dspmv_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal wnorm;
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *);
+ extern doublereal dlansp_(char *, char *, integer *, doublereal *,
+ doublereal *);
+ extern /* Subroutine */ int dopmtr_(char *, char *, char *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSPT21 generally checks a decomposition of the form */
+
+/* A = U S U' */
+
+/* where ' means transpose, A is symmetric (stored in packed format), U */
+/* is orthogonal, and S is diagonal (if KBAND=0) or symmetric */
+/* tridiagonal (if KBAND=1). If ITYPE=1, then U is represented as a */
+/* dense matrix, otherwise the U is expressed as a product of */
+/* Householder transformations, whose vectors are stored in the array */
+/* "V" and whose scaling constants are in "TAU"; we shall use the */
+/* letter "V" to refer to the product of Householder transformations */
+/* (which should be equal to U). */
+
+/* Specifically, if ITYPE=1, then: */
+
+/* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU' | / ( n ulp ) */
+
+/* If ITYPE=2, then: */
+
+/* RESULT(1) = | A - V S V' | / ( |A| n ulp ) */
+
+/* If ITYPE=3, then: */
+
+/* RESULT(1) = | I - VU' | / ( n ulp ) */
+
+/* Packed storage means that, for example, if UPLO='U', then the columns */
+/* of the upper triangle of A are stored one after another, so that */
+/* A(1,j+1) immediately follows A(j,j) in the array AP. Similarly, if */
+/* UPLO='L', then the columns of the lower triangle of A are stored one */
+/* after another in AP, so that A(j+1,j+1) immediately follows A(n,j) */
+/* in the array AP. This means that A(i,j) is stored in: */
+
+/* AP( i + j*(j-1)/2 ) if UPLO='U' */
+
+/* AP( i + (2*n-j)*(j-1)/2 ) if UPLO='L' */
+
+/* The array VP bears the same relation to the matrix V that A does to */
+/* AP. */
+
+/* For ITYPE > 1, the transformation U is expressed as a product */
+/* of Householder transformations: */
+
+/* If UPLO='U', then V = H(n-1)...H(1), where */
+
+/* H(j) = I - tau(j) v(j) v(j)' */
+
+/* and the first j-1 elements of v(j) are stored in V(1:j-1,j+1), */
+/* (i.e., VP( j*(j+1)/2 + 1 : j*(j+1)/2 + j-1 ) ), */
+/* the j-th element is 1, and the last n-j elements are 0. */
+
+/* If UPLO='L', then V = H(1)...H(n-1), where */
+
+/* H(j) = I - tau(j) v(j) v(j)' */
+
+/* and the first j elements of v(j) are 0, the (j+1)-st is 1, and the */
+/* (j+2)-nd through n-th elements are stored in V(j+2:n,j) (i.e., */
+/* in VP( (2*n-j)*(j-1)/2 + j+2 : (2*n-j)*(j-1)/2 + n ) .) */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the type of tests to be performed. */
+/* 1: U expressed as a dense orthogonal matrix: */
+/* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU' | / ( n ulp ) */
+
+/* 2: U expressed as a product V of Housholder transformations: */
+/* RESULT(1) = | A - V S V' | / ( |A| n ulp ) */
+
+/* 3: U expressed both as a dense orthogonal matrix and */
+/* as a product of Housholder transformations: */
+/* RESULT(1) = | I - VU' | / ( n ulp ) */
+
+/* UPLO (input) CHARACTER */
+/* If UPLO='U', AP and VP are considered to contain the upper */
+/* triangle of A and V. */
+/* If UPLO='L', AP and VP are considered to contain the lower */
+/* triangle of A and V. */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, DSPT21 does nothing. */
+/* It must be at least zero. */
+
+/* KBAND (input) INTEGER */
+/* The bandwidth of the matrix. It may only be zero or one. */
+/* If zero, then S is diagonal, and E is not referenced. If */
+/* one, then S is symmetric tri-diagonal. */
+
+/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The original (unfactored) matrix. It is assumed to be */
+/* symmetric, and contains the columns of just the upper */
+/* triangle (UPLO='U') or only the lower triangle (UPLO='L'), */
+/* packed one after another. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal of the (symmetric tri-) diagonal matrix. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The off-diagonal of the (symmetric tri-) diagonal matrix. */
+/* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and */
+/* (3,2) element, etc. */
+/* Not referenced if KBAND=0. */
+
+/* U (input) DOUBLE PRECISION array, dimension (LDU, N) */
+/* If ITYPE=1 or 3, this contains the orthogonal matrix in */
+/* the decomposition, expressed as a dense matrix. If ITYPE=2, */
+/* then it is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+
+/* VP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* If ITYPE=2 or 3, the columns of this array contain the */
+/* Householder vectors used to describe the orthogonal matrix */
+/* in the decomposition, as described in purpose. */
+/* *NOTE* If ITYPE=2 or 3, V is modified and restored. The */
+/* subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U') */
+/* is set to one, and later reset to its original value, during */
+/* the course of the calculation. */
+/* If ITYPE=1, then it is neither referenced nor modified. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (N) */
+/* If ITYPE >= 2, then TAU(j) is the scalar factor of */
+/* v(j) v(j)' in the Householder transformation H(j) of */
+/* the product U = H(1)...H(n-2) */
+/* If ITYPE < 2, then TAU is not referenced. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N**2+N) */
+/* Workspace. */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+/* RESULT(1) is always modified. RESULT(2) is modified only */
+/* if ITYPE=1. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Constants */
+
+ /* Parameter adjustments */
+ --ap;
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --vp;
+ --tau;
+ --work;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.;
+ if (*itype == 1) {
+ result[2] = 0.;
+ }
+ if (*n <= 0) {
+ return 0;
+ }
+
+ lap = *n * (*n + 1) / 2;
+
+ if (lsame_(uplo, "U")) {
+ lower = FALSE_;
+ *(unsigned char *)cuplo = 'U';
+ } else {
+ lower = TRUE_;
+ *(unsigned char *)cuplo = 'L';
+ }
+
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+
+/* Some Error Checks */
+
+ if (*itype < 1 || *itype > 3) {
+ result[1] = 10. / ulp;
+ return 0;
+ }
+
+/* Do Test 1 */
+
+/* Norm of A: */
+
+ if (*itype == 3) {
+ anorm = 1.;
+ } else {
+/* Computing MAX */
+ d__1 = dlansp_("1", cuplo, n, &ap[1], &work[1]);
+ anorm = max(d__1,unfl);
+ }
+
+/* Compute error matrix: */
+
+ if (*itype == 1) {
+
+/* ITYPE=1: error = A - U S U' */
+
+ dlaset_("Full", n, n, &c_b10, &c_b10, &work[1], n);
+ dcopy_(&lap, &ap[1], &c__1, &work[1], &c__1);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ d__1 = -d__[j];
+ dspr_(cuplo, n, &d__1, &u[j * u_dim1 + 1], &c__1, &work[1]);
+/* L10: */
+ }
+
+ if (*n > 1 && *kband == 1) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ d__1 = -e[j];
+ dspr2_(cuplo, n, &d__1, &u[j * u_dim1 + 1], &c__1, &u[(j + 1)
+ * u_dim1 + 1], &c__1, &work[1]);
+/* L20: */
+ }
+ }
+/* Computing 2nd power */
+ i__1 = *n;
+ wnorm = dlansp_("1", cuplo, n, &work[1], &work[i__1 * i__1 + 1]);
+
+ } else if (*itype == 2) {
+
+/* ITYPE=2: error = V S V' - A */
+
+ dlaset_("Full", n, n, &c_b10, &c_b10, &work[1], n);
+
+ if (lower) {
+ work[lap] = d__[*n];
+ for (j = *n - 1; j >= 1; --j) {
+ jp = ((*n << 1) - j) * (j - 1) / 2;
+ jp1 = jp + *n - j;
+ if (*kband == 1) {
+ work[jp + j + 1] = (1. - tau[j]) * e[j];
+ i__1 = *n;
+ for (jr = j + 2; jr <= i__1; ++jr) {
+ work[jp + jr] = -tau[j] * e[j] * vp[jp + jr];
+/* L30: */
+ }
+ }
+
+ if (tau[j] != 0.) {
+ vsave = vp[jp + j + 1];
+ vp[jp + j + 1] = 1.;
+ i__1 = *n - j;
+ dspmv_("L", &i__1, &c_b26, &work[jp1 + j + 1], &vp[jp + j
+ + 1], &c__1, &c_b10, &work[lap + 1], &c__1);
+ i__1 = *n - j;
+ temp = tau[j] * -.5 * ddot_(&i__1, &work[lap + 1], &c__1,
+ &vp[jp + j + 1], &c__1);
+ i__1 = *n - j;
+ daxpy_(&i__1, &temp, &vp[jp + j + 1], &c__1, &work[lap +
+ 1], &c__1);
+ i__1 = *n - j;
+ d__1 = -tau[j];
+ dspr2_("L", &i__1, &d__1, &vp[jp + j + 1], &c__1, &work[
+ lap + 1], &c__1, &work[jp1 + j + 1]);
+ vp[jp + j + 1] = vsave;
+ }
+ work[jp + j] = d__[j];
+/* L40: */
+ }
+ } else {
+ work[1] = d__[1];
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ jp = j * (j - 1) / 2;
+ jp1 = jp + j;
+ if (*kband == 1) {
+ work[jp1 + j] = (1. - tau[j]) * e[j];
+ i__2 = j - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ work[jp1 + jr] = -tau[j] * e[j] * vp[jp1 + jr];
+/* L50: */
+ }
+ }
+
+ if (tau[j] != 0.) {
+ vsave = vp[jp1 + j];
+ vp[jp1 + j] = 1.;
+ dspmv_("U", &j, &c_b26, &work[1], &vp[jp1 + 1], &c__1, &
+ c_b10, &work[lap + 1], &c__1);
+ temp = tau[j] * -.5 * ddot_(&j, &work[lap + 1], &c__1, &
+ vp[jp1 + 1], &c__1);
+ daxpy_(&j, &temp, &vp[jp1 + 1], &c__1, &work[lap + 1], &
+ c__1);
+ d__1 = -tau[j];
+ dspr2_("U", &j, &d__1, &vp[jp1 + 1], &c__1, &work[lap + 1]
+, &c__1, &work[1]);
+ vp[jp1 + j] = vsave;
+ }
+ work[jp1 + j + 1] = d__[j + 1];
+/* L60: */
+ }
+ }
+
+ i__1 = lap;
+ for (j = 1; j <= i__1; ++j) {
+ work[j] -= ap[j];
+/* L70: */
+ }
+ wnorm = dlansp_("1", cuplo, n, &work[1], &work[lap + 1]);
+
+ } else if (*itype == 3) {
+
+/* ITYPE=3: error = U V' - I */
+
+ if (*n < 2) {
+ return 0;
+ }
+ dlacpy_(" ", n, n, &u[u_offset], ldu, &work[1], n);
+/* Computing 2nd power */
+ i__1 = *n;
+ dopmtr_("R", cuplo, "T", n, n, &vp[1], &tau[1], &work[1], n, &work[
+ i__1 * i__1 + 1], &iinfo);
+ if (iinfo != 0) {
+ result[1] = 10. / ulp;
+ return 0;
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[(*n + 1) * (j - 1) + 1] += -1.;
+/* L80: */
+ }
+
+/* Computing 2nd power */
+ i__1 = *n;
+ wnorm = dlange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]);
+ }
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.) {
+/* Computing MIN */
+ d__1 = wnorm, d__2 = *n * anorm;
+ result[1] = min(d__1,d__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
+ result[1] = min(d__1,d__2) / (*n * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute UU' - I */
+
+ if (*itype == 1) {
+ dgemm_("N", "C", n, n, n, &c_b26, &u[u_offset], ldu, &u[u_offset],
+ ldu, &c_b10, &work[1], n);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[(*n + 1) * (j - 1) + 1] += -1.;
+/* L90: */
+ }
+
+/* Computing MIN */
+/* Computing 2nd power */
+ i__1 = *n;
+ d__1 = dlange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]), d__2 = (doublereal) (*n);
+ result[2] = min(d__1,d__2) / (*n * ulp);
+ }
+
+ return 0;
+
+/* End of DSPT21 */
+
+} /* dspt21_ */
diff --git a/TESTING/EIG/dstech.c b/TESTING/EIG/dstech.c
new file mode 100644
index 0000000..3ffdbdf
--- /dev/null
+++ b/TESTING/EIG/dstech.c
@@ -0,0 +1,220 @@
+/* dstech.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dstech_(integer *n, doublereal *a, doublereal *b,
+ doublereal *eig, doublereal *tol, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal mx, eps, emin;
+ integer isub, bpnt, numl, numu, tpnt, count;
+ doublereal lower, upper, tuppr;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dstect_(integer *, doublereal *, doublereal *,
+ doublereal *, integer *);
+ doublereal unflep;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Let T be the tridiagonal matrix with diagonal entries A(1) ,..., */
+/* A(N) and offdiagonal entries B(1) ,..., B(N-1)). DSTECH checks to */
+/* see if EIG(1) ,..., EIG(N) are indeed accurate eigenvalues of T. */
+/* It does this by expanding each EIG(I) into an interval */
+/* [SVD(I) - EPS, SVD(I) + EPS], merging overlapping intervals if */
+/* any, and using Sturm sequences to count and verify whether each */
+/* resulting interval has the correct number of eigenvalues (using */
+/* DSTECT). Here EPS = TOL*MAZHEPS*MAXEIG, where MACHEPS is the */
+/* machine precision and MAXEIG is the absolute value of the largest */
+/* eigenvalue. If each interval contains the correct number of */
+/* eigenvalues, INFO = 0 is returned, otherwise INFO is the index of */
+/* the first eigenvalue in the first bad interval. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The dimension of the tridiagonal matrix T. */
+
+/* A (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal entries of the tridiagonal matrix T. */
+
+/* B (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The offdiagonal entries of the tridiagonal matrix T. */
+
+/* EIG (input) DOUBLE PRECISION array, dimension (N) */
+/* The purported eigenvalues to be checked. */
+
+/* TOL (input) DOUBLE PRECISION */
+/* Error tolerance for checking, a multiple of the */
+/* machine precision. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* 0 if the eigenvalues are all correct (to within */
+/* 1 +- TOL*MAZHEPS*MAXEIG) */
+/* >0 if the interval containing the INFO-th eigenvalue */
+/* contains the incorrect number of eigenvalues. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check input parameters */
+
+ /* Parameter adjustments */
+ --work;
+ --eig;
+ --b;
+ --a;
+
+ /* Function Body */
+ *info = 0;
+ if (*n == 0) {
+ return 0;
+ }
+ if (*n < 0) {
+ *info = -1;
+ return 0;
+ }
+ if (*tol < 0.) {
+ *info = -5;
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = dlamch_("Epsilon") * dlamch_("Base");
+ unflep = dlamch_("Safe minimum") / eps;
+ eps = *tol * eps;
+
+/* Compute maximum absolute eigenvalue, error tolerance */
+
+ mx = abs(eig[1]);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = mx, d__3 = (d__1 = eig[i__], abs(d__1));
+ mx = max(d__2,d__3);
+/* L10: */
+ }
+/* Computing MAX */
+ d__1 = eps * mx;
+ eps = max(d__1,unflep);
+
+/* Sort eigenvalues from EIG into WORK */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = eig[i__];
+/* L20: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ isub = 1;
+ emin = work[1];
+ i__2 = *n + 1 - i__;
+ for (j = 2; j <= i__2; ++j) {
+ if (work[j] < emin) {
+ isub = j;
+ emin = work[j];
+ }
+/* L30: */
+ }
+ if (isub != *n + 1 - i__) {
+ work[isub] = work[*n + 1 - i__];
+ work[*n + 1 - i__] = emin;
+ }
+/* L40: */
+ }
+
+/* TPNT points to singular value at right endpoint of interval */
+/* BPNT points to singular value at left endpoint of interval */
+
+ tpnt = 1;
+ bpnt = 1;
+
+/* Begin loop over all intervals */
+
+L50:
+ upper = work[tpnt] + eps;
+ lower = work[bpnt] - eps;
+
+/* Begin loop merging overlapping intervals */
+
+L60:
+ if (bpnt == *n) {
+ goto L70;
+ }
+ tuppr = work[bpnt + 1] + eps;
+ if (tuppr < lower) {
+ goto L70;
+ }
+
+/* Merge */
+
+ ++bpnt;
+ lower = work[bpnt] - eps;
+ goto L60;
+L70:
+
+/* Count singular values in interval [ LOWER, UPPER ] */
+
+ dstect_(n, &a[1], &b[1], &lower, &numl);
+ dstect_(n, &a[1], &b[1], &upper, &numu);
+ count = numu - numl;
+ if (count != bpnt - tpnt + 1) {
+
+/* Wrong number of singular values in interval */
+
+ *info = tpnt;
+ goto L80;
+ }
+ tpnt = bpnt + 1;
+ bpnt = tpnt;
+ if (tpnt <= *n) {
+ goto L50;
+ }
+L80:
+ return 0;
+
+/* End of DSTECH */
+
+} /* dstech_ */
diff --git a/TESTING/EIG/dstect.c b/TESTING/EIG/dstect.c
new file mode 100644
index 0000000..47db9b8
--- /dev/null
+++ b/TESTING/EIG/dstect.c
@@ -0,0 +1,167 @@
+/* dstect.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dstect_(integer *n, doublereal *a, doublereal *b,
+ doublereal *shift, integer *num)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal u, m1, m2, mx, tmp, tom, sun, sov, unfl, ovfl, ssun;
+ extern doublereal dlamch_(char *);
+ doublereal sshift;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSTECT counts the number NUM of eigenvalues of a tridiagonal */
+/* matrix T which are less than or equal to SHIFT. T has */
+/* diagonal entries A(1), ... , A(N), and offdiagonal entries */
+/* B(1), ..., B(N-1). */
+/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */
+/* Matrix", Report CS41, Computer Science Dept., Stanford */
+/* University, July 21, 1966 */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The dimension of the tridiagonal matrix T. */
+
+/* A (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal entries of the tridiagonal matrix T. */
+
+/* B (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The offdiagonal entries of the tridiagonal matrix T. */
+
+/* SHIFT (input) DOUBLE PRECISION */
+/* The shift, used as described under Purpose. */
+
+/* NUM (output) INTEGER */
+/* The number of eigenvalues of T less than or equal */
+/* to SHIFT. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Get machine constants */
+
+ /* Parameter adjustments */
+ --b;
+ --a;
+
+ /* Function Body */
+ unfl = dlamch_("Safe minimum");
+ ovfl = dlamch_("Overflow");
+
+/* Find largest entry */
+
+ mx = abs(a[1]);
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__3 = mx, d__4 = (d__1 = a[i__ + 1], abs(d__1)), d__3 = max(d__3,
+ d__4), d__4 = (d__2 = b[i__], abs(d__2));
+ mx = max(d__3,d__4);
+/* L10: */
+ }
+
+/* Handle easy cases, including zero matrix */
+
+ if (*shift >= mx * 3.) {
+ *num = *n;
+ return 0;
+ }
+ if (*shift < mx * -3.) {
+ *num = 0;
+ return 0;
+ }
+
+/* Compute scale factors as in Kahan's report */
+/* At this point, MX .NE. 0 so we can divide by it */
+
+ sun = sqrt(unfl);
+ ssun = sqrt(sun);
+ sov = sqrt(ovfl);
+ tom = ssun * sov;
+ if (mx <= 1.) {
+ m1 = 1. / mx;
+ m2 = tom;
+ } else {
+ m1 = 1.;
+ m2 = tom / mx;
+ }
+
+/* Begin counting */
+
+ *num = 0;
+ sshift = *shift * m1 * m2;
+ u = a[1] * m1 * m2 - sshift;
+ if (u <= sun) {
+ if (u <= 0.) {
+ ++(*num);
+ if (u > -sun) {
+ u = -sun;
+ }
+ } else {
+ u = sun;
+ }
+ }
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ tmp = b[i__ - 1] * m1 * m2;
+ u = a[i__] * m1 * m2 - tmp * (tmp / u) - sshift;
+ if (u <= sun) {
+ if (u <= 0.) {
+ ++(*num);
+ if (u > -sun) {
+ u = -sun;
+ }
+ } else {
+ u = sun;
+ }
+ }
+/* L20: */
+ }
+ return 0;
+
+/* End of DSTECT */
+
+} /* dstect_ */
diff --git a/TESTING/EIG/dstt21.c b/TESTING/EIG/dstt21.c
new file mode 100644
index 0000000..f1fd553
--- /dev/null
+++ b/TESTING/EIG/dstt21.c
@@ -0,0 +1,244 @@
+/* dstt21.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b5 = 0.;
+static integer c__1 = 1;
+static doublereal c_b19 = 1.;
+
+/* Subroutine */ int dstt21_(integer *n, integer *kband, doublereal *ad,
+ doublereal *ae, doublereal *sd, doublereal *se, doublereal *u,
+ integer *ldu, doublereal *work, doublereal *result)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, i__1;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer j;
+ doublereal ulp, unfl;
+ extern /* Subroutine */ int dsyr_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *);
+ doublereal temp1, temp2;
+ extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ doublereal anorm, wnorm;
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSTT21 checks a decomposition of the form */
+
+/* A = U S U' */
+
+/* where ' means transpose, A is symmetric tridiagonal, U is orthogonal, */
+/* and S is diagonal (if KBAND=0) or symmetric tridiagonal (if KBAND=1). */
+/* Two tests are performed: */
+
+/* RESULT(1) = | A - U S U' | / ( |A| n ulp ) */
+
+/* RESULT(2) = | I - UU' | / ( n ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, DSTT21 does nothing. */
+/* It must be at least zero. */
+
+/* KBAND (input) INTEGER */
+/* The bandwidth of the matrix S. It may only be zero or one. */
+/* If zero, then S is diagonal, and SE is not referenced. If */
+/* one, then S is symmetric tri-diagonal. */
+
+/* AD (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal of the original (unfactored) matrix A. A is */
+/* assumed to be symmetric tridiagonal. */
+
+/* AE (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The off-diagonal of the original (unfactored) matrix A. A */
+/* is assumed to be symmetric tridiagonal. AE(1) is the (1,2) */
+/* and (2,1) element, AE(2) is the (2,3) and (3,2) element, etc. */
+
+/* SD (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal of the (symmetric tri-) diagonal matrix S. */
+
+/* SE (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The off-diagonal of the (symmetric tri-) diagonal matrix S. */
+/* Not referenced if KBSND=0. If KBAND=1, then AE(1) is the */
+/* (1,2) and (2,1) element, SE(2) is the (2,3) and (3,2) */
+/* element, etc. */
+
+/* U (input) DOUBLE PRECISION array, dimension (LDU, N) */
+/* The orthogonal matrix in the decomposition. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N*(N+1)) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+/* RESULT(1) is always modified. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Constants */
+
+ /* Parameter adjustments */
+ --ad;
+ --ae;
+ --sd;
+ --se;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --work;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.;
+ result[2] = 0.;
+ if (*n <= 0) {
+ return 0;
+ }
+
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Precision");
+
+/* Do Test 1 */
+
+/* Copy A & Compute its 1-Norm: */
+
+ dlaset_("Full", n, n, &c_b5, &c_b5, &work[1], n);
+
+ anorm = 0.;
+ temp1 = 0.;
+
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ work[(*n + 1) * (j - 1) + 1] = ad[j];
+ work[(*n + 1) * (j - 1) + 2] = ae[j];
+ temp2 = (d__1 = ae[j], abs(d__1));
+/* Computing MAX */
+ d__2 = anorm, d__3 = (d__1 = ad[j], abs(d__1)) + temp1 + temp2;
+ anorm = max(d__2,d__3);
+ temp1 = temp2;
+/* L10: */
+ }
+
+/* Computing 2nd power */
+ i__1 = *n;
+ work[i__1 * i__1] = ad[*n];
+/* Computing MAX */
+ d__2 = anorm, d__3 = (d__1 = ad[*n], abs(d__1)) + temp1, d__2 = max(d__2,
+ d__3);
+ anorm = max(d__2,unfl);
+
+/* Norm of A - USU' */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ d__1 = -sd[j];
+ dsyr_("L", n, &d__1, &u[j * u_dim1 + 1], &c__1, &work[1], n);
+/* L20: */
+ }
+
+ if (*n > 1 && *kband == 1) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ d__1 = -se[j];
+ dsyr2_("L", n, &d__1, &u[j * u_dim1 + 1], &c__1, &u[(j + 1) *
+ u_dim1 + 1], &c__1, &work[1], n);
+/* L30: */
+ }
+ }
+
+/* Computing 2nd power */
+ i__1 = *n;
+ wnorm = dlansy_("1", "L", n, &work[1], n, &work[i__1 * i__1 + 1]);
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.) {
+/* Computing MIN */
+ d__1 = wnorm, d__2 = *n * anorm;
+ result[1] = min(d__1,d__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
+ result[1] = min(d__1,d__2) / (*n * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute UU' - I */
+
+ dgemm_("N", "C", n, n, n, &c_b19, &u[u_offset], ldu, &u[u_offset], ldu, &
+ c_b5, &work[1], n);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[(*n + 1) * (j - 1) + 1] += -1.;
+/* L40: */
+ }
+
+/* Computing MIN */
+/* Computing 2nd power */
+ i__1 = *n;
+ d__1 = (doublereal) (*n), d__2 = dlange_("1", n, n, &work[1], n, &work[
+ i__1 * i__1 + 1]);
+ result[2] = min(d__1,d__2) / (*n * ulp);
+
+ return 0;
+
+/* End of DSTT21 */
+
+} /* dstt21_ */
diff --git a/TESTING/EIG/dstt22.c b/TESTING/EIG/dstt22.c
new file mode 100644
index 0000000..a67e7eb
--- /dev/null
+++ b/TESTING/EIG/dstt22.c
@@ -0,0 +1,248 @@
+/* dstt22.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b12 = 1.;
+static doublereal c_b13 = 0.;
+
+/* Subroutine */ int dstt22_(integer *n, integer *m, integer *kband,
+ doublereal *ad, doublereal *ae, doublereal *sd, doublereal *se,
+ doublereal *u, integer *ldu, doublereal *work, integer *ldwork,
+ doublereal *result)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, work_dim1, work_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2, d__3, d__4, d__5;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal ulp, aukj, unfl;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ doublereal anorm, wnorm;
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *),
+ dlansy_(char *, char *, integer *, doublereal *, integer *,
+ doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSTT22 checks a set of M eigenvalues and eigenvectors, */
+
+/* A U = U S */
+
+/* where A is symmetric tridiagonal, the columns of U are orthogonal, */
+/* and S is diagonal (if KBAND=0) or symmetric tridiagonal (if KBAND=1). */
+/* Two tests are performed: */
+
+/* RESULT(1) = | U' A U - S | / ( |A| m ulp ) */
+
+/* RESULT(2) = | I - U'U | / ( m ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, DSTT22 does nothing. */
+/* It must be at least zero. */
+
+/* M (input) INTEGER */
+/* The number of eigenpairs to check. If it is zero, DSTT22 */
+/* does nothing. It must be at least zero. */
+
+/* KBAND (input) INTEGER */
+/* The bandwidth of the matrix S. It may only be zero or one. */
+/* If zero, then S is diagonal, and SE is not referenced. If */
+/* one, then S is symmetric tri-diagonal. */
+
+/* AD (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal of the original (unfactored) matrix A. A is */
+/* assumed to be symmetric tridiagonal. */
+
+/* AE (input) DOUBLE PRECISION array, dimension (N) */
+/* The off-diagonal of the original (unfactored) matrix A. A */
+/* is assumed to be symmetric tridiagonal. AE(1) is ignored, */
+/* AE(2) is the (1,2) and (2,1) element, etc. */
+
+/* SD (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal of the (symmetric tri-) diagonal matrix S. */
+
+/* SE (input) DOUBLE PRECISION array, dimension (N) */
+/* The off-diagonal of the (symmetric tri-) diagonal matrix S. */
+/* Not referenced if KBSND=0. If KBAND=1, then AE(1) is */
+/* ignored, SE(2) is the (1,2) and (2,1) element, etc. */
+
+/* U (input) DOUBLE PRECISION array, dimension (LDU, N) */
+/* The orthogonal matrix in the decomposition. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK, M+1) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of WORK. LDWORK must be at least */
+/* max(1,M). */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ad;
+ --ae;
+ --sd;
+ --se;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.;
+ result[2] = 0.;
+ if (*n <= 0 || *m <= 0) {
+ return 0;
+ }
+
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon");
+
+/* Do Test 1 */
+
+/* Compute the 1-norm of A. */
+
+ if (*n > 1) {
+ anorm = abs(ad[1]) + abs(ae[1]);
+ i__1 = *n - 1;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MAX */
+ d__4 = anorm, d__5 = (d__1 = ad[j], abs(d__1)) + (d__2 = ae[j],
+ abs(d__2)) + (d__3 = ae[j - 1], abs(d__3));
+ anorm = max(d__4,d__5);
+/* L10: */
+ }
+/* Computing MAX */
+ d__3 = anorm, d__4 = (d__1 = ad[*n], abs(d__1)) + (d__2 = ae[*n - 1],
+ abs(d__2));
+ anorm = max(d__3,d__4);
+ } else {
+ anorm = abs(ad[1]);
+ }
+ anorm = max(anorm,unfl);
+
+/* Norm of U'AU - S */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *m;
+ for (j = 1; j <= i__2; ++j) {
+ work[i__ + j * work_dim1] = 0.;
+ i__3 = *n;
+ for (k = 1; k <= i__3; ++k) {
+ aukj = ad[k] * u[k + j * u_dim1];
+ if (k != *n) {
+ aukj += ae[k] * u[k + 1 + j * u_dim1];
+ }
+ if (k != 1) {
+ aukj += ae[k - 1] * u[k - 1 + j * u_dim1];
+ }
+ work[i__ + j * work_dim1] += u[k + i__ * u_dim1] * aukj;
+/* L20: */
+ }
+/* L30: */
+ }
+ work[i__ + i__ * work_dim1] -= sd[i__];
+ if (*kband == 1) {
+ if (i__ != 1) {
+ work[i__ + (i__ - 1) * work_dim1] -= se[i__ - 1];
+ }
+ if (i__ != *n) {
+ work[i__ + (i__ + 1) * work_dim1] -= se[i__];
+ }
+ }
+/* L40: */
+ }
+
+ wnorm = dlansy_("1", "L", m, &work[work_offset], m, &work[(*m + 1) *
+ work_dim1 + 1]);
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*m * ulp);
+ } else {
+ if (anorm < 1.) {
+/* Computing MIN */
+ d__1 = wnorm, d__2 = *m * anorm;
+ result[1] = min(d__1,d__2) / anorm / (*m * ulp);
+ } else {
+/* Computing MIN */
+ d__1 = wnorm / anorm, d__2 = (doublereal) (*m);
+ result[1] = min(d__1,d__2) / (*m * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute U'U - I */
+
+ dgemm_("T", "N", m, m, n, &c_b12, &u[u_offset], ldu, &u[u_offset], ldu, &
+ c_b13, &work[work_offset], m);
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ work[j + j * work_dim1] += -1.;
+/* L50: */
+ }
+
+/* Computing MIN */
+ d__1 = (doublereal) (*m), d__2 = dlange_("1", m, m, &work[work_offset], m,
+ &work[(*m + 1) * work_dim1 + 1]);
+ result[2] = min(d__1,d__2) / (*m * ulp);
+
+ return 0;
+
+/* End of DSTT22 */
+
+} /* dstt22_ */
diff --git a/TESTING/EIG/dsvdch.c b/TESTING/EIG/dsvdch.c
new file mode 100644
index 0000000..d4e4942
--- /dev/null
+++ b/TESTING/EIG/dsvdch.c
@@ -0,0 +1,191 @@
+/* dsvdch.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dsvdch_(integer *n, doublereal *s, doublereal *e,
+ doublereal *svd, doublereal *tol, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ doublereal eps;
+ integer bpnt;
+ doublereal unfl, ovfl;
+ integer numl, numu, tpnt, count;
+ doublereal lower, upper, tuppr;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dsvdct_(integer *, doublereal *, doublereal *,
+ doublereal *, integer *);
+ doublereal unflep;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSVDCH checks to see if SVD(1) ,..., SVD(N) are accurate singular */
+/* values of the bidiagonal matrix B with diagonal entries */
+/* S(1) ,..., S(N) and superdiagonal entries E(1) ,..., E(N-1)). */
+/* It does this by expanding each SVD(I) into an interval */
+/* [SVD(I) * (1-EPS) , SVD(I) * (1+EPS)], merging overlapping intervals */
+/* if any, and using Sturm sequences to count and verify whether each */
+/* resulting interval has the correct number of singular values (using */
+/* DSVDCT). Here EPS=TOL*MAX(N/10,1)*MAZHEP, where MACHEP is the */
+/* machine precision. The routine assumes the singular values are sorted */
+/* with SVD(1) the largest and SVD(N) smallest. If each interval */
+/* contains the correct number of singular values, INFO = 0 is returned, */
+/* otherwise INFO is the index of the first singular value in the first */
+/* bad interval. */
+
+/* Arguments */
+/* ========== */
+
+/* N (input) INTEGER */
+/* The dimension of the bidiagonal matrix B. */
+
+/* S (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal entries of the bidiagonal matrix B. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The superdiagonal entries of the bidiagonal matrix B. */
+
+/* SVD (input) DOUBLE PRECISION array, dimension (N) */
+/* The computed singular values to be checked. */
+
+/* TOL (input) DOUBLE PRECISION */
+/* Error tolerance for checking, a multiplier of the */
+/* machine precision. */
+
+/* INFO (output) INTEGER */
+/* =0 if the singular values are all correct (to within */
+/* 1 +- TOL*MAZHEPS) */
+/* >0 if the interval containing the INFO-th singular value */
+/* contains the incorrect number of singular values. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Get machine constants */
+
+ /* Parameter adjustments */
+ --svd;
+ --e;
+ --s;
+
+ /* Function Body */
+ *info = 0;
+ if (*n <= 0) {
+ return 0;
+ }
+ unfl = dlamch_("Safe minimum");
+ ovfl = dlamch_("Overflow");
+ eps = dlamch_("Epsilon") * dlamch_("Base");
+
+/* UNFLEP is chosen so that when an eigenvalue is multiplied by the */
+/* scale factor sqrt(OVFL)*sqrt(sqrt(UNFL))/MX in DSVDCT, it exceeds */
+/* sqrt(UNFL), which is the lower limit for DSVDCT. */
+
+ unflep = sqrt(sqrt(unfl)) / sqrt(ovfl) * svd[1] + unfl / eps;
+
+/* The value of EPS works best when TOL .GE. 10. */
+
+/* Computing MAX */
+ i__1 = *n / 10;
+ eps = *tol * max(i__1,1) * eps;
+
+/* TPNT points to singular value at right endpoint of interval */
+/* BPNT points to singular value at left endpoint of interval */
+
+ tpnt = 1;
+ bpnt = 1;
+
+/* Begin loop over all intervals */
+
+L10:
+ upper = (eps + 1.) * svd[tpnt] + unflep;
+ lower = (1. - eps) * svd[bpnt] - unflep;
+ if (lower <= unflep) {
+ lower = -upper;
+ }
+
+/* Begin loop merging overlapping intervals */
+
+L20:
+ if (bpnt == *n) {
+ goto L30;
+ }
+ tuppr = (eps + 1.) * svd[bpnt + 1] + unflep;
+ if (tuppr < lower) {
+ goto L30;
+ }
+
+/* Merge */
+
+ ++bpnt;
+ lower = (1. - eps) * svd[bpnt] - unflep;
+ if (lower <= unflep) {
+ lower = -upper;
+ }
+ goto L20;
+L30:
+
+/* Count singular values in interval [ LOWER, UPPER ] */
+
+ dsvdct_(n, &s[1], &e[1], &lower, &numl);
+ dsvdct_(n, &s[1], &e[1], &upper, &numu);
+ count = numu - numl;
+ if (lower < 0.) {
+ count /= 2;
+ }
+ if (count != bpnt - tpnt + 1) {
+
+/* Wrong number of singular values in interval */
+
+ *info = tpnt;
+ goto L40;
+ }
+ tpnt = bpnt + 1;
+ bpnt = tpnt;
+ if (tpnt <= *n) {
+ goto L10;
+ }
+L40:
+ return 0;
+
+/* End of DSVDCH */
+
+} /* dsvdch_ */
diff --git a/TESTING/EIG/dsvdct.c b/TESTING/EIG/dsvdct.c
new file mode 100644
index 0000000..9e3487e
--- /dev/null
+++ b/TESTING/EIG/dsvdct.c
@@ -0,0 +1,194 @@
+/* dsvdct.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dsvdct_(integer *n, doublereal *s, doublereal *e,
+ doublereal *shift, integer *num)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal u, m1, m2, mx, tmp, tom, sun, sov, unfl, ovfl, ssun;
+ extern doublereal dlamch_(char *);
+ doublereal sshift;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSVDCT counts the number NUM of eigenvalues of a 2*N by 2*N */
+/* tridiagonal matrix T which are less than or equal to SHIFT. T is */
+/* formed by putting zeros on the diagonal and making the off-diagonals */
+/* equal to S(1), E(1), S(2), E(2), ... , E(N-1), S(N). If SHIFT is */
+/* positive, NUM is equal to N plus the number of singular values of a */
+/* bidiagonal matrix B less than or equal to SHIFT. Here B has diagonal */
+/* entries S(1), ..., S(N) and superdiagonal entries E(1), ... E(N-1). */
+/* If SHIFT is negative, NUM is equal to the number of singular values */
+/* of B greater than or equal to -SHIFT. */
+
+/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */
+/* Matrix", Report CS41, Computer Science Dept., Stanford University, */
+/* July 21, 1966 */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The dimension of the bidiagonal matrix B. */
+
+/* S (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal entries of the bidiagonal matrix B. */
+
+/* E (input) DOUBLE PRECISION array of dimension (N-1) */
+/* The superdiagonal entries of the bidiagonal matrix B. */
+
+/* SHIFT (input) DOUBLE PRECISION */
+/* The shift, used as described under Purpose. */
+
+/* NUM (output) INTEGER */
+/* The number of eigenvalues of T less than or equal to SHIFT. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Get machine constants */
+
+ /* Parameter adjustments */
+ --e;
+ --s;
+
+ /* Function Body */
+ unfl = dlamch_("Safe minimum") * 2;
+ ovfl = 1. / unfl;
+
+/* Find largest entry */
+
+ mx = abs(s[1]);
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__3 = mx, d__4 = (d__1 = s[i__ + 1], abs(d__1)), d__3 = max(d__3,
+ d__4), d__4 = (d__2 = e[i__], abs(d__2));
+ mx = max(d__3,d__4);
+/* L10: */
+ }
+
+ if (mx == 0.) {
+ if (*shift < 0.) {
+ *num = 0;
+ } else {
+ *num = *n << 1;
+ }
+ return 0;
+ }
+
+/* Compute scale factors as in Kahan's report */
+
+ sun = sqrt(unfl);
+ ssun = sqrt(sun);
+ sov = sqrt(ovfl);
+ tom = ssun * sov;
+ if (mx <= 1.) {
+ m1 = 1. / mx;
+ m2 = tom;
+ } else {
+ m1 = 1.;
+ m2 = tom / mx;
+ }
+
+/* Begin counting */
+
+ u = 1.;
+ *num = 0;
+ sshift = *shift * m1 * m2;
+ u = -sshift;
+ if (u <= sun) {
+ if (u <= 0.) {
+ ++(*num);
+ if (u > -sun) {
+ u = -sun;
+ }
+ } else {
+ u = sun;
+ }
+ }
+ tmp = s[1] * m1 * m2;
+ u = -tmp * (tmp / u) - sshift;
+ if (u <= sun) {
+ if (u <= 0.) {
+ ++(*num);
+ if (u > -sun) {
+ u = -sun;
+ }
+ } else {
+ u = sun;
+ }
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = e[i__] * m1 * m2;
+ u = -tmp * (tmp / u) - sshift;
+ if (u <= sun) {
+ if (u <= 0.) {
+ ++(*num);
+ if (u > -sun) {
+ u = -sun;
+ }
+ } else {
+ u = sun;
+ }
+ }
+ tmp = s[i__ + 1] * m1 * m2;
+ u = -tmp * (tmp / u) - sshift;
+ if (u <= sun) {
+ if (u <= 0.) {
+ ++(*num);
+ if (u > -sun) {
+ u = -sun;
+ }
+ } else {
+ u = sun;
+ }
+ }
+/* L20: */
+ }
+ return 0;
+
+/* End of DSVDCT */
+
+} /* dsvdct_ */
diff --git a/TESTING/EIG/dsxt1.c b/TESTING/EIG/dsxt1.c
new file mode 100644
index 0000000..c4ce744
--- /dev/null
+++ b/TESTING/EIG/dsxt1.c
@@ -0,0 +1,134 @@
+/* dsxt1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dsxt1_(integer *ijob, doublereal *d1, integer *n1, doublereal *d2,
+ integer *n2, doublereal *abstol, doublereal *ulp, doublereal *unfl)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal ret_val, d__1, d__2, d__3, d__4;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal temp1, temp2;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSXT1 computes the difference between a set of eigenvalues. */
+/* The result is returned as the function value. */
+
+/* IJOB = 1: Computes max { min | D1(i)-D2(j) | } */
+/* i j */
+
+/* IJOB = 2: Computes max { min | D1(i)-D2(j) | / */
+/* i j */
+/* ( ABSTOL + |D1(i)|*ULP ) } */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the type of tests to be performed. (See above.) */
+
+/* D1 (input) DOUBLE PRECISION array, dimension (N1) */
+/* The first array. D1 should be in increasing order, i.e., */
+/* D1(j) <= D1(j+1). */
+
+/* N1 (input) INTEGER */
+/* The length of D1. */
+
+/* D2 (input) DOUBLE PRECISION array, dimension (N2) */
+/* The second array. D2 should be in increasing order, i.e., */
+/* D2(j) <= D2(j+1). */
+
+/* N2 (input) INTEGER */
+/* The length of D2. */
+
+/* ABSTOL (input) DOUBLE PRECISION */
+/* The absolute tolerance, used as a measure of the error. */
+
+/* ULP (input) DOUBLE PRECISION */
+/* Machine precision. */
+
+/* UNFL (input) DOUBLE PRECISION */
+/* The smallest positive number whose reciprocal does not */
+/* overflow. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --d2;
+ --d1;
+
+ /* Function Body */
+ temp1 = 0.;
+
+ j = 1;
+ i__1 = *n1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+L10:
+ if (d2[j] < d1[i__] && j < *n2) {
+ ++j;
+ goto L10;
+ }
+ if (j == 1) {
+ temp2 = (d__1 = d2[j] - d1[i__], abs(d__1));
+ if (*ijob == 2) {
+/* Computing MAX */
+ d__2 = *unfl, d__3 = *abstol + *ulp * (d__1 = d1[i__], abs(
+ d__1));
+ temp2 /= max(d__2,d__3);
+ }
+ } else {
+/* Computing MIN */
+ d__3 = (d__1 = d2[j] - d1[i__], abs(d__1)), d__4 = (d__2 = d1[i__]
+ - d2[j - 1], abs(d__2));
+ temp2 = min(d__3,d__4);
+ if (*ijob == 2) {
+/* Computing MAX */
+ d__2 = *unfl, d__3 = *abstol + *ulp * (d__1 = d1[i__], abs(
+ d__1));
+ temp2 /= max(d__2,d__3);
+ }
+ }
+ temp1 = max(temp1,temp2);
+/* L20: */
+ }
+
+ ret_val = temp1;
+ return ret_val;
+
+/* End of DSXT1 */
+
+} /* dsxt1_ */
diff --git a/TESTING/EIG/dsyt21.c b/TESTING/EIG/dsyt21.c
new file mode 100644
index 0000000..2bde63f
--- /dev/null
+++ b/TESTING/EIG/dsyt21.c
@@ -0,0 +1,455 @@
+/* dsyt21.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b10 = 0.;
+static integer c__1 = 1;
+static doublereal c_b42 = 1.;
+
+/* Subroutine */ int dsyt21_(integer *itype, char *uplo, integer *n, integer *
+ kband, doublereal *a, integer *lda, doublereal *d__, doublereal *e,
+ doublereal *u, integer *ldu, doublereal *v, integer *ldv, doublereal *
+ tau, doublereal *work, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2,
+ i__3;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j, jr;
+ doublereal ulp;
+ integer jcol;
+ doublereal unfl;
+ integer jrow;
+ extern /* Subroutine */ int dsyr_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *), dsyr2_(
+ char *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *), dgemm_(
+ char *, char *, integer *, integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ doublereal anorm;
+ char cuplo[1];
+ doublereal vsave;
+ logical lower;
+ doublereal wnorm;
+ extern /* Subroutine */ int dorm2l_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *), dorm2r_(char
+ *, char *, integer *, integer *, integer *, doublereal *, integer
+ *, doublereal *, doublereal *, integer *, doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), dlarfy_(char *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYT21 generally checks a decomposition of the form */
+
+/* A = U S U' */
+
+/* where ' means transpose, A is symmetric, U is orthogonal, and S is */
+/* diagonal (if KBAND=0) or symmetric tridiagonal (if KBAND=1). */
+
+/* If ITYPE=1, then U is represented as a dense matrix; otherwise U is */
+/* expressed as a product of Householder transformations, whose vectors */
+/* are stored in the array "V" and whose scaling constants are in "TAU". */
+/* We shall use the letter "V" to refer to the product of Householder */
+/* transformations (which should be equal to U). */
+
+/* Specifically, if ITYPE=1, then: */
+
+/* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU' | / ( n ulp ) */
+
+/* If ITYPE=2, then: */
+
+/* RESULT(1) = | A - V S V' | / ( |A| n ulp ) */
+
+/* If ITYPE=3, then: */
+
+/* RESULT(1) = | I - VU' | / ( n ulp ) */
+
+/* For ITYPE > 1, the transformation U is expressed as a product */
+/* V = H(1)...H(n-2), where H(j) = I - tau(j) v(j) v(j)' and each */
+/* vector v(j) has its first j elements 0 and the remaining n-j elements */
+/* stored in V(j+1:n,j). */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the type of tests to be performed. */
+/* 1: U expressed as a dense orthogonal matrix: */
+/* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU' | / ( n ulp ) */
+
+/* 2: U expressed as a product V of Housholder transformations: */
+/* RESULT(1) = | A - V S V' | / ( |A| n ulp ) */
+
+/* 3: U expressed both as a dense orthogonal matrix and */
+/* as a product of Housholder transformations: */
+/* RESULT(1) = | I - VU' | / ( n ulp ) */
+
+/* UPLO (input) CHARACTER */
+/* If UPLO='U', the upper triangle of A and V will be used and */
+/* the (strictly) lower triangle will not be referenced. */
+/* If UPLO='L', the lower triangle of A and V will be used and */
+/* the (strictly) upper triangle will not be referenced. */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, DSYT21 does nothing. */
+/* It must be at least zero. */
+
+/* KBAND (input) INTEGER */
+/* The bandwidth of the matrix. It may only be zero or one. */
+/* If zero, then S is diagonal, and E is not referenced. If */
+/* one, then S is symmetric tri-diagonal. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA, N) */
+/* The original (unfactored) matrix. It is assumed to be */
+/* symmetric, and only the upper (UPLO='U') or only the lower */
+/* (UPLO='L') will be referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least N. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal of the (symmetric tri-) diagonal matrix. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The off-diagonal of the (symmetric tri-) diagonal matrix. */
+/* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and */
+/* (3,2) element, etc. */
+/* Not referenced if KBAND=0. */
+
+/* U (input) DOUBLE PRECISION array, dimension (LDU, N) */
+/* If ITYPE=1 or 3, this contains the orthogonal matrix in */
+/* the decomposition, expressed as a dense matrix. If ITYPE=2, */
+/* then it is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+
+/* V (input) DOUBLE PRECISION array, dimension (LDV, N) */
+/* If ITYPE=2 or 3, the columns of this array contain the */
+/* Householder vectors used to describe the orthogonal matrix */
+/* in the decomposition. If UPLO='L', then the vectors are in */
+/* the lower triangle, if UPLO='U', then in the upper */
+/* triangle. */
+/* *NOTE* If ITYPE=2 or 3, V is modified and restored. The */
+/* subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U') */
+/* is set to one, and later reset to its original value, during */
+/* the course of the calculation. */
+/* If ITYPE=1, then it is neither referenced nor modified. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of V. LDV must be at least N and */
+/* at least 1. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (N) */
+/* If ITYPE >= 2, then TAU(j) is the scalar factor of */
+/* v(j) v(j)' in the Householder transformation H(j) of */
+/* the product U = H(1)...H(n-2) */
+/* If ITYPE < 2, then TAU is not referenced. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N**2) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+/* RESULT(1) is always modified. RESULT(2) is modified only */
+/* if ITYPE=1. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --tau;
+ --work;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.;
+ if (*itype == 1) {
+ result[2] = 0.;
+ }
+ if (*n <= 0) {
+ return 0;
+ }
+
+ if (lsame_(uplo, "U")) {
+ lower = FALSE_;
+ *(unsigned char *)cuplo = 'U';
+ } else {
+ lower = TRUE_;
+ *(unsigned char *)cuplo = 'L';
+ }
+
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+
+/* Some Error Checks */
+
+ if (*itype < 1 || *itype > 3) {
+ result[1] = 10. / ulp;
+ return 0;
+ }
+
+/* Do Test 1 */
+
+/* Norm of A: */
+
+ if (*itype == 3) {
+ anorm = 1.;
+ } else {
+/* Computing MAX */
+ d__1 = dlansy_("1", cuplo, n, &a[a_offset], lda, &work[1]);
+ anorm = max(d__1,unfl);
+ }
+
+/* Compute error matrix: */
+
+ if (*itype == 1) {
+
+/* ITYPE=1: error = A - U S U' */
+
+ dlaset_("Full", n, n, &c_b10, &c_b10, &work[1], n);
+ dlacpy_(cuplo, n, n, &a[a_offset], lda, &work[1], n);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ d__1 = -d__[j];
+ dsyr_(cuplo, n, &d__1, &u[j * u_dim1 + 1], &c__1, &work[1], n);
+/* L10: */
+ }
+
+ if (*n > 1 && *kband == 1) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ d__1 = -e[j];
+ dsyr2_(cuplo, n, &d__1, &u[j * u_dim1 + 1], &c__1, &u[(j + 1)
+ * u_dim1 + 1], &c__1, &work[1], n);
+/* L20: */
+ }
+ }
+/* Computing 2nd power */
+ i__1 = *n;
+ wnorm = dlansy_("1", cuplo, n, &work[1], n, &work[i__1 * i__1 + 1]);
+
+ } else if (*itype == 2) {
+
+/* ITYPE=2: error = V S V' - A */
+
+ dlaset_("Full", n, n, &c_b10, &c_b10, &work[1], n);
+
+ if (lower) {
+/* Computing 2nd power */
+ i__1 = *n;
+ work[i__1 * i__1] = d__[*n];
+ for (j = *n - 1; j >= 1; --j) {
+ if (*kband == 1) {
+ work[(*n + 1) * (j - 1) + 2] = (1. - tau[j]) * e[j];
+ i__1 = *n;
+ for (jr = j + 2; jr <= i__1; ++jr) {
+ work[(j - 1) * *n + jr] = -tau[j] * e[j] * v[jr + j *
+ v_dim1];
+/* L30: */
+ }
+ }
+
+ vsave = v[j + 1 + j * v_dim1];
+ v[j + 1 + j * v_dim1] = 1.;
+ i__1 = *n - j;
+/* Computing 2nd power */
+ i__2 = *n;
+ dlarfy_("L", &i__1, &v[j + 1 + j * v_dim1], &c__1, &tau[j], &
+ work[(*n + 1) * j + 1], n, &work[i__2 * i__2 + 1]);
+ v[j + 1 + j * v_dim1] = vsave;
+ work[(*n + 1) * (j - 1) + 1] = d__[j];
+/* L40: */
+ }
+ } else {
+ work[1] = d__[1];
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ if (*kband == 1) {
+ work[(*n + 1) * j] = (1. - tau[j]) * e[j];
+ i__2 = j - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ work[j * *n + jr] = -tau[j] * e[j] * v[jr + (j + 1) *
+ v_dim1];
+/* L50: */
+ }
+ }
+
+ vsave = v[j + (j + 1) * v_dim1];
+ v[j + (j + 1) * v_dim1] = 1.;
+/* Computing 2nd power */
+ i__2 = *n;
+ dlarfy_("U", &j, &v[(j + 1) * v_dim1 + 1], &c__1, &tau[j], &
+ work[1], n, &work[i__2 * i__2 + 1]);
+ v[j + (j + 1) * v_dim1] = vsave;
+ work[(*n + 1) * j + 1] = d__[j + 1];
+/* L60: */
+ }
+ }
+
+ i__1 = *n;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ if (lower) {
+ i__2 = *n;
+ for (jrow = jcol; jrow <= i__2; ++jrow) {
+ work[jrow + *n * (jcol - 1)] -= a[jrow + jcol * a_dim1];
+/* L70: */
+ }
+ } else {
+ i__2 = jcol;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ work[jrow + *n * (jcol - 1)] -= a[jrow + jcol * a_dim1];
+/* L80: */
+ }
+ }
+/* L90: */
+ }
+/* Computing 2nd power */
+ i__1 = *n;
+ wnorm = dlansy_("1", cuplo, n, &work[1], n, &work[i__1 * i__1 + 1]);
+
+ } else if (*itype == 3) {
+
+/* ITYPE=3: error = U V' - I */
+
+ if (*n < 2) {
+ return 0;
+ }
+ dlacpy_(" ", n, n, &u[u_offset], ldu, &work[1], n);
+ if (lower) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+/* Computing 2nd power */
+ i__3 = *n;
+ dorm2r_("R", "T", n, &i__1, &i__2, &v[v_dim1 + 2], ldv, &tau[1], &
+ work[*n + 1], n, &work[i__3 * i__3 + 1], &iinfo);
+ } else {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+/* Computing 2nd power */
+ i__3 = *n;
+ dorm2l_("R", "T", n, &i__1, &i__2, &v[(v_dim1 << 1) + 1], ldv, &
+ tau[1], &work[1], n, &work[i__3 * i__3 + 1], &iinfo);
+ }
+ if (iinfo != 0) {
+ result[1] = 10. / ulp;
+ return 0;
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[(*n + 1) * (j - 1) + 1] += -1.;
+/* L100: */
+ }
+
+/* Computing 2nd power */
+ i__1 = *n;
+ wnorm = dlange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]);
+ }
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.) {
+/* Computing MIN */
+ d__1 = wnorm, d__2 = *n * anorm;
+ result[1] = min(d__1,d__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
+ result[1] = min(d__1,d__2) / (*n * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute UU' - I */
+
+ if (*itype == 1) {
+ dgemm_("N", "C", n, n, n, &c_b42, &u[u_offset], ldu, &u[u_offset],
+ ldu, &c_b10, &work[1], n);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[(*n + 1) * (j - 1) + 1] += -1.;
+/* L110: */
+ }
+
+/* Computing MIN */
+/* Computing 2nd power */
+ i__1 = *n;
+ d__1 = dlange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]), d__2 = (doublereal) (*n);
+ result[2] = min(d__1,d__2) / (*n * ulp);
+ }
+
+ return 0;
+
+/* End of DSYT21 */
+
+} /* dsyt21_ */
diff --git a/TESTING/EIG/dsyt22.c b/TESTING/EIG/dsyt22.c
new file mode 100644
index 0000000..851e173
--- /dev/null
+++ b/TESTING/EIG/dsyt22.c
@@ -0,0 +1,277 @@
+/* dsyt22.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b6 = 1.;
+static doublereal c_b7 = 0.;
+
+/* Subroutine */ int dsyt22_(integer *itype, char *uplo, integer *n, integer *
+ m, integer *kband, doublereal *a, integer *lda, doublereal *d__,
+ doublereal *e, doublereal *u, integer *ldu, doublereal *v, integer *
+ ldv, doublereal *tau, doublereal *work, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j, jj, nn, jj1, jj2;
+ doublereal ulp;
+ integer nnp1;
+ doublereal unfl;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *),
+ dort01_(char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *);
+ doublereal anorm;
+ extern /* Subroutine */ int dsymm_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ doublereal wnorm;
+ extern doublereal dlamch_(char *), dlansy_(char *, char *,
+ integer *, doublereal *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYT22 generally checks a decomposition of the form */
+
+/* A U = U S */
+
+/* where A is symmetric, the columns of U are orthonormal, and S */
+/* is diagonal (if KBAND=0) or symmetric tridiagonal (if */
+/* KBAND=1). If ITYPE=1, then U is represented as a dense matrix, */
+/* otherwise the U is expressed as a product of Householder */
+/* transformations, whose vectors are stored in the array "V" and */
+/* whose scaling constants are in "TAU"; we shall use the letter */
+/* "V" to refer to the product of Householder transformations */
+/* (which should be equal to U). */
+
+/* Specifically, if ITYPE=1, then: */
+
+/* RESULT(1) = | U' A U - S | / ( |A| m ulp ) *and* */
+/* RESULT(2) = | I - U'U | / ( m ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE INTEGER */
+/* Specifies the type of tests to be performed. */
+/* 1: U expressed as a dense orthogonal matrix: */
+/* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU' | / ( n ulp ) */
+
+/* UPLO CHARACTER */
+/* If UPLO='U', the upper triangle of A will be used and the */
+/* (strictly) lower triangle will not be referenced. If */
+/* UPLO='L', the lower triangle of A will be used and the */
+/* (strictly) upper triangle will not be referenced. */
+/* Not modified. */
+
+/* N INTEGER */
+/* The size of the matrix. If it is zero, DSYT22 does nothing. */
+/* It must be at least zero. */
+/* Not modified. */
+
+/* M INTEGER */
+/* The number of columns of U. If it is zero, DSYT22 does */
+/* nothing. It must be at least zero. */
+/* Not modified. */
+
+/* KBAND INTEGER */
+/* The bandwidth of the matrix. It may only be zero or one. */
+/* If zero, then S is diagonal, and E is not referenced. If */
+/* one, then S is symmetric tri-diagonal. */
+/* Not modified. */
+
+/* A DOUBLE PRECISION array, dimension (LDA , N) */
+/* The original (unfactored) matrix. It is assumed to be */
+/* symmetric, and only the upper (UPLO='U') or only the lower */
+/* (UPLO='L') will be referenced. */
+/* Not modified. */
+
+/* LDA INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least N. */
+/* Not modified. */
+
+/* D DOUBLE PRECISION array, dimension (N) */
+/* The diagonal of the (symmetric tri-) diagonal matrix. */
+/* Not modified. */
+
+/* E DOUBLE PRECISION array, dimension (N) */
+/* The off-diagonal of the (symmetric tri-) diagonal matrix. */
+/* E(1) is ignored, E(2) is the (1,2) and (2,1) element, etc. */
+/* Not referenced if KBAND=0. */
+/* Not modified. */
+
+/* U DOUBLE PRECISION array, dimension (LDU, N) */
+/* If ITYPE=1 or 3, this contains the orthogonal matrix in */
+/* the decomposition, expressed as a dense matrix. If ITYPE=2, */
+/* then it is not referenced. */
+/* Not modified. */
+
+/* LDU INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+/* Not modified. */
+
+/* V DOUBLE PRECISION array, dimension (LDV, N) */
+/* If ITYPE=2 or 3, the lower triangle of this array contains */
+/* the Householder vectors used to describe the orthogonal */
+/* matrix in the decomposition. If ITYPE=1, then it is not */
+/* referenced. */
+/* Not modified. */
+
+/* LDV INTEGER */
+/* The leading dimension of V. LDV must be at least N and */
+/* at least 1. */
+/* Not modified. */
+
+/* TAU DOUBLE PRECISION array, dimension (N) */
+/* If ITYPE >= 2, then TAU(j) is the scalar factor of */
+/* v(j) v(j)' in the Householder transformation H(j) of */
+/* the product U = H(1)...H(n-2) */
+/* If ITYPE < 2, then TAU is not referenced. */
+/* Not modified. */
+
+/* WORK DOUBLE PRECISION array, dimension (2*N**2) */
+/* Workspace. */
+/* Modified. */
+
+/* RESULT DOUBLE PRECISION array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+/* RESULT(1) is always modified. RESULT(2) is modified only */
+/* if LDU is at least N. */
+/* Modified. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --tau;
+ --work;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.;
+ result[2] = 0.;
+ if (*n <= 0 || *m <= 0) {
+ return 0;
+ }
+
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Precision");
+
+/* Do Test 1 */
+
+/* Norm of A: */
+
+/* Computing MAX */
+ d__1 = dlansy_("1", uplo, n, &a[a_offset], lda, &work[1]);
+ anorm = max(d__1,unfl);
+
+/* Compute error matrix: */
+
+/* ITYPE=1: error = U' A U - S */
+
+ dsymm_("L", uplo, n, m, &c_b6, &a[a_offset], lda, &u[u_offset], ldu, &
+ c_b7, &work[1], n);
+ nn = *n * *n;
+ nnp1 = nn + 1;
+ dgemm_("T", "N", m, m, n, &c_b6, &u[u_offset], ldu, &work[1], n, &c_b7, &
+ work[nnp1], n);
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ jj = nn + (j - 1) * *n + j;
+ work[jj] -= d__[j];
+/* L10: */
+ }
+ if (*kband == 1 && *n > 1) {
+ i__1 = *m;
+ for (j = 2; j <= i__1; ++j) {
+ jj1 = nn + (j - 1) * *n + j - 1;
+ jj2 = nn + (j - 2) * *n + j;
+ work[jj1] -= e[j - 1];
+ work[jj2] -= e[j - 1];
+/* L20: */
+ }
+ }
+ wnorm = dlansy_("1", uplo, m, &work[nnp1], n, &work[1]);
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*m * ulp);
+ } else {
+ if (anorm < 1.) {
+/* Computing MIN */
+ d__1 = wnorm, d__2 = *m * anorm;
+ result[1] = min(d__1,d__2) / anorm / (*m * ulp);
+ } else {
+/* Computing MIN */
+ d__1 = wnorm / anorm, d__2 = (doublereal) (*m);
+ result[1] = min(d__1,d__2) / (*m * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute U'U - I */
+
+ if (*itype == 1) {
+ i__1 = (*n << 1) * *n;
+ dort01_("Columns", n, m, &u[u_offset], ldu, &work[1], &i__1, &result[
+ 2]);
+ }
+
+ return 0;
+
+/* End of DSYT22 */
+
+} /* dsyt22_ */
diff --git a/TESTING/EIG/ilaenv.c b/TESTING/EIG/ilaenv.c
new file mode 100644
index 0000000..9a1b36d
--- /dev/null
+++ b/TESTING/EIG/ilaenv.c
@@ -0,0 +1,321 @@
+/* ilaenv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer iparms[100];
+} claenv_;
+
+#define claenv_1 claenv_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b3 = 0.f;
+static real c_b4 = 1.f;
+static integer c__0 = 0;
+
+integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1,
+ integer *n2, integer *n3, integer *n4)
+{
+ /* System generated locals */
+ integer ret_val;
+
+ /* Local variables */
+ extern integer ieeeck_(integer *, real *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ILAENV returns problem-dependent parameters for the local */
+/* environment. See ISPEC for a description of the parameters. */
+
+/* In this version, the problem-dependent parameters are contained in */
+/* the integer array IPARMS in the common block CLAENV and the value */
+/* with index ISPEC is copied to ILAENV. This version of ILAENV is */
+/* to be used in conjunction with XLAENV in TESTING and TIMING. */
+
+/* Arguments */
+/* ========= */
+
+/* ISPEC (input) INTEGER */
+/* Specifies the parameter to be returned as the value of */
+/* ILAENV. */
+/* = 1: the optimal blocksize; if this value is 1, an unblocked */
+/* algorithm will give the best performance. */
+/* = 2: the minimum block size for which the block routine */
+/* should be used; if the usable block size is less than */
+/* this value, an unblocked routine should be used. */
+/* = 3: the crossover point (in a block routine, for N less */
+/* than this value, an unblocked routine should be used) */
+/* = 4: the number of shifts, used in the nonsymmetric */
+/* eigenvalue routines */
+/* = 5: the minimum column dimension for blocking to be used; */
+/* rectangular blocks must have dimension at least k by m, */
+/* where k is given by ILAENV(2,...) and m by ILAENV(5,...) */
+/* = 6: the crossover point for the SVD (when reducing an m by n */
+/* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds */
+/* this value, a QR factorization is used first to reduce */
+/* the matrix to a triangular form.) */
+/* = 7: the number of processors */
+/* = 8: the crossover point for the multishift QR and QZ methods */
+/* for nonsymmetric eigenvalue problems. */
+/* = 9: maximum size of the subproblems at the bottom of the */
+/* computation tree in the divide-and-conquer algorithm */
+/* =10: ieee NaN arithmetic can be trusted not to trap */
+/* =11: infinity arithmetic can be trusted not to trap */
+/* 12 <= ISPEC <= 16: */
+/* xHSEQR or one of its subroutines, */
+/* see IPARMQ for detailed explanation */
+
+/* Other specifications (up to 100) can be added later. */
+
+/* NAME (input) CHARACTER*(*) */
+/* The name of the calling subroutine. */
+
+/* OPTS (input) CHARACTER*(*) */
+/* The character options to the subroutine NAME, concatenated */
+/* into a single character string. For example, UPLO = 'U', */
+/* TRANS = 'T', and DIAG = 'N' for a triangular routine would */
+/* be specified as OPTS = 'UTN'. */
+
+/* N1 (input) INTEGER */
+/* N2 (input) INTEGER */
+/* N3 (input) INTEGER */
+/* N4 (input) INTEGER */
+/* Problem dimensions for the subroutine NAME; these may not all */
+/* be required. */
+
+/* (ILAENV) (output) INTEGER */
+/* >= 0: the value of the parameter specified by ISPEC */
+/* < 0: if ILAENV = -k, the k-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The following conventions have been used when calling ILAENV from the */
+/* LAPACK routines: */
+/* 1) OPTS is a concatenation of all of the character options to */
+/* subroutine NAME, in the same order that they appear in the */
+/* argument list for NAME, even if they are not used in determining */
+/* the value of the parameter specified by ISPEC. */
+/* 2) The problem dimensions N1, N2, N3, N4 are specified in the order */
+/* that they appear in the argument list for NAME. N1 is used */
+/* first, N2 second, and so on, and unused problem dimensions are */
+/* passed a value of -1. */
+/* 3) The parameter value returned by ILAENV is checked for validity in */
+/* the calling subroutine. For example, ILAENV is used to retrieve */
+/* the optimal blocksize for STRTRI as follows: */
+
+/* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) */
+/* IF( NB.LE.1 ) NB = MAX( 1, N ) */
+
+/* ===================================================================== */
+
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (*ispec >= 1 && *ispec <= 5) {
+
+/* Return a value from the common block. */
+
+ ret_val = claenv_1.iparms[*ispec - 1];
+
+ } else if (*ispec == 6) {
+
+/* Compute SVD crossover point. */
+
+ ret_val = (integer) ((real) min(*n1,*n2) * 1.6f);
+
+ } else if (*ispec >= 7 && *ispec <= 9) {
+
+/* Return a value from the common block. */
+
+ ret_val = claenv_1.iparms[*ispec - 1];
+
+ } else if (*ispec == 10) {
+
+/* IEEE NaN arithmetic can be trusted not to trap */
+
+/* ILAENV = 0 */
+ ret_val = 1;
+ if (ret_val == 1) {
+ ret_val = ieeeck_(&c__1, &c_b3, &c_b4);
+ }
+
+ } else if (*ispec == 11) {
+
+/* Infinity arithmetic can be trusted not to trap */
+
+/* ILAENV = 0 */
+ ret_val = 1;
+ if (ret_val == 1) {
+ ret_val = ieeeck_(&c__0, &c_b3, &c_b4);
+ }
+
+ } else if (*ispec >= 12 && *ispec <= 16) {
+
+/* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines. */
+
+ ret_val = claenv_1.iparms[*ispec - 1];
+/* WRITE(*,*) 'ISPEC = ',ISPEC,' ILAENV =',ILAENV */
+/* ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) */
+
+ } else {
+
+/* Invalid value for ISPEC */
+
+ ret_val = -1;
+ }
+
+ return ret_val;
+
+/* End of ILAENV */
+
+} /* ilaenv_ */
+
+integer iparmq_(integer *ispec, char *name__, char *opts, integer *n, integer
+ *ilo, integer *ihi, integer *lwork)
+{
+ /* System generated locals */
+ integer ret_val, i__1, i__2;
+ real r__1;
+
+ /* Builtin functions */
+ double log(doublereal);
+ integer i_nint(real *);
+
+ /* Local variables */
+ integer nh, ns;
+
+
+/* .. */
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ if (*ispec == 15 || *ispec == 13 || *ispec == 16) {
+
+/* ==== Set the number simultaneous shifts ==== */
+
+ nh = *ihi - *ilo + 1;
+ ns = 2;
+ if (nh >= 30) {
+ ns = 4;
+ }
+ if (nh >= 60) {
+ ns = 10;
+ }
+ if (nh >= 150) {
+/* Computing MAX */
+ r__1 = log((real) nh) / log(2.f);
+ i__1 = 10, i__2 = nh / i_nint(&r__1);
+ ns = max(i__1,i__2);
+ }
+ if (nh >= 590) {
+ ns = 64;
+ }
+ if (nh >= 3000) {
+ ns = 128;
+ }
+ if (nh >= 6000) {
+ ns = 256;
+ }
+/* Computing MAX */
+ i__1 = 2, i__2 = ns - ns % 2;
+ ns = max(i__1,i__2);
+ }
+
+ if (*ispec == 12) {
+
+
+/* ===== Matrices of order smaller than NMIN get sent */
+/* . to LAHQR, the classic double shift algorithm. */
+/* . This must be at least 11. ==== */
+
+ ret_val = 11;
+
+ } else if (*ispec == 14) {
+
+/* ==== INIBL: skip a multi-shift qr iteration and */
+/* . whenever aggressive early deflation finds */
+/* . at least (NIBBLE*(window size)/100) deflations. ==== */
+
+ ret_val = 14;
+
+ } else if (*ispec == 15) {
+
+/* ==== NSHFTS: The number of simultaneous shifts ===== */
+
+ ret_val = ns;
+
+ } else if (*ispec == 13) {
+
+/* ==== NW: deflation window size. ==== */
+
+ if (nh <= 500) {
+ ret_val = ns;
+ } else {
+ ret_val = ns * 3 / 2;
+ }
+
+ } else if (*ispec == 16) {
+
+/* ==== IACC22: Whether to accumulate reflections */
+/* . before updating the far-from-diagonal elements */
+/* . and whether to use 2-by-2 block structure while */
+/* . doing it. A small amount of work could be saved */
+/* . by making this choice dependent also upon the */
+/* . NH=IHI-ILO+1. */
+
+ ret_val = 0;
+ if (ns >= 14) {
+ ret_val = 1;
+ }
+ if (ns >= 14) {
+ ret_val = 2;
+ }
+
+ } else {
+/* ===== invalid value of ispec ===== */
+ ret_val = -1;
+
+ }
+
+/* ==== End of IPARMQ ==== */
+
+ return ret_val;
+} /* iparmq_ */
diff --git a/TESTING/EIG/sbdt01.c b/TESTING/EIG/sbdt01.c
new file mode 100644
index 0000000..3fcfdf8
--- /dev/null
+++ b/TESTING/EIG/sbdt01.c
@@ -0,0 +1,288 @@
+/* sbdt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b7 = -1.f;
+static real c_b9 = 1.f;
+
+/* Subroutine */ int sbdt01_(integer *m, integer *n, integer *kd, real *a,
+ integer *lda, real *q, integer *ldq, real *d__, real *e, real *pt,
+ integer *ldpt, real *work, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, pt_dim1, pt_offset, q_dim1, q_offset, i__1,
+ i__2;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer i__, j;
+ real eps, anorm;
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ extern doublereal sasum_(integer *, real *, integer *);
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SBDT01 reconstructs a general matrix A from its bidiagonal form */
+/* A = Q * B * P' */
+/* where Q (m by min(m,n)) and P' (min(m,n) by n) are orthogonal */
+/* matrices and B is bidiagonal. */
+
+/* The test ratio to test the reduction is */
+/* RESID = norm( A - Q * B * PT ) / ( n * norm(A) * EPS ) */
+/* where PT = P' and EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices A and Q. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and P'. */
+
+/* KD (input) INTEGER */
+/* If KD = 0, B is diagonal and the array E is not referenced. */
+/* If KD = 1, the reduction was performed by xGEBRD; B is upper */
+/* bidiagonal if M >= N, and lower bidiagonal if M < N. */
+/* If KD = -1, the reduction was performed by xGBBRD; B is */
+/* always upper bidiagonal. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* Q (input) REAL array, dimension (LDQ,N) */
+/* The m by min(m,n) orthogonal matrix Q in the reduction */
+/* A = Q * B * P'. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,M). */
+
+/* D (input) REAL array, dimension (min(M,N)) */
+/* The diagonal elements of the bidiagonal matrix B. */
+
+/* E (input) REAL array, dimension (min(M,N)-1) */
+/* The superdiagonal elements of the bidiagonal matrix B if */
+/* m >= n, or the subdiagonal elements of B if m < n. */
+
+/* PT (input) REAL array, dimension (LDPT,N) */
+/* The min(m,n) by n orthogonal matrix P' in the reduction */
+/* A = Q * B * P'. */
+
+/* LDPT (input) INTEGER */
+/* The leading dimension of the array PT. */
+/* LDPT >= max(1,min(M,N)). */
+
+/* WORK (workspace) REAL array, dimension (M+N) */
+
+/* RESID (output) REAL */
+/* The test ratio: norm(A - Q * B * P') / ( n * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --d__;
+ --e;
+ pt_dim1 = *ldpt;
+ pt_offset = 1 + pt_dim1;
+ pt -= pt_offset;
+ --work;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Compute A - Q * B * P' one column at a time. */
+
+ *resid = 0.f;
+ if (*kd != 0) {
+
+/* B is bidiagonal. */
+
+ if (*kd != 0 && *m >= *n) {
+
+/* B is upper bidiagonal and M >= N. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__2 = *n - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*m + i__] = d__[i__] * pt[i__ + j * pt_dim1] + e[i__]
+ * pt[i__ + 1 + j * pt_dim1];
+/* L10: */
+ }
+ work[*m + *n] = d__[*n] * pt[*n + j * pt_dim1];
+ sgemv_("No transpose", m, n, &c_b7, &q[q_offset], ldq, &work[*
+ m + 1], &c__1, &c_b9, &work[1], &c__1);
+/* Computing MAX */
+ r__1 = *resid, r__2 = sasum_(m, &work[1], &c__1);
+ *resid = dmax(r__1,r__2);
+/* L20: */
+ }
+ } else if (*kd < 0) {
+
+/* B is upper bidiagonal and M < N. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__2 = *m - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*m + i__] = d__[i__] * pt[i__ + j * pt_dim1] + e[i__]
+ * pt[i__ + 1 + j * pt_dim1];
+/* L30: */
+ }
+ work[*m + *m] = d__[*m] * pt[*m + j * pt_dim1];
+ sgemv_("No transpose", m, m, &c_b7, &q[q_offset], ldq, &work[*
+ m + 1], &c__1, &c_b9, &work[1], &c__1);
+/* Computing MAX */
+ r__1 = *resid, r__2 = sasum_(m, &work[1], &c__1);
+ *resid = dmax(r__1,r__2);
+/* L40: */
+ }
+ } else {
+
+/* B is lower bidiagonal. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ work[*m + 1] = d__[1] * pt[j * pt_dim1 + 1];
+ i__2 = *m;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ work[*m + i__] = e[i__ - 1] * pt[i__ - 1 + j * pt_dim1] +
+ d__[i__] * pt[i__ + j * pt_dim1];
+/* L50: */
+ }
+ sgemv_("No transpose", m, m, &c_b7, &q[q_offset], ldq, &work[*
+ m + 1], &c__1, &c_b9, &work[1], &c__1);
+/* Computing MAX */
+ r__1 = *resid, r__2 = sasum_(m, &work[1], &c__1);
+ *resid = dmax(r__1,r__2);
+/* L60: */
+ }
+ }
+ } else {
+
+/* B is diagonal. */
+
+ if (*m >= *n) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*m + i__] = d__[i__] * pt[i__ + j * pt_dim1];
+/* L70: */
+ }
+ sgemv_("No transpose", m, n, &c_b7, &q[q_offset], ldq, &work[*
+ m + 1], &c__1, &c_b9, &work[1], &c__1);
+/* Computing MAX */
+ r__1 = *resid, r__2 = sasum_(m, &work[1], &c__1);
+ *resid = dmax(r__1,r__2);
+/* L80: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*m + i__] = d__[i__] * pt[i__ + j * pt_dim1];
+/* L90: */
+ }
+ sgemv_("No transpose", m, m, &c_b7, &q[q_offset], ldq, &work[*
+ m + 1], &c__1, &c_b9, &work[1], &c__1);
+/* Computing MAX */
+ r__1 = *resid, r__2 = sasum_(m, &work[1], &c__1);
+ *resid = dmax(r__1,r__2);
+/* L100: */
+ }
+ }
+ }
+
+/* Compute norm(A - Q * B * P') / ( n * norm(A) * EPS ) */
+
+ anorm = slange_("1", m, n, &a[a_offset], lda, &work[1]);
+ eps = slamch_("Precision");
+
+ if (anorm <= 0.f) {
+ if (*resid != 0.f) {
+ *resid = 1.f / eps;
+ }
+ } else {
+ if (anorm >= *resid) {
+ *resid = *resid / anorm / ((real) (*n) * eps);
+ } else {
+ if (anorm < 1.f) {
+/* Computing MIN */
+ r__1 = *resid, r__2 = (real) (*n) * anorm;
+ *resid = dmin(r__1,r__2) / anorm / ((real) (*n) * eps);
+ } else {
+/* Computing MIN */
+ r__1 = *resid / anorm, r__2 = (real) (*n);
+ *resid = dmin(r__1,r__2) / ((real) (*n) * eps);
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SBDT01 */
+
+} /* sbdt01_ */
diff --git a/TESTING/EIG/sbdt02.c b/TESTING/EIG/sbdt02.c
new file mode 100644
index 0000000..927c0d9
--- /dev/null
+++ b/TESTING/EIG/sbdt02.c
@@ -0,0 +1,171 @@
+/* sbdt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b7 = -1.f;
+static real c_b9 = 1.f;
+
+/* Subroutine */ int sbdt02_(integer *m, integer *n, real *b, integer *ldb,
+ real *c__, integer *ldc, real *u, integer *ldu, real *work, real *
+ resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, c_dim1, c_offset, u_dim1, u_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j;
+ real eps, bnorm;
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ extern doublereal sasum_(integer *, real *, integer *);
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ real realmn;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SBDT02 tests the change of basis C = U' * B by computing the residual */
+
+/* RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ), */
+
+/* where B and C are M by N matrices, U is an M by M orthogonal matrix, */
+/* and EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices B and C and the order of */
+/* the matrix Q. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices B and C. */
+
+/* B (input) REAL array, dimension (LDB,N) */
+/* The m by n matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M). */
+
+/* C (input) REAL array, dimension (LDC,N) */
+/* The m by n matrix C, assumed to contain U' * B. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* U (input) REAL array, dimension (LDU,M) */
+/* The m by m orthogonal matrix U. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M). */
+
+/* WORK (workspace) REAL array, dimension (M) */
+
+/* RESID (output) REAL */
+/* RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ), */
+
+/* ====================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --work;
+
+ /* Function Body */
+ *resid = 0.f;
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+ realmn = (real) max(*m,*n);
+ eps = slamch_("Precision");
+
+/* Compute norm( B - U * C ) */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(m, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ sgemv_("No transpose", m, m, &c_b7, &u[u_offset], ldu, &c__[j *
+ c_dim1 + 1], &c__1, &c_b9, &work[1], &c__1);
+/* Computing MAX */
+ r__1 = *resid, r__2 = sasum_(m, &work[1], &c__1);
+ *resid = dmax(r__1,r__2);
+/* L10: */
+ }
+
+/* Compute norm of B. */
+
+ bnorm = slange_("1", m, n, &b[b_offset], ldb, &work[1]);
+
+ if (bnorm <= 0.f) {
+ if (*resid != 0.f) {
+ *resid = 1.f / eps;
+ }
+ } else {
+ if (bnorm >= *resid) {
+ *resid = *resid / bnorm / (realmn * eps);
+ } else {
+ if (bnorm < 1.f) {
+/* Computing MIN */
+ r__1 = *resid, r__2 = realmn * bnorm;
+ *resid = dmin(r__1,r__2) / bnorm / (realmn * eps);
+ } else {
+/* Computing MIN */
+ r__1 = *resid / bnorm;
+ *resid = dmin(r__1,realmn) / (realmn * eps);
+ }
+ }
+ }
+ return 0;
+
+/* End of SBDT02 */
+
+} /* sbdt02_ */
diff --git a/TESTING/EIG/sbdt03.c b/TESTING/EIG/sbdt03.c
new file mode 100644
index 0000000..aa76464
--- /dev/null
+++ b/TESTING/EIG/sbdt03.c
@@ -0,0 +1,261 @@
+/* sbdt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b6 = -1.f;
+static integer c__1 = 1;
+static real c_b8 = 0.f;
+
+/* Subroutine */ int sbdt03_(char *uplo, integer *n, integer *kd, real *d__,
+ real *e, real *u, integer *ldu, real *s, real *vt, integer *ldvt,
+ real *work, real *resid)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2;
+ real r__1, r__2, r__3, r__4;
+
+ /* Local variables */
+ integer i__, j;
+ real eps;
+ extern logical lsame_(char *, char *);
+ real bnorm;
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ extern doublereal sasum_(integer *, real *, integer *), slamch_(char *);
+ extern integer isamax_(integer *, real *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SBDT03 reconstructs a bidiagonal matrix B from its SVD: */
+/* S = U' * B * V */
+/* where U and V are orthogonal matrices and S is diagonal. */
+
+/* The test ratio to test the singular value decomposition is */
+/* RESID = norm( B - U * S * VT ) / ( n * norm(B) * EPS ) */
+/* where VT = V' and EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix B is upper or lower bidiagonal. */
+/* = 'U': Upper bidiagonal */
+/* = 'L': Lower bidiagonal */
+
+/* N (input) INTEGER */
+/* The order of the matrix B. */
+
+/* KD (input) INTEGER */
+/* The bandwidth of the bidiagonal matrix B. If KD = 1, the */
+/* matrix B is bidiagonal, and if KD = 0, B is diagonal and E is */
+/* not referenced. If KD is greater than 1, it is assumed to be */
+/* 1, and if KD is less than 0, it is assumed to be 0. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the bidiagonal matrix B. */
+
+/* E (input) REAL array, dimension (N-1) */
+/* The (n-1) superdiagonal elements of the bidiagonal matrix B */
+/* if UPLO = 'U', or the (n-1) subdiagonal elements of B if */
+/* UPLO = 'L'. */
+
+/* U (input) REAL array, dimension (LDU,N) */
+/* The n by n orthogonal matrix U in the reduction B = U'*A*P. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,N) */
+
+/* S (input) REAL array, dimension (N) */
+/* The singular values from the SVD of B, sorted in decreasing */
+/* order. */
+
+/* VT (input) REAL array, dimension (LDVT,N) */
+/* The n by n orthogonal matrix V' in the reduction */
+/* B = U * S * V'. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. */
+
+/* WORK (workspace) REAL array, dimension (2*N) */
+
+/* RESID (output) REAL */
+/* The test ratio: norm(B - U * S * V') / ( n * norm(A) * EPS ) */
+
+/* ====================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --s;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --work;
+
+ /* Function Body */
+ *resid = 0.f;
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Compute B - U * S * V' one column at a time. */
+
+ bnorm = 0.f;
+ if (*kd >= 1) {
+
+/* B is bidiagonal. */
+
+ if (lsame_(uplo, "U")) {
+
+/* B is upper bidiagonal. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = s[i__] * vt[i__ + j * vt_dim1];
+/* L10: */
+ }
+ sgemv_("No transpose", n, n, &c_b6, &u[u_offset], ldu, &work[*
+ n + 1], &c__1, &c_b8, &work[1], &c__1);
+ work[j] += d__[j];
+ if (j > 1) {
+ work[j - 1] += e[j - 1];
+/* Computing MAX */
+ r__3 = bnorm, r__4 = (r__1 = d__[j], dabs(r__1)) + (r__2 =
+ e[j - 1], dabs(r__2));
+ bnorm = dmax(r__3,r__4);
+ } else {
+/* Computing MAX */
+ r__2 = bnorm, r__3 = (r__1 = d__[j], dabs(r__1));
+ bnorm = dmax(r__2,r__3);
+ }
+/* Computing MAX */
+ r__1 = *resid, r__2 = sasum_(n, &work[1], &c__1);
+ *resid = dmax(r__1,r__2);
+/* L20: */
+ }
+ } else {
+
+/* B is lower bidiagonal. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = s[i__] * vt[i__ + j * vt_dim1];
+/* L30: */
+ }
+ sgemv_("No transpose", n, n, &c_b6, &u[u_offset], ldu, &work[*
+ n + 1], &c__1, &c_b8, &work[1], &c__1);
+ work[j] += d__[j];
+ if (j < *n) {
+ work[j + 1] += e[j];
+/* Computing MAX */
+ r__3 = bnorm, r__4 = (r__1 = d__[j], dabs(r__1)) + (r__2 =
+ e[j], dabs(r__2));
+ bnorm = dmax(r__3,r__4);
+ } else {
+/* Computing MAX */
+ r__2 = bnorm, r__3 = (r__1 = d__[j], dabs(r__1));
+ bnorm = dmax(r__2,r__3);
+ }
+/* Computing MAX */
+ r__1 = *resid, r__2 = sasum_(n, &work[1], &c__1);
+ *resid = dmax(r__1,r__2);
+/* L40: */
+ }
+ }
+ } else {
+
+/* B is diagonal. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[*n + i__] = s[i__] * vt[i__ + j * vt_dim1];
+/* L50: */
+ }
+ sgemv_("No transpose", n, n, &c_b6, &u[u_offset], ldu, &work[*n +
+ 1], &c__1, &c_b8, &work[1], &c__1);
+ work[j] += d__[j];
+/* Computing MAX */
+ r__1 = *resid, r__2 = sasum_(n, &work[1], &c__1);
+ *resid = dmax(r__1,r__2);
+/* L60: */
+ }
+ j = isamax_(n, &d__[1], &c__1);
+ bnorm = (r__1 = d__[j], dabs(r__1));
+ }
+
+/* Compute norm(B - U * S * V') / ( n * norm(B) * EPS ) */
+
+ eps = slamch_("Precision");
+
+ if (bnorm <= 0.f) {
+ if (*resid != 0.f) {
+ *resid = 1.f / eps;
+ }
+ } else {
+ if (bnorm >= *resid) {
+ *resid = *resid / bnorm / ((real) (*n) * eps);
+ } else {
+ if (bnorm < 1.f) {
+/* Computing MIN */
+ r__1 = *resid, r__2 = (real) (*n) * bnorm;
+ *resid = dmin(r__1,r__2) / bnorm / ((real) (*n) * eps);
+ } else {
+/* Computing MIN */
+ r__1 = *resid / bnorm, r__2 = (real) (*n);
+ *resid = dmin(r__1,r__2) / ((real) (*n) * eps);
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SBDT03 */
+
+} /* sbdt03_ */
diff --git a/TESTING/EIG/schkbb.c b/TESTING/EIG/schkbb.c
new file mode 100644
index 0000000..9c76412
--- /dev/null
+++ b/TESTING/EIG/schkbb.c
@@ -0,0 +1,767 @@
+/* schkbb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b18 = 0.f;
+static integer c__0 = 0;
+static integer c__6 = 6;
+static real c_b35 = 1.f;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c_n1 = -1;
+
+/* Subroutine */ int schkbb_(integer *nsizes, integer *mval, integer *nval,
+ integer *nwdths, integer *kk, integer *ntypes, logical *dotype,
+ integer *nrhs, integer *iseed, real *thresh, integer *nounit, real *a,
+ integer *lda, real *ab, integer *ldab, real *bd, real *be, real *q,
+ integer *ldq, real *p, integer *ldp, real *c__, integer *ldc, real *
+ cc, real *work, integer *lwork, real *result, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[15] = { 1,2,4,4,4,4,4,6,6,6,6,6,9,9,9 };
+ static integer kmagn[15] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3 };
+ static integer kmode[15] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 SCHKBB: \002,a,\002 returned INFO=\002,i"
+ "5,\002.\002,/9x,\002M=\002,i5,\002 N=\002,i5,\002 K=\002,i5,\002"
+ ", JTYPE=\002,i5,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 M =\002,i4,\002 N=\002,i4,\002, K=\002,i"
+ "3,\002, seed=\002,4(i4,\002,\002),\002 type \002,i2,\002, test"
+ "(\002,i2,\002)=\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, ab_dim1, ab_offset, c_dim1, c_offset, cc_dim1,
+ cc_offset, p_dim1, p_offset, q_dim1, q_offset, i__1, i__2, i__3,
+ i__4, i__5, i__6, i__7, i__8, i__9;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, m, n, kl, jr, ku;
+ real ulp, cond;
+ integer jcol, kmax, mmax, nmax;
+ real unfl, ovfl;
+ logical badmm, badnn;
+ integer imode;
+ extern /* Subroutine */ int sbdt01_(integer *, integer *, integer *, real
+ *, integer *, real *, integer *, real *, real *, real *, integer *
+, real *, real *), sbdt02_(integer *, integer *, real *, integer *
+, real *, integer *, real *, integer *, real *, real *);
+ integer iinfo;
+ real anorm;
+ integer mnmin, mnmax, nmats, jsize;
+ extern /* Subroutine */ int sort01_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, real *);
+ integer nerrs, itype, jtype, ntest;
+ extern /* Subroutine */ int slahd2_(integer *, char *);
+ logical badnnb;
+ extern /* Subroutine */ int sgbbrd_(char *, integer *, integer *, integer
+ *, integer *, integer *, real *, integer *, real *, real *, real *
+, integer *, real *, integer *, real *, integer *, real *,
+ integer *);
+ extern doublereal slamch_(char *);
+ integer idumma[1];
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer ioldsd[4];
+ real amninv;
+ integer jwidth;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *), slatmr_(
+ integer *, integer *, char *, integer *, char *, real *, integer *
+, real *, real *, char *, char *, real *, integer *, real *, real
+ *, integer *, real *, char *, integer *, integer *, integer *,
+ real *, real *, char *, real *, integer *, integer *, integer *), slatms_(integer *
+, integer *, char *, integer *, char *, real *, integer *, real *,
+ real *, integer *, integer *, char *, real *, integer *, real *,
+ integer *), slasum_(char *, integer *,
+ integer *, integer *);
+ real rtunfl, rtovfl, ulpinv;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (release 2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKBB tests the reduction of a general real rectangular band */
+/* matrix to bidiagonal form. */
+
+/* SGBBRD factors a general band matrix A as Q B P* , where * means */
+/* transpose, B is upper bidiagonal, and Q and P are orthogonal; */
+/* SGBBRD can also overwrite a given matrix C with Q* C . */
+
+/* For each pair of matrix dimensions (M,N) and each selected matrix */
+/* type, an M by N matrix A and an M by NRHS matrix C are generated. */
+/* The problem dimensions are as follows */
+/* A: M x N */
+/* Q: M x M */
+/* P: N x N */
+/* B: min(M,N) x min(M,N) */
+/* C: M x NRHS */
+
+/* For each generated matrix, 4 tests are performed: */
+
+/* (1) | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P' */
+
+/* (2) | I - Q' Q | / ( M ulp ) */
+
+/* (3) | I - PT PT' | / ( N ulp ) */
+
+/* (4) | Y - Q' C | / ( |Y| max(M,NRHS) ulp ), where Y = Q' C. */
+
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* The possible matrix types are */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (6) Same as (3), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (3), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) Rectangular matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of values of M and N contained in the vectors */
+/* MVAL and NVAL. The matrix sizes are used in pairs (M,N). */
+/* If NSIZES is zero, SCHKBB does nothing. NSIZES must be at */
+/* least zero. */
+
+/* MVAL (input) INTEGER array, dimension (NSIZES) */
+/* The values of the matrix row dimension M. */
+
+/* NVAL (input) INTEGER array, dimension (NSIZES) */
+/* The values of the matrix column dimension N. */
+
+/* NWDTHS (input) INTEGER */
+/* The number of bandwidths to use. If it is zero, */
+/* SCHKBB does nothing. It must be at least zero. */
+
+/* KK (input) INTEGER array, dimension (NWDTHS) */
+/* An array containing the bandwidths to be used for the band */
+/* matrices. The values must be at least zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, SCHKBB */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns in the "right-hand side" matrix C. */
+/* If NRHS = 0, then the operations on the right-hand side will */
+/* not be tested. NRHS must be at least 0. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to SCHKBB to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace) REAL array, dimension */
+/* (LDA, max(NN)) */
+/* Used to hold the matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* AB (workspace) REAL array, dimension (LDAB, max(NN)) */
+/* Used to hold A in band storage format. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of AB. It must be at least 2 (not 1!) */
+/* and at least max( KK )+1. */
+
+/* BD (workspace) REAL array, dimension (max(NN)) */
+/* Used to hold the diagonal of the bidiagonal matrix computed */
+/* by SGBBRD. */
+
+/* BE (workspace) REAL array, dimension (max(NN)) */
+/* Used to hold the off-diagonal of the bidiagonal matrix */
+/* computed by SGBBRD. */
+
+/* Q (workspace) REAL array, dimension (LDQ, max(NN)) */
+/* Used to hold the orthogonal matrix Q computed by SGBBRD. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of Q. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* P (workspace) REAL array, dimension (LDP, max(NN)) */
+/* Used to hold the orthogonal matrix P computed by SGBBRD. */
+
+/* LDP (input) INTEGER */
+/* The leading dimension of P. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* C (workspace) REAL array, dimension (LDC, max(NN)) */
+/* Used to hold the matrix C updated by SGBBRD. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of U. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* CC (workspace) REAL array, dimension (LDC, max(NN)) */
+/* Used to hold a copy of the matrix C. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* max( LDA+1, max(NN)+1 )*max(NN). */
+
+/* RESULT (output) REAL array, dimension (4) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests performed, or which can */
+/* be performed so far, for the current matrix. */
+/* NTESTT The total number of tests performed so far. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far. */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --mval;
+ --nval;
+ --kk;
+ --dotype;
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --bd;
+ --be;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ p_dim1 = *ldp;
+ p_offset = 1 + p_dim1;
+ p -= p_offset;
+ cc_dim1 = *ldc;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badmm = FALSE_;
+ badnn = FALSE_;
+ mmax = 1;
+ nmax = 1;
+ mnmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = mmax, i__3 = mval[j];
+ mmax = max(i__2,i__3);
+ if (mval[j] < 0) {
+ badmm = TRUE_;
+ }
+/* Computing MAX */
+ i__2 = nmax, i__3 = nval[j];
+ nmax = max(i__2,i__3);
+ if (nval[j] < 0) {
+ badnn = TRUE_;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__4 = mval[j], i__5 = nval[j];
+ i__2 = mnmax, i__3 = min(i__4,i__5);
+ mnmax = max(i__2,i__3);
+/* L10: */
+ }
+
+ badnnb = FALSE_;
+ kmax = 0;
+ i__1 = *nwdths;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = kmax, i__3 = kk[j];
+ kmax = max(i__2,i__3);
+ if (kk[j] < 0) {
+ badnnb = TRUE_;
+ }
+/* L20: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badmm) {
+ *info = -2;
+ } else if (badnn) {
+ *info = -3;
+ } else if (*nwdths < 0) {
+ *info = -4;
+ } else if (badnnb) {
+ *info = -5;
+ } else if (*ntypes < 0) {
+ *info = -6;
+ } else if (*nrhs < 0) {
+ *info = -8;
+ } else if (*lda < nmax) {
+ *info = -13;
+ } else if (*ldab < (kmax << 1) + 1) {
+ *info = -15;
+ } else if (*ldq < nmax) {
+ *info = -19;
+ } else if (*ldp < nmax) {
+ *info = -21;
+ } else if (*ldc < nmax) {
+ *info = -23;
+ } else if ((max(*lda,nmax) + 1) * nmax > *lwork) {
+ *info = -26;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SCHKBB", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0 || *nwdths == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ ulpinv = 1.f / ulp;
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+
+/* Loop over sizes, widths, types */
+
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ m = mval[jsize];
+ n = nval[jsize];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__2 = max(1,m);
+ amninv = 1.f / (real) max(i__2,n);
+
+ i__2 = *nwdths;
+ for (jwidth = 1; jwidth <= i__2; ++jwidth) {
+ k = kk[jwidth];
+ if (k >= m && k >= n) {
+ goto L150;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__5 = m - 1;
+ i__3 = 0, i__4 = min(i__5,k);
+ kl = max(i__3,i__4);
+/* Computing MAX */
+/* Computing MIN */
+ i__5 = n - 1;
+ i__3 = 0, i__4 = min(i__5,k);
+ ku = max(i__3,i__4);
+
+ if (*nsizes != 1) {
+ mtypes = min(15,*ntypes);
+ } else {
+ mtypes = min(16,*ntypes);
+ }
+
+ i__3 = mtypes;
+ for (jtype = 1; jtype <= i__3; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L140;
+ }
+ ++nmats;
+ ntest = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L30: */
+ }
+
+/* Compute "A". */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, (w/ singular values) */
+/* =5 random log (none) */
+/* =6 random nonhermitian, w/ singular values */
+/* =7 (none) */
+/* =8 (none) */
+/* =9 random nonhermitian */
+
+ if (mtypes > 15) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.f;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * amninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * max(m,n) * ulpinv;
+ goto L70;
+
+L70:
+
+ slaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
+ slaset_("Full", ldab, &n, &c_b18, &c_b18, &ab[ab_offset],
+ ldab);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__4 = n;
+ for (jcol = 1; jcol <= i__4; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, singular values specified */
+
+ slatms_(&m, &n, "S", &iseed[1], "N", &work[1], &imode, &
+ cond, &anorm, &c__0, &c__0, "N", &a[a_offset],
+ lda, &work[m + 1], &iinfo);
+
+ } else if (itype == 6) {
+
+/* Nonhermitian, singular values specified */
+
+ slatms_(&m, &n, "S", &iseed[1], "N", &work[1], &imode, &
+ cond, &anorm, &kl, &ku, "N", &a[a_offset], lda, &
+ work[m + 1], &iinfo);
+
+ } else if (itype == 9) {
+
+/* Nonhermitian, random entries */
+
+ slatmr_(&m, &n, "S", &iseed[1], "N", &work[1], &c__6, &
+ c_b35, &c_b35, "T", "N", &work[n + 1], &c__1, &
+ c_b35, &work[(n << 1) + 1], &c__1, &c_b35, "N",
+ idumma, &kl, &ku, &c_b18, &anorm, "N", &a[
+ a_offset], lda, idumma, &iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+/* Generate Right-Hand Side */
+
+ slatmr_(&m, nrhs, "S", &iseed[1], "N", &work[1], &c__6, &
+ c_b35, &c_b35, "T", "N", &work[m + 1], &c__1, &c_b35,
+ &work[(m << 1) + 1], &c__1, &c_b35, "N", idumma, &m,
+ nrhs, &c_b18, &c_b35, "NO", &c__[c_offset], ldc,
+ idumma, &iinfo);
+
+ if (iinfo != 0) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+/* Copy A to band storage. */
+
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__6 = j - ku;
+/* Computing MIN */
+ i__8 = m, i__9 = j + kl;
+ i__7 = min(i__8,i__9);
+ for (i__ = max(i__5,i__6); i__ <= i__7; ++i__) {
+ ab[ku + 1 + i__ - j + j * ab_dim1] = a[i__ + j *
+ a_dim1];
+/* L100: */
+ }
+/* L110: */
+ }
+
+/* Copy C */
+
+ slacpy_("Full", &m, nrhs, &c__[c_offset], ldc, &cc[cc_offset],
+ ldc);
+
+/* Call SGBBRD to compute B, Q and P, and to update C. */
+
+ sgbbrd_("B", &m, &n, nrhs, &kl, &ku, &ab[ab_offset], ldab, &
+ bd[1], &be[1], &q[q_offset], ldq, &p[p_offset], ldp, &
+ cc[cc_offset], ldc, &work[1], &iinfo);
+
+ if (iinfo != 0) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "SGBBRD", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[1] = ulpinv;
+ goto L120;
+ }
+ }
+
+/* Test 1: Check the decomposition A := Q * B * P' */
+/* 2: Check the orthogonality of Q */
+/* 3: Check the orthogonality of P */
+/* 4: Check the computation of Q' * C */
+
+ sbdt01_(&m, &n, &c_n1, &a[a_offset], lda, &q[q_offset], ldq, &
+ bd[1], &be[1], &p[p_offset], ldp, &work[1], &result[1]
+);
+ sort01_("Columns", &m, &m, &q[q_offset], ldq, &work[1], lwork,
+ &result[2]);
+ sort01_("Rows", &n, &n, &p[p_offset], ldp, &work[1], lwork, &
+ result[3]);
+ sbdt02_(&m, nrhs, &c__[c_offset], ldc, &cc[cc_offset], ldc, &
+ q[q_offset], ldq, &work[1], &result[4]);
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+ ntest = 4;
+L120:
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__4 = ntest;
+ for (jr = 1; jr <= i__4; ++jr) {
+ if (result[jr] >= *thresh) {
+ if (nerrs == 0) {
+ slahd2_(nounit, "SBB");
+ }
+ ++nerrs;
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ }
+/* L130: */
+ }
+
+L140:
+ ;
+ }
+L150:
+ ;
+ }
+/* L160: */
+ }
+
+/* Summary */
+
+ slasum_("SBB", nounit, &nerrs, &ntestt);
+ return 0;
+
+
+/* End of SCHKBB */
+
+} /* schkbb_ */
diff --git a/TESTING/EIG/schkbd.c b/TESTING/EIG/schkbd.c
new file mode 100644
index 0000000..97dc2ea
--- /dev/null
+++ b/TESTING/EIG/schkbd.c
@@ -0,0 +1,1263 @@
+/* schkbd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static real c_b20 = 0.f;
+static integer c__0 = 0;
+static integer c__6 = 6;
+static real c_b37 = 1.f;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__4 = 4;
+
+/* Subroutine */ int schkbd_(integer *nsizes, integer *mval, integer *nval,
+ integer *ntypes, logical *dotype, integer *nrhs, integer *iseed, real
+ *thresh, real *a, integer *lda, real *bd, real *be, real *s1, real *
+ s2, real *x, integer *ldx, real *y, real *z__, real *q, integer *ldq,
+ real *pt, integer *ldpt, real *u, real *vt, real *work, integer *
+ lwork, integer *iwork, integer *nout, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[16] = { 1,2,4,4,4,4,4,6,6,6,6,6,9,9,9,10 };
+ static integer kmagn[16] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3,0 };
+ static integer kmode[16] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9998[] = "(\002 SCHKBD: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002M=\002,i6,\002, N=\002,i6,\002, JTYPE=\002,i"
+ "6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, type "
+ "\002,i2,\002, seed=\002,4(i4,\002,\002),\002 test(\002,i2,\002)"
+ "=\002,g11.4)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, pt_dim1, pt_offset, q_dim1, q_offset, u_dim1,
+ u_offset, vt_dim1, vt_offset, x_dim1, x_offset, y_dim1, y_offset,
+ z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+ real r__1, r__2, r__3, r__4, r__5, r__6, r__7;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double log(doublereal), sqrt(doublereal), exp(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, m, n, mq;
+ real dum[1], ulp, cond;
+ integer jcol;
+ char path[3];
+ integer idum[1], mmax, nmax;
+ real unfl, ovfl;
+ char uplo[1];
+ real temp1, temp2;
+ logical badmm, badnn;
+ integer nfail, imode;
+ extern /* Subroutine */ int sbdt01_(integer *, integer *, integer *, real
+ *, integer *, real *, integer *, real *, real *, real *, integer *
+, real *, real *), sbdt02_(integer *, integer *, real *, integer *
+, real *, integer *, real *, integer *, real *, real *), sbdt03_(
+ char *, integer *, integer *, real *, real *, real *, integer *,
+ real *, real *, integer *, real *, real *);
+ real dumma[1];
+ integer iinfo;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm;
+ integer mnmin, mnmax, jsize;
+ extern /* Subroutine */ int sort01_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, real *);
+ integer itype, jtype, ntest;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), slahd2_(integer *, char *);
+ integer log2ui;
+ logical bidiag;
+ extern /* Subroutine */ int slabad_(real *, real *), sbdsdc_(char *, char
+ *, integer *, real *, real *, real *, integer *, real *, integer *
+, real *, integer *, real *, integer *, integer *)
+ , sgebrd_(integer *, integer *, real *, integer *, real *, real *,
+ real *, real *, real *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ extern doublereal slarnd_(integer *, integer *);
+ real amninv;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *), sbdsqr_(
+ char *, integer *, integer *, integer *, integer *, real *, real *
+, real *, integer *, real *, integer *, real *, integer *, real *,
+ integer *), sorgbr_(char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, integer *
+), slatmr_(integer *, integer *, char *, integer *, char *
+, real *, integer *, real *, real *, char *, char *, real *,
+ integer *, real *, real *, integer *, real *, char *, integer *,
+ integer *, integer *, real *, real *, char *, real *, integer *,
+ integer *, integer *), slatms_(integer *, integer *, char *, integer *, char *,
+ real *, integer *, real *, real *, integer *, integer *, char *,
+ real *, integer *, real *, integer *);
+ integer minwrk;
+ real rtunfl, rtovfl, ulpinv, result[19];
+ integer mtypes;
+
+ /* Fortran I/O blocks */
+ static cilist io___39 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKBD checks the singular value decomposition (SVD) routines. */
+
+/* SGEBRD reduces a real general m by n matrix A to upper or lower */
+/* bidiagonal form B by an orthogonal transformation: Q' * A * P = B */
+/* (or A = Q * B * P'). The matrix B is upper bidiagonal if m >= n */
+/* and lower bidiagonal if m < n. */
+
+/* SORGBR generates the orthogonal matrices Q and P' from SGEBRD. */
+/* Note that Q and P are not necessarily square. */
+
+/* SBDSQR computes the singular value decomposition of the bidiagonal */
+/* matrix B as B = U S V'. It is called three times to compute */
+/* 1) B = U S1 V', where S1 is the diagonal matrix of singular */
+/* values and the columns of the matrices U and V are the left */
+/* and right singular vectors, respectively, of B. */
+/* 2) Same as 1), but the singular values are stored in S2 and the */
+/* singular vectors are not computed. */
+/* 3) A = (UQ) S (P'V'), the SVD of the original matrix A. */
+/* In addition, SBDSQR has an option to apply the left orthogonal matrix */
+/* U to a matrix X, useful in least squares applications. */
+
+/* SBDSDC computes the singular value decomposition of the bidiagonal */
+/* matrix B as B = U S V' using divide-and-conquer. It is called twice */
+/* to compute */
+/* 1) B = U S1 V', where S1 is the diagonal matrix of singular */
+/* values and the columns of the matrices U and V are the left */
+/* and right singular vectors, respectively, of B. */
+/* 2) Same as 1), but the singular values are stored in S2 and the */
+/* singular vectors are not computed. */
+
+/* For each pair of matrix dimensions (M,N) and each selected matrix */
+/* type, an M by N matrix A and an M by NRHS matrix X are generated. */
+/* The problem dimensions are as follows */
+/* A: M x N */
+/* Q: M x min(M,N) (but M x M if NRHS > 0) */
+/* P: min(M,N) x N */
+/* B: min(M,N) x min(M,N) */
+/* U, V: min(M,N) x min(M,N) */
+/* S1, S2 diagonal, order min(M,N) */
+/* X: M x NRHS */
+
+/* For each generated matrix, 14 tests are performed: */
+
+/* Test SGEBRD and SORGBR */
+
+/* (1) | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P' */
+
+/* (2) | I - Q' Q | / ( M ulp ) */
+
+/* (3) | I - PT PT' | / ( N ulp ) */
+
+/* Test SBDSQR on bidiagonal matrix B */
+
+/* (4) | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V' */
+
+/* (5) | Y - U Z | / ( |Y| max(min(M,N),k) ulp ), where Y = Q' X */
+/* and Z = U' Y. */
+/* (6) | I - U' U | / ( min(M,N) ulp ) */
+
+/* (7) | I - VT VT' | / ( min(M,N) ulp ) */
+
+/* (8) S1 contains min(M,N) nonnegative values in decreasing order. */
+/* (Return 0 if true, 1/ULP if false.) */
+
+/* (9) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without */
+/* computing U and V. */
+
+/* (10) 0 if the true singular values of B are within THRESH of */
+/* those in S1. 2*THRESH if they are not. (Tested using */
+/* SSVDCH) */
+
+/* Test SBDSQR on matrix A */
+
+/* (11) | A - (QU) S (VT PT) | / ( |A| max(M,N) ulp ) */
+
+/* (12) | X - (QU) Z | / ( |X| max(M,k) ulp ) */
+
+/* (13) | I - (QU)'(QU) | / ( M ulp ) */
+
+/* (14) | I - (VT PT) (PT'VT') | / ( N ulp ) */
+
+/* Test SBDSDC on bidiagonal matrix B */
+
+/* (15) | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V' */
+
+/* (16) | I - U' U | / ( min(M,N) ulp ) */
+
+/* (17) | I - VT VT' | / ( min(M,N) ulp ) */
+
+/* (18) S1 contains min(M,N) nonnegative values in decreasing order. */
+/* (Return 0 if true, 1/ULP if false.) */
+
+/* (19) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without */
+/* computing U and V. */
+/* The possible matrix types are */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (6) Same as (3), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (3), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) Rectangular matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
+
+/* Special case: */
+/* (16) A bidiagonal matrix with random entries chosen from a */
+/* logarithmic distribution on [ulp^2,ulp^(-2)] (I.e., each */
+/* entry is e^x, where x is chosen uniformly on */
+/* [ 2 log(ulp), -2 log(ulp) ] .) For *this* type: */
+/* (a) SGEBRD is not called to reduce it to bidiagonal form. */
+/* (b) the bidiagonal is min(M,N) x min(M,N); if M<N, the */
+/* matrix will be lower bidiagonal, otherwise upper. */
+/* (c) only tests 5--8 and 14 are performed. */
+
+/* A subset of the full set of matrix types may be selected through */
+/* the logical array DOTYPE. */
+
+/* Arguments */
+/* ========== */
+
+/* NSIZES (input) INTEGER */
+/* The number of values of M and N contained in the vectors */
+/* MVAL and NVAL. The matrix sizes are used in pairs (M,N). */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix column dimension N. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, SCHKBD */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrices are in A and B. */
+/* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size (m,n), a matrix */
+/* of type j will be generated. If NTYPES is smaller than the */
+/* maximum number of types defined (PARAMETER MAXTYP), then */
+/* types NTYPES+1 through MAXTYP will not be generated. If */
+/* NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through */
+/* DOTYPE(NTYPES) will be ignored. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns in the "right-hand side" matrices X, Y, */
+/* and Z, used in testing SBDSQR. If NRHS = 0, then the */
+/* operations on the right-hand side will not be tested. */
+/* NRHS must be at least 0. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The values of ISEED are changed on exit, and can be */
+/* used in the next call to SCHKBD to continue the same random */
+/* number sequence. */
+
+/* THRESH (input) 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. Note that the */
+/* expected value of the test ratios is O(1), so THRESH should */
+/* be a reasonably small multiple of 1, e.g., 10 or 100. */
+
+/* A (workspace) REAL array, dimension (LDA,NMAX) */
+/* where NMAX is the maximum value of N in NVAL. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,MMAX), */
+/* where MMAX is the maximum value of M in MVAL. */
+
+/* BD (workspace) REAL array, dimension */
+/* (max(min(MVAL(j),NVAL(j)))) */
+
+/* BE (workspace) REAL array, dimension */
+/* (max(min(MVAL(j),NVAL(j)))) */
+
+/* S1 (workspace) REAL array, dimension */
+/* (max(min(MVAL(j),NVAL(j)))) */
+
+/* S2 (workspace) REAL array, dimension */
+/* (max(min(MVAL(j),NVAL(j)))) */
+
+/* X (workspace) REAL array, dimension (LDX,NRHS) */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the arrays X, Y, and Z. */
+/* LDX >= max(1,MMAX) */
+
+/* Y (workspace) REAL array, dimension (LDX,NRHS) */
+
+/* Z (workspace) REAL array, dimension (LDX,NRHS) */
+
+/* Q (workspace) REAL array, dimension (LDQ,MMAX) */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,MMAX). */
+
+/* PT (workspace) REAL array, dimension (LDPT,NMAX) */
+
+/* LDPT (input) INTEGER */
+/* The leading dimension of the arrays PT, U, and V. */
+/* LDPT >= max(1, max(min(MVAL(j),NVAL(j)))). */
+
+/* U (workspace) REAL array, dimension */
+/* (LDPT,max(min(MVAL(j),NVAL(j)))) */
+
+/* V (workspace) REAL array, dimension */
+/* (LDPT,max(min(MVAL(j),NVAL(j)))) */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 3(M+N) and M(M + max(M,N,k) + 1) + N*min(M,N) for all */
+/* pairs (M,N)=(MM(j),NN(j)) */
+
+/* IWORK (workspace) INTEGER array, dimension at least 8*min(M,N) */
+
+/* NOUT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some MM(j) < 0 */
+/* -3: Some NN(j) < 0 */
+/* -4: NTYPES < 0 */
+/* -6: NRHS < 0 */
+/* -8: THRESH < 0 */
+/* -11: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ). */
+/* -17: LDB < 1 or LDB < MMAX. */
+/* -21: LDQ < 1 or LDQ < MMAX. */
+/* -23: LDPT< 1 or LDPT< MNMAX. */
+/* -27: LWORK too small. */
+/* If SLATMR, SLATMS, SGEBRD, SORGBR, or SBDSQR, */
+/* returns an error code, the */
+/* absolute value of it is returned. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests performed, or which can */
+/* be performed so far, for the current matrix. */
+/* MMAX Largest value in NN. */
+/* NMAX Largest value in NN. */
+/* MNMIN min(MM(j), NN(j)) (the dimension of the bidiagonal */
+/* matrix.) */
+/* MNMAX The maximum value of MNMIN for j=1,...,NSIZES. */
+/* NFAIL The number of tests which have exceeded THRESH */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* ====================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --mval;
+ --nval;
+ --dotype;
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --bd;
+ --be;
+ --s1;
+ --s2;
+ z_dim1 = *ldx;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ y_dim1 = *ldx;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ vt_dim1 = *ldpt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ u_dim1 = *ldpt;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ pt_dim1 = *ldpt;
+ pt_offset = 1 + pt_dim1;
+ pt -= pt_offset;
+ --work;
+ --iwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+
+ badmm = FALSE_;
+ badnn = FALSE_;
+ mmax = 1;
+ nmax = 1;
+ mnmax = 1;
+ minwrk = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = mmax, i__3 = mval[j];
+ mmax = max(i__2,i__3);
+ if (mval[j] < 0) {
+ badmm = TRUE_;
+ }
+/* Computing MAX */
+ i__2 = nmax, i__3 = nval[j];
+ nmax = max(i__2,i__3);
+ if (nval[j] < 0) {
+ badnn = TRUE_;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__4 = mval[j], i__5 = nval[j];
+ i__2 = mnmax, i__3 = min(i__4,i__5);
+ mnmax = max(i__2,i__3);
+/* Computing MAX */
+/* Computing MAX */
+ i__4 = mval[j], i__5 = nval[j], i__4 = max(i__4,i__5);
+/* Computing MIN */
+ i__6 = nval[j], i__7 = mval[j];
+ i__2 = minwrk, i__3 = (mval[j] + nval[j]) * 3, i__2 = max(i__2,i__3),
+ i__3 = mval[j] * (mval[j] + max(i__4,*nrhs) + 1) + nval[j] *
+ min(i__6,i__7);
+ minwrk = max(i__2,i__3);
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badmm) {
+ *info = -2;
+ } else if (badnn) {
+ *info = -3;
+ } else if (*ntypes < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*lda < mmax) {
+ *info = -11;
+ } else if (*ldx < mmax) {
+ *info = -17;
+ } else if (*ldq < mmax) {
+ *info = -21;
+ } else if (*ldpt < mnmax) {
+ *info = -23;
+ } else if (minwrk > *lwork) {
+ *info = -27;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SCHKBD", &i__1);
+ return 0;
+ }
+
+/* Initialize constants */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "BD", (ftnlen)2, (ftnlen)2);
+ nfail = 0;
+ ntest = 0;
+ unfl = slamch_("Safe minimum");
+ ovfl = slamch_("Overflow");
+ slabad_(&unfl, &ovfl);
+ ulp = slamch_("Precision");
+ ulpinv = 1.f / ulp;
+ log2ui = (integer) (log(ulpinv) / log(2.f));
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+ infoc_1.infot = 0;
+
+/* Loop over sizes, types */
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ m = mval[jsize];
+ n = nval[jsize];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__2 = max(m,n);
+ amninv = 1.f / max(i__2,1);
+
+ if (*nsizes != 1) {
+ mtypes = min(16,*ntypes);
+ } else {
+ mtypes = min(17,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L190;
+ }
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+ for (j = 1; j <= 14; ++j) {
+ result[j - 1] = -1.f;
+/* L30: */
+ }
+
+ *(unsigned char *)uplo = ' ';
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random symmetric, w/ eigenvalues */
+/* =6 nonsymmetric, w/ singular values */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 random nonsymmetric */
+/* =10 random bidiagonal (log. distrib.) */
+
+ if (mtypes > 16) {
+ goto L100;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.f;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * amninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * max(m,n) * ulpinv;
+ goto L70;
+
+L70:
+
+ slaset_("Full", lda, &n, &c_b20, &c_b20, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+ bidiag = FALSE_;
+ if (itype == 1) {
+
+/* Zero matrix */
+
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = mnmin;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ slatms_(&mnmin, &mnmin, "S", &iseed[1], "N", &work[1], &imode,
+ &cond, &anorm, &c__0, &c__0, "N", &a[a_offset], lda,
+ &work[mnmin + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ slatms_(&mnmin, &mnmin, "S", &iseed[1], "S", &work[1], &imode,
+ &cond, &anorm, &m, &n, "N", &a[a_offset], lda, &work[
+ mnmin + 1], &iinfo);
+
+ } else if (itype == 6) {
+
+/* Nonsymmetric, singular values specified */
+
+ slatms_(&m, &n, "S", &iseed[1], "N", &work[1], &imode, &cond,
+ &anorm, &m, &n, "N", &a[a_offset], lda, &work[mnmin +
+ 1], &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random entries */
+
+ slatmr_(&mnmin, &mnmin, "S", &iseed[1], "N", &work[1], &c__6,
+ &c_b37, &c_b37, "T", "N", &work[mnmin + 1], &c__1, &
+ c_b37, &work[(mnmin << 1) + 1], &c__1, &c_b37, "N", &
+ iwork[1], &c__0, &c__0, &c_b20, &anorm, "NO", &a[
+ a_offset], lda, &iwork[1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random entries */
+
+ slatmr_(&mnmin, &mnmin, "S", &iseed[1], "S", &work[1], &c__6,
+ &c_b37, &c_b37, "T", "N", &work[mnmin + 1], &c__1, &
+ c_b37, &work[m + mnmin + 1], &c__1, &c_b37, "N", &
+ iwork[1], &m, &n, &c_b20, &anorm, "NO", &a[a_offset],
+ lda, &iwork[1], &iinfo);
+
+ } else if (itype == 9) {
+
+/* Nonsymmetric, random entries */
+
+ slatmr_(&m, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b37,
+ &c_b37, "T", "N", &work[mnmin + 1], &c__1, &c_b37, &
+ work[m + mnmin + 1], &c__1, &c_b37, "N", &iwork[1], &
+ m, &n, &c_b20, &anorm, "NO", &a[a_offset], lda, &
+ iwork[1], &iinfo);
+
+ } else if (itype == 10) {
+
+/* Bidiagonal, random entries */
+
+ temp1 = log(ulp) * -2.f;
+ i__3 = mnmin;
+ for (j = 1; j <= i__3; ++j) {
+ bd[j] = exp(temp1 * slarnd_(&c__2, &iseed[1]));
+ if (j < mnmin) {
+ be[j] = exp(temp1 * slarnd_(&c__2, &iseed[1]));
+ }
+/* L90: */
+ }
+
+ iinfo = 0;
+ bidiag = TRUE_;
+ if (m >= n) {
+ *(unsigned char *)uplo = 'U';
+ } else {
+ *(unsigned char *)uplo = 'L';
+ }
+ } else {
+ iinfo = 1;
+ }
+
+ if (iinfo == 0) {
+
+/* Generate Right-Hand Side */
+
+ if (bidiag) {
+ slatmr_(&mnmin, nrhs, "S", &iseed[1], "N", &work[1], &
+ c__6, &c_b37, &c_b37, "T", "N", &work[mnmin + 1],
+ &c__1, &c_b37, &work[(mnmin << 1) + 1], &c__1, &
+ c_b37, "N", &iwork[1], &mnmin, nrhs, &c_b20, &
+ c_b37, "NO", &y[y_offset], ldx, &iwork[1], &iinfo);
+ } else {
+ slatmr_(&m, nrhs, "S", &iseed[1], "N", &work[1], &c__6, &
+ c_b37, &c_b37, "T", "N", &work[m + 1], &c__1, &
+ c_b37, &work[(m << 1) + 1], &c__1, &c_b37, "N", &
+ iwork[1], &m, nrhs, &c_b20, &c_b37, "NO", &x[
+ x_offset], ldx, &iwork[1], &iinfo);
+ }
+ }
+
+/* Error Exit */
+
+ if (iinfo != 0) {
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L100:
+
+/* Call SGEBRD and SORGBR to compute B, Q, and P, do tests. */
+
+ if (! bidiag) {
+
+/* Compute transformations to reduce A to bidiagonal form: */
+/* B := Q' * A * P. */
+
+ slacpy_(" ", &m, &n, &a[a_offset], lda, &q[q_offset], ldq);
+ i__3 = *lwork - (mnmin << 1);
+ sgebrd_(&m, &n, &q[q_offset], ldq, &bd[1], &be[1], &work[1], &
+ work[mnmin + 1], &work[(mnmin << 1) + 1], &i__3, &
+ iinfo);
+
+/* Check error code from SGEBRD. */
+
+ if (iinfo != 0) {
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "SGEBRD", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+ slacpy_(" ", &m, &n, &q[q_offset], ldq, &pt[pt_offset], ldpt);
+ if (m >= n) {
+ *(unsigned char *)uplo = 'U';
+ } else {
+ *(unsigned char *)uplo = 'L';
+ }
+
+/* Generate Q */
+
+ mq = m;
+ if (*nrhs <= 0) {
+ mq = mnmin;
+ }
+ i__3 = *lwork - (mnmin << 1);
+ sorgbr_("Q", &m, &mq, &n, &q[q_offset], ldq, &work[1], &work[(
+ mnmin << 1) + 1], &i__3, &iinfo);
+
+/* Check error code from SORGBR. */
+
+ if (iinfo != 0) {
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "SORGBR(Q)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Generate P' */
+
+ i__3 = *lwork - (mnmin << 1);
+ sorgbr_("P", &mnmin, &n, &m, &pt[pt_offset], ldpt, &work[
+ mnmin + 1], &work[(mnmin << 1) + 1], &i__3, &iinfo);
+
+/* Check error code from SORGBR. */
+
+ if (iinfo != 0) {
+ io___43.ciunit = *nout;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "SORGBR(P)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Apply Q' to an M by NRHS matrix X: Y := Q' * X. */
+
+ sgemm_("Transpose", "No transpose", &m, nrhs, &m, &c_b37, &q[
+ q_offset], ldq, &x[x_offset], ldx, &c_b20, &y[
+ y_offset], ldx);
+
+/* Test 1: Check the decomposition A := Q * B * PT */
+/* 2: Check the orthogonality of Q */
+/* 3: Check the orthogonality of PT */
+
+ sbdt01_(&m, &n, &c__1, &a[a_offset], lda, &q[q_offset], ldq, &
+ bd[1], &be[1], &pt[pt_offset], ldpt, &work[1], result)
+ ;
+ sort01_("Columns", &m, &mq, &q[q_offset], ldq, &work[1],
+ lwork, &result[1]);
+ sort01_("Rows", &mnmin, &n, &pt[pt_offset], ldpt, &work[1],
+ lwork, &result[2]);
+ }
+
+/* Use SBDSQR to form the SVD of the bidiagonal matrix B: */
+/* B := U * S1 * VT, and compute Z = U' * Y. */
+
+ scopy_(&mnmin, &bd[1], &c__1, &s1[1], &c__1);
+ if (mnmin > 0) {
+ i__3 = mnmin - 1;
+ scopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
+ }
+ slacpy_(" ", &m, nrhs, &y[y_offset], ldx, &z__[z_offset], ldx);
+ slaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &u[u_offset],
+ ldpt);
+ slaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &vt[vt_offset],
+ ldpt);
+
+ sbdsqr_(uplo, &mnmin, &mnmin, &mnmin, nrhs, &s1[1], &work[1], &vt[
+ vt_offset], ldpt, &u[u_offset], ldpt, &z__[z_offset], ldx,
+ &work[mnmin + 1], &iinfo);
+
+/* Check error code from SBDSQR. */
+
+ if (iinfo != 0) {
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "SBDSQR(vects)", (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[3] = ulpinv;
+ goto L170;
+ }
+ }
+
+/* Use SBDSQR to compute only the singular values of the */
+/* bidiagonal matrix B; U, VT, and Z should not be modified. */
+
+ scopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
+ if (mnmin > 0) {
+ i__3 = mnmin - 1;
+ scopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
+ }
+
+ sbdsqr_(uplo, &mnmin, &c__0, &c__0, &c__0, &s2[1], &work[1], &vt[
+ vt_offset], ldpt, &u[u_offset], ldpt, &z__[z_offset], ldx,
+ &work[mnmin + 1], &iinfo);
+
+/* Check error code from SBDSQR. */
+
+ if (iinfo != 0) {
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "SBDSQR(values)", (ftnlen)14);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[8] = ulpinv;
+ goto L170;
+ }
+ }
+
+/* Test 4: Check the decomposition B := U * S1 * VT */
+/* 5: Check the computation Z := U' * Y */
+/* 6: Check the orthogonality of U */
+/* 7: Check the orthogonality of VT */
+
+ sbdt03_(uplo, &mnmin, &c__1, &bd[1], &be[1], &u[u_offset], ldpt, &
+ s1[1], &vt[vt_offset], ldpt, &work[1], &result[3]);
+ sbdt02_(&mnmin, nrhs, &y[y_offset], ldx, &z__[z_offset], ldx, &u[
+ u_offset], ldpt, &work[1], &result[4]);
+ sort01_("Columns", &mnmin, &mnmin, &u[u_offset], ldpt, &work[1],
+ lwork, &result[5]);
+ sort01_("Rows", &mnmin, &mnmin, &vt[vt_offset], ldpt, &work[1],
+ lwork, &result[6]);
+
+/* Test 8: Check that the singular values are sorted in */
+/* non-increasing order and are non-negative */
+
+ result[7] = 0.f;
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (s1[i__] < s1[i__ + 1]) {
+ result[7] = ulpinv;
+ }
+ if (s1[i__] < 0.f) {
+ result[7] = ulpinv;
+ }
+/* L110: */
+ }
+ if (mnmin >= 1) {
+ if (s1[mnmin] < 0.f) {
+ result[7] = ulpinv;
+ }
+ }
+
+/* Test 9: Compare SBDSQR with and without singular vectors */
+
+ temp2 = 0.f;
+
+ i__3 = mnmin;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+/* Computing MAX */
+ r__6 = (r__1 = s1[j], dabs(r__1)), r__7 = (r__2 = s2[j], dabs(
+ r__2));
+ r__4 = sqrt(unfl) * dmax(s1[1],1.f), r__5 = ulp * dmax(r__6,
+ r__7);
+ temp1 = (r__3 = s1[j] - s2[j], dabs(r__3)) / dmax(r__4,r__5);
+ temp2 = dmax(temp1,temp2);
+/* L120: */
+ }
+
+ result[8] = temp2;
+
+/* Test 10: Sturm sequence test of singular values */
+/* Go up by factors of two until it succeeds */
+
+ temp1 = *thresh * (.5f - ulp);
+
+ i__3 = log2ui;
+ for (j = 0; j <= i__3; ++j) {
+/* CALL SSVDCH( MNMIN, BD, BE, S1, TEMP1, IINFO ) */
+ if (iinfo == 0) {
+ goto L140;
+ }
+ temp1 *= 2.f;
+/* L130: */
+ }
+
+L140:
+ result[9] = temp1;
+
+/* Use SBDSQR to form the decomposition A := (QU) S (VT PT) */
+/* from the bidiagonal form A := Q B PT. */
+
+ if (! bidiag) {
+ scopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
+ if (mnmin > 0) {
+ i__3 = mnmin - 1;
+ scopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
+ }
+
+ sbdsqr_(uplo, &mnmin, &n, &m, nrhs, &s2[1], &work[1], &pt[
+ pt_offset], ldpt, &q[q_offset], ldq, &y[y_offset],
+ ldx, &work[mnmin + 1], &iinfo);
+
+/* Test 11: Check the decomposition A := Q*U * S2 * VT*PT */
+/* 12: Check the computation Z := U' * Q' * X */
+/* 13: Check the orthogonality of Q*U */
+/* 14: Check the orthogonality of VT*PT */
+
+ sbdt01_(&m, &n, &c__0, &a[a_offset], lda, &q[q_offset], ldq, &
+ s2[1], dumma, &pt[pt_offset], ldpt, &work[1], &result[
+ 10]);
+ sbdt02_(&m, nrhs, &x[x_offset], ldx, &y[y_offset], ldx, &q[
+ q_offset], ldq, &work[1], &result[11]);
+ sort01_("Columns", &m, &mq, &q[q_offset], ldq, &work[1],
+ lwork, &result[12]);
+ sort01_("Rows", &mnmin, &n, &pt[pt_offset], ldpt, &work[1],
+ lwork, &result[13]);
+ }
+
+/* Use SBDSDC to form the SVD of the bidiagonal matrix B: */
+/* B := U * S1 * VT */
+
+ scopy_(&mnmin, &bd[1], &c__1, &s1[1], &c__1);
+ if (mnmin > 0) {
+ i__3 = mnmin - 1;
+ scopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
+ }
+ slaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &u[u_offset],
+ ldpt);
+ slaset_("Full", &mnmin, &mnmin, &c_b20, &c_b37, &vt[vt_offset],
+ ldpt);
+
+ sbdsdc_(uplo, "I", &mnmin, &s1[1], &work[1], &u[u_offset], ldpt, &
+ vt[vt_offset], ldpt, dum, idum, &work[mnmin + 1], &iwork[
+ 1], &iinfo);
+
+/* Check error code from SBDSDC. */
+
+ if (iinfo != 0) {
+ io___51.ciunit = *nout;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "SBDSDC(vects)", (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[14] = ulpinv;
+ goto L170;
+ }
+ }
+
+/* Use SBDSDC to compute only the singular values of the */
+/* bidiagonal matrix B; U and VT should not be modified. */
+
+ scopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
+ if (mnmin > 0) {
+ i__3 = mnmin - 1;
+ scopy_(&i__3, &be[1], &c__1, &work[1], &c__1);
+ }
+
+ sbdsdc_(uplo, "N", &mnmin, &s2[1], &work[1], dum, &c__1, dum, &
+ c__1, dum, idum, &work[mnmin + 1], &iwork[1], &iinfo);
+
+/* Check error code from SBDSDC. */
+
+ if (iinfo != 0) {
+ io___52.ciunit = *nout;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "SBDSDC(values)", (ftnlen)14);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[17] = ulpinv;
+ goto L170;
+ }
+ }
+
+/* Test 15: Check the decomposition B := U * S1 * VT */
+/* 16: Check the orthogonality of U */
+/* 17: Check the orthogonality of VT */
+
+ sbdt03_(uplo, &mnmin, &c__1, &bd[1], &be[1], &u[u_offset], ldpt, &
+ s1[1], &vt[vt_offset], ldpt, &work[1], &result[14]);
+ sort01_("Columns", &mnmin, &mnmin, &u[u_offset], ldpt, &work[1],
+ lwork, &result[15]);
+ sort01_("Rows", &mnmin, &mnmin, &vt[vt_offset], ldpt, &work[1],
+ lwork, &result[16]);
+
+/* Test 18: Check that the singular values are sorted in */
+/* non-increasing order and are non-negative */
+
+ result[17] = 0.f;
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (s1[i__] < s1[i__ + 1]) {
+ result[17] = ulpinv;
+ }
+ if (s1[i__] < 0.f) {
+ result[17] = ulpinv;
+ }
+/* L150: */
+ }
+ if (mnmin >= 1) {
+ if (s1[mnmin] < 0.f) {
+ result[17] = ulpinv;
+ }
+ }
+
+/* Test 19: Compare SBDSQR with and without singular vectors */
+
+ temp2 = 0.f;
+
+ i__3 = mnmin;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+/* Computing MAX */
+ r__4 = dabs(s1[1]), r__5 = dabs(s2[1]);
+ r__2 = sqrt(unfl) * dmax(s1[1],1.f), r__3 = ulp * dmax(r__4,
+ r__5);
+ temp1 = (r__1 = s1[j] - s2[j], dabs(r__1)) / dmax(r__2,r__3);
+ temp2 = dmax(temp1,temp2);
+/* L160: */
+ }
+
+ result[18] = temp2;
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L170:
+ for (j = 1; j <= 19; ++j) {
+ if (result[j - 1] >= *thresh) {
+ if (nfail == 0) {
+ slahd2_(nout, path);
+ }
+ io___53.ciunit = *nout;
+ s_wsfe(&io___53);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ ++nfail;
+ }
+/* L180: */
+ }
+ if (! bidiag) {
+ ntest += 19;
+ } else {
+ ntest += 5;
+ }
+
+L190:
+ ;
+ }
+/* L200: */
+ }
+
+/* Summary */
+
+ alasum_(path, nout, &nfail, &ntest, &c__0);
+
+ return 0;
+
+/* End of SCHKBD */
+
+
+} /* schkbd_ */
diff --git a/TESTING/EIG/schkbk.c b/TESTING/EIG/schkbk.c
new file mode 100644
index 0000000..286906d
--- /dev/null
+++ b/TESTING/EIG/schkbk.c
@@ -0,0 +1,231 @@
+/* schkbk.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c__20 = 20;
+
+/* Subroutine */ int schkbk_(integer *nin, integer *nout)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002.. test output of SGEBAK .. \002)";
+ static char fmt_9998[] = "(1x,\002value of largest test error "
+ " = \002,e12.3)";
+ static char fmt_9997[] = "(1x,\002example number where info is not zero "
+ " = \002,i4)";
+ static char fmt_9996[] = "(1x,\002example number having largest error "
+ " = \002,i4)";
+ static char fmt_9995[] = "(1x,\002number of examples where info is not 0"
+ " = \002,i4)";
+ static char fmt_9994[] = "(1x,\002total number of examples tested "
+ " = \002,i4)";
+
+ /* System generated locals */
+ integer i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void), s_wsfe(cilist *), e_wsfe(void), do_fio(integer *,
+ char *, ftnlen);
+
+ /* Local variables */
+ real e[400] /* was [20][20] */;
+ integer i__, j, n;
+ real x;
+ integer ihi;
+ real ein[400] /* was [20][20] */;
+ integer ilo;
+ real eps;
+ integer knt, info, lmax[2];
+ real rmax, vmax, scale[20];
+ integer ninfo;
+ extern /* Subroutine */ int sgebak_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ real safmin;
+
+ /* Fortran I/O blocks */
+ static cilist io___7 = { 0, 0, 0, 0, 0 };
+ static cilist io___11 = { 0, 0, 0, 0, 0 };
+ static cilist io___14 = { 0, 0, 0, 0, 0 };
+ static cilist io___17 = { 0, 0, 0, 0, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___26 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKBK tests SGEBAK, a routine for backward transformation of */
+/* the computed right or left eigenvectors if the orginal matrix */
+/* was preprocessed by balance subroutine SGEBAL. */
+
+/* Arguments */
+/* ========= */
+
+/* NIN (input) INTEGER */
+/* The logical unit number for input. NIN > 0. */
+
+/* NOUT (input) INTEGER */
+/* The logical unit number for output. NOUT > 0. */
+
+/* ====================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ lmax[0] = 0;
+ lmax[1] = 0;
+ ninfo = 0;
+ knt = 0;
+ rmax = 0.f;
+ eps = slamch_("E");
+ safmin = slamch_("S");
+
+L10:
+
+ io___7.ciunit = *nin;
+ s_rsle(&io___7);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ilo, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ihi, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ goto L60;
+ }
+
+ io___11.ciunit = *nin;
+ s_rsle(&io___11);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__4, &c__1, (char *)&scale[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_rsle();
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___14.ciunit = *nin;
+ s_rsle(&io___14);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__4, &c__1, (char *)&e[i__ + j * 20 - 21], (ftnlen)
+ sizeof(real));
+ }
+ e_rsle();
+/* L20: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___17.ciunit = *nin;
+ s_rsle(&io___17);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__4, &c__1, (char *)&ein[i__ + j * 20 - 21], (ftnlen)
+ sizeof(real));
+ }
+ e_rsle();
+/* L30: */
+ }
+
+ ++knt;
+ sgebak_("B", "R", &n, &ilo, &ihi, scale, &n, e, &c__20, &info);
+
+ if (info != 0) {
+ ++ninfo;
+ lmax[0] = knt;
+ }
+
+ vmax = 0.f;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ x = (r__1 = e[i__ + j * 20 - 21] - ein[i__ + j * 20 - 21], dabs(
+ r__1)) / eps;
+ if ((r__1 = e[i__ + j * 20 - 21], dabs(r__1)) > safmin) {
+ x /= (r__2 = e[i__ + j * 20 - 21], dabs(r__2));
+ }
+ vmax = dmax(vmax,x);
+/* L40: */
+ }
+/* L50: */
+ }
+
+ if (vmax > rmax) {
+ lmax[1] = knt;
+ rmax = vmax;
+ }
+
+ goto L10;
+
+L60:
+
+ io___22.ciunit = *nout;
+ s_wsfe(&io___22);
+ e_wsfe();
+
+ io___23.ciunit = *nout;
+ s_wsfe(&io___23);
+ do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ io___24.ciunit = *nout;
+ s_wsfe(&io___24);
+ do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___25.ciunit = *nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ return 0;
+
+/* End of SCHKBK */
+
+} /* schkbk_ */
diff --git a/TESTING/EIG/schkbl.c b/TESTING/EIG/schkbl.c
new file mode 100644
index 0000000..b42e136
--- /dev/null
+++ b/TESTING/EIG/schkbl.c
@@ -0,0 +1,263 @@
+/* schkbl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c__20 = 20;
+
+/* Subroutine */ int schkbl_(integer *nin, integer *nout)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002.. test output of SGEBAL .. \002)";
+ static char fmt_9998[] = "(1x,\002value of largest test error "
+ " = \002,e12.3)";
+ static char fmt_9997[] = "(1x,\002example number where info is not zero "
+ " = \002,i4)";
+ static char fmt_9996[] = "(1x,\002example number where ILO or IHI wrong "
+ " = \002,i4)";
+ static char fmt_9995[] = "(1x,\002example number having largest error "
+ " = \002,i4)";
+ static char fmt_9994[] = "(1x,\002number of examples where info is not 0"
+ " = \002,i4)";
+ static char fmt_9993[] = "(1x,\002total number of examples tested "
+ " = \002,i4)";
+
+ /* System generated locals */
+ integer i__1, i__2;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void), s_wsfe(cilist *), e_wsfe(void), do_fio(integer *,
+ char *, ftnlen);
+
+ /* Local variables */
+ real a[400] /* was [20][20] */;
+ integer i__, j, n;
+ real ain[400] /* was [20][20] */;
+ integer ihi, ilo, knt, info, lmax[3];
+ real meps, temp, rmax, vmax, scale[20];
+ integer ihiin, ninfo, iloin;
+ real anorm, sfmin, dummy[1];
+ extern /* Subroutine */ int sgebal_(char *, integer *, real *, integer *,
+ integer *, integer *, real *, integer *);
+ extern doublereal slamch_(char *);
+ real scalin[20];
+ extern doublereal slange_(char *, integer *, integer *, real *, integer *,
+ real *);
+
+ /* Fortran I/O blocks */
+ static cilist io___8 = { 0, 0, 0, 0, 0 };
+ static cilist io___11 = { 0, 0, 0, 0, 0 };
+ static cilist io___14 = { 0, 0, 0, 0, 0 };
+ static cilist io___17 = { 0, 0, 0, 0, 0 };
+ static cilist io___19 = { 0, 0, 0, 0, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKBL tests SGEBAL, a routine for balancing a general real */
+/* matrix and isolating some of its eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* NIN (input) INTEGER */
+/* The logical unit number for input. NIN > 0. */
+
+/* NOUT (input) INTEGER */
+/* The logical unit number for output. NOUT > 0. */
+
+/* ====================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ lmax[0] = 0;
+ lmax[1] = 0;
+ lmax[2] = 0;
+ ninfo = 0;
+ knt = 0;
+ rmax = 0.f;
+ vmax = 0.f;
+ sfmin = slamch_("S");
+ meps = slamch_("E");
+
+L10:
+
+ io___8.ciunit = *nin;
+ s_rsle(&io___8);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ goto L70;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___11.ciunit = *nin;
+ s_rsle(&io___11);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__4, &c__1, (char *)&a[i__ + j * 20 - 21], (ftnlen)
+ sizeof(real));
+ }
+ e_rsle();
+/* L20: */
+ }
+
+ io___14.ciunit = *nin;
+ s_rsle(&io___14);
+ do_lio(&c__3, &c__1, (char *)&iloin, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ihiin, (ftnlen)sizeof(integer));
+ e_rsle();
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___17.ciunit = *nin;
+ s_rsle(&io___17);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__4, &c__1, (char *)&ain[i__ + j * 20 - 21], (ftnlen)
+ sizeof(real));
+ }
+ e_rsle();
+/* L30: */
+ }
+ io___19.ciunit = *nin;
+ s_rsle(&io___19);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__4, &c__1, (char *)&scalin[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_rsle();
+
+ anorm = slange_("M", &n, &n, a, &c__20, dummy);
+ ++knt;
+
+ sgebal_("B", &n, a, &c__20, &ilo, &ihi, scale, &info);
+
+ if (info != 0) {
+ ++ninfo;
+ lmax[0] = knt;
+ }
+
+ if (ilo != iloin || ihi != ihiin) {
+ ++ninfo;
+ lmax[1] = knt;
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ r__1 = a[i__ + j * 20 - 21], r__2 = ain[i__ + j * 20 - 21];
+ temp = dmax(r__1,r__2);
+ temp = dmax(temp,sfmin);
+/* Computing MAX */
+ r__2 = vmax, r__3 = (r__1 = a[i__ + j * 20 - 21] - ain[i__ + j *
+ 20 - 21], dabs(r__1)) / temp;
+ vmax = dmax(r__2,r__3);
+/* L40: */
+ }
+/* L50: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = scale[i__ - 1], r__2 = scalin[i__ - 1];
+ temp = dmax(r__1,r__2);
+ temp = dmax(temp,sfmin);
+/* Computing MAX */
+ r__2 = vmax, r__3 = (r__1 = scale[i__ - 1] - scalin[i__ - 1], dabs(
+ r__1)) / temp;
+ vmax = dmax(r__2,r__3);
+/* L60: */
+ }
+
+
+ if (vmax > rmax) {
+ lmax[2] = knt;
+ rmax = vmax;
+ }
+
+ goto L10;
+
+L70:
+
+ io___28.ciunit = *nout;
+ s_wsfe(&io___28);
+ e_wsfe();
+
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ return 0;
+
+/* End of SCHKBL */
+
+} /* schkbl_ */
diff --git a/TESTING/EIG/schkec.c b/TESTING/EIG/schkec.c
new file mode 100644
index 0000000..b95a601
--- /dev/null
+++ b/TESTING/EIG/schkec.c
@@ -0,0 +1,310 @@
+/* schkec.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+
+/* Subroutine */ int schkec_(real *thresh, logical *tsterr, integer *nin,
+ integer *nout)
+{
+ /* Format strings */
+ static char fmt_9989[] = "(\002 Tests of the Nonsymmetric eigenproblem c"
+ "ondition estim\002,\002ation routines\002,/\002 SLALN2, SLASY2, "
+ "SLANV2, SLAEXC, STRS\002,\002YL, STREXC, STRSNA, STRSEN, SLAQT"
+ "R\002,/)";
+ static char fmt_9988[] = "(\002 Relative machine precision (EPS) = \002,"
+ "e16.6,/\002 Safe \002,\002minimum (SFMIN) = \002,e16"
+ ".6,/)";
+ static char fmt_9987[] = "(\002 Routines pass computational tests if tes"
+ "t ratio is les\002,\002s than\002,f8.2,//)";
+ static char fmt_9999[] = "(\002 Error in SLALN2: RMAX =\002,e12.3,/\002 "
+ "LMAX = \002,i8,\002 N\002,\002INFO=\002,2i8,\002 KNT=\002,i8)";
+ static char fmt_9998[] = "(\002 Error in SLASY2: RMAX =\002,e12.3,/\002 "
+ "LMAX = \002,i8,\002 N\002,\002INFO=\002,i8,\002 KNT=\002,i8)";
+ static char fmt_9997[] = "(\002 Error in SLANV2: RMAX =\002,e12.3,/\002 "
+ "LMAX = \002,i8,\002 N\002,\002INFO=\002,i8,\002 KNT=\002,i8)";
+ static char fmt_9996[] = "(\002 Error in SLAEXC: RMAX =\002,e12.3,/\002 "
+ "LMAX = \002,i8,\002 N\002,\002INFO=\002,2i8,\002 KNT=\002,i8)";
+ static char fmt_9995[] = "(\002 Error in STRSYL: RMAX =\002,e12.3,/\002 "
+ "LMAX = \002,i8,\002 N\002,\002INFO=\002,i8,\002 KNT=\002,i8)";
+ static char fmt_9994[] = "(\002 Error in STREXC: RMAX =\002,e12.3,/\002 "
+ "LMAX = \002,i8,\002 N\002,\002INFO=\002,3i8,\002 KNT=\002,i8)";
+ static char fmt_9993[] = "(\002 Error in STRSNA: RMAX =\002,3e12.3,/\002"
+ " LMAX = \002,3i8,\002 NINFO=\002,3i8,\002 KNT=\002,i8)";
+ static char fmt_9992[] = "(\002 Error in STRSEN: RMAX =\002,3e12.3,/\002"
+ " LMAX = \002,3i8,\002 NINFO=\002,3i8,\002 KNT=\002,i8)";
+ static char fmt_9991[] = "(\002 Error in SLAQTR: RMAX =\002,e12.3,/\002 "
+ "LMAX = \002,i8,\002 N\002,\002INFO=\002,i8,\002 KNT=\002,i8)";
+ static char fmt_9990[] = "(/1x,\002All tests for \002,a3,\002 routines p"
+ "assed the thresh\002,\002old (\002,i6,\002 tests run)\002)";
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ logical ok;
+ real eps;
+ char path[3];
+ extern /* Subroutine */ int sget31_(real *, integer *, integer *, integer
+ *), sget32_(real *, integer *, integer *, integer *), sget33_(
+ real *, integer *, integer *, integer *), sget34_(real *, integer
+ *, integer *, integer *), sget35_(real *, integer *, integer *,
+ integer *), sget36_(real *, integer *, integer *, integer *,
+ integer *);
+ real sfmin;
+ extern /* Subroutine */ int sget37_(real *, integer *, integer *, integer
+ *, integer *), sget38_(real *, integer *, integer *, integer *,
+ integer *), sget39_(real *, integer *, integer *, integer *);
+ integer klaln2, llaln2, nlaln2[2];
+ real rlaln2;
+ integer klanv2, llanv2, nlanv2;
+ real rlanv2;
+ integer klasy2, llasy2, nlasy2;
+ real rlasy2;
+ integer klaexc, llaexc;
+ extern doublereal slamch_(char *);
+ integer nlaexc[2];
+ real rlaexc;
+ extern /* Subroutine */ int serrec_(char *, integer *);
+ integer klaqtr, llaqtr, ktrexc, ltrexc, ktrsna, nlaqtr, ltrsna[3];
+ real rlaqtr;
+ integer ktrsen;
+ real rtrexc;
+ integer ltrsen[3], ntrexc[3], ntrsen[3], ntrsna[3];
+ real rtrsna[3], rtrsen[3];
+ integer ntests, ktrsyl, ltrsyl, ntrsyl;
+ real rtrsyl;
+
+ /* Fortran I/O blocks */
+ static cilist io___4 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___5 = { 0, 0, 0, fmt_9988, 0 };
+ static cilist io___6 = { 0, 0, 0, fmt_9987, 0 };
+ static cilist io___12 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___17 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9990, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKEC tests eigen- condition estimation routines */
+/* SLALN2, SLASY2, SLANV2, SLAQTR, SLAEXC, */
+/* STRSYL, STREXC, STRSNA, STRSEN */
+
+/* In all cases, the routine runs through a fixed set of numerical */
+/* examples, subjects them to various tests, and compares the test */
+/* results to a threshold THRESH. In addition, STREXC, STRSNA and STRSEN */
+/* are tested by reading in precomputed examples from a file (on input */
+/* unit NIN). Output is written to output unit NOUT. */
+
+/* Arguments */
+/* ========= */
+
+/* THRESH (input) REAL */
+/* Threshold for residual tests. A computed test ratio passes */
+/* the threshold if it is less than THRESH. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NIN (input) INTEGER */
+/* The logical unit number for input. */
+
+/* NOUT (input) INTEGER */
+/* The logical unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "EC", (ftnlen)2, (ftnlen)2);
+ eps = slamch_("P");
+ sfmin = slamch_("S");
+
+/* Print header information */
+
+ io___4.ciunit = *nout;
+ s_wsfe(&io___4);
+ e_wsfe();
+ io___5.ciunit = *nout;
+ s_wsfe(&io___5);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&sfmin, (ftnlen)sizeof(real));
+ e_wsfe();
+ io___6.ciunit = *nout;
+ s_wsfe(&io___6);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
+ e_wsfe();
+
+/* Test error exits if TSTERR is .TRUE. */
+
+ if (*tsterr) {
+ serrec_(path, nout);
+ }
+
+ ok = TRUE_;
+ sget31_(&rlaln2, &llaln2, nlaln2, &klaln2);
+ if (rlaln2 > *thresh || nlaln2[0] != 0) {
+ ok = FALSE_;
+ io___12.ciunit = *nout;
+ s_wsfe(&io___12);
+ do_fio(&c__1, (char *)&rlaln2, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&llaln2, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&nlaln2[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&klaln2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ sget32_(&rlasy2, &llasy2, &nlasy2, &klasy2);
+ if (rlasy2 > *thresh) {
+ ok = FALSE_;
+ io___17.ciunit = *nout;
+ s_wsfe(&io___17);
+ do_fio(&c__1, (char *)&rlasy2, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&llasy2, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nlasy2, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&klasy2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ sget33_(&rlanv2, &llanv2, &nlanv2, &klanv2);
+ if (rlanv2 > *thresh || nlanv2 != 0) {
+ ok = FALSE_;
+ io___22.ciunit = *nout;
+ s_wsfe(&io___22);
+ do_fio(&c__1, (char *)&rlanv2, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&llanv2, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nlanv2, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&klanv2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ sget34_(&rlaexc, &llaexc, nlaexc, &klaexc);
+ if (rlaexc > *thresh || nlaexc[1] != 0) {
+ ok = FALSE_;
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__1, (char *)&rlaexc, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&llaexc, (ftnlen)sizeof(integer));
+ do_fio(&c__2, (char *)&nlaexc[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&klaexc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ sget35_(&rtrsyl, <rsyl, &ntrsyl, &ktrsyl);
+ if (rtrsyl > *thresh) {
+ ok = FALSE_;
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, (char *)&rtrsyl, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)<rsyl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ntrsyl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ktrsyl, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ sget36_(&rtrexc, <rexc, ntrexc, &ktrexc, nin);
+ if (rtrexc > *thresh || ntrexc[2] > 0) {
+ ok = FALSE_;
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&rtrexc, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)<rexc, (ftnlen)sizeof(integer));
+ do_fio(&c__3, (char *)&ntrexc[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ktrexc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ sget37_(rtrsna, ltrsna, ntrsna, &ktrsna, nin);
+ if (rtrsna[0] > *thresh || rtrsna[1] > *thresh || ntrsna[0] != 0 ||
+ ntrsna[1] != 0 || ntrsna[2] != 0) {
+ ok = FALSE_;
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__3, (char *)&rtrsna[0], (ftnlen)sizeof(real));
+ do_fio(&c__3, (char *)<rsna[0], (ftnlen)sizeof(integer));
+ do_fio(&c__3, (char *)&ntrsna[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ktrsna, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ sget38_(rtrsen, ltrsen, ntrsen, &ktrsen, nin);
+ if (rtrsen[0] > *thresh || rtrsen[1] > *thresh || ntrsen[0] != 0 ||
+ ntrsen[1] != 0 || ntrsen[2] != 0) {
+ ok = FALSE_;
+ io___47.ciunit = *nout;
+ s_wsfe(&io___47);
+ do_fio(&c__3, (char *)&rtrsen[0], (ftnlen)sizeof(real));
+ do_fio(&c__3, (char *)<rsen[0], (ftnlen)sizeof(integer));
+ do_fio(&c__3, (char *)&ntrsen[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ktrsen, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ sget39_(&rlaqtr, &llaqtr, &nlaqtr, &klaqtr);
+ if (rlaqtr > *thresh) {
+ ok = FALSE_;
+ io___52.ciunit = *nout;
+ s_wsfe(&io___52);
+ do_fio(&c__1, (char *)&rlaqtr, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&llaqtr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nlaqtr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&klaqtr, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ ntests = klaln2 + klasy2 + klanv2 + klaexc + ktrsyl + ktrexc + ktrsna +
+ ktrsen + klaqtr;
+ if (ok) {
+ io___54.ciunit = *nout;
+ s_wsfe(&io___54);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&ntests, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ return 0;
+
+/* End of SCHKEC */
+
+} /* schkec_ */
diff --git a/TESTING/EIG/schkee.c b/TESTING/EIG/schkee.c
new file mode 100644
index 0000000..7a3c5bb
--- /dev/null
+++ b/TESTING/EIG/schkee.c
@@ -0,0 +1,3483 @@
+/* schkee.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer nproc, nshift, maxb;
+} cenvir_;
+
+#define cenvir_1 cenvir_
+
+struct {
+ integer iparms[100];
+} claenv_;
+
+#define claenv_1 claenv_
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ real selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__5 = 5;
+static integer c__6 = 6;
+static integer c__4 = 4;
+static integer c__12 = 12;
+static integer c__11 = 11;
+static integer c__13 = 13;
+static integer c__2 = 2;
+static integer c__14 = 14;
+static integer c__0 = 0;
+static integer c__15 = 15;
+static integer c__16 = 16;
+static integer c__20 = 20;
+static integer c__132 = 132;
+static integer c__8 = 8;
+static integer c__87781 = 87781;
+static integer c__9 = 9;
+static integer c__25 = 25;
+static integer c__89760 = 89760;
+static integer c__18 = 18;
+static integer c__400 = 400;
+static integer c__89758 = 89758;
+static integer c__264 = 264;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Initialized data */
+
+ static char intstr[10] = "0123456789";
+ static integer ioldsd[4] = { 0,0,0,1 };
+
+ /* Format strings */
+ static char fmt_9987[] = "(\002 Tests of the Nonsymmetric Eigenvalue Pro"
+ "blem routines\002)";
+ static char fmt_9986[] = "(\002 Tests of the Symmetric Eigenvalue Proble"
+ "m routines\002)";
+ static char fmt_9985[] = "(\002 Tests of the Singular Value Decompositio"
+ "n routines\002)";
+ static char fmt_9979[] = "(/\002 Tests of the Nonsymmetric Eigenvalue Pr"
+ "oblem Driver\002,/\002 SGEEV (eigenvalues and eigevectors)"
+ "\002)";
+ static char fmt_9978[] = "(/\002 Tests of the Nonsymmetric Eigenvalue Pr"
+ "oblem Driver\002,/\002 SGEES (Schur form)\002)";
+ static char fmt_9977[] = "(/\002 Tests of the Nonsymmetric Eigenvalue Pr"
+ "oblem Expert\002,\002 Driver\002,/\002 SGEEVX (eigenvalues, e"
+ "igenvectors and\002,\002 condition numbers)\002)";
+ static char fmt_9976[] = "(/\002 Tests of the Nonsymmetric Eigenvalue Pr"
+ "oblem Expert\002,\002 Driver\002,/\002 SGEESX (Schur form and"
+ " condition\002,\002 numbers)\002)";
+ static char fmt_9975[] = "(/\002 Tests of the Generalized Nonsymmetric E"
+ "igenvalue \002,\002Problem routines\002)";
+ static char fmt_9964[] = "(/\002 Tests of the Generalized Nonsymmetric E"
+ "igenvalue \002,\002Problem Driver SGGES\002)";
+ static char fmt_9965[] = "(/\002 Tests of the Generalized Nonsymmetric E"
+ "igenvalue \002,\002Problem Expert Driver SGGESX\002)";
+ static char fmt_9963[] = "(/\002 Tests of the Generalized Nonsymmetric E"
+ "igenvalue \002,\002Problem Driver SGGEV\002)";
+ static char fmt_9962[] = "(/\002 Tests of the Generalized Nonsymmetric E"
+ "igenvalue \002,\002Problem Expert Driver SGGEVX\002)";
+ static char fmt_9974[] = "(\002 Tests of SSBTRD\002,/\002 (reduction of "
+ "a symmetric band \002,\002matrix to tridiagonal form)\002)";
+ static char fmt_9967[] = "(\002 Tests of SGBBRD\002,/\002 (reduction of "
+ "a general band \002,\002matrix to real bidiagonal form)\002)";
+ static char fmt_9971[] = "(/\002 Tests of the Generalized Linear Regress"
+ "ion Model \002,\002routines\002)";
+ static char fmt_9970[] = "(/\002 Tests of the Generalized QR and RQ rout"
+ "ines\002)";
+ static char fmt_9969[] = "(/\002 Tests of the Generalized Singular Valu"
+ "e\002,\002 Decomposition routines\002)";
+ static char fmt_9968[] = "(/\002 Tests of the Linear Least Squares routi"
+ "nes\002)";
+ static char fmt_9992[] = "(1x,a3,\002: Unrecognized path name\002)";
+ static char fmt_9972[] = "(/\002 LAPACK VERSION \002,i1,\002.\002,i1,"
+ "\002.\002,i1)";
+ static char fmt_9984[] = "(/\002 The following parameter values will be "
+ "used:\002)";
+ static char fmt_9989[] = "(\002 Invalid input value: \002,a,\002=\002,"
+ "i6,\002; must be >=\002,i6)";
+ static char fmt_9988[] = "(\002 Invalid input value: \002,a,\002=\002,"
+ "i6,\002; must be <=\002,i6)";
+ static char fmt_9983[] = "(4x,a,10i6,/10x,10i6)";
+ static char fmt_9981[] = "(\002 Relative machine \002,a,\002 is taken to"
+ " be\002,e16.6)";
+ static char fmt_9982[] = "(/\002 Routines pass computational tests if te"
+ "st ratio is \002,\002less than\002,f8.2,/)";
+ static char fmt_9999[] = "(/\002 Execution not attempted due to input er"
+ "rors\002)";
+ static char fmt_9991[] = "(//\002 *** Invalid integer value in column"
+ " \002,i2,\002 of input\002,\002 line:\002,/a79)";
+ static char fmt_9990[] = "(//1x,a3,\002 routines were not tested\002)";
+ static char fmt_9961[] = "(//1x,a3,\002: NB =\002,i4,\002, NBMIN =\002,"
+ "i4,\002, NX =\002,i4,\002, INMIN=\002,i4,\002, INWIN =\002,i4"
+ ",\002, INIBL =\002,i4,\002, ISHFTS =\002,i4,\002, IACC22 =\002,i"
+ "4)";
+ static char fmt_9980[] = "(\002 *** Error code from \002,a,\002 = \002,i"
+ "4)";
+ static char fmt_9997[] = "(//1x,a3,\002: NB =\002,i4,\002, NBMIN =\002,"
+ "i4,\002, NX =\002,i4)";
+ static char fmt_9995[] = "(//1x,a3,\002: NB =\002,i4,\002, NBMIN =\002,"
+ "i4,\002, NX =\002,i4,\002, NRHS =\002,i4)";
+ static char fmt_9973[] = "(/1x,71(\002-\002))";
+ static char fmt_9996[] = "(//1x,a3,\002: NB =\002,i4,\002, NBMIN =\002,"
+ "i4,\002, NS =\002,i4,\002, MAXB =\002,i4,\002, NBCOL =\002,i4)";
+ static char fmt_9966[] = "(//1x,a3,\002: NRHS =\002,i4)";
+ static char fmt_9994[] = "(//\002 End of tests\002)";
+ static char fmt_9993[] = "(\002 Total time used = \002,f12.2,\002 seco"
+ "nds\002,/)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1;
+ cilist ci__1;
+
+ /* Builtin functions */
+ integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), e_wsfe(
+ void), s_rsle(cilist *), do_lio(integer *, integer *, char *,
+ ftnlen), e_rsle(void), s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+ integer i_len(char *, ftnlen);
+
+ /* Local variables */
+ real a[243936] /* was [17424][14] */, b[87120] /* was [17424][5] */,
+ c__[160000] /* was [400][400] */, d__[1584] /* was [132][12] */;
+ integer i__, k;
+ real x[660];
+ char c1[1], c3[3];
+ integer i1;
+ real s1, s2;
+ integer ic, nk, nn, vers_patch__, vers_major__, vers_minor__;
+ logical sbb, glm, sbk, sbl, nep, lse, sgg, sep, sgk, gqr, ses, sgl, sgs,
+ sev, ssb, gsv, sgv, sgx, svd;
+ real eps;
+ logical ssx, svx, sxv;
+ char line[80];
+ real taua[132];
+ integer info;
+ char path[3];
+ integer kval[20], lenp, mval[20], nval[20];
+ real taub[132];
+ integer pval[20], itmp, nrhs;
+ real work[87781];
+ integer iacc22[20];
+ logical fatal;
+ integer iseed[4], nbcol[20], inibl[20], nbval[20], nbmin[20];
+ char vname[32];
+ integer inmin[20], newsd, nsval[20], inwin[20], nxval[20], iwork[89760];
+ extern /* Subroutine */ int schkbb_(integer *, integer *, integer *,
+ integer *, integer *, integer *, logical *, integer *, integer *,
+ real *, integer *, real *, integer *, real *, integer *, real *,
+ real *, real *, integer *, real *, integer *, real *, integer *,
+ real *, real *, integer *, real *, integer *), schkbd_(integer *,
+ integer *, integer *, integer *, logical *, integer *, integer *,
+ real *, real *, integer *, real *, real *, real *, real *, real *,
+ integer *, real *, real *, real *, integer *, real *, integer *,
+ real *, real *, real *, integer *, integer *, integer *, integer *
+), schkec_(real *, logical *, integer *, integer *), alareq_(char
+ *, integer *, logical *, integer *, integer *, integer *),
+ schkbk_(integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int schkbl_(integer *, integer *), schkgg_(
+ integer *, integer *, integer *, logical *, integer *, real *,
+ logical *, real *, integer *, real *, integer *, real *, real *,
+ real *, real *, real *, real *, real *, real *, integer *, real *,
+ real *, real *, real *, real *, real *, real *, real *, real *,
+ real *, real *, real *, integer *, logical *, real *, integer *),
+ schkgk_(integer *, integer *);
+ extern doublereal second_(void);
+ extern /* Subroutine */ int schkgl_(integer *, integer *), schksb_(
+ integer *, integer *, integer *, integer *, integer *, logical *,
+ integer *, real *, integer *, real *, integer *, real *, real *,
+ real *, integer *, real *, integer *, real *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int sckglm_(integer *, integer *, integer *,
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, real *, real *, real *, real *, real *, integer *, integer *,
+ integer *), serrbd_(char *, integer *), ilaver_(integer *,
+ integer *, integer *), schkhs_(integer *, integer *, integer *,
+ logical *, integer *, real *, integer *, real *, integer *, real *
+, real *, real *, real *, integer *, real *, real *, real *, real
+ *, real *, real *, real *, real *, real *, real *, real *, real *,
+ real *, integer *, integer *, logical *, real *, integer *),
+ scklse_(integer *, integer *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ real *, real *, real *, integer *, integer *, integer *), sdrvbd_(
+ integer *, integer *, integer *, integer *, logical *, integer *,
+ real *, real *, integer *, real *, integer *, real *, integer *,
+ real *, real *, real *, real *, real *, real *, real *, integer *,
+ integer *, integer *, integer *), serred_(char *, integer *), sdrges_(integer *, integer *, integer *, logical *,
+ integer *, real *, integer *, real *, integer *, real *, real *,
+ real *, real *, integer *, real *, real *, real *, real *, real *,
+ integer *, real *, logical *, integer *);
+ integer mxbval[20];
+ extern /* Subroutine */ int sckgqr_(integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, real *,
+ integer *, real *, real *, real *, real *, real *, real *, real *,
+ real *, real *, real *, real *, real *, real *, integer *,
+ integer *, integer *), sdrgev_(integer *, integer *, integer *,
+ logical *, integer *, real *, integer *, real *, integer *, real *
+, real *, real *, real *, integer *, real *, real *, integer *,
+ real *, real *, real *, real *, real *, real *, real *, integer *,
+ real *, integer *), sdrvgg_(integer *, integer *, integer *,
+ logical *, integer *, real *, real *, integer *, real *, integer *
+, real *, real *, real *, real *, real *, real *, integer *, real
+ *, real *, real *, real *, real *, real *, real *, real *, real *,
+ real *, integer *, real *, integer *);
+ logical tstdif;
+ real thresh;
+ extern /* Subroutine */ int schkst_(integer *, integer *, integer *,
+ logical *, integer *, real *, integer *, real *, integer *, real *
+, real *, real *, real *, real *, real *, real *, real *, real *,
+ real *, real *, real *, real *, integer *, real *, real *, real *,
+ real *, real *, integer *, integer *, integer *, real *, integer
+ *);
+ logical tstchk;
+ integer nparms, ishfts[20];
+ extern /* Subroutine */ int sckgsv_(integer *, integer *, integer *,
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, real *, real *, real *, real *, real *, real *, real *, real *,
+ integer *, real *, real *, integer *, integer *, integer *);
+ logical dotype[30], logwrk[132];
+ real thrshn;
+ extern /* Subroutine */ int sdrves_(integer *, integer *, integer *,
+ logical *, integer *, real *, integer *, real *, integer *, real *
+, real *, real *, real *, real *, real *, real *, integer *, real
+ *, real *, integer *, integer *, logical *, integer *), sdrvev_(
+ integer *, integer *, integer *, logical *, integer *, real *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ real *, real *, integer *, real *, integer *, real *, integer *,
+ real *, real *, integer *, integer *, integer *), sdrgsx_(integer
+ *, integer *, real *, integer *, integer *, real *, integer *,
+ real *, real *, real *, real *, real *, real *, real *, real *,
+ real *, integer *, real *, real *, integer *, integer *, integer *
+, logical *, integer *), sdrvsg_(integer *, integer *, integer *,
+ logical *, integer *, real *, integer *, real *, integer *, real *
+, integer *, real *, real *, integer *, real *, real *, real *,
+ real *, real *, integer *, integer *, integer *, real *, integer *
+), serrgg_(char *, integer *), sdrgvx_(integer *, real *,
+ integer *, integer *, real *, integer *, real *, real *, real *,
+ real *, real *, real *, real *, real *, integer *, integer *,
+ real *, real *, real *, real *, real *, real *, real *, integer *,
+ integer *, integer *, real *, logical *, integer *);
+ real result[500];
+ extern /* Subroutine */ int serrhs_(char *, integer *), xlaenv_(
+ integer *, integer *);
+ integer maxtyp;
+ logical tsterr;
+ integer ntypes;
+ logical tstdrv;
+ extern /* Subroutine */ int sdrvst_(integer *, integer *, integer *,
+ logical *, integer *, real *, integer *, real *, integer *, real *
+, real *, real *, real *, real *, real *, real *, real *, real *,
+ integer *, real *, real *, real *, real *, integer *, integer *,
+ integer *, real *, integer *), serrst_(char *, integer *),
+ sdrvsx_(integer *, integer *, integer *, logical *, integer *,
+ real *, integer *, integer *, real *, integer *, real *, real *,
+ real *, real *, real *, real *, real *, real *, real *, integer *,
+ real *, real *, real *, integer *, integer *, logical *, integer
+ *), sdrvvx_(integer *, integer *, integer *, logical *, integer *,
+ real *, integer *, integer *, real *, integer *, real *, real *,
+ real *, real *, real *, real *, integer *, real *, integer *,
+ real *, integer *, real *, real *, real *, real *, real *, real *,
+ real *, real *, real *, real *, integer *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___29 = { 0, 6, 0, fmt_9987, 0 };
+ static cilist io___30 = { 0, 6, 0, fmt_9986, 0 };
+ static cilist io___31 = { 0, 6, 0, fmt_9985, 0 };
+ static cilist io___32 = { 0, 6, 0, fmt_9979, 0 };
+ static cilist io___33 = { 0, 6, 0, fmt_9978, 0 };
+ static cilist io___34 = { 0, 6, 0, fmt_9977, 0 };
+ static cilist io___35 = { 0, 6, 0, fmt_9976, 0 };
+ static cilist io___36 = { 0, 6, 0, fmt_9975, 0 };
+ static cilist io___37 = { 0, 6, 0, fmt_9964, 0 };
+ static cilist io___38 = { 0, 6, 0, fmt_9965, 0 };
+ static cilist io___39 = { 0, 6, 0, fmt_9963, 0 };
+ static cilist io___40 = { 0, 6, 0, fmt_9962, 0 };
+ static cilist io___41 = { 0, 6, 0, fmt_9974, 0 };
+ static cilist io___42 = { 0, 6, 0, fmt_9967, 0 };
+ static cilist io___43 = { 0, 6, 0, fmt_9971, 0 };
+ static cilist io___44 = { 0, 6, 0, fmt_9970, 0 };
+ static cilist io___45 = { 0, 6, 0, fmt_9969, 0 };
+ static cilist io___46 = { 0, 6, 0, fmt_9968, 0 };
+ static cilist io___47 = { 0, 5, 0, 0, 0 };
+ static cilist io___50 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___54 = { 0, 6, 0, fmt_9972, 0 };
+ static cilist io___55 = { 0, 6, 0, fmt_9984, 0 };
+ static cilist io___56 = { 0, 5, 0, 0, 0 };
+ static cilist io___58 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___59 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___60 = { 0, 5, 0, 0, 0 };
+ static cilist io___64 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___65 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___66 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___67 = { 0, 5, 0, 0, 0 };
+ static cilist io___69 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___70 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___71 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___72 = { 0, 5, 0, 0, 0 };
+ static cilist io___74 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___75 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___76 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___77 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___78 = { 0, 5, 0, 0, 0 };
+ static cilist io___80 = { 0, 5, 0, 0, 0 };
+ static cilist io___82 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___83 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___84 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___85 = { 0, 5, 0, 0, 0 };
+ static cilist io___94 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___95 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___96 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___97 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___98 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___99 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___100 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___101 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___102 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___103 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___104 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___105 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___106 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___107 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___108 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___109 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___110 = { 0, 5, 0, 0, 0 };
+ static cilist io___113 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___114 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___115 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___116 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___117 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___118 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___119 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___120 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___121 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___122 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___123 = { 0, 5, 0, 0, 0 };
+ static cilist io___125 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___126 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___127 = { 0, 5, 0, 0, 0 };
+ static cilist io___128 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___129 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___130 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___131 = { 0, 5, 0, 0, 0 };
+ static cilist io___132 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___133 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___134 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___135 = { 0, 5, 0, 0, 0 };
+ static cilist io___136 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___137 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___138 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___139 = { 0, 5, 0, 0, 0 };
+ static cilist io___140 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___141 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___142 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___143 = { 0, 5, 0, 0, 0 };
+ static cilist io___144 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___145 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___146 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___147 = { 0, 5, 0, 0, 0 };
+ static cilist io___148 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___149 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___150 = { 0, 5, 0, 0, 0 };
+ static cilist io___151 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___152 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___153 = { 0, 5, 0, 0, 0 };
+ static cilist io___154 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___155 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___156 = { 0, 5, 0, 0, 0 };
+ static cilist io___157 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___158 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___159 = { 0, 5, 0, 0, 0 };
+ static cilist io___160 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___161 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___162 = { 0, 5, 0, 0, 0 };
+ static cilist io___164 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___165 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___166 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___167 = { 0, 6, 0, 0, 0 };
+ static cilist io___169 = { 0, 6, 0, fmt_9981, 0 };
+ static cilist io___170 = { 0, 6, 0, fmt_9981, 0 };
+ static cilist io___171 = { 0, 6, 0, fmt_9981, 0 };
+ static cilist io___172 = { 0, 5, 0, 0, 0 };
+ static cilist io___173 = { 0, 6, 0, fmt_9982, 0 };
+ static cilist io___174 = { 0, 5, 0, 0, 0 };
+ static cilist io___176 = { 0, 5, 0, 0, 0 };
+ static cilist io___178 = { 0, 5, 0, 0, 0 };
+ static cilist io___179 = { 0, 5, 0, 0, 0 };
+ static cilist io___181 = { 0, 5, 0, 0, 0 };
+ static cilist io___183 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___192 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___193 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___196 = { 0, 6, 0, fmt_9961, 0 };
+ static cilist io___204 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___205 = { 0, 6, 0, fmt_9997, 0 };
+ static cilist io___206 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___207 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___208 = { 0, 6, 0, fmt_9997, 0 };
+ static cilist io___209 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___211 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___212 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___213 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___214 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___215 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___216 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___217 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___218 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___219 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___220 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___221 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___222 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___223 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___224 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___225 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___228 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___229 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___230 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___231 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___232 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___233 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___235 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___236 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___237 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___238 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___239 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___240 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___241 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___242 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___243 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___244 = { 0, 6, 0, fmt_9966, 0 };
+ static cilist io___245 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___248 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___251 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___252 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___253 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___254 = { 0, 6, 0, 0, 0 };
+ static cilist io___255 = { 0, 6, 0, 0, 0 };
+ static cilist io___256 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___257 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___259 = { 0, 6, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2007 */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKEE tests the REAL LAPACK subroutines for the matrix */
+/* eigenvalue problem. The test paths in this version are */
+
+/* NEP (Nonsymmetric Eigenvalue Problem): */
+/* Test SGEHRD, SORGHR, SHSEQR, STREVC, SHSEIN, and SORMHR */
+
+/* SEP (Symmetric Eigenvalue Problem): */
+/* Test SSYTRD, SORGTR, SSTEQR, SSTERF, SSTEIN, SSTEDC, */
+/* and drivers SSYEV(X), SSBEV(X), SSPEV(X), SSTEV(X), */
+/* SSYEVD, SSBEVD, SSPEVD, SSTEVD */
+
+/* SVD (Singular Value Decomposition): */
+/* Test SGEBRD, SORGBR, SBDSQR, SBDSDC */
+/* and the drivers SGESVD, SGESDD */
+
+/* SEV (Nonsymmetric Eigenvalue/eigenvector Driver): */
+/* Test SGEEV */
+
+/* SES (Nonsymmetric Schur form Driver): */
+/* Test SGEES */
+
+/* SVX (Nonsymmetric Eigenvalue/eigenvector Expert Driver): */
+/* Test SGEEVX */
+
+/* SSX (Nonsymmetric Schur form Expert Driver): */
+/* Test SGEESX */
+
+/* SGG (Generalized Nonsymmetric Eigenvalue Problem): */
+/* Test SGGHRD, SGGBAL, SGGBAK, SHGEQZ, and STGEVC */
+/* and the driver routines SGEGS and SGEGV */
+
+/* SGS (Generalized Nonsymmetric Schur form Driver): */
+/* Test SGGES */
+
+/* SGV (Generalized Nonsymmetric Eigenvalue/eigenvector Driver): */
+/* Test SGGEV */
+
+/* SGX (Generalized Nonsymmetric Schur form Expert Driver): */
+/* Test SGGESX */
+
+/* SXV (Generalized Nonsymmetric Eigenvalue/eigenvector Expert Driver): */
+/* Test SGGEVX */
+
+/* SSG (Symmetric Generalized Eigenvalue Problem): */
+/* Test SSYGST, SSYGV, SSYGVD, SSYGVX, SSPGST, SSPGV, SSPGVD, */
+/* SSPGVX, SSBGST, SSBGV, SSBGVD, and SSBGVX */
+
+/* SSB (Symmetric Band Eigenvalue Problem): */
+/* Test SSBTRD */
+
+/* SBB (Band Singular Value Decomposition): */
+/* Test SGBBRD */
+
+/* SEC (Eigencondition estimation): */
+/* Test SLALN2, SLASY2, SLAEQU, SLAEXC, STRSYL, STREXC, STRSNA, */
+/* STRSEN, and SLAQTR */
+
+/* SBL (Balancing a general matrix) */
+/* Test SGEBAL */
+
+/* SBK (Back transformation on a balanced matrix) */
+/* Test SGEBAK */
+
+/* SGL (Balancing a matrix pair) */
+/* Test SGGBAL */
+
+/* SGK (Back transformation on a matrix pair) */
+/* Test SGGBAK */
+
+/* GLM (Generalized Linear Regression Model): */
+/* Tests SGGGLM */
+
+/* GQR (Generalized QR and RQ factorizations): */
+/* Tests SGGQRF and SGGRQF */
+
+/* GSV (Generalized Singular Value Decomposition): */
+/* Tests SGGSVD, SGGSVP, STGSJA, SLAGS2, SLAPLL, and SLAPMT */
+
+/* LSE (Constrained Linear Least Squares): */
+/* Tests SGGLSE */
+
+/* Each test path has a different set of inputs, but the data sets for */
+/* the driver routines xEV, xES, xVX, and xSX can be concatenated in a */
+/* single input file. The first line of input should contain one of the */
+/* 3-character path names in columns 1-3. The number of remaining lines */
+/* depends on what is found on the first line. */
+
+/* The number of matrix types used in testing is often controllable from */
+/* the input file. The number of matrix types for each path, and the */
+/* test routine that describes them, is as follows: */
+
+/* Path name(s) Types Test routine */
+
+/* SHS or NEP 21 SCHKHS */
+/* SST or SEP 21 SCHKST (routines) */
+/* 18 SDRVST (drivers) */
+/* SBD or SVD 16 SCHKBD (routines) */
+/* 5 SDRVBD (drivers) */
+/* SEV 21 SDRVEV */
+/* SES 21 SDRVES */
+/* SVX 21 SDRVVX */
+/* SSX 21 SDRVSX */
+/* SGG 26 SCHKGG (routines) */
+/* 26 SDRVGG (drivers) */
+/* SGS 26 SDRGES */
+/* SGX 5 SDRGSX */
+/* SGV 26 SDRGEV */
+/* SXV 2 SDRGVX */
+/* SSG 21 SDRVSG */
+/* SSB 15 SCHKSB */
+/* SBB 15 SCHKBB */
+/* SEC - SCHKEC */
+/* SBL - SCHKBL */
+/* SBK - SCHKBK */
+/* SGL - SCHKGL */
+/* SGK - SCHKGK */
+/* GLM 8 SCKGLM */
+/* GQR 8 SCKGQR */
+/* GSV 8 SCKGSV */
+/* LSE 8 SCKLSE */
+
+/* ----------------------------------------------------------------------- */
+
+/* NEP input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of N. */
+
+/* line 3: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix dimension N. */
+
+/* line 4: NPARMS, INTEGER */
+/* Number of values of the parameters NB, NBMIN, NX, NS, and */
+/* MAXB. */
+
+/* line 5: NBVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the blocksize NB. */
+
+/* line 6: NBMIN, INTEGER array, dimension (NPARMS) */
+/* The values for the minimum blocksize NBMIN. */
+
+/* line 7: NXVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the crossover point NX. */
+
+/* line 8: INMIN, INTEGER array, dimension (NPARMS) */
+/* LAHQR vs TTQRE crossover point, >= 11 */
+
+/* line 9: INWIN, INTEGER array, dimension (NPARMS) */
+/* recommended deflation window size */
+
+/* line 10: INIBL, INTEGER array, dimension (NPARMS) */
+/* nibble crossover point */
+
+/* line 11: ISHFTS, INTEGER array, dimension (NPARMS) */
+/* number of simultaneous shifts) */
+
+/* line 12: IACC22, INTEGER array, dimension (NPARMS) */
+/* select structured matrix multiply: 0, 1 or 2) */
+
+/* line 13: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. To have all of the test */
+/* ratios printed, use THRESH = 0.0 . */
+
+/* line 14: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 14 was 2: */
+
+/* line 15: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 15-EOF: The remaining lines occur in sets of 1 or 2 and allow */
+/* the user to specify the matrix types. Each line contains */
+/* a 3-character path name in columns 1-3, and the number */
+/* of matrix types must be the first nonblank item in columns */
+/* 4-80. If the number of matrix types is at least 1 but is */
+/* less than the maximum number of possible types, a second */
+/* line will be read to get the numbers of the matrix types to */
+/* be used. For example, */
+/* NEP 21 */
+/* requests all of the matrix types for the nonsymmetric */
+/* eigenvalue problem, while */
+/* NEP 4 */
+/* 9 10 11 12 */
+/* requests only matrices of type 9, 10, 11, and 12. */
+
+/* The valid 3-character path names are 'NEP' or 'SHS' for the */
+/* nonsymmetric eigenvalue routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* SEP or SSG input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of N. */
+
+/* line 3: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix dimension N. */
+
+/* line 4: NPARMS, INTEGER */
+/* Number of values of the parameters NB, NBMIN, and NX. */
+
+/* line 5: NBVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the blocksize NB. */
+
+/* line 6: NBMIN, INTEGER array, dimension (NPARMS) */
+/* The values for the minimum blocksize NBMIN. */
+
+/* line 7: NXVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the crossover point NX. */
+
+/* line 8: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 9: TSTCHK, LOGICAL */
+/* Flag indicating whether or not to test the LAPACK routines. */
+
+/* line 10: TSTDRV, LOGICAL */
+/* Flag indicating whether or not to test the driver routines. */
+
+/* line 11: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 12: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 12 was 2: */
+
+/* line 13: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 13-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path names are 'SEP' or 'SST' for the */
+/* symmetric eigenvalue routines and driver routines, and */
+/* 'SSG' for the routines for the symmetric generalized */
+/* eigenvalue problem. */
+
+/* ----------------------------------------------------------------------- */
+
+/* SVD input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M and N. */
+
+/* line 3: MVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix row dimension M. */
+
+/* line 4: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix column dimension N. */
+
+/* line 5: NPARMS, INTEGER */
+/* Number of values of the parameter NB, NBMIN, NX, and NRHS. */
+
+/* line 6: NBVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the blocksize NB. */
+
+/* line 7: NBMIN, INTEGER array, dimension (NPARMS) */
+/* The values for the minimum blocksize NBMIN. */
+
+/* line 8: NXVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the crossover point NX. */
+
+/* line 9: NSVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the number of right hand sides NRHS. */
+
+/* line 10: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 11: TSTCHK, LOGICAL */
+/* Flag indicating whether or not to test the LAPACK routines. */
+
+/* line 12: TSTDRV, LOGICAL */
+/* Flag indicating whether or not to test the driver routines. */
+
+/* line 13: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 14: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 14 was 2: */
+
+/* line 15: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 15-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path names are 'SVD' or 'SBD' for both the */
+/* SVD routines and the SVD driver routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* SEV and SES data files: */
+
+/* line 1: 'SEV' or 'SES' in columns 1 to 3. */
+
+/* line 2: NSIZES, INTEGER */
+/* Number of sizes of matrices to use. Should be at least 0 */
+/* and at most 20. If NSIZES = 0, no testing is done */
+/* (although the remaining 3 lines are still read). */
+
+/* line 3: NN, INTEGER array, dimension(NSIZES) */
+/* Dimensions of matrices to be tested. */
+
+/* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+/* These integer parameters determine how blocking is done */
+/* (see ILAENV for details) */
+/* NB : block size */
+/* NBMIN : minimum block size */
+/* NX : minimum dimension for blocking */
+/* NS : number of shifts in xHSEQR */
+/* NBCOL : minimum column dimension for blocking */
+
+/* line 5: THRESH, REAL */
+/* The test threshold against which computed residuals are */
+/* compared. Should generally be in the range from 10. to 20. */
+/* If it is 0., all test case data will be printed. */
+
+/* line 6: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits. */
+
+/* line 7: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 7 was 2: */
+
+/* line 8: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 9 and following: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'SEV' to test SGEEV, or */
+/* 'SES' to test SGEES. */
+
+/* ----------------------------------------------------------------------- */
+
+/* The SVX data has two parts. The first part is identical to SEV, */
+/* and the second part consists of test matrices with precomputed */
+/* solutions. */
+
+/* line 1: 'SVX' in columns 1-3. */
+
+/* line 2: NSIZES, INTEGER */
+/* If NSIZES = 0, no testing of randomly generated examples */
+/* is done, but any precomputed examples are tested. */
+
+/* line 3: NN, INTEGER array, dimension(NSIZES) */
+
+/* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+
+/* line 5: THRESH, REAL */
+
+/* line 6: TSTERR, LOGICAL */
+
+/* line 7: NEWSD, INTEGER */
+
+/* If line 7 was 2: */
+
+/* line 8: INTEGER array, dimension (4) */
+
+/* lines 9 and following: The first line contains 'SVX' in columns 1-3 */
+/* followed by the number of matrix types, possibly with */
+/* a second line to specify certain matrix types. */
+/* If the number of matrix types = 0, no testing of randomly */
+/* generated examples is done, but any precomputed examples */
+/* are tested. */
+
+/* remaining lines : Each matrix is stored on 1+2*N lines, where N is */
+/* its dimension. The first line contains the dimension (a */
+/* single integer). The next N lines contain the matrix, one */
+/* row per line. The last N lines correspond to each */
+/* eigenvalue. Each of these last N lines contains 4 real */
+/* values: the real part of the eigenvalue, the imaginary */
+/* part of the eigenvalue, the reciprocal condition number of */
+/* the eigenvalues, and the reciprocal condition number of the */
+/* eigenvector. The end of data is indicated by dimension N=0. */
+/* Even if no data is to be tested, there must be at least one */
+/* line containing N=0. */
+
+/* ----------------------------------------------------------------------- */
+
+/* The SSX data is like SVX. The first part is identical to SEV, and the */
+/* second part consists of test matrices with precomputed solutions. */
+
+/* line 1: 'SSX' in columns 1-3. */
+
+/* line 2: NSIZES, INTEGER */
+/* If NSIZES = 0, no testing of randomly generated examples */
+/* is done, but any precomputed examples are tested. */
+
+/* line 3: NN, INTEGER array, dimension(NSIZES) */
+
+/* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+
+/* line 5: THRESH, REAL */
+
+/* line 6: TSTERR, LOGICAL */
+
+/* line 7: NEWSD, INTEGER */
+
+/* If line 7 was 2: */
+
+/* line 8: INTEGER array, dimension (4) */
+
+/* lines 9 and following: The first line contains 'SSX' in columns 1-3 */
+/* followed by the number of matrix types, possibly with */
+/* a second line to specify certain matrix types. */
+/* If the number of matrix types = 0, no testing of randomly */
+/* generated examples is done, but any precomputed examples */
+/* are tested. */
+
+/* remaining lines : Each matrix is stored on 3+N lines, where N is its */
+/* dimension. The first line contains the dimension N and the */
+/* dimension M of an invariant subspace. The second line */
+/* contains M integers, identifying the eigenvalues in the */
+/* invariant subspace (by their position in a list of */
+/* eigenvalues ordered by increasing real part). The next N */
+/* lines contain the matrix. The last line contains the */
+/* reciprocal condition number for the average of the selected */
+/* eigenvalues, and the reciprocal condition number for the */
+/* corresponding right invariant subspace. The end of data is */
+/* indicated by a line containing N=0 and M=0. Even if no data */
+/* is to be tested, there must be at least one line containing */
+/* N=0 and M=0. */
+
+/* ----------------------------------------------------------------------- */
+
+/* SGG input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of N. */
+
+/* line 3: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix dimension N. */
+
+/* line 4: NPARMS, INTEGER */
+/* Number of values of the parameters NB, NBMIN, NS, MAXB, and */
+/* NBCOL. */
+
+/* line 5: NBVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the blocksize NB. */
+
+/* line 6: NBMIN, INTEGER array, dimension (NPARMS) */
+/* The values for NBMIN, the minimum row dimension for blocks. */
+
+/* line 7: NSVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the number of shifts. */
+
+/* line 8: MXBVAL, INTEGER array, dimension (NPARMS) */
+/* The values for MAXB, used in determining minimum blocksize. */
+
+/* line 9: NBCOL, INTEGER array, dimension (NPARMS) */
+/* The values for NBCOL, the minimum column dimension for */
+/* blocks. */
+
+/* line 10: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 11: TSTCHK, LOGICAL */
+/* Flag indicating whether or not to test the LAPACK routines. */
+
+/* line 12: TSTDRV, LOGICAL */
+/* Flag indicating whether or not to test the driver routines. */
+
+/* line 13: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 14: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 14 was 2: */
+
+/* line 15: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 15-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'SGG' for the generalized */
+/* eigenvalue problem routines and driver routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* SGS and SGV input files: */
+
+/* line 1: 'SGS' or 'SGV' in columns 1 to 3. */
+
+/* line 2: NN, INTEGER */
+/* Number of values of N. */
+
+/* line 3: NVAL, INTEGER array, dimension(NN) */
+/* Dimensions of matrices to be tested. */
+
+/* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+/* These integer parameters determine how blocking is done */
+/* (see ILAENV for details) */
+/* NB : block size */
+/* NBMIN : minimum block size */
+/* NX : minimum dimension for blocking */
+/* NS : number of shifts in xHGEQR */
+/* NBCOL : minimum column dimension for blocking */
+
+/* line 5: THRESH, REAL */
+/* The test threshold against which computed residuals are */
+/* compared. Should generally be in the range from 10. to 20. */
+/* If it is 0., all test case data will be printed. */
+
+/* line 6: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits. */
+
+/* line 7: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 17 was 2: */
+
+/* line 7: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 7-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'SGS' for the generalized */
+/* eigenvalue problem routines and driver routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* SXV input files: */
+
+/* line 1: 'SXV' in columns 1 to 3. */
+
+/* line 2: N, INTEGER */
+/* Value of N. */
+
+/* line 3: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+/* These integer parameters determine how blocking is done */
+/* (see ILAENV for details) */
+/* NB : block size */
+/* NBMIN : minimum block size */
+/* NX : minimum dimension for blocking */
+/* NS : number of shifts in xHGEQR */
+/* NBCOL : minimum column dimension for blocking */
+
+/* line 4: THRESH, REAL */
+/* The test threshold against which computed residuals are */
+/* compared. Should generally be in the range from 10. to 20. */
+/* Information will be printed about each test for which the */
+/* test ratio is greater than or equal to the threshold. */
+
+/* line 5: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 6: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 6 was 2: */
+
+/* line 7: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* If line 2 was 0: */
+
+/* line 7-EOF: Precomputed examples are tested. */
+
+/* remaining lines : Each example is stored on 3+2*N lines, where N is */
+/* its dimension. The first line contains the dimension (a */
+/* single integer). The next N lines contain the matrix A, one */
+/* row per line. The next N lines contain the matrix B. The */
+/* next line contains the reciprocals of the eigenvalue */
+/* condition numbers. The last line contains the reciprocals of */
+/* the eigenvector condition numbers. The end of data is */
+/* indicated by dimension N=0. Even if no data is to be tested, */
+/* there must be at least one line containing N=0. */
+
+/* ----------------------------------------------------------------------- */
+
+/* SGX input files: */
+
+/* line 1: 'SGX' in columns 1 to 3. */
+
+/* line 2: N, INTEGER */
+/* Value of N. */
+
+/* line 3: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+/* These integer parameters determine how blocking is done */
+/* (see ILAENV for details) */
+/* NB : block size */
+/* NBMIN : minimum block size */
+/* NX : minimum dimension for blocking */
+/* NS : number of shifts in xHGEQR */
+/* NBCOL : minimum column dimension for blocking */
+
+/* line 4: THRESH, REAL */
+/* The test threshold against which computed residuals are */
+/* compared. Should generally be in the range from 10. to 20. */
+/* Information will be printed about each test for which the */
+/* test ratio is greater than or equal to the threshold. */
+
+/* line 5: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 6: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 6 was 2: */
+
+/* line 7: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* If line 2 was 0: */
+
+/* line 7-EOF: Precomputed examples are tested. */
+
+/* remaining lines : Each example is stored on 3+2*N lines, where N is */
+/* its dimension. The first line contains the dimension (a */
+/* single integer). The next line contains an integer k such */
+/* that only the last k eigenvalues will be selected and appear */
+/* in the leading diagonal blocks of $A$ and $B$. The next N */
+/* lines contain the matrix A, one row per line. The next N */
+/* lines contain the matrix B. The last line contains the */
+/* reciprocal of the eigenvalue cluster condition number and the */
+/* reciprocal of the deflating subspace (associated with the */
+/* selected eigencluster) condition number. The end of data is */
+/* indicated by dimension N=0. Even if no data is to be tested, */
+/* there must be at least one line containing N=0. */
+
+/* ----------------------------------------------------------------------- */
+
+/* SSB input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of N. */
+
+/* line 3: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix dimension N. */
+
+/* line 4: NK, INTEGER */
+/* Number of values of K. */
+
+/* line 5: KVAL, INTEGER array, dimension (NK) */
+/* The values for the matrix dimension K. */
+
+/* line 6: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 7: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 7 was 2: */
+
+/* line 8: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 8-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'SSB'. */
+
+/* ----------------------------------------------------------------------- */
+
+/* SBB input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M and N. */
+
+/* line 3: MVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix row dimension M. */
+
+/* line 4: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix column dimension N. */
+
+/* line 4: NK, INTEGER */
+/* Number of values of K. */
+
+/* line 5: KVAL, INTEGER array, dimension (NK) */
+/* The values for the matrix bandwidth K. */
+
+/* line 6: NPARMS, INTEGER */
+/* Number of values of the parameter NRHS */
+
+/* line 7: NSVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the number of right hand sides NRHS. */
+
+/* line 8: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 9: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 9 was 2: */
+
+/* line 10: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 10-EOF: Lines specifying matrix types, as for SVD. */
+/* The 3-character path name is 'SBB'. */
+
+/* ----------------------------------------------------------------------- */
+
+/* SEC input file: */
+
+/* line 2: THRESH, REAL */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* lines 3-EOF: */
+
+/* Input for testing the eigencondition routines consists of a set of */
+/* specially constructed test cases and their solutions. The data */
+/* format is not intended to be modified by the user. */
+
+/* ----------------------------------------------------------------------- */
+
+/* SBL and SBK input files: */
+
+/* line 1: 'SBL' in columns 1-3 to test SGEBAL, or 'SBK' in */
+/* columns 1-3 to test SGEBAK. */
+
+/* The remaining lines consist of specially constructed test cases. */
+
+/* ----------------------------------------------------------------------- */
+
+/* SGL and SGK input files: */
+
+/* line 1: 'SGL' in columns 1-3 to test SGGBAL, or 'SGK' in */
+/* columns 1-3 to test SGGBAK. */
+
+/* The remaining lines consist of specially constructed test cases. */
+
+/* ----------------------------------------------------------------------- */
+
+/* GLM data file: */
+
+/* line 1: 'GLM' in columns 1 to 3. */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M, P, and N. */
+
+/* line 3: MVAL, INTEGER array, dimension(NN) */
+/* Values of M (row dimension). */
+
+/* line 4: PVAL, INTEGER array, dimension(NN) */
+/* Values of P (row dimension). */
+
+/* line 5: NVAL, INTEGER array, dimension(NN) */
+/* Values of N (column dimension), note M <= N <= M+P. */
+
+/* line 6: THRESH, REAL */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 7: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 8: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 8 was 2: */
+
+/* line 9: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 9-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'GLM' for the generalized */
+/* linear regression model routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* GQR data file: */
+
+/* line 1: 'GQR' in columns 1 to 3. */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M, P, and N. */
+
+/* line 3: MVAL, INTEGER array, dimension(NN) */
+/* Values of M. */
+
+/* line 4: PVAL, INTEGER array, dimension(NN) */
+/* Values of P. */
+
+/* line 5: NVAL, INTEGER array, dimension(NN) */
+/* Values of N. */
+
+/* line 6: THRESH, REAL */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 7: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 8: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 8 was 2: */
+
+/* line 9: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 9-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'GQR' for the generalized */
+/* QR and RQ routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* GSV data file: */
+
+/* line 1: 'GSV' in columns 1 to 3. */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M, P, and N. */
+
+/* line 3: MVAL, INTEGER array, dimension(NN) */
+/* Values of M (row dimension). */
+
+/* line 4: PVAL, INTEGER array, dimension(NN) */
+/* Values of P (row dimension). */
+
+/* line 5: NVAL, INTEGER array, dimension(NN) */
+/* Values of N (column dimension). */
+
+/* line 6: THRESH, REAL */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 7: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 8: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 8 was 2: */
+
+/* line 9: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 9-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'GSV' for the generalized */
+/* SVD routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* LSE data file: */
+
+/* line 1: 'LSE' in columns 1 to 3. */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M, P, and N. */
+
+/* line 3: MVAL, INTEGER array, dimension(NN) */
+/* Values of M. */
+
+/* line 4: PVAL, INTEGER array, dimension(NN) */
+/* Values of P. */
+
+/* line 5: NVAL, INTEGER array, dimension(NN) */
+/* Values of N, note P <= N <= P+M. */
+
+/* line 6: THRESH, REAL */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 7: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 8: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 8 was 2: */
+
+/* line 9: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 9-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'GSV' for the generalized */
+/* SVD routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* NMAX is currently set to 132 and must be at least 12 for some of the */
+/* precomputed examples, and LWORK = NMAX*(5*NMAX+5)+1 in the parameter */
+/* statements below. For SVD, we assume NRHS may be as big as N. The */
+/* parameter NEED is set to 14 to allow for 14 N-by-N matrices for SGG. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ s1 = second_();
+ fatal = FALSE_;
+ infoc_1.nunit = 6;
+
+/* Return to here to read multiple sets of data */
+
+L10:
+
+/* Read the first line and set the 3-character test path */
+
+ ci__1.cierr = 0;
+ ci__1.ciend = 1;
+ ci__1.ciunit = 5;
+ ci__1.cifmt = "(A80)";
+ i__1 = s_rsfe(&ci__1);
+ if (i__1 != 0) {
+ goto L380;
+ }
+ i__1 = do_fio(&c__1, line, (ftnlen)80);
+ if (i__1 != 0) {
+ goto L380;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L380;
+ }
+ s_copy(path, line, (ftnlen)3, (ftnlen)3);
+ nep = lsamen_(&c__3, path, "NEP") || lsamen_(&c__3,
+ path, "SHS");
+ sep = lsamen_(&c__3, path, "SEP") || lsamen_(&c__3,
+ path, "SST") || lsamen_(&c__3, path, "SSG");
+ svd = lsamen_(&c__3, path, "SVD") || lsamen_(&c__3,
+ path, "SBD");
+ sev = lsamen_(&c__3, path, "SEV");
+ ses = lsamen_(&c__3, path, "SES");
+ svx = lsamen_(&c__3, path, "SVX");
+ ssx = lsamen_(&c__3, path, "SSX");
+ sgg = lsamen_(&c__3, path, "SGG");
+ sgs = lsamen_(&c__3, path, "SGS");
+ sgx = lsamen_(&c__3, path, "SGX");
+ sgv = lsamen_(&c__3, path, "SGV");
+ sxv = lsamen_(&c__3, path, "SXV");
+ ssb = lsamen_(&c__3, path, "SSB");
+ sbb = lsamen_(&c__3, path, "SBB");
+ glm = lsamen_(&c__3, path, "GLM");
+ gqr = lsamen_(&c__3, path, "GQR") || lsamen_(&c__3,
+ path, "GRQ");
+ gsv = lsamen_(&c__3, path, "GSV");
+ lse = lsamen_(&c__3, path, "LSE");
+ sbl = lsamen_(&c__3, path, "SBL");
+ sbk = lsamen_(&c__3, path, "SBK");
+ sgl = lsamen_(&c__3, path, "SGL");
+ sgk = lsamen_(&c__3, path, "SGK");
+
+/* Report values of parameters. */
+
+ if (s_cmp(path, " ", (ftnlen)3, (ftnlen)3) == 0) {
+ goto L10;
+ } else if (nep) {
+ s_wsfe(&io___29);
+ e_wsfe();
+ } else if (sep) {
+ s_wsfe(&io___30);
+ e_wsfe();
+ } else if (svd) {
+ s_wsfe(&io___31);
+ e_wsfe();
+ } else if (sev) {
+ s_wsfe(&io___32);
+ e_wsfe();
+ } else if (ses) {
+ s_wsfe(&io___33);
+ e_wsfe();
+ } else if (svx) {
+ s_wsfe(&io___34);
+ e_wsfe();
+ } else if (ssx) {
+ s_wsfe(&io___35);
+ e_wsfe();
+ } else if (sgg) {
+ s_wsfe(&io___36);
+ e_wsfe();
+ } else if (sgs) {
+ s_wsfe(&io___37);
+ e_wsfe();
+ } else if (sgx) {
+ s_wsfe(&io___38);
+ e_wsfe();
+ } else if (sgv) {
+ s_wsfe(&io___39);
+ e_wsfe();
+ } else if (sxv) {
+ s_wsfe(&io___40);
+ e_wsfe();
+ } else if (ssb) {
+ s_wsfe(&io___41);
+ e_wsfe();
+ } else if (sbb) {
+ s_wsfe(&io___42);
+ e_wsfe();
+ } else if (glm) {
+ s_wsfe(&io___43);
+ e_wsfe();
+ } else if (gqr) {
+ s_wsfe(&io___44);
+ e_wsfe();
+ } else if (gsv) {
+ s_wsfe(&io___45);
+ e_wsfe();
+ } else if (lse) {
+ s_wsfe(&io___46);
+ e_wsfe();
+ } else if (sbl) {
+
+/* SGEBAL: Balancing */
+
+ schkbl_(&c__5, &c__6);
+ goto L10;
+ } else if (sbk) {
+
+/* SGEBAK: Back transformation */
+
+ schkbk_(&c__5, &c__6);
+ goto L10;
+ } else if (sgl) {
+
+/* SGGBAL: Balancing */
+
+ schkgl_(&c__5, &c__6);
+ goto L10;
+ } else if (sgk) {
+
+/* SGGBAK: Back transformation */
+
+ schkgk_(&c__5, &c__6);
+ goto L10;
+ } else if (lsamen_(&c__3, path, "SEC")) {
+
+/* SEC: Eigencondition estimation */
+
+ s_rsle(&io___47);
+ do_lio(&c__4, &c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_rsle();
+ xlaenv_(&c__1, &c__1);
+ xlaenv_(&c__12, &c__11);
+ xlaenv_(&c__13, &c__2);
+ xlaenv_(&c__14, &c__0);
+ xlaenv_(&c__15, &c__2);
+ xlaenv_(&c__16, &c__2);
+ tsterr = TRUE_;
+ schkec_(&thresh, &tsterr, &c__5, &c__6);
+ goto L10;
+ } else {
+ s_wsfe(&io___50);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ goto L10;
+ }
+ ilaver_(&vers_major__, &vers_minor__, &vers_patch__);
+ s_wsfe(&io___54);
+ do_fio(&c__1, (char *)&vers_major__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_minor__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_patch__, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___55);
+ e_wsfe();
+
+/* Read the number of values of M, P, and N. */
+
+ s_rsle(&io___56);
+ do_lio(&c__3, &c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nn < 0) {
+ s_wsfe(&io___58);
+ do_fio(&c__1, " NN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ } else if (nn > 20) {
+ s_wsfe(&io___59);
+ do_fio(&c__1, " NN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__20, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ }
+
+/* Read the values of M */
+
+ if (! (sgx || sxv)) {
+ s_rsle(&io___60);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ if (svd) {
+ s_copy(vname, " M ", (ftnlen)32, (ftnlen)6);
+ } else {
+ s_copy(vname, " N ", (ftnlen)32, (ftnlen)6);
+ }
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (mval[i__ - 1] < 0) {
+ s_wsfe(&io___64);
+ do_fio(&c__1, vname, (ftnlen)32);
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (mval[i__ - 1] > 132) {
+ s_wsfe(&io___65);
+ do_fio(&c__1, vname, (ftnlen)32);
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L20: */
+ }
+ s_wsfe(&io___66);
+ do_fio(&c__1, "M: ", (ftnlen)6);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of P */
+
+ if (glm || gqr || gsv || lse) {
+ s_rsle(&io___67);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&pval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (pval[i__ - 1] < 0) {
+ s_wsfe(&io___69);
+ do_fio(&c__1, " P ", (ftnlen)4);
+ do_fio(&c__1, (char *)&pval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (pval[i__ - 1] > 132) {
+ s_wsfe(&io___70);
+ do_fio(&c__1, " P ", (ftnlen)4);
+ do_fio(&c__1, (char *)&pval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L30: */
+ }
+ s_wsfe(&io___71);
+ do_fio(&c__1, "P: ", (ftnlen)6);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&pval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of N */
+
+ if (svd || sbb || glm || gqr || gsv || lse) {
+ s_rsle(&io___72);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nval[i__ - 1] < 0) {
+ s_wsfe(&io___74);
+ do_fio(&c__1, " N ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nval[i__ - 1] > 132) {
+ s_wsfe(&io___75);
+ do_fio(&c__1, " N ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L40: */
+ }
+ } else {
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nval[i__ - 1] = mval[i__ - 1];
+/* L50: */
+ }
+ }
+ if (! (sgx || sxv)) {
+ s_wsfe(&io___76);
+ do_fio(&c__1, "N: ", (ftnlen)6);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ } else {
+ s_wsfe(&io___77);
+ do_fio(&c__1, "N: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Read the number of values of K, followed by the values of K */
+
+ if (ssb || sbb) {
+ s_rsle(&io___78);
+ do_lio(&c__3, &c__1, (char *)&nk, (ftnlen)sizeof(integer));
+ e_rsle();
+ s_rsle(&io___80);
+ i__1 = nk;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&kval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nk;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (kval[i__ - 1] < 0) {
+ s_wsfe(&io___82);
+ do_fio(&c__1, " K ", (ftnlen)6);
+ do_fio(&c__1, (char *)&kval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (kval[i__ - 1] > 132) {
+ s_wsfe(&io___83);
+ do_fio(&c__1, " K ", (ftnlen)6);
+ do_fio(&c__1, (char *)&kval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L60: */
+ }
+ s_wsfe(&io___84);
+ do_fio(&c__1, "K: ", (ftnlen)6);
+ i__1 = nk;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&kval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+ if (sev || ses || svx || ssx) {
+
+/* For the nonsymmetric QR driver routines, only one set of */
+/* parameters is allowed. */
+
+ s_rsle(&io___85);
+ do_lio(&c__3, &c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&inmin[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&inwin[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&inibl[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ishfts[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&iacc22[0], (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nbval[0] < 1) {
+ s_wsfe(&io___94);
+ do_fio(&c__1, " NB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nbmin[0] < 1) {
+ s_wsfe(&io___95);
+ do_fio(&c__1, "NBMIN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nxval[0] < 1) {
+ s_wsfe(&io___96);
+ do_fio(&c__1, " NX ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (inmin[0] < 1) {
+ s_wsfe(&io___97);
+ do_fio(&c__1, " INMIN ", (ftnlen)9);
+ do_fio(&c__1, (char *)&inmin[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (inwin[0] < 1) {
+ s_wsfe(&io___98);
+ do_fio(&c__1, " INWIN ", (ftnlen)9);
+ do_fio(&c__1, (char *)&inwin[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (inibl[0] < 1) {
+ s_wsfe(&io___99);
+ do_fio(&c__1, " INIBL ", (ftnlen)9);
+ do_fio(&c__1, (char *)&inibl[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (ishfts[0] < 1) {
+ s_wsfe(&io___100);
+ do_fio(&c__1, " ISHFTS ", (ftnlen)10);
+ do_fio(&c__1, (char *)&ishfts[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (iacc22[0] < 0) {
+ s_wsfe(&io___101);
+ do_fio(&c__1, " IACC22 ", (ftnlen)10);
+ do_fio(&c__1, (char *)&iacc22[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+ xlaenv_(&c__1, nbval);
+ xlaenv_(&c__2, nbmin);
+ xlaenv_(&c__3, nxval);
+ i__1 = max(11,inmin[0]);
+ xlaenv_(&c__12, &i__1);
+ xlaenv_(&c__13, inwin);
+ xlaenv_(&c__14, inibl);
+ xlaenv_(&c__15, ishfts);
+ xlaenv_(&c__16, iacc22);
+ s_wsfe(&io___102);
+ do_fio(&c__1, "NB: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___103);
+ do_fio(&c__1, "NBMIN:", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___104);
+ do_fio(&c__1, "NX: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___105);
+ do_fio(&c__1, "INMIN: ", (ftnlen)9);
+ do_fio(&c__1, (char *)&inmin[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___106);
+ do_fio(&c__1, "INWIN: ", (ftnlen)7);
+ do_fio(&c__1, (char *)&inwin[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___107);
+ do_fio(&c__1, "INIBL: ", (ftnlen)7);
+ do_fio(&c__1, (char *)&inibl[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___108);
+ do_fio(&c__1, "ISHFTS: ", (ftnlen)8);
+ do_fio(&c__1, (char *)&ishfts[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___109);
+ do_fio(&c__1, "IACC22: ", (ftnlen)8);
+ do_fio(&c__1, (char *)&iacc22[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ } else if (sgs || sgx || sgv || sxv) {
+
+/* For the nonsymmetric generalized driver routines, only one set */
+/* of parameters is allowed. */
+
+ s_rsle(&io___110);
+ do_lio(&c__3, &c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&nsval[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&mxbval[0], (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nbval[0] < 1) {
+ s_wsfe(&io___113);
+ do_fio(&c__1, " NB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nbmin[0] < 1) {
+ s_wsfe(&io___114);
+ do_fio(&c__1, "NBMIN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nxval[0] < 1) {
+ s_wsfe(&io___115);
+ do_fio(&c__1, " NX ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nsval[0] < 2) {
+ s_wsfe(&io___116);
+ do_fio(&c__1, " NS ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nsval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (mxbval[0] < 1) {
+ s_wsfe(&io___117);
+ do_fio(&c__1, " MAXB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&mxbval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+ xlaenv_(&c__1, nbval);
+ xlaenv_(&c__2, nbmin);
+ xlaenv_(&c__3, nxval);
+ xlaenv_(&c__4, nsval);
+ xlaenv_(&c__8, mxbval);
+ s_wsfe(&io___118);
+ do_fio(&c__1, "NB: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___119);
+ do_fio(&c__1, "NBMIN:", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___120);
+ do_fio(&c__1, "NX: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___121);
+ do_fio(&c__1, "NS: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nsval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___122);
+ do_fio(&c__1, "MAXB: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&mxbval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ } else if (! ssb && ! glm && ! gqr && ! gsv && ! lse) {
+
+/* For the other paths, the number of parameters can be varied */
+/* from the input file. Read the number of parameter values. */
+
+ s_rsle(&io___123);
+ do_lio(&c__3, &c__1, (char *)&nparms, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nparms < 1) {
+ s_wsfe(&io___125);
+ do_fio(&c__1, "NPARMS", (ftnlen)6);
+ do_fio(&c__1, (char *)&nparms, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nparms = 0;
+ fatal = TRUE_;
+ } else if (nparms > 20) {
+ s_wsfe(&io___126);
+ do_fio(&c__1, "NPARMS", (ftnlen)6);
+ do_fio(&c__1, (char *)&nparms, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__20, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nparms = 0;
+ fatal = TRUE_;
+ }
+
+/* Read the values of NB */
+
+ if (! sbb) {
+ s_rsle(&io___127);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nbval[i__ - 1] < 0) {
+ s_wsfe(&io___128);
+ do_fio(&c__1, " NB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nbval[i__ - 1] > 132) {
+ s_wsfe(&io___129);
+ do_fio(&c__1, " NB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L70: */
+ }
+ s_wsfe(&io___130);
+ do_fio(&c__1, "NB: ", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ }
+
+/* Read the values of NBMIN */
+
+ if (nep || sep || svd || sgg) {
+ s_rsle(&io___131);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nbmin[i__ - 1] < 0) {
+ s_wsfe(&io___132);
+ do_fio(&c__1, "NBMIN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nbmin[i__ - 1] > 132) {
+ s_wsfe(&io___133);
+ do_fio(&c__1, "NBMIN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L80: */
+ }
+ s_wsfe(&io___134);
+ do_fio(&c__1, "NBMIN:", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nbmin[i__ - 1] = 1;
+/* L90: */
+ }
+ }
+
+/* Read the values of NX */
+
+ if (nep || sep || svd) {
+ s_rsle(&io___135);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nxval[i__ - 1] < 0) {
+ s_wsfe(&io___136);
+ do_fio(&c__1, " NX ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nxval[i__ - 1] > 132) {
+ s_wsfe(&io___137);
+ do_fio(&c__1, " NX ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L100: */
+ }
+ s_wsfe(&io___138);
+ do_fio(&c__1, "NX: ", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nxval[i__ - 1] = 1;
+/* L110: */
+ }
+ }
+
+/* Read the values of NSHIFT (if SGG) or NRHS (if SVD */
+/* or SBB). */
+
+ if (svd || sbb || sgg) {
+ s_rsle(&io___139);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nsval[i__ - 1] < 0) {
+ s_wsfe(&io___140);
+ do_fio(&c__1, " NS ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nsval[i__ - 1] > 132) {
+ s_wsfe(&io___141);
+ do_fio(&c__1, " NS ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L120: */
+ }
+ s_wsfe(&io___142);
+ do_fio(&c__1, "NS: ", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nsval[i__ - 1] = 1;
+/* L130: */
+ }
+ }
+
+/* Read the values for MAXB. */
+
+ if (sgg) {
+ s_rsle(&io___143);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (mxbval[i__ - 1] < 0) {
+ s_wsfe(&io___144);
+ do_fio(&c__1, " MAXB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (mxbval[i__ - 1] > 132) {
+ s_wsfe(&io___145);
+ do_fio(&c__1, " MAXB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L140: */
+ }
+ s_wsfe(&io___146);
+ do_fio(&c__1, "MAXB: ", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ mxbval[i__ - 1] = 1;
+/* L150: */
+ }
+ }
+
+/* Read the values for INMIN. */
+
+ if (nep) {
+ s_rsle(&io___147);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&inmin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (inmin[i__ - 1] < 0) {
+ s_wsfe(&io___148);
+ do_fio(&c__1, " INMIN ", (ftnlen)7);
+ do_fio(&c__1, (char *)&inmin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L540: */
+ }
+ s_wsfe(&io___149);
+ do_fio(&c__1, "INMIN: ", (ftnlen)7);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&inmin[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ inmin[i__ - 1] = 1;
+/* L550: */
+ }
+ }
+
+/* Read the values for INWIN. */
+
+ if (nep) {
+ s_rsle(&io___150);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&inwin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (inwin[i__ - 1] < 0) {
+ s_wsfe(&io___151);
+ do_fio(&c__1, " INWIN ", (ftnlen)7);
+ do_fio(&c__1, (char *)&inwin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L560: */
+ }
+ s_wsfe(&io___152);
+ do_fio(&c__1, "INWIN: ", (ftnlen)7);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&inwin[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ inwin[i__ - 1] = 1;
+/* L570: */
+ }
+ }
+
+/* Read the values for INIBL. */
+
+ if (nep) {
+ s_rsle(&io___153);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&inibl[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (inibl[i__ - 1] < 0) {
+ s_wsfe(&io___154);
+ do_fio(&c__1, " INIBL ", (ftnlen)7);
+ do_fio(&c__1, (char *)&inibl[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L580: */
+ }
+ s_wsfe(&io___155);
+ do_fio(&c__1, "INIBL: ", (ftnlen)7);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&inibl[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ inibl[i__ - 1] = 1;
+/* L590: */
+ }
+ }
+
+/* Read the values for ISHFTS. */
+
+ if (nep) {
+ s_rsle(&io___156);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&ishfts[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (ishfts[i__ - 1] < 0) {
+ s_wsfe(&io___157);
+ do_fio(&c__1, " ISHFTS ", (ftnlen)8);
+ do_fio(&c__1, (char *)&ishfts[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L600: */
+ }
+ s_wsfe(&io___158);
+ do_fio(&c__1, "ISHFTS: ", (ftnlen)8);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&ishfts[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ishfts[i__ - 1] = 1;
+/* L610: */
+ }
+ }
+
+/* Read the values for IACC22. */
+
+ if (nep) {
+ s_rsle(&io___159);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&iacc22[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (iacc22[i__ - 1] < 0) {
+ s_wsfe(&io___160);
+ do_fio(&c__1, " IACC22 ", (ftnlen)8);
+ do_fio(&c__1, (char *)&iacc22[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L620: */
+ }
+ s_wsfe(&io___161);
+ do_fio(&c__1, "IACC22: ", (ftnlen)8);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&iacc22[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ iacc22[i__ - 1] = 1;
+/* L630: */
+ }
+ }
+
+/* Read the values for NBCOL. */
+
+ if (sgg) {
+ s_rsle(&io___162);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nbcol[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nbcol[i__ - 1] < 0) {
+ s_wsfe(&io___164);
+ do_fio(&c__1, "NBCOL ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbcol[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nbcol[i__ - 1] > 132) {
+ s_wsfe(&io___165);
+ do_fio(&c__1, "NBCOL ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbcol[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L160: */
+ }
+ s_wsfe(&io___166);
+ do_fio(&c__1, "NBCOL:", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nbcol[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nbcol[i__ - 1] = 1;
+/* L170: */
+ }
+ }
+ }
+
+/* Calculate and print the machine dependent constants. */
+
+ s_wsle(&io___167);
+ e_wsle();
+ eps = slamch_("Underflow threshold");
+ s_wsfe(&io___169);
+ do_fio(&c__1, "underflow", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+ eps = slamch_("Overflow threshold");
+ s_wsfe(&io___170);
+ do_fio(&c__1, "overflow ", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+ eps = slamch_("Epsilon");
+ s_wsfe(&io___171);
+ do_fio(&c__1, "precision", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+
+/* Read the threshold value for the test ratios. */
+
+ s_rsle(&io___172);
+ do_lio(&c__4, &c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_rsle();
+ s_wsfe(&io___173);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_wsfe();
+ if (sep || svd || sgg) {
+
+/* Read the flag that indicates whether to test LAPACK routines. */
+
+ s_rsle(&io___174);
+ do_lio(&c__8, &c__1, (char *)&tstchk, (ftnlen)sizeof(logical));
+ e_rsle();
+
+/* Read the flag that indicates whether to test driver routines. */
+
+ s_rsle(&io___176);
+ do_lio(&c__8, &c__1, (char *)&tstdrv, (ftnlen)sizeof(logical));
+ e_rsle();
+ }
+
+/* Read the flag that indicates whether to test the error exits. */
+
+ s_rsle(&io___178);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+
+/* Read the code describing how to set the random number seed. */
+
+ s_rsle(&io___179);
+ do_lio(&c__3, &c__1, (char *)&newsd, (ftnlen)sizeof(integer));
+ e_rsle();
+
+/* If NEWSD = 2, read another line with 4 integers for the seed. */
+
+ if (newsd == 2) {
+ s_rsle(&io___181);
+ for (i__ = 1; i__ <= 4; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&ioldsd[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ }
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = ioldsd[i__ - 1];
+/* L180: */
+ }
+
+ if (fatal) {
+ s_wsfe(&io___183);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Read the input lines indicating the test path and its parameters. */
+/* The first three characters indicate the test path, and the number */
+/* of test matrix types must be the first nonblank item in columns */
+/* 4-80. */
+
+L190:
+
+ if (! (sgx || sxv)) {
+
+L200:
+ ci__1.cierr = 0;
+ ci__1.ciend = 1;
+ ci__1.ciunit = 5;
+ ci__1.cifmt = "(A80)";
+ i__1 = s_rsfe(&ci__1);
+ if (i__1 != 0) {
+ goto L380;
+ }
+ i__1 = do_fio(&c__1, line, (ftnlen)80);
+ if (i__1 != 0) {
+ goto L380;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L380;
+ }
+ s_copy(c3, line, (ftnlen)3, (ftnlen)3);
+ lenp = i_len(line, (ftnlen)80);
+ i__ = 3;
+ itmp = 0;
+ i1 = 0;
+L210:
+ ++i__;
+ if (i__ > lenp) {
+ if (i1 > 0) {
+ goto L240;
+ } else {
+ ntypes = 30;
+ goto L240;
+ }
+ }
+ if (*(unsigned char *)&line[i__ - 1] != ' ' && *(unsigned char *)&
+ line[i__ - 1] != ',') {
+ i1 = i__;
+ *(unsigned char *)c1 = *(unsigned char *)&line[i1 - 1];
+
+/* Check that a valid integer was read */
+
+ for (k = 1; k <= 10; ++k) {
+ if (*(unsigned char *)c1 == *(unsigned char *)&intstr[k - 1])
+ {
+ ic = k - 1;
+ goto L230;
+ }
+/* L220: */
+ }
+ s_wsfe(&io___192);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, line, (ftnlen)80);
+ e_wsfe();
+ goto L200;
+L230:
+ itmp = itmp * 10 + ic;
+ goto L210;
+ } else if (i1 > 0) {
+ goto L240;
+ } else {
+ goto L210;
+ }
+L240:
+ ntypes = itmp;
+
+/* Skip the tests if NTYPES is <= 0. */
+
+ if (! (sev || ses || svx || ssx || sgv || sgs) && ntypes <= 0) {
+ s_wsfe(&io___193);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ goto L200;
+ }
+
+ } else {
+ if (sxv) {
+ s_copy(c3, "SXV", (ftnlen)3, (ftnlen)3);
+ }
+ if (sgx) {
+ s_copy(c3, "SGX", (ftnlen)3, (ftnlen)3);
+ }
+ }
+
+/* Reset the random number seed. */
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L250: */
+ }
+ }
+
+ if (lsamen_(&c__3, c3, "SHS") || lsamen_(&c__3, c3,
+ "NEP")) {
+
+/* ------------------------------------- */
+/* NEP: Nonsymmetric Eigenvalue Problem */
+/* ------------------------------------- */
+/* Vary the parameters */
+/* NB = block size */
+/* NBMIN = minimum block size */
+/* NX = crossover point */
+/* NS = number of shifts */
+/* MAXB = minimum submatrix size */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ xlaenv_(&c__1, &c__1);
+ if (tsterr) {
+ serrhs_("SHSEQR", &c__6);
+ }
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xlaenv_(&c__1, &nbval[i__ - 1]);
+ xlaenv_(&c__2, &nbmin[i__ - 1]);
+ xlaenv_(&c__3, &nxval[i__ - 1]);
+/* Computing MAX */
+ i__3 = 11, i__4 = inmin[i__ - 1];
+ i__2 = max(i__3,i__4);
+ xlaenv_(&c__12, &i__2);
+ xlaenv_(&c__13, &inwin[i__ - 1]);
+ xlaenv_(&c__14, &inibl[i__ - 1]);
+ xlaenv_(&c__15, &ishfts[i__ - 1]);
+ xlaenv_(&c__16, &iacc22[i__ - 1]);
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L260: */
+ }
+ }
+ s_wsfe(&io___196);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+/* Computing MAX */
+ i__3 = 11, i__4 = inmin[i__ - 1];
+ i__2 = max(i__3,i__4);
+ do_fio(&c__1, (char *)&i__2, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&inwin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&inibl[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ishfts[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iacc22[i__ - 1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ schkhs_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &a[17424], &a[34848], &a[52272], &a[69696], &
+ c__132, &a[87120], &a[104544], d__, &d__[132], &d__[264],
+ &d__[396], &a[121968], &a[139392], &a[156816], &a[174240],
+ &a[191664], &d__[528], work, &c__87781, iwork, logwrk,
+ result, &info);
+ if (info != 0) {
+ s_wsfe(&io___204);
+ do_fio(&c__1, "SCHKHS", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L270: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "SST") || lsamen_(&
+ c__3, c3, "SEP")) {
+
+/* ---------------------------------- */
+/* SEP: Symmetric Eigenvalue Problem */
+/* ---------------------------------- */
+/* Vary the parameters */
+/* NB = block size */
+/* NBMIN = minimum block size */
+/* NX = crossover point */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ xlaenv_(&c__1, &c__1);
+ xlaenv_(&c__9, &c__25);
+ if (tsterr) {
+ serrst_("SST", &c__6);
+ }
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xlaenv_(&c__1, &nbval[i__ - 1]);
+ xlaenv_(&c__2, &nbmin[i__ - 1]);
+ xlaenv_(&c__3, &nxval[i__ - 1]);
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L280: */
+ }
+ }
+ s_wsfe(&io___205);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ if (tstchk) {
+ schkst_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &c__6, a,
+ &c__132, &a[17424], d__, &d__[132], &d__[264], &d__[
+ 396], &d__[528], &d__[660], &d__[792], &d__[924], &
+ d__[1056], &d__[1188], &d__[1320], &a[34848], &c__132,
+ &a[52272], &a[69696], &d__[1452], &a[87120], work, &
+ c__87781, iwork, &c__89760, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___206);
+ do_fio(&c__1, "SCHKST", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ if (tstdrv) {
+ sdrvst_(&nn, nval, &c__18, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &d__[264], &d__[396], &d__[528], &d__[660], &
+ d__[924], &d__[1056], &d__[1188], &d__[1320], &a[
+ 17424], &c__132, &a[34848], &d__[1452], &a[52272],
+ work, &c__87781, iwork, &c__89760, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___207);
+ do_fio(&c__1, "SDRVST", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+/* L290: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "SSG")) {
+
+/* ---------------------------------------------- */
+/* SSG: Symmetric Generalized Eigenvalue Problem */
+/* ---------------------------------------------- */
+/* Vary the parameters */
+/* NB = block size */
+/* NBMIN = minimum block size */
+/* NX = crossover point */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ xlaenv_(&c__9, &c__25);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xlaenv_(&c__1, &nbval[i__ - 1]);
+ xlaenv_(&c__2, &nbmin[i__ - 1]);
+ xlaenv_(&c__3, &nxval[i__ - 1]);
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L300: */
+ }
+ }
+ s_wsfe(&io___208);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ if (tstchk) {
+ sdrvsg_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &c__6, a,
+ &c__132, &a[17424], &c__132, &d__[264], &a[34848], &
+ c__132, &a[52272], &a[69696], &a[87120], &a[104544],
+ work, &c__87781, iwork, &c__89760, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___209);
+ do_fio(&c__1, "SDRVSG", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+/* L310: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "SBD") || lsamen_(&
+ c__3, c3, "SVD")) {
+
+/* ---------------------------------- */
+/* SVD: Singular Value Decomposition */
+/* ---------------------------------- */
+/* Vary the parameters */
+/* NB = block size */
+/* NBMIN = minimum block size */
+/* NX = crossover point */
+/* NRHS = number of right hand sides */
+
+ maxtyp = 16;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ xlaenv_(&c__1, &c__1);
+ xlaenv_(&c__9, &c__25);
+
+/* Test the error exits */
+
+ if (tsterr && tstchk) {
+ serrbd_("SBD", &c__6);
+ }
+ if (tsterr && tstdrv) {
+ serred_("SBD", &c__6);
+ }
+
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nrhs = nsval[i__ - 1];
+ xlaenv_(&c__1, &nbval[i__ - 1]);
+ xlaenv_(&c__2, &nbmin[i__ - 1]);
+ xlaenv_(&c__3, &nxval[i__ - 1]);
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L320: */
+ }
+ }
+ s_wsfe(&io___211);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(integer));
+ e_wsfe();
+ if (tstchk) {
+ schkbd_(&nn, mval, nval, &maxtyp, dotype, &nrhs, iseed, &
+ thresh, a, &c__132, d__, &d__[132], &d__[264], &d__[
+ 396], &a[17424], &c__132, &a[34848], &a[52272], &a[
+ 69696], &c__132, &a[87120], &c__132, &a[104544], &a[
+ 121968], work, &c__87781, iwork, &c__6, &info);
+ if (info != 0) {
+ s_wsfe(&io___212);
+ do_fio(&c__1, "SCHKBD", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ if (tstdrv) {
+ sdrvbd_(&nn, mval, nval, &maxtyp, dotype, iseed, &thresh, a, &
+ c__132, &a[17424], &c__132, &a[34848], &c__132, &a[
+ 52272], &a[69696], &a[87120], d__, &d__[132], &d__[
+ 264], work, &c__87781, iwork, &c__6, &info);
+ }
+/* L330: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "SEV")) {
+
+/* -------------------------------------------- */
+/* SEV: Nonsymmetric Eigenvalue Problem Driver */
+/* SGEEV (eigenvalues and eigenvectors) */
+/* -------------------------------------------- */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes <= 0) {
+ s_wsfe(&io___213);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ serred_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ sdrvev_(&nn, nval, &ntypes, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &a[17424], d__, &d__[132], &d__[264], &d__[396], &
+ a[34848], &c__132, &a[52272], &c__132, &a[69696], &c__132,
+ result, work, &c__87781, iwork, &info);
+ if (info != 0) {
+ s_wsfe(&io___214);
+ do_fio(&c__1, "SGEEV", (ftnlen)5);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___215);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "SES")) {
+
+/* -------------------------------------------- */
+/* SES: Nonsymmetric Eigenvalue Problem Driver */
+/* SGEES (Schur form) */
+/* -------------------------------------------- */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes <= 0) {
+ s_wsfe(&io___216);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ serred_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ sdrves_(&nn, nval, &ntypes, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &a[17424], &a[34848], d__, &d__[132], &d__[264], &
+ d__[396], &a[52272], &c__132, result, work, &c__87781,
+ iwork, logwrk, &info);
+ if (info != 0) {
+ s_wsfe(&io___217);
+ do_fio(&c__1, "SGEES", (ftnlen)5);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___218);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "SVX")) {
+
+/* -------------------------------------------------------------- */
+/* SVX: Nonsymmetric Eigenvalue Problem Expert Driver */
+/* SGEEVX (eigenvalues, eigenvectors and condition numbers) */
+/* -------------------------------------------------------------- */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes < 0) {
+ s_wsfe(&io___219);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ serred_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ sdrvvx_(&nn, nval, &ntypes, dotype, iseed, &thresh, &c__5, &c__6,
+ a, &c__132, &a[17424], d__, &d__[132], &d__[264], &d__[
+ 396], &a[34848], &c__132, &a[52272], &c__132, &a[69696], &
+ c__132, &d__[528], &d__[660], &d__[792], &d__[924], &d__[
+ 1056], &d__[1188], &d__[1320], &d__[1452], result, work, &
+ c__87781, iwork, &info);
+ if (info != 0) {
+ s_wsfe(&io___220);
+ do_fio(&c__1, "SGEEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___221);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "SSX")) {
+
+/* --------------------------------------------------- */
+/* SSX: Nonsymmetric Eigenvalue Problem Expert Driver */
+/* SGEESX (Schur form and condition numbers) */
+/* --------------------------------------------------- */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes < 0) {
+ s_wsfe(&io___222);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ serred_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ sdrvsx_(&nn, nval, &ntypes, dotype, iseed, &thresh, &c__5, &c__6,
+ a, &c__132, &a[17424], &a[34848], d__, &d__[132], &d__[
+ 264], &d__[396], &d__[528], &d__[660], &a[52272], &c__132,
+ &a[69696], result, work, &c__87781, iwork, logwrk, &info)
+ ;
+ if (info != 0) {
+ s_wsfe(&io___223);
+ do_fio(&c__1, "SGEESX", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___224);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "SGG")) {
+
+/* ------------------------------------------------- */
+/* SGG: Generalized Nonsymmetric Eigenvalue Problem */
+/* ------------------------------------------------- */
+/* Vary the parameters */
+/* NB = block size */
+/* NBMIN = minimum block size */
+/* NS = number of shifts */
+/* MAXB = minimum submatrix size */
+/* NBCOL = minimum column dimension for blocks */
+
+ maxtyp = 26;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ if (tstchk && tsterr) {
+ serrgg_(c3, &c__6);
+ }
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xlaenv_(&c__1, &nbval[i__ - 1]);
+ xlaenv_(&c__2, &nbmin[i__ - 1]);
+ xlaenv_(&c__4, &nsval[i__ - 1]);
+ xlaenv_(&c__8, &mxbval[i__ - 1]);
+ xlaenv_(&c__5, &nbcol[i__ - 1]);
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L340: */
+ }
+ }
+ s_wsfe(&io___225);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbcol[i__ - 1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ tstdif = FALSE_;
+ thrshn = 10.f;
+ if (tstchk) {
+ schkgg_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &tstdif, &
+ thrshn, &c__6, a, &c__132, &a[17424], &a[34848], &a[
+ 52272], &a[69696], &a[87120], &a[104544], &a[121968],
+ &a[139392], &c__132, &a[156816], &a[174240], &a[
+ 191664], d__, &d__[132], &d__[264], &d__[396], &d__[
+ 528], &d__[660], &a[209088], &a[226512], work, &
+ c__87781, logwrk, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___228);
+ do_fio(&c__1, "SCHKGG", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ xlaenv_(&c__1, &c__1);
+ if (tstdrv) {
+ sdrvgg_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &thrshn, &
+ c__6, a, &c__132, &a[17424], &a[34848], &a[52272], &a[
+ 69696], &a[87120], &a[104544], &c__132, &a[121968],
+ d__, &d__[132], &d__[264], &d__[396], &d__[528], &d__[
+ 660], &a[209088], &a[226512], work, &c__87781, result,
+ &info);
+ if (info != 0) {
+ s_wsfe(&io___229);
+ do_fio(&c__1, "SDRVGG", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+/* L350: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "SGS")) {
+
+/* ------------------------------------------------- */
+/* SGS: Generalized Nonsymmetric Eigenvalue Problem */
+/* SGGES (Schur form) */
+/* ------------------------------------------------- */
+
+ maxtyp = 26;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes <= 0) {
+ s_wsfe(&io___230);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ serrgg_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ sdrges_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &a[17424], &a[34848], &a[52272], &a[104544], &
+ c__132, &a[121968], d__, &d__[132], &d__[264], work, &
+ c__87781, result, logwrk, &info);
+
+ if (info != 0) {
+ s_wsfe(&io___231);
+ do_fio(&c__1, "SDRGES", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___232);
+ e_wsfe();
+ goto L10;
+
+ } else if (sgx) {
+
+/* ------------------------------------------------- */
+/* SGX: Generalized Nonsymmetric Eigenvalue Problem */
+/* SGGESX (Schur form and condition numbers) */
+/* ------------------------------------------------- */
+
+ maxtyp = 5;
+ ntypes = maxtyp;
+ if (nn < 0) {
+ s_wsfe(&io___233);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ serrgg_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ xlaenv_(&c__5, &c__2);
+ sdrgsx_(&nn, &c__20, &thresh, &c__5, &c__6, a, &c__132, &a[17424],
+ &a[34848], &a[52272], &a[69696], &a[87120], d__, &d__[
+ 132], &d__[264], c__, &c__400, &a[191664], work, &
+ c__87781, iwork, &c__89760, logwrk, &info);
+ if (info != 0) {
+ s_wsfe(&io___235);
+ do_fio(&c__1, "SDRGSX", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___236);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "SGV")) {
+
+/* ------------------------------------------------- */
+/* SGV: Generalized Nonsymmetric Eigenvalue Problem */
+/* SGGEV (Eigenvalue/vector form) */
+/* ------------------------------------------------- */
+
+ maxtyp = 26;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes <= 0) {
+ s_wsfe(&io___237);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ serrgg_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ sdrgev_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &a[17424], &a[34848], &a[52272], &a[104544], &
+ c__132, &a[121968], &a[139392], &c__132, d__, &d__[132], &
+ d__[264], &d__[396], &d__[528], &d__[660], work, &
+ c__87781, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___238);
+ do_fio(&c__1, "SDRGEV", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___239);
+ e_wsfe();
+ goto L10;
+
+ } else if (sxv) {
+
+/* ------------------------------------------------- */
+/* SXV: Generalized Nonsymmetric Eigenvalue Problem */
+/* SGGEVX (eigenvalue/vector with condition numbers) */
+/* ------------------------------------------------- */
+
+ maxtyp = 2;
+ ntypes = maxtyp;
+ if (nn < 0) {
+ s_wsfe(&io___240);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ serrgg_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ sdrgvx_(&nn, &thresh, &c__5, &c__6, a, &c__132, &a[17424], &a[
+ 34848], &a[52272], d__, &d__[132], &d__[264], &a[69696], &
+ a[87120], iwork, &iwork[1], &d__[396], &d__[528], &d__[
+ 660], &d__[792], &d__[924], &d__[1056], work, &c__87781, &
+ iwork[2], &c__89758, result, logwrk, &info);
+
+ if (info != 0) {
+ s_wsfe(&io___241);
+ do_fio(&c__1, "SDRGVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___242);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "SSB")) {
+
+/* ------------------------------ */
+/* SSB: Symmetric Band Reduction */
+/* ------------------------------ */
+
+ maxtyp = 15;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ if (tsterr) {
+ serrst_("SSB", &c__6);
+ }
+ schksb_(&nn, nval, &nk, kval, &maxtyp, dotype, iseed, &thresh, &c__6,
+ a, &c__132, d__, &d__[132], &a[17424], &c__132, work, &
+ c__87781, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___243);
+ do_fio(&c__1, "SCHKSB", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "SBB")) {
+
+/* ------------------------------ */
+/* SBB: General Band Reduction */
+/* ------------------------------ */
+
+ maxtyp = 15;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nrhs = nsval[i__ - 1];
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L360: */
+ }
+ }
+ s_wsfe(&io___244);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(integer));
+ e_wsfe();
+ schkbb_(&nn, mval, nval, &nk, kval, &maxtyp, dotype, &nrhs, iseed,
+ &thresh, &c__6, a, &c__132, &a[17424], &c__264, d__, &
+ d__[132], &a[52272], &c__132, &a[69696], &c__132, &a[
+ 87120], &c__132, &a[104544], work, &c__87781, result, &
+ info);
+ if (info != 0) {
+ s_wsfe(&io___245);
+ do_fio(&c__1, "SCHKBB", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L370: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "GLM")) {
+
+/* ----------------------------------------- */
+/* GLM: Generalized Linear Regression Model */
+/* ----------------------------------------- */
+
+ xlaenv_(&c__1, &c__1);
+ if (tsterr) {
+ serrgg_("GLM", &c__6);
+ }
+ sckglm_(&nn, mval, pval, nval, &ntypes, iseed, &thresh, &c__132, a, &
+ a[17424], b, &b[17424], x, work, d__, &c__5, &c__6, &info);
+ if (info != 0) {
+ s_wsfe(&io___248);
+ do_fio(&c__1, "SCKGLM", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "GQR")) {
+
+/* ------------------------------------------ */
+/* GQR: Generalized QR and RQ factorizations */
+/* ------------------------------------------ */
+
+ xlaenv_(&c__1, &c__1);
+ if (tsterr) {
+ serrgg_("GQR", &c__6);
+ }
+ sckgqr_(&nn, mval, &nn, pval, &nn, nval, &ntypes, iseed, &thresh, &
+ c__132, a, &a[17424], &a[34848], &a[52272], taua, b, &b[17424]
+, &b[34848], &b[52272], &b[69696], taub, work, d__, &c__5, &
+ c__6, &info);
+ if (info != 0) {
+ s_wsfe(&io___251);
+ do_fio(&c__1, "SCKGQR", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "GSV")) {
+
+/* ---------------------------------------------- */
+/* GSV: Generalized Singular Value Decomposition */
+/* ---------------------------------------------- */
+
+ if (tsterr) {
+ serrgg_("GSV", &c__6);
+ }
+ sckgsv_(&nn, mval, pval, nval, &ntypes, iseed, &thresh, &c__132, a, &
+ a[17424], b, &b[17424], &a[34848], &b[34848], &a[52272], taua,
+ taub, &b[52272], iwork, work, d__, &c__5, &c__6, &info);
+ if (info != 0) {
+ s_wsfe(&io___252);
+ do_fio(&c__1, "SCKGSV", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "LSE")) {
+
+/* -------------------------------------- */
+/* LSE: Constrained Linear Least Squares */
+/* -------------------------------------- */
+
+ xlaenv_(&c__1, &c__1);
+ if (tsterr) {
+ serrgg_("LSE", &c__6);
+ }
+ scklse_(&nn, mval, pval, nval, &ntypes, iseed, &thresh, &c__132, a, &
+ a[17424], b, &b[17424], x, work, d__, &c__5, &c__6, &info);
+ if (info != 0) {
+ s_wsfe(&io___253);
+ do_fio(&c__1, "SCKLSE", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else {
+ s_wsle(&io___254);
+ e_wsle();
+ s_wsle(&io___255);
+ e_wsle();
+ s_wsfe(&io___256);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ }
+ if (! (sgx || sxv)) {
+ goto L190;
+ }
+L380:
+ s_wsfe(&io___257);
+ e_wsfe();
+ s2 = second_();
+ s_wsfe(&io___259);
+ r__1 = s2 - s1;
+ do_fio(&c__1, (char *)&r__1, (ftnlen)sizeof(real));
+ e_wsfe();
+
+/* L9998: */
+
+/* End of SCHKEE */
+
+ return 0;
+} /* MAIN__ */
+
+/* Main program alias */ int schkee_ () { MAIN__ (); return 0; }
diff --git a/TESTING/EIG/schkgg.c b/TESTING/EIG/schkgg.c
new file mode 100644
index 0000000..769a0aa
--- /dev/null
+++ b/TESTING/EIG/schkgg.c
@@ -0,0 +1,1478 @@
+/* schkgg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b13 = 0.f;
+static integer c__2 = 2;
+static real c_b19 = 1.f;
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int schkgg_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, logical *tstdif, real *
+ thrshn, integer *nounit, real *a, integer *lda, real *b, real *h__,
+ real *t, real *s1, real *s2, real *p1, real *p2, real *u, integer *
+ ldu, real *v, real *q, real *z__, real *alphr1, real *alphi1, real *
+ beta1, real *alphr3, real *alphi3, real *beta3, real *evectl, real *
+ evectr, real *work, integer *lwork, logical *llwork, real *result,
+ integer *info)
+{
+ /* Initialized data */
+
+ static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
+ 2,2,2,3 };
+ static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
+ 2,3,2,1 };
+ static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
+ 1,1,1,1 };
+ static integer iasign[26] = { 0,0,0,0,0,0,2,0,2,2,0,0,2,2,2,0,2,0,0,0,2,2,
+ 2,2,2,0 };
+ static integer ibsign[26] = { 0,0,0,0,0,0,0,2,0,0,2,2,0,0,2,0,2,0,0,0,0,0,
+ 0,0,0,0 };
+ static integer kz1[6] = { 0,1,2,1,3,3 };
+ static integer kz2[6] = { 0,0,1,2,1,1 };
+ static integer kadd[6] = { 0,0,0,0,3,2 };
+ static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
+ 4,4,4,0 };
+ static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
+ 8,8,8,8,8,0 };
+ static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
+ 3,3,3,1 };
+ static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
+ 4,4,4,1 };
+ static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
+ 3,3,2,1 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 SCHKGG: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 SCHKGG: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
+ "i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9997[] = "(/1x,a3,\002 -- Real Generalized eigenvalue pr"
+ "oblem\002)";
+ static char fmt_9996[] = "(\002 Matrix types (see SCHKGG for details):"
+ " \002)";
+ static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
+ "osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
+ ") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
+ "onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
+ "I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
+ "arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
+ "(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
+ "=(D, reversed D)\002)";
+ static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
+ "atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
+ " 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
+ "ha&beta \002,\002 20=arithmetic alpha, beta=0,"
+ "1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
+ "=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
+ "/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
+ "l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
+ ".\002)";
+ static char fmt_9993[] = "(/\002 Tests performed: (H is Hessenberg, S "
+ "is Schur, B, \002,\002T, P are triangular,\002,/20x,\002U, V, Q,"
+ " and Z are \002,a,\002, l and r are the\002,/20x,\002appropriate"
+ " left and right eigenvectors, resp., a is\002,/20x,\002alpha, b "
+ "is beta, and \002,a,\002 means \002,a,\002.)\002,/\002 1 = | A -"
+ " U H V\002,a,\002 | / ( |A| n ulp ) 2 = | B - U T V\002,a"
+ ",\002 | / ( |B| n ulp )\002,/\002 3 = | I - UU\002,a,\002 | / ( "
+ "n ulp ) 4 = | I - VV\002,a,\002 | / ( n ulp )\002,"
+ "/\002 5 = | H - Q S Z\002,a,\002 | / ( |H| n ulp )\002,6x,\0026 "
+ "= | T - Q P Z\002,a,\002 | / ( |T| n ulp )\002,/\002 7 = | I - QQ"
+ "\002,a,\002 | / ( n ulp ) 8 = | I - ZZ\002,a,\002 | "
+ "/ ( n ulp )\002,/\002 9 = max | ( b S - a P )\002,a,\002 l | / c"
+ "onst. 10 = max | ( b H - a T )\002,a,\002 l | / const.\002,/"
+ "\002 11= max | ( b S - a P ) r | / const. 12 = max | ( b H\002,"
+ "\002 - a T ) r | / const.\002,/1x)";
+ static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",0p,f8.2)";
+ static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",1p,e10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, evectl_dim1, evectl_offset,
+ evectr_dim1, evectr_offset, h_dim1, h_offset, p1_dim1, p1_offset,
+ p2_dim1, p2_offset, q_dim1, q_offset, s1_dim1, s1_offset, s2_dim1,
+ s2_offset, t_dim1, t_offset, u_dim1, u_offset, v_dim1, v_offset,
+ z_dim1, z_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ double r_sign(real *, real *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer j, n, i1, n1, jc, in, jr;
+ real ulp;
+ integer iadd, nmax;
+ real temp1, temp2;
+ logical badnn;
+ real dumma[4];
+ integer iinfo;
+ real rmagn[4];
+ extern /* Subroutine */ int sget51_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, integer *, real *, integer *, real *
+, real *), sget52_(logical *, integer *, real *, integer *, real *
+, integer *, real *, integer *, real *, real *, real *, real *,
+ real *);
+ real anorm, bnorm;
+ integer nmats, jsize, nerrs, jtype, ntest;
+ extern /* Subroutine */ int sgeqr2_(integer *, integer *, real *, integer
+ *, real *, real *, integer *), slatm4_(integer *, integer *,
+ integer *, integer *, integer *, real *, real *, real *, integer *
+, integer *, real *, integer *), sorm2r_(char *, char *, integer *
+, integer *, integer *, real *, integer *, real *, real *,
+ integer *, real *, integer *), slabad_(real *,
+ real *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ real safmin;
+ integer ioldsd[4];
+ real safmax;
+ extern /* Subroutine */ int sgghrd_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, integer *, integer *);
+ extern doublereal slarnd_(integer *, integer *);
+ extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
+ real *), xerbla_(char *, integer *), shgeqz_(char *, char
+ *, char *, integer *, integer *, integer *, real *, integer *,
+ real *, integer *, real *, real *, real *, real *, integer *,
+ real *, integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *,
+ real *, integer *), slaset_(char *, integer *, integer *,
+ real *, real *, real *, integer *), slasum_(char *,
+ integer *, integer *, integer *), stgevc_(char *, char *,
+ logical *, integer *, real *, integer *, real *, integer *, real *
+, integer *, real *, integer *, integer *, integer *, real *,
+ integer *);
+ real ulpinv;
+ integer lwkopt, mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___68 = { 0, 0, 0, fmt_9991, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKGG checks the nonsymmetric generalized eigenvalue problem */
+/* routines. */
+/* T T T */
+/* SGGHRD factors A and B as U H V and U T V , where means */
+/* transpose, H is hessenberg, T is triangular and U and V are */
+/* orthogonal. */
+/* T T */
+/* SHGEQZ factors H and T as Q S Z and Q P Z , where P is upper */
+/* triangular, S is in generalized Schur form (block upper triangular, */
+/* with 1x1 and 2x2 blocks on the diagonal, the 2x2 blocks */
+/* corresponding to complex conjugate pairs of generalized */
+/* eigenvalues), and Q and Z are orthogonal. It also computes the */
+/* generalized eigenvalues (alpha(1),beta(1)),...,(alpha(n),beta(n)), */
+/* where alpha(j)=S(j,j) and beta(j)=P(j,j) -- thus, */
+/* w(j) = alpha(j)/beta(j) is a root of the generalized eigenvalue */
+/* problem */
+
+/* det( A - w(j) B ) = 0 */
+
+/* and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent */
+/* problem */
+
+/* det( m(j) A - B ) = 0 */
+
+/* STGEVC computes the matrix L of left eigenvectors and the matrix R */
+/* of right eigenvectors for the matrix pair ( S, P ). In the */
+/* description below, l and r are left and right eigenvectors */
+/* corresponding to the generalized eigenvalues (alpha,beta). */
+
+/* When SCHKGG is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 15 */
+/* tests will be performed. The first twelve "test ratios" should be */
+/* small -- O(1). They will be compared with the threshhold THRESH: */
+
+/* T */
+/* (1) | A - U H V | / ( |A| n ulp ) */
+
+/* T */
+/* (2) | B - U T V | / ( |B| n ulp ) */
+
+/* T */
+/* (3) | I - UU | / ( n ulp ) */
+
+/* T */
+/* (4) | I - VV | / ( n ulp ) */
+
+/* T */
+/* (5) | H - Q S Z | / ( |H| n ulp ) */
+
+/* T */
+/* (6) | T - Q P Z | / ( |T| n ulp ) */
+
+/* T */
+/* (7) | I - QQ | / ( n ulp ) */
+
+/* T */
+/* (8) | I - ZZ | / ( n ulp ) */
+
+/* (9) max over all left eigenvalue/-vector pairs (beta/alpha,l) of */
+
+/* | l**H * (beta S - alpha P) | / ( ulp max( |beta S|, |alpha P| ) ) */
+
+/* (10) max over all left eigenvalue/-vector pairs (beta/alpha,l') of */
+/* T */
+/* | l'**H * (beta H - alpha T) | / ( ulp max( |beta H|, |alpha T| ) ) */
+
+/* where the eigenvectors l' are the result of passing Q to */
+/* STGEVC and back transforming (HOWMNY='B'). */
+
+/* (11) max over all right eigenvalue/-vector pairs (beta/alpha,r) of */
+
+/* | (beta S - alpha T) r | / ( ulp max( |beta S|, |alpha T| ) ) */
+
+/* (12) max over all right eigenvalue/-vector pairs (beta/alpha,r') of */
+
+/* | (beta H - alpha T) r' | / ( ulp max( |beta H|, |alpha T| ) ) */
+
+/* where the eigenvectors r' are the result of passing Z to */
+/* STGEVC and back transforming (HOWMNY='B'). */
+
+/* The last three test ratios will usually be small, but there is no */
+/* mathematical requirement that they be so. They are therefore */
+/* compared with THRESH only if TSTDIF is .TRUE. */
+
+/* (13) | S(Q,Z computed) - S(Q,Z not computed) | / ( |S| ulp ) */
+
+/* (14) | P(Q,Z computed) - P(Q,Z not computed) | / ( |P| ulp ) */
+
+/* (15) max( |alpha(Q,Z computed) - alpha(Q,Z not computed)|/|S| , */
+/* |beta(Q,Z computed) - beta(Q,Z not computed)|/|P| ) / ulp */
+
+/* In addition, the normalization of L and R are checked, and compared */
+/* with the threshhold THRSHN. */
+
+/* Test Matrices */
+/* ---- -------- */
+
+/* The sizes of the test matrices are specified by an array */
+/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
+/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) ( 0, 0 ) (a pair of zero matrices) */
+
+/* (2) ( I, 0 ) (an identity and a zero matrix) */
+
+/* (3) ( 0, I ) (an identity and a zero matrix) */
+
+/* (4) ( I, I ) (a pair of identity matrices) */
+
+/* t t */
+/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
+
+/* t ( I 0 ) */
+/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
+/* ( 0 I ) ( 0 J ) */
+/* and I is a k x k identity and J a (k+1)x(k+1) */
+/* Jordan block; k=(N-1)/2 */
+
+/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
+/* matrix with those diagonal entries.) */
+/* (8) ( I, D ) */
+
+/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
+
+/* (10) ( small*D, big*I ) */
+
+/* (11) ( big*I, small*D ) */
+
+/* (12) ( small*I, big*D ) */
+
+/* (13) ( big*D, big*I ) */
+
+/* (14) ( small*D, small*I ) */
+
+/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
+/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
+/* t t */
+/* (16) U ( J , J ) V where U and V are random orthogonal matrices. */
+
+/* (17) U ( T1, T2 ) V where T1 and T2 are upper triangular matrices */
+/* with random O(1) entries above the diagonal */
+/* and diagonal entries diag(T1) = */
+/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
+/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
+
+/* (18) U ( T1, T2 ) V diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
+/* s = machine precision. */
+
+/* (19) U ( T1, T2 ) V diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
+
+/* N-5 */
+/* (20) U ( T1, T2 ) V diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+
+/* (21) U ( T1, T2 ) V diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+/* where r1,..., r(N-4) are random. */
+
+/* (22) U ( big*T1, small*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (23) U ( small*T1, big*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (24) U ( small*T1, small*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (25) U ( big*T1, big*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (26) U ( T1, T2 ) V where T1 and T2 are random upper-triangular */
+/* matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* SCHKGG does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, SCHKGG */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to SCHKGG to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error is */
+/* scaled to be O(1), so THRESH should be a reasonably small */
+/* multiple of 1, e.g., 10 or 100. In particular, it should */
+/* not depend on the precision (single vs. double) or the size */
+/* of the matrix. It must be at least zero. */
+
+/* TSTDIF (input) LOGICAL */
+/* Specifies whether test ratios 13-15 will be computed and */
+/* compared with THRESH. */
+/* = .FALSE.: Only test ratios 1-12 will be computed and tested. */
+/* Ratios 13-15 will be set to zero. */
+/* = .TRUE.: All the test ratios 1-15 will be computed and */
+/* tested. */
+
+/* THRSHN (input) REAL */
+/* Threshhold for reporting eigenvector normalization error. */
+/* If the normalization of any eigenvector differs from 1 by */
+/* more than THRSHN*ulp, then a special error message will be */
+/* printed. (This is handled separately from the other tests, */
+/* since only a compiler or programming error should cause an */
+/* error message, at least if THRSHN is at least 5--10.) */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace) REAL array, dimension */
+/* (LDA, max(NN)) */
+/* Used to hold the original A matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, H, T, S1, P1, S2, and P2. */
+/* It must be at least 1 and at least max( NN ). */
+
+/* B (input/workspace) REAL array, dimension */
+/* (LDA, max(NN)) */
+/* Used to hold the original B matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* H (workspace) REAL array, dimension (LDA, max(NN)) */
+/* The upper Hessenberg matrix computed from A by SGGHRD. */
+
+/* T (workspace) REAL array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from B by SGGHRD. */
+
+/* S1 (workspace) REAL array, dimension (LDA, max(NN)) */
+/* The Schur (block upper triangular) matrix computed from H by */
+/* SHGEQZ when Q and Z are also computed. */
+
+/* S2 (workspace) REAL array, dimension (LDA, max(NN)) */
+/* The Schur (block upper triangular) matrix computed from H by */
+/* SHGEQZ when Q and Z are not computed. */
+
+/* P1 (workspace) REAL array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from T by SHGEQZ */
+/* when Q and Z are also computed. */
+
+/* P2 (workspace) REAL array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from T by SHGEQZ */
+/* when Q and Z are not computed. */
+
+/* U (workspace) REAL array, dimension (LDU, max(NN)) */
+/* The (left) orthogonal matrix computed by SGGHRD. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U, V, Q, Z, EVECTL, and EVECTR. It */
+/* must be at least 1 and at least max( NN ). */
+
+/* V (workspace) REAL array, dimension (LDU, max(NN)) */
+/* The (right) orthogonal matrix computed by SGGHRD. */
+
+/* Q (workspace) REAL array, dimension (LDU, max(NN)) */
+/* The (left) orthogonal matrix computed by SHGEQZ. */
+
+/* Z (workspace) REAL array, dimension (LDU, max(NN)) */
+/* The (left) orthogonal matrix computed by SHGEQZ. */
+
+/* ALPHR1 (workspace) REAL array, dimension (max(NN)) */
+/* ALPHI1 (workspace) REAL array, dimension (max(NN)) */
+/* BETA1 (workspace) REAL array, dimension (max(NN)) */
+
+/* The generalized eigenvalues of (A,B) computed by SHGEQZ */
+/* when Q, Z, and the full Schur matrices are computed. */
+/* On exit, ( ALPHR1(k)+ALPHI1(k)*i ) / BETA1(k) is the k-th */
+/* generalized eigenvalue of the matrices in A and B. */
+
+/* ALPHR3 (workspace) REAL array, dimension (max(NN)) */
+/* ALPHI3 (workspace) REAL array, dimension (max(NN)) */
+/* BETA3 (workspace) REAL array, dimension (max(NN)) */
+
+/* EVECTL (workspace) REAL array, dimension (LDU, max(NN)) */
+/* The (block lower triangular) left eigenvector matrix for */
+/* the matrices in S1 and P1. (See STGEVC for the format.) */
+
+/* EVECTR (workspace) REAL array, dimension (LDU, max(NN)) */
+/* The (block upper triangular) right eigenvector matrix for */
+/* the matrices in S1 and P1. (See STGEVC for the format.) */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* max( 2 * N**2, 6*N, 1 ), for all N=NN(j). */
+
+/* LLWORK (workspace) LOGICAL array, dimension (max(NN)) */
+
+/* RESULT (output) REAL array, dimension (15) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > 0: A routine returned an error code. INFO is the */
+/* absolute value of the INFO value returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ p2_dim1 = *lda;
+ p2_offset = 1 + p2_dim1;
+ p2 -= p2_offset;
+ p1_dim1 = *lda;
+ p1_offset = 1 + p1_dim1;
+ p1 -= p1_offset;
+ s2_dim1 = *lda;
+ s2_offset = 1 + s2_dim1;
+ s2 -= s2_offset;
+ s1_dim1 = *lda;
+ s1_offset = 1 + s1_dim1;
+ s1 -= s1_offset;
+ t_dim1 = *lda;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ evectr_dim1 = *ldu;
+ evectr_offset = 1 + evectr_dim1;
+ evectr -= evectr_offset;
+ evectl_dim1 = *ldu;
+ evectl_offset = 1 + evectl_dim1;
+ evectl -= evectl_offset;
+ z_dim1 = *ldu;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ q_dim1 = *ldu;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ v_dim1 = *ldu;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --alphr1;
+ --alphi1;
+ --beta1;
+ --alphr3;
+ --alphi3;
+ --beta3;
+ --work;
+ --llwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Maximum blocksize and shift -- we assume that blocksize and number */
+/* of shifts are monotone increasing functions of N. */
+
+/* Computing MAX */
+ i__1 = nmax * 6, i__2 = (nmax << 1) * nmax, i__1 = max(i__1,i__2);
+ lwkopt = max(i__1,1);
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.f) {
+ *info = -6;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -10;
+ } else if (*ldu <= 1 || *ldu < nmax) {
+ *info = -19;
+ } else if (lwkopt > *lwork) {
+ *info = -30;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SCHKGG", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+ safmin = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ safmin /= ulp;
+ safmax = 1.f / safmin;
+ slabad_(&safmin, &safmax);
+ ulpinv = 1.f / ulp;
+
+/* The values RMAGN(2:3) depend on N, see below. */
+
+ rmagn[0] = 0.f;
+ rmagn[1] = 1.f;
+
+/* Loop over sizes, types */
+
+ ntestt = 0;
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ n1 = max(1,n);
+ rmagn[2] = safmax * ulp / (real) n1;
+ rmagn[3] = safmin * ulpinv * n1;
+
+ if (*nsizes != 1) {
+ mtypes = min(26,*ntypes);
+ } else {
+ mtypes = min(27,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L230;
+ }
+ ++nmats;
+ ntest = 0;
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 15; ++j) {
+ result[j] = 0.f;
+/* L30: */
+ }
+
+/* Compute A and B */
+
+/* Description of control parameters: */
+
+/* KCLASS: =1 means w/o rotation, =2 means w/ rotation, */
+/* =3 means random. */
+/* KATYPE: the "type" to be passed to SLATM4 for computing A. */
+/* KAZERO: the pattern of zeros on the diagonal for A: */
+/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
+/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
+/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
+/* non-zero entries.) */
+/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
+/* =2: large, =3: small. */
+/* IASIGN: 1 if the diagonal elements of A are to be */
+/* multiplied by a random magnitude 1 number, =2 if */
+/* randomly chosen diagonal blocks are to be rotated */
+/* to form 2x2 blocks. */
+/* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B. */
+/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
+/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
+/* RMAGN: used to implement KAMAGN and KBMAGN. */
+
+ if (mtypes > 26) {
+ goto L110;
+ }
+ iinfo = 0;
+ if (kclass[jtype - 1] < 3) {
+
+/* Generate A (w/o rotation) */
+
+ if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ slaset_("Full", &n, &n, &c_b13, &c_b13, &a[a_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ slatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
+ &kz2[kazero[jtype - 1] - 1], &iasign[jtype - 1], &
+ rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
+ 1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
+ a_offset], lda);
+ iadd = kadd[kazero[jtype - 1] - 1];
+ if (iadd > 0 && iadd <= n) {
+ a[iadd + iadd * a_dim1] = rmagn[kamagn[jtype - 1]];
+ }
+
+/* Generate B (w/o rotation) */
+
+ if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ slaset_("Full", &n, &n, &c_b13, &c_b13, &b[b_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ slatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
+ &kz2[kbzero[jtype - 1] - 1], &ibsign[jtype - 1], &
+ rmagn[kbmagn[jtype - 1]], &c_b19, &rmagn[ktrian[jtype
+ - 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
+ b_offset], lda);
+ iadd = kadd[kbzero[jtype - 1] - 1];
+ if (iadd != 0 && iadd <= n) {
+ b[iadd + iadd * b_dim1] = rmagn[kbmagn[jtype - 1]];
+ }
+
+ if (kclass[jtype - 1] == 2 && n > 0) {
+
+/* Include rotations */
+
+/* Generate U, V as Householder transformations times */
+/* a diagonal matrix. */
+
+ i__3 = n - 1;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = jc; jr <= i__4; ++jr) {
+ u[jr + jc * u_dim1] = slarnd_(&c__3, &iseed[1]);
+ v[jr + jc * v_dim1] = slarnd_(&c__3, &iseed[1]);
+/* L40: */
+ }
+ i__4 = n + 1 - jc;
+ slarfg_(&i__4, &u[jc + jc * u_dim1], &u[jc + 1 + jc *
+ u_dim1], &c__1, &work[jc]);
+ work[(n << 1) + jc] = r_sign(&c_b19, &u[jc + jc *
+ u_dim1]);
+ u[jc + jc * u_dim1] = 1.f;
+ i__4 = n + 1 - jc;
+ slarfg_(&i__4, &v[jc + jc * v_dim1], &v[jc + 1 + jc *
+ v_dim1], &c__1, &work[n + jc]);
+ work[n * 3 + jc] = r_sign(&c_b19, &v[jc + jc * v_dim1]
+ );
+ v[jc + jc * v_dim1] = 1.f;
+/* L50: */
+ }
+ u[n + n * u_dim1] = 1.f;
+ work[n] = 0.f;
+ r__1 = slarnd_(&c__2, &iseed[1]);
+ work[n * 3] = r_sign(&c_b19, &r__1);
+ v[n + n * v_dim1] = 1.f;
+ work[n * 2] = 0.f;
+ r__1 = slarnd_(&c__2, &iseed[1]);
+ work[n * 4] = r_sign(&c_b19, &r__1);
+
+/* Apply the diagonal matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ a[jr + jc * a_dim1] = work[(n << 1) + jr] * work[
+ n * 3 + jc] * a[jr + jc * a_dim1];
+ b[jr + jc * b_dim1] = work[(n << 1) + jr] * work[
+ n * 3 + jc] * b[jr + jc * b_dim1];
+/* L60: */
+ }
+/* L70: */
+ }
+ i__3 = n - 1;
+ sorm2r_("L", "N", &n, &n, &i__3, &u[u_offset], ldu, &work[
+ 1], &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ sorm2r_("R", "T", &n, &n, &i__3, &v[v_offset], ldu, &work[
+ n + 1], &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ sorm2r_("L", "N", &n, &n, &i__3, &u[u_offset], ldu, &work[
+ 1], &b[b_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ sorm2r_("R", "T", &n, &n, &i__3, &v[v_offset], ldu, &work[
+ n + 1], &b[b_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ }
+ } else {
+
+/* Random matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ a[jr + jc * a_dim1] = rmagn[kamagn[jtype - 1]] *
+ slarnd_(&c__2, &iseed[1]);
+ b[jr + jc * b_dim1] = rmagn[kbmagn[jtype - 1]] *
+ slarnd_(&c__2, &iseed[1]);
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+
+ anorm = slange_("1", &n, &n, &a[a_offset], lda, &work[1]);
+ bnorm = slange_("1", &n, &n, &b[b_offset], lda, &work[1]);
+
+L100:
+
+ if (iinfo != 0) {
+ io___40.ciunit = *nounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L110:
+
+/* Call SGEQR2, SORM2R, and SGGHRD to compute H, T, U, and V */
+
+ slacpy_(" ", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+ slacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ ntest = 1;
+ result[1] = ulpinv;
+
+ sgeqr2_(&n, &n, &t[t_offset], lda, &work[1], &work[n + 1], &iinfo)
+ ;
+ if (iinfo != 0) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "SGEQR2", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ sorm2r_("L", "T", &n, &n, &n, &t[t_offset], lda, &work[1], &h__[
+ h_offset], lda, &work[n + 1], &iinfo);
+ if (iinfo != 0) {
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "SORM2R", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ slaset_("Full", &n, &n, &c_b13, &c_b19, &u[u_offset], ldu);
+ sorm2r_("R", "N", &n, &n, &n, &t[t_offset], lda, &work[1], &u[
+ u_offset], ldu, &work[n + 1], &iinfo);
+ if (iinfo != 0) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "SORM2R", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ sgghrd_("V", "I", &n, &c__1, &n, &h__[h_offset], lda, &t[t_offset]
+, lda, &u[u_offset], ldu, &v[v_offset], ldu, &iinfo);
+ if (iinfo != 0) {
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "SGGHRD", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+ ntest = 4;
+
+/* Do tests 1--4 */
+
+ sget51_(&c__1, &n, &a[a_offset], lda, &h__[h_offset], lda, &u[
+ u_offset], ldu, &v[v_offset], ldu, &work[1], &result[1]);
+ sget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &u[
+ u_offset], ldu, &v[v_offset], ldu, &work[1], &result[2]);
+ sget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &u[
+ u_offset], ldu, &u[u_offset], ldu, &work[1], &result[3]);
+ sget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &v[
+ v_offset], ldu, &v[v_offset], ldu, &work[1], &result[4]);
+
+/* Call SHGEQZ to compute S1, P1, S2, P2, Q, and Z, do tests. */
+
+/* Compute T1 and UZ */
+
+/* Eigenvalues only */
+
+ slacpy_(" ", &n, &n, &h__[h_offset], lda, &s2[s2_offset], lda);
+ slacpy_(" ", &n, &n, &t[t_offset], lda, &p2[p2_offset], lda);
+ ntest = 5;
+ result[5] = ulpinv;
+
+ shgeqz_("E", "N", "N", &n, &c__1, &n, &s2[s2_offset], lda, &p2[
+ p2_offset], lda, &alphr3[1], &alphi3[1], &beta3[1], &q[
+ q_offset], ldu, &z__[z_offset], ldu, &work[1], lwork, &
+ iinfo);
+ if (iinfo != 0) {
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "SHGEQZ(E)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+/* Eigenvalues and Full Schur Form */
+
+ slacpy_(" ", &n, &n, &h__[h_offset], lda, &s2[s2_offset], lda);
+ slacpy_(" ", &n, &n, &t[t_offset], lda, &p2[p2_offset], lda);
+
+ shgeqz_("S", "N", "N", &n, &c__1, &n, &s2[s2_offset], lda, &p2[
+ p2_offset], lda, &alphr1[1], &alphi1[1], &beta1[1], &q[
+ q_offset], ldu, &z__[z_offset], ldu, &work[1], lwork, &
+ iinfo);
+ if (iinfo != 0) {
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, "SHGEQZ(S)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+/* Eigenvalues, Schur Form, and Schur Vectors */
+
+ slacpy_(" ", &n, &n, &h__[h_offset], lda, &s1[s1_offset], lda);
+ slacpy_(" ", &n, &n, &t[t_offset], lda, &p1[p1_offset], lda);
+
+ shgeqz_("S", "I", "I", &n, &c__1, &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, &alphr1[1], &alphi1[1], &beta1[1], &q[
+ q_offset], ldu, &z__[z_offset], ldu, &work[1], lwork, &
+ iinfo);
+ if (iinfo != 0) {
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ do_fio(&c__1, "SHGEQZ(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ ntest = 8;
+
+/* Do Tests 5--8 */
+
+ sget51_(&c__1, &n, &h__[h_offset], lda, &s1[s1_offset], lda, &q[
+ q_offset], ldu, &z__[z_offset], ldu, &work[1], &result[5])
+ ;
+ sget51_(&c__1, &n, &t[t_offset], lda, &p1[p1_offset], lda, &q[
+ q_offset], ldu, &z__[z_offset], ldu, &work[1], &result[6])
+ ;
+ sget51_(&c__3, &n, &t[t_offset], lda, &p1[p1_offset], lda, &q[
+ q_offset], ldu, &q[q_offset], ldu, &work[1], &result[7]);
+ sget51_(&c__3, &n, &t[t_offset], lda, &p1[p1_offset], lda, &z__[
+ z_offset], ldu, &z__[z_offset], ldu, &work[1], &result[8])
+ ;
+
+/* Compute the Left and Right Eigenvectors of (S1,P1) */
+
+/* 9: Compute the left eigenvector Matrix without */
+/* back transforming: */
+
+ ntest = 9;
+ result[9] = ulpinv;
+
+/* To test "SELECT" option, compute half of the eigenvectors */
+/* in one call, and half in another */
+
+ i1 = n / 2;
+ i__3 = i1;
+ for (j = 1; j <= i__3; ++j) {
+ llwork[j] = TRUE_;
+/* L120: */
+ }
+ i__3 = n;
+ for (j = i1 + 1; j <= i__3; ++j) {
+ llwork[j] = FALSE_;
+/* L130: */
+ }
+
+ stgevc_("L", "S", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, &evectl[evectl_offset], ldu, dumma, ldu,
+ &n, &in, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ do_fio(&c__1, "STGEVC(L,S1)", (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ i1 = in;
+ i__3 = i1;
+ for (j = 1; j <= i__3; ++j) {
+ llwork[j] = FALSE_;
+/* L140: */
+ }
+ i__3 = n;
+ for (j = i1 + 1; j <= i__3; ++j) {
+ llwork[j] = TRUE_;
+/* L150: */
+ }
+
+ stgevc_("L", "S", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, &evectl[(i1 + 1) * evectl_dim1 + 1], ldu,
+ dumma, ldu, &n, &in, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "STGEVC(L,S2)", (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ sget52_(&c_true, &n, &s1[s1_offset], lda, &p1[p1_offset], lda, &
+ evectl[evectl_offset], ldu, &alphr1[1], &alphi1[1], &
+ beta1[1], &work[1], dumma);
+ result[9] = dumma[0];
+ if (dumma[1] > *thrshn) {
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "STGEVC(HOWMNY=S)", (ftnlen)16);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* 10: Compute the left eigenvector Matrix with */
+/* back transforming: */
+
+ ntest = 10;
+ result[10] = ulpinv;
+ slacpy_("F", &n, &n, &q[q_offset], ldu, &evectl[evectl_offset],
+ ldu);
+ stgevc_("L", "B", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, &evectl[evectl_offset], ldu, dumma, ldu,
+ &n, &in, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, "STGEVC(L,B)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ sget52_(&c_true, &n, &h__[h_offset], lda, &t[t_offset], lda, &
+ evectl[evectl_offset], ldu, &alphr1[1], &alphi1[1], &
+ beta1[1], &work[1], dumma);
+ result[10] = dumma[0];
+ if (dumma[1] > *thrshn) {
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "STGEVC(HOWMNY=B)", (ftnlen)16);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* 11: Compute the right eigenvector Matrix without */
+/* back transforming: */
+
+ ntest = 11;
+ result[11] = ulpinv;
+
+/* To test "SELECT" option, compute half of the eigenvectors */
+/* in one call, and half in another */
+
+ i1 = n / 2;
+ i__3 = i1;
+ for (j = 1; j <= i__3; ++j) {
+ llwork[j] = TRUE_;
+/* L160: */
+ }
+ i__3 = n;
+ for (j = i1 + 1; j <= i__3; ++j) {
+ llwork[j] = FALSE_;
+/* L170: */
+ }
+
+ stgevc_("R", "S", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, dumma, ldu, &evectr[evectr_offset], ldu,
+ &n, &in, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+ do_fio(&c__1, "STGEVC(R,S1)", (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ i1 = in;
+ i__3 = i1;
+ for (j = 1; j <= i__3; ++j) {
+ llwork[j] = FALSE_;
+/* L180: */
+ }
+ i__3 = n;
+ for (j = i1 + 1; j <= i__3; ++j) {
+ llwork[j] = TRUE_;
+/* L190: */
+ }
+
+ stgevc_("R", "S", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, dumma, ldu, &evectr[(i1 + 1) *
+ evectr_dim1 + 1], ldu, &n, &in, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ do_fio(&c__1, "STGEVC(R,S2)", (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ sget52_(&c_false, &n, &s1[s1_offset], lda, &p1[p1_offset], lda, &
+ evectr[evectr_offset], ldu, &alphr1[1], &alphi1[1], &
+ beta1[1], &work[1], dumma);
+ result[11] = dumma[0];
+ if (dumma[1] > *thresh) {
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "STGEVC(HOWMNY=S)", (ftnlen)16);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* 12: Compute the right eigenvector Matrix with */
+/* back transforming: */
+
+ ntest = 12;
+ result[12] = ulpinv;
+ slacpy_("F", &n, &n, &z__[z_offset], ldu, &evectr[evectr_offset],
+ ldu);
+ stgevc_("R", "B", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, dumma, ldu, &evectr[evectr_offset], ldu,
+ &n, &in, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ do_fio(&c__1, "STGEVC(R,B)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ sget52_(&c_false, &n, &h__[h_offset], lda, &t[t_offset], lda, &
+ evectr[evectr_offset], ldu, &alphr1[1], &alphi1[1], &
+ beta1[1], &work[1], dumma);
+ result[12] = dumma[0];
+ if (dumma[1] > *thresh) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "STGEVC(HOWMNY=B)", (ftnlen)16);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Tests 13--15 are done only on request */
+
+ if (*tstdif) {
+
+/* Do Tests 13--14 */
+
+ sget51_(&c__2, &n, &s1[s1_offset], lda, &s2[s2_offset], lda, &
+ q[q_offset], ldu, &z__[z_offset], ldu, &work[1], &
+ result[13]);
+ sget51_(&c__2, &n, &p1[p1_offset], lda, &p2[p2_offset], lda, &
+ q[q_offset], ldu, &z__[z_offset], ldu, &work[1], &
+ result[14]);
+
+/* Do Test 15 */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = alphr1[j] - alphr3[j], dabs(
+ r__1)) + (r__2 = alphi1[j] - alphi3[j], dabs(r__2)
+ );
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = beta1[j] - beta3[j], dabs(
+ r__1));
+ temp2 = dmax(r__2,r__3);
+/* L200: */
+ }
+
+/* Computing MAX */
+ r__1 = safmin, r__2 = ulp * dmax(temp1,anorm);
+ temp1 /= dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = safmin, r__2 = ulp * dmax(temp2,bnorm);
+ temp2 /= dmax(r__1,r__2);
+ result[15] = dmax(temp1,temp2);
+ ntest = 15;
+ } else {
+ result[13] = 0.f;
+ result[14] = 0.f;
+ result[15] = 0.f;
+ ntest = 12;
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L210:
+
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__3 = ntest;
+ for (jr = 1; jr <= i__3; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___62.ciunit = *nounit;
+ s_wsfe(&io___62);
+ do_fio(&c__1, "SGG", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___63.ciunit = *nounit;
+ s_wsfe(&io___63);
+ e_wsfe();
+ io___64.ciunit = *nounit;
+ s_wsfe(&io___64);
+ e_wsfe();
+ io___65.ciunit = *nounit;
+ s_wsfe(&io___65);
+ do_fio(&c__1, "Orthogonal", (ftnlen)10);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___66.ciunit = *nounit;
+ s_wsfe(&io___66);
+ do_fio(&c__1, "orthogonal", (ftnlen)10);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ for (j = 1; j <= 10; ++j) {
+ do_fio(&c__1, "'", (ftnlen)1);
+ }
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[jr] < 1e4f) {
+ io___67.ciunit = *nounit;
+ s_wsfe(&io___67);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ } else {
+ io___68.ciunit = *nounit;
+ s_wsfe(&io___68);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ }
+ }
+/* L220: */
+ }
+
+L230:
+ ;
+ }
+/* L240: */
+ }
+
+/* Summary */
+
+ slasum_("SGG", nounit, &nerrs, &ntestt);
+ return 0;
+
+
+
+
+
+
+
+
+/* End of SCHKGG */
+
+} /* schkgg_ */
diff --git a/TESTING/EIG/schkgk.c b/TESTING/EIG/schkgk.c
new file mode 100644
index 0000000..4cb993d
--- /dev/null
+++ b/TESTING/EIG/schkgk.c
@@ -0,0 +1,348 @@
+/* schkgk.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c__50 = 50;
+static real c_b52 = 1.f;
+static real c_b55 = 0.f;
+
+/* Subroutine */ int schkgk_(integer *nin, integer *nout)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002.. test output of SGGBAK .. \002)";
+ static char fmt_9998[] = "(\002 value of largest test error "
+ " =\002,e12.3)";
+ static char fmt_9997[] = "(\002 example number where SGGBAL info is not "
+ "0 =\002,i4)";
+ static char fmt_9996[] = "(\002 example number where SGGBAK(L) info is n"
+ "ot 0 =\002,i4)";
+ static char fmt_9995[] = "(\002 example number where SGGBAK(R) info is n"
+ "ot 0 =\002,i4)";
+ static char fmt_9994[] = "(\002 example number having largest error "
+ " =\002,i4)";
+ static char fmt_9992[] = "(\002 number of examples where info is not 0 "
+ " =\002,i4)";
+ static char fmt_9991[] = "(\002 total number of examples tested "
+ " =\002,i4)";
+
+ /* System generated locals */
+ integer i__1, i__2;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void), s_wsfe(cilist *), e_wsfe(void), do_fio(integer *,
+ char *, ftnlen);
+
+ /* Local variables */
+ real a[2500] /* was [50][50] */, b[2500] /* was [50][50] */, e[
+ 2500] /* was [50][50] */, f[2500] /* was [50][50] */;
+ integer i__, j, m, n;
+ real af[2500] /* was [50][50] */, bf[2500] /* was [50][50] */,
+ vl[2500] /* was [50][50] */, vr[2500] /* was [50][50] */;
+ integer ihi, ilo;
+ real eps, vlf[2500] /* was [50][50] */;
+ integer knt;
+ real vrf[2500] /* was [50][50] */;
+ integer info, lmax[4];
+ real rmax, vmax, work[2500] /* was [50][50] */;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ integer ninfo;
+ real anorm, bnorm;
+ extern /* Subroutine */ int sggbak_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, integer *
+), sggbal_(char *, integer *, real *, integer *,
+ real *, integer *, integer *, integer *, real *, real *, real *,
+ integer *);
+ real lscale[50];
+ extern doublereal slamch_(char *);
+ real rscale[50];
+ extern doublereal slange_(char *, integer *, integer *, real *, integer *,
+ real *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 0, 0, 0, 0 };
+ static cilist io___10 = { 0, 0, 0, 0, 0 };
+ static cilist io___13 = { 0, 0, 0, 0, 0 };
+ static cilist io___15 = { 0, 0, 0, 0, 0 };
+ static cilist io___17 = { 0, 0, 0, 0, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9991, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKGK tests SGGBAK, a routine for backward balancing of */
+/* a matrix pair (A, B). */
+
+/* Arguments */
+/* ========= */
+
+/* NIN (input) INTEGER */
+/* The logical unit number for input. NIN > 0. */
+
+/* NOUT (input) INTEGER */
+/* The logical unit number for output. NOUT > 0. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialization */
+
+ lmax[0] = 0;
+ lmax[1] = 0;
+ lmax[2] = 0;
+ lmax[3] = 0;
+ ninfo = 0;
+ knt = 0;
+ rmax = 0.f;
+
+ eps = slamch_("Precision");
+
+L10:
+ io___6.ciunit = *nin;
+ s_rsle(&io___6);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&m, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ goto L100;
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___10.ciunit = *nin;
+ s_rsle(&io___10);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__4, &c__1, (char *)&a[i__ + j * 50 - 51], (ftnlen)
+ sizeof(real));
+ }
+ e_rsle();
+/* L20: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___13.ciunit = *nin;
+ s_rsle(&io___13);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__4, &c__1, (char *)&b[i__ + j * 50 - 51], (ftnlen)
+ sizeof(real));
+ }
+ e_rsle();
+/* L30: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___15.ciunit = *nin;
+ s_rsle(&io___15);
+ i__2 = m;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__4, &c__1, (char *)&vl[i__ + j * 50 - 51], (ftnlen)
+ sizeof(real));
+ }
+ e_rsle();
+/* L40: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___17.ciunit = *nin;
+ s_rsle(&io___17);
+ i__2 = m;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__4, &c__1, (char *)&vr[i__ + j * 50 - 51], (ftnlen)
+ sizeof(real));
+ }
+ e_rsle();
+/* L50: */
+ }
+
+ ++knt;
+
+ anorm = slange_("M", &n, &n, a, &c__50, work);
+ bnorm = slange_("M", &n, &n, b, &c__50, work);
+
+ slacpy_("FULL", &n, &n, a, &c__50, af, &c__50);
+ slacpy_("FULL", &n, &n, b, &c__50, bf, &c__50);
+
+ sggbal_("B", &n, a, &c__50, b, &c__50, &ilo, &ihi, lscale, rscale, work, &
+ info);
+ if (info != 0) {
+ ++ninfo;
+ lmax[0] = knt;
+ }
+
+ slacpy_("FULL", &n, &m, vl, &c__50, vlf, &c__50);
+ slacpy_("FULL", &n, &m, vr, &c__50, vrf, &c__50);
+
+ sggbak_("B", "L", &n, &ilo, &ihi, lscale, rscale, &m, vl, &c__50, &info);
+ if (info != 0) {
+ ++ninfo;
+ lmax[1] = knt;
+ }
+
+ sggbak_("B", "R", &n, &ilo, &ihi, lscale, rscale, &m, vr, &c__50, &info);
+ if (info != 0) {
+ ++ninfo;
+ lmax[2] = knt;
+ }
+
+/* Test of SGGBAK */
+
+/* Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR */
+/* where tilde(A) denotes the transformed matrix. */
+
+ sgemm_("N", "N", &n, &m, &n, &c_b52, af, &c__50, vr, &c__50, &c_b55, work,
+ &c__50);
+ sgemm_("T", "N", &m, &m, &n, &c_b52, vl, &c__50, work, &c__50, &c_b55, e,
+ &c__50);
+
+ sgemm_("N", "N", &n, &m, &n, &c_b52, a, &c__50, vrf, &c__50, &c_b55, work,
+ &c__50);
+ sgemm_("T", "N", &m, &m, &n, &c_b52, vlf, &c__50, work, &c__50, &c_b55, f,
+ &c__50);
+
+ vmax = 0.f;
+ i__1 = m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = vmax, r__3 = (r__1 = e[i__ + j * 50 - 51] - f[i__ + j * 50
+ - 51], dabs(r__1));
+ vmax = dmax(r__2,r__3);
+/* L60: */
+ }
+/* L70: */
+ }
+ vmax /= eps * dmax(anorm,bnorm);
+ if (vmax > rmax) {
+ lmax[3] = knt;
+ rmax = vmax;
+ }
+
+/* Check tilde(VL)'*B*tilde(VR) - VL'*tilde(B)*VR */
+
+ sgemm_("N", "N", &n, &m, &n, &c_b52, bf, &c__50, vr, &c__50, &c_b55, work,
+ &c__50);
+ sgemm_("T", "N", &m, &m, &n, &c_b52, vl, &c__50, work, &c__50, &c_b55, e,
+ &c__50);
+
+ sgemm_("N", "N", &n, &m, &n, &c_b52, b, &c__50, vrf, &c__50, &c_b55, work,
+ &c__50);
+ sgemm_("T", "N", &m, &m, &n, &c_b52, vlf, &c__50, work, &c__50, &c_b55, f,
+ &c__50);
+
+ vmax = 0.f;
+ i__1 = m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = vmax, r__3 = (r__1 = e[i__ + j * 50 - 51] - f[i__ + j * 50
+ - 51], dabs(r__1));
+ vmax = dmax(r__2,r__3);
+/* L80: */
+ }
+/* L90: */
+ }
+ vmax /= eps * dmax(anorm,bnorm);
+ if (vmax > rmax) {
+ lmax[3] = knt;
+ rmax = vmax;
+ }
+
+ goto L10;
+
+L100:
+
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ e_wsfe();
+
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, (char *)&lmax[3], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ return 0;
+
+/* End of SCHKGK */
+
+} /* schkgk_ */
diff --git a/TESTING/EIG/schkgl.c b/TESTING/EIG/schkgl.c
new file mode 100644
index 0000000..7a280fc
--- /dev/null
+++ b/TESTING/EIG/schkgl.c
@@ -0,0 +1,307 @@
+/* schkgl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c__20 = 20;
+
+/* Subroutine */ int schkgl_(integer *nin, integer *nout)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002.. test output of SGGBAL .. \002)";
+ static char fmt_9998[] = "(1x,\002value of largest test error "
+ " = \002,e12.3)";
+ static char fmt_9997[] = "(1x,\002example number where info is not zero "
+ " = \002,i4)";
+ static char fmt_9996[] = "(1x,\002example number where ILO or IHI wrong "
+ " = \002,i4)";
+ static char fmt_9995[] = "(1x,\002example number having largest error "
+ " = \002,i4)";
+ static char fmt_9994[] = "(1x,\002number of examples where info is not 0"
+ " = \002,i4)";
+ static char fmt_9993[] = "(1x,\002total number of examples tested "
+ " = \002,i4)";
+
+ /* System generated locals */
+ integer i__1, i__2;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void), s_wsfe(cilist *), e_wsfe(void), do_fio(integer *,
+ char *, ftnlen);
+
+ /* Local variables */
+ real a[400] /* was [20][20] */, b[400] /* was [20][20] */;
+ integer i__, j, n;
+ real ain[400] /* was [20][20] */, bin[400] /* was [20][20] */;
+ integer ihi, ilo;
+ real eps;
+ integer knt, info, lmax[5];
+ real rmax, vmax, work[120];
+ integer ihiin, ninfo, iloin;
+ real anorm, bnorm;
+ extern /* Subroutine */ int sggbal_(char *, integer *, real *, integer *,
+ real *, integer *, integer *, integer *, real *, real *, real *,
+ integer *);
+ real lscale[20];
+ extern doublereal slamch_(char *);
+ real rscale[20];
+ extern doublereal slange_(char *, integer *, integer *, real *, integer *,
+ real *);
+ real lsclin[20], rsclin[20];
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 0, 0, 0, 0 };
+ static cilist io___9 = { 0, 0, 0, 0, 0 };
+ static cilist io___12 = { 0, 0, 0, 0, 0 };
+ static cilist io___14 = { 0, 0, 0, 0, 0 };
+ static cilist io___17 = { 0, 0, 0, 0, 0 };
+ static cilist io___19 = { 0, 0, 0, 0, 0 };
+ static cilist io___21 = { 0, 0, 0, 0, 0 };
+ static cilist io___23 = { 0, 0, 0, 0, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKGL tests SGGBAL, a routine for balancing a matrix pair (A, B). */
+
+/* Arguments */
+/* ========= */
+
+/* NIN (input) INTEGER */
+/* The logical unit number for input. NIN > 0. */
+
+/* NOUT (input) INTEGER */
+/* The logical unit number for output. NOUT > 0. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ lmax[0] = 0;
+ lmax[1] = 0;
+ lmax[2] = 0;
+ ninfo = 0;
+ knt = 0;
+ rmax = 0.f;
+
+ eps = slamch_("Precision");
+
+L10:
+
+ io___6.ciunit = *nin;
+ s_rsle(&io___6);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ goto L90;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___9.ciunit = *nin;
+ s_rsle(&io___9);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__4, &c__1, (char *)&a[i__ + j * 20 - 21], (ftnlen)
+ sizeof(real));
+ }
+ e_rsle();
+/* L20: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___12.ciunit = *nin;
+ s_rsle(&io___12);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__4, &c__1, (char *)&b[i__ + j * 20 - 21], (ftnlen)
+ sizeof(real));
+ }
+ e_rsle();
+/* L30: */
+ }
+
+ io___14.ciunit = *nin;
+ s_rsle(&io___14);
+ do_lio(&c__3, &c__1, (char *)&iloin, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ihiin, (ftnlen)sizeof(integer));
+ e_rsle();
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___17.ciunit = *nin;
+ s_rsle(&io___17);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__4, &c__1, (char *)&ain[i__ + j * 20 - 21], (ftnlen)
+ sizeof(real));
+ }
+ e_rsle();
+/* L40: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___19.ciunit = *nin;
+ s_rsle(&io___19);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__4, &c__1, (char *)&bin[i__ + j * 20 - 21], (ftnlen)
+ sizeof(real));
+ }
+ e_rsle();
+/* L50: */
+ }
+
+ io___21.ciunit = *nin;
+ s_rsle(&io___21);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__4, &c__1, (char *)&lsclin[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_rsle();
+ io___23.ciunit = *nin;
+ s_rsle(&io___23);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__4, &c__1, (char *)&rsclin[i__ - 1], (ftnlen)sizeof(real));
+ }
+ e_rsle();
+
+ anorm = slange_("M", &n, &n, a, &c__20, work);
+ bnorm = slange_("M", &n, &n, b, &c__20, work);
+
+ ++knt;
+
+ sggbal_("B", &n, a, &c__20, b, &c__20, &ilo, &ihi, lscale, rscale, work, &
+ info);
+
+ if (info != 0) {
+ ++ninfo;
+ lmax[0] = knt;
+ }
+
+ if (ilo != iloin || ihi != ihiin) {
+ ++ninfo;
+ lmax[1] = knt;
+ }
+
+ vmax = 0.f;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ r__2 = vmax, r__3 = (r__1 = a[i__ + j * 20 - 21] - ain[i__ + j *
+ 20 - 21], dabs(r__1));
+ vmax = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = vmax, r__3 = (r__1 = b[i__ + j * 20 - 21] - bin[i__ + j *
+ 20 - 21], dabs(r__1));
+ vmax = dmax(r__2,r__3);
+/* L60: */
+ }
+/* L70: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = vmax, r__3 = (r__1 = lscale[i__ - 1] - lsclin[i__ - 1], dabs(
+ r__1));
+ vmax = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = vmax, r__3 = (r__1 = rscale[i__ - 1] - rsclin[i__ - 1], dabs(
+ r__1));
+ vmax = dmax(r__2,r__3);
+/* L80: */
+ }
+
+ vmax /= eps * dmax(anorm,bnorm);
+
+ if (vmax > rmax) {
+ lmax[2] = knt;
+ rmax = vmax;
+ }
+
+ goto L10;
+
+L90:
+
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ e_wsfe();
+
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(real));
+ e_wsfe();
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ return 0;
+
+/* End of SCHKGL */
+
+} /* schkgl_ */
diff --git a/TESTING/EIG/schkhs.c b/TESTING/EIG/schkhs.c
new file mode 100644
index 0000000..33a7346
--- /dev/null
+++ b/TESTING/EIG/schkhs.c
@@ -0,0 +1,1449 @@
+/* schkhs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b18 = 0.f;
+static integer c__0 = 0;
+static real c_b32 = 1.f;
+static integer c__4 = 4;
+static integer c__6 = 6;
+static integer c__1 = 1;
+
+/* Subroutine */ int schkhs_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, integer *nounit, real *
+ a, integer *lda, real *h__, real *t1, real *t2, real *u, integer *ldu,
+ real *z__, real *uz, real *wr1, real *wi1, real *wr3, real *wi3,
+ real *evectl, real *evectr, real *evecty, real *evectx, real *uu,
+ real *tau, real *work, integer *nwork, integer *iwork, logical *
+ select, real *result, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
+ static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
+ static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 SCHKHS: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 SCHKHS: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
+ "i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9997[] = "(\002 SCHKHS: Selected \002,a,\002 Eigenvector"
+ "s from \002,a,\002 do not match other eigenvectors \002,9x,\002N="
+ "\002,i6,\002, JTYPE=\002,i6,\002, ISEED=(\002,3(i5,\002,\002),i5,"
+ "\002)\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, evectl_dim1, evectl_offset, evectr_dim1,
+ evectr_offset, evectx_dim1, evectx_offset, evecty_dim1,
+ evecty_offset, h_dim1, h_offset, t1_dim1, t1_offset, t2_dim1,
+ t2_offset, u_dim1, u_offset, uu_dim1, uu_offset, uz_dim1,
+ uz_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4, r__5, r__6;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n, n1, jj, in, ihi, ilo;
+ real ulp, cond;
+ integer jcol, nmax;
+ real unfl, ovfl, temp1, temp2;
+ logical badnn, match;
+ integer imode;
+ real dumma[6];
+ integer iinfo, nselc;
+ real conds;
+ extern /* Subroutine */ int sget10_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *), sgemm_(char *, char *,
+ integer *, integer *, integer *, real *, real *, integer *, real *
+, integer *, real *, real *, integer *), sget22_(
+ char *, char *, char *, integer *, real *, integer *, real *,
+ integer *, real *, real *, real *, real *)
+ ;
+ real aninv, anorm;
+ integer nmats, nselr, jsize;
+ extern /* Subroutine */ int shst01_(integer *, integer *, integer *, real
+ *, integer *, real *, integer *, real *, integer *, real *,
+ integer *, real *);
+ integer nerrs, itype, jtype, ntest;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ real rtulp;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ char adumma[1*1];
+ extern doublereal slamch_(char *);
+ integer idumma[1];
+ extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int xerbla_(char *, integer *), slatme_(
+ integer *, char *, integer *, real *, integer *, real *, real *,
+ char *, char *, char *, char *, real *, integer *, real *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), shsein_(char *, char *,
+ char *, logical *, integer *, real *, integer *, real *, real *,
+ real *, integer *, real *, integer *, integer *, integer *, real *
+, integer *, integer *, integer *),
+ slacpy_(char *, integer *, integer *, real *, integer *, real *,
+ integer *), slafts_(char *, integer *, integer *, integer
+ *, integer *, real *, integer *, real *, integer *, integer *), slaset_(char *, integer *, integer *, real *, real *,
+ real *, integer *), slatmr_(integer *, integer *, char *,
+ integer *, char *, real *, integer *, real *, real *, char *,
+ char *, real *, integer *, real *, real *, integer *, real *,
+ char *, integer *, integer *, integer *, real *, real *, char *,
+ real *, integer *, integer *, integer *), slatms_(integer *, integer *, char *,
+ integer *, char *, real *, integer *, real *, real *, integer *,
+ integer *, char *, real *, integer *, real *, integer *), shseqr_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, real *, integer *,
+ real *, integer *, integer *), slasum_(char *,
+ integer *, integer *, integer *), sorghr_(integer *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, integer *), strevc_(char *, char *, logical *, integer *, real *
+, integer *, real *, integer *, real *, integer *, integer *,
+ integer *, real *, integer *);
+ real rtunfl, rtovfl, rtulpi, ulpinv;
+ integer mtypes, ntestt;
+ extern /* Subroutine */ int sormhr_(char *, char *, integer *, integer *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKHS checks the nonsymmetric eigenvalue problem routines. */
+
+/* SGEHRD factors A as U H U' , where ' means transpose, */
+/* H is hessenberg, and U is an orthogonal matrix. */
+
+/* SORGHR generates the orthogonal matrix U. */
+
+/* SORMHR multiplies a matrix by the orthogonal matrix U. */
+
+/* SHSEQR factors H as Z T Z' , where Z is orthogonal and */
+/* T is "quasi-triangular", and the eigenvalue vector W. */
+
+/* STREVC computes the left and right eigenvector matrices */
+/* L and R for T. */
+
+/* SHSEIN computes the left and right eigenvector matrices */
+/* Y and X for H, using inverse iteration. */
+
+/* When SCHKHS is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 14 */
+/* tests will be performed: */
+
+/* (1) | A - U H U**T | / ( |A| n ulp ) */
+
+/* (2) | I - UU**T | / ( n ulp ) */
+
+/* (3) | H - Z T Z**T | / ( |H| n ulp ) */
+
+/* (4) | I - ZZ**T | / ( n ulp ) */
+
+/* (5) | A - UZ H (UZ)**T | / ( |A| n ulp ) */
+
+/* (6) | I - UZ (UZ)**T | / ( n ulp ) */
+
+/* (7) | T(Z computed) - T(Z not computed) | / ( |T| ulp ) */
+
+/* (8) | W(Z computed) - W(Z not computed) | / ( |W| ulp ) */
+
+/* (9) | TR - RW | / ( |T| |R| ulp ) */
+
+/* (10) | L**H T - W**H L | / ( |T| |L| ulp ) */
+
+/* (11) | HX - XW | / ( |H| |X| ulp ) */
+
+/* (12) | Y**H H - W**H Y | / ( |H| |Y| ulp ) */
+
+/* (13) | AX - XW | / ( |A| |X| ulp ) */
+
+/* (14) | Y**H A - W**H Y | / ( |A| |Y| ulp ) */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
+
+/* (4) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (5) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (7) Same as (4), but multiplied by SQRT( overflow threshold ) */
+/* (8) Same as (4), but multiplied by SQRT( underflow threshold ) */
+
+/* (9) A matrix of the form U' T U, where U is orthogonal and */
+/* T has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (10) A matrix of the form U' T U, where U is orthogonal and */
+/* T has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (11) A matrix of the form U' T U, where U is orthogonal and */
+/* T has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (12) A matrix of the form U' T U, where U is orthogonal and */
+/* T has real or complex conjugate paired eigenvalues randomly */
+/* chosen from ( ULP, 1 ) and random O(1) entries in the upper */
+/* triangle. */
+
+/* (13) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
+/* with random signs on the diagonal and random O(1) entries */
+/* in the upper triangle. */
+
+/* (14) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has geometrically spaced entries */
+/* 1, ..., ULP with random signs on the diagonal and random */
+/* O(1) entries in the upper triangle. */
+
+/* (15) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
+/* with random signs on the diagonal and random O(1) entries */
+/* in the upper triangle. */
+
+/* (16) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has real or complex conjugate paired */
+/* eigenvalues randomly chosen from ( ULP, 1 ) and random */
+/* O(1) entries in the upper triangle. */
+
+/* (17) Same as (16), but multiplied by SQRT( overflow threshold ) */
+/* (18) Same as (16), but multiplied by SQRT( underflow threshold ) */
+
+/* (19) Nonsymmetric matrix with random entries chosen from (-1,1). */
+/* (20) Same as (19), but multiplied by SQRT( overflow threshold ) */
+/* (21) Same as (19), but multiplied by SQRT( underflow threshold ) */
+
+/* Arguments */
+/* ========== */
+
+/* NSIZES - INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* SCHKHS does nothing. It must be at least zero. */
+/* Not modified. */
+
+/* NN - INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+/* Not modified. */
+
+/* NTYPES - INTEGER */
+/* The number of elements in DOTYPE. If it is zero, SCHKHS */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+/* Not modified. */
+
+/* DOTYPE - LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to SCHKHS to continue the same random number */
+/* sequence. */
+/* Modified. */
+
+/* THRESH - REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+/* Not modified. */
+
+/* NOUNIT - INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+/* Not modified. */
+
+/* A - REAL array, dimension (LDA,max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually */
+/* used. */
+/* Modified. */
+
+/* LDA - INTEGER */
+/* The leading dimension of A, H, T1 and T2. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* H - REAL array, dimension (LDA,max(NN)) */
+/* The upper hessenberg matrix computed by SGEHRD. On exit, */
+/* H contains the Hessenberg form of the matrix in A. */
+/* Modified. */
+
+/* T1 - REAL array, dimension (LDA,max(NN)) */
+/* The Schur (="quasi-triangular") matrix computed by SHSEQR */
+/* if Z is computed. On exit, T1 contains the Schur form of */
+/* the matrix in A. */
+/* Modified. */
+
+/* T2 - REAL array, dimension (LDA,max(NN)) */
+/* The Schur matrix computed by SHSEQR when Z is not computed. */
+/* This should be identical to T1. */
+/* Modified. */
+
+/* LDU - INTEGER */
+/* The leading dimension of U, Z, UZ and UU. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* U - REAL array, dimension (LDU,max(NN)) */
+/* The orthogonal matrix computed by SGEHRD. */
+/* Modified. */
+
+/* Z - REAL array, dimension (LDU,max(NN)) */
+/* The orthogonal matrix computed by SHSEQR. */
+/* Modified. */
+
+/* UZ - REAL array, dimension (LDU,max(NN)) */
+/* The product of U times Z. */
+/* Modified. */
+
+/* WR1 - REAL array, dimension (max(NN)) */
+/* WI1 - REAL array, dimension (max(NN)) */
+/* The real and imaginary parts of the eigenvalues of A, */
+/* as computed when Z is computed. */
+/* On exit, WR1 + WI1*i are the eigenvalues of the matrix in A. */
+/* Modified. */
+
+/* WR3 - REAL array, dimension (max(NN)) */
+/* WI3 - REAL array, dimension (max(NN)) */
+/* Like WR1, WI1, these arrays contain the eigenvalues of A, */
+/* but those computed when SHSEQR only computes the */
+/* eigenvalues, i.e., not the Schur vectors and no more of the */
+/* Schur form than is necessary for computing the */
+/* eigenvalues. */
+/* Modified. */
+
+/* EVECTL - REAL array, dimension (LDU,max(NN)) */
+/* The (upper triangular) left eigenvector matrix for the */
+/* matrix in T1. For complex conjugate pairs, the real part */
+/* is stored in one row and the imaginary part in the next. */
+/* Modified. */
+
+/* EVECTR - REAL array, dimension (LDU,max(NN)) */
+/* The (upper triangular) right eigenvector matrix for the */
+/* matrix in T1. For complex conjugate pairs, the real part */
+/* is stored in one column and the imaginary part in the next. */
+/* Modified. */
+
+/* EVECTY - REAL array, dimension (LDU,max(NN)) */
+/* The left eigenvector matrix for the */
+/* matrix in H. For complex conjugate pairs, the real part */
+/* is stored in one row and the imaginary part in the next. */
+/* Modified. */
+
+/* EVECTX - REAL array, dimension (LDU,max(NN)) */
+/* The right eigenvector matrix for the */
+/* matrix in H. For complex conjugate pairs, the real part */
+/* is stored in one column and the imaginary part in the next. */
+/* Modified. */
+
+/* UU - REAL array, dimension (LDU,max(NN)) */
+/* Details of the orthogonal matrix computed by SGEHRD. */
+/* Modified. */
+
+/* TAU - REAL array, dimension(max(NN)) */
+/* Further details of the orthogonal matrix computed by SGEHRD. */
+/* Modified. */
+
+/* WORK - REAL array, dimension (NWORK) */
+/* Workspace. */
+/* Modified. */
+
+/* NWORK - INTEGER */
+/* The number of entries in WORK. NWORK >= 4*NN(j)*NN(j) + 2. */
+
+/* IWORK - INTEGER array, dimension (max(NN)) */
+/* Workspace. */
+/* Modified. */
+
+/* SELECT - LOGICAL array, dimension (max(NN)) */
+/* Workspace. */
+/* Modified. */
+
+/* RESULT - REAL array, dimension (14) */
+/* The values computed by the fourteen tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+/* Modified. */
+
+/* INFO - INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -6: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -14: LDU < 1 or LDU < NMAX. */
+/* -28: NWORK too small. */
+/* If SLATMR, SLATMS, or SLATME returns an error code, the */
+/* absolute value of it is returned. */
+/* If 1, then SHSEQR could not find all the shifts. */
+/* If 2, then the EISPACK code (for small blocks) failed. */
+/* If >2, then 30*N iterations were not enough to find an */
+/* eigenvalue or to decompose the problem. */
+/* Modified. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* MTEST The number of tests defined: care must be taken */
+/* that (1) the size of RESULT, (2) the number of */
+/* tests actually performed, and (3) MTEST agree. */
+/* NTEST The number of tests performed on this matrix */
+/* so far. This should be less than MTEST, and */
+/* equal to it by the last test. It will be less */
+/* if any of the routines being tested indicates */
+/* that it could not compute the matrices that */
+/* would be tested. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far (computed by SLAFTS). */
+/* COND, CONDS, */
+/* IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL, */
+/* RTULP, RTULPI Square roots of the previous 4 values. */
+
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+/* KCONDS(j) Selects whether CONDS is to be 1 or */
+/* 1/sqrt(ulp). (0 means irrelevant.) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ t2_dim1 = *lda;
+ t2_offset = 1 + t2_dim1;
+ t2 -= t2_offset;
+ t1_dim1 = *lda;
+ t1_offset = 1 + t1_dim1;
+ t1 -= t1_offset;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ uu_dim1 = *ldu;
+ uu_offset = 1 + uu_dim1;
+ uu -= uu_offset;
+ evectx_dim1 = *ldu;
+ evectx_offset = 1 + evectx_dim1;
+ evectx -= evectx_offset;
+ evecty_dim1 = *ldu;
+ evecty_offset = 1 + evecty_dim1;
+ evecty -= evecty_offset;
+ evectr_dim1 = *ldu;
+ evectr_offset = 1 + evectr_dim1;
+ evectr -= evectr_offset;
+ evectl_dim1 = *ldu;
+ evectl_offset = 1 + evectl_dim1;
+ evectl -= evectl_offset;
+ uz_dim1 = *ldu;
+ uz_offset = 1 + uz_dim1;
+ uz -= uz_offset;
+ z_dim1 = *ldu;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --wr1;
+ --wi1;
+ --wr3;
+ --wi3;
+ --tau;
+ --work;
+ --iwork;
+ --select;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 0;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.f) {
+ *info = -6;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldu <= 1 || *ldu < nmax) {
+ *info = -14;
+ } else if ((nmax << 2) * nmax + 2 > *nwork) {
+ *info = -28;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SCHKHS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More important constants */
+
+ unfl = slamch_("Safe minimum");
+ ovfl = slamch_("Overflow");
+ slabad_(&unfl, &ovfl);
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ ulpinv = 1.f / ulp;
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+ rtulp = sqrt(ulp);
+ rtulpi = 1.f / rtulp;
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (n == 0) {
+ goto L270;
+ }
+ n1 = max(1,n);
+ aninv = 1.f / (real) n1;
+
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L260;
+ }
+ ++nmats;
+ ntest = 0;
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 14; ++j) {
+ result[j] = 0.f;
+/* L30: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KCONDS KMODE KTYPE */
+/* =1 O(1) 1 clustered 1 zero */
+/* =2 large large clustered 2 identity */
+/* =3 small exponential Jordan */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random general, w/ eigenvalues */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 random general */
+/* =10 random triangular */
+
+ if (mtypes > 21) {
+ goto L100;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.f;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * aninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * n * ulpinv;
+ goto L70;
+
+L70:
+
+ slaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices */
+
+ if (itype == 1) {
+
+/* Zero */
+
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+/* L80: */
+ }
+
+ } else if (itype == 3) {
+
+/* Jordan Block */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+ if (jcol > 1) {
+ a[jcol + (jcol - 1) * a_dim1] = 1.f;
+ }
+/* L90: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 6) {
+
+/* General, eigenvalues specified */
+
+ if (kconds[jtype - 1] == 1) {
+ conds = 1.f;
+ } else if (kconds[jtype - 1] == 2) {
+ conds = rtulpi;
+ } else {
+ conds = 0.f;
+ }
+
+ *(unsigned char *)&adumma[0] = ' ';
+ slatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b32,
+ adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
+ n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
+ &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &c__0, &
+ c__0, &c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
+ c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* General, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
+ c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 10) {
+
+/* Triangular, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &c__0, &
+ c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___36.ciunit = *nounit;
+ s_wsfe(&io___36);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L100:
+
+/* Call SGEHRD to compute H and U, do tests. */
+
+ slacpy_(" ", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+
+ ntest = 1;
+
+ ilo = 1;
+ ihi = n;
+
+ i__3 = *nwork - n;
+ sgehrd_(&n, &ilo, &ihi, &h__[h_offset], lda, &work[1], &work[n +
+ 1], &i__3, &iinfo);
+
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___39.ciunit = *nounit;
+ s_wsfe(&io___39);
+ do_fio(&c__1, "SGEHRD", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+ i__3 = n - 1;
+ for (j = 1; j <= i__3; ++j) {
+ uu[j + 1 + j * uu_dim1] = 0.f;
+ i__4 = n;
+ for (i__ = j + 2; i__ <= i__4; ++i__) {
+ u[i__ + j * u_dim1] = h__[i__ + j * h_dim1];
+ uu[i__ + j * uu_dim1] = h__[i__ + j * h_dim1];
+ h__[i__ + j * h_dim1] = 0.f;
+/* L110: */
+ }
+/* L120: */
+ }
+ i__3 = n - 1;
+ scopy_(&i__3, &work[1], &c__1, &tau[1], &c__1);
+ i__3 = *nwork - n;
+ sorghr_(&n, &ilo, &ihi, &u[u_offset], ldu, &work[1], &work[n + 1],
+ &i__3, &iinfo);
+ ntest = 2;
+
+ shst01_(&n, &ilo, &ihi, &a[a_offset], lda, &h__[h_offset], lda, &
+ u[u_offset], ldu, &work[1], nwork, &result[1]);
+
+/* Call SHSEQR to compute T1, T2 and Z, do tests. */
+
+/* Eigenvalues only (WR3,WI3) */
+
+ slacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
+ ntest = 3;
+ result[3] = ulpinv;
+
+ shseqr_("E", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &wr3[1], &
+ wi3[1], &uz[uz_offset], ldu, &work[1], nwork, &iinfo);
+ if (iinfo != 0) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "SHSEQR(E)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ if (iinfo <= n + 2) {
+ *info = abs(iinfo);
+ goto L250;
+ }
+ }
+
+/* Eigenvalues (WR1,WI1) and Full Schur Form (T2) */
+
+ slacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
+
+ shseqr_("S", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &wr1[1], &
+ wi1[1], &uz[uz_offset], ldu, &work[1], nwork, &iinfo);
+ if (iinfo != 0 && iinfo <= n + 2) {
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "SHSEQR(S)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Eigenvalues (WR1,WI1), Schur Form (T1), and Schur vectors */
+/* (UZ) */
+
+ slacpy_(" ", &n, &n, &h__[h_offset], lda, &t1[t1_offset], lda);
+ slacpy_(" ", &n, &n, &u[u_offset], ldu, &uz[uz_offset], lda);
+
+ shseqr_("S", "V", &n, &ilo, &ihi, &t1[t1_offset], lda, &wr1[1], &
+ wi1[1], &uz[uz_offset], ldu, &work[1], nwork, &iinfo);
+ if (iinfo != 0 && iinfo <= n + 2) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "SHSEQR(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Compute Z = U' UZ */
+
+ sgemm_("T", "N", &n, &n, &n, &c_b32, &u[u_offset], ldu, &uz[
+ uz_offset], ldu, &c_b18, &z__[z_offset], ldu);
+ ntest = 8;
+
+/* Do Tests 3: | H - Z T Z' | / ( |H| n ulp ) */
+/* and 4: | I - Z Z' | / ( n ulp ) */
+
+ shst01_(&n, &ilo, &ihi, &h__[h_offset], lda, &t1[t1_offset], lda,
+ &z__[z_offset], ldu, &work[1], nwork, &result[3]);
+
+/* Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp ) */
+/* and 6: | I - UZ (UZ)' | / ( n ulp ) */
+
+ shst01_(&n, &ilo, &ihi, &a[a_offset], lda, &t1[t1_offset], lda, &
+ uz[uz_offset], ldu, &work[1], nwork, &result[5]);
+
+/* Do Test 7: | T2 - T1 | / ( |T| n ulp ) */
+
+ sget10_(&n, &n, &t2[t2_offset], lda, &t1[t1_offset], lda, &work[1]
+, &result[7]);
+
+/* Do Test 8: | W3 - W1 | / ( max(|W1|,|W3|) ulp ) */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__5 = temp1, r__6 = (r__1 = wr1[j], dabs(r__1)) + (r__2 =
+ wi1[j], dabs(r__2)), r__5 = max(r__5,r__6), r__6 = (
+ r__3 = wr3[j], dabs(r__3)) + (r__4 = wi3[j], dabs(
+ r__4));
+ temp1 = dmax(r__5,r__6);
+/* Computing MAX */
+ r__3 = temp2, r__4 = (r__1 = wr1[j] - wr3[j], dabs(r__1)) + (
+ r__2 = wr1[j] - wr3[j], dabs(r__2));
+ temp2 = dmax(r__3,r__4);
+/* L130: */
+ }
+
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[8] = temp2 / dmax(r__1,r__2);
+
+/* Compute the Left and Right Eigenvectors of T */
+
+/* Compute the Right eigenvector Matrix: */
+
+ ntest = 9;
+ result[9] = ulpinv;
+
+/* Select last max(N/4,1) real, max(N/4,1) complex eigenvectors */
+
+ nselc = 0;
+ nselr = 0;
+ j = n;
+L140:
+ if (wi1[j] == 0.f) {
+/* Computing MAX */
+ i__3 = n / 4;
+ if (nselr < max(i__3,1)) {
+ ++nselr;
+ select[j] = TRUE_;
+ } else {
+ select[j] = FALSE_;
+ }
+ --j;
+ } else {
+/* Computing MAX */
+ i__3 = n / 4;
+ if (nselc < max(i__3,1)) {
+ ++nselc;
+ select[j] = TRUE_;
+ select[j - 1] = FALSE_;
+ } else {
+ select[j] = FALSE_;
+ select[j - 1] = FALSE_;
+ }
+ j += -2;
+ }
+ if (j > 0) {
+ goto L140;
+ }
+
+ strevc_("Right", "All", &select[1], &n, &t1[t1_offset], lda,
+ dumma, ldu, &evectr[evectr_offset], ldu, &n, &in, &work[1]
+, &iinfo);
+ if (iinfo != 0) {
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ do_fio(&c__1, "STREVC(R,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Test 9: | TR - RW | / ( |T| |R| ulp ) */
+
+ sget22_("N", "N", "N", &n, &t1[t1_offset], lda, &evectr[
+ evectr_offset], ldu, &wr1[1], &wi1[1], &work[1], dumma);
+ result[9] = dumma[0];
+ if (dumma[1] > *thresh) {
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "STREVC", (ftnlen)6);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Compute selected right eigenvectors and confirm that */
+/* they agree with previous right eigenvectors */
+
+ strevc_("Right", "Some", &select[1], &n, &t1[t1_offset], lda,
+ dumma, ldu, &evectl[evectl_offset], ldu, &n, &in, &work[1]
+, &iinfo);
+ if (iinfo != 0) {
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "STREVC(R,S)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+ k = 1;
+ match = TRUE_;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ if (select[j] && wi1[j] == 0.f) {
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ if (evectr[jj + j * evectr_dim1] != evectl[jj + k *
+ evectl_dim1]) {
+ match = FALSE_;
+ goto L180;
+ }
+/* L150: */
+ }
+ ++k;
+ } else if (select[j] && wi1[j] != 0.f) {
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ if (evectr[jj + j * evectr_dim1] != evectl[jj + k *
+ evectl_dim1] || evectr[jj + (j + 1) *
+ evectr_dim1] != evectl[jj + (k + 1) *
+ evectl_dim1]) {
+ match = FALSE_;
+ goto L180;
+ }
+/* L160: */
+ }
+ k += 2;
+ }
+/* L170: */
+ }
+L180:
+ if (! match) {
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "STREVC", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Compute the Left eigenvector Matrix: */
+
+ ntest = 10;
+ result[10] = ulpinv;
+ strevc_("Left", "All", &select[1], &n, &t1[t1_offset], lda, &
+ evectl[evectl_offset], ldu, dumma, ldu, &n, &in, &work[1],
+ &iinfo);
+ if (iinfo != 0) {
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, "STREVC(L,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Test 10: | LT - WL | / ( |T| |L| ulp ) */
+
+ sget22_("Trans", "N", "Conj", &n, &t1[t1_offset], lda, &evectl[
+ evectl_offset], ldu, &wr1[1], &wi1[1], &work[1], &dumma[2]
+);
+ result[10] = dumma[2];
+ if (dumma[3] > *thresh) {
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "STREVC", (ftnlen)6);
+ do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Compute selected left eigenvectors and confirm that */
+/* they agree with previous left eigenvectors */
+
+ strevc_("Left", "Some", &select[1], &n, &t1[t1_offset], lda, &
+ evectr[evectr_offset], ldu, dumma, ldu, &n, &in, &work[1],
+ &iinfo);
+ if (iinfo != 0) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, "STREVC(L,S)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+ k = 1;
+ match = TRUE_;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ if (select[j] && wi1[j] == 0.f) {
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ if (evectl[jj + j * evectl_dim1] != evectr[jj + k *
+ evectr_dim1]) {
+ match = FALSE_;
+ goto L220;
+ }
+/* L190: */
+ }
+ ++k;
+ } else if (select[j] && wi1[j] != 0.f) {
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ if (evectl[jj + j * evectl_dim1] != evectr[jj + k *
+ evectr_dim1] || evectl[jj + (j + 1) *
+ evectl_dim1] != evectr[jj + (k + 1) *
+ evectr_dim1]) {
+ match = FALSE_;
+ goto L220;
+ }
+/* L200: */
+ }
+ k += 2;
+ }
+/* L210: */
+ }
+L220:
+ if (! match) {
+ io___60.ciunit = *nounit;
+ s_wsfe(&io___60);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "STREVC", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Call SHSEIN for Right eigenvectors of H, do test 11 */
+
+ ntest = 11;
+ result[11] = ulpinv;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ select[j] = TRUE_;
+/* L230: */
+ }
+
+ shsein_("Right", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
+ lda, &wr3[1], &wi3[1], dumma, ldu, &evectx[evectx_offset],
+ ldu, &n1, &in, &work[1], &iwork[1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___61.ciunit = *nounit;
+ s_wsfe(&io___61);
+ do_fio(&c__1, "SHSEIN(R)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ goto L250;
+ }
+ } else {
+
+/* Test 11: | HX - XW | / ( |H| |X| ulp ) */
+
+/* (from inverse iteration) */
+
+ sget22_("N", "N", "N", &n, &h__[h_offset], lda, &evectx[
+ evectx_offset], ldu, &wr3[1], &wi3[1], &work[1],
+ dumma);
+ if (dumma[0] < ulpinv) {
+ result[11] = dumma[0] * aninv;
+ }
+ if (dumma[1] > *thresh) {
+ io___62.ciunit = *nounit;
+ s_wsfe(&io___62);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "SHSEIN", (ftnlen)6);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ }
+ }
+
+/* Call SHSEIN for Left eigenvectors of H, do test 12 */
+
+ ntest = 12;
+ result[12] = ulpinv;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ select[j] = TRUE_;
+/* L240: */
+ }
+
+ shsein_("Left", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
+ lda, &wr3[1], &wi3[1], &evecty[evecty_offset], ldu, dumma,
+ ldu, &n1, &in, &work[1], &iwork[1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___63.ciunit = *nounit;
+ s_wsfe(&io___63);
+ do_fio(&c__1, "SHSEIN(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ goto L250;
+ }
+ } else {
+
+/* Test 12: | YH - WY | / ( |H| |Y| ulp ) */
+
+/* (from inverse iteration) */
+
+ sget22_("C", "N", "C", &n, &h__[h_offset], lda, &evecty[
+ evecty_offset], ldu, &wr3[1], &wi3[1], &work[1], &
+ dumma[2]);
+ if (dumma[2] < ulpinv) {
+ result[12] = dumma[2] * aninv;
+ }
+ if (dumma[3] > *thresh) {
+ io___64.ciunit = *nounit;
+ s_wsfe(&io___64);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "SHSEIN", (ftnlen)6);
+ do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ }
+ }
+
+/* Call SORMHR for Right eigenvectors of A, do test 13 */
+
+ ntest = 13;
+ result[13] = ulpinv;
+
+ sormhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
+, ldu, &tau[1], &evectx[evectx_offset], ldu, &work[1],
+ nwork, &iinfo);
+ if (iinfo != 0) {
+ io___65.ciunit = *nounit;
+ s_wsfe(&io___65);
+ do_fio(&c__1, "SORMHR(R)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ goto L250;
+ }
+ } else {
+
+/* Test 13: | AX - XW | / ( |A| |X| ulp ) */
+
+/* (from inverse iteration) */
+
+ sget22_("N", "N", "N", &n, &a[a_offset], lda, &evectx[
+ evectx_offset], ldu, &wr3[1], &wi3[1], &work[1],
+ dumma);
+ if (dumma[0] < ulpinv) {
+ result[13] = dumma[0] * aninv;
+ }
+ }
+
+/* Call SORMHR for Left eigenvectors of A, do test 14 */
+
+ ntest = 14;
+ result[14] = ulpinv;
+
+ sormhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
+, ldu, &tau[1], &evecty[evecty_offset], ldu, &work[1],
+ nwork, &iinfo);
+ if (iinfo != 0) {
+ io___66.ciunit = *nounit;
+ s_wsfe(&io___66);
+ do_fio(&c__1, "SORMHR(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ goto L250;
+ }
+ } else {
+
+/* Test 14: | YA - WY | / ( |A| |Y| ulp ) */
+
+/* (from inverse iteration) */
+
+ sget22_("C", "N", "C", &n, &a[a_offset], lda, &evecty[
+ evecty_offset], ldu, &wr3[1], &wi3[1], &work[1], &
+ dumma[2]);
+ if (dumma[2] < ulpinv) {
+ result[14] = dumma[2] * aninv;
+ }
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L250:
+
+ ntestt += ntest;
+ slafts_("SHS", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh,
+ nounit, &nerrs);
+
+L260:
+ ;
+ }
+L270:
+ ;
+ }
+
+/* Summary */
+
+ slasum_("SHS", nounit, &nerrs, &ntestt);
+
+ return 0;
+
+
+/* End of SCHKHS */
+
+} /* schkhs_ */
diff --git a/TESTING/EIG/schksb.c b/TESTING/EIG/schksb.c
new file mode 100644
index 0000000..21a3c93
--- /dev/null
+++ b/TESTING/EIG/schksb.c
@@ -0,0 +1,806 @@
+/* schksb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b18 = 0.f;
+static integer c__0 = 0;
+static integer c__6 = 6;
+static real c_b32 = 1.f;
+static integer c__1 = 1;
+static integer c__4 = 4;
+
+/* Subroutine */ int schksb_(integer *nsizes, integer *nn, integer *nwdths,
+ integer *kk, integer *ntypes, logical *dotype, integer *iseed, real *
+ thresh, integer *nounit, real *a, integer *lda, real *sd, real *se,
+ real *u, integer *ldu, real *work, integer *lwork, real *result,
+ integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[15] = { 1,2,4,4,4,4,4,5,5,5,5,5,8,8,8 };
+ static integer kmagn[15] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3 };
+ static integer kmode[15] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 SCHKSB: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(/1x,a3,\002 -- Real Symmetric Banded Tridiago"
+ "nal Reduction Routines\002)";
+ static char fmt_9997[] = "(\002 Matrix types (see SCHKSB for details):"
+ " \002)";
+ static char fmt_9996[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 5=Diagonal: clustered ent"
+ "ries.\002,/\002 2=Identity matrix. \002,\002"
+ " 6=Diagonal: large, evenly spaced.\002,/\002 3=Diagonal: evenl"
+ "y spaced entries. \002,\002 7=Diagonal: small, evenly spaced."
+ "\002,/\002 4=Diagonal: geometr. spaced entries.\002)";
+ static char fmt_9995[] = "(\002 Dense \002,a,\002 Banded Matrices:\002,"
+ "/\002 8=Evenly spaced eigenvals. \002,\002 12=Small,"
+ " evenly spaced eigenvals.\002,/\002 9=Geometrically spaced eige"
+ "nvals. \002,\002 13=Matrix with random O(1) entries.\002,"
+ "/\002 10=Clustered eigenvalues. \002,\002 14=Matrix"
+ " with large random entries.\002,/\002 11=Large, evenly spaced ei"
+ "genvals. \002,\002 15=Matrix with small random entries.\002)";
+ static char fmt_9994[] = "(/\002 Tests performed: (S is Tridiag, U "
+ "is \002,a,\002,\002,/20x,a,\002 means \002,a,\002.\002,/\002 UPL"
+ "O='U':\002,/\002 1= | A - U S U\002,a1,\002 | / ( |A| n ulp ) "
+ " \002,\002 2= | I - U U\002,a1,\002 | / ( n ulp )\002,/\002 U"
+ "PLO='L':\002,/\002 3= | A - U S U\002,a1,\002 | / ( |A| n ulp )"
+ " \002,\002 4= | I - U U\002,a1,\002 | / ( n ulp )\002)";
+ static char fmt_9993[] = "(\002 N=\002,i5,\002, K=\002,i4,\002, seed="
+ "\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)"
+ "=\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6, i__7;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n, jc, jr;
+ real ulp, cond;
+ integer jcol, kmax, nmax;
+ real unfl, ovfl, temp1;
+ logical badnn;
+ integer imode, iinfo;
+ real aninv, anorm;
+ extern /* Subroutine */ int ssbt21_(char *, integer *, integer *, integer
+ *, real *, integer *, real *, real *, real *, integer *, real *,
+ real *);
+ integer nmats, jsize, nerrs, itype, jtype, ntest;
+ logical badnnb;
+ extern doublereal slamch_(char *);
+ integer idumma[1], ioldsd[4];
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer jwidth;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *), ssbtrd_(
+ char *, char *, integer *, integer *, real *, integer *, real *,
+ real *, real *, integer *, real *, integer *),
+ slatmr_(integer *, integer *, char *, integer *, char *, real *,
+ integer *, real *, real *, char *, char *, real *, integer *,
+ real *, real *, integer *, real *, char *, integer *, integer *,
+ integer *, real *, real *, char *, real *, integer *, integer *,
+ integer *),
+ slatms_(integer *, integer *, char *, integer *, char *, real *,
+ integer *, real *, real *, integer *, integer *, char *, real *,
+ integer *, real *, integer *), slasum_(
+ char *, integer *, integer *, integer *);
+ real rtunfl, rtovfl, ulpinv;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKSB tests the reduction of a symmetric band matrix to tridiagonal */
+/* form, used with the symmetric eigenvalue problem. */
+
+/* SSBTRD factors a symmetric band matrix A as U S U' , where ' means */
+/* transpose, S is symmetric tridiagonal, and U is orthogonal. */
+/* SSBTRD can use either just the lower or just the upper triangle */
+/* of A; SCHKSB checks both cases. */
+
+/* When SCHKSB is called, a number of matrix "sizes" ("n's"), a number */
+/* of bandwidths ("k's"), and a number of matrix "types" are */
+/* specified. For each size ("n"), each bandwidth ("k") less than or */
+/* equal to "n", and each type of matrix, one matrix will be generated */
+/* and used to test the symmetric banded reduction routine. For each */
+/* matrix, a number of tests will be performed: */
+
+/* (1) | A - V S V' | / ( |A| n ulp ) computed by SSBTRD with */
+/* UPLO='U' */
+
+/* (2) | I - UU' | / ( n ulp ) */
+
+/* (3) | A - V S V' | / ( |A| n ulp ) computed by SSBTRD with */
+/* UPLO='L' */
+
+/* (4) | I - UU' | / ( n ulp ) */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (6) Same as (4), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (4), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U' D U, where U is orthogonal and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U' D U, where U is orthogonal and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U' D U, where U is orthogonal and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) Symmetric matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* SCHKSB does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NWDTHS (input) INTEGER */
+/* The number of bandwidths to use. If it is zero, */
+/* SCHKSB does nothing. It must be at least zero. */
+
+/* KK (input) INTEGER array, dimension (NWDTHS) */
+/* An array containing the bandwidths to be used for the band */
+/* matrices. The values must be at least zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, SCHKSB */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to SCHKSB to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace) REAL array, dimension */
+/* (LDA, max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 2 (not 1!) */
+/* and at least max( KK )+1. */
+
+/* SD (workspace) REAL array, dimension (max(NN)) */
+/* Used to hold the diagonal of the tridiagonal matrix computed */
+/* by SSBTRD. */
+
+/* SE (workspace) REAL array, dimension (max(NN)) */
+/* Used to hold the off-diagonal of the tridiagonal matrix */
+/* computed by SSBTRD. */
+
+/* U (workspace) REAL array, dimension (LDU, max(NN)) */
+/* Used to hold the orthogonal matrix computed by SSBTRD. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* max( LDA+1, max(NN)+1 )*max(NN). */
+
+/* RESULT (output) REAL array, dimension (4) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests performed, or which can */
+/* be performed so far, for the current matrix. */
+/* NTESTT The total number of tests performed so far. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far. */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --kk;
+ --dotype;
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --sd;
+ --se;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --work;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+ badnnb = FALSE_;
+ kmax = 0;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = kmax, i__3 = kk[j];
+ kmax = max(i__2,i__3);
+ if (kk[j] < 0) {
+ badnnb = TRUE_;
+ }
+/* L20: */
+ }
+/* Computing MIN */
+ i__1 = nmax - 1;
+ kmax = min(i__1,kmax);
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*nwdths < 0) {
+ *info = -3;
+ } else if (badnnb) {
+ *info = -4;
+ } else if (*ntypes < 0) {
+ *info = -5;
+ } else if (*lda < kmax + 1) {
+ *info = -11;
+ } else if (*ldu < nmax) {
+ *info = -15;
+ } else if ((max(*lda,nmax) + 1) * nmax > *lwork) {
+ *info = -17;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SCHKSB", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0 || *nwdths == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ ulpinv = 1.f / ulp;
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ aninv = 1.f / (real) max(1,n);
+
+ i__2 = *nwdths;
+ for (jwidth = 1; jwidth <= i__2; ++jwidth) {
+ k = kk[jwidth];
+ if (k > n) {
+ goto L180;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__5 = n - 1;
+ i__3 = 0, i__4 = min(i__5,k);
+ k = max(i__3,i__4);
+
+ if (*nsizes != 1) {
+ mtypes = min(15,*ntypes);
+ } else {
+ mtypes = min(16,*ntypes);
+ }
+
+ i__3 = mtypes;
+ for (jtype = 1; jtype <= i__3; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L170;
+ }
+ ++nmats;
+ ntest = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L30: */
+ }
+
+/* Compute "A". */
+/* Store as "Upper"; later, we will copy to other format. */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random (none) */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 positive definite */
+/* =10 diagonally dominant tridiagonal */
+
+ if (mtypes > 15) {
+ goto L100;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.f;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * aninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * n * ulpinv;
+ goto L70;
+
+L70:
+
+ slaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
+ iinfo = 0;
+ if (jtype <= 15) {
+ cond = ulpinv;
+ } else {
+ cond = ulpinv * aninv / 10.f;
+ }
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__4 = n;
+ for (jcol = 1; jcol <= i__4; ++jcol) {
+ a[k + 1 + jcol * a_dim1] = anorm;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &
+ cond, &anorm, &c__0, &c__0, "Q", &a[k + 1 +
+ a_dim1], lda, &work[n + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &
+ cond, &anorm, &k, &k, "Q", &a[a_offset], lda, &
+ work[n + 1], &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &
+ c_b32, &c_b32, "T", "N", &work[n + 1], &c__1, &
+ c_b32, &work[(n << 1) + 1], &c__1, &c_b32, "N",
+ idumma, &c__0, &c__0, &c_b18, &anorm, "Q", &a[k +
+ 1 + a_dim1], lda, idumma, &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &
+ c_b32, &c_b32, "T", "N", &work[n + 1], &c__1, &
+ c_b32, &work[(n << 1) + 1], &c__1, &c_b32, "N",
+ idumma, &k, &k, &c_b18, &anorm, "Q", &a[a_offset],
+ lda, idumma, &iinfo);
+
+ } else if (itype == 9) {
+
+/* Positive definite, eigenvalues specified. */
+
+ slatms_(&n, &n, "S", &iseed[1], "P", &work[1], &imode, &
+ cond, &anorm, &k, &k, "Q", &a[a_offset], lda, &
+ work[n + 1], &iinfo);
+
+ } else if (itype == 10) {
+
+/* Positive definite tridiagonal, eigenvalues specified. */
+
+ if (n > 1) {
+ k = max(1,k);
+ }
+ slatms_(&n, &n, "S", &iseed[1], "P", &work[1], &imode, &
+ cond, &anorm, &c__1, &c__1, "Q", &a[k + a_dim1],
+ lda, &work[n + 1], &iinfo);
+ i__4 = n;
+ for (i__ = 2; i__ <= i__4; ++i__) {
+ temp1 = (r__1 = a[k + i__ * a_dim1], dabs(r__1)) /
+ sqrt((r__2 = a[k + 1 + (i__ - 1) * a_dim1] *
+ a[k + 1 + i__ * a_dim1], dabs(r__2)));
+ if (temp1 > .5f) {
+ a[k + i__ * a_dim1] = sqrt((r__1 = a[k + 1 + (i__
+ - 1) * a_dim1] * a[k + 1 + i__ * a_dim1],
+ dabs(r__1))) * .5f;
+ }
+/* L90: */
+ }
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___36.ciunit = *nounit;
+ s_wsfe(&io___36);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L100:
+
+/* Call SSBTRD to compute S and U from upper triangle. */
+
+ i__4 = k + 1;
+ slacpy_(" ", &i__4, &n, &a[a_offset], lda, &work[1], lda);
+
+ ntest = 1;
+ ssbtrd_("V", "U", &n, &k, &work[1], lda, &sd[1], &se[1], &u[
+ u_offset], ldu, &work[*lda * n + 1], &iinfo);
+
+ if (iinfo != 0) {
+ io___37.ciunit = *nounit;
+ s_wsfe(&io___37);
+ do_fio(&c__1, "SSBTRD(U)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[1] = ulpinv;
+ goto L150;
+ }
+ }
+
+/* Do tests 1 and 2 */
+
+ ssbt21_("Upper", &n, &k, &c__1, &a[a_offset], lda, &sd[1], &
+ se[1], &u[u_offset], ldu, &work[1], &result[1]);
+
+/* Convert A from Upper-Triangle-Only storage to */
+/* Lower-Triangle-Only storage. */
+
+ i__4 = n;
+ for (jc = 1; jc <= i__4; ++jc) {
+/* Computing MIN */
+ i__6 = k, i__7 = n - jc;
+ i__5 = min(i__6,i__7);
+ for (jr = 0; jr <= i__5; ++jr) {
+ a[jr + 1 + jc * a_dim1] = a[k + 1 - jr + (jc + jr) *
+ a_dim1];
+/* L110: */
+ }
+/* L120: */
+ }
+ i__4 = n;
+ for (jc = n + 1 - k; jc <= i__4; ++jc) {
+/* Computing MIN */
+ i__5 = k, i__6 = n - jc;
+ i__7 = k;
+ for (jr = min(i__5,i__6) + 1; jr <= i__7; ++jr) {
+ a[jr + 1 + jc * a_dim1] = 0.f;
+/* L130: */
+ }
+/* L140: */
+ }
+
+/* Call SSBTRD to compute S and U from lower triangle */
+
+ i__4 = k + 1;
+ slacpy_(" ", &i__4, &n, &a[a_offset], lda, &work[1], lda);
+
+ ntest = 3;
+ ssbtrd_("V", "L", &n, &k, &work[1], lda, &sd[1], &se[1], &u[
+ u_offset], ldu, &work[*lda * n + 1], &iinfo);
+
+ if (iinfo != 0) {
+ io___40.ciunit = *nounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "SSBTRD(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[3] = ulpinv;
+ goto L150;
+ }
+ }
+ ntest = 4;
+
+/* Do tests 3 and 4 */
+
+ ssbt21_("Lower", &n, &k, &c__1, &a[a_offset], lda, &sd[1], &
+ se[1], &u[u_offset], ldu, &work[1], &result[3]);
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L150:
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__4 = ntest;
+ for (jr = 1; jr <= i__4; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "SSB", (ftnlen)3);
+ e_wsfe();
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ e_wsfe();
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ e_wsfe();
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "Symmetric", (ftnlen)9);
+ e_wsfe();
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "orthogonal", (ftnlen)10);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ for (j = 1; j <= 4; ++j) {
+ do_fio(&c__1, "'", (ftnlen)1);
+ }
+ e_wsfe();
+ }
+ ++nerrs;
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ }
+/* L160: */
+ }
+
+L170:
+ ;
+ }
+L180:
+ ;
+ }
+/* L190: */
+ }
+
+/* Summary */
+
+ slasum_("SSB", nounit, &nerrs, &ntestt);
+ return 0;
+
+
+
+
+
+/* End of SCHKSB */
+
+} /* schksb_ */
diff --git a/TESTING/EIG/schkst.c b/TESTING/EIG/schkst.c
new file mode 100644
index 0000000..c4760f7
--- /dev/null
+++ b/TESTING/EIG/schkst.c
@@ -0,0 +1,2389 @@
+/* schkst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static real c_b25 = 0.f;
+static integer c__0 = 0;
+static integer c__6 = 6;
+static real c_b39 = 1.f;
+static integer c__4 = 4;
+static integer c__3 = 3;
+static integer c__10 = 10;
+static integer c__11 = 11;
+
+/* Subroutine */ int schkst_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, integer *nounit, real *
+ a, integer *lda, real *ap, real *sd, real *se, real *d1, real *d2,
+ real *d3, real *d4, real *d5, real *wa1, real *wa2, real *wa3, real *
+ wr, real *u, integer *ldu, real *v, real *vp, real *tau, real *z__,
+ real *work, integer *lwork, integer *iwork, integer *liwork, real *
+ result, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,4,4,4,4,4,5,5,5,5,5,8,8,8,9,9,9,9,9,10 };
+ static integer kmagn[21] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3,1,1,1,2,3,1 };
+ static integer kmode[21] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0,4,3,1,4,4,3 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 SCHKST: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(/1x,a3,\002 -- Real Symmetric eigenvalue prob"
+ "lem\002)";
+ static char fmt_9997[] = "(\002 Matrix types (see SCHKST for details):"
+ " \002)";
+ static char fmt_9996[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 5=Diagonal: clustered ent"
+ "ries.\002,/\002 2=Identity matrix. \002,\002"
+ " 6=Diagonal: large, evenly spaced.\002,/\002 3=Diagonal: evenl"
+ "y spaced entries. \002,\002 7=Diagonal: small, evenly spaced."
+ "\002,/\002 4=Diagonal: geometr. spaced entries.\002)";
+ static char fmt_9995[] = "(\002 Dense \002,a,\002 Matrices:\002,/\002 8"
+ "=Evenly spaced eigenvals. \002,\002 12=Small, evenly "
+ "spaced eigenvals.\002,/\002 9=Geometrically spaced eigenvals. "
+ " \002,\002 13=Matrix with random O(1) entries.\002,/\002 10=Cl"
+ "ustered eigenvalues. \002,\002 14=Matrix with large"
+ " random entries.\002,/\002 11=Large, evenly spaced eigenvals. "
+ " \002,\002 15=Matrix with small random entries.\002)";
+ static char fmt_9994[] = "(\002 16=Positive definite, evenly spaced eige"
+ "nvalues\002,/\002 17=Positive definite, geometrically spaced eig"
+ "envlaues\002,/\002 18=Positive definite, clustered eigenvalue"
+ "s\002,/\002 19=Positive definite, small evenly spaced eigenvalues"
+ "\002,/\002 20=Positive definite, large evenly spaced eigenvalue"
+ "s\002,/\002 21=Diagonally dominant tridiagonal, geometrically"
+ "\002,\002 spaced eigenvalues\002)";
+ static char fmt_9988[] = "(/\002Test performed: see SCHKST for details"
+ ".\002,/)";
+ static char fmt_9990[] = "(\002 N=\002,i5,\002, seed=\002,4(i4,\002,\002"
+ "),\002 type \002,i2,\002, test(\002,i2,\002)=\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, z_dim1,
+ z_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ double log(doublereal), sqrt(doublereal);
+ integer pow_ii(integer *, integer *), s_wsfe(cilist *), do_fio(integer *,
+ char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, m, n, m2, m3, jc, il, jr, iu;
+ real vl, vu;
+ integer nap, lgn;
+ real ulp, cond;
+ integer nmax;
+ real unfl, ovfl, temp1, temp2, temp3, temp4;
+ logical badnn;
+ extern doublereal ssxt1_(integer *, real *, integer *, real *, integer *,
+ real *, real *, real *);
+ integer imode, lwedc;
+ real dumma[1];
+ integer iinfo;
+ real aninv, anorm;
+ integer itemp, nmats, jsize, nerrs, itype, jtype, ntest;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), sspt21_(integer *, char *, integer *, integer *, real
+ *, real *, real *, real *, integer *, real *, real *, real *,
+ real *), sstt21_(integer *, integer *, real *, real *,
+ real *, real *, real *, integer *, real *, real *), sstt22_(
+ integer *, integer *, integer *, real *, real *, real *, real *,
+ real *, integer *, real *, integer *, real *), ssyt21_(integer *,
+ char *, integer *, integer *, real *, integer *, real *, real *,
+ real *, integer *, real *, integer *, real *, real *, real *);
+ integer iseed2[4], log2ui;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ integer liwedc, nblock;
+ extern doublereal slamch_(char *);
+ integer idumma[1];
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer ioldsd[4];
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern doublereal slarnd_(integer *, integer *);
+ real abstol;
+ extern /* Subroutine */ int sstedc_(char *, integer *, real *, real *,
+ real *, integer *, real *, integer *, integer *, integer *,
+ integer *), sstech_(integer *, real *, real *, real *,
+ real *, real *, integer *), slacpy_(char *, integer *, integer *,
+ real *, integer *, real *, integer *), slaset_(char *,
+ integer *, integer *, real *, real *, real *, integer *),
+ slatmr_(integer *, integer *, char *, integer *, char *, real *,
+ integer *, real *, real *, char *, char *, real *, integer *,
+ real *, real *, integer *, real *, char *, integer *, integer *,
+ integer *, real *, real *, char *, real *, integer *, integer *,
+ integer *),
+ slatms_(integer *, integer *, char *, integer *, char *, real *,
+ integer *, real *, real *, integer *, integer *, char *, real *,
+ integer *, real *, integer *);
+ logical tryrac;
+ extern /* Subroutine */ int slasum_(char *, integer *, integer *, integer
+ *), sstein_(integer *, real *, real *, integer *, real *,
+ integer *, integer *, real *, integer *, real *, integer *,
+ integer *, integer *);
+ integer nsplit;
+ real rtunfl, rtovfl, ulpinv;
+ extern /* Subroutine */ int sopgtr_(char *, integer *, real *, real *,
+ real *, integer *, real *, integer *);
+ integer mtypes, ntestt;
+ extern /* Subroutine */ int sorgtr_(char *, integer *, real *, integer *,
+ real *, real *, integer *, integer *), spteqr_(char *,
+ integer *, real *, real *, real *, integer *, real *, integer *), ssptrd_(char *, integer *, real *, real *, real *, real *
+, integer *), sstebz_(char *, char *, integer *, real *,
+ real *, integer *, integer *, real *, real *, real *, integer *,
+ integer *, real *, integer *, integer *, real *, integer *,
+ integer *), sstemr_(char *, char *, integer *,
+ real *, real *, real *, real *, integer *, integer *, integer *,
+ real *, real *, integer *, integer *, integer *, logical *, real *
+, integer *, integer *, integer *, integer *),
+ ssteqr_(char *, integer *, real *, real *, real *, integer *,
+ real *, integer *), ssterf_(integer *, real *, real *,
+ integer *), ssytrd_(char *, integer *, real *, integer *, real *,
+ real *, real *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___70 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___72 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___73 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___74 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___75 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___76 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___77 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___80 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___81 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___82 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___83 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___84 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___85 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___86 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___87 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___88 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___89 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___90 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___91 = { 0, 0, 0, fmt_9988, 0 };
+ static cilist io___92 = { 0, 0, 0, fmt_9990, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKST checks the symmetric eigenvalue problem routines. */
+
+/* SSYTRD factors A as U S U' , where ' means transpose, */
+/* S is symmetric tridiagonal, and U is orthogonal. */
+/* SSYTRD can use either just the lower or just the upper triangle */
+/* of A; SCHKST checks both cases. */
+/* U is represented as a product of Householder */
+/* transformations, whose vectors are stored in the first */
+/* n-1 columns of V, and whose scale factors are in TAU. */
+
+/* SSPTRD does the same as SSYTRD, except that A and V are stored */
+/* in "packed" format. */
+
+/* SORGTR constructs the matrix U from the contents of V and TAU. */
+
+/* SOPGTR constructs the matrix U from the contents of VP and TAU. */
+
+/* SSTEQR factors S as Z D1 Z' , where Z is the orthogonal */
+/* matrix of eigenvectors and D1 is a diagonal matrix with */
+/* the eigenvalues on the diagonal. D2 is the matrix of */
+/* eigenvalues computed when Z is not computed. */
+
+/* SSTERF computes D3, the matrix of eigenvalues, by the */
+/* PWK method, which does not yield eigenvectors. */
+
+/* SPTEQR factors S as Z4 D4 Z4' , for a */
+/* symmetric positive definite tridiagonal matrix. */
+/* D5 is the matrix of eigenvalues computed when Z is not */
+/* computed. */
+
+/* SSTEBZ computes selected eigenvalues. WA1, WA2, and */
+/* WA3 will denote eigenvalues computed to high */
+/* absolute accuracy, with different range options. */
+/* WR will denote eigenvalues computed to high relative */
+/* accuracy. */
+
+/* SSTEIN computes Y, the eigenvectors of S, given the */
+/* eigenvalues. */
+
+/* SSTEDC factors S as Z D1 Z' , where Z is the orthogonal */
+/* matrix of eigenvectors and D1 is a diagonal matrix with */
+/* the eigenvalues on the diagonal ('I' option). It may also */
+/* update an input orthogonal matrix, usually the output */
+/* from SSYTRD/SORGTR or SSPTRD/SOPGTR ('V' option). It may */
+/* also just compute eigenvalues ('N' option). */
+
+/* SSTEMR factors S as Z D1 Z' , where Z is the orthogonal */
+/* matrix of eigenvectors and D1 is a diagonal matrix with */
+/* the eigenvalues on the diagonal ('I' option). SSTEMR */
+/* uses the Relatively Robust Representation whenever possible. */
+
+/* When SCHKST is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the symmetric eigenroutines. For each matrix, a number */
+/* of tests will be performed: */
+
+/* (1) | A - V S V' | / ( |A| n ulp ) SSYTRD( UPLO='U', ... ) */
+
+/* (2) | I - UV' | / ( n ulp ) SORGTR( UPLO='U', ... ) */
+
+/* (3) | A - V S V' | / ( |A| n ulp ) SSYTRD( UPLO='L', ... ) */
+
+/* (4) | I - UV' | / ( n ulp ) SORGTR( UPLO='L', ... ) */
+
+/* (5-8) Same as 1-4, but for SSPTRD and SOPGTR. */
+
+/* (9) | S - Z D Z' | / ( |S| n ulp ) SSTEQR('V',...) */
+
+/* (10) | I - ZZ' | / ( n ulp ) SSTEQR('V',...) */
+
+/* (11) | D1 - D2 | / ( |D1| ulp ) SSTEQR('N',...) */
+
+/* (12) | D1 - D3 | / ( |D1| ulp ) SSTERF */
+
+/* (13) 0 if the true eigenvalues (computed by sturm count) */
+/* of S are within THRESH of */
+/* those in D1. 2*THRESH if they are not. (Tested using */
+/* SSTECH) */
+
+/* For S positive definite, */
+
+/* (14) | S - Z4 D4 Z4' | / ( |S| n ulp ) SPTEQR('V',...) */
+
+/* (15) | I - Z4 Z4' | / ( n ulp ) SPTEQR('V',...) */
+
+/* (16) | D4 - D5 | / ( 100 |D4| ulp ) SPTEQR('N',...) */
+
+/* When S is also diagonally dominant by the factor gamma < 1, */
+
+/* (17) max | D4(i) - WR(i) | / ( |D4(i)| omega ) , */
+/* i */
+/* omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 */
+/* SSTEBZ( 'A', 'E', ...) */
+
+/* (18) | WA1 - D3 | / ( |D3| ulp ) SSTEBZ( 'A', 'E', ...) */
+
+/* (19) ( max { min | WA2(i)-WA3(j) | } + */
+/* i j */
+/* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) */
+/* i j */
+/* SSTEBZ( 'I', 'E', ...) */
+
+/* (20) | S - Y WA1 Y' | / ( |S| n ulp ) SSTEBZ, SSTEIN */
+
+/* (21) | I - Y Y' | / ( n ulp ) SSTEBZ, SSTEIN */
+
+/* (22) | S - Z D Z' | / ( |S| n ulp ) SSTEDC('I') */
+
+/* (23) | I - ZZ' | / ( n ulp ) SSTEDC('I') */
+
+/* (24) | S - Z D Z' | / ( |S| n ulp ) SSTEDC('V') */
+
+/* (25) | I - ZZ' | / ( n ulp ) SSTEDC('V') */
+
+/* (26) | D1 - D2 | / ( |D1| ulp ) SSTEDC('V') and */
+/* SSTEDC('N') */
+
+/* Test 27 is disabled at the moment because SSTEMR does not */
+/* guarantee high relatvie accuracy. */
+
+/* (27) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , */
+/* i */
+/* omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 */
+/* SSTEMR('V', 'A') */
+
+/* (28) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , */
+/* i */
+/* omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 */
+/* SSTEMR('V', 'I') */
+
+/* Tests 29 through 34 are disable at present because SSTEMR */
+/* does not handle partial specturm requests. */
+
+/* (29) | S - Z D Z' | / ( |S| n ulp ) SSTEMR('V', 'I') */
+
+/* (30) | I - ZZ' | / ( n ulp ) SSTEMR('V', 'I') */
+
+/* (31) ( max { min | WA2(i)-WA3(j) | } + */
+/* i j */
+/* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) */
+/* i j */
+/* SSTEMR('N', 'I') vs. SSTEMR('V', 'I') */
+
+/* (32) | S - Z D Z' | / ( |S| n ulp ) SSTEMR('V', 'V') */
+
+/* (33) | I - ZZ' | / ( n ulp ) SSTEMR('V', 'V') */
+
+/* (34) ( max { min | WA2(i)-WA3(j) | } + */
+/* i j */
+/* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) */
+/* i j */
+/* SSTEMR('N', 'V') vs. SSTEMR('V', 'V') */
+
+/* (35) | S - Z D Z' | / ( |S| n ulp ) SSTEMR('V', 'A') */
+
+/* (36) | I - ZZ' | / ( n ulp ) SSTEMR('V', 'A') */
+
+/* (37) ( max { min | WA2(i)-WA3(j) | } + */
+/* i j */
+/* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) */
+/* i j */
+/* SSTEMR('N', 'A') vs. SSTEMR('V', 'A') */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (6) Same as (4), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (4), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U' D U, where U is orthogonal and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U' D U, where U is orthogonal and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U' D U, where U is orthogonal and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) Symmetric matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
+/* (16) Same as (8), but diagonal elements are all positive. */
+/* (17) Same as (9), but diagonal elements are all positive. */
+/* (18) Same as (10), but diagonal elements are all positive. */
+/* (19) Same as (16), but multiplied by SQRT( overflow threshold ) */
+/* (20) Same as (16), but multiplied by SQRT( underflow threshold ) */
+/* (21) A diagonally dominant tridiagonal matrix with geometrically */
+/* spaced diagonal entries 1, ..., ULP. */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* SCHKST does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, SCHKST */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to SCHKST to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace/output) REAL array of */
+/* dimension ( LDA , max(NN) ) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually */
+/* used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at */
+/* least 1 and at least max( NN ). */
+
+/* AP (workspace) REAL array of */
+/* dimension( max(NN)*max(NN+1)/2 ) */
+/* The matrix A stored in packed format. */
+
+/* SD (workspace/output) REAL array of */
+/* dimension( max(NN) ) */
+/* The diagonal of the tridiagonal matrix computed by SSYTRD. */
+/* On exit, SD and SE contain the tridiagonal form of the */
+/* matrix in A. */
+
+/* SE (workspace/output) REAL array of */
+/* dimension( max(NN) ) */
+/* The off-diagonal of the tridiagonal matrix computed by */
+/* SSYTRD. On exit, SD and SE contain the tridiagonal form of */
+/* the matrix in A. */
+
+/* D1 (workspace/output) REAL array of */
+/* dimension( max(NN) ) */
+/* The eigenvalues of A, as computed by SSTEQR simlutaneously */
+/* with Z. On exit, the eigenvalues in D1 correspond with the */
+/* matrix in A. */
+
+/* D2 (workspace/output) REAL array of */
+/* dimension( max(NN) ) */
+/* The eigenvalues of A, as computed by SSTEQR if Z is not */
+/* computed. On exit, the eigenvalues in D2 correspond with */
+/* the matrix in A. */
+
+/* D3 (workspace/output) REAL array of */
+/* dimension( max(NN) ) */
+/* The eigenvalues of A, as computed by SSTERF. On exit, the */
+/* eigenvalues in D3 correspond with the matrix in A. */
+
+/* U (workspace/output) REAL array of */
+/* dimension( LDU, max(NN) ). */
+/* The orthogonal matrix computed by SSYTRD + SORGTR. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U, Z, and V. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* V (workspace/output) REAL array of */
+/* dimension( LDU, max(NN) ). */
+/* The Housholder vectors computed by SSYTRD in reducing A to */
+/* tridiagonal form. The vectors computed with UPLO='U' are */
+/* in the upper triangle, and the vectors computed with UPLO='L' */
+/* are in the lower triangle. (As described in SSYTRD, the */
+/* sub- and superdiagonal are not set to 1, although the */
+/* true Householder vector has a 1 in that position. The */
+/* routines that use V, such as SORGTR, set those entries to */
+/* 1 before using them, and then restore them later.) */
+
+/* VP (workspace) REAL array of */
+/* dimension( max(NN)*max(NN+1)/2 ) */
+/* The matrix V stored in packed format. */
+
+/* TAU (workspace/output) REAL array of */
+/* dimension( max(NN) ) */
+/* The Householder factors computed by SSYTRD in reducing A */
+/* to tridiagonal form. */
+
+/* Z (workspace/output) REAL array of */
+/* dimension( LDU, max(NN) ). */
+/* The orthogonal matrix of eigenvectors computed by SSTEQR, */
+/* SPTEQR, and SSTEIN. */
+
+/* WORK (workspace/output) REAL array of */
+/* dimension( LWORK ) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 3 * Nmax**2 */
+/* where Nmax = max( NN(j), 2 ) and lg = log base 2. */
+
+/* IWORK (workspace/output) INTEGER array, */
+/* dimension (6 + 6*Nmax + 5 * Nmax * lg Nmax ) */
+/* where Nmax = max( NN(j), 2 ) and lg = log base 2. */
+/* Workspace. */
+
+/* RESULT (output) REAL array, dimension (26) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -5: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -23: LDU < 1 or LDU < NMAX. */
+/* -29: LWORK too small. */
+/* If SLATMR, SLATMS, SSYTRD, SORGTR, SSTEQR, SSTERF, */
+/* or SORMC2 returns an error code, the */
+/* absolute value of it is returned. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests performed, or which can */
+/* be performed so far, for the current matrix. */
+/* NTESTT The total number of tests performed so far. */
+/* NBLOCK Blocksize as returned by ENVIR. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far. */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ap;
+ --sd;
+ --se;
+ --d1;
+ --d2;
+ --d3;
+ --d4;
+ --d5;
+ --wa1;
+ --wa2;
+ --wa3;
+ --wr;
+ z_dim1 = *ldu;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ v_dim1 = *ldu;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --vp;
+ --tau;
+ --work;
+ --iwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Keep ftnchek happy */
+ idumma[0] = 1;
+
+/* Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+ tryrac = TRUE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+ nblock = ilaenv_(&c__1, "SSYTRD", "L", &nmax, &c_n1, &c_n1, &c_n1);
+/* Computing MIN */
+ i__1 = nmax, i__2 = max(1,nblock);
+ nblock = min(i__1,i__2);
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*lda < nmax) {
+ *info = -9;
+ } else if (*ldu < nmax) {
+ *info = -23;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = max(2,nmax);
+ if (i__1 * i__1 << 1 > *lwork) {
+ *info = -29;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SCHKST", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ slabad_(&unfl, &ovfl);
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ ulpinv = 1.f / ulp;
+ log2ui = (integer) (log(ulpinv) / log(2.f));
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+
+/* Loop over sizes, types */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed2[i__ - 1] = iseed[i__];
+/* L20: */
+ }
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (n > 0) {
+ lgn = (integer) (log((real) n) / log(2.f));
+ if (pow_ii(&c__2, &lgn) < n) {
+ ++lgn;
+ }
+ if (pow_ii(&c__2, &lgn) < n) {
+ ++lgn;
+ }
+/* Computing 2nd power */
+ i__2 = n;
+ lwedc = (n << 2) + 1 + (n << 1) * lgn + i__2 * i__2 * 3;
+ liwedc = n * 6 + 6 + n * 5 * lgn;
+ } else {
+ lwedc = 8;
+ liwedc = 12;
+ }
+ nap = n * (n + 1) / 2;
+ aninv = 1.f / (real) max(1,n);
+
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L300;
+ }
+ ++nmats;
+ ntest = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L30: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random (none) */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 positive definite */
+/* =10 diagonally dominant tridiagonal */
+
+ if (mtypes > 21) {
+ goto L100;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.f;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * aninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * n * ulpinv;
+ goto L70;
+
+L70:
+
+ slaset_("Full", lda, &n, &c_b25, &c_b25, &a[a_offset], lda);
+ iinfo = 0;
+ if (jtype <= 15) {
+ cond = ulpinv;
+ } else {
+ cond = ulpinv * aninv / 10.f;
+ }
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ a[jc + jc * a_dim1] = anorm;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ + 1], &iinfo);
+
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b39,
+ &c_b39, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &c__0, &
+ c__0, &c_b25, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b39,
+ &c_b39, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &n, &
+ c_b25, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* Positive definite, eigenvalues specified. */
+
+ slatms_(&n, &n, "S", &iseed[1], "P", &work[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 10) {
+
+/* Positive definite tridiagonal, eigenvalues specified. */
+
+ slatms_(&n, &n, "S", &iseed[1], "P", &work[1], &imode, &cond,
+ &anorm, &c__1, &c__1, "N", &a[a_offset], lda, &work[n
+ + 1], &iinfo);
+ i__3 = n;
+ for (i__ = 2; i__ <= i__3; ++i__) {
+ temp1 = (r__1 = a[i__ - 1 + i__ * a_dim1], dabs(r__1)) /
+ sqrt((r__2 = a[i__ - 1 + (i__ - 1) * a_dim1] * a[
+ i__ + i__ * a_dim1], dabs(r__2)));
+ if (temp1 > .5f) {
+ a[i__ - 1 + i__ * a_dim1] = sqrt((r__1 = a[i__ - 1 + (
+ i__ - 1) * a_dim1] * a[i__ + i__ * a_dim1],
+ dabs(r__1))) * .5f;
+ a[i__ + (i__ - 1) * a_dim1] = a[i__ - 1 + i__ *
+ a_dim1];
+ }
+/* L90: */
+ }
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___40.ciunit = *nounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L100:
+
+/* Call SSYTRD and SORGTR to compute S and U from */
+/* upper triangle. */
+
+ slacpy_("U", &n, &n, &a[a_offset], lda, &v[v_offset], ldu);
+
+ ntest = 1;
+ ssytrd_("U", &n, &v[v_offset], ldu, &sd[1], &se[1], &tau[1], &
+ work[1], lwork, &iinfo);
+
+ if (iinfo != 0) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "SSYTRD(U)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[1] = ulpinv;
+ goto L280;
+ }
+ }
+
+ slacpy_("U", &n, &n, &v[v_offset], ldu, &u[u_offset], ldu);
+
+ ntest = 2;
+ sorgtr_("U", &n, &u[u_offset], ldu, &tau[1], &work[1], lwork, &
+ iinfo);
+ if (iinfo != 0) {
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "SORGTR(U)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[2] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do tests 1 and 2 */
+
+ ssyt21_(&c__2, "Upper", &n, &c__1, &a[a_offset], lda, &sd[1], &se[
+ 1], &u[u_offset], ldu, &v[v_offset], ldu, &tau[1], &work[
+ 1], &result[1]);
+ ssyt21_(&c__3, "Upper", &n, &c__1, &a[a_offset], lda, &sd[1], &se[
+ 1], &u[u_offset], ldu, &v[v_offset], ldu, &tau[1], &work[
+ 1], &result[2]);
+
+/* Call SSYTRD and SORGTR to compute S and U from */
+/* lower triangle, do tests. */
+
+ slacpy_("L", &n, &n, &a[a_offset], lda, &v[v_offset], ldu);
+
+ ntest = 3;
+ ssytrd_("L", &n, &v[v_offset], ldu, &sd[1], &se[1], &tau[1], &
+ work[1], lwork, &iinfo);
+
+ if (iinfo != 0) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "SSYTRD(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[3] = ulpinv;
+ goto L280;
+ }
+ }
+
+ slacpy_("L", &n, &n, &v[v_offset], ldu, &u[u_offset], ldu);
+
+ ntest = 4;
+ sorgtr_("L", &n, &u[u_offset], ldu, &tau[1], &work[1], lwork, &
+ iinfo);
+ if (iinfo != 0) {
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "SORGTR(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[4] = ulpinv;
+ goto L280;
+ }
+ }
+
+ ssyt21_(&c__2, "Lower", &n, &c__1, &a[a_offset], lda, &sd[1], &se[
+ 1], &u[u_offset], ldu, &v[v_offset], ldu, &tau[1], &work[
+ 1], &result[3]);
+ ssyt21_(&c__3, "Lower", &n, &c__1, &a[a_offset], lda, &sd[1], &se[
+ 1], &u[u_offset], ldu, &v[v_offset], ldu, &tau[1], &work[
+ 1], &result[4]);
+
+/* Store the upper triangle of A in AP */
+
+ i__ = 0;
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = jc;
+ for (jr = 1; jr <= i__4; ++jr) {
+ ++i__;
+ ap[i__] = a[jr + jc * a_dim1];
+/* L110: */
+ }
+/* L120: */
+ }
+
+/* Call SSPTRD and SOPGTR to compute S and U from AP */
+
+ scopy_(&nap, &ap[1], &c__1, &vp[1], &c__1);
+
+ ntest = 5;
+ ssptrd_("U", &n, &vp[1], &sd[1], &se[1], &tau[1], &iinfo);
+
+ if (iinfo != 0) {
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, "SSPTRD(U)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[5] = ulpinv;
+ goto L280;
+ }
+ }
+
+ ntest = 6;
+ sopgtr_("U", &n, &vp[1], &tau[1], &u[u_offset], ldu, &work[1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ do_fio(&c__1, "SOPGTR(U)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[6] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do tests 5 and 6 */
+
+ sspt21_(&c__2, "Upper", &n, &c__1, &ap[1], &sd[1], &se[1], &u[
+ u_offset], ldu, &vp[1], &tau[1], &work[1], &result[5]);
+ sspt21_(&c__3, "Upper", &n, &c__1, &ap[1], &sd[1], &se[1], &u[
+ u_offset], ldu, &vp[1], &tau[1], &work[1], &result[6]);
+
+/* Store the lower triangle of A in AP */
+
+ i__ = 0;
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = jc; jr <= i__4; ++jr) {
+ ++i__;
+ ap[i__] = a[jr + jc * a_dim1];
+/* L130: */
+ }
+/* L140: */
+ }
+
+/* Call SSPTRD and SOPGTR to compute S and U from AP */
+
+ scopy_(&nap, &ap[1], &c__1, &vp[1], &c__1);
+
+ ntest = 7;
+ ssptrd_("L", &n, &vp[1], &sd[1], &se[1], &tau[1], &iinfo);
+
+ if (iinfo != 0) {
+ io___48.ciunit = *nounit;
+ s_wsfe(&io___48);
+ do_fio(&c__1, "SSPTRD(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[7] = ulpinv;
+ goto L280;
+ }
+ }
+
+ ntest = 8;
+ sopgtr_("L", &n, &vp[1], &tau[1], &u[u_offset], ldu, &work[1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ do_fio(&c__1, "SOPGTR(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[8] = ulpinv;
+ goto L280;
+ }
+ }
+
+ sspt21_(&c__2, "Lower", &n, &c__1, &ap[1], &sd[1], &se[1], &u[
+ u_offset], ldu, &vp[1], &tau[1], &work[1], &result[7]);
+ sspt21_(&c__3, "Lower", &n, &c__1, &ap[1], &sd[1], &se[1], &u[
+ u_offset], ldu, &vp[1], &tau[1], &work[1], &result[8]);
+
+/* Call SSTEQR to compute D1, D2, and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ scopy_(&n, &sd[1], &c__1, &d1[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+ slaset_("Full", &n, &n, &c_b25, &c_b39, &z__[z_offset], ldu);
+
+ ntest = 9;
+ ssteqr_("V", &n, &d1[1], &work[1], &z__[z_offset], ldu, &work[n +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ do_fio(&c__1, "SSTEQR(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[9] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Compute D2 */
+
+ scopy_(&n, &sd[1], &c__1, &d2[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+
+ ntest = 11;
+ ssteqr_("N", &n, &d2[1], &work[1], &work[n + 1], ldu, &work[n + 1]
+, &iinfo);
+ if (iinfo != 0) {
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "SSTEQR(N)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[11] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Compute D3 (using PWK method) */
+
+ scopy_(&n, &sd[1], &c__1, &d3[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+
+ ntest = 12;
+ ssterf_(&n, &d3[1], &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "SSTERF", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[12] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 9 and 10 */
+
+ sstt21_(&n, &c__0, &sd[1], &se[1], &d1[1], dumma, &z__[z_offset],
+ ldu, &work[1], &result[9]);
+
+/* Do Tests 11 and 12 */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ temp3 = 0.f;
+ temp4 = 0.f;
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d1[j], dabs(r__1)), r__3 = max(
+ r__3,r__4), r__4 = (r__2 = d2[j], dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d1[j] - d2[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* Computing MAX */
+ r__3 = temp3, r__4 = (r__1 = d1[j], dabs(r__1)), r__3 = max(
+ r__3,r__4), r__4 = (r__2 = d3[j], dabs(r__2));
+ temp3 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp4, r__3 = (r__1 = d1[j] - d3[j], dabs(r__1));
+ temp4 = dmax(r__2,r__3);
+/* L150: */
+ }
+
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[11] = temp2 / dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp3,temp4);
+ result[12] = temp4 / dmax(r__1,r__2);
+
+/* Do Test 13 -- Sturm Sequence Test of Eigenvalues */
+/* Go up by factors of two until it succeeds */
+
+ ntest = 13;
+ temp1 = *thresh * (.5f - ulp);
+
+ i__3 = log2ui;
+ for (j = 0; j <= i__3; ++j) {
+ sstech_(&n, &sd[1], &se[1], &d1[1], &temp1, &work[1], &iinfo);
+ if (iinfo == 0) {
+ goto L170;
+ }
+ temp1 *= 2.f;
+/* L160: */
+ }
+
+L170:
+ result[13] = temp1;
+
+/* For positive definite matrices ( JTYPE.GT.15 ) call SPTEQR */
+/* and do tests 14, 15, and 16 . */
+
+ if (jtype > 15) {
+
+/* Compute D4 and Z4 */
+
+ scopy_(&n, &sd[1], &c__1, &d4[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+ slaset_("Full", &n, &n, &c_b25, &c_b39, &z__[z_offset], ldu);
+
+ ntest = 14;
+ spteqr_("V", &n, &d4[1], &work[1], &z__[z_offset], ldu, &work[
+ n + 1], &iinfo);
+ if (iinfo != 0) {
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, "SPTEQR(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[14] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 14 and 15 */
+
+ sstt21_(&n, &c__0, &sd[1], &se[1], &d4[1], dumma, &z__[
+ z_offset], ldu, &work[1], &result[14]);
+
+/* Compute D5 */
+
+ scopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+
+ ntest = 16;
+ spteqr_("N", &n, &d5[1], &work[1], &z__[z_offset], ldu, &work[
+ n + 1], &iinfo);
+ if (iinfo != 0) {
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ do_fio(&c__1, "SPTEQR(N)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[16] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Test 16 */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d4[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = d5[j], dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d4[j] - d5[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L180: */
+ }
+
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * 100.f * dmax(temp1,temp2);
+ result[16] = temp2 / dmax(r__1,r__2);
+ } else {
+ result[14] = 0.f;
+ result[15] = 0.f;
+ result[16] = 0.f;
+ }
+
+/* Call SSTEBZ with different options and do tests 17-18. */
+
+/* If S is positive definite and diagonally dominant, */
+/* ask for all eigenvalues with high relative accuracy. */
+
+ vl = 0.f;
+ vu = 0.f;
+ il = 0;
+ iu = 0;
+ if (jtype == 21) {
+ ntest = 17;
+ abstol = unfl + unfl;
+ sstebz_("A", "E", &n, &vl, &vu, &il, &iu, &abstol, &sd[1], &
+ se[1], &m, &nsplit, &wr[1], &iwork[1], &iwork[n + 1],
+ &work[1], &iwork[(n << 1) + 1], &iinfo);
+ if (iinfo != 0) {
+ io___66.ciunit = *nounit;
+ s_wsfe(&io___66);
+ do_fio(&c__1, "SSTEBZ(A,rel)", (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[17] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do test 17 */
+
+ temp2 = (n * 2.f - 1.f) * 2.f * ulp * 3.f / .0625f;
+
+ temp1 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__2 = d4[j] - wr[n - j + 1], dabs(
+ r__2)) / (abstol + (r__1 = d4[j], dabs(r__1)));
+ temp1 = dmax(r__3,r__4);
+/* L190: */
+ }
+
+ result[17] = temp1 / temp2;
+ } else {
+ result[17] = 0.f;
+ }
+
+/* Now ask for all eigenvalues with high absolute accuracy. */
+
+ ntest = 18;
+ abstol = unfl + unfl;
+ sstebz_("A", "E", &n, &vl, &vu, &il, &iu, &abstol, &sd[1], &se[1],
+ &m, &nsplit, &wa1[1], &iwork[1], &iwork[n + 1], &work[1],
+ &iwork[(n << 1) + 1], &iinfo);
+ if (iinfo != 0) {
+ io___67.ciunit = *nounit;
+ s_wsfe(&io___67);
+ do_fio(&c__1, "SSTEBZ(A)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[18] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do test 18 */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d3[j], dabs(r__1)), r__3 = max(
+ r__3,r__4), r__4 = (r__2 = wa1[j], dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d3[j] - wa1[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L200: */
+ }
+
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[18] = temp2 / dmax(r__1,r__2);
+
+/* Choose random values for IL and IU, and ask for the */
+/* IL-th through IU-th eigenvalues. */
+
+ ntest = 19;
+ if (n <= 1) {
+ il = 1;
+ iu = n;
+ } else {
+ il = (n - 1) * (integer) slarnd_(&c__1, iseed2) + 1;
+ iu = (n - 1) * (integer) slarnd_(&c__1, iseed2) + 1;
+ if (iu < il) {
+ itemp = iu;
+ iu = il;
+ il = itemp;
+ }
+ }
+
+ sstebz_("I", "E", &n, &vl, &vu, &il, &iu, &abstol, &sd[1], &se[1],
+ &m2, &nsplit, &wa2[1], &iwork[1], &iwork[n + 1], &work[1]
+, &iwork[(n << 1) + 1], &iinfo);
+ if (iinfo != 0) {
+ io___70.ciunit = *nounit;
+ s_wsfe(&io___70);
+ do_fio(&c__1, "SSTEBZ(I)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[19] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Determine the values VL and VU of the IL-th and IU-th */
+/* eigenvalues and ask for all eigenvalues in this range. */
+
+ if (n > 0) {
+ if (il != 1) {
+/* Computing MAX */
+ r__1 = (wa1[il] - wa1[il - 1]) * .5f, r__2 = ulp * anorm,
+ r__1 = max(r__1,r__2), r__2 = rtunfl * 2.f;
+ vl = wa1[il] - dmax(r__1,r__2);
+ } else {
+/* Computing MAX */
+ r__1 = (wa1[n] - wa1[1]) * .5f, r__2 = ulp * anorm, r__1 =
+ max(r__1,r__2), r__2 = rtunfl * 2.f;
+ vl = wa1[1] - dmax(r__1,r__2);
+ }
+ if (iu != n) {
+/* Computing MAX */
+ r__1 = (wa1[iu + 1] - wa1[iu]) * .5f, r__2 = ulp * anorm,
+ r__1 = max(r__1,r__2), r__2 = rtunfl * 2.f;
+ vu = wa1[iu] + dmax(r__1,r__2);
+ } else {
+/* Computing MAX */
+ r__1 = (wa1[n] - wa1[1]) * .5f, r__2 = ulp * anorm, r__1 =
+ max(r__1,r__2), r__2 = rtunfl * 2.f;
+ vu = wa1[n] + dmax(r__1,r__2);
+ }
+ } else {
+ vl = 0.f;
+ vu = 1.f;
+ }
+
+ sstebz_("V", "E", &n, &vl, &vu, &il, &iu, &abstol, &sd[1], &se[1],
+ &m3, &nsplit, &wa3[1], &iwork[1], &iwork[n + 1], &work[1]
+, &iwork[(n << 1) + 1], &iinfo);
+ if (iinfo != 0) {
+ io___72.ciunit = *nounit;
+ s_wsfe(&io___72);
+ do_fio(&c__1, "SSTEBZ(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[19] = ulpinv;
+ goto L280;
+ }
+ }
+
+ if (m3 == 0 && n != 0) {
+ result[19] = ulpinv;
+ goto L280;
+ }
+
+/* Do test 19 */
+
+ temp1 = ssxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &ulp, &
+ unfl);
+ temp2 = ssxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &ulp, &
+ unfl);
+ if (n > 0) {
+/* Computing MAX */
+ r__2 = (r__1 = wa1[n], dabs(r__1)), r__3 = dabs(wa1[1]);
+ temp3 = dmax(r__2,r__3);
+ } else {
+ temp3 = 0.f;
+ }
+
+/* Computing MAX */
+ r__1 = unfl, r__2 = temp3 * ulp;
+ result[19] = (temp1 + temp2) / dmax(r__1,r__2);
+
+/* Call SSTEIN to compute eigenvectors corresponding to */
+/* eigenvalues in WA1. (First call SSTEBZ again, to make sure */
+/* it returns these eigenvalues in the correct order.) */
+
+ ntest = 21;
+ sstebz_("A", "B", &n, &vl, &vu, &il, &iu, &abstol, &sd[1], &se[1],
+ &m, &nsplit, &wa1[1], &iwork[1], &iwork[n + 1], &work[1],
+ &iwork[(n << 1) + 1], &iinfo);
+ if (iinfo != 0) {
+ io___73.ciunit = *nounit;
+ s_wsfe(&io___73);
+ do_fio(&c__1, "SSTEBZ(A,B)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[20] = ulpinv;
+ result[21] = ulpinv;
+ goto L280;
+ }
+ }
+
+ sstein_(&n, &sd[1], &se[1], &m, &wa1[1], &iwork[1], &iwork[n + 1],
+ &z__[z_offset], ldu, &work[1], &iwork[(n << 1) + 1], &
+ iwork[n * 3 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___74.ciunit = *nounit;
+ s_wsfe(&io___74);
+ do_fio(&c__1, "SSTEIN", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[20] = ulpinv;
+ result[21] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do tests 20 and 21 */
+
+ sstt21_(&n, &c__0, &sd[1], &se[1], &wa1[1], dumma, &z__[z_offset],
+ ldu, &work[1], &result[20]);
+
+/* Call SSTEDC(I) to compute D1 and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ scopy_(&n, &sd[1], &c__1, &d1[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+ slaset_("Full", &n, &n, &c_b25, &c_b39, &z__[z_offset], ldu);
+
+ ntest = 22;
+ i__3 = lwedc - n;
+ sstedc_("I", &n, &d1[1], &work[1], &z__[z_offset], ldu, &work[n +
+ 1], &i__3, &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___75.ciunit = *nounit;
+ s_wsfe(&io___75);
+ do_fio(&c__1, "SSTEDC(I)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[22] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 22 and 23 */
+
+ sstt21_(&n, &c__0, &sd[1], &se[1], &d1[1], dumma, &z__[z_offset],
+ ldu, &work[1], &result[22]);
+
+/* Call SSTEDC(V) to compute D1 and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ scopy_(&n, &sd[1], &c__1, &d1[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+ slaset_("Full", &n, &n, &c_b25, &c_b39, &z__[z_offset], ldu);
+
+ ntest = 24;
+ i__3 = lwedc - n;
+ sstedc_("V", &n, &d1[1], &work[1], &z__[z_offset], ldu, &work[n +
+ 1], &i__3, &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___76.ciunit = *nounit;
+ s_wsfe(&io___76);
+ do_fio(&c__1, "SSTEDC(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[24] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 24 and 25 */
+
+ sstt21_(&n, &c__0, &sd[1], &se[1], &d1[1], dumma, &z__[z_offset],
+ ldu, &work[1], &result[24]);
+
+/* Call SSTEDC(N) to compute D2, do tests. */
+
+/* Compute D2 */
+
+ scopy_(&n, &sd[1], &c__1, &d2[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+ slaset_("Full", &n, &n, &c_b25, &c_b39, &z__[z_offset], ldu);
+
+ ntest = 26;
+ i__3 = lwedc - n;
+ sstedc_("N", &n, &d2[1], &work[1], &z__[z_offset], ldu, &work[n +
+ 1], &i__3, &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___77.ciunit = *nounit;
+ s_wsfe(&io___77);
+ do_fio(&c__1, "SSTEDC(N)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[26] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Test 26 */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d1[j], dabs(r__1)), r__3 = max(
+ r__3,r__4), r__4 = (r__2 = d2[j], dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d1[j] - d2[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L210: */
+ }
+
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[26] = temp2 / dmax(r__1,r__2);
+
+/* Only test SSTEMR if IEEE compliant */
+
+ if (ilaenv_(&c__10, "SSTEMR", "VA", &c__1, &c__0, &c__0, &c__0) == 1 && ilaenv_(&c__11, "SSTEMR",
+ "VA", &c__1, &c__0, &c__0, &c__0) ==
+ 1) {
+
+/* Call SSTEMR, do test 27 (relative eigenvalue accuracy) */
+
+/* If S is positive definite and diagonally dominant, */
+/* ask for all eigenvalues with high relative accuracy. */
+
+ vl = 0.f;
+ vu = 0.f;
+ il = 0;
+ iu = 0;
+ if (FALSE_) {
+ ntest = 27;
+ abstol = unfl + unfl;
+ i__3 = *lwork - (n << 1);
+ sstemr_("V", "A", &n, &sd[1], &se[1], &vl, &vu, &il, &iu,
+ &m, &wr[1], &z__[z_offset], ldu, &n, &iwork[1], &
+ tryrac, &work[1], lwork, &iwork[(n << 1) + 1], &
+ i__3, &iinfo);
+ if (iinfo != 0) {
+ io___78.ciunit = *nounit;
+ s_wsfe(&io___78);
+ do_fio(&c__1, "SSTEMR(V,A,rel)", (ftnlen)15);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[27] = ulpinv;
+ goto L270;
+ }
+ }
+
+/* Do test 27 */
+
+ temp2 = (n * 2.f - 1.f) * 2.f * ulp * 3.f / .0625f;
+
+ temp1 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__2 = d4[j] - wr[n - j + 1],
+ dabs(r__2)) / (abstol + (r__1 = d4[j], dabs(
+ r__1)));
+ temp1 = dmax(r__3,r__4);
+/* L220: */
+ }
+
+ result[27] = temp1 / temp2;
+
+ il = (n - 1) * (integer) slarnd_(&c__1, iseed2) + 1;
+ iu = (n - 1) * (integer) slarnd_(&c__1, iseed2) + 1;
+ if (iu < il) {
+ itemp = iu;
+ iu = il;
+ il = itemp;
+ }
+
+ if (FALSE_) {
+ ntest = 28;
+ abstol = unfl + unfl;
+ i__3 = *lwork - (n << 1);
+ sstemr_("V", "I", &n, &sd[1], &se[1], &vl, &vu, &il, &
+ iu, &m, &wr[1], &z__[z_offset], ldu, &n, &
+ iwork[1], &tryrac, &work[1], lwork, &iwork[(n
+ << 1) + 1], &i__3, &iinfo);
+
+ if (iinfo != 0) {
+ io___79.ciunit = *nounit;
+ s_wsfe(&io___79);
+ do_fio(&c__1, "SSTEMR(V,I,rel)", (ftnlen)15);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[28] = ulpinv;
+ goto L270;
+ }
+ }
+
+
+/* Do test 28 */
+
+ temp2 = (n * 2.f - 1.f) * 2.f * ulp * 3.f / .0625f;
+
+ temp1 = 0.f;
+ i__3 = iu;
+ for (j = il; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__2 = wr[j - il + 1] - d4[
+ n - j + 1], dabs(r__2)) / (abstol + (r__1
+ = wr[j - il + 1], dabs(r__1)));
+ temp1 = dmax(r__3,r__4);
+/* L230: */
+ }
+
+ result[28] = temp1 / temp2;
+ } else {
+ result[28] = 0.f;
+ }
+ } else {
+ result[27] = 0.f;
+ result[28] = 0.f;
+ }
+
+/* Call SSTEMR(V,I) to compute D1 and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ scopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+ slaset_("Full", &n, &n, &c_b25, &c_b39, &z__[z_offset], ldu);
+
+ if (FALSE_) {
+ ntest = 29;
+ il = (n - 1) * (integer) slarnd_(&c__1, iseed2) + 1;
+ iu = (n - 1) * (integer) slarnd_(&c__1, iseed2) + 1;
+ if (iu < il) {
+ itemp = iu;
+ iu = il;
+ il = itemp;
+ }
+ i__3 = *lwork - n;
+ i__4 = *liwork - (n << 1);
+ sstemr_("V", "I", &n, &d5[1], &work[1], &vl, &vu, &il, &
+ iu, &m, &d1[1], &z__[z_offset], ldu, &n, &iwork[1]
+, &tryrac, &work[n + 1], &i__3, &iwork[(n << 1) +
+ 1], &i__4, &iinfo);
+ if (iinfo != 0) {
+ io___80.ciunit = *nounit;
+ s_wsfe(&io___80);
+ do_fio(&c__1, "SSTEMR(V,I)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[29] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 29 and 30 */
+
+ sstt22_(&n, &m, &c__0, &sd[1], &se[1], &d1[1], dumma, &
+ z__[z_offset], ldu, &work[1], &m, &result[29]);
+
+/* Call SSTEMR to compute D2, do tests. */
+
+/* Compute D2 */
+
+ scopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+
+ ntest = 31;
+ i__3 = *lwork - n;
+ i__4 = *liwork - (n << 1);
+ sstemr_("N", "I", &n, &d5[1], &work[1], &vl, &vu, &il, &
+ iu, &m, &d2[1], &z__[z_offset], ldu, &n, &iwork[1]
+, &tryrac, &work[n + 1], &i__3, &iwork[(n << 1) +
+ 1], &i__4, &iinfo);
+ if (iinfo != 0) {
+ io___81.ciunit = *nounit;
+ s_wsfe(&io___81);
+ do_fio(&c__1, "SSTEMR(N,I)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[31] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Test 31 */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+
+ i__3 = iu - il + 1;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d1[j], dabs(r__1)), r__3
+ = max(r__3,r__4), r__4 = (r__2 = d2[j], dabs(
+ r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d1[j] - d2[j], dabs(r__1)
+ );
+ temp2 = dmax(r__2,r__3);
+/* L240: */
+ }
+
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[31] = temp2 / dmax(r__1,r__2);
+
+
+/* Call SSTEMR(V,V) to compute D1 and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ scopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+ slaset_("Full", &n, &n, &c_b25, &c_b39, &z__[z_offset],
+ ldu);
+
+ ntest = 32;
+
+ if (n > 0) {
+ if (il != 1) {
+/* Computing MAX */
+ r__1 = (d2[il] - d2[il - 1]) * .5f, r__2 = ulp *
+ anorm, r__1 = max(r__1,r__2), r__2 =
+ rtunfl * 2.f;
+ vl = d2[il] - dmax(r__1,r__2);
+ } else {
+/* Computing MAX */
+ r__1 = (d2[n] - d2[1]) * .5f, r__2 = ulp * anorm,
+ r__1 = max(r__1,r__2), r__2 = rtunfl *
+ 2.f;
+ vl = d2[1] - dmax(r__1,r__2);
+ }
+ if (iu != n) {
+/* Computing MAX */
+ r__1 = (d2[iu + 1] - d2[iu]) * .5f, r__2 = ulp *
+ anorm, r__1 = max(r__1,r__2), r__2 =
+ rtunfl * 2.f;
+ vu = d2[iu] + dmax(r__1,r__2);
+ } else {
+/* Computing MAX */
+ r__1 = (d2[n] - d2[1]) * .5f, r__2 = ulp * anorm,
+ r__1 = max(r__1,r__2), r__2 = rtunfl *
+ 2.f;
+ vu = d2[n] + dmax(r__1,r__2);
+ }
+ } else {
+ vl = 0.f;
+ vu = 1.f;
+ }
+
+ i__3 = *lwork - n;
+ i__4 = *liwork - (n << 1);
+ sstemr_("V", "V", &n, &d5[1], &work[1], &vl, &vu, &il, &
+ iu, &m, &d1[1], &z__[z_offset], ldu, &n, &iwork[1]
+, &tryrac, &work[n + 1], &i__3, &iwork[(n << 1) +
+ 1], &i__4, &iinfo);
+ if (iinfo != 0) {
+ io___82.ciunit = *nounit;
+ s_wsfe(&io___82);
+ do_fio(&c__1, "SSTEMR(V,V)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[32] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 32 and 33 */
+
+ sstt22_(&n, &m, &c__0, &sd[1], &se[1], &d1[1], dumma, &
+ z__[z_offset], ldu, &work[1], &m, &result[32]);
+
+/* Call SSTEMR to compute D2, do tests. */
+
+/* Compute D2 */
+
+ scopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+
+ ntest = 34;
+ i__3 = *lwork - n;
+ i__4 = *liwork - (n << 1);
+ sstemr_("N", "V", &n, &d5[1], &work[1], &vl, &vu, &il, &
+ iu, &m, &d2[1], &z__[z_offset], ldu, &n, &iwork[1]
+, &tryrac, &work[n + 1], &i__3, &iwork[(n << 1) +
+ 1], &i__4, &iinfo);
+ if (iinfo != 0) {
+ io___83.ciunit = *nounit;
+ s_wsfe(&io___83);
+ do_fio(&c__1, "SSTEMR(N,V)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[34] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Test 34 */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+
+ i__3 = iu - il + 1;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d1[j], dabs(r__1)), r__3
+ = max(r__3,r__4), r__4 = (r__2 = d2[j], dabs(
+ r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d1[j] - d2[j], dabs(r__1)
+ );
+ temp2 = dmax(r__2,r__3);
+/* L250: */
+ }
+
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[34] = temp2 / dmax(r__1,r__2);
+ } else {
+ result[29] = 0.f;
+ result[30] = 0.f;
+ result[31] = 0.f;
+ result[32] = 0.f;
+ result[33] = 0.f;
+ result[34] = 0.f;
+ }
+
+
+/* Call SSTEMR(V,A) to compute D1 and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ scopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+
+ ntest = 35;
+
+ i__3 = *lwork - n;
+ i__4 = *liwork - (n << 1);
+ sstemr_("V", "A", &n, &d5[1], &work[1], &vl, &vu, &il, &iu, &
+ m, &d1[1], &z__[z_offset], ldu, &n, &iwork[1], &
+ tryrac, &work[n + 1], &i__3, &iwork[(n << 1) + 1], &
+ i__4, &iinfo);
+ if (iinfo != 0) {
+ io___84.ciunit = *nounit;
+ s_wsfe(&io___84);
+ do_fio(&c__1, "SSTEMR(V,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[35] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 35 and 36 */
+
+ sstt22_(&n, &m, &c__0, &sd[1], &se[1], &d1[1], dumma, &z__[
+ z_offset], ldu, &work[1], &m, &result[35]);
+
+/* Call SSTEMR to compute D2, do tests. */
+
+/* Compute D2 */
+
+ scopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ scopy_(&i__3, &se[1], &c__1, &work[1], &c__1);
+ }
+
+ ntest = 37;
+ i__3 = *lwork - n;
+ i__4 = *liwork - (n << 1);
+ sstemr_("N", "A", &n, &d5[1], &work[1], &vl, &vu, &il, &iu, &
+ m, &d2[1], &z__[z_offset], ldu, &n, &iwork[1], &
+ tryrac, &work[n + 1], &i__3, &iwork[(n << 1) + 1], &
+ i__4, &iinfo);
+ if (iinfo != 0) {
+ io___85.ciunit = *nounit;
+ s_wsfe(&io___85);
+ do_fio(&c__1, "SSTEMR(N,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[37] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Test 34 */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d1[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = d2[j], dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d1[j] - d2[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L260: */
+ }
+
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[37] = temp2 / dmax(r__1,r__2);
+ }
+L270:
+L280:
+ ntestt += ntest;
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+
+/* Print out tests which fail. */
+
+ i__3 = ntest;
+ for (jr = 1; jr <= i__3; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___86.ciunit = *nounit;
+ s_wsfe(&io___86);
+ do_fio(&c__1, "SST", (ftnlen)3);
+ e_wsfe();
+ io___87.ciunit = *nounit;
+ s_wsfe(&io___87);
+ e_wsfe();
+ io___88.ciunit = *nounit;
+ s_wsfe(&io___88);
+ e_wsfe();
+ io___89.ciunit = *nounit;
+ s_wsfe(&io___89);
+ do_fio(&c__1, "Symmetric", (ftnlen)9);
+ e_wsfe();
+ io___90.ciunit = *nounit;
+ s_wsfe(&io___90);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___91.ciunit = *nounit;
+ s_wsfe(&io___91);
+ e_wsfe();
+ }
+ ++nerrs;
+ io___92.ciunit = *nounit;
+ s_wsfe(&io___92);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+/* L290: */
+ }
+L300:
+ ;
+ }
+/* L310: */
+ }
+
+/* Summary */
+
+ slasum_("SST", nounit, &nerrs, &ntestt);
+ return 0;
+
+
+
+
+/* L9993: */
+/* L9992: */
+/* L9991: */
+/* L9989: */
+
+/* End of SCHKST */
+
+} /* schkst_ */
diff --git a/TESTING/EIG/sckglm.c b/TESTING/EIG/sckglm.c
new file mode 100644
index 0000000..0cddf0f
--- /dev/null
+++ b/TESTING/EIG/sckglm.c
@@ -0,0 +1,325 @@
+/* sckglm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+
+/* Subroutine */ int sckglm_(integer *nn, integer *mval, integer *pval,
+ integer *nval, integer *nmats, integer *iseed, real *thresh, integer *
+ nmax, real *a, real *af, real *b, real *bf, real *x, real *work, real
+ *rwork, integer *nin, integer *nout, integer *info)
+{
+ /* Format strings */
+ static char fmt_9997[] = "(\002 *** Invalid input for GLM: M = \002,"
+ "i6,\002, P = \002,i6,\002, N = \002,i6,\002;\002,/\002 must "
+ "satisfy M <= N <= M+P \002,\002(this set of values will be skip"
+ "ped)\002)";
+ static char fmt_9999[] = "(\002 SLATMS in SCKGLM INFO = \002,i5)";
+ static char fmt_9998[] = "(\002 N=\002,i4,\002 M=\002,i4,\002, P=\002,"
+ "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
+
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), do_fio(integer *
+ , char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, m, n, p, ik, lda, ldb, kla, klb, kua, kub, imat;
+ char path[3], type__[1];
+ integer nrun, modea, modeb, nfail;
+ char dista[1], distb[1];
+ integer iinfo;
+ real resid, anorm, bnorm;
+ integer lwork;
+ extern /* Subroutine */ int slatb9_(char *, integer *, integer *, integer
+ *, integer *, char *, integer *, integer *, integer *, integer *,
+ real *, real *, integer *, integer *, real *, real *, char *,
+ char *), alahdg_(integer *, char *
+);
+ real cndnma, cndnmb;
+ extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
+ *, integer *, integer *), alasum_(char *, integer *,
+ integer *, integer *, integer *);
+ extern doublereal slarnd_(integer *, integer *);
+ extern /* Subroutine */ int slatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, real *, integer *, real *, integer *);
+ logical dotype[8];
+ extern /* Subroutine */ int sglmts_(integer *, integer *, integer *, real
+ *, real *, integer *, real *, real *, integer *, real *, real *,
+ real *, real *, real *, integer *, real *, real *);
+ logical firstt;
+
+ /* Fortran I/O blocks */
+ static cilist io___13 = { 0, 0, 0, 0, 0 };
+ static cilist io___14 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCKGLM tests SGGGLM - subroutine for solving generalized linear */
+/* model problem. */
+
+/* Arguments */
+/* ========= */
+
+/* NN (input) INTEGER */
+/* The number of values of N, M and P contained in the vectors */
+/* NVAL, MVAL and PVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension M. */
+
+/* PVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension P. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix row dimension N. */
+
+/* NMATS (input) INTEGER */
+/* The number of matrix types to be tested for each combination */
+/* of matrix dimensions. If NMATS >= NTYPES (the maximum */
+/* number of matrix types), then all the different types are */
+/* generated for testing. If NMATS < NTYPES, another input line */
+/* is read to get the numbers of the matrix types to be used. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator. The array */
+/* elements should be between 0 and 4095, otherwise they will be */
+/* reduced mod 4096, and ISEED(4) must be odd. */
+/* On exit, the next seed in the random number sequence after */
+/* all the test matrices have been generated. */
+
+/* THRESH (input) REAL */
+/* The threshold value for the test ratios. A result is */
+/* included in the output file if RESID >= THRESH. To have */
+/* every test ratio printed, use THRESH = 0. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* B (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* BF (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* X (workspace) REAL array, dimension (4*NMAX) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX) */
+
+/* WORK (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* NIN (input) INTEGER */
+/* The unit number for input. */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit */
+/* > 0 : If SLATMS returns an error code, the absolute value */
+/* of it is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --x;
+ --bf;
+ --b;
+ --af;
+ --a;
+ --iseed;
+ --nval;
+ --pval;
+ --mval;
+
+ /* Function Body */
+ s_copy(path, "GLM", (ftnlen)3, (ftnlen)3);
+ *info = 0;
+ nrun = 0;
+ nfail = 0;
+ firstt = TRUE_;
+ alareq_(path, nmats, dotype, &c__8, nin, nout);
+ lda = *nmax;
+ ldb = *nmax;
+ lwork = *nmax * *nmax;
+
+/* Check for valid input values. */
+
+ i__1 = *nn;
+ for (ik = 1; ik <= i__1; ++ik) {
+ m = mval[ik];
+ p = pval[ik];
+ n = nval[ik];
+ if (m > n || n > m + p) {
+ if (firstt) {
+ io___13.ciunit = *nout;
+ s_wsle(&io___13);
+ e_wsle();
+ firstt = FALSE_;
+ }
+ io___14.ciunit = *nout;
+ s_wsfe(&io___14);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L10: */
+ }
+ firstt = TRUE_;
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nn;
+ for (ik = 1; ik <= i__1; ++ik) {
+ m = mval[ik];
+ p = pval[ik];
+ n = nval[ik];
+ if (m > n || n > m + p) {
+ goto L40;
+ }
+
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat - 1]) {
+ goto L30;
+ }
+
+/* Set up parameters with SLATB9 and generate test */
+/* matrices A and B with SLATMS. */
+
+ slatb9_(path, &imat, &m, &p, &n, type__, &kla, &kua, &klb, &kub, &
+ anorm, &bnorm, &modea, &modeb, &cndnma, &cndnmb, dista,
+ distb);
+
+ slatms_(&n, &m, dista, &iseed[1], type__, &rwork[1], &modea, &
+ cndnma, &anorm, &kla, &kua, "No packing", &a[1], &lda, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+ slatms_(&n, &p, distb, &iseed[1], type__, &rwork[1], &modeb, &
+ cndnmb, &bnorm, &klb, &kub, "No packing", &b[1], &ldb, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+/* Generate random left hand side vector of GLM */
+
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__] = slarnd_(&c__2, &iseed[1]);
+/* L20: */
+ }
+
+ sglmts_(&n, &m, &p, &a[1], &af[1], &lda, &b[1], &bf[1], &ldb, &x[
+ 1], &x[*nmax + 1], &x[(*nmax << 1) + 1], &x[*nmax * 3 + 1]
+, &work[1], &lwork, &rwork[1], &resid);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ if (resid >= *thresh) {
+ if (nfail == 0 && firstt) {
+ firstt = FALSE_;
+ alahdg_(nout, path);
+ }
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&resid, (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+L30:
+ ;
+ }
+L40:
+ ;
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &c__0);
+
+ return 0;
+
+/* End of SCKGLM */
+
+} /* sckglm_ */
diff --git a/TESTING/EIG/sckgqr.c b/TESTING/EIG/sckgqr.c
new file mode 100644
index 0000000..4dafb4c
--- /dev/null
+++ b/TESTING/EIG/sckgqr.c
@@ -0,0 +1,426 @@
+/* sckgqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static integer c__1 = 1;
+static integer c__0 = 0;
+
+/* Subroutine */ int sckgqr_(integer *nm, integer *mval, integer *np, integer
+ *pval, integer *nn, integer *nval, integer *nmats, integer *iseed,
+ real *thresh, integer *nmax, real *a, real *af, real *aq, real *ar,
+ real *taua, real *b, real *bf, real *bz, real *bt, real *bwk, real *
+ taub, real *work, real *rwork, integer *nin, integer *nout, integer *
+ info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 SLATMS in SCKGQR: INFO = \002,i5)";
+ static char fmt_9998[] = "(\002 M=\002,i4,\002 P=\002,i4,\002, N=\002,"
+ "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
+ static char fmt_9997[] = "(\002 N=\002,i4,\002 M=\002,i4,\002, P=\002,"
+ "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, m, n, p, im, in, ip, nt, lda, ldb, kla, klb, kua, kub;
+ char path[3];
+ integer imat;
+ char type__[1];
+ integer nrun, modea, modeb, nfail;
+ char dista[1], distb[1];
+ integer iinfo;
+ real anorm, bnorm;
+ integer lwork;
+ extern /* Subroutine */ int slatb9_(char *, integer *, integer *, integer
+ *, integer *, char *, integer *, integer *, integer *, integer *,
+ real *, real *, integer *, integer *, real *, real *, char *,
+ char *), alahdg_(integer *, char *
+);
+ real cndnma, cndnmb;
+ extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
+ *, integer *, integer *), alasum_(char *, integer *,
+ integer *, integer *, integer *), slatms_(integer *,
+ integer *, char *, integer *, char *, real *, integer *, real *,
+ real *, integer *, integer *, char *, real *, integer *, real *,
+ integer *);
+ logical dotype[8], firstt;
+ real result[7];
+ extern /* Subroutine */ int sgqrts_(integer *, integer *, integer *, real
+ *, real *, real *, real *, integer *, real *, real *, real *,
+ real *, real *, real *, integer *, real *, real *, integer *,
+ real *, real *), sgrqts_(integer *, integer *, integer *, real *,
+ real *, real *, real *, integer *, real *, real *, real *, real *,
+ real *, real *, integer *, real *, real *, integer *, real *,
+ real *);
+
+ /* Fortran I/O blocks */
+ static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCKGQR tests */
+/* SGGQRF: GQR factorization for N-by-M matrix A and N-by-P matrix B, */
+/* SGGRQF: GRQ factorization for M-by-N matrix A and P-by-N matrix B. */
+
+/* Arguments */
+/* ========= */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row(column) dimension M. */
+
+/* NP (input) INTEGER */
+/* The number of values of P contained in the vector PVAL. */
+
+/* PVAL (input) INTEGER array, dimension (NP) */
+/* The values of the matrix row(column) dimension P. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column(row) dimension N. */
+
+/* NMATS (input) INTEGER */
+/* The number of matrix types to be tested for each combination */
+/* of matrix dimensions. If NMATS >= NTYPES (the maximum */
+/* number of matrix types), then all the different types are */
+/* generated for testing. If NMATS < NTYPES, another input line */
+/* is read to get the numbers of the matrix types to be used. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator. The array */
+/* elements should be between 0 and 4095, otherwise they will be */
+/* reduced mod 4096, and ISEED(4) must be odd. */
+/* On exit, the next seed in the random number sequence after */
+/* all the test matrices have been generated. */
+
+/* THRESH (input) 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. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AQ (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AR (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* TAUA (workspace) REAL array, dimension (NMAX) */
+
+/* B (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* BF (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* BZ (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* BT (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* BWK (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* TAUB (workspace) REAL array, dimension (NMAX) */
+
+/* WORK (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX) */
+
+/* NIN (input) INTEGER */
+/* The unit number for input. */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit */
+/* > 0 : If SLATMS returns an error code, the absolute value */
+/* of it is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --taub;
+ --bwk;
+ --bt;
+ --bz;
+ --bf;
+ --b;
+ --taua;
+ --ar;
+ --aq;
+ --af;
+ --a;
+ --iseed;
+ --nval;
+ --pval;
+ --mval;
+
+ /* Function Body */
+ s_copy(path, "GQR", (ftnlen)3, (ftnlen)3);
+ *info = 0;
+ nrun = 0;
+ nfail = 0;
+ firstt = TRUE_;
+ alareq_(path, nmats, dotype, &c__8, nin, nout);
+ lda = *nmax;
+ ldb = *nmax;
+ lwork = *nmax * *nmax;
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Do for each value of P in PVAL. */
+
+ i__2 = *np;
+ for (ip = 1; ip <= i__2; ++ip) {
+ p = pval[ip];
+
+/* Do for each value of N in NVAL. */
+
+ i__3 = *nn;
+ for (in = 1; in <= i__3; ++in) {
+ n = nval[in];
+
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat - 1]) {
+ goto L30;
+ }
+
+/* Test SGGRQF */
+
+/* Set up parameters with SLATB9 and generate test */
+/* matrices A and B with SLATMS. */
+
+ slatb9_("GRQ", &imat, &m, &p, &n, type__, &kla, &kua, &
+ klb, &kub, &anorm, &bnorm, &modea, &modeb, &
+ cndnma, &cndnmb, dista, distb);
+
+/* Generate M by N matrix A */
+
+ slatms_(&m, &n, dista, &iseed[1], type__, &rwork[1], &
+ modea, &cndnma, &anorm, &kla, &kua, "No packing",
+ &a[1], &lda, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+/* Generate P by N matrix B */
+
+ slatms_(&p, &n, distb, &iseed[1], type__, &rwork[1], &
+ modeb, &cndnmb, &bnorm, &klb, &kub, "No packing",
+ &b[1], &ldb, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+ nt = 4;
+
+ sgrqts_(&m, &p, &n, &a[1], &af[1], &aq[1], &ar[1], &lda, &
+ taua[1], &b[1], &bf[1], &bz[1], &bt[1], &bwk[1], &
+ ldb, &taub[1], &work[1], &lwork, &rwork[1],
+ result);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && firstt) {
+ firstt = FALSE_;
+ alahdg_(nout, "GRQ");
+ }
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L10: */
+ }
+ nrun += nt;
+
+/* Test SGGQRF */
+
+/* Set up parameters with SLATB9 and generate test */
+/* matrices A and B with SLATMS. */
+
+ slatb9_("GQR", &imat, &m, &p, &n, type__, &kla, &kua, &
+ klb, &kub, &anorm, &bnorm, &modea, &modeb, &
+ cndnma, &cndnmb, dista, distb);
+
+/* Generate N-by-M matrix A */
+
+ slatms_(&n, &m, dista, &iseed[1], type__, &rwork[1], &
+ modea, &cndnma, &anorm, &kla, &kua, "No packing",
+ &a[1], &lda, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+/* Generate N-by-P matrix B */
+
+ slatms_(&n, &p, distb, &iseed[1], type__, &rwork[1], &
+ modea, &cndnma, &bnorm, &klb, &kub, "No packing",
+ &b[1], &ldb, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+ nt = 4;
+
+ sgqrts_(&n, &m, &p, &a[1], &af[1], &aq[1], &ar[1], &lda, &
+ taua[1], &b[1], &bf[1], &bz[1], &bt[1], &bwk[1], &
+ ldb, &taub[1], &work[1], &lwork, &rwork[1],
+ result);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && firstt) {
+ firstt = FALSE_;
+ alahdg_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+
+L30:
+ ;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &c__0);
+
+ return 0;
+
+/* End of SCKGQR */
+
+} /* sckgqr_ */
diff --git a/TESTING/EIG/sckgsv.c b/TESTING/EIG/sckgsv.c
new file mode 100644
index 0000000..27b6c6b
--- /dev/null
+++ b/TESTING/EIG/sckgsv.c
@@ -0,0 +1,310 @@
+/* sckgsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static integer c__1 = 1;
+static integer c__0 = 0;
+
+/* Subroutine */ int sckgsv_(integer *nm, integer *mval, integer *pval,
+ integer *nval, integer *nmats, integer *iseed, real *thresh, integer *
+ nmax, real *a, real *af, real *b, real *bf, real *u, real *v, real *q,
+ real *alpha, real *beta, real *r__, integer *iwork, real *work, real
+ *rwork, integer *nin, integer *nout, integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 SLATMS in SCKGSV INFO = \002,i5)";
+ static char fmt_9998[] = "(\002 M=\002,i4,\002 P=\002,i4,\002, N=\002,"
+ "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
+
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, m, n, p, im, nt, lda, ldb, kla, klb, kua, kub, ldq, ldr, ldu,
+ ldv, imat;
+ char path[3], type__[1];
+ integer nrun, modea, modeb, nfail;
+ char dista[1], distb[1];
+ integer iinfo;
+ real anorm, bnorm;
+ integer lwork;
+ extern /* Subroutine */ int slatb9_(char *, integer *, integer *, integer
+ *, integer *, char *, integer *, integer *, integer *, integer *,
+ real *, real *, integer *, integer *, real *, real *, char *,
+ char *), alahdg_(integer *, char *
+);
+ real cndnma, cndnmb;
+ extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
+ *, integer *, integer *), alasum_(char *, integer *,
+ integer *, integer *, integer *), slatms_(integer *,
+ integer *, char *, integer *, char *, real *, integer *, real *,
+ real *, integer *, integer *, char *, real *, integer *, real *,
+ integer *);
+ logical dotype[8], firstt;
+ real result[7];
+ extern /* Subroutine */ int sgsvts_(integer *, integer *, integer *, real
+ *, real *, integer *, real *, real *, integer *, real *, integer *
+, real *, integer *, real *, integer *, real *, real *, real *,
+ integer *, integer *, real *, integer *, real *, real *);
+
+ /* Fortran I/O blocks */
+ static cilist io___32 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCKGSV tests SGGSVD: */
+/* the GSVD for M-by-N matrix A and P-by-N matrix B. */
+
+/* Arguments */
+/* ========= */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* PVAL (input) INTEGER array, dimension (NP) */
+/* The values of the matrix row dimension P. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NMATS (input) INTEGER */
+/* The number of matrix types to be tested for each combination */
+/* of matrix dimensions. If NMATS >= NTYPES (the maximum */
+/* number of matrix types), then all the different types are */
+/* generated for testing. If NMATS < NTYPES, another input line */
+/* is read to get the numbers of the matrix types to be used. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator. The array */
+/* elements should be between 0 and 4095, otherwise they will be */
+/* reduced mod 4096, and ISEED(4) must be odd. */
+/* On exit, the next seed in the random number sequence after */
+/* all the test matrices have been generated. */
+
+/* THRESH (input) 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. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* B (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* BF (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* U (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* V (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* Q (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* ALPHA (workspace) REAL array, dimension (NMAX) */
+
+/* BETA (workspace) REAL array, dimension (NMAX) */
+
+/* R (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* WORK (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX) */
+
+/* NIN (input) INTEGER */
+/* The unit number for input. */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit */
+/* > 0 : If SLATMS returns an error code, the absolute value */
+/* of it is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --iwork;
+ --r__;
+ --beta;
+ --alpha;
+ --q;
+ --v;
+ --u;
+ --bf;
+ --b;
+ --af;
+ --a;
+ --iseed;
+ --nval;
+ --pval;
+ --mval;
+
+ /* Function Body */
+ s_copy(path, "GSV", (ftnlen)3, (ftnlen)3);
+ *info = 0;
+ nrun = 0;
+ nfail = 0;
+ firstt = TRUE_;
+ alareq_(path, nmats, dotype, &c__8, nin, nout);
+ lda = *nmax;
+ ldb = *nmax;
+ ldu = *nmax;
+ ldv = *nmax;
+ ldq = *nmax;
+ ldr = *nmax;
+ lwork = *nmax * *nmax;
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+ p = pval[im];
+ n = nval[im];
+
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat - 1]) {
+ goto L20;
+ }
+
+/* Set up parameters with SLATB9 and generate test */
+/* matrices A and B with SLATMS. */
+
+ slatb9_(path, &imat, &m, &p, &n, type__, &kla, &kua, &klb, &kub, &
+ anorm, &bnorm, &modea, &modeb, &cndnma, &cndnmb, dista,
+ distb);
+
+/* Generate M by N matrix A */
+
+ slatms_(&m, &n, dista, &iseed[1], type__, &rwork[1], &modea, &
+ cndnma, &anorm, &kla, &kua, "No packing", &a[1], &lda, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L20;
+ }
+
+ slatms_(&p, &n, distb, &iseed[1], type__, &rwork[1], &modeb, &
+ cndnmb, &bnorm, &klb, &kub, "No packing", &b[1], &ldb, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L20;
+ }
+
+ nt = 6;
+
+ sgsvts_(&m, &p, &n, &a[1], &af[1], &lda, &b[1], &bf[1], &ldb, &u[
+ 1], &ldu, &v[1], &ldv, &q[1], &ldq, &alpha[1], &beta[1], &
+ r__[1], &ldr, &iwork[1], &work[1], &lwork, &rwork[1],
+ result);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__2 = nt;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && firstt) {
+ firstt = FALSE_;
+ alahdg_(nout, path);
+ }
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L10: */
+ }
+ nrun += nt;
+L20:
+ ;
+ }
+/* L30: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &c__0);
+
+ return 0;
+
+/* End of SCKGSV */
+
+} /* sckgsv_ */
diff --git a/TESTING/EIG/scklse.c b/TESTING/EIG/scklse.c
new file mode 100644
index 0000000..f1e0406
--- /dev/null
+++ b/TESTING/EIG/scklse.c
@@ -0,0 +1,350 @@
+/* scklse.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static integer c__1 = 1;
+static integer c__0 = 0;
+
+/* Subroutine */ int scklse_(integer *nn, integer *mval, integer *pval,
+ integer *nval, integer *nmats, integer *iseed, real *thresh, integer *
+ nmax, real *a, real *af, real *b, real *bf, real *x, real *work, real
+ *rwork, integer *nin, integer *nout, integer *info)
+{
+ /* Format strings */
+ static char fmt_9997[] = "(\002 *** Invalid input for LSE: M = \002,"
+ "i6,\002, P = \002,i6,\002, N = \002,i6,\002;\002,/\002 must "
+ "satisfy P <= N <= P+M \002,\002(this set of values will be skip"
+ "ped)\002)";
+ static char fmt_9999[] = "(\002 SLATMS in SCKLSE INFO = \002,i5)";
+ static char fmt_9998[] = "(\002 M=\002,i4,\002 P=\002,i4,\002, N=\002,"
+ "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), do_fio(integer *
+ , char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, m, n, p, ik, nt, lda, ldb, kla, klb, kua, kub, imat;
+ char path[3], type__[1];
+ integer nrun, modea, modeb, nfail;
+ char dista[1], distb[1];
+ integer iinfo;
+ real anorm, bnorm;
+ integer lwork;
+ extern /* Subroutine */ int slatb9_(char *, integer *, integer *, integer
+ *, integer *, char *, integer *, integer *, integer *, integer *,
+ real *, real *, integer *, integer *, real *, real *, char *,
+ char *), alahdg_(integer *, char *
+);
+ real cndnma, cndnmb;
+ extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
+ *, integer *, integer *), alasum_(char *, integer *,
+ integer *, integer *, integer *), slarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, integer *, integer *), slatms_(
+ integer *, integer *, char *, integer *, char *, real *, integer *
+, real *, real *, integer *, integer *, char *, real *, integer *,
+ real *, integer *);
+ logical dotype[8], firstt;
+ extern /* Subroutine */ int slsets_(integer *, integer *, integer *, real
+ *, real *, integer *, real *, real *, integer *, real *, real *,
+ real *, real *, real *, real *, integer *, real *, real *);
+ real result[7];
+
+ /* Fortran I/O blocks */
+ static cilist io___13 = { 0, 0, 0, 0, 0 };
+ static cilist io___14 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCKLSE tests SGGLSE - a subroutine for solving linear equality */
+/* constrained least square problem (LSE). */
+
+/* Arguments */
+/* ========= */
+
+/* NN (input) INTEGER */
+/* The number of values of (M,P,N) contained in the vectors */
+/* (MVAL, PVAL, NVAL). */
+
+/* MVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix row(column) dimension M. */
+
+/* PVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix row(column) dimension P. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column(row) dimension N. */
+
+/* NMATS (input) INTEGER */
+/* The number of matrix types to be tested for each combination */
+/* of matrix dimensions. If NMATS >= NTYPES (the maximum */
+/* number of matrix types), then all the different types are */
+/* generated for testing. If NMATS < NTYPES, another input line */
+/* is read to get the numbers of the matrix types to be used. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator. The array */
+/* elements should be between 0 and 4095, otherwise they will be */
+/* reduced mod 4096, and ISEED(4) must be odd. */
+/* On exit, the next seed in the random number sequence after */
+/* all the test matrices have been generated. */
+
+/* THRESH (input) 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. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* B (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* BF (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* X (workspace) REAL array, dimension (5*NMAX) */
+
+/* WORK (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX) */
+
+/* NIN (input) INTEGER */
+/* The unit number for input. */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit */
+/* > 0 : If SLATMS returns an error code, the absolute value */
+/* of it is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --x;
+ --bf;
+ --b;
+ --af;
+ --a;
+ --iseed;
+ --nval;
+ --pval;
+ --mval;
+
+ /* Function Body */
+ s_copy(path, "LSE", (ftnlen)3, (ftnlen)3);
+ *info = 0;
+ nrun = 0;
+ nfail = 0;
+ firstt = TRUE_;
+ alareq_(path, nmats, dotype, &c__8, nin, nout);
+ lda = *nmax;
+ ldb = *nmax;
+ lwork = *nmax * *nmax;
+
+/* Check for valid input values. */
+
+ i__1 = *nn;
+ for (ik = 1; ik <= i__1; ++ik) {
+ m = mval[ik];
+ p = pval[ik];
+ n = nval[ik];
+ if (p > n || n > m + p) {
+ if (firstt) {
+ io___13.ciunit = *nout;
+ s_wsle(&io___13);
+ e_wsle();
+ firstt = FALSE_;
+ }
+ io___14.ciunit = *nout;
+ s_wsfe(&io___14);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L10: */
+ }
+ firstt = TRUE_;
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nn;
+ for (ik = 1; ik <= i__1; ++ik) {
+ m = mval[ik];
+ p = pval[ik];
+ n = nval[ik];
+ if (p > n || n > m + p) {
+ goto L40;
+ }
+
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat - 1]) {
+ goto L30;
+ }
+
+/* Set up parameters with SLATB9 and generate test */
+/* matrices A and B with SLATMS. */
+
+ slatb9_(path, &imat, &m, &p, &n, type__, &kla, &kua, &klb, &kub, &
+ anorm, &bnorm, &modea, &modeb, &cndnma, &cndnmb, dista,
+ distb);
+
+ slatms_(&m, &n, dista, &iseed[1], type__, &rwork[1], &modea, &
+ cndnma, &anorm, &kla, &kua, "No packing", &a[1], &lda, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+ slatms_(&p, &n, distb, &iseed[1], type__, &rwork[1], &modeb, &
+ cndnmb, &bnorm, &klb, &kub, "No packing", &b[1], &ldb, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+/* Generate the right-hand sides C and D for the LSE. */
+
+/* Computing MAX */
+ i__3 = m - 1;
+ i__2 = max(i__3,0);
+/* Computing MAX */
+ i__5 = n - 1;
+ i__4 = max(i__5,0);
+ i__6 = max(n,1);
+ i__7 = max(m,1);
+ slarhs_("SGE", "New solution", "Upper", "N", &m, &n, &i__2, &i__4,
+ &c__1, &a[1], &lda, &x[(*nmax << 2) + 1], &i__6, &x[1], &
+ i__7, &iseed[1], &iinfo);
+
+/* Computing MAX */
+ i__3 = p - 1;
+ i__2 = max(i__3,0);
+/* Computing MAX */
+ i__5 = n - 1;
+ i__4 = max(i__5,0);
+ i__6 = max(n,1);
+ i__7 = max(p,1);
+ slarhs_("SGE", "Computed", "Upper", "N", &p, &n, &i__2, &i__4, &
+ c__1, &b[1], &ldb, &x[(*nmax << 2) + 1], &i__6, &x[(*nmax
+ << 1) + 1], &i__7, &iseed[1], &iinfo);
+
+ nt = 2;
+
+ slsets_(&m, &p, &n, &a[1], &af[1], &lda, &b[1], &bf[1], &ldb, &x[
+ 1], &x[*nmax + 1], &x[(*nmax << 1) + 1], &x[*nmax * 3 + 1]
+, &x[(*nmax << 2) + 1], &work[1], &lwork, &rwork[1],
+ result);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__2 = nt;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && firstt) {
+ firstt = FALSE_;
+ alahdg_(nout, path);
+ }
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+
+L30:
+ ;
+ }
+L40:
+ ;
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &c__0);
+
+ return 0;
+
+/* End of SCKLSE */
+
+} /* scklse_ */
diff --git a/TESTING/EIG/sdrges.c b/TESTING/EIG/sdrges.c
new file mode 100644
index 0000000..12b5031
--- /dev/null
+++ b/TESTING/EIG/sdrges.c
@@ -0,0 +1,1135 @@
+/* sdrges.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static real c_b26 = 0.f;
+static integer c__2 = 2;
+static real c_b32 = 1.f;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static integer c__0 = 0;
+
+/* Subroutine */ int sdrges_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, integer *nounit, real *
+ a, integer *lda, real *b, real *s, real *t, real *q, integer *ldq,
+ real *z__, real *alphar, real *alphai, real *beta, real *work,
+ integer *lwork, real *result, logical *bwork, integer *info)
+{
+ /* Initialized data */
+
+ static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
+ 2,2,2,3 };
+ static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
+ 2,3,2,1 };
+ static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
+ 1,1,1,1 };
+ static integer iasign[26] = { 0,0,0,0,0,0,2,0,2,2,0,0,2,2,2,0,2,0,0,0,2,2,
+ 2,2,2,0 };
+ static integer ibsign[26] = { 0,0,0,0,0,0,0,2,0,0,2,2,0,0,2,0,2,0,0,0,0,0,
+ 0,0,0,0 };
+ static integer kz1[6] = { 0,1,2,1,3,3 };
+ static integer kz2[6] = { 0,0,1,2,1,1 };
+ static integer kadd[6] = { 0,0,0,0,3,2 };
+ static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
+ 4,4,4,0 };
+ static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
+ 8,8,8,8,8,0 };
+ static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
+ 3,3,3,1 };
+ static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
+ 4,4,4,1 };
+ static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
+ 3,3,2,1 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 SDRGES: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,4(i4,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 SDRGES: SGET53 returned INFO=\002,i1,"
+ "\002 for eigenvalue \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JT"
+ "YPE=\002,i6,\002, ISEED=(\002,4(i4,\002,\002),i5,\002)\002)";
+ static char fmt_9997[] = "(\002 SDRGES: S not in Schur form at eigenvalu"
+ "e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, "
+ "ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9996[] = "(/1x,a3,\002 -- Real Generalized Schur form dr"
+ "iver\002)";
+ static char fmt_9995[] = "(\002 Matrix types (see SDRGES for details):"
+ " \002)";
+ static char fmt_9994[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
+ "osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
+ ") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
+ "onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
+ "I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
+ "arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
+ "(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
+ "=(D, reversed D)\002)";
+ static char fmt_9993[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
+ "atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
+ " 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
+ "ha&beta \002,\002 20=arithmetic alpha, beta=0,"
+ "1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
+ "=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
+ "/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
+ "l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
+ ".\002)";
+ static char fmt_9992[] = "(/\002 Tests performed: (S is Schur, T is tri"
+ "angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002l and r "
+ "are the appropriate left and right\002,/19x,\002eigenvectors, re"
+ "sp., a is alpha, b is beta, and\002,/19x,a,\002 means \002,a,"
+ "\002.)\002,/\002 Without ordering: \002,/\002 1 = | A - Q S "
+ "Z\002,a,\002 | / ( |A| n ulp ) 2 = | B - Q T Z\002,a,\002 |"
+ " / ( |B| n ulp )\002,/\002 3 = | I - QQ\002,a,\002 | / ( n ulp "
+ ") 4 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 5"
+ " = A is in Schur form S\002,/\002 6 = difference between (alpha"
+ ",beta)\002,\002 and diagonals of (S,T)\002,/\002 With ordering:"
+ " \002,/\002 7 = | (A,B) - Q (S,T) Z\002,a,\002 | / ( |(A,B)| n "
+ "ulp ) \002,/\002 8 = | I - QQ\002,a,\002 | / ( n ulp ) "
+ " 9 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 10 = A is in"
+ " Schur form S\002,/\002 11 = difference between (alpha,beta) and"
+ " diagonals\002,\002 of (S,T)\002,/\002 12 = SDIM is the correct "
+ "number of \002,\002selected eigenvalues\002,/)";
+ static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",0p,f8.2)";
+ static char fmt_9990[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",1p,e10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1,
+ s_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2, i__3,
+ i__4;
+ real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10;
+
+ /* Builtin functions */
+ double r_sign(real *, real *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, n, i1, n1, jc, nb, in, jr;
+ real ulp;
+ integer iadd, sdim, ierr, nmax, rsub;
+ char sort[1];
+ real temp1, temp2;
+ logical badnn;
+ integer iinfo;
+ real rmagn[4];
+ extern /* Subroutine */ int sget51_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, integer *, real *, integer *, real *
+, real *), sgges_(char *, char *, char *, L_fp, integer *, real *,
+ integer *, real *, integer *, integer *, real *, real *, real *,
+ real *, integer *, real *, integer *, real *, integer *, logical *
+, integer *), sget53_(real *, integer *,
+ real *, integer *, real *, real *, real *, real *, integer *),
+ sget54_(integer *, real *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, real *);
+ integer nmats, jsize, nerrs, jtype, ntest, isort;
+ extern /* Subroutine */ int slatm4_(integer *, integer *, integer *,
+ integer *, integer *, real *, real *, real *, integer *, integer *
+, real *, integer *);
+ logical ilabad;
+ extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *), slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ integer ioldsd[4];
+ real safmax;
+ integer knteig;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern doublereal slarnd_(integer *, integer *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *), slarfg_(integer *, real *, real *, integer
+ *, real *), xerbla_(char *, integer *);
+ extern logical slctes_(real *, real *, real *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *);
+ integer minwrk, maxwrk;
+ real ulpinv;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9990, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRGES checks the nonsymmetric generalized eigenvalue (Schur form) */
+/* problem driver SGGES. */
+
+/* SGGES factors A and B as Q S Z' and Q T Z' , where ' means */
+/* transpose, T is upper triangular, S is in generalized Schur form */
+/* (block upper triangular, with 1x1 and 2x2 blocks on the diagonal, */
+/* the 2x2 blocks corresponding to complex conjugate pairs of */
+/* generalized eigenvalues), and Q and Z are orthogonal. It also */
+/* computes the generalized eigenvalues (alpha(j),beta(j)), j=1,...,n, */
+/* Thus, w(j) = alpha(j)/beta(j) is a root of the characteristic */
+/* equation */
+/* det( A - w(j) B ) = 0 */
+/* Optionally it also reorder the eigenvalues so that a selected */
+/* cluster of eigenvalues appears in the leading diagonal block of the */
+/* Schur forms. */
+
+/* When SDRGES is called, a number of matrix "sizes" ("N's") and a */
+/* number of matrix "TYPES" are specified. For each size ("N") */
+/* and each TYPE of matrix, a pair of matrices (A, B) will be generated */
+/* and used for testing. For each matrix pair, the following 13 tests */
+/* will be performed and compared with the threshhold THRESH except */
+/* the tests (5), (11) and (13). */
+
+
+/* (1) | A - Q S Z' | / ( |A| n ulp ) (no sorting of eigenvalues) */
+
+
+/* (2) | B - Q T Z' | / ( |B| n ulp ) (no sorting of eigenvalues) */
+
+
+/* (3) | I - QQ' | / ( n ulp ) (no sorting of eigenvalues) */
+
+
+/* (4) | I - ZZ' | / ( n ulp ) (no sorting of eigenvalues) */
+
+/* (5) if A is in Schur form (i.e. quasi-triangular form) */
+/* (no sorting of eigenvalues) */
+
+/* (6) if eigenvalues = diagonal blocks of the Schur form (S, T), */
+/* i.e., test the maximum over j of D(j) where: */
+
+/* if alpha(j) is real: */
+/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
+/* D(j) = ------------------------ + ----------------------- */
+/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
+
+/* if alpha(j) is complex: */
+/* | det( s S - w T ) | */
+/* D(j) = --------------------------------------------------- */
+/* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T ) */
+
+/* and S and T are here the 2 x 2 diagonal blocks of S and T */
+/* corresponding to the j-th and j+1-th eigenvalues. */
+/* (no sorting of eigenvalues) */
+
+/* (7) | (A,B) - Q (S,T) Z' | / ( | (A,B) | n ulp ) */
+/* (with sorting of eigenvalues). */
+
+/* (8) | I - QQ' | / ( n ulp ) (with sorting of eigenvalues). */
+
+/* (9) | I - ZZ' | / ( n ulp ) (with sorting of eigenvalues). */
+
+/* (10) if A is in Schur form (i.e. quasi-triangular form) */
+/* (with sorting of eigenvalues). */
+
+/* (11) if eigenvalues = diagonal blocks of the Schur form (S, T), */
+/* i.e. test the maximum over j of D(j) where: */
+
+/* if alpha(j) is real: */
+/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
+/* D(j) = ------------------------ + ----------------------- */
+/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
+
+/* if alpha(j) is complex: */
+/* | det( s S - w T ) | */
+/* D(j) = --------------------------------------------------- */
+/* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T ) */
+
+/* and S and T are here the 2 x 2 diagonal blocks of S and T */
+/* corresponding to the j-th and j+1-th eigenvalues. */
+/* (with sorting of eigenvalues). */
+
+/* (12) if sorting worked and SDIM is the number of eigenvalues */
+/* which were SELECTed. */
+
+/* Test Matrices */
+/* ============= */
+
+/* The sizes of the test matrices are specified by an array */
+/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
+/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) ( 0, 0 ) (a pair of zero matrices) */
+
+/* (2) ( I, 0 ) (an identity and a zero matrix) */
+
+/* (3) ( 0, I ) (an identity and a zero matrix) */
+
+/* (4) ( I, I ) (a pair of identity matrices) */
+
+/* t t */
+/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
+
+/* t ( I 0 ) */
+/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
+/* ( 0 I ) ( 0 J ) */
+/* and I is a k x k identity and J a (k+1)x(k+1) */
+/* Jordan block; k=(N-1)/2 */
+
+/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
+/* matrix with those diagonal entries.) */
+/* (8) ( I, D ) */
+
+/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
+
+/* (10) ( small*D, big*I ) */
+
+/* (11) ( big*I, small*D ) */
+
+/* (12) ( small*I, big*D ) */
+
+/* (13) ( big*D, big*I ) */
+
+/* (14) ( small*D, small*I ) */
+
+/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
+/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
+/* t t */
+/* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. */
+
+/* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices */
+/* with random O(1) entries above the diagonal */
+/* and diagonal entries diag(T1) = */
+/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
+/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
+
+/* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
+/* s = machine precision. */
+
+/* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
+
+/* N-5 */
+/* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+
+/* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+/* where r1,..., r(N-4) are random. */
+
+/* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular */
+/* matrices. */
+
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* SDRGES does nothing. NSIZES >= 0. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. NN >= 0. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, SDRGES */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A on input. */
+/* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to SDRGES to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error is */
+/* scaled to be O(1), so THRESH should be a reasonably small */
+/* multiple of 1, e.g., 10 or 100. In particular, it should */
+/* not depend on the precision (single vs. double) or the size */
+/* of the matrix. THRESH >= 0. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace) REAL array, */
+/* dimension(LDA, max(NN)) */
+/* Used to hold the original A matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, S, and T. */
+/* It must be at least 1 and at least max( NN ). */
+
+/* B (input/workspace) REAL array, */
+/* dimension(LDA, max(NN)) */
+/* Used to hold the original B matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* S (workspace) REAL array, dimension (LDA, max(NN)) */
+/* The Schur form matrix computed from A by SGGES. On exit, S */
+/* contains the Schur form matrix corresponding to the matrix */
+/* in A. */
+
+/* T (workspace) REAL array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from B by SGGES. */
+
+/* Q (workspace) REAL array, dimension (LDQ, max(NN)) */
+/* The (left) orthogonal matrix computed by SGGES. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of Q and Z. It must */
+/* be at least 1 and at least max( NN ). */
+
+/* Z (workspace) REAL array, dimension( LDQ, max(NN) ) */
+/* The (right) orthogonal matrix computed by SGGES. */
+
+/* ALPHAR (workspace) REAL array, dimension (max(NN)) */
+/* ALPHAI (workspace) REAL array, dimension (max(NN)) */
+/* BETA (workspace) REAL array, dimension (max(NN)) */
+/* The generalized eigenvalues of (A,B) computed by SGGES. */
+/* ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th */
+/* generalized eigenvalue of A and B. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* LWORK >= MAX( 10*(N+1), 3*N*N ), where N is the largest */
+/* matrix dimension. */
+
+/* RESULT (output) REAL array, dimension (15) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid overflow. */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: A routine returned an error code. INFO is the */
+/* absolute value of the INFO value returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ t_dim1 = *lda;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ s_dim1 = *lda;
+ s_offset = 1 + s_dim1;
+ s -= s_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ z_dim1 = *ldq;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ --work;
+ --result;
+ --bwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.f) {
+ *info = -6;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldq <= 1 || *ldq < nmax) {
+ *info = -14;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. */
+
+ minwrk = 1;
+ if (*info == 0 && *lwork >= 1) {
+/* Computing MAX */
+ i__1 = (nmax + 1) * 10, i__2 = nmax * 3 * nmax;
+ minwrk = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = 1, i__2 = ilaenv_(&c__1, "SGEQRF", " ", &nmax, &nmax, &c_n1, &
+ c_n1), i__1 = max(i__1,i__2), i__2 =
+ ilaenv_(&c__1, "SORMQR", "LT", &nmax, &nmax, &nmax, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
+ c__1, "SORGQR", " ", &nmax, &nmax, &nmax, &c_n1);
+ nb = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = (nmax + 1) * 10, i__2 = (nmax << 1) + nmax * nb, i__1 = max(
+ i__1,i__2), i__2 = nmax * 3 * nmax;
+ maxwrk = max(i__1,i__2);
+ work[1] = (real) maxwrk;
+ }
+
+ if (*lwork < minwrk) {
+ *info = -20;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SDRGES", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+ safmin = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ safmin /= ulp;
+ safmax = 1.f / safmin;
+ slabad_(&safmin, &safmax);
+ ulpinv = 1.f / ulp;
+
+/* The values RMAGN(2:3) depend on N, see below. */
+
+ rmagn[0] = 0.f;
+ rmagn[1] = 1.f;
+
+/* Loop over matrix sizes */
+
+ ntestt = 0;
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ n1 = max(1,n);
+ rmagn[2] = safmax * ulp / (real) n1;
+ rmagn[3] = safmin * ulpinv * (real) n1;
+
+ if (*nsizes != 1) {
+ mtypes = min(26,*ntypes);
+ } else {
+ mtypes = min(27,*ntypes);
+ }
+
+/* Loop over matrix types */
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L180;
+ }
+ ++nmats;
+ ntest = 0;
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 13; ++j) {
+ result[j] = 0.f;
+/* L30: */
+ }
+
+/* Generate test matrices A and B */
+
+/* Description of control parameters: */
+
+/* KCLASS: =1 means w/o rotation, =2 means w/ rotation, */
+/* =3 means random. */
+/* KATYPE: the "type" to be passed to SLATM4 for computing A. */
+/* KAZERO: the pattern of zeros on the diagonal for A: */
+/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
+/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
+/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
+/* non-zero entries.) */
+/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
+/* =2: large, =3: small. */
+/* IASIGN: 1 if the diagonal elements of A are to be */
+/* multiplied by a random magnitude 1 number, =2 if */
+/* randomly chosen diagonal blocks are to be rotated */
+/* to form 2x2 blocks. */
+/* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B. */
+/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
+/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
+/* RMAGN: used to implement KAMAGN and KBMAGN. */
+
+ if (mtypes > 26) {
+ goto L110;
+ }
+ iinfo = 0;
+ if (kclass[jtype - 1] < 3) {
+
+/* Generate A (w/o rotation) */
+
+ if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ slaset_("Full", &n, &n, &c_b26, &c_b26, &a[a_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ slatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
+ &kz2[kazero[jtype - 1] - 1], &iasign[jtype - 1], &
+ rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
+ 1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
+ a_offset], lda);
+ iadd = kadd[kazero[jtype - 1] - 1];
+ if (iadd > 0 && iadd <= n) {
+ a[iadd + iadd * a_dim1] = 1.f;
+ }
+
+/* Generate B (w/o rotation) */
+
+ if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ slaset_("Full", &n, &n, &c_b26, &c_b26, &b[b_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ slatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
+ &kz2[kbzero[jtype - 1] - 1], &ibsign[jtype - 1], &
+ rmagn[kbmagn[jtype - 1]], &c_b32, &rmagn[ktrian[jtype
+ - 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
+ b_offset], lda);
+ iadd = kadd[kbzero[jtype - 1] - 1];
+ if (iadd != 0 && iadd <= n) {
+ b[iadd + iadd * b_dim1] = 1.f;
+ }
+
+ if (kclass[jtype - 1] == 2 && n > 0) {
+
+/* Include rotations */
+
+/* Generate Q, Z as Householder transformations times */
+/* a diagonal matrix. */
+
+ i__3 = n - 1;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = jc; jr <= i__4; ++jr) {
+ q[jr + jc * q_dim1] = slarnd_(&c__3, &iseed[1]);
+ z__[jr + jc * z_dim1] = slarnd_(&c__3, &iseed[1]);
+/* L40: */
+ }
+ i__4 = n + 1 - jc;
+ slarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc *
+ q_dim1], &c__1, &work[jc]);
+ work[(n << 1) + jc] = r_sign(&c_b32, &q[jc + jc *
+ q_dim1]);
+ q[jc + jc * q_dim1] = 1.f;
+ i__4 = n + 1 - jc;
+ slarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 +
+ jc * z_dim1], &c__1, &work[n + jc]);
+ work[n * 3 + jc] = r_sign(&c_b32, &z__[jc + jc *
+ z_dim1]);
+ z__[jc + jc * z_dim1] = 1.f;
+/* L50: */
+ }
+ q[n + n * q_dim1] = 1.f;
+ work[n] = 0.f;
+ r__1 = slarnd_(&c__2, &iseed[1]);
+ work[n * 3] = r_sign(&c_b32, &r__1);
+ z__[n + n * z_dim1] = 1.f;
+ work[n * 2] = 0.f;
+ r__1 = slarnd_(&c__2, &iseed[1]);
+ work[n * 4] = r_sign(&c_b32, &r__1);
+
+/* Apply the diagonal matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ a[jr + jc * a_dim1] = work[(n << 1) + jr] * work[
+ n * 3 + jc] * a[jr + jc * a_dim1];
+ b[jr + jc * b_dim1] = work[(n << 1) + jr] * work[
+ n * 3 + jc] * b[jr + jc * b_dim1];
+/* L60: */
+ }
+/* L70: */
+ }
+ i__3 = n - 1;
+ sorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ sorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &a[a_offset], lda, &work[(n << 1) +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ sorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &b[b_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ sorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &b[b_offset], lda, &work[(n << 1) +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ }
+ } else {
+
+/* Random matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ a[jr + jc * a_dim1] = rmagn[kamagn[jtype - 1]] *
+ slarnd_(&c__2, &iseed[1]);
+ b[jr + jc * b_dim1] = rmagn[kbmagn[jtype - 1]] *
+ slarnd_(&c__2, &iseed[1]);
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+
+L100:
+
+ if (iinfo != 0) {
+ io___40.ciunit = *nounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L110:
+
+ for (i__ = 1; i__ <= 13; ++i__) {
+ result[i__] = -1.f;
+/* L120: */
+ }
+
+/* Test with and without sorting of eigenvalues */
+
+ for (isort = 0; isort <= 1; ++isort) {
+ if (isort == 0) {
+ *(unsigned char *)sort = 'N';
+ rsub = 0;
+ } else {
+ *(unsigned char *)sort = 'S';
+ rsub = 5;
+ }
+
+/* Call SGGES to compute H, T, Q, Z, alpha, and beta. */
+
+ slacpy_("Full", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ slacpy_("Full", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ ntest = rsub + 1 + isort;
+ result[rsub + 1 + isort] = ulpinv;
+ sgges_("V", "V", sort, (L_fp)slctes_, &n, &s[s_offset], lda, &
+ t[t_offset], lda, &sdim, &alphar[1], &alphai[1], &
+ beta[1], &q[q_offset], ldq, &z__[z_offset], ldq, &
+ work[1], lwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != n + 2) {
+ result[rsub + 1 + isort] = ulpinv;
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, "SGGES", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L160;
+ }
+
+ ntest = rsub + 4;
+
+/* Do tests 1--4 (or tests 7--9 when reordering ) */
+
+ if (isort == 0) {
+ sget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, &
+ q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
+ result[1]);
+ sget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &
+ q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
+ result[2]);
+ } else {
+ sget54_(&n, &a[a_offset], lda, &b[b_offset], lda, &s[
+ s_offset], lda, &t[t_offset], lda, &q[q_offset],
+ ldq, &z__[z_offset], ldq, &work[1], &result[7]);
+ }
+ sget51_(&c__3, &n, &a[a_offset], lda, &t[t_offset], lda, &q[
+ q_offset], ldq, &q[q_offset], ldq, &work[1], &result[
+ rsub + 3]);
+ sget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[
+ z_offset], ldq, &z__[z_offset], ldq, &work[1], &
+ result[rsub + 4]);
+
+/* Do test 5 and 6 (or Tests 10 and 11 when reordering): */
+/* check Schur form of A and compare eigenvalues with */
+/* diagonals. */
+
+ ntest = rsub + 6;
+ temp1 = 0.f;
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ ilabad = FALSE_;
+ if (alphai[j] == 0.f) {
+/* Computing MAX */
+ r__7 = safmin, r__8 = (r__2 = alphar[j], dabs(r__2)),
+ r__7 = max(r__7,r__8), r__8 = (r__3 = s[j + j
+ * s_dim1], dabs(r__3));
+/* Computing MAX */
+ r__9 = safmin, r__10 = (r__5 = beta[j], dabs(r__5)),
+ r__9 = max(r__9,r__10), r__10 = (r__6 = t[j +
+ j * t_dim1], dabs(r__6));
+ temp2 = ((r__1 = alphar[j] - s[j + j * s_dim1], dabs(
+ r__1)) / dmax(r__7,r__8) + (r__4 = beta[j] -
+ t[j + j * t_dim1], dabs(r__4)) / dmax(r__9,
+ r__10)) / ulp;
+
+ if (j < n) {
+ if (s[j + 1 + j * s_dim1] != 0.f) {
+ ilabad = TRUE_;
+ result[rsub + 5] = ulpinv;
+ }
+ }
+ if (j > 1) {
+ if (s[j + (j - 1) * s_dim1] != 0.f) {
+ ilabad = TRUE_;
+ result[rsub + 5] = ulpinv;
+ }
+ }
+
+ } else {
+ if (alphai[j] > 0.f) {
+ i1 = j;
+ } else {
+ i1 = j - 1;
+ }
+ if (i1 <= 0 || i1 >= n) {
+ ilabad = TRUE_;
+ } else if (i1 < n - 1) {
+ if (s[i1 + 2 + (i1 + 1) * s_dim1] != 0.f) {
+ ilabad = TRUE_;
+ result[rsub + 5] = ulpinv;
+ }
+ } else if (i1 > 1) {
+ if (s[i1 + (i1 - 1) * s_dim1] != 0.f) {
+ ilabad = TRUE_;
+ result[rsub + 5] = ulpinv;
+ }
+ }
+ if (! ilabad) {
+ sget53_(&s[i1 + i1 * s_dim1], lda, &t[i1 + i1 *
+ t_dim1], lda, &beta[j], &alphar[j], &
+ alphai[j], &temp2, &ierr);
+ if (ierr >= 3) {
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ *info = abs(ierr);
+ }
+ } else {
+ temp2 = ulpinv;
+ }
+
+ }
+ temp1 = dmax(temp1,temp2);
+ if (ilabad) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+/* L130: */
+ }
+ result[rsub + 6] = temp1;
+
+ if (isort >= 1) {
+
+/* Do test 12 */
+
+ ntest = 12;
+ result[12] = 0.f;
+ knteig = 0;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ r__1 = -alphai[i__];
+ if (slctes_(&alphar[i__], &alphai[i__], &beta[i__]) ||
+ slctes_(&alphar[i__], &r__1, &beta[i__])) {
+ ++knteig;
+ }
+ if (i__ < n) {
+ r__1 = -alphai[i__ + 1];
+ r__2 = -alphai[i__];
+ if ((slctes_(&alphar[i__ + 1], &alphai[i__ + 1], &
+ beta[i__ + 1]) || slctes_(&alphar[i__ + 1]
+, &r__1, &beta[i__ + 1])) && ! (slctes_(&
+ alphar[i__], &alphai[i__], &beta[i__]) ||
+ slctes_(&alphar[i__], &r__2, &beta[i__]))
+ && iinfo != n + 2) {
+ result[12] = ulpinv;
+ }
+ }
+/* L140: */
+ }
+ if (sdim != knteig) {
+ result[12] = ulpinv;
+ }
+ }
+
+/* L150: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L160:
+
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__3 = ntest;
+ for (jr = 1; jr <= i__3; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+ do_fio(&c__1, "SGS", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ e_wsfe();
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ e_wsfe();
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ do_fio(&c__1, "Orthogonal", (ftnlen)10);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, "orthogonal", (ftnlen)10);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ for (j = 1; j <= 8; ++j) {
+ do_fio(&c__1, "'", (ftnlen)1);
+ }
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[jr] < 1e4f) {
+ io___60.ciunit = *nounit;
+ s_wsfe(&io___60);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ } else {
+ io___61.ciunit = *nounit;
+ s_wsfe(&io___61);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ }
+ }
+/* L170: */
+ }
+
+L180:
+ ;
+ }
+/* L190: */
+ }
+
+/* Summary */
+
+ alasvm_("SGS", nounit, &nerrs, &ntestt, &c__0);
+
+ work[1] = (real) maxwrk;
+
+ return 0;
+
+
+
+
+
+
+
+
+/* End of SDRGES */
+
+} /* sdrges_ */
diff --git a/TESTING/EIG/sdrgev.c b/TESTING/EIG/sdrgev.c
new file mode 100644
index 0000000..4a01f1e
--- /dev/null
+++ b/TESTING/EIG/sdrgev.c
@@ -0,0 +1,1067 @@
+/* sdrgev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static real c_b17 = 0.f;
+static integer c__2 = 2;
+static real c_b23 = 1.f;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int sdrgev_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, integer *nounit, real *
+ a, integer *lda, real *b, real *s, real *t, real *q, integer *ldq,
+ real *z__, real *qe, integer *ldqe, real *alphar, real *alphai, real *
+ beta, real *alphr1, real *alphi1, real *beta1, real *work, integer *
+ lwork, real *result, integer *info)
+{
+ /* Initialized data */
+
+ static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
+ 2,2,2,3 };
+ static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
+ 2,3,2,1 };
+ static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
+ 1,1,1,1 };
+ static integer iasign[26] = { 0,0,0,0,0,0,2,0,2,2,0,0,2,2,2,0,2,0,0,0,2,2,
+ 2,2,2,0 };
+ static integer ibsign[26] = { 0,0,0,0,0,0,0,2,0,0,2,2,0,0,2,0,2,0,0,0,0,0,
+ 0,0,0,0 };
+ static integer kz1[6] = { 0,1,2,1,3,3 };
+ static integer kz2[6] = { 0,0,1,2,1,1 };
+ static integer kadd[6] = { 0,0,0,0,3,2 };
+ static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
+ 4,4,4,0 };
+ static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
+ 8,8,8,8,8,0 };
+ static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
+ 3,3,3,1 };
+ static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
+ 4,4,4,1 };
+ static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
+ 3,3,2,1 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 SDRGEV: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/3x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,4(i4,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 SDRGEV: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,3x,\002N=\002,i4,\002, JTYPE=\002,"
+ "i3,\002, ISEED=(\002,4(i4,\002,\002),i5,\002)\002)";
+ static char fmt_9997[] = "(/1x,a3,\002 -- Real Generalized eigenvalue pr"
+ "oblem driver\002)";
+ static char fmt_9996[] = "(\002 Matrix types (see SDRGEV for details):"
+ " \002)";
+ static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
+ "osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
+ ") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
+ "onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
+ "I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
+ "arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
+ "(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
+ "=(D, reversed D)\002)";
+ static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
+ "atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
+ " 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
+ "ha&beta \002,\002 20=arithmetic alpha, beta=0,"
+ "1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
+ "=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
+ "/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
+ "l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
+ ".\002)";
+ static char fmt_9993[] = "(/\002 Tests performed: \002,/\002 1 = max "
+ "| ( b A - a B )'*l | / const.,\002,/\002 2 = | |VR(i)| - 1 | / u"
+ "lp,\002,/\002 3 = max | ( b A - a B )*r | / const.\002,/\002 4 ="
+ " | |VL(i)| - 1 | / ulp,\002,/\002 5 = 0 if W same no matter if r"
+ " or l computed,\002,/\002 6 = 0 if l same no matter if l compute"
+ "d,\002,/\002 7 = 0 if r same no matter if r computed,\002,/1x)";
+ static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",0p,f8.2)";
+ static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",1p,e10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, qe_dim1,
+ qe_offset, s_dim1, s_offset, t_dim1, t_offset, z_dim1, z_offset,
+ i__1, i__2, i__3, i__4;
+ real r__1;
+
+ /* Builtin functions */
+ double r_sign(real *, real *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, n, n1, jc, in, jr;
+ real ulp;
+ integer iadd, ierr, nmax;
+ logical badnn;
+ real rmagn[4];
+ extern /* Subroutine */ int sget52_(logical *, integer *, real *, integer
+ *, real *, integer *, real *, integer *, real *, real *, real *,
+ real *, real *), sggev_(char *, char *, integer *, real *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ integer *, real *, integer *, real *, integer *, integer *);
+ integer nmats, jsize, nerrs, jtype;
+ extern /* Subroutine */ int slatm4_(integer *, integer *, integer *,
+ integer *, integer *, real *, real *, real *, integer *, integer *
+, real *, integer *), sorm2r_(char *, char *, integer *, integer *
+, integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *), slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ integer ioldsd[4];
+ real safmax;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
+ real *);
+ extern doublereal slarnd_(integer *, integer *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *), xerbla_(char *, integer *),
+ slacpy_(char *, integer *, integer *, real *, integer *, real *,
+ integer *), slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *);
+ integer minwrk, maxwrk;
+ real ulpinv;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___38 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9991, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRGEV checks the nonsymmetric generalized eigenvalue problem driver */
+/* routine SGGEV. */
+
+/* SGGEV computes for a pair of n-by-n nonsymmetric matrices (A,B) the */
+/* generalized eigenvalues and, optionally, the left and right */
+/* eigenvectors. */
+
+/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w */
+/* or a ratio alpha/beta = w, such that A - w*B is singular. It is */
+/* usually represented as the pair (alpha,beta), as there is reasonalbe */
+/* interpretation for beta=0, and even for both being zero. */
+
+/* A right generalized eigenvector corresponding to a generalized */
+/* eigenvalue w for a pair of matrices (A,B) is a vector r such that */
+/* (A - wB) * r = 0. A left generalized eigenvector is a vector l such */
+/* that l**H * (A - wB) = 0, where l**H is the conjugate-transpose of l. */
+
+/* When SDRGEV is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, a pair of matrices (A, B) will be generated */
+/* and used for testing. For each matrix pair, the following tests */
+/* will be performed and compared with the threshhold THRESH. */
+
+/* Results from SGGEV: */
+
+/* (1) max over all left eigenvalue/-vector pairs (alpha/beta,l) of */
+
+/* | VL**H * (beta A - alpha B) |/( ulp max(|beta A|, |alpha B|) ) */
+
+/* where VL**H is the conjugate-transpose of VL. */
+
+/* (2) | |VL(i)| - 1 | / ulp and whether largest component real */
+
+/* VL(i) denotes the i-th column of VL. */
+
+/* (3) max over all left eigenvalue/-vector pairs (alpha/beta,r) of */
+
+/* | (beta A - alpha B) * VR | / ( ulp max(|beta A|, |alpha B|) ) */
+
+/* (4) | |VR(i)| - 1 | / ulp and whether largest component real */
+
+/* VR(i) denotes the i-th column of VR. */
+
+/* (5) W(full) = W(partial) */
+/* W(full) denotes the eigenvalues computed when both l and r */
+/* are also computed, and W(partial) denotes the eigenvalues */
+/* computed when only W, only W and r, or only W and l are */
+/* computed. */
+
+/* (6) VL(full) = VL(partial) */
+/* VL(full) denotes the left eigenvectors computed when both l */
+/* and r are computed, and VL(partial) denotes the result */
+/* when only l is computed. */
+
+/* (7) VR(full) = VR(partial) */
+/* VR(full) denotes the right eigenvectors computed when both l */
+/* and r are also computed, and VR(partial) denotes the result */
+/* when only l is computed. */
+
+
+/* Test Matrices */
+/* ---- -------- */
+
+/* The sizes of the test matrices are specified by an array */
+/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
+/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) ( 0, 0 ) (a pair of zero matrices) */
+
+/* (2) ( I, 0 ) (an identity and a zero matrix) */
+
+/* (3) ( 0, I ) (an identity and a zero matrix) */
+
+/* (4) ( I, I ) (a pair of identity matrices) */
+
+/* t t */
+/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
+
+/* t ( I 0 ) */
+/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
+/* ( 0 I ) ( 0 J ) */
+/* and I is a k x k identity and J a (k+1)x(k+1) */
+/* Jordan block; k=(N-1)/2 */
+
+/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
+/* matrix with those diagonal entries.) */
+/* (8) ( I, D ) */
+
+/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
+
+/* (10) ( small*D, big*I ) */
+
+/* (11) ( big*I, small*D ) */
+
+/* (12) ( small*I, big*D ) */
+
+/* (13) ( big*D, big*I ) */
+
+/* (14) ( small*D, small*I ) */
+
+/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
+/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
+/* t t */
+/* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. */
+
+/* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices */
+/* with random O(1) entries above the diagonal */
+/* and diagonal entries diag(T1) = */
+/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
+/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
+
+/* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
+/* s = machine precision. */
+
+/* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
+
+/* N-5 */
+/* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+
+/* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+/* where r1,..., r(N-4) are random. */
+
+/* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular */
+/* matrices. */
+
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* SDRGES does nothing. NSIZES >= 0. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. NN >= 0. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, SDRGES */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to SDRGES to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error is */
+/* scaled to be O(1), so THRESH should be a reasonably small */
+/* multiple of 1, e.g., 10 or 100. In particular, it should */
+/* not depend on the precision (single vs. double) or the size */
+/* of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IERR not equal to 0.) */
+
+/* A (input/workspace) REAL array, */
+/* dimension(LDA, max(NN)) */
+/* Used to hold the original A matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, S, and T. */
+/* It must be at least 1 and at least max( NN ). */
+
+/* B (input/workspace) REAL array, */
+/* dimension(LDA, max(NN)) */
+/* Used to hold the original B matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* S (workspace) REAL array, */
+/* dimension (LDA, max(NN)) */
+/* The Schur form matrix computed from A by SGGES. On exit, S */
+/* contains the Schur form matrix corresponding to the matrix */
+/* in A. */
+
+/* T (workspace) REAL array, */
+/* dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from B by SGGES. */
+
+/* Q (workspace) REAL array, */
+/* dimension (LDQ, max(NN)) */
+/* The (left) eigenvectors matrix computed by SGGEV. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of Q and Z. It must */
+/* be at least 1 and at least max( NN ). */
+
+/* Z (workspace) REAL array, dimension( LDQ, max(NN) ) */
+/* The (right) orthogonal matrix computed by SGGES. */
+
+/* QE (workspace) REAL array, dimension( LDQ, max(NN) ) */
+/* QE holds the computed right or left eigenvectors. */
+
+/* LDQE (input) INTEGER */
+/* The leading dimension of QE. LDQE >= max(1,max(NN)). */
+
+/* ALPHAR (workspace) REAL array, dimension (max(NN)) */
+/* ALPHAI (workspace) REAL array, dimension (max(NN)) */
+/* BETA (workspace) REAL array, dimension (max(NN)) */
+/* The generalized eigenvalues of (A,B) computed by SGGEV. */
+/* ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th */
+/* generalized eigenvalue of A and B. */
+
+/* ALPHR1 (workspace) REAL array, dimension (max(NN)) */
+/* ALPHI1 (workspace) REAL array, dimension (max(NN)) */
+/* BETA1 (workspace) REAL array, dimension (max(NN)) */
+/* Like ALPHAR, ALPHAI, BETA, these arrays contain the */
+/* eigenvalues of A and B, but those computed when SGGEV only */
+/* computes a partial eigendecomposition, i.e. not the */
+/* eigenvalues and left and right eigenvectors. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. LWORK >= MAX( 8*N, N*(N+1) ). */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid overflow. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: A routine returned an error code. INFO is the */
+/* absolute value of the INFO value returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ t_dim1 = *lda;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ s_dim1 = *lda;
+ s_offset = 1 + s_dim1;
+ s -= s_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ z_dim1 = *ldq;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ qe_dim1 = *ldqe;
+ qe_offset = 1 + qe_dim1;
+ qe -= qe_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ --alphr1;
+ --alphi1;
+ --beta1;
+ --work;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.f) {
+ *info = -6;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldq <= 1 || *ldq < nmax) {
+ *info = -14;
+ } else if (*ldqe <= 1 || *ldqe < nmax) {
+ *info = -17;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. */
+
+ minwrk = 1;
+ if (*info == 0 && *lwork >= 1) {
+/* Computing MAX */
+ i__1 = 1, i__2 = nmax << 3, i__1 = max(i__1,i__2), i__2 = nmax * (
+ nmax + 1);
+ minwrk = max(i__1,i__2);
+ maxwrk = nmax * 7 + nmax * ilaenv_(&c__1, "SGEQRF", " ", &nmax, &c__1,
+ &nmax, &c__0);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = nmax * (nmax + 1);
+ maxwrk = max(i__1,i__2);
+ work[1] = (real) maxwrk;
+ }
+
+ if (*lwork < minwrk) {
+ *info = -25;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SDRGEV", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+ safmin = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ safmin /= ulp;
+ safmax = 1.f / safmin;
+ slabad_(&safmin, &safmax);
+ ulpinv = 1.f / ulp;
+
+/* The values RMAGN(2:3) depend on N, see below. */
+
+ rmagn[0] = 0.f;
+ rmagn[1] = 1.f;
+
+/* Loop over sizes, types */
+
+ ntestt = 0;
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ n1 = max(1,n);
+ rmagn[2] = safmax * ulp / (real) n1;
+ rmagn[3] = safmin * ulpinv * n1;
+
+ if (*nsizes != 1) {
+ mtypes = min(26,*ntypes);
+ } else {
+ mtypes = min(27,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L210;
+ }
+ ++nmats;
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Generate test matrices A and B */
+
+/* Description of control parameters: */
+
+/* KCLASS: =1 means w/o rotation, =2 means w/ rotation, */
+/* =3 means random. */
+/* KATYPE: the "type" to be passed to SLATM4 for computing A. */
+/* KAZERO: the pattern of zeros on the diagonal for A: */
+/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
+/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
+/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
+/* non-zero entries.) */
+/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
+/* =2: large, =3: small. */
+/* IASIGN: 1 if the diagonal elements of A are to be */
+/* multiplied by a random magnitude 1 number, =2 if */
+/* randomly chosen diagonal blocks are to be rotated */
+/* to form 2x2 blocks. */
+/* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B. */
+/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
+/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
+/* RMAGN: used to implement KAMAGN and KBMAGN. */
+
+ if (mtypes > 26) {
+ goto L100;
+ }
+ ierr = 0;
+ if (kclass[jtype - 1] < 3) {
+
+/* Generate A (w/o rotation) */
+
+ if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ slaset_("Full", &n, &n, &c_b17, &c_b17, &a[a_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ slatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
+ &kz2[kazero[jtype - 1] - 1], &iasign[jtype - 1], &
+ rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
+ 1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
+ a_offset], lda);
+ iadd = kadd[kazero[jtype - 1] - 1];
+ if (iadd > 0 && iadd <= n) {
+ a[iadd + iadd * a_dim1] = 1.f;
+ }
+
+/* Generate B (w/o rotation) */
+
+ if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ slaset_("Full", &n, &n, &c_b17, &c_b17, &b[b_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ slatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
+ &kz2[kbzero[jtype - 1] - 1], &ibsign[jtype - 1], &
+ rmagn[kbmagn[jtype - 1]], &c_b23, &rmagn[ktrian[jtype
+ - 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
+ b_offset], lda);
+ iadd = kadd[kbzero[jtype - 1] - 1];
+ if (iadd != 0 && iadd <= n) {
+ b[iadd + iadd * b_dim1] = 1.f;
+ }
+
+ if (kclass[jtype - 1] == 2 && n > 0) {
+
+/* Include rotations */
+
+/* Generate Q, Z as Householder transformations times */
+/* a diagonal matrix. */
+
+ i__3 = n - 1;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = jc; jr <= i__4; ++jr) {
+ q[jr + jc * q_dim1] = slarnd_(&c__3, &iseed[1]);
+ z__[jr + jc * z_dim1] = slarnd_(&c__3, &iseed[1]);
+/* L30: */
+ }
+ i__4 = n + 1 - jc;
+ slarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc *
+ q_dim1], &c__1, &work[jc]);
+ work[(n << 1) + jc] = r_sign(&c_b23, &q[jc + jc *
+ q_dim1]);
+ q[jc + jc * q_dim1] = 1.f;
+ i__4 = n + 1 - jc;
+ slarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 +
+ jc * z_dim1], &c__1, &work[n + jc]);
+ work[n * 3 + jc] = r_sign(&c_b23, &z__[jc + jc *
+ z_dim1]);
+ z__[jc + jc * z_dim1] = 1.f;
+/* L40: */
+ }
+ q[n + n * q_dim1] = 1.f;
+ work[n] = 0.f;
+ r__1 = slarnd_(&c__2, &iseed[1]);
+ work[n * 3] = r_sign(&c_b23, &r__1);
+ z__[n + n * z_dim1] = 1.f;
+ work[n * 2] = 0.f;
+ r__1 = slarnd_(&c__2, &iseed[1]);
+ work[n * 4] = r_sign(&c_b23, &r__1);
+
+/* Apply the diagonal matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ a[jr + jc * a_dim1] = work[(n << 1) + jr] * work[
+ n * 3 + jc] * a[jr + jc * a_dim1];
+ b[jr + jc * b_dim1] = work[(n << 1) + jr] * work[
+ n * 3 + jc] * b[jr + jc * b_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+ i__3 = n - 1;
+ sorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &a[a_offset], lda, &work[(n << 1) + 1], &ierr);
+ if (ierr != 0) {
+ goto L90;
+ }
+ i__3 = n - 1;
+ sorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &a[a_offset], lda, &work[(n << 1) +
+ 1], &ierr);
+ if (ierr != 0) {
+ goto L90;
+ }
+ i__3 = n - 1;
+ sorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &b[b_offset], lda, &work[(n << 1) + 1], &ierr);
+ if (ierr != 0) {
+ goto L90;
+ }
+ i__3 = n - 1;
+ sorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &b[b_offset], lda, &work[(n << 1) +
+ 1], &ierr);
+ if (ierr != 0) {
+ goto L90;
+ }
+ }
+ } else {
+
+/* Random matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ a[jr + jc * a_dim1] = rmagn[kamagn[jtype - 1]] *
+ slarnd_(&c__2, &iseed[1]);
+ b[jr + jc * b_dim1] = rmagn[kbmagn[jtype - 1]] *
+ slarnd_(&c__2, &iseed[1]);
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+
+L90:
+
+ if (ierr != 0) {
+ io___38.ciunit = *nounit;
+ s_wsfe(&io___38);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(ierr);
+ return 0;
+ }
+
+L100:
+
+ for (i__ = 1; i__ <= 7; ++i__) {
+ result[i__] = -1.f;
+/* L110: */
+ }
+
+/* Call SGGEV to compute eigenvalues and eigenvectors. */
+
+ slacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ slacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ sggev_("V", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
+ alphar[1], &alphai[1], &beta[1], &q[q_offset], ldq, &z__[
+ z_offset], ldq, &work[1], lwork, &ierr);
+ if (ierr != 0 && ierr != n + 1) {
+ result[1] = ulpinv;
+ io___40.ciunit = *nounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "SGGEV1", (ftnlen)6);
+ do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(ierr);
+ goto L190;
+ }
+
+/* Do the tests (1) and (2) */
+
+ sget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &q[
+ q_offset], ldq, &alphar[1], &alphai[1], &beta[1], &work[1]
+, &result[1]);
+ if (result[2] > *thresh) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "SGGEV1", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Do the tests (3) and (4) */
+
+ sget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &z__[
+ z_offset], ldq, &alphar[1], &alphai[1], &beta[1], &work[1]
+, &result[3]);
+ if (result[4] > *thresh) {
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "SGGEV1", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[4], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Do the test (5) */
+
+ slacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ slacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ sggev_("N", "N", &n, &s[s_offset], lda, &t[t_offset], lda, &
+ alphr1[1], &alphi1[1], &beta1[1], &q[q_offset], ldq, &z__[
+ z_offset], ldq, &work[1], lwork, &ierr);
+ if (ierr != 0 && ierr != n + 1) {
+ result[1] = ulpinv;
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "SGGEV2", (ftnlen)6);
+ do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(ierr);
+ goto L190;
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ if (alphar[j] != alphr1[j] || alphai[j] != alphi1[j] || beta[
+ j] != beta1[j]) {
+ result[5] = ulpinv;
+ }
+/* L120: */
+ }
+
+/* Do the test (6): Compute eigenvalues and left eigenvectors, */
+/* and test them */
+
+ slacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ slacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ sggev_("V", "N", &n, &s[s_offset], lda, &t[t_offset], lda, &
+ alphr1[1], &alphi1[1], &beta1[1], &qe[qe_offset], ldqe, &
+ z__[z_offset], ldq, &work[1], lwork, &ierr);
+ if (ierr != 0 && ierr != n + 1) {
+ result[1] = ulpinv;
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "SGGEV3", (ftnlen)6);
+ do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(ierr);
+ goto L190;
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ if (alphar[j] != alphr1[j] || alphai[j] != alphi1[j] || beta[
+ j] != beta1[j]) {
+ result[6] = ulpinv;
+ }
+/* L130: */
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (jc = 1; jc <= i__4; ++jc) {
+ if (q[j + jc * q_dim1] != qe[j + jc * qe_dim1]) {
+ result[6] = ulpinv;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+/* DO the test (7): Compute eigenvalues and right eigenvectors, */
+/* and test them */
+
+ slacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ slacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ sggev_("N", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
+ alphr1[1], &alphi1[1], &beta1[1], &q[q_offset], ldq, &qe[
+ qe_offset], ldqe, &work[1], lwork, &ierr);
+ if (ierr != 0 && ierr != n + 1) {
+ result[1] = ulpinv;
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "SGGEV4", (ftnlen)6);
+ do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(ierr);
+ goto L190;
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ if (alphar[j] != alphr1[j] || alphai[j] != alphi1[j] || beta[
+ j] != beta1[j]) {
+ result[7] = ulpinv;
+ }
+/* L160: */
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (jc = 1; jc <= i__4; ++jc) {
+ if (z__[j + jc * z_dim1] != qe[j + jc * qe_dim1]) {
+ result[7] = ulpinv;
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L190:
+
+ ntestt += 7;
+
+/* Print out tests which fail. */
+
+ for (jr = 1; jr <= 7; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, "SGV", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ e_wsfe();
+ io___48.ciunit = *nounit;
+ s_wsfe(&io___48);
+ e_wsfe();
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ do_fio(&c__1, "Orthogonal", (ftnlen)10);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[jr] < 1e4f) {
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ } else {
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ }
+ }
+/* L200: */
+ }
+
+L210:
+ ;
+ }
+/* L220: */
+ }
+
+/* Summary */
+
+ alasvm_("SGV", nounit, &nerrs, &ntestt, &c__0);
+
+ work[1] = (real) maxwrk;
+
+ return 0;
+
+
+
+
+
+
+
+/* End of SDRGEV */
+
+} /* sdrgev_ */
diff --git a/TESTING/EIG/sdrgsx.c b/TESTING/EIG/sdrgsx.c
new file mode 100644
index 0000000..57a57ad
--- /dev/null
+++ b/TESTING/EIG/sdrgsx.c
@@ -0,0 +1,1255 @@
+/* sdrgsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer m, n, mplusn, k;
+ logical fs;
+} mn_;
+
+#define mn_1 mn_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static real c_b26 = 0.f;
+static integer c__3 = 3;
+static integer c__4 = 4;
+
+/* Subroutine */ int sdrgsx_(integer *nsize, integer *ncmax, real *thresh,
+ integer *nin, integer *nout, real *a, integer *lda, real *b, real *ai,
+ real *bi, real *z__, real *q, real *alphar, real *alphai, real *beta,
+ real *c__, integer *ldc, real *s, real *work, integer *lwork,
+ integer *iwork, integer *liwork, logical *bwork, integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 SDRGSX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002)\002)";
+ static char fmt_9997[] = "(\002 SDRGSX: SGET53 returned INFO=\002,i1,"
+ "\002 for eigenvalue \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JT"
+ "YPE=\002,i6,\002)\002)";
+ static char fmt_9996[] = "(\002 SDRGSX: S not in Schur form at eigenvalu"
+ "e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002"
+ ")\002)";
+ static char fmt_9995[] = "(/1x,a3,\002 -- Real Expert Generalized Schur "
+ "form\002,\002 problem driver\002)";
+ static char fmt_9993[] = "(\002 Matrix types: \002,/\002 1: A is a blo"
+ "ck diagonal matrix of Jordan blocks \002,\002and B is the identi"
+ "ty \002,/\002 matrix, \002,/\002 2: A and B are upper tri"
+ "angular matrices, \002,/\002 3: A and B are as type 2, but eac"
+ "h second diagonal \002,\002block in A_11 and \002,/\002 eac"
+ "h third diaongal block in A_22 are 2x2 blocks,\002,/\002 4: A "
+ "and B are block diagonal matrices, \002,/\002 5: (A,B) has pot"
+ "entially close or common \002,\002eigenvalues.\002,/)";
+ static char fmt_9992[] = "(/\002 Tests performed: (S is Schur, T is tri"
+ "angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002 a is al"
+ "pha, b is beta, and \002,a,\002 means \002,a,\002.)\002,/\002 1"
+ " = | A - Q S Z\002,a,\002 | / ( |A| n ulp ) 2 = | B - Q T "
+ "Z\002,a,\002 | / ( |B| n ulp )\002,/\002 3 = | I - QQ\002,a,"
+ "\002 | / ( n ulp ) 4 = | I - ZZ\002,a,\002 | / ( n u"
+ "lp )\002,/\002 5 = 1/ULP if A is not in \002,\002Schur form "
+ "S\002,/\002 6 = difference between (alpha,beta)\002,\002 and di"
+ "agonals of (S,T)\002,/\002 7 = 1/ULP if SDIM is not the correc"
+ "t number of \002,\002selected eigenvalues\002,/\002 8 = 1/ULP "
+ "if DIFEST/DIFTRU > 10*THRESH or \002,\002DIFTRU/DIFEST > 10*THRE"
+ "SH\002,/\002 9 = 1/ULP if DIFEST <> 0 or DIFTRU > ULP*norm(A,B"
+ ") \002,\002when reordering fails\002,/\002 10 = 1/ULP if PLEST/"
+ "PLTRU > THRESH or \002,\002PLTRU/PLEST > THRESH\002,/\002 ( T"
+ "est 10 is only for input examples )\002,/)";
+ static char fmt_9991[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
+ ",\002, a=\002,e10.4,\002, order(A_11)=\002,i2,\002, result \002,"
+ "i2,\002 is \002,0p,f8.2)";
+ static char fmt_9990[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
+ ",\002, a=\002,e10.4,\002, order(A_11)=\002,i2,\002, result \002,"
+ "i2,\002 is \002,0p,e10.4)";
+ static char fmt_9998[] = "(\002 SDRGSX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, Input Example #\002,i2,\002"
+ ")\002)";
+ static char fmt_9994[] = "(\002Input Example\002)";
+ static char fmt_9989[] = "(\002 Input example #\002,i2,\002, matrix orde"
+ "r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,0p,f8.2)";
+ static char fmt_9988[] = "(\002 Input example #\002,i2,\002, matrix orde"
+ "r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,1p,e10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, ai_dim1, ai_offset, b_dim1, b_offset, bi_dim1,
+ bi_offset, c_dim1, c_offset, q_dim1, q_offset, z_dim1, z_offset,
+ i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+
+ /* Local variables */
+ integer i__, j, i1, mm;
+ real pl[2];
+ integer mn2, qba, qbb;
+ real ulp, temp1, temp2, abnrm;
+ integer ifunc, iinfo, linfo;
+ extern /* Subroutine */ int sget51_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, integer *, real *, integer *, real *
+, real *), sget53_(real *, integer *, real *, integer *, real *,
+ real *, real *, real *, integer *);
+ char sense[1];
+ integer nerrs, ntest;
+ real pltru;
+ extern /* Subroutine */ int slakf2_(integer *, integer *, real *, integer
+ *, real *, real *, real *, real *, integer *), slatm5_(integer *,
+ integer *, integer *, real *, integer *, real *, integer *, real *
+, integer *, real *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, integer *);
+ real thrsh2;
+ logical ilabad;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ integer bdspac;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real difest[2];
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ real bignum;
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ real weight;
+ extern /* Subroutine */ int sgesvd_(char *, char *, integer *, integer *,
+ real *, integer *, real *, real *, integer *, real *, integer *,
+ real *, integer *, integer *), slacpy_(char *,
+ integer *, integer *, real *, integer *, real *, integer *);
+ real diftru;
+ extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *), sggesx_(char *, char *, char *
+, L_fp, char *, integer *, real *, integer *, real *, integer *,
+ integer *, real *, real *, real *, real *, integer *, real *,
+ integer *, real *, real *, real *, integer *, integer *, integer *
+, logical *, integer *);
+ integer minwrk, maxwrk;
+ real smlnum, ulpinv;
+ integer nptknt;
+ real result[10];
+ extern logical slctsx_();
+ integer ntestt, prtype;
+
+ /* Fortran I/O blocks */
+ static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___42 = { 0, 0, 1, 0, 0 };
+ static cilist io___43 = { 0, 0, 1, 0, 0 };
+ static cilist io___44 = { 0, 0, 0, 0, 0 };
+ static cilist io___45 = { 0, 0, 0, 0, 0 };
+ static cilist io___46 = { 0, 0, 0, 0, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9988, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRGSX checks the nonsymmetric generalized eigenvalue (Schur form) */
+/* problem expert driver SGGESX. */
+
+/* SGGESX factors A and B as Q S Z' and Q T Z', where ' means */
+/* transpose, T is upper triangular, S is in generalized Schur form */
+/* (block upper triangular, with 1x1 and 2x2 blocks on the diagonal, */
+/* the 2x2 blocks corresponding to complex conjugate pairs of */
+/* generalized eigenvalues), and Q and Z are orthogonal. It also */
+/* computes the generalized eigenvalues (alpha(1),beta(1)), ..., */
+/* (alpha(n),beta(n)). Thus, w(j) = alpha(j)/beta(j) is a root of the */
+/* characteristic equation */
+
+/* det( A - w(j) B ) = 0 */
+
+/* Optionally it also reorders the eigenvalues so that a selected */
+/* cluster of eigenvalues appears in the leading diagonal block of the */
+/* Schur forms; computes a reciprocal condition number for the average */
+/* of the selected eigenvalues; and computes a reciprocal condition */
+/* number for the right and left deflating subspaces corresponding to */
+/* the selected eigenvalues. */
+
+/* When SDRGSX is called with NSIZE > 0, five (5) types of built-in */
+/* matrix pairs are used to test the routine SGGESX. */
+
+/* When SDRGSX is called with NSIZE = 0, it reads in test matrix data */
+/* to test SGGESX. */
+
+/* For each matrix pair, the following tests will be performed and */
+/* compared with the threshhold THRESH except for the tests (7) and (9): */
+
+/* (1) | A - Q S Z' | / ( |A| n ulp ) */
+
+/* (2) | B - Q T Z' | / ( |B| n ulp ) */
+
+/* (3) | I - QQ' | / ( n ulp ) */
+
+/* (4) | I - ZZ' | / ( n ulp ) */
+
+/* (5) if A is in Schur form (i.e. quasi-triangular form) */
+
+/* (6) maximum over j of D(j) where: */
+
+/* if alpha(j) is real: */
+/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
+/* D(j) = ------------------------ + ----------------------- */
+/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
+
+/* if alpha(j) is complex: */
+/* | det( s S - w T ) | */
+/* D(j) = --------------------------------------------------- */
+/* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T ) */
+
+/* and S and T are here the 2 x 2 diagonal blocks of S and T */
+/* corresponding to the j-th and j+1-th eigenvalues. */
+
+/* (7) if sorting worked and SDIM is the number of eigenvalues */
+/* which were selected. */
+
+/* (8) the estimated value DIF does not differ from the true values of */
+/* Difu and Difl more than a factor 10*THRESH. If the estimate DIF */
+/* equals zero the corresponding true values of Difu and Difl */
+/* should be less than EPS*norm(A, B). If the true value of Difu */
+/* and Difl equal zero, the estimate DIF should be less than */
+/* EPS*norm(A, B). */
+
+/* (9) If INFO = N+3 is returned by SGGESX, the reordering "failed" */
+/* and we check that DIF = PL = PR = 0 and that the true value of */
+/* Difu and Difl is < EPS*norm(A, B). We count the events when */
+/* INFO=N+3. */
+
+/* For read-in test matrices, the above tests are run except that the */
+/* exact value for DIF (and PL) is input data. Additionally, there is */
+/* one more test run for read-in test matrices: */
+
+/* (10) the estimated value PL does not differ from the true value of */
+/* PLTRU more than a factor THRESH. If the estimate PL equals */
+/* zero the corresponding true value of PLTRU should be less than */
+/* EPS*norm(A, B). If the true value of PLTRU equal zero, the */
+/* estimate PL should be less than EPS*norm(A, B). */
+
+/* Note that for the built-in tests, a total of 10*NSIZE*(NSIZE-1) */
+/* matrix pairs are generated and tested. NSIZE should be kept small. */
+
+/* SVD (routine SGESVD) is used for computing the true value of DIF_u */
+/* and DIF_l when testing the built-in test problems. */
+
+/* Built-in Test Matrices */
+/* ====================== */
+
+/* All built-in test matrices are the 2 by 2 block of triangular */
+/* matrices */
+
+/* A = [ A11 A12 ] and B = [ B11 B12 ] */
+/* [ A22 ] [ B22 ] */
+
+/* where for different type of A11 and A22 are given as the following. */
+/* A12 and B12 are chosen so that the generalized Sylvester equation */
+
+/* A11*R - L*A22 = -A12 */
+/* B11*R - L*B22 = -B12 */
+
+/* have prescribed solution R and L. */
+
+/* Type 1: A11 = J_m(1,-1) and A_22 = J_k(1-a,1). */
+/* B11 = I_m, B22 = I_k */
+/* where J_k(a,b) is the k-by-k Jordan block with ``a'' on */
+/* diagonal and ``b'' on superdiagonal. */
+
+/* Type 2: A11 = (a_ij) = ( 2(.5-sin(i)) ) and */
+/* B11 = (b_ij) = ( 2(.5-sin(ij)) ) for i=1,...,m, j=i,...,m */
+/* A22 = (a_ij) = ( 2(.5-sin(i+j)) ) and */
+/* B22 = (b_ij) = ( 2(.5-sin(ij)) ) for i=m+1,...,k, j=i,...,k */
+
+/* Type 3: A11, A22 and B11, B22 are chosen as for Type 2, but each */
+/* second diagonal block in A_11 and each third diagonal block */
+/* in A_22 are made as 2 by 2 blocks. */
+
+/* Type 4: A11 = ( 20(.5 - sin(ij)) ) and B22 = ( 2(.5 - sin(i+j)) ) */
+/* for i=1,...,m, j=1,...,m and */
+/* A22 = ( 20(.5 - sin(i+j)) ) and B22 = ( 2(.5 - sin(ij)) ) */
+/* for i=m+1,...,k, j=m+1,...,k */
+
+/* Type 5: (A,B) and have potentially close or common eigenvalues and */
+/* very large departure from block diagonality A_11 is chosen */
+/* as the m x m leading submatrix of A_1: */
+/* | 1 b | */
+/* | -b 1 | */
+/* | 1+d b | */
+/* | -b 1+d | */
+/* A_1 = | d 1 | */
+/* | -1 d | */
+/* | -d 1 | */
+/* | -1 -d | */
+/* | 1 | */
+/* and A_22 is chosen as the k x k leading submatrix of A_2: */
+/* | -1 b | */
+/* | -b -1 | */
+/* | 1-d b | */
+/* | -b 1-d | */
+/* A_2 = | d 1+b | */
+/* | -1-b d | */
+/* | -d 1+b | */
+/* | -1+b -d | */
+/* | 1-d | */
+/* and matrix B are chosen as identity matrices (see SLATM5). */
+
+
+/* Arguments */
+/* ========= */
+
+/* NSIZE (input) INTEGER */
+/* The maximum size of the matrices to use. NSIZE >= 0. */
+/* If NSIZE = 0, no built-in tests matrices are used, but */
+/* read-in test matrices are used to test SGGESX. */
+
+/* NCMAX (input) INTEGER */
+/* Maximum allowable NMAX for generating Kroneker matrix */
+/* in call to SLAKF2 */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. THRESH >= 0. */
+
+/* NIN (input) INTEGER */
+/* The FORTRAN unit number for reading in the data file of */
+/* problems to solve. */
+
+/* NOUT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (workspace) REAL array, dimension (LDA, NSIZE) */
+/* Used to store the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, AI, BI, Z and Q, */
+/* LDA >= max( 1, NSIZE ). For the read-in test, */
+/* LDA >= max( 1, N ), N is the size of the test matrices. */
+
+/* B (workspace) REAL array, dimension (LDA, NSIZE) */
+/* Used to store the matrix whose eigenvalues are to be */
+/* computed. On exit, B contains the last matrix actually used. */
+
+/* AI (workspace) REAL array, dimension (LDA, NSIZE) */
+/* Copy of A, modified by SGGESX. */
+
+/* BI (workspace) REAL array, dimension (LDA, NSIZE) */
+/* Copy of B, modified by SGGESX. */
+
+/* Z (workspace) REAL array, dimension (LDA, NSIZE) */
+/* Z holds the left Schur vectors computed by SGGESX. */
+
+/* Q (workspace) REAL array, dimension (LDA, NSIZE) */
+/* Q holds the right Schur vectors computed by SGGESX. */
+
+/* ALPHAR (workspace) REAL array, dimension (NSIZE) */
+/* ALPHAI (workspace) REAL array, dimension (NSIZE) */
+/* BETA (workspace) REAL array, dimension (NSIZE) */
+/* On exit, (ALPHAR + ALPHAI*i)/BETA are the eigenvalues. */
+
+/* C (workspace) REAL array, dimension (LDC, LDC) */
+/* Store the matrix generated by subroutine SLAKF2, this is the */
+/* matrix formed by Kronecker products used for estimating */
+/* DIF. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of C. LDC >= max(1, LDA*LDA/2 ). */
+
+/* S (workspace) REAL array, dimension (LDC) */
+/* Singular values of C */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+/* LWORK >= MAX( 5*NSIZE*NSIZE/2 - 2, 10*(NSIZE+1) ) */
+
+/* IWORK (workspace) INTEGER array, dimension (LIWORK) */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. LIWORK >= NSIZE + 6. */
+
+/* BWORK (workspace) LOGICAL array, dimension (LDA) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: A routine returned an error code. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ /* Parameter adjustments */
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *lda;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ bi_dim1 = *lda;
+ bi_offset = 1 + bi_dim1;
+ bi -= bi_offset;
+ ai_dim1 = *lda;
+ ai_offset = 1 + ai_dim1;
+ ai -= ai_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --s;
+ --work;
+ --iwork;
+ --bwork;
+
+ /* Function Body */
+ if (*nsize < 0) {
+ *info = -1;
+ } else if (*thresh < 0.f) {
+ *info = -2;
+ } else if (*nin <= 0) {
+ *info = -3;
+ } else if (*nout <= 0) {
+ *info = -4;
+ } else if (*lda < 1 || *lda < *nsize) {
+ *info = -6;
+ } else if (*ldc < 1 || *ldc < *nsize * *nsize / 2) {
+ *info = -17;
+ } else if (*liwork < *nsize + 6) {
+ *info = -21;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ minwrk = 1;
+ if (*info == 0 && *lwork >= 1) {
+/* MINWRK = MAX( 10*( NSIZE+1 ), 5*NSIZE*NSIZE / 2-2 ) */
+/* Computing MAX */
+ i__1 = (*nsize + 1) * 10, i__2 = *nsize * 5 * *nsize / 2;
+ minwrk = max(i__1,i__2);
+
+/* workspace for sggesx */
+
+ maxwrk = (*nsize + 1) * 9 + *nsize * ilaenv_(&c__1, "SGEQRF", " ",
+ nsize, &c__1, nsize, &c__0);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (*nsize + 1) * 9 + *nsize * ilaenv_(&c__1,
+ "SORGQR", " ", nsize, &c__1, nsize, &c_n1);
+ maxwrk = max(i__1,i__2);
+
+/* workspace for sgesvd */
+
+ bdspac = *nsize * 5 * *nsize / 2;
+/* Computing MAX */
+ i__3 = *nsize * *nsize / 2;
+ i__4 = *nsize * *nsize / 2;
+ i__1 = maxwrk, i__2 = *nsize * 3 * *nsize / 2 + *nsize * *nsize *
+ ilaenv_(&c__1, "SGEBRD", " ", &i__3, &i__4, &c_n1, &c_n1);
+ maxwrk = max(i__1,i__2);
+ maxwrk = max(maxwrk,bdspac);
+
+ maxwrk = max(maxwrk,minwrk);
+
+ work[1] = (real) maxwrk;
+ }
+
+ if (*lwork < minwrk) {
+ *info = -19;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SDRGSX", &i__1);
+ return 0;
+ }
+
+/* Important constants */
+
+ ulp = slamch_("P");
+ ulpinv = 1.f / ulp;
+ smlnum = slamch_("S") / ulp;
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ thrsh2 = *thresh * 10.f;
+ ntestt = 0;
+ nerrs = 0;
+
+/* Go to the tests for read-in matrix pairs */
+
+ ifunc = 0;
+ if (*nsize == 0) {
+ goto L70;
+ }
+
+/* Test the built-in matrix pairs. */
+/* Loop over different functions (IFUNC) of SGGESX, types (PRTYPE) */
+/* of test matrices, different size (M+N) */
+
+ prtype = 0;
+ qba = 3;
+ qbb = 4;
+ weight = sqrt(ulp);
+
+ for (ifunc = 0; ifunc <= 3; ++ifunc) {
+ for (prtype = 1; prtype <= 5; ++prtype) {
+ i__1 = *nsize - 1;
+ for (mn_1.m = 1; mn_1.m <= i__1; ++mn_1.m) {
+ i__2 = *nsize - mn_1.m;
+ for (mn_1.n = 1; mn_1.n <= i__2; ++mn_1.n) {
+
+ weight = 1.f / weight;
+ mn_1.mplusn = mn_1.m + mn_1.n;
+
+/* Generate test matrices */
+
+ mn_1.fs = TRUE_;
+ mn_1.k = 0;
+
+ slaset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b26, &
+ c_b26, &ai[ai_offset], lda);
+ slaset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b26, &
+ c_b26, &bi[bi_offset], lda);
+
+ slatm5_(&prtype, &mn_1.m, &mn_1.n, &ai[ai_offset], lda, &
+ ai[mn_1.m + 1 + (mn_1.m + 1) * ai_dim1], lda, &ai[
+ (mn_1.m + 1) * ai_dim1 + 1], lda, &bi[bi_offset],
+ lda, &bi[mn_1.m + 1 + (mn_1.m + 1) * bi_dim1],
+ lda, &bi[(mn_1.m + 1) * bi_dim1 + 1], lda, &q[
+ q_offset], lda, &z__[z_offset], lda, &weight, &
+ qba, &qbb);
+
+/* Compute the Schur factorization and swapping the */
+/* m-by-m (1,1)-blocks with n-by-n (2,2)-blocks. */
+/* Swapping is accomplished via the function SLCTSX */
+/* which is supplied below. */
+
+ if (ifunc == 0) {
+ *(unsigned char *)sense = 'N';
+ } else if (ifunc == 1) {
+ *(unsigned char *)sense = 'E';
+ } else if (ifunc == 2) {
+ *(unsigned char *)sense = 'V';
+ } else if (ifunc == 3) {
+ *(unsigned char *)sense = 'B';
+ }
+
+ slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
+, lda, &a[a_offset], lda);
+ slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
+, lda, &b[b_offset], lda);
+
+ sggesx_("V", "V", "S", (L_fp)slctsx_, sense, &mn_1.mplusn,
+ &ai[ai_offset], lda, &bi[bi_offset], lda, &mm, &
+ alphar[1], &alphai[1], &beta[1], &q[q_offset],
+ lda, &z__[z_offset], lda, pl, difest, &work[1],
+ lwork, &iwork[1], liwork, &bwork[1], &linfo);
+
+ if (linfo != 0 && linfo != mn_1.mplusn + 2) {
+ result[0] = ulpinv;
+ io___22.ciunit = *nout;
+ s_wsfe(&io___22);
+ do_fio(&c__1, "SGGESX", (ftnlen)6);
+ do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(integer)
+ );
+ e_wsfe();
+ *info = linfo;
+ goto L30;
+ }
+
+/* Compute the norm(A, B) */
+
+ slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
+, lda, &work[1], &mn_1.mplusn);
+ slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
+, lda, &work[mn_1.mplusn * mn_1.mplusn + 1], &
+ mn_1.mplusn);
+ i__3 = mn_1.mplusn << 1;
+ abnrm = slange_("Fro", &mn_1.mplusn, &i__3, &work[1], &
+ mn_1.mplusn, &work[1]);
+
+/* Do tests (1) to (4) */
+
+ sget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[
+ ai_offset], lda, &q[q_offset], lda, &z__[z_offset]
+, lda, &work[1], result);
+ sget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[
+ bi_offset], lda, &q[q_offset], lda, &z__[z_offset]
+, lda, &work[1], &result[1]);
+ sget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
+ bi_offset], lda, &q[q_offset], lda, &q[q_offset],
+ lda, &work[1], &result[2]);
+ sget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
+ bi_offset], lda, &z__[z_offset], lda, &z__[
+ z_offset], lda, &work[1], &result[3]);
+ ntest = 4;
+
+/* Do tests (5) and (6): check Schur form of A and */
+/* compare eigenvalues with diagonals. */
+
+ temp1 = 0.f;
+ result[4] = 0.f;
+ result[5] = 0.f;
+
+ i__3 = mn_1.mplusn;
+ for (j = 1; j <= i__3; ++j) {
+ ilabad = FALSE_;
+ if (alphai[j] == 0.f) {
+/* Computing MAX */
+ r__7 = smlnum, r__8 = (r__2 = alphar[j], dabs(
+ r__2)), r__7 = max(r__7,r__8), r__8 = (
+ r__3 = ai[j + j * ai_dim1], dabs(r__3));
+/* Computing MAX */
+ r__9 = smlnum, r__10 = (r__5 = beta[j], dabs(r__5)
+ ), r__9 = max(r__9,r__10), r__10 = (r__6 =
+ bi[j + j * bi_dim1], dabs(r__6));
+ temp2 = ((r__1 = alphar[j] - ai[j + j * ai_dim1],
+ dabs(r__1)) / dmax(r__7,r__8) + (r__4 =
+ beta[j] - bi[j + j * bi_dim1], dabs(r__4))
+ / dmax(r__9,r__10)) / ulp;
+ if (j < mn_1.mplusn) {
+ if (ai[j + 1 + j * ai_dim1] != 0.f) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ }
+ if (j > 1) {
+ if (ai[j + (j - 1) * ai_dim1] != 0.f) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ }
+ } else {
+ if (alphai[j] > 0.f) {
+ i1 = j;
+ } else {
+ i1 = j - 1;
+ }
+ if (i1 <= 0 || i1 >= mn_1.mplusn) {
+ ilabad = TRUE_;
+ } else if (i1 < mn_1.mplusn - 1) {
+ if (ai[i1 + 2 + (i1 + 1) * ai_dim1] != 0.f) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ } else if (i1 > 1) {
+ if (ai[i1 + (i1 - 1) * ai_dim1] != 0.f) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ }
+ if (! ilabad) {
+ sget53_(&ai[i1 + i1 * ai_dim1], lda, &bi[i1 +
+ i1 * bi_dim1], lda, &beta[j], &alphar[
+ j], &alphai[j], &temp2, &iinfo);
+ if (iinfo >= 3) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&mn_1.mplusn, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&prtype, (ftnlen)
+ sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ }
+ } else {
+ temp2 = ulpinv;
+ }
+ }
+ temp1 = dmax(temp1,temp2);
+ if (ilabad) {
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+/* L10: */
+ }
+ result[5] = temp1;
+ ntest += 2;
+
+/* Test (7) (if sorting worked) */
+
+ result[6] = 0.f;
+ if (linfo == mn_1.mplusn + 3) {
+ result[6] = ulpinv;
+ } else if (mm != mn_1.n) {
+ result[6] = ulpinv;
+ }
+ ++ntest;
+
+/* Test (8): compare the estimated value DIF and its */
+/* value. first, compute the exact DIF. */
+
+ result[7] = 0.f;
+ mn2 = mm * (mn_1.mplusn - mm) << 1;
+ if (ifunc >= 2 && mn2 <= *ncmax * *ncmax) {
+
+/* Note: for either following two causes, there are */
+/* almost same number of test cases fail the test. */
+
+ i__3 = mn_1.mplusn - mm;
+ slakf2_(&mm, &i__3, &ai[ai_offset], lda, &ai[mm + 1 +
+ (mm + 1) * ai_dim1], &bi[bi_offset], &bi[mm +
+ 1 + (mm + 1) * bi_dim1], &c__[c_offset], ldc);
+
+ i__3 = *lwork - 2;
+ sgesvd_("N", "N", &mn2, &mn2, &c__[c_offset], ldc, &s[
+ 1], &work[1], &c__1, &work[2], &c__1, &work[3]
+, &i__3, info);
+ diftru = s[mn2];
+
+ if (difest[1] == 0.f) {
+ if (diftru > abnrm * ulp) {
+ result[7] = ulpinv;
+ }
+ } else if (diftru == 0.f) {
+ if (difest[1] > abnrm * ulp) {
+ result[7] = ulpinv;
+ }
+ } else if (diftru > thrsh2 * difest[1] || diftru *
+ thrsh2 < difest[1]) {
+/* Computing MAX */
+ r__1 = diftru / difest[1], r__2 = difest[1] /
+ diftru;
+ result[7] = dmax(r__1,r__2);
+ }
+ ++ntest;
+ }
+
+/* Test (9) */
+
+ result[8] = 0.f;
+ if (linfo == mn_1.mplusn + 2) {
+ if (diftru > abnrm * ulp) {
+ result[8] = ulpinv;
+ }
+ if (ifunc > 1 && difest[1] != 0.f) {
+ result[8] = ulpinv;
+ }
+ if (ifunc == 1 && pl[0] != 0.f) {
+ result[8] = ulpinv;
+ }
+ ++ntest;
+ }
+
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ for (j = 1; j <= 9; ++j) {
+ if (result[j - 1] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, "SGX", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, "orthogonal", (ftnlen)10);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ for (i__ = 1; i__ <= 4; ++i__) {
+ do_fio(&c__1, "'", (ftnlen)1);
+ }
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[j - 1] < 1e4f) {
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
+ real));
+ do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
+ real));
+ do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ }
+/* L20: */
+ }
+
+L30:
+ ;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+
+ goto L150;
+
+L70:
+
+/* Read in data from file to check accuracy of condition estimation */
+/* Read input data until N=0 */
+
+ nptknt = 0;
+
+L80:
+ io___42.ciunit = *nin;
+ i__1 = s_rsle(&io___42);
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer))
+ ;
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = e_rsle();
+ if (i__1 != 0) {
+ goto L140;
+ }
+ if (mn_1.mplusn == 0) {
+ goto L140;
+ }
+ io___43.ciunit = *nin;
+ i__1 = s_rsle(&io___43);
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.n, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = e_rsle();
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = mn_1.mplusn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___44.ciunit = *nin;
+ s_rsle(&io___44);
+ i__2 = mn_1.mplusn;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__4, &c__1, (char *)&ai[i__ + j * ai_dim1], (ftnlen)
+ sizeof(real));
+ }
+ e_rsle();
+/* L90: */
+ }
+ i__1 = mn_1.mplusn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___45.ciunit = *nin;
+ s_rsle(&io___45);
+ i__2 = mn_1.mplusn;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__4, &c__1, (char *)&bi[i__ + j * bi_dim1], (ftnlen)
+ sizeof(real));
+ }
+ e_rsle();
+/* L100: */
+ }
+ io___46.ciunit = *nin;
+ s_rsle(&io___46);
+ do_lio(&c__4, &c__1, (char *)&pltru, (ftnlen)sizeof(real));
+ do_lio(&c__4, &c__1, (char *)&diftru, (ftnlen)sizeof(real));
+ e_rsle();
+
+ ++nptknt;
+ mn_1.fs = TRUE_;
+ mn_1.k = 0;
+ mn_1.m = mn_1.mplusn - mn_1.n;
+
+ slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &a[
+ a_offset], lda);
+ slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &b[
+ b_offset], lda);
+
+/* Compute the Schur factorization while swaping the */
+/* m-by-m (1,1)-blocks with n-by-n (2,2)-blocks. */
+
+ sggesx_("V", "V", "S", (L_fp)slctsx_, "B", &mn_1.mplusn, &ai[ai_offset],
+ lda, &bi[bi_offset], lda, &mm, &alphar[1], &alphai[1], &beta[1], &
+ q[q_offset], lda, &z__[z_offset], lda, pl, difest, &work[1],
+ lwork, &iwork[1], liwork, &bwork[1], &linfo);
+
+ if (linfo != 0 && linfo != mn_1.mplusn + 2) {
+ result[0] = ulpinv;
+ io___48.ciunit = *nout;
+ s_wsfe(&io___48);
+ do_fio(&c__1, "SGGESX", (ftnlen)6);
+ do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L130;
+ }
+
+/* Compute the norm(A, B) */
+/* (should this be norm of (A,B) or (AI,BI)?) */
+
+ slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &work[1],
+ &mn_1.mplusn);
+ slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &work[
+ mn_1.mplusn * mn_1.mplusn + 1], &mn_1.mplusn);
+ i__1 = mn_1.mplusn << 1;
+ abnrm = slange_("Fro", &mn_1.mplusn, &i__1, &work[1], &mn_1.mplusn, &work[
+ 1]);
+
+/* Do tests (1) to (4) */
+
+ sget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[ai_offset], lda, &q[
+ q_offset], lda, &z__[z_offset], lda, &work[1], result);
+ sget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
+ q_offset], lda, &z__[z_offset], lda, &work[1], &result[1]);
+ sget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
+ q_offset], lda, &q[q_offset], lda, &work[1], &result[2]);
+ sget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &z__[
+ z_offset], lda, &z__[z_offset], lda, &work[1], &result[3]);
+
+/* Do tests (5) and (6): check Schur form of A and compare */
+/* eigenvalues with diagonals. */
+
+ ntest = 6;
+ temp1 = 0.f;
+ result[4] = 0.f;
+ result[5] = 0.f;
+
+ i__1 = mn_1.mplusn;
+ for (j = 1; j <= i__1; ++j) {
+ ilabad = FALSE_;
+ if (alphai[j] == 0.f) {
+/* Computing MAX */
+ r__7 = smlnum, r__8 = (r__2 = alphar[j], dabs(r__2)), r__7 = max(
+ r__7,r__8), r__8 = (r__3 = ai[j + j * ai_dim1], dabs(r__3)
+ );
+/* Computing MAX */
+ r__9 = smlnum, r__10 = (r__5 = beta[j], dabs(r__5)), r__9 = max(
+ r__9,r__10), r__10 = (r__6 = bi[j + j * bi_dim1], dabs(
+ r__6));
+ temp2 = ((r__1 = alphar[j] - ai[j + j * ai_dim1], dabs(r__1)) /
+ dmax(r__7,r__8) + (r__4 = beta[j] - bi[j + j * bi_dim1],
+ dabs(r__4)) / dmax(r__9,r__10)) / ulp;
+ if (j < mn_1.mplusn) {
+ if (ai[j + 1 + j * ai_dim1] != 0.f) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ }
+ if (j > 1) {
+ if (ai[j + (j - 1) * ai_dim1] != 0.f) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ }
+ } else {
+ if (alphai[j] > 0.f) {
+ i1 = j;
+ } else {
+ i1 = j - 1;
+ }
+ if (i1 <= 0 || i1 >= mn_1.mplusn) {
+ ilabad = TRUE_;
+ } else if (i1 < mn_1.mplusn - 1) {
+ if (ai[i1 + 2 + (i1 + 1) * ai_dim1] != 0.f) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ } else if (i1 > 1) {
+ if (ai[i1 + (i1 - 1) * ai_dim1] != 0.f) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ }
+ if (! ilabad) {
+ sget53_(&ai[i1 + i1 * ai_dim1], lda, &bi[i1 + i1 * bi_dim1],
+ lda, &beta[j], &alphar[j], &alphai[j], &temp2, &iinfo)
+ ;
+ if (iinfo >= 3) {
+ io___49.ciunit = *nout;
+ s_wsfe(&io___49);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ }
+ } else {
+ temp2 = ulpinv;
+ }
+ }
+ temp1 = dmax(temp1,temp2);
+ if (ilabad) {
+ io___50.ciunit = *nout;
+ s_wsfe(&io___50);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L110: */
+ }
+ result[5] = temp1;
+
+/* Test (7) (if sorting worked) <--------- need to be checked. */
+
+ ntest = 7;
+ result[6] = 0.f;
+ if (linfo == mn_1.mplusn + 3) {
+ result[6] = ulpinv;
+ }
+
+/* Test (8): compare the estimated value of DIF and its true value. */
+
+ ntest = 8;
+ result[7] = 0.f;
+ if (difest[1] == 0.f) {
+ if (diftru > abnrm * ulp) {
+ result[7] = ulpinv;
+ }
+ } else if (diftru == 0.f) {
+ if (difest[1] > abnrm * ulp) {
+ result[7] = ulpinv;
+ }
+ } else if (diftru > thrsh2 * difest[1] || diftru * thrsh2 < difest[1]) {
+/* Computing MAX */
+ r__1 = diftru / difest[1], r__2 = difest[1] / diftru;
+ result[7] = dmax(r__1,r__2);
+ }
+
+/* Test (9) */
+
+ ntest = 9;
+ result[8] = 0.f;
+ if (linfo == mn_1.mplusn + 2) {
+ if (diftru > abnrm * ulp) {
+ result[8] = ulpinv;
+ }
+ if (ifunc > 1 && difest[1] != 0.f) {
+ result[8] = ulpinv;
+ }
+ if (ifunc == 1 && pl[0] != 0.f) {
+ result[8] = ulpinv;
+ }
+ }
+
+/* Test (10): compare the estimated value of PL and it true value. */
+
+ ntest = 10;
+ result[9] = 0.f;
+ if (pl[0] == 0.f) {
+ if (pltru > abnrm * ulp) {
+ result[9] = ulpinv;
+ }
+ } else if (pltru == 0.f) {
+ if (pl[0] > abnrm * ulp) {
+ result[9] = ulpinv;
+ }
+ } else if (pltru > *thresh * pl[0] || pltru * *thresh < pl[0]) {
+ result[9] = ulpinv;
+ }
+
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__1 = ntest;
+ for (j = 1; j <= i__1; ++j) {
+ if (result[j - 1] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___51.ciunit = *nout;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "SGX", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___52.ciunit = *nout;
+ s_wsfe(&io___52);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___53.ciunit = *nout;
+ s_wsfe(&io___53);
+ do_fio(&c__1, "orthogonal", (ftnlen)10);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ for (i__ = 1; i__ <= 4; ++i__) {
+ do_fio(&c__1, "'", (ftnlen)1);
+ }
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[j - 1] < 1e4f) {
+ io___54.ciunit = *nout;
+ s_wsfe(&io___54);
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___55.ciunit = *nout;
+ s_wsfe(&io___55);
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ }
+
+/* L120: */
+ }
+
+L130:
+ goto L80;
+L140:
+
+L150:
+
+/* Summary */
+
+ alasvm_("SGX", nout, &nerrs, &ntestt, &c__0);
+
+ work[1] = (real) maxwrk;
+
+ return 0;
+
+
+
+
+
+
+
+
+
+/* End of SDRGSX */
+
+} /* sdrgsx_ */
diff --git a/TESTING/EIG/sdrgvx.c b/TESTING/EIG/sdrgvx.c
new file mode 100644
index 0000000..7042aab
--- /dev/null
+++ b/TESTING/EIG/sdrgvx.c
@@ -0,0 +1,963 @@
+/* sdrgvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c__5 = 5;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+static integer c__3 = 3;
+static integer c__4 = 4;
+
+/* Subroutine */ int sdrgvx_(integer *nsize, real *thresh, integer *nin,
+ integer *nout, real *a, integer *lda, real *b, real *ai, real *bi,
+ real *alphar, real *alphai, real *beta, real *vl, real *vr, integer *
+ ilo, integer *ihi, real *lscale, real *rscale, real *s, real *stru,
+ real *dif, real *diftru, real *work, integer *lwork, integer *iwork,
+ integer *liwork, real *result, logical *bwork, integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 SDRGVX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002)\002)";
+ static char fmt_9998[] = "(\002 SDRGVX: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
+ "i6,\002, IWA=\002,i5,\002, IWB=\002,i5,\002, IWX=\002,i5,\002, I"
+ "WY=\002,i5)";
+ static char fmt_9997[] = "(/1x,a3,\002 -- Real Expert Eigenvalue/vecto"
+ "r\002,\002 problem driver\002)";
+ static char fmt_9995[] = "(\002 Matrix types: \002,/)";
+ static char fmt_9994[] = "(\002 TYPE 1: Da is diagonal, Db is identity,"
+ " \002,/\002 A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1) \002,/"
+ "\002 YH and X are left and right eigenvectors. \002,/)";
+ static char fmt_9993[] = "(\002 TYPE 2: Da is quasi-diagonal, Db is iden"
+ "tity, \002,/\002 A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1)"
+ " \002,/\002 YH and X are left and right eigenvectors. \002,/)"
+ ;
+ static char fmt_9992[] = "(/\002 Tests performed: \002,/4x,\002 a is al"
+ "pha, b is beta, l is a left eigenvector, \002,/4x,\002 r is a ri"
+ "ght eigenvector and \002,a,\002 means \002,a,\002.\002,/\002 1 ="
+ " max | ( b A - a B )\002,a,\002 l | / const.\002,/\002 2 = max |"
+ " ( b A - a B ) r | / const.\002,/\002 3 = max ( Sest/Stru, Stru/"
+ "Sest ) \002,\002 over all eigenvalues\002,/\002 4 = max( DIFest/"
+ "DIFtru, DIFtru/DIFest ) \002,\002 over the 1st and 5th eigenvect"
+ "ors\002,/)";
+ static char fmt_9991[] = "(\002 Type=\002,i2,\002,\002,\002 IWA=\002,i2"
+ ",\002, IWB=\002,i2,\002, IWX=\002,i2,\002, IWY=\002,i2,\002, res"
+ "ult \002,i2,\002 is\002,0p,f8.2)";
+ static char fmt_9990[] = "(\002 Type=\002,i2,\002,\002,\002 IWA=\002,i2"
+ ",\002, IWB=\002,i2,\002, IWX=\002,i2,\002, IWY=\002,i2,\002, res"
+ "ult \002,i2,\002 is\002,1p,e10.3)";
+ static char fmt_9987[] = "(\002 SDRGVX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, Input example #\002,i2,\002"
+ ")\002)";
+ static char fmt_9986[] = "(\002 SDRGVX: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, Input Examp"
+ "le #\002,i2,\002)\002)";
+ static char fmt_9996[] = "(\002 Input Example\002)";
+ static char fmt_9989[] = "(\002 Input example #\002,i2,\002, matrix orde"
+ "r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,0p,f8.2)";
+ static char fmt_9988[] = "(\002 Input example #\002,i2,\002, matrix orde"
+ "r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,1p,e10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, ai_dim1, ai_offset, b_dim1, b_offset, bi_dim1,
+ bi_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2;
+ real r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+
+ /* Local variables */
+ integer i__, j, n, iwa, iwb;
+ real ulp;
+ integer iwx, iwy, nmax, linfo;
+ extern /* Subroutine */ int sget52_(logical *, integer *, real *, integer
+ *, real *, integer *, real *, integer *, real *, real *, real *,
+ real *, real *);
+ real anorm, bnorm;
+ integer nerrs;
+ real ratio1, ratio2;
+ extern /* Subroutine */ int slatm6_(integer *, integer *, real *, integer
+ *, real *, real *, integer *, real *, integer *, real *, real *,
+ real *, real *, real *, real *);
+ real thrsh2;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real abnorm;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ real weight[5];
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), sggevx_(char *, char *,
+ char *, char *, integer *, real *, integer *, real *, integer *,
+ real *, real *, real *, real *, integer *, real *, integer *,
+ integer *, integer *, real *, real *, real *, real *, real *,
+ real *, real *, integer *, integer *, logical *, integer *);
+ integer minwrk, maxwrk, iptype, nptknt;
+ real ulpinv;
+ integer ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___20 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___35 = { 0, 0, 1, 0, 0 };
+ static cilist io___36 = { 0, 0, 0, 0, 0 };
+ static cilist io___37 = { 0, 0, 0, 0, 0 };
+ static cilist io___38 = { 0, 0, 0, 0, 0 };
+ static cilist io___39 = { 0, 0, 0, 0, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9987, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9986, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9986, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9988, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRGVX checks the nonsymmetric generalized eigenvalue problem */
+/* expert driver SGGEVX. */
+
+/* SGGEVX computes the generalized eigenvalues, (optionally) the left */
+/* and/or right eigenvectors, (optionally) computes a balancing */
+/* transformation to improve the conditioning, and (optionally) */
+/* reciprocal condition numbers for the eigenvalues and eigenvectors. */
+
+/* When SDRGVX is called with NSIZE > 0, two types of test matrix pairs */
+/* are generated by the subroutine SLATM6 and test the driver SGGEVX. */
+/* The test matrices have the known exact condition numbers for */
+/* eigenvalues. For the condition numbers of the eigenvectors */
+/* corresponding the first and last eigenvalues are also know */
+/* ``exactly'' (see SLATM6). */
+
+/* For each matrix pair, the following tests will be performed and */
+/* compared with the threshhold THRESH. */
+
+/* (1) max over all left eigenvalue/-vector pairs (beta/alpha,l) of */
+
+/* | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) ) */
+
+/* where l**H is the conjugate tranpose of l. */
+
+/* (2) max over all right eigenvalue/-vector pairs (beta/alpha,r) of */
+
+/* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) ) */
+
+/* (3) The condition number S(i) of eigenvalues computed by SGGEVX */
+/* differs less than a factor THRESH from the exact S(i) (see */
+/* SLATM6). */
+
+/* (4) DIF(i) computed by STGSNA differs less than a factor 10*THRESH */
+/* from the exact value (for the 1st and 5th vectors only). */
+
+/* Test Matrices */
+/* ============= */
+
+/* Two kinds of test matrix pairs */
+
+/* (A, B) = inverse(YH) * (Da, Db) * inverse(X) */
+
+/* are used in the tests: */
+
+/* 1: Da = 1+a 0 0 0 0 Db = 1 0 0 0 0 */
+/* 0 2+a 0 0 0 0 1 0 0 0 */
+/* 0 0 3+a 0 0 0 0 1 0 0 */
+/* 0 0 0 4+a 0 0 0 0 1 0 */
+/* 0 0 0 0 5+a , 0 0 0 0 1 , and */
+
+/* 2: Da = 1 -1 0 0 0 Db = 1 0 0 0 0 */
+/* 1 1 0 0 0 0 1 0 0 0 */
+/* 0 0 1 0 0 0 0 1 0 0 */
+/* 0 0 0 1+a 1+b 0 0 0 1 0 */
+/* 0 0 0 -1-b 1+a , 0 0 0 0 1 . */
+
+/* In both cases the same inverse(YH) and inverse(X) are used to compute */
+/* (A, B), giving the exact eigenvectors to (A,B) as (YH, X): */
+
+/* YH: = 1 0 -y y -y X = 1 0 -x -x x */
+/* 0 1 -y y -y 0 1 x -x -x */
+/* 0 0 1 0 0 0 0 1 0 0 */
+/* 0 0 0 1 0 0 0 0 1 0 */
+/* 0 0 0 0 1, 0 0 0 0 1 , where */
+
+/* a, b, x and y will have all values independently of each other from */
+/* { sqrt(sqrt(ULP)), 0.1, 1, 10, 1/sqrt(sqrt(ULP)) }. */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZE (input) INTEGER */
+/* The number of sizes of matrices to use. NSIZE must be at */
+/* least zero. If it is zero, no randomly generated matrices */
+/* are tested, but any test matrices read from NIN will be */
+/* tested. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NIN (input) INTEGER */
+/* The FORTRAN unit number for reading in the data file of */
+/* problems to solve. */
+
+/* NOUT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (workspace) REAL array, dimension (LDA, NSIZE) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, AI, BI, Ao, and Bo. */
+/* It must be at least 1 and at least NSIZE. */
+
+/* B (workspace) REAL array, dimension (LDA, NSIZE) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, B contains the last matrix actually used. */
+
+/* AI (workspace) REAL array, dimension (LDA, NSIZE) */
+/* Copy of A, modified by SGGEVX. */
+
+/* BI (workspace) REAL array, dimension (LDA, NSIZE) */
+/* Copy of B, modified by SGGEVX. */
+
+/* ALPHAR (workspace) REAL array, dimension (NSIZE) */
+/* ALPHAI (workspace) REAL array, dimension (NSIZE) */
+/* BETA (workspace) REAL array, dimension (NSIZE) */
+/* On exit, (ALPHAR + ALPHAI*i)/BETA are the eigenvalues. */
+
+/* VL (workspace) REAL array, dimension (LDA, NSIZE) */
+/* VL holds the left eigenvectors computed by SGGEVX. */
+
+/* VR (workspace) REAL array, dimension (LDA, NSIZE) */
+/* VR holds the right eigenvectors computed by SGGEVX. */
+
+/* ILO (output/workspace) INTEGER */
+
+/* IHI (output/workspace) INTEGER */
+
+/* LSCALE (output/workspace) REAL array, dimension (N) */
+
+/* RSCALE (output/workspace) REAL array, dimension (N) */
+
+/* S (output/workspace) REAL array, dimension (N) */
+
+/* STRU (output/workspace) REAL array, dimension (N) */
+
+/* DIF (output/workspace) REAL array, dimension (N) */
+
+/* DIFTRU (output/workspace) REAL array, dimension (N) */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* Leading dimension of WORK. LWORK >= 2*N*N+12*N+16. */
+
+/* IWORK (workspace) INTEGER array, dimension (LIWORK) */
+
+/* LIWORK (input) INTEGER */
+/* Leading dimension of IWORK. Must be at least N+6. */
+
+/* RESULT (output/workspace) REAL array, dimension (4) */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: A routine returned an error code. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ /* Parameter adjustments */
+ vr_dim1 = *lda;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ vl_dim1 = *lda;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ bi_dim1 = *lda;
+ bi_offset = 1 + bi_dim1;
+ bi -= bi_offset;
+ ai_dim1 = *lda;
+ ai_offset = 1 + ai_dim1;
+ ai -= ai_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ --lscale;
+ --rscale;
+ --s;
+ --stru;
+ --dif;
+ --diftru;
+ --work;
+ --iwork;
+ --result;
+ --bwork;
+
+ /* Function Body */
+ *info = 0;
+
+ nmax = 5;
+
+ if (*nsize < 0) {
+ *info = -1;
+ } else if (*thresh < 0.f) {
+ *info = -2;
+ } else if (*nin <= 0) {
+ *info = -3;
+ } else if (*nout <= 0) {
+ *info = -4;
+ } else if (*lda < 1 || *lda < nmax) {
+ *info = -6;
+ } else if (*liwork < nmax + 6) {
+ *info = -26;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ minwrk = 1;
+ if (*info == 0 && *lwork >= 1) {
+ minwrk = (nmax << 1) * nmax + nmax * 12 + 16;
+ maxwrk = nmax * 6 + nmax * ilaenv_(&c__1, "SGEQRF", " ", &nmax, &c__1,
+ &nmax, &c__0);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (nmax << 1) * nmax + nmax * 12 + 16;
+ maxwrk = max(i__1,i__2);
+ work[1] = (real) maxwrk;
+ }
+
+ if (*lwork < minwrk) {
+ *info = -24;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SDRGVX", &i__1);
+ return 0;
+ }
+
+ n = 5;
+ ulp = slamch_("P");
+ ulpinv = 1.f / ulp;
+ thrsh2 = *thresh * 10.f;
+ nerrs = 0;
+ nptknt = 0;
+ ntestt = 0;
+
+ if (*nsize == 0) {
+ goto L90;
+ }
+
+/* Parameters used for generating test matrices. */
+
+ weight[0] = sqrt(sqrt(ulp));
+ weight[1] = .1f;
+ weight[2] = 1.f;
+ weight[3] = 1.f / weight[1];
+ weight[4] = 1.f / weight[0];
+
+ for (iptype = 1; iptype <= 2; ++iptype) {
+ for (iwa = 1; iwa <= 5; ++iwa) {
+ for (iwb = 1; iwb <= 5; ++iwb) {
+ for (iwx = 1; iwx <= 5; ++iwx) {
+ for (iwy = 1; iwy <= 5; ++iwy) {
+
+/* generated a test matrix pair */
+
+ slatm6_(&iptype, &c__5, &a[a_offset], lda, &b[
+ b_offset], &vr[vr_offset], lda, &vl[vl_offset]
+, lda, &weight[iwa - 1], &weight[iwb - 1], &
+ weight[iwx - 1], &weight[iwy - 1], &stru[1], &
+ diftru[1]);
+
+/* Compute eigenvalues/eigenvectors of (A, B). */
+/* Compute eigenvalue/eigenvector condition numbers */
+/* using computed eigenvectors. */
+
+ slacpy_("F", &n, &n, &a[a_offset], lda, &ai[ai_offset]
+, lda);
+ slacpy_("F", &n, &n, &b[b_offset], lda, &bi[bi_offset]
+, lda);
+
+ sggevx_("N", "V", "V", "B", &n, &ai[ai_offset], lda, &
+ bi[bi_offset], lda, &alphar[1], &alphai[1], &
+ beta[1], &vl[vl_offset], lda, &vr[vr_offset],
+ lda, ilo, ihi, &lscale[1], &rscale[1], &anorm,
+ &bnorm, &s[1], &dif[1], &work[1], lwork, &
+ iwork[1], &bwork[1], &linfo);
+ if (linfo != 0) {
+ result[1] = ulpinv;
+ io___20.ciunit = *nout;
+ s_wsfe(&io___20);
+ do_fio(&c__1, "SGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ goto L30;
+ }
+
+/* Compute the norm(A, B) */
+
+ slacpy_("Full", &n, &n, &ai[ai_offset], lda, &work[1],
+ &n);
+ slacpy_("Full", &n, &n, &bi[bi_offset], lda, &work[n *
+ n + 1], &n);
+ i__1 = n << 1;
+ abnorm = slange_("Fro", &n, &i__1, &work[1], &n, &
+ work[1]);
+
+/* Tests (1) and (2) */
+
+ result[1] = 0.f;
+ sget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset],
+ lda, &vl[vl_offset], lda, &alphar[1], &alphai[
+ 1], &beta[1], &work[1], &result[1]);
+ if (result[2] > *thresh) {
+ io___22.ciunit = *nout;
+ s_wsfe(&io___22);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "SGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(
+ real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+
+ result[2] = 0.f;
+ sget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset],
+ lda, &vr[vr_offset], lda, &alphar[1], &
+ alphai[1], &beta[1], &work[1], &result[2]);
+ if (result[3] > *thresh) {
+ io___23.ciunit = *nout;
+ s_wsfe(&io___23);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "SGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[3], (ftnlen)sizeof(
+ real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+
+/* Test (3) */
+
+ result[3] = 0.f;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] == 0.f) {
+ if (stru[i__] > abnorm * ulp) {
+ result[3] = ulpinv;
+ }
+ } else if (stru[i__] == 0.f) {
+ if (s[i__] > abnorm * ulp) {
+ result[3] = ulpinv;
+ }
+ } else {
+/* Computing MAX */
+ r__3 = (r__1 = stru[i__] / s[i__], dabs(r__1))
+ , r__4 = (r__2 = s[i__] / stru[i__],
+ dabs(r__2));
+ work[i__] = dmax(r__3,r__4);
+/* Computing MAX */
+ r__1 = result[3], r__2 = work[i__];
+ result[3] = dmax(r__1,r__2);
+ }
+/* L10: */
+ }
+
+/* Test (4) */
+
+ result[4] = 0.f;
+ if (dif[1] == 0.f) {
+ if (diftru[1] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (diftru[1] == 0.f) {
+ if (dif[1] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (dif[5] == 0.f) {
+ if (diftru[5] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (diftru[5] == 0.f) {
+ if (dif[5] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else {
+/* Computing MAX */
+ r__3 = (r__1 = diftru[1] / dif[1], dabs(r__1)),
+ r__4 = (r__2 = dif[1] / diftru[1], dabs(
+ r__2));
+ ratio1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__3 = (r__1 = diftru[5] / dif[5], dabs(r__1)),
+ r__4 = (r__2 = dif[5] / diftru[5], dabs(
+ r__2));
+ ratio2 = dmax(r__3,r__4);
+ result[4] = dmax(ratio1,ratio2);
+ }
+
+ ntestt += 4;
+
+/* Print out tests which fail. */
+
+ for (j = 1; j <= 4; ++j) {
+ if (result[j] >= thrsh2 && j >= 4 || result[j] >=
+ *thresh && j <= 3) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___28.ciunit = *nout;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "SXV", (ftnlen)3);
+ e_wsfe();
+
+/* Print out messages for built-in examples */
+
+/* Matrix types */
+
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ e_wsfe();
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ e_wsfe();
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ do_fio(&c__1, "'", (ftnlen)1);
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[j] < 1e4f) {
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&iptype, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwa, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwb, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwx, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwy, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, (char *)&iptype, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwa, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwb, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwx, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwy, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ }
+/* L20: */
+ }
+
+L30:
+
+/* L40: */
+ ;
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+
+ goto L150;
+
+L90:
+
+/* Read in data from file to check accuracy of condition estimation */
+/* Read input data until N=0 */
+
+ io___35.ciunit = *nin;
+ i__1 = s_rsle(&io___35);
+ if (i__1 != 0) {
+ goto L150;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L150;
+ }
+ i__1 = e_rsle();
+ if (i__1 != 0) {
+ goto L150;
+ }
+ if (n == 0) {
+ goto L150;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___36.ciunit = *nin;
+ s_rsle(&io___36);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__4, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
+ real));
+ }
+ e_rsle();
+/* L100: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___37.ciunit = *nin;
+ s_rsle(&io___37);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__4, &c__1, (char *)&b[i__ + j * b_dim1], (ftnlen)sizeof(
+ real));
+ }
+ e_rsle();
+/* L110: */
+ }
+ io___38.ciunit = *nin;
+ s_rsle(&io___38);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__4, &c__1, (char *)&stru[i__], (ftnlen)sizeof(real));
+ }
+ e_rsle();
+ io___39.ciunit = *nin;
+ s_rsle(&io___39);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__4, &c__1, (char *)&diftru[i__], (ftnlen)sizeof(real));
+ }
+ e_rsle();
+
+ ++nptknt;
+
+/* Compute eigenvalues/eigenvectors of (A, B). */
+/* Compute eigenvalue/eigenvector condition numbers */
+/* using computed eigenvectors. */
+
+ slacpy_("F", &n, &n, &a[a_offset], lda, &ai[ai_offset], lda);
+ slacpy_("F", &n, &n, &b[b_offset], lda, &bi[bi_offset], lda);
+
+ sggevx_("N", "V", "V", "B", &n, &ai[ai_offset], lda, &bi[bi_offset], lda,
+ &alphar[1], &alphai[1], &beta[1], &vl[vl_offset], lda, &vr[
+ vr_offset], lda, ilo, ihi, &lscale[1], &rscale[1], &anorm, &bnorm,
+ &s[1], &dif[1], &work[1], lwork, &iwork[1], &bwork[1], &linfo);
+
+ if (linfo != 0) {
+ result[1] = ulpinv;
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "SGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L140;
+ }
+
+/* Compute the norm(A, B) */
+
+ slacpy_("Full", &n, &n, &ai[ai_offset], lda, &work[1], &n);
+ slacpy_("Full", &n, &n, &bi[bi_offset], lda, &work[n * n + 1], &n);
+ i__1 = n << 1;
+ abnorm = slange_("Fro", &n, &i__1, &work[1], &n, &work[1]);
+
+/* Tests (1) and (2) */
+
+ result[1] = 0.f;
+ sget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &vl[vl_offset],
+ lda, &alphar[1], &alphai[1], &beta[1], &work[1], &result[1]);
+ if (result[2] > *thresh) {
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "SGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ result[2] = 0.f;
+ sget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &vr[vr_offset]
+, lda, &alphar[1], &alphai[1], &beta[1], &work[1], &result[2]);
+ if (result[3] > *thresh) {
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "SGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[3], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Test (3) */
+
+ result[3] = 0.f;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] == 0.f) {
+ if (stru[i__] > abnorm * ulp) {
+ result[3] = ulpinv;
+ }
+ } else if (stru[i__] == 0.f) {
+ if (s[i__] > abnorm * ulp) {
+ result[3] = ulpinv;
+ }
+ } else {
+/* Computing MAX */
+ r__3 = (r__1 = stru[i__] / s[i__], dabs(r__1)), r__4 = (r__2 = s[
+ i__] / stru[i__], dabs(r__2));
+ work[i__] = dmax(r__3,r__4);
+/* Computing MAX */
+ r__1 = result[3], r__2 = work[i__];
+ result[3] = dmax(r__1,r__2);
+ }
+/* L120: */
+ }
+
+/* Test (4) */
+
+ result[4] = 0.f;
+ if (dif[1] == 0.f) {
+ if (diftru[1] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (diftru[1] == 0.f) {
+ if (dif[1] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (dif[5] == 0.f) {
+ if (diftru[5] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (diftru[5] == 0.f) {
+ if (dif[5] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else {
+/* Computing MAX */
+ r__3 = (r__1 = diftru[1] / dif[1], dabs(r__1)), r__4 = (r__2 = dif[1]
+ / diftru[1], dabs(r__2));
+ ratio1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__3 = (r__1 = diftru[5] / dif[5], dabs(r__1)), r__4 = (r__2 = dif[5]
+ / diftru[5], dabs(r__2));
+ ratio2 = dmax(r__3,r__4);
+ result[4] = dmax(ratio1,ratio2);
+ }
+
+ ntestt += 4;
+
+/* Print out tests which fail. */
+
+ for (j = 1; j <= 4; ++j) {
+ if (result[j] >= thrsh2) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___43.ciunit = *nout;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "SXV", (ftnlen)3);
+ e_wsfe();
+
+/* Print out messages for built-in examples */
+
+/* Matrix types */
+
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ do_fio(&c__1, "'", (ftnlen)1);
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[j] < 1e4f) {
+ io___46.ciunit = *nout;
+ s_wsfe(&io___46);
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___47.ciunit = *nout;
+ s_wsfe(&io___47);
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ }
+/* L130: */
+ }
+
+L140:
+
+ goto L90;
+L150:
+
+/* Summary */
+
+ alasvm_("SXV", nout, &nerrs, &ntestt, &c__0);
+
+ work[1] = (real) maxwrk;
+
+ return 0;
+
+
+
+
+
+
+
+
+
+
+
+
+/* End of SDRGVX */
+
+} /* sdrgvx_ */
diff --git a/TESTING/EIG/sdrvbd.c b/TESTING/EIG/sdrvbd.c
new file mode 100644
index 0000000..df1f53a
--- /dev/null
+++ b/TESTING/EIG/sdrvbd.c
@@ -0,0 +1,1108 @@
+/* sdrvbd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static real c_b13 = 0.f;
+static real c_b17 = 1.f;
+static integer c__4 = 4;
+static integer c__1 = 1;
+static integer c__0 = 0;
+
+/* Subroutine */ int sdrvbd_(integer *nsizes, integer *mm, integer *nn,
+ integer *ntypes, logical *dotype, integer *iseed, real *thresh, real *
+ a, integer *lda, real *u, integer *ldu, real *vt, integer *ldvt, real
+ *asav, real *usav, real *vtsav, real *s, real *ssav, real *e, real *
+ work, integer *lwork, integer *iwork, integer *nout, integer *info)
+{
+ /* Initialized data */
+
+ static char cjob[1*4] = "N" "O" "S" "A";
+
+ /* Format strings */
+ static char fmt_9996[] = "(\002 SDRVBD: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002M=\002,i6,\002, N=\002,i6,\002, JTYPE=\002,i"
+ "6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9995[] = "(\002 SDRVBD: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002M=\002,i6,\002, N=\002,i6,\002, JTYPE=\002,i"
+ "6,\002, LSWORK=\002,i6,/9x,\002ISEED=(\002,3(i5,\002,\002),i5"
+ ",\002)\002)";
+ static char fmt_9999[] = "(\002 SVD -- Real Singular Value Decomposition"
+ " Driver \002,/\002 Matrix types (see SDRVBD for details):\002,/"
+ "/\002 1 = Zero matrix\002,/\002 2 = Identity matrix\002,/\002 3 "
+ "= Evenly spaced singular values near 1\002,/\002 4 = Evenly spac"
+ "ed singular values near underflow\002,/\002 5 = Evenly spaced si"
+ "ngular values near overflow\002,//\002 Tests performed: ( A is d"
+ "ense, U and V are orthogonal,\002,/19x,\002 S is an array, and U"
+ "partial, VTpartial, and\002,/19x,\002 Spartial are partially com"
+ "puted U, VT and S),\002,/)";
+ static char fmt_9998[] = "(\002 1 = | A - U diag(S) VT | / ( |A| max(M,N"
+ ") ulp ) \002,/\002 2 = | I - U**T U | / ( M ulp ) \002,/\002 3 ="
+ " | I - VT VT**T | / ( N ulp ) \002,/\002 4 = 0 if S contains min"
+ "(M,N) nonnegative values in\002,\002 decreasing order, else 1/ulp"
+ "\002,/\002 5 = | U - Upartial | / ( M ulp )\002,/\002 6 = | VT -"
+ " VTpartial | / ( N ulp )\002,/\002 7 = | S - Spartial | / ( min("
+ "M,N) ulp |S| )\002,/\002 8 = | A - U diag(S) VT | / ( |A| max(M,"
+ "N) ulp ) \002,/\002 9 = | I - U**T U | / ( M ulp ) \002,/\00210 "
+ "= | I - VT VT**T | / ( N ulp ) \002,/\00211 = 0 if S contains mi"
+ "n(M,N) nonnegative values in\002,\002 decreasing order, else 1/u"
+ "lp\002,/\00212 = | U - Upartial | / ( M ulp )\002,/\00213 = | VT"
+ " - VTpartial | / ( N ulp )\002,/\00214 = | S - Spartial | / ( mi"
+ "n(M,N) ulp |S| )\002,/\00215 = | A - U diag(S) VT | / ( |A| max("
+ "M,N) ulp ) \002,/\00216 = | I - U**T U | / ( M ulp ) \002,/\0021"
+ "7 = | I - VT VT**T | / ( N ulp ) \002,/\00218 = 0 if S contains "
+ "min(M,N) nonnegative values in\002,\002 decreasing order, else 1"
+ "/ulp\002,/\00219 = | U - Upartial | / ( M ulp )\002,/\00220 = | "
+ "VT - VTpartial | / ( N ulp )\002,/\00221 = | S - Spartial | / ( "
+ "min(M,N) ulp |S| )\002,//)";
+ static char fmt_9997[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, type "
+ "\002,i1,\002, IWS=\002,i1,\002, seed=\002,4(i4,\002,\002),\002 t"
+ "est(\002,i2,\002)=\002,g11.4)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, asav_dim1, asav_offset, u_dim1, u_offset,
+ usav_dim1, usav_offset, vt_dim1, vt_offset, vtsav_dim1,
+ vtsav_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
+ i__9, i__10, i__11, i__12, i__13, i__14;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, m, n;
+ real dif, div;
+ integer ijq, iju;
+ real ulp;
+ integer iws;
+ char jobq[1], path[3], jobu[1];
+ integer mmax, nmax;
+ real unfl, ovfl;
+ integer ijvt;
+ logical badmm, badnn;
+ integer nfail;
+ extern /* Subroutine */ int sbdt01_(integer *, integer *, integer *, real
+ *, integer *, real *, integer *, real *, real *, real *, integer *
+, real *, real *);
+ integer iinfo;
+ real anorm;
+ integer mnmin, mnmax;
+ char jobvt[1];
+ integer jsize;
+ extern /* Subroutine */ int sort01_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, real *), sort03_(char *,
+ integer *, integer *, integer *, integer *, real *, integer *,
+ real *, integer *, real *, integer *, real *, integer *);
+ integer jtype, ntest, iwtmp;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int sgesdd_(char *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ integer *, integer *, integer *), xerbla_(char *, integer
+ *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *), sgesvd_(char *, char *, integer *, integer
+ *, real *, integer *, real *, real *, integer *, real *, integer *
+, real *, integer *, integer *), slacpy_(char *,
+ integer *, integer *, real *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *,
+ real *, integer *), sgesvj_(char *, char *, char *,
+ integer *, integer *, real *, integer *, real *, integer *, real *
+, integer *, real *, integer *, integer *)
+ , sgejsv_(char *, char *, char *, char *, char *, char *, integer
+ *, integer *, real *, integer *, real *, real *, integer *, real *
+, integer *, real *, integer *, integer *, integer *), slatms_(integer *,
+ integer *, char *, integer *, char *, real *, integer *, real *,
+ real *, integer *, integer *, char *, real *, integer *, real *,
+ integer *);
+ integer minwrk;
+ real ulpinv, result[22];
+ integer lswork, mtypes;
+
+ /* Fortran I/O blocks */
+ static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVBD checks the singular value decomposition (SVD) drivers */
+/* SGESVD, SGESDD, SGESVJ, and SGEJSV. */
+
+/* Both SGESVD and SGESDD factor A = U diag(S) VT, where U and VT are */
+/* orthogonal and diag(S) is diagonal with the entries of the array S */
+/* on its diagonal. The entries of S are the singular values, */
+/* nonnegative and stored in decreasing order. U and VT can be */
+/* optionally not computed, overwritten on A, or computed partially. */
+
+/* A is M by N. Let MNMIN = min( M, N ). S has dimension MNMIN. */
+/* U can be M by M or M by MNMIN. VT can be N by N or MNMIN by N. */
+
+/* When SDRVBD is called, a number of matrix "sizes" (M's and N's) */
+/* and a number of matrix "types" are specified. For each size (M,N) */
+/* and each type of matrix, and for the minimal workspace as well as */
+/* workspace adequate to permit blocking, an M x N matrix "A" will be */
+/* generated and used to test the SVD routines. For each matrix, A will */
+/* be factored as A = U diag(S) VT and the following 12 tests computed: */
+
+/* Test for SGESVD: */
+
+/* (1) | A - U diag(S) VT | / ( |A| max(M,N) ulp ) */
+
+/* (2) | I - U'U | / ( M ulp ) */
+
+/* (3) | I - VT VT' | / ( N ulp ) */
+
+/* (4) S contains MNMIN nonnegative values in decreasing order. */
+/* (Return 0 if true, 1/ULP if false.) */
+
+/* (5) | U - Upartial | / ( M ulp ) where Upartial is a partially */
+/* computed U. */
+
+/* (6) | VT - VTpartial | / ( N ulp ) where VTpartial is a partially */
+/* computed VT. */
+
+/* (7) | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the */
+/* vector of singular values from the partial SVD */
+
+/* Test for SGESDD: */
+
+/* (8) | A - U diag(S) VT | / ( |A| max(M,N) ulp ) */
+
+/* (9) | I - U'U | / ( M ulp ) */
+
+/* (10) | I - VT VT' | / ( N ulp ) */
+
+/* (11) S contains MNMIN nonnegative values in decreasing order. */
+/* (Return 0 if true, 1/ULP if false.) */
+
+/* (12) | U - Upartial | / ( M ulp ) where Upartial is a partially */
+/* computed U. */
+
+/* (13) | VT - VTpartial | / ( N ulp ) where VTpartial is a partially */
+/* computed VT. */
+
+/* (14) | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the */
+/* vector of singular values from the partial SVD */
+
+/* Test for SGESVJ: */
+
+/* (15) | A - U diag(S) VT | / ( |A| max(M,N) ulp ) */
+
+/* (16) | I - U'U | / ( M ulp ) */
+
+/* (17) | I - VT VT' | / ( N ulp ) */
+
+/* (18) S contains MNMIN nonnegative values in decreasing order. */
+/* (Return 0 if true, 1/ULP if false.) */
+
+/* Test for SGEJSV: */
+
+/* (19) | A - U diag(S) VT | / ( |A| max(M,N) ulp ) */
+
+/* (20) | I - U'U | / ( M ulp ) */
+
+/* (21) | I - VT VT' | / ( N ulp ) */
+
+/* (22) S contains MNMIN nonnegative values in decreasing order. */
+/* (Return 0 if true, 1/ULP if false.) */
+
+/* The "sizes" are specified by the arrays MM(1:NSIZES) and */
+/* NN(1:NSIZES); the value of each element pair (MM(j),NN(j)) */
+/* specifies one size. The "types" are specified by a logical array */
+/* DOTYPE( 1:NTYPES ); if DOTYPE(j) is .TRUE., then matrix type "j" */
+/* will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+/* (4) Same as (3), but multiplied by the underflow-threshold / ULP. */
+/* (5) Same as (3), but multiplied by the overflow-threshold * ULP. */
+
+/* Arguments */
+/* ========== */
+
+/* NSIZES (input) INTEGER */
+/* The number of matrix sizes (M,N) contained in the vectors */
+/* MM and NN. */
+
+/* MM (input) INTEGER array, dimension (NSIZES) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* The values of the matrix column dimension N. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, SDRVBD */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrices are in A and B. */
+/* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size (m,n), a matrix */
+/* of type j will be generated. If NTYPES is smaller than the */
+/* maximum number of types defined (PARAMETER MAXTYP), then */
+/* types NTYPES+1 through MAXTYP will not be generated. If */
+/* NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through */
+/* DOTYPE(NTYPES) will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator. The array */
+/* elements should be between 0 and 4095; if not they will be */
+/* reduced mod 4096. Also, ISEED(4) must be odd. */
+/* On exit, ISEED is changed and can be used in the next call to */
+/* SDRVBD to continue the same random number sequence. */
+
+/* THRESH (input) REAL */
+/* The threshold value for the test ratios. A result is */
+/* included in the output file if RESULT >= THRESH. The test */
+/* ratios are scaled to be O(1), so THRESH should be a small */
+/* multiple of 1, e.g., 10 or 100. To have every test ratio */
+/* printed, use THRESH = 0. */
+
+/* A (workspace) REAL array, dimension (LDA,NMAX) */
+/* where NMAX is the maximum value of N in NN. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,MMAX), */
+/* where MMAX is the maximum value of M in MM. */
+
+/* U (workspace) REAL array, dimension (LDU,MMAX) */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,MMAX). */
+
+/* VT (workspace) REAL array, dimension (LDVT,NMAX) */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. LDVT >= max(1,NMAX). */
+
+/* ASAV (workspace) REAL array, dimension (LDA,NMAX) */
+
+/* USAV (workspace) REAL array, dimension (LDU,MMAX) */
+
+/* VTSAV (workspace) REAL array, dimension (LDVT,NMAX) */
+
+/* S (workspace) REAL array, dimension */
+/* (max(min(MM,NN))) */
+
+/* SSAV (workspace) REAL array, dimension */
+/* (max(min(MM,NN))) */
+
+/* E (workspace) REAL array, dimension */
+/* (max(min(MM,NN))) */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* max(3*MN+MX,5*MN-4)+2*MN**2 for all pairs */
+/* pairs (MN,MX)=( min(MM(j),NN(j), max(MM(j),NN(j)) ) */
+
+/* IWORK (workspace) INTEGER array, dimension at least 8*min(M,N) */
+
+/* NOUT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some MM(j) < 0 */
+/* -3: Some NN(j) < 0 */
+/* -4: NTYPES < 0 */
+/* -7: THRESH < 0 */
+/* -10: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ). */
+/* -12: LDU < 1 or LDU < MMAX. */
+/* -14: LDVT < 1 or LDVT < NMAX, where NMAX is max( NN(j) ). */
+/* -21: LWORK too small. */
+/* If SLATMS, or SGESVD returns an error code, the */
+/* absolute value of it is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --mm;
+ --nn;
+ --dotype;
+ --iseed;
+ asav_dim1 = *lda;
+ asav_offset = 1 + asav_dim1;
+ asav -= asav_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ usav_dim1 = *ldu;
+ usav_offset = 1 + usav_dim1;
+ usav -= usav_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ vtsav_dim1 = *ldvt;
+ vtsav_offset = 1 + vtsav_dim1;
+ vtsav -= vtsav_offset;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --s;
+ --ssav;
+ --e;
+ --work;
+ --iwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+ badmm = FALSE_;
+ badnn = FALSE_;
+ mmax = 1;
+ nmax = 1;
+ mnmax = 1;
+ minwrk = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = mmax, i__3 = mm[j];
+ mmax = max(i__2,i__3);
+ if (mm[j] < 0) {
+ badmm = TRUE_;
+ }
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__4 = mm[j], i__5 = nn[j];
+ i__2 = mnmax, i__3 = min(i__4,i__5);
+ mnmax = max(i__2,i__3);
+/* Computing MAX */
+/* Computing MAX */
+/* Computing MIN */
+ i__6 = mm[j], i__7 = nn[j];
+/* Computing MAX */
+ i__8 = mm[j], i__9 = nn[j];
+/* Computing MIN */
+ i__10 = mm[j], i__11 = nn[j] - 4;
+ i__4 = min(i__6,i__7) * 3 + max(i__8,i__9), i__5 = min(i__10,i__11) *
+ 5;
+/* Computing MIN */
+ i__13 = mm[j], i__14 = nn[j];
+/* Computing 2nd power */
+ i__12 = min(i__13,i__14);
+ i__2 = minwrk, i__3 = max(i__4,i__5) + (i__12 * i__12 << 1);
+ minwrk = max(i__2,i__3);
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badmm) {
+ *info = -2;
+ } else if (badnn) {
+ *info = -3;
+ } else if (*ntypes < 0) {
+ *info = -4;
+ } else if (*lda < max(1,mmax)) {
+ *info = -10;
+ } else if (*ldu < max(1,mmax)) {
+ *info = -12;
+ } else if (*ldvt < max(1,nmax)) {
+ *info = -14;
+ } else if (minwrk > *lwork) {
+ *info = -21;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SDRVBD", &i__1);
+ return 0;
+ }
+
+/* Initialize constants */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "BD", (ftnlen)2, (ftnlen)2);
+ nfail = 0;
+ ntest = 0;
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ slabad_(&unfl, &ovfl);
+ ulp = slamch_("Precision");
+ ulpinv = 1.f / ulp;
+ infoc_1.infot = 0;
+
+/* Loop over sizes, types */
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ m = mm[jsize];
+ n = nn[jsize];
+ mnmin = min(m,n);
+
+ if (*nsizes != 1) {
+ mtypes = min(5,*ntypes);
+ } else {
+ mtypes = min(6,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L140;
+ }
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Compute "A" */
+
+ if (mtypes > 5) {
+ goto L30;
+ }
+
+ if (jtype == 1) {
+
+/* Zero matrix */
+
+ slaset_("Full", &m, &n, &c_b13, &c_b13, &a[a_offset], lda);
+
+ } else if (jtype == 2) {
+
+/* Identity matrix */
+
+ slaset_("Full", &m, &n, &c_b13, &c_b17, &a[a_offset], lda);
+
+ } else {
+
+/* (Scaled) random matrix */
+
+ if (jtype == 3) {
+ anorm = 1.f;
+ }
+ if (jtype == 4) {
+ anorm = unfl / ulp;
+ }
+ if (jtype == 5) {
+ anorm = ovfl * ulp;
+ }
+ r__1 = (real) mnmin;
+ i__3 = m - 1;
+ i__4 = n - 1;
+ slatms_(&m, &n, "U", &iseed[1], "N", &s[1], &c__4, &r__1, &
+ anorm, &i__3, &i__4, "N", &a[a_offset], lda, &work[1],
+ &iinfo);
+ if (iinfo != 0) {
+ io___25.ciunit = *nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+ }
+
+L30:
+ slacpy_("F", &m, &n, &a[a_offset], lda, &asav[asav_offset], lda);
+
+/* Do for minimal and adequate (for blocking) workspace */
+
+ for (iws = 1; iws <= 4; ++iws) {
+
+ for (j = 1; j <= 14; ++j) {
+ result[j - 1] = -1.f;
+/* L40: */
+ }
+
+/* Test SGESVD: Factorize A */
+
+/* Computing MAX */
+ i__3 = min(m,n) * 3 + max(m,n), i__4 = min(m,n) * 5;
+ iwtmp = max(i__3,i__4);
+ lswork = iwtmp + (iws - 1) * (*lwork - iwtmp) / 3;
+ lswork = min(lswork,*lwork);
+ lswork = max(lswork,1);
+ if (iws == 4) {
+ lswork = *lwork;
+ }
+
+ if (iws > 1) {
+ slacpy_("F", &m, &n, &asav[asav_offset], lda, &a[a_offset]
+, lda);
+ }
+ s_copy(srnamc_1.srnamt, "SGESVD", (ftnlen)32, (ftnlen)6);
+ sgesvd_("A", "A", &m, &n, &a[a_offset], lda, &ssav[1], &usav[
+ usav_offset], ldu, &vtsav[vtsav_offset], ldvt, &work[
+ 1], &lswork, &iinfo);
+ if (iinfo != 0) {
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, "GESVD", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lswork, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Do tests 1--4 */
+
+ sbdt01_(&m, &n, &c__0, &asav[asav_offset], lda, &usav[
+ usav_offset], ldu, &ssav[1], &e[1], &vtsav[
+ vtsav_offset], ldvt, &work[1], result);
+ if (m != 0 && n != 0) {
+ sort01_("Columns", &m, &m, &usav[usav_offset], ldu, &work[
+ 1], lwork, &result[1]);
+ sort01_("Rows", &n, &n, &vtsav[vtsav_offset], ldvt, &work[
+ 1], lwork, &result[2]);
+ }
+ result[3] = 0.f;
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (ssav[i__] < ssav[i__ + 1]) {
+ result[3] = ulpinv;
+ }
+ if (ssav[i__] < 0.f) {
+ result[3] = ulpinv;
+ }
+/* L50: */
+ }
+ if (mnmin >= 1) {
+ if (ssav[mnmin] < 0.f) {
+ result[3] = ulpinv;
+ }
+ }
+
+/* Do partial SVDs, comparing to SSAV, USAV, and VTSAV */
+
+ result[4] = 0.f;
+ result[5] = 0.f;
+ result[6] = 0.f;
+ for (iju = 0; iju <= 3; ++iju) {
+ for (ijvt = 0; ijvt <= 3; ++ijvt) {
+ if (iju == 3 && ijvt == 3 || iju == 1 && ijvt == 1) {
+ goto L70;
+ }
+ *(unsigned char *)jobu = *(unsigned char *)&cjob[iju];
+ *(unsigned char *)jobvt = *(unsigned char *)&cjob[
+ ijvt];
+ slacpy_("F", &m, &n, &asav[asav_offset], lda, &a[
+ a_offset], lda);
+ s_copy(srnamc_1.srnamt, "SGESVD", (ftnlen)32, (ftnlen)
+ 6);
+ sgesvd_(jobu, jobvt, &m, &n, &a[a_offset], lda, &s[1],
+ &u[u_offset], ldu, &vt[vt_offset], ldvt, &
+ work[1], &lswork, &iinfo);
+
+/* Compare U */
+
+ dif = 0.f;
+ if (m > 0 && n > 0) {
+ if (iju == 1) {
+ sort03_("C", &m, &mnmin, &m, &mnmin, &usav[
+ usav_offset], ldu, &a[a_offset], lda,
+ &work[1], lwork, &dif, &iinfo);
+ } else if (iju == 2) {
+ sort03_("C", &m, &mnmin, &m, &mnmin, &usav[
+ usav_offset], ldu, &u[u_offset], ldu,
+ &work[1], lwork, &dif, &iinfo);
+ } else if (iju == 3) {
+ sort03_("C", &m, &m, &m, &mnmin, &usav[
+ usav_offset], ldu, &u[u_offset], ldu,
+ &work[1], lwork, &dif, &iinfo);
+ }
+ }
+ result[4] = dmax(result[4],dif);
+
+/* Compare VT */
+
+ dif = 0.f;
+ if (m > 0 && n > 0) {
+ if (ijvt == 1) {
+ sort03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &a[a_offset],
+ lda, &work[1], lwork, &dif, &iinfo);
+ } else if (ijvt == 2) {
+ sort03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &vt[vt_offset],
+ ldvt, &work[1], lwork, &dif, &iinfo);
+ } else if (ijvt == 3) {
+ sort03_("R", &n, &n, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &vt[vt_offset],
+ ldvt, &work[1], lwork, &dif, &iinfo);
+ }
+ }
+ result[5] = dmax(result[5],dif);
+
+/* Compare S */
+
+ dif = 0.f;
+/* Computing MAX */
+ r__1 = (real) mnmin * ulp * s[1];
+ div = dmax(r__1,unfl);
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (ssav[i__] < ssav[i__ + 1]) {
+ dif = ulpinv;
+ }
+ if (ssav[i__] < 0.f) {
+ dif = ulpinv;
+ }
+/* Computing MAX */
+ r__2 = dif, r__3 = (r__1 = ssav[i__] - s[i__],
+ dabs(r__1)) / div;
+ dif = dmax(r__2,r__3);
+/* L60: */
+ }
+ result[6] = dmax(result[6],dif);
+L70:
+ ;
+ }
+/* L80: */
+ }
+
+/* Test SGESDD: Factorize A */
+
+ iwtmp = mnmin * 5 * mnmin + mnmin * 9 + max(m,n);
+ lswork = iwtmp + (iws - 1) * (*lwork - iwtmp) / 3;
+ lswork = min(lswork,*lwork);
+ lswork = max(lswork,1);
+ if (iws == 4) {
+ lswork = *lwork;
+ }
+
+ slacpy_("F", &m, &n, &asav[asav_offset], lda, &a[a_offset],
+ lda);
+ s_copy(srnamc_1.srnamt, "SGESDD", (ftnlen)32, (ftnlen)6);
+ sgesdd_("A", &m, &n, &a[a_offset], lda, &ssav[1], &usav[
+ usav_offset], ldu, &vtsav[vtsav_offset], ldvt, &work[
+ 1], &lswork, &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, "GESDD", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lswork, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Do tests 8--11 */
+
+ sbdt01_(&m, &n, &c__0, &asav[asav_offset], lda, &usav[
+ usav_offset], ldu, &ssav[1], &e[1], &vtsav[
+ vtsav_offset], ldvt, &work[1], &result[7]);
+ if (m != 0 && n != 0) {
+ sort01_("Columns", &m, &m, &usav[usav_offset], ldu, &work[
+ 1], lwork, &result[8]);
+ sort01_("Rows", &n, &n, &vtsav[vtsav_offset], ldvt, &work[
+ 1], lwork, &result[9]);
+ }
+ result[10] = 0.f;
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (ssav[i__] < ssav[i__ + 1]) {
+ result[10] = ulpinv;
+ }
+ if (ssav[i__] < 0.f) {
+ result[10] = ulpinv;
+ }
+/* L90: */
+ }
+ if (mnmin >= 1) {
+ if (ssav[mnmin] < 0.f) {
+ result[10] = ulpinv;
+ }
+ }
+
+/* Do partial SVDs, comparing to SSAV, USAV, and VTSAV */
+
+ result[11] = 0.f;
+ result[12] = 0.f;
+ result[13] = 0.f;
+ for (ijq = 0; ijq <= 2; ++ijq) {
+ *(unsigned char *)jobq = *(unsigned char *)&cjob[ijq];
+ slacpy_("F", &m, &n, &asav[asav_offset], lda, &a[a_offset]
+, lda);
+ s_copy(srnamc_1.srnamt, "SGESDD", (ftnlen)32, (ftnlen)6);
+ sgesdd_(jobq, &m, &n, &a[a_offset], lda, &s[1], &u[
+ u_offset], ldu, &vt[vt_offset], ldvt, &work[1], &
+ lswork, &iwork[1], &iinfo);
+
+/* Compare U */
+
+ dif = 0.f;
+ if (m > 0 && n > 0) {
+ if (ijq == 1) {
+ if (m >= n) {
+ sort03_("C", &m, &mnmin, &m, &mnmin, &usav[
+ usav_offset], ldu, &a[a_offset], lda,
+ &work[1], lwork, &dif, info);
+ } else {
+ sort03_("C", &m, &mnmin, &m, &mnmin, &usav[
+ usav_offset], ldu, &u[u_offset], ldu,
+ &work[1], lwork, &dif, info);
+ }
+ } else if (ijq == 2) {
+ sort03_("C", &m, &mnmin, &m, &mnmin, &usav[
+ usav_offset], ldu, &u[u_offset], ldu, &
+ work[1], lwork, &dif, info);
+ }
+ }
+ result[11] = dmax(result[11],dif);
+
+/* Compare VT */
+
+ dif = 0.f;
+ if (m > 0 && n > 0) {
+ if (ijq == 1) {
+ if (m >= n) {
+ sort03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &vt[vt_offset],
+ ldvt, &work[1], lwork, &dif, info);
+ } else {
+ sort03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &a[a_offset],
+ lda, &work[1], lwork, &dif, info);
+ }
+ } else if (ijq == 2) {
+ sort03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &vt[vt_offset], ldvt,
+ &work[1], lwork, &dif, info);
+ }
+ }
+ result[12] = dmax(result[12],dif);
+
+/* Compare S */
+
+ dif = 0.f;
+/* Computing MAX */
+ r__1 = (real) mnmin * ulp * s[1];
+ div = dmax(r__1,unfl);
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (ssav[i__] < ssav[i__ + 1]) {
+ dif = ulpinv;
+ }
+ if (ssav[i__] < 0.f) {
+ dif = ulpinv;
+ }
+/* Computing MAX */
+ r__2 = dif, r__3 = (r__1 = ssav[i__] - s[i__], dabs(
+ r__1)) / div;
+ dif = dmax(r__2,r__3);
+/* L100: */
+ }
+ result[13] = dmax(result[13],dif);
+/* L110: */
+ }
+
+/* Test SGESVJ: Factorize A */
+/* Note: SGESVJ does not work for M < N */
+
+ result[14] = 0.f;
+ result[15] = 0.f;
+ result[16] = 0.f;
+ result[17] = 0.f;
+
+ if (m >= n) {
+ iwtmp = mnmin * 5 * mnmin + mnmin * 9 + max(m,n);
+ lswork = iwtmp + (iws - 1) * (*lwork - iwtmp) / 3;
+ lswork = min(lswork,*lwork);
+ lswork = max(lswork,1);
+ if (iws == 4) {
+ lswork = *lwork;
+ }
+
+ slacpy_("F", &m, &n, &asav[asav_offset], lda, &usav[
+ usav_offset], lda);
+ s_copy(srnamc_1.srnamt, "SGESVJ", (ftnlen)32, (ftnlen)6);
+ sgesvj_("G", "U", "V", &m, &n, &usav[usav_offset], lda, &
+ ssav[1], &c__0, &a[a_offset], ldvt, &work[1],
+ lwork, info);
+
+/* SGESVJ retuns V not VT, so we transpose to use the same */
+/* test suite. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ vtsav[j + i__ * vtsav_dim1] = a[i__ + j * a_dim1];
+ }
+ }
+
+ if (iinfo != 0) {
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "GESVJ", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&lswork, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Do tests 15--18 */
+
+ sbdt01_(&m, &n, &c__0, &asav[asav_offset], lda, &usav[
+ usav_offset], ldu, &ssav[1], &e[1], &vtsav[
+ vtsav_offset], ldvt, &work[1], &result[14]);
+ if (m != 0 && n != 0) {
+ sort01_("Columns", &m, &m, &usav[usav_offset], ldu, &
+ work[1], lwork, &result[15]);
+ sort01_("Rows", &n, &n, &vtsav[vtsav_offset], ldvt, &
+ work[1], lwork, &result[16]);
+ }
+ result[17] = 0.f;
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (ssav[i__] < ssav[i__ + 1]) {
+ result[17] = ulpinv;
+ }
+ if (ssav[i__] < 0.f) {
+ result[17] = ulpinv;
+ }
+/* L200: */
+ }
+ if (mnmin >= 1) {
+ if (ssav[mnmin] < 0.f) {
+ result[17] = ulpinv;
+ }
+ }
+ }
+
+/* Test SGEJSV: Factorize A */
+/* Note: SGEJSV does not work for M < N */
+
+ result[18] = 0.f;
+ result[19] = 0.f;
+ result[20] = 0.f;
+ result[21] = 0.f;
+ if (m >= n) {
+ iwtmp = mnmin * 5 * mnmin + mnmin * 9 + max(m,n);
+ lswork = iwtmp + (iws - 1) * (*lwork - iwtmp) / 3;
+ lswork = min(lswork,*lwork);
+ lswork = max(lswork,1);
+ if (iws == 4) {
+ lswork = *lwork;
+ }
+
+ slacpy_("F", &m, &n, &asav[asav_offset], lda, &vtsav[
+ vtsav_offset], lda);
+ s_copy(srnamc_1.srnamt, "SGEJSV", (ftnlen)32, (ftnlen)6);
+ sgejsv_("G", "U", "V", "R", "N", "N", &m, &n, &vtsav[
+ vtsav_offset], lda, &ssav[1], &usav[usav_offset],
+ ldu, &a[a_offset], ldvt, &work[1], lwork, &iwork[
+ 1], info);
+
+/* SGEJSV retuns V not VT, so we transpose to use the same */
+/* test suite. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ vtsav[j + i__ * vtsav_dim1] = a[i__ + j * a_dim1];
+ }
+ }
+
+ if (iinfo != 0) {
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "GESVJ", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&lswork, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Do tests 19--22 */
+
+ sbdt01_(&m, &n, &c__0, &asav[asav_offset], lda, &usav[
+ usav_offset], ldu, &ssav[1], &e[1], &vtsav[
+ vtsav_offset], ldvt, &work[1], &result[18]);
+ if (m != 0 && n != 0) {
+ sort01_("Columns", &m, &m, &usav[usav_offset], ldu, &
+ work[1], lwork, &result[19]);
+ sort01_("Rows", &n, &n, &vtsav[vtsav_offset], ldvt, &
+ work[1], lwork, &result[20]);
+ }
+ result[21] = 0.f;
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (ssav[i__] < ssav[i__ + 1]) {
+ result[21] = ulpinv;
+ }
+ if (ssav[i__] < 0.f) {
+ result[21] = ulpinv;
+ }
+/* L300: */
+ }
+ if (mnmin >= 1) {
+ if (ssav[mnmin] < 0.f) {
+ result[21] = ulpinv;
+ }
+ }
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+ for (j = 1; j <= 22; ++j) {
+ if (result[j - 1] >= *thresh) {
+ if (nfail == 0) {
+ io___43.ciunit = *nout;
+ s_wsfe(&io___43);
+ e_wsfe();
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ e_wsfe();
+ }
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iws, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L120: */
+ }
+ ntest += 22;
+
+/* L130: */
+ }
+L140:
+ ;
+ }
+/* L150: */
+ }
+
+/* Summary */
+
+ alasvm_(path, nout, &nfail, &ntest, &c__0);
+
+
+ return 0;
+
+/* End of SDRVBD */
+
+} /* sdrvbd_ */
diff --git a/TESTING/EIG/sdrves.c b/TESTING/EIG/sdrves.c
new file mode 100644
index 0000000..401cd44
--- /dev/null
+++ b/TESTING/EIG/sdrves.c
@@ -0,0 +1,1095 @@
+/* sdrves.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ real selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+/* Table of constant values */
+
+static real c_b17 = 0.f;
+static integer c__0 = 0;
+static real c_b31 = 1.f;
+static integer c__4 = 4;
+static integer c__6 = 6;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int sdrves_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, integer *nounit, real *
+ a, integer *lda, real *h__, real *ht, real *wr, real *wi, real *wrt,
+ real *wit, real *vs, integer *ldvs, real *result, real *work, integer
+ *nwork, integer *iwork, logical *bwork, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
+ static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
+ static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9992[] = "(\002 SDRVES: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(/1x,a3,\002 -- Real Schur Form Decomposition "
+ "Driver\002,/\002 Matrix types (see SDRVES for details): \002)";
+ static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 \002,\002 5=Diagonal: geom"
+ "etr. spaced entries.\002,/\002 2=Identity matrix. "
+ " \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
+ "/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
+ " 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
+ "l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
+ "ll, evenly spaced.\002)";
+ static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
+ " 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
+ "l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
+ "d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
+ "red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
+ "vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
+ " 12=Well-cond., random complex \002,6x,\002 \002,\002 17=Ill-c"
+ "ond., large rand. complx \002,/\002 13=Ill-condi\002,\002tioned,"
+ " evenly spaced. \002,\002 18=Ill-cond., small rand.\002,\002"
+ " complx \002)";
+ static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
+ " \002,\002 21=Matrix \002,\002with small random entries.\002,"
+ "/\002 20=Matrix with large ran\002,\002dom entries. \002,/)";
+ static char fmt_9995[] = "(\002 Tests performed with test threshold ="
+ "\002,f8.2,/\002 ( A denotes A on input and T denotes A on output)"
+ "\002,//\002 1 = 0 if T in Schur form (no sort), \002,\002 1/ulp"
+ " otherwise\002,/\002 2 = | A - VS T transpose(VS) | / ( n |A| ul"
+ "p ) (no sort)\002,/\002 3 = | I - VS transpose(VS) | / ( n ulp )"
+ " (no sort) \002,/\002 4 = 0 if WR+sqrt(-1)*WI are eigenvalues of"
+ " T (no sort),\002,\002 1/ulp otherwise\002,/\002 5 = 0 if T sam"
+ "e no matter if VS computed (no sort),\002,\002 1/ulp otherwis"
+ "e\002,/\002 6 = 0 if WR, WI same no matter if VS computed (no so"
+ "rt)\002,\002, 1/ulp otherwise\002)";
+ static char fmt_9994[] = "(\002 7 = 0 if T in Schur form (sort), \002"
+ ",\002 1/ulp otherwise\002,/\002 8 = | A - VS T transpose(VS) | "
+ "/ ( n |A| ulp ) (sort)\002,/\002 9 = | I - VS transpose(VS) | / "
+ "( n ulp ) (sort) \002,/\002 10 = 0 if WR+sqrt(-1)*WI are eigenva"
+ "lues of T (sort),\002,\002 1/ulp otherwise\002,/\002 11 = 0 if "
+ "T same no matter if VS computed (sort),\002,\002 1/ulp otherwise"
+ "\002,/\002 12 = 0 if WR, WI same no matter if VS computed (sort),"
+ "\002,\002 1/ulp otherwise\002,/\002 13 = 0 if sorting succesful"
+ ", 1/ulp otherwise\002,/)";
+ static char fmt_9993[] = "(\002 N=\002,i5,\002, IWK=\002,i2,\002, seed"
+ "=\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)="
+ "\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, ht_dim1, ht_offset, vs_dim1,
+ vs_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double r_sign(real *, real *);
+
+ /* Local variables */
+ integer i__, j, n;
+ real res[2];
+ integer iwk;
+ real tmp, ulp, cond;
+ integer jcol;
+ char path[3];
+ integer sdim, nmax;
+ real unfl, ovfl;
+ integer rsub;
+ char sort[1];
+ logical badnn;
+ integer nfail, imode, iinfo;
+ real conds;
+ extern /* Subroutine */ int sgees_(char *, char *, L_fp, integer *, real *
+, integer *, integer *, real *, real *, real *, integer *, real *,
+ integer *, logical *, integer *);
+ real anorm;
+ extern /* Subroutine */ int shst01_(integer *, integer *, integer *, real
+ *, integer *, real *, integer *, real *, integer *, real *,
+ integer *, real *);
+ integer jsize, nerrs, itype, jtype, ntest, lwork, isort;
+ real rtulp;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ char adumma[1*1];
+ extern doublereal slamch_(char *);
+ integer idumma[1], ioldsd[4];
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer knteig;
+ extern /* Subroutine */ int slatme_(integer *, char *, integer *, real *,
+ integer *, real *, real *, char *, char *, char *, char *, real *,
+ integer *, real *, integer *, integer *, real *, real *, integer
+ *, real *, integer *),
+ slacpy_(char *, integer *, integer *, real *, integer *, real *,
+ integer *), slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *);
+ extern logical sslect_(real *, real *);
+ extern /* Subroutine */ int slatmr_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, char *, char *,
+ real *, integer *, real *, real *, integer *, real *, char *,
+ integer *, integer *, integer *, real *, real *, char *, real *,
+ integer *, integer *, integer *);
+ integer ntestf;
+ extern /* Subroutine */ int slasum_(char *, integer *, integer *, integer
+ *), slatms_(integer *, integer *, char *, integer *, char
+ *, real *, integer *, real *, real *, integer *, integer *, char *
+, real *, integer *, real *, integer *);
+ real ulpinv;
+ integer nnwork;
+ real rtulpi;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___32 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVES checks the nonsymmetric eigenvalue (Schur form) problem */
+/* driver SGEES. */
+
+/* When SDRVES is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 13 */
+/* tests will be performed: */
+
+/* (1) 0 if T is in Schur form, 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (2) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (no sorting of eigenvalues). */
+
+/* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues). */
+
+/* (4) 0 if WR+sqrt(-1)*WI are eigenvalues of T */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (5) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (7) 0 if T is in Schur form, 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (8) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (with sorting of eigenvalues). */
+
+/* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues). */
+
+/* (10) 0 if WR+sqrt(-1)*WI are eigenvalues of T */
+/* 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (11) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (13) if sorting worked and SDIM is the number of */
+/* eigenvalues which were SELECTed */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
+
+/* (4) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (5) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (7) Same as (4), but multiplied by a constant near */
+/* the overflow threshold */
+/* (8) Same as (4), but multiplied by a constant near */
+/* the underflow threshold */
+
+/* (9) A matrix of the form U' T U, where U is orthogonal and */
+/* T has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (10) A matrix of the form U' T U, where U is orthogonal and */
+/* T has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (11) A matrix of the form U' T U, where U is orthogonal and */
+/* T has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (12) A matrix of the form U' T U, where U is orthogonal and */
+/* T has real or complex conjugate paired eigenvalues randomly */
+/* chosen from ( ULP, 1 ) and random O(1) entries in the upper */
+/* triangle. */
+
+/* (13) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
+/* with random signs on the diagonal and random O(1) entries */
+/* in the upper triangle. */
+
+/* (14) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has geometrically spaced entries */
+/* 1, ..., ULP with random signs on the diagonal and random */
+/* O(1) entries in the upper triangle. */
+
+/* (15) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
+/* with random signs on the diagonal and random O(1) entries */
+/* in the upper triangle. */
+
+/* (16) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has real or complex conjugate paired */
+/* eigenvalues randomly chosen from ( ULP, 1 ) and random */
+/* O(1) entries in the upper triangle. */
+
+/* (17) Same as (16), but multiplied by a constant */
+/* near the overflow threshold */
+/* (18) Same as (16), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* (19) Nonsymmetric matrix with random entries chosen from (-1,1). */
+/* If N is at least 4, all entries in first two rows and last */
+/* row, and first column and last two columns are zero. */
+/* (20) Same as (19), but multiplied by a constant */
+/* near the overflow threshold */
+/* (21) Same as (19), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* SDRVES does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, SDRVES */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to SDRVES to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* A (workspace) REAL array, dimension (LDA, max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, and H. LDA must be at */
+/* least 1 and at least max(NN). */
+
+/* H (workspace) REAL array, dimension (LDA, max(NN)) */
+/* Another copy of the test matrix A, modified by SGEES. */
+
+/* HT (workspace) REAL array, dimension (LDA, max(NN)) */
+/* Yet another copy of the test matrix A, modified by SGEES. */
+
+/* WR (workspace) REAL array, dimension (max(NN)) */
+/* WI (workspace) REAL array, dimension (max(NN)) */
+/* The real and imaginary parts of the eigenvalues of A. */
+/* On exit, WR + WI*i are the eigenvalues of the matrix in A. */
+
+/* WRT (workspace) REAL array, dimension (max(NN)) */
+/* WIT (workspace) REAL array, dimension (max(NN)) */
+/* Like WR, WI, these arrays contain the eigenvalues of A, */
+/* but those computed when SGEES only computes a partial */
+/* eigendecomposition, i.e. not Schur vectors */
+
+/* VS (workspace) REAL array, dimension (LDVS, max(NN)) */
+/* VS holds the computed Schur vectors. */
+
+/* LDVS (input) INTEGER */
+/* Leading dimension of VS. Must be at least max(1,max(NN)). */
+
+/* RESULT (output) REAL array, dimension (13) */
+/* The values computed by the 13 tests described above. */
+/* The values are currently limited to 1/ulp, to avoid overflow. */
+
+/* WORK (workspace) REAL array, dimension (NWORK) */
+
+/* NWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 5*NN(j)+2*NN(j)**2 for all j. */
+
+/* IWORK (workspace) INTEGER array, dimension (max(NN)) */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -6: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -17: LDVS < 1 or LDVS < NMAX, where NMAX is max( NN(j) ). */
+/* -20: NWORK too small. */
+/* If SLATMR, SLATMS, SLATME or SGEES returns an error code, */
+/* the absolute value of it is returned. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NMAX Largest value in NN. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* COND, CONDS, */
+/* IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTULP, RTULPI Square roots of the previous 4 values. */
+
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+/* KCONDS(j) Selectw whether CONDS is to be 1 or */
+/* 1/sqrt(ulp). (0 means irrelevant.) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ ht_dim1 = *lda;
+ ht_offset = 1 + ht_dim1;
+ ht -= ht_offset;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --wr;
+ --wi;
+ --wrt;
+ --wit;
+ vs_dim1 = *ldvs;
+ vs_offset = 1 + vs_dim1;
+ vs -= vs_offset;
+ --result;
+ --work;
+ --iwork;
+ --bwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "ES", (ftnlen)2, (ftnlen)2);
+
+/* Check for errors */
+
+ ntestt = 0;
+ ntestf = 0;
+ *info = 0;
+ sslct_1.selopt = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+ nmax = 0;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.f) {
+ *info = -6;
+ } else if (*nounit <= 0) {
+ *info = -7;
+ } else if (*lda < 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldvs < 1 || *ldvs < nmax) {
+ *info = -17;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = nmax;
+ if (nmax * 5 + (i__1 * i__1 << 1) > *nwork) {
+ *info = -20;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SDRVES", &i__1);
+ return 0;
+ }
+
+/* Quick return if nothing to do */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ slabad_(&unfl, &ovfl);
+ ulp = slamch_("Precision");
+ ulpinv = 1.f / ulp;
+ rtulp = sqrt(ulp);
+ rtulpi = 1.f / rtulp;
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ mtypes = 21;
+ if (*nsizes == 1 && *ntypes == 22) {
+ ++mtypes;
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L260;
+ }
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KCONDS KMODE KTYPE */
+/* =1 O(1) 1 clustered 1 zero */
+/* =2 large large clustered 2 identity */
+/* =3 small exponential Jordan */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random general, w/ eigenvalues */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 random general */
+/* =10 random triangular */
+
+ if (mtypes > 21) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L30;
+ case 2: goto L40;
+ case 3: goto L50;
+ }
+
+L30:
+ anorm = 1.f;
+ goto L60;
+
+L40:
+ anorm = ovfl * ulp;
+ goto L60;
+
+L50:
+ anorm = unfl * ulpinv;
+ goto L60;
+
+L60:
+
+ slaset_("Full", lda, &n, &c_b17, &c_b17, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+/* L70: */
+ }
+
+ } else if (itype == 3) {
+
+/* Jordan Block */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+ if (jcol > 1) {
+ a[jcol + (jcol - 1) * a_dim1] = 1.f;
+ }
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 6) {
+
+/* General, eigenvalues specified */
+
+ if (kconds[jtype - 1] == 1) {
+ conds = 1.f;
+ } else if (kconds[jtype - 1] == 2) {
+ conds = rtulpi;
+ } else {
+ conds = 0.f;
+ }
+
+ *(unsigned char *)&adumma[0] = ' ';
+ slatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b31,
+ adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
+ n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
+ &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b31,
+ &c_b31, "T", "N", &work[n + 1], &c__1, &c_b31, &work[(
+ n << 1) + 1], &c__1, &c_b31, "N", idumma, &c__0, &
+ c__0, &c_b17, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b31,
+ &c_b31, "T", "N", &work[n + 1], &c__1, &c_b31, &work[(
+ n << 1) + 1], &c__1, &c_b31, "N", idumma, &n, &n, &
+ c_b17, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* General, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b31,
+ &c_b31, "T", "N", &work[n + 1], &c__1, &c_b31, &work[(
+ n << 1) + 1], &c__1, &c_b31, "N", idumma, &n, &n, &
+ c_b17, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+ if (n >= 4) {
+ slaset_("Full", &c__2, &n, &c_b17, &c_b17, &a[a_offset],
+ lda);
+ i__3 = n - 3;
+ slaset_("Full", &i__3, &c__1, &c_b17, &c_b17, &a[a_dim1 +
+ 3], lda);
+ i__3 = n - 3;
+ slaset_("Full", &i__3, &c__2, &c_b17, &c_b17, &a[(n - 1) *
+ a_dim1 + 3], lda);
+ slaset_("Full", &c__1, &n, &c_b17, &c_b17, &a[n + a_dim1],
+ lda);
+ }
+
+ } else if (itype == 10) {
+
+/* Triangular, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b31,
+ &c_b31, "T", "N", &work[n + 1], &c__1, &c_b31, &work[(
+ n << 1) + 1], &c__1, &c_b31, "N", idumma, &n, &c__0, &
+ c_b17, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___32.ciunit = *nounit;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+/* Test for minimal and generous workspace */
+
+ for (iwk = 1; iwk <= 2; ++iwk) {
+ if (iwk == 1) {
+ nnwork = n * 3;
+ } else {
+/* Computing 2nd power */
+ i__3 = n;
+ nnwork = n * 5 + (i__3 * i__3 << 1);
+ }
+ nnwork = max(nnwork,1);
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 13; ++j) {
+ result[j] = -1.f;
+/* L100: */
+ }
+
+/* Test with and without sorting of eigenvalues */
+
+ for (isort = 0; isort <= 1; ++isort) {
+ if (isort == 0) {
+ *(unsigned char *)sort = 'N';
+ rsub = 0;
+ } else {
+ *(unsigned char *)sort = 'S';
+ rsub = 6;
+ }
+
+/* Compute Schur form and Schur vectors, and test them */
+
+ slacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset],
+ lda);
+ sgees_("V", sort, (L_fp)sslect_, &n, &h__[h_offset], lda,
+ &sdim, &wr[1], &wi[1], &vs[vs_offset], ldvs, &
+ work[1], &nnwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != n + 2) {
+ result[rsub + 1] = ulpinv;
+ io___39.ciunit = *nounit;
+ s_wsfe(&io___39);
+ do_fio(&c__1, "SGEES1", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Do Test (1) or Test (7) */
+
+ result[rsub + 1] = 0.f;
+ i__3 = n - 2;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j + 2; i__ <= i__4; ++i__) {
+ if (h__[i__ + j * h_dim1] != 0.f) {
+ result[rsub + 1] = ulpinv;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+ i__3 = n - 2;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (h__[i__ + 1 + i__ * h_dim1] != 0.f && h__[i__ + 2
+ + (i__ + 1) * h_dim1] != 0.f) {
+ result[rsub + 1] = ulpinv;
+ }
+/* L130: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (h__[i__ + 1 + i__ * h_dim1] != 0.f) {
+ if (h__[i__ + i__ * h_dim1] != h__[i__ + 1 + (i__
+ + 1) * h_dim1] || h__[i__ + (i__ + 1) *
+ h_dim1] == 0.f || r_sign(&c_b31, &h__[i__
+ + 1 + i__ * h_dim1]) == r_sign(&c_b31, &
+ h__[i__ + (i__ + 1) * h_dim1])) {
+ result[rsub + 1] = ulpinv;
+ }
+ }
+/* L140: */
+ }
+
+/* Do Tests (2) and (3) or Tests (8) and (9) */
+
+/* Computing MAX */
+ i__3 = 1, i__4 = (n << 1) * n;
+ lwork = max(i__3,i__4);
+ shst01_(&n, &c__1, &n, &a[a_offset], lda, &h__[h_offset],
+ lda, &vs[vs_offset], ldvs, &work[1], &lwork, res);
+ result[rsub + 2] = res[0];
+ result[rsub + 3] = res[1];
+
+/* Do Test (4) or Test (10) */
+
+ result[rsub + 4] = 0.f;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (h__[i__ + i__ * h_dim1] != wr[i__]) {
+ result[rsub + 4] = ulpinv;
+ }
+/* L150: */
+ }
+ if (n > 1) {
+ if (h__[h_dim1 + 2] == 0.f && wi[1] != 0.f) {
+ result[rsub + 4] = ulpinv;
+ }
+ if (h__[n + (n - 1) * h_dim1] == 0.f && wi[n] != 0.f)
+ {
+ result[rsub + 4] = ulpinv;
+ }
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (h__[i__ + 1 + i__ * h_dim1] != 0.f) {
+ tmp = sqrt((r__1 = h__[i__ + 1 + i__ * h_dim1],
+ dabs(r__1))) * sqrt((r__2 = h__[i__ + (
+ i__ + 1) * h_dim1], dabs(r__2)));
+/* Computing MAX */
+/* Computing MAX */
+ r__4 = ulp * tmp;
+ r__2 = result[rsub + 4], r__3 = (r__1 = wi[i__] -
+ tmp, dabs(r__1)) / dmax(r__4,unfl);
+ result[rsub + 4] = dmax(r__2,r__3);
+/* Computing MAX */
+/* Computing MAX */
+ r__4 = ulp * tmp;
+ r__2 = result[rsub + 4], r__3 = (r__1 = wi[i__ +
+ 1] + tmp, dabs(r__1)) / dmax(r__4,unfl);
+ result[rsub + 4] = dmax(r__2,r__3);
+ } else if (i__ > 1) {
+ if (h__[i__ + 1 + i__ * h_dim1] == 0.f && h__[i__
+ + (i__ - 1) * h_dim1] == 0.f && wi[i__] !=
+ 0.f) {
+ result[rsub + 4] = ulpinv;
+ }
+ }
+/* L160: */
+ }
+
+/* Do Test (5) or Test (11) */
+
+ slacpy_("F", &n, &n, &a[a_offset], lda, &ht[ht_offset],
+ lda);
+ sgees_("N", sort, (L_fp)sslect_, &n, &ht[ht_offset], lda,
+ &sdim, &wrt[1], &wit[1], &vs[vs_offset], ldvs, &
+ work[1], &nnwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != n + 2) {
+ result[rsub + 5] = ulpinv;
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "SGEES2", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+ result[rsub + 5] = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ if (h__[i__ + j * h_dim1] != ht[i__ + j * ht_dim1]
+ ) {
+ result[rsub + 5] = ulpinv;
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+
+/* Do Test (6) or Test (12) */
+
+ result[rsub + 6] = 0.f;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (wr[i__] != wrt[i__] || wi[i__] != wit[i__]) {
+ result[rsub + 6] = ulpinv;
+ }
+/* L190: */
+ }
+
+/* Do Test (13) */
+
+ if (isort == 1) {
+ result[13] = 0.f;
+ knteig = 0;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ r__1 = -wi[i__];
+ if (sslect_(&wr[i__], &wi[i__]) || sslect_(&wr[
+ i__], &r__1)) {
+ ++knteig;
+ }
+ if (i__ < n) {
+ r__1 = -wi[i__ + 1];
+ r__2 = -wi[i__];
+ if ((sslect_(&wr[i__ + 1], &wi[i__ + 1]) ||
+ sslect_(&wr[i__ + 1], &r__1)) && ! (
+ sslect_(&wr[i__], &wi[i__]) ||
+ sslect_(&wr[i__], &r__2)) && iinfo !=
+ n + 2) {
+ result[13] = ulpinv;
+ }
+ }
+/* L200: */
+ }
+ if (sdim != knteig) {
+ result[13] = ulpinv;
+ }
+ }
+
+/* L210: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L220:
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 13; ++j) {
+ if (result[j] >= 0.f) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L230: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___48.ciunit = *nounit;
+ s_wsfe(&io___48);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ e_wsfe();
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ e_wsfe();
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ e_wsfe();
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
+ e_wsfe();
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ e_wsfe();
+ ntestf = 2;
+ }
+
+ for (j = 1; j <= 13; ++j) {
+ if (result[j] >= *thresh) {
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ }
+/* L240: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+
+/* L250: */
+ }
+L260:
+ ;
+ }
+/* L270: */
+ }
+
+/* Summary */
+
+ slasum_(path, nounit, &nerrs, &ntestt);
+
+
+
+ return 0;
+
+/* End of SDRVES */
+
+} /* sdrves_ */
diff --git a/TESTING/EIG/sdrvev.c b/TESTING/EIG/sdrvev.c
new file mode 100644
index 0000000..c2169a0
--- /dev/null
+++ b/TESTING/EIG/sdrvev.c
@@ -0,0 +1,1110 @@
+/* sdrvev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b17 = 0.f;
+static integer c__0 = 0;
+static real c_b31 = 1.f;
+static integer c__4 = 4;
+static integer c__6 = 6;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int sdrvev_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, integer *nounit, real *
+ a, integer *lda, real *h__, real *wr, real *wi, real *wr1, real *wi1,
+ real *vl, integer *ldvl, real *vr, integer *ldvr, real *lre, integer *
+ ldlre, real *result, real *work, integer *nwork, integer *iwork,
+ integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
+ static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
+ static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9993[] = "(\002 SDRVEV: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(/1x,a3,\002 -- Real Eigenvalue-Eigenvector De"
+ "composition\002,\002 Driver\002,/\002 Matrix types (see SDRVEV f"
+ "or details): \002)";
+ static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 \002,\002 5=Diagonal: geom"
+ "etr. spaced entries.\002,/\002 2=Identity matrix. "
+ " \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
+ "/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
+ " 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
+ "l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
+ "ll, evenly spaced.\002)";
+ static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
+ " 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
+ "l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
+ "d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
+ "red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
+ "vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
+ " 12=Well-cond., random complex \002,6x,\002 \002,\002 17=Ill-c"
+ "ond., large rand. complx \002,/\002 13=Ill-condi\002,\002tioned,"
+ " evenly spaced. \002,\002 18=Ill-cond., small rand.\002,\002"
+ " complx \002)";
+ static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
+ " \002,\002 21=Matrix \002,\002with small random entries.\002,"
+ "/\002 20=Matrix with large ran\002,\002dom entries. \002,/)";
+ static char fmt_9995[] = "(\002 Tests performed with test threshold ="
+ "\002,f8.2,//\002 1 = | A VR - VR W | / ( n |A| ulp ) \002,/\002 "
+ "2 = | transpose(A) VL - VL W | / ( n |A| ulp ) \002,/\002 3 = | "
+ "|VR(i)| - 1 | / ulp \002,/\002 4 = | |VL(i)| - 1 | / ulp \002,"
+ "/\002 5 = 0 if W same no matter if VR or VL computed,\002,\002 1"
+ "/ulp otherwise\002,/\002 6 = 0 if VR same no matter if VL comput"
+ "ed,\002,\002 1/ulp otherwise\002,/\002 7 = 0 if VL same no matt"
+ "er if VR computed,\002,\002 1/ulp otherwise\002,/)";
+ static char fmt_9994[] = "(\002 N=\002,i5,\002, IWK=\002,i2,\002, seed"
+ "=\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)="
+ "\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1,
+ vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4, r__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer j, n, jj;
+ real dum[1], res[2];
+ integer iwk;
+ real ulp, vmx, cond;
+ integer jcol;
+ char path[3];
+ integer nmax;
+ real unfl, ovfl, tnrm, vrmx, vtst;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ logical badnn;
+ integer nfail, imode, iinfo;
+ real conds;
+ extern /* Subroutine */ int sget22_(char *, char *, char *, integer *,
+ real *, integer *, real *, integer *, real *, real *, real *,
+ real *), sgeev_(char *, char *, integer *,
+ real *, integer *, real *, real *, real *, integer *, real *,
+ integer *, real *, integer *, integer *);
+ real anorm;
+ integer jsize, nerrs, itype, jtype, ntest;
+ real rtulp;
+ extern doublereal slapy2_(real *, real *);
+ extern /* Subroutine */ int slabad_(real *, real *);
+ char adumma[1*1];
+ extern doublereal slamch_(char *);
+ integer idumma[1];
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int slatme_(integer *, char *, integer *, real *,
+ integer *, real *, real *, char *, char *, char *, char *, real *,
+ integer *, real *, integer *, integer *, real *, real *, integer
+ *, real *, integer *),
+ slacpy_(char *, integer *, integer *, real *, integer *, real *,
+ integer *), slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *), slatmr_(integer *, integer *,
+ char *, integer *, char *, real *, integer *, real *, real *,
+ char *, char *, real *, integer *, real *, real *, integer *,
+ real *, char *, integer *, integer *, integer *, real *, real *,
+ char *, real *, integer *, integer *, integer *);
+ integer ntestf;
+ extern /* Subroutine */ int slasum_(char *, integer *, integer *, integer
+ *), slatms_(integer *, integer *, char *, integer *, char
+ *, real *, integer *, real *, real *, integer *, integer *, char *
+, real *, integer *, real *, integer *);
+ real ulpinv;
+ integer nnwork;
+ real rtulpi;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___32 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVEV checks the nonsymmetric eigenvalue problem driver SGEEV. */
+
+/* When SDRVEV is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 7 */
+/* tests will be performed: */
+
+/* (1) | A * VR - VR * W | / ( n |A| ulp ) */
+
+/* Here VR is the matrix of unit right eigenvectors. */
+/* W is a block diagonal matrix, with a 1x1 block for each */
+/* real eigenvalue and a 2x2 block for each complex conjugate */
+/* pair. If eigenvalues j and j+1 are a complex conjugate pair, */
+/* so WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the */
+/* 2 x 2 block corresponding to the pair will be: */
+
+/* ( wr wi ) */
+/* ( -wi wr ) */
+
+/* Such a block multiplying an n x 2 matrix ( ur ui ) on the */
+/* right will be the same as multiplying ur + i*ui by wr + i*wi. */
+
+/* (2) | A**H * VL - VL * W**H | / ( n |A| ulp ) */
+
+/* Here VL is the matrix of unit left eigenvectors, A**H is the */
+/* conjugate transpose of A, and W is as above. */
+
+/* (3) | |VR(i)| - 1 | / ulp and whether largest component real */
+
+/* VR(i) denotes the i-th column of VR. */
+
+/* (4) | |VL(i)| - 1 | / ulp and whether largest component real */
+
+/* VL(i) denotes the i-th column of VL. */
+
+/* (5) W(full) = W(partial) */
+
+/* W(full) denotes the eigenvalues computed when both VR and VL */
+/* are also computed, and W(partial) denotes the eigenvalues */
+/* computed when only W, only W and VR, or only W and VL are */
+/* computed. */
+
+/* (6) VR(full) = VR(partial) */
+
+/* VR(full) denotes the right eigenvectors computed when both VR */
+/* and VL are computed, and VR(partial) denotes the result */
+/* when only VR is computed. */
+
+/* (7) VL(full) = VL(partial) */
+
+/* VL(full) denotes the left eigenvectors computed when both VR */
+/* and VL are also computed, and VL(partial) denotes the result */
+/* when only VL is computed. */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
+
+/* (4) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (5) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (7) Same as (4), but multiplied by a constant near */
+/* the overflow threshold */
+/* (8) Same as (4), but multiplied by a constant near */
+/* the underflow threshold */
+
+/* (9) A matrix of the form U' T U, where U is orthogonal and */
+/* T has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (10) A matrix of the form U' T U, where U is orthogonal and */
+/* T has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (11) A matrix of the form U' T U, where U is orthogonal and */
+/* T has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (12) A matrix of the form U' T U, where U is orthogonal and */
+/* T has real or complex conjugate paired eigenvalues randomly */
+/* chosen from ( ULP, 1 ) and random O(1) entries in the upper */
+/* triangle. */
+
+/* (13) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
+/* with random signs on the diagonal and random O(1) entries */
+/* in the upper triangle. */
+
+/* (14) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has geometrically spaced entries */
+/* 1, ..., ULP with random signs on the diagonal and random */
+/* O(1) entries in the upper triangle. */
+
+/* (15) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
+/* with random signs on the diagonal and random O(1) entries */
+/* in the upper triangle. */
+
+/* (16) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has real or complex conjugate paired */
+/* eigenvalues randomly chosen from ( ULP, 1 ) and random */
+/* O(1) entries in the upper triangle. */
+
+/* (17) Same as (16), but multiplied by a constant */
+/* near the overflow threshold */
+/* (18) Same as (16), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* (19) Nonsymmetric matrix with random entries chosen from (-1,1). */
+/* If N is at least 4, all entries in first two rows and last */
+/* row, and first column and last two columns are zero. */
+/* (20) Same as (19), but multiplied by a constant */
+/* near the overflow threshold */
+/* (21) Same as (19), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* Arguments */
+/* ========== */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* SDRVEV does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, SDRVEV */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to SDRVEV to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* A (workspace) REAL array, dimension (LDA, max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, and H. LDA must be at */
+/* least 1 and at least max(NN). */
+
+/* H (workspace) REAL array, dimension (LDA, max(NN)) */
+/* Another copy of the test matrix A, modified by SGEEV. */
+
+/* WR (workspace) REAL array, dimension (max(NN)) */
+/* WI (workspace) REAL array, dimension (max(NN)) */
+/* The real and imaginary parts of the eigenvalues of A. */
+/* On exit, WR + WI*i are the eigenvalues of the matrix in A. */
+
+/* WR1 (workspace) REAL array, dimension (max(NN)) */
+/* WI1 (workspace) REAL array, dimension (max(NN)) */
+/* Like WR, WI, these arrays contain the eigenvalues of A, */
+/* but those computed when SGEEV only computes a partial */
+/* eigendecomposition, i.e. not the eigenvalues and left */
+/* and right eigenvectors. */
+
+/* VL (workspace) REAL array, dimension (LDVL, max(NN)) */
+/* VL holds the computed left eigenvectors. */
+
+/* LDVL (input) INTEGER */
+/* Leading dimension of VL. Must be at least max(1,max(NN)). */
+
+/* VR (workspace) REAL array, dimension (LDVR, max(NN)) */
+/* VR holds the computed right eigenvectors. */
+
+/* LDVR (input) INTEGER */
+/* Leading dimension of VR. Must be at least max(1,max(NN)). */
+
+/* LRE (workspace) REAL array, dimension (LDLRE,max(NN)) */
+/* LRE holds the computed right or left eigenvectors. */
+
+/* LDLRE (input) INTEGER */
+/* Leading dimension of LRE. Must be at least max(1,max(NN)). */
+
+/* RESULT (output) REAL array, dimension (7) */
+/* The values computed by the seven tests described above. */
+/* The values are currently limited to 1/ulp, to avoid overflow. */
+
+/* WORK (workspace) REAL array, dimension (NWORK) */
+
+/* NWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 5*NN(j)+2*NN(j)**2 for all j. */
+
+/* IWORK (workspace) INTEGER array, dimension (max(NN)) */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -6: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -16: LDVL < 1 or LDVL < NMAX, where NMAX is max( NN(j) ). */
+/* -18: LDVR < 1 or LDVR < NMAX, where NMAX is max( NN(j) ). */
+/* -20: LDLRE < 1 or LDLRE < NMAX, where NMAX is max( NN(j) ). */
+/* -23: NWORK too small. */
+/* If SLATMR, SLATMS, SLATME or SGEEV returns an error code, */
+/* the absolute value of it is returned. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NMAX Largest value in NN. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* COND, CONDS, */
+/* IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTULP, RTULPI Square roots of the previous 4 values. */
+
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+/* KCONDS(j) Selectw whether CONDS is to be 1 or */
+/* 1/sqrt(ulp). (0 means irrelevant.) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --wr;
+ --wi;
+ --wr1;
+ --wi1;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ lre_dim1 = *ldlre;
+ lre_offset = 1 + lre_dim1;
+ lre -= lre_offset;
+ --result;
+ --work;
+ --iwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "EV", (ftnlen)2, (ftnlen)2);
+
+/* Check for errors */
+
+ ntestt = 0;
+ ntestf = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+ nmax = 0;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.f) {
+ *info = -6;
+ } else if (*nounit <= 0) {
+ *info = -7;
+ } else if (*lda < 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldvl < 1 || *ldvl < nmax) {
+ *info = -16;
+ } else if (*ldvr < 1 || *ldvr < nmax) {
+ *info = -18;
+ } else if (*ldlre < 1 || *ldlre < nmax) {
+ *info = -20;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = nmax;
+ if (nmax * 5 + (i__1 * i__1 << 1) > *nwork) {
+ *info = -23;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SDRVEV", &i__1);
+ return 0;
+ }
+
+/* Quick return if nothing to do */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ slabad_(&unfl, &ovfl);
+ ulp = slamch_("Precision");
+ ulpinv = 1.f / ulp;
+ rtulp = sqrt(ulp);
+ rtulpi = 1.f / rtulp;
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L260;
+ }
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KCONDS KMODE KTYPE */
+/* =1 O(1) 1 clustered 1 zero */
+/* =2 large large clustered 2 identity */
+/* =3 small exponential Jordan */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random general, w/ eigenvalues */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 random general */
+/* =10 random triangular */
+
+ if (mtypes > 21) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L30;
+ case 2: goto L40;
+ case 3: goto L50;
+ }
+
+L30:
+ anorm = 1.f;
+ goto L60;
+
+L40:
+ anorm = ovfl * ulp;
+ goto L60;
+
+L50:
+ anorm = unfl * ulpinv;
+ goto L60;
+
+L60:
+
+ slaset_("Full", lda, &n, &c_b17, &c_b17, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+/* L70: */
+ }
+
+ } else if (itype == 3) {
+
+/* Jordan Block */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+ if (jcol > 1) {
+ a[jcol + (jcol - 1) * a_dim1] = 1.f;
+ }
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 6) {
+
+/* General, eigenvalues specified */
+
+ if (kconds[jtype - 1] == 1) {
+ conds = 1.f;
+ } else if (kconds[jtype - 1] == 2) {
+ conds = rtulpi;
+ } else {
+ conds = 0.f;
+ }
+
+ *(unsigned char *)&adumma[0] = ' ';
+ slatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b31,
+ adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
+ n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
+ &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b31,
+ &c_b31, "T", "N", &work[n + 1], &c__1, &c_b31, &work[(
+ n << 1) + 1], &c__1, &c_b31, "N", idumma, &c__0, &
+ c__0, &c_b17, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b31,
+ &c_b31, "T", "N", &work[n + 1], &c__1, &c_b31, &work[(
+ n << 1) + 1], &c__1, &c_b31, "N", idumma, &n, &n, &
+ c_b17, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* General, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b31,
+ &c_b31, "T", "N", &work[n + 1], &c__1, &c_b31, &work[(
+ n << 1) + 1], &c__1, &c_b31, "N", idumma, &n, &n, &
+ c_b17, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+ if (n >= 4) {
+ slaset_("Full", &c__2, &n, &c_b17, &c_b17, &a[a_offset],
+ lda);
+ i__3 = n - 3;
+ slaset_("Full", &i__3, &c__1, &c_b17, &c_b17, &a[a_dim1 +
+ 3], lda);
+ i__3 = n - 3;
+ slaset_("Full", &i__3, &c__2, &c_b17, &c_b17, &a[(n - 1) *
+ a_dim1 + 3], lda);
+ slaset_("Full", &c__1, &n, &c_b17, &c_b17, &a[n + a_dim1],
+ lda);
+ }
+
+ } else if (itype == 10) {
+
+/* Triangular, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b31,
+ &c_b31, "T", "N", &work[n + 1], &c__1, &c_b31, &work[(
+ n << 1) + 1], &c__1, &c_b31, "N", idumma, &n, &c__0, &
+ c_b17, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___32.ciunit = *nounit;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+/* Test for minimal and generous workspace */
+
+ for (iwk = 1; iwk <= 2; ++iwk) {
+ if (iwk == 1) {
+ nnwork = n << 2;
+ } else {
+/* Computing 2nd power */
+ i__3 = n;
+ nnwork = n * 5 + (i__3 * i__3 << 1);
+ }
+ nnwork = max(nnwork,1);
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 7; ++j) {
+ result[j] = -1.f;
+/* L100: */
+ }
+
+/* Compute eigenvalues and eigenvectors, and test them */
+
+ slacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+ sgeev_("V", "V", &n, &h__[h_offset], lda, &wr[1], &wi[1], &vl[
+ vl_offset], ldvl, &vr[vr_offset], ldvr, &work[1], &
+ nnwork, &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___35.ciunit = *nounit;
+ s_wsfe(&io___35);
+ do_fio(&c__1, "SGEEV1", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Do Test (1) */
+
+ sget22_("N", "N", "N", &n, &a[a_offset], lda, &vr[vr_offset],
+ ldvr, &wr[1], &wi[1], &work[1], res);
+ result[1] = res[0];
+
+/* Do Test (2) */
+
+ sget22_("T", "N", "T", &n, &a[a_offset], lda, &vl[vl_offset],
+ ldvl, &wr[1], &wi[1], &work[1], res);
+ result[2] = res[0];
+
+/* Do Test (3) */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ tnrm = 1.f;
+ if (wi[j] == 0.f) {
+ tnrm = snrm2_(&n, &vr[j * vr_dim1 + 1], &c__1);
+ } else if (wi[j] > 0.f) {
+ r__1 = snrm2_(&n, &vr[j * vr_dim1 + 1], &c__1);
+ r__2 = snrm2_(&n, &vr[(j + 1) * vr_dim1 + 1], &c__1);
+ tnrm = slapy2_(&r__1, &r__2);
+ }
+/* Computing MAX */
+/* Computing MIN */
+ r__4 = ulpinv, r__5 = (r__1 = tnrm - 1.f, dabs(r__1)) /
+ ulp;
+ r__2 = result[3], r__3 = dmin(r__4,r__5);
+ result[3] = dmax(r__2,r__3);
+ if (wi[j] > 0.f) {
+ vmx = 0.f;
+ vrmx = 0.f;
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ vtst = slapy2_(&vr[jj + j * vr_dim1], &vr[jj + (j
+ + 1) * vr_dim1]);
+ if (vtst > vmx) {
+ vmx = vtst;
+ }
+ if (vr[jj + (j + 1) * vr_dim1] == 0.f && (r__1 =
+ vr[jj + j * vr_dim1], dabs(r__1)) > vrmx)
+ {
+ vrmx = (r__2 = vr[jj + j * vr_dim1], dabs(
+ r__2));
+ }
+/* L110: */
+ }
+ if (vrmx / vmx < 1.f - ulp * 2.f) {
+ result[3] = ulpinv;
+ }
+ }
+/* L120: */
+ }
+
+/* Do Test (4) */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ tnrm = 1.f;
+ if (wi[j] == 0.f) {
+ tnrm = snrm2_(&n, &vl[j * vl_dim1 + 1], &c__1);
+ } else if (wi[j] > 0.f) {
+ r__1 = snrm2_(&n, &vl[j * vl_dim1 + 1], &c__1);
+ r__2 = snrm2_(&n, &vl[(j + 1) * vl_dim1 + 1], &c__1);
+ tnrm = slapy2_(&r__1, &r__2);
+ }
+/* Computing MAX */
+/* Computing MIN */
+ r__4 = ulpinv, r__5 = (r__1 = tnrm - 1.f, dabs(r__1)) /
+ ulp;
+ r__2 = result[4], r__3 = dmin(r__4,r__5);
+ result[4] = dmax(r__2,r__3);
+ if (wi[j] > 0.f) {
+ vmx = 0.f;
+ vrmx = 0.f;
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ vtst = slapy2_(&vl[jj + j * vl_dim1], &vl[jj + (j
+ + 1) * vl_dim1]);
+ if (vtst > vmx) {
+ vmx = vtst;
+ }
+ if (vl[jj + (j + 1) * vl_dim1] == 0.f && (r__1 =
+ vl[jj + j * vl_dim1], dabs(r__1)) > vrmx)
+ {
+ vrmx = (r__2 = vl[jj + j * vl_dim1], dabs(
+ r__2));
+ }
+/* L130: */
+ }
+ if (vrmx / vmx < 1.f - ulp * 2.f) {
+ result[4] = ulpinv;
+ }
+ }
+/* L140: */
+ }
+
+/* Compute eigenvalues only, and test them */
+
+ slacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+ sgeev_("N", "N", &n, &h__[h_offset], lda, &wr1[1], &wi1[1],
+ dum, &c__1, dum, &c__1, &work[1], &nnwork, &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "SGEEV2", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Do Test (5) */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ if (wr[j] != wr1[j] || wi[j] != wi1[j]) {
+ result[5] = ulpinv;
+ }
+/* L150: */
+ }
+
+/* Compute eigenvalues and right eigenvectors, and test them */
+
+ slacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+ sgeev_("N", "V", &n, &h__[h_offset], lda, &wr1[1], &wi1[1],
+ dum, &c__1, &lre[lre_offset], ldlre, &work[1], &
+ nnwork, &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "SGEEV3", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Do Test (5) again */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ if (wr[j] != wr1[j] || wi[j] != wi1[j]) {
+ result[5] = ulpinv;
+ }
+/* L160: */
+ }
+
+/* Do Test (6) */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ if (vr[j + jj * vr_dim1] != lre[j + jj * lre_dim1]) {
+ result[6] = ulpinv;
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+
+/* Compute eigenvalues and left eigenvectors, and test them */
+
+ slacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+ sgeev_("V", "N", &n, &h__[h_offset], lda, &wr1[1], &wi1[1], &
+ lre[lre_offset], ldlre, dum, &c__1, &work[1], &nnwork,
+ &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "SGEEV4", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Do Test (5) again */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ if (wr[j] != wr1[j] || wi[j] != wi1[j]) {
+ result[5] = ulpinv;
+ }
+/* L190: */
+ }
+
+/* Do Test (7) */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ if (vl[j + jj * vl_dim1] != lre[j + jj * lre_dim1]) {
+ result[7] = ulpinv;
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L220:
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 7; ++j) {
+ if (result[j] >= 0.f) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L230: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___48.ciunit = *nounit;
+ s_wsfe(&io___48);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ e_wsfe();
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ e_wsfe();
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ e_wsfe();
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
+ e_wsfe();
+ ntestf = 2;
+ }
+
+ for (j = 1; j <= 7; ++j) {
+ if (result[j] >= *thresh) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ }
+/* L240: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+
+/* L250: */
+ }
+L260:
+ ;
+ }
+/* L270: */
+ }
+
+/* Summary */
+
+ slasum_(path, nounit, &nerrs, &ntestt);
+
+
+
+ return 0;
+
+/* End of SDRVEV */
+
+} /* sdrvev_ */
diff --git a/TESTING/EIG/sdrvgg.c b/TESTING/EIG/sdrvgg.c
new file mode 100644
index 0000000..bea3a04
--- /dev/null
+++ b/TESTING/EIG/sdrvgg.c
@@ -0,0 +1,1187 @@
+/* sdrvgg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__4 = 4;
+static real c_b36 = 0.f;
+static integer c__2 = 2;
+static real c_b42 = 1.f;
+static integer c__3 = 3;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int sdrvgg_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, real *thrshn, integer *
+ nounit, real *a, integer *lda, real *b, real *s, real *t, real *s2,
+ real *t2, real *q, integer *ldq, real *z__, real *alphr1, real *
+ alphi1, real *beta1, real *alphr2, real *alphi2, real *beta2, real *
+ vl, real *vr, real *work, integer *lwork, real *result, integer *info)
+{
+ /* Initialized data */
+
+ static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
+ 2,2,2,3 };
+ static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
+ 2,3,2,1 };
+ static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
+ 1,1,1,1 };
+ static integer iasign[26] = { 0,0,0,0,0,0,2,0,2,2,0,0,2,2,2,0,2,0,0,0,2,2,
+ 2,2,2,0 };
+ static integer ibsign[26] = { 0,0,0,0,0,0,0,2,0,0,2,2,0,0,2,0,2,0,0,0,0,0,
+ 0,0,0,0 };
+ static integer kz1[6] = { 0,1,2,1,3,3 };
+ static integer kz2[6] = { 0,0,1,2,1,1 };
+ static integer kadd[6] = { 0,0,0,0,3,2 };
+ static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
+ 4,4,4,0 };
+ static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
+ 8,8,8,8,8,0 };
+ static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
+ 3,3,3,1 };
+ static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
+ 4,4,4,1 };
+ static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
+ 3,3,2,1 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 SDRVGG: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9997[] = "(\002 SDRVGG: SGET53 returned INFO=\002,i1,"
+ "\002 for eigenvalue \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JT"
+ "YPE=\002,i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9996[] = "(\002 SDRVGG: S not in Schur form at eigenvalu"
+ "e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, "
+ "ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 SDRVGG: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
+ "i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9995[] = "(/1x,a3,\002 -- Real Generalized eigenvalue pr"
+ "oblem driver\002)";
+ static char fmt_9994[] = "(\002 Matrix types (see SDRVGG for details):"
+ " \002)";
+ static char fmt_9993[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
+ "osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
+ ") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
+ "onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
+ "I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
+ "arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
+ "(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
+ "=(D, reversed D)\002)";
+ static char fmt_9992[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
+ "atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
+ " 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
+ "ha&beta \002,\002 20=arithmetic alpha, beta=0,"
+ "1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
+ "=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
+ "/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
+ "l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
+ ".\002)";
+ static char fmt_9991[] = "(/\002 Tests performed: (S is Schur, T is tri"
+ "angular, \002,\002Q and Z are \002,a,\002,\002,/20x,\002l and r "
+ "are the appropriate left and right\002,/19x,\002eigenvectors, re"
+ "sp., a is alpha, b is beta, and\002,/19x,a,\002 means \002,a,"
+ "\002.)\002,/\002 1 = | A - Q S Z\002,a,\002 | / ( |A| n ulp ) "
+ " 2 = | B - Q T Z\002,a,\002 | / ( |B| n ulp )\002,/\002 3 = | "
+ "I - QQ\002,a,\002 | / ( n ulp ) 4 = | I - ZZ\002,a"
+ ",\002 | / ( n ulp )\002,/\002 5 = difference between (alpha,beta"
+ ") and diagonals of\002,\002 (S,T)\002,/\002 6 = max | ( b A - a "
+ "B )\002,a,\002 l | / const. 7 = max | ( b A - a B ) r | / cons"
+ "t.\002,/1x)";
+ static char fmt_9990[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
+ ",0p,f8.2)";
+ static char fmt_9989[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
+ ",1p,e10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1,
+ s_offset, s2_dim1, s2_offset, t_dim1, t_offset, t2_dim1,
+ t2_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, z_dim1,
+ z_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10;
+
+ /* Builtin functions */
+ double r_sign(real *, real *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer j, n, i1, n1, jc, nb, in, jr, ns, nbz;
+ real ulp;
+ integer iadd, nmax;
+ real temp1, temp2;
+ logical badnn;
+ real dumma[4];
+ integer iinfo;
+ real rmagn[4];
+ extern /* Subroutine */ int sgegs_(char *, char *, integer *, real *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ integer *, real *, integer *, real *, integer *, integer *), sget51_(integer *, integer *, real *, integer *,
+ real *, integer *, real *, integer *, real *, integer *, real *,
+ real *), sget52_(logical *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ real *), sgegv_(char *, char *, integer *, real *, integer *,
+ real *, integer *, real *, real *, real *, real *, integer *,
+ real *, integer *, real *, integer *, integer *),
+ sget53_(real *, integer *, real *, integer *, real *, real *,
+ real *, real *, integer *);
+ integer nmats, jsize, nerrs, jtype, ntest;
+ extern /* Subroutine */ int slatm4_(integer *, integer *, integer *,
+ integer *, integer *, real *, real *, real *, integer *, integer *
+, real *, integer *);
+ logical ilabad;
+ extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *), slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ real safmin;
+ integer ioldsd[4];
+ real safmax;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *,
+ real *);
+ extern doublereal slarnd_(integer *, integer *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *), xerbla_(char *, integer *),
+ slacpy_(char *, integer *, integer *, real *, integer *, real *,
+ integer *), slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *);
+ real ulpinv;
+ integer lwkopt, mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9989, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVGG checks the nonsymmetric generalized eigenvalue driver */
+/* routines. */
+/* T T T */
+/* SGEGS factors A and B as Q S Z and Q T Z , where means */
+/* transpose, T is upper triangular, S is in generalized Schur form */
+/* (block upper triangular, with 1x1 and 2x2 blocks on the diagonal, */
+/* the 2x2 blocks corresponding to complex conjugate pairs of */
+/* generalized eigenvalues), and Q and Z are orthogonal. It also */
+/* computes the generalized eigenvalues (alpha(1),beta(1)), ..., */
+/* (alpha(n),beta(n)), where alpha(j)=S(j,j) and beta(j)=P(j,j) -- */
+/* thus, w(j) = alpha(j)/beta(j) is a root of the generalized */
+/* eigenvalue problem */
+
+/* det( A - w(j) B ) = 0 */
+
+/* and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent */
+/* problem */
+
+/* det( m(j) A - B ) = 0 */
+
+/* SGEGV computes the generalized eigenvalues (alpha(1),beta(1)), ..., */
+/* (alpha(n),beta(n)), the matrix L whose columns contain the */
+/* generalized left eigenvectors l, and the matrix R whose columns */
+/* contain the generalized right eigenvectors r for the pair (A,B). */
+
+/* When SDRVGG is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 7 */
+/* tests will be performed and compared with the threshhold THRESH: */
+
+/* Results from SGEGS: */
+
+/* T */
+/* (1) | A - Q S Z | / ( |A| n ulp ) */
+
+/* T */
+/* (2) | B - Q T Z | / ( |B| n ulp ) */
+
+/* T */
+/* (3) | I - QQ | / ( n ulp ) */
+
+/* T */
+/* (4) | I - ZZ | / ( n ulp ) */
+
+/* (5) maximum over j of D(j) where: */
+
+/* if alpha(j) is real: */
+/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
+/* D(j) = ------------------------ + ----------------------- */
+/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
+
+/* if alpha(j) is complex: */
+/* | det( s S - w T ) | */
+/* D(j) = --------------------------------------------------- */
+/* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T ) */
+
+/* and S and T are here the 2 x 2 diagonal blocks of S and T */
+/* corresponding to the j-th eigenvalue. */
+
+/* Results from SGEGV: */
+
+/* (6) max over all left eigenvalue/-vector pairs (beta/alpha,l) of */
+
+/* | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) ) */
+
+/* where l**H is the conjugate tranpose of l. */
+
+/* (7) max over all right eigenvalue/-vector pairs (beta/alpha,r) of */
+
+/* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) ) */
+
+/* Test Matrices */
+/* ---- -------- */
+
+/* The sizes of the test matrices are specified by an array */
+/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
+/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) ( 0, 0 ) (a pair of zero matrices) */
+
+/* (2) ( I, 0 ) (an identity and a zero matrix) */
+
+/* (3) ( 0, I ) (an identity and a zero matrix) */
+
+/* (4) ( I, I ) (a pair of identity matrices) */
+
+/* t t */
+/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
+
+/* t ( I 0 ) */
+/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
+/* ( 0 I ) ( 0 J ) */
+/* and I is a k x k identity and J a (k+1)x(k+1) */
+/* Jordan block; k=(N-1)/2 */
+
+/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
+/* matrix with those diagonal entries.) */
+/* (8) ( I, D ) */
+
+/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
+
+/* (10) ( small*D, big*I ) */
+
+/* (11) ( big*I, small*D ) */
+
+/* (12) ( small*I, big*D ) */
+
+/* (13) ( big*D, big*I ) */
+
+/* (14) ( small*D, small*I ) */
+
+/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
+/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
+/* t t */
+/* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. */
+
+/* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices */
+/* with random O(1) entries above the diagonal */
+/* and diagonal entries diag(T1) = */
+/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
+/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
+
+/* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
+/* s = machine precision. */
+
+/* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
+
+/* N-5 */
+/* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+
+/* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+/* where r1,..., r(N-4) are random. */
+
+/* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular */
+/* matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* SDRVGG does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, SDRVGG */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to SDRVGG to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error is */
+/* scaled to be O(1), so THRESH should be a reasonably small */
+/* multiple of 1, e.g., 10 or 100. In particular, it should */
+/* not depend on the precision (single vs. double) or the size */
+/* of the matrix. It must be at least zero. */
+
+/* THRSHN (input) REAL */
+/* Threshhold for reporting eigenvector normalization error. */
+/* If the normalization of any eigenvector differs from 1 by */
+/* more than THRSHN*ulp, then a special error message will be */
+/* printed. (This is handled separately from the other tests, */
+/* since only a compiler or programming error should cause an */
+/* error message, at least if THRSHN is at least 5--10.) */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace) REAL array, dimension */
+/* (LDA, max(NN)) */
+/* Used to hold the original A matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, S, T, S2, and T2. */
+/* It must be at least 1 and at least max( NN ). */
+
+/* B (input/workspace) REAL array, dimension */
+/* (LDA, max(NN)) */
+/* Used to hold the original B matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* S (workspace) REAL array, dimension (LDA, max(NN)) */
+/* The Schur form matrix computed from A by SGEGS. On exit, S */
+/* contains the Schur form matrix corresponding to the matrix */
+/* in A. */
+
+/* T (workspace) REAL array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from B by SGEGS. */
+
+/* S2 (workspace) REAL array, dimension (LDA, max(NN)) */
+/* The matrix computed from A by SGEGV. This will be the */
+/* Schur form of some matrix related to A, but will not, in */
+/* general, be the same as S. */
+
+/* T2 (workspace) REAL array, dimension (LDA, max(NN)) */
+/* The matrix computed from B by SGEGV. This will be the */
+/* Schur form of some matrix related to B, but will not, in */
+/* general, be the same as T. */
+
+/* Q (workspace) REAL array, dimension (LDQ, max(NN)) */
+/* The (left) orthogonal matrix computed by SGEGS. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of Q, Z, VL, and VR. It must */
+/* be at least 1 and at least max( NN ). */
+
+/* Z (workspace) REAL array of */
+/* dimension( LDQ, max(NN) ) */
+/* The (right) orthogonal matrix computed by SGEGS. */
+
+/* ALPHR1 (workspace) REAL array, dimension (max(NN)) */
+/* ALPHI1 (workspace) REAL array, dimension (max(NN)) */
+/* BETA1 (workspace) REAL array, dimension (max(NN)) */
+
+/* The generalized eigenvalues of (A,B) computed by SGEGS. */
+/* ( ALPHR1(k)+ALPHI1(k)*i ) / BETA1(k) is the k-th */
+/* generalized eigenvalue of the matrices in A and B. */
+
+/* ALPHR2 (workspace) REAL array, dimension (max(NN)) */
+/* ALPHI2 (workspace) REAL array, dimension (max(NN)) */
+/* BETA2 (workspace) REAL array, dimension (max(NN)) */
+
+/* The generalized eigenvalues of (A,B) computed by SGEGV. */
+/* ( ALPHR2(k)+ALPHI2(k)*i ) / BETA2(k) is the k-th */
+/* generalized eigenvalue of the matrices in A and B. */
+
+/* VL (workspace) REAL array, dimension (LDQ, max(NN)) */
+/* The (block lower triangular) left eigenvector matrix for */
+/* the matrices in A and B. (See STGEVC for the format.) */
+
+/* VR (workspace) REAL array, dimension (LDQ, max(NN)) */
+/* The (block upper triangular) right eigenvector matrix for */
+/* the matrices in A and B. (See STGEVC for the format.) */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 2*N + MAX( 6*N, N*(NB+1), (k+1)*(2*k+N+1) ), where */
+/* "k" is the sum of the blocksize and number-of-shifts for */
+/* SHGEQZ, and NB is the greatest of the blocksizes for */
+/* SGEQRF, SORMQR, and SORGQR. (The blocksizes and the */
+/* number-of-shifts are retrieved through calls to ILAENV.) */
+
+/* RESULT (output) REAL array, dimension (15) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: A routine returned an error code. INFO is the */
+/* absolute value of the INFO value returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ t2_dim1 = *lda;
+ t2_offset = 1 + t2_dim1;
+ t2 -= t2_offset;
+ s2_dim1 = *lda;
+ s2_offset = 1 + s2_dim1;
+ s2 -= s2_offset;
+ t_dim1 = *lda;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ s_dim1 = *lda;
+ s_offset = 1 + s_dim1;
+ s -= s_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ vr_dim1 = *ldq;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ vl_dim1 = *ldq;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ z_dim1 = *ldq;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --alphr1;
+ --alphi1;
+ --beta1;
+ --alphr2;
+ --alphi2;
+ --beta2;
+ --work;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Maximum blocksize and shift -- we assume that blocksize and number */
+/* of shifts are monotone increasing functions of N. */
+
+/* Computing MAX */
+ i__1 = 1, i__2 = ilaenv_(&c__1, "SGEQRF", " ", &nmax, &nmax, &c_n1, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
+ c__1, "SORMQR", "LT", &nmax, &nmax, &nmax, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&c__1, "SORGQR",
+ " ", &nmax, &nmax, &nmax, &c_n1);
+ nb = max(i__1,i__2);
+ nbz = ilaenv_(&c__1, "SHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0);
+ ns = ilaenv_(&c__4, "SHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0);
+ i1 = nbz + ns;
+/* Computing MAX */
+ i__1 = nmax * 6, i__2 = nmax * (nb + 1), i__1 = max(i__1,i__2), i__2 = ((
+ i1 << 1) + nmax + 1) * (i1 + 1);
+ lwkopt = (nmax << 1) + max(i__1,i__2);
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.f) {
+ *info = -6;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -10;
+ } else if (*ldq <= 1 || *ldq < nmax) {
+ *info = -19;
+ } else if (lwkopt > *lwork) {
+ *info = -30;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SDRVGG", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+ safmin = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ safmin /= ulp;
+ safmax = 1.f / safmin;
+ slabad_(&safmin, &safmax);
+ ulpinv = 1.f / ulp;
+
+/* The values RMAGN(2:3) depend on N, see below. */
+
+ rmagn[0] = 0.f;
+ rmagn[1] = 1.f;
+
+/* Loop over sizes, types */
+
+ ntestt = 0;
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ n1 = max(1,n);
+ rmagn[2] = safmax * ulp / (real) n1;
+ rmagn[3] = safmin * ulpinv * n1;
+
+ if (*nsizes != 1) {
+ mtypes = min(26,*ntypes);
+ } else {
+ mtypes = min(27,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L160;
+ }
+ ++nmats;
+ ntest = 0;
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 15; ++j) {
+ result[j] = 0.f;
+/* L30: */
+ }
+
+/* Compute A and B */
+
+/* Description of control parameters: */
+
+/* KCLASS: =1 means w/o rotation, =2 means w/ rotation, */
+/* =3 means random. */
+/* KATYPE: the "type" to be passed to SLATM4 for computing A. */
+/* KAZERO: the pattern of zeros on the diagonal for A: */
+/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
+/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
+/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
+/* non-zero entries.) */
+/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
+/* =2: large, =3: small. */
+/* IASIGN: 1 if the diagonal elements of A are to be */
+/* multiplied by a random magnitude 1 number, =2 if */
+/* randomly chosen diagonal blocks are to be rotated */
+/* to form 2x2 blocks. */
+/* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B. */
+/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
+/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
+/* RMAGN: used to implement KAMAGN and KBMAGN. */
+
+ if (mtypes > 26) {
+ goto L110;
+ }
+ iinfo = 0;
+ if (kclass[jtype - 1] < 3) {
+
+/* Generate A (w/o rotation) */
+
+ if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ slaset_("Full", &n, &n, &c_b36, &c_b36, &a[a_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ slatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
+ &kz2[kazero[jtype - 1] - 1], &iasign[jtype - 1], &
+ rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
+ 1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
+ a_offset], lda);
+ iadd = kadd[kazero[jtype - 1] - 1];
+ if (iadd > 0 && iadd <= n) {
+ a[iadd + iadd * a_dim1] = 1.f;
+ }
+
+/* Generate B (w/o rotation) */
+
+ if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ slaset_("Full", &n, &n, &c_b36, &c_b36, &b[b_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ slatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
+ &kz2[kbzero[jtype - 1] - 1], &ibsign[jtype - 1], &
+ rmagn[kbmagn[jtype - 1]], &c_b42, &rmagn[ktrian[jtype
+ - 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
+ b_offset], lda);
+ iadd = kadd[kbzero[jtype - 1] - 1];
+ if (iadd != 0 && iadd <= n) {
+ b[iadd + iadd * b_dim1] = 1.f;
+ }
+
+ if (kclass[jtype - 1] == 2 && n > 0) {
+
+/* Include rotations */
+
+/* Generate Q, Z as Householder transformations times */
+/* a diagonal matrix. */
+
+ i__3 = n - 1;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = jc; jr <= i__4; ++jr) {
+ q[jr + jc * q_dim1] = slarnd_(&c__3, &iseed[1]);
+ z__[jr + jc * z_dim1] = slarnd_(&c__3, &iseed[1]);
+/* L40: */
+ }
+ i__4 = n + 1 - jc;
+ slarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc *
+ q_dim1], &c__1, &work[jc]);
+ work[(n << 1) + jc] = r_sign(&c_b42, &q[jc + jc *
+ q_dim1]);
+ q[jc + jc * q_dim1] = 1.f;
+ i__4 = n + 1 - jc;
+ slarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 +
+ jc * z_dim1], &c__1, &work[n + jc]);
+ work[n * 3 + jc] = r_sign(&c_b42, &z__[jc + jc *
+ z_dim1]);
+ z__[jc + jc * z_dim1] = 1.f;
+/* L50: */
+ }
+ q[n + n * q_dim1] = 1.f;
+ work[n] = 0.f;
+ r__1 = slarnd_(&c__2, &iseed[1]);
+ work[n * 3] = r_sign(&c_b42, &r__1);
+ z__[n + n * z_dim1] = 1.f;
+ work[n * 2] = 0.f;
+ r__1 = slarnd_(&c__2, &iseed[1]);
+ work[n * 4] = r_sign(&c_b42, &r__1);
+
+/* Apply the diagonal matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ a[jr + jc * a_dim1] = work[(n << 1) + jr] * work[
+ n * 3 + jc] * a[jr + jc * a_dim1];
+ b[jr + jc * b_dim1] = work[(n << 1) + jr] * work[
+ n * 3 + jc] * b[jr + jc * b_dim1];
+/* L60: */
+ }
+/* L70: */
+ }
+ i__3 = n - 1;
+ sorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ sorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &a[a_offset], lda, &work[(n << 1) +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ sorm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &b[b_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ sorm2r_("R", "T", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &b[b_offset], lda, &work[(n << 1) +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ }
+ } else {
+
+/* Random matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ a[jr + jc * a_dim1] = rmagn[kamagn[jtype - 1]] *
+ slarnd_(&c__2, &iseed[1]);
+ b[jr + jc * b_dim1] = rmagn[kbmagn[jtype - 1]] *
+ slarnd_(&c__2, &iseed[1]);
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+
+L100:
+
+ if (iinfo != 0) {
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L110:
+
+/* Call SGEGS to compute H, T, Q, Z, alpha, and beta. */
+
+ slacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ slacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ ntest = 1;
+ result[1] = ulpinv;
+
+ sgegs_("V", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
+ alphr1[1], &alphi1[1], &beta1[1], &q[q_offset], ldq, &z__[
+ z_offset], ldq, &work[1], lwork, &iinfo);
+ if (iinfo != 0) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "SGEGS", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L140;
+ }
+
+ ntest = 4;
+
+/* Do tests 1--4 */
+
+ sget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, &q[
+ q_offset], ldq, &z__[z_offset], ldq, &work[1], &result[1])
+ ;
+ sget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
+ q_offset], ldq, &z__[z_offset], ldq, &work[1], &result[2])
+ ;
+ sget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
+ q_offset], ldq, &q[q_offset], ldq, &work[1], &result[3]);
+ sget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[
+ z_offset], ldq, &z__[z_offset], ldq, &work[1], &result[4])
+ ;
+
+/* Do test 5: compare eigenvalues with diagonals. */
+/* Also check Schur form of A. */
+
+ temp1 = 0.f;
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ ilabad = FALSE_;
+ if (alphi1[j] == 0.f) {
+/* Computing MAX */
+ r__7 = safmin, r__8 = (r__2 = alphr1[j], dabs(r__2)),
+ r__7 = max(r__7,r__8), r__8 = (r__3 = s[j + j *
+ s_dim1], dabs(r__3));
+/* Computing MAX */
+ r__9 = safmin, r__10 = (r__5 = beta1[j], dabs(r__5)),
+ r__9 = max(r__9,r__10), r__10 = (r__6 = t[j + j *
+ t_dim1], dabs(r__6));
+ temp2 = ((r__1 = alphr1[j] - s[j + j * s_dim1], dabs(r__1)
+ ) / dmax(r__7,r__8) + (r__4 = beta1[j] - t[j + j *
+ t_dim1], dabs(r__4)) / dmax(r__9,r__10)) / ulp;
+ if (j < n) {
+ if (s[j + 1 + j * s_dim1] != 0.f) {
+ ilabad = TRUE_;
+ }
+ }
+ if (j > 1) {
+ if (s[j + (j - 1) * s_dim1] != 0.f) {
+ ilabad = TRUE_;
+ }
+ }
+ } else {
+ if (alphi1[j] > 0.f) {
+ i1 = j;
+ } else {
+ i1 = j - 1;
+ }
+ if (i1 <= 0 || i1 >= n) {
+ ilabad = TRUE_;
+ } else if (i1 < n - 1) {
+ if (s[i1 + 2 + (i1 + 1) * s_dim1] != 0.f) {
+ ilabad = TRUE_;
+ }
+ } else if (i1 > 1) {
+ if (s[i1 + (i1 - 1) * s_dim1] != 0.f) {
+ ilabad = TRUE_;
+ }
+ }
+ if (! ilabad) {
+ sget53_(&s[i1 + i1 * s_dim1], lda, &t[i1 + i1 *
+ t_dim1], lda, &beta1[j], &alphr1[j], &alphi1[
+ j], &temp2, &iinfo);
+ if (iinfo >= 3) {
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ }
+ } else {
+ temp2 = ulpinv;
+ }
+ }
+ temp1 = dmax(temp1,temp2);
+ if (ilabad) {
+ io___48.ciunit = *nounit;
+ s_wsfe(&io___48);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ }
+/* L120: */
+ }
+ result[5] = temp1;
+
+/* Call SGEGV to compute S2, T2, VL, and VR, do tests. */
+
+/* Eigenvalues and Eigenvectors */
+
+ slacpy_(" ", &n, &n, &a[a_offset], lda, &s2[s2_offset], lda);
+ slacpy_(" ", &n, &n, &b[b_offset], lda, &t2[t2_offset], lda);
+ ntest = 6;
+ result[6] = ulpinv;
+
+ sgegv_("V", "V", &n, &s2[s2_offset], lda, &t2[t2_offset], lda, &
+ alphr2[1], &alphi2[1], &beta2[1], &vl[vl_offset], ldq, &
+ vr[vr_offset], ldq, &work[1], lwork, &iinfo);
+ if (iinfo != 0) {
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ do_fio(&c__1, "SGEGV", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L140;
+ }
+
+ ntest = 7;
+
+/* Do Tests 6 and 7 */
+
+ sget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &vl[
+ vl_offset], ldq, &alphr2[1], &alphi2[1], &beta2[1], &work[
+ 1], dumma);
+ result[6] = dumma[0];
+ if (dumma[1] > *thrshn) {
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "SGEGV", (ftnlen)5);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ sget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &vr[
+ vr_offset], ldq, &alphr2[1], &alphi2[1], &beta2[1], &work[
+ 1], dumma);
+ result[7] = dumma[0];
+ if (dumma[1] > *thresh) {
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "SGEGV", (ftnlen)5);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Check form of Complex eigenvalues. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ ilabad = FALSE_;
+ if (alphi2[j] > 0.f) {
+ if (j == n) {
+ ilabad = TRUE_;
+ } else if (alphi2[j + 1] >= 0.f) {
+ ilabad = TRUE_;
+ }
+ } else if (alphi2[j] < 0.f) {
+ if (j == 1) {
+ ilabad = TRUE_;
+ } else if (alphi2[j - 1] <= 0.f) {
+ ilabad = TRUE_;
+ }
+ }
+ if (ilabad) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ }
+/* L130: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L140:
+
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__3 = ntest;
+ for (jr = 1; jr <= i__3; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ do_fio(&c__1, "SGG", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+ e_wsfe();
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ e_wsfe();
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, "Orthogonal", (ftnlen)10);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ do_fio(&c__1, "orthogonal", (ftnlen)10);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ for (j = 1; j <= 5; ++j) {
+ do_fio(&c__1, "'", (ftnlen)1);
+ }
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[jr] < 1e4f) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ } else {
+ io___60.ciunit = *nounit;
+ s_wsfe(&io___60);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ }
+ }
+/* L150: */
+ }
+
+L160:
+ ;
+ }
+/* L170: */
+ }
+
+/* Summary */
+
+ alasvm_("SGG", nounit, &nerrs, &ntestt, &c__0);
+ return 0;
+
+
+
+
+
+
+
+
+
+/* End of SDRVGG */
+
+} /* sdrvgg_ */
diff --git a/TESTING/EIG/sdrvsg.c b/TESTING/EIG/sdrvsg.c
new file mode 100644
index 0000000..16eda1a
--- /dev/null
+++ b/TESTING/EIG/sdrvsg.c
@@ -0,0 +1,1881 @@
+/* sdrvsg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b18 = 0.f;
+static integer c__0 = 0;
+static integer c__6 = 6;
+static real c_b35 = 1.f;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c__5 = 5;
+static real c_b82 = 10.f;
+static integer c__3 = 3;
+
+/* Subroutine */ int sdrvsg_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, integer *nounit, real *
+ a, integer *lda, real *b, integer *ldb, real *d__, real *z__, integer
+ *ldz, real *ab, real *bb, real *ap, real *bp, real *work, integer *
+ nwork, integer *iwork, integer *liwork, real *result, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,4,4,4,4,4,5,5,5,5,5,8,8,8,9,9,9,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3,1,1,1,1,1,1 };
+ static integer kmode[21] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0,4,4,4,4,4,4 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 SDRVSG: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+
+ /* System generated locals */
+ address a__1[3];
+ integer a_dim1, a_offset, ab_dim1, ab_offset, b_dim1, b_offset, bb_dim1,
+ bb_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6[3]
+ , i__7;
+ char ch__1[10], ch__2[11], ch__3[12], ch__4[13];
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, m, n, ka, kb, ij, il, iu;
+ real vl, vu;
+ integer ka9, kb9;
+ real ulp, cond;
+ integer jcol, nmax;
+ real unfl, ovfl;
+ char uplo[1];
+ logical badnn;
+ integer imode;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ real aninv, anorm;
+ integer itemp;
+ extern /* Subroutine */ int ssgt01_(integer *, char *, integer *, integer
+ *, real *, integer *, real *, integer *, real *, integer *, real *
+, real *, real *);
+ integer nmats, jsize;
+ extern /* Subroutine */ int ssbgv_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, real *,
+ integer *, real *, integer *);
+ integer nerrs, itype, jtype, ntest;
+ extern /* Subroutine */ int sspgv_(integer *, char *, char *, integer *,
+ real *, real *, real *, real *, integer *, real *, integer *);
+ integer iseed2[4];
+ extern /* Subroutine */ int ssygv_(integer *, char *, char *, integer *,
+ real *, integer *, real *, integer *, real *, real *, integer *,
+ integer *), slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ integer idumma[1];
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer ioldsd[4];
+ extern doublereal slarnd_(integer *, integer *);
+ real abstol;
+ extern /* Subroutine */ int ssbgvd_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, real *,
+ integer *, real *, integer *, integer *, integer *, integer *);
+ integer ibuplo;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+ integer ibtype;
+ extern /* Subroutine */ int slafts_(char *, integer *, integer *, integer
+ *, integer *, real *, integer *, real *, integer *, integer *), slaset_(char *, integer *, integer *, real *, real *,
+ real *, integer *), slatmr_(integer *, integer *, char *,
+ integer *, char *, real *, integer *, real *, real *, char *,
+ char *, real *, integer *, real *, real *, integer *, real *,
+ char *, integer *, integer *, integer *, real *, real *, char *,
+ real *, integer *, integer *, integer *), slatms_(integer *, integer *, char *,
+ integer *, char *, real *, integer *, real *, real *, integer *,
+ integer *, char *, real *, integer *, real *, integer *), slasum_(char *, integer *, integer *, integer *), sspgvd_(integer *, char *, char *, integer *, real *,
+ real *, real *, real *, integer *, real *, integer *, integer *,
+ integer *, integer *);
+ real rtunfl, rtovfl, ulpinv;
+ extern /* Subroutine */ int ssbgvx_(char *, char *, char *, integer *,
+ integer *, integer *, real *, integer *, real *, integer *, real *
+, integer *, real *, real *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *, integer *, integer *
+, integer *);
+ integer mtypes, ntestt;
+ extern /* Subroutine */ int ssygvd_(integer *, char *, char *, integer *,
+ real *, integer *, real *, integer *, real *, real *, integer *,
+ integer *, integer *, integer *), sspgvx_(integer
+ *, char *, char *, char *, integer *, real *, real *, real *,
+ real *, integer *, integer *, real *, integer *, real *, real *,
+ integer *, real *, integer *, integer *, integer *), ssygvx_(integer *, char *, char *, char *,
+ integer *, real *, integer *, real *, integer *, real *, real *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, real *, integer *, integer *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* ****************************************************************** */
+
+/* modified August 1997, a new parameter LIWORK is added */
+/* in the calling sequence. */
+
+/* test routine SSGT01 is also modified */
+
+/* ****************************************************************** */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVSG checks the real symmetric generalized eigenproblem */
+/* drivers. */
+
+/* SSYGV computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric-definite generalized */
+/* eigenproblem. */
+
+/* SSYGVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric-definite generalized */
+/* eigenproblem using a divide and conquer algorithm. */
+
+/* SSYGVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric-definite generalized */
+/* eigenproblem. */
+
+/* SSPGV computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric-definite generalized */
+/* eigenproblem in packed storage. */
+
+/* SSPGVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric-definite generalized */
+/* eigenproblem in packed storage using a divide and */
+/* conquer algorithm. */
+
+/* SSPGVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric-definite generalized */
+/* eigenproblem in packed storage. */
+
+/* SSBGV computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric-definite banded */
+/* generalized eigenproblem. */
+
+/* SSBGVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric-definite banded */
+/* generalized eigenproblem using a divide and conquer */
+/* algorithm. */
+
+/* SSBGVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric-definite banded */
+/* generalized eigenproblem. */
+
+/* When SDRVSG is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix A of the given type will be */
+/* generated; a random well-conditioned matrix B is also generated */
+/* and the pair (A,B) is used to test the drivers. */
+
+/* For each pair (A,B), the following tests are performed: */
+
+/* (1) SSYGV with ITYPE = 1 and UPLO ='U': */
+
+/* | A Z - B Z D | / ( |A| |Z| n ulp ) */
+
+/* (2) as (1) but calling SSPGV */
+/* (3) as (1) but calling SSBGV */
+/* (4) as (1) but with UPLO = 'L' */
+/* (5) as (4) but calling SSPGV */
+/* (6) as (4) but calling SSBGV */
+
+/* (7) SSYGV with ITYPE = 2 and UPLO ='U': */
+
+/* | A B Z - Z D | / ( |A| |Z| n ulp ) */
+
+/* (8) as (7) but calling SSPGV */
+/* (9) as (7) but with UPLO = 'L' */
+/* (10) as (9) but calling SSPGV */
+
+/* (11) SSYGV with ITYPE = 3 and UPLO ='U': */
+
+/* | B A Z - Z D | / ( |A| |Z| n ulp ) */
+
+/* (12) as (11) but calling SSPGV */
+/* (13) as (11) but with UPLO = 'L' */
+/* (14) as (13) but calling SSPGV */
+
+/* SSYGVD, SSPGVD and SSBGVD performed the same 14 tests. */
+
+/* SSYGVX, SSPGVX and SSBGVX performed the above 14 tests with */
+/* the parameter RANGE = 'A', 'N' and 'I', respectively. */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value */
+/* of each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* This type is used for the matrix A which has half-bandwidth KA. */
+/* B is generated as a well-conditioned positive definite matrix */
+/* with half-bandwidth KB (<= KA). */
+/* Currently, the list of possible types for A is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" entries */
+/* 1, ULP, ..., ULP and random signs. */
+
+/* (6) Same as (4), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (4), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U* D U, where U is orthogonal and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U* D U, where U is orthogonal and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U* D U, where U is orthogonal and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) symmetric matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold) */
+
+/* (16) Same as (8), but with KA = 1 and KB = 1 */
+/* (17) Same as (8), but with KA = 2 and KB = 1 */
+/* (18) Same as (8), but with KA = 2 and KB = 2 */
+/* (19) Same as (8), but with KA = 3 and KB = 1 */
+/* (20) Same as (8), but with KA = 3 and KB = 2 */
+/* (21) Same as (8), but with KA = 3 and KB = 3 */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* SDRVSG does nothing. It must be at least zero. */
+/* Not modified. */
+
+/* NN INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+/* Not modified. */
+
+/* NTYPES INTEGER */
+/* The number of elements in DOTYPE. If it is zero, SDRVSG */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+/* Not modified. */
+
+/* DOTYPE LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+/* Not modified. */
+
+/* ISEED INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to SDRVSG to continue the same random number */
+/* sequence. */
+/* Modified. */
+
+/* THRESH REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+/* Not modified. */
+
+/* NOUNIT INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+/* Not modified. */
+
+/* A REAL array, dimension (LDA , max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually */
+/* used. */
+/* Modified. */
+
+/* LDA INTEGER */
+/* The leading dimension of A and AB. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* B REAL array, dimension (LDB , max(NN)) */
+/* Used to hold the symmetric positive definite matrix for */
+/* the generailzed problem. */
+/* On exit, B contains the last matrix actually */
+/* used. */
+/* Modified. */
+
+/* LDB INTEGER */
+/* The leading dimension of B and BB. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* D REAL array, dimension (max(NN)) */
+/* The eigenvalues of A. On exit, the eigenvalues in D */
+/* correspond with the matrix in A. */
+/* Modified. */
+
+/* Z REAL array, dimension (LDZ, max(NN)) */
+/* The matrix of eigenvectors. */
+/* Modified. */
+
+/* LDZ INTEGER */
+/* The leading dimension of Z. It must be at least 1 and */
+/* at least max( NN ). */
+/* Not modified. */
+
+/* AB REAL array, dimension (LDA, max(NN)) */
+/* Workspace. */
+/* Modified. */
+
+/* BB REAL array, dimension (LDB, max(NN)) */
+/* Workspace. */
+/* Modified. */
+
+/* AP REAL array, dimension (max(NN)**2) */
+/* Workspace. */
+/* Modified. */
+
+/* BP REAL array, dimension (max(NN)**2) */
+/* Workspace. */
+/* Modified. */
+
+/* WORK REAL array, dimension (NWORK) */
+/* Workspace. */
+/* Modified. */
+
+/* NWORK INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 1+5*N+2*N*lg(N)+3*N**2 where N = max( NN(j) ) and */
+/* lg( N ) = smallest integer k such that 2**k >= N. */
+/* Not modified. */
+
+/* IWORK INTEGER array, dimension (LIWORK) */
+/* Workspace. */
+/* Modified. */
+
+/* LIWORK INTEGER */
+/* The number of entries in WORK. This must be at least 6*N. */
+/* Not modified. */
+
+/* RESULT REAL array, dimension (70) */
+/* The values computed by the 70 tests described above. */
+/* Modified. */
+
+/* INFO INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -5: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -16: LDZ < 1 or LDZ < NMAX. */
+/* -21: NWORK too small. */
+/* -23: LIWORK too small. */
+/* If SLATMR, SLATMS, SSYGV, SSPGV, SSBGV, SSYGVD, SSPGVD, */
+/* SSBGVD, SSYGVX, SSPGVX or SSBGVX returns an error code, */
+/* the absolute value of it is returned. */
+/* Modified. */
+
+/* ---------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests that have been run */
+/* on this matrix. */
+/* NTESTT The total number of tests for this call. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far (computed by SLAFTS). */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ ab_dim1 = *lda;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ bb_dim1 = *ldb;
+ bb_offset = 1 + bb_dim1;
+ bb -= bb_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --d__;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --ap;
+ --bp;
+ --work;
+ --iwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 0;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldz <= 1 || *ldz < nmax) {
+ *info = -16;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = max(nmax,3);
+ if (i__1 * i__1 << 1 > *nwork) {
+ *info = -21;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = max(nmax,3);
+ if (i__1 * i__1 << 1 > *liwork) {
+ *info = -23;
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SDRVSG", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = slamch_("Safe minimum");
+ ovfl = slamch_("Overflow");
+ slabad_(&unfl, &ovfl);
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ ulpinv = 1.f / ulp;
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed2[i__ - 1] = iseed[i__];
+/* L20: */
+ }
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ aninv = 1.f / (real) max(1,n);
+
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ ka9 = 0;
+ kb9 = 0;
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L640;
+ }
+ ++nmats;
+ ntest = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L30: */
+ }
+
+/* 2) Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, w/ eigenvalues */
+/* =5 random log hermitian, w/ eigenvalues */
+/* =6 random (none) */
+/* =7 random diagonal */
+/* =8 random hermitian */
+/* =9 banded, w/ eigenvalues */
+
+ if (mtypes > 21) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.f;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * aninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * n * ulpinv;
+ goto L70;
+
+L70:
+
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+ if (itype == 1) {
+
+/* Zero */
+
+ ka = 0;
+ kb = 0;
+ slaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ ka = 0;
+ kb = 0;
+ slaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ ka = 0;
+ kb = 0;
+ slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* symmetric, eigenvalues specified */
+
+/* Computing MAX */
+ i__3 = 0, i__4 = n - 1;
+ ka = max(i__3,i__4);
+ kb = ka;
+ slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ ka = 0;
+ kb = 0;
+ slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b35,
+ &c_b35, "T", "N", &work[n + 1], &c__1, &c_b35, &work[(
+ n << 1) + 1], &c__1, &c_b35, "N", idumma, &c__0, &
+ c__0, &c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* symmetric, random eigenvalues */
+
+/* Computing MAX */
+ i__3 = 0, i__4 = n - 1;
+ ka = max(i__3,i__4);
+ kb = ka;
+ slatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &c_b35,
+ &c_b35, "T", "N", &work[n + 1], &c__1, &c_b35, &work[(
+ n << 1) + 1], &c__1, &c_b35, "N", idumma, &n, &n, &
+ c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* symmetric banded, eigenvalues specified */
+
+/* The following values are used for the half-bandwidths: */
+
+/* ka = 1 kb = 1 */
+/* ka = 2 kb = 1 */
+/* ka = 2 kb = 2 */
+/* ka = 3 kb = 1 */
+/* ka = 3 kb = 2 */
+/* ka = 3 kb = 3 */
+
+ ++kb9;
+ if (kb9 > ka9) {
+ ++ka9;
+ kb9 = 1;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__5 = n - 1;
+ i__3 = 0, i__4 = min(i__5,ka9);
+ ka = max(i__3,i__4);
+/* Computing MAX */
+/* Computing MIN */
+ i__5 = n - 1;
+ i__3 = 0, i__4 = min(i__5,kb9);
+ kb = max(i__3,i__4);
+ slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &ka, &ka, "N", &a[a_offset], lda, &work[n + 1]
+, &iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___36.ciunit = *nounit;
+ s_wsfe(&io___36);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+ abstol = unfl + unfl;
+ if (n <= 1) {
+ il = 1;
+ iu = n;
+ } else {
+ il = (n - 1) * slarnd_(&c__1, iseed2) + 1;
+ iu = (n - 1) * slarnd_(&c__1, iseed2) + 1;
+ if (il > iu) {
+ itemp = il;
+ il = iu;
+ iu = itemp;
+ }
+ }
+
+/* 3) Call SSYGV, SSPGV, SSBGV, SSYGVD, SSPGVD, SSBGVD, */
+/* SSYGVX, SSPGVX, and SSBGVX, do tests. */
+
+/* loop over the three generalized problems */
+/* IBTYPE = 1: A*x = (lambda)*B*x */
+/* IBTYPE = 2: A*B*x = (lambda)*x */
+/* IBTYPE = 3: B*A*x = (lambda)*x */
+
+ for (ibtype = 1; ibtype <= 3; ++ibtype) {
+
+/* loop over the setting UPLO */
+
+ for (ibuplo = 1; ibuplo <= 2; ++ibuplo) {
+ if (ibuplo == 1) {
+ *(unsigned char *)uplo = 'U';
+ }
+ if (ibuplo == 2) {
+ *(unsigned char *)uplo = 'L';
+ }
+
+/* Generate random well-conditioned positive definite */
+/* matrix B, of bandwidth not greater than that of A. */
+
+ slatms_(&n, &n, "U", &iseed[1], "P", &work[1], &c__5, &
+ c_b82, &c_b35, &kb, &kb, uplo, &b[b_offset], ldb,
+ &work[n + 1], &iinfo);
+
+/* Test SSYGV */
+
+ ++ntest;
+
+ slacpy_(" ", &n, &n, &a[a_offset], lda, &z__[z_offset],
+ ldz);
+ slacpy_(uplo, &n, &n, &b[b_offset], ldb, &bb[bb_offset],
+ ldb);
+
+ ssygv_(&ibtype, "V", uplo, &n, &z__[z_offset], ldz, &bb[
+ bb_offset], ldb, &d__[1], &work[1], nwork, &iinfo);
+ if (iinfo != 0) {
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "SSYGV(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L100;
+ }
+ }
+
+/* Do Test */
+
+ ssgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &result[ntest]);
+
+/* Test SSYGVD */
+
+ ++ntest;
+
+ slacpy_(" ", &n, &n, &a[a_offset], lda, &z__[z_offset],
+ ldz);
+ slacpy_(uplo, &n, &n, &b[b_offset], ldb, &bb[bb_offset],
+ ldb);
+
+ ssygvd_(&ibtype, "V", uplo, &n, &z__[z_offset], ldz, &bb[
+ bb_offset], ldb, &d__[1], &work[1], nwork, &iwork[
+ 1], liwork, &iinfo);
+ if (iinfo != 0) {
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "SSYGVD(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__2, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L100;
+ }
+ }
+
+/* Do Test */
+
+ ssgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &result[ntest]);
+
+/* Test SSYGVX */
+
+ ++ntest;
+
+ slacpy_(" ", &n, &n, &a[a_offset], lda, &ab[ab_offset],
+ lda);
+ slacpy_(uplo, &n, &n, &b[b_offset], ldb, &bb[bb_offset],
+ ldb);
+
+ ssygvx_(&ibtype, "V", "A", uplo, &n, &ab[ab_offset], lda,
+ &bb[bb_offset], ldb, &vl, &vu, &il, &iu, &abstol,
+ &m, &d__[1], &z__[z_offset], ldz, &work[1], nwork,
+ &iwork[n + 1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "SSYGVX(V,A";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L100;
+ }
+ }
+
+/* Do Test */
+
+ ssgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &result[ntest]);
+
+ ++ntest;
+
+ slacpy_(" ", &n, &n, &a[a_offset], lda, &ab[ab_offset],
+ lda);
+ slacpy_(uplo, &n, &n, &b[b_offset], ldb, &bb[bb_offset],
+ ldb);
+
+/* since we do not know the exact eigenvalues of this */
+/* eigenpair, we just set VL and VU as constants. */
+/* It is quite possible that there are no eigenvalues */
+/* in this interval. */
+
+ vl = 0.f;
+ vu = anorm;
+ ssygvx_(&ibtype, "V", "V", uplo, &n, &ab[ab_offset], lda,
+ &bb[bb_offset], ldb, &vl, &vu, &il, &iu, &abstol,
+ &m, &d__[1], &z__[z_offset], ldz, &work[1], nwork,
+ &iwork[n + 1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSYGVX(V,V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__4, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__4, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L100;
+ }
+ }
+
+/* Do Test */
+
+ ssgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &result[ntest]);
+
+ ++ntest;
+
+ slacpy_(" ", &n, &n, &a[a_offset], lda, &ab[ab_offset],
+ lda);
+ slacpy_(uplo, &n, &n, &b[b_offset], ldb, &bb[bb_offset],
+ ldb);
+
+ ssygvx_(&ibtype, "V", "I", uplo, &n, &ab[ab_offset], lda,
+ &bb[bb_offset], ldb, &vl, &vu, &il, &iu, &abstol,
+ &m, &d__[1], &z__[z_offset], ldz, &work[1], nwork,
+ &iwork[n + 1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSYGVX(V,I,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__4, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__4, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L100;
+ }
+ }
+
+/* Do Test */
+
+ ssgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &result[ntest]);
+
+L100:
+
+/* Test SSPGV */
+
+ ++ntest;
+
+/* Copy the matrices into packed storage. */
+
+ if (lsame_(uplo, "U")) {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ ap[ij] = a[i__ + j * a_dim1];
+ bp[ij] = b[i__ + j * b_dim1];
+ ++ij;
+/* L110: */
+ }
+/* L120: */
+ }
+ } else {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ ap[ij] = a[i__ + j * a_dim1];
+ bp[ij] = b[i__ + j * b_dim1];
+ ++ij;
+/* L130: */
+ }
+/* L140: */
+ }
+ }
+
+ sspgv_(&ibtype, "V", uplo, &n, &ap[1], &bp[1], &d__[1], &
+ z__[z_offset], ldz, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "SSPGV(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L310;
+ }
+ }
+
+/* Do Test */
+
+ ssgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &result[ntest]);
+
+/* Test SSPGVD */
+
+ ++ntest;
+
+/* Copy the matrices into packed storage. */
+
+ if (lsame_(uplo, "U")) {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ ap[ij] = a[i__ + j * a_dim1];
+ bp[ij] = b[i__ + j * b_dim1];
+ ++ij;
+/* L150: */
+ }
+/* L160: */
+ }
+ } else {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ ap[ij] = a[i__ + j * a_dim1];
+ bp[ij] = b[i__ + j * b_dim1];
+ ++ij;
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+
+ sspgvd_(&ibtype, "V", uplo, &n, &ap[1], &bp[1], &d__[1], &
+ z__[z_offset], ldz, &work[1], nwork, &iwork[1],
+ liwork, &iinfo);
+ if (iinfo != 0) {
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "SSPGVD(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__2, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L310;
+ }
+ }
+
+/* Do Test */
+
+ ssgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &result[ntest]);
+
+/* Test SSPGVX */
+
+ ++ntest;
+
+/* Copy the matrices into packed storage. */
+
+ if (lsame_(uplo, "U")) {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ ap[ij] = a[i__ + j * a_dim1];
+ bp[ij] = b[i__ + j * b_dim1];
+ ++ij;
+/* L190: */
+ }
+/* L200: */
+ }
+ } else {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ ap[ij] = a[i__ + j * a_dim1];
+ bp[ij] = b[i__ + j * b_dim1];
+ ++ij;
+/* L210: */
+ }
+/* L220: */
+ }
+ }
+
+ sspgvx_(&ibtype, "V", "A", uplo, &n, &ap[1], &bp[1], &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &iwork[n + 1], &iwork[1]
+, info);
+ if (iinfo != 0) {
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "SSPGVX(V,A";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L310;
+ }
+ }
+
+/* Do Test */
+
+ ssgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &result[ntest]);
+
+ ++ntest;
+
+/* Copy the matrices into packed storage. */
+
+ if (lsame_(uplo, "U")) {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ ap[ij] = a[i__ + j * a_dim1];
+ bp[ij] = b[i__ + j * b_dim1];
+ ++ij;
+/* L230: */
+ }
+/* L240: */
+ }
+ } else {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ ap[ij] = a[i__ + j * a_dim1];
+ bp[ij] = b[i__ + j * b_dim1];
+ ++ij;
+/* L250: */
+ }
+/* L260: */
+ }
+ }
+
+ vl = 0.f;
+ vu = anorm;
+ sspgvx_(&ibtype, "V", "V", uplo, &n, &ap[1], &bp[1], &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &iwork[n + 1], &iwork[1]
+, info);
+ if (iinfo != 0) {
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "SSPGVX(V,V";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L310;
+ }
+ }
+
+/* Do Test */
+
+ ssgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &result[ntest]);
+
+ ++ntest;
+
+/* Copy the matrices into packed storage. */
+
+ if (lsame_(uplo, "U")) {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ ap[ij] = a[i__ + j * a_dim1];
+ bp[ij] = b[i__ + j * b_dim1];
+ ++ij;
+/* L270: */
+ }
+/* L280: */
+ }
+ } else {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ ap[ij] = a[i__ + j * a_dim1];
+ bp[ij] = b[i__ + j * b_dim1];
+ ++ij;
+/* L290: */
+ }
+/* L300: */
+ }
+ }
+
+ sspgvx_(&ibtype, "V", "I", uplo, &n, &ap[1], &bp[1], &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &iwork[n + 1], &iwork[1]
+, info);
+ if (iinfo != 0) {
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "SSPGVX(V,I";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L310;
+ }
+ }
+
+/* Do Test */
+
+ ssgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &result[ntest]);
+
+L310:
+
+ if (ibtype == 1) {
+
+/* TEST SSBGV */
+
+ ++ntest;
+
+/* Copy the matrices into band storage. */
+
+ if (lsame_(uplo, "U")) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - ka;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__)
+ {
+ ab[ka + 1 + i__ - j + j * ab_dim1] = a[
+ i__ + j * a_dim1];
+/* L320: */
+ }
+/* Computing MAX */
+ i__7 = 1, i__4 = j - kb;
+ i__5 = j;
+ for (i__ = max(i__7,i__4); i__ <= i__5; ++i__)
+ {
+ bb[kb + 1 + i__ - j + j * bb_dim1] = b[
+ i__ + j * b_dim1];
+/* L330: */
+ }
+/* L340: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__7 = n, i__4 = j + ka;
+ i__5 = min(i__7,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ ab[i__ + 1 - j + j * ab_dim1] = a[i__ + j
+ * a_dim1];
+/* L350: */
+ }
+/* Computing MIN */
+ i__7 = n, i__4 = j + kb;
+ i__5 = min(i__7,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ bb[i__ + 1 - j + j * bb_dim1] = b[i__ + j
+ * b_dim1];
+/* L360: */
+ }
+/* L370: */
+ }
+ }
+
+ ssbgv_("V", uplo, &n, &ka, &kb, &ab[ab_offset], lda, &
+ bb[bb_offset], ldb, &d__[1], &z__[z_offset],
+ ldz, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "SSBGV(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L620;
+ }
+ }
+
+/* Do Test */
+
+ ssgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1],
+ &work[1], &result[ntest]);
+
+/* TEST SSBGVD */
+
+ ++ntest;
+
+/* Copy the matrices into band storage. */
+
+ if (lsame_(uplo, "U")) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__7 = j - ka;
+ i__4 = j;
+ for (i__ = max(i__5,i__7); i__ <= i__4; ++i__)
+ {
+ ab[ka + 1 + i__ - j + j * ab_dim1] = a[
+ i__ + j * a_dim1];
+/* L380: */
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kb;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__)
+ {
+ bb[kb + 1 + i__ - j + j * bb_dim1] = b[
+ i__ + j * b_dim1];
+/* L390: */
+ }
+/* L400: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + ka;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ ab[i__ + 1 - j + j * ab_dim1] = a[i__ + j
+ * a_dim1];
+/* L410: */
+ }
+/* Computing MIN */
+ i__4 = n, i__5 = j + kb;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ bb[i__ + 1 - j + j * bb_dim1] = b[i__ + j
+ * b_dim1];
+/* L420: */
+ }
+/* L430: */
+ }
+ }
+
+ ssbgvd_("V", uplo, &n, &ka, &kb, &ab[ab_offset], lda,
+ &bb[bb_offset], ldb, &d__[1], &z__[z_offset],
+ ldz, &work[1], nwork, &iwork[1], liwork, &
+ iinfo);
+ if (iinfo != 0) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "SSBGVD(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__2, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L620;
+ }
+ }
+
+/* Do Test */
+
+ ssgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1],
+ &work[1], &result[ntest]);
+
+/* Test SSBGVX */
+
+ ++ntest;
+
+/* Copy the matrices into band storage. */
+
+ if (lsame_(uplo, "U")) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__7 = 1, i__4 = j - ka;
+ i__5 = j;
+ for (i__ = max(i__7,i__4); i__ <= i__5; ++i__)
+ {
+ ab[ka + 1 + i__ - j + j * ab_dim1] = a[
+ i__ + j * a_dim1];
+/* L440: */
+ }
+/* Computing MAX */
+ i__5 = 1, i__7 = j - kb;
+ i__4 = j;
+ for (i__ = max(i__5,i__7); i__ <= i__4; ++i__)
+ {
+ bb[kb + 1 + i__ - j + j * bb_dim1] = b[
+ i__ + j * b_dim1];
+/* L450: */
+ }
+/* L460: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__5 = n, i__7 = j + ka;
+ i__4 = min(i__5,i__7);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ ab[i__ + 1 - j + j * ab_dim1] = a[i__ + j
+ * a_dim1];
+/* L470: */
+ }
+/* Computing MIN */
+ i__5 = n, i__7 = j + kb;
+ i__4 = min(i__5,i__7);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ bb[i__ + 1 - j + j * bb_dim1] = b[i__ + j
+ * b_dim1];
+/* L480: */
+ }
+/* L490: */
+ }
+ }
+
+ i__3 = max(1,n);
+ ssbgvx_("V", "A", uplo, &n, &ka, &kb, &ab[ab_offset],
+ lda, &bb[bb_offset], ldb, &bp[1], &i__3, &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &iwork[n + 1], &
+ iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___60.ciunit = *nounit;
+ s_wsfe(&io___60);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "SSBGVX(V,A";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L620;
+ }
+ }
+
+/* Do Test */
+
+ ssgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1],
+ &work[1], &result[ntest]);
+
+
+ ++ntest;
+
+/* Copy the matrices into band storage. */
+
+ if (lsame_(uplo, "U")) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - ka;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__)
+ {
+ ab[ka + 1 + i__ - j + j * ab_dim1] = a[
+ i__ + j * a_dim1];
+/* L500: */
+ }
+/* Computing MAX */
+ i__7 = 1, i__4 = j - kb;
+ i__5 = j;
+ for (i__ = max(i__7,i__4); i__ <= i__5; ++i__)
+ {
+ bb[kb + 1 + i__ - j + j * bb_dim1] = b[
+ i__ + j * b_dim1];
+/* L510: */
+ }
+/* L520: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__7 = n, i__4 = j + ka;
+ i__5 = min(i__7,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ ab[i__ + 1 - j + j * ab_dim1] = a[i__ + j
+ * a_dim1];
+/* L530: */
+ }
+/* Computing MIN */
+ i__7 = n, i__4 = j + kb;
+ i__5 = min(i__7,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ bb[i__ + 1 - j + j * bb_dim1] = b[i__ + j
+ * b_dim1];
+/* L540: */
+ }
+/* L550: */
+ }
+ }
+
+ vl = 0.f;
+ vu = anorm;
+ i__3 = max(1,n);
+ ssbgvx_("V", "V", uplo, &n, &ka, &kb, &ab[ab_offset],
+ lda, &bb[bb_offset], ldb, &bp[1], &i__3, &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &iwork[n + 1], &
+ iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___61.ciunit = *nounit;
+ s_wsfe(&io___61);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "SSBGVX(V,V";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L620;
+ }
+ }
+
+/* Do Test */
+
+ ssgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1],
+ &work[1], &result[ntest]);
+
+ ++ntest;
+
+/* Copy the matrices into band storage. */
+
+ if (lsame_(uplo, "U")) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__7 = j - ka;
+ i__4 = j;
+ for (i__ = max(i__5,i__7); i__ <= i__4; ++i__)
+ {
+ ab[ka + 1 + i__ - j + j * ab_dim1] = a[
+ i__ + j * a_dim1];
+/* L560: */
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kb;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__)
+ {
+ bb[kb + 1 + i__ - j + j * bb_dim1] = b[
+ i__ + j * b_dim1];
+/* L570: */
+ }
+/* L580: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + ka;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ ab[i__ + 1 - j + j * ab_dim1] = a[i__ + j
+ * a_dim1];
+/* L590: */
+ }
+/* Computing MIN */
+ i__4 = n, i__5 = j + kb;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ bb[i__ + 1 - j + j * bb_dim1] = b[i__ + j
+ * b_dim1];
+/* L600: */
+ }
+/* L610: */
+ }
+ }
+
+ i__3 = max(1,n);
+ ssbgvx_("V", "I", uplo, &n, &ka, &kb, &ab[ab_offset],
+ lda, &bb[bb_offset], ldb, &bp[1], &i__3, &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &iwork[n + 1], &
+ iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___62.ciunit = *nounit;
+ s_wsfe(&io___62);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "SSBGVX(V,I";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L620;
+ }
+ }
+
+/* Do Test */
+
+ ssgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1],
+ &work[1], &result[ntest]);
+
+ }
+
+L620:
+ ;
+ }
+/* L630: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+ ntestt += ntest;
+ slafts_("SSG", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh,
+ nounit, &nerrs);
+L640:
+ ;
+ }
+/* L650: */
+ }
+
+/* Summary */
+
+ slasum_("SSG", nounit, &nerrs, &ntestt);
+
+ return 0;
+
+/* End of SDRVSG */
+
+} /* sdrvsg_ */
diff --git a/TESTING/EIG/sdrvst.c b/TESTING/EIG/sdrvst.c
new file mode 100644
index 0000000..a1160ae
--- /dev/null
+++ b/TESTING/EIG/sdrvst.c
@@ -0,0 +1,4151 @@
+/* sdrvst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static real c_b20 = 0.f;
+static integer c__0 = 0;
+static integer c__6 = 6;
+static real c_b34 = 1.f;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c__3 = 3;
+
+/* Subroutine */ int sdrvst_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, integer *nounit, real *
+ a, integer *lda, real *d1, real *d2, real *d3, real *d4, real *eveigs,
+ real *wa1, real *wa2, real *wa3, real *u, integer *ldu, real *v,
+ real *tau, real *z__, real *work, integer *lwork, integer *iwork,
+ integer *liwork, real *result, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[18] = { 1,2,4,4,4,4,4,5,5,5,5,5,8,8,8,9,9,9 };
+ static integer kmagn[18] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3,1,2,3 };
+ static integer kmode[18] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0,4,4,4 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 SDRVST: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+
+ /* System generated locals */
+ address a__1[3];
+ integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, z_dim1,
+ z_offset, i__1, i__2, i__3, i__4, i__5, i__6[3], i__7;
+ real r__1, r__2, r__3, r__4;
+ char ch__1[10], ch__2[13], ch__3[11];
+
+ /* Builtin functions */
+ double sqrt(doublereal), log(doublereal);
+ integer pow_ii(integer *, integer *), s_wsfe(cilist *), do_fio(integer *,
+ char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
+ char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, m, n, j1, j2, m2, m3, kd, il, iu;
+ real vl, vu;
+ integer lgn;
+ real ulp, cond;
+ integer jcol, ihbw, indx, nmax;
+ real unfl, ovfl;
+ char uplo[1];
+ integer irow;
+ real temp1, temp2, temp3;
+ integer idiag;
+ logical badnn;
+ extern doublereal ssxt1_(integer *, real *, integer *, real *, integer *,
+ real *, real *, real *);
+ integer imode, lwedc, iinfo;
+ real aninv, anorm;
+ integer itemp, nmats;
+ extern /* Subroutine */ int ssbev_(char *, char *, integer *, integer *,
+ real *, integer *, real *, real *, integer *, real *, integer *);
+ integer jsize, iuplo, nerrs, itype, jtype, ntest;
+ extern /* Subroutine */ int sspev_(char *, char *, integer *, real *,
+ real *, real *, integer *, real *, integer *),
+ sstt21_(integer *, integer *, real *, real *, real *, real *,
+ real *, integer *, real *, real *), sstt22_(integer *, integer *,
+ integer *, real *, real *, real *, real *, real *, integer *,
+ real *, integer *, real *), sstev_(char *, integer *, real *,
+ real *, real *, integer *, real *, integer *), ssyt21_(
+ integer *, char *, integer *, integer *, real *, integer *, real *
+, real *, real *, integer *, real *, integer *, real *, real *,
+ real *), ssyt22_(integer *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, real *, integer *,
+ real *, integer *, real *, real *, real *), ssyev_(char *,
+ char *, integer *, real *, integer *, real *, real *, integer *,
+ integer *);
+ integer iseed2[4], iseed3[4];
+ extern /* Subroutine */ int slabad_(real *, real *);
+ integer liwedc;
+ extern doublereal slamch_(char *);
+ integer idumma[1];
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer ioldsd[4];
+ extern doublereal slarnd_(integer *, integer *);
+ real abstol;
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *), ssbevd_(char *, char *, integer *, integer
+ *, real *, integer *, real *, real *, integer *, real *, integer *
+, integer *, integer *, integer *), slacpy_(char *
+, integer *, integer *, real *, integer *, real *, integer *), slafts_(char *, integer *, integer *, integer *, integer
+ *, real *, integer *, real *, integer *, integer *),
+ slaset_(char *, integer *, integer *, real *, real *, real *,
+ integer *), slatmr_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, char *, char *,
+ real *, integer *, real *, real *, integer *, real *, char *,
+ integer *, integer *, integer *, real *, real *, char *, real *,
+ integer *, integer *, integer *), slatms_(integer *, integer *, char *, integer *,
+ char *, real *, integer *, real *, real *, integer *, integer *,
+ char *, real *, integer *, real *, integer *), sspevd_(char *, char *, integer *, real *, real *, real *
+, integer *, real *, integer *, integer *, integer *, integer *), sstevd_(char *, integer *, real *, real *, real *
+, integer *, real *, integer *, integer *, integer *, integer *);
+ real rtunfl, rtovfl, ulpinv;
+ extern /* Subroutine */ int ssbevx_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, real *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, real *, integer *, integer *, integer *)
+ ;
+ integer mtypes, ntestt;
+ extern /* Subroutine */ int sstevr_(char *, char *, integer *, real *,
+ real *, real *, real *, integer *, integer *, real *, integer *,
+ real *, real *, integer *, integer *, real *, integer *, integer *
+, integer *, integer *), ssyevd_(char *, char *,
+ integer *, real *, integer *, real *, real *, integer *, integer *
+, integer *, integer *), sspevx_(char *, char *,
+ char *, integer *, real *, real *, real *, integer *, integer *,
+ real *, integer *, real *, real *, integer *, real *, integer *,
+ integer *, integer *), ssyevr_(char *,
+ char *, char *, integer *, real *, integer *, real *, real *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, integer *, real *, integer *, integer *, integer *, integer *), sstevx_(char *, char *, integer *, real *
+, real *, real *, real *, integer *, integer *, real *, integer *,
+ real *, real *, integer *, real *, integer *, integer *, integer
+ *), ssyevx_(char *, char *, char *, integer *,
+ real *, integer *, real *, real *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *, integer *, integer *
+, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___68 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___69 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___72 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___73 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___74 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___75 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___76 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___77 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___81 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___82 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___83 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___84 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___85 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___86 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___87 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___88 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___90 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___91 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___92 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___93 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___94 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___95 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___96 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___97 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___98 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___99 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___100 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___101 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___102 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___103 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___104 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___105 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___106 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___107 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___108 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___109 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVST checks the symmetric eigenvalue problem drivers. */
+
+/* SSTEV computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric tridiagonal matrix. */
+
+/* SSTEVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric tridiagonal matrix. */
+
+/* SSTEVR computes selected eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric tridiagonal matrix */
+/* using the Relatively Robust Representation where it can. */
+
+/* SSYEV computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric matrix. */
+
+/* SSYEVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric matrix. */
+
+/* SSYEVR computes selected eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric matrix */
+/* using the Relatively Robust Representation where it can. */
+
+/* SSPEV computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric matrix in packed */
+/* storage. */
+
+/* SSPEVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric matrix in packed */
+/* storage. */
+
+/* SSBEV computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric band matrix. */
+
+/* SSBEVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric band matrix. */
+
+/* SSYEVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric matrix using */
+/* a divide and conquer algorithm. */
+
+/* SSPEVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric matrix in packed */
+/* storage, using a divide and conquer algorithm. */
+
+/* SSBEVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a real symmetric band matrix, */
+/* using a divide and conquer algorithm. */
+
+/* When SDRVST is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the appropriate drivers. For each matrix and each */
+/* driver routine called, the following tests will be performed: */
+
+/* (1) | A - Z D Z' | / ( |A| n ulp ) */
+
+/* (2) | I - Z Z' | / ( n ulp ) */
+
+/* (3) | D1 - D2 | / ( |D1| ulp ) */
+
+/* where Z is the matrix of eigenvectors returned when the */
+/* eigenvector option is given and D1 and D2 are the eigenvalues */
+/* returned with and without the eigenvector option. */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced eigenvalues */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced eigenvalues */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" eigenvalues */
+/* 1, ULP, ..., ULP and random signs. */
+
+/* (6) Same as (4), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (4), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U' D U, where U is orthogonal and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U' D U, where U is orthogonal and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U' D U, where U is orthogonal and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) Symmetric matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
+/* (16) A band matrix with half bandwidth randomly chosen between */
+/* 0 and N-1, with evenly spaced eigenvalues 1, ..., ULP */
+/* with random signs. */
+/* (17) Same as (16), but multiplied by SQRT( overflow threshold ) */
+/* (18) Same as (16), but multiplied by SQRT( underflow threshold ) */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* SDRVST does nothing. It must be at least zero. */
+/* Not modified. */
+
+/* NN INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+/* Not modified. */
+
+/* NTYPES INTEGER */
+/* The number of elements in DOTYPE. If it is zero, SDRVST */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+/* Not modified. */
+
+/* DOTYPE LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+/* Not modified. */
+
+/* ISEED INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to SDRVST to continue the same random number */
+/* sequence. */
+/* Modified. */
+
+/* THRESH REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+/* Not modified. */
+
+/* NOUNIT INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+/* Not modified. */
+
+/* A REAL array, dimension (LDA , max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually */
+/* used. */
+/* Modified. */
+
+/* LDA INTEGER */
+/* The leading dimension of A. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* D1 REAL array, dimension (max(NN)) */
+/* The eigenvalues of A, as computed by SSTEQR simlutaneously */
+/* with Z. On exit, the eigenvalues in D1 correspond with the */
+/* matrix in A. */
+/* Modified. */
+
+/* D2 REAL array, dimension (max(NN)) */
+/* The eigenvalues of A, as computed by SSTEQR if Z is not */
+/* computed. On exit, the eigenvalues in D2 correspond with */
+/* the matrix in A. */
+/* Modified. */
+
+/* D3 REAL array, dimension (max(NN)) */
+/* The eigenvalues of A, as computed by SSTERF. On exit, the */
+/* eigenvalues in D3 correspond with the matrix in A. */
+/* Modified. */
+
+/* D4 REAL array, dimension */
+
+/* EVEIGS REAL array, dimension (max(NN)) */
+/* The eigenvalues as computed by SSTEV('N', ... ) */
+/* (I reserve the right to change this to the output of */
+/* whichever algorithm computes the most accurate eigenvalues). */
+
+/* WA1 REAL array, dimension */
+
+/* WA2 REAL array, dimension */
+
+/* WA3 REAL array, dimension */
+
+/* U REAL array, dimension (LDU, max(NN)) */
+/* The orthogonal matrix computed by SSYTRD + SORGTR. */
+/* Modified. */
+
+/* LDU INTEGER */
+/* The leading dimension of U, Z, and V. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* V REAL array, dimension (LDU, max(NN)) */
+/* The Housholder vectors computed by SSYTRD in reducing A to */
+/* tridiagonal form. */
+/* Modified. */
+
+/* TAU REAL array, dimension (max(NN)) */
+/* The Householder factors computed by SSYTRD in reducing A */
+/* to tridiagonal form. */
+/* Modified. */
+
+/* Z REAL array, dimension (LDU, max(NN)) */
+/* The orthogonal matrix of eigenvectors computed by SSTEQR, */
+/* SPTEQR, and SSTEIN. */
+/* Modified. */
+
+/* WORK REAL array, dimension (LWORK) */
+/* Workspace. */
+/* Modified. */
+
+/* LWORK INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 4 * Nmax**2 */
+/* where Nmax = max( NN(j), 2 ) and lg = log base 2. */
+/* Not modified. */
+
+/* IWORK INTEGER array, */
+/* dimension (6 + 6*Nmax + 5 * Nmax * lg Nmax ) */
+/* where Nmax = max( NN(j), 2 ) and lg = log base 2. */
+/* Workspace. */
+/* Modified. */
+
+/* RESULT REAL array, dimension (105) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+/* Modified. */
+
+/* INFO INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -5: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -16: LDU < 1 or LDU < NMAX. */
+/* -21: LWORK too small. */
+/* If SLATMR, SLATMS, SSYTRD, SORGTR, SSTEQR, SSTERF, */
+/* or SORMTR returns an error code, the */
+/* absolute value of it is returned. */
+/* Modified. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests performed, or which can */
+/* be performed so far, for the current matrix. */
+/* NTESTT The total number of tests performed so far. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far (computed by SLAFTS). */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* The tests performed are: Routine tested */
+/* 1= | A - U S U' | / ( |A| n ulp ) SSTEV('V', ... ) */
+/* 2= | I - U U' | / ( n ulp ) SSTEV('V', ... ) */
+/* 3= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEV('N', ... ) */
+/* 4= | A - U S U' | / ( |A| n ulp ) SSTEVX('V','A', ... ) */
+/* 5= | I - U U' | / ( n ulp ) SSTEVX('V','A', ... ) */
+/* 6= |D(with Z) - EVEIGS| / (|D| ulp) SSTEVX('N','A', ... ) */
+/* 7= | A - U S U' | / ( |A| n ulp ) SSTEVR('V','A', ... ) */
+/* 8= | I - U U' | / ( n ulp ) SSTEVR('V','A', ... ) */
+/* 9= |D(with Z) - EVEIGS| / (|D| ulp) SSTEVR('N','A', ... ) */
+/* 10= | A - U S U' | / ( |A| n ulp ) SSTEVX('V','I', ... ) */
+/* 11= | I - U U' | / ( n ulp ) SSTEVX('V','I', ... ) */
+/* 12= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVX('N','I', ... ) */
+/* 13= | A - U S U' | / ( |A| n ulp ) SSTEVX('V','V', ... ) */
+/* 14= | I - U U' | / ( n ulp ) SSTEVX('V','V', ... ) */
+/* 15= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVX('N','V', ... ) */
+/* 16= | A - U S U' | / ( |A| n ulp ) SSTEVD('V', ... ) */
+/* 17= | I - U U' | / ( n ulp ) SSTEVD('V', ... ) */
+/* 18= |D(with Z) - EVEIGS| / (|D| ulp) SSTEVD('N', ... ) */
+/* 19= | A - U S U' | / ( |A| n ulp ) SSTEVR('V','I', ... ) */
+/* 20= | I - U U' | / ( n ulp ) SSTEVR('V','I', ... ) */
+/* 21= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVR('N','I', ... ) */
+/* 22= | A - U S U' | / ( |A| n ulp ) SSTEVR('V','V', ... ) */
+/* 23= | I - U U' | / ( n ulp ) SSTEVR('V','V', ... ) */
+/* 24= |D(with Z) - D(w/o Z)| / (|D| ulp) SSTEVR('N','V', ... ) */
+
+/* 25= | A - U S U' | / ( |A| n ulp ) SSYEV('L','V', ... ) */
+/* 26= | I - U U' | / ( n ulp ) SSYEV('L','V', ... ) */
+/* 27= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEV('L','N', ... ) */
+/* 28= | A - U S U' | / ( |A| n ulp ) SSYEVX('L','V','A', ... ) */
+/* 29= | I - U U' | / ( n ulp ) SSYEVX('L','V','A', ... ) */
+/* 30= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVX('L','N','A', ... ) */
+/* 31= | A - U S U' | / ( |A| n ulp ) SSYEVX('L','V','I', ... ) */
+/* 32= | I - U U' | / ( n ulp ) SSYEVX('L','V','I', ... ) */
+/* 33= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVX('L','N','I', ... ) */
+/* 34= | A - U S U' | / ( |A| n ulp ) SSYEVX('L','V','V', ... ) */
+/* 35= | I - U U' | / ( n ulp ) SSYEVX('L','V','V', ... ) */
+/* 36= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVX('L','N','V', ... ) */
+/* 37= | A - U S U' | / ( |A| n ulp ) SSPEV('L','V', ... ) */
+/* 38= | I - U U' | / ( n ulp ) SSPEV('L','V', ... ) */
+/* 39= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEV('L','N', ... ) */
+/* 40= | A - U S U' | / ( |A| n ulp ) SSPEVX('L','V','A', ... ) */
+/* 41= | I - U U' | / ( n ulp ) SSPEVX('L','V','A', ... ) */
+/* 42= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVX('L','N','A', ... ) */
+/* 43= | A - U S U' | / ( |A| n ulp ) SSPEVX('L','V','I', ... ) */
+/* 44= | I - U U' | / ( n ulp ) SSPEVX('L','V','I', ... ) */
+/* 45= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVX('L','N','I', ... ) */
+/* 46= | A - U S U' | / ( |A| n ulp ) SSPEVX('L','V','V', ... ) */
+/* 47= | I - U U' | / ( n ulp ) SSPEVX('L','V','V', ... ) */
+/* 48= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVX('L','N','V', ... ) */
+/* 49= | A - U S U' | / ( |A| n ulp ) SSBEV('L','V', ... ) */
+/* 50= | I - U U' | / ( n ulp ) SSBEV('L','V', ... ) */
+/* 51= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEV('L','N', ... ) */
+/* 52= | A - U S U' | / ( |A| n ulp ) SSBEVX('L','V','A', ... ) */
+/* 53= | I - U U' | / ( n ulp ) SSBEVX('L','V','A', ... ) */
+/* 54= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVX('L','N','A', ... ) */
+/* 55= | A - U S U' | / ( |A| n ulp ) SSBEVX('L','V','I', ... ) */
+/* 56= | I - U U' | / ( n ulp ) SSBEVX('L','V','I', ... ) */
+/* 57= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVX('L','N','I', ... ) */
+/* 58= | A - U S U' | / ( |A| n ulp ) SSBEVX('L','V','V', ... ) */
+/* 59= | I - U U' | / ( n ulp ) SSBEVX('L','V','V', ... ) */
+/* 60= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVX('L','N','V', ... ) */
+/* 61= | A - U S U' | / ( |A| n ulp ) SSYEVD('L','V', ... ) */
+/* 62= | I - U U' | / ( n ulp ) SSYEVD('L','V', ... ) */
+/* 63= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVD('L','N', ... ) */
+/* 64= | A - U S U' | / ( |A| n ulp ) SSPEVD('L','V', ... ) */
+/* 65= | I - U U' | / ( n ulp ) SSPEVD('L','V', ... ) */
+/* 66= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVD('L','N', ... ) */
+/* 67= | A - U S U' | / ( |A| n ulp ) SSBEVD('L','V', ... ) */
+/* 68= | I - U U' | / ( n ulp ) SSBEVD('L','V', ... ) */
+/* 69= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVD('L','N', ... ) */
+/* 70= | A - U S U' | / ( |A| n ulp ) SSYEVR('L','V','A', ... ) */
+/* 71= | I - U U' | / ( n ulp ) SSYEVR('L','V','A', ... ) */
+/* 72= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVR('L','N','A', ... ) */
+/* 73= | A - U S U' | / ( |A| n ulp ) SSYEVR('L','V','I', ... ) */
+/* 74= | I - U U' | / ( n ulp ) SSYEVR('L','V','I', ... ) */
+/* 75= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVR('L','N','I', ... ) */
+/* 76= | A - U S U' | / ( |A| n ulp ) SSYEVR('L','V','V', ... ) */
+/* 77= | I - U U' | / ( n ulp ) SSYEVR('L','V','V', ... ) */
+/* 78= |D(with Z) - D(w/o Z)| / (|D| ulp) SSYEVR('L','N','V', ... ) */
+
+/* Tests 25 through 78 are repeated (as tests 79 through 132) */
+/* with UPLO='U' */
+
+/* To be added in 1999 */
+
+/* 79= | A - U S U' | / ( |A| n ulp ) SSPEVR('L','V','A', ... ) */
+/* 80= | I - U U' | / ( n ulp ) SSPEVR('L','V','A', ... ) */
+/* 81= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVR('L','N','A', ... ) */
+/* 82= | A - U S U' | / ( |A| n ulp ) SSPEVR('L','V','I', ... ) */
+/* 83= | I - U U' | / ( n ulp ) SSPEVR('L','V','I', ... ) */
+/* 84= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVR('L','N','I', ... ) */
+/* 85= | A - U S U' | / ( |A| n ulp ) SSPEVR('L','V','V', ... ) */
+/* 86= | I - U U' | / ( n ulp ) SSPEVR('L','V','V', ... ) */
+/* 87= |D(with Z) - D(w/o Z)| / (|D| ulp) SSPEVR('L','N','V', ... ) */
+/* 88= | A - U S U' | / ( |A| n ulp ) SSBEVR('L','V','A', ... ) */
+/* 89= | I - U U' | / ( n ulp ) SSBEVR('L','V','A', ... ) */
+/* 90= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVR('L','N','A', ... ) */
+/* 91= | A - U S U' | / ( |A| n ulp ) SSBEVR('L','V','I', ... ) */
+/* 92= | I - U U' | / ( n ulp ) SSBEVR('L','V','I', ... ) */
+/* 93= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVR('L','N','I', ... ) */
+/* 94= | A - U S U' | / ( |A| n ulp ) SSBEVR('L','V','V', ... ) */
+/* 95= | I - U U' | / ( n ulp ) SSBEVR('L','V','V', ... ) */
+/* 96= |D(with Z) - D(w/o Z)| / (|D| ulp) SSBEVR('L','N','V', ... ) */
+
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d1;
+ --d2;
+ --d3;
+ --d4;
+ --eveigs;
+ --wa1;
+ --wa2;
+ --wa3;
+ z_dim1 = *ldu;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ v_dim1 = *ldu;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --tau;
+ --work;
+ --iwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Keep ftrnchek happy */
+
+ vl = 0.f;
+ vu = 0.f;
+
+/* 1) Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*lda < nmax) {
+ *info = -9;
+ } else if (*ldu < nmax) {
+ *info = -16;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = max(2,nmax);
+ if (i__1 * i__1 << 1 > *lwork) {
+ *info = -21;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SDRVST", &i__1);
+ return 0;
+ }
+
+/* Quick return if nothing to do */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = slamch_("Safe minimum");
+ ovfl = slamch_("Overflow");
+ slabad_(&unfl, &ovfl);
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ ulpinv = 1.f / ulp;
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+
+/* Loop over sizes, types */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed2[i__ - 1] = iseed[i__];
+ iseed3[i__ - 1] = iseed[i__];
+/* L20: */
+ }
+
+ nerrs = 0;
+ nmats = 0;
+
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (n > 0) {
+ lgn = (integer) (log((real) n) / log(2.f));
+ if (pow_ii(&c__2, &lgn) < n) {
+ ++lgn;
+ }
+ if (pow_ii(&c__2, &lgn) < n) {
+ ++lgn;
+ }
+/* Computing 2nd power */
+ i__2 = n;
+ lwedc = (n << 2) + 1 + (n << 1) * lgn + (i__2 * i__2 << 2);
+/* LIWEDC = 6 + 6*N + 5*N*LGN */
+ liwedc = n * 5 + 3;
+ } else {
+ lwedc = 9;
+/* LIWEDC = 12 */
+ liwedc = 8;
+ }
+ aninv = 1.f / (real) max(1,n);
+
+ if (*nsizes != 1) {
+ mtypes = min(18,*ntypes);
+ } else {
+ mtypes = min(19,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+
+ if (! dotype[jtype]) {
+ goto L1730;
+ }
+ ++nmats;
+ ntest = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L30: */
+ }
+
+/* 2) Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random (none) */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 band symmetric, w/ eigenvalues */
+
+ if (mtypes > 18) {
+ goto L110;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.f;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * aninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * n * ulpinv;
+ goto L70;
+
+L70:
+
+ slaset_("Full", lda, &n, &c_b20, &c_b20, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ idumma[0] = 1;
+ slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b34,
+ &c_b34, "T", "N", &work[n + 1], &c__1, &c_b34, &work[(
+ n << 1) + 1], &c__1, &c_b34, "N", idumma, &c__0, &
+ c__0, &c_b20, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ idumma[0] = 1;
+ slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b34,
+ &c_b34, "T", "N", &work[n + 1], &c__1, &c_b34, &work[(
+ n << 1) + 1], &c__1, &c_b34, "N", idumma, &n, &n, &
+ c_b20, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* Symmetric banded, eigenvalues specified */
+
+ ihbw = (integer) ((n - 1) * slarnd_(&c__1, iseed3));
+ slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &ihbw, &ihbw, "Z", &u[u_offset], ldu, &work[n
+ + 1], &iinfo);
+
+/* Store as dense matrix for most routines. */
+
+ slaset_("Full", lda, &n, &c_b20, &c_b20, &a[a_offset], lda);
+ i__3 = ihbw;
+ for (idiag = -ihbw; idiag <= i__3; ++idiag) {
+ irow = ihbw - idiag + 1;
+/* Computing MAX */
+ i__4 = 1, i__5 = idiag + 1;
+ j1 = max(i__4,i__5);
+/* Computing MIN */
+ i__4 = n, i__5 = n + idiag;
+ j2 = min(i__4,i__5);
+ i__4 = j2;
+ for (j = j1; j <= i__4; ++j) {
+ i__ = j - idiag;
+ a[i__ + j * a_dim1] = u[irow + j * u_dim1];
+/* L90: */
+ }
+/* L100: */
+ }
+ } else {
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L110:
+
+ abstol = unfl + unfl;
+ if (n <= 1) {
+ il = 1;
+ iu = n;
+ } else {
+ il = (integer) ((n - 1) * slarnd_(&c__1, iseed2)) + 1;
+ iu = (integer) ((n - 1) * slarnd_(&c__1, iseed2)) + 1;
+ if (il > iu) {
+ itemp = il;
+ il = iu;
+ iu = itemp;
+ }
+ }
+
+/* 3) If matrix is tridiagonal, call SSTEV and SSTEVX. */
+
+ if (jtype <= 7) {
+ ntest = 1;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d1[i__] = a[i__ + i__ * a_dim1];
+/* L120: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d2[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L130: */
+ }
+ s_copy(srnamc_1.srnamt, "SSTEV", (ftnlen)32, (ftnlen)5);
+ sstev_("V", &n, &d1[1], &d2[1], &z__[z_offset], ldu, &work[1],
+ &iinfo);
+ if (iinfo != 0) {
+ io___48.ciunit = *nounit;
+ s_wsfe(&io___48);
+ do_fio(&c__1, "SSTEV(V)", (ftnlen)8);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[1] = ulpinv;
+ result[2] = ulpinv;
+ result[3] = ulpinv;
+ goto L180;
+ }
+ }
+
+/* Do tests 1 and 2. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d3[i__] = a[i__ + i__ * a_dim1];
+/* L140: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L150: */
+ }
+ sstt21_(&n, &c__0, &d3[1], &d4[1], &d1[1], &d2[1], &z__[
+ z_offset], ldu, &work[1], &result[1]);
+
+ ntest = 3;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L160: */
+ }
+ s_copy(srnamc_1.srnamt, "SSTEV", (ftnlen)32, (ftnlen)5);
+ sstev_("N", &n, &d3[1], &d4[1], &z__[z_offset], ldu, &work[1],
+ &iinfo);
+ if (iinfo != 0) {
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ do_fio(&c__1, "SSTEV(N)", (ftnlen)8);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[3] = ulpinv;
+ goto L180;
+ }
+ }
+
+/* Do test 3. */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d1[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = d3[j], dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d1[j] - d3[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L170: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[3] = temp2 / dmax(r__1,r__2);
+
+L180:
+
+ ntest = 4;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ eveigs[i__] = d3[i__];
+ d1[i__] = a[i__ + i__ * a_dim1];
+/* L190: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d2[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L200: */
+ }
+ s_copy(srnamc_1.srnamt, "SSTEVX", (ftnlen)32, (ftnlen)6);
+ sstevx_("V", "A", &n, &d1[1], &d2[1], &vl, &vu, &il, &iu, &
+ abstol, &m, &wa1[1], &z__[z_offset], ldu, &work[1], &
+ iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, "SSTEVX(V,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[4] = ulpinv;
+ result[5] = ulpinv;
+ result[6] = ulpinv;
+ goto L250;
+ }
+ }
+ if (n > 0) {
+/* Computing MAX */
+ r__2 = dabs(wa1[1]), r__3 = (r__1 = wa1[n], dabs(r__1));
+ temp3 = dmax(r__2,r__3);
+ } else {
+ temp3 = 0.f;
+ }
+
+/* Do tests 4 and 5. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d3[i__] = a[i__ + i__ * a_dim1];
+/* L210: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L220: */
+ }
+ sstt21_(&n, &c__0, &d3[1], &d4[1], &wa1[1], &d2[1], &z__[
+ z_offset], ldu, &work[1], &result[4]);
+
+ ntest = 6;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L230: */
+ }
+ s_copy(srnamc_1.srnamt, "SSTEVX", (ftnlen)32, (ftnlen)6);
+ sstevx_("N", "A", &n, &d3[1], &d4[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &work[1], &
+ iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ do_fio(&c__1, "SSTEVX(N,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[6] = ulpinv;
+ goto L250;
+ }
+ }
+
+/* Do test 6. */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = wa2[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = eveigs[j], dabs(
+ r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = wa2[j] - eveigs[j], dabs(
+ r__1));
+ temp2 = dmax(r__2,r__3);
+/* L240: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[6] = temp2 / dmax(r__1,r__2);
+
+L250:
+
+ ntest = 7;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d1[i__] = a[i__ + i__ * a_dim1];
+/* L260: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d2[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L270: */
+ }
+ s_copy(srnamc_1.srnamt, "SSTEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ sstevr_("V", "A", &n, &d1[1], &d2[1], &vl, &vu, &il, &iu, &
+ abstol, &m, &wa1[1], &z__[z_offset], ldu, &iwork[1], &
+ work[1], lwork, &iwork[(n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, "SSTEVR(V,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[7] = ulpinv;
+ result[8] = ulpinv;
+ goto L320;
+ }
+ }
+ if (n > 0) {
+/* Computing MAX */
+ r__2 = dabs(wa1[1]), r__3 = (r__1 = wa1[n], dabs(r__1));
+ temp3 = dmax(r__2,r__3);
+ } else {
+ temp3 = 0.f;
+ }
+
+/* Do tests 7 and 8. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d3[i__] = a[i__ + i__ * a_dim1];
+/* L280: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L290: */
+ }
+ sstt21_(&n, &c__0, &d3[1], &d4[1], &wa1[1], &d2[1], &z__[
+ z_offset], ldu, &work[1], &result[7]);
+
+ ntest = 9;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L300: */
+ }
+ s_copy(srnamc_1.srnamt, "SSTEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ sstevr_("N", "A", &n, &d3[1], &d4[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &iwork[1],
+ &work[1], lwork, &iwork[(n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ do_fio(&c__1, "SSTEVR(N,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[9] = ulpinv;
+ goto L320;
+ }
+ }
+
+/* Do test 9. */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = wa2[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = eveigs[j], dabs(
+ r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = wa2[j] - eveigs[j], dabs(
+ r__1));
+ temp2 = dmax(r__2,r__3);
+/* L310: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[9] = temp2 / dmax(r__1,r__2);
+
+L320:
+
+
+ ntest = 10;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d1[i__] = a[i__ + i__ * a_dim1];
+/* L330: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d2[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L340: */
+ }
+ s_copy(srnamc_1.srnamt, "SSTEVX", (ftnlen)32, (ftnlen)6);
+ sstevx_("V", "I", &n, &d1[1], &d2[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &work[1], &
+ iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, "SSTEVX(V,I)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[10] = ulpinv;
+ result[11] = ulpinv;
+ result[12] = ulpinv;
+ goto L380;
+ }
+ }
+
+/* Do tests 10 and 11. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d3[i__] = a[i__ + i__ * a_dim1];
+/* L350: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L360: */
+ }
+ i__3 = max(1,m2);
+ sstt22_(&n, &m2, &c__0, &d3[1], &d4[1], &wa2[1], &d2[1], &z__[
+ z_offset], ldu, &work[1], &i__3, &result[10]);
+
+
+ ntest = 12;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L370: */
+ }
+ s_copy(srnamc_1.srnamt, "SSTEVX", (ftnlen)32, (ftnlen)6);
+ sstevx_("N", "I", &n, &d3[1], &d4[1], &vl, &vu, &il, &iu, &
+ abstol, &m3, &wa3[1], &z__[z_offset], ldu, &work[1], &
+ iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___61.ciunit = *nounit;
+ s_wsfe(&io___61);
+ do_fio(&c__1, "SSTEVX(N,I)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[12] = ulpinv;
+ goto L380;
+ }
+ }
+
+/* Do test 12. */
+
+ temp1 = ssxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = ssxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * temp3;
+ result[12] = (temp1 + temp2) / dmax(r__1,r__2);
+
+L380:
+
+ ntest = 12;
+ if (n > 0) {
+ if (il != 1) {
+/* Computing MAX */
+ r__1 = (wa1[il] - wa1[il - 1]) * .5f, r__2 = ulp *
+ 10.f * temp3, r__1 = max(r__1,r__2), r__2 =
+ rtunfl * 10.f;
+ vl = wa1[il] - dmax(r__1,r__2);
+ } else {
+/* Computing MAX */
+ r__1 = (wa1[n] - wa1[1]) * .5f, r__2 = ulp * 10.f *
+ temp3, r__1 = max(r__1,r__2), r__2 = rtunfl *
+ 10.f;
+ vl = wa1[1] - dmax(r__1,r__2);
+ }
+ if (iu != n) {
+/* Computing MAX */
+ r__1 = (wa1[iu + 1] - wa1[iu]) * .5f, r__2 = ulp *
+ 10.f * temp3, r__1 = max(r__1,r__2), r__2 =
+ rtunfl * 10.f;
+ vu = wa1[iu] + dmax(r__1,r__2);
+ } else {
+/* Computing MAX */
+ r__1 = (wa1[n] - wa1[1]) * .5f, r__2 = ulp * 10.f *
+ temp3, r__1 = max(r__1,r__2), r__2 = rtunfl *
+ 10.f;
+ vu = wa1[n] + dmax(r__1,r__2);
+ }
+ } else {
+ vl = 0.f;
+ vu = 1.f;
+ }
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d1[i__] = a[i__ + i__ * a_dim1];
+/* L390: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d2[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L400: */
+ }
+ s_copy(srnamc_1.srnamt, "SSTEVX", (ftnlen)32, (ftnlen)6);
+ sstevx_("V", "V", &n, &d1[1], &d2[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &work[1], &
+ iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___62.ciunit = *nounit;
+ s_wsfe(&io___62);
+ do_fio(&c__1, "SSTEVX(V,V)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[13] = ulpinv;
+ result[14] = ulpinv;
+ result[15] = ulpinv;
+ goto L440;
+ }
+ }
+
+ if (m2 == 0 && n > 0) {
+ result[13] = ulpinv;
+ result[14] = ulpinv;
+ result[15] = ulpinv;
+ goto L440;
+ }
+
+/* Do tests 13 and 14. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d3[i__] = a[i__ + i__ * a_dim1];
+/* L410: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L420: */
+ }
+ i__3 = max(1,m2);
+ sstt22_(&n, &m2, &c__0, &d3[1], &d4[1], &wa2[1], &d2[1], &z__[
+ z_offset], ldu, &work[1], &i__3, &result[13]);
+
+ ntest = 15;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L430: */
+ }
+ s_copy(srnamc_1.srnamt, "SSTEVX", (ftnlen)32, (ftnlen)6);
+ sstevx_("N", "V", &n, &d3[1], &d4[1], &vl, &vu, &il, &iu, &
+ abstol, &m3, &wa3[1], &z__[z_offset], ldu, &work[1], &
+ iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___63.ciunit = *nounit;
+ s_wsfe(&io___63);
+ do_fio(&c__1, "SSTEVX(N,V)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[15] = ulpinv;
+ goto L440;
+ }
+ }
+
+/* Do test 15. */
+
+ temp1 = ssxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = ssxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+/* Computing MAX */
+ r__1 = unfl, r__2 = temp3 * ulp;
+ result[15] = (temp1 + temp2) / dmax(r__1,r__2);
+
+L440:
+
+ ntest = 16;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d1[i__] = a[i__ + i__ * a_dim1];
+/* L450: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d2[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L460: */
+ }
+ s_copy(srnamc_1.srnamt, "SSTEVD", (ftnlen)32, (ftnlen)6);
+ sstevd_("V", &n, &d1[1], &d2[1], &z__[z_offset], ldu, &work[1]
+, &lwedc, &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___64.ciunit = *nounit;
+ s_wsfe(&io___64);
+ do_fio(&c__1, "SSTEVD(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[16] = ulpinv;
+ result[17] = ulpinv;
+ result[18] = ulpinv;
+ goto L510;
+ }
+ }
+
+/* Do tests 16 and 17. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d3[i__] = a[i__ + i__ * a_dim1];
+/* L470: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L480: */
+ }
+ sstt21_(&n, &c__0, &d3[1], &d4[1], &d1[1], &d2[1], &z__[
+ z_offset], ldu, &work[1], &result[16]);
+
+ ntest = 18;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L490: */
+ }
+ s_copy(srnamc_1.srnamt, "SSTEVD", (ftnlen)32, (ftnlen)6);
+ sstevd_("N", &n, &d3[1], &d4[1], &z__[z_offset], ldu, &work[1]
+, &lwedc, &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___65.ciunit = *nounit;
+ s_wsfe(&io___65);
+ do_fio(&c__1, "SSTEVD(N)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[18] = ulpinv;
+ goto L510;
+ }
+ }
+
+/* Do test 18. */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = eveigs[j], dabs(r__1)), r__3
+ = max(r__3,r__4), r__4 = (r__2 = d3[j], dabs(r__2)
+ );
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = eveigs[j] - d3[j], dabs(r__1)
+ );
+ temp2 = dmax(r__2,r__3);
+/* L500: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[18] = temp2 / dmax(r__1,r__2);
+
+L510:
+
+ ntest = 19;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d1[i__] = a[i__ + i__ * a_dim1];
+/* L520: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d2[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L530: */
+ }
+ s_copy(srnamc_1.srnamt, "SSTEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ sstevr_("V", "I", &n, &d1[1], &d2[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &iwork[1],
+ &work[1], lwork, &iwork[(n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___66.ciunit = *nounit;
+ s_wsfe(&io___66);
+ do_fio(&c__1, "SSTEVR(V,I)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[19] = ulpinv;
+ result[20] = ulpinv;
+ result[21] = ulpinv;
+ goto L570;
+ }
+ }
+
+/* DO tests 19 and 20. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d3[i__] = a[i__ + i__ * a_dim1];
+/* L540: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L550: */
+ }
+ i__3 = max(1,m2);
+ sstt22_(&n, &m2, &c__0, &d3[1], &d4[1], &wa2[1], &d2[1], &z__[
+ z_offset], ldu, &work[1], &i__3, &result[19]);
+
+
+ ntest = 21;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L560: */
+ }
+ s_copy(srnamc_1.srnamt, "SSTEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ sstevr_("N", "I", &n, &d3[1], &d4[1], &vl, &vu, &il, &iu, &
+ abstol, &m3, &wa3[1], &z__[z_offset], ldu, &iwork[1],
+ &work[1], lwork, &iwork[(n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___67.ciunit = *nounit;
+ s_wsfe(&io___67);
+ do_fio(&c__1, "SSTEVR(N,I)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[21] = ulpinv;
+ goto L570;
+ }
+ }
+
+/* Do test 21. */
+
+ temp1 = ssxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = ssxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * temp3;
+ result[21] = (temp1 + temp2) / dmax(r__1,r__2);
+
+L570:
+
+ ntest = 21;
+ if (n > 0) {
+ if (il != 1) {
+/* Computing MAX */
+ r__1 = (wa1[il] - wa1[il - 1]) * .5f, r__2 = ulp *
+ 10.f * temp3, r__1 = max(r__1,r__2), r__2 =
+ rtunfl * 10.f;
+ vl = wa1[il] - dmax(r__1,r__2);
+ } else {
+/* Computing MAX */
+ r__1 = (wa1[n] - wa1[1]) * .5f, r__2 = ulp * 10.f *
+ temp3, r__1 = max(r__1,r__2), r__2 = rtunfl *
+ 10.f;
+ vl = wa1[1] - dmax(r__1,r__2);
+ }
+ if (iu != n) {
+/* Computing MAX */
+ r__1 = (wa1[iu + 1] - wa1[iu]) * .5f, r__2 = ulp *
+ 10.f * temp3, r__1 = max(r__1,r__2), r__2 =
+ rtunfl * 10.f;
+ vu = wa1[iu] + dmax(r__1,r__2);
+ } else {
+/* Computing MAX */
+ r__1 = (wa1[n] - wa1[1]) * .5f, r__2 = ulp * 10.f *
+ temp3, r__1 = max(r__1,r__2), r__2 = rtunfl *
+ 10.f;
+ vu = wa1[n] + dmax(r__1,r__2);
+ }
+ } else {
+ vl = 0.f;
+ vu = 1.f;
+ }
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d1[i__] = a[i__ + i__ * a_dim1];
+/* L580: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d2[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L590: */
+ }
+ s_copy(srnamc_1.srnamt, "SSTEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ sstevr_("V", "V", &n, &d1[1], &d2[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &iwork[1],
+ &work[1], lwork, &iwork[(n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___68.ciunit = *nounit;
+ s_wsfe(&io___68);
+ do_fio(&c__1, "SSTEVR(V,V)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[22] = ulpinv;
+ result[23] = ulpinv;
+ result[24] = ulpinv;
+ goto L630;
+ }
+ }
+
+ if (m2 == 0 && n > 0) {
+ result[22] = ulpinv;
+ result[23] = ulpinv;
+ result[24] = ulpinv;
+ goto L630;
+ }
+
+/* Do tests 22 and 23. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d3[i__] = a[i__ + i__ * a_dim1];
+/* L600: */
+ }
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L610: */
+ }
+ i__3 = max(1,m2);
+ sstt22_(&n, &m2, &c__0, &d3[1], &d4[1], &wa2[1], &d2[1], &z__[
+ z_offset], ldu, &work[1], &i__3, &result[22]);
+
+ ntest = 24;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d4[i__] = a[i__ + 1 + i__ * a_dim1];
+/* L620: */
+ }
+ s_copy(srnamc_1.srnamt, "SSTEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ sstevr_("N", "V", &n, &d3[1], &d4[1], &vl, &vu, &il, &iu, &
+ abstol, &m3, &wa3[1], &z__[z_offset], ldu, &iwork[1],
+ &work[1], lwork, &iwork[(n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___69.ciunit = *nounit;
+ s_wsfe(&io___69);
+ do_fio(&c__1, "SSTEVR(N,V)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[24] = ulpinv;
+ goto L630;
+ }
+ }
+
+/* Do test 24. */
+
+ temp1 = ssxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = ssxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+/* Computing MAX */
+ r__1 = unfl, r__2 = temp3 * ulp;
+ result[24] = (temp1 + temp2) / dmax(r__1,r__2);
+
+L630:
+
+
+
+ ;
+ } else {
+
+ for (i__ = 1; i__ <= 24; ++i__) {
+ result[i__] = 0.f;
+/* L640: */
+ }
+ ntest = 24;
+ }
+
+/* Perform remaining tests storing upper or lower triangular */
+/* part of matrix. */
+
+ for (iuplo = 0; iuplo <= 1; ++iuplo) {
+ if (iuplo == 0) {
+ *(unsigned char *)uplo = 'L';
+ } else {
+ *(unsigned char *)uplo = 'U';
+ }
+
+/* 4) Call SSYEV and SSYEVX. */
+
+ slacpy_(" ", &n, &n, &a[a_offset], lda, &v[v_offset], ldu);
+
+ ++ntest;
+ s_copy(srnamc_1.srnamt, "SSYEV", (ftnlen)32, (ftnlen)5);
+ ssyev_("V", uplo, &n, &a[a_offset], ldu, &d1[1], &work[1],
+ lwork, &iinfo);
+ if (iinfo != 0) {
+ io___72.ciunit = *nounit;
+ s_wsfe(&io___72);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "SSYEV(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L660;
+ }
+ }
+
+/* Do tests 25 and 26 (or +54) */
+
+ ssyt21_(&c__1, uplo, &n, &c__0, &v[v_offset], ldu, &d1[1], &
+ d2[1], &a[a_offset], ldu, &z__[z_offset], ldu, &tau[1]
+, &work[1], &result[ntest]);
+
+ slacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ ntest += 2;
+ s_copy(srnamc_1.srnamt, "SSYEV", (ftnlen)32, (ftnlen)5);
+ ssyev_("N", uplo, &n, &a[a_offset], ldu, &d3[1], &work[1],
+ lwork, &iinfo);
+ if (iinfo != 0) {
+ io___73.ciunit = *nounit;
+ s_wsfe(&io___73);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "SSYEV(N,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L660;
+ }
+ }
+
+/* Do test 27 (or +54) */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d1[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = d3[j], dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d1[j] - d3[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L650: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[ntest] = temp2 / dmax(r__1,r__2);
+
+L660:
+ slacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ ++ntest;
+
+ if (n > 0) {
+/* Computing MAX */
+ r__2 = dabs(d1[1]), r__3 = (r__1 = d1[n], dabs(r__1));
+ temp3 = dmax(r__2,r__3);
+ if (il != 1) {
+/* Computing MAX */
+ r__1 = (d1[il] - d1[il - 1]) * .5f, r__2 = ulp * 10.f
+ * temp3, r__1 = max(r__1,r__2), r__2 = rtunfl
+ * 10.f;
+ vl = d1[il] - dmax(r__1,r__2);
+ } else if (n > 0) {
+/* Computing MAX */
+ r__1 = (d1[n] - d1[1]) * .5f, r__2 = ulp * 10.f *
+ temp3, r__1 = max(r__1,r__2), r__2 = rtunfl *
+ 10.f;
+ vl = d1[1] - dmax(r__1,r__2);
+ }
+ if (iu != n) {
+/* Computing MAX */
+ r__1 = (d1[iu + 1] - d1[iu]) * .5f, r__2 = ulp * 10.f
+ * temp3, r__1 = max(r__1,r__2), r__2 = rtunfl
+ * 10.f;
+ vu = d1[iu] + dmax(r__1,r__2);
+ } else if (n > 0) {
+/* Computing MAX */
+ r__1 = (d1[n] - d1[1]) * .5f, r__2 = ulp * 10.f *
+ temp3, r__1 = max(r__1,r__2), r__2 = rtunfl *
+ 10.f;
+ vu = d1[n] + dmax(r__1,r__2);
+ }
+ } else {
+ temp3 = 0.f;
+ vl = 0.f;
+ vu = 1.f;
+ }
+
+ s_copy(srnamc_1.srnamt, "SSYEVX", (ftnlen)32, (ftnlen)6);
+ ssyevx_("V", "A", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m, &wa1[1], &z__[z_offset], ldu, &work[
+ 1], lwork, &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___74.ciunit = *nounit;
+ s_wsfe(&io___74);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSYEVX(V,A,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L680;
+ }
+ }
+
+/* Do tests 28 and 29 (or +54) */
+
+ slacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ ssyt21_(&c__1, uplo, &n, &c__0, &a[a_offset], ldu, &d1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &result[ntest]);
+
+ ntest += 2;
+ s_copy(srnamc_1.srnamt, "SSYEVX", (ftnlen)32, (ftnlen)6);
+ ssyevx_("N", "A", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ work[1], lwork, &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___75.ciunit = *nounit;
+ s_wsfe(&io___75);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSYEVX(N,A,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L680;
+ }
+ }
+
+/* Do test 30 (or +54) */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = wa1[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = wa2[j], dabs(r__2))
+ ;
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = wa1[j] - wa2[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L670: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[ntest] = temp2 / dmax(r__1,r__2);
+
+L680:
+
+ ++ntest;
+ slacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ s_copy(srnamc_1.srnamt, "SSYEVX", (ftnlen)32, (ftnlen)6);
+ ssyevx_("V", "I", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ work[1], lwork, &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___76.ciunit = *nounit;
+ s_wsfe(&io___76);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSYEVX(V,I,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L690;
+ }
+ }
+
+/* Do tests 31 and 32 (or +54) */
+
+ slacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ ssyt22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &result[ntest]);
+
+ ntest += 2;
+ slacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ s_copy(srnamc_1.srnamt, "SSYEVX", (ftnlen)32, (ftnlen)6);
+ ssyevx_("N", "I", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m3, &wa3[1], &z__[z_offset], ldu, &
+ work[1], lwork, &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___77.ciunit = *nounit;
+ s_wsfe(&io___77);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSYEVX(N,I,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L690;
+ }
+ }
+
+/* Do test 33 (or +54) */
+
+ temp1 = ssxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = ssxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * temp3;
+ result[ntest] = (temp1 + temp2) / dmax(r__1,r__2);
+L690:
+
+ ++ntest;
+ slacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ s_copy(srnamc_1.srnamt, "SSYEVX", (ftnlen)32, (ftnlen)6);
+ ssyevx_("V", "V", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ work[1], lwork, &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___78.ciunit = *nounit;
+ s_wsfe(&io___78);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSYEVX(V,V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L700;
+ }
+ }
+
+/* Do tests 34 and 35 (or +54) */
+
+ slacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ ssyt22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &result[ntest]);
+
+ ntest += 2;
+ slacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ s_copy(srnamc_1.srnamt, "SSYEVX", (ftnlen)32, (ftnlen)6);
+ ssyevx_("N", "V", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m3, &wa3[1], &z__[z_offset], ldu, &
+ work[1], lwork, &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___79.ciunit = *nounit;
+ s_wsfe(&io___79);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSYEVX(N,V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L700;
+ }
+ }
+
+ if (m3 == 0 && n > 0) {
+ result[ntest] = ulpinv;
+ goto L700;
+ }
+
+/* Do test 36 (or +54) */
+
+ temp1 = ssxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = ssxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ r__2 = dabs(wa1[1]), r__3 = (r__1 = wa1[n], dabs(r__1));
+ temp3 = dmax(r__2,r__3);
+ } else {
+ temp3 = 0.f;
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / dmax(r__1,r__2);
+
+L700:
+
+/* 5) Call SSPEV and SSPEVX. */
+
+ slacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+/* Load array WORK with the upper or lower triangular */
+/* part of the matrix in packed form. */
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L710: */
+ }
+/* L720: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L730: */
+ }
+/* L740: */
+ }
+ }
+
+ ++ntest;
+ s_copy(srnamc_1.srnamt, "SSPEV", (ftnlen)32, (ftnlen)5);
+ sspev_("V", uplo, &n, &work[1], &d1[1], &z__[z_offset], ldu, &
+ v[v_offset], &iinfo);
+ if (iinfo != 0) {
+ io___81.ciunit = *nounit;
+ s_wsfe(&io___81);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "SSPEV(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L800;
+ }
+ }
+
+/* Do tests 37 and 38 (or +54) */
+
+ ssyt21_(&c__1, uplo, &n, &c__0, &a[a_offset], lda, &d1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &result[ntest]);
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L750: */
+ }
+/* L760: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L770: */
+ }
+/* L780: */
+ }
+ }
+
+ ntest += 2;
+ s_copy(srnamc_1.srnamt, "SSPEV", (ftnlen)32, (ftnlen)5);
+ sspev_("N", uplo, &n, &work[1], &d3[1], &z__[z_offset], ldu, &
+ v[v_offset], &iinfo);
+ if (iinfo != 0) {
+ io___82.ciunit = *nounit;
+ s_wsfe(&io___82);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "SSPEV(N,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L800;
+ }
+ }
+
+/* Do test 39 (or +54) */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d1[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = d3[j], dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d1[j] - d3[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L790: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[ntest] = temp2 / dmax(r__1,r__2);
+
+/* Load array WORK with the upper or lower triangular part */
+/* of the matrix in packed form. */
+
+L800:
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L810: */
+ }
+/* L820: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L830: */
+ }
+/* L840: */
+ }
+ }
+
+ ++ntest;
+
+ if (n > 0) {
+/* Computing MAX */
+ r__2 = dabs(d1[1]), r__3 = (r__1 = d1[n], dabs(r__1));
+ temp3 = dmax(r__2,r__3);
+ if (il != 1) {
+/* Computing MAX */
+ r__1 = (d1[il] - d1[il - 1]) * .5f, r__2 = ulp * 10.f
+ * temp3, r__1 = max(r__1,r__2), r__2 = rtunfl
+ * 10.f;
+ vl = d1[il] - dmax(r__1,r__2);
+ } else if (n > 0) {
+/* Computing MAX */
+ r__1 = (d1[n] - d1[1]) * .5f, r__2 = ulp * 10.f *
+ temp3, r__1 = max(r__1,r__2), r__2 = rtunfl *
+ 10.f;
+ vl = d1[1] - dmax(r__1,r__2);
+ }
+ if (iu != n) {
+/* Computing MAX */
+ r__1 = (d1[iu + 1] - d1[iu]) * .5f, r__2 = ulp * 10.f
+ * temp3, r__1 = max(r__1,r__2), r__2 = rtunfl
+ * 10.f;
+ vu = d1[iu] + dmax(r__1,r__2);
+ } else if (n > 0) {
+/* Computing MAX */
+ r__1 = (d1[n] - d1[1]) * .5f, r__2 = ulp * 10.f *
+ temp3, r__1 = max(r__1,r__2), r__2 = rtunfl *
+ 10.f;
+ vu = d1[n] + dmax(r__1,r__2);
+ }
+ } else {
+ temp3 = 0.f;
+ vl = 0.f;
+ vu = 1.f;
+ }
+
+ s_copy(srnamc_1.srnamt, "SSPEVX", (ftnlen)32, (ftnlen)6);
+ sspevx_("V", "A", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m, &wa1[1], &z__[z_offset], ldu, &v[v_offset]
+, &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___83.ciunit = *nounit;
+ s_wsfe(&io___83);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSPEVX(V,A,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L900;
+ }
+ }
+
+/* Do tests 40 and 41 (or +54) */
+
+ ssyt21_(&c__1, uplo, &n, &c__0, &a[a_offset], ldu, &wa1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L850: */
+ }
+/* L860: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L870: */
+ }
+/* L880: */
+ }
+ }
+
+ s_copy(srnamc_1.srnamt, "SSPEVX", (ftnlen)32, (ftnlen)6);
+ sspevx_("N", "A", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &v[
+ v_offset], &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___84.ciunit = *nounit;
+ s_wsfe(&io___84);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSPEVX(N,A,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L900;
+ }
+ }
+
+/* Do test 42 (or +54) */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = wa1[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = wa2[j], dabs(r__2))
+ ;
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = wa1[j] - wa2[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L890: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[ntest] = temp2 / dmax(r__1,r__2);
+
+L900:
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L910: */
+ }
+/* L920: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L930: */
+ }
+/* L940: */
+ }
+ }
+
+ ++ntest;
+
+ s_copy(srnamc_1.srnamt, "SSPEVX", (ftnlen)32, (ftnlen)6);
+ sspevx_("V", "I", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &v[
+ v_offset], &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___85.ciunit = *nounit;
+ s_wsfe(&io___85);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSPEVX(V,I,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L990;
+ }
+ }
+
+/* Do tests 43 and 44 (or +54) */
+
+ ssyt22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L950: */
+ }
+/* L960: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L970: */
+ }
+/* L980: */
+ }
+ }
+
+ s_copy(srnamc_1.srnamt, "SSPEVX", (ftnlen)32, (ftnlen)6);
+ sspevx_("N", "I", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m3, &wa3[1], &z__[z_offset], ldu, &v[
+ v_offset], &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___86.ciunit = *nounit;
+ s_wsfe(&io___86);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSPEVX(N,I,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L990;
+ }
+ }
+
+ if (m3 == 0 && n > 0) {
+ result[ntest] = ulpinv;
+ goto L990;
+ }
+
+/* Do test 45 (or +54) */
+
+ temp1 = ssxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = ssxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ r__2 = dabs(wa1[1]), r__3 = (r__1 = wa1[n], dabs(r__1));
+ temp3 = dmax(r__2,r__3);
+ } else {
+ temp3 = 0.f;
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / dmax(r__1,r__2);
+
+L990:
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L1000: */
+ }
+/* L1010: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L1020: */
+ }
+/* L1030: */
+ }
+ }
+
+ ++ntest;
+
+ s_copy(srnamc_1.srnamt, "SSPEVX", (ftnlen)32, (ftnlen)6);
+ sspevx_("V", "V", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &v[
+ v_offset], &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___87.ciunit = *nounit;
+ s_wsfe(&io___87);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSPEVX(V,V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1080;
+ }
+ }
+
+/* Do tests 46 and 47 (or +54) */
+
+ ssyt22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L1040: */
+ }
+/* L1050: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L1060: */
+ }
+/* L1070: */
+ }
+ }
+
+ s_copy(srnamc_1.srnamt, "SSPEVX", (ftnlen)32, (ftnlen)6);
+ sspevx_("N", "V", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m3, &wa3[1], &z__[z_offset], ldu, &v[
+ v_offset], &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___88.ciunit = *nounit;
+ s_wsfe(&io___88);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSPEVX(N,V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1080;
+ }
+ }
+
+ if (m3 == 0 && n > 0) {
+ result[ntest] = ulpinv;
+ goto L1080;
+ }
+
+/* Do test 48 (or +54) */
+
+ temp1 = ssxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = ssxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ r__2 = dabs(wa1[1]), r__3 = (r__1 = wa1[n], dabs(r__1));
+ temp3 = dmax(r__2,r__3);
+ } else {
+ temp3 = 0.f;
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / dmax(r__1,r__2);
+
+L1080:
+
+/* 6) Call SSBEV and SSBEVX. */
+
+ if (jtype <= 7) {
+ kd = 1;
+ } else if (jtype >= 8 && jtype <= 15) {
+/* Computing MAX */
+ i__3 = n - 1;
+ kd = max(i__3,0);
+ } else {
+ kd = ihbw;
+ }
+
+/* Load array V with the upper or lower triangular part */
+/* of the matrix in band form. */
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kd;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__) {
+ v[kd + 1 + i__ - j + j * v_dim1] = a[i__ + j *
+ a_dim1];
+/* L1090: */
+ }
+/* L1100: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + kd;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ v[i__ + 1 - j + j * v_dim1] = a[i__ + j * a_dim1];
+/* L1110: */
+ }
+/* L1120: */
+ }
+ }
+
+ ++ntest;
+ s_copy(srnamc_1.srnamt, "SSBEV", (ftnlen)32, (ftnlen)5);
+ ssbev_("V", uplo, &n, &kd, &v[v_offset], ldu, &d1[1], &z__[
+ z_offset], ldu, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___90.ciunit = *nounit;
+ s_wsfe(&io___90);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "SSBEV(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1180;
+ }
+ }
+
+/* Do tests 49 and 50 (or ... ) */
+
+ ssyt21_(&c__1, uplo, &n, &c__0, &a[a_offset], lda, &d1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &result[ntest]);
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__7 = 1, i__4 = j - kd;
+ i__5 = j;
+ for (i__ = max(i__7,i__4); i__ <= i__5; ++i__) {
+ v[kd + 1 + i__ - j + j * v_dim1] = a[i__ + j *
+ a_dim1];
+/* L1130: */
+ }
+/* L1140: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__7 = n, i__4 = j + kd;
+ i__5 = min(i__7,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ v[i__ + 1 - j + j * v_dim1] = a[i__ + j * a_dim1];
+/* L1150: */
+ }
+/* L1160: */
+ }
+ }
+
+ ntest += 2;
+ s_copy(srnamc_1.srnamt, "SSBEV", (ftnlen)32, (ftnlen)5);
+ ssbev_("N", uplo, &n, &kd, &v[v_offset], ldu, &d3[1], &z__[
+ z_offset], ldu, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___91.ciunit = *nounit;
+ s_wsfe(&io___91);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "SSBEV(N,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1180;
+ }
+ }
+
+/* Do test 51 (or +54) */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d1[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = d3[j], dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d1[j] - d3[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L1170: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[ntest] = temp2 / dmax(r__1,r__2);
+
+/* Load array V with the upper or lower triangular part */
+/* of the matrix in band form. */
+
+L1180:
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__7 = j - kd;
+ i__4 = j;
+ for (i__ = max(i__5,i__7); i__ <= i__4; ++i__) {
+ v[kd + 1 + i__ - j + j * v_dim1] = a[i__ + j *
+ a_dim1];
+/* L1190: */
+ }
+/* L1200: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__5 = n, i__7 = j + kd;
+ i__4 = min(i__5,i__7);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ v[i__ + 1 - j + j * v_dim1] = a[i__ + j * a_dim1];
+/* L1210: */
+ }
+/* L1220: */
+ }
+ }
+
+ ++ntest;
+ s_copy(srnamc_1.srnamt, "SSBEVX", (ftnlen)32, (ftnlen)6);
+ ssbevx_("V", "A", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m, &wa2[
+ 1], &z__[z_offset], ldu, &work[1], &iwork[1], &iwork[
+ n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___92.ciunit = *nounit;
+ s_wsfe(&io___92);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSBEVX(V,A,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1280;
+ }
+ }
+
+/* Do tests 52 and 53 (or +54) */
+
+ ssyt21_(&c__1, uplo, &n, &c__0, &a[a_offset], ldu, &wa2[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kd;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__) {
+ v[kd + 1 + i__ - j + j * v_dim1] = a[i__ + j *
+ a_dim1];
+/* L1230: */
+ }
+/* L1240: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + kd;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ v[i__ + 1 - j + j * v_dim1] = a[i__ + j * a_dim1];
+/* L1250: */
+ }
+/* L1260: */
+ }
+ }
+
+ s_copy(srnamc_1.srnamt, "SSBEVX", (ftnlen)32, (ftnlen)6);
+ ssbevx_("N", "A", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m3, &
+ wa3[1], &z__[z_offset], ldu, &work[1], &iwork[1], &
+ iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___93.ciunit = *nounit;
+ s_wsfe(&io___93);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSBEVX(N,A,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1280;
+ }
+ }
+
+/* Do test 54 (or +54) */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = wa2[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = wa3[j], dabs(r__2))
+ ;
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = wa2[j] - wa3[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L1270: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[ntest] = temp2 / dmax(r__1,r__2);
+
+L1280:
+ ++ntest;
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__7 = 1, i__4 = j - kd;
+ i__5 = j;
+ for (i__ = max(i__7,i__4); i__ <= i__5; ++i__) {
+ v[kd + 1 + i__ - j + j * v_dim1] = a[i__ + j *
+ a_dim1];
+/* L1290: */
+ }
+/* L1300: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__7 = n, i__4 = j + kd;
+ i__5 = min(i__7,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ v[i__ + 1 - j + j * v_dim1] = a[i__ + j * a_dim1];
+/* L1310: */
+ }
+/* L1320: */
+ }
+ }
+
+ s_copy(srnamc_1.srnamt, "SSBEVX", (ftnlen)32, (ftnlen)6);
+ ssbevx_("V", "I", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m2, &
+ wa2[1], &z__[z_offset], ldu, &work[1], &iwork[1], &
+ iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___94.ciunit = *nounit;
+ s_wsfe(&io___94);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSBEVX(V,I,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1370;
+ }
+ }
+
+/* Do tests 55 and 56 (or +54) */
+
+ ssyt22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__7 = j - kd;
+ i__4 = j;
+ for (i__ = max(i__5,i__7); i__ <= i__4; ++i__) {
+ v[kd + 1 + i__ - j + j * v_dim1] = a[i__ + j *
+ a_dim1];
+/* L1330: */
+ }
+/* L1340: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__5 = n, i__7 = j + kd;
+ i__4 = min(i__5,i__7);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ v[i__ + 1 - j + j * v_dim1] = a[i__ + j * a_dim1];
+/* L1350: */
+ }
+/* L1360: */
+ }
+ }
+
+ s_copy(srnamc_1.srnamt, "SSBEVX", (ftnlen)32, (ftnlen)6);
+ ssbevx_("N", "I", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m3, &
+ wa3[1], &z__[z_offset], ldu, &work[1], &iwork[1], &
+ iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___95.ciunit = *nounit;
+ s_wsfe(&io___95);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSBEVX(N,I,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1370;
+ }
+ }
+
+/* Do test 57 (or +54) */
+
+ temp1 = ssxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = ssxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ r__2 = dabs(wa1[1]), r__3 = (r__1 = wa1[n], dabs(r__1));
+ temp3 = dmax(r__2,r__3);
+ } else {
+ temp3 = 0.f;
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / dmax(r__1,r__2);
+
+L1370:
+ ++ntest;
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kd;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__) {
+ v[kd + 1 + i__ - j + j * v_dim1] = a[i__ + j *
+ a_dim1];
+/* L1380: */
+ }
+/* L1390: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + kd;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ v[i__ + 1 - j + j * v_dim1] = a[i__ + j * a_dim1];
+/* L1400: */
+ }
+/* L1410: */
+ }
+ }
+
+ s_copy(srnamc_1.srnamt, "SSBEVX", (ftnlen)32, (ftnlen)6);
+ ssbevx_("V", "V", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m2, &
+ wa2[1], &z__[z_offset], ldu, &work[1], &iwork[1], &
+ iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___96.ciunit = *nounit;
+ s_wsfe(&io___96);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSBEVX(V,V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1460;
+ }
+ }
+
+/* Do tests 58 and 59 (or +54) */
+
+ ssyt22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__7 = 1, i__4 = j - kd;
+ i__5 = j;
+ for (i__ = max(i__7,i__4); i__ <= i__5; ++i__) {
+ v[kd + 1 + i__ - j + j * v_dim1] = a[i__ + j *
+ a_dim1];
+/* L1420: */
+ }
+/* L1430: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__7 = n, i__4 = j + kd;
+ i__5 = min(i__7,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ v[i__ + 1 - j + j * v_dim1] = a[i__ + j * a_dim1];
+/* L1440: */
+ }
+/* L1450: */
+ }
+ }
+
+ s_copy(srnamc_1.srnamt, "SSBEVX", (ftnlen)32, (ftnlen)6);
+ ssbevx_("N", "V", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m3, &
+ wa3[1], &z__[z_offset], ldu, &work[1], &iwork[1], &
+ iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___97.ciunit = *nounit;
+ s_wsfe(&io___97);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSBEVX(N,V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1460;
+ }
+ }
+
+ if (m3 == 0 && n > 0) {
+ result[ntest] = ulpinv;
+ goto L1460;
+ }
+
+/* Do test 60 (or +54) */
+
+ temp1 = ssxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = ssxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ r__2 = dabs(wa1[1]), r__3 = (r__1 = wa1[n], dabs(r__1));
+ temp3 = dmax(r__2,r__3);
+ } else {
+ temp3 = 0.f;
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / dmax(r__1,r__2);
+
+L1460:
+
+/* 7) Call SSYEVD */
+
+ slacpy_(" ", &n, &n, &a[a_offset], lda, &v[v_offset], ldu);
+
+ ++ntest;
+ s_copy(srnamc_1.srnamt, "SSYEVD", (ftnlen)32, (ftnlen)6);
+ ssyevd_("V", uplo, &n, &a[a_offset], ldu, &d1[1], &work[1], &
+ lwedc, &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___98.ciunit = *nounit;
+ s_wsfe(&io___98);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "SSYEVD(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__3, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1480;
+ }
+ }
+
+/* Do tests 61 and 62 (or +54) */
+
+ ssyt21_(&c__1, uplo, &n, &c__0, &v[v_offset], ldu, &d1[1], &
+ d2[1], &a[a_offset], ldu, &z__[z_offset], ldu, &tau[1]
+, &work[1], &result[ntest]);
+
+ slacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ ntest += 2;
+ s_copy(srnamc_1.srnamt, "SSYEVD", (ftnlen)32, (ftnlen)6);
+ ssyevd_("N", uplo, &n, &a[a_offset], ldu, &d3[1], &work[1], &
+ lwedc, &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___99.ciunit = *nounit;
+ s_wsfe(&io___99);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "SSYEVD(N,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__3, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1480;
+ }
+ }
+
+/* Do test 63 (or +54) */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d1[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = d3[j], dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d1[j] - d3[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L1470: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[ntest] = temp2 / dmax(r__1,r__2);
+
+L1480:
+
+/* 8) Call SSPEVD. */
+
+ slacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+/* Load array WORK with the upper or lower triangular */
+/* part of the matrix in packed form. */
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__5 = j;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L1490: */
+ }
+/* L1500: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__5 = n;
+ for (i__ = j; i__ <= i__5; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L1510: */
+ }
+/* L1520: */
+ }
+ }
+
+ ++ntest;
+ s_copy(srnamc_1.srnamt, "SSPEVD", (ftnlen)32, (ftnlen)6);
+ i__3 = lwedc - indx + 1;
+ sspevd_("V", uplo, &n, &work[1], &d1[1], &z__[z_offset], ldu,
+ &work[indx], &i__3, &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___100.ciunit = *nounit;
+ s_wsfe(&io___100);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "SSPEVD(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__3, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1580;
+ }
+ }
+
+/* Do tests 64 and 65 (or +54) */
+
+ ssyt21_(&c__1, uplo, &n, &c__0, &a[a_offset], lda, &d1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &result[ntest]);
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__5 = j;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L1530: */
+ }
+/* L1540: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__5 = n;
+ for (i__ = j; i__ <= i__5; ++i__) {
+ work[indx] = a[i__ + j * a_dim1];
+ ++indx;
+/* L1550: */
+ }
+/* L1560: */
+ }
+ }
+
+ ntest += 2;
+ s_copy(srnamc_1.srnamt, "SSPEVD", (ftnlen)32, (ftnlen)6);
+ i__3 = lwedc - indx + 1;
+ sspevd_("N", uplo, &n, &work[1], &d3[1], &z__[z_offset], ldu,
+ &work[indx], &i__3, &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___101.ciunit = *nounit;
+ s_wsfe(&io___101);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "SSPEVD(N,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__3, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1580;
+ }
+ }
+
+/* Do test 66 (or +54) */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d1[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = d3[j], dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d1[j] - d3[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L1570: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[ntest] = temp2 / dmax(r__1,r__2);
+L1580:
+
+/* 9) Call SSBEVD. */
+
+ if (jtype <= 7) {
+ kd = 1;
+ } else if (jtype >= 8 && jtype <= 15) {
+/* Computing MAX */
+ i__3 = n - 1;
+ kd = max(i__3,0);
+ } else {
+ kd = ihbw;
+ }
+
+/* Load array V with the upper or lower triangular part */
+/* of the matrix in band form. */
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__7 = j - kd;
+ i__4 = j;
+ for (i__ = max(i__5,i__7); i__ <= i__4; ++i__) {
+ v[kd + 1 + i__ - j + j * v_dim1] = a[i__ + j *
+ a_dim1];
+/* L1590: */
+ }
+/* L1600: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__5 = n, i__7 = j + kd;
+ i__4 = min(i__5,i__7);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ v[i__ + 1 - j + j * v_dim1] = a[i__ + j * a_dim1];
+/* L1610: */
+ }
+/* L1620: */
+ }
+ }
+
+ ++ntest;
+ s_copy(srnamc_1.srnamt, "SSBEVD", (ftnlen)32, (ftnlen)6);
+ ssbevd_("V", uplo, &n, &kd, &v[v_offset], ldu, &d1[1], &z__[
+ z_offset], ldu, &work[1], &lwedc, &iwork[1], &liwedc,
+ &iinfo);
+ if (iinfo != 0) {
+ io___102.ciunit = *nounit;
+ s_wsfe(&io___102);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "SSBEVD(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__3, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1680;
+ }
+ }
+
+/* Do tests 67 and 68 (or +54) */
+
+ ssyt21_(&c__1, uplo, &n, &c__0, &a[a_offset], lda, &d1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &result[ntest]);
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kd;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__) {
+ v[kd + 1 + i__ - j + j * v_dim1] = a[i__ + j *
+ a_dim1];
+/* L1630: */
+ }
+/* L1640: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + kd;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ v[i__ + 1 - j + j * v_dim1] = a[i__ + j * a_dim1];
+/* L1650: */
+ }
+/* L1660: */
+ }
+ }
+
+ ntest += 2;
+ s_copy(srnamc_1.srnamt, "SSBEVD", (ftnlen)32, (ftnlen)6);
+ ssbevd_("N", uplo, &n, &kd, &v[v_offset], ldu, &d3[1], &z__[
+ z_offset], ldu, &work[1], &lwedc, &iwork[1], &liwedc,
+ &iinfo);
+ if (iinfo != 0) {
+ io___103.ciunit = *nounit;
+ s_wsfe(&io___103);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "SSBEVD(N,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__3, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1680;
+ }
+ }
+
+/* Do test 69 (or +54) */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = d1[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = d3[j], dabs(r__2));
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = d1[j] - d3[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L1670: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[ntest] = temp2 / dmax(r__1,r__2);
+
+L1680:
+
+
+ slacpy_(" ", &n, &n, &a[a_offset], lda, &v[v_offset], ldu);
+ ++ntest;
+ s_copy(srnamc_1.srnamt, "SSYEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ ssyevr_("V", "A", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m, &wa1[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &iwork[(n << 1) + 1], &
+ i__3, &iinfo);
+ if (iinfo != 0) {
+ io___104.ciunit = *nounit;
+ s_wsfe(&io___104);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSYEVR(V,A,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1700;
+ }
+ }
+
+/* Do tests 70 and 71 (or ... ) */
+
+ slacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ ssyt21_(&c__1, uplo, &n, &c__0, &a[a_offset], ldu, &wa1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &result[ntest]);
+
+ ntest += 2;
+ s_copy(srnamc_1.srnamt, "SSYEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ ssyevr_("N", "A", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &iwork[(n << 1) + 1], &
+ i__3, &iinfo);
+ if (iinfo != 0) {
+ io___105.ciunit = *nounit;
+ s_wsfe(&io___105);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSYEVR(N,A,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1700;
+ }
+ }
+
+/* Do test 72 (or ... ) */
+
+ temp1 = 0.f;
+ temp2 = 0.f;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = wa1[j], dabs(r__1)), r__3 =
+ max(r__3,r__4), r__4 = (r__2 = wa2[j], dabs(r__2))
+ ;
+ temp1 = dmax(r__3,r__4);
+/* Computing MAX */
+ r__2 = temp2, r__3 = (r__1 = wa1[j] - wa2[j], dabs(r__1));
+ temp2 = dmax(r__2,r__3);
+/* L1690: */
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * dmax(temp1,temp2);
+ result[ntest] = temp2 / dmax(r__1,r__2);
+
+L1700:
+
+ ++ntest;
+ slacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ s_copy(srnamc_1.srnamt, "SSYEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ ssyevr_("V", "I", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &iwork[(n << 1) + 1], &
+ i__3, &iinfo);
+ if (iinfo != 0) {
+ io___106.ciunit = *nounit;
+ s_wsfe(&io___106);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSYEVR(V,I,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1710;
+ }
+ }
+
+/* Do tests 73 and 74 (or +54) */
+
+ slacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ ssyt22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &result[ntest]);
+
+ ntest += 2;
+ slacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ s_copy(srnamc_1.srnamt, "SSYEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ ssyevr_("N", "I", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m3, &wa3[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &iwork[(n << 1) + 1], &
+ i__3, &iinfo);
+ if (iinfo != 0) {
+ io___107.ciunit = *nounit;
+ s_wsfe(&io___107);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSYEVR(N,I,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1710;
+ }
+ }
+
+/* Do test 75 (or +54) */
+
+ temp1 = ssxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = ssxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+/* Computing MAX */
+ r__1 = unfl, r__2 = ulp * temp3;
+ result[ntest] = (temp1 + temp2) / dmax(r__1,r__2);
+L1710:
+
+ ++ntest;
+ slacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ s_copy(srnamc_1.srnamt, "SSYEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ ssyevr_("V", "V", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &iwork[(n << 1) + 1], &
+ i__3, &iinfo);
+ if (iinfo != 0) {
+ io___108.ciunit = *nounit;
+ s_wsfe(&io___108);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSYEVR(V,V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L700;
+ }
+ }
+
+/* Do tests 76 and 77 (or +54) */
+
+ slacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ ssyt22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &result[ntest]);
+
+ ntest += 2;
+ slacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ s_copy(srnamc_1.srnamt, "SSYEVR", (ftnlen)32, (ftnlen)6);
+ i__3 = *liwork - (n << 1);
+ ssyevr_("N", "V", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m3, &wa3[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &iwork[(n << 1) + 1], &
+ i__3, &iinfo);
+ if (iinfo != 0) {
+ io___109.ciunit = *nounit;
+ s_wsfe(&io___109);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "SSYEVR(N,V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L700;
+ }
+ }
+
+ if (m3 == 0 && n > 0) {
+ result[ntest] = ulpinv;
+ goto L700;
+ }
+
+/* Do test 78 (or +54) */
+
+ temp1 = ssxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = ssxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ r__2 = dabs(wa1[1]), r__3 = (r__1 = wa1[n], dabs(r__1));
+ temp3 = dmax(r__2,r__3);
+ } else {
+ temp3 = 0.f;
+ }
+/* Computing MAX */
+ r__1 = unfl, r__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / dmax(r__1,r__2);
+
+ slacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+/* L1720: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+ ntestt += ntest;
+
+ slafts_("SST", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh,
+ nounit, &nerrs);
+
+L1730:
+ ;
+ }
+/* L1740: */
+ }
+
+/* Summary */
+
+ alasvm_("SST", nounit, &nerrs, &ntestt, &c__0);
+
+
+ return 0;
+
+/* End of SDRVST */
+
+} /* sdrvst_ */
diff --git a/TESTING/EIG/sdrvsx.c b/TESTING/EIG/sdrvsx.c
new file mode 100644
index 0000000..c17c990
--- /dev/null
+++ b/TESTING/EIG/sdrvsx.c
@@ -0,0 +1,1080 @@
+/* sdrvsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ real selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+/* Table of constant values */
+
+static real c_b18 = 0.f;
+static integer c__0 = 0;
+static real c_b32 = 1.f;
+static integer c__4 = 4;
+static integer c__6 = 6;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static logical c_false = FALSE_;
+static integer c__3 = 3;
+static logical c_true = TRUE_;
+static integer c__22 = 22;
+
+/* Subroutine */ int sdrvsx_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, integer *niunit,
+ integer *nounit, real *a, integer *lda, real *h__, real *ht, real *wr,
+ real *wi, real *wrt, real *wit, real *wrtmp, real *witmp, real *vs,
+ integer *ldvs, real *vs1, real *result, real *work, integer *lwork,
+ integer *iwork, logical *bwork, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
+ static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
+ static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9991[] = "(\002 SDRVSX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(/1x,a3,\002 -- Real Schur Form Decomposition "
+ "Expert \002,\002Driver\002,/\002 Matrix types (see SDRVSX for de"
+ "tails):\002)";
+ static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 \002,\002 5=Diagonal: geom"
+ "etr. spaced entries.\002,/\002 2=Identity matrix. "
+ " \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
+ "/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
+ " 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
+ "l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
+ "ll, evenly spaced.\002)";
+ static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
+ " 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
+ "l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
+ "d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
+ "red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
+ "vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
+ " 12=Well-cond., random complex \002,\002 \002,\002 17=Il"
+ "l-cond., large rand. complx \002,/\002 13=Ill-condi\002,\002tion"
+ "ed, evenly spaced. \002,\002 18=Ill-cond., small rand.\002"
+ ",\002 complx \002)";
+ static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
+ " \002,\002 21=Matrix \002,\002with small random entries.\002,"
+ "/\002 20=Matrix with large ran\002,\002dom entries. \002,/)";
+ static char fmt_9995[] = "(\002 Tests performed with test threshold ="
+ "\002,f8.2,/\002 ( A denotes A on input and T denotes A on output)"
+ "\002,//\002 1 = 0 if T in Schur form (no sort), \002,\002 1/ulp"
+ " otherwise\002,/\002 2 = | A - VS T transpose(VS) | / ( n |A| ul"
+ "p ) (no sort)\002,/\002 3 = | I - VS transpose(VS) | / ( n ulp )"
+ " (no sort) \002,/\002 4 = 0 if WR+sqrt(-1)*WI are eigenvalues of"
+ " T (no sort),\002,\002 1/ulp otherwise\002,/\002 5 = 0 if T sam"
+ "e no matter if VS computed (no sort),\002,\002 1/ulp otherwis"
+ "e\002,/\002 6 = 0 if WR, WI same no matter if VS computed (no so"
+ "rt)\002,\002, 1/ulp otherwise\002)";
+ static char fmt_9994[] = "(\002 7 = 0 if T in Schur form (sort), \002"
+ ",\002 1/ulp otherwise\002,/\002 8 = | A - VS T transpose(VS) | "
+ "/ ( n |A| ulp ) (sort)\002,/\002 9 = | I - VS transpose(VS) | / "
+ "( n ulp ) (sort) \002,/\002 10 = 0 if WR+sqrt(-1)*WI are eigenva"
+ "lues of T (sort),\002,\002 1/ulp otherwise\002,/\002 11 = 0 if "
+ "T same no matter what else computed (sort),\002,\002 1/ulp othe"
+ "rwise\002,/\002 12 = 0 if WR, WI same no matter what else comput"
+ "ed \002,\002(sort), 1/ulp otherwise\002,/\002 13 = 0 if sorting "
+ "succesful, 1/ulp otherwise\002,/\002 14 = 0 if RCONDE same no ma"
+ "tter what else computed,\002,\002 1/ulp otherwise\002,/\002 15 ="
+ " 0 if RCONDv same no matter what else computed,\002,\002 1/ulp o"
+ "therwise\002,/\002 16 = | RCONDE - RCONDE(precomputed) | / cond("
+ "RCONDE),\002,/\002 17 = | RCONDV - RCONDV(precomputed) | / cond("
+ "RCONDV),\002)";
+ static char fmt_9993[] = "(\002 N=\002,i5,\002, IWK=\002,i2,\002, seed"
+ "=\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)="
+ "\002,g10.3)";
+ static char fmt_9992[] = "(\002 N=\002,i5,\002, input example =\002,i3"
+ ",\002, test(\002,i2,\002)=\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, ht_dim1, ht_offset, vs_dim1,
+ vs_offset, vs1_dim1, vs1_offset, i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+
+ /* Local variables */
+ integer i__, j, n, iwk;
+ real ulp, cond;
+ integer jcol;
+ char path[3];
+ integer nmax;
+ real unfl, ovfl;
+ logical badnn;
+ integer nfail, imode, iinfo;
+ real conds;
+ extern /* Subroutine */ int sget24_(logical *, integer *, real *, integer
+ *, integer *, integer *, real *, integer *, real *, real *, real *
+, real *, real *, real *, real *, real *, real *, integer *, real
+ *, real *, real *, integer *, integer *, real *, real *, integer *
+, integer *, logical *, integer *);
+ real anorm;
+ integer islct[20], nslct, jsize, nerrs, itype, jtype, ntest;
+ real rtulp;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ real rcdein;
+ char adumma[1*1];
+ extern doublereal slamch_(char *);
+ integer idumma[1], ioldsd[4];
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real rcdvin;
+ extern /* Subroutine */ int slatme_(integer *, char *, integer *, real *,
+ integer *, real *, real *, char *, char *, char *, char *, real *,
+ integer *, real *, integer *, integer *, real *, real *, integer
+ *, real *, integer *),
+ slaset_(char *, integer *, integer *, real *, real *, real *,
+ integer *), slatmr_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, char *, char *,
+ real *, integer *, real *, real *, integer *, real *, char *,
+ integer *, integer *, integer *, real *, real *, char *, real *,
+ integer *, integer *, integer *);
+ integer ntestf;
+ extern /* Subroutine */ int slasum_(char *, integer *, integer *, integer
+ *), slatms_(integer *, integer *, char *, integer *, char
+ *, real *, integer *, real *, real *, integer *, integer *, char *
+, real *, integer *, real *, integer *);
+ real ulpinv;
+ integer nnwork;
+ real rtulpi;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___32 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___48 = { 0, 0, 1, 0, 0 };
+ static cilist io___49 = { 0, 0, 0, 0, 0 };
+ static cilist io___51 = { 0, 0, 0, 0, 0 };
+ static cilist io___52 = { 0, 0, 0, 0, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9992, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVSX checks the nonsymmetric eigenvalue (Schur form) problem */
+/* expert driver SGEESX. */
+
+/* SDRVSX uses both test matrices generated randomly depending on */
+/* data supplied in the calling sequence, as well as on data */
+/* read from an input file and including precomputed condition */
+/* numbers to which it compares the ones it computes. */
+
+/* When SDRVSX is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 15 */
+/* tests will be performed: */
+
+/* (1) 0 if T is in Schur form, 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (2) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (no sorting of eigenvalues). */
+
+/* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues). */
+
+/* (4) 0 if WR+sqrt(-1)*WI are eigenvalues of T */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (5) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (7) 0 if T is in Schur form, 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (8) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (with sorting of eigenvalues). */
+
+/* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues). */
+
+/* (10) 0 if WR+sqrt(-1)*WI are eigenvalues of T */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare WR, WI with and */
+/* without reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (11) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare T with and without */
+/* reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare VS with and without */
+/* reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (13) if sorting worked and SDIM is the number of */
+/* eigenvalues which were SELECTed */
+/* If workspace sufficient, also compare SDIM with and */
+/* without reciprocal condition numbers */
+
+/* (14) if RCONDE the same no matter if VS and/or RCONDV computed */
+
+/* (15) if RCONDV the same no matter if VS and/or RCONDE computed */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
+
+/* (4) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (5) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (7) Same as (4), but multiplied by a constant near */
+/* the overflow threshold */
+/* (8) Same as (4), but multiplied by a constant near */
+/* the underflow threshold */
+
+/* (9) A matrix of the form U' T U, where U is orthogonal and */
+/* T has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (10) A matrix of the form U' T U, where U is orthogonal and */
+/* T has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (11) A matrix of the form U' T U, where U is orthogonal and */
+/* T has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (12) A matrix of the form U' T U, where U is orthogonal and */
+/* T has real or complex conjugate paired eigenvalues randomly */
+/* chosen from ( ULP, 1 ) and random O(1) entries in the upper */
+/* triangle. */
+
+/* (13) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
+/* with random signs on the diagonal and random O(1) entries */
+/* in the upper triangle. */
+
+/* (14) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has geometrically spaced entries */
+/* 1, ..., ULP with random signs on the diagonal and random */
+/* O(1) entries in the upper triangle. */
+
+/* (15) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
+/* with random signs on the diagonal and random O(1) entries */
+/* in the upper triangle. */
+
+/* (16) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has real or complex conjugate paired */
+/* eigenvalues randomly chosen from ( ULP, 1 ) and random */
+/* O(1) entries in the upper triangle. */
+
+/* (17) Same as (16), but multiplied by a constant */
+/* near the overflow threshold */
+/* (18) Same as (16), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* (19) Nonsymmetric matrix with random entries chosen from (-1,1). */
+/* If N is at least 4, all entries in first two rows and last */
+/* row, and first column and last two columns are zero. */
+/* (20) Same as (19), but multiplied by a constant */
+/* near the overflow threshold */
+/* (21) Same as (19), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* In addition, an input file will be read from logical unit number */
+/* NIUNIT. The file contains matrices along with precomputed */
+/* eigenvalues and reciprocal condition numbers for the eigenvalue */
+/* average and right invariant subspace. For these matrices, in */
+/* addition to tests (1) to (15) we will compute the following two */
+/* tests: */
+
+/* (16) |RCONDE - RCDEIN| / cond(RCONDE) */
+
+/* RCONDE is the reciprocal average eigenvalue condition number */
+/* computed by SGEESX and RCDEIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDE) is the condition number */
+/* of RCONDE, and takes errors in computing RCONDE into account, */
+/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
+/* is essentially given by norm(A)/RCONDV. */
+
+/* (17) |RCONDV - RCDVIN| / cond(RCONDV) */
+
+/* RCONDV is the reciprocal right invariant subspace condition */
+/* number computed by SGEESX and RCDVIN (the precomputed true */
+/* value) is supplied as input. cond(RCONDV) is the condition */
+/* number of RCONDV, and takes errors in computing RCONDV into */
+/* account, so that the resulting quantity should be O(ULP). */
+/* cond(RCONDV) is essentially given by norm(A)/RCONDE. */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. NSIZES must be at */
+/* least zero. If it is zero, no randomly generated matrices */
+/* are tested, but any test matrices read from NIUNIT will be */
+/* tested. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. NTYPES must be at least */
+/* zero. If it is zero, no randomly generated test matrices */
+/* are tested, but and test matrices read from NIUNIT will be */
+/* tested. If it is MAXTYP+1 and NSIZES is 1, then an */
+/* additional type, MAXTYP+1 is defined, which is to use */
+/* whatever matrix is in A. This is only useful if */
+/* DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to SDRVSX to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NIUNIT (input) INTEGER */
+/* The FORTRAN unit number for reading in the data file of */
+/* problems to solve. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* A (workspace) REAL array, dimension (LDA, max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, and H. LDA must be at */
+/* least 1 and at least max( NN ). */
+
+/* H (workspace) REAL array, dimension (LDA, max(NN)) */
+/* Another copy of the test matrix A, modified by SGEESX. */
+
+/* HT (workspace) REAL array, dimension (LDA, max(NN)) */
+/* Yet another copy of the test matrix A, modified by SGEESX. */
+
+/* WR (workspace) REAL array, dimension (max(NN)) */
+/* WI (workspace) REAL array, dimension (max(NN)) */
+/* The real and imaginary parts of the eigenvalues of A. */
+/* On exit, WR + WI*i are the eigenvalues of the matrix in A. */
+
+/* WRT (workspace) REAL array, dimension (max(NN)) */
+/* WIT (workspace) REAL array, dimension (max(NN)) */
+/* Like WR, WI, these arrays contain the eigenvalues of A, */
+/* but those computed when SGEESX only computes a partial */
+/* eigendecomposition, i.e. not Schur vectors */
+
+/* WRTMP (workspace) REAL array, dimension (max(NN)) */
+/* WITMP (workspace) REAL array, dimension (max(NN)) */
+/* More temporary storage for eigenvalues. */
+
+/* VS (workspace) REAL array, dimension (LDVS, max(NN)) */
+/* VS holds the computed Schur vectors. */
+
+/* LDVS (input) INTEGER */
+/* Leading dimension of VS. Must be at least max(1,max(NN)). */
+
+/* VS1 (workspace) REAL array, dimension (LDVS, max(NN)) */
+/* VS1 holds another copy of the computed Schur vectors. */
+
+/* RESULT (output) REAL array, dimension (17) */
+/* The values computed by the 17 tests described above. */
+/* The values are currently limited to 1/ulp, to avoid overflow. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* max(3*NN(j),2*NN(j)**2) for all j. */
+
+/* IWORK (workspace) INTEGER array, dimension (max(NN)*max(NN)) */
+
+/* INFO (output) INTEGER */
+/* If 0, successful exit. */
+/* <0, input parameter -INFO is incorrect */
+/* >0, SLATMR, SLATMS, SLATME or SGET24 returned an error */
+/* code and INFO is its absolute value */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NMAX Largest value in NN. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* COND, CONDS, */
+/* IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTULP, RTULPI Square roots of the previous 4 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+/* KCONDS(j) Selectw whether CONDS is to be 1 or */
+/* 1/sqrt(ulp). (0 means irrelevant.) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ ht_dim1 = *lda;
+ ht_offset = 1 + ht_dim1;
+ ht -= ht_offset;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --wr;
+ --wi;
+ --wrt;
+ --wit;
+ --wrtmp;
+ --witmp;
+ vs1_dim1 = *ldvs;
+ vs1_offset = 1 + vs1_dim1;
+ vs1 -= vs1_offset;
+ vs_dim1 = *ldvs;
+ vs_offset = 1 + vs_dim1;
+ vs -= vs_offset;
+ --result;
+ --work;
+ --iwork;
+ --bwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "SX", (ftnlen)2, (ftnlen)2);
+
+/* Check for errors */
+
+ ntestt = 0;
+ ntestf = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+
+/* 12 is the largest dimension in the input file of precomputed */
+/* problems */
+
+ nmax = 12;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.f) {
+ *info = -6;
+ } else if (*niunit <= 0) {
+ *info = -7;
+ } else if (*nounit <= 0) {
+ *info = -8;
+ } else if (*lda < 1 || *lda < nmax) {
+ *info = -10;
+ } else if (*ldvs < 1 || *ldvs < nmax) {
+ *info = -20;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+/* Computing 2nd power */
+ i__3 = nmax;
+ i__1 = nmax * 3, i__2 = i__3 * i__3 << 1;
+ if (max(i__1,i__2) > *lwork) {
+ *info = -24;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SDRVSX", &i__1);
+ return 0;
+ }
+
+/* If nothing to do check on NIUNIT */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ goto L150;
+ }
+
+/* More Important constants */
+
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ slabad_(&unfl, &ovfl);
+ ulp = slamch_("Precision");
+ ulpinv = 1.f / ulp;
+ rtulp = sqrt(ulp);
+ rtulpi = 1.f / rtulp;
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L130;
+ }
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KCONDS KMODE KTYPE */
+/* =1 O(1) 1 clustered 1 zero */
+/* =2 large large clustered 2 identity */
+/* =3 small exponential Jordan */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random general, w/ eigenvalues */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 random general */
+/* =10 random triangular */
+
+ if (mtypes > 21) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L30;
+ case 2: goto L40;
+ case 3: goto L50;
+ }
+
+L30:
+ anorm = 1.f;
+ goto L60;
+
+L40:
+ anorm = ovfl * ulp;
+ goto L60;
+
+L50:
+ anorm = unfl * ulpinv;
+ goto L60;
+
+L60:
+
+ slaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+/* L70: */
+ }
+
+ } else if (itype == 3) {
+
+/* Jordan Block */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+ if (jcol > 1) {
+ a[jcol + (jcol - 1) * a_dim1] = 1.f;
+ }
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 6) {
+
+/* General, eigenvalues specified */
+
+ if (kconds[jtype - 1] == 1) {
+ conds = 1.f;
+ } else if (kconds[jtype - 1] == 2) {
+ conds = rtulpi;
+ } else {
+ conds = 0.f;
+ }
+
+ *(unsigned char *)&adumma[0] = ' ';
+ slatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b32,
+ adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
+ n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
+ &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &c__0, &
+ c__0, &c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
+ c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* General, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
+ c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+ if (n >= 4) {
+ slaset_("Full", &c__2, &n, &c_b18, &c_b18, &a[a_offset],
+ lda);
+ i__3 = n - 3;
+ slaset_("Full", &i__3, &c__1, &c_b18, &c_b18, &a[a_dim1 +
+ 3], lda);
+ i__3 = n - 3;
+ slaset_("Full", &i__3, &c__2, &c_b18, &c_b18, &a[(n - 1) *
+ a_dim1 + 3], lda);
+ slaset_("Full", &c__1, &n, &c_b18, &c_b18, &a[n + a_dim1],
+ lda);
+ }
+
+ } else if (itype == 10) {
+
+/* Triangular, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &c__0, &
+ c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___32.ciunit = *nounit;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+/* Test for minimal and generous workspace */
+
+ for (iwk = 1; iwk <= 2; ++iwk) {
+ if (iwk == 1) {
+ nnwork = n * 3;
+ } else {
+/* Computing MAX */
+ i__3 = n * 3, i__4 = (n << 1) * n;
+ nnwork = max(i__3,i__4);
+ }
+ nnwork = max(nnwork,1);
+
+ sget24_(&c_false, &jtype, thresh, ioldsd, nounit, &n, &a[
+ a_offset], lda, &h__[h_offset], &ht[ht_offset], &wr[1]
+, &wi[1], &wrt[1], &wit[1], &wrtmp[1], &witmp[1], &vs[
+ vs_offset], ldvs, &vs1[vs1_offset], &rcdein, &rcdvin,
+ &nslct, islct, &result[1], &work[1], &nnwork, &iwork[
+ 1], &bwork[1], info);
+
+/* Check for RESULT(j) > THRESH */
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 15; ++j) {
+ if (result[j] >= 0.f) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L100: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ e_wsfe();
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ e_wsfe();
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ e_wsfe();
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
+ e_wsfe();
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ e_wsfe();
+ ntestf = 2;
+ }
+
+ for (j = 1; j <= 15; ++j) {
+ if (result[j] >= *thresh) {
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ }
+/* L110: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+
+/* L120: */
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+
+L150:
+
+/* Read in data from file to check accuracy of condition estimation */
+/* Read input data until N=0 */
+
+ jtype = 0;
+L160:
+ io___48.ciunit = *niunit;
+ i__1 = s_rsle(&io___48);
+ if (i__1 != 0) {
+ goto L200;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L200;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&nslct, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L200;
+ }
+ i__1 = e_rsle();
+ if (i__1 != 0) {
+ goto L200;
+ }
+ if (n == 0) {
+ goto L200;
+ }
+ ++jtype;
+ iseed[1] = jtype;
+ if (nslct > 0) {
+ io___49.ciunit = *niunit;
+ s_rsle(&io___49);
+ i__1 = nslct;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&islct[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___51.ciunit = *niunit;
+ s_rsle(&io___51);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__4, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
+ real));
+ }
+ e_rsle();
+/* L170: */
+ }
+ io___52.ciunit = *niunit;
+ s_rsle(&io___52);
+ do_lio(&c__4, &c__1, (char *)&rcdein, (ftnlen)sizeof(real));
+ do_lio(&c__4, &c__1, (char *)&rcdvin, (ftnlen)sizeof(real));
+ e_rsle();
+
+ sget24_(&c_true, &c__22, thresh, &iseed[1], nounit, &n, &a[a_offset], lda,
+ &h__[h_offset], &ht[ht_offset], &wr[1], &wi[1], &wrt[1], &wit[1],
+ &wrtmp[1], &witmp[1], &vs[vs_offset], ldvs, &vs1[vs1_offset], &
+ rcdein, &rcdvin, &nslct, islct, &result[1], &work[1], lwork, &
+ iwork[1], &bwork[1], info);
+
+/* Check for RESULT(j) > THRESH */
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 17; ++j) {
+ if (result[j] >= 0.f) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L180: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ e_wsfe();
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+ e_wsfe();
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ e_wsfe();
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
+ e_wsfe();
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ e_wsfe();
+ ntestf = 2;
+ }
+ for (j = 1; j <= 17; ++j) {
+ if (result[j] >= *thresh) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+/* L190: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+ goto L160;
+L200:
+
+/* Summary */
+
+ slasum_(path, nounit, &nerrs, &ntestt);
+
+
+
+ return 0;
+
+/* End of SDRVSX */
+
+} /* sdrvsx_ */
diff --git a/TESTING/EIG/sdrvvx.c b/TESTING/EIG/sdrvvx.c
new file mode 100644
index 0000000..627048d
--- /dev/null
+++ b/TESTING/EIG/sdrvvx.c
@@ -0,0 +1,1113 @@
+/* sdrvvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b18 = 0.f;
+static integer c__0 = 0;
+static real c_b32 = 1.f;
+static integer c__4 = 4;
+static integer c__6 = 6;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static logical c_false = FALSE_;
+static integer c__3 = 3;
+static logical c_true = TRUE_;
+static integer c__22 = 22;
+
+/* Subroutine */ int sdrvvx_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, real *thresh, integer *niunit,
+ integer *nounit, real *a, integer *lda, real *h__, real *wr, real *wi,
+ real *wr1, real *wi1, real *vl, integer *ldvl, real *vr, integer *
+ ldvr, real *lre, integer *ldlre, real *rcondv, real *rcndv1, real *
+ rcdvin, real *rconde, real *rcnde1, real *rcdein, real *scale, real *
+ scale1, real *result, real *work, integer *nwork, integer *iwork,
+ integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
+ static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
+ static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
+ static char bal[1*4] = "N" "P" "S" "B";
+
+ /* Format strings */
+ static char fmt_9992[] = "(\002 SDRVVX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(/1x,a3,\002 -- Real Eigenvalue-Eigenvector De"
+ "composition\002,\002 Expert Driver\002,/\002 Matrix types (see S"
+ "DRVVX for details): \002)";
+ static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 \002,\002 5=Diagonal: geom"
+ "etr. spaced entries.\002,/\002 2=Identity matrix. "
+ " \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
+ "/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
+ " 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
+ "l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
+ "ll, evenly spaced.\002)";
+ static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
+ " 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
+ "l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
+ "d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
+ "red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
+ "vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
+ " 12=Well-cond., random complex \002,\002 \002,\002 17=Il"
+ "l-cond., large rand. complx \002,/\002 13=Ill-condi\002,\002tion"
+ "ed, evenly spaced. \002,\002 18=Ill-cond., small rand.\002"
+ ",\002 complx \002)";
+ static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
+ " \002,\002 21=Matrix \002,\002with small random entries.\002,"
+ "/\002 20=Matrix with large ran\002,\002dom entries. \002,\002 "
+ "22=Matrix read from input file\002,/)";
+ static char fmt_9995[] = "(\002 Tests performed with test threshold ="
+ "\002,f8.2,//\002 1 = | A VR - VR W | / ( n |A| ulp ) \002,/\002 "
+ "2 = | transpose(A) VL - VL W | / ( n |A| ulp ) \002,/\002 3 = | "
+ "|VR(i)| - 1 | / ulp \002,/\002 4 = | |VL(i)| - 1 | / ulp \002,"
+ "/\002 5 = 0 if W same no matter if VR or VL computed,\002,\002 1"
+ "/ulp otherwise\002,/\002 6 = 0 if VR same no matter what else co"
+ "mputed,\002,\002 1/ulp otherwise\002,/\002 7 = 0 if VL same no "
+ "matter what else computed,\002,\002 1/ulp otherwise\002,/\002 8"
+ " = 0 if RCONDV same no matter what else computed,\002,\002 1/ul"
+ "p otherwise\002,/\002 9 = 0 if SCALE, ILO, IHI, ABNRM same no ma"
+ "tter what else\002,\002 computed, 1/ulp otherwise\002,/\002 10 "
+ "= | RCONDV - RCONDV(precomputed) | / cond(RCONDV),\002,/\002 11 "
+ "= | RCONDE - RCONDE(precomputed) | / cond(RCONDE),\002)";
+ static char fmt_9994[] = "(\002 BALANC='\002,a1,\002',N=\002,i4,\002,I"
+ "WK=\002,i1,\002, seed=\002,4(i4,\002,\002),\002 type \002,i2,"
+ "\002, test(\002,i2,\002)=\002,g10.3)";
+ static char fmt_9993[] = "(\002 N=\002,i5,\002, input example =\002,i3"
+ ",\002, test(\002,i2,\002)=\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1,
+ vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+
+ /* Local variables */
+ integer i__, j, n, iwk;
+ real ulp;
+ integer ibal;
+ real cond;
+ integer jcol;
+ char path[3];
+ integer nmax;
+ real unfl, ovfl;
+ logical badnn;
+ integer nfail, imode, iinfo;
+ real conds;
+ extern /* Subroutine */ int sget23_(logical *, char *, integer *, real *,
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, real *, real *, real *, real *, integer *, real *, integer *,
+ real *, integer *, real *, real *, real *, real *, real *, real *,
+ real *, real *, real *, real *, integer *, integer *, integer *);
+ real anorm;
+ integer jsize, nerrs, itype, jtype, ntest;
+ real rtulp;
+ char balanc[1];
+ extern /* Subroutine */ int slabad_(real *, real *);
+ char adumma[1*1];
+ extern doublereal slamch_(char *);
+ integer idumma[1];
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int slatme_(integer *, char *, integer *, real *,
+ integer *, real *, real *, char *, char *, char *, char *, real *,
+ integer *, real *, integer *, integer *, real *, real *, integer
+ *, real *, integer *),
+ slaset_(char *, integer *, integer *, real *, real *, real *,
+ integer *), slatmr_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, char *, char *,
+ real *, integer *, real *, real *, integer *, real *, char *,
+ integer *, integer *, integer *, real *, real *, char *, real *,
+ integer *, integer *, integer *);
+ integer ntestf;
+ extern /* Subroutine */ int slasum_(char *, integer *, integer *, integer
+ *), slatms_(integer *, integer *, char *, integer *, char
+ *, real *, integer *, real *, real *, integer *, integer *, char *
+, real *, integer *, real *, integer *);
+ real ulpinv;
+ integer nnwork;
+ real rtulpi;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___46 = { 0, 0, 1, 0, 0 };
+ static cilist io___48 = { 0, 0, 0, 0, 0 };
+ static cilist io___49 = { 0, 0, 0, 0, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVVX checks the nonsymmetric eigenvalue problem expert driver */
+/* SGEEVX. */
+
+/* SDRVVX uses both test matrices generated randomly depending on */
+/* data supplied in the calling sequence, as well as on data */
+/* read from an input file and including precomputed condition */
+/* numbers to which it compares the ones it computes. */
+
+/* When SDRVVX is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified in the calling sequence. */
+/* For each size ("n") and each type of matrix, one matrix will be */
+/* generated and used to test the nonsymmetric eigenroutines. For */
+/* each matrix, 9 tests will be performed: */
+
+/* (1) | A * VR - VR * W | / ( n |A| ulp ) */
+
+/* Here VR is the matrix of unit right eigenvectors. */
+/* W is a block diagonal matrix, with a 1x1 block for each */
+/* real eigenvalue and a 2x2 block for each complex conjugate */
+/* pair. If eigenvalues j and j+1 are a complex conjugate pair, */
+/* so WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the */
+/* 2 x 2 block corresponding to the pair will be: */
+
+/* ( wr wi ) */
+/* ( -wi wr ) */
+
+/* Such a block multiplying an n x 2 matrix ( ur ui ) on the */
+/* right will be the same as multiplying ur + i*ui by wr + i*wi. */
+
+/* (2) | A**H * VL - VL * W**H | / ( n |A| ulp ) */
+
+/* Here VL is the matrix of unit left eigenvectors, A**H is the */
+/* conjugate transpose of A, and W is as above. */
+
+/* (3) | |VR(i)| - 1 | / ulp and largest component real */
+
+/* VR(i) denotes the i-th column of VR. */
+
+/* (4) | |VL(i)| - 1 | / ulp and largest component real */
+
+/* VL(i) denotes the i-th column of VL. */
+
+/* (5) W(full) = W(partial) */
+
+/* W(full) denotes the eigenvalues computed when VR, VL, RCONDV */
+/* and RCONDE are also computed, and W(partial) denotes the */
+/* eigenvalues computed when only some of VR, VL, RCONDV, and */
+/* RCONDE are computed. */
+
+/* (6) VR(full) = VR(partial) */
+
+/* VR(full) denotes the right eigenvectors computed when VL, RCONDV */
+/* and RCONDE are computed, and VR(partial) denotes the result */
+/* when only some of VL and RCONDV are computed. */
+
+/* (7) VL(full) = VL(partial) */
+
+/* VL(full) denotes the left eigenvectors computed when VR, RCONDV */
+/* and RCONDE are computed, and VL(partial) denotes the result */
+/* when only some of VR and RCONDV are computed. */
+
+/* (8) 0 if SCALE, ILO, IHI, ABNRM (full) = */
+/* SCALE, ILO, IHI, ABNRM (partial) */
+/* 1/ulp otherwise */
+
+/* SCALE, ILO, IHI and ABNRM describe how the matrix is balanced. */
+/* (full) is when VR, VL, RCONDE and RCONDV are also computed, and */
+/* (partial) is when some are not computed. */
+
+/* (9) RCONDV(full) = RCONDV(partial) */
+
+/* RCONDV(full) denotes the reciprocal condition numbers of the */
+/* right eigenvectors computed when VR, VL and RCONDE are also */
+/* computed. RCONDV(partial) denotes the reciprocal condition */
+/* numbers when only some of VR, VL and RCONDE are computed. */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
+
+/* (4) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (5) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (7) Same as (4), but multiplied by a constant near */
+/* the overflow threshold */
+/* (8) Same as (4), but multiplied by a constant near */
+/* the underflow threshold */
+
+/* (9) A matrix of the form U' T U, where U is orthogonal and */
+/* T has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (10) A matrix of the form U' T U, where U is orthogonal and */
+/* T has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (11) A matrix of the form U' T U, where U is orthogonal and */
+/* T has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (12) A matrix of the form U' T U, where U is orthogonal and */
+/* T has real or complex conjugate paired eigenvalues randomly */
+/* chosen from ( ULP, 1 ) and random O(1) entries in the upper */
+/* triangle. */
+
+/* (13) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
+/* with random signs on the diagonal and random O(1) entries */
+/* in the upper triangle. */
+
+/* (14) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has geometrically spaced entries */
+/* 1, ..., ULP with random signs on the diagonal and random */
+/* O(1) entries in the upper triangle. */
+
+/* (15) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
+/* with random signs on the diagonal and random O(1) entries */
+/* in the upper triangle. */
+
+/* (16) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has real or complex conjugate paired */
+/* eigenvalues randomly chosen from ( ULP, 1 ) and random */
+/* O(1) entries in the upper triangle. */
+
+/* (17) Same as (16), but multiplied by a constant */
+/* near the overflow threshold */
+/* (18) Same as (16), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* (19) Nonsymmetric matrix with random entries chosen from (-1,1). */
+/* If N is at least 4, all entries in first two rows and last */
+/* row, and first column and last two columns are zero. */
+/* (20) Same as (19), but multiplied by a constant */
+/* near the overflow threshold */
+/* (21) Same as (19), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* In addition, an input file will be read from logical unit number */
+/* NIUNIT. The file contains matrices along with precomputed */
+/* eigenvalues and reciprocal condition numbers for the eigenvalues */
+/* and right eigenvectors. For these matrices, in addition to tests */
+/* (1) to (9) we will compute the following two tests: */
+
+/* (10) |RCONDV - RCDVIN| / cond(RCONDV) */
+
+/* RCONDV is the reciprocal right eigenvector condition number */
+/* computed by SGEEVX and RCDVIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDV) is the condition number of */
+/* RCONDV, and takes errors in computing RCONDV into account, so */
+/* that the resulting quantity should be O(ULP). cond(RCONDV) is */
+/* essentially given by norm(A)/RCONDE. */
+
+/* (11) |RCONDE - RCDEIN| / cond(RCONDE) */
+
+/* RCONDE is the reciprocal eigenvalue condition number */
+/* computed by SGEEVX and RCDEIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDE) is the condition number */
+/* of RCONDE, and takes errors in computing RCONDE into account, */
+/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
+/* is essentially given by norm(A)/RCONDV. */
+
+/* Arguments */
+/* ========== */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. NSIZES must be at */
+/* least zero. If it is zero, no randomly generated matrices */
+/* are tested, but any test matrices read from NIUNIT will be */
+/* tested. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. NTYPES must be at least */
+/* zero. If it is zero, no randomly generated test matrices */
+/* are tested, but and test matrices read from NIUNIT will be */
+/* tested. If it is MAXTYP+1 and NSIZES is 1, then an */
+/* additional type, MAXTYP+1 is defined, which is to use */
+/* whatever matrix is in A. This is only useful if */
+/* DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to SDRVVX to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NIUNIT (input) INTEGER */
+/* The FORTRAN unit number for reading in the data file of */
+/* problems to solve. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* A (workspace) REAL array, dimension */
+/* (LDA, max(NN,12)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A and H. */
+/* LDA >= max(NN,12), since 12 is the dimension of the largest */
+/* matrix in the precomputed input file. */
+
+/* H (workspace) REAL array, dimension */
+/* (LDA, max(NN,12)) */
+/* Another copy of the test matrix A, modified by SGEEVX. */
+
+/* WR (workspace) REAL array, dimension (max(NN)) */
+/* WI (workspace) REAL array, dimension (max(NN)) */
+/* The real and imaginary parts of the eigenvalues of A. */
+/* On exit, WR + WI*i are the eigenvalues of the matrix in A. */
+
+/* WR1 (workspace) REAL array, dimension (max(NN,12)) */
+/* WI1 (workspace) REAL array, dimension (max(NN,12)) */
+/* Like WR, WI, these arrays contain the eigenvalues of A, */
+/* but those computed when SGEEVX only computes a partial */
+/* eigendecomposition, i.e. not the eigenvalues and left */
+/* and right eigenvectors. */
+
+/* VL (workspace) REAL array, dimension */
+/* (LDVL, max(NN,12)) */
+/* VL holds the computed left eigenvectors. */
+
+/* LDVL (input) INTEGER */
+/* Leading dimension of VL. Must be at least max(1,max(NN,12)). */
+
+/* VR (workspace) REAL array, dimension */
+/* (LDVR, max(NN,12)) */
+/* VR holds the computed right eigenvectors. */
+
+/* LDVR (input) INTEGER */
+/* Leading dimension of VR. Must be at least max(1,max(NN,12)). */
+
+/* LRE (workspace) REAL array, dimension */
+/* (LDLRE, max(NN,12)) */
+/* LRE holds the computed right or left eigenvectors. */
+
+/* LDLRE (input) INTEGER */
+/* Leading dimension of LRE. Must be at least max(1,max(NN,12)) */
+
+/* RCONDV (workspace) REAL array, dimension (N) */
+/* RCONDV holds the computed reciprocal condition numbers */
+/* for eigenvectors. */
+
+/* RCNDV1 (workspace) REAL array, dimension (N) */
+/* RCNDV1 holds more computed reciprocal condition numbers */
+/* for eigenvectors. */
+
+/* RCDVIN (workspace) REAL array, dimension (N) */
+/* When COMP = .TRUE. RCDVIN holds the precomputed reciprocal */
+/* condition numbers for eigenvectors to be compared with */
+/* RCONDV. */
+
+/* RCONDE (workspace) REAL array, dimension (N) */
+/* RCONDE holds the computed reciprocal condition numbers */
+/* for eigenvalues. */
+
+/* RCNDE1 (workspace) REAL array, dimension (N) */
+/* RCNDE1 holds more computed reciprocal condition numbers */
+/* for eigenvalues. */
+
+/* RCDEIN (workspace) REAL array, dimension (N) */
+/* When COMP = .TRUE. RCDEIN holds the precomputed reciprocal */
+/* condition numbers for eigenvalues to be compared with */
+/* RCONDE. */
+
+/* RESULT (output) REAL array, dimension (11) */
+/* The values computed by the seven tests described above. */
+/* The values are currently limited to 1/ulp, to avoid overflow. */
+
+/* WORK (workspace) REAL array, dimension (NWORK) */
+
+/* NWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* max(6*12+2*12**2,6*NN(j)+2*NN(j)**2) = */
+/* max( 360 ,6*NN(j)+2*NN(j)**2) for all j. */
+
+/* IWORK (workspace) INTEGER array, dimension (2*max(NN,12)) */
+
+/* INFO (output) INTEGER */
+/* If 0, then successful exit. */
+/* If <0, then input paramter -INFO is incorrect. */
+/* If >0, SLATMR, SLATMS, SLATME or SGET23 returned an error */
+/* code, and INFO is its absolute value. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NMAX Largest value in NN or 12. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* COND, CONDS, */
+/* IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTULP, RTULPI Square roots of the previous 4 values. */
+
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+/* KCONDS(j) Selectw whether CONDS is to be 1 or */
+/* 1/sqrt(ulp). (0 means irrelevant.) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --wr;
+ --wi;
+ --wr1;
+ --wi1;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ lre_dim1 = *ldlre;
+ lre_offset = 1 + lre_dim1;
+ lre -= lre_offset;
+ --rcondv;
+ --rcndv1;
+ --rcdvin;
+ --rconde;
+ --rcnde1;
+ --rcdein;
+ --scale;
+ --scale1;
+ --result;
+ --work;
+ --iwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "VX", (ftnlen)2, (ftnlen)2);
+
+/* Check for errors */
+
+ ntestt = 0;
+ ntestf = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+
+/* 12 is the largest dimension in the input file of precomputed */
+/* problems */
+
+ nmax = 12;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.f) {
+ *info = -6;
+ } else if (*lda < 1 || *lda < nmax) {
+ *info = -10;
+ } else if (*ldvl < 1 || *ldvl < nmax) {
+ *info = -17;
+ } else if (*ldvr < 1 || *ldvr < nmax) {
+ *info = -19;
+ } else if (*ldlre < 1 || *ldlre < nmax) {
+ *info = -21;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = nmax;
+ if (nmax * 6 + (i__1 * i__1 << 1) > *nwork) {
+ *info = -32;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SDRVVX", &i__1);
+ return 0;
+ }
+
+/* If nothing to do check on NIUNIT */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ goto L160;
+ }
+
+/* More Important constants */
+
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ slabad_(&unfl, &ovfl);
+ ulp = slamch_("Precision");
+ ulpinv = 1.f / ulp;
+ rtulp = sqrt(ulp);
+ rtulpi = 1.f / rtulp;
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L140;
+ }
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KCONDS KMODE KTYPE */
+/* =1 O(1) 1 clustered 1 zero */
+/* =2 large large clustered 2 identity */
+/* =3 small exponential Jordan */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random general, w/ eigenvalues */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 random general */
+/* =10 random triangular */
+
+ if (mtypes > 21) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L30;
+ case 2: goto L40;
+ case 3: goto L50;
+ }
+
+L30:
+ anorm = 1.f;
+ goto L60;
+
+L40:
+ anorm = ovfl * ulp;
+ goto L60;
+
+L50:
+ anorm = unfl * ulpinv;
+ goto L60;
+
+L60:
+
+ slaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+/* L70: */
+ }
+
+ } else if (itype == 3) {
+
+/* Jordan Block */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ a[jcol + jcol * a_dim1] = anorm;
+ if (jcol > 1) {
+ a[jcol + (jcol - 1) * a_dim1] = 1.f;
+ }
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 6) {
+
+/* General, eigenvalues specified */
+
+ if (kconds[jtype - 1] == 1) {
+ conds = 1.f;
+ } else if (kconds[jtype - 1] == 2) {
+ conds = rtulpi;
+ } else {
+ conds = 0.f;
+ }
+
+ *(unsigned char *)&adumma[0] = ' ';
+ slatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b32,
+ adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
+ n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
+ &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &c__0, &
+ c__0, &c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
+ c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* General, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
+ c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+ if (n >= 4) {
+ slaset_("Full", &c__2, &n, &c_b18, &c_b18, &a[a_offset],
+ lda);
+ i__3 = n - 3;
+ slaset_("Full", &i__3, &c__1, &c_b18, &c_b18, &a[a_dim1 +
+ 3], lda);
+ i__3 = n - 3;
+ slaset_("Full", &i__3, &c__2, &c_b18, &c_b18, &a[(n - 1) *
+ a_dim1 + 3], lda);
+ slaset_("Full", &c__1, &n, &c_b18, &c_b18, &a[n + a_dim1],
+ lda);
+ }
+
+ } else if (itype == 10) {
+
+/* Triangular, random eigenvalues */
+
+ slatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
+ &c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
+ n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &c__0, &
+ c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___33.ciunit = *nounit;
+ s_wsfe(&io___33);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+/* Test for minimal and generous workspace */
+
+ for (iwk = 1; iwk <= 3; ++iwk) {
+ if (iwk == 1) {
+ nnwork = n * 3;
+ } else if (iwk == 2) {
+/* Computing 2nd power */
+ i__3 = n;
+ nnwork = n * 6 + i__3 * i__3;
+ } else {
+/* Computing 2nd power */
+ i__3 = n;
+ nnwork = n * 6 + (i__3 * i__3 << 1);
+ }
+ nnwork = max(nnwork,1);
+
+/* Test for all balancing options */
+
+ for (ibal = 1; ibal <= 4; ++ibal) {
+ *(unsigned char *)balanc = *(unsigned char *)&bal[ibal -
+ 1];
+
+/* Perform tests */
+
+ sget23_(&c_false, balanc, &jtype, thresh, ioldsd, nounit,
+ &n, &a[a_offset], lda, &h__[h_offset], &wr[1], &
+ wi[1], &wr1[1], &wi1[1], &vl[vl_offset], ldvl, &
+ vr[vr_offset], ldvr, &lre[lre_offset], ldlre, &
+ rcondv[1], &rcndv1[1], &rcdvin[1], &rconde[1], &
+ rcnde1[1], &rcdein[1], &scale[1], &scale1[1], &
+ result[1], &work[1], &nnwork, &iwork[1], info);
+
+/* Check for RESULT(j) > THRESH */
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 9; ++j) {
+ if (result[j] >= 0.f) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L100: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___40.ciunit = *nounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ e_wsfe();
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ e_wsfe();
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ e_wsfe();
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ ntestf = 2;
+ }
+
+ for (j = 1; j <= 9; ++j) {
+ if (result[j] >= *thresh) {
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, balanc, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ }
+/* L110: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+
+/* L120: */
+ }
+/* L130: */
+ }
+L140:
+ ;
+ }
+/* L150: */
+ }
+
+L160:
+
+/* Read in data from file to check accuracy of condition estimation. */
+/* Assume input eigenvalues are sorted lexicographically (increasing */
+/* by real part, then decreasing by imaginary part) */
+
+ jtype = 0;
+L170:
+ io___46.ciunit = *niunit;
+ i__1 = s_rsle(&io___46);
+ if (i__1 != 0) {
+ goto L220;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L220;
+ }
+ i__1 = e_rsle();
+ if (i__1 != 0) {
+ goto L220;
+ }
+
+/* Read input data until N=0 */
+
+ if (n == 0) {
+ goto L220;
+ }
+ ++jtype;
+ iseed[1] = jtype;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___48.ciunit = *niunit;
+ s_rsle(&io___48);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__4, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
+ real));
+ }
+ e_rsle();
+/* L180: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___49.ciunit = *niunit;
+ s_rsle(&io___49);
+ do_lio(&c__4, &c__1, (char *)&wr1[i__], (ftnlen)sizeof(real));
+ do_lio(&c__4, &c__1, (char *)&wi1[i__], (ftnlen)sizeof(real));
+ do_lio(&c__4, &c__1, (char *)&rcdein[i__], (ftnlen)sizeof(real));
+ do_lio(&c__4, &c__1, (char *)&rcdvin[i__], (ftnlen)sizeof(real));
+ e_rsle();
+/* L190: */
+ }
+/* Computing 2nd power */
+ i__2 = n;
+ i__1 = n * 6 + (i__2 * i__2 << 1);
+ sget23_(&c_true, "N", &c__22, thresh, &iseed[1], nounit, &n, &a[a_offset],
+ lda, &h__[h_offset], &wr[1], &wi[1], &wr1[1], &wi1[1], &vl[
+ vl_offset], ldvl, &vr[vr_offset], ldvr, &lre[lre_offset], ldlre, &
+ rcondv[1], &rcndv1[1], &rcdvin[1], &rconde[1], &rcnde1[1], &
+ rcdein[1], &scale[1], &scale1[1], &result[1], &work[1], &i__1, &
+ iwork[1], info);
+
+/* Check for RESULT(j) > THRESH */
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 11; ++j) {
+ if (result[j] >= 0.f) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L200: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ e_wsfe();
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ e_wsfe();
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ e_wsfe();
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
+ e_wsfe();
+ ntestf = 2;
+ }
+
+ for (j = 1; j <= 11; ++j) {
+ if (result[j] >= *thresh) {
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+/* L210: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+ goto L170;
+L220:
+
+/* Summary */
+
+ slasum_(path, nounit, &nerrs, &ntestt);
+
+
+
+ return 0;
+
+/* End of SDRVVX */
+
+} /* sdrvvx_ */
diff --git a/TESTING/EIG/serrbd.c b/TESTING/EIG/serrbd.c
new file mode 100644
index 0000000..eecc3eb
--- /dev/null
+++ b/TESTING/EIG/serrbd.c
@@ -0,0 +1,396 @@
+/* serrbd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int serrbd_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
+ "rror exits\002,\002 (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
+ "ts of the error \002,\002exits ***\002)";
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ real a[16] /* was [4][4] */, d__[4], e[4];
+ integer i__, j;
+ real q[16] /* was [4][4] */, u[16] /* was [4][4] */, v[16] /* was [4][4]
+ */, w[4];
+ char c2[2];
+ integer iq[16] /* was [4][4] */, iw[4], nt;
+ real tp[4], tq[4];
+ integer info;
+ extern /* Subroutine */ int sgebd2_(integer *, integer *, real *, integer
+ *, real *, real *, real *, real *, real *, integer *), sbdsdc_(
+ char *, char *, integer *, real *, real *, real *, integer *,
+ real *, integer *, real *, integer *, real *, integer *, integer *
+), sgebrd_(integer *, integer *, real *, integer *
+, real *, real *, real *, real *, real *, integer *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), sbdsqr_(char *, integer *, integer *,
+ integer *, integer *, real *, real *, real *, integer *, real *,
+ integer *, real *, integer *, real *, integer *), sorgbr_(
+ char *, integer *, integer *, integer *, real *, integer *, real *
+, real *, integer *, integer *), sormbr_(char *, char *,
+ char *, integer *, integer *, integer *, real *, integer *, real *
+, real *, integer *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___18 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___19 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SERRBD tests the error exits for SGEBRD, SORGBR, SORMBR, SBDSQR and */
+/* SBDSDC. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (j << 2) - 5] = 1.f / (real) (i__ + j);
+/* L10: */
+ }
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+ nt = 0;
+
+/* Test error exits of the SVD routines. */
+
+ if (lsamen_(&c__2, c2, "BD")) {
+
+/* SGEBRD */
+
+ s_copy(srnamc_1.srnamt, "SGEBRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgebrd_(&c_n1, &c__0, a, &c__1, d__, e, tq, tp, w, &c__1, &info);
+ chkxer_("SGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgebrd_(&c__0, &c_n1, a, &c__1, d__, e, tq, tp, w, &c__1, &info);
+ chkxer_("SGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgebrd_(&c__2, &c__1, a, &c__1, d__, e, tq, tp, w, &c__2, &info);
+ chkxer_("SGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sgebrd_(&c__2, &c__1, a, &c__2, d__, e, tq, tp, w, &c__1, &info);
+ chkxer_("SGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 4;
+
+/* SGEBD2 */
+
+ s_copy(srnamc_1.srnamt, "SGEBD2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgebd2_(&c_n1, &c__0, a, &c__1, d__, e, tq, tp, w, &info);
+ chkxer_("SGEBD2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgebd2_(&c__0, &c_n1, a, &c__1, d__, e, tq, tp, w, &info);
+ chkxer_("SGEBD2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgebd2_(&c__2, &c__1, a, &c__1, d__, e, tq, tp, w, &info);
+ chkxer_("SGEBD2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 3;
+
+/* SORGBR */
+
+ s_copy(srnamc_1.srnamt, "SORGBR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sorgbr_("/", &c__0, &c__0, &c__0, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("SORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sorgbr_("Q", &c_n1, &c__0, &c__0, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("SORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorgbr_("Q", &c__0, &c_n1, &c__0, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("SORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorgbr_("Q", &c__0, &c__1, &c__0, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("SORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorgbr_("Q", &c__1, &c__0, &c__1, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("SORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorgbr_("P", &c__1, &c__0, &c__0, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("SORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorgbr_("P", &c__0, &c__1, &c__1, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("SORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sorgbr_("Q", &c__0, &c__0, &c_n1, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("SORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sorgbr_("Q", &c__2, &c__1, &c__1, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("SORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sorgbr_("Q", &c__2, &c__2, &c__1, a, &c__2, tq, w, &c__1, &info);
+ chkxer_("SORGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* SORMBR */
+
+ s_copy(srnamc_1.srnamt, "SORMBR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sormbr_("/", "L", "T", &c__0, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("SORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sormbr_("Q", "/", "T", &c__0, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("SORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sormbr_("Q", "L", "/", &c__0, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("SORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sormbr_("Q", "L", "T", &c_n1, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("SORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sormbr_("Q", "L", "T", &c__0, &c_n1, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("SORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sormbr_("Q", "L", "T", &c__0, &c__0, &c_n1, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("SORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sormbr_("Q", "L", "T", &c__2, &c__0, &c__0, a, &c__1, tq, u, &c__2, w,
+ &c__1, &info);
+ chkxer_("SORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sormbr_("Q", "R", "T", &c__0, &c__2, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("SORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sormbr_("P", "L", "T", &c__2, &c__0, &c__2, a, &c__1, tq, u, &c__2, w,
+ &c__1, &info);
+ chkxer_("SORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sormbr_("P", "R", "T", &c__0, &c__2, &c__2, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("SORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ sormbr_("Q", "R", "T", &c__2, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("SORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ sormbr_("Q", "L", "T", &c__0, &c__2, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("SORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ sormbr_("Q", "R", "T", &c__2, &c__0, &c__0, a, &c__1, tq, u, &c__2, w,
+ &c__1, &info);
+ chkxer_("SORMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 13;
+
+/* SBDSQR */
+
+ s_copy(srnamc_1.srnamt, "SBDSQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sbdsqr_("/", &c__0, &c__0, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, w, &info);
+ chkxer_("SBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sbdsqr_("U", &c_n1, &c__0, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, w, &info);
+ chkxer_("SBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sbdsqr_("U", &c__0, &c_n1, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, w, &info);
+ chkxer_("SBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sbdsqr_("U", &c__0, &c__0, &c_n1, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, w, &info);
+ chkxer_("SBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sbdsqr_("U", &c__0, &c__0, &c__0, &c_n1, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, w, &info);
+ chkxer_("SBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sbdsqr_("U", &c__2, &c__1, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, w, &info);
+ chkxer_("SBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ sbdsqr_("U", &c__0, &c__0, &c__2, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, w, &info);
+ chkxer_("SBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ sbdsqr_("U", &c__2, &c__0, &c__0, &c__1, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, w, &info);
+ chkxer_("SBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* SBDSDC */
+
+ s_copy(srnamc_1.srnamt, "SBDSDC", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sbdsdc_("/", "N", &c__0, d__, e, u, &c__1, v, &c__1, q, iq, w, iw, &
+ info);
+ chkxer_("SBDSDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sbdsdc_("U", "/", &c__0, d__, e, u, &c__1, v, &c__1, q, iq, w, iw, &
+ info);
+ chkxer_("SBDSDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sbdsdc_("U", "N", &c_n1, d__, e, u, &c__1, v, &c__1, q, iq, w, iw, &
+ info);
+ chkxer_("SBDSDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sbdsdc_("U", "I", &c__2, d__, e, u, &c__1, v, &c__1, q, iq, w, iw, &
+ info);
+ chkxer_("SBDSDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sbdsdc_("U", "I", &c__2, d__, e, u, &c__2, v, &c__1, q, iq, w, iw, &
+ info);
+ chkxer_("SBDSDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 5;
+ }
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___18.ciunit = infoc_1.nout;
+ s_wsfe(&io___18);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___19.ciunit = infoc_1.nout;
+ s_wsfe(&io___19);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of SERRBD */
+
+} /* serrbd_ */
diff --git a/TESTING/EIG/serrec.c b/TESTING/EIG/serrec.c
new file mode 100644
index 0000000..e449ac4
--- /dev/null
+++ b/TESTING/EIG/serrec.c
@@ -0,0 +1,356 @@
+/* serrec.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__4 = 4;
+
+/* Subroutine */ int serrec_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
+ "rror exits (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
+ "ts of the error ex\002,\002its ***\002)";
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ real a[16] /* was [4][4] */, b[16] /* was [4][4] */, c__[16] /*
+ was [4][4] */;
+ integer i__, j, m;
+ real s[4], wi[4];
+ integer nt;
+ real wr[4];
+ logical sel[4];
+ real sep[4];
+ integer info, ifst, ilst;
+ real work[4], scale;
+ integer iwork[4];
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), strexc_(char *, integer *, real *, integer
+ *, real *, integer *, integer *, integer *, real *, integer *), strsna_(char *, char *, logical *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, real *, real *,
+ integer *, integer *, real *, integer *, integer *, integer *), strsen_(char *, char *, logical *, integer *,
+ real *, integer *, real *, integer *, real *, real *, integer *,
+ real *, real *, real *, integer *, integer *, integer *, integer *
+), strsyl_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___19 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___20 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SERREC tests the error exits for the routines for eigen- condition */
+/* estimation for REAL matrices: */
+/* STRSYL, STREXC, STRSNA and STRSEN. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ infoc_1.ok = TRUE_;
+ nt = 0;
+
+/* Initialize A, B and SEL */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (j << 2) - 5] = 0.f;
+ b[i__ + (j << 2) - 5] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (i__ << 2) - 5] = 1.f;
+ sel[i__ - 1] = TRUE_;
+/* L30: */
+ }
+
+/* Test STRSYL */
+
+ s_copy(srnamc_1.srnamt, "STRSYL", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ strsyl_("X", "N", &c__1, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ strsyl_("N", "X", &c__1, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ strsyl_("N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ strsyl_("N", "N", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ strsyl_("N", "N", &c__1, &c__0, &c_n1, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ strsyl_("N", "N", &c__1, &c__2, &c__0, a, &c__1, b, &c__1, c__, &c__2, &
+ scale, &info);
+ chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ strsyl_("N", "N", &c__1, &c__0, &c__2, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ strsyl_("N", "N", &c__1, &c__2, &c__0, a, &c__2, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("STRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Test STREXC */
+
+ s_copy(srnamc_1.srnamt, "STREXC", (ftnlen)32, (ftnlen)6);
+ ifst = 1;
+ ilst = 1;
+ infoc_1.infot = 1;
+ strexc_("X", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
+ chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ strexc_("N", &c__0, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
+ chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ilst = 2;
+ strexc_("N", &c__2, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
+ chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ strexc_("V", &c__2, a, &c__2, b, &c__1, &ifst, &ilst, work, &info);
+ chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ifst = 0;
+ ilst = 1;
+ strexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
+ chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ifst = 2;
+ strexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
+ chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ifst = 1;
+ ilst = 0;
+ strexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
+ chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ilst = 2;
+ strexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, work, &info);
+ chkxer_("STREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Test STRSNA */
+
+ s_copy(srnamc_1.srnamt, "STRSNA", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ strsna_("X", "A", sel, &c__0, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
+ c__1, &m, work, &c__1, iwork, &info);
+ chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ strsna_("B", "X", sel, &c__0, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
+ c__1, &m, work, &c__1, iwork, &info);
+ chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ strsna_("B", "A", sel, &c_n1, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
+ c__1, &m, work, &c__1, iwork, &info);
+ chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ strsna_("V", "A", sel, &c__2, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
+ c__2, &m, work, &c__2, iwork, &info);
+ chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ strsna_("B", "A", sel, &c__2, a, &c__2, b, &c__1, c__, &c__2, s, sep, &
+ c__2, &m, work, &c__2, iwork, &info);
+ chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ strsna_("B", "A", sel, &c__2, a, &c__2, b, &c__2, c__, &c__1, s, sep, &
+ c__2, &m, work, &c__2, iwork, &info);
+ chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ strsna_("B", "A", sel, &c__1, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
+ c__0, &m, work, &c__1, iwork, &info);
+ chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ strsna_("B", "S", sel, &c__2, a, &c__2, b, &c__2, c__, &c__2, s, sep, &
+ c__1, &m, work, &c__2, iwork, &info);
+ chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ strsna_("B", "A", sel, &c__2, a, &c__2, b, &c__2, c__, &c__2, s, sep, &
+ c__2, &m, work, &c__1, iwork, &info);
+ chkxer_("STRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* Test STRSEN */
+
+ sel[0] = FALSE_;
+ s_copy(srnamc_1.srnamt, "STRSEN", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ strsen_("X", "N", sel, &c__0, a, &c__1, b, &c__1, wr, wi, &m, s, sep,
+ work, &c__1, iwork, &c__1, &info);
+ chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ strsen_("N", "X", sel, &c__0, a, &c__1, b, &c__1, wr, wi, &m, s, sep,
+ work, &c__1, iwork, &c__1, &info);
+ chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ strsen_("N", "N", sel, &c_n1, a, &c__1, b, &c__1, wr, wi, &m, s, sep,
+ work, &c__1, iwork, &c__1, &info);
+ chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ strsen_("N", "N", sel, &c__2, a, &c__1, b, &c__1, wr, wi, &m, s, sep,
+ work, &c__2, iwork, &c__1, &info);
+ chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ strsen_("N", "V", sel, &c__2, a, &c__2, b, &c__1, wr, wi, &m, s, sep,
+ work, &c__1, iwork, &c__1, &info);
+ chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ strsen_("N", "V", sel, &c__2, a, &c__2, b, &c__2, wr, wi, &m, s, sep,
+ work, &c__0, iwork, &c__1, &info);
+ chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ strsen_("E", "V", sel, &c__3, a, &c__3, b, &c__3, wr, wi, &m, s, sep,
+ work, &c__1, iwork, &c__1, &info);
+ chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ strsen_("V", "V", sel, &c__3, a, &c__3, b, &c__3, wr, wi, &m, s, sep,
+ work, &c__3, iwork, &c__2, &info);
+ chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 17;
+ strsen_("E", "V", sel, &c__2, a, &c__2, b, &c__2, wr, wi, &m, s, sep,
+ work, &c__1, iwork, &c__0, &info);
+ chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 17;
+ strsen_("V", "V", sel, &c__3, a, &c__3, b, &c__3, wr, wi, &m, s, sep,
+ work, &c__4, iwork, &c__1, &info);
+ chkxer_("STRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___19.ciunit = infoc_1.nout;
+ s_wsfe(&io___19);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___20.ciunit = infoc_1.nout;
+ s_wsfe(&io___20);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ return 0;
+
+/* End of SERREC */
+
+} /* serrec_ */
diff --git a/TESTING/EIG/serred.c b/TESTING/EIG/serred.c
new file mode 100644
index 0000000..b78bdeb
--- /dev/null
+++ b/TESTING/EIG/serred.c
@@ -0,0 +1,467 @@
+/* serred.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ real selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__6 = 6;
+static integer c__8 = 8;
+static integer c__3 = 3;
+static integer c__5 = 5;
+
+/* Subroutine */ int serred_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
+ "rror exits (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
+ "ts of the error ex\002,\002its ***\002)";
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ real a[16] /* was [4][4] */;
+ logical b[4];
+ integer i__, j;
+ real s[4], u[16] /* was [4][4] */, w[16];
+ char c2[2];
+ real r1[4], r2[4];
+ integer iw[8];
+ real wi[4];
+ integer nt;
+ real vl[16] /* was [4][4] */, vr[16] /* was [4][4] */, wr[4], vt[
+ 16] /* was [4][4] */;
+ integer ihi, ilo, info, sdim;
+ real abnrm;
+ extern /* Subroutine */ int sgees_(char *, char *, L_fp, integer *, real *
+, integer *, integer *, real *, real *, real *, integer *, real *,
+ integer *, logical *, integer *), sgeev_(char *,
+ char *, integer *, real *, integer *, real *, real *, real *,
+ integer *, real *, integer *, real *, integer *, integer *), sgesdd_(char *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ integer *, integer *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), sgesvd_(char *, char *, integer *, integer
+ *, real *, integer *, real *, real *, integer *, real *, integer *
+, real *, integer *, integer *);
+ extern logical sslect_();
+ extern /* Subroutine */ int sgeesx_(char *, char *, L_fp, char *, integer
+ *, real *, integer *, integer *, real *, real *, real *, integer *
+, real *, real *, real *, integer *, integer *, integer *,
+ logical *, integer *), sgeevx_(char *,
+ char *, char *, char *, integer *, real *, integer *, real *,
+ real *, real *, integer *, real *, integer *, integer *, integer *
+, real *, real *, real *, real *, real *, integer *, integer *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SERRED tests the error exits for the eigenvalue driver routines for */
+/* REAL matrices: */
+
+/* PATH driver description */
+/* ---- ------ ----------- */
+/* SEV SGEEV find eigenvalues/eigenvectors for nonsymmetric A */
+/* SES SGEES find eigenvalues/Schur form for nonsymmetric A */
+/* SVX SGEEVX SGEEV + balancing and condition estimation */
+/* SSX SGEESX SGEES + balancing and condition estimation */
+/* SBD SGESVD compute SVD of an M-by-N matrix A */
+/* SGESDD compute SVD of an M-by-N matrix A (by divide and */
+/* conquer) */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Initialize A */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (j << 2) - 5] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (i__ << 2) - 5] = 1.f;
+/* L30: */
+ }
+ infoc_1.ok = TRUE_;
+ nt = 0;
+
+ if (lsamen_(&c__2, c2, "EV")) {
+
+/* Test SGEEV */
+
+ s_copy(srnamc_1.srnamt, "SGEEV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgeev_("X", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
+ c__1, &info);
+ chkxer_("SGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgeev_("N", "X", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
+ c__1, &info);
+ chkxer_("SGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgeev_("N", "N", &c_n1, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
+ c__1, &info);
+ chkxer_("SGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgeev_("N", "N", &c__2, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
+ c__6, &info);
+ chkxer_("SGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sgeev_("V", "N", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &c__1, w, &
+ c__8, &info);
+ chkxer_("SGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ sgeev_("N", "V", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &c__1, w, &
+ c__8, &info);
+ chkxer_("SGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ sgeev_("V", "V", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
+ c__3, &info);
+ chkxer_("SGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+
+ } else if (lsamen_(&c__2, c2, "ES")) {
+
+/* Test SGEES */
+
+ s_copy(srnamc_1.srnamt, "SGEES ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgees_("X", "N", (L_fp)sslect_, &c__0, a, &c__1, &sdim, wr, wi, vl, &
+ c__1, w, &c__1, b, &info);
+ chkxer_("SGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgees_("N", "X", (L_fp)sslect_, &c__0, a, &c__1, &sdim, wr, wi, vl, &
+ c__1, w, &c__1, b, &info);
+ chkxer_("SGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgees_("N", "S", (L_fp)sslect_, &c_n1, a, &c__1, &sdim, wr, wi, vl, &
+ c__1, w, &c__1, b, &info);
+ chkxer_("SGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sgees_("N", "S", (L_fp)sslect_, &c__2, a, &c__1, &sdim, wr, wi, vl, &
+ c__1, w, &c__6, b, &info);
+ chkxer_("SGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ sgees_("V", "S", (L_fp)sslect_, &c__2, a, &c__2, &sdim, wr, wi, vl, &
+ c__1, w, &c__6, b, &info);
+ chkxer_("SGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ sgees_("N", "S", (L_fp)sslect_, &c__1, a, &c__1, &sdim, wr, wi, vl, &
+ c__1, w, &c__2, b, &info);
+ chkxer_("SGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+ } else if (lsamen_(&c__2, c2, "VX")) {
+
+/* Test SGEEVX */
+
+ s_copy(srnamc_1.srnamt, "SGEEVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgeevx_("X", "N", "N", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
+ chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgeevx_("N", "X", "N", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
+ chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgeevx_("N", "N", "X", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
+ chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgeevx_("N", "N", "N", "X", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
+ chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgeevx_("N", "N", "N", "N", &c_n1, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
+ chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sgeevx_("N", "N", "N", "N", &c__2, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
+ chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ sgeevx_("N", "V", "N", "N", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
+ c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__6, iw, &info);
+ chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ sgeevx_("N", "N", "V", "N", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
+ c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__6, iw, &info);
+ chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 21;
+ sgeevx_("N", "N", "N", "N", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
+ chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 21;
+ sgeevx_("N", "V", "N", "N", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__2, iw, &info);
+ chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 21;
+ sgeevx_("N", "N", "V", "V", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__3, iw, &info);
+ chkxer_("SGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+ } else if (lsamen_(&c__2, c2, "SX")) {
+
+/* Test SGEESX */
+
+ s_copy(srnamc_1.srnamt, "SGEESX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgeesx_("X", "N", (L_fp)sslect_, "N", &c__0, a, &c__1, &sdim, wr, wi,
+ vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
+ chkxer_("SGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgeesx_("N", "X", (L_fp)sslect_, "N", &c__0, a, &c__1, &sdim, wr, wi,
+ vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
+ chkxer_("SGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgeesx_("N", "N", (L_fp)sslect_, "X", &c__0, a, &c__1, &sdim, wr, wi,
+ vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
+ chkxer_("SGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgeesx_("N", "N", (L_fp)sslect_, "N", &c_n1, a, &c__1, &sdim, wr, wi,
+ vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
+ chkxer_("SGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sgeesx_("N", "N", (L_fp)sslect_, "N", &c__2, a, &c__1, &sdim, wr, wi,
+ vl, &c__1, r1, r2, w, &c__6, iw, &c__1, b, &info);
+ chkxer_("SGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sgeesx_("V", "N", (L_fp)sslect_, "N", &c__2, a, &c__2, &sdim, wr, wi,
+ vl, &c__1, r1, r2, w, &c__6, iw, &c__1, b, &info);
+ chkxer_("SGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ sgeesx_("N", "N", (L_fp)sslect_, "N", &c__1, a, &c__1, &sdim, wr, wi,
+ vl, &c__1, r1, r2, w, &c__2, iw, &c__1, b, &info);
+ chkxer_("SGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+
+ } else if (lsamen_(&c__2, c2, "BD")) {
+
+/* Test SGESVD */
+
+ s_copy(srnamc_1.srnamt, "SGESVD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgesvd_("X", "N", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__1, &info);
+ chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgesvd_("N", "X", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__1, &info);
+ chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgesvd_("O", "O", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__1, &info);
+ chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgesvd_("N", "N", &c_n1, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__1, &info);
+ chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgesvd_("N", "N", &c__0, &c_n1, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__1, &info);
+ chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sgesvd_("N", "N", &c__2, &c__1, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__5, &info);
+ chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sgesvd_("A", "N", &c__2, &c__1, a, &c__2, s, u, &c__1, vt, &c__1, w, &
+ c__5, &info);
+ chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ sgesvd_("N", "A", &c__1, &c__2, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__5, &info);
+ chkxer_("SGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Test SGESDD */
+
+ s_copy(srnamc_1.srnamt, "SGESDD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgesdd_("X", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
+ iw, &info);
+ chkxer_("SGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgesdd_("N", &c_n1, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
+ iw, &info);
+ chkxer_("SGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgesdd_("N", &c__0, &c_n1, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
+ iw, &info);
+ chkxer_("SGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgesdd_("N", &c__2, &c__1, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__5,
+ iw, &info);
+ chkxer_("SGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sgesdd_("A", &c__2, &c__1, a, &c__2, s, u, &c__1, vt, &c__1, w, &c__5,
+ iw, &info);
+ chkxer_("SGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sgesdd_("A", &c__1, &c__2, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__5,
+ iw, &info);
+ chkxer_("SGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+ }
+
+/* Print a summary line. */
+
+ if (! lsamen_(&c__2, c2, "BD")) {
+ if (infoc_1.ok) {
+ io___24.ciunit = infoc_1.nout;
+ s_wsfe(&io___24);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___25.ciunit = infoc_1.nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+ }
+
+ return 0;
+
+/* End of SERRED */
+
+} /* serred_ */
diff --git a/TESTING/EIG/serrgg.c b/TESTING/EIG/serrgg.c
new file mode 100644
index 0000000..ae041c3
--- /dev/null
+++ b/TESTING/EIG/serrgg.c
@@ -0,0 +1,1311 @@
+/* serrgg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__18 = 18;
+static integer c__3 = 3;
+static integer c__32 = 32;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+static integer c__20 = 20;
+
+/* Subroutine */ int serrgg_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
+ "rror exits (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
+ "ts of the error \002,\002exits ***\002)";
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ real a[9] /* was [3][3] */, b[9] /* was [3][3] */;
+ integer i__, j, m;
+ real q[9] /* was [3][3] */, u[9] /* was [3][3] */, v[9] /* was [3][3]
+ */, w[18], z__[9] /* was [3][3] */;
+ char c2[2];
+ real r1[3], r2[3], r3[3];
+ logical bw[3];
+ real ls[3];
+ integer iw[3], nt;
+ real rs[3], dif, rce[2];
+ logical sel[3];
+ real tau[3], rcv[2];
+ integer info, sdim;
+ real anrm, bnrm, tola, tolb;
+ integer ifst, ilst;
+ real scale;
+ extern /* Subroutine */ int sgges_(char *, char *, char *, L_fp, integer *
+, real *, integer *, real *, integer *, integer *, real *, real *,
+ real *, real *, integer *, real *, integer *, real *, integer *,
+ logical *, integer *), sggev_(char *,
+ char *, integer *, real *, integer *, real *, integer *, real *,
+ real *, real *, real *, integer *, real *, integer *, real *,
+ integer *, integer *);
+ integer ncycle;
+ extern /* Subroutine */ int sgghrd_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, integer *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int sggglm_(integer *, integer *, integer *, real
+ *, integer *, real *, integer *, real *, real *, real *, real *,
+ integer *, integer *), chkxer_(char *, integer *, integer *,
+ logical *, logical *), sgglse_(integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, real *,
+ real *, real *, integer *, integer *), sggqrf_(integer *, integer
+ *, integer *, real *, integer *, real *, real *, integer *, real *
+, real *, integer *, integer *), sggrqf_(integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ real *, integer *, integer *), stgevc_(char *, char *, logical *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, integer *, integer *, integer *, real *, integer *);
+ extern logical slctes_();
+ extern /* Subroutine */ int sggsvd_(char *, char *, char *, integer *,
+ integer *, integer *, integer *, integer *, real *, integer *,
+ real *, integer *, real *, real *, real *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, integer *), stgexc_(logical *, logical *, integer *,
+ real *, integer *, real *, integer *, real *, integer *, real *,
+ integer *, integer *, integer *, real *, integer *, integer *),
+ sggesx_(char *, char *, char *, L_fp, char *, integer *, real *,
+ integer *, real *, integer *, integer *, real *, real *, real *,
+ real *, integer *, real *, integer *, real *, real *, real *,
+ integer *, integer *, integer *, logical *, integer *), shgeqz_(char *, char *, char *, integer *
+, integer *, integer *, real *, integer *, real *, integer *,
+ real *, real *, real *, real *, integer *, real *, integer *,
+ real *, integer *, integer *), stgsja_(
+ char *, char *, char *, integer *, integer *, integer *, integer *
+, integer *, real *, integer *, real *, integer *, real *, real *,
+ real *, real *, real *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, integer *),
+ sggevx_(char *, char *, char *, char *, integer *, real *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ integer *, real *, integer *, integer *, integer *, real *, real *
+, real *, real *, real *, real *, real *, integer *, integer *,
+ logical *, integer *), stgsen_(
+ integer *, logical *, logical *, logical *, integer *, real *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ integer *, real *, integer *, integer *, real *, real *, real *,
+ real *, integer *, integer *, integer *, integer *), stgsna_(char
+ *, char *, logical *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, real *, real *,
+ integer *, integer *, real *, integer *, integer *, integer *);
+ integer dummyk, dummyl;
+ extern /* Subroutine */ int sggsvp_(char *, char *, char *, integer *,
+ integer *, integer *, real *, integer *, real *, integer *, real *
+, real *, integer *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, integer *, real *, real *, integer *
+);
+ extern logical slctsx_();
+ extern /* Subroutine */ int stgsyl_(char *, integer *, integer *, integer
+ *, real *, integer *, real *, integer *, real *, integer *, real *
+, integer *, real *, integer *, real *, integer *, real *, real *,
+ real *, integer *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SERRGG tests the error exits for SGGES, SGGESX, SGGEV, SGGEVX, */
+/* SGGGLM, SGGHRD, SGGLSE, SGGQRF, SGGRQF, SGGSVD, SGGSVP, SHGEQZ, */
+/* STGEVC, STGEXC, STGSEN, STGSJA, STGSNA, and STGSYL. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 3; ++j) {
+ sel[j - 1] = TRUE_;
+ for (i__ = 1; i__ <= 3; ++i__) {
+ a[i__ + j * 3 - 4] = 0.f;
+ b[i__ + j * 3 - 4] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ for (i__ = 1; i__ <= 3; ++i__) {
+ a[i__ + i__ * 3 - 4] = 1.f;
+ b[i__ + i__ * 3 - 4] = 1.f;
+/* L30: */
+ }
+ infoc_1.ok = TRUE_;
+ tola = 1.f;
+ tolb = 1.f;
+ ifst = 1;
+ ilst = 1;
+ nt = 0;
+
+/* Test error exits for the GG path. */
+
+ if (lsamen_(&c__2, c2, "GG")) {
+
+/* SGGHRD */
+
+ s_copy(srnamc_1.srnamt, "SGGHRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgghrd_("/", "N", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("SGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgghrd_("N", "/", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("SGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgghrd_("N", "N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("SGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgghrd_("N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("SGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgghrd_("N", "N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("SGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sgghrd_("N", "N", &c__2, &c__1, &c__1, a, &c__1, b, &c__2, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("SGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sgghrd_("N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("SGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ sgghrd_("V", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("SGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ sgghrd_("N", "V", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("SGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* SHGEQZ */
+
+ s_copy(srnamc_1.srnamt, "SHGEQZ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ shgeqz_("/", "N", "N", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, w, &c__18, &info);
+ chkxer_("SHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ shgeqz_("E", "/", "N", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, w, &c__18, &info);
+ chkxer_("SHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ shgeqz_("E", "N", "/", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, w, &c__18, &info);
+ chkxer_("SHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ shgeqz_("E", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, w, &c__18, &info);
+ chkxer_("SHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ shgeqz_("E", "N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, w, &c__18, &info);
+ chkxer_("SHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ shgeqz_("E", "N", "N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, w, &c__18, &info);
+ chkxer_("SHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ shgeqz_("E", "N", "N", &c__2, &c__1, &c__1, a, &c__1, b, &c__2, r1,
+ r2, r3, q, &c__1, z__, &c__1, w, &c__18, &info);
+ chkxer_("SHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ shgeqz_("E", "N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, w, &c__18, &info);
+ chkxer_("SHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ shgeqz_("E", "V", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, r1,
+ r2, r3, q, &c__1, z__, &c__1, w, &c__18, &info);
+ chkxer_("SHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 17;
+ shgeqz_("E", "N", "V", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, r1,
+ r2, r3, q, &c__1, z__, &c__1, w, &c__18, &info);
+ chkxer_("SHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* STGEVC */
+
+ s_copy(srnamc_1.srnamt, "STGEVC", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ stgevc_("/", "A", sel, &c__0, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__1, &c__0, &m, w, &info);
+ chkxer_("STGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ stgevc_("R", "/", sel, &c__0, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__1, &c__0, &m, w, &info);
+ chkxer_("STGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ stgevc_("R", "A", sel, &c_n1, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__1, &c__0, &m, w, &info);
+ chkxer_("STGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ stgevc_("R", "A", sel, &c__2, a, &c__1, b, &c__2, q, &c__1, z__, &
+ c__2, &c__0, &m, w, &info);
+ chkxer_("STGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ stgevc_("R", "A", sel, &c__2, a, &c__2, b, &c__1, q, &c__1, z__, &
+ c__2, &c__0, &m, w, &info);
+ chkxer_("STGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ stgevc_("L", "A", sel, &c__2, a, &c__2, b, &c__2, q, &c__1, z__, &
+ c__1, &c__0, &m, w, &info);
+ chkxer_("STGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ stgevc_("R", "A", sel, &c__2, a, &c__2, b, &c__2, q, &c__1, z__, &
+ c__1, &c__0, &m, w, &info);
+ chkxer_("STGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ stgevc_("R", "A", sel, &c__2, a, &c__2, b, &c__2, q, &c__1, z__, &
+ c__2, &c__1, &m, w, &info);
+ chkxer_("STGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Test error exits for the GSV path. */
+
+ } else if (lsamen_(&c__3, path, "GSV")) {
+
+/* SGGSVD */
+
+ s_copy(srnamc_1.srnamt, "SGGSVD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sggsvd_("/", "N", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, iw, &
+ info);
+ chkxer_("SGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sggsvd_("N", "/", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, iw, &
+ info);
+ chkxer_("SGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sggsvd_("N", "N", "/", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, iw, &
+ info);
+ chkxer_("SGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sggsvd_("N", "N", "N", &c_n1, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, iw, &
+ info);
+ chkxer_("SGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sggsvd_("N", "N", "N", &c__0, &c_n1, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, iw, &
+ info);
+ chkxer_("SGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sggsvd_("N", "N", "N", &c__0, &c__0, &c_n1, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, iw, &
+ info);
+ chkxer_("SGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sggsvd_("N", "N", "N", &c__2, &c__1, &c__1, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, iw, &
+ info);
+ chkxer_("SGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sggsvd_("N", "N", "N", &c__1, &c__1, &c__2, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, iw, &
+ info);
+ chkxer_("SGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ sggsvd_("U", "N", "N", &c__2, &c__2, &c__2, &dummyk, &dummyl, a, &
+ c__2, b, &c__2, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, iw, &
+ info);
+ chkxer_("SGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ sggsvd_("N", "V", "N", &c__1, &c__1, &c__2, &dummyk, &dummyl, a, &
+ c__1, b, &c__2, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, iw, &
+ info);
+ chkxer_("SGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ sggsvd_("N", "N", "Q", &c__1, &c__2, &c__1, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, iw, &
+ info);
+ chkxer_("SGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* SGGSVP */
+
+ s_copy(srnamc_1.srnamt, "SGGSVP", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sggsvp_("/", "N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ tau, w, &info);
+ chkxer_("SGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sggsvp_("N", "/", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ tau, w, &info);
+ chkxer_("SGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sggsvp_("N", "N", "/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ tau, w, &info);
+ chkxer_("SGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sggsvp_("N", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ tau, w, &info);
+ chkxer_("SGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sggsvp_("N", "N", "N", &c__0, &c_n1, &c__0, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ tau, w, &info);
+ chkxer_("SGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sggsvp_("N", "N", "N", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ tau, w, &info);
+ chkxer_("SGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sggsvp_("N", "N", "N", &c__2, &c__1, &c__1, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ tau, w, &info);
+ chkxer_("SGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sggsvp_("N", "N", "N", &c__1, &c__2, &c__1, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ tau, w, &info);
+ chkxer_("SGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ sggsvp_("U", "N", "N", &c__2, &c__2, &c__2, a, &c__2, b, &c__2, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ tau, w, &info);
+ chkxer_("SGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ sggsvp_("N", "V", "N", &c__1, &c__2, &c__1, a, &c__1, b, &c__2, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ tau, w, &info);
+ chkxer_("SGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ sggsvp_("N", "N", "Q", &c__1, &c__1, &c__2, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ tau, w, &info);
+ chkxer_("SGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* STGSJA */
+
+ s_copy(srnamc_1.srnamt, "STGSJA", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ stgsja_("/", "N", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("STGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ stgsja_("N", "/", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("STGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ stgsja_("N", "N", "/", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("STGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ stgsja_("N", "N", "N", &c_n1, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("STGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ stgsja_("N", "N", "N", &c__0, &c_n1, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("STGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ stgsja_("N", "N", "N", &c__0, &c__0, &c_n1, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("STGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ stgsja_("N", "N", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__0, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("STGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ stgsja_("N", "N", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__0, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("STGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ stgsja_("U", "N", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__0, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("STGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ stgsja_("N", "V", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__0, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("STGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 22;
+ stgsja_("N", "N", "Q", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__0, w, &ncycle, &info);
+ chkxer_("STGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* Test error exits for the GLM path. */
+
+ } else if (lsamen_(&c__3, path, "GLM")) {
+
+/* SGGGLM */
+
+ s_copy(srnamc_1.srnamt, "SGGGLM", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sggglm_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("SGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sggglm_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("SGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sggglm_(&c__0, &c__1, &c__0, a, &c__1, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("SGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sggglm_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("SGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sggglm_(&c__1, &c__0, &c__0, a, &c__1, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("SGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sggglm_(&c__0, &c__0, &c__0, a, &c__0, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("SGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sggglm_(&c__0, &c__0, &c__0, a, &c__1, b, &c__0, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("SGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sggglm_(&c__1, &c__1, &c__1, a, &c__1, b, &c__1, r1, r2, r3, w, &c__1,
+ &info);
+ chkxer_("SGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Test error exits for the LSE path. */
+
+ } else if (lsamen_(&c__3, path, "LSE")) {
+
+/* SGGLSE */
+
+ s_copy(srnamc_1.srnamt, "SGGLSE", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgglse_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("SGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgglse_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("SGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgglse_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("SGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgglse_(&c__0, &c__0, &c__1, a, &c__1, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("SGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgglse_(&c__0, &c__1, &c__0, a, &c__1, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("SGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgglse_(&c__0, &c__0, &c__0, a, &c__0, b, &c__1, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("SGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sgglse_(&c__0, &c__0, &c__0, a, &c__1, b, &c__0, r1, r2, r3, w, &
+ c__18, &info);
+ chkxer_("SGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sgglse_(&c__1, &c__1, &c__1, a, &c__1, b, &c__1, r1, r2, r3, w, &c__1,
+ &info);
+ chkxer_("SGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Test error exits for the GQR path. */
+
+ } else if (lsamen_(&c__3, path, "GQR")) {
+
+/* SGGQRF */
+
+ s_copy(srnamc_1.srnamt, "SGGQRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sggqrf_(&c_n1, &c__0, &c__0, a, &c__1, r1, b, &c__1, r2, w, &c__18, &
+ info);
+ chkxer_("SGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sggqrf_(&c__0, &c_n1, &c__0, a, &c__1, r1, b, &c__1, r2, w, &c__18, &
+ info);
+ chkxer_("SGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sggqrf_(&c__0, &c__0, &c_n1, a, &c__1, r1, b, &c__1, r2, w, &c__18, &
+ info);
+ chkxer_("SGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sggqrf_(&c__0, &c__0, &c__0, a, &c__0, r1, b, &c__1, r2, w, &c__18, &
+ info);
+ chkxer_("SGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sggqrf_(&c__0, &c__0, &c__0, a, &c__1, r1, b, &c__0, r2, w, &c__18, &
+ info);
+ chkxer_("SGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ sggqrf_(&c__1, &c__1, &c__2, a, &c__1, r1, b, &c__1, r2, w, &c__1, &
+ info);
+ chkxer_("SGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+/* SGGRQF */
+
+ s_copy(srnamc_1.srnamt, "SGGRQF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sggrqf_(&c_n1, &c__0, &c__0, a, &c__1, r1, b, &c__1, r2, w, &c__18, &
+ info);
+ chkxer_("SGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sggrqf_(&c__0, &c_n1, &c__0, a, &c__1, r1, b, &c__1, r2, w, &c__18, &
+ info);
+ chkxer_("SGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sggrqf_(&c__0, &c__0, &c_n1, a, &c__1, r1, b, &c__1, r2, w, &c__18, &
+ info);
+ chkxer_("SGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sggrqf_(&c__0, &c__0, &c__0, a, &c__0, r1, b, &c__1, r2, w, &c__18, &
+ info);
+ chkxer_("SGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sggrqf_(&c__0, &c__0, &c__0, a, &c__1, r1, b, &c__0, r2, w, &c__18, &
+ info);
+ chkxer_("SGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ sggrqf_(&c__1, &c__1, &c__2, a, &c__1, r1, b, &c__1, r2, w, &c__1, &
+ info);
+ chkxer_("SGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+/* Test error exits for the SGS, SGV, SGX, and SXV paths. */
+
+ } else if (lsamen_(&c__3, path, "SGS") || lsamen_(&
+ c__3, path, "SGV") || lsamen_(&c__3, path,
+ "SGX") || lsamen_(&c__3, path, "SXV")) {
+
+/* SGGES */
+
+ s_copy(srnamc_1.srnamt, "SGGES ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgges_("/", "N", "S", (L_fp)slctes_, &c__1, a, &c__1, b, &c__1, &sdim,
+ r1, r2, r3, q, &c__1, u, &c__1, w, &c__1, bw, &info);
+ chkxer_("SGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgges_("N", "/", "S", (L_fp)slctes_, &c__1, a, &c__1, b, &c__1, &sdim,
+ r1, r2, r3, q, &c__1, u, &c__1, w, &c__1, bw, &info);
+ chkxer_("SGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgges_("N", "V", "/", (L_fp)slctes_, &c__1, a, &c__1, b, &c__1, &sdim,
+ r1, r2, r3, q, &c__1, u, &c__1, w, &c__1, bw, &info);
+ chkxer_("SGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgges_("N", "V", "S", (L_fp)slctes_, &c_n1, a, &c__1, b, &c__1, &sdim,
+ r1, r2, r3, q, &c__1, u, &c__1, w, &c__1, bw, &info);
+ chkxer_("SGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sgges_("N", "V", "S", (L_fp)slctes_, &c__1, a, &c__0, b, &c__1, &sdim,
+ r1, r2, r3, q, &c__1, u, &c__1, w, &c__1, bw, &info);
+ chkxer_("SGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sgges_("N", "V", "S", (L_fp)slctes_, &c__1, a, &c__1, b, &c__0, &sdim,
+ r1, r2, r3, q, &c__1, u, &c__1, w, &c__1, bw, &info);
+ chkxer_("SGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ sgges_("N", "V", "S", (L_fp)slctes_, &c__1, a, &c__1, b, &c__1, &sdim,
+ r1, r2, r3, q, &c__0, u, &c__1, w, &c__1, bw, &info);
+ chkxer_("SGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ sgges_("V", "V", "S", (L_fp)slctes_, &c__2, a, &c__2, b, &c__2, &sdim,
+ r1, r2, r3, q, &c__1, u, &c__2, w, &c__1, bw, &info);
+ chkxer_("SGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 17;
+ sgges_("N", "V", "S", (L_fp)slctes_, &c__1, a, &c__1, b, &c__1, &sdim,
+ r1, r2, r3, q, &c__1, u, &c__0, w, &c__1, bw, &info);
+ chkxer_("SGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 17;
+ sgges_("V", "V", "S", (L_fp)slctes_, &c__2, a, &c__2, b, &c__2, &sdim,
+ r1, r2, r3, q, &c__2, u, &c__1, w, &c__1, bw, &info);
+ chkxer_("SGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 19;
+ sgges_("V", "V", "S", (L_fp)slctes_, &c__2, a, &c__2, b, &c__2, &sdim,
+ r1, r2, r3, q, &c__2, u, &c__2, w, &c__1, bw, &info);
+ chkxer_("SGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* SGGESX */
+
+ s_copy(srnamc_1.srnamt, "SGGESX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sggesx_("/", "N", "S", (L_fp)slctsx_, "N", &c__1, a, &c__1, b, &c__1,
+ &sdim, r1, r2, r3, q, &c__1, u, &c__1, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("SGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sggesx_("N", "/", "S", (L_fp)slctsx_, "N", &c__1, a, &c__1, b, &c__1,
+ &sdim, r1, r2, r3, q, &c__1, u, &c__1, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("SGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sggesx_("V", "V", "/", (L_fp)slctsx_, "N", &c__1, a, &c__1, b, &c__1,
+ &sdim, r1, r2, r3, q, &c__1, u, &c__1, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("SGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sggesx_("V", "V", "S", (L_fp)slctsx_, "/", &c__1, a, &c__1, b, &c__1,
+ &sdim, r1, r2, r3, q, &c__1, u, &c__1, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("SGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sggesx_("V", "V", "S", (L_fp)slctsx_, "B", &c_n1, a, &c__1, b, &c__1,
+ &sdim, r1, r2, r3, q, &c__1, u, &c__1, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("SGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sggesx_("V", "V", "S", (L_fp)slctsx_, "B", &c__1, a, &c__0, b, &c__1,
+ &sdim, r1, r2, r3, q, &c__1, u, &c__1, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("SGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sggesx_("V", "V", "S", (L_fp)slctsx_, "B", &c__1, a, &c__1, b, &c__0,
+ &sdim, r1, r2, r3, q, &c__1, u, &c__1, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("SGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ sggesx_("V", "V", "S", (L_fp)slctsx_, "B", &c__1, a, &c__1, b, &c__1,
+ &sdim, r1, r2, r3, q, &c__0, u, &c__1, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("SGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ sggesx_("V", "V", "S", (L_fp)slctsx_, "B", &c__2, a, &c__2, b, &c__2,
+ &sdim, r1, r2, r3, q, &c__1, u, &c__1, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("SGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ sggesx_("V", "V", "S", (L_fp)slctsx_, "B", &c__1, a, &c__1, b, &c__1,
+ &sdim, r1, r2, r3, q, &c__1, u, &c__0, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("SGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ sggesx_("V", "V", "S", (L_fp)slctsx_, "B", &c__2, a, &c__2, b, &c__2,
+ &sdim, r1, r2, r3, q, &c__2, u, &c__1, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("SGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 22;
+ sggesx_("V", "V", "S", (L_fp)slctsx_, "B", &c__2, a, &c__2, b, &c__2,
+ &sdim, r1, r2, r3, q, &c__2, u, &c__2, rce, rcv, w, &c__1, iw,
+ &c__1, bw, &info)
+ ;
+ chkxer_("SGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 24;
+ sggesx_("V", "V", "S", (L_fp)slctsx_, "V", &c__1, a, &c__1, b, &c__1,
+ &sdim, r1, r2, r3, q, &c__1, u, &c__1, rce, rcv, w, &c__32,
+ iw, &c__0, bw, &info);
+ chkxer_("SGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 13;
+
+/* SGGEV */
+
+ s_copy(srnamc_1.srnamt, "SGGEV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sggev_("/", "N", &c__1, a, &c__1, b, &c__1, r1, r2, r3, q, &c__1, u, &
+ c__1, w, &c__1, &info);
+ chkxer_("SGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sggev_("N", "/", &c__1, a, &c__1, b, &c__1, r1, r2, r3, q, &c__1, u, &
+ c__1, w, &c__1, &info);
+ chkxer_("SGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sggev_("V", "V", &c_n1, a, &c__1, b, &c__1, r1, r2, r3, q, &c__1, u, &
+ c__1, w, &c__1, &info);
+ chkxer_("SGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sggev_("V", "V", &c__1, a, &c__0, b, &c__1, r1, r2, r3, q, &c__1, u, &
+ c__1, w, &c__1, &info);
+ chkxer_("SGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sggev_("V", "V", &c__1, a, &c__1, b, &c__0, r1, r2, r3, q, &c__1, u, &
+ c__1, w, &c__1, &info);
+ chkxer_("SGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sggev_("N", "V", &c__1, a, &c__1, b, &c__1, r1, r2, r3, q, &c__0, u, &
+ c__1, w, &c__1, &info);
+ chkxer_("SGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sggev_("V", "V", &c__2, a, &c__2, b, &c__2, r1, r2, r3, q, &c__1, u, &
+ c__2, w, &c__1, &info);
+ chkxer_("SGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ sggev_("V", "N", &c__2, a, &c__2, b, &c__2, r1, r2, r3, q, &c__2, u, &
+ c__0, w, &c__1, &info);
+ chkxer_("SGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ sggev_("V", "V", &c__2, a, &c__2, b, &c__2, r1, r2, r3, q, &c__2, u, &
+ c__1, w, &c__1, &info);
+ chkxer_("SGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ sggev_("V", "V", &c__1, a, &c__1, b, &c__1, r1, r2, r3, q, &c__1, u, &
+ c__1, w, &c__1, &info);
+ chkxer_("SGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* SGGEVX */
+
+ s_copy(srnamc_1.srnamt, "SGGEVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sggevx_("/", "N", "N", "N", &c__1, a, &c__1, b, &c__1, r1, r2, r3, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("SGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sggevx_("N", "/", "N", "N", &c__1, a, &c__1, b, &c__1, r1, r2, r3, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("SGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sggevx_("N", "N", "/", "N", &c__1, a, &c__1, b, &c__1, r1, r2, r3, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("SGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sggevx_("N", "N", "N", "/", &c__1, a, &c__1, b, &c__1, r1, r2, r3, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("SGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sggevx_("N", "N", "N", "N", &c_n1, a, &c__1, b, &c__1, r1, r2, r3, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("SGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sggevx_("N", "N", "N", "N", &c__1, a, &c__0, b, &c__1, r1, r2, r3, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("SGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sggevx_("N", "N", "N", "N", &c__1, a, &c__1, b, &c__0, r1, r2, r3, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("SGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ sggevx_("N", "N", "N", "N", &c__1, a, &c__1, b, &c__1, r1, r2, r3, q,
+ &c__0, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("SGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ sggevx_("N", "V", "N", "N", &c__2, a, &c__2, b, &c__2, r1, r2, r3, q,
+ &c__1, u, &c__2, &c__1, &c__2, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("SGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ sggevx_("N", "N", "N", "N", &c__1, a, &c__1, b, &c__1, r1, r2, r3, q,
+ &c__1, u, &c__0, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("SGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ sggevx_("N", "N", "V", "N", &c__2, a, &c__2, b, &c__2, r1, r2, r3, q,
+ &c__2, u, &c__1, &c__1, &c__2, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("SGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 26;
+ sggevx_("N", "N", "V", "N", &c__2, a, &c__2, b, &c__2, r1, r2, r3, q,
+ &c__2, u, &c__2, &c__1, &c__2, ls, rs, &anrm, &bnrm, rce, rcv,
+ w, &c__1, iw, bw, &info);
+ chkxer_("SGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 12;
+
+/* STGEXC */
+
+ s_copy(srnamc_1.srnamt, "STGEXC", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 3;
+ stgexc_(&c_true, &c_true, &c_n1, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__1, &ifst, &ilst, w, &c__1, &info);
+ chkxer_("STGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ stgexc_(&c_true, &c_true, &c__1, a, &c__0, b, &c__1, q, &c__1, z__, &
+ c__1, &ifst, &ilst, w, &c__1, &info);
+ chkxer_("STGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ stgexc_(&c_true, &c_true, &c__1, a, &c__1, b, &c__0, q, &c__1, z__, &
+ c__1, &ifst, &ilst, w, &c__1, &info);
+ chkxer_("STGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ stgexc_(&c_false, &c_true, &c__1, a, &c__1, b, &c__1, q, &c__0, z__, &
+ c__1, &ifst, &ilst, w, &c__1, &info);
+ chkxer_("STGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ stgexc_(&c_true, &c_true, &c__1, a, &c__1, b, &c__1, q, &c__0, z__, &
+ c__1, &ifst, &ilst, w, &c__1, &info);
+ chkxer_("STGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ stgexc_(&c_true, &c_false, &c__1, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__0, &ifst, &ilst, w, &c__1, &info);
+ chkxer_("STGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ stgexc_(&c_true, &c_true, &c__1, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__0, &ifst, &ilst, w, &c__1, &info);
+ chkxer_("STGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ stgexc_(&c_true, &c_true, &c__1, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__1, &ifst, &ilst, w, &c__0, &info);
+ chkxer_("STGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* STGSEN */
+
+ s_copy(srnamc_1.srnamt, "STGSEN", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ stgsen_(&c_n1, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &c__1,
+ iw, &c__1, &info);
+ chkxer_("STGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ stgsen_(&c__1, &c_true, &c_true, sel, &c_n1, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &c__1,
+ iw, &c__1, &info);
+ chkxer_("STGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ stgsen_(&c__1, &c_true, &c_true, sel, &c__1, a, &c__0, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &c__1,
+ iw, &c__1, &info);
+ chkxer_("STGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ stgsen_(&c__1, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__0, r1,
+ r2, r3, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &c__1,
+ iw, &c__1, &info);
+ chkxer_("STGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ stgsen_(&c__1, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__0, z__, &c__1, &m, &tola, &tolb, rcv, w, &c__1,
+ iw, &c__1, &info);
+ chkxer_("STGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ stgsen_(&c__1, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__0, &m, &tola, &tolb, rcv, w, &c__1,
+ iw, &c__1, &info);
+ chkxer_("STGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 22;
+ stgsen_(&c__0, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &c__1,
+ iw, &c__1, &info);
+ chkxer_("STGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 22;
+ stgsen_(&c__1, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &c__1,
+ iw, &c__1, &info);
+ chkxer_("STGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 22;
+ stgsen_(&c__2, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &c__1,
+ iw, &c__1, &info);
+ chkxer_("STGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 24;
+ stgsen_(&c__0, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c__20, iw, &c__0, &info);
+ chkxer_("STGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 24;
+ stgsen_(&c__1, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c__20, iw, &c__0, &info);
+ chkxer_("STGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 24;
+ stgsen_(&c__2, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1, r1,
+ r2, r3, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c__20, iw, &c__1, &info);
+ chkxer_("STGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 12;
+
+/* STGSNA */
+
+ s_copy(srnamc_1.srnamt, "STGSNA", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ stgsna_("/", "A", sel, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("STGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ stgsna_("B", "/", sel, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("STGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ stgsna_("B", "A", sel, &c_n1, a, &c__1, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("STGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ stgsna_("B", "A", sel, &c__1, a, &c__0, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("STGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ stgsna_("B", "A", sel, &c__1, a, &c__1, b, &c__0, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("STGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ stgsna_("E", "A", sel, &c__1, a, &c__1, b, &c__1, q, &c__0, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("STGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ stgsna_("E", "A", sel, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &c__0,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("STGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ stgsna_("E", "A", sel, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__0, &m, w, &c__1, iw, &info);
+ chkxer_("STGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ stgsna_("E", "A", sel, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__0, iw, &info);
+ chkxer_("STGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* STGSYL */
+
+ s_copy(srnamc_1.srnamt, "STGSYL", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ stgsyl_("/", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("STGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ stgsyl_("N", &c_n1, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("STGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ stgsyl_("N", &c__0, &c__0, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("STGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ stgsyl_("N", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("STGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ stgsyl_("N", &c__0, &c__1, &c__1, a, &c__0, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("STGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ stgsyl_("N", &c__0, &c__1, &c__1, a, &c__1, b, &c__0, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("STGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ stgsyl_("N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__0, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("STGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ stgsyl_("N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__0, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("STGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ stgsyl_("N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__0, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("STGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ stgsyl_("N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__0, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("STGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ stgsyl_("N", &c__1, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("STGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ stgsyl_("N", &c__2, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("STGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 12;
+ }
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___38.ciunit = infoc_1.nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___39.ciunit = infoc_1.nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of SERRGG */
+
+} /* serrgg_ */
diff --git a/TESTING/EIG/serrhs.c b/TESTING/EIG/serrhs.c
new file mode 100644
index 0000000..fbb2884
--- /dev/null
+++ b/TESTING/EIG/serrhs.c
@@ -0,0 +1,524 @@
+/* serrhs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__4 = 4;
+
+/* Subroutine */ int serrhs_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
+ "rror exits\002,\002 (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
+ "ts of the error \002,\002exits ***\002)";
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ real a[9] /* was [3][3] */, c__[9] /* was [3][3] */;
+ integer i__, j, m;
+ real s[3], w[28];
+ char c2[2];
+ real wi[3];
+ integer nt;
+ real vl[9] /* was [3][3] */, vr[9] /* was [3][3] */, wr[3];
+ integer ihi, ilo;
+ logical sel[3];
+ real tau[3];
+ integer info;
+ extern /* Subroutine */ int sgebak_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *), sgebal_(char *, integer *, real *, integer *,
+ integer *, integer *, real *, integer *);
+ integer ifaill[3], ifailr[3];
+ extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), shsein_(char *, char *, char *, logical *,
+ integer *, real *, integer *, real *, real *, real *, integer *,
+ real *, integer *, integer *, integer *, real *, integer *,
+ integer *, integer *), sorghr_(integer *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, integer *), shseqr_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, real *, integer *,
+ real *, integer *, integer *), strevc_(char *,
+ char *, logical *, integer *, real *, integer *, real *, integer *
+, real *, integer *, integer *, integer *, real *, integer *), sormhr_(char *, char *, integer *, integer *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SERRHS tests the error exits for SGEBAK, SGEBAL, SGEHRD, SORGHR, */
+/* SORMHR, SHSEQR, SHSEIN, and STREVC. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 3; ++j) {
+ for (i__ = 1; i__ <= 3; ++i__) {
+ a[i__ + j * 3 - 4] = 1.f / (real) (i__ + j);
+/* L10: */
+ }
+ wi[j - 1] = (real) j;
+ sel[j - 1] = TRUE_;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+ nt = 0;
+
+/* Test error exits of the nonsymmetric eigenvalue routines. */
+
+ if (lsamen_(&c__2, c2, "HS")) {
+
+/* SGEBAL */
+
+ s_copy(srnamc_1.srnamt, "SGEBAL", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgebal_("/", &c__0, a, &c__1, &ilo, &ihi, s, &info);
+ chkxer_("SGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgebal_("N", &c_n1, a, &c__1, &ilo, &ihi, s, &info);
+ chkxer_("SGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgebal_("N", &c__2, a, &c__1, &ilo, &ihi, s, &info);
+ chkxer_("SGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 3;
+
+/* SGEBAK */
+
+ s_copy(srnamc_1.srnamt, "SGEBAK", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgebak_("/", "R", &c__0, &c__1, &c__0, s, &c__0, a, &c__1, &info);
+ chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgebak_("N", "/", &c__0, &c__1, &c__0, s, &c__0, a, &c__1, &info);
+ chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgebak_("N", "R", &c_n1, &c__1, &c__0, s, &c__0, a, &c__1, &info);
+ chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgebak_("N", "R", &c__0, &c__0, &c__0, s, &c__0, a, &c__1, &info);
+ chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgebak_("N", "R", &c__0, &c__2, &c__0, s, &c__0, a, &c__1, &info);
+ chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgebak_("N", "R", &c__2, &c__2, &c__1, s, &c__0, a, &c__2, &info);
+ chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgebak_("N", "R", &c__0, &c__1, &c__1, s, &c__0, a, &c__1, &info);
+ chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sgebak_("N", "R", &c__0, &c__1, &c__0, s, &c_n1, a, &c__1, &info);
+ chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sgebak_("N", "R", &c__2, &c__1, &c__2, s, &c__0, a, &c__1, &info);
+ chkxer_("SGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* SGEHRD */
+
+ s_copy(srnamc_1.srnamt, "SGEHRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgehrd_(&c_n1, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgehrd_(&c__0, &c__0, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgehrd_(&c__0, &c__2, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgehrd_(&c__1, &c__1, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgehrd_(&c__0, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgehrd_(&c__2, &c__1, &c__1, a, &c__1, tau, w, &c__2, &info);
+ chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sgehrd_(&c__2, &c__1, &c__2, a, &c__2, tau, w, &c__1, &info);
+ chkxer_("SGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+
+/* SORGHR */
+
+ s_copy(srnamc_1.srnamt, "SORGHR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sorghr_(&c_n1, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sorghr_(&c__0, &c__0, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sorghr_(&c__0, &c__2, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorghr_(&c__1, &c__1, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorghr_(&c__0, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sorghr_(&c__2, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sorghr_(&c__3, &c__1, &c__3, a, &c__3, tau, w, &c__1, &info);
+ chkxer_("SORGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+
+/* SORMHR */
+
+ s_copy(srnamc_1.srnamt, "SORMHR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sormhr_("/", "N", &c__0, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sormhr_("L", "/", &c__0, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sormhr_("L", "N", &c_n1, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sormhr_("L", "N", &c__0, &c_n1, &c__1, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sormhr_("L", "N", &c__0, &c__0, &c__0, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sormhr_("L", "N", &c__0, &c__0, &c__2, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sormhr_("L", "N", &c__1, &c__2, &c__2, &c__1, a, &c__1, tau, c__, &
+ c__1, w, &c__2, &info);
+ chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sormhr_("R", "N", &c__2, &c__1, &c__2, &c__1, a, &c__1, tau, c__, &
+ c__2, w, &c__2, &info);
+ chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sormhr_("L", "N", &c__1, &c__1, &c__1, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sormhr_("L", "N", &c__0, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sormhr_("R", "N", &c__1, &c__0, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sormhr_("L", "N", &c__2, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__2, w, &c__1, &info);
+ chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sormhr_("R", "N", &c__1, &c__2, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ sormhr_("L", "N", &c__2, &c__1, &c__1, &c__1, a, &c__2, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ sormhr_("L", "N", &c__1, &c__2, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ sormhr_("R", "N", &c__2, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__2, w, &c__1, &info);
+ chkxer_("SORMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 16;
+
+/* SHSEQR */
+
+ s_copy(srnamc_1.srnamt, "SHSEQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ shseqr_("/", "N", &c__0, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1,
+ w, &c__1, &info);
+ chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ shseqr_("E", "/", &c__0, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1,
+ w, &c__1, &info);
+ chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ shseqr_("E", "N", &c_n1, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1,
+ w, &c__1, &info);
+ chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ shseqr_("E", "N", &c__0, &c__0, &c__0, a, &c__1, wr, wi, c__, &c__1,
+ w, &c__1, &info);
+ chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ shseqr_("E", "N", &c__0, &c__2, &c__0, a, &c__1, wr, wi, c__, &c__1,
+ w, &c__1, &info);
+ chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ shseqr_("E", "N", &c__1, &c__1, &c__0, a, &c__1, wr, wi, c__, &c__1,
+ w, &c__1, &info);
+ chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ shseqr_("E", "N", &c__1, &c__1, &c__2, a, &c__1, wr, wi, c__, &c__1,
+ w, &c__1, &info);
+ chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ shseqr_("E", "N", &c__2, &c__1, &c__2, a, &c__1, wr, wi, c__, &c__2,
+ w, &c__1, &info);
+ chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ shseqr_("E", "V", &c__2, &c__1, &c__2, a, &c__2, wr, wi, c__, &c__1,
+ w, &c__1, &info);
+ chkxer_("SHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* SHSEIN */
+
+ s_copy(srnamc_1.srnamt, "SHSEIN", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ shsein_("/", "N", "N", sel, &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &c__0, &m, w, ifaill, ifailr, &info);
+ chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ shsein_("R", "/", "N", sel, &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &c__0, &m, w, ifaill, ifailr, &info);
+ chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ shsein_("R", "N", "/", sel, &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &c__0, &m, w, ifaill, ifailr, &info);
+ chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ shsein_("R", "N", "N", sel, &c_n1, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__1, &c__0, &m, w, ifaill, ifailr, &info);
+ chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ shsein_("R", "N", "N", sel, &c__2, a, &c__1, wr, wi, vl, &c__1, vr, &
+ c__2, &c__4, &m, w, ifaill, ifailr, &info);
+ chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ shsein_("L", "N", "N", sel, &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
+ c__1, &c__4, &m, w, ifaill, ifailr, &info);
+ chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ shsein_("R", "N", "N", sel, &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
+ c__1, &c__4, &m, w, ifaill, ifailr, &info);
+ chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ shsein_("R", "N", "N", sel, &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
+ c__2, &c__1, &m, w, ifaill, ifailr, &info);
+ chkxer_("SHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* STREVC */
+
+ s_copy(srnamc_1.srnamt, "STREVC", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ strevc_("/", "A", sel, &c__0, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
+ m, w, &info);
+ chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ strevc_("L", "/", sel, &c__0, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
+ m, w, &info);
+ chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ strevc_("L", "A", sel, &c_n1, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
+ m, w, &info);
+ chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ strevc_("L", "A", sel, &c__2, a, &c__1, vl, &c__2, vr, &c__1, &c__4, &
+ m, w, &info);
+ chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ strevc_("L", "A", sel, &c__2, a, &c__2, vl, &c__1, vr, &c__1, &c__4, &
+ m, w, &info);
+ chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ strevc_("R", "A", sel, &c__2, a, &c__2, vl, &c__1, vr, &c__1, &c__4, &
+ m, w, &info);
+ chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ strevc_("L", "A", sel, &c__2, a, &c__2, vl, &c__2, vr, &c__1, &c__1, &
+ m, w, &info);
+ chkxer_("STREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+ }
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___22.ciunit = infoc_1.nout;
+ s_wsfe(&io___22);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___23.ciunit = infoc_1.nout;
+ s_wsfe(&io___23);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of SERRHS */
+
+} /* serrhs_ */
diff --git a/TESTING/EIG/serrst.c b/TESTING/EIG/serrst.c
new file mode 100644
index 0000000..f04dcd8
--- /dev/null
+++ b/TESTING/EIG/serrst.c
@@ -0,0 +1,1292 @@
+/* serrst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static real c_b220 = 0.f;
+static real c_b221 = 1.f;
+static integer c__23 = 23;
+static integer c__28 = 28;
+static integer c__12 = 12;
+static integer c__19 = 19;
+static integer c__11 = 11;
+static integer c__4 = 4;
+static integer c__20 = 20;
+static integer c__5 = 5;
+static integer c__27 = 27;
+static integer c__16 = 16;
+static integer c__8 = 8;
+static integer c__25 = 25;
+static integer c__18 = 18;
+
+/* Subroutine */ int serrst_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
+ "rror exits\002,\002 (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
+ "ts of the error \002,\002exits ***\002)";
+
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ real a[9] /* was [3][3] */, c__[9] /* was [3][3] */, d__[3], e[3]
+ ;
+ integer i__, j, m, n;
+ real q[9] /* was [3][3] */, r__[3], w[60], x[3], z__[9] /* was [3][3]
+ */;
+ char c2[2];
+ integer i1[3], i2[3], i3[3], iw[36], nt;
+ real tau[3];
+ integer info;
+ extern /* Subroutine */ int ssbev_(char *, char *, integer *, integer *,
+ real *, integer *, real *, real *, integer *, real *, integer *), sspev_(char *, char *, integer *, real *, real *,
+ real *, integer *, real *, integer *), sstev_(
+ char *, integer *, real *, real *, real *, integer *, real *,
+ integer *), ssyev_(char *, char *, integer *, real *,
+ integer *, real *, real *, integer *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), sstedc_(char *, integer *, real *, real *,
+ real *, integer *, real *, integer *, integer *, integer *,
+ integer *), ssbevd_(char *, char *, integer *, integer *,
+ real *, integer *, real *, real *, integer *, real *, integer *,
+ integer *, integer *, integer *), ssbtrd_(char *,
+ char *, integer *, integer *, real *, integer *, real *, real *,
+ real *, integer *, real *, integer *), sspevd_(
+ char *, char *, integer *, real *, real *, real *, integer *,
+ real *, integer *, integer *, integer *, integer *), sstein_(integer *, real *, real *, integer *, real *,
+ integer *, integer *, real *, integer *, real *, integer *,
+ integer *, integer *), ssterf_(integer *, real *, real *, integer
+ *), sstevd_(char *, integer *, real *, real *, real *, integer *,
+ real *, integer *, integer *, integer *, integer *);
+ integer nsplit;
+ extern /* Subroutine */ int ssbevx_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, real *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, real *, integer *, integer *, integer *)
+ , sstebz_(char *, char *, integer *, real *, real *, integer *,
+ integer *, real *, real *, real *, integer *, integer *, real *,
+ integer *, integer *, real *, integer *, integer *), ssyevd_(char *, char *, integer *, real *, integer *,
+ real *, real *, integer *, integer *, integer *, integer *), sopgtr_(char *, integer *, real *, real *, real *
+, integer *, real *, integer *), spteqr_(char *, integer *
+, real *, real *, real *, integer *, real *, integer *),
+ sorgtr_(char *, integer *, real *, integer *, real *, real *,
+ integer *, integer *), ssptrd_(char *, integer *, real *,
+ real *, real *, real *, integer *), ssteqr_(char *,
+ integer *, real *, real *, real *, integer *, real *, integer *), sopmtr_(char *, char *, char *, integer *, integer *,
+ real *, real *, real *, integer *, real *, integer *), sormtr_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *), sstevr_(char *,
+ char *, integer *, real *, real *, real *, real *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, integer *
+, real *, integer *, integer *, integer *, integer *), sspevx_(char *, char *, char *, integer *, real *, real *
+, real *, integer *, integer *, real *, integer *, real *, real *,
+ integer *, real *, integer *, integer *, integer *), ssytrd_(char *, integer *, real *, integer *,
+ real *, real *, real *, real *, integer *, integer *),
+ ssyevr_(char *, char *, char *, integer *, real *, integer *,
+ real *, real *, integer *, integer *, real *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *,
+ integer *, integer *), sstevx_(char *,
+ char *, integer *, real *, real *, real *, real *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *, integer *), ssyevx_(char *,
+ char *, char *, integer *, real *, integer *, real *, real *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, real *, integer *, integer *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SERRST tests the error exits for SSYTRD, SORGTR, SORMTR, SSPTRD, */
+/* SOPGTR, SOPMTR, SSTEQR, SSTERF, SSTEBZ, SSTEIN, SPTEQR, SSBTRD, */
+/* SSYEV, SSYEVX, SSYEVD, SSBEV, SSBEVX, SSBEVD, */
+/* SSPEV, SSPEVX, SSPEVD, SSTEV, SSTEVX, SSTEVD, and SSTEDC. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* NMAX has to be at least 3 or LIW may be too small */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 3; ++j) {
+ for (i__ = 1; i__ <= 3; ++i__) {
+ a[i__ + j * 3 - 4] = 1.f / (real) (i__ + j);
+/* L10: */
+ }
+/* L20: */
+ }
+ for (j = 1; j <= 3; ++j) {
+ d__[j - 1] = (real) j;
+ e[j - 1] = 0.f;
+ i1[j - 1] = j;
+ i2[j - 1] = j;
+ tau[j - 1] = 1.f;
+/* L30: */
+ }
+ infoc_1.ok = TRUE_;
+ nt = 0;
+
+/* Test error exits for the ST path. */
+
+ if (lsamen_(&c__2, c2, "ST")) {
+
+/* SSYTRD */
+
+ s_copy(srnamc_1.srnamt, "SSYTRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssytrd_("/", &c__0, a, &c__1, d__, e, tau, w, &c__1, &info)
+ ;
+ chkxer_("SSYTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ssytrd_("U", &c_n1, a, &c__1, d__, e, tau, w, &c__1, &info)
+ ;
+ chkxer_("SSYTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ssytrd_("U", &c__2, a, &c__1, d__, e, tau, w, &c__1, &info)
+ ;
+ chkxer_("SSYTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ ssytrd_("U", &c__0, a, &c__1, d__, e, tau, w, &c__0, &info)
+ ;
+ chkxer_("SSYTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 4;
+
+/* SORGTR */
+
+ s_copy(srnamc_1.srnamt, "SORGTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sorgtr_("/", &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("SORGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sorgtr_("U", &c_n1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("SORGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sorgtr_("U", &c__2, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("SORGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sorgtr_("U", &c__3, a, &c__3, tau, w, &c__1, &info);
+ chkxer_("SORGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 4;
+
+/* SORMTR */
+
+ s_copy(srnamc_1.srnamt, "SORMTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sormtr_("/", "U", "N", &c__0, &c__0, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("SORMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sormtr_("L", "/", "N", &c__0, &c__0, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("SORMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sormtr_("L", "U", "/", &c__0, &c__0, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("SORMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sormtr_("L", "U", "N", &c_n1, &c__0, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("SORMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sormtr_("L", "U", "N", &c__0, &c_n1, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("SORMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sormtr_("L", "U", "N", &c__2, &c__0, a, &c__1, tau, c__, &c__2, w, &
+ c__1, &info);
+ chkxer_("SORMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sormtr_("R", "U", "N", &c__0, &c__2, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("SORMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sormtr_("L", "U", "N", &c__2, &c__0, a, &c__2, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("SORMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sormtr_("L", "U", "N", &c__0, &c__2, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("SORMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sormtr_("R", "U", "N", &c__2, &c__0, a, &c__1, tau, c__, &c__2, w, &
+ c__1, &info);
+ chkxer_("SORMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* SSPTRD */
+
+ s_copy(srnamc_1.srnamt, "SSPTRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssptrd_("/", &c__0, a, d__, e, tau, &info);
+ chkxer_("SSPTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ssptrd_("U", &c_n1, a, d__, e, tau, &info);
+ chkxer_("SSPTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 2;
+
+/* SOPGTR */
+
+ s_copy(srnamc_1.srnamt, "SOPGTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sopgtr_("/", &c__0, a, tau, z__, &c__1, w, &info);
+ chkxer_("SOPGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sopgtr_("U", &c_n1, a, tau, z__, &c__1, w, &info);
+ chkxer_("SOPGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sopgtr_("U", &c__2, a, tau, z__, &c__1, w, &info);
+ chkxer_("SOPGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 3;
+
+/* SOPMTR */
+
+ s_copy(srnamc_1.srnamt, "SOPMTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sopmtr_("/", "U", "N", &c__0, &c__0, a, tau, c__, &c__1, w, &info);
+ chkxer_("SOPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sopmtr_("L", "/", "N", &c__0, &c__0, a, tau, c__, &c__1, w, &info);
+ chkxer_("SOPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sopmtr_("L", "U", "/", &c__0, &c__0, a, tau, c__, &c__1, w, &info);
+ chkxer_("SOPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sopmtr_("L", "U", "N", &c_n1, &c__0, a, tau, c__, &c__1, w, &info);
+ chkxer_("SOPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sopmtr_("L", "U", "N", &c__0, &c_n1, a, tau, c__, &c__1, w, &info);
+ chkxer_("SOPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sopmtr_("L", "U", "N", &c__2, &c__0, a, tau, c__, &c__1, w, &info);
+ chkxer_("SOPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+/* SPTEQR */
+
+ s_copy(srnamc_1.srnamt, "SPTEQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spteqr_("/", &c__0, d__, e, z__, &c__1, w, &info);
+ chkxer_("SPTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spteqr_("N", &c_n1, d__, e, z__, &c__1, w, &info);
+ chkxer_("SPTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ spteqr_("V", &c__2, d__, e, z__, &c__1, w, &info);
+ chkxer_("SPTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 3;
+
+/* SSTEBZ */
+
+ s_copy(srnamc_1.srnamt, "SSTEBZ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sstebz_("/", "E", &c__0, &c_b220, &c_b221, &c__1, &c__0, &c_b220, d__,
+ e, &m, &nsplit, x, i1, i2, w, iw, &info);
+ chkxer_("SSTEBZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sstebz_("A", "/", &c__0, &c_b220, &c_b220, &c__0, &c__0, &c_b220, d__,
+ e, &m, &nsplit, x, i1, i2, w, iw, &info);
+ chkxer_("SSTEBZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sstebz_("A", "E", &c_n1, &c_b220, &c_b220, &c__0, &c__0, &c_b220, d__,
+ e, &m, &nsplit, x, i1, i2, w, iw, &info);
+ chkxer_("SSTEBZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sstebz_("V", "E", &c__0, &c_b220, &c_b220, &c__0, &c__0, &c_b220, d__,
+ e, &m, &nsplit, x, i1, i2, w, iw, &info);
+ chkxer_("SSTEBZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sstebz_("I", "E", &c__0, &c_b220, &c_b220, &c__0, &c__0, &c_b220, d__,
+ e, &m, &nsplit, x, i1, i2, w, iw, &info);
+ chkxer_("SSTEBZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sstebz_("I", "E", &c__1, &c_b220, &c_b220, &c__2, &c__1, &c_b220, d__,
+ e, &m, &nsplit, x, i1, i2, w, iw, &info);
+ chkxer_("SSTEBZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sstebz_("I", "E", &c__1, &c_b220, &c_b220, &c__1, &c__0, &c_b220, d__,
+ e, &m, &nsplit, x, i1, i2, w, iw, &info);
+ chkxer_("SSTEBZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sstebz_("I", "E", &c__1, &c_b220, &c_b220, &c__1, &c__2, &c_b220, d__,
+ e, &m, &nsplit, x, i1, i2, w, iw, &info);
+ chkxer_("SSTEBZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* SSTEIN */
+
+ s_copy(srnamc_1.srnamt, "SSTEIN", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sstein_(&c_n1, d__, e, &c__0, x, i1, i2, z__, &c__1, w, iw, i3, &info)
+ ;
+ chkxer_("SSTEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sstein_(&c__0, d__, e, &c_n1, x, i1, i2, z__, &c__1, w, iw, i3, &info)
+ ;
+ chkxer_("SSTEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sstein_(&c__0, d__, e, &c__1, x, i1, i2, z__, &c__1, w, iw, i3, &info)
+ ;
+ chkxer_("SSTEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sstein_(&c__2, d__, e, &c__0, x, i1, i2, z__, &c__1, w, iw, i3, &info)
+ ;
+ chkxer_("SSTEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 4;
+
+/* SSTEQR */
+
+ s_copy(srnamc_1.srnamt, "SSTEQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssteqr_("/", &c__0, d__, e, z__, &c__1, w, &info);
+ chkxer_("SSTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ssteqr_("N", &c_n1, d__, e, z__, &c__1, w, &info);
+ chkxer_("SSTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ssteqr_("V", &c__2, d__, e, z__, &c__1, w, &info);
+ chkxer_("SSTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 3;
+
+/* SSTERF */
+
+ s_copy(srnamc_1.srnamt, "SSTERF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssterf_(&c_n1, d__, e, &info);
+ chkxer_("SSTERF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ ++nt;
+
+/* SSTEDC */
+
+ s_copy(srnamc_1.srnamt, "SSTEDC", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sstedc_("/", &c__0, d__, e, z__, &c__1, w, &c__1, iw, &c__1, &info);
+ chkxer_("SSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sstedc_("N", &c_n1, d__, e, z__, &c__1, w, &c__1, iw, &c__1, &info);
+ chkxer_("SSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sstedc_("V", &c__2, d__, e, z__, &c__1, w, &c__23, iw, &c__28, &info);
+ chkxer_("SSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sstedc_("N", &c__1, d__, e, z__, &c__1, w, &c__0, iw, &c__1, &info);
+ chkxer_("SSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sstedc_("I", &c__2, d__, e, z__, &c__2, w, &c__0, iw, &c__12, &info);
+ chkxer_("SSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sstedc_("V", &c__2, d__, e, z__, &c__2, w, &c__0, iw, &c__28, &info);
+ chkxer_("SSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sstedc_("N", &c__1, d__, e, z__, &c__1, w, &c__1, iw, &c__0, &info);
+ chkxer_("SSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sstedc_("I", &c__2, d__, e, z__, &c__2, w, &c__19, iw, &c__0, &info);
+ chkxer_("SSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sstedc_("V", &c__2, d__, e, z__, &c__2, w, &c__23, iw, &c__0, &info);
+ chkxer_("SSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* SSTEVD */
+
+ s_copy(srnamc_1.srnamt, "SSTEVD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sstevd_("/", &c__0, d__, e, z__, &c__1, w, &c__1, iw, &c__1, &info);
+ chkxer_("SSTEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sstevd_("N", &c_n1, d__, e, z__, &c__1, w, &c__1, iw, &c__1, &info);
+ chkxer_("SSTEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sstevd_("V", &c__2, d__, e, z__, &c__1, w, &c__19, iw, &c__12, &info);
+ chkxer_("SSTEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sstevd_("N", &c__1, d__, e, z__, &c__1, w, &c__0, iw, &c__1, &info);
+ chkxer_("SSTEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sstevd_("V", &c__2, d__, e, z__, &c__2, w, &c__12, iw, &c__12, &info);
+ chkxer_("SSTEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sstevd_("N", &c__0, d__, e, z__, &c__1, w, &c__1, iw, &c__0, &info);
+ chkxer_("SSTEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sstevd_("V", &c__2, d__, e, z__, &c__2, w, &c__19, iw, &c__11, &info);
+ chkxer_("SSTEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+
+/* SSTEV */
+
+ s_copy(srnamc_1.srnamt, "SSTEV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sstev_("/", &c__0, d__, e, z__, &c__1, w, &info);
+ chkxer_("SSTEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sstev_("N", &c_n1, d__, e, z__, &c__1, w, &info);
+ chkxer_("SSTEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sstev_("V", &c__2, d__, e, z__, &c__1, w, &info);
+ chkxer_("SSTEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 3;
+
+/* SSTEVX */
+
+ s_copy(srnamc_1.srnamt, "SSTEVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sstevx_("/", "A", &c__0, d__, e, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("SSTEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sstevx_("N", "/", &c__0, d__, e, &c_b220, &c_b221, &c__1, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("SSTEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sstevx_("N", "A", &c_n1, d__, e, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("SSTEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sstevx_("N", "V", &c__1, d__, e, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("SSTEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sstevx_("N", "I", &c__1, d__, e, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("SSTEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sstevx_("N", "I", &c__1, d__, e, &c_b220, &c_b220, &c__2, &c__1, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("SSTEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sstevx_("N", "I", &c__2, d__, e, &c_b220, &c_b220, &c__2, &c__1, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("SSTEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sstevx_("N", "I", &c__1, d__, e, &c_b220, &c_b220, &c__1, &c__2, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("SSTEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ sstevx_("V", "A", &c__2, d__, e, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("SSTEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* SSTEVR */
+
+ n = 1;
+ s_copy(srnamc_1.srnamt, "SSTEVR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ i__1 = n * 20;
+ i__2 = n * 10;
+ sstevr_("/", "A", &c__0, d__, e, &c_b220, &c_b220, &c__1, &c__1, &
+ c_b220, &m, r__, z__, &c__1, iw, x, &i__1, &iw[n * 2], &i__2,
+ &info);
+ chkxer_("SSTEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ i__1 = n * 20;
+ i__2 = n * 10;
+ sstevr_("V", "/", &c__0, d__, e, &c_b220, &c_b220, &c__1, &c__1, &
+ c_b220, &m, r__, z__, &c__1, iw, x, &i__1, &iw[n * 2], &i__2,
+ &info);
+ chkxer_("SSTEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ i__1 = n * 20;
+ i__2 = n * 10;
+ sstevr_("V", "A", &c_n1, d__, e, &c_b220, &c_b220, &c__1, &c__1, &
+ c_b220, &m, r__, z__, &c__1, iw, x, &i__1, &iw[n * 2], &i__2,
+ &info);
+ chkxer_("SSTEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ i__1 = n * 20;
+ i__2 = n * 10;
+ sstevr_("V", "V", &c__1, d__, e, &c_b220, &c_b220, &c__1, &c__1, &
+ c_b220, &m, r__, z__, &c__1, iw, x, &i__1, &iw[n * 2], &i__2,
+ &info);
+ chkxer_("SSTEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ i__1 = n * 20;
+ i__2 = n * 10;
+ sstevr_("V", "I", &c__1, d__, e, &c_b220, &c_b220, &c__0, &c__1, &
+ c_b220, &m, w, z__, &c__1, iw, x, &i__1, &iw[n * 2], &i__2, &
+ info);
+ chkxer_("SSTEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ n = 2;
+ i__1 = n * 20;
+ i__2 = n * 10;
+ sstevr_("V", "I", &c__2, d__, e, &c_b220, &c_b220, &c__2, &c__1, &
+ c_b220, &m, w, z__, &c__1, iw, x, &i__1, &iw[n * 2], &i__2, &
+ info);
+ chkxer_("SSTEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ n = 1;
+ i__1 = n * 20;
+ i__2 = n * 10;
+ sstevr_("V", "I", &c__1, d__, e, &c_b220, &c_b220, &c__1, &c__1, &
+ c_b220, &m, w, z__, &c__0, iw, x, &i__1, &iw[n * 2], &i__2, &
+ info);
+ chkxer_("SSTEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 17;
+ i__1 = n * 20 - 1;
+ i__2 = n * 10;
+ sstevr_("V", "I", &c__1, d__, e, &c_b220, &c_b220, &c__1, &c__1, &
+ c_b220, &m, w, z__, &c__1, iw, x, &i__1, &iw[n * 2], &i__2, &
+ info);
+ chkxer_("SSTEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 19;
+ i__1 = n * 20;
+ i__2 = n * 10 - 1;
+ sstevr_("V", "I", &c__1, d__, e, &c_b220, &c_b220, &c__1, &c__1, &
+ c_b220, &m, w, z__, &c__1, iw, x, &i__1, &iw[n * 2], &i__2, &
+ info);
+ chkxer_("SSTEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* SSYEVD */
+
+ s_copy(srnamc_1.srnamt, "SSYEVD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssyevd_("/", "U", &c__0, a, &c__1, x, w, &c__1, iw, &c__1, &info);
+ chkxer_("SSYEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ssyevd_("N", "/", &c__0, a, &c__1, x, w, &c__1, iw, &c__1, &info);
+ chkxer_("SSYEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ssyevd_("N", "U", &c_n1, a, &c__1, x, w, &c__1, iw, &c__1, &info);
+ chkxer_("SSYEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ssyevd_("N", "U", &c__2, a, &c__1, x, w, &c__3, iw, &c__1, &info);
+ chkxer_("SSYEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ssyevd_("N", "U", &c__1, a, &c__1, x, w, &c__0, iw, &c__1, &info);
+ chkxer_("SSYEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ssyevd_("N", "U", &c__2, a, &c__2, x, w, &c__4, iw, &c__1, &info);
+ chkxer_("SSYEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ssyevd_("V", "U", &c__2, a, &c__2, x, w, &c__20, iw, &c__12, &info);
+ chkxer_("SSYEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ssyevd_("N", "U", &c__1, a, &c__1, x, w, &c__1, iw, &c__0, &info);
+ chkxer_("SSYEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ssyevd_("N", "U", &c__2, a, &c__2, x, w, &c__5, iw, &c__0, &info);
+ chkxer_("SSYEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ssyevd_("V", "U", &c__2, a, &c__2, x, w, &c__27, iw, &c__11, &info);
+ chkxer_("SSYEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* SSYEVR */
+
+ s_copy(srnamc_1.srnamt, "SSYEVR", (ftnlen)32, (ftnlen)6);
+ n = 1;
+ infoc_1.infot = 1;
+ i__1 = n * 26;
+ i__2 = n * 10;
+ ssyevr_("/", "A", "U", &c__0, a, &c__1, &c_b220, &c_b220, &c__1, &
+ c__1, &c_b220, &m, r__, z__, &c__1, iw, q, &i__1, &iw[n * 2],
+ &i__2, &info);
+ chkxer_("SSYEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ i__1 = n * 26;
+ i__2 = n * 10;
+ ssyevr_("V", "/", "U", &c__0, a, &c__1, &c_b220, &c_b220, &c__1, &
+ c__1, &c_b220, &m, r__, z__, &c__1, iw, q, &i__1, &iw[n * 2],
+ &i__2, &info);
+ chkxer_("SSYEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ i__1 = n * 26;
+ i__2 = n * 10;
+ ssyevr_("V", "A", "/", &c_n1, a, &c__1, &c_b220, &c_b220, &c__1, &
+ c__1, &c_b220, &m, r__, z__, &c__1, iw, q, &i__1, &iw[n * 2],
+ &i__2, &info);
+ chkxer_("SSYEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ i__1 = n * 26;
+ i__2 = n * 10;
+ ssyevr_("V", "A", "U", &c_n1, a, &c__1, &c_b220, &c_b220, &c__1, &
+ c__1, &c_b220, &m, r__, z__, &c__1, iw, q, &i__1, &iw[n * 2],
+ &i__2, &info);
+ chkxer_("SSYEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ i__1 = n * 26;
+ i__2 = n * 10;
+ ssyevr_("V", "A", "U", &c__2, a, &c__1, &c_b220, &c_b220, &c__1, &
+ c__1, &c_b220, &m, r__, z__, &c__1, iw, q, &i__1, &iw[n * 2],
+ &i__2, &info);
+ chkxer_("SSYEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ i__1 = n * 26;
+ i__2 = n * 10;
+ ssyevr_("V", "V", "U", &c__1, a, &c__1, &c_b220, &c_b220, &c__1, &
+ c__1, &c_b220, &m, r__, z__, &c__1, iw, q, &i__1, &iw[n * 2],
+ &i__2, &info);
+ chkxer_("SSYEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ i__1 = n * 26;
+ i__2 = n * 10;
+ ssyevr_("V", "I", "U", &c__1, a, &c__1, &c_b220, &c_b220, &c__0, &
+ c__1, &c_b220, &m, r__, z__, &c__1, iw, q, &i__1, &iw[n * 2],
+ &i__2, &info);
+ chkxer_("SSYEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+
+ i__1 = n * 26;
+ i__2 = n * 10;
+ ssyevr_("V", "I", "U", &c__2, a, &c__2, &c_b220, &c_b220, &c__2, &
+ c__1, &c_b220, &m, r__, z__, &c__1, iw, q, &i__1, &iw[n * 2],
+ &i__2, &info);
+ chkxer_("SSYEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ i__1 = n * 26;
+ i__2 = n * 10;
+ ssyevr_("V", "I", "U", &c__1, a, &c__1, &c_b220, &c_b220, &c__1, &
+ c__1, &c_b220, &m, r__, z__, &c__0, iw, q, &i__1, &iw[n * 2],
+ &i__2, &info);
+ chkxer_("SSYEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ i__1 = n * 26 - 1;
+ i__2 = n * 10;
+ ssyevr_("V", "I", "U", &c__1, a, &c__1, &c_b220, &c_b220, &c__1, &
+ c__1, &c_b220, &m, r__, z__, &c__1, iw, q, &i__1, &iw[n * 2],
+ &i__2, &info);
+ chkxer_("SSYEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ i__1 = n * 26;
+ i__2 = n * 10 - 1;
+ ssyevr_("V", "I", "U", &c__1, a, &c__1, &c_b220, &c_b220, &c__1, &
+ c__1, &c_b220, &m, r__, z__, &c__1, iw, q, &i__1, &iw[n * 2],
+ &i__2, &info);
+ chkxer_("SSYEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* SSYEV */
+
+ s_copy(srnamc_1.srnamt, "SSYEV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssyev_("/", "U", &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("SSYEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ssyev_("N", "/", &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("SSYEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ssyev_("N", "U", &c_n1, a, &c__1, x, w, &c__1, &info);
+ chkxer_("SSYEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ssyev_("N", "U", &c__2, a, &c__1, x, w, &c__3, &info);
+ chkxer_("SSYEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ssyev_("N", "U", &c__1, a, &c__1, x, w, &c__1, &info);
+ chkxer_("SSYEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 5;
+
+/* SSYEVX */
+
+ s_copy(srnamc_1.srnamt, "SSYEVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssyevx_("/", "A", "U", &c__0, a, &c__1, &c_b220, &c_b220, &c__0, &
+ c__0, &c_b220, &m, x, z__, &c__1, w, &c__1, iw, i3, &info);
+ chkxer_("SSYEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ssyevx_("N", "/", "U", &c__0, a, &c__1, &c_b220, &c_b221, &c__1, &
+ c__0, &c_b220, &m, x, z__, &c__1, w, &c__1, iw, i3, &info);
+ chkxer_("SSYEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ssyevx_("N", "A", "/", &c__0, a, &c__1, &c_b220, &c_b220, &c__0, &
+ c__0, &c_b220, &m, x, z__, &c__1, w, &c__1, iw, i3, &info);
+ infoc_1.infot = 4;
+ ssyevx_("N", "A", "U", &c_n1, a, &c__1, &c_b220, &c_b220, &c__0, &
+ c__0, &c_b220, &m, x, z__, &c__1, w, &c__1, iw, i3, &info);
+ chkxer_("SSYEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ssyevx_("N", "A", "U", &c__2, a, &c__1, &c_b220, &c_b220, &c__0, &
+ c__0, &c_b220, &m, x, z__, &c__1, w, &c__16, iw, i3, &info);
+ chkxer_("SSYEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ssyevx_("N", "V", "U", &c__1, a, &c__1, &c_b220, &c_b220, &c__0, &
+ c__0, &c_b220, &m, x, z__, &c__1, w, &c__8, iw, i3, &info);
+ chkxer_("SSYEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ ssyevx_("N", "I", "U", &c__1, a, &c__1, &c_b220, &c_b220, &c__0, &
+ c__0, &c_b220, &m, x, z__, &c__1, w, &c__8, iw, i3, &info);
+ chkxer_("SSYEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ ssyevx_("N", "I", "U", &c__1, a, &c__1, &c_b220, &c_b220, &c__2, &
+ c__1, &c_b220, &m, x, z__, &c__1, w, &c__8, iw, i3, &info);
+ chkxer_("SSYEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ssyevx_("N", "I", "U", &c__2, a, &c__2, &c_b220, &c_b220, &c__2, &
+ c__1, &c_b220, &m, x, z__, &c__1, w, &c__16, iw, i3, &info);
+ chkxer_("SSYEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ssyevx_("N", "I", "U", &c__1, a, &c__1, &c_b220, &c_b220, &c__1, &
+ c__2, &c_b220, &m, x, z__, &c__1, w, &c__8, iw, i3, &info);
+ chkxer_("SSYEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ ssyevx_("V", "A", "U", &c__2, a, &c__2, &c_b220, &c_b220, &c__0, &
+ c__0, &c_b220, &m, x, z__, &c__1, w, &c__16, iw, i3, &info);
+ chkxer_("SSYEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 17;
+ ssyevx_("V", "A", "U", &c__1, a, &c__1, &c_b220, &c_b220, &c__0, &
+ c__0, &c_b220, &m, x, z__, &c__1, w, &c__0, iw, i3, &info);
+ chkxer_("SSYEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 12;
+
+/* SSPEVD */
+
+ s_copy(srnamc_1.srnamt, "SSPEVD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sspevd_("/", "U", &c__0, a, x, z__, &c__1, w, &c__1, iw, &c__1, &info);
+ chkxer_("SSPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sspevd_("N", "/", &c__0, a, x, z__, &c__1, w, &c__1, iw, &c__1, &info);
+ chkxer_("SSPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sspevd_("N", "U", &c_n1, a, x, z__, &c__1, w, &c__1, iw, &c__1, &info);
+ chkxer_("SSPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sspevd_("V", "U", &c__2, a, x, z__, &c__1, w, &c__23, iw, &c__12, &
+ info);
+ chkxer_("SSPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sspevd_("N", "U", &c__1, a, x, z__, &c__1, w, &c__0, iw, &c__1, &info);
+ chkxer_("SSPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sspevd_("N", "U", &c__2, a, x, z__, &c__1, w, &c__3, iw, &c__1, &info);
+ chkxer_("SSPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sspevd_("V", "U", &c__2, a, x, z__, &c__2, w, &c__16, iw, &c__12, &
+ info);
+ chkxer_("SSPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ sspevd_("N", "U", &c__1, a, x, z__, &c__1, w, &c__1, iw, &c__0, &info);
+ chkxer_("SSPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ sspevd_("N", "U", &c__2, a, x, z__, &c__1, w, &c__4, iw, &c__0, &info);
+ chkxer_("SSPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ sspevd_("V", "U", &c__2, a, x, z__, &c__2, w, &c__23, iw, &c__11, &
+ info);
+ chkxer_("SSPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* SSPEV */
+
+ s_copy(srnamc_1.srnamt, "SSPEV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sspev_("/", "U", &c__0, a, w, z__, &c__1, x, &info);
+ chkxer_("SSPEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sspev_("N", "/", &c__0, a, w, z__, &c__1, x, &info);
+ chkxer_("SSPEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sspev_("N", "U", &c_n1, a, w, z__, &c__1, x, &info);
+ chkxer_("SSPEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sspev_("V", "U", &c__2, a, w, z__, &c__1, x, &info);
+ chkxer_("SSPEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 4;
+
+/* SSPEVX */
+
+ s_copy(srnamc_1.srnamt, "SSPEVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sspevx_("/", "A", "U", &c__0, a, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("SSPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sspevx_("N", "/", "U", &c__0, a, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("SSPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sspevx_("N", "A", "/", &c__0, a, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ infoc_1.infot = 4;
+ sspevx_("N", "A", "U", &c_n1, a, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("SSPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sspevx_("N", "V", "U", &c__1, a, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("SSPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sspevx_("N", "I", "U", &c__1, a, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("SSPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sspevx_("N", "I", "U", &c__1, a, &c_b220, &c_b220, &c__2, &c__1, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("SSPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sspevx_("N", "I", "U", &c__2, a, &c_b220, &c_b220, &c__2, &c__1, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("SSPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sspevx_("N", "I", "U", &c__1, a, &c_b220, &c_b220, &c__1, &c__2, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("SSPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ sspevx_("V", "A", "U", &c__2, a, &c_b220, &c_b220, &c__0, &c__0, &
+ c_b220, &m, x, z__, &c__1, w, iw, i3, &info);
+ chkxer_("SSPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* Test error exits for the SB path. */
+
+ } else if (lsamen_(&c__2, c2, "SB")) {
+
+/* SSBTRD */
+
+ s_copy(srnamc_1.srnamt, "SSBTRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssbtrd_("/", "U", &c__0, &c__0, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("SSBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ssbtrd_("N", "/", &c__0, &c__0, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("SSBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ssbtrd_("N", "U", &c_n1, &c__0, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("SSBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ssbtrd_("N", "U", &c__0, &c_n1, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("SSBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ssbtrd_("N", "U", &c__1, &c__1, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("SSBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ssbtrd_("V", "U", &c__2, &c__0, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("SSBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+/* SSBEVD */
+
+ s_copy(srnamc_1.srnamt, "SSBEVD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssbevd_("/", "U", &c__0, &c__0, a, &c__1, x, z__, &c__1, w, &c__1, iw,
+ &c__1, &info);
+ chkxer_("SSBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ssbevd_("N", "/", &c__0, &c__0, a, &c__1, x, z__, &c__1, w, &c__1, iw,
+ &c__1, &info);
+ chkxer_("SSBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ssbevd_("N", "U", &c_n1, &c__0, a, &c__1, x, z__, &c__1, w, &c__1, iw,
+ &c__1, &info);
+ chkxer_("SSBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ssbevd_("N", "U", &c__0, &c_n1, a, &c__1, x, z__, &c__1, w, &c__1, iw,
+ &c__1, &info);
+ chkxer_("SSBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ssbevd_("N", "U", &c__2, &c__1, a, &c__1, x, z__, &c__1, w, &c__4, iw,
+ &c__1, &info);
+ chkxer_("SSBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ ssbevd_("V", "U", &c__2, &c__1, a, &c__2, x, z__, &c__1, w, &c__25,
+ iw, &c__12, &info);
+ chkxer_("SSBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ ssbevd_("N", "U", &c__1, &c__0, a, &c__1, x, z__, &c__1, w, &c__0, iw,
+ &c__1, &info);
+ chkxer_("SSBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ ssbevd_("N", "U", &c__2, &c__0, a, &c__1, x, z__, &c__1, w, &c__3, iw,
+ &c__1, &info);
+ chkxer_("SSBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ ssbevd_("V", "U", &c__2, &c__0, a, &c__1, x, z__, &c__2, w, &c__18,
+ iw, &c__12, &info);
+ chkxer_("SSBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ ssbevd_("N", "U", &c__1, &c__0, a, &c__1, x, z__, &c__1, w, &c__1, iw,
+ &c__0, &info);
+ chkxer_("SSBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ ssbevd_("V", "U", &c__2, &c__0, a, &c__1, x, z__, &c__2, w, &c__25,
+ iw, &c__11, &info);
+ chkxer_("SSBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* SSBEV */
+
+ s_copy(srnamc_1.srnamt, "SSBEV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssbev_("/", "U", &c__0, &c__0, a, &c__1, x, z__, &c__1, w, &info);
+ chkxer_("SSBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ssbev_("N", "/", &c__0, &c__0, a, &c__1, x, z__, &c__1, w, &info);
+ chkxer_("SSBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ssbev_("N", "U", &c_n1, &c__0, a, &c__1, x, z__, &c__1, w, &info);
+ chkxer_("SSBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ssbev_("N", "U", &c__0, &c_n1, a, &c__1, x, z__, &c__1, w, &info);
+ chkxer_("SSBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ssbev_("N", "U", &c__2, &c__1, a, &c__1, x, z__, &c__1, w, &info);
+ chkxer_("SSBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ ssbev_("V", "U", &c__2, &c__0, a, &c__1, x, z__, &c__1, w, &info);
+ chkxer_("SSBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+/* SSBEVX */
+
+ s_copy(srnamc_1.srnamt, "SSBEVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssbevx_("/", "A", "U", &c__0, &c__0, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__0, &c__0, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ chkxer_("SSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ssbevx_("N", "/", "U", &c__0, &c__0, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__0, &c__0, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ chkxer_("SSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ssbevx_("N", "A", "/", &c__0, &c__0, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__0, &c__0, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ infoc_1.infot = 4;
+ ssbevx_("N", "A", "U", &c_n1, &c__0, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__0, &c__0, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ chkxer_("SSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ssbevx_("N", "A", "U", &c__0, &c_n1, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__0, &c__0, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ chkxer_("SSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ssbevx_("N", "A", "U", &c__2, &c__1, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__0, &c__0, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ chkxer_("SSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ ssbevx_("V", "A", "U", &c__2, &c__0, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__0, &c__0, &c_b220, &m, x, z__, &c__2, w, iw, i3, &
+ info);
+ chkxer_("SSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ ssbevx_("N", "V", "U", &c__1, &c__0, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__0, &c__0, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ chkxer_("SSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ ssbevx_("N", "I", "U", &c__1, &c__0, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__0, &c__0, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ chkxer_("SSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ ssbevx_("N", "I", "U", &c__1, &c__0, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__2, &c__1, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ chkxer_("SSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ ssbevx_("N", "I", "U", &c__2, &c__0, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__2, &c__1, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ chkxer_("SSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ ssbevx_("N", "I", "U", &c__1, &c__0, a, &c__1, q, &c__1, &c_b220, &
+ c_b220, &c__1, &c__2, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ chkxer_("SSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ ssbevx_("V", "A", "U", &c__2, &c__0, a, &c__1, q, &c__2, &c_b220, &
+ c_b220, &c__0, &c__0, &c_b220, &m, x, z__, &c__1, w, iw, i3, &
+ info);
+ chkxer_("SSBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 13;
+ }
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___24.ciunit = infoc_1.nout;
+ s_wsfe(&io___24);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___25.ciunit = infoc_1.nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of SERRST */
+
+} /* serrst_ */
diff --git a/TESTING/EIG/sget02.c b/TESTING/EIG/sget02.c
new file mode 100644
index 0000000..50c99e8
--- /dev/null
+++ b/TESTING/EIG/sget02.c
@@ -0,0 +1,188 @@
+/* sget02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b7 = -1.f;
+static real c_b8 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int sget02_(char *trans, integer *m, integer *n, integer *
+ nrhs, real *a, integer *lda, real *x, integer *ldx, real *b, integer *
+ ldb, real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j, n1, n2;
+ real eps;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm, bnorm;
+ extern doublereal sasum_(integer *, real *, integer *);
+ real xnorm;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET02 computes the residual for a solution of a system of linear */
+/* equations A*x = b or A'*x = b: */
+/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A *x = b */
+/* = 'T': A'*x = b, where A' is the transpose of A */
+/* = 'C': A'*x = b, where A' is the transpose of A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The original M x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M). */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. IF TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if M = 0 or N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0 || *nrhs == 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+ if (lsame_(trans, "T") || lsame_(trans, "C")) {
+ n1 = *n;
+ n2 = *m;
+ } else {
+ n1 = *m;
+ n2 = *n;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = slange_("1", &n1, &n2, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute B - A*X (or B - A'*X ) and store in B. */
+
+ sgemm_(trans, "No transpose", &n1, nrhs, &n2, &c_b7, &a[a_offset], lda, &
+ x[x_offset], ldx, &c_b8, &b[b_offset], ldb)
+ ;
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = sasum_(&n1, &b[j * b_dim1 + 1], &c__1);
+ xnorm = sasum_(&n2, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of SGET02 */
+
+} /* sget02_ */
diff --git a/TESTING/EIG/sget10.c b/TESTING/EIG/sget10.c
new file mode 100644
index 0000000..2d87733
--- /dev/null
+++ b/TESTING/EIG/sget10.c
@@ -0,0 +1,149 @@
+/* sget10.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b7 = -1.f;
+
+/* Subroutine */ int sget10_(integer *m, integer *n, real *a, integer *lda,
+ real *b, integer *ldb, real *work, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j;
+ real eps, unfl, anorm;
+ extern doublereal sasum_(integer *, real *, integer *);
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ real wnorm;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET10 compares two matrices A and B and computes the ratio */
+/* RESULT = norm( A - B ) / ( norm(A) * M * EPS ) */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices A and B. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input) REAL array, dimension (LDB,N) */
+/* The m by n matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M). */
+
+/* WORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL */
+/* RESULT = norm( A - B ) / ( norm(A) * M * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ *result = 0.f;
+ return 0;
+ }
+
+ unfl = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+
+ wnorm = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ saxpy_(m, &c_b7, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+/* Computing MAX */
+ r__1 = wnorm, r__2 = sasum_(n, &work[1], &c__1);
+ wnorm = dmax(r__1,r__2);
+/* L10: */
+ }
+
+/* Computing MAX */
+ r__1 = slange_("1", m, n, &a[a_offset], lda, &work[1]);
+ anorm = dmax(r__1,unfl);
+
+ if (anorm > wnorm) {
+ *result = wnorm / anorm / (*m * eps);
+ } else {
+ if (anorm < 1.f) {
+/* Computing MIN */
+ r__1 = wnorm, r__2 = *m * anorm;
+ *result = dmin(r__1,r__2) / anorm / (*m * eps);
+ } else {
+/* Computing MIN */
+ r__1 = wnorm / anorm, r__2 = (real) (*m);
+ *result = dmin(r__1,r__2) / (*m * eps);
+ }
+ }
+
+ return 0;
+
+/* End of SGET10 */
+
+} /* sget10_ */
diff --git a/TESTING/EIG/sget22.c b/TESTING/EIG/sget22.c
new file mode 100644
index 0000000..485582a
--- /dev/null
+++ b/TESTING/EIG/sget22.c
@@ -0,0 +1,401 @@
+/* sget22.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b20 = 0.f;
+static integer c__2 = 2;
+static real c_b25 = 1.f;
+static integer c__1 = 1;
+static real c_b30 = -1.f;
+
+/* Subroutine */ int sget22_(char *transa, char *transe, char *transw,
+ integer *n, real *a, integer *lda, real *e, integer *lde, real *wr,
+ real *wi, real *work, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, e_dim1, e_offset, i__1, i__2;
+ real r__1, r__2, r__3, r__4;
+
+ /* Local variables */
+ integer j;
+ real ulp;
+ integer ince, jcol, jvec;
+ real unfl, wmat[4] /* was [2][2] */, temp1;
+ integer iecol;
+ extern logical lsame_(char *, char *);
+ integer ipair;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ char norma[1];
+ real anorm;
+ char norme[1];
+ real enorm;
+ integer ierow;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ real enrmin, enrmax;
+ extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *);
+ integer itrnse;
+ real errnrm;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET22 does an eigenvector check. */
+
+/* The basic test is: */
+
+/* RESULT(1) = | A E - E W | / ( |A| |E| ulp ) */
+
+/* using the 1-norm. It also tests the normalization of E: */
+
+/* RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp ) */
+/* j */
+
+/* where E(j) is the j-th eigenvector, and m-norm is the max-norm of a */
+/* vector. If an eigenvector is complex, as determined from WI(j) */
+/* nonzero, then the max-norm of the vector ( er + i*ei ) is the maximum */
+/* of */
+/* |er(1)| + |ei(1)|, ... , |er(n)| + |ei(n)| */
+
+/* W is a block diagonal matrix, with a 1 by 1 block for each real */
+/* eigenvalue and a 2 by 2 block for each complex conjugate pair. */
+/* If eigenvalues j and j+1 are a complex conjugate pair, so that */
+/* WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the 2 by 2 */
+/* block corresponding to the pair will be: */
+
+/* ( wr wi ) */
+/* ( -wi wr ) */
+
+/* Such a block multiplying an n by 2 matrix ( ur ui ) on the right */
+/* will be the same as multiplying ur + i*ui by wr + i*wi. */
+
+/* To handle various schemes for storage of left eigenvectors, there are */
+/* options to use A-transpose instead of A, E-transpose instead of E, */
+/* and/or W-transpose instead of W. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANSA (input) CHARACTER*1 */
+/* Specifies whether or not A is transposed. */
+/* = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose (= Transpose) */
+
+/* TRANSE (input) CHARACTER*1 */
+/* Specifies whether or not E is transposed. */
+/* = 'N': No transpose, eigenvectors are in columns of E */
+/* = 'T': Transpose, eigenvectors are in rows of E */
+/* = 'C': Conjugate transpose (= Transpose) */
+
+/* TRANSW (input) CHARACTER*1 */
+/* Specifies whether or not W is transposed. */
+/* = 'N': No transpose */
+/* = 'T': Transpose, use -WI(j) instead of WI(j) */
+/* = 'C': Conjugate transpose, use -WI(j) instead of WI(j) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The matrix whose eigenvectors are in E. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* E (input) REAL array, dimension (LDE,N) */
+/* The matrix of eigenvectors. If TRANSE = 'N', the eigenvectors */
+/* are stored in the columns of E, if TRANSE = 'T' or 'C', the */
+/* eigenvectors are stored in the rows of E. */
+
+/* LDE (input) INTEGER */
+/* The leading dimension of the array E. LDE >= max(1,N). */
+
+/* WR (input) REAL array, dimension (N) */
+/* WI (input) REAL array, dimension (N) */
+/* The real and imaginary parts of the eigenvalues of A. */
+/* Purely real eigenvalues are indicated by WI(j) = 0. */
+/* Complex conjugate pairs are indicated by WR(j)=WR(j+1) and */
+/* WI(j) = - WI(j+1) non-zero; the real part is assumed to be */
+/* stored in the j-th row/column and the imaginary part in */
+/* the (j+1)-th row/column. */
+
+/* WORK (workspace) REAL array, dimension (N*(N+1)) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* RESULT(1) = | A E - E W | / ( |A| |E| ulp ) */
+/* RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize RESULT (in case N=0) */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ e_dim1 = *lde;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ --wr;
+ --wi;
+ --work;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.f;
+ result[2] = 0.f;
+ if (*n <= 0) {
+ return 0;
+ }
+
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Precision");
+
+ itrnse = 0;
+ ince = 1;
+ *(unsigned char *)norma = 'O';
+ *(unsigned char *)norme = 'O';
+
+ if (lsame_(transa, "T") || lsame_(transa, "C")) {
+ *(unsigned char *)norma = 'I';
+ }
+ if (lsame_(transe, "T") || lsame_(transe, "C")) {
+ *(unsigned char *)norme = 'I';
+ itrnse = 1;
+ ince = *lde;
+ }
+
+/* Check normalization of E */
+
+ enrmin = 1.f / ulp;
+ enrmax = 0.f;
+ if (itrnse == 0) {
+
+/* Eigenvectors are column vectors. */
+
+ ipair = 0;
+ i__1 = *n;
+ for (jvec = 1; jvec <= i__1; ++jvec) {
+ temp1 = 0.f;
+ if (ipair == 0 && jvec < *n && wi[jvec] != 0.f) {
+ ipair = 1;
+ }
+ if (ipair == 1) {
+
+/* Complex eigenvector */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = e[j + jvec * e_dim1], dabs(
+ r__1)) + (r__2 = e[j + (jvec + 1) * e_dim1], dabs(
+ r__2));
+ temp1 = dmax(r__3,r__4);
+/* L10: */
+ }
+ enrmin = dmin(enrmin,temp1);
+ enrmax = dmax(enrmax,temp1);
+ ipair = 2;
+ } else if (ipair == 2) {
+ ipair = 0;
+ } else {
+
+/* Real eigenvector */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ r__2 = temp1, r__3 = (r__1 = e[j + jvec * e_dim1], dabs(
+ r__1));
+ temp1 = dmax(r__2,r__3);
+/* L20: */
+ }
+ enrmin = dmin(enrmin,temp1);
+ enrmax = dmax(enrmax,temp1);
+ ipair = 0;
+ }
+/* L30: */
+ }
+
+ } else {
+
+/* Eigenvectors are row vectors. */
+
+ i__1 = *n;
+ for (jvec = 1; jvec <= i__1; ++jvec) {
+ work[jvec] = 0.f;
+/* L40: */
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ipair = 0;
+ i__2 = *n;
+ for (jvec = 1; jvec <= i__2; ++jvec) {
+ if (ipair == 0 && jvec < *n && wi[jvec] != 0.f) {
+ ipair = 1;
+ }
+ if (ipair == 1) {
+/* Computing MAX */
+ r__3 = work[jvec], r__4 = (r__1 = e[j + jvec * e_dim1],
+ dabs(r__1)) + (r__2 = e[j + (jvec + 1) * e_dim1],
+ dabs(r__2));
+ work[jvec] = dmax(r__3,r__4);
+ work[jvec + 1] = work[jvec];
+ } else if (ipair == 2) {
+ ipair = 0;
+ } else {
+/* Computing MAX */
+ r__2 = work[jvec], r__3 = (r__1 = e[j + jvec * e_dim1],
+ dabs(r__1));
+ work[jvec] = dmax(r__2,r__3);
+ ipair = 0;
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+
+ i__1 = *n;
+ for (jvec = 1; jvec <= i__1; ++jvec) {
+/* Computing MIN */
+ r__1 = enrmin, r__2 = work[jvec];
+ enrmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = enrmax, r__2 = work[jvec];
+ enrmax = dmax(r__1,r__2);
+/* L70: */
+ }
+ }
+
+/* Norm of A: */
+
+/* Computing MAX */
+ r__1 = slange_(norma, n, n, &a[a_offset], lda, &work[1]);
+ anorm = dmax(r__1,unfl);
+
+/* Norm of E: */
+
+/* Computing MAX */
+ r__1 = slange_(norme, n, n, &e[e_offset], lde, &work[1]);
+ enorm = dmax(r__1,ulp);
+
+/* Norm of error: */
+
+/* Error = AE - EW */
+
+ slaset_("Full", n, n, &c_b20, &c_b20, &work[1], n);
+
+ ipair = 0;
+ ierow = 1;
+ iecol = 1;
+
+ i__1 = *n;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ if (itrnse == 1) {
+ ierow = jcol;
+ } else {
+ iecol = jcol;
+ }
+
+ if (ipair == 0 && wi[jcol] != 0.f) {
+ ipair = 1;
+ }
+
+ if (ipair == 1) {
+ wmat[0] = wr[jcol];
+ wmat[1] = -wi[jcol];
+ wmat[2] = wi[jcol];
+ wmat[3] = wr[jcol];
+ sgemm_(transe, transw, n, &c__2, &c__2, &c_b25, &e[ierow + iecol *
+ e_dim1], lde, wmat, &c__2, &c_b20, &work[*n * (jcol - 1)
+ + 1], n);
+ ipair = 2;
+ } else if (ipair == 2) {
+ ipair = 0;
+
+ } else {
+
+ saxpy_(n, &wr[jcol], &e[ierow + iecol * e_dim1], &ince, &work[*n *
+ (jcol - 1) + 1], &c__1);
+ ipair = 0;
+ }
+
+/* L80: */
+ }
+
+ sgemm_(transa, transe, n, n, n, &c_b25, &a[a_offset], lda, &e[e_offset],
+ lde, &c_b30, &work[1], n);
+
+ errnrm = slange_("One", n, n, &work[1], n, &work[*n * *n + 1])
+ / enorm;
+
+/* Compute RESULT(1) (avoiding under/overflow) */
+
+ if (anorm > errnrm) {
+ result[1] = errnrm / anorm / ulp;
+ } else {
+ if (anorm < 1.f) {
+ result[1] = dmin(errnrm,anorm) / anorm / ulp;
+ } else {
+/* Computing MIN */
+ r__1 = errnrm / anorm;
+ result[1] = dmin(r__1,1.f) / ulp;
+ }
+ }
+
+/* Compute RESULT(2) : the normalization error in E. */
+
+/* Computing MAX */
+ r__3 = (r__1 = enrmax - 1.f, dabs(r__1)), r__4 = (r__2 = enrmin - 1.f,
+ dabs(r__2));
+ result[2] = dmax(r__3,r__4) / ((real) (*n) * ulp);
+
+ return 0;
+
+/* End of SGET22 */
+
+} /* sget22_ */
diff --git a/TESTING/EIG/sget23.c b/TESTING/EIG/sget23.c
new file mode 100644
index 0000000..cc85dab
--- /dev/null
+++ b/TESTING/EIG/sget23.c
@@ -0,0 +1,961 @@
+/* sget23.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__4 = 4;
+
+/* Subroutine */ int sget23_(logical *comp, char *balanc, integer *jtype,
+ real *thresh, integer *iseed, integer *nounit, integer *n, real *a,
+ integer *lda, real *h__, real *wr, real *wi, real *wr1, real *wi1,
+ real *vl, integer *ldvl, real *vr, integer *ldvr, real *lre, integer *
+ ldlre, real *rcondv, real *rcndv1, real *rcdvin, real *rconde, real *
+ rcnde1, real *rcdein, real *scale, real *scale1, real *result, real *
+ work, integer *lwork, integer *iwork, integer *info)
+{
+ /* Initialized data */
+
+ static char sens[1*2] = "N" "V";
+
+ /* Format strings */
+ static char fmt_9998[] = "(\002 SGET23: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, BALANC = "
+ "\002,a,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(\002 SGET23: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, INPUT EXAMPLE NUMBER = \002,"
+ "i4)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1,
+ vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3;
+ real r__1, r__2, r__3, r__4, r__5;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j;
+ real v;
+ integer jj, ihi, ilo;
+ real dum[1], eps, res[2], tol, ulp, vmx;
+ integer ihi1, ilo1, kmin;
+ real vmax, tnrm, vrmx, vtst;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ logical balok, nobal;
+ real abnrm;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sget22_(char *, char *, char *, integer *,
+ real *, integer *, real *, integer *, real *, real *, real *,
+ real *);
+ char sense[1];
+ integer isens;
+ real vimin, tolin, vrmin, abnrm1;
+ extern doublereal slapy2_(real *, real *), slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), slacpy_(
+ char *, integer *, integer *, real *, integer *, real *, integer *
+);
+ integer isensm;
+ extern /* Subroutine */ int sgeevx_(char *, char *, char *, char *,
+ integer *, real *, integer *, real *, real *, real *, integer *,
+ real *, integer *, integer *, integer *, real *, real *, real *,
+ real *, real *, integer *, integer *, integer *);
+ real smlnum, ulpinv;
+
+ /* Fortran I/O blocks */
+ static cilist io___14 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___15 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET23 checks the nonsymmetric eigenvalue problem driver SGEEVX. */
+/* If COMP = .FALSE., the first 8 of the following tests will be */
+/* performed on the input matrix A, and also test 9 if LWORK is */
+/* sufficiently large. */
+/* if COMP is .TRUE. all 11 tests will be performed. */
+
+/* (1) | A * VR - VR * W | / ( n |A| ulp ) */
+
+/* Here VR is the matrix of unit right eigenvectors. */
+/* W is a block diagonal matrix, with a 1x1 block for each */
+/* real eigenvalue and a 2x2 block for each complex conjugate */
+/* pair. If eigenvalues j and j+1 are a complex conjugate pair, */
+/* so WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the */
+/* 2 x 2 block corresponding to the pair will be: */
+
+/* ( wr wi ) */
+/* ( -wi wr ) */
+
+/* Such a block multiplying an n x 2 matrix ( ur ui ) on the */
+/* right will be the same as multiplying ur + i*ui by wr + i*wi. */
+
+/* (2) | A**H * VL - VL * W**H | / ( n |A| ulp ) */
+
+/* Here VL is the matrix of unit left eigenvectors, A**H is the */
+/* conjugate transpose of A, and W is as above. */
+
+/* (3) | |VR(i)| - 1 | / ulp and largest component real */
+
+/* VR(i) denotes the i-th column of VR. */
+
+/* (4) | |VL(i)| - 1 | / ulp and largest component real */
+
+/* VL(i) denotes the i-th column of VL. */
+
+/* (5) 0 if W(full) = W(partial), 1/ulp otherwise */
+
+/* W(full) denotes the eigenvalues computed when VR, VL, RCONDV */
+/* and RCONDE are also computed, and W(partial) denotes the */
+/* eigenvalues computed when only some of VR, VL, RCONDV, and */
+/* RCONDE are computed. */
+
+/* (6) 0 if VR(full) = VR(partial), 1/ulp otherwise */
+
+/* VR(full) denotes the right eigenvectors computed when VL, RCONDV */
+/* and RCONDE are computed, and VR(partial) denotes the result */
+/* when only some of VL and RCONDV are computed. */
+
+/* (7) 0 if VL(full) = VL(partial), 1/ulp otherwise */
+
+/* VL(full) denotes the left eigenvectors computed when VR, RCONDV */
+/* and RCONDE are computed, and VL(partial) denotes the result */
+/* when only some of VR and RCONDV are computed. */
+
+/* (8) 0 if SCALE, ILO, IHI, ABNRM (full) = */
+/* SCALE, ILO, IHI, ABNRM (partial) */
+/* 1/ulp otherwise */
+
+/* SCALE, ILO, IHI and ABNRM describe how the matrix is balanced. */
+/* (full) is when VR, VL, RCONDE and RCONDV are also computed, and */
+/* (partial) is when some are not computed. */
+
+/* (9) 0 if RCONDV(full) = RCONDV(partial), 1/ulp otherwise */
+
+/* RCONDV(full) denotes the reciprocal condition numbers of the */
+/* right eigenvectors computed when VR, VL and RCONDE are also */
+/* computed. RCONDV(partial) denotes the reciprocal condition */
+/* numbers when only some of VR, VL and RCONDE are computed. */
+
+/* (10) |RCONDV - RCDVIN| / cond(RCONDV) */
+
+/* RCONDV is the reciprocal right eigenvector condition number */
+/* computed by SGEEVX and RCDVIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDV) is the condition number of */
+/* RCONDV, and takes errors in computing RCONDV into account, so */
+/* that the resulting quantity should be O(ULP). cond(RCONDV) is */
+/* essentially given by norm(A)/RCONDE. */
+
+/* (11) |RCONDE - RCDEIN| / cond(RCONDE) */
+
+/* RCONDE is the reciprocal eigenvalue condition number */
+/* computed by SGEEVX and RCDEIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDE) is the condition number */
+/* of RCONDE, and takes errors in computing RCONDE into account, */
+/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
+/* is essentially given by norm(A)/RCONDV. */
+
+/* Arguments */
+/* ========= */
+
+/* COMP (input) LOGICAL */
+/* COMP describes which input tests to perform: */
+/* = .FALSE. if the computed condition numbers are not to */
+/* be tested against RCDVIN and RCDEIN */
+/* = .TRUE. if they are to be compared */
+
+/* BALANC (input) CHARACTER */
+/* Describes the balancing option to be tested. */
+/* = 'N' for no permuting or diagonal scaling */
+/* = 'P' for permuting but no diagonal scaling */
+/* = 'S' for no permuting but diagonal scaling */
+/* = 'B' for permuting and diagonal scaling */
+
+/* JTYPE (input) INTEGER */
+/* Type of input matrix. Used to label output if error occurs. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* ISEED (input) INTEGER array, dimension (4) */
+/* If COMP = .FALSE., the random number generator seed */
+/* used to produce matrix. */
+/* If COMP = .TRUE., ISEED(1) = the number of the example. */
+/* Used to label output if error occurs. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* N (input) INTEGER */
+/* The dimension of A. N must be at least 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, and H. LDA must be at */
+/* least 1 and at least N. */
+
+/* H (workspace) REAL array, dimension (LDA,N) */
+/* Another copy of the test matrix A, modified by SGEEVX. */
+
+/* WR (workspace) REAL array, dimension (N) */
+/* WI (workspace) REAL array, dimension (N) */
+/* The real and imaginary parts of the eigenvalues of A. */
+/* On exit, WR + WI*i are the eigenvalues of the matrix in A. */
+
+/* WR1 (workspace) REAL array, dimension (N) */
+/* WI1 (workspace) REAL array, dimension (N) */
+/* Like WR, WI, these arrays contain the eigenvalues of A, */
+/* but those computed when SGEEVX only computes a partial */
+/* eigendecomposition, i.e. not the eigenvalues and left */
+/* and right eigenvectors. */
+
+/* VL (workspace) REAL array, dimension (LDVL,N) */
+/* VL holds the computed left eigenvectors. */
+
+/* LDVL (input) INTEGER */
+/* Leading dimension of VL. Must be at least max(1,N). */
+
+/* VR (workspace) REAL array, dimension (LDVR,N) */
+/* VR holds the computed right eigenvectors. */
+
+/* LDVR (input) INTEGER */
+/* Leading dimension of VR. Must be at least max(1,N). */
+
+/* LRE (workspace) REAL array, dimension (LDLRE,N) */
+/* LRE holds the computed right or left eigenvectors. */
+
+/* LDLRE (input) INTEGER */
+/* Leading dimension of LRE. Must be at least max(1,N). */
+
+/* RCONDV (workspace) REAL array, dimension (N) */
+/* RCONDV holds the computed reciprocal condition numbers */
+/* for eigenvectors. */
+
+/* RCNDV1 (workspace) REAL array, dimension (N) */
+/* RCNDV1 holds more computed reciprocal condition numbers */
+/* for eigenvectors. */
+
+/* RCDVIN (input) REAL array, dimension (N) */
+/* When COMP = .TRUE. RCDVIN holds the precomputed reciprocal */
+/* condition numbers for eigenvectors to be compared with */
+/* RCONDV. */
+
+/* RCONDE (workspace) REAL array, dimension (N) */
+/* RCONDE holds the computed reciprocal condition numbers */
+/* for eigenvalues. */
+
+/* RCNDE1 (workspace) REAL array, dimension (N) */
+/* RCNDE1 holds more computed reciprocal condition numbers */
+/* for eigenvalues. */
+
+/* RCDEIN (input) REAL array, dimension (N) */
+/* When COMP = .TRUE. RCDEIN holds the precomputed reciprocal */
+/* condition numbers for eigenvalues to be compared with */
+/* RCONDE. */
+
+/* SCALE (workspace) REAL array, dimension (N) */
+/* Holds information describing balancing of matrix. */
+
+/* SCALE1 (workspace) REAL array, dimension (N) */
+/* Holds information describing balancing of matrix. */
+
+/* RESULT (output) REAL array, dimension (11) */
+/* The values computed by the 11 tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 3*N, and 6*N+N**2 if tests 9, 10 or 11 are to be performed. */
+
+/* IWORK (workspace) INTEGER array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* If 0, successful exit. */
+/* If <0, input parameter -INFO had an incorrect value. */
+/* If >0, SGEEVX returned an error code, the absolute */
+/* value of which is returned. */
+
+/* ===================================================================== */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iseed;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --wr;
+ --wi;
+ --wr1;
+ --wi1;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ lre_dim1 = *ldlre;
+ lre_offset = 1 + lre_dim1;
+ lre -= lre_offset;
+ --rcondv;
+ --rcndv1;
+ --rcdvin;
+ --rconde;
+ --rcnde1;
+ --rcdein;
+ --scale;
+ --scale1;
+ --result;
+ --work;
+ --iwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ nobal = lsame_(balanc, "N");
+ balok = nobal || lsame_(balanc, "P") || lsame_(
+ balanc, "S") || lsame_(balanc, "B");
+ *info = 0;
+ if (! balok) {
+ *info = -2;
+ } else if (*thresh < 0.f) {
+ *info = -4;
+ } else if (*nounit <= 0) {
+ *info = -6;
+ } else if (*n < 0) {
+ *info = -7;
+ } else if (*lda < 1 || *lda < *n) {
+ *info = -9;
+ } else if (*ldvl < 1 || *ldvl < *n) {
+ *info = -16;
+ } else if (*ldvr < 1 || *ldvr < *n) {
+ *info = -18;
+ } else if (*ldlre < 1 || *ldlre < *n) {
+ *info = -20;
+ } else if (*lwork < *n * 3 || *comp && *lwork < *n * 6 + *n * *n) {
+ *info = -31;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGET23", &i__1);
+ return 0;
+ }
+
+/* Quick return if nothing to do */
+
+ for (i__ = 1; i__ <= 11; ++i__) {
+ result[i__] = -1.f;
+/* L10: */
+ }
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ ulp = slamch_("Precision");
+ smlnum = slamch_("S");
+ ulpinv = 1.f / ulp;
+
+/* Compute eigenvalues and eigenvectors, and test them */
+
+ if (*lwork >= *n * 6 + *n * *n) {
+ *(unsigned char *)sense = 'B';
+ isensm = 2;
+ } else {
+ *(unsigned char *)sense = 'E';
+ isensm = 1;
+ }
+ slacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ sgeevx_(balanc, "V", "V", sense, n, &h__[h_offset], lda, &wr[1], &wi[1], &
+ vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ilo, &ihi, &scale[1],
+ &abnrm, &rconde[1], &rcondv[1], &work[1], lwork, &iwork[1], &
+ iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ if (*jtype != 22) {
+ io___14.ciunit = *nounit;
+ s_wsfe(&io___14);
+ do_fio(&c__1, "SGEEVX1", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__1, balanc, (ftnlen)1);
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___15.ciunit = *nounit;
+ s_wsfe(&io___15);
+ do_fio(&c__1, "SGEEVX1", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Do Test (1) */
+
+ sget22_("N", "N", "N", n, &a[a_offset], lda, &vr[vr_offset], ldvr, &wr[1],
+ &wi[1], &work[1], res);
+ result[1] = res[0];
+
+/* Do Test (2) */
+
+ sget22_("T", "N", "T", n, &a[a_offset], lda, &vl[vl_offset], ldvl, &wr[1],
+ &wi[1], &work[1], res);
+ result[2] = res[0];
+
+/* Do Test (3) */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ tnrm = 1.f;
+ if (wi[j] == 0.f) {
+ tnrm = snrm2_(n, &vr[j * vr_dim1 + 1], &c__1);
+ } else if (wi[j] > 0.f) {
+ r__1 = snrm2_(n, &vr[j * vr_dim1 + 1], &c__1);
+ r__2 = snrm2_(n, &vr[(j + 1) * vr_dim1 + 1], &c__1);
+ tnrm = slapy2_(&r__1, &r__2);
+ }
+/* Computing MAX */
+/* Computing MIN */
+ r__4 = ulpinv, r__5 = (r__1 = tnrm - 1.f, dabs(r__1)) / ulp;
+ r__2 = result[3], r__3 = dmin(r__4,r__5);
+ result[3] = dmax(r__2,r__3);
+ if (wi[j] > 0.f) {
+ vmx = 0.f;
+ vrmx = 0.f;
+ i__2 = *n;
+ for (jj = 1; jj <= i__2; ++jj) {
+ vtst = slapy2_(&vr[jj + j * vr_dim1], &vr[jj + (j + 1) *
+ vr_dim1]);
+ if (vtst > vmx) {
+ vmx = vtst;
+ }
+ if (vr[jj + (j + 1) * vr_dim1] == 0.f && (r__1 = vr[jj + j *
+ vr_dim1], dabs(r__1)) > vrmx) {
+ vrmx = (r__2 = vr[jj + j * vr_dim1], dabs(r__2));
+ }
+/* L20: */
+ }
+ if (vrmx / vmx < 1.f - ulp * 2.f) {
+ result[3] = ulpinv;
+ }
+ }
+/* L30: */
+ }
+
+/* Do Test (4) */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ tnrm = 1.f;
+ if (wi[j] == 0.f) {
+ tnrm = snrm2_(n, &vl[j * vl_dim1 + 1], &c__1);
+ } else if (wi[j] > 0.f) {
+ r__1 = snrm2_(n, &vl[j * vl_dim1 + 1], &c__1);
+ r__2 = snrm2_(n, &vl[(j + 1) * vl_dim1 + 1], &c__1);
+ tnrm = slapy2_(&r__1, &r__2);
+ }
+/* Computing MAX */
+/* Computing MIN */
+ r__4 = ulpinv, r__5 = (r__1 = tnrm - 1.f, dabs(r__1)) / ulp;
+ r__2 = result[4], r__3 = dmin(r__4,r__5);
+ result[4] = dmax(r__2,r__3);
+ if (wi[j] > 0.f) {
+ vmx = 0.f;
+ vrmx = 0.f;
+ i__2 = *n;
+ for (jj = 1; jj <= i__2; ++jj) {
+ vtst = slapy2_(&vl[jj + j * vl_dim1], &vl[jj + (j + 1) *
+ vl_dim1]);
+ if (vtst > vmx) {
+ vmx = vtst;
+ }
+ if (vl[jj + (j + 1) * vl_dim1] == 0.f && (r__1 = vl[jj + j *
+ vl_dim1], dabs(r__1)) > vrmx) {
+ vrmx = (r__2 = vl[jj + j * vl_dim1], dabs(r__2));
+ }
+/* L40: */
+ }
+ if (vrmx / vmx < 1.f - ulp * 2.f) {
+ result[4] = ulpinv;
+ }
+ }
+/* L50: */
+ }
+
+/* Test for all options of computing condition numbers */
+
+ i__1 = isensm;
+ for (isens = 1; isens <= i__1; ++isens) {
+
+ *(unsigned char *)sense = *(unsigned char *)&sens[isens - 1];
+
+/* Compute eigenvalues only, and test them */
+
+ slacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ sgeevx_(balanc, "N", "N", sense, n, &h__[h_offset], lda, &wr1[1], &
+ wi1[1], dum, &c__1, dum, &c__1, &ilo1, &ihi1, &scale1[1], &
+ abnrm1, &rcnde1[1], &rcndv1[1], &work[1], lwork, &iwork[1], &
+ iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ if (*jtype != 22) {
+ io___28.ciunit = *nounit;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "SGEEVX2", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__1, balanc, (ftnlen)1);
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___29.ciunit = *nounit;
+ s_wsfe(&io___29);
+ do_fio(&c__1, "SGEEVX2", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L190;
+ }
+
+/* Do Test (5) */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (wr[j] != wr1[j] || wi[j] != wi1[j]) {
+ result[5] = ulpinv;
+ }
+/* L60: */
+ }
+
+/* Do Test (8) */
+
+ if (! nobal) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (scale[j] != scale1[j]) {
+ result[8] = ulpinv;
+ }
+/* L70: */
+ }
+ if (ilo != ilo1) {
+ result[8] = ulpinv;
+ }
+ if (ihi != ihi1) {
+ result[8] = ulpinv;
+ }
+ if (abnrm != abnrm1) {
+ result[8] = ulpinv;
+ }
+ }
+
+/* Do Test (9) */
+
+ if (isens == 2 && *n > 1) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (rcondv[j] != rcndv1[j]) {
+ result[9] = ulpinv;
+ }
+/* L80: */
+ }
+ }
+
+/* Compute eigenvalues and right eigenvectors, and test them */
+
+ slacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ sgeevx_(balanc, "N", "V", sense, n, &h__[h_offset], lda, &wr1[1], &
+ wi1[1], dum, &c__1, &lre[lre_offset], ldlre, &ilo1, &ihi1, &
+ scale1[1], &abnrm1, &rcnde1[1], &rcndv1[1], &work[1], lwork, &
+ iwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ if (*jtype != 22) {
+ io___30.ciunit = *nounit;
+ s_wsfe(&io___30);
+ do_fio(&c__1, "SGEEVX3", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__1, balanc, (ftnlen)1);
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___31.ciunit = *nounit;
+ s_wsfe(&io___31);
+ do_fio(&c__1, "SGEEVX3", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L190;
+ }
+
+/* Do Test (5) again */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (wr[j] != wr1[j] || wi[j] != wi1[j]) {
+ result[5] = ulpinv;
+ }
+/* L90: */
+ }
+
+/* Do Test (6) */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = *n;
+ for (jj = 1; jj <= i__3; ++jj) {
+ if (vr[j + jj * vr_dim1] != lre[j + jj * lre_dim1]) {
+ result[6] = ulpinv;
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+
+/* Do Test (8) again */
+
+ if (! nobal) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (scale[j] != scale1[j]) {
+ result[8] = ulpinv;
+ }
+/* L120: */
+ }
+ if (ilo != ilo1) {
+ result[8] = ulpinv;
+ }
+ if (ihi != ihi1) {
+ result[8] = ulpinv;
+ }
+ if (abnrm != abnrm1) {
+ result[8] = ulpinv;
+ }
+ }
+
+/* Do Test (9) again */
+
+ if (isens == 2 && *n > 1) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (rcondv[j] != rcndv1[j]) {
+ result[9] = ulpinv;
+ }
+/* L130: */
+ }
+ }
+
+/* Compute eigenvalues and left eigenvectors, and test them */
+
+ slacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ sgeevx_(balanc, "V", "N", sense, n, &h__[h_offset], lda, &wr1[1], &
+ wi1[1], &lre[lre_offset], ldlre, dum, &c__1, &ilo1, &ihi1, &
+ scale1[1], &abnrm1, &rcnde1[1], &rcndv1[1], &work[1], lwork, &
+ iwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ if (*jtype != 22) {
+ io___32.ciunit = *nounit;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "SGEEVX4", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__1, balanc, (ftnlen)1);
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___33.ciunit = *nounit;
+ s_wsfe(&io___33);
+ do_fio(&c__1, "SGEEVX4", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L190;
+ }
+
+/* Do Test (5) again */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (wr[j] != wr1[j] || wi[j] != wi1[j]) {
+ result[5] = ulpinv;
+ }
+/* L140: */
+ }
+
+/* Do Test (7) */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = *n;
+ for (jj = 1; jj <= i__3; ++jj) {
+ if (vl[j + jj * vl_dim1] != lre[j + jj * lre_dim1]) {
+ result[7] = ulpinv;
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+
+/* Do Test (8) again */
+
+ if (! nobal) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (scale[j] != scale1[j]) {
+ result[8] = ulpinv;
+ }
+/* L170: */
+ }
+ if (ilo != ilo1) {
+ result[8] = ulpinv;
+ }
+ if (ihi != ihi1) {
+ result[8] = ulpinv;
+ }
+ if (abnrm != abnrm1) {
+ result[8] = ulpinv;
+ }
+ }
+
+/* Do Test (9) again */
+
+ if (isens == 2 && *n > 1) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (rcondv[j] != rcndv1[j]) {
+ result[9] = ulpinv;
+ }
+/* L180: */
+ }
+ }
+
+L190:
+
+/* L200: */
+ ;
+ }
+
+/* If COMP, compare condition numbers to precomputed ones */
+
+ if (*comp) {
+ slacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ sgeevx_("N", "V", "V", "B", n, &h__[h_offset], lda, &wr[1], &wi[1], &
+ vl[vl_offset], ldvl, &vr[vr_offset], ldvr, &ilo, &ihi, &scale[
+ 1], &abnrm, &rconde[1], &rcondv[1], &work[1], lwork, &iwork[1]
+, &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___34.ciunit = *nounit;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "SGEEVX5", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Sort eigenvalues and condition numbers lexicographically */
+/* to compare with inputs */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ kmin = i__;
+ vrmin = wr[i__];
+ vimin = wi[i__];
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (wr[j] < vrmin) {
+ kmin = j;
+ vrmin = wr[j];
+ vimin = wi[j];
+ }
+/* L210: */
+ }
+ wr[kmin] = wr[i__];
+ wi[kmin] = wi[i__];
+ wr[i__] = vrmin;
+ wi[i__] = vimin;
+ vrmin = rconde[kmin];
+ rconde[kmin] = rconde[i__];
+ rconde[i__] = vrmin;
+ vrmin = rcondv[kmin];
+ rcondv[kmin] = rcondv[i__];
+ rcondv[i__] = vrmin;
+/* L220: */
+ }
+
+/* Compare condition numbers for eigenvectors */
+/* taking their condition numbers into account */
+
+ result[10] = 0.f;
+ eps = dmax(5.9605e-8f,ulp);
+/* Computing MAX */
+ r__1 = (real) (*n) * eps * abnrm;
+ v = dmax(r__1,smlnum);
+ if (abnrm == 0.f) {
+ v = 1.f;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (v > rcondv[i__] * rconde[i__]) {
+ tol = rcondv[i__];
+ } else {
+ tol = v / rconde[i__];
+ }
+ if (v > rcdvin[i__] * rcdein[i__]) {
+ tolin = rcdvin[i__];
+ } else {
+ tolin = v / rcdein[i__];
+ }
+/* Computing MAX */
+ r__1 = tol, r__2 = smlnum / eps;
+ tol = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = tolin, r__2 = smlnum / eps;
+ tolin = dmax(r__1,r__2);
+ if (eps * (rcdvin[i__] - tolin) > rcondv[i__] + tol) {
+ vmax = 1.f / eps;
+ } else if (rcdvin[i__] - tolin > rcondv[i__] + tol) {
+ vmax = (rcdvin[i__] - tolin) / (rcondv[i__] + tol);
+ } else if (rcdvin[i__] + tolin < eps * (rcondv[i__] - tol)) {
+ vmax = 1.f / eps;
+ } else if (rcdvin[i__] + tolin < rcondv[i__] - tol) {
+ vmax = (rcondv[i__] - tol) / (rcdvin[i__] + tolin);
+ } else {
+ vmax = 1.f;
+ }
+ result[10] = dmax(result[10],vmax);
+/* L230: */
+ }
+
+/* Compare condition numbers for eigenvalues */
+/* taking their condition numbers into account */
+
+ result[11] = 0.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (v > rcondv[i__]) {
+ tol = 1.f;
+ } else {
+ tol = v / rcondv[i__];
+ }
+ if (v > rcdvin[i__]) {
+ tolin = 1.f;
+ } else {
+ tolin = v / rcdvin[i__];
+ }
+/* Computing MAX */
+ r__1 = tol, r__2 = smlnum / eps;
+ tol = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = tolin, r__2 = smlnum / eps;
+ tolin = dmax(r__1,r__2);
+ if (eps * (rcdein[i__] - tolin) > rconde[i__] + tol) {
+ vmax = 1.f / eps;
+ } else if (rcdein[i__] - tolin > rconde[i__] + tol) {
+ vmax = (rcdein[i__] - tolin) / (rconde[i__] + tol);
+ } else if (rcdein[i__] + tolin < eps * (rconde[i__] - tol)) {
+ vmax = 1.f / eps;
+ } else if (rcdein[i__] + tolin < rconde[i__] - tol) {
+ vmax = (rconde[i__] - tol) / (rcdein[i__] + tolin);
+ } else {
+ vmax = 1.f;
+ }
+ result[11] = dmax(result[11],vmax);
+/* L240: */
+ }
+L250:
+
+ ;
+ }
+
+
+ return 0;
+
+/* End of SGET23 */
+
+} /* sget23_ */
diff --git a/TESTING/EIG/sget24.c b/TESTING/EIG/sget24.c
new file mode 100644
index 0000000..59234b8
--- /dev/null
+++ b/TESTING/EIG/sget24.c
@@ -0,0 +1,1180 @@
+/* sget24.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ real selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__4 = 4;
+static real c_b35 = 1.f;
+static real c_b41 = 0.f;
+static real c_b44 = -1.f;
+
+/* Subroutine */ int sget24_(logical *comp, integer *jtype, real *thresh,
+ integer *iseed, integer *nounit, integer *n, real *a, integer *lda,
+ real *h__, real *ht, real *wr, real *wi, real *wrt, real *wit, real *
+ wrtmp, real *witmp, real *vs, integer *ldvs, real *vs1, real *rcdein,
+ real *rcdvin, integer *nslct, integer *islct, real *result, real *
+ work, integer *lwork, integer *iwork, logical *bwork, integer *info)
+{
+ /* Format strings */
+ static char fmt_9998[] = "(\002 SGET24: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(\002 SGET24: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, INPUT EXAMPLE NUMBER = \002,"
+ "i4)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, ht_dim1, ht_offset, vs_dim1,
+ vs_offset, vs1_dim1, vs1_offset, i__1, i__2;
+ real r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double r_sign(real *, real *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ real v, eps, tol, tmp, ulp;
+ integer sdim, kmin, itmp, ipnt[20], rsub;
+ char sort[1];
+ integer sdim1, iinfo;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm, vimin, tolin;
+ extern /* Subroutine */ int sort01_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, real *);
+ real vrmin;
+ integer isort;
+ real wnorm;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ real rcnde1, rcndv1;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ real rconde;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer knteig;
+ real rcondv;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+ extern logical sslect_(real *, real *);
+ extern /* Subroutine */ int sgeesx_(char *, char *, L_fp, char *, integer
+ *, real *, integer *, integer *, real *, real *, real *, integer *
+, real *, real *, real *, integer *, integer *, integer *,
+ logical *, integer *);
+ integer liwork;
+ real smlnum, ulpinv;
+
+ /* Fortran I/O blocks */
+ static cilist io___13 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___14 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___19 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___20 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET24 checks the nonsymmetric eigenvalue (Schur form) problem */
+/* expert driver SGEESX. */
+
+/* If COMP = .FALSE., the first 13 of the following tests will be */
+/* be performed on the input matrix A, and also tests 14 and 15 */
+/* if LWORK is sufficiently large. */
+/* If COMP = .TRUE., all 17 test will be performed. */
+
+/* (1) 0 if T is in Schur form, 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (2) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (no sorting of eigenvalues). */
+
+/* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues). */
+
+/* (4) 0 if WR+sqrt(-1)*WI are eigenvalues of T */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (5) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (7) 0 if T is in Schur form, 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (8) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (with sorting of eigenvalues). */
+
+/* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues). */
+
+/* (10) 0 if WR+sqrt(-1)*WI are eigenvalues of T */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare WR, WI with and */
+/* without reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (11) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare T with and without */
+/* reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare VS with and without */
+/* reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (13) if sorting worked and SDIM is the number of */
+/* eigenvalues which were SELECTed */
+/* If workspace sufficient, also compare SDIM with and */
+/* without reciprocal condition numbers */
+
+/* (14) if RCONDE the same no matter if VS and/or RCONDV computed */
+
+/* (15) if RCONDV the same no matter if VS and/or RCONDE computed */
+
+/* (16) |RCONDE - RCDEIN| / cond(RCONDE) */
+
+/* RCONDE is the reciprocal average eigenvalue condition number */
+/* computed by SGEESX and RCDEIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDE) is the condition number */
+/* of RCONDE, and takes errors in computing RCONDE into account, */
+/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
+/* is essentially given by norm(A)/RCONDV. */
+
+/* (17) |RCONDV - RCDVIN| / cond(RCONDV) */
+
+/* RCONDV is the reciprocal right invariant subspace condition */
+/* number computed by SGEESX and RCDVIN (the precomputed true */
+/* value) is supplied as input. cond(RCONDV) is the condition */
+/* number of RCONDV, and takes errors in computing RCONDV into */
+/* account, so that the resulting quantity should be O(ULP). */
+/* cond(RCONDV) is essentially given by norm(A)/RCONDE. */
+
+/* Arguments */
+/* ========= */
+
+/* COMP (input) LOGICAL */
+/* COMP describes which input tests to perform: */
+/* = .FALSE. if the computed condition numbers are not to */
+/* be tested against RCDVIN and RCDEIN */
+/* = .TRUE. if they are to be compared */
+
+/* JTYPE (input) INTEGER */
+/* Type of input matrix. Used to label output if error occurs. */
+
+/* ISEED (input) INTEGER array, dimension (4) */
+/* If COMP = .FALSE., the random number generator seed */
+/* used to produce matrix. */
+/* If COMP = .TRUE., ISEED(1) = the number of the example. */
+/* Used to label output if error occurs. */
+
+/* THRESH (input) REAL */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* N (input) INTEGER */
+/* The dimension of A. N must be at least 0. */
+
+/* A (input/output) REAL array, dimension (LDA, N) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, and H. LDA must be at */
+/* least 1 and at least N. */
+
+/* H (workspace) REAL array, dimension (LDA, N) */
+/* Another copy of the test matrix A, modified by SGEESX. */
+
+/* HT (workspace) REAL array, dimension (LDA, N) */
+/* Yet another copy of the test matrix A, modified by SGEESX. */
+
+/* WR (workspace) REAL array, dimension (N) */
+/* WI (workspace) REAL array, dimension (N) */
+/* The real and imaginary parts of the eigenvalues of A. */
+/* On exit, WR + WI*i are the eigenvalues of the matrix in A. */
+
+/* WRT (workspace) REAL array, dimension (N) */
+/* WIT (workspace) REAL array, dimension (N) */
+/* Like WR, WI, these arrays contain the eigenvalues of A, */
+/* but those computed when SGEESX only computes a partial */
+/* eigendecomposition, i.e. not Schur vectors */
+
+/* WRTMP (workspace) REAL array, dimension (N) */
+/* WITMP (workspace) REAL array, dimension (N) */
+/* Like WR, WI, these arrays contain the eigenvalues of A, */
+/* but sorted by increasing real part. */
+
+/* VS (workspace) REAL array, dimension (LDVS, N) */
+/* VS holds the computed Schur vectors. */
+
+/* LDVS (input) INTEGER */
+/* Leading dimension of VS. Must be at least max(1, N). */
+
+/* VS1 (workspace) REAL array, dimension (LDVS, N) */
+/* VS1 holds another copy of the computed Schur vectors. */
+
+/* RCDEIN (input) REAL */
+/* When COMP = .TRUE. RCDEIN holds the precomputed reciprocal */
+/* condition number for the average of selected eigenvalues. */
+
+/* RCDVIN (input) REAL */
+/* When COMP = .TRUE. RCDVIN holds the precomputed reciprocal */
+/* condition number for the selected right invariant subspace. */
+
+/* NSLCT (input) INTEGER */
+/* When COMP = .TRUE. the number of selected eigenvalues */
+/* corresponding to the precomputed values RCDEIN and RCDVIN. */
+
+/* ISLCT (input) INTEGER array, dimension (NSLCT) */
+/* When COMP = .TRUE. ISLCT selects the eigenvalues of the */
+/* input matrix corresponding to the precomputed values RCDEIN */
+/* and RCDVIN. For I=1, ... ,NSLCT, if ISLCT(I) = J, then the */
+/* eigenvalue with the J-th largest real part is selected. */
+/* Not referenced if COMP = .FALSE. */
+
+/* RESULT (output) REAL array, dimension (17) */
+/* The values computed by the 17 tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK to be passed to SGEESX. This */
+/* must be at least 3*N, and N+N**2 if tests 14--16 are to */
+/* be performed. */
+
+/* IWORK (workspace) INTEGER array, dimension (N*N) */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* If 0, successful exit. */
+/* If <0, input parameter -INFO had an incorrect value. */
+/* If >0, SGEESX returned an error code, the absolute */
+/* value of which is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ /* Parameter adjustments */
+ --iseed;
+ ht_dim1 = *lda;
+ ht_offset = 1 + ht_dim1;
+ ht -= ht_offset;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --wr;
+ --wi;
+ --wrt;
+ --wit;
+ --wrtmp;
+ --witmp;
+ vs1_dim1 = *ldvs;
+ vs1_offset = 1 + vs1_dim1;
+ vs1 -= vs1_offset;
+ vs_dim1 = *ldvs;
+ vs_offset = 1 + vs_dim1;
+ vs -= vs_offset;
+ --islct;
+ --result;
+ --work;
+ --iwork;
+ --bwork;
+
+ /* Function Body */
+ *info = 0;
+ if (*thresh < 0.f) {
+ *info = -3;
+ } else if (*nounit <= 0) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (*lda < 1 || *lda < *n) {
+ *info = -8;
+ } else if (*ldvs < 1 || *ldvs < *n) {
+ *info = -18;
+ } else if (*lwork < *n * 3) {
+ *info = -26;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGET24", &i__1);
+ return 0;
+ }
+
+/* Quick return if nothing to do */
+
+ for (i__ = 1; i__ <= 17; ++i__) {
+ result[i__] = -1.f;
+/* L10: */
+ }
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Important constants */
+
+ smlnum = slamch_("Safe minimum");
+ ulp = slamch_("Precision");
+ ulpinv = 1.f / ulp;
+
+/* Perform tests (1)-(13) */
+
+ sslct_1.selopt = 0;
+ liwork = *n * *n;
+ for (isort = 0; isort <= 1; ++isort) {
+ if (isort == 0) {
+ *(unsigned char *)sort = 'N';
+ rsub = 0;
+ } else {
+ *(unsigned char *)sort = 'S';
+ rsub = 6;
+ }
+
+/* Compute Schur form and Schur vectors, and test them */
+
+ slacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ sgeesx_("V", sort, (L_fp)sslect_, "N", n, &h__[h_offset], lda, &sdim,
+ &wr[1], &wi[1], &vs[vs_offset], ldvs, &rconde, &rcondv, &work[
+ 1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != *n + 2) {
+ result[rsub + 1] = ulpinv;
+ if (*jtype != 22) {
+ io___13.ciunit = *nounit;
+ s_wsfe(&io___13);
+ do_fio(&c__1, "SGEESX1", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___14.ciunit = *nounit;
+ s_wsfe(&io___14);
+ do_fio(&c__1, "SGEESX1", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ return 0;
+ }
+ if (isort == 0) {
+ scopy_(n, &wr[1], &c__1, &wrtmp[1], &c__1);
+ scopy_(n, &wi[1], &c__1, &witmp[1], &c__1);
+ }
+
+/* Do Test (1) or Test (7) */
+
+ result[rsub + 1] = 0.f;
+ i__1 = *n - 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+ if (h__[i__ + j * h_dim1] != 0.f) {
+ result[rsub + 1] = ulpinv;
+ }
+/* L20: */
+ }
+/* L30: */
+ }
+ i__1 = *n - 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (h__[i__ + 1 + i__ * h_dim1] != 0.f && h__[i__ + 2 + (i__ + 1)
+ * h_dim1] != 0.f) {
+ result[rsub + 1] = ulpinv;
+ }
+/* L40: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (h__[i__ + 1 + i__ * h_dim1] != 0.f) {
+ if (h__[i__ + i__ * h_dim1] != h__[i__ + 1 + (i__ + 1) *
+ h_dim1] || h__[i__ + (i__ + 1) * h_dim1] == 0.f ||
+ r_sign(&c_b35, &h__[i__ + 1 + i__ * h_dim1]) ==
+ r_sign(&c_b35, &h__[i__ + (i__ + 1) * h_dim1])) {
+ result[rsub + 1] = ulpinv;
+ }
+ }
+/* L50: */
+ }
+
+/* Test (2) or (8): Compute norm(A - Q*H*Q') / (norm(A) * N * ULP) */
+
+/* Copy A to VS1, used as workspace */
+
+ slacpy_(" ", n, n, &a[a_offset], lda, &vs1[vs1_offset], ldvs);
+
+/* Compute Q*H and store in HT. */
+
+ sgemm_("No transpose", "No transpose", n, n, n, &c_b35, &vs[vs_offset]
+, ldvs, &h__[h_offset], lda, &c_b41, &ht[ht_offset], lda);
+
+/* Compute A - Q*H*Q' */
+
+ sgemm_("No transpose", "Transpose", n, n, n, &c_b44, &ht[ht_offset],
+ lda, &vs[vs_offset], ldvs, &c_b35, &vs1[vs1_offset], ldvs);
+
+/* Computing MAX */
+ r__1 = slange_("1", n, n, &a[a_offset], lda, &work[1]);
+ anorm = dmax(r__1,smlnum);
+ wnorm = slange_("1", n, n, &vs1[vs1_offset], ldvs, &work[1]);
+
+ if (anorm > wnorm) {
+ result[rsub + 2] = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.f) {
+/* Computing MIN */
+ r__1 = wnorm, r__2 = *n * anorm;
+ result[rsub + 2] = dmin(r__1,r__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ r__1 = wnorm / anorm, r__2 = (real) (*n);
+ result[rsub + 2] = dmin(r__1,r__2) / (*n * ulp);
+ }
+ }
+
+/* Test (3) or (9): Compute norm( I - Q'*Q ) / ( N * ULP ) */
+
+ sort01_("Columns", n, n, &vs[vs_offset], ldvs, &work[1], lwork, &
+ result[rsub + 3]);
+
+/* Do Test (4) or Test (10) */
+
+ result[rsub + 4] = 0.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (h__[i__ + i__ * h_dim1] != wr[i__]) {
+ result[rsub + 4] = ulpinv;
+ }
+/* L60: */
+ }
+ if (*n > 1) {
+ if (h__[h_dim1 + 2] == 0.f && wi[1] != 0.f) {
+ result[rsub + 4] = ulpinv;
+ }
+ if (h__[*n + (*n - 1) * h_dim1] == 0.f && wi[*n] != 0.f) {
+ result[rsub + 4] = ulpinv;
+ }
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (h__[i__ + 1 + i__ * h_dim1] != 0.f) {
+ tmp = sqrt((r__1 = h__[i__ + 1 + i__ * h_dim1], dabs(r__1))) *
+ sqrt((r__2 = h__[i__ + (i__ + 1) * h_dim1], dabs(
+ r__2)));
+/* Computing MAX */
+/* Computing MAX */
+ r__4 = ulp * tmp;
+ r__2 = result[rsub + 4], r__3 = (r__1 = wi[i__] - tmp, dabs(
+ r__1)) / dmax(r__4,smlnum);
+ result[rsub + 4] = dmax(r__2,r__3);
+/* Computing MAX */
+/* Computing MAX */
+ r__4 = ulp * tmp;
+ r__2 = result[rsub + 4], r__3 = (r__1 = wi[i__ + 1] + tmp,
+ dabs(r__1)) / dmax(r__4,smlnum);
+ result[rsub + 4] = dmax(r__2,r__3);
+ } else if (i__ > 1) {
+ if (h__[i__ + 1 + i__ * h_dim1] == 0.f && h__[i__ + (i__ - 1)
+ * h_dim1] == 0.f && wi[i__] != 0.f) {
+ result[rsub + 4] = ulpinv;
+ }
+ }
+/* L70: */
+ }
+
+/* Do Test (5) or Test (11) */
+
+ slacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ sgeesx_("N", sort, (L_fp)sslect_, "N", n, &ht[ht_offset], lda, &sdim,
+ &wrt[1], &wit[1], &vs[vs_offset], ldvs, &rconde, &rcondv, &
+ work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != *n + 2) {
+ result[rsub + 5] = ulpinv;
+ if (*jtype != 22) {
+ io___19.ciunit = *nounit;
+ s_wsfe(&io___19);
+ do_fio(&c__1, "SGEESX2", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___20.ciunit = *nounit;
+ s_wsfe(&io___20);
+ do_fio(&c__1, "SGEESX2", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+ result[rsub + 5] = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (h__[i__ + j * h_dim1] != ht[i__ + j * ht_dim1]) {
+ result[rsub + 5] = ulpinv;
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Do Test (6) or Test (12) */
+
+ result[rsub + 6] = 0.f;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (wr[i__] != wrt[i__] || wi[i__] != wit[i__]) {
+ result[rsub + 6] = ulpinv;
+ }
+/* L100: */
+ }
+
+/* Do Test (13) */
+
+ if (isort == 1) {
+ result[13] = 0.f;
+ knteig = 0;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ r__1 = -wi[i__];
+ if (sslect_(&wr[i__], &wi[i__]) || sslect_(&wr[i__], &r__1)) {
+ ++knteig;
+ }
+ if (i__ < *n) {
+ r__1 = -wi[i__ + 1];
+ r__2 = -wi[i__];
+ if ((sslect_(&wr[i__ + 1], &wi[i__ + 1]) || sslect_(&wr[
+ i__ + 1], &r__1)) && ! (sslect_(&wr[i__], &wi[i__]
+) || sslect_(&wr[i__], &r__2)) && iinfo != *n + 2)
+ {
+ result[13] = ulpinv;
+ }
+ }
+/* L110: */
+ }
+ if (sdim != knteig) {
+ result[13] = ulpinv;
+ }
+ }
+
+/* L120: */
+ }
+
+/* If there is enough workspace, perform tests (14) and (15) */
+/* as well as (10) through (13) */
+
+ if (*lwork >= *n + *n * *n / 2) {
+
+/* Compute both RCONDE and RCONDV with VS */
+
+ *(unsigned char *)sort = 'S';
+ result[14] = 0.f;
+ result[15] = 0.f;
+ slacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ sgeesx_("V", sort, (L_fp)sslect_, "B", n, &ht[ht_offset], lda, &sdim1,
+ &wrt[1], &wit[1], &vs1[vs1_offset], ldvs, &rconde, &rcondv, &
+ work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != *n + 2) {
+ result[14] = ulpinv;
+ result[15] = ulpinv;
+ if (*jtype != 22) {
+ io___23.ciunit = *nounit;
+ s_wsfe(&io___23);
+ do_fio(&c__1, "SGEESX3", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___24.ciunit = *nounit;
+ s_wsfe(&io___24);
+ do_fio(&c__1, "SGEESX3", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (wr[i__] != wrt[i__] || wi[i__] != wit[i__]) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (h__[i__ + j * h_dim1] != ht[i__ + j * ht_dim1]) {
+ result[11] = ulpinv;
+ }
+ if (vs[i__ + j * vs_dim1] != vs1[i__ + j * vs1_dim1]) {
+ result[12] = ulpinv;
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+/* Compute both RCONDE and RCONDV without VS, and compare */
+
+ slacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ sgeesx_("N", sort, (L_fp)sslect_, "B", n, &ht[ht_offset], lda, &sdim1,
+ &wrt[1], &wit[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &
+ work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != *n + 2) {
+ result[14] = ulpinv;
+ result[15] = ulpinv;
+ if (*jtype != 22) {
+ io___27.ciunit = *nounit;
+ s_wsfe(&io___27);
+ do_fio(&c__1, "SGEESX4", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___28.ciunit = *nounit;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "SGEESX4", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Perform tests (14) and (15) */
+
+ if (rcnde1 != rconde) {
+ result[14] = ulpinv;
+ }
+ if (rcndv1 != rcondv) {
+ result[15] = ulpinv;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (wr[i__] != wrt[i__] || wi[i__] != wit[i__]) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (h__[i__ + j * h_dim1] != ht[i__ + j * ht_dim1]) {
+ result[11] = ulpinv;
+ }
+ if (vs[i__ + j * vs_dim1] != vs1[i__ + j * vs1_dim1]) {
+ result[12] = ulpinv;
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+/* Compute RCONDE with VS, and compare */
+
+ slacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ sgeesx_("V", sort, (L_fp)sslect_, "E", n, &ht[ht_offset], lda, &sdim1,
+ &wrt[1], &wit[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &
+ work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != *n + 2) {
+ result[14] = ulpinv;
+ if (*jtype != 22) {
+ io___29.ciunit = *nounit;
+ s_wsfe(&io___29);
+ do_fio(&c__1, "SGEESX5", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___30.ciunit = *nounit;
+ s_wsfe(&io___30);
+ do_fio(&c__1, "SGEESX5", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Perform test (14) */
+
+ if (rcnde1 != rconde) {
+ result[14] = ulpinv;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (wr[i__] != wrt[i__] || wi[i__] != wit[i__]) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (h__[i__ + j * h_dim1] != ht[i__ + j * ht_dim1]) {
+ result[11] = ulpinv;
+ }
+ if (vs[i__ + j * vs_dim1] != vs1[i__ + j * vs1_dim1]) {
+ result[12] = ulpinv;
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+/* Compute RCONDE without VS, and compare */
+
+ slacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ sgeesx_("N", sort, (L_fp)sslect_, "E", n, &ht[ht_offset], lda, &sdim1,
+ &wrt[1], &wit[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &
+ work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != *n + 2) {
+ result[14] = ulpinv;
+ if (*jtype != 22) {
+ io___31.ciunit = *nounit;
+ s_wsfe(&io___31);
+ do_fio(&c__1, "SGEESX6", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___32.ciunit = *nounit;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "SGEESX6", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Perform test (14) */
+
+ if (rcnde1 != rconde) {
+ result[14] = ulpinv;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (wr[i__] != wrt[i__] || wi[i__] != wit[i__]) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (h__[i__ + j * h_dim1] != ht[i__ + j * ht_dim1]) {
+ result[11] = ulpinv;
+ }
+ if (vs[i__ + j * vs_dim1] != vs1[i__ + j * vs1_dim1]) {
+ result[12] = ulpinv;
+ }
+/* L190: */
+ }
+/* L200: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+/* Compute RCONDV with VS, and compare */
+
+ slacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ sgeesx_("V", sort, (L_fp)sslect_, "V", n, &ht[ht_offset], lda, &sdim1,
+ &wrt[1], &wit[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &
+ work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != *n + 2) {
+ result[15] = ulpinv;
+ if (*jtype != 22) {
+ io___33.ciunit = *nounit;
+ s_wsfe(&io___33);
+ do_fio(&c__1, "SGEESX7", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___34.ciunit = *nounit;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "SGEESX7", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Perform test (15) */
+
+ if (rcndv1 != rcondv) {
+ result[15] = ulpinv;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (wr[i__] != wrt[i__] || wi[i__] != wit[i__]) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (h__[i__ + j * h_dim1] != ht[i__ + j * ht_dim1]) {
+ result[11] = ulpinv;
+ }
+ if (vs[i__ + j * vs_dim1] != vs1[i__ + j * vs1_dim1]) {
+ result[12] = ulpinv;
+ }
+/* L210: */
+ }
+/* L220: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+/* Compute RCONDV without VS, and compare */
+
+ slacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ sgeesx_("N", sort, (L_fp)sslect_, "V", n, &ht[ht_offset], lda, &sdim1,
+ &wrt[1], &wit[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &
+ work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != *n + 2) {
+ result[15] = ulpinv;
+ if (*jtype != 22) {
+ io___35.ciunit = *nounit;
+ s_wsfe(&io___35);
+ do_fio(&c__1, "SGEESX8", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___36.ciunit = *nounit;
+ s_wsfe(&io___36);
+ do_fio(&c__1, "SGEESX8", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Perform test (15) */
+
+ if (rcndv1 != rcondv) {
+ result[15] = ulpinv;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (wr[i__] != wrt[i__] || wi[i__] != wit[i__]) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (h__[i__ + j * h_dim1] != ht[i__ + j * ht_dim1]) {
+ result[11] = ulpinv;
+ }
+ if (vs[i__ + j * vs_dim1] != vs1[i__ + j * vs1_dim1]) {
+ result[12] = ulpinv;
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+ }
+
+L250:
+
+/* If there are precomputed reciprocal condition numbers, compare */
+/* computed values with them. */
+
+ if (*comp) {
+
+/* First set up SELOPT, SELDIM, SELVAL, SELWR, and SELWI so that */
+/* the logical function SSLECT selects the eigenvalues specified */
+/* by NSLCT and ISLCT. */
+
+ sslct_1.seldim = *n;
+ sslct_1.selopt = 1;
+ eps = dmax(ulp,5.9605e-8f);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ipnt[i__ - 1] = i__;
+ sslct_1.selval[i__ - 1] = FALSE_;
+ sslct_1.selwr[i__ - 1] = wrtmp[i__];
+ sslct_1.selwi[i__ - 1] = witmp[i__];
+/* L260: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ kmin = i__;
+ vrmin = wrtmp[i__];
+ vimin = witmp[i__];
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (wrtmp[j] < vrmin) {
+ kmin = j;
+ vrmin = wrtmp[j];
+ vimin = witmp[j];
+ }
+/* L270: */
+ }
+ wrtmp[kmin] = wrtmp[i__];
+ witmp[kmin] = witmp[i__];
+ wrtmp[i__] = vrmin;
+ witmp[i__] = vimin;
+ itmp = ipnt[i__ - 1];
+ ipnt[i__ - 1] = ipnt[kmin - 1];
+ ipnt[kmin - 1] = itmp;
+/* L280: */
+ }
+ i__1 = *nslct;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sslct_1.selval[ipnt[islct[i__] - 1] - 1] = TRUE_;
+/* L290: */
+ }
+
+/* Compute condition numbers */
+
+ slacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ sgeesx_("N", "S", (L_fp)sslect_, "B", n, &ht[ht_offset], lda, &sdim1,
+ &wrt[1], &wit[1], &vs1[vs1_offset], ldvs, &rconde, &rcondv, &
+ work[1], lwork, &iwork[1], &liwork, &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != *n + 2) {
+ result[16] = ulpinv;
+ result[17] = ulpinv;
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "SGEESX9", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L300;
+ }
+
+/* Compare condition number for average of selected eigenvalues */
+/* taking its condition number into account */
+
+ anorm = slange_("1", n, n, &a[a_offset], lda, &work[1]);
+/* Computing MAX */
+ r__1 = (real) (*n) * eps * anorm;
+ v = dmax(r__1,smlnum);
+ if (anorm == 0.f) {
+ v = 1.f;
+ }
+ if (v > rcondv) {
+ tol = 1.f;
+ } else {
+ tol = v / rcondv;
+ }
+ if (v > *rcdvin) {
+ tolin = 1.f;
+ } else {
+ tolin = v / *rcdvin;
+ }
+/* Computing MAX */
+ r__1 = tol, r__2 = smlnum / eps;
+ tol = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = tolin, r__2 = smlnum / eps;
+ tolin = dmax(r__1,r__2);
+ if (eps * (*rcdein - tolin) > rconde + tol) {
+ result[16] = ulpinv;
+ } else if (*rcdein - tolin > rconde + tol) {
+ result[16] = (*rcdein - tolin) / (rconde + tol);
+ } else if (*rcdein + tolin < eps * (rconde - tol)) {
+ result[16] = ulpinv;
+ } else if (*rcdein + tolin < rconde - tol) {
+ result[16] = (rconde - tol) / (*rcdein + tolin);
+ } else {
+ result[16] = 1.f;
+ }
+
+/* Compare condition numbers for right invariant subspace */
+/* taking its condition number into account */
+
+ if (v > rcondv * rconde) {
+ tol = rcondv;
+ } else {
+ tol = v / rconde;
+ }
+ if (v > *rcdvin * *rcdein) {
+ tolin = *rcdvin;
+ } else {
+ tolin = v / *rcdein;
+ }
+/* Computing MAX */
+ r__1 = tol, r__2 = smlnum / eps;
+ tol = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = tolin, r__2 = smlnum / eps;
+ tolin = dmax(r__1,r__2);
+ if (eps * (*rcdvin - tolin) > rcondv + tol) {
+ result[17] = ulpinv;
+ } else if (*rcdvin - tolin > rcondv + tol) {
+ result[17] = (*rcdvin - tolin) / (rcondv + tol);
+ } else if (*rcdvin + tolin < eps * (rcondv - tol)) {
+ result[17] = ulpinv;
+ } else if (*rcdvin + tolin < rcondv - tol) {
+ result[17] = (rcondv - tol) / (*rcdvin + tolin);
+ } else {
+ result[17] = 1.f;
+ }
+
+L300:
+
+ ;
+ }
+
+
+ return 0;
+
+/* End of SGET24 */
+
+} /* sget24_ */
diff --git a/TESTING/EIG/sget31.c b/TESTING/EIG/sget31.c
new file mode 100644
index 0000000..1318cfc
--- /dev/null
+++ b/TESTING/EIG/sget31.c
@@ -0,0 +1,587 @@
+/* sget31.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+
+/* Subroutine */ int sget31_(real *rmax, integer *lmax, integer *ninfo,
+ integer *knt)
+{
+ /* Initialized data */
+
+ static logical ltrans[2] = { FALSE_,TRUE_ };
+
+ /* System generated locals */
+ real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10, r__11,
+ r__12, r__13;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real a[4] /* was [2][2] */, b[4] /* was [2][2] */, x[4] /* was [2][2]
+ */, d1, d2, ca;
+ integer ia, ib, na;
+ real wi;
+ integer nw;
+ real wr;
+ integer id1, id2, ica;
+ real den, vab[3], vca[5], vdd[4], eps;
+ integer iwi;
+ real res, tmp;
+ integer iwr;
+ real vwi[4], vwr[4];
+ integer info;
+ real unfl, smin, scale;
+ integer ismin;
+ real vsmin[4], xnorm;
+ extern /* Subroutine */ int slaln2_(logical *, integer *, integer *, real
+ *, real *, real *, integer *, real *, real *, real *, integer *,
+ real *, real *, real *, integer *, real *, real *, integer *),
+ slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ real bignum;
+ integer itrans;
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET31 tests SLALN2, a routine for solving */
+
+/* (ca A - w D)X = sB */
+
+/* where A is an NA by NA matrix (NA=1 or 2 only), w is a real (NW=1) or */
+/* complex (NW=2) constant, ca is a real constant, D is an NA by NA real */
+/* diagonal matrix, and B is an NA by NW matrix (when NW=2 the second */
+/* column of B contains the imaginary part of the solution). The code */
+/* returns X and s, where s is a scale factor, less than or equal to 1, */
+/* which is chosen to avoid overflow in X. */
+
+/* If any singular values of ca A-w D are less than another input */
+/* parameter SMIN, they are perturbed up to SMIN. */
+
+/* The test condition is that the scaled residual */
+
+/* norm( (ca A-w D)*X - s*B ) / */
+/* ( max( ulp*norm(ca A-w D), SMIN )*norm(X) ) */
+
+/* should be on the order of 1. Here, ulp is the machine precision. */
+/* Also, it is verified that SCALE is less than or equal to 1, and that */
+/* XNORM = infinity-norm(X). */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) REAL */
+/* Value of the largest test ratio. */
+
+/* LMAX (output) INTEGER */
+/* Example number where largest test ratio achieved. */
+
+/* NINFO (output) INTEGER array, dimension (3) */
+/* NINFO(1) = number of examples with INFO less than 0 */
+/* NINFO(2) = number of examples with INFO greater than 0 */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --ninfo;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Get machine parameters */
+
+ eps = slamch_("P");
+ unfl = slamch_("U");
+ smlnum = slamch_("S") / eps;
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Set up test case parameters */
+
+ vsmin[0] = smlnum;
+ vsmin[1] = eps;
+ vsmin[2] = .01f;
+ vsmin[3] = 1.f / eps;
+ vab[0] = sqrt(smlnum);
+ vab[1] = 1.f;
+ vab[2] = sqrt(bignum);
+ vwr[0] = 0.f;
+ vwr[1] = .5f;
+ vwr[2] = 2.f;
+ vwr[3] = 1.f;
+ vwi[0] = smlnum;
+ vwi[1] = eps;
+ vwi[2] = 1.f;
+ vwi[3] = 2.f;
+ vdd[0] = sqrt(smlnum);
+ vdd[1] = 1.f;
+ vdd[2] = 2.f;
+ vdd[3] = sqrt(bignum);
+ vca[0] = 0.f;
+ vca[1] = sqrt(smlnum);
+ vca[2] = eps;
+ vca[3] = .5f;
+ vca[4] = 1.f;
+
+ *knt = 0;
+ ninfo[1] = 0;
+ ninfo[2] = 0;
+ *lmax = 0;
+ *rmax = 0.f;
+
+/* Begin test loop */
+
+ for (id1 = 1; id1 <= 4; ++id1) {
+ d1 = vdd[id1 - 1];
+ for (id2 = 1; id2 <= 4; ++id2) {
+ d2 = vdd[id2 - 1];
+ for (ica = 1; ica <= 5; ++ica) {
+ ca = vca[ica - 1];
+ for (itrans = 0; itrans <= 1; ++itrans) {
+ for (ismin = 1; ismin <= 4; ++ismin) {
+ smin = vsmin[ismin - 1];
+
+ na = 1;
+ nw = 1;
+ for (ia = 1; ia <= 3; ++ia) {
+ a[0] = vab[ia - 1];
+ for (ib = 1; ib <= 3; ++ib) {
+ b[0] = vab[ib - 1];
+ for (iwr = 1; iwr <= 4; ++iwr) {
+ if (d1 == 1.f && d2 == 1.f && ca == 1.f) {
+ wr = vwr[iwr - 1] * a[0];
+ } else {
+ wr = vwr[iwr - 1];
+ }
+ wi = 0.f;
+ slaln2_(<rans[itrans], &na, &nw, &smin,
+ &ca, a, &c__2, &d1, &d2, b, &c__2,
+ &wr, &wi, x, &c__2, &scale, &
+ xnorm, &info);
+ if (info < 0) {
+ ++ninfo[1];
+ }
+ if (info > 0) {
+ ++ninfo[2];
+ }
+ res = (r__1 = (ca * a[0] - wr * d1) * x[0]
+ - scale * b[0], dabs(r__1));
+ if (info == 0) {
+/* Computing MAX */
+ r__2 = eps * (r__1 = (ca * a[0] - wr *
+ d1) * x[0], dabs(r__1));
+ den = dmax(r__2,smlnum);
+ } else {
+/* Computing MAX */
+ r__1 = smin * dabs(x[0]);
+ den = dmax(r__1,smlnum);
+ }
+ res /= den;
+ if (dabs(x[0]) < unfl && dabs(b[0]) <=
+ smlnum * (r__1 = ca * a[0] - wr *
+ d1, dabs(r__1))) {
+ res = 0.f;
+ }
+ if (scale > 1.f) {
+ res += 1.f / eps;
+ }
+ res += (r__1 = xnorm - dabs(x[0]), dabs(
+ r__1)) / dmax(smlnum,xnorm) / eps;
+ if (info != 0 && info != 1) {
+ res += 1.f / eps;
+ }
+ ++(*knt);
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+/* L30: */
+ }
+
+ na = 1;
+ nw = 2;
+ for (ia = 1; ia <= 3; ++ia) {
+ a[0] = vab[ia - 1];
+ for (ib = 1; ib <= 3; ++ib) {
+ b[0] = vab[ib - 1];
+ b[2] = vab[ib - 1] * -.5f;
+ for (iwr = 1; iwr <= 4; ++iwr) {
+ if (d1 == 1.f && d2 == 1.f && ca == 1.f) {
+ wr = vwr[iwr - 1] * a[0];
+ } else {
+ wr = vwr[iwr - 1];
+ }
+ for (iwi = 1; iwi <= 4; ++iwi) {
+ if (d1 == 1.f && d2 == 1.f && ca ==
+ 1.f) {
+ wi = vwi[iwi - 1] * a[0];
+ } else {
+ wi = vwi[iwi - 1];
+ }
+ slaln2_(<rans[itrans], &na, &nw, &
+ smin, &ca, a, &c__2, &d1, &d2,
+ b, &c__2, &wr, &wi, x, &c__2,
+ &scale, &xnorm, &info);
+ if (info < 0) {
+ ++ninfo[1];
+ }
+ if (info > 0) {
+ ++ninfo[2];
+ }
+ res = (r__1 = (ca * a[0] - wr * d1) *
+ x[0] + wi * d1 * x[2] - scale
+ * b[0], dabs(r__1));
+ res += (r__1 = -wi * d1 * x[0] + (ca *
+ a[0] - wr * d1) * x[2] -
+ scale * b[2], dabs(r__1));
+ if (info == 0) {
+/* Computing MAX */
+/* Computing MAX */
+ r__4 = (r__1 = ca * a[0] - wr *
+ d1, dabs(r__1)), r__5 = (
+ r__2 = d1 * wi, dabs(r__2)
+ );
+ r__3 = eps * (dmax(r__4,r__5) * (
+ dabs(x[0]) + dabs(x[2])));
+ den = dmax(r__3,smlnum);
+ } else {
+/* Computing MAX */
+ r__1 = smin * (dabs(x[0]) + dabs(
+ x[2]));
+ den = dmax(r__1,smlnum);
+ }
+ res /= den;
+ if (dabs(x[0]) < unfl && dabs(x[2]) <
+ unfl && dabs(b[0]) <= smlnum *
+ (r__1 = ca * a[0] - wr * d1,
+ dabs(r__1))) {
+ res = 0.f;
+ }
+ if (scale > 1.f) {
+ res += 1.f / eps;
+ }
+ res += (r__1 = xnorm - dabs(x[0]) -
+ dabs(x[2]), dabs(r__1)) /
+ dmax(smlnum,xnorm) / eps;
+ if (info != 0 && info != 1) {
+ res += 1.f / eps;
+ }
+ ++(*knt);
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+ na = 2;
+ nw = 1;
+ for (ia = 1; ia <= 3; ++ia) {
+ a[0] = vab[ia - 1];
+ a[2] = vab[ia - 1] * -3.f;
+ a[1] = vab[ia - 1] * -7.f;
+ a[3] = vab[ia - 1] * 21.f;
+ for (ib = 1; ib <= 3; ++ib) {
+ b[0] = vab[ib - 1];
+ b[1] = vab[ib - 1] * -2.f;
+ for (iwr = 1; iwr <= 4; ++iwr) {
+ if (d1 == 1.f && d2 == 1.f && ca == 1.f) {
+ wr = vwr[iwr - 1] * a[0];
+ } else {
+ wr = vwr[iwr - 1];
+ }
+ wi = 0.f;
+ slaln2_(<rans[itrans], &na, &nw, &smin,
+ &ca, a, &c__2, &d1, &d2, b, &c__2,
+ &wr, &wi, x, &c__2, &scale, &
+ xnorm, &info);
+ if (info < 0) {
+ ++ninfo[1];
+ }
+ if (info > 0) {
+ ++ninfo[2];
+ }
+ if (itrans == 1) {
+ tmp = a[2];
+ a[2] = a[1];
+ a[1] = tmp;
+ }
+ res = (r__1 = (ca * a[0] - wr * d1) * x[0]
+ + ca * a[2] * x[1] - scale * b[0]
+ , dabs(r__1));
+ res += (r__1 = ca * a[1] * x[0] + (ca * a[
+ 3] - wr * d2) * x[1] - scale * b[
+ 1], dabs(r__1));
+ if (info == 0) {
+/* Computing MAX */
+/* Computing MAX */
+ r__6 = (r__1 = ca * a[0] - wr * d1,
+ dabs(r__1)) + (r__2 = ca * a[
+ 2], dabs(r__2)), r__7 = (r__3
+ = ca * a[1], dabs(r__3)) + (
+ r__4 = ca * a[3] - wr * d2,
+ dabs(r__4));
+/* Computing MAX */
+ r__8 = dabs(x[0]), r__9 = dabs(x[1]);
+ r__5 = eps * (dmax(r__6,r__7) * dmax(
+ r__8,r__9));
+ den = dmax(r__5,smlnum);
+ } else {
+/* Computing MAX */
+/* Computing MAX */
+/* Computing MAX */
+ r__8 = (r__1 = ca * a[0] - wr * d1,
+ dabs(r__1)) + (r__2 = ca * a[
+ 2], dabs(r__2)), r__9 = (r__3
+ = ca * a[1], dabs(r__3)) + (
+ r__4 = ca * a[3] - wr * d2,
+ dabs(r__4));
+ r__6 = smin / eps, r__7 = dmax(r__8,
+ r__9);
+/* Computing MAX */
+ r__10 = dabs(x[0]), r__11 = dabs(x[1])
+ ;
+ r__5 = eps * (dmax(r__6,r__7) * dmax(
+ r__10,r__11));
+ den = dmax(r__5,smlnum);
+ }
+ res /= den;
+ if (dabs(x[0]) < unfl && dabs(x[1]) <
+ unfl && dabs(b[0]) + dabs(b[1]) <=
+ smlnum * ((r__1 = ca * a[0] - wr
+ * d1, dabs(r__1)) + (r__2 = ca *
+ a[2], dabs(r__2)) + (r__3 = ca *
+ a[1], dabs(r__3)) + (r__4 = ca *
+ a[3] - wr * d2, dabs(r__4)))) {
+ res = 0.f;
+ }
+ if (scale > 1.f) {
+ res += 1.f / eps;
+ }
+/* Computing MAX */
+ r__2 = dabs(x[0]), r__3 = dabs(x[1]);
+ res += (r__1 = xnorm - dmax(r__2,r__3),
+ dabs(r__1)) / dmax(smlnum,xnorm) /
+ eps;
+ if (info != 0 && info != 1) {
+ res += 1.f / eps;
+ }
+ ++(*knt);
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+
+ na = 2;
+ nw = 2;
+ for (ia = 1; ia <= 3; ++ia) {
+ a[0] = vab[ia - 1] * 2.f;
+ a[2] = vab[ia - 1] * -3.f;
+ a[1] = vab[ia - 1] * -7.f;
+ a[3] = vab[ia - 1] * 21.f;
+ for (ib = 1; ib <= 3; ++ib) {
+ b[0] = vab[ib - 1];
+ b[1] = vab[ib - 1] * -2.f;
+ b[2] = vab[ib - 1] * 4.f;
+ b[3] = vab[ib - 1] * -7.f;
+ for (iwr = 1; iwr <= 4; ++iwr) {
+ if (d1 == 1.f && d2 == 1.f && ca == 1.f) {
+ wr = vwr[iwr - 1] * a[0];
+ } else {
+ wr = vwr[iwr - 1];
+ }
+ for (iwi = 1; iwi <= 4; ++iwi) {
+ if (d1 == 1.f && d2 == 1.f && ca ==
+ 1.f) {
+ wi = vwi[iwi - 1] * a[0];
+ } else {
+ wi = vwi[iwi - 1];
+ }
+ slaln2_(<rans[itrans], &na, &nw, &
+ smin, &ca, a, &c__2, &d1, &d2,
+ b, &c__2, &wr, &wi, x, &c__2,
+ &scale, &xnorm, &info);
+ if (info < 0) {
+ ++ninfo[1];
+ }
+ if (info > 0) {
+ ++ninfo[2];
+ }
+ if (itrans == 1) {
+ tmp = a[2];
+ a[2] = a[1];
+ a[1] = tmp;
+ }
+ res = (r__1 = (ca * a[0] - wr * d1) *
+ x[0] + ca * a[2] * x[1] + wi *
+ d1 * x[2] - scale * b[0],
+ dabs(r__1));
+ res += (r__1 = (ca * a[0] - wr * d1) *
+ x[2] + ca * a[2] * x[3] - wi
+ * d1 * x[0] - scale * b[2],
+ dabs(r__1));
+ res += (r__1 = ca * a[1] * x[0] + (ca
+ * a[3] - wr * d2) * x[1] + wi
+ * d2 * x[3] - scale * b[1],
+ dabs(r__1));
+ res += (r__1 = ca * a[1] * x[2] + (ca
+ * a[3] - wr * d2) * x[3] - wi
+ * d2 * x[1] - scale * b[3],
+ dabs(r__1));
+ if (info == 0) {
+/* Computing MAX */
+/* Computing MAX */
+ r__8 = (r__1 = ca * a[0] - wr *
+ d1, dabs(r__1)) + (r__2 =
+ ca * a[2], dabs(r__2)) + (
+ r__3 = wi * d1, dabs(r__3)
+ ), r__9 = (r__4 = ca * a[
+ 1], dabs(r__4)) + (r__5 =
+ ca * a[3] - wr * d2, dabs(
+ r__5)) + (r__6 = wi * d2,
+ dabs(r__6));
+/* Computing MAX */
+ r__10 = dabs(x[0]) + dabs(x[1]),
+ r__11 = dabs(x[2]) + dabs(
+ x[3]);
+ r__7 = eps * (dmax(r__8,r__9) *
+ dmax(r__10,r__11));
+ den = dmax(r__7,smlnum);
+ } else {
+/* Computing MAX */
+/* Computing MAX */
+/* Computing MAX */
+ r__10 = (r__1 = ca * a[0] - wr *
+ d1, dabs(r__1)) + (r__2 =
+ ca * a[2], dabs(r__2)) + (
+ r__3 = wi * d1, dabs(r__3)
+ ), r__11 = (r__4 = ca * a[
+ 1], dabs(r__4)) + (r__5 =
+ ca * a[3] - wr * d2, dabs(
+ r__5)) + (r__6 = wi * d2,
+ dabs(r__6));
+ r__8 = smin / eps, r__9 = dmax(
+ r__10,r__11);
+/* Computing MAX */
+ r__12 = dabs(x[0]) + dabs(x[1]),
+ r__13 = dabs(x[2]) + dabs(
+ x[3]);
+ r__7 = eps * (dmax(r__8,r__9) *
+ dmax(r__12,r__13));
+ den = dmax(r__7,smlnum);
+ }
+ res /= den;
+ if (dabs(x[0]) < unfl && dabs(x[1]) <
+ unfl && dabs(x[2]) < unfl &&
+ dabs(x[3]) < unfl && dabs(b[0]
+ ) + dabs(b[1]) <= smlnum * ((
+ r__1 = ca * a[0] - wr * d1,
+ dabs(r__1)) + (r__2 = ca * a[
+ 2], dabs(r__2)) + (r__3 = ca *
+ a[1], dabs(r__3)) + (r__4 =
+ ca * a[3] - wr * d2, dabs(
+ r__4)) + (r__5 = wi * d2,
+ dabs(r__5)) + (r__6 = wi * d1,
+ dabs(r__6)))) {
+ res = 0.f;
+ }
+ if (scale > 1.f) {
+ res += 1.f / eps;
+ }
+/* Computing MAX */
+ r__2 = dabs(x[0]) + dabs(x[2]), r__3 =
+ dabs(x[1]) + dabs(x[3]);
+ res += (r__1 = xnorm - dmax(r__2,r__3)
+ , dabs(r__1)) / dmax(smlnum,
+ xnorm) / eps;
+ if (info != 0 && info != 1) {
+ res += 1.f / eps;
+ }
+ ++(*knt);
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+/* L190: */
+ }
+
+ return 0;
+
+/* End of SGET31 */
+
+} /* sget31_ */
diff --git a/TESTING/EIG/sget32.c b/TESTING/EIG/sget32.c
new file mode 100644
index 0000000..d18b25f
--- /dev/null
+++ b/TESTING/EIG/sget32.c
@@ -0,0 +1,450 @@
+/* sget32.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+
+/* Subroutine */ int sget32_(real *rmax, integer *lmax, integer *ninfo,
+ integer *knt)
+{
+ /* Initialized data */
+
+ static integer itval[32] /* was [2][2][8] */ = { 8,4,2,1,4,8,1,2,2,1,8,
+ 4,1,2,4,8,9,4,2,1,4,9,1,2,2,1,9,4,1,2,4,9 };
+
+ /* System generated locals */
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real b[4] /* was [2][2] */, x[4] /* was [2][2] */;
+ integer n1, n2, ib;
+ real tl[4] /* was [2][2] */, tr[4] /* was [2][2] */;
+ integer ib1, ib2, ib3;
+ real den, val[3], eps;
+ integer itl;
+ real res, sgn;
+ integer itr;
+ real tmp;
+ integer info, isgn;
+ real tnrm, xnrm, scale, xnorm;
+ extern /* Subroutine */ int slasy2_(logical *, logical *, integer *,
+ integer *, integer *, real *, integer *, real *, integer *, real *
+, integer *, real *, real *, integer *, real *, integer *),
+ slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ real bignum;
+ integer itranl, itlscl;
+ logical ltranl;
+ integer itranr, itrscl;
+ logical ltranr;
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET32 tests SLASY2, a routine for solving */
+
+/* op(TL)*X + ISGN*X*op(TR) = SCALE*B */
+
+/* where TL is N1 by N1, TR is N2 by N2, and N1,N2 =1 or 2 only. */
+/* X and B are N1 by N2, op() is an optional transpose, an */
+/* ISGN = 1 or -1. SCALE is chosen less than or equal to 1 to */
+/* avoid overflow in X. */
+
+/* The test condition is that the scaled residual */
+
+/* norm( op(TL)*X + ISGN*X*op(TR) = SCALE*B ) */
+/* / ( max( ulp*norm(TL), ulp*norm(TR)) * norm(X), SMLNUM ) */
+
+/* should be on the order of 1. Here, ulp is the machine precision. */
+/* Also, it is verified that SCALE is less than or equal to 1, and */
+/* that XNORM = infinity-norm(X). */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) REAL */
+/* Value of the largest test ratio. */
+
+/* LMAX (output) INTEGER */
+/* Example number where largest test ratio achieved. */
+
+/* NINFO (output) INTEGER */
+/* Number of examples returned with INFO.NE.0. */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Get machine parameters */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S") / eps;
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Set up test case parameters */
+
+ val[0] = sqrt(smlnum);
+ val[1] = 1.f;
+ val[2] = sqrt(bignum);
+
+ *knt = 0;
+ *ninfo = 0;
+ *lmax = 0;
+ *rmax = 0.f;
+
+/* Begin test loop */
+
+ for (itranl = 0; itranl <= 1; ++itranl) {
+ for (itranr = 0; itranr <= 1; ++itranr) {
+ for (isgn = -1; isgn <= 1; isgn += 2) {
+ sgn = (real) isgn;
+ ltranl = itranl == 1;
+ ltranr = itranr == 1;
+
+ n1 = 1;
+ n2 = 1;
+ for (itl = 1; itl <= 3; ++itl) {
+ for (itr = 1; itr <= 3; ++itr) {
+ for (ib = 1; ib <= 3; ++ib) {
+ tl[0] = val[itl - 1];
+ tr[0] = val[itr - 1];
+ b[0] = val[ib - 1];
+ ++(*knt);
+ slasy2_(<ranl, <ranr, &isgn, &n1, &n2, tl, &
+ c__2, tr, &c__2, b, &c__2, &scale, x, &
+ c__2, &xnorm, &info);
+ if (info != 0) {
+ ++(*ninfo);
+ }
+ res = (r__1 = (tl[0] + sgn * tr[0]) * x[0] -
+ scale * b[0], dabs(r__1));
+ if (info == 0) {
+/* Computing MAX */
+ r__1 = eps * ((dabs(tr[0]) + dabs(tl[0])) *
+ dabs(x[0]));
+ den = dmax(r__1,smlnum);
+ } else {
+/* Computing MAX */
+ r__1 = dabs(x[0]);
+ den = smlnum * dmax(r__1,1.f);
+ }
+ res /= den;
+ if (scale > 1.f) {
+ res += 1.f / eps;
+ }
+ res += (r__1 = xnorm - dabs(x[0]), dabs(r__1)) /
+ dmax(smlnum,xnorm) / eps;
+ if (info != 0 && info != 1) {
+ res += 1.f / eps;
+ }
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+/* L30: */
+ }
+
+ n1 = 2;
+ n2 = 1;
+ for (itl = 1; itl <= 8; ++itl) {
+ for (itlscl = 1; itlscl <= 3; ++itlscl) {
+ for (itr = 1; itr <= 3; ++itr) {
+ for (ib1 = 1; ib1 <= 3; ++ib1) {
+ for (ib2 = 1; ib2 <= 3; ++ib2) {
+ b[0] = val[ib1 - 1];
+ b[1] = val[ib2 - 1] * -4.f;
+ tl[0] = itval[((itl << 1) + 1 << 1) - 6] *
+ val[itlscl - 1];
+ tl[1] = itval[((itl << 1) + 1 << 1) - 5] *
+ val[itlscl - 1];
+ tl[2] = itval[((itl << 1) + 2 << 1) - 6] *
+ val[itlscl - 1];
+ tl[3] = itval[((itl << 1) + 2 << 1) - 5] *
+ val[itlscl - 1];
+ tr[0] = val[itr - 1];
+ ++(*knt);
+ slasy2_(<ranl, <ranr, &isgn, &n1, &n2,
+ tl, &c__2, tr, &c__2, b, &c__2, &
+ scale, x, &c__2, &xnorm, &info);
+ if (info != 0) {
+ ++(*ninfo);
+ }
+ if (ltranl) {
+ tmp = tl[2];
+ tl[2] = tl[1];
+ tl[1] = tmp;
+ }
+ res = (r__1 = (tl[0] + sgn * tr[0]) * x[0]
+ + tl[2] * x[1] - scale * b[0],
+ dabs(r__1));
+ res += (r__1 = (tl[3] + sgn * tr[0]) * x[
+ 1] + tl[1] * x[0] - scale * b[1],
+ dabs(r__1));
+ tnrm = dabs(tr[0]) + dabs(tl[0]) + dabs(
+ tl[2]) + dabs(tl[1]) + dabs(tl[3])
+ ;
+/* Computing MAX */
+ r__1 = dabs(x[0]), r__2 = dabs(x[1]);
+ xnrm = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = smlnum, r__2 = smlnum * xnrm, r__1
+ = max(r__1,r__2), r__2 = tnrm *
+ eps * xnrm;
+ den = dmax(r__1,r__2);
+ res /= den;
+ if (scale > 1.f) {
+ res += 1.f / eps;
+ }
+ res += (r__1 = xnorm - xnrm, dabs(r__1)) /
+ dmax(smlnum,xnorm) / eps;
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+
+ n1 = 1;
+ n2 = 2;
+ for (itr = 1; itr <= 8; ++itr) {
+ for (itrscl = 1; itrscl <= 3; ++itrscl) {
+ for (itl = 1; itl <= 3; ++itl) {
+ for (ib1 = 1; ib1 <= 3; ++ib1) {
+ for (ib2 = 1; ib2 <= 3; ++ib2) {
+ b[0] = val[ib1 - 1];
+ b[2] = val[ib2 - 1] * -2.f;
+ tr[0] = itval[((itr << 1) + 1 << 1) - 6] *
+ val[itrscl - 1];
+ tr[1] = itval[((itr << 1) + 1 << 1) - 5] *
+ val[itrscl - 1];
+ tr[2] = itval[((itr << 1) + 2 << 1) - 6] *
+ val[itrscl - 1];
+ tr[3] = itval[((itr << 1) + 2 << 1) - 5] *
+ val[itrscl - 1];
+ tl[0] = val[itl - 1];
+ ++(*knt);
+ slasy2_(<ranl, <ranr, &isgn, &n1, &n2,
+ tl, &c__2, tr, &c__2, b, &c__2, &
+ scale, x, &c__2, &xnorm, &info);
+ if (info != 0) {
+ ++(*ninfo);
+ }
+ if (ltranr) {
+ tmp = tr[2];
+ tr[2] = tr[1];
+ tr[1] = tmp;
+ }
+ tnrm = dabs(tl[0]) + dabs(tr[0]) + dabs(
+ tr[2]) + dabs(tr[3]) + dabs(tr[1])
+ ;
+ xnrm = dabs(x[0]) + dabs(x[2]);
+ res = (r__1 = (tl[0] + sgn * tr[0]) * x[0]
+ + sgn * tr[1] * x[2] - scale * b[
+ 0], dabs(r__1));
+ res += (r__1 = (tl[0] + sgn * tr[3]) * x[
+ 2] + sgn * tr[2] * x[0] - scale *
+ b[2], dabs(r__1));
+/* Computing MAX */
+ r__1 = smlnum, r__2 = smlnum * xnrm, r__1
+ = max(r__1,r__2), r__2 = tnrm *
+ eps * xnrm;
+ den = dmax(r__1,r__2);
+ res /= den;
+ if (scale > 1.f) {
+ res += 1.f / eps;
+ }
+ res += (r__1 = xnorm - xnrm, dabs(r__1)) /
+ dmax(smlnum,xnorm) / eps;
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+
+ n1 = 2;
+ n2 = 2;
+ for (itr = 1; itr <= 8; ++itr) {
+ for (itrscl = 1; itrscl <= 3; ++itrscl) {
+ for (itl = 1; itl <= 8; ++itl) {
+ for (itlscl = 1; itlscl <= 3; ++itlscl) {
+ for (ib1 = 1; ib1 <= 3; ++ib1) {
+ for (ib2 = 1; ib2 <= 3; ++ib2) {
+ for (ib3 = 1; ib3 <= 3; ++ib3) {
+ b[0] = val[ib1 - 1];
+ b[1] = val[ib2 - 1] * -4.f;
+ b[2] = val[ib3 - 1] * -2.f;
+/* Computing MIN */
+ r__1 = val[ib1 - 1], r__2 = val[
+ ib2 - 1], r__1 = min(r__1,
+ r__2), r__2 = val[ib3 - 1]
+ ;
+ b[3] = dmin(r__1,r__2) * 8.f;
+ tr[0] = itval[((itr << 1) + 1 <<
+ 1) - 6] * val[itrscl - 1];
+ tr[1] = itval[((itr << 1) + 1 <<
+ 1) - 5] * val[itrscl - 1];
+ tr[2] = itval[((itr << 1) + 2 <<
+ 1) - 6] * val[itrscl - 1];
+ tr[3] = itval[((itr << 1) + 2 <<
+ 1) - 5] * val[itrscl - 1];
+ tl[0] = itval[((itl << 1) + 1 <<
+ 1) - 6] * val[itlscl - 1];
+ tl[1] = itval[((itl << 1) + 1 <<
+ 1) - 5] * val[itlscl - 1];
+ tl[2] = itval[((itl << 1) + 2 <<
+ 1) - 6] * val[itlscl - 1];
+ tl[3] = itval[((itl << 1) + 2 <<
+ 1) - 5] * val[itlscl - 1];
+ ++(*knt);
+ slasy2_(<ranl, <ranr, &isgn, &
+ n1, &n2, tl, &c__2, tr, &
+ c__2, b, &c__2, &scale, x,
+ &c__2, &xnorm, &info);
+ if (info != 0) {
+ ++(*ninfo);
+ }
+ if (ltranr) {
+ tmp = tr[2];
+ tr[2] = tr[1];
+ tr[1] = tmp;
+ }
+ if (ltranl) {
+ tmp = tl[2];
+ tl[2] = tl[1];
+ tl[1] = tmp;
+ }
+ tnrm = dabs(tr[0]) + dabs(tr[1])
+ + dabs(tr[2]) + dabs(tr[3]
+ ) + dabs(tl[0]) + dabs(tl[
+ 1]) + dabs(tl[2]) + dabs(
+ tl[3]);
+/* Computing MAX */
+ r__1 = dabs(x[0]) + dabs(x[2]),
+ r__2 = dabs(x[1]) + dabs(
+ x[3]);
+ xnrm = dmax(r__1,r__2);
+ res = (r__1 = (tl[0] + sgn * tr[0]
+ ) * x[0] + sgn * tr[1] *
+ x[2] + tl[2] * x[1] -
+ scale * b[0], dabs(r__1));
+ res += (r__1 = tl[0] * x[2] + sgn
+ * tr[2] * x[0] + sgn * tr[
+ 3] * x[2] + tl[2] * x[3]
+ - scale * b[2], dabs(r__1)
+ );
+ res += (r__1 = tl[1] * x[0] + sgn
+ * tr[0] * x[1] + sgn * tr[
+ 1] * x[3] + tl[3] * x[1]
+ - scale * b[1], dabs(r__1)
+ );
+ res += (r__1 = (tl[3] + sgn * tr[
+ 3]) * x[3] + sgn * tr[2] *
+ x[1] + tl[1] * x[2] -
+ scale * b[3], dabs(r__1));
+/* Computing MAX */
+ r__1 = smlnum, r__2 = smlnum *
+ xnrm, r__1 = max(r__1,
+ r__2), r__2 = tnrm * eps *
+ xnrm;
+ den = dmax(r__1,r__2);
+ res /= den;
+ if (scale > 1.f) {
+ res += 1.f / eps;
+ }
+ res += (r__1 = xnorm - xnrm, dabs(
+ r__1)) / dmax(smlnum,
+ xnorm) / eps;
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+/* L190: */
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+/* L220: */
+ }
+/* L230: */
+ }
+
+ return 0;
+
+/* End of SGET32 */
+
+} /* sget32_ */
diff --git a/TESTING/EIG/sget33.c b/TESTING/EIG/sget33.c
new file mode 100644
index 0000000..9ae1f24
--- /dev/null
+++ b/TESTING/EIG/sget33.c
@@ -0,0 +1,227 @@
+/* sget33.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b19 = 1.f;
+
+/* Subroutine */ int sget33_(real *rmax, integer *lmax, integer *ninfo,
+ integer *knt)
+{
+ /* System generated locals */
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double r_sign(real *, real *);
+
+ /* Local variables */
+ real q[4] /* was [2][2] */, t[4] /* was [2][2] */;
+ integer i1, i2, i3, i4, j1, j2, j3;
+ real t1[4] /* was [2][2] */, t2[4] /* was [2][2] */, cs, sn, vm[3];
+ integer im1, im2, im3, im4;
+ real wi1, wi2, wr1, wr2, val[4], eps, res, sum, tnrm;
+ extern /* Subroutine */ int slanv2_(real *, real *, real *, real *, real *
+, real *, real *, real *, real *, real *), slabad_(real *, real *)
+ ;
+ extern doublereal slamch_(char *);
+ real bignum, smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET33 tests SLANV2, a routine for putting 2 by 2 blocks into */
+/* standard form. In other words, it computes a two by two rotation */
+/* [[C,S];[-S,C]] where in */
+
+/* [ C S ][T(1,1) T(1,2)][ C -S ] = [ T11 T12 ] */
+/* [-S C ][T(2,1) T(2,2)][ S C ] [ T21 T22 ] */
+
+/* either */
+/* 1) T21=0 (real eigenvalues), or */
+/* 2) T11=T22 and T21*T12<0 (complex conjugate eigenvalues). */
+/* We also verify that the residual is small. */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) REAL */
+/* Value of the largest test ratio. */
+
+/* LMAX (output) INTEGER */
+/* Example number where largest test ratio achieved. */
+
+/* NINFO (output) INTEGER */
+/* Number of examples returned with INFO .NE. 0. */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Get machine parameters */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S") / eps;
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Set up test case parameters */
+
+ val[0] = 1.f;
+ val[1] = eps * 2.f + 1.f;
+ val[2] = 2.f;
+ val[3] = 2.f - eps * 4.f;
+ vm[0] = smlnum;
+ vm[1] = 1.f;
+ vm[2] = bignum;
+
+ *knt = 0;
+ *ninfo = 0;
+ *lmax = 0;
+ *rmax = 0.f;
+
+/* Begin test loop */
+
+ for (i1 = 1; i1 <= 4; ++i1) {
+ for (i2 = 1; i2 <= 4; ++i2) {
+ for (i3 = 1; i3 <= 4; ++i3) {
+ for (i4 = 1; i4 <= 4; ++i4) {
+ for (im1 = 1; im1 <= 3; ++im1) {
+ for (im2 = 1; im2 <= 3; ++im2) {
+ for (im3 = 1; im3 <= 3; ++im3) {
+ for (im4 = 1; im4 <= 3; ++im4) {
+ t[0] = val[i1 - 1] * vm[im1 - 1];
+ t[2] = val[i2 - 1] * vm[im2 - 1];
+ t[1] = -val[i3 - 1] * vm[im3 - 1];
+ t[3] = val[i4 - 1] * vm[im4 - 1];
+/* Computing MAX */
+ r__1 = dabs(t[0]), r__2 = dabs(t[2]),
+ r__1 = max(r__1,r__2), r__2 =
+ dabs(t[1]), r__1 = max(r__1,r__2),
+ r__2 = dabs(t[3]);
+ tnrm = dmax(r__1,r__2);
+ t1[0] = t[0];
+ t1[2] = t[2];
+ t1[1] = t[1];
+ t1[3] = t[3];
+ q[0] = 1.f;
+ q[2] = 0.f;
+ q[1] = 0.f;
+ q[3] = 1.f;
+
+ slanv2_(t, &t[2], &t[1], &t[3], &wr1, &
+ wi1, &wr2, &wi2, &cs, &sn);
+ for (j1 = 1; j1 <= 2; ++j1) {
+ res = q[j1 - 1] * cs + q[j1 + 1] * sn;
+ q[j1 + 1] = -q[j1 - 1] * sn + q[j1 +
+ 1] * cs;
+ q[j1 - 1] = res;
+/* L10: */
+ }
+
+ res = 0.f;
+/* Computing 2nd power */
+ r__2 = q[0];
+/* Computing 2nd power */
+ r__3 = q[2];
+ res += (r__1 = r__2 * r__2 + r__3 * r__3
+ - 1.f, dabs(r__1)) / eps;
+/* Computing 2nd power */
+ r__2 = q[3];
+/* Computing 2nd power */
+ r__3 = q[1];
+ res += (r__1 = r__2 * r__2 + r__3 * r__3
+ - 1.f, dabs(r__1)) / eps;
+ res += (r__1 = q[0] * q[1] + q[2] * q[3],
+ dabs(r__1)) / eps;
+ for (j1 = 1; j1 <= 2; ++j1) {
+ for (j2 = 1; j2 <= 2; ++j2) {
+ t2[j1 + (j2 << 1) - 3] = 0.f;
+ for (j3 = 1; j3 <= 2; ++j3) {
+ t2[j1 + (j2 << 1) - 3] += t1[j1 + (j3 << 1) - 3] *
+ q[j3 + (j2 << 1) - 3];
+/* L20: */
+ }
+/* L30: */
+ }
+/* L40: */
+ }
+ for (j1 = 1; j1 <= 2; ++j1) {
+ for (j2 = 1; j2 <= 2; ++j2) {
+ sum = t[j1 + (j2 << 1) - 3];
+ for (j3 = 1; j3 <= 2; ++j3) {
+ sum -= q[j3 + (j1 << 1) - 3] * t2[j3 + (j2 << 1) -
+ 3];
+/* L50: */
+ }
+ res += dabs(sum) / eps / tnrm;
+/* L60: */
+ }
+/* L70: */
+ }
+ if (t[1] != 0.f && (t[0] != t[3] ||
+ r_sign(&c_b19, &t[2]) * r_sign(&
+ c_b19, &t[1]) > 0.f)) {
+ res += 1.f / eps;
+ }
+ ++(*knt);
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+ return 0;
+
+/* End of SGET33 */
+
+} /* sget33_ */
diff --git a/TESTING/EIG/sget34.c b/TESTING/EIG/sget34.c
new file mode 100644
index 0000000..159a5bd
--- /dev/null
+++ b/TESTING/EIG/sget34.c
@@ -0,0 +1,459 @@
+/* sget34.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__16 = 16;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c__5 = 5;
+static logical c_true = TRUE_;
+static integer c__2 = 2;
+static integer c__32 = 32;
+static integer c__3 = 3;
+static real c_b64 = 1.f;
+
+/* Subroutine */ int sget34_(real *rmax, integer *lmax, integer *ninfo,
+ integer *knt)
+{
+ /* System generated locals */
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal), r_sign(real *, real *);
+
+ /* Local variables */
+ integer i__, j;
+ real q[16] /* was [4][4] */, t[16] /* was [4][4] */, t1[16] /*
+ was [4][4] */;
+ integer ia, ib, ic;
+ real vm[2];
+ integer ia11, ia12, ia21, ia22, ic11, ic12, ic21, ic22, iam, icm;
+ real val[9], eps, res;
+ integer info;
+ real tnrm, work[32];
+ extern /* Subroutine */ int shst01_(integer *, integer *, integer *, real
+ *, integer *, real *, integer *, real *, integer *, real *,
+ integer *, real *), scopy_(integer *, real *, integer *, real *,
+ integer *), slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int slaexc_(logical *, integer *, real *, integer
+ *, real *, integer *, integer *, integer *, integer *, real *,
+ integer *);
+ real bignum, smlnum, result[2];
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET34 tests SLAEXC, a routine for swapping adjacent blocks (either */
+/* 1 by 1 or 2 by 2) on the diagonal of a matrix in real Schur form. */
+/* Thus, SLAEXC computes an orthogonal matrix Q such that */
+
+/* Q' * [ A B ] * Q = [ C1 B1 ] */
+/* [ 0 C ] [ 0 A1 ] */
+
+/* where C1 is similar to C and A1 is similar to A. Both A and C are */
+/* assumed to be in standard form (equal diagonal entries and */
+/* offdiagonal with differing signs) and A1 and C1 are returned with the */
+/* same properties. */
+
+/* The test code verifies these last last assertions, as well as that */
+/* the residual in the above equation is small. */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) REAL */
+/* Value of the largest test ratio. */
+
+/* LMAX (output) INTEGER */
+/* Example number where largest test ratio achieved. */
+
+/* NINFO (output) INTEGER array, dimension (2) */
+/* NINFO(J) is the number of examples where INFO=J occurred. */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Get machine parameters */
+
+ /* Parameter adjustments */
+ --ninfo;
+
+ /* Function Body */
+ eps = slamch_("P");
+ smlnum = slamch_("S") / eps;
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Set up test case parameters */
+
+ val[0] = 0.f;
+ val[1] = sqrt(smlnum);
+ val[2] = 1.f;
+ val[3] = 2.f;
+ val[4] = sqrt(bignum);
+ val[5] = -sqrt(smlnum);
+ val[6] = -1.f;
+ val[7] = -2.f;
+ val[8] = -sqrt(bignum);
+ vm[0] = 1.f;
+ vm[1] = eps * 2.f + 1.f;
+ scopy_(&c__16, &val[3], &c__0, t, &c__1);
+
+ ninfo[1] = 0;
+ ninfo[2] = 0;
+ *knt = 0;
+ *lmax = 0;
+ *rmax = 0.f;
+
+/* Begin test loop */
+
+ for (ia = 1; ia <= 9; ++ia) {
+ for (iam = 1; iam <= 2; ++iam) {
+ for (ib = 1; ib <= 9; ++ib) {
+ for (ic = 1; ic <= 9; ++ic) {
+ t[0] = val[ia - 1] * vm[iam - 1];
+ t[5] = val[ic - 1];
+ t[4] = val[ib - 1];
+ t[1] = 0.f;
+/* Computing MAX */
+ r__1 = dabs(t[0]), r__2 = dabs(t[5]), r__1 = max(r__1,
+ r__2), r__2 = dabs(t[4]);
+ tnrm = dmax(r__1,r__2);
+ scopy_(&c__16, t, &c__1, t1, &c__1);
+ scopy_(&c__16, val, &c__0, q, &c__1);
+ scopy_(&c__4, &val[2], &c__0, q, &c__5);
+ slaexc_(&c_true, &c__2, t, &c__4, q, &c__4, &c__1, &c__1,
+ &c__1, work, &info);
+ if (info != 0) {
+ ++ninfo[info];
+ }
+ shst01_(&c__2, &c__1, &c__2, t1, &c__4, t, &c__4, q, &
+ c__4, work, &c__32, result);
+ res = result[0] + result[1];
+ if (info != 0) {
+ res += 1.f / eps;
+ }
+ if (t[0] != t1[5]) {
+ res += 1.f / eps;
+ }
+ if (t[5] != t1[0]) {
+ res += 1.f / eps;
+ }
+ if (t[1] != 0.f) {
+ res += 1.f / eps;
+ }
+ ++(*knt);
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+/* L30: */
+ }
+/* L40: */
+ }
+
+ for (ia = 1; ia <= 5; ++ia) {
+ for (iam = 1; iam <= 2; ++iam) {
+ for (ib = 1; ib <= 5; ++ib) {
+ for (ic11 = 1; ic11 <= 5; ++ic11) {
+ for (ic12 = 2; ic12 <= 5; ++ic12) {
+ for (ic21 = 2; ic21 <= 4; ++ic21) {
+ for (ic22 = -1; ic22 <= 1; ic22 += 2) {
+ t[0] = val[ia - 1] * vm[iam - 1];
+ t[4] = val[ib - 1];
+ t[8] = val[ib - 1] * -2.f;
+ t[1] = 0.f;
+ t[5] = val[ic11 - 1];
+ t[9] = val[ic12 - 1];
+ t[2] = 0.f;
+ t[6] = -val[ic21 - 1];
+ t[10] = val[ic11 - 1] * (real) ic22;
+/* Computing MAX */
+ r__1 = dabs(t[0]), r__2 = dabs(t[4]), r__1 =
+ max(r__1,r__2), r__2 = dabs(t[8]),
+ r__1 = max(r__1,r__2), r__2 = dabs(t[
+ 5]), r__1 = max(r__1,r__2), r__2 =
+ dabs(t[9]), r__1 = max(r__1,r__2),
+ r__2 = dabs(t[6]), r__1 = max(r__1,
+ r__2), r__2 = dabs(t[10]);
+ tnrm = dmax(r__1,r__2);
+ scopy_(&c__16, t, &c__1, t1, &c__1);
+ scopy_(&c__16, val, &c__0, q, &c__1);
+ scopy_(&c__4, &val[2], &c__0, q, &c__5);
+ slaexc_(&c_true, &c__3, t, &c__4, q, &c__4, &
+ c__1, &c__1, &c__2, work, &info);
+ if (info != 0) {
+ ++ninfo[info];
+ }
+ shst01_(&c__3, &c__1, &c__3, t1, &c__4, t, &
+ c__4, q, &c__4, work, &c__32, result);
+ res = result[0] + result[1];
+ if (info == 0) {
+ if (t1[0] != t[10]) {
+ res += 1.f / eps;
+ }
+ if (t[2] != 0.f) {
+ res += 1.f / eps;
+ }
+ if (t[6] != 0.f) {
+ res += 1.f / eps;
+ }
+ if (t[1] != 0.f && (t[0] != t[5] ||
+ r_sign(&c_b64, &t[4]) == r_sign(&
+ c_b64, &t[1]))) {
+ res += 1.f / eps;
+ }
+ }
+ ++(*knt);
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+
+ for (ia11 = 1; ia11 <= 5; ++ia11) {
+ for (ia12 = 2; ia12 <= 5; ++ia12) {
+ for (ia21 = 2; ia21 <= 4; ++ia21) {
+ for (ia22 = -1; ia22 <= 1; ia22 += 2) {
+ for (icm = 1; icm <= 2; ++icm) {
+ for (ib = 1; ib <= 5; ++ib) {
+ for (ic = 1; ic <= 5; ++ic) {
+ t[0] = val[ia11 - 1];
+ t[4] = val[ia12 - 1];
+ t[8] = val[ib - 1] * -2.f;
+ t[1] = -val[ia21 - 1];
+ t[5] = val[ia11 - 1] * (real) ia22;
+ t[9] = val[ib - 1];
+ t[2] = 0.f;
+ t[6] = 0.f;
+ t[10] = val[ic - 1] * vm[icm - 1];
+/* Computing MAX */
+ r__1 = dabs(t[0]), r__2 = dabs(t[4]), r__1 =
+ max(r__1,r__2), r__2 = dabs(t[8]),
+ r__1 = max(r__1,r__2), r__2 = dabs(t[
+ 5]), r__1 = max(r__1,r__2), r__2 =
+ dabs(t[9]), r__1 = max(r__1,r__2),
+ r__2 = dabs(t[6]), r__1 = max(r__1,
+ r__2), r__2 = dabs(t[10]);
+ tnrm = dmax(r__1,r__2);
+ scopy_(&c__16, t, &c__1, t1, &c__1);
+ scopy_(&c__16, val, &c__0, q, &c__1);
+ scopy_(&c__4, &val[2], &c__0, q, &c__5);
+ slaexc_(&c_true, &c__3, t, &c__4, q, &c__4, &
+ c__1, &c__2, &c__1, work, &info);
+ if (info != 0) {
+ ++ninfo[info];
+ }
+ shst01_(&c__3, &c__1, &c__3, t1, &c__4, t, &
+ c__4, q, &c__4, work, &c__32, result);
+ res = result[0] + result[1];
+ if (info == 0) {
+ if (t1[10] != t[0]) {
+ res += 1.f / eps;
+ }
+ if (t[1] != 0.f) {
+ res += 1.f / eps;
+ }
+ if (t[2] != 0.f) {
+ res += 1.f / eps;
+ }
+ if (t[6] != 0.f && (t[5] != t[10] ||
+ r_sign(&c_b64, &t[9]) == r_sign(&
+ c_b64, &t[6]))) {
+ res += 1.f / eps;
+ }
+ }
+ ++(*knt);
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+
+ for (ia11 = 1; ia11 <= 5; ++ia11) {
+ for (ia12 = 2; ia12 <= 5; ++ia12) {
+ for (ia21 = 2; ia21 <= 4; ++ia21) {
+ for (ia22 = -1; ia22 <= 1; ia22 += 2) {
+ for (ib = 1; ib <= 5; ++ib) {
+ for (ic11 = 3; ic11 <= 4; ++ic11) {
+ for (ic12 = 3; ic12 <= 4; ++ic12) {
+ for (ic21 = 3; ic21 <= 4; ++ic21) {
+ for (ic22 = -1; ic22 <= 1; ic22 += 2) {
+ for (icm = 5; icm <= 7; ++icm) {
+ iam = 1;
+ t[0] = val[ia11 - 1] * vm[iam - 1]
+ ;
+ t[4] = val[ia12 - 1] * vm[iam - 1]
+ ;
+ t[8] = val[ib - 1] * -2.f;
+ t[12] = val[ib - 1] * .5f;
+ t[1] = -t[4] * val[ia21 - 1];
+ t[5] = val[ia11 - 1] * (real)
+ ia22 * vm[iam - 1];
+ t[9] = val[ib - 1];
+ t[13] = val[ib - 1] * 3.f;
+ t[2] = 0.f;
+ t[6] = 0.f;
+ t[10] = val[ic11 - 1] * (r__1 =
+ val[icm - 1], dabs(r__1));
+ t[14] = val[ic12 - 1] * (r__1 =
+ val[icm - 1], dabs(r__1));
+ t[3] = 0.f;
+ t[7] = 0.f;
+ t[11] = -t[14] * val[ic21 - 1] * (
+ r__1 = val[icm - 1], dabs(
+ r__1));
+ t[15] = val[ic11 - 1] * (real)
+ ic22 * (r__1 = val[icm -
+ 1], dabs(r__1));
+ tnrm = 0.f;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ for (j = 1; j <= 4; ++j) {
+/* Computing MAX */
+ r__2 = tnrm, r__3 = (r__1 = t[i__ + (j << 2) -
+ 5], dabs(r__1));
+ tnrm = dmax(r__2,r__3);
+/* L190: */
+ }
+/* L200: */
+ }
+ scopy_(&c__16, t, &c__1, t1, &
+ c__1);
+ scopy_(&c__16, val, &c__0, q, &
+ c__1);
+ scopy_(&c__4, &val[2], &c__0, q, &
+ c__5);
+ slaexc_(&c_true, &c__4, t, &c__4,
+ q, &c__4, &c__1, &c__2, &
+ c__2, work, &info);
+ if (info != 0) {
+ ++ninfo[info];
+ }
+ shst01_(&c__4, &c__1, &c__4, t1, &
+ c__4, t, &c__4, q, &c__4,
+ work, &c__32, result);
+ res = result[0] + result[1];
+ if (info == 0) {
+ if (t[2] != 0.f) {
+ res += 1.f / eps;
+ }
+ if (t[3] != 0.f) {
+ res += 1.f / eps;
+ }
+ if (t[6] != 0.f) {
+ res += 1.f / eps;
+ }
+ if (t[7] != 0.f) {
+ res += 1.f / eps;
+ }
+ if (t[1] != 0.f && (t[0] != t[5] || r_sign(&c_b64, &
+ t[4]) == r_sign(&c_b64, &t[1]))) {
+ res += 1.f / eps;
+ }
+ if (t[11] != 0.f && (t[10] != t[15] || r_sign(&
+ c_b64, &t[14]) == r_sign(&c_b64, &t[11]))) {
+ res += 1.f / eps;
+ }
+ }
+ ++(*knt);
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L210: */
+ }
+/* L220: */
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+/* L250: */
+ }
+/* L260: */
+ }
+/* L270: */
+ }
+/* L280: */
+ }
+/* L290: */
+ }
+/* L300: */
+ }
+
+ return 0;
+
+/* End of SGET34 */
+
+} /* sget34_ */
diff --git a/TESTING/EIG/sget35.c b/TESTING/EIG/sget35.c
new file mode 100644
index 0000000..887ace5
--- /dev/null
+++ b/TESTING/EIG/sget35.c
@@ -0,0 +1,285 @@
+/* sget35.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__6 = 6;
+static real c_b35 = 1.f;
+
+/* Subroutine */ int sget35_(real *rmax, integer *lmax, integer *ninfo,
+ integer *knt)
+{
+ /* Initialized data */
+
+ static integer idim[8] = { 1,2,3,4,3,3,6,4 };
+ static integer ival[288] /* was [6][6][8] */ = { 1,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,0,0,0,0,-2,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,
+ 0,0,5,1,2,0,0,0,-8,-2,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 3,4,0,0,0,0,-5,3,0,0,0,0,1,2,1,4,0,0,-3,-9,-1,1,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,1,0,0,0,0,0,2,3,0,0,0,0,5,6,7,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,1,0,0,0,0,0,1,3,-4,0,0,0,2,5,2,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,1,2,0,0,0,0,-2,0,0,0,0,0,5,6,3,4,0,0,-1,
+ -9,-5,2,0,0,8,8,8,8,5,6,9,9,9,9,-7,5,1,0,0,0,0,0,1,5,2,0,0,0,2,
+ -21,5,0,0,0,1,2,3,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0 };
+
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal), sin(doublereal);
+
+ /* Local variables */
+ real a[36] /* was [6][6] */, b[36] /* was [6][6] */, c__[36] /*
+ was [6][6] */;
+ integer i__, j, m, n;
+ real cc[36] /* was [6][6] */, vm1[3], vm2[3];
+ integer ima, imb;
+ real dum[1], eps, res, res1;
+ integer info;
+ real cnrm;
+ integer isgn;
+ real rmul, tnrm, xnrm, scale;
+ char trana[1], tranb[1];
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ integer imlda1, imlda2, imldb1;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ integer imloff, itrana, itranb;
+ real bignum, smlnum;
+ extern /* Subroutine */ int strsyl_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET35 tests STRSYL, a routine for solving the Sylvester matrix */
+/* equation */
+
+/* op(A)*X + ISGN*X*op(B) = scale*C, */
+
+/* A and B are assumed to be in Schur canonical form, op() represents an */
+/* optional transpose, and ISGN can be -1 or +1. Scale is an output */
+/* less than or equal to 1, chosen to avoid overflow in X. */
+
+/* The test code verifies that the following residual is order 1: */
+
+/* norm(op(A)*X + ISGN*X*op(B) - scale*C) / */
+/* (EPS*max(norm(A),norm(B))*norm(X)) */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) REAL */
+/* Value of the largest test ratio. */
+
+/* LMAX (output) INTEGER */
+/* Example number where largest test ratio achieved. */
+
+/* NINFO (output) INTEGER */
+/* Number of examples where INFO is nonzero. */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Get machine parameters */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S") * 4.f / eps;
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Set up test case parameters */
+
+ vm1[0] = sqrt(smlnum);
+ vm1[1] = 1.f;
+ vm1[2] = sqrt(bignum);
+ vm2[0] = 1.f;
+ vm2[1] = eps * 2.f + 1.f;
+ vm2[2] = 2.f;
+
+ *knt = 0;
+ *ninfo = 0;
+ *lmax = 0;
+ *rmax = 0.f;
+
+/* Begin test loop */
+
+ for (itrana = 1; itrana <= 2; ++itrana) {
+ for (itranb = 1; itranb <= 2; ++itranb) {
+ for (isgn = -1; isgn <= 1; isgn += 2) {
+ for (ima = 1; ima <= 8; ++ima) {
+ for (imlda1 = 1; imlda1 <= 3; ++imlda1) {
+ for (imlda2 = 1; imlda2 <= 3; ++imlda2) {
+ for (imloff = 1; imloff <= 2; ++imloff) {
+ for (imb = 1; imb <= 8; ++imb) {
+ for (imldb1 = 1; imldb1 <= 3; ++imldb1) {
+ if (itrana == 1) {
+ *(unsigned char *)trana = 'N';
+ }
+ if (itrana == 2) {
+ *(unsigned char *)trana = 'T';
+ }
+ if (itranb == 1) {
+ *(unsigned char *)tranb = 'N';
+ }
+ if (itranb == 2) {
+ *(unsigned char *)tranb = 'T';
+ }
+ m = idim[ima - 1];
+ n = idim[imb - 1];
+ tnrm = 0.f;
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = m;
+ for (j = 1; j <= i__2; ++j) {
+ a[i__ + j * 6 - 7] = (real) ival[i__ + (j + ima * 6)
+ * 6 - 43];
+ if ((i__3 = i__ - j, abs(i__3)) <= 1) {
+ a[i__ + j * 6 - 7] *= vm1[imlda1 - 1];
+ a[i__ + j * 6 - 7] *= vm2[imlda2 - 1];
+ } else {
+ a[i__ + j * 6 - 7] *= vm1[imloff - 1];
+ }
+/* Computing MAX */
+ r__2 = tnrm, r__3 = (r__1 = a[i__ + j * 6 - 7],
+ dabs(r__1));
+ tnrm = dmax(r__2,r__3);
+/* L10: */
+ }
+/* L20: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ b[i__ + j * 6 - 7] = (real) ival[i__ + (j + imb * 6)
+ * 6 - 43];
+ if ((i__3 = i__ - j, abs(i__3)) <= 1) {
+ b[i__ + j * 6 - 7] *= vm1[imldb1 - 1];
+ } else {
+ b[i__ + j * 6 - 7] *= vm1[imloff - 1];
+ }
+/* Computing MAX */
+ r__2 = tnrm, r__3 = (r__1 = b[i__ + j * 6 - 7],
+ dabs(r__1));
+ tnrm = dmax(r__2,r__3);
+/* L30: */
+ }
+/* L40: */
+ }
+ cnrm = 0.f;
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ c__[i__ + j * 6 - 7] = sin((real) (i__ * j));
+/* Computing MAX */
+ r__1 = cnrm, r__2 = c__[i__ + j * 6 - 7];
+ cnrm = dmax(r__1,r__2);
+ cc[i__ + j * 6 - 7] = c__[i__ + j * 6 - 7];
+/* L50: */
+ }
+/* L60: */
+ }
+ ++(*knt);
+ strsyl_(trana, tranb, &isgn, &m, &n,
+ a, &c__6, b, &c__6, c__, &
+ c__6, &scale, &info);
+ if (info != 0) {
+ ++(*ninfo);
+ }
+ xnrm = slange_("M", &m, &n, c__, &
+ c__6, dum);
+ rmul = 1.f;
+ if (xnrm > 1.f && tnrm > 1.f) {
+ if (xnrm > bignum / tnrm) {
+ rmul = 1.f / dmax(xnrm,tnrm);
+ }
+ }
+ r__1 = -scale * rmul;
+ sgemm_(trana, "N", &m, &n, &m, &rmul,
+ a, &c__6, c__, &c__6, &r__1,
+ cc, &c__6);
+ r__1 = (real) isgn * rmul;
+ sgemm_("N", tranb, &m, &n, &n, &r__1,
+ c__, &c__6, b, &c__6, &c_b35,
+ cc, &c__6);
+ res1 = slange_("M", &m, &n, cc, &c__6,
+ dum);
+/* Computing MAX */
+ r__1 = smlnum, r__2 = smlnum * xnrm,
+ r__1 = max(r__1,r__2), r__2 =
+ rmul * tnrm * eps * xnrm;
+ res = res1 / dmax(r__1,r__2);
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+ return 0;
+
+/* End of SGET35 */
+
+} /* sget35_ */
diff --git a/TESTING/EIG/sget36.c b/TESTING/EIG/sget36.c
new file mode 100644
index 0000000..c4d8cb9
--- /dev/null
+++ b/TESTING/EIG/sget36.c
@@ -0,0 +1,288 @@
+/* sget36.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c__10 = 10;
+static real c_b21 = 0.f;
+static real c_b22 = 1.f;
+static integer c__200 = 200;
+
+/* Subroutine */ int sget36_(real *rmax, integer *lmax, integer *ninfo,
+ integer *knt, integer *nin)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+ double r_sign(real *, real *);
+
+ /* Local variables */
+ integer i__, j, n;
+ real q[100] /* was [10][10] */, t1[100] /* was [10][10] */, t2[100]
+ /* was [10][10] */;
+ integer loc;
+ real eps, res, tmp[100] /* was [10][10] */;
+ integer ifst, ilst;
+ real work[200];
+ integer info1, info2, ifst1, ifst2, ilst1, ilst2;
+ extern /* Subroutine */ int shst01_(integer *, integer *, integer *, real
+ *, integer *, real *, integer *, real *, integer *, real *,
+ integer *, real *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *), strexc_(
+ char *, integer *, real *, integer *, real *, integer *, integer *
+, integer *, real *, integer *);
+ integer ifstsv;
+ real result[2];
+ integer ilstsv;
+
+ /* Fortran I/O blocks */
+ static cilist io___2 = { 0, 0, 0, 0, 0 };
+ static cilist io___7 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET36 tests STREXC, a routine for moving blocks (either 1 by 1 or */
+/* 2 by 2) on the diagonal of a matrix in real Schur form. Thus, SLAEXC */
+/* computes an orthogonal matrix Q such that */
+
+/* Q' * T1 * Q = T2 */
+
+/* and where one of the diagonal blocks of T1 (the one at row IFST) has */
+/* been moved to position ILST. */
+
+/* The test code verifies that the residual Q'*T1*Q-T2 is small, that T2 */
+/* is in Schur form, and that the final position of the IFST block is */
+/* ILST (within +-1). */
+
+/* The test matrices are read from a file with logical unit number NIN. */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) REAL */
+/* Value of the largest test ratio. */
+
+/* LMAX (output) INTEGER */
+/* Example number where largest test ratio achieved. */
+
+/* NINFO (output) INTEGER array, dimension (3) */
+/* NINFO(J) is the number of examples where INFO=J. */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* NIN (input) INTEGER */
+/* Input logical unit number. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ninfo;
+
+ /* Function Body */
+ eps = slamch_("P");
+ *rmax = 0.f;
+ *lmax = 0;
+ *knt = 0;
+ ninfo[1] = 0;
+ ninfo[2] = 0;
+ ninfo[3] = 0;
+
+/* Read input data until N=0 */
+
+L10:
+ io___2.ciunit = *nin;
+ s_rsle(&io___2);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ifst, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ilst, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ return 0;
+ }
+ ++(*knt);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___7.ciunit = *nin;
+ s_rsle(&io___7);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__4, &c__1, (char *)&tmp[i__ + j * 10 - 11], (ftnlen)
+ sizeof(real));
+ }
+ e_rsle();
+/* L20: */
+ }
+ slacpy_("F", &n, &n, tmp, &c__10, t1, &c__10);
+ slacpy_("F", &n, &n, tmp, &c__10, t2, &c__10);
+ ifstsv = ifst;
+ ilstsv = ilst;
+ ifst1 = ifst;
+ ilst1 = ilst;
+ ifst2 = ifst;
+ ilst2 = ilst;
+ res = 0.f;
+
+/* Test without accumulating Q */
+
+ slaset_("Full", &n, &n, &c_b21, &c_b22, q, &c__10);
+ strexc_("N", &n, t1, &c__10, q, &c__10, &ifst1, &ilst1, work, &info1);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ if (i__ == j && q[i__ + j * 10 - 11] != 1.f) {
+ res += 1.f / eps;
+ }
+ if (i__ != j && q[i__ + j * 10 - 11] != 0.f) {
+ res += 1.f / eps;
+ }
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Test with accumulating Q */
+
+ slaset_("Full", &n, &n, &c_b21, &c_b22, q, &c__10);
+ strexc_("V", &n, t2, &c__10, q, &c__10, &ifst2, &ilst2, work, &info2);
+
+/* Compare T1 with T2 */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ if (t1[i__ + j * 10 - 11] != t2[i__ + j * 10 - 11]) {
+ res += 1.f / eps;
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+ if (ifst1 != ifst2) {
+ res += 1.f / eps;
+ }
+ if (ilst1 != ilst2) {
+ res += 1.f / eps;
+ }
+ if (info1 != info2) {
+ res += 1.f / eps;
+ }
+
+/* Test for successful reordering of T2 */
+
+ if (info2 != 0) {
+ ++ninfo[info2];
+ } else {
+ if ((i__1 = ifst2 - ifstsv, abs(i__1)) > 1) {
+ res += 1.f / eps;
+ }
+ if ((i__1 = ilst2 - ilstsv, abs(i__1)) > 1) {
+ res += 1.f / eps;
+ }
+ }
+
+/* Test for small residual, and orthogonality of Q */
+
+ shst01_(&n, &c__1, &n, tmp, &c__10, t2, &c__10, q, &c__10, work, &c__200,
+ result);
+ res = res + result[0] + result[1];
+
+/* Test for T2 being in Schur form */
+
+ loc = 1;
+L70:
+ if (t2[loc + 1 + loc * 10 - 11] != 0.f) {
+
+/* 2 by 2 block */
+
+ if (t2[loc + (loc + 1) * 10 - 11] == 0.f || t2[loc + loc * 10 - 11] !=
+ t2[loc + 1 + (loc + 1) * 10 - 11] || r_sign(&c_b22, &t2[loc
+ + (loc + 1) * 10 - 11]) == r_sign(&c_b22, &t2[loc + 1 + loc *
+ 10 - 11])) {
+ res += 1.f / eps;
+ }
+ i__1 = n;
+ for (i__ = loc + 2; i__ <= i__1; ++i__) {
+ if (t2[i__ + loc * 10 - 11] != 0.f) {
+ res += 1.f / res;
+ }
+ if (t2[i__ + (loc + 1) * 10 - 11] != 0.f) {
+ res += 1.f / res;
+ }
+/* L80: */
+ }
+ loc += 2;
+ } else {
+
+/* 1 by 1 block */
+
+ i__1 = n;
+ for (i__ = loc + 1; i__ <= i__1; ++i__) {
+ if (t2[i__ + loc * 10 - 11] != 0.f) {
+ res += 1.f / res;
+ }
+/* L90: */
+ }
+ ++loc;
+ }
+ if (loc < n) {
+ goto L70;
+ }
+ if (res > *rmax) {
+ *rmax = res;
+ *lmax = *knt;
+ }
+ goto L10;
+
+/* End of SGET36 */
+
+} /* sget36_ */
diff --git a/TESTING/EIG/sget37.c b/TESTING/EIG/sget37.c
new file mode 100644
index 0000000..cc529a6
--- /dev/null
+++ b/TESTING/EIG/sget37.c
@@ -0,0 +1,703 @@
+/* sget37.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c__20 = 20;
+static integer c__1200 = 1200;
+static integer c__0 = 0;
+
+/* Subroutine */ int sget37_(real *rmax, integer *lmax, integer *ninfo,
+ integer *knt, integer *nin)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+
+ /* Local variables */
+ integer i__, j, m, n;
+ real s[20], t[400] /* was [20][20] */, v, le[400] /* was [20][20] */,
+ re[400] /* was [20][20] */, wi[20], wr[20], val[3], dum[1],
+ eps, sep[20], sin__[20], tol, tmp[400] /* was [20][20] */;
+ integer ifnd, icmp, iscl, info, lcmp[3], kmin;
+ real wiin[20], vmax, tnrm, wrin[20], work[1200], vmul, stmp[20];
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real sepin[20], vimin, tolin, vrmin;
+ integer iwork[40];
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ real witmp[20], wrtmp[20];
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *);
+ logical select[20];
+ real bignum;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), shseqr_(char *, char *,
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, real *, integer *, real *, integer *, integer *)
+ , strevc_(char *, char *, logical *, integer *, real *, integer *,
+ real *, integer *, real *, integer *, integer *, integer *, real
+ *, integer *);
+ real septmp[20];
+ extern /* Subroutine */ int strsna_(char *, char *, logical *, integer *,
+ real *, integer *, real *, integer *, real *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *,
+ integer *);
+ real smlnum;
+
+ /* Fortran I/O blocks */
+ static cilist io___5 = { 0, 0, 0, 0, 0 };
+ static cilist io___8 = { 0, 0, 0, 0, 0 };
+ static cilist io___11 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET37 tests STRSNA, a routine for estimating condition numbers of */
+/* eigenvalues and/or right eigenvectors of a matrix. */
+
+/* The test matrices are read from a file with logical unit number NIN. */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) REAL array, dimension (3) */
+/* Value of the largest test ratio. */
+/* RMAX(1) = largest ratio comparing different calls to STRSNA */
+/* RMAX(2) = largest error in reciprocal condition */
+/* numbers taking their conditioning into account */
+/* RMAX(3) = largest error in reciprocal condition */
+/* numbers not taking their conditioning into */
+/* account (may be larger than RMAX(2)) */
+
+/* LMAX (output) INTEGER array, dimension (3) */
+/* LMAX(i) is example number where largest test ratio */
+/* RMAX(i) is achieved. Also: */
+/* If SGEHRD returns INFO nonzero on example i, LMAX(1)=i */
+/* If SHSEQR returns INFO nonzero on example i, LMAX(2)=i */
+/* If STRSNA returns INFO nonzero on example i, LMAX(3)=i */
+
+/* NINFO (output) INTEGER array, dimension (3) */
+/* NINFO(1) = No. of times SGEHRD returned INFO nonzero */
+/* NINFO(2) = No. of times SHSEQR returned INFO nonzero */
+/* NINFO(3) = No. of times STRSNA returned INFO nonzero */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* NIN (input) INTEGER */
+/* Input logical unit number */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ninfo;
+ --lmax;
+ --rmax;
+
+ /* Function Body */
+ eps = slamch_("P");
+ smlnum = slamch_("S") / eps;
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* EPSIN = 2**(-24) = precision to which input data computed */
+
+ eps = dmax(eps,5.9605e-8f);
+ rmax[1] = 0.f;
+ rmax[2] = 0.f;
+ rmax[3] = 0.f;
+ lmax[1] = 0;
+ lmax[2] = 0;
+ lmax[3] = 0;
+ *knt = 0;
+ ninfo[1] = 0;
+ ninfo[2] = 0;
+ ninfo[3] = 0;
+
+ val[0] = sqrt(smlnum);
+ val[1] = 1.f;
+ val[2] = sqrt(bignum);
+
+/* Read input data until N=0. Assume input eigenvalues are sorted */
+/* lexicographically (increasing by real part, then decreasing by */
+/* imaginary part) */
+
+L10:
+ io___5.ciunit = *nin;
+ s_rsle(&io___5);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ return 0;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___8.ciunit = *nin;
+ s_rsle(&io___8);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__4, &c__1, (char *)&tmp[i__ + j * 20 - 21], (ftnlen)
+ sizeof(real));
+ }
+ e_rsle();
+/* L20: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___11.ciunit = *nin;
+ s_rsle(&io___11);
+ do_lio(&c__4, &c__1, (char *)&wrin[i__ - 1], (ftnlen)sizeof(real));
+ do_lio(&c__4, &c__1, (char *)&wiin[i__ - 1], (ftnlen)sizeof(real));
+ do_lio(&c__4, &c__1, (char *)&sin__[i__ - 1], (ftnlen)sizeof(real));
+ do_lio(&c__4, &c__1, (char *)&sepin[i__ - 1], (ftnlen)sizeof(real));
+ e_rsle();
+/* L30: */
+ }
+ tnrm = slange_("M", &n, &n, tmp, &c__20, work);
+
+/* Begin test */
+
+ for (iscl = 1; iscl <= 3; ++iscl) {
+
+/* Scale input matrix */
+
+ ++(*knt);
+ slacpy_("F", &n, &n, tmp, &c__20, t, &c__20);
+ vmul = val[iscl - 1];
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sscal_(&n, &vmul, &t[i__ * 20 - 20], &c__1);
+/* L40: */
+ }
+ if (tnrm == 0.f) {
+ vmul = 1.f;
+ }
+
+/* Compute eigenvalues and eigenvectors */
+
+ i__1 = 1200 - n;
+ sgehrd_(&n, &c__1, &n, t, &c__20, work, &work[n], &i__1, &info);
+ if (info != 0) {
+ lmax[1] = *knt;
+ ++ninfo[1];
+ goto L240;
+ }
+ i__1 = n - 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = n;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+ t[i__ + j * 20 - 21] = 0.f;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* Compute Schur form */
+
+ shseqr_("S", "N", &n, &c__1, &n, t, &c__20, wr, wi, dum, &c__1, work,
+ &c__1200, &info);
+ if (info != 0) {
+ lmax[2] = *knt;
+ ++ninfo[2];
+ goto L240;
+ }
+
+/* Compute eigenvectors */
+
+ strevc_("Both", "All", select, &n, t, &c__20, le, &c__20, re, &c__20,
+ &n, &m, work, &info);
+
+/* Compute condition numbers */
+
+ strsna_("Both", "All", select, &n, t, &c__20, le, &c__20, re, &c__20,
+ s, sep, &n, &m, work, &n, iwork, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L240;
+ }
+
+/* Sort eigenvalues and condition numbers lexicographically */
+/* to compare with inputs */
+
+ scopy_(&n, wr, &c__1, wrtmp, &c__1);
+ scopy_(&n, wi, &c__1, witmp, &c__1);
+ scopy_(&n, s, &c__1, stmp, &c__1);
+ scopy_(&n, sep, &c__1, septmp, &c__1);
+ r__1 = 1.f / vmul;
+ sscal_(&n, &r__1, septmp, &c__1);
+ i__1 = n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ kmin = i__;
+ vrmin = wrtmp[i__ - 1];
+ vimin = witmp[i__ - 1];
+ i__2 = n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (wrtmp[j - 1] < vrmin) {
+ kmin = j;
+ vrmin = wrtmp[j - 1];
+ vimin = witmp[j - 1];
+ }
+/* L70: */
+ }
+ wrtmp[kmin - 1] = wrtmp[i__ - 1];
+ witmp[kmin - 1] = witmp[i__ - 1];
+ wrtmp[i__ - 1] = vrmin;
+ witmp[i__ - 1] = vimin;
+ vrmin = stmp[kmin - 1];
+ stmp[kmin - 1] = stmp[i__ - 1];
+ stmp[i__ - 1] = vrmin;
+ vrmin = septmp[kmin - 1];
+ septmp[kmin - 1] = septmp[i__ - 1];
+ septmp[i__ - 1] = vrmin;
+/* L80: */
+ }
+
+/* Compare condition numbers for eigenvalues */
+/* taking their condition numbers into account */
+
+/* Computing MAX */
+ r__1 = (real) n * 2.f * eps * tnrm;
+ v = dmax(r__1,smlnum);
+ if (tnrm == 0.f) {
+ v = 1.f;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (v > septmp[i__ - 1]) {
+ tol = 1.f;
+ } else {
+ tol = v / septmp[i__ - 1];
+ }
+ if (v > sepin[i__ - 1]) {
+ tolin = 1.f;
+ } else {
+ tolin = v / sepin[i__ - 1];
+ }
+/* Computing MAX */
+ r__1 = tol, r__2 = smlnum / eps;
+ tol = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = tolin, r__2 = smlnum / eps;
+ tolin = dmax(r__1,r__2);
+ if (eps * (sin__[i__ - 1] - tolin) > stmp[i__ - 1] + tol) {
+ vmax = 1.f / eps;
+ } else if (sin__[i__ - 1] - tolin > stmp[i__ - 1] + tol) {
+ vmax = (sin__[i__ - 1] - tolin) / (stmp[i__ - 1] + tol);
+ } else if (sin__[i__ - 1] + tolin < eps * (stmp[i__ - 1] - tol)) {
+ vmax = 1.f / eps;
+ } else if (sin__[i__ - 1] + tolin < stmp[i__ - 1] - tol) {
+ vmax = (stmp[i__ - 1] - tol) / (sin__[i__ - 1] + tolin);
+ } else {
+ vmax = 1.f;
+ }
+ if (vmax > rmax[2]) {
+ rmax[2] = vmax;
+ if (ninfo[2] == 0) {
+ lmax[2] = *knt;
+ }
+ }
+/* L90: */
+ }
+
+/* Compare condition numbers for eigenvectors */
+/* taking their condition numbers into account */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (v > septmp[i__ - 1] * stmp[i__ - 1]) {
+ tol = septmp[i__ - 1];
+ } else {
+ tol = v / stmp[i__ - 1];
+ }
+ if (v > sepin[i__ - 1] * sin__[i__ - 1]) {
+ tolin = sepin[i__ - 1];
+ } else {
+ tolin = v / sin__[i__ - 1];
+ }
+/* Computing MAX */
+ r__1 = tol, r__2 = smlnum / eps;
+ tol = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = tolin, r__2 = smlnum / eps;
+ tolin = dmax(r__1,r__2);
+ if (eps * (sepin[i__ - 1] - tolin) > septmp[i__ - 1] + tol) {
+ vmax = 1.f / eps;
+ } else if (sepin[i__ - 1] - tolin > septmp[i__ - 1] + tol) {
+ vmax = (sepin[i__ - 1] - tolin) / (septmp[i__ - 1] + tol);
+ } else if (sepin[i__ - 1] + tolin < eps * (septmp[i__ - 1] - tol))
+ {
+ vmax = 1.f / eps;
+ } else if (sepin[i__ - 1] + tolin < septmp[i__ - 1] - tol) {
+ vmax = (septmp[i__ - 1] - tol) / (sepin[i__ - 1] + tolin);
+ } else {
+ vmax = 1.f;
+ }
+ if (vmax > rmax[2]) {
+ rmax[2] = vmax;
+ if (ninfo[2] == 0) {
+ lmax[2] = *knt;
+ }
+ }
+/* L100: */
+ }
+
+/* Compare condition numbers for eigenvalues */
+/* without taking their condition numbers into account */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (sin__[i__ - 1] <= (real) (n << 1) * eps && stmp[i__ - 1] <= (
+ real) (n << 1) * eps) {
+ vmax = 1.f;
+ } else if (eps * sin__[i__ - 1] > stmp[i__ - 1]) {
+ vmax = 1.f / eps;
+ } else if (sin__[i__ - 1] > stmp[i__ - 1]) {
+ vmax = sin__[i__ - 1] / stmp[i__ - 1];
+ } else if (sin__[i__ - 1] < eps * stmp[i__ - 1]) {
+ vmax = 1.f / eps;
+ } else if (sin__[i__ - 1] < stmp[i__ - 1]) {
+ vmax = stmp[i__ - 1] / sin__[i__ - 1];
+ } else {
+ vmax = 1.f;
+ }
+ if (vmax > rmax[3]) {
+ rmax[3] = vmax;
+ if (ninfo[3] == 0) {
+ lmax[3] = *knt;
+ }
+ }
+/* L110: */
+ }
+
+/* Compare condition numbers for eigenvectors */
+/* without taking their condition numbers into account */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (sepin[i__ - 1] <= v && septmp[i__ - 1] <= v) {
+ vmax = 1.f;
+ } else if (eps * sepin[i__ - 1] > septmp[i__ - 1]) {
+ vmax = 1.f / eps;
+ } else if (sepin[i__ - 1] > septmp[i__ - 1]) {
+ vmax = sepin[i__ - 1] / septmp[i__ - 1];
+ } else if (sepin[i__ - 1] < eps * septmp[i__ - 1]) {
+ vmax = 1.f / eps;
+ } else if (sepin[i__ - 1] < septmp[i__ - 1]) {
+ vmax = septmp[i__ - 1] / sepin[i__ - 1];
+ } else {
+ vmax = 1.f;
+ }
+ if (vmax > rmax[3]) {
+ rmax[3] = vmax;
+ if (ninfo[3] == 0) {
+ lmax[3] = *knt;
+ }
+ }
+/* L120: */
+ }
+
+/* Compute eigenvalue condition numbers only and compare */
+
+ vmax = 0.f;
+ dum[0] = -1.f;
+ scopy_(&n, dum, &c__0, stmp, &c__1);
+ scopy_(&n, dum, &c__0, septmp, &c__1);
+ strsna_("Eigcond", "All", select, &n, t, &c__20, le, &c__20, re, &
+ c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L240;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (stmp[i__ - 1] != s[i__ - 1]) {
+ vmax = 1.f / eps;
+ }
+ if (septmp[i__ - 1] != dum[0]) {
+ vmax = 1.f / eps;
+ }
+/* L130: */
+ }
+
+/* Compute eigenvector condition numbers only and compare */
+
+ scopy_(&n, dum, &c__0, stmp, &c__1);
+ scopy_(&n, dum, &c__0, septmp, &c__1);
+ strsna_("Veccond", "All", select, &n, t, &c__20, le, &c__20, re, &
+ c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L240;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (stmp[i__ - 1] != dum[0]) {
+ vmax = 1.f / eps;
+ }
+ if (septmp[i__ - 1] != sep[i__ - 1]) {
+ vmax = 1.f / eps;
+ }
+/* L140: */
+ }
+
+/* Compute all condition numbers using SELECT and compare */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ select[i__ - 1] = TRUE_;
+/* L150: */
+ }
+ scopy_(&n, dum, &c__0, stmp, &c__1);
+ scopy_(&n, dum, &c__0, septmp, &c__1);
+ strsna_("Bothcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
+ c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L240;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (septmp[i__ - 1] != sep[i__ - 1]) {
+ vmax = 1.f / eps;
+ }
+ if (stmp[i__ - 1] != s[i__ - 1]) {
+ vmax = 1.f / eps;
+ }
+/* L160: */
+ }
+
+/* Compute eigenvalue condition numbers using SELECT and compare */
+
+ scopy_(&n, dum, &c__0, stmp, &c__1);
+ scopy_(&n, dum, &c__0, septmp, &c__1);
+ strsna_("Eigcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
+ c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L240;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (stmp[i__ - 1] != s[i__ - 1]) {
+ vmax = 1.f / eps;
+ }
+ if (septmp[i__ - 1] != dum[0]) {
+ vmax = 1.f / eps;
+ }
+/* L170: */
+ }
+
+/* Compute eigenvector condition numbers using SELECT and compare */
+
+ scopy_(&n, dum, &c__0, stmp, &c__1);
+ scopy_(&n, dum, &c__0, septmp, &c__1);
+ strsna_("Veccond", "Some", select, &n, t, &c__20, le, &c__20, re, &
+ c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L240;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (stmp[i__ - 1] != dum[0]) {
+ vmax = 1.f / eps;
+ }
+ if (septmp[i__ - 1] != sep[i__ - 1]) {
+ vmax = 1.f / eps;
+ }
+/* L180: */
+ }
+ if (vmax > rmax[1]) {
+ rmax[1] = vmax;
+ if (ninfo[1] == 0) {
+ lmax[1] = *knt;
+ }
+ }
+
+/* Select first real and first complex eigenvalue */
+
+ if (wi[0] == 0.f) {
+ lcmp[0] = 1;
+ ifnd = 0;
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ if (ifnd == 1 || wi[i__ - 1] == 0.f) {
+ select[i__ - 1] = FALSE_;
+ } else {
+ ifnd = 1;
+ lcmp[1] = i__;
+ lcmp[2] = i__ + 1;
+ scopy_(&n, &re[i__ * 20 - 20], &c__1, &re[20], &c__1);
+ scopy_(&n, &re[(i__ + 1) * 20 - 20], &c__1, &re[40], &
+ c__1);
+ scopy_(&n, &le[i__ * 20 - 20], &c__1, &le[20], &c__1);
+ scopy_(&n, &le[(i__ + 1) * 20 - 20], &c__1, &le[40], &
+ c__1);
+ }
+/* L190: */
+ }
+ if (ifnd == 0) {
+ icmp = 1;
+ } else {
+ icmp = 3;
+ }
+ } else {
+ lcmp[0] = 1;
+ lcmp[1] = 2;
+ ifnd = 0;
+ i__1 = n;
+ for (i__ = 3; i__ <= i__1; ++i__) {
+ if (ifnd == 1 || wi[i__ - 1] != 0.f) {
+ select[i__ - 1] = FALSE_;
+ } else {
+ lcmp[2] = i__;
+ ifnd = 1;
+ scopy_(&n, &re[i__ * 20 - 20], &c__1, &re[40], &c__1);
+ scopy_(&n, &le[i__ * 20 - 20], &c__1, &le[40], &c__1);
+ }
+/* L200: */
+ }
+ if (ifnd == 0) {
+ icmp = 2;
+ } else {
+ icmp = 3;
+ }
+ }
+
+/* Compute all selected condition numbers */
+
+ scopy_(&icmp, dum, &c__0, stmp, &c__1);
+ scopy_(&icmp, dum, &c__0, septmp, &c__1);
+ strsna_("Bothcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
+ c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L240;
+ }
+ i__1 = icmp;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ j = lcmp[i__ - 1];
+ if (septmp[i__ - 1] != sep[j - 1]) {
+ vmax = 1.f / eps;
+ }
+ if (stmp[i__ - 1] != s[j - 1]) {
+ vmax = 1.f / eps;
+ }
+/* L210: */
+ }
+
+/* Compute selected eigenvalue condition numbers */
+
+ scopy_(&icmp, dum, &c__0, stmp, &c__1);
+ scopy_(&icmp, dum, &c__0, septmp, &c__1);
+ strsna_("Eigcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
+ c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L240;
+ }
+ i__1 = icmp;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ j = lcmp[i__ - 1];
+ if (stmp[i__ - 1] != s[j - 1]) {
+ vmax = 1.f / eps;
+ }
+ if (septmp[i__ - 1] != dum[0]) {
+ vmax = 1.f / eps;
+ }
+/* L220: */
+ }
+
+/* Compute selected eigenvector condition numbers */
+
+ scopy_(&icmp, dum, &c__0, stmp, &c__1);
+ scopy_(&icmp, dum, &c__0, septmp, &c__1);
+ strsna_("Veccond", "Some", select, &n, t, &c__20, le, &c__20, re, &
+ c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L240;
+ }
+ i__1 = icmp;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ j = lcmp[i__ - 1];
+ if (stmp[i__ - 1] != dum[0]) {
+ vmax = 1.f / eps;
+ }
+ if (septmp[i__ - 1] != sep[j - 1]) {
+ vmax = 1.f / eps;
+ }
+/* L230: */
+ }
+ if (vmax > rmax[1]) {
+ rmax[1] = vmax;
+ if (ninfo[1] == 0) {
+ lmax[1] = *knt;
+ }
+ }
+L240:
+ ;
+ }
+ goto L10;
+
+/* End of SGET37 */
+
+} /* sget37_ */
diff --git a/TESTING/EIG/sget38.c b/TESTING/EIG/sget38.c
new file mode 100644
index 0000000..3c72afe
--- /dev/null
+++ b/TESTING/EIG/sget38.c
@@ -0,0 +1,609 @@
+/* sget38.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c__20 = 20;
+static integer c__1200 = 1200;
+static integer c__400 = 400;
+
+/* Subroutine */ int sget38_(real *rmax, integer *lmax, integer *ninfo,
+ integer *knt, integer *nin)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+
+ /* Local variables */
+ integer i__, j, m, n;
+ real q[400] /* was [20][20] */, s, t[400] /* was [20][20] */, v, wi[20],
+ wr[20], val[3], eps, sep, sin__, tol, tmp[400] /* was [20][
+ 20] */;
+ integer ndim, iscl, info, kmin, itmp, ipnt[20];
+ real vmax, qsav[400] /* was [20][20] */, tsav[400] /* was [20][
+ 20] */, tnrm, qtmp[400] /* was [20][20] */, work[1200], stmp,
+ vmul, ttmp[400] /* was [20][20] */, tsav1[400] /* was [20][
+ 20] */;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real sepin, vimin;
+ extern /* Subroutine */ int shst01_(integer *, integer *, integer *, real
+ *, integer *, real *, integer *, real *, integer *, real *,
+ integer *, real *);
+ real tolin, vrmin;
+ integer iwork[400];
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ real witmp[20], wrtmp[20];
+ extern /* Subroutine */ int slabad_(real *, real *);
+ integer iselec[20];
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *);
+ logical select[20];
+ real bignum;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), sorghr_(integer *, integer
+ *, integer *, real *, integer *, real *, real *, integer *,
+ integer *), shseqr_(char *, char *, integer *, integer *, integer
+ *, real *, integer *, real *, real *, real *, integer *, real *,
+ integer *, integer *);
+ real septmp, smlnum, result[2];
+ extern /* Subroutine */ int strsen_(char *, char *, logical *, integer *,
+ real *, integer *, real *, integer *, real *, real *, integer *,
+ real *, real *, real *, integer *, integer *, integer *, integer *
+);
+
+ /* Fortran I/O blocks */
+ static cilist io___5 = { 0, 0, 0, 0, 0 };
+ static cilist io___8 = { 0, 0, 0, 0, 0 };
+ static cilist io___11 = { 0, 0, 0, 0, 0 };
+ static cilist io___14 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET38 tests STRSEN, a routine for estimating condition numbers of a */
+/* cluster of eigenvalues and/or its associated right invariant subspace */
+
+/* The test matrices are read from a file with logical unit number NIN. */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) REAL array, dimension (3) */
+/* Values of the largest test ratios. */
+/* RMAX(1) = largest residuals from SHST01 or comparing */
+/* different calls to STRSEN */
+/* RMAX(2) = largest error in reciprocal condition */
+/* numbers taking their conditioning into account */
+/* RMAX(3) = largest error in reciprocal condition */
+/* numbers not taking their conditioning into */
+/* account (may be larger than RMAX(2)) */
+
+/* LMAX (output) INTEGER array, dimension (3) */
+/* LMAX(i) is example number where largest test ratio */
+/* RMAX(i) is achieved. Also: */
+/* If SGEHRD returns INFO nonzero on example i, LMAX(1)=i */
+/* If SHSEQR returns INFO nonzero on example i, LMAX(2)=i */
+/* If STRSEN returns INFO nonzero on example i, LMAX(3)=i */
+
+/* NINFO (output) INTEGER array, dimension (3) */
+/* NINFO(1) = No. of times SGEHRD returned INFO nonzero */
+/* NINFO(2) = No. of times SHSEQR returned INFO nonzero */
+/* NINFO(3) = No. of times STRSEN returned INFO nonzero */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* NIN (input) INTEGER */
+/* Input logical unit number. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ninfo;
+ --lmax;
+ --rmax;
+
+ /* Function Body */
+ eps = slamch_("P");
+ smlnum = slamch_("S") / eps;
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* EPSIN = 2**(-24) = precision to which input data computed */
+
+ eps = dmax(eps,5.9605e-8f);
+ rmax[1] = 0.f;
+ rmax[2] = 0.f;
+ rmax[3] = 0.f;
+ lmax[1] = 0;
+ lmax[2] = 0;
+ lmax[3] = 0;
+ *knt = 0;
+ ninfo[1] = 0;
+ ninfo[2] = 0;
+ ninfo[3] = 0;
+
+ val[0] = sqrt(smlnum);
+ val[1] = 1.f;
+ val[2] = sqrt(sqrt(bignum));
+
+/* Read input data until N=0. Assume input eigenvalues are sorted */
+/* lexicographically (increasing by real part, then decreasing by */
+/* imaginary part) */
+
+L10:
+ io___5.ciunit = *nin;
+ s_rsle(&io___5);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ndim, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ return 0;
+ }
+ io___8.ciunit = *nin;
+ s_rsle(&io___8);
+ i__1 = ndim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&iselec[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_rsle();
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___11.ciunit = *nin;
+ s_rsle(&io___11);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__4, &c__1, (char *)&tmp[i__ + j * 20 - 21], (ftnlen)
+ sizeof(real));
+ }
+ e_rsle();
+/* L20: */
+ }
+ io___14.ciunit = *nin;
+ s_rsle(&io___14);
+ do_lio(&c__4, &c__1, (char *)&sin__, (ftnlen)sizeof(real));
+ do_lio(&c__4, &c__1, (char *)&sepin, (ftnlen)sizeof(real));
+ e_rsle();
+
+ tnrm = slange_("M", &n, &n, tmp, &c__20, work);
+ for (iscl = 1; iscl <= 3; ++iscl) {
+
+/* Scale input matrix */
+
+ ++(*knt);
+ slacpy_("F", &n, &n, tmp, &c__20, t, &c__20);
+ vmul = val[iscl - 1];
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sscal_(&n, &vmul, &t[i__ * 20 - 20], &c__1);
+/* L30: */
+ }
+ if (tnrm == 0.f) {
+ vmul = 1.f;
+ }
+ slacpy_("F", &n, &n, t, &c__20, tsav, &c__20);
+
+/* Compute Schur form */
+
+ i__1 = 1200 - n;
+ sgehrd_(&n, &c__1, &n, t, &c__20, work, &work[n], &i__1, &info);
+ if (info != 0) {
+ lmax[1] = *knt;
+ ++ninfo[1];
+ goto L160;
+ }
+
+/* Generate orthogonal matrix */
+
+ slacpy_("L", &n, &n, t, &c__20, q, &c__20);
+ i__1 = 1200 - n;
+ sorghr_(&n, &c__1, &n, q, &c__20, work, &work[n], &i__1, &info);
+
+/* Compute Schur form */
+
+ shseqr_("S", "V", &n, &c__1, &n, t, &c__20, wr, wi, q, &c__20, work, &
+ c__1200, &info);
+ if (info != 0) {
+ lmax[2] = *knt;
+ ++ninfo[2];
+ goto L160;
+ }
+
+/* Sort, select eigenvalues */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ipnt[i__ - 1] = i__;
+ select[i__ - 1] = FALSE_;
+/* L40: */
+ }
+ scopy_(&n, wr, &c__1, wrtmp, &c__1);
+ scopy_(&n, wi, &c__1, witmp, &c__1);
+ i__1 = n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ kmin = i__;
+ vrmin = wrtmp[i__ - 1];
+ vimin = witmp[i__ - 1];
+ i__2 = n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (wrtmp[j - 1] < vrmin) {
+ kmin = j;
+ vrmin = wrtmp[j - 1];
+ vimin = witmp[j - 1];
+ }
+/* L50: */
+ }
+ wrtmp[kmin - 1] = wrtmp[i__ - 1];
+ witmp[kmin - 1] = witmp[i__ - 1];
+ wrtmp[i__ - 1] = vrmin;
+ witmp[i__ - 1] = vimin;
+ itmp = ipnt[i__ - 1];
+ ipnt[i__ - 1] = ipnt[kmin - 1];
+ ipnt[kmin - 1] = itmp;
+/* L60: */
+ }
+ i__1 = ndim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ select[ipnt[iselec[i__ - 1] - 1] - 1] = TRUE_;
+/* L70: */
+ }
+
+/* Compute condition numbers */
+
+ slacpy_("F", &n, &n, q, &c__20, qsav, &c__20);
+ slacpy_("F", &n, &n, t, &c__20, tsav1, &c__20);
+ strsen_("B", "V", select, &n, t, &c__20, q, &c__20, wrtmp, witmp, &m,
+ &s, &sep, work, &c__1200, iwork, &c__400, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L160;
+ }
+ septmp = sep / vmul;
+ stmp = s;
+
+/* Compute residuals */
+
+ shst01_(&n, &c__1, &n, tsav, &c__20, t, &c__20, q, &c__20, work, &
+ c__1200, result);
+ vmax = dmax(result[0],result[1]);
+ if (vmax > rmax[1]) {
+ rmax[1] = vmax;
+ if (ninfo[1] == 0) {
+ lmax[1] = *knt;
+ }
+ }
+
+/* Compare condition number for eigenvalue cluster */
+/* taking its condition number into account */
+
+/* Computing MAX */
+ r__1 = (real) n * 2.f * eps * tnrm;
+ v = dmax(r__1,smlnum);
+ if (tnrm == 0.f) {
+ v = 1.f;
+ }
+ if (v > septmp) {
+ tol = 1.f;
+ } else {
+ tol = v / septmp;
+ }
+ if (v > sepin) {
+ tolin = 1.f;
+ } else {
+ tolin = v / sepin;
+ }
+/* Computing MAX */
+ r__1 = tol, r__2 = smlnum / eps;
+ tol = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = tolin, r__2 = smlnum / eps;
+ tolin = dmax(r__1,r__2);
+ if (eps * (sin__ - tolin) > stmp + tol) {
+ vmax = 1.f / eps;
+ } else if (sin__ - tolin > stmp + tol) {
+ vmax = (sin__ - tolin) / (stmp + tol);
+ } else if (sin__ + tolin < eps * (stmp - tol)) {
+ vmax = 1.f / eps;
+ } else if (sin__ + tolin < stmp - tol) {
+ vmax = (stmp - tol) / (sin__ + tolin);
+ } else {
+ vmax = 1.f;
+ }
+ if (vmax > rmax[2]) {
+ rmax[2] = vmax;
+ if (ninfo[2] == 0) {
+ lmax[2] = *knt;
+ }
+ }
+
+/* Compare condition numbers for invariant subspace */
+/* taking its condition number into account */
+
+ if (v > septmp * stmp) {
+ tol = septmp;
+ } else {
+ tol = v / stmp;
+ }
+ if (v > sepin * sin__) {
+ tolin = sepin;
+ } else {
+ tolin = v / sin__;
+ }
+/* Computing MAX */
+ r__1 = tol, r__2 = smlnum / eps;
+ tol = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = tolin, r__2 = smlnum / eps;
+ tolin = dmax(r__1,r__2);
+ if (eps * (sepin - tolin) > septmp + tol) {
+ vmax = 1.f / eps;
+ } else if (sepin - tolin > septmp + tol) {
+ vmax = (sepin - tolin) / (septmp + tol);
+ } else if (sepin + tolin < eps * (septmp - tol)) {
+ vmax = 1.f / eps;
+ } else if (sepin + tolin < septmp - tol) {
+ vmax = (septmp - tol) / (sepin + tolin);
+ } else {
+ vmax = 1.f;
+ }
+ if (vmax > rmax[2]) {
+ rmax[2] = vmax;
+ if (ninfo[2] == 0) {
+ lmax[2] = *knt;
+ }
+ }
+
+/* Compare condition number for eigenvalue cluster */
+/* without taking its condition number into account */
+
+ if (sin__ <= (real) (n << 1) * eps && stmp <= (real) (n << 1) * eps) {
+ vmax = 1.f;
+ } else if (eps * sin__ > stmp) {
+ vmax = 1.f / eps;
+ } else if (sin__ > stmp) {
+ vmax = sin__ / stmp;
+ } else if (sin__ < eps * stmp) {
+ vmax = 1.f / eps;
+ } else if (sin__ < stmp) {
+ vmax = stmp / sin__;
+ } else {
+ vmax = 1.f;
+ }
+ if (vmax > rmax[3]) {
+ rmax[3] = vmax;
+ if (ninfo[3] == 0) {
+ lmax[3] = *knt;
+ }
+ }
+
+/* Compare condition numbers for invariant subspace */
+/* without taking its condition number into account */
+
+ if (sepin <= v && septmp <= v) {
+ vmax = 1.f;
+ } else if (eps * sepin > septmp) {
+ vmax = 1.f / eps;
+ } else if (sepin > septmp) {
+ vmax = sepin / septmp;
+ } else if (sepin < eps * septmp) {
+ vmax = 1.f / eps;
+ } else if (sepin < septmp) {
+ vmax = septmp / sepin;
+ } else {
+ vmax = 1.f;
+ }
+ if (vmax > rmax[3]) {
+ rmax[3] = vmax;
+ if (ninfo[3] == 0) {
+ lmax[3] = *knt;
+ }
+ }
+
+/* Compute eigenvalue condition number only and compare */
+/* Update Q */
+
+ vmax = 0.f;
+ slacpy_("F", &n, &n, tsav1, &c__20, ttmp, &c__20);
+ slacpy_("F", &n, &n, qsav, &c__20, qtmp, &c__20);
+ septmp = -1.f;
+ stmp = -1.f;
+ strsen_("E", "V", select, &n, ttmp, &c__20, qtmp, &c__20, wrtmp,
+ witmp, &m, &stmp, &septmp, work, &c__1200, iwork, &c__400, &
+ info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L160;
+ }
+ if (s != stmp) {
+ vmax = 1.f / eps;
+ }
+ if (-1.f != septmp) {
+ vmax = 1.f / eps;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ if (ttmp[i__ + j * 20 - 21] != t[i__ + j * 20 - 21]) {
+ vmax = 1.f / eps;
+ }
+ if (qtmp[i__ + j * 20 - 21] != q[i__ + j * 20 - 21]) {
+ vmax = 1.f / eps;
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Compute invariant subspace condition number only and compare */
+/* Update Q */
+
+ slacpy_("F", &n, &n, tsav1, &c__20, ttmp, &c__20);
+ slacpy_("F", &n, &n, qsav, &c__20, qtmp, &c__20);
+ septmp = -1.f;
+ stmp = -1.f;
+ strsen_("V", "V", select, &n, ttmp, &c__20, qtmp, &c__20, wrtmp,
+ witmp, &m, &stmp, &septmp, work, &c__1200, iwork, &c__400, &
+ info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L160;
+ }
+ if (-1.f != stmp) {
+ vmax = 1.f / eps;
+ }
+ if (sep != septmp) {
+ vmax = 1.f / eps;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ if (ttmp[i__ + j * 20 - 21] != t[i__ + j * 20 - 21]) {
+ vmax = 1.f / eps;
+ }
+ if (qtmp[i__ + j * 20 - 21] != q[i__ + j * 20 - 21]) {
+ vmax = 1.f / eps;
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+
+/* Compute eigenvalue condition number only and compare */
+/* Do not update Q */
+
+ slacpy_("F", &n, &n, tsav1, &c__20, ttmp, &c__20);
+ slacpy_("F", &n, &n, qsav, &c__20, qtmp, &c__20);
+ septmp = -1.f;
+ stmp = -1.f;
+ strsen_("E", "N", select, &n, ttmp, &c__20, qtmp, &c__20, wrtmp,
+ witmp, &m, &stmp, &septmp, work, &c__1200, iwork, &c__400, &
+ info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L160;
+ }
+ if (s != stmp) {
+ vmax = 1.f / eps;
+ }
+ if (-1.f != septmp) {
+ vmax = 1.f / eps;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ if (ttmp[i__ + j * 20 - 21] != t[i__ + j * 20 - 21]) {
+ vmax = 1.f / eps;
+ }
+ if (qtmp[i__ + j * 20 - 21] != qsav[i__ + j * 20 - 21]) {
+ vmax = 1.f / eps;
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+
+/* Compute invariant subspace condition number only and compare */
+/* Do not update Q */
+
+ slacpy_("F", &n, &n, tsav1, &c__20, ttmp, &c__20);
+ slacpy_("F", &n, &n, qsav, &c__20, qtmp, &c__20);
+ septmp = -1.f;
+ stmp = -1.f;
+ strsen_("V", "N", select, &n, ttmp, &c__20, qtmp, &c__20, wrtmp,
+ witmp, &m, &stmp, &septmp, work, &c__1200, iwork, &c__400, &
+ info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L160;
+ }
+ if (-1.f != stmp) {
+ vmax = 1.f / eps;
+ }
+ if (sep != septmp) {
+ vmax = 1.f / eps;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ if (ttmp[i__ + j * 20 - 21] != t[i__ + j * 20 - 21]) {
+ vmax = 1.f / eps;
+ }
+ if (qtmp[i__ + j * 20 - 21] != qsav[i__ + j * 20 - 21]) {
+ vmax = 1.f / eps;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+ if (vmax > rmax[1]) {
+ rmax[1] = vmax;
+ if (ninfo[1] == 0) {
+ lmax[1] = *knt;
+ }
+ }
+L160:
+ ;
+ }
+ goto L10;
+
+/* End of SGET38 */
+
+} /* sget38_ */
diff --git a/TESTING/EIG/sget39.c b/TESTING/EIG/sget39.c
new file mode 100644
index 0000000..70f9560
--- /dev/null
+++ b/TESTING/EIG/sget39.c
@@ -0,0 +1,414 @@
+/* sget39.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__10 = 10;
+static integer c__1 = 1;
+static logical c_false = FALSE_;
+static logical c_true = TRUE_;
+static real c_b25 = 1.f;
+static real c_b59 = -1.f;
+
+/* Subroutine */ int sget39_(real *rmax, integer *lmax, integer *ninfo,
+ integer *knt)
+{
+ /* Initialized data */
+
+ static integer idim[6] = { 4,5,5,5,5,5 };
+ static integer ival[150] /* was [5][5][6] */ = { 3,0,0,0,0,1,1,-1,0,0,
+ 3,2,1,0,0,4,3,2,2,0,0,0,0,0,0,1,0,0,0,0,2,2,0,0,0,3,3,4,0,0,4,2,2,
+ 3,0,1,1,1,1,5,1,0,0,0,0,2,4,-2,0,0,3,3,4,0,0,4,2,2,3,0,1,1,1,1,1,
+ 1,0,0,0,0,2,1,-1,0,0,9,8,1,0,0,4,9,1,2,-1,2,2,2,2,2,9,0,0,0,0,6,4,
+ 0,0,0,3,2,1,1,0,5,1,-1,1,0,2,2,2,2,2,4,0,0,0,0,2,2,0,0,0,1,4,4,0,
+ 0,2,4,2,2,-1,2,2,2,2,2 };
+
+ /* System generated locals */
+ integer i__1, i__2;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal), cos(doublereal), sin(doublereal);
+
+ /* Local variables */
+ real b[10], d__[20];
+ integer i__, j, k, n;
+ real t[100] /* was [10][10] */, w, x[20], y[20], vm1[5], vm2[5], vm3[5],
+ vm4[5], vm5[3], dum[1], eps;
+ integer ivm1, ivm2, ivm3, ivm4, ivm5, ndim, info;
+ real dumm;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ real norm, work[10], scale, domin, resid;
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ extern doublereal sasum_(integer *, real *, integer *);
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ real xnorm;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ real bignum;
+ extern integer isamax_(integer *, real *, integer *);
+ real normtb;
+ extern /* Subroutine */ int slaqtr_(logical *, logical *, integer *, real
+ *, integer *, real *, real *, real *, real *, real *, integer *);
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET39 tests SLAQTR, a routine for solving the real or */
+/* special complex quasi upper triangular system */
+
+/* op(T)*p = scale*c, */
+/* or */
+/* op(T + iB)*(p+iq) = scale*(c+id), */
+
+/* in real arithmetic. T is upper quasi-triangular. */
+/* If it is complex, then the first diagonal block of T must be */
+/* 1 by 1, B has the special structure */
+
+/* B = [ b(1) b(2) ... b(n) ] */
+/* [ w ] */
+/* [ w ] */
+/* [ . ] */
+/* [ w ] */
+
+/* op(A) = A or A', where A' denotes the conjugate transpose of */
+/* the matrix A. */
+
+/* On input, X = [ c ]. On output, X = [ p ]. */
+/* [ d ] [ q ] */
+
+/* Scale is an output less than or equal to 1, chosen to avoid */
+/* overflow in X. */
+/* This subroutine is specially designed for the condition number */
+/* estimation in the eigenproblem routine STRSNA. */
+
+/* The test code verifies that the following residual is order 1: */
+
+/* ||(T+i*B)*(x1+i*x2) - scale*(d1+i*d2)|| */
+/* ----------------------------------------- */
+/* max(ulp*(||T||+||B||)*(||x1||+||x2||), */
+/* (||T||+||B||)*smlnum/ulp, */
+/* smlnum) */
+
+/* (The (||T||+||B||)*smlnum/ulp term accounts for possible */
+/* (gradual or nongradual) underflow in x1 and x2.) */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) REAL */
+/* Value of the largest test ratio. */
+
+/* LMAX (output) INTEGER */
+/* Example number where largest test ratio achieved. */
+
+/* NINFO (output) INTEGER */
+/* Number of examples where INFO is nonzero. */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Get machine parameters */
+
+ eps = slamch_("P");
+ smlnum = slamch_("S");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Set up test case parameters */
+
+ vm1[0] = 1.f;
+ vm1[1] = sqrt(smlnum);
+ vm1[2] = sqrt(vm1[1]);
+ vm1[3] = sqrt(bignum);
+ vm1[4] = sqrt(vm1[3]);
+
+ vm2[0] = 1.f;
+ vm2[1] = sqrt(smlnum);
+ vm2[2] = sqrt(vm2[1]);
+ vm2[3] = sqrt(bignum);
+ vm2[4] = sqrt(vm2[3]);
+
+ vm3[0] = 1.f;
+ vm3[1] = sqrt(smlnum);
+ vm3[2] = sqrt(vm3[1]);
+ vm3[3] = sqrt(bignum);
+ vm3[4] = sqrt(vm3[3]);
+
+ vm4[0] = 1.f;
+ vm4[1] = sqrt(smlnum);
+ vm4[2] = sqrt(vm4[1]);
+ vm4[3] = sqrt(bignum);
+ vm4[4] = sqrt(vm4[3]);
+
+ vm5[0] = 1.f;
+ vm5[1] = eps;
+ vm5[2] = sqrt(smlnum);
+
+/* Initalization */
+
+ *knt = 0;
+ *rmax = 0.f;
+ *ninfo = 0;
+ smlnum /= eps;
+
+/* Begin test loop */
+
+ for (ivm5 = 1; ivm5 <= 3; ++ivm5) {
+ for (ivm4 = 1; ivm4 <= 5; ++ivm4) {
+ for (ivm3 = 1; ivm3 <= 5; ++ivm3) {
+ for (ivm2 = 1; ivm2 <= 5; ++ivm2) {
+ for (ivm1 = 1; ivm1 <= 5; ++ivm1) {
+ for (ndim = 1; ndim <= 6; ++ndim) {
+
+ n = idim[ndim - 1];
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ t[i__ + j * 10 - 11] = (real) ival[i__ + (
+ j + ndim * 5) * 5 - 31] * vm1[
+ ivm1 - 1];
+ if (i__ >= j) {
+ t[i__ + j * 10 - 11] *= vm5[ivm5 - 1];
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+
+ w = vm2[ivm2 - 1] * 1.f;
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ b[i__ - 1] = cos((real) i__) * vm3[ivm3 - 1];
+/* L30: */
+ }
+
+ i__1 = n << 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__ - 1] = sin((real) i__) * vm4[ivm4 - 1]
+ ;
+/* L40: */
+ }
+
+ norm = slange_("1", &n, &n, t, &c__10, work);
+ k = isamax_(&n, b, &c__1);
+ normtb = norm + (r__1 = b[k - 1], dabs(r__1)) +
+ dabs(w);
+
+ scopy_(&n, d__, &c__1, x, &c__1);
+ ++(*knt);
+ slaqtr_(&c_false, &c_true, &n, t, &c__10, dum, &
+ dumm, &scale, x, work, &info);
+ if (info != 0) {
+ ++(*ninfo);
+ }
+
+/* || T*x - scale*d || / */
+/* max(ulp*||T||*||x||,smlnum/ulp*||T||,smlnum) */
+
+ scopy_(&n, d__, &c__1, y, &c__1);
+ r__1 = -scale;
+ sgemv_("No transpose", &n, &n, &c_b25, t, &c__10,
+ x, &c__1, &r__1, y, &c__1);
+ xnorm = sasum_(&n, x, &c__1);
+ resid = sasum_(&n, y, &c__1);
+/* Computing MAX */
+ r__1 = smlnum, r__2 = smlnum / eps * norm, r__1 =
+ max(r__1,r__2), r__2 = norm * eps * xnorm;
+ domin = dmax(r__1,r__2);
+ resid /= domin;
+ if (resid > *rmax) {
+ *rmax = resid;
+ *lmax = *knt;
+ }
+
+ scopy_(&n, d__, &c__1, x, &c__1);
+ ++(*knt);
+ slaqtr_(&c_true, &c_true, &n, t, &c__10, dum, &
+ dumm, &scale, x, work, &info);
+ if (info != 0) {
+ ++(*ninfo);
+ }
+
+/* || T*x - scale*d || / */
+/* max(ulp*||T||*||x||,smlnum/ulp*||T||,smlnum) */
+
+ scopy_(&n, d__, &c__1, y, &c__1);
+ r__1 = -scale;
+ sgemv_("Transpose", &n, &n, &c_b25, t, &c__10, x,
+ &c__1, &r__1, y, &c__1);
+ xnorm = sasum_(&n, x, &c__1);
+ resid = sasum_(&n, y, &c__1);
+/* Computing MAX */
+ r__1 = smlnum, r__2 = smlnum / eps * norm, r__1 =
+ max(r__1,r__2), r__2 = norm * eps * xnorm;
+ domin = dmax(r__1,r__2);
+ resid /= domin;
+ if (resid > *rmax) {
+ *rmax = resid;
+ *lmax = *knt;
+ }
+
+ i__1 = n << 1;
+ scopy_(&i__1, d__, &c__1, x, &c__1);
+ ++(*knt);
+ slaqtr_(&c_false, &c_false, &n, t, &c__10, b, &w,
+ &scale, x, work, &info);
+ if (info != 0) {
+ ++(*ninfo);
+ }
+
+/* ||(T+i*B)*(x1+i*x2) - scale*(d1+i*d2)|| / */
+/* max(ulp*(||T||+||B||)*(||x1||+||x2||), */
+/* smlnum/ulp * (||T||+||B||), smlnum ) */
+
+
+ i__1 = n << 1;
+ scopy_(&i__1, d__, &c__1, y, &c__1);
+ y[0] = sdot_(&n, b, &c__1, &x[n], &c__1) + scale *
+ y[0];
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ y[i__ - 1] = w * x[i__ + n - 1] + scale * y[
+ i__ - 1];
+/* L50: */
+ }
+ sgemv_("No transpose", &n, &n, &c_b25, t, &c__10,
+ x, &c__1, &c_b59, y, &c__1);
+
+ y[n] = sdot_(&n, b, &c__1, x, &c__1) - scale * y[
+ n];
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ y[i__ + n - 1] = w * x[i__ - 1] - scale * y[
+ i__ + n - 1];
+/* L60: */
+ }
+ sgemv_("No transpose", &n, &n, &c_b25, t, &c__10,
+ &x[n], &c__1, &c_b25, &y[n], &c__1);
+
+ i__1 = n << 1;
+ resid = sasum_(&i__1, y, &c__1);
+/* Computing MAX */
+ i__1 = n << 1;
+ r__1 = smlnum, r__2 = smlnum / eps * normtb, r__1
+ = max(r__1,r__2), r__2 = eps * (normtb *
+ sasum_(&i__1, x, &c__1));
+ domin = dmax(r__1,r__2);
+ resid /= domin;
+ if (resid > *rmax) {
+ *rmax = resid;
+ *lmax = *knt;
+ }
+
+ i__1 = n << 1;
+ scopy_(&i__1, d__, &c__1, x, &c__1);
+ ++(*knt);
+ slaqtr_(&c_true, &c_false, &n, t, &c__10, b, &w, &
+ scale, x, work, &info);
+ if (info != 0) {
+ ++(*ninfo);
+ }
+
+/* ||(T+i*B)*(x1+i*x2) - scale*(d1+i*d2)|| / */
+/* max(ulp*(||T||+||B||)*(||x1||+||x2||), */
+/* smlnum/ulp * (||T||+||B||), smlnum ) */
+
+ i__1 = n << 1;
+ scopy_(&i__1, d__, &c__1, y, &c__1);
+ y[0] = b[0] * x[n] - scale * y[0];
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ y[i__ - 1] = b[i__ - 1] * x[n] + w * x[i__ +
+ n - 1] - scale * y[i__ - 1];
+/* L70: */
+ }
+ sgemv_("Transpose", &n, &n, &c_b25, t, &c__10, x,
+ &c__1, &c_b25, y, &c__1);
+
+ y[n] = b[0] * x[0] + scale * y[n];
+ i__1 = n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ y[i__ + n - 1] = b[i__ - 1] * x[0] + w * x[
+ i__ - 1] + scale * y[i__ + n - 1];
+/* L80: */
+ }
+ sgemv_("Transpose", &n, &n, &c_b25, t, &c__10, &x[
+ n], &c__1, &c_b59, &y[n], &c__1);
+
+ i__1 = n << 1;
+ resid = sasum_(&i__1, y, &c__1);
+/* Computing MAX */
+ i__1 = n << 1;
+ r__1 = smlnum, r__2 = smlnum / eps * normtb, r__1
+ = max(r__1,r__2), r__2 = eps * (normtb *
+ sasum_(&i__1, x, &c__1));
+ domin = dmax(r__1,r__2);
+ resid /= domin;
+ if (resid > *rmax) {
+ *rmax = resid;
+ *lmax = *knt;
+ }
+
+/* L90: */
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+
+ return 0;
+
+/* End of SGET39 */
+
+} /* sget39_ */
diff --git a/TESTING/EIG/sget51.c b/TESTING/EIG/sget51.c
new file mode 100644
index 0000000..75bb84b
--- /dev/null
+++ b/TESTING/EIG/sget51.c
@@ -0,0 +1,261 @@
+/* sget51.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b9 = 1.f;
+static real c_b10 = 0.f;
+static real c_b13 = -1.f;
+
+/* Subroutine */ int sget51_(integer *itype, integer *n, real *a, integer *
+ lda, real *b, integer *ldb, real *u, integer *ldu, real *v, integer *
+ ldv, real *work, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, u_dim1, u_offset, v_dim1,
+ v_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Local variables */
+ real ulp;
+ integer jcol;
+ real unfl;
+ integer jrow, jdiag;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm, wnorm;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET51 generally checks a decomposition of the form */
+
+/* A = U B V' */
+
+/* where ' means transpose and U and V are orthogonal. */
+
+/* Specifically, if ITYPE=1 */
+
+/* RESULT = | A - U B V' | / ( |A| n ulp ) */
+
+/* If ITYPE=2, then: */
+
+/* RESULT = | A - B | / ( |A| n ulp ) */
+
+/* If ITYPE=3, then: */
+
+/* RESULT = | I - UU' | / ( n ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the type of tests to be performed. */
+/* =1: RESULT = | A - U B V' | / ( |A| n ulp ) */
+/* =2: RESULT = | A - B | / ( |A| n ulp ) */
+/* =3: RESULT = | I - UU' | / ( n ulp ) */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, SGET51 does nothing. */
+/* It must be at least zero. */
+
+/* A (input) REAL array, dimension (LDA, N) */
+/* The original (unfactored) matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least N. */
+
+/* B (input) REAL array, dimension (LDB, N) */
+/* The factored matrix. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. It must be at least 1 */
+/* and at least N. */
+
+/* U (input) REAL array, dimension (LDU, N) */
+/* The orthogonal matrix on the left-hand side in the */
+/* decomposition. */
+/* Not referenced if ITYPE=2 */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+
+/* V (input) REAL array, dimension (LDV, N) */
+/* The orthogonal matrix on the left-hand side in the */
+/* decomposition. */
+/* Not referenced if ITYPE=2 */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of V. LDV must be at least N and */
+/* at least 1. */
+
+/* WORK (workspace) REAL array, dimension (2*N**2) */
+
+/* RESULT (output) REAL */
+/* The values computed by the test specified by ITYPE. The */
+/* value is currently limited to 1/ulp, to avoid overflow. */
+/* Errors are flagged by RESULT=10/ulp. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --work;
+
+ /* Function Body */
+ *result = 0.f;
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Constants */
+
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon") * slamch_("Base");
+
+/* Some Error Checks */
+
+ if (*itype < 1 || *itype > 3) {
+ *result = 10.f / ulp;
+ return 0;
+ }
+
+ if (*itype <= 2) {
+
+/* Tests scaled by the norm(A) */
+
+/* Computing MAX */
+ r__1 = slange_("1", n, n, &a[a_offset], lda, &work[1]);
+ anorm = dmax(r__1,unfl);
+
+ if (*itype == 1) {
+
+/* ITYPE=1: Compute W = A - UBV' */
+
+ slacpy_(" ", n, n, &a[a_offset], lda, &work[1], n);
+/* Computing 2nd power */
+ i__1 = *n;
+ sgemm_("N", "N", n, n, n, &c_b9, &u[u_offset], ldu, &b[b_offset],
+ ldb, &c_b10, &work[i__1 * i__1 + 1], n);
+
+/* Computing 2nd power */
+ i__1 = *n;
+ sgemm_("N", "C", n, n, n, &c_b13, &work[i__1 * i__1 + 1], n, &v[
+ v_offset], ldv, &c_b9, &work[1], n);
+
+ } else {
+
+/* ITYPE=2: Compute W = A - B */
+
+ slacpy_(" ", n, n, &b[b_offset], ldb, &work[1], n);
+
+ i__1 = *n;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ i__2 = *n;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ work[jrow + *n * (jcol - 1)] -= a[jrow + jcol * a_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+ }
+
+/* Compute norm(W)/ ( ulp*norm(A) ) */
+
+/* Computing 2nd power */
+ i__1 = *n;
+ wnorm = slange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]);
+
+ if (anorm > wnorm) {
+ *result = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.f) {
+/* Computing MIN */
+ r__1 = wnorm, r__2 = *n * anorm;
+ *result = dmin(r__1,r__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ r__1 = wnorm / anorm, r__2 = (real) (*n);
+ *result = dmin(r__1,r__2) / (*n * ulp);
+ }
+ }
+
+ } else {
+
+/* Tests not scaled by norm(A) */
+
+/* ITYPE=3: Compute UU' - I */
+
+ sgemm_("N", "C", n, n, n, &c_b9, &u[u_offset], ldu, &u[u_offset], ldu,
+ &c_b10, &work[1], n);
+
+ i__1 = *n;
+ for (jdiag = 1; jdiag <= i__1; ++jdiag) {
+ work[(*n + 1) * (jdiag - 1) + 1] += -1.f;
+/* L30: */
+ }
+
+/* Computing MIN */
+/* Computing 2nd power */
+ i__1 = *n;
+ r__1 = slange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]), r__2 = (real) (*n);
+ *result = dmin(r__1,r__2) / (*n * ulp);
+ }
+
+ return 0;
+
+/* End of SGET51 */
+
+} /* sget51_ */
diff --git a/TESTING/EIG/sget52.c b/TESTING/EIG/sget52.c
new file mode 100644
index 0000000..8fea4dd
--- /dev/null
+++ b/TESTING/EIG/sget52.c
@@ -0,0 +1,394 @@
+/* sget52.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b12 = 0.f;
+static real c_b15 = 1.f;
+
+/* Subroutine */ int sget52_(logical *left, integer *n, real *a, integer *lda,
+ real *b, integer *ldb, real *e, integer *lde, real *alphar, real *
+ alphai, real *beta, real *work, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, e_dim1, e_offset, i__1, i__2;
+ real r__1, r__2, r__3, r__4;
+
+ /* Local variables */
+ integer j;
+ real ulp;
+ integer jvec;
+ real temp1, acoef, scale, abmax, salfi, sbeta, salfr, anorm, bnorm, enorm;
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ char trans[1];
+ real bcoefi, bcoefr, alfmax;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ real safmin;
+ char normab[1];
+ real safmax, betmax, enrmer;
+ logical ilcplx;
+ real errnrm;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET52 does an eigenvector check for the generalized eigenvalue */
+/* problem. */
+
+/* The basic test for right eigenvectors is: */
+
+/* | b(j) A E(j) - a(j) B E(j) | */
+/* RESULT(1) = max ------------------------------- */
+/* j n ulp max( |b(j) A|, |a(j) B| ) */
+
+/* using the 1-norm. Here, a(j)/b(j) = w is the j-th generalized */
+/* eigenvalue of A - w B, or, equivalently, b(j)/a(j) = m is the j-th */
+/* generalized eigenvalue of m A - B. */
+
+/* For real eigenvalues, the test is straightforward. For complex */
+/* eigenvalues, E(j) and a(j) are complex, represented by */
+/* Er(j) + i*Ei(j) and ar(j) + i*ai(j), resp., so the test for that */
+/* eigenvector becomes */
+
+/* max( |Wr|, |Wi| ) */
+/* -------------------------------------------- */
+/* n ulp max( |b(j) A|, (|ar(j)|+|ai(j)|) |B| ) */
+
+/* where */
+
+/* Wr = b(j) A Er(j) - ar(j) B Er(j) + ai(j) B Ei(j) */
+
+/* Wi = b(j) A Ei(j) - ai(j) B Er(j) - ar(j) B Ei(j) */
+
+/* T T _ */
+/* For left eigenvectors, A , B , a, and b are used. */
+
+/* SGET52 also tests the normalization of E. Each eigenvector is */
+/* supposed to be normalized so that the maximum "absolute value" */
+/* of its elements is 1, where in this case, "absolute value" */
+/* of a complex value x is |Re(x)| + |Im(x)| ; let us call this */
+/* maximum "absolute value" norm of a vector v M(v). */
+/* if a(j)=b(j)=0, then the eigenvector is set to be the jth coordinate */
+/* vector. The normalization test is: */
+
+/* RESULT(2) = max | M(v(j)) - 1 | / ( n ulp ) */
+/* eigenvectors v(j) */
+
+/* Arguments */
+/* ========= */
+
+/* LEFT (input) LOGICAL */
+/* =.TRUE.: The eigenvectors in the columns of E are assumed */
+/* to be *left* eigenvectors. */
+/* =.FALSE.: The eigenvectors in the columns of E are assumed */
+/* to be *right* eigenvectors. */
+
+/* N (input) INTEGER */
+/* The size of the matrices. If it is zero, SGET52 does */
+/* nothing. It must be at least zero. */
+
+/* A (input) REAL array, dimension (LDA, N) */
+/* The matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least N. */
+
+/* B (input) REAL array, dimension (LDB, N) */
+/* The matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. It must be at least 1 */
+/* and at least N. */
+
+/* E (input) REAL array, dimension (LDE, N) */
+/* The matrix of eigenvectors. It must be O( 1 ). Complex */
+/* eigenvalues and eigenvectors always come in pairs, the */
+/* eigenvalue and its conjugate being stored in adjacent */
+/* elements of ALPHAR, ALPHAI, and BETA. Thus, if a(j)/b(j) */
+/* and a(j+1)/b(j+1) are a complex conjugate pair of */
+/* generalized eigenvalues, then E(,j) contains the real part */
+/* of the eigenvector and E(,j+1) contains the imaginary part. */
+/* Note that whether E(,j) is a real eigenvector or part of a */
+/* complex one is specified by whether ALPHAI(j) is zero or not. */
+
+/* LDE (input) INTEGER */
+/* The leading dimension of E. It must be at least 1 and at */
+/* least N. */
+
+/* ALPHAR (input) REAL array, dimension (N) */
+/* The real parts of the values a(j) as described above, which, */
+/* along with b(j), define the generalized eigenvalues. */
+/* Complex eigenvalues always come in complex conjugate pairs */
+/* a(j)/b(j) and a(j+1)/b(j+1), which are stored in adjacent */
+/* elements in ALPHAR, ALPHAI, and BETA. Thus, if the j-th */
+/* and (j+1)-st eigenvalues form a pair, ALPHAR(j+1)/BETA(j+1) */
+/* is assumed to be equal to ALPHAR(j)/BETA(j). */
+
+/* ALPHAI (input) REAL array, dimension (N) */
+/* The imaginary parts of the values a(j) as described above, */
+/* which, along with b(j), define the generalized eigenvalues. */
+/* If ALPHAI(j)=0, then the eigenvalue is real, otherwise it */
+/* is part of a complex conjugate pair. Complex eigenvalues */
+/* always come in complex conjugate pairs a(j)/b(j) and */
+/* a(j+1)/b(j+1), which are stored in adjacent elements in */
+/* ALPHAR, ALPHAI, and BETA. Thus, if the j-th and (j+1)-st */
+/* eigenvalues form a pair, ALPHAI(j+1)/BETA(j+1) is assumed to */
+/* be equal to -ALPHAI(j)/BETA(j). Also, nonzero values in */
+/* ALPHAI are assumed to always come in adjacent pairs. */
+
+/* BETA (input) REAL array, dimension (N) */
+/* The values b(j) as described above, which, along with a(j), */
+/* define the generalized eigenvalues. */
+
+/* WORK (workspace) REAL array, dimension (N**2+N) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The values computed by the test described above. If A E or */
+/* B E is likely to overflow, then RESULT(1:2) is set to */
+/* 10 / ulp. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ e_dim1 = *lde;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ --alphar;
+ --alphai;
+ --beta;
+ --work;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.f;
+ result[2] = 0.f;
+ if (*n <= 0) {
+ return 0;
+ }
+
+ safmin = slamch_("Safe minimum");
+ safmax = 1.f / safmin;
+ ulp = slamch_("Epsilon") * slamch_("Base");
+
+ if (*left) {
+ *(unsigned char *)trans = 'T';
+ *(unsigned char *)normab = 'I';
+ } else {
+ *(unsigned char *)trans = 'N';
+ *(unsigned char *)normab = 'O';
+ }
+
+/* Norm of A, B, and E: */
+
+/* Computing MAX */
+ r__1 = slange_(normab, n, n, &a[a_offset], lda, &work[1]);
+ anorm = dmax(r__1,safmin);
+/* Computing MAX */
+ r__1 = slange_(normab, n, n, &b[b_offset], ldb, &work[1]);
+ bnorm = dmax(r__1,safmin);
+/* Computing MAX */
+ r__1 = slange_("O", n, n, &e[e_offset], lde, &work[1]);
+ enorm = dmax(r__1,ulp);
+ alfmax = safmax / dmax(1.f,bnorm);
+ betmax = safmax / dmax(1.f,anorm);
+
+/* Compute error matrix. */
+/* Column i = ( b(i) A - a(i) B ) E(i) / max( |a(i) B| |b(i) A| ) */
+
+ ilcplx = FALSE_;
+ i__1 = *n;
+ for (jvec = 1; jvec <= i__1; ++jvec) {
+ if (ilcplx) {
+
+/* 2nd Eigenvalue/-vector of pair -- do nothing */
+
+ ilcplx = FALSE_;
+ } else {
+ salfr = alphar[jvec];
+ salfi = alphai[jvec];
+ sbeta = beta[jvec];
+ if (salfi == 0.f) {
+
+/* Real eigenvalue and -vector */
+
+/* Computing MAX */
+ r__1 = dabs(salfr), r__2 = dabs(sbeta);
+ abmax = dmax(r__1,r__2);
+ if (dabs(salfr) > alfmax || dabs(sbeta) > betmax || abmax <
+ 1.f) {
+ scale = 1.f / dmax(abmax,safmin);
+ salfr = scale * salfr;
+ sbeta = scale * sbeta;
+ }
+/* Computing MAX */
+ r__1 = dabs(salfr) * bnorm, r__2 = dabs(sbeta) * anorm, r__1 =
+ max(r__1,r__2);
+ scale = 1.f / dmax(r__1,safmin);
+ acoef = scale * sbeta;
+ bcoefr = scale * salfr;
+ sgemv_(trans, n, n, &acoef, &a[a_offset], lda, &e[jvec *
+ e_dim1 + 1], &c__1, &c_b12, &work[*n * (jvec - 1) + 1]
+, &c__1);
+ r__1 = -bcoefr;
+ sgemv_(trans, n, n, &r__1, &b[b_offset], lda, &e[jvec *
+ e_dim1 + 1], &c__1, &c_b15, &work[*n * (jvec - 1) + 1]
+, &c__1);
+ } else {
+
+/* Complex conjugate pair */
+
+ ilcplx = TRUE_;
+ if (jvec == *n) {
+ result[1] = 10.f / ulp;
+ return 0;
+ }
+/* Computing MAX */
+ r__1 = dabs(salfr) + dabs(salfi), r__2 = dabs(sbeta);
+ abmax = dmax(r__1,r__2);
+ if (dabs(salfr) + dabs(salfi) > alfmax || dabs(sbeta) >
+ betmax || abmax < 1.f) {
+ scale = 1.f / dmax(abmax,safmin);
+ salfr = scale * salfr;
+ salfi = scale * salfi;
+ sbeta = scale * sbeta;
+ }
+/* Computing MAX */
+ r__1 = (dabs(salfr) + dabs(salfi)) * bnorm, r__2 = dabs(sbeta)
+ * anorm, r__1 = max(r__1,r__2);
+ scale = 1.f / dmax(r__1,safmin);
+ acoef = scale * sbeta;
+ bcoefr = scale * salfr;
+ bcoefi = scale * salfi;
+ if (*left) {
+ bcoefi = -bcoefi;
+ }
+
+ sgemv_(trans, n, n, &acoef, &a[a_offset], lda, &e[jvec *
+ e_dim1 + 1], &c__1, &c_b12, &work[*n * (jvec - 1) + 1]
+, &c__1);
+ r__1 = -bcoefr;
+ sgemv_(trans, n, n, &r__1, &b[b_offset], lda, &e[jvec *
+ e_dim1 + 1], &c__1, &c_b15, &work[*n * (jvec - 1) + 1]
+, &c__1);
+ sgemv_(trans, n, n, &bcoefi, &b[b_offset], lda, &e[(jvec + 1)
+ * e_dim1 + 1], &c__1, &c_b15, &work[*n * (jvec - 1) +
+ 1], &c__1);
+
+ sgemv_(trans, n, n, &acoef, &a[a_offset], lda, &e[(jvec + 1) *
+ e_dim1 + 1], &c__1, &c_b12, &work[*n * jvec + 1], &
+ c__1);
+ r__1 = -bcoefi;
+ sgemv_(trans, n, n, &r__1, &b[b_offset], lda, &e[jvec *
+ e_dim1 + 1], &c__1, &c_b15, &work[*n * jvec + 1], &
+ c__1);
+ r__1 = -bcoefr;
+ sgemv_(trans, n, n, &r__1, &b[b_offset], lda, &e[(jvec + 1) *
+ e_dim1 + 1], &c__1, &c_b15, &work[*n * jvec + 1], &
+ c__1);
+ }
+ }
+/* L10: */
+ }
+
+/* Computing 2nd power */
+ i__1 = *n;
+ errnrm = slange_("One", n, n, &work[1], n, &work[i__1 * i__1 + 1]) / enorm;
+
+/* Compute RESULT(1) */
+
+ result[1] = errnrm / ulp;
+
+/* Normalization of E: */
+
+ enrmer = 0.f;
+ ilcplx = FALSE_;
+ i__1 = *n;
+ for (jvec = 1; jvec <= i__1; ++jvec) {
+ if (ilcplx) {
+ ilcplx = FALSE_;
+ } else {
+ temp1 = 0.f;
+ if (alphai[jvec] == 0.f) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ r__2 = temp1, r__3 = (r__1 = e[j + jvec * e_dim1], dabs(
+ r__1));
+ temp1 = dmax(r__2,r__3);
+/* L20: */
+ }
+/* Computing MAX */
+ r__1 = enrmer, r__2 = temp1 - 1.f;
+ enrmer = dmax(r__1,r__2);
+ } else {
+ ilcplx = TRUE_;
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ r__3 = temp1, r__4 = (r__1 = e[j + jvec * e_dim1], dabs(
+ r__1)) + (r__2 = e[j + (jvec + 1) * e_dim1], dabs(
+ r__2));
+ temp1 = dmax(r__3,r__4);
+/* L30: */
+ }
+/* Computing MAX */
+ r__1 = enrmer, r__2 = temp1 - 1.f;
+ enrmer = dmax(r__1,r__2);
+ }
+ }
+/* L40: */
+ }
+
+/* Compute RESULT(2) : the normalization error in E. */
+
+ result[2] = enrmer / ((real) (*n) * ulp);
+
+ return 0;
+
+/* End of SGET52 */
+
+} /* sget52_ */
diff --git a/TESTING/EIG/sget53.c b/TESTING/EIG/sget53.c
new file mode 100644
index 0000000..e04d784
--- /dev/null
+++ b/TESTING/EIG/sget53.c
@@ -0,0 +1,231 @@
+/* sget53.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sget53_(real *a, integer *lda, real *b, integer *ldb,
+ real *scale, real *wr, real *wi, real *result, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset;
+ real r__1, r__2, r__3, r__4, r__5, r__6;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real s1, ci11, ci12, ci22, cr11, cr12, cr21, cr22, ulp, wis, wrs, deti,
+ absw, detr, temp, anorm, bnorm, cnorm, cscale;
+ extern doublereal slamch_(char *);
+ real scales, safmin, sigmin;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET53 checks the generalized eigenvalues computed by SLAG2. */
+
+/* The basic test for an eigenvalue is: */
+
+/* | det( s A - w B ) | */
+/* RESULT = --------------------------------------------------- */
+/* ulp max( s norm(A), |w| norm(B) )*norm( s A - w B ) */
+
+/* Two "safety checks" are performed: */
+
+/* (1) ulp*max( s*norm(A), |w|*norm(B) ) must be at least */
+/* safe_minimum. This insures that the test performed is */
+/* not essentially det(0*A + 0*B)=0. */
+
+/* (2) s*norm(A) + |w|*norm(B) must be less than 1/safe_minimum. */
+/* This insures that s*A - w*B will not overflow. */
+
+/* If these tests are not passed, then s and w are scaled and */
+/* tested anyway, if this is possible. */
+
+/* Arguments */
+/* ========= */
+
+/* A (input) REAL array, dimension (LDA, 2) */
+/* The 2x2 matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 2. */
+
+/* B (input) REAL array, dimension (LDB, N) */
+/* The 2x2 upper-triangular matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. It must be at least 2. */
+
+/* SCALE (input) REAL */
+/* The "scale factor" s in the formula s A - w B . It is */
+/* assumed to be non-negative. */
+
+/* WR (input) REAL */
+/* The real part of the eigenvalue w in the formula */
+/* s A - w B . */
+
+/* WI (input) REAL */
+/* The imaginary part of the eigenvalue w in the formula */
+/* s A - w B . */
+
+/* RESULT (output) REAL */
+/* If INFO is 2 or less, the value computed by the test */
+/* described above. */
+/* If INFO=3, this will just be 1/ulp. */
+
+/* INFO (output) INTEGER */
+/* =0: The input data pass the "safety checks". */
+/* =1: s*norm(A) + |w|*norm(B) > 1/safe_minimum. */
+/* =2: ulp*max( s*norm(A), |w|*norm(B) ) < safe_minimum */
+/* =3: same as INFO=2, but s and w could not be scaled so */
+/* as to compute the test. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ *result = 0.f;
+ scales = *scale;
+ wrs = *wr;
+ wis = *wi;
+
+/* Machine constants and norms */
+
+ safmin = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ absw = dabs(wrs) + dabs(wis);
+/* Computing MAX */
+ r__5 = (r__1 = a[a_dim1 + 1], dabs(r__1)) + (r__2 = a[a_dim1 + 2], dabs(
+ r__2)), r__6 = (r__3 = a[(a_dim1 << 1) + 1], dabs(r__3)) + (r__4 =
+ a[(a_dim1 << 1) + 2], dabs(r__4)), r__5 = max(r__5,r__6);
+ anorm = dmax(r__5,safmin);
+/* Computing MAX */
+ r__4 = (r__3 = b[b_dim1 + 1], dabs(r__3)), r__5 = (r__1 = b[(b_dim1 << 1)
+ + 1], dabs(r__1)) + (r__2 = b[(b_dim1 << 1) + 2], dabs(r__2)),
+ r__4 = max(r__4,r__5);
+ bnorm = dmax(r__4,safmin);
+
+/* Check for possible overflow. */
+
+ temp = safmin * bnorm * absw + safmin * anorm * scales;
+ if (temp >= 1.f) {
+
+/* Scale down to avoid overflow */
+
+ *info = 1;
+ temp = 1.f / temp;
+ scales *= temp;
+ wrs *= temp;
+ wis *= temp;
+ absw = dabs(wrs) + dabs(wis);
+ }
+/* Computing MAX */
+/* Computing MAX */
+ r__3 = scales * anorm, r__4 = absw * bnorm;
+ r__1 = ulp * dmax(r__3,r__4), r__2 = safmin * dmax(scales,absw);
+ s1 = dmax(r__1,r__2);
+
+/* Check for W and SCALE essentially zero. */
+
+ if (s1 < safmin) {
+ *info = 2;
+ if (scales < safmin && absw < safmin) {
+ *info = 3;
+ *result = 1.f / ulp;
+ return 0;
+ }
+
+/* Scale up to avoid underflow */
+
+/* Computing MAX */
+ r__1 = scales * anorm + absw * bnorm;
+ temp = 1.f / dmax(r__1,safmin);
+ scales *= temp;
+ wrs *= temp;
+ wis *= temp;
+ absw = dabs(wrs) + dabs(wis);
+/* Computing MAX */
+/* Computing MAX */
+ r__3 = scales * anorm, r__4 = absw * bnorm;
+ r__1 = ulp * dmax(r__3,r__4), r__2 = safmin * dmax(scales,absw);
+ s1 = dmax(r__1,r__2);
+ if (s1 < safmin) {
+ *info = 3;
+ *result = 1.f / ulp;
+ return 0;
+ }
+ }
+
+/* Compute C = s A - w B */
+
+ cr11 = scales * a[a_dim1 + 1] - wrs * b[b_dim1 + 1];
+ ci11 = -wis * b[b_dim1 + 1];
+ cr21 = scales * a[a_dim1 + 2];
+ cr12 = scales * a[(a_dim1 << 1) + 1] - wrs * b[(b_dim1 << 1) + 1];
+ ci12 = -wis * b[(b_dim1 << 1) + 1];
+ cr22 = scales * a[(a_dim1 << 1) + 2] - wrs * b[(b_dim1 << 1) + 2];
+ ci22 = -wis * b[(b_dim1 << 1) + 2];
+
+/* Compute the smallest singular value of s A - w B: */
+
+/* |det( s A - w B )| */
+/* sigma_min = ------------------ */
+/* norm( s A - w B ) */
+
+/* Computing MAX */
+ r__1 = dabs(cr11) + dabs(ci11) + dabs(cr21), r__2 = dabs(cr12) + dabs(
+ ci12) + dabs(cr22) + dabs(ci22), r__1 = max(r__1,r__2);
+ cnorm = dmax(r__1,safmin);
+ cscale = 1.f / sqrt(cnorm);
+ detr = cscale * cr11 * (cscale * cr22) - cscale * ci11 * (cscale * ci22)
+ - cscale * cr12 * (cscale * cr21);
+ deti = cscale * cr11 * (cscale * ci22) + cscale * ci11 * (cscale * cr22)
+ - cscale * ci12 * (cscale * cr21);
+ sigmin = dabs(detr) + dabs(deti);
+ *result = sigmin / s1;
+ return 0;
+
+/* End of SGET53 */
+
+} /* sget53_ */
diff --git a/TESTING/EIG/sget54.c b/TESTING/EIG/sget54.c
new file mode 100644
index 0000000..d557aac
--- /dev/null
+++ b/TESTING/EIG/sget54.c
@@ -0,0 +1,222 @@
+/* sget54.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b11 = 1.f;
+static real c_b12 = 0.f;
+static real c_b15 = -1.f;
+
+/* Subroutine */ int sget54_(integer *n, real *a, integer *lda, real *b,
+ integer *ldb, real *s, integer *lds, real *t, integer *ldt, real *u,
+ integer *ldu, real *v, integer *ldv, real *work, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, s_dim1, s_offset, t_dim1,
+ t_offset, u_dim1, u_offset, v_dim1, v_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ real dum[1], ulp, unfl;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real wnorm;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ real abnorm;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET54 checks a generalized decomposition of the form */
+
+/* A = U*S*V' and B = U*T* V' */
+
+/* where ' means transpose and U and V are orthogonal. */
+
+/* Specifically, */
+
+/* RESULT = ||( A - U*S*V', B - U*T*V' )|| / (||( A, B )||*n*ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, SGET54 does nothing. */
+/* It must be at least zero. */
+
+/* A (input) REAL array, dimension (LDA, N) */
+/* The original (unfactored) matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least N. */
+
+/* B (input) REAL array, dimension (LDB, N) */
+/* The original (unfactored) matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. It must be at least 1 */
+/* and at least N. */
+
+/* S (input) REAL array, dimension (LDS, N) */
+/* The factored matrix S. */
+
+/* LDS (input) INTEGER */
+/* The leading dimension of S. It must be at least 1 */
+/* and at least N. */
+
+/* T (input) REAL array, dimension (LDT, N) */
+/* The factored matrix T. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of T. It must be at least 1 */
+/* and at least N. */
+
+/* U (input) REAL array, dimension (LDU, N) */
+/* The orthogonal matrix on the left-hand side in the */
+/* decomposition. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+
+/* V (input) REAL array, dimension (LDV, N) */
+/* The orthogonal matrix on the left-hand side in the */
+/* decomposition. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of V. LDV must be at least N and */
+/* at least 1. */
+
+/* WORK (workspace) REAL array, dimension (3*N**2) */
+
+/* RESULT (output) REAL */
+/* The value RESULT, It is currently limited to 1/ulp, to */
+/* avoid overflow. Errors are flagged by RESULT=10/ulp. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ s_dim1 = *lds;
+ s_offset = 1 + s_dim1;
+ s -= s_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --work;
+
+ /* Function Body */
+ *result = 0.f;
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Constants */
+
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon") * slamch_("Base");
+
+/* compute the norm of (A,B) */
+
+ slacpy_("Full", n, n, &a[a_offset], lda, &work[1], n);
+ slacpy_("Full", n, n, &b[b_offset], ldb, &work[*n * *n + 1], n)
+ ;
+/* Computing MAX */
+ i__1 = *n << 1;
+ r__1 = slange_("1", n, &i__1, &work[1], n, dum);
+ abnorm = dmax(r__1,unfl);
+
+/* Compute W1 = A - U*S*V', and put in the array WORK(1:N*N) */
+
+ slacpy_(" ", n, n, &a[a_offset], lda, &work[1], n);
+ sgemm_("N", "N", n, n, n, &c_b11, &u[u_offset], ldu, &s[s_offset], lds, &
+ c_b12, &work[*n * *n + 1], n);
+
+ sgemm_("N", "C", n, n, n, &c_b15, &work[*n * *n + 1], n, &v[v_offset],
+ ldv, &c_b11, &work[1], n);
+
+/* Compute W2 = B - U*T*V', and put in the workarray W(N*N+1:2*N*N) */
+
+ slacpy_(" ", n, n, &b[b_offset], ldb, &work[*n * *n + 1], n);
+ sgemm_("N", "N", n, n, n, &c_b11, &u[u_offset], ldu, &t[t_offset], ldt, &
+ c_b12, &work[(*n << 1) * *n + 1], n);
+
+ sgemm_("N", "C", n, n, n, &c_b15, &work[(*n << 1) * *n + 1], n, &v[
+ v_offset], ldv, &c_b11, &work[*n * *n + 1], n);
+
+/* Compute norm(W)/ ( ulp*norm((A,B)) ) */
+
+ i__1 = *n << 1;
+ wnorm = slange_("1", n, &i__1, &work[1], n, dum);
+
+ if (abnorm > wnorm) {
+ *result = wnorm / abnorm / ((*n << 1) * ulp);
+ } else {
+ if (abnorm < 1.f) {
+/* Computing MIN */
+ r__1 = wnorm, r__2 = (*n << 1) * abnorm;
+ *result = dmin(r__1,r__2) / abnorm / ((*n << 1) * ulp);
+ } else {
+/* Computing MIN */
+ r__1 = wnorm / abnorm, r__2 = (real) (*n << 1);
+ *result = dmin(r__1,r__2) / ((*n << 1) * ulp);
+ }
+ }
+
+ return 0;
+
+/* End of SGET54 */
+
+} /* sget54_ */
diff --git a/TESTING/EIG/sglmts.c b/TESTING/EIG/sglmts.c
new file mode 100644
index 0000000..306aa05
--- /dev/null
+++ b/TESTING/EIG/sglmts.c
@@ -0,0 +1,199 @@
+/* sglmts.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b13 = -1.f;
+static real c_b15 = 1.f;
+
+/* Subroutine */ int sglmts_(integer *n, integer *m, integer *p, real *a,
+ real *af, integer *lda, real *b, real *bf, integer *ldb, real *d__,
+ real *df, real *x, real *u, real *work, integer *lwork, real *rwork,
+ real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1,
+ bf_offset;
+ real r__1;
+
+ /* Local variables */
+ real eps;
+ integer info;
+ real unfl, anorm, bnorm, dnorm;
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ extern doublereal sasum_(integer *, real *, integer *);
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ real xnorm, ynorm;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int sggglm_(integer *, integer *, integer *, real
+ *, integer *, real *, integer *, real *, real *, real *, real *,
+ integer *, integer *), slacpy_(char *, integer *, integer *, real
+ *, integer *, real *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGLMTS tests SGGGLM - a subroutine for solving the generalized */
+/* linear model problem. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices A and B. N >= 0. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of columns of the matrix B. P >= 0. */
+
+/* A (input) REAL array, dimension (LDA,M) */
+/* The N-by-M matrix A. */
+
+/* AF (workspace) REAL array, dimension (LDA,M) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF. LDA >= max(M,N). */
+
+/* B (input) REAL array, dimension (LDB,P) */
+/* The N-by-P matrix A. */
+
+/* BF (workspace) REAL array, dimension (LDB,P) */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the arrays B, BF. LDB >= max(P,N). */
+
+/* D (input) REAL array, dimension( N ) */
+/* On input, the left hand side of the GLM. */
+
+/* DF (workspace) REAL array, dimension( N ) */
+
+/* X (output) REAL array, dimension( M ) */
+/* solution vector X in the GLM problem. */
+
+/* U (output) REAL array, dimension( P ) */
+/* solution vector U in the GLM problem. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL */
+/* The test ratio: */
+/* norm( d - A*x - B*u ) */
+/* RESULT = ----------------------------------------- */
+/* (norm(A)+norm(B))*(norm(x)+norm(u))*EPS */
+
+/* ==================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ bf_dim1 = *ldb;
+ bf_offset = 1 + bf_dim1;
+ bf -= bf_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --d__;
+ --df;
+ --x;
+ --u;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+/* Computing MAX */
+ r__1 = slange_("1", n, m, &a[a_offset], lda, &rwork[1]);
+ anorm = dmax(r__1,unfl);
+/* Computing MAX */
+ r__1 = slange_("1", n, p, &b[b_offset], ldb, &rwork[1]);
+ bnorm = dmax(r__1,unfl);
+
+/* Copy the matrices A and B to the arrays AF and BF, */
+/* and the vector D the array DF. */
+
+ slacpy_("Full", n, m, &a[a_offset], lda, &af[af_offset], lda);
+ slacpy_("Full", n, p, &b[b_offset], ldb, &bf[bf_offset], ldb);
+ scopy_(n, &d__[1], &c__1, &df[1], &c__1);
+
+/* Solve GLM problem */
+
+ sggglm_(n, m, p, &af[af_offset], lda, &bf[bf_offset], ldb, &df[1], &x[1],
+ &u[1], &work[1], lwork, &info);
+
+/* Test the residual for the solution of LSE */
+
+/* norm( d - A*x - B*u ) */
+/* RESULT = ----------------------------------------- */
+/* (norm(A)+norm(B))*(norm(x)+norm(u))*EPS */
+
+ scopy_(n, &d__[1], &c__1, &df[1], &c__1);
+ sgemv_("No transpose", n, m, &c_b13, &a[a_offset], lda, &x[1], &c__1, &
+ c_b15, &df[1], &c__1);
+
+ sgemv_("No transpose", n, p, &c_b13, &b[b_offset], ldb, &u[1], &c__1, &
+ c_b15, &df[1], &c__1);
+
+ dnorm = sasum_(n, &df[1], &c__1);
+ xnorm = sasum_(m, &x[1], &c__1) + sasum_(p, &u[1], &c__1);
+ ynorm = anorm + bnorm;
+
+ if (xnorm <= 0.f) {
+ *result = 0.f;
+ } else {
+ *result = dnorm / ynorm / xnorm / eps;
+ }
+
+ return 0;
+
+/* End of SGLMTS */
+
+} /* sglmts_ */
diff --git a/TESTING/EIG/sgqrts.c b/TESTING/EIG/sgqrts.c
new file mode 100644
index 0000000..3e58bad
--- /dev/null
+++ b/TESTING/EIG/sgqrts.c
@@ -0,0 +1,324 @@
+/* sgqrts.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b9 = -1e10f;
+static real c_b19 = 0.f;
+static real c_b30 = -1.f;
+static real c_b31 = 1.f;
+
+/* Subroutine */ int sgqrts_(integer *n, integer *m, integer *p, real *a,
+ real *af, real *q, real *r__, integer *lda, real *taua, real *b, real
+ *bf, real *z__, real *t, real *bwk, integer *ldb, real *taub, real *
+ work, integer *lwork, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, r_dim1, r_offset, q_dim1,
+ q_offset, b_dim1, b_offset, bf_dim1, bf_offset, t_dim1, t_offset,
+ z_dim1, z_offset, bwk_dim1, bwk_offset, i__1, i__2;
+ real r__1;
+
+ /* Local variables */
+ real ulp;
+ integer info;
+ real unfl, resid;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm, bnorm;
+ extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *,
+ real *, real *, integer *, real *, real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int sggqrf_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, real *, real *, integer *
+, integer *), slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+ extern /* Subroutine */ int sorgqr_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *), sorgrq_(
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGQRTS tests SGGQRF, which computes the GQR factorization of an */
+/* N-by-M matrix A and a N-by-P matrix B: A = Q*R and B = Q*T*Z. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices A and B. N >= 0. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of columns of the matrix B. P >= 0. */
+
+/* A (input) REAL array, dimension (LDA,M) */
+/* The N-by-M matrix A. */
+
+/* AF (output) REAL array, dimension (LDA,N) */
+/* Details of the GQR factorization of A and B, as returned */
+/* by SGGQRF, see SGGQRF for further details. */
+
+/* Q (output) REAL array, dimension (LDA,N) */
+/* The M-by-M orthogonal matrix Q. */
+
+/* R (workspace) REAL array, dimension (LDA,MAX(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, R and Q. */
+/* LDA >= max(M,N). */
+
+/* TAUA (output) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by SGGQRF. */
+
+/* B (input) REAL array, dimension (LDB,P) */
+/* On entry, the N-by-P matrix A. */
+
+/* BF (output) REAL array, dimension (LDB,N) */
+/* Details of the GQR factorization of A and B, as returned */
+/* by SGGQRF, see SGGQRF for further details. */
+
+/* Z (output) REAL array, dimension (LDB,P) */
+/* The P-by-P orthogonal matrix Z. */
+
+/* T (workspace) REAL array, dimension (LDB,max(P,N)) */
+
+/* BWK (workspace) REAL array, dimension (LDB,N) */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the arrays B, BF, Z and T. */
+/* LDB >= max(P,N). */
+
+/* TAUB (output) REAL array, dimension (min(P,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by SGGRQF. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK, LWORK >= max(N,M,P)**2. */
+
+/* RWORK (workspace) REAL array, dimension (max(N,M,P)) */
+
+/* RESULT (output) REAL array, dimension (4) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP) */
+/* RESULT(2) = norm( T*Z - Q'*B ) / (MAX(P,N)*norm(B)*ULP) */
+/* RESULT(3) = norm( I - Q'*Q ) / ( M*ULP ) */
+/* RESULT(4) = norm( I - Z'*Z ) / ( P*ULP ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --taua;
+ bwk_dim1 = *ldb;
+ bwk_offset = 1 + bwk_dim1;
+ bwk -= bwk_offset;
+ t_dim1 = *ldb;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ z_dim1 = *ldb;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ bf_dim1 = *ldb;
+ bf_offset = 1 + bf_dim1;
+ bf -= bf_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --taub;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ ulp = slamch_("Precision");
+ unfl = slamch_("Safe minimum");
+
+/* Copy the matrix A to the array AF. */
+
+ slacpy_("Full", n, m, &a[a_offset], lda, &af[af_offset], lda);
+ slacpy_("Full", n, p, &b[b_offset], ldb, &bf[bf_offset], ldb);
+
+/* Computing MAX */
+ r__1 = slange_("1", n, m, &a[a_offset], lda, &rwork[1]);
+ anorm = dmax(r__1,unfl);
+/* Computing MAX */
+ r__1 = slange_("1", n, p, &b[b_offset], ldb, &rwork[1]);
+ bnorm = dmax(r__1,unfl);
+
+/* Factorize the matrices A and B in the arrays AF and BF. */
+
+ sggqrf_(n, m, p, &af[af_offset], lda, &taua[1], &bf[bf_offset], ldb, &
+ taub[1], &work[1], lwork, &info);
+
+/* Generate the N-by-N matrix Q */
+
+ slaset_("Full", n, n, &c_b9, &c_b9, &q[q_offset], lda);
+ i__1 = *n - 1;
+ slacpy_("Lower", &i__1, m, &af[af_dim1 + 2], lda, &q[q_dim1 + 2], lda);
+ i__1 = min(*n,*m);
+ sorgqr_(n, n, &i__1, &q[q_offset], lda, &taua[1], &work[1], lwork, &info);
+
+/* Generate the P-by-P matrix Z */
+
+ slaset_("Full", p, p, &c_b9, &c_b9, &z__[z_offset], ldb);
+ if (*n <= *p) {
+ if (*n > 0 && *n < *p) {
+ i__1 = *p - *n;
+ slacpy_("Full", n, &i__1, &bf[bf_offset], ldb, &z__[*p - *n + 1 +
+ z_dim1], ldb);
+ }
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ slacpy_("Lower", &i__1, &i__2, &bf[(*p - *n + 1) * bf_dim1 + 2],
+ ldb, &z__[*p - *n + 2 + (*p - *n + 1) * z_dim1], ldb);
+ }
+ } else {
+ if (*p > 1) {
+ i__1 = *p - 1;
+ i__2 = *p - 1;
+ slacpy_("Lower", &i__1, &i__2, &bf[*n - *p + 2 + bf_dim1], ldb, &
+ z__[z_dim1 + 2], ldb);
+ }
+ }
+ i__1 = min(*n,*p);
+ sorgrq_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, &
+ info);
+
+/* Copy R */
+
+ slaset_("Full", n, m, &c_b19, &c_b19, &r__[r_offset], lda);
+ slacpy_("Upper", n, m, &af[af_offset], lda, &r__[r_offset], lda);
+
+/* Copy T */
+
+ slaset_("Full", n, p, &c_b19, &c_b19, &t[t_offset], ldb);
+ if (*n <= *p) {
+ slacpy_("Upper", n, n, &bf[(*p - *n + 1) * bf_dim1 + 1], ldb, &t[(*p
+ - *n + 1) * t_dim1 + 1], ldb);
+ } else {
+ i__1 = *n - *p;
+ slacpy_("Full", &i__1, p, &bf[bf_offset], ldb, &t[t_offset], ldb);
+ slacpy_("Upper", p, p, &bf[*n - *p + 1 + bf_dim1], ldb, &t[*n - *p +
+ 1 + t_dim1], ldb);
+ }
+
+/* Compute R - Q'*A */
+
+ sgemm_("Transpose", "No transpose", n, m, n, &c_b30, &q[q_offset], lda, &
+ a[a_offset], lda, &c_b31, &r__[r_offset], lda);
+
+/* Compute norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP ) . */
+
+ resid = slange_("1", n, m, &r__[r_offset], lda, &rwork[1]);
+ if (anorm > 0.f) {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ result[1] = resid / (real) max(i__1,*n) / anorm / ulp;
+ } else {
+ result[1] = 0.f;
+ }
+
+/* Compute T*Z - Q'*B */
+
+ sgemm_("No Transpose", "No transpose", n, p, p, &c_b31, &t[t_offset], ldb,
+ &z__[z_offset], ldb, &c_b19, &bwk[bwk_offset], ldb);
+ sgemm_("Transpose", "No transpose", n, p, n, &c_b30, &q[q_offset], lda, &
+ b[b_offset], ldb, &c_b31, &bwk[bwk_offset], ldb);
+
+/* Compute norm( T*Z - Q'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */
+
+ resid = slange_("1", n, p, &bwk[bwk_offset], ldb, &rwork[1]);
+ if (bnorm > 0.f) {
+/* Computing MAX */
+ i__1 = max(1,*p);
+ result[2] = resid / (real) max(i__1,*n) / bnorm / ulp;
+ } else {
+ result[2] = 0.f;
+ }
+
+/* Compute I - Q'*Q */
+
+ slaset_("Full", n, n, &c_b19, &c_b31, &r__[r_offset], lda);
+ ssyrk_("Upper", "Transpose", n, n, &c_b30, &q[q_offset], lda, &c_b31, &
+ r__[r_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( N * ULP ) . */
+
+ resid = slansy_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
+ result[3] = resid / (real) max(1,*n) / ulp;
+
+/* Compute I - Z'*Z */
+
+ slaset_("Full", p, p, &c_b19, &c_b31, &t[t_offset], ldb);
+ ssyrk_("Upper", "Transpose", p, p, &c_b30, &z__[z_offset], ldb, &c_b31, &
+ t[t_offset], ldb);
+
+/* Compute norm( I - Z'*Z ) / ( P*ULP ) . */
+
+ resid = slansy_("1", "Upper", p, &t[t_offset], ldb, &rwork[1]);
+ result[4] = resid / (real) max(1,*p) / ulp;
+
+ return 0;
+
+/* End of SGQRTS */
+
+} /* sgqrts_ */
diff --git a/TESTING/EIG/sgrqts.c b/TESTING/EIG/sgrqts.c
new file mode 100644
index 0000000..2eb84c6
--- /dev/null
+++ b/TESTING/EIG/sgrqts.c
@@ -0,0 +1,327 @@
+/* sgrqts.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b9 = -1e10f;
+static real c_b19 = 0.f;
+static real c_b30 = -1.f;
+static real c_b31 = 1.f;
+
+/* Subroutine */ int sgrqts_(integer *m, integer *p, integer *n, real *a,
+ real *af, real *q, real *r__, integer *lda, real *taua, real *b, real
+ *bf, real *z__, real *t, real *bwk, integer *ldb, real *taub, real *
+ work, integer *lwork, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, r_dim1, r_offset, q_dim1,
+ q_offset, b_dim1, b_offset, bf_dim1, bf_offset, t_dim1, t_offset,
+ z_dim1, z_offset, bwk_dim1, bwk_offset, i__1, i__2;
+ real r__1;
+
+ /* Local variables */
+ real ulp;
+ integer info;
+ real unfl, resid;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm, bnorm;
+ extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *,
+ real *, real *, integer *, real *, real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int sggrqf_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, real *, real *, integer *
+, integer *), slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+ extern /* Subroutine */ int sorgqr_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *), sorgrq_(
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGRQTS tests SGGRQF, which computes the GRQ factorization of an */
+/* M-by-N matrix A and a P-by-N matrix B: A = R*Q and B = Z*T*Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The M-by-N matrix A. */
+
+/* AF (output) REAL array, dimension (LDA,N) */
+/* Details of the GRQ factorization of A and B, as returned */
+/* by SGGRQF, see SGGRQF for further details. */
+
+/* Q (output) REAL array, dimension (LDA,N) */
+/* The N-by-N orthogonal matrix Q. */
+
+/* R (workspace) REAL array, dimension (LDA,MAX(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, R and Q. */
+/* LDA >= max(M,N). */
+
+/* TAUA (output) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by SGGQRC. */
+
+/* B (input) REAL array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix A. */
+
+/* BF (output) REAL array, dimension (LDB,N) */
+/* Details of the GQR factorization of A and B, as returned */
+/* by SGGRQF, see SGGRQF for further details. */
+
+/* Z (output) REAL array, dimension (LDB,P) */
+/* The P-by-P orthogonal matrix Z. */
+
+/* T (workspace) REAL array, dimension (LDB,max(P,N)) */
+
+/* BWK (workspace) REAL array, dimension (LDB,N) */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the arrays B, BF, Z and T. */
+/* LDB >= max(P,N). */
+
+/* TAUB (output) REAL array, dimension (min(P,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by SGGRQF. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK, LWORK >= max(M,P,N)**2. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (4) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP) */
+/* RESULT(2) = norm( T*Q - Z'*B ) / (MAX(P,N)*norm(B)*ULP) */
+/* RESULT(3) = norm( I - Q'*Q ) / ( N*ULP ) */
+/* RESULT(4) = norm( I - Z'*Z ) / ( P*ULP ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --taua;
+ bwk_dim1 = *ldb;
+ bwk_offset = 1 + bwk_dim1;
+ bwk -= bwk_offset;
+ t_dim1 = *ldb;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ z_dim1 = *ldb;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ bf_dim1 = *ldb;
+ bf_offset = 1 + bf_dim1;
+ bf -= bf_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --taub;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ ulp = slamch_("Precision");
+ unfl = slamch_("Safe minimum");
+
+/* Copy the matrix A to the array AF. */
+
+ slacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+ slacpy_("Full", p, n, &b[b_offset], ldb, &bf[bf_offset], ldb);
+
+/* Computing MAX */
+ r__1 = slange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ anorm = dmax(r__1,unfl);
+/* Computing MAX */
+ r__1 = slange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
+ bnorm = dmax(r__1,unfl);
+
+/* Factorize the matrices A and B in the arrays AF and BF. */
+
+ sggrqf_(m, p, n, &af[af_offset], lda, &taua[1], &bf[bf_offset], ldb, &
+ taub[1], &work[1], lwork, &info);
+
+/* Generate the N-by-N matrix Q */
+
+ slaset_("Full", n, n, &c_b9, &c_b9, &q[q_offset], lda);
+ if (*m <= *n) {
+ if (*m > 0 && *m < *n) {
+ i__1 = *n - *m;
+ slacpy_("Full", m, &i__1, &af[af_offset], lda, &q[*n - *m + 1 +
+ q_dim1], lda);
+ }
+ if (*m > 1) {
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ slacpy_("Lower", &i__1, &i__2, &af[(*n - *m + 1) * af_dim1 + 2],
+ lda, &q[*n - *m + 2 + (*n - *m + 1) * q_dim1], lda);
+ }
+ } else {
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ slacpy_("Lower", &i__1, &i__2, &af[*m - *n + 2 + af_dim1], lda, &
+ q[q_dim1 + 2], lda);
+ }
+ }
+ i__1 = min(*m,*n);
+ sorgrq_(n, n, &i__1, &q[q_offset], lda, &taua[1], &work[1], lwork, &info);
+
+/* Generate the P-by-P matrix Z */
+
+ slaset_("Full", p, p, &c_b9, &c_b9, &z__[z_offset], ldb);
+ if (*p > 1) {
+ i__1 = *p - 1;
+ slacpy_("Lower", &i__1, n, &bf[bf_dim1 + 2], ldb, &z__[z_dim1 + 2],
+ ldb);
+ }
+ i__1 = min(*p,*n);
+ sorgqr_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, &
+ info);
+
+/* Copy R */
+
+ slaset_("Full", m, n, &c_b19, &c_b19, &r__[r_offset], lda);
+ if (*m <= *n) {
+ slacpy_("Upper", m, m, &af[(*n - *m + 1) * af_dim1 + 1], lda, &r__[(*
+ n - *m + 1) * r_dim1 + 1], lda);
+ } else {
+ i__1 = *m - *n;
+ slacpy_("Full", &i__1, n, &af[af_offset], lda, &r__[r_offset], lda);
+ slacpy_("Upper", n, n, &af[*m - *n + 1 + af_dim1], lda, &r__[*m - *n
+ + 1 + r_dim1], lda);
+ }
+
+/* Copy T */
+
+ slaset_("Full", p, n, &c_b19, &c_b19, &t[t_offset], ldb);
+ slacpy_("Upper", p, n, &bf[bf_offset], ldb, &t[t_offset], ldb);
+
+/* Compute R - A*Q' */
+
+ sgemm_("No transpose", "Transpose", m, n, n, &c_b30, &a[a_offset], lda, &
+ q[q_offset], lda, &c_b31, &r__[r_offset], lda);
+
+/* Compute norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP ) . */
+
+ resid = slange_("1", m, n, &r__[r_offset], lda, &rwork[1]);
+ if (anorm > 0.f) {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ result[1] = resid / (real) max(i__1,*n) / anorm / ulp;
+ } else {
+ result[1] = 0.f;
+ }
+
+/* Compute T*Q - Z'*B */
+
+ sgemm_("Transpose", "No transpose", p, n, p, &c_b31, &z__[z_offset], ldb,
+ &b[b_offset], ldb, &c_b19, &bwk[bwk_offset], ldb);
+ sgemm_("No transpose", "No transpose", p, n, n, &c_b31, &t[t_offset], ldb,
+ &q[q_offset], lda, &c_b30, &bwk[bwk_offset], ldb);
+
+/* Compute norm( T*Q - Z'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */
+
+ resid = slange_("1", p, n, &bwk[bwk_offset], ldb, &rwork[1]);
+ if (bnorm > 0.f) {
+/* Computing MAX */
+ i__1 = max(1,*p);
+ result[2] = resid / (real) max(i__1,*m) / bnorm / ulp;
+ } else {
+ result[2] = 0.f;
+ }
+
+/* Compute I - Q*Q' */
+
+ slaset_("Full", n, n, &c_b19, &c_b31, &r__[r_offset], lda);
+ ssyrk_("Upper", "No Transpose", n, n, &c_b30, &q[q_offset], lda, &c_b31, &
+ r__[r_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( N * ULP ) . */
+
+ resid = slansy_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
+ result[3] = resid / (real) max(1,*n) / ulp;
+
+/* Compute I - Z'*Z */
+
+ slaset_("Full", p, p, &c_b19, &c_b31, &t[t_offset], ldb);
+ ssyrk_("Upper", "Transpose", p, p, &c_b30, &z__[z_offset], ldb, &c_b31, &
+ t[t_offset], ldb);
+
+/* Compute norm( I - Z'*Z ) / ( P*ULP ) . */
+
+ resid = slansy_("1", "Upper", p, &t[t_offset], ldb, &rwork[1]);
+ result[4] = resid / (real) max(1,*p) / ulp;
+
+ return 0;
+
+/* End of SGRQTS */
+
+} /* sgrqts_ */
diff --git a/TESTING/EIG/sgsvts.c b/TESTING/EIG/sgsvts.c
new file mode 100644
index 0000000..800ab11
--- /dev/null
+++ b/TESTING/EIG/sgsvts.c
@@ -0,0 +1,396 @@
+/* sgsvts.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b17 = 1.f;
+static real c_b18 = 0.f;
+static real c_b44 = -1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int sgsvts_(integer *m, integer *p, integer *n, real *a,
+ real *af, integer *lda, real *b, real *bf, integer *ldb, real *u,
+ integer *ldu, real *v, integer *ldv, real *q, integer *ldq, real *
+ alpha, real *beta, real *r__, integer *ldr, integer *iwork, real *
+ work, integer *lwork, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1,
+ bf_offset, q_dim1, q_offset, r_dim1, r_offset, u_dim1, u_offset,
+ v_dim1, v_offset, i__1, i__2;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j, k, l;
+ real ulp;
+ integer info;
+ real unfl, temp, resid;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm, bnorm;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), ssyrk_(char *, char *, integer *, integer *, real *,
+ real *, integer *, real *, real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *), sggsvd_(
+ char *, char *, char *, integer *, integer *, integer *, integer *
+, integer *, real *, integer *, real *, integer *, real *, real *,
+ real *, integer *, real *, integer *, real *, integer *, real *,
+ integer *, integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+ real ulpinv;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGSVTS tests SGGSVD, which computes the GSVD of an M-by-N matrix A */
+/* and a P-by-N matrix B: */
+/* U'*A*Q = D1*R and V'*B*Q = D2*R. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,M) */
+/* The M-by-N matrix A. */
+
+/* AF (output) REAL array, dimension (LDA,N) */
+/* Details of the GSVD of A and B, as returned by SGGSVD, */
+/* see SGGSVD for further details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A and AF. */
+/* LDA >= max( 1,M ). */
+
+/* B (input) REAL array, dimension (LDB,P) */
+/* On entry, the P-by-N matrix B. */
+
+/* BF (output) REAL array, dimension (LDB,N) */
+/* Details of the GSVD of A and B, as returned by SGGSVD, */
+/* see SGGSVD for further details. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the arrays B and BF. */
+/* LDB >= max(1,P). */
+
+/* U (output) REAL array, dimension(LDU,M) */
+/* The M by M orthogonal matrix U. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M). */
+
+/* V (output) REAL array, dimension(LDV,M) */
+/* The P by P orthogonal matrix V. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. LDV >= max(1,P). */
+
+/* Q (output) REAL array, dimension(LDQ,N) */
+/* The N by N orthogonal matrix Q. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* ALPHA (output) REAL array, dimension (N) */
+/* BETA (output) REAL array, dimension (N) */
+/* The generalized singular value pairs of A and B, the */
+/* ``diagonal'' matrices D1 and D2 are constructed from */
+/* ALPHA and BETA, see subroutine SGGSVD for details. */
+
+/* R (output) REAL array, dimension(LDQ,N) */
+/* The upper triangular matrix R. */
+
+/* LDR (input) INTEGER */
+/* The leading dimension of the array R. LDR >= max(1,N). */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK, */
+/* LWORK >= max(M,P,N)*max(M,P,N). */
+
+/* RWORK (workspace) REAL array, dimension (max(M,P,N)) */
+
+/* RESULT (output) REAL array, dimension (6) */
+/* The test ratios: */
+/* RESULT(1) = norm( U'*A*Q - D1*R ) / ( MAX(M,N)*norm(A)*ULP) */
+/* RESULT(2) = norm( V'*B*Q - D2*R ) / ( MAX(P,N)*norm(B)*ULP) */
+/* RESULT(3) = norm( I - U'*U ) / ( M*ULP ) */
+/* RESULT(4) = norm( I - V'*V ) / ( P*ULP ) */
+/* RESULT(5) = norm( I - Q'*Q ) / ( N*ULP ) */
+/* RESULT(6) = 0 if ALPHA is in decreasing order; */
+/* = ULPINV otherwise. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ bf_dim1 = *ldb;
+ bf_offset = 1 + bf_dim1;
+ bf -= bf_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --alpha;
+ --beta;
+ r_dim1 = *ldr;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ --iwork;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ ulp = slamch_("Precision");
+ ulpinv = 1.f / ulp;
+ unfl = slamch_("Safe minimum");
+
+/* Copy the matrix A to the array AF. */
+
+ slacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+ slacpy_("Full", p, n, &b[b_offset], ldb, &bf[bf_offset], ldb);
+
+/* Computing MAX */
+ r__1 = slange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ anorm = dmax(r__1,unfl);
+/* Computing MAX */
+ r__1 = slange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
+ bnorm = dmax(r__1,unfl);
+
+/* Factorize the matrices A and B in the arrays AF and BF. */
+
+ sggsvd_("U", "V", "Q", m, n, p, &k, &l, &af[af_offset], lda, &bf[
+ bf_offset], ldb, &alpha[1], &beta[1], &u[u_offset], ldu, &v[
+ v_offset], ldv, &q[q_offset], ldq, &work[1], &iwork[1], &info);
+
+/* Copy R */
+
+/* Computing MIN */
+ i__2 = k + l;
+ i__1 = min(i__2,*m);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = k + l;
+ for (j = i__; j <= i__2; ++j) {
+ r__[i__ + j * r_dim1] = af[i__ + (*n - k - l + j) * af_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+
+ if (*m - k - l < 0) {
+ i__1 = k + l;
+ for (i__ = *m + 1; i__ <= i__1; ++i__) {
+ i__2 = k + l;
+ for (j = i__; j <= i__2; ++j) {
+ r__[i__ + j * r_dim1] = bf[i__ - k + (*n - k - l + j) *
+ bf_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+/* Compute A:= U'*A*Q - D1*R */
+
+ sgemm_("No transpose", "No transpose", m, n, n, &c_b17, &a[a_offset], lda,
+ &q[q_offset], ldq, &c_b18, &work[1], lda)
+ ;
+
+ sgemm_("Transpose", "No transpose", m, n, m, &c_b17, &u[u_offset], ldu, &
+ work[1], lda, &c_b18, &a[a_offset], lda);
+
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = k + l;
+ for (j = i__; j <= i__2; ++j) {
+ a[i__ + (*n - k - l + j) * a_dim1] -= r__[i__ + j * r_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* Computing MIN */
+ i__2 = k + l;
+ i__1 = min(i__2,*m);
+ for (i__ = k + 1; i__ <= i__1; ++i__) {
+ i__2 = k + l;
+ for (j = i__; j <= i__2; ++j) {
+ a[i__ + (*n - k - l + j) * a_dim1] -= alpha[i__] * r__[i__ + j *
+ r_dim1];
+/* L70: */
+ }
+/* L80: */
+ }
+
+/* Compute norm( U'*A*Q - D1*R ) / ( MAX(1,M,N)*norm(A)*ULP ) . */
+
+ resid = slange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+
+ if (anorm > 0.f) {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ result[1] = resid / (real) max(i__1,*n) / anorm / ulp;
+ } else {
+ result[1] = 0.f;
+ }
+
+/* Compute B := V'*B*Q - D2*R */
+
+ sgemm_("No transpose", "No transpose", p, n, n, &c_b17, &b[b_offset], ldb,
+ &q[q_offset], ldq, &c_b18, &work[1], ldb)
+ ;
+
+ sgemm_("Transpose", "No transpose", p, n, p, &c_b17, &v[v_offset], ldv, &
+ work[1], ldb, &c_b18, &b[b_offset], ldb);
+
+ i__1 = l;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = l;
+ for (j = i__; j <= i__2; ++j) {
+ b[i__ + (*n - l + j) * b_dim1] -= beta[k + i__] * r__[k + i__ + (
+ k + j) * r_dim1];
+/* L90: */
+ }
+/* L100: */
+ }
+
+/* Compute norm( V'*B*Q - D2*R ) / ( MAX(P,N)*norm(B)*ULP ) . */
+
+ resid = slange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
+ if (bnorm > 0.f) {
+/* Computing MAX */
+ i__1 = max(1,*p);
+ result[2] = resid / (real) max(i__1,*n) / bnorm / ulp;
+ } else {
+ result[2] = 0.f;
+ }
+
+/* Compute I - U'*U */
+
+ slaset_("Full", m, m, &c_b18, &c_b17, &work[1], ldq);
+ ssyrk_("Upper", "Transpose", m, m, &c_b44, &u[u_offset], ldu, &c_b17, &
+ work[1], ldu);
+
+/* Compute norm( I - U'*U ) / ( M * ULP ) . */
+
+ resid = slansy_("1", "Upper", m, &work[1], ldu, &rwork[1]);
+ result[3] = resid / (real) max(1,*m) / ulp;
+
+/* Compute I - V'*V */
+
+ slaset_("Full", p, p, &c_b18, &c_b17, &work[1], ldv);
+ ssyrk_("Upper", "Transpose", p, p, &c_b44, &v[v_offset], ldv, &c_b17, &
+ work[1], ldv);
+
+/* Compute norm( I - V'*V ) / ( P * ULP ) . */
+
+ resid = slansy_("1", "Upper", p, &work[1], ldv, &rwork[1]);
+ result[4] = resid / (real) max(1,*p) / ulp;
+
+/* Compute I - Q'*Q */
+
+ slaset_("Full", n, n, &c_b18, &c_b17, &work[1], ldq);
+ ssyrk_("Upper", "Transpose", n, n, &c_b44, &q[q_offset], ldq, &c_b17, &
+ work[1], ldq);
+
+/* Compute norm( I - Q'*Q ) / ( N * ULP ) . */
+
+ resid = slansy_("1", "Upper", n, &work[1], ldq, &rwork[1]);
+ result[5] = resid / (real) max(1,*n) / ulp;
+
+/* Check sorting */
+
+ scopy_(n, &alpha[1], &c__1, &work[1], &c__1);
+/* Computing MIN */
+ i__2 = k + l;
+ i__1 = min(i__2,*m);
+ for (i__ = k + 1; i__ <= i__1; ++i__) {
+ j = iwork[i__];
+ if (i__ != j) {
+ temp = work[i__];
+ work[i__] = work[j];
+ work[j] = temp;
+ }
+/* L110: */
+ }
+
+ result[6] = 0.f;
+/* Computing MIN */
+ i__2 = k + l;
+ i__1 = min(i__2,*m) - 1;
+ for (i__ = k + 1; i__ <= i__1; ++i__) {
+ if (work[i__] < work[i__ + 1]) {
+ result[6] = ulpinv;
+ }
+/* L120: */
+ }
+
+ return 0;
+
+/* End of SGSVTS */
+
+} /* sgsvts_ */
diff --git a/TESTING/EIG/shst01.c b/TESTING/EIG/shst01.c
new file mode 100644
index 0000000..62eab84
--- /dev/null
+++ b/TESTING/EIG/shst01.c
@@ -0,0 +1,192 @@
+/* shst01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b7 = 1.f;
+static real c_b8 = 0.f;
+static real c_b11 = -1.f;
+
+/* Subroutine */ int shst01_(integer *n, integer *ilo, integer *ihi, real *a,
+ integer *lda, real *h__, integer *ldh, real *q, integer *ldq, real *
+ work, integer *lwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, q_dim1, q_offset;
+ real r__1, r__2;
+
+ /* Local variables */
+ real eps, unfl, ovfl;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm;
+ extern /* Subroutine */ int sort01_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, real *);
+ real wnorm;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+ integer ldwork;
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SHST01 tests the reduction of a general matrix A to upper Hessenberg */
+/* form: A = Q*H*Q'. Two test ratios are computed; */
+
+/* RESULT(1) = norm( A - Q*H*Q' ) / ( norm(A) * N * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( N * EPS ) */
+
+/* The matrix Q is assumed to be given explicitly as it would be */
+/* following SGEHRD + SORGHR. */
+
+/* In this version, ILO and IHI are not used and are assumed to be 1 and */
+/* N, respectively. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* A is assumed to be upper triangular in rows and columns */
+/* 1:ILO-1 and IHI+1:N, so Q differs from the identity only in */
+/* rows and columns ILO+1:IHI. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The original n by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* H (input) REAL array, dimension (LDH,N) */
+/* The upper Hessenberg matrix H from the reduction A = Q*H*Q' */
+/* as computed by SGEHRD. H is assumed to be zero below the */
+/* first subdiagonal. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH >= max(1,N). */
+
+/* Q (input) REAL array, dimension (LDQ,N) */
+/* The orthogonal matrix Q from the reduction A = Q*H*Q' as */
+/* computed by SGEHRD + SORGHR. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= 2*N*N. */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* RESULT(1) = norm( A - Q*H*Q' ) / ( norm(A) * N * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( N * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+ --result;
+
+ /* Function Body */
+ if (*n <= 0) {
+ result[1] = 0.f;
+ result[2] = 0.f;
+ return 0;
+ }
+
+ unfl = slamch_("Safe minimum");
+ eps = slamch_("Precision");
+ ovfl = 1.f / unfl;
+ slabad_(&unfl, &ovfl);
+ smlnum = unfl * *n / eps;
+
+/* Test 1: Compute norm( A - Q*H*Q' ) / ( norm(A) * N * EPS ) */
+
+/* Copy A to WORK */
+
+ ldwork = max(1,*n);
+ slacpy_(" ", n, n, &a[a_offset], lda, &work[1], &ldwork);
+
+/* Compute Q*H */
+
+ sgemm_("No transpose", "No transpose", n, n, n, &c_b7, &q[q_offset], ldq,
+ &h__[h_offset], ldh, &c_b8, &work[ldwork * *n + 1], &ldwork);
+
+/* Compute A - Q*H*Q' */
+
+ sgemm_("No transpose", "Transpose", n, n, n, &c_b11, &work[ldwork * *n +
+ 1], &ldwork, &q[q_offset], ldq, &c_b7, &work[1], &ldwork);
+
+/* Computing MAX */
+ r__1 = slange_("1", n, n, &a[a_offset], lda, &work[ldwork * *n + 1]);
+ anorm = dmax(r__1,unfl);
+ wnorm = slange_("1", n, n, &work[1], &ldwork, &work[ldwork * *n + 1]);
+
+/* Note that RESULT(1) cannot overflow and is bounded by 1/(N*EPS) */
+
+/* Computing MAX */
+ r__1 = smlnum, r__2 = anorm * eps;
+ result[1] = dmin(wnorm,anorm) / dmax(r__1,r__2) / *n;
+
+/* Test 2: Compute norm( I - Q'*Q ) / ( N * EPS ) */
+
+ sort01_("Columns", n, n, &q[q_offset], ldq, &work[1], lwork, &result[2]);
+
+ return 0;
+
+/* End of SHST01 */
+
+} /* shst01_ */
diff --git a/TESTING/EIG/slafts.c b/TESTING/EIG/slafts.c
new file mode 100644
index 0000000..b0a97d3
--- /dev/null
+++ b/TESTING/EIG/slafts.c
@@ -0,0 +1,217 @@
+/* slafts.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__4 = 4;
+
+/* Subroutine */ int slafts_(char *type__, integer *m, integer *n, integer *
+ imat, integer *ntests, real *result, integer *iseed, real *thresh,
+ integer *iounit, integer *ie)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
+ ",0p,f8.2)";
+ static char fmt_9998[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
+ ",1p,e10.3)";
+ static char fmt_9997[] = "(1x,i5,\002 x\002,i5,\002 matrix, type=\002,"
+ "i2,\002, s\002,\002eed=\002,3(i4,\002,\002),i4,\002: result \002"
+ ",i3,\002 is\002,0p,f8.2)";
+ static char fmt_9996[] = "(1x,i5,\002 x\002,i5,\002 matrix, type=\002,"
+ "i2,\002, s\002,\002eed=\002,3(i4,\002,\002),i4,\002: result \002"
+ ",i3,\002 is\002,1p,e10.3)";
+
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer k;
+ extern /* Subroutine */ int slahd2_(integer *, char *);
+
+ /* Fortran I/O blocks */
+ static cilist io___2 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___3 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___4 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___5 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* -- LAPACK auxiliary test routine (version 3.1.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* April 2009 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAFTS tests the result vector against the threshold value to */
+/* see which tests for this matrix type failed to pass the threshold. */
+/* Output is to the file given by unit IOUNIT. */
+
+/* Arguments */
+/* ========= */
+
+/* TYPE - CHARACTER*3 */
+/* On entry, TYPE specifies the matrix type to be used in the */
+/* printed messages. */
+/* Not modified. */
+
+/* N - INTEGER */
+/* On entry, N specifies the order of the test matrix. */
+/* Not modified. */
+
+/* IMAT - INTEGER */
+/* On entry, IMAT specifies the type of the test matrix. */
+/* A listing of the different types is printed by SLAHD2 */
+/* to the output file if a test fails to pass the threshold. */
+/* Not modified. */
+
+/* NTESTS - INTEGER */
+/* On entry, NTESTS is the number of tests performed on the */
+/* subroutines in the path given by TYPE. */
+/* Not modified. */
+
+/* RESULT - REAL array of dimension( NTESTS ) */
+/* On entry, RESULT contains the test ratios from the tests */
+/* performed in the calling program. */
+/* Not modified. */
+
+/* ISEED - INTEGER array of dimension( 4 ) */
+/* Contains the random seed that generated the matrix used */
+/* for the tests whose ratios are in RESULT. */
+/* Not modified. */
+
+/* THRESH - REAL */
+/* On entry, THRESH specifies the acceptable threshold of the */
+/* test ratios. If RESULT( K ) > THRESH, then the K-th test */
+/* did not pass the threshold and a message will be printed. */
+/* Not modified. */
+
+/* IOUNIT - INTEGER */
+/* On entry, IOUNIT specifies the unit number of the file */
+/* to which the messages are printed. */
+/* Not modified. */
+
+/* IE - INTEGER */
+/* On entry, IE contains the number of tests which have */
+/* failed to pass the threshold so far. */
+/* Updated on exit if any of the ratios in RESULT also fail. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iseed;
+ --result;
+
+ /* Function Body */
+ if (*m == *n) {
+
+/* Output for square matrices: */
+
+ i__1 = *ntests;
+ for (k = 1; k <= i__1; ++k) {
+ if (result[k] >= *thresh) {
+
+/* If this is the first test to fail, call SLAHD2 */
+/* to print a header to the data file. */
+
+ if (*ie == 0) {
+ slahd2_(iounit, type__);
+ }
+ ++(*ie);
+ if (result[k] < 1e4f) {
+ io___2.ciunit = *iounit;
+ s_wsfe(&io___2);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k], (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___3.ciunit = *iounit;
+ s_wsfe(&io___3);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k], (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ }
+/* L10: */
+ }
+ } else {
+
+/* Output for rectangular matrices */
+
+ i__1 = *ntests;
+ for (k = 1; k <= i__1; ++k) {
+ if (result[k] >= *thresh) {
+
+/* If this is the first test to fail, call SLAHD2 */
+/* to print a header to the data file. */
+
+ if (*ie == 0) {
+ slahd2_(iounit, type__);
+ }
+ ++(*ie);
+ if (result[k] < 1e4f) {
+ io___4.ciunit = *iounit;
+ s_wsfe(&io___4);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k], (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___5.ciunit = *iounit;
+ s_wsfe(&io___5);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k], (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ }
+/* L20: */
+ }
+
+ }
+ return 0;
+
+/* End of SLAFTS */
+
+} /* slafts_ */
diff --git a/TESTING/EIG/slahd2.c b/TESTING/EIG/slahd2.c
new file mode 100644
index 0000000..f92bf44
--- /dev/null
+++ b/TESTING/EIG/slahd2.c
@@ -0,0 +1,678 @@
+/* slahd2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int slahd2_(integer *iounit, char *path)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002: no header available\002)";
+ static char fmt_9998[] = "(/1x,a3,\002 -- Real Non-symmetric eigenvalue "
+ "problem\002)";
+ static char fmt_9988[] = "(\002 Matrix types (see xCHKHS for details):"
+ " \002)";
+ static char fmt_9987[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 \002,\002 5=Diagonal: geom"
+ "etr. spaced entries.\002,/\002 2=Identity matrix. "
+ " \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
+ "/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
+ " 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
+ "l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
+ "ll, evenly spaced.\002)";
+ static char fmt_9986[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
+ " 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
+ "l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
+ "d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
+ "red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
+ "vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,a6,"
+ "/\002 12=Well-cond., random complex \002,a6,\002 \002,\002 17="
+ "Ill-cond., large rand. complx \002,a4,/\002 13=Ill-condi\002,"
+ "\002tioned, evenly spaced. \002,\002 18=Ill-cond., small ran"
+ "d.\002,\002 complx \002,a4)";
+ static char fmt_9985[] = "(\002 19=Matrix with random O(1) entries. "
+ " \002,\002 21=Matrix \002,\002with small random entries.\002,"
+ "/\002 20=Matrix with large ran\002,\002dom entries. \002)";
+ static char fmt_9984[] = "(/\002 Tests performed: \002,\002(H is Hesse"
+ "nberg, T is Schur,\002,\002 U and Z are \002,a,\002,\002,/20x,a"
+ ",\002, W is a diagonal matr\002,\002ix of eigenvalues,\002,/20x"
+ ",\002L and R are the left and rig\002,\002ht eigenvector matrice"
+ "s)\002,/\002 1 = | A - U H U\002,a1,\002 |\002,\002 / ( |A| n u"
+ "lp ) \002,\002 2 = | I - U U\002,a1,\002 | / \002,\002("
+ " n ulp )\002,/\002 3 = | H - Z T Z\002,a1,\002 | / ( |H| n ulp"
+ " \002,\002) \002,\002 4 = | I - Z Z\002,a1,\002 | / ( n"
+ " ulp )\002,/\002 5 = | A - UZ T (UZ)\002,a1,\002 | / ( |A| n ul"
+ "p ) \002,\002 6 = | I - UZ (UZ)\002,a1,\002 | / ( n ulp "
+ ")\002,/\002 7 = | T(\002,\002e.vects.) - T(no e.vects.) | / ( |"
+ "T| ulp )\002,/\002 8 = | W\002,\002(e.vects.) - W(no e.vects.) "
+ "| / ( |W| ulp )\002,/\002 9 = | \002,\002TR - RW | / ( |T| |R| "
+ "ulp ) \002,\002 10 = | LT - WL | / (\002,\002 |T| |L| ulp "
+ ")\002,/\002 11= |HX - XW| / (|H| |X| ulp) (inv.\002,\002it)\002,"
+ "\002 12= |YH - WY| / (|H| |Y| ulp) (inv.it)\002)";
+ static char fmt_9997[] = "(/1x,a3,\002 -- Complex Non-symmetric eigenval"
+ "ue problem\002)";
+ static char fmt_9996[] = "(/1x,a3,\002 -- Real Symmetric eigenvalue prob"
+ "lem\002)";
+ static char fmt_9983[] = "(\002 Matrix types (see xDRVST for details):"
+ " \002)";
+ static char fmt_9982[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 \002,\002 5=Diagonal: clus"
+ "tered entries.\002,/\002 2=\002,\002Identity matrix. "
+ " \002,\002 6=Diagonal: lar\002,\002ge, evenly spaced"
+ ".\002,/\002 3=Diagonal: evenly spaced entri\002,\002es. \002,"
+ "\002 7=Diagonal: small, evenly spaced.\002,/\002 4=D\002,\002i"
+ "agonal: geometr. spaced entries.\002)";
+ static char fmt_9981[] = "(\002 Dense \002,a,\002 Matrices:\002,/\002 8"
+ "=Evenly spaced eigen\002,\002vals. \002,\002 12=Small"
+ ", evenly spaced eigenvals.\002,/\002 9=Geometrically spaced eig"
+ "envals. \002,\002 13=Matrix \002,\002with random O(1) entrie"
+ "s.\002,/\002 10=Clustered eigenvalues.\002,\002 "
+ "\002,\002 14=Matrix with large random entries.\002,/\002 11=Larg"
+ "e, evenly spaced eigenvals. \002,\002 15=Matrix \002,\002wit"
+ "h small random entries.\002)";
+ static char fmt_9968[] = "(/\002 Tests performed: See sdrvst.f\002)";
+ static char fmt_9995[] = "(/1x,a3,\002 -- Complex Hermitian eigenvalue p"
+ "roblem\002)";
+ static char fmt_9967[] = "(/\002 Tests performed: See cdrvst.f\002)";
+ static char fmt_9992[] = "(/1x,a3,\002 -- Real Symmetric Generalized eig"
+ "envalue \002,\002problem\002)";
+ static char fmt_9980[] = "(\002 Matrix types (see xDRVSG for details):"
+ " \002)";
+ static char fmt_9979[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 \002,\002 5=Diagonal: clus"
+ "tered entries.\002,/\002 2=\002,\002Identity matrix. "
+ " \002,\002 6=Diagonal: lar\002,\002ge, evenly spaced"
+ ".\002,/\002 3=Diagonal: evenly spaced entri\002,\002es. \002,"
+ "\002 7=Diagonal: small, evenly spaced.\002,/\002 4=D\002,\002i"
+ "agonal: geometr. spaced entries.\002)";
+ static char fmt_9978[] = "(\002 Dense or Banded \002,a,\002 Matrices:"
+ " \002,/\002 8=Evenly spaced eigenvals. \002,\002 15=Mat"
+ "rix with small random entries.\002,/\002 9=Geometrically spaced"
+ " eigenvals. \002,\002 16=Evenly spaced eigenvals, KA=1, KB=1"
+ ".\002,/\002 10=Clustered eigenvalues. \002,\002 17=Eve"
+ "nly spaced eigenvals, KA=2, KB=1.\002,/\002 11=Large, evenly spa"
+ "ced eigenvals. \002,\002 18=Evenly spaced eigenvals, KA=2, KB=2."
+ "\002,/\002 12=Small, evenly spaced eigenvals. \002,\002 19=Even"
+ "ly spaced eigenvals, KA=3, KB=1.\002,/\002 13=Matrix with random"
+ " O(1) entries. \002,\002 20=Evenly spaced eigenvals, KA=3, KB=2"
+ ".\002,/\002 14=Matrix with large random entries.\002,\002 21=Eve"
+ "nly spaced eigenvals, KA=3, KB=3.\002)";
+ static char fmt_9977[] = "(/\002 Tests performed: \002,/\002( For each"
+ " pair (A,B), where A is of the given type \002,/\002 and B is a "
+ "random well-conditioned matrix. D is \002,/\002 diagonal, and Z "
+ "is orthogonal. )\002,/\002 1 = SSYGV, with ITYPE=1 and UPLO='U'"
+ ":\002,\002 | A Z - B Z D | / ( |A| |Z| n ulp ) \002,/\002 2"
+ " = SSPGV, with ITYPE=1 and UPLO='U':\002,\002 | A Z - B Z D | /"
+ " ( |A| |Z| n ulp ) \002,/\002 3 = SSBGV, with ITYPE=1 and UP"
+ "LO='U':\002,\002 | A Z - B Z D | / ( |A| |Z| n ulp ) \002,"
+ "/\002 4 = SSYGV, with ITYPE=1 and UPLO='L':\002,\002 | A Z - B "
+ "Z D | / ( |A| |Z| n ulp ) \002,/\002 5 = SSPGV, with ITYPE=1"
+ " and UPLO='L':\002,\002 | A Z - B Z D | / ( |A| |Z| n ulp ) "
+ "\002,/\002 6 = SSBGV, with ITYPE=1 and UPLO='L':\002,\002 | A Z"
+ " - B Z D | / ( |A| |Z| n ulp ) \002)";
+ static char fmt_9976[] = "(\002 7 = SSYGV, with ITYPE=2 and UPLO='U':"
+ "\002,\002 | A B Z - Z D | / ( |A| |Z| n ulp ) \002,/\002 8 "
+ "= SSPGV, with ITYPE=2 and UPLO='U':\002,\002 | A B Z - Z D | / "
+ "( |A| |Z| n ulp ) \002,/\002 9 = SSPGV, with ITYPE=2 and UPL"
+ "O='L':\002,\002 | A B Z - Z D | / ( |A| |Z| n ulp ) \002,"
+ "/\00210 = SSPGV, with ITYPE=2 and UPLO='L':\002,\002 | A B Z - "
+ "Z D | / ( |A| |Z| n ulp ) \002,/\00211 = SSYGV, with ITYPE=3"
+ " and UPLO='U':\002,\002 | B A Z - Z D | / ( |A| |Z| n ulp ) "
+ "\002,/\00212 = SSPGV, with ITYPE=3 and UPLO='U':\002,\002 | B A"
+ " Z - Z D | / ( |A| |Z| n ulp ) \002,/\00213 = SSYGV, with IT"
+ "YPE=3 and UPLO='L':\002,\002 | B A Z - Z D | / ( |A| |Z| n ulp "
+ ") \002,/\00214 = SSPGV, with ITYPE=3 and UPLO='L':\002,\002 "
+ " | B A Z - Z D | / ( |A| |Z| n ulp ) \002)";
+ static char fmt_9991[] = "(/1x,a3,\002 -- Complex Hermitian Generalized "
+ "eigenvalue \002,\002problem\002)";
+ static char fmt_9975[] = "(/\002 Tests performed: \002,/\002( For each"
+ " pair (A,B), where A is of the given type \002,/\002 and B is a "
+ "random well-conditioned matrix. D is \002,/\002 diagonal, and Z "
+ "is unitary. )\002,/\002 1 = CHEGV, with ITYPE=1 and UPLO='U':"
+ "\002,\002 | A Z - B Z D | / ( |A| |Z| n ulp ) \002,/\002 2 "
+ "= CHPGV, with ITYPE=1 and UPLO='U':\002,\002 | A Z - B Z D | / "
+ "( |A| |Z| n ulp ) \002,/\002 3 = CHBGV, with ITYPE=1 and UPL"
+ "O='U':\002,\002 | A Z - B Z D | / ( |A| |Z| n ulp ) \002,"
+ "/\002 4 = CHEGV, with ITYPE=1 and UPLO='L':\002,\002 | A Z - B "
+ "Z D | / ( |A| |Z| n ulp ) \002,/\002 5 = CHPGV, with ITYPE=1"
+ " and UPLO='L':\002,\002 | A Z - B Z D | / ( |A| |Z| n ulp ) "
+ "\002,/\002 6 = CHBGV, with ITYPE=1 and UPLO='L':\002,\002 | A Z"
+ " - B Z D | / ( |A| |Z| n ulp ) \002)";
+ static char fmt_9974[] = "(\002 7 = CHEGV, with ITYPE=2 and UPLO='U':"
+ "\002,\002 | A B Z - Z D | / ( |A| |Z| n ulp ) \002,/\002 8 "
+ "= CHPGV, with ITYPE=2 and UPLO='U':\002,\002 | A B Z - Z D | / "
+ "( |A| |Z| n ulp ) \002,/\002 9 = CHPGV, with ITYPE=2 and UPL"
+ "O='L':\002,\002 | A B Z - Z D | / ( |A| |Z| n ulp ) \002,"
+ "/\00210 = CHPGV, with ITYPE=2 and UPLO='L':\002,\002 | A B Z - "
+ "Z D | / ( |A| |Z| n ulp ) \002,/\00211 = CHEGV, with ITYPE=3"
+ " and UPLO='U':\002,\002 | B A Z - Z D | / ( |A| |Z| n ulp ) "
+ "\002,/\00212 = CHPGV, with ITYPE=3 and UPLO='U':\002,\002 | B A"
+ " Z - Z D | / ( |A| |Z| n ulp ) \002,/\00213 = CHEGV, with IT"
+ "YPE=3 and UPLO='L':\002,\002 | B A Z - Z D | / ( |A| |Z| n ulp "
+ ") \002,/\00214 = CHPGV, with ITYPE=3 and UPLO='L':\002,\002 "
+ " | B A Z - Z D | / ( |A| |Z| n ulp ) \002)";
+ static char fmt_9994[] = "(/1x,a3,\002 -- Real Singular Value Decomposit"
+ "ion\002)";
+ static char fmt_9973[] = "(\002 Matrix types (see xCHKBD for details)"
+ ":\002,/\002 Diagonal matrices:\002,/\002 1: Zero\002,28x,\002 "
+ "5: Clustered entries\002,/\002 2: Identity\002,24x,\002 6: Lar"
+ "ge, evenly spaced entries\002,/\002 3: Evenly spaced entrie"
+ "s\002,11x,\002 7: Small, evenly spaced entries\002,/\002 4: Ge"
+ "ometrically spaced entries\002,/\002 General matrices:\002,/\002"
+ " 8: Evenly spaced sing. vals.\002,7x,\00212: Small, evenly spa"
+ "ced sing vals\002,/\002 9: Geometrically spaced sing vals "
+ "\002,\00213: Random, O(1) entries\002,/\002 10: Clustered sing."
+ " vals.\002,11x,\00214: Random, scaled near overflow\002,/\002 1"
+ "1: Large, evenly spaced sing vals \002,\00215: Random, scaled n"
+ "ear underflow\002)";
+ static char fmt_9972[] = "(/\002 Test ratios: \002,\002(B: bidiagonal, "
+ "S: diagonal, Q, P, U, and V: \002,a10,/16x,\002X: m x nrhs, Y = "
+ "Q' X, and Z = U' Y)\002,/\002 1: norm( A - Q B P' ) / ( norm(A"
+ ") max(m,n) ulp )\002,/\002 2: norm( I - Q' Q ) / ( m ulp "
+ ")\002,/\002 3: norm( I - P' P ) / ( n ulp )\002,/\002 4: n"
+ "orm( B - U S V' ) / ( norm(B) min(m,n) ulp )\002,/\002 5: norm"
+ "( Y - U Z ) / ( norm(Z) max(min(m,n),k) ulp )\002,/\002 6: "
+ "norm( I - U' U ) / ( min(m,n) ulp )\002,/\002 7: norm( I - V"
+ "' V ) / ( min(m,n) ulp )\002)";
+ static char fmt_9971[] = "(\002 8: Test ordering of S (0 if nondecrea"
+ "sing, 1/ulp \002,\002 otherwise)\002,/\002 9: norm( S - S2 ) "
+ " / ( norm(S) ulp ),\002,\002 where S2 is computed\002,/44x,"
+ "\002without computing U and V'\002,/\002 10: Sturm sequence tes"
+ "t \002,\002(0 if sing. vals of B within THRESH of S)\002,/\002 "
+ "11: norm( A - (QU) S (V' P') ) / \002,\002( norm(A) max(m,n) ulp"
+ " )\002,/\002 12: norm( X - (QU) Z ) / ( |X| max(M,k) ul"
+ "p )\002,/\002 13: norm( I - (QU)'(QU) ) / ( M ulp )\002,"
+ "/\002 14: norm( I - (V' P') (P V) ) / ( N ulp )\002)";
+ static char fmt_9993[] = "(/1x,a3,\002 -- Complex Singular Value Decompo"
+ "sition\002)";
+ static char fmt_9990[] = "(/1x,a3,\002 -- Real Band reduc. to bidiagonal"
+ " form\002)";
+ static char fmt_9970[] = "(\002 Matrix types (see xCHKBB for details)"
+ ":\002,/\002 Diagonal matrices:\002,/\002 1: Zero\002,28x,\002 "
+ "5: Clustered entries\002,/\002 2: Identity\002,24x,\002 6: Lar"
+ "ge, evenly spaced entries\002,/\002 3: Evenly spaced entrie"
+ "s\002,11x,\002 7: Small, evenly spaced entries\002,/\002 4: Ge"
+ "ometrically spaced entries\002,/\002 General matrices:\002,/\002"
+ " 8: Evenly spaced sing. vals.\002,7x,\00212: Small, evenly spa"
+ "ced sing vals\002,/\002 9: Geometrically spaced sing vals "
+ "\002,\00213: Random, O(1) entries\002,/\002 10: Clustered sing."
+ " vals.\002,11x,\00214: Random, scaled near overflow\002,/\002 1"
+ "1: Large, evenly spaced sing vals \002,\00215: Random, scaled n"
+ "ear underflow\002)";
+ static char fmt_9969[] = "(/\002 Test ratios: \002,\002(B: upper bidiag"
+ "onal, Q and P: \002,a10,/16x,\002C: m x nrhs, PT = P', Y = Q' C"
+ ")\002,/\002 1: norm( A - Q B PT ) / ( norm(A) max(m,n) ulp )\002"
+ ",/\002 2: norm( I - Q' Q ) / ( m ulp )\002,/\002 3: norm( I - "
+ "PT PT' ) / ( n ulp )\002,/\002 4: norm( Y - Q' C ) / ( norm("
+ "Y) max(m,nrhs) ulp )\002)";
+ static char fmt_9989[] = "(/1x,a3,\002 -- Complex Band reduc. to bidiago"
+ "nal form\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j;
+ char c2[2];
+ logical sord, corz;
+ extern logical lsame_(char *, char *), lsamen_(integer *,
+ char *, char *);
+
+ /* Fortran I/O blocks */
+ static cilist io___3 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___5 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___6 = { 0, 0, 0, fmt_9988, 0 };
+ static cilist io___7 = { 0, 0, 0, fmt_9987, 0 };
+ static cilist io___8 = { 0, 0, 0, fmt_9986, 0 };
+ static cilist io___9 = { 0, 0, 0, fmt_9985, 0 };
+ static cilist io___10 = { 0, 0, 0, fmt_9984, 0 };
+ static cilist io___12 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___13 = { 0, 0, 0, fmt_9988, 0 };
+ static cilist io___14 = { 0, 0, 0, fmt_9987, 0 };
+ static cilist io___15 = { 0, 0, 0, fmt_9986, 0 };
+ static cilist io___16 = { 0, 0, 0, fmt_9985, 0 };
+ static cilist io___17 = { 0, 0, 0, fmt_9984, 0 };
+ static cilist io___18 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___19 = { 0, 0, 0, fmt_9983, 0 };
+ static cilist io___20 = { 0, 0, 0, fmt_9982, 0 };
+ static cilist io___21 = { 0, 0, 0, fmt_9981, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9968, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9983, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9982, 0 };
+ static cilist io___26 = { 0, 0, 0, fmt_9981, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9967, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9980, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9979, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9978, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9977, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9976, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9980, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9979, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9978, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9975, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9974, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9973, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9972, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9971, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9973, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9972, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9971, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9970, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9969, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9970, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9969, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK auxiliary test routine (version 2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAHD2 prints header information for the different test paths. */
+
+/* Arguments */
+/* ========= */
+
+/* IOUNIT (input) INTEGER. */
+/* On entry, IOUNIT specifies the unit number to which the */
+/* header information should be printed. */
+
+/* PATH (input) CHARACTER*3. */
+/* On entry, PATH contains the name of the path for which the */
+/* header information is to be printed. Current paths are */
+
+/* SHS, CHS: Non-symmetric eigenproblem. */
+/* SST, CST: Symmetric eigenproblem. */
+/* SSG, CSG: Symmetric Generalized eigenproblem. */
+/* SBD, CBD: Singular Value Decomposition (SVD) */
+/* SBB, CBB: General Banded reduction to bidiagonal form */
+
+/* These paths also are supplied in double precision (replace */
+/* leading S by D and leading C by Z in path names). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (*iounit <= 0) {
+ return 0;
+ }
+ sord = lsame_(path, "S") || lsame_(path, "D");
+ corz = lsame_(path, "C") || lsame_(path, "Z");
+ if (! sord && ! corz) {
+ io___3.ciunit = *iounit;
+ s_wsfe(&io___3);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+ if (lsamen_(&c__2, c2, "HS")) {
+ if (sord) {
+
+/* Real Non-symmetric Eigenvalue Problem: */
+
+ io___5.ciunit = *iounit;
+ s_wsfe(&io___5);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___6.ciunit = *iounit;
+ s_wsfe(&io___6);
+ e_wsfe();
+ io___7.ciunit = *iounit;
+ s_wsfe(&io___7);
+ e_wsfe();
+ io___8.ciunit = *iounit;
+ s_wsfe(&io___8);
+ do_fio(&c__1, "pairs ", (ftnlen)6);
+ do_fio(&c__1, "pairs ", (ftnlen)6);
+ do_fio(&c__1, "prs.", (ftnlen)4);
+ do_fio(&c__1, "prs.", (ftnlen)4);
+ e_wsfe();
+ io___9.ciunit = *iounit;
+ s_wsfe(&io___9);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___10.ciunit = *iounit;
+ s_wsfe(&io___10);
+ do_fio(&c__1, "orthogonal", (ftnlen)10);
+ do_fio(&c__1, "'=transpose", (ftnlen)11);
+ for (j = 1; j <= 6; ++j) {
+ do_fio(&c__1, "'", (ftnlen)1);
+ }
+ e_wsfe();
+
+ } else {
+
+/* Complex Non-symmetric Eigenvalue Problem: */
+
+ io___12.ciunit = *iounit;
+ s_wsfe(&io___12);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___13.ciunit = *iounit;
+ s_wsfe(&io___13);
+ e_wsfe();
+ io___14.ciunit = *iounit;
+ s_wsfe(&io___14);
+ e_wsfe();
+ io___15.ciunit = *iounit;
+ s_wsfe(&io___15);
+ do_fio(&c__1, "e.vals", (ftnlen)6);
+ do_fio(&c__1, "e.vals", (ftnlen)6);
+ do_fio(&c__1, "e.vs", (ftnlen)4);
+ do_fio(&c__1, "e.vs", (ftnlen)4);
+ e_wsfe();
+ io___16.ciunit = *iounit;
+ s_wsfe(&io___16);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___17.ciunit = *iounit;
+ s_wsfe(&io___17);
+ do_fio(&c__1, "unitary", (ftnlen)7);
+ do_fio(&c__1, "*=conj.transp.", (ftnlen)14);
+ for (j = 1; j <= 6; ++j) {
+ do_fio(&c__1, "*", (ftnlen)1);
+ }
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "ST")) {
+
+ if (sord) {
+
+/* Real Symmetric Eigenvalue Problem: */
+
+ io___18.ciunit = *iounit;
+ s_wsfe(&io___18);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___19.ciunit = *iounit;
+ s_wsfe(&io___19);
+ e_wsfe();
+ io___20.ciunit = *iounit;
+ s_wsfe(&io___20);
+ e_wsfe();
+ io___21.ciunit = *iounit;
+ s_wsfe(&io___21);
+ do_fio(&c__1, "Symmetric", (ftnlen)9);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___22.ciunit = *iounit;
+ s_wsfe(&io___22);
+ e_wsfe();
+
+ } else {
+
+/* Complex Hermitian Eigenvalue Problem: */
+
+ io___23.ciunit = *iounit;
+ s_wsfe(&io___23);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___24.ciunit = *iounit;
+ s_wsfe(&io___24);
+ e_wsfe();
+ io___25.ciunit = *iounit;
+ s_wsfe(&io___25);
+ e_wsfe();
+ io___26.ciunit = *iounit;
+ s_wsfe(&io___26);
+ do_fio(&c__1, "Hermitian", (ftnlen)9);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___27.ciunit = *iounit;
+ s_wsfe(&io___27);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "SG")) {
+
+ if (sord) {
+
+/* Real Symmetric Generalized Eigenvalue Problem: */
+
+ io___28.ciunit = *iounit;
+ s_wsfe(&io___28);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___29.ciunit = *iounit;
+ s_wsfe(&io___29);
+ e_wsfe();
+ io___30.ciunit = *iounit;
+ s_wsfe(&io___30);
+ e_wsfe();
+ io___31.ciunit = *iounit;
+ s_wsfe(&io___31);
+ do_fio(&c__1, "Symmetric", (ftnlen)9);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___32.ciunit = *iounit;
+ s_wsfe(&io___32);
+ e_wsfe();
+ io___33.ciunit = *iounit;
+ s_wsfe(&io___33);
+ e_wsfe();
+
+ } else {
+
+/* Complex Hermitian Generalized Eigenvalue Problem: */
+
+ io___34.ciunit = *iounit;
+ s_wsfe(&io___34);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___35.ciunit = *iounit;
+ s_wsfe(&io___35);
+ e_wsfe();
+ io___36.ciunit = *iounit;
+ s_wsfe(&io___36);
+ e_wsfe();
+ io___37.ciunit = *iounit;
+ s_wsfe(&io___37);
+ do_fio(&c__1, "Hermitian", (ftnlen)9);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___38.ciunit = *iounit;
+ s_wsfe(&io___38);
+ e_wsfe();
+ io___39.ciunit = *iounit;
+ s_wsfe(&io___39);
+ e_wsfe();
+
+ }
+
+ } else if (lsamen_(&c__2, c2, "BD")) {
+
+ if (sord) {
+
+/* Real Singular Value Decomposition: */
+
+ io___40.ciunit = *iounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___41.ciunit = *iounit;
+ s_wsfe(&io___41);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___42.ciunit = *iounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "orthogonal", (ftnlen)10);
+ e_wsfe();
+ io___43.ciunit = *iounit;
+ s_wsfe(&io___43);
+ e_wsfe();
+ } else {
+
+/* Complex Singular Value Decomposition: */
+
+ io___44.ciunit = *iounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___45.ciunit = *iounit;
+ s_wsfe(&io___45);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___46.ciunit = *iounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, "unitary ", (ftnlen)10);
+ e_wsfe();
+ io___47.ciunit = *iounit;
+ s_wsfe(&io___47);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "BB")) {
+
+ if (sord) {
+
+/* Real General Band reduction to bidiagonal form: */
+
+ io___48.ciunit = *iounit;
+ s_wsfe(&io___48);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___49.ciunit = *iounit;
+ s_wsfe(&io___49);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___50.ciunit = *iounit;
+ s_wsfe(&io___50);
+ do_fio(&c__1, "orthogonal", (ftnlen)10);
+ e_wsfe();
+ } else {
+
+/* Complex Band reduction to bidiagonal form: */
+
+ io___51.ciunit = *iounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___52.ciunit = *iounit;
+ s_wsfe(&io___52);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___53.ciunit = *iounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, "unitary ", (ftnlen)10);
+ e_wsfe();
+ }
+
+ } else {
+
+ io___54.ciunit = *iounit;
+ s_wsfe(&io___54);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ return 0;
+ }
+
+ return 0;
+
+
+
+
+/* Symmetric/Hermitian eigenproblem */
+
+
+
+/* Symmetric/Hermitian Generalized eigenproblem */
+
+
+
+/* Singular Value Decomposition */
+
+
+
+/* Band reduction to bidiagonal form */
+
+
+
+/* End of SLAHD2 */
+
+} /* slahd2_ */
diff --git a/TESTING/EIG/slarfy.c b/TESTING/EIG/slarfy.c
new file mode 100644
index 0000000..9ea3d7f
--- /dev/null
+++ b/TESTING/EIG/slarfy.c
@@ -0,0 +1,135 @@
+/* slarfy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b2 = 1.f;
+static real c_b3 = 0.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int slarfy_(char *uplo, integer *n, real *v, integer *incv,
+ real *tau, real *c__, integer *ldc, real *work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset;
+ real r__1;
+
+ /* Local variables */
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ extern /* Subroutine */ int ssyr2_(char *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ real alpha;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *), ssymv_(char *, integer *, real *, real *,
+ integer *, real *, integer *, real *, real *, integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARFY applies an elementary reflector, or Householder matrix, H, */
+/* to an n x n symmetric matrix C, from both the left and the right. */
+
+/* H is represented in the form */
+
+/* H = I - tau * v * v' */
+
+/* where tau is a scalar and v is a vector. */
+
+/* If tau is zero, then H is taken to be the unit matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix C is stored. */
+/* = 'U': Upper triangle */
+/* = 'L': Lower triangle */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix C. N >= 0. */
+
+/* V (input) REAL array, dimension */
+/* (1 + (N-1)*abs(INCV)) */
+/* The vector v as described above. */
+
+/* INCV (input) INTEGER */
+/* The increment between successive elements of v. INCV must */
+/* not be zero. */
+
+/* TAU (input) REAL */
+/* The value tau as described above. */
+
+/* C (input/output) REAL array, dimension (LDC, N) */
+/* On entry, the matrix C. */
+/* On exit, C is overwritten by H * C * H'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max( 1, N ). */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ if (*tau == 0.f) {
+ return 0;
+ }
+
+/* Form w:= C * v */
+
+ ssymv_(uplo, n, &c_b2, &c__[c_offset], ldc, &v[1], incv, &c_b3, &work[1],
+ &c__1);
+
+ alpha = *tau * -.5f * sdot_(n, &work[1], &c__1, &v[1], incv);
+ saxpy_(n, &alpha, &v[1], incv, &work[1], &c__1);
+
+/* C := C - v * w' - w * v' */
+
+ r__1 = -(*tau);
+ ssyr2_(uplo, n, &r__1, &v[1], incv, &work[1], &c__1, &c__[c_offset], ldc);
+
+ return 0;
+
+/* End of SLARFY */
+
+} /* slarfy_ */
diff --git a/TESTING/EIG/slarhs.c b/TESTING/EIG/slarhs.c
new file mode 100644
index 0000000..074e52d
--- /dev/null
+++ b/TESTING/EIG/slarhs.c
@@ -0,0 +1,394 @@
+/* slarhs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static real c_b32 = 1.f;
+static real c_b33 = 0.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int slarhs_(char *path, char *xtype, char *uplo, char *trans,
+ integer *m, integer *n, integer *kl, integer *ku, integer *nrhs,
+ real *a, integer *lda, real *x, integer *ldx, real *b, integer *ldb,
+ integer *iseed, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j;
+ char c1[1], c2[2];
+ integer mb, nx;
+ logical gen, tri, qrs, sym, band;
+ char diag[1];
+ logical tran;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *), sgbmv_(char *, integer *,
+ integer *, integer *, integer *, real *, real *, integer *, real *
+, integer *, real *, real *, integer *), ssbmv_(char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+, real *, real *, integer *), stbmv_(char *, char *, char
+ *, integer *, integer *, real *, integer *, real *, integer *), strmm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), sspmv_(char *, integer *, real
+ *, real *, real *, integer *, real *, real *, integer *),
+ ssymm_(char *, char *, integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, real *, integer *), stpmv_(char *, char *, char *, integer *, real *, real *,
+ integer *), xerbla_(char *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+ logical notran;
+ extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
+ *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARHS chooses a set of NRHS random solution vectors and sets */
+/* up the right hand sides for the linear system */
+/* op( A ) * X = B, */
+/* where op( A ) may be A or A' (transpose of A). */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The type of the real matrix A. PATH may be given in any */
+/* combination of upper and lower case. Valid types include */
+/* xGE: General m x n matrix */
+/* xGB: General banded matrix */
+/* xPO: Symmetric positive definite, 2-D storage */
+/* xPP: Symmetric positive definite packed */
+/* xPB: Symmetric positive definite banded */
+/* xSY: Symmetric indefinite, 2-D storage */
+/* xSP: Symmetric indefinite packed */
+/* xSB: Symmetric indefinite banded */
+/* xTR: Triangular */
+/* xTP: Triangular packed */
+/* xTB: Triangular banded */
+/* xQR: General m x n matrix */
+/* xLQ: General m x n matrix */
+/* xQL: General m x n matrix */
+/* xRQ: General m x n matrix */
+/* where the leading character indicates the precision. */
+
+/* XTYPE (input) CHARACTER*1 */
+/* Specifies how the exact solution X will be determined: */
+/* = 'N': New solution; generate a random X. */
+/* = 'C': Computed; use value of X on entry. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* matrix A is stored, if A is symmetric. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to the matrix A. */
+/* = 'N': System is A * x = b */
+/* = 'T': System is A'* x = b */
+/* = 'C': System is A'* x = b */
+
+/* M (input) INTEGER */
+/* The number or rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* Used only if A is a band matrix; specifies the number of */
+/* subdiagonals of A if A is a general band matrix or if A is */
+/* symmetric or triangular and UPLO = 'L'; specifies the number */
+/* of superdiagonals of A if A is symmetric or triangular and */
+/* UPLO = 'U'. 0 <= KL <= M-1. */
+
+/* KU (input) INTEGER */
+/* Used only if A is a general band matrix or if A is */
+/* triangular. */
+
+/* If PATH = xGB, specifies the number of superdiagonals of A, */
+/* and 0 <= KU <= N-1. */
+
+/* If PATH = xTR, xTP, or xTB, specifies whether or not the */
+/* matrix has unit diagonal: */
+/* = 1: matrix has non-unit diagonal (default) */
+/* = 2: matrix has unit diagonal */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors in the system A*X = B. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The test matrix whose type is given by PATH. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If PATH = xGB, LDA >= KL+KU+1. */
+/* If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1. */
+/* Otherwise, LDA >= max(1,M). */
+
+/* X (input or output) REAL array, dimension(LDX,NRHS) */
+/* On entry, if XTYPE = 'C' (for 'Computed'), then X contains */
+/* the exact solution to the system of linear equations. */
+/* On exit, if XTYPE = 'N' (for 'New'), then X is initialized */
+/* with random values. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M). */
+
+/* B (output) REAL array, dimension (LDB,NRHS) */
+/* The right hand side vector(s) for the system of equations, */
+/* computed from B = op(A) * X, where op(A) is determined by */
+/* TRANS. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. If TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N). */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* The seed vector for the random number generator (used in */
+/* SLATMS). Modified on exit. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --iseed;
+
+ /* Function Body */
+ *info = 0;
+ *(unsigned char *)c1 = *(unsigned char *)path;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ tran = lsame_(trans, "T") || lsame_(trans, "C");
+ notran = ! tran;
+ gen = lsame_(path + 1, "G");
+ qrs = lsame_(path + 1, "Q") || lsame_(path + 2,
+ "Q");
+ sym = lsame_(path + 1, "P") || lsame_(path + 1,
+ "S");
+ tri = lsame_(path + 1, "T");
+ band = lsame_(path + 2, "B");
+ if (! lsame_(c1, "Single precision")) {
+ *info = -1;
+ } else if (! (lsame_(xtype, "N") || lsame_(xtype,
+ "C"))) {
+ *info = -2;
+ } else if ((sym || tri) && ! (lsame_(uplo, "U") ||
+ lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if ((gen || qrs) && ! (tran || lsame_(trans, "N"))) {
+ *info = -4;
+ } else if (*m < 0) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (band && *kl < 0) {
+ *info = -7;
+ } else if (band && *ku < 0) {
+ *info = -8;
+ } else if (*nrhs < 0) {
+ *info = -9;
+ } else if (! band && *lda < max(1,*m) || band && (sym || tri) && *lda < *
+ kl + 1 || band && gen && *lda < *kl + *ku + 1) {
+ *info = -11;
+ } else if (notran && *ldx < max(1,*n) || tran && *ldx < max(1,*m)) {
+ *info = -13;
+ } else if (notran && *ldb < max(1,*m) || tran && *ldb < max(1,*n)) {
+ *info = -15;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLARHS", &i__1);
+ return 0;
+ }
+
+/* Initialize X to NRHS random vectors unless XTYPE = 'C'. */
+
+ if (tran) {
+ nx = *m;
+ mb = *n;
+ } else {
+ nx = *n;
+ mb = *m;
+ }
+ if (! lsame_(xtype, "C")) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ slarnv_(&c__2, &iseed[1], n, &x[j * x_dim1 + 1]);
+/* L10: */
+ }
+ }
+
+/* Multiply X by op( A ) using an appropriate */
+/* matrix multiply routine. */
+
+ if (lsamen_(&c__2, c2, "GE") || lsamen_(&c__2, c2,
+ "QR") || lsamen_(&c__2, c2, "LQ") || lsamen_(&c__2, c2, "QL") ||
+ lsamen_(&c__2, c2, "RQ")) {
+
+/* General matrix */
+
+ sgemm_(trans, "N", &mb, nrhs, &nx, &c_b32, &a[a_offset], lda, &x[
+ x_offset], ldx, &c_b33, &b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "PO") || lsamen_(&
+ c__2, c2, "SY")) {
+
+/* Symmetric matrix, 2-D storage */
+
+ ssymm_("Left", uplo, n, nrhs, &c_b32, &a[a_offset], lda, &x[x_offset],
+ ldx, &c_b33, &b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* General matrix, band storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ sgbmv_(trans, &mb, &nx, kl, ku, &c_b32, &a[a_offset], lda, &x[j *
+ x_dim1 + 1], &c__1, &c_b33, &b[j * b_dim1 + 1], &c__1);
+/* L20: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* Symmetric matrix, band storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ssbmv_(uplo, n, kl, &c_b32, &a[a_offset], lda, &x[j * x_dim1 + 1],
+ &c__1, &c_b33, &b[j * b_dim1 + 1], &c__1);
+/* L30: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "PP") || lsamen_(&
+ c__2, c2, "SP")) {
+
+/* Symmetric matrix, packed storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ sspmv_(uplo, n, &c_b32, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
+ c_b33, &b[j * b_dim1 + 1], &c__1);
+/* L40: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "TR")) {
+
+/* Triangular matrix. Note that for triangular matrices, */
+/* KU = 1 => non-unit triangular */
+/* KU = 2 => unit triangular */
+
+ slacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ strmm_("Left", uplo, trans, diag, n, nrhs, &c_b32, &a[a_offset], lda,
+ &b[b_offset], ldb)
+ ;
+
+ } else if (lsamen_(&c__2, c2, "TP")) {
+
+/* Triangular matrix, packed storage */
+
+ slacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ stpmv_(uplo, trans, diag, n, &a[a_offset], &b[j * b_dim1 + 1], &
+ c__1);
+/* L50: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "TB")) {
+
+/* Triangular matrix, banded storage */
+
+ slacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ stbmv_(uplo, trans, diag, n, kl, &a[a_offset], lda, &b[j * b_dim1
+ + 1], &c__1);
+/* L60: */
+ }
+
+ } else {
+
+/* If PATH is none of the above, return with an error code. */
+
+ *info = -1;
+ i__1 = -(*info);
+ xerbla_("SLARHS", &i__1);
+ }
+
+ return 0;
+
+/* End of SLARHS */
+
+} /* slarhs_ */
diff --git a/TESTING/EIG/slasum.c b/TESTING/EIG/slasum.c
new file mode 100644
index 0000000..6b9bdc0
--- /dev/null
+++ b/TESTING/EIG/slasum.c
@@ -0,0 +1,76 @@
+/* slasum.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int slasum_(char *type__, integer *iounit, integer *ie,
+ integer *nrun)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,a2,i4,a8,i5,a35)";
+ static char fmt_9998[] = "(/1x,a14,a3,a23,i5,a11)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___2 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLASUM prints a summary of the results from one of the test routines. */
+
+/* ===================================================================== */
+
+/* .. Executable Statements .. */
+
+ if (*ie > 0) {
+ io___1.ciunit = *iounit;
+ s_wsfe(&io___1);
+ do_fio(&c__1, type__, (ftnlen)3);
+ do_fio(&c__1, ": ", (ftnlen)2);
+ do_fio(&c__1, (char *)&(*ie), (ftnlen)sizeof(integer));
+ do_fio(&c__1, " out of ", (ftnlen)8);
+ do_fio(&c__1, (char *)&(*nrun), (ftnlen)sizeof(integer));
+ do_fio(&c__1, " tests failed to pass the threshold", (ftnlen)35);
+ e_wsfe();
+ } else {
+ io___2.ciunit = *iounit;
+ s_wsfe(&io___2);
+ do_fio(&c__1, "All tests for ", (ftnlen)14);
+ do_fio(&c__1, type__, (ftnlen)3);
+ do_fio(&c__1, " passed the threshold (", (ftnlen)23);
+ do_fio(&c__1, (char *)&(*nrun), (ftnlen)sizeof(integer));
+ do_fio(&c__1, " tests run)", (ftnlen)11);
+ e_wsfe();
+ }
+ return 0;
+
+/* End of SLASUM */
+
+} /* slasum_ */
diff --git a/TESTING/EIG/slatb9.c b/TESTING/EIG/slatb9.c
new file mode 100644
index 0000000..4fa0c9c
--- /dev/null
+++ b/TESTING/EIG/slatb9.c
@@ -0,0 +1,307 @@
+/* slatb9.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+
+/* Subroutine */ int slatb9_(char *path, integer *imat, integer *m, integer *
+ p, integer *n, char *type__, integer *kla, integer *kua, integer *klb,
+ integer *kub, real *anorm, real *bnorm, integer *modea, integer *
+ modeb, real *cndnma, real *cndnmb, char *dista, char *distb)
+{
+ /* Initialized data */
+
+ static logical first = TRUE_;
+
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ static real eps, badc1, badc2, large, small;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ extern logical lsamen_(integer *, char *, char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLATB9 sets parameters for the matrix generator based on the type of */
+/* matrix to be generated. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name. */
+
+/* IMAT (input) INTEGER */
+/* An integer key describing which matrix to generate for this */
+/* path. */
+
+/* M (input) INTEGER */
+/* The number of rows in the matrix to be generated. */
+
+/* N (input) INTEGER */
+/* The number of columns in the matrix to be generated. */
+
+/* TYPE (output) CHARACTER*1 */
+/* The type of the matrix to be generated: */
+/* = 'S': symmetric matrix; */
+/* = 'P': symmetric positive (semi)definite matrix; */
+/* = 'N': nonsymmetric matrix. */
+
+/* KL (output) INTEGER */
+/* The lower band width of the matrix to be generated. */
+
+/* KU (output) INTEGER */
+/* The upper band width of the matrix to be generated. */
+
+/* ANORM (output) REAL */
+/* The desired norm of the matrix to be generated. The diagonal */
+/* matrix of singular values or eigenvalues is scaled by this */
+/* value. */
+
+/* MODE (output) INTEGER */
+/* A key indicating how to choose the vector of eigenvalues. */
+
+/* CNDNUM (output) REAL */
+/* The desired condition number. */
+
+/* DIST (output) CHARACTER*1 */
+/* The type of distribution to be used by the random number */
+/* generator. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Set some constants for use in the subroutine. */
+
+ if (first) {
+ first = FALSE_;
+ eps = slamch_("Precision");
+ badc2 = .1f / eps;
+ badc1 = sqrt(badc2);
+ small = slamch_("Safe minimum");
+ large = 1.f / small;
+
+/* If it looks like we're on a Cray, take the square root of */
+/* SMALL and LARGE to avoid overflow and underflow problems. */
+
+ slabad_(&small, &large);
+ small = small / eps * .25f;
+ large = 1.f / small;
+ }
+
+/* Set some parameters we don't plan to change. */
+
+ *(unsigned char *)type__ = 'N';
+ *(unsigned char *)dista = 'S';
+ *(unsigned char *)distb = 'S';
+ *modea = 3;
+ *modeb = 4;
+
+/* Set the lower and upper bandwidths. */
+
+ if (lsamen_(&c__3, path, "GRQ") || lsamen_(&c__3,
+ path, "LSE") || lsamen_(&c__3, path, "GSV")) {
+
+/* A: M by N, B: P by N */
+
+ if (*imat == 1) {
+
+/* A: diagonal, B: upper triangular */
+
+ *kla = 0;
+ *kua = 0;
+ *klb = 0;
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kub = max(i__1,0);
+
+ } else if (*imat == 2) {
+
+/* A: upper triangular, B: upper triangular */
+
+ *kla = 0;
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kua = max(i__1,0);
+ *klb = 0;
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kub = max(i__1,0);
+
+ } else if (*imat == 3) {
+
+/* A: lower triangular, B: upper triangular */
+
+/* Computing MAX */
+ i__1 = *m - 1;
+ *kla = max(i__1,0);
+ *kua = 0;
+ *klb = 0;
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kub = max(i__1,0);
+
+ } else {
+
+/* A: general dense, B: general dense */
+
+/* Computing MAX */
+ i__1 = *m - 1;
+ *kla = max(i__1,0);
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kua = max(i__1,0);
+/* Computing MAX */
+ i__1 = *p - 1;
+ *klb = max(i__1,0);
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kub = max(i__1,0);
+
+ }
+
+ } else if (lsamen_(&c__3, path, "GQR") || lsamen_(&
+ c__3, path, "GLM")) {
+
+/* A: N by M, B: N by P */
+
+ if (*imat == 1) {
+
+/* A: diagonal, B: lower triangular */
+
+ *kla = 0;
+ *kua = 0;
+/* Computing MAX */
+ i__1 = *n - 1;
+ *klb = max(i__1,0);
+ *kub = 0;
+ } else if (*imat == 2) {
+
+/* A: lower triangular, B: diagonal */
+
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kla = max(i__1,0);
+ *kua = 0;
+ *klb = 0;
+ *kub = 0;
+
+ } else if (*imat == 3) {
+
+/* A: lower triangular, B: upper triangular */
+
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kla = max(i__1,0);
+ *kua = 0;
+ *klb = 0;
+/* Computing MAX */
+ i__1 = *p - 1;
+ *kub = max(i__1,0);
+
+ } else {
+
+/* A: general dense, B: general dense */
+
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kla = max(i__1,0);
+/* Computing MAX */
+ i__1 = *m - 1;
+ *kua = max(i__1,0);
+/* Computing MAX */
+ i__1 = *n - 1;
+ *klb = max(i__1,0);
+/* Computing MAX */
+ i__1 = *p - 1;
+ *kub = max(i__1,0);
+ }
+
+ }
+
+/* Set the condition number and norm. */
+
+ *cndnma = 100.f;
+ *cndnmb = 10.f;
+ if (lsamen_(&c__3, path, "GQR") || lsamen_(&c__3,
+ path, "GRQ") || lsamen_(&c__3, path, "GSV")) {
+ if (*imat == 5) {
+ *cndnma = badc1;
+ *cndnmb = badc1;
+ } else if (*imat == 6) {
+ *cndnma = badc2;
+ *cndnmb = badc2;
+ } else if (*imat == 7) {
+ *cndnma = badc1;
+ *cndnmb = badc2;
+ } else if (*imat == 8) {
+ *cndnma = badc2;
+ *cndnmb = badc1;
+ }
+ }
+
+ *anorm = 10.f;
+ *bnorm = 1e3f;
+ if (lsamen_(&c__3, path, "GQR") || lsamen_(&c__3,
+ path, "GRQ")) {
+ if (*imat == 7) {
+ *anorm = small;
+ *bnorm = large;
+ } else if (*imat == 8) {
+ *anorm = large;
+ *bnorm = small;
+ }
+ }
+
+ if (*n <= 1) {
+ *cndnma = 1.f;
+ *cndnmb = 1.f;
+ }
+
+ return 0;
+
+/* End of SLATB9 */
+
+} /* slatb9_ */
diff --git a/TESTING/EIG/slatm4.c b/TESTING/EIG/slatm4.c
new file mode 100644
index 0000000..83dcdb9
--- /dev/null
+++ b/TESTING/EIG/slatm4.c
@@ -0,0 +1,494 @@
+/* slatm4.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b3 = 0.f;
+
+/* Subroutine */ int slatm4_(integer *itype, integer *n, integer *nz1,
+ integer *nz2, integer *isign, real *amagn, real *rcond, real *triang,
+ integer *idist, integer *iseed, real *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double pow_dd(doublereal *, doublereal *), log(doublereal), exp(
+ doublereal), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, k, jc, jd;
+ real cl, cr;
+ integer jr;
+ real sl, sr, sv1, sv2;
+ integer kbeg, isdb, kend, ioff, isde, klen;
+ real temp, alpha;
+ extern doublereal slamch_(char *);
+ real safmin;
+ extern doublereal slaran_(integer *), slarnd_(integer *, integer *);
+ extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLATM4 generates basic square matrices, which may later be */
+/* multiplied by others in order to produce test matrices. It is */
+/* intended mainly to be used to test the generalized eigenvalue */
+/* routines. */
+
+/* It first generates the diagonal and (possibly) subdiagonal, */
+/* according to the value of ITYPE, NZ1, NZ2, ISIGN, AMAGN, and RCOND. */
+/* It then fills in the upper triangle with random numbers, if TRIANG is */
+/* non-zero. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* The "type" of matrix on the diagonal and sub-diagonal. */
+/* If ITYPE < 0, then type abs(ITYPE) is generated and then */
+/* swapped end for end (A(I,J) := A'(N-J,N-I).) See also */
+/* the description of AMAGN and ISIGN. */
+
+/* Special types: */
+/* = 0: the zero matrix. */
+/* = 1: the identity. */
+/* = 2: a transposed Jordan block. */
+/* = 3: If N is odd, then a k+1 x k+1 transposed Jordan block */
+/* followed by a k x k identity block, where k=(N-1)/2. */
+/* If N is even, then k=(N-2)/2, and a zero diagonal entry */
+/* is tacked onto the end. */
+
+/* Diagonal types. The diagonal consists of NZ1 zeros, then */
+/* k=N-NZ1-NZ2 nonzeros. The subdiagonal is zero. ITYPE */
+/* specifies the nonzero diagonal entries as follows: */
+/* = 4: 1, ..., k */
+/* = 5: 1, RCOND, ..., RCOND */
+/* = 6: 1, ..., 1, RCOND */
+/* = 7: 1, a, a^2, ..., a^(k-1)=RCOND */
+/* = 8: 1, 1-d, 1-2*d, ..., 1-(k-1)*d=RCOND */
+/* = 9: random numbers chosen from (RCOND,1) */
+/* = 10: random numbers with distribution IDIST (see SLARND.) */
+
+/* N (input) INTEGER */
+/* The order of the matrix. */
+
+/* NZ1 (input) INTEGER */
+/* If abs(ITYPE) > 3, then the first NZ1 diagonal entries will */
+/* be zero. */
+
+/* NZ2 (input) INTEGER */
+/* If abs(ITYPE) > 3, then the last NZ2 diagonal entries will */
+/* be zero. */
+
+/* ISIGN (input) INTEGER */
+/* = 0: The sign of the diagonal and subdiagonal entries will */
+/* be left unchanged. */
+/* = 1: The diagonal and subdiagonal entries will have their */
+/* sign changed at random. */
+/* = 2: If ITYPE is 2 or 3, then the same as ISIGN=1. */
+/* Otherwise, with probability 0.5, odd-even pairs of */
+/* diagonal entries A(2*j-1,2*j-1), A(2*j,2*j) will be */
+/* converted to a 2x2 block by pre- and post-multiplying */
+/* by distinct random orthogonal rotations. The remaining */
+/* diagonal entries will have their sign changed at random. */
+
+/* AMAGN (input) REAL */
+/* The diagonal and subdiagonal entries will be multiplied by */
+/* AMAGN. */
+
+/* RCOND (input) REAL */
+/* If abs(ITYPE) > 4, then the smallest diagonal entry will be */
+/* entry will be RCOND. RCOND must be between 0 and 1. */
+
+/* TRIANG (input) REAL */
+/* The entries above the diagonal will be random numbers with */
+/* magnitude bounded by TRIANG (i.e., random numbers multiplied */
+/* by TRIANG.) */
+
+/* IDIST (input) INTEGER */
+/* Specifies the type of distribution to be used to generate a */
+/* random matrix. */
+/* = 1: UNIFORM( 0, 1 ) */
+/* = 2: UNIFORM( -1, 1 ) */
+/* = 3: NORMAL ( 0, 1 ) */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The values of ISEED are changed on exit, and can */
+/* be used in the next call to SLATM4 to continue the same */
+/* random number sequence. */
+/* Note: ISEED(4) should be odd, for the random number generator */
+/* used at present. */
+
+/* A (output) REAL array, dimension (LDA, N) */
+/* Array to be computed. */
+
+/* LDA (input) INTEGER */
+/* Leading dimension of A. Must be at least 1 and at least N. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ slaset_("Full", n, n, &c_b3, &c_b3, &a[a_offset], lda);
+
+/* Insure a correct ISEED */
+
+ if (iseed[4] % 2 != 1) {
+ ++iseed[4];
+ }
+
+/* Compute diagonal and subdiagonal according to ITYPE, NZ1, NZ2, */
+/* and RCOND */
+
+ if (*itype != 0) {
+ if (abs(*itype) >= 4) {
+/* Computing MAX */
+/* Computing MIN */
+ i__3 = *n, i__4 = *nz1 + 1;
+ i__1 = 1, i__2 = min(i__3,i__4);
+ kbeg = max(i__1,i__2);
+/* Computing MAX */
+/* Computing MIN */
+ i__3 = *n, i__4 = *n - *nz2;
+ i__1 = kbeg, i__2 = min(i__3,i__4);
+ kend = max(i__1,i__2);
+ klen = kend + 1 - kbeg;
+ } else {
+ kbeg = 1;
+ kend = *n;
+ klen = *n;
+ }
+ isdb = 1;
+ isde = 0;
+ switch (abs(*itype)) {
+ case 1: goto L10;
+ case 2: goto L30;
+ case 3: goto L50;
+ case 4: goto L80;
+ case 5: goto L100;
+ case 6: goto L120;
+ case 7: goto L140;
+ case 8: goto L160;
+ case 9: goto L180;
+ case 10: goto L200;
+ }
+
+/* abs(ITYPE) = 1: Identity */
+
+L10:
+ i__1 = *n;
+ for (jd = 1; jd <= i__1; ++jd) {
+ a[jd + jd * a_dim1] = 1.f;
+/* L20: */
+ }
+ goto L220;
+
+/* abs(ITYPE) = 2: Transposed Jordan block */
+
+L30:
+ i__1 = *n - 1;
+ for (jd = 1; jd <= i__1; ++jd) {
+ a[jd + 1 + jd * a_dim1] = 1.f;
+/* L40: */
+ }
+ isdb = 1;
+ isde = *n - 1;
+ goto L220;
+
+/* abs(ITYPE) = 3: Transposed Jordan block, followed by the */
+/* identity. */
+
+L50:
+ k = (*n - 1) / 2;
+ i__1 = k;
+ for (jd = 1; jd <= i__1; ++jd) {
+ a[jd + 1 + jd * a_dim1] = 1.f;
+/* L60: */
+ }
+ isdb = 1;
+ isde = k;
+ i__1 = (k << 1) + 1;
+ for (jd = k + 2; jd <= i__1; ++jd) {
+ a[jd + jd * a_dim1] = 1.f;
+/* L70: */
+ }
+ goto L220;
+
+/* abs(ITYPE) = 4: 1,...,k */
+
+L80:
+ i__1 = kend;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ a[jd + jd * a_dim1] = (real) (jd - *nz1);
+/* L90: */
+ }
+ goto L220;
+
+/* abs(ITYPE) = 5: One large D value: */
+
+L100:
+ i__1 = kend;
+ for (jd = kbeg + 1; jd <= i__1; ++jd) {
+ a[jd + jd * a_dim1] = *rcond;
+/* L110: */
+ }
+ a[kbeg + kbeg * a_dim1] = 1.f;
+ goto L220;
+
+/* abs(ITYPE) = 6: One small D value: */
+
+L120:
+ i__1 = kend - 1;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ a[jd + jd * a_dim1] = 1.f;
+/* L130: */
+ }
+ a[kend + kend * a_dim1] = *rcond;
+ goto L220;
+
+/* abs(ITYPE) = 7: Exponentially distributed D values: */
+
+L140:
+ a[kbeg + kbeg * a_dim1] = 1.f;
+ if (klen > 1) {
+ d__1 = (doublereal) (*rcond);
+ d__2 = (doublereal) (1.f / (real) (klen - 1));
+ alpha = pow_dd(&d__1, &d__2);
+ i__1 = klen;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ d__1 = (doublereal) alpha;
+ d__2 = (doublereal) ((real) (i__ - 1));
+ a[*nz1 + i__ + (*nz1 + i__) * a_dim1] = pow_dd(&d__1, &d__2);
+/* L150: */
+ }
+ }
+ goto L220;
+
+/* abs(ITYPE) = 8: Arithmetically distributed D values: */
+
+L160:
+ a[kbeg + kbeg * a_dim1] = 1.f;
+ if (klen > 1) {
+ alpha = (1.f - *rcond) / (real) (klen - 1);
+ i__1 = klen;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ a[*nz1 + i__ + (*nz1 + i__) * a_dim1] = (real) (klen - i__) *
+ alpha + *rcond;
+/* L170: */
+ }
+ }
+ goto L220;
+
+/* abs(ITYPE) = 9: Randomly distributed D values on ( RCOND, 1): */
+
+L180:
+ alpha = log(*rcond);
+ i__1 = kend;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ a[jd + jd * a_dim1] = exp(alpha * slaran_(&iseed[1]));
+/* L190: */
+ }
+ goto L220;
+
+/* abs(ITYPE) = 10: Randomly distributed D values from DIST */
+
+L200:
+ i__1 = kend;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ a[jd + jd * a_dim1] = slarnd_(idist, &iseed[1]);
+/* L210: */
+ }
+
+L220:
+
+/* Scale by AMAGN */
+
+ i__1 = kend;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ a[jd + jd * a_dim1] = *amagn * a[jd + jd * a_dim1];
+/* L230: */
+ }
+ i__1 = isde;
+ for (jd = isdb; jd <= i__1; ++jd) {
+ a[jd + 1 + jd * a_dim1] = *amagn * a[jd + 1 + jd * a_dim1];
+/* L240: */
+ }
+
+/* If ISIGN = 1 or 2, assign random signs to diagonal and */
+/* subdiagonal */
+
+ if (*isign > 0) {
+ i__1 = kend;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ if (a[jd + jd * a_dim1] != 0.f) {
+ if (slaran_(&iseed[1]) > .5f) {
+ a[jd + jd * a_dim1] = -a[jd + jd * a_dim1];
+ }
+ }
+/* L250: */
+ }
+ i__1 = isde;
+ for (jd = isdb; jd <= i__1; ++jd) {
+ if (a[jd + 1 + jd * a_dim1] != 0.f) {
+ if (slaran_(&iseed[1]) > .5f) {
+ a[jd + 1 + jd * a_dim1] = -a[jd + 1 + jd * a_dim1];
+ }
+ }
+/* L260: */
+ }
+ }
+
+/* Reverse if ITYPE < 0 */
+
+ if (*itype < 0) {
+ i__1 = (kbeg + kend - 1) / 2;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ temp = a[jd + jd * a_dim1];
+ a[jd + jd * a_dim1] = a[kbeg + kend - jd + (kbeg + kend - jd)
+ * a_dim1];
+ a[kbeg + kend - jd + (kbeg + kend - jd) * a_dim1] = temp;
+/* L270: */
+ }
+ i__1 = (*n - 1) / 2;
+ for (jd = 1; jd <= i__1; ++jd) {
+ temp = a[jd + 1 + jd * a_dim1];
+ a[jd + 1 + jd * a_dim1] = a[*n + 1 - jd + (*n - jd) * a_dim1];
+ a[*n + 1 - jd + (*n - jd) * a_dim1] = temp;
+/* L280: */
+ }
+ }
+
+/* If ISIGN = 2, and no subdiagonals already, then apply */
+/* random rotations to make 2x2 blocks. */
+
+ if (*isign == 2 && *itype != 2 && *itype != 3) {
+ safmin = slamch_("S");
+ i__1 = kend - 1;
+ for (jd = kbeg; jd <= i__1; jd += 2) {
+ if (slaran_(&iseed[1]) > .5f) {
+
+/* Rotation on left. */
+
+ cl = slaran_(&iseed[1]) * 2.f - 1.f;
+ sl = slaran_(&iseed[1]) * 2.f - 1.f;
+/* Computing MAX */
+/* Computing 2nd power */
+ r__3 = cl;
+/* Computing 2nd power */
+ r__4 = sl;
+ r__1 = safmin, r__2 = sqrt(r__3 * r__3 + r__4 * r__4);
+ temp = 1.f / dmax(r__1,r__2);
+ cl *= temp;
+ sl *= temp;
+
+/* Rotation on right. */
+
+ cr = slaran_(&iseed[1]) * 2.f - 1.f;
+ sr = slaran_(&iseed[1]) * 2.f - 1.f;
+/* Computing MAX */
+/* Computing 2nd power */
+ r__3 = cr;
+/* Computing 2nd power */
+ r__4 = sr;
+ r__1 = safmin, r__2 = sqrt(r__3 * r__3 + r__4 * r__4);
+ temp = 1.f / dmax(r__1,r__2);
+ cr *= temp;
+ sr *= temp;
+
+/* Apply */
+
+ sv1 = a[jd + jd * a_dim1];
+ sv2 = a[jd + 1 + (jd + 1) * a_dim1];
+ a[jd + jd * a_dim1] = cl * cr * sv1 + sl * sr * sv2;
+ a[jd + 1 + jd * a_dim1] = -sl * cr * sv1 + cl * sr * sv2;
+ a[jd + (jd + 1) * a_dim1] = -cl * sr * sv1 + sl * cr *
+ sv2;
+ a[jd + 1 + (jd + 1) * a_dim1] = sl * sr * sv1 + cl * cr *
+ sv2;
+ }
+/* L290: */
+ }
+ }
+
+ }
+
+/* Fill in upper triangle (except for 2x2 blocks) */
+
+ if (*triang != 0.f) {
+ if (*isign != 2 || *itype == 2 || *itype == 3) {
+ ioff = 1;
+ } else {
+ ioff = 2;
+ i__1 = *n - 1;
+ for (jr = 1; jr <= i__1; ++jr) {
+ if (a[jr + 1 + jr * a_dim1] == 0.f) {
+ a[jr + (jr + 1) * a_dim1] = *triang * slarnd_(idist, &
+ iseed[1]);
+ }
+/* L300: */
+ }
+ }
+
+ i__1 = *n;
+ for (jc = 2; jc <= i__1; ++jc) {
+ i__2 = jc - ioff;
+ for (jr = 1; jr <= i__2; ++jr) {
+ a[jr + jc * a_dim1] = *triang * slarnd_(idist, &iseed[1]);
+/* L310: */
+ }
+/* L320: */
+ }
+ }
+
+ return 0;
+
+/* End of SLATM4 */
+
+} /* slatm4_ */
diff --git a/TESTING/EIG/slctes.c b/TESTING/EIG/slctes.c
new file mode 100644
index 0000000..15145b2
--- /dev/null
+++ b/TESTING/EIG/slctes.c
@@ -0,0 +1,80 @@
+/* slctes.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b2 = 1.f;
+
+logical slctes_(real *zr, real *zi, real *d__)
+{
+ /* System generated locals */
+ logical ret_val;
+
+ /* Builtin functions */
+ double r_sign(real *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLCTES returns .TRUE. if the eigenvalue (ZR/D) + sqrt(-1)*(ZI/D) */
+/* is to be selected (specifically, in this subroutine, if the real */
+/* part of the eigenvalue is negative), and otherwise it returns */
+/* .FALSE.. */
+
+/* It is used by the test routine SDRGES to test whether the driver */
+/* routine SGGES succesfully sorts eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* ZR (input) REAL */
+/* The numerator of the real part of a complex eigenvalue */
+/* (ZR/D) + i*(ZI/D). */
+
+/* ZI (input) REAL */
+/* The numerator of the imaginary part of a complex eigenvalue */
+/* (ZR/D) + i*(ZI). */
+
+/* D (input) REAL */
+/* The denominator part of a complex eigenvalue */
+/* (ZR/D) + i*(ZI/D). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (*d__ == 0.f) {
+ ret_val = *zr < 0.f;
+ } else {
+ ret_val = r_sign(&c_b2, zr) != r_sign(&c_b2, d__);
+ }
+
+ return ret_val;
+
+/* End of SLCTES */
+
+} /* slctes_ */
diff --git a/TESTING/EIG/slctsx.c b/TESTING/EIG/slctsx.c
new file mode 100644
index 0000000..7d7aa7c
--- /dev/null
+++ b/TESTING/EIG/slctsx.c
@@ -0,0 +1,105 @@
+/* slctsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer m, n, mplusn, i__;
+ logical fs;
+} mn_;
+
+#define mn_1 mn_
+
+logical slctsx_(real *ar, real *ai, real *beta)
+{
+ /* System generated locals */
+ logical ret_val;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This function is used to determine what eigenvalues will be */
+/* selected. If this is part of the test driver SDRGSX, do not */
+/* change the code UNLESS you are testing input examples and not */
+/* using the built-in examples. */
+
+/* Arguments */
+/* ========= */
+
+/* AR (input) REAL */
+/* The numerator of the real part of a complex eigenvalue */
+/* (AR/BETA) + i*(AI/BETA). */
+
+/* AI (input) REAL */
+/* The numerator of the imaginary part of a complex eigenvalue */
+/* (AR/BETA) + i*(AI). */
+
+/* BETA (input) REAL */
+/* The denominator part of a complex eigenvalue */
+/* (AR/BETA) + i*(AI/BETA). */
+
+/* ===================================================================== */
+
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (mn_1.fs) {
+ ++mn_1.i__;
+ if (mn_1.i__ <= mn_1.m) {
+ ret_val = FALSE_;
+ } else {
+ ret_val = TRUE_;
+ }
+ if (mn_1.i__ == mn_1.mplusn) {
+ mn_1.fs = FALSE_;
+ mn_1.i__ = 0;
+ }
+ } else {
+ ++mn_1.i__;
+ if (mn_1.i__ <= mn_1.n) {
+ ret_val = TRUE_;
+ } else {
+ ret_val = FALSE_;
+ }
+ if (mn_1.i__ == mn_1.mplusn) {
+ mn_1.fs = TRUE_;
+ mn_1.i__ = 0;
+ }
+ }
+
+/* IF( AR/BETA.GT.0.0 )THEN */
+/* SLCTSX = .TRUE. */
+/* ELSE */
+/* SLCTSX = .FALSE. */
+/* END IF */
+
+ return ret_val;
+
+/* End of SLCTSX */
+
+} /* slctsx_ */
diff --git a/TESTING/EIG/slsets.c b/TESTING/EIG/slsets.c
new file mode 100644
index 0000000..825feac
--- /dev/null
+++ b/TESTING/EIG/slsets.c
@@ -0,0 +1,172 @@
+/* slsets.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int slsets_(integer *m, integer *p, integer *n, real *a,
+ real *af, integer *lda, real *b, real *bf, integer *ldb, real *c__,
+ real *cf, real *d__, real *df, real *x, real *work, integer *lwork,
+ real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1,
+ bf_offset;
+
+ /* Local variables */
+ integer info;
+ extern /* Subroutine */ int sget02_(char *, integer *, integer *, integer
+ *, real *, integer *, real *, integer *, real *, integer *, real *
+, real *), scopy_(integer *, real *, integer *, real *,
+ integer *), sgglse_(integer *, integer *, integer *, real *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ integer *, integer *), slacpy_(char *, integer *, integer *, real
+ *, integer *, real *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLSETS tests SGGLSE - a subroutine for solving linear equality */
+/* constrained least square problem (LSE). */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The M-by-N matrix A. */
+
+/* AF (workspace) REAL array, dimension (LDA,N) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and R. */
+/* LDA >= max(M,N). */
+
+/* B (input) REAL array, dimension (LDB,N) */
+/* The P-by-N matrix A. */
+
+/* BF (workspace) REAL array, dimension (LDB,N) */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the arrays B, BF, V and S. */
+/* LDB >= max(P,N). */
+
+/* C (input) REAL array, dimension( M ) */
+/* the vector C in the LSE problem. */
+
+/* CF (workspace) REAL array, dimension( M ) */
+
+/* D (input) REAL array, dimension( P ) */
+/* the vector D in the LSE problem. */
+
+/* DF (workspace) REAL array, dimension( P ) */
+
+/* X (output) REAL array, dimension( N ) */
+/* solution vector X in the LSE problem. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( A*x - c )/ norm(A)*norm(X)*EPS */
+/* RESULT(2) = norm( B*x - d )/ norm(B)*norm(X)*EPS */
+
+/* ==================================================================== */
+
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Copy the matrices A and B to the arrays AF and BF, */
+/* and the vectors C and D to the arrays CF and DF, */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ bf_dim1 = *ldb;
+ bf_offset = 1 + bf_dim1;
+ bf -= bf_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --c__;
+ --cf;
+ --d__;
+ --df;
+ --x;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ slacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+ slacpy_("Full", p, n, &b[b_offset], ldb, &bf[bf_offset], ldb);
+ scopy_(m, &c__[1], &c__1, &cf[1], &c__1);
+ scopy_(p, &d__[1], &c__1, &df[1], &c__1);
+
+/* Solve LSE problem */
+
+ sgglse_(m, n, p, &af[af_offset], lda, &bf[bf_offset], ldb, &cf[1], &df[1],
+ &x[1], &work[1], lwork, &info);
+
+/* Test the residual for the solution of LSE */
+
+/* Compute RESULT(1) = norm( A*x - c ) / norm(A)*norm(X)*EPS */
+
+ scopy_(m, &c__[1], &c__1, &cf[1], &c__1);
+ scopy_(p, &d__[1], &c__1, &df[1], &c__1);
+ sget02_("No transpose", m, n, &c__1, &a[a_offset], lda, &x[1], n, &cf[1],
+ m, &rwork[1], &result[1]);
+
+/* Compute result(2) = norm( B*x - d ) / norm(B)*norm(X)*EPS */
+
+ sget02_("No transpose", p, n, &c__1, &b[b_offset], ldb, &x[1], n, &df[1],
+ p, &rwork[1], &result[2]);
+
+ return 0;
+
+/* End of SLSETS */
+
+} /* slsets_ */
diff --git a/TESTING/EIG/sort01.c b/TESTING/EIG/sort01.c
new file mode 100644
index 0000000..eb9d22b
--- /dev/null
+++ b/TESTING/EIG/sort01.c
@@ -0,0 +1,217 @@
+/* sort01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b7 = 0.f;
+static real c_b8 = 1.f;
+static real c_b10 = -1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int sort01_(char *rowcol, integer *m, integer *n, real *u,
+ integer *ldu, real *work, integer *lwork, real *resid)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer i__, j, k;
+ real eps, tmp;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ extern logical lsame_(char *, char *);
+ integer mnmin;
+ extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *,
+ real *, real *, integer *, real *, real *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *);
+ integer ldwork;
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+ char transu[1];
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORT01 checks that the matrix U is orthogonal by computing the ratio */
+
+/* RESID = norm( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R', */
+/* or */
+/* RESID = norm( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'. */
+
+/* Alternatively, if there isn't sufficient workspace to form */
+/* I - U*U' or I - U'*U, the ratio is computed as */
+
+/* RESID = abs( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R', */
+/* or */
+/* RESID = abs( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'. */
+
+/* where EPS is the machine precision. ROWCOL is used only if m = n; */
+/* if m > n, ROWCOL is assumed to be 'C', and if m < n, ROWCOL is */
+/* assumed to be 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* ROWCOL (input) CHARACTER */
+/* Specifies whether the rows or columns of U should be checked */
+/* for orthogonality. Used only if M = N. */
+/* = 'R': Check for orthogonal rows of U */
+/* = 'C': Check for orthogonal columns of U */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix U. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix U. */
+
+/* U (input) REAL array, dimension (LDU,N) */
+/* The orthogonal matrix U. U is checked for orthogonal columns */
+/* if m > n or if m = n and ROWCOL = 'C'. U is checked for */
+/* orthogonal rows if m < n or if m = n and ROWCOL = 'R'. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M). */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. For best performance, LWORK */
+/* should be at least N*(N+1) if ROWCOL = 'C' or M*(M+1) if */
+/* ROWCOL = 'R', but the test will be done even if LWORK is 0. */
+
+/* RESID (output) REAL */
+/* RESID = norm( I - U * U' ) / ( n * EPS ), if ROWCOL = 'R', or */
+/* RESID = norm( I - U' * U ) / ( m * EPS ), if ROWCOL = 'C'. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --work;
+
+ /* Function Body */
+ *resid = 0.f;
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+ eps = slamch_("Precision");
+ if (*m < *n || *m == *n && lsame_(rowcol, "R")) {
+ *(unsigned char *)transu = 'N';
+ k = *n;
+ } else {
+ *(unsigned char *)transu = 'T';
+ k = *m;
+ }
+ mnmin = min(*m,*n);
+
+ if ((mnmin + 1) * mnmin <= *lwork) {
+ ldwork = mnmin;
+ } else {
+ ldwork = 0;
+ }
+ if (ldwork > 0) {
+
+/* Compute I - U*U' or I - U'*U. */
+
+ slaset_("Upper", &mnmin, &mnmin, &c_b7, &c_b8, &work[1], &ldwork);
+ ssyrk_("Upper", transu, &mnmin, &k, &c_b10, &u[u_offset], ldu, &c_b8,
+ &work[1], &ldwork);
+
+/* Compute norm( I - U*U' ) / ( K * EPS ) . */
+
+ *resid = slansy_("1", "Upper", &mnmin, &work[1], &ldwork, &work[
+ ldwork * mnmin + 1]);
+ *resid = *resid / (real) k / eps;
+ } else if (*(unsigned char *)transu == 'T') {
+
+/* Find the maximum element in abs( I - U'*U ) / ( m * EPS ) */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (i__ != j) {
+ tmp = 0.f;
+ } else {
+ tmp = 1.f;
+ }
+ tmp -= sdot_(m, &u[i__ * u_dim1 + 1], &c__1, &u[j * u_dim1 +
+ 1], &c__1);
+/* Computing MAX */
+ r__1 = *resid, r__2 = dabs(tmp);
+ *resid = dmax(r__1,r__2);
+/* L10: */
+ }
+/* L20: */
+ }
+ *resid = *resid / (real) (*m) / eps;
+ } else {
+
+/* Find the maximum element in abs( I - U*U' ) / ( n * EPS ) */
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (i__ != j) {
+ tmp = 0.f;
+ } else {
+ tmp = 1.f;
+ }
+ tmp -= sdot_(n, &u[j + u_dim1], ldu, &u[i__ + u_dim1], ldu);
+/* Computing MAX */
+ r__1 = *resid, r__2 = dabs(tmp);
+ *resid = dmax(r__1,r__2);
+/* L30: */
+ }
+/* L40: */
+ }
+ *resid = *resid / (real) (*n) / eps;
+ }
+ return 0;
+
+/* End of SORT01 */
+
+} /* sort01_ */
diff --git a/TESTING/EIG/sort03.c b/TESTING/EIG/sort03.c
new file mode 100644
index 0000000..b180c8a
--- /dev/null
+++ b/TESTING/EIG/sort03.c
@@ -0,0 +1,259 @@
+/* sort03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b7 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int sort03_(char *rc, integer *mu, integer *mv, integer *n,
+ integer *k, real *u, integer *ldu, real *v, integer *ldv, real *work,
+ integer *lwork, real *result, integer *info)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, v_dim1, v_offset, i__1, i__2;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ double r_sign(real *, real *);
+
+ /* Local variables */
+ integer i__, j;
+ real s;
+ integer irc, lmx;
+ real ulp, res1, res2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sort01_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, real *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SORT03 compares two orthogonal matrices U and V to see if their */
+/* corresponding rows or columns span the same spaces. The rows are */
+/* checked if RC = 'R', and the columns are checked if RC = 'C'. */
+
+/* RESULT is the maximum of */
+
+/* | V*V' - I | / ( MV ulp ), if RC = 'R', or */
+
+/* | V'*V - I | / ( MV ulp ), if RC = 'C', */
+
+/* and the maximum over rows (or columns) 1 to K of */
+
+/* | U(i) - S*V(i) |/ ( N ulp ) */
+
+/* where S is +-1 (chosen to minimize the expression), U(i) is the i-th */
+/* row (column) of U, and V(i) is the i-th row (column) of V. */
+
+/* Arguments */
+/* ========== */
+
+/* RC (input) CHARACTER*1 */
+/* If RC = 'R' the rows of U and V are to be compared. */
+/* If RC = 'C' the columns of U and V are to be compared. */
+
+/* MU (input) INTEGER */
+/* The number of rows of U if RC = 'R', and the number of */
+/* columns if RC = 'C'. If MU = 0 SORT03 does nothing. */
+/* MU must be at least zero. */
+
+/* MV (input) INTEGER */
+/* The number of rows of V if RC = 'R', and the number of */
+/* columns if RC = 'C'. If MV = 0 SORT03 does nothing. */
+/* MV must be at least zero. */
+
+/* N (input) INTEGER */
+/* If RC = 'R', the number of columns in the matrices U and V, */
+/* and if RC = 'C', the number of rows in U and V. If N = 0 */
+/* SORT03 does nothing. N must be at least zero. */
+
+/* K (input) INTEGER */
+/* The number of rows or columns of U and V to compare. */
+/* 0 <= K <= max(MU,MV). */
+
+/* U (input) REAL array, dimension (LDU,N) */
+/* The first matrix to compare. If RC = 'R', U is MU by N, and */
+/* if RC = 'C', U is N by MU. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. If RC = 'R', LDU >= max(1,MU), */
+/* and if RC = 'C', LDU >= max(1,N). */
+
+/* V (input) REAL array, dimension (LDV,N) */
+/* The second matrix to compare. If RC = 'R', V is MV by N, and */
+/* if RC = 'C', V is N by MV. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of V. If RC = 'R', LDV >= max(1,MV), */
+/* and if RC = 'C', LDV >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. For best performance, LWORK */
+/* should be at least N*N if RC = 'C' or M*M if RC = 'R', but */
+/* the tests will be done even if LWORK is 0. */
+
+/* RESULT (output) REAL */
+/* The value computed by the test described above. RESULT is */
+/* limited to 1/ulp to avoid overflow. */
+
+/* INFO (output) INTEGER */
+/* 0 indicates a successful exit */
+/* -k indicates the k-th parameter had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check inputs */
+
+ /* Parameter adjustments */
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (lsame_(rc, "R")) {
+ irc = 0;
+ } else if (lsame_(rc, "C")) {
+ irc = 1;
+ } else {
+ irc = -1;
+ }
+ if (irc == -1) {
+ *info = -1;
+ } else if (*mu < 0) {
+ *info = -2;
+ } else if (*mv < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > max(*mu,*mv)) {
+ *info = -5;
+ } else if (irc == 0 && *ldu < max(1,*mu) || irc == 1 && *ldu < max(1,*n))
+ {
+ *info = -7;
+ } else if (irc == 0 && *ldv < max(1,*mv) || irc == 1 && *ldv < max(1,*n))
+ {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SORT03", &i__1);
+ return 0;
+ }
+
+/* Initialize result */
+
+ *result = 0.f;
+ if (*mu == 0 || *mv == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Machine constants */
+
+ ulp = slamch_("Precision");
+
+ if (irc == 0) {
+
+/* Compare rows */
+
+ res1 = 0.f;
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ lmx = isamax_(n, &u[i__ + u_dim1], ldu);
+ s = r_sign(&c_b7, &u[i__ + lmx * u_dim1]) * r_sign(&c_b7, &v[i__
+ + lmx * v_dim1]);
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ r__2 = res1, r__3 = (r__1 = u[i__ + j * u_dim1] - s * v[i__ +
+ j * v_dim1], dabs(r__1));
+ res1 = dmax(r__2,r__3);
+/* L10: */
+ }
+/* L20: */
+ }
+ res1 /= (real) (*n) * ulp;
+
+/* Compute orthogonality of rows of V. */
+
+ sort01_("Rows", mv, n, &v[v_offset], ldv, &work[1], lwork, &res2);
+
+ } else {
+
+/* Compare columns */
+
+ res1 = 0.f;
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ lmx = isamax_(n, &u[i__ * u_dim1 + 1], &c__1);
+ s = r_sign(&c_b7, &u[lmx + i__ * u_dim1]) * r_sign(&c_b7, &v[lmx
+ + i__ * v_dim1]);
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ r__2 = res1, r__3 = (r__1 = u[j + i__ * u_dim1] - s * v[j +
+ i__ * v_dim1], dabs(r__1));
+ res1 = dmax(r__2,r__3);
+/* L30: */
+ }
+/* L40: */
+ }
+ res1 /= (real) (*n) * ulp;
+
+/* Compute orthogonality of columns of V. */
+
+ sort01_("Columns", n, mv, &v[v_offset], ldv, &work[1], lwork, &res2);
+ }
+
+/* Computing MIN */
+ r__1 = dmax(res1,res2), r__2 = 1.f / ulp;
+ *result = dmin(r__1,r__2);
+ return 0;
+
+/* End of SORT03 */
+
+} /* sort03_ */
diff --git a/TESTING/EIG/ssbt21.c b/TESTING/EIG/ssbt21.c
new file mode 100644
index 0000000..e88ec04
--- /dev/null
+++ b/TESTING/EIG/ssbt21.c
@@ -0,0 +1,289 @@
+/* ssbt21.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b22 = 1.f;
+static real c_b23 = 0.f;
+
+/* Subroutine */ int ssbt21_(char *uplo, integer *n, integer *ka, integer *ks,
+ real *a, integer *lda, real *d__, real *e, real *u, integer *ldu,
+ real *work, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j, jc, jr, lw, ika;
+ real ulp, unfl;
+ extern /* Subroutine */ int sspr_(char *, integer *, real *, real *,
+ integer *, real *), sspr2_(char *, integer *, real *,
+ real *, integer *, real *, integer *, real *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm;
+ char cuplo[1];
+ logical lower;
+ real wnorm;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *), slansb_(char *,
+ char *, integer *, integer *, real *, integer *, real *), slansp_(char *, char *, integer *, real *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSBT21 generally checks a decomposition of the form */
+
+/* A = U S U' */
+
+/* where ' means transpose, A is symmetric banded, U is */
+/* orthogonal, and S is diagonal (if KS=0) or symmetric */
+/* tridiagonal (if KS=1). */
+
+/* Specifically: */
+
+/* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU' | / ( n ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER */
+/* If UPLO='U', the upper triangle of A and V will be used and */
+/* the (strictly) lower triangle will not be referenced. */
+/* If UPLO='L', the lower triangle of A and V will be used and */
+/* the (strictly) upper triangle will not be referenced. */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, SSBT21 does nothing. */
+/* It must be at least zero. */
+
+/* KA (input) INTEGER */
+/* The bandwidth of the matrix A. It must be at least zero. If */
+/* it is larger than N-1, then max( 0, N-1 ) will be used. */
+
+/* KS (input) INTEGER */
+/* The bandwidth of the matrix S. It may only be zero or one. */
+/* If zero, then S is diagonal, and E is not referenced. If */
+/* one, then S is symmetric tri-diagonal. */
+
+/* A (input) REAL array, dimension (LDA, N) */
+/* The original (unfactored) matrix. It is assumed to be */
+/* symmetric, and only the upper (UPLO='U') or only the lower */
+/* (UPLO='L') will be referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least min( KA, N-1 ). */
+
+/* D (input) REAL array, dimension (N) */
+/* The diagonal of the (symmetric tri-) diagonal matrix S. */
+
+/* E (input) REAL array, dimension (N-1) */
+/* The off-diagonal of the (symmetric tri-) diagonal matrix S. */
+/* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and */
+/* (3,2) element, etc. */
+/* Not referenced if KS=0. */
+
+/* U (input) REAL array, dimension (LDU, N) */
+/* The orthogonal matrix in the decomposition, expressed as a */
+/* dense matrix (i.e., not as a product of Householder */
+/* transformations, Givens transformations, etc.) */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+
+/* WORK (workspace) REAL array, dimension (N**2+N) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Constants */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --work;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.f;
+ result[2] = 0.f;
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Computing MAX */
+/* Computing MIN */
+ i__3 = *n - 1;
+ i__1 = 0, i__2 = min(i__3,*ka);
+ ika = max(i__1,i__2);
+ lw = *n * (*n + 1) / 2;
+
+ if (lsame_(uplo, "U")) {
+ lower = FALSE_;
+ *(unsigned char *)cuplo = 'U';
+ } else {
+ lower = TRUE_;
+ *(unsigned char *)cuplo = 'L';
+ }
+
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon") * slamch_("Base");
+
+/* Some Error Checks */
+
+/* Do Test 1 */
+
+/* Norm of A: */
+
+/* Computing MAX */
+ r__1 = slansb_("1", cuplo, n, &ika, &a[a_offset], lda, &work[1]);
+ anorm = dmax(r__1,unfl);
+
+/* Compute error matrix: Error = A - U S U' */
+
+/* Copy A from SB to SP storage format. */
+
+ j = 0;
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ if (lower) {
+/* Computing MIN */
+ i__3 = ika + 1, i__4 = *n + 1 - jc;
+ i__2 = min(i__3,i__4);
+ for (jr = 1; jr <= i__2; ++jr) {
+ ++j;
+ work[j] = a[jr + jc * a_dim1];
+/* L10: */
+ }
+ i__2 = *n + 1 - jc;
+ for (jr = ika + 2; jr <= i__2; ++jr) {
+ ++j;
+ work[j] = 0.f;
+/* L20: */
+ }
+ } else {
+ i__2 = jc;
+ for (jr = ika + 2; jr <= i__2; ++jr) {
+ ++j;
+ work[j] = 0.f;
+/* L30: */
+ }
+/* Computing MIN */
+ i__2 = ika, i__3 = jc - 1;
+ for (jr = min(i__2,i__3); jr >= 0; --jr) {
+ ++j;
+ work[j] = a[ika + 1 - jr + jc * a_dim1];
+/* L40: */
+ }
+ }
+/* L50: */
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ r__1 = -d__[j];
+ sspr_(cuplo, n, &r__1, &u[j * u_dim1 + 1], &c__1, &work[1])
+ ;
+/* L60: */
+ }
+
+ if (*n > 1 && *ks == 1) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ r__1 = -e[j];
+ sspr2_(cuplo, n, &r__1, &u[j * u_dim1 + 1], &c__1, &u[(j + 1) *
+ u_dim1 + 1], &c__1, &work[1]);
+/* L70: */
+ }
+ }
+ wnorm = slansp_("1", cuplo, n, &work[1], &work[lw + 1]);
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.f) {
+/* Computing MIN */
+ r__1 = wnorm, r__2 = *n * anorm;
+ result[1] = dmin(r__1,r__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ r__1 = wnorm / anorm, r__2 = (real) (*n);
+ result[1] = dmin(r__1,r__2) / (*n * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute UU' - I */
+
+ sgemm_("N", "C", n, n, n, &c_b22, &u[u_offset], ldu, &u[u_offset], ldu, &
+ c_b23, &work[1], n);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[(*n + 1) * (j - 1) + 1] += -1.f;
+/* L80: */
+ }
+
+/* Computing MIN */
+/* Computing 2nd power */
+ i__1 = *n;
+ r__1 = slange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]),
+ r__2 = (real) (*n);
+ result[2] = dmin(r__1,r__2) / (*n * ulp);
+
+ return 0;
+
+/* End of SSBT21 */
+
+} /* ssbt21_ */
diff --git a/TESTING/EIG/ssgt01.c b/TESTING/EIG/ssgt01.c
new file mode 100644
index 0000000..5f5b18a
--- /dev/null
+++ b/TESTING/EIG/ssgt01.c
@@ -0,0 +1,217 @@
+/* ssgt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b6 = 1.f;
+static real c_b7 = 0.f;
+static integer c__1 = 1;
+static real c_b12 = -1.f;
+
+/* Subroutine */ int ssgt01_(integer *itype, char *uplo, integer *n, integer *
+ m, real *a, integer *lda, real *b, integer *ldb, real *z__, integer *
+ ldz, real *d__, real *work, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1;
+
+ /* Local variables */
+ integer i__;
+ real ulp;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real anorm;
+ extern /* Subroutine */ int ssymm_(char *, char *, integer *, integer *,
+ real *, real *, integer *, real *, integer *, real *, real *,
+ integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *), slansy_(char *,
+ char *, integer *, real *, integer *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* modified August 1997, a new parameter M is added to the calling */
+/* sequence. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSGT01 checks a decomposition of the form */
+
+/* A Z = B Z D or */
+/* A B Z = Z D or */
+/* B A Z = Z D */
+
+/* where A is a symmetric matrix, B is */
+/* symmetric positive definite, Z is orthogonal, and D is diagonal. */
+
+/* One of the following test ratios is computed: */
+
+/* ITYPE = 1: RESULT(1) = | A Z - B Z D | / ( |A| |Z| n ulp ) */
+
+/* ITYPE = 2: RESULT(1) = | A B Z - Z D | / ( |A| |Z| n ulp ) */
+
+/* ITYPE = 3: RESULT(1) = | B A Z - Z D | / ( |A| |Z| n ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* The form of the symmetric generalized eigenproblem. */
+/* = 1: A*z = (lambda)*B*z */
+/* = 2: A*B*z = (lambda)*z */
+/* = 3: B*A*z = (lambda)*z */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrices A and B is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* M (input) INTEGER */
+/* The number of eigenvalues found. 0 <= M <= N. */
+
+/* A (input) REAL array, dimension (LDA, N) */
+/* The original symmetric matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) REAL array, dimension (LDB, N) */
+/* The original symmetric positive definite matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Z (input) REAL array, dimension (LDZ, M) */
+/* The computed eigenvectors of the generalized eigenproblem. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= max(1,N). */
+
+/* D (input) REAL array, dimension (M) */
+/* The computed eigenvalues of the generalized eigenproblem. */
+
+/* WORK (workspace) REAL array, dimension (N*N) */
+
+/* RESULT (output) REAL array, dimension (1) */
+/* The test ratio as described above. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --d__;
+ --work;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.f;
+ if (*n <= 0) {
+ return 0;
+ }
+
+ ulp = slamch_("Epsilon");
+
+/* Compute product of 1-norms of A and Z. */
+
+ anorm = slansy_("1", uplo, n, &a[a_offset], lda, &work[1]) * slange_("1", n, m, &z__[z_offset], ldz, &work[1]);
+ if (anorm == 0.f) {
+ anorm = 1.f;
+ }
+
+ if (*itype == 1) {
+
+/* Norm of AZ - BZD */
+
+ ssymm_("Left", uplo, n, m, &c_b6, &a[a_offset], lda, &z__[z_offset],
+ ldz, &c_b7, &work[1], n);
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sscal_(n, &d__[i__], &z__[i__ * z_dim1 + 1], &c__1);
+/* L10: */
+ }
+ ssymm_("Left", uplo, n, m, &c_b6, &b[b_offset], ldb, &z__[z_offset],
+ ldz, &c_b12, &work[1], n);
+
+ result[1] = slange_("1", n, m, &work[1], n, &work[1]) /
+ anorm / (*n * ulp);
+
+ } else if (*itype == 2) {
+
+/* Norm of ABZ - ZD */
+
+ ssymm_("Left", uplo, n, m, &c_b6, &b[b_offset], ldb, &z__[z_offset],
+ ldz, &c_b7, &work[1], n);
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sscal_(n, &d__[i__], &z__[i__ * z_dim1 + 1], &c__1);
+/* L20: */
+ }
+ ssymm_("Left", uplo, n, m, &c_b6, &a[a_offset], lda, &work[1], n, &
+ c_b12, &z__[z_offset], ldz);
+
+ result[1] = slange_("1", n, m, &z__[z_offset], ldz, &work[1]) / anorm / (*n * ulp);
+
+ } else if (*itype == 3) {
+
+/* Norm of BAZ - ZD */
+
+ ssymm_("Left", uplo, n, m, &c_b6, &a[a_offset], lda, &z__[z_offset],
+ ldz, &c_b7, &work[1], n);
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sscal_(n, &d__[i__], &z__[i__ * z_dim1 + 1], &c__1);
+/* L30: */
+ }
+ ssymm_("Left", uplo, n, m, &c_b6, &b[b_offset], ldb, &work[1], n, &
+ c_b12, &z__[z_offset], ldz);
+
+ result[1] = slange_("1", n, m, &z__[z_offset], ldz, &work[1]) / anorm / (*n * ulp);
+ }
+
+ return 0;
+
+/* End of SSGT01 */
+
+} /* ssgt01_ */
diff --git a/TESTING/EIG/sslect.c b/TESTING/EIG/sslect.c
new file mode 100644
index 0000000..7aa53f3
--- /dev/null
+++ b/TESTING/EIG/sslect.c
@@ -0,0 +1,108 @@
+/* sslect.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ real selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+logical sslect_(real *zr, real *zi)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+ logical ret_val;
+
+ /* Local variables */
+ integer i__;
+ real x, rmin;
+ extern doublereal slapy2_(real *, real *);
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSLECT returns .TRUE. if the eigenvalue ZR+sqrt(-1)*ZI is to be */
+/* selected, and otherwise it returns .FALSE. */
+/* It is used by SCHK41 to test if SGEES succesfully sorts eigenvalues, */
+/* and by SCHK43 to test if SGEESX succesfully sorts eigenvalues. */
+
+/* The common block /SSLCT/ controls how eigenvalues are selected. */
+/* If SELOPT = 0, then SSLECT return .TRUE. when ZR is less than zero, */
+/* and .FALSE. otherwise. */
+/* If SELOPT is at least 1, SSLECT returns SELVAL(SELOPT) and adds 1 */
+/* to SELOPT, cycling back to 1 at SELMAX. */
+
+/* Arguments */
+/* ========= */
+
+/* ZR (input) REAL */
+/* The real part of a complex eigenvalue ZR + i*ZI. */
+
+/* ZI (input) REAL */
+/* The imaginary part of a complex eigenvalue ZR + i*ZI. */
+
+/* ===================================================================== */
+
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (sslct_1.selopt == 0) {
+ ret_val = *zr < 0.f;
+ } else {
+ r__1 = *zr - sslct_1.selwr[0];
+ r__2 = *zi - sslct_1.selwi[0];
+ rmin = slapy2_(&r__1, &r__2);
+ ret_val = sslct_1.selval[0];
+ i__1 = sslct_1.seldim;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ r__1 = *zr - sslct_1.selwr[i__ - 1];
+ r__2 = *zi - sslct_1.selwi[i__ - 1];
+ x = slapy2_(&r__1, &r__2);
+ if (x <= rmin) {
+ rmin = x;
+ ret_val = sslct_1.selval[i__ - 1];
+ }
+/* L10: */
+ }
+ }
+ return ret_val;
+
+/* End of SSLECT */
+
+} /* sslect_ */
diff --git a/TESTING/EIG/sspt21.c b/TESTING/EIG/sspt21.c
new file mode 100644
index 0000000..963b254
--- /dev/null
+++ b/TESTING/EIG/sspt21.c
@@ -0,0 +1,460 @@
+/* sspt21.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b10 = 0.f;
+static integer c__1 = 1;
+static real c_b26 = 1.f;
+
+/* Subroutine */ int sspt21_(integer *itype, char *uplo, integer *n, integer *
+ kband, real *ap, real *d__, real *e, real *u, integer *ldu, real *vp,
+ real *tau, real *work, real *result)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, i__1, i__2;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j, jp, jr, jp1, lap;
+ real ulp, unfl, temp;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ extern /* Subroutine */ int sspr_(char *, integer *, real *, real *,
+ integer *, real *), sspr2_(char *, integer *, real *,
+ real *, integer *, real *, integer *, real *);
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm;
+ char cuplo[1];
+ real vsave;
+ logical lower;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ real wnorm;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *), sspmv_(char *, integer *, real *, real *,
+ real *, integer *, real *, real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *);
+ extern doublereal slansp_(char *, char *, integer *, real *, real *);
+ extern /* Subroutine */ int sopmtr_(char *, char *, char *, integer *,
+ integer *, real *, real *, real *, integer *, real *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSPT21 generally checks a decomposition of the form */
+
+/* A = U S U' */
+
+/* where ' means transpose, A is symmetric (stored in packed format), U */
+/* is orthogonal, and S is diagonal (if KBAND=0) or symmetric */
+/* tridiagonal (if KBAND=1). If ITYPE=1, then U is represented as a */
+/* dense matrix, otherwise the U is expressed as a product of */
+/* Householder transformations, whose vectors are stored in the array */
+/* "V" and whose scaling constants are in "TAU"; we shall use the */
+/* letter "V" to refer to the product of Householder transformations */
+/* (which should be equal to U). */
+
+/* Specifically, if ITYPE=1, then: */
+
+/* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU' | / ( n ulp ) */
+
+/* If ITYPE=2, then: */
+
+/* RESULT(1) = | A - V S V' | / ( |A| n ulp ) */
+
+/* If ITYPE=3, then: */
+
+/* RESULT(1) = | I - VU' | / ( n ulp ) */
+
+/* Packed storage means that, for example, if UPLO='U', then the columns */
+/* of the upper triangle of A are stored one after another, so that */
+/* A(1,j+1) immediately follows A(j,j) in the array AP. Similarly, if */
+/* UPLO='L', then the columns of the lower triangle of A are stored one */
+/* after another in AP, so that A(j+1,j+1) immediately follows A(n,j) */
+/* in the array AP. This means that A(i,j) is stored in: */
+
+/* AP( i + j*(j-1)/2 ) if UPLO='U' */
+
+/* AP( i + (2*n-j)*(j-1)/2 ) if UPLO='L' */
+
+/* The array VP bears the same relation to the matrix V that A does to */
+/* AP. */
+
+/* For ITYPE > 1, the transformation U is expressed as a product */
+/* of Householder transformations: */
+
+/* If UPLO='U', then V = H(n-1)...H(1), where */
+
+/* H(j) = I - tau(j) v(j) v(j)' */
+
+/* and the first j-1 elements of v(j) are stored in V(1:j-1,j+1), */
+/* (i.e., VP( j*(j+1)/2 + 1 : j*(j+1)/2 + j-1 ) ), */
+/* the j-th element is 1, and the last n-j elements are 0. */
+
+/* If UPLO='L', then V = H(1)...H(n-1), where */
+
+/* H(j) = I - tau(j) v(j) v(j)' */
+
+/* and the first j elements of v(j) are 0, the (j+1)-st is 1, and the */
+/* (j+2)-nd through n-th elements are stored in V(j+2:n,j) (i.e., */
+/* in VP( (2*n-j)*(j-1)/2 + j+2 : (2*n-j)*(j-1)/2 + n ) .) */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the type of tests to be performed. */
+/* 1: U expressed as a dense orthogonal matrix: */
+/* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU' | / ( n ulp ) */
+
+/* 2: U expressed as a product V of Housholder transformations: */
+/* RESULT(1) = | A - V S V' | / ( |A| n ulp ) */
+
+/* 3: U expressed both as a dense orthogonal matrix and */
+/* as a product of Housholder transformations: */
+/* RESULT(1) = | I - VU' | / ( n ulp ) */
+
+/* UPLO (input) CHARACTER */
+/* If UPLO='U', AP and VP are considered to contain the upper */
+/* triangle of A and V. */
+/* If UPLO='L', AP and VP are considered to contain the lower */
+/* triangle of A and V. */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, SSPT21 does nothing. */
+/* It must be at least zero. */
+
+/* KBAND (input) INTEGER */
+/* The bandwidth of the matrix. It may only be zero or one. */
+/* If zero, then S is diagonal, and E is not referenced. If */
+/* one, then S is symmetric tri-diagonal. */
+
+/* AP (input) REAL array, dimension (N*(N+1)/2) */
+/* The original (unfactored) matrix. It is assumed to be */
+/* symmetric, and contains the columns of just the upper */
+/* triangle (UPLO='U') or only the lower triangle (UPLO='L'), */
+/* packed one after another. */
+
+/* D (input) REAL array, dimension (N) */
+/* The diagonal of the (symmetric tri-) diagonal matrix. */
+
+/* E (input) REAL array, dimension (N-1) */
+/* The off-diagonal of the (symmetric tri-) diagonal matrix. */
+/* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and */
+/* (3,2) element, etc. */
+/* Not referenced if KBAND=0. */
+
+/* U (input) REAL array, dimension (LDU, N) */
+/* If ITYPE=1 or 3, this contains the orthogonal matrix in */
+/* the decomposition, expressed as a dense matrix. If ITYPE=2, */
+/* then it is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+
+/* VP (input) REAL array, dimension (N*(N+1)/2) */
+/* If ITYPE=2 or 3, the columns of this array contain the */
+/* Householder vectors used to describe the orthogonal matrix */
+/* in the decomposition, as described in purpose. */
+/* *NOTE* If ITYPE=2 or 3, V is modified and restored. The */
+/* subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U') */
+/* is set to one, and later reset to its original value, during */
+/* the course of the calculation. */
+/* If ITYPE=1, then it is neither referenced nor modified. */
+
+/* TAU (input) REAL array, dimension (N) */
+/* If ITYPE >= 2, then TAU(j) is the scalar factor of */
+/* v(j) v(j)' in the Householder transformation H(j) of */
+/* the product U = H(1)...H(n-2) */
+/* If ITYPE < 2, then TAU is not referenced. */
+
+/* WORK (workspace) REAL array, dimension (N**2+N) */
+/* Workspace. */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+/* RESULT(1) is always modified. RESULT(2) is modified only */
+/* if ITYPE=1. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Constants */
+
+ /* Parameter adjustments */
+ --ap;
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --vp;
+ --tau;
+ --work;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.f;
+ if (*itype == 1) {
+ result[2] = 0.f;
+ }
+ if (*n <= 0) {
+ return 0;
+ }
+
+ lap = *n * (*n + 1) / 2;
+
+ if (lsame_(uplo, "U")) {
+ lower = FALSE_;
+ *(unsigned char *)cuplo = 'U';
+ } else {
+ lower = TRUE_;
+ *(unsigned char *)cuplo = 'L';
+ }
+
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon") * slamch_("Base");
+
+/* Some Error Checks */
+
+ if (*itype < 1 || *itype > 3) {
+ result[1] = 10.f / ulp;
+ return 0;
+ }
+
+/* Do Test 1 */
+
+/* Norm of A: */
+
+ if (*itype == 3) {
+ anorm = 1.f;
+ } else {
+/* Computing MAX */
+ r__1 = slansp_("1", cuplo, n, &ap[1], &work[1]);
+ anorm = dmax(r__1,unfl);
+ }
+
+/* Compute error matrix: */
+
+ if (*itype == 1) {
+
+/* ITYPE=1: error = A - U S U' */
+
+ slaset_("Full", n, n, &c_b10, &c_b10, &work[1], n);
+ scopy_(&lap, &ap[1], &c__1, &work[1], &c__1);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ r__1 = -d__[j];
+ sspr_(cuplo, n, &r__1, &u[j * u_dim1 + 1], &c__1, &work[1]);
+/* L10: */
+ }
+
+ if (*n > 1 && *kband == 1) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ r__1 = -e[j];
+ sspr2_(cuplo, n, &r__1, &u[j * u_dim1 + 1], &c__1, &u[(j + 1)
+ * u_dim1 + 1], &c__1, &work[1]);
+/* L20: */
+ }
+ }
+/* Computing 2nd power */
+ i__1 = *n;
+ wnorm = slansp_("1", cuplo, n, &work[1], &work[i__1 * i__1 + 1]);
+
+ } else if (*itype == 2) {
+
+/* ITYPE=2: error = V S V' - A */
+
+ slaset_("Full", n, n, &c_b10, &c_b10, &work[1], n);
+
+ if (lower) {
+ work[lap] = d__[*n];
+ for (j = *n - 1; j >= 1; --j) {
+ jp = ((*n << 1) - j) * (j - 1) / 2;
+ jp1 = jp + *n - j;
+ if (*kband == 1) {
+ work[jp + j + 1] = (1.f - tau[j]) * e[j];
+ i__1 = *n;
+ for (jr = j + 2; jr <= i__1; ++jr) {
+ work[jp + jr] = -tau[j] * e[j] * vp[jp + jr];
+/* L30: */
+ }
+ }
+
+ if (tau[j] != 0.f) {
+ vsave = vp[jp + j + 1];
+ vp[jp + j + 1] = 1.f;
+ i__1 = *n - j;
+ sspmv_("L", &i__1, &c_b26, &work[jp1 + j + 1], &vp[jp + j
+ + 1], &c__1, &c_b10, &work[lap + 1], &c__1);
+ i__1 = *n - j;
+ temp = tau[j] * -.5f * sdot_(&i__1, &work[lap + 1], &c__1,
+ &vp[jp + j + 1], &c__1);
+ i__1 = *n - j;
+ saxpy_(&i__1, &temp, &vp[jp + j + 1], &c__1, &work[lap +
+ 1], &c__1);
+ i__1 = *n - j;
+ r__1 = -tau[j];
+ sspr2_("L", &i__1, &r__1, &vp[jp + j + 1], &c__1, &work[
+ lap + 1], &c__1, &work[jp1 + j + 1]);
+ vp[jp + j + 1] = vsave;
+ }
+ work[jp + j] = d__[j];
+/* L40: */
+ }
+ } else {
+ work[1] = d__[1];
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ jp = j * (j - 1) / 2;
+ jp1 = jp + j;
+ if (*kband == 1) {
+ work[jp1 + j] = (1.f - tau[j]) * e[j];
+ i__2 = j - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ work[jp1 + jr] = -tau[j] * e[j] * vp[jp1 + jr];
+/* L50: */
+ }
+ }
+
+ if (tau[j] != 0.f) {
+ vsave = vp[jp1 + j];
+ vp[jp1 + j] = 1.f;
+ sspmv_("U", &j, &c_b26, &work[1], &vp[jp1 + 1], &c__1, &
+ c_b10, &work[lap + 1], &c__1);
+ temp = tau[j] * -.5f * sdot_(&j, &work[lap + 1], &c__1, &
+ vp[jp1 + 1], &c__1);
+ saxpy_(&j, &temp, &vp[jp1 + 1], &c__1, &work[lap + 1], &
+ c__1);
+ r__1 = -tau[j];
+ sspr2_("U", &j, &r__1, &vp[jp1 + 1], &c__1, &work[lap + 1]
+, &c__1, &work[1]);
+ vp[jp1 + j] = vsave;
+ }
+ work[jp1 + j + 1] = d__[j + 1];
+/* L60: */
+ }
+ }
+
+ i__1 = lap;
+ for (j = 1; j <= i__1; ++j) {
+ work[j] -= ap[j];
+/* L70: */
+ }
+ wnorm = slansp_("1", cuplo, n, &work[1], &work[lap + 1]);
+
+ } else if (*itype == 3) {
+
+/* ITYPE=3: error = U V' - I */
+
+ if (*n < 2) {
+ return 0;
+ }
+ slacpy_(" ", n, n, &u[u_offset], ldu, &work[1], n);
+/* Computing 2nd power */
+ i__1 = *n;
+ sopmtr_("R", cuplo, "T", n, n, &vp[1], &tau[1], &work[1], n, &work[
+ i__1 * i__1 + 1], &iinfo);
+ if (iinfo != 0) {
+ result[1] = 10.f / ulp;
+ return 0;
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[(*n + 1) * (j - 1) + 1] += -1.f;
+/* L80: */
+ }
+
+/* Computing 2nd power */
+ i__1 = *n;
+ wnorm = slange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]);
+ }
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.f) {
+/* Computing MIN */
+ r__1 = wnorm, r__2 = *n * anorm;
+ result[1] = dmin(r__1,r__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ r__1 = wnorm / anorm, r__2 = (real) (*n);
+ result[1] = dmin(r__1,r__2) / (*n * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute UU' - I */
+
+ if (*itype == 1) {
+ sgemm_("N", "C", n, n, n, &c_b26, &u[u_offset], ldu, &u[u_offset],
+ ldu, &c_b10, &work[1], n);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[(*n + 1) * (j - 1) + 1] += -1.f;
+/* L90: */
+ }
+
+/* Computing MIN */
+/* Computing 2nd power */
+ i__1 = *n;
+ r__1 = slange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]), r__2 = (real) (*n);
+ result[2] = dmin(r__1,r__2) / (*n * ulp);
+ }
+
+ return 0;
+
+/* End of SSPT21 */
+
+} /* sspt21_ */
diff --git a/TESTING/EIG/sstech.c b/TESTING/EIG/sstech.c
new file mode 100644
index 0000000..3baf397
--- /dev/null
+++ b/TESTING/EIG/sstech.c
@@ -0,0 +1,220 @@
+/* sstech.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sstech_(integer *n, real *a, real *b, real *eig, real *
+ tol, real *work, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j;
+ real mx, eps, emin;
+ integer isub, bpnt, numl, numu, tpnt, count;
+ real lower, upper, tuppr;
+ extern doublereal slamch_(char *);
+ real unflep;
+ extern /* Subroutine */ int sstect_(integer *, real *, real *, real *,
+ integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Let T be the tridiagonal matrix with diagonal entries A(1) ,..., */
+/* A(N) and offdiagonal entries B(1) ,..., B(N-1)). SSTECH checks to */
+/* see if EIG(1) ,..., EIG(N) are indeed accurate eigenvalues of T. */
+/* It does this by expanding each EIG(I) into an interval */
+/* [SVD(I) - EPS, SVD(I) + EPS], merging overlapping intervals if */
+/* any, and using Sturm sequences to count and verify whether each */
+/* resulting interval has the correct number of eigenvalues (using */
+/* SSTECT). Here EPS = TOL*MACHEPS*MAXEIG, where MACHEPS is the */
+/* machine precision and MAXEIG is the absolute value of the largest */
+/* eigenvalue. If each interval contains the correct number of */
+/* eigenvalues, INFO = 0 is returned, otherwise INFO is the index of */
+/* the first eigenvalue in the first bad interval. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The dimension of the tridiagonal matrix T. */
+
+/* A (input) REAL array, dimension (N) */
+/* The diagonal entries of the tridiagonal matrix T. */
+
+/* B (input) REAL array, dimension (N-1) */
+/* The offdiagonal entries of the tridiagonal matrix T. */
+
+/* EIG (input) REAL array, dimension (N) */
+/* The purported eigenvalues to be checked. */
+
+/* TOL (input) REAL */
+/* Error tolerance for checking, a multiple of the */
+/* machine precision. */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* 0 if the eigenvalues are all correct (to within */
+/* 1 +- TOL*MACHEPS*MAXEIG) */
+/* >0 if the interval containing the INFO-th eigenvalue */
+/* contains the incorrect number of eigenvalues. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check input parameters */
+
+ /* Parameter adjustments */
+ --work;
+ --eig;
+ --b;
+ --a;
+
+ /* Function Body */
+ *info = 0;
+ if (*n == 0) {
+ return 0;
+ }
+ if (*n < 0) {
+ *info = -1;
+ return 0;
+ }
+ if (*tol < 0.f) {
+ *info = -5;
+ return 0;
+ }
+
+/* Get machine constants */
+
+ eps = slamch_("Epsilon") * slamch_("Base");
+ unflep = slamch_("Safe minimum") / eps;
+ eps = *tol * eps;
+
+/* Compute maximum absolute eigenvalue, error tolerance */
+
+ mx = dabs(eig[1]);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = mx, r__3 = (r__1 = eig[i__], dabs(r__1));
+ mx = dmax(r__2,r__3);
+/* L10: */
+ }
+/* Computing MAX */
+ r__1 = eps * mx;
+ eps = dmax(r__1,unflep);
+
+/* Sort eigenvalues from EIG into WORK */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__] = eig[i__];
+/* L20: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ isub = 1;
+ emin = work[1];
+ i__2 = *n + 1 - i__;
+ for (j = 2; j <= i__2; ++j) {
+ if (work[j] < emin) {
+ isub = j;
+ emin = work[j];
+ }
+/* L30: */
+ }
+ if (isub != *n + 1 - i__) {
+ work[isub] = work[*n + 1 - i__];
+ work[*n + 1 - i__] = emin;
+ }
+/* L40: */
+ }
+
+/* TPNT points to singular value at right endpoint of interval */
+/* BPNT points to singular value at left endpoint of interval */
+
+ tpnt = 1;
+ bpnt = 1;
+
+/* Begin loop over all intervals */
+
+L50:
+ upper = work[tpnt] + eps;
+ lower = work[bpnt] - eps;
+
+/* Begin loop merging overlapping intervals */
+
+L60:
+ if (bpnt == *n) {
+ goto L70;
+ }
+ tuppr = work[bpnt + 1] + eps;
+ if (tuppr < lower) {
+ goto L70;
+ }
+
+/* Merge */
+
+ ++bpnt;
+ lower = work[bpnt] - eps;
+ goto L60;
+L70:
+
+/* Count singular values in interval [ LOWER, UPPER ] */
+
+ sstect_(n, &a[1], &b[1], &lower, &numl);
+ sstect_(n, &a[1], &b[1], &upper, &numu);
+ count = numu - numl;
+ if (count != bpnt - tpnt + 1) {
+
+/* Wrong number of singular values in interval */
+
+ *info = tpnt;
+ goto L80;
+ }
+ tpnt = bpnt + 1;
+ bpnt = tpnt;
+ if (tpnt <= *n) {
+ goto L50;
+ }
+L80:
+ return 0;
+
+/* End of SSTECH */
+
+} /* sstech_ */
diff --git a/TESTING/EIG/sstect.c b/TESTING/EIG/sstect.c
new file mode 100644
index 0000000..0dd6516
--- /dev/null
+++ b/TESTING/EIG/sstect.c
@@ -0,0 +1,167 @@
+/* sstect.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sstect_(integer *n, real *a, real *b, real *shift,
+ integer *num)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real u, m1, m2, mx, tmp, tom, sun, sov, unfl, ovfl, ssun;
+ extern doublereal slamch_(char *);
+ real sshift;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSTECT counts the number NUM of eigenvalues of a tridiagonal */
+/* matrix T which are less than or equal to SHIFT. T has */
+/* diagonal entries A(1), ... , A(N), and offdiagonal entries */
+/* B(1), ..., B(N-1). */
+/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */
+/* Matrix", Report CS41, Computer Science Dept., Stanford */
+/* University, July 21, 1966 */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The dimension of the tridiagonal matrix T. */
+
+/* A (input) REAL array, dimension (N) */
+/* The diagonal entries of the tridiagonal matrix T. */
+
+/* B (input) REAL array, dimension (N-1) */
+/* The offdiagonal entries of the tridiagonal matrix T. */
+
+/* SHIFT (input) REAL */
+/* The shift, used as described under Purpose. */
+
+/* NUM (output) INTEGER */
+/* The number of eigenvalues of T less than or equal */
+/* to SHIFT. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Get machine constants */
+
+ /* Parameter adjustments */
+ --b;
+ --a;
+
+ /* Function Body */
+ unfl = slamch_("Safe minimum");
+ ovfl = slamch_("Overflow");
+
+/* Find largest entry */
+
+ mx = dabs(a[1]);
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__3 = mx, r__4 = (r__1 = a[i__ + 1], dabs(r__1)), r__3 = max(r__3,
+ r__4), r__4 = (r__2 = b[i__], dabs(r__2));
+ mx = dmax(r__3,r__4);
+/* L10: */
+ }
+
+/* Handle easy cases, including zero matrix */
+
+ if (*shift >= mx * 3.f) {
+ *num = *n;
+ return 0;
+ }
+ if (*shift < mx * -3.f) {
+ *num = 0;
+ return 0;
+ }
+
+/* Compute scale factors as in Kahan's report */
+/* At this point, MX .NE. 0 so we can divide by it */
+
+ sun = sqrt(unfl);
+ ssun = sqrt(sun);
+ sov = sqrt(ovfl);
+ tom = ssun * sov;
+ if (mx <= 1.f) {
+ m1 = 1.f / mx;
+ m2 = tom;
+ } else {
+ m1 = 1.f;
+ m2 = tom / mx;
+ }
+
+/* Begin counting */
+
+ *num = 0;
+ sshift = *shift * m1 * m2;
+ u = a[1] * m1 * m2 - sshift;
+ if (u <= sun) {
+ if (u <= 0.f) {
+ ++(*num);
+ if (u > -sun) {
+ u = -sun;
+ }
+ } else {
+ u = sun;
+ }
+ }
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ tmp = b[i__ - 1] * m1 * m2;
+ u = a[i__] * m1 * m2 - tmp * (tmp / u) - sshift;
+ if (u <= sun) {
+ if (u <= 0.f) {
+ ++(*num);
+ if (u > -sun) {
+ u = -sun;
+ }
+ } else {
+ u = sun;
+ }
+ }
+/* L20: */
+ }
+ return 0;
+
+/* End of SSTECT */
+
+} /* sstect_ */
diff --git a/TESTING/EIG/sstt21.c b/TESTING/EIG/sstt21.c
new file mode 100644
index 0000000..f1a5159
--- /dev/null
+++ b/TESTING/EIG/sstt21.c
@@ -0,0 +1,242 @@
+/* sstt21.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b5 = 0.f;
+static integer c__1 = 1;
+static real c_b19 = 1.f;
+
+/* Subroutine */ int sstt21_(integer *n, integer *kband, real *ad, real *ae,
+ real *sd, real *se, real *u, integer *ldu, real *work, real *result)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, i__1;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer j;
+ real ulp, unfl;
+ extern /* Subroutine */ int ssyr_(char *, integer *, real *, real *,
+ integer *, real *, integer *);
+ real temp1, temp2;
+ extern /* Subroutine */ int ssyr2_(char *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *), sgemm_(
+ char *, char *, integer *, integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, real *, integer *);
+ real anorm, wnorm;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSTT21 checks a decomposition of the form */
+
+/* A = U S U' */
+
+/* where ' means transpose, A is symmetric tridiagonal, U is orthogonal, */
+/* and S is diagonal (if KBAND=0) or symmetric tridiagonal (if KBAND=1). */
+/* Two tests are performed: */
+
+/* RESULT(1) = | A - U S U' | / ( |A| n ulp ) */
+
+/* RESULT(2) = | I - UU' | / ( n ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, SSTT21 does nothing. */
+/* It must be at least zero. */
+
+/* KBAND (input) INTEGER */
+/* The bandwidth of the matrix S. It may only be zero or one. */
+/* If zero, then S is diagonal, and SE is not referenced. If */
+/* one, then S is symmetric tri-diagonal. */
+
+/* AD (input) REAL array, dimension (N) */
+/* The diagonal of the original (unfactored) matrix A. A is */
+/* assumed to be symmetric tridiagonal. */
+
+/* AE (input) REAL array, dimension (N-1) */
+/* The off-diagonal of the original (unfactored) matrix A. A */
+/* is assumed to be symmetric tridiagonal. AE(1) is the (1,2) */
+/* and (2,1) element, AE(2) is the (2,3) and (3,2) element, etc. */
+
+/* SD (input) REAL array, dimension (N) */
+/* The diagonal of the (symmetric tri-) diagonal matrix S. */
+
+/* SE (input) REAL array, dimension (N-1) */
+/* The off-diagonal of the (symmetric tri-) diagonal matrix S. */
+/* Not referenced if KBSND=0. If KBAND=1, then AE(1) is the */
+/* (1,2) and (2,1) element, SE(2) is the (2,3) and (3,2) */
+/* element, etc. */
+
+/* U (input) REAL array, dimension (LDU, N) */
+/* The orthogonal matrix in the decomposition. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N. */
+
+/* WORK (workspace) REAL array, dimension (N*(N+1)) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+/* RESULT(1) is always modified. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Constants */
+
+ /* Parameter adjustments */
+ --ad;
+ --ae;
+ --sd;
+ --se;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --work;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.f;
+ result[2] = 0.f;
+ if (*n <= 0) {
+ return 0;
+ }
+
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Precision");
+
+/* Do Test 1 */
+
+/* Copy A & Compute its 1-Norm: */
+
+ slaset_("Full", n, n, &c_b5, &c_b5, &work[1], n);
+
+ anorm = 0.f;
+ temp1 = 0.f;
+
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ work[(*n + 1) * (j - 1) + 1] = ad[j];
+ work[(*n + 1) * (j - 1) + 2] = ae[j];
+ temp2 = (r__1 = ae[j], dabs(r__1));
+/* Computing MAX */
+ r__2 = anorm, r__3 = (r__1 = ad[j], dabs(r__1)) + temp1 + temp2;
+ anorm = dmax(r__2,r__3);
+ temp1 = temp2;
+/* L10: */
+ }
+
+/* Computing 2nd power */
+ i__1 = *n;
+ work[i__1 * i__1] = ad[*n];
+/* Computing MAX */
+ r__2 = anorm, r__3 = (r__1 = ad[*n], dabs(r__1)) + temp1, r__2 = max(r__2,
+ r__3);
+ anorm = dmax(r__2,unfl);
+
+/* Norm of A - USU' */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ r__1 = -sd[j];
+ ssyr_("L", n, &r__1, &u[j * u_dim1 + 1], &c__1, &work[1], n);
+/* L20: */
+ }
+
+ if (*n > 1 && *kband == 1) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ r__1 = -se[j];
+ ssyr2_("L", n, &r__1, &u[j * u_dim1 + 1], &c__1, &u[(j + 1) *
+ u_dim1 + 1], &c__1, &work[1], n);
+/* L30: */
+ }
+ }
+
+/* Computing 2nd power */
+ i__1 = *n;
+ wnorm = slansy_("1", "L", n, &work[1], n, &work[i__1 * i__1 + 1]);
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.f) {
+/* Computing MIN */
+ r__1 = wnorm, r__2 = *n * anorm;
+ result[1] = dmin(r__1,r__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ r__1 = wnorm / anorm, r__2 = (real) (*n);
+ result[1] = dmin(r__1,r__2) / (*n * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute UU' - I */
+
+ sgemm_("N", "C", n, n, n, &c_b19, &u[u_offset], ldu, &u[u_offset], ldu, &
+ c_b5, &work[1], n);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[(*n + 1) * (j - 1) + 1] += -1.f;
+/* L40: */
+ }
+
+/* Computing MIN */
+/* Computing 2nd power */
+ i__1 = *n;
+ r__1 = (real) (*n), r__2 = slange_("1", n, n, &work[1], n, &work[i__1 *
+ i__1 + 1]);
+ result[2] = dmin(r__1,r__2) / (*n * ulp);
+
+ return 0;
+
+/* End of SSTT21 */
+
+} /* sstt21_ */
diff --git a/TESTING/EIG/sstt22.c b/TESTING/EIG/sstt22.c
new file mode 100644
index 0000000..9fa5406
--- /dev/null
+++ b/TESTING/EIG/sstt22.c
@@ -0,0 +1,246 @@
+/* sstt22.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b12 = 1.f;
+static real c_b13 = 0.f;
+
+/* Subroutine */ int sstt22_(integer *n, integer *m, integer *kband, real *ad,
+ real *ae, real *sd, real *se, real *u, integer *ldu, real *work,
+ integer *ldwork, real *result)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, work_dim1, work_offset, i__1, i__2, i__3;
+ real r__1, r__2, r__3, r__4, r__5;
+
+ /* Local variables */
+ integer i__, j, k;
+ real ulp, aukj, unfl;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm, wnorm;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *), slansy_(char *,
+ char *, integer *, real *, integer *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSTT22 checks a set of M eigenvalues and eigenvectors, */
+
+/* A U = U S */
+
+/* where A is symmetric tridiagonal, the columns of U are orthogonal, */
+/* and S is diagonal (if KBAND=0) or symmetric tridiagonal (if KBAND=1). */
+/* Two tests are performed: */
+
+/* RESULT(1) = | U' A U - S | / ( |A| m ulp ) */
+
+/* RESULT(2) = | I - U'U | / ( m ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, SSTT22 does nothing. */
+/* It must be at least zero. */
+
+/* M (input) INTEGER */
+/* The number of eigenpairs to check. If it is zero, SSTT22 */
+/* does nothing. It must be at least zero. */
+
+/* KBAND (input) INTEGER */
+/* The bandwidth of the matrix S. It may only be zero or one. */
+/* If zero, then S is diagonal, and SE is not referenced. If */
+/* one, then S is symmetric tri-diagonal. */
+
+/* AD (input) REAL array, dimension (N) */
+/* The diagonal of the original (unfactored) matrix A. A is */
+/* assumed to be symmetric tridiagonal. */
+
+/* AE (input) REAL array, dimension (N) */
+/* The off-diagonal of the original (unfactored) matrix A. A */
+/* is assumed to be symmetric tridiagonal. AE(1) is ignored, */
+/* AE(2) is the (1,2) and (2,1) element, etc. */
+
+/* SD (input) REAL array, dimension (N) */
+/* The diagonal of the (symmetric tri-) diagonal matrix S. */
+
+/* SE (input) REAL array, dimension (N) */
+/* The off-diagonal of the (symmetric tri-) diagonal matrix S. */
+/* Not referenced if KBSND=0. If KBAND=1, then AE(1) is */
+/* ignored, SE(2) is the (1,2) and (2,1) element, etc. */
+
+/* U (input) REAL array, dimension (LDU, N) */
+/* The orthogonal matrix in the decomposition. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N. */
+
+/* WORK (workspace) REAL array, dimension (LDWORK, M+1) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of WORK. LDWORK must be at least */
+/* max(1,M). */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ad;
+ --ae;
+ --sd;
+ --se;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.f;
+ result[2] = 0.f;
+ if (*n <= 0 || *m <= 0) {
+ return 0;
+ }
+
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon");
+
+/* Do Test 1 */
+
+/* Compute the 1-norm of A. */
+
+ if (*n > 1) {
+ anorm = dabs(ad[1]) + dabs(ae[1]);
+ i__1 = *n - 1;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MAX */
+ r__4 = anorm, r__5 = (r__1 = ad[j], dabs(r__1)) + (r__2 = ae[j],
+ dabs(r__2)) + (r__3 = ae[j - 1], dabs(r__3));
+ anorm = dmax(r__4,r__5);
+/* L10: */
+ }
+/* Computing MAX */
+ r__3 = anorm, r__4 = (r__1 = ad[*n], dabs(r__1)) + (r__2 = ae[*n - 1],
+ dabs(r__2));
+ anorm = dmax(r__3,r__4);
+ } else {
+ anorm = dabs(ad[1]);
+ }
+ anorm = dmax(anorm,unfl);
+
+/* Norm of U'AU - S */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *m;
+ for (j = 1; j <= i__2; ++j) {
+ work[i__ + j * work_dim1] = 0.f;
+ i__3 = *n;
+ for (k = 1; k <= i__3; ++k) {
+ aukj = ad[k] * u[k + j * u_dim1];
+ if (k != *n) {
+ aukj += ae[k] * u[k + 1 + j * u_dim1];
+ }
+ if (k != 1) {
+ aukj += ae[k - 1] * u[k - 1 + j * u_dim1];
+ }
+ work[i__ + j * work_dim1] += u[k + i__ * u_dim1] * aukj;
+/* L20: */
+ }
+/* L30: */
+ }
+ work[i__ + i__ * work_dim1] -= sd[i__];
+ if (*kband == 1) {
+ if (i__ != 1) {
+ work[i__ + (i__ - 1) * work_dim1] -= se[i__ - 1];
+ }
+ if (i__ != *n) {
+ work[i__ + (i__ + 1) * work_dim1] -= se[i__];
+ }
+ }
+/* L40: */
+ }
+
+ wnorm = slansy_("1", "L", m, &work[work_offset], m, &work[(*m + 1) *
+ work_dim1 + 1]);
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*m * ulp);
+ } else {
+ if (anorm < 1.f) {
+/* Computing MIN */
+ r__1 = wnorm, r__2 = *m * anorm;
+ result[1] = dmin(r__1,r__2) / anorm / (*m * ulp);
+ } else {
+/* Computing MIN */
+ r__1 = wnorm / anorm, r__2 = (real) (*m);
+ result[1] = dmin(r__1,r__2) / (*m * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute U'U - I */
+
+ sgemm_("T", "N", m, m, n, &c_b12, &u[u_offset], ldu, &u[u_offset], ldu, &
+ c_b13, &work[work_offset], m);
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ work[j + j * work_dim1] += -1.f;
+/* L50: */
+ }
+
+/* Computing MIN */
+ r__1 = (real) (*m), r__2 = slange_("1", m, m, &work[work_offset], m, &
+ work[(*m + 1) * work_dim1 + 1]);
+ result[2] = dmin(r__1,r__2) / (*m * ulp);
+
+ return 0;
+
+/* End of SSTT22 */
+
+} /* sstt22_ */
diff --git a/TESTING/EIG/ssvdch.c b/TESTING/EIG/ssvdch.c
new file mode 100644
index 0000000..3d29415
--- /dev/null
+++ b/TESTING/EIG/ssvdch.c
@@ -0,0 +1,191 @@
+/* ssvdch.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ssvdch_(integer *n, real *s, real *e, real *svd, real *
+ tol, integer *info)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ real eps;
+ integer bpnt;
+ real unfl, ovfl;
+ integer numl, numu, tpnt, count;
+ real lower, upper, tuppr;
+ extern doublereal slamch_(char *);
+ real unflep;
+ extern /* Subroutine */ int ssvdct_(integer *, real *, real *, real *,
+ integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSVDCH checks to see if SVD(1) ,..., SVD(N) are accurate singular */
+/* values of the bidiagonal matrix B with diagonal entries */
+/* S(1) ,..., S(N) and superdiagonal entries E(1) ,..., E(N-1)). */
+/* It does this by expanding each SVD(I) into an interval */
+/* [SVD(I) * (1-EPS) , SVD(I) * (1+EPS)], merging overlapping intervals */
+/* if any, and using Sturm sequences to count and verify whether each */
+/* resulting interval has the correct number of singular values (using */
+/* SSVDCT). Here EPS=TOL*MAX(N/10,1)*MACHEP, where MACHEP is the */
+/* machine precision. The routine assumes the singular values are sorted */
+/* with SVD(1) the largest and SVD(N) smallest. If each interval */
+/* contains the correct number of singular values, INFO = 0 is returned, */
+/* otherwise INFO is the index of the first singular value in the first */
+/* bad interval. */
+
+/* Arguments */
+/* ========== */
+
+/* N (input) INTEGER */
+/* The dimension of the bidiagonal matrix B. */
+
+/* S (input) REAL array, dimension (N) */
+/* The diagonal entries of the bidiagonal matrix B. */
+
+/* E (input) REAL array, dimension (N-1) */
+/* The superdiagonal entries of the bidiagonal matrix B. */
+
+/* SVD (input) REAL array, dimension (N) */
+/* The computed singular values to be checked. */
+
+/* TOL (input) REAL */
+/* Error tolerance for checking, a multiplier of the */
+/* machine precision. */
+
+/* INFO (output) INTEGER */
+/* =0 if the singular values are all correct (to within */
+/* 1 +- TOL*MACHEPS) */
+/* >0 if the interval containing the INFO-th singular value */
+/* contains the incorrect number of singular values. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Get machine constants */
+
+ /* Parameter adjustments */
+ --svd;
+ --e;
+ --s;
+
+ /* Function Body */
+ *info = 0;
+ if (*n <= 0) {
+ return 0;
+ }
+ unfl = slamch_("Safe minimum");
+ ovfl = slamch_("Overflow");
+ eps = slamch_("Epsilon") * slamch_("Base");
+
+/* UNFLEP is chosen so that when an eigenvalue is multiplied by the */
+/* scale factor sqrt(OVFL)*sqrt(sqrt(UNFL))/MX in SSVDCT, it exceeds */
+/* sqrt(UNFL), which is the lower limit for SSVDCT. */
+
+ unflep = sqrt(sqrt(unfl)) / sqrt(ovfl) * svd[1] + unfl / eps;
+
+/* The value of EPS works best when TOL .GE. 10. */
+
+/* Computing MAX */
+ i__1 = *n / 10;
+ eps = *tol * max(i__1,1) * eps;
+
+/* TPNT points to singular value at right endpoint of interval */
+/* BPNT points to singular value at left endpoint of interval */
+
+ tpnt = 1;
+ bpnt = 1;
+
+/* Begin loop over all intervals */
+
+L10:
+ upper = (eps + 1.f) * svd[tpnt] + unflep;
+ lower = (1.f - eps) * svd[bpnt] - unflep;
+ if (lower <= unflep) {
+ lower = -upper;
+ }
+
+/* Begin loop merging overlapping intervals */
+
+L20:
+ if (bpnt == *n) {
+ goto L30;
+ }
+ tuppr = (eps + 1.f) * svd[bpnt + 1] + unflep;
+ if (tuppr < lower) {
+ goto L30;
+ }
+
+/* Merge */
+
+ ++bpnt;
+ lower = (1.f - eps) * svd[bpnt] - unflep;
+ if (lower <= unflep) {
+ lower = -upper;
+ }
+ goto L20;
+L30:
+
+/* Count singular values in interval [ LOWER, UPPER ] */
+
+ ssvdct_(n, &s[1], &e[1], &lower, &numl);
+ ssvdct_(n, &s[1], &e[1], &upper, &numu);
+ count = numu - numl;
+ if (lower < 0.f) {
+ count /= 2;
+ }
+ if (count != bpnt - tpnt + 1) {
+
+/* Wrong number of singular values in interval */
+
+ *info = tpnt;
+ goto L40;
+ }
+ tpnt = bpnt + 1;
+ bpnt = tpnt;
+ if (tpnt <= *n) {
+ goto L10;
+ }
+L40:
+ return 0;
+
+/* End of SSVDCH */
+
+} /* ssvdch_ */
diff --git a/TESTING/EIG/ssvdct.c b/TESTING/EIG/ssvdct.c
new file mode 100644
index 0000000..2f12dfd
--- /dev/null
+++ b/TESTING/EIG/ssvdct.c
@@ -0,0 +1,194 @@
+/* ssvdct.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ssvdct_(integer *n, real *s, real *e, real *shift,
+ integer *num)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2, r__3, r__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real u, m1, m2, mx, tmp, tom, sun, sov, unfl, ovfl, ssun;
+ extern doublereal slamch_(char *);
+ real sshift;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSVDCT counts the number NUM of eigenvalues of a 2*N by 2*N */
+/* tridiagonal matrix T which are less than or equal to SHIFT. T is */
+/* formed by putting zeros on the diagonal and making the off-diagonals */
+/* equal to S(1), E(1), S(2), E(2), ... , E(N-1), S(N). If SHIFT is */
+/* positive, NUM is equal to N plus the number of singular values of a */
+/* bidiagonal matrix B less than or equal to SHIFT. Here B has diagonal */
+/* entries S(1), ..., S(N) and superdiagonal entries E(1), ... E(N-1). */
+/* If SHIFT is negative, NUM is equal to the number of singular values */
+/* of B greater than or equal to -SHIFT. */
+
+/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */
+/* Matrix", Report CS41, Computer Science Dept., Stanford University, */
+/* July 21, 1966 */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The dimension of the bidiagonal matrix B. */
+
+/* S (input) REAL array, dimension (N) */
+/* The diagonal entries of the bidiagonal matrix B. */
+
+/* E (input) REAL array of dimension (N-1) */
+/* The superdiagonal entries of the bidiagonal matrix B. */
+
+/* SHIFT (input) REAL */
+/* The shift, used as described under Purpose. */
+
+/* NUM (output) INTEGER */
+/* The number of eigenvalues of T less than or equal to SHIFT. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Get machine constants */
+
+ /* Parameter adjustments */
+ --e;
+ --s;
+
+ /* Function Body */
+ unfl = slamch_("Safe minimum") * 2;
+ ovfl = 1.f / unfl;
+
+/* Find largest entry */
+
+ mx = dabs(s[1]);
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__3 = mx, r__4 = (r__1 = s[i__ + 1], dabs(r__1)), r__3 = max(r__3,
+ r__4), r__4 = (r__2 = e[i__], dabs(r__2));
+ mx = dmax(r__3,r__4);
+/* L10: */
+ }
+
+ if (mx == 0.f) {
+ if (*shift < 0.f) {
+ *num = 0;
+ } else {
+ *num = *n << 1;
+ }
+ return 0;
+ }
+
+/* Compute scale factors as in Kahan's report */
+
+ sun = sqrt(unfl);
+ ssun = sqrt(sun);
+ sov = sqrt(ovfl);
+ tom = ssun * sov;
+ if (mx <= 1.f) {
+ m1 = 1.f / mx;
+ m2 = tom;
+ } else {
+ m1 = 1.f;
+ m2 = tom / mx;
+ }
+
+/* Begin counting */
+
+ u = 1.f;
+ *num = 0;
+ sshift = *shift * m1 * m2;
+ u = -sshift;
+ if (u <= sun) {
+ if (u <= 0.f) {
+ ++(*num);
+ if (u > -sun) {
+ u = -sun;
+ }
+ } else {
+ u = sun;
+ }
+ }
+ tmp = s[1] * m1 * m2;
+ u = -tmp * (tmp / u) - sshift;
+ if (u <= sun) {
+ if (u <= 0.f) {
+ ++(*num);
+ if (u > -sun) {
+ u = -sun;
+ }
+ } else {
+ u = sun;
+ }
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ tmp = e[i__] * m1 * m2;
+ u = -tmp * (tmp / u) - sshift;
+ if (u <= sun) {
+ if (u <= 0.f) {
+ ++(*num);
+ if (u > -sun) {
+ u = -sun;
+ }
+ } else {
+ u = sun;
+ }
+ }
+ tmp = s[i__ + 1] * m1 * m2;
+ u = -tmp * (tmp / u) - sshift;
+ if (u <= sun) {
+ if (u <= 0.f) {
+ ++(*num);
+ if (u > -sun) {
+ u = -sun;
+ }
+ } else {
+ u = sun;
+ }
+ }
+/* L20: */
+ }
+ return 0;
+
+/* End of SSVDCT */
+
+} /* ssvdct_ */
diff --git a/TESTING/EIG/ssxt1.c b/TESTING/EIG/ssxt1.c
new file mode 100644
index 0000000..480e888
--- /dev/null
+++ b/TESTING/EIG/ssxt1.c
@@ -0,0 +1,134 @@
+/* ssxt1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal ssxt1_(integer *ijob, real *d1, integer *n1, real *d2, integer *n2,
+ real *abstol, real *ulp, real *unfl)
+{
+ /* System generated locals */
+ integer i__1;
+ real ret_val, r__1, r__2, r__3, r__4;
+
+ /* Local variables */
+ integer i__, j;
+ real temp1, temp2;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSXT1 computes the difference between a set of eigenvalues. */
+/* The result is returned as the function value. */
+
+/* IJOB = 1: Computes max { min | D1(i)-D2(j) | } */
+/* i j */
+
+/* IJOB = 2: Computes max { min | D1(i)-D2(j) | / */
+/* i j */
+/* ( ABSTOL + |D1(i)|*ULP ) } */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the type of tests to be performed. (See above.) */
+
+/* D1 (input) REAL array, dimension (N1) */
+/* The first array. D1 should be in increasing order, i.e., */
+/* D1(j) <= D1(j+1). */
+
+/* N1 (input) INTEGER */
+/* The length of D1. */
+
+/* D2 (input) REAL array, dimension (N2) */
+/* The second array. D2 should be in increasing order, i.e., */
+/* D2(j) <= D2(j+1). */
+
+/* N2 (input) INTEGER */
+/* The length of D2. */
+
+/* ABSTOL (input) REAL */
+/* The absolute tolerance, used as a measure of the error. */
+
+/* ULP (input) REAL */
+/* Machine precision. */
+
+/* UNFL (input) REAL */
+/* The smallest positive number whose reciprocal does not */
+/* overflow. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --d2;
+ --d1;
+
+ /* Function Body */
+ temp1 = 0.f;
+
+ j = 1;
+ i__1 = *n1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+L10:
+ if (d2[j] < d1[i__] && j < *n2) {
+ ++j;
+ goto L10;
+ }
+ if (j == 1) {
+ temp2 = (r__1 = d2[j] - d1[i__], dabs(r__1));
+ if (*ijob == 2) {
+/* Computing MAX */
+ r__2 = *unfl, r__3 = *abstol + *ulp * (r__1 = d1[i__], dabs(
+ r__1));
+ temp2 /= dmax(r__2,r__3);
+ }
+ } else {
+/* Computing MIN */
+ r__3 = (r__1 = d2[j] - d1[i__], dabs(r__1)), r__4 = (r__2 = d1[
+ i__] - d2[j - 1], dabs(r__2));
+ temp2 = dmin(r__3,r__4);
+ if (*ijob == 2) {
+/* Computing MAX */
+ r__2 = *unfl, r__3 = *abstol + *ulp * (r__1 = d1[i__], dabs(
+ r__1));
+ temp2 /= dmax(r__2,r__3);
+ }
+ }
+ temp1 = dmax(temp1,temp2);
+/* L20: */
+ }
+
+ ret_val = temp1;
+ return ret_val;
+
+/* End of SSXT1 */
+
+} /* ssxt1_ */
diff --git a/TESTING/EIG/ssyt21.c b/TESTING/EIG/ssyt21.c
new file mode 100644
index 0000000..4870f6e
--- /dev/null
+++ b/TESTING/EIG/ssyt21.c
@@ -0,0 +1,452 @@
+/* ssyt21.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b10 = 0.f;
+static integer c__1 = 1;
+static real c_b42 = 1.f;
+
+/* Subroutine */ int ssyt21_(integer *itype, char *uplo, integer *n, integer *
+ kband, real *a, integer *lda, real *d__, real *e, real *u, integer *
+ ldu, real *v, integer *ldv, real *tau, real *work, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2,
+ i__3;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j, jr;
+ real ulp;
+ integer jcol;
+ real unfl;
+ integer jrow;
+ extern /* Subroutine */ int ssyr_(char *, integer *, real *, real *,
+ integer *, real *, integer *), ssyr2_(char *, integer *,
+ real *, real *, integer *, real *, integer *, real *, integer *);
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm;
+ char cuplo[1];
+ real vsave;
+ logical lower;
+ real wnorm;
+ extern /* Subroutine */ int sorm2l_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *), sorm2r_(char *, char *, integer *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *), slarfy_(
+ char *, integer *, real *, integer *, real *, real *, integer *,
+ real *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYT21 generally checks a decomposition of the form */
+
+/* A = U S U' */
+
+/* where ' means transpose, A is symmetric, U is orthogonal, and S is */
+/* diagonal (if KBAND=0) or symmetric tridiagonal (if KBAND=1). */
+
+/* If ITYPE=1, then U is represented as a dense matrix; otherwise U is */
+/* expressed as a product of Householder transformations, whose vectors */
+/* are stored in the array "V" and whose scaling constants are in "TAU". */
+/* We shall use the letter "V" to refer to the product of Householder */
+/* transformations (which should be equal to U). */
+
+/* Specifically, if ITYPE=1, then: */
+
+/* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU' | / ( n ulp ) */
+
+/* If ITYPE=2, then: */
+
+/* RESULT(1) = | A - V S V' | / ( |A| n ulp ) */
+
+/* If ITYPE=3, then: */
+
+/* RESULT(1) = | I - VU' | / ( n ulp ) */
+
+/* For ITYPE > 1, the transformation U is expressed as a product */
+/* V = H(1)...H(n-2), where H(j) = I - tau(j) v(j) v(j)' and each */
+/* vector v(j) has its first j elements 0 and the remaining n-j elements */
+/* stored in V(j+1:n,j). */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the type of tests to be performed. */
+/* 1: U expressed as a dense orthogonal matrix: */
+/* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU' | / ( n ulp ) */
+
+/* 2: U expressed as a product V of Housholder transformations: */
+/* RESULT(1) = | A - V S V' | / ( |A| n ulp ) */
+
+/* 3: U expressed both as a dense orthogonal matrix and */
+/* as a product of Housholder transformations: */
+/* RESULT(1) = | I - VU' | / ( n ulp ) */
+
+/* UPLO (input) CHARACTER */
+/* If UPLO='U', the upper triangle of A and V will be used and */
+/* the (strictly) lower triangle will not be referenced. */
+/* If UPLO='L', the lower triangle of A and V will be used and */
+/* the (strictly) upper triangle will not be referenced. */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, SSYT21 does nothing. */
+/* It must be at least zero. */
+
+/* KBAND (input) INTEGER */
+/* The bandwidth of the matrix. It may only be zero or one. */
+/* If zero, then S is diagonal, and E is not referenced. If */
+/* one, then S is symmetric tri-diagonal. */
+
+/* A (input) REAL array, dimension (LDA, N) */
+/* The original (unfactored) matrix. It is assumed to be */
+/* symmetric, and only the upper (UPLO='U') or only the lower */
+/* (UPLO='L') will be referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least N. */
+
+/* D (input) REAL array, dimension (N) */
+/* The diagonal of the (symmetric tri-) diagonal matrix. */
+
+/* E (input) REAL array, dimension (N-1) */
+/* The off-diagonal of the (symmetric tri-) diagonal matrix. */
+/* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and */
+/* (3,2) element, etc. */
+/* Not referenced if KBAND=0. */
+
+/* U (input) REAL array, dimension (LDU, N) */
+/* If ITYPE=1 or 3, this contains the orthogonal matrix in */
+/* the decomposition, expressed as a dense matrix. If ITYPE=2, */
+/* then it is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+
+/* V (input) REAL array, dimension (LDV, N) */
+/* If ITYPE=2 or 3, the columns of this array contain the */
+/* Householder vectors used to describe the orthogonal matrix */
+/* in the decomposition. If UPLO='L', then the vectors are in */
+/* the lower triangle, if UPLO='U', then in the upper */
+/* triangle. */
+/* *NOTE* If ITYPE=2 or 3, V is modified and restored. The */
+/* subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U') */
+/* is set to one, and later reset to its original value, during */
+/* the course of the calculation. */
+/* If ITYPE=1, then it is neither referenced nor modified. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of V. LDV must be at least N and */
+/* at least 1. */
+
+/* TAU (input) REAL array, dimension (N) */
+/* If ITYPE >= 2, then TAU(j) is the scalar factor of */
+/* v(j) v(j)' in the Householder transformation H(j) of */
+/* the product U = H(1)...H(n-2) */
+/* If ITYPE < 2, then TAU is not referenced. */
+
+/* WORK (workspace) REAL array, dimension (2*N**2) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+/* RESULT(1) is always modified. RESULT(2) is modified only */
+/* if ITYPE=1. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --tau;
+ --work;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.f;
+ if (*itype == 1) {
+ result[2] = 0.f;
+ }
+ if (*n <= 0) {
+ return 0;
+ }
+
+ if (lsame_(uplo, "U")) {
+ lower = FALSE_;
+ *(unsigned char *)cuplo = 'U';
+ } else {
+ lower = TRUE_;
+ *(unsigned char *)cuplo = 'L';
+ }
+
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon") * slamch_("Base");
+
+/* Some Error Checks */
+
+ if (*itype < 1 || *itype > 3) {
+ result[1] = 10.f / ulp;
+ return 0;
+ }
+
+/* Do Test 1 */
+
+/* Norm of A: */
+
+ if (*itype == 3) {
+ anorm = 1.f;
+ } else {
+/* Computing MAX */
+ r__1 = slansy_("1", cuplo, n, &a[a_offset], lda, &work[1]);
+ anorm = dmax(r__1,unfl);
+ }
+
+/* Compute error matrix: */
+
+ if (*itype == 1) {
+
+/* ITYPE=1: error = A - U S U' */
+
+ slaset_("Full", n, n, &c_b10, &c_b10, &work[1], n);
+ slacpy_(cuplo, n, n, &a[a_offset], lda, &work[1], n);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ r__1 = -d__[j];
+ ssyr_(cuplo, n, &r__1, &u[j * u_dim1 + 1], &c__1, &work[1], n);
+/* L10: */
+ }
+
+ if (*n > 1 && *kband == 1) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ r__1 = -e[j];
+ ssyr2_(cuplo, n, &r__1, &u[j * u_dim1 + 1], &c__1, &u[(j + 1)
+ * u_dim1 + 1], &c__1, &work[1], n);
+/* L20: */
+ }
+ }
+/* Computing 2nd power */
+ i__1 = *n;
+ wnorm = slansy_("1", cuplo, n, &work[1], n, &work[i__1 * i__1 + 1]);
+
+ } else if (*itype == 2) {
+
+/* ITYPE=2: error = V S V' - A */
+
+ slaset_("Full", n, n, &c_b10, &c_b10, &work[1], n);
+
+ if (lower) {
+/* Computing 2nd power */
+ i__1 = *n;
+ work[i__1 * i__1] = d__[*n];
+ for (j = *n - 1; j >= 1; --j) {
+ if (*kband == 1) {
+ work[(*n + 1) * (j - 1) + 2] = (1.f - tau[j]) * e[j];
+ i__1 = *n;
+ for (jr = j + 2; jr <= i__1; ++jr) {
+ work[(j - 1) * *n + jr] = -tau[j] * e[j] * v[jr + j *
+ v_dim1];
+/* L30: */
+ }
+ }
+
+ vsave = v[j + 1 + j * v_dim1];
+ v[j + 1 + j * v_dim1] = 1.f;
+ i__1 = *n - j;
+/* Computing 2nd power */
+ i__2 = *n;
+ slarfy_("L", &i__1, &v[j + 1 + j * v_dim1], &c__1, &tau[j], &
+ work[(*n + 1) * j + 1], n, &work[i__2 * i__2 + 1]);
+ v[j + 1 + j * v_dim1] = vsave;
+ work[(*n + 1) * (j - 1) + 1] = d__[j];
+/* L40: */
+ }
+ } else {
+ work[1] = d__[1];
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ if (*kband == 1) {
+ work[(*n + 1) * j] = (1.f - tau[j]) * e[j];
+ i__2 = j - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ work[j * *n + jr] = -tau[j] * e[j] * v[jr + (j + 1) *
+ v_dim1];
+/* L50: */
+ }
+ }
+
+ vsave = v[j + (j + 1) * v_dim1];
+ v[j + (j + 1) * v_dim1] = 1.f;
+/* Computing 2nd power */
+ i__2 = *n;
+ slarfy_("U", &j, &v[(j + 1) * v_dim1 + 1], &c__1, &tau[j], &
+ work[1], n, &work[i__2 * i__2 + 1]);
+ v[j + (j + 1) * v_dim1] = vsave;
+ work[(*n + 1) * j + 1] = d__[j + 1];
+/* L60: */
+ }
+ }
+
+ i__1 = *n;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ if (lower) {
+ i__2 = *n;
+ for (jrow = jcol; jrow <= i__2; ++jrow) {
+ work[jrow + *n * (jcol - 1)] -= a[jrow + jcol * a_dim1];
+/* L70: */
+ }
+ } else {
+ i__2 = jcol;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ work[jrow + *n * (jcol - 1)] -= a[jrow + jcol * a_dim1];
+/* L80: */
+ }
+ }
+/* L90: */
+ }
+/* Computing 2nd power */
+ i__1 = *n;
+ wnorm = slansy_("1", cuplo, n, &work[1], n, &work[i__1 * i__1 + 1]);
+
+ } else if (*itype == 3) {
+
+/* ITYPE=3: error = U V' - I */
+
+ if (*n < 2) {
+ return 0;
+ }
+ slacpy_(" ", n, n, &u[u_offset], ldu, &work[1], n);
+ if (lower) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+/* Computing 2nd power */
+ i__3 = *n;
+ sorm2r_("R", "T", n, &i__1, &i__2, &v[v_dim1 + 2], ldv, &tau[1], &
+ work[*n + 1], n, &work[i__3 * i__3 + 1], &iinfo);
+ } else {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+/* Computing 2nd power */
+ i__3 = *n;
+ sorm2l_("R", "T", n, &i__1, &i__2, &v[(v_dim1 << 1) + 1], ldv, &
+ tau[1], &work[1], n, &work[i__3 * i__3 + 1], &iinfo);
+ }
+ if (iinfo != 0) {
+ result[1] = 10.f / ulp;
+ return 0;
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[(*n + 1) * (j - 1) + 1] += -1.f;
+/* L100: */
+ }
+
+/* Computing 2nd power */
+ i__1 = *n;
+ wnorm = slange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]);
+ }
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.f) {
+/* Computing MIN */
+ r__1 = wnorm, r__2 = *n * anorm;
+ result[1] = dmin(r__1,r__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ r__1 = wnorm / anorm, r__2 = (real) (*n);
+ result[1] = dmin(r__1,r__2) / (*n * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute UU' - I */
+
+ if (*itype == 1) {
+ sgemm_("N", "C", n, n, n, &c_b42, &u[u_offset], ldu, &u[u_offset],
+ ldu, &c_b10, &work[1], n);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ work[(*n + 1) * (j - 1) + 1] += -1.f;
+/* L110: */
+ }
+
+/* Computing MIN */
+/* Computing 2nd power */
+ i__1 = *n;
+ r__1 = slange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]), r__2 = (real) (*n);
+ result[2] = dmin(r__1,r__2) / (*n * ulp);
+ }
+
+ return 0;
+
+/* End of SSYT21 */
+
+} /* ssyt21_ */
diff --git a/TESTING/EIG/ssyt22.c b/TESTING/EIG/ssyt22.c
new file mode 100644
index 0000000..4277e7c
--- /dev/null
+++ b/TESTING/EIG/ssyt22.c
@@ -0,0 +1,277 @@
+/* ssyt22.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b6 = 1.f;
+static real c_b7 = 0.f;
+
+/* Subroutine */ int ssyt22_(integer *itype, char *uplo, integer *n, integer *
+ m, integer *kband, real *a, integer *lda, real *d__, real *e, real *u,
+ integer *ldu, real *v, integer *ldv, real *tau, real *work, real *
+ result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j, jj, nn, jj1, jj2;
+ real ulp;
+ integer nnp1;
+ real unfl;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm;
+ extern /* Subroutine */ int sort01_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, real *);
+ real wnorm;
+ extern /* Subroutine */ int ssymm_(char *, char *, integer *, integer *,
+ real *, real *, integer *, real *, integer *, real *, real *,
+ integer *);
+ extern doublereal slamch_(char *), slansy_(char *, char *,
+ integer *, real *, integer *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYT22 generally checks a decomposition of the form */
+
+/* A U = U S */
+
+/* where A is symmetric, the columns of U are orthonormal, and S */
+/* is diagonal (if KBAND=0) or symmetric tridiagonal (if */
+/* KBAND=1). If ITYPE=1, then U is represented as a dense matrix, */
+/* otherwise the U is expressed as a product of Householder */
+/* transformations, whose vectors are stored in the array "V" and */
+/* whose scaling constants are in "TAU"; we shall use the letter */
+/* "V" to refer to the product of Householder transformations */
+/* (which should be equal to U). */
+
+/* Specifically, if ITYPE=1, then: */
+
+/* RESULT(1) = | U' A U - S | / ( |A| m ulp ) *and* */
+/* RESULT(2) = | I - U'U | / ( m ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE INTEGER */
+/* Specifies the type of tests to be performed. */
+/* 1: U expressed as a dense orthogonal matrix: */
+/* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU' | / ( n ulp ) */
+
+/* UPLO CHARACTER */
+/* If UPLO='U', the upper triangle of A will be used and the */
+/* (strictly) lower triangle will not be referenced. If */
+/* UPLO='L', the lower triangle of A will be used and the */
+/* (strictly) upper triangle will not be referenced. */
+/* Not modified. */
+
+/* N INTEGER */
+/* The size of the matrix. If it is zero, SSYT22 does nothing. */
+/* It must be at least zero. */
+/* Not modified. */
+
+/* M INTEGER */
+/* The number of columns of U. If it is zero, SSYT22 does */
+/* nothing. It must be at least zero. */
+/* Not modified. */
+
+/* KBAND INTEGER */
+/* The bandwidth of the matrix. It may only be zero or one. */
+/* If zero, then S is diagonal, and E is not referenced. If */
+/* one, then S is symmetric tri-diagonal. */
+/* Not modified. */
+
+/* A REAL array, dimension (LDA , N) */
+/* The original (unfactored) matrix. It is assumed to be */
+/* symmetric, and only the upper (UPLO='U') or only the lower */
+/* (UPLO='L') will be referenced. */
+/* Not modified. */
+
+/* LDA INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least N. */
+/* Not modified. */
+
+/* D REAL array, dimension (N) */
+/* The diagonal of the (symmetric tri-) diagonal matrix. */
+/* Not modified. */
+
+/* E REAL array, dimension (N) */
+/* The off-diagonal of the (symmetric tri-) diagonal matrix. */
+/* E(1) is ignored, E(2) is the (1,2) and (2,1) element, etc. */
+/* Not referenced if KBAND=0. */
+/* Not modified. */
+
+/* U REAL array, dimension (LDU, N) */
+/* If ITYPE=1 or 3, this contains the orthogonal matrix in */
+/* the decomposition, expressed as a dense matrix. If ITYPE=2, */
+/* then it is not referenced. */
+/* Not modified. */
+
+/* LDU INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+/* Not modified. */
+
+/* V REAL array, dimension (LDV, N) */
+/* If ITYPE=2 or 3, the lower triangle of this array contains */
+/* the Householder vectors used to describe the orthogonal */
+/* matrix in the decomposition. If ITYPE=1, then it is not */
+/* referenced. */
+/* Not modified. */
+
+/* LDV INTEGER */
+/* The leading dimension of V. LDV must be at least N and */
+/* at least 1. */
+/* Not modified. */
+
+/* TAU REAL array, dimension (N) */
+/* If ITYPE >= 2, then TAU(j) is the scalar factor of */
+/* v(j) v(j)' in the Householder transformation H(j) of */
+/* the product U = H(1)...H(n-2) */
+/* If ITYPE < 2, then TAU is not referenced. */
+/* Not modified. */
+
+/* WORK REAL array, dimension (2*N**2) */
+/* Workspace. */
+/* Modified. */
+
+/* RESULT REAL array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+/* RESULT(1) is always modified. RESULT(2) is modified only */
+/* if LDU is at least N. */
+/* Modified. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --tau;
+ --work;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.f;
+ result[2] = 0.f;
+ if (*n <= 0 || *m <= 0) {
+ return 0;
+ }
+
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Precision");
+
+/* Do Test 1 */
+
+/* Norm of A: */
+
+/* Computing MAX */
+ r__1 = slansy_("1", uplo, n, &a[a_offset], lda, &work[1]);
+ anorm = dmax(r__1,unfl);
+
+/* Compute error matrix: */
+
+/* ITYPE=1: error = U' A U - S */
+
+ ssymm_("L", uplo, n, m, &c_b6, &a[a_offset], lda, &u[u_offset], ldu, &
+ c_b7, &work[1], n);
+ nn = *n * *n;
+ nnp1 = nn + 1;
+ sgemm_("T", "N", m, m, n, &c_b6, &u[u_offset], ldu, &work[1], n, &c_b7, &
+ work[nnp1], n);
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ jj = nn + (j - 1) * *n + j;
+ work[jj] -= d__[j];
+/* L10: */
+ }
+ if (*kband == 1 && *n > 1) {
+ i__1 = *m;
+ for (j = 2; j <= i__1; ++j) {
+ jj1 = nn + (j - 1) * *n + j - 1;
+ jj2 = nn + (j - 2) * *n + j;
+ work[jj1] -= e[j - 1];
+ work[jj2] -= e[j - 1];
+/* L20: */
+ }
+ }
+ wnorm = slansy_("1", uplo, m, &work[nnp1], n, &work[1]);
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*m * ulp);
+ } else {
+ if (anorm < 1.f) {
+/* Computing MIN */
+ r__1 = wnorm, r__2 = *m * anorm;
+ result[1] = dmin(r__1,r__2) / anorm / (*m * ulp);
+ } else {
+/* Computing MIN */
+ r__1 = wnorm / anorm, r__2 = (real) (*m);
+ result[1] = dmin(r__1,r__2) / (*m * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute U'U - I */
+
+ if (*itype == 1) {
+ i__1 = (*n << 1) * *n;
+ sort01_("Columns", n, m, &u[u_offset], ldu, &work[1], &i__1, &result[
+ 2]);
+ }
+
+ return 0;
+
+/* End of SSYT22 */
+
+} /* ssyt22_ */
diff --git a/TESTING/EIG/xerbla.c b/TESTING/EIG/xerbla.c
new file mode 100644
index 0000000..fc3f4cc
--- /dev/null
+++ b/TESTING/EIG/xerbla.c
@@ -0,0 +1,142 @@
+/* xerbla.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+#include "string.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int xerbla_(char *srname, integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 *** XERBLA was called from \002,a,\002 w"
+ "ith INFO = \002,i6,\002 instead of \002,i2,\002 ***\002)";
+ static char fmt_9997[] = "(\002 *** On entry to \002,a,\002 parameter nu"
+ "mber \002,i6,\002 had an illegal value ***\002)";
+ static char fmt_9998[] = "(\002 *** XERBLA was called with SRNAME = \002"
+ ",a,\002 instead of \002,a6,\002 ***\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), i_len_trim(char *, ftnlen), do_fio(integer *,
+ char *, ftnlen), e_wsfe(void), s_cmp(char *, char *, ftnlen,
+ ftnlen);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___2 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___3 = { 0, 0, 0, fmt_9998, 0 };
+
+ int srname_len;
+
+ srname_len = strlen(srname);
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This is a special version of XERBLA to be used only as part of */
+/* the test program for testing error exits from the LAPACK routines. */
+/* Error messages are printed if INFO.NE.INFOT or if SRNAME.NE.SRNAMT, */
+/* where INFOT and SRNAMT are values stored in COMMON. */
+
+/* Arguments */
+/* ========= */
+
+/* SRNAME (input) CHARACTER*(*) */
+/* The name of the subroutine calling XERBLA. This name should */
+/* match the COMMON variable SRNAMT. */
+
+/* INFO (input) INTEGER */
+/* The error return code from the calling subroutine. INFO */
+/* should equal the COMMON variable INFOT. */
+
+/* Further Details */
+/* ======= ======= */
+
+/* The following variables are passed via the common blocks INFOC and */
+/* SRNAMC: */
+
+/* INFOT INTEGER Expected integer return code */
+/* NOUT INTEGER Unit number for printing error messages */
+/* OK LOGICAL Set to .TRUE. if INFO = INFOT and */
+/* SRNAME = SRNAMT, otherwise set to .FALSE. */
+/* LERR LOGICAL Set to .TRUE., indicating that XERBLA was called */
+/* SRNAMT CHARACTER*(*) Expected name of calling subroutine */
+
+
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.lerr = TRUE_;
+ if (*info != infoc_1.infot) {
+ if (infoc_1.infot != 0) {
+ io___1.ciunit = infoc_1.nout;
+ s_wsfe(&io___1);
+ do_fio(&c__1, srnamc_1.srnamt, i_len_trim(srnamc_1.srnamt, (
+ ftnlen)32));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&infoc_1.infot, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___2.ciunit = infoc_1.nout;
+ s_wsfe(&io___2);
+ do_fio(&c__1, srname, i_len_trim(srname, srname_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ infoc_1.ok = FALSE_;
+ }
+ if (s_cmp(srname, srnamc_1.srnamt, srname_len, (ftnlen)32) != 0) {
+ io___3.ciunit = infoc_1.nout;
+ s_wsfe(&io___3);
+ do_fio(&c__1, srname, i_len_trim(srname, srname_len));
+ do_fio(&c__1, srnamc_1.srnamt, i_len_trim(srnamc_1.srnamt, (ftnlen)32)
+ );
+ e_wsfe();
+ infoc_1.ok = FALSE_;
+ }
+ return 0;
+
+
+/* End of XERBLA */
+
+} /* xerbla_ */
diff --git a/TESTING/EIG/xlaenv.c b/TESTING/EIG/xlaenv.c
new file mode 100644
index 0000000..79fe8ff
--- /dev/null
+++ b/TESTING/EIG/xlaenv.c
@@ -0,0 +1,94 @@
+/* xlaenv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer iparms[100];
+} claenv_;
+
+#define claenv_1 claenv_
+
+/* Subroutine */ int xlaenv_(integer *ispec, integer *nvalue)
+{
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* XLAENV sets certain machine- and problem-dependent quantities */
+/* which will later be retrieved by ILAENV. */
+
+/* Arguments */
+/* ========= */
+
+/* ISPEC (input) INTEGER */
+/* Specifies the parameter to be set in the COMMON array IPARMS. */
+/* = 1: the optimal blocksize; if this value is 1, an unblocked */
+/* algorithm will give the best performance. */
+/* = 2: the minimum block size for which the block routine */
+/* should be used; if the usable block size is less than */
+/* this value, an unblocked routine should be used. */
+/* = 3: the crossover point (in a block routine, for N less */
+/* than this value, an unblocked routine should be used) */
+/* = 4: the number of shifts, used in the nonsymmetric */
+/* eigenvalue routines */
+/* = 5: the minimum column dimension for blocking to be used; */
+/* rectangular blocks must have dimension at least k by m, */
+/* where k is given by ILAENV(2,...) and m by ILAENV(5,...) */
+/* = 6: the crossover point for the SVD (when reducing an m by n */
+/* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds */
+/* this value, a QR factorization is used first to reduce */
+/* the matrix to a triangular form) */
+/* = 7: the number of processors */
+/* = 8: another crossover point, for the multishift QR and QZ */
+/* methods for nonsymmetric eigenvalue problems. */
+/* = 9: maximum size of the subproblems at the bottom of the */
+/* computation tree in the divide-and-conquer algorithm */
+/* (used by xGELSD and xGESDD) */
+/* =10: ieee NaN arithmetic can be trusted not to trap */
+/* =11: infinity arithmetic can be trusted not to trap */
+/* 12 <= ISPEC <= 16: */
+/* xHSEQR or one of its subroutines, */
+/* see IPARMQ for detailed explanation */
+
+/* NVALUE (input) INTEGER */
+/* The value of the parameter specified by ISPEC. */
+
+/* ===================================================================== */
+
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (*ispec >= 1 && *ispec <= 16) {
+ claenv_1.iparms[*ispec - 1] = *nvalue;
+ }
+
+ return 0;
+
+/* End of XLAENV */
+
+} /* xlaenv_ */
diff --git a/TESTING/EIG/zbdt01.c b/TESTING/EIG/zbdt01.c
new file mode 100644
index 0000000..b7a4c22
--- /dev/null
+++ b/TESTING/EIG/zbdt01.c
@@ -0,0 +1,344 @@
+/* zbdt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublecomplex c_b7 = {-1.,-0.};
+static doublecomplex c_b10 = {1.,0.};
+
+/* Subroutine */ int zbdt01_(integer *m, integer *n, integer *kd,
+ doublecomplex *a, integer *lda, doublecomplex *q, integer *ldq,
+ doublereal *d__, doublereal *e, doublecomplex *pt, integer *ldpt,
+ doublecomplex *work, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, pt_dim1, pt_offset, q_dim1, q_offset, i__1,
+ i__2, i__3, i__4, i__5, i__6, i__7;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal eps, anorm;
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *),
+ dzasum_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZBDT01 reconstructs a general matrix A from its bidiagonal form */
+/* A = Q * B * P' */
+/* where Q (m by min(m,n)) and P' (min(m,n) by n) are unitary */
+/* matrices and B is bidiagonal. */
+
+/* The test ratio to test the reduction is */
+/* RESID = norm( A - Q * B * PT ) / ( n * norm(A) * EPS ) */
+/* where PT = P' and EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices A and Q. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and P'. */
+
+/* KD (input) INTEGER */
+/* If KD = 0, B is diagonal and the array E is not referenced. */
+/* If KD = 1, the reduction was performed by xGEBRD; B is upper */
+/* bidiagonal if M >= N, and lower bidiagonal if M < N. */
+/* If KD = -1, the reduction was performed by xGBBRD; B is */
+/* always upper bidiagonal. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* Q (input) COMPLEX*16 array, dimension (LDQ,N) */
+/* The m by min(m,n) unitary matrix Q in the reduction */
+/* A = Q * B * P'. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,M). */
+
+/* D (input) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The diagonal elements of the bidiagonal matrix B. */
+
+/* E (input) DOUBLE PRECISION array, dimension (min(M,N)-1) */
+/* The superdiagonal elements of the bidiagonal matrix B if */
+/* m >= n, or the subdiagonal elements of B if m < n. */
+
+/* PT (input) COMPLEX*16 array, dimension (LDPT,N) */
+/* The min(m,n) by n unitary matrix P' in the reduction */
+/* A = Q * B * P'. */
+
+/* LDPT (input) INTEGER */
+/* The leading dimension of the array PT. */
+/* LDPT >= max(1,min(M,N)). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (M+N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The test ratio: norm(A - Q * B * P') / ( n * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --d__;
+ --e;
+ pt_dim1 = *ldpt;
+ pt_offset = 1 + pt_dim1;
+ pt -= pt_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Compute A - Q * B * P' one column at a time. */
+
+ *resid = 0.;
+ if (*kd != 0) {
+
+/* B is bidiagonal. */
+
+ if (*kd != 0 && *m >= *n) {
+
+/* B is upper bidiagonal and M >= N. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__2 = *n - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = *m + i__;
+ i__4 = i__;
+ i__5 = i__ + j * pt_dim1;
+ z__2.r = d__[i__4] * pt[i__5].r, z__2.i = d__[i__4] * pt[
+ i__5].i;
+ i__6 = i__;
+ i__7 = i__ + 1 + j * pt_dim1;
+ z__3.r = e[i__6] * pt[i__7].r, z__3.i = e[i__6] * pt[i__7]
+ .i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L10: */
+ }
+ i__2 = *m + *n;
+ i__3 = *n;
+ i__4 = *n + j * pt_dim1;
+ z__1.r = d__[i__3] * pt[i__4].r, z__1.i = d__[i__3] * pt[i__4]
+ .i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ zgemv_("No transpose", m, n, &c_b7, &q[q_offset], ldq, &work[*
+ m + 1], &c__1, &c_b10, &work[1], &c__1);
+/* Computing MAX */
+ d__1 = *resid, d__2 = dzasum_(m, &work[1], &c__1);
+ *resid = max(d__1,d__2);
+/* L20: */
+ }
+ } else if (*kd < 0) {
+
+/* B is upper bidiagonal and M < N. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__2 = *m - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = *m + i__;
+ i__4 = i__;
+ i__5 = i__ + j * pt_dim1;
+ z__2.r = d__[i__4] * pt[i__5].r, z__2.i = d__[i__4] * pt[
+ i__5].i;
+ i__6 = i__;
+ i__7 = i__ + 1 + j * pt_dim1;
+ z__3.r = e[i__6] * pt[i__7].r, z__3.i = e[i__6] * pt[i__7]
+ .i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L30: */
+ }
+ i__2 = *m + *m;
+ i__3 = *m;
+ i__4 = *m + j * pt_dim1;
+ z__1.r = d__[i__3] * pt[i__4].r, z__1.i = d__[i__3] * pt[i__4]
+ .i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ zgemv_("No transpose", m, m, &c_b7, &q[q_offset], ldq, &work[*
+ m + 1], &c__1, &c_b10, &work[1], &c__1);
+/* Computing MAX */
+ d__1 = *resid, d__2 = dzasum_(m, &work[1], &c__1);
+ *resid = max(d__1,d__2);
+/* L40: */
+ }
+ } else {
+
+/* B is lower bidiagonal. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__2 = *m + 1;
+ i__3 = j * pt_dim1 + 1;
+ z__1.r = d__[1] * pt[i__3].r, z__1.i = d__[1] * pt[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ i__2 = *m;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = *m + i__;
+ i__4 = i__ - 1;
+ i__5 = i__ - 1 + j * pt_dim1;
+ z__2.r = e[i__4] * pt[i__5].r, z__2.i = e[i__4] * pt[i__5]
+ .i;
+ i__6 = i__;
+ i__7 = i__ + j * pt_dim1;
+ z__3.r = d__[i__6] * pt[i__7].r, z__3.i = d__[i__6] * pt[
+ i__7].i;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L50: */
+ }
+ zgemv_("No transpose", m, m, &c_b7, &q[q_offset], ldq, &work[*
+ m + 1], &c__1, &c_b10, &work[1], &c__1);
+/* Computing MAX */
+ d__1 = *resid, d__2 = dzasum_(m, &work[1], &c__1);
+ *resid = max(d__1,d__2);
+/* L60: */
+ }
+ }
+ } else {
+
+/* B is diagonal. */
+
+ if (*m >= *n) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = *m + i__;
+ i__4 = i__;
+ i__5 = i__ + j * pt_dim1;
+ z__1.r = d__[i__4] * pt[i__5].r, z__1.i = d__[i__4] * pt[
+ i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L70: */
+ }
+ zgemv_("No transpose", m, n, &c_b7, &q[q_offset], ldq, &work[*
+ m + 1], &c__1, &c_b10, &work[1], &c__1);
+/* Computing MAX */
+ d__1 = *resid, d__2 = dzasum_(m, &work[1], &c__1);
+ *resid = max(d__1,d__2);
+/* L80: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = *m + i__;
+ i__4 = i__;
+ i__5 = i__ + j * pt_dim1;
+ z__1.r = d__[i__4] * pt[i__5].r, z__1.i = d__[i__4] * pt[
+ i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L90: */
+ }
+ zgemv_("No transpose", m, m, &c_b7, &q[q_offset], ldq, &work[*
+ m + 1], &c__1, &c_b10, &work[1], &c__1);
+/* Computing MAX */
+ d__1 = *resid, d__2 = dzasum_(m, &work[1], &c__1);
+ *resid = max(d__1,d__2);
+/* L100: */
+ }
+ }
+ }
+
+/* Compute norm(A - Q * B * P') / ( n * norm(A) * EPS ) */
+
+ anorm = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ eps = dlamch_("Precision");
+
+ if (anorm <= 0.) {
+ if (*resid != 0.) {
+ *resid = 1. / eps;
+ }
+ } else {
+ if (anorm >= *resid) {
+ *resid = *resid / anorm / ((doublereal) (*n) * eps);
+ } else {
+ if (anorm < 1.) {
+/* Computing MIN */
+ d__1 = *resid, d__2 = (doublereal) (*n) * anorm;
+ *resid = min(d__1,d__2) / anorm / ((doublereal) (*n) * eps);
+ } else {
+/* Computing MIN */
+ d__1 = *resid / anorm, d__2 = (doublereal) (*n);
+ *resid = min(d__1,d__2) / ((doublereal) (*n) * eps);
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZBDT01 */
+
+} /* zbdt01_ */
diff --git a/TESTING/EIG/zbdt02.c b/TESTING/EIG/zbdt02.c
new file mode 100644
index 0000000..21362c7
--- /dev/null
+++ b/TESTING/EIG/zbdt02.c
@@ -0,0 +1,177 @@
+/* zbdt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublecomplex c_b7 = {-1.,-0.};
+static doublecomplex c_b10 = {1.,0.};
+
+/* Subroutine */ int zbdt02_(integer *m, integer *n, doublecomplex *b,
+ integer *ldb, doublecomplex *c__, integer *ldc, doublecomplex *u,
+ integer *ldu, doublecomplex *work, doublereal *rwork, doublereal *
+ resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, c_dim1, c_offset, u_dim1, u_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ doublereal eps, bnorm;
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *);
+ extern doublereal dlamch_(char *);
+ doublereal realmn;
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *), dzasum_(integer *,
+ doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZBDT02 tests the change of basis C = U' * B by computing the residual */
+
+/* RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ), */
+
+/* where B and C are M by N matrices, U is an M by M orthogonal matrix, */
+/* and EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices B and C and the order of */
+/* the matrix Q. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices B and C. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,N) */
+/* The m by n matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M). */
+
+/* C (input) COMPLEX*16 array, dimension (LDC,N) */
+/* The m by n matrix C, assumed to contain U' * B. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,M). */
+
+/* U (input) COMPLEX*16 array, dimension (LDU,M) */
+/* The m by m orthogonal matrix U. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (M) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ), */
+
+/* ====================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *resid = 0.;
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+ realmn = (doublereal) max(*m,*n);
+ eps = dlamch_("Precision");
+
+/* Compute norm( B - U * C ) */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(m, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ zgemv_("No transpose", m, m, &c_b7, &u[u_offset], ldu, &c__[j *
+ c_dim1 + 1], &c__1, &c_b10, &work[1], &c__1);
+/* Computing MAX */
+ d__1 = *resid, d__2 = dzasum_(m, &work[1], &c__1);
+ *resid = max(d__1,d__2);
+/* L10: */
+ }
+
+/* Compute norm of B. */
+
+ bnorm = zlange_("1", m, n, &b[b_offset], ldb, &rwork[1]);
+
+ if (bnorm <= 0.) {
+ if (*resid != 0.) {
+ *resid = 1. / eps;
+ }
+ } else {
+ if (bnorm >= *resid) {
+ *resid = *resid / bnorm / (realmn * eps);
+ } else {
+ if (bnorm < 1.) {
+/* Computing MIN */
+ d__1 = *resid, d__2 = realmn * bnorm;
+ *resid = min(d__1,d__2) / bnorm / (realmn * eps);
+ } else {
+/* Computing MIN */
+ d__1 = *resid / bnorm;
+ *resid = min(d__1,realmn) / (realmn * eps);
+ }
+ }
+ }
+ return 0;
+
+/* End of ZBDT02 */
+
+} /* zbdt02_ */
diff --git a/TESTING/EIG/zbdt03.c b/TESTING/EIG/zbdt03.c
new file mode 100644
index 0000000..7ee3ed3
--- /dev/null
+++ b/TESTING/EIG/zbdt03.c
@@ -0,0 +1,300 @@
+/* zbdt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b6 = {-1.,-0.};
+static integer c__1 = 1;
+static doublecomplex c_b9 = {0.,0.};
+
+/* Subroutine */ int zbdt03_(char *uplo, integer *n, integer *kd, doublereal *
+ d__, doublereal *e, doublecomplex *u, integer *ldu, doublereal *s,
+ doublecomplex *vt, integer *ldvt, doublecomplex *work, doublereal *
+ resid)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2, i__3, i__4,
+ i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ doublereal bnorm;
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern doublereal dzasum_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZBDT03 reconstructs a bidiagonal matrix B from its SVD: */
+/* S = U' * B * V */
+/* where U and V are orthogonal matrices and S is diagonal. */
+
+/* The test ratio to test the singular value decomposition is */
+/* RESID = norm( B - U * S * VT ) / ( n * norm(B) * EPS ) */
+/* where VT = V' and EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix B is upper or lower bidiagonal. */
+/* = 'U': Upper bidiagonal */
+/* = 'L': Lower bidiagonal */
+
+/* N (input) INTEGER */
+/* The order of the matrix B. */
+
+/* KD (input) INTEGER */
+/* The bandwidth of the bidiagonal matrix B. If KD = 1, the */
+/* matrix B is bidiagonal, and if KD = 0, B is diagonal and E is */
+/* not referenced. If KD is greater than 1, it is assumed to be */
+/* 1, and if KD is less than 0, it is assumed to be 0. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the bidiagonal matrix B. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) superdiagonal elements of the bidiagonal matrix B */
+/* if UPLO = 'U', or the (n-1) subdiagonal elements of B if */
+/* UPLO = 'L'. */
+
+/* U (input) COMPLEX*16 array, dimension (LDU,N) */
+/* The n by n orthogonal matrix U in the reduction B = U'*A*P. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,N) */
+
+/* S (input) DOUBLE PRECISION array, dimension (N) */
+/* The singular values from the SVD of B, sorted in decreasing */
+/* order. */
+
+/* VT (input) COMPLEX*16 array, dimension (LDVT,N) */
+/* The n by n orthogonal matrix V' in the reduction */
+/* B = U * S * V'. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of the array VT. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The test ratio: norm(B - U * S * V') / ( n * norm(A) * EPS ) */
+
+/* ====================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --s;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --work;
+
+ /* Function Body */
+ *resid = 0.;
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Compute B - U * S * V' one column at a time. */
+
+ bnorm = 0.;
+ if (*kd >= 1) {
+
+/* B is bidiagonal. */
+
+ if (lsame_(uplo, "U")) {
+
+/* B is upper bidiagonal. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = *n + i__;
+ i__4 = i__;
+ i__5 = i__ + j * vt_dim1;
+ z__1.r = s[i__4] * vt[i__5].r, z__1.i = s[i__4] * vt[i__5]
+ .i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L10: */
+ }
+ zgemv_("No transpose", n, n, &c_b6, &u[u_offset], ldu, &work[*
+ n + 1], &c__1, &c_b9, &work[1], &c__1);
+ i__2 = j;
+ i__3 = j;
+ i__4 = j;
+ z__1.r = work[i__3].r + d__[i__4], z__1.i = work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ if (j > 1) {
+ i__2 = j - 1;
+ i__3 = j - 1;
+ i__4 = j - 1;
+ z__1.r = work[i__3].r + e[i__4], z__1.i = work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* Computing MAX */
+ d__3 = bnorm, d__4 = (d__1 = d__[j], abs(d__1)) + (d__2 =
+ e[j - 1], abs(d__2));
+ bnorm = max(d__3,d__4);
+ } else {
+/* Computing MAX */
+ d__2 = bnorm, d__3 = (d__1 = d__[j], abs(d__1));
+ bnorm = max(d__2,d__3);
+ }
+/* Computing MAX */
+ d__1 = *resid, d__2 = dzasum_(n, &work[1], &c__1);
+ *resid = max(d__1,d__2);
+/* L20: */
+ }
+ } else {
+
+/* B is lower bidiagonal. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = *n + i__;
+ i__4 = i__;
+ i__5 = i__ + j * vt_dim1;
+ z__1.r = s[i__4] * vt[i__5].r, z__1.i = s[i__4] * vt[i__5]
+ .i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L30: */
+ }
+ zgemv_("No transpose", n, n, &c_b6, &u[u_offset], ldu, &work[*
+ n + 1], &c__1, &c_b9, &work[1], &c__1);
+ i__2 = j;
+ i__3 = j;
+ i__4 = j;
+ z__1.r = work[i__3].r + d__[i__4], z__1.i = work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ if (j < *n) {
+ i__2 = j + 1;
+ i__3 = j + 1;
+ i__4 = j;
+ z__1.r = work[i__3].r + e[i__4], z__1.i = work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* Computing MAX */
+ d__3 = bnorm, d__4 = (d__1 = d__[j], abs(d__1)) + (d__2 =
+ e[j], abs(d__2));
+ bnorm = max(d__3,d__4);
+ } else {
+/* Computing MAX */
+ d__2 = bnorm, d__3 = (d__1 = d__[j], abs(d__1));
+ bnorm = max(d__2,d__3);
+ }
+/* Computing MAX */
+ d__1 = *resid, d__2 = dzasum_(n, &work[1], &c__1);
+ *resid = max(d__1,d__2);
+/* L40: */
+ }
+ }
+ } else {
+
+/* B is diagonal. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = *n + i__;
+ i__4 = i__;
+ i__5 = i__ + j * vt_dim1;
+ z__1.r = s[i__4] * vt[i__5].r, z__1.i = s[i__4] * vt[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L50: */
+ }
+ zgemv_("No transpose", n, n, &c_b6, &u[u_offset], ldu, &work[*n +
+ 1], &c__1, &c_b9, &work[1], &c__1);
+ i__2 = j;
+ i__3 = j;
+ i__4 = j;
+ z__1.r = work[i__3].r + d__[i__4], z__1.i = work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* Computing MAX */
+ d__1 = *resid, d__2 = dzasum_(n, &work[1], &c__1);
+ *resid = max(d__1,d__2);
+/* L60: */
+ }
+ j = idamax_(n, &d__[1], &c__1);
+ bnorm = (d__1 = d__[j], abs(d__1));
+ }
+
+/* Compute norm(B - U * S * V') / ( n * norm(B) * EPS ) */
+
+ eps = dlamch_("Precision");
+
+ if (bnorm <= 0.) {
+ if (*resid != 0.) {
+ *resid = 1. / eps;
+ }
+ } else {
+ if (bnorm >= *resid) {
+ *resid = *resid / bnorm / ((doublereal) (*n) * eps);
+ } else {
+ if (bnorm < 1.) {
+/* Computing MIN */
+ d__1 = *resid, d__2 = (doublereal) (*n) * bnorm;
+ *resid = min(d__1,d__2) / bnorm / ((doublereal) (*n) * eps);
+ } else {
+/* Computing MIN */
+ d__1 = *resid / bnorm, d__2 = (doublereal) (*n);
+ *resid = min(d__1,d__2) / ((doublereal) (*n) * eps);
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZBDT03 */
+
+} /* zbdt03_ */
diff --git a/TESTING/EIG/zchkbb.c b/TESTING/EIG/zchkbb.c
new file mode 100644
index 0000000..5b599bf
--- /dev/null
+++ b/TESTING/EIG/zchkbb.c
@@ -0,0 +1,782 @@
+/* zchkbb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__0 = 0;
+static integer c__6 = 6;
+static doublereal c_b33 = 1.;
+static integer c__1 = 1;
+static doublereal c_b41 = 0.;
+static integer c__4 = 4;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zchkbb_(integer *nsizes, integer *mval, integer *nval,
+ integer *nwdths, integer *kk, integer *ntypes, logical *dotype,
+ integer *nrhs, integer *iseed, doublereal *thresh, integer *nounit,
+ doublecomplex *a, integer *lda, doublecomplex *ab, integer *ldab,
+ doublereal *bd, doublereal *be, doublecomplex *q, integer *ldq,
+ doublecomplex *p, integer *ldp, doublecomplex *c__, integer *ldc,
+ doublecomplex *cc, doublecomplex *work, integer *lwork, doublereal *
+ rwork, doublereal *result, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[15] = { 1,2,4,4,4,4,4,6,6,6,6,6,9,9,9 };
+ static integer kmagn[15] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3 };
+ static integer kmode[15] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ZCHKBB: \002,a,\002 returned INFO=\002,i"
+ "5,\002.\002,/9x,\002M=\002,i5,\002 N=\002,i5,\002 K=\002,i5,\002"
+ ", JTYPE=\002,i5,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 M =\002,i4,\002 N=\002,i4,\002, K=\002,i"
+ "3,\002, seed=\002,4(i4,\002,\002),\002 type \002,i2,\002, test"
+ "(\002,i2,\002)=\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, ab_dim1, ab_offset, c_dim1, c_offset, cc_dim1,
+ cc_offset, p_dim1, p_offset, q_dim1, q_offset, i__1, i__2, i__3,
+ i__4, i__5, i__6, i__7, i__8, i__9;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, m, n, kl, jr, ku;
+ doublereal ulp, cond;
+ integer jcol, kmax, mmax, nmax;
+ doublereal unfl, ovfl;
+ logical badmm, badnn;
+ integer imode, iinfo;
+ extern /* Subroutine */ int zbdt01_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, doublereal *, doublereal *), zbdt02_(integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublereal *,
+ doublereal *);
+ doublereal anorm;
+ integer mnmin, mnmax, nmats, jsize, nerrs, itype, jtype, ntest;
+ extern /* Subroutine */ int dlahd2_(integer *, char *), zunt01_(
+ char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *);
+ logical badnnb;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zgbbrd_(char *, integer *, integer *, integer
+ *, integer *, integer *, doublecomplex *, integer *, doublereal *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *, integer *);
+ integer idumma[1];
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int dlasum_(char *, integer *, integer *, integer
+ *);
+ doublereal amninv;
+ integer jwidth;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *), zlatmr_(
+ integer *, integer *, char *, integer *, char *, doublecomplex *,
+ integer *, doublereal *, doublecomplex *, char *, char *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ integer *, doublereal *, char *, integer *, integer *, integer *,
+ doublereal *, doublereal *, char *, doublecomplex *, integer *,
+ integer *, integer *);
+ doublereal rtunfl, rtovfl, ulpinv;
+ extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (new routine for release 2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKBB tests the reduction of a general complex rectangular band */
+/* matrix to real bidiagonal form. */
+
+/* ZGBBRD factors a general band matrix A as Q B P* , where * means */
+/* conjugate transpose, B is upper bidiagonal, and Q and P are unitary; */
+/* ZGBBRD can also overwrite a given matrix C with Q* C . */
+
+/* For each pair of matrix dimensions (M,N) and each selected matrix */
+/* type, an M by N matrix A and an M by NRHS matrix C are generated. */
+/* The problem dimensions are as follows */
+/* A: M x N */
+/* Q: M x M */
+/* P: N x N */
+/* B: min(M,N) x min(M,N) */
+/* C: M x NRHS */
+
+/* For each generated matrix, 4 tests are performed: */
+
+/* (1) | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P' */
+
+/* (2) | I - Q' Q | / ( M ulp ) */
+
+/* (3) | I - PT PT' | / ( N ulp ) */
+
+/* (4) | Y - Q' C | / ( |Y| max(M,NRHS) ulp ), where Y = Q' C. */
+
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* The possible matrix types are */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (6) Same as (3), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (3), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) Rectangular matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of values of M and N contained in the vectors */
+/* MVAL and NVAL. The matrix sizes are used in pairs (M,N). */
+/* If NSIZES is zero, ZCHKBB does nothing. NSIZES must be at */
+/* least zero. */
+
+/* MVAL (input) INTEGER array, dimension (NSIZES) */
+/* The values of the matrix row dimension M. */
+
+/* NVAL (input) INTEGER array, dimension (NSIZES) */
+/* The values of the matrix column dimension N. */
+
+/* NWDTHS (input) INTEGER */
+/* The number of bandwidths to use. If it is zero, */
+/* ZCHKBB does nothing. It must be at least zero. */
+
+/* KK (input) INTEGER array, dimension (NWDTHS) */
+/* An array containing the bandwidths to be used for the band */
+/* matrices. The values must be at least zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, ZCHKBB */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns in the "right-hand side" matrix C. */
+/* If NRHS = 0, then the operations on the right-hand side will */
+/* not be tested. NRHS must be at least 0. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to ZCHKBB to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace) DOUBLE PRECISION array, dimension */
+/* (LDA, max(NN)) */
+/* Used to hold the matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* AB (workspace) DOUBLE PRECISION array, dimension (LDAB, max(NN)) */
+/* Used to hold A in band storage format. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of AB. It must be at least 2 (not 1!) */
+/* and at least max( KK )+1. */
+
+/* BD (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* Used to hold the diagonal of the bidiagonal matrix computed */
+/* by ZGBBRD. */
+
+/* BE (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* Used to hold the off-diagonal of the bidiagonal matrix */
+/* computed by ZGBBRD. */
+
+/* Q (workspace) COMPLEX*16 array, dimension (LDQ, max(NN)) */
+/* Used to hold the unitary matrix Q computed by ZGBBRD. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of Q. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* P (workspace) COMPLEX*16 array, dimension (LDP, max(NN)) */
+/* Used to hold the unitary matrix P computed by ZGBBRD. */
+
+/* LDP (input) INTEGER */
+/* The leading dimension of P. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* C (workspace) COMPLEX*16 array, dimension (LDC, max(NN)) */
+/* Used to hold the matrix C updated by ZGBBRD. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of U. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* CC (workspace) COMPLEX*16 array, dimension (LDC, max(NN)) */
+/* Used to hold a copy of the matrix C. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* max( LDA+1, max(NN)+1 )*max(NN). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests performed, or which can */
+/* be performed so far, for the current matrix. */
+/* NTESTT The total number of tests performed so far. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far. */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --mval;
+ --nval;
+ --kk;
+ --dotype;
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --bd;
+ --be;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ p_dim1 = *ldp;
+ p_offset = 1 + p_dim1;
+ p -= p_offset;
+ cc_dim1 = *ldc;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badmm = FALSE_;
+ badnn = FALSE_;
+ mmax = 1;
+ nmax = 1;
+ mnmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = mmax, i__3 = mval[j];
+ mmax = max(i__2,i__3);
+ if (mval[j] < 0) {
+ badmm = TRUE_;
+ }
+/* Computing MAX */
+ i__2 = nmax, i__3 = nval[j];
+ nmax = max(i__2,i__3);
+ if (nval[j] < 0) {
+ badnn = TRUE_;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__4 = mval[j], i__5 = nval[j];
+ i__2 = mnmax, i__3 = min(i__4,i__5);
+ mnmax = max(i__2,i__3);
+/* L10: */
+ }
+
+ badnnb = FALSE_;
+ kmax = 0;
+ i__1 = *nwdths;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = kmax, i__3 = kk[j];
+ kmax = max(i__2,i__3);
+ if (kk[j] < 0) {
+ badnnb = TRUE_;
+ }
+/* L20: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badmm) {
+ *info = -2;
+ } else if (badnn) {
+ *info = -3;
+ } else if (*nwdths < 0) {
+ *info = -4;
+ } else if (badnnb) {
+ *info = -5;
+ } else if (*ntypes < 0) {
+ *info = -6;
+ } else if (*nrhs < 0) {
+ *info = -8;
+ } else if (*lda < nmax) {
+ *info = -13;
+ } else if (*ldab < (kmax << 1) + 1) {
+ *info = -15;
+ } else if (*ldq < nmax) {
+ *info = -19;
+ } else if (*ldp < nmax) {
+ *info = -21;
+ } else if (*ldc < nmax) {
+ *info = -23;
+ } else if ((max(*lda,nmax) + 1) * nmax > *lwork) {
+ *info = -26;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZCHKBB", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0 || *nwdths == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ ulpinv = 1. / ulp;
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+
+/* Loop over sizes, widths, types */
+
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ m = mval[jsize];
+ n = nval[jsize];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__2 = max(1,m);
+ amninv = 1. / (doublereal) max(i__2,n);
+
+ i__2 = *nwdths;
+ for (jwidth = 1; jwidth <= i__2; ++jwidth) {
+ k = kk[jwidth];
+ if (k >= m && k >= n) {
+ goto L150;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__5 = m - 1;
+ i__3 = 0, i__4 = min(i__5,k);
+ kl = max(i__3,i__4);
+/* Computing MAX */
+/* Computing MIN */
+ i__5 = n - 1;
+ i__3 = 0, i__4 = min(i__5,k);
+ ku = max(i__3,i__4);
+
+ if (*nsizes != 1) {
+ mtypes = min(15,*ntypes);
+ } else {
+ mtypes = min(16,*ntypes);
+ }
+
+ i__3 = mtypes;
+ for (jtype = 1; jtype <= i__3; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L140;
+ }
+ ++nmats;
+ ntest = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L30: */
+ }
+
+/* Compute "A". */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, (w/ singular values) */
+/* =5 random log (none) */
+/* =6 random nonhermitian, w/ singular values */
+/* =7 (none) */
+/* =8 (none) */
+/* =9 random nonhermitian */
+
+ if (mtypes > 15) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * amninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * max(m,n) * ulpinv;
+ goto L70;
+
+L70:
+
+ zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ zlaset_("Full", ldab, &n, &c_b1, &c_b1, &ab[ab_offset], ldab);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__4 = n;
+ for (jcol = 1; jcol <= i__4; ++jcol) {
+ i__5 = jcol + jcol * a_dim1;
+ a[i__5].r = anorm, a[i__5].i = 0.;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, singular values specified */
+
+ zlatms_(&m, &n, "S", &iseed[1], "N", &rwork[1], &imode, &
+ cond, &anorm, &c__0, &c__0, "N", &a[a_offset],
+ lda, &work[1], &iinfo);
+
+ } else if (itype == 6) {
+
+/* Nonhermitian, singular values specified */
+
+ zlatms_(&m, &n, "S", &iseed[1], "N", &rwork[1], &imode, &
+ cond, &anorm, &kl, &ku, "N", &a[a_offset], lda, &
+ work[1], &iinfo);
+
+ } else if (itype == 9) {
+
+/* Nonhermitian, random entries */
+
+ zlatmr_(&m, &n, "S", &iseed[1], "N", &work[1], &c__6, &
+ c_b33, &c_b2, "T", "N", &work[n + 1], &c__1, &
+ c_b33, &work[(n << 1) + 1], &c__1, &c_b33, "N",
+ idumma, &kl, &ku, &c_b41, &anorm, "N", &a[
+ a_offset], lda, idumma, &iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+/* Generate Right-Hand Side */
+
+ zlatmr_(&m, nrhs, "S", &iseed[1], "N", &work[1], &c__6, &
+ c_b33, &c_b2, "T", "N", &work[m + 1], &c__1, &c_b33, &
+ work[(m << 1) + 1], &c__1, &c_b33, "N", idumma, &m,
+ nrhs, &c_b41, &c_b33, "NO", &c__[c_offset], ldc,
+ idumma, &iinfo);
+
+ if (iinfo != 0) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+/* Copy A to band storage. */
+
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__6 = j - ku;
+/* Computing MIN */
+ i__8 = m, i__9 = j + kl;
+ i__7 = min(i__8,i__9);
+ for (i__ = max(i__5,i__6); i__ <= i__7; ++i__) {
+ i__5 = ku + 1 + i__ - j + j * ab_dim1;
+ i__6 = i__ + j * a_dim1;
+ ab[i__5].r = a[i__6].r, ab[i__5].i = a[i__6].i;
+/* L100: */
+ }
+/* L110: */
+ }
+
+/* Copy C */
+
+ zlacpy_("Full", &m, nrhs, &c__[c_offset], ldc, &cc[cc_offset],
+ ldc);
+
+/* Call ZGBBRD to compute B, Q and P, and to update C. */
+
+ zgbbrd_("B", &m, &n, nrhs, &kl, &ku, &ab[ab_offset], ldab, &
+ bd[1], &be[1], &q[q_offset], ldq, &p[p_offset], ldp, &
+ cc[cc_offset], ldc, &work[1], &rwork[1], &iinfo);
+
+ if (iinfo != 0) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "ZGBBRD", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[1] = ulpinv;
+ goto L120;
+ }
+ }
+
+/* Test 1: Check the decomposition A := Q * B * P' */
+/* 2: Check the orthogonality of Q */
+/* 3: Check the orthogonality of P */
+/* 4: Check the computation of Q' * C */
+
+ zbdt01_(&m, &n, &c_n1, &a[a_offset], lda, &q[q_offset], ldq, &
+ bd[1], &be[1], &p[p_offset], ldp, &work[1], &rwork[1],
+ &result[1]);
+ zunt01_("Columns", &m, &m, &q[q_offset], ldq, &work[1], lwork,
+ &rwork[1], &result[2]);
+ zunt01_("Rows", &n, &n, &p[p_offset], ldp, &work[1], lwork, &
+ rwork[1], &result[3]);
+ zbdt02_(&m, nrhs, &c__[c_offset], ldc, &cc[cc_offset], ldc, &
+ q[q_offset], ldq, &work[1], &rwork[1], &result[4]);
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+ ntest = 4;
+L120:
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__4 = ntest;
+ for (jr = 1; jr <= i__4; ++jr) {
+ if (result[jr] >= *thresh) {
+ if (nerrs == 0) {
+ dlahd2_(nounit, "ZBB");
+ }
+ ++nerrs;
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+/* L130: */
+ }
+
+L140:
+ ;
+ }
+L150:
+ ;
+ }
+/* L160: */
+ }
+
+/* Summary */
+
+ dlasum_("ZBB", nounit, &nerrs, &ntestt);
+ return 0;
+
+
+/* End of ZCHKBB */
+
+} /* zchkbb_ */
diff --git a/TESTING/EIG/zchkbd.c b/TESTING/EIG/zchkbd.c
new file mode 100644
index 0000000..beb9a19
--- /dev/null
+++ b/TESTING/EIG/zchkbd.c
@@ -0,0 +1,1135 @@
+/* zchkbd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__0 = 0;
+static integer c__6 = 6;
+static doublereal c_b37 = 1.;
+static integer c__1 = 1;
+static doublereal c_b47 = 0.;
+static integer c__2 = 2;
+static integer c__4 = 4;
+
+/* Subroutine */ int zchkbd_(integer *nsizes, integer *mval, integer *nval,
+ integer *ntypes, logical *dotype, integer *nrhs, integer *iseed,
+ doublereal *thresh, doublecomplex *a, integer *lda, doublereal *bd,
+ doublereal *be, doublereal *s1, doublereal *s2, doublecomplex *x,
+ integer *ldx, doublecomplex *y, doublecomplex *z__, doublecomplex *q,
+ integer *ldq, doublecomplex *pt, integer *ldpt, doublecomplex *u,
+ doublecomplex *vt, doublecomplex *work, integer *lwork, doublereal *
+ rwork, integer *nout, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[16] = { 1,2,4,4,4,4,4,6,6,6,6,6,9,9,9,10 };
+ static integer kmagn[16] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3,0 };
+ static integer kmode[16] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9998[] = "(\002 ZCHKBD: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002M=\002,i6,\002, N=\002,i6,\002, JTYPE=\002,i"
+ "6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, type "
+ "\002,i2,\002, seed=\002,4(i4,\002,\002),\002 test(\002,i2,\002)"
+ "=\002,g11.4)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, pt_dim1, pt_offset, q_dim1, q_offset, u_dim1,
+ u_offset, vt_dim1, vt_offset, x_dim1, x_offset, y_dim1, y_offset,
+ z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double log(doublereal), sqrt(doublereal), exp(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, m, n, mq;
+ doublereal ulp, cond;
+ integer jcol;
+ char path[3];
+ integer mmax, nmax;
+ doublereal unfl, ovfl;
+ char uplo[1];
+ doublereal temp1, temp2;
+ logical badmm, badnn;
+ integer nfail, imode;
+ doublereal dumma[1];
+ integer iinfo;
+ extern /* Subroutine */ int zbdt01_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, doublereal *, doublereal *), zbdt02_(integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublereal *,
+ doublereal *), zbdt03_(char *, integer *, integer *, doublereal *,
+ doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, doublereal *)
+ ;
+ doublereal anorm;
+ integer mnmin;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer mnmax;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer jsize, itype, jtype, iwork[1], ntest;
+ extern /* Subroutine */ int dlahd2_(integer *, char *), zunt01_(
+ char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *);
+ integer log2ui;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ logical bidiag;
+ extern doublereal dlamch_(char *), dlarnd_(integer *, integer *);
+ extern /* Subroutine */ int dsvdch_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *), xerbla_(char *, integer *
+);
+ integer ioldsd[4];
+ extern /* Subroutine */ int zgebrd_(integer *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *, integer *), alasum_(
+ char *, integer *, integer *, integer *, integer *);
+ doublereal amninv;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *), zbdsqr_(
+ char *, integer *, integer *, integer *, integer *, doublereal *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, integer *);
+ integer minwrk;
+ extern /* Subroutine */ int zungbr_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *), zlatmr_(integer *, integer *, char
+ *, integer *, char *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, char *, char *, doublecomplex *, integer *,
+ doublereal *, doublecomplex *, integer *, doublereal *, char *,
+ integer *, integer *, integer *, doublereal *, doublereal *, char
+ *, doublecomplex *, integer *, integer *, integer *);
+ doublereal rtunfl, rtovfl, ulpinv, result[14];
+ extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ integer mtypes;
+
+ /* Fortran I/O blocks */
+ static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKBD checks the singular value decomposition (SVD) routines. */
+
+/* ZGEBRD reduces a complex general m by n matrix A to real upper or */
+/* lower bidiagonal form by an orthogonal transformation: Q' * A * P = B */
+/* (or A = Q * B * P'). The matrix B is upper bidiagonal if m >= n */
+/* and lower bidiagonal if m < n. */
+
+/* ZUNGBR generates the orthogonal matrices Q and P' from ZGEBRD. */
+/* Note that Q and P are not necessarily square. */
+
+/* ZBDSQR computes the singular value decomposition of the bidiagonal */
+/* matrix B as B = U S V'. It is called three times to compute */
+/* 1) B = U S1 V', where S1 is the diagonal matrix of singular */
+/* values and the columns of the matrices U and V are the left */
+/* and right singular vectors, respectively, of B. */
+/* 2) Same as 1), but the singular values are stored in S2 and the */
+/* singular vectors are not computed. */
+/* 3) A = (UQ) S (P'V'), the SVD of the original matrix A. */
+/* In addition, ZBDSQR has an option to apply the left orthogonal matrix */
+/* U to a matrix X, useful in least squares applications. */
+
+/* For each pair of matrix dimensions (M,N) and each selected matrix */
+/* type, an M by N matrix A and an M by NRHS matrix X are generated. */
+/* The problem dimensions are as follows */
+/* A: M x N */
+/* Q: M x min(M,N) (but M x M if NRHS > 0) */
+/* P: min(M,N) x N */
+/* B: min(M,N) x min(M,N) */
+/* U, V: min(M,N) x min(M,N) */
+/* S1, S2 diagonal, order min(M,N) */
+/* X: M x NRHS */
+
+/* For each generated matrix, 14 tests are performed: */
+
+/* Test ZGEBRD and ZUNGBR */
+
+/* (1) | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P' */
+
+/* (2) | I - Q' Q | / ( M ulp ) */
+
+/* (3) | I - PT PT' | / ( N ulp ) */
+
+/* Test ZBDSQR on bidiagonal matrix B */
+
+/* (4) | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V' */
+
+/* (5) | Y - U Z | / ( |Y| max(min(M,N),k) ulp ), where Y = Q' X */
+/* and Z = U' Y. */
+/* (6) | I - U' U | / ( min(M,N) ulp ) */
+
+/* (7) | I - VT VT' | / ( min(M,N) ulp ) */
+
+/* (8) S1 contains min(M,N) nonnegative values in decreasing order. */
+/* (Return 0 if true, 1/ULP if false.) */
+
+/* (9) 0 if the true singular values of B are within THRESH of */
+/* those in S1. 2*THRESH if they are not. (Tested using */
+/* DSVDCH) */
+
+/* (10) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without */
+/* computing U and V. */
+
+/* Test ZBDSQR on matrix A */
+
+/* (11) | A - (QU) S (VT PT) | / ( |A| max(M,N) ulp ) */
+
+/* (12) | X - (QU) Z | / ( |X| max(M,k) ulp ) */
+
+/* (13) | I - (QU)'(QU) | / ( M ulp ) */
+
+/* (14) | I - (VT PT) (PT'VT') | / ( N ulp ) */
+
+/* The possible matrix types are */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (6) Same as (3), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (3), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U D V, where U and V are orthogonal and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) Rectangular matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
+
+/* Special case: */
+/* (16) A bidiagonal matrix with random entries chosen from a */
+/* logarithmic distribution on [ulp^2,ulp^(-2)] (I.e., each */
+/* entry is e^x, where x is chosen uniformly on */
+/* [ 2 log(ulp), -2 log(ulp) ] .) For *this* type: */
+/* (a) ZGEBRD is not called to reduce it to bidiagonal form. */
+/* (b) the bidiagonal is min(M,N) x min(M,N); if M<N, the */
+/* matrix will be lower bidiagonal, otherwise upper. */
+/* (c) only tests 5--8 and 14 are performed. */
+
+/* A subset of the full set of matrix types may be selected through */
+/* the logical array DOTYPE. */
+
+/* Arguments */
+/* ========== */
+
+/* NSIZES (input) INTEGER */
+/* The number of values of M and N contained in the vectors */
+/* MVAL and NVAL. The matrix sizes are used in pairs (M,N). */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix column dimension N. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, ZCHKBD */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrices are in A and B. */
+/* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size (m,n), a matrix */
+/* of type j will be generated. If NTYPES is smaller than the */
+/* maximum number of types defined (PARAMETER MAXTYP), then */
+/* types NTYPES+1 through MAXTYP will not be generated. If */
+/* NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through */
+/* DOTYPE(NTYPES) will be ignored. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns in the "right-hand side" matrices X, Y, */
+/* and Z, used in testing ZBDSQR. If NRHS = 0, then the */
+/* operations on the right-hand side will not be tested. */
+/* NRHS must be at least 0. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The values of ISEED are changed on exit, and can be */
+/* used in the next call to ZCHKBD to continue the same random */
+/* number sequence. */
+
+/* THRESH (input) 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. Note that the */
+/* expected value of the test ratios is O(1), so THRESH should */
+/* be a reasonably small multiple of 1, e.g., 10 or 100. */
+
+/* A (workspace) COMPLEX*16 array, dimension (LDA,NMAX) */
+/* where NMAX is the maximum value of N in NVAL. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,MMAX), */
+/* where MMAX is the maximum value of M in MVAL. */
+
+/* BD (workspace) DOUBLE PRECISION array, dimension */
+/* (max(min(MVAL(j),NVAL(j)))) */
+
+/* BE (workspace) DOUBLE PRECISION array, dimension */
+/* (max(min(MVAL(j),NVAL(j)))) */
+
+/* S1 (workspace) DOUBLE PRECISION array, dimension */
+/* (max(min(MVAL(j),NVAL(j)))) */
+
+/* S2 (workspace) DOUBLE PRECISION array, dimension */
+/* (max(min(MVAL(j),NVAL(j)))) */
+
+/* X (workspace) COMPLEX*16 array, dimension (LDX,NRHS) */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the arrays X, Y, and Z. */
+/* LDX >= max(1,MMAX). */
+
+/* Y (workspace) COMPLEX*16 array, dimension (LDX,NRHS) */
+
+/* Z (workspace) COMPLEX*16 array, dimension (LDX,NRHS) */
+
+/* Q (workspace) COMPLEX*16 array, dimension (LDQ,MMAX) */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,MMAX). */
+
+/* PT (workspace) COMPLEX*16 array, dimension (LDPT,NMAX) */
+
+/* LDPT (input) INTEGER */
+/* The leading dimension of the arrays PT, U, and V. */
+/* LDPT >= max(1, max(min(MVAL(j),NVAL(j)))). */
+
+/* U (workspace) COMPLEX*16 array, dimension */
+/* (LDPT,max(min(MVAL(j),NVAL(j)))) */
+
+/* V (workspace) COMPLEX*16 array, dimension */
+/* (LDPT,max(min(MVAL(j),NVAL(j)))) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 3(M+N) and M(M + max(M,N,k) + 1) + N*min(M,N) for all */
+/* pairs (M,N)=(MM(j),NN(j)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (5*max(min(M,N))) */
+
+/* NOUT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some MM(j) < 0 */
+/* -3: Some NN(j) < 0 */
+/* -4: NTYPES < 0 */
+/* -6: NRHS < 0 */
+/* -8: THRESH < 0 */
+/* -11: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ). */
+/* -17: LDB < 1 or LDB < MMAX. */
+/* -21: LDQ < 1 or LDQ < MMAX. */
+/* -23: LDP < 1 or LDP < MNMAX. */
+/* -27: LWORK too small. */
+/* If ZLATMR, CLATMS, ZGEBRD, ZUNGBR, or ZBDSQR, */
+/* returns an error code, the */
+/* absolute value of it is returned. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests performed, or which can */
+/* be performed so far, for the current matrix. */
+/* MMAX Largest value in NN. */
+/* NMAX Largest value in NN. */
+/* MNMIN min(MM(j), NN(j)) (the dimension of the bidiagonal */
+/* matrix.) */
+/* MNMAX The maximum value of MNMIN for j=1,...,NSIZES. */
+/* NFAIL The number of tests which have exceeded THRESH */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* ====================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --mval;
+ --nval;
+ --dotype;
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --bd;
+ --be;
+ --s1;
+ --s2;
+ z_dim1 = *ldx;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ y_dim1 = *ldx;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ vt_dim1 = *ldpt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ u_dim1 = *ldpt;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ pt_dim1 = *ldpt;
+ pt_offset = 1 + pt_dim1;
+ pt -= pt_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+
+ badmm = FALSE_;
+ badnn = FALSE_;
+ mmax = 1;
+ nmax = 1;
+ mnmax = 1;
+ minwrk = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = mmax, i__3 = mval[j];
+ mmax = max(i__2,i__3);
+ if (mval[j] < 0) {
+ badmm = TRUE_;
+ }
+/* Computing MAX */
+ i__2 = nmax, i__3 = nval[j];
+ nmax = max(i__2,i__3);
+ if (nval[j] < 0) {
+ badnn = TRUE_;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__4 = mval[j], i__5 = nval[j];
+ i__2 = mnmax, i__3 = min(i__4,i__5);
+ mnmax = max(i__2,i__3);
+/* Computing MAX */
+/* Computing MAX */
+ i__4 = mval[j], i__5 = nval[j], i__4 = max(i__4,i__5);
+/* Computing MIN */
+ i__6 = nval[j], i__7 = mval[j];
+ i__2 = minwrk, i__3 = (mval[j] + nval[j]) * 3, i__2 = max(i__2,i__3),
+ i__3 = mval[j] * (mval[j] + max(i__4,*nrhs) + 1) + nval[j] *
+ min(i__6,i__7);
+ minwrk = max(i__2,i__3);
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badmm) {
+ *info = -2;
+ } else if (badnn) {
+ *info = -3;
+ } else if (*ntypes < 0) {
+ *info = -4;
+ } else if (*nrhs < 0) {
+ *info = -6;
+ } else if (*lda < mmax) {
+ *info = -11;
+ } else if (*ldx < mmax) {
+ *info = -17;
+ } else if (*ldq < mmax) {
+ *info = -21;
+ } else if (*ldpt < mnmax) {
+ *info = -23;
+ } else if (minwrk > *lwork) {
+ *info = -27;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZCHKBD", &i__1);
+ return 0;
+ }
+
+/* Initialize constants */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "BD", (ftnlen)2, (ftnlen)2);
+ nfail = 0;
+ ntest = 0;
+ unfl = dlamch_("Safe minimum");
+ ovfl = dlamch_("Overflow");
+ dlabad_(&unfl, &ovfl);
+ ulp = dlamch_("Precision");
+ ulpinv = 1. / ulp;
+ log2ui = (integer) (log(ulpinv) / log(2.));
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+ infoc_1.infot = 0;
+
+/* Loop over sizes, types */
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ m = mval[jsize];
+ n = nval[jsize];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__2 = max(m,n);
+ amninv = 1. / max(i__2,1);
+
+ if (*nsizes != 1) {
+ mtypes = min(16,*ntypes);
+ } else {
+ mtypes = min(17,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L170;
+ }
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+ for (j = 1; j <= 14; ++j) {
+ result[j - 1] = -1.;
+/* L30: */
+ }
+
+ *(unsigned char *)uplo = ' ';
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random symmetric, w/ eigenvalues */
+/* =6 nonsymmetric, w/ singular values */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 random nonsymmetric */
+/* =10 random bidiagonal (log. distrib.) */
+
+ if (mtypes > 16) {
+ goto L100;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * amninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * max(m,n) * ulpinv;
+ goto L70;
+
+L70:
+
+ zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+ bidiag = FALSE_;
+ if (itype == 1) {
+
+/* Zero matrix */
+
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = mnmin;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ a[i__4].r = anorm, a[i__4].i = 0.;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ zlatms_(&mnmin, &mnmin, "S", &iseed[1], "N", &rwork[1], &
+ imode, &cond, &anorm, &c__0, &c__0, "N", &a[a_offset],
+ lda, &work[1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ zlatms_(&mnmin, &mnmin, "S", &iseed[1], "S", &rwork[1], &
+ imode, &cond, &anorm, &m, &n, "N", &a[a_offset], lda,
+ &work[1], &iinfo);
+
+ } else if (itype == 6) {
+
+/* Nonsymmetric, singular values specified */
+
+ zlatms_(&m, &n, "S", &iseed[1], "N", &rwork[1], &imode, &cond,
+ &anorm, &m, &n, "N", &a[a_offset], lda, &work[1], &
+ iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random entries */
+
+ zlatmr_(&mnmin, &mnmin, "S", &iseed[1], "N", &work[1], &c__6,
+ &c_b37, &c_b2, "T", "N", &work[mnmin + 1], &c__1, &
+ c_b37, &work[(mnmin << 1) + 1], &c__1, &c_b37, "N",
+ iwork, &c__0, &c__0, &c_b47, &anorm, "NO", &a[
+ a_offset], lda, iwork, &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random entries */
+
+ zlatmr_(&mnmin, &mnmin, "S", &iseed[1], "S", &work[1], &c__6,
+ &c_b37, &c_b2, "T", "N", &work[mnmin + 1], &c__1, &
+ c_b37, &work[m + mnmin + 1], &c__1, &c_b37, "N",
+ iwork, &m, &n, &c_b47, &anorm, "NO", &a[a_offset],
+ lda, iwork, &iinfo);
+
+ } else if (itype == 9) {
+
+/* Nonsymmetric, random entries */
+
+ zlatmr_(&m, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b37,
+ &c_b2, "T", "N", &work[mnmin + 1], &c__1, &c_b37, &
+ work[m + mnmin + 1], &c__1, &c_b37, "N", iwork, &m, &
+ n, &c_b47, &anorm, "NO", &a[a_offset], lda, iwork, &
+ iinfo);
+
+ } else if (itype == 10) {
+
+/* Bidiagonal, random entries */
+
+ temp1 = log(ulp) * -2.;
+ i__3 = mnmin;
+ for (j = 1; j <= i__3; ++j) {
+ bd[j] = exp(temp1 * dlarnd_(&c__2, &iseed[1]));
+ if (j < mnmin) {
+ be[j] = exp(temp1 * dlarnd_(&c__2, &iseed[1]));
+ }
+/* L90: */
+ }
+
+ iinfo = 0;
+ bidiag = TRUE_;
+ if (m >= n) {
+ *(unsigned char *)uplo = 'U';
+ } else {
+ *(unsigned char *)uplo = 'L';
+ }
+ } else {
+ iinfo = 1;
+ }
+
+ if (iinfo == 0) {
+
+/* Generate Right-Hand Side */
+
+ if (bidiag) {
+ zlatmr_(&mnmin, nrhs, "S", &iseed[1], "N", &work[1], &
+ c__6, &c_b37, &c_b2, "T", "N", &work[mnmin + 1], &
+ c__1, &c_b37, &work[(mnmin << 1) + 1], &c__1, &
+ c_b37, "N", iwork, &mnmin, nrhs, &c_b47, &c_b37,
+ "NO", &y[y_offset], ldx, iwork, &iinfo);
+ } else {
+ zlatmr_(&m, nrhs, "S", &iseed[1], "N", &work[1], &c__6, &
+ c_b37, &c_b2, "T", "N", &work[m + 1], &c__1, &
+ c_b37, &work[(m << 1) + 1], &c__1, &c_b37, "N",
+ iwork, &m, nrhs, &c_b47, &c_b37, "NO", &x[
+ x_offset], ldx, iwork, &iinfo);
+ }
+ }
+
+/* Error Exit */
+
+ if (iinfo != 0) {
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L100:
+
+/* Call ZGEBRD and ZUNGBR to compute B, Q, and P, do tests. */
+
+ if (! bidiag) {
+
+/* Compute transformations to reduce A to bidiagonal form: */
+/* B := Q' * A * P. */
+
+ zlacpy_(" ", &m, &n, &a[a_offset], lda, &q[q_offset], ldq);
+ i__3 = *lwork - (mnmin << 1);
+ zgebrd_(&m, &n, &q[q_offset], ldq, &bd[1], &be[1], &work[1], &
+ work[mnmin + 1], &work[(mnmin << 1) + 1], &i__3, &
+ iinfo);
+
+/* Check error code from ZGEBRD. */
+
+ if (iinfo != 0) {
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "ZGEBRD", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+ zlacpy_(" ", &m, &n, &q[q_offset], ldq, &pt[pt_offset], ldpt);
+ if (m >= n) {
+ *(unsigned char *)uplo = 'U';
+ } else {
+ *(unsigned char *)uplo = 'L';
+ }
+
+/* Generate Q */
+
+ mq = m;
+ if (*nrhs <= 0) {
+ mq = mnmin;
+ }
+ i__3 = *lwork - (mnmin << 1);
+ zungbr_("Q", &m, &mq, &n, &q[q_offset], ldq, &work[1], &work[(
+ mnmin << 1) + 1], &i__3, &iinfo);
+
+/* Check error code from ZUNGBR. */
+
+ if (iinfo != 0) {
+ io___43.ciunit = *nout;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "ZUNGBR(Q)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Generate P' */
+
+ i__3 = *lwork - (mnmin << 1);
+ zungbr_("P", &mnmin, &n, &m, &pt[pt_offset], ldpt, &work[
+ mnmin + 1], &work[(mnmin << 1) + 1], &i__3, &iinfo);
+
+/* Check error code from ZUNGBR. */
+
+ if (iinfo != 0) {
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "ZUNGBR(P)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Apply Q' to an M by NRHS matrix X: Y := Q' * X. */
+
+ zgemm_("Conjugate transpose", "No transpose", &m, nrhs, &m, &
+ c_b2, &q[q_offset], ldq, &x[x_offset], ldx, &c_b1, &y[
+ y_offset], ldx);
+
+/* Test 1: Check the decomposition A := Q * B * PT */
+/* 2: Check the orthogonality of Q */
+/* 3: Check the orthogonality of PT */
+
+ zbdt01_(&m, &n, &c__1, &a[a_offset], lda, &q[q_offset], ldq, &
+ bd[1], &be[1], &pt[pt_offset], ldpt, &work[1], &rwork[
+ 1], result);
+ zunt01_("Columns", &m, &mq, &q[q_offset], ldq, &work[1],
+ lwork, &rwork[1], &result[1]);
+ zunt01_("Rows", &mnmin, &n, &pt[pt_offset], ldpt, &work[1],
+ lwork, &rwork[1], &result[2]);
+ }
+
+/* Use ZBDSQR to form the SVD of the bidiagonal matrix B: */
+/* B := U * S1 * VT, and compute Z = U' * Y. */
+
+ dcopy_(&mnmin, &bd[1], &c__1, &s1[1], &c__1);
+ if (mnmin > 0) {
+ i__3 = mnmin - 1;
+ dcopy_(&i__3, &be[1], &c__1, &rwork[1], &c__1);
+ }
+ zlacpy_(" ", &m, nrhs, &y[y_offset], ldx, &z__[z_offset], ldx);
+ zlaset_("Full", &mnmin, &mnmin, &c_b1, &c_b2, &u[u_offset], ldpt);
+ zlaset_("Full", &mnmin, &mnmin, &c_b1, &c_b2, &vt[vt_offset],
+ ldpt);
+
+ zbdsqr_(uplo, &mnmin, &mnmin, &mnmin, nrhs, &s1[1], &rwork[1], &
+ vt[vt_offset], ldpt, &u[u_offset], ldpt, &z__[z_offset],
+ ldx, &rwork[mnmin + 1], &iinfo);
+
+/* Check error code from ZBDSQR. */
+
+ if (iinfo != 0) {
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "ZBDSQR(vects)", (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[3] = ulpinv;
+ goto L150;
+ }
+ }
+
+/* Use ZBDSQR to compute only the singular values of the */
+/* bidiagonal matrix B; U, VT, and Z should not be modified. */
+
+ dcopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
+ if (mnmin > 0) {
+ i__3 = mnmin - 1;
+ dcopy_(&i__3, &be[1], &c__1, &rwork[1], &c__1);
+ }
+
+ zbdsqr_(uplo, &mnmin, &c__0, &c__0, &c__0, &s2[1], &rwork[1], &vt[
+ vt_offset], ldpt, &u[u_offset], ldpt, &z__[z_offset], ldx,
+ &rwork[mnmin + 1], &iinfo);
+
+/* Check error code from ZBDSQR. */
+
+ if (iinfo != 0) {
+ io___46.ciunit = *nout;
+ s_wsfe(&io___46);
+ do_fio(&c__1, "ZBDSQR(values)", (ftnlen)14);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[8] = ulpinv;
+ goto L150;
+ }
+ }
+
+/* Test 4: Check the decomposition B := U * S1 * VT */
+/* 5: Check the computation Z := U' * Y */
+/* 6: Check the orthogonality of U */
+/* 7: Check the orthogonality of VT */
+
+ zbdt03_(uplo, &mnmin, &c__1, &bd[1], &be[1], &u[u_offset], ldpt, &
+ s1[1], &vt[vt_offset], ldpt, &work[1], &result[3]);
+ zbdt02_(&mnmin, nrhs, &y[y_offset], ldx, &z__[z_offset], ldx, &u[
+ u_offset], ldpt, &work[1], &rwork[1], &result[4]);
+ zunt01_("Columns", &mnmin, &mnmin, &u[u_offset], ldpt, &work[1],
+ lwork, &rwork[1], &result[5]);
+ zunt01_("Rows", &mnmin, &mnmin, &vt[vt_offset], ldpt, &work[1],
+ lwork, &rwork[1], &result[6]);
+
+/* Test 8: Check that the singular values are sorted in */
+/* non-increasing order and are non-negative */
+
+ result[7] = 0.;
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (s1[i__] < s1[i__ + 1]) {
+ result[7] = ulpinv;
+ }
+ if (s1[i__] < 0.) {
+ result[7] = ulpinv;
+ }
+/* L110: */
+ }
+ if (mnmin >= 1) {
+ if (s1[mnmin] < 0.) {
+ result[7] = ulpinv;
+ }
+ }
+
+/* Test 9: Compare ZBDSQR with and without singular vectors */
+
+ temp2 = 0.;
+
+ i__3 = mnmin;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+/* Computing MAX */
+ d__6 = (d__1 = s1[j], abs(d__1)), d__7 = (d__2 = s2[j], abs(
+ d__2));
+ d__4 = sqrt(unfl) * max(s1[1],1.), d__5 = ulp * max(d__6,d__7)
+ ;
+ temp1 = (d__3 = s1[j] - s2[j], abs(d__3)) / max(d__4,d__5);
+ temp2 = max(temp1,temp2);
+/* L120: */
+ }
+
+ result[8] = temp2;
+
+/* Test 10: Sturm sequence test of singular values */
+/* Go up by factors of two until it succeeds */
+
+ temp1 = *thresh * (.5 - ulp);
+
+ i__3 = log2ui;
+ for (j = 0; j <= i__3; ++j) {
+ dsvdch_(&mnmin, &bd[1], &be[1], &s1[1], &temp1, &iinfo);
+ if (iinfo == 0) {
+ goto L140;
+ }
+ temp1 *= 2.;
+/* L130: */
+ }
+
+L140:
+ result[9] = temp1;
+
+/* Use ZBDSQR to form the decomposition A := (QU) S (VT PT) */
+/* from the bidiagonal form A := Q B PT. */
+
+ if (! bidiag) {
+ dcopy_(&mnmin, &bd[1], &c__1, &s2[1], &c__1);
+ if (mnmin > 0) {
+ i__3 = mnmin - 1;
+ dcopy_(&i__3, &be[1], &c__1, &rwork[1], &c__1);
+ }
+
+ zbdsqr_(uplo, &mnmin, &n, &m, nrhs, &s2[1], &rwork[1], &pt[
+ pt_offset], ldpt, &q[q_offset], ldq, &y[y_offset],
+ ldx, &rwork[mnmin + 1], &iinfo);
+
+/* Test 11: Check the decomposition A := Q*U * S2 * VT*PT */
+/* 12: Check the computation Z := U' * Q' * X */
+/* 13: Check the orthogonality of Q*U */
+/* 14: Check the orthogonality of VT*PT */
+
+ zbdt01_(&m, &n, &c__0, &a[a_offset], lda, &q[q_offset], ldq, &
+ s2[1], dumma, &pt[pt_offset], ldpt, &work[1], &rwork[
+ 1], &result[10]);
+ zbdt02_(&m, nrhs, &x[x_offset], ldx, &y[y_offset], ldx, &q[
+ q_offset], ldq, &work[1], &rwork[1], &result[11]);
+ zunt01_("Columns", &m, &mq, &q[q_offset], ldq, &work[1],
+ lwork, &rwork[1], &result[12]);
+ zunt01_("Rows", &mnmin, &n, &pt[pt_offset], ldpt, &work[1],
+ lwork, &rwork[1], &result[13]);
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L150:
+ for (j = 1; j <= 14; ++j) {
+ if (result[j - 1] >= *thresh) {
+ if (nfail == 0) {
+ dlahd2_(nout, path);
+ }
+ io___50.ciunit = *nout;
+ s_wsfe(&io___50);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L160: */
+ }
+ if (! bidiag) {
+ ntest += 14;
+ } else {
+ ntest += 5;
+ }
+
+L170:
+ ;
+ }
+/* L180: */
+ }
+
+/* Summary */
+
+ alasum_(path, nout, &nfail, &ntest, &c__0);
+
+ return 0;
+
+/* End of ZCHKBD */
+
+
+} /* zchkbd_ */
diff --git a/TESTING/EIG/zchkbk.c b/TESTING/EIG/zchkbk.c
new file mode 100644
index 0000000..55bfec6
--- /dev/null
+++ b/TESTING/EIG/zchkbk.c
@@ -0,0 +1,249 @@
+/* zchkbk.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__5 = 5;
+static integer c__7 = 7;
+static integer c__20 = 20;
+
+/* Subroutine */ int zchkbk_(integer *nin, integer *nout)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002.. test output of ZGEBAK .. \002)";
+ static char fmt_9998[] = "(1x,\002value of largest test error "
+ " = \002,d12.3)";
+ static char fmt_9997[] = "(1x,\002example number where info is not zero "
+ " = \002,i4)";
+ static char fmt_9996[] = "(1x,\002example number having largest error "
+ " = \002,i4)";
+ static char fmt_9995[] = "(1x,\002number of examples where info is not 0"
+ " = \002,i4)";
+ static char fmt_9994[] = "(1x,\002total number of examples tested "
+ " = \002,i4)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+ double d_imag(doublecomplex *);
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ doublecomplex e[400] /* was [20][20] */;
+ integer i__, j, n;
+ doublereal x;
+ integer ihi;
+ doublecomplex ein[400] /* was [20][20] */;
+ integer ilo;
+ doublereal eps;
+ integer knt, info, lmax[2];
+ doublereal rmax, vmax, scale[20];
+ integer ninfo;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zgebak_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublecomplex *, integer *,
+ integer *);
+ doublereal safmin;
+
+ /* Fortran I/O blocks */
+ static cilist io___7 = { 0, 0, 0, 0, 0 };
+ static cilist io___11 = { 0, 0, 0, 0, 0 };
+ static cilist io___14 = { 0, 0, 0, 0, 0 };
+ static cilist io___17 = { 0, 0, 0, 0, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___26 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKBK tests ZGEBAK, a routine for backward transformation of */
+/* the computed right or left eigenvectors if the orginal matrix */
+/* was preprocessed by balance subroutine ZGEBAL. */
+
+/* Arguments */
+/* ========= */
+
+/* NIN (input) INTEGER */
+/* The logical unit number for input. NIN > 0. */
+
+/* NOUT (input) INTEGER */
+/* The logical unit number for output. NOUT > 0. */
+
+/* ====================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ lmax[0] = 0;
+ lmax[1] = 0;
+ ninfo = 0;
+ knt = 0;
+ rmax = 0.;
+ eps = dlamch_("E");
+ safmin = dlamch_("S");
+
+L10:
+
+ io___7.ciunit = *nin;
+ s_rsle(&io___7);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ilo, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ihi, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ goto L60;
+ }
+
+ io___11.ciunit = *nin;
+ s_rsle(&io___11);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__5, &c__1, (char *)&scale[i__ - 1], (ftnlen)sizeof(
+ doublereal));
+ }
+ e_rsle();
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___14.ciunit = *nin;
+ s_rsle(&io___14);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&e[i__ + j * 20 - 21], (ftnlen)
+ sizeof(doublecomplex));
+ }
+ e_rsle();
+/* L20: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___17.ciunit = *nin;
+ s_rsle(&io___17);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&ein[i__ + j * 20 - 21], (ftnlen)
+ sizeof(doublecomplex));
+ }
+ e_rsle();
+/* L30: */
+ }
+
+ ++knt;
+ zgebak_("B", "R", &n, &ilo, &ihi, scale, &n, e, &c__20, &info);
+
+ if (info != 0) {
+ ++ninfo;
+ lmax[0] = knt;
+ }
+
+ vmax = 0.;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ z__2.r = e[i__3].r - ein[i__4].r, z__2.i = e[i__3].i - ein[i__4]
+ .i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ x = ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), abs(d__2)
+ )) / eps;
+ i__3 = i__ + j * 20 - 21;
+ if ((d__1 = e[i__3].r, abs(d__1)) + (d__2 = d_imag(&e[i__ + j *
+ 20 - 21]), abs(d__2)) > safmin) {
+ i__4 = i__ + j * 20 - 21;
+ x /= (d__3 = e[i__4].r, abs(d__3)) + (d__4 = d_imag(&e[i__ +
+ j * 20 - 21]), abs(d__4));
+ }
+ vmax = max(vmax,x);
+/* L40: */
+ }
+/* L50: */
+ }
+
+ if (vmax > rmax) {
+ lmax[1] = knt;
+ rmax = vmax;
+ }
+
+ goto L10;
+
+L60:
+
+ io___22.ciunit = *nout;
+ s_wsfe(&io___22);
+ e_wsfe();
+
+ io___23.ciunit = *nout;
+ s_wsfe(&io___23);
+ do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ io___24.ciunit = *nout;
+ s_wsfe(&io___24);
+ do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___25.ciunit = *nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ return 0;
+
+/* End of ZCHKBK */
+
+} /* zchkbk_ */
diff --git a/TESTING/EIG/zchkbl.c b/TESTING/EIG/zchkbl.c
new file mode 100644
index 0000000..6a6d8cb
--- /dev/null
+++ b/TESTING/EIG/zchkbl.c
@@ -0,0 +1,279 @@
+/* zchkbl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__7 = 7;
+static integer c__5 = 5;
+static integer c__20 = 20;
+
+/* Subroutine */ int zchkbl_(integer *nin, integer *nout)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002.. test output of ZGEBAL .. \002)";
+ static char fmt_9998[] = "(1x,\002value of largest test error "
+ " = \002,d12.3)";
+ static char fmt_9997[] = "(1x,\002example number where info is not zero "
+ " = \002,i4)";
+ static char fmt_9996[] = "(1x,\002example number where ILO or IHI wrong "
+ " = \002,i4)";
+ static char fmt_9995[] = "(1x,\002example number having largest error "
+ " = \002,i4)";
+ static char fmt_9994[] = "(1x,\002number of examples where info is not 0"
+ " = \002,i4)";
+ static char fmt_9993[] = "(1x,\002total number of examples tested "
+ " = \002,i4)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+ double d_imag(doublecomplex *);
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ doublecomplex a[400] /* was [20][20] */;
+ integer i__, j, n;
+ doublecomplex ain[400] /* was [20][20] */;
+ integer ihi, ilo, knt, info, lmax[3];
+ doublereal meps, temp, rmax, vmax, scale[20];
+ integer ihiin, ninfo, iloin;
+ doublereal anorm, sfmin, dummy[1];
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zgebal_(char *, integer *, doublecomplex *,
+ integer *, integer *, integer *, doublereal *, integer *);
+ doublereal scalin[20];
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+
+ /* Fortran I/O blocks */
+ static cilist io___8 = { 0, 0, 0, 0, 0 };
+ static cilist io___11 = { 0, 0, 0, 0, 0 };
+ static cilist io___14 = { 0, 0, 0, 0, 0 };
+ static cilist io___17 = { 0, 0, 0, 0, 0 };
+ static cilist io___19 = { 0, 0, 0, 0, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKBL tests ZGEBAL, a routine for balancing a general complex */
+/* matrix and isolating some of its eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* NIN (input) INTEGER */
+/* The logical unit number for input. NIN > 0. */
+
+/* NOUT (input) INTEGER */
+/* The logical unit number for output. NOUT > 0. */
+
+/* ====================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ lmax[0] = 0;
+ lmax[1] = 0;
+ lmax[2] = 0;
+ ninfo = 0;
+ knt = 0;
+ rmax = 0.;
+ vmax = 0.;
+ sfmin = dlamch_("S");
+ meps = dlamch_("E");
+
+L10:
+
+ io___8.ciunit = *nin;
+ s_rsle(&io___8);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ goto L70;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___11.ciunit = *nin;
+ s_rsle(&io___11);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&a[i__ + j * 20 - 21], (ftnlen)
+ sizeof(doublecomplex));
+ }
+ e_rsle();
+/* L20: */
+ }
+
+ io___14.ciunit = *nin;
+ s_rsle(&io___14);
+ do_lio(&c__3, &c__1, (char *)&iloin, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ihiin, (ftnlen)sizeof(integer));
+ e_rsle();
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___17.ciunit = *nin;
+ s_rsle(&io___17);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&ain[i__ + j * 20 - 21], (ftnlen)
+ sizeof(doublecomplex));
+ }
+ e_rsle();
+/* L30: */
+ }
+ io___19.ciunit = *nin;
+ s_rsle(&io___19);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__5, &c__1, (char *)&scalin[i__ - 1], (ftnlen)sizeof(
+ doublereal));
+ }
+ e_rsle();
+
+ anorm = zlange_("M", &n, &n, a, &c__20, dummy);
+ ++knt;
+ zgebal_("B", &n, a, &c__20, &ilo, &ihi, scale, &info);
+
+ if (info != 0) {
+ ++ninfo;
+ lmax[0] = knt;
+ }
+
+ if (ilo != iloin || ihi != ihiin) {
+ ++ninfo;
+ lmax[1] = knt;
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ d__5 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + j *
+ 20 - 21]), abs(d__2)), d__6 = (d__3 = ain[i__4].r, abs(
+ d__3)) + (d__4 = d_imag(&ain[i__ + j * 20 - 21]), abs(
+ d__4));
+ temp = max(d__5,d__6);
+ temp = max(temp,sfmin);
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ z__2.r = a[i__3].r - ain[i__4].r, z__2.i = a[i__3].i - ain[i__4]
+ .i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+/* Computing MAX */
+ d__3 = vmax, d__4 = ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
+ z__1), abs(d__2))) / temp;
+ vmax = max(d__3,d__4);
+/* L40: */
+ }
+/* L50: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = scale[i__ - 1], d__2 = scalin[i__ - 1];
+ temp = max(d__1,d__2);
+ temp = max(temp,sfmin);
+/* Computing MAX */
+ d__2 = vmax, d__3 = (d__1 = scale[i__ - 1] - scalin[i__ - 1], abs(
+ d__1)) / temp;
+ vmax = max(d__2,d__3);
+/* L60: */
+ }
+
+ if (vmax > rmax) {
+ lmax[2] = knt;
+ rmax = vmax;
+ }
+
+ goto L10;
+
+L70:
+
+ io___28.ciunit = *nout;
+ s_wsfe(&io___28);
+ e_wsfe();
+
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ return 0;
+
+/* End of ZCHKBL */
+
+} /* zchkbl_ */
diff --git a/TESTING/EIG/zchkec.c b/TESTING/EIG/zchkec.c
new file mode 100644
index 0000000..392a854
--- /dev/null
+++ b/TESTING/EIG/zchkec.c
@@ -0,0 +1,212 @@
+/* zchkec.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int zchkec_(doublereal *thresh, logical *tsterr, integer *
+ nin, integer *nout)
+{
+ /* Format strings */
+ static char fmt_9994[] = "(\002 Tests of the Nonsymmetric eigenproblem c"
+ "ondition\002,\002 estimation routines\002,/\002 ZTRSYL, CTREXC, "
+ "CTRSNA, CTRSEN\002,/)";
+ static char fmt_9993[] = "(\002 Relative machine precision (EPS) = \002,"
+ "d16.6,/\002 Safe minimum (SFMIN) = \002,d16.6,/)";
+ static char fmt_9992[] = "(\002 Routines pass computational tests if tes"
+ "t ratio is \002,\002less than\002,f8.2,//)";
+ static char fmt_9999[] = "(\002 Error in ZTRSYL: RMAX =\002,d12.3,/\002 "
+ "LMAX = \002,i8,\002 NINFO=\002,i8,\002 KNT=\002,i8)";
+ static char fmt_9998[] = "(\002 Error in ZTREXC: RMAX =\002,d12.3,/\002 "
+ "LMAX = \002,i8,\002 NINFO=\002,i8,\002 KNT=\002,i8)";
+ static char fmt_9997[] = "(\002 Error in ZTRSNA: RMAX =\002,3d12.3,/\002"
+ " LMAX = \002,3i8,\002 NINFO=\002,3i8,\002 KNT=\002,i8)";
+ static char fmt_9996[] = "(\002 Error in ZTRSEN: RMAX =\002,3d12.3,/\002"
+ " LMAX = \002,3i8,\002 NINFO=\002,3i8,\002 KNT=\002,i8)";
+ static char fmt_9995[] = "(/1x,\002All tests for \002,a3,\002 routines p"
+ "assed the threshold (\002,i6,\002 tests run)\002)";
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ logical ok;
+ doublereal eps;
+ char path[3];
+ doublereal sfmin;
+ extern /* Subroutine */ int zget35_(doublereal *, integer *, integer *,
+ integer *, integer *), zget36_(doublereal *, integer *, integer *,
+ integer *, integer *), zget37_(doublereal *, integer *, integer *
+, integer *, integer *), zget38_(doublereal *, integer *, integer
+ *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zerrec_(char *, integer *);
+ integer ktrexc, ltrexc, ktrsna, ntrexc, ltrsna[3], ntrsna[3], ktrsen;
+ doublereal rtrexc;
+ integer ltrsen[3], ntrsen[3];
+ doublereal rtrsna[3], rtrsen[3];
+ integer ntests, ktrsyl, ltrsyl, ntrsyl;
+ doublereal rtrsyl;
+
+ /* Fortran I/O blocks */
+ static cilist io___4 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___5 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___6 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___12 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___17 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKEC tests eigen- condition estimation routines */
+/* ZTRSYL, CTREXC, CTRSNA, CTRSEN */
+
+/* In all cases, the routine runs through a fixed set of numerical */
+/* examples, subjects them to various tests, and compares the test */
+/* results to a threshold THRESH. In addition, ZTRSNA and CTRSEN are */
+/* tested by reading in precomputed examples from a file (on input unit */
+/* NIN). Output is written to output unit NOUT. */
+
+/* Arguments */
+/* ========= */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* Threshold for residual tests. A computed test ratio passes */
+/* the threshold if it is less than THRESH. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NIN (input) INTEGER */
+/* The logical unit number for input. */
+
+/* NOUT (input) INTEGER */
+/* The logical unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "EC", (ftnlen)2, (ftnlen)2);
+ eps = dlamch_("P");
+ sfmin = dlamch_("S");
+ io___4.ciunit = *nout;
+ s_wsfe(&io___4);
+ e_wsfe();
+ io___5.ciunit = *nout;
+ s_wsfe(&io___5);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&sfmin, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ io___6.ciunit = *nout;
+ s_wsfe(&io___6);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+/* Test error exits if TSTERR is .TRUE. */
+
+ if (*tsterr) {
+ zerrec_(path, nout);
+ }
+
+ ok = TRUE_;
+ zget35_(&rtrsyl, <rsyl, &ntrsyl, &ktrsyl, nin);
+ if (rtrsyl > *thresh) {
+ ok = FALSE_;
+ io___12.ciunit = *nout;
+ s_wsfe(&io___12);
+ do_fio(&c__1, (char *)&rtrsyl, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)<rsyl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ntrsyl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ktrsyl, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ zget36_(&rtrexc, <rexc, &ntrexc, &ktrexc, nin);
+ if (rtrexc > *thresh || ntrexc > 0) {
+ ok = FALSE_;
+ io___17.ciunit = *nout;
+ s_wsfe(&io___17);
+ do_fio(&c__1, (char *)&rtrexc, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)<rexc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ntrexc, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ktrexc, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ zget37_(rtrsna, ltrsna, ntrsna, &ktrsna, nin);
+ if (rtrsna[0] > *thresh || rtrsna[1] > *thresh || ntrsna[0] != 0 ||
+ ntrsna[1] != 0 || ntrsna[2] != 0) {
+ ok = FALSE_;
+ io___22.ciunit = *nout;
+ s_wsfe(&io___22);
+ do_fio(&c__3, (char *)&rtrsna[0], (ftnlen)sizeof(doublereal));
+ do_fio(&c__3, (char *)<rsna[0], (ftnlen)sizeof(integer));
+ do_fio(&c__3, (char *)&ntrsna[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ktrsna, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ zget38_(rtrsen, ltrsen, ntrsen, &ktrsen, nin);
+ if (rtrsen[0] > *thresh || rtrsen[1] > *thresh || ntrsen[0] != 0 ||
+ ntrsen[1] != 0 || ntrsen[2] != 0) {
+ ok = FALSE_;
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__3, (char *)&rtrsen[0], (ftnlen)sizeof(doublereal));
+ do_fio(&c__3, (char *)<rsen[0], (ftnlen)sizeof(integer));
+ do_fio(&c__3, (char *)&ntrsen[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ktrsen, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ ntests = ktrsyl + ktrexc + ktrsna + ktrsen;
+ if (ok) {
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&ntests, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ return 0;
+
+/* End of ZCHKEC */
+
+} /* zchkec_ */
diff --git a/TESTING/EIG/zchkee.c b/TESTING/EIG/zchkee.c
new file mode 100644
index 0000000..db29390
--- /dev/null
+++ b/TESTING/EIG/zchkee.c
@@ -0,0 +1,3515 @@
+/* zchkee.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer nproc, nshift, maxb;
+} cenvir_;
+
+#define cenvir_1 cenvir_
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ doublereal selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+struct {
+ integer iparms[100];
+} zlaenv_;
+
+#define zlaenv_1 zlaenv_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__5 = 5;
+static integer c__6 = 6;
+static integer c__20 = 20;
+static integer c__0 = 0;
+static integer c__132 = 132;
+static integer c__2 = 2;
+static integer c__12 = 12;
+static integer c__13 = 13;
+static integer c__14 = 14;
+static integer c__15 = 15;
+static integer c__16 = 16;
+static integer c__4 = 4;
+static integer c__8 = 8;
+static integer c__89760 = 89760;
+static integer c__9 = 9;
+static integer c__25 = 25;
+static integer c__20064 = 20064;
+static integer c__18 = 18;
+static integer c__400 = 400;
+static integer c__20062 = 20062;
+static integer c__264 = 264;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Initialized data */
+
+ static char intstr[10] = "0123456789";
+ static integer ioldsd[4] = { 0,0,0,1 };
+
+ /* Format strings */
+ static char fmt_9987[] = "(\002 Tests of the Nonsymmetric Eigenvalue Pro"
+ "blem routines\002)";
+ static char fmt_9986[] = "(\002 Tests of the Hermitian Eigenvalue Proble"
+ "m routines\002)";
+ static char fmt_9985[] = "(\002 Tests of the Singular Value Decompositio"
+ "n routines\002)";
+ static char fmt_9979[] = "(/\002 Tests of the Nonsymmetric Eigenvalue Pr"
+ "oblem Driver\002,/\002 ZGEEV (eigenvalues and eigevectors)"
+ "\002)";
+ static char fmt_9978[] = "(/\002 Tests of the Nonsymmetric Eigenvalue Pr"
+ "oblem Driver\002,/\002 ZGEES (Schur form)\002)";
+ static char fmt_9977[] = "(/\002 Tests of the Nonsymmetric Eigenvalue Pr"
+ "oblem Expert\002,\002 Driver\002,/\002 ZGEEVX (eigenvalues, e"
+ "igenvectors and\002,\002 condition numbers)\002)";
+ static char fmt_9976[] = "(/\002 Tests of the Nonsymmetric Eigenvalue Pr"
+ "oblem Expert\002,\002 Driver\002,/\002 ZGEESX (Schur form and"
+ " condition\002,\002 numbers)\002)";
+ static char fmt_9975[] = "(/\002 Tests of the Generalized Nonsymmetric E"
+ "igenvalue \002,\002Problem routines\002)";
+ static char fmt_9964[] = "(/\002 Tests of the Generalized Nonsymmetric E"
+ "igenvalue \002,\002Problem Driver ZGGES\002)";
+ static char fmt_9965[] = "(/\002 Tests of the Generalized Nonsymmetric E"
+ "igenvalue \002,\002Problem Expert Driver ZGGESX\002)";
+ static char fmt_9963[] = "(/\002 Tests of the Generalized Nonsymmetric E"
+ "igenvalue \002,\002Problem Driver ZGGEV\002)";
+ static char fmt_9962[] = "(/\002 Tests of the Generalized Nonsymmetric E"
+ "igenvalue \002,\002Problem Expert Driver ZGGEVX\002)";
+ static char fmt_9974[] = "(\002 Tests of ZHBTRD\002,/\002 (reduction of "
+ "a Hermitian band \002,\002matrix to real tridiagonal form)\002)";
+ static char fmt_9967[] = "(\002 Tests of ZGBBRD\002,/\002 (reduction of "
+ "a general band \002,\002matrix to real bidiagonal form)\002)";
+ static char fmt_9971[] = "(/\002 Tests of the Generalized Linear Regress"
+ "ion Model \002,\002routines\002)";
+ static char fmt_9970[] = "(/\002 Tests of the Generalized QR and RQ rout"
+ "ines\002)";
+ static char fmt_9969[] = "(/\002 Tests of the Generalized Singular Valu"
+ "e\002,\002 Decomposition routines\002)";
+ static char fmt_9968[] = "(/\002 Tests of the Linear Least Squares routi"
+ "nes\002)";
+ static char fmt_9992[] = "(1x,a3,\002: Unrecognized path name\002)";
+ static char fmt_9972[] = "(/\002 LAPACK VERSION \002,i1,\002.\002,i1,"
+ "\002.\002,i1)";
+ static char fmt_9984[] = "(/\002 The following parameter values will be "
+ "used:\002)";
+ static char fmt_9989[] = "(\002 Invalid input value: \002,a,\002=\002,"
+ "i6,\002; must be >=\002,i6)";
+ static char fmt_9988[] = "(\002 Invalid input value: \002,a,\002=\002,"
+ "i6,\002; must be <=\002,i6)";
+ static char fmt_9983[] = "(4x,a,10i6,/10x,10i6)";
+ static char fmt_9981[] = "(\002 Relative machine \002,a,\002 is taken to"
+ " be\002,d16.6)";
+ static char fmt_9982[] = "(/\002 Routines pass computational tests if te"
+ "st ratio is \002,\002less than\002,f8.2,/)";
+ static char fmt_9999[] = "(/\002 Execution not attempted due to input er"
+ "rors\002)";
+ static char fmt_9991[] = "(//\002 *** Invalid integer value in column"
+ " \002,i2,\002 of input\002,\002 line:\002,/a79)";
+ static char fmt_9990[] = "(//1x,a3,\002 routines were not tested\002)";
+ static char fmt_9961[] = "(//1x,a3,\002: NB =\002,i4,\002, NBMIN =\002,"
+ "i4,\002, NX =\002,i4,\002, INMIN=\002,i4,\002, INWIN =\002,i4"
+ ",\002, INIBL =\002,i4,\002, ISHFTS =\002,i4,\002, IACC22 =\002,i"
+ "4)";
+ static char fmt_9980[] = "(\002 *** Error code from \002,a,\002 = \002,i"
+ "4)";
+ static char fmt_9997[] = "(//1x,a3,\002: NB =\002,i4,\002, NBMIN =\002,"
+ "i4,\002, NX =\002,i4)";
+ static char fmt_9995[] = "(//1x,a3,\002: NB =\002,i4,\002, NBMIN =\002,"
+ "i4,\002, NX =\002,i4,\002, NRHS =\002,i4)";
+ static char fmt_9973[] = "(/1x,71(\002-\002))";
+ static char fmt_9996[] = "(//1x,a3,\002: NB =\002,i4,\002, NBMIN =\002,"
+ "i4,\002, NS =\002,i4,\002, MAXB =\002,i4,\002, NBCOL =\002,i4)";
+ static char fmt_9966[] = "(//1x,a3,\002: NRHS =\002,i4)";
+ static char fmt_9994[] = "(//\002 End of tests\002)";
+ static char fmt_9993[] = "(\002 Total time used = \002,f12.2,\002 seco"
+ "nds\002,/)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublereal d__1;
+ cilist ci__1;
+
+ /* Builtin functions */
+ integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_cmp(char *, char *, ftnlen, ftnlen), s_wsfe(cilist *), e_wsfe(
+ void), s_rsle(cilist *), do_lio(integer *, integer *, char *,
+ ftnlen), e_rsle(void), s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+ integer i_len(char *, ftnlen);
+
+ /* Local variables */
+ doublecomplex a[243936] /* was [17424][14] */, b[87120] /* was [17424]
+ [5] */, c__[160000] /* was [400][400] */;
+ integer i__, k;
+ doublereal s[17424];
+ doublecomplex x[660];
+ char c1[1], c3[3];
+ integer i1;
+ doublereal s1, s2;
+ doublecomplex dc[792] /* was [132][6] */;
+ integer ic;
+ doublereal dr[1584] /* was [132][12] */;
+ integer nk, nn, vers_patch__, vers_major__, vers_minor__;
+ logical zbb, glm, nep, lse, zbk, zbl, sep, gqr, zgg, zgk, zgl, svd, zhb,
+ gsv;
+ doublereal eps;
+ logical zes, zgs, zev, zgv, zgx, zsx, zvx, zxv;
+ doublereal beta[132];
+ char line[80];
+ doublecomplex taua[132];
+ integer info;
+ char path[3];
+ integer kval[20], lenp, mval[20], nval[20];
+ doublecomplex taub[132];
+ integer pval[20], itmp, nrhs;
+ doublecomplex work[89760];
+ integer iacc22[20];
+ doublereal alpha[132];
+ logical fatal;
+ integer iseed[4], nbcol[20], inibl[20], nbval[20], nbmin[20];
+ char vname[32];
+ integer inmin[20], newsd, nsval[20], inwin[20], nxval[20], iwork[20064];
+ doublereal rwork[89760];
+ extern doublereal dlamch_(char *), dsecnd_(void);
+ extern /* Subroutine */ int zchkbb_(integer *, integer *, integer *,
+ integer *, integer *, integer *, logical *, integer *, integer *,
+ doublereal *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublereal *, doublereal *, integer *), alareq_(char *,
+ integer *, logical *, integer *, integer *, integer *),
+ zchkbd_(integer *, integer *, integer *, integer *, logical *,
+ integer *, integer *, doublereal *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublereal *, integer *, integer *), zchkec_(doublereal *,
+ logical *, integer *, integer *), zchkhb_(integer *, integer *,
+ integer *, integer *, integer *, logical *, integer *, doublereal
+ *, integer *, doublecomplex *, integer *, doublereal *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, integer *), zchkbk_(
+ integer *, integer *), zchkbl_(integer *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int zchkgg_(integer *, integer *, integer *,
+ logical *, integer *, doublereal *, logical *, doublereal *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublereal *, logical *, doublereal *, integer *), zchkgk_(
+ integer *, integer *), zchkgl_(integer *, integer *), ilaver_(
+ integer *, integer *, integer *), zckglm_(integer *, integer *,
+ integer *, integer *, integer *, integer *, doublereal *, integer
+ *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
+ integer *, integer *, integer *), zerrbd_(char *, integer *);
+ integer mxbval[20];
+ extern /* Subroutine */ int zchkhs_(integer *, integer *, integer *,
+ logical *, integer *, doublereal *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *, doublereal *,
+ integer *, logical *, doublereal *, integer *), zcklse_(integer *,
+ integer *, integer *, integer *, integer *, integer *,
+ doublereal *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublereal *, integer *, integer *, integer *), zdrvbd_(integer
+ *, integer *, integer *, integer *, logical *, integer *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublereal *, doublereal *,
+ doublereal *, doublecomplex *, integer *, doublereal *, integer *,
+ integer *, integer *);
+ logical tstdif;
+ doublereal thresh;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *);
+ logical tstchk;
+ integer nparms, ishfts[20];
+ extern /* Subroutine */ int zckgqr_(integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, doublereal
+ *, integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublereal *, integer *,
+ integer *, integer *);
+ logical dotype[30], logwrk[132];
+ doublereal thrshn;
+ extern /* Subroutine */ int zchkst_(integer *, integer *, integer *,
+ logical *, integer *, doublereal *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, doublereal *, integer *, integer *, integer *,
+ doublereal *, integer *), zckgsv_(integer *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *, integer *, integer *, integer *), zdrges_(integer *,
+ integer *, integer *, logical *, integer *, doublereal *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, doublereal *, doublereal *, logical *, integer *),
+ zdrgev_(integer *, integer *, integer *, logical *, integer *,
+ doublereal *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, integer *, doublereal *, doublereal *, integer
+ *), zdrvgg_(integer *, integer *, integer *, logical *, integer *,
+ doublereal *, doublereal *, integer *, doublecomplex *, integer *
+, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublereal *, doublereal *, integer *)
+ , zdrves_(integer *, integer *, integer *, logical *, integer *,
+ doublereal *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, integer *, doublereal *, doublecomplex *,
+ integer *, doublereal *, integer *, logical *, integer *);
+ doublereal result[500];
+ extern /* Subroutine */ int zdrvsg_(integer *, integer *, integer *,
+ logical *, integer *, doublereal *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublereal *, integer *, integer *, integer *, doublereal *,
+ integer *), zdrvev_(integer *, integer *, integer *, logical *,
+ integer *, doublereal *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, doublecomplex *, integer *, doublecomplex *, integer
+ *, doublereal *, doublecomplex *, integer *, doublereal *,
+ integer *, integer *), zdrgsx_(integer *, integer *, doublereal *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, doublereal *, doublecomplex *, integer *, doublereal
+ *, integer *, integer *, logical *, integer *);
+ integer maxtyp;
+ logical tsterr;
+ integer ntypes;
+ logical tstdrv;
+ extern /* Subroutine */ int zdrgvx_(integer *, doublereal *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublecomplex *, integer *,
+ doublereal *, integer *, integer *, doublereal *, logical *,
+ integer *), zerred_(char *, integer *), zerrgg_(char *,
+ integer *), zerrhs_(char *, integer *), zerrst_(
+ char *, integer *), zdrvst_(integer *, integer *, integer
+ *, logical *, integer *, doublereal *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *
+, doublereal *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, doublereal *, integer *, integer *, integer *,
+ doublereal *, integer *), zdrvsx_(integer *, integer *, integer *,
+ logical *, integer *, doublereal *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, doublecomplex *, doublereal *, doublecomplex *,
+ integer *, doublereal *, logical *, integer *), zdrvvx_(integer *,
+ integer *, integer *, logical *, integer *, doublereal *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublecomplex *, integer *, doublereal *, integer *)
+ ;
+
+ /* Fortran I/O blocks */
+ static cilist io___29 = { 0, 6, 0, fmt_9987, 0 };
+ static cilist io___30 = { 0, 6, 0, fmt_9986, 0 };
+ static cilist io___31 = { 0, 6, 0, fmt_9985, 0 };
+ static cilist io___32 = { 0, 6, 0, fmt_9979, 0 };
+ static cilist io___33 = { 0, 6, 0, fmt_9978, 0 };
+ static cilist io___34 = { 0, 6, 0, fmt_9977, 0 };
+ static cilist io___35 = { 0, 6, 0, fmt_9976, 0 };
+ static cilist io___36 = { 0, 6, 0, fmt_9975, 0 };
+ static cilist io___37 = { 0, 6, 0, fmt_9964, 0 };
+ static cilist io___38 = { 0, 6, 0, fmt_9965, 0 };
+ static cilist io___39 = { 0, 6, 0, fmt_9963, 0 };
+ static cilist io___40 = { 0, 6, 0, fmt_9962, 0 };
+ static cilist io___41 = { 0, 6, 0, fmt_9974, 0 };
+ static cilist io___42 = { 0, 6, 0, fmt_9967, 0 };
+ static cilist io___43 = { 0, 6, 0, fmt_9971, 0 };
+ static cilist io___44 = { 0, 6, 0, fmt_9970, 0 };
+ static cilist io___45 = { 0, 6, 0, fmt_9969, 0 };
+ static cilist io___46 = { 0, 6, 0, fmt_9968, 0 };
+ static cilist io___47 = { 0, 5, 0, 0, 0 };
+ static cilist io___50 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___54 = { 0, 6, 0, fmt_9972, 0 };
+ static cilist io___55 = { 0, 6, 0, fmt_9984, 0 };
+ static cilist io___56 = { 0, 5, 0, 0, 0 };
+ static cilist io___58 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___59 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___60 = { 0, 5, 0, 0, 0 };
+ static cilist io___64 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___65 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___66 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___67 = { 0, 5, 0, 0, 0 };
+ static cilist io___69 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___70 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___71 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___72 = { 0, 5, 0, 0, 0 };
+ static cilist io___74 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___75 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___76 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___77 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___78 = { 0, 5, 0, 0, 0 };
+ static cilist io___80 = { 0, 5, 0, 0, 0 };
+ static cilist io___82 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___83 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___84 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___85 = { 0, 5, 0, 0, 0 };
+ static cilist io___94 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___95 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___96 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___97 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___98 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___99 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___100 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___101 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___102 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___103 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___104 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___105 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___106 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___107 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___108 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___109 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___110 = { 0, 5, 0, 0, 0 };
+ static cilist io___113 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___114 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___115 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___116 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___117 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___118 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___119 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___120 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___121 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___122 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___123 = { 0, 5, 0, 0, 0 };
+ static cilist io___125 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___126 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___127 = { 0, 5, 0, 0, 0 };
+ static cilist io___128 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___129 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___130 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___131 = { 0, 5, 0, 0, 0 };
+ static cilist io___132 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___133 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___134 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___135 = { 0, 5, 0, 0, 0 };
+ static cilist io___136 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___137 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___138 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___139 = { 0, 5, 0, 0, 0 };
+ static cilist io___140 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___141 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___142 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___143 = { 0, 5, 0, 0, 0 };
+ static cilist io___144 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___145 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___146 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___147 = { 0, 5, 0, 0, 0 };
+ static cilist io___148 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___149 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___150 = { 0, 5, 0, 0, 0 };
+ static cilist io___151 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___152 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___153 = { 0, 5, 0, 0, 0 };
+ static cilist io___154 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___155 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___156 = { 0, 5, 0, 0, 0 };
+ static cilist io___157 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___158 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___159 = { 0, 5, 0, 0, 0 };
+ static cilist io___160 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___161 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___162 = { 0, 5, 0, 0, 0 };
+ static cilist io___164 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___165 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___166 = { 0, 6, 0, fmt_9983, 0 };
+ static cilist io___167 = { 0, 6, 0, 0, 0 };
+ static cilist io___169 = { 0, 6, 0, fmt_9981, 0 };
+ static cilist io___170 = { 0, 6, 0, fmt_9981, 0 };
+ static cilist io___171 = { 0, 6, 0, fmt_9981, 0 };
+ static cilist io___172 = { 0, 5, 0, 0, 0 };
+ static cilist io___173 = { 0, 6, 0, fmt_9982, 0 };
+ static cilist io___174 = { 0, 5, 0, 0, 0 };
+ static cilist io___176 = { 0, 5, 0, 0, 0 };
+ static cilist io___178 = { 0, 5, 0, 0, 0 };
+ static cilist io___179 = { 0, 5, 0, 0, 0 };
+ static cilist io___181 = { 0, 5, 0, 0, 0 };
+ static cilist io___183 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___192 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___193 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___196 = { 0, 6, 0, fmt_9961, 0 };
+ static cilist io___205 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___206 = { 0, 6, 0, fmt_9997, 0 };
+ static cilist io___208 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___209 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___210 = { 0, 6, 0, fmt_9997, 0 };
+ static cilist io___211 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___213 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___214 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___215 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___216 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___217 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___218 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___219 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___220 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___221 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___222 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___223 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___224 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___225 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___226 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___227 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___230 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___231 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___232 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___233 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___234 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___235 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___238 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___239 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___240 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___241 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___242 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___243 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___244 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___245 = { 0, 6, 0, fmt_9973, 0 };
+ static cilist io___246 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___247 = { 0, 6, 0, fmt_9966, 0 };
+ static cilist io___248 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___251 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___254 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___257 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___258 = { 0, 6, 0, fmt_9980, 0 };
+ static cilist io___259 = { 0, 6, 0, 0, 0 };
+ static cilist io___260 = { 0, 6, 0, 0, 0 };
+ static cilist io___261 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___262 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___264 = { 0, 6, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2007 */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKEE tests the COMPLEX*16 LAPACK subroutines for the matrix */
+/* eigenvalue problem. The test paths in this version are */
+
+/* NEP (Nonsymmetric Eigenvalue Problem): */
+/* Test ZGEHRD, ZUNGHR, ZHSEQR, ZTREVC, ZHSEIN, and ZUNMHR */
+
+/* SEP (Hermitian Eigenvalue Problem): */
+/* Test ZHETRD, ZUNGTR, ZSTEQR, ZSTERF, ZSTEIN, ZSTEDC, */
+/* and drivers ZHEEV(X), ZHBEV(X), ZHPEV(X), */
+/* ZHEEVD, ZHBEVD, ZHPEVD */
+
+/* SVD (Singular Value Decomposition): */
+/* Test ZGEBRD, ZUNGBR, and ZBDSQR */
+/* and the drivers ZGESVD, ZGESDD */
+
+/* ZEV (Nonsymmetric Eigenvalue/eigenvector Driver): */
+/* Test ZGEEV */
+
+/* ZES (Nonsymmetric Schur form Driver): */
+/* Test ZGEES */
+
+/* ZVX (Nonsymmetric Eigenvalue/eigenvector Expert Driver): */
+/* Test ZGEEVX */
+
+/* ZSX (Nonsymmetric Schur form Expert Driver): */
+/* Test ZGEESX */
+
+/* ZGG (Generalized Nonsymmetric Eigenvalue Problem): */
+/* Test ZGGHRD, ZGGBAL, ZGGBAK, ZHGEQZ, and ZTGEVC */
+/* and the driver routines ZGEGS and ZGEGV */
+
+/* ZGS (Generalized Nonsymmetric Schur form Driver): */
+/* Test ZGGES */
+
+/* ZGV (Generalized Nonsymmetric Eigenvalue/eigenvector Driver): */
+/* Test ZGGEV */
+
+/* ZGX (Generalized Nonsymmetric Schur form Expert Driver): */
+/* Test ZGGESX */
+
+/* ZXV (Generalized Nonsymmetric Eigenvalue/eigenvector Expert Driver): */
+/* Test ZGGEVX */
+
+/* ZSG (Hermitian Generalized Eigenvalue Problem): */
+/* Test ZHEGST, ZHEGV, ZHEGVD, ZHEGVX, ZHPGST, ZHPGV, ZHPGVD, */
+/* ZHPGVX, ZHBGST, ZHBGV, ZHBGVD, and ZHBGVX */
+
+/* ZHB (Hermitian Band Eigenvalue Problem): */
+/* Test ZHBTRD */
+
+/* ZBB (Band Singular Value Decomposition): */
+/* Test ZGBBRD */
+
+/* ZEC (Eigencondition estimation): */
+/* Test ZTRSYL, ZTREXC, ZTRSNA, and ZTRSEN */
+
+/* ZBL (Balancing a general matrix) */
+/* Test ZGEBAL */
+
+/* ZBK (Back transformation on a balanced matrix) */
+/* Test ZGEBAK */
+
+/* ZGL (Balancing a matrix pair) */
+/* Test ZGGBAL */
+
+/* ZGK (Back transformation on a matrix pair) */
+/* Test ZGGBAK */
+
+/* GLM (Generalized Linear Regression Model): */
+/* Tests ZGGGLM */
+
+/* GQR (Generalized QR and RQ factorizations): */
+/* Tests ZGGQRF and ZGGRQF */
+
+/* GSV (Generalized Singular Value Decomposition): */
+/* Tests ZGGSVD, ZGGSVP, ZTGSJA, ZLAGS2, ZLAPLL, and ZLAPMT */
+
+/* LSE (Constrained Linear Least Squares): */
+/* Tests ZGGLSE */
+
+/* Each test path has a different set of inputs, but the data sets for */
+/* the driver routines xEV, xES, xVX, and xSX can be concatenated in a */
+/* single input file. The first line of input should contain one of the */
+/* 3-character path names in columns 1-3. The number of remaining lines */
+/* depends on what is found on the first line. */
+
+/* The number of matrix types used in testing is often controllable from */
+/* the input file. The number of matrix types for each path, and the */
+/* test routine that describes them, is as follows: */
+
+/* Path name(s) Types Test routine */
+
+/* ZHS or NEP 21 ZCHKHS */
+/* ZST or SEP 21 ZCHKST (routines) */
+/* 18 ZDRVST (drivers) */
+/* ZBD or SVD 16 ZCHKBD (routines) */
+/* 5 ZDRVBD (drivers) */
+/* ZEV 21 ZDRVEV */
+/* ZES 21 ZDRVES */
+/* ZVX 21 ZDRVVX */
+/* ZSX 21 ZDRVSX */
+/* ZGG 26 ZCHKGG (routines) */
+/* 26 ZDRVGG (drivers) */
+/* ZGS 26 ZDRGES */
+/* ZGX 5 ZDRGSX */
+/* ZGV 26 ZDRGEV */
+/* ZXV 2 ZDRGVX */
+/* ZSG 21 ZDRVSG */
+/* ZHB 15 ZCHKHB */
+/* ZBB 15 ZCHKBB */
+/* ZEC - ZCHKEC */
+/* ZBL - ZCHKBL */
+/* ZBK - ZCHKBK */
+/* ZGL - ZCHKGL */
+/* ZGK - ZCHKGK */
+/* GLM 8 ZCKGLM */
+/* GQR 8 ZCKGQR */
+/* GSV 8 ZCKGSV */
+/* LSE 8 ZCKLSE */
+
+/* ----------------------------------------------------------------------- */
+
+/* NEP input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of N. */
+
+/* line 3: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix dimension N. */
+
+/* line 4: NPARMS, INTEGER */
+/* Number of values of the parameters NB, NBMIN, NX, NS, and */
+/* MAXB. */
+
+/* line 5: NBVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the blocksize NB. */
+
+/* line 6: NBMIN, INTEGER array, dimension (NPARMS) */
+/* The values for the minimum blocksize NBMIN. */
+
+/* line 7: NXVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the crossover point NX. */
+
+/* line 8: INMIN, INTEGER array, dimension (NPARMS) */
+/* LAHQR vs TTQRE crossover point, >= 11 */
+
+/* line 9: INWIN, INTEGER array, dimension (NPARMS) */
+/* recommended deflation window size */
+
+/* line 10: INIBL, INTEGER array, dimension (NPARMS) */
+/* nibble crossover point */
+
+/* line 11: ISHFTS, INTEGER array, dimension (NPARMS) */
+/* number of simultaneous shifts) */
+
+/* line 12: IACC22, INTEGER array, dimension (NPARMS) */
+/* select structured matrix multiply: 0, 1 or 2) */
+
+/* line 13: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. To have all of the test */
+/* ratios printed, use THRESH = 0.0 . */
+
+/* line 14: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 14 was 2: */
+
+/* line 15: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 15-EOF: The remaining lines occur in sets of 1 or 2 and allow */
+/* the user to specify the matrix types. Each line contains */
+/* a 3-character path name in columns 1-3, and the number */
+/* of matrix types must be the first nonblank item in columns */
+/* 4-80. If the number of matrix types is at least 1 but is */
+/* less than the maximum number of possible types, a second */
+/* line will be read to get the numbers of the matrix types to */
+/* be used. For example, */
+/* NEP 21 */
+/* requests all of the matrix types for the nonsymmetric */
+/* eigenvalue problem, while */
+/* NEP 4 */
+/* 9 10 11 12 */
+/* requests only matrices of type 9, 10, 11, and 12. */
+
+/* The valid 3-character path names are 'NEP' or 'ZHS' for the */
+/* nonsymmetric eigenvalue routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* SEP or ZSG input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of N. */
+
+/* line 3: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix dimension N. */
+
+/* line 4: NPARMS, INTEGER */
+/* Number of values of the parameters NB, NBMIN, and NX. */
+
+/* line 5: NBVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the blocksize NB. */
+
+/* line 6: NBMIN, INTEGER array, dimension (NPARMS) */
+/* The values for the minimum blocksize NBMIN. */
+
+/* line 7: NXVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the crossover point NX. */
+
+/* line 8: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 9: TSTCHK, LOGICAL */
+/* Flag indicating whether or not to test the LAPACK routines. */
+
+/* line 10: TSTDRV, LOGICAL */
+/* Flag indicating whether or not to test the driver routines. */
+
+/* line 11: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 12: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 12 was 2: */
+
+/* line 13: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 13-EOF: Lines specifying matrix types, as for NEP. */
+/* The valid 3-character path names are 'SEP' or 'ZST' for the */
+/* Hermitian eigenvalue routines and driver routines, and */
+/* 'ZSG' for the routines for the Hermitian generalized */
+/* eigenvalue problem. */
+
+/* ----------------------------------------------------------------------- */
+
+/* SVD input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M and N. */
+
+/* line 3: MVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix row dimension M. */
+
+/* line 4: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix column dimension N. */
+
+/* line 5: NPARMS, INTEGER */
+/* Number of values of the parameter NB, NBMIN, NX, and NRHS. */
+
+/* line 6: NBVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the blocksize NB. */
+
+/* line 7: NBMIN, INTEGER array, dimension (NPARMS) */
+/* The values for the minimum blocksize NBMIN. */
+
+/* line 8: NXVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the crossover point NX. */
+
+/* line 9: NSVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the number of right hand sides NRHS. */
+
+/* line 10: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 11: TSTCHK, LOGICAL */
+/* Flag indicating whether or not to test the LAPACK routines. */
+
+/* line 12: TSTDRV, LOGICAL */
+/* Flag indicating whether or not to test the driver routines. */
+
+/* line 13: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 14: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 14 was 2: */
+
+/* line 15: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 15-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path names are 'SVD' or 'ZBD' for both the */
+/* SVD routines and the SVD driver routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* ZEV and ZES data files: */
+
+/* line 1: 'ZEV' or 'ZES' in columns 1 to 3. */
+
+/* line 2: NSIZES, INTEGER */
+/* Number of sizes of matrices to use. Should be at least 0 */
+/* and at most 20. If NSIZES = 0, no testing is done */
+/* (although the remaining 3 lines are still read). */
+
+/* line 3: NN, INTEGER array, dimension(NSIZES) */
+/* Dimensions of matrices to be tested. */
+
+/* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+/* These integer parameters determine how blocking is done */
+/* (see ILAENV for details) */
+/* NB : block size */
+/* NBMIN : minimum block size */
+/* NX : minimum dimension for blocking */
+/* NS : number of shifts in xHSEQR */
+/* NBCOL : minimum column dimension for blocking */
+
+/* line 5: THRESH, REAL */
+/* The test threshold against which computed residuals are */
+/* compared. Should generally be in the range from 10. to 20. */
+/* If it is 0., all test case data will be printed. */
+
+/* line 6: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 6 was 2: */
+
+/* line 7: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 8 and following: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'ZEV' to test CGEEV, or */
+/* 'ZES' to test CGEES. */
+
+/* ----------------------------------------------------------------------- */
+
+/* The ZVX data has two parts. The first part is identical to ZEV, */
+/* and the second part consists of test matrices with precomputed */
+/* solutions. */
+
+/* line 1: 'ZVX' in columns 1-3. */
+
+/* line 2: NSIZES, INTEGER */
+/* If NSIZES = 0, no testing of randomly generated examples */
+/* is done, but any precomputed examples are tested. */
+
+/* line 3: NN, INTEGER array, dimension(NSIZES) */
+
+/* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+
+/* line 5: THRESH, REAL */
+
+/* line 6: NEWSD, INTEGER */
+
+/* If line 6 was 2: */
+
+/* line 7: INTEGER array, dimension (4) */
+
+/* lines 8 and following: The first line contains 'ZVX' in columns 1-3 */
+/* followed by the number of matrix types, possibly with */
+/* a second line to specify certain matrix types. */
+/* If the number of matrix types = 0, no testing of randomly */
+/* generated examples is done, but any precomputed examples */
+/* are tested. */
+
+/* remaining lines : Each matrix is stored on 1+N+N**2 lines, where N is */
+/* its dimension. The first line contains the dimension N and */
+/* ISRT (two integers). ISRT indicates whether the last N lines */
+/* are sorted by increasing real part of the eigenvalue */
+/* (ISRT=0) or by increasing imaginary part (ISRT=1). The next */
+/* N**2 lines contain the matrix rowwise, one entry per line. */
+/* The last N lines correspond to each eigenvalue. Each of */
+/* these last N lines contains 4 real values: the real part of */
+/* the eigenvalues, the imaginary part of the eigenvalue, the */
+/* reciprocal condition number of the eigenvalues, and the */
+/* reciprocal condition number of the vector eigenvector. The */
+/* end of data is indicated by dimension N=0. Even if no data */
+/* is to be tested, there must be at least one line containing */
+/* N=0. */
+
+/* ----------------------------------------------------------------------- */
+
+/* The ZSX data is like ZVX. The first part is identical to ZEV, and the */
+/* second part consists of test matrices with precomputed solutions. */
+
+/* line 1: 'ZSX' in columns 1-3. */
+
+/* line 2: NSIZES, INTEGER */
+/* If NSIZES = 0, no testing of randomly generated examples */
+/* is done, but any precomputed examples are tested. */
+
+/* line 3: NN, INTEGER array, dimension(NSIZES) */
+
+/* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+
+/* line 5: THRESH, REAL */
+
+/* line 6: NEWSD, INTEGER */
+
+/* If line 6 was 2: */
+
+/* line 7: INTEGER array, dimension (4) */
+
+/* lines 8 and following: The first line contains 'ZSX' in columns 1-3 */
+/* followed by the number of matrix types, possibly with */
+/* a second line to specify certain matrix types. */
+/* If the number of matrix types = 0, no testing of randomly */
+/* generated examples is done, but any precomputed examples */
+/* are tested. */
+
+/* remaining lines : Each matrix is stored on 3+N**2 lines, where N is */
+/* its dimension. The first line contains the dimension N, the */
+/* dimension M of an invariant subspace, and ISRT. The second */
+/* line contains M integers, identifying the eigenvalues in the */
+/* invariant subspace (by their position in a list of */
+/* eigenvalues ordered by increasing real part (if ISRT=0) or */
+/* by increasing imaginary part (if ISRT=1)). The next N**2 */
+/* lines contain the matrix rowwise. The last line contains the */
+/* reciprocal condition number for the average of the selected */
+/* eigenvalues, and the reciprocal condition number for the */
+/* corresponding right invariant subspace. The end of data in */
+/* indicated by a line containing N=0, M=0, and ISRT = 0. Even */
+/* if no data is to be tested, there must be at least one line */
+/* containing N=0, M=0 and ISRT=0. */
+
+/* ----------------------------------------------------------------------- */
+
+/* ZGG input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of N. */
+
+/* line 3: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix dimension N. */
+
+/* line 4: NPARMS, INTEGER */
+/* Number of values of the parameters NB, NBMIN, NBCOL, NS, and */
+/* MAXB. */
+
+/* line 5: NBVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the blocksize NB. */
+
+/* line 6: NBMIN, INTEGER array, dimension (NPARMS) */
+/* The values for NBMIN, the minimum row dimension for blocks. */
+
+/* line 7: NSVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the number of shifts. */
+
+/* line 8: MXBVAL, INTEGER array, dimension (NPARMS) */
+/* The values for MAXB, used in determining minimum blocksize. */
+
+/* line 9: NBCOL, INTEGER array, dimension (NPARMS) */
+/* The values for NBCOL, the minimum column dimension for */
+/* blocks. */
+
+/* line 10: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 11: TSTCHK, LOGICAL */
+/* Flag indicating whether or not to test the LAPACK routines. */
+
+/* line 12: TSTDRV, LOGICAL */
+/* Flag indicating whether or not to test the driver routines. */
+
+/* line 13: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 14: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 14 was 2: */
+
+/* line 15: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 16-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'ZGG' for the generalized */
+/* eigenvalue problem routines and driver routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* ZGS and ZGV input files: */
+
+/* line 1: 'ZGS' or 'ZGV' in columns 1 to 3. */
+
+/* line 2: NN, INTEGER */
+/* Number of values of N. */
+
+/* line 3: NVAL, INTEGER array, dimension(NN) */
+/* Dimensions of matrices to be tested. */
+
+/* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+/* These integer parameters determine how blocking is done */
+/* (see ILAENV for details) */
+/* NB : block size */
+/* NBMIN : minimum block size */
+/* NX : minimum dimension for blocking */
+/* NS : number of shifts in xHGEQR */
+/* NBCOL : minimum column dimension for blocking */
+
+/* line 5: THRESH, REAL */
+/* The test threshold against which computed residuals are */
+/* compared. Should generally be in the range from 10. to 20. */
+/* If it is 0., all test case data will be printed. */
+
+/* line 6: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits. */
+
+/* line 7: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 17 was 2: */
+
+/* line 7: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 7-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'ZGS' for the generalized */
+/* eigenvalue problem routines and driver routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* ZGX input file: */
+/* line 1: 'ZGX' in columns 1 to 3. */
+
+/* line 2: N, INTEGER */
+/* Value of N. */
+
+/* line 3: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+/* These integer parameters determine how blocking is done */
+/* (see ILAENV for details) */
+/* NB : block size */
+/* NBMIN : minimum block size */
+/* NX : minimum dimension for blocking */
+/* NS : number of shifts in xHGEQR */
+/* NBCOL : minimum column dimension for blocking */
+
+/* line 4: THRESH, REAL */
+/* The test threshold against which computed residuals are */
+/* compared. Should generally be in the range from 10. to 20. */
+/* Information will be printed about each test for which the */
+/* test ratio is greater than or equal to the threshold. */
+
+/* line 5: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 6: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 6 was 2: */
+
+/* line 7: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* If line 2 was 0: */
+
+/* line 7-EOF: Precomputed examples are tested. */
+
+/* remaining lines : Each example is stored on 3+2*N*N lines, where N is */
+/* its dimension. The first line contains the dimension (a */
+/* single integer). The next line contains an integer k such */
+/* that only the last k eigenvalues will be selected and appear */
+/* in the leading diagonal blocks of $A$ and $B$. The next N*N */
+/* lines contain the matrix A, one element per line. The next N*N */
+/* lines contain the matrix B. The last line contains the */
+/* reciprocal of the eigenvalue cluster condition number and the */
+/* reciprocal of the deflating subspace (associated with the */
+/* selected eigencluster) condition number. The end of data is */
+/* indicated by dimension N=0. Even if no data is to be tested, */
+/* there must be at least one line containing N=0. */
+
+/* ----------------------------------------------------------------------- */
+
+/* ZXV input files: */
+/* line 1: 'ZXV' in columns 1 to 3. */
+
+/* line 2: N, INTEGER */
+/* Value of N. */
+
+/* line 3: NB, NBMIN, NX, NS, NBCOL, INTEGERs */
+/* These integer parameters determine how blocking is done */
+/* (see ILAENV for details) */
+/* NB : block size */
+/* NBMIN : minimum block size */
+/* NX : minimum dimension for blocking */
+/* NS : number of shifts in xHGEQR */
+/* NBCOL : minimum column dimension for blocking */
+
+/* line 4: THRESH, REAL */
+/* The test threshold against which computed residuals are */
+/* compared. Should generally be in the range from 10. to 20. */
+/* Information will be printed about each test for which the */
+/* test ratio is greater than or equal to the threshold. */
+
+/* line 5: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 6: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 6 was 2: */
+
+/* line 7: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* If line 2 was 0: */
+
+/* line 7-EOF: Precomputed examples are tested. */
+
+/* remaining lines : Each example is stored on 3+2*N*N lines, where N is */
+/* its dimension. The first line contains the dimension (a */
+/* single integer). The next N*N lines contain the matrix A, one */
+/* element per line. The next N*N lines contain the matrix B. */
+/* The next line contains the reciprocals of the eigenvalue */
+/* condition numbers. The last line contains the reciprocals of */
+/* the eigenvector condition numbers. The end of data is */
+/* indicated by dimension N=0. Even if no data is to be tested, */
+/* there must be at least one line containing N=0. */
+
+/* ----------------------------------------------------------------------- */
+
+/* ZHB input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of N. */
+
+/* line 3: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix dimension N. */
+
+/* line 4: NK, INTEGER */
+/* Number of values of K. */
+
+/* line 5: KVAL, INTEGER array, dimension (NK) */
+/* The values for the matrix dimension K. */
+
+/* line 6: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 7: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 7 was 2: */
+
+/* line 8: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 8-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'ZHB'. */
+
+/* ----------------------------------------------------------------------- */
+
+/* ZBB input file: */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M and N. */
+
+/* line 3: MVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix row dimension M. */
+
+/* line 4: NVAL, INTEGER array, dimension (NN) */
+/* The values for the matrix column dimension N. */
+
+/* line 4: NK, INTEGER */
+/* Number of values of K. */
+
+/* line 5: KVAL, INTEGER array, dimension (NK) */
+/* The values for the matrix bandwidth K. */
+
+/* line 6: NPARMS, INTEGER */
+/* Number of values of the parameter NRHS */
+
+/* line 7: NSVAL, INTEGER array, dimension (NPARMS) */
+/* The values for the number of right hand sides NRHS. */
+
+/* line 8: THRESH */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 9: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 9 was 2: */
+
+/* line 10: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 10-EOF: Lines specifying matrix types, as for SVD. */
+/* The 3-character path name is 'ZBB'. */
+
+/* ----------------------------------------------------------------------- */
+
+/* ZEC input file: */
+
+/* line 2: THRESH, REAL */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* lines 3-EOF: */
+
+/* Input for testing the eigencondition routines consists of a set of */
+/* specially constructed test cases and their solutions. The data */
+/* format is not intended to be modified by the user. */
+
+/* ----------------------------------------------------------------------- */
+
+/* ZBL and ZBK input files: */
+
+/* line 1: 'ZBL' in columns 1-3 to test CGEBAL, or 'ZBK' in */
+/* columns 1-3 to test CGEBAK. */
+
+/* The remaining lines consist of specially constructed test cases. */
+
+/* ----------------------------------------------------------------------- */
+
+/* ZGL and ZGK input files: */
+
+/* line 1: 'ZGL' in columns 1-3 to test ZGGBAL, or 'ZGK' in */
+/* columns 1-3 to test ZGGBAK. */
+
+/* The remaining lines consist of specially constructed test cases. */
+
+/* ----------------------------------------------------------------------- */
+
+/* GLM data file: */
+
+/* line 1: 'GLM' in columns 1 to 3. */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M, P, and N. */
+
+/* line 3: MVAL, INTEGER array, dimension(NN) */
+/* Values of M (row dimension). */
+
+/* line 4: PVAL, INTEGER array, dimension(NN) */
+/* Values of P (row dimension). */
+
+/* line 5: NVAL, INTEGER array, dimension(NN) */
+/* Values of N (column dimension), note M <= N <= M+P. */
+
+/* line 6: THRESH, REAL */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 7: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 8: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 8 was 2: */
+
+/* line 9: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 9-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'GLM' for the generalized */
+/* linear regression model routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* GQR data file: */
+
+/* line 1: 'GQR' in columns 1 to 3. */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M, P, and N. */
+
+/* line 3: MVAL, INTEGER array, dimension(NN) */
+/* Values of M. */
+
+/* line 4: PVAL, INTEGER array, dimension(NN) */
+/* Values of P. */
+
+/* line 5: NVAL, INTEGER array, dimension(NN) */
+/* Values of N. */
+
+/* line 6: THRESH, REAL */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 7: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 8: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 8 was 2: */
+
+/* line 9: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 9-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'GQR' for the generalized */
+/* QR and RQ routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* GSV data file: */
+
+/* line 1: 'GSV' in columns 1 to 3. */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M, P, and N. */
+
+/* line 3: MVAL, INTEGER array, dimension(NN) */
+/* Values of M (row dimension). */
+
+/* line 4: PVAL, INTEGER array, dimension(NN) */
+/* Values of P (row dimension). */
+
+/* line 5: NVAL, INTEGER array, dimension(NN) */
+/* Values of N (column dimension). */
+
+/* line 6: THRESH, REAL */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 7: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 8: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 8 was 2: */
+
+/* line 9: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 9-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'GSV' for the generalized */
+/* SVD routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* LSE data file: */
+
+/* line 1: 'LSE' in columns 1 to 3. */
+
+/* line 2: NN, INTEGER */
+/* Number of values of M, P, and N. */
+
+/* line 3: MVAL, INTEGER array, dimension(NN) */
+/* Values of M. */
+
+/* line 4: PVAL, INTEGER array, dimension(NN) */
+/* Values of P. */
+
+/* line 5: NVAL, INTEGER array, dimension(NN) */
+/* Values of N, note P <= N <= P+M. */
+
+/* line 6: THRESH, REAL */
+/* Threshold value for the test ratios. Information will be */
+/* printed about each test for which the test ratio is greater */
+/* than or equal to the threshold. */
+
+/* line 7: TSTERR, LOGICAL */
+/* Flag indicating whether or not to test the error exits for */
+/* the LAPACK routines and driver routines. */
+
+/* line 8: NEWSD, INTEGER */
+/* A code indicating how to set the random number seed. */
+/* = 0: Set the seed to a default value before each run */
+/* = 1: Initialize the seed to a default value only before the */
+/* first run */
+/* = 2: Like 1, but use the seed values on the next line */
+
+/* If line 8 was 2: */
+
+/* line 9: INTEGER array, dimension (4) */
+/* Four integer values for the random number seed. */
+
+/* lines 9-EOF: Lines specifying matrix types, as for NEP. */
+/* The 3-character path name is 'GSV' for the generalized */
+/* SVD routines. */
+
+/* ----------------------------------------------------------------------- */
+
+/* NMAX is currently set to 132 and must be at least 12 for some of the */
+/* precomputed examples, and LWORK = NMAX*(5*NMAX+20) in the parameter */
+/* statements below. For SVD, we assume NRHS may be as big as N. The */
+/* parameter NEED is set to 14 to allow for 14 N-by-N matrices for ZGG. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ s1 = dsecnd_();
+ fatal = FALSE_;
+ infoc_1.nunit = 6;
+
+/* Return to here to read multiple sets of data */
+
+L10:
+
+/* Read the first line and set the 3-character test path */
+
+ ci__1.cierr = 0;
+ ci__1.ciend = 1;
+ ci__1.ciunit = 5;
+ ci__1.cifmt = "(A80)";
+ i__1 = s_rsfe(&ci__1);
+ if (i__1 != 0) {
+ goto L380;
+ }
+ i__1 = do_fio(&c__1, line, (ftnlen)80);
+ if (i__1 != 0) {
+ goto L380;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L380;
+ }
+ s_copy(path, line, (ftnlen)3, (ftnlen)3);
+ nep = lsamen_(&c__3, path, "NEP") || lsamen_(&c__3,
+ path, "ZHS");
+ sep = lsamen_(&c__3, path, "SEP") || lsamen_(&c__3,
+ path, "ZST") || lsamen_(&c__3, path, "ZSG");
+ svd = lsamen_(&c__3, path, "SVD") || lsamen_(&c__3,
+ path, "ZBD");
+ zev = lsamen_(&c__3, path, "ZEV");
+ zes = lsamen_(&c__3, path, "ZES");
+ zvx = lsamen_(&c__3, path, "ZVX");
+ zsx = lsamen_(&c__3, path, "ZSX");
+ zgg = lsamen_(&c__3, path, "ZGG");
+ zgs = lsamen_(&c__3, path, "ZGS");
+ zgx = lsamen_(&c__3, path, "ZGX");
+ zgv = lsamen_(&c__3, path, "ZGV");
+ zxv = lsamen_(&c__3, path, "ZXV");
+ zhb = lsamen_(&c__3, path, "ZHB");
+ zbb = lsamen_(&c__3, path, "ZBB");
+ glm = lsamen_(&c__3, path, "GLM");
+ gqr = lsamen_(&c__3, path, "GQR") || lsamen_(&c__3,
+ path, "GRQ");
+ gsv = lsamen_(&c__3, path, "GSV");
+ lse = lsamen_(&c__3, path, "LSE");
+ zbl = lsamen_(&c__3, path, "ZBL");
+ zbk = lsamen_(&c__3, path, "ZBK");
+ zgl = lsamen_(&c__3, path, "ZGL");
+ zgk = lsamen_(&c__3, path, "ZGK");
+
+/* Report values of parameters. */
+
+ if (s_cmp(path, " ", (ftnlen)3, (ftnlen)3) == 0) {
+ goto L10;
+ } else if (nep) {
+ s_wsfe(&io___29);
+ e_wsfe();
+ } else if (sep) {
+ s_wsfe(&io___30);
+ e_wsfe();
+ } else if (svd) {
+ s_wsfe(&io___31);
+ e_wsfe();
+ } else if (zev) {
+ s_wsfe(&io___32);
+ e_wsfe();
+ } else if (zes) {
+ s_wsfe(&io___33);
+ e_wsfe();
+ } else if (zvx) {
+ s_wsfe(&io___34);
+ e_wsfe();
+ } else if (zsx) {
+ s_wsfe(&io___35);
+ e_wsfe();
+ } else if (zgg) {
+ s_wsfe(&io___36);
+ e_wsfe();
+ } else if (zgs) {
+ s_wsfe(&io___37);
+ e_wsfe();
+ } else if (zgx) {
+ s_wsfe(&io___38);
+ e_wsfe();
+ } else if (zgv) {
+ s_wsfe(&io___39);
+ e_wsfe();
+ } else if (zxv) {
+ s_wsfe(&io___40);
+ e_wsfe();
+ } else if (zhb) {
+ s_wsfe(&io___41);
+ e_wsfe();
+ } else if (zbb) {
+ s_wsfe(&io___42);
+ e_wsfe();
+ } else if (glm) {
+ s_wsfe(&io___43);
+ e_wsfe();
+ } else if (gqr) {
+ s_wsfe(&io___44);
+ e_wsfe();
+ } else if (gsv) {
+ s_wsfe(&io___45);
+ e_wsfe();
+ } else if (lse) {
+ s_wsfe(&io___46);
+ e_wsfe();
+ } else if (zbl) {
+
+/* ZGEBAL: Balancing */
+
+ zchkbl_(&c__5, &c__6);
+ goto L380;
+ } else if (zbk) {
+
+/* ZGEBAK: Back transformation */
+
+ zchkbk_(&c__5, &c__6);
+ goto L380;
+ } else if (zgl) {
+
+/* ZGGBAL: Balancing */
+
+ zchkgl_(&c__5, &c__6);
+ goto L380;
+ } else if (zgk) {
+
+/* ZGGBAK: Back transformation */
+
+ zchkgk_(&c__5, &c__6);
+ goto L380;
+ } else if (lsamen_(&c__3, path, "ZEC")) {
+
+/* ZEC: Eigencondition estimation */
+
+ s_rsle(&io___47);
+ do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_rsle();
+ xlaenv_(&c__1, &c__1);
+ tsterr = TRUE_;
+ zchkec_(&thresh, &tsterr, &c__5, &c__6);
+ goto L380;
+ } else {
+ s_wsfe(&io___50);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ goto L380;
+ }
+ ilaver_(&vers_major__, &vers_minor__, &vers_patch__);
+ s_wsfe(&io___54);
+ do_fio(&c__1, (char *)&vers_major__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_minor__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_patch__, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___55);
+ e_wsfe();
+
+/* Read the number of values of M, P, and N. */
+
+ s_rsle(&io___56);
+ do_lio(&c__3, &c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nn < 0) {
+ s_wsfe(&io___58);
+ do_fio(&c__1, " NN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ } else if (nn > 20) {
+ s_wsfe(&io___59);
+ do_fio(&c__1, " NN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__20, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ }
+
+/* Read the values of M */
+
+ if (! (zgx || zxv)) {
+ s_rsle(&io___60);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ if (svd) {
+ s_copy(vname, " M ", (ftnlen)32, (ftnlen)6);
+ } else {
+ s_copy(vname, " N ", (ftnlen)32, (ftnlen)6);
+ }
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (mval[i__ - 1] < 0) {
+ s_wsfe(&io___64);
+ do_fio(&c__1, vname, (ftnlen)32);
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (mval[i__ - 1] > 132) {
+ s_wsfe(&io___65);
+ do_fio(&c__1, vname, (ftnlen)32);
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L20: */
+ }
+ s_wsfe(&io___66);
+ do_fio(&c__1, "M: ", (ftnlen)6);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of P */
+
+ if (glm || gqr || gsv || lse) {
+ s_rsle(&io___67);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&pval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (pval[i__ - 1] < 0) {
+ s_wsfe(&io___69);
+ do_fio(&c__1, " P ", (ftnlen)4);
+ do_fio(&c__1, (char *)&pval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (pval[i__ - 1] > 132) {
+ s_wsfe(&io___70);
+ do_fio(&c__1, " P ", (ftnlen)4);
+ do_fio(&c__1, (char *)&pval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L30: */
+ }
+ s_wsfe(&io___71);
+ do_fio(&c__1, "P: ", (ftnlen)6);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&pval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of N */
+
+ if (svd || zbb || glm || gqr || gsv || lse) {
+ s_rsle(&io___72);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nval[i__ - 1] < 0) {
+ s_wsfe(&io___74);
+ do_fio(&c__1, " N ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nval[i__ - 1] > 132) {
+ s_wsfe(&io___75);
+ do_fio(&c__1, " N ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L40: */
+ }
+ } else {
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nval[i__ - 1] = mval[i__ - 1];
+/* L50: */
+ }
+ }
+ if (! (zgx || zxv)) {
+ s_wsfe(&io___76);
+ do_fio(&c__1, "N: ", (ftnlen)6);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ } else {
+ s_wsfe(&io___77);
+ do_fio(&c__1, "N: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Read the number of values of K, followed by the values of K */
+
+ if (zhb || zbb) {
+ s_rsle(&io___78);
+ do_lio(&c__3, &c__1, (char *)&nk, (ftnlen)sizeof(integer));
+ e_rsle();
+ s_rsle(&io___80);
+ i__1 = nk;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&kval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nk;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (kval[i__ - 1] < 0) {
+ s_wsfe(&io___82);
+ do_fio(&c__1, " K ", (ftnlen)6);
+ do_fio(&c__1, (char *)&kval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (kval[i__ - 1] > 132) {
+ s_wsfe(&io___83);
+ do_fio(&c__1, " K ", (ftnlen)6);
+ do_fio(&c__1, (char *)&kval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L60: */
+ }
+ s_wsfe(&io___84);
+ do_fio(&c__1, "K: ", (ftnlen)6);
+ i__1 = nk;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&kval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+ if (zev || zes || zvx || zsx) {
+
+/* For the nonsymmetric QR driver routines, only one set of */
+/* parameters is allowed. */
+
+ s_rsle(&io___85);
+ do_lio(&c__3, &c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&inmin[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&inwin[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&inibl[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ishfts[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&iacc22[0], (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nbval[0] < 1) {
+ s_wsfe(&io___94);
+ do_fio(&c__1, " NB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nbmin[0] < 1) {
+ s_wsfe(&io___95);
+ do_fio(&c__1, "NBMIN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nxval[0] < 1) {
+ s_wsfe(&io___96);
+ do_fio(&c__1, " NX ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (inmin[0] < 1) {
+ s_wsfe(&io___97);
+ do_fio(&c__1, " INMIN ", (ftnlen)9);
+ do_fio(&c__1, (char *)&inmin[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (inwin[0] < 1) {
+ s_wsfe(&io___98);
+ do_fio(&c__1, " INWIN ", (ftnlen)9);
+ do_fio(&c__1, (char *)&inwin[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (inibl[0] < 1) {
+ s_wsfe(&io___99);
+ do_fio(&c__1, " INIBL ", (ftnlen)9);
+ do_fio(&c__1, (char *)&inibl[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (ishfts[0] < 1) {
+ s_wsfe(&io___100);
+ do_fio(&c__1, " ISHFTS ", (ftnlen)10);
+ do_fio(&c__1, (char *)&ishfts[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (iacc22[0] < 0) {
+ s_wsfe(&io___101);
+ do_fio(&c__1, " IACC22 ", (ftnlen)10);
+ do_fio(&c__1, (char *)&iacc22[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+ xlaenv_(&c__1, nbval);
+ xlaenv_(&c__2, nbmin);
+ xlaenv_(&c__3, nxval);
+ i__1 = max(11,inmin[0]);
+ xlaenv_(&c__12, &i__1);
+ xlaenv_(&c__13, inwin);
+ xlaenv_(&c__14, inibl);
+ xlaenv_(&c__15, ishfts);
+ xlaenv_(&c__16, iacc22);
+ s_wsfe(&io___102);
+ do_fio(&c__1, "NB: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___103);
+ do_fio(&c__1, "NBMIN:", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___104);
+ do_fio(&c__1, "NX: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___105);
+ do_fio(&c__1, "INMIN: ", (ftnlen)9);
+ do_fio(&c__1, (char *)&inmin[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___106);
+ do_fio(&c__1, "INWIN: ", (ftnlen)7);
+ do_fio(&c__1, (char *)&inwin[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___107);
+ do_fio(&c__1, "INIBL: ", (ftnlen)7);
+ do_fio(&c__1, (char *)&inibl[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___108);
+ do_fio(&c__1, "ISHFTS: ", (ftnlen)8);
+ do_fio(&c__1, (char *)&ishfts[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___109);
+ do_fio(&c__1, "IACC22: ", (ftnlen)8);
+ do_fio(&c__1, (char *)&iacc22[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ } else if (zgs || zgx || zgv || zxv) {
+
+/* For the nonsymmetric generalized driver routines, only one set of */
+/* parameters is allowed. */
+
+ s_rsle(&io___110);
+ do_lio(&c__3, &c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&nsval[0], (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&mxbval[0], (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nbval[0] < 1) {
+ s_wsfe(&io___113);
+ do_fio(&c__1, " NB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nbmin[0] < 1) {
+ s_wsfe(&io___114);
+ do_fio(&c__1, "NBMIN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nxval[0] < 1) {
+ s_wsfe(&io___115);
+ do_fio(&c__1, " NX ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nsval[0] < 2) {
+ s_wsfe(&io___116);
+ do_fio(&c__1, " NS ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nsval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (mxbval[0] < 1) {
+ s_wsfe(&io___117);
+ do_fio(&c__1, " MAXB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&mxbval[0], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+ xlaenv_(&c__1, nbval);
+ xlaenv_(&c__2, nbmin);
+ xlaenv_(&c__3, nxval);
+ xlaenv_(&c__4, nsval);
+ xlaenv_(&c__8, mxbval);
+ s_wsfe(&io___118);
+ do_fio(&c__1, "NB: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___119);
+ do_fio(&c__1, "NBMIN:", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___120);
+ do_fio(&c__1, "NX: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___121);
+ do_fio(&c__1, "NS: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nsval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___122);
+ do_fio(&c__1, "MAXB: ", (ftnlen)6);
+ do_fio(&c__1, (char *)&mxbval[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (! zhb && ! glm && ! gqr && ! gsv && ! lse) {
+
+/* For the other paths, the number of parameters can be varied */
+/* from the input file. Read the number of parameter values. */
+
+ s_rsle(&io___123);
+ do_lio(&c__3, &c__1, (char *)&nparms, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nparms < 1) {
+ s_wsfe(&io___125);
+ do_fio(&c__1, "NPARMS", (ftnlen)6);
+ do_fio(&c__1, (char *)&nparms, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nparms = 0;
+ fatal = TRUE_;
+ } else if (nparms > 20) {
+ s_wsfe(&io___126);
+ do_fio(&c__1, "NPARMS", (ftnlen)6);
+ do_fio(&c__1, (char *)&nparms, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__20, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nparms = 0;
+ fatal = TRUE_;
+ }
+
+/* Read the values of NB */
+
+ if (! zbb) {
+ s_rsle(&io___127);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nbval[i__ - 1] < 0) {
+ s_wsfe(&io___128);
+ do_fio(&c__1, " NB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nbval[i__ - 1] > 132) {
+ s_wsfe(&io___129);
+ do_fio(&c__1, " NB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L70: */
+ }
+ s_wsfe(&io___130);
+ do_fio(&c__1, "NB: ", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ }
+
+/* Read the values of NBMIN */
+
+ if (nep || sep || svd || zgg) {
+ s_rsle(&io___131);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nbmin[i__ - 1] < 0) {
+ s_wsfe(&io___132);
+ do_fio(&c__1, "NBMIN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nbmin[i__ - 1] > 132) {
+ s_wsfe(&io___133);
+ do_fio(&c__1, "NBMIN ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L80: */
+ }
+ s_wsfe(&io___134);
+ do_fio(&c__1, "NBMIN:", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nbmin[i__ - 1] = 1;
+/* L90: */
+ }
+ }
+
+/* Read the values of NX */
+
+ if (nep || sep || svd) {
+ s_rsle(&io___135);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nxval[i__ - 1] < 0) {
+ s_wsfe(&io___136);
+ do_fio(&c__1, " NX ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nxval[i__ - 1] > 132) {
+ s_wsfe(&io___137);
+ do_fio(&c__1, " NX ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L100: */
+ }
+ s_wsfe(&io___138);
+ do_fio(&c__1, "NX: ", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nxval[i__ - 1] = 1;
+/* L110: */
+ }
+ }
+
+/* Read the values of NSHIFT (if ZGG) or NRHS (if SVD */
+/* or ZBB). */
+
+ if (svd || zbb || zgg) {
+ s_rsle(&io___139);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nsval[i__ - 1] < 0) {
+ s_wsfe(&io___140);
+ do_fio(&c__1, " NS ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nsval[i__ - 1] > 132) {
+ s_wsfe(&io___141);
+ do_fio(&c__1, " NS ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L120: */
+ }
+ s_wsfe(&io___142);
+ do_fio(&c__1, "NS: ", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nsval[i__ - 1] = 1;
+/* L130: */
+ }
+ }
+
+/* Read the values for MAXB. */
+
+ if (zgg) {
+ s_rsle(&io___143);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (mxbval[i__ - 1] < 0) {
+ s_wsfe(&io___144);
+ do_fio(&c__1, " MAXB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (mxbval[i__ - 1] > 132) {
+ s_wsfe(&io___145);
+ do_fio(&c__1, " MAXB ", (ftnlen)6);
+ do_fio(&c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L140: */
+ }
+ s_wsfe(&io___146);
+ do_fio(&c__1, "MAXB: ", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ mxbval[i__ - 1] = 1;
+/* L150: */
+ }
+ }
+
+/* Read the values for INMIN. */
+
+ if (nep) {
+ s_rsle(&io___147);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&inmin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (inmin[i__ - 1] < 0) {
+ s_wsfe(&io___148);
+ do_fio(&c__1, " INMIN ", (ftnlen)7);
+ do_fio(&c__1, (char *)&inmin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L540: */
+ }
+ s_wsfe(&io___149);
+ do_fio(&c__1, "INMIN: ", (ftnlen)7);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&inmin[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ inmin[i__ - 1] = 1;
+/* L550: */
+ }
+ }
+
+/* Read the values for INWIN. */
+
+ if (nep) {
+ s_rsle(&io___150);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&inwin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (inwin[i__ - 1] < 0) {
+ s_wsfe(&io___151);
+ do_fio(&c__1, " INWIN ", (ftnlen)7);
+ do_fio(&c__1, (char *)&inwin[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L560: */
+ }
+ s_wsfe(&io___152);
+ do_fio(&c__1, "INWIN: ", (ftnlen)7);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&inwin[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ inwin[i__ - 1] = 1;
+/* L570: */
+ }
+ }
+
+/* Read the values for INIBL. */
+
+ if (nep) {
+ s_rsle(&io___153);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&inibl[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (inibl[i__ - 1] < 0) {
+ s_wsfe(&io___154);
+ do_fio(&c__1, " INIBL ", (ftnlen)7);
+ do_fio(&c__1, (char *)&inibl[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L580: */
+ }
+ s_wsfe(&io___155);
+ do_fio(&c__1, "INIBL: ", (ftnlen)7);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&inibl[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ inibl[i__ - 1] = 1;
+/* L590: */
+ }
+ }
+
+/* Read the values for ISHFTS. */
+
+ if (nep) {
+ s_rsle(&io___156);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&ishfts[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (ishfts[i__ - 1] < 0) {
+ s_wsfe(&io___157);
+ do_fio(&c__1, " ISHFTS ", (ftnlen)8);
+ do_fio(&c__1, (char *)&ishfts[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L600: */
+ }
+ s_wsfe(&io___158);
+ do_fio(&c__1, "ISHFTS: ", (ftnlen)8);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&ishfts[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ishfts[i__ - 1] = 1;
+/* L610: */
+ }
+ }
+
+/* Read the values for IACC22. */
+
+ if (nep) {
+ s_rsle(&io___159);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&iacc22[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (iacc22[i__ - 1] < 0) {
+ s_wsfe(&io___160);
+ do_fio(&c__1, " IACC22 ", (ftnlen)8);
+ do_fio(&c__1, (char *)&iacc22[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L620: */
+ }
+ s_wsfe(&io___161);
+ do_fio(&c__1, "IACC22: ", (ftnlen)8);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&iacc22[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ iacc22[i__ - 1] = 1;
+/* L630: */
+ }
+ }
+
+/* Read the values for NBCOL. */
+
+ if (zgg) {
+ s_rsle(&io___162);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nbcol[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nbcol[i__ - 1] < 0) {
+ s_wsfe(&io___164);
+ do_fio(&c__1, "NBCOL ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbcol[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nbcol[i__ - 1] > 132) {
+ s_wsfe(&io___165);
+ do_fio(&c__1, "NBCOL ", (ftnlen)6);
+ do_fio(&c__1, (char *)&nbcol[i__ - 1], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L160: */
+ }
+ s_wsfe(&io___166);
+ do_fio(&c__1, "NBCOL:", (ftnlen)6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nbcol[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_wsfe();
+ } else {
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nbcol[i__ - 1] = 1;
+/* L170: */
+ }
+ }
+ }
+
+/* Calculate and print the machine dependent constants. */
+
+ s_wsle(&io___167);
+ e_wsle();
+ eps = dlamch_("Underflow threshold");
+ s_wsfe(&io___169);
+ do_fio(&c__1, "underflow", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ eps = dlamch_("Overflow threshold");
+ s_wsfe(&io___170);
+ do_fio(&c__1, "overflow ", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ eps = dlamch_("Epsilon");
+ s_wsfe(&io___171);
+ do_fio(&c__1, "precision", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+/* Read the threshold value for the test ratios. */
+
+ s_rsle(&io___172);
+ do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_rsle();
+ s_wsfe(&io___173);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ if (sep || svd || zgg) {
+
+/* Read the flag that indicates whether to test LAPACK routines. */
+
+ s_rsle(&io___174);
+ do_lio(&c__8, &c__1, (char *)&tstchk, (ftnlen)sizeof(logical));
+ e_rsle();
+
+/* Read the flag that indicates whether to test driver routines. */
+
+ s_rsle(&io___176);
+ do_lio(&c__8, &c__1, (char *)&tstdrv, (ftnlen)sizeof(logical));
+ e_rsle();
+ }
+
+/* Read the flag that indicates whether to test the error exits. */
+
+ s_rsle(&io___178);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+
+/* Read the code describing how to set the random number seed. */
+
+ s_rsle(&io___179);
+ do_lio(&c__3, &c__1, (char *)&newsd, (ftnlen)sizeof(integer));
+ e_rsle();
+
+/* If NEWSD = 2, read another line with 4 integers for the seed. */
+
+ if (newsd == 2) {
+ s_rsle(&io___181);
+ for (i__ = 1; i__ <= 4; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&ioldsd[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ }
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = ioldsd[i__ - 1];
+/* L180: */
+ }
+
+ if (fatal) {
+ s_wsfe(&io___183);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Read the input lines indicating the test path and its parameters. */
+/* The first three characters indicate the test path, and the number */
+/* of test matrix types must be the first nonblank item in columns */
+/* 4-80. */
+
+L190:
+
+ if (! (zgx || zxv)) {
+
+L200:
+ ci__1.cierr = 0;
+ ci__1.ciend = 1;
+ ci__1.ciunit = 5;
+ ci__1.cifmt = "(A80)";
+ i__1 = s_rsfe(&ci__1);
+ if (i__1 != 0) {
+ goto L380;
+ }
+ i__1 = do_fio(&c__1, line, (ftnlen)80);
+ if (i__1 != 0) {
+ goto L380;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L380;
+ }
+ s_copy(c3, line, (ftnlen)3, (ftnlen)3);
+ lenp = i_len(line, (ftnlen)80);
+ i__ = 3;
+ itmp = 0;
+ i1 = 0;
+L210:
+ ++i__;
+ if (i__ > lenp) {
+ if (i1 > 0) {
+ goto L240;
+ } else {
+ ntypes = 30;
+ goto L240;
+ }
+ }
+ if (*(unsigned char *)&line[i__ - 1] != ' ' && *(unsigned char *)&
+ line[i__ - 1] != ',') {
+ i1 = i__;
+ *(unsigned char *)c1 = *(unsigned char *)&line[i1 - 1];
+
+/* Check that a valid integer was read */
+
+ for (k = 1; k <= 10; ++k) {
+ if (*(unsigned char *)c1 == *(unsigned char *)&intstr[k - 1])
+ {
+ ic = k - 1;
+ goto L230;
+ }
+/* L220: */
+ }
+ s_wsfe(&io___192);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, line, (ftnlen)80);
+ e_wsfe();
+ goto L200;
+L230:
+ itmp = itmp * 10 + ic;
+ goto L210;
+ } else if (i1 > 0) {
+ goto L240;
+ } else {
+ goto L210;
+ }
+L240:
+ ntypes = itmp;
+
+/* Skip the tests if NTYPES is <= 0. */
+
+ if (! (zev || zes || zvx || zsx || zgv || zgs) && ntypes <= 0) {
+ s_wsfe(&io___193);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ goto L200;
+ }
+
+ } else {
+ if (zgx) {
+ s_copy(c3, "ZGX", (ftnlen)3, (ftnlen)3);
+ }
+ if (zxv) {
+ s_copy(c3, "ZXV", (ftnlen)3, (ftnlen)3);
+ }
+ }
+
+/* Reset the random number seed. */
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L250: */
+ }
+ }
+
+ if (lsamen_(&c__3, c3, "ZHS") || lsamen_(&c__3, c3,
+ "NEP")) {
+
+/* ------------------------------------- */
+/* NEP: Nonsymmetric Eigenvalue Problem */
+/* ------------------------------------- */
+/* Vary the parameters */
+/* NB = block size */
+/* NBMIN = minimum block size */
+/* NX = crossover point */
+/* NS = number of shifts */
+/* MAXB = minimum submatrix size */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ xlaenv_(&c__1, &c__1);
+ if (tsterr) {
+ zerrhs_("ZHSEQR", &c__6);
+ }
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xlaenv_(&c__1, &nbval[i__ - 1]);
+ xlaenv_(&c__2, &nbmin[i__ - 1]);
+ xlaenv_(&c__3, &nxval[i__ - 1]);
+/* Computing MAX */
+ i__3 = 11, i__4 = inmin[i__ - 1];
+ i__2 = max(i__3,i__4);
+ xlaenv_(&c__12, &i__2);
+ xlaenv_(&c__13, &inwin[i__ - 1]);
+ xlaenv_(&c__14, &inibl[i__ - 1]);
+ xlaenv_(&c__15, &ishfts[i__ - 1]);
+ xlaenv_(&c__16, &iacc22[i__ - 1]);
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L260: */
+ }
+ }
+ s_wsfe(&io___196);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+/* Computing MAX */
+ i__3 = 11, i__4 = inmin[i__ - 1];
+ i__2 = max(i__3,i__4);
+ do_fio(&c__1, (char *)&i__2, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&inwin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&inibl[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ishfts[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iacc22[i__ - 1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ zchkhs_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &a[17424], &a[34848], &a[52272], &a[69696], &
+ c__132, &a[87120], &a[104544], dc, &dc[132], &a[121968], &
+ a[139392], &a[156816], &a[174240], &a[191664], &dc[264],
+ work, &c__89760, rwork, iwork, logwrk, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___205);
+ do_fio(&c__1, "ZCHKHS", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L270: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "ZST") || lsamen_(&
+ c__3, c3, "SEP")) {
+
+/* ---------------------------------- */
+/* SEP: Symmetric Eigenvalue Problem */
+/* ---------------------------------- */
+/* Vary the parameters */
+/* NB = block size */
+/* NBMIN = minimum block size */
+/* NX = crossover point */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ xlaenv_(&c__1, &c__1);
+ xlaenv_(&c__9, &c__25);
+ if (tsterr) {
+ zerrst_("ZST", &c__6);
+ }
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xlaenv_(&c__1, &nbval[i__ - 1]);
+ xlaenv_(&c__2, &nbmin[i__ - 1]);
+ xlaenv_(&c__3, &nxval[i__ - 1]);
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L280: */
+ }
+ }
+ s_wsfe(&io___206);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ if (tstchk) {
+ zchkst_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &c__6, a,
+ &c__132, &a[17424], dr, &dr[132], &dr[264], &dr[396],
+ &dr[528], &dr[660], &dr[792], &dr[924], &dr[1056], &
+ dr[1188], &dr[1320], &a[34848], &c__132, &a[52272], &
+ a[69696], dc, &a[87120], work, &c__89760, rwork, &
+ c__89760, iwork, &c__20064, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___208);
+ do_fio(&c__1, "ZCHKST", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ if (tstdrv) {
+ zdrvst_(&nn, nval, &c__18, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &dr[264], &dr[396], &dr[528], &dr[924], &dr[
+ 1056], &dr[1188], &a[17424], &c__132, &a[34848], dc, &
+ a[52272], work, &c__89760, rwork, &c__89760, iwork, &
+ c__20064, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___209);
+ do_fio(&c__1, "ZDRVST", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+/* L290: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "ZSG")) {
+
+/* ---------------------------------------------- */
+/* ZSG: Hermitian Generalized Eigenvalue Problem */
+/* ---------------------------------------------- */
+/* Vary the parameters */
+/* NB = block size */
+/* NBMIN = minimum block size */
+/* NX = crossover point */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ xlaenv_(&c__9, &c__25);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xlaenv_(&c__1, &nbval[i__ - 1]);
+ xlaenv_(&c__2, &nbmin[i__ - 1]);
+ xlaenv_(&c__3, &nxval[i__ - 1]);
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L300: */
+ }
+ }
+ s_wsfe(&io___210);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ if (tstchk) {
+ zdrvsg_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &c__6, a,
+ &c__132, &a[17424], &c__132, &dr[264], &a[34848], &
+ c__132, &a[52272], &a[69696], &a[87120], &a[104544],
+ work, &c__89760, rwork, &c__89760, iwork, &c__20064,
+ result, &info);
+ if (info != 0) {
+ s_wsfe(&io___211);
+ do_fio(&c__1, "ZDRVSG", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+/* L310: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "ZBD") || lsamen_(&
+ c__3, c3, "SVD")) {
+
+/* ---------------------------------- */
+/* SVD: Singular Value Decomposition */
+/* ---------------------------------- */
+/* Vary the parameters */
+/* NB = block size */
+/* NBMIN = minimum block size */
+/* NX = crossover point */
+/* NRHS = number of right hand sides */
+
+ maxtyp = 16;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ xlaenv_(&c__9, &c__25);
+
+/* Test the error exits */
+
+ xlaenv_(&c__1, &c__1);
+ if (tsterr && tstchk) {
+ zerrbd_("ZBD", &c__6);
+ }
+ if (tsterr && tstdrv) {
+ zerred_("ZBD", &c__6);
+ }
+
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nrhs = nsval[i__ - 1];
+ xlaenv_(&c__1, &nbval[i__ - 1]);
+ xlaenv_(&c__2, &nbmin[i__ - 1]);
+ xlaenv_(&c__3, &nxval[i__ - 1]);
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L320: */
+ }
+ }
+ s_wsfe(&io___213);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(integer));
+ e_wsfe();
+ if (tstchk) {
+ zchkbd_(&nn, mval, nval, &maxtyp, dotype, &nrhs, iseed, &
+ thresh, a, &c__132, dr, &dr[132], &dr[264], &dr[396],
+ &a[17424], &c__132, &a[34848], &a[52272], &a[69696], &
+ c__132, &a[87120], &c__132, &a[104544], &a[121968],
+ work, &c__89760, rwork, &c__6, &info);
+ if (info != 0) {
+ s_wsfe(&io___214);
+ do_fio(&c__1, "ZCHKBD", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ if (tstdrv) {
+ zdrvbd_(&nn, mval, nval, &maxtyp, dotype, iseed, &thresh, a, &
+ c__132, &a[17424], &c__132, &a[34848], &c__132, &a[
+ 52272], &a[69696], &a[87120], dr, &dr[132], &dr[264],
+ work, &c__89760, rwork, iwork, &c__6, &info);
+ }
+/* L330: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "ZEV")) {
+
+/* -------------------------------------------- */
+/* ZEV: Nonsymmetric Eigenvalue Problem Driver */
+/* ZGEEV (eigenvalues and eigenvectors) */
+/* -------------------------------------------- */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes <= 0) {
+ s_wsfe(&io___215);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ zerred_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ zdrvev_(&nn, nval, &ntypes, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &a[17424], dc, &dc[132], &a[34848], &c__132, &a[
+ 52272], &c__132, &a[69696], &c__132, result, work, &
+ c__89760, rwork, iwork, &info);
+ if (info != 0) {
+ s_wsfe(&io___216);
+ do_fio(&c__1, "ZGEEV", (ftnlen)5);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___217);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "ZES")) {
+
+/* -------------------------------------------- */
+/* ZES: Nonsymmetric Eigenvalue Problem Driver */
+/* ZGEES (Schur form) */
+/* -------------------------------------------- */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes <= 0) {
+ s_wsfe(&io___218);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ zerred_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ zdrves_(&nn, nval, &ntypes, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &a[17424], &a[34848], dc, &dc[132], &a[52272], &
+ c__132, result, work, &c__89760, rwork, iwork, logwrk, &
+ info);
+ if (info != 0) {
+ s_wsfe(&io___219);
+ do_fio(&c__1, "ZGEES", (ftnlen)5);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___220);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "ZVX")) {
+
+/* -------------------------------------------------------------- */
+/* ZVX: Nonsymmetric Eigenvalue Problem Expert Driver */
+/* ZGEEVX (eigenvalues, eigenvectors and condition numbers) */
+/* -------------------------------------------------------------- */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes < 0) {
+ s_wsfe(&io___221);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ zerred_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ zdrvvx_(&nn, nval, &ntypes, dotype, iseed, &thresh, &c__5, &c__6,
+ a, &c__132, &a[17424], dc, &dc[132], &a[34848], &c__132, &
+ a[52272], &c__132, &a[69696], &c__132, dr, &dr[132], &dr[
+ 264], &dr[396], &dr[528], &dr[660], &dr[792], &dr[924],
+ result, work, &c__89760, rwork, &info);
+ if (info != 0) {
+ s_wsfe(&io___222);
+ do_fio(&c__1, "ZGEEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___223);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "ZSX")) {
+
+/* --------------------------------------------------- */
+/* ZSX: Nonsymmetric Eigenvalue Problem Expert Driver */
+/* ZGEESX (Schur form and condition numbers) */
+/* --------------------------------------------------- */
+
+ maxtyp = 21;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes < 0) {
+ s_wsfe(&io___224);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ zerred_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ zdrvsx_(&nn, nval, &ntypes, dotype, iseed, &thresh, &c__5, &c__6,
+ a, &c__132, &a[17424], &a[34848], dc, &dc[132], &dc[264],
+ &a[52272], &c__132, &a[69696], result, work, &c__89760,
+ rwork, logwrk, &info);
+ if (info != 0) {
+ s_wsfe(&io___225);
+ do_fio(&c__1, "ZGEESX", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___226);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "ZGG")) {
+
+/* ------------------------------------------------- */
+/* ZGG: Generalized Nonsymmetric Eigenvalue Problem */
+/* ------------------------------------------------- */
+/* Vary the parameters */
+/* NB = block size */
+/* NBMIN = minimum block size */
+/* NS = number of shifts */
+/* MAXB = minimum submatrix size */
+/* NBCOL = minimum column dimension for blocks */
+
+ maxtyp = 26;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ if (tstchk && tsterr) {
+ zerrgg_(c3, &c__6);
+ }
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ xlaenv_(&c__1, &nbval[i__ - 1]);
+ xlaenv_(&c__2, &nbmin[i__ - 1]);
+ xlaenv_(&c__4, &nsval[i__ - 1]);
+ xlaenv_(&c__8, &mxbval[i__ - 1]);
+ xlaenv_(&c__5, &nbcol[i__ - 1]);
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L340: */
+ }
+ }
+ s_wsfe(&io___227);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbmin[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nbcol[i__ - 1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ tstdif = FALSE_;
+ thrshn = 10.;
+ if (tstchk) {
+ zchkgg_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &tstdif, &
+ thrshn, &c__6, a, &c__132, &a[17424], &a[34848], &a[
+ 52272], &a[69696], &a[87120], &a[104544], &a[121968],
+ &a[139392], &c__132, &a[156816], &a[174240], &a[
+ 191664], dc, &dc[132], &dc[264], &dc[396], &a[209088],
+ &a[226512], work, &c__89760, rwork, logwrk, result, &
+ info);
+ if (info != 0) {
+ s_wsfe(&io___230);
+ do_fio(&c__1, "ZCHKGG", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ xlaenv_(&c__1, &c__1);
+ if (tstdrv) {
+ zdrvgg_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &thrshn, &
+ c__6, a, &c__132, &a[17424], &a[34848], &a[52272], &a[
+ 69696], &a[87120], &a[104544], &c__132, &a[121968],
+ dc, &dc[132], &dc[264], &dc[396], &a[121968], &a[
+ 139392], work, &c__89760, rwork, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___231);
+ do_fio(&c__1, "ZDRVGG", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+/* L350: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "ZGS")) {
+
+/* ------------------------------------------------- */
+/* ZGS: Generalized Nonsymmetric Eigenvalue Problem */
+/* ZGGES (Schur form) */
+/* ------------------------------------------------- */
+
+ maxtyp = 26;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes <= 0) {
+ s_wsfe(&io___232);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ zerrgg_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ zdrges_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &a[17424], &a[34848], &a[52272], &a[104544], &
+ c__132, &a[121968], dc, &dc[132], work, &c__89760, rwork,
+ result, logwrk, &info);
+
+ if (info != 0) {
+ s_wsfe(&io___233);
+ do_fio(&c__1, "ZDRGES", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___234);
+ e_wsfe();
+ goto L10;
+
+ } else if (zgx) {
+
+/* ------------------------------------------------- */
+/* ZGX Generalized Nonsymmetric Eigenvalue Problem */
+/* ZGGESX (Schur form and condition numbers) */
+/* ------------------------------------------------- */
+
+ maxtyp = 5;
+ ntypes = maxtyp;
+ if (nn < 0) {
+ s_wsfe(&io___235);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ zerrgg_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ xlaenv_(&c__5, &c__2);
+ zdrgsx_(&nn, &c__20, &thresh, &c__5, &c__6, a, &c__132, &a[17424],
+ &a[34848], &a[52272], &a[69696], &a[87120], dc, &dc[132],
+ c__, &c__400, s, work, &c__89760, rwork, iwork, &
+ c__20064, logwrk, &info);
+ if (info != 0) {
+ s_wsfe(&io___238);
+ do_fio(&c__1, "ZDRGSX", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___239);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "ZGV")) {
+
+/* ------------------------------------------------- */
+/* ZGV: Generalized Nonsymmetric Eigenvalue Problem */
+/* ZGGEV (Eigenvalue/vector form) */
+/* ------------------------------------------------- */
+
+ maxtyp = 26;
+ ntypes = min(maxtyp,ntypes);
+ if (ntypes <= 0) {
+ s_wsfe(&io___240);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ zerrgg_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ zdrgev_(&nn, nval, &maxtyp, dotype, iseed, &thresh, &c__6, a, &
+ c__132, &a[17424], &a[34848], &a[52272], &a[104544], &
+ c__132, &a[121968], &a[139392], &c__132, dc, &dc[132], &
+ dc[264], &dc[396], work, &c__89760, rwork, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___241);
+ do_fio(&c__1, "ZDRGEV", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___242);
+ e_wsfe();
+ goto L10;
+
+ } else if (zxv) {
+
+/* ------------------------------------------------- */
+/* ZXV: Generalized Nonsymmetric Eigenvalue Problem */
+/* ZGGEVX (eigenvalue/vector with condition numbers) */
+/* ------------------------------------------------- */
+
+ maxtyp = 2;
+ ntypes = maxtyp;
+ if (nn < 0) {
+ s_wsfe(&io___243);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (tsterr) {
+ zerrgg_(c3, &c__6);
+ }
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ zdrgvx_(&nn, &thresh, &c__5, &c__6, a, &c__132, &a[17424], &a[
+ 34848], &a[52272], dc, &dc[132], &a[69696], &a[87120],
+ iwork, &iwork[1], dr, &dr[132], &dr[264], &dr[396], &dr[
+ 528], &dr[660], work, &c__89760, rwork, &iwork[2], &
+ c__20062, result, logwrk, &info);
+
+ if (info != 0) {
+ s_wsfe(&io___244);
+ do_fio(&c__1, "ZDRGVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+ s_wsfe(&io___245);
+ e_wsfe();
+ goto L10;
+
+ } else if (lsamen_(&c__3, c3, "ZHB")) {
+
+/* ------------------------------ */
+/* ZHB: Hermitian Band Reduction */
+/* ------------------------------ */
+
+ maxtyp = 15;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ if (tsterr) {
+ zerrst_("ZHB", &c__6);
+ }
+ zchkhb_(&nn, nval, &nk, kval, &maxtyp, dotype, iseed, &thresh, &c__6,
+ a, &c__132, dr, &dr[132], &a[17424], &c__132, work, &c__89760,
+ rwork, result, &info);
+ if (info != 0) {
+ s_wsfe(&io___246);
+ do_fio(&c__1, "ZCHKHB", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "ZBB")) {
+
+/* ------------------------------ */
+/* ZBB: General Band Reduction */
+/* ------------------------------ */
+
+ maxtyp = 15;
+ ntypes = min(maxtyp,ntypes);
+ alareq_(c3, &ntypes, dotype, &maxtyp, &c__5, &c__6);
+ i__1 = nparms;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nrhs = nsval[i__ - 1];
+
+ if (newsd == 0) {
+ for (k = 1; k <= 4; ++k) {
+ iseed[k - 1] = ioldsd[k - 1];
+/* L360: */
+ }
+ }
+ s_wsfe(&io___247);
+ do_fio(&c__1, c3, (ftnlen)3);
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(integer));
+ e_wsfe();
+ zchkbb_(&nn, mval, nval, &nk, kval, &maxtyp, dotype, &nrhs, iseed,
+ &thresh, &c__6, a, &c__132, &a[17424], &c__264, dr, &dr[
+ 132], &a[52272], &c__132, &a[69696], &c__132, &a[87120], &
+ c__132, &a[104544], work, &c__89760, rwork, result, &info)
+ ;
+ if (info != 0) {
+ s_wsfe(&io___248);
+ do_fio(&c__1, "ZCHKBB", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L370: */
+ }
+
+ } else if (lsamen_(&c__3, c3, "GLM")) {
+
+/* ----------------------------------------- */
+/* GLM: Generalized Linear Regression Model */
+/* ----------------------------------------- */
+
+ xlaenv_(&c__1, &c__1);
+ if (tsterr) {
+ zerrgg_("GLM", &c__6);
+ }
+ zckglm_(&nn, nval, mval, pval, &ntypes, iseed, &thresh, &c__132, a, &
+ a[17424], b, &b[17424], x, work, dr, &c__5, &c__6, &info);
+ if (info != 0) {
+ s_wsfe(&io___251);
+ do_fio(&c__1, "ZCKGLM", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "GQR")) {
+
+/* ------------------------------------------ */
+/* GQR: Generalized QR and RQ factorizations */
+/* ------------------------------------------ */
+
+ xlaenv_(&c__1, &c__1);
+ if (tsterr) {
+ zerrgg_("GQR", &c__6);
+ }
+ zckgqr_(&nn, mval, &nn, pval, &nn, nval, &ntypes, iseed, &thresh, &
+ c__132, a, &a[17424], &a[34848], &a[52272], taua, b, &b[17424]
+, &b[34848], &b[52272], &b[69696], taub, work, dr, &c__5, &
+ c__6, &info);
+ if (info != 0) {
+ s_wsfe(&io___254);
+ do_fio(&c__1, "ZCKGQR", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "GSV")) {
+
+/* ---------------------------------------------- */
+/* GSV: Generalized Singular Value Decomposition */
+/* ---------------------------------------------- */
+
+ if (tsterr) {
+ zerrgg_("GSV", &c__6);
+ }
+ zckgsv_(&nn, mval, pval, nval, &ntypes, iseed, &thresh, &c__132, a, &
+ a[17424], b, &b[17424], &a[34848], &b[34848], &a[52272],
+ alpha, beta, &b[52272], iwork, work, dr, &c__5, &c__6, &info);
+ if (info != 0) {
+ s_wsfe(&io___257);
+ do_fio(&c__1, "ZCKGSV", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "LSE")) {
+
+/* -------------------------------------- */
+/* LSE: Constrained Linear Least Squares */
+/* -------------------------------------- */
+
+ xlaenv_(&c__1, &c__1);
+ if (tsterr) {
+ zerrgg_("LSE", &c__6);
+ }
+ zcklse_(&nn, mval, pval, nval, &ntypes, iseed, &thresh, &c__132, a, &
+ a[17424], b, &b[17424], x, work, dr, &c__5, &c__6, &info);
+ if (info != 0) {
+ s_wsfe(&io___258);
+ do_fio(&c__1, "ZCKLSE", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ } else {
+ s_wsle(&io___259);
+ e_wsle();
+ s_wsle(&io___260);
+ e_wsle();
+ s_wsfe(&io___261);
+ do_fio(&c__1, c3, (ftnlen)3);
+ e_wsfe();
+ }
+ if (! (zgx || zxv)) {
+ goto L190;
+ }
+L380:
+ s_wsfe(&io___262);
+ e_wsfe();
+ s2 = dsecnd_();
+ s_wsfe(&io___264);
+ d__1 = s2 - s1;
+ do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+/* L9998: */
+
+/* End of ZCHKEE */
+
+ return 0;
+} /* MAIN__ */
+
+/* Main program alias */ int zchkee_ () { MAIN__ (); return 0; }
diff --git a/TESTING/EIG/zchkgg.c b/TESTING/EIG/zchkgg.c
new file mode 100644
index 0000000..bdb994f
--- /dev/null
+++ b/TESTING/EIG/zchkgg.c
@@ -0,0 +1,1549 @@
+/* zchkgg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__4 = 4;
+static doublereal c_b17 = 1.;
+static integer c__3 = 3;
+static integer c__1 = 1;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+static integer c__2 = 2;
+
+/* Subroutine */ int zchkgg_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, logical *tstdif,
+ doublereal *thrshn, integer *nounit, doublecomplex *a, integer *lda,
+ doublecomplex *b, doublecomplex *h__, doublecomplex *t, doublecomplex
+ *s1, doublecomplex *s2, doublecomplex *p1, doublecomplex *p2,
+ doublecomplex *u, integer *ldu, doublecomplex *v, doublecomplex *q,
+ doublecomplex *z__, doublecomplex *alpha1, doublecomplex *beta1,
+ doublecomplex *alpha3, doublecomplex *beta3, doublecomplex *evectl,
+ doublecomplex *evectr, doublecomplex *work, integer *lwork,
+ doublereal *rwork, logical *llwork, doublereal *result, integer *info)
+{
+ /* Initialized data */
+
+ static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
+ 2,2,2,3 };
+ static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
+ 2,3,2,1 };
+ static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
+ 1,1,1,1 };
+ static logical lasign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ TRUE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,FALSE_,
+ TRUE_,FALSE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_ };
+ static logical lbsign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ FALSE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,FALSE_,
+ TRUE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ FALSE_ };
+ static integer kz1[6] = { 0,1,2,1,3,3 };
+ static integer kz2[6] = { 0,0,1,2,1,1 };
+ static integer kadd[6] = { 0,0,0,0,3,2 };
+ static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
+ 4,4,4,0 };
+ static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
+ 8,8,8,8,8,0 };
+ static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
+ 3,3,3,1 };
+ static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
+ 4,4,4,1 };
+ static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
+ 3,3,2,1 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ZCHKGG: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 ZCHKGG: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
+ "i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9997[] = "(1x,a3,\002 -- Complex Generalized eigenvalue "
+ "problem\002)";
+ static char fmt_9996[] = "(\002 Matrix types (see ZCHKGG for details):"
+ " \002)";
+ static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
+ "osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
+ ") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
+ "onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
+ "I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
+ "arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
+ "(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
+ "=(D, reversed D)\002)";
+ static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
+ "atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
+ " 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
+ "ha&beta \002,\002 20=arithmetic alpha, beta=0,"
+ "1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
+ "=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
+ "/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
+ "l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
+ ".\002)";
+ static char fmt_9993[] = "(/\002 Tests performed: (H is Hessenberg, S "
+ "is Schur, B, \002,\002T, P are triangular,\002,/20x,\002U, V, Q,"
+ " and Z are \002,a,\002, l and r are the\002,/20x,\002appropriate"
+ " left and right eigenvectors, resp., a is\002,/20x,\002alpha, b "
+ "is beta, and \002,a,\002 means \002,a,\002.)\002,/\002 1 = | A -"
+ " U H V\002,a,\002 | / ( |A| n ulp ) 2 = | B - U T V\002,a"
+ ",\002 | / ( |B| n ulp )\002,/\002 3 = | I - UU\002,a,\002 | / ( "
+ "n ulp ) 4 = | I - VV\002,a,\002 | / ( n ulp )\002,"
+ "/\002 5 = | H - Q S Z\002,a,\002 | / ( |H| n ulp )\002,6x,\0026 "
+ "= | T - Q P Z\002,a,\002 | / ( |T| n ulp )\002,/\002 7 = | I - QQ"
+ "\002,a,\002 | / ( n ulp ) 8 = | I - ZZ\002,a,\002 | "
+ "/ ( n ulp )\002,/\002 9 = max | ( b S - a P )\002,a,\002 l | / c"
+ "onst. 10 = max | ( b H - a T )\002,a,\002 l | / const.\002,/"
+ "\002 11= max | ( b S - a P ) r | / const. 12 = max | ( b H\002,"
+ "\002 - a T ) r | / const.\002,/1x)";
+ static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",0p,f8.2)";
+ static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",1p,d10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, evectl_dim1, evectl_offset,
+ evectr_dim1, evectr_offset, h_dim1, h_offset, p1_dim1, p1_offset,
+ p2_dim1, p2_offset, q_dim1, q_offset, s1_dim1, s1_offset, s2_dim1,
+ s2_offset, t_dim1, t_offset, u_dim1, u_offset, v_dim1, v_offset,
+ z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *), z_abs(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer j, n, i1, n1, jc, in, jr;
+ doublereal ulp;
+ integer iadd, nmax;
+ doublereal temp1, temp2;
+ logical badnn;
+ doublereal dumma[4];
+ integer iinfo;
+ doublereal rmagn[4];
+ doublecomplex ctemp;
+ doublereal anorm, bnorm;
+ extern /* Subroutine */ int zget51_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *
+, doublecomplex *, integer *, doublecomplex *, doublereal *,
+ doublereal *), zget52_(logical *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
+ doublereal *);
+ integer nmats, jsize, nerrs, jtype, ntest;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), zgeqr2_(
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *), zlatm4_(integer *, integer *,
+ integer *, integer *, logical *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublecomplex cdumma[4];
+ doublereal safmin, safmax;
+ integer ioldsd[4];
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dlasum_(char *, integer *, integer *, integer
+ *), xerbla_(char *, integer *);
+ extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
+ integer *);
+ extern /* Subroutine */ int zgghrd_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+), zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *), zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), ztgevc_(char *, char *, logical *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ integer *, doublecomplex *, doublereal *, integer *), zhgeqz_(char *, char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *);
+ doublereal ulpinv;
+ integer lwkopt, mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___68 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___69 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___70 = { 0, 0, 0, fmt_9991, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKGG checks the nonsymmetric generalized eigenvalue problem */
+/* routines. */
+/* H H H */
+/* ZGGHRD factors A and B as U H V and U T V , where means conjugate */
+/* transpose, H is hessenberg, T is triangular and U and V are unitary. */
+
+/* H H */
+/* ZHGEQZ factors H and T as Q S Z and Q P Z , where P and S are upper */
+/* triangular and Q and Z are unitary. It also computes the generalized */
+/* eigenvalues (alpha(1),beta(1)),...,(alpha(n),beta(n)), where */
+/* alpha(j)=S(j,j) and beta(j)=P(j,j) -- thus, w(j) = alpha(j)/beta(j) */
+/* is a root of the generalized eigenvalue problem */
+
+/* det( A - w(j) B ) = 0 */
+
+/* and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent */
+/* problem */
+
+/* det( m(j) A - B ) = 0 */
+
+/* ZTGEVC computes the matrix L of left eigenvectors and the matrix R */
+/* of right eigenvectors for the matrix pair ( S, P ). In the */
+/* description below, l and r are left and right eigenvectors */
+/* corresponding to the generalized eigenvalues (alpha,beta). */
+
+/* When ZCHKGG is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 13 */
+/* tests will be performed. The first twelve "test ratios" should be */
+/* small -- O(1). They will be compared with the threshhold THRESH: */
+
+/* H */
+/* (1) | A - U H V | / ( |A| n ulp ) */
+
+/* H */
+/* (2) | B - U T V | / ( |B| n ulp ) */
+
+/* H */
+/* (3) | I - UU | / ( n ulp ) */
+
+/* H */
+/* (4) | I - VV | / ( n ulp ) */
+
+/* H */
+/* (5) | H - Q S Z | / ( |H| n ulp ) */
+
+/* H */
+/* (6) | T - Q P Z | / ( |T| n ulp ) */
+
+/* H */
+/* (7) | I - QQ | / ( n ulp ) */
+
+/* H */
+/* (8) | I - ZZ | / ( n ulp ) */
+
+/* (9) max over all left eigenvalue/-vector pairs (beta/alpha,l) of */
+/* H */
+/* | (beta A - alpha B) l | / ( ulp max( |beta A|, |alpha B| ) ) */
+
+/* (10) max over all left eigenvalue/-vector pairs (beta/alpha,l') of */
+/* H */
+/* | (beta H - alpha T) l' | / ( ulp max( |beta H|, |alpha T| ) ) */
+
+/* where the eigenvectors l' are the result of passing Q to */
+/* DTGEVC and back transforming (JOB='B'). */
+
+/* (11) max over all right eigenvalue/-vector pairs (beta/alpha,r) of */
+
+/* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) ) */
+
+/* (12) max over all right eigenvalue/-vector pairs (beta/alpha,r') of */
+
+/* | (beta H - alpha T) r' | / ( ulp max( |beta H|, |alpha T| ) ) */
+
+/* where the eigenvectors r' are the result of passing Z to */
+/* DTGEVC and back transforming (JOB='B'). */
+
+/* The last three test ratios will usually be small, but there is no */
+/* mathematical requirement that they be so. They are therefore */
+/* compared with THRESH only if TSTDIF is .TRUE. */
+
+/* (13) | S(Q,Z computed) - S(Q,Z not computed) | / ( |S| ulp ) */
+
+/* (14) | P(Q,Z computed) - P(Q,Z not computed) | / ( |P| ulp ) */
+
+/* (15) max( |alpha(Q,Z computed) - alpha(Q,Z not computed)|/|S| , */
+/* |beta(Q,Z computed) - beta(Q,Z not computed)|/|P| ) / ulp */
+
+/* In addition, the normalization of L and R are checked, and compared */
+/* with the threshhold THRSHN. */
+
+/* Test Matrices */
+/* ---- -------- */
+
+/* The sizes of the test matrices are specified by an array */
+/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
+/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) ( 0, 0 ) (a pair of zero matrices) */
+
+/* (2) ( I, 0 ) (an identity and a zero matrix) */
+
+/* (3) ( 0, I ) (an identity and a zero matrix) */
+
+/* (4) ( I, I ) (a pair of identity matrices) */
+
+/* t t */
+/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
+
+/* t ( I 0 ) */
+/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
+/* ( 0 I ) ( 0 J ) */
+/* and I is a k x k identity and J a (k+1)x(k+1) */
+/* Jordan block; k=(N-1)/2 */
+
+/* (7) ( D, I ) where D is P*D1, P is a random unitary diagonal */
+/* matrix (i.e., with random magnitude 1 entries */
+/* on the diagonal), and D1=diag( 0, 1,..., N-1 ) */
+/* (i.e., a diagonal matrix with D1(1,1)=0, */
+/* D1(2,2)=1, ..., D1(N,N)=N-1.) */
+/* (8) ( I, D ) */
+
+/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
+
+/* (10) ( small*D, big*I ) */
+
+/* (11) ( big*I, small*D ) */
+
+/* (12) ( small*I, big*D ) */
+
+/* (13) ( big*D, big*I ) */
+
+/* (14) ( small*D, small*I ) */
+
+/* (15) ( D1, D2 ) where D1=P*diag( 0, 0, 1, ..., N-3, 0 ) and */
+/* D2=Q*diag( 0, N-3, N-4,..., 1, 0, 0 ), and */
+/* P and Q are random unitary diagonal matrices. */
+/* t t */
+/* (16) U ( J , J ) V where U and V are random unitary matrices. */
+
+/* (17) U ( T1, T2 ) V where T1 and T2 are upper triangular matrices */
+/* with random O(1) entries above the diagonal */
+/* and diagonal entries diag(T1) = */
+/* P*( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
+/* Q*( 0, N-3, N-4,..., 1, 0, 0 ) */
+
+/* (18) U ( T1, T2 ) V diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
+/* s = machine precision. */
+
+/* (19) U ( T1, T2 ) V diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
+
+/* N-5 */
+/* (20) U ( T1, T2 ) V diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+
+/* (21) U ( T1, T2 ) V diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+/* where r1,..., r(N-4) are random. */
+
+/* (22) U ( big*T1, small*T2 ) V diag(T1) = P*( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (23) U ( small*T1, big*T2 ) V diag(T1) = P*( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (24) U ( small*T1, small*T2 ) V diag(T1) = P*( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (25) U ( big*T1, big*T2 ) V diag(T1) = P*( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (26) U ( T1, T2 ) V where T1 and T2 are random upper-triangular */
+/* matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* ZCHKGG does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, ZCHKGG */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to ZCHKGG to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* TSTDIF (input) LOGICAL */
+/* Specifies whether test ratios 13-15 will be computed and */
+/* compared with THRESH. */
+/* = .FALSE.: Only test ratios 1-12 will be computed and tested. */
+/* Ratios 13-15 will be set to zero. */
+/* = .TRUE.: All the test ratios 1-15 will be computed and */
+/* tested. */
+
+/* THRSHN (input) DOUBLE PRECISION */
+/* Threshhold for reporting eigenvector normalization error. */
+/* If the normalization of any eigenvector differs from 1 by */
+/* more than THRSHN*ulp, then a special error message will be */
+/* printed. (This is handled separately from the other tests, */
+/* since only a compiler or programming error should cause an */
+/* error message, at least if THRSHN is at least 5--10.) */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* Used to hold the original A matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, H, T, S1, P1, S2, and P2. */
+/* It must be at least 1 and at least max( NN ). */
+
+/* B (input/workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* Used to hold the original B matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* H (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* The upper Hessenberg matrix computed from A by ZGGHRD. */
+
+/* T (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from B by ZGGHRD. */
+
+/* S1 (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* The Schur (upper triangular) matrix computed from H by ZHGEQZ */
+/* when Q and Z are also computed. */
+
+/* S2 (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* The Schur (upper triangular) matrix computed from H by ZHGEQZ */
+/* when Q and Z are not computed. */
+
+/* P1 (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from T by ZHGEQZ */
+/* when Q and Z are also computed. */
+
+/* P2 (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from T by ZHGEQZ */
+/* when Q and Z are not computed. */
+
+/* U (workspace) COMPLEX*16 array, dimension (LDU, max(NN)) */
+/* The (left) unitary matrix computed by ZGGHRD. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U, V, Q, Z, EVECTL, and EVEZTR. It */
+/* must be at least 1 and at least max( NN ). */
+
+/* V (workspace) COMPLEX*16 array, dimension (LDU, max(NN)) */
+/* The (right) unitary matrix computed by ZGGHRD. */
+
+/* Q (workspace) COMPLEX*16 array, dimension (LDU, max(NN)) */
+/* The (left) unitary matrix computed by ZHGEQZ. */
+
+/* Z (workspace) COMPLEX*16 array, dimension (LDU, max(NN)) */
+/* The (left) unitary matrix computed by ZHGEQZ. */
+
+/* ALPHA1 (workspace) COMPLEX*16 array, dimension (max(NN)) */
+/* BETA1 (workspace) COMPLEX*16 array, dimension (max(NN)) */
+/* The generalized eigenvalues of (A,B) computed by ZHGEQZ */
+/* when Q, Z, and the full Schur matrices are computed. */
+
+/* ALPHA3 (workspace) COMPLEX*16 array, dimension (max(NN)) */
+/* BETA3 (workspace) COMPLEX*16 array, dimension (max(NN)) */
+/* The generalized eigenvalues of (A,B) computed by ZHGEQZ */
+/* when neither Q, Z, nor the Schur matrices are computed. */
+
+/* EVECTL (workspace) COMPLEX*16 array, dimension (LDU, max(NN)) */
+/* The (lower triangular) left eigenvector matrix for the */
+/* matrices in S1 and P1. */
+
+/* EVEZTR (workspace) COMPLEX*16 array, dimension (LDU, max(NN)) */
+/* The (upper triangular) right eigenvector matrix for the */
+/* matrices in S1 and P1. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* max( 4*N, 2 * N**2, 1 ), for all N=NN(j). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*max(NN)) */
+
+/* LLWORK (workspace) LOGICAL array, dimension (max(NN)) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (15) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: A routine returned an error code. INFO is the */
+/* absolute value of the INFO value returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ p2_dim1 = *lda;
+ p2_offset = 1 + p2_dim1;
+ p2 -= p2_offset;
+ p1_dim1 = *lda;
+ p1_offset = 1 + p1_dim1;
+ p1 -= p1_offset;
+ s2_dim1 = *lda;
+ s2_offset = 1 + s2_dim1;
+ s2 -= s2_offset;
+ s1_dim1 = *lda;
+ s1_offset = 1 + s1_dim1;
+ s1 -= s1_offset;
+ t_dim1 = *lda;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ evectr_dim1 = *ldu;
+ evectr_offset = 1 + evectr_dim1;
+ evectr -= evectr_offset;
+ evectl_dim1 = *ldu;
+ evectl_offset = 1 + evectl_dim1;
+ evectl -= evectl_offset;
+ z_dim1 = *ldu;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ q_dim1 = *ldu;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ v_dim1 = *ldu;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --alpha1;
+ --beta1;
+ --alpha3;
+ --beta3;
+ --work;
+ --rwork;
+ --llwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Computing MAX */
+ i__1 = (nmax << 1) * nmax, i__2 = nmax << 2, i__1 = max(i__1,i__2);
+ lwkopt = max(i__1,1);
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.) {
+ *info = -6;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -10;
+ } else if (*ldu <= 1 || *ldu < nmax) {
+ *info = -19;
+ } else if (lwkopt > *lwork) {
+ *info = -30;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZCHKGG", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+ safmin = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ safmin /= ulp;
+ safmax = 1. / safmin;
+ dlabad_(&safmin, &safmax);
+ ulpinv = 1. / ulp;
+
+/* The values RMAGN(2:3) depend on N, see below. */
+
+ rmagn[0] = 0.;
+ rmagn[1] = 1.;
+
+/* Loop over sizes, types */
+
+ ntestt = 0;
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ n1 = max(1,n);
+ rmagn[2] = safmax * ulp / (doublereal) n1;
+ rmagn[3] = safmin * ulpinv * n1;
+
+ if (*nsizes != 1) {
+ mtypes = min(26,*ntypes);
+ } else {
+ mtypes = min(27,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L230;
+ }
+ ++nmats;
+ ntest = 0;
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 15; ++j) {
+ result[j] = 0.;
+/* L30: */
+ }
+
+/* Compute A and B */
+
+/* Description of control parameters: */
+
+/* KZLASS: =1 means w/o rotation, =2 means w/ rotation, */
+/* =3 means random. */
+/* KATYPE: the "type" to be passed to ZLATM4 for computing A. */
+/* KAZERO: the pattern of zeros on the diagonal for A: */
+/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
+/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
+/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
+/* non-zero entries.) */
+/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
+/* =2: large, =3: small. */
+/* LASIGN: .TRUE. if the diagonal elements of A are to be */
+/* multiplied by a random magnitude 1 number. */
+/* KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B. */
+/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
+/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
+/* RMAGN: used to implement KAMAGN and KBMAGN. */
+
+ if (mtypes > 26) {
+ goto L110;
+ }
+ iinfo = 0;
+ if (kclass[jtype - 1] < 3) {
+
+/* Generate A (w/o rotation) */
+
+ if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ zlaset_("Full", &n, &n, &c_b1, &c_b1, &a[a_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ zlatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
+ &kz2[kazero[jtype - 1] - 1], &lasign[jtype - 1], &
+ rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
+ 1] * kamagn[jtype - 1]], &c__4, &iseed[1], &a[
+ a_offset], lda);
+ iadd = kadd[kazero[jtype - 1] - 1];
+ if (iadd > 0 && iadd <= n) {
+ i__3 = iadd + iadd * a_dim1;
+ i__4 = kamagn[jtype - 1];
+ a[i__3].r = rmagn[i__4], a[i__3].i = 0.;
+ }
+
+/* Generate B (w/o rotation) */
+
+ if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ zlaset_("Full", &n, &n, &c_b1, &c_b1, &b[b_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ zlatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
+ &kz2[kbzero[jtype - 1] - 1], &lbsign[jtype - 1], &
+ rmagn[kbmagn[jtype - 1]], &c_b17, &rmagn[ktrian[jtype
+ - 1] * kbmagn[jtype - 1]], &c__4, &iseed[1], &b[
+ b_offset], lda);
+ iadd = kadd[kbzero[jtype - 1] - 1];
+ if (iadd != 0) {
+ i__3 = iadd + iadd * b_dim1;
+ i__4 = kbmagn[jtype - 1];
+ b[i__3].r = rmagn[i__4], b[i__3].i = 0.;
+ }
+
+ if (kclass[jtype - 1] == 2 && n > 0) {
+
+/* Include rotations */
+
+/* Generate U, V as Householder transformations times a */
+/* diagonal matrix. (Note that ZLARFG makes U(j,j) and */
+/* V(j,j) real.) */
+
+ i__3 = n - 1;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = jc; jr <= i__4; ++jr) {
+ i__5 = jr + jc * u_dim1;
+ zlarnd_(&z__1, &c__3, &iseed[1]);
+ u[i__5].r = z__1.r, u[i__5].i = z__1.i;
+ i__5 = jr + jc * v_dim1;
+ zlarnd_(&z__1, &c__3, &iseed[1]);
+ v[i__5].r = z__1.r, v[i__5].i = z__1.i;
+/* L40: */
+ }
+ i__4 = n + 1 - jc;
+ zlarfg_(&i__4, &u[jc + jc * u_dim1], &u[jc + 1 + jc *
+ u_dim1], &c__1, &work[jc]);
+ i__4 = (n << 1) + jc;
+ i__5 = jc + jc * u_dim1;
+ d__2 = u[i__5].r;
+ d__1 = d_sign(&c_b17, &d__2);
+ work[i__4].r = d__1, work[i__4].i = 0.;
+ i__4 = jc + jc * u_dim1;
+ u[i__4].r = 1., u[i__4].i = 0.;
+ i__4 = n + 1 - jc;
+ zlarfg_(&i__4, &v[jc + jc * v_dim1], &v[jc + 1 + jc *
+ v_dim1], &c__1, &work[n + jc]);
+ i__4 = n * 3 + jc;
+ i__5 = jc + jc * v_dim1;
+ d__2 = v[i__5].r;
+ d__1 = d_sign(&c_b17, &d__2);
+ work[i__4].r = d__1, work[i__4].i = 0.;
+ i__4 = jc + jc * v_dim1;
+ v[i__4].r = 1., v[i__4].i = 0.;
+/* L50: */
+ }
+ zlarnd_(&z__1, &c__3, &iseed[1]);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__3 = n + n * u_dim1;
+ u[i__3].r = 1., u[i__3].i = 0.;
+ i__3 = n;
+ work[i__3].r = 0., work[i__3].i = 0.;
+ i__3 = n * 3;
+ d__1 = z_abs(&ctemp);
+ z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ zlarnd_(&z__1, &c__3, &iseed[1]);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__3 = n + n * v_dim1;
+ v[i__3].r = 1., v[i__3].i = 0.;
+ i__3 = n << 1;
+ work[i__3].r = 0., work[i__3].i = 0.;
+ i__3 = n << 2;
+ d__1 = z_abs(&ctemp);
+ z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+
+/* Apply the diagonal matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ i__5 = jr + jc * a_dim1;
+ i__6 = (n << 1) + jr;
+ d_cnjg(&z__3, &work[n * 3 + jc]);
+ z__2.r = work[i__6].r * z__3.r - work[i__6].i *
+ z__3.i, z__2.i = work[i__6].r * z__3.i +
+ work[i__6].i * z__3.r;
+ i__7 = jr + jc * a_dim1;
+ z__1.r = z__2.r * a[i__7].r - z__2.i * a[i__7].i,
+ z__1.i = z__2.r * a[i__7].i + z__2.i * a[
+ i__7].r;
+ a[i__5].r = z__1.r, a[i__5].i = z__1.i;
+ i__5 = jr + jc * b_dim1;
+ i__6 = (n << 1) + jr;
+ d_cnjg(&z__3, &work[n * 3 + jc]);
+ z__2.r = work[i__6].r * z__3.r - work[i__6].i *
+ z__3.i, z__2.i = work[i__6].r * z__3.i +
+ work[i__6].i * z__3.r;
+ i__7 = jr + jc * b_dim1;
+ z__1.r = z__2.r * b[i__7].r - z__2.i * b[i__7].i,
+ z__1.i = z__2.r * b[i__7].i + z__2.i * b[
+ i__7].r;
+ b[i__5].r = z__1.r, b[i__5].i = z__1.i;
+/* L60: */
+ }
+/* L70: */
+ }
+ i__3 = n - 1;
+ zunm2r_("L", "N", &n, &n, &i__3, &u[u_offset], ldu, &work[
+ 1], &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ zunm2r_("R", "C", &n, &n, &i__3, &v[v_offset], ldu, &work[
+ n + 1], &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ zunm2r_("L", "N", &n, &n, &i__3, &u[u_offset], ldu, &work[
+ 1], &b[b_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ zunm2r_("R", "C", &n, &n, &i__3, &v[v_offset], ldu, &work[
+ n + 1], &b[b_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ }
+ } else {
+
+/* Random matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ i__5 = jr + jc * a_dim1;
+ i__6 = kamagn[jtype - 1];
+ zlarnd_(&z__2, &c__4, &iseed[1]);
+ z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] *
+ z__2.i;
+ a[i__5].r = z__1.r, a[i__5].i = z__1.i;
+ i__5 = jr + jc * b_dim1;
+ i__6 = kbmagn[jtype - 1];
+ zlarnd_(&z__2, &c__4, &iseed[1]);
+ z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] *
+ z__2.i;
+ b[i__5].r = z__1.r, b[i__5].i = z__1.i;
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+
+ anorm = zlange_("1", &n, &n, &a[a_offset], lda, &rwork[1]);
+ bnorm = zlange_("1", &n, &n, &b[b_offset], lda, &rwork[1]);
+
+L100:
+
+ if (iinfo != 0) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L110:
+
+/* Call ZGEQR2, ZUNM2R, and ZGGHRD to compute H, T, U, and V */
+
+ zlacpy_(" ", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+ zlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ ntest = 1;
+ result[1] = ulpinv;
+
+ zgeqr2_(&n, &n, &t[t_offset], lda, &work[1], &work[n + 1], &iinfo)
+ ;
+ if (iinfo != 0) {
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "ZGEQR2", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ zunm2r_("L", "C", &n, &n, &n, &t[t_offset], lda, &work[1], &h__[
+ h_offset], lda, &work[n + 1], &iinfo);
+ if (iinfo != 0) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "ZUNM2R", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ zlaset_("Full", &n, &n, &c_b1, &c_b2, &u[u_offset], ldu);
+ zunm2r_("R", "N", &n, &n, &n, &t[t_offset], lda, &work[1], &u[
+ u_offset], ldu, &work[n + 1], &iinfo);
+ if (iinfo != 0) {
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "ZUNM2R", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ zgghrd_("V", "I", &n, &c__1, &n, &h__[h_offset], lda, &t[t_offset]
+, lda, &u[u_offset], ldu, &v[v_offset], ldu, &iinfo);
+ if (iinfo != 0) {
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "ZGGHRD", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+ ntest = 4;
+
+/* Do tests 1--4 */
+
+ zget51_(&c__1, &n, &a[a_offset], lda, &h__[h_offset], lda, &u[
+ u_offset], ldu, &v[v_offset], ldu, &work[1], &rwork[1], &
+ result[1]);
+ zget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &u[
+ u_offset], ldu, &v[v_offset], ldu, &work[1], &rwork[1], &
+ result[2]);
+ zget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &u[
+ u_offset], ldu, &u[u_offset], ldu, &work[1], &rwork[1], &
+ result[3]);
+ zget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &v[
+ v_offset], ldu, &v[v_offset], ldu, &work[1], &rwork[1], &
+ result[4]);
+
+/* Call ZHGEQZ to compute S1, P1, S2, P2, Q, and Z, do tests. */
+
+/* Compute T1 and UZ */
+
+/* Eigenvalues only */
+
+ zlacpy_(" ", &n, &n, &h__[h_offset], lda, &s2[s2_offset], lda);
+ zlacpy_(" ", &n, &n, &t[t_offset], lda, &p2[p2_offset], lda);
+ ntest = 5;
+ result[5] = ulpinv;
+
+ zhgeqz_("E", "N", "N", &n, &c__1, &n, &s2[s2_offset], lda, &p2[
+ p2_offset], lda, &alpha3[1], &beta3[1], &q[q_offset], ldu,
+ &z__[z_offset], ldu, &work[1], lwork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, "ZHGEQZ(E)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+/* Eigenvalues and Full Schur Form */
+
+ zlacpy_(" ", &n, &n, &h__[h_offset], lda, &s2[s2_offset], lda);
+ zlacpy_(" ", &n, &n, &t[t_offset], lda, &p2[p2_offset], lda);
+
+ zhgeqz_("S", "N", "N", &n, &c__1, &n, &s2[s2_offset], lda, &p2[
+ p2_offset], lda, &alpha1[1], &beta1[1], &q[q_offset], ldu,
+ &z__[z_offset], ldu, &work[1], lwork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ do_fio(&c__1, "ZHGEQZ(S)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+/* Eigenvalues, Schur Form, and Schur Vectors */
+
+ zlacpy_(" ", &n, &n, &h__[h_offset], lda, &s1[s1_offset], lda);
+ zlacpy_(" ", &n, &n, &t[t_offset], lda, &p1[p1_offset], lda);
+
+ zhgeqz_("S", "I", "I", &n, &c__1, &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, &alpha1[1], &beta1[1], &q[q_offset], ldu,
+ &z__[z_offset], ldu, &work[1], lwork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___48.ciunit = *nounit;
+ s_wsfe(&io___48);
+ do_fio(&c__1, "ZHGEQZ(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ ntest = 8;
+
+/* Do Tests 5--8 */
+
+ zget51_(&c__1, &n, &h__[h_offset], lda, &s1[s1_offset], lda, &q[
+ q_offset], ldu, &z__[z_offset], ldu, &work[1], &rwork[1],
+ &result[5]);
+ zget51_(&c__1, &n, &t[t_offset], lda, &p1[p1_offset], lda, &q[
+ q_offset], ldu, &z__[z_offset], ldu, &work[1], &rwork[1],
+ &result[6]);
+ zget51_(&c__3, &n, &t[t_offset], lda, &p1[p1_offset], lda, &q[
+ q_offset], ldu, &q[q_offset], ldu, &work[1], &rwork[1], &
+ result[7]);
+ zget51_(&c__3, &n, &t[t_offset], lda, &p1[p1_offset], lda, &z__[
+ z_offset], ldu, &z__[z_offset], ldu, &work[1], &rwork[1],
+ &result[8]);
+
+/* Compute the Left and Right Eigenvectors of (S1,P1) */
+
+/* 9: Compute the left eigenvector Matrix without */
+/* back transforming: */
+
+ ntest = 9;
+ result[9] = ulpinv;
+
+/* To test "SELECT" option, compute half of the eigenvectors */
+/* in one call, and half in another */
+
+ i1 = n / 2;
+ i__3 = i1;
+ for (j = 1; j <= i__3; ++j) {
+ llwork[j] = TRUE_;
+/* L120: */
+ }
+ i__3 = n;
+ for (j = i1 + 1; j <= i__3; ++j) {
+ llwork[j] = FALSE_;
+/* L130: */
+ }
+
+ ztgevc_("L", "S", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, &evectl[evectl_offset], ldu, cdumma, ldu,
+ &n, &in, &work[1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "ZTGEVC(L,S1)", (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ i1 = in;
+ i__3 = i1;
+ for (j = 1; j <= i__3; ++j) {
+ llwork[j] = FALSE_;
+/* L140: */
+ }
+ i__3 = n;
+ for (j = i1 + 1; j <= i__3; ++j) {
+ llwork[j] = TRUE_;
+/* L150: */
+ }
+
+ ztgevc_("L", "S", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, &evectl[(i1 + 1) * evectl_dim1 + 1], ldu,
+ cdumma, ldu, &n, &in, &work[1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "ZTGEVC(L,S2)", (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ zget52_(&c_true, &n, &s1[s1_offset], lda, &p1[p1_offset], lda, &
+ evectl[evectl_offset], ldu, &alpha1[1], &beta1[1], &work[
+ 1], &rwork[1], dumma);
+ result[9] = dumma[0];
+ if (dumma[1] > *thrshn) {
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "ZTGEVC(HOWMNY=S)", (ftnlen)16);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* 10: Compute the left eigenvector Matrix with */
+/* back transforming: */
+
+ ntest = 10;
+ result[10] = ulpinv;
+ zlacpy_("F", &n, &n, &q[q_offset], ldu, &evectl[evectl_offset],
+ ldu);
+ ztgevc_("L", "B", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, &evectl[evectl_offset], ldu, cdumma, ldu,
+ &n, &in, &work[1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+ do_fio(&c__1, "ZTGEVC(L,B)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ zget52_(&c_true, &n, &h__[h_offset], lda, &t[t_offset], lda, &
+ evectl[evectl_offset], ldu, &alpha1[1], &beta1[1], &work[
+ 1], &rwork[1], dumma);
+ result[10] = dumma[0];
+ if (dumma[1] > *thrshn) {
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "ZTGEVC(HOWMNY=B)", (ftnlen)16);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* 11: Compute the right eigenvector Matrix without */
+/* back transforming: */
+
+ ntest = 11;
+ result[11] = ulpinv;
+
+/* To test "SELECT" option, compute half of the eigenvectors */
+/* in one call, and half in another */
+
+ i1 = n / 2;
+ i__3 = i1;
+ for (j = 1; j <= i__3; ++j) {
+ llwork[j] = TRUE_;
+/* L160: */
+ }
+ i__3 = n;
+ for (j = i1 + 1; j <= i__3; ++j) {
+ llwork[j] = FALSE_;
+/* L170: */
+ }
+
+ ztgevc_("R", "S", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, cdumma, ldu, &evectr[evectr_offset], ldu,
+ &n, &in, &work[1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, "ZTGEVC(R,S1)", (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ i1 = in;
+ i__3 = i1;
+ for (j = 1; j <= i__3; ++j) {
+ llwork[j] = FALSE_;
+/* L180: */
+ }
+ i__3 = n;
+ for (j = i1 + 1; j <= i__3; ++j) {
+ llwork[j] = TRUE_;
+/* L190: */
+ }
+
+ ztgevc_("R", "S", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, cdumma, ldu, &evectr[(i1 + 1) *
+ evectr_dim1 + 1], ldu, &n, &in, &work[1], &rwork[1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ do_fio(&c__1, "ZTGEVC(R,S2)", (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ zget52_(&c_false, &n, &s1[s1_offset], lda, &p1[p1_offset], lda, &
+ evectr[evectr_offset], ldu, &alpha1[1], &beta1[1], &work[
+ 1], &rwork[1], dumma);
+ result[11] = dumma[0];
+ if (dumma[1] > *thresh) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "ZTGEVC(HOWMNY=S)", (ftnlen)16);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* 12: Compute the right eigenvector Matrix with */
+/* back transforming: */
+
+ ntest = 12;
+ result[12] = ulpinv;
+ zlacpy_("F", &n, &n, &z__[z_offset], ldu, &evectr[evectr_offset],
+ ldu);
+ ztgevc_("R", "B", &llwork[1], &n, &s1[s1_offset], lda, &p1[
+ p1_offset], lda, cdumma, ldu, &evectr[evectr_offset], ldu,
+ &n, &in, &work[1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___60.ciunit = *nounit;
+ s_wsfe(&io___60);
+ do_fio(&c__1, "ZTGEVC(R,B)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L210;
+ }
+
+ zget52_(&c_false, &n, &h__[h_offset], lda, &t[t_offset], lda, &
+ evectr[evectr_offset], ldu, &alpha1[1], &beta1[1], &work[
+ 1], &rwork[1], dumma);
+ result[12] = dumma[0];
+ if (dumma[1] > *thresh) {
+ io___61.ciunit = *nounit;
+ s_wsfe(&io___61);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "ZTGEVC(HOWMNY=B)", (ftnlen)16);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Tests 13--15 are done only on request */
+
+ if (*tstdif) {
+
+/* Do Tests 13--14 */
+
+ zget51_(&c__2, &n, &s1[s1_offset], lda, &s2[s2_offset], lda, &
+ q[q_offset], ldu, &z__[z_offset], ldu, &work[1], &
+ rwork[1], &result[13]);
+ zget51_(&c__2, &n, &p1[p1_offset], lda, &p2[p2_offset], lda, &
+ q[q_offset], ldu, &z__[z_offset], ldu, &work[1], &
+ rwork[1], &result[14]);
+
+/* Do Test 15 */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = j;
+ i__5 = j;
+ z__1.r = alpha1[i__4].r - alpha3[i__5].r, z__1.i = alpha1[
+ i__4].i - alpha3[i__5].i;
+ d__1 = temp1, d__2 = z_abs(&z__1);
+ temp1 = max(d__1,d__2);
+/* Computing MAX */
+ i__4 = j;
+ i__5 = j;
+ z__1.r = beta1[i__4].r - beta3[i__5].r, z__1.i = beta1[
+ i__4].i - beta3[i__5].i;
+ d__1 = temp2, d__2 = z_abs(&z__1);
+ temp2 = max(d__1,d__2);
+/* L200: */
+ }
+
+/* Computing MAX */
+ d__1 = safmin, d__2 = ulp * max(temp1,anorm);
+ temp1 /= max(d__1,d__2);
+/* Computing MAX */
+ d__1 = safmin, d__2 = ulp * max(temp2,bnorm);
+ temp2 /= max(d__1,d__2);
+ result[15] = max(temp1,temp2);
+ ntest = 15;
+ } else {
+ result[13] = 0.;
+ result[14] = 0.;
+ result[15] = 0.;
+ ntest = 12;
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L210:
+
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__3 = ntest;
+ for (jr = 1; jr <= i__3; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___64.ciunit = *nounit;
+ s_wsfe(&io___64);
+ do_fio(&c__1, "ZGG", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___65.ciunit = *nounit;
+ s_wsfe(&io___65);
+ e_wsfe();
+ io___66.ciunit = *nounit;
+ s_wsfe(&io___66);
+ e_wsfe();
+ io___67.ciunit = *nounit;
+ s_wsfe(&io___67);
+ do_fio(&c__1, "Unitary", (ftnlen)7);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___68.ciunit = *nounit;
+ s_wsfe(&io___68);
+ do_fio(&c__1, "unitary", (ftnlen)7);
+ do_fio(&c__1, "*", (ftnlen)1);
+ do_fio(&c__1, "conjugate transpose", (ftnlen)19);
+ for (j = 1; j <= 10; ++j) {
+ do_fio(&c__1, "*", (ftnlen)1);
+ }
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[jr] < 1e4) {
+ io___69.ciunit = *nounit;
+ s_wsfe(&io___69);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ } else {
+ io___70.ciunit = *nounit;
+ s_wsfe(&io___70);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+ }
+/* L220: */
+ }
+
+L230:
+ ;
+ }
+/* L240: */
+ }
+
+/* Summary */
+
+ dlasum_("ZGG", nounit, &nerrs, &ntestt);
+ return 0;
+
+
+
+
+
+
+
+
+/* End of ZCHKGG */
+
+} /* zchkgg_ */
diff --git a/TESTING/EIG/zchkgk.c b/TESTING/EIG/zchkgk.c
new file mode 100644
index 0000000..36e4433
--- /dev/null
+++ b/TESTING/EIG/zchkgk.c
@@ -0,0 +1,366 @@
+/* zchkgk.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__7 = 7;
+static integer c__50 = 50;
+
+/* Subroutine */ int zchkgk_(integer *nin, integer *nout)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002.. test output of ZGGBAK .. \002)";
+ static char fmt_9998[] = "(\002 value of largest test error "
+ " =\002,d12.3)";
+ static char fmt_9997[] = "(\002 example number where ZGGBAL info is not "
+ "0 =\002,i4)";
+ static char fmt_9996[] = "(\002 example number where ZGGBAK(L) info is n"
+ "ot 0 =\002,i4)";
+ static char fmt_9995[] = "(\002 example number where ZGGBAK(R) info is n"
+ "ot 0 =\002,i4)";
+ static char fmt_9994[] = "(\002 example number having largest error "
+ " =\002,i4)";
+ static char fmt_9992[] = "(\002 number of examples where info is not 0 "
+ " =\002,i4)";
+ static char fmt_9991[] = "(\002 total number of examples tested "
+ " =\002,i4)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+ double d_imag(doublecomplex *);
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ doublecomplex a[2500] /* was [50][50] */, b[2500] /* was [50][
+ 50] */, e[2500] /* was [50][50] */, f[2500] /* was [50][
+ 50] */;
+ integer i__, j, m, n;
+ doublecomplex af[2500] /* was [50][50] */, bf[2500] /* was [50][
+ 50] */, vl[2500] /* was [50][50] */, vr[2500] /* was [50][
+ 50] */;
+ integer ihi, ilo;
+ doublereal eps;
+ doublecomplex vlf[2500] /* was [50][50] */;
+ integer knt;
+ doublecomplex vrf[2500] /* was [50][50] */;
+ integer info, lmax[4];
+ doublereal rmax, vmax;
+ doublecomplex work[2500] /* was [50][50] */;
+ integer ninfo;
+ doublereal anorm, bnorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ doublereal rwork[300];
+ extern doublereal dlamch_(char *);
+ doublereal lscale[50];
+ extern /* Subroutine */ int zggbak_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublecomplex *,
+ integer *, integer *), zggbal_(char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+, integer *, doublereal *, doublereal *, doublereal *, integer *);
+ doublereal rscale[50];
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 0, 0, 0, 0 };
+ static cilist io___10 = { 0, 0, 0, 0, 0 };
+ static cilist io___13 = { 0, 0, 0, 0, 0 };
+ static cilist io___15 = { 0, 0, 0, 0, 0 };
+ static cilist io___17 = { 0, 0, 0, 0, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9991, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKGK tests ZGGBAK, a routine for backward balancing of */
+/* a matrix pair (A, B). */
+
+/* Arguments */
+/* ========= */
+
+/* NIN (input) INTEGER */
+/* The logical unit number for input. NIN > 0. */
+
+/* NOUT (input) INTEGER */
+/* The logical unit number for output. NOUT > 0. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ lmax[0] = 0;
+ lmax[1] = 0;
+ lmax[2] = 0;
+ lmax[3] = 0;
+ ninfo = 0;
+ knt = 0;
+ rmax = 0.;
+
+ eps = dlamch_("Precision");
+
+L10:
+ io___6.ciunit = *nin;
+ s_rsle(&io___6);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&m, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ goto L100;
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___10.ciunit = *nin;
+ s_rsle(&io___10);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&a[i__ + j * 50 - 51], (ftnlen)
+ sizeof(doublecomplex));
+ }
+ e_rsle();
+/* L20: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___13.ciunit = *nin;
+ s_rsle(&io___13);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&b[i__ + j * 50 - 51], (ftnlen)
+ sizeof(doublecomplex));
+ }
+ e_rsle();
+/* L30: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___15.ciunit = *nin;
+ s_rsle(&io___15);
+ i__2 = m;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&vl[i__ + j * 50 - 51], (ftnlen)
+ sizeof(doublecomplex));
+ }
+ e_rsle();
+/* L40: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___17.ciunit = *nin;
+ s_rsle(&io___17);
+ i__2 = m;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&vr[i__ + j * 50 - 51], (ftnlen)
+ sizeof(doublecomplex));
+ }
+ e_rsle();
+/* L50: */
+ }
+
+ ++knt;
+
+ anorm = zlange_("M", &n, &n, a, &c__50, rwork);
+ bnorm = zlange_("M", &n, &n, b, &c__50, rwork);
+
+ zlacpy_("FULL", &n, &n, a, &c__50, af, &c__50);
+ zlacpy_("FULL", &n, &n, b, &c__50, bf, &c__50);
+
+ zggbal_("B", &n, a, &c__50, b, &c__50, &ilo, &ihi, lscale, rscale, rwork,
+ &info);
+ if (info != 0) {
+ ++ninfo;
+ lmax[0] = knt;
+ }
+
+ zlacpy_("FULL", &n, &m, vl, &c__50, vlf, &c__50);
+ zlacpy_("FULL", &n, &m, vr, &c__50, vrf, &c__50);
+
+ zggbak_("B", "L", &n, &ilo, &ihi, lscale, rscale, &m, vl, &c__50, &info);
+ if (info != 0) {
+ ++ninfo;
+ lmax[1] = knt;
+ }
+
+ zggbak_("B", "R", &n, &ilo, &ihi, lscale, rscale, &m, vr, &c__50, &info);
+ if (info != 0) {
+ ++ninfo;
+ lmax[2] = knt;
+ }
+
+/* Test of ZGGBAK */
+
+/* Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR */
+/* where tilde(A) denotes the transformed matrix. */
+
+ zgemm_("N", "N", &n, &m, &n, &c_b2, af, &c__50, vr, &c__50, &c_b1, work, &
+ c__50);
+ zgemm_("C", "N", &m, &m, &n, &c_b2, vl, &c__50, work, &c__50, &c_b1, e, &
+ c__50);
+
+ zgemm_("N", "N", &n, &m, &n, &c_b2, a, &c__50, vrf, &c__50, &c_b1, work, &
+ c__50);
+ zgemm_("C", "N", &m, &m, &n, &c_b2, vlf, &c__50, work, &c__50, &c_b1, f, &
+ c__50);
+
+ vmax = 0.;
+ i__1 = m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 50 - 51;
+ i__4 = i__ + j * 50 - 51;
+ z__2.r = e[i__3].r - f[i__4].r, z__2.i = e[i__3].i - f[i__4].i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+/* Computing MAX */
+ d__3 = vmax, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
+ z__1), abs(d__2));
+ vmax = max(d__3,d__4);
+/* L60: */
+ }
+/* L70: */
+ }
+ vmax /= eps * max(anorm,bnorm);
+ if (vmax > rmax) {
+ lmax[3] = knt;
+ rmax = vmax;
+ }
+
+/* Check tilde(VL)'*B*tilde(VR) - VL'*tilde(B)*VR */
+
+ zgemm_("N", "N", &n, &m, &n, &c_b2, bf, &c__50, vr, &c__50, &c_b1, work, &
+ c__50);
+ zgemm_("C", "N", &m, &m, &n, &c_b2, vl, &c__50, work, &c__50, &c_b1, e, &
+ c__50);
+
+ zgemm_("n", "n", &n, &m, &n, &c_b2, b, &c__50, vrf, &c__50, &c_b1, work, &
+ c__50);
+ zgemm_("C", "N", &m, &m, &n, &c_b2, vlf, &c__50, work, &c__50, &c_b1, f, &
+ c__50);
+
+ vmax = 0.;
+ i__1 = m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 50 - 51;
+ i__4 = i__ + j * 50 - 51;
+ z__2.r = e[i__3].r - f[i__4].r, z__2.i = e[i__3].i - f[i__4].i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+/* Computing MAX */
+ d__3 = vmax, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
+ z__1), abs(d__2));
+ vmax = max(d__3,d__4);
+/* L80: */
+ }
+/* L90: */
+ }
+ vmax /= eps * max(anorm,bnorm);
+ if (vmax > rmax) {
+ lmax[3] = knt;
+ rmax = vmax;
+ }
+
+ goto L10;
+
+L100:
+
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ e_wsfe();
+
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, (char *)&lmax[3], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ return 0;
+
+/* End of ZCHKGK */
+
+} /* zchkgk_ */
diff --git a/TESTING/EIG/zchkgl.c b/TESTING/EIG/zchkgl.c
new file mode 100644
index 0000000..fd5e7ed
--- /dev/null
+++ b/TESTING/EIG/zchkgl.c
@@ -0,0 +1,320 @@
+/* zchkgl.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__7 = 7;
+static integer c__5 = 5;
+static integer c__20 = 20;
+
+/* Subroutine */ int zchkgl_(integer *nin, integer *nout)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 .. test output of ZGGBAL .. \002)";
+ static char fmt_9998[] = "(\002 ratio of largest test error "
+ " = \002,d12.3)";
+ static char fmt_9997[] = "(\002 example number where info is not zero "
+ " = \002,i4)";
+ static char fmt_9996[] = "(\002 example number where ILO or IHI is wrong"
+ " = \002,i4)";
+ static char fmt_9995[] = "(\002 example number having largest error "
+ " = \002,i4)";
+ static char fmt_9994[] = "(\002 number of examples where info is not 0 "
+ " = \002,i4)";
+ static char fmt_9993[] = "(\002 total number of examples tested "
+ " = \002,i4)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+ double z_abs(doublecomplex *);
+ integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ doublecomplex a[400] /* was [20][20] */, b[400] /* was [20][
+ 20] */;
+ integer i__, j, n;
+ doublecomplex ain[400] /* was [20][20] */, bin[400] /* was [20][
+ 20] */;
+ integer ihi, ilo;
+ doublereal eps;
+ integer knt, info, lmax[3];
+ doublereal rmax, vmax, work[120];
+ integer ihiin, ninfo, iloin;
+ doublereal anorm, bnorm;
+ extern doublereal dlamch_(char *);
+ doublereal lscale[20];
+ extern /* Subroutine */ int zggbal_(char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ doublereal rscale[20];
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ doublereal lsclin[20], rsclin[20];
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 0, 0, 0, 0 };
+ static cilist io___9 = { 0, 0, 0, 0, 0 };
+ static cilist io___12 = { 0, 0, 0, 0, 0 };
+ static cilist io___14 = { 0, 0, 0, 0, 0 };
+ static cilist io___17 = { 0, 0, 0, 0, 0 };
+ static cilist io___19 = { 0, 0, 0, 0, 0 };
+ static cilist io___21 = { 0, 0, 0, 0, 0 };
+ static cilist io___23 = { 0, 0, 0, 0, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKGL tests ZGGBAL, a routine for balancing a matrix pair (A, B). */
+
+/* Arguments */
+/* ========= */
+
+/* NIN (input) INTEGER */
+/* The logical unit number for input. NIN > 0. */
+
+/* NOUT (input) INTEGER */
+/* The logical unit number for output. NOUT > 0. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ lmax[0] = 0;
+ lmax[1] = 0;
+ lmax[2] = 0;
+ ninfo = 0;
+ knt = 0;
+ rmax = 0.;
+
+ eps = dlamch_("Precision");
+
+L10:
+
+ io___6.ciunit = *nin;
+ s_rsle(&io___6);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ goto L90;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___9.ciunit = *nin;
+ s_rsle(&io___9);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&a[i__ + j * 20 - 21], (ftnlen)
+ sizeof(doublecomplex));
+ }
+ e_rsle();
+/* L20: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___12.ciunit = *nin;
+ s_rsle(&io___12);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&b[i__ + j * 20 - 21], (ftnlen)
+ sizeof(doublecomplex));
+ }
+ e_rsle();
+/* L30: */
+ }
+
+ io___14.ciunit = *nin;
+ s_rsle(&io___14);
+ do_lio(&c__3, &c__1, (char *)&iloin, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ihiin, (ftnlen)sizeof(integer));
+ e_rsle();
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___17.ciunit = *nin;
+ s_rsle(&io___17);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&ain[i__ + j * 20 - 21], (ftnlen)
+ sizeof(doublecomplex));
+ }
+ e_rsle();
+/* L40: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___19.ciunit = *nin;
+ s_rsle(&io___19);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&bin[i__ + j * 20 - 21], (ftnlen)
+ sizeof(doublecomplex));
+ }
+ e_rsle();
+/* L50: */
+ }
+
+ io___21.ciunit = *nin;
+ s_rsle(&io___21);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__5, &c__1, (char *)&lsclin[i__ - 1], (ftnlen)sizeof(
+ doublereal));
+ }
+ e_rsle();
+ io___23.ciunit = *nin;
+ s_rsle(&io___23);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__5, &c__1, (char *)&rsclin[i__ - 1], (ftnlen)sizeof(
+ doublereal));
+ }
+ e_rsle();
+
+ anorm = zlange_("M", &n, &n, a, &c__20, work);
+ bnorm = zlange_("M", &n, &n, b, &c__20, work);
+
+ ++knt;
+
+ zggbal_("B", &n, a, &c__20, b, &c__20, &ilo, &ihi, lscale, rscale, work, &
+ info);
+
+ if (info != 0) {
+ ++ninfo;
+ lmax[0] = knt;
+ }
+
+ if (ilo != iloin || ihi != ihiin) {
+ ++ninfo;
+ lmax[1] = knt;
+ }
+
+ vmax = 0.;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ z__1.r = a[i__3].r - ain[i__4].r, z__1.i = a[i__3].i - ain[i__4]
+ .i;
+ d__1 = vmax, d__2 = z_abs(&z__1);
+ vmax = max(d__1,d__2);
+/* Computing MAX */
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ z__1.r = b[i__3].r - bin[i__4].r, z__1.i = b[i__3].i - bin[i__4]
+ .i;
+ d__1 = vmax, d__2 = z_abs(&z__1);
+ vmax = max(d__1,d__2);
+/* L60: */
+ }
+/* L70: */
+ }
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = vmax, d__3 = (d__1 = lscale[i__ - 1] - lsclin[i__ - 1], abs(
+ d__1));
+ vmax = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = vmax, d__3 = (d__1 = rscale[i__ - 1] - rsclin[i__ - 1], abs(
+ d__1));
+ vmax = max(d__2,d__3);
+/* L80: */
+ }
+
+ vmax /= eps * max(anorm,bnorm);
+
+ if (vmax > rmax) {
+ lmax[2] = knt;
+ rmax = vmax;
+ }
+
+ goto L10;
+
+L90:
+
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ e_wsfe();
+
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ return 0;
+
+/* End of ZCHKGL */
+
+} /* zchkgl_ */
diff --git a/TESTING/EIG/zchkhb.c b/TESTING/EIG/zchkhb.c
new file mode 100644
index 0000000..96e5919
--- /dev/null
+++ b/TESTING/EIG/zchkhb.c
@@ -0,0 +1,831 @@
+/* zchkhb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__0 = 0;
+static integer c__6 = 6;
+static doublereal c_b32 = 1.;
+static integer c__1 = 1;
+static doublereal c_b42 = 0.;
+static integer c__4 = 4;
+
+/* Subroutine */ int zchkhb_(integer *nsizes, integer *nn, integer *nwdths,
+ integer *kk, integer *ntypes, logical *dotype, integer *iseed,
+ doublereal *thresh, integer *nounit, doublecomplex *a, integer *lda,
+ doublereal *sd, doublereal *se, doublecomplex *u, integer *ldu,
+ doublecomplex *work, integer *lwork, doublereal *rwork, doublereal *
+ result, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[15] = { 1,2,4,4,4,4,4,5,5,5,5,5,8,8,8 };
+ static integer kmagn[15] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3 };
+ static integer kmode[15] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ZCHKHB: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(/1x,a3,\002 -- Complex Hermitian Banded Tridi"
+ "agonal Reduction Routines\002)";
+ static char fmt_9997[] = "(\002 Matrix types (see DCHK23 for details):"
+ " \002)";
+ static char fmt_9996[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 5=Diagonal: clustered ent"
+ "ries.\002,/\002 2=Identity matrix. \002,\002"
+ " 6=Diagonal: large, evenly spaced.\002,/\002 3=Diagonal: evenl"
+ "y spaced entries. \002,\002 7=Diagonal: small, evenly spaced."
+ "\002,/\002 4=Diagonal: geometr. spaced entries.\002)";
+ static char fmt_9995[] = "(\002 Dense \002,a,\002 Banded Matrices:\002,"
+ "/\002 8=Evenly spaced eigenvals. \002,\002 12=Small,"
+ " evenly spaced eigenvals.\002,/\002 9=Geometrically spaced eige"
+ "nvals. \002,\002 13=Matrix with random O(1) entries.\002,"
+ "/\002 10=Clustered eigenvalues. \002,\002 14=Matrix"
+ " with large random entries.\002,/\002 11=Large, evenly spaced ei"
+ "genvals. \002,\002 15=Matrix with small random entries.\002)";
+ static char fmt_9994[] = "(/\002 Tests performed: (S is Tridiag, U "
+ "is \002,a,\002,\002,/20x,a,\002 means \002,a,\002.\002,/\002 UPL"
+ "O='U':\002,/\002 1= | A - U S U\002,a1,\002 | / ( |A| n ulp ) "
+ " \002,\002 2= | I - U U\002,a1,\002 | / ( n ulp )\002,/\002 U"
+ "PLO='L':\002,/\002 3= | A - U S U\002,a1,\002 | / ( |A| n ulp )"
+ " \002,\002 4= | I - U U\002,a1,\002 | / ( n ulp )\002)";
+ static char fmt_9993[] = "(\002 N=\002,i5,\002, K=\002,i4,\002, seed="
+ "\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)"
+ "=\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6, i__7;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal), z_abs(doublecomplex *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, n, jc, jr;
+ doublereal ulp, cond;
+ integer jcol, kmax, nmax;
+ doublereal unfl, ovfl, temp1;
+ logical badnn;
+ integer imode, iinfo;
+ extern /* Subroutine */ int zhbt21_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, doublereal *,
+ doublereal *);
+ doublereal aninv, anorm;
+ integer nmats, jsize, nerrs, itype, jtype, ntest;
+ logical badnnb;
+ extern doublereal dlamch_(char *);
+ integer idumma[1];
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int dlasum_(char *, integer *, integer *, integer
+ *);
+ integer jwidth;
+ extern /* Subroutine */ int zhbtrd_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), zlaset_(char *,
+ integer *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *), zlatmr_(integer *, integer *,
+ char *, integer *, char *, doublecomplex *, integer *,
+ doublereal *, doublecomplex *, char *, char *, doublecomplex *,
+ integer *, doublereal *, doublecomplex *, integer *, doublereal *,
+ char *, integer *, integer *, integer *, doublereal *,
+ doublereal *, char *, doublecomplex *, integer *, integer *,
+ integer *);
+ doublereal rtunfl, rtovfl, ulpinv;
+ extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKHB tests the reduction of a Hermitian band matrix to tridiagonal */
+/* from, used with the Hermitian eigenvalue problem. */
+
+/* ZHBTRD factors a Hermitian band matrix A as U S U* , where * means */
+/* conjugate transpose, S is symmetric tridiagonal, and U is unitary. */
+/* ZHBTRD can use either just the lower or just the upper triangle */
+/* of A; ZCHKHB checks both cases. */
+
+/* When ZCHKHB is called, a number of matrix "sizes" ("n's"), a number */
+/* of bandwidths ("k's"), and a number of matrix "types" are */
+/* specified. For each size ("n"), each bandwidth ("k") less than or */
+/* equal to "n", and each type of matrix, one matrix will be generated */
+/* and used to test the hermitian banded reduction routine. For each */
+/* matrix, a number of tests will be performed: */
+
+/* (1) | A - V S V* | / ( |A| n ulp ) computed by ZHBTRD with */
+/* UPLO='U' */
+
+/* (2) | I - UU* | / ( n ulp ) */
+
+/* (3) | A - V S V* | / ( |A| n ulp ) computed by ZHBTRD with */
+/* UPLO='L' */
+
+/* (4) | I - UU* | / ( n ulp ) */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (6) Same as (4), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (4), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U* D U, where U is unitary and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U* D U, where U is unitary and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U* D U, where U is unitary and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) Hermitian matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* ZCHKHB does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NWDTHS (input) INTEGER */
+/* The number of bandwidths to use. If it is zero, */
+/* ZCHKHB does nothing. It must be at least zero. */
+
+/* KK (input) INTEGER array, dimension (NWDTHS) */
+/* An array containing the bandwidths to be used for the band */
+/* matrices. The values must be at least zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, ZCHKHB */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to ZCHKHB to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace) DOUBLE PRECISION array, dimension */
+/* (LDA, max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 2 (not 1!) */
+/* and at least max( KK )+1. */
+
+/* SD (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* Used to hold the diagonal of the tridiagonal matrix computed */
+/* by ZHBTRD. */
+
+/* SE (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+/* Used to hold the off-diagonal of the tridiagonal matrix */
+/* computed by ZHBTRD. */
+
+/* U (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN)) */
+/* Used to hold the unitary matrix computed by ZHBTRD. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* max( LDA+1, max(NN)+1 )*max(NN). */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests performed, or which can */
+/* be performed so far, for the current matrix. */
+/* NTESTT The total number of tests performed so far. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far. */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --kk;
+ --dotype;
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --sd;
+ --se;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+ badnnb = FALSE_;
+ kmax = 0;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = kmax, i__3 = kk[j];
+ kmax = max(i__2,i__3);
+ if (kk[j] < 0) {
+ badnnb = TRUE_;
+ }
+/* L20: */
+ }
+/* Computing MIN */
+ i__1 = nmax - 1;
+ kmax = min(i__1,kmax);
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*nwdths < 0) {
+ *info = -3;
+ } else if (badnnb) {
+ *info = -4;
+ } else if (*ntypes < 0) {
+ *info = -5;
+ } else if (*lda < kmax + 1) {
+ *info = -11;
+ } else if (*ldu < nmax) {
+ *info = -15;
+ } else if ((max(*lda,nmax) + 1) * nmax > *lwork) {
+ *info = -17;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZCHKHB", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0 || *nwdths == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ ulpinv = 1. / ulp;
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ aninv = 1. / (doublereal) max(1,n);
+
+ i__2 = *nwdths;
+ for (jwidth = 1; jwidth <= i__2; ++jwidth) {
+ k = kk[jwidth];
+ if (k > n) {
+ goto L180;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__5 = n - 1;
+ i__3 = 0, i__4 = min(i__5,k);
+ k = max(i__3,i__4);
+
+ if (*nsizes != 1) {
+ mtypes = min(15,*ntypes);
+ } else {
+ mtypes = min(16,*ntypes);
+ }
+
+ i__3 = mtypes;
+ for (jtype = 1; jtype <= i__3; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L170;
+ }
+ ++nmats;
+ ntest = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L30: */
+ }
+
+/* Compute "A". */
+/* Store as "Upper"; later, we will copy to other format. */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log hermitian, w/ eigenvalues */
+/* =6 random (none) */
+/* =7 random diagonal */
+/* =8 random hermitian */
+/* =9 positive definite */
+/* =10 diagonally dominant tridiagonal */
+
+ if (mtypes > 15) {
+ goto L100;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * aninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * n * ulpinv;
+ goto L70;
+
+L70:
+
+ zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ iinfo = 0;
+ if (jtype <= 15) {
+ cond = ulpinv;
+ } else {
+ cond = ulpinv * aninv / 10.;
+ }
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__4 = n;
+ for (jcol = 1; jcol <= i__4; ++jcol) {
+ i__5 = k + 1 + jcol * a_dim1;
+ a[i__5].r = anorm, a[i__5].i = 0.;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &
+ cond, &anorm, &c__0, &c__0, "Q", &a[k + 1 +
+ a_dim1], lda, &work[1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Hermitian, eigenvalues specified */
+
+ zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &
+ cond, &anorm, &k, &k, "Q", &a[a_offset], lda, &
+ work[1], &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ zlatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &
+ c_b32, &c_b2, "T", "N", &work[n + 1], &c__1, &
+ c_b32, &work[(n << 1) + 1], &c__1, &c_b32, "N",
+ idumma, &c__0, &c__0, &c_b42, &anorm, "Q", &a[k +
+ 1 + a_dim1], lda, idumma, &iinfo);
+
+ } else if (itype == 8) {
+
+/* Hermitian, random eigenvalues */
+
+ zlatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &
+ c_b32, &c_b2, "T", "N", &work[n + 1], &c__1, &
+ c_b32, &work[(n << 1) + 1], &c__1, &c_b32, "N",
+ idumma, &k, &k, &c_b42, &anorm, "Q", &a[a_offset],
+ lda, idumma, &iinfo);
+
+ } else if (itype == 9) {
+
+/* Positive definite, eigenvalues specified. */
+
+ zlatms_(&n, &n, "S", &iseed[1], "P", &rwork[1], &imode, &
+ cond, &anorm, &k, &k, "Q", &a[a_offset], lda, &
+ work[n + 1], &iinfo);
+
+ } else if (itype == 10) {
+
+/* Positive definite tridiagonal, eigenvalues specified. */
+
+ if (n > 1) {
+ k = max(1,k);
+ }
+ zlatms_(&n, &n, "S", &iseed[1], "P", &rwork[1], &imode, &
+ cond, &anorm, &c__1, &c__1, "Q", &a[k + a_dim1],
+ lda, &work[1], &iinfo);
+ i__4 = n;
+ for (i__ = 2; i__ <= i__4; ++i__) {
+ i__5 = k + 1 + (i__ - 1) * a_dim1;
+ i__6 = k + 1 + i__ * a_dim1;
+ z__1.r = a[i__5].r * a[i__6].r - a[i__5].i * a[i__6]
+ .i, z__1.i = a[i__5].r * a[i__6].i + a[i__5]
+ .i * a[i__6].r;
+ temp1 = z_abs(&a[k + i__ * a_dim1]) / sqrt(z_abs(&
+ z__1));
+ if (temp1 > .5) {
+ i__5 = k + i__ * a_dim1;
+ i__6 = k + 1 + (i__ - 1) * a_dim1;
+ i__7 = k + 1 + i__ * a_dim1;
+ z__1.r = a[i__6].r * a[i__7].r - a[i__6].i * a[
+ i__7].i, z__1.i = a[i__6].r * a[i__7].i +
+ a[i__6].i * a[i__7].r;
+ d__1 = sqrt(z_abs(&z__1)) * .5;
+ a[i__5].r = d__1, a[i__5].i = 0.;
+ }
+/* L90: */
+ }
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___36.ciunit = *nounit;
+ s_wsfe(&io___36);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L100:
+
+/* Call ZHBTRD to compute S and U from upper triangle. */
+
+ i__4 = k + 1;
+ zlacpy_(" ", &i__4, &n, &a[a_offset], lda, &work[1], lda);
+
+ ntest = 1;
+ zhbtrd_("V", "U", &n, &k, &work[1], lda, &sd[1], &se[1], &u[
+ u_offset], ldu, &work[*lda * n + 1], &iinfo);
+
+ if (iinfo != 0) {
+ io___37.ciunit = *nounit;
+ s_wsfe(&io___37);
+ do_fio(&c__1, "ZHBTRD(U)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[1] = ulpinv;
+ goto L150;
+ }
+ }
+
+/* Do tests 1 and 2 */
+
+ zhbt21_("Upper", &n, &k, &c__1, &a[a_offset], lda, &sd[1], &
+ se[1], &u[u_offset], ldu, &work[1], &rwork[1], &
+ result[1]);
+
+/* Convert A from Upper-Triangle-Only storage to */
+/* Lower-Triangle-Only storage. */
+
+ i__4 = n;
+ for (jc = 1; jc <= i__4; ++jc) {
+/* Computing MIN */
+ i__6 = k, i__7 = n - jc;
+ i__5 = min(i__6,i__7);
+ for (jr = 0; jr <= i__5; ++jr) {
+ i__6 = jr + 1 + jc * a_dim1;
+ d_cnjg(&z__1, &a[k + 1 - jr + (jc + jr) * a_dim1]);
+ a[i__6].r = z__1.r, a[i__6].i = z__1.i;
+/* L110: */
+ }
+/* L120: */
+ }
+ i__4 = n;
+ for (jc = n + 1 - k; jc <= i__4; ++jc) {
+/* Computing MIN */
+ i__5 = k, i__6 = n - jc;
+ i__7 = k;
+ for (jr = min(i__5,i__6) + 1; jr <= i__7; ++jr) {
+ i__5 = jr + 1 + jc * a_dim1;
+ a[i__5].r = 0., a[i__5].i = 0.;
+/* L130: */
+ }
+/* L140: */
+ }
+
+/* Call ZHBTRD to compute S and U from lower triangle */
+
+ i__4 = k + 1;
+ zlacpy_(" ", &i__4, &n, &a[a_offset], lda, &work[1], lda);
+
+ ntest = 3;
+ zhbtrd_("V", "L", &n, &k, &work[1], lda, &sd[1], &se[1], &u[
+ u_offset], ldu, &work[*lda * n + 1], &iinfo);
+
+ if (iinfo != 0) {
+ io___40.ciunit = *nounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "ZHBTRD(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[3] = ulpinv;
+ goto L150;
+ }
+ }
+ ntest = 4;
+
+/* Do tests 3 and 4 */
+
+ zhbt21_("Lower", &n, &k, &c__1, &a[a_offset], lda, &sd[1], &
+ se[1], &u[u_offset], ldu, &work[1], &rwork[1], &
+ result[3]);
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L150:
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__4 = ntest;
+ for (jr = 1; jr <= i__4; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "ZHB", (ftnlen)3);
+ e_wsfe();
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ e_wsfe();
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ e_wsfe();
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "Hermitian", (ftnlen)9);
+ e_wsfe();
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "unitary", (ftnlen)7);
+ do_fio(&c__1, "*", (ftnlen)1);
+ do_fio(&c__1, "conjugate transpose", (ftnlen)19);
+ for (j = 1; j <= 4; ++j) {
+ do_fio(&c__1, "*", (ftnlen)1);
+ }
+ e_wsfe();
+ }
+ ++nerrs;
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+/* L160: */
+ }
+
+L170:
+ ;
+ }
+L180:
+ ;
+ }
+/* L190: */
+ }
+
+/* Summary */
+
+ dlasum_("ZHB", nounit, &nerrs, &ntestt);
+ return 0;
+
+
+
+
+/* End of ZCHKHB */
+
+} /* zchkhb_ */
diff --git a/TESTING/EIG/zchkhs.c b/TESTING/EIG/zchkhs.c
new file mode 100644
index 0000000..b459bf4
--- /dev/null
+++ b/TESTING/EIG/zchkhs.c
@@ -0,0 +1,1434 @@
+/* zchkhs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+static doublereal c_b27 = 1.;
+static integer c__0 = 0;
+static doublereal c_b33 = 0.;
+static integer c__4 = 4;
+static integer c__6 = 6;
+
+/* Subroutine */ int zchkhs_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
+ doublecomplex *a, integer *lda, doublecomplex *h__, doublecomplex *t1,
+ doublecomplex *t2, doublecomplex *u, integer *ldu, doublecomplex *
+ z__, doublecomplex *uz, doublecomplex *w1, doublecomplex *w3,
+ doublecomplex *evectl, doublecomplex *evectr, doublecomplex *evecty,
+ doublecomplex *evectx, doublecomplex *uu, doublecomplex *tau,
+ doublecomplex *work, integer *nwork, doublereal *rwork, integer *
+ iwork, logical *select, doublereal *result, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
+ static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
+ static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ZCHKHS: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 ZCHKHS: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
+ "i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9997[] = "(\002 ZCHKHS: Selected \002,a,\002 Eigenvector"
+ "s from \002,a,\002 do not match other eigenvectors \002,9x,\002N="
+ "\002,i6,\002, JTYPE=\002,i6,\002, ISEED=(\002,3(i5,\002,\002),i5,"
+ "\002)\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, evectl_dim1, evectl_offset, evectr_dim1,
+ evectr_offset, evectx_dim1, evectx_offset, evecty_dim1,
+ evecty_offset, h_dim1, h_offset, t1_dim1, t1_offset, t2_dim1,
+ t2_offset, u_dim1, u_offset, uu_dim1, uu_offset, uz_dim1,
+ uz_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double z_abs(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, n, n1, jj, in, ihi, ilo;
+ doublereal ulp, cond;
+ integer jcol, nmax;
+ doublereal unfl, ovfl, temp1, temp2;
+ logical badnn, match;
+ integer imode;
+ doublereal dumma[4];
+ integer iinfo;
+ doublereal conds;
+ extern /* Subroutine */ int zget10_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *, doublereal *);
+ doublereal aninv, anorm;
+ extern /* Subroutine */ int zget22_(char *, char *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublereal *, doublereal *), zgemm_(char *, char *, integer *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer nmats, jsize, nerrs, itype, jtype, ntest;
+ extern /* Subroutine */ int zhst01_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *), zcopy_(integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *);
+ doublereal rtulp;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ doublecomplex cdumma[4];
+ integer idumma[1];
+ extern /* Subroutine */ int dlafts_(char *, integer *, integer *, integer
+ *, integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int xerbla_(char *, integer *), zgehrd_(
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *), dlasum_(
+ char *, integer *, integer *, integer *), zlatme_(integer
+ *, char *, integer *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, char *, char *, char *, char *, doublereal *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *), zhsein_(char *, char *, char *,
+ logical *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+, integer *, doublecomplex *, doublereal *, integer *, integer *,
+ integer *), zlacpy_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *), zlatmr_(
+ integer *, integer *, char *, integer *, char *, doublecomplex *,
+ integer *, doublereal *, doublecomplex *, char *, char *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ integer *, doublereal *, char *, integer *, integer *, integer *,
+ doublereal *, doublereal *, char *, doublecomplex *, integer *,
+ integer *, integer *);
+ doublereal rtunfl, rtovfl, rtulpi, ulpinv;
+ integer mtypes, ntestt;
+ extern /* Subroutine */ int zhseqr_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *), zlatms_(integer *, integer *, char *, integer *,
+ char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublecomplex *, integer *,
+ doublecomplex *, integer *), ztrevc_(char
+ *, char *, logical *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ integer *, doublecomplex *, doublereal *, integer *), zunghr_(integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *
+), zunmhr_(char *, char *, integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKHS checks the nonsymmetric eigenvalue problem routines. */
+
+/* ZGEHRD factors A as U H U' , where ' means conjugate */
+/* transpose, H is hessenberg, and U is unitary. */
+
+/* ZUNGHR generates the unitary matrix U. */
+
+/* ZUNMHR multiplies a matrix by the unitary matrix U. */
+
+/* ZHSEQR factors H as Z T Z' , where Z is unitary and T */
+/* is upper triangular. It also computes the eigenvalues, */
+/* w(1), ..., w(n); we define a diagonal matrix W whose */
+/* (diagonal) entries are the eigenvalues. */
+
+/* ZTREVC computes the left eigenvector matrix L and the */
+/* right eigenvector matrix R for the matrix T. The */
+/* columns of L are the complex conjugates of the left */
+/* eigenvectors of T. The columns of R are the right */
+/* eigenvectors of T. L is lower triangular, and R is */
+/* upper triangular. */
+
+/* ZHSEIN computes the left eigenvector matrix Y and the */
+/* right eigenvector matrix X for the matrix H. The */
+/* columns of Y are the complex conjugates of the left */
+/* eigenvectors of H. The columns of X are the right */
+/* eigenvectors of H. Y is lower triangular, and X is */
+/* upper triangular. */
+
+/* When ZCHKHS is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 14 */
+/* tests will be performed: */
+
+/* (1) | A - U H U**H | / ( |A| n ulp ) */
+
+/* (2) | I - UU**H | / ( n ulp ) */
+
+/* (3) | H - Z T Z**H | / ( |H| n ulp ) */
+
+/* (4) | I - ZZ**H | / ( n ulp ) */
+
+/* (5) | A - UZ H (UZ)**H | / ( |A| n ulp ) */
+
+/* (6) | I - UZ (UZ)**H | / ( n ulp ) */
+
+/* (7) | T(Z computed) - T(Z not computed) | / ( |T| ulp ) */
+
+/* (8) | W(Z computed) - W(Z not computed) | / ( |W| ulp ) */
+
+/* (9) | TR - RW | / ( |T| |R| ulp ) */
+
+/* (10) | L**H T - W**H L | / ( |T| |L| ulp ) */
+
+/* (11) | HX - XW | / ( |H| |X| ulp ) */
+
+/* (12) | Y**H H - W**H Y | / ( |H| |Y| ulp ) */
+
+/* (13) | AX - XW | / ( |A| |X| ulp ) */
+
+/* (14) | Y**H A - W**H Y | / ( |A| |Y| ulp ) */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
+
+/* (4) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random complex angles. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (5) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random complex angles. */
+/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random complex angles. */
+
+/* (7) Same as (4), but multiplied by SQRT( overflow threshold ) */
+/* (8) Same as (4), but multiplied by SQRT( underflow threshold ) */
+
+/* (9) A matrix of the form U' T U, where U is unitary and */
+/* T has evenly spaced entries 1, ..., ULP with random complex */
+/* angles on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (10) A matrix of the form U' T U, where U is unitary and */
+/* T has geometrically spaced entries 1, ..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (11) A matrix of the form U' T U, where U is unitary and */
+/* T has "clustered" entries 1, ULP,..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (12) A matrix of the form U' T U, where U is unitary and */
+/* T has complex eigenvalues randomly chosen from */
+/* ULP < |z| < 1 and random O(1) entries in the upper */
+/* triangle. */
+
+/* (13) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
+/* with random complex angles on the diagonal and random O(1) */
+/* entries in the upper triangle. */
+
+/* (14) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has geometrically spaced entries */
+/* 1, ..., ULP with random complex angles on the diagonal */
+/* and random O(1) entries in the upper triangle. */
+
+/* (15) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
+/* with random complex angles on the diagonal and random O(1) */
+/* entries in the upper triangle. */
+
+/* (16) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has complex eigenvalues randomly chosen */
+/* from ULP < |z| < 1 and random O(1) entries in the upper */
+/* triangle. */
+
+/* (17) Same as (16), but multiplied by SQRT( overflow threshold ) */
+/* (18) Same as (16), but multiplied by SQRT( underflow threshold ) */
+
+/* (19) Nonsymmetric matrix with random entries chosen from |z| < 1 */
+/* (20) Same as (19), but multiplied by SQRT( overflow threshold ) */
+/* (21) Same as (19), but multiplied by SQRT( underflow threshold ) */
+
+/* Arguments */
+/* ========== */
+
+/* NSIZES - INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* ZCHKHS does nothing. It must be at least zero. */
+/* Not modified. */
+
+/* NN - INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+/* Not modified. */
+
+/* NTYPES - INTEGER */
+/* The number of elements in DOTYPE. If it is zero, ZCHKHS */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+/* Not modified. */
+
+/* DOTYPE - LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to ZCHKHS to continue the same random number */
+/* sequence. */
+/* Modified. */
+
+/* THRESH - DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+/* Not modified. */
+
+/* NOUNIT - INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+/* Not modified. */
+
+/* A - COMPLEX*16 array, dimension (LDA,max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually */
+/* used. */
+/* Modified. */
+
+/* LDA - INTEGER */
+/* The leading dimension of A, H, T1 and T2. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* H - COMPLEX*16 array, dimension (LDA,max(NN)) */
+/* The upper hessenberg matrix computed by ZGEHRD. On exit, */
+/* H contains the Hessenberg form of the matrix in A. */
+/* Modified. */
+
+/* T1 - COMPLEX*16 array, dimension (LDA,max(NN)) */
+/* The Schur (="quasi-triangular") matrix computed by ZHSEQR */
+/* if Z is computed. On exit, T1 contains the Schur form of */
+/* the matrix in A. */
+/* Modified. */
+
+/* T2 - COMPLEX*16 array, dimension (LDA,max(NN)) */
+/* The Schur matrix computed by ZHSEQR when Z is not computed. */
+/* This should be identical to T1. */
+/* Modified. */
+
+/* LDU - INTEGER */
+/* The leading dimension of U, Z, UZ and UU. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* U - COMPLEX*16 array, dimension (LDU,max(NN)) */
+/* The unitary matrix computed by ZGEHRD. */
+/* Modified. */
+
+/* Z - COMPLEX*16 array, dimension (LDU,max(NN)) */
+/* The unitary matrix computed by ZHSEQR. */
+/* Modified. */
+
+/* UZ - COMPLEX*16 array, dimension (LDU,max(NN)) */
+/* The product of U times Z. */
+/* Modified. */
+
+/* W1 - COMPLEX*16 array, dimension (max(NN)) */
+/* The eigenvalues of A, as computed by a full Schur */
+/* decomposition H = Z T Z'. On exit, W1 contains the */
+/* eigenvalues of the matrix in A. */
+/* Modified. */
+
+/* W3 - COMPLEX*16 array, dimension (max(NN)) */
+/* The eigenvalues of A, as computed by a partial Schur */
+/* decomposition (Z not computed, T only computed as much */
+/* as is necessary for determining eigenvalues). On exit, */
+/* W3 contains the eigenvalues of the matrix in A, possibly */
+/* perturbed by ZHSEIN. */
+/* Modified. */
+
+/* EVECTL - COMPLEX*16 array, dimension (LDU,max(NN)) */
+/* The conjugate transpose of the (upper triangular) left */
+/* eigenvector matrix for the matrix in T1. */
+/* Modified. */
+
+/* EVEZTR - COMPLEX*16 array, dimension (LDU,max(NN)) */
+/* The (upper triangular) right eigenvector matrix for the */
+/* matrix in T1. */
+/* Modified. */
+
+/* EVECTY - COMPLEX*16 array, dimension (LDU,max(NN)) */
+/* The conjugate transpose of the left eigenvector matrix */
+/* for the matrix in H. */
+/* Modified. */
+
+/* EVECTX - COMPLEX*16 array, dimension (LDU,max(NN)) */
+/* The right eigenvector matrix for the matrix in H. */
+/* Modified. */
+
+/* UU - COMPLEX*16 array, dimension (LDU,max(NN)) */
+/* Details of the unitary matrix computed by ZGEHRD. */
+/* Modified. */
+
+/* TAU - COMPLEX*16 array, dimension (max(NN)) */
+/* Further details of the unitary matrix computed by ZGEHRD. */
+/* Modified. */
+
+/* WORK - COMPLEX*16 array, dimension (NWORK) */
+/* Workspace. */
+/* Modified. */
+
+/* NWORK - INTEGER */
+/* The number of entries in WORK. NWORK >= 4*NN(j)*NN(j) + 2. */
+
+/* RWORK - DOUBLE PRECISION array, dimension (max(NN)) */
+/* Workspace. Could be equivalenced to IWORK, but not SELECT. */
+/* Modified. */
+
+/* IWORK - INTEGER array, dimension (max(NN)) */
+/* Workspace. */
+/* Modified. */
+
+/* SELECT - LOGICAL array, dimension (max(NN)) */
+/* Workspace. Could be equivalenced to IWORK, but not RWORK. */
+/* Modified. */
+
+/* RESULT - DOUBLE PRECISION array, dimension (14) */
+/* The values computed by the fourteen tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+/* Modified. */
+
+/* INFO - INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -6: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -14: LDU < 1 or LDU < NMAX. */
+/* -26: NWORK too small. */
+/* If ZLATMR, CLATMS, or CLATME returns an error code, the */
+/* absolute value of it is returned. */
+/* If 1, then ZHSEQR could not find all the shifts. */
+/* If 2, then the EISPACK code (for small blocks) failed. */
+/* If >2, then 30*N iterations were not enough to find an */
+/* eigenvalue or to decompose the problem. */
+/* Modified. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* MTEST The number of tests defined: care must be taken */
+/* that (1) the size of RESULT, (2) the number of */
+/* tests actually performed, and (3) MTEST agree. */
+/* NTEST The number of tests performed on this matrix */
+/* so far. This should be less than MTEST, and */
+/* equal to it by the last test. It will be less */
+/* if any of the routines being tested indicates */
+/* that it could not compute the matrices that */
+/* would be tested. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far (computed by DLAFTS). */
+/* COND, CONDS, */
+/* IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL, */
+/* RTULP, RTULPI Square roots of the previous 4 values. */
+
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+/* KCONDS(j) Selects whether CONDS is to be 1 or */
+/* 1/sqrt(ulp). (0 means irrelevant.) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ t2_dim1 = *lda;
+ t2_offset = 1 + t2_dim1;
+ t2 -= t2_offset;
+ t1_dim1 = *lda;
+ t1_offset = 1 + t1_dim1;
+ t1 -= t1_offset;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ uu_dim1 = *ldu;
+ uu_offset = 1 + uu_dim1;
+ uu -= uu_offset;
+ evectx_dim1 = *ldu;
+ evectx_offset = 1 + evectx_dim1;
+ evectx -= evectx_offset;
+ evecty_dim1 = *ldu;
+ evecty_offset = 1 + evecty_dim1;
+ evecty -= evecty_offset;
+ evectr_dim1 = *ldu;
+ evectr_offset = 1 + evectr_dim1;
+ evectr -= evectr_offset;
+ evectl_dim1 = *ldu;
+ evectl_offset = 1 + evectl_dim1;
+ evectl -= evectl_offset;
+ uz_dim1 = *ldu;
+ uz_offset = 1 + uz_dim1;
+ uz -= uz_offset;
+ z_dim1 = *ldu;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --w1;
+ --w3;
+ --tau;
+ --work;
+ --rwork;
+ --iwork;
+ --select;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 0;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.) {
+ *info = -6;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldu <= 1 || *ldu < nmax) {
+ *info = -14;
+ } else if ((nmax << 2) * nmax + 2 > *nwork) {
+ *info = -26;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZCHKHS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More important constants */
+
+ unfl = dlamch_("Safe minimum");
+ ovfl = dlamch_("Overflow");
+ dlabad_(&unfl, &ovfl);
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ ulpinv = 1. / ulp;
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+ rtulp = sqrt(ulp);
+ rtulpi = 1. / rtulp;
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ n1 = max(1,n);
+ aninv = 1. / (doublereal) n1;
+
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L250;
+ }
+ ++nmats;
+ ntest = 0;
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 14; ++j) {
+ result[j] = 0.;
+/* L30: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KCONDS KMODE KTYPE */
+/* =1 O(1) 1 clustered 1 zero */
+/* =2 large large clustered 2 identity */
+/* =3 small exponential Jordan */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log hermitian, w/ eigenvalues */
+/* =6 random general, w/ eigenvalues */
+/* =7 random diagonal */
+/* =8 random hermitian */
+/* =9 random general */
+/* =10 random triangular */
+
+ if (mtypes > 21) {
+ goto L100;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * aninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * n * ulpinv;
+ goto L70;
+
+L70:
+
+ zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices */
+
+ if (itype == 1) {
+
+/* Zero */
+
+ iinfo = 0;
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ a[i__4].r = anorm, a[i__4].i = 0.;
+/* L80: */
+ }
+
+ } else if (itype == 3) {
+
+/* Jordan Block */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ a[i__4].r = anorm, a[i__4].i = 0.;
+ if (jcol > 1) {
+ i__4 = jcol + (jcol - 1) * a_dim1;
+ a[i__4].r = 1., a[i__4].i = 0.;
+ }
+/* L90: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &imode, &cond,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
+ n << 1) + 1], &c__1, &c_b27, "N", idumma, &c__0, &
+ c__0, &c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Hermitian, eigenvalues specified */
+
+ zlatms_(&n, &n, "D", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[1], &
+ iinfo);
+
+ } else if (itype == 6) {
+
+/* General, eigenvalues specified */
+
+ if (kconds[jtype - 1] == 1) {
+ conds = 1.;
+ } else if (kconds[jtype - 1] == 2) {
+ conds = rtulpi;
+ } else {
+ conds = 0.;
+ }
+
+ zlatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2,
+ " ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n,
+ &anorm, &a[a_offset], lda, &work[n + 1], &iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
+ n << 1) + 1], &c__1, &c_b27, "N", idumma, &c__0, &
+ c__0, &c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Hermitian, random eigenvalues */
+
+ zlatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b27,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
+ n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &n, &
+ c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* General, random eigenvalues */
+
+ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
+ n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &n, &
+ c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 10) {
+
+/* Triangular, random eigenvalues */
+
+ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b27,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b27, &work[(
+ n << 1) + 1], &c__1, &c_b27, "N", idumma, &n, &c__0, &
+ c_b33, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___35.ciunit = *nounit;
+ s_wsfe(&io___35);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L100:
+
+/* Call ZGEHRD to compute H and U, do tests. */
+
+ zlacpy_(" ", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+ ntest = 1;
+
+ ilo = 1;
+ ihi = n;
+
+ i__3 = *nwork - n;
+ zgehrd_(&n, &ilo, &ihi, &h__[h_offset], lda, &work[1], &work[n +
+ 1], &i__3, &iinfo);
+
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___38.ciunit = *nounit;
+ s_wsfe(&io___38);
+ do_fio(&c__1, "ZGEHRD", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L240;
+ }
+
+ i__3 = n - 1;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j + 1 + j * uu_dim1;
+ uu[i__4].r = 0., uu[i__4].i = 0.;
+ i__4 = n;
+ for (i__ = j + 2; i__ <= i__4; ++i__) {
+ i__5 = i__ + j * u_dim1;
+ i__6 = i__ + j * h_dim1;
+ u[i__5].r = h__[i__6].r, u[i__5].i = h__[i__6].i;
+ i__5 = i__ + j * uu_dim1;
+ i__6 = i__ + j * h_dim1;
+ uu[i__5].r = h__[i__6].r, uu[i__5].i = h__[i__6].i;
+ i__5 = i__ + j * h_dim1;
+ h__[i__5].r = 0., h__[i__5].i = 0.;
+/* L110: */
+ }
+/* L120: */
+ }
+ i__3 = n - 1;
+ zcopy_(&i__3, &work[1], &c__1, &tau[1], &c__1);
+ i__3 = *nwork - n;
+ zunghr_(&n, &ilo, &ihi, &u[u_offset], ldu, &work[1], &work[n + 1],
+ &i__3, &iinfo);
+ ntest = 2;
+
+ zhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &h__[h_offset], lda, &
+ u[u_offset], ldu, &work[1], nwork, &rwork[1], &result[1]);
+
+/* Call ZHSEQR to compute T1, T2 and Z, do tests. */
+
+/* Eigenvalues only (W3) */
+
+ zlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
+ ntest = 3;
+ result[3] = ulpinv;
+
+ zhseqr_("E", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &w3[1], &
+ uz[uz_offset], ldu, &work[1], nwork, &iinfo);
+ if (iinfo != 0) {
+ io___40.ciunit = *nounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "ZHSEQR(E)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ if (iinfo <= n + 2) {
+ *info = abs(iinfo);
+ goto L240;
+ }
+ }
+
+/* Eigenvalues (W1) and Full Schur Form (T2) */
+
+ zlacpy_(" ", &n, &n, &h__[h_offset], lda, &t2[t2_offset], lda);
+
+ zhseqr_("S", "N", &n, &ilo, &ihi, &t2[t2_offset], lda, &w1[1], &
+ uz[uz_offset], ldu, &work[1], nwork, &iinfo);
+ if (iinfo != 0 && iinfo <= n + 2) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "ZHSEQR(S)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L240;
+ }
+
+/* Eigenvalues (W1), Schur Form (T1), and Schur Vectors (UZ) */
+
+ zlacpy_(" ", &n, &n, &h__[h_offset], lda, &t1[t1_offset], lda);
+ zlacpy_(" ", &n, &n, &u[u_offset], ldu, &uz[uz_offset], ldu);
+
+ zhseqr_("S", "V", &n, &ilo, &ihi, &t1[t1_offset], lda, &w1[1], &
+ uz[uz_offset], ldu, &work[1], nwork, &iinfo);
+ if (iinfo != 0 && iinfo <= n + 2) {
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "ZHSEQR(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L240;
+ }
+
+/* Compute Z = U' UZ */
+
+ zgemm_("C", "N", &n, &n, &n, &c_b2, &u[u_offset], ldu, &uz[
+ uz_offset], ldu, &c_b1, &z__[z_offset], ldu);
+ ntest = 8;
+
+/* Do Tests 3: | H - Z T Z' | / ( |H| n ulp ) */
+/* and 4: | I - Z Z' | / ( n ulp ) */
+
+ zhst01_(&n, &ilo, &ihi, &h__[h_offset], lda, &t1[t1_offset], lda,
+ &z__[z_offset], ldu, &work[1], nwork, &rwork[1], &result[
+ 3]);
+
+/* Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp ) */
+/* and 6: | I - UZ (UZ)' | / ( n ulp ) */
+
+ zhst01_(&n, &ilo, &ihi, &a[a_offset], lda, &t1[t1_offset], lda, &
+ uz[uz_offset], ldu, &work[1], nwork, &rwork[1], &result[5]
+);
+
+/* Do Test 7: | T2 - T1 | / ( |T| n ulp ) */
+
+ zget10_(&n, &n, &t2[t2_offset], lda, &t1[t1_offset], lda, &work[1]
+, &rwork[1], &result[7]);
+
+/* Do Test 8: | W3 - W1 | / ( max(|W1|,|W3|) ulp ) */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__1 = temp1, d__2 = z_abs(&w1[j]), d__1 = max(d__1,d__2),
+ d__2 = z_abs(&w3[j]);
+ temp1 = max(d__1,d__2);
+/* Computing MAX */
+ i__4 = j;
+ i__5 = j;
+ z__1.r = w1[i__4].r - w3[i__5].r, z__1.i = w1[i__4].i - w3[
+ i__5].i;
+ d__1 = temp2, d__2 = z_abs(&z__1);
+ temp2 = max(d__1,d__2);
+/* L130: */
+ }
+
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[8] = temp2 / max(d__1,d__2);
+
+/* Compute the Left and Right Eigenvectors of T */
+
+/* Compute the Right eigenvector Matrix: */
+
+ ntest = 9;
+ result[9] = ulpinv;
+
+/* Select every other eigenvector */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ select[j] = FALSE_;
+/* L140: */
+ }
+ i__3 = n;
+ for (j = 1; j <= i__3; j += 2) {
+ select[j] = TRUE_;
+/* L150: */
+ }
+ ztrevc_("Right", "All", &select[1], &n, &t1[t1_offset], lda,
+ cdumma, ldu, &evectr[evectr_offset], ldu, &n, &in, &work[
+ 1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ do_fio(&c__1, "ZTREVC(R,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L240;
+ }
+
+/* Test 9: | TR - RW | / ( |T| |R| ulp ) */
+
+ zget22_("N", "N", "N", &n, &t1[t1_offset], lda, &evectr[
+ evectr_offset], ldu, &w1[1], &work[1], &rwork[1], dumma);
+ result[9] = dumma[0];
+ if (dumma[1] > *thresh) {
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "ZTREVC", (ftnlen)6);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Compute selected right eigenvectors and confirm that */
+/* they agree with previous right eigenvectors */
+
+ ztrevc_("Right", "Some", &select[1], &n, &t1[t1_offset], lda,
+ cdumma, ldu, &evectl[evectl_offset], ldu, &n, &in, &work[
+ 1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ do_fio(&c__1, "ZTREVC(R,S)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L240;
+ }
+
+ k = 1;
+ match = TRUE_;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ if (select[j]) {
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ i__5 = jj + j * evectr_dim1;
+ i__6 = jj + k * evectl_dim1;
+ if (evectr[i__5].r != evectl[i__6].r || evectr[i__5]
+ .i != evectl[i__6].i) {
+ match = FALSE_;
+ goto L180;
+ }
+/* L160: */
+ }
+ ++k;
+ }
+/* L170: */
+ }
+L180:
+ if (! match) {
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "ZTREVC", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Compute the Left eigenvector Matrix: */
+
+ ntest = 10;
+ result[10] = ulpinv;
+ ztrevc_("Left", "All", &select[1], &n, &t1[t1_offset], lda, &
+ evectl[evectl_offset], ldu, cdumma, ldu, &n, &in, &work[1]
+, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+ do_fio(&c__1, "ZTREVC(L,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L240;
+ }
+
+/* Test 10: | LT - WL | / ( |T| |L| ulp ) */
+
+ zget22_("C", "N", "C", &n, &t1[t1_offset], lda, &evectl[
+ evectl_offset], ldu, &w1[1], &work[1], &rwork[1], &dumma[
+ 2]);
+ result[10] = dumma[2];
+ if (dumma[3] > *thresh) {
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "ZTREVC", (ftnlen)6);
+ do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Compute selected left eigenvectors and confirm that */
+/* they agree with previous left eigenvectors */
+
+ ztrevc_("Left", "Some", &select[1], &n, &t1[t1_offset], lda, &
+ evectr[evectr_offset], ldu, cdumma, ldu, &n, &in, &work[1]
+, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, "ZTREVC(L,S)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L240;
+ }
+
+ k = 1;
+ match = TRUE_;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ if (select[j]) {
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ i__5 = jj + j * evectl_dim1;
+ i__6 = jj + k * evectr_dim1;
+ if (evectl[i__5].r != evectr[i__6].r || evectl[i__5]
+ .i != evectr[i__6].i) {
+ match = FALSE_;
+ goto L210;
+ }
+/* L190: */
+ }
+ ++k;
+ }
+/* L200: */
+ }
+L210:
+ if (! match) {
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "ZTREVC", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Call ZHSEIN for Right eigenvectors of H, do test 11 */
+
+ ntest = 11;
+ result[11] = ulpinv;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ select[j] = TRUE_;
+/* L220: */
+ }
+
+ zhsein_("Right", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
+ lda, &w3[1], cdumma, ldu, &evectx[evectx_offset], ldu, &
+ n1, &in, &work[1], &rwork[1], &iwork[1], &iwork[1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, "ZHSEIN(R)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ goto L240;
+ }
+ } else {
+
+/* Test 11: | HX - XW | / ( |H| |X| ulp ) */
+
+/* (from inverse iteration) */
+
+ zget22_("N", "N", "N", &n, &h__[h_offset], lda, &evectx[
+ evectx_offset], ldu, &w3[1], &work[1], &rwork[1],
+ dumma);
+ if (dumma[0] < ulpinv) {
+ result[11] = dumma[0] * aninv;
+ }
+ if (dumma[1] > *thresh) {
+ io___60.ciunit = *nounit;
+ s_wsfe(&io___60);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "ZHSEIN", (ftnlen)6);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ }
+ }
+
+/* Call ZHSEIN for Left eigenvectors of H, do test 12 */
+
+ ntest = 12;
+ result[12] = ulpinv;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ select[j] = TRUE_;
+/* L230: */
+ }
+
+ zhsein_("Left", "Qr", "Ninitv", &select[1], &n, &h__[h_offset],
+ lda, &w3[1], &evecty[evecty_offset], ldu, cdumma, ldu, &
+ n1, &in, &work[1], &rwork[1], &iwork[1], &iwork[1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___61.ciunit = *nounit;
+ s_wsfe(&io___61);
+ do_fio(&c__1, "ZHSEIN(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ goto L240;
+ }
+ } else {
+
+/* Test 12: | YH - WY | / ( |H| |Y| ulp ) */
+
+/* (from inverse iteration) */
+
+ zget22_("C", "N", "C", &n, &h__[h_offset], lda, &evecty[
+ evecty_offset], ldu, &w3[1], &work[1], &rwork[1], &
+ dumma[2]);
+ if (dumma[2] < ulpinv) {
+ result[12] = dumma[2] * aninv;
+ }
+ if (dumma[3] > *thresh) {
+ io___62.ciunit = *nounit;
+ s_wsfe(&io___62);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "ZHSEIN", (ftnlen)6);
+ do_fio(&c__1, (char *)&dumma[3], (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ }
+ }
+
+/* Call ZUNMHR for Right eigenvectors of A, do test 13 */
+
+ ntest = 13;
+ result[13] = ulpinv;
+
+ zunmhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
+, ldu, &tau[1], &evectx[evectx_offset], ldu, &work[1],
+ nwork, &iinfo);
+ if (iinfo != 0) {
+ io___63.ciunit = *nounit;
+ s_wsfe(&io___63);
+ do_fio(&c__1, "ZUNMHR(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ goto L240;
+ }
+ } else {
+
+/* Test 13: | AX - XW | / ( |A| |X| ulp ) */
+
+/* (from inverse iteration) */
+
+ zget22_("N", "N", "N", &n, &a[a_offset], lda, &evectx[
+ evectx_offset], ldu, &w3[1], &work[1], &rwork[1],
+ dumma);
+ if (dumma[0] < ulpinv) {
+ result[13] = dumma[0] * aninv;
+ }
+ }
+
+/* Call ZUNMHR for Left eigenvectors of A, do test 14 */
+
+ ntest = 14;
+ result[14] = ulpinv;
+
+ zunmhr_("Left", "No transpose", &n, &n, &ilo, &ihi, &uu[uu_offset]
+, ldu, &tau[1], &evecty[evecty_offset], ldu, &work[1],
+ nwork, &iinfo);
+ if (iinfo != 0) {
+ io___64.ciunit = *nounit;
+ s_wsfe(&io___64);
+ do_fio(&c__1, "ZUNMHR(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ goto L240;
+ }
+ } else {
+
+/* Test 14: | YA - WY | / ( |A| |Y| ulp ) */
+
+/* (from inverse iteration) */
+
+ zget22_("C", "N", "C", &n, &a[a_offset], lda, &evecty[
+ evecty_offset], ldu, &w3[1], &work[1], &rwork[1], &
+ dumma[2]);
+ if (dumma[2] < ulpinv) {
+ result[14] = dumma[2] * aninv;
+ }
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L240:
+
+ ntestt += ntest;
+ dlafts_("ZHS", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh,
+ nounit, &nerrs);
+
+L250:
+ ;
+ }
+/* L260: */
+ }
+
+/* Summary */
+
+ dlasum_("ZHS", nounit, &nerrs, &ntestt);
+
+ return 0;
+
+
+/* End of ZCHKHS */
+
+} /* zchkhs_ */
diff --git a/TESTING/EIG/zchkst.c b/TESTING/EIG/zchkst.c
new file mode 100644
index 0000000..4917965
--- /dev/null
+++ b/TESTING/EIG/zchkst.c
@@ -0,0 +1,2464 @@
+/* zchkst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__6 = 6;
+static doublereal c_b39 = 1.;
+static doublereal c_b49 = 0.;
+static integer c__4 = 4;
+static integer c__3 = 3;
+static integer c__10 = 10;
+static integer c__11 = 11;
+
+/* Subroutine */ int zchkst_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
+ doublecomplex *a, integer *lda, doublecomplex *ap, doublereal *sd,
+ doublereal *se, doublereal *d1, doublereal *d2, doublereal *d3,
+ doublereal *d4, doublereal *d5, doublereal *wa1, doublereal *wa2,
+ doublereal *wa3, doublereal *wr, doublecomplex *u, integer *ldu,
+ doublecomplex *v, doublecomplex *vp, doublecomplex *tau,
+ doublecomplex *z__, doublecomplex *work, integer *lwork, doublereal *
+ rwork, integer *lrwork, integer *iwork, integer *liwork, doublereal *
+ result, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,4,4,4,4,4,5,5,5,5,5,8,8,8,9,9,9,9,9,10 };
+ static integer kmagn[21] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3,1,1,1,2,3,1 };
+ static integer kmode[21] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0,4,3,1,4,4,3 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ZCHKST: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(/1x,a3,\002 -- Complex Hermitian eigenvalue p"
+ "roblem\002)";
+ static char fmt_9997[] = "(\002 Matrix types (see ZCHKST for details):"
+ " \002)";
+ static char fmt_9996[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 5=Diagonal: clustered ent"
+ "ries.\002,/\002 2=Identity matrix. \002,\002"
+ " 6=Diagonal: large, evenly spaced.\002,/\002 3=Diagonal: evenl"
+ "y spaced entries. \002,\002 7=Diagonal: small, evenly spaced."
+ "\002,/\002 4=Diagonal: geometr. spaced entries.\002)";
+ static char fmt_9995[] = "(\002 Dense \002,a,\002 Matrices:\002,/\002 8"
+ "=Evenly spaced eigenvals. \002,\002 12=Small, evenly "
+ "spaced eigenvals.\002,/\002 9=Geometrically spaced eigenvals. "
+ " \002,\002 13=Matrix with random O(1) entries.\002,/\002 10=Cl"
+ "ustered eigenvalues. \002,\002 14=Matrix with large"
+ " random entries.\002,/\002 11=Large, evenly spaced eigenvals. "
+ " \002,\002 15=Matrix with small random entries.\002)";
+ static char fmt_9994[] = "(\002 16=Positive definite, evenly spaced eige"
+ "nvalues\002,/\002 17=Positive definite, geometrically spaced eig"
+ "envlaues\002,/\002 18=Positive definite, clustered eigenvalue"
+ "s\002,/\002 19=Positive definite, small evenly spaced eigenvalues"
+ "\002,/\002 20=Positive definite, large evenly spaced eigenvalue"
+ "s\002,/\002 21=Diagonally dominant tridiagonal, geometrically"
+ "\002,\002 spaced eigenvalues\002)";
+ static char fmt_9987[] = "(/\002Test performed: see ZCHKST for details"
+ ".\002,/)";
+ static char fmt_9989[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
+ ",0p,f8.2)";
+ static char fmt_9988[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
+ ",1p,d10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, z_dim1,
+ z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double log(doublereal), sqrt(doublereal);
+ integer pow_ii(integer *, integer *);
+ double z_abs(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, m, n, m2, m3, jc, il, jr, iu;
+ doublereal vl, vu;
+ integer nap, lgn;
+ doublereal ulp;
+ integer inde;
+ doublereal cond;
+ integer nmax;
+ doublereal unfl, ovfl, temp1, temp2, temp3, temp4;
+ extern doublereal dsxt1_(integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *);
+ logical badnn;
+ integer imode, lwedc;
+ doublereal dumma[1];
+ integer iinfo;
+ doublereal aninv, anorm;
+ extern /* Subroutine */ int zhet21_(integer *, char *, integer *, integer
+ *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublereal *, doublereal *);
+ integer itemp;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer nmats, jsize;
+ extern /* Subroutine */ int zhpt21_(integer *, char *, integer *, integer
+ *, doublecomplex *, doublereal *, doublereal *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublereal *, doublereal *);
+ integer nerrs, itype, jtype, ntest;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zstt21_(integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, doublereal *,
+ doublereal *), zstt22_(integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+ integer iseed2[4], log2ui;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *), dlarnd_(integer *, integer *);
+ integer liwedc, nblock;
+ extern /* Subroutine */ int dstech_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ integer idumma[1];
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer ioldsd[4];
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ integer lrwedc;
+ doublereal abstol;
+ extern /* Subroutine */ int dlasum_(char *, integer *, integer *, integer
+ *), dsterf_(integer *, doublereal *, doublereal *,
+ integer *), dstebz_(char *, char *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, integer *),
+ zstedc_(char *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *, integer *, integer *, integer *);
+ integer indrwk;
+ extern /* Subroutine */ int zhetrd_(char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublecomplex *,
+ doublecomplex *, integer *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+ logical tryrac;
+ integer nsplit;
+ doublereal rtunfl, rtovfl, ulpinv;
+ integer mtypes, ntestt;
+ extern /* Subroutine */ int zhptrd_(char *, integer *, doublecomplex *,
+ doublereal *, doublereal *, doublecomplex *, integer *),
+ zlatmr_(integer *, integer *, char *, integer *, char *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *, char *,
+ char *, doublecomplex *, integer *, doublereal *, doublecomplex *
+, integer *, doublereal *, char *, integer *, integer *, integer *
+, doublereal *, doublereal *, char *, doublecomplex *, integer *,
+ integer *, integer *), zlatms_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zpteqr_(char *, integer *,
+ doublereal *, doublereal *, doublecomplex *, integer *,
+ doublereal *, integer *), zstemr_(char *, char *, integer
+ *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *, integer *, doublereal *, doublecomplex *,
+ integer *, integer *, integer *, logical *, doublereal *, integer
+ *, integer *, integer *, integer *), zstein_(
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, integer *, doublecomplex *, integer *, doublereal *,
+ integer *, integer *, integer *), zsteqr_(char *, integer *,
+ doublereal *, doublereal *, doublecomplex *, integer *,
+ doublereal *, integer *), zungtr_(char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *), zupgtr_(char *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___68 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___71 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___73 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___74 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___75 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___80 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___81 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___82 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___83 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___84 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___85 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___86 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___87 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___88 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___89 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___90 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___91 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___92 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___93 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___94 = { 0, 0, 0, fmt_9987, 0 };
+ static cilist io___95 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___96 = { 0, 0, 0, fmt_9988, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKST checks the Hermitian eigenvalue problem routines. */
+
+/* ZHETRD factors A as U S U* , where * means conjugate transpose, */
+/* S is real symmetric tridiagonal, and U is unitary. */
+/* ZHETRD can use either just the lower or just the upper triangle */
+/* of A; ZCHKST checks both cases. */
+/* U is represented as a product of Householder */
+/* transformations, whose vectors are stored in the first */
+/* n-1 columns of V, and whose scale factors are in TAU. */
+
+/* ZHPTRD does the same as ZHETRD, except that A and V are stored */
+/* in "packed" format. */
+
+/* ZUNGTR constructs the matrix U from the contents of V and TAU. */
+
+/* ZUPGTR constructs the matrix U from the contents of VP and TAU. */
+
+/* ZSTEQR factors S as Z D1 Z* , where Z is the unitary */
+/* matrix of eigenvectors and D1 is a diagonal matrix with */
+/* the eigenvalues on the diagonal. D2 is the matrix of */
+/* eigenvalues computed when Z is not computed. */
+
+/* DSTERF computes D3, the matrix of eigenvalues, by the */
+/* PWK method, which does not yield eigenvectors. */
+
+/* ZPTEQR factors S as Z4 D4 Z4* , for a */
+/* Hermitian positive definite tridiagonal matrix. */
+/* D5 is the matrix of eigenvalues computed when Z is not */
+/* computed. */
+
+/* DSTEBZ computes selected eigenvalues. WA1, WA2, and */
+/* WA3 will denote eigenvalues computed to high */
+/* absolute accuracy, with different range options. */
+/* WR will denote eigenvalues computed to high relative */
+/* accuracy. */
+
+/* ZSTEIN computes Y, the eigenvectors of S, given the */
+/* eigenvalues. */
+
+/* ZSTEDC factors S as Z D1 Z* , where Z is the unitary */
+/* matrix of eigenvectors and D1 is a diagonal matrix with */
+/* the eigenvalues on the diagonal ('I' option). It may also */
+/* update an input unitary matrix, usually the output */
+/* from ZHETRD/ZUNGTR or ZHPTRD/ZUPGTR ('V' option). It may */
+/* also just compute eigenvalues ('N' option). */
+
+/* ZSTEMR factors S as Z D1 Z* , where Z is the unitary */
+/* matrix of eigenvectors and D1 is a diagonal matrix with */
+/* the eigenvalues on the diagonal ('I' option). ZSTEMR */
+/* uses the Relatively Robust Representation whenever possible. */
+
+/* When ZCHKST is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the Hermitian eigenroutines. For each matrix, a number */
+/* of tests will be performed: */
+
+/* (1) | A - V S V* | / ( |A| n ulp ) ZHETRD( UPLO='U', ... ) */
+
+/* (2) | I - UV* | / ( n ulp ) ZUNGTR( UPLO='U', ... ) */
+
+/* (3) | A - V S V* | / ( |A| n ulp ) ZHETRD( UPLO='L', ... ) */
+
+/* (4) | I - UV* | / ( n ulp ) ZUNGTR( UPLO='L', ... ) */
+
+/* (5-8) Same as 1-4, but for ZHPTRD and ZUPGTR. */
+
+/* (9) | S - Z D Z* | / ( |S| n ulp ) ZSTEQR('V',...) */
+
+/* (10) | I - ZZ* | / ( n ulp ) ZSTEQR('V',...) */
+
+/* (11) | D1 - D2 | / ( |D1| ulp ) ZSTEQR('N',...) */
+
+/* (12) | D1 - D3 | / ( |D1| ulp ) DSTERF */
+
+/* (13) 0 if the true eigenvalues (computed by sturm count) */
+/* of S are within THRESH of */
+/* those in D1. 2*THRESH if they are not. (Tested using */
+/* DSTECH) */
+
+/* For S positive definite, */
+
+/* (14) | S - Z4 D4 Z4* | / ( |S| n ulp ) ZPTEQR('V',...) */
+
+/* (15) | I - Z4 Z4* | / ( n ulp ) ZPTEQR('V',...) */
+
+/* (16) | D4 - D5 | / ( 100 |D4| ulp ) ZPTEQR('N',...) */
+
+/* When S is also diagonally dominant by the factor gamma < 1, */
+
+/* (17) max | D4(i) - WR(i) | / ( |D4(i)| omega ) , */
+/* i */
+/* omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 */
+/* DSTEBZ( 'A', 'E', ...) */
+
+/* (18) | WA1 - D3 | / ( |D3| ulp ) DSTEBZ( 'A', 'E', ...) */
+
+/* (19) ( max { min | WA2(i)-WA3(j) | } + */
+/* i j */
+/* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) */
+/* i j */
+/* DSTEBZ( 'I', 'E', ...) */
+
+/* (20) | S - Y WA1 Y* | / ( |S| n ulp ) DSTEBZ, ZSTEIN */
+
+/* (21) | I - Y Y* | / ( n ulp ) DSTEBZ, ZSTEIN */
+
+/* (22) | S - Z D Z* | / ( |S| n ulp ) ZSTEDC('I') */
+
+/* (23) | I - ZZ* | / ( n ulp ) ZSTEDC('I') */
+
+/* (24) | S - Z D Z* | / ( |S| n ulp ) ZSTEDC('V') */
+
+/* (25) | I - ZZ* | / ( n ulp ) ZSTEDC('V') */
+
+/* (26) | D1 - D2 | / ( |D1| ulp ) ZSTEDC('V') and */
+/* ZSTEDC('N') */
+
+/* Test 27 is disabled at the moment because ZSTEMR does not */
+/* guarantee high relatvie accuracy. */
+
+/* (27) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , */
+/* i */
+/* omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 */
+/* ZSTEMR('V', 'A') */
+
+/* (28) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , */
+/* i */
+/* omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 */
+/* ZSTEMR('V', 'I') */
+
+/* Tests 29 through 34 are disable at present because ZSTEMR */
+/* does not handle partial specturm requests. */
+
+/* (29) | S - Z D Z* | / ( |S| n ulp ) ZSTEMR('V', 'I') */
+
+/* (30) | I - ZZ* | / ( n ulp ) ZSTEMR('V', 'I') */
+
+/* (31) ( max { min | WA2(i)-WA3(j) | } + */
+/* i j */
+/* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) */
+/* i j */
+/* ZSTEMR('N', 'I') vs. CSTEMR('V', 'I') */
+
+/* (32) | S - Z D Z* | / ( |S| n ulp ) ZSTEMR('V', 'V') */
+
+/* (33) | I - ZZ* | / ( n ulp ) ZSTEMR('V', 'V') */
+
+/* (34) ( max { min | WA2(i)-WA3(j) | } + */
+/* i j */
+/* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) */
+/* i j */
+/* ZSTEMR('N', 'V') vs. CSTEMR('V', 'V') */
+
+/* (35) | S - Z D Z* | / ( |S| n ulp ) ZSTEMR('V', 'A') */
+
+/* (36) | I - ZZ* | / ( n ulp ) ZSTEMR('V', 'A') */
+
+/* (37) ( max { min | WA2(i)-WA3(j) | } + */
+/* i j */
+/* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) */
+/* i j */
+/* ZSTEMR('N', 'A') vs. CSTEMR('V', 'A') */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (6) Same as (4), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (4), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U* D U, where U is unitary and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U* D U, where U is unitary and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U* D U, where U is unitary and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) Hermitian matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
+/* (16) Same as (8), but diagonal elements are all positive. */
+/* (17) Same as (9), but diagonal elements are all positive. */
+/* (18) Same as (10), but diagonal elements are all positive. */
+/* (19) Same as (16), but multiplied by SQRT( overflow threshold ) */
+/* (20) Same as (16), but multiplied by SQRT( underflow threshold ) */
+/* (21) A diagonally dominant tridiagonal matrix with geometrically */
+/* spaced diagonal entries 1, ..., ULP. */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* ZCHKST does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, ZCHKST */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to ZCHKST to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace/output) COMPLEX*16 array of */
+/* dimension ( LDA , max(NN) ) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually */
+/* used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at */
+/* least 1 and at least max( NN ). */
+
+/* AP (workspace) COMPLEX*16 array of */
+/* dimension( max(NN)*max(NN+1)/2 ) */
+/* The matrix A stored in packed format. */
+
+/* SD (workspace/output) DOUBLE PRECISION array of */
+/* dimension( max(NN) ) */
+/* The diagonal of the tridiagonal matrix computed by ZHETRD. */
+/* On exit, SD and SE contain the tridiagonal form of the */
+/* matrix in A. */
+
+/* SE (workspace/output) DOUBLE PRECISION array of */
+/* dimension( max(NN) ) */
+/* The off-diagonal of the tridiagonal matrix computed by */
+/* ZHETRD. On exit, SD and SE contain the tridiagonal form of */
+/* the matrix in A. */
+
+/* D1 (workspace/output) DOUBLE PRECISION array of */
+/* dimension( max(NN) ) */
+/* The eigenvalues of A, as computed by ZSTEQR simlutaneously */
+/* with Z. On exit, the eigenvalues in D1 correspond with the */
+/* matrix in A. */
+
+/* D2 (workspace/output) DOUBLE PRECISION array of */
+/* dimension( max(NN) ) */
+/* The eigenvalues of A, as computed by ZSTEQR if Z is not */
+/* computed. On exit, the eigenvalues in D2 correspond with */
+/* the matrix in A. */
+
+/* D3 (workspace/output) DOUBLE PRECISION array of */
+/* dimension( max(NN) ) */
+/* The eigenvalues of A, as computed by DSTERF. On exit, the */
+/* eigenvalues in D3 correspond with the matrix in A. */
+
+/* U (workspace/output) COMPLEX*16 array of */
+/* dimension( LDU, max(NN) ). */
+/* The unitary matrix computed by ZHETRD + ZUNGTR. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U, Z, and V. It must be at least 1 */
+/* and at least max( NN ). */
+
+/* V (workspace/output) COMPLEX*16 array of */
+/* dimension( LDU, max(NN) ). */
+/* The Housholder vectors computed by ZHETRD in reducing A to */
+/* tridiagonal form. The vectors computed with UPLO='U' are */
+/* in the upper triangle, and the vectors computed with UPLO='L' */
+/* are in the lower triangle. (As described in ZHETRD, the */
+/* sub- and superdiagonal are not set to 1, although the */
+/* true Householder vector has a 1 in that position. The */
+/* routines that use V, such as ZUNGTR, set those entries to */
+/* 1 before using them, and then restore them later.) */
+
+/* VP (workspace) COMPLEX*16 array of */
+/* dimension( max(NN)*max(NN+1)/2 ) */
+/* The matrix V stored in packed format. */
+
+/* TAU (workspace/output) COMPLEX*16 array of */
+/* dimension( max(NN) ) */
+/* The Householder factors computed by ZHETRD in reducing A */
+/* to tridiagonal form. */
+
+/* Z (workspace/output) COMPLEX*16 array of */
+/* dimension( LDU, max(NN) ). */
+/* The unitary matrix of eigenvectors computed by ZSTEQR, */
+/* ZPTEQR, and ZSTEIN. */
+
+/* WORK (workspace/output) COMPLEX*16 array of */
+/* dimension( LWORK ) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 3 * Nmax**2 */
+/* where Nmax = max( NN(j), 2 ) and lg = log base 2. */
+
+/* IWORK (workspace/output) INTEGER array, */
+/* dimension (6 + 6*Nmax + 5 * Nmax * lg Nmax ) */
+/* where Nmax = max( NN(j), 2 ) and lg = log base 2. */
+/* Workspace. */
+
+/* RWORK (workspace/output) DOUBLE PRECISION array of */
+/* dimension( ??? ) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (26) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -5: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -23: LDU < 1 or LDU < NMAX. */
+/* -29: LWORK too small. */
+/* If ZLATMR, CLATMS, ZHETRD, ZUNGTR, ZSTEQR, DSTERF, */
+/* or ZUNMC2 returns an error code, the */
+/* absolute value of it is returned. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests performed, or which can */
+/* be performed so far, for the current matrix. */
+/* NTESTT The total number of tests performed so far. */
+/* NBLOCK Blocksize as returned by ENVIR. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far. */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ap;
+ --sd;
+ --se;
+ --d1;
+ --d2;
+ --d3;
+ --d4;
+ --d5;
+ --wa1;
+ --wa2;
+ --wa3;
+ --wr;
+ z_dim1 = *ldu;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ v_dim1 = *ldu;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --vp;
+ --tau;
+ --work;
+ --rwork;
+ --iwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Keep ftnchek happy */
+ idumma[0] = 1;
+
+/* Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+ tryrac = TRUE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+ nblock = ilaenv_(&c__1, "ZHETRD", "L", &nmax, &c_n1, &c_n1, &c_n1);
+/* Computing MIN */
+ i__1 = nmax, i__2 = max(1,nblock);
+ nblock = min(i__1,i__2);
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*lda < nmax) {
+ *info = -9;
+ } else if (*ldu < nmax) {
+ *info = -23;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = max(2,nmax);
+ if (i__1 * i__1 << 1 > *lwork) {
+ *info = -29;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZCHKST", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ dlabad_(&unfl, &ovfl);
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ ulpinv = 1. / ulp;
+ log2ui = (integer) (log(ulpinv) / log(2.));
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+
+/* Loop over sizes, types */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed2[i__ - 1] = iseed[i__];
+/* L20: */
+ }
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (n > 0) {
+ lgn = (integer) (log((doublereal) n) / log(2.));
+ if (pow_ii(&c__2, &lgn) < n) {
+ ++lgn;
+ }
+ if (pow_ii(&c__2, &lgn) < n) {
+ ++lgn;
+ }
+/* Computing 2nd power */
+ i__2 = n;
+ lwedc = (n << 2) + 1 + (n << 1) * lgn + i__2 * i__2 * 3;
+/* Computing 2nd power */
+ i__2 = n;
+ lrwedc = n * 3 + 1 + (n << 1) * lgn + i__2 * i__2 * 3;
+ liwedc = n * 6 + 6 + n * 5 * lgn;
+ } else {
+ lwedc = 8;
+ lrwedc = 7;
+ liwedc = 12;
+ }
+ nap = n * (n + 1) / 2;
+ aninv = 1. / (doublereal) max(1,n);
+
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L300;
+ }
+ ++nmats;
+ ntest = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L30: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log Hermitian, w/ eigenvalues */
+/* =6 random (none) */
+/* =7 random diagonal */
+/* =8 random Hermitian */
+/* =9 positive definite */
+/* =10 diagonally dominant tridiagonal */
+
+ if (mtypes > 21) {
+ goto L100;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * aninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * n * ulpinv;
+ goto L70;
+
+L70:
+
+ zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ iinfo = 0;
+ if (jtype <= 15) {
+ cond = ulpinv;
+ } else {
+ cond = ulpinv * aninv / 10.;
+ }
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = jc + jc * a_dim1;
+ a[i__4].r = anorm, a[i__4].i = 0.;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[
+ 1], &iinfo);
+
+
+ } else if (itype == 5) {
+
+/* Hermitian, eigenvalues specified */
+
+ zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[1], &
+ iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ zlatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &c_b39,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &c__0, &
+ c__0, &c_b49, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Hermitian, random eigenvalues */
+
+ zlatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &c_b39,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &n, &
+ c_b49, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* Positive definite, eigenvalues specified. */
+
+ zlatms_(&n, &n, "S", &iseed[1], "P", &rwork[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[1], &
+ iinfo);
+
+ } else if (itype == 10) {
+
+/* Positive definite tridiagonal, eigenvalues specified. */
+
+ zlatms_(&n, &n, "S", &iseed[1], "P", &rwork[1], &imode, &cond,
+ &anorm, &c__1, &c__1, "N", &a[a_offset], lda, &work[
+ 1], &iinfo);
+ i__3 = n;
+ for (i__ = 2; i__ <= i__3; ++i__) {
+ temp1 = z_abs(&a[i__ - 1 + i__ * a_dim1]);
+ i__4 = i__ - 1 + (i__ - 1) * a_dim1;
+ i__5 = i__ + i__ * a_dim1;
+ z__1.r = a[i__4].r * a[i__5].r - a[i__4].i * a[i__5].i,
+ z__1.i = a[i__4].r * a[i__5].i + a[i__4].i * a[
+ i__5].r;
+ temp2 = sqrt(z_abs(&z__1));
+ if (temp1 > temp2 * .5) {
+ i__4 = i__ - 1 + i__ * a_dim1;
+ i__5 = i__ - 1 + i__ * a_dim1;
+ d__1 = temp2 * .5 / (unfl + temp1);
+ z__1.r = d__1 * a[i__5].r, z__1.i = d__1 * a[i__5].i;
+ a[i__4].r = z__1.r, a[i__4].i = z__1.i;
+ i__4 = i__ + (i__ - 1) * a_dim1;
+ d_cnjg(&z__1, &a[i__ - 1 + i__ * a_dim1]);
+ a[i__4].r = z__1.r, a[i__4].i = z__1.i;
+ }
+/* L90: */
+ }
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L100:
+
+/* Call ZHETRD and ZUNGTR to compute S and U from */
+/* upper triangle. */
+
+ zlacpy_("U", &n, &n, &a[a_offset], lda, &v[v_offset], ldu);
+
+ ntest = 1;
+ zhetrd_("U", &n, &v[v_offset], ldu, &sd[1], &se[1], &tau[1], &
+ work[1], lwork, &iinfo);
+
+ if (iinfo != 0) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "ZHETRD(U)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[1] = ulpinv;
+ goto L280;
+ }
+ }
+
+ zlacpy_("U", &n, &n, &v[v_offset], ldu, &u[u_offset], ldu);
+
+ ntest = 2;
+ zungtr_("U", &n, &u[u_offset], ldu, &tau[1], &work[1], lwork, &
+ iinfo);
+ if (iinfo != 0) {
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "ZUNGTR(U)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[2] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do tests 1 and 2 */
+
+ zhet21_(&c__2, "Upper", &n, &c__1, &a[a_offset], lda, &sd[1], &se[
+ 1], &u[u_offset], ldu, &v[v_offset], ldu, &tau[1], &work[
+ 1], &rwork[1], &result[1]);
+ zhet21_(&c__3, "Upper", &n, &c__1, &a[a_offset], lda, &sd[1], &se[
+ 1], &u[u_offset], ldu, &v[v_offset], ldu, &tau[1], &work[
+ 1], &rwork[1], &result[2]);
+
+/* Call ZHETRD and ZUNGTR to compute S and U from */
+/* lower triangle, do tests. */
+
+ zlacpy_("L", &n, &n, &a[a_offset], lda, &v[v_offset], ldu);
+
+ ntest = 3;
+ zhetrd_("L", &n, &v[v_offset], ldu, &sd[1], &se[1], &tau[1], &
+ work[1], lwork, &iinfo);
+
+ if (iinfo != 0) {
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "ZHETRD(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[3] = ulpinv;
+ goto L280;
+ }
+ }
+
+ zlacpy_("L", &n, &n, &v[v_offset], ldu, &u[u_offset], ldu);
+
+ ntest = 4;
+ zungtr_("L", &n, &u[u_offset], ldu, &tau[1], &work[1], lwork, &
+ iinfo);
+ if (iinfo != 0) {
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, "ZUNGTR(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[4] = ulpinv;
+ goto L280;
+ }
+ }
+
+ zhet21_(&c__2, "Lower", &n, &c__1, &a[a_offset], lda, &sd[1], &se[
+ 1], &u[u_offset], ldu, &v[v_offset], ldu, &tau[1], &work[
+ 1], &rwork[1], &result[3]);
+ zhet21_(&c__3, "Lower", &n, &c__1, &a[a_offset], lda, &sd[1], &se[
+ 1], &u[u_offset], ldu, &v[v_offset], ldu, &tau[1], &work[
+ 1], &rwork[1], &result[4]);
+
+/* Store the upper triangle of A in AP */
+
+ i__ = 0;
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = jc;
+ for (jr = 1; jr <= i__4; ++jr) {
+ ++i__;
+ i__5 = i__;
+ i__6 = jr + jc * a_dim1;
+ ap[i__5].r = a[i__6].r, ap[i__5].i = a[i__6].i;
+/* L110: */
+ }
+/* L120: */
+ }
+
+/* Call ZHPTRD and ZUPGTR to compute S and U from AP */
+
+ zcopy_(&nap, &ap[1], &c__1, &vp[1], &c__1);
+
+ ntest = 5;
+ zhptrd_("U", &n, &vp[1], &sd[1], &se[1], &tau[1], &iinfo);
+
+ if (iinfo != 0) {
+ io___48.ciunit = *nounit;
+ s_wsfe(&io___48);
+ do_fio(&c__1, "ZHPTRD(U)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[5] = ulpinv;
+ goto L280;
+ }
+ }
+
+ ntest = 6;
+ zupgtr_("U", &n, &vp[1], &tau[1], &u[u_offset], ldu, &work[1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ do_fio(&c__1, "ZUPGTR(U)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[6] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do tests 5 and 6 */
+
+ zhpt21_(&c__2, "Upper", &n, &c__1, &ap[1], &sd[1], &se[1], &u[
+ u_offset], ldu, &vp[1], &tau[1], &work[1], &rwork[1], &
+ result[5]);
+ zhpt21_(&c__3, "Upper", &n, &c__1, &ap[1], &sd[1], &se[1], &u[
+ u_offset], ldu, &vp[1], &tau[1], &work[1], &rwork[1], &
+ result[6]);
+
+/* Store the lower triangle of A in AP */
+
+ i__ = 0;
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = jc; jr <= i__4; ++jr) {
+ ++i__;
+ i__5 = i__;
+ i__6 = jr + jc * a_dim1;
+ ap[i__5].r = a[i__6].r, ap[i__5].i = a[i__6].i;
+/* L130: */
+ }
+/* L140: */
+ }
+
+/* Call ZHPTRD and ZUPGTR to compute S and U from AP */
+
+ zcopy_(&nap, &ap[1], &c__1, &vp[1], &c__1);
+
+ ntest = 7;
+ zhptrd_("L", &n, &vp[1], &sd[1], &se[1], &tau[1], &iinfo);
+
+ if (iinfo != 0) {
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ do_fio(&c__1, "ZHPTRD(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[7] = ulpinv;
+ goto L280;
+ }
+ }
+
+ ntest = 8;
+ zupgtr_("L", &n, &vp[1], &tau[1], &u[u_offset], ldu, &work[1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "ZUPGTR(L)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[8] = ulpinv;
+ goto L280;
+ }
+ }
+
+ zhpt21_(&c__2, "Lower", &n, &c__1, &ap[1], &sd[1], &se[1], &u[
+ u_offset], ldu, &vp[1], &tau[1], &work[1], &rwork[1], &
+ result[7]);
+ zhpt21_(&c__3, "Lower", &n, &c__1, &ap[1], &sd[1], &se[1], &u[
+ u_offset], ldu, &vp[1], &tau[1], &work[1], &rwork[1], &
+ result[8]);
+
+/* Call ZSTEQR to compute D1, D2, and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ dcopy_(&n, &sd[1], &c__1, &d1[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &rwork[1], &c__1);
+ }
+ zlaset_("Full", &n, &n, &c_b1, &c_b2, &z__[z_offset], ldu);
+
+ ntest = 9;
+ zsteqr_("V", &n, &d1[1], &rwork[1], &z__[z_offset], ldu, &rwork[n
+ + 1], &iinfo);
+ if (iinfo != 0) {
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "ZSTEQR(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[9] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Compute D2 */
+
+ dcopy_(&n, &sd[1], &c__1, &d2[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &rwork[1], &c__1);
+ }
+
+ ntest = 11;
+ zsteqr_("N", &n, &d2[1], &rwork[1], &work[1], ldu, &rwork[n + 1],
+ &iinfo);
+ if (iinfo != 0) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, "ZSTEQR(N)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[11] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Compute D3 (using PWK method) */
+
+ dcopy_(&n, &sd[1], &c__1, &d3[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &rwork[1], &c__1);
+ }
+
+ ntest = 12;
+ dsterf_(&n, &d3[1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ do_fio(&c__1, "DSTERF", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[12] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 9 and 10 */
+
+ zstt21_(&n, &c__0, &sd[1], &se[1], &d1[1], dumma, &z__[z_offset],
+ ldu, &work[1], &rwork[1], &result[9]);
+
+/* Do Tests 11 and 12 */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ temp3 = 0.;
+ temp4 = 0.;
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d1[j], abs(d__1)), d__3 = max(
+ d__3,d__4), d__4 = (d__2 = d2[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d1[j] - d2[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* Computing MAX */
+ d__3 = temp3, d__4 = (d__1 = d1[j], abs(d__1)), d__3 = max(
+ d__3,d__4), d__4 = (d__2 = d3[j], abs(d__2));
+ temp3 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp4, d__3 = (d__1 = d1[j] - d3[j], abs(d__1));
+ temp4 = max(d__2,d__3);
+/* L150: */
+ }
+
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[11] = temp2 / max(d__1,d__2);
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp3,temp4);
+ result[12] = temp4 / max(d__1,d__2);
+
+/* Do Test 13 -- Sturm Sequence Test of Eigenvalues */
+/* Go up by factors of two until it succeeds */
+
+ ntest = 13;
+ temp1 = *thresh * (.5 - ulp);
+
+ i__3 = log2ui;
+ for (j = 0; j <= i__3; ++j) {
+ dstech_(&n, &sd[1], &se[1], &d1[1], &temp1, &rwork[1], &iinfo)
+ ;
+ if (iinfo == 0) {
+ goto L170;
+ }
+ temp1 *= 2.;
+/* L160: */
+ }
+
+L170:
+ result[13] = temp1;
+
+/* For positive definite matrices ( JTYPE.GT.15 ) call ZPTEQR */
+/* and do tests 14, 15, and 16 . */
+
+ if (jtype > 15) {
+
+/* Compute D4 and Z4 */
+
+ dcopy_(&n, &sd[1], &c__1, &d4[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &rwork[1], &c__1);
+ }
+ zlaset_("Full", &n, &n, &c_b1, &c_b2, &z__[z_offset], ldu);
+
+ ntest = 14;
+ zpteqr_("V", &n, &d4[1], &rwork[1], &z__[z_offset], ldu, &
+ rwork[n + 1], &iinfo);
+ if (iinfo != 0) {
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ do_fio(&c__1, "ZPTEQR(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[14] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 14 and 15 */
+
+ zstt21_(&n, &c__0, &sd[1], &se[1], &d4[1], dumma, &z__[
+ z_offset], ldu, &work[1], &rwork[1], &result[14]);
+
+/* Compute D5 */
+
+ dcopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &rwork[1], &c__1);
+ }
+
+ ntest = 16;
+ zpteqr_("N", &n, &d5[1], &rwork[1], &z__[z_offset], ldu, &
+ rwork[n + 1], &iinfo);
+ if (iinfo != 0) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, "ZPTEQR(N)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[16] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Test 16 */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d4[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = d5[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d4[j] - d5[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L180: */
+ }
+
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * 100. * max(temp1,temp2);
+ result[16] = temp2 / max(d__1,d__2);
+ } else {
+ result[14] = 0.;
+ result[15] = 0.;
+ result[16] = 0.;
+ }
+
+/* Call DSTEBZ with different options and do tests 17-18. */
+
+/* If S is positive definite and diagonally dominant, */
+/* ask for all eigenvalues with high relative accuracy. */
+
+ vl = 0.;
+ vu = 0.;
+ il = 0;
+ iu = 0;
+ if (jtype == 21) {
+ ntest = 17;
+ abstol = unfl + unfl;
+ dstebz_("A", "E", &n, &vl, &vu, &il, &iu, &abstol, &sd[1], &
+ se[1], &m, &nsplit, &wr[1], &iwork[1], &iwork[n + 1],
+ &rwork[1], &iwork[(n << 1) + 1], &iinfo);
+ if (iinfo != 0) {
+ io___67.ciunit = *nounit;
+ s_wsfe(&io___67);
+ do_fio(&c__1, "DSTEBZ(A,rel)", (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[17] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do test 17 */
+
+ temp2 = (n * 2. - 1.) * 2. * ulp * 3. / .0625;
+
+ temp1 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__2 = d4[j] - wr[n - j + 1], abs(
+ d__2)) / (abstol + (d__1 = d4[j], abs(d__1)));
+ temp1 = max(d__3,d__4);
+/* L190: */
+ }
+
+ result[17] = temp1 / temp2;
+ } else {
+ result[17] = 0.;
+ }
+
+/* Now ask for all eigenvalues with high absolute accuracy. */
+
+ ntest = 18;
+ abstol = unfl + unfl;
+ dstebz_("A", "E", &n, &vl, &vu, &il, &iu, &abstol, &sd[1], &se[1],
+ &m, &nsplit, &wa1[1], &iwork[1], &iwork[n + 1], &rwork[1]
+, &iwork[(n << 1) + 1], &iinfo);
+ if (iinfo != 0) {
+ io___68.ciunit = *nounit;
+ s_wsfe(&io___68);
+ do_fio(&c__1, "DSTEBZ(A)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[18] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do test 18 */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d3[j], abs(d__1)), d__3 = max(
+ d__3,d__4), d__4 = (d__2 = wa1[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d3[j] - wa1[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L200: */
+ }
+
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[18] = temp2 / max(d__1,d__2);
+
+/* Choose random values for IL and IU, and ask for the */
+/* IL-th through IU-th eigenvalues. */
+
+ ntest = 19;
+ if (n <= 1) {
+ il = 1;
+ iu = n;
+ } else {
+ il = (n - 1) * (integer) dlarnd_(&c__1, iseed2) + 1;
+ iu = (n - 1) * (integer) dlarnd_(&c__1, iseed2) + 1;
+ if (iu < il) {
+ itemp = iu;
+ iu = il;
+ il = itemp;
+ }
+ }
+
+ dstebz_("I", "E", &n, &vl, &vu, &il, &iu, &abstol, &sd[1], &se[1],
+ &m2, &nsplit, &wa2[1], &iwork[1], &iwork[n + 1], &rwork[
+ 1], &iwork[(n << 1) + 1], &iinfo);
+ if (iinfo != 0) {
+ io___71.ciunit = *nounit;
+ s_wsfe(&io___71);
+ do_fio(&c__1, "DSTEBZ(I)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[19] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Determine the values VL and VU of the IL-th and IU-th */
+/* eigenvalues and ask for all eigenvalues in this range. */
+
+ if (n > 0) {
+ if (il != 1) {
+/* Computing MAX */
+ d__1 = (wa1[il] - wa1[il - 1]) * .5, d__2 = ulp * anorm,
+ d__1 = max(d__1,d__2), d__2 = rtunfl * 2.;
+ vl = wa1[il] - max(d__1,d__2);
+ } else {
+/* Computing MAX */
+ d__1 = (wa1[n] - wa1[1]) * .5, d__2 = ulp * anorm, d__1 =
+ max(d__1,d__2), d__2 = rtunfl * 2.;
+ vl = wa1[1] - max(d__1,d__2);
+ }
+ if (iu != n) {
+/* Computing MAX */
+ d__1 = (wa1[iu + 1] - wa1[iu]) * .5, d__2 = ulp * anorm,
+ d__1 = max(d__1,d__2), d__2 = rtunfl * 2.;
+ vu = wa1[iu] + max(d__1,d__2);
+ } else {
+/* Computing MAX */
+ d__1 = (wa1[n] - wa1[1]) * .5, d__2 = ulp * anorm, d__1 =
+ max(d__1,d__2), d__2 = rtunfl * 2.;
+ vu = wa1[n] + max(d__1,d__2);
+ }
+ } else {
+ vl = 0.;
+ vu = 1.;
+ }
+
+ dstebz_("V", "E", &n, &vl, &vu, &il, &iu, &abstol, &sd[1], &se[1],
+ &m3, &nsplit, &wa3[1], &iwork[1], &iwork[n + 1], &rwork[
+ 1], &iwork[(n << 1) + 1], &iinfo);
+ if (iinfo != 0) {
+ io___73.ciunit = *nounit;
+ s_wsfe(&io___73);
+ do_fio(&c__1, "DSTEBZ(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[19] = ulpinv;
+ goto L280;
+ }
+ }
+
+ if (m3 == 0 && n != 0) {
+ result[19] = ulpinv;
+ goto L280;
+ }
+
+/* Do test 19 */
+
+ temp1 = dsxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &ulp, &
+ unfl);
+ temp2 = dsxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &ulp, &
+ unfl);
+ if (n > 0) {
+/* Computing MAX */
+ d__2 = (d__1 = wa1[n], abs(d__1)), d__3 = abs(wa1[1]);
+ temp3 = max(d__2,d__3);
+ } else {
+ temp3 = 0.;
+ }
+
+/* Computing MAX */
+ d__1 = unfl, d__2 = temp3 * ulp;
+ result[19] = (temp1 + temp2) / max(d__1,d__2);
+
+/* Call ZSTEIN to compute eigenvectors corresponding to */
+/* eigenvalues in WA1. (First call DSTEBZ again, to make sure */
+/* it returns these eigenvalues in the correct order.) */
+
+ ntest = 21;
+ dstebz_("A", "B", &n, &vl, &vu, &il, &iu, &abstol, &sd[1], &se[1],
+ &m, &nsplit, &wa1[1], &iwork[1], &iwork[n + 1], &rwork[1]
+, &iwork[(n << 1) + 1], &iinfo);
+ if (iinfo != 0) {
+ io___74.ciunit = *nounit;
+ s_wsfe(&io___74);
+ do_fio(&c__1, "DSTEBZ(A,B)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[20] = ulpinv;
+ result[21] = ulpinv;
+ goto L280;
+ }
+ }
+
+ zstein_(&n, &sd[1], &se[1], &m, &wa1[1], &iwork[1], &iwork[n + 1],
+ &z__[z_offset], ldu, &rwork[1], &iwork[(n << 1) + 1], &
+ iwork[n * 3 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___75.ciunit = *nounit;
+ s_wsfe(&io___75);
+ do_fio(&c__1, "ZSTEIN", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[20] = ulpinv;
+ result[21] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do tests 20 and 21 */
+
+ zstt21_(&n, &c__0, &sd[1], &se[1], &wa1[1], dumma, &z__[z_offset],
+ ldu, &work[1], &rwork[1], &result[20]);
+
+/* Call ZSTEDC(I) to compute D1 and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ inde = 1;
+ indrwk = inde + n;
+ dcopy_(&n, &sd[1], &c__1, &d1[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &rwork[inde], &c__1);
+ }
+ zlaset_("Full", &n, &n, &c_b1, &c_b2, &z__[z_offset], ldu);
+
+ ntest = 22;
+ zstedc_("I", &n, &d1[1], &rwork[inde], &z__[z_offset], ldu, &work[
+ 1], &lwedc, &rwork[indrwk], &lrwedc, &iwork[1], &liwedc, &
+ iinfo);
+ if (iinfo != 0) {
+ io___78.ciunit = *nounit;
+ s_wsfe(&io___78);
+ do_fio(&c__1, "ZSTEDC(I)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[22] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 22 and 23 */
+
+ zstt21_(&n, &c__0, &sd[1], &se[1], &d1[1], dumma, &z__[z_offset],
+ ldu, &work[1], &rwork[1], &result[22]);
+
+/* Call ZSTEDC(V) to compute D1 and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ dcopy_(&n, &sd[1], &c__1, &d1[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &rwork[inde], &c__1);
+ }
+ zlaset_("Full", &n, &n, &c_b1, &c_b2, &z__[z_offset], ldu);
+
+ ntest = 24;
+ zstedc_("V", &n, &d1[1], &rwork[inde], &z__[z_offset], ldu, &work[
+ 1], &lwedc, &rwork[indrwk], &lrwedc, &iwork[1], &liwedc, &
+ iinfo);
+ if (iinfo != 0) {
+ io___79.ciunit = *nounit;
+ s_wsfe(&io___79);
+ do_fio(&c__1, "ZSTEDC(V)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[24] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 24 and 25 */
+
+ zstt21_(&n, &c__0, &sd[1], &se[1], &d1[1], dumma, &z__[z_offset],
+ ldu, &work[1], &rwork[1], &result[24]);
+
+/* Call ZSTEDC(N) to compute D2, do tests. */
+
+/* Compute D2 */
+
+ dcopy_(&n, &sd[1], &c__1, &d2[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &rwork[inde], &c__1);
+ }
+ zlaset_("Full", &n, &n, &c_b1, &c_b2, &z__[z_offset], ldu);
+
+ ntest = 26;
+ zstedc_("N", &n, &d2[1], &rwork[inde], &z__[z_offset], ldu, &work[
+ 1], &lwedc, &rwork[indrwk], &lrwedc, &iwork[1], &liwedc, &
+ iinfo);
+ if (iinfo != 0) {
+ io___80.ciunit = *nounit;
+ s_wsfe(&io___80);
+ do_fio(&c__1, "ZSTEDC(N)", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[26] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Test 26 */
+
+ temp1 = 0.;
+ temp2 = 0.;
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d1[j], abs(d__1)), d__3 = max(
+ d__3,d__4), d__4 = (d__2 = d2[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d1[j] - d2[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L210: */
+ }
+
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[26] = temp2 / max(d__1,d__2);
+
+/* Only test ZSTEMR if IEEE compliant */
+
+ if (ilaenv_(&c__10, "ZSTEMR", "VA", &c__1, &c__0, &c__0, &c__0) == 1 && ilaenv_(&c__11, "ZSTEMR",
+ "VA", &c__1, &c__0, &c__0, &c__0) ==
+ 1) {
+
+/* Call ZSTEMR, do test 27 (relative eigenvalue accuracy) */
+
+/* If S is positive definite and diagonally dominant, */
+/* ask for all eigenvalues with high relative accuracy. */
+
+ vl = 0.;
+ vu = 0.;
+ il = 0;
+ iu = 0;
+ if (FALSE_) {
+ ntest = 27;
+ abstol = unfl + unfl;
+ i__3 = *lwork - (n << 1);
+ zstemr_("V", "A", &n, &sd[1], &se[1], &vl, &vu, &il, &iu,
+ &m, &wr[1], &z__[z_offset], ldu, &n, &iwork[1], &
+ tryrac, &rwork[1], lrwork, &iwork[(n << 1) + 1], &
+ i__3, &iinfo);
+ if (iinfo != 0) {
+ io___81.ciunit = *nounit;
+ s_wsfe(&io___81);
+ do_fio(&c__1, "ZSTEMR(V,A,rel)", (ftnlen)15);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[27] = ulpinv;
+ goto L270;
+ }
+ }
+
+/* Do test 27 */
+
+ temp2 = (n * 2. - 1.) * 2. * ulp * 3. / .0625;
+
+ temp1 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__2 = d4[j] - wr[n - j + 1],
+ abs(d__2)) / (abstol + (d__1 = d4[j], abs(
+ d__1)));
+ temp1 = max(d__3,d__4);
+/* L220: */
+ }
+
+ result[27] = temp1 / temp2;
+
+ il = (n - 1) * (integer) dlarnd_(&c__1, iseed2) + 1;
+ iu = (n - 1) * (integer) dlarnd_(&c__1, iseed2) + 1;
+ if (iu < il) {
+ itemp = iu;
+ iu = il;
+ il = itemp;
+ }
+
+ if (FALSE_) {
+ ntest = 28;
+ abstol = unfl + unfl;
+ i__3 = *lwork - (n << 1);
+ zstemr_("V", "I", &n, &sd[1], &se[1], &vl, &vu, &il, &
+ iu, &m, &wr[1], &z__[z_offset], ldu, &n, &
+ iwork[1], &tryrac, &rwork[1], lrwork, &iwork[(
+ n << 1) + 1], &i__3, &iinfo);
+
+ if (iinfo != 0) {
+ io___82.ciunit = *nounit;
+ s_wsfe(&io___82);
+ do_fio(&c__1, "ZSTEMR(V,I,rel)", (ftnlen)15);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[28] = ulpinv;
+ goto L270;
+ }
+ }
+
+
+/* Do test 28 */
+
+ temp2 = (n * 2. - 1.) * 2. * ulp * 3. / .0625;
+
+ temp1 = 0.;
+ i__3 = iu;
+ for (j = il; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__2 = wr[j - il + 1] - d4[
+ n - j + 1], abs(d__2)) / (abstol + (d__1 =
+ wr[j - il + 1], abs(d__1)));
+ temp1 = max(d__3,d__4);
+/* L230: */
+ }
+
+ result[28] = temp1 / temp2;
+ } else {
+ result[28] = 0.;
+ }
+ } else {
+ result[27] = 0.;
+ result[28] = 0.;
+ }
+
+/* Call ZSTEMR(V,I) to compute D1 and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ dcopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &rwork[1], &c__1);
+ }
+ zlaset_("Full", &n, &n, &c_b1, &c_b2, &z__[z_offset], ldu);
+
+ if (FALSE_) {
+ ntest = 29;
+ il = (n - 1) * (integer) dlarnd_(&c__1, iseed2) + 1;
+ iu = (n - 1) * (integer) dlarnd_(&c__1, iseed2) + 1;
+ if (iu < il) {
+ itemp = iu;
+ iu = il;
+ il = itemp;
+ }
+ i__3 = *lrwork - n;
+ i__4 = *liwork - (n << 1);
+ zstemr_("V", "I", &n, &d5[1], &rwork[1], &vl, &vu, &il, &
+ iu, &m, &d1[1], &z__[z_offset], ldu, &n, &iwork[1]
+, &tryrac, &rwork[n + 1], &i__3, &iwork[(n << 1)
+ + 1], &i__4, &iinfo);
+ if (iinfo != 0) {
+ io___83.ciunit = *nounit;
+ s_wsfe(&io___83);
+ do_fio(&c__1, "ZSTEMR(V,I)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[29] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 29 and 30 */
+
+
+/* Call ZSTEMR to compute D2, do tests. */
+
+/* Compute D2 */
+
+ dcopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &rwork[1], &c__1);
+ }
+
+ ntest = 31;
+ i__3 = *lrwork - n;
+ i__4 = *liwork - (n << 1);
+ zstemr_("N", "I", &n, &d5[1], &rwork[1], &vl, &vu, &il, &
+ iu, &m, &d2[1], &z__[z_offset], ldu, &n, &iwork[1]
+, &tryrac, &rwork[n + 1], &i__3, &iwork[(n << 1)
+ + 1], &i__4, &iinfo);
+ if (iinfo != 0) {
+ io___84.ciunit = *nounit;
+ s_wsfe(&io___84);
+ do_fio(&c__1, "ZSTEMR(N,I)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[31] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Test 31 */
+
+ temp1 = 0.;
+ temp2 = 0.;
+
+ i__3 = iu - il + 1;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = d2[j], abs(
+ d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d1[j] - d2[j], abs(d__1))
+ ;
+ temp2 = max(d__2,d__3);
+/* L240: */
+ }
+
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[31] = temp2 / max(d__1,d__2);
+
+
+/* Call ZSTEMR(V,V) to compute D1 and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ dcopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &rwork[1], &c__1);
+ }
+ zlaset_("Full", &n, &n, &c_b1, &c_b2, &z__[z_offset], ldu);
+
+ ntest = 32;
+
+ if (n > 0) {
+ if (il != 1) {
+/* Computing MAX */
+ d__1 = (d2[il] - d2[il - 1]) * .5, d__2 = ulp *
+ anorm, d__1 = max(d__1,d__2), d__2 =
+ rtunfl * 2.;
+ vl = d2[il] - max(d__1,d__2);
+ } else {
+/* Computing MAX */
+ d__1 = (d2[n] - d2[1]) * .5, d__2 = ulp * anorm,
+ d__1 = max(d__1,d__2), d__2 = rtunfl * 2.;
+ vl = d2[1] - max(d__1,d__2);
+ }
+ if (iu != n) {
+/* Computing MAX */
+ d__1 = (d2[iu + 1] - d2[iu]) * .5, d__2 = ulp *
+ anorm, d__1 = max(d__1,d__2), d__2 =
+ rtunfl * 2.;
+ vu = d2[iu] + max(d__1,d__2);
+ } else {
+/* Computing MAX */
+ d__1 = (d2[n] - d2[1]) * .5, d__2 = ulp * anorm,
+ d__1 = max(d__1,d__2), d__2 = rtunfl * 2.;
+ vu = d2[n] + max(d__1,d__2);
+ }
+ } else {
+ vl = 0.;
+ vu = 1.;
+ }
+
+ i__3 = *lrwork - n;
+ i__4 = *liwork - (n << 1);
+ zstemr_("V", "V", &n, &d5[1], &rwork[1], &vl, &vu, &il, &
+ iu, &m, &d1[1], &z__[z_offset], ldu, &m, &iwork[1]
+, &tryrac, &rwork[n + 1], &i__3, &iwork[(n << 1)
+ + 1], &i__4, &iinfo);
+ if (iinfo != 0) {
+ io___85.ciunit = *nounit;
+ s_wsfe(&io___85);
+ do_fio(&c__1, "ZSTEMR(V,V)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[32] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 32 and 33 */
+
+ zstt22_(&n, &m, &c__0, &sd[1], &se[1], &d1[1], dumma, &
+ z__[z_offset], ldu, &work[1], &m, &rwork[1], &
+ result[32]);
+
+/* Call ZSTEMR to compute D2, do tests. */
+
+/* Compute D2 */
+
+ dcopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &rwork[1], &c__1);
+ }
+
+ ntest = 34;
+ i__3 = *lrwork - n;
+ i__4 = *liwork - (n << 1);
+ zstemr_("N", "V", &n, &d5[1], &rwork[1], &vl, &vu, &il, &
+ iu, &m, &d2[1], &z__[z_offset], ldu, &n, &iwork[1]
+, &tryrac, &rwork[n + 1], &i__3, &iwork[(n << 1)
+ + 1], &i__4, &iinfo);
+ if (iinfo != 0) {
+ io___86.ciunit = *nounit;
+ s_wsfe(&io___86);
+ do_fio(&c__1, "ZSTEMR(N,V)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[34] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Test 34 */
+
+ temp1 = 0.;
+ temp2 = 0.;
+
+ i__3 = iu - il + 1;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = d2[j], abs(
+ d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d1[j] - d2[j], abs(d__1))
+ ;
+ temp2 = max(d__2,d__3);
+/* L250: */
+ }
+
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[34] = temp2 / max(d__1,d__2);
+ } else {
+ result[29] = 0.;
+ result[30] = 0.;
+ result[31] = 0.;
+ result[32] = 0.;
+ result[33] = 0.;
+ result[34] = 0.;
+ }
+
+
+/* Call ZSTEMR(V,A) to compute D1 and Z, do tests. */
+
+/* Compute D1 and Z */
+
+ dcopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &rwork[1], &c__1);
+ }
+
+ ntest = 35;
+
+ i__3 = *lrwork - n;
+ i__4 = *liwork - (n << 1);
+ zstemr_("V", "A", &n, &d5[1], &rwork[1], &vl, &vu, &il, &iu, &
+ m, &d1[1], &z__[z_offset], ldu, &n, &iwork[1], &
+ tryrac, &rwork[n + 1], &i__3, &iwork[(n << 1) + 1], &
+ i__4, &iinfo);
+ if (iinfo != 0) {
+ io___87.ciunit = *nounit;
+ s_wsfe(&io___87);
+ do_fio(&c__1, "ZSTEMR(V,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[35] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Tests 35 and 36 */
+
+ zstt22_(&n, &m, &c__0, &sd[1], &se[1], &d1[1], dumma, &z__[
+ z_offset], ldu, &work[1], &m, &rwork[1], &result[35]);
+
+/* Call ZSTEMR to compute D2, do tests. */
+
+/* Compute D2 */
+
+ dcopy_(&n, &sd[1], &c__1, &d5[1], &c__1);
+ if (n > 0) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &se[1], &c__1, &rwork[1], &c__1);
+ }
+
+ ntest = 37;
+ i__3 = *lrwork - n;
+ i__4 = *liwork - (n << 1);
+ zstemr_("N", "A", &n, &d5[1], &rwork[1], &vl, &vu, &il, &iu, &
+ m, &d2[1], &z__[z_offset], ldu, &n, &iwork[1], &
+ tryrac, &rwork[n + 1], &i__3, &iwork[(n << 1) + 1], &
+ i__4, &iinfo);
+ if (iinfo != 0) {
+ io___88.ciunit = *nounit;
+ s_wsfe(&io___88);
+ do_fio(&c__1, "ZSTEMR(N,A)", (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[37] = ulpinv;
+ goto L280;
+ }
+ }
+
+/* Do Test 34 */
+
+ temp1 = 0.;
+ temp2 = 0.;
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = d2[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d1[j] - d2[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L260: */
+ }
+
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[37] = temp2 / max(d__1,d__2);
+ }
+L270:
+L280:
+ ntestt += ntest;
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+
+/* Print out tests which fail. */
+
+ i__3 = ntest;
+ for (jr = 1; jr <= i__3; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___89.ciunit = *nounit;
+ s_wsfe(&io___89);
+ do_fio(&c__1, "ZST", (ftnlen)3);
+ e_wsfe();
+ io___90.ciunit = *nounit;
+ s_wsfe(&io___90);
+ e_wsfe();
+ io___91.ciunit = *nounit;
+ s_wsfe(&io___91);
+ e_wsfe();
+ io___92.ciunit = *nounit;
+ s_wsfe(&io___92);
+ do_fio(&c__1, "Hermitian", (ftnlen)9);
+ e_wsfe();
+ io___93.ciunit = *nounit;
+ s_wsfe(&io___93);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___94.ciunit = *nounit;
+ s_wsfe(&io___94);
+ e_wsfe();
+ }
+ ++nerrs;
+ if (result[jr] < 1e4) {
+ io___95.ciunit = *nounit;
+ s_wsfe(&io___95);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ } else {
+ io___96.ciunit = *nounit;
+ s_wsfe(&io___96);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+ }
+/* L290: */
+ }
+L300:
+ ;
+ }
+/* L310: */
+ }
+
+/* Summary */
+
+ dlasum_("ZST", nounit, &nerrs, &ntestt);
+ return 0;
+
+
+
+
+/* L9993: */
+/* L9992: */
+/* L9991: */
+/* L9990: */
+
+/* End of ZCHKST */
+
+} /* zchkst_ */
diff --git a/TESTING/EIG/zckglm.c b/TESTING/EIG/zckglm.c
new file mode 100644
index 0000000..bc72375
--- /dev/null
+++ b/TESTING/EIG/zckglm.c
@@ -0,0 +1,333 @@
+/* zckglm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+
+/* Subroutine */ int zckglm_(integer *nn, integer *nval, integer *mval,
+ integer *pval, integer *nmats, integer *iseed, doublereal *thresh,
+ integer *nmax, doublecomplex *a, doublecomplex *af, doublecomplex *b,
+ doublecomplex *bf, doublecomplex *x, doublecomplex *work, doublereal *
+ rwork, integer *nin, integer *nout, integer *info)
+{
+ /* Format strings */
+ static char fmt_9997[] = "(\002 *** Invalid input for GLM: M = \002,"
+ "i6,\002, P = \002,i6,\002, N = \002,i6,\002;\002,/\002 must "
+ "satisfy M <= N <= M+P \002,\002(this set of values will be skip"
+ "ped)\002)";
+ static char fmt_9999[] = "(\002 ZLATMS in ZCKGLM INFO = \002,i5)";
+ static char fmt_9998[] = "(\002 N=\002,i4,\002 M=\002,i4,\002, P=\002,"
+ "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), do_fio(integer *
+ , char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, m, n, p, ik, lda, ldb, kla, klb, kua, kub, imat;
+ char path[3], type__[1];
+ integer nrun, modea, modeb, nfail;
+ char dista[1], distb[1];
+ integer iinfo;
+ doublereal resid, anorm, bnorm;
+ integer lwork;
+ extern /* Subroutine */ int dlatb9_(char *, integer *, integer *, integer
+ *, integer *, char *, integer *, integer *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ doublereal *, char *, char *),
+ alahdg_(integer *, char *);
+ doublereal cndnma, cndnmb;
+ extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
+ *, integer *, integer *), alasum_(char *, integer *,
+ integer *, integer *, integer *);
+ extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
+ integer *);
+ logical dotype[8];
+ extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ logical firstt;
+ extern /* Subroutine */ int zglmts_(integer *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+
+ /* Fortran I/O blocks */
+ static cilist io___13 = { 0, 0, 0, 0, 0 };
+ static cilist io___14 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCKGLM tests ZGGGLM - subroutine for solving generalized linear */
+/* model problem. */
+
+/* Arguments */
+/* ========= */
+
+/* NN (input) INTEGER */
+/* The number of values of N, M and P contained in the vectors */
+/* NVAL, MVAL and PVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix row dimension N. */
+
+/* MVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension M. */
+
+/* PVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension P. */
+
+/* NMATS (input) INTEGER */
+/* The number of matrix types to be tested for each combination */
+/* of matrix dimensions. If NMATS >= NTYPES (the maximum */
+/* number of matrix types), then all the different types are */
+/* generated for testing. If NMATS < NTYPES, another input line */
+/* is read to get the numbers of the matrix types to be used. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator. The array */
+/* elements should be between 0 and 4095, otherwise they will be */
+/* reduced mod 4096, and ISEED(4) must be odd. */
+/* On exit, the next seed in the random number sequence after */
+/* all the test matrices have been generated. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* The threshold value for the test ratios. A result is */
+/* included in the output file if RESID >= THRESH. To have */
+/* every test ratio printed, use THRESH = 0. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* BF (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* X (workspace) COMPLEX*16 array, dimension (4*NMAX) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* NIN (input) INTEGER */
+/* The unit number for input. */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit */
+/* > 0 : If ZLATMS returns an error code, the absolute value */
+/* of it is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --x;
+ --bf;
+ --b;
+ --af;
+ --a;
+ --iseed;
+ --pval;
+ --mval;
+ --nval;
+
+ /* Function Body */
+ s_copy(path, "GLM", (ftnlen)3, (ftnlen)3);
+ *info = 0;
+ nrun = 0;
+ nfail = 0;
+ firstt = TRUE_;
+ alareq_(path, nmats, dotype, &c__8, nin, nout);
+ lda = *nmax;
+ ldb = *nmax;
+ lwork = *nmax * *nmax;
+
+/* Check for valid input values. */
+
+ i__1 = *nn;
+ for (ik = 1; ik <= i__1; ++ik) {
+ m = mval[ik];
+ p = pval[ik];
+ n = nval[ik];
+ if (m > n || n > m + p) {
+ if (firstt) {
+ io___13.ciunit = *nout;
+ s_wsle(&io___13);
+ e_wsle();
+ firstt = FALSE_;
+ }
+ io___14.ciunit = *nout;
+ s_wsfe(&io___14);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L10: */
+ }
+ firstt = TRUE_;
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nn;
+ for (ik = 1; ik <= i__1; ++ik) {
+ m = mval[ik];
+ p = pval[ik];
+ n = nval[ik];
+ if (m > n || n > m + p) {
+ goto L40;
+ }
+
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat - 1]) {
+ goto L30;
+ }
+
+/* Set up parameters with DLATB9 and generate test */
+/* matrices A and B with ZLATMS. */
+
+ dlatb9_(path, &imat, &m, &p, &n, type__, &kla, &kua, &klb, &kub, &
+ anorm, &bnorm, &modea, &modeb, &cndnma, &cndnmb, dista,
+ distb);
+
+ zlatms_(&n, &m, dista, &iseed[1], type__, &rwork[1], &modea, &
+ cndnma, &anorm, &kla, &kua, "No packing", &a[1], &lda, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+ zlatms_(&n, &p, distb, &iseed[1], type__, &rwork[1], &modeb, &
+ cndnmb, &bnorm, &klb, &kub, "No packing", &b[1], &ldb, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+/* Generate random left hand side vector of GLM */
+
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+/* L20: */
+ }
+
+ zglmts_(&n, &m, &p, &a[1], &af[1], &lda, &b[1], &bf[1], &ldb, &x[
+ 1], &x[*nmax + 1], &x[(*nmax << 1) + 1], &x[*nmax * 3 + 1]
+, &work[1], &lwork, &rwork[1], &resid);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ if (resid >= *thresh) {
+ if (nfail == 0 && firstt) {
+ firstt = FALSE_;
+ alahdg_(nout, path);
+ }
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&resid, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+L30:
+ ;
+ }
+L40:
+ ;
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &c__0);
+
+ return 0;
+
+/* End of ZCKGLM */
+
+} /* zckglm_ */
diff --git a/TESTING/EIG/zckgqr.c b/TESTING/EIG/zckgqr.c
new file mode 100644
index 0000000..4331959
--- /dev/null
+++ b/TESTING/EIG/zckgqr.c
@@ -0,0 +1,425 @@
+/* zckgqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static integer c__1 = 1;
+static integer c__0 = 0;
+
+/* Subroutine */ int zckgqr_(integer *nm, integer *mval, integer *np, integer
+ *pval, integer *nn, integer *nval, integer *nmats, integer *iseed,
+ doublereal *thresh, integer *nmax, doublecomplex *a, doublecomplex *
+ af, doublecomplex *aq, doublecomplex *ar, doublecomplex *taua,
+ doublecomplex *b, doublecomplex *bf, doublecomplex *bz, doublecomplex
+ *bt, doublecomplex *bwk, doublecomplex *taub, doublecomplex *work,
+ doublereal *rwork, integer *nin, integer *nout, integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ZLATMS in ZCKGQR: INFO = \002,i5)";
+ static char fmt_9998[] = "(\002 M=\002,i4,\002 P=\002,i4,\002, N=\002,"
+ "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
+ static char fmt_9997[] = "(\002 N=\002,i4,\002 M=\002,i4,\002, P=\002,"
+ "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, m, n, p, im, in, ip, nt, lda, ldb, kla, klb, kua, kub;
+ char path[3];
+ integer imat;
+ char type__[1];
+ integer nrun, modea, modeb, nfail;
+ char dista[1], distb[1];
+ integer iinfo;
+ doublereal anorm, bnorm;
+ integer lwork;
+ extern /* Subroutine */ int dlatb9_(char *, integer *, integer *, integer
+ *, integer *, char *, integer *, integer *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ doublereal *, char *, char *),
+ alahdg_(integer *, char *);
+ doublereal cndnma, cndnmb;
+ extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
+ *, integer *, integer *), alasum_(char *, integer *,
+ integer *, integer *, integer *);
+ logical dotype[8];
+ extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ logical firstt;
+ doublereal result[7];
+ extern /* Subroutine */ int zgqrts_(integer *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublereal *,
+ doublereal *), zgrqts_(integer *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublereal *,
+ doublereal *);
+
+ /* Fortran I/O blocks */
+ static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCKGQR tests */
+/* ZGGQRF: GQR factorization for N-by-M matrix A and N-by-P matrix B, */
+/* ZGGRQF: GRQ factorization for M-by-N matrix A and P-by-N matrix B. */
+
+/* Arguments */
+/* ========= */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row(column) dimension M. */
+
+/* NP (input) INTEGER */
+/* The number of values of P contained in the vector PVAL. */
+
+/* PVAL (input) INTEGER array, dimension (NP) */
+/* The values of the matrix row(column) dimension P. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column(row) dimension N. */
+
+/* NMATS (input) INTEGER */
+/* The number of matrix types to be tested for each combination */
+/* of matrix dimensions. If NMATS >= NTYPES (the maximum */
+/* number of matrix types), then all the different types are */
+/* generated for testing. If NMATS < NTYPES, another input line */
+/* is read to get the numbers of the matrix types to be used. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator. The array */
+/* elements should be between 0 and 4095, otherwise they will be */
+/* reduced mod 4096, and ISEED(4) must be odd. */
+/* On exit, the next seed in the random number sequence after */
+/* all the test matrices have been generated. */
+
+/* THRESH (input) 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. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AQ (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AR (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* TAUA (workspace) COMPLEX*16 array, dimension (NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* BF (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* BZ (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* BT (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* BWK (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* TAUB (workspace) COMPLEX*16 array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* NIN (input) INTEGER */
+/* The unit number for input. */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit */
+/* > 0 : If ZLATMS returns an error code, the absolute value */
+/* of it is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --taub;
+ --bwk;
+ --bt;
+ --bz;
+ --bf;
+ --b;
+ --taua;
+ --ar;
+ --aq;
+ --af;
+ --a;
+ --iseed;
+ --nval;
+ --pval;
+ --mval;
+
+ /* Function Body */
+ s_copy(path, "GQR", (ftnlen)3, (ftnlen)3);
+ *info = 0;
+ nrun = 0;
+ nfail = 0;
+ firstt = TRUE_;
+ alareq_(path, nmats, dotype, &c__8, nin, nout);
+ lda = *nmax;
+ ldb = *nmax;
+ lwork = *nmax * *nmax;
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Do for each value of P in PVAL. */
+
+ i__2 = *np;
+ for (ip = 1; ip <= i__2; ++ip) {
+ p = pval[ip];
+
+/* Do for each value of N in NVAL. */
+
+ i__3 = *nn;
+ for (in = 1; in <= i__3; ++in) {
+ n = nval[in];
+
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat - 1]) {
+ goto L30;
+ }
+
+/* Test ZGGRQF */
+
+/* Set up parameters with DLATB9 and generate test */
+/* matrices A and B with ZLATMS. */
+
+ dlatb9_("GRQ", &imat, &m, &p, &n, type__, &kla, &kua, &
+ klb, &kub, &anorm, &bnorm, &modea, &modeb, &
+ cndnma, &cndnmb, dista, distb);
+
+ zlatms_(&m, &n, dista, &iseed[1], type__, &rwork[1], &
+ modea, &cndnma, &anorm, &kla, &kua, "No packing",
+ &a[1], &lda, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+ zlatms_(&p, &n, distb, &iseed[1], type__, &rwork[1], &
+ modeb, &cndnmb, &bnorm, &klb, &kub, "No packing",
+ &b[1], &ldb, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+ nt = 4;
+
+ zgrqts_(&m, &p, &n, &a[1], &af[1], &aq[1], &ar[1], &lda, &
+ taua[1], &b[1], &bf[1], &bz[1], &bt[1], &bwk[1], &
+ ldb, &taub[1], &work[1], &lwork, &rwork[1],
+ result);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && firstt) {
+ firstt = FALSE_;
+ alahdg_(nout, "GRQ");
+ }
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L10: */
+ }
+ nrun += nt;
+
+/* Test ZGGQRF */
+
+/* Set up parameters with DLATB9 and generate test */
+/* matrices A and B with ZLATMS. */
+
+ dlatb9_("GQR", &imat, &m, &p, &n, type__, &kla, &kua, &
+ klb, &kub, &anorm, &bnorm, &modea, &modeb, &
+ cndnma, &cndnmb, dista, distb);
+
+ zlatms_(&n, &m, dista, &iseed[1], type__, &rwork[1], &
+ modea, &cndnma, &anorm, &kla, &kua, "No packing",
+ &a[1], &lda, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+ zlatms_(&n, &p, distb, &iseed[1], type__, &rwork[1], &
+ modea, &cndnma, &bnorm, &klb, &kub, "No packing",
+ &b[1], &ldb, &work[1], &iinfo);
+ if (iinfo != 0) {
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+ nt = 4;
+
+ zgqrts_(&n, &m, &p, &a[1], &af[1], &aq[1], &ar[1], &lda, &
+ taua[1], &b[1], &bf[1], &bz[1], &bt[1], &bwk[1], &
+ ldb, &taub[1], &work[1], &lwork, &rwork[1],
+ result);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && firstt) {
+ firstt = FALSE_;
+ alahdg_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+
+L30:
+ ;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &c__0);
+
+ return 0;
+
+/* End of ZCKGQR */
+
+} /* zckgqr_ */
diff --git a/TESTING/EIG/zckgsv.c b/TESTING/EIG/zckgsv.c
new file mode 100644
index 0000000..08aa151
--- /dev/null
+++ b/TESTING/EIG/zckgsv.c
@@ -0,0 +1,319 @@
+/* zckgsv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static integer c__1 = 1;
+static integer c__0 = 0;
+
+/* Subroutine */ int zckgsv_(integer *nm, integer *mval, integer *pval,
+ integer *nval, integer *nmats, integer *iseed, doublereal *thresh,
+ integer *nmax, doublecomplex *a, doublecomplex *af, doublecomplex *b,
+ doublecomplex *bf, doublecomplex *u, doublecomplex *v, doublecomplex *
+ q, doublereal *alpha, doublereal *beta, doublecomplex *r__, integer *
+ iwork, doublecomplex *work, doublereal *rwork, integer *nin, integer *
+ nout, integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ZLATMS in ZCKGSV INFO = \002,i5)";
+ static char fmt_9998[] = "(\002 M=\002,i4,\002 P=\002,i4,\002, N=\002,"
+ "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
+
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, m, n, p, im, nt, lda, ldb, kla, klb, kua, kub, ldq, ldr, ldu,
+ ldv, imat;
+ char path[3], type__[1];
+ integer nrun, modea, modeb, nfail;
+ char dista[1], distb[1];
+ integer iinfo;
+ doublereal anorm, bnorm;
+ integer lwork;
+ extern /* Subroutine */ int dlatb9_(char *, integer *, integer *, integer
+ *, integer *, char *, integer *, integer *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ doublereal *, char *, char *),
+ alahdg_(integer *, char *);
+ doublereal cndnma, cndnmb;
+ extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
+ *, integer *, integer *), alasum_(char *, integer *,
+ integer *, integer *, integer *);
+ logical dotype[8];
+ extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ logical firstt;
+ doublereal result[7];
+ extern /* Subroutine */ int zgsvts_(integer *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *);
+
+ /* Fortran I/O blocks */
+ static cilist io___32 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCKGSV tests ZGGSVD: */
+/* the GSVD for M-by-N matrix A and P-by-N matrix B. */
+
+/* Arguments */
+/* ========= */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* PVAL (input) INTEGER array, dimension (NP) */
+/* The values of the matrix row dimension P. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NMATS (input) INTEGER */
+/* The number of matrix types to be tested for each combination */
+/* of matrix dimensions. If NMATS >= NTYPES (the maximum */
+/* number of matrix types), then all the different types are */
+/* generated for testing. If NMATS < NTYPES, another input line */
+/* is read to get the numbers of the matrix types to be used. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator. The array */
+/* elements should be between 0 and 4095, otherwise they will be */
+/* reduced mod 4096, and ISEED(4) must be odd. */
+/* On exit, the next seed in the random number sequence after */
+/* all the test matrices have been generated. */
+
+/* THRESH (input) 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. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* BF (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* U (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* V (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* Q (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* ALPHA (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* BETA (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* R (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* NIN (input) INTEGER */
+/* The unit number for input. */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit */
+/* > 0 : If ZLATMS returns an error code, the absolute value */
+/* of it is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --iwork;
+ --r__;
+ --beta;
+ --alpha;
+ --q;
+ --v;
+ --u;
+ --bf;
+ --b;
+ --af;
+ --a;
+ --iseed;
+ --nval;
+ --pval;
+ --mval;
+
+ /* Function Body */
+ s_copy(path, "GSV", (ftnlen)3, (ftnlen)3);
+ *info = 0;
+ nrun = 0;
+ nfail = 0;
+ firstt = TRUE_;
+ alareq_(path, nmats, dotype, &c__8, nin, nout);
+ lda = *nmax;
+ ldb = *nmax;
+ ldu = *nmax;
+ ldv = *nmax;
+ ldq = *nmax;
+ ldr = *nmax;
+ lwork = *nmax * *nmax;
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+ p = pval[im];
+ n = nval[im];
+
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat - 1]) {
+ goto L20;
+ }
+
+/* Set up parameters with DLATB9 and generate test */
+/* matrices A and B with ZLATMS. */
+
+ dlatb9_(path, &imat, &m, &p, &n, type__, &kla, &kua, &klb, &kub, &
+ anorm, &bnorm, &modea, &modeb, &cndnma, &cndnmb, dista,
+ distb);
+
+/* Generate M by N matrix A */
+
+ zlatms_(&m, &n, dista, &iseed[1], type__, &rwork[1], &modea, &
+ cndnma, &anorm, &kla, &kua, "No packing", &a[1], &lda, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L20;
+ }
+
+/* Generate P by N matrix B */
+
+ zlatms_(&p, &n, distb, &iseed[1], type__, &rwork[1], &modeb, &
+ cndnmb, &bnorm, &klb, &kub, "No packing", &b[1], &ldb, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L20;
+ }
+
+ nt = 6;
+
+ zgsvts_(&m, &p, &n, &a[1], &af[1], &lda, &b[1], &bf[1], &ldb, &u[
+ 1], &ldu, &v[1], &ldv, &q[1], &ldq, &alpha[1], &beta[1], &
+ r__[1], &ldr, &iwork[1], &work[1], &lwork, &rwork[1],
+ result);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__2 = nt;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && firstt) {
+ firstt = FALSE_;
+ alahdg_(nout, path);
+ }
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L10: */
+ }
+ nrun += nt;
+
+L20:
+ ;
+ }
+/* L30: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &c__0);
+
+ return 0;
+
+/* End of ZCKGSV */
+
+} /* zckgsv_ */
diff --git a/TESTING/EIG/zcklse.c b/TESTING/EIG/zcklse.c
new file mode 100644
index 0000000..d1ae881
--- /dev/null
+++ b/TESTING/EIG/zcklse.c
@@ -0,0 +1,355 @@
+/* zcklse.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static integer c__1 = 1;
+static integer c__0 = 0;
+
+/* Subroutine */ int zcklse_(integer *nn, integer *mval, integer *pval,
+ integer *nval, integer *nmats, integer *iseed, doublereal *thresh,
+ integer *nmax, doublecomplex *a, doublecomplex *af, doublecomplex *b,
+ doublecomplex *bf, doublecomplex *x, doublecomplex *work, doublereal *
+ rwork, integer *nin, integer *nout, integer *info)
+{
+ /* Format strings */
+ static char fmt_9997[] = "(\002 *** Invalid input for LSE: M = \002,"
+ "i6,\002, P = \002,i6,\002, N = \002,i6,\002;\002,/\002 must "
+ "satisfy P <= N <= P+M \002,\002(this set of values will be skip"
+ "ped)\002)";
+ static char fmt_9999[] = "(\002 ZLATMS in ZCKLSE INFO = \002,i5)";
+ static char fmt_9998[] = "(\002 M=\002,i4,\002 P=\002,i4,\002, N=\002,"
+ "i4,\002, type \002,i2,\002, test \002,i2,\002, ratio=\002,g13.6)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), do_fio(integer *
+ , char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, m, n, p, ik, nt, lda, ldb, kla, klb, kua, kub, imat;
+ char path[3], type__[1];
+ integer nrun, modea, modeb, nfail;
+ char dista[1], distb[1];
+ integer iinfo;
+ doublereal anorm, bnorm;
+ integer lwork;
+ extern /* Subroutine */ int dlatb9_(char *, integer *, integer *, integer
+ *, integer *, char *, integer *, integer *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ doublereal *, char *, char *),
+ alahdg_(integer *, char *);
+ doublereal cndnma, cndnmb;
+ extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
+ *, integer *, integer *), alasum_(char *, integer *,
+ integer *, integer *, integer *), zlarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *);
+ logical dotype[8];
+ extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ logical firstt;
+ doublereal result[7];
+ extern /* Subroutine */ int zlsets_(integer *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, doublereal *, doublereal *);
+
+ /* Fortran I/O blocks */
+ static cilist io___13 = { 0, 0, 0, 0, 0 };
+ static cilist io___14 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCKLSE tests ZGGLSE - a subroutine for solving linear equality */
+/* constrained least square problem (LSE). */
+
+/* Arguments */
+/* ========= */
+
+/* NN (input) INTEGER */
+/* The number of values of (M,P,N) contained in the vectors */
+/* (MVAL, PVAL, NVAL). */
+
+/* MVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix row(column) dimension M. */
+
+/* PVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix row(column) dimension P. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column(row) dimension N. */
+
+/* NMATS (input) INTEGER */
+/* The number of matrix types to be tested for each combination */
+/* of matrix dimensions. If NMATS >= NTYPES (the maximum */
+/* number of matrix types), then all the different types are */
+/* generated for testing. If NMATS < NTYPES, another input line */
+/* is read to get the numbers of the matrix types to be used. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator. The array */
+/* elements should be between 0 and 4095, otherwise they will be */
+/* reduced mod 4096, and ISEED(4) must be odd. */
+/* On exit, the next seed in the random number sequence after */
+/* all the test matrices have been generated. */
+
+/* THRESH (input) 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. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* BF (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* X (workspace) COMPLEX*16 array, dimension (5*NMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* NIN (input) INTEGER */
+/* The unit number for input. */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* INFO (output) INTEGER */
+/* = 0 : successful exit */
+/* > 0 : If ZLATMS returns an error code, the absolute value */
+/* of it is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --x;
+ --bf;
+ --b;
+ --af;
+ --a;
+ --iseed;
+ --nval;
+ --pval;
+ --mval;
+
+ /* Function Body */
+ s_copy(path, "LSE", (ftnlen)3, (ftnlen)3);
+ *info = 0;
+ nrun = 0;
+ nfail = 0;
+ firstt = TRUE_;
+ alareq_(path, nmats, dotype, &c__8, nin, nout);
+ lda = *nmax;
+ ldb = *nmax;
+ lwork = *nmax * *nmax;
+
+/* Check for valid input values. */
+
+ i__1 = *nn;
+ for (ik = 1; ik <= i__1; ++ik) {
+ m = mval[ik];
+ p = pval[ik];
+ n = nval[ik];
+ if (p > n || n > m + p) {
+ if (firstt) {
+ io___13.ciunit = *nout;
+ s_wsle(&io___13);
+ e_wsle();
+ firstt = FALSE_;
+ }
+ io___14.ciunit = *nout;
+ s_wsfe(&io___14);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L10: */
+ }
+ firstt = TRUE_;
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nn;
+ for (ik = 1; ik <= i__1; ++ik) {
+ m = mval[ik];
+ p = pval[ik];
+ n = nval[ik];
+ if (p > n || n > m + p) {
+ goto L40;
+ }
+
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat - 1]) {
+ goto L30;
+ }
+
+/* Set up parameters with DLATB9 and generate test */
+/* matrices A and B with ZLATMS. */
+
+ dlatb9_(path, &imat, &m, &p, &n, type__, &kla, &kua, &klb, &kub, &
+ anorm, &bnorm, &modea, &modeb, &cndnma, &cndnmb, dista,
+ distb);
+
+ zlatms_(&m, &n, dista, &iseed[1], type__, &rwork[1], &modea, &
+ cndnma, &anorm, &kla, &kua, "No packing", &a[1], &lda, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+ zlatms_(&p, &n, distb, &iseed[1], type__, &rwork[1], &modeb, &
+ cndnmb, &bnorm, &klb, &kub, "No packing", &b[1], &ldb, &
+ work[1], &iinfo);
+ if (iinfo != 0) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L30;
+ }
+
+/* Generate the right-hand sides C and D for the LSE. */
+
+/* Computing MAX */
+ i__3 = m - 1;
+ i__2 = max(i__3,0);
+/* Computing MAX */
+ i__5 = n - 1;
+ i__4 = max(i__5,0);
+ i__6 = max(n,1);
+ i__7 = max(m,1);
+ zlarhs_("ZGE", "New solution", "Upper", "N", &m, &n, &i__2, &i__4,
+ &c__1, &a[1], &lda, &x[(*nmax << 2) + 1], &i__6, &x[1], &
+ i__7, &iseed[1], &iinfo);
+
+/* Computing MAX */
+ i__3 = p - 1;
+ i__2 = max(i__3,0);
+/* Computing MAX */
+ i__5 = n - 1;
+ i__4 = max(i__5,0);
+ i__6 = max(n,1);
+ i__7 = max(p,1);
+ zlarhs_("ZGE", "Computed", "Upper", "N", &p, &n, &i__2, &i__4, &
+ c__1, &b[1], &ldb, &x[(*nmax << 2) + 1], &i__6, &x[(*nmax
+ << 1) + 1], &i__7, &iseed[1], &iinfo);
+
+ nt = 2;
+
+ zlsets_(&m, &p, &n, &a[1], &af[1], &lda, &b[1], &bf[1], &ldb, &x[
+ 1], &x[*nmax + 1], &x[(*nmax << 1) + 1], &x[*nmax * 3 + 1]
+, &x[(*nmax << 2) + 1], &work[1], &lwork, &rwork[1],
+ result);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__2 = nt;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && firstt) {
+ firstt = FALSE_;
+ alahdg_(nout, path);
+ }
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&p, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+
+L30:
+ ;
+ }
+L40:
+ ;
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &c__0);
+
+ return 0;
+
+/* End of ZCKLSE */
+
+} /* zcklse_ */
diff --git a/TESTING/EIG/zdrges.c b/TESTING/EIG/zdrges.c
new file mode 100644
index 0000000..2f9da7f
--- /dev/null
+++ b/TESTING/EIG/zdrges.c
@@ -0,0 +1,1141 @@
+/* zdrges.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static doublereal c_b29 = 1.;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static integer c__0 = 0;
+
+/* Subroutine */ int zdrges_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
+ doublecomplex *a, integer *lda, doublecomplex *b, doublecomplex *s,
+ doublecomplex *t, doublecomplex *q, integer *ldq, doublecomplex *z__,
+ doublecomplex *alpha, doublecomplex *beta, doublecomplex *work,
+ integer *lwork, doublereal *rwork, doublereal *result, logical *bwork,
+ integer *info)
+{
+ /* Initialized data */
+
+ static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
+ 2,2,2,3 };
+ static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
+ 2,3,2,1 };
+ static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
+ 1,1,1,1 };
+ static logical lasign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ TRUE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,FALSE_,
+ TRUE_,FALSE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_ };
+ static logical lbsign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ FALSE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,FALSE_,
+ TRUE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ FALSE_ };
+ static integer kz1[6] = { 0,1,2,1,3,3 };
+ static integer kz2[6] = { 0,0,1,2,1,1 };
+ static integer kadd[6] = { 0,0,0,0,3,2 };
+ static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
+ 4,4,4,0 };
+ static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
+ 8,8,8,8,8,0 };
+ static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
+ 3,3,3,1 };
+ static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
+ 4,4,4,1 };
+ static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
+ 3,3,2,1 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ZDRGES: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,4(i4,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 ZDRGES: S not in Schur form at eigenvalu"
+ "e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, "
+ "ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9997[] = "(/1x,a3,\002 -- Complex Generalized Schur from"
+ " problem \002,\002driver\002)";
+ static char fmt_9996[] = "(\002 Matrix types (see ZDRGES for details):"
+ " \002)";
+ static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
+ "osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
+ ") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
+ "onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
+ "I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
+ "arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
+ "(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
+ "=(D, reversed D)\002)";
+ static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
+ "atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
+ " 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
+ "ha&beta \002,\002 20=arithmetic alpha, beta=0,"
+ "1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
+ "=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
+ "/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
+ "l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
+ ".\002)";
+ static char fmt_9993[] = "(/\002 Tests performed: (S is Schur, T is tri"
+ "angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002l and r "
+ "are the appropriate left and right\002,/19x,\002eigenvectors, re"
+ "sp., a is alpha, b is beta, and\002,/19x,a,\002 means \002,a,"
+ "\002.)\002,/\002 Without ordering: \002,/\002 1 = | A - Q S "
+ "Z\002,a,\002 | / ( |A| n ulp ) 2 = | B - Q T Z\002,a,\002 |"
+ " / ( |B| n ulp )\002,/\002 3 = | I - QQ\002,a,\002 | / ( n ulp "
+ ") 4 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 5"
+ " = A is in Schur form S\002,/\002 6 = difference between (alpha"
+ ",beta)\002,\002 and diagonals of (S,T)\002,/\002 With ordering:"
+ " \002,/\002 7 = | (A,B) - Q (S,T) Z\002,a,\002 | / ( |(A,B)| n "
+ "ulp )\002,/\002 8 = | I - QQ\002,a,\002 | / ( n ulp ) "
+ " 9 = | I - ZZ\002,a,\002 | / ( n ulp )\002,/\002 10 = A is in "
+ "Schur form S\002,/\002 11 = difference between (alpha,beta) and "
+ "diagonals\002,\002 of (S,T)\002,/\002 12 = SDIM is the correct n"
+ "umber of \002,\002selected eigenvalues\002,/)";
+ static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",0p,f8.2)";
+ static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",1p,d10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1,
+ s_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2, i__3,
+ i__4, i__5, i__6, i__7, i__8, i__9, i__10, i__11;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
+ d__11, d__12, d__13, d__14, d__15, d__16;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *), z_abs(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, n, n1, jc, nb, in, jr;
+ doublereal ulp;
+ integer iadd, sdim, nmax, rsub;
+ char sort[1];
+ doublereal temp1, temp2;
+ logical badnn;
+ integer iinfo;
+ doublereal rmagn[4];
+ doublecomplex ctemp;
+ extern /* Subroutine */ int zget51_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *
+, doublecomplex *, integer *, doublecomplex *, doublereal *,
+ doublereal *), zgges_(char *, char *, char *, L_fp, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, logical *, integer *);
+ integer nmats, jsize;
+ extern /* Subroutine */ int zget54_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublereal *);
+ integer nerrs, jtype, ntest, isort;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), zlatm4_(
+ integer *, integer *, integer *, integer *, logical *, doublereal
+ *, doublereal *, doublereal *, integer *, integer *,
+ doublecomplex *, integer *);
+ logical ilabad;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal safmin, safmax;
+ integer knteig, ioldsd[4];
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *), xerbla_(char *, integer *),
+ zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *);
+ extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
+ integer *);
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *);
+ extern logical zlctes_(doublecomplex *, doublecomplex *);
+ integer minwrk, maxwrk;
+ doublereal ulpinv;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9991, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRGES checks the nonsymmetric generalized eigenvalue (Schur form) */
+/* problem driver ZGGES. */
+
+/* ZGGES factors A and B as Q*S*Z' and Q*T*Z' , where ' means conjugate */
+/* transpose, S and T are upper triangular (i.e., in generalized Schur */
+/* form), and Q and Z are unitary. It also computes the generalized */
+/* eigenvalues (alpha(j),beta(j)), j=1,...,n. Thus, */
+/* w(j) = alpha(j)/beta(j) is a root of the characteristic equation */
+
+/* det( A - w(j) B ) = 0 */
+
+/* Optionally it also reorder the eigenvalues so that a selected */
+/* cluster of eigenvalues appears in the leading diagonal block of the */
+/* Schur forms. */
+
+/* When ZDRGES is called, a number of matrix "sizes" ("N's") and a */
+/* number of matrix "TYPES" are specified. For each size ("N") */
+/* and each TYPE of matrix, a pair of matrices (A, B) will be generated */
+/* and used for testing. For each matrix pair, the following 13 tests */
+/* will be performed and compared with the threshhold THRESH except */
+/* the tests (5), (11) and (13). */
+
+
+/* (1) | A - Q S Z' | / ( |A| n ulp ) (no sorting of eigenvalues) */
+
+
+/* (2) | B - Q T Z' | / ( |B| n ulp ) (no sorting of eigenvalues) */
+
+
+/* (3) | I - QQ' | / ( n ulp ) (no sorting of eigenvalues) */
+
+
+/* (4) | I - ZZ' | / ( n ulp ) (no sorting of eigenvalues) */
+
+/* (5) if A is in Schur form (i.e. triangular form) (no sorting of */
+/* eigenvalues) */
+
+/* (6) if eigenvalues = diagonal elements of the Schur form (S, T), */
+/* i.e., test the maximum over j of D(j) where: */
+
+/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
+/* D(j) = ------------------------ + ----------------------- */
+/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
+
+/* (no sorting of eigenvalues) */
+
+/* (7) | (A,B) - Q (S,T) Z' | / ( |(A,B)| n ulp ) */
+/* (with sorting of eigenvalues). */
+
+/* (8) | I - QQ' | / ( n ulp ) (with sorting of eigenvalues). */
+
+/* (9) | I - ZZ' | / ( n ulp ) (with sorting of eigenvalues). */
+
+/* (10) if A is in Schur form (i.e. quasi-triangular form) */
+/* (with sorting of eigenvalues). */
+
+/* (11) if eigenvalues = diagonal elements of the Schur form (S, T), */
+/* i.e. test the maximum over j of D(j) where: */
+
+/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
+/* D(j) = ------------------------ + ----------------------- */
+/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
+
+/* (with sorting of eigenvalues). */
+
+/* (12) if sorting worked and SDIM is the number of eigenvalues */
+/* which were CELECTed. */
+
+/* Test Matrices */
+/* ============= */
+
+/* The sizes of the test matrices are specified by an array */
+/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
+/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) ( 0, 0 ) (a pair of zero matrices) */
+
+/* (2) ( I, 0 ) (an identity and a zero matrix) */
+
+/* (3) ( 0, I ) (an identity and a zero matrix) */
+
+/* (4) ( I, I ) (a pair of identity matrices) */
+
+/* t t */
+/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
+
+/* t ( I 0 ) */
+/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
+/* ( 0 I ) ( 0 J ) */
+/* and I is a k x k identity and J a (k+1)x(k+1) */
+/* Jordan block; k=(N-1)/2 */
+
+/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
+/* matrix with those diagonal entries.) */
+/* (8) ( I, D ) */
+
+/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
+
+/* (10) ( small*D, big*I ) */
+
+/* (11) ( big*I, small*D ) */
+
+/* (12) ( small*I, big*D ) */
+
+/* (13) ( big*D, big*I ) */
+
+/* (14) ( small*D, small*I ) */
+
+/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
+/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
+/* t t */
+/* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. */
+
+/* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices */
+/* with random O(1) entries above the diagonal */
+/* and diagonal entries diag(T1) = */
+/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
+/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
+
+/* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
+/* s = machine precision. */
+
+/* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
+
+/* N-5 */
+/* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+
+/* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+/* where r1,..., r(N-4) are random. */
+
+/* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular */
+/* matrices. */
+
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* DDRGES does nothing. NSIZES >= 0. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. NN >= 0. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, DDRGES */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A on input. */
+/* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to DDRGES to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error is */
+/* scaled to be O(1), so THRESH should be a reasonably small */
+/* multiple of 1, e.g., 10 or 100. In particular, it should */
+/* not depend on the precision (single vs. double) or the size */
+/* of the matrix. THRESH >= 0. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace) COMPLEX*16 array, dimension(LDA, max(NN)) */
+/* Used to hold the original A matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, S, and T. */
+/* It must be at least 1 and at least max( NN ). */
+
+/* B (input/workspace) COMPLEX*16 array, dimension(LDA, max(NN)) */
+/* Used to hold the original B matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* S (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* The Schur form matrix computed from A by ZGGES. On exit, S */
+/* contains the Schur form matrix corresponding to the matrix */
+/* in A. */
+
+/* T (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from B by ZGGES. */
+
+/* Q (workspace) COMPLEX*16 array, dimension (LDQ, max(NN)) */
+/* The (left) orthogonal matrix computed by ZGGES. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of Q and Z. It must */
+/* be at least 1 and at least max( NN ). */
+
+/* Z (workspace) COMPLEX*16 array, dimension( LDQ, max(NN) ) */
+/* The (right) orthogonal matrix computed by ZGGES. */
+
+/* ALPHA (workspace) COMPLEX*16 array, dimension (max(NN)) */
+/* BETA (workspace) COMPLEX*16 array, dimension (max(NN)) */
+/* The generalized eigenvalues of (A,B) computed by ZGGES. */
+/* ALPHA(k) / BETA(k) is the k-th generalized eigenvalue of A */
+/* and B. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= 3*N*N. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension ( 8*N ) */
+/* Real workspace. */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (15) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid overflow. */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: A routine returned an error code. INFO is the */
+/* absolute value of the INFO value returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ t_dim1 = *lda;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ s_dim1 = *lda;
+ s_offset = 1 + s_dim1;
+ s -= s_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ z_dim1 = *ldq;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --alpha;
+ --beta;
+ --work;
+ --rwork;
+ --result;
+ --bwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.) {
+ *info = -6;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldq <= 1 || *ldq < nmax) {
+ *info = -14;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. */
+
+ minwrk = 1;
+ if (*info == 0 && *lwork >= 1) {
+ minwrk = nmax * 3 * nmax;
+/* Computing MAX */
+ i__1 = 1, i__2 = ilaenv_(&c__1, "ZGEQRF", " ", &nmax, &nmax, &c_n1, &
+ c_n1), i__1 = max(i__1,i__2), i__2 =
+ ilaenv_(&c__1, "ZUNMQR", "LC", &nmax, &nmax, &nmax, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
+ c__1, "ZUNGQR", " ", &nmax, &nmax, &nmax, &c_n1);
+ nb = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = nmax + nmax * nb, i__2 = nmax * 3 * nmax;
+ maxwrk = max(i__1,i__2);
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+ }
+
+ if (*lwork < minwrk) {
+ *info = -19;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZDRGES", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+ ulp = dlamch_("Precision");
+ safmin = dlamch_("Safe minimum");
+ safmin /= ulp;
+ safmax = 1. / safmin;
+ dlabad_(&safmin, &safmax);
+ ulpinv = 1. / ulp;
+
+/* The values RMAGN(2:3) depend on N, see below. */
+
+ rmagn[0] = 0.;
+ rmagn[1] = 1.;
+
+/* Loop over matrix sizes */
+
+ ntestt = 0;
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ n1 = max(1,n);
+ rmagn[2] = safmax * ulp / (doublereal) n1;
+ rmagn[3] = safmin * ulpinv * (doublereal) n1;
+
+ if (*nsizes != 1) {
+ mtypes = min(26,*ntypes);
+ } else {
+ mtypes = min(27,*ntypes);
+ }
+
+/* Loop over matrix types */
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L180;
+ }
+ ++nmats;
+ ntest = 0;
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 13; ++j) {
+ result[j] = 0.;
+/* L30: */
+ }
+
+/* Generate test matrices A and B */
+
+/* Description of control parameters: */
+
+/* KZLASS: =1 means w/o rotation, =2 means w/ rotation, */
+/* =3 means random. */
+/* KATYPE: the "type" to be passed to ZLATM4 for computing A. */
+/* KAZERO: the pattern of zeros on the diagonal for A: */
+/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
+/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
+/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
+/* non-zero entries.) */
+/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
+/* =2: large, =3: small. */
+/* LASIGN: .TRUE. if the diagonal elements of A are to be */
+/* multiplied by a random magnitude 1 number. */
+/* KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B. */
+/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
+/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
+/* RMAGN: used to implement KAMAGN and KBMAGN. */
+
+ if (mtypes > 26) {
+ goto L110;
+ }
+ iinfo = 0;
+ if (kclass[jtype - 1] < 3) {
+
+/* Generate A (w/o rotation) */
+
+ if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ zlaset_("Full", &n, &n, &c_b1, &c_b1, &a[a_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ zlatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
+ &kz2[kazero[jtype - 1] - 1], &lasign[jtype - 1], &
+ rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
+ 1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
+ a_offset], lda);
+ iadd = kadd[kazero[jtype - 1] - 1];
+ if (iadd > 0 && iadd <= n) {
+ i__3 = iadd + iadd * a_dim1;
+ i__4 = kamagn[jtype - 1];
+ a[i__3].r = rmagn[i__4], a[i__3].i = 0.;
+ }
+
+/* Generate B (w/o rotation) */
+
+ if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ zlaset_("Full", &n, &n, &c_b1, &c_b1, &b[b_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ zlatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
+ &kz2[kbzero[jtype - 1] - 1], &lbsign[jtype - 1], &
+ rmagn[kbmagn[jtype - 1]], &c_b29, &rmagn[ktrian[jtype
+ - 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
+ b_offset], lda);
+ iadd = kadd[kbzero[jtype - 1] - 1];
+ if (iadd != 0 && iadd <= n) {
+ i__3 = iadd + iadd * b_dim1;
+ i__4 = kbmagn[jtype - 1];
+ b[i__3].r = rmagn[i__4], b[i__3].i = 0.;
+ }
+
+ if (kclass[jtype - 1] == 2 && n > 0) {
+
+/* Include rotations */
+
+/* Generate Q, Z as Householder transformations times */
+/* a diagonal matrix. */
+
+ i__3 = n - 1;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = jc; jr <= i__4; ++jr) {
+ i__5 = jr + jc * q_dim1;
+ zlarnd_(&z__1, &c__3, &iseed[1]);
+ q[i__5].r = z__1.r, q[i__5].i = z__1.i;
+ i__5 = jr + jc * z_dim1;
+ zlarnd_(&z__1, &c__3, &iseed[1]);
+ z__[i__5].r = z__1.r, z__[i__5].i = z__1.i;
+/* L40: */
+ }
+ i__4 = n + 1 - jc;
+ zlarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc *
+ q_dim1], &c__1, &work[jc]);
+ i__4 = (n << 1) + jc;
+ i__5 = jc + jc * q_dim1;
+ d__2 = q[i__5].r;
+ d__1 = d_sign(&c_b29, &d__2);
+ work[i__4].r = d__1, work[i__4].i = 0.;
+ i__4 = jc + jc * q_dim1;
+ q[i__4].r = 1., q[i__4].i = 0.;
+ i__4 = n + 1 - jc;
+ zlarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 +
+ jc * z_dim1], &c__1, &work[n + jc]);
+ i__4 = n * 3 + jc;
+ i__5 = jc + jc * z_dim1;
+ d__2 = z__[i__5].r;
+ d__1 = d_sign(&c_b29, &d__2);
+ work[i__4].r = d__1, work[i__4].i = 0.;
+ i__4 = jc + jc * z_dim1;
+ z__[i__4].r = 1., z__[i__4].i = 0.;
+/* L50: */
+ }
+ zlarnd_(&z__1, &c__3, &iseed[1]);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__3 = n + n * q_dim1;
+ q[i__3].r = 1., q[i__3].i = 0.;
+ i__3 = n;
+ work[i__3].r = 0., work[i__3].i = 0.;
+ i__3 = n * 3;
+ d__1 = z_abs(&ctemp);
+ z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ zlarnd_(&z__1, &c__3, &iseed[1]);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__3 = n + n * z_dim1;
+ z__[i__3].r = 1., z__[i__3].i = 0.;
+ i__3 = n << 1;
+ work[i__3].r = 0., work[i__3].i = 0.;
+ i__3 = n << 2;
+ d__1 = z_abs(&ctemp);
+ z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+
+/* Apply the diagonal matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ i__5 = jr + jc * a_dim1;
+ i__6 = (n << 1) + jr;
+ d_cnjg(&z__3, &work[n * 3 + jc]);
+ z__2.r = work[i__6].r * z__3.r - work[i__6].i *
+ z__3.i, z__2.i = work[i__6].r * z__3.i +
+ work[i__6].i * z__3.r;
+ i__7 = jr + jc * a_dim1;
+ z__1.r = z__2.r * a[i__7].r - z__2.i * a[i__7].i,
+ z__1.i = z__2.r * a[i__7].i + z__2.i * a[
+ i__7].r;
+ a[i__5].r = z__1.r, a[i__5].i = z__1.i;
+ i__5 = jr + jc * b_dim1;
+ i__6 = (n << 1) + jr;
+ d_cnjg(&z__3, &work[n * 3 + jc]);
+ z__2.r = work[i__6].r * z__3.r - work[i__6].i *
+ z__3.i, z__2.i = work[i__6].r * z__3.i +
+ work[i__6].i * z__3.r;
+ i__7 = jr + jc * b_dim1;
+ z__1.r = z__2.r * b[i__7].r - z__2.i * b[i__7].i,
+ z__1.i = z__2.r * b[i__7].i + z__2.i * b[
+ i__7].r;
+ b[i__5].r = z__1.r, b[i__5].i = z__1.i;
+/* L60: */
+ }
+/* L70: */
+ }
+ i__3 = n - 1;
+ zunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ zunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &a[a_offset], lda, &work[(n << 1) +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ zunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &b[b_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ zunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &b[b_offset], lda, &work[(n << 1) +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ }
+ } else {
+
+/* Random matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ i__5 = jr + jc * a_dim1;
+ i__6 = kamagn[jtype - 1];
+ zlarnd_(&z__2, &c__4, &iseed[1]);
+ z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] *
+ z__2.i;
+ a[i__5].r = z__1.r, a[i__5].i = z__1.i;
+ i__5 = jr + jc * b_dim1;
+ i__6 = kbmagn[jtype - 1];
+ zlarnd_(&z__2, &c__4, &iseed[1]);
+ z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] *
+ z__2.i;
+ b[i__5].r = z__1.r, b[i__5].i = z__1.i;
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+
+L100:
+
+ if (iinfo != 0) {
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L110:
+
+ for (i__ = 1; i__ <= 13; ++i__) {
+ result[i__] = -1.;
+/* L120: */
+ }
+
+/* Test with and without sorting of eigenvalues */
+
+ for (isort = 0; isort <= 1; ++isort) {
+ if (isort == 0) {
+ *(unsigned char *)sort = 'N';
+ rsub = 0;
+ } else {
+ *(unsigned char *)sort = 'S';
+ rsub = 5;
+ }
+
+/* Call ZGGES to compute H, T, Q, Z, alpha, and beta. */
+
+ zlacpy_("Full", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ zlacpy_("Full", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ ntest = rsub + 1 + isort;
+ result[rsub + 1 + isort] = ulpinv;
+ zgges_("V", "V", sort, (L_fp)zlctes_, &n, &s[s_offset], lda, &
+ t[t_offset], lda, &sdim, &alpha[1], &beta[1], &q[
+ q_offset], ldq, &z__[z_offset], ldq, &work[1], lwork,
+ &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0 && iinfo != n + 2) {
+ result[rsub + 1 + isort] = ulpinv;
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ do_fio(&c__1, "ZGGES", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L160;
+ }
+
+ ntest = rsub + 4;
+
+/* Do tests 1--4 (or tests 7--9 when reordering ) */
+
+ if (isort == 0) {
+ zget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, &
+ q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
+ rwork[1], &result[1]);
+ zget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &
+ q[q_offset], ldq, &z__[z_offset], ldq, &work[1], &
+ rwork[1], &result[2]);
+ } else {
+ zget54_(&n, &a[a_offset], lda, &b[b_offset], lda, &s[
+ s_offset], lda, &t[t_offset], lda, &q[q_offset],
+ ldq, &z__[z_offset], ldq, &work[1], &result[rsub
+ + 2]);
+ }
+
+ zget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
+ q_offset], ldq, &q[q_offset], ldq, &work[1], &rwork[1]
+, &result[rsub + 3]);
+ zget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[
+ z_offset], ldq, &z__[z_offset], ldq, &work[1], &rwork[
+ 1], &result[rsub + 4]);
+
+/* Do test 5 and 6 (or Tests 10 and 11 when reordering): */
+/* check Schur form of A and compare eigenvalues with */
+/* diagonals. */
+
+ ntest = rsub + 6;
+ temp1 = 0.;
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ ilabad = FALSE_;
+ i__4 = j;
+ i__5 = j + j * s_dim1;
+ z__2.r = alpha[i__4].r - s[i__5].r, z__2.i = alpha[i__4]
+ .i - s[i__5].i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ i__6 = j;
+ i__7 = j + j * t_dim1;
+ z__4.r = beta[i__6].r - t[i__7].r, z__4.i = beta[i__6].i
+ - t[i__7].i;
+ z__3.r = z__4.r, z__3.i = z__4.i;
+/* Computing MAX */
+ i__8 = j;
+ i__9 = j + j * s_dim1;
+ d__13 = safmin, d__14 = (d__1 = alpha[i__8].r, abs(d__1))
+ + (d__2 = d_imag(&alpha[j]), abs(d__2)), d__13 =
+ max(d__13,d__14), d__14 = (d__3 = s[i__9].r, abs(
+ d__3)) + (d__4 = d_imag(&s[j + j * s_dim1]), abs(
+ d__4));
+/* Computing MAX */
+ i__10 = j;
+ i__11 = j + j * t_dim1;
+ d__15 = safmin, d__16 = (d__5 = beta[i__10].r, abs(d__5))
+ + (d__6 = d_imag(&beta[j]), abs(d__6)), d__15 =
+ max(d__15,d__16), d__16 = (d__7 = t[i__11].r, abs(
+ d__7)) + (d__8 = d_imag(&t[j + j * t_dim1]), abs(
+ d__8));
+ temp2 = (((d__9 = z__1.r, abs(d__9)) + (d__10 = d_imag(&
+ z__1), abs(d__10))) / max(d__13,d__14) + ((d__11 =
+ z__3.r, abs(d__11)) + (d__12 = d_imag(&z__3),
+ abs(d__12))) / max(d__15,d__16)) / ulp;
+
+ if (j < n) {
+ i__4 = j + 1 + j * s_dim1;
+ if (s[i__4].r != 0. || s[i__4].i != 0.) {
+ ilabad = TRUE_;
+ result[rsub + 5] = ulpinv;
+ }
+ }
+ if (j > 1) {
+ i__4 = j + (j - 1) * s_dim1;
+ if (s[i__4].r != 0. || s[i__4].i != 0.) {
+ ilabad = TRUE_;
+ result[rsub + 5] = ulpinv;
+ }
+ }
+ temp1 = max(temp1,temp2);
+ if (ilabad) {
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+/* L130: */
+ }
+ result[rsub + 6] = temp1;
+
+ if (isort >= 1) {
+
+/* Do test 12 */
+
+ ntest = 12;
+ result[12] = 0.;
+ knteig = 0;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (zlctes_(&alpha[i__], &beta[i__])) {
+ ++knteig;
+ }
+/* L140: */
+ }
+ if (sdim != knteig) {
+ result[13] = ulpinv;
+ }
+ }
+
+/* L150: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L160:
+
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__3 = ntest;
+ for (jr = 1; jr <= i__3; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, "ZGS", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ e_wsfe();
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+ e_wsfe();
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ do_fio(&c__1, "Unitary", (ftnlen)7);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, "unitary", (ftnlen)7);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ for (j = 1; j <= 8; ++j) {
+ do_fio(&c__1, "'", (ftnlen)1);
+ }
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[jr] < 1e4) {
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ } else {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+ }
+/* L170: */
+ }
+
+L180:
+ ;
+ }
+/* L190: */
+ }
+
+/* Summary */
+
+ alasvm_("ZGS", nounit, &nerrs, &ntestt, &c__0);
+
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+
+ return 0;
+
+
+
+
+
+
+
+/* End of ZDRGES */
+
+} /* zdrges_ */
diff --git a/TESTING/EIG/zdrgev.c b/TESTING/EIG/zdrgev.c
new file mode 100644
index 0000000..a6dac35
--- /dev/null
+++ b/TESTING/EIG/zdrgev.c
@@ -0,0 +1,1153 @@
+/* zdrgev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static doublereal c_b28 = 1.;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+static integer c__0 = 0;
+
+/* Subroutine */ int zdrgev_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
+ doublecomplex *a, integer *lda, doublecomplex *b, doublecomplex *s,
+ doublecomplex *t, doublecomplex *q, integer *ldq, doublecomplex *z__,
+ doublecomplex *qe, integer *ldqe, doublecomplex *alpha, doublecomplex
+ *beta, doublecomplex *alpha1, doublecomplex *beta1, doublecomplex *
+ work, integer *lwork, doublereal *rwork, doublereal *result, integer *
+ info)
+{
+ /* Initialized data */
+
+ static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
+ 2,2,2,3 };
+ static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
+ 2,3,2,1 };
+ static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
+ 1,1,1,1 };
+ static logical lasign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ TRUE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,FALSE_,
+ TRUE_,FALSE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_ };
+ static logical lbsign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ FALSE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,FALSE_,
+ TRUE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ FALSE_ };
+ static integer kz1[6] = { 0,1,2,1,3,3 };
+ static integer kz2[6] = { 0,0,1,2,1,1 };
+ static integer kadd[6] = { 0,0,0,0,3,2 };
+ static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
+ 4,4,4,0 };
+ static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
+ 8,8,8,8,8,0 };
+ static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
+ 3,3,3,1 };
+ static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
+ 4,4,4,1 };
+ static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
+ 3,3,2,1 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ZDRGEV: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/3x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 ZDRGEV: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,3x,\002N=\002,i4,\002, JTYPE=\002,"
+ "i3,\002, ISEED=(\002,3(i4,\002,\002),i5,\002)\002)";
+ static char fmt_9997[] = "(/1x,a3,\002 -- Complex Generalized eigenvalue"
+ " problem \002,\002driver\002)";
+ static char fmt_9996[] = "(\002 Matrix types (see ZDRGEV for details):"
+ " \002)";
+ static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
+ "osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
+ ") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
+ "onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
+ "I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
+ "arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
+ "(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
+ "=(D, reversed D)\002)";
+ static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
+ "atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
+ " 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
+ "ha&beta \002,\002 20=arithmetic alpha, beta=0,"
+ "1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
+ "=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
+ "/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
+ "l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
+ ".\002)";
+ static char fmt_9993[] = "(/\002 Tests performed: \002,/\002 1 = max "
+ "| ( b A - a B )'*l | / const.,\002,/\002 2 = | |VR(i)| - 1 | / u"
+ "lp,\002,/\002 3 = max | ( b A - a B )*r | / const.\002,/\002 4 ="
+ " | |VL(i)| - 1 | / ulp,\002,/\002 5 = 0 if W same no matter if r"
+ " or l computed,\002,/\002 6 = 0 if l same no matter if l compute"
+ "d,\002,/\002 7 = 0 if r same no matter if r computed,\002,/1x)";
+ static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",0p,f8.2)";
+ static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i2,\002 is\002"
+ ",1p,d10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, qe_dim1,
+ qe_offset, s_dim1, s_offset, t_dim1, t_offset, z_dim1, z_offset,
+ i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *), z_abs(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, n, n1, jc, nb, in, jr;
+ doublereal ulp;
+ integer iadd, ierr, nmax;
+ logical badnn;
+ doublereal rmagn[4];
+ doublecomplex ctemp;
+ extern /* Subroutine */ int zget52_(logical *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *
+, doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
+ doublereal *);
+ integer nmats, jsize;
+ extern /* Subroutine */ int zggev_(char *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *);
+ integer nerrs, jtype;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), zlatm4_(
+ integer *, integer *, integer *, integer *, logical *, doublereal
+ *, doublereal *, doublereal *, integer *, integer *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal safmin, safmax;
+ integer ioldsd[4];
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *), xerbla_(char *, integer *),
+ zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *);
+ extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
+ integer *);
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *);
+ integer minwrk, maxwrk;
+ doublereal ulpinv;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9991, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRGEV checks the nonsymmetric generalized eigenvalue problem driver */
+/* routine ZGGEV. */
+
+/* ZGGEV computes for a pair of n-by-n nonsymmetric matrices (A,B) the */
+/* generalized eigenvalues and, optionally, the left and right */
+/* eigenvectors. */
+
+/* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w */
+/* or a ratio alpha/beta = w, such that A - w*B is singular. It is */
+/* usually represented as the pair (alpha,beta), as there is reasonalbe */
+/* interpretation for beta=0, and even for both being zero. */
+
+/* A right generalized eigenvector corresponding to a generalized */
+/* eigenvalue w for a pair of matrices (A,B) is a vector r such that */
+/* (A - wB) * r = 0. A left generalized eigenvector is a vector l such */
+/* that l**H * (A - wB) = 0, where l**H is the conjugate-transpose of l. */
+
+/* When ZDRGEV is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, a pair of matrices (A, B) will be generated */
+/* and used for testing. For each matrix pair, the following tests */
+/* will be performed and compared with the threshhold THRESH. */
+
+/* Results from ZGGEV: */
+
+/* (1) max over all left eigenvalue/-vector pairs (alpha/beta,l) of */
+
+/* | VL**H * (beta A - alpha B) |/( ulp max(|beta A|, |alpha B|) ) */
+
+/* where VL**H is the conjugate-transpose of VL. */
+
+/* (2) | |VL(i)| - 1 | / ulp and whether largest component real */
+
+/* VL(i) denotes the i-th column of VL. */
+
+/* (3) max over all left eigenvalue/-vector pairs (alpha/beta,r) of */
+
+/* | (beta A - alpha B) * VR | / ( ulp max(|beta A|, |alpha B|) ) */
+
+/* (4) | |VR(i)| - 1 | / ulp and whether largest component real */
+
+/* VR(i) denotes the i-th column of VR. */
+
+/* (5) W(full) = W(partial) */
+/* W(full) denotes the eigenvalues computed when both l and r */
+/* are also computed, and W(partial) denotes the eigenvalues */
+/* computed when only W, only W and r, or only W and l are */
+/* computed. */
+
+/* (6) VL(full) = VL(partial) */
+/* VL(full) denotes the left eigenvectors computed when both l */
+/* and r are computed, and VL(partial) denotes the result */
+/* when only l is computed. */
+
+/* (7) VR(full) = VR(partial) */
+/* VR(full) denotes the right eigenvectors computed when both l */
+/* and r are also computed, and VR(partial) denotes the result */
+/* when only l is computed. */
+
+
+/* Test Matrices */
+/* ---- -------- */
+
+/* The sizes of the test matrices are specified by an array */
+/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
+/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) ( 0, 0 ) (a pair of zero matrices) */
+
+/* (2) ( I, 0 ) (an identity and a zero matrix) */
+
+/* (3) ( 0, I ) (an identity and a zero matrix) */
+
+/* (4) ( I, I ) (a pair of identity matrices) */
+
+/* t t */
+/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
+
+/* t ( I 0 ) */
+/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
+/* ( 0 I ) ( 0 J ) */
+/* and I is a k x k identity and J a (k+1)x(k+1) */
+/* Jordan block; k=(N-1)/2 */
+
+/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
+/* matrix with those diagonal entries.) */
+/* (8) ( I, D ) */
+
+/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
+
+/* (10) ( small*D, big*I ) */
+
+/* (11) ( big*I, small*D ) */
+
+/* (12) ( small*I, big*D ) */
+
+/* (13) ( big*D, big*I ) */
+
+/* (14) ( small*D, small*I ) */
+
+/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
+/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
+/* t t */
+/* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices. */
+
+/* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices */
+/* with random O(1) entries above the diagonal */
+/* and diagonal entries diag(T1) = */
+/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
+/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
+
+/* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
+/* s = machine precision. */
+
+/* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
+
+/* N-5 */
+/* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+
+/* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+/* where r1,..., r(N-4) are random. */
+
+/* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular */
+/* matrices. */
+
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* ZDRGES does nothing. NSIZES >= 0. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. NN >= 0. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, ZDRGEV */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to ZDRGES to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error is */
+/* scaled to be O(1), so THRESH should be a reasonably small */
+/* multiple of 1, e.g., 10 or 100. In particular, it should */
+/* not depend on the precision (single vs. double) or the size */
+/* of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IERR not equal to 0.) */
+
+/* A (input/workspace) COMPLEX*16 array, dimension(LDA, max(NN)) */
+/* Used to hold the original A matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, S, and T. */
+/* It must be at least 1 and at least max( NN ). */
+
+/* B (input/workspace) COMPLEX*16 array, dimension(LDA, max(NN)) */
+/* Used to hold the original B matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* S (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* The Schur form matrix computed from A by ZGGEV. On exit, S */
+/* contains the Schur form matrix corresponding to the matrix */
+/* in A. */
+
+/* T (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from B by ZGGEV. */
+
+/* Q (workspace) COMPLEX*16 array, dimension (LDQ, max(NN)) */
+/* The (left) eigenvectors matrix computed by ZGGEV. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of Q and Z. It must */
+/* be at least 1 and at least max( NN ). */
+
+/* Z (workspace) COMPLEX*16 array, dimension( LDQ, max(NN) ) */
+/* The (right) orthogonal matrix computed by ZGGEV. */
+
+/* QE (workspace) COMPLEX*16 array, dimension( LDQ, max(NN) ) */
+/* QE holds the computed right or left eigenvectors. */
+
+/* LDQE (input) INTEGER */
+/* The leading dimension of QE. LDQE >= max(1,max(NN)). */
+
+/* ALPHA (workspace) COMPLEX*16 array, dimension (max(NN)) */
+/* BETA (workspace) COMPLEX*16 array, dimension (max(NN)) */
+/* The generalized eigenvalues of (A,B) computed by ZGGEV. */
+/* ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th */
+/* generalized eigenvalue of A and B. */
+
+/* ALPHA1 (workspace) COMPLEX*16 array, dimension (max(NN)) */
+/* BETA1 (workspace) COMPLEX*16 array, dimension (max(NN)) */
+/* Like ALPHAR, ALPHAI, BETA, these arrays contain the */
+/* eigenvalues of A and B, but those computed when ZGGEV only */
+/* computes a partial eigendecomposition, i.e. not the */
+/* eigenvalues and left and right eigenvectors. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. LWORK >= N*(N+1) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (8*N) */
+/* Real workspace. */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid overflow. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: A routine returned an error code. INFO is the */
+/* absolute value of the INFO value returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ t_dim1 = *lda;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ s_dim1 = *lda;
+ s_offset = 1 + s_dim1;
+ s -= s_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ z_dim1 = *ldq;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ qe_dim1 = *ldqe;
+ qe_offset = 1 + qe_dim1;
+ qe -= qe_offset;
+ --alpha;
+ --beta;
+ --alpha1;
+ --beta1;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.) {
+ *info = -6;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldq <= 1 || *ldq < nmax) {
+ *info = -14;
+ } else if (*ldqe <= 1 || *ldqe < nmax) {
+ *info = -17;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV. */
+
+ minwrk = 1;
+ if (*info == 0 && *lwork >= 1) {
+ minwrk = nmax * (nmax + 1);
+/* Computing MAX */
+ i__1 = 1, i__2 = ilaenv_(&c__1, "ZGEQRF", " ", &nmax, &nmax, &c_n1, &
+ c_n1), i__1 = max(i__1,i__2), i__2 =
+ ilaenv_(&c__1, "ZUNMQR", "LC", &nmax, &nmax, &nmax, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
+ c__1, "ZUNGQR", " ", &nmax, &nmax, &nmax, &c_n1);
+ nb = max(i__1,i__2);
+/* Computing MAX */
+ i__1 = nmax << 1, i__2 = nmax * (nb + 1), i__1 = max(i__1,i__2), i__2
+ = nmax * (nmax + 1);
+ maxwrk = max(i__1,i__2);
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+ }
+
+ if (*lwork < minwrk) {
+ *info = -23;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZDRGEV", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+ ulp = dlamch_("Precision");
+ safmin = dlamch_("Safe minimum");
+ safmin /= ulp;
+ safmax = 1. / safmin;
+ dlabad_(&safmin, &safmax);
+ ulpinv = 1. / ulp;
+
+/* The values RMAGN(2:3) depend on N, see below. */
+
+ rmagn[0] = 0.;
+ rmagn[1] = 1.;
+
+/* Loop over sizes, types */
+
+ ntestt = 0;
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ n1 = max(1,n);
+ rmagn[2] = safmax * ulp / (doublereal) n1;
+ rmagn[3] = safmin * ulpinv * n1;
+
+ if (*nsizes != 1) {
+ mtypes = min(26,*ntypes);
+ } else {
+ mtypes = min(27,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L210;
+ }
+ ++nmats;
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Generate test matrices A and B */
+
+/* Description of control parameters: */
+
+/* KZLASS: =1 means w/o rotation, =2 means w/ rotation, */
+/* =3 means random. */
+/* KATYPE: the "type" to be passed to ZLATM4 for computing A. */
+/* KAZERO: the pattern of zeros on the diagonal for A: */
+/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
+/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
+/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
+/* non-zero entries.) */
+/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
+/* =2: large, =3: small. */
+/* LASIGN: .TRUE. if the diagonal elements of A are to be */
+/* multiplied by a random magnitude 1 number. */
+/* KBTYPE, KBZERO, KBMAGN, LBSIGN: the same, but for B. */
+/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
+/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
+/* RMAGN: used to implement KAMAGN and KBMAGN. */
+
+ if (mtypes > 26) {
+ goto L100;
+ }
+ ierr = 0;
+ if (kclass[jtype - 1] < 3) {
+
+/* Generate A (w/o rotation) */
+
+ if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ zlaset_("Full", &n, &n, &c_b1, &c_b1, &a[a_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ zlatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
+ &kz2[kazero[jtype - 1] - 1], &lasign[jtype - 1], &
+ rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
+ 1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
+ a_offset], lda);
+ iadd = kadd[kazero[jtype - 1] - 1];
+ if (iadd > 0 && iadd <= n) {
+ i__3 = iadd + iadd * a_dim1;
+ i__4 = kamagn[jtype - 1];
+ a[i__3].r = rmagn[i__4], a[i__3].i = 0.;
+ }
+
+/* Generate B (w/o rotation) */
+
+ if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ zlaset_("Full", &n, &n, &c_b1, &c_b1, &b[b_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ zlatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
+ &kz2[kbzero[jtype - 1] - 1], &lbsign[jtype - 1], &
+ rmagn[kbmagn[jtype - 1]], &c_b28, &rmagn[ktrian[jtype
+ - 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
+ b_offset], lda);
+ iadd = kadd[kbzero[jtype - 1] - 1];
+ if (iadd != 0 && iadd <= n) {
+ i__3 = iadd + iadd * b_dim1;
+ i__4 = kbmagn[jtype - 1];
+ b[i__3].r = rmagn[i__4], b[i__3].i = 0.;
+ }
+
+ if (kclass[jtype - 1] == 2 && n > 0) {
+
+/* Include rotations */
+
+/* Generate Q, Z as Householder transformations times */
+/* a diagonal matrix. */
+
+ i__3 = n - 1;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = jc; jr <= i__4; ++jr) {
+ i__5 = jr + jc * q_dim1;
+ zlarnd_(&z__1, &c__3, &iseed[1]);
+ q[i__5].r = z__1.r, q[i__5].i = z__1.i;
+ i__5 = jr + jc * z_dim1;
+ zlarnd_(&z__1, &c__3, &iseed[1]);
+ z__[i__5].r = z__1.r, z__[i__5].i = z__1.i;
+/* L30: */
+ }
+ i__4 = n + 1 - jc;
+ zlarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc *
+ q_dim1], &c__1, &work[jc]);
+ i__4 = (n << 1) + jc;
+ i__5 = jc + jc * q_dim1;
+ d__2 = q[i__5].r;
+ d__1 = d_sign(&c_b28, &d__2);
+ work[i__4].r = d__1, work[i__4].i = 0.;
+ i__4 = jc + jc * q_dim1;
+ q[i__4].r = 1., q[i__4].i = 0.;
+ i__4 = n + 1 - jc;
+ zlarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 +
+ jc * z_dim1], &c__1, &work[n + jc]);
+ i__4 = n * 3 + jc;
+ i__5 = jc + jc * z_dim1;
+ d__2 = z__[i__5].r;
+ d__1 = d_sign(&c_b28, &d__2);
+ work[i__4].r = d__1, work[i__4].i = 0.;
+ i__4 = jc + jc * z_dim1;
+ z__[i__4].r = 1., z__[i__4].i = 0.;
+/* L40: */
+ }
+ zlarnd_(&z__1, &c__3, &iseed[1]);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__3 = n + n * q_dim1;
+ q[i__3].r = 1., q[i__3].i = 0.;
+ i__3 = n;
+ work[i__3].r = 0., work[i__3].i = 0.;
+ i__3 = n * 3;
+ d__1 = z_abs(&ctemp);
+ z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ zlarnd_(&z__1, &c__3, &iseed[1]);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__3 = n + n * z_dim1;
+ z__[i__3].r = 1., z__[i__3].i = 0.;
+ i__3 = n << 1;
+ work[i__3].r = 0., work[i__3].i = 0.;
+ i__3 = n << 2;
+ d__1 = z_abs(&ctemp);
+ z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+
+/* Apply the diagonal matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ i__5 = jr + jc * a_dim1;
+ i__6 = (n << 1) + jr;
+ d_cnjg(&z__3, &work[n * 3 + jc]);
+ z__2.r = work[i__6].r * z__3.r - work[i__6].i *
+ z__3.i, z__2.i = work[i__6].r * z__3.i +
+ work[i__6].i * z__3.r;
+ i__7 = jr + jc * a_dim1;
+ z__1.r = z__2.r * a[i__7].r - z__2.i * a[i__7].i,
+ z__1.i = z__2.r * a[i__7].i + z__2.i * a[
+ i__7].r;
+ a[i__5].r = z__1.r, a[i__5].i = z__1.i;
+ i__5 = jr + jc * b_dim1;
+ i__6 = (n << 1) + jr;
+ d_cnjg(&z__3, &work[n * 3 + jc]);
+ z__2.r = work[i__6].r * z__3.r - work[i__6].i *
+ z__3.i, z__2.i = work[i__6].r * z__3.i +
+ work[i__6].i * z__3.r;
+ i__7 = jr + jc * b_dim1;
+ z__1.r = z__2.r * b[i__7].r - z__2.i * b[i__7].i,
+ z__1.i = z__2.r * b[i__7].i + z__2.i * b[
+ i__7].r;
+ b[i__5].r = z__1.r, b[i__5].i = z__1.i;
+/* L50: */
+ }
+/* L60: */
+ }
+ i__3 = n - 1;
+ zunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &a[a_offset], lda, &work[(n << 1) + 1], &ierr);
+ if (ierr != 0) {
+ goto L90;
+ }
+ i__3 = n - 1;
+ zunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &a[a_offset], lda, &work[(n << 1) +
+ 1], &ierr);
+ if (ierr != 0) {
+ goto L90;
+ }
+ i__3 = n - 1;
+ zunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &b[b_offset], lda, &work[(n << 1) + 1], &ierr);
+ if (ierr != 0) {
+ goto L90;
+ }
+ i__3 = n - 1;
+ zunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &b[b_offset], lda, &work[(n << 1) +
+ 1], &ierr);
+ if (ierr != 0) {
+ goto L90;
+ }
+ }
+ } else {
+
+/* Random matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ i__5 = jr + jc * a_dim1;
+ i__6 = kamagn[jtype - 1];
+ zlarnd_(&z__2, &c__4, &iseed[1]);
+ z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] *
+ z__2.i;
+ a[i__5].r = z__1.r, a[i__5].i = z__1.i;
+ i__5 = jr + jc * b_dim1;
+ i__6 = kbmagn[jtype - 1];
+ zlarnd_(&z__2, &c__4, &iseed[1]);
+ z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] *
+ z__2.i;
+ b[i__5].r = z__1.r, b[i__5].i = z__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+
+L90:
+
+ if (ierr != 0) {
+ io___40.ciunit = *nounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(ierr);
+ return 0;
+ }
+
+L100:
+
+ for (i__ = 1; i__ <= 7; ++i__) {
+ result[i__] = -1.;
+/* L110: */
+ }
+
+/* Call ZGGEV to compute eigenvalues and eigenvectors. */
+
+ zlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ zlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ zggev_("V", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &alpha[
+ 1], &beta[1], &q[q_offset], ldq, &z__[z_offset], ldq, &
+ work[1], lwork, &rwork[1], &ierr);
+ if (ierr != 0 && ierr != n + 1) {
+ result[1] = ulpinv;
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "ZGGEV1", (ftnlen)6);
+ do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(ierr);
+ goto L190;
+ }
+
+/* Do the tests (1) and (2) */
+
+ zget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &q[
+ q_offset], ldq, &alpha[1], &beta[1], &work[1], &rwork[1],
+ &result[1]);
+ if (result[2] > *thresh) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "ZGGEV1", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Do the tests (3) and (4) */
+
+ zget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &z__[
+ z_offset], ldq, &alpha[1], &beta[1], &work[1], &rwork[1],
+ &result[3]);
+ if (result[4] > *thresh) {
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "ZGGEV1", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[4], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Do test (5) */
+
+ zlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ zlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ zggev_("N", "N", &n, &s[s_offset], lda, &t[t_offset], lda, &
+ alpha1[1], &beta1[1], &q[q_offset], ldq, &z__[z_offset],
+ ldq, &work[1], lwork, &rwork[1], &ierr);
+ if (ierr != 0 && ierr != n + 1) {
+ result[1] = ulpinv;
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "ZGGEV2", (ftnlen)6);
+ do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(ierr);
+ goto L190;
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ i__5 = j;
+ i__6 = j;
+ i__7 = j;
+ if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i !=
+ alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r ||
+ beta[i__6].i != beta1[i__7].i)) {
+ result[5] = ulpinv;
+ }
+/* L120: */
+ }
+
+/* Do test (6): Compute eigenvalues and left eigenvectors, */
+/* and test them */
+
+ zlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ zlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ zggev_("V", "N", &n, &s[s_offset], lda, &t[t_offset], lda, &
+ alpha1[1], &beta1[1], &qe[qe_offset], ldqe, &z__[z_offset]
+, ldq, &work[1], lwork, &rwork[1], &ierr);
+ if (ierr != 0 && ierr != n + 1) {
+ result[1] = ulpinv;
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, "ZGGEV3", (ftnlen)6);
+ do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(ierr);
+ goto L190;
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ i__5 = j;
+ i__6 = j;
+ i__7 = j;
+ if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i !=
+ alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r ||
+ beta[i__6].i != beta1[i__7].i)) {
+ result[6] = ulpinv;
+ }
+/* L130: */
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (jc = 1; jc <= i__4; ++jc) {
+ i__5 = j + jc * q_dim1;
+ i__6 = j + jc * qe_dim1;
+ if (q[i__5].r != qe[i__6].r || q[i__5].i != qe[i__6].i) {
+ result[6] = ulpinv;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+/* Do test (7): Compute eigenvalues and right eigenvectors, */
+/* and test them */
+
+ zlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ zlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ zggev_("N", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
+ alpha1[1], &beta1[1], &q[q_offset], ldq, &qe[qe_offset],
+ ldqe, &work[1], lwork, &rwork[1], &ierr);
+ if (ierr != 0 && ierr != n + 1) {
+ result[1] = ulpinv;
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ do_fio(&c__1, "ZGGEV4", (ftnlen)6);
+ do_fio(&c__1, (char *)&ierr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(ierr);
+ goto L190;
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ i__5 = j;
+ i__6 = j;
+ i__7 = j;
+ if (alpha[i__4].r != alpha1[i__5].r || alpha[i__4].i !=
+ alpha1[i__5].i || (beta[i__6].r != beta1[i__7].r ||
+ beta[i__6].i != beta1[i__7].i)) {
+ result[7] = ulpinv;
+ }
+/* L160: */
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (jc = 1; jc <= i__4; ++jc) {
+ i__5 = j + jc * z_dim1;
+ i__6 = j + jc * qe_dim1;
+ if (z__[i__5].r != qe[i__6].r || z__[i__5].i != qe[i__6]
+ .i) {
+ result[7] = ulpinv;
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L190:
+
+ ntestt += 7;
+
+/* Print out tests which fail. */
+
+ for (jr = 1; jr <= 7; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___48.ciunit = *nounit;
+ s_wsfe(&io___48);
+ do_fio(&c__1, "ZGV", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ e_wsfe();
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ e_wsfe();
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "Orthogonal", (ftnlen)10);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[jr] < 1e4) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ } else {
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+ }
+/* L200: */
+ }
+
+L210:
+ ;
+ }
+/* L220: */
+ }
+
+/* Summary */
+
+ alasvm_("ZGV", nounit, &nerrs, &ntestt, &c__0);
+
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+
+ return 0;
+
+
+
+
+
+
+
+/* End of ZDRGEV */
+
+} /* zdrgev_ */
diff --git a/TESTING/EIG/zdrgsx.c b/TESTING/EIG/zdrgsx.c
new file mode 100644
index 0000000..2d069bd
--- /dev/null
+++ b/TESTING/EIG/zdrgsx.c
@@ -0,0 +1,1218 @@
+/* zdrgsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer m, n, mplusn, k;
+ logical fs;
+} mn_;
+
+#define mn_1 mn_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__7 = 7;
+static integer c__5 = 5;
+
+/* Subroutine */ int zdrgsx_(integer *nsize, integer *ncmax, doublereal *
+ thresh, integer *nin, integer *nout, doublecomplex *a, integer *lda,
+ doublecomplex *b, doublecomplex *ai, doublecomplex *bi, doublecomplex
+ *z__, doublecomplex *q, doublecomplex *alpha, doublecomplex *beta,
+ doublecomplex *c__, integer *ldc, doublereal *s, doublecomplex *work,
+ integer *lwork, doublereal *rwork, integer *iwork, integer *liwork,
+ logical *bwork, integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ZDRGSX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002)\002)";
+ static char fmt_9997[] = "(\002 ZDRGSX: S not in Schur form at eigenvalu"
+ "e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002"
+ ")\002)";
+ static char fmt_9996[] = "(/1x,a3,\002 -- Complex Expert Generalized Sch"
+ "ur form\002,\002 problem driver\002)";
+ static char fmt_9994[] = "(\002 Matrix types: \002,/\002 1: A is a blo"
+ "ck diagonal matrix of Jordan blocks \002,\002and B is the identi"
+ "ty \002,/\002 matrix, \002,/\002 2: A and B are upper tri"
+ "angular matrices, \002,/\002 3: A and B are as type 2, but eac"
+ "h second diagonal \002,\002block in A_11 and \002,/\002 eac"
+ "h third diaongal block in A_22 are 2x2 blocks,\002,/\002 4: A "
+ "and B are block diagonal matrices, \002,/\002 5: (A,B) has pot"
+ "entially close or common \002,\002eigenvalues.\002,/)";
+ static char fmt_9993[] = "(/\002 Tests performed: (S is Schur, T is tri"
+ "angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002 a is al"
+ "pha, b is beta, and \002,a,\002 means \002,a,\002.)\002,/\002 1"
+ " = | A - Q S Z\002,a,\002 | / ( |A| n ulp ) 2 = | B - Q T "
+ "Z\002,a,\002 | / ( |B| n ulp )\002,/\002 3 = | I - QQ\002,a,"
+ "\002 | / ( n ulp ) 4 = | I - ZZ\002,a,\002 | / ( n u"
+ "lp )\002,/\002 5 = 1/ULP if A is not in \002,\002Schur form "
+ "S\002,/\002 6 = difference between (alpha,beta)\002,\002 and di"
+ "agonals of (S,T)\002,/\002 7 = 1/ULP if SDIM is not the correc"
+ "t number of \002,\002selected eigenvalues\002,/\002 8 = 1/ULP "
+ "if DIFEST/DIFTRU > 10*THRESH or \002,\002DIFTRU/DIFEST > 10*THRE"
+ "SH\002,/\002 9 = 1/ULP if DIFEST <> 0 or DIFTRU > ULP*norm(A,B"
+ ") \002,\002when reordering fails\002,/\002 10 = 1/ULP if PLEST/"
+ "PLTRU > THRESH or \002,\002PLTRU/PLEST > THRESH\002,/\002 ( T"
+ "est 10 is only for input examples )\002,/)";
+ static char fmt_9992[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
+ ",\002, a=\002,d10.4,\002, order(A_11)=\002,i2,\002, result \002,"
+ "i2,\002 is \002,0p,f8.2)";
+ static char fmt_9991[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
+ ",\002, a=\002,d10.4,\002, order(A_11)=\002,i2,\002, result \002,"
+ "i2,\002 is \002,0p,d10.4)";
+ static char fmt_9998[] = "(\002 ZDRGSX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, Input Example #\002,i2,\002"
+ ")\002)";
+ static char fmt_9995[] = "(\002Input Example\002)";
+ static char fmt_9990[] = "(\002 Input example #\002,i2,\002, matrix orde"
+ "r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,0p,f8.2)";
+ static char fmt_9989[] = "(\002 Input example #\002,i2,\002, matrix orde"
+ "r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,1p,d10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, ai_dim1, ai_offset, b_dim1, b_offset, bi_dim1,
+ bi_offset, c_dim1, c_offset, q_dim1, q_offset, z_dim1, z_offset,
+ i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10,
+ i__11;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
+ d__11, d__12, d__13, d__14, d__15, d__16;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double d_imag(doublecomplex *);
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+
+ /* Local variables */
+ integer i__, j, mm;
+ doublereal pl[2];
+ integer mn2, qba, qbb;
+ doublereal ulp, temp1, temp2, abnrm;
+ integer ifunc, linfo;
+ char sense[1];
+ extern /* Subroutine */ int zget51_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *
+, doublecomplex *, integer *, doublecomplex *, doublereal *,
+ doublereal *);
+ integer nerrs, ntest;
+ doublereal pltru;
+ extern /* Subroutine */ int zlakf2_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
+ doublereal thrsh2;
+ logical ilabad;
+ extern /* Subroutine */ int zlatm5_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ integer bdspac;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal difest[2];
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ doublereal bignum;
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal weight, diftru;
+ extern /* Subroutine */ int zgesvd_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+ integer minwrk, maxwrk;
+ extern /* Subroutine */ int zggesx_(char *, char *, char *, L_fp, char *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublereal *, integer *, integer *,
+ logical *, integer *);
+ doublereal smlnum, ulpinv;
+ integer nptknt;
+ doublereal result[10];
+ integer ntestt, prtype;
+ extern logical zlctsx_();
+
+ /* Fortran I/O blocks */
+ static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___39 = { 0, 0, 1, 0, 0 };
+ static cilist io___40 = { 0, 0, 1, 0, 0 };
+ static cilist io___41 = { 0, 0, 0, 0, 0 };
+ static cilist io___42 = { 0, 0, 0, 0, 0 };
+ static cilist io___43 = { 0, 0, 0, 0, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9989, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRGSX checks the nonsymmetric generalized eigenvalue (Schur form) */
+/* problem expert driver ZGGESX. */
+
+/* ZGGES factors A and B as Q*S*Z' and Q*T*Z' , where ' means conjugate */
+/* transpose, S and T are upper triangular (i.e., in generalized Schur */
+/* form), and Q and Z are unitary. It also computes the generalized */
+/* eigenvalues (alpha(j),beta(j)), j=1,...,n. Thus, */
+/* w(j) = alpha(j)/beta(j) is a root of the characteristic equation */
+
+/* det( A - w(j) B ) = 0 */
+
+/* Optionally it also reorders the eigenvalues so that a selected */
+/* cluster of eigenvalues appears in the leading diagonal block of the */
+/* Schur forms; computes a reciprocal condition number for the average */
+/* of the selected eigenvalues; and computes a reciprocal condition */
+/* number for the right and left deflating subspaces corresponding to */
+/* the selected eigenvalues. */
+
+/* When ZDRGSX is called with NSIZE > 0, five (5) types of built-in */
+/* matrix pairs are used to test the routine ZGGESX. */
+
+/* When ZDRGSX is called with NSIZE = 0, it reads in test matrix data */
+/* to test ZGGESX. */
+/* (need more details on what kind of read-in data are needed). */
+
+/* For each matrix pair, the following tests will be performed and */
+/* compared with the threshhold THRESH except for the tests (7) and (9): */
+
+/* (1) | A - Q S Z' | / ( |A| n ulp ) */
+
+/* (2) | B - Q T Z' | / ( |B| n ulp ) */
+
+/* (3) | I - QQ' | / ( n ulp ) */
+
+/* (4) | I - ZZ' | / ( n ulp ) */
+
+/* (5) if A is in Schur form (i.e. triangular form) */
+
+/* (6) maximum over j of D(j) where: */
+
+/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
+/* D(j) = ------------------------ + ----------------------- */
+/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
+
+/* (7) if sorting worked and SDIM is the number of eigenvalues */
+/* which were selected. */
+
+/* (8) the estimated value DIF does not differ from the true values of */
+/* Difu and Difl more than a factor 10*THRESH. If the estimate DIF */
+/* equals zero the corresponding true values of Difu and Difl */
+/* should be less than EPS*norm(A, B). If the true value of Difu */
+/* and Difl equal zero, the estimate DIF should be less than */
+/* EPS*norm(A, B). */
+
+/* (9) If INFO = N+3 is returned by ZGGESX, the reordering "failed" */
+/* and we check that DIF = PL = PR = 0 and that the true value of */
+/* Difu and Difl is < EPS*norm(A, B). We count the events when */
+/* INFO=N+3. */
+
+/* For read-in test matrices, the same tests are run except that the */
+/* exact value for DIF (and PL) is input data. Additionally, there is */
+/* one more test run for read-in test matrices: */
+
+/* (10) the estimated value PL does not differ from the true value of */
+/* PLTRU more than a factor THRESH. If the estimate PL equals */
+/* zero the corresponding true value of PLTRU should be less than */
+/* EPS*norm(A, B). If the true value of PLTRU equal zero, the */
+/* estimate PL should be less than EPS*norm(A, B). */
+
+/* Note that for the built-in tests, a total of 10*NSIZE*(NSIZE-1) */
+/* matrix pairs are generated and tested. NSIZE should be kept small. */
+
+/* SVD (routine ZGESVD) is used for computing the true value of DIF_u */
+/* and DIF_l when testing the built-in test problems. */
+
+/* Built-in Test Matrices */
+/* ====================== */
+
+/* All built-in test matrices are the 2 by 2 block of triangular */
+/* matrices */
+
+/* A = [ A11 A12 ] and B = [ B11 B12 ] */
+/* [ A22 ] [ B22 ] */
+
+/* where for different type of A11 and A22 are given as the following. */
+/* A12 and B12 are chosen so that the generalized Sylvester equation */
+
+/* A11*R - L*A22 = -A12 */
+/* B11*R - L*B22 = -B12 */
+
+/* have prescribed solution R and L. */
+
+/* Type 1: A11 = J_m(1,-1) and A_22 = J_k(1-a,1). */
+/* B11 = I_m, B22 = I_k */
+/* where J_k(a,b) is the k-by-k Jordan block with ``a'' on */
+/* diagonal and ``b'' on superdiagonal. */
+
+/* Type 2: A11 = (a_ij) = ( 2(.5-sin(i)) ) and */
+/* B11 = (b_ij) = ( 2(.5-sin(ij)) ) for i=1,...,m, j=i,...,m */
+/* A22 = (a_ij) = ( 2(.5-sin(i+j)) ) and */
+/* B22 = (b_ij) = ( 2(.5-sin(ij)) ) for i=m+1,...,k, j=i,...,k */
+
+/* Type 3: A11, A22 and B11, B22 are chosen as for Type 2, but each */
+/* second diagonal block in A_11 and each third diagonal block */
+/* in A_22 are made as 2 by 2 blocks. */
+
+/* Type 4: A11 = ( 20(.5 - sin(ij)) ) and B22 = ( 2(.5 - sin(i+j)) ) */
+/* for i=1,...,m, j=1,...,m and */
+/* A22 = ( 20(.5 - sin(i+j)) ) and B22 = ( 2(.5 - sin(ij)) ) */
+/* for i=m+1,...,k, j=m+1,...,k */
+
+/* Type 5: (A,B) and have potentially close or common eigenvalues and */
+/* very large departure from block diagonality A_11 is chosen */
+/* as the m x m leading submatrix of A_1: */
+/* | 1 b | */
+/* | -b 1 | */
+/* | 1+d b | */
+/* | -b 1+d | */
+/* A_1 = | d 1 | */
+/* | -1 d | */
+/* | -d 1 | */
+/* | -1 -d | */
+/* | 1 | */
+/* and A_22 is chosen as the k x k leading submatrix of A_2: */
+/* | -1 b | */
+/* | -b -1 | */
+/* | 1-d b | */
+/* | -b 1-d | */
+/* A_2 = | d 1+b | */
+/* | -1-b d | */
+/* | -d 1+b | */
+/* | -1+b -d | */
+/* | 1-d | */
+/* and matrix B are chosen as identity matrices (see DLATM5). */
+
+
+/* Arguments */
+/* ========= */
+
+/* NSIZE (input) INTEGER */
+/* The maximum size of the matrices to use. NSIZE >= 0. */
+/* If NSIZE = 0, no built-in tests matrices are used, but */
+/* read-in test matrices are used to test DGGESX. */
+
+/* NCMAX (input) INTEGER */
+/* Maximum allowable NMAX for generating Kroneker matrix */
+/* in call to ZLAKF2 */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. THRESH >= 0. */
+
+/* NIN (input) INTEGER */
+/* The FORTRAN unit number for reading in the data file of */
+/* problems to solve. */
+
+/* NOUT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* A (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
+/* Used to store the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, AI, BI, Z and Q, */
+/* LDA >= max( 1, NSIZE ). For the read-in test, */
+/* LDA >= max( 1, N ), N is the size of the test matrices. */
+
+/* B (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
+/* Used to store the matrix whose eigenvalues are to be */
+/* computed. On exit, B contains the last matrix actually used. */
+
+/* AI (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
+/* Copy of A, modified by ZGGESX. */
+
+/* BI (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
+/* Copy of B, modified by ZGGESX. */
+
+/* Z (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
+/* Z holds the left Schur vectors computed by ZGGESX. */
+
+/* Q (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
+/* Q holds the right Schur vectors computed by ZGGESX. */
+
+/* ALPHA (workspace) COMPLEX*16 array, dimension (NSIZE) */
+/* BETA (workspace) COMPLEX*16 array, dimension (NSIZE) */
+/* On exit, ALPHA/BETA are the eigenvalues. */
+
+/* C (workspace) COMPLEX*16 array, dimension (LDC, LDC) */
+/* Store the matrix generated by subroutine ZLAKF2, this is the */
+/* matrix formed by Kronecker products used for estimating */
+/* DIF. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of C. LDC >= max(1, LDA*LDA/2 ). */
+
+/* S (workspace) DOUBLE PRECISION array, dimension (LDC) */
+/* Singular values of C */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. LWORK >= 3*NSIZE*NSIZE/2 */
+
+/* RWORK (workspace) DOUBLE PRECISION array, */
+/* dimension (5*NSIZE*NSIZE/2 - 4) */
+
+/* IWORK (workspace) INTEGER array, dimension (LIWORK) */
+
+/* LIWORK (input) INTEGER */
+/* The dimension of the array IWORK. LIWORK >= NSIZE + 2. */
+
+/* BWORK (workspace) LOGICAL array, dimension (NSIZE) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: A routine returned an error code. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ /* Parameter adjustments */
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ z_dim1 = *lda;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ bi_dim1 = *lda;
+ bi_offset = 1 + bi_dim1;
+ bi -= bi_offset;
+ ai_dim1 = *lda;
+ ai_offset = 1 + ai_dim1;
+ ai -= ai_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --alpha;
+ --beta;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --s;
+ --work;
+ --rwork;
+ --iwork;
+ --bwork;
+
+ /* Function Body */
+ *info = 0;
+ if (*nsize < 0) {
+ *info = -1;
+ } else if (*thresh < 0.) {
+ *info = -2;
+ } else if (*nin <= 0) {
+ *info = -3;
+ } else if (*nout <= 0) {
+ *info = -4;
+ } else if (*lda < 1 || *lda < *nsize) {
+ *info = -6;
+ } else if (*ldc < 1 || *ldc < *nsize * *nsize / 2) {
+ *info = -15;
+ } else if (*liwork < *nsize + 2) {
+ *info = -21;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ minwrk = 1;
+ if (*info == 0 && *lwork >= 1) {
+ minwrk = *nsize * 3 * *nsize / 2;
+
+/* workspace for cggesx */
+
+ maxwrk = *nsize * (ilaenv_(&c__1, "ZGEQRF", " ", nsize, &c__1, nsize,
+ &c__0) + 1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = *nsize * (ilaenv_(&c__1, "ZUNGQR", " ", nsize, &
+ c__1, nsize, &c_n1) + 1);
+ maxwrk = max(i__1,i__2);
+
+/* workspace for zgesvd */
+
+ bdspac = *nsize * 3 * *nsize / 2;
+/* Computing MAX */
+ i__3 = *nsize * *nsize / 2;
+ i__4 = *nsize * *nsize / 2;
+ i__1 = maxwrk, i__2 = *nsize * *nsize * (ilaenv_(&c__1, "ZGEBRD",
+ " ", &i__3, &i__4, &c_n1, &c_n1) + 1);
+ maxwrk = max(i__1,i__2);
+ maxwrk = max(maxwrk,bdspac);
+
+ maxwrk = max(maxwrk,minwrk);
+
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+ }
+
+ if (*lwork < minwrk) {
+ *info = -18;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZDRGSX", &i__1);
+ return 0;
+ }
+
+/* Important constants */
+
+ ulp = dlamch_("P");
+ ulpinv = 1. / ulp;
+ smlnum = dlamch_("S") / ulp;
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ thrsh2 = *thresh * 10.;
+ ntestt = 0;
+ nerrs = 0;
+
+/* Go to the tests for read-in matrix pairs */
+
+ ifunc = 0;
+ if (*nsize == 0) {
+ goto L70;
+ }
+
+/* Test the built-in matrix pairs. */
+/* Loop over different functions (IFUNC) of ZGGESX, types (PRTYPE) */
+/* of test matrices, different size (M+N) */
+
+ prtype = 0;
+ qba = 3;
+ qbb = 4;
+ weight = sqrt(ulp);
+
+ for (ifunc = 0; ifunc <= 3; ++ifunc) {
+ for (prtype = 1; prtype <= 5; ++prtype) {
+ i__1 = *nsize - 1;
+ for (mn_1.m = 1; mn_1.m <= i__1; ++mn_1.m) {
+ i__2 = *nsize - mn_1.m;
+ for (mn_1.n = 1; mn_1.n <= i__2; ++mn_1.n) {
+
+ weight = 1. / weight;
+ mn_1.mplusn = mn_1.m + mn_1.n;
+
+/* Generate test matrices */
+
+ mn_1.fs = TRUE_;
+ mn_1.k = 0;
+
+ zlaset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b1, &c_b1,
+ &ai[ai_offset], lda);
+ zlaset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b1, &c_b1,
+ &bi[bi_offset], lda);
+
+ zlatm5_(&prtype, &mn_1.m, &mn_1.n, &ai[ai_offset], lda, &
+ ai[mn_1.m + 1 + (mn_1.m + 1) * ai_dim1], lda, &ai[
+ (mn_1.m + 1) * ai_dim1 + 1], lda, &bi[bi_offset],
+ lda, &bi[mn_1.m + 1 + (mn_1.m + 1) * bi_dim1],
+ lda, &bi[(mn_1.m + 1) * bi_dim1 + 1], lda, &q[
+ q_offset], lda, &z__[z_offset], lda, &weight, &
+ qba, &qbb);
+
+/* Compute the Schur factorization and swapping the */
+/* m-by-m (1,1)-blocks with n-by-n (2,2)-blocks. */
+/* Swapping is accomplished via the function ZLCTSX */
+/* which is supplied below. */
+
+ if (ifunc == 0) {
+ *(unsigned char *)sense = 'N';
+ } else if (ifunc == 1) {
+ *(unsigned char *)sense = 'E';
+ } else if (ifunc == 2) {
+ *(unsigned char *)sense = 'V';
+ } else if (ifunc == 3) {
+ *(unsigned char *)sense = 'B';
+ }
+
+ zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
+, lda, &a[a_offset], lda);
+ zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
+, lda, &b[b_offset], lda);
+
+ zggesx_("V", "V", "S", (L_fp)zlctsx_, sense, &mn_1.mplusn,
+ &ai[ai_offset], lda, &bi[bi_offset], lda, &mm, &
+ alpha[1], &beta[1], &q[q_offset], lda, &z__[
+ z_offset], lda, pl, difest, &work[1], lwork, &
+ rwork[1], &iwork[1], liwork, &bwork[1], &linfo);
+
+ if (linfo != 0 && linfo != mn_1.mplusn + 2) {
+ result[0] = ulpinv;
+ io___22.ciunit = *nout;
+ s_wsfe(&io___22);
+ do_fio(&c__1, "ZGGESX", (ftnlen)6);
+ do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(integer)
+ );
+ e_wsfe();
+ *info = linfo;
+ goto L30;
+ }
+
+/* Compute the norm(A, B) */
+
+ zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
+, lda, &work[1], &mn_1.mplusn);
+ zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
+, lda, &work[mn_1.mplusn * mn_1.mplusn + 1], &
+ mn_1.mplusn);
+ i__3 = mn_1.mplusn << 1;
+ abnrm = zlange_("Fro", &mn_1.mplusn, &i__3, &work[1], &
+ mn_1.mplusn, &rwork[1]);
+
+/* Do tests (1) to (4) */
+
+ result[1] = 0.;
+ zget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[
+ ai_offset], lda, &q[q_offset], lda, &z__[z_offset]
+, lda, &work[1], &rwork[1], result);
+ zget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[
+ bi_offset], lda, &q[q_offset], lda, &z__[z_offset]
+, lda, &work[1], &rwork[1], &result[1]);
+ zget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
+ bi_offset], lda, &q[q_offset], lda, &q[q_offset],
+ lda, &work[1], &rwork[1], &result[2]);
+ zget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
+ bi_offset], lda, &z__[z_offset], lda, &z__[
+ z_offset], lda, &work[1], &rwork[1], &result[3]);
+ ntest = 4;
+
+/* Do tests (5) and (6): check Schur form of A and */
+/* compare eigenvalues with diagonals. */
+
+ temp1 = 0.;
+ result[4] = 0.;
+ result[5] = 0.;
+
+ i__3 = mn_1.mplusn;
+ for (j = 1; j <= i__3; ++j) {
+ ilabad = FALSE_;
+ i__4 = j;
+ i__5 = j + j * ai_dim1;
+ z__2.r = alpha[i__4].r - ai[i__5].r, z__2.i = alpha[
+ i__4].i - ai[i__5].i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ i__6 = j;
+ i__7 = j + j * bi_dim1;
+ z__4.r = beta[i__6].r - bi[i__7].r, z__4.i = beta[
+ i__6].i - bi[i__7].i;
+ z__3.r = z__4.r, z__3.i = z__4.i;
+/* Computing MAX */
+ i__8 = j;
+ i__9 = j + j * ai_dim1;
+ d__13 = smlnum, d__14 = (d__1 = alpha[i__8].r, abs(
+ d__1)) + (d__2 = d_imag(&alpha[j]), abs(d__2))
+ , d__13 = max(d__13,d__14), d__14 = (d__3 =
+ ai[i__9].r, abs(d__3)) + (d__4 = d_imag(&ai[j
+ + j * ai_dim1]), abs(d__4));
+/* Computing MAX */
+ i__10 = j;
+ i__11 = j + j * bi_dim1;
+ d__15 = smlnum, d__16 = (d__5 = beta[i__10].r, abs(
+ d__5)) + (d__6 = d_imag(&beta[j]), abs(d__6)),
+ d__15 = max(d__15,d__16), d__16 = (d__7 = bi[
+ i__11].r, abs(d__7)) + (d__8 = d_imag(&bi[j +
+ j * bi_dim1]), abs(d__8));
+ temp2 = (((d__9 = z__1.r, abs(d__9)) + (d__10 =
+ d_imag(&z__1), abs(d__10))) / max(d__13,d__14)
+ + ((d__11 = z__3.r, abs(d__11)) + (d__12 =
+ d_imag(&z__3), abs(d__12))) / max(d__15,d__16)
+ ) / ulp;
+ if (j < mn_1.mplusn) {
+ i__4 = j + 1 + j * ai_dim1;
+ if (ai[i__4].r != 0. || ai[i__4].i != 0.) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ }
+ if (j > 1) {
+ i__4 = j + (j - 1) * ai_dim1;
+ if (ai[i__4].r != 0. || ai[i__4].i != 0.) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ }
+ temp1 = max(temp1,temp2);
+ if (ilabad) {
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+/* L10: */
+ }
+ result[5] = temp1;
+ ntest += 2;
+
+/* Test (7) (if sorting worked) */
+
+ result[6] = 0.;
+ if (linfo == mn_1.mplusn + 3) {
+ result[6] = ulpinv;
+ } else if (mm != mn_1.n) {
+ result[6] = ulpinv;
+ }
+ ++ntest;
+
+/* Test (8): compare the estimated value DIF and its */
+/* value. first, compute the exact DIF. */
+
+ result[7] = 0.;
+ mn2 = mm * (mn_1.mplusn - mm) << 1;
+ if (ifunc >= 2 && mn2 <= *ncmax * *ncmax) {
+
+/* Note: for either following two cases, there are */
+/* almost same number of test cases fail the test. */
+
+ i__3 = mn_1.mplusn - mm;
+ zlakf2_(&mm, &i__3, &ai[ai_offset], lda, &ai[mm + 1 +
+ (mm + 1) * ai_dim1], &bi[bi_offset], &bi[mm +
+ 1 + (mm + 1) * bi_dim1], &c__[c_offset], ldc);
+
+ i__3 = *lwork - 2;
+ zgesvd_("N", "N", &mn2, &mn2, &c__[c_offset], ldc, &s[
+ 1], &work[1], &c__1, &work[2], &c__1, &work[3]
+, &i__3, &rwork[1], info);
+ diftru = s[mn2];
+
+ if (difest[1] == 0.) {
+ if (diftru > abnrm * ulp) {
+ result[7] = ulpinv;
+ }
+ } else if (diftru == 0.) {
+ if (difest[1] > abnrm * ulp) {
+ result[7] = ulpinv;
+ }
+ } else if (diftru > thrsh2 * difest[1] || diftru *
+ thrsh2 < difest[1]) {
+/* Computing MAX */
+ d__1 = diftru / difest[1], d__2 = difest[1] /
+ diftru;
+ result[7] = max(d__1,d__2);
+ }
+ ++ntest;
+ }
+
+/* Test (9) */
+
+ result[8] = 0.;
+ if (linfo == mn_1.mplusn + 2) {
+ if (diftru > abnrm * ulp) {
+ result[8] = ulpinv;
+ }
+ if (ifunc > 1 && difest[1] != 0.) {
+ result[8] = ulpinv;
+ }
+ if (ifunc == 1 && pl[0] != 0.) {
+ result[8] = ulpinv;
+ }
+ ++ntest;
+ }
+
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ for (j = 1; j <= 9; ++j) {
+ if (result[j - 1] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "CGX", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "unitary", (ftnlen)7);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ for (i__ = 1; i__ <= 4; ++i__) {
+ do_fio(&c__1, "'", (ftnlen)1);
+ }
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[j - 1] < 1e4) {
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ }
+/* L20: */
+ }
+
+L30:
+ ;
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+
+ goto L150;
+
+L70:
+
+/* Read in data from file to check accuracy of condition estimation */
+/* Read input data until N=0 */
+
+ nptknt = 0;
+
+L80:
+ io___39.ciunit = *nin;
+ i__1 = s_rsle(&io___39);
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer))
+ ;
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = e_rsle();
+ if (i__1 != 0) {
+ goto L140;
+ }
+ if (mn_1.mplusn == 0) {
+ goto L140;
+ }
+ io___40.ciunit = *nin;
+ i__1 = s_rsle(&io___40);
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.n, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = e_rsle();
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = mn_1.mplusn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___41.ciunit = *nin;
+ s_rsle(&io___41);
+ i__2 = mn_1.mplusn;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&ai[i__ + j * ai_dim1], (ftnlen)
+ sizeof(doublecomplex));
+ }
+ e_rsle();
+/* L90: */
+ }
+ i__1 = mn_1.mplusn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___42.ciunit = *nin;
+ s_rsle(&io___42);
+ i__2 = mn_1.mplusn;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&bi[i__ + j * bi_dim1], (ftnlen)
+ sizeof(doublecomplex));
+ }
+ e_rsle();
+/* L100: */
+ }
+ io___43.ciunit = *nin;
+ s_rsle(&io___43);
+ do_lio(&c__5, &c__1, (char *)&pltru, (ftnlen)sizeof(doublereal));
+ do_lio(&c__5, &c__1, (char *)&diftru, (ftnlen)sizeof(doublereal));
+ e_rsle();
+
+ ++nptknt;
+ mn_1.fs = TRUE_;
+ mn_1.k = 0;
+ mn_1.m = mn_1.mplusn - mn_1.n;
+
+ zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &a[
+ a_offset], lda);
+ zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &b[
+ b_offset], lda);
+
+/* Compute the Schur factorization while swaping the */
+/* m-by-m (1,1)-blocks with n-by-n (2,2)-blocks. */
+
+ zggesx_("V", "V", "S", (L_fp)zlctsx_, "B", &mn_1.mplusn, &ai[ai_offset],
+ lda, &bi[bi_offset], lda, &mm, &alpha[1], &beta[1], &q[q_offset],
+ lda, &z__[z_offset], lda, pl, difest, &work[1], lwork, &rwork[1],
+ &iwork[1], liwork, &bwork[1], &linfo);
+
+ if (linfo != 0 && linfo != mn_1.mplusn + 2) {
+ result[0] = ulpinv;
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "ZGGESX", (ftnlen)6);
+ do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L130;
+ }
+
+/* Compute the norm(A, B) */
+/* (should this be norm of (A,B) or (AI,BI)?) */
+
+ zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &work[1],
+ &mn_1.mplusn);
+ zlacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &work[
+ mn_1.mplusn * mn_1.mplusn + 1], &mn_1.mplusn);
+ i__1 = mn_1.mplusn << 1;
+ abnrm = zlange_("Fro", &mn_1.mplusn, &i__1, &work[1], &mn_1.mplusn, &
+ rwork[1]);
+
+/* Do tests (1) to (4) */
+
+ zget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[ai_offset], lda, &q[
+ q_offset], lda, &z__[z_offset], lda, &work[1], &rwork[1], result);
+ zget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
+ q_offset], lda, &z__[z_offset], lda, &work[1], &rwork[1], &result[
+ 1]);
+ zget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
+ q_offset], lda, &q[q_offset], lda, &work[1], &rwork[1], &result[2]
+);
+ zget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &z__[
+ z_offset], lda, &z__[z_offset], lda, &work[1], &rwork[1], &result[
+ 3]);
+
+/* Do tests (5) and (6): check Schur form of A and compare */
+/* eigenvalues with diagonals. */
+
+ ntest = 6;
+ temp1 = 0.;
+ result[4] = 0.;
+ result[5] = 0.;
+
+ i__1 = mn_1.mplusn;
+ for (j = 1; j <= i__1; ++j) {
+ ilabad = FALSE_;
+ i__2 = j;
+ i__3 = j + j * ai_dim1;
+ z__2.r = alpha[i__2].r - ai[i__3].r, z__2.i = alpha[i__2].i - ai[i__3]
+ .i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ i__4 = j;
+ i__5 = j + j * bi_dim1;
+ z__4.r = beta[i__4].r - bi[i__5].r, z__4.i = beta[i__4].i - bi[i__5]
+ .i;
+ z__3.r = z__4.r, z__3.i = z__4.i;
+/* Computing MAX */
+ i__6 = j;
+ i__7 = j + j * ai_dim1;
+ d__13 = smlnum, d__14 = (d__1 = alpha[i__6].r, abs(d__1)) + (d__2 =
+ d_imag(&alpha[j]), abs(d__2)), d__13 = max(d__13,d__14),
+ d__14 = (d__3 = ai[i__7].r, abs(d__3)) + (d__4 = d_imag(&ai[j
+ + j * ai_dim1]), abs(d__4));
+/* Computing MAX */
+ i__8 = j;
+ i__9 = j + j * bi_dim1;
+ d__15 = smlnum, d__16 = (d__5 = beta[i__8].r, abs(d__5)) + (d__6 =
+ d_imag(&beta[j]), abs(d__6)), d__15 = max(d__15,d__16), d__16
+ = (d__7 = bi[i__9].r, abs(d__7)) + (d__8 = d_imag(&bi[j + j *
+ bi_dim1]), abs(d__8));
+ temp2 = (((d__9 = z__1.r, abs(d__9)) + (d__10 = d_imag(&z__1), abs(
+ d__10))) / max(d__13,d__14) + ((d__11 = z__3.r, abs(d__11)) +
+ (d__12 = d_imag(&z__3), abs(d__12))) / max(d__15,d__16)) /
+ ulp;
+ if (j < mn_1.mplusn) {
+ i__2 = j + 1 + j * ai_dim1;
+ if (ai[i__2].r != 0. || ai[i__2].i != 0.) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ }
+ if (j > 1) {
+ i__2 = j + (j - 1) * ai_dim1;
+ if (ai[i__2].r != 0. || ai[i__2].i != 0.) {
+ ilabad = TRUE_;
+ result[4] = ulpinv;
+ }
+ }
+ temp1 = max(temp1,temp2);
+ if (ilabad) {
+ io___46.ciunit = *nout;
+ s_wsfe(&io___46);
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L110: */
+ }
+ result[5] = temp1;
+
+/* Test (7) (if sorting worked) <--------- need to be checked. */
+
+ ntest = 7;
+ result[6] = 0.;
+ if (linfo == mn_1.mplusn + 3) {
+ result[6] = ulpinv;
+ }
+
+/* Test (8): compare the estimated value of DIF and its true value. */
+
+ ntest = 8;
+ result[7] = 0.;
+ if (difest[1] == 0.) {
+ if (diftru > abnrm * ulp) {
+ result[7] = ulpinv;
+ }
+ } else if (diftru == 0.) {
+ if (difest[1] > abnrm * ulp) {
+ result[7] = ulpinv;
+ }
+ } else if (diftru > thrsh2 * difest[1] || diftru * thrsh2 < difest[1]) {
+/* Computing MAX */
+ d__1 = diftru / difest[1], d__2 = difest[1] / diftru;
+ result[7] = max(d__1,d__2);
+ }
+
+/* Test (9) */
+
+ ntest = 9;
+ result[8] = 0.;
+ if (linfo == mn_1.mplusn + 2) {
+ if (diftru > abnrm * ulp) {
+ result[8] = ulpinv;
+ }
+ if (ifunc > 1 && difest[1] != 0.) {
+ result[8] = ulpinv;
+ }
+ if (ifunc == 1 && pl[0] != 0.) {
+ result[8] = ulpinv;
+ }
+ }
+
+/* Test (10): compare the estimated value of PL and it true value. */
+
+ ntest = 10;
+ result[9] = 0.;
+ if (pl[0] == 0.) {
+ if (pltru > abnrm * ulp) {
+ result[9] = ulpinv;
+ }
+ } else if (pltru == 0.) {
+ if (pl[0] > abnrm * ulp) {
+ result[9] = ulpinv;
+ }
+ } else if (pltru > *thresh * pl[0] || pltru * *thresh < pl[0]) {
+ result[9] = ulpinv;
+ }
+
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__1 = ntest;
+ for (j = 1; j <= i__1; ++j) {
+ if (result[j - 1] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___47.ciunit = *nout;
+ s_wsfe(&io___47);
+ do_fio(&c__1, "CGX", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___48.ciunit = *nout;
+ s_wsfe(&io___48);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___49.ciunit = *nout;
+ s_wsfe(&io___49);
+ do_fio(&c__1, "unitary", (ftnlen)7);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ for (i__ = 1; i__ <= 4; ++i__) {
+ do_fio(&c__1, "'", (ftnlen)1);
+ }
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[j - 1] < 1e4) {
+ io___50.ciunit = *nout;
+ s_wsfe(&io___50);
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ } else {
+ io___51.ciunit = *nout;
+ s_wsfe(&io___51);
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+ }
+
+/* L120: */
+ }
+
+L130:
+ goto L80;
+L140:
+
+L150:
+
+/* Summary */
+
+ alasvm_("CGX", nout, &nerrs, &ntestt, &c__0);
+
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+
+ return 0;
+
+
+
+
+
+
+
+
+/* End of ZDRGSX */
+
+} /* zdrgsx_ */
diff --git a/TESTING/EIG/zdrgvx.c b/TESTING/EIG/zdrgvx.c
new file mode 100644
index 0000000..41732d6
--- /dev/null
+++ b/TESTING/EIG/zdrgvx.c
@@ -0,0 +1,986 @@
+/* zdrgvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static doublecomplex c_b11 = {1.,0.};
+static integer c__5 = 5;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+static integer c__3 = 3;
+static integer c__7 = 7;
+
+/* Subroutine */ int zdrgvx_(integer *nsize, doublereal *thresh, integer *nin,
+ integer *nout, doublecomplex *a, integer *lda, doublecomplex *b,
+ doublecomplex *ai, doublecomplex *bi, doublecomplex *alpha,
+ doublecomplex *beta, doublecomplex *vl, doublecomplex *vr, integer *
+ ilo, integer *ihi, doublereal *lscale, doublereal *rscale, doublereal
+ *s, doublereal *dtru, doublereal *dif, doublereal *diftru,
+ doublecomplex *work, integer *lwork, doublereal *rwork, integer *
+ iwork, integer *liwork, doublereal *result, logical *bwork, integer *
+ info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ZDRGVX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002)\002)";
+ static char fmt_9998[] = "(\002 ZDRGVX: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
+ "i6,\002, IWA=\002,i5,\002, IWB=\002,i5,\002, IWX=\002,i5,\002, I"
+ "WY=\002,i5)";
+ static char fmt_9997[] = "(/1x,a3,\002 -- Complex Expert Eigenvalue/vect"
+ "or\002,\002 problem driver\002)";
+ static char fmt_9995[] = "(\002 Matrix types: \002,/)";
+ static char fmt_9994[] = "(\002 TYPE 1: Da is diagonal, Db is identity,"
+ " \002,/\002 A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1) \002,/"
+ "\002 YH and X are left and right eigenvectors. \002,/)";
+ static char fmt_9993[] = "(\002 TYPE 2: Da is quasi-diagonal, Db is iden"
+ "tity, \002,/\002 A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1)"
+ " \002,/\002 YH and X are left and right eigenvectors. \002,/)"
+ ;
+ static char fmt_9992[] = "(/\002 Tests performed: \002,/4x,\002 a is al"
+ "pha, b is beta, l is a left eigenvector, \002,/4x,\002 r is a ri"
+ "ght eigenvector and \002,a,\002 means \002,a,\002.\002,/\002 1 ="
+ " max | ( b A - a B )\002,a,\002 l | / const.\002,/\002 2 = max |"
+ " ( b A - a B ) r | / const.\002,/\002 3 = max ( Sest/Stru, Stru/"
+ "Sest ) \002,\002 over all eigenvalues\002,/\002 4 = max( DIFest/"
+ "DIFtru, DIFtru/DIFest ) \002,\002 over the 1st and 5th eigenvect"
+ "ors\002,/)";
+ static char fmt_9991[] = "(\002 Type=\002,i2,\002,\002,\002 IWA=\002,i2"
+ ",\002, IWB=\002,i2,\002, IWX=\002,i2,\002, IWY=\002,i2,\002, res"
+ "ult \002,i2,\002 is\002,0p,f8.2)";
+ static char fmt_9990[] = "(\002 Type=\002,i2,\002,\002,\002 IWA=\002,i2"
+ ",\002, IWB=\002,i2,\002, IWX=\002,i2,\002, IWY=\002,i2,\002, res"
+ "ult \002,i2,\002 is\002,1p,d10.3)";
+ static char fmt_9987[] = "(\002 ZDRGVX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, Input example #\002,i2,\002"
+ ")\002)";
+ static char fmt_9986[] = "(\002 ZDRGVX: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, Input Examp"
+ "le #\002,i2,\002)\002)";
+ static char fmt_9996[] = "(\002Input Example\002)";
+ static char fmt_9989[] = "(\002 Input example #\002,i2,\002, matrix orde"
+ "r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,0p,f8.2)";
+ static char fmt_9988[] = "(\002 Input example #\002,i2,\002, matrix orde"
+ "r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,1p,d10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, ai_dim1, ai_offset, b_dim1, b_offset, bi_dim1,
+ bi_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+
+ /* Local variables */
+ integer i__, j, n, iwa, iwb;
+ doublereal ulp;
+ integer iwx, iwy, nmax, linfo;
+ doublereal anorm, bnorm;
+ extern /* Subroutine */ int zget52_(logical *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *
+, doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
+ doublereal *);
+ integer nerrs;
+ doublereal ratio1, ratio2, thrsh2;
+ extern /* Subroutine */ int zlatm6_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal abnorm;
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ doublecomplex weight[5];
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ integer minwrk, maxwrk, iptype;
+ extern /* Subroutine */ int zggevx_(char *, char *, char *, char *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublecomplex *, integer *, doublereal *, integer *,
+ logical *, integer *);
+ doublereal ulpinv;
+ integer nptknt, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___20 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___35 = { 0, 0, 1, 0, 0 };
+ static cilist io___36 = { 0, 0, 0, 0, 0 };
+ static cilist io___37 = { 0, 0, 0, 0, 0 };
+ static cilist io___38 = { 0, 0, 0, 0, 0 };
+ static cilist io___39 = { 0, 0, 0, 0, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9987, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9986, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9986, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9988, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRGVX checks the nonsymmetric generalized eigenvalue problem */
+/* expert driver ZGGEVX. */
+
+/* ZGGEVX computes the generalized eigenvalues, (optionally) the left */
+/* and/or right eigenvectors, (optionally) computes a balancing */
+/* transformation to improve the conditioning, and (optionally) */
+/* reciprocal condition numbers for the eigenvalues and eigenvectors. */
+
+/* When ZDRGVX is called with NSIZE > 0, two types of test matrix pairs */
+/* are generated by the subroutine DLATM6 and test the driver ZGGEVX. */
+/* The test matrices have the known exact condition numbers for */
+/* eigenvalues. For the condition numbers of the eigenvectors */
+/* corresponding the first and last eigenvalues are also know */
+/* ``exactly'' (see ZLATM6). */
+/* For each matrix pair, the following tests will be performed and */
+/* compared with the threshhold THRESH. */
+
+/* (1) max over all left eigenvalue/-vector pairs (beta/alpha,l) of */
+
+/* | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) ) */
+
+/* where l**H is the conjugate tranpose of l. */
+
+/* (2) max over all right eigenvalue/-vector pairs (beta/alpha,r) of */
+
+/* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) ) */
+
+/* (3) The condition number S(i) of eigenvalues computed by ZGGEVX */
+/* differs less than a factor THRESH from the exact S(i) (see */
+/* ZLATM6). */
+
+/* (4) DIF(i) computed by ZTGSNA differs less than a factor 10*THRESH */
+/* from the exact value (for the 1st and 5th vectors only). */
+
+/* Test Matrices */
+/* ============= */
+
+/* Two kinds of test matrix pairs */
+/* (A, B) = inverse(YH) * (Da, Db) * inverse(X) */
+/* are used in the tests: */
+
+/* 1: Da = 1+a 0 0 0 0 Db = 1 0 0 0 0 */
+/* 0 2+a 0 0 0 0 1 0 0 0 */
+/* 0 0 3+a 0 0 0 0 1 0 0 */
+/* 0 0 0 4+a 0 0 0 0 1 0 */
+/* 0 0 0 0 5+a , 0 0 0 0 1 , and */
+
+/* 2: Da = 1 -1 0 0 0 Db = 1 0 0 0 0 */
+/* 1 1 0 0 0 0 1 0 0 0 */
+/* 0 0 1 0 0 0 0 1 0 0 */
+/* 0 0 0 1+a 1+b 0 0 0 1 0 */
+/* 0 0 0 -1-b 1+a , 0 0 0 0 1 . */
+
+/* In both cases the same inverse(YH) and inverse(X) are used to compute */
+/* (A, B), giving the exact eigenvectors to (A,B) as (YH, X): */
+
+/* YH: = 1 0 -y y -y X = 1 0 -x -x x */
+/* 0 1 -y y -y 0 1 x -x -x */
+/* 0 0 1 0 0 0 0 1 0 0 */
+/* 0 0 0 1 0 0 0 0 1 0 */
+/* 0 0 0 0 1, 0 0 0 0 1 , where */
+
+/* a, b, x and y will have all values independently of each other from */
+/* { sqrt(sqrt(ULP)), 0.1, 1, 10, 1/sqrt(sqrt(ULP)) }. */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZE (input) INTEGER */
+/* The number of sizes of matrices to use. NSIZE must be at */
+/* least zero. If it is zero, no randomly generated matrices */
+/* are tested, but any test matrices read from NIN will be */
+/* tested. If it is not zero, then N = 5. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NIN (input) INTEGER */
+/* The FORTRAN unit number for reading in the data file of */
+/* problems to solve. */
+
+/* NOUT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, AI, BI, Ao, and Bo. */
+/* It must be at least 1 and at least NSIZE. */
+
+/* B (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, B contains the last matrix actually used. */
+
+/* AI (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
+/* Copy of A, modified by ZGGEVX. */
+
+/* BI (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
+/* Copy of B, modified by ZGGEVX. */
+
+/* ALPHA (workspace) COMPLEX*16 array, dimension (NSIZE) */
+/* BETA (workspace) COMPLEX*16 array, dimension (NSIZE) */
+/* On exit, ALPHA/BETA are the eigenvalues. */
+
+/* VL (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
+/* VL holds the left eigenvectors computed by ZGGEVX. */
+
+/* VR (workspace) COMPLEX*16 array, dimension (LDA, NSIZE) */
+/* VR holds the right eigenvectors computed by ZGGEVX. */
+
+/* ILO (output/workspace) INTEGER */
+
+/* IHI (output/workspace) INTEGER */
+
+/* LSCALE (output/workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RSCALE (output/workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* S (output/workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* DTRU (output/workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* DIF (output/workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* DIFTRU (output/workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* Leading dimension of WORK. LWORK >= 2*N*N + 2*N */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (6*N) */
+
+/* IWORK (workspace) INTEGER array, dimension (LIWORK) */
+
+/* LIWORK (input) INTEGER */
+/* Leading dimension of IWORK. LIWORK >= N+2. */
+
+/* RESULT (output/workspace) DOUBLE PRECISION array, dimension (4) */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: A routine returned an error code. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ /* Parameter adjustments */
+ vr_dim1 = *lda;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ vl_dim1 = *lda;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ bi_dim1 = *lda;
+ bi_offset = 1 + bi_dim1;
+ bi -= bi_offset;
+ ai_dim1 = *lda;
+ ai_offset = 1 + ai_dim1;
+ ai -= ai_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --alpha;
+ --beta;
+ --lscale;
+ --rscale;
+ --s;
+ --dtru;
+ --dif;
+ --diftru;
+ --work;
+ --rwork;
+ --iwork;
+ --result;
+ --bwork;
+
+ /* Function Body */
+ *info = 0;
+
+ nmax = 5;
+
+ if (*nsize < 0) {
+ *info = -1;
+ } else if (*thresh < 0.) {
+ *info = -2;
+ } else if (*nin <= 0) {
+ *info = -3;
+ } else if (*nout <= 0) {
+ *info = -4;
+ } else if (*lda < 1 || *lda < nmax) {
+ *info = -6;
+ } else if (*liwork < nmax + 2) {
+ *info = -26;
+ }
+
+/* Compute workspace */
+/* (Note: Comments in the code beginning "Workspace:" describe the */
+/* minimal amount of workspace needed at that point in the code, */
+/* as well as the preferred amount for good performance. */
+/* NB refers to the optimal block size for the immediately */
+/* following subroutine, as returned by ILAENV.) */
+
+ minwrk = 1;
+ if (*info == 0 && *lwork >= 1) {
+ minwrk = (nmax << 1) * (nmax + 1);
+ maxwrk = nmax * (ilaenv_(&c__1, "ZGEQRF", " ", &nmax, &c__1, &nmax, &
+ c__0) + 1);
+/* Computing MAX */
+ i__1 = maxwrk, i__2 = (nmax << 1) * (nmax + 1);
+ maxwrk = max(i__1,i__2);
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+ }
+
+ if (*lwork < minwrk) {
+ *info = -23;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZDRGVX", &i__1);
+ return 0;
+ }
+
+ n = 5;
+ ulp = dlamch_("P");
+ ulpinv = 1. / ulp;
+ thrsh2 = *thresh * 10.;
+ nerrs = 0;
+ nptknt = 0;
+ ntestt = 0;
+
+ if (*nsize == 0) {
+ goto L90;
+ }
+
+/* Parameters used for generating test matrices. */
+
+ d__1 = sqrt(sqrt(ulp));
+ z__1.r = d__1, z__1.i = 0.;
+ weight[0].r = z__1.r, weight[0].i = z__1.i;
+ weight[1].r = .1, weight[1].i = 0.;
+ weight[2].r = 1., weight[2].i = 0.;
+ z_div(&z__1, &c_b11, &weight[1]);
+ weight[3].r = z__1.r, weight[3].i = z__1.i;
+ z_div(&z__1, &c_b11, weight);
+ weight[4].r = z__1.r, weight[4].i = z__1.i;
+
+ for (iptype = 1; iptype <= 2; ++iptype) {
+ for (iwa = 1; iwa <= 5; ++iwa) {
+ for (iwb = 1; iwb <= 5; ++iwb) {
+ for (iwx = 1; iwx <= 5; ++iwx) {
+ for (iwy = 1; iwy <= 5; ++iwy) {
+
+/* generated a pair of test matrix */
+
+ zlatm6_(&iptype, &c__5, &a[a_offset], lda, &b[
+ b_offset], &vr[vr_offset], lda, &vl[vl_offset]
+, lda, &weight[iwa - 1], &weight[iwb - 1], &
+ weight[iwx - 1], &weight[iwy - 1], &dtru[1], &
+ diftru[1]);
+
+/* Compute eigenvalues/eigenvectors of (A, B). */
+/* Compute eigenvalue/eigenvector condition numbers */
+/* using computed eigenvectors. */
+
+ zlacpy_("F", &n, &n, &a[a_offset], lda, &ai[ai_offset]
+, lda);
+ zlacpy_("F", &n, &n, &b[b_offset], lda, &bi[bi_offset]
+, lda);
+
+ zggevx_("N", "V", "V", "B", &n, &ai[ai_offset], lda, &
+ bi[bi_offset], lda, &alpha[1], &beta[1], &vl[
+ vl_offset], lda, &vr[vr_offset], lda, ilo,
+ ihi, &lscale[1], &rscale[1], &anorm, &bnorm, &
+ s[1], &dif[1], &work[1], lwork, &rwork[1], &
+ iwork[1], &bwork[1], &linfo);
+ if (linfo != 0) {
+ io___20.ciunit = *nout;
+ s_wsfe(&io___20);
+ do_fio(&c__1, "ZGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ goto L30;
+ }
+
+/* Compute the norm(A, B) */
+
+ zlacpy_("Full", &n, &n, &ai[ai_offset], lda, &work[1],
+ &n);
+ zlacpy_("Full", &n, &n, &bi[bi_offset], lda, &work[n *
+ n + 1], &n);
+ i__1 = n << 1;
+ abnorm = zlange_("Fro", &n, &i__1, &work[1], &n, &
+ rwork[1]);
+
+/* Tests (1) and (2) */
+
+ result[1] = 0.;
+ zget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset],
+ lda, &vl[vl_offset], lda, &alpha[1], &beta[1],
+ &work[1], &rwork[1], &result[1]);
+ if (result[2] > *thresh) {
+ io___22.ciunit = *nout;
+ s_wsfe(&io___22);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "ZGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+
+ result[2] = 0.;
+ zget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset],
+ lda, &vr[vr_offset], lda, &alpha[1], &beta[1]
+, &work[1], &rwork[1], &result[2]);
+ if (result[3] > *thresh) {
+ io___23.ciunit = *nout;
+ s_wsfe(&io___23);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "ZGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[3], (ftnlen)sizeof(
+ doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+
+/* Test (3) */
+
+ result[3] = 0.;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] == 0.) {
+ if (dtru[i__] > abnorm * ulp) {
+ result[3] = ulpinv;
+ }
+ } else if (dtru[i__] == 0.) {
+ if (s[i__] > abnorm * ulp) {
+ result[3] = ulpinv;
+ }
+ } else {
+/* Computing MAX */
+ d__3 = (d__1 = dtru[i__] / s[i__], abs(d__1)),
+ d__4 = (d__2 = s[i__] / dtru[i__],
+ abs(d__2));
+ rwork[i__] = max(d__3,d__4);
+/* Computing MAX */
+ d__1 = result[3], d__2 = rwork[i__];
+ result[3] = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+/* Test (4) */
+
+ result[4] = 0.;
+ if (dif[1] == 0.) {
+ if (diftru[1] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (diftru[1] == 0.) {
+ if (dif[1] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (dif[5] == 0.) {
+ if (diftru[5] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (diftru[5] == 0.) {
+ if (dif[5] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else {
+/* Computing MAX */
+ d__3 = (d__1 = diftru[1] / dif[1], abs(d__1)),
+ d__4 = (d__2 = dif[1] / diftru[1], abs(
+ d__2));
+ ratio1 = max(d__3,d__4);
+/* Computing MAX */
+ d__3 = (d__1 = diftru[5] / dif[5], abs(d__1)),
+ d__4 = (d__2 = dif[5] / diftru[5], abs(
+ d__2));
+ ratio2 = max(d__3,d__4);
+ result[4] = max(ratio1,ratio2);
+ }
+
+ ntestt += 4;
+
+/* Print out tests which fail. */
+
+ for (j = 1; j <= 4; ++j) {
+ if (result[j] >= thrsh2 && j >= 4 || result[j] >=
+ *thresh && j <= 3) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___28.ciunit = *nout;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "ZXV", (ftnlen)3);
+ e_wsfe();
+
+/* Print out messages for built-in examples */
+
+/* Matrix types */
+
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ e_wsfe();
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ e_wsfe();
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ do_fio(&c__1, "'", (ftnlen)1);
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[j] < 1e4) {
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&iptype, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwa, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwb, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwx, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwy, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, (char *)&iptype, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwa, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwb, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwx, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&iwy, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ }
+/* L20: */
+ }
+
+L30:
+
+/* L40: */
+ ;
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+
+ goto L150;
+
+L90:
+
+/* Read in data from file to check accuracy of condition estimation */
+/* Read input data until N=0 */
+
+ io___35.ciunit = *nin;
+ i__1 = s_rsle(&io___35);
+ if (i__1 != 0) {
+ goto L150;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L150;
+ }
+ i__1 = e_rsle();
+ if (i__1 != 0) {
+ goto L150;
+ }
+ if (n == 0) {
+ goto L150;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___36.ciunit = *nin;
+ s_rsle(&io___36);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
+ doublecomplex));
+ }
+ e_rsle();
+/* L100: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___37.ciunit = *nin;
+ s_rsle(&io___37);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&b[i__ + j * b_dim1], (ftnlen)sizeof(
+ doublecomplex));
+ }
+ e_rsle();
+/* L110: */
+ }
+ io___38.ciunit = *nin;
+ s_rsle(&io___38);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__5, &c__1, (char *)&dtru[i__], (ftnlen)sizeof(doublereal));
+ }
+ e_rsle();
+ io___39.ciunit = *nin;
+ s_rsle(&io___39);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__5, &c__1, (char *)&diftru[i__], (ftnlen)sizeof(doublereal))
+ ;
+ }
+ e_rsle();
+
+ ++nptknt;
+
+/* Compute eigenvalues/eigenvectors of (A, B). */
+/* Compute eigenvalue/eigenvector condition numbers */
+/* using computed eigenvectors. */
+
+ zlacpy_("F", &n, &n, &a[a_offset], lda, &ai[ai_offset], lda);
+ zlacpy_("F", &n, &n, &b[b_offset], lda, &bi[bi_offset], lda);
+
+ zggevx_("N", "V", "V", "B", &n, &ai[ai_offset], lda, &bi[bi_offset], lda,
+ &alpha[1], &beta[1], &vl[vl_offset], lda, &vr[vr_offset], lda,
+ ilo, ihi, &lscale[1], &rscale[1], &anorm, &bnorm, &s[1], &dif[1],
+ &work[1], lwork, &rwork[1], &iwork[1], &bwork[1], &linfo);
+
+ if (linfo != 0) {
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "ZGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L140;
+ }
+
+/* Compute the norm(A, B) */
+
+ zlacpy_("Full", &n, &n, &ai[ai_offset], lda, &work[1], &n);
+ zlacpy_("Full", &n, &n, &bi[bi_offset], lda, &work[n * n + 1], &n);
+ i__1 = n << 1;
+ abnorm = zlange_("Fro", &n, &i__1, &work[1], &n, &rwork[1]);
+
+/* Tests (1) and (2) */
+
+ result[1] = 0.;
+ zget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &vl[vl_offset],
+ lda, &alpha[1], &beta[1], &work[1], &rwork[1], &result[1]);
+ if (result[2] > *thresh) {
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "ZGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ result[2] = 0.;
+ zget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &vr[vr_offset]
+, lda, &alpha[1], &beta[1], &work[1], &rwork[1], &result[2]);
+ if (result[3] > *thresh) {
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "ZGGEVX", (ftnlen)6);
+ do_fio(&c__1, (char *)&result[3], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Test (3) */
+
+ result[3] = 0.;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (s[i__] == 0.) {
+ if (dtru[i__] > abnorm * ulp) {
+ result[3] = ulpinv;
+ }
+ } else if (dtru[i__] == 0.) {
+ if (s[i__] > abnorm * ulp) {
+ result[3] = ulpinv;
+ }
+ } else {
+/* Computing MAX */
+ d__3 = (d__1 = dtru[i__] / s[i__], abs(d__1)), d__4 = (d__2 = s[
+ i__] / dtru[i__], abs(d__2));
+ rwork[i__] = max(d__3,d__4);
+/* Computing MAX */
+ d__1 = result[3], d__2 = rwork[i__];
+ result[3] = max(d__1,d__2);
+ }
+/* L120: */
+ }
+
+/* Test (4) */
+
+ result[4] = 0.;
+ if (dif[1] == 0.) {
+ if (diftru[1] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (diftru[1] == 0.) {
+ if (dif[1] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (dif[5] == 0.) {
+ if (diftru[5] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else if (diftru[5] == 0.) {
+ if (dif[5] > abnorm * ulp) {
+ result[4] = ulpinv;
+ }
+ } else {
+/* Computing MAX */
+ d__3 = (d__1 = diftru[1] / dif[1], abs(d__1)), d__4 = (d__2 = dif[1] /
+ diftru[1], abs(d__2));
+ ratio1 = max(d__3,d__4);
+/* Computing MAX */
+ d__3 = (d__1 = diftru[5] / dif[5], abs(d__1)), d__4 = (d__2 = dif[5] /
+ diftru[5], abs(d__2));
+ ratio2 = max(d__3,d__4);
+ result[4] = max(ratio1,ratio2);
+ }
+
+ ntestt += 4;
+
+/* Print out tests which fail. */
+
+ for (j = 1; j <= 4; ++j) {
+ if (result[j] >= thrsh2) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___43.ciunit = *nout;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "ZXV", (ftnlen)3);
+ e_wsfe();
+
+/* Print out messages for built-in examples */
+
+/* Matrix types */
+
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "'", (ftnlen)1);
+ do_fio(&c__1, "transpose", (ftnlen)9);
+ do_fio(&c__1, "'", (ftnlen)1);
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[j] < 1e4) {
+ io___46.ciunit = *nout;
+ s_wsfe(&io___46);
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___47.ciunit = *nout;
+ s_wsfe(&io___47);
+ do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ }
+/* L130: */
+ }
+
+L140:
+
+ goto L90;
+L150:
+
+/* Summary */
+
+ alasvm_("ZXV", nout, &nerrs, &ntestt, &c__0);
+
+ work[1].r = (doublereal) maxwrk, work[1].i = 0.;
+
+ return 0;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+/* End of ZDRGVX */
+
+} /* zdrgvx_ */
diff --git a/TESTING/EIG/zdrvbd.c b/TESTING/EIG/zdrvbd.c
new file mode 100644
index 0000000..642052c
--- /dev/null
+++ b/TESTING/EIG/zdrvbd.c
@@ -0,0 +1,978 @@
+/* zdrvbd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__4 = 4;
+static integer c__1 = 1;
+static integer c__0 = 0;
+
+/* Subroutine */ int zdrvbd_(integer *nsizes, integer *mm, integer *nn,
+ integer *ntypes, logical *dotype, integer *iseed, doublereal *thresh,
+ doublecomplex *a, integer *lda, doublecomplex *u, integer *ldu,
+ doublecomplex *vt, integer *ldvt, doublecomplex *asav, doublecomplex *
+ usav, doublecomplex *vtsav, doublereal *s, doublereal *ssav,
+ doublereal *e, doublecomplex *work, integer *lwork, doublereal *rwork,
+ integer *iwork, integer *nounit, integer *info)
+{
+ /* Initialized data */
+
+ static char cjob[1*4] = "N" "O" "S" "A";
+
+ /* Format strings */
+ static char fmt_9996[] = "(\002 ZDRVBD: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002M=\002,i6,\002, N=\002,i6,\002, JTYPE=\002,i"
+ "6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9995[] = "(\002 ZDRVBD: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002M=\002,i6,\002, N=\002,i6,\002, JTYPE=\002,i"
+ "6,\002, LSWORK=\002,i6,/9x,\002ISEED=(\002,3(i5,\002,\002),i5"
+ ",\002)\002)";
+ static char fmt_9999[] = "(\002 SVD -- Complex Singular Value Decomposit"
+ "ion Driver \002,/\002 Matrix types (see ZDRVBD for details):\002"
+ ",//\002 1 = Zero matrix\002,/\002 2 = Identity matrix\002,/\002 "
+ "3 = Evenly spaced singular values near 1\002,/\002 4 = Evenly sp"
+ "aced singular values near underflow\002,/\002 5 = Evenly spaced "
+ "singular values near overflow\002,//\002 Tests performed: ( A is"
+ " dense, U and V are unitary,\002,/19x,\002 S is an array, and Up"
+ "artial, VTpartial, and\002,/19x,\002 Spartial are partially comp"
+ "uted U, VT and S),\002,/)";
+ static char fmt_9998[] = "(\002 Tests performed with Test Threshold ="
+ " \002,f8.2,/\002 ZGESVD: \002,/\002 1 = | A - U diag(S) VT | / ("
+ " |A| max(M,N) ulp ) \002,/\002 2 = | I - U**T U | / ( M ulp )"
+ " \002,/\002 3 = | I - VT VT**T | / ( N ulp ) \002,/\002 4 = 0 if"
+ " S contains min(M,N) nonnegative values in\002,\002 decreasing o"
+ "rder, else 1/ulp\002,/\002 5 = | U - Upartial | / ( M ulp )\002,/"
+ "\002 6 = | VT - VTpartial | / ( N ulp )\002,/\002 7 = | S - Spar"
+ "tial | / ( min(M,N) ulp |S| )\002,/\002 ZGESDD: \002,/\002 8 = |"
+ " A - U diag(S) VT | / ( |A| max(M,N) ulp ) \002,/\002 9 = | I - "
+ "U**T U | / ( M ulp ) \002,/\00210 = | I - VT VT**T | / ( N ulp ) "
+ "\002,/\00211 = 0 if S contains min(M,N) nonnegative values in"
+ "\002,\002 decreasing order, else 1/ulp\002,/\00212 = | U - Upart"
+ "ial | / ( M ulp )\002,/\00213 = | VT - VTpartial | / ( N ulp "
+ ")\002,/\00214 = | S - Spartial | / ( min(M,N) ulp |S| )\002,//)";
+ static char fmt_9997[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, type "
+ "\002,i1,\002, IWS=\002,i1,\002, seed=\002,4(i4,\002,\002),\002 t"
+ "est(\002,i1,\002)=\002,g11.4)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, asav_dim1, asav_offset, u_dim1, u_offset,
+ usav_dim1, usav_offset, vt_dim1, vt_offset, vtsav_dim1,
+ vtsav_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
+ i__9, i__10, i__11, i__12, i__13, i__14;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, m, n;
+ doublereal dif, div;
+ integer ijq, iju;
+ doublereal ulp;
+ char jobq[1], jobu[1];
+ integer mmax, nmax;
+ doublereal unfl, ovfl;
+ integer ijvt;
+ logical badmm, badnn;
+ integer nfail, iinfo;
+ extern /* Subroutine */ int zbdt01_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, doublereal *, doublereal *);
+ doublereal anorm;
+ integer mnmin, mnmax;
+ char jobvt[1];
+ integer iwspc, jsize, nerrs, jtype, ntest, iwtmp;
+ extern /* Subroutine */ int zunt01_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *), zunt03_(char *, integer *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int zgesdd_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *, integer *), alasvm_(char *,
+ integer *, integer *, integer *, integer *), zgesvd_(char
+ *, char *, integer *, integer *, doublecomplex *, integer *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, integer *);
+ integer ntestf;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *);
+ integer minwrk;
+ extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ doublereal ulpinv, result[14];
+ integer lswork, mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___27 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVBD checks the singular value decomposition (SVD) driver ZGESVD */
+/* and ZGESDD. */
+/* ZGESVD and CGESDD factors A = U diag(S) VT, where U and VT are */
+/* unitary and diag(S) is diagonal with the entries of the array S on */
+/* its diagonal. The entries of S are the singular values, nonnegative */
+/* and stored in decreasing order. U and VT can be optionally not */
+/* computed, overwritten on A, or computed partially. */
+
+/* A is M by N. Let MNMIN = min( M, N ). S has dimension MNMIN. */
+/* U can be M by M or M by MNMIN. VT can be N by N or MNMIN by N. */
+
+/* When ZDRVBD is called, a number of matrix "sizes" (M's and N's) */
+/* and a number of matrix "types" are specified. For each size (M,N) */
+/* and each type of matrix, and for the minimal workspace as well as */
+/* workspace adequate to permit blocking, an M x N matrix "A" will be */
+/* generated and used to test the SVD routines. For each matrix, A will */
+/* be factored as A = U diag(S) VT and the following 12 tests computed: */
+
+/* Test for ZGESVD: */
+
+/* (1) | A - U diag(S) VT | / ( |A| max(M,N) ulp ) */
+
+/* (2) | I - U'U | / ( M ulp ) */
+
+/* (3) | I - VT VT' | / ( N ulp ) */
+
+/* (4) S contains MNMIN nonnegative values in decreasing order. */
+/* (Return 0 if true, 1/ULP if false.) */
+
+/* (5) | U - Upartial | / ( M ulp ) where Upartial is a partially */
+/* computed U. */
+
+/* (6) | VT - VTpartial | / ( N ulp ) where VTpartial is a partially */
+/* computed VT. */
+
+/* (7) | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the */
+/* vector of singular values from the partial SVD */
+
+/* Test for ZGESDD: */
+
+/* (1) | A - U diag(S) VT | / ( |A| max(M,N) ulp ) */
+
+/* (2) | I - U'U | / ( M ulp ) */
+
+/* (3) | I - VT VT' | / ( N ulp ) */
+
+/* (4) S contains MNMIN nonnegative values in decreasing order. */
+/* (Return 0 if true, 1/ULP if false.) */
+
+/* (5) | U - Upartial | / ( M ulp ) where Upartial is a partially */
+/* computed U. */
+
+/* (6) | VT - VTpartial | / ( N ulp ) where VTpartial is a partially */
+/* computed VT. */
+
+/* (7) | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the */
+/* vector of singular values from the partial SVD */
+
+/* The "sizes" are specified by the arrays MM(1:NSIZES) and */
+/* NN(1:NSIZES); the value of each element pair (MM(j),NN(j)) */
+/* specifies one size. The "types" are specified by a logical array */
+/* DOTYPE( 1:NTYPES ); if DOTYPE(j) is .TRUE., then matrix type "j" */
+/* will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A matrix of the form U D V, where U and V are unitary and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+/* (4) Same as (3), but multiplied by the underflow-threshold / ULP. */
+/* (5) Same as (3), but multiplied by the overflow-threshold * ULP. */
+
+/* Arguments */
+/* ========== */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* ZDRVBD does nothing. It must be at least zero. */
+
+/* MM (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the matrix "heights" to be used. For */
+/* each j=1,...,NSIZES, if MM(j) is zero, then MM(j) and NN(j) */
+/* will be ignored. The MM(j) values must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the matrix "widths" to be used. For */
+/* each j=1,...,NSIZES, if NN(j) is zero, then MM(j) and NN(j) */
+/* will be ignored. The NN(j) values must be at least zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, ZDRVBD */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrices are in A and B. */
+/* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size (m,n), a matrix */
+/* of type j will be generated. If NTYPES is smaller than the */
+/* maximum number of types defined (PARAMETER MAXTYP), then */
+/* types NTYPES+1 through MAXTYP will not be generated. If */
+/* NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through */
+/* DOTYPE(NTYPES) will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to ZDRVBD to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (output) COMPLEX*16 array, dimension (LDA,max(NN)) */
+/* Used to hold the matrix whose singular values are to be */
+/* computed. On exit, A contains the last matrix actually */
+/* used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at */
+/* least 1 and at least max( MM ). */
+
+/* U (output) COMPLEX*16 array, dimension (LDU,max(MM)) */
+/* Used to hold the computed matrix of right singular vectors. */
+/* On exit, U contains the last such vectors actually computed. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. It must be at */
+/* least 1 and at least max( MM ). */
+
+/* VT (output) COMPLEX*16 array, dimension (LDVT,max(NN)) */
+/* Used to hold the computed matrix of left singular vectors. */
+/* On exit, VT contains the last such vectors actually computed. */
+
+/* LDVT (input) INTEGER */
+/* The leading dimension of VT. It must be at */
+/* least 1 and at least max( NN ). */
+
+/* ASAV (output) COMPLEX*16 array, dimension (LDA,max(NN)) */
+/* Used to hold a different copy of the matrix whose singular */
+/* values are to be computed. On exit, A contains the last */
+/* matrix actually used. */
+
+/* USAV (output) COMPLEX*16 array, dimension (LDU,max(MM)) */
+/* Used to hold a different copy of the computed matrix of */
+/* right singular vectors. On exit, USAV contains the last such */
+/* vectors actually computed. */
+
+/* VTSAV (output) COMPLEX*16 array, dimension (LDVT,max(NN)) */
+/* Used to hold a different copy of the computed matrix of */
+/* left singular vectors. On exit, VTSAV contains the last such */
+/* vectors actually computed. */
+
+/* S (output) DOUBLE PRECISION array, dimension (max(min(MM,NN))) */
+/* Contains the computed singular values. */
+
+/* SSAV (output) DOUBLE PRECISION array, dimension (max(min(MM,NN))) */
+/* Contains another copy of the computed singular values. */
+
+/* E (output) DOUBLE PRECISION array, dimension (max(min(MM,NN))) */
+/* Workspace for ZGESVD. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* MAX(3*MIN(M,N)+MAX(M,N)**2,5*MIN(M,N),3*MAX(M,N)) for all */
+/* pairs (M,N)=(MM(j),NN(j)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, */
+/* dimension ( 5*max(max(MM,NN)) ) */
+
+/* IWORK (workspace) INTEGER array, dimension at least 8*min(M,N) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (7) */
+/* The values computed by the 7 tests described above. */
+/* The values are currently limited to 1/ULP, to avoid */
+/* overflow. */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some MM(j) < 0 */
+/* -3: Some NN(j) < 0 */
+/* -4: NTYPES < 0 */
+/* -7: THRESH < 0 */
+/* -10: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ). */
+/* -12: LDU < 1 or LDU < MMAX. */
+/* -14: LDVT < 1 or LDVT < NMAX, where NMAX is max( NN(j) ). */
+/* -21: LWORK too small. */
+/* If ZLATMS, or ZGESVD returns an error code, the */
+/* absolute value of it is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --mm;
+ --nn;
+ --dotype;
+ --iseed;
+ asav_dim1 = *lda;
+ asav_offset = 1 + asav_dim1;
+ asav -= asav_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ usav_dim1 = *ldu;
+ usav_offset = 1 + usav_dim1;
+ usav -= usav_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ vtsav_dim1 = *ldvt;
+ vtsav_offset = 1 + vtsav_dim1;
+ vtsav -= vtsav_offset;
+ vt_dim1 = *ldvt;
+ vt_offset = 1 + vt_dim1;
+ vt -= vt_offset;
+ --s;
+ --ssav;
+ --e;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+
+/* Important constants */
+
+ nerrs = 0;
+ ntestt = 0;
+ ntestf = 0;
+ badmm = FALSE_;
+ badnn = FALSE_;
+ mmax = 1;
+ nmax = 1;
+ mnmax = 1;
+ minwrk = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = mmax, i__3 = mm[j];
+ mmax = max(i__2,i__3);
+ if (mm[j] < 0) {
+ badmm = TRUE_;
+ }
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__4 = mm[j], i__5 = nn[j];
+ i__2 = mnmax, i__3 = min(i__4,i__5);
+ mnmax = max(i__2,i__3);
+/* Computing MAX */
+/* Computing MAX */
+/* Computing MIN */
+ i__6 = mm[j], i__7 = nn[j];
+/* Computing MAX */
+ i__9 = mm[j], i__10 = nn[j];
+/* Computing 2nd power */
+ i__8 = max(i__9,i__10);
+/* Computing MIN */
+ i__11 = mm[j], i__12 = nn[j];
+/* Computing MAX */
+ i__13 = mm[j], i__14 = nn[j];
+ i__4 = min(i__6,i__7) * 3 + i__8 * i__8, i__5 = min(i__11,i__12) * 5,
+ i__4 = max(i__4,i__5), i__5 = max(i__13,i__14) * 3;
+ i__2 = minwrk, i__3 = max(i__4,i__5);
+ minwrk = max(i__2,i__3);
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badmm) {
+ *info = -2;
+ } else if (badnn) {
+ *info = -3;
+ } else if (*ntypes < 0) {
+ *info = -4;
+ } else if (*lda < max(1,mmax)) {
+ *info = -10;
+ } else if (*ldu < max(1,mmax)) {
+ *info = -12;
+ } else if (*ldvt < max(1,nmax)) {
+ *info = -14;
+ } else if (minwrk > *lwork) {
+ *info = -21;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZDRVBD", &i__1);
+ return 0;
+ }
+
+/* Quick return if nothing to do */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = dlamch_("S");
+ ovfl = 1. / unfl;
+ ulp = dlamch_("E");
+ ulpinv = 1. / ulp;
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ m = mm[jsize];
+ n = nn[jsize];
+ mnmin = min(m,n);
+
+ if (*nsizes != 1) {
+ mtypes = min(5,*ntypes);
+ } else {
+ mtypes = min(6,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L170;
+ }
+ ntest = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Compute "A" */
+
+ if (mtypes > 5) {
+ goto L50;
+ }
+
+ if (jtype == 1) {
+
+/* Zero matrix */
+
+ zlaset_("Full", &m, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ i__3 = min(m,n);
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ s[i__] = 0.;
+/* L30: */
+ }
+
+ } else if (jtype == 2) {
+
+/* Identity matrix */
+
+ zlaset_("Full", &m, &n, &c_b1, &c_b2, &a[a_offset], lda);
+ i__3 = min(m,n);
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ s[i__] = 1.;
+/* L40: */
+ }
+
+ } else {
+
+/* (Scaled) random matrix */
+
+ if (jtype == 3) {
+ anorm = 1.;
+ }
+ if (jtype == 4) {
+ anorm = unfl / ulp;
+ }
+ if (jtype == 5) {
+ anorm = ovfl * ulp;
+ }
+ d__1 = (doublereal) mnmin;
+ i__3 = m - 1;
+ i__4 = n - 1;
+ zlatms_(&m, &n, "U", &iseed[1], "N", &s[1], &c__4, &d__1, &
+ anorm, &i__3, &i__4, "N", &a[a_offset], lda, &work[1],
+ &iinfo);
+ if (iinfo != 0) {
+ io___27.ciunit = *nounit;
+ s_wsfe(&io___27);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+ }
+
+L50:
+ zlacpy_("F", &m, &n, &a[a_offset], lda, &asav[asav_offset], lda);
+
+/* Do for minimal and adequate (for blocking) workspace */
+
+ for (iwspc = 1; iwspc <= 4; ++iwspc) {
+
+/* Test for ZGESVD */
+
+ iwtmp = (min(m,n) << 1) + max(m,n);
+ lswork = iwtmp + (iwspc - 1) * (*lwork - iwtmp) / 3;
+ lswork = min(lswork,*lwork);
+ lswork = max(lswork,1);
+ if (iwspc == 4) {
+ lswork = *lwork;
+ }
+
+ for (j = 1; j <= 14; ++j) {
+ result[j - 1] = -1.;
+/* L60: */
+ }
+
+/* Factorize A */
+
+ if (iwspc > 1) {
+ zlacpy_("F", &m, &n, &asav[asav_offset], lda, &a[a_offset]
+, lda);
+ }
+ zgesvd_("A", "A", &m, &n, &a[a_offset], lda, &ssav[1], &usav[
+ usav_offset], ldu, &vtsav[vtsav_offset], ldvt, &work[
+ 1], &lswork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___32.ciunit = *nounit;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "GESVD", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lswork, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Do tests 1--4 */
+
+ zbdt01_(&m, &n, &c__0, &asav[asav_offset], lda, &usav[
+ usav_offset], ldu, &ssav[1], &e[1], &vtsav[
+ vtsav_offset], ldvt, &work[1], &rwork[1], result);
+ if (m != 0 && n != 0) {
+ zunt01_("Columns", &mnmin, &m, &usav[usav_offset], ldu, &
+ work[1], lwork, &rwork[1], &result[1]);
+ zunt01_("Rows", &mnmin, &n, &vtsav[vtsav_offset], ldvt, &
+ work[1], lwork, &rwork[1], &result[2]);
+ }
+ result[3] = 0.;
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (ssav[i__] < ssav[i__ + 1]) {
+ result[3] = ulpinv;
+ }
+ if (ssav[i__] < 0.) {
+ result[3] = ulpinv;
+ }
+/* L70: */
+ }
+ if (mnmin >= 1) {
+ if (ssav[mnmin] < 0.) {
+ result[3] = ulpinv;
+ }
+ }
+
+/* Do partial SVDs, comparing to SSAV, USAV, and VTSAV */
+
+ result[4] = 0.;
+ result[5] = 0.;
+ result[6] = 0.;
+ for (iju = 0; iju <= 3; ++iju) {
+ for (ijvt = 0; ijvt <= 3; ++ijvt) {
+ if (iju == 3 && ijvt == 3 || iju == 1 && ijvt == 1) {
+ goto L90;
+ }
+ *(unsigned char *)jobu = *(unsigned char *)&cjob[iju];
+ *(unsigned char *)jobvt = *(unsigned char *)&cjob[
+ ijvt];
+ zlacpy_("F", &m, &n, &asav[asav_offset], lda, &a[
+ a_offset], lda);
+ zgesvd_(jobu, jobvt, &m, &n, &a[a_offset], lda, &s[1],
+ &u[u_offset], ldu, &vt[vt_offset], ldvt, &
+ work[1], &lswork, &rwork[1], &iinfo);
+
+/* Compare U */
+
+ dif = 0.;
+ if (m > 0 && n > 0) {
+ if (iju == 1) {
+ zunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
+ usav_offset], ldu, &a[a_offset], lda,
+ &work[1], lwork, &rwork[1], &dif, &
+ iinfo);
+ } else if (iju == 2) {
+ zunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
+ usav_offset], ldu, &u[u_offset], ldu,
+ &work[1], lwork, &rwork[1], &dif, &
+ iinfo);
+ } else if (iju == 3) {
+ zunt03_("C", &m, &m, &m, &mnmin, &usav[
+ usav_offset], ldu, &u[u_offset], ldu,
+ &work[1], lwork, &rwork[1], &dif, &
+ iinfo);
+ }
+ }
+ result[4] = max(result[4],dif);
+
+/* Compare VT */
+
+ dif = 0.;
+ if (m > 0 && n > 0) {
+ if (ijvt == 1) {
+ zunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &a[a_offset],
+ lda, &work[1], lwork, &rwork[1], &dif,
+ &iinfo);
+ } else if (ijvt == 2) {
+ zunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &vt[vt_offset],
+ ldvt, &work[1], lwork, &rwork[1], &
+ dif, &iinfo);
+ } else if (ijvt == 3) {
+ zunt03_("R", &n, &n, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &vt[vt_offset],
+ ldvt, &work[1], lwork, &rwork[1], &
+ dif, &iinfo);
+ }
+ }
+ result[5] = max(result[5],dif);
+
+/* Compare S */
+
+ dif = 0.;
+/* Computing MAX */
+ d__1 = (doublereal) mnmin * ulp * s[1], d__2 =
+ dlamch_("Safe minimum");
+ div = max(d__1,d__2);
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (ssav[i__] < ssav[i__ + 1]) {
+ dif = ulpinv;
+ }
+ if (ssav[i__] < 0.) {
+ dif = ulpinv;
+ }
+/* Computing MAX */
+ d__2 = dif, d__3 = (d__1 = ssav[i__] - s[i__],
+ abs(d__1)) / div;
+ dif = max(d__2,d__3);
+/* L80: */
+ }
+ result[6] = max(result[6],dif);
+L90:
+ ;
+ }
+/* L100: */
+ }
+
+/* Test for ZGESDD */
+
+ iwtmp = (mnmin << 1) * mnmin + (mnmin << 1) + max(m,n);
+ lswork = iwtmp + (iwspc - 1) * (*lwork - iwtmp) / 3;
+ lswork = min(lswork,*lwork);
+ lswork = max(lswork,1);
+ if (iwspc == 4) {
+ lswork = *lwork;
+ }
+
+/* Factorize A */
+
+ zlacpy_("F", &m, &n, &asav[asav_offset], lda, &a[a_offset],
+ lda);
+ zgesdd_("A", &m, &n, &a[a_offset], lda, &ssav[1], &usav[
+ usav_offset], ldu, &vtsav[vtsav_offset], ldvt, &work[
+ 1], &lswork, &rwork[1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___39.ciunit = *nounit;
+ s_wsfe(&io___39);
+ do_fio(&c__1, "GESDD", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&lswork, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Do tests 1--4 */
+
+ zbdt01_(&m, &n, &c__0, &asav[asav_offset], lda, &usav[
+ usav_offset], ldu, &ssav[1], &e[1], &vtsav[
+ vtsav_offset], ldvt, &work[1], &rwork[1], &result[7]);
+ if (m != 0 && n != 0) {
+ zunt01_("Columns", &mnmin, &m, &usav[usav_offset], ldu, &
+ work[1], lwork, &rwork[1], &result[8]);
+ zunt01_("Rows", &mnmin, &n, &vtsav[vtsav_offset], ldvt, &
+ work[1], lwork, &rwork[1], &result[9]);
+ }
+ result[10] = 0.;
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (ssav[i__] < ssav[i__ + 1]) {
+ result[10] = ulpinv;
+ }
+ if (ssav[i__] < 0.) {
+ result[10] = ulpinv;
+ }
+/* L110: */
+ }
+ if (mnmin >= 1) {
+ if (ssav[mnmin] < 0.) {
+ result[10] = ulpinv;
+ }
+ }
+
+/* Do partial SVDs, comparing to SSAV, USAV, and VTSAV */
+
+ result[11] = 0.;
+ result[12] = 0.;
+ result[13] = 0.;
+ for (ijq = 0; ijq <= 2; ++ijq) {
+ *(unsigned char *)jobq = *(unsigned char *)&cjob[ijq];
+ zlacpy_("F", &m, &n, &asav[asav_offset], lda, &a[a_offset]
+, lda);
+ zgesdd_(jobq, &m, &n, &a[a_offset], lda, &s[1], &u[
+ u_offset], ldu, &vt[vt_offset], ldvt, &work[1], &
+ lswork, &rwork[1], &iwork[1], &iinfo);
+
+/* Compare U */
+
+ dif = 0.;
+ if (m > 0 && n > 0) {
+ if (ijq == 1) {
+ if (m >= n) {
+ zunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
+ usav_offset], ldu, &a[a_offset], lda,
+ &work[1], lwork, &rwork[1], &dif, &
+ iinfo);
+ } else {
+ zunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
+ usav_offset], ldu, &u[u_offset], ldu,
+ &work[1], lwork, &rwork[1], &dif, &
+ iinfo);
+ }
+ } else if (ijq == 2) {
+ zunt03_("C", &m, &mnmin, &m, &mnmin, &usav[
+ usav_offset], ldu, &u[u_offset], ldu, &
+ work[1], lwork, &rwork[1], &dif, &iinfo);
+ }
+ }
+ result[11] = max(result[11],dif);
+
+/* Compare VT */
+
+ dif = 0.;
+ if (m > 0 && n > 0) {
+ if (ijq == 1) {
+ if (m >= n) {
+ zunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &vt[vt_offset],
+ ldvt, &work[1], lwork, &rwork[1], &
+ dif, &iinfo);
+ } else {
+ zunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &a[a_offset],
+ lda, &work[1], lwork, &rwork[1], &dif,
+ &iinfo);
+ }
+ } else if (ijq == 2) {
+ zunt03_("R", &n, &mnmin, &n, &mnmin, &vtsav[
+ vtsav_offset], ldvt, &vt[vt_offset], ldvt,
+ &work[1], lwork, &rwork[1], &dif, &iinfo);
+ }
+ }
+ result[12] = max(result[12],dif);
+
+/* Compare S */
+
+ dif = 0.;
+/* Computing MAX */
+ d__1 = (doublereal) mnmin * ulp * s[1], d__2 = dlamch_(
+ "Safe minimum");
+ div = max(d__1,d__2);
+ i__3 = mnmin - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (ssav[i__] < ssav[i__ + 1]) {
+ dif = ulpinv;
+ }
+ if (ssav[i__] < 0.) {
+ dif = ulpinv;
+ }
+/* Computing MAX */
+ d__2 = dif, d__3 = (d__1 = ssav[i__] - s[i__], abs(
+ d__1)) / div;
+ dif = max(d__2,d__3);
+/* L120: */
+ }
+ result[13] = max(result[13],dif);
+/* L130: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 14; ++j) {
+ if (result[j - 1] >= 0.) {
+ ++ntest;
+ }
+ if (result[j - 1] >= *thresh) {
+ ++nfail;
+ }
+/* L140: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ e_wsfe();
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ntestf = 2;
+ }
+
+ for (j = 1; j <= 14; ++j) {
+ if (result[j - 1] >= *thresh) {
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iwspc, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+/* L150: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+
+/* L160: */
+ }
+
+L170:
+ ;
+ }
+/* L180: */
+ }
+
+/* Summary */
+
+ alasvm_("ZBD", nounit, &nerrs, &ntestt, &c__0);
+
+
+ return 0;
+
+/* End of ZDRVBD */
+
+} /* zdrvbd_ */
diff --git a/TESTING/EIG/zdrves.c b/TESTING/EIG/zdrves.c
new file mode 100644
index 0000000..4d85ecf
--- /dev/null
+++ b/TESTING/EIG/zdrves.c
@@ -0,0 +1,1047 @@
+/* zdrves.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ doublereal selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__0 = 0;
+static integer c__4 = 4;
+static integer c__6 = 6;
+static doublereal c_b38 = 1.;
+static integer c__1 = 1;
+static doublereal c_b48 = 0.;
+static integer c__2 = 2;
+
+/* Subroutine */ int zdrves_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
+ doublecomplex *a, integer *lda, doublecomplex *h__, doublecomplex *ht,
+ doublecomplex *w, doublecomplex *wt, doublecomplex *vs, integer *
+ ldvs, doublereal *result, doublecomplex *work, integer *nwork,
+ doublereal *rwork, integer *iwork, logical *bwork, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
+ static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
+ static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9992[] = "(\002 ZDRVES: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(/1x,a3,\002 -- Complex Schur Form Decompositi"
+ "on Driver\002,/\002 Matrix types (see ZDRVES for details): \002)";
+ static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 \002,\002 5=Diagonal: geom"
+ "etr. spaced entries.\002,/\002 2=Identity matrix. "
+ " \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
+ "/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
+ " 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
+ "l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
+ "ll, evenly spaced.\002)";
+ static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
+ " 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
+ "l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
+ "d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
+ "red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
+ "vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,a6,"
+ "/\002 12=Well-cond., random complex \002,a6,\002 \002,\002 17="
+ "Ill-cond., large rand. complx \002,a4,/\002 13=Ill-condi\002,"
+ "\002tioned, evenly spaced. \002,\002 18=Ill-cond., small ran"
+ "d.\002,\002 complx \002,a4)";
+ static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
+ " \002,\002 21=Matrix \002,\002with small random entries.\002,"
+ "/\002 20=Matrix with large ran\002,\002dom entries. \002,/)";
+ static char fmt_9995[] = "(\002 Tests performed with test threshold ="
+ "\002,f8.2,/\002 ( A denotes A on input and T denotes A on output)"
+ "\002,//\002 1 = 0 if T in Schur form (no sort), \002,\002 1/ulp"
+ " otherwise\002,/\002 2 = | A - VS T transpose(VS) | / ( n |A| ul"
+ "p ) (no sort)\002,/\002 3 = | I - VS transpose(VS) | / ( n ulp )"
+ " (no sort) \002,/\002 4 = 0 if W are eigenvalues of T (no sort)"
+ ",\002,\002 1/ulp otherwise\002,/\002 5 = 0 if T same no matter "
+ "if VS computed (no sort),\002,\002 1/ulp otherwise\002,/\002 6 "
+ "= 0 if W same no matter if VS computed (no sort)\002,\002, 1/ul"
+ "p otherwise\002)";
+ static char fmt_9994[] = "(\002 7 = 0 if T in Schur form (sort), \002"
+ ",\002 1/ulp otherwise\002,/\002 8 = | A - VS T transpose(VS) | "
+ "/ ( n |A| ulp ) (sort)\002,/\002 9 = | I - VS transpose(VS) | / "
+ "( n ulp ) (sort) \002,/\002 10 = 0 if W are eigenvalues of T (so"
+ "rt),\002,\002 1/ulp otherwise\002,/\002 11 = 0 if T same no mat"
+ "ter if VS computed (sort),\002,\002 1/ulp otherwise\002,/\002 1"
+ "2 = 0 if W same no matter if VS computed (sort),\002,\002 1/ulp"
+ " otherwise\002,/\002 13 = 0 if sorting succesful, 1/ulp otherwise"
+ "\002,/)";
+ static char fmt_9993[] = "(\002 N=\002,i5,\002, IWK=\002,i2,\002, seed"
+ "=\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)="
+ "\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, ht_dim1, ht_offset, vs_dim1,
+ vs_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, n;
+ doublereal res[2];
+ integer iwk;
+ doublereal ulp, cond;
+ integer jcol;
+ char path[3];
+ integer sdim, nmax;
+ doublereal unfl, ovfl;
+ integer rsub;
+ char sort[1];
+ logical badnn;
+ integer nfail, imode, iinfo;
+ doublereal conds, anorm;
+ extern /* Subroutine */ int zgees_(char *, char *, L_fp, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, logical *, integer *);
+ integer jsize, nerrs, itype, jtype, ntest, lwork, isort;
+ extern /* Subroutine */ int zhst01_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+ doublereal rtulp;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ integer idumma[1], ioldsd[4];
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer knteig;
+ extern /* Subroutine */ int dlasum_(char *, integer *, integer *, integer
+ *), zlatme_(integer *, char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublecomplex *, char *, char *, char *,
+ char *, doublereal *, integer *, doublereal *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *);
+ integer ntestf;
+ extern logical zslect_(doublecomplex *);
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatmr_(integer *, integer *, char *, integer *, char *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *, char *,
+ char *, doublecomplex *, integer *, doublereal *, doublecomplex *
+, integer *, doublereal *, char *, integer *, integer *, integer *
+, doublereal *, doublereal *, char *, doublecomplex *, integer *,
+ integer *, integer *), zlatms_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublecomplex *, integer *, doublecomplex *,
+ integer *);
+ integer nnwork;
+ doublereal rtulpi;
+ integer mtypes, ntestt;
+ doublereal ulpinv;
+
+ /* Fortran I/O blocks */
+ static cilist io___31 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVES checks the nonsymmetric eigenvalue (Schur form) problem */
+/* driver ZGEES. */
+
+/* When ZDRVES is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 13 */
+/* tests will be performed: */
+
+/* (1) 0 if T is in Schur form, 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (2) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (no sorting of eigenvalues). */
+
+/* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues). */
+
+/* (4) 0 if W are eigenvalues of T */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (5) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (7) 0 if T is in Schur form, 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (8) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (with sorting of eigenvalues). */
+
+/* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues). */
+
+/* (10) 0 if W are eigenvalues of T */
+/* 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (11) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (13) if sorting worked and SDIM is the number of */
+/* eigenvalues which were SELECTed */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
+
+/* (4) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random complex angles. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (5) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random complex angles. */
+/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random complex angles. */
+
+/* (7) Same as (4), but multiplied by a constant near */
+/* the overflow threshold */
+/* (8) Same as (4), but multiplied by a constant near */
+/* the underflow threshold */
+
+/* (9) A matrix of the form U' T U, where U is unitary and */
+/* T has evenly spaced entries 1, ..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (10) A matrix of the form U' T U, where U is unitary and */
+/* T has geometrically spaced entries 1, ..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (11) A matrix of the form U' T U, where U is orthogonal and */
+/* T has "clustered" entries 1, ULP,..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (12) A matrix of the form U' T U, where U is unitary and */
+/* T has complex eigenvalues randomly chosen from */
+/* ULP < |z| < 1 and random O(1) entries in the upper */
+/* triangle. */
+
+/* (13) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
+/* with random complex angles on the diagonal and random O(1) */
+/* entries in the upper triangle. */
+
+/* (14) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has geometrically spaced entries */
+/* 1, ..., ULP with random complex angles on the diagonal */
+/* and random O(1) entries in the upper triangle. */
+
+/* (15) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
+/* with random complex angles on the diagonal and random O(1) */
+/* entries in the upper triangle. */
+
+/* (16) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has complex eigenvalues randomly chosen */
+/* from ULP < |z| < 1 and random O(1) entries in the upper */
+/* triangle. */
+
+/* (17) Same as (16), but multiplied by a constant */
+/* near the overflow threshold */
+/* (18) Same as (16), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* (19) Nonsymmetric matrix with random entries chosen from (-1,1). */
+/* If N is at least 4, all entries in first two rows and last */
+/* row, and first column and last two columns are zero. */
+/* (20) Same as (19), but multiplied by a constant */
+/* near the overflow threshold */
+/* (21) Same as (19), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* ZDRVES does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, ZDRVES */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to ZDRVES to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* A (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, and H. LDA must be at */
+/* least 1 and at least max( NN ). */
+
+/* H (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* Another copy of the test matrix A, modified by ZGEES. */
+
+/* HT (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* Yet another copy of the test matrix A, modified by ZGEES. */
+
+/* W (workspace) COMPLEX*16 array, dimension (max(NN)) */
+/* The computed eigenvalues of A. */
+
+/* WT (workspace) COMPLEX*16 array, dimension (max(NN)) */
+/* Like W, this array contains the eigenvalues of A, */
+/* but those computed when ZGEES only computes a partial */
+/* eigendecomposition, i.e. not Schur vectors */
+
+/* VS (workspace) COMPLEX*16 array, dimension (LDVS, max(NN)) */
+/* VS holds the computed Schur vectors. */
+
+/* LDVS (input) INTEGER */
+/* Leading dimension of VS. Must be at least max(1,max(NN)). */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (13) */
+/* The values computed by the 13 tests described above. */
+/* The values are currently limited to 1/ulp, to avoid overflow. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (NWORK) */
+
+/* NWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 5*NN(j)+2*NN(j)**2 for all j. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+
+/* IWORK (workspace) INTEGER array, dimension (max(NN)) */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -6: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -15: LDVS < 1 or LDVS < NMAX, where NMAX is max( NN(j) ). */
+/* -18: NWORK too small. */
+/* If ZLATMR, CLATMS, CLATME or ZGEES returns an error code, */
+/* the absolute value of it is returned. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NMAX Largest value in NN. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* COND, CONDS, */
+/* IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTULP, RTULPI Square roots of the previous 4 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+/* KCONDS(j) Select whether CONDS is to be 1 or */
+/* 1/sqrt(ulp). (0 means irrelevant.) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ ht_dim1 = *lda;
+ ht_offset = 1 + ht_dim1;
+ ht -= ht_offset;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ --wt;
+ vs_dim1 = *ldvs;
+ vs_offset = 1 + vs_dim1;
+ vs -= vs_offset;
+ --result;
+ --work;
+ --rwork;
+ --iwork;
+ --bwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "ES", (ftnlen)2, (ftnlen)2);
+
+/* Check for errors */
+
+ ntestt = 0;
+ ntestf = 0;
+ *info = 0;
+ sslct_1.selopt = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+ nmax = 0;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.) {
+ *info = -6;
+ } else if (*nounit <= 0) {
+ *info = -7;
+ } else if (*lda < 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldvs < 1 || *ldvs < nmax) {
+ *info = -15;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = nmax;
+ if (nmax * 5 + (i__1 * i__1 << 1) > *nwork) {
+ *info = -18;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZDRVES", &i__1);
+ return 0;
+ }
+
+/* Quick return if nothing to do */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ dlabad_(&unfl, &ovfl);
+ ulp = dlamch_("Precision");
+ ulpinv = 1. / ulp;
+ rtulp = sqrt(ulp);
+ rtulpi = 1. / rtulp;
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L230;
+ }
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KCONDS KMODE KTYPE */
+/* =1 O(1) 1 clustered 1 zero */
+/* =2 large large clustered 2 identity */
+/* =3 small exponential Jordan */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random general, w/ eigenvalues */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 random general */
+/* =10 random triangular */
+
+ if (mtypes > 21) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L30;
+ case 2: goto L40;
+ case 3: goto L50;
+ }
+
+L30:
+ anorm = 1.;
+ goto L60;
+
+L40:
+ anorm = ovfl * ulp;
+ goto L60;
+
+L50:
+ anorm = unfl * ulpinv;
+ goto L60;
+
+L60:
+
+ zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+ if (itype == 1) {
+
+/* Zero */
+
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ z__1.r = anorm, z__1.i = 0.;
+ a[i__4].r = z__1.r, a[i__4].i = z__1.i;
+/* L70: */
+ }
+
+ } else if (itype == 3) {
+
+/* Jordan Block */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ z__1.r = anorm, z__1.i = 0.;
+ a[i__4].r = z__1.r, a[i__4].i = z__1.i;
+ if (jcol > 1) {
+ i__4 = jcol + (jcol - 1) * a_dim1;
+ a[i__4].r = 1., a[i__4].i = 0.;
+ }
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[
+ n + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 6) {
+
+/* General, eigenvalues specified */
+
+ if (kconds[jtype - 1] == 1) {
+ conds = 1.;
+ } else if (kconds[jtype - 1] == 2) {
+ conds = rtulpi;
+ } else {
+ conds = 0.;
+ }
+
+ zlatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2,
+ " ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n,
+ &anorm, &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
+ n << 1) + 1], &c__1, &c_b38, "N", idumma, &c__0, &
+ c__0, &c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ zlatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b38,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
+ n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &n, &
+ c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* General, random eigenvalues */
+
+ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
+ n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &n, &
+ c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+ if (n >= 4) {
+ zlaset_("Full", &c__2, &n, &c_b1, &c_b1, &a[a_offset],
+ lda);
+ i__3 = n - 3;
+ zlaset_("Full", &i__3, &c__1, &c_b1, &c_b1, &a[a_dim1 + 3]
+, lda);
+ i__3 = n - 3;
+ zlaset_("Full", &i__3, &c__2, &c_b1, &c_b1, &a[(n - 1) *
+ a_dim1 + 3], lda);
+ zlaset_("Full", &c__1, &n, &c_b1, &c_b1, &a[n + a_dim1],
+ lda);
+ }
+
+ } else if (itype == 10) {
+
+/* Triangular, random eigenvalues */
+
+ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
+ n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &c__0, &
+ c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___31.ciunit = *nounit;
+ s_wsfe(&io___31);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+/* Test for minimal and generous workspace */
+
+ for (iwk = 1; iwk <= 2; ++iwk) {
+ if (iwk == 1) {
+ nnwork = n * 3;
+ } else {
+/* Computing 2nd power */
+ i__3 = n;
+ nnwork = n * 5 + (i__3 * i__3 << 1);
+ }
+ nnwork = max(nnwork,1);
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 13; ++j) {
+ result[j] = -1.;
+/* L100: */
+ }
+
+/* Test with and without sorting of eigenvalues */
+
+ for (isort = 0; isort <= 1; ++isort) {
+ if (isort == 0) {
+ *(unsigned char *)sort = 'N';
+ rsub = 0;
+ } else {
+ *(unsigned char *)sort = 'S';
+ rsub = 6;
+ }
+
+/* Compute Schur form and Schur vectors, and test them */
+
+ zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset],
+ lda);
+ zgees_("V", sort, (L_fp)zslect_, &n, &h__[h_offset], lda,
+ &sdim, &w[1], &vs[vs_offset], ldvs, &work[1], &
+ nnwork, &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[rsub + 1] = ulpinv;
+ io___38.ciunit = *nounit;
+ s_wsfe(&io___38);
+ do_fio(&c__1, "ZGEES1", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L190;
+ }
+
+/* Do Test (1) or Test (7) */
+
+ result[rsub + 1] = 0.;
+ i__3 = n - 1;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j + 1; i__ <= i__4; ++i__) {
+ i__5 = i__ + j * h_dim1;
+ if (h__[i__5].r != 0. || h__[i__5].i != 0.) {
+ result[rsub + 1] = ulpinv;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+
+/* Do Tests (2) and (3) or Tests (8) and (9) */
+
+/* Computing MAX */
+ i__3 = 1, i__4 = (n << 1) * n;
+ lwork = max(i__3,i__4);
+ zhst01_(&n, &c__1, &n, &a[a_offset], lda, &h__[h_offset],
+ lda, &vs[vs_offset], ldvs, &work[1], &lwork, &
+ rwork[1], res);
+ result[rsub + 2] = res[0];
+ result[rsub + 3] = res[1];
+
+/* Do Test (4) or Test (10) */
+
+ result[rsub + 4] = 0.;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + i__ * h_dim1;
+ i__5 = i__;
+ if (h__[i__4].r != w[i__5].r || h__[i__4].i != w[i__5]
+ .i) {
+ result[rsub + 4] = ulpinv;
+ }
+/* L130: */
+ }
+
+/* Do Test (5) or Test (11) */
+
+ zlacpy_("F", &n, &n, &a[a_offset], lda, &ht[ht_offset],
+ lda);
+ zgees_("N", sort, (L_fp)zslect_, &n, &ht[ht_offset], lda,
+ &sdim, &wt[1], &vs[vs_offset], ldvs, &work[1], &
+ nnwork, &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[rsub + 5] = ulpinv;
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "ZGEES2", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L190;
+ }
+
+ result[rsub + 5] = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__ + j * h_dim1;
+ i__6 = i__ + j * ht_dim1;
+ if (h__[i__5].r != ht[i__6].r || h__[i__5].i !=
+ ht[i__6].i) {
+ result[rsub + 5] = ulpinv;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+/* Do Test (6) or Test (12) */
+
+ result[rsub + 6] = 0.;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = i__;
+ if (w[i__4].r != wt[i__5].r || w[i__4].i != wt[i__5]
+ .i) {
+ result[rsub + 6] = ulpinv;
+ }
+/* L160: */
+ }
+
+/* Do Test (13) */
+
+ if (isort == 1) {
+ result[13] = 0.;
+ knteig = 0;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (zslect_(&w[i__])) {
+ ++knteig;
+ }
+ if (i__ < n) {
+ if (zslect_(&w[i__ + 1]) && ! zslect_(&w[i__])
+ ) {
+ result[13] = ulpinv;
+ }
+ }
+/* L170: */
+ }
+ if (sdim != knteig) {
+ result[13] = ulpinv;
+ }
+ }
+
+/* L180: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L190:
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 13; ++j) {
+ if (result[j] >= 0.) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L200: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ e_wsfe();
+ io___48.ciunit = *nounit;
+ s_wsfe(&io___48);
+ e_wsfe();
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ e_wsfe();
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ e_wsfe();
+ ntestf = 2;
+ }
+
+ for (j = 1; j <= 13; ++j) {
+ if (result[j] >= *thresh) {
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+/* L210: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+
+/* L220: */
+ }
+L230:
+ ;
+ }
+/* L240: */
+ }
+
+/* Summary */
+
+ dlasum_(path, nounit, &nerrs, &ntestt);
+
+
+
+ return 0;
+
+/* End of ZDRVES */
+
+} /* zdrves_ */
diff --git a/TESTING/EIG/zdrvev.c b/TESTING/EIG/zdrvev.c
new file mode 100644
index 0000000..f38326a
--- /dev/null
+++ b/TESTING/EIG/zdrvev.c
@@ -0,0 +1,1102 @@
+/* zdrvev.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__0 = 0;
+static integer c__4 = 4;
+static integer c__6 = 6;
+static doublereal c_b38 = 1.;
+static integer c__1 = 1;
+static doublereal c_b48 = 0.;
+static integer c__2 = 2;
+
+/* Subroutine */ int zdrvev_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
+ doublecomplex *a, integer *lda, doublecomplex *h__, doublecomplex *w,
+ doublecomplex *w1, doublecomplex *vl, integer *ldvl, doublecomplex *
+ vr, integer *ldvr, doublecomplex *lre, integer *ldlre, doublereal *
+ result, doublecomplex *work, integer *nwork, doublereal *rwork,
+ integer *iwork, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
+ static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
+ static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9993[] = "(\002 ZDRVEV: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(/1x,a3,\002 -- Complex Eigenvalue-Eigenvect"
+ "or \002,\002Decomposition Driver\002,/\002 Matrix types (see ZDR"
+ "VEV for details): \002)";
+ static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 \002,\002 5=Diagonal: geom"
+ "etr. spaced entries.\002,/\002 2=Identity matrix. "
+ " \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
+ "/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
+ " 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
+ "l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
+ "ll, evenly spaced.\002)";
+ static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
+ " 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
+ "l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
+ "d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
+ "red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
+ "vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,a6,"
+ "/\002 12=Well-cond., random complex \002,a6,\002 \002,\002 17="
+ "Ill-cond., large rand. complx \002,a4,/\002 13=Ill-condi\002,"
+ "\002tioned, evenly spaced. \002,\002 18=Ill-cond., small ran"
+ "d.\002,\002 complx \002,a4)";
+ static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
+ " \002,\002 21=Matrix \002,\002with small random entries.\002,"
+ "/\002 20=Matrix with large ran\002,\002dom entries. \002,/)";
+ static char fmt_9995[] = "(\002 Tests performed with test threshold ="
+ "\002,f8.2,//\002 1 = | A VR - VR W | / ( n |A| ulp ) \002,/\002 "
+ "2 = | conj-trans(A) VL - VL conj-trans(W) | /\002,\002 ( n |A| u"
+ "lp ) \002,/\002 3 = | |VR(i)| - 1 | / ulp \002,/\002 4 = | |VL(i"
+ ")| - 1 | / ulp \002,/\002 5 = 0 if W same no matter if VR or VL "
+ "computed,\002,\002 1/ulp otherwise\002,/\002 6 = 0 if VR same no"
+ " matter if VL computed,\002,\002 1/ulp otherwise\002,/\002 7 = "
+ "0 if VL same no matter if VR computed,\002,\002 1/ulp otherwis"
+ "e\002,/)";
+ static char fmt_9994[] = "(\002 N=\002,i5,\002, IWK=\002,i2,\002, seed"
+ "=\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)="
+ "\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1,
+ vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6;
+ doublereal d__1, d__2, d__3, d__4, d__5;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double z_abs(doublecomplex *), d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer j, n, jj;
+ doublecomplex dum[1];
+ doublereal res[2];
+ integer iwk;
+ doublereal ulp, vmx, cond;
+ integer jcol;
+ char path[3];
+ integer nmax;
+ doublereal unfl, ovfl, tnrm, vrmx, vtst;
+ logical badnn;
+ integer nfail, imode, iinfo;
+ doublereal conds, anorm;
+ extern /* Subroutine */ int zget22_(char *, char *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublereal *, doublereal *), zgeev_(char *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *);
+ integer jsize, nerrs, itype, jtype, ntest;
+ doublereal rtulp;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
+ char *);
+ integer idumma[1];
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int dlasum_(char *, integer *, integer *, integer
+ *), zlatme_(integer *, char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublecomplex *, char *, char *, char *,
+ char *, doublereal *, integer *, doublereal *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *);
+ integer ntestf;
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatmr_(integer *, integer *, char *, integer *, char *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *, char *,
+ char *, doublecomplex *, integer *, doublereal *, doublecomplex *
+, integer *, doublereal *, char *, integer *, integer *, integer *
+, doublereal *, doublereal *, char *, doublecomplex *, integer *,
+ integer *, integer *), zlatms_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublecomplex *, integer *, doublecomplex *,
+ integer *);
+ doublereal ulpinv;
+ integer nnwork, mtypes, ntestt;
+ doublereal rtulpi;
+
+ /* Fortran I/O blocks */
+ static cilist io___31 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVEV checks the nonsymmetric eigenvalue problem driver ZGEEV. */
+
+/* When ZDRVEV is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 7 */
+/* tests will be performed: */
+
+/* (1) | A * VR - VR * W | / ( n |A| ulp ) */
+
+/* Here VR is the matrix of unit right eigenvectors. */
+/* W is a diagonal matrix with diagonal entries W(j). */
+
+/* (2) | A**H * VL - VL * W**H | / ( n |A| ulp ) */
+
+/* Here VL is the matrix of unit left eigenvectors, A**H is the */
+/* conjugate-transpose of A, and W is as above. */
+
+/* (3) | |VR(i)| - 1 | / ulp and whether largest component real */
+
+/* VR(i) denotes the i-th column of VR. */
+
+/* (4) | |VL(i)| - 1 | / ulp and whether largest component real */
+
+/* VL(i) denotes the i-th column of VL. */
+
+/* (5) W(full) = W(partial) */
+
+/* W(full) denotes the eigenvalues computed when both VR and VL */
+/* are also computed, and W(partial) denotes the eigenvalues */
+/* computed when only W, only W and VR, or only W and VL are */
+/* computed. */
+
+/* (6) VR(full) = VR(partial) */
+
+/* VR(full) denotes the right eigenvectors computed when both VR */
+/* and VL are computed, and VR(partial) denotes the result */
+/* when only VR is computed. */
+
+/* (7) VL(full) = VL(partial) */
+
+/* VL(full) denotes the left eigenvectors computed when both VR */
+/* and VL are also computed, and VL(partial) denotes the result */
+/* when only VL is computed. */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
+
+/* (4) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random complex angles. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (5) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random complex angles. */
+/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random complex angles. */
+
+/* (7) Same as (4), but multiplied by a constant near */
+/* the overflow threshold */
+/* (8) Same as (4), but multiplied by a constant near */
+/* the underflow threshold */
+
+/* (9) A matrix of the form U' T U, where U is unitary and */
+/* T has evenly spaced entries 1, ..., ULP with random complex */
+/* angles on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (10) A matrix of the form U' T U, where U is unitary and */
+/* T has geometrically spaced entries 1, ..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (11) A matrix of the form U' T U, where U is unitary and */
+/* T has "clustered" entries 1, ULP,..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (12) A matrix of the form U' T U, where U is unitary and */
+/* T has complex eigenvalues randomly chosen from */
+/* ULP < |z| < 1 and random O(1) entries in the upper */
+/* triangle. */
+
+/* (13) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
+/* with random complex angles on the diagonal and random O(1) */
+/* entries in the upper triangle. */
+
+/* (14) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has geometrically spaced entries */
+/* 1, ..., ULP with random complex angles on the diagonal */
+/* and random O(1) entries in the upper triangle. */
+
+/* (15) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
+/* with random complex angles on the diagonal and random O(1) */
+/* entries in the upper triangle. */
+
+/* (16) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has complex eigenvalues randomly chosen */
+/* from ULP < |z| < 1 and random O(1) entries in the upper */
+/* triangle. */
+
+/* (17) Same as (16), but multiplied by a constant */
+/* near the overflow threshold */
+/* (18) Same as (16), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* (19) Nonsymmetric matrix with random entries chosen from |z| < 1 */
+/* If N is at least 4, all entries in first two rows and last */
+/* row, and first column and last two columns are zero. */
+/* (20) Same as (19), but multiplied by a constant */
+/* near the overflow threshold */
+/* (21) Same as (19), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* Arguments */
+/* ========== */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* ZDRVEV does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, ZDRVEV */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to ZDRVEV to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* A (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, and H. LDA must be at */
+/* least 1 and at least max(NN). */
+
+/* H (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* Another copy of the test matrix A, modified by ZGEEV. */
+
+/* W (workspace) COMPLEX*16 array, dimension (max(NN)) */
+/* The eigenvalues of A. On exit, W are the eigenvalues of */
+/* the matrix in A. */
+
+/* W1 (workspace) COMPLEX*16 array, dimension (max(NN)) */
+/* Like W, this array contains the eigenvalues of A, */
+/* but those computed when ZGEEV only computes a partial */
+/* eigendecomposition, i.e. not the eigenvalues and left */
+/* and right eigenvectors. */
+
+/* VL (workspace) COMPLEX*16 array, dimension (LDVL, max(NN)) */
+/* VL holds the computed left eigenvectors. */
+
+/* LDVL (input) INTEGER */
+/* Leading dimension of VL. Must be at least max(1,max(NN)). */
+
+/* VR (workspace) COMPLEX*16 array, dimension (LDVR, max(NN)) */
+/* VR holds the computed right eigenvectors. */
+
+/* LDVR (input) INTEGER */
+/* Leading dimension of VR. Must be at least max(1,max(NN)). */
+
+/* LRE (workspace) COMPLEX*16 array, dimension (LDLRE, max(NN)) */
+/* LRE holds the computed right or left eigenvectors. */
+
+/* LDLRE (input) INTEGER */
+/* Leading dimension of LRE. Must be at least max(1,max(NN)). */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (7) */
+/* The values computed by the seven tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (NWORK) */
+
+/* NWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 5*NN(j)+2*NN(j)**2 for all j. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*max(NN)) */
+
+/* IWORK (workspace) INTEGER array, dimension (max(NN)) */
+
+/* INFO (output) INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -6: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -14: LDVL < 1 or LDVL < NMAX, where NMAX is max( NN(j) ). */
+/* -16: LDVR < 1 or LDVR < NMAX, where NMAX is max( NN(j) ). */
+/* -18: LDLRE < 1 or LDLRE < NMAX, where NMAX is max( NN(j) ). */
+/* -21: NWORK too small. */
+/* If ZLATMR, CLATMS, CLATME or ZGEEV returns an error code, */
+/* the absolute value of it is returned. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NMAX Largest value in NN. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* COND, CONDS, */
+/* IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTULP, RTULPI Square roots of the previous 4 values. */
+
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+/* KCONDS(j) Selectw whether CONDS is to be 1 or */
+/* 1/sqrt(ulp). (0 means irrelevant.) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ --w1;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ lre_dim1 = *ldlre;
+ lre_offset = 1 + lre_dim1;
+ lre -= lre_offset;
+ --result;
+ --work;
+ --rwork;
+ --iwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "EV", (ftnlen)2, (ftnlen)2);
+
+/* Check for errors */
+
+ ntestt = 0;
+ ntestf = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+ nmax = 0;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.) {
+ *info = -6;
+ } else if (*nounit <= 0) {
+ *info = -7;
+ } else if (*lda < 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldvl < 1 || *ldvl < nmax) {
+ *info = -14;
+ } else if (*ldvr < 1 || *ldvr < nmax) {
+ *info = -16;
+ } else if (*ldlre < 1 || *ldlre < nmax) {
+ *info = -28;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = nmax;
+ if (nmax * 5 + (i__1 * i__1 << 1) > *nwork) {
+ *info = -21;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZDRVEV", &i__1);
+ return 0;
+ }
+
+/* Quick return if nothing to do */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ dlabad_(&unfl, &ovfl);
+ ulp = dlamch_("Precision");
+ ulpinv = 1. / ulp;
+ rtulp = sqrt(ulp);
+ rtulpi = 1. / rtulp;
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L260;
+ }
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KCONDS KMODE KTYPE */
+/* =1 O(1) 1 clustered 1 zero */
+/* =2 large large clustered 2 identity */
+/* =3 small exponential Jordan */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random general, w/ eigenvalues */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 random general */
+/* =10 random triangular */
+
+ if (mtypes > 21) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L30;
+ case 2: goto L40;
+ case 3: goto L50;
+ }
+
+L30:
+ anorm = 1.;
+ goto L60;
+
+L40:
+ anorm = ovfl * ulp;
+ goto L60;
+
+L50:
+ anorm = unfl * ulpinv;
+ goto L60;
+
+L60:
+
+ zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ z__1.r = anorm, z__1.i = 0.;
+ a[i__4].r = z__1.r, a[i__4].i = z__1.i;
+/* L70: */
+ }
+
+ } else if (itype == 3) {
+
+/* Jordan Block */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ z__1.r = anorm, z__1.i = 0.;
+ a[i__4].r = z__1.r, a[i__4].i = z__1.i;
+ if (jcol > 1) {
+ i__4 = jcol + (jcol - 1) * a_dim1;
+ a[i__4].r = 1., a[i__4].i = 0.;
+ }
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[
+ n + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Hermitian, eigenvalues specified */
+
+ zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 6) {
+
+/* General, eigenvalues specified */
+
+ if (kconds[jtype - 1] == 1) {
+ conds = 1.;
+ } else if (kconds[jtype - 1] == 2) {
+ conds = rtulpi;
+ } else {
+ conds = 0.;
+ }
+
+ zlatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2,
+ " ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n,
+ &anorm, &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
+ n << 1) + 1], &c__1, &c_b38, "N", idumma, &c__0, &
+ c__0, &c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ zlatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b38,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
+ n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &n, &
+ c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* General, random eigenvalues */
+
+ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
+ n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &n, &
+ c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+ if (n >= 4) {
+ zlaset_("Full", &c__2, &n, &c_b1, &c_b1, &a[a_offset],
+ lda);
+ i__3 = n - 3;
+ zlaset_("Full", &i__3, &c__1, &c_b1, &c_b1, &a[a_dim1 + 3]
+, lda);
+ i__3 = n - 3;
+ zlaset_("Full", &i__3, &c__2, &c_b1, &c_b1, &a[(n - 1) *
+ a_dim1 + 3], lda);
+ zlaset_("Full", &c__1, &n, &c_b1, &c_b1, &a[n + a_dim1],
+ lda);
+ }
+
+ } else if (itype == 10) {
+
+/* Triangular, random eigenvalues */
+
+ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b38,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b38, &work[(
+ n << 1) + 1], &c__1, &c_b38, "N", idumma, &n, &c__0, &
+ c_b48, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___31.ciunit = *nounit;
+ s_wsfe(&io___31);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+/* Test for minimal and generous workspace */
+
+ for (iwk = 1; iwk <= 2; ++iwk) {
+ if (iwk == 1) {
+ nnwork = n << 1;
+ } else {
+/* Computing 2nd power */
+ i__3 = n;
+ nnwork = n * 5 + (i__3 * i__3 << 1);
+ }
+ nnwork = max(nnwork,1);
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 7; ++j) {
+ result[j] = -1.;
+/* L100: */
+ }
+
+/* Compute eigenvalues and eigenvectors, and test them */
+
+ zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+ zgeev_("V", "V", &n, &h__[h_offset], lda, &w[1], &vl[
+ vl_offset], ldvl, &vr[vr_offset], ldvr, &work[1], &
+ nnwork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___34.ciunit = *nounit;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "ZGEEV1", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Do Test (1) */
+
+ zget22_("N", "N", "N", &n, &a[a_offset], lda, &vr[vr_offset],
+ ldvr, &w[1], &work[1], &rwork[1], res);
+ result[1] = res[0];
+
+/* Do Test (2) */
+
+ zget22_("C", "N", "C", &n, &a[a_offset], lda, &vl[vl_offset],
+ ldvl, &w[1], &work[1], &rwork[1], res);
+ result[2] = res[0];
+
+/* Do Test (3) */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ tnrm = dznrm2_(&n, &vr[j * vr_dim1 + 1], &c__1);
+/* Computing MAX */
+/* Computing MIN */
+ d__4 = ulpinv, d__5 = (d__1 = tnrm - 1., abs(d__1)) / ulp;
+ d__2 = result[3], d__3 = min(d__4,d__5);
+ result[3] = max(d__2,d__3);
+ vmx = 0.;
+ vrmx = 0.;
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ vtst = z_abs(&vr[jj + j * vr_dim1]);
+ if (vtst > vmx) {
+ vmx = vtst;
+ }
+ i__5 = jj + j * vr_dim1;
+ if (d_imag(&vr[jj + j * vr_dim1]) == 0. && (d__1 = vr[
+ i__5].r, abs(d__1)) > vrmx) {
+ i__6 = jj + j * vr_dim1;
+ vrmx = (d__2 = vr[i__6].r, abs(d__2));
+ }
+/* L110: */
+ }
+ if (vrmx / vmx < 1. - ulp * 2.) {
+ result[3] = ulpinv;
+ }
+/* L120: */
+ }
+
+/* Do Test (4) */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ tnrm = dznrm2_(&n, &vl[j * vl_dim1 + 1], &c__1);
+/* Computing MAX */
+/* Computing MIN */
+ d__4 = ulpinv, d__5 = (d__1 = tnrm - 1., abs(d__1)) / ulp;
+ d__2 = result[4], d__3 = min(d__4,d__5);
+ result[4] = max(d__2,d__3);
+ vmx = 0.;
+ vrmx = 0.;
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ vtst = z_abs(&vl[jj + j * vl_dim1]);
+ if (vtst > vmx) {
+ vmx = vtst;
+ }
+ i__5 = jj + j * vl_dim1;
+ if (d_imag(&vl[jj + j * vl_dim1]) == 0. && (d__1 = vl[
+ i__5].r, abs(d__1)) > vrmx) {
+ i__6 = jj + j * vl_dim1;
+ vrmx = (d__2 = vl[i__6].r, abs(d__2));
+ }
+/* L130: */
+ }
+ if (vrmx / vmx < 1. - ulp * 2.) {
+ result[4] = ulpinv;
+ }
+/* L140: */
+ }
+
+/* Compute eigenvalues only, and test them */
+
+ zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+ zgeev_("N", "N", &n, &h__[h_offset], lda, &w1[1], dum, &c__1,
+ dum, &c__1, &work[1], &nnwork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "ZGEEV2", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Do Test (5) */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ i__5 = j;
+ if (w[i__4].r != w1[i__5].r || w[i__4].i != w1[i__5].i) {
+ result[5] = ulpinv;
+ }
+/* L150: */
+ }
+
+/* Compute eigenvalues and right eigenvectors, and test them */
+
+ zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+ zgeev_("N", "V", &n, &h__[h_offset], lda, &w1[1], dum, &c__1,
+ &lre[lre_offset], ldlre, &work[1], &nnwork, &rwork[1],
+ &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "ZGEEV3", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Do Test (5) again */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ i__5 = j;
+ if (w[i__4].r != w1[i__5].r || w[i__4].i != w1[i__5].i) {
+ result[5] = ulpinv;
+ }
+/* L160: */
+ }
+
+/* Do Test (6) */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ i__5 = j + jj * vr_dim1;
+ i__6 = j + jj * lre_dim1;
+ if (vr[i__5].r != lre[i__6].r || vr[i__5].i != lre[
+ i__6].i) {
+ result[6] = ulpinv;
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+
+/* Compute eigenvalues and left eigenvectors, and test them */
+
+ zlacpy_("F", &n, &n, &a[a_offset], lda, &h__[h_offset], lda);
+ zgeev_("V", "N", &n, &h__[h_offset], lda, &w1[1], &lre[
+ lre_offset], ldlre, dum, &c__1, &work[1], &nnwork, &
+ rwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "ZGEEV4", (ftnlen)6);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Do Test (5) again */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ i__5 = j;
+ if (w[i__4].r != w1[i__5].r || w[i__4].i != w1[i__5].i) {
+ result[5] = ulpinv;
+ }
+/* L190: */
+ }
+
+/* Do Test (7) */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (jj = 1; jj <= i__4; ++jj) {
+ i__5 = j + jj * vl_dim1;
+ i__6 = j + jj * lre_dim1;
+ if (vl[i__5].r != lre[i__6].r || vl[i__5].i != lre[
+ i__6].i) {
+ result[7] = ulpinv;
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L220:
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 7; ++j) {
+ if (result[j] >= 0.) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L230: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___48.ciunit = *nounit;
+ s_wsfe(&io___48);
+ e_wsfe();
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ e_wsfe();
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ e_wsfe();
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ntestf = 2;
+ }
+
+ for (j = 1; j <= 7; ++j) {
+ if (result[j] >= *thresh) {
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+/* L240: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+
+/* L250: */
+ }
+L260:
+ ;
+ }
+/* L270: */
+ }
+
+/* Summary */
+
+ dlasum_(path, nounit, &nerrs, &ntestt);
+
+
+
+ return 0;
+
+/* End of ZDRVEV */
+
+} /* zdrvev_ */
diff --git a/TESTING/EIG/zdrvgg.c b/TESTING/EIG/zdrvgg.c
new file mode 100644
index 0000000..6ce4cce
--- /dev/null
+++ b/TESTING/EIG/zdrvgg.c
@@ -0,0 +1,1155 @@
+/* zdrvgg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__4 = 4;
+static integer c__2 = 2;
+static doublereal c_b39 = 1.;
+static integer c__3 = 3;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int zdrvgg_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, doublereal *
+ thrshn, integer *nounit, doublecomplex *a, integer *lda,
+ doublecomplex *b, doublecomplex *s, doublecomplex *t, doublecomplex *
+ s2, doublecomplex *t2, doublecomplex *q, integer *ldq, doublecomplex *
+ z__, doublecomplex *alpha1, doublecomplex *beta1, doublecomplex *
+ alpha2, doublecomplex *beta2, doublecomplex *vl, doublecomplex *vr,
+ doublecomplex *work, integer *lwork, doublereal *rwork, doublereal *
+ result, integer *info)
+{
+ /* Initialized data */
+
+ static integer kclass[26] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,
+ 2,2,2,3 };
+ static integer kbmagn[26] = { 1,1,1,1,1,1,1,1,3,2,3,2,2,3,1,1,1,1,1,1,1,3,
+ 2,3,2,1 };
+ static integer ktrian[26] = { 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,
+ 1,1,1,1 };
+ static logical lasign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ TRUE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,FALSE_,
+ TRUE_,FALSE_,FALSE_,FALSE_,TRUE_,TRUE_,TRUE_,TRUE_,TRUE_,FALSE_ };
+ static logical lbsign[26] = { FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ FALSE_,TRUE_,FALSE_,FALSE_,TRUE_,TRUE_,FALSE_,FALSE_,TRUE_,FALSE_,
+ TRUE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,FALSE_,
+ FALSE_ };
+ static integer kz1[6] = { 0,1,2,1,3,3 };
+ static integer kz2[6] = { 0,0,1,2,1,1 };
+ static integer kadd[6] = { 0,0,0,0,3,2 };
+ static integer katype[26] = { 0,1,0,1,2,3,4,1,4,4,1,1,4,4,4,2,4,5,8,7,9,4,
+ 4,4,4,0 };
+ static integer kbtype[26] = { 0,0,1,1,2,-3,1,4,1,1,4,4,1,1,-4,2,-4,8,8,8,
+ 8,8,8,8,8,0 };
+ static integer kazero[26] = { 1,1,1,1,1,1,2,1,2,2,1,1,2,2,3,1,3,5,5,5,5,3,
+ 3,3,3,1 };
+ static integer kbzero[26] = { 1,1,1,1,1,1,1,2,1,1,2,2,1,1,4,1,4,6,6,6,6,4,
+ 4,4,4,1 };
+ static integer kamagn[26] = { 1,1,1,1,1,1,1,1,2,3,2,3,2,3,1,1,1,1,1,1,1,2,
+ 3,3,2,1 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ZDRVGG: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 ZDRVGG: \002,a,\002 Eigenvectors from"
+ " \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
+ "error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
+ "i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9997[] = "(/1x,a3,\002 -- Complex Generalized eigenvalue"
+ " problem driver\002)";
+ static char fmt_9996[] = "(\002 Matrix types (see ZDRVGG for details):"
+ " \002)";
+ static char fmt_9995[] = "(\002 Special Matrices:\002,23x,\002(J'=transp"
+ "osed Jordan block)\002,/\002 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I"
+ ") 5=(J',J') \002,\0026=(diag(J',I), diag(I,J'))\002,/\002 Diag"
+ "onal Matrices: ( \002,\002D=diag(0,1,2,...) )\002,/\002 7=(D,"
+ "I) 9=(large*D, small*I\002,\002) 11=(large*I, small*D) 13=(l"
+ "arge*D, large*I)\002,/\002 8=(I,D) 10=(small*D, large*I) 12="
+ "(small*I, large*D) \002,\002 14=(small*D, small*I)\002,/\002 15"
+ "=(D, reversed D)\002)";
+ static char fmt_9994[] = "(\002 Matrices Rotated by Random \002,a,\002 M"
+ "atrices U, V:\002,/\002 16=Transposed Jordan Blocks "
+ " 19=geometric \002,\002alpha, beta=0,1\002,/\002 17=arithm. alp"
+ "ha&beta \002,\002 20=arithmetic alpha, beta=0,"
+ "1\002,/\002 18=clustered \002,\002alpha, beta=0,1 21"
+ "=random alpha, beta=0,1\002,/\002 Large & Small Matrices:\002,"
+ "/\002 22=(large, small) \002,\00223=(small,large) 24=(smal"
+ "l,small) 25=(large,large)\002,/\002 26=random O(1) matrices"
+ ".\002)";
+ static char fmt_9993[] = "(/\002 Tests performed: (S is Schur, T is tri"
+ "angular, \002,\002Q and Z are \002,a,\002,\002,/20x,\002l and r "
+ "are the appropriate left and right\002,/19x,\002eigenvectors, re"
+ "sp., a is alpha, b is beta, and\002,/19x,a,\002 means \002,a,"
+ "\002.)\002,/\002 1 = | A - Q S Z\002,a,\002 | / ( |A| n ulp ) "
+ " 2 = | B - Q T Z\002,a,\002 | / ( |B| n ulp )\002,/\002 3 = | "
+ "I - QQ\002,a,\002 | / ( n ulp ) 4 = | I - ZZ\002,a"
+ ",\002 | / ( n ulp )\002,/\002 5 = difference between (alpha,beta"
+ ") and diagonals of\002,\002 (S,T)\002,/\002 6 = max | ( b A - a "
+ "B )\002,a,\002 l | / const. 7 = max | ( b A - a B ) r | / cons"
+ "t.\002,/1x)";
+ static char fmt_9992[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
+ ",0p,f8.2)";
+ static char fmt_9991[] = "(\002 Matrix order=\002,i5,\002, type=\002,i2"
+ ",\002, seed=\002,4(i4,\002,\002),\002 result \002,i3,\002 is\002"
+ ",1p,d10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, s_dim1,
+ s_offset, s2_dim1, s2_offset, t_dim1, t_offset, t2_dim1,
+ t2_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, z_dim1,
+ z_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9,
+ i__10, i__11;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
+ d__11, d__12, d__13, d__14, d__15, d__16;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *), z_abs(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer j, n, i1, n1, jc, nb, in, jr, ns, nbz;
+ doublereal ulp;
+ integer iadd, nmax;
+ doublereal temp1, temp2;
+ logical badnn;
+ doublereal dumma[4];
+ integer iinfo;
+ doublereal rmagn[4];
+ doublecomplex ctemp;
+ extern /* Subroutine */ int zgegs_(char *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *), zget51_(integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublereal *, doublereal *), zget52_(logical *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublereal *, doublereal *);
+ integer nmats, jsize;
+ extern /* Subroutine */ int zgegv_(char *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *);
+ integer nerrs, jtype, ntest;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *), zlatm4_(
+ integer *, integer *, integer *, integer *, logical *, doublereal
+ *, doublereal *, doublereal *, integer *, integer *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal safmin, safmax;
+ integer ioldsd[4];
+ extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
+ integer *, integer *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *), xerbla_(char *, integer *),
+ zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *);
+ extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
+ integer *);
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *);
+ doublereal ulpinv;
+ integer lwkopt, mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9991, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVGG checks the nonsymmetric generalized eigenvalue driver */
+/* routines. */
+/* T T T */
+/* ZGEGS factors A and B as Q S Z and Q T Z , where means */
+/* transpose, T is upper triangular, S is in generalized Schur form */
+/* (upper triangular), and Q and Z are unitary. It also */
+/* computes the generalized eigenvalues (alpha(1),beta(1)), ..., */
+/* (alpha(n),beta(n)), where alpha(j)=S(j,j) and beta(j)=T(j,j) -- */
+/* thus, w(j) = alpha(j)/beta(j) is a root of the generalized */
+/* eigenvalue problem */
+
+/* det( A - w(j) B ) = 0 */
+
+/* and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent */
+/* problem */
+
+/* det( m(j) A - B ) = 0 */
+
+/* ZGEGV computes the generalized eigenvalues (alpha(1),beta(1)), ..., */
+/* (alpha(n),beta(n)), the matrix L whose columns contain the */
+/* generalized left eigenvectors l, and the matrix R whose columns */
+/* contain the generalized right eigenvectors r for the pair (A,B). */
+
+/* When ZDRVGG is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 7 */
+/* tests will be performed and compared with the threshhold THRESH: */
+
+/* Results from ZGEGS: */
+
+/* H */
+/* (1) | A - Q S Z | / ( |A| n ulp ) */
+
+/* H */
+/* (2) | B - Q T Z | / ( |B| n ulp ) */
+
+/* H */
+/* (3) | I - QQ | / ( n ulp ) */
+
+/* H */
+/* (4) | I - ZZ | / ( n ulp ) */
+
+/* (5) maximum over j of D(j) where: */
+
+/* |alpha(j) - S(j,j)| |beta(j) - T(j,j)| */
+/* D(j) = ------------------------ + ----------------------- */
+/* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|) */
+
+/* Results from ZGEGV: */
+
+/* (6) max over all left eigenvalue/-vector pairs (beta/alpha,l) of */
+
+/* | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) ) */
+
+/* where l**H is the conjugate tranpose of l. */
+
+/* (7) max over all right eigenvalue/-vector pairs (beta/alpha,r) of */
+
+/* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) ) */
+
+/* Test Matrices */
+/* ---- -------- */
+
+/* The sizes of the test matrices are specified by an array */
+/* NN(1:NSIZES); the value of each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if */
+/* DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) ( 0, 0 ) (a pair of zero matrices) */
+
+/* (2) ( I, 0 ) (an identity and a zero matrix) */
+
+/* (3) ( 0, I ) (an identity and a zero matrix) */
+
+/* (4) ( I, I ) (a pair of identity matrices) */
+
+/* t t */
+/* (5) ( J , J ) (a pair of transposed Jordan blocks) */
+
+/* t ( I 0 ) */
+/* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t ) */
+/* ( 0 I ) ( 0 J ) */
+/* and I is a k x k identity and J a (k+1)x(k+1) */
+/* Jordan block; k=(N-1)/2 */
+
+/* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal */
+/* matrix with those diagonal entries.) */
+/* (8) ( I, D ) */
+
+/* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big */
+
+/* (10) ( small*D, big*I ) */
+
+/* (11) ( big*I, small*D ) */
+
+/* (12) ( small*I, big*D ) */
+
+/* (13) ( big*D, big*I ) */
+
+/* (14) ( small*D, small*I ) */
+
+/* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and */
+/* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 ) */
+/* t t */
+/* (16) Q ( J , J ) Z where Q and Z are random unitary matrices. */
+
+/* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices */
+/* with random O(1) entries above the diagonal */
+/* and diagonal entries diag(T1) = */
+/* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) = */
+/* ( 0, N-3, N-4,..., 1, 0, 0 ) */
+
+/* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 ) */
+/* s = machine precision. */
+
+/* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 ) */
+
+/* N-5 */
+/* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+
+/* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 ) */
+/* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 ) */
+/* where r1,..., r(N-4) are random. */
+
+/* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 ) */
+/* diag(T2) = ( 0, 1, ..., 1, 0, 0 ) */
+
+/* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular */
+/* matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* ZDRVGG does nothing. It must be at least zero. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. If it is zero, ZDRVGG */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to ZDRVGG to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error is */
+/* scaled to be O(1), so THRESH should be a reasonably small */
+/* multiple of 1, e.g., 10 or 100. In particular, it should */
+/* not depend on the precision (single vs. double) or the size */
+/* of the matrix. It must be at least zero. */
+
+/* THRSHN (input) DOUBLE PRECISION */
+/* Threshhold for reporting eigenvector normalization error. */
+/* If the normalization of any eigenvector differs from 1 by */
+/* more than THRSHN*ulp, then a special error message will be */
+/* printed. (This is handled separately from the other tests, */
+/* since only a compiler or programming error should cause an */
+/* error message, at least if THRSHN is at least 5--10.) */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+
+/* A (input/workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* Used to hold the original A matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, S, T, S2, and T2. */
+/* It must be at least 1 and at least max( NN ). */
+
+/* B (input/workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* Used to hold the original B matrix. Used as input only */
+/* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and */
+/* DOTYPE(MAXTYP+1)=.TRUE. */
+
+/* S (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from A by ZGEGS. */
+
+/* T (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* The upper triangular matrix computed from B by ZGEGS. */
+
+/* S2 (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* The matrix computed from A by ZGEGV. This will be the */
+/* Schur (upper triangular) form of some matrix related to A, */
+/* but will not, in general, be the same as S. */
+
+/* T2 (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* The matrix computed from B by ZGEGV. This will be the */
+/* Schur form of some matrix related to B, but will not, in */
+/* general, be the same as T. */
+
+/* Q (workspace) COMPLEX*16 array, dimension (LDQ, max(NN)) */
+/* The (left) unitary matrix computed by ZGEGS. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of Q, Z, VL, and VR. It must */
+/* be at least 1 and at least max( NN ). */
+
+/* Z (workspace) COMPLEX*16 array, dimension (LDQ, max(NN)) */
+/* The (right) unitary matrix computed by ZGEGS. */
+
+/* ALPHA1 (workspace) COMPLEX*16 array, dimension (max(NN)) */
+/* BETA1 (workspace) COMPLEX*16 array, dimension (max(NN)) */
+/* The generalized eigenvalues of (A,B) computed by ZGEGS. */
+/* ALPHA1(k) / BETA1(k) is the k-th generalized eigenvalue of */
+/* the matrices in A and B. */
+
+/* ALPHA2 (workspace) COMPLEX*16 array, dimension (max(NN)) */
+/* BETA2 (workspace) COMPLEX*16 array, dimension (max(NN)) */
+/* The generalized eigenvalues of (A,B) computed by ZGEGV. */
+/* ALPHA2(k) / BETA2(k) is the k-th generalized eigenvalue of */
+/* the matrices in A and B. */
+
+/* VL (workspace) COMPLEX*16 array, dimension (LDQ, max(NN)) */
+/* The (lower triangular) left eigenvector matrix for the */
+/* matrices in A and B. */
+
+/* VR (workspace) COMPLEX*16 array, dimension (LDQ, max(NN)) */
+/* The (upper triangular) right eigenvector matrix for the */
+/* matrices in A and B. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* MAX( 2*N, N*(NB+1), (k+1)*(2*k+N+1) ), where "k" is the */
+/* sum of the blocksize and number-of-shifts for ZHGEQZ, and */
+/* NB is the greatest of the blocksizes for ZGEQRF, ZUNMQR, */
+/* and ZUNGQR. (The blocksizes and the number-of-shifts are */
+/* retrieved through calls to ILAENV.) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (8*N) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (7) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value. */
+/* > 0: A routine returned an error code. INFO is the */
+/* absolute value of the INFO value returned. */
+
+/* ===================================================================== */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ t2_dim1 = *lda;
+ t2_offset = 1 + t2_dim1;
+ t2 -= t2_offset;
+ s2_dim1 = *lda;
+ s2_offset = 1 + s2_dim1;
+ s2 -= s2_offset;
+ t_dim1 = *lda;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ s_dim1 = *lda;
+ s_offset = 1 + s_dim1;
+ s -= s_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ vr_dim1 = *ldq;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ vl_dim1 = *ldq;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ z_dim1 = *ldq;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --alpha1;
+ --beta1;
+ --alpha2;
+ --beta2;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Maximum blocksize and shift -- we assume that blocksize and number */
+/* of shifts are monotone increasing functions of N. */
+
+/* Computing MAX */
+ i__1 = 1, i__2 = ilaenv_(&c__1, "ZGEQRF", " ", &nmax, &nmax, &c_n1, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&
+ c__1, "ZUNMQR", "LC", &nmax, &nmax, &nmax, &c_n1), i__1 = max(i__1,i__2), i__2 = ilaenv_(&c__1, "ZUNGQR",
+ " ", &nmax, &nmax, &nmax, &c_n1);
+ nb = max(i__1,i__2);
+ nbz = ilaenv_(&c__1, "ZHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0);
+ ns = ilaenv_(&c__4, "ZHGEQZ", "SII", &nmax, &c__1, &nmax, &c__0);
+ i1 = nbz + ns;
+/* Computing MAX */
+ i__1 = nmax << 1, i__2 = nmax * (nb + 1), i__1 = max(i__1,i__2), i__2 = ((
+ i1 << 1) + nmax + 1) * (i1 + 1);
+ lwkopt = max(i__1,i__2);
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.) {
+ *info = -6;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -10;
+ } else if (*ldq <= 1 || *ldq < nmax) {
+ *info = -19;
+ } else if (lwkopt > *lwork) {
+ *info = -30;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZDRVGG", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+ ulp = dlamch_("Precision");
+ safmin = dlamch_("Safe minimum");
+ safmin /= ulp;
+ safmax = 1. / safmin;
+ dlabad_(&safmin, &safmax);
+ ulpinv = 1. / ulp;
+
+/* The values RMAGN(2:3) depend on N, see below. */
+
+ rmagn[0] = 0.;
+ rmagn[1] = 1.;
+
+/* Loop over sizes, types */
+
+ ntestt = 0;
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ n1 = max(1,n);
+ rmagn[2] = safmax * ulp / (doublereal) n1;
+ rmagn[3] = safmin * ulpinv * n1;
+
+ if (*nsizes != 1) {
+ mtypes = min(26,*ntypes);
+ } else {
+ mtypes = min(27,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L150;
+ }
+ ++nmats;
+ ntest = 0;
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Initialize RESULT */
+
+ for (j = 1; j <= 7; ++j) {
+ result[j] = 0.;
+/* L30: */
+ }
+
+/* Compute A and B */
+
+/* Description of control parameters: */
+
+/* KZLASS: =1 means w/o rotation, =2 means w/ rotation, */
+/* =3 means random. */
+/* KATYPE: the "type" to be passed to ZLATM4 for computing A. */
+/* KAZERO: the pattern of zeros on the diagonal for A: */
+/* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ), */
+/* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ), */
+/* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of */
+/* non-zero entries.) */
+/* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1), */
+/* =2: large, =3: small. */
+/* LASIGN: .TRUE. if the diagonal elements of A are to be */
+/* multiplied by a random magnitude 1 number. */
+/* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B. */
+/* KTRIAN: =0: don't fill in the upper triangle, =1: do. */
+/* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO. */
+/* RMAGN: used to implement KAMAGN and KBMAGN. */
+
+ if (mtypes > 26) {
+ goto L110;
+ }
+ iinfo = 0;
+ if (kclass[jtype - 1] < 3) {
+
+/* Generate A (w/o rotation) */
+
+ if ((i__3 = katype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ zlaset_("Full", &n, &n, &c_b1, &c_b1, &a[a_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ zlatm4_(&katype[jtype - 1], &in, &kz1[kazero[jtype - 1] - 1],
+ &kz2[kazero[jtype - 1] - 1], &lasign[jtype - 1], &
+ rmagn[kamagn[jtype - 1]], &ulp, &rmagn[ktrian[jtype -
+ 1] * kamagn[jtype - 1]], &c__2, &iseed[1], &a[
+ a_offset], lda);
+ iadd = kadd[kazero[jtype - 1] - 1];
+ if (iadd > 0 && iadd <= n) {
+ i__3 = iadd + iadd * a_dim1;
+ i__4 = kamagn[jtype - 1];
+ a[i__3].r = rmagn[i__4], a[i__3].i = 0.;
+ }
+
+/* Generate B (w/o rotation) */
+
+ if ((i__3 = kbtype[jtype - 1], abs(i__3)) == 3) {
+ in = ((n - 1) / 2 << 1) + 1;
+ if (in != n) {
+ zlaset_("Full", &n, &n, &c_b1, &c_b1, &b[b_offset],
+ lda);
+ }
+ } else {
+ in = n;
+ }
+ zlatm4_(&kbtype[jtype - 1], &in, &kz1[kbzero[jtype - 1] - 1],
+ &kz2[kbzero[jtype - 1] - 1], &lbsign[jtype - 1], &
+ rmagn[kbmagn[jtype - 1]], &c_b39, &rmagn[ktrian[jtype
+ - 1] * kbmagn[jtype - 1]], &c__2, &iseed[1], &b[
+ b_offset], lda);
+ iadd = kadd[kbzero[jtype - 1] - 1];
+ if (iadd != 0 && iadd <= n) {
+ i__3 = iadd + iadd * b_dim1;
+ i__4 = kbmagn[jtype - 1];
+ b[i__3].r = rmagn[i__4], b[i__3].i = 0.;
+ }
+
+ if (kclass[jtype - 1] == 2 && n > 0) {
+
+/* Include rotations */
+
+/* Generate Q, Z as Householder transformations times */
+/* a diagonal matrix. */
+
+ i__3 = n - 1;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = jc; jr <= i__4; ++jr) {
+ i__5 = jr + jc * q_dim1;
+ zlarnd_(&z__1, &c__3, &iseed[1]);
+ q[i__5].r = z__1.r, q[i__5].i = z__1.i;
+ i__5 = jr + jc * z_dim1;
+ zlarnd_(&z__1, &c__3, &iseed[1]);
+ z__[i__5].r = z__1.r, z__[i__5].i = z__1.i;
+/* L40: */
+ }
+ i__4 = n + 1 - jc;
+ zlarfg_(&i__4, &q[jc + jc * q_dim1], &q[jc + 1 + jc *
+ q_dim1], &c__1, &work[jc]);
+ i__4 = (n << 1) + jc;
+ i__5 = jc + jc * q_dim1;
+ d__2 = q[i__5].r;
+ d__1 = d_sign(&c_b39, &d__2);
+ work[i__4].r = d__1, work[i__4].i = 0.;
+ i__4 = jc + jc * q_dim1;
+ q[i__4].r = 1., q[i__4].i = 0.;
+ i__4 = n + 1 - jc;
+ zlarfg_(&i__4, &z__[jc + jc * z_dim1], &z__[jc + 1 +
+ jc * z_dim1], &c__1, &work[n + jc]);
+ i__4 = n * 3 + jc;
+ i__5 = jc + jc * z_dim1;
+ d__2 = z__[i__5].r;
+ d__1 = d_sign(&c_b39, &d__2);
+ work[i__4].r = d__1, work[i__4].i = 0.;
+ i__4 = jc + jc * z_dim1;
+ z__[i__4].r = 1., z__[i__4].i = 0.;
+/* L50: */
+ }
+ zlarnd_(&z__1, &c__3, &iseed[1]);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__3 = n + n * q_dim1;
+ q[i__3].r = 1., q[i__3].i = 0.;
+ i__3 = n;
+ work[i__3].r = 0., work[i__3].i = 0.;
+ i__3 = n * 3;
+ d__1 = z_abs(&ctemp);
+ z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+ zlarnd_(&z__1, &c__3, &iseed[1]);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__3 = n + n * z_dim1;
+ z__[i__3].r = 1., z__[i__3].i = 0.;
+ i__3 = n << 1;
+ work[i__3].r = 0., work[i__3].i = 0.;
+ i__3 = n << 2;
+ d__1 = z_abs(&ctemp);
+ z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+
+/* Apply the diagonal matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ i__5 = jr + jc * a_dim1;
+ i__6 = (n << 1) + jr;
+ d_cnjg(&z__3, &work[n * 3 + jc]);
+ z__2.r = work[i__6].r * z__3.r - work[i__6].i *
+ z__3.i, z__2.i = work[i__6].r * z__3.i +
+ work[i__6].i * z__3.r;
+ i__7 = jr + jc * a_dim1;
+ z__1.r = z__2.r * a[i__7].r - z__2.i * a[i__7].i,
+ z__1.i = z__2.r * a[i__7].i + z__2.i * a[
+ i__7].r;
+ a[i__5].r = z__1.r, a[i__5].i = z__1.i;
+ i__5 = jr + jc * b_dim1;
+ i__6 = (n << 1) + jr;
+ d_cnjg(&z__3, &work[n * 3 + jc]);
+ z__2.r = work[i__6].r * z__3.r - work[i__6].i *
+ z__3.i, z__2.i = work[i__6].r * z__3.i +
+ work[i__6].i * z__3.r;
+ i__7 = jr + jc * b_dim1;
+ z__1.r = z__2.r * b[i__7].r - z__2.i * b[i__7].i,
+ z__1.i = z__2.r * b[i__7].i + z__2.i * b[
+ i__7].r;
+ b[i__5].r = z__1.r, b[i__5].i = z__1.i;
+/* L60: */
+ }
+/* L70: */
+ }
+ i__3 = n - 1;
+ zunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ zunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &a[a_offset], lda, &work[(n << 1) +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ zunm2r_("L", "N", &n, &n, &i__3, &q[q_offset], ldq, &work[
+ 1], &b[b_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ i__3 = n - 1;
+ zunm2r_("R", "C", &n, &n, &i__3, &z__[z_offset], ldq, &
+ work[n + 1], &b[b_offset], lda, &work[(n << 1) +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ goto L100;
+ }
+ }
+ } else {
+
+/* Random matrices */
+
+ i__3 = n;
+ for (jc = 1; jc <= i__3; ++jc) {
+ i__4 = n;
+ for (jr = 1; jr <= i__4; ++jr) {
+ i__5 = jr + jc * a_dim1;
+ i__6 = kamagn[jtype - 1];
+ zlarnd_(&z__2, &c__4, &iseed[1]);
+ z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] *
+ z__2.i;
+ a[i__5].r = z__1.r, a[i__5].i = z__1.i;
+ i__5 = jr + jc * b_dim1;
+ i__6 = kbmagn[jtype - 1];
+ zlarnd_(&z__2, &c__4, &iseed[1]);
+ z__1.r = rmagn[i__6] * z__2.r, z__1.i = rmagn[i__6] *
+ z__2.i;
+ b[i__5].r = z__1.r, b[i__5].i = z__1.i;
+/* L80: */
+ }
+/* L90: */
+ }
+ }
+
+L100:
+
+ if (iinfo != 0) {
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L110:
+
+/* Call ZGEGS to compute H, T, Q, Z, alpha, and beta. */
+
+ zlacpy_(" ", &n, &n, &a[a_offset], lda, &s[s_offset], lda);
+ zlacpy_(" ", &n, &n, &b[b_offset], lda, &t[t_offset], lda);
+ ntest = 1;
+ result[1] = ulpinv;
+
+ zgegs_("V", "V", &n, &s[s_offset], lda, &t[t_offset], lda, &
+ alpha1[1], &beta1[1], &q[q_offset], ldq, &z__[z_offset],
+ ldq, &work[1], lwork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "ZGEGS", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L130;
+ }
+
+ ntest = 4;
+
+/* Do tests 1--4 */
+
+ zget51_(&c__1, &n, &a[a_offset], lda, &s[s_offset], lda, &q[
+ q_offset], ldq, &z__[z_offset], ldq, &work[1], &rwork[1],
+ &result[1]);
+ zget51_(&c__1, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
+ q_offset], ldq, &z__[z_offset], ldq, &work[1], &rwork[1],
+ &result[2]);
+ zget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &q[
+ q_offset], ldq, &q[q_offset], ldq, &work[1], &rwork[1], &
+ result[3]);
+ zget51_(&c__3, &n, &b[b_offset], lda, &t[t_offset], lda, &z__[
+ z_offset], ldq, &z__[z_offset], ldq, &work[1], &rwork[1],
+ &result[4]);
+
+/* Do test 5: compare eigenvalues with diagonals. */
+
+ temp1 = 0.;
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ i__5 = j + j * s_dim1;
+ z__2.r = alpha1[i__4].r - s[i__5].r, z__2.i = alpha1[i__4].i
+ - s[i__5].i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ i__6 = j;
+ i__7 = j + j * t_dim1;
+ z__4.r = beta1[i__6].r - t[i__7].r, z__4.i = beta1[i__6].i -
+ t[i__7].i;
+ z__3.r = z__4.r, z__3.i = z__4.i;
+/* Computing MAX */
+ i__8 = j;
+ i__9 = j + j * s_dim1;
+ d__13 = safmin, d__14 = (d__1 = alpha1[i__8].r, abs(d__1)) + (
+ d__2 = d_imag(&alpha1[j]), abs(d__2)), d__13 = max(
+ d__13,d__14), d__14 = (d__3 = s[i__9].r, abs(d__3)) +
+ (d__4 = d_imag(&s[j + j * s_dim1]), abs(d__4));
+/* Computing MAX */
+ i__10 = j;
+ i__11 = j + j * t_dim1;
+ d__15 = safmin, d__16 = (d__5 = beta1[i__10].r, abs(d__5)) + (
+ d__6 = d_imag(&beta1[j]), abs(d__6)), d__15 = max(
+ d__15,d__16), d__16 = (d__7 = t[i__11].r, abs(d__7))
+ + (d__8 = d_imag(&t[j + j * t_dim1]), abs(d__8));
+ temp2 = (((d__9 = z__1.r, abs(d__9)) + (d__10 = d_imag(&z__1),
+ abs(d__10))) / max(d__13,d__14) + ((d__11 = z__3.r,
+ abs(d__11)) + (d__12 = d_imag(&z__3), abs(d__12))) /
+ max(d__15,d__16)) / ulp;
+ temp1 = max(temp1,temp2);
+/* L120: */
+ }
+ result[5] = temp1;
+
+/* Call ZGEGV to compute S2, T2, VL, and VR, do tests. */
+
+/* Eigenvalues and Eigenvectors */
+
+ zlacpy_(" ", &n, &n, &a[a_offset], lda, &s2[s2_offset], lda);
+ zlacpy_(" ", &n, &n, &b[b_offset], lda, &t2[t2_offset], lda);
+ ntest = 6;
+ result[6] = ulpinv;
+
+ zgegv_("V", "V", &n, &s2[s2_offset], lda, &t2[t2_offset], lda, &
+ alpha2[1], &beta2[1], &vl[vl_offset], ldq, &vr[vr_offset],
+ ldq, &work[1], lwork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___47.ciunit = *nounit;
+ s_wsfe(&io___47);
+ do_fio(&c__1, "ZGEGV", (ftnlen)5);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L130;
+ }
+
+ ntest = 7;
+
+/* Do Tests 6 and 7 */
+
+ zget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &vl[
+ vl_offset], ldq, &alpha2[1], &beta2[1], &work[1], &rwork[
+ 1], dumma);
+ result[6] = dumma[0];
+ if (dumma[1] > *thrshn) {
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+ do_fio(&c__1, "Left", (ftnlen)4);
+ do_fio(&c__1, "ZGEGV", (ftnlen)5);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ zget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &vr[
+ vr_offset], ldq, &alpha2[1], &beta2[1], &work[1], &rwork[
+ 1], dumma);
+ result[7] = dumma[0];
+ if (dumma[1] > *thresh) {
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+ do_fio(&c__1, "Right", (ftnlen)5);
+ do_fio(&c__1, "ZGEGV", (ftnlen)5);
+ do_fio(&c__1, (char *)&dumma[1], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+L130:
+
+ ntestt += ntest;
+
+/* Print out tests which fail. */
+
+ i__3 = ntest;
+ for (jr = 1; jr <= i__3; ++jr) {
+ if (result[jr] >= *thresh) {
+
+/* If this is the first test to fail, */
+/* print a header to the data file. */
+
+ if (nerrs == 0) {
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "ZGG", (ftnlen)3);
+ e_wsfe();
+
+/* Matrix types */
+
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ e_wsfe();
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ e_wsfe();
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ do_fio(&c__1, "Unitary", (ftnlen)7);
+ e_wsfe();
+
+/* Tests performed */
+
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+ do_fio(&c__1, "unitary", (ftnlen)7);
+ do_fio(&c__1, "*", (ftnlen)1);
+ do_fio(&c__1, "conjugate transpose", (ftnlen)19);
+ for (j = 1; j <= 5; ++j) {
+ do_fio(&c__1, "*", (ftnlen)1);
+ }
+ e_wsfe();
+
+ }
+ ++nerrs;
+ if (result[jr] < 1e4) {
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ } else {
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+ }
+/* L140: */
+ }
+
+L150:
+ ;
+ }
+/* L160: */
+ }
+
+/* Summary */
+
+ alasvm_("ZGG", nounit, &nerrs, &ntestt, &c__0);
+ return 0;
+
+
+
+
+
+
+
+/* End of ZDRVGG */
+
+} /* zdrvgg_ */
diff --git a/TESTING/EIG/zdrvsg.c b/TESTING/EIG/zdrvsg.c
new file mode 100644
index 0000000..e8df394
--- /dev/null
+++ b/TESTING/EIG/zdrvsg.c
@@ -0,0 +1,2022 @@
+/* zdrvsg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__0 = 0;
+static integer c__6 = 6;
+static doublereal c_b33 = 1.;
+static integer c__1 = 1;
+static doublereal c_b43 = 0.;
+static integer c__4 = 4;
+static integer c__5 = 5;
+static doublereal c_b78 = 10.;
+static integer c__3 = 3;
+
+/* Subroutine */ int zdrvsg_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublereal *d__, doublecomplex *z__, integer *ldz, doublecomplex *ab,
+ doublecomplex *bb, doublecomplex *ap, doublecomplex *bp,
+ doublecomplex *work, integer *nwork, doublereal *rwork, integer *
+ lrwork, integer *iwork, integer *liwork, doublereal *result, integer *
+ info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,4,4,4,4,4,5,5,5,5,5,8,8,8,9,9,9,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3,1,1,1,1,1,1 };
+ static integer kmode[21] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0,4,4,4,4,4,4 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ZDRVSG: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+
+ /* System generated locals */
+ address a__1[3];
+ integer a_dim1, a_offset, ab_dim1, ab_offset, b_dim1, b_offset, bb_dim1,
+ bb_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6[3]
+ , i__7;
+ char ch__1[10], ch__2[11], ch__3[12], ch__4[13];
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, m, n, ka, kb, ij, il, iu;
+ doublereal vl, vu;
+ integer ka9, kb9;
+ doublereal ulp, cond;
+ integer jcol, nmax;
+ doublereal unfl, ovfl;
+ char uplo[1];
+ logical badnn;
+ integer imode;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ doublereal aninv, anorm;
+ integer itemp;
+ extern /* Subroutine */ int zhbgv_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *, integer *);
+ integer nmats, jsize;
+ extern /* Subroutine */ int zhegv_(integer *, char *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublecomplex *, integer *, doublereal *, integer *), zsgt01_(integer *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ doublereal *, doublereal *);
+ integer nerrs, itype, jtype, ntest;
+ extern /* Subroutine */ int zhpgv_(integer *, char *, char *, integer *,
+ doublecomplex *, doublecomplex *, doublereal *, doublecomplex *,
+ integer *, doublecomplex *, doublereal *, integer *);
+ integer iseed2[4];
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *), dlarnd_(integer *, integer *);
+ integer idumma[1];
+ extern /* Subroutine */ int dlafts_(char *, integer *, integer *, integer
+ *, integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal abstol;
+ extern /* Subroutine */ int dlasum_(char *, integer *, integer *, integer
+ *), zhbgvd_(char *, char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, integer *, integer *, integer *, integer
+ *), zhegvd_(integer *, char *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublecomplex *, integer *, doublereal *, integer *,
+ integer *, integer *, integer *);
+ integer ibuplo, ibtype;
+ extern /* Subroutine */ int zhpgvd_(integer *, char *, char *, integer *,
+ doublecomplex *, doublecomplex *, doublereal *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, integer *,
+ integer *, integer *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zhbgvx_(char *, char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *, integer *
+, integer *, doublereal *, integer *, doublereal *, doublecomplex
+ *, integer *, doublecomplex *, doublereal *, integer *, integer *,
+ integer *), zlatmr_(integer *, integer *,
+ char *, integer *, char *, doublecomplex *, integer *,
+ doublereal *, doublecomplex *, char *, char *, doublecomplex *,
+ integer *, doublereal *, doublecomplex *, integer *, doublereal *,
+ char *, integer *, integer *, integer *, doublereal *,
+ doublereal *, char *, doublecomplex *, integer *, integer *,
+ integer *);
+ doublereal rtunfl, rtovfl;
+ integer mtypes, ntestt;
+ doublereal ulpinv;
+ extern /* Subroutine */ int zhegvx_(integer *, char *, char *, char *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, integer *, integer *,
+ integer *), zhpgvx_(integer *, char *,
+ char *, char *, integer *, doublecomplex *, doublecomplex *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, doublereal *, integer *, integer *, integer *), zlatms_(integer *, integer *, char *,
+ integer *, char *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *, char *, doublecomplex *,
+ integer *, doublecomplex *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* ********************************************************************* */
+
+/* modified August 1997, a new parameter LRWORK and LIWORK are */
+/* added in the calling sequence. */
+
+/* test routine CDGT01 is also modified */
+
+/* ********************************************************************* */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVSG checks the complex Hermitian generalized eigenproblem */
+/* drivers. */
+
+/* ZHEGV computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian-definite generalized */
+/* eigenproblem. */
+
+/* ZHEGVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian-definite generalized */
+/* eigenproblem using a divide and conquer algorithm. */
+
+/* ZHEGVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian-definite generalized */
+/* eigenproblem. */
+
+/* ZHPGV computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian-definite generalized */
+/* eigenproblem in packed storage. */
+
+/* ZHPGVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian-definite generalized */
+/* eigenproblem in packed storage using a divide and */
+/* conquer algorithm. */
+
+/* ZHPGVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian-definite generalized */
+/* eigenproblem in packed storage. */
+
+/* ZHBGV computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian-definite banded */
+/* generalized eigenproblem. */
+
+/* ZHBGVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian-definite banded */
+/* generalized eigenproblem using a divide and conquer */
+/* algorithm. */
+
+/* ZHBGVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian-definite banded */
+/* generalized eigenproblem. */
+
+/* When ZDRVSG is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix A of the given type will be */
+/* generated; a random well-conditioned matrix B is also generated */
+/* and the pair (A,B) is used to test the drivers. */
+
+/* For each pair (A,B), the following tests are performed: */
+
+/* (1) ZHEGV with ITYPE = 1 and UPLO ='U': */
+
+/* | A Z - B Z D | / ( |A| |Z| n ulp ) */
+
+/* (2) as (1) but calling ZHPGV */
+/* (3) as (1) but calling ZHBGV */
+/* (4) as (1) but with UPLO = 'L' */
+/* (5) as (4) but calling ZHPGV */
+/* (6) as (4) but calling ZHBGV */
+
+/* (7) ZHEGV with ITYPE = 2 and UPLO ='U': */
+
+/* | A B Z - Z D | / ( |A| |Z| n ulp ) */
+
+/* (8) as (7) but calling ZHPGV */
+/* (9) as (7) but with UPLO = 'L' */
+/* (10) as (9) but calling ZHPGV */
+
+/* (11) ZHEGV with ITYPE = 3 and UPLO ='U': */
+
+/* | B A Z - Z D | / ( |A| |Z| n ulp ) */
+
+/* (12) as (11) but calling ZHPGV */
+/* (13) as (11) but with UPLO = 'L' */
+/* (14) as (13) but calling ZHPGV */
+
+/* ZHEGVD, ZHPGVD and ZHBGVD performed the same 14 tests. */
+
+/* ZHEGVX, ZHPGVX and ZHBGVX performed the above 14 tests with */
+/* the parameter RANGE = 'A', 'N' and 'I', respectively. */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* This type is used for the matrix A which has half-bandwidth KA. */
+/* B is generated as a well-conditioned positive definite matrix */
+/* with half-bandwidth KB (<= KA). */
+/* Currently, the list of possible types for A is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (6) Same as (4), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (4), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U* D U, where U is unitary and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U* D U, where U is unitary and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U* D U, where U is unitary and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) Hermitian matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
+
+/* (16) Same as (8), but with KA = 1 and KB = 1 */
+/* (17) Same as (8), but with KA = 2 and KB = 1 */
+/* (18) Same as (8), but with KA = 2 and KB = 2 */
+/* (19) Same as (8), but with KA = 3 and KB = 1 */
+/* (20) Same as (8), but with KA = 3 and KB = 2 */
+/* (21) Same as (8), but with KA = 3 and KB = 3 */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* ZDRVSG does nothing. It must be at least zero. */
+/* Not modified. */
+
+/* NN INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+/* Not modified. */
+
+/* NTYPES INTEGER */
+/* The number of elements in DOTYPE. If it is zero, ZDRVSG */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+/* Not modified. */
+
+/* DOTYPE LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+/* Not modified. */
+
+/* ISEED INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to ZDRVSG to continue the same random number */
+/* sequence. */
+/* Modified. */
+
+/* THRESH DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+/* Not modified. */
+
+/* NOUNIT INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+/* Not modified. */
+
+/* A COMPLEX*16 array, dimension (LDA , max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually */
+/* used. */
+/* Modified. */
+
+/* LDA INTEGER */
+/* The leading dimension of A. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* B COMPLEX*16 array, dimension (LDB , max(NN)) */
+/* Used to hold the Hermitian positive definite matrix for */
+/* the generailzed problem. */
+/* On exit, B contains the last matrix actually */
+/* used. */
+/* Modified. */
+
+/* LDB INTEGER */
+/* The leading dimension of B. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* D DOUBLE PRECISION array, dimension (max(NN)) */
+/* The eigenvalues of A. On exit, the eigenvalues in D */
+/* correspond with the matrix in A. */
+/* Modified. */
+
+/* Z COMPLEX*16 array, dimension (LDZ, max(NN)) */
+/* The matrix of eigenvectors. */
+/* Modified. */
+
+/* LDZ INTEGER */
+/* The leading dimension of ZZ. It must be at least 1 and */
+/* at least max( NN ). */
+/* Not modified. */
+
+/* AB COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* Workspace. */
+/* Modified. */
+
+/* BB COMPLEX*16 array, dimension (LDB, max(NN)) */
+/* Workspace. */
+/* Modified. */
+
+/* AP COMPLEX*16 array, dimension (max(NN)**2) */
+/* Workspace. */
+/* Modified. */
+
+/* BP COMPLEX*16 array, dimension (max(NN)**2) */
+/* Workspace. */
+/* Modified. */
+
+/* WORK COMPLEX*16 array, dimension (NWORK) */
+/* Workspace. */
+/* Modified. */
+
+/* NWORK INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 2*N + N**2 where N = max( NN(j), 2 ). */
+/* Not modified. */
+
+/* RWORK DOUBLE PRECISION array, dimension (LRWORK) */
+/* Workspace. */
+/* Modified. */
+
+/* LRWORK INTEGER */
+/* The number of entries in RWORK. This must be at least */
+/* max( 7*N, 1 + 4*N + 2*N*lg(N) + 3*N**2 ) where */
+/* N = max( NN(j) ) and lg( N ) = smallest integer k such */
+/* that 2**k >= N . */
+/* Not modified. */
+
+/* IWORK INTEGER array, dimension (LIWORK)) */
+/* Workspace. */
+/* Modified. */
+
+/* LIWORK INTEGER */
+/* The number of entries in IWORK. This must be at least */
+/* 2 + 5*max( NN(j) ). */
+/* Not modified. */
+
+/* RESULT DOUBLE PRECISION array, dimension (70) */
+/* The values computed by the 70 tests described above. */
+/* Modified. */
+
+/* INFO INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -5: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -16: LDZ < 1 or LDZ < NMAX. */
+/* -21: NWORK too small. */
+/* -23: LRWORK too small. */
+/* -25: LIWORK too small. */
+/* If ZLATMR, CLATMS, ZHEGV, ZHPGV, ZHBGV, CHEGVD, CHPGVD, */
+/* ZHPGVD, ZHEGVX, CHPGVX, ZHBGVX returns an error code, */
+/* the absolute value of it is returned. */
+/* Modified. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests that have been run */
+/* on this matrix. */
+/* NTESTT The total number of tests for this call. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far (computed by DLAFTS). */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ ab_dim1 = *lda;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ bb_dim1 = *ldb;
+ bb_offset = 1 + bb_dim1;
+ bb -= bb_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --d__;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --ap;
+ --bp;
+ --work;
+ --rwork;
+ --iwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 0;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*lda <= 1 || *lda < nmax) {
+ *info = -9;
+ } else if (*ldz <= 1 || *ldz < nmax) {
+ *info = -16;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = max(nmax,2);
+ if (i__1 * i__1 << 1 > *nwork) {
+ *info = -21;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = max(nmax,2);
+ if (i__1 * i__1 << 1 > *lrwork) {
+ *info = -23;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = max(nmax,2);
+ if (i__1 * i__1 << 1 > *liwork) {
+ *info = -25;
+ }
+ }
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZDRVSG", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = dlamch_("Safe minimum");
+ ovfl = dlamch_("Overflow");
+ dlabad_(&unfl, &ovfl);
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ ulpinv = 1. / ulp;
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed2[i__ - 1] = iseed[i__];
+/* L20: */
+ }
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ aninv = 1. / (doublereal) max(1,n);
+
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ ka9 = 0;
+ kb9 = 0;
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L640;
+ }
+ ++nmats;
+ ntest = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L30: */
+ }
+
+/* 2) Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, w/ eigenvalues */
+/* =5 random log hermitian, w/ eigenvalues */
+/* =6 random (none) */
+/* =7 random diagonal */
+/* =8 random hermitian */
+/* =9 banded, w/ eigenvalues */
+
+ if (mtypes > 21) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * aninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * n * ulpinv;
+ goto L70;
+
+L70:
+
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+ if (itype == 1) {
+
+/* Zero */
+
+ ka = 0;
+ kb = 0;
+ zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ ka = 0;
+ kb = 0;
+ zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ a[i__4].r = anorm, a[i__4].i = 0.;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ ka = 0;
+ kb = 0;
+ zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[
+ 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Hermitian, eigenvalues specified */
+
+/* Computing MAX */
+ i__3 = 0, i__4 = n - 1;
+ ka = max(i__3,i__4);
+ kb = ka;
+ zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[1], &
+ iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ ka = 0;
+ kb = 0;
+ zlatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &c_b33,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b33, &work[(
+ n << 1) + 1], &c__1, &c_b33, "N", idumma, &c__0, &
+ c__0, &c_b43, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Hermitian, random eigenvalues */
+
+/* Computing MAX */
+ i__3 = 0, i__4 = n - 1;
+ ka = max(i__3,i__4);
+ kb = ka;
+ zlatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &c_b33,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b33, &work[(
+ n << 1) + 1], &c__1, &c_b33, "N", idumma, &n, &n, &
+ c_b43, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* Hermitian banded, eigenvalues specified */
+
+/* The following values are used for the half-bandwidths: */
+
+/* ka = 1 kb = 1 */
+/* ka = 2 kb = 1 */
+/* ka = 2 kb = 2 */
+/* ka = 3 kb = 1 */
+/* ka = 3 kb = 2 */
+/* ka = 3 kb = 3 */
+
+ ++kb9;
+ if (kb9 > ka9) {
+ ++ka9;
+ kb9 = 1;
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__5 = n - 1;
+ i__3 = 0, i__4 = min(i__5,ka9);
+ ka = max(i__3,i__4);
+/* Computing MAX */
+/* Computing MIN */
+ i__5 = n - 1;
+ i__3 = 0, i__4 = min(i__5,kb9);
+ kb = max(i__3,i__4);
+ zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &ka, &ka, "N", &a[a_offset], lda, &work[1], &
+ iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___36.ciunit = *nounit;
+ s_wsfe(&io___36);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+ abstol = unfl + unfl;
+ if (n <= 1) {
+ il = 1;
+ iu = n;
+ } else {
+ il = (integer) ((n - 1) * dlarnd_(&c__1, iseed2) + 1);
+ iu = (integer) ((n - 1) * dlarnd_(&c__1, iseed2) + 1);
+ if (il > iu) {
+ itemp = il;
+ il = iu;
+ iu = itemp;
+ }
+ }
+
+/* 3) Call ZHEGV, ZHPGV, ZHBGV, CHEGVD, CHPGVD, CHBGVD, */
+/* ZHEGVX, ZHPGVX and ZHBGVX, do tests. */
+
+/* loop over the three generalized problems */
+/* IBTYPE = 1: A*x = (lambda)*B*x */
+/* IBTYPE = 2: A*B*x = (lambda)*x */
+/* IBTYPE = 3: B*A*x = (lambda)*x */
+
+ for (ibtype = 1; ibtype <= 3; ++ibtype) {
+
+/* loop over the setting UPLO */
+
+ for (ibuplo = 1; ibuplo <= 2; ++ibuplo) {
+ if (ibuplo == 1) {
+ *(unsigned char *)uplo = 'U';
+ }
+ if (ibuplo == 2) {
+ *(unsigned char *)uplo = 'L';
+ }
+
+/* Generate random well-conditioned positive definite */
+/* matrix B, of bandwidth not greater than that of A. */
+
+ zlatms_(&n, &n, "U", &iseed[1], "P", &rwork[1], &c__5, &
+ c_b78, &c_b33, &kb, &kb, uplo, &b[b_offset], ldb,
+ &work[n + 1], &iinfo);
+
+/* Test ZHEGV */
+
+ ++ntest;
+
+ zlacpy_(" ", &n, &n, &a[a_offset], lda, &z__[z_offset],
+ ldz);
+ zlacpy_(uplo, &n, &n, &b[b_offset], ldb, &bb[bb_offset],
+ ldb);
+
+ zhegv_(&ibtype, "V", uplo, &n, &z__[z_offset], ldz, &bb[
+ bb_offset], ldb, &d__[1], &work[1], nwork, &rwork[
+ 1], &iinfo);
+ if (iinfo != 0) {
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "ZHEGV(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L100;
+ }
+ }
+
+/* Do Test */
+
+ zsgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &rwork[1], &result[ntest]);
+
+/* Test ZHEGVD */
+
+ ++ntest;
+
+ zlacpy_(" ", &n, &n, &a[a_offset], lda, &z__[z_offset],
+ ldz);
+ zlacpy_(uplo, &n, &n, &b[b_offset], ldb, &bb[bb_offset],
+ ldb);
+
+ zhegvd_(&ibtype, "V", uplo, &n, &z__[z_offset], ldz, &bb[
+ bb_offset], ldb, &d__[1], &work[1], nwork, &rwork[
+ 1], lrwork, &iwork[1], liwork, &iinfo);
+ if (iinfo != 0) {
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "ZHEGVD(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__2, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L100;
+ }
+ }
+
+/* Do Test */
+
+ zsgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &rwork[1], &result[ntest]);
+
+/* Test ZHEGVX */
+
+ ++ntest;
+
+ zlacpy_(" ", &n, &n, &a[a_offset], lda, &ab[ab_offset],
+ lda);
+ zlacpy_(uplo, &n, &n, &b[b_offset], ldb, &bb[bb_offset],
+ ldb);
+
+ zhegvx_(&ibtype, "V", "A", uplo, &n, &ab[ab_offset], lda,
+ &bb[bb_offset], ldb, &vl, &vu, &il, &iu, &abstol,
+ &m, &d__[1], &z__[z_offset], ldz, &work[1], nwork,
+ &rwork[1], &iwork[n + 1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "ZHEGVX(V,A";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L100;
+ }
+ }
+
+/* Do Test */
+
+ zsgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &rwork[1], &result[ntest]);
+
+ ++ntest;
+
+ zlacpy_(" ", &n, &n, &a[a_offset], lda, &ab[ab_offset],
+ lda);
+ zlacpy_(uplo, &n, &n, &b[b_offset], ldb, &bb[bb_offset],
+ ldb);
+
+/* since we do not know the exact eigenvalues of this */
+/* eigenpair, we just set VL and VU as constants. */
+/* It is quite possible that there are no eigenvalues */
+/* in this interval. */
+
+ vl = 0.;
+ vu = anorm;
+ zhegvx_(&ibtype, "V", "V", uplo, &n, &ab[ab_offset], lda,
+ &bb[bb_offset], ldb, &vl, &vu, &il, &iu, &abstol,
+ &m, &d__[1], &z__[z_offset], ldz, &work[1], nwork,
+ &rwork[1], &iwork[n + 1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "ZHEGVX(V,V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__4, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__4, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L100;
+ }
+ }
+
+/* Do Test */
+
+ zsgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &rwork[1], &result[ntest]);
+
+ ++ntest;
+
+ zlacpy_(" ", &n, &n, &a[a_offset], lda, &ab[ab_offset],
+ lda);
+ zlacpy_(uplo, &n, &n, &b[b_offset], ldb, &bb[bb_offset],
+ ldb);
+
+ zhegvx_(&ibtype, "V", "I", uplo, &n, &ab[ab_offset], lda,
+ &bb[bb_offset], ldb, &vl, &vu, &il, &iu, &abstol,
+ &m, &d__[1], &z__[z_offset], ldz, &work[1], nwork,
+ &rwork[1], &iwork[n + 1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___51.ciunit = *nounit;
+ s_wsfe(&io___51);
+/* Writing concatenation */
+ i__6[0] = 11, a__1[0] = "ZHEGVX(V,I,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__4, a__1, i__6, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__4, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L100;
+ }
+ }
+
+/* Do Test */
+
+ zsgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &rwork[1], &result[ntest]);
+
+L100:
+
+/* Test ZHPGV */
+
+ ++ntest;
+
+/* Copy the matrices into packed storage. */
+
+ if (lsame_(uplo, "U")) {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ij;
+ i__7 = i__ + j * a_dim1;
+ ap[i__5].r = a[i__7].r, ap[i__5].i = a[i__7]
+ .i;
+ i__5 = ij;
+ i__7 = i__ + j * b_dim1;
+ bp[i__5].r = b[i__7].r, bp[i__5].i = b[i__7]
+ .i;
+ ++ij;
+/* L110: */
+ }
+/* L120: */
+ }
+ } else {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = ij;
+ i__7 = i__ + j * a_dim1;
+ ap[i__5].r = a[i__7].r, ap[i__5].i = a[i__7]
+ .i;
+ i__5 = ij;
+ i__7 = i__ + j * b_dim1;
+ bp[i__5].r = b[i__7].r, bp[i__5].i = b[i__7]
+ .i;
+ ++ij;
+/* L130: */
+ }
+/* L140: */
+ }
+ }
+
+ zhpgv_(&ibtype, "V", uplo, &n, &ap[1], &bp[1], &d__[1], &
+ z__[z_offset], ldz, &work[1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "ZHPGV(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L310;
+ }
+ }
+
+/* Do Test */
+
+ zsgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &rwork[1], &result[ntest]);
+
+/* Test ZHPGVD */
+
+ ++ntest;
+
+/* Copy the matrices into packed storage. */
+
+ if (lsame_(uplo, "U")) {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ij;
+ i__7 = i__ + j * a_dim1;
+ ap[i__5].r = a[i__7].r, ap[i__5].i = a[i__7]
+ .i;
+ i__5 = ij;
+ i__7 = i__ + j * b_dim1;
+ bp[i__5].r = b[i__7].r, bp[i__5].i = b[i__7]
+ .i;
+ ++ij;
+/* L150: */
+ }
+/* L160: */
+ }
+ } else {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = ij;
+ i__7 = i__ + j * a_dim1;
+ ap[i__5].r = a[i__7].r, ap[i__5].i = a[i__7]
+ .i;
+ i__5 = ij;
+ i__7 = i__ + j * b_dim1;
+ bp[i__5].r = b[i__7].r, bp[i__5].i = b[i__7]
+ .i;
+ ++ij;
+/* L170: */
+ }
+/* L180: */
+ }
+ }
+
+ zhpgvd_(&ibtype, "V", uplo, &n, &ap[1], &bp[1], &d__[1], &
+ z__[z_offset], ldz, &work[1], nwork, &rwork[1],
+ lrwork, &iwork[1], liwork, &iinfo);
+ if (iinfo != 0) {
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "ZHPGVD(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__2, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L310;
+ }
+ }
+
+/* Do Test */
+
+ zsgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &rwork[1], &result[ntest]);
+
+/* Test ZHPGVX */
+
+ ++ntest;
+
+/* Copy the matrices into packed storage. */
+
+ if (lsame_(uplo, "U")) {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ij;
+ i__7 = i__ + j * a_dim1;
+ ap[i__5].r = a[i__7].r, ap[i__5].i = a[i__7]
+ .i;
+ i__5 = ij;
+ i__7 = i__ + j * b_dim1;
+ bp[i__5].r = b[i__7].r, bp[i__5].i = b[i__7]
+ .i;
+ ++ij;
+/* L190: */
+ }
+/* L200: */
+ }
+ } else {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = ij;
+ i__7 = i__ + j * a_dim1;
+ ap[i__5].r = a[i__7].r, ap[i__5].i = a[i__7]
+ .i;
+ i__5 = ij;
+ i__7 = i__ + j * b_dim1;
+ bp[i__5].r = b[i__7].r, bp[i__5].i = b[i__7]
+ .i;
+ ++ij;
+/* L210: */
+ }
+/* L220: */
+ }
+ }
+
+ zhpgvx_(&ibtype, "V", "A", uplo, &n, &ap[1], &bp[1], &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &rwork[1], &iwork[n + 1]
+, &iwork[1], info);
+ if (iinfo != 0) {
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "ZHPGVX(V,A";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L310;
+ }
+ }
+
+/* Do Test */
+
+ zsgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &rwork[1], &result[ntest]);
+
+ ++ntest;
+
+/* Copy the matrices into packed storage. */
+
+ if (lsame_(uplo, "U")) {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ij;
+ i__7 = i__ + j * a_dim1;
+ ap[i__5].r = a[i__7].r, ap[i__5].i = a[i__7]
+ .i;
+ i__5 = ij;
+ i__7 = i__ + j * b_dim1;
+ bp[i__5].r = b[i__7].r, bp[i__5].i = b[i__7]
+ .i;
+ ++ij;
+/* L230: */
+ }
+/* L240: */
+ }
+ } else {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = ij;
+ i__7 = i__ + j * a_dim1;
+ ap[i__5].r = a[i__7].r, ap[i__5].i = a[i__7]
+ .i;
+ i__5 = ij;
+ i__7 = i__ + j * b_dim1;
+ bp[i__5].r = b[i__7].r, bp[i__5].i = b[i__7]
+ .i;
+ ++ij;
+/* L250: */
+ }
+/* L260: */
+ }
+ }
+
+ vl = 0.;
+ vu = anorm;
+ zhpgvx_(&ibtype, "V", "V", uplo, &n, &ap[1], &bp[1], &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &rwork[1], &iwork[n + 1]
+, &iwork[1], info);
+ if (iinfo != 0) {
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "ZHPGVX(V,V";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L310;
+ }
+ }
+
+/* Do Test */
+
+ zsgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &rwork[1], &result[ntest]);
+
+ ++ntest;
+
+/* Copy the matrices into packed storage. */
+
+ if (lsame_(uplo, "U")) {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ij;
+ i__7 = i__ + j * a_dim1;
+ ap[i__5].r = a[i__7].r, ap[i__5].i = a[i__7]
+ .i;
+ i__5 = ij;
+ i__7 = i__ + j * b_dim1;
+ bp[i__5].r = b[i__7].r, bp[i__5].i = b[i__7]
+ .i;
+ ++ij;
+/* L270: */
+ }
+/* L280: */
+ }
+ } else {
+ ij = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = ij;
+ i__7 = i__ + j * a_dim1;
+ ap[i__5].r = a[i__7].r, ap[i__5].i = a[i__7]
+ .i;
+ i__5 = ij;
+ i__7 = i__ + j * b_dim1;
+ bp[i__5].r = b[i__7].r, bp[i__5].i = b[i__7]
+ .i;
+ ++ij;
+/* L290: */
+ }
+/* L300: */
+ }
+ }
+
+ zhpgvx_(&ibtype, "V", "I", uplo, &n, &ap[1], &bp[1], &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &rwork[1], &iwork[n + 1]
+, &iwork[1], info);
+ if (iinfo != 0) {
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "ZHPGVX(V,I";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L310;
+ }
+ }
+
+/* Do Test */
+
+ zsgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1], &
+ work[1], &rwork[1], &result[ntest]);
+
+L310:
+
+ if (ibtype == 1) {
+
+/* TEST ZHBGV */
+
+ ++ntest;
+
+/* Copy the matrices into band storage. */
+
+ if (lsame_(uplo, "U")) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - ka;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__)
+ {
+ i__4 = ka + 1 + i__ - j + j * ab_dim1;
+ i__5 = i__ + j * a_dim1;
+ ab[i__4].r = a[i__5].r, ab[i__4].i = a[
+ i__5].i;
+/* L320: */
+ }
+/* Computing MAX */
+ i__7 = 1, i__4 = j - kb;
+ i__5 = j;
+ for (i__ = max(i__7,i__4); i__ <= i__5; ++i__)
+ {
+ i__7 = kb + 1 + i__ - j + j * bb_dim1;
+ i__4 = i__ + j * b_dim1;
+ bb[i__7].r = b[i__4].r, bb[i__7].i = b[
+ i__4].i;
+/* L330: */
+ }
+/* L340: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__7 = n, i__4 = j + ka;
+ i__5 = min(i__7,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ i__7 = i__ + 1 - j + j * ab_dim1;
+ i__4 = i__ + j * a_dim1;
+ ab[i__7].r = a[i__4].r, ab[i__7].i = a[
+ i__4].i;
+/* L350: */
+ }
+/* Computing MIN */
+ i__7 = n, i__4 = j + kb;
+ i__5 = min(i__7,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ i__7 = i__ + 1 - j + j * bb_dim1;
+ i__4 = i__ + j * b_dim1;
+ bb[i__7].r = b[i__4].r, bb[i__7].i = b[
+ i__4].i;
+/* L360: */
+ }
+/* L370: */
+ }
+ }
+
+ zhbgv_("V", uplo, &n, &ka, &kb, &ab[ab_offset], lda, &
+ bb[bb_offset], ldb, &d__[1], &z__[z_offset],
+ ldz, &work[1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+/* Writing concatenation */
+ i__6[0] = 8, a__1[0] = "ZHBGV(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__1, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L620;
+ }
+ }
+
+/* Do Test */
+
+ zsgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1],
+ &work[1], &rwork[1], &result[ntest]);
+
+/* TEST ZHBGVD */
+
+ ++ntest;
+
+/* Copy the matrices into band storage. */
+
+ if (lsame_(uplo, "U")) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__7 = j - ka;
+ i__4 = j;
+ for (i__ = max(i__5,i__7); i__ <= i__4; ++i__)
+ {
+ i__5 = ka + 1 + i__ - j + j * ab_dim1;
+ i__7 = i__ + j * a_dim1;
+ ab[i__5].r = a[i__7].r, ab[i__5].i = a[
+ i__7].i;
+/* L380: */
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kb;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__)
+ {
+ i__4 = kb + 1 + i__ - j + j * bb_dim1;
+ i__5 = i__ + j * b_dim1;
+ bb[i__4].r = b[i__5].r, bb[i__4].i = b[
+ i__5].i;
+/* L390: */
+ }
+/* L400: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + ka;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ i__4 = i__ + 1 - j + j * ab_dim1;
+ i__5 = i__ + j * a_dim1;
+ ab[i__4].r = a[i__5].r, ab[i__4].i = a[
+ i__5].i;
+/* L410: */
+ }
+/* Computing MIN */
+ i__4 = n, i__5 = j + kb;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ i__4 = i__ + 1 - j + j * bb_dim1;
+ i__5 = i__ + j * b_dim1;
+ bb[i__4].r = b[i__5].r, bb[i__4].i = b[
+ i__5].i;
+/* L420: */
+ }
+/* L430: */
+ }
+ }
+
+ zhbgvd_("V", uplo, &n, &ka, &kb, &ab[ab_offset], lda,
+ &bb[bb_offset], ldb, &d__[1], &z__[z_offset],
+ ldz, &work[1], nwork, &rwork[1], lrwork, &
+ iwork[1], liwork, &iinfo);
+ if (iinfo != 0) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+/* Writing concatenation */
+ i__6[0] = 9, a__1[0] = "ZHBGVD(V,";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__6, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__2, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L620;
+ }
+ }
+
+/* Do Test */
+
+ zsgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1],
+ &work[1], &rwork[1], &result[ntest]);
+
+/* Test ZHBGVX */
+
+ ++ntest;
+
+/* Copy the matrices into band storage. */
+
+ if (lsame_(uplo, "U")) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__7 = 1, i__4 = j - ka;
+ i__5 = j;
+ for (i__ = max(i__7,i__4); i__ <= i__5; ++i__)
+ {
+ i__7 = ka + 1 + i__ - j + j * ab_dim1;
+ i__4 = i__ + j * a_dim1;
+ ab[i__7].r = a[i__4].r, ab[i__7].i = a[
+ i__4].i;
+/* L440: */
+ }
+/* Computing MAX */
+ i__5 = 1, i__7 = j - kb;
+ i__4 = j;
+ for (i__ = max(i__5,i__7); i__ <= i__4; ++i__)
+ {
+ i__5 = kb + 1 + i__ - j + j * bb_dim1;
+ i__7 = i__ + j * b_dim1;
+ bb[i__5].r = b[i__7].r, bb[i__5].i = b[
+ i__7].i;
+/* L450: */
+ }
+/* L460: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__5 = n, i__7 = j + ka;
+ i__4 = min(i__5,i__7);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = i__ + 1 - j + j * ab_dim1;
+ i__7 = i__ + j * a_dim1;
+ ab[i__5].r = a[i__7].r, ab[i__5].i = a[
+ i__7].i;
+/* L470: */
+ }
+/* Computing MIN */
+ i__5 = n, i__7 = j + kb;
+ i__4 = min(i__5,i__7);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = i__ + 1 - j + j * bb_dim1;
+ i__7 = i__ + j * b_dim1;
+ bb[i__5].r = b[i__7].r, bb[i__5].i = b[
+ i__7].i;
+/* L480: */
+ }
+/* L490: */
+ }
+ }
+
+ i__3 = max(1,n);
+ zhbgvx_("V", "A", uplo, &n, &ka, &kb, &ab[ab_offset],
+ lda, &bb[bb_offset], ldb, &bp[1], &i__3, &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &rwork[1], &iwork[n
+ + 1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___60.ciunit = *nounit;
+ s_wsfe(&io___60);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "ZHBGVX(V,A";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L620;
+ }
+ }
+
+/* Do Test */
+
+ zsgt01_(&ibtype, uplo, &n, &n, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1],
+ &work[1], &rwork[1], &result[ntest]);
+
+ ++ntest;
+
+/* Copy the matrices into band storage. */
+
+ if (lsame_(uplo, "U")) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - ka;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__)
+ {
+ i__4 = ka + 1 + i__ - j + j * ab_dim1;
+ i__5 = i__ + j * a_dim1;
+ ab[i__4].r = a[i__5].r, ab[i__4].i = a[
+ i__5].i;
+/* L500: */
+ }
+/* Computing MAX */
+ i__7 = 1, i__4 = j - kb;
+ i__5 = j;
+ for (i__ = max(i__7,i__4); i__ <= i__5; ++i__)
+ {
+ i__7 = kb + 1 + i__ - j + j * bb_dim1;
+ i__4 = i__ + j * b_dim1;
+ bb[i__7].r = b[i__4].r, bb[i__7].i = b[
+ i__4].i;
+/* L510: */
+ }
+/* L520: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__7 = n, i__4 = j + ka;
+ i__5 = min(i__7,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ i__7 = i__ + 1 - j + j * ab_dim1;
+ i__4 = i__ + j * a_dim1;
+ ab[i__7].r = a[i__4].r, ab[i__7].i = a[
+ i__4].i;
+/* L530: */
+ }
+/* Computing MIN */
+ i__7 = n, i__4 = j + kb;
+ i__5 = min(i__7,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ i__7 = i__ + 1 - j + j * bb_dim1;
+ i__4 = i__ + j * b_dim1;
+ bb[i__7].r = b[i__4].r, bb[i__7].i = b[
+ i__4].i;
+/* L540: */
+ }
+/* L550: */
+ }
+ }
+
+ vl = 0.;
+ vu = anorm;
+ i__3 = max(1,n);
+ zhbgvx_("V", "V", uplo, &n, &ka, &kb, &ab[ab_offset],
+ lda, &bb[bb_offset], ldb, &bp[1], &i__3, &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &rwork[1], &iwork[n
+ + 1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___61.ciunit = *nounit;
+ s_wsfe(&io___61);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "ZHBGVX(V,V";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L620;
+ }
+ }
+
+/* Do Test */
+
+ zsgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1],
+ &work[1], &rwork[1], &result[ntest]);
+
+ ++ntest;
+
+/* Copy the matrices into band storage. */
+
+ if (lsame_(uplo, "U")) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__7 = j - ka;
+ i__4 = j;
+ for (i__ = max(i__5,i__7); i__ <= i__4; ++i__)
+ {
+ i__5 = ka + 1 + i__ - j + j * ab_dim1;
+ i__7 = i__ + j * a_dim1;
+ ab[i__5].r = a[i__7].r, ab[i__5].i = a[
+ i__7].i;
+/* L560: */
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kb;
+ i__7 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__7; ++i__)
+ {
+ i__4 = kb + 1 + i__ - j + j * bb_dim1;
+ i__5 = i__ + j * b_dim1;
+ bb[i__4].r = b[i__5].r, bb[i__4].i = b[
+ i__5].i;
+/* L570: */
+ }
+/* L580: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + ka;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ i__4 = i__ + 1 - j + j * ab_dim1;
+ i__5 = i__ + j * a_dim1;
+ ab[i__4].r = a[i__5].r, ab[i__4].i = a[
+ i__5].i;
+/* L590: */
+ }
+/* Computing MIN */
+ i__4 = n, i__5 = j + kb;
+ i__7 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__7; ++i__) {
+ i__4 = i__ + 1 - j + j * bb_dim1;
+ i__5 = i__ + j * b_dim1;
+ bb[i__4].r = b[i__5].r, bb[i__4].i = b[
+ i__5].i;
+/* L600: */
+ }
+/* L610: */
+ }
+ }
+
+ i__3 = max(1,n);
+ zhbgvx_("V", "I", uplo, &n, &ka, &kb, &ab[ab_offset],
+ lda, &bb[bb_offset], ldb, &bp[1], &i__3, &vl,
+ &vu, &il, &iu, &abstol, &m, &d__[1], &z__[
+ z_offset], ldz, &work[1], &rwork[1], &iwork[n
+ + 1], &iwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___62.ciunit = *nounit;
+ s_wsfe(&io___62);
+/* Writing concatenation */
+ i__6[0] = 10, a__1[0] = "ZHBGVX(V,I";
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__6, &c__3, (ftnlen)12);
+ do_fio(&c__1, ch__3, (ftnlen)12);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L620;
+ }
+ }
+
+/* Do Test */
+
+ zsgt01_(&ibtype, uplo, &n, &m, &a[a_offset], lda, &b[
+ b_offset], ldb, &z__[z_offset], ldz, &d__[1],
+ &work[1], &rwork[1], &result[ntest]);
+
+ }
+
+L620:
+ ;
+ }
+/* L630: */
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+ ntestt += ntest;
+ dlafts_("ZSG", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh,
+ nounit, &nerrs);
+L640:
+ ;
+ }
+/* L650: */
+ }
+
+/* Summary */
+
+ dlasum_("ZSG", nounit, &nerrs, &ntestt);
+
+ return 0;
+
+
+/* End of ZDRVSG */
+
+} /* zdrvsg_ */
diff --git a/TESTING/EIG/zdrvst.c b/TESTING/EIG/zdrvst.c
new file mode 100644
index 0000000..def4f45
--- /dev/null
+++ b/TESTING/EIG/zdrvst.c
@@ -0,0 +1,3201 @@
+/* zdrvst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__6 = 6;
+static doublereal c_b34 = 1.;
+static integer c__1 = 1;
+static doublereal c_b44 = 0.;
+static integer c__4 = 4;
+static integer c__3 = 3;
+
+/* Subroutine */ int zdrvst_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
+ doublecomplex *a, integer *lda, doublereal *d1, doublereal *d2,
+ doublereal *d3, doublereal *wa1, doublereal *wa2, doublereal *wa3,
+ doublecomplex *u, integer *ldu, doublecomplex *v, doublecomplex *tau,
+ doublecomplex *z__, doublecomplex *work, integer *lwork, doublereal *
+ rwork, integer *lrwork, integer *iwork, integer *liwork, doublereal *
+ result, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[18] = { 1,2,4,4,4,4,4,5,5,5,5,5,8,8,8,9,9,9 };
+ static integer kmagn[18] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3,1,2,3 };
+ static integer kmode[18] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0,4,4,4 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 ZDRVST: \002,a,\002 returned INFO=\002,i"
+ "6,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED=(\002,3(i5"
+ ",\002,\002),i5,\002)\002)";
+ static char fmt_9998[] = "(\002 ZDRVST: \002,a,\002 returned INFO=\002,i"
+ "6,/9x,\002N=\002,i6,\002, KD=\002,i6,\002, JTYPE=\002,i6,\002, I"
+ "SEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+
+ /* System generated locals */
+ address a__1[3];
+ integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, z_dim1,
+ z_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7[3];
+ doublereal d__1, d__2, d__3, d__4;
+ char ch__1[11], ch__2[13], ch__3[10];
+
+ /* Builtin functions */
+ double sqrt(doublereal), log(doublereal);
+ integer pow_ii(integer *, integer *), s_wsfe(cilist *), do_fio(integer *,
+ char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, m, n, j1, j2, m2, m3, kd, il, iu;
+ doublereal vl, vu;
+ integer lgn;
+ doublereal ulp, cond;
+ integer jcol, ihbw, indx, nmax;
+ doublereal unfl, ovfl;
+ char uplo[1];
+ integer irow;
+ doublereal temp1, temp2, temp3;
+ extern doublereal dsxt1_(integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *);
+ integer idiag;
+ logical badnn;
+ integer imode, lwedc, iinfo;
+ doublereal aninv, anorm;
+ extern /* Subroutine */ int zhet21_(integer *, char *, integer *, integer
+ *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublereal *, doublereal *);
+ integer itemp;
+ extern /* Subroutine */ int zhbev_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ integer *, doublecomplex *, doublereal *, integer *), zhet22_(integer *, char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublereal *, doublereal *), zheev_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublecomplex *, integer *, doublereal *,
+ integer *);
+ integer nmats, jsize, iuplo, nerrs, itype, jtype, ntest;
+ extern /* Subroutine */ int zhpev_(char *, char *, integer *,
+ doublecomplex *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, doublereal *, integer *);
+ integer iseed2[4], iseed3[4];
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *), dlarnd_(integer *, integer *);
+ integer liwedc, idumma[1];
+ extern /* Subroutine */ int dlafts_(char *, integer *, integer *, integer
+ *, integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer lrwedc;
+ extern /* Subroutine */ int zhbevd_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, integer *,
+ integer *, integer *, integer *), alasvm_(char *,
+ integer *, integer *, integer *, integer *);
+ doublereal abstol;
+ extern /* Subroutine */ int zheevd_(char *, char *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ integer *, doublereal *, integer *, integer *, integer *, integer
+ *);
+ integer indwrk;
+ extern /* Subroutine */ int zhpevd_(char *, char *, integer *,
+ doublecomplex *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, integer *, integer *,
+ integer *, integer *), zlacpy_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *), zheevr_(char *, char *, char *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublecomplex *
+, integer *, integer *, doublecomplex *, integer *, doublereal *,
+ integer *, integer *, integer *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *), zhbevx_(
+ char *, char *, char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, doublereal *,
+ integer *, integer *, integer *), zheevx_(
+ char *, char *, char *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, integer *, integer *,
+ integer *);
+ doublereal rtunfl, rtovfl, ulpinv;
+ integer mtypes, ntestt;
+ extern /* Subroutine */ int zhpevx_(char *, char *, char *, integer *,
+ doublecomplex *, doublereal *, doublereal *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublecomplex *, integer *
+, doublecomplex *, doublereal *, integer *, integer *, integer *), zlatmr_(integer *, integer *, char *,
+ integer *, char *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, char *, char *, doublecomplex *, integer *,
+ doublereal *, doublecomplex *, integer *, doublereal *, char *,
+ integer *, integer *, integer *, doublereal *, doublereal *, char
+ *, doublecomplex *, integer *, integer *, integer *), zlatms_(integer *,
+ integer *, char *, integer *, char *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *, char *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___68 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___69 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___70 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___71 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___72 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___73 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___74 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___76 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___77 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___80 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___81 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___82 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___83 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___84 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___85 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___86 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___87 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___88 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___89 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___90 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___91 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___92 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___93 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___94 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___95 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVST checks the Hermitian eigenvalue problem drivers. */
+
+/* ZHEEVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian matrix, */
+/* using a divide-and-conquer algorithm. */
+
+/* ZHEEVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian matrix. */
+
+/* ZHEEVR computes selected eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian matrix */
+/* using the Relatively Robust Representation where it can. */
+
+/* ZHPEVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian matrix in packed */
+/* storage, using a divide-and-conquer algorithm. */
+
+/* ZHPEVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian matrix in packed */
+/* storage. */
+
+/* ZHBEVD computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian band matrix, */
+/* using a divide-and-conquer algorithm. */
+
+/* ZHBEVX computes selected eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian band matrix. */
+
+/* ZHEEV computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian matrix. */
+
+/* ZHPEV computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian matrix in packed */
+/* storage. */
+
+/* ZHBEV computes all eigenvalues and, optionally, */
+/* eigenvectors of a complex Hermitian band matrix. */
+
+/* When ZDRVST is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the appropriate drivers. For each matrix and each */
+/* driver routine called, the following tests will be performed: */
+
+/* (1) | A - Z D Z' | / ( |A| n ulp ) */
+
+/* (2) | I - Z Z' | / ( n ulp ) */
+
+/* (3) | D1 - D2 | / ( |D1| ulp ) */
+
+/* where Z is the matrix of eigenvectors returned when the */
+/* eigenvector option is given and D1 and D2 are the eigenvalues */
+/* returned with and without the eigenvector option. */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+
+/* (3) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (4) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random signs. */
+/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random signs. */
+
+/* (6) Same as (4), but multiplied by SQRT( overflow threshold ) */
+/* (7) Same as (4), but multiplied by SQRT( underflow threshold ) */
+
+/* (8) A matrix of the form U* D U, where U is unitary and */
+/* D has evenly spaced entries 1, ..., ULP with random signs */
+/* on the diagonal. */
+
+/* (9) A matrix of the form U* D U, where U is unitary and */
+/* D has geometrically spaced entries 1, ..., ULP with random */
+/* signs on the diagonal. */
+
+/* (10) A matrix of the form U* D U, where U is unitary and */
+/* D has "clustered" entries 1, ULP,..., ULP with random */
+/* signs on the diagonal. */
+
+/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
+/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
+
+/* (13) Symmetric matrix with random entries chosen from (-1,1). */
+/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
+/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
+/* (16) A band matrix with half bandwidth randomly chosen between */
+/* 0 and N-1, with evenly spaced eigenvalues 1, ..., ULP */
+/* with random signs. */
+/* (17) Same as (16), but multiplied by SQRT( overflow threshold ) */
+/* (18) Same as (16), but multiplied by SQRT( underflow threshold ) */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES INTEGER */
+/* The number of sizes of matrices to use. If it is zero, */
+/* ZDRVST does nothing. It must be at least zero. */
+/* Not modified. */
+
+/* NN INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+/* Not modified. */
+
+/* NTYPES INTEGER */
+/* The number of elements in DOTYPE. If it is zero, ZDRVST */
+/* does nothing. It must be at least zero. If it is MAXTYP+1 */
+/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
+/* defined, which is to use whatever matrix is in A. This */
+/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
+/* DOTYPE(MAXTYP+1) is .TRUE. . */
+/* Not modified. */
+
+/* DOTYPE LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+/* Not modified. */
+
+/* ISEED INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to ZDRVST to continue the same random number */
+/* sequence. */
+/* Modified. */
+
+/* THRESH DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+/* Not modified. */
+
+/* NOUNIT INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns IINFO not equal to 0.) */
+/* Not modified. */
+
+/* A COMPLEX*16 array, dimension (LDA , max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually */
+/* used. */
+/* Modified. */
+
+/* LDA INTEGER */
+/* The leading dimension of A. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* D1 DOUBLE PRECISION array, dimension (max(NN)) */
+/* The eigenvalues of A, as computed by ZSTEQR simlutaneously */
+/* with Z. On exit, the eigenvalues in D1 correspond with the */
+/* matrix in A. */
+/* Modified. */
+
+/* D2 DOUBLE PRECISION array, dimension (max(NN)) */
+/* The eigenvalues of A, as computed by ZSTEQR if Z is not */
+/* computed. On exit, the eigenvalues in D2 correspond with */
+/* the matrix in A. */
+/* Modified. */
+
+/* D3 DOUBLE PRECISION array, dimension (max(NN)) */
+/* The eigenvalues of A, as computed by DSTERF. On exit, the */
+/* eigenvalues in D3 correspond with the matrix in A. */
+/* Modified. */
+
+/* WA1 DOUBLE PRECISION array, dimension */
+
+/* WA2 DOUBLE PRECISION array, dimension */
+
+/* WA3 DOUBLE PRECISION array, dimension */
+
+/* U COMPLEX*16 array, dimension (LDU, max(NN)) */
+/* The unitary matrix computed by ZHETRD + ZUNGC3. */
+/* Modified. */
+
+/* LDU INTEGER */
+/* The leading dimension of U, Z, and V. It must be at */
+/* least 1 and at least max( NN ). */
+/* Not modified. */
+
+/* V COMPLEX*16 array, dimension (LDU, max(NN)) */
+/* The Housholder vectors computed by ZHETRD in reducing A to */
+/* tridiagonal form. */
+/* Modified. */
+
+/* TAU COMPLEX*16 array, dimension (max(NN)) */
+/* The Householder factors computed by ZHETRD in reducing A */
+/* to tridiagonal form. */
+/* Modified. */
+
+/* Z COMPLEX*16 array, dimension (LDU, max(NN)) */
+/* The unitary matrix of eigenvectors computed by ZHEEVD, */
+/* ZHEEVX, ZHPEVD, CHPEVX, ZHBEVD, and CHBEVX. */
+/* Modified. */
+
+/* WORK - COMPLEX*16 array of dimension ( LWORK ) */
+/* Workspace. */
+/* Modified. */
+
+/* LWORK - INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 2*max( NN(j), 2 )**2. */
+/* Not modified. */
+
+/* RWORK DOUBLE PRECISION array, dimension (3*max(NN)) */
+/* Workspace. */
+/* Modified. */
+
+/* LRWORK - INTEGER */
+/* The number of entries in RWORK. */
+
+/* IWORK INTEGER array, dimension (6*max(NN)) */
+/* Workspace. */
+/* Modified. */
+
+/* LIWORK - INTEGER */
+/* The number of entries in IWORK. */
+
+/* RESULT DOUBLE PRECISION array, dimension (??) */
+/* The values computed by the tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+/* Modified. */
+
+/* INFO INTEGER */
+/* If 0, then everything ran OK. */
+/* -1: NSIZES < 0 */
+/* -2: Some NN(j) < 0 */
+/* -3: NTYPES < 0 */
+/* -5: THRESH < 0 */
+/* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). */
+/* -16: LDU < 1 or LDU < NMAX. */
+/* -21: LWORK too small. */
+/* If DLATMR, SLATMS, ZHETRD, DORGC3, ZSTEQR, DSTERF, */
+/* or DORMC2 returns an error code, the */
+/* absolute value of it is returned. */
+/* Modified. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NTEST The number of tests performed, or which can */
+/* be performed so far, for the current matrix. */
+/* NTESTT The total number of tests performed so far. */
+/* NMAX Largest value in NN. */
+/* NMATS The number of matrices generated so far. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* so far (computed by DLAFTS). */
+/* COND, IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+
+/* ===================================================================== */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d1;
+ --d2;
+ --d3;
+ --wa1;
+ --wa2;
+ --wa3;
+ z_dim1 = *ldu;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ v_dim1 = *ldu;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --tau;
+ --work;
+ --rwork;
+ --iwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Check for errors */
+
+ ntestt = 0;
+ *info = 0;
+
+ badnn = FALSE_;
+ nmax = 1;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*lda < nmax) {
+ *info = -9;
+ } else if (*ldu < nmax) {
+ *info = -16;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = max(2,nmax);
+ if (i__1 * i__1 << 1 > *lwork) {
+ *info = -22;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZDRVST", &i__1);
+ return 0;
+ }
+
+/* Quick return if nothing to do */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ unfl = dlamch_("Safe minimum");
+ ovfl = dlamch_("Overflow");
+ dlabad_(&unfl, &ovfl);
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ ulpinv = 1. / ulp;
+ rtunfl = sqrt(unfl);
+ rtovfl = sqrt(ovfl);
+
+/* Loop over sizes, types */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed2[i__ - 1] = iseed[i__];
+ iseed3[i__ - 1] = iseed[i__];
+/* L20: */
+ }
+
+ nerrs = 0;
+ nmats = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (n > 0) {
+ lgn = (integer) (log((doublereal) n) / log(2.));
+ if (pow_ii(&c__2, &lgn) < n) {
+ ++lgn;
+ }
+ if (pow_ii(&c__2, &lgn) < n) {
+ ++lgn;
+ }
+/* Computing MAX */
+ i__2 = (n << 1) + n * n, i__3 = (n << 1) * n;
+ lwedc = max(i__2,i__3);
+/* Computing 2nd power */
+ i__2 = n;
+ lrwedc = (n << 2) + 1 + (n << 1) * lgn + i__2 * i__2 * 3;
+ liwedc = n * 5 + 3;
+ } else {
+ lwedc = 2;
+ lrwedc = 8;
+ liwedc = 8;
+ }
+ aninv = 1. / (doublereal) max(1,n);
+
+ if (*nsizes != 1) {
+ mtypes = min(18,*ntypes);
+ } else {
+ mtypes = min(19,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L1210;
+ }
+ ++nmats;
+ ntest = 0;
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L30: */
+ }
+
+/* 2) Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KMODE KTYPE */
+/* =1 O(1) clustered 1 zero */
+/* =2 large clustered 2 identity */
+/* =3 small exponential (none) */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log Hermitian, w/ eigenvalues */
+/* =6 random (none) */
+/* =7 random diagonal */
+/* =8 random Hermitian */
+/* =9 band Hermitian, w/ eigenvalues */
+
+ if (mtypes > 18) {
+ goto L110;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L40;
+ case 2: goto L50;
+ case 3: goto L60;
+ }
+
+L40:
+ anorm = 1.;
+ goto L70;
+
+L50:
+ anorm = rtovfl * ulp * aninv;
+ goto L70;
+
+L60:
+ anorm = rtunfl * n * ulpinv;
+ goto L70;
+
+L70:
+
+ zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ a[i__4].r = anorm, a[i__4].i = 0.;
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[
+ 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Hermitian, eigenvalues specified */
+
+ zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[1], &
+ iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ zlatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &c_b34,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b34, &work[(
+ n << 1) + 1], &c__1, &c_b34, "N", idumma, &c__0, &
+ c__0, &c_b44, &anorm, "NO", &a[a_offset], lda, &iwork[
+ 1], &iinfo);
+
+ } else if (itype == 8) {
+
+/* Hermitian, random eigenvalues */
+
+ zlatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &c_b34,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b34, &work[(
+ n << 1) + 1], &c__1, &c_b34, "N", idumma, &n, &n, &
+ c_b44, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* Hermitian banded, eigenvalues specified */
+
+ ihbw = (integer) ((n - 1) * dlarnd_(&c__1, iseed3));
+ zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &ihbw, &ihbw, "Z", &u[u_offset], ldu, &work[
+ 1], &iinfo);
+
+/* Store as dense matrix for most routines. */
+
+ zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ i__3 = ihbw;
+ for (idiag = -ihbw; idiag <= i__3; ++idiag) {
+ irow = ihbw - idiag + 1;
+/* Computing MAX */
+ i__4 = 1, i__5 = idiag + 1;
+ j1 = max(i__4,i__5);
+/* Computing MIN */
+ i__4 = n, i__5 = n + idiag;
+ j2 = min(i__4,i__5);
+ i__4 = j2;
+ for (j = j1; j <= i__4; ++j) {
+ i__ = j - idiag;
+ i__5 = i__ + j * a_dim1;
+ i__6 = irow + j * u_dim1;
+ a[i__5].r = u[i__6].r, a[i__5].i = u[i__6].i;
+/* L90: */
+ }
+/* L100: */
+ }
+ } else {
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L110:
+
+ abstol = unfl + unfl;
+ if (n <= 1) {
+ il = 1;
+ iu = n;
+ } else {
+ il = (integer) ((n - 1) * dlarnd_(&c__1, iseed2)) + 1;
+ iu = (integer) ((n - 1) * dlarnd_(&c__1, iseed2)) + 1;
+ if (il > iu) {
+ itemp = il;
+ il = iu;
+ iu = itemp;
+ }
+ }
+
+/* Perform tests storing upper or lower triangular */
+/* part of matrix. */
+
+ for (iuplo = 0; iuplo <= 1; ++iuplo) {
+ if (iuplo == 0) {
+ *(unsigned char *)uplo = 'L';
+ } else {
+ *(unsigned char *)uplo = 'U';
+ }
+
+/* Call ZHEEVD and CHEEVX. */
+
+ zlacpy_(" ", &n, &n, &a[a_offset], lda, &v[v_offset], ldu);
+
+ ++ntest;
+ zheevd_("V", uplo, &n, &a[a_offset], ldu, &d1[1], &work[1], &
+ lwedc, &rwork[1], &lrwedc, &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___49.ciunit = *nounit;
+ s_wsfe(&io___49);
+/* Writing concatenation */
+ i__7[0] = 9, a__1[0] = "ZHEEVD(V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__7, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__1, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L130;
+ }
+ }
+
+/* Do tests 1 and 2. */
+
+ zhet21_(&c__1, uplo, &n, &c__0, &v[v_offset], ldu, &d1[1], &
+ d2[1], &a[a_offset], ldu, &z__[z_offset], ldu, &tau[1]
+, &work[1], &rwork[1], &result[ntest]);
+
+ zlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ ntest += 2;
+ zheevd_("N", uplo, &n, &a[a_offset], ldu, &d3[1], &work[1], &
+ lwedc, &rwork[1], &lrwedc, &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___50.ciunit = *nounit;
+ s_wsfe(&io___50);
+/* Writing concatenation */
+ i__7[0] = 9, a__1[0] = "ZHEEVD(N,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__7, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__1, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L130;
+ }
+ }
+
+/* Do test 3. */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = d3[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d1[j] - d3[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L120: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[ntest] = temp2 / max(d__1,d__2);
+
+L130:
+ zlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ ++ntest;
+
+ if (n > 0) {
+/* Computing MAX */
+ d__2 = abs(d1[1]), d__3 = (d__1 = d1[n], abs(d__1));
+ temp3 = max(d__2,d__3);
+ if (il != 1) {
+/* Computing MAX */
+ d__1 = (d1[il] - d1[il - 1]) * .5, d__2 = ulp * 10. *
+ temp3, d__1 = max(d__1,d__2), d__2 = rtunfl *
+ 10.;
+ vl = d1[il] - max(d__1,d__2);
+ } else if (n > 0) {
+/* Computing MAX */
+ d__1 = (d1[n] - d1[1]) * .5, d__2 = ulp * 10. * temp3,
+ d__1 = max(d__1,d__2), d__2 = rtunfl * 10.;
+ vl = d1[1] - max(d__1,d__2);
+ }
+ if (iu != n) {
+/* Computing MAX */
+ d__1 = (d1[iu + 1] - d1[iu]) * .5, d__2 = ulp * 10. *
+ temp3, d__1 = max(d__1,d__2), d__2 = rtunfl *
+ 10.;
+ vu = d1[iu] + max(d__1,d__2);
+ } else if (n > 0) {
+/* Computing MAX */
+ d__1 = (d1[n] - d1[1]) * .5, d__2 = ulp * 10. * temp3,
+ d__1 = max(d__1,d__2), d__2 = rtunfl * 10.;
+ vu = d1[n] + max(d__1,d__2);
+ }
+ } else {
+ temp3 = 0.;
+ vl = 0.;
+ vu = 1.;
+ }
+
+ zheevx_("V", "A", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m, &wa1[1], &z__[z_offset], ldu, &work[
+ 1], lwork, &rwork[1], &iwork[1], &iwork[n * 5 + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHEEVX(V,A,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L150;
+ }
+ }
+
+/* Do tests 4 and 5. */
+
+ zlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ zhet21_(&c__1, uplo, &n, &c__0, &a[a_offset], ldu, &wa1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+ zheevx_("N", "A", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ work[1], lwork, &rwork[1], &iwork[1], &iwork[n * 5 +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHEEVX(N,A,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L150;
+ }
+ }
+
+/* Do test 6. */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = wa1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = wa2[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = wa1[j] - wa2[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L140: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[ntest] = temp2 / max(d__1,d__2);
+
+L150:
+ zlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ ++ntest;
+
+ zheevx_("V", "I", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ work[1], lwork, &rwork[1], &iwork[1], &iwork[n * 5 +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ io___60.ciunit = *nounit;
+ s_wsfe(&io___60);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHEEVX(V,I,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L160;
+ }
+ }
+
+/* Do tests 7 and 8. */
+
+ zlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ zhet22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+
+ zheevx_("N", "I", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m3, &wa3[1], &z__[z_offset], ldu, &
+ work[1], lwork, &rwork[1], &iwork[1], &iwork[n * 5 +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ io___62.ciunit = *nounit;
+ s_wsfe(&io___62);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHEEVX(N,I,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L160;
+ }
+ }
+
+/* Do test 9. */
+
+ temp1 = dsxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = dsxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ d__2 = abs(wa1[1]), d__3 = (d__1 = wa1[n], abs(d__1));
+ temp3 = max(d__2,d__3);
+ } else {
+ temp3 = 0.;
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / max(d__1,d__2);
+
+L160:
+ zlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ ++ntest;
+
+ zheevx_("V", "V", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ work[1], lwork, &rwork[1], &iwork[1], &iwork[n * 5 +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ io___63.ciunit = *nounit;
+ s_wsfe(&io___63);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHEEVX(V,V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L170;
+ }
+ }
+
+/* Do tests 10 and 11. */
+
+ zlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ zhet22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+
+ zheevx_("N", "V", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m3, &wa3[1], &z__[z_offset], ldu, &
+ work[1], lwork, &rwork[1], &iwork[1], &iwork[n * 5 +
+ 1], &iinfo);
+ if (iinfo != 0) {
+ io___64.ciunit = *nounit;
+ s_wsfe(&io___64);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHEEVX(N,V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L170;
+ }
+ }
+
+ if (m3 == 0 && n > 0) {
+ result[ntest] = ulpinv;
+ goto L170;
+ }
+
+/* Do test 12. */
+
+ temp1 = dsxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = dsxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ d__2 = abs(wa1[1]), d__3 = (d__1 = wa1[n], abs(d__1));
+ temp3 = max(d__2,d__3);
+ } else {
+ temp3 = 0.;
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / max(d__1,d__2);
+
+L170:
+
+/* Call ZHPEVD and CHPEVX. */
+
+ zlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+/* Load array WORK with the upper or lower triangular */
+/* part of the matrix in packed form. */
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L180: */
+ }
+/* L190: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L200: */
+ }
+/* L210: */
+ }
+ }
+
+ ++ntest;
+ indwrk = n * (n + 1) / 2 + 1;
+ zhpevd_("V", uplo, &n, &work[1], &d1[1], &z__[z_offset], ldu,
+ &work[indwrk], &lwedc, &rwork[1], &lrwedc, &iwork[1],
+ &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___67.ciunit = *nounit;
+ s_wsfe(&io___67);
+/* Writing concatenation */
+ i__7[0] = 9, a__1[0] = "ZHPEVD(V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__7, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__1, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L270;
+ }
+ }
+
+/* Do tests 13 and 14. */
+
+ zhet21_(&c__1, uplo, &n, &c__0, &a[a_offset], lda, &d1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &rwork[1], &result[ntest]);
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L220: */
+ }
+/* L230: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L240: */
+ }
+/* L250: */
+ }
+ }
+
+ ntest += 2;
+ indwrk = n * (n + 1) / 2 + 1;
+ zhpevd_("N", uplo, &n, &work[1], &d3[1], &z__[z_offset], ldu,
+ &work[indwrk], &lwedc, &rwork[1], &lrwedc, &iwork[1],
+ &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___68.ciunit = *nounit;
+ s_wsfe(&io___68);
+/* Writing concatenation */
+ i__7[0] = 9, a__1[0] = "ZHPEVD(N,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__7, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__1, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L270;
+ }
+ }
+
+/* Do test 15. */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = d3[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d1[j] - d3[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L260: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[ntest] = temp2 / max(d__1,d__2);
+
+/* Load array WORK with the upper or lower triangular part */
+/* of the matrix in packed form. */
+
+L270:
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L280: */
+ }
+/* L290: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L300: */
+ }
+/* L310: */
+ }
+ }
+
+ ++ntest;
+
+ if (n > 0) {
+/* Computing MAX */
+ d__2 = abs(d1[1]), d__3 = (d__1 = d1[n], abs(d__1));
+ temp3 = max(d__2,d__3);
+ if (il != 1) {
+/* Computing MAX */
+ d__1 = (d1[il] - d1[il - 1]) * .5, d__2 = ulp * 10. *
+ temp3, d__1 = max(d__1,d__2), d__2 = rtunfl *
+ 10.;
+ vl = d1[il] - max(d__1,d__2);
+ } else if (n > 0) {
+/* Computing MAX */
+ d__1 = (d1[n] - d1[1]) * .5, d__2 = ulp * 10. * temp3,
+ d__1 = max(d__1,d__2), d__2 = rtunfl * 10.;
+ vl = d1[1] - max(d__1,d__2);
+ }
+ if (iu != n) {
+/* Computing MAX */
+ d__1 = (d1[iu + 1] - d1[iu]) * .5, d__2 = ulp * 10. *
+ temp3, d__1 = max(d__1,d__2), d__2 = rtunfl *
+ 10.;
+ vu = d1[iu] + max(d__1,d__2);
+ } else if (n > 0) {
+/* Computing MAX */
+ d__1 = (d1[n] - d1[1]) * .5, d__2 = ulp * 10. * temp3,
+ d__1 = max(d__1,d__2), d__2 = rtunfl * 10.;
+ vu = d1[n] + max(d__1,d__2);
+ }
+ } else {
+ temp3 = 0.;
+ vl = 0.;
+ vu = 1.;
+ }
+
+ zhpevx_("V", "A", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m, &wa1[1], &z__[z_offset], ldu, &v[v_offset]
+, &rwork[1], &iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___69.ciunit = *nounit;
+ s_wsfe(&io___69);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHPEVX(V,A,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L370;
+ }
+ }
+
+/* Do tests 16 and 17. */
+
+ zhet21_(&c__1, uplo, &n, &c__0, &a[a_offset], ldu, &wa1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L320: */
+ }
+/* L330: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L340: */
+ }
+/* L350: */
+ }
+ }
+
+ zhpevx_("N", "A", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &v[
+ v_offset], &rwork[1], &iwork[1], &iwork[n * 5 + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___70.ciunit = *nounit;
+ s_wsfe(&io___70);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHPEVX(N,A,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L370;
+ }
+ }
+
+/* Do test 18. */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = wa1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = wa2[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = wa1[j] - wa2[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L360: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[ntest] = temp2 / max(d__1,d__2);
+
+L370:
+ ++ntest;
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L380: */
+ }
+/* L390: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L400: */
+ }
+/* L410: */
+ }
+ }
+
+ zhpevx_("V", "I", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &v[
+ v_offset], &rwork[1], &iwork[1], &iwork[n * 5 + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___71.ciunit = *nounit;
+ s_wsfe(&io___71);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHPEVX(V,I,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L460;
+ }
+ }
+
+/* Do tests 19 and 20. */
+
+ zhet22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L420: */
+ }
+/* L430: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L440: */
+ }
+/* L450: */
+ }
+ }
+
+ zhpevx_("N", "I", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m3, &wa3[1], &z__[z_offset], ldu, &v[
+ v_offset], &rwork[1], &iwork[1], &iwork[n * 5 + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___72.ciunit = *nounit;
+ s_wsfe(&io___72);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHPEVX(N,I,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L460;
+ }
+ }
+
+/* Do test 21. */
+
+ temp1 = dsxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = dsxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ d__2 = abs(wa1[1]), d__3 = (d__1 = wa1[n], abs(d__1));
+ temp3 = max(d__2,d__3);
+ } else {
+ temp3 = 0.;
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / max(d__1,d__2);
+
+L460:
+ ++ntest;
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L470: */
+ }
+/* L480: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L490: */
+ }
+/* L500: */
+ }
+ }
+
+ zhpevx_("V", "V", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m2, &wa2[1], &z__[z_offset], ldu, &v[
+ v_offset], &rwork[1], &iwork[1], &iwork[n * 5 + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___73.ciunit = *nounit;
+ s_wsfe(&io___73);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHPEVX(V,V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L550;
+ }
+ }
+
+/* Do tests 22 and 23. */
+
+ zhet22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L510: */
+ }
+/* L520: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = indx;
+ i__6 = i__ + j * a_dim1;
+ work[i__5].r = a[i__6].r, work[i__5].i = a[i__6]
+ .i;
+ ++indx;
+/* L530: */
+ }
+/* L540: */
+ }
+ }
+
+ zhpevx_("N", "V", uplo, &n, &work[1], &vl, &vu, &il, &iu, &
+ abstol, &m3, &wa3[1], &z__[z_offset], ldu, &v[
+ v_offset], &rwork[1], &iwork[1], &iwork[n * 5 + 1], &
+ iinfo);
+ if (iinfo != 0) {
+ io___74.ciunit = *nounit;
+ s_wsfe(&io___74);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHPEVX(N,V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L550;
+ }
+ }
+
+ if (m3 == 0 && n > 0) {
+ result[ntest] = ulpinv;
+ goto L550;
+ }
+
+/* Do test 24. */
+
+ temp1 = dsxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = dsxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ d__2 = abs(wa1[1]), d__3 = (d__1 = wa1[n], abs(d__1));
+ temp3 = max(d__2,d__3);
+ } else {
+ temp3 = 0.;
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / max(d__1,d__2);
+
+L550:
+
+/* Call ZHBEVD and CHBEVX. */
+
+ if (jtype <= 7) {
+ kd = 0;
+ } else if (jtype >= 8 && jtype <= 15) {
+/* Computing MAX */
+ i__3 = n - 1;
+ kd = max(i__3,0);
+ } else {
+ kd = ihbw;
+ }
+
+/* Load array V with the upper or lower triangular part */
+/* of the matrix in band form. */
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kd;
+ i__6 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__6; ++i__) {
+ i__4 = kd + 1 + i__ - j + j * v_dim1;
+ i__5 = i__ + j * a_dim1;
+ v[i__4].r = a[i__5].r, v[i__4].i = a[i__5].i;
+/* L560: */
+ }
+/* L570: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + kd;
+ i__6 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__6; ++i__) {
+ i__4 = i__ + 1 - j + j * v_dim1;
+ i__5 = i__ + j * a_dim1;
+ v[i__4].r = a[i__5].r, v[i__4].i = a[i__5].i;
+/* L580: */
+ }
+/* L590: */
+ }
+ }
+
+ ++ntest;
+ zhbevd_("V", uplo, &n, &kd, &v[v_offset], ldu, &d1[1], &z__[
+ z_offset], ldu, &work[1], &lwedc, &rwork[1], &lrwedc,
+ &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___76.ciunit = *nounit;
+ s_wsfe(&io___76);
+/* Writing concatenation */
+ i__7[0] = 9, a__1[0] = "ZHBEVD(V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__7, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__1, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L650;
+ }
+ }
+
+/* Do tests 25 and 26. */
+
+ zhet21_(&c__1, uplo, &n, &c__0, &a[a_offset], lda, &d1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &rwork[1], &result[ntest]);
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__6 = 1, i__4 = j - kd;
+ i__5 = j;
+ for (i__ = max(i__6,i__4); i__ <= i__5; ++i__) {
+ i__6 = kd + 1 + i__ - j + j * v_dim1;
+ i__4 = i__ + j * a_dim1;
+ v[i__6].r = a[i__4].r, v[i__6].i = a[i__4].i;
+/* L600: */
+ }
+/* L610: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__6 = n, i__4 = j + kd;
+ i__5 = min(i__6,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ i__6 = i__ + 1 - j + j * v_dim1;
+ i__4 = i__ + j * a_dim1;
+ v[i__6].r = a[i__4].r, v[i__6].i = a[i__4].i;
+/* L620: */
+ }
+/* L630: */
+ }
+ }
+
+ ntest += 2;
+ zhbevd_("N", uplo, &n, &kd, &v[v_offset], ldu, &d3[1], &z__[
+ z_offset], ldu, &work[1], &lwedc, &rwork[1], &lrwedc,
+ &iwork[1], &liwedc, &iinfo);
+ if (iinfo != 0) {
+ io___77.ciunit = *nounit;
+ s_wsfe(&io___77);
+/* Writing concatenation */
+ i__7[0] = 9, a__1[0] = "ZHBEVD(N,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__1, a__1, i__7, &c__3, (ftnlen)11);
+ do_fio(&c__1, ch__1, (ftnlen)11);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L650;
+ }
+ }
+
+/* Do test 27. */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = d3[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d1[j] - d3[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L640: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[ntest] = temp2 / max(d__1,d__2);
+
+/* Load array V with the upper or lower triangular part */
+/* of the matrix in band form. */
+
+L650:
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__6 = j - kd;
+ i__4 = j;
+ for (i__ = max(i__5,i__6); i__ <= i__4; ++i__) {
+ i__5 = kd + 1 + i__ - j + j * v_dim1;
+ i__6 = i__ + j * a_dim1;
+ v[i__5].r = a[i__6].r, v[i__5].i = a[i__6].i;
+/* L660: */
+ }
+/* L670: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__5 = n, i__6 = j + kd;
+ i__4 = min(i__5,i__6);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = i__ + 1 - j + j * v_dim1;
+ i__6 = i__ + j * a_dim1;
+ v[i__5].r = a[i__6].r, v[i__5].i = a[i__6].i;
+/* L680: */
+ }
+/* L690: */
+ }
+ }
+
+ ++ntest;
+ zhbevx_("V", "A", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m, &wa1[
+ 1], &z__[z_offset], ldu, &work[1], &rwork[1], &iwork[
+ 1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___78.ciunit = *nounit;
+ s_wsfe(&io___78);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHBEVX(V,A,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L750;
+ }
+ }
+
+/* Do tests 28 and 29. */
+
+ zhet21_(&c__1, uplo, &n, &c__0, &a[a_offset], ldu, &wa1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kd;
+ i__6 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__6; ++i__) {
+ i__4 = kd + 1 + i__ - j + j * v_dim1;
+ i__5 = i__ + j * a_dim1;
+ v[i__4].r = a[i__5].r, v[i__4].i = a[i__5].i;
+/* L700: */
+ }
+/* L710: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + kd;
+ i__6 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__6; ++i__) {
+ i__4 = i__ + 1 - j + j * v_dim1;
+ i__5 = i__ + j * a_dim1;
+ v[i__4].r = a[i__5].r, v[i__4].i = a[i__5].i;
+/* L720: */
+ }
+/* L730: */
+ }
+ }
+
+ zhbevx_("N", "A", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m2, &
+ wa2[1], &z__[z_offset], ldu, &work[1], &rwork[1], &
+ iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___79.ciunit = *nounit;
+ s_wsfe(&io___79);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHBEVX(N,A,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L750;
+ }
+ }
+
+/* Do test 30. */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = wa1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = wa2[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = wa1[j] - wa2[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L740: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[ntest] = temp2 / max(d__1,d__2);
+
+/* Load array V with the upper or lower triangular part */
+/* of the matrix in band form. */
+
+L750:
+ ++ntest;
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__6 = 1, i__4 = j - kd;
+ i__5 = j;
+ for (i__ = max(i__6,i__4); i__ <= i__5; ++i__) {
+ i__6 = kd + 1 + i__ - j + j * v_dim1;
+ i__4 = i__ + j * a_dim1;
+ v[i__6].r = a[i__4].r, v[i__6].i = a[i__4].i;
+/* L760: */
+ }
+/* L770: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__6 = n, i__4 = j + kd;
+ i__5 = min(i__6,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ i__6 = i__ + 1 - j + j * v_dim1;
+ i__4 = i__ + j * a_dim1;
+ v[i__6].r = a[i__4].r, v[i__6].i = a[i__4].i;
+/* L780: */
+ }
+/* L790: */
+ }
+ }
+
+ zhbevx_("V", "I", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m2, &
+ wa2[1], &z__[z_offset], ldu, &work[1], &rwork[1], &
+ iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___80.ciunit = *nounit;
+ s_wsfe(&io___80);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHBEVX(V,I,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L840;
+ }
+ }
+
+/* Do tests 31 and 32. */
+
+ zhet22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__6 = j - kd;
+ i__4 = j;
+ for (i__ = max(i__5,i__6); i__ <= i__4; ++i__) {
+ i__5 = kd + 1 + i__ - j + j * v_dim1;
+ i__6 = i__ + j * a_dim1;
+ v[i__5].r = a[i__6].r, v[i__5].i = a[i__6].i;
+/* L800: */
+ }
+/* L810: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__5 = n, i__6 = j + kd;
+ i__4 = min(i__5,i__6);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = i__ + 1 - j + j * v_dim1;
+ i__6 = i__ + j * a_dim1;
+ v[i__5].r = a[i__6].r, v[i__5].i = a[i__6].i;
+/* L820: */
+ }
+/* L830: */
+ }
+ }
+ zhbevx_("N", "I", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m3, &
+ wa3[1], &z__[z_offset], ldu, &work[1], &rwork[1], &
+ iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___81.ciunit = *nounit;
+ s_wsfe(&io___81);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHBEVX(N,I,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L840;
+ }
+ }
+
+/* Do test 33. */
+
+ temp1 = dsxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = dsxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ d__2 = abs(wa1[1]), d__3 = (d__1 = wa1[n], abs(d__1));
+ temp3 = max(d__2,d__3);
+ } else {
+ temp3 = 0.;
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / max(d__1,d__2);
+
+/* Load array V with the upper or lower triangular part */
+/* of the matrix in band form. */
+
+L840:
+ ++ntest;
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kd;
+ i__6 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__6; ++i__) {
+ i__4 = kd + 1 + i__ - j + j * v_dim1;
+ i__5 = i__ + j * a_dim1;
+ v[i__4].r = a[i__5].r, v[i__4].i = a[i__5].i;
+/* L850: */
+ }
+/* L860: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + kd;
+ i__6 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__6; ++i__) {
+ i__4 = i__ + 1 - j + j * v_dim1;
+ i__5 = i__ + j * a_dim1;
+ v[i__4].r = a[i__5].r, v[i__4].i = a[i__5].i;
+/* L870: */
+ }
+/* L880: */
+ }
+ }
+ zhbevx_("V", "V", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m2, &
+ wa2[1], &z__[z_offset], ldu, &work[1], &rwork[1], &
+ iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___82.ciunit = *nounit;
+ s_wsfe(&io___82);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHBEVX(V,V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L930;
+ }
+ }
+
+/* Do tests 34 and 35. */
+
+ zhet22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__6 = 1, i__4 = j - kd;
+ i__5 = j;
+ for (i__ = max(i__6,i__4); i__ <= i__5; ++i__) {
+ i__6 = kd + 1 + i__ - j + j * v_dim1;
+ i__4 = i__ + j * a_dim1;
+ v[i__6].r = a[i__4].r, v[i__6].i = a[i__4].i;
+/* L890: */
+ }
+/* L900: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__6 = n, i__4 = j + kd;
+ i__5 = min(i__6,i__4);
+ for (i__ = j; i__ <= i__5; ++i__) {
+ i__6 = i__ + 1 - j + j * v_dim1;
+ i__4 = i__ + j * a_dim1;
+ v[i__6].r = a[i__4].r, v[i__6].i = a[i__4].i;
+/* L910: */
+ }
+/* L920: */
+ }
+ }
+ zhbevx_("N", "V", uplo, &n, &kd, &v[v_offset], ldu, &u[
+ u_offset], ldu, &vl, &vu, &il, &iu, &abstol, &m3, &
+ wa3[1], &z__[z_offset], ldu, &work[1], &rwork[1], &
+ iwork[1], &iwork[n * 5 + 1], &iinfo);
+ if (iinfo != 0) {
+ io___83.ciunit = *nounit;
+ s_wsfe(&io___83);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHBEVX(N,V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L930;
+ }
+ }
+
+ if (m3 == 0 && n > 0) {
+ result[ntest] = ulpinv;
+ goto L930;
+ }
+
+/* Do test 36. */
+
+ temp1 = dsxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = dsxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ d__2 = abs(wa1[1]), d__3 = (d__1 = wa1[n], abs(d__1));
+ temp3 = max(d__2,d__3);
+ } else {
+ temp3 = 0.;
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / max(d__1,d__2);
+
+L930:
+
+/* Call ZHEEV */
+
+ zlacpy_(" ", &n, &n, &a[a_offset], lda, &v[v_offset], ldu);
+
+ ++ntest;
+ zheev_("V", uplo, &n, &a[a_offset], ldu, &d1[1], &work[1],
+ lwork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___84.ciunit = *nounit;
+ s_wsfe(&io___84);
+/* Writing concatenation */
+ i__7[0] = 8, a__1[0] = "ZHEEV(V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__7, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__3, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L950;
+ }
+ }
+
+/* Do tests 37 and 38 */
+
+ zhet21_(&c__1, uplo, &n, &c__0, &v[v_offset], ldu, &d1[1], &
+ d2[1], &a[a_offset], ldu, &z__[z_offset], ldu, &tau[1]
+, &work[1], &rwork[1], &result[ntest]);
+
+ zlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ ntest += 2;
+ zheev_("N", uplo, &n, &a[a_offset], ldu, &d3[1], &work[1],
+ lwork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___85.ciunit = *nounit;
+ s_wsfe(&io___85);
+/* Writing concatenation */
+ i__7[0] = 8, a__1[0] = "ZHEEV(N,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__7, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__3, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L950;
+ }
+ }
+
+/* Do test 39 */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = d3[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d1[j] - d3[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L940: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[ntest] = temp2 / max(d__1,d__2);
+
+L950:
+
+ zlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+/* Call ZHPEV */
+
+/* Load array WORK with the upper or lower triangular */
+/* part of the matrix in packed form. */
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__5 = j;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = indx;
+ i__4 = i__ + j * a_dim1;
+ work[i__6].r = a[i__4].r, work[i__6].i = a[i__4]
+ .i;
+ ++indx;
+/* L960: */
+ }
+/* L970: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__5 = n;
+ for (i__ = j; i__ <= i__5; ++i__) {
+ i__6 = indx;
+ i__4 = i__ + j * a_dim1;
+ work[i__6].r = a[i__4].r, work[i__6].i = a[i__4]
+ .i;
+ ++indx;
+/* L980: */
+ }
+/* L990: */
+ }
+ }
+
+ ++ntest;
+ indwrk = n * (n + 1) / 2 + 1;
+ zhpev_("V", uplo, &n, &work[1], &d1[1], &z__[z_offset], ldu, &
+ work[indwrk], &rwork[1], &iinfo)
+ ;
+ if (iinfo != 0) {
+ io___86.ciunit = *nounit;
+ s_wsfe(&io___86);
+/* Writing concatenation */
+ i__7[0] = 8, a__1[0] = "ZHPEV(V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__7, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__3, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1050;
+ }
+ }
+
+/* Do tests 40 and 41. */
+
+ zhet21_(&c__1, uplo, &n, &c__0, &a[a_offset], lda, &d1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &rwork[1], &result[ntest]);
+
+ if (iuplo == 1) {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__5 = j;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ i__6 = indx;
+ i__4 = i__ + j * a_dim1;
+ work[i__6].r = a[i__4].r, work[i__6].i = a[i__4]
+ .i;
+ ++indx;
+/* L1000: */
+ }
+/* L1010: */
+ }
+ } else {
+ indx = 1;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__5 = n;
+ for (i__ = j; i__ <= i__5; ++i__) {
+ i__6 = indx;
+ i__4 = i__ + j * a_dim1;
+ work[i__6].r = a[i__4].r, work[i__6].i = a[i__4]
+ .i;
+ ++indx;
+/* L1020: */
+ }
+/* L1030: */
+ }
+ }
+
+ ntest += 2;
+ indwrk = n * (n + 1) / 2 + 1;
+ zhpev_("N", uplo, &n, &work[1], &d3[1], &z__[z_offset], ldu, &
+ work[indwrk], &rwork[1], &iinfo)
+ ;
+ if (iinfo != 0) {
+ io___87.ciunit = *nounit;
+ s_wsfe(&io___87);
+/* Writing concatenation */
+ i__7[0] = 8, a__1[0] = "ZHPEV(N,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__7, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__3, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1050;
+ }
+ }
+
+/* Do test 42 */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = d3[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d1[j] - d3[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L1040: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[ntest] = temp2 / max(d__1,d__2);
+
+L1050:
+
+/* Call ZHBEV */
+
+ if (jtype <= 7) {
+ kd = 0;
+ } else if (jtype >= 8 && jtype <= 15) {
+/* Computing MAX */
+ i__3 = n - 1;
+ kd = max(i__3,0);
+ } else {
+ kd = ihbw;
+ }
+
+/* Load array V with the upper or lower triangular part */
+/* of the matrix in band form. */
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__5 = 1, i__6 = j - kd;
+ i__4 = j;
+ for (i__ = max(i__5,i__6); i__ <= i__4; ++i__) {
+ i__5 = kd + 1 + i__ - j + j * v_dim1;
+ i__6 = i__ + j * a_dim1;
+ v[i__5].r = a[i__6].r, v[i__5].i = a[i__6].i;
+/* L1060: */
+ }
+/* L1070: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__5 = n, i__6 = j + kd;
+ i__4 = min(i__5,i__6);
+ for (i__ = j; i__ <= i__4; ++i__) {
+ i__5 = i__ + 1 - j + j * v_dim1;
+ i__6 = i__ + j * a_dim1;
+ v[i__5].r = a[i__6].r, v[i__5].i = a[i__6].i;
+/* L1080: */
+ }
+/* L1090: */
+ }
+ }
+
+ ++ntest;
+ zhbev_("V", uplo, &n, &kd, &v[v_offset], ldu, &d1[1], &z__[
+ z_offset], ldu, &work[1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___88.ciunit = *nounit;
+ s_wsfe(&io___88);
+/* Writing concatenation */
+ i__7[0] = 8, a__1[0] = "ZHBEV(V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__7, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__3, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1140;
+ }
+ }
+
+/* Do tests 43 and 44. */
+
+ zhet21_(&c__1, uplo, &n, &c__0, &a[a_offset], lda, &d1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &rwork[1], &result[ntest]);
+
+ if (iuplo == 1) {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__5 = j - kd;
+ i__6 = j;
+ for (i__ = max(i__4,i__5); i__ <= i__6; ++i__) {
+ i__4 = kd + 1 + i__ - j + j * v_dim1;
+ i__5 = i__ + j * a_dim1;
+ v[i__4].r = a[i__5].r, v[i__4].i = a[i__5].i;
+/* L1100: */
+ }
+/* L1110: */
+ }
+ } else {
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ i__4 = n, i__5 = j + kd;
+ i__6 = min(i__4,i__5);
+ for (i__ = j; i__ <= i__6; ++i__) {
+ i__4 = i__ + 1 - j + j * v_dim1;
+ i__5 = i__ + j * a_dim1;
+ v[i__4].r = a[i__5].r, v[i__4].i = a[i__5].i;
+/* L1120: */
+ }
+/* L1130: */
+ }
+ }
+
+ ntest += 2;
+ zhbev_("N", uplo, &n, &kd, &v[v_offset], ldu, &d3[1], &z__[
+ z_offset], ldu, &work[1], &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ io___89.ciunit = *nounit;
+ s_wsfe(&io___89);
+/* Writing concatenation */
+ i__7[0] = 8, a__1[0] = "ZHBEV(N,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__3, a__1, i__7, &c__3, (ftnlen)10);
+ do_fio(&c__1, ch__3, (ftnlen)10);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1140;
+ }
+ }
+
+L1140:
+
+/* Do test 45. */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = d1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = d3[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = d1[j] - d3[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L1150: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[ntest] = temp2 / max(d__1,d__2);
+
+ zlacpy_(" ", &n, &n, &a[a_offset], lda, &v[v_offset], ldu);
+ ++ntest;
+ i__3 = *liwork - (n << 1);
+ zheevr_("V", "A", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m, &wa1[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &rwork[1], lrwork, &iwork[(
+ n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___90.ciunit = *nounit;
+ s_wsfe(&io___90);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHEEVR(V,A,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1170;
+ }
+ }
+
+/* Do tests 45 and 46 (or ... ) */
+
+ zlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ zhet21_(&c__1, uplo, &n, &c__0, &a[a_offset], ldu, &wa1[1], &
+ d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &tau[1]
+, &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+ i__3 = *liwork - (n << 1);
+ zheevr_("N", "A", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &rwork[1], lrwork, &iwork[(
+ n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___91.ciunit = *nounit;
+ s_wsfe(&io___91);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHEEVR(N,A,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1170;
+ }
+ }
+
+/* Do test 47 (or ... ) */
+
+ temp1 = 0.;
+ temp2 = 0.;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MAX */
+ d__3 = temp1, d__4 = (d__1 = wa1[j], abs(d__1)), d__3 =
+ max(d__3,d__4), d__4 = (d__2 = wa2[j], abs(d__2));
+ temp1 = max(d__3,d__4);
+/* Computing MAX */
+ d__2 = temp2, d__3 = (d__1 = wa1[j] - wa2[j], abs(d__1));
+ temp2 = max(d__2,d__3);
+/* L1160: */
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * max(temp1,temp2);
+ result[ntest] = temp2 / max(d__1,d__2);
+
+L1170:
+
+ ++ntest;
+ zlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ i__3 = *liwork - (n << 1);
+ zheevr_("V", "I", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &rwork[1], lrwork, &iwork[(
+ n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___92.ciunit = *nounit;
+ s_wsfe(&io___92);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHEEVR(V,I,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1180;
+ }
+ }
+
+/* Do tests 48 and 49 (or +??) */
+
+ zlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ zhet22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+ zlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ i__3 = *liwork - (n << 1);
+ zheevr_("N", "I", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m3, &wa3[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &rwork[1], lrwork, &iwork[(
+ n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___93.ciunit = *nounit;
+ s_wsfe(&io___93);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHEEVR(N,I,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1180;
+ }
+ }
+
+/* Do test 50 (or +??) */
+
+ temp1 = dsxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = dsxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+/* Computing MAX */
+ d__1 = unfl, d__2 = ulp * temp3;
+ result[ntest] = (temp1 + temp2) / max(d__1,d__2);
+L1180:
+
+ ++ntest;
+ zlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ i__3 = *liwork - (n << 1);
+ zheevr_("V", "V", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m2, &wa2[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &rwork[1], lrwork, &iwork[(
+ n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___94.ciunit = *nounit;
+ s_wsfe(&io___94);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHEEVR(V,V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ result[ntest + 1] = ulpinv;
+ result[ntest + 2] = ulpinv;
+ goto L1190;
+ }
+ }
+
+/* Do tests 51 and 52 (or +??) */
+
+ zlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+ zhet22_(&c__1, uplo, &n, &m2, &c__0, &a[a_offset], ldu, &wa2[
+ 1], &d2[1], &z__[z_offset], ldu, &v[v_offset], ldu, &
+ tau[1], &work[1], &rwork[1], &result[ntest]);
+
+ ntest += 2;
+ zlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+ i__3 = *liwork - (n << 1);
+ zheevr_("N", "V", uplo, &n, &a[a_offset], ldu, &vl, &vu, &il,
+ &iu, &abstol, &m3, &wa3[1], &z__[z_offset], ldu, &
+ iwork[1], &work[1], lwork, &rwork[1], lrwork, &iwork[(
+ n << 1) + 1], &i__3, &iinfo);
+ if (iinfo != 0) {
+ io___95.ciunit = *nounit;
+ s_wsfe(&io___95);
+/* Writing concatenation */
+ i__7[0] = 11, a__1[0] = "ZHEEVR(N,V,";
+ i__7[1] = 1, a__1[1] = uplo;
+ i__7[2] = 1, a__1[2] = ")";
+ s_cat(ch__2, a__1, i__7, &c__3, (ftnlen)13);
+ do_fio(&c__1, ch__2, (ftnlen)13);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
+ ;
+ e_wsfe();
+ *info = abs(iinfo);
+ if (iinfo < 0) {
+ return 0;
+ } else {
+ result[ntest] = ulpinv;
+ goto L1190;
+ }
+ }
+
+ if (m3 == 0 && n > 0) {
+ result[ntest] = ulpinv;
+ goto L1190;
+ }
+
+/* Do test 52 (or +??) */
+
+ temp1 = dsxt1_(&c__1, &wa2[1], &m2, &wa3[1], &m3, &abstol, &
+ ulp, &unfl);
+ temp2 = dsxt1_(&c__1, &wa3[1], &m3, &wa2[1], &m2, &abstol, &
+ ulp, &unfl);
+ if (n > 0) {
+/* Computing MAX */
+ d__2 = abs(wa1[1]), d__3 = (d__1 = wa1[n], abs(d__1));
+ temp3 = max(d__2,d__3);
+ } else {
+ temp3 = 0.;
+ }
+/* Computing MAX */
+ d__1 = unfl, d__2 = temp3 * ulp;
+ result[ntest] = (temp1 + temp2) / max(d__1,d__2);
+
+ zlacpy_(" ", &n, &n, &v[v_offset], ldu, &a[a_offset], lda);
+
+
+
+
+/* Load array V with the upper or lower triangular part */
+/* of the matrix in band form. */
+
+L1190:
+
+/* L1200: */
+ ;
+ }
+
+/* End of Loop -- Check for RESULT(j) > THRESH */
+
+ ntestt += ntest;
+ dlafts_("ZST", &n, &n, &jtype, &ntest, &result[1], ioldsd, thresh,
+ nounit, &nerrs);
+
+L1210:
+ ;
+ }
+/* L1220: */
+ }
+
+/* Summary */
+
+ alasvm_("ZST", nounit, &nerrs, &ntestt, &c__0);
+
+
+ return 0;
+
+/* End of ZDRVST */
+
+} /* zdrvst_ */
diff --git a/TESTING/EIG/zdrvsx.c b/TESTING/EIG/zdrvsx.c
new file mode 100644
index 0000000..a8574f0
--- /dev/null
+++ b/TESTING/EIG/zdrvsx.c
@@ -0,0 +1,1089 @@
+/* zdrvsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ doublereal selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__0 = 0;
+static integer c__4 = 4;
+static integer c__6 = 6;
+static doublereal c_b39 = 1.;
+static integer c__1 = 1;
+static doublereal c_b49 = 0.;
+static integer c__2 = 2;
+static logical c_false = FALSE_;
+static integer c__3 = 3;
+static integer c__7 = 7;
+static integer c__5 = 5;
+static logical c_true = TRUE_;
+static integer c__22 = 22;
+
+/* Subroutine */ int zdrvsx_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, integer *niunit,
+ integer *nounit, doublecomplex *a, integer *lda, doublecomplex *h__,
+ doublecomplex *ht, doublecomplex *w, doublecomplex *wt, doublecomplex
+ *wtmp, doublecomplex *vs, integer *ldvs, doublecomplex *vs1,
+ doublereal *result, doublecomplex *work, integer *lwork, doublereal *
+ rwork, logical *bwork, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
+ static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
+ static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
+
+ /* Format strings */
+ static char fmt_9991[] = "(\002 ZDRVSX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(/1x,a3,\002 -- Complex Schur Form Decompositi"
+ "on Expert \002,\002Driver\002,/\002 Matrix types (see ZDRVSX for"
+ " details): \002)";
+ static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 \002,\002 5=Diagonal: geom"
+ "etr. spaced entries.\002,/\002 2=Identity matrix. "
+ " \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
+ "/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
+ " 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
+ "l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
+ "ll, evenly spaced.\002)";
+ static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
+ " 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
+ "l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
+ "d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
+ "red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
+ "vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
+ " 12=Well-cond., random complex \002,\002 \002,\002 17=Il"
+ "l-cond., large rand. complx \002,/\002 13=Ill-condi\002,\002tion"
+ "ed, evenly spaced. \002,\002 18=Ill-cond., small rand.\002"
+ ",\002 complx \002)";
+ static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
+ " \002,\002 21=Matrix \002,\002with small random entries.\002,"
+ "/\002 20=Matrix with large ran\002,\002dom entries. \002,/)";
+ static char fmt_9995[] = "(\002 Tests performed with test threshold ="
+ "\002,f8.2,/\002 ( A denotes A on input and T denotes A on output)"
+ "\002,//\002 1 = 0 if T in Schur form (no sort), \002,\002 1/ulp"
+ " otherwise\002,/\002 2 = | A - VS T transpose(VS) | / ( n |A| ul"
+ "p ) (no sort)\002,/\002 3 = | I - VS transpose(VS) | / ( n ulp )"
+ " (no sort) \002,/\002 4 = 0 if W are eigenvalues of T (no sort)"
+ ",\002,\002 1/ulp otherwise\002,/\002 5 = 0 if T same no matter "
+ "if VS computed (no sort),\002,\002 1/ulp otherwise\002,/\002 6 "
+ "= 0 if W same no matter if VS computed (no sort)\002,\002, 1/ul"
+ "p otherwise\002)";
+ static char fmt_9994[] = "(\002 7 = 0 if T in Schur form (sort), \002"
+ ",\002 1/ulp otherwise\002,/\002 8 = | A - VS T transpose(VS) | "
+ "/ ( n |A| ulp ) (sort)\002,/\002 9 = | I - VS transpose(VS) | / "
+ "( n ulp ) (sort) \002,/\002 10 = 0 if W are eigenvalues of T (so"
+ "rt),\002,\002 1/ulp otherwise\002,/\002 11 = 0 if T same no mat"
+ "ter what else computed (sort),\002,\002 1/ulp otherwise\002,"
+ "/\002 12 = 0 if W same no matter what else computed \002,\002(so"
+ "rt), 1/ulp otherwise\002,/\002 13 = 0 if sorting succesful, 1/ul"
+ "p otherwise\002,/\002 14 = 0 if RCONDE same no matter what else "
+ "computed,\002,\002 1/ulp otherwise\002,/\002 15 = 0 if RCONDv sa"
+ "me no matter what else computed,\002,\002 1/ulp otherwise\002,"
+ "/\002 16 = | RCONDE - RCONDE(precomputed) | / cond(RCONDE),\002,/"
+ "\002 17 = | RCONDV - RCONDV(precomputed) | / cond(RCONDV),\002)";
+ static char fmt_9993[] = "(\002 N=\002,i5,\002, IWK=\002,i2,\002, seed"
+ "=\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)="
+ "\002,g10.3)";
+ static char fmt_9992[] = "(\002 N=\002,i5,\002, input example =\002,i3"
+ ",\002, test(\002,i2,\002)=\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, ht_dim1, ht_offset, vs_dim1,
+ vs_offset, vs1_dim1, vs1_offset, i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+
+ /* Local variables */
+ integer i__, j, n, iwk;
+ doublereal ulp, cond;
+ integer jcol;
+ char path[3];
+ integer nmax;
+ doublereal unfl, ovfl;
+ integer isrt;
+ logical badnn;
+ integer nfail, imode, iinfo;
+ doublereal conds, anorm;
+ integer islct[20];
+ extern /* Subroutine */ int zget24_(logical *, integer *, doublereal *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *, doublereal *, integer *, integer *, integer *,
+ doublereal *, doublecomplex *, integer *, doublereal *, logical *,
+ integer *);
+ integer nslct, jsize, nerrs, itype, jtype, ntest;
+ doublereal rtulp;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ doublereal rcdein;
+ integer idumma[1], ioldsd[4];
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal rcdvin;
+ extern /* Subroutine */ int dlasum_(char *, integer *, integer *, integer
+ *), zlatme_(integer *, char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublecomplex *, char *, char *, char *,
+ char *, doublereal *, integer *, doublereal *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *);
+ integer ntestf;
+ extern /* Subroutine */ int zlatmr_(integer *, integer *, char *, integer
+ *, char *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, char *, char *, doublecomplex *, integer *,
+ doublereal *, doublecomplex *, integer *, doublereal *, char *,
+ integer *, integer *, integer *, doublereal *, doublereal *, char
+ *, doublecomplex *, integer *, integer *, integer *), zlatms_(integer *,
+ integer *, char *, integer *, char *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *, char *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal ulpinv;
+ integer nnwork;
+ doublereal rtulpi;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___31 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___47 = { 0, 0, 1, 0, 0 };
+ static cilist io___49 = { 0, 0, 0, 0, 0 };
+ static cilist io___51 = { 0, 0, 0, 0, 0 };
+ static cilist io___52 = { 0, 0, 0, 0, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9992, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVSX checks the nonsymmetric eigenvalue (Schur form) problem */
+/* expert driver ZGEESX. */
+
+/* ZDRVSX uses both test matrices generated randomly depending on */
+/* data supplied in the calling sequence, as well as on data */
+/* read from an input file and including precomputed condition */
+/* numbers to which it compares the ones it computes. */
+
+/* When ZDRVSX is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified. For each size ("n") */
+/* and each type of matrix, one matrix will be generated and used */
+/* to test the nonsymmetric eigenroutines. For each matrix, 15 */
+/* tests will be performed: */
+
+/* (1) 0 if T is in Schur form, 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (2) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (no sorting of eigenvalues). */
+
+/* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues). */
+
+/* (4) 0 if W are eigenvalues of T */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (5) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (7) 0 if T is in Schur form, 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (8) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (with sorting of eigenvalues). */
+
+/* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues). */
+
+/* (10) 0 if W are eigenvalues of T */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare W with and */
+/* without reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (11) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare T with and without */
+/* reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare VS with and without */
+/* reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (13) if sorting worked and SDIM is the number of */
+/* eigenvalues which were SELECTed */
+/* If workspace sufficient, also compare SDIM with and */
+/* without reciprocal condition numbers */
+
+/* (14) if RCONDE the same no matter if VS and/or RCONDV computed */
+
+/* (15) if RCONDV the same no matter if VS and/or RCONDE computed */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
+
+/* (4) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random complex angles. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (5) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random complex angles. */
+/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random complex angles. */
+
+/* (7) Same as (4), but multiplied by a constant near */
+/* the overflow threshold */
+/* (8) Same as (4), but multiplied by a constant near */
+/* the underflow threshold */
+
+/* (9) A matrix of the form U' T U, where U is unitary and */
+/* T has evenly spaced entries 1, ..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (10) A matrix of the form U' T U, where U is unitary and */
+/* T has geometrically spaced entries 1, ..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (11) A matrix of the form U' T U, where U is orthogonal and */
+/* T has "clustered" entries 1, ULP,..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (12) A matrix of the form U' T U, where U is unitary and */
+/* T has complex eigenvalues randomly chosen from */
+/* ULP < |z| < 1 and random O(1) entries in the upper */
+/* triangle. */
+
+/* (13) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
+/* with random complex angles on the diagonal and random O(1) */
+/* entries in the upper triangle. */
+
+/* (14) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has geometrically spaced entries */
+/* 1, ..., ULP with random complex angles on the diagonal */
+/* and random O(1) entries in the upper triangle. */
+
+/* (15) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
+/* with random complex angles on the diagonal and random O(1) */
+/* entries in the upper triangle. */
+
+/* (16) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has complex eigenvalues randomly chosen */
+/* from ULP < |z| < 1 and random O(1) entries in the upper */
+/* triangle. */
+
+/* (17) Same as (16), but multiplied by a constant */
+/* near the overflow threshold */
+/* (18) Same as (16), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* (19) Nonsymmetric matrix with random entries chosen from (-1,1). */
+/* If N is at least 4, all entries in first two rows and last */
+/* row, and first column and last two columns are zero. */
+/* (20) Same as (19), but multiplied by a constant */
+/* near the overflow threshold */
+/* (21) Same as (19), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* In addition, an input file will be read from logical unit number */
+/* NIUNIT. The file contains matrices along with precomputed */
+/* eigenvalues and reciprocal condition numbers for the eigenvalue */
+/* average and right invariant subspace. For these matrices, in */
+/* addition to tests (1) to (15) we will compute the following two */
+/* tests: */
+
+/* (16) |RCONDE - RCDEIN| / cond(RCONDE) */
+
+/* RCONDE is the reciprocal average eigenvalue condition number */
+/* computed by ZGEESX and RCDEIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDE) is the condition number */
+/* of RCONDE, and takes errors in computing RCONDE into account, */
+/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
+/* is essentially given by norm(A)/RCONDV. */
+
+/* (17) |RCONDV - RCDVIN| / cond(RCONDV) */
+
+/* RCONDV is the reciprocal right invariant subspace condition */
+/* number computed by ZGEESX and RCDVIN (the precomputed true */
+/* value) is supplied as input. cond(RCONDV) is the condition */
+/* number of RCONDV, and takes errors in computing RCONDV into */
+/* account, so that the resulting quantity should be O(ULP). */
+/* cond(RCONDV) is essentially given by norm(A)/RCONDE. */
+
+/* Arguments */
+/* ========= */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. NSIZES must be at */
+/* least zero. If it is zero, no randomly generated matrices */
+/* are tested, but any test matrices read from NIUNIT will be */
+/* tested. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. NTYPES must be at least */
+/* zero. If it is zero, no randomly generated test matrices */
+/* are tested, but and test matrices read from NIUNIT will be */
+/* tested. If it is MAXTYP+1 and NSIZES is 1, then an */
+/* additional type, MAXTYP+1 is defined, which is to use */
+/* whatever matrix is in A. This is only useful if */
+/* DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to ZDRVSX to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NIUNIT (input) INTEGER */
+/* The FORTRAN unit number for reading in the data file of */
+/* problems to solve. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* A (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, and H. LDA must be at */
+/* least 1 and at least max( NN ). */
+
+/* H (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* Another copy of the test matrix A, modified by ZGEESX. */
+
+/* HT (workspace) COMPLEX*16 array, dimension (LDA, max(NN)) */
+/* Yet another copy of the test matrix A, modified by ZGEESX. */
+
+/* W (workspace) COMPLEX*16 array, dimension (max(NN)) */
+/* The computed eigenvalues of A. */
+
+/* WT (workspace) COMPLEX*16 array, dimension (max(NN)) */
+/* Like W, this array contains the eigenvalues of A, */
+/* but those computed when ZGEESX only computes a partial */
+/* eigendecomposition, i.e. not Schur vectors */
+
+/* WTMP (workspace) COMPLEX*16 array, dimension (max(NN)) */
+/* More temporary storage for eigenvalues. */
+
+/* VS (workspace) COMPLEX*16 array, dimension (LDVS, max(NN)) */
+/* VS holds the computed Schur vectors. */
+
+/* LDVS (input) INTEGER */
+/* Leading dimension of VS. Must be at least max(1,max(NN)). */
+
+/* VS1 (workspace) COMPLEX*16 array, dimension (LDVS, max(NN)) */
+/* VS1 holds another copy of the computed Schur vectors. */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (17) */
+/* The values computed by the 17 tests described above. */
+/* The values are currently limited to 1/ulp, to avoid overflow. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* max(1,2*NN(j)**2) for all j. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
+
+/* BWORK (workspace) LOGICAL array, dimension (max(NN)) */
+
+/* INFO (output) INTEGER */
+/* If 0, successful exit. */
+/* <0, input parameter -INFO is incorrect */
+/* >0, ZLATMR, CLATMS, CLATME or ZGET24 returned an error */
+/* code and INFO is its absolute value */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NMAX Largest value in NN. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* COND, CONDS, */
+/* IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTULP, RTULPI Square roots of the previous 4 values. */
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+/* KCONDS(j) Selectw whether CONDS is to be 1 or */
+/* 1/sqrt(ulp). (0 means irrelevant.) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ ht_dim1 = *lda;
+ ht_offset = 1 + ht_dim1;
+ ht -= ht_offset;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ --wt;
+ --wtmp;
+ vs1_dim1 = *ldvs;
+ vs1_offset = 1 + vs1_dim1;
+ vs1 -= vs1_offset;
+ vs_dim1 = *ldvs;
+ vs_offset = 1 + vs_dim1;
+ vs -= vs_offset;
+ --result;
+ --work;
+ --rwork;
+ --bwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "SX", (ftnlen)2, (ftnlen)2);
+
+/* Check for errors */
+
+ ntestt = 0;
+ ntestf = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+
+/* 8 is the largest dimension in the input file of precomputed */
+/* problems */
+
+ nmax = 8;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.) {
+ *info = -6;
+ } else if (*niunit <= 0) {
+ *info = -7;
+ } else if (*nounit <= 0) {
+ *info = -8;
+ } else if (*lda < 1 || *lda < nmax) {
+ *info = -10;
+ } else if (*ldvs < 1 || *ldvs < nmax) {
+ *info = -20;
+ } else /* if(complicated condition) */ {
+/* Computing MAX */
+/* Computing 2nd power */
+ i__3 = nmax;
+ i__1 = nmax * 3, i__2 = i__3 * i__3 << 1;
+ if (max(i__1,i__2) > *lwork) {
+ *info = -24;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZDRVSX", &i__1);
+ return 0;
+ }
+
+/* If nothing to do check on NIUNIT */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ goto L150;
+ }
+
+/* More Important constants */
+
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ dlabad_(&unfl, &ovfl);
+ ulp = dlamch_("Precision");
+ ulpinv = 1. / ulp;
+ rtulp = sqrt(ulp);
+ rtulpi = 1. / rtulp;
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L130;
+ }
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KCONDS KMODE KTYPE */
+/* =1 O(1) 1 clustered 1 zero */
+/* =2 large large clustered 2 identity */
+/* =3 small exponential Jordan */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random general, w/ eigenvalues */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 random general */
+/* =10 random triangular */
+
+ if (mtypes > 21) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L30;
+ case 2: goto L40;
+ case 3: goto L50;
+ }
+
+L30:
+ anorm = 1.;
+ goto L60;
+
+L40:
+ anorm = ovfl * ulp;
+ goto L60;
+
+L50:
+ anorm = unfl * ulpinv;
+ goto L60;
+
+L60:
+
+ zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+ if (itype == 1) {
+
+/* Zero */
+
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ a[i__4].r = anorm, a[i__4].i = 0.;
+/* L70: */
+ }
+
+ } else if (itype == 3) {
+
+/* Jordan Block */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ a[i__4].r = anorm, a[i__4].i = 0.;
+ if (jcol > 1) {
+ i__4 = jcol + (jcol - 1) * a_dim1;
+ a[i__4].r = 1., a[i__4].i = 0.;
+ }
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[
+ n + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 6) {
+
+/* General, eigenvalues specified */
+
+ if (kconds[jtype - 1] == 1) {
+ conds = 1.;
+ } else if (kconds[jtype - 1] == 2) {
+ conds = rtulpi;
+ } else {
+ conds = 0.;
+ }
+
+ zlatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2,
+ " ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n,
+ &anorm, &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b39,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &c__0, &
+ c__0, &c_b49, &anorm, "NO", &a[a_offset], lda, idumma,
+ &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ zlatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b39,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &n, &
+ c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* General, random eigenvalues */
+
+ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b39,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &n, &
+ c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
+ iinfo);
+ if (n >= 4) {
+ zlaset_("Full", &c__2, &n, &c_b1, &c_b1, &a[a_offset],
+ lda);
+ i__3 = n - 3;
+ zlaset_("Full", &i__3, &c__1, &c_b1, &c_b1, &a[a_dim1 + 3]
+, lda);
+ i__3 = n - 3;
+ zlaset_("Full", &i__3, &c__2, &c_b1, &c_b1, &a[(n - 1) *
+ a_dim1 + 3], lda);
+ zlaset_("Full", &c__1, &n, &c_b1, &c_b1, &a[n + a_dim1],
+ lda);
+ }
+
+ } else if (itype == 10) {
+
+/* Triangular, random eigenvalues */
+
+ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b39,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &c__0, &
+ c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
+ iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___31.ciunit = *nounit;
+ s_wsfe(&io___31);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+/* Test for minimal and generous workspace */
+
+ for (iwk = 1; iwk <= 2; ++iwk) {
+ if (iwk == 1) {
+ nnwork = n << 1;
+ } else {
+/* Computing MAX */
+ i__3 = n << 1, i__4 = n * (n + 1) / 2;
+ nnwork = max(i__3,i__4);
+ }
+ nnwork = max(nnwork,1);
+
+ zget24_(&c_false, &jtype, thresh, ioldsd, nounit, &n, &a[
+ a_offset], lda, &h__[h_offset], &ht[ht_offset], &w[1],
+ &wt[1], &wtmp[1], &vs[vs_offset], ldvs, &vs1[
+ vs1_offset], &rcdein, &rcdvin, &nslct, islct, &c__0, &
+ result[1], &work[1], &nnwork, &rwork[1], &bwork[1],
+ info);
+
+/* Check for RESULT(j) > THRESH */
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 15; ++j) {
+ if (result[j] >= 0.) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L100: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___40.ciunit = *nounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ e_wsfe();
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ e_wsfe();
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ e_wsfe();
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ io___45.ciunit = *nounit;
+ s_wsfe(&io___45);
+ e_wsfe();
+ ntestf = 2;
+ }
+
+ for (j = 1; j <= 15; ++j) {
+ if (result[j] >= *thresh) {
+ io___46.ciunit = *nounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+/* L110: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+
+/* L120: */
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+
+L150:
+
+/* Read in data from file to check accuracy of condition estimation */
+/* Read input data until N=0 */
+
+ jtype = 0;
+L160:
+ io___47.ciunit = *niunit;
+ i__1 = s_rsle(&io___47);
+ if (i__1 != 0) {
+ goto L200;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L200;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&nslct, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L200;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&isrt, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L200;
+ }
+ i__1 = e_rsle();
+ if (i__1 != 0) {
+ goto L200;
+ }
+ if (n == 0) {
+ goto L200;
+ }
+ ++jtype;
+ iseed[1] = jtype;
+ io___49.ciunit = *niunit;
+ s_rsle(&io___49);
+ i__1 = nslct;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&islct[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___51.ciunit = *niunit;
+ s_rsle(&io___51);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
+ doublecomplex));
+ }
+ e_rsle();
+/* L170: */
+ }
+ io___52.ciunit = *niunit;
+ s_rsle(&io___52);
+ do_lio(&c__5, &c__1, (char *)&rcdein, (ftnlen)sizeof(doublereal));
+ do_lio(&c__5, &c__1, (char *)&rcdvin, (ftnlen)sizeof(doublereal));
+ e_rsle();
+
+ zget24_(&c_true, &c__22, thresh, &iseed[1], nounit, &n, &a[a_offset], lda,
+ &h__[h_offset], &ht[ht_offset], &w[1], &wt[1], &wtmp[1], &vs[
+ vs_offset], ldvs, &vs1[vs1_offset], &rcdein, &rcdvin, &nslct,
+ islct, &isrt, &result[1], &work[1], lwork, &rwork[1], &bwork[1],
+ info);
+
+/* Check for RESULT(j) > THRESH */
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 17; ++j) {
+ if (result[j] >= 0.) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L180: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ e_wsfe();
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+ e_wsfe();
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ e_wsfe();
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ io___58.ciunit = *nounit;
+ s_wsfe(&io___58);
+ e_wsfe();
+ ntestf = 2;
+ }
+ for (j = 1; j <= 17; ++j) {
+ if (result[j] >= *thresh) {
+ io___59.ciunit = *nounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+/* L190: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+ goto L160;
+L200:
+
+/* Summary */
+
+ dlasum_(path, nounit, &nerrs, &ntestt);
+
+
+
+ return 0;
+
+/* End of ZDRVSX */
+
+} /* zdrvsx_ */
diff --git a/TESTING/EIG/zdrvvx.c b/TESTING/EIG/zdrvvx.c
new file mode 100644
index 0000000..c1ed750
--- /dev/null
+++ b/TESTING/EIG/zdrvvx.c
@@ -0,0 +1,1091 @@
+/* zdrvvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__0 = 0;
+static integer c__4 = 4;
+static integer c__6 = 6;
+static doublereal c_b39 = 1.;
+static integer c__1 = 1;
+static doublereal c_b49 = 0.;
+static integer c__2 = 2;
+static logical c_false = FALSE_;
+static integer c__3 = 3;
+static integer c__7 = 7;
+static integer c__5 = 5;
+static logical c_true = TRUE_;
+static integer c__22 = 22;
+
+/* Subroutine */ int zdrvvx_(integer *nsizes, integer *nn, integer *ntypes,
+ logical *dotype, integer *iseed, doublereal *thresh, integer *niunit,
+ integer *nounit, doublecomplex *a, integer *lda, doublecomplex *h__,
+ doublecomplex *w, doublecomplex *w1, doublecomplex *vl, integer *ldvl,
+ doublecomplex *vr, integer *ldvr, doublecomplex *lre, integer *ldlre,
+ doublereal *rcondv, doublereal *rcndv1, doublereal *rcdvin,
+ doublereal *rconde, doublereal *rcnde1, doublereal *rcdein,
+ doublereal *scale, doublereal *scale1, doublereal *result,
+ doublecomplex *work, integer *nwork, doublereal *rwork, integer *info)
+{
+ /* Initialized data */
+
+ static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
+ static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
+ static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
+ static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
+ static char bal[1*4] = "N" "P" "S" "B";
+
+ /* Format strings */
+ static char fmt_9992[] = "(\002 ZDRVVX: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(/1x,a3,\002 -- Complex Eigenvalue-Eigenvect"
+ "or \002,\002Decomposition Expert Driver\002,/\002 Matrix types ("
+ "see ZDRVVX for details): \002)";
+ static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
+ "rix. \002,\002 \002,\002 5=Diagonal: geom"
+ "etr. spaced entries.\002,/\002 2=Identity matrix. "
+ " \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
+ "/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
+ " 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
+ "l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
+ "ll, evenly spaced.\002)";
+ static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
+ " 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
+ "l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
+ "d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
+ "red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
+ "vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
+ " 12=Well-cond., random complex \002,\002 \002,\002 17=Il"
+ "l-cond., large rand. complx \002,/\002 13=Ill-condi\002,\002tion"
+ "ed, evenly spaced. \002,\002 18=Ill-cond., small rand.\002"
+ ",\002 complx \002)";
+ static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
+ " \002,\002 21=Matrix \002,\002with small random entries.\002,"
+ "/\002 20=Matrix with large ran\002,\002dom entries. \002,\002 "
+ "22=Matrix read from input file\002,/)";
+ static char fmt_9995[] = "(\002 Tests performed with test threshold ="
+ "\002,f8.2,//\002 1 = | A VR - VR W | / ( n |A| ulp ) \002,/\002 "
+ "2 = | transpose(A) VL - VL W | / ( n |A| ulp ) \002,/\002 3 = | "
+ "|VR(i)| - 1 | / ulp \002,/\002 4 = | |VL(i)| - 1 | / ulp \002,"
+ "/\002 5 = 0 if W same no matter if VR or VL computed,\002,\002 1"
+ "/ulp otherwise\002,/\002 6 = 0 if VR same no matter what else co"
+ "mputed,\002,\002 1/ulp otherwise\002,/\002 7 = 0 if VL same no "
+ "matter what else computed,\002,\002 1/ulp otherwise\002,/\002 8"
+ " = 0 if RCONDV same no matter what else computed,\002,\002 1/ul"
+ "p otherwise\002,/\002 9 = 0 if SCALE, ILO, IHI, ABNRM same no ma"
+ "tter what else\002,\002 computed, 1/ulp otherwise\002,/\002 10 "
+ "= | RCONDV - RCONDV(precomputed) | / cond(RCONDV),\002,/\002 11 "
+ "= | RCONDE - RCONDE(precomputed) | / cond(RCONDE),\002)";
+ static char fmt_9994[] = "(\002 BALANC='\002,a1,\002',N=\002,i4,\002,I"
+ "WK=\002,i1,\002, seed=\002,4(i4,\002,\002),\002 type \002,i2,"
+ "\002, test(\002,i2,\002)=\002,g10.3)";
+ static char fmt_9993[] = "(\002 N=\002,i5,\002, input example =\002,i3"
+ ",\002, test(\002,i2,\002)=\002,g10.3)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1,
+ vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+
+ /* Local variables */
+ integer i__, j, n;
+ doublereal wi, wr;
+ integer iwk;
+ doublereal ulp;
+ integer ibal;
+ doublereal cond;
+ integer jcol;
+ char path[3];
+ integer nmax;
+ doublereal unfl, ovfl;
+ integer isrt;
+ logical badnn;
+ integer nfail, imode, iinfo;
+ doublereal conds, anorm;
+ extern /* Subroutine */ int zget23_(logical *, integer *, char *, integer
+ *, doublereal *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublecomplex *,
+ integer *, doublereal *, integer *);
+ integer jsize, nerrs, itype, jtype, ntest;
+ doublereal rtulp;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ char balanc[1];
+ extern doublereal dlamch_(char *);
+ integer idumma[1];
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer ioldsd[4];
+ extern /* Subroutine */ int dlasum_(char *, integer *, integer *, integer
+ *), zlatme_(integer *, char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublecomplex *, char *, char *, char *,
+ char *, doublereal *, integer *, doublereal *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *);
+ integer ntestf;
+ extern /* Subroutine */ int zlatmr_(integer *, integer *, char *, integer
+ *, char *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, char *, char *, doublecomplex *, integer *,
+ doublereal *, doublecomplex *, integer *, doublereal *, char *,
+ integer *, integer *, integer *, doublereal *, doublereal *, char
+ *, doublecomplex *, integer *, integer *, integer *), zlatms_(integer *,
+ integer *, char *, integer *, char *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *, char *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal ulpinv;
+ integer nnwork;
+ doublereal rtulpi;
+ integer mtypes, ntestt;
+
+ /* Fortran I/O blocks */
+ static cilist io___32 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___45 = { 0, 0, 1, 0, 0 };
+ static cilist io___48 = { 0, 0, 0, 0, 0 };
+ static cilist io___49 = { 0, 0, 0, 0, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9993, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVVX checks the nonsymmetric eigenvalue problem expert driver */
+/* ZGEEVX. */
+
+/* ZDRVVX uses both test matrices generated randomly depending on */
+/* data supplied in the calling sequence, as well as on data */
+/* read from an input file and including precomputed condition */
+/* numbers to which it compares the ones it computes. */
+
+/* When ZDRVVX is called, a number of matrix "sizes" ("n's") and a */
+/* number of matrix "types" are specified in the calling sequence. */
+/* For each size ("n") and each type of matrix, one matrix will be */
+/* generated and used to test the nonsymmetric eigenroutines. For */
+/* each matrix, 9 tests will be performed: */
+
+/* (1) | A * VR - VR * W | / ( n |A| ulp ) */
+
+/* Here VR is the matrix of unit right eigenvectors. */
+/* W is a diagonal matrix with diagonal entries W(j). */
+
+/* (2) | A**H * VL - VL * W**H | / ( n |A| ulp ) */
+
+/* Here VL is the matrix of unit left eigenvectors, A**H is the */
+/* conjugate transpose of A, and W is as above. */
+
+/* (3) | |VR(i)| - 1 | / ulp and largest component real */
+
+/* VR(i) denotes the i-th column of VR. */
+
+/* (4) | |VL(i)| - 1 | / ulp and largest component real */
+
+/* VL(i) denotes the i-th column of VL. */
+
+/* (5) W(full) = W(partial) */
+
+/* W(full) denotes the eigenvalues computed when VR, VL, RCONDV */
+/* and RCONDE are also computed, and W(partial) denotes the */
+/* eigenvalues computed when only some of VR, VL, RCONDV, and */
+/* RCONDE are computed. */
+
+/* (6) VR(full) = VR(partial) */
+
+/* VR(full) denotes the right eigenvectors computed when VL, RCONDV */
+/* and RCONDE are computed, and VR(partial) denotes the result */
+/* when only some of VL and RCONDV are computed. */
+
+/* (7) VL(full) = VL(partial) */
+
+/* VL(full) denotes the left eigenvectors computed when VR, RCONDV */
+/* and RCONDE are computed, and VL(partial) denotes the result */
+/* when only some of VR and RCONDV are computed. */
+
+/* (8) 0 if SCALE, ILO, IHI, ABNRM (full) = */
+/* SCALE, ILO, IHI, ABNRM (partial) */
+/* 1/ulp otherwise */
+
+/* SCALE, ILO, IHI and ABNRM describe how the matrix is balanced. */
+/* (full) is when VR, VL, RCONDE and RCONDV are also computed, and */
+/* (partial) is when some are not computed. */
+
+/* (9) RCONDV(full) = RCONDV(partial) */
+
+/* RCONDV(full) denotes the reciprocal condition numbers of the */
+/* right eigenvectors computed when VR, VL and RCONDE are also */
+/* computed. RCONDV(partial) denotes the reciprocal condition */
+/* numbers when only some of VR, VL and RCONDE are computed. */
+
+/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
+/* each element NN(j) specifies one size. */
+/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
+/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
+/* Currently, the list of possible types is: */
+
+/* (1) The zero matrix. */
+/* (2) The identity matrix. */
+/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
+
+/* (4) A diagonal matrix with evenly spaced entries */
+/* 1, ..., ULP and random complex angles. */
+/* (ULP = (first number larger than 1) - 1 ) */
+/* (5) A diagonal matrix with geometrically spaced entries */
+/* 1, ..., ULP and random complex angles. */
+/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
+/* and random complex angles. */
+
+/* (7) Same as (4), but multiplied by a constant near */
+/* the overflow threshold */
+/* (8) Same as (4), but multiplied by a constant near */
+/* the underflow threshold */
+
+/* (9) A matrix of the form U' T U, where U is unitary and */
+/* T has evenly spaced entries 1, ..., ULP with random complex */
+/* angles on the diagonal and random O(1) entries in the upper */
+/* triangle. */
+
+/* (10) A matrix of the form U' T U, where U is unitary and */
+/* T has geometrically spaced entries 1, ..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (11) A matrix of the form U' T U, where U is unitary and */
+/* T has "clustered" entries 1, ULP,..., ULP with random */
+/* complex angles on the diagonal and random O(1) entries in */
+/* the upper triangle. */
+
+/* (12) A matrix of the form U' T U, where U is unitary and */
+/* T has complex eigenvalues randomly chosen from */
+/* ULP < |z| < 1 and random O(1) entries in the upper */
+/* triangle. */
+
+/* (13) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
+/* with random complex angles on the diagonal and random O(1) */
+/* entries in the upper triangle. */
+
+/* (14) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has geometrically spaced entries */
+/* 1, ..., ULP with random complex angles on the diagonal */
+/* and random O(1) entries in the upper triangle. */
+
+/* (15) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
+/* with random complex angles on the diagonal and random O(1) */
+/* entries in the upper triangle. */
+
+/* (16) A matrix of the form X' T X, where X has condition */
+/* SQRT( ULP ) and T has complex eigenvalues randomly chosen */
+/* from ULP < |z| < 1 and random O(1) entries in the upper */
+/* triangle. */
+
+/* (17) Same as (16), but multiplied by a constant */
+/* near the overflow threshold */
+/* (18) Same as (16), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* (19) Nonsymmetric matrix with random entries chosen from |z| < 1 */
+/* If N is at least 4, all entries in first two rows and last */
+/* row, and first column and last two columns are zero. */
+/* (20) Same as (19), but multiplied by a constant */
+/* near the overflow threshold */
+/* (21) Same as (19), but multiplied by a constant */
+/* near the underflow threshold */
+
+/* In addition, an input file will be read from logical unit number */
+/* NIUNIT. The file contains matrices along with precomputed */
+/* eigenvalues and reciprocal condition numbers for the eigenvalues */
+/* and right eigenvectors. For these matrices, in addition to tests */
+/* (1) to (9) we will compute the following two tests: */
+
+/* (10) |RCONDV - RCDVIN| / cond(RCONDV) */
+
+/* RCONDV is the reciprocal right eigenvector condition number */
+/* computed by ZGEEVX and RCDVIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDV) is the condition number of */
+/* RCONDV, and takes errors in computing RCONDV into account, so */
+/* that the resulting quantity should be O(ULP). cond(RCONDV) is */
+/* essentially given by norm(A)/RCONDE. */
+
+/* (11) |RCONDE - RCDEIN| / cond(RCONDE) */
+
+/* RCONDE is the reciprocal eigenvalue condition number */
+/* computed by ZGEEVX and RCDEIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDE) is the condition number */
+/* of RCONDE, and takes errors in computing RCONDE into account, */
+/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
+/* is essentially given by norm(A)/RCONDV. */
+
+/* Arguments */
+/* ========== */
+
+/* NSIZES (input) INTEGER */
+/* The number of sizes of matrices to use. NSIZES must be at */
+/* least zero. If it is zero, no randomly generated matrices */
+/* are tested, but any test matrices read from NIUNIT will be */
+/* tested. */
+
+/* NN (input) INTEGER array, dimension (NSIZES) */
+/* An array containing the sizes to be used for the matrices. */
+/* Zero values will be skipped. The values must be at least */
+/* zero. */
+
+/* NTYPES (input) INTEGER */
+/* The number of elements in DOTYPE. NTYPES must be at least */
+/* zero. If it is zero, no randomly generated test matrices */
+/* are tested, but and test matrices read from NIUNIT will be */
+/* tested. If it is MAXTYP+1 and NSIZES is 1, then an */
+/* additional type, MAXTYP+1 is defined, which is to use */
+/* whatever matrix is in A. This is only useful if */
+/* DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. . */
+
+/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
+/* If DOTYPE(j) is .TRUE., then for each size in NN a */
+/* matrix of that size and of type j will be generated. */
+/* If NTYPES is smaller than the maximum number of types */
+/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
+/* MAXTYP will not be generated. If NTYPES is larger */
+/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
+/* will be ignored. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to ZDRVVX to continue the same random number */
+/* sequence. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NIUNIT (input) INTEGER */
+/* The FORTRAN unit number for reading in the data file of */
+/* problems to solve. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* A (workspace) COMPLEX*16 array, dimension (LDA, max(NN,12)) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. On exit, A contains the last matrix actually used. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, and H. LDA must be at */
+/* least 1 and at least max( NN, 12 ). (12 is the */
+/* dimension of the largest matrix on the precomputed */
+/* input file.) */
+
+/* H (workspace) COMPLEX*16 array, dimension (LDA, max(NN,12)) */
+/* Another copy of the test matrix A, modified by ZGEEVX. */
+
+/* W (workspace) COMPLEX*16 array, dimension (max(NN,12)) */
+/* Contains the eigenvalues of A. */
+
+/* W1 (workspace) COMPLEX*16 array, dimension (max(NN,12)) */
+/* Like W, this array contains the eigenvalues of A, */
+/* but those computed when ZGEEVX only computes a partial */
+/* eigendecomposition, i.e. not the eigenvalues and left */
+/* and right eigenvectors. */
+
+/* VL (workspace) COMPLEX*16 array, dimension (LDVL, max(NN,12)) */
+/* VL holds the computed left eigenvectors. */
+
+/* LDVL (input) INTEGER */
+/* Leading dimension of VL. Must be at least max(1,max(NN,12)). */
+
+/* VR (workspace) COMPLEX*16 array, dimension (LDVR, max(NN,12)) */
+/* VR holds the computed right eigenvectors. */
+
+/* LDVR (input) INTEGER */
+/* Leading dimension of VR. Must be at least max(1,max(NN,12)). */
+
+/* LRE (workspace) COMPLEX*16 array, dimension (LDLRE, max(NN,12)) */
+/* LRE holds the computed right or left eigenvectors. */
+
+/* LDLRE (input) INTEGER */
+/* Leading dimension of LRE. Must be at least max(1,max(NN,12)) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (11) */
+/* The values computed by the seven tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (NWORK) */
+
+/* NWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* max(6*12+2*12**2,6*NN(j)+2*NN(j)**2) = */
+/* max( 360 ,6*NN(j)+2*NN(j)**2) for all j. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*max(NN,12)) */
+
+/* INFO (output) INTEGER */
+/* If 0, then successful exit. */
+/* If <0, then input paramter -INFO is incorrect. */
+/* If >0, ZLATMR, CLATMS, CLATME or ZGET23 returned an error */
+/* code, and INFO is its absolute value. */
+
+/* ----------------------------------------------------------------------- */
+
+/* Some Local Variables and Parameters: */
+/* ---- ----- --------- --- ---------- */
+
+/* ZERO, ONE Real 0 and 1. */
+/* MAXTYP The number of types defined. */
+/* NMAX Largest value in NN or 12. */
+/* NERRS The number of tests which have exceeded THRESH */
+/* COND, CONDS, */
+/* IMODE Values to be passed to the matrix generators. */
+/* ANORM Norm of A; passed to matrix generators. */
+
+/* OVFL, UNFL Overflow and underflow thresholds. */
+/* ULP, ULPINV Finest relative precision and its inverse. */
+/* RTULP, RTULPI Square roots of the previous 4 values. */
+
+/* The following four arrays decode JTYPE: */
+/* KTYPE(j) The general type (1-10) for type "j". */
+/* KMODE(j) The MODE value to be passed to the matrix */
+/* generator for type "j". */
+/* KMAGN(j) The order of magnitude ( O(1), */
+/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
+/* KCONDS(j) Selectw whether CONDS is to be 1 or */
+/* 1/sqrt(ulp). (0 means irrelevant.) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nn;
+ --dotype;
+ --iseed;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ --w1;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ lre_dim1 = *ldlre;
+ lre_offset = 1 + lre_dim1;
+ lre -= lre_offset;
+ --rcondv;
+ --rcndv1;
+ --rcdvin;
+ --rconde;
+ --rcnde1;
+ --rcdein;
+ --scale;
+ --scale1;
+ --result;
+ --work;
+ --rwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "VX", (ftnlen)2, (ftnlen)2);
+
+/* Check for errors */
+
+ ntestt = 0;
+ ntestf = 0;
+ *info = 0;
+
+/* Important constants */
+
+ badnn = FALSE_;
+
+/* 7 is the largest dimension in the input file of precomputed */
+/* problems */
+
+ nmax = 7;
+ i__1 = *nsizes;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = nmax, i__3 = nn[j];
+ nmax = max(i__2,i__3);
+ if (nn[j] < 0) {
+ badnn = TRUE_;
+ }
+/* L10: */
+ }
+
+/* Check for errors */
+
+ if (*nsizes < 0) {
+ *info = -1;
+ } else if (badnn) {
+ *info = -2;
+ } else if (*ntypes < 0) {
+ *info = -3;
+ } else if (*thresh < 0.) {
+ *info = -6;
+ } else if (*lda < 1 || *lda < nmax) {
+ *info = -10;
+ } else if (*ldvl < 1 || *ldvl < nmax) {
+ *info = -15;
+ } else if (*ldvr < 1 || *ldvr < nmax) {
+ *info = -17;
+ } else if (*ldlre < 1 || *ldlre < nmax) {
+ *info = -19;
+ } else /* if(complicated condition) */ {
+/* Computing 2nd power */
+ i__1 = nmax;
+ if (nmax * 6 + (i__1 * i__1 << 1) > *nwork) {
+ *info = -30;
+ }
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZDRVVX", &i__1);
+ return 0;
+ }
+
+/* If nothing to do check on NIUNIT */
+
+ if (*nsizes == 0 || *ntypes == 0) {
+ goto L160;
+ }
+
+/* More Important constants */
+
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ dlabad_(&unfl, &ovfl);
+ ulp = dlamch_("Precision");
+ ulpinv = 1. / ulp;
+ rtulp = sqrt(ulp);
+ rtulpi = 1. / rtulp;
+
+/* Loop over sizes, types */
+
+ nerrs = 0;
+
+ i__1 = *nsizes;
+ for (jsize = 1; jsize <= i__1; ++jsize) {
+ n = nn[jsize];
+ if (*nsizes != 1) {
+ mtypes = min(21,*ntypes);
+ } else {
+ mtypes = min(22,*ntypes);
+ }
+
+ i__2 = mtypes;
+ for (jtype = 1; jtype <= i__2; ++jtype) {
+ if (! dotype[jtype]) {
+ goto L140;
+ }
+
+/* Save ISEED in case of an error. */
+
+ for (j = 1; j <= 4; ++j) {
+ ioldsd[j - 1] = iseed[j];
+/* L20: */
+ }
+
+/* Compute "A" */
+
+/* Control parameters: */
+
+/* KMAGN KCONDS KMODE KTYPE */
+/* =1 O(1) 1 clustered 1 zero */
+/* =2 large large clustered 2 identity */
+/* =3 small exponential Jordan */
+/* =4 arithmetic diagonal, (w/ eigenvalues) */
+/* =5 random log symmetric, w/ eigenvalues */
+/* =6 random general, w/ eigenvalues */
+/* =7 random diagonal */
+/* =8 random symmetric */
+/* =9 random general */
+/* =10 random triangular */
+
+ if (mtypes > 21) {
+ goto L90;
+ }
+
+ itype = ktype[jtype - 1];
+ imode = kmode[jtype - 1];
+
+/* Compute norm */
+
+ switch (kmagn[jtype - 1]) {
+ case 1: goto L30;
+ case 2: goto L40;
+ case 3: goto L50;
+ }
+
+L30:
+ anorm = 1.;
+ goto L60;
+
+L40:
+ anorm = ovfl * ulp;
+ goto L60;
+
+L50:
+ anorm = unfl * ulpinv;
+ goto L60;
+
+L60:
+
+ zlaset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
+ iinfo = 0;
+ cond = ulpinv;
+
+/* Special Matrices -- Identity & Jordan block */
+
+/* Zero */
+
+ if (itype == 1) {
+ iinfo = 0;
+
+ } else if (itype == 2) {
+
+/* Identity */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ a[i__4].r = anorm, a[i__4].i = 0.;
+/* L70: */
+ }
+
+ } else if (itype == 3) {
+
+/* Jordan Block */
+
+ i__3 = n;
+ for (jcol = 1; jcol <= i__3; ++jcol) {
+ i__4 = jcol + jcol * a_dim1;
+ a[i__4].r = anorm, a[i__4].i = 0.;
+ if (jcol > 1) {
+ i__4 = jcol + (jcol - 1) * a_dim1;
+ a[i__4].r = 1., a[i__4].i = 0.;
+ }
+/* L80: */
+ }
+
+ } else if (itype == 4) {
+
+/* Diagonal Matrix, [Eigen]values Specified */
+
+ zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[
+ n + 1], &iinfo);
+
+ } else if (itype == 5) {
+
+/* Symmetric, eigenvalues specified */
+
+ zlatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &cond,
+ &anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
+ &iinfo);
+
+ } else if (itype == 6) {
+
+/* General, eigenvalues specified */
+
+ if (kconds[jtype - 1] == 1) {
+ conds = 1.;
+ } else if (kconds[jtype - 1] == 2) {
+ conds = rtulpi;
+ } else {
+ conds = 0.;
+ }
+
+ zlatme_(&n, "D", &iseed[1], &work[1], &imode, &cond, &c_b2,
+ " ", "T", "T", "T", &rwork[1], &c__4, &conds, &n, &n,
+ &anorm, &a[a_offset], lda, &work[(n << 1) + 1], &
+ iinfo);
+
+ } else if (itype == 7) {
+
+/* Diagonal, random eigenvalues */
+
+ zlatmr_(&n, &n, "D", &iseed[1], "S", &work[1], &c__6, &c_b39,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &c__0, &
+ c__0, &c_b49, &anorm, "NO", &a[a_offset], lda, idumma,
+ &iinfo);
+
+ } else if (itype == 8) {
+
+/* Symmetric, random eigenvalues */
+
+ zlatmr_(&n, &n, "D", &iseed[1], "H", &work[1], &c__6, &c_b39,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &n, &
+ c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
+ iinfo);
+
+ } else if (itype == 9) {
+
+/* General, random eigenvalues */
+
+ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b39,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &n, &
+ c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
+ iinfo);
+ if (n >= 4) {
+ zlaset_("Full", &c__2, &n, &c_b1, &c_b1, &a[a_offset],
+ lda);
+ i__3 = n - 3;
+ zlaset_("Full", &i__3, &c__1, &c_b1, &c_b1, &a[a_dim1 + 3]
+, lda);
+ i__3 = n - 3;
+ zlaset_("Full", &i__3, &c__2, &c_b1, &c_b1, &a[(n - 1) *
+ a_dim1 + 3], lda);
+ zlaset_("Full", &c__1, &n, &c_b1, &c_b1, &a[n + a_dim1],
+ lda);
+ }
+
+ } else if (itype == 10) {
+
+/* Triangular, random eigenvalues */
+
+ zlatmr_(&n, &n, "D", &iseed[1], "N", &work[1], &c__6, &c_b39,
+ &c_b2, "T", "N", &work[n + 1], &c__1, &c_b39, &work[(
+ n << 1) + 1], &c__1, &c_b39, "N", idumma, &n, &c__0, &
+ c_b49, &anorm, "NO", &a[a_offset], lda, idumma, &
+ iinfo);
+
+ } else {
+
+ iinfo = 1;
+ }
+
+ if (iinfo != 0) {
+ io___32.ciunit = *nounit;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "Generator", (ftnlen)9);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ return 0;
+ }
+
+L90:
+
+/* Test for minimal and generous workspace */
+
+ for (iwk = 1; iwk <= 3; ++iwk) {
+ if (iwk == 1) {
+ nnwork = n << 1;
+ } else if (iwk == 2) {
+/* Computing 2nd power */
+ i__3 = n;
+ nnwork = (n << 1) + i__3 * i__3;
+ } else {
+/* Computing 2nd power */
+ i__3 = n;
+ nnwork = n * 6 + (i__3 * i__3 << 1);
+ }
+ nnwork = max(nnwork,1);
+
+/* Test for all balancing options */
+
+ for (ibal = 1; ibal <= 4; ++ibal) {
+ *(unsigned char *)balanc = *(unsigned char *)&bal[ibal -
+ 1];
+
+/* Perform tests */
+
+ zget23_(&c_false, &c__0, balanc, &jtype, thresh, ioldsd,
+ nounit, &n, &a[a_offset], lda, &h__[h_offset], &w[
+ 1], &w1[1], &vl[vl_offset], ldvl, &vr[vr_offset],
+ ldvr, &lre[lre_offset], ldlre, &rcondv[1], &
+ rcndv1[1], &rcdvin[1], &rconde[1], &rcnde1[1], &
+ rcdein[1], &scale[1], &scale1[1], &result[1], &
+ work[1], &nnwork, &rwork[1], info);
+
+/* Check for RESULT(j) > THRESH */
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 9; ++j) {
+ if (result[j] >= 0.) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L100: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___39.ciunit = *nounit;
+ s_wsfe(&io___39);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___40.ciunit = *nounit;
+ s_wsfe(&io___40);
+ e_wsfe();
+ io___41.ciunit = *nounit;
+ s_wsfe(&io___41);
+ e_wsfe();
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ e_wsfe();
+ io___43.ciunit = *nounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ntestf = 2;
+ }
+
+ for (j = 1; j <= 9; ++j) {
+ if (result[j] >= *thresh) {
+ io___44.ciunit = *nounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, balanc, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ }
+/* L110: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+
+/* L120: */
+ }
+/* L130: */
+ }
+L140:
+ ;
+ }
+/* L150: */
+ }
+
+L160:
+
+/* Read in data from file to check accuracy of condition estimation. */
+/* Assume input eigenvalues are sorted lexicographically (increasing */
+/* by real part, then decreasing by imaginary part) */
+
+ jtype = 0;
+L170:
+ io___45.ciunit = *niunit;
+ i__1 = s_rsle(&io___45);
+ if (i__1 != 0) {
+ goto L220;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L220;
+ }
+ i__1 = do_lio(&c__3, &c__1, (char *)&isrt, (ftnlen)sizeof(integer));
+ if (i__1 != 0) {
+ goto L220;
+ }
+ i__1 = e_rsle();
+ if (i__1 != 0) {
+ goto L220;
+ }
+
+/* Read input data until N=0 */
+
+ if (n == 0) {
+ goto L220;
+ }
+ ++jtype;
+ iseed[1] = jtype;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___48.ciunit = *niunit;
+ s_rsle(&io___48);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
+ doublecomplex));
+ }
+ e_rsle();
+/* L180: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___49.ciunit = *niunit;
+ s_rsle(&io___49);
+ do_lio(&c__5, &c__1, (char *)&wr, (ftnlen)sizeof(doublereal));
+ do_lio(&c__5, &c__1, (char *)&wi, (ftnlen)sizeof(doublereal));
+ do_lio(&c__5, &c__1, (char *)&rcdein[i__], (ftnlen)sizeof(doublereal))
+ ;
+ do_lio(&c__5, &c__1, (char *)&rcdvin[i__], (ftnlen)sizeof(doublereal))
+ ;
+ e_rsle();
+ i__2 = i__;
+ z__1.r = wr, z__1.i = wi;
+ w1[i__2].r = z__1.r, w1[i__2].i = z__1.i;
+/* L190: */
+ }
+/* Computing 2nd power */
+ i__2 = n;
+ i__1 = n * 6 + (i__2 * i__2 << 1);
+ zget23_(&c_true, &isrt, "N", &c__22, thresh, &iseed[1], nounit, &n, &a[
+ a_offset], lda, &h__[h_offset], &w[1], &w1[1], &vl[vl_offset],
+ ldvl, &vr[vr_offset], ldvr, &lre[lre_offset], ldlre, &rcondv[1], &
+ rcndv1[1], &rcdvin[1], &rconde[1], &rcnde1[1], &rcdein[1], &scale[
+ 1], &scale1[1], &result[1], &work[1], &i__1, &rwork[1], info);
+
+/* Check for RESULT(j) > THRESH */
+
+ ntest = 0;
+ nfail = 0;
+ for (j = 1; j <= 11; ++j) {
+ if (result[j] >= 0.) {
+ ++ntest;
+ }
+ if (result[j] >= *thresh) {
+ ++nfail;
+ }
+/* L200: */
+ }
+
+ if (nfail > 0) {
+ ++ntestf;
+ }
+ if (ntestf == 1) {
+ io___52.ciunit = *nounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___53.ciunit = *nounit;
+ s_wsfe(&io___53);
+ e_wsfe();
+ io___54.ciunit = *nounit;
+ s_wsfe(&io___54);
+ e_wsfe();
+ io___55.ciunit = *nounit;
+ s_wsfe(&io___55);
+ e_wsfe();
+ io___56.ciunit = *nounit;
+ s_wsfe(&io___56);
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ntestf = 2;
+ }
+
+ for (j = 1; j <= 11; ++j) {
+ if (result[j] >= *thresh) {
+ io___57.ciunit = *nounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+/* L210: */
+ }
+
+ nerrs += nfail;
+ ntestt += ntest;
+ goto L170;
+L220:
+
+/* Summary */
+
+ dlasum_(path, nounit, &nerrs, &ntestt);
+
+
+
+ return 0;
+
+/* End of ZDRVVX */
+
+} /* zdrvvx_ */
diff --git a/TESTING/EIG/zerrbd.c b/TESTING/EIG/zerrbd.c
new file mode 100644
index 0000000..1e501ca
--- /dev/null
+++ b/TESTING/EIG/zerrbd.c
@@ -0,0 +1,354 @@
+/* zerrbd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int zerrbd_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
+ "rror exits (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
+ "ts of the error \002,\002exits ***\002)";
+
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublecomplex a[16] /* was [4][4] */;
+ doublereal d__[4], e[4];
+ integer i__, j;
+ doublecomplex u[16] /* was [4][4] */, v[16] /* was [4][4] */, w[4];
+ char c2[2];
+ integer nt;
+ doublecomplex tp[4], tq[4];
+ doublereal rw[16];
+ integer info;
+ extern /* Subroutine */ int zgebrd_(integer *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), zbdsqr_(char *, integer *, integer *,
+ integer *, integer *, doublereal *, doublereal *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *
+, doublereal *, integer *), zungbr_(char *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, integer *), zunmbr_(char *,
+ char *, char *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___16 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___17 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRBD tests the error exits for ZGEBRD, ZUNGBR, ZUNMBR, and ZBDSQR. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ d__1 = 1. / (doublereal) (i__ + j);
+ a[i__1].r = d__1, a[i__1].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+ nt = 0;
+
+/* Test error exits of the SVD routines. */
+
+ if (lsamen_(&c__2, c2, "BD")) {
+
+/* ZGEBRD */
+
+ s_copy(srnamc_1.srnamt, "ZGEBRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgebrd_(&c_n1, &c__0, a, &c__1, d__, e, tq, tp, w, &c__1, &info);
+ chkxer_("ZGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgebrd_(&c__0, &c_n1, a, &c__1, d__, e, tq, tp, w, &c__1, &info);
+ chkxer_("ZGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgebrd_(&c__2, &c__1, a, &c__1, d__, e, tq, tp, w, &c__2, &info);
+ chkxer_("ZGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zgebrd_(&c__2, &c__1, a, &c__2, d__, e, tq, tp, w, &c__1, &info);
+ chkxer_("ZGEBRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 4;
+
+/* ZUNGBR */
+
+ s_copy(srnamc_1.srnamt, "ZUNGBR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zungbr_("/", &c__0, &c__0, &c__0, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("ZUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zungbr_("Q", &c_n1, &c__0, &c__0, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("ZUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zungbr_("Q", &c__0, &c_n1, &c__0, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("ZUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zungbr_("Q", &c__0, &c__1, &c__0, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("ZUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zungbr_("Q", &c__1, &c__0, &c__1, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("ZUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zungbr_("P", &c__1, &c__0, &c__0, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("ZUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zungbr_("P", &c__0, &c__1, &c__1, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("ZUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zungbr_("Q", &c__0, &c__0, &c_n1, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("ZUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zungbr_("Q", &c__2, &c__1, &c__1, a, &c__1, tq, w, &c__1, &info);
+ chkxer_("ZUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zungbr_("Q", &c__2, &c__2, &c__1, a, &c__2, tq, w, &c__1, &info);
+ chkxer_("ZUNGBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* ZUNMBR */
+
+ s_copy(srnamc_1.srnamt, "ZUNMBR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zunmbr_("/", "L", "T", &c__0, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zunmbr_("Q", "/", "T", &c__0, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zunmbr_("Q", "L", "/", &c__0, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zunmbr_("Q", "L", "C", &c_n1, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunmbr_("Q", "L", "C", &c__0, &c_n1, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zunmbr_("Q", "L", "C", &c__0, &c__0, &c_n1, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zunmbr_("Q", "L", "C", &c__2, &c__0, &c__0, a, &c__1, tq, u, &c__2, w,
+ &c__1, &info);
+ chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zunmbr_("Q", "R", "C", &c__0, &c__2, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zunmbr_("P", "L", "C", &c__2, &c__0, &c__2, a, &c__1, tq, u, &c__2, w,
+ &c__1, &info);
+ chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zunmbr_("P", "R", "C", &c__0, &c__2, &c__2, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zunmbr_("Q", "R", "C", &c__2, &c__0, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__1, &info);
+ chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ zunmbr_("Q", "L", "C", &c__0, &c__2, &c__0, a, &c__1, tq, u, &c__1, w,
+ &c__0, &info);
+ chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ zunmbr_("Q", "R", "C", &c__2, &c__0, &c__0, a, &c__1, tq, u, &c__2, w,
+ &c__0, &info);
+ chkxer_("ZUNMBR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 13;
+
+/* ZBDSQR */
+
+ s_copy(srnamc_1.srnamt, "ZBDSQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zbdsqr_("/", &c__0, &c__0, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, rw, &info);
+ chkxer_("ZBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zbdsqr_("U", &c_n1, &c__0, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, rw, &info);
+ chkxer_("ZBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zbdsqr_("U", &c__0, &c_n1, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, rw, &info);
+ chkxer_("ZBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zbdsqr_("U", &c__0, &c__0, &c_n1, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, rw, &info);
+ chkxer_("ZBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zbdsqr_("U", &c__0, &c__0, &c__0, &c_n1, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, rw, &info);
+ chkxer_("ZBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zbdsqr_("U", &c__2, &c__1, &c__0, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, rw, &info);
+ chkxer_("ZBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zbdsqr_("U", &c__0, &c__0, &c__2, &c__0, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, rw, &info);
+ chkxer_("ZBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ zbdsqr_("U", &c__2, &c__0, &c__0, &c__1, d__, e, v, &c__1, u, &c__1,
+ a, &c__1, rw, &info);
+ chkxer_("ZBDSQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+ }
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___16.ciunit = infoc_1.nout;
+ s_wsfe(&io___16);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___17.ciunit = infoc_1.nout;
+ s_wsfe(&io___17);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of ZERRBD */
+
+} /* zerrbd_ */
diff --git a/TESTING/EIG/zerrec.c b/TESTING/EIG/zerrec.c
new file mode 100644
index 0000000..ad782f6
--- /dev/null
+++ b/TESTING/EIG/zerrec.c
@@ -0,0 +1,355 @@
+/* zerrec.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+
+/* Subroutine */ int zerrec_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
+ "rror exits (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
+ "ts of the error \002,\002exits ***\002)";
+
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublecomplex a[16] /* was [4][4] */, b[16] /* was [4][4] */, c__[16]
+ /* was [4][4] */;
+ integer i__, j, m;
+ doublereal s[4];
+ doublecomplex x[4];
+ integer nt;
+ doublereal rw[24];
+ logical sel[4];
+ doublereal sep[4];
+ integer info, ifst, ilst;
+ doublecomplex work[24];
+ doublereal scale;
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), ztrexc_(char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, integer *,
+ integer *), ztrsna_(char *, char *, logical *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *, integer *), ztrsen_(char *, char *, logical *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, integer *), ztrsyl_(
+ char *, char *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___18 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___19 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERREC tests the error exits for the routines for eigen- condition */
+/* estimation for DOUBLE PRECISION matrices: */
+/* ZTRSYL, CTREXC, CTRSNA and CTRSEN. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ infoc_1.ok = TRUE_;
+ nt = 0;
+
+/* Initialize A, B and SEL */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ a[i__1].r = 0., a[i__1].i = 0.;
+ i__1 = i__ + (j << 2) - 5;
+ b[i__1].r = 0., b[i__1].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (i__ << 2) - 5;
+ a[i__1].r = 1., a[i__1].i = 0.;
+ sel[i__ - 1] = TRUE_;
+/* L30: */
+ }
+
+/* Test ZTRSYL */
+
+ s_copy(srnamc_1.srnamt, "ZTRSYL", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztrsyl_("X", "N", &c__1, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztrsyl_("N", "X", &c__1, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ztrsyl_("N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ztrsyl_("N", "N", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrsyl_("N", "N", &c__1, &c__0, &c_n1, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ztrsyl_("N", "N", &c__1, &c__2, &c__0, a, &c__1, b, &c__1, c__, &c__2, &
+ scale, &info);
+ chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrsyl_("N", "N", &c__1, &c__0, &c__2, a, &c__1, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrsyl_("N", "N", &c__1, &c__2, &c__0, a, &c__2, b, &c__1, c__, &c__1, &
+ scale, &info);
+ chkxer_("ZTRSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Test ZTREXC */
+
+ s_copy(srnamc_1.srnamt, "ZTREXC", (ftnlen)32, (ftnlen)6);
+ ifst = 1;
+ ilst = 1;
+ infoc_1.infot = 1;
+ ztrexc_("X", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
+ chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ztrexc_("N", &c__0, a, &c__1, b, &c__1, &ifst, &ilst, &info);
+ chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ilst = 2;
+ ztrexc_("N", &c__2, a, &c__1, b, &c__1, &ifst, &ilst, &info);
+ chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrexc_("V", &c__2, a, &c__2, b, &c__1, &ifst, &ilst, &info);
+ chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ifst = 0;
+ ilst = 1;
+ ztrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
+ chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ifst = 2;
+ ztrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
+ chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ifst = 1;
+ ilst = 0;
+ ztrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
+ chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ilst = 2;
+ ztrexc_("V", &c__1, a, &c__1, b, &c__1, &ifst, &ilst, &info);
+ chkxer_("ZTREXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Test ZTRSNA */
+
+ s_copy(srnamc_1.srnamt, "ZTRSNA", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztrsna_("X", "A", sel, &c__0, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
+ c__1, &m, work, &c__1, rw, &info);
+ chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztrsna_("B", "X", sel, &c__0, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
+ c__1, &m, work, &c__1, rw, &info);
+ chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ztrsna_("B", "A", sel, &c_n1, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
+ c__1, &m, work, &c__1, rw, &info);
+ chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrsna_("V", "A", sel, &c__2, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
+ c__2, &m, work, &c__2, rw, &info);
+ chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ztrsna_("B", "A", sel, &c__2, a, &c__2, b, &c__1, c__, &c__2, s, sep, &
+ c__2, &m, work, &c__2, rw, &info);
+ chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ztrsna_("B", "A", sel, &c__2, a, &c__2, b, &c__2, c__, &c__1, s, sep, &
+ c__2, &m, work, &c__2, rw, &info);
+ chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ ztrsna_("B", "A", sel, &c__1, a, &c__1, b, &c__1, c__, &c__1, s, sep, &
+ c__0, &m, work, &c__1, rw, &info);
+ chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ ztrsna_("B", "S", sel, &c__2, a, &c__2, b, &c__2, c__, &c__2, s, sep, &
+ c__1, &m, work, &c__1, rw, &info);
+ chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ ztrsna_("B", "A", sel, &c__2, a, &c__2, b, &c__2, c__, &c__2, s, sep, &
+ c__2, &m, work, &c__1, rw, &info);
+ chkxer_("ZTRSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* Test ZTRSEN */
+
+ sel[0] = FALSE_;
+ s_copy(srnamc_1.srnamt, "ZTRSEN", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztrsen_("X", "N", sel, &c__0, a, &c__1, b, &c__1, x, &m, s, sep, work, &
+ c__1, &info);
+ chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztrsen_("N", "X", sel, &c__0, a, &c__1, b, &c__1, x, &m, s, sep, work, &
+ c__1, &info);
+ chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ztrsen_("N", "N", sel, &c_n1, a, &c__1, b, &c__1, x, &m, s, sep, work, &
+ c__1, &info);
+ chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrsen_("N", "N", sel, &c__2, a, &c__1, b, &c__1, x, &m, s, sep, work, &
+ c__2, &info);
+ chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ztrsen_("N", "V", sel, &c__2, a, &c__2, b, &c__1, x, &m, s, sep, work, &
+ c__1, &info);
+ chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ ztrsen_("N", "V", sel, &c__2, a, &c__2, b, &c__2, x, &m, s, sep, work, &
+ c__0, &info);
+ chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ ztrsen_("E", "V", sel, &c__3, a, &c__3, b, &c__3, x, &m, s, sep, work, &
+ c__1, &info);
+ chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ ztrsen_("V", "V", sel, &c__3, a, &c__3, b, &c__3, x, &m, s, sep, work, &
+ c__3, &info);
+ chkxer_("ZTRSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___18.ciunit = infoc_1.nout;
+ s_wsfe(&io___18);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___19.ciunit = infoc_1.nout;
+ s_wsfe(&io___19);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ return 0;
+
+/* End of ZERREC */
+
+} /* zerrec_ */
diff --git a/TESTING/EIG/zerred.c b/TESTING/EIG/zerred.c
new file mode 100644
index 0000000..bc0d566
--- /dev/null
+++ b/TESTING/EIG/zerred.c
@@ -0,0 +1,501 @@
+/* zerred.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ doublereal selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__4 = 4;
+static integer c__5 = 5;
+
+/* Subroutine */ int zerred_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002 passed the tests of the error exits"
+ " (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a,\002 failed the tests of the "
+ "error exits ***\002)";
+
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), i_len_trim(char *, ftnlen), do_fio(integer *,
+ char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublecomplex a[16] /* was [4][4] */;
+ logical b[4];
+ integer i__, j;
+ doublereal s[4];
+ doublecomplex u[16] /* was [4][4] */, w[16], x[4];
+ char c2[2];
+ doublereal r1[4], r2[4];
+ integer iw[16], nt;
+ doublecomplex vl[16] /* was [4][4] */, vr[16] /* was [4][4]
+ */;
+ doublereal rw[20];
+ doublecomplex vt[16] /* was [4][4] */;
+ integer ihi, ilo, info, sdim;
+ doublereal abnrm;
+ extern /* Subroutine */ int zgees_(char *, char *, L_fp, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, logical *, integer *), zgeev_(char *
+, char *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int zgesdd_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *, integer *), chkxer_(char *,
+ integer *, integer *, logical *, logical *), zgesvd_(char
+ *, char *, integer *, integer *, doublecomplex *, integer *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, integer *);
+ extern logical zslect_();
+ extern /* Subroutine */ int zgeesx_(char *, char *, L_fp, char *, integer
+ *, doublecomplex *, integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublereal *, logical *, integer *), zgeevx_(char *, char *, char *, char *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *
+, doublecomplex *, integer *, doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRED tests the error exits for the eigenvalue driver routines for */
+/* DOUBLE PRECISION matrices: */
+
+/* PATH driver description */
+/* ---- ------ ----------- */
+/* ZEV ZGEEV find eigenvalues/eigenvectors for nonsymmetric A */
+/* ZES ZGEES find eigenvalues/Schur form for nonsymmetric A */
+/* ZVX ZGEEVX ZGEEV + balancing and condition estimation */
+/* ZSX ZGEESX ZGEES + balancing and condition estimation */
+/* ZBD ZGESVD compute SVD of an M-by-N matrix A */
+/* ZGESDD compute SVD of an M-by-N matrix A(by divide and */
+/* conquer) */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Initialize A */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ a[i__1].r = 0., a[i__1].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (i__ << 2) - 5;
+ a[i__1].r = 1., a[i__1].i = 0.;
+/* L30: */
+ }
+ infoc_1.ok = TRUE_;
+ nt = 0;
+
+ if (lsamen_(&c__2, c2, "EV")) {
+
+/* Test ZGEEV */
+
+ s_copy(srnamc_1.srnamt, "ZGEEV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgeev_("X", "N", &c__0, a, &c__1, x, vl, &c__1, vr, &c__1, w, &c__1,
+ rw, &info);
+ chkxer_("ZGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgeev_("N", "X", &c__0, a, &c__1, x, vl, &c__1, vr, &c__1, w, &c__1,
+ rw, &info);
+ chkxer_("ZGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgeev_("N", "N", &c_n1, a, &c__1, x, vl, &c__1, vr, &c__1, w, &c__1,
+ rw, &info);
+ chkxer_("ZGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgeev_("N", "N", &c__2, a, &c__1, x, vl, &c__1, vr, &c__1, w, &c__4,
+ rw, &info);
+ chkxer_("ZGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zgeev_("V", "N", &c__2, a, &c__2, x, vl, &c__1, vr, &c__1, w, &c__4,
+ rw, &info);
+ chkxer_("ZGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zgeev_("N", "V", &c__2, a, &c__2, x, vl, &c__1, vr, &c__1, w, &c__4,
+ rw, &info);
+ chkxer_("ZGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zgeev_("V", "V", &c__1, a, &c__1, x, vl, &c__1, vr, &c__1, w, &c__1,
+ rw, &info);
+ chkxer_("ZGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+
+ } else if (lsamen_(&c__2, c2, "ES")) {
+
+/* Test ZGEES */
+
+ s_copy(srnamc_1.srnamt, "ZGEES ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgees_("X", "N", (L_fp)zslect_, &c__0, a, &c__1, &sdim, x, vl, &c__1,
+ w, &c__1, rw, b, &info);
+ chkxer_("ZGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgees_("N", "X", (L_fp)zslect_, &c__0, a, &c__1, &sdim, x, vl, &c__1,
+ w, &c__1, rw, b, &info);
+ chkxer_("ZGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgees_("N", "S", (L_fp)zslect_, &c_n1, a, &c__1, &sdim, x, vl, &c__1,
+ w, &c__1, rw, b, &info);
+ chkxer_("ZGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zgees_("N", "S", (L_fp)zslect_, &c__2, a, &c__1, &sdim, x, vl, &c__1,
+ w, &c__4, rw, b, &info);
+ chkxer_("ZGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zgees_("V", "S", (L_fp)zslect_, &c__2, a, &c__2, &sdim, x, vl, &c__1,
+ w, &c__4, rw, b, &info);
+ chkxer_("ZGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zgees_("N", "S", (L_fp)zslect_, &c__1, a, &c__1, &sdim, x, vl, &c__1,
+ w, &c__1, rw, b, &info);
+ chkxer_("ZGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+ } else if (lsamen_(&c__2, c2, "VX")) {
+
+/* Test ZGEEVX */
+
+ s_copy(srnamc_1.srnamt, "ZGEEVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgeevx_("X", "N", "N", "N", &c__0, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, rw, &info);
+ chkxer_("ZGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgeevx_("N", "X", "N", "N", &c__0, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, rw, &info);
+ chkxer_("ZGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgeevx_("N", "N", "X", "N", &c__0, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, rw, &info);
+ chkxer_("ZGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgeevx_("N", "N", "N", "X", &c__0, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, rw, &info);
+ chkxer_("ZGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgeevx_("N", "N", "N", "N", &c_n1, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, rw, &info);
+ chkxer_("ZGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zgeevx_("N", "N", "N", "N", &c__2, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &ilo, &ihi, s, &abnrm, r1, r2, w, &c__4, rw, &info);
+ chkxer_("ZGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zgeevx_("N", "V", "N", "N", &c__2, a, &c__2, x, vl, &c__1, vr, &c__1,
+ &ilo, &ihi, s, &abnrm, r1, r2, w, &c__4, rw, &info);
+ chkxer_("ZGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zgeevx_("N", "N", "V", "N", &c__2, a, &c__2, x, vl, &c__1, vr, &c__1,
+ &ilo, &ihi, s, &abnrm, r1, r2, w, &c__4, rw, &info);
+ chkxer_("ZGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ zgeevx_("N", "N", "N", "N", &c__1, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, rw, &info);
+ chkxer_("ZGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ zgeevx_("N", "N", "V", "V", &c__1, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &ilo, &ihi, s, &abnrm, r1, r2, w, &c__2, rw, &info);
+ chkxer_("ZGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+ } else if (lsamen_(&c__2, c2, "SX")) {
+
+/* Test ZGEESX */
+
+ s_copy(srnamc_1.srnamt, "ZGEESX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgeesx_("X", "N", (L_fp)zslect_, "N", &c__0, a, &c__1, &sdim, x, vl, &
+ c__1, r1, r2, w, &c__1, rw, b, &info);
+ chkxer_("ZGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgeesx_("N", "X", (L_fp)zslect_, "N", &c__0, a, &c__1, &sdim, x, vl, &
+ c__1, r1, r2, w, &c__1, rw, b, &info);
+ chkxer_("ZGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgeesx_("N", "N", (L_fp)zslect_, "X", &c__0, a, &c__1, &sdim, x, vl, &
+ c__1, r1, r2, w, &c__1, rw, b, &info);
+ chkxer_("ZGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgeesx_("N", "N", (L_fp)zslect_, "N", &c_n1, a, &c__1, &sdim, x, vl, &
+ c__1, r1, r2, w, &c__1, rw, b, &info);
+ chkxer_("ZGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zgeesx_("N", "N", (L_fp)zslect_, "N", &c__2, a, &c__1, &sdim, x, vl, &
+ c__1, r1, r2, w, &c__4, rw, b, &info);
+ chkxer_("ZGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zgeesx_("V", "N", (L_fp)zslect_, "N", &c__2, a, &c__2, &sdim, x, vl, &
+ c__1, r1, r2, w, &c__4, rw, b, &info);
+ chkxer_("ZGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ zgeesx_("N", "N", (L_fp)zslect_, "N", &c__1, a, &c__1, &sdim, x, vl, &
+ c__1, r1, r2, w, &c__1, rw, b, &info);
+ chkxer_("ZGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+
+ } else if (lsamen_(&c__2, c2, "BD")) {
+
+/* Test ZGESVD */
+
+ s_copy(srnamc_1.srnamt, "ZGESVD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgesvd_("X", "N", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__1, rw, &info);
+ chkxer_("ZGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgesvd_("N", "X", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__1, rw, &info);
+ chkxer_("ZGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgesvd_("O", "O", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__1, rw, &info);
+ chkxer_("ZGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgesvd_("N", "N", &c_n1, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__1, rw, &info);
+ chkxer_("ZGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgesvd_("N", "N", &c__0, &c_n1, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__1, rw, &info);
+ chkxer_("ZGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zgesvd_("N", "N", &c__2, &c__1, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__5, rw, &info);
+ chkxer_("ZGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zgesvd_("A", "N", &c__2, &c__1, a, &c__2, s, u, &c__1, vt, &c__1, w, &
+ c__5, rw, &info);
+ chkxer_("ZGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zgesvd_("N", "A", &c__1, &c__2, a, &c__1, s, u, &c__1, vt, &c__1, w, &
+ c__5, rw, &info);
+ chkxer_("ZGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+ if (infoc_1.ok) {
+ io___23.ciunit = infoc_1.nout;
+ s_wsfe(&io___23);
+ do_fio(&c__1, srnamc_1.srnamt, i_len_trim(srnamc_1.srnamt, (
+ ftnlen)32));
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___24.ciunit = infoc_1.nout;
+ s_wsfe(&io___24);
+ e_wsfe();
+ }
+
+/* Test ZGESDD */
+
+ s_copy(srnamc_1.srnamt, "ZGESDD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgesdd_("X", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
+ rw, iw, &info);
+ chkxer_("ZGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgesdd_("N", &c_n1, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
+ rw, iw, &info);
+ chkxer_("ZGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgesdd_("N", &c__0, &c_n1, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
+ rw, iw, &info);
+ chkxer_("ZGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgesdd_("N", &c__2, &c__1, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__5,
+ rw, iw, &info);
+ chkxer_("ZGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zgesdd_("A", &c__2, &c__1, a, &c__2, s, u, &c__1, vt, &c__1, w, &c__5,
+ rw, iw, &info);
+ chkxer_("ZGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zgesdd_("A", &c__1, &c__2, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__5,
+ rw, iw, &info);
+ chkxer_("ZGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += -2;
+ if (infoc_1.ok) {
+ io___26.ciunit = infoc_1.nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, srnamc_1.srnamt, i_len_trim(srnamc_1.srnamt, (
+ ftnlen)32));
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___27.ciunit = infoc_1.nout;
+ s_wsfe(&io___27);
+ e_wsfe();
+ }
+ }
+
+/* Print a summary line. */
+
+ if (! lsamen_(&c__2, c2, "BD")) {
+ if (infoc_1.ok) {
+ io___28.ciunit = infoc_1.nout;
+ s_wsfe(&io___28);
+ do_fio(&c__1, srnamc_1.srnamt, i_len_trim(srnamc_1.srnamt, (
+ ftnlen)32));
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___29.ciunit = infoc_1.nout;
+ s_wsfe(&io___29);
+ e_wsfe();
+ }
+ }
+
+ return 0;
+
+/* End of ZERRED */
+
+} /* zerred_ */
diff --git a/TESTING/EIG/zerrgg.c b/TESTING/EIG/zerrgg.c
new file mode 100644
index 0000000..d3a8537
--- /dev/null
+++ b/TESTING/EIG/zerrgg.c
@@ -0,0 +1,1314 @@
+/* zerrgg.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__18 = 18;
+static integer c__32 = 32;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+static integer c_n5 = -5;
+static integer c__20 = 20;
+static integer c__5 = 5;
+
+/* Subroutine */ int zerrgg_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
+ "rror exits (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
+ "ts of the error \002,\002exits ***\002)";
+
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublecomplex a[9] /* was [3][3] */, b[9] /* was [3][3] */;
+ integer i__, j, m;
+ doublecomplex q[9] /* was [3][3] */, u[9] /* was [3][3] */, v[9] /*
+ was [3][3] */, w[18], z__[9] /* was [3][3] */;
+ char c2[2];
+ doublereal r1[3], r2[3];
+ logical bw[3];
+ doublereal ls[3];
+ integer iw[18], nt;
+ doublereal rs[3], rw[18], dif, rce[3];
+ logical sel[3];
+ doublecomplex tau[3];
+ doublereal rcv[3];
+ doublecomplex beta[3];
+ integer info, sdim;
+ doublereal anrm, bnrm, tola, tolb;
+ integer ifst, ilst;
+ doublecomplex alpha[3];
+ doublereal scale;
+ extern /* Subroutine */ int zgges_(char *, char *, char *, L_fp, integer *
+, doublecomplex *, integer *, doublecomplex *, integer *, integer
+ *, doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, logical *, integer *),
+ zggev_(char *, char *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, integer *);
+ integer ncycle;
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), zgghrd_(char *, char *, integer *, integer
+ *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *), zggglm_(integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex
+ *, integer *, integer *), zgglse_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, integer *), zggqrf_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *)
+ , zggrqf_(integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *), ztgevc_(
+ char *, char *, logical *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *, doublecomplex *,
+ doublereal *, integer *);
+ extern logical zlctes_();
+ extern /* Subroutine */ int zggsvd_(char *, char *, char *, integer *,
+ integer *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublereal *,
+ integer *, integer *);
+ integer dummyk, dummyl;
+ extern /* Subroutine */ int zggesx_(char *, char *, char *, L_fp, char *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublereal *, integer *, integer *,
+ logical *, integer *), zhgeqz_(
+ char *, char *, char *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *), zggevx_(char *,
+ char *, char *, char *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *
+, doublereal *, doublereal *, doublecomplex *, integer *,
+ doublereal *, integer *, logical *, integer *), ztgexc_(logical *, logical *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ integer *, integer *), ztgsen_(integer *, logical *, logical *,
+ logical *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, doublecomplex *, integer *, integer *,
+ integer *, integer *), ztgsja_(char *, char *, char *, integer *,
+ integer *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *),
+ ztgsna_(char *, char *, logical *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *, integer *
+, integer *, doublecomplex *, integer *, integer *, integer *), zggsvp_(char *, char *, char *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, doublereal *,
+ doublecomplex *, doublecomplex *, integer *);
+ extern logical zlctsx_();
+ extern /* Subroutine */ int ztgsyl_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, integer *, integer *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRGG tests the error exits for ZGGES, ZGGESX, ZGGEV, ZGGEVX, */
+/* ZGGGLM, ZGGHRD, ZGGLSE, ZGGQRF, ZGGRQF, ZGGSVD, ZGGSVP, ZHGEQZ, */
+/* ZTGEVC, ZTGEXC, ZTGSEN, ZTGSJA, ZTGSNA, and ZTGSYL. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 3; ++j) {
+ sel[j - 1] = TRUE_;
+ for (i__ = 1; i__ <= 3; ++i__) {
+ i__1 = i__ + j * 3 - 4;
+ a[i__1].r = 0., a[i__1].i = 0.;
+ i__1 = i__ + j * 3 - 4;
+ b[i__1].r = 0., b[i__1].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ for (i__ = 1; i__ <= 3; ++i__) {
+ i__1 = i__ + i__ * 3 - 4;
+ a[i__1].r = 1., a[i__1].i = 0.;
+ i__1 = i__ + i__ * 3 - 4;
+ b[i__1].r = 1., b[i__1].i = 0.;
+/* L30: */
+ }
+ infoc_1.ok = TRUE_;
+ tola = 1.;
+ tolb = 1.;
+ ifst = 1;
+ ilst = 1;
+ nt = 0;
+
+/* Test error exits for the GG path. */
+
+ if (lsamen_(&c__2, c2, "GG")) {
+
+/* ZGGHRD */
+
+ s_copy(srnamc_1.srnamt, "ZGGHRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgghrd_("/", "N", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("ZGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgghrd_("N", "/", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("ZGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgghrd_("N", "N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("ZGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgghrd_("N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("ZGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgghrd_("N", "N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("ZGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zgghrd_("N", "N", &c__2, &c__1, &c__1, a, &c__1, b, &c__2, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("ZGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zgghrd_("N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__1, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("ZGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zgghrd_("V", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("ZGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ zgghrd_("N", "V", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, q, &c__1,
+ z__, &c__1, &info);
+ chkxer_("ZGGHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* ZHGEQZ */
+
+ s_copy(srnamc_1.srnamt, "ZHGEQZ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhgeqz_("/", "N", "N", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, alpha,
+ beta, q, &c__1, z__, &c__1, w, &c__1, rw, &info);
+ chkxer_("ZHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhgeqz_("E", "/", "N", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, alpha,
+ beta, q, &c__1, z__, &c__1, w, &c__1, rw, &info);
+ chkxer_("ZHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zhgeqz_("E", "N", "/", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, alpha,
+ beta, q, &c__1, z__, &c__1, w, &c__1, rw, &info);
+ chkxer_("ZHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zhgeqz_("E", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, alpha,
+ beta, q, &c__1, z__, &c__1, w, &c__1, rw, &info);
+ chkxer_("ZHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zhgeqz_("E", "N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, alpha,
+ beta, q, &c__1, z__, &c__1, w, &c__1, rw, &info);
+ chkxer_("ZHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zhgeqz_("E", "N", "N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, alpha,
+ beta, q, &c__1, z__, &c__1, w, &c__1, rw, &info);
+ chkxer_("ZHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zhgeqz_("E", "N", "N", &c__2, &c__1, &c__1, a, &c__1, b, &c__2, alpha,
+ beta, q, &c__1, z__, &c__1, w, &c__1, rw, &info);
+ chkxer_("ZHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zhgeqz_("E", "N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__1, alpha,
+ beta, q, &c__1, z__, &c__1, w, &c__1, rw, &info);
+ chkxer_("ZHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ zhgeqz_("E", "V", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, alpha,
+ beta, q, &c__1, z__, &c__1, w, &c__1, rw, &info);
+ chkxer_("ZHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ zhgeqz_("E", "N", "V", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, alpha,
+ beta, q, &c__1, z__, &c__1, w, &c__1, rw, &info);
+ chkxer_("ZHGEQZ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* ZTGEVC */
+
+ s_copy(srnamc_1.srnamt, "ZTGEVC", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztgevc_("/", "A", sel, &c__0, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__1, &c__0, &m, w, rw, &info);
+ chkxer_("ZTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztgevc_("R", "/", sel, &c__0, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__1, &c__0, &m, w, rw, &info);
+ chkxer_("ZTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ztgevc_("R", "A", sel, &c_n1, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__1, &c__0, &m, w, rw, &info);
+ chkxer_("ZTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ztgevc_("R", "A", sel, &c__2, a, &c__1, b, &c__2, q, &c__1, z__, &
+ c__2, &c__0, &m, w, rw, &info);
+ chkxer_("ZTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ztgevc_("R", "A", sel, &c__2, a, &c__2, b, &c__1, q, &c__1, z__, &
+ c__2, &c__0, &m, w, rw, &info);
+ chkxer_("ZTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ztgevc_("L", "A", sel, &c__2, a, &c__2, b, &c__2, q, &c__1, z__, &
+ c__1, &c__0, &m, w, rw, &info);
+ chkxer_("ZTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ ztgevc_("R", "A", sel, &c__2, a, &c__2, b, &c__2, q, &c__1, z__, &
+ c__1, &c__0, &m, w, rw, &info);
+ chkxer_("ZTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ ztgevc_("R", "A", sel, &c__2, a, &c__2, b, &c__2, q, &c__1, z__, &
+ c__2, &c__1, &m, w, rw, &info);
+ chkxer_("ZTGEVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Test error exits for the GSV path. */
+
+ } else if (lsamen_(&c__3, path, "GSV")) {
+
+/* ZGGSVD */
+
+ s_copy(srnamc_1.srnamt, "ZGGSVD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zggsvd_("/", "N", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, rw,
+ iw, &info);
+ chkxer_("ZGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zggsvd_("N", "/", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, rw,
+ iw, &info);
+ chkxer_("ZGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zggsvd_("N", "N", "/", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, rw,
+ iw, &info);
+ chkxer_("ZGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zggsvd_("N", "N", "N", &c_n1, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, rw,
+ iw, &info);
+ chkxer_("ZGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zggsvd_("N", "N", "N", &c__0, &c_n1, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, rw,
+ iw, &info);
+ chkxer_("ZGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zggsvd_("N", "N", "N", &c__0, &c__0, &c_n1, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, rw,
+ iw, &info);
+ chkxer_("ZGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zggsvd_("N", "N", "N", &c__2, &c__1, &c__1, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, rw,
+ iw, &info);
+ chkxer_("ZGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zggsvd_("N", "N", "N", &c__1, &c__1, &c__2, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, rw,
+ iw, &info);
+ chkxer_("ZGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ zggsvd_("U", "N", "N", &c__2, &c__2, &c__2, &dummyk, &dummyl, a, &
+ c__2, b, &c__2, r1, r2, u, &c__1, v, &c__1, q, &c__1, w, rw,
+ iw, &info);
+ chkxer_("ZGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ zggsvd_("N", "V", "N", &c__2, &c__2, &c__2, &dummyk, &dummyl, a, &
+ c__2, b, &c__2, r1, r2, u, &c__2, v, &c__1, q, &c__1, w, rw,
+ iw, &info);
+ chkxer_("ZGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ zggsvd_("N", "N", "Q", &c__2, &c__2, &c__2, &dummyk, &dummyl, a, &
+ c__2, b, &c__2, r1, r2, u, &c__2, v, &c__2, q, &c__1, w, rw,
+ iw, &info);
+ chkxer_("ZGGSVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* ZGGSVP */
+
+ s_copy(srnamc_1.srnamt, "ZGGSVP", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zggsvp_("/", "N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ rw, tau, w, &info);
+ chkxer_("ZGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zggsvp_("N", "/", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ rw, tau, w, &info);
+ chkxer_("ZGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zggsvp_("N", "N", "/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ rw, tau, w, &info);
+ chkxer_("ZGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zggsvp_("N", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ rw, tau, w, &info);
+ chkxer_("ZGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zggsvp_("N", "N", "N", &c__0, &c_n1, &c__0, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ rw, tau, w, &info);
+ chkxer_("ZGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zggsvp_("N", "N", "N", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ rw, tau, w, &info);
+ chkxer_("ZGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zggsvp_("N", "N", "N", &c__2, &c__1, &c__1, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ rw, tau, w, &info);
+ chkxer_("ZGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zggsvp_("N", "N", "N", &c__1, &c__2, &c__1, a, &c__1, b, &c__1, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ rw, tau, w, &info);
+ chkxer_("ZGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ zggsvp_("U", "N", "N", &c__2, &c__2, &c__2, a, &c__2, b, &c__2, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__1, v, &c__1, q, &c__1, iw,
+ rw, tau, w, &info);
+ chkxer_("ZGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ zggsvp_("N", "V", "N", &c__2, &c__2, &c__2, a, &c__2, b, &c__2, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__2, v, &c__1, q, &c__1, iw,
+ rw, tau, w, &info);
+ chkxer_("ZGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ zggsvp_("N", "N", "Q", &c__2, &c__2, &c__2, a, &c__2, b, &c__2, &tola,
+ &tolb, &dummyk, &dummyl, u, &c__2, v, &c__2, q, &c__1, iw,
+ rw, tau, w, &info);
+ chkxer_("ZGGSVP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* ZTGSJA */
+
+ s_copy(srnamc_1.srnamt, "ZTGSJA", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztgsja_("/", "N", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("ZTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztgsja_("N", "/", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("ZTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ztgsja_("N", "N", "/", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("ZTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ztgsja_("N", "N", "N", &c_n1, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("ZTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ztgsja_("N", "N", "N", &c__0, &c_n1, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("ZTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ztgsja_("N", "N", "N", &c__0, &c__0, &c_n1, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("ZTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ztgsja_("N", "N", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__0, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("ZTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ ztgsja_("N", "N", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__0, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("ZTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ ztgsja_("U", "N", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__0, v, &c__1, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("ZTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ ztgsja_("N", "V", "N", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__0, q, &
+ c__1, w, &ncycle, &info);
+ chkxer_("ZTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 22;
+ ztgsja_("N", "N", "Q", &c__0, &c__0, &c__0, &dummyk, &dummyl, a, &
+ c__1, b, &c__1, &tola, &tolb, r1, r2, u, &c__1, v, &c__1, q, &
+ c__0, w, &ncycle, &info);
+ chkxer_("ZTGSJA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* Test error exits for the GLM path. */
+
+ } else if (lsamen_(&c__3, path, "GLM")) {
+
+/* ZGGGLM */
+
+ s_copy(srnamc_1.srnamt, "ZGGGLM", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zggglm_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("ZGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zggglm_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("ZGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zggglm_(&c__0, &c__1, &c__0, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("ZGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zggglm_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("ZGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zggglm_(&c__1, &c__0, &c__0, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("ZGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zggglm_(&c__0, &c__0, &c__0, a, &c__0, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("ZGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zggglm_(&c__0, &c__0, &c__0, a, &c__1, b, &c__0, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("ZGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zggglm_(&c__1, &c__1, &c__1, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__1, &info);
+ chkxer_("ZGGGLM", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Test error exits for the LSE path. */
+
+ } else if (lsamen_(&c__3, path, "LSE")) {
+
+/* ZGGLSE */
+
+ s_copy(srnamc_1.srnamt, "ZGGLSE", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgglse_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("ZGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgglse_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("ZGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgglse_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("ZGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgglse_(&c__0, &c__0, &c__1, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("ZGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgglse_(&c__0, &c__1, &c__0, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("ZGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgglse_(&c__0, &c__0, &c__0, a, &c__0, b, &c__1, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("ZGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zgglse_(&c__0, &c__0, &c__0, a, &c__1, b, &c__0, tau, alpha, beta, w,
+ &c__18, &info);
+ chkxer_("ZGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zgglse_(&c__1, &c__1, &c__1, a, &c__1, b, &c__1, tau, alpha, beta, w,
+ &c__1, &info);
+ chkxer_("ZGGLSE", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Test error exits for the GQR path. */
+
+ } else if (lsamen_(&c__3, path, "GQR")) {
+
+/* ZGGQRF */
+
+ s_copy(srnamc_1.srnamt, "ZGGQRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zggqrf_(&c_n1, &c__0, &c__0, a, &c__1, alpha, b, &c__1, beta, w, &
+ c__18, &info);
+ chkxer_("ZGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zggqrf_(&c__0, &c_n1, &c__0, a, &c__1, alpha, b, &c__1, beta, w, &
+ c__18, &info);
+ chkxer_("ZGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zggqrf_(&c__0, &c__0, &c_n1, a, &c__1, alpha, b, &c__1, beta, w, &
+ c__18, &info);
+ chkxer_("ZGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zggqrf_(&c__0, &c__0, &c__0, a, &c__0, alpha, b, &c__1, beta, w, &
+ c__18, &info);
+ chkxer_("ZGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zggqrf_(&c__0, &c__0, &c__0, a, &c__1, alpha, b, &c__0, beta, w, &
+ c__18, &info);
+ chkxer_("ZGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zggqrf_(&c__1, &c__1, &c__2, a, &c__1, alpha, b, &c__1, beta, w, &
+ c__1, &info);
+ chkxer_("ZGGQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+/* ZGGRQF */
+
+ s_copy(srnamc_1.srnamt, "ZGGRQF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zggrqf_(&c_n1, &c__0, &c__0, a, &c__1, alpha, b, &c__1, beta, w, &
+ c__18, &info);
+ chkxer_("ZGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zggrqf_(&c__0, &c_n1, &c__0, a, &c__1, alpha, b, &c__1, beta, w, &
+ c__18, &info);
+ chkxer_("ZGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zggrqf_(&c__0, &c__0, &c_n1, a, &c__1, alpha, b, &c__1, beta, w, &
+ c__18, &info);
+ chkxer_("ZGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zggrqf_(&c__0, &c__0, &c__0, a, &c__0, alpha, b, &c__1, beta, w, &
+ c__18, &info);
+ chkxer_("ZGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zggrqf_(&c__0, &c__0, &c__0, a, &c__1, alpha, b, &c__0, beta, w, &
+ c__18, &info);
+ chkxer_("ZGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zggrqf_(&c__1, &c__1, &c__2, a, &c__1, alpha, b, &c__1, beta, w, &
+ c__1, &info);
+ chkxer_("ZGGRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+/* Test error exits for the ZGS, ZGV, ZGX, and ZXV paths. */
+
+ } else if (lsamen_(&c__3, path, "ZGS") || lsamen_(&
+ c__3, path, "ZGV") || lsamen_(&c__3, path,
+ "ZGX") || lsamen_(&c__3, path, "ZXV")) {
+
+/* ZGGES */
+
+ s_copy(srnamc_1.srnamt, "ZGGES ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgges_("/", "N", "S", (L_fp)zlctes_, &c__1, a, &c__1, b, &c__1, &sdim,
+ alpha, beta, q, &c__1, u, &c__1, w, &c__1, rw, bw, &info);
+ chkxer_("ZGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgges_("N", "/", "S", (L_fp)zlctes_, &c__1, a, &c__1, b, &c__1, &sdim,
+ alpha, beta, q, &c__1, u, &c__1, w, &c__1, rw, bw, &info);
+ chkxer_("ZGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgges_("N", "V", "/", (L_fp)zlctes_, &c__1, a, &c__1, b, &c__1, &sdim,
+ alpha, beta, q, &c__1, u, &c__1, w, &c__1, rw, bw, &info);
+ chkxer_("ZGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgges_("N", "V", "S", (L_fp)zlctes_, &c_n1, a, &c__1, b, &c__1, &sdim,
+ alpha, beta, q, &c__1, u, &c__1, w, &c__1, rw, bw, &info);
+ chkxer_("ZGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zgges_("N", "V", "S", (L_fp)zlctes_, &c__1, a, &c__0, b, &c__1, &sdim,
+ alpha, beta, q, &c__1, u, &c__1, w, &c__1, rw, bw, &info);
+ chkxer_("ZGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zgges_("N", "V", "S", (L_fp)zlctes_, &c__1, a, &c__1, b, &c__0, &sdim,
+ alpha, beta, q, &c__1, u, &c__1, w, &c__1, rw, bw, &info);
+ chkxer_("ZGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ zgges_("N", "V", "S", (L_fp)zlctes_, &c__1, a, &c__1, b, &c__1, &sdim,
+ alpha, beta, q, &c__0, u, &c__1, w, &c__1, rw, bw, &info);
+ chkxer_("ZGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ zgges_("V", "V", "S", (L_fp)zlctes_, &c__2, a, &c__2, b, &c__2, &sdim,
+ alpha, beta, q, &c__1, u, &c__2, w, &c__1, rw, bw, &info);
+ chkxer_("ZGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ zgges_("N", "V", "S", (L_fp)zlctes_, &c__1, a, &c__1, b, &c__1, &sdim,
+ alpha, beta, q, &c__1, u, &c__0, w, &c__1, rw, bw, &info);
+ chkxer_("ZGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ zgges_("V", "V", "S", (L_fp)zlctes_, &c__2, a, &c__2, b, &c__2, &sdim,
+ alpha, beta, q, &c__2, u, &c__1, w, &c__1, rw, bw, &info);
+ chkxer_("ZGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ zgges_("V", "V", "S", (L_fp)zlctes_, &c__2, a, &c__2, b, &c__2, &sdim,
+ alpha, beta, q, &c__2, u, &c__2, w, &c__1, rw, bw, &info);
+ chkxer_("ZGGES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* ZGGESX */
+
+ s_copy(srnamc_1.srnamt, "ZGGESX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zggesx_("/", "N", "S", (L_fp)zlctsx_, "N", &c__1, a, &c__1, b, &c__1,
+ &sdim, alpha, beta, q, &c__1, u, &c__1, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("ZGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zggesx_("N", "/", "S", (L_fp)zlctsx_, "N", &c__1, a, &c__1, b, &c__1,
+ &sdim, alpha, beta, q, &c__1, u, &c__1, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("ZGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zggesx_("V", "V", "/", (L_fp)zlctsx_, "N", &c__1, a, &c__1, b, &c__1,
+ &sdim, alpha, beta, q, &c__1, u, &c__1, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("ZGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zggesx_("V", "V", "S", (L_fp)zlctsx_, "/", &c__1, a, &c__1, b, &c__1,
+ &sdim, alpha, beta, q, &c__1, u, &c__1, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("ZGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zggesx_("V", "V", "S", (L_fp)zlctsx_, "B", &c_n1, a, &c__1, b, &c__1,
+ &sdim, alpha, beta, q, &c__1, u, &c__1, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("ZGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zggesx_("V", "V", "S", (L_fp)zlctsx_, "B", &c__1, a, &c__0, b, &c__1,
+ &sdim, alpha, beta, q, &c__1, u, &c__1, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("ZGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zggesx_("V", "V", "S", (L_fp)zlctsx_, "B", &c__1, a, &c__1, b, &c__0,
+ &sdim, alpha, beta, q, &c__1, u, &c__1, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("ZGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ zggesx_("V", "V", "S", (L_fp)zlctsx_, "B", &c__1, a, &c__1, b, &c__1,
+ &sdim, alpha, beta, q, &c__0, u, &c__1, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("ZGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ zggesx_("V", "V", "S", (L_fp)zlctsx_, "B", &c__2, a, &c__2, b, &c__2,
+ &sdim, alpha, beta, q, &c__1, u, &c__1, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("ZGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 17;
+ zggesx_("V", "V", "S", (L_fp)zlctsx_, "B", &c__1, a, &c__1, b, &c__1,
+ &sdim, alpha, beta, q, &c__1, u, &c__0, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("ZGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 17;
+ zggesx_("V", "V", "S", (L_fp)zlctsx_, "B", &c__2, a, &c__2, b, &c__2,
+ &sdim, alpha, beta, q, &c__2, u, &c__1, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("ZGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 21;
+ zggesx_("V", "V", "S", (L_fp)zlctsx_, "B", &c__2, a, &c__2, b, &c__2,
+ &sdim, alpha, beta, q, &c__2, u, &c__2, rce, rcv, w, &c__1,
+ rw, iw, &c__1, bw, &info);
+ chkxer_("ZGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 24;
+ zggesx_("V", "V", "S", (L_fp)zlctsx_, "V", &c__1, a, &c__1, b, &c__1,
+ &sdim, alpha, beta, q, &c__1, u, &c__1, rce, rcv, w, &c__32,
+ rw, iw, &c__0, bw, &info);
+ chkxer_("ZGGESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 13;
+
+/* ZGGEV */
+
+ s_copy(srnamc_1.srnamt, "ZGGEV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zggev_("/", "N", &c__1, a, &c__1, b, &c__1, alpha, beta, q, &c__1, u,
+ &c__1, w, &c__1, rw, &info);
+ chkxer_("ZGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zggev_("N", "/", &c__1, a, &c__1, b, &c__1, alpha, beta, q, &c__1, u,
+ &c__1, w, &c__1, rw, &info);
+ chkxer_("ZGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zggev_("V", "V", &c_n1, a, &c__1, b, &c__1, alpha, beta, q, &c__1, u,
+ &c__1, w, &c__1, rw, &info);
+ chkxer_("ZGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zggev_("V", "V", &c__1, a, &c__0, b, &c__1, alpha, beta, q, &c__1, u,
+ &c__1, w, &c__1, rw, &info);
+ chkxer_("ZGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zggev_("V", "V", &c__1, a, &c__1, b, &c__0, alpha, beta, q, &c__1, u,
+ &c__1, w, &c__1, rw, &info);
+ chkxer_("ZGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zggev_("N", "V", &c__1, a, &c__1, b, &c__1, alpha, beta, q, &c__0, u,
+ &c__1, w, &c__1, rw, &info);
+ chkxer_("ZGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zggev_("V", "V", &c__2, a, &c__2, b, &c__2, alpha, beta, q, &c__1, u,
+ &c__2, w, &c__1, rw, &info);
+ chkxer_("ZGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ zggev_("V", "N", &c__2, a, &c__2, b, &c__2, alpha, beta, q, &c__2, u,
+ &c__0, w, &c__1, rw, &info);
+ chkxer_("ZGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ zggev_("V", "V", &c__2, a, &c__2, b, &c__2, alpha, beta, q, &c__2, u,
+ &c__1, w, &c__1, rw, &info);
+ chkxer_("ZGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ zggev_("V", "V", &c__1, a, &c__1, b, &c__1, alpha, beta, q, &c__1, u,
+ &c__1, w, &c__1, rw, &info);
+ chkxer_("ZGGEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* ZGGEVX */
+
+ s_copy(srnamc_1.srnamt, "ZGGEVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zggevx_("/", "N", "N", "N", &c__1, a, &c__1, b, &c__1, alpha, beta, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__1, rw, iw, bw, &info);
+ chkxer_("ZGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zggevx_("N", "/", "N", "N", &c__1, a, &c__1, b, &c__1, alpha, beta, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__1, rw, iw, bw, &info);
+ chkxer_("ZGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zggevx_("N", "N", "/", "N", &c__1, a, &c__1, b, &c__1, alpha, beta, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__1, rw, iw, bw, &info);
+ chkxer_("ZGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zggevx_("N", "N", "N", "/", &c__1, a, &c__1, b, &c__1, alpha, beta, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__1, rw, iw, bw, &info);
+ chkxer_("ZGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zggevx_("N", "N", "N", "N", &c_n1, a, &c__1, b, &c__1, alpha, beta, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__1, rw, iw, bw, &info);
+ chkxer_("ZGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zggevx_("N", "N", "N", "N", &c__1, a, &c__0, b, &c__1, alpha, beta, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__1, rw, iw, bw, &info);
+ chkxer_("ZGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zggevx_("N", "N", "N", "N", &c__1, a, &c__1, b, &c__0, alpha, beta, q,
+ &c__1, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__1, rw, iw, bw, &info);
+ chkxer_("ZGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ zggevx_("N", "N", "N", "N", &c__1, a, &c__1, b, &c__1, alpha, beta, q,
+ &c__0, u, &c__1, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__1, rw, iw, bw, &info);
+ chkxer_("ZGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ zggevx_("N", "V", "N", "N", &c__2, a, &c__2, b, &c__2, alpha, beta, q,
+ &c__1, u, &c__2, &c__1, &c__2, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__1, rw, iw, bw, &info);
+ chkxer_("ZGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ zggevx_("N", "N", "N", "N", &c__1, a, &c__1, b, &c__1, alpha, beta, q,
+ &c__1, u, &c__0, &c__1, &c__1, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__1, rw, iw, bw, &info);
+ chkxer_("ZGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ zggevx_("N", "N", "V", "N", &c__2, a, &c__2, b, &c__2, alpha, beta, q,
+ &c__2, u, &c__1, &c__1, &c__2, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__1, rw, iw, bw, &info);
+ chkxer_("ZGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 25;
+ zggevx_("N", "N", "V", "N", &c__2, a, &c__2, b, &c__2, alpha, beta, q,
+ &c__2, u, &c__2, &c__1, &c__2, ls, rs, &anrm, &bnrm, rce,
+ rcv, w, &c__0, rw, iw, bw, &info);
+ chkxer_("ZGGEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 12;
+
+/* ZTGEXC */
+
+ s_copy(srnamc_1.srnamt, "ZTGEXC", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 3;
+ ztgexc_(&c_true, &c_true, &c_n1, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__1, &ifst, &ilst, &info);
+ chkxer_("ZTGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ztgexc_(&c_true, &c_true, &c__1, a, &c__0, b, &c__1, q, &c__1, z__, &
+ c__1, &ifst, &ilst, &info);
+ chkxer_("ZTGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ztgexc_(&c_true, &c_true, &c__1, a, &c__1, b, &c__0, q, &c__1, z__, &
+ c__1, &ifst, &ilst, &info);
+ chkxer_("ZTGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ ztgexc_(&c_false, &c_true, &c__1, a, &c__1, b, &c__1, q, &c__0, z__, &
+ c__1, &ifst, &ilst, &info);
+ chkxer_("ZTGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ ztgexc_(&c_true, &c_true, &c__1, a, &c__1, b, &c__1, q, &c__0, z__, &
+ c__1, &ifst, &ilst, &info);
+ chkxer_("ZTGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ ztgexc_(&c_true, &c_false, &c__1, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__0, &ifst, &ilst, &info);
+ chkxer_("ZTGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ ztgexc_(&c_true, &c_true, &c__1, a, &c__1, b, &c__1, q, &c__1, z__, &
+ c__0, &ifst, &ilst, &info);
+ chkxer_("ZTGEXC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+
+/* ZTGSEN */
+
+ s_copy(srnamc_1.srnamt, "ZTGSEN", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztgsen_(&c_n1, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1,
+ alpha, beta, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c__1, iw, &c__1, &info);
+ chkxer_("ZTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ztgsen_(&c__1, &c_true, &c_true, sel, &c_n1, a, &c__1, b, &c__1,
+ alpha, beta, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c__1, iw, &c__1, &info);
+ chkxer_("ZTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ztgsen_(&c__1, &c_true, &c_true, sel, &c__1, a, &c__0, b, &c__1,
+ alpha, beta, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c__1, iw, &c__1, &info);
+ chkxer_("ZTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ ztgsen_(&c__1, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__0,
+ alpha, beta, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c__1, iw, &c__1, &info);
+ chkxer_("ZTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ ztgsen_(&c__1, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1,
+ alpha, beta, q, &c__0, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c__1, iw, &c__1, &info);
+ chkxer_("ZTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ ztgsen_(&c__1, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1,
+ alpha, beta, q, &c__1, z__, &c__0, &m, &tola, &tolb, rcv, w, &
+ c__1, iw, &c__1, &info);
+ chkxer_("ZTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 21;
+ ztgsen_(&c__3, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1,
+ alpha, beta, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c_n5, iw, &c__1, &info);
+ chkxer_("ZTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 23;
+ ztgsen_(&c__0, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1,
+ alpha, beta, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c__20, iw, &c__0, &info);
+ chkxer_("ZTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 23;
+ ztgsen_(&c__1, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1,
+ alpha, beta, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c__20, iw, &c__0, &info);
+ chkxer_("ZTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 23;
+ ztgsen_(&c__5, &c_true, &c_true, sel, &c__1, a, &c__1, b, &c__1,
+ alpha, beta, q, &c__1, z__, &c__1, &m, &tola, &tolb, rcv, w, &
+ c__20, iw, &c__1, &info);
+ chkxer_("ZTGSEN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* ZTGSNA */
+
+ s_copy(srnamc_1.srnamt, "ZTGSNA", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztgsna_("/", "A", sel, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("ZTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztgsna_("B", "/", sel, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("ZTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ztgsna_("B", "A", sel, &c_n1, a, &c__1, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("ZTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ztgsna_("B", "A", sel, &c__1, a, &c__0, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("ZTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ztgsna_("B", "A", sel, &c__1, a, &c__1, b, &c__0, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("ZTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ztgsna_("E", "A", sel, &c__1, a, &c__1, b, &c__1, q, &c__0, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("ZTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ ztgsna_("E", "A", sel, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &c__0,
+ r1, r2, &c__1, &m, w, &c__1, iw, &info);
+ chkxer_("ZTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ ztgsna_("E", "A", sel, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__0, &m, w, &c__1, iw, &info);
+ chkxer_("ZTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ ztgsna_("E", "A", sel, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &c__1,
+ r1, r2, &c__1, &m, w, &c__0, iw, &info);
+ chkxer_("ZTGSNA", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* ZTGSYL */
+
+ s_copy(srnamc_1.srnamt, "ZTGSYL", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztgsyl_("/", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("ZTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztgsyl_("N", &c_n1, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("ZTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ztgsyl_("N", &c__0, &c__0, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("ZTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ztgsyl_("N", &c__0, &c__1, &c__0, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("ZTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ztgsyl_("N", &c__0, &c__1, &c__1, a, &c__0, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("ZTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ztgsyl_("N", &c__0, &c__1, &c__1, a, &c__1, b, &c__0, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("ZTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ztgsyl_("N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__0, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("ZTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ ztgsyl_("N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__0, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("ZTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ ztgsyl_("N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__0, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("ZTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ ztgsyl_("N", &c__0, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__0, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("ZTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ ztgsyl_("N", &c__1, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("ZTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ ztgsyl_("N", &c__2, &c__1, &c__1, a, &c__1, b, &c__1, q, &c__1, u, &
+ c__1, v, &c__1, z__, &c__1, &scale, &dif, w, &c__1, iw, &info);
+ chkxer_("ZTGSYL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 12;
+ }
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___40.ciunit = infoc_1.nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___41.ciunit = infoc_1.nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of ZERRGG */
+
+} /* zerrgg_ */
diff --git a/TESTING/EIG/zerrhs.c b/TESTING/EIG/zerrhs.c
new file mode 100644
index 0000000..944d255
--- /dev/null
+++ b/TESTING/EIG/zerrhs.c
@@ -0,0 +1,536 @@
+/* zerrhs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__4 = 4;
+
+/* Subroutine */ int zerrhs_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
+ "rror exits\002,\002 (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
+ "ts of the error \002,\002exits ***\002)";
+
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublecomplex a[9] /* was [3][3] */, c__[9] /* was [3][3] */;
+ integer i__, j, m;
+ doublereal s[3];
+ doublecomplex w[9], x[3];
+ char c2[2];
+ integer nt;
+ doublecomplex vl[9] /* was [3][3] */, vr[9] /* was [3][3] */;
+ doublereal rw[3];
+ integer ihi, ilo;
+ logical sel[3];
+ doublecomplex tau[3];
+ integer info, ifaill[3];
+ extern /* Subroutine */ int zgebak_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublecomplex *, integer *,
+ integer *), zgebal_(char *, integer *,
+ doublecomplex *, integer *, integer *, integer *, doublereal *,
+ integer *);
+ integer ifailr[3];
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *), chkxer_(char *, integer *, integer *,
+ logical *, logical *), zhsein_(char *, char *, char *,
+ logical *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+, integer *, doublecomplex *, doublereal *, integer *, integer *,
+ integer *), zhseqr_(char *, char *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *), ztrevc_(char *, char *,
+ logical *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, integer *,
+ doublecomplex *, doublereal *, integer *),
+ zunghr_(integer *, integer *, integer *, doublecomplex *, integer
+ *, doublecomplex *, doublecomplex *, integer *, integer *),
+ zunmhr_(char *, char *, integer *, integer *, integer *, integer *
+, doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRHS tests the error exits for ZGEBAK, CGEBAL, CGEHRD, ZUNGHR, */
+/* ZUNMHR, ZHSEQR, CHSEIN, and ZTREVC. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 3; ++j) {
+ for (i__ = 1; i__ <= 3; ++i__) {
+ i__1 = i__ + j * 3 - 4;
+ d__1 = 1. / (doublereal) (i__ + j);
+ a[i__1].r = d__1, a[i__1].i = 0.;
+/* L10: */
+ }
+ sel[j - 1] = TRUE_;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+ nt = 0;
+
+/* Test error exits of the nonsymmetric eigenvalue routines. */
+
+ if (lsamen_(&c__2, c2, "HS")) {
+
+/* ZGEBAL */
+
+ s_copy(srnamc_1.srnamt, "ZGEBAL", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgebal_("/", &c__0, a, &c__1, &ilo, &ihi, s, &info);
+ chkxer_("ZGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgebal_("N", &c_n1, a, &c__1, &ilo, &ihi, s, &info);
+ chkxer_("ZGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgebal_("N", &c__2, a, &c__1, &ilo, &ihi, s, &info);
+ chkxer_("ZGEBAL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 3;
+
+/* ZGEBAK */
+
+ s_copy(srnamc_1.srnamt, "ZGEBAK", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgebak_("/", "R", &c__0, &c__1, &c__0, s, &c__0, a, &c__1, &info);
+ chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgebak_("N", "/", &c__0, &c__1, &c__0, s, &c__0, a, &c__1, &info);
+ chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgebak_("N", "R", &c_n1, &c__1, &c__0, s, &c__0, a, &c__1, &info);
+ chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgebak_("N", "R", &c__0, &c__0, &c__0, s, &c__0, a, &c__1, &info);
+ chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgebak_("N", "R", &c__0, &c__2, &c__0, s, &c__0, a, &c__1, &info);
+ chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgebak_("N", "R", &c__2, &c__2, &c__1, s, &c__0, a, &c__2, &info);
+ chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgebak_("N", "R", &c__0, &c__1, &c__1, s, &c__0, a, &c__1, &info);
+ chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zgebak_("N", "R", &c__0, &c__1, &c__0, s, &c_n1, a, &c__1, &info);
+ chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zgebak_("N", "R", &c__2, &c__1, &c__2, s, &c__0, a, &c__1, &info);
+ chkxer_("ZGEBAK", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* ZGEHRD */
+
+ s_copy(srnamc_1.srnamt, "ZGEHRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgehrd_(&c_n1, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("ZGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgehrd_(&c__0, &c__0, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("ZGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgehrd_(&c__0, &c__2, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("ZGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgehrd_(&c__1, &c__1, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("ZGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgehrd_(&c__0, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("ZGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgehrd_(&c__2, &c__1, &c__1, a, &c__1, tau, w, &c__2, &info);
+ chkxer_("ZGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zgehrd_(&c__2, &c__1, &c__2, a, &c__2, tau, w, &c__1, &info);
+ chkxer_("ZGEHRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+
+/* ZUNGHR */
+
+ s_copy(srnamc_1.srnamt, "ZUNGHR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zunghr_(&c_n1, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("ZUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zunghr_(&c__0, &c__0, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("ZUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zunghr_(&c__0, &c__2, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("ZUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zunghr_(&c__1, &c__1, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("ZUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zunghr_(&c__0, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("ZUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunghr_(&c__2, &c__1, &c__1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("ZUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zunghr_(&c__3, &c__1, &c__3, a, &c__3, tau, w, &c__1, &info);
+ chkxer_("ZUNGHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+
+/* ZUNMHR */
+
+ s_copy(srnamc_1.srnamt, "ZUNMHR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zunmhr_("/", "N", &c__0, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zunmhr_("L", "/", &c__0, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zunmhr_("L", "N", &c_n1, &c__0, &c__1, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zunmhr_("L", "N", &c__0, &c_n1, &c__1, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunmhr_("L", "N", &c__0, &c__0, &c__0, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunmhr_("L", "N", &c__0, &c__0, &c__2, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunmhr_("L", "N", &c__1, &c__2, &c__2, &c__1, a, &c__1, tau, c__, &
+ c__1, w, &c__2, &info);
+ chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunmhr_("R", "N", &c__2, &c__1, &c__2, &c__1, a, &c__1, tau, c__, &
+ c__2, w, &c__2, &info);
+ chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zunmhr_("L", "N", &c__1, &c__1, &c__1, &c__0, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zunmhr_("L", "N", &c__0, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zunmhr_("R", "N", &c__1, &c__0, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zunmhr_("L", "N", &c__2, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__2, w, &c__1, &info);
+ chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zunmhr_("R", "N", &c__1, &c__2, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zunmhr_("L", "N", &c__2, &c__1, &c__1, &c__1, a, &c__2, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ zunmhr_("L", "N", &c__1, &c__2, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__1, w, &c__1, &info);
+ chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ zunmhr_("R", "N", &c__2, &c__1, &c__1, &c__1, a, &c__1, tau, c__, &
+ c__2, w, &c__1, &info);
+ chkxer_("ZUNMHR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 16;
+
+/* ZHSEQR */
+
+ s_copy(srnamc_1.srnamt, "ZHSEQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhseqr_("/", "N", &c__0, &c__1, &c__0, a, &c__1, x, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhseqr_("E", "/", &c__0, &c__1, &c__0, a, &c__1, x, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zhseqr_("E", "N", &c_n1, &c__1, &c__0, a, &c__1, x, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zhseqr_("E", "N", &c__0, &c__0, &c__0, a, &c__1, x, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zhseqr_("E", "N", &c__0, &c__2, &c__0, a, &c__1, x, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zhseqr_("E", "N", &c__1, &c__1, &c__0, a, &c__1, x, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zhseqr_("E", "N", &c__1, &c__1, &c__2, a, &c__1, x, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zhseqr_("E", "N", &c__2, &c__1, &c__2, a, &c__1, x, c__, &c__2, w, &
+ c__1, &info);
+ chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zhseqr_("E", "V", &c__2, &c__1, &c__2, a, &c__2, x, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("ZHSEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 9;
+
+/* ZHSEIN */
+
+ s_copy(srnamc_1.srnamt, "ZHSEIN", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhsein_("/", "N", "N", sel, &c__0, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &c__0, &m, w, rw, ifaill, ifailr, &info);
+ chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhsein_("R", "/", "N", sel, &c__0, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &c__0, &m, w, rw, ifaill, ifailr, &info);
+ chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zhsein_("R", "N", "/", sel, &c__0, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &c__0, &m, w, rw, ifaill, ifailr, &info);
+ chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zhsein_("R", "N", "N", sel, &c_n1, a, &c__1, x, vl, &c__1, vr, &c__1,
+ &c__0, &m, w, rw, ifaill, ifailr, &info);
+ chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zhsein_("R", "N", "N", sel, &c__2, a, &c__1, x, vl, &c__1, vr, &c__2,
+ &c__4, &m, w, rw, ifaill, ifailr, &info);
+ chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zhsein_("L", "N", "N", sel, &c__2, a, &c__2, x, vl, &c__1, vr, &c__1,
+ &c__4, &m, w, rw, ifaill, ifailr, &info);
+ chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zhsein_("R", "N", "N", sel, &c__2, a, &c__2, x, vl, &c__1, vr, &c__1,
+ &c__4, &m, w, rw, ifaill, ifailr, &info);
+ chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ zhsein_("R", "N", "N", sel, &c__2, a, &c__2, x, vl, &c__1, vr, &c__2,
+ &c__1, &m, w, rw, ifaill, ifailr, &info);
+ chkxer_("ZHSEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* ZTREVC */
+
+ s_copy(srnamc_1.srnamt, "ZTREVC", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztrevc_("/", "A", sel, &c__0, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
+ m, w, rw, &info);
+ chkxer_("ZTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztrevc_("L", "/", sel, &c__0, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
+ m, w, rw, &info);
+ chkxer_("ZTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ztrevc_("L", "A", sel, &c_n1, a, &c__1, vl, &c__1, vr, &c__1, &c__0, &
+ m, w, rw, &info);
+ chkxer_("ZTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrevc_("L", "A", sel, &c__2, a, &c__1, vl, &c__2, vr, &c__1, &c__4, &
+ m, w, rw, &info);
+ chkxer_("ZTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ztrevc_("L", "A", sel, &c__2, a, &c__2, vl, &c__1, vr, &c__1, &c__4, &
+ m, w, rw, &info);
+ chkxer_("ZTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ztrevc_("R", "A", sel, &c__2, a, &c__2, vl, &c__1, vr, &c__1, &c__4, &
+ m, w, rw, &info);
+ chkxer_("ZTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrevc_("L", "A", sel, &c__2, a, &c__2, vl, &c__2, vr, &c__1, &c__1, &
+ m, w, rw, &info);
+ chkxer_("ZTREVC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 7;
+ }
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___22.ciunit = infoc_1.nout;
+ s_wsfe(&io___22);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___23.ciunit = infoc_1.nout;
+ s_wsfe(&io___23);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of ZERRHS */
+
+} /* zerrhs_ */
diff --git a/TESTING/EIG/zerrst.c b/TESTING/EIG/zerrst.c
new file mode 100644
index 0000000..4fd731d
--- /dev/null
+++ b/TESTING/EIG/zerrst.c
@@ -0,0 +1,1138 @@
+/* zerrst.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static integer c__23 = 23;
+static integer c__28 = 28;
+static integer c__12 = 12;
+static integer c__25 = 25;
+static integer c__8 = 8;
+static integer c__18 = 18;
+static integer c__11 = 11;
+static doublereal c_b458 = 0.;
+static doublereal c_b472 = 1.;
+
+/* Subroutine */ int zerrst_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
+ "rror exits\002,\002 (\002,i3,\002 tests done)\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
+ "ts of the error \002,\002exits ***\002)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublecomplex a[9] /* was [3][3] */, c__[9] /* was [3][3] */;
+ doublereal d__[3], e[3];
+ integer i__, j, m, n;
+ doublecomplex q[9] /* was [3][3] */;
+ doublereal r__[60];
+ doublecomplex w[60];
+ doublereal x[3];
+ doublecomplex z__[9] /* was [3][3] */;
+ char c2[2];
+ integer i1[3], i2[3], i3[3], iw[36], nt;
+ doublereal rw[60];
+ doublecomplex tau[3];
+ integer info;
+ extern /* Subroutine */ int zhbev_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ integer *, doublecomplex *, doublereal *, integer *), zheev_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublecomplex *, integer *, doublereal *,
+ integer *), zhpev_(char *, char *, integer *,
+ doublecomplex *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, doublereal *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int zhbevd_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, integer *,
+ integer *, integer *, integer *), chkxer_(char *,
+ integer *, integer *, logical *, logical *), zheevd_(char
+ *, char *, integer *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *, doublereal *, integer *, integer *,
+ integer *, integer *), zstedc_(char *, integer *,
+ doublereal *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, integer *, integer *,
+ integer *, integer *), zhbtrd_(char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *), zhetrd_(char *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublecomplex *,
+ integer *, integer *), zhpevd_(char *, char *, integer *,
+ doublecomplex *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, integer *, integer *,
+ integer *, integer *), zheevr_(char *, char *,
+ char *, integer *, doublecomplex *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *, integer *, integer *,
+ integer *, integer *), zhbevx_(char *,
+ char *, char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublecomplex *
+, integer *, doublecomplex *, doublereal *, integer *, integer *,
+ integer *), zheevx_(char *, char *, char *
+, integer *, doublecomplex *, integer *, doublereal *, doublereal
+ *, integer *, integer *, doublereal *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *, integer *, integer *), zhptrd_(char *, integer *, doublecomplex *, doublereal *,
+ doublereal *, doublecomplex *, integer *), zstein_(
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, integer *, doublecomplex *, integer *, doublereal *,
+ integer *, integer *, integer *), zhpevx_(char *, char *, char *,
+ integer *, doublecomplex *, doublereal *, doublereal *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublecomplex *
+, integer *, doublecomplex *, doublereal *, integer *, integer *,
+ integer *), zpteqr_(char *, integer *,
+ doublereal *, doublereal *, doublecomplex *, integer *,
+ doublereal *, integer *), zsteqr_(char *, integer *,
+ doublereal *, doublereal *, doublecomplex *, integer *,
+ doublereal *, integer *), zungtr_(char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *), zupgtr_(char *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zunmtr_(char *, char *, char
+ *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *), zupmtr_(char *,
+ char *, char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRST tests the error exits for ZHETRD, ZUNGTR, CUNMTR, ZHPTRD, */
+/* ZUNGTR, ZUPMTR, ZSTEQR, CSTEIN, ZPTEQR, ZHBTRD, */
+/* ZHEEV, CHEEVX, CHEEVD, ZHBEV, CHBEVX, CHBEVD, */
+/* ZHPEV, CHPEVX, CHPEVD, and ZSTEDC. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 3; ++j) {
+ for (i__ = 1; i__ <= 3; ++i__) {
+ i__1 = i__ + j * 3 - 4;
+ d__1 = 1. / (doublereal) (i__ + j);
+ a[i__1].r = d__1, a[i__1].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ for (j = 1; j <= 3; ++j) {
+ d__[j - 1] = (doublereal) j;
+ e[j - 1] = 0.;
+ i1[j - 1] = j;
+ i2[j - 1] = j;
+ i__1 = j - 1;
+ tau[i__1].r = 1., tau[i__1].i = 0.;
+/* L30: */
+ }
+ infoc_1.ok = TRUE_;
+ nt = 0;
+
+/* Test error exits for the ST path. */
+
+ if (lsamen_(&c__2, c2, "ST")) {
+
+/* ZHETRD */
+
+ s_copy(srnamc_1.srnamt, "ZHETRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhetrd_("/", &c__0, a, &c__1, d__, e, tau, w, &c__1, &info)
+ ;
+ chkxer_("ZHETRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhetrd_("U", &c_n1, a, &c__1, d__, e, tau, w, &c__1, &info)
+ ;
+ chkxer_("ZHETRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zhetrd_("U", &c__2, a, &c__1, d__, e, tau, w, &c__1, &info)
+ ;
+ chkxer_("ZHETRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zhetrd_("U", &c__0, a, &c__1, d__, e, tau, w, &c__0, &info)
+ ;
+ chkxer_("ZHETRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 4;
+
+/* ZUNGTR */
+
+ s_copy(srnamc_1.srnamt, "ZUNGTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zungtr_("/", &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("ZUNGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zungtr_("U", &c_n1, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("ZUNGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zungtr_("U", &c__2, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("ZUNGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zungtr_("U", &c__3, a, &c__3, tau, w, &c__1, &info);
+ chkxer_("ZUNGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 4;
+
+/* ZUNMTR */
+
+ s_copy(srnamc_1.srnamt, "ZUNMTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zunmtr_("/", "U", "N", &c__0, &c__0, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("ZUNMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zunmtr_("L", "/", "N", &c__0, &c__0, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("ZUNMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zunmtr_("L", "U", "/", &c__0, &c__0, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("ZUNMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zunmtr_("L", "U", "N", &c_n1, &c__0, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("ZUNMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunmtr_("L", "U", "N", &c__0, &c_n1, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("ZUNMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zunmtr_("L", "U", "N", &c__2, &c__0, a, &c__1, tau, c__, &c__2, w, &
+ c__1, &info);
+ chkxer_("ZUNMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zunmtr_("R", "U", "N", &c__0, &c__2, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("ZUNMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zunmtr_("L", "U", "N", &c__2, &c__0, a, &c__2, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("ZUNMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zunmtr_("L", "U", "N", &c__0, &c__2, a, &c__1, tau, c__, &c__1, w, &
+ c__1, &info);
+ chkxer_("ZUNMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zunmtr_("R", "U", "N", &c__2, &c__0, a, &c__1, tau, c__, &c__2, w, &
+ c__1, &info);
+ chkxer_("ZUNMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* ZHPTRD */
+
+ s_copy(srnamc_1.srnamt, "ZHPTRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhptrd_("/", &c__0, a, d__, e, tau, &info);
+ chkxer_("ZHPTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhptrd_("U", &c_n1, a, d__, e, tau, &info);
+ chkxer_("ZHPTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 2;
+
+/* ZUPGTR */
+
+ s_copy(srnamc_1.srnamt, "ZUPGTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zupgtr_("/", &c__0, a, tau, z__, &c__1, w, &info);
+ chkxer_("ZUPGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zupgtr_("U", &c_n1, a, tau, z__, &c__1, w, &info);
+ chkxer_("ZUPGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zupgtr_("U", &c__2, a, tau, z__, &c__1, w, &info);
+ chkxer_("ZUPGTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 3;
+
+/* ZUPMTR */
+
+ s_copy(srnamc_1.srnamt, "ZUPMTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zupmtr_("/", "U", "N", &c__0, &c__0, a, tau, c__, &c__1, w, &info);
+ chkxer_("ZUPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zupmtr_("L", "/", "N", &c__0, &c__0, a, tau, c__, &c__1, w, &info);
+ chkxer_("ZUPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zupmtr_("L", "U", "/", &c__0, &c__0, a, tau, c__, &c__1, w, &info);
+ chkxer_("ZUPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zupmtr_("L", "U", "N", &c_n1, &c__0, a, tau, c__, &c__1, w, &info);
+ chkxer_("ZUPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zupmtr_("L", "U", "N", &c__0, &c_n1, a, tau, c__, &c__1, w, &info);
+ chkxer_("ZUPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zupmtr_("L", "U", "N", &c__2, &c__0, a, tau, c__, &c__1, w, &info);
+ chkxer_("ZUPMTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+/* ZPTEQR */
+
+ s_copy(srnamc_1.srnamt, "ZPTEQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpteqr_("/", &c__0, d__, e, z__, &c__1, rw, &info);
+ chkxer_("ZPTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpteqr_("N", &c_n1, d__, e, z__, &c__1, rw, &info);
+ chkxer_("ZPTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zpteqr_("V", &c__2, d__, e, z__, &c__1, rw, &info);
+ chkxer_("ZPTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 3;
+
+/* ZSTEIN */
+
+ s_copy(srnamc_1.srnamt, "ZSTEIN", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zstein_(&c_n1, d__, e, &c__0, x, i1, i2, z__, &c__1, rw, iw, i3, &
+ info);
+ chkxer_("ZSTEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zstein_(&c__0, d__, e, &c_n1, x, i1, i2, z__, &c__1, rw, iw, i3, &
+ info);
+ chkxer_("ZSTEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zstein_(&c__0, d__, e, &c__1, x, i1, i2, z__, &c__1, rw, iw, i3, &
+ info);
+ chkxer_("ZSTEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zstein_(&c__2, d__, e, &c__0, x, i1, i2, z__, &c__1, rw, iw, i3, &
+ info);
+ chkxer_("ZSTEIN", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 4;
+
+/* ZSTEQR */
+
+ s_copy(srnamc_1.srnamt, "ZSTEQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zsteqr_("/", &c__0, d__, e, z__, &c__1, rw, &info);
+ chkxer_("ZSTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zsteqr_("N", &c_n1, d__, e, z__, &c__1, rw, &info);
+ chkxer_("ZSTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zsteqr_("V", &c__2, d__, e, z__, &c__1, rw, &info);
+ chkxer_("ZSTEQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 3;
+
+/* ZSTEDC */
+
+ s_copy(srnamc_1.srnamt, "ZSTEDC", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zstedc_("/", &c__0, d__, e, z__, &c__1, w, &c__1, rw, &c__1, iw, &
+ c__1, &info);
+ chkxer_("ZSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zstedc_("N", &c_n1, d__, e, z__, &c__1, w, &c__1, rw, &c__1, iw, &
+ c__1, &info);
+ chkxer_("ZSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zstedc_("V", &c__2, d__, e, z__, &c__1, w, &c__4, rw, &c__23, iw, &
+ c__28, &info);
+ chkxer_("ZSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zstedc_("N", &c__2, d__, e, z__, &c__1, w, &c__0, rw, &c__1, iw, &
+ c__1, &info);
+ chkxer_("ZSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zstedc_("V", &c__2, d__, e, z__, &c__2, w, &c__0, rw, &c__23, iw, &
+ c__28, &info);
+ chkxer_("ZSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zstedc_("N", &c__2, d__, e, z__, &c__1, w, &c__1, rw, &c__0, iw, &
+ c__1, &info);
+ chkxer_("ZSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zstedc_("I", &c__2, d__, e, z__, &c__2, w, &c__1, rw, &c__1, iw, &
+ c__12, &info);
+ chkxer_("ZSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zstedc_("V", &c__2, d__, e, z__, &c__2, w, &c__4, rw, &c__1, iw, &
+ c__28, &info);
+ chkxer_("ZSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zstedc_("N", &c__2, d__, e, z__, &c__1, w, &c__1, rw, &c__1, iw, &
+ c__0, &info);
+ chkxer_("ZSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zstedc_("I", &c__2, d__, e, z__, &c__2, w, &c__1, rw, &c__23, iw, &
+ c__0, &info);
+ chkxer_("ZSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zstedc_("V", &c__2, d__, e, z__, &c__2, w, &c__4, rw, &c__23, iw, &
+ c__0, &info);
+ chkxer_("ZSTEDC", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+
+/* ZHEEVD */
+
+ s_copy(srnamc_1.srnamt, "ZHEEVD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zheevd_("/", "U", &c__0, a, &c__1, x, w, &c__1, rw, &c__1, iw, &c__1,
+ &info);
+ chkxer_("ZHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zheevd_("N", "/", &c__0, a, &c__1, x, w, &c__1, rw, &c__1, iw, &c__1,
+ &info);
+ chkxer_("ZHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zheevd_("N", "U", &c_n1, a, &c__1, x, w, &c__1, rw, &c__1, iw, &c__1,
+ &info);
+ chkxer_("ZHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zheevd_("N", "U", &c__2, a, &c__1, x, w, &c__3, rw, &c__2, iw, &c__1,
+ &info);
+ chkxer_("ZHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zheevd_("N", "U", &c__1, a, &c__1, x, w, &c__0, rw, &c__1, iw, &c__1,
+ &info);
+ chkxer_("ZHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zheevd_("N", "U", &c__2, a, &c__2, x, w, &c__2, rw, &c__2, iw, &c__1,
+ &info);
+ chkxer_("ZHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zheevd_("V", "U", &c__2, a, &c__2, x, w, &c__3, rw, &c__25, iw, &
+ c__12, &info);
+ chkxer_("ZHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zheevd_("N", "U", &c__1, a, &c__1, x, w, &c__1, rw, &c__0, iw, &c__1,
+ &info);
+ chkxer_("ZHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zheevd_("N", "U", &c__2, a, &c__2, x, w, &c__3, rw, &c__1, iw, &c__1,
+ &info);
+ chkxer_("ZHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zheevd_("V", "U", &c__2, a, &c__2, x, w, &c__8, rw, &c__18, iw, &
+ c__12, &info);
+ chkxer_("ZHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zheevd_("N", "U", &c__1, a, &c__1, x, w, &c__1, rw, &c__1, iw, &c__0,
+ &info);
+ chkxer_("ZHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zheevd_("V", "U", &c__2, a, &c__2, x, w, &c__8, rw, &c__25, iw, &
+ c__11, &info);
+ chkxer_("ZHEEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 12;
+
+/* ZHEEV */
+
+ s_copy(srnamc_1.srnamt, "ZHEEV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zheev_("/", "U", &c__0, a, &c__1, x, w, &c__1, rw, &info);
+ chkxer_("ZHEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zheev_("N", "/", &c__0, a, &c__1, x, w, &c__1, rw, &info);
+ chkxer_("ZHEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zheev_("N", "U", &c_n1, a, &c__1, x, w, &c__1, rw, &info);
+ chkxer_("ZHEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zheev_("N", "U", &c__2, a, &c__1, x, w, &c__3, rw, &info);
+ chkxer_("ZHEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zheev_("N", "U", &c__2, a, &c__2, x, w, &c__2, rw, &info);
+ chkxer_("ZHEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 5;
+
+/* ZHEEVX */
+
+ s_copy(srnamc_1.srnamt, "ZHEEVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zheevx_("/", "A", "U", &c__0, a, &c__1, &c_b458, &c_b458, &c__0, &
+ c__0, &c_b458, &m, x, z__, &c__1, w, &c__1, rw, iw, i3, &info);
+ chkxer_("ZHEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zheevx_("V", "/", "U", &c__0, a, &c__1, &c_b458, &c_b472, &c__1, &
+ c__0, &c_b458, &m, x, z__, &c__1, w, &c__1, rw, iw, i3, &info);
+ chkxer_("ZHEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zheevx_("V", "A", "/", &c__0, a, &c__1, &c_b458, &c_b458, &c__0, &
+ c__0, &c_b458, &m, x, z__, &c__1, w, &c__1, rw, iw, i3, &info);
+ infoc_1.infot = 4;
+ zheevx_("V", "A", "U", &c_n1, a, &c__1, &c_b458, &c_b458, &c__0, &
+ c__0, &c_b458, &m, x, z__, &c__1, w, &c__1, rw, iw, i3, &info);
+ chkxer_("ZHEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zheevx_("V", "A", "U", &c__2, a, &c__1, &c_b458, &c_b458, &c__0, &
+ c__0, &c_b458, &m, x, z__, &c__2, w, &c__3, rw, iw, i3, &info);
+ chkxer_("ZHEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zheevx_("V", "V", "U", &c__1, a, &c__1, &c_b458, &c_b458, &c__0, &
+ c__0, &c_b458, &m, x, z__, &c__1, w, &c__1, rw, iw, i3, &info);
+ chkxer_("ZHEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zheevx_("V", "I", "U", &c__1, a, &c__1, &c_b458, &c_b458, &c__0, &
+ c__0, &c_b458, &m, x, z__, &c__1, w, &c__1, rw, iw, i3, &info);
+ chkxer_("ZHEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zheevx_("V", "I", "U", &c__2, a, &c__2, &c_b458, &c_b458, &c__2, &
+ c__1, &c_b458, &m, x, z__, &c__2, w, &c__3, rw, iw, i3, &info);
+ chkxer_("ZHEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ zheevx_("V", "A", "U", &c__2, a, &c__2, &c_b458, &c_b458, &c__0, &
+ c__0, &c_b458, &m, x, z__, &c__1, w, &c__3, rw, iw, i3, &info);
+ chkxer_("ZHEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 17;
+ zheevx_("V", "A", "U", &c__2, a, &c__2, &c_b458, &c_b458, &c__0, &
+ c__0, &c_b458, &m, x, z__, &c__2, w, &c__2, rw, iw, i1, &info);
+ chkxer_("ZHEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 10;
+
+/* ZHEEVR */
+
+ s_copy(srnamc_1.srnamt, "ZHEEVR", (ftnlen)32, (ftnlen)6);
+ n = 1;
+ infoc_1.infot = 1;
+ i__1 = n << 1;
+ i__2 = n * 24;
+ i__3 = n * 10;
+ zheevr_("/", "A", "U", &c__0, a, &c__1, &c_b458, &c_b458, &c__1, &
+ c__1, &c_b458, &m, r__, z__, &c__1, iw, q, &i__1, rw, &i__2, &
+ iw[n * 2], &i__3, &info);
+ chkxer_("ZHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ i__1 = n << 1;
+ i__2 = n * 24;
+ i__3 = n * 10;
+ zheevr_("V", "/", "U", &c__0, a, &c__1, &c_b458, &c_b458, &c__1, &
+ c__1, &c_b458, &m, r__, z__, &c__1, iw, q, &i__1, rw, &i__2, &
+ iw[n * 2], &i__3, &info);
+ chkxer_("ZHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ i__1 = n << 1;
+ i__2 = n * 24;
+ i__3 = n * 10;
+ zheevr_("V", "A", "/", &c_n1, a, &c__1, &c_b458, &c_b458, &c__1, &
+ c__1, &c_b458, &m, r__, z__, &c__1, iw, q, &i__1, rw, &i__2, &
+ iw[n * 2], &i__3, &info);
+ chkxer_("ZHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ i__1 = n << 1;
+ i__2 = n * 24;
+ i__3 = n * 10;
+ zheevr_("V", "A", "U", &c_n1, a, &c__1, &c_b458, &c_b458, &c__1, &
+ c__1, &c_b458, &m, r__, z__, &c__1, iw, q, &i__1, rw, &i__2, &
+ iw[n * 2], &i__3, &info);
+ chkxer_("ZHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ i__1 = n << 1;
+ i__2 = n * 24;
+ i__3 = n * 10;
+ zheevr_("V", "A", "U", &c__2, a, &c__1, &c_b458, &c_b458, &c__1, &
+ c__1, &c_b458, &m, r__, z__, &c__1, iw, q, &i__1, rw, &i__2, &
+ iw[n * 2], &i__3, &info);
+ chkxer_("ZHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ i__1 = n << 1;
+ i__2 = n * 24;
+ i__3 = n * 10;
+ zheevr_("V", "V", "U", &c__1, a, &c__1, &c_b458, &c_b458, &c__1, &
+ c__1, &c_b458, &m, r__, z__, &c__1, iw, q, &i__1, rw, &i__2, &
+ iw[n * 2], &i__3, &info);
+ chkxer_("ZHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ i__1 = n << 1;
+ i__2 = n * 24;
+ i__3 = n * 10;
+ zheevr_("V", "I", "U", &c__1, a, &c__1, &c_b458, &c_b458, &c__0, &
+ c__1, &c_b458, &m, r__, z__, &c__1, iw, q, &i__1, rw, &i__2, &
+ iw[n * 2], &i__3, &info);
+ chkxer_("ZHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+
+ i__1 = n << 1;
+ i__2 = n * 24;
+ i__3 = n * 10;
+ zheevr_("V", "I", "U", &c__2, a, &c__2, &c_b458, &c_b458, &c__2, &
+ c__1, &c_b458, &m, r__, z__, &c__1, iw, q, &i__1, rw, &i__2, &
+ iw[n * 2], &i__3, &info);
+ chkxer_("ZHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ i__1 = n << 1;
+ i__2 = n * 24;
+ i__3 = n * 10;
+ zheevr_("V", "I", "U", &c__1, a, &c__1, &c_b458, &c_b458, &c__1, &
+ c__1, &c_b458, &m, r__, z__, &c__0, iw, q, &i__1, rw, &i__2, &
+ iw[n * 2], &i__3, &info);
+ chkxer_("ZHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ i__1 = (n << 1) - 1;
+ i__2 = n * 24;
+ i__3 = n * 10;
+ zheevr_("V", "I", "U", &c__1, a, &c__1, &c_b458, &c_b458, &c__1, &
+ c__1, &c_b458, &m, r__, z__, &c__1, iw, q, &i__1, rw, &i__2, &
+ iw[n * 2], &i__3, &info);
+ chkxer_("ZHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 20;
+ i__1 = n << 1;
+ i__2 = n * 24 - 1;
+ i__3 = n * 10;
+ zheevr_("V", "I", "U", &c__1, a, &c__1, &c_b458, &c_b458, &c__1, &
+ c__1, &c_b458, &m, r__, z__, &c__1, iw, q, &i__1, rw, &i__2, &
+ iw[(n << 1) - 2], &i__3, &info);
+ chkxer_("ZHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 22;
+ i__1 = n << 1;
+ i__2 = n * 24;
+ i__3 = n * 10 - 1;
+ zheevr_("V", "I", "U", &c__1, a, &c__1, &c_b458, &c_b458, &c__1, &
+ c__1, &c_b458, &m, r__, z__, &c__1, iw, q, &i__1, rw, &i__2,
+ iw, &i__3, &info);
+ chkxer_("ZHEEVR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 12;
+
+/* ZHPEVD */
+
+ s_copy(srnamc_1.srnamt, "ZHPEVD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhpevd_("/", "U", &c__0, a, x, z__, &c__1, w, &c__1, rw, &c__1, iw, &
+ c__1, &info);
+ chkxer_("ZHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhpevd_("N", "/", &c__0, a, x, z__, &c__1, w, &c__1, rw, &c__1, iw, &
+ c__1, &info);
+ chkxer_("ZHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zhpevd_("N", "U", &c_n1, a, x, z__, &c__1, w, &c__1, rw, &c__1, iw, &
+ c__1, &info);
+ chkxer_("ZHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zhpevd_("V", "U", &c__2, a, x, z__, &c__1, w, &c__4, rw, &c__25, iw, &
+ c__12, &info);
+ chkxer_("ZHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zhpevd_("N", "U", &c__1, a, x, z__, &c__1, w, &c__0, rw, &c__1, iw, &
+ c__1, &info);
+ chkxer_("ZHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zhpevd_("N", "U", &c__2, a, x, z__, &c__2, w, &c__1, rw, &c__2, iw, &
+ c__1, &info);
+ chkxer_("ZHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zhpevd_("V", "U", &c__2, a, x, z__, &c__2, w, &c__2, rw, &c__25, iw, &
+ c__12, &info);
+ chkxer_("ZHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zhpevd_("N", "U", &c__1, a, x, z__, &c__1, w, &c__1, rw, &c__0, iw, &
+ c__1, &info);
+ chkxer_("ZHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zhpevd_("N", "U", &c__2, a, x, z__, &c__2, w, &c__2, rw, &c__1, iw, &
+ c__1, &info);
+ chkxer_("ZHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zhpevd_("V", "U", &c__2, a, x, z__, &c__2, w, &c__4, rw, &c__18, iw, &
+ c__12, &info);
+ chkxer_("ZHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ zhpevd_("N", "U", &c__1, a, x, z__, &c__1, w, &c__1, rw, &c__1, iw, &
+ c__0, &info);
+ chkxer_("ZHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ zhpevd_("N", "U", &c__2, a, x, z__, &c__2, w, &c__2, rw, &c__2, iw, &
+ c__0, &info);
+ chkxer_("ZHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ zhpevd_("V", "U", &c__2, a, x, z__, &c__2, w, &c__4, rw, &c__25, iw, &
+ c__2, &info);
+ chkxer_("ZHPEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 13;
+
+/* ZHPEV */
+
+ s_copy(srnamc_1.srnamt, "ZHPEV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhpev_("/", "U", &c__0, a, x, z__, &c__1, w, rw, &info);
+ chkxer_("ZHPEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhpev_("N", "/", &c__0, a, x, z__, &c__1, w, rw, &info);
+ chkxer_("ZHPEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zhpev_("N", "U", &c_n1, a, x, z__, &c__1, w, rw, &info);
+ chkxer_("ZHPEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zhpev_("V", "U", &c__2, a, x, z__, &c__1, w, rw, &info);
+ chkxer_("ZHPEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 4;
+
+/* ZHPEVX */
+
+ s_copy(srnamc_1.srnamt, "ZHPEVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhpevx_("/", "A", "U", &c__0, a, &c_b458, &c_b458, &c__0, &c__0, &
+ c_b458, &m, x, z__, &c__1, w, rw, iw, i3, &info);
+ chkxer_("ZHPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhpevx_("V", "/", "U", &c__0, a, &c_b458, &c_b472, &c__1, &c__0, &
+ c_b458, &m, x, z__, &c__1, w, rw, iw, i3, &info);
+ chkxer_("ZHPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zhpevx_("V", "A", "/", &c__0, a, &c_b458, &c_b458, &c__0, &c__0, &
+ c_b458, &m, x, z__, &c__1, w, rw, iw, i3, &info);
+ chkxer_("ZHPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zhpevx_("V", "A", "U", &c_n1, a, &c_b458, &c_b458, &c__0, &c__0, &
+ c_b458, &m, x, z__, &c__1, w, rw, iw, i3, &info);
+ chkxer_("ZHPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zhpevx_("V", "V", "U", &c__1, a, &c_b458, &c_b458, &c__0, &c__0, &
+ c_b458, &m, x, z__, &c__1, w, rw, iw, i3, &info);
+ chkxer_("ZHPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zhpevx_("V", "I", "U", &c__1, a, &c_b458, &c_b458, &c__0, &c__0, &
+ c_b458, &m, x, z__, &c__1, w, rw, iw, i3, &info);
+ chkxer_("ZHPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zhpevx_("V", "I", "U", &c__2, a, &c_b458, &c_b458, &c__2, &c__1, &
+ c_b458, &m, x, z__, &c__2, w, rw, iw, i3, &info);
+ chkxer_("ZHPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ zhpevx_("V", "A", "U", &c__2, a, &c_b458, &c_b458, &c__0, &c__0, &
+ c_b458, &m, x, z__, &c__1, w, rw, iw, i3, &info);
+ chkxer_("ZHPEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 8;
+
+/* Test error exits for the HB path. */
+
+ } else if (lsamen_(&c__2, c2, "HB")) {
+
+/* ZHBTRD */
+
+ s_copy(srnamc_1.srnamt, "ZHBTRD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhbtrd_("/", "U", &c__0, &c__0, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("ZHBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhbtrd_("N", "/", &c__0, &c__0, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("ZHBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zhbtrd_("N", "U", &c_n1, &c__0, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("ZHBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zhbtrd_("N", "U", &c__0, &c_n1, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("ZHBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zhbtrd_("N", "U", &c__1, &c__1, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("ZHBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zhbtrd_("V", "U", &c__2, &c__0, a, &c__1, d__, e, z__, &c__1, w, &
+ info);
+ chkxer_("ZHBTRD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+/* ZHBEVD */
+
+ s_copy(srnamc_1.srnamt, "ZHBEVD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhbevd_("/", "U", &c__0, &c__0, a, &c__1, x, z__, &c__1, w, &c__1, rw,
+ &c__1, iw, &c__1, &info);
+ chkxer_("ZHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhbevd_("N", "/", &c__0, &c__0, a, &c__1, x, z__, &c__1, w, &c__1, rw,
+ &c__1, iw, &c__1, &info);
+ chkxer_("ZHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zhbevd_("N", "U", &c_n1, &c__0, a, &c__1, x, z__, &c__1, w, &c__1, rw,
+ &c__1, iw, &c__1, &info);
+ chkxer_("ZHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zhbevd_("N", "U", &c__0, &c_n1, a, &c__1, x, z__, &c__1, w, &c__1, rw,
+ &c__1, iw, &c__1, &info);
+ chkxer_("ZHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zhbevd_("N", "U", &c__2, &c__1, a, &c__1, x, z__, &c__1, w, &c__2, rw,
+ &c__2, iw, &c__1, &info);
+ chkxer_("ZHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zhbevd_("V", "U", &c__2, &c__1, a, &c__2, x, z__, &c__1, w, &c__8, rw,
+ &c__25, iw, &c__12, &info);
+ chkxer_("ZHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zhbevd_("N", "U", &c__1, &c__0, a, &c__1, x, z__, &c__1, w, &c__0, rw,
+ &c__1, iw, &c__1, &info);
+ chkxer_("ZHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zhbevd_("N", "U", &c__2, &c__1, a, &c__2, x, z__, &c__2, w, &c__1, rw,
+ &c__2, iw, &c__1, &info);
+ chkxer_("ZHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zhbevd_("V", "U", &c__2, &c__1, a, &c__2, x, z__, &c__2, w, &c__2, rw,
+ &c__25, iw, &c__12, &info);
+ chkxer_("ZHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ zhbevd_("N", "U", &c__1, &c__0, a, &c__1, x, z__, &c__1, w, &c__1, rw,
+ &c__0, iw, &c__1, &info);
+ chkxer_("ZHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ zhbevd_("N", "U", &c__2, &c__1, a, &c__2, x, z__, &c__2, w, &c__2, rw,
+ &c__1, iw, &c__1, &info);
+ chkxer_("ZHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ zhbevd_("V", "U", &c__2, &c__1, a, &c__2, x, z__, &c__2, w, &c__8, rw,
+ &c__2, iw, &c__12, &info);
+ chkxer_("ZHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ zhbevd_("N", "U", &c__1, &c__0, a, &c__1, x, z__, &c__1, w, &c__1, rw,
+ &c__1, iw, &c__0, &info);
+ chkxer_("ZHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ zhbevd_("N", "U", &c__2, &c__1, a, &c__2, x, z__, &c__2, w, &c__2, rw,
+ &c__2, iw, &c__0, &info);
+ chkxer_("ZHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ zhbevd_("V", "U", &c__2, &c__1, a, &c__2, x, z__, &c__2, w, &c__8, rw,
+ &c__25, iw, &c__2, &info);
+ chkxer_("ZHBEVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 15;
+
+/* ZHBEV */
+
+ s_copy(srnamc_1.srnamt, "ZHBEV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhbev_("/", "U", &c__0, &c__0, a, &c__1, x, z__, &c__1, w, rw, &info);
+ chkxer_("ZHBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhbev_("N", "/", &c__0, &c__0, a, &c__1, x, z__, &c__1, w, rw, &info);
+ chkxer_("ZHBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zhbev_("N", "U", &c_n1, &c__0, a, &c__1, x, z__, &c__1, w, rw, &info);
+ chkxer_("ZHBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zhbev_("N", "U", &c__0, &c_n1, a, &c__1, x, z__, &c__1, w, rw, &info);
+ chkxer_("ZHBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zhbev_("N", "U", &c__2, &c__1, a, &c__1, x, z__, &c__1, w, rw, &info);
+ chkxer_("ZHBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zhbev_("V", "U", &c__2, &c__0, a, &c__1, x, z__, &c__1, w, rw, &info);
+ chkxer_("ZHBEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 6;
+
+/* ZHBEVX */
+
+ s_copy(srnamc_1.srnamt, "ZHBEVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhbevx_("/", "A", "U", &c__0, &c__0, a, &c__1, q, &c__1, &c_b458, &
+ c_b458, &c__0, &c__0, &c_b458, &m, x, z__, &c__1, w, rw, iw,
+ i3, &info);
+ chkxer_("ZHBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhbevx_("V", "/", "U", &c__0, &c__0, a, &c__1, q, &c__1, &c_b458, &
+ c_b472, &c__1, &c__0, &c_b458, &m, x, z__, &c__1, w, rw, iw,
+ i3, &info);
+ chkxer_("ZHBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zhbevx_("V", "A", "/", &c__0, &c__0, a, &c__1, q, &c__1, &c_b458, &
+ c_b458, &c__0, &c__0, &c_b458, &m, x, z__, &c__1, w, rw, iw,
+ i3, &info);
+ infoc_1.infot = 4;
+ zhbevx_("V", "A", "U", &c_n1, &c__0, a, &c__1, q, &c__1, &c_b458, &
+ c_b458, &c__0, &c__0, &c_b458, &m, x, z__, &c__1, w, rw, iw,
+ i3, &info);
+ chkxer_("ZHBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zhbevx_("V", "A", "U", &c__0, &c_n1, a, &c__1, q, &c__1, &c_b458, &
+ c_b458, &c__0, &c__0, &c_b458, &m, x, z__, &c__1, w, rw, iw,
+ i3, &info);
+ chkxer_("ZHBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zhbevx_("V", "A", "U", &c__2, &c__1, a, &c__1, q, &c__2, &c_b458, &
+ c_b458, &c__0, &c__0, &c_b458, &m, x, z__, &c__2, w, rw, iw,
+ i3, &info);
+ chkxer_("ZHBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zhbevx_("V", "A", "U", &c__2, &c__0, a, &c__1, q, &c__1, &c_b458, &
+ c_b458, &c__0, &c__0, &c_b458, &m, x, z__, &c__2, w, rw, iw,
+ i3, &info);
+ chkxer_("ZHBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zhbevx_("V", "V", "U", &c__1, &c__0, a, &c__1, q, &c__1, &c_b458, &
+ c_b458, &c__0, &c__0, &c_b458, &m, x, z__, &c__1, w, rw, iw,
+ i3, &info);
+ chkxer_("ZHBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zhbevx_("V", "I", "U", &c__1, &c__0, a, &c__1, q, &c__1, &c_b458, &
+ c_b458, &c__0, &c__0, &c_b458, &m, x, z__, &c__1, w, rw, iw,
+ i3, &info);
+ chkxer_("ZHBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ zhbevx_("V", "I", "U", &c__1, &c__0, a, &c__1, q, &c__1, &c_b458, &
+ c_b458, &c__1, &c__2, &c_b458, &m, x, z__, &c__1, w, rw, iw,
+ i3, &info);
+ chkxer_("ZHBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ zhbevx_("V", "A", "U", &c__2, &c__0, a, &c__1, q, &c__2, &c_b458, &
+ c_b458, &c__0, &c__0, &c_b458, &m, x, z__, &c__1, w, rw, iw,
+ i3, &info);
+ chkxer_("ZHBEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ nt += 11;
+ }
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___24.ciunit = infoc_1.nout;
+ s_wsfe(&io___24);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___25.ciunit = infoc_1.nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of ZERRST */
+
+} /* zerrst_ */
diff --git a/TESTING/EIG/zget02.c b/TESTING/EIG/zget02.c
new file mode 100644
index 0000000..b21bc86
--- /dev/null
+++ b/TESTING/EIG/zget02.c
@@ -0,0 +1,189 @@
+/* zget02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b7 = {-1.,-0.};
+static doublecomplex c_b8 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zget02_(char *trans, integer *m, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *x, integer *ldx,
+ doublecomplex *b, integer *ldb, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j, n1, n2;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ doublereal anorm, bnorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ doublereal xnorm;
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *),
+ dzasum_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGET02 computes the residual for a solution of a system of linear */
+/* equations A*x = b or A'*x = b: */
+/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A *x = b */
+/* = 'T': A^T*x = b, where A^T is the transpose of A */
+/* = 'C': A^H*x = b, where A^H is the conjugate transpose of A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original M x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. IF TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if M = 0 or N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0 || *nrhs == 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+ if (lsame_(trans, "T") || lsame_(trans, "C")) {
+ n1 = *n;
+ n2 = *m;
+ } else {
+ n1 = *m;
+ n2 = *n;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlange_("1", &n1, &n2, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute B - A*X (or B - A'*X ) and store in B. */
+
+ zgemm_(trans, "No transpose", &n1, nrhs, &n2, &c_b7, &a[a_offset], lda, &
+ x[x_offset], ldx, &c_b8, &b[b_offset], ldb)
+ ;
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = dzasum_(&n1, &b[j * b_dim1 + 1], &c__1);
+ xnorm = dzasum_(&n2, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of ZGET02 */
+
+} /* zget02_ */
diff --git a/TESTING/EIG/zget10.c b/TESTING/EIG/zget10.c
new file mode 100644
index 0000000..b95286a
--- /dev/null
+++ b/TESTING/EIG/zget10.c
@@ -0,0 +1,151 @@
+/* zget10.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublecomplex c_b9 = {-1.,0.};
+
+/* Subroutine */ int zget10_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *b, integer *ldb, doublecomplex *work,
+ doublereal *rwork, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ doublereal eps, unfl, anorm, wnorm;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *),
+ dzasum_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGET10 compares two matrices A and B and computes the ratio */
+/* RESULT = norm( A - B ) / ( norm(A) * M * EPS ) */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices A and B. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,N) */
+/* The m by n matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,M). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (M) */
+
+/* RWORK (workspace) COMPLEX*16 array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION */
+/* RESULT = norm( A - B ) / ( norm(A) * M * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ *result = 0.;
+ return 0;
+ }
+
+ unfl = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+
+ wnorm = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(m, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
+ zaxpy_(m, &c_b9, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+/* Computing MAX */
+ d__1 = wnorm, d__2 = dzasum_(n, &work[1], &c__1);
+ wnorm = max(d__1,d__2);
+/* L10: */
+ }
+
+/* Computing MAX */
+ d__1 = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ anorm = max(d__1,unfl);
+
+ if (anorm > wnorm) {
+ *result = wnorm / anorm / (*m * eps);
+ } else {
+ if (anorm < 1.) {
+/* Computing MIN */
+ d__1 = wnorm, d__2 = *m * anorm;
+ *result = min(d__1,d__2) / anorm / (*m * eps);
+ } else {
+/* Computing MIN */
+ d__1 = wnorm / anorm, d__2 = (doublereal) (*m);
+ *result = min(d__1,d__2) / (*m * eps);
+ }
+ }
+
+ return 0;
+
+/* End of ZGET10 */
+
+} /* zget10_ */
diff --git a/TESTING/EIG/zget22.c b/TESTING/EIG/zget22.c
new file mode 100644
index 0000000..cbeb0a3
--- /dev/null
+++ b/TESTING/EIG/zget22.c
@@ -0,0 +1,346 @@
+/* zget22.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+
+/* Subroutine */ int zget22_(char *transa, char *transe, char *transw,
+ integer *n, doublecomplex *a, integer *lda, doublecomplex *e, integer
+ *lde, doublecomplex *w, doublecomplex *work, doublereal *rwork,
+ doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, e_dim1, e_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer j;
+ doublereal ulp;
+ integer joff, jcol, jvec;
+ doublereal unfl;
+ integer jrow;
+ doublereal temp1;
+ extern logical lsame_(char *, char *);
+ char norma[1];
+ doublereal anorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ char norme[1];
+ doublereal enorm;
+ doublecomplex wtemp;
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ doublereal enrmin, enrmax;
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+ integer itrnse;
+ doublereal errnrm;
+ integer itrnsw;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGET22 does an eigenvector check. */
+
+/* The basic test is: */
+
+/* RESULT(1) = | A E - E W | / ( |A| |E| ulp ) */
+
+/* using the 1-norm. It also tests the normalization of E: */
+
+/* RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp ) */
+/* j */
+
+/* where E(j) is the j-th eigenvector, and m-norm is the max-norm of a */
+/* vector. The max-norm of a complex n-vector x in this case is the */
+/* maximum of |re(x(i)| + |im(x(i)| over i = 1, ..., n. */
+
+/* Arguments */
+/* ========== */
+
+/* TRANSA (input) CHARACTER*1 */
+/* Specifies whether or not A is transposed. */
+/* = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose */
+
+/* TRANSE (input) CHARACTER*1 */
+/* Specifies whether or not E is transposed. */
+/* = 'N': No transpose, eigenvectors are in columns of E */
+/* = 'T': Transpose, eigenvectors are in rows of E */
+/* = 'C': Conjugate transpose, eigenvectors are in rows of E */
+
+/* TRANSW (input) CHARACTER*1 */
+/* Specifies whether or not W is transposed. */
+/* = 'N': No transpose */
+/* = 'T': Transpose, same as TRANSW = 'N' */
+/* = 'C': Conjugate transpose, use -WI(j) instead of WI(j) */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The matrix whose eigenvectors are in E. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* E (input) COMPLEX*16 array, dimension (LDE,N) */
+/* The matrix of eigenvectors. If TRANSE = 'N', the eigenvectors */
+/* are stored in the columns of E, if TRANSE = 'T' or 'C', the */
+/* eigenvectors are stored in the rows of E. */
+
+/* LDE (input) INTEGER */
+/* The leading dimension of the array E. LDE >= max(1,N). */
+
+/* W (input) COMPLEX*16 array, dimension (N) */
+/* The eigenvalues of A. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* RESULT(1) = | A E - E W | / ( |A| |E| ulp ) */
+/* RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp ) */
+/* j */
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize RESULT (in case N=0) */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ e_dim1 = *lde;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ --w;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.;
+ result[2] = 0.;
+ if (*n <= 0) {
+ return 0;
+ }
+
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Precision");
+
+ itrnse = 0;
+ itrnsw = 0;
+ *(unsigned char *)norma = 'O';
+ *(unsigned char *)norme = 'O';
+
+ if (lsame_(transa, "T") || lsame_(transa, "C")) {
+ *(unsigned char *)norma = 'I';
+ }
+
+ if (lsame_(transe, "T")) {
+ itrnse = 1;
+ *(unsigned char *)norme = 'I';
+ } else if (lsame_(transe, "C")) {
+ itrnse = 2;
+ *(unsigned char *)norme = 'I';
+ }
+
+ if (lsame_(transw, "C")) {
+ itrnsw = 1;
+ }
+
+/* Normalization of E: */
+
+ enrmin = 1. / ulp;
+ enrmax = 0.;
+ if (itrnse == 0) {
+ i__1 = *n;
+ for (jvec = 1; jvec <= i__1; ++jvec) {
+ temp1 = 0.;
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ i__3 = j + jvec * e_dim1;
+ d__3 = temp1, d__4 = (d__1 = e[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&e[j + jvec * e_dim1]), abs(d__2));
+ temp1 = max(d__3,d__4);
+/* L10: */
+ }
+ enrmin = min(enrmin,temp1);
+ enrmax = max(enrmax,temp1);
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (jvec = 1; jvec <= i__1; ++jvec) {
+ rwork[jvec] = 0.;
+/* L30: */
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (jvec = 1; jvec <= i__2; ++jvec) {
+/* Computing MAX */
+ i__3 = jvec + j * e_dim1;
+ d__3 = rwork[jvec], d__4 = (d__1 = e[i__3].r, abs(d__1)) + (
+ d__2 = d_imag(&e[jvec + j * e_dim1]), abs(d__2));
+ rwork[jvec] = max(d__3,d__4);
+/* L40: */
+ }
+/* L50: */
+ }
+
+ i__1 = *n;
+ for (jvec = 1; jvec <= i__1; ++jvec) {
+/* Computing MIN */
+ d__1 = enrmin, d__2 = rwork[jvec];
+ enrmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = enrmax, d__2 = rwork[jvec];
+ enrmax = max(d__1,d__2);
+/* L60: */
+ }
+ }
+
+/* Norm of A: */
+
+/* Computing MAX */
+ d__1 = zlange_(norma, n, n, &a[a_offset], lda, &rwork[1]);
+ anorm = max(d__1,unfl);
+
+/* Norm of E: */
+
+/* Computing MAX */
+ d__1 = zlange_(norme, n, n, &e[e_offset], lde, &rwork[1]);
+ enorm = max(d__1,ulp);
+
+/* Norm of error: */
+
+/* Error = AE - EW */
+
+ zlaset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
+
+ joff = 0;
+ i__1 = *n;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ if (itrnsw == 0) {
+ i__2 = jcol;
+ wtemp.r = w[i__2].r, wtemp.i = w[i__2].i;
+ } else {
+ d_cnjg(&z__1, &w[jcol]);
+ wtemp.r = z__1.r, wtemp.i = z__1.i;
+ }
+
+ if (itrnse == 0) {
+ i__2 = *n;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ i__3 = joff + jrow;
+ i__4 = jrow + jcol * e_dim1;
+ z__1.r = e[i__4].r * wtemp.r - e[i__4].i * wtemp.i, z__1.i =
+ e[i__4].r * wtemp.i + e[i__4].i * wtemp.r;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L70: */
+ }
+ } else if (itrnse == 1) {
+ i__2 = *n;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ i__3 = joff + jrow;
+ i__4 = jcol + jrow * e_dim1;
+ z__1.r = e[i__4].r * wtemp.r - e[i__4].i * wtemp.i, z__1.i =
+ e[i__4].r * wtemp.i + e[i__4].i * wtemp.r;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L80: */
+ }
+ } else {
+ i__2 = *n;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ i__3 = joff + jrow;
+ d_cnjg(&z__2, &e[jcol + jrow * e_dim1]);
+ z__1.r = z__2.r * wtemp.r - z__2.i * wtemp.i, z__1.i = z__2.r
+ * wtemp.i + z__2.i * wtemp.r;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L90: */
+ }
+ }
+ joff += *n;
+/* L100: */
+ }
+
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_(transa, transe, n, n, n, &c_b2, &a[a_offset], lda, &e[e_offset],
+ lde, &z__1, &work[1], n);
+
+ errnrm = zlange_("One", n, n, &work[1], n, &rwork[1]) / enorm;
+
+/* Compute RESULT(1) (avoiding under/overflow) */
+
+ if (anorm > errnrm) {
+ result[1] = errnrm / anorm / ulp;
+ } else {
+ if (anorm < 1.) {
+ result[1] = min(errnrm,anorm) / anorm / ulp;
+ } else {
+/* Computing MIN */
+ d__1 = errnrm / anorm;
+ result[1] = min(d__1,1.) / ulp;
+ }
+ }
+
+/* Compute RESULT(2) : the normalization error in E. */
+
+/* Computing MAX */
+ d__3 = (d__1 = enrmax - 1., abs(d__1)), d__4 = (d__2 = enrmin - 1., abs(
+ d__2));
+ result[2] = max(d__3,d__4) / ((doublereal) (*n) * ulp);
+
+ return 0;
+
+/* End of ZGET22 */
+
+} /* zget22_ */
diff --git a/TESTING/EIG/zget23.c b/TESTING/EIG/zget23.c
new file mode 100644
index 0000000..28534fd
--- /dev/null
+++ b/TESTING/EIG/zget23.c
@@ -0,0 +1,969 @@
+/* zget23.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__4 = 4;
+
+/* Subroutine */ int zget23_(logical *comp, integer *isrt, char *balanc,
+ integer *jtype, doublereal *thresh, integer *iseed, integer *nounit,
+ integer *n, doublecomplex *a, integer *lda, doublecomplex *h__,
+ doublecomplex *w, doublecomplex *w1, doublecomplex *vl, integer *ldvl,
+ doublecomplex *vr, integer *ldvr, doublecomplex *lre, integer *ldlre,
+ doublereal *rcondv, doublereal *rcndv1, doublereal *rcdvin,
+ doublereal *rconde, doublereal *rcnde1, doublereal *rcdein,
+ doublereal *scale, doublereal *scale1, doublereal *result,
+ doublecomplex *work, integer *lwork, doublereal *rwork, integer *info)
+{
+ /* Initialized data */
+
+ static char sens[1*2] = "N" "V";
+
+ /* Format strings */
+ static char fmt_9998[] = "(\002 ZGET23: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, BALANC = "
+ "\002,a,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(\002 ZGET23: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, INPUT EXAMPLE NUMBER = \002,"
+ "i4)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, lre_dim1, lre_offset, vl_dim1,
+ vl_offset, vr_dim1, vr_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4, d__5;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double z_abs(doublecomplex *), d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal v;
+ integer jj, ihi, ilo;
+ doublereal eps, res[2], tol, ulp, vmx;
+ integer ihi1, ilo1;
+ doublecomplex cdum[1];
+ integer kmin;
+ doublecomplex ctmp;
+ doublereal vmax, tnrm, vrmx, vtst;
+ logical balok, nobal;
+ doublereal abnrm;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ char sense[1];
+ extern /* Subroutine */ int zget22_(char *, char *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublereal *, doublereal *);
+ integer isens;
+ doublereal tolin, abnrm1;
+ extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
+ char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ integer isensm;
+ doublereal vricmp;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal vrimin;
+ extern /* Subroutine */ int zgeevx_(char *, char *, char *, char *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *
+, doublecomplex *, integer *, doublereal *, integer *);
+ doublereal smlnum, ulpinv;
+
+ /* Fortran I/O blocks */
+ static cilist io___14 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___15 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGET23 checks the nonsymmetric eigenvalue problem driver CGEEVX. */
+/* If COMP = .FALSE., the first 8 of the following tests will be */
+/* performed on the input matrix A, and also test 9 if LWORK is */
+/* sufficiently large. */
+/* if COMP is .TRUE. all 11 tests will be performed. */
+
+/* (1) | A * VR - VR * W | / ( n |A| ulp ) */
+
+/* Here VR is the matrix of unit right eigenvectors. */
+/* W is a diagonal matrix with diagonal entries W(j). */
+
+/* (2) | A**H * VL - VL * W**H | / ( n |A| ulp ) */
+
+/* Here VL is the matrix of unit left eigenvectors, A**H is the */
+/* conjugate transpose of A, and W is as above. */
+
+/* (3) | |VR(i)| - 1 | / ulp and largest component real */
+
+/* VR(i) denotes the i-th column of VR. */
+
+/* (4) | |VL(i)| - 1 | / ulp and largest component real */
+
+/* VL(i) denotes the i-th column of VL. */
+
+/* (5) 0 if W(full) = W(partial), 1/ulp otherwise */
+
+/* W(full) denotes the eigenvalues computed when VR, VL, RCONDV */
+/* and RCONDE are also computed, and W(partial) denotes the */
+/* eigenvalues computed when only some of VR, VL, RCONDV, and */
+/* RCONDE are computed. */
+
+/* (6) 0 if VR(full) = VR(partial), 1/ulp otherwise */
+
+/* VR(full) denotes the right eigenvectors computed when VL, RCONDV */
+/* and RCONDE are computed, and VR(partial) denotes the result */
+/* when only some of VL and RCONDV are computed. */
+
+/* (7) 0 if VL(full) = VL(partial), 1/ulp otherwise */
+
+/* VL(full) denotes the left eigenvectors computed when VR, RCONDV */
+/* and RCONDE are computed, and VL(partial) denotes the result */
+/* when only some of VR and RCONDV are computed. */
+
+/* (8) 0 if SCALE, ILO, IHI, ABNRM (full) = */
+/* SCALE, ILO, IHI, ABNRM (partial) */
+/* 1/ulp otherwise */
+
+/* SCALE, ILO, IHI and ABNRM describe how the matrix is balanced. */
+/* (full) is when VR, VL, RCONDE and RCONDV are also computed, and */
+/* (partial) is when some are not computed. */
+
+/* (9) 0 if RCONDV(full) = RCONDV(partial), 1/ulp otherwise */
+
+/* RCONDV(full) denotes the reciprocal condition numbers of the */
+/* right eigenvectors computed when VR, VL and RCONDE are also */
+/* computed. RCONDV(partial) denotes the reciprocal condition */
+/* numbers when only some of VR, VL and RCONDE are computed. */
+
+/* (10) |RCONDV - RCDVIN| / cond(RCONDV) */
+
+/* RCONDV is the reciprocal right eigenvector condition number */
+/* computed by ZGEEVX and RCDVIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDV) is the condition number of */
+/* RCONDV, and takes errors in computing RCONDV into account, so */
+/* that the resulting quantity should be O(ULP). cond(RCONDV) is */
+/* essentially given by norm(A)/RCONDE. */
+
+/* (11) |RCONDE - RCDEIN| / cond(RCONDE) */
+
+/* RCONDE is the reciprocal eigenvalue condition number */
+/* computed by ZGEEVX and RCDEIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDE) is the condition number */
+/* of RCONDE, and takes errors in computing RCONDE into account, */
+/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
+/* is essentially given by norm(A)/RCONDV. */
+
+/* Arguments */
+/* ========= */
+
+/* COMP (input) LOGICAL */
+/* COMP describes which input tests to perform: */
+/* = .FALSE. if the computed condition numbers are not to */
+/* be tested against RCDVIN and RCDEIN */
+/* = .TRUE. if they are to be compared */
+
+/* ISRT (input) INTEGER */
+/* If COMP = .TRUE., ISRT indicates in how the eigenvalues */
+/* corresponding to values in RCDVIN and RCDEIN are ordered: */
+/* = 0 means the eigenvalues are sorted by */
+/* increasing real part */
+/* = 1 means the eigenvalues are sorted by */
+/* increasing imaginary part */
+/* If COMP = .FALSE., ISRT is not referenced. */
+
+/* BALANC (input) CHARACTER */
+/* Describes the balancing option to be tested. */
+/* = 'N' for no permuting or diagonal scaling */
+/* = 'P' for permuting but no diagonal scaling */
+/* = 'S' for no permuting but diagonal scaling */
+/* = 'B' for permuting and diagonal scaling */
+
+/* JTYPE (input) INTEGER */
+/* Type of input matrix. Used to label output if error occurs. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* ISEED (input) INTEGER array, dimension (4) */
+/* If COMP = .FALSE., the random number generator seed */
+/* used to produce matrix. */
+/* If COMP = .TRUE., ISEED(1) = the number of the example. */
+/* Used to label output if error occurs. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* N (input) INTEGER */
+/* The dimension of A. N must be at least 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, and H. LDA must be at */
+/* least 1 and at least N. */
+
+/* H (workspace) COMPLEX*16 array, dimension (LDA,N) */
+/* Another copy of the test matrix A, modified by ZGEEVX. */
+
+/* W (workspace) COMPLEX*16 array, dimension (N) */
+/* Contains the eigenvalues of A. */
+
+/* W1 (workspace) COMPLEX*16 array, dimension (N) */
+/* Like W, this array contains the eigenvalues of A, */
+/* but those computed when ZGEEVX only computes a partial */
+/* eigendecomposition, i.e. not the eigenvalues and left */
+/* and right eigenvectors. */
+
+/* VL (workspace) COMPLEX*16 array, dimension (LDVL,N) */
+/* VL holds the computed left eigenvectors. */
+
+/* LDVL (input) INTEGER */
+/* Leading dimension of VL. Must be at least max(1,N). */
+
+/* VR (workspace) COMPLEX*16 array, dimension (LDVR,N) */
+/* VR holds the computed right eigenvectors. */
+
+/* LDVR (input) INTEGER */
+/* Leading dimension of VR. Must be at least max(1,N). */
+
+/* LRE (workspace) COMPLEX*16 array, dimension (LDLRE,N) */
+/* LRE holds the computed right or left eigenvectors. */
+
+/* LDLRE (input) INTEGER */
+/* Leading dimension of LRE. Must be at least max(1,N). */
+
+/* RCONDV (workspace) DOUBLE PRECISION array, dimension (N) */
+/* RCONDV holds the computed reciprocal condition numbers */
+/* for eigenvectors. */
+
+/* RCNDV1 (workspace) DOUBLE PRECISION array, dimension (N) */
+/* RCNDV1 holds more computed reciprocal condition numbers */
+/* for eigenvectors. */
+
+/* RCDVIN (input) DOUBLE PRECISION array, dimension (N) */
+/* When COMP = .TRUE. RCDVIN holds the precomputed reciprocal */
+/* condition numbers for eigenvectors to be compared with */
+/* RCONDV. */
+
+/* RCONDE (workspace) DOUBLE PRECISION array, dimension (N) */
+/* RCONDE holds the computed reciprocal condition numbers */
+/* for eigenvalues. */
+
+/* RCNDE1 (workspace) DOUBLE PRECISION array, dimension (N) */
+/* RCNDE1 holds more computed reciprocal condition numbers */
+/* for eigenvalues. */
+
+/* RCDEIN (input) DOUBLE PRECISION array, dimension (N) */
+/* When COMP = .TRUE. RCDEIN holds the precomputed reciprocal */
+/* condition numbers for eigenvalues to be compared with */
+/* RCONDE. */
+
+/* SCALE (workspace) DOUBLE PRECISION array, dimension (N) */
+/* Holds information describing balancing of matrix. */
+
+/* SCALE1 (workspace) DOUBLE PRECISION array, dimension (N) */
+/* Holds information describing balancing of matrix. */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (11) */
+/* The values computed by the 11 tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK. This must be at least */
+/* 2*N, and 2*N+N**2 if tests 9, 10 or 11 are to be performed. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* If 0, successful exit. */
+/* If <0, input parameter -INFO had an incorrect value. */
+/* If >0, ZGEEVX returned an error code, the absolute */
+/* value of which is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iseed;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ --w1;
+ vl_dim1 = *ldvl;
+ vl_offset = 1 + vl_dim1;
+ vl -= vl_offset;
+ vr_dim1 = *ldvr;
+ vr_offset = 1 + vr_dim1;
+ vr -= vr_offset;
+ lre_dim1 = *ldlre;
+ lre_offset = 1 + lre_dim1;
+ lre -= lre_offset;
+ --rcondv;
+ --rcndv1;
+ --rcdvin;
+ --rconde;
+ --rcnde1;
+ --rcdein;
+ --scale;
+ --scale1;
+ --result;
+ --work;
+ --rwork;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ nobal = lsame_(balanc, "N");
+ balok = nobal || lsame_(balanc, "P") || lsame_(
+ balanc, "S") || lsame_(balanc, "B");
+ *info = 0;
+ if (*isrt != 0 && *isrt != 1) {
+ *info = -2;
+ } else if (! balok) {
+ *info = -3;
+ } else if (*thresh < 0.) {
+ *info = -5;
+ } else if (*nounit <= 0) {
+ *info = -7;
+ } else if (*n < 0) {
+ *info = -8;
+ } else if (*lda < 1 || *lda < *n) {
+ *info = -10;
+ } else if (*ldvl < 1 || *ldvl < *n) {
+ *info = -15;
+ } else if (*ldvr < 1 || *ldvr < *n) {
+ *info = -17;
+ } else if (*ldlre < 1 || *ldlre < *n) {
+ *info = -19;
+ } else if (*lwork < *n << 1 || *comp && *lwork < (*n << 1) + *n * *n) {
+ *info = -30;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGET23", &i__1);
+ return 0;
+ }
+
+/* Quick return if nothing to do */
+
+ for (i__ = 1; i__ <= 11; ++i__) {
+ result[i__] = -1.;
+/* L10: */
+ }
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* More Important constants */
+
+ ulp = dlamch_("Precision");
+ smlnum = dlamch_("S");
+ ulpinv = 1. / ulp;
+
+/* Compute eigenvalues and eigenvectors, and test them */
+
+ if (*lwork >= (*n << 1) + *n * *n) {
+ *(unsigned char *)sense = 'B';
+ isensm = 2;
+ } else {
+ *(unsigned char *)sense = 'E';
+ isensm = 1;
+ }
+ zlacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ zgeevx_(balanc, "V", "V", sense, n, &h__[h_offset], lda, &w[1], &vl[
+ vl_offset], ldvl, &vr[vr_offset], ldvr, &ilo, &ihi, &scale[1], &
+ abnrm, &rconde[1], &rcondv[1], &work[1], lwork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ if (*jtype != 22) {
+ io___14.ciunit = *nounit;
+ s_wsfe(&io___14);
+ do_fio(&c__1, "ZGEEVX1", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__1, balanc, (ftnlen)1);
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___15.ciunit = *nounit;
+ s_wsfe(&io___15);
+ do_fio(&c__1, "ZGEEVX1", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ return 0;
+ }
+
+/* Do Test (1) */
+
+ zget22_("N", "N", "N", n, &a[a_offset], lda, &vr[vr_offset], ldvr, &w[1],
+ &work[1], &rwork[1], res);
+ result[1] = res[0];
+
+/* Do Test (2) */
+
+ zget22_("C", "N", "C", n, &a[a_offset], lda, &vl[vl_offset], ldvl, &w[1],
+ &work[1], &rwork[1], res);
+ result[2] = res[0];
+
+/* Do Test (3) */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ tnrm = dznrm2_(n, &vr[j * vr_dim1 + 1], &c__1);
+/* Computing MAX */
+/* Computing MIN */
+ d__4 = ulpinv, d__5 = (d__1 = tnrm - 1., abs(d__1)) / ulp;
+ d__2 = result[3], d__3 = min(d__4,d__5);
+ result[3] = max(d__2,d__3);
+ vmx = 0.;
+ vrmx = 0.;
+ i__2 = *n;
+ for (jj = 1; jj <= i__2; ++jj) {
+ vtst = z_abs(&vr[jj + j * vr_dim1]);
+ if (vtst > vmx) {
+ vmx = vtst;
+ }
+ i__3 = jj + j * vr_dim1;
+ if (d_imag(&vr[jj + j * vr_dim1]) == 0. && (d__1 = vr[i__3].r,
+ abs(d__1)) > vrmx) {
+ i__4 = jj + j * vr_dim1;
+ vrmx = (d__2 = vr[i__4].r, abs(d__2));
+ }
+/* L20: */
+ }
+ if (vrmx / vmx < 1. - ulp * 2.) {
+ result[3] = ulpinv;
+ }
+/* L30: */
+ }
+
+/* Do Test (4) */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ tnrm = dznrm2_(n, &vl[j * vl_dim1 + 1], &c__1);
+/* Computing MAX */
+/* Computing MIN */
+ d__4 = ulpinv, d__5 = (d__1 = tnrm - 1., abs(d__1)) / ulp;
+ d__2 = result[4], d__3 = min(d__4,d__5);
+ result[4] = max(d__2,d__3);
+ vmx = 0.;
+ vrmx = 0.;
+ i__2 = *n;
+ for (jj = 1; jj <= i__2; ++jj) {
+ vtst = z_abs(&vl[jj + j * vl_dim1]);
+ if (vtst > vmx) {
+ vmx = vtst;
+ }
+ i__3 = jj + j * vl_dim1;
+ if (d_imag(&vl[jj + j * vl_dim1]) == 0. && (d__1 = vl[i__3].r,
+ abs(d__1)) > vrmx) {
+ i__4 = jj + j * vl_dim1;
+ vrmx = (d__2 = vl[i__4].r, abs(d__2));
+ }
+/* L40: */
+ }
+ if (vrmx / vmx < 1. - ulp * 2.) {
+ result[4] = ulpinv;
+ }
+/* L50: */
+ }
+
+/* Test for all options of computing condition numbers */
+
+ i__1 = isensm;
+ for (isens = 1; isens <= i__1; ++isens) {
+
+ *(unsigned char *)sense = *(unsigned char *)&sens[isens - 1];
+
+/* Compute eigenvalues only, and test them */
+
+ zlacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ zgeevx_(balanc, "N", "N", sense, n, &h__[h_offset], lda, &w1[1], cdum,
+ &c__1, cdum, &c__1, &ilo1, &ihi1, &scale1[1], &abnrm1, &
+ rcnde1[1], &rcndv1[1], &work[1], lwork, &rwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ if (*jtype != 22) {
+ io___28.ciunit = *nounit;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "ZGEEVX2", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__1, balanc, (ftnlen)1);
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___29.ciunit = *nounit;
+ s_wsfe(&io___29);
+ do_fio(&c__1, "ZGEEVX2", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L190;
+ }
+
+/* Do Test (5) */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j;
+ i__4 = j;
+ if (w[i__3].r != w1[i__4].r || w[i__3].i != w1[i__4].i) {
+ result[5] = ulpinv;
+ }
+/* L60: */
+ }
+
+/* Do Test (8) */
+
+ if (! nobal) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (scale[j] != scale1[j]) {
+ result[8] = ulpinv;
+ }
+/* L70: */
+ }
+ if (ilo != ilo1) {
+ result[8] = ulpinv;
+ }
+ if (ihi != ihi1) {
+ result[8] = ulpinv;
+ }
+ if (abnrm != abnrm1) {
+ result[8] = ulpinv;
+ }
+ }
+
+/* Do Test (9) */
+
+ if (isens == 2 && *n > 1) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (rcondv[j] != rcndv1[j]) {
+ result[9] = ulpinv;
+ }
+/* L80: */
+ }
+ }
+
+/* Compute eigenvalues and right eigenvectors, and test them */
+
+ zlacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ zgeevx_(balanc, "N", "V", sense, n, &h__[h_offset], lda, &w1[1], cdum,
+ &c__1, &lre[lre_offset], ldlre, &ilo1, &ihi1, &scale1[1], &
+ abnrm1, &rcnde1[1], &rcndv1[1], &work[1], lwork, &rwork[1], &
+ iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ if (*jtype != 22) {
+ io___30.ciunit = *nounit;
+ s_wsfe(&io___30);
+ do_fio(&c__1, "ZGEEVX3", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__1, balanc, (ftnlen)1);
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___31.ciunit = *nounit;
+ s_wsfe(&io___31);
+ do_fio(&c__1, "ZGEEVX3", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L190;
+ }
+
+/* Do Test (5) again */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j;
+ i__4 = j;
+ if (w[i__3].r != w1[i__4].r || w[i__3].i != w1[i__4].i) {
+ result[5] = ulpinv;
+ }
+/* L90: */
+ }
+
+/* Do Test (6) */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = *n;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = j + jj * vr_dim1;
+ i__5 = j + jj * lre_dim1;
+ if (vr[i__4].r != lre[i__5].r || vr[i__4].i != lre[i__5].i) {
+ result[6] = ulpinv;
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+
+/* Do Test (8) again */
+
+ if (! nobal) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (scale[j] != scale1[j]) {
+ result[8] = ulpinv;
+ }
+/* L120: */
+ }
+ if (ilo != ilo1) {
+ result[8] = ulpinv;
+ }
+ if (ihi != ihi1) {
+ result[8] = ulpinv;
+ }
+ if (abnrm != abnrm1) {
+ result[8] = ulpinv;
+ }
+ }
+
+/* Do Test (9) again */
+
+ if (isens == 2 && *n > 1) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (rcondv[j] != rcndv1[j]) {
+ result[9] = ulpinv;
+ }
+/* L130: */
+ }
+ }
+
+/* Compute eigenvalues and left eigenvectors, and test them */
+
+ zlacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ zgeevx_(balanc, "V", "N", sense, n, &h__[h_offset], lda, &w1[1], &lre[
+ lre_offset], ldlre, cdum, &c__1, &ilo1, &ihi1, &scale1[1], &
+ abnrm1, &rcnde1[1], &rcndv1[1], &work[1], lwork, &rwork[1], &
+ iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ if (*jtype != 22) {
+ io___32.ciunit = *nounit;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "ZGEEVX4", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__1, balanc, (ftnlen)1);
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___33.ciunit = *nounit;
+ s_wsfe(&io___33);
+ do_fio(&c__1, "ZGEEVX4", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L190;
+ }
+
+/* Do Test (5) again */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j;
+ i__4 = j;
+ if (w[i__3].r != w1[i__4].r || w[i__3].i != w1[i__4].i) {
+ result[5] = ulpinv;
+ }
+/* L140: */
+ }
+
+/* Do Test (7) */
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = *n;
+ for (jj = 1; jj <= i__3; ++jj) {
+ i__4 = j + jj * vl_dim1;
+ i__5 = j + jj * lre_dim1;
+ if (vl[i__4].r != lre[i__5].r || vl[i__4].i != lre[i__5].i) {
+ result[7] = ulpinv;
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+
+/* Do Test (8) again */
+
+ if (! nobal) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (scale[j] != scale1[j]) {
+ result[8] = ulpinv;
+ }
+/* L170: */
+ }
+ if (ilo != ilo1) {
+ result[8] = ulpinv;
+ }
+ if (ihi != ihi1) {
+ result[8] = ulpinv;
+ }
+ if (abnrm != abnrm1) {
+ result[8] = ulpinv;
+ }
+ }
+
+/* Do Test (9) again */
+
+ if (isens == 2 && *n > 1) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (rcondv[j] != rcndv1[j]) {
+ result[9] = ulpinv;
+ }
+/* L180: */
+ }
+ }
+
+L190:
+
+/* L200: */
+ ;
+ }
+
+/* If COMP, compare condition numbers to precomputed ones */
+
+ if (*comp) {
+ zlacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ zgeevx_("N", "V", "V", "B", n, &h__[h_offset], lda, &w[1], &vl[
+ vl_offset], ldvl, &vr[vr_offset], ldvr, &ilo, &ihi, &scale[1],
+ &abnrm, &rconde[1], &rcondv[1], &work[1], lwork, &rwork[1], &
+ iinfo);
+ if (iinfo != 0) {
+ result[1] = ulpinv;
+ io___34.ciunit = *nounit;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "ZGEEVX5", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L250;
+ }
+
+/* Sort eigenvalues and condition numbers lexicographically */
+/* to compare with inputs */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ kmin = i__;
+ if (*isrt == 0) {
+ i__2 = i__;
+ vrimin = w[i__2].r;
+ } else {
+ vrimin = d_imag(&w[i__]);
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (*isrt == 0) {
+ i__3 = j;
+ vricmp = w[i__3].r;
+ } else {
+ vricmp = d_imag(&w[j]);
+ }
+ if (vricmp < vrimin) {
+ kmin = j;
+ vrimin = vricmp;
+ }
+/* L210: */
+ }
+ i__2 = kmin;
+ ctmp.r = w[i__2].r, ctmp.i = w[i__2].i;
+ i__2 = kmin;
+ i__3 = i__;
+ w[i__2].r = w[i__3].r, w[i__2].i = w[i__3].i;
+ i__2 = i__;
+ w[i__2].r = ctmp.r, w[i__2].i = ctmp.i;
+ vrimin = rconde[kmin];
+ rconde[kmin] = rconde[i__];
+ rconde[i__] = vrimin;
+ vrimin = rcondv[kmin];
+ rcondv[kmin] = rcondv[i__];
+ rcondv[i__] = vrimin;
+/* L220: */
+ }
+
+/* Compare condition numbers for eigenvectors */
+/* taking their condition numbers into account */
+
+ result[10] = 0.;
+ eps = max(5.9605e-8,ulp);
+/* Computing MAX */
+ d__1 = (doublereal) (*n) * eps * abnrm;
+ v = max(d__1,smlnum);
+ if (abnrm == 0.) {
+ v = 1.;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (v > rcondv[i__] * rconde[i__]) {
+ tol = rcondv[i__];
+ } else {
+ tol = v / rconde[i__];
+ }
+ if (v > rcdvin[i__] * rcdein[i__]) {
+ tolin = rcdvin[i__];
+ } else {
+ tolin = v / rcdein[i__];
+ }
+/* Computing MAX */
+ d__1 = tol, d__2 = smlnum / eps;
+ tol = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = tolin, d__2 = smlnum / eps;
+ tolin = max(d__1,d__2);
+ if (eps * (rcdvin[i__] - tolin) > rcondv[i__] + tol) {
+ vmax = 1. / eps;
+ } else if (rcdvin[i__] - tolin > rcondv[i__] + tol) {
+ vmax = (rcdvin[i__] - tolin) / (rcondv[i__] + tol);
+ } else if (rcdvin[i__] + tolin < eps * (rcondv[i__] - tol)) {
+ vmax = 1. / eps;
+ } else if (rcdvin[i__] + tolin < rcondv[i__] - tol) {
+ vmax = (rcondv[i__] - tol) / (rcdvin[i__] + tolin);
+ } else {
+ vmax = 1.;
+ }
+ result[10] = max(result[10],vmax);
+/* L230: */
+ }
+
+/* Compare condition numbers for eigenvalues */
+/* taking their condition numbers into account */
+
+ result[11] = 0.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (v > rcondv[i__]) {
+ tol = 1.;
+ } else {
+ tol = v / rcondv[i__];
+ }
+ if (v > rcdvin[i__]) {
+ tolin = 1.;
+ } else {
+ tolin = v / rcdvin[i__];
+ }
+/* Computing MAX */
+ d__1 = tol, d__2 = smlnum / eps;
+ tol = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = tolin, d__2 = smlnum / eps;
+ tolin = max(d__1,d__2);
+ if (eps * (rcdein[i__] - tolin) > rconde[i__] + tol) {
+ vmax = 1. / eps;
+ } else if (rcdein[i__] - tolin > rconde[i__] + tol) {
+ vmax = (rcdein[i__] - tolin) / (rconde[i__] + tol);
+ } else if (rcdein[i__] + tolin < eps * (rconde[i__] - tol)) {
+ vmax = 1. / eps;
+ } else if (rcdein[i__] + tolin < rconde[i__] - tol) {
+ vmax = (rconde[i__] - tol) / (rcdein[i__] + tolin);
+ } else {
+ vmax = 1.;
+ }
+ result[11] = max(result[11],vmax);
+/* L240: */
+ }
+L250:
+
+ ;
+ }
+
+
+ return 0;
+
+/* End of ZGET23 */
+
+} /* zget23_ */
diff --git a/TESTING/EIG/zget24.c b/TESTING/EIG/zget24.c
new file mode 100644
index 0000000..6cff7ab
--- /dev/null
+++ b/TESTING/EIG/zget24.c
@@ -0,0 +1,1183 @@
+/* zget24.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ doublereal selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+static integer c__4 = 4;
+
+/* Subroutine */ int zget24_(logical *comp, integer *jtype, doublereal *
+ thresh, integer *iseed, integer *nounit, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *h__, doublecomplex *ht, doublecomplex *
+ w, doublecomplex *wt, doublecomplex *wtmp, doublecomplex *vs, integer
+ *ldvs, doublecomplex *vs1, doublereal *rcdein, doublereal *rcdvin,
+ integer *nslct, integer *islct, integer *isrt, doublereal *result,
+ doublecomplex *work, integer *lwork, doublereal *rwork, logical *
+ bwork, integer *info)
+{
+ /* Format strings */
+ static char fmt_9998[] = "(\002 ZGET24: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
+ "(\002,3(i5,\002,\002),i5,\002)\002)";
+ static char fmt_9999[] = "(\002 ZGET24: \002,a,\002 returned INFO=\002,i"
+ "6,\002.\002,/9x,\002N=\002,i6,\002, INPUT EXAMPLE NUMBER = \002,"
+ "i4)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, ht_dim1, ht_offset, vs_dim1,
+ vs_offset, vs1_dim1, vs1_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal v, eps, tol, ulp;
+ integer sdim, kmin;
+ doublecomplex ctmp;
+ integer itmp, ipnt[20], rsub;
+ char sort[1];
+ integer sdim1, iinfo;
+ doublereal anorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ doublereal tolin;
+ integer isort;
+ extern /* Subroutine */ int zunt01_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+ doublereal wnorm;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ doublereal rcnde1, rcndv1;
+ extern doublereal dlamch_(char *);
+ doublereal rconde;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ integer knteig;
+ doublereal rcondv, vricmp;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal vrimin;
+ extern logical zslect_(doublecomplex *);
+ extern /* Subroutine */ int zgeesx_(char *, char *, L_fp, char *, integer
+ *, doublecomplex *, integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublereal *, logical *, integer *);
+ doublereal smlnum, ulpinv;
+
+ /* Fortran I/O blocks */
+ static cilist io___12 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___13 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___17 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___18 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___21 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGET24 checks the nonsymmetric eigenvalue (Schur form) problem */
+/* expert driver ZGEESX. */
+
+/* If COMP = .FALSE., the first 13 of the following tests will be */
+/* be performed on the input matrix A, and also tests 14 and 15 */
+/* if LWORK is sufficiently large. */
+/* If COMP = .TRUE., all 17 test will be performed. */
+
+/* (1) 0 if T is in Schur form, 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (2) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (no sorting of eigenvalues). */
+
+/* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues). */
+
+/* (4) 0 if W are eigenvalues of T */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (5) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* (no sorting of eigenvalues) */
+
+/* (7) 0 if T is in Schur form, 1/ulp otherwise */
+/* (with sorting of eigenvalues) */
+
+/* (8) | A - VS T VS' | / ( n |A| ulp ) */
+
+/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
+/* form (with sorting of eigenvalues). */
+
+/* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues). */
+
+/* (10) 0 if W are eigenvalues of T */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare W with and */
+/* without reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (11) 0 if T(with VS) = T(without VS), */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare T with and without */
+/* reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
+/* 1/ulp otherwise */
+/* If workspace sufficient, also compare VS with and without */
+/* reciprocal condition numbers */
+/* (with sorting of eigenvalues) */
+
+/* (13) if sorting worked and SDIM is the number of */
+/* eigenvalues which were SELECTed */
+/* If workspace sufficient, also compare SDIM with and */
+/* without reciprocal condition numbers */
+
+/* (14) if RCONDE the same no matter if VS and/or RCONDV computed */
+
+/* (15) if RCONDV the same no matter if VS and/or RCONDE computed */
+
+/* (16) |RCONDE - RCDEIN| / cond(RCONDE) */
+
+/* RCONDE is the reciprocal average eigenvalue condition number */
+/* computed by ZGEESX and RCDEIN (the precomputed true value) */
+/* is supplied as input. cond(RCONDE) is the condition number */
+/* of RCONDE, and takes errors in computing RCONDE into account, */
+/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
+/* is essentially given by norm(A)/RCONDV. */
+
+/* (17) |RCONDV - RCDVIN| / cond(RCONDV) */
+
+/* RCONDV is the reciprocal right invariant subspace condition */
+/* number computed by ZGEESX and RCDVIN (the precomputed true */
+/* value) is supplied as input. cond(RCONDV) is the condition */
+/* number of RCONDV, and takes errors in computing RCONDV into */
+/* account, so that the resulting quantity should be O(ULP). */
+/* cond(RCONDV) is essentially given by norm(A)/RCONDE. */
+
+/* Arguments */
+/* ========= */
+
+/* COMP (input) LOGICAL */
+/* COMP describes which input tests to perform: */
+/* = .FALSE. if the computed condition numbers are not to */
+/* be tested against RCDVIN and RCDEIN */
+/* = .TRUE. if they are to be compared */
+
+/* JTYPE (input) INTEGER */
+/* Type of input matrix. Used to label output if error occurs. */
+
+/* ISEED (input) INTEGER array, dimension (4) */
+/* If COMP = .FALSE., the random number generator seed */
+/* used to produce matrix. */
+/* If COMP = .TRUE., ISEED(1) = the number of the example. */
+/* Used to label output if error occurs. */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* A test will count as "failed" if the "error", computed as */
+/* described above, exceeds THRESH. Note that the error */
+/* is scaled to be O(1), so THRESH should be a reasonably */
+/* small multiple of 1, e.g., 10 or 100. In particular, */
+/* it should not depend on the precision (single vs. double) */
+/* or the size of the matrix. It must be at least zero. */
+
+/* NOUNIT (input) INTEGER */
+/* The FORTRAN unit number for printing out error messages */
+/* (e.g., if a routine returns INFO not equal to 0.) */
+
+/* N (input) INTEGER */
+/* The dimension of A. N must be at least 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA, N) */
+/* Used to hold the matrix whose eigenvalues are to be */
+/* computed. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, and H. LDA must be at */
+/* least 1 and at least N. */
+
+/* H (workspace) COMPLEX*16 array, dimension (LDA, N) */
+/* Another copy of the test matrix A, modified by ZGEESX. */
+
+/* HT (workspace) COMPLEX*16 array, dimension (LDA, N) */
+/* Yet another copy of the test matrix A, modified by ZGEESX. */
+
+/* W (workspace) COMPLEX*16 array, dimension (N) */
+/* The computed eigenvalues of A. */
+
+/* WT (workspace) COMPLEX*16 array, dimension (N) */
+/* Like W, this array contains the eigenvalues of A, */
+/* but those computed when ZGEESX only computes a partial */
+/* eigendecomposition, i.e. not Schur vectors */
+
+/* WTMP (workspace) COMPLEX*16 array, dimension (N) */
+/* Like W, this array contains the eigenvalues of A, */
+/* but sorted by increasing real or imaginary part. */
+
+/* VS (workspace) COMPLEX*16 array, dimension (LDVS, N) */
+/* VS holds the computed Schur vectors. */
+
+/* LDVS (input) INTEGER */
+/* Leading dimension of VS. Must be at least max(1, N). */
+
+/* VS1 (workspace) COMPLEX*16 array, dimension (LDVS, N) */
+/* VS1 holds another copy of the computed Schur vectors. */
+
+/* RCDEIN (input) DOUBLE PRECISION */
+/* When COMP = .TRUE. RCDEIN holds the precomputed reciprocal */
+/* condition number for the average of selected eigenvalues. */
+
+/* RCDVIN (input) DOUBLE PRECISION */
+/* When COMP = .TRUE. RCDVIN holds the precomputed reciprocal */
+/* condition number for the selected right invariant subspace. */
+
+/* NSLCT (input) INTEGER */
+/* When COMP = .TRUE. the number of selected eigenvalues */
+/* corresponding to the precomputed values RCDEIN and RCDVIN. */
+
+/* ISLCT (input) INTEGER array, dimension (NSLCT) */
+/* When COMP = .TRUE. ISLCT selects the eigenvalues of the */
+/* input matrix corresponding to the precomputed values RCDEIN */
+/* and RCDVIN. For I=1, ... ,NSLCT, if ISLCT(I) = J, then the */
+/* eigenvalue with the J-th largest real or imaginary part is */
+/* selected. The real part is used if ISRT = 0, and the */
+/* imaginary part if ISRT = 1. */
+/* Not referenced if COMP = .FALSE. */
+
+/* ISRT (input) INTEGER */
+/* When COMP = .TRUE., ISRT describes how ISLCT is used to */
+/* choose a subset of the spectrum. */
+/* Not referenced if COMP = .FALSE. */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (17) */
+/* The values computed by the 17 tests described above. */
+/* The values are currently limited to 1/ulp, to avoid */
+/* overflow. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N*N) */
+
+/* LWORK (input) INTEGER */
+/* The number of entries in WORK to be passed to ZGEESX. This */
+/* must be at least 2*N, and N*(N+1)/2 if tests 14--16 are to */
+/* be performed. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* BWORK (workspace) LOGICAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* If 0, successful exit. */
+/* If <0, input parameter -INFO had an incorrect value. */
+/* If >0, ZGEESX returned an error code, the absolute */
+/* value of which is returned. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check for errors */
+
+ /* Parameter adjustments */
+ --iseed;
+ ht_dim1 = *lda;
+ ht_offset = 1 + ht_dim1;
+ ht -= ht_offset;
+ h_dim1 = *lda;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --w;
+ --wt;
+ --wtmp;
+ vs1_dim1 = *ldvs;
+ vs1_offset = 1 + vs1_dim1;
+ vs1 -= vs1_offset;
+ vs_dim1 = *ldvs;
+ vs_offset = 1 + vs_dim1;
+ vs -= vs_offset;
+ --islct;
+ --result;
+ --work;
+ --rwork;
+ --bwork;
+
+ /* Function Body */
+ *info = 0;
+ if (*thresh < 0.) {
+ *info = -3;
+ } else if (*nounit <= 0) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (*lda < 1 || *lda < *n) {
+ *info = -8;
+ } else if (*ldvs < 1 || *ldvs < *n) {
+ *info = -15;
+ } else if (*lwork < *n << 1) {
+ *info = -24;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGET24", &i__1);
+ return 0;
+ }
+
+/* Quick return if nothing to do */
+
+ for (i__ = 1; i__ <= 17; ++i__) {
+ result[i__] = -1.;
+/* L10: */
+ }
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Important constants */
+
+ smlnum = dlamch_("Safe minimum");
+ ulp = dlamch_("Precision");
+ ulpinv = 1. / ulp;
+
+/* Perform tests (1)-(13) */
+
+ sslct_1.selopt = 0;
+ for (isort = 0; isort <= 1; ++isort) {
+ if (isort == 0) {
+ *(unsigned char *)sort = 'N';
+ rsub = 0;
+ } else {
+ *(unsigned char *)sort = 'S';
+ rsub = 6;
+ }
+
+/* Compute Schur form and Schur vectors, and test them */
+
+ zlacpy_("F", n, n, &a[a_offset], lda, &h__[h_offset], lda);
+ zgeesx_("V", sort, (L_fp)zslect_, "N", n, &h__[h_offset], lda, &sdim,
+ &w[1], &vs[vs_offset], ldvs, &rconde, &rcondv, &work[1],
+ lwork, &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[rsub + 1] = ulpinv;
+ if (*jtype != 22) {
+ io___12.ciunit = *nounit;
+ s_wsfe(&io___12);
+ do_fio(&c__1, "ZGEESX1", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___13.ciunit = *nounit;
+ s_wsfe(&io___13);
+ do_fio(&c__1, "ZGEESX1", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ return 0;
+ }
+ if (isort == 0) {
+ zcopy_(n, &w[1], &c__1, &wtmp[1], &c__1);
+ }
+
+/* Do Test (1) or Test (7) */
+
+ result[rsub + 1] = 0.;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * h_dim1;
+ if (h__[i__3].r != 0. || h__[i__3].i != 0.) {
+ result[rsub + 1] = ulpinv;
+ }
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* Test (2) or (8): Compute norm(A - Q*H*Q') / (norm(A) * N * ULP) */
+
+/* Copy A to VS1, used as workspace */
+
+ zlacpy_(" ", n, n, &a[a_offset], lda, &vs1[vs1_offset], ldvs);
+
+/* Compute Q*H and store in HT. */
+
+ zgemm_("No transpose", "No transpose", n, n, n, &c_b2, &vs[vs_offset],
+ ldvs, &h__[h_offset], lda, &c_b1, &ht[ht_offset], lda);
+
+/* Compute A - Q*H*Q' */
+
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "Conjugate transpose", n, n, n, &z__1, &ht[
+ ht_offset], lda, &vs[vs_offset], ldvs, &c_b2, &vs1[vs1_offset]
+, ldvs);
+
+/* Computing MAX */
+ d__1 = zlange_("1", n, n, &a[a_offset], lda, &rwork[1]);
+ anorm = max(d__1,smlnum);
+ wnorm = zlange_("1", n, n, &vs1[vs1_offset], ldvs, &rwork[1]);
+
+ if (anorm > wnorm) {
+ result[rsub + 2] = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.) {
+/* Computing MIN */
+ d__1 = wnorm, d__2 = *n * anorm;
+ result[rsub + 2] = min(d__1,d__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
+ result[rsub + 2] = min(d__1,d__2) / (*n * ulp);
+ }
+ }
+
+/* Test (3) or (9): Compute norm( I - Q'*Q ) / ( N * ULP ) */
+
+ zunt01_("Columns", n, n, &vs[vs_offset], ldvs, &work[1], lwork, &
+ rwork[1], &result[rsub + 3]);
+
+/* Do Test (4) or Test (10) */
+
+ result[rsub + 4] = 0.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * h_dim1;
+ i__3 = i__;
+ if (h__[i__2].r != w[i__3].r || h__[i__2].i != w[i__3].i) {
+ result[rsub + 4] = ulpinv;
+ }
+/* L40: */
+ }
+
+/* Do Test (5) or Test (11) */
+
+ zlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ zgeesx_("N", sort, (L_fp)zslect_, "N", n, &ht[ht_offset], lda, &sdim,
+ &wt[1], &vs[vs_offset], ldvs, &rconde, &rcondv, &work[1],
+ lwork, &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[rsub + 5] = ulpinv;
+ if (*jtype != 22) {
+ io___17.ciunit = *nounit;
+ s_wsfe(&io___17);
+ do_fio(&c__1, "ZGEESX2", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___18.ciunit = *nounit;
+ s_wsfe(&io___18);
+ do_fio(&c__1, "ZGEESX2", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+ result[rsub + 5] = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * h_dim1;
+ i__4 = i__ + j * ht_dim1;
+ if (h__[i__3].r != ht[i__4].r || h__[i__3].i != ht[i__4].i) {
+ result[rsub + 5] = ulpinv;
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* Do Test (6) or Test (12) */
+
+ result[rsub + 6] = 0.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ if (w[i__2].r != wt[i__3].r || w[i__2].i != wt[i__3].i) {
+ result[rsub + 6] = ulpinv;
+ }
+/* L70: */
+ }
+
+/* Do Test (13) */
+
+ if (isort == 1) {
+ result[13] = 0.;
+ knteig = 0;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (zslect_(&w[i__])) {
+ ++knteig;
+ }
+ if (i__ < *n) {
+ if (zslect_(&w[i__ + 1]) && ! zslect_(&w[i__])) {
+ result[13] = ulpinv;
+ }
+ }
+/* L80: */
+ }
+ if (sdim != knteig) {
+ result[13] = ulpinv;
+ }
+ }
+
+/* L90: */
+ }
+
+/* If there is enough workspace, perform tests (14) and (15) */
+/* as well as (10) through (13) */
+
+ if (*lwork >= *n * (*n + 1) / 2) {
+
+/* Compute both RCONDE and RCONDV with VS */
+
+ *(unsigned char *)sort = 'S';
+ result[14] = 0.;
+ result[15] = 0.;
+ zlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ zgeesx_("V", sort, (L_fp)zslect_, "B", n, &ht[ht_offset], lda, &sdim1,
+ &wt[1], &vs1[vs1_offset], ldvs, &rconde, &rcondv, &work[1],
+ lwork, &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[14] = ulpinv;
+ result[15] = ulpinv;
+ if (*jtype != 22) {
+ io___21.ciunit = *nounit;
+ s_wsfe(&io___21);
+ do_fio(&c__1, "ZGEESX3", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___22.ciunit = *nounit;
+ s_wsfe(&io___22);
+ do_fio(&c__1, "ZGEESX3", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ if (w[i__2].r != wt[i__3].r || w[i__2].i != wt[i__3].i) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * h_dim1;
+ i__4 = i__ + j * ht_dim1;
+ if (h__[i__3].r != ht[i__4].r || h__[i__3].i != ht[i__4].i) {
+ result[11] = ulpinv;
+ }
+ i__3 = i__ + j * vs_dim1;
+ i__4 = i__ + j * vs1_dim1;
+ if (vs[i__3].r != vs1[i__4].r || vs[i__3].i != vs1[i__4].i) {
+ result[12] = ulpinv;
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+/* Compute both RCONDE and RCONDV without VS, and compare */
+
+ zlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ zgeesx_("N", sort, (L_fp)zslect_, "B", n, &ht[ht_offset], lda, &sdim1,
+ &wt[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &work[1],
+ lwork, &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[14] = ulpinv;
+ result[15] = ulpinv;
+ if (*jtype != 22) {
+ io___25.ciunit = *nounit;
+ s_wsfe(&io___25);
+ do_fio(&c__1, "ZGEESX4", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___26.ciunit = *nounit;
+ s_wsfe(&io___26);
+ do_fio(&c__1, "ZGEESX4", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Perform tests (14) and (15) */
+
+ if (rcnde1 != rconde) {
+ result[14] = ulpinv;
+ }
+ if (rcndv1 != rcondv) {
+ result[15] = ulpinv;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ if (w[i__2].r != wt[i__3].r || w[i__2].i != wt[i__3].i) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * h_dim1;
+ i__4 = i__ + j * ht_dim1;
+ if (h__[i__3].r != ht[i__4].r || h__[i__3].i != ht[i__4].i) {
+ result[11] = ulpinv;
+ }
+ i__3 = i__ + j * vs_dim1;
+ i__4 = i__ + j * vs1_dim1;
+ if (vs[i__3].r != vs1[i__4].r || vs[i__3].i != vs1[i__4].i) {
+ result[12] = ulpinv;
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+/* Compute RCONDE with VS, and compare */
+
+ zlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ zgeesx_("V", sort, (L_fp)zslect_, "E", n, &ht[ht_offset], lda, &sdim1,
+ &wt[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &work[1],
+ lwork, &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[14] = ulpinv;
+ if (*jtype != 22) {
+ io___27.ciunit = *nounit;
+ s_wsfe(&io___27);
+ do_fio(&c__1, "ZGEESX5", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___28.ciunit = *nounit;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "ZGEESX5", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Perform test (14) */
+
+ if (rcnde1 != rconde) {
+ result[14] = ulpinv;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ if (w[i__2].r != wt[i__3].r || w[i__2].i != wt[i__3].i) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * h_dim1;
+ i__4 = i__ + j * ht_dim1;
+ if (h__[i__3].r != ht[i__4].r || h__[i__3].i != ht[i__4].i) {
+ result[11] = ulpinv;
+ }
+ i__3 = i__ + j * vs_dim1;
+ i__4 = i__ + j * vs1_dim1;
+ if (vs[i__3].r != vs1[i__4].r || vs[i__3].i != vs1[i__4].i) {
+ result[12] = ulpinv;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+/* Compute RCONDE without VS, and compare */
+
+ zlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ zgeesx_("N", sort, (L_fp)zslect_, "E", n, &ht[ht_offset], lda, &sdim1,
+ &wt[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &work[1],
+ lwork, &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[14] = ulpinv;
+ if (*jtype != 22) {
+ io___29.ciunit = *nounit;
+ s_wsfe(&io___29);
+ do_fio(&c__1, "ZGEESX6", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___30.ciunit = *nounit;
+ s_wsfe(&io___30);
+ do_fio(&c__1, "ZGEESX6", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Perform test (14) */
+
+ if (rcnde1 != rconde) {
+ result[14] = ulpinv;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ if (w[i__2].r != wt[i__3].r || w[i__2].i != wt[i__3].i) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * h_dim1;
+ i__4 = i__ + j * ht_dim1;
+ if (h__[i__3].r != ht[i__4].r || h__[i__3].i != ht[i__4].i) {
+ result[11] = ulpinv;
+ }
+ i__3 = i__ + j * vs_dim1;
+ i__4 = i__ + j * vs1_dim1;
+ if (vs[i__3].r != vs1[i__4].r || vs[i__3].i != vs1[i__4].i) {
+ result[12] = ulpinv;
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+/* Compute RCONDV with VS, and compare */
+
+ zlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ zgeesx_("V", sort, (L_fp)zslect_, "V", n, &ht[ht_offset], lda, &sdim1,
+ &wt[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &work[1],
+ lwork, &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[15] = ulpinv;
+ if (*jtype != 22) {
+ io___31.ciunit = *nounit;
+ s_wsfe(&io___31);
+ do_fio(&c__1, "ZGEESX7", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___32.ciunit = *nounit;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "ZGEESX7", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Perform test (15) */
+
+ if (rcndv1 != rcondv) {
+ result[15] = ulpinv;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ if (w[i__2].r != wt[i__3].r || w[i__2].i != wt[i__3].i) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * h_dim1;
+ i__4 = i__ + j * ht_dim1;
+ if (h__[i__3].r != ht[i__4].r || h__[i__3].i != ht[i__4].i) {
+ result[11] = ulpinv;
+ }
+ i__3 = i__ + j * vs_dim1;
+ i__4 = i__ + j * vs1_dim1;
+ if (vs[i__3].r != vs1[i__4].r || vs[i__3].i != vs1[i__4].i) {
+ result[12] = ulpinv;
+ }
+/* L180: */
+ }
+/* L190: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+/* Compute RCONDV without VS, and compare */
+
+ zlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ zgeesx_("N", sort, (L_fp)zslect_, "V", n, &ht[ht_offset], lda, &sdim1,
+ &wt[1], &vs1[vs1_offset], ldvs, &rcnde1, &rcndv1, &work[1],
+ lwork, &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[15] = ulpinv;
+ if (*jtype != 22) {
+ io___33.ciunit = *nounit;
+ s_wsfe(&io___33);
+ do_fio(&c__1, "ZGEESX8", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*jtype), (ftnlen)sizeof(integer));
+ do_fio(&c__4, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___34.ciunit = *nounit;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "ZGEESX8", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ *info = abs(iinfo);
+ goto L220;
+ }
+
+/* Perform test (15) */
+
+ if (rcndv1 != rcondv) {
+ result[15] = ulpinv;
+ }
+
+/* Perform tests (10), (11), (12), and (13) */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ if (w[i__2].r != wt[i__3].r || w[i__2].i != wt[i__3].i) {
+ result[10] = ulpinv;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * h_dim1;
+ i__4 = i__ + j * ht_dim1;
+ if (h__[i__3].r != ht[i__4].r || h__[i__3].i != ht[i__4].i) {
+ result[11] = ulpinv;
+ }
+ i__3 = i__ + j * vs_dim1;
+ i__4 = i__ + j * vs1_dim1;
+ if (vs[i__3].r != vs1[i__4].r || vs[i__3].i != vs1[i__4].i) {
+ result[12] = ulpinv;
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+ if (sdim != sdim1) {
+ result[13] = ulpinv;
+ }
+
+ }
+
+L220:
+
+/* If there are precomputed reciprocal condition numbers, compare */
+/* computed values with them. */
+
+ if (*comp) {
+
+/* First set up SELOPT, SELDIM, SELVAL, SELWR and SELWI so that */
+/* the logical function ZSLECT selects the eigenvalues specified */
+/* by NSLCT, ISLCT and ISRT. */
+
+ sslct_1.seldim = *n;
+ sslct_1.selopt = 1;
+ eps = max(ulp,5.9605e-8);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ipnt[i__ - 1] = i__;
+ sslct_1.selval[i__ - 1] = FALSE_;
+ i__2 = i__;
+ sslct_1.selwr[i__ - 1] = wtmp[i__2].r;
+ sslct_1.selwi[i__ - 1] = d_imag(&wtmp[i__]);
+/* L230: */
+ }
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ kmin = i__;
+ if (*isrt == 0) {
+ i__2 = i__;
+ vrimin = wtmp[i__2].r;
+ } else {
+ vrimin = d_imag(&wtmp[i__]);
+ }
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (*isrt == 0) {
+ i__3 = j;
+ vricmp = wtmp[i__3].r;
+ } else {
+ vricmp = d_imag(&wtmp[j]);
+ }
+ if (vricmp < vrimin) {
+ kmin = j;
+ vrimin = vricmp;
+ }
+/* L240: */
+ }
+ i__2 = kmin;
+ ctmp.r = wtmp[i__2].r, ctmp.i = wtmp[i__2].i;
+ i__2 = kmin;
+ i__3 = i__;
+ wtmp[i__2].r = wtmp[i__3].r, wtmp[i__2].i = wtmp[i__3].i;
+ i__2 = i__;
+ wtmp[i__2].r = ctmp.r, wtmp[i__2].i = ctmp.i;
+ itmp = ipnt[i__ - 1];
+ ipnt[i__ - 1] = ipnt[kmin - 1];
+ ipnt[kmin - 1] = itmp;
+/* L250: */
+ }
+ i__1 = *nslct;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sslct_1.selval[ipnt[islct[i__] - 1] - 1] = TRUE_;
+/* L260: */
+ }
+
+/* Compute condition numbers */
+
+ zlacpy_("F", n, n, &a[a_offset], lda, &ht[ht_offset], lda);
+ zgeesx_("N", "S", (L_fp)zslect_, "B", n, &ht[ht_offset], lda, &sdim1,
+ &wt[1], &vs1[vs1_offset], ldvs, &rconde, &rcondv, &work[1],
+ lwork, &rwork[1], &bwork[1], &iinfo);
+ if (iinfo != 0) {
+ result[16] = ulpinv;
+ result[17] = ulpinv;
+ io___42.ciunit = *nounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "ZGEESX9", (ftnlen)7);
+ do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&iseed[1], (ftnlen)sizeof(integer));
+ e_wsfe();
+ *info = abs(iinfo);
+ goto L270;
+ }
+
+/* Compare condition number for average of selected eigenvalues */
+/* taking its condition number into account */
+
+ anorm = zlange_("1", n, n, &a[a_offset], lda, &rwork[1]);
+/* Computing MAX */
+ d__1 = (doublereal) (*n) * eps * anorm;
+ v = max(d__1,smlnum);
+ if (anorm == 0.) {
+ v = 1.;
+ }
+ if (v > rcondv) {
+ tol = 1.;
+ } else {
+ tol = v / rcondv;
+ }
+ if (v > *rcdvin) {
+ tolin = 1.;
+ } else {
+ tolin = v / *rcdvin;
+ }
+/* Computing MAX */
+ d__1 = tol, d__2 = smlnum / eps;
+ tol = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = tolin, d__2 = smlnum / eps;
+ tolin = max(d__1,d__2);
+ if (eps * (*rcdein - tolin) > rconde + tol) {
+ result[16] = ulpinv;
+ } else if (*rcdein - tolin > rconde + tol) {
+ result[16] = (*rcdein - tolin) / (rconde + tol);
+ } else if (*rcdein + tolin < eps * (rconde - tol)) {
+ result[16] = ulpinv;
+ } else if (*rcdein + tolin < rconde - tol) {
+ result[16] = (rconde - tol) / (*rcdein + tolin);
+ } else {
+ result[16] = 1.;
+ }
+
+/* Compare condition numbers for right invariant subspace */
+/* taking its condition number into account */
+
+ if (v > rcondv * rconde) {
+ tol = rcondv;
+ } else {
+ tol = v / rconde;
+ }
+ if (v > *rcdvin * *rcdein) {
+ tolin = *rcdvin;
+ } else {
+ tolin = v / *rcdein;
+ }
+/* Computing MAX */
+ d__1 = tol, d__2 = smlnum / eps;
+ tol = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = tolin, d__2 = smlnum / eps;
+ tolin = max(d__1,d__2);
+ if (eps * (*rcdvin - tolin) > rcondv + tol) {
+ result[17] = ulpinv;
+ } else if (*rcdvin - tolin > rcondv + tol) {
+ result[17] = (*rcdvin - tolin) / (rcondv + tol);
+ } else if (*rcdvin + tolin < eps * (rcondv - tol)) {
+ result[17] = ulpinv;
+ } else if (*rcdvin + tolin < rcondv - tol) {
+ result[17] = (rcondv - tol) / (*rcdvin + tolin);
+ } else {
+ result[17] = 1.;
+ }
+
+L270:
+
+ ;
+ }
+
+
+ return 0;
+
+/* End of ZGET24 */
+
+} /* zget24_ */
diff --git a/TESTING/EIG/zget35.c b/TESTING/EIG/zget35.c
new file mode 100644
index 0000000..2ba4121
--- /dev/null
+++ b/TESTING/EIG/zget35.c
@@ -0,0 +1,352 @@
+/* zget35.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__7 = 7;
+static integer c__10 = 10;
+static doublecomplex c_b43 = {1.,0.};
+
+/* Subroutine */ int zget35_(doublereal *rmax, integer *lmax, integer *ninfo,
+ integer *knt, integer *nin)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+ double z_abs(doublecomplex *);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ doublecomplex a[100] /* was [10][10] */, b[100] /* was [10][
+ 10] */, c__[100] /* was [10][10] */;
+ integer i__, j, m, n;
+ doublereal vm1[3], vm2[3], dum[1], eps, res, res1;
+ integer imla, imlb, imlc, info;
+ doublecomplex csav[100] /* was [10][10] */;
+ integer isgn;
+ doublecomplex atmp[100] /* was [10][10] */, btmp[100] /* was [10][
+ 10] */, ctmp[100] /* was [10][10] */;
+ doublereal tnrm;
+ doublecomplex rmul;
+ doublereal xnrm;
+ integer imlad;
+ doublereal scale;
+ char trana[1], tranb[1];
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ integer itrana, itranb;
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ doublereal bignum, smlnum;
+ extern /* Subroutine */ int ztrsyl_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 0, 0, 0, 0 };
+ static cilist io___10 = { 0, 0, 0, 0, 0 };
+ static cilist io___13 = { 0, 0, 0, 0, 0 };
+ static cilist io___15 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGET35 tests ZTRSYL, a routine for solving the Sylvester matrix */
+/* equation */
+
+/* op(A)*X + ISGN*X*op(B) = scale*C, */
+
+/* A and B are assumed to be in Schur canonical form, op() represents an */
+/* optional transpose, and ISGN can be -1 or +1. Scale is an output */
+/* less than or equal to 1, chosen to avoid overflow in X. */
+
+/* The test code verifies that the following residual is order 1: */
+
+/* norm(op(A)*X + ISGN*X*op(B) - scale*C) / */
+/* (EPS*max(norm(A),norm(B))*norm(X)) */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) DOUBLE PRECISION */
+/* Value of the largest test ratio. */
+
+/* LMAX (output) INTEGER */
+/* Example number where largest test ratio achieved. */
+
+/* NINFO (output) INTEGER */
+/* Number of examples where INFO is nonzero. */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* NIN (input) INTEGER */
+/* Input logical unit number. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Get machine parameters */
+
+ eps = dlamch_("P");
+ smlnum = dlamch_("S") / eps;
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Set up test case parameters */
+
+ vm1[0] = sqrt(smlnum);
+ vm1[1] = 1.;
+ vm1[2] = 1e6;
+ vm2[0] = 1.;
+ vm2[1] = eps * 2. + 1.;
+ vm2[2] = 2.;
+
+ *knt = 0;
+ *ninfo = 0;
+ *lmax = 0;
+ *rmax = 0.;
+
+/* Begin test loop */
+
+L10:
+ io___6.ciunit = *nin;
+ s_rsle(&io___6);
+ do_lio(&c__3, &c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ return 0;
+ }
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___10.ciunit = *nin;
+ s_rsle(&io___10);
+ i__2 = m;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&atmp[i__ + j * 10 - 11], (ftnlen)
+ sizeof(doublecomplex));
+ }
+ e_rsle();
+/* L20: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___13.ciunit = *nin;
+ s_rsle(&io___13);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&btmp[i__ + j * 10 - 11], (ftnlen)
+ sizeof(doublecomplex));
+ }
+ e_rsle();
+/* L30: */
+ }
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___15.ciunit = *nin;
+ s_rsle(&io___15);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&ctmp[i__ + j * 10 - 11], (ftnlen)
+ sizeof(doublecomplex));
+ }
+ e_rsle();
+/* L40: */
+ }
+ for (imla = 1; imla <= 3; ++imla) {
+ for (imlad = 1; imlad <= 3; ++imlad) {
+ for (imlb = 1; imlb <= 3; ++imlb) {
+ for (imlc = 1; imlc <= 3; ++imlc) {
+ for (itrana = 1; itrana <= 2; ++itrana) {
+ for (itranb = 1; itranb <= 2; ++itranb) {
+ for (isgn = -1; isgn <= 1; isgn += 2) {
+ if (itrana == 1) {
+ *(unsigned char *)trana = 'N';
+ }
+ if (itrana == 2) {
+ *(unsigned char *)trana = 'C';
+ }
+ if (itranb == 1) {
+ *(unsigned char *)tranb = 'N';
+ }
+ if (itranb == 2) {
+ *(unsigned char *)tranb = 'C';
+ }
+ tnrm = 0.;
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = m;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * 10 - 11;
+ i__4 = i__ + j * 10 - 11;
+ i__5 = imla - 1;
+ z__1.r = vm1[i__5] * atmp[i__4].r,
+ z__1.i = vm1[i__5] * atmp[
+ i__4].i;
+ a[i__3].r = z__1.r, a[i__3].i =
+ z__1.i;
+/* Computing MAX */
+ d__1 = tnrm, d__2 = z_abs(&a[i__ + j *
+ 10 - 11]);
+ tnrm = max(d__1,d__2);
+/* L50: */
+ }
+ i__2 = i__ + i__ * 10 - 11;
+ i__3 = i__ + i__ * 10 - 11;
+ i__4 = imlad - 1;
+ z__1.r = vm2[i__4] * a[i__3].r, z__1.i =
+ vm2[i__4] * a[i__3].i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* Computing MAX */
+ d__1 = tnrm, d__2 = z_abs(&a[i__ + i__ *
+ 10 - 11]);
+ tnrm = max(d__1,d__2);
+/* L60: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * 10 - 11;
+ i__4 = i__ + j * 10 - 11;
+ i__5 = imlb - 1;
+ z__1.r = vm1[i__5] * btmp[i__4].r,
+ z__1.i = vm1[i__5] * btmp[
+ i__4].i;
+ b[i__3].r = z__1.r, b[i__3].i =
+ z__1.i;
+/* Computing MAX */
+ d__1 = tnrm, d__2 = z_abs(&b[i__ + j *
+ 10 - 11]);
+ tnrm = max(d__1,d__2);
+/* L70: */
+ }
+/* L80: */
+ }
+ if (tnrm == 0.) {
+ tnrm = 1.;
+ }
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * 10 - 11;
+ i__4 = i__ + j * 10 - 11;
+ i__5 = imlc - 1;
+ z__1.r = vm1[i__5] * ctmp[i__4].r,
+ z__1.i = vm1[i__5] * ctmp[
+ i__4].i;
+ c__[i__3].r = z__1.r, c__[i__3].i =
+ z__1.i;
+ i__3 = i__ + j * 10 - 11;
+ i__4 = i__ + j * 10 - 11;
+ csav[i__3].r = c__[i__4].r, csav[i__3]
+ .i = c__[i__4].i;
+/* L90: */
+ }
+/* L100: */
+ }
+ ++(*knt);
+ ztrsyl_(trana, tranb, &isgn, &m, &n, a, &
+ c__10, b, &c__10, c__, &c__10, &scale,
+ &info);
+ if (info != 0) {
+ ++(*ninfo);
+ }
+ xnrm = zlange_("M", &m, &n, c__, &c__10, dum);
+ rmul.r = 1., rmul.i = 0.;
+ if (xnrm > 1. && tnrm > 1.) {
+ if (xnrm > bignum / tnrm) {
+ d__1 = max(xnrm,tnrm);
+ rmul.r = d__1, rmul.i = 0.;
+ z_div(&z__1, &c_b43, &rmul);
+ rmul.r = z__1.r, rmul.i = z__1.i;
+ }
+ }
+ d__1 = -scale;
+ z__1.r = d__1 * rmul.r, z__1.i = d__1 *
+ rmul.i;
+ zgemm_(trana, "N", &m, &n, &m, &rmul, a, &
+ c__10, c__, &c__10, &z__1, csav, &
+ c__10);
+ d__1 = (doublereal) isgn;
+ z__1.r = d__1 * rmul.r, z__1.i = d__1 *
+ rmul.i;
+ zgemm_("N", tranb, &m, &n, &n, &z__1, c__, &
+ c__10, b, &c__10, &c_b43, csav, &
+ c__10);
+ res1 = zlange_("M", &m, &n, csav, &c__10, dum);
+/* Computing MAX */
+ d__1 = smlnum, d__2 = smlnum * xnrm, d__1 =
+ max(d__1,d__2), d__2 = z_abs(&rmul) *
+ tnrm * eps * xnrm;
+ res = res1 / max(d__1,d__2);
+ if (res > *rmax) {
+ *lmax = *knt;
+ *rmax = res;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+ goto L10;
+
+/* End of ZGET35 */
+
+} /* zget35_ */
diff --git a/TESTING/EIG/zget36.c b/TESTING/EIG/zget36.c
new file mode 100644
index 0000000..0c34347
--- /dev/null
+++ b/TESTING/EIG/zget36.c
@@ -0,0 +1,276 @@
+/* zget36.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__7 = 7;
+static integer c__10 = 10;
+static integer c__11 = 11;
+static integer c__200 = 200;
+
+/* Subroutine */ int zget36_(doublereal *rmax, integer *lmax, integer *ninfo,
+ integer *knt, integer *nin)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+
+ /* Local variables */
+ integer i__, j, n;
+ doublecomplex q[100] /* was [10][10] */, t1[100] /* was [10][
+ 10] */, t2[100] /* was [10][10] */;
+ doublereal eps, res;
+ doublecomplex tmp[100] /* was [10][10] */, diag[10];
+ integer ifst, ilst;
+ doublecomplex work[200];
+ integer info1, info2;
+ doublecomplex ctemp;
+ extern /* Subroutine */ int zhst01_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+ doublereal rwork[10];
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *);
+ doublereal result[2];
+ extern /* Subroutine */ int ztrexc_(char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, integer *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___2 = { 0, 0, 0, 0, 0 };
+ static cilist io___7 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGET36 tests ZTREXC, a routine for reordering diagonal entries of a */
+/* matrix in complex Schur form. Thus, ZLAEXC computes a unitary matrix */
+/* Q such that */
+
+/* Q' * T1 * Q = T2 */
+
+/* and where one of the diagonal blocks of T1 (the one at row IFST) has */
+/* been moved to position ILST. */
+
+/* The test code verifies that the residual Q'*T1*Q-T2 is small, that T2 */
+/* is in Schur form, and that the final position of the IFST block is */
+/* ILST. */
+
+/* The test matrices are read from a file with logical unit number NIN. */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) DOUBLE PRECISION */
+/* Value of the largest test ratio. */
+
+/* LMAX (output) INTEGER */
+/* Example number where largest test ratio achieved. */
+
+/* NINFO (output) INTEGER */
+/* Number of examples where INFO is nonzero. */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* NIN (input) INTEGER */
+/* Input logical unit number. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = dlamch_("P");
+ *rmax = 0.;
+ *lmax = 0;
+ *knt = 0;
+ *ninfo = 0;
+
+/* Read input data until N=0 */
+
+L10:
+ io___2.ciunit = *nin;
+ s_rsle(&io___2);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ifst, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ilst, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ return 0;
+ }
+ ++(*knt);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___7.ciunit = *nin;
+ s_rsle(&io___7);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&tmp[i__ + j * 10 - 11], (ftnlen)
+ sizeof(doublecomplex));
+ }
+ e_rsle();
+/* L20: */
+ }
+ zlacpy_("F", &n, &n, tmp, &c__10, t1, &c__10);
+ zlacpy_("F", &n, &n, tmp, &c__10, t2, &c__10);
+ res = 0.;
+
+/* Test without accumulating Q */
+
+ zlaset_("Full", &n, &n, &c_b1, &c_b2, q, &c__10);
+ ztrexc_("N", &n, t1, &c__10, q, &c__10, &ifst, &ilst, &info1);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * 10 - 11;
+ if (i__ == j && (q[i__3].r != 1. || q[i__3].i != 0.)) {
+ res += 1. / eps;
+ }
+ i__3 = i__ + j * 10 - 11;
+ if (i__ != j && (q[i__3].r != 0. || q[i__3].i != 0.)) {
+ res += 1. / eps;
+ }
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* Test with accumulating Q */
+
+ zlaset_("Full", &n, &n, &c_b1, &c_b2, q, &c__10);
+ ztrexc_("V", &n, t2, &c__10, q, &c__10, &ifst, &ilst, &info2);
+
+/* Compare T1 with T2 */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * 10 - 11;
+ i__4 = i__ + j * 10 - 11;
+ if (t1[i__3].r != t2[i__4].r || t1[i__3].i != t2[i__4].i) {
+ res += 1. / eps;
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+ if (info1 != 0 || info2 != 0) {
+ ++(*ninfo);
+ }
+ if (info1 != info2) {
+ res += 1. / eps;
+ }
+
+/* Test for successful reordering of T2 */
+
+ zcopy_(&n, tmp, &c__11, diag, &c__1);
+ if (ifst < ilst) {
+ i__1 = ilst;
+ for (i__ = ifst + 1; i__ <= i__1; ++i__) {
+ i__2 = i__ - 1;
+ ctemp.r = diag[i__2].r, ctemp.i = diag[i__2].i;
+ i__2 = i__ - 1;
+ i__3 = i__ - 2;
+ diag[i__2].r = diag[i__3].r, diag[i__2].i = diag[i__3].i;
+ i__2 = i__ - 2;
+ diag[i__2].r = ctemp.r, diag[i__2].i = ctemp.i;
+/* L70: */
+ }
+ } else if (ifst > ilst) {
+ i__1 = ilst;
+ for (i__ = ifst - 1; i__ >= i__1; --i__) {
+ i__2 = i__;
+ ctemp.r = diag[i__2].r, ctemp.i = diag[i__2].i;
+ i__2 = i__;
+ i__3 = i__ - 1;
+ diag[i__2].r = diag[i__3].r, diag[i__2].i = diag[i__3].i;
+ i__2 = i__ - 1;
+ diag[i__2].r = ctemp.r, diag[i__2].i = ctemp.i;
+/* L80: */
+ }
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * 10 - 11;
+ i__3 = i__ - 1;
+ if (t2[i__2].r != diag[i__3].r || t2[i__2].i != diag[i__3].i) {
+ res += 1. / eps;
+ }
+/* L90: */
+ }
+
+/* Test for small residual, and orthogonality of Q */
+
+ zhst01_(&n, &c__1, &n, tmp, &c__10, t2, &c__10, q, &c__10, work, &c__200,
+ rwork, result);
+ res = res + result[0] + result[1];
+
+/* Test for T2 being in Schur form */
+
+ i__1 = n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 10 - 11;
+ if (t2[i__3].r != 0. || t2[i__3].i != 0.) {
+ res += 1. / eps;
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+ if (res > *rmax) {
+ *rmax = res;
+ *lmax = *knt;
+ }
+ goto L10;
+
+/* End of ZGET36 */
+
+} /* zget36_ */
diff --git a/TESTING/EIG/zget37.c b/TESTING/EIG/zget37.c
new file mode 100644
index 0000000..dad8ce3
--- /dev/null
+++ b/TESTING/EIG/zget37.c
@@ -0,0 +1,729 @@
+/* zget37.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__7 = 7;
+static integer c__5 = 5;
+static integer c__20 = 20;
+static integer c__1200 = 1200;
+static integer c__0 = 0;
+
+/* Subroutine */ int zget37_(doublereal *rmax, integer *lmax, integer *ninfo,
+ integer *knt, integer *nin)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, m, n;
+ doublereal s[20];
+ doublecomplex t[400] /* was [20][20] */;
+ doublereal v;
+ doublecomplex w[20], le[400] /* was [20][20] */, re[400] /*
+ was [20][20] */;
+ doublereal val[3], dum[1], eps, sep[20], sin__[20], tol;
+ doublecomplex tmp[400] /* was [20][20] */;
+ integer icmp;
+ doublecomplex cdum[1];
+ integer iscl, info, lcmp[3], kmin;
+ doublereal wiin[20], vmin, vmax, tnrm;
+ integer isrt;
+ doublereal wrin[20], vmul, stmp[20];
+ doublecomplex work[1200], wtmp[20];
+ doublereal wsrt[20];
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal vcmin, sepin[20];
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ doublereal tolin, rwork[40];
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ logical select[20];
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ doublereal bignum;
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *), zgehrd_(integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, integer *), zlacpy_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *
+);
+ doublereal septmp[20], smlnum;
+ extern /* Subroutine */ int zhseqr_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *), ztrevc_(char *, char *, logical *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *, doublecomplex *,
+ doublereal *, integer *), ztrsna_(char *, char *,
+ logical *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *, doublecomplex *, integer *, doublereal *, doublereal
+ *, integer *, integer *, doublecomplex *, integer *, doublereal *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___5 = { 0, 0, 0, 0, 0 };
+ static cilist io___9 = { 0, 0, 0, 0, 0 };
+ static cilist io___12 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGET37 tests ZTRSNA, a routine for estimating condition numbers of */
+/* eigenvalues and/or right eigenvectors of a matrix. */
+
+/* The test matrices are read from a file with logical unit number NIN. */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) DOUBLE PRECISION array, dimension (3) */
+/* Value of the largest test ratio. */
+/* RMAX(1) = largest ratio comparing different calls to ZTRSNA */
+/* RMAX(2) = largest error in reciprocal condition */
+/* numbers taking their conditioning into account */
+/* RMAX(3) = largest error in reciprocal condition */
+/* numbers not taking their conditioning into */
+/* account (may be larger than RMAX(2)) */
+
+/* LMAX (output) INTEGER array, dimension (3) */
+/* LMAX(i) is example number where largest test ratio */
+/* RMAX(i) is achieved. Also: */
+/* If ZGEHRD returns INFO nonzero on example i, LMAX(1)=i */
+/* If ZHSEQR returns INFO nonzero on example i, LMAX(2)=i */
+/* If ZTRSNA returns INFO nonzero on example i, LMAX(3)=i */
+
+/* NINFO (output) INTEGER array, dimension (3) */
+/* NINFO(1) = No. of times ZGEHRD returned INFO nonzero */
+/* NINFO(2) = No. of times ZHSEQR returned INFO nonzero */
+/* NINFO(3) = No. of times ZTRSNA returned INFO nonzero */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* NIN (input) INTEGER */
+/* Input logical unit number */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ninfo;
+ --lmax;
+ --rmax;
+
+ /* Function Body */
+ eps = dlamch_("P");
+ smlnum = dlamch_("S") / eps;
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* EPSIN = 2**(-24) = precision to which input data computed */
+
+ eps = max(eps,5.9605e-8);
+ rmax[1] = 0.;
+ rmax[2] = 0.;
+ rmax[3] = 0.;
+ lmax[1] = 0;
+ lmax[2] = 0;
+ lmax[3] = 0;
+ *knt = 0;
+ ninfo[1] = 0;
+ ninfo[2] = 0;
+ ninfo[3] = 0;
+ val[0] = sqrt(smlnum);
+ val[1] = 1.;
+ val[2] = sqrt(bignum);
+
+/* Read input data until N=0. Assume input eigenvalues are sorted */
+/* lexicographically (increasing by real part if ISRT = 0, */
+/* increasing by imaginary part if ISRT = 1) */
+
+L10:
+ io___5.ciunit = *nin;
+ s_rsle(&io___5);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&isrt, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ return 0;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___9.ciunit = *nin;
+ s_rsle(&io___9);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&tmp[i__ + j * 20 - 21], (ftnlen)
+ sizeof(doublecomplex));
+ }
+ e_rsle();
+/* L20: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___12.ciunit = *nin;
+ s_rsle(&io___12);
+ do_lio(&c__5, &c__1, (char *)&wrin[i__ - 1], (ftnlen)sizeof(
+ doublereal));
+ do_lio(&c__5, &c__1, (char *)&wiin[i__ - 1], (ftnlen)sizeof(
+ doublereal));
+ do_lio(&c__5, &c__1, (char *)&sin__[i__ - 1], (ftnlen)sizeof(
+ doublereal));
+ do_lio(&c__5, &c__1, (char *)&sepin[i__ - 1], (ftnlen)sizeof(
+ doublereal));
+ e_rsle();
+/* L30: */
+ }
+ tnrm = zlange_("M", &n, &n, tmp, &c__20, rwork);
+ for (iscl = 1; iscl <= 3; ++iscl) {
+
+/* Scale input matrix */
+
+ ++(*knt);
+ zlacpy_("F", &n, &n, tmp, &c__20, t, &c__20);
+ vmul = val[iscl - 1];
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ zdscal_(&n, &vmul, &t[i__ * 20 - 20], &c__1);
+/* L40: */
+ }
+ if (tnrm == 0.) {
+ vmul = 1.;
+ }
+
+/* Compute eigenvalues and eigenvectors */
+
+ i__1 = 1200 - n;
+ zgehrd_(&n, &c__1, &n, t, &c__20, work, &work[n], &i__1, &info);
+ if (info != 0) {
+ lmax[1] = *knt;
+ ++ninfo[1];
+ goto L260;
+ }
+ i__1 = n - 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = n;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 20 - 21;
+ t[i__3].r = 0., t[i__3].i = 0.;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* Compute Schur form */
+
+ zhseqr_("S", "N", &n, &c__1, &n, t, &c__20, w, cdum, &c__1, work, &
+ c__1200, &info);
+ if (info != 0) {
+ lmax[2] = *knt;
+ ++ninfo[2];
+ goto L260;
+ }
+
+/* Compute eigenvectors */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ select[i__ - 1] = TRUE_;
+/* L70: */
+ }
+ ztrevc_("B", "A", select, &n, t, &c__20, le, &c__20, re, &c__20, &n, &
+ m, work, rwork, &info);
+
+/* Compute condition numbers */
+
+ ztrsna_("B", "A", select, &n, t, &c__20, le, &c__20, re, &c__20, s,
+ sep, &n, &m, work, &n, rwork, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L260;
+ }
+
+/* Sort eigenvalues and condition numbers lexicographically */
+/* to compare with inputs */
+
+ zcopy_(&n, w, &c__1, wtmp, &c__1);
+ if (isrt == 0) {
+
+/* Sort by increasing real part */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ - 1;
+ wsrt[i__ - 1] = w[i__2].r;
+/* L80: */
+ }
+ } else {
+
+/* Sort by increasing imaginary part */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ wsrt[i__ - 1] = d_imag(&w[i__ - 1]);
+/* L90: */
+ }
+ }
+ dcopy_(&n, s, &c__1, stmp, &c__1);
+ dcopy_(&n, sep, &c__1, septmp, &c__1);
+ d__1 = 1. / vmul;
+ dscal_(&n, &d__1, septmp, &c__1);
+ i__1 = n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ kmin = i__;
+ vmin = wsrt[i__ - 1];
+ i__2 = n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (wsrt[j - 1] < vmin) {
+ kmin = j;
+ vmin = wsrt[j - 1];
+ }
+/* L100: */
+ }
+ wsrt[kmin - 1] = wsrt[i__ - 1];
+ wsrt[i__ - 1] = vmin;
+ i__2 = i__ - 1;
+ vcmin = wtmp[i__2].r;
+ i__2 = i__ - 1;
+ i__3 = kmin - 1;
+ wtmp[i__2].r = w[i__3].r, wtmp[i__2].i = w[i__3].i;
+ i__2 = kmin - 1;
+ wtmp[i__2].r = vcmin, wtmp[i__2].i = 0.;
+ vmin = stmp[kmin - 1];
+ stmp[kmin - 1] = stmp[i__ - 1];
+ stmp[i__ - 1] = vmin;
+ vmin = septmp[kmin - 1];
+ septmp[kmin - 1] = septmp[i__ - 1];
+ septmp[i__ - 1] = vmin;
+/* L110: */
+ }
+
+/* Compare condition numbers for eigenvalues */
+/* taking their condition numbers into account */
+
+/* Computing MAX */
+ d__1 = (doublereal) n * 2. * eps * tnrm;
+ v = max(d__1,smlnum);
+ if (tnrm == 0.) {
+ v = 1.;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (v > septmp[i__ - 1]) {
+ tol = 1.;
+ } else {
+ tol = v / septmp[i__ - 1];
+ }
+ if (v > sepin[i__ - 1]) {
+ tolin = 1.;
+ } else {
+ tolin = v / sepin[i__ - 1];
+ }
+/* Computing MAX */
+ d__1 = tol, d__2 = smlnum / eps;
+ tol = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = tolin, d__2 = smlnum / eps;
+ tolin = max(d__1,d__2);
+ if (eps * (sin__[i__ - 1] - tolin) > stmp[i__ - 1] + tol) {
+ vmax = 1. / eps;
+ } else if (sin__[i__ - 1] - tolin > stmp[i__ - 1] + tol) {
+ vmax = (sin__[i__ - 1] - tolin) / (stmp[i__ - 1] + tol);
+ } else if (sin__[i__ - 1] + tolin < eps * (stmp[i__ - 1] - tol)) {
+ vmax = 1. / eps;
+ } else if (sin__[i__ - 1] + tolin < stmp[i__ - 1] - tol) {
+ vmax = (stmp[i__ - 1] - tol) / (sin__[i__ - 1] + tolin);
+ } else {
+ vmax = 1.;
+ }
+ if (vmax > rmax[2]) {
+ rmax[2] = vmax;
+ if (ninfo[2] == 0) {
+ lmax[2] = *knt;
+ }
+ }
+/* L120: */
+ }
+
+/* Compare condition numbers for eigenvectors */
+/* taking their condition numbers into account */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (v > septmp[i__ - 1] * stmp[i__ - 1]) {
+ tol = septmp[i__ - 1];
+ } else {
+ tol = v / stmp[i__ - 1];
+ }
+ if (v > sepin[i__ - 1] * sin__[i__ - 1]) {
+ tolin = sepin[i__ - 1];
+ } else {
+ tolin = v / sin__[i__ - 1];
+ }
+/* Computing MAX */
+ d__1 = tol, d__2 = smlnum / eps;
+ tol = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = tolin, d__2 = smlnum / eps;
+ tolin = max(d__1,d__2);
+ if (eps * (sepin[i__ - 1] - tolin) > septmp[i__ - 1] + tol) {
+ vmax = 1. / eps;
+ } else if (sepin[i__ - 1] - tolin > septmp[i__ - 1] + tol) {
+ vmax = (sepin[i__ - 1] - tolin) / (septmp[i__ - 1] + tol);
+ } else if (sepin[i__ - 1] + tolin < eps * (septmp[i__ - 1] - tol))
+ {
+ vmax = 1. / eps;
+ } else if (sepin[i__ - 1] + tolin < septmp[i__ - 1] - tol) {
+ vmax = (septmp[i__ - 1] - tol) / (sepin[i__ - 1] + tolin);
+ } else {
+ vmax = 1.;
+ }
+ if (vmax > rmax[2]) {
+ rmax[2] = vmax;
+ if (ninfo[2] == 0) {
+ lmax[2] = *knt;
+ }
+ }
+/* L130: */
+ }
+
+/* Compare condition numbers for eigenvalues */
+/* without taking their condition numbers into account */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (sin__[i__ - 1] <= (doublereal) (n << 1) * eps && stmp[i__ - 1]
+ <= (doublereal) (n << 1) * eps) {
+ vmax = 1.;
+ } else if (eps * sin__[i__ - 1] > stmp[i__ - 1]) {
+ vmax = 1. / eps;
+ } else if (sin__[i__ - 1] > stmp[i__ - 1]) {
+ vmax = sin__[i__ - 1] / stmp[i__ - 1];
+ } else if (sin__[i__ - 1] < eps * stmp[i__ - 1]) {
+ vmax = 1. / eps;
+ } else if (sin__[i__ - 1] < stmp[i__ - 1]) {
+ vmax = stmp[i__ - 1] / sin__[i__ - 1];
+ } else {
+ vmax = 1.;
+ }
+ if (vmax > rmax[3]) {
+ rmax[3] = vmax;
+ if (ninfo[3] == 0) {
+ lmax[3] = *knt;
+ }
+ }
+/* L140: */
+ }
+
+/* Compare condition numbers for eigenvectors */
+/* without taking their condition numbers into account */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (sepin[i__ - 1] <= v && septmp[i__ - 1] <= v) {
+ vmax = 1.;
+ } else if (eps * sepin[i__ - 1] > septmp[i__ - 1]) {
+ vmax = 1. / eps;
+ } else if (sepin[i__ - 1] > septmp[i__ - 1]) {
+ vmax = sepin[i__ - 1] / septmp[i__ - 1];
+ } else if (sepin[i__ - 1] < eps * septmp[i__ - 1]) {
+ vmax = 1. / eps;
+ } else if (sepin[i__ - 1] < septmp[i__ - 1]) {
+ vmax = septmp[i__ - 1] / sepin[i__ - 1];
+ } else {
+ vmax = 1.;
+ }
+ if (vmax > rmax[3]) {
+ rmax[3] = vmax;
+ if (ninfo[3] == 0) {
+ lmax[3] = *knt;
+ }
+ }
+/* L150: */
+ }
+
+/* Compute eigenvalue condition numbers only and compare */
+
+ vmax = 0.;
+ dum[0] = -1.;
+ dcopy_(&n, dum, &c__0, stmp, &c__1);
+ dcopy_(&n, dum, &c__0, septmp, &c__1);
+ ztrsna_("E", "A", select, &n, t, &c__20, le, &c__20, re, &c__20, stmp,
+ septmp, &n, &m, work, &n, rwork, &info)
+ ;
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L260;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (stmp[i__ - 1] != s[i__ - 1]) {
+ vmax = 1. / eps;
+ }
+ if (septmp[i__ - 1] != dum[0]) {
+ vmax = 1. / eps;
+ }
+/* L160: */
+ }
+
+/* Compute eigenvector condition numbers only and compare */
+
+ dcopy_(&n, dum, &c__0, stmp, &c__1);
+ dcopy_(&n, dum, &c__0, septmp, &c__1);
+ ztrsna_("V", "A", select, &n, t, &c__20, le, &c__20, re, &c__20, stmp,
+ septmp, &n, &m, work, &n, rwork, &info)
+ ;
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L260;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (stmp[i__ - 1] != dum[0]) {
+ vmax = 1. / eps;
+ }
+ if (septmp[i__ - 1] != sep[i__ - 1]) {
+ vmax = 1. / eps;
+ }
+/* L170: */
+ }
+
+/* Compute all condition numbers using SELECT and compare */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ select[i__ - 1] = TRUE_;
+/* L180: */
+ }
+ dcopy_(&n, dum, &c__0, stmp, &c__1);
+ dcopy_(&n, dum, &c__0, septmp, &c__1);
+ ztrsna_("B", "S", select, &n, t, &c__20, le, &c__20, re, &c__20, stmp,
+ septmp, &n, &m, work, &n, rwork, &info)
+ ;
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L260;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (septmp[i__ - 1] != sep[i__ - 1]) {
+ vmax = 1. / eps;
+ }
+ if (stmp[i__ - 1] != s[i__ - 1]) {
+ vmax = 1. / eps;
+ }
+/* L190: */
+ }
+
+/* Compute eigenvalue condition numbers using SELECT and compare */
+
+ dcopy_(&n, dum, &c__0, stmp, &c__1);
+ dcopy_(&n, dum, &c__0, septmp, &c__1);
+ ztrsna_("E", "S", select, &n, t, &c__20, le, &c__20, re, &c__20, stmp,
+ septmp, &n, &m, work, &n, rwork, &info)
+ ;
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L260;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (stmp[i__ - 1] != s[i__ - 1]) {
+ vmax = 1. / eps;
+ }
+ if (septmp[i__ - 1] != dum[0]) {
+ vmax = 1. / eps;
+ }
+/* L200: */
+ }
+
+/* Compute eigenvector condition numbers using SELECT and compare */
+
+ dcopy_(&n, dum, &c__0, stmp, &c__1);
+ dcopy_(&n, dum, &c__0, septmp, &c__1);
+ ztrsna_("V", "S", select, &n, t, &c__20, le, &c__20, re, &c__20, stmp,
+ septmp, &n, &m, work, &n, rwork, &info)
+ ;
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L260;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (stmp[i__ - 1] != dum[0]) {
+ vmax = 1. / eps;
+ }
+ if (septmp[i__ - 1] != sep[i__ - 1]) {
+ vmax = 1. / eps;
+ }
+/* L210: */
+ }
+ if (vmax > rmax[1]) {
+ rmax[1] = vmax;
+ if (ninfo[1] == 0) {
+ lmax[1] = *knt;
+ }
+ }
+
+/* Select second and next to last eigenvalues */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ select[i__ - 1] = FALSE_;
+/* L220: */
+ }
+ icmp = 0;
+ if (n > 1) {
+ icmp = 1;
+ lcmp[0] = 2;
+ select[1] = TRUE_;
+ zcopy_(&n, &re[20], &c__1, re, &c__1);
+ zcopy_(&n, &le[20], &c__1, le, &c__1);
+ }
+ if (n > 3) {
+ icmp = 2;
+ lcmp[1] = n - 1;
+ select[n - 2] = TRUE_;
+ zcopy_(&n, &re[(n - 1) * 20 - 20], &c__1, &re[20], &c__1);
+ zcopy_(&n, &le[(n - 1) * 20 - 20], &c__1, &le[20], &c__1);
+ }
+
+/* Compute all selected condition numbers */
+
+ dcopy_(&icmp, dum, &c__0, stmp, &c__1);
+ dcopy_(&icmp, dum, &c__0, septmp, &c__1);
+ ztrsna_("B", "S", select, &n, t, &c__20, le, &c__20, re, &c__20, stmp,
+ septmp, &n, &m, work, &n, rwork, &info)
+ ;
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L260;
+ }
+ i__1 = icmp;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ j = lcmp[i__ - 1];
+ if (septmp[i__ - 1] != sep[j - 1]) {
+ vmax = 1. / eps;
+ }
+ if (stmp[i__ - 1] != s[j - 1]) {
+ vmax = 1. / eps;
+ }
+/* L230: */
+ }
+
+/* Compute selected eigenvalue condition numbers */
+
+ dcopy_(&icmp, dum, &c__0, stmp, &c__1);
+ dcopy_(&icmp, dum, &c__0, septmp, &c__1);
+ ztrsna_("E", "S", select, &n, t, &c__20, le, &c__20, re, &c__20, stmp,
+ septmp, &n, &m, work, &n, rwork, &info)
+ ;
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L260;
+ }
+ i__1 = icmp;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ j = lcmp[i__ - 1];
+ if (stmp[i__ - 1] != s[j - 1]) {
+ vmax = 1. / eps;
+ }
+ if (septmp[i__ - 1] != dum[0]) {
+ vmax = 1. / eps;
+ }
+/* L240: */
+ }
+
+/* Compute selected eigenvector condition numbers */
+
+ dcopy_(&icmp, dum, &c__0, stmp, &c__1);
+ dcopy_(&icmp, dum, &c__0, septmp, &c__1);
+ ztrsna_("V", "S", select, &n, t, &c__20, le, &c__20, re, &c__20, stmp,
+ septmp, &n, &m, work, &n, rwork, &info)
+ ;
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L260;
+ }
+ i__1 = icmp;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ j = lcmp[i__ - 1];
+ if (stmp[i__ - 1] != dum[0]) {
+ vmax = 1. / eps;
+ }
+ if (septmp[i__ - 1] != sep[j - 1]) {
+ vmax = 1. / eps;
+ }
+/* L250: */
+ }
+ if (vmax > rmax[1]) {
+ rmax[1] = vmax;
+ if (ninfo[1] == 0) {
+ lmax[1] = *knt;
+ }
+ }
+L260:
+ ;
+ }
+ goto L10;
+
+/* End of ZGET37 */
+
+} /* zget37_ */
diff --git a/TESTING/EIG/zget38.c b/TESTING/EIG/zget38.c
new file mode 100644
index 0000000..710a952
--- /dev/null
+++ b/TESTING/EIG/zget38.c
@@ -0,0 +1,655 @@
+/* zget38.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__7 = 7;
+static integer c__5 = 5;
+static integer c__20 = 20;
+static integer c__1200 = 1200;
+
+/* Subroutine */ int zget38_(doublereal *rmax, integer *lmax, integer *ninfo,
+ integer *knt, integer *nin)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
+ e_rsle(void);
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, m, n;
+ doublecomplex q[400] /* was [20][20] */;
+ doublereal s;
+ doublecomplex t[400] /* was [20][20] */;
+ doublereal v;
+ doublecomplex w[20];
+ doublereal val[3], eps, sep, sin__, tol;
+ doublecomplex tmp[400] /* was [20][20] */;
+ integer ndim, iscl, info, kmin, itmp;
+ doublereal vmin, vmax;
+ integer ipnt[20];
+ doublecomplex qsav[400] /* was [20][20] */, tsav[400] /* was [20][
+ 20] */;
+ doublereal tnrm;
+ integer isrt;
+ doublecomplex qtmp[400] /* was [20][20] */;
+ doublereal stmp, vmul;
+ doublecomplex ttmp[400] /* was [20][20] */, work[1200], wtmp[20];
+ doublereal wsrt[20];
+ doublecomplex tsav1[400] /* was [20][20] */;
+ doublereal sepin, tolin;
+ extern /* Subroutine */ int zhst01_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+ doublereal rwork[20];
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ integer iselec[20];
+ logical select[20];
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ doublereal bignum;
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *), zgehrd_(integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, integer *), zlacpy_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *
+);
+ doublereal septmp, smlnum;
+ extern /* Subroutine */ int zhseqr_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *), zunghr_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+ doublereal result[2];
+ extern /* Subroutine */ int ztrsen_(char *, char *, logical *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___5 = { 0, 0, 0, 0, 0 };
+ static cilist io___9 = { 0, 0, 0, 0, 0 };
+ static cilist io___12 = { 0, 0, 0, 0, 0 };
+ static cilist io___15 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGET38 tests ZTRSEN, a routine for estimating condition numbers of a */
+/* cluster of eigenvalues and/or its associated right invariant subspace */
+
+/* The test matrices are read from a file with logical unit number NIN. */
+
+/* Arguments */
+/* ========== */
+
+/* RMAX (output) DOUBLE PRECISION array, dimension (3) */
+/* Values of the largest test ratios. */
+/* RMAX(1) = largest residuals from ZHST01 or comparing */
+/* different calls to ZTRSEN */
+/* RMAX(2) = largest error in reciprocal condition */
+/* numbers taking their conditioning into account */
+/* RMAX(3) = largest error in reciprocal condition */
+/* numbers not taking their conditioning into */
+/* account (may be larger than RMAX(2)) */
+
+/* LMAX (output) INTEGER array, dimension (3) */
+/* LMAX(i) is example number where largest test ratio */
+/* RMAX(i) is achieved. Also: */
+/* If ZGEHRD returns INFO nonzero on example i, LMAX(1)=i */
+/* If ZHSEQR returns INFO nonzero on example i, LMAX(2)=i */
+/* If ZTRSEN returns INFO nonzero on example i, LMAX(3)=i */
+
+/* NINFO (output) INTEGER array, dimension (3) */
+/* NINFO(1) = No. of times ZGEHRD returned INFO nonzero */
+/* NINFO(2) = No. of times ZHSEQR returned INFO nonzero */
+/* NINFO(3) = No. of times ZTRSEN returned INFO nonzero */
+
+/* KNT (output) INTEGER */
+/* Total number of examples tested. */
+
+/* NIN (input) INTEGER */
+/* Input logical unit number. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ninfo;
+ --lmax;
+ --rmax;
+
+ /* Function Body */
+ eps = dlamch_("P");
+ smlnum = dlamch_("S") / eps;
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* EPSIN = 2**(-24) = precision to which input data computed */
+
+ eps = max(eps,5.9605e-8);
+ rmax[1] = 0.;
+ rmax[2] = 0.;
+ rmax[3] = 0.;
+ lmax[1] = 0;
+ lmax[2] = 0;
+ lmax[3] = 0;
+ *knt = 0;
+ ninfo[1] = 0;
+ ninfo[2] = 0;
+ ninfo[3] = 0;
+ val[0] = sqrt(smlnum);
+ val[1] = 1.;
+ val[2] = sqrt(sqrt(bignum));
+
+/* Read input data until N=0. Assume input eigenvalues are sorted */
+/* lexicographically (increasing by real part, then decreasing by */
+/* imaginary part) */
+
+L10:
+ io___5.ciunit = *nin;
+ s_rsle(&io___5);
+ do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&ndim, (ftnlen)sizeof(integer));
+ do_lio(&c__3, &c__1, (char *)&isrt, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (n == 0) {
+ return 0;
+ }
+ io___9.ciunit = *nin;
+ s_rsle(&io___9);
+ i__1 = ndim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&iselec[i__ - 1], (ftnlen)sizeof(integer)
+ );
+ }
+ e_rsle();
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ io___12.ciunit = *nin;
+ s_rsle(&io___12);
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ do_lio(&c__7, &c__1, (char *)&tmp[i__ + j * 20 - 21], (ftnlen)
+ sizeof(doublecomplex));
+ }
+ e_rsle();
+/* L20: */
+ }
+ io___15.ciunit = *nin;
+ s_rsle(&io___15);
+ do_lio(&c__5, &c__1, (char *)&sin__, (ftnlen)sizeof(doublereal));
+ do_lio(&c__5, &c__1, (char *)&sepin, (ftnlen)sizeof(doublereal));
+ e_rsle();
+
+ tnrm = zlange_("M", &n, &n, tmp, &c__20, rwork);
+ for (iscl = 1; iscl <= 3; ++iscl) {
+
+/* Scale input matrix */
+
+ ++(*knt);
+ zlacpy_("F", &n, &n, tmp, &c__20, t, &c__20);
+ vmul = val[iscl - 1];
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ zdscal_(&n, &vmul, &t[i__ * 20 - 20], &c__1);
+/* L30: */
+ }
+ if (tnrm == 0.) {
+ vmul = 1.;
+ }
+ zlacpy_("F", &n, &n, t, &c__20, tsav, &c__20);
+
+/* Compute Schur form */
+
+ i__1 = 1200 - n;
+ zgehrd_(&n, &c__1, &n, t, &c__20, work, &work[n], &i__1, &info);
+ if (info != 0) {
+ lmax[1] = *knt;
+ ++ninfo[1];
+ goto L200;
+ }
+
+/* Generate unitary matrix */
+
+ zlacpy_("L", &n, &n, t, &c__20, q, &c__20);
+ i__1 = 1200 - n;
+ zunghr_(&n, &c__1, &n, q, &c__20, work, &work[n], &i__1, &info);
+
+/* Compute Schur form */
+
+ i__1 = n - 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = n;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 20 - 21;
+ t[i__3].r = 0., t[i__3].i = 0.;
+/* L40: */
+ }
+/* L50: */
+ }
+ zhseqr_("S", "V", &n, &c__1, &n, t, &c__20, w, q, &c__20, work, &
+ c__1200, &info);
+ if (info != 0) {
+ lmax[2] = *knt;
+ ++ninfo[2];
+ goto L200;
+ }
+
+/* Sort, select eigenvalues */
+
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ipnt[i__ - 1] = i__;
+ select[i__ - 1] = FALSE_;
+/* L60: */
+ }
+ if (isrt == 0) {
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ - 1;
+ wsrt[i__ - 1] = w[i__2].r;
+/* L70: */
+ }
+ } else {
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ wsrt[i__ - 1] = d_imag(&w[i__ - 1]);
+/* L80: */
+ }
+ }
+ i__1 = n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ kmin = i__;
+ vmin = wsrt[i__ - 1];
+ i__2 = n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ if (wsrt[j - 1] < vmin) {
+ kmin = j;
+ vmin = wsrt[j - 1];
+ }
+/* L90: */
+ }
+ wsrt[kmin - 1] = wsrt[i__ - 1];
+ wsrt[i__ - 1] = vmin;
+ itmp = ipnt[i__ - 1];
+ ipnt[i__ - 1] = ipnt[kmin - 1];
+ ipnt[kmin - 1] = itmp;
+/* L100: */
+ }
+ i__1 = ndim;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ select[ipnt[iselec[i__ - 1] - 1] - 1] = TRUE_;
+/* L110: */
+ }
+
+/* Compute condition numbers */
+
+ zlacpy_("F", &n, &n, q, &c__20, qsav, &c__20);
+ zlacpy_("F", &n, &n, t, &c__20, tsav1, &c__20);
+ ztrsen_("B", "V", select, &n, t, &c__20, q, &c__20, wtmp, &m, &s, &
+ sep, work, &c__1200, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L200;
+ }
+ septmp = sep / vmul;
+ stmp = s;
+
+/* Compute residuals */
+
+ zhst01_(&n, &c__1, &n, tsav, &c__20, t, &c__20, q, &c__20, work, &
+ c__1200, rwork, result);
+ vmax = max(result[0],result[1]);
+ if (vmax > rmax[1]) {
+ rmax[1] = vmax;
+ if (ninfo[1] == 0) {
+ lmax[1] = *knt;
+ }
+ }
+
+/* Compare condition number for eigenvalue cluster */
+/* taking its condition number into account */
+
+/* Computing MAX */
+ d__1 = (doublereal) n * 2. * eps * tnrm;
+ v = max(d__1,smlnum);
+ if (tnrm == 0.) {
+ v = 1.;
+ }
+ if (v > septmp) {
+ tol = 1.;
+ } else {
+ tol = v / septmp;
+ }
+ if (v > sepin) {
+ tolin = 1.;
+ } else {
+ tolin = v / sepin;
+ }
+/* Computing MAX */
+ d__1 = tol, d__2 = smlnum / eps;
+ tol = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = tolin, d__2 = smlnum / eps;
+ tolin = max(d__1,d__2);
+ if (eps * (sin__ - tolin) > stmp + tol) {
+ vmax = 1. / eps;
+ } else if (sin__ - tolin > stmp + tol) {
+ vmax = (sin__ - tolin) / (stmp + tol);
+ } else if (sin__ + tolin < eps * (stmp - tol)) {
+ vmax = 1. / eps;
+ } else if (sin__ + tolin < stmp - tol) {
+ vmax = (stmp - tol) / (sin__ + tolin);
+ } else {
+ vmax = 1.;
+ }
+ if (vmax > rmax[2]) {
+ rmax[2] = vmax;
+ if (ninfo[2] == 0) {
+ lmax[2] = *knt;
+ }
+ }
+
+/* Compare condition numbers for invariant subspace */
+/* taking its condition number into account */
+
+ if (v > septmp * stmp) {
+ tol = septmp;
+ } else {
+ tol = v / stmp;
+ }
+ if (v > sepin * sin__) {
+ tolin = sepin;
+ } else {
+ tolin = v / sin__;
+ }
+/* Computing MAX */
+ d__1 = tol, d__2 = smlnum / eps;
+ tol = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = tolin, d__2 = smlnum / eps;
+ tolin = max(d__1,d__2);
+ if (eps * (sepin - tolin) > septmp + tol) {
+ vmax = 1. / eps;
+ } else if (sepin - tolin > septmp + tol) {
+ vmax = (sepin - tolin) / (septmp + tol);
+ } else if (sepin + tolin < eps * (septmp - tol)) {
+ vmax = 1. / eps;
+ } else if (sepin + tolin < septmp - tol) {
+ vmax = (septmp - tol) / (sepin + tolin);
+ } else {
+ vmax = 1.;
+ }
+ if (vmax > rmax[2]) {
+ rmax[2] = vmax;
+ if (ninfo[2] == 0) {
+ lmax[2] = *knt;
+ }
+ }
+
+/* Compare condition number for eigenvalue cluster */
+/* without taking its condition number into account */
+
+ if (sin__ <= (doublereal) (n << 1) * eps && stmp <= (doublereal) (n <<
+ 1) * eps) {
+ vmax = 1.;
+ } else if (eps * sin__ > stmp) {
+ vmax = 1. / eps;
+ } else if (sin__ > stmp) {
+ vmax = sin__ / stmp;
+ } else if (sin__ < eps * stmp) {
+ vmax = 1. / eps;
+ } else if (sin__ < stmp) {
+ vmax = stmp / sin__;
+ } else {
+ vmax = 1.;
+ }
+ if (vmax > rmax[3]) {
+ rmax[3] = vmax;
+ if (ninfo[3] == 0) {
+ lmax[3] = *knt;
+ }
+ }
+
+/* Compare condition numbers for invariant subspace */
+/* without taking its condition number into account */
+
+ if (sepin <= v && septmp <= v) {
+ vmax = 1.;
+ } else if (eps * sepin > septmp) {
+ vmax = 1. / eps;
+ } else if (sepin > septmp) {
+ vmax = sepin / septmp;
+ } else if (sepin < eps * septmp) {
+ vmax = 1. / eps;
+ } else if (sepin < septmp) {
+ vmax = septmp / sepin;
+ } else {
+ vmax = 1.;
+ }
+ if (vmax > rmax[3]) {
+ rmax[3] = vmax;
+ if (ninfo[3] == 0) {
+ lmax[3] = *knt;
+ }
+ }
+
+/* Compute eigenvalue condition number only and compare */
+/* Update Q */
+
+ vmax = 0.;
+ zlacpy_("F", &n, &n, tsav1, &c__20, ttmp, &c__20);
+ zlacpy_("F", &n, &n, qsav, &c__20, qtmp, &c__20);
+ septmp = -1.;
+ stmp = -1.;
+ ztrsen_("E", "V", select, &n, ttmp, &c__20, qtmp, &c__20, wtmp, &m, &
+ stmp, &septmp, work, &c__1200, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L200;
+ }
+ if (s != stmp) {
+ vmax = 1. / eps;
+ }
+ if (-1. != septmp) {
+ vmax = 1. / eps;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ if (ttmp[i__3].r != t[i__4].r || ttmp[i__3].i != t[i__4].i) {
+ vmax = 1. / eps;
+ }
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ if (qtmp[i__3].r != q[i__4].r || qtmp[i__3].i != q[i__4].i) {
+ vmax = 1. / eps;
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+
+/* Compute invariant subspace condition number only and compare */
+/* Update Q */
+
+ zlacpy_("F", &n, &n, tsav1, &c__20, ttmp, &c__20);
+ zlacpy_("F", &n, &n, qsav, &c__20, qtmp, &c__20);
+ septmp = -1.;
+ stmp = -1.;
+ ztrsen_("V", "V", select, &n, ttmp, &c__20, qtmp, &c__20, wtmp, &m, &
+ stmp, &septmp, work, &c__1200, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L200;
+ }
+ if (-1. != stmp) {
+ vmax = 1. / eps;
+ }
+ if (sep != septmp) {
+ vmax = 1. / eps;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ if (ttmp[i__3].r != t[i__4].r || ttmp[i__3].i != t[i__4].i) {
+ vmax = 1. / eps;
+ }
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ if (qtmp[i__3].r != q[i__4].r || qtmp[i__3].i != q[i__4].i) {
+ vmax = 1. / eps;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+/* Compute eigenvalue condition number only and compare */
+/* Do not update Q */
+
+ zlacpy_("F", &n, &n, tsav1, &c__20, ttmp, &c__20);
+ zlacpy_("F", &n, &n, qsav, &c__20, qtmp, &c__20);
+ septmp = -1.;
+ stmp = -1.;
+ ztrsen_("E", "N", select, &n, ttmp, &c__20, qtmp, &c__20, wtmp, &m, &
+ stmp, &septmp, work, &c__1200, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L200;
+ }
+ if (s != stmp) {
+ vmax = 1. / eps;
+ }
+ if (-1. != septmp) {
+ vmax = 1. / eps;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ if (ttmp[i__3].r != t[i__4].r || ttmp[i__3].i != t[i__4].i) {
+ vmax = 1. / eps;
+ }
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ if (qtmp[i__3].r != qsav[i__4].r || qtmp[i__3].i != qsav[i__4]
+ .i) {
+ vmax = 1. / eps;
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+
+/* Compute invariant subspace condition number only and compare */
+/* Do not update Q */
+
+ zlacpy_("F", &n, &n, tsav1, &c__20, ttmp, &c__20);
+ zlacpy_("F", &n, &n, qsav, &c__20, qtmp, &c__20);
+ septmp = -1.;
+ stmp = -1.;
+ ztrsen_("V", "N", select, &n, ttmp, &c__20, qtmp, &c__20, wtmp, &m, &
+ stmp, &septmp, work, &c__1200, &info);
+ if (info != 0) {
+ lmax[3] = *knt;
+ ++ninfo[3];
+ goto L200;
+ }
+ if (-1. != stmp) {
+ vmax = 1. / eps;
+ }
+ if (sep != septmp) {
+ vmax = 1. / eps;
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ if (ttmp[i__3].r != t[i__4].r || ttmp[i__3].i != t[i__4].i) {
+ vmax = 1. / eps;
+ }
+ i__3 = i__ + j * 20 - 21;
+ i__4 = i__ + j * 20 - 21;
+ if (qtmp[i__3].r != qsav[i__4].r || qtmp[i__3].i != qsav[i__4]
+ .i) {
+ vmax = 1. / eps;
+ }
+/* L180: */
+ }
+/* L190: */
+ }
+ if (vmax > rmax[1]) {
+ rmax[1] = vmax;
+ if (ninfo[1] == 0) {
+ lmax[1] = *knt;
+ }
+ }
+L200:
+ ;
+ }
+ goto L10;
+
+/* End of ZGET38 */
+
+} /* zget38_ */
diff --git a/TESTING/EIG/zget51.c b/TESTING/EIG/zget51.c
new file mode 100644
index 0000000..8da69f8
--- /dev/null
+++ b/TESTING/EIG/zget51.c
@@ -0,0 +1,273 @@
+/* zget51.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+
+/* Subroutine */ int zget51_(integer *itype, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *b, integer *ldb, doublecomplex *u,
+ integer *ldu, doublecomplex *v, integer *ldv, doublecomplex *work,
+ doublereal *rwork, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, u_dim1, u_offset, v_dim1,
+ v_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Local variables */
+ doublereal ulp;
+ integer jcol;
+ doublereal unfl;
+ integer jrow, jdiag;
+ doublereal anorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ doublereal wnorm;
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGET51 generally checks a decomposition of the form */
+
+/* A = U B V* */
+
+/* where * means conjugate transpose and U and V are unitary. */
+
+/* Specifically, if ITYPE=1 */
+
+/* RESULT = | A - U B V* | / ( |A| n ulp ) */
+
+/* If ITYPE=2, then: */
+
+/* RESULT = | A - B | / ( |A| n ulp ) */
+
+/* If ITYPE=3, then: */
+
+/* RESULT = | I - UU* | / ( n ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the type of tests to be performed. */
+/* =1: RESULT = | A - U B V* | / ( |A| n ulp ) */
+/* =2: RESULT = | A - B | / ( |A| n ulp ) */
+/* =3: RESULT = | I - UU* | / ( n ulp ) */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, ZGET51 does nothing. */
+/* It must be at least zero. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA, N) */
+/* The original (unfactored) matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least N. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB, N) */
+/* The factored matrix. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. It must be at least 1 */
+/* and at least N. */
+
+/* U (input) COMPLEX*16 array, dimension (LDU, N) */
+/* The unitary matrix on the left-hand side in the */
+/* decomposition. */
+/* Not referenced if ITYPE=2 */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+
+/* V (input) COMPLEX*16 array, dimension (LDV, N) */
+/* The unitary matrix on the left-hand side in the */
+/* decomposition. */
+/* Not referenced if ITYPE=2 */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of V. LDV must be at least N and */
+/* at least 1. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N**2) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESULT (output) DOUBLE PRECISION */
+/* The values computed by the test specified by ITYPE. The */
+/* value is currently limited to 1/ulp, to avoid overflow. */
+/* Errors are flagged by RESULT=10/ulp. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *result = 0.;
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Constants */
+
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+
+/* Some Error Checks */
+
+ if (*itype < 1 || *itype > 3) {
+ *result = 10. / ulp;
+ return 0;
+ }
+
+ if (*itype <= 2) {
+
+/* Tests scaled by the norm(A) */
+
+/* Computing MAX */
+ d__1 = zlange_("1", n, n, &a[a_offset], lda, &rwork[1]);
+ anorm = max(d__1,unfl);
+
+ if (*itype == 1) {
+
+/* ITYPE=1: Compute W = A - UBV' */
+
+ zlacpy_(" ", n, n, &a[a_offset], lda, &work[1], n);
+/* Computing 2nd power */
+ i__1 = *n;
+ zgemm_("N", "N", n, n, n, &c_b2, &u[u_offset], ldu, &b[b_offset],
+ ldb, &c_b1, &work[i__1 * i__1 + 1], n);
+
+ z__1.r = -1., z__1.i = -0.;
+/* Computing 2nd power */
+ i__1 = *n;
+ zgemm_("N", "C", n, n, n, &z__1, &work[i__1 * i__1 + 1], n, &v[
+ v_offset], ldv, &c_b2, &work[1], n);
+
+ } else {
+
+/* ITYPE=2: Compute W = A - B */
+
+ zlacpy_(" ", n, n, &b[b_offset], ldb, &work[1], n);
+
+ i__1 = *n;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ i__2 = *n;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ i__3 = jrow + *n * (jcol - 1);
+ i__4 = jrow + *n * (jcol - 1);
+ i__5 = jrow + jcol * a_dim1;
+ z__1.r = work[i__4].r - a[i__5].r, z__1.i = work[i__4].i
+ - a[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L10: */
+ }
+/* L20: */
+ }
+ }
+
+/* Compute norm(W)/ ( ulp*norm(A) ) */
+
+ wnorm = zlange_("1", n, n, &work[1], n, &rwork[1]);
+
+ if (anorm > wnorm) {
+ *result = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.) {
+/* Computing MIN */
+ d__1 = wnorm, d__2 = *n * anorm;
+ *result = min(d__1,d__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
+ *result = min(d__1,d__2) / (*n * ulp);
+ }
+ }
+
+ } else {
+
+/* Tests not scaled by norm(A) */
+
+/* ITYPE=3: Compute UU' - I */
+
+ zgemm_("N", "C", n, n, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu,
+ &c_b1, &work[1], n);
+
+ i__1 = *n;
+ for (jdiag = 1; jdiag <= i__1; ++jdiag) {
+ i__2 = (*n + 1) * (jdiag - 1) + 1;
+ i__3 = (*n + 1) * (jdiag - 1) + 1;
+ z__1.r = work[i__3].r - 1., z__1.i = work[i__3].i - 0.;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L30: */
+ }
+
+/* Computing MIN */
+ d__1 = zlange_("1", n, n, &work[1], n, &rwork[1]), d__2 = (
+ doublereal) (*n);
+ *result = min(d__1,d__2) / (*n * ulp);
+ }
+
+ return 0;
+
+/* End of ZGET51 */
+
+} /* zget51_ */
diff --git a/TESTING/EIG/zget52.c b/TESTING/EIG/zget52.c
new file mode 100644
index 0000000..fa8e304
--- /dev/null
+++ b/TESTING/EIG/zget52.c
@@ -0,0 +1,298 @@
+/* zget52.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zget52_(logical *left, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *b, integer *ldb, doublecomplex *e,
+ integer *lde, doublecomplex *alpha, doublecomplex *beta,
+ doublecomplex *work, doublereal *rwork, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, e_dim1, e_offset, i__1, i__2,
+ i__3;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer j;
+ doublereal ulp;
+ integer jvec;
+ doublereal temp1;
+ doublecomplex betai;
+ doublereal scale, abmax, anorm, bnorm, enorm;
+ char trans[1];
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ doublecomplex acoeff, bcoeff;
+ extern doublereal dlamch_(char *);
+ doublecomplex alphai;
+ doublereal alfmax, safmin;
+ char normab[1];
+ doublereal safmax, betmax;
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ doublereal enrmer, errnrm;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGET52 does an eigenvector check for the generalized eigenvalue */
+/* problem. */
+
+/* The basic test for right eigenvectors is: */
+
+/* | b(i) A E(i) - a(i) B E(i) | */
+/* RESULT(1) = max ------------------------------- */
+/* i n ulp max( |b(i) A|, |a(i) B| ) */
+
+/* using the 1-norm. Here, a(i)/b(i) = w is the i-th generalized */
+/* eigenvalue of A - w B, or, equivalently, b(i)/a(i) = m is the i-th */
+/* generalized eigenvalue of m A - B. */
+
+/* H H _ _ */
+/* For left eigenvectors, A , B , a, and b are used. */
+
+/* ZGET52 also tests the normalization of E. Each eigenvector is */
+/* supposed to be normalized so that the maximum "absolute value" */
+/* of its elements is 1, where in this case, "absolute value" */
+/* of a complex value x is |Re(x)| + |Im(x)| ; let us call this */
+/* maximum "absolute value" norm of a vector v M(v). */
+/* If a(i)=b(i)=0, then the eigenvector is set to be the jth coordinate */
+/* vector. The normalization test is: */
+
+/* RESULT(2) = max | M(v(i)) - 1 | / ( n ulp ) */
+/* eigenvectors v(i) */
+
+
+/* Arguments */
+/* ========= */
+
+/* LEFT (input) LOGICAL */
+/* =.TRUE.: The eigenvectors in the columns of E are assumed */
+/* to be *left* eigenvectors. */
+/* =.FALSE.: The eigenvectors in the columns of E are assumed */
+/* to be *right* eigenvectors. */
+
+/* N (input) INTEGER */
+/* The size of the matrices. If it is zero, ZGET52 does */
+/* nothing. It must be at least zero. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA, N) */
+/* The matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least N. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB, N) */
+/* The matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. It must be at least 1 */
+/* and at least N. */
+
+/* E (input) COMPLEX*16 array, dimension (LDE, N) */
+/* The matrix of eigenvectors. It must be O( 1 ). */
+
+/* LDE (input) INTEGER */
+/* The leading dimension of E. It must be at least 1 and at */
+/* least N. */
+
+/* ALPHA (input) COMPLEX*16 array, dimension (N) */
+/* The values a(i) as described above, which, along with b(i), */
+/* define the generalized eigenvalues. */
+
+/* BETA (input) COMPLEX*16 array, dimension (N) */
+/* The values b(i) as described above, which, along with a(i), */
+/* define the generalized eigenvalues. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N**2) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The values computed by the test described above. If A E or */
+/* B E is likely to overflow, then RESULT(1:2) is set to */
+/* 10 / ulp. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ e_dim1 = *lde;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ --alpha;
+ --beta;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.;
+ result[2] = 0.;
+ if (*n <= 0) {
+ return 0;
+ }
+
+ safmin = dlamch_("Safe minimum");
+ safmax = 1. / safmin;
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+
+ if (*left) {
+ *(unsigned char *)trans = 'C';
+ *(unsigned char *)normab = 'I';
+ } else {
+ *(unsigned char *)trans = 'N';
+ *(unsigned char *)normab = 'O';
+ }
+
+/* Norm of A, B, and E: */
+
+/* Computing MAX */
+ d__1 = zlange_(normab, n, n, &a[a_offset], lda, &rwork[1]);
+ anorm = max(d__1,safmin);
+/* Computing MAX */
+ d__1 = zlange_(normab, n, n, &b[b_offset], ldb, &rwork[1]);
+ bnorm = max(d__1,safmin);
+/* Computing MAX */
+ d__1 = zlange_("O", n, n, &e[e_offset], lde, &rwork[1]);
+ enorm = max(d__1,ulp);
+ alfmax = safmax / max(1.,bnorm);
+ betmax = safmax / max(1.,anorm);
+
+/* Compute error matrix. */
+/* Column i = ( b(i) A - a(i) B ) E(i) / max( |a(i) B| |b(i) A| ) */
+
+ i__1 = *n;
+ for (jvec = 1; jvec <= i__1; ++jvec) {
+ i__2 = jvec;
+ alphai.r = alpha[i__2].r, alphai.i = alpha[i__2].i;
+ i__2 = jvec;
+ betai.r = beta[i__2].r, betai.i = beta[i__2].i;
+/* Computing MAX */
+ d__5 = (d__1 = alphai.r, abs(d__1)) + (d__2 = d_imag(&alphai), abs(
+ d__2)), d__6 = (d__3 = betai.r, abs(d__3)) + (d__4 = d_imag(&
+ betai), abs(d__4));
+ abmax = max(d__5,d__6);
+ if ((d__1 = alphai.r, abs(d__1)) + (d__2 = d_imag(&alphai), abs(d__2))
+ > alfmax || (d__3 = betai.r, abs(d__3)) + (d__4 = d_imag(&
+ betai), abs(d__4)) > betmax || abmax < 1.) {
+ scale = 1. / max(abmax,safmin);
+ z__1.r = scale * alphai.r, z__1.i = scale * alphai.i;
+ alphai.r = z__1.r, alphai.i = z__1.i;
+ z__1.r = scale * betai.r, z__1.i = scale * betai.i;
+ betai.r = z__1.r, betai.i = z__1.i;
+ }
+/* Computing MAX */
+ d__5 = ((d__1 = alphai.r, abs(d__1)) + (d__2 = d_imag(&alphai), abs(
+ d__2))) * bnorm, d__6 = ((d__3 = betai.r, abs(d__3)) + (d__4 =
+ d_imag(&betai), abs(d__4))) * anorm, d__5 = max(d__5,d__6);
+ scale = 1. / max(d__5,safmin);
+ z__1.r = scale * betai.r, z__1.i = scale * betai.i;
+ acoeff.r = z__1.r, acoeff.i = z__1.i;
+ z__1.r = scale * alphai.r, z__1.i = scale * alphai.i;
+ bcoeff.r = z__1.r, bcoeff.i = z__1.i;
+ if (*left) {
+ d_cnjg(&z__1, &acoeff);
+ acoeff.r = z__1.r, acoeff.i = z__1.i;
+ d_cnjg(&z__1, &bcoeff);
+ bcoeff.r = z__1.r, bcoeff.i = z__1.i;
+ }
+ zgemv_(trans, n, n, &acoeff, &a[a_offset], lda, &e[jvec * e_dim1 + 1],
+ &c__1, &c_b1, &work[*n * (jvec - 1) + 1], &c__1);
+ z__1.r = -bcoeff.r, z__1.i = -bcoeff.i;
+ zgemv_(trans, n, n, &z__1, &b[b_offset], lda, &e[jvec * e_dim1 + 1], &
+ c__1, &c_b2, &work[*n * (jvec - 1) + 1], &c__1);
+/* L10: */
+ }
+
+ errnrm = zlange_("One", n, n, &work[1], n, &rwork[1]) / enorm;
+
+/* Compute RESULT(1) */
+
+ result[1] = errnrm / ulp;
+
+/* Normalization of E: */
+
+ enrmer = 0.;
+ i__1 = *n;
+ for (jvec = 1; jvec <= i__1; ++jvec) {
+ temp1 = 0.;
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ i__3 = j + jvec * e_dim1;
+ d__3 = temp1, d__4 = (d__1 = e[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&e[j + jvec * e_dim1]), abs(d__2));
+ temp1 = max(d__3,d__4);
+/* L20: */
+ }
+/* Computing MAX */
+ d__1 = enrmer, d__2 = temp1 - 1.;
+ enrmer = max(d__1,d__2);
+/* L30: */
+ }
+
+/* Compute RESULT(2) : the normalization error in E. */
+
+ result[2] = enrmer / ((doublereal) (*n) * ulp);
+
+ return 0;
+
+/* End of ZGET52 */
+
+} /* zget52_ */
diff --git a/TESTING/EIG/zget54.c b/TESTING/EIG/zget54.c
new file mode 100644
index 0000000..0c3f758
--- /dev/null
+++ b/TESTING/EIG/zget54.c
@@ -0,0 +1,228 @@
+/* zget54.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+
+/* Subroutine */ int zget54_(integer *n, doublecomplex *a, integer *lda,
+ doublecomplex *b, integer *ldb, doublecomplex *s, integer *lds,
+ doublecomplex *t, integer *ldt, doublecomplex *u, integer *ldu,
+ doublecomplex *v, integer *ldv, doublecomplex *work, doublereal *
+ result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, s_dim1, s_offset, t_dim1,
+ t_offset, u_dim1, u_offset, v_dim1, v_offset, i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Local variables */
+ doublereal dum[1], ulp, unfl;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ doublereal wnorm;
+ extern doublereal dlamch_(char *);
+ doublereal abnorm;
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGET54 checks a generalized decomposition of the form */
+
+/* A = U*S*V' and B = U*T* V' */
+
+/* where ' means conjugate transpose and U and V are unitary. */
+
+/* Specifically, */
+
+/* RESULT = ||( A - U*S*V', B - U*T*V' )|| / (||( A, B )||*n*ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, DGET54 does nothing. */
+/* It must be at least zero. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA, N) */
+/* The original (unfactored) matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least N. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB, N) */
+/* The original (unfactored) matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. It must be at least 1 */
+/* and at least N. */
+
+/* S (input) COMPLEX*16 array, dimension (LDS, N) */
+/* The factored matrix S. */
+
+/* LDS (input) INTEGER */
+/* The leading dimension of S. It must be at least 1 */
+/* and at least N. */
+
+/* T (input) COMPLEX*16 array, dimension (LDT, N) */
+/* The factored matrix T. */
+
+/* LDT (input) INTEGER */
+/* The leading dimension of T. It must be at least 1 */
+/* and at least N. */
+
+/* U (input) COMPLEX*16 array, dimension (LDU, N) */
+/* The orthogonal matrix on the left-hand side in the */
+/* decomposition. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+
+/* V (input) COMPLEX*16 array, dimension (LDV, N) */
+/* The orthogonal matrix on the left-hand side in the */
+/* decomposition. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of V. LDV must be at least N and */
+/* at least 1. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (3*N**2) */
+
+/* RESULT (output) DOUBLE PRECISION */
+/* The value RESULT, It is currently limited to 1/ulp, to */
+/* avoid overflow. Errors are flagged by RESULT=10/ulp. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ s_dim1 = *lds;
+ s_offset = 1 + s_dim1;
+ s -= s_offset;
+ t_dim1 = *ldt;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --work;
+
+ /* Function Body */
+ *result = 0.;
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Constants */
+
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+
+/* compute the norm of (A,B) */
+
+ zlacpy_("Full", n, n, &a[a_offset], lda, &work[1], n);
+ zlacpy_("Full", n, n, &b[b_offset], ldb, &work[*n * *n + 1], n)
+ ;
+/* Computing MAX */
+ i__1 = *n << 1;
+ d__1 = zlange_("1", n, &i__1, &work[1], n, dum);
+ abnorm = max(d__1,unfl);
+
+/* Compute W1 = A - U*S*V', and put in the array WORK(1:N*N) */
+
+ zlacpy_(" ", n, n, &a[a_offset], lda, &work[1], n);
+ zgemm_("N", "N", n, n, n, &c_b2, &u[u_offset], ldu, &s[s_offset], lds, &
+ c_b1, &work[*n * *n + 1], n);
+
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("N", "C", n, n, n, &z__1, &work[*n * *n + 1], n, &v[v_offset], ldv,
+ &c_b2, &work[1], n);
+
+/* Compute W2 = B - U*T*V', and put in the workarray W(N*N+1:2*N*N) */
+
+ zlacpy_(" ", n, n, &b[b_offset], ldb, &work[*n * *n + 1], n);
+ zgemm_("N", "N", n, n, n, &c_b2, &u[u_offset], ldu, &t[t_offset], ldt, &
+ c_b1, &work[(*n << 1) * *n + 1], n);
+
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("N", "C", n, n, n, &z__1, &work[(*n << 1) * *n + 1], n, &v[
+ v_offset], ldv, &c_b2, &work[*n * *n + 1], n);
+
+/* Compute norm(W)/ ( ulp*norm((A,B)) ) */
+
+ i__1 = *n << 1;
+ wnorm = zlange_("1", n, &i__1, &work[1], n, dum);
+
+ if (abnorm > wnorm) {
+ *result = wnorm / abnorm / ((*n << 1) * ulp);
+ } else {
+ if (abnorm < 1.) {
+/* Computing MIN */
+ d__1 = wnorm, d__2 = (*n << 1) * abnorm;
+ *result = min(d__1,d__2) / abnorm / ((*n << 1) * ulp);
+ } else {
+/* Computing MIN */
+ d__1 = wnorm / abnorm, d__2 = (doublereal) (*n << 1);
+ *result = min(d__1,d__2) / ((*n << 1) * ulp);
+ }
+ }
+
+ return 0;
+
+/* End of ZGET54 */
+
+} /* zget54_ */
diff --git a/TESTING/EIG/zglmts.c b/TESTING/EIG/zglmts.c
new file mode 100644
index 0000000..af140cf
--- /dev/null
+++ b/TESTING/EIG/zglmts.c
@@ -0,0 +1,204 @@
+/* zglmts.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublecomplex c_b13 = {-1.,-0.};
+static doublecomplex c_b15 = {1.,0.};
+
+/* Subroutine */ int zglmts_(integer *n, integer *m, integer *p,
+ doublecomplex *a, doublecomplex *af, integer *lda, doublecomplex *b,
+ doublecomplex *bf, integer *ldb, doublecomplex *d__, doublecomplex *
+ df, doublecomplex *x, doublecomplex *u, doublecomplex *work, integer *
+ lwork, doublereal *rwork, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1,
+ bf_offset;
+ doublereal d__1;
+
+ /* Local variables */
+ doublereal eps;
+ integer info;
+ doublereal unfl, anorm, bnorm, dnorm;
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ doublereal xnorm, ynorm;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int zggglm_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, integer *), zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dzasum_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGLMTS tests ZGGGLM - a subroutine for solving the generalized */
+/* linear model problem. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices A and B. N >= 0. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of columns of the matrix B. P >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,M) */
+/* The N-by-M matrix A. */
+
+/* AF (workspace) COMPLEX*16 array, dimension (LDA,M) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF. LDA >= max(M,N). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,P) */
+/* The N-by-P matrix A. */
+
+/* BF (workspace) COMPLEX*16 array, dimension (LDB,P) */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the arrays B, BF. LDB >= max(P,N). */
+
+/* D (input) COMPLEX*16 array, dimension( N ) */
+/* On input, the left hand side of the GLM. */
+
+/* DF (workspace) COMPLEX*16 array, dimension( N ) */
+
+/* X (output) COMPLEX*16 array, dimension( M ) */
+/* solution vector X in the GLM problem. */
+
+/* U (output) COMPLEX*16 array, dimension( P ) */
+/* solution vector U in the GLM problem. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION */
+/* The test ratio: */
+/* norm( d - A*x - B*u ) */
+/* RESULT = ----------------------------------------- */
+/* (norm(A)+norm(B))*(norm(x)+norm(u))*EPS */
+
+/* ==================================================================== */
+
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ bf_dim1 = *ldb;
+ bf_offset = 1 + bf_dim1;
+ bf -= bf_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --d__;
+ --df;
+ --x;
+ --u;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+/* Computing MAX */
+ d__1 = zlange_("1", n, m, &a[a_offset], lda, &rwork[1]);
+ anorm = max(d__1,unfl);
+/* Computing MAX */
+ d__1 = zlange_("1", n, p, &b[b_offset], ldb, &rwork[1]);
+ bnorm = max(d__1,unfl);
+
+/* Copy the matrices A and B to the arrays AF and BF, */
+/* and the vector D the array DF. */
+
+ zlacpy_("Full", n, m, &a[a_offset], lda, &af[af_offset], lda);
+ zlacpy_("Full", n, p, &b[b_offset], ldb, &bf[bf_offset], ldb);
+ zcopy_(n, &d__[1], &c__1, &df[1], &c__1);
+
+/* Solve GLM problem */
+
+ zggglm_(n, m, p, &af[af_offset], lda, &bf[bf_offset], ldb, &df[1], &x[1],
+ &u[1], &work[1], lwork, &info);
+
+/* Test the residual for the solution of LSE */
+
+/* norm( d - A*x - B*u ) */
+/* RESULT = ----------------------------------------- */
+/* (norm(A)+norm(B))*(norm(x)+norm(u))*EPS */
+
+ zcopy_(n, &d__[1], &c__1, &df[1], &c__1);
+ zgemv_("No transpose", n, m, &c_b13, &a[a_offset], lda, &x[1], &c__1, &
+ c_b15, &df[1], &c__1);
+
+ zgemv_("No transpose", n, p, &c_b13, &b[b_offset], ldb, &u[1], &c__1, &
+ c_b15, &df[1], &c__1);
+
+ dnorm = dzasum_(n, &df[1], &c__1);
+ xnorm = dzasum_(m, &x[1], &c__1) + dzasum_(p, &u[1], &c__1);
+ ynorm = anorm + bnorm;
+
+ if (xnorm <= 0.) {
+ *result = 0.;
+ } else {
+ *result = dnorm / ynorm / xnorm / eps;
+ }
+
+ return 0;
+
+/* End of ZGLMTS */
+
+} /* zglmts_ */
diff --git a/TESTING/EIG/zgqrts.c b/TESTING/EIG/zgqrts.c
new file mode 100644
index 0000000..ca2e641
--- /dev/null
+++ b/TESTING/EIG/zgqrts.c
@@ -0,0 +1,332 @@
+/* zgqrts.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static doublecomplex c_b3 = {-1e10,0.};
+static doublereal c_b34 = -1.;
+static doublereal c_b35 = 1.;
+
+/* Subroutine */ int zgqrts_(integer *n, integer *m, integer *p,
+ doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex *
+ r__, integer *lda, doublecomplex *taua, doublecomplex *b,
+ doublecomplex *bf, doublecomplex *z__, doublecomplex *t,
+ doublecomplex *bwk, integer *ldb, doublecomplex *taub, doublecomplex *
+ work, integer *lwork, doublereal *rwork, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1,
+ bf_offset, bwk_dim1, bwk_offset, q_dim1, q_offset, r_dim1,
+ r_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Local variables */
+ doublereal ulp;
+ integer info;
+ doublereal unfl, resid, anorm, bnorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zherk_(char *, char *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *),
+ zlanhe_(char *, char *, integer *, doublecomplex *, integer *,
+ doublereal *);
+ extern /* Subroutine */ int zggqrf_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *)
+ , zlacpy_(char *, integer *, integer *, doublecomplex *, integer *
+, doublecomplex *, integer *), zlaset_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *), zungqr_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *), zungrq_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGQRTS tests ZGGQRF, which computes the GQR factorization of an */
+/* N-by-M matrix A and a N-by-P matrix B: A = Q*R and B = Q*T*Z. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices A and B. N >= 0. */
+
+/* M (input) INTEGER */
+/* The number of columns of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of columns of the matrix B. P >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,M) */
+/* The N-by-M matrix A. */
+
+/* AF (output) COMPLEX*16 array, dimension (LDA,N) */
+/* Details of the GQR factorization of A and B, as returned */
+/* by ZGGQRF, see CGGQRF for further details. */
+
+/* Q (output) COMPLEX*16 array, dimension (LDA,N) */
+/* The M-by-M unitary matrix Q. */
+
+/* R (workspace) COMPLEX*16 array, dimension (LDA,MAX(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, R and Q. */
+/* LDA >= max(M,N). */
+
+/* TAUA (output) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by ZGGQRF. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,P) */
+/* On entry, the N-by-P matrix A. */
+
+/* BF (output) COMPLEX*16 array, dimension (LDB,N) */
+/* Details of the GQR factorization of A and B, as returned */
+/* by ZGGQRF, see CGGQRF for further details. */
+
+/* Z (output) COMPLEX*16 array, dimension (LDB,P) */
+/* The P-by-P unitary matrix Z. */
+
+/* T (workspace) COMPLEX*16 array, dimension (LDB,max(P,N)) */
+
+/* BWK (workspace) COMPLEX*16 array, dimension (LDB,N) */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the arrays B, BF, Z and T. */
+/* LDB >= max(P,N). */
+
+/* TAUB (output) COMPLEX*16 array, dimension (min(P,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by DGGRQF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK, LWORK >= max(N,M,P)**2. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(N,M,P)) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP) */
+/* RESULT(2) = norm( T*Z - Q'*B ) / (MAX(P,N)*norm(B)*ULP) */
+/* RESULT(3) = norm( I - Q'*Q ) / ( M*ULP ) */
+/* RESULT(4) = norm( I - Z'*Z ) / ( P*ULP ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --taua;
+ bwk_dim1 = *ldb;
+ bwk_offset = 1 + bwk_dim1;
+ bwk -= bwk_offset;
+ t_dim1 = *ldb;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ z_dim1 = *ldb;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ bf_dim1 = *ldb;
+ bf_offset = 1 + bf_dim1;
+ bf -= bf_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --taub;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ ulp = dlamch_("Precision");
+ unfl = dlamch_("Safe minimum");
+
+/* Copy the matrix A to the array AF. */
+
+ zlacpy_("Full", n, m, &a[a_offset], lda, &af[af_offset], lda);
+ zlacpy_("Full", n, p, &b[b_offset], ldb, &bf[bf_offset], ldb);
+
+/* Computing MAX */
+ d__1 = zlange_("1", n, m, &a[a_offset], lda, &rwork[1]);
+ anorm = max(d__1,unfl);
+/* Computing MAX */
+ d__1 = zlange_("1", n, p, &b[b_offset], ldb, &rwork[1]);
+ bnorm = max(d__1,unfl);
+
+/* Factorize the matrices A and B in the arrays AF and BF. */
+
+ zggqrf_(n, m, p, &af[af_offset], lda, &taua[1], &bf[bf_offset], ldb, &
+ taub[1], &work[1], lwork, &info);
+
+/* Generate the N-by-N matrix Q */
+
+ zlaset_("Full", n, n, &c_b3, &c_b3, &q[q_offset], lda);
+ i__1 = *n - 1;
+ zlacpy_("Lower", &i__1, m, &af[af_dim1 + 2], lda, &q[q_dim1 + 2], lda);
+ i__1 = min(*n,*m);
+ zungqr_(n, n, &i__1, &q[q_offset], lda, &taua[1], &work[1], lwork, &info);
+
+/* Generate the P-by-P matrix Z */
+
+ zlaset_("Full", p, p, &c_b3, &c_b3, &z__[z_offset], ldb);
+ if (*n <= *p) {
+ if (*n > 0 && *n < *p) {
+ i__1 = *p - *n;
+ zlacpy_("Full", n, &i__1, &bf[bf_offset], ldb, &z__[*p - *n + 1 +
+ z_dim1], ldb);
+ }
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ zlacpy_("Lower", &i__1, &i__2, &bf[(*p - *n + 1) * bf_dim1 + 2],
+ ldb, &z__[*p - *n + 2 + (*p - *n + 1) * z_dim1], ldb);
+ }
+ } else {
+ if (*p > 1) {
+ i__1 = *p - 1;
+ i__2 = *p - 1;
+ zlacpy_("Lower", &i__1, &i__2, &bf[*n - *p + 2 + bf_dim1], ldb, &
+ z__[z_dim1 + 2], ldb);
+ }
+ }
+ i__1 = min(*n,*p);
+ zungrq_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, &
+ info);
+
+/* Copy R */
+
+ zlaset_("Full", n, m, &c_b1, &c_b1, &r__[r_offset], lda);
+ zlacpy_("Upper", n, m, &af[af_offset], lda, &r__[r_offset], lda);
+
+/* Copy T */
+
+ zlaset_("Full", n, p, &c_b1, &c_b1, &t[t_offset], ldb);
+ if (*n <= *p) {
+ zlacpy_("Upper", n, n, &bf[(*p - *n + 1) * bf_dim1 + 1], ldb, &t[(*p
+ - *n + 1) * t_dim1 + 1], ldb);
+ } else {
+ i__1 = *n - *p;
+ zlacpy_("Full", &i__1, p, &bf[bf_offset], ldb, &t[t_offset], ldb);
+ zlacpy_("Upper", p, p, &bf[*n - *p + 1 + bf_dim1], ldb, &t[*n - *p +
+ 1 + t_dim1], ldb);
+ }
+
+/* Compute R - Q'*A */
+
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("Conjugate transpose", "No transpose", n, m, n, &z__1, &q[q_offset]
+, lda, &a[a_offset], lda, &c_b2, &r__[r_offset], lda);
+
+/* Compute norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP ) . */
+
+ resid = zlange_("1", n, m, &r__[r_offset], lda, &rwork[1]);
+ if (anorm > 0.) {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ result[1] = resid / (doublereal) max(i__1,*n) / anorm / ulp;
+ } else {
+ result[1] = 0.;
+ }
+
+/* Compute T*Z - Q'*B */
+
+ zgemm_("No Transpose", "No transpose", n, p, p, &c_b2, &t[t_offset], ldb,
+ &z__[z_offset], ldb, &c_b1, &bwk[bwk_offset], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("Conjugate transpose", "No transpose", n, p, n, &z__1, &q[q_offset]
+, lda, &b[b_offset], ldb, &c_b2, &bwk[bwk_offset], ldb);
+
+/* Compute norm( T*Z - Q'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */
+
+ resid = zlange_("1", n, p, &bwk[bwk_offset], ldb, &rwork[1]);
+ if (bnorm > 0.) {
+/* Computing MAX */
+ i__1 = max(1,*p);
+ result[2] = resid / (doublereal) max(i__1,*n) / bnorm / ulp;
+ } else {
+ result[2] = 0.;
+ }
+
+/* Compute I - Q'*Q */
+
+ zlaset_("Full", n, n, &c_b1, &c_b2, &r__[r_offset], lda);
+ zherk_("Upper", "Conjugate transpose", n, n, &c_b34, &q[q_offset], lda, &
+ c_b35, &r__[r_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( N * ULP ) . */
+
+ resid = zlanhe_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
+ result[3] = resid / (doublereal) max(1,*n) / ulp;
+
+/* Compute I - Z'*Z */
+
+ zlaset_("Full", p, p, &c_b1, &c_b2, &t[t_offset], ldb);
+ zherk_("Upper", "Conjugate transpose", p, p, &c_b34, &z__[z_offset], ldb,
+ &c_b35, &t[t_offset], ldb);
+
+/* Compute norm( I - Z'*Z ) / ( P*ULP ) . */
+
+ resid = zlanhe_("1", "Upper", p, &t[t_offset], ldb, &rwork[1]);
+ result[4] = resid / (doublereal) max(1,*p) / ulp;
+
+ return 0;
+
+/* End of ZGQRTS */
+
+} /* zgqrts_ */
diff --git a/TESTING/EIG/zgrqts.c b/TESTING/EIG/zgrqts.c
new file mode 100644
index 0000000..8ceefdf
--- /dev/null
+++ b/TESTING/EIG/zgrqts.c
@@ -0,0 +1,335 @@
+/* zgrqts.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static doublecomplex c_b3 = {-1e10,0.};
+static doublereal c_b34 = -1.;
+static doublereal c_b35 = 1.;
+
+/* Subroutine */ int zgrqts_(integer *m, integer *p, integer *n,
+ doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex *
+ r__, integer *lda, doublecomplex *taua, doublecomplex *b,
+ doublecomplex *bf, doublecomplex *z__, doublecomplex *t,
+ doublecomplex *bwk, integer *ldb, doublecomplex *taub, doublecomplex *
+ work, integer *lwork, doublereal *rwork, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1,
+ bf_offset, bwk_dim1, bwk_offset, q_dim1, q_offset, r_dim1,
+ r_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Local variables */
+ doublereal ulp;
+ integer info;
+ doublereal unfl, resid, anorm, bnorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zherk_(char *, char *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *),
+ zlanhe_(char *, char *, integer *, doublecomplex *, integer *,
+ doublereal *);
+ extern /* Subroutine */ int zggrqf_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *)
+ , zlacpy_(char *, integer *, integer *, doublecomplex *, integer *
+, doublecomplex *, integer *), zlaset_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *), zungqr_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *), zungrq_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGRQTS tests ZGGRQF, which computes the GRQ factorization of an */
+/* M-by-N matrix A and a P-by-N matrix B: A = R*Q and B = Z*T*Q. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The M-by-N matrix A. */
+
+/* AF (output) COMPLEX*16 array, dimension (LDA,N) */
+/* Details of the GRQ factorization of A and B, as returned */
+/* by ZGGRQF, see CGGRQF for further details. */
+
+/* Q (output) COMPLEX*16 array, dimension (LDA,N) */
+/* The N-by-N unitary matrix Q. */
+
+/* R (workspace) COMPLEX*16 array, dimension (LDA,MAX(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, R and Q. */
+/* LDA >= max(M,N). */
+
+/* TAUA (output) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by DGGQRC. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,N) */
+/* On entry, the P-by-N matrix A. */
+
+/* BF (output) COMPLEX*16 array, dimension (LDB,N) */
+/* Details of the GQR factorization of A and B, as returned */
+/* by ZGGRQF, see CGGRQF for further details. */
+
+/* Z (output) DOUBLE PRECISION array, dimension (LDB,P) */
+/* The P-by-P unitary matrix Z. */
+
+/* T (workspace) COMPLEX*16 array, dimension (LDB,max(P,N)) */
+
+/* BWK (workspace) COMPLEX*16 array, dimension (LDB,N) */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the arrays B, BF, Z and T. */
+/* LDB >= max(P,N). */
+
+/* TAUB (output) COMPLEX*16 array, dimension (min(P,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by DGGRQF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK, LWORK >= max(M,P,N)**2. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP) */
+/* RESULT(2) = norm( T*Q - Z'*B ) / (MAX(P,N)*norm(B)*ULP) */
+/* RESULT(3) = norm( I - Q'*Q ) / ( N*ULP ) */
+/* RESULT(4) = norm( I - Z'*Z ) / ( P*ULP ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --taua;
+ bwk_dim1 = *ldb;
+ bwk_offset = 1 + bwk_dim1;
+ bwk -= bwk_offset;
+ t_dim1 = *ldb;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ z_dim1 = *ldb;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ bf_dim1 = *ldb;
+ bf_offset = 1 + bf_dim1;
+ bf -= bf_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --taub;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ ulp = dlamch_("Precision");
+ unfl = dlamch_("Safe minimum");
+
+/* Copy the matrix A to the array AF. */
+
+ zlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+ zlacpy_("Full", p, n, &b[b_offset], ldb, &bf[bf_offset], ldb);
+
+/* Computing MAX */
+ d__1 = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ anorm = max(d__1,unfl);
+/* Computing MAX */
+ d__1 = zlange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
+ bnorm = max(d__1,unfl);
+
+/* Factorize the matrices A and B in the arrays AF and BF. */
+
+ zggrqf_(m, p, n, &af[af_offset], lda, &taua[1], &bf[bf_offset], ldb, &
+ taub[1], &work[1], lwork, &info);
+
+/* Generate the N-by-N matrix Q */
+
+ zlaset_("Full", n, n, &c_b3, &c_b3, &q[q_offset], lda);
+ if (*m <= *n) {
+ if (*m > 0 && *m < *n) {
+ i__1 = *n - *m;
+ zlacpy_("Full", m, &i__1, &af[af_offset], lda, &q[*n - *m + 1 +
+ q_dim1], lda);
+ }
+ if (*m > 1) {
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ zlacpy_("Lower", &i__1, &i__2, &af[(*n - *m + 1) * af_dim1 + 2],
+ lda, &q[*n - *m + 2 + (*n - *m + 1) * q_dim1], lda);
+ }
+ } else {
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ zlacpy_("Lower", &i__1, &i__2, &af[*m - *n + 2 + af_dim1], lda, &
+ q[q_dim1 + 2], lda);
+ }
+ }
+ i__1 = min(*m,*n);
+ zungrq_(n, n, &i__1, &q[q_offset], lda, &taua[1], &work[1], lwork, &info);
+
+/* Generate the P-by-P matrix Z */
+
+ zlaset_("Full", p, p, &c_b3, &c_b3, &z__[z_offset], ldb);
+ if (*p > 1) {
+ i__1 = *p - 1;
+ zlacpy_("Lower", &i__1, n, &bf[bf_dim1 + 2], ldb, &z__[z_dim1 + 2],
+ ldb);
+ }
+ i__1 = min(*p,*n);
+ zungqr_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, &
+ info);
+
+/* Copy R */
+
+ zlaset_("Full", m, n, &c_b1, &c_b1, &r__[r_offset], lda);
+ if (*m <= *n) {
+ zlacpy_("Upper", m, m, &af[(*n - *m + 1) * af_dim1 + 1], lda, &r__[(*
+ n - *m + 1) * r_dim1 + 1], lda);
+ } else {
+ i__1 = *m - *n;
+ zlacpy_("Full", &i__1, n, &af[af_offset], lda, &r__[r_offset], lda);
+ zlacpy_("Upper", n, n, &af[*m - *n + 1 + af_dim1], lda, &r__[*m - *n
+ + 1 + r_dim1], lda);
+ }
+
+/* Copy T */
+
+ zlaset_("Full", p, n, &c_b1, &c_b1, &t[t_offset], ldb);
+ zlacpy_("Upper", p, n, &bf[bf_offset], ldb, &t[t_offset], ldb);
+
+/* Compute R - A*Q' */
+
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "Conjugate transpose", m, n, n, &z__1, &a[a_offset]
+, lda, &q[q_offset], lda, &c_b2, &r__[r_offset], lda);
+
+/* Compute norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP ) . */
+
+ resid = zlange_("1", m, n, &r__[r_offset], lda, &rwork[1]);
+ if (anorm > 0.) {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ result[1] = resid / (doublereal) max(i__1,*n) / anorm / ulp;
+ } else {
+ result[1] = 0.;
+ }
+
+/* Compute T*Q - Z'*B */
+
+ zgemm_("Conjugate transpose", "No transpose", p, n, p, &c_b2, &z__[
+ z_offset], ldb, &b[b_offset], ldb, &c_b1, &bwk[bwk_offset], ldb);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "No transpose", p, n, n, &c_b2, &t[t_offset], ldb,
+ &q[q_offset], lda, &z__1, &bwk[bwk_offset], ldb);
+
+/* Compute norm( T*Q - Z'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */
+
+ resid = zlange_("1", p, n, &bwk[bwk_offset], ldb, &rwork[1]);
+ if (bnorm > 0.) {
+/* Computing MAX */
+ i__1 = max(1,*p);
+ result[2] = resid / (doublereal) max(i__1,*m) / bnorm / ulp;
+ } else {
+ result[2] = 0.;
+ }
+
+/* Compute I - Q*Q' */
+
+ zlaset_("Full", n, n, &c_b1, &c_b2, &r__[r_offset], lda);
+ zherk_("Upper", "No Transpose", n, n, &c_b34, &q[q_offset], lda, &c_b35, &
+ r__[r_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( N * ULP ) . */
+
+ resid = zlanhe_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
+ result[3] = resid / (doublereal) max(1,*n) / ulp;
+
+/* Compute I - Z'*Z */
+
+ zlaset_("Full", p, p, &c_b1, &c_b2, &t[t_offset], ldb);
+ zherk_("Upper", "Conjugate transpose", p, p, &c_b34, &z__[z_offset], ldb,
+ &c_b35, &t[t_offset], ldb);
+
+/* Compute norm( I - Z'*Z ) / ( P*ULP ) . */
+
+ resid = zlanhe_("1", "Upper", p, &t[t_offset], ldb, &rwork[1]);
+ result[4] = resid / (doublereal) max(1,*p) / ulp;
+
+ return 0;
+
+/* End of ZGRQTS */
+
+} /* zgrqts_ */
diff --git a/TESTING/EIG/zgsvts.c b/TESTING/EIG/zgsvts.c
new file mode 100644
index 0000000..d97b3b6
--- /dev/null
+++ b/TESTING/EIG/zgsvts.c
@@ -0,0 +1,420 @@
+/* zgsvts.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static doublereal c_b36 = -1.;
+static doublereal c_b37 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int zgsvts_(integer *m, integer *p, integer *n,
+ doublecomplex *a, doublecomplex *af, integer *lda, doublecomplex *b,
+ doublecomplex *bf, integer *ldb, doublecomplex *u, integer *ldu,
+ doublecomplex *v, integer *ldv, doublecomplex *q, integer *ldq,
+ doublereal *alpha, doublereal *beta, doublecomplex *r__, integer *ldr,
+ integer *iwork, doublecomplex *work, integer *lwork, doublereal *
+ rwork, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1,
+ bf_offset, q_dim1, q_offset, r_dim1, r_offset, u_dim1, u_offset,
+ v_dim1, v_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1;
+ doublecomplex z__1, z__2;
+
+ /* Local variables */
+ integer i__, j, k, l;
+ doublereal ulp;
+ integer info;
+ doublereal unfl, temp, resid, anorm, bnorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), zgemm_(char *, char *, integer *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zherk_(char *, char *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *),
+ zlanhe_(char *, char *, integer *, doublecomplex *, integer *,
+ doublereal *);
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *), zggsvd_(
+ char *, char *, char *, integer *, integer *, integer *, integer *
+, integer *, doublecomplex *, integer *, doublecomplex *, integer
+ *, doublereal *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublereal *, integer *, integer *);
+ doublereal ulpinv;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGSVTS tests ZGGSVD, which computes the GSVD of an M-by-N matrix A */
+/* and a P-by-N matrix B: */
+/* U'*A*Q = D1*R and V'*B*Q = D2*R. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,M) */
+/* The M-by-N matrix A. */
+
+/* AF (output) COMPLEX*16 array, dimension (LDA,N) */
+/* Details of the GSVD of A and B, as returned by ZGGSVD, */
+/* see ZGGSVD for further details. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A and AF. */
+/* LDA >= max( 1,M ). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,P) */
+/* On entry, the P-by-N matrix B. */
+
+/* BF (output) COMPLEX*16 array, dimension (LDB,N) */
+/* Details of the GSVD of A and B, as returned by ZGGSVD, */
+/* see ZGGSVD for further details. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the arrays B and BF. */
+/* LDB >= max(1,P). */
+
+/* U (output) COMPLEX*16 array, dimension(LDU,M) */
+/* The M by M unitary matrix U. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M). */
+
+/* V (output) COMPLEX*16 array, dimension(LDV,M) */
+/* The P by P unitary matrix V. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of the array V. LDV >= max(1,P). */
+
+/* Q (output) COMPLEX*16 array, dimension(LDQ,N) */
+/* The N by N unitary matrix Q. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* ALPHA (output) DOUBLE PRECISION array, dimension (N) */
+/* BETA (output) DOUBLE PRECISION array, dimension (N) */
+/* The generalized singular value pairs of A and B, the */
+/* ``diagonal'' matrices D1 and D2 are constructed from */
+/* ALPHA and BETA, see subroutine ZGGSVD for details. */
+
+/* R (output) COMPLEX*16 array, dimension(LDQ,N) */
+/* The upper triangular matrix R. */
+
+/* LDR (input) INTEGER */
+/* The leading dimension of the array R. LDR >= max(1,N). */
+
+/* IWORK (workspace) INTEGER array, dimension (N) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK, */
+/* LWORK >= max(M,P,N)*max(M,P,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(M,P,N)) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (5) */
+/* The test ratios: */
+/* RESULT(1) = norm( U'*A*Q - D1*R ) / ( MAX(M,N)*norm(A)*ULP) */
+/* RESULT(2) = norm( V'*B*Q - D2*R ) / ( MAX(P,N)*norm(B)*ULP) */
+/* RESULT(3) = norm( I - U'*U ) / ( M*ULP ) */
+/* RESULT(4) = norm( I - V'*V ) / ( P*ULP ) */
+/* RESULT(5) = norm( I - Q'*Q ) / ( N*ULP ) */
+/* RESULT(6) = 0 if ALPHA is in decreasing order; */
+/* = ULPINV otherwise. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ bf_dim1 = *ldb;
+ bf_offset = 1 + bf_dim1;
+ bf -= bf_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --alpha;
+ --beta;
+ r_dim1 = *ldr;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ --iwork;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ ulp = dlamch_("Precision");
+ ulpinv = 1. / ulp;
+ unfl = dlamch_("Safe minimum");
+
+/* Copy the matrix A to the array AF. */
+
+ zlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+ zlacpy_("Full", p, n, &b[b_offset], ldb, &bf[bf_offset], ldb);
+
+/* Computing MAX */
+ d__1 = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ anorm = max(d__1,unfl);
+/* Computing MAX */
+ d__1 = zlange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
+ bnorm = max(d__1,unfl);
+
+/* Factorize the matrices A and B in the arrays AF and BF. */
+
+ zggsvd_("U", "V", "Q", m, n, p, &k, &l, &af[af_offset], lda, &bf[
+ bf_offset], ldb, &alpha[1], &beta[1], &u[u_offset], ldu, &v[
+ v_offset], ldv, &q[q_offset], ldq, &work[1], &rwork[1], &iwork[1],
+ &info);
+
+/* Copy R */
+
+/* Computing MIN */
+ i__2 = k + l;
+ i__1 = min(i__2,*m);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = k + l;
+ for (j = i__; j <= i__2; ++j) {
+ i__3 = i__ + j * r_dim1;
+ i__4 = i__ + (*n - k - l + j) * af_dim1;
+ r__[i__3].r = af[i__4].r, r__[i__3].i = af[i__4].i;
+/* L10: */
+ }
+/* L20: */
+ }
+
+ if (*m - k - l < 0) {
+ i__1 = k + l;
+ for (i__ = *m + 1; i__ <= i__1; ++i__) {
+ i__2 = k + l;
+ for (j = i__; j <= i__2; ++j) {
+ i__3 = i__ + j * r_dim1;
+ i__4 = i__ - k + (*n - k - l + j) * bf_dim1;
+ r__[i__3].r = bf[i__4].r, r__[i__3].i = bf[i__4].i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+/* Compute A:= U'*A*Q - D1*R */
+
+ zgemm_("No transpose", "No transpose", m, n, n, &c_b2, &a[a_offset], lda,
+ &q[q_offset], ldq, &c_b1, &work[1], lda);
+
+ zgemm_("Conjugate transpose", "No transpose", m, n, m, &c_b2, &u[u_offset]
+, ldu, &work[1], lda, &c_b1, &a[a_offset], lda);
+
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = k + l;
+ for (j = i__; j <= i__2; ++j) {
+ i__3 = i__ + (*n - k - l + j) * a_dim1;
+ i__4 = i__ + (*n - k - l + j) * a_dim1;
+ i__5 = i__ + j * r_dim1;
+ z__1.r = a[i__4].r - r__[i__5].r, z__1.i = a[i__4].i - r__[i__5]
+ .i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* Computing MIN */
+ i__2 = k + l;
+ i__1 = min(i__2,*m);
+ for (i__ = k + 1; i__ <= i__1; ++i__) {
+ i__2 = k + l;
+ for (j = i__; j <= i__2; ++j) {
+ i__3 = i__ + (*n - k - l + j) * a_dim1;
+ i__4 = i__ + (*n - k - l + j) * a_dim1;
+ i__5 = i__;
+ i__6 = i__ + j * r_dim1;
+ z__2.r = alpha[i__5] * r__[i__6].r, z__2.i = alpha[i__5] * r__[
+ i__6].i;
+ z__1.r = a[i__4].r - z__2.r, z__1.i = a[i__4].i - z__2.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+
+/* Compute norm( U'*A*Q - D1*R ) / ( MAX(1,M,N)*norm(A)*ULP ) . */
+
+ resid = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ if (anorm > 0.) {
+/* Computing MAX */
+ i__1 = max(1,*m);
+ result[1] = resid / (doublereal) max(i__1,*n) / anorm / ulp;
+ } else {
+ result[1] = 0.;
+ }
+
+/* Compute B := V'*B*Q - D2*R */
+
+ zgemm_("No transpose", "No transpose", p, n, n, &c_b2, &b[b_offset], ldb,
+ &q[q_offset], ldq, &c_b1, &work[1], ldb);
+
+ zgemm_("Conjugate transpose", "No transpose", p, n, p, &c_b2, &v[v_offset]
+, ldv, &work[1], ldb, &c_b1, &b[b_offset], ldb);
+
+ i__1 = l;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = l;
+ for (j = i__; j <= i__2; ++j) {
+ i__3 = i__ + (*n - l + j) * b_dim1;
+ i__4 = i__ + (*n - l + j) * b_dim1;
+ i__5 = k + i__;
+ i__6 = k + i__ + (k + j) * r_dim1;
+ z__2.r = beta[i__5] * r__[i__6].r, z__2.i = beta[i__5] * r__[i__6]
+ .i;
+ z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4].i - z__2.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L90: */
+ }
+/* L100: */
+ }
+
+/* Compute norm( V'*B*Q - D2*R ) / ( MAX(P,N)*norm(B)*ULP ) . */
+
+ resid = zlange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
+ if (bnorm > 0.) {
+/* Computing MAX */
+ i__1 = max(1,*p);
+ result[2] = resid / (doublereal) max(i__1,*n) / bnorm / ulp;
+ } else {
+ result[2] = 0.;
+ }
+
+/* Compute I - U'*U */
+
+ zlaset_("Full", m, m, &c_b1, &c_b2, &work[1], ldq);
+ zherk_("Upper", "Conjugate transpose", m, m, &c_b36, &u[u_offset], ldu, &
+ c_b37, &work[1], ldu);
+
+/* Compute norm( I - U'*U ) / ( M * ULP ) . */
+
+ resid = zlanhe_("1", "Upper", m, &work[1], ldu, &rwork[1]);
+ result[3] = resid / (doublereal) max(1,*m) / ulp;
+
+/* Compute I - V'*V */
+
+ zlaset_("Full", p, p, &c_b1, &c_b2, &work[1], ldv);
+ zherk_("Upper", "Conjugate transpose", p, p, &c_b36, &v[v_offset], ldv, &
+ c_b37, &work[1], ldv);
+
+/* Compute norm( I - V'*V ) / ( P * ULP ) . */
+
+ resid = zlanhe_("1", "Upper", p, &work[1], ldv, &rwork[1]);
+ result[4] = resid / (doublereal) max(1,*p) / ulp;
+
+/* Compute I - Q'*Q */
+
+ zlaset_("Full", n, n, &c_b1, &c_b2, &work[1], ldq);
+ zherk_("Upper", "Conjugate transpose", n, n, &c_b36, &q[q_offset], ldq, &
+ c_b37, &work[1], ldq);
+
+/* Compute norm( I - Q'*Q ) / ( N * ULP ) . */
+
+ resid = zlanhe_("1", "Upper", n, &work[1], ldq, &rwork[1]);
+ result[5] = resid / (doublereal) max(1,*n) / ulp;
+
+/* Check sorting */
+
+ dcopy_(n, &alpha[1], &c__1, &rwork[1], &c__1);
+/* Computing MIN */
+ i__2 = k + l;
+ i__1 = min(i__2,*m);
+ for (i__ = k + 1; i__ <= i__1; ++i__) {
+ j = iwork[i__];
+ if (i__ != j) {
+ temp = rwork[i__];
+ rwork[i__] = rwork[j];
+ rwork[j] = temp;
+ }
+/* L110: */
+ }
+
+ result[6] = 0.;
+/* Computing MIN */
+ i__2 = k + l;
+ i__1 = min(i__2,*m) - 1;
+ for (i__ = k + 1; i__ <= i__1; ++i__) {
+ if (rwork[i__] < rwork[i__ + 1]) {
+ result[6] = ulpinv;
+ }
+/* L120: */
+ }
+
+ return 0;
+
+/* End of ZGSVTS */
+
+} /* zgsvts_ */
diff --git a/TESTING/EIG/zhbt21.c b/TESTING/EIG/zhbt21.c
new file mode 100644
index 0000000..9134c7a
--- /dev/null
+++ b/TESTING/EIG/zhbt21.c
@@ -0,0 +1,306 @@
+/* zhbt21.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zhbt21_(char *uplo, integer *n, integer *ka, integer *ks,
+ doublecomplex *a, integer *lda, doublereal *d__, doublereal *e,
+ doublecomplex *u, integer *ldu, doublecomplex *work, doublereal *
+ rwork, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2;
+
+ /* Local variables */
+ integer j, jc, jr, ika;
+ doublereal ulp, unfl;
+ extern /* Subroutine */ int zhpr_(char *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *), zhpr2_(char
+ *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *);
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ char cuplo[1];
+ logical lower;
+ doublereal wnorm;
+ extern doublereal dlamch_(char *), zlanhb_(char *, char *,
+ integer *, integer *, doublecomplex *, integer *, doublereal *), zlange_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *), zlanhp_(char *,
+ char *, integer *, doublecomplex *, doublereal *)
+ ;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHBT21 generally checks a decomposition of the form */
+
+/* A = U S U* */
+
+/* where * means conjugate transpose, A is hermitian banded, U is */
+/* unitary, and S is diagonal (if KS=0) or symmetric */
+/* tridiagonal (if KS=1). */
+
+/* Specifically: */
+
+/* RESULT(1) = | A - U S U* | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU* | / ( n ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER */
+/* If UPLO='U', the upper triangle of A and V will be used and */
+/* the (strictly) lower triangle will not be referenced. */
+/* If UPLO='L', the lower triangle of A and V will be used and */
+/* the (strictly) upper triangle will not be referenced. */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, ZHBT21 does nothing. */
+/* It must be at least zero. */
+
+/* KA (input) INTEGER */
+/* The bandwidth of the matrix A. It must be at least zero. If */
+/* it is larger than N-1, then max( 0, N-1 ) will be used. */
+
+/* KS (input) INTEGER */
+/* The bandwidth of the matrix S. It may only be zero or one. */
+/* If zero, then S is diagonal, and E is not referenced. If */
+/* one, then S is symmetric tri-diagonal. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA, N) */
+/* The original (unfactored) matrix. It is assumed to be */
+/* hermitian, and only the upper (UPLO='U') or only the lower */
+/* (UPLO='L') will be referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least min( KA, N-1 ). */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal of the (symmetric tri-) diagonal matrix S. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The off-diagonal of the (symmetric tri-) diagonal matrix S. */
+/* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and */
+/* (3,2) element, etc. */
+/* Not referenced if KS=0. */
+
+/* U (input) COMPLEX*16 array, dimension (LDU, N) */
+/* The unitary matrix in the decomposition, expressed as a */
+/* dense matrix (i.e., not as a product of Householder */
+/* transformations, Givens transformations, etc.) */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N**2) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Constants */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.;
+ result[2] = 0.;
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Computing MAX */
+/* Computing MIN */
+ i__3 = *n - 1;
+ i__1 = 0, i__2 = min(i__3,*ka);
+ ika = max(i__1,i__2);
+
+ if (lsame_(uplo, "U")) {
+ lower = FALSE_;
+ *(unsigned char *)cuplo = 'U';
+ } else {
+ lower = TRUE_;
+ *(unsigned char *)cuplo = 'L';
+ }
+
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+
+/* Some Error Checks */
+
+/* Do Test 1 */
+
+/* Norm of A: */
+
+/* Computing MAX */
+ d__1 = zlanhb_("1", cuplo, n, &ika, &a[a_offset], lda, &rwork[1]);
+ anorm = max(d__1,unfl);
+
+/* Compute error matrix: Error = A - U S U* */
+
+/* Copy A from SB to SP storage format. */
+
+ j = 0;
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ if (lower) {
+/* Computing MIN */
+ i__3 = ika + 1, i__4 = *n + 1 - jc;
+ i__2 = min(i__3,i__4);
+ for (jr = 1; jr <= i__2; ++jr) {
+ ++j;
+ i__3 = j;
+ i__4 = jr + jc * a_dim1;
+ work[i__3].r = a[i__4].r, work[i__3].i = a[i__4].i;
+/* L10: */
+ }
+ i__2 = *n + 1 - jc;
+ for (jr = ika + 2; jr <= i__2; ++jr) {
+ ++j;
+ i__3 = j;
+ work[i__3].r = 0., work[i__3].i = 0.;
+/* L20: */
+ }
+ } else {
+ i__2 = jc;
+ for (jr = ika + 2; jr <= i__2; ++jr) {
+ ++j;
+ i__3 = j;
+ work[i__3].r = 0., work[i__3].i = 0.;
+/* L30: */
+ }
+/* Computing MIN */
+ i__2 = ika, i__3 = jc - 1;
+ for (jr = min(i__2,i__3); jr >= 0; --jr) {
+ ++j;
+ i__2 = j;
+ i__3 = ika + 1 - jr + jc * a_dim1;
+ work[i__2].r = a[i__3].r, work[i__2].i = a[i__3].i;
+/* L40: */
+ }
+ }
+/* L50: */
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ d__1 = -d__[j];
+ zhpr_(cuplo, n, &d__1, &u[j * u_dim1 + 1], &c__1, &work[1])
+ ;
+/* L60: */
+ }
+
+ if (*n > 1 && *ks == 1) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ z__2.r = e[i__2], z__2.i = 0.;
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ zhpr2_(cuplo, n, &z__1, &u[j * u_dim1 + 1], &c__1, &u[(j + 1) *
+ u_dim1 + 1], &c__1, &work[1]);
+/* L70: */
+ }
+ }
+ wnorm = zlanhp_("1", cuplo, n, &work[1], &rwork[1]);
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.) {
+/* Computing MIN */
+ d__1 = wnorm, d__2 = *n * anorm;
+ result[1] = min(d__1,d__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
+ result[1] = min(d__1,d__2) / (*n * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute UU* - I */
+
+ zgemm_("N", "C", n, n, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu, &
+ c_b1, &work[1], n);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (*n + 1) * (j - 1) + 1;
+ i__3 = (*n + 1) * (j - 1) + 1;
+ z__1.r = work[i__3].r - 1., z__1.i = work[i__3].i - 0.;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L80: */
+ }
+
+/* Computing MIN */
+ d__1 = zlange_("1", n, n, &work[1], n, &rwork[1]), d__2 = (
+ doublereal) (*n);
+ result[2] = min(d__1,d__2) / (*n * ulp);
+
+ return 0;
+
+/* End of ZHBT21 */
+
+} /* zhbt21_ */
diff --git a/TESTING/EIG/zhet21.c b/TESTING/EIG/zhet21.c
new file mode 100644
index 0000000..343e23d
--- /dev/null
+++ b/TESTING/EIG/zhet21.c
@@ -0,0 +1,513 @@
+/* zhet21.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zhet21_(integer *itype, char *uplo, integer *n, integer *
+ kband, doublecomplex *a, integer *lda, doublereal *d__, doublereal *e,
+ doublecomplex *u, integer *ldu, doublecomplex *v, integer *ldv,
+ doublecomplex *tau, doublecomplex *work, doublereal *rwork,
+ doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2,
+ i__3, i__4, i__5, i__6;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Local variables */
+ integer j, jr;
+ doublereal ulp;
+ integer jcol;
+ doublereal unfl;
+ extern /* Subroutine */ int zher_(char *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ integer jrow;
+ extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ doublereal anorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ char cuplo[1];
+ doublecomplex vsave;
+ logical lower;
+ doublereal wnorm;
+ extern /* Subroutine */ int zunm2l_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *), zlanhe_(char *, char *, integer
+ *, doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *), zlarfy_(
+ char *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHET21 generally checks a decomposition of the form */
+
+/* A = U S U* */
+
+/* where * means conjugate transpose, A is hermitian, U is unitary, and */
+/* S is diagonal (if KBAND=0) or (real) symmetric tridiagonal (if */
+/* KBAND=1). */
+
+/* If ITYPE=1, then U is represented as a dense matrix; otherwise U is */
+/* expressed as a product of Householder transformations, whose vectors */
+/* are stored in the array "V" and whose scaling constants are in "TAU". */
+/* We shall use the letter "V" to refer to the product of Householder */
+/* transformations (which should be equal to U). */
+
+/* Specifically, if ITYPE=1, then: */
+
+/* RESULT(1) = | A - U S U* | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU* | / ( n ulp ) */
+
+/* If ITYPE=2, then: */
+
+/* RESULT(1) = | A - V S V* | / ( |A| n ulp ) */
+
+/* If ITYPE=3, then: */
+
+/* RESULT(1) = | I - UV* | / ( n ulp ) */
+
+/* For ITYPE > 1, the transformation U is expressed as a product */
+/* V = H(1)...H(n-2), where H(j) = I - tau(j) v(j) v(j)* and each */
+/* vector v(j) has its first j elements 0 and the remaining n-j elements */
+/* stored in V(j+1:n,j). */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the type of tests to be performed. */
+/* 1: U expressed as a dense unitary matrix: */
+/* RESULT(1) = | A - U S U* | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU* | / ( n ulp ) */
+
+/* 2: U expressed as a product V of Housholder transformations: */
+/* RESULT(1) = | A - V S V* | / ( |A| n ulp ) */
+
+/* 3: U expressed both as a dense unitary matrix and */
+/* as a product of Housholder transformations: */
+/* RESULT(1) = | I - UV* | / ( n ulp ) */
+
+/* UPLO (input) CHARACTER */
+/* If UPLO='U', the upper triangle of A and V will be used and */
+/* the (strictly) lower triangle will not be referenced. */
+/* If UPLO='L', the lower triangle of A and V will be used and */
+/* the (strictly) upper triangle will not be referenced. */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, ZHET21 does nothing. */
+/* It must be at least zero. */
+
+/* KBAND (input) INTEGER */
+/* The bandwidth of the matrix. It may only be zero or one. */
+/* If zero, then S is diagonal, and E is not referenced. If */
+/* one, then S is symmetric tri-diagonal. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA, N) */
+/* The original (unfactored) matrix. It is assumed to be */
+/* hermitian, and only the upper (UPLO='U') or only the lower */
+/* (UPLO='L') will be referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least N. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal of the (symmetric tri-) diagonal matrix. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The off-diagonal of the (symmetric tri-) diagonal matrix. */
+/* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and */
+/* (3,2) element, etc. */
+/* Not referenced if KBAND=0. */
+
+/* U (input) COMPLEX*16 array, dimension (LDU, N) */
+/* If ITYPE=1 or 3, this contains the unitary matrix in */
+/* the decomposition, expressed as a dense matrix. If ITYPE=2, */
+/* then it is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+
+/* V (input) COMPLEX*16 array, dimension (LDV, N) */
+/* If ITYPE=2 or 3, the columns of this array contain the */
+/* Householder vectors used to describe the unitary matrix */
+/* in the decomposition. If UPLO='L', then the vectors are in */
+/* the lower triangle, if UPLO='U', then in the upper */
+/* triangle. */
+/* *NOTE* If ITYPE=2 or 3, V is modified and restored. The */
+/* subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U') */
+/* is set to one, and later reset to its original value, during */
+/* the course of the calculation. */
+/* If ITYPE=1, then it is neither referenced nor modified. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of V. LDV must be at least N and */
+/* at least 1. */
+
+/* TAU (input) COMPLEX*16 array, dimension (N) */
+/* If ITYPE >= 2, then TAU(j) is the scalar factor of */
+/* v(j) v(j)* in the Householder transformation H(j) of */
+/* the product U = H(1)...H(n-2) */
+/* If ITYPE < 2, then TAU is not referenced. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N**2) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+/* RESULT(1) is always modified. RESULT(2) is modified only */
+/* if ITYPE=1. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.;
+ if (*itype == 1) {
+ result[2] = 0.;
+ }
+ if (*n <= 0) {
+ return 0;
+ }
+
+ if (lsame_(uplo, "U")) {
+ lower = FALSE_;
+ *(unsigned char *)cuplo = 'U';
+ } else {
+ lower = TRUE_;
+ *(unsigned char *)cuplo = 'L';
+ }
+
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+
+/* Some Error Checks */
+
+ if (*itype < 1 || *itype > 3) {
+ result[1] = 10. / ulp;
+ return 0;
+ }
+
+/* Do Test 1 */
+
+/* Norm of A: */
+
+ if (*itype == 3) {
+ anorm = 1.;
+ } else {
+/* Computing MAX */
+ d__1 = zlanhe_("1", cuplo, n, &a[a_offset], lda, &rwork[1]);
+ anorm = max(d__1,unfl);
+ }
+
+/* Compute error matrix: */
+
+ if (*itype == 1) {
+
+/* ITYPE=1: error = A - U S U* */
+
+ zlaset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
+ zlacpy_(cuplo, n, n, &a[a_offset], lda, &work[1], n);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ d__1 = -d__[j];
+ zher_(cuplo, n, &d__1, &u[j * u_dim1 + 1], &c__1, &work[1], n);
+/* L10: */
+ }
+
+ if (*n > 1 && *kband == 1) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ z__2.r = e[i__2], z__2.i = 0.;
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ zher2_(cuplo, n, &z__1, &u[j * u_dim1 + 1], &c__1, &u[(j - 1)
+ * u_dim1 + 1], &c__1, &work[1], n);
+/* L20: */
+ }
+ }
+ wnorm = zlanhe_("1", cuplo, n, &work[1], n, &rwork[1]);
+
+ } else if (*itype == 2) {
+
+/* ITYPE=2: error = V S V* - A */
+
+ zlaset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
+
+ if (lower) {
+/* Computing 2nd power */
+ i__2 = *n;
+ i__1 = i__2 * i__2;
+ i__3 = *n;
+ work[i__1].r = d__[i__3], work[i__1].i = 0.;
+ for (j = *n - 1; j >= 1; --j) {
+ if (*kband == 1) {
+ i__1 = (*n + 1) * (j - 1) + 2;
+ i__2 = j;
+ z__2.r = 1. - tau[i__2].r, z__2.i = 0. - tau[i__2].i;
+ i__3 = j;
+ z__1.r = e[i__3] * z__2.r, z__1.i = e[i__3] * z__2.i;
+ work[i__1].r = z__1.r, work[i__1].i = z__1.i;
+ i__1 = *n;
+ for (jr = j + 2; jr <= i__1; ++jr) {
+ i__2 = (j - 1) * *n + jr;
+ i__3 = j;
+ z__3.r = -tau[i__3].r, z__3.i = -tau[i__3].i;
+ i__4 = j;
+ z__2.r = e[i__4] * z__3.r, z__2.i = e[i__4] * z__3.i;
+ i__5 = jr + j * v_dim1;
+ z__1.r = z__2.r * v[i__5].r - z__2.i * v[i__5].i,
+ z__1.i = z__2.r * v[i__5].i + z__2.i * v[i__5]
+ .r;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L30: */
+ }
+ }
+
+ i__1 = j + 1 + j * v_dim1;
+ vsave.r = v[i__1].r, vsave.i = v[i__1].i;
+ i__1 = j + 1 + j * v_dim1;
+ v[i__1].r = 1., v[i__1].i = 0.;
+ i__1 = *n - j;
+/* Computing 2nd power */
+ i__2 = *n;
+ zlarfy_("L", &i__1, &v[j + 1 + j * v_dim1], &c__1, &tau[j], &
+ work[(*n + 1) * j + 1], n, &work[i__2 * i__2 + 1]);
+ i__1 = j + 1 + j * v_dim1;
+ v[i__1].r = vsave.r, v[i__1].i = vsave.i;
+ i__1 = (*n + 1) * (j - 1) + 1;
+ i__2 = j;
+ work[i__1].r = d__[i__2], work[i__1].i = 0.;
+/* L40: */
+ }
+ } else {
+ work[1].r = d__[1], work[1].i = 0.;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ if (*kband == 1) {
+ i__2 = (*n + 1) * j;
+ i__3 = j;
+ z__2.r = 1. - tau[i__3].r, z__2.i = 0. - tau[i__3].i;
+ i__4 = j;
+ z__1.r = e[i__4] * z__2.r, z__1.i = e[i__4] * z__2.i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ i__2 = j - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = j * *n + jr;
+ i__4 = j;
+ z__3.r = -tau[i__4].r, z__3.i = -tau[i__4].i;
+ i__5 = j;
+ z__2.r = e[i__5] * z__3.r, z__2.i = e[i__5] * z__3.i;
+ i__6 = jr + (j + 1) * v_dim1;
+ z__1.r = z__2.r * v[i__6].r - z__2.i * v[i__6].i,
+ z__1.i = z__2.r * v[i__6].i + z__2.i * v[i__6]
+ .r;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L50: */
+ }
+ }
+
+ i__2 = j + (j + 1) * v_dim1;
+ vsave.r = v[i__2].r, vsave.i = v[i__2].i;
+ i__2 = j + (j + 1) * v_dim1;
+ v[i__2].r = 1., v[i__2].i = 0.;
+/* Computing 2nd power */
+ i__2 = *n;
+ zlarfy_("U", &j, &v[(j + 1) * v_dim1 + 1], &c__1, &tau[j], &
+ work[1], n, &work[i__2 * i__2 + 1]);
+ i__2 = j + (j + 1) * v_dim1;
+ v[i__2].r = vsave.r, v[i__2].i = vsave.i;
+ i__2 = (*n + 1) * j + 1;
+ i__3 = j + 1;
+ work[i__2].r = d__[i__3], work[i__2].i = 0.;
+/* L60: */
+ }
+ }
+
+ i__1 = *n;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ if (lower) {
+ i__2 = *n;
+ for (jrow = jcol; jrow <= i__2; ++jrow) {
+ i__3 = jrow + *n * (jcol - 1);
+ i__4 = jrow + *n * (jcol - 1);
+ i__5 = jrow + jcol * a_dim1;
+ z__1.r = work[i__4].r - a[i__5].r, z__1.i = work[i__4].i
+ - a[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L70: */
+ }
+ } else {
+ i__2 = jcol;
+ for (jrow = 1; jrow <= i__2; ++jrow) {
+ i__3 = jrow + *n * (jcol - 1);
+ i__4 = jrow + *n * (jcol - 1);
+ i__5 = jrow + jcol * a_dim1;
+ z__1.r = work[i__4].r - a[i__5].r, z__1.i = work[i__4].i
+ - a[i__5].i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L80: */
+ }
+ }
+/* L90: */
+ }
+ wnorm = zlanhe_("1", cuplo, n, &work[1], n, &rwork[1]);
+
+ } else if (*itype == 3) {
+
+/* ITYPE=3: error = U V* - I */
+
+ if (*n < 2) {
+ return 0;
+ }
+ zlacpy_(" ", n, n, &u[u_offset], ldu, &work[1], n);
+ if (lower) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+/* Computing 2nd power */
+ i__3 = *n;
+ zunm2r_("R", "C", n, &i__1, &i__2, &v[v_dim1 + 2], ldv, &tau[1], &
+ work[*n + 1], n, &work[i__3 * i__3 + 1], &iinfo);
+ } else {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+/* Computing 2nd power */
+ i__3 = *n;
+ zunm2l_("R", "C", n, &i__1, &i__2, &v[(v_dim1 << 1) + 1], ldv, &
+ tau[1], &work[1], n, &work[i__3 * i__3 + 1], &iinfo);
+ }
+ if (iinfo != 0) {
+ result[1] = 10. / ulp;
+ return 0;
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (*n + 1) * (j - 1) + 1;
+ i__3 = (*n + 1) * (j - 1) + 1;
+ z__1.r = work[i__3].r - 1., z__1.i = work[i__3].i - 0.;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L100: */
+ }
+
+ wnorm = zlange_("1", n, n, &work[1], n, &rwork[1]);
+ }
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.) {
+/* Computing MIN */
+ d__1 = wnorm, d__2 = *n * anorm;
+ result[1] = min(d__1,d__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
+ result[1] = min(d__1,d__2) / (*n * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute UU* - I */
+
+ if (*itype == 1) {
+ zgemm_("N", "C", n, n, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu,
+ &c_b1, &work[1], n);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (*n + 1) * (j - 1) + 1;
+ i__3 = (*n + 1) * (j - 1) + 1;
+ z__1.r = work[i__3].r - 1., z__1.i = work[i__3].i - 0.;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L110: */
+ }
+
+/* Computing MIN */
+ d__1 = zlange_("1", n, n, &work[1], n, &rwork[1]), d__2 = (
+ doublereal) (*n);
+ result[2] = min(d__1,d__2) / (*n * ulp);
+ }
+
+ return 0;
+
+/* End of ZHET21 */
+
+} /* zhet21_ */
diff --git a/TESTING/EIG/zhet22.c b/TESTING/EIG/zhet22.c
new file mode 100644
index 0000000..4c89f13
--- /dev/null
+++ b/TESTING/EIG/zhet22.c
@@ -0,0 +1,296 @@
+/* zhet22.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+
+/* Subroutine */ int zhet22_(integer *itype, char *uplo, integer *n, integer *
+ m, integer *kband, doublecomplex *a, integer *lda, doublereal *d__,
+ doublereal *e, doublecomplex *u, integer *ldu, doublecomplex *v,
+ integer *ldv, doublecomplex *tau, doublecomplex *work, doublereal *
+ rwork, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2,
+ i__3, i__4;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer j, jj, nn, jj1, jj2;
+ doublereal ulp;
+ integer nnp1;
+ doublereal unfl, anorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zhemm_(char *, char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zunt01_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+ doublereal wnorm;
+ extern doublereal dlamch_(char *), zlanhe_(char *, char *,
+ integer *, doublecomplex *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHET22 generally checks a decomposition of the form */
+
+/* A U = U S */
+
+/* where A is complex Hermitian, the columns of U are orthonormal, */
+/* and S is diagonal (if KBAND=0) or symmetric tridiagonal (if */
+/* KBAND=1). If ITYPE=1, then U is represented as a dense matrix, */
+/* otherwise the U is expressed as a product of Householder */
+/* transformations, whose vectors are stored in the array "V" and */
+/* whose scaling constants are in "TAU"; we shall use the letter */
+/* "V" to refer to the product of Householder transformations */
+/* (which should be equal to U). */
+
+/* Specifically, if ITYPE=1, then: */
+
+/* RESULT(1) = | U' A U - S | / ( |A| m ulp ) *and* */
+/* RESULT(2) = | I - U'U | / ( m ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE INTEGER */
+/* Specifies the type of tests to be performed. */
+/* 1: U expressed as a dense orthogonal matrix: */
+/* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU' | / ( n ulp ) */
+
+/* UPLO CHARACTER */
+/* If UPLO='U', the upper triangle of A will be used and the */
+/* (strictly) lower triangle will not be referenced. If */
+/* UPLO='L', the lower triangle of A will be used and the */
+/* (strictly) upper triangle will not be referenced. */
+/* Not modified. */
+
+/* N INTEGER */
+/* The size of the matrix. If it is zero, ZHET22 does nothing. */
+/* It must be at least zero. */
+/* Not modified. */
+
+/* M INTEGER */
+/* The number of columns of U. If it is zero, ZHET22 does */
+/* nothing. It must be at least zero. */
+/* Not modified. */
+
+/* KBAND INTEGER */
+/* The bandwidth of the matrix. It may only be zero or one. */
+/* If zero, then S is diagonal, and E is not referenced. If */
+/* one, then S is symmetric tri-diagonal. */
+/* Not modified. */
+
+/* A COMPLEX*16 array, dimension (LDA , N) */
+/* The original (unfactored) matrix. It is assumed to be */
+/* symmetric, and only the upper (UPLO='U') or only the lower */
+/* (UPLO='L') will be referenced. */
+/* Not modified. */
+
+/* LDA INTEGER */
+/* The leading dimension of A. It must be at least 1 */
+/* and at least N. */
+/* Not modified. */
+
+/* D DOUBLE PRECISION array, dimension (N) */
+/* The diagonal of the (symmetric tri-) diagonal matrix. */
+/* Not modified. */
+
+/* E DOUBLE PRECISION array, dimension (N) */
+/* The off-diagonal of the (symmetric tri-) diagonal matrix. */
+/* E(1) is ignored, E(2) is the (1,2) and (2,1) element, etc. */
+/* Not referenced if KBAND=0. */
+/* Not modified. */
+
+/* U COMPLEX*16 array, dimension (LDU, N) */
+/* If ITYPE=1, this contains the orthogonal matrix in */
+/* the decomposition, expressed as a dense matrix. */
+/* Not modified. */
+
+/* LDU INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+/* Not modified. */
+
+/* V COMPLEX*16 array, dimension (LDV, N) */
+/* If ITYPE=2 or 3, the lower triangle of this array contains */
+/* the Householder vectors used to describe the orthogonal */
+/* matrix in the decomposition. If ITYPE=1, then it is not */
+/* referenced. */
+/* Not modified. */
+
+/* LDV INTEGER */
+/* The leading dimension of V. LDV must be at least N and */
+/* at least 1. */
+/* Not modified. */
+
+/* TAU COMPLEX*16 array, dimension (N) */
+/* If ITYPE >= 2, then TAU(j) is the scalar factor of */
+/* v(j) v(j)' in the Householder transformation H(j) of */
+/* the product U = H(1)...H(n-2) */
+/* If ITYPE < 2, then TAU is not referenced. */
+/* Not modified. */
+
+/* WORK COMPLEX*16 array, dimension (2*N**2) */
+/* Workspace. */
+/* Modified. */
+
+/* RWORK DOUBLE PRECISION array, dimension (N) */
+/* Workspace. */
+/* Modified. */
+
+/* RESULT DOUBLE PRECISION array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+/* RESULT(1) is always modified. RESULT(2) is modified only */
+/* if LDU is at least N. */
+/* Modified. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.;
+ result[2] = 0.;
+ if (*n <= 0 || *m <= 0) {
+ return 0;
+ }
+
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Precision");
+
+/* Do Test 1 */
+
+/* Norm of A: */
+
+/* Computing MAX */
+ d__1 = zlanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+ anorm = max(d__1,unfl);
+
+/* Compute error matrix: */
+
+/* ITYPE=1: error = U' A U - S */
+
+ zhemm_("L", uplo, n, m, &c_b2, &a[a_offset], lda, &u[u_offset], ldu, &
+ c_b1, &work[1], n);
+ nn = *n * *n;
+ nnp1 = nn + 1;
+ zgemm_("C", "N", m, m, n, &c_b2, &u[u_offset], ldu, &work[1], n, &c_b1, &
+ work[nnp1], n);
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ jj = nn + (j - 1) * *n + j;
+ i__2 = jj;
+ i__3 = jj;
+ i__4 = j;
+ z__1.r = work[i__3].r - d__[i__4], z__1.i = work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L10: */
+ }
+ if (*kband == 1 && *n > 1) {
+ i__1 = *m;
+ for (j = 2; j <= i__1; ++j) {
+ jj1 = nn + (j - 1) * *n + j - 1;
+ jj2 = nn + (j - 2) * *n + j;
+ i__2 = jj1;
+ i__3 = jj1;
+ i__4 = j - 1;
+ z__1.r = work[i__3].r - e[i__4], z__1.i = work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ i__2 = jj2;
+ i__3 = jj2;
+ i__4 = j - 1;
+ z__1.r = work[i__3].r - e[i__4], z__1.i = work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L20: */
+ }
+ }
+ wnorm = zlanhe_("1", uplo, m, &work[nnp1], n, &rwork[1]);
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*m * ulp);
+ } else {
+ if (anorm < 1.) {
+/* Computing MIN */
+ d__1 = wnorm, d__2 = *m * anorm;
+ result[1] = min(d__1,d__2) / anorm / (*m * ulp);
+ } else {
+/* Computing MIN */
+ d__1 = wnorm / anorm, d__2 = (doublereal) (*m);
+ result[1] = min(d__1,d__2) / (*m * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute U'U - I */
+
+ if (*itype == 1) {
+ i__1 = (*n << 1) * *n;
+ zunt01_("Columns", n, m, &u[u_offset], ldu, &work[1], &i__1, &rwork[1]
+, &result[2]);
+ }
+
+ return 0;
+
+/* End of ZHET22 */
+
+} /* zhet22_ */
diff --git a/TESTING/EIG/zhpt21.c b/TESTING/EIG/zhpt21.c
new file mode 100644
index 0000000..a234c38
--- /dev/null
+++ b/TESTING/EIG/zhpt21.c
@@ -0,0 +1,537 @@
+/* zhpt21.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zhpt21_(integer *itype, char *uplo, integer *n, integer *
+ kband, doublecomplex *ap, doublereal *d__, doublereal *e,
+ doublecomplex *u, integer *ldu, doublecomplex *vp, doublecomplex *tau,
+ doublecomplex *work, doublereal *rwork, doublereal *result)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Local variables */
+ integer j, jp, jr, jp1, lap;
+ doublereal ulp, unfl;
+ doublecomplex temp;
+ extern /* Subroutine */ int zhpr_(char *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *), zhpr2_(char
+ *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *);
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ doublereal anorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ char cuplo[1];
+ doublecomplex vsave;
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ logical lower;
+ doublereal wnorm;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zhpmv_(char *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *), zaxpy_(
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *),
+ zlanhp_(char *, char *, integer *, doublecomplex *, doublereal *);
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *), zupmtr_(
+ char *, char *, char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHPT21 generally checks a decomposition of the form */
+
+/* A = U S U* */
+
+/* where * means conjugate transpose, A is hermitian, U is */
+/* unitary, and S is diagonal (if KBAND=0) or (real) symmetric */
+/* tridiagonal (if KBAND=1). If ITYPE=1, then U is represented as */
+/* a dense matrix, otherwise the U is expressed as a product of */
+/* Householder transformations, whose vectors are stored in the */
+/* array "V" and whose scaling constants are in "TAU"; we shall */
+/* use the letter "V" to refer to the product of Householder */
+/* transformations (which should be equal to U). */
+
+/* Specifically, if ITYPE=1, then: */
+
+/* RESULT(1) = | A - U S U* | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU* | / ( n ulp ) */
+
+/* If ITYPE=2, then: */
+
+/* RESULT(1) = | A - V S V* | / ( |A| n ulp ) */
+
+/* If ITYPE=3, then: */
+
+/* RESULT(1) = | I - UV* | / ( n ulp ) */
+
+/* Packed storage means that, for example, if UPLO='U', then the columns */
+/* of the upper triangle of A are stored one after another, so that */
+/* A(1,j+1) immediately follows A(j,j) in the array AP. Similarly, if */
+/* UPLO='L', then the columns of the lower triangle of A are stored one */
+/* after another in AP, so that A(j+1,j+1) immediately follows A(n,j) */
+/* in the array AP. This means that A(i,j) is stored in: */
+
+/* AP( i + j*(j-1)/2 ) if UPLO='U' */
+
+/* AP( i + (2*n-j)*(j-1)/2 ) if UPLO='L' */
+
+/* The array VP bears the same relation to the matrix V that A does to */
+/* AP. */
+
+/* For ITYPE > 1, the transformation U is expressed as a product */
+/* of Householder transformations: */
+
+/* If UPLO='U', then V = H(n-1)...H(1), where */
+
+/* H(j) = I - tau(j) v(j) v(j)* */
+
+/* and the first j-1 elements of v(j) are stored in V(1:j-1,j+1), */
+/* (i.e., VP( j*(j+1)/2 + 1 : j*(j+1)/2 + j-1 ) ), */
+/* the j-th element is 1, and the last n-j elements are 0. */
+
+/* If UPLO='L', then V = H(1)...H(n-1), where */
+
+/* H(j) = I - tau(j) v(j) v(j)* */
+
+/* and the first j elements of v(j) are 0, the (j+1)-st is 1, and the */
+/* (j+2)-nd through n-th elements are stored in V(j+2:n,j) (i.e., */
+/* in VP( (2*n-j)*(j-1)/2 + j+2 : (2*n-j)*(j-1)/2 + n ) .) */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* Specifies the type of tests to be performed. */
+/* 1: U expressed as a dense unitary matrix: */
+/* RESULT(1) = | A - U S U* | / ( |A| n ulp ) *and* */
+/* RESULT(2) = | I - UU* | / ( n ulp ) */
+
+/* 2: U expressed as a product V of Housholder transformations: */
+/* RESULT(1) = | A - V S V* | / ( |A| n ulp ) */
+
+/* 3: U expressed both as a dense unitary matrix and */
+/* as a product of Housholder transformations: */
+/* RESULT(1) = | I - UV* | / ( n ulp ) */
+
+/* UPLO (input) CHARACTER */
+/* If UPLO='U', the upper triangle of A and V will be used and */
+/* the (strictly) lower triangle will not be referenced. */
+/* If UPLO='L', the lower triangle of A and V will be used and */
+/* the (strictly) upper triangle will not be referenced. */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, ZHPT21 does nothing. */
+/* It must be at least zero. */
+
+/* KBAND (input) INTEGER */
+/* The bandwidth of the matrix. It may only be zero or one. */
+/* If zero, then S is diagonal, and E is not referenced. If */
+/* one, then S is symmetric tri-diagonal. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The original (unfactored) matrix. It is assumed to be */
+/* hermitian, and contains the columns of just the upper */
+/* triangle (UPLO='U') or only the lower triangle (UPLO='L'), */
+/* packed one after another. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal of the (symmetric tri-) diagonal matrix. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N) */
+/* The off-diagonal of the (symmetric tri-) diagonal matrix. */
+/* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and */
+/* (3,2) element, etc. */
+/* Not referenced if KBAND=0. */
+
+/* U (input) COMPLEX*16 array, dimension (LDU, N) */
+/* If ITYPE=1 or 3, this contains the unitary matrix in */
+/* the decomposition, expressed as a dense matrix. If ITYPE=2, */
+/* then it is not referenced. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N and */
+/* at least 1. */
+
+/* VP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* If ITYPE=2 or 3, the columns of this array contain the */
+/* Householder vectors used to describe the unitary matrix */
+/* in the decomposition, as described in purpose. */
+/* *NOTE* If ITYPE=2 or 3, V is modified and restored. The */
+/* subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U') */
+/* is set to one, and later reset to its original value, during */
+/* the course of the calculation. */
+/* If ITYPE=1, then it is neither referenced nor modified. */
+
+/* TAU (input) COMPLEX*16 array, dimension (N) */
+/* If ITYPE >= 2, then TAU(j) is the scalar factor of */
+/* v(j) v(j)* in the Householder transformation H(j) of */
+/* the product U = H(1)...H(n-2) */
+/* If ITYPE < 2, then TAU is not referenced. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N**2) */
+/* Workspace. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+/* Workspace. */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+/* RESULT(1) is always modified. RESULT(2) is modified only */
+/* if ITYPE=1. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Constants */
+
+ /* Parameter adjustments */
+ --ap;
+ --d__;
+ --e;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --vp;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.;
+ if (*itype == 1) {
+ result[2] = 0.;
+ }
+ if (*n <= 0) {
+ return 0;
+ }
+
+ lap = *n * (*n + 1) / 2;
+
+ if (lsame_(uplo, "U")) {
+ lower = FALSE_;
+ *(unsigned char *)cuplo = 'U';
+ } else {
+ lower = TRUE_;
+ *(unsigned char *)cuplo = 'L';
+ }
+
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+
+/* Some Error Checks */
+
+ if (*itype < 1 || *itype > 3) {
+ result[1] = 10. / ulp;
+ return 0;
+ }
+
+/* Do Test 1 */
+
+/* Norm of A: */
+
+ if (*itype == 3) {
+ anorm = 1.;
+ } else {
+/* Computing MAX */
+ d__1 = zlanhp_("1", cuplo, n, &ap[1], &rwork[1])
+ ;
+ anorm = max(d__1,unfl);
+ }
+
+/* Compute error matrix: */
+
+ if (*itype == 1) {
+
+/* ITYPE=1: error = A - U S U* */
+
+ zlaset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
+ zcopy_(&lap, &ap[1], &c__1, &work[1], &c__1);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ d__1 = -d__[j];
+ zhpr_(cuplo, n, &d__1, &u[j * u_dim1 + 1], &c__1, &work[1]);
+/* L10: */
+ }
+
+ if (*n > 1 && *kband == 1) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ z__2.r = e[i__2], z__2.i = 0.;
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ zhpr2_(cuplo, n, &z__1, &u[j * u_dim1 + 1], &c__1, &u[(j - 1)
+ * u_dim1 + 1], &c__1, &work[1]);
+/* L20: */
+ }
+ }
+ wnorm = zlanhp_("1", cuplo, n, &work[1], &rwork[1]);
+
+ } else if (*itype == 2) {
+
+/* ITYPE=2: error = V S V* - A */
+
+ zlaset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
+
+ if (lower) {
+ i__1 = lap;
+ i__2 = *n;
+ work[i__1].r = d__[i__2], work[i__1].i = 0.;
+ for (j = *n - 1; j >= 1; --j) {
+ jp = ((*n << 1) - j) * (j - 1) / 2;
+ jp1 = jp + *n - j;
+ if (*kband == 1) {
+ i__1 = jp + j + 1;
+ i__2 = j;
+ z__2.r = 1. - tau[i__2].r, z__2.i = 0. - tau[i__2].i;
+ i__3 = j;
+ z__1.r = e[i__3] * z__2.r, z__1.i = e[i__3] * z__2.i;
+ work[i__1].r = z__1.r, work[i__1].i = z__1.i;
+ i__1 = *n;
+ for (jr = j + 2; jr <= i__1; ++jr) {
+ i__2 = jp + jr;
+ i__3 = j;
+ z__3.r = -tau[i__3].r, z__3.i = -tau[i__3].i;
+ i__4 = j;
+ z__2.r = e[i__4] * z__3.r, z__2.i = e[i__4] * z__3.i;
+ i__5 = jp + jr;
+ z__1.r = z__2.r * vp[i__5].r - z__2.i * vp[i__5].i,
+ z__1.i = z__2.r * vp[i__5].i + z__2.i * vp[
+ i__5].r;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L30: */
+ }
+ }
+
+ i__1 = j;
+ if (tau[i__1].r != 0. || tau[i__1].i != 0.) {
+ i__1 = jp + j + 1;
+ vsave.r = vp[i__1].r, vsave.i = vp[i__1].i;
+ i__1 = jp + j + 1;
+ vp[i__1].r = 1., vp[i__1].i = 0.;
+ i__1 = *n - j;
+ zhpmv_("L", &i__1, &c_b2, &work[jp1 + j + 1], &vp[jp + j
+ + 1], &c__1, &c_b1, &work[lap + 1], &c__1);
+ i__1 = j;
+ z__2.r = tau[i__1].r * -.5, z__2.i = tau[i__1].i * -.5;
+ i__2 = *n - j;
+ zdotc_(&z__3, &i__2, &work[lap + 1], &c__1, &vp[jp + j +
+ 1], &c__1);
+ z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i =
+ z__2.r * z__3.i + z__2.i * z__3.r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ i__1 = *n - j;
+ zaxpy_(&i__1, &temp, &vp[jp + j + 1], &c__1, &work[lap +
+ 1], &c__1);
+ i__1 = *n - j;
+ i__2 = j;
+ z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i;
+ zhpr2_("L", &i__1, &z__1, &vp[jp + j + 1], &c__1, &work[
+ lap + 1], &c__1, &work[jp1 + j + 1]);
+
+ i__1 = jp + j + 1;
+ vp[i__1].r = vsave.r, vp[i__1].i = vsave.i;
+ }
+ i__1 = jp + j;
+ i__2 = j;
+ work[i__1].r = d__[i__2], work[i__1].i = 0.;
+/* L40: */
+ }
+ } else {
+ work[1].r = d__[1], work[1].i = 0.;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ jp = j * (j - 1) / 2;
+ jp1 = jp + j;
+ if (*kband == 1) {
+ i__2 = jp1 + j;
+ i__3 = j;
+ z__2.r = 1. - tau[i__3].r, z__2.i = 0. - tau[i__3].i;
+ i__4 = j;
+ z__1.r = e[i__4] * z__2.r, z__1.i = e[i__4] * z__2.i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ i__2 = j - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = jp1 + jr;
+ i__4 = j;
+ z__3.r = -tau[i__4].r, z__3.i = -tau[i__4].i;
+ i__5 = j;
+ z__2.r = e[i__5] * z__3.r, z__2.i = e[i__5] * z__3.i;
+ i__6 = jp1 + jr;
+ z__1.r = z__2.r * vp[i__6].r - z__2.i * vp[i__6].i,
+ z__1.i = z__2.r * vp[i__6].i + z__2.i * vp[
+ i__6].r;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L50: */
+ }
+ }
+
+ i__2 = j;
+ if (tau[i__2].r != 0. || tau[i__2].i != 0.) {
+ i__2 = jp1 + j;
+ vsave.r = vp[i__2].r, vsave.i = vp[i__2].i;
+ i__2 = jp1 + j;
+ vp[i__2].r = 1., vp[i__2].i = 0.;
+ zhpmv_("U", &j, &c_b2, &work[1], &vp[jp1 + 1], &c__1, &
+ c_b1, &work[lap + 1], &c__1);
+ i__2 = j;
+ z__2.r = tau[i__2].r * -.5, z__2.i = tau[i__2].i * -.5;
+ zdotc_(&z__3, &j, &work[lap + 1], &c__1, &vp[jp1 + 1], &
+ c__1);
+ z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i =
+ z__2.r * z__3.i + z__2.i * z__3.r;
+ temp.r = z__1.r, temp.i = z__1.i;
+ zaxpy_(&j, &temp, &vp[jp1 + 1], &c__1, &work[lap + 1], &
+ c__1);
+ i__2 = j;
+ z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i;
+ zhpr2_("U", &j, &z__1, &vp[jp1 + 1], &c__1, &work[lap + 1]
+, &c__1, &work[1]);
+ i__2 = jp1 + j;
+ vp[i__2].r = vsave.r, vp[i__2].i = vsave.i;
+ }
+ i__2 = jp1 + j + 1;
+ i__3 = j + 1;
+ work[i__2].r = d__[i__3], work[i__2].i = 0.;
+/* L60: */
+ }
+ }
+
+ i__1 = lap;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ i__3 = j;
+ i__4 = j;
+ z__1.r = work[i__3].r - ap[i__4].r, z__1.i = work[i__3].i - ap[
+ i__4].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L70: */
+ }
+ wnorm = zlanhp_("1", cuplo, n, &work[1], &rwork[1]);
+
+ } else if (*itype == 3) {
+
+/* ITYPE=3: error = U V* - I */
+
+ if (*n < 2) {
+ return 0;
+ }
+ zlacpy_(" ", n, n, &u[u_offset], ldu, &work[1], n);
+/* Computing 2nd power */
+ i__1 = *n;
+ zupmtr_("R", cuplo, "C", n, n, &vp[1], &tau[1], &work[1], n, &work[
+ i__1 * i__1 + 1], &iinfo);
+ if (iinfo != 0) {
+ result[1] = 10. / ulp;
+ return 0;
+ }
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (*n + 1) * (j - 1) + 1;
+ i__3 = (*n + 1) * (j - 1) + 1;
+ z__1.r = work[i__3].r - 1., z__1.i = work[i__3].i - 0.;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L80: */
+ }
+
+ wnorm = zlange_("1", n, n, &work[1], n, &rwork[1]);
+ }
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.) {
+/* Computing MIN */
+ d__1 = wnorm, d__2 = *n * anorm;
+ result[1] = min(d__1,d__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
+ result[1] = min(d__1,d__2) / (*n * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute UU* - I */
+
+ if (*itype == 1) {
+ zgemm_("N", "C", n, n, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu,
+ &c_b1, &work[1], n);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (*n + 1) * (j - 1) + 1;
+ i__3 = (*n + 1) * (j - 1) + 1;
+ z__1.r = work[i__3].r - 1., z__1.i = work[i__3].i - 0.;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L90: */
+ }
+
+/* Computing MIN */
+ d__1 = zlange_("1", n, n, &work[1], n, &rwork[1]), d__2 = (
+ doublereal) (*n);
+ result[2] = min(d__1,d__2) / (*n * ulp);
+ }
+
+ return 0;
+
+/* End of ZHPT21 */
+
+} /* zhpt21_ */
diff --git a/TESTING/EIG/zhst01.c b/TESTING/EIG/zhst01.c
new file mode 100644
index 0000000..bddb060
--- /dev/null
+++ b/TESTING/EIG/zhst01.c
@@ -0,0 +1,198 @@
+/* zhst01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b7 = {1.,0.};
+static doublecomplex c_b8 = {0.,0.};
+static doublecomplex c_b11 = {-1.,0.};
+
+/* Subroutine */ int zhst01_(integer *n, integer *ilo, integer *ihi,
+ doublecomplex *a, integer *lda, doublecomplex *h__, integer *ldh,
+ doublecomplex *q, integer *ldq, doublecomplex *work, integer *lwork,
+ doublereal *rwork, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, h_dim1, h_offset, q_dim1, q_offset;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ doublereal eps, unfl, ovfl, anorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zunt01_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+ doublereal wnorm;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ integer ldwork;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHST01 tests the reduction of a general matrix A to upper Hessenberg */
+/* form: A = Q*H*Q'. Two test ratios are computed; */
+
+/* RESULT(1) = norm( A - Q*H*Q' ) / ( norm(A) * N * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( N * EPS ) */
+
+/* The matrix Q is assumed to be given explicitly as it would be */
+/* following ZGEHRD + ZUNGHR. */
+
+/* In this version, ILO and IHI are not used, but they could be used */
+/* to save some work if this is desired. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* ILO (input) INTEGER */
+/* IHI (input) INTEGER */
+/* A is assumed to be upper triangular in rows and columns */
+/* 1:ILO-1 and IHI+1:N, so Q differs from the identity only in */
+/* rows and columns ILO+1:IHI. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original n by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* H (input) COMPLEX*16 array, dimension (LDH,N) */
+/* The upper Hessenberg matrix H from the reduction A = Q*H*Q' */
+/* as computed by ZGEHRD. H is assumed to be zero below the */
+/* first subdiagonal. */
+
+/* LDH (input) INTEGER */
+/* The leading dimension of the array H. LDH >= max(1,N). */
+
+/* Q (input) COMPLEX*16 array, dimension (LDQ,N) */
+/* The orthogonal matrix Q from the reduction A = Q*H*Q' as */
+/* computed by ZGEHRD + ZUNGHR. */
+
+/* LDQ (input) INTEGER */
+/* The leading dimension of the array Q. LDQ >= max(1,N). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= 2*N*N. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* RESULT(1) = norm( A - Q*H*Q' ) / ( norm(A) * N * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( N * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ h_dim1 = *ldh;
+ h_offset = 1 + h_dim1;
+ h__ -= h_offset;
+ q_dim1 = *ldq;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ if (*n <= 0) {
+ result[1] = 0.;
+ result[2] = 0.;
+ return 0;
+ }
+
+ unfl = dlamch_("Safe minimum");
+ eps = dlamch_("Precision");
+ ovfl = 1. / unfl;
+ dlabad_(&unfl, &ovfl);
+ smlnum = unfl * *n / eps;
+
+/* Test 1: Compute norm( A - Q*H*Q' ) / ( norm(A) * N * EPS ) */
+
+/* Copy A to WORK */
+
+ ldwork = max(1,*n);
+ zlacpy_(" ", n, n, &a[a_offset], lda, &work[1], &ldwork);
+
+/* Compute Q*H */
+
+ zgemm_("No transpose", "No transpose", n, n, n, &c_b7, &q[q_offset], ldq,
+ &h__[h_offset], ldh, &c_b8, &work[ldwork * *n + 1], &ldwork);
+
+/* Compute A - Q*H*Q' */
+
+ zgemm_("No transpose", "Conjugate transpose", n, n, n, &c_b11, &work[
+ ldwork * *n + 1], &ldwork, &q[q_offset], ldq, &c_b7, &work[1], &
+ ldwork);
+
+/* Computing MAX */
+ d__1 = zlange_("1", n, n, &a[a_offset], lda, &rwork[1]);
+ anorm = max(d__1,unfl);
+ wnorm = zlange_("1", n, n, &work[1], &ldwork, &rwork[1]);
+
+/* Note that RESULT(1) cannot overflow and is bounded by 1/(N*EPS) */
+
+/* Computing MAX */
+ d__1 = smlnum, d__2 = anorm * eps;
+ result[1] = min(wnorm,anorm) / max(d__1,d__2) / *n;
+
+/* Test 2: Compute norm( I - Q'*Q ) / ( N * EPS ) */
+
+ zunt01_("Columns", n, n, &q[q_offset], ldq, &work[1], lwork, &rwork[1], &
+ result[2]);
+
+ return 0;
+
+/* End of ZHST01 */
+
+} /* zhst01_ */
diff --git a/TESTING/EIG/zlarfy.c b/TESTING/EIG/zlarfy.c
new file mode 100644
index 0000000..691e934
--- /dev/null
+++ b/TESTING/EIG/zlarfy.c
@@ -0,0 +1,146 @@
+/* zlarfy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static doublecomplex c_b2 = {0.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zlarfy_(char *uplo, integer *n, doublecomplex *v,
+ integer *incv, doublecomplex *tau, doublecomplex *c__, integer *ldc,
+ doublecomplex *work)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Local variables */
+ extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ doublecomplex alpha;
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zhemv_(char *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *), zaxpy_(
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLARFY applies an elementary reflector, or Householder matrix, H, */
+/* to an n x n Hermitian matrix C, from both the left and the right. */
+
+/* H is represented in the form */
+
+/* H = I - tau * v * v' */
+
+/* where tau is a scalar and v is a vector. */
+
+/* If tau is zero, then H is taken to be the unit matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix C is stored. */
+/* = 'U': Upper triangle */
+/* = 'L': Lower triangle */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix C. N >= 0. */
+
+/* V (input) COMPLEX*16 array, dimension */
+/* (1 + (N-1)*abs(INCV)) */
+/* The vector v as described above. */
+
+/* INCV (input) INTEGER */
+/* The increment between successive elements of v. INCV must */
+/* not be zero. */
+
+/* TAU (input) COMPLEX*16 */
+/* The value tau as described above. */
+
+/* C (input/output) COMPLEX*16 array, dimension (LDC, N) */
+/* On entry, the matrix C. */
+/* On exit, C is overwritten by H * C * H'. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array C. LDC >= max( 1, N ). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --v;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --work;
+
+ /* Function Body */
+ if (tau->r == 0. && tau->i == 0.) {
+ return 0;
+ }
+
+/* Form w:= C * v */
+
+ zhemv_(uplo, n, &c_b1, &c__[c_offset], ldc, &v[1], incv, &c_b2, &work[1],
+ &c__1);
+
+ z__3.r = -.5, z__3.i = -0.;
+ z__2.r = z__3.r * tau->r - z__3.i * tau->i, z__2.i = z__3.r * tau->i +
+ z__3.i * tau->r;
+ zdotc_(&z__4, n, &work[1], &c__1, &v[1], incv);
+ z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i +
+ z__2.i * z__4.r;
+ alpha.r = z__1.r, alpha.i = z__1.i;
+ zaxpy_(n, &alpha, &v[1], incv, &work[1], &c__1);
+
+/* C := C - v * w' - w * v' */
+
+ z__1.r = -tau->r, z__1.i = -tau->i;
+ zher2_(uplo, n, &z__1, &v[1], incv, &work[1], &c__1, &c__[c_offset], ldc);
+
+ return 0;
+
+/* End of ZLARFY */
+
+} /* zlarfy_ */
diff --git a/TESTING/EIG/zlarhs.c b/TESTING/EIG/zlarhs.c
new file mode 100644
index 0000000..df180d3
--- /dev/null
+++ b/TESTING/EIG/zlarhs.c
@@ -0,0 +1,442 @@
+/* zlarhs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static doublecomplex c_b2 = {0.,0.};
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* Subroutine */ int zlarhs_(char *path, char *xtype, char *uplo, char *trans,
+ integer *m, integer *n, integer *kl, integer *ku, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *x, integer *ldx,
+ doublecomplex *b, integer *ldb, integer *iseed, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j;
+ char c1[1], c2[2];
+ integer mb, nx;
+ logical gen, tri, qrs, sym, band;
+ char diag[1];
+ logical tran;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zhemm_(char *, char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zgbmv_(char *, integer *, integer *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zhbmv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zsbmv_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *), ztbmv_(char
+ *, char *, char *, integer *, integer *, doublecomplex *, integer
+ *, doublecomplex *, integer *), zhpmv_(
+ char *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), ztrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ zspmv_(char *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zsymm_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *), ztpmv_(char *, char *, char *, integer *, doublecomplex *
+, doublecomplex *, integer *), xerbla_(
+ char *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ logical notran;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlarnv_(integer *, integer *, integer *, doublecomplex *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLARHS chooses a set of NRHS random solution vectors and sets */
+/* up the right hand sides for the linear system */
+/* op( A ) * X = B, */
+/* where op( A ) may be A, A**T (transpose of A), or A**H (conjugate */
+/* transpose of A). */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The type of the complex matrix A. PATH may be given in any */
+/* combination of upper and lower case. Valid paths include */
+/* xGE: General m x n matrix */
+/* xGB: General banded matrix */
+/* xPO: Hermitian positive definite, 2-D storage */
+/* xPP: Hermitian positive definite packed */
+/* xPB: Hermitian positive definite banded */
+/* xHE: Hermitian indefinite, 2-D storage */
+/* xHP: Hermitian indefinite packed */
+/* xHB: Hermitian indefinite banded */
+/* xSY: Symmetric indefinite, 2-D storage */
+/* xSP: Symmetric indefinite packed */
+/* xSB: Symmetric indefinite banded */
+/* xTR: Triangular */
+/* xTP: Triangular packed */
+/* xTB: Triangular banded */
+/* xQR: General m x n matrix */
+/* xLQ: General m x n matrix */
+/* xQL: General m x n matrix */
+/* xRQ: General m x n matrix */
+/* where the leading character indicates the precision. */
+
+/* XTYPE (input) CHARACTER*1 */
+/* Specifies how the exact solution X will be determined: */
+/* = 'N': New solution; generate a random X. */
+/* = 'C': Computed; use value of X on entry. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Used only if A is symmetric or triangular; specifies whether */
+/* the upper or lower triangular part of the matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Used only if A is nonsymmetric; specifies the operation */
+/* applied to the matrix A. */
+/* = 'N': B := A * X */
+/* = 'T': B := A**T * X */
+/* = 'C': B := A**H * X */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* Used only if A is a band matrix; specifies the number of */
+/* subdiagonals of A if A is a general band matrix or if A is */
+/* symmetric or triangular and UPLO = 'L'; specifies the number */
+/* of superdiagonals of A if A is symmetric or triangular and */
+/* UPLO = 'U'. 0 <= KL <= M-1. */
+
+/* KU (input) INTEGER */
+/* Used only if A is a general band matrix or if A is */
+/* triangular. */
+
+/* If PATH = xGB, specifies the number of superdiagonals of A, */
+/* and 0 <= KU <= N-1. */
+
+/* If PATH = xTR, xTP, or xTB, specifies whether or not the */
+/* matrix has unit diagonal: */
+/* = 1: matrix has non-unit diagonal (default) */
+/* = 2: matrix has unit diagonal */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors in the system A*X = B. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The test matrix whose type is given by PATH. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If PATH = xGB, LDA >= KL+KU+1. */
+/* If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1. */
+/* Otherwise, LDA >= max(1,M). */
+
+/* X (input or output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* On entry, if XTYPE = 'C' (for 'Computed'), then X contains */
+/* the exact solution to the system of linear equations. */
+/* On exit, if XTYPE = 'N' (for 'New'), then X is initialized */
+/* with random values. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M). */
+
+/* B (output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side vector(s) for the system of equations, */
+/* computed from B = op(A) * X, where op(A) is determined by */
+/* TRANS. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. If TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N). */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* The seed vector for the random number generator (used in */
+/* ZLATMS). Modified on exit. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --iseed;
+
+ /* Function Body */
+ *info = 0;
+ *(unsigned char *)c1 = *(unsigned char *)path;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ tran = lsame_(trans, "T") || lsame_(trans, "C");
+ notran = ! tran;
+ gen = lsame_(path + 1, "G");
+ qrs = lsame_(path + 1, "Q") || lsame_(path + 2,
+ "Q");
+ sym = lsame_(path + 1, "P") || lsame_(path + 1,
+ "S") || lsame_(path + 1, "H");
+ tri = lsame_(path + 1, "T");
+ band = lsame_(path + 2, "B");
+ if (! lsame_(c1, "Zomplex precision")) {
+ *info = -1;
+ } else if (! (lsame_(xtype, "N") || lsame_(xtype,
+ "C"))) {
+ *info = -2;
+ } else if ((sym || tri) && ! (lsame_(uplo, "U") ||
+ lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if ((gen || qrs) && ! (tran || lsame_(trans, "N"))) {
+ *info = -4;
+ } else if (*m < 0) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (band && *kl < 0) {
+ *info = -7;
+ } else if (band && *ku < 0) {
+ *info = -8;
+ } else if (*nrhs < 0) {
+ *info = -9;
+ } else if (! band && *lda < max(1,*m) || band && (sym || tri) && *lda < *
+ kl + 1 || band && gen && *lda < *kl + *ku + 1) {
+ *info = -11;
+ } else if (notran && *ldx < max(1,*n) || tran && *ldx < max(1,*m)) {
+ *info = -13;
+ } else if (notran && *ldb < max(1,*m) || tran && *ldb < max(1,*n)) {
+ *info = -15;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLARHS", &i__1);
+ return 0;
+ }
+
+/* Initialize X to NRHS random vectors unless XTYPE = 'C'. */
+
+ if (tran) {
+ nx = *m;
+ mb = *n;
+ } else {
+ nx = *n;
+ mb = *m;
+ }
+ if (! lsame_(xtype, "C")) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ zlarnv_(&c__2, &iseed[1], n, &x[j * x_dim1 + 1]);
+/* L10: */
+ }
+ }
+
+/* Multiply X by op( A ) using an appropriate */
+/* matrix multiply routine. */
+
+ if (lsamen_(&c__2, c2, "GE") || lsamen_(&c__2, c2,
+ "QR") || lsamen_(&c__2, c2, "LQ") || lsamen_(&c__2, c2, "QL") ||
+ lsamen_(&c__2, c2, "RQ")) {
+
+/* General matrix */
+
+ zgemm_(trans, "N", &mb, nrhs, &nx, &c_b1, &a[a_offset], lda, &x[
+ x_offset], ldx, &c_b2, &b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "PO") || lsamen_(&
+ c__2, c2, "HE")) {
+
+/* Hermitian matrix, 2-D storage */
+
+ zhemm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset],
+ ldx, &c_b2, &b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "SY")) {
+
+/* Symmetric matrix, 2-D storage */
+
+ zsymm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset],
+ ldx, &c_b2, &b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* General matrix, band storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ zgbmv_(trans, m, n, kl, ku, &c_b1, &a[a_offset], lda, &x[j *
+ x_dim1 + 1], &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
+/* L20: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "PB") || lsamen_(&
+ c__2, c2, "HB")) {
+
+/* Hermitian matrix, band storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ zhbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1],
+ &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
+/* L30: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "SB")) {
+
+/* Symmetric matrix, band storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ zsbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1],
+ &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
+/* L40: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "PP") || lsamen_(&
+ c__2, c2, "HP")) {
+
+/* Hermitian matrix, packed storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ zhpmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
+ c_b2, &b[j * b_dim1 + 1], &c__1);
+/* L50: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "SP")) {
+
+/* Symmetric matrix, packed storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ zspmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
+ c_b2, &b[j * b_dim1 + 1], &c__1);
+/* L60: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "TR")) {
+
+/* Triangular matrix. Note that for triangular matrices, */
+/* KU = 1 => non-unit triangular */
+/* KU = 2 => unit triangular */
+
+ zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ ztrmm_("Left", uplo, trans, diag, n, nrhs, &c_b1, &a[a_offset], lda, &
+ b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "TP")) {
+
+/* Triangular matrix, packed storage */
+
+ zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ztpmv_(uplo, trans, diag, n, &a[a_offset], &b[j * b_dim1 + 1], &
+ c__1);
+/* L70: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "TB")) {
+
+/* Triangular matrix, banded storage */
+
+ zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ztbmv_(uplo, trans, diag, n, kl, &a[a_offset], lda, &b[j * b_dim1
+ + 1], &c__1);
+/* L80: */
+ }
+
+ } else {
+
+/* If none of the above, set INFO = -1 and return */
+
+ *info = -1;
+ i__1 = -(*info);
+ xerbla_("ZLARHS", &i__1);
+ }
+
+ return 0;
+
+/* End of ZLARHS */
+
+} /* zlarhs_ */
diff --git a/TESTING/EIG/zlatm4.c b/TESTING/EIG/zlatm4.c
new file mode 100644
index 0000000..cec120d
--- /dev/null
+++ b/TESTING/EIG/zlatm4.c
@@ -0,0 +1,476 @@
+/* zlatm4.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static integer c__3 = 3;
+
+/* Subroutine */ int zlatm4_(integer *itype, integer *n, integer *nz1,
+ integer *nz2, logical *rsign, doublereal *amagn, doublereal *rcond,
+ doublereal *triang, integer *idist, integer *iseed, doublecomplex *a,
+ integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double pow_dd(doublereal *, doublereal *), log(doublereal), exp(
+ doublereal), z_abs(doublecomplex *);
+
+ /* Local variables */
+ integer i__, k, jc, jd, jr, kbeg, isdb, kend, isde, klen;
+ doublereal alpha;
+ doublecomplex ctemp;
+ extern doublereal dlaran_(integer *);
+ extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
+ integer *);
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLATM4 generates basic square matrices, which may later be */
+/* multiplied by others in order to produce test matrices. It is */
+/* intended mainly to be used to test the generalized eigenvalue */
+/* routines. */
+
+/* It first generates the diagonal and (possibly) subdiagonal, */
+/* according to the value of ITYPE, NZ1, NZ2, RSIGN, AMAGN, and RCOND. */
+/* It then fills in the upper triangle with random numbers, if TRIANG is */
+/* non-zero. */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* The "type" of matrix on the diagonal and sub-diagonal. */
+/* If ITYPE < 0, then type abs(ITYPE) is generated and then */
+/* swapped end for end (A(I,J) := A'(N-J,N-I).) See also */
+/* the description of AMAGN and RSIGN. */
+
+/* Special types: */
+/* = 0: the zero matrix. */
+/* = 1: the identity. */
+/* = 2: a transposed Jordan block. */
+/* = 3: If N is odd, then a k+1 x k+1 transposed Jordan block */
+/* followed by a k x k identity block, where k=(N-1)/2. */
+/* If N is even, then k=(N-2)/2, and a zero diagonal entry */
+/* is tacked onto the end. */
+
+/* Diagonal types. The diagonal consists of NZ1 zeros, then */
+/* k=N-NZ1-NZ2 nonzeros. The subdiagonal is zero. ITYPE */
+/* specifies the nonzero diagonal entries as follows: */
+/* = 4: 1, ..., k */
+/* = 5: 1, RCOND, ..., RCOND */
+/* = 6: 1, ..., 1, RCOND */
+/* = 7: 1, a, a^2, ..., a^(k-1)=RCOND */
+/* = 8: 1, 1-d, 1-2*d, ..., 1-(k-1)*d=RCOND */
+/* = 9: random numbers chosen from (RCOND,1) */
+/* = 10: random numbers with distribution IDIST (see ZLARND.) */
+
+/* N (input) INTEGER */
+/* The order of the matrix. */
+
+/* NZ1 (input) INTEGER */
+/* If abs(ITYPE) > 3, then the first NZ1 diagonal entries will */
+/* be zero. */
+
+/* NZ2 (input) INTEGER */
+/* If abs(ITYPE) > 3, then the last NZ2 diagonal entries will */
+/* be zero. */
+
+/* RSIGN (input) LOGICAL */
+/* = .TRUE.: The diagonal and subdiagonal entries will be */
+/* multiplied by random numbers of magnitude 1. */
+/* = .FALSE.: The diagonal and subdiagonal entries will be */
+/* left as they are (usually non-negative real.) */
+
+/* AMAGN (input) DOUBLE PRECISION */
+/* The diagonal and subdiagonal entries will be multiplied by */
+/* AMAGN. */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* If abs(ITYPE) > 4, then the smallest diagonal entry will be */
+/* RCOND. RCOND must be between 0 and 1. */
+
+/* TRIANG (input) DOUBLE PRECISION */
+/* The entries above the diagonal will be random numbers with */
+/* magnitude bounded by TRIANG (i.e., random numbers multiplied */
+/* by TRIANG.) */
+
+/* IDIST (input) INTEGER */
+/* On entry, DIST specifies the type of distribution to be used */
+/* to generate a random matrix . */
+/* = 1: real and imaginary parts each UNIFORM( 0, 1 ) */
+/* = 2: real and imaginary parts each UNIFORM( -1, 1 ) */
+/* = 3: real and imaginary parts each NORMAL( 0, 1 ) */
+/* = 4: complex number uniform in DISK( 0, 1 ) */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The values of ISEED are changed on exit, and can */
+/* be used in the next call to ZLATM4 to continue the same */
+/* random number sequence. */
+/* Note: ISEED(4) should be odd, for the random number generator */
+/* used at present. */
+
+/* A (output) COMPLEX*16 array, dimension (LDA, N) */
+/* Array to be computed. */
+
+/* LDA (input) INTEGER */
+/* Leading dimension of A. Must be at least 1 and at least N. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ zlaset_("Full", n, n, &c_b1, &c_b1, &a[a_offset], lda);
+
+/* Insure a correct ISEED */
+
+ if (iseed[4] % 2 != 1) {
+ ++iseed[4];
+ }
+
+/* Compute diagonal and subdiagonal according to ITYPE, NZ1, NZ2, */
+/* and RCOND */
+
+ if (*itype != 0) {
+ if (abs(*itype) >= 4) {
+/* Computing MAX */
+/* Computing MIN */
+ i__3 = *n, i__4 = *nz1 + 1;
+ i__1 = 1, i__2 = min(i__3,i__4);
+ kbeg = max(i__1,i__2);
+/* Computing MAX */
+/* Computing MIN */
+ i__3 = *n, i__4 = *n - *nz2;
+ i__1 = kbeg, i__2 = min(i__3,i__4);
+ kend = max(i__1,i__2);
+ klen = kend + 1 - kbeg;
+ } else {
+ kbeg = 1;
+ kend = *n;
+ klen = *n;
+ }
+ isdb = 1;
+ isde = 0;
+ switch (abs(*itype)) {
+ case 1: goto L10;
+ case 2: goto L30;
+ case 3: goto L50;
+ case 4: goto L80;
+ case 5: goto L100;
+ case 6: goto L120;
+ case 7: goto L140;
+ case 8: goto L160;
+ case 9: goto L180;
+ case 10: goto L200;
+ }
+
+/* abs(ITYPE) = 1: Identity */
+
+L10:
+ i__1 = *n;
+ for (jd = 1; jd <= i__1; ++jd) {
+ i__2 = jd + jd * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+/* L20: */
+ }
+ goto L220;
+
+/* abs(ITYPE) = 2: Transposed Jordan block */
+
+L30:
+ i__1 = *n - 1;
+ for (jd = 1; jd <= i__1; ++jd) {
+ i__2 = jd + 1 + jd * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+/* L40: */
+ }
+ isdb = 1;
+ isde = *n - 1;
+ goto L220;
+
+/* abs(ITYPE) = 3: Transposed Jordan block, followed by the */
+/* identity. */
+
+L50:
+ k = (*n - 1) / 2;
+ i__1 = k;
+ for (jd = 1; jd <= i__1; ++jd) {
+ i__2 = jd + 1 + jd * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+/* L60: */
+ }
+ isdb = 1;
+ isde = k;
+ i__1 = (k << 1) + 1;
+ for (jd = k + 2; jd <= i__1; ++jd) {
+ i__2 = jd + jd * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+/* L70: */
+ }
+ goto L220;
+
+/* abs(ITYPE) = 4: 1,...,k */
+
+L80:
+ i__1 = kend;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ i__2 = jd + jd * a_dim1;
+ i__3 = jd - *nz1;
+ z__1.r = (doublereal) i__3, z__1.i = 0.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L90: */
+ }
+ goto L220;
+
+/* abs(ITYPE) = 5: One large D value: */
+
+L100:
+ i__1 = kend;
+ for (jd = kbeg + 1; jd <= i__1; ++jd) {
+ i__2 = jd + jd * a_dim1;
+ z__1.r = *rcond, z__1.i = 0.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L110: */
+ }
+ i__1 = kbeg + kbeg * a_dim1;
+ a[i__1].r = 1., a[i__1].i = 0.;
+ goto L220;
+
+/* abs(ITYPE) = 6: One small D value: */
+
+L120:
+ i__1 = kend - 1;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ i__2 = jd + jd * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+/* L130: */
+ }
+ i__1 = kend + kend * a_dim1;
+ z__1.r = *rcond, z__1.i = 0.;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ goto L220;
+
+/* abs(ITYPE) = 7: Exponentially distributed D values: */
+
+L140:
+ i__1 = kbeg + kbeg * a_dim1;
+ a[i__1].r = 1., a[i__1].i = 0.;
+ if (klen > 1) {
+ d__1 = 1. / (doublereal) (klen - 1);
+ alpha = pow_dd(rcond, &d__1);
+ i__1 = klen;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = *nz1 + i__ + (*nz1 + i__) * a_dim1;
+ d__2 = (doublereal) (i__ - 1);
+ d__1 = pow_dd(&alpha, &d__2);
+ z__1.r = d__1, z__1.i = 0.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L150: */
+ }
+ }
+ goto L220;
+
+/* abs(ITYPE) = 8: Arithmetically distributed D values: */
+
+L160:
+ i__1 = kbeg + kbeg * a_dim1;
+ a[i__1].r = 1., a[i__1].i = 0.;
+ if (klen > 1) {
+ alpha = (1. - *rcond) / (doublereal) (klen - 1);
+ i__1 = klen;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = *nz1 + i__ + (*nz1 + i__) * a_dim1;
+ d__1 = (doublereal) (klen - i__) * alpha + *rcond;
+ z__1.r = d__1, z__1.i = 0.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L170: */
+ }
+ }
+ goto L220;
+
+/* abs(ITYPE) = 9: Randomly distributed D values on ( RCOND, 1): */
+
+L180:
+ alpha = log(*rcond);
+ i__1 = kend;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ i__2 = jd + jd * a_dim1;
+ d__1 = exp(alpha * dlaran_(&iseed[1]));
+ a[i__2].r = d__1, a[i__2].i = 0.;
+/* L190: */
+ }
+ goto L220;
+
+/* abs(ITYPE) = 10: Randomly distributed D values from DIST */
+
+L200:
+ i__1 = kend;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ i__2 = jd + jd * a_dim1;
+ zlarnd_(&z__1, idist, &iseed[1]);
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L210: */
+ }
+
+L220:
+
+/* Scale by AMAGN */
+
+ i__1 = kend;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ i__2 = jd + jd * a_dim1;
+ i__3 = jd + jd * a_dim1;
+ d__1 = *amagn * a[i__3].r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+/* L230: */
+ }
+ i__1 = isde;
+ for (jd = isdb; jd <= i__1; ++jd) {
+ i__2 = jd + 1 + jd * a_dim1;
+ i__3 = jd + 1 + jd * a_dim1;
+ d__1 = *amagn * a[i__3].r;
+ a[i__2].r = d__1, a[i__2].i = 0.;
+/* L240: */
+ }
+
+/* If RSIGN = .TRUE., assign random signs to diagonal and */
+/* subdiagonal */
+
+ if (*rsign) {
+ i__1 = kend;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ i__2 = jd + jd * a_dim1;
+ if (a[i__2].r != 0.) {
+ zlarnd_(&z__1, &c__3, &iseed[1]);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ d__1 = z_abs(&ctemp);
+ z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__2 = jd + jd * a_dim1;
+ i__3 = jd + jd * a_dim1;
+ d__1 = a[i__3].r;
+ z__1.r = d__1 * ctemp.r, z__1.i = d__1 * ctemp.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ }
+/* L250: */
+ }
+ i__1 = isde;
+ for (jd = isdb; jd <= i__1; ++jd) {
+ i__2 = jd + 1 + jd * a_dim1;
+ if (a[i__2].r != 0.) {
+ zlarnd_(&z__1, &c__3, &iseed[1]);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ d__1 = z_abs(&ctemp);
+ z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__2 = jd + 1 + jd * a_dim1;
+ i__3 = jd + 1 + jd * a_dim1;
+ d__1 = a[i__3].r;
+ z__1.r = d__1 * ctemp.r, z__1.i = d__1 * ctemp.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ }
+/* L260: */
+ }
+ }
+
+/* Reverse if ITYPE < 0 */
+
+ if (*itype < 0) {
+ i__1 = (kbeg + kend - 1) / 2;
+ for (jd = kbeg; jd <= i__1; ++jd) {
+ i__2 = jd + jd * a_dim1;
+ ctemp.r = a[i__2].r, ctemp.i = a[i__2].i;
+ i__2 = jd + jd * a_dim1;
+ i__3 = kbeg + kend - jd + (kbeg + kend - jd) * a_dim1;
+ a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
+ i__2 = kbeg + kend - jd + (kbeg + kend - jd) * a_dim1;
+ a[i__2].r = ctemp.r, a[i__2].i = ctemp.i;
+/* L270: */
+ }
+ i__1 = (*n - 1) / 2;
+ for (jd = 1; jd <= i__1; ++jd) {
+ i__2 = jd + 1 + jd * a_dim1;
+ ctemp.r = a[i__2].r, ctemp.i = a[i__2].i;
+ i__2 = jd + 1 + jd * a_dim1;
+ i__3 = *n + 1 - jd + (*n - jd) * a_dim1;
+ a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
+ i__2 = *n + 1 - jd + (*n - jd) * a_dim1;
+ a[i__2].r = ctemp.r, a[i__2].i = ctemp.i;
+/* L280: */
+ }
+ }
+
+ }
+
+/* Fill in upper triangle */
+
+ if (*triang != 0.) {
+ i__1 = *n;
+ for (jc = 2; jc <= i__1; ++jc) {
+ i__2 = jc - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__3 = jr + jc * a_dim1;
+ zlarnd_(&z__2, idist, &iseed[1]);
+ z__1.r = *triang * z__2.r, z__1.i = *triang * z__2.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L290: */
+ }
+/* L300: */
+ }
+ }
+
+ return 0;
+
+/* End of ZLATM4 */
+
+} /* zlatm4_ */
diff --git a/TESTING/EIG/zlctes.c b/TESTING/EIG/zlctes.c
new file mode 100644
index 0000000..a9fdba1
--- /dev/null
+++ b/TESTING/EIG/zlctes.c
@@ -0,0 +1,95 @@
+/* zlctes.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b3 = 1.;
+
+logical zlctes_(doublecomplex *z__, doublecomplex *d__)
+{
+ /* System generated locals */
+ doublereal d__1, d__2, d__3, d__4;
+ logical ret_val;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *), d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ doublereal zmax;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLCTES returns .TRUE. if the eigenvalue Z/D is to be selected */
+/* (specifically, in this subroutine, if the real part of the */
+/* eigenvalue is negative), and otherwise it returns .FALSE.. */
+
+/* It is used by the test routine ZDRGES to test whether the driver */
+/* routine ZGGES succesfully sorts eigenvalues. */
+
+/* Arguments */
+/* ========= */
+
+/* Z (input) COMPLEX*16 */
+/* The numerator part of a complex eigenvalue Z/D. */
+
+/* D (input) COMPLEX*16 */
+/* The denominator part of a complex eigenvalue Z/D. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (d__->r == 0. && d__->i == 0.) {
+ ret_val = z__->r < 0.;
+ } else {
+ if (z__->r == 0. || d__->r == 0.) {
+ d__1 = d_imag(z__);
+ d__2 = d_imag(d__);
+ ret_val = d_sign(&c_b3, &d__1) != d_sign(&c_b3, &d__2);
+ } else if (d_imag(z__) == 0. || d_imag(d__) == 0.) {
+ d__1 = z__->r;
+ d__2 = d__->r;
+ ret_val = d_sign(&c_b3, &d__1) != d_sign(&c_b3, &d__2);
+ } else {
+/* Computing MAX */
+ d__3 = (d__1 = z__->r, abs(d__1)), d__4 = (d__2 = d_imag(z__),
+ abs(d__2));
+ zmax = max(d__3,d__4);
+ ret_val = z__->r / zmax * d__->r + d_imag(z__) / zmax * d_imag(
+ d__) < 0.;
+ }
+ }
+
+ return ret_val;
+
+/* End of ZLCTES */
+
+} /* zlctes_ */
diff --git a/TESTING/EIG/zlctsx.c b/TESTING/EIG/zlctsx.c
new file mode 100644
index 0000000..99c071c
--- /dev/null
+++ b/TESTING/EIG/zlctsx.c
@@ -0,0 +1,104 @@
+/* zlctsx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer m, n, mplusn, i__;
+ logical fs;
+} mn_;
+
+#define mn_1 mn_
+
+logical zlctsx_(doublecomplex *alpha, doublecomplex *beta)
+{
+ /* System generated locals */
+ logical ret_val;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This function is used to determine what eigenvalues will be */
+/* selected. If this is part of the test driver ZDRGSX, do not */
+/* change the code UNLESS you are testing input examples and not */
+/* using the built-in examples. */
+
+/* Arguments */
+/* ========= */
+
+/* ALPHA (input) COMPLEX*16 */
+/* BETA (input) COMPLEX*16 */
+/* parameters to decide whether the pair (ALPHA, BETA) is */
+/* selected. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* DOUBLE PRECISION ZERO */
+/* PARAMETER ( ZERO = 0.0E+0 ) */
+/* COMPLEX*16 CZERO */
+/* PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (mn_1.fs) {
+ ++mn_1.i__;
+ if (mn_1.i__ <= mn_1.m) {
+ ret_val = FALSE_;
+ } else {
+ ret_val = TRUE_;
+ }
+ if (mn_1.i__ == mn_1.mplusn) {
+ mn_1.fs = FALSE_;
+ mn_1.i__ = 0;
+ }
+ } else {
+ ++mn_1.i__;
+ if (mn_1.i__ <= mn_1.n) {
+ ret_val = TRUE_;
+ } else {
+ ret_val = FALSE_;
+ }
+ if (mn_1.i__ == mn_1.mplusn) {
+ mn_1.fs = TRUE_;
+ mn_1.i__ = 0;
+ }
+ }
+
+/* IF( BETA.EQ.CZERO ) THEN */
+/* ZLCTSX = ( DBLE( ALPHA ).GT.ZERO ) */
+/* ELSE */
+/* ZLCTSX = ( DBLE( ALPHA/BETA ).GT.ZERO ) */
+/* END IF */
+
+ return ret_val;
+
+/* End of ZLCTSX */
+
+} /* zlctsx_ */
diff --git a/TESTING/EIG/zlsets.c b/TESTING/EIG/zlsets.c
new file mode 100644
index 0000000..08483db
--- /dev/null
+++ b/TESTING/EIG/zlsets.c
@@ -0,0 +1,176 @@
+/* zlsets.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zlsets_(integer *m, integer *p, integer *n,
+ doublecomplex *a, doublecomplex *af, integer *lda, doublecomplex *b,
+ doublecomplex *bf, integer *ldb, doublecomplex *c__, doublecomplex *
+ cf, doublecomplex *d__, doublecomplex *df, doublecomplex *x,
+ doublecomplex *work, integer *lwork, doublereal *rwork, doublereal *
+ result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1,
+ bf_offset;
+
+ /* Local variables */
+ integer info;
+ extern /* Subroutine */ int zget02_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *),
+ zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zgglse_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, integer *), zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLSETS tests ZGGLSE - a subroutine for solving linear equality */
+/* constrained least square problem (LSE). */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* P (input) INTEGER */
+/* The number of rows of the matrix B. P >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and B. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The M-by-N matrix A. */
+
+/* AF (workspace) COMPLEX*16 array, dimension (LDA,N) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and R. */
+/* LDA >= max(M,N). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,N) */
+/* The P-by-N matrix A. */
+
+/* BF (workspace) COMPLEX*16 array, dimension (LDB,N) */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the arrays B, BF, V and S. */
+/* LDB >= max(P,N). */
+
+/* C (input) COMPLEX*16 array, dimension( M ) */
+/* the vector C in the LSE problem. */
+
+/* CF (workspace) COMPLEX*16 array, dimension( M ) */
+
+/* D (input) COMPLEX*16 array, dimension( P ) */
+/* the vector D in the LSE problem. */
+
+/* DF (workspace) COMPLEX*16 array, dimension( P ) */
+
+/* X (output) COMPLEX*16 array, dimension( N ) */
+/* solution vector X in the LSE problem. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( A*x - c )/ norm(A)*norm(X)*EPS */
+/* RESULT(2) = norm( B*x - d )/ norm(B)*norm(X)*EPS */
+
+/* ==================================================================== */
+
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Copy the matrices A and B to the arrays AF and BF, */
+/* and the vectors C and D to the arrays CF and DF, */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ bf_dim1 = *ldb;
+ bf_offset = 1 + bf_dim1;
+ bf -= bf_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --c__;
+ --cf;
+ --d__;
+ --df;
+ --x;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ zlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+ zlacpy_("Full", p, n, &b[b_offset], ldb, &bf[bf_offset], ldb);
+ zcopy_(m, &c__[1], &c__1, &cf[1], &c__1);
+ zcopy_(p, &d__[1], &c__1, &df[1], &c__1);
+
+/* Solve LSE problem */
+
+ zgglse_(m, n, p, &af[af_offset], lda, &bf[bf_offset], ldb, &cf[1], &df[1],
+ &x[1], &work[1], lwork, &info);
+
+/* Test the residual for the solution of LSE */
+
+/* Compute RESULT(1) = norm( A*x - c ) / norm(A)*norm(X)*EPS */
+
+ zcopy_(m, &c__[1], &c__1, &cf[1], &c__1);
+ zcopy_(p, &d__[1], &c__1, &df[1], &c__1);
+ zget02_("No transpose", m, n, &c__1, &a[a_offset], lda, &x[1], n, &cf[1],
+ m, &rwork[1], &result[1]);
+
+/* Compute result(2) = norm( B*x - d ) / norm(B)*norm(X)*EPS */
+
+ zget02_("No transpose", p, n, &c__1, &b[b_offset], ldb, &x[1], n, &df[1],
+ p, &rwork[1], &result[2]);
+
+ return 0;
+
+/* End of ZLSETS */
+
+} /* zlsets_ */
diff --git a/TESTING/EIG/zsbmv.c b/TESTING/EIG/zsbmv.c
new file mode 100644
index 0000000..bf09f15
--- /dev/null
+++ b/TESTING/EIG/zsbmv.c
@@ -0,0 +1,479 @@
+/* zsbmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zsbmv_(char *uplo, integer *n, integer *k, doublecomplex
+ *alpha, doublecomplex *a, integer *lda, doublecomplex *x, integer *
+ incx, doublecomplex *beta, doublecomplex *y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Local variables */
+ integer i__, j, l, ix, iy, jx, jy, kx, ky, info;
+ doublecomplex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ integer kplus1;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSBMV performs the matrix-vector operation */
+
+/* y := alpha*A*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are n element vectors and */
+/* A is an n by n symmetric band matrix, with k super-diagonals. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1 */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the band matrix A is being supplied as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* being supplied. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* being supplied. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER */
+/* On entry, K specifies the number of super-diagonals of the */
+/* matrix A. K must satisfy 0 .le. K. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX*16 */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array, dimension( LDA, N ) */
+/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
+/* by n part of the array A must contain the upper triangular */
+/* band part of the symmetric matrix, supplied column by */
+/* column, with the leading diagonal of the matrix in row */
+/* ( k + 1 ) of the array, the first super-diagonal starting at */
+/* position 2 in row k, and so on. The top left k by k triangle */
+/* of the array A is not referenced. */
+/* The following program segment will transfer the upper */
+/* triangular part of a symmetric band matrix from conventional */
+/* full matrix storage to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = K + 1 - J */
+/* DO 10, I = MAX( 1, J - K ), J */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
+/* by n part of the array A must contain the lower triangular */
+/* band part of the symmetric matrix, supplied column by */
+/* column, with the leading diagonal of the matrix in row 1 of */
+/* the array, the first sub-diagonal starting at position 1 in */
+/* row 2, and so on. The bottom right k by k triangle of the */
+/* array A is not referenced. */
+/* The following program segment will transfer the lower */
+/* triangular part of a symmetric band matrix from conventional */
+/* full matrix storage to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = 1 - J */
+/* DO 10, I = J, MIN( N, J + K ) */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Unchanged on exit. */
+
+/* LDA - INTEGER */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* ( k + 1 ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX*16 array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX*16 */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+/* Y - COMPLEX*16 array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the */
+/* vector y. On exit, Y is overwritten by the updated vector y. */
+
+/* INCY - INTEGER */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*k < 0) {
+ info = 3;
+ } else if (*lda < *k + 1) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ } else if (*incy == 0) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("ZSBMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r == 1. &&
+ beta->i == 0.)) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of the array A */
+/* are accessed sequentially with one pass through A. */
+
+/* First form y := beta*y. */
+
+ if (beta->r != 1. || beta->i != 0.) {
+ if (*incy == 1) {
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ y[i__2].r = 0., y[i__2].i = 0.;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ y[i__2].r = 0., y[i__2].i = 0.;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ i__3 = iy;
+ z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (alpha->r == 0. && alpha->i == 0.) {
+ return 0;
+ }
+ if (lsame_(uplo, "U")) {
+
+/* Form y when upper triangle of A is stored. */
+
+ kplus1 = *k + 1;
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__5 = l + i__ + j * a_dim1;
+ z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ i__2 = l + i__ + j * a_dim1;
+ i__3 = i__;
+ z__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[i__3].i,
+ z__2.i = a[i__2].r * x[i__3].i + a[i__2].i * x[
+ i__3].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L50: */
+ }
+ i__4 = j;
+ i__2 = j;
+ i__3 = kplus1 + j * a_dim1;
+ z__3.r = temp1.r * a[i__3].r - temp1.i * a[i__3].i, z__3.i =
+ temp1.r * a[i__3].i + temp1.i * a[i__3].r;
+ z__2.r = y[i__2].r + z__3.r, z__2.i = y[i__2].i + z__3.i;
+ z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ y[i__4].r = z__1.r, y[i__4].i = z__1.i;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = jx;
+ z__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i, z__1.i =
+ alpha->r * x[i__4].i + alpha->i * x[i__4].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ ix = kx;
+ iy = ky;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *k;
+ i__3 = j - 1;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ i__4 = iy;
+ i__2 = iy;
+ i__5 = l + i__ + j * a_dim1;
+ z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i;
+ y[i__4].r = z__1.r, y[i__4].i = z__1.i;
+ i__4 = l + i__ + j * a_dim1;
+ i__2 = ix;
+ z__2.r = a[i__4].r * x[i__2].r - a[i__4].i * x[i__2].i,
+ z__2.i = a[i__4].r * x[i__2].i + a[i__4].i * x[
+ i__2].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ i__3 = jy;
+ i__4 = jy;
+ i__2 = kplus1 + j * a_dim1;
+ z__3.r = temp1.r * a[i__2].r - temp1.i * a[i__2].i, z__3.i =
+ temp1.r * a[i__2].i + temp1.i * a[i__2].r;
+ z__2.r = y[i__4].r + z__3.r, z__2.i = y[i__4].i + z__3.i;
+ z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ jx += *incx;
+ jy += *incy;
+ if (j > *k) {
+ kx += *incx;
+ ky += *incy;
+ }
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y when lower triangle of A is stored. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = j;
+ z__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, z__1.i =
+ alpha->r * x[i__3].i + alpha->i * x[i__3].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ i__3 = j;
+ i__4 = j;
+ i__2 = j * a_dim1 + 1;
+ z__2.r = temp1.r * a[i__2].r - temp1.i * a[i__2].i, z__2.i =
+ temp1.r * a[i__2].i + temp1.i * a[i__2].r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ l = 1 - j;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__2 = i__;
+ i__5 = l + i__ + j * a_dim1;
+ z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i;
+ y[i__4].r = z__1.r, y[i__4].i = z__1.i;
+ i__4 = l + i__ + j * a_dim1;
+ i__2 = i__;
+ z__2.r = a[i__4].r * x[i__2].r - a[i__4].i * x[i__2].i,
+ z__2.i = a[i__4].r * x[i__2].i + a[i__4].i * x[
+ i__2].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L90: */
+ }
+ i__3 = j;
+ i__4 = j;
+ z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = jx;
+ z__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, z__1.i =
+ alpha->r * x[i__3].i + alpha->i * x[i__3].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ i__3 = jy;
+ i__4 = jy;
+ i__2 = j * a_dim1 + 1;
+ z__2.r = temp1.r * a[i__2].r - temp1.i * a[i__2].i, z__2.i =
+ temp1.r * a[i__2].i + temp1.i * a[i__2].r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ l = 1 - j;
+ ix = jx;
+ iy = jy;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ ix += *incx;
+ iy += *incy;
+ i__4 = iy;
+ i__2 = iy;
+ i__5 = l + i__ + j * a_dim1;
+ z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i;
+ y[i__4].r = z__1.r, y[i__4].i = z__1.i;
+ i__4 = l + i__ + j * a_dim1;
+ i__2 = ix;
+ z__2.r = a[i__4].r * x[i__2].r - a[i__4].i * x[i__2].i,
+ z__2.i = a[i__4].r * x[i__2].i + a[i__4].i * x[
+ i__2].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L110: */
+ }
+ i__3 = jy;
+ i__4 = jy;
+ z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ jx += *incx;
+ jy += *incy;
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZSBMV */
+
+} /* zsbmv_ */
diff --git a/TESTING/EIG/zsgt01.c b/TESTING/EIG/zsgt01.c
new file mode 100644
index 0000000..58db596
--- /dev/null
+++ b/TESTING/EIG/zsgt01.c
@@ -0,0 +1,225 @@
+/* zsgt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zsgt01_(integer *itype, char *uplo, integer *n, integer *
+ m, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *z__, integer *ldz, doublereal *d__, doublecomplex *
+ work, doublereal *rwork, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__;
+ doublereal ulp, anorm;
+ extern /* Subroutine */ int zhemm_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *),
+ zlanhe_(char *, char *, integer *, doublecomplex *, integer *,
+ doublereal *);
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* modified August 1997, a new parameter M is added to the calling */
+/* sequence. */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDGT01 checks a decomposition of the form */
+
+/* A Z = B Z D or */
+/* A B Z = Z D or */
+/* B A Z = Z D */
+
+/* where A is a Hermitian matrix, B is Hermitian positive definite, */
+/* Z is unitary, and D is diagonal. */
+
+/* One of the following test ratios is computed: */
+
+/* ITYPE = 1: RESULT(1) = | A Z - B Z D | / ( |A| |Z| n ulp ) */
+
+/* ITYPE = 2: RESULT(1) = | A B Z - Z D | / ( |A| |Z| n ulp ) */
+
+/* ITYPE = 3: RESULT(1) = | B A Z - Z D | / ( |A| |Z| n ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* ITYPE (input) INTEGER */
+/* The form of the Hermitian generalized eigenproblem. */
+/* = 1: A*z = (lambda)*B*z */
+/* = 2: A*B*z = (lambda)*z */
+/* = 3: B*A*z = (lambda)*z */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrices A and B is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* M (input) INTEGER */
+/* The number of eigenvalues found. M >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA, N) */
+/* The original Hermitian matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB, N) */
+/* The original Hermitian positive definite matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* Z (input) COMPLEX*16 array, dimension (LDZ, M) */
+/* The computed eigenvectors of the generalized eigenproblem. */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of the array Z. LDZ >= max(1,N). */
+
+/* D (input) DOUBLE PRECISION array, dimension (M) */
+/* The computed eigenvalues of the generalized eigenproblem. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (1) */
+/* The test ratio as described above. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+ --d__;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.;
+ if (*n <= 0) {
+ return 0;
+ }
+
+ ulp = dlamch_("Epsilon");
+
+/* Compute product of 1-norms of A and Z. */
+
+ anorm = zlanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]) * zlange_("1", n, m, &z__[z_offset], ldz, &rwork[1]);
+ if (anorm == 0.) {
+ anorm = 1.;
+ }
+
+ if (*itype == 1) {
+
+/* Norm of AZ - BZD */
+
+ zhemm_("Left", uplo, n, m, &c_b2, &a[a_offset], lda, &z__[z_offset],
+ ldz, &c_b1, &work[1], n);
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ zdscal_(n, &d__[i__], &z__[i__ * z_dim1 + 1], &c__1);
+/* L10: */
+ }
+ z__1.r = -1., z__1.i = -0.;
+ zhemm_("Left", uplo, n, m, &c_b2, &b[b_offset], ldb, &z__[z_offset],
+ ldz, &z__1, &work[1], n);
+
+ result[1] = zlange_("1", n, m, &work[1], n, &rwork[1]) /
+ anorm / (*n * ulp);
+
+ } else if (*itype == 2) {
+
+/* Norm of ABZ - ZD */
+
+ zhemm_("Left", uplo, n, m, &c_b2, &b[b_offset], ldb, &z__[z_offset],
+ ldz, &c_b1, &work[1], n);
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ zdscal_(n, &d__[i__], &z__[i__ * z_dim1 + 1], &c__1);
+/* L20: */
+ }
+ z__1.r = -1., z__1.i = -0.;
+ zhemm_("Left", uplo, n, m, &c_b2, &a[a_offset], lda, &work[1], n, &
+ z__1, &z__[z_offset], ldz);
+
+ result[1] = zlange_("1", n, m, &z__[z_offset], ldz, &rwork[1]) / anorm / (*n * ulp);
+
+ } else if (*itype == 3) {
+
+/* Norm of BAZ - ZD */
+
+ zhemm_("Left", uplo, n, m, &c_b2, &a[a_offset], lda, &z__[z_offset],
+ ldz, &c_b1, &work[1], n);
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ zdscal_(n, &d__[i__], &z__[i__ * z_dim1 + 1], &c__1);
+/* L30: */
+ }
+ z__1.r = -1., z__1.i = -0.;
+ zhemm_("Left", uplo, n, m, &c_b2, &b[b_offset], ldb, &work[1], n, &
+ z__1, &z__[z_offset], ldz);
+
+ result[1] = zlange_("1", n, m, &z__[z_offset], ldz, &rwork[1]) / anorm / (*n * ulp);
+ }
+
+ return 0;
+
+/* End of CDGT01 */
+
+} /* zsgt01_ */
diff --git a/TESTING/EIG/zslect.c b/TESTING/EIG/zslect.c
new file mode 100644
index 0000000..3b833ff
--- /dev/null
+++ b/TESTING/EIG/zslect.c
@@ -0,0 +1,109 @@
+/* zslect.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer selopt, seldim;
+ logical selval[20];
+ doublereal selwr[20], selwi[20];
+} sslct_;
+
+#define sslct_1 sslct_
+
+logical zslect_(doublecomplex *z__)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublecomplex z__1, z__2;
+ logical ret_val;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+
+ /* Local variables */
+ integer i__;
+ doublereal x, rmin;
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSLECT returns .TRUE. if the eigenvalue Z is to be selected, */
+/* otherwise it returns .FALSE. */
+/* It is used by ZCHK41 to test if ZGEES succesfully sorts eigenvalues, */
+/* and by ZCHK43 to test if ZGEESX succesfully sorts eigenvalues. */
+
+/* The common block /SSLCT/ controls how eigenvalues are selected. */
+/* If SELOPT = 0, then ZSLECT return .TRUE. when real(Z) is less than */
+/* zero, and .FALSE. otherwise. */
+/* If SELOPT is at least 1, ZSLECT returns SELVAL(SELOPT) and adds 1 */
+/* to SELOPT, cycling back to 1 at SELMAX. */
+
+/* Arguments */
+/* ========= */
+
+/* Z (input) COMPLEX*16 */
+/* The eigenvalue Z. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (sslct_1.selopt == 0) {
+ ret_val = z__->r < 0.;
+ } else {
+ z__2.r = sslct_1.selwr[0], z__2.i = sslct_1.selwi[0];
+ z__1.r = z__->r - z__2.r, z__1.i = z__->i - z__2.i;
+ rmin = z_abs(&z__1);
+ ret_val = sslct_1.selval[0];
+ i__1 = sslct_1.seldim;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__ - 1;
+ i__3 = i__ - 1;
+ z__2.r = sslct_1.selwr[i__2], z__2.i = sslct_1.selwi[i__3];
+ z__1.r = z__->r - z__2.r, z__1.i = z__->i - z__2.i;
+ x = z_abs(&z__1);
+ if (x <= rmin) {
+ rmin = x;
+ ret_val = sslct_1.selval[i__ - 1];
+ }
+/* L10: */
+ }
+ }
+ return ret_val;
+
+/* End of ZSLECT */
+
+} /* zslect_ */
diff --git a/TESTING/EIG/zstt21.c b/TESTING/EIG/zstt21.c
new file mode 100644
index 0000000..2888a7c
--- /dev/null
+++ b/TESTING/EIG/zstt21.c
@@ -0,0 +1,260 @@
+/* zstt21.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zstt21_(integer *n, integer *kband, doublereal *ad,
+ doublereal *ae, doublereal *sd, doublereal *se, doublecomplex *u,
+ integer *ldu, doublecomplex *work, doublereal *rwork, doublereal *
+ result)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2, d__3;
+ doublecomplex z__1, z__2;
+
+ /* Local variables */
+ integer j;
+ doublereal ulp, unfl;
+ extern /* Subroutine */ int zher_(char *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal temp1, temp2;
+ extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ doublereal anorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ doublereal wnorm;
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *),
+ zlanhe_(char *, char *, integer *, doublecomplex *, integer *,
+ doublereal *);
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSTT21 checks a decomposition of the form */
+
+/* A = U S U* */
+
+/* where * means conjugate transpose, A is real symmetric tridiagonal, */
+/* U is unitary, and S is real and diagonal (if KBAND=0) or symmetric */
+/* tridiagonal (if KBAND=1). Two tests are performed: */
+
+/* RESULT(1) = | A - U S U* | / ( |A| n ulp ) */
+
+/* RESULT(2) = | I - UU* | / ( n ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, ZSTT21 does nothing. */
+/* It must be at least zero. */
+
+/* KBAND (input) INTEGER */
+/* The bandwidth of the matrix S. It may only be zero or one. */
+/* If zero, then S is diagonal, and SE is not referenced. If */
+/* one, then S is symmetric tri-diagonal. */
+
+/* AD (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal of the original (unfactored) matrix A. A is */
+/* assumed to be real symmetric tridiagonal. */
+
+/* AE (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The off-diagonal of the original (unfactored) matrix A. A */
+/* is assumed to be symmetric tridiagonal. AE(1) is the (1,2) */
+/* and (2,1) element, AE(2) is the (2,3) and (3,2) element, etc. */
+
+/* SD (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal of the real (symmetric tri-) diagonal matrix S. */
+
+/* SE (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The off-diagonal of the (symmetric tri-) diagonal matrix S. */
+/* Not referenced if KBSND=0. If KBAND=1, then AE(1) is the */
+/* (1,2) and (2,1) element, SE(2) is the (2,3) and (3,2) */
+/* element, etc. */
+
+/* U (input) COMPLEX*16 array, dimension (LDU, N) */
+/* The unitary matrix in the decomposition. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N**2) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+/* RESULT(1) is always modified. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Constants */
+
+ /* Parameter adjustments */
+ --ad;
+ --ae;
+ --sd;
+ --se;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.;
+ result[2] = 0.;
+ if (*n <= 0) {
+ return 0;
+ }
+
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Precision");
+
+/* Do Test 1 */
+
+/* Copy A & Compute its 1-Norm: */
+
+ zlaset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
+
+ anorm = 0.;
+ temp1 = 0.;
+
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (*n + 1) * (j - 1) + 1;
+ i__3 = j;
+ work[i__2].r = ad[i__3], work[i__2].i = 0.;
+ i__2 = (*n + 1) * (j - 1) + 2;
+ i__3 = j;
+ work[i__2].r = ae[i__3], work[i__2].i = 0.;
+ temp2 = (d__1 = ae[j], abs(d__1));
+/* Computing MAX */
+ d__2 = anorm, d__3 = (d__1 = ad[j], abs(d__1)) + temp1 + temp2;
+ anorm = max(d__2,d__3);
+ temp1 = temp2;
+/* L10: */
+ }
+
+/* Computing 2nd power */
+ i__2 = *n;
+ i__1 = i__2 * i__2;
+ i__3 = *n;
+ work[i__1].r = ad[i__3], work[i__1].i = 0.;
+/* Computing MAX */
+ d__2 = anorm, d__3 = (d__1 = ad[*n], abs(d__1)) + temp1, d__2 = max(d__2,
+ d__3);
+ anorm = max(d__2,unfl);
+
+/* Norm of A - USU* */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ d__1 = -sd[j];
+ zher_("L", n, &d__1, &u[j * u_dim1 + 1], &c__1, &work[1], n);
+/* L20: */
+ }
+
+ if (*n > 1 && *kband == 1) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ z__2.r = se[i__2], z__2.i = 0.;
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ zher2_("L", n, &z__1, &u[j * u_dim1 + 1], &c__1, &u[(j + 1) *
+ u_dim1 + 1], &c__1, &work[1], n);
+/* L30: */
+ }
+ }
+
+ wnorm = zlanhe_("1", "L", n, &work[1], n, &rwork[1])
+ ;
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*n * ulp);
+ } else {
+ if (anorm < 1.) {
+/* Computing MIN */
+ d__1 = wnorm, d__2 = *n * anorm;
+ result[1] = min(d__1,d__2) / anorm / (*n * ulp);
+ } else {
+/* Computing MIN */
+ d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
+ result[1] = min(d__1,d__2) / (*n * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute UU* - I */
+
+ zgemm_("N", "C", n, n, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu, &
+ c_b1, &work[1], n);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (*n + 1) * (j - 1) + 1;
+ i__3 = (*n + 1) * (j - 1) + 1;
+ z__1.r = work[i__3].r - 1., z__1.i = work[i__3].i - 0.;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L40: */
+ }
+
+/* Computing MIN */
+ d__1 = (doublereal) (*n), d__2 = zlange_("1", n, n, &work[1], n, &rwork[1]
+);
+ result[2] = min(d__1,d__2) / (*n * ulp);
+
+ return 0;
+
+/* End of ZSTT21 */
+
+} /* zstt21_ */
diff --git a/TESTING/EIG/zstt22.c b/TESTING/EIG/zstt22.c
new file mode 100644
index 0000000..cc8902f
--- /dev/null
+++ b/TESTING/EIG/zstt22.c
@@ -0,0 +1,291 @@
+/* zstt22.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+
+/* Subroutine */ int zstt22_(integer *n, integer *m, integer *kband,
+ doublereal *ad, doublereal *ae, doublereal *sd, doublereal *se,
+ doublecomplex *u, integer *ldu, doublecomplex *work, integer *ldwork,
+ doublereal *rwork, doublereal *result)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, work_dim1, work_offset, i__1, i__2, i__3, i__4,
+ i__5, i__6;
+ doublereal d__1, d__2, d__3, d__4, d__5;
+ doublecomplex z__1, z__2;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal ulp;
+ doublecomplex aukj;
+ doublereal unfl, anorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ doublereal wnorm;
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *),
+ zlansy_(char *, char *, integer *, doublecomplex *, integer *,
+ doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSTT22 checks a set of M eigenvalues and eigenvectors, */
+
+/* A U = U S */
+
+/* where A is Hermitian tridiagonal, the columns of U are unitary, */
+/* and S is diagonal (if KBAND=0) or Hermitian tridiagonal (if KBAND=1). */
+/* Two tests are performed: */
+
+/* RESULT(1) = | U* A U - S | / ( |A| m ulp ) */
+
+/* RESULT(2) = | I - U*U | / ( m ulp ) */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The size of the matrix. If it is zero, ZSTT22 does nothing. */
+/* It must be at least zero. */
+
+/* M (input) INTEGER */
+/* The number of eigenpairs to check. If it is zero, ZSTT22 */
+/* does nothing. It must be at least zero. */
+
+/* KBAND (input) INTEGER */
+/* The bandwidth of the matrix S. It may only be zero or one. */
+/* If zero, then S is diagonal, and SE is not referenced. If */
+/* one, then S is Hermitian tri-diagonal. */
+
+/* AD (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal of the original (unfactored) matrix A. A is */
+/* assumed to be Hermitian tridiagonal. */
+
+/* AE (input) DOUBLE PRECISION array, dimension (N) */
+/* The off-diagonal of the original (unfactored) matrix A. A */
+/* is assumed to be Hermitian tridiagonal. AE(1) is ignored, */
+/* AE(2) is the (1,2) and (2,1) element, etc. */
+
+/* SD (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal of the (Hermitian tri-) diagonal matrix S. */
+
+/* SE (input) DOUBLE PRECISION array, dimension (N) */
+/* The off-diagonal of the (Hermitian tri-) diagonal matrix S. */
+/* Not referenced if KBSND=0. If KBAND=1, then AE(1) is */
+/* ignored, SE(2) is the (1,2) and (2,1) element, etc. */
+
+/* U (input) DOUBLE PRECISION array, dimension (LDU, N) */
+/* The unitary matrix in the decomposition. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. LDU must be at least N. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LDWORK, M+1) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of WORK. LDWORK must be at least */
+/* max(1,M). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The values computed by the two tests described above. The */
+/* values are currently limited to 1/ulp, to avoid overflow. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --ad;
+ --ae;
+ --sd;
+ --se;
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ result[1] = 0.;
+ result[2] = 0.;
+ if (*n <= 0 || *m <= 0) {
+ return 0;
+ }
+
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon");
+
+/* Do Test 1 */
+
+/* Compute the 1-norm of A. */
+
+ if (*n > 1) {
+ anorm = abs(ad[1]) + abs(ae[1]);
+ i__1 = *n - 1;
+ for (j = 2; j <= i__1; ++j) {
+/* Computing MAX */
+ d__4 = anorm, d__5 = (d__1 = ad[j], abs(d__1)) + (d__2 = ae[j],
+ abs(d__2)) + (d__3 = ae[j - 1], abs(d__3));
+ anorm = max(d__4,d__5);
+/* L10: */
+ }
+/* Computing MAX */
+ d__3 = anorm, d__4 = (d__1 = ad[*n], abs(d__1)) + (d__2 = ae[*n - 1],
+ abs(d__2));
+ anorm = max(d__3,d__4);
+ } else {
+ anorm = abs(ad[1]);
+ }
+ anorm = max(anorm,unfl);
+
+/* Norm of U*AU - S */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *m;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * work_dim1;
+ work[i__3].r = 0., work[i__3].i = 0.;
+ i__3 = *n;
+ for (k = 1; k <= i__3; ++k) {
+ i__4 = k;
+ i__5 = k + j * u_dim1;
+ z__1.r = ad[i__4] * u[i__5].r, z__1.i = ad[i__4] * u[i__5].i;
+ aukj.r = z__1.r, aukj.i = z__1.i;
+ if (k != *n) {
+ i__4 = k;
+ i__5 = k + 1 + j * u_dim1;
+ z__2.r = ae[i__4] * u[i__5].r, z__2.i = ae[i__4] * u[i__5]
+ .i;
+ z__1.r = aukj.r + z__2.r, z__1.i = aukj.i + z__2.i;
+ aukj.r = z__1.r, aukj.i = z__1.i;
+ }
+ if (k != 1) {
+ i__4 = k - 1;
+ i__5 = k - 1 + j * u_dim1;
+ z__2.r = ae[i__4] * u[i__5].r, z__2.i = ae[i__4] * u[i__5]
+ .i;
+ z__1.r = aukj.r + z__2.r, z__1.i = aukj.i + z__2.i;
+ aukj.r = z__1.r, aukj.i = z__1.i;
+ }
+ i__4 = i__ + j * work_dim1;
+ i__5 = i__ + j * work_dim1;
+ i__6 = k + i__ * u_dim1;
+ z__2.r = u[i__6].r * aukj.r - u[i__6].i * aukj.i, z__2.i = u[
+ i__6].r * aukj.i + u[i__6].i * aukj.r;
+ z__1.r = work[i__5].r + z__2.r, z__1.i = work[i__5].i +
+ z__2.i;
+ work[i__4].r = z__1.r, work[i__4].i = z__1.i;
+/* L20: */
+ }
+/* L30: */
+ }
+ i__2 = i__ + i__ * work_dim1;
+ i__3 = i__ + i__ * work_dim1;
+ i__4 = i__;
+ z__1.r = work[i__3].r - sd[i__4], z__1.i = work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ if (*kband == 1) {
+ if (i__ != 1) {
+ i__2 = i__ + (i__ - 1) * work_dim1;
+ i__3 = i__ + (i__ - 1) * work_dim1;
+ i__4 = i__ - 1;
+ z__1.r = work[i__3].r - se[i__4], z__1.i = work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ if (i__ != *n) {
+ i__2 = i__ + (i__ + 1) * work_dim1;
+ i__3 = i__ + (i__ + 1) * work_dim1;
+ i__4 = i__;
+ z__1.r = work[i__3].r - se[i__4], z__1.i = work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ }
+ }
+/* L40: */
+ }
+
+ wnorm = zlansy_("1", "L", m, &work[work_offset], m, &rwork[1]);
+
+ if (anorm > wnorm) {
+ result[1] = wnorm / anorm / (*m * ulp);
+ } else {
+ if (anorm < 1.) {
+/* Computing MIN */
+ d__1 = wnorm, d__2 = *m * anorm;
+ result[1] = min(d__1,d__2) / anorm / (*m * ulp);
+ } else {
+/* Computing MIN */
+ d__1 = wnorm / anorm, d__2 = (doublereal) (*m);
+ result[1] = min(d__1,d__2) / (*m * ulp);
+ }
+ }
+
+/* Do Test 2 */
+
+/* Compute U*U - I */
+
+ zgemm_("T", "N", m, m, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu, &
+ c_b1, &work[work_offset], m);
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * work_dim1;
+ i__3 = j + j * work_dim1;
+ z__1.r = work[i__3].r - 1., z__1.i = work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L50: */
+ }
+
+/* Computing MIN */
+ d__1 = (doublereal) (*m), d__2 = zlange_("1", m, m, &work[work_offset], m,
+ &rwork[1]);
+ result[2] = min(d__1,d__2) / (*m * ulp);
+
+ return 0;
+
+/* End of ZSTT22 */
+
+} /* zstt22_ */
diff --git a/TESTING/EIG/zunt01.c b/TESTING/EIG/zunt01.c
new file mode 100644
index 0000000..3748ef8
--- /dev/null
+++ b/TESTING/EIG/zunt01.c
@@ -0,0 +1,240 @@
+/* zunt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b7 = {0.,0.};
+static doublecomplex c_b8 = {1.,0.};
+static doublereal c_b10 = -1.;
+static doublereal c_b11 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int zunt01_(char *rowcol, integer *m, integer *n,
+ doublecomplex *u, integer *ldu, doublecomplex *work, integer *lwork,
+ doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, i__1, i__2;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal eps;
+ doublecomplex tmp;
+ extern logical lsame_(char *, char *);
+ integer mnmin;
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zherk_(char *, char *, integer *, integer *,
+ doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ integer ldwork;
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+ char transu[1];
+ extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNT01 checks that the matrix U is unitary by computing the ratio */
+
+/* RESID = norm( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R', */
+/* or */
+/* RESID = norm( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'. */
+
+/* Alternatively, if there isn't sufficient workspace to form */
+/* I - U*U' or I - U'*U, the ratio is computed as */
+
+/* RESID = abs( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R', */
+/* or */
+/* RESID = abs( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'. */
+
+/* where EPS is the machine precision. ROWCOL is used only if m = n; */
+/* if m > n, ROWCOL is assumed to be 'C', and if m < n, ROWCOL is */
+/* assumed to be 'R'. */
+
+/* Arguments */
+/* ========= */
+
+/* ROWCOL (input) CHARACTER */
+/* Specifies whether the rows or columns of U should be checked */
+/* for orthogonality. Used only if M = N. */
+/* = 'R': Check for orthogonal rows of U */
+/* = 'C': Check for orthogonal columns of U */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix U. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix U. */
+
+/* U (input) COMPLEX*16 array, dimension (LDU,N) */
+/* The unitary matrix U. U is checked for orthogonal columns */
+/* if m > n or if m = n and ROWCOL = 'C'. U is checked for */
+/* orthogonal rows if m < n or if m = n and ROWCOL = 'R'. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of the array U. LDU >= max(1,M). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. For best performance, LWORK */
+/* should be at least N*N if ROWCOL = 'C' or M*M if */
+/* ROWCOL = 'R', but the test will be done even if LWORK is 0. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* Used only if LWORK is large enough to use the Level 3 BLAS */
+/* code. */
+
+/* RESID (output) DOUBLE PRECISION */
+/* RESID = norm( I - U * U' ) / ( n * EPS ), if ROWCOL = 'R', or */
+/* RESID = norm( I - U' * U ) / ( m * EPS ), if ROWCOL = 'C'. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *resid = 0.;
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+ eps = dlamch_("Precision");
+ if (*m < *n || *m == *n && lsame_(rowcol, "R")) {
+ *(unsigned char *)transu = 'N';
+ k = *n;
+ } else {
+ *(unsigned char *)transu = 'C';
+ k = *m;
+ }
+ mnmin = min(*m,*n);
+
+ if ((mnmin + 1) * mnmin <= *lwork) {
+ ldwork = mnmin;
+ } else {
+ ldwork = 0;
+ }
+ if (ldwork > 0) {
+
+/* Compute I - U*U' or I - U'*U. */
+
+ zlaset_("Upper", &mnmin, &mnmin, &c_b7, &c_b8, &work[1], &ldwork);
+ zherk_("Upper", transu, &mnmin, &k, &c_b10, &u[u_offset], ldu, &c_b11,
+ &work[1], &ldwork);
+
+/* Compute norm( I - U*U' ) / ( K * EPS ) . */
+
+ *resid = zlansy_("1", "Upper", &mnmin, &work[1], &ldwork, &rwork[1]);
+ *resid = *resid / (doublereal) k / eps;
+ } else if (*(unsigned char *)transu == 'C') {
+
+/* Find the maximum element in abs( I - U'*U ) / ( m * EPS ) */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (i__ != j) {
+ tmp.r = 0., tmp.i = 0.;
+ } else {
+ tmp.r = 1., tmp.i = 0.;
+ }
+ zdotc_(&z__2, m, &u[i__ * u_dim1 + 1], &c__1, &u[j * u_dim1 +
+ 1], &c__1);
+ z__1.r = tmp.r - z__2.r, z__1.i = tmp.i - z__2.i;
+ tmp.r = z__1.r, tmp.i = z__1.i;
+/* Computing MAX */
+ d__3 = *resid, d__4 = (d__1 = tmp.r, abs(d__1)) + (d__2 =
+ d_imag(&tmp), abs(d__2));
+ *resid = max(d__3,d__4);
+/* L10: */
+ }
+/* L20: */
+ }
+ *resid = *resid / (doublereal) (*m) / eps;
+ } else {
+
+/* Find the maximum element in abs( I - U*U' ) / ( n * EPS ) */
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (i__ != j) {
+ tmp.r = 0., tmp.i = 0.;
+ } else {
+ tmp.r = 1., tmp.i = 0.;
+ }
+ zdotc_(&z__2, n, &u[j + u_dim1], ldu, &u[i__ + u_dim1], ldu);
+ z__1.r = tmp.r - z__2.r, z__1.i = tmp.i - z__2.i;
+ tmp.r = z__1.r, tmp.i = z__1.i;
+/* Computing MAX */
+ d__3 = *resid, d__4 = (d__1 = tmp.r, abs(d__1)) + (d__2 =
+ d_imag(&tmp), abs(d__2));
+ *resid = max(d__3,d__4);
+/* L30: */
+ }
+/* L40: */
+ }
+ *resid = *resid / (doublereal) (*n) / eps;
+ }
+ return 0;
+
+/* End of ZUNT01 */
+
+} /* zunt01_ */
diff --git a/TESTING/EIG/zunt03.c b/TESTING/EIG/zunt03.c
new file mode 100644
index 0000000..bd9f4fa
--- /dev/null
+++ b/TESTING/EIG/zunt03.c
@@ -0,0 +1,312 @@
+/* zunt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zunt03_(char *rc, integer *mu, integer *mv, integer *n,
+ integer *k, doublecomplex *u, integer *ldu, doublecomplex *v, integer
+ *ldv, doublecomplex *work, integer *lwork, doublereal *rwork,
+ doublereal *result, integer *info)
+{
+ /* System generated locals */
+ integer u_dim1, u_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublecomplex s, su, sv;
+ integer irc, lmx;
+ doublereal ulp, res1, res2;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zunt01_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZUNT03 compares two unitary matrices U and V to see if their */
+/* corresponding rows or columns span the same spaces. The rows are */
+/* checked if RC = 'R', and the columns are checked if RC = 'C'. */
+
+/* RESULT is the maximum of */
+
+/* | V*V' - I | / ( MV ulp ), if RC = 'R', or */
+
+/* | V'*V - I | / ( MV ulp ), if RC = 'C', */
+
+/* and the maximum over rows (or columns) 1 to K of */
+
+/* | U(i) - S*V(i) |/ ( N ulp ) */
+
+/* where abs(S) = 1 (chosen to minimize the expression), U(i) is the */
+/* i-th row (column) of U, and V(i) is the i-th row (column) of V. */
+
+/* Arguments */
+/* ========== */
+
+/* RC (input) CHARACTER*1 */
+/* If RC = 'R' the rows of U and V are to be compared. */
+/* If RC = 'C' the columns of U and V are to be compared. */
+
+/* MU (input) INTEGER */
+/* The number of rows of U if RC = 'R', and the number of */
+/* columns if RC = 'C'. If MU = 0 ZUNT03 does nothing. */
+/* MU must be at least zero. */
+
+/* MV (input) INTEGER */
+/* The number of rows of V if RC = 'R', and the number of */
+/* columns if RC = 'C'. If MV = 0 ZUNT03 does nothing. */
+/* MV must be at least zero. */
+
+/* N (input) INTEGER */
+/* If RC = 'R', the number of columns in the matrices U and V, */
+/* and if RC = 'C', the number of rows in U and V. If N = 0 */
+/* ZUNT03 does nothing. N must be at least zero. */
+
+/* K (input) INTEGER */
+/* The number of rows or columns of U and V to compare. */
+/* 0 <= K <= max(MU,MV). */
+
+/* U (input) COMPLEX*16 array, dimension (LDU,N) */
+/* The first matrix to compare. If RC = 'R', U is MU by N, and */
+/* if RC = 'C', U is N by MU. */
+
+/* LDU (input) INTEGER */
+/* The leading dimension of U. If RC = 'R', LDU >= max(1,MU), */
+/* and if RC = 'C', LDU >= max(1,N). */
+
+/* V (input) COMPLEX*16 array, dimension (LDV,N) */
+/* The second matrix to compare. If RC = 'R', V is MV by N, and */
+/* if RC = 'C', V is N by MV. */
+
+/* LDV (input) INTEGER */
+/* The leading dimension of V. If RC = 'R', LDV >= max(1,MV), */
+/* and if RC = 'C', LDV >= max(1,N). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. For best performance, LWORK */
+/* should be at least N*N if RC = 'C' or M*M if RC = 'R', but */
+/* the tests will be done even if LWORK is 0. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(MV,N)) */
+
+/* RESULT (output) DOUBLE PRECISION */
+/* The value computed by the test described above. RESULT is */
+/* limited to 1/ulp to avoid overflow. */
+
+/* INFO (output) INTEGER */
+/* 0 indicates a successful exit */
+/* -k indicates the k-th parameter had an illegal value */
+
+/* ===================================================================== */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Check inputs */
+
+ /* Parameter adjustments */
+ u_dim1 = *ldu;
+ u_offset = 1 + u_dim1;
+ u -= u_offset;
+ v_dim1 = *ldv;
+ v_offset = 1 + v_dim1;
+ v -= v_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ *info = 0;
+ if (lsame_(rc, "R")) {
+ irc = 0;
+ } else if (lsame_(rc, "C")) {
+ irc = 1;
+ } else {
+ irc = -1;
+ }
+ if (irc == -1) {
+ *info = -1;
+ } else if (*mu < 0) {
+ *info = -2;
+ } else if (*mv < 0) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*k < 0 || *k > max(*mu,*mv)) {
+ *info = -5;
+ } else if (irc == 0 && *ldu < max(1,*mu) || irc == 1 && *ldu < max(1,*n))
+ {
+ *info = -7;
+ } else if (irc == 0 && *ldv < max(1,*mv) || irc == 1 && *ldv < max(1,*n))
+ {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZUNT03", &i__1);
+ return 0;
+ }
+
+/* Initialize result */
+
+ *result = 0.;
+ if (*mu == 0 || *mv == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Machine constants */
+
+ ulp = dlamch_("Precision");
+
+ if (irc == 0) {
+
+/* Compare rows */
+
+ res1 = 0.;
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ lmx = izamax_(n, &u[i__ + u_dim1], ldu);
+ i__2 = i__ + lmx * v_dim1;
+ if (v[i__2].r == 0. && v[i__2].i == 0.) {
+ sv.r = 1., sv.i = 0.;
+ } else {
+ d__1 = z_abs(&v[i__ + lmx * v_dim1]);
+ z__2.r = d__1, z__2.i = 0.;
+ z_div(&z__1, &z__2, &v[i__ + lmx * v_dim1]);
+ sv.r = z__1.r, sv.i = z__1.i;
+ }
+ i__2 = i__ + lmx * u_dim1;
+ if (u[i__2].r == 0. && u[i__2].i == 0.) {
+ su.r = 1., su.i = 0.;
+ } else {
+ d__1 = z_abs(&u[i__ + lmx * u_dim1]);
+ z__2.r = d__1, z__2.i = 0.;
+ z_div(&z__1, &z__2, &u[i__ + lmx * u_dim1]);
+ su.r = z__1.r, su.i = z__1.i;
+ }
+ z_div(&z__1, &sv, &su);
+ s.r = z__1.r, s.i = z__1.i;
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ i__3 = i__ + j * u_dim1;
+ i__4 = i__ + j * v_dim1;
+ z__2.r = s.r * v[i__4].r - s.i * v[i__4].i, z__2.i = s.r * v[
+ i__4].i + s.i * v[i__4].r;
+ z__1.r = u[i__3].r - z__2.r, z__1.i = u[i__3].i - z__2.i;
+ d__1 = res1, d__2 = z_abs(&z__1);
+ res1 = max(d__1,d__2);
+/* L10: */
+ }
+/* L20: */
+ }
+ res1 /= (doublereal) (*n) * ulp;
+
+/* Compute orthogonality of rows of V. */
+
+ zunt01_("Rows", mv, n, &v[v_offset], ldv, &work[1], lwork, &rwork[1],
+ &res2);
+
+ } else {
+
+/* Compare columns */
+
+ res1 = 0.;
+ i__1 = *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ lmx = izamax_(n, &u[i__ * u_dim1 + 1], &c__1);
+ i__2 = lmx + i__ * v_dim1;
+ if (v[i__2].r == 0. && v[i__2].i == 0.) {
+ sv.r = 1., sv.i = 0.;
+ } else {
+ d__1 = z_abs(&v[lmx + i__ * v_dim1]);
+ z__2.r = d__1, z__2.i = 0.;
+ z_div(&z__1, &z__2, &v[lmx + i__ * v_dim1]);
+ sv.r = z__1.r, sv.i = z__1.i;
+ }
+ i__2 = lmx + i__ * u_dim1;
+ if (u[i__2].r == 0. && u[i__2].i == 0.) {
+ su.r = 1., su.i = 0.;
+ } else {
+ d__1 = z_abs(&u[lmx + i__ * u_dim1]);
+ z__2.r = d__1, z__2.i = 0.;
+ z_div(&z__1, &z__2, &u[lmx + i__ * u_dim1]);
+ su.r = z__1.r, su.i = z__1.i;
+ }
+ z_div(&z__1, &sv, &su);
+ s.r = z__1.r, s.i = z__1.i;
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MAX */
+ i__3 = j + i__ * u_dim1;
+ i__4 = j + i__ * v_dim1;
+ z__2.r = s.r * v[i__4].r - s.i * v[i__4].i, z__2.i = s.r * v[
+ i__4].i + s.i * v[i__4].r;
+ z__1.r = u[i__3].r - z__2.r, z__1.i = u[i__3].i - z__2.i;
+ d__1 = res1, d__2 = z_abs(&z__1);
+ res1 = max(d__1,d__2);
+/* L30: */
+ }
+/* L40: */
+ }
+ res1 /= (doublereal) (*n) * ulp;
+
+/* Compute orthogonality of columns of V. */
+
+ zunt01_("Columns", n, mv, &v[v_offset], ldv, &work[1], lwork, &rwork[
+ 1], &res2);
+ }
+
+/* Computing MIN */
+ d__1 = max(res1,res2), d__2 = 1. / ulp;
+ *result = min(d__1,d__2);
+ return 0;
+
+/* End of ZUNT03 */
+
+} /* zunt03_ */
diff --git a/TESTING/LIN/CMakeLists.txt b/TESTING/LIN/CMakeLists.txt
new file mode 100644
index 0000000..d5c20cf
--- /dev/null
+++ b/TESTING/LIN/CMakeLists.txt
@@ -0,0 +1,223 @@
+set(ALINTST
+ aladhd.c alaerh.c alaesm.c alahd.c alareq.c
+ alasum.c alasvm.c chkxer.c icopy.c ilaenv.c xlaenv.c xerbla.c)
+
+set(SCLNTST slaord.c)
+
+set(DZLNTST dlaord.c )
+
+set(SLINTST schkaa.c
+ schkeq.c schkgb.c schkge.c schkgt.c
+ schklq.c schkpb.c schkpo.c schkps.c schkpp.c
+ schkpt.c schkq3.c schkql.c schkqp.c schkqr.c schkrq.c
+ schksp.c schksy.c schktb.c schktp.c schktr.c
+ schktz.c
+ sdrvgt.c sdrvls.c sdrvpb.c
+ sdrvpp.c sdrvpt.c sdrvsp.c sdrvsy.c
+ serrgt.c serrlq.c serrls.c
+ serrpo.c serrps.c serrql.c serrqp.c serrqr.c
+ serrrq.c serrsy.c serrtr.c serrtz.c serrvx.c
+ sgbt01.c sgbt02.c sgbt05.c sgelqs.c sgeqls.c sgeqrs.c
+ sgerqs.c sget01.c sget02.c
+ sget03.c sget04.c sget06.c sget07.c sgtt01.c sgtt02.c
+ sgtt05.c slaptm.c slarhs.c slatb4.c slatb5.c slattb.c slattp.c
+ slattr.c slavsp.c slavsy.c slqt01.c slqt02.c
+ slqt03.c spbt01.c spbt02.c spbt05.c spot01.c
+ spot02.c spot03.c spot05.c spst01.c sppt01.c
+ sppt02.c sppt03.c sppt05.c sptt01.c sptt02.c
+ sptt05.c sqlt01.c sqlt02.c sqlt03.c sqpt01.c
+ sqrt01.c sqrt02.c sqrt03.c sqrt11.c sqrt12.c
+ sqrt13.c sqrt14.c sqrt15.c sqrt16.c sqrt17.c
+ srqt01.c srqt02.c srqt03.c srzt01.c srzt02.c
+ sspt01.c ssyt01.c
+ stbt02.c stbt03.c stbt05.c stbt06.c stpt01.c
+ stpt02.c stpt03.c stpt05.c stpt06.c strt01.c
+ strt02.c strt03.c strt05.c strt06.c
+ stzt01.c stzt02.c sgennd.c)
+
+if(USEXBLAS)
+ list(APPEND SLINTST sdrvgex.c serrgex.c sdrvgbx.c sdrvpox.c sebchvxx.c)
+else()
+ list(APPEND SLINTST sdrvge.c serrge.c sdrvgb.c sdrvpo.c)
+endif()
+
+set(CLINTST cchkaa.c
+ cchkeq.c cchkgb.c cchkge.c cchkgt.c
+ cchkhe.c cchkhp.c cchklq.c cchkpb.c
+ cchkpo.c cchkps.c cchkpp.c cchkpt.c cchkq3.c cchkql.c cchkqp.c
+ cchkqr.c cchkrq.c cchksp.c cchksy.c cchktb.c
+ cchktp.c cchktr.c cchktz.c
+ cdrvgt.c cdrvhe.c cdrvhp.c
+ cdrvls.c cdrvpb.c cdrvpp.c cdrvpt.c
+ cdrvsp.c cdrvsy.c
+ cerrgt.c cerrhe.c cerrlq.c
+ cerrls.c cerrps.c cerrql.c cerrqp.c
+ cerrqr.c cerrrq.c cerrsy.c cerrtr.c cerrtz.c
+ cerrvx.c
+ cgbt01.c cgbt02.c cgbt05.c cgelqs.c cgeqls.c cgeqrs.c
+ cgerqs.c cget01.c cget02.c
+ cget03.c cget04.c cget07.c cgtt01.c cgtt02.c
+ cgtt05.c chet01.c chpt01.c claipd.c claptm.c clarhs.c clatb4.c clatb5.c
+ clatsp.c clatsy.c clattb.c clattp.c clattr.c
+ clavhe.c clavhp.c clavsp.c clavsy.c clqt01.c
+ clqt02.c clqt03.c cpbt01.c cpbt02.c cpbt05.c
+ cpot01.c cpot02.c cpot03.c cpot05.c cpst01.c
+ cppt01.c cppt02.c cppt03.c cppt05.c cptt01.c
+ cptt02.c cptt05.c cqlt01.c cqlt02.c cqlt03.c
+ cqpt01.c cqrt01.c cqrt02.c cqrt03.c cqrt11.c
+ cqrt12.c cqrt13.c cqrt14.c cqrt15.c cqrt16.c
+ cqrt17.c crqt01.c crqt02.c crqt03.c crzt01.c crzt02.c
+ csbmv.c cspt01.c
+ cspt02.c cspt03.c csyt01.c csyt02.c csyt03.c
+ ctbt02.c ctbt03.c ctbt05.c ctbt06.c ctpt01.c
+ ctpt02.c ctpt03.c ctpt05.c ctpt06.c ctrt01.c
+ ctrt02.c ctrt03.c ctrt05.c ctrt06.c
+ ctzt01.c ctzt02.c sget06.c cgennd.c)
+
+if(USEXBLAS)
+ list(APPEND
+ CLINTST cdrvgex.c cdrvgbx.c cerrgex.c cdrvpox.c cerrpox.c cebchvxx.c)
+else()
+ list(APPEND CLINTST cdrvge.c cdrvgb.c cerrge.c cdrvpo.c cerrpo.c)
+endif()
+
+set(DLINTST dchkaa.c
+ dchkeq.c dchkgb.c dchkge.c dchkgt.c
+ dchklq.c dchkpb.c dchkpo.c dchkps.c dchkpp.c
+ dchkpt.c dchkq3.c dchkql.c dchkqp.c dchkqr.c dchkrq.c
+ dchksp.c dchksy.c dchktb.c dchktp.c dchktr.c
+ dchktz.c
+ ddrvgt.c ddrvls.c ddrvpb.c
+ ddrvpp.c ddrvpt.c ddrvsp.c ddrvsy.c
+ derrgt.c derrlq.c derrls.c
+ derrps.c derrql.c derrqp.c derrqr.c
+ derrrq.c derrsy.c derrtr.c derrtz.c derrvx.c
+ dgbt01.c dgbt02.c dgbt05.c dgelqs.c dgeqls.c dgeqrs.c
+ dgerqs.c dget01.c dget02.c
+ dget03.c dget04.c dget06.c dget07.c dgtt01.c dgtt02.c
+ dgtt05.c dlaptm.c dlarhs.c dlatb4.c dlatb5.c dlattb.c dlattp.c
+ dlattr.c dlavsp.c dlavsy.c dlqt01.c dlqt02.c
+ dlqt03.c dpbt01.c dpbt02.c dpbt05.c dpot01.c
+ dpot02.c dpot03.c dpot05.c dpst01.c dppt01.c
+ dppt02.c dppt03.c dppt05.c dptt01.c dptt02.c
+ dptt05.c dqlt01.c dqlt02.c dqlt03.c dqpt01.c
+ dqrt01.c dqrt02.c dqrt03.c dqrt11.c dqrt12.c
+ dqrt13.c dqrt14.c dqrt15.c dqrt16.c dqrt17.c
+ drqt01.c drqt02.c drqt03.c drzt01.c drzt02.c
+ dspt01.c dsyt01.c
+ dtbt02.c dtbt03.c dtbt05.c dtbt06.c dtpt01.c
+ dtpt02.c dtpt03.c dtpt05.c dtpt06.c dtrt01.c
+ dtrt02.c dtrt03.c dtrt05.c dtrt06.c
+ dtzt01.c dtzt02.c dgennd.c)
+
+if(USEXBLAS)
+ list(APPEND
+ DLINTST ddrvgex.c ddrvgbx.c derrgex.c ddrvpox.c derrpox.c debchvxx.c)
+else()
+ list(APPEND
+ DLINTST ddrvge.c ddrvgb.c derrge.c ddrvpo.c derrpo.c)
+endif()
+
+set(ZLINTST zchkaa.c
+ zchkeq.c zchkgb.c zchkge.c zchkgt.c
+ zchkhe.c zchkhp.c zchklq.c zchkpb.c
+ zchkpo.c zchkps.c zchkpp.c zchkpt.c zchkq3.c zchkql.c zchkqp.c
+ zchkqr.c zchkrq.c zchksp.c zchksy.c zchktb.c
+ zchktp.c zchktr.c zchktz.c
+ zdrvgt.c zdrvhe.c zdrvhp.c
+ zdrvls.c zdrvpb.c zdrvpp.c zdrvpt.c
+ zdrvsp.c zdrvsy.c
+ zerrgt.c zerrhe.c zerrlq.c
+ zerrls.c zerrps.c zerrql.c zerrqp.c
+ zerrqr.c zerrrq.c zerrsy.c zerrtr.c zerrtz.c
+ zerrvx.c
+ zgbt01.c zgbt02.c zgbt05.c zgelqs.c zgeqls.c zgeqrs.c
+ zgerqs.c zget01.c zget02.c
+ zget03.c zget04.c zget07.c zgtt01.c zgtt02.c
+ zgtt05.c zhet01.c zhpt01.c zlaipd.c zlaptm.c zlarhs.c zlatb4.c zlatb5.c
+ zlatsp.c zlatsy.c zlattb.c zlattp.c zlattr.c
+ zlavhe.c zlavhp.c zlavsp.c zlavsy.c zlqt01.c
+ zlqt02.c zlqt03.c zpbt01.c zpbt02.c zpbt05.c
+ zpot01.c zpot02.c zpot03.c zpot05.c zpst01.c
+ zppt01.c zppt02.c zppt03.c zppt05.c zptt01.c
+ zptt02.c zptt05.c zqlt01.c zqlt02.c zqlt03.c
+ zqpt01.c zqrt01.c zqrt02.c zqrt03.c zqrt11.c
+ zqrt12.c zqrt13.c zqrt14.c zqrt15.c zqrt16.c
+ zqrt17.c zrqt01.c zrqt02.c zrqt03.c zrzt01.c zrzt02.c
+ zsbmv.c zspt01.c
+ zspt02.c zspt03.c zsyt01.c zsyt02.c zsyt03.c
+ ztbt02.c ztbt03.c ztbt05.c ztbt06.c ztpt01.c
+ ztpt02.c ztpt03.c ztpt05.c ztpt06.c ztrt01.c
+ ztrt02.c ztrt03.c ztrt05.c ztrt06.c
+ ztzt01.c ztzt02.c dget06.c zgennd.c)
+
+if(USEXBLAS)
+ list(APPEND
+ ZLINTST zdrvgex.c zdrvgbx.c zerrgex.c zdrvpox.c zerrpox.c zebchvxx.c)
+else()
+ list(APPEND
+ ZLINTST zdrvge.c zdrvgb.c zerrge.c zdrvpo.c zerrpo.c)
+endif()
+
+set(DSLINTST dchkab.c
+ ddrvab.c ddrvac.c derrab.c derrac.c dget08.c
+ alaerh.c alahd.c aladhd.c alareq.c
+ chkxer.c dlarhs.c dlatb4.c xerbla.c
+ dget02.c dpot06.c)
+
+set(ZCLINTST zchkab.c
+ zdrvab.c zdrvac.c zerrab.c zerrac.c zget08.c
+ alaerh.c alahd.c aladhd.c alareq.c
+ chkxer.c zget02.c zlarhs.c zlatb4.c
+ zsbmv.c xerbla.c zpot06.c zlaipd.c)
+
+set(SLINTSTRFP schkrfp.c sdrvrfp.c sdrvrf1.c sdrvrf2.c sdrvrf3.c sdrvrf4.c serrrfp.c
+ slatb4.c slarhs.c sget04.c spot01.c spot03.c spot02.c
+ chkxer.c xerbla.c alaerh.c aladhd.c alahd.c alasvm.c )
+
+set(DLINTSTRFP dchkrfp.c ddrvrfp.c ddrvrf1.c ddrvrf2.c ddrvrf3.c ddrvrf4.c derrrfp.c
+ dlatb4.c dlarhs.c dget04.c dpot01.c dpot03.c dpot02.c
+ chkxer.c xerbla.c alaerh.c aladhd.c alahd.c alasvm.c )
+
+set(CLINTSTRFP cchkrfp.c cdrvrfp.c cdrvrf1.c cdrvrf2.c cdrvrf3.c cdrvrf4.c cerrrfp.c
+ claipd.c clatb4.c clarhs.c csbmv.c cget04.c cpot01.c cpot03.c cpot02.c
+ chkxer.c xerbla.c alaerh.c aladhd.c alahd.c alasvm.c )
+
+set(ZLINTSTRFP zchkrfp.c zdrvrfp.c zdrvrf1.c zdrvrf2.c zdrvrf3.c zdrvrf4.c zerrrfp.c
+ zlatb4.c zlaipd.c zlarhs.c zsbmv.c zget04.c zpot01.c zpot03.c zpot02.c
+ chkxer.c xerbla.c alaerh.c aladhd.c alahd.c alasvm.c )
+
+macro(add_lin_executable name )
+ add_executable(${name} ${ARGN})
+ target_link_libraries(${name} tmglib lapack)
+endmacro(add_lin_executable)
+
+add_lin_executable(xlintsts ${ALINTST} ${SCLNTST} ${SLINTST}
+ ${SECOND_SRC} )
+
+add_lin_executable(xlintstc ${ALINTST} ${CLINTST} ${SCLNTST}
+ ${SECOND_SRC} )
+
+add_lin_executable(xlintstd ${ALINTST} ${DLINTST} ${DZLNTST}
+ ${DSECOND_SRC})
+add_lin_executable(xlintstz ${ALINTST} ${ZLINTST} ${DZLNTST}
+ ${DSECOND_SRC})
+
+add_lin_executable(xlintstds ${DSLINTST}
+ ${SECOND_SRC}
+ ${DSECOND_SRC} )
+add_lin_executable(xlintstzc ${ZCLINTST}
+ ${SECOND_SRC}
+ ${DSECOND_SRC} )
+
+add_lin_executable(xlintstrfs ${SLINTSTRFP}
+ ${SECOND_SRC})
+
+add_lin_executable(xlintstrfd ${DLINTSTRFP}
+ ${DSECOND_SRC})
+
+add_lin_executable(xlintstrfc ${CLINTSTRFP}
+ ${SECOND_SRC})
+add_lin_executable(xlintstrfz ${ZLINTSTRFP}
+ ${DSECOND_SRC})
+
diff --git a/TESTING/LIN/Makefile b/TESTING/LIN/Makefile
new file mode 100644
index 0000000..a02cff9
--- /dev/null
+++ b/TESTING/LIN/Makefile
@@ -0,0 +1,313 @@
+include ../../make.inc
+
+#######################################################################
+# This makefile creates the test programs for the linear equation
+# routines in LAPACK. The test files are grouped as follows:
+#
+# ALINTST -- Auxiliary test routines
+# SLINTST -- Single precision real test routines
+# CLINTST -- Single precision complex test routines
+# SCLNTST -- Single and Complex routines in common
+# DLINTST -- Double precision real test routines
+# ZLINTST -- Double precision complex test routines
+# DZLNTST -- Double and Double Complex routines in common
+#
+# Test programs can be generated for all or some of the four different
+# precisions. Enter make followed by one or more of the data types
+# desired. Some examples:
+# make single
+# make single complex
+# make single double complex complex16
+# Alternatively, the command
+# make
+# without any arguments creates all four test programs.
+# The executable files are called
+# xlintims, xlintimd, xlintimc, and xlintimz
+# and are created in the next higher directory level.
+#
+# To remove the object files after the executable files have been
+# created, enter
+# make clean
+# On some systems, you can force the source files to be recompiled by
+# entering (for example)
+# make single FRC=FRC
+#
+#######################################################################
+
+ifneq ($(strip $(VARLIB)),)
+ LAPACKLIB := $(VARLIB) ../../$(LAPACKLIB)
+endif
+
+ALINTST = \
+ aladhd.o alaerh.o alaesm.o alahd.o alareq.o \
+ alasum.o alasvm.o chkxer.o icopy.o ilaenv.o xlaenv.o xerbla.o
+
+SCLNTST= slaord.o
+
+DZLNTST= dlaord.o
+
+SLINTST = schkaa.o \
+ schkeq.o schkgb.o schkge.o schkgt.o \
+ schklq.o schkpb.o schkpo.o schkps.o schkpp.o \
+ schkpt.o schkq3.o schkql.o schkqp.o schkqr.o schkrq.o \
+ schksp.o schksy.o schktb.o schktp.o schktr.o \
+ schktz.o \
+ sdrvgt.o sdrvls.o sdrvpb.o \
+ sdrvpp.o sdrvpt.o sdrvsp.o sdrvsy.o \
+ serrgt.o serrlq.o serrls.o \
+ serrpo.o serrps.o serrql.o serrqp.o serrqr.o \
+ serrrq.o serrsy.o serrtr.o serrtz.o serrvx.o \
+ sgbt01.o sgbt02.o sgbt05.o sgelqs.o sgeqls.o sgeqrs.o \
+ sgerqs.o sget01.o sget02.o \
+ sget03.o sget04.o sget06.o sget07.o sgtt01.o sgtt02.o \
+ sgtt05.o slaptm.o slarhs.o slatb4.o slatb5.o slattb.o slattp.o \
+ slattr.o slavsp.o slavsy.o slqt01.o slqt02.o \
+ slqt03.o spbt01.o spbt02.o spbt05.o spot01.o \
+ spot02.o spot03.o spot05.o spst01.o sppt01.o \
+ sppt02.o sppt03.o sppt05.o sptt01.o sptt02.o \
+ sptt05.o sqlt01.o sqlt02.o sqlt03.o sqpt01.o \
+ sqrt01.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 \
+ 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 \
+ stzt01.o stzt02.o sgennd.o
+
+ifdef USEXBLAS
+SLINTST += sdrvgex.o serrgex.o sdrvgbx.o sdrvpox.o sebchvxx.o
+else
+SLINTST += sdrvge.o serrge.o sdrvgb.o sdrvpo.o
+endif
+
+CLINTST = cchkaa.o \
+ cchkeq.o cchkgb.o cchkge.o cchkgt.o \
+ cchkhe.o cchkhp.o cchklq.o cchkpb.o \
+ cchkpo.o cchkps.o cchkpp.o cchkpt.o cchkq3.o cchkql.o cchkqp.o \
+ cchkqr.o cchkrq.o cchksp.o cchksy.o cchktb.o \
+ cchktp.o cchktr.o cchktz.o \
+ cdrvgt.o cdrvhe.o cdrvhp.o \
+ cdrvls.o cdrvpb.o cdrvpp.o cdrvpt.o \
+ cdrvsp.o cdrvsy.o \
+ cerrgt.o cerrhe.o cerrlq.o \
+ cerrls.o cerrps.o cerrql.o cerrqp.o \
+ cerrqr.o cerrrq.o cerrsy.o cerrtr.o cerrtz.o \
+ cerrvx.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 chpt01.o claipd.o claptm.o clarhs.o clatb4.o clatb5.o \
+ clatsp.o clatsy.o clattb.o clattp.o clattr.o \
+ clavhe.o clavhp.o clavsp.o clavsy.o clqt01.o \
+ clqt02.o clqt03.o cpbt01.o cpbt02.o cpbt05.o \
+ cpot01.o cpot02.o cpot03.o cpot05.o cpst01.o \
+ cppt01.o cppt02.o cppt03.o cppt05.o cptt01.o \
+ cptt02.o cptt05.o cqlt01.o cqlt02.o cqlt03.o \
+ cqpt01.o cqrt01.o cqrt02.o cqrt03.o cqrt11.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 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 \
+ ctzt01.o ctzt02.o sget06.o cgennd.o
+
+ifdef USEXBLAS
+CLINTST += cdrvgex.o cdrvgbx.o cerrgex.o cdrvpox.o cerrpox.o cebchvxx.o
+else
+CLINTST += cdrvge.o cdrvgb.o cerrge.o cdrvpo.o cerrpo.o
+endif
+
+DLINTST = dchkaa.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 dchkqp.o dchkqr.o dchkrq.o \
+ dchksp.o dchksy.o dchktb.o dchktp.o dchktr.o \
+ dchktz.o \
+ ddrvgt.o ddrvls.o ddrvpb.o \
+ ddrvpp.o ddrvpt.o ddrvsp.o ddrvsy.o \
+ derrgt.o derrlq.o derrls.o \
+ derrps.o derrql.o derrqp.o derrqr.o \
+ derrrq.o derrsy.o derrtr.o derrtz.o derrvx.o \
+ dgbt01.o dgbt02.o dgbt05.o dgelqs.o dgeqls.o dgeqrs.o \
+ dgerqs.o dget01.o dget02.o \
+ dget03.o dget04.o dget06.o dget07.o dgtt01.o dgtt02.o \
+ dgtt05.o dlaptm.o dlarhs.o dlatb4.o dlatb5.o dlattb.o dlattp.o \
+ dlattr.o dlavsp.o dlavsy.o dlqt01.o dlqt02.o \
+ dlqt03.o dpbt01.o dpbt02.o dpbt05.o dpot01.o \
+ dpot02.o dpot03.o dpot05.o dpst01.o dppt01.o \
+ dppt02.o dppt03.o dppt05.o dptt01.o dptt02.o \
+ dptt05.o dqlt01.o dqlt02.o dqlt03.o dqpt01.o \
+ dqrt01.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 \
+ 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 \
+ dtzt01.o dtzt02.o dgennd.o
+
+ifdef USEXBLAS
+DLINTST += ddrvgex.o ddrvgbx.o derrgex.o ddrvpox.o derrpox.o debchvxx.o
+else
+DLINTST += ddrvge.o ddrvgb.o derrge.o ddrvpo.o derrpo.o
+endif
+
+ZLINTST = zchkaa.o \
+ zchkeq.o zchkgb.o zchkge.o zchkgt.o \
+ zchkhe.o zchkhp.o zchklq.o zchkpb.o \
+ zchkpo.o zchkps.o zchkpp.o zchkpt.o zchkq3.o zchkql.o zchkqp.o \
+ zchkqr.o zchkrq.o zchksp.o zchksy.o zchktb.o \
+ zchktp.o zchktr.o zchktz.o \
+ zdrvgt.o zdrvhe.o zdrvhp.o \
+ zdrvls.o zdrvpb.o zdrvpp.o zdrvpt.o \
+ zdrvsp.o zdrvsy.o \
+ zerrgt.o zerrhe.o zerrlq.o \
+ zerrls.o zerrps.o zerrql.o zerrqp.o \
+ zerrqr.o zerrrq.o zerrsy.o zerrtr.o zerrtz.o \
+ zerrvx.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 zhpt01.o zlaipd.o zlaptm.o zlarhs.o zlatb4.o zlatb5.o \
+ zlatsp.o zlatsy.o zlattb.o zlattp.o zlattr.o \
+ zlavhe.o zlavhp.o zlavsp.o zlavsy.o zlqt01.o \
+ zlqt02.o zlqt03.o zpbt01.o zpbt02.o zpbt05.o \
+ zpot01.o zpot02.o zpot03.o zpot05.o zpst01.o \
+ zppt01.o zppt02.o zppt03.o zppt05.o zptt01.o \
+ zptt02.o zptt05.o zqlt01.o zqlt02.o zqlt03.o \
+ zqpt01.o zqrt01.o zqrt02.o zqrt03.o zqrt11.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 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 \
+ ztzt01.o ztzt02.o dget06.o zgennd.o
+
+ifdef USEXBLAS
+ZLINTST += zdrvgex.o zdrvgbx.o zerrgex.o zdrvpox.o zerrpox.o zebchvxx.o
+else
+ZLINTST += zdrvge.o zdrvgb.o zerrge.o zdrvpo.o zerrpo.o
+endif
+
+DSLINTST = dchkab.o \
+ ddrvab.o ddrvac.o derrab.o derrac.o dget08.o \
+ alaerh.o alahd.o aladhd.o alareq.o \
+ chkxer.o dlarhs.o dlatb4.o xerbla.o \
+ dget02.o dpot06.o
+
+ZCLINTST = zchkab.o \
+ zdrvab.o zdrvac.o zerrab.o zerrac.o zget08.o \
+ alaerh.o alahd.o aladhd.o alareq.o \
+ chkxer.o zget02.o zlarhs.o zlatb4.o \
+ zsbmv.o xerbla.o zpot06.o zlaipd.o
+
+SLINTSTRFP = schkrfp.o sdrvrfp.o sdrvrf1.o sdrvrf2.o sdrvrf3.o sdrvrf4.o serrrfp.o \
+ slatb4.o slarhs.o sget04.o spot01.o spot03.o spot02.o \
+ chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o
+
+DLINTSTRFP = dchkrfp.o ddrvrfp.o ddrvrf1.o ddrvrf2.o ddrvrf3.o ddrvrf4.o derrrfp.o \
+ dlatb4.o dlarhs.o dget04.o dpot01.o dpot03.o dpot02.o \
+ chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o
+
+CLINTSTRFP = cchkrfp.o cdrvrfp.o cdrvrf1.o cdrvrf2.o cdrvrf3.o cdrvrf4.o cerrrfp.o \
+ claipd.o clatb4.o clarhs.o csbmv.o cget04.o cpot01.o cpot03.o cpot02.o \
+ chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o
+
+ZLINTSTRFP = zchkrfp.o zdrvrfp.o zdrvrf1.o zdrvrf2.o zdrvrf3.o zdrvrf4.o zerrrfp.o \
+ zlatb4.o zlaipd.o zlarhs.o zsbmv.o zget04.o zpot01.o zpot03.o zpot02.o \
+ chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o
+
+all: single double complex complex16 proto-single proto-double proto-complex proto-complex16
+
+single: ../xlintsts
+double: ../xlintstd
+complex: ../xlintstc
+complex16: ../xlintstz
+
+proto-single: ../xlintstrfs
+proto-double: ../xlintstds ../xlintstrfd
+proto-complex: ../xlintstrfc
+proto-complex16: ../xlintstzc ../xlintstrfz
+
+../xlintsts : $(ALINTST) $(SLINTST) $(SCLNTST)
+ $(CC) $(LOADOPTS) $(ALINTST) $(SCLNTST) $(SLINTST) \
+ ../../INSTALL/second.o \
+ ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) $(F2CLIB) -lm -o xlintsts && mv xlintsts $@
+
+../xlintstc : $(ALINTST) $(CLINTST) $(SCLNTST)
+ $(CC) $(LOADOPTS) $(ALINTST) $(SCLNTST) $(CLINTST) \
+ ../../INSTALL/second.o \
+ ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) $(F2CLIB) -lm -o xlintstc && mv xlintstc $@
+
+../xlintstd : $(ALINTST) $(DLINTST) $(DZLNTST)
+ $(CC) $(LOADOPTS) $^ \
+ ../../INSTALL/dsecnd.o \
+ ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) $(F2CLIB) -lm -o xlintstd && mv xlintstd $@
+
+../xlintstz : $(ALINTST) $(ZLINTST) $(DZLNTST)
+ $(CC) $(LOADOPTS) $(ALINTST) $(DZLNTST) $(ZLINTST) \
+ ../../INSTALL/dsecnd.o \
+ ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) $(F2CLIB) -lm -o xlintstz && mv xlintstz $@
+
+../xlintstds : $(DSLINTST)
+ $(CC) $(LOADOPTS) $(DSLINTST) \
+ ../../INSTALL/second.o \
+ ../../INSTALL/dsecnd.o \
+ ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) $(F2CLIB) -lm -o xlintstds && mv xlintstds $@
+
+../xlintstzc : $(ZCLINTST)
+ $(CC) $(LOADOPTS) $(ZCLINTST) \
+ ../../INSTALL/second.o \
+ ../../INSTALL/dsecnd.o \
+ ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) $(F2CLIB) -lm -o xlintstzc && mv xlintstzc $@
+
+../xlintstrfs : $(SLINTSTRFP)
+ $(CC) $(LOADOPTS) $(SLINTSTRFP) \
+ ../../INSTALL/second.o \
+ ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) $(F2CLIB) -lm -o xlintstrfs && mv xlintstrfs $@
+
+../xlintstrfd : $(DLINTSTRFP)
+ $(CC) $(LOADOPTS) $(DLINTSTRFP) \
+ ../../INSTALL/dsecnd.o \
+ ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) $(F2CLIB) -lm -o xlintstrfd && mv xlintstrfd $@
+
+../xlintstrfc : $(CLINTSTRFP)
+ $(CC) $(LOADOPTS) $(CLINTSTRFP) \
+ ../../INSTALL/second.o \
+ ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) $(F2CLIB) -lm -o xlintstrfc && mv xlintstrfc $@
+
+../xlintstrfz : $(ZLINTSTRFP)
+ $(CC) $(LOADOPTS) $(ZLINTSTRFP) \
+ ../../INSTALL/dsecnd.o \
+ ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) $(F2CLIB) -lm -o xlintstrfz && mv xlintstrfz $@
+
+$(ALINTST): $(FRC)
+$(SCLNTST): $(FRC)
+$(DZLNTST): $(FRC)
+$(SLINTST): $(FRC)
+$(CLINTST): $(FRC)
+$(DLINTST): $(FRC)
+$(ZLINTST): $(FRC)
+
+FRC:
+ @FRC=$(FRC)
+
+clean:
+ rm -f *.o
+
+schkaa.o: schkaa.c
+ $(CC) $(DRVCFLAGS) -I../../INCLUDE -c $< -o $@
+dchkaa.o: dchkaa.c
+ $(CC) $(DRVCFLAGS) -I../../INCLUDE -c $< -o $@
+cchkaa.o: cchkaa.c
+ $(CC) $(DRVCFLAGS) -I../../INCLUDE -c $< -o $@
+zchkaa.o: zchkaa.c
+ $(CC) $(DRVCFLAGS) -I../../INCLUDE -c $< -o $@
+
+.c.o:
+ $(CC) $(CFLAGS) -I../../INCLUDE -c $<
diff --git a/TESTING/LIN/aladhd.c b/TESTING/LIN/aladhd.c
new file mode 100644
index 0000000..96d951c
--- /dev/null
+++ b/TESTING/LIN/aladhd.c
@@ -0,0 +1,788 @@
+/* aladhd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static integer c__5 = 5;
+static integer c__6 = 6;
+static integer c__7 = 7;
+
+/* Subroutine */ int aladhd_(integer *iounit, char *path)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(/1x,a3,\002 drivers: General dense matrice"
+ "s\002)";
+ static char fmt_9989[] = "(4x,\0021. Diagonal\002,24x,\0027. Last n/2 co"
+ "lumns zero\002,/4x,\0022. Upper triangular\002,16x,\0028. Random"
+ ", CNDNUM = sqrt(0.1/EPS)\002,/4x,\0023. Lower triangular\002,16x,"
+ "\0029. Random, CNDNUM = 0.1/EPS\002,/4x,\0024. Random, CNDNUM = 2"
+ "\002,13x,\00210. Scaled near underflow\002,/4x,\0025. First colu"
+ "mn zero\002,14x,\00211. Scaled near overflow\002,/4x,\0026. Last"
+ " column zero\002)";
+ static char fmt_9981[] = "(3x,i2,\002: norm( L * U - A ) / ( N * norm(A"
+ ") * EPS )\002)";
+ static char fmt_9980[] = "(3x,i2,\002: norm( B - A * X ) / \002,\002( n"
+ "orm(A) * norm(X) * EPS )\002)";
+ static char fmt_9979[] = "(3x,i2,\002: norm( X - XACT ) / \002,\002( n"
+ "orm(XACT) * CNDNUM * EPS )\002)";
+ static char fmt_9978[] = "(3x,i2,\002: norm( X - XACT ) / \002,\002( n"
+ "orm(XACT) * (error bound) )\002)";
+ static char fmt_9977[] = "(3x,i2,\002: (backward error) / EPS\002)";
+ static char fmt_9976[] = "(3x,i2,\002: RCOND * CNDNUM - 1.0\002)";
+ static char fmt_9972[] = "(3x,i2,\002: abs( WORK(1) - RPVGRW ) /\002,"
+ "\002 ( max( WORK(1), RPVGRW ) * EPS )\002)";
+ static char fmt_9998[] = "(/1x,a3,\002 drivers: General band matrice"
+ "s\002)";
+ static char fmt_9988[] = "(4x,\0021. Random, CNDNUM = 2\002,14x,\0025. R"
+ "andom, CNDNUM = sqrt(0.1/EPS)\002,/4x,\0022. First column zer"
+ "o\002,15x,\0026. Random, CNDNUM = 0.1/EPS\002,/4x,\0023. Last co"
+ "lumn zero\002,16x,\0027. Scaled near underflow\002,/4x,\0024. La"
+ "st n/2 columns zero\002,11x,\0028. Scaled near overflow\002)";
+ static char fmt_9997[] = "(/1x,a3,\002 drivers: General tridiagonal\002)"
+ ;
+ static char fmt_9987[] = "(\002 Matrix types (1-6 have specified conditi"
+ "on numbers):\002,/4x,\0021. Diagonal\002,24x,\0027. Random, unsp"
+ "ecified CNDNUM\002,/4x,\0022. Random, CNDNUM = 2\002,14x,\0028. "
+ "First column zero\002,/4x,\0023. Random, CNDNUM = sqrt(0.1/EPS"
+ ")\002,2x,\0029. Last column zero\002,/4x,\0024. Random, CNDNUM ="
+ " 0.1/EPS\002,7x,\00210. Last n/2 columns zero\002,/4x,\0025. Sca"
+ "led near underflow\002,10x,\00211. Scaled near underflow\002,/4x,"
+ "\0026. Scaled near overflow\002,11x,\00212. Scaled near overflo"
+ "w\002)";
+ static char fmt_9996[] = "(/1x,a3,\002 drivers: \002,a9,\002 positive d"
+ "efinite matrices\002)";
+ static char fmt_9995[] = "(/1x,a3,\002 drivers: \002,a9,\002 positive d"
+ "efinite packed matrices\002)";
+ static char fmt_9985[] = "(4x,\0021. Diagonal\002,24x,\0026. Random, CND"
+ "NUM = sqrt(0.1/EPS)\002,/4x,\0022. Random, CNDNUM = 2\002,14x"
+ ",\0027. Random, CNDNUM = 0.1/EPS\002,/3x,\002*3. First row and c"
+ "olumn zero\002,7x,\0028. Scaled near underflow\002,/3x,\002*4. L"
+ "ast row and column zero\002,8x,\0029. Scaled near overflow\002,/"
+ "3x,\002*5. Middle row and column zero\002,/3x,\002(* - tests err"
+ "or exits from \002,a3,\002TRF, no test ratios are computed)\002)";
+ static char fmt_9975[] = "(3x,i2,\002: norm( U' * U - A ) / ( N * norm(A"
+ ") * EPS )\002,\002, or\002,/7x,\002norm( L * L' - A ) / ( N * no"
+ "rm(A) * EPS )\002)";
+ static char fmt_9994[] = "(/1x,a3,\002 drivers: \002,a9,\002 positive d"
+ "efinite band matrices\002)";
+ static char fmt_9984[] = "(4x,\0021. Random, CNDNUM = 2\002,14x,\0025. R"
+ "andom, CNDNUM = sqrt(0.1/EPS)\002,/3x,\002*2. First row and colu"
+ "mn zero\002,7x,\0026. Random, CNDNUM = 0.1/EPS\002,/3x,\002*3. L"
+ "ast row and column zero\002,8x,\0027. Scaled near underflow\002,"
+ "/3x,\002*4. Middle row and column zero\002,6x,\0028. Scaled near"
+ " overflow\002,/3x,\002(* - tests error exits from \002,a3,\002TR"
+ "F, no test ratios are computed)\002)";
+ static char fmt_9993[] = "(/1x,a3,\002 drivers: \002,a9,\002 positive d"
+ "efinite tridiagonal\002)";
+ static char fmt_9986[] = "(\002 Matrix types (1-6 have specified conditi"
+ "on numbers):\002,/4x,\0021. Diagonal\002,24x,\0027. Random, unsp"
+ "ecified CNDNUM\002,/4x,\0022. Random, CNDNUM = 2\002,14x,\0028. "
+ "First row and column zero\002,/4x,\0023. Random, CNDNUM = sqrt(0"
+ ".1/EPS)\002,2x,\0029. Last row and column zero\002,/4x,\0024. Ra"
+ "ndom, CNDNUM = 0.1/EPS\002,7x,\00210. Middle row and column zer"
+ "o\002,/4x,\0025. Scaled near underflow\002,10x,\00211. Scaled ne"
+ "ar underflow\002,/4x,\0026. Scaled near overflow\002,11x,\00212."
+ " Scaled near overflow\002)";
+ static char fmt_9973[] = "(3x,i2,\002: norm( U'*D*U - A ) / ( N * norm(A"
+ ") * EPS )\002,\002, or\002,/7x,\002norm( L*D*L' - A ) / ( N * no"
+ "rm(A) * EPS )\002)";
+ static char fmt_9992[] = "(/1x,a3,\002 drivers: \002,a9,\002 indefinite"
+ " matrices\002)";
+ static char fmt_9991[] = "(/1x,a3,\002 drivers: \002,a9,\002 indefinite"
+ " packed matrices\002)";
+ static char fmt_9983[] = "(4x,\0021. Diagonal\002,24x,\0026. Last n/2 ro"
+ "ws and columns zero\002,/4x,\0022. Random, CNDNUM = 2\002,14x"
+ ",\0027. Random, CNDNUM = sqrt(0.1/EPS)\002,/4x,\0023. First row "
+ "and column zero\002,7x,\0028. Random, CNDNUM = 0.1/EPS\002,/4x"
+ ",\0024. Last row and column zero\002,8x,\0029. Scaled near under"
+ "flow\002,/4x,\0025. Middle row and column zero\002,5x,\00210. Sc"
+ "aled near overflow\002)";
+ static char fmt_9982[] = "(4x,\0021. Diagonal\002,24x,\0027. Random, CND"
+ "NUM = sqrt(0.1/EPS)\002,/4x,\0022. Random, CNDNUM = 2\002,14x"
+ ",\0028. Random, CNDNUM = 0.1/EPS\002,/4x,\0023. First row and co"
+ "lumn zero\002,7x,\0029. Scaled near underflow\002,/4x,\0024. Las"
+ "t row and column zero\002,7x,\00210. Scaled near overflow\002,/4"
+ "x,\0025. Middle row and column zero\002,5x,\00211. Block diagona"
+ "l matrix\002,/4x,\0026. Last n/2 rows and columns zero\002)";
+ static char fmt_9974[] = "(3x,i2,\002: norm( U*D*U' - A ) / ( N * norm(A"
+ ") * EPS )\002,\002, or\002,/7x,\002norm( L*D*L' - A ) / ( N * no"
+ "rm(A) * EPS )\002)";
+ static char fmt_9990[] = "(/1x,a3,\002: No header available\002)";
+
+ /* System generated locals */
+ cilist ci__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ char c1[1], c3[1], p2[2], sym[9];
+ logical sord, corz;
+ extern logical lsame_(char *, char *), lsamen_(integer *,
+ char *, char *);
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___7 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___8 = { 0, 0, 0, fmt_9981, 0 };
+ static cilist io___9 = { 0, 0, 0, fmt_9980, 0 };
+ static cilist io___10 = { 0, 0, 0, fmt_9979, 0 };
+ static cilist io___11 = { 0, 0, 0, fmt_9978, 0 };
+ static cilist io___12 = { 0, 0, 0, fmt_9977, 0 };
+ static cilist io___13 = { 0, 0, 0, fmt_9976, 0 };
+ static cilist io___14 = { 0, 0, 0, fmt_9972, 0 };
+ static cilist io___15 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___16 = { 0, 0, 0, fmt_9988, 0 };
+ static cilist io___17 = { 0, 0, 0, fmt_9981, 0 };
+ static cilist io___18 = { 0, 0, 0, fmt_9980, 0 };
+ static cilist io___19 = { 0, 0, 0, fmt_9979, 0 };
+ static cilist io___20 = { 0, 0, 0, fmt_9978, 0 };
+ static cilist io___21 = { 0, 0, 0, fmt_9977, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9976, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9972, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9987, 0 };
+ static cilist io___26 = { 0, 0, 0, fmt_9981, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9980, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9979, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9978, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9977, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9976, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9985, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9975, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9980, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9979, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9978, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9977, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9976, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9984, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9975, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9980, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9979, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9978, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9977, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9976, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9986, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9973, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9980, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9979, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9978, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9977, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9976, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9983, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9982, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9974, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9980, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9979, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9977, 0 };
+ static cilist io___68 = { 0, 0, 0, fmt_9978, 0 };
+ static cilist io___69 = { 0, 0, 0, fmt_9976, 0 };
+ static cilist io___70 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___71 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___72 = { 0, 0, 0, fmt_9983, 0 };
+ static cilist io___73 = { 0, 0, 0, fmt_9974, 0 };
+ static cilist io___74 = { 0, 0, 0, fmt_9980, 0 };
+ static cilist io___75 = { 0, 0, 0, fmt_9979, 0 };
+ static cilist io___76 = { 0, 0, 0, fmt_9977, 0 };
+ static cilist io___77 = { 0, 0, 0, fmt_9978, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9976, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9990, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ALADHD prints header information for the driver routines test paths. */
+
+/* Arguments */
+/* ========= */
+
+/* IOUNIT (input) INTEGER */
+/* The unit number to which the header information should be */
+/* printed. */
+
+/* PATH (input) CHARACTER*3 */
+/* The name of the path for which the header information is to */
+/* be printed. Current paths are */
+/* _GE: General matrices */
+/* _GB: General band */
+/* _GT: General Tridiagonal */
+/* _PO: Symmetric or Hermitian positive definite */
+/* _PS: Symmetric or Hermitian positive semi-definite */
+/* _PP: Symmetric or Hermitian positive definite packed */
+/* _PB: Symmetric or Hermitian positive definite band */
+/* _PT: Symmetric or Hermitian positive definite tridiagonal */
+/* _SY: Symmetric indefinite */
+/* _SP: Symmetric indefinite packed */
+/* _HE: (complex) Hermitian indefinite */
+/* _HP: (complex) Hermitian indefinite packed */
+/* The first character must be one of S, D, C, or Z (C or Z only */
+/* if complex). */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (*iounit <= 0) {
+ return 0;
+ }
+ *(unsigned char *)c1 = *(unsigned char *)path;
+ *(unsigned char *)c3 = *(unsigned char *)&path[2];
+ s_copy(p2, path + 1, (ftnlen)2, (ftnlen)2);
+ sord = lsame_(c1, "S") || lsame_(c1, "D");
+ corz = lsame_(c1, "C") || lsame_(c1, "Z");
+ if (! (sord || corz)) {
+ return 0;
+ }
+
+ if (lsamen_(&c__2, p2, "GE")) {
+
+/* GE: General dense */
+
+ io___6.ciunit = *iounit;
+ s_wsfe(&io___6);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___7.ciunit = *iounit;
+ s_wsfe(&io___7);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___8.ciunit = *iounit;
+ s_wsfe(&io___8);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___9.ciunit = *iounit;
+ s_wsfe(&io___9);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___10.ciunit = *iounit;
+ s_wsfe(&io___10);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___11.ciunit = *iounit;
+ s_wsfe(&io___11);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___12.ciunit = *iounit;
+ s_wsfe(&io___12);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___13.ciunit = *iounit;
+ s_wsfe(&io___13);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___14.ciunit = *iounit;
+ s_wsfe(&io___14);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "GB")) {
+
+/* GB: General band */
+
+ io___15.ciunit = *iounit;
+ s_wsfe(&io___15);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___16.ciunit = *iounit;
+ s_wsfe(&io___16);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___17.ciunit = *iounit;
+ s_wsfe(&io___17);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___18.ciunit = *iounit;
+ s_wsfe(&io___18);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___19.ciunit = *iounit;
+ s_wsfe(&io___19);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___20.ciunit = *iounit;
+ s_wsfe(&io___20);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___21.ciunit = *iounit;
+ s_wsfe(&io___21);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___22.ciunit = *iounit;
+ s_wsfe(&io___22);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___23.ciunit = *iounit;
+ s_wsfe(&io___23);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "GT")) {
+
+/* GT: General tridiagonal */
+
+ io___24.ciunit = *iounit;
+ s_wsfe(&io___24);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___25.ciunit = *iounit;
+ s_wsfe(&io___25);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___26.ciunit = *iounit;
+ s_wsfe(&io___26);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___27.ciunit = *iounit;
+ s_wsfe(&io___27);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___28.ciunit = *iounit;
+ s_wsfe(&io___28);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___29.ciunit = *iounit;
+ s_wsfe(&io___29);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___30.ciunit = *iounit;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___31.ciunit = *iounit;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "PO") || lsamen_(&
+ c__2, p2, "PP") || lsamen_(&c__2, p2, "PS")) {
+
+/* PO: Positive definite full */
+/* PS: Positive definite full */
+/* PP: Positive definite packed */
+
+ if (sord) {
+ s_copy(sym, "Symmetric", (ftnlen)9, (ftnlen)9);
+ } else {
+ s_copy(sym, "Hermitian", (ftnlen)9, (ftnlen)9);
+ }
+ if (lsame_(c3, "O")) {
+ io___33.ciunit = *iounit;
+ s_wsfe(&io___33);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, sym, (ftnlen)9);
+ e_wsfe();
+ } else {
+ io___34.ciunit = *iounit;
+ s_wsfe(&io___34);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, sym, (ftnlen)9);
+ e_wsfe();
+ }
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___35.ciunit = *iounit;
+ s_wsfe(&io___35);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___36.ciunit = *iounit;
+ s_wsfe(&io___36);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___37.ciunit = *iounit;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___38.ciunit = *iounit;
+ s_wsfe(&io___38);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___39.ciunit = *iounit;
+ s_wsfe(&io___39);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___40.ciunit = *iounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___41.ciunit = *iounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "PB")) {
+
+/* PB: Positive definite band */
+
+ if (sord) {
+ io___42.ciunit = *iounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, "Symmetric", (ftnlen)9);
+ e_wsfe();
+ } else {
+ io___43.ciunit = *iounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, "Hermitian", (ftnlen)9);
+ e_wsfe();
+ }
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___44.ciunit = *iounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___45.ciunit = *iounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___46.ciunit = *iounit;
+ s_wsfe(&io___46);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___47.ciunit = *iounit;
+ s_wsfe(&io___47);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___48.ciunit = *iounit;
+ s_wsfe(&io___48);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___49.ciunit = *iounit;
+ s_wsfe(&io___49);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___50.ciunit = *iounit;
+ s_wsfe(&io___50);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "PT")) {
+
+/* PT: Positive definite tridiagonal */
+
+ if (sord) {
+ io___51.ciunit = *iounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, "Symmetric", (ftnlen)9);
+ e_wsfe();
+ } else {
+ io___52.ciunit = *iounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, "Hermitian", (ftnlen)9);
+ e_wsfe();
+ }
+ io___53.ciunit = *iounit;
+ s_wsfe(&io___53);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___54.ciunit = *iounit;
+ s_wsfe(&io___54);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___55.ciunit = *iounit;
+ s_wsfe(&io___55);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___56.ciunit = *iounit;
+ s_wsfe(&io___56);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___57.ciunit = *iounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___58.ciunit = *iounit;
+ s_wsfe(&io___58);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___59.ciunit = *iounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "SY") || lsamen_(&
+ c__2, p2, "SP")) {
+
+/* SY: Symmetric indefinite full */
+/* SP: Symmetric indefinite packed */
+
+ if (lsame_(c3, "Y")) {
+ io___60.ciunit = *iounit;
+ s_wsfe(&io___60);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, "Symmetric", (ftnlen)9);
+ e_wsfe();
+ } else {
+ io___61.ciunit = *iounit;
+ s_wsfe(&io___61);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, "Symmetric", (ftnlen)9);
+ e_wsfe();
+ }
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ if (sord) {
+ io___62.ciunit = *iounit;
+ s_wsfe(&io___62);
+ e_wsfe();
+ } else {
+ io___63.ciunit = *iounit;
+ s_wsfe(&io___63);
+ e_wsfe();
+ }
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___64.ciunit = *iounit;
+ s_wsfe(&io___64);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___65.ciunit = *iounit;
+ s_wsfe(&io___65);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___66.ciunit = *iounit;
+ s_wsfe(&io___66);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___67.ciunit = *iounit;
+ s_wsfe(&io___67);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___68.ciunit = *iounit;
+ s_wsfe(&io___68);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___69.ciunit = *iounit;
+ s_wsfe(&io___69);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "HE") || lsamen_(&
+ c__2, p2, "HP")) {
+
+/* HE: Hermitian indefinite full */
+/* HP: Hermitian indefinite packed */
+
+ if (lsame_(c3, "E")) {
+ io___70.ciunit = *iounit;
+ s_wsfe(&io___70);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, "Hermitian", (ftnlen)9);
+ e_wsfe();
+ } else {
+ io___71.ciunit = *iounit;
+ s_wsfe(&io___71);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, "Hermitian", (ftnlen)9);
+ e_wsfe();
+ }
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___72.ciunit = *iounit;
+ s_wsfe(&io___72);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___73.ciunit = *iounit;
+ s_wsfe(&io___73);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___74.ciunit = *iounit;
+ s_wsfe(&io___74);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___75.ciunit = *iounit;
+ s_wsfe(&io___75);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___76.ciunit = *iounit;
+ s_wsfe(&io___76);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___77.ciunit = *iounit;
+ s_wsfe(&io___77);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___78.ciunit = *iounit;
+ s_wsfe(&io___78);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else {
+
+/* Print error message if no header is available. */
+
+ io___79.ciunit = *iounit;
+ s_wsfe(&io___79);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+/* First line of header */
+
+
+/* GE matrix types */
+
+
+/* GB matrix types */
+
+
+/* GT matrix types */
+
+
+/* PT matrix types */
+
+
+/* PO, PP matrix types */
+
+
+/* PB matrix types */
+
+
+/* SSY, SSP, CHE, CHP matrix types */
+
+
+/* CSY, CSP matrix types */
+
+
+/* Test ratios */
+
+
+ return 0;
+
+/* End of ALADHD */
+
+} /* aladhd_ */
diff --git a/TESTING/LIN/alaerh.c b/TESTING/LIN/alaerh.c
new file mode 100644
index 0000000..54f62dd
--- /dev/null
+++ b/TESTING/LIN/alaerh.c
@@ -0,0 +1,2000 @@
+/* alaerh.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+#include "string.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c__5 = 5;
+
+/* Subroutine */ int alaerh_(char *path, char *subnam, integer *info, integer
+ *infoe, char *opts, integer *m, integer *n, integer *kl, integer *ku,
+ integer *n5, integer *imat, integer *nfail, integer *nerrs, integer *
+ nout)
+{
+ /* Format strings */
+ static char fmt_9988[] = "(\002 *** \002,a,\002 returned with INFO =\002"
+ ",i5,\002 instead of \002,i2,/\002 ==> M =\002,i5,\002, N =\002,i"
+ "5,\002, NB =\002,i4,\002, type \002,i2)";
+ static char fmt_9975[] = "(\002 *** Error code from \002,a,\002=\002,i5"
+ ",\002 for M=\002,i5,\002, N=\002,i5,\002, NB=\002,i4,\002, type"
+ " \002,i2)";
+ static char fmt_9949[] = "(\002 ==> Doing only the condition estimate fo"
+ "r this case\002)";
+ static char fmt_9984[] = "(\002 *** \002,a,\002 returned with INFO =\002"
+ ",i5,\002 instead of \002,i2,/\002 ==> N =\002,i5,\002, NRHS ="
+ "\002,i4,\002, type \002,i2)";
+ static char fmt_9970[] = "(\002 *** Error code from \002,a,\002 =\002,"
+ "i5,\002 for N =\002,i5,\002, NRHS =\002,i4,\002, type \002,i2)";
+ static char fmt_9992[] = "(\002 *** \002,a,\002 returned with INFO =\002"
+ ",i5,\002 instead of \002,i2,/\002 ==> FACT='\002,a1,\002', TRANS"
+ "='\002,a1,\002', N =\002,i5,\002, NRHS =\002,i4,\002, type \002,"
+ "i2)";
+ static char fmt_9997[] = "(\002 *** Error code from \002,a,\002 =\002,i5"
+ ",/\002 ==> FACT='\002,a1,\002', TRANS='\002,a1,\002', N =\002,i5,"
+ "\002, NRHS =\002,i4,\002, type \002,i2)";
+ static char fmt_9971[] = "(\002 *** Error code from \002,a,\002=\002,i5"
+ ",\002 for N=\002,i5,\002, NB=\002,i4,\002, type \002,i2)";
+ static char fmt_9978[] = "(\002 *** Error code from \002,a,\002 =\002,"
+ "i5,\002 for M =\002,i5,\002, N =\002,i5,\002, type \002,i2)";
+ static char fmt_9969[] = "(\002 *** Error code from \002,a,\002 =\002,"
+ "i5,\002 for NORM = '\002,a1,\002', N =\002,i5,\002, type \002,i2)"
+ ;
+ static char fmt_9965[] = "(\002 *** Error code from \002,a,\002 =\002,i5"
+ ",/\002 ==> TRANS = '\002,a1,\002', M =\002,i5,\002, N =\002,i5"
+ ",\002, NRHS =\002,i4,\002, NB =\002,i4,\002, type \002,i2)";
+ static char fmt_9974[] = "(\002 *** Error code from \002,a,\002=\002,i"
+ "5,/\002 ==> M =\002,i5,\002, N =\002,i5,\002, NRHS =\002,i4,\002"
+ ", NB =\002,i4,\002, type \002,i2)";
+ static char fmt_9963[] = "(\002 *** Error code from \002,a,\002 =\002,i5"
+ ",/\002 ==> TRANS = '\002,a1,\002', N =\002,i5,\002, NRHS =\002,i"
+ "4,\002, type \002,i2)";
+ static char fmt_9989[] = "(\002 *** \002,a,\002 returned with INFO =\002"
+ ",i5,\002 instead of \002,i2,/\002 ==> M = \002,i5,\002, N =\002,"
+ "i5,\002, KL =\002,i5,\002, KU =\002,i5,\002, NB =\002,i4,\002, t"
+ "ype \002,i2)";
+ static char fmt_9976[] = "(\002 *** Error code from \002,a,\002 =\002,i5"
+ ",/\002 ==> M = \002,i5,\002, N =\002,i5,\002, KL =\002,i5,\002, "
+ "KU =\002,i5,\002, NB =\002,i4,\002, type \002,i2)";
+ static char fmt_9986[] = "(\002 *** \002,a,\002 returned with INFO =\002"
+ ",i5,\002 instead of \002,i2,/\002 ==> N =\002,i5,\002, KL =\002,"
+ "i5,\002, KU =\002,i5,\002, NRHS =\002,i4,\002, type \002,i2)";
+ static char fmt_9972[] = "(\002 *** Error code from \002,a,\002 =\002,i5"
+ ",/\002 ==> N =\002,i5,\002, KL =\002,i5,\002, KU =\002,i5,\002, "
+ "NRHS =\002,i4,\002, type \002,i2)";
+ static char fmt_9993[] = "(\002 *** \002,a,\002 returned with INFO =\002"
+ ",i5,\002 instead of \002,i2,/\002 ==> FACT='\002,a1,\002', TRANS"
+ "='\002,a1,\002', N=\002,i5,\002, KL=\002,i5,\002, KU=\002,i5,"
+ "\002, NRHS=\002,i4,\002, type \002,i1)";
+ static char fmt_9998[] = "(\002 *** Error code from \002,a,\002 =\002,i5"
+ ",/\002 ==> FACT='\002,a1,\002', TRANS='\002,a1,\002', N=\002,i5"
+ ",\002, KL=\002,i5,\002, KU=\002,i5,\002, NRHS=\002,i4,\002, type "
+ "\002,i1)";
+ static char fmt_9977[] = "(\002 *** Error code from \002,a,\002 =\002,i5"
+ ",/\002 ==> M = \002,i5,\002, N =\002,i5,\002, KL =\002,i5,\002, "
+ "KU =\002,i5,\002, type \002,i2)";
+ static char fmt_9968[] = "(\002 *** Error code from \002,a,\002 =\002,i5"
+ ",/\002 ==> NORM ='\002,a1,\002', N =\002,i5,\002, KL =\002,i5"
+ ",\002, KU =\002,i5,\002, type \002,i2)";
+ static char fmt_9964[] = "(\002 *** Error code from \002,a,\002=\002,i"
+ "5,/\002 ==> TRANS='\002,a1,\002', N =\002,i5,\002, KL =\002,i5"
+ ",\002, KU =\002,i5,\002, NRHS =\002,i4,\002, type \002,i2)";
+ static char fmt_9987[] = "(\002 *** \002,a,\002 returned with INFO =\002"
+ ",i5,\002 instead of \002,i2,\002 for N=\002,i5,\002, type \002,i"
+ "2)";
+ static char fmt_9973[] = "(\002 *** Error code from \002,a,\002 =\002,"
+ "i5,\002 for N =\002,i5,\002, type \002,i2)";
+ static char fmt_9980[] = "(\002 *** \002,a,\002 returned with INFO =\002"
+ ",i5,\002 instead of \002,i2,/\002 ==> UPLO = '\002,a1,\002', N "
+ "=\002,i5,\002, NB =\002,i4,\002, type \002,i2)";
+ static char fmt_9956[] = "(\002 *** Error code from \002,a,\002 =\002,i5"
+ ",/\002 ==> UPLO = '\002,a1,\002', N =\002,i5,\002, NB =\002,i4"
+ ",\002, type \002,i2)";
+ static char fmt_9979[] = "(\002 *** \002,a,\002 returned with INFO =\002"
+ ",i5,\002 instead of \002,i2,/\002 ==> UPLO = '\002,a1,\002', N "
+ "=\002,i5,\002, NRHS =\002,i4,\002, type \002,i2)";
+ static char fmt_9955[] = "(\002 *** Error code from \002,a,\002 =\002,i5"
+ ",/\002 ==> UPLO = '\002,a1,\002', N =\002,i5,\002, NRHS =\002,i4,"
+ "\002, type \002,i2)";
+ static char fmt_9990[] = "(\002 *** \002,a,\002 returned with INFO =\002"
+ ",i5,\002 instead of \002,i2,/\002 ==> FACT='\002,a1,\002', UPLO='"
+ "\002,a1,\002', N =\002,i5,\002, NRHS =\002,i4,\002, type \002,i2)"
+ ;
+ static char fmt_9995[] = "(\002 *** Error code from \002,a,\002 =\002,i5"
+ ",/\002 ==> FACT='\002,a1,\002', UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, NRHS =\002,i4,\002, type \002,i2)";
+ static char fmt_9960[] = "(\002 *** Error code from \002,a,\002 =\002,"
+ "i5,\002 for UPLO = '\002,a1,\002', N =\002,i5,\002, type \002,i2)"
+ ;
+ static char fmt_9983[] = "(\002 *** \002,a,\002 returned with INFO =\002"
+ ",i5,\002 instead of \002,i2,/\002 ==> UPLO = '\002,a1,\002', N "
+ "=\002,i5,\002, type \002,i2)";
+ static char fmt_9982[] = "(\002 *** \002,a,\002 returned with INFO =\002"
+ ",i5,\002 instead of \002,i2,/\002 ==> UPLO = '\002,a1,\002', N "
+ "=\002,i5,\002, KD =\002,i5,\002, NB =\002,i4,\002, type \002,i2)";
+ static char fmt_9958[] = "(\002 *** Error code from \002,a,\002 =\002,i5"
+ ",/\002 ==> UPLO = '\002,a1,\002', N =\002,i5,\002, KD =\002,i5"
+ ",\002, NB =\002,i4,\002, type \002,i2)";
+ static char fmt_9981[] = "(\002 *** \002,a,\002 returned with INFO =\002"
+ ",i5,\002 instead of \002,i2,/\002 ==> UPLO='\002,a1,\002', N "
+ "=\002,i5,\002, KD =\002,i5,\002, NRHS =\002,i4,\002, type \002,i"
+ "2)";
+ static char fmt_9957[] = "(\002 *** Error code from \002,a,\002=\002,i"
+ "5,/\002 ==> UPLO = '\002,a1,\002', N =\002,i5,\002, KD =\002,i5"
+ ",\002, NRHS =\002,i4,\002, type \002,i2)";
+ static char fmt_9991[] = "(\002 *** \002,a,\002 returned with INFO =\002"
+ ",i5,\002 instead of \002,i2,/\002 ==> FACT='\002,a1,\002', UPLO='"
+ "\002,a1,\002', N=\002,i5,\002, KD=\002,i5,\002, NRHS=\002,i4,"
+ "\002, type \002,i2)";
+ static char fmt_9996[] = "(\002 *** Error code from \002,a,\002 =\002,i5"
+ ",/\002 ==> FACT='\002,a1,\002', UPLO='\002,a1,\002', N=\002,i5"
+ ",\002, KD=\002,i5,\002, NRHS=\002,i4,\002, type \002,i2)";
+ static char fmt_9959[] = "(\002 *** Error code from \002,a,\002 =\002,i5"
+ ",/\002 ==> UPLO = '\002,a1,\002', N =\002,i5,\002, KD =\002,i5"
+ ",\002, type \002,i2)";
+ static char fmt_9994[] = "(\002 *** \002,a,\002 returned with INFO =\002"
+ ",i5,\002 instead of \002,i2,/\002 ==> FACT='\002,a1,\002', N "
+ "=\002,i5,\002, NRHS =\002,i4,\002, type \002,i2)";
+ static char fmt_9999[] = "(\002 *** Error code from \002,a,\002=\002,i5"
+ ",\002, FACT='\002,a1,\002', N=\002,i5,\002, NRHS=\002,i4,\002, t"
+ "ype \002,i2)";
+ static char fmt_9961[] = "(\002 *** Error code from \002,a,\002 =\002,i5"
+ ",/\002 ==> UPLO='\002,a1,\002', DIAG ='\002,a1,\002', N =\002,i5,"
+ "\002, NB =\002,i4,\002, type \002,i2)";
+ static char fmt_9967[] = "(\002 *** Error code from \002,a,\002 =\002,i5"
+ ",/\002 ==> NORM='\002,a1,\002', UPLO ='\002,a1,\002', DIAG='\002"
+ ",a1,\002', N =\002,i5,\002, type \002,i2)";
+ static char fmt_9952[] = "(\002 *** Error code from \002,a,\002 =\002,i5"
+ ",/\002 ==> UPLO='\002,a1,\002', TRANS='\002,a1,\002', DIAG='\002"
+ ",a1,\002', NORMIN='\002,a1,\002', N =\002,i5,\002, type \002,i2)";
+ static char fmt_9953[] = "(\002 *** Error code from \002,a,\002 =\002,i5"
+ ",/\002 ==> UPLO='\002,a1,\002', TRANS='\002,a1,\002', DIAG='\002"
+ ",a1,\002', N =\002,i5,\002, NRHS =\002,i4,\002, type \002,i2)";
+ static char fmt_9962[] = "(\002 *** Error code from \002,a,\002 =\002,i5"
+ ",/\002 ==> UPLO='\002,a1,\002', DIAG ='\002,a1,\002', N =\002,i5,"
+ "\002, type \002,i2)";
+ static char fmt_9966[] = "(\002 *** Error code from \002,a,\002 =\002,i5"
+ ",/\002 ==> NORM='\002,a1,\002', UPLO ='\002,a1,\002', DIAG='\002"
+ ",a1,\002', N=\002,i5,\002, KD=\002,i5,\002, type \002,i2)";
+ static char fmt_9951[] = "(\002 *** Error code from \002,a,\002 =\002,i5"
+ ",/\002 ==> UPLO='\002,a1,\002', TRANS='\002,a1,\002', DIAG='\002"
+ ",a1,\002', NORMIN='\002,a1,\002', N=\002,i5,\002, KD=\002,i5,"
+ "\002, type \002,i2)";
+ static char fmt_9954[] = "(\002 *** Error code from \002,a,\002 =\002,i5"
+ ",/\002 ==> UPLO='\002,a1,\002', TRANS='\002,a1,\002', DIAG='\002"
+ ",a1,\002', N=\002,i5,\002, KD=\002,i5,\002, NRHS=\002,i4,\002, t"
+ "ype \002,i2)";
+ static char fmt_9985[] = "(\002 *** \002,a,\002 returned with INFO =\002"
+ ",i5,\002 instead of \002,i2,/\002 ==> N =\002,i5,\002, NB =\002,"
+ "i4,\002, type \002,i2)";
+ static char fmt_9950[] = "(\002 *** Error code from \002,a,\002 =\002,i5)"
+ ;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), i_len_trim(char *, ftnlen), do_fio(integer *,
+ char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ char c3[3], p2[2], uplo[1];
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int aladhd_(integer *, char *);
+ extern logical lsamen_(integer *, char *, char *);
+
+ /* Fortran I/O blocks */
+ static cilist io___3 = { 0, 0, 0, fmt_9988, 0 };
+ static cilist io___4 = { 0, 0, 0, fmt_9975, 0 };
+ static cilist io___5 = { 0, 0, 0, fmt_9949, 0 };
+ static cilist io___6 = { 0, 0, 0, fmt_9984, 0 };
+ static cilist io___7 = { 0, 0, 0, fmt_9970, 0 };
+ static cilist io___8 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___9 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___10 = { 0, 0, 0, fmt_9971, 0 };
+ static cilist io___11 = { 0, 0, 0, fmt_9978, 0 };
+ static cilist io___12 = { 0, 0, 0, fmt_9969, 0 };
+ static cilist io___13 = { 0, 0, 0, fmt_9965, 0 };
+ static cilist io___14 = { 0, 0, 0, fmt_9974, 0 };
+ static cilist io___15 = { 0, 0, 0, fmt_9963, 0 };
+ static cilist io___16 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___17 = { 0, 0, 0, fmt_9976, 0 };
+ static cilist io___18 = { 0, 0, 0, fmt_9949, 0 };
+ static cilist io___19 = { 0, 0, 0, fmt_9986, 0 };
+ static cilist io___20 = { 0, 0, 0, fmt_9972, 0 };
+ static cilist io___21 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9977, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9968, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9964, 0 };
+ static cilist io___26 = { 0, 0, 0, fmt_9987, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9973, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9949, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9984, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9970, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9969, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9963, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9980, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9956, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9949, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9979, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9956, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9960, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9980, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9956, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9949, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_9979, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9956, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9960, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9980, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9956, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9949, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9979, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9960, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9983, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9960, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9949, 0 };
+ static cilist io___68 = { 0, 0, 0, fmt_9979, 0 };
+ static cilist io___69 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___70 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___71 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___72 = { 0, 0, 0, fmt_9960, 0 };
+ static cilist io___73 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___74 = { 0, 0, 0, fmt_9982, 0 };
+ static cilist io___75 = { 0, 0, 0, fmt_9958, 0 };
+ static cilist io___76 = { 0, 0, 0, fmt_9949, 0 };
+ static cilist io___77 = { 0, 0, 0, fmt_9981, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9957, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___80 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___81 = { 0, 0, 0, fmt_9959, 0 };
+ static cilist io___82 = { 0, 0, 0, fmt_9957, 0 };
+ static cilist io___83 = { 0, 0, 0, fmt_9987, 0 };
+ static cilist io___84 = { 0, 0, 0, fmt_9973, 0 };
+ static cilist io___85 = { 0, 0, 0, fmt_9949, 0 };
+ static cilist io___86 = { 0, 0, 0, fmt_9984, 0 };
+ static cilist io___87 = { 0, 0, 0, fmt_9970, 0 };
+ static cilist io___88 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___89 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___90 = { 0, 0, 0, fmt_9973, 0 };
+ static cilist io___91 = { 0, 0, 0, fmt_9969, 0 };
+ static cilist io___92 = { 0, 0, 0, fmt_9963, 0 };
+ static cilist io___93 = { 0, 0, 0, fmt_9961, 0 };
+ static cilist io___94 = { 0, 0, 0, fmt_9967, 0 };
+ static cilist io___95 = { 0, 0, 0, fmt_9952, 0 };
+ static cilist io___96 = { 0, 0, 0, fmt_9953, 0 };
+ static cilist io___97 = { 0, 0, 0, fmt_9962, 0 };
+ static cilist io___98 = { 0, 0, 0, fmt_9967, 0 };
+ static cilist io___99 = { 0, 0, 0, fmt_9952, 0 };
+ static cilist io___100 = { 0, 0, 0, fmt_9953, 0 };
+ static cilist io___101 = { 0, 0, 0, fmt_9966, 0 };
+ static cilist io___102 = { 0, 0, 0, fmt_9951, 0 };
+ static cilist io___103 = { 0, 0, 0, fmt_9954, 0 };
+ static cilist io___104 = { 0, 0, 0, fmt_9974, 0 };
+ static cilist io___105 = { 0, 0, 0, fmt_9978, 0 };
+ static cilist io___106 = { 0, 0, 0, fmt_9974, 0 };
+ static cilist io___107 = { 0, 0, 0, fmt_9978, 0 };
+ static cilist io___108 = { 0, 0, 0, fmt_9974, 0 };
+ static cilist io___109 = { 0, 0, 0, fmt_9978, 0 };
+ static cilist io___110 = { 0, 0, 0, fmt_9974, 0 };
+ static cilist io___111 = { 0, 0, 0, fmt_9978, 0 };
+ static cilist io___112 = { 0, 0, 0, fmt_9988, 0 };
+ static cilist io___113 = { 0, 0, 0, fmt_9975, 0 };
+ static cilist io___114 = { 0, 0, 0, fmt_9985, 0 };
+ static cilist io___115 = { 0, 0, 0, fmt_9971, 0 };
+ static cilist io___116 = { 0, 0, 0, fmt_9950, 0 };
+
+ int subnam_len;
+
+ subnam_len = strlen(subnam);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ALAERH is an error handler for the LAPACK routines. It prints the */
+/* header if this is the first error message and prints the error code */
+/* and form of recovery, if any. The character evaluations in this */
+/* routine may make it slow, but it should not be called once the LAPACK */
+/* routines are fully debugged. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name of subroutine SUBNAM. */
+
+/* SUBNAM (input) CHARACTER*(*) */
+/* The name of the subroutine that returned an error code. */
+
+/* INFO (input) INTEGER */
+/* The error code returned from routine SUBNAM. */
+
+/* INFOE (input) INTEGER */
+/* The expected error code from routine SUBNAM, if SUBNAM were */
+/* error-free. If INFOE = 0, an error message is printed, but */
+/* if INFOE.NE.0, we assume only the return code INFO is wrong. */
+
+/* OPTS (input) CHARACTER*(*) */
+/* The character options to the subroutine SUBNAM, concatenated */
+/* into a single character string. For example, UPLO = 'U', */
+/* TRANS = 'T', and DIAG = 'N' for a triangular routine would */
+/* be specified as OPTS = 'UTN'. */
+
+/* M (input) INTEGER */
+/* The matrix row dimension. */
+
+/* N (input) INTEGER */
+/* The matrix column dimension. Accessed only if PATH = xGE or */
+/* xGB. */
+
+/* KL (input) INTEGER */
+/* The number of sub-diagonals of the matrix. Accessed only if */
+/* PATH = xGB, xPB, or xTB. Also used for NRHS for PATH = xLS. */
+
+/* KU (input) INTEGER */
+/* The number of super-diagonals of the matrix. Accessed only */
+/* if PATH = xGB. */
+
+/* N5 (input) INTEGER */
+/* A fifth integer parameter, may be the blocksize NB or the */
+/* number of right hand sides NRHS. */
+
+/* IMAT (input) INTEGER */
+/* The matrix type. */
+
+/* NFAIL (input) INTEGER */
+/* The number of prior tests that did not pass the threshold; */
+/* used to determine if the header should be printed. */
+
+/* NERRS (input/output) INTEGER */
+/* On entry, the number of errors already detected; used to */
+/* determine if the header should be printed. */
+/* On exit, NERRS is increased by 1. */
+
+/* NOUT (input) INTEGER */
+/* The unit number on which results are to be printed. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (*info == 0) {
+ return 0;
+ }
+ s_copy(p2, path + 1, (ftnlen)2, (ftnlen)2);
+ s_copy(c3, subnam + 3, (ftnlen)3, (ftnlen)3);
+
+/* Print the header if this is the first error message. */
+
+ if (*nfail == 0 && *nerrs == 0) {
+ if (lsamen_(&c__3, c3, "SV ") || lsamen_(&c__3,
+ c3, "SVX")) {
+ aladhd_(nout, path);
+ } else {
+ alahd_(nout, path);
+ }
+ }
+ ++(*nerrs);
+
+/* Print the message detailing the error and form of recovery, */
+/* if any. */
+
+ if (lsamen_(&c__2, p2, "GE")) {
+
+/* xGE: General matrices */
+
+ if (lsamen_(&c__3, c3, "TRF")) {
+ if (*info != *infoe && *infoe != 0) {
+ io___3.ciunit = *nout;
+ s_wsfe(&io___3);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___4.ciunit = *nout;
+ s_wsfe(&io___4);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*info != 0) {
+ io___5.ciunit = *nout;
+ s_wsfe(&io___5);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "SV ")) {
+
+ if (*info != *infoe && *infoe != 0) {
+ io___6.ciunit = *nout;
+ s_wsfe(&io___6);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___7.ciunit = *nout;
+ s_wsfe(&io___7);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "SVX")) {
+
+ if (*info != *infoe && *infoe != 0) {
+ io___8.ciunit = *nout;
+ s_wsfe(&io___8);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___9.ciunit = *nout;
+ s_wsfe(&io___9);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "TRI")) {
+
+ io___10.ciunit = *nout;
+ s_wsfe(&io___10);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ } else if (lsamen_(&c__5, subnam + 1, "LATMS"))
+ {
+
+ io___11.ciunit = *nout;
+ s_wsfe(&io___11);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ } else if (lsamen_(&c__3, c3, "CON")) {
+
+ io___12.ciunit = *nout;
+ s_wsfe(&io___12);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ } else if (lsamen_(&c__3, c3, "LS ")) {
+
+ io___13.ciunit = *nout;
+ s_wsfe(&io___13);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ } else if (lsamen_(&c__3, c3, "LSX") || lsamen_(
+ &c__3, c3, "LSS")) {
+
+ io___14.ciunit = *nout;
+ s_wsfe(&io___14);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ } else {
+
+ io___15.ciunit = *nout;
+ s_wsfe(&io___15);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, p2, "GB")) {
+
+/* xGB: General band matrices */
+
+ if (lsamen_(&c__3, c3, "TRF")) {
+ if (*info != *infoe && *infoe != 0) {
+ io___16.ciunit = *nout;
+ s_wsfe(&io___16);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ku), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___17.ciunit = *nout;
+ s_wsfe(&io___17);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ku), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*info != 0) {
+ io___18.ciunit = *nout;
+ s_wsfe(&io___18);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "SV ")) {
+
+ if (*info != *infoe && *infoe != 0) {
+ io___19.ciunit = *nout;
+ s_wsfe(&io___19);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ku), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___20.ciunit = *nout;
+ s_wsfe(&io___20);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ku), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "SVX")) {
+
+ if (*info != *infoe && *infoe != 0) {
+ io___21.ciunit = *nout;
+ s_wsfe(&io___21);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ku), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___22.ciunit = *nout;
+ s_wsfe(&io___22);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ku), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__5, subnam + 1, "LATMS"))
+ {
+
+ io___23.ciunit = *nout;
+ s_wsfe(&io___23);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ku), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ } else if (lsamen_(&c__3, c3, "CON")) {
+
+ io___24.ciunit = *nout;
+ s_wsfe(&io___24);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ku), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ } else {
+
+ io___25.ciunit = *nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ku), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, p2, "GT")) {
+
+/* xGT: General tridiagonal matrices */
+
+ if (lsamen_(&c__3, c3, "TRF")) {
+ if (*info != *infoe && *infoe != 0) {
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*info != 0) {
+ io___28.ciunit = *nout;
+ s_wsfe(&io___28);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "SV ")) {
+
+ if (*info != *infoe && *infoe != 0) {
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "SVX")) {
+
+ if (*info != *infoe && *infoe != 0) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "CON")) {
+
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ } else {
+
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, p2, "PO")) {
+
+/* xPO: Symmetric or Hermitian positive definite matrices */
+
+ *(unsigned char *)uplo = *(unsigned char *)opts;
+ if (lsamen_(&c__3, c3, "TRF")) {
+ if (*info != *infoe && *infoe != 0) {
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*info != 0) {
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "SV ")) {
+
+ if (*info != *infoe && *infoe != 0) {
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "SVX")) {
+
+ if (*info != *infoe && *infoe != 0) {
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "TRI")) {
+
+ io___43.ciunit = *nout;
+ s_wsfe(&io___43);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ } else if (lsamen_(&c__5, subnam + 1, "LATMS")
+ || lsamen_(&c__3, c3, "CON")) {
+
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ } else {
+
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, p2, "PS")) {
+
+/* xPS: Symmetric or Hermitian positive semi-definite matrices */
+
+ *(unsigned char *)uplo = *(unsigned char *)opts;
+ if (lsamen_(&c__3, c3, "TRF")) {
+ if (*info != *infoe && *infoe != 0) {
+ io___46.ciunit = *nout;
+ s_wsfe(&io___46);
+ do_fio(&c__1, subnam, subnam_len);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___47.ciunit = *nout;
+ s_wsfe(&io___47);
+ do_fio(&c__1, subnam, subnam_len);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*info != 0) {
+ io___48.ciunit = *nout;
+ s_wsfe(&io___48);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "SV ")) {
+
+ if (*info != *infoe && *infoe != 0) {
+ io___49.ciunit = *nout;
+ s_wsfe(&io___49);
+ do_fio(&c__1, subnam, subnam_len);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___50.ciunit = *nout;
+ s_wsfe(&io___50);
+ do_fio(&c__1, subnam, subnam_len);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "SVX")) {
+
+ if (*info != *infoe && *infoe != 0) {
+ io___51.ciunit = *nout;
+ s_wsfe(&io___51);
+ do_fio(&c__1, subnam, subnam_len);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___52.ciunit = *nout;
+ s_wsfe(&io___52);
+ do_fio(&c__1, subnam, subnam_len);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "TRI")) {
+
+ io___53.ciunit = *nout;
+ s_wsfe(&io___53);
+ do_fio(&c__1, subnam, subnam_len);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ } else if (lsamen_(&c__5, subnam + 1, "LATMT")
+ || lsamen_(&c__3, c3, "CON")) {
+
+ io___54.ciunit = *nout;
+ s_wsfe(&io___54);
+ do_fio(&c__1, subnam, subnam_len);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ } else {
+
+ io___55.ciunit = *nout;
+ s_wsfe(&io___55);
+ do_fio(&c__1, subnam, subnam_len);
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, p2, "SY") || lsamen_(&
+ c__2, p2, "HE")) {
+
+/* xHE, or xSY: Symmetric or Hermitian indefinite matrices */
+
+ *(unsigned char *)uplo = *(unsigned char *)opts;
+ if (lsamen_(&c__3, c3, "TRF")) {
+ if (*info != *infoe && *infoe != 0) {
+ io___56.ciunit = *nout;
+ s_wsfe(&io___56);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___57.ciunit = *nout;
+ s_wsfe(&io___57);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*info != 0) {
+ io___58.ciunit = *nout;
+ s_wsfe(&io___58);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "SV ")) {
+
+ if (*info != *infoe && *infoe != 0) {
+ io___59.ciunit = *nout;
+ s_wsfe(&io___59);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___60.ciunit = *nout;
+ s_wsfe(&io___60);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "SVX")) {
+
+ if (*info != *infoe && *infoe != 0) {
+ io___61.ciunit = *nout;
+ s_wsfe(&io___61);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___62.ciunit = *nout;
+ s_wsfe(&io___62);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__5, subnam + 1, "LATMS")
+ || lsamen_(&c__3, c3, "TRI") || lsamen_(
+ &c__3, c3, "CON")) {
+
+ io___63.ciunit = *nout;
+ s_wsfe(&io___63);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ } else {
+
+ io___64.ciunit = *nout;
+ s_wsfe(&io___64);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, p2, "PP") || lsamen_(&
+ c__2, p2, "SP") || lsamen_(&c__2, p2, "HP")) {
+
+/* xPP, xHP, or xSP: Symmetric or Hermitian packed matrices */
+
+ *(unsigned char *)uplo = *(unsigned char *)opts;
+ if (lsamen_(&c__3, c3, "TRF")) {
+ if (*info != *infoe && *infoe != 0) {
+ io___65.ciunit = *nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___66.ciunit = *nout;
+ s_wsfe(&io___66);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*info != 0) {
+ io___67.ciunit = *nout;
+ s_wsfe(&io___67);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "SV ")) {
+
+ if (*info != *infoe && *infoe != 0) {
+ io___68.ciunit = *nout;
+ s_wsfe(&io___68);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___69.ciunit = *nout;
+ s_wsfe(&io___69);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "SVX")) {
+
+ if (*info != *infoe && *infoe != 0) {
+ io___70.ciunit = *nout;
+ s_wsfe(&io___70);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___71.ciunit = *nout;
+ s_wsfe(&io___71);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__5, subnam + 1, "LATMS")
+ || lsamen_(&c__3, c3, "TRI") || lsamen_(
+ &c__3, c3, "CON")) {
+
+ io___72.ciunit = *nout;
+ s_wsfe(&io___72);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ } else {
+
+ io___73.ciunit = *nout;
+ s_wsfe(&io___73);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, p2, "PB")) {
+
+/* xPB: Symmetric (Hermitian) positive definite band matrix */
+
+ *(unsigned char *)uplo = *(unsigned char *)opts;
+ if (lsamen_(&c__3, c3, "TRF")) {
+ if (*info != *infoe && *infoe != 0) {
+ io___74.ciunit = *nout;
+ s_wsfe(&io___74);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___75.ciunit = *nout;
+ s_wsfe(&io___75);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*info != 0) {
+ io___76.ciunit = *nout;
+ s_wsfe(&io___76);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "SV ")) {
+
+ if (*info != *infoe && *infoe != 0) {
+ io___77.ciunit = *nout;
+ s_wsfe(&io___77);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___78.ciunit = *nout;
+ s_wsfe(&io___78);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "SVX")) {
+
+ if (*info != *infoe && *infoe != 0) {
+ io___79.ciunit = *nout;
+ s_wsfe(&io___79);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___80.ciunit = *nout;
+ s_wsfe(&io___80);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__5, subnam + 1, "LATMS")
+ || lsamen_(&c__3, c3, "CON")) {
+
+ io___81.ciunit = *nout;
+ s_wsfe(&io___81);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+
+ } else {
+
+ io___82.ciunit = *nout;
+ s_wsfe(&io___82);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, p2, "PT")) {
+
+/* xPT: Positive definite tridiagonal matrices */
+
+ if (lsamen_(&c__3, c3, "TRF")) {
+ if (*info != *infoe && *infoe != 0) {
+ io___83.ciunit = *nout;
+ s_wsfe(&io___83);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___84.ciunit = *nout;
+ s_wsfe(&io___84);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*info != 0) {
+ io___85.ciunit = *nout;
+ s_wsfe(&io___85);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "SV ")) {
+
+ if (*info != *infoe && *infoe != 0) {
+ io___86.ciunit = *nout;
+ s_wsfe(&io___86);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___87.ciunit = *nout;
+ s_wsfe(&io___87);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "SVX")) {
+
+ if (*info != *infoe && *infoe != 0) {
+ io___88.ciunit = *nout;
+ s_wsfe(&io___88);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___89.ciunit = *nout;
+ s_wsfe(&io___89);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__3, c3, "CON")) {
+
+ if (lsame_(subnam, "S") || lsame_(subnam,
+ "D")) {
+ io___90.ciunit = *nout;
+ s_wsfe(&io___90);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___91.ciunit = *nout;
+ s_wsfe(&io___91);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else {
+
+ io___92.ciunit = *nout;
+ s_wsfe(&io___92);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, p2, "TR")) {
+
+/* xTR: Triangular matrix */
+
+ if (lsamen_(&c__3, c3, "TRI")) {
+ io___93.ciunit = *nout;
+ s_wsfe(&io___93);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (lsamen_(&c__3, c3, "CON")) {
+ io___94.ciunit = *nout;
+ s_wsfe(&io___94);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, opts + 2, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (lsamen_(&c__5, subnam + 1, "LATRS"))
+ {
+ io___95.ciunit = *nout;
+ s_wsfe(&io___95);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, opts + 2, (ftnlen)1);
+ do_fio(&c__1, opts + 3, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___96.ciunit = *nout;
+ s_wsfe(&io___96);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, opts + 2, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, p2, "TP")) {
+
+/* xTP: Triangular packed matrix */
+
+ if (lsamen_(&c__3, c3, "TRI")) {
+ io___97.ciunit = *nout;
+ s_wsfe(&io___97);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (lsamen_(&c__3, c3, "CON")) {
+ io___98.ciunit = *nout;
+ s_wsfe(&io___98);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, opts + 2, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (lsamen_(&c__5, subnam + 1, "LATPS"))
+ {
+ io___99.ciunit = *nout;
+ s_wsfe(&io___99);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, opts + 2, (ftnlen)1);
+ do_fio(&c__1, opts + 3, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___100.ciunit = *nout;
+ s_wsfe(&io___100);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, opts + 2, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, p2, "TB")) {
+
+/* xTB: Triangular band matrix */
+
+ if (lsamen_(&c__3, c3, "CON")) {
+ io___101.ciunit = *nout;
+ s_wsfe(&io___101);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, opts + 2, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (lsamen_(&c__5, subnam + 1, "LATBS"))
+ {
+ io___102.ciunit = *nout;
+ s_wsfe(&io___102);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, opts + 2, (ftnlen)1);
+ do_fio(&c__1, opts + 3, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___103.ciunit = *nout;
+ s_wsfe(&io___103);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, opts, (ftnlen)1);
+ do_fio(&c__1, opts + 1, (ftnlen)1);
+ do_fio(&c__1, opts + 2, (ftnlen)1);
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, p2, "QR")) {
+
+/* xQR: QR factorization */
+
+ if (lsamen_(&c__3, c3, "QRS")) {
+ io___104.ciunit = *nout;
+ s_wsfe(&io___104);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (lsamen_(&c__5, subnam + 1, "LATMS"))
+ {
+ io___105.ciunit = *nout;
+ s_wsfe(&io___105);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, p2, "LQ")) {
+
+/* xLQ: LQ factorization */
+
+ if (lsamen_(&c__3, c3, "LQS")) {
+ io___106.ciunit = *nout;
+ s_wsfe(&io___106);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (lsamen_(&c__5, subnam + 1, "LATMS"))
+ {
+ io___107.ciunit = *nout;
+ s_wsfe(&io___107);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, p2, "QL")) {
+
+/* xQL: QL factorization */
+
+ if (lsamen_(&c__3, c3, "QLS")) {
+ io___108.ciunit = *nout;
+ s_wsfe(&io___108);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (lsamen_(&c__5, subnam + 1, "LATMS"))
+ {
+ io___109.ciunit = *nout;
+ s_wsfe(&io___109);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, p2, "RQ")) {
+
+/* xRQ: RQ factorization */
+
+ if (lsamen_(&c__3, c3, "RQS")) {
+ io___110.ciunit = *nout;
+ s_wsfe(&io___110);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*kl), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else if (lsamen_(&c__5, subnam + 1, "LATMS"))
+ {
+ io___111.ciunit = *nout;
+ s_wsfe(&io___111);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, p2, "LU")) {
+
+ if (*info != *infoe && *infoe != 0) {
+ io___112.ciunit = *nout;
+ s_wsfe(&io___112);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___113.ciunit = *nout;
+ s_wsfe(&io___113);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, p2, "CH")) {
+
+ if (*info != *infoe && *infoe != 0) {
+ io___114.ciunit = *nout;
+ s_wsfe(&io___114);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*infoe), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___115.ciunit = *nout;
+ s_wsfe(&io___115);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*m), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*n5), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*imat), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ } else {
+
+/* Print a generic message if the path is unknown. */
+
+ io___116.ciunit = *nout;
+ s_wsfe(&io___116);
+ do_fio(&c__1, subnam, i_len_trim(subnam, subnam_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+/* Description of error message (alphabetical, left to right) */
+
+/* SUBNAM, INFO, FACT, N, NRHS, IMAT */
+
+
+/* SUBNAM, INFO, FACT, TRANS, N, KL, KU, NRHS, IMAT */
+
+
+/* SUBNAM, INFO, FACT, TRANS, N, NRHS, IMAT */
+
+
+/* SUBNAM, INFO, FACT, UPLO, N, KD, NRHS, IMAT */
+
+
+/* SUBNAM, INFO, FACT, UPLO, N, NRHS, IMAT */
+
+
+/* SUBNAM, INFO, INFOE, FACT, N, NRHS, IMAT */
+
+
+/* SUBNAM, INFO, INFOE, FACT, TRANS, N, KL, KU, NRHS, IMAT */
+
+
+/* SUBNAM, INFO, INFOE, FACT, TRANS, N, NRHS, IMAT */
+
+
+/* SUBNAM, INFO, INFOE, FACT, UPLO, N, KD, NRHS, IMAT */
+
+
+/* SUBNAM, INFO, INFOE, FACT, UPLO, N, NRHS, IMAT */
+
+
+/* SUBNAM, INFO, INFOE, M, N, KL, KU, NB, IMAT */
+
+
+/* SUBNAM, INFO, INFOE, M, N, NB, IMAT */
+
+
+/* SUBNAM, INFO, INFOE, N, IMAT */
+
+
+/* SUBNAM, INFO, INFOE, N, KL, KU, NRHS, IMAT */
+
+
+/* SUBNAM, INFO, INFOE, N, NB, IMAT */
+
+
+/* SUBNAM, INFO, INFOE, N, NRHS, IMAT */
+
+
+/* SUBNAM, INFO, INFOE, UPLO, N, IMAT */
+
+
+/* SUBNAM, INFO, INFOE, UPLO, N, KD, NB, IMAT */
+
+
+/* SUBNAM, INFO, INFOE, UPLO, N, KD, NRHS, IMAT */
+
+
+/* SUBNAM, INFO, INFOE, UPLO, N, NB, IMAT */
+
+
+/* SUBNAM, INFO, INFOE, UPLO, N, NRHS, IMAT */
+
+
+/* SUBNAM, INFO, M, N, IMAT */
+
+
+/* SUBNAM, INFO, M, N, KL, KU, IMAT */
+
+
+/* SUBNAM, INFO, M, N, KL, KU, NB, IMAT */
+
+
+/* SUBNAM, INFO, M, N, NB, IMAT */
+
+
+/* SUBNAM, INFO, M, N, NRHS, NB, IMAT */
+
+
+/* SUBNAM, INFO, N, IMAT */
+
+
+/* SUBNAM, INFO, N, KL, KU, NRHS, IMAT */
+
+
+/* SUBNAM, INFO, N, NB, IMAT */
+
+
+/* SUBNAM, INFO, N, NRHS, IMAT */
+
+
+/* SUBNAM, INFO, NORM, N, IMAT */
+
+
+/* SUBNAM, INFO, NORM, N, KL, KU, IMAT */
+
+
+/* SUBNAM, INFO, NORM, UPLO, DIAG, N, IMAT */
+
+
+/* SUBNAM, INFO, NORM, UPLO, DIAG, N, KD, IMAT */
+
+
+/* SUBNAM, INFO, TRANS, M, N, NRHS, NB, IMAT */
+
+
+/* SUBNAM, INFO, TRANS, N, KL, KU, NRHS, IMAT */
+
+
+/* SUBNAM, INFO, TRANS, N, NRHS, IMAT */
+
+
+/* SUBNAM, INFO, UPLO, DIAG, N, IMAT */
+
+
+/* SUBNAM, INFO, UPLO, DIAG, N, NB, IMAT */
+
+
+/* SUBNAM, INFO, UPLO, N, IMAT */
+
+
+/* SUBNAM, INFO, UPLO, N, KD, IMAT */
+
+
+/* SUBNAM, INFO, UPLO, N, KD, NB, IMAT */
+
+
+/* SUBNAM, INFO, UPLO, N, KD, NRHS, IMAT */
+
+
+/* SUBNAM, INFO, UPLO, N, NB, IMAT */
+
+
+/* SUBNAM, INFO, UPLO, N, NRHS, IMAT */
+
+
+/* SUBNAM, INFO, UPLO, TRANS, DIAG, N, KD, NRHS, IMAT */
+
+
+/* SUBNAM, INFO, UPLO, TRANS, DIAG, N, NRHS, IMAT */
+
+
+/* SUBNAM, INFO, UPLO, TRANS, DIAG, NORMIN, N, IMAT */
+
+
+/* SUBNAM, INFO, UPLO, TRANS, DIAG, NORMIN, N, KD, IMAT */
+
+
+/* Unknown type */
+
+
+/* What we do next */
+
+
+ return 0;
+
+/* End of ALAERH */
+
+} /* alaerh_ */
diff --git a/TESTING/LIN/alaesm.c b/TESTING/LIN/alaesm.c
new file mode 100644
index 0000000..662424e
--- /dev/null
+++ b/TESTING/LIN/alaesm.c
@@ -0,0 +1,83 @@
+/* alaesm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int alaesm_(char *path, logical *ok, integer *nout)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 routines passed the tests of the e"
+ "rror exits\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 routines failed the tes"
+ "ts of the error \002,\002exits ***\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___2 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ALAESM prints a summary of results from one of the -ERR- routines. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name. */
+
+/* OK (input) LOGICAL */
+/* The flag from CHKXER that indicates whether or not the tests */
+/* of error exits passed. */
+
+/* NOUT (input) INTEGER */
+/* The unit number on which results are to be printed. */
+/* NOUT >= 0. */
+
+/* ===================================================================== */
+
+/* .. Executable Statements .. */
+
+ if (*ok) {
+ io___1.ciunit = *nout;
+ s_wsfe(&io___1);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ } else {
+ io___2.ciunit = *nout;
+ s_wsfe(&io___2);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ return 0;
+
+/* End of ALAESM */
+
+} /* alaesm_ */
diff --git a/TESTING/LIN/alahd.c b/TESTING/LIN/alahd.c
new file mode 100644
index 0000000..08a6bbc
--- /dev/null
+++ b/TESTING/LIN/alahd.c
@@ -0,0 +1,1774 @@
+/* alahd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static integer c__5 = 5;
+static integer c__6 = 6;
+static integer c__7 = 7;
+static integer c__8 = 8;
+
+/* Subroutine */ int alahd_(integer *iounit, char *path)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(/1x,a3,\002: General dense matrices\002)";
+ static char fmt_9979[] = "(4x,\0021. Diagonal\002,24x,\0027. Last n/2 co"
+ "lumns zero\002,/4x,\0022. Upper triangular\002,16x,\0028. Random"
+ ", CNDNUM = sqrt(0.1/EPS)\002,/4x,\0023. Lower triangular\002,16x,"
+ "\0029. Random, CNDNUM = 0.1/EPS\002,/4x,\0024. Random, CNDNUM = 2"
+ "\002,13x,\00210. Scaled near underflow\002,/4x,\0025. First colu"
+ "mn zero\002,14x,\00211. Scaled near overflow\002,/4x,\0026. Last"
+ " column zero\002)";
+ static char fmt_9962[] = "(3x,i2,\002: norm( L * U - A ) / ( N * norm(A"
+ ") * EPS )\002)";
+ static char fmt_9961[] = "(3x,i2,\002: norm( I - A*AINV ) / \002,\002( N"
+ " * norm(A) * norm(AINV) * EPS )\002)";
+ static char fmt_9960[] = "(3x,i2,\002: norm( B - A * X ) / \002,\002( n"
+ "orm(A) * norm(X) * EPS )\002)";
+ static char fmt_9959[] = "(3x,i2,\002: norm( X - XACT ) / \002,\002( n"
+ "orm(XACT) * CNDNUM * EPS )\002)";
+ static char fmt_9958[] = "(3x,i2,\002: norm( X - XACT ) / \002,\002( n"
+ "orm(XACT) * CNDNUM * EPS ), refined\002)";
+ static char fmt_9957[] = "(3x,i2,\002: norm( X - XACT ) / \002,\002( n"
+ "orm(XACT) * (error bound) )\002)";
+ static char fmt_9956[] = "(3x,i2,\002: (backward error) / EPS\002)";
+ static char fmt_9955[] = "(3x,i2,\002: RCOND * CNDNUM - 1.0\002)";
+ static char fmt_9998[] = "(/1x,a3,\002: General band matrices\002)";
+ static char fmt_9978[] = "(4x,\0021. Random, CNDNUM = 2\002,14x,\0025. R"
+ "andom, CNDNUM = sqrt(0.1/EPS)\002,/4x,\0022. First column zer"
+ "o\002,15x,\0026. Random, CNDNUM = .01/EPS\002,/4x,\0023. Last co"
+ "lumn zero\002,16x,\0027. Scaled near underflow\002,/4x,\0024. La"
+ "st n/2 columns zero\002,11x,\0028. Scaled near overflow\002)";
+ static char fmt_9997[] = "(/1x,a3,\002: General tridiagonal\002)";
+ static char fmt_9977[] = "(\002 Matrix types (1-6 have specified conditi"
+ "on numbers):\002,/4x,\0021. Diagonal\002,24x,\0027. Random, unsp"
+ "ecified CNDNUM\002,/4x,\0022. Random, CNDNUM = 2\002,14x,\0028. "
+ "First column zero\002,/4x,\0023. Random, CNDNUM = sqrt(0.1/EPS"
+ ")\002,2x,\0029. Last column zero\002,/4x,\0024. Random, CNDNUM ="
+ " 0.1/EPS\002,7x,\00210. Last n/2 columns zero\002,/4x,\0025. Sca"
+ "led near underflow\002,10x,\00211. Scaled near underflow\002,/4x,"
+ "\0026. Scaled near overflow\002,11x,\00212. Scaled near overflo"
+ "w\002)";
+ static char fmt_9996[] = "(/1x,a3,\002: \002,a9,\002 positive definite "
+ "matrices\002)";
+ static char fmt_9995[] = "(/1x,a3,\002: \002,a9,\002 positive definite "
+ "packed matrices\002)";
+ static char fmt_9975[] = "(4x,\0021. Diagonal\002,24x,\0026. Random, CND"
+ "NUM = sqrt(0.1/EPS)\002,/4x,\0022. Random, CNDNUM = 2\002,14x"
+ ",\0027. Random, CNDNUM = 0.1/EPS\002,/3x,\002*3. First row and c"
+ "olumn zero\002,7x,\0028. Scaled near underflow\002,/3x,\002*4. L"
+ "ast row and column zero\002,8x,\0029. Scaled near overflow\002,/"
+ "3x,\002*5. Middle row and column zero\002,/3x,\002(* - tests err"
+ "or exits from \002,a3,\002TRF, no test ratios are computed)\002)";
+ static char fmt_9954[] = "(3x,i2,\002: norm( U' * U - A ) / ( N * norm(A"
+ ") * EPS )\002,\002, or\002,/7x,\002norm( L * L' - A ) / ( N * no"
+ "rm(A) * EPS )\002)";
+ static char fmt_8973[] = "(4x,\0021. Diagonal\002,/4x,\0022. Random, CND"
+ "NUM = 2\002,14x,/3x,\002*3. Nonzero eigenvalues of: D(1:RANK-1)="
+ "1 and \002,\002D(RANK) = 1.0/\002,a4,/3x,\002*4. Nonzero eigenva"
+ "lues of: D(1)=1 and \002,\002 D(2:RANK) = 1.0/\002,a4,/3x,\002*5"
+ ". Nonzero eigenvalues of: D(I) = \002,a4,\002**(-(I-1)/(RANK-1)) "
+ "\002,\002 I=1:RANK\002,/4x,\0026. Random, CNDNUM = sqrt(0.1/EPS"
+ ")\002,/4x,\0027. Random, CNDNUM = 0.1/EPS\002,/4x,\0028. Scaled "
+ "near underflow\002,/4x,\0029. Scaled near overflow\002,/3x,\002("
+ "* - Semi-definite tests )\002)";
+ static char fmt_8972[] = "(3x,\002RANK minus computed rank, returned by"
+ " \002,a,\002PSTRF\002)";
+ static char fmt_8950[] = "(3x,\002norm( P * U' * U * P' - A ) / ( N * no"
+ "rm(A) * EPS )\002,\002, or\002,/3x,\002norm( P * L * L' * P' - A"
+ " ) / ( N * norm(A) * EPS )\002)";
+ static char fmt_9994[] = "(/1x,a3,\002: \002,a9,\002 positive definite "
+ "band matrices\002)";
+ static char fmt_9973[] = "(4x,\0021. Random, CNDNUM = 2\002,14x,\0025. R"
+ "andom, CNDNUM = sqrt(0.1/EPS)\002,/3x,\002*2. First row and colu"
+ "mn zero\002,7x,\0026. Random, CNDNUM = 0.1/EPS\002,/3x,\002*3. L"
+ "ast row and column zero\002,8x,\0027. Scaled near underflow\002,"
+ "/3x,\002*4. Middle row and column zero\002,6x,\0028. Scaled near"
+ " overflow\002,/3x,\002(* - tests error exits from \002,a3,\002TR"
+ "F, no test ratios are computed)\002)";
+ static char fmt_9993[] = "(/1x,a3,\002: \002,a9,\002 positive definite "
+ "tridiagonal\002)";
+ static char fmt_9976[] = "(\002 Matrix types (1-6 have specified conditi"
+ "on numbers):\002,/4x,\0021. Diagonal\002,24x,\0027. Random, unsp"
+ "ecified CNDNUM\002,/4x,\0022. Random, CNDNUM = 2\002,14x,\0028. "
+ "First row and column zero\002,/4x,\0023. Random, CNDNUM = sqrt(0"
+ ".1/EPS)\002,2x,\0029. Last row and column zero\002,/4x,\0024. Ra"
+ "ndom, CNDNUM = 0.1/EPS\002,7x,\00210. Middle row and column zer"
+ "o\002,/4x,\0025. Scaled near underflow\002,10x,\00211. Scaled ne"
+ "ar underflow\002,/4x,\0026. Scaled near overflow\002,11x,\00212."
+ " Scaled near overflow\002)";
+ static char fmt_9952[] = "(3x,i2,\002: norm( U'*D*U - A ) / ( N * norm(A"
+ ") * EPS )\002,\002, or\002,/7x,\002norm( L*D*L' - A ) / ( N * no"
+ "rm(A) * EPS )\002)";
+ static char fmt_9992[] = "(/1x,a3,\002: \002,a9,\002 indefinite matri"
+ "ces\002)";
+ static char fmt_9991[] = "(/1x,a3,\002: \002,a9,\002 indefinite packed "
+ "matrices\002)";
+ static char fmt_9972[] = "(4x,\0021. Diagonal\002,24x,\0026. Last n/2 ro"
+ "ws and columns zero\002,/4x,\0022. Random, CNDNUM = 2\002,14x"
+ ",\0027. Random, CNDNUM = sqrt(0.1/EPS)\002,/4x,\0023. First row "
+ "and column zero\002,7x,\0028. Random, CNDNUM = 0.1/EPS\002,/4x"
+ ",\0024. Last row and column zero\002,8x,\0029. Scaled near under"
+ "flow\002,/4x,\0025. Middle row and column zero\002,5x,\00210. Sc"
+ "aled near overflow\002)";
+ static char fmt_9971[] = "(4x,\0021. Diagonal\002,24x,\0027. Random, CND"
+ "NUM = sqrt(0.1/EPS)\002,/4x,\0022. Random, CNDNUM = 2\002,14x"
+ ",\0028. Random, CNDNUM = 0.1/EPS\002,/4x,\0023. First row and co"
+ "lumn zero\002,7x,\0029. Scaled near underflow\002,/4x,\0024. Las"
+ "t row and column zero\002,7x,\00210. Scaled near overflow\002,/4"
+ "x,\0025. Middle row and column zero\002,5x,\00211. Block diagona"
+ "l matrix\002,/4x,\0026. Last n/2 rows and columns zero\002)";
+ static char fmt_9953[] = "(3x,i2,\002: norm( U*D*U' - A ) / ( N * norm(A"
+ ") * EPS )\002,\002, or\002,/7x,\002norm( L*D*L' - A ) / ( N * no"
+ "rm(A) * EPS )\002)";
+ static char fmt_9990[] = "(/1x,a3,\002: Triangular matrices\002)";
+ static char fmt_9989[] = "(/1x,a3,\002: Triangular packed matrices\002)";
+ static char fmt_9966[] = "(\002 Matrix types for \002,a3,\002 routines"
+ ":\002,/4x,\0021. Diagonal\002,24x,\0026. Scaled near overflow"
+ "\002,/4x,\0022. Random, CNDNUM = 2\002,14x,\0027. Identity\002,/"
+ "4x,\0023. Random, CNDNUM = sqrt(0.1/EPS) \002,\0028. Unit trian"
+ "gular, CNDNUM = 2\002,/4x,\0024. Random, CNDNUM = 0.1/EPS\002,8x,"
+ "\0029. Unit, CNDNUM = sqrt(0.1/EPS)\002,/4x,\0025. Scaled near u"
+ "nderflow\002,10x,\00210. Unit, CNDNUM = 0.1/EPS\002)";
+ static char fmt_9965[] = "(\002 Special types for testing \002,a,\002"
+ ":\002,/3x,\00211. Matrix elements are O(1), large right hand side"
+ "\002,/3x,\00212. First diagonal causes overflow,\002,\002 offdia"
+ "gonal column norms < 1\002,/3x,\00213. First diagonal causes ove"
+ "rflow,\002,\002 offdiagonal column norms > 1\002,/3x,\00214. Gro"
+ "wth factor underflows, solution does not overflow\002,/3x,\00215"
+ ". Small diagonal causes gradual overflow\002,/3x,\00216. One zer"
+ "o diagonal element\002,/3x,\00217. Large offdiagonals cause over"
+ "flow when adding a column\002,/3x,\00218. Unit triangular with l"
+ "arge right hand side\002)";
+ static char fmt_9951[] = "(\002 Test ratio for \002,a,\002:\002,/3x,i2"
+ ",\002: norm( s*b - A*x ) / ( norm(A) * norm(x) * EPS )\002)";
+ static char fmt_9988[] = "(/1x,a3,\002: Triangular band matrices\002)";
+ static char fmt_9964[] = "(\002 Matrix types for \002,a3,\002 routines"
+ ":\002,/4x,\0021. Random, CNDNUM = 2\002,14x,\0026. Identity\002,"
+ "/4x,\0022. Random, CNDNUM = sqrt(0.1/EPS) \002,\0027. Unit tria"
+ "ngular, CNDNUM = 2\002,/4x,\0023. Random, CNDNUM = 0.1/EPS\002,8"
+ "x,\0028. Unit, CNDNUM = sqrt(0.1/EPS)\002,/4x,\0024. Scaled near"
+ " underflow\002,11x,\0029. Unit, CNDNUM = 0.1/EPS\002,/4x,\0025. "
+ "Scaled near overflow\002)";
+ static char fmt_9963[] = "(\002 Special types for testing \002,a,\002"
+ ":\002,/3x,\00210. Matrix elements are O(1), large right hand side"
+ "\002,/3x,\00211. First diagonal causes overflow,\002,\002 offdia"
+ "gonal column norms < 1\002,/3x,\00212. First diagonal causes ove"
+ "rflow,\002,\002 offdiagonal column norms > 1\002,/3x,\00213. Gro"
+ "wth factor underflows, solution does not overflow\002,/3x,\00214"
+ ". Small diagonal causes gradual overflow\002,/3x,\00215. One zer"
+ "o diagonal element\002,/3x,\00216. Large offdiagonals cause over"
+ "flow when adding a column\002,/3x,\00217. Unit triangular with l"
+ "arge right hand side\002)";
+ static char fmt_9987[] = "(/1x,a3,\002: \002,a2,\002 factorization of g"
+ "eneral matrices\002)";
+ static char fmt_9970[] = "(4x,\0021. Diagonal\002,24x,\0025. Random, CND"
+ "NUM = sqrt(0.1/EPS)\002,/4x,\0022. Upper triangular\002,16x,\002"
+ "6. Random, CNDNUM = 0.1/EPS\002,/4x,\0023. Lower triangular\002,"
+ "16x,\0027. Scaled near underflow\002,/4x,\0024. Random, CNDNUM ="
+ " 2\002,14x,\0028. Scaled near overflow\002)";
+ static char fmt_9950[] = "(3x,i2,\002: norm( R - Q' * A ) / ( M * norm(A"
+ ") * EPS )\002)";
+ static char fmt_9946[] = "(3x,i2,\002: norm( I - Q'*Q ) / ( M * EPS "
+ ")\002)";
+ static char fmt_9944[] = "(3x,i2,\002: norm( Q*C - Q*C ) / \002,\002("
+ " \002,a1,\002 * norm(C) * EPS )\002)";
+ static char fmt_9943[] = "(3x,i2,\002: norm( C*Q - C*Q ) / \002,\002("
+ " \002,a1,\002 * norm(C) * EPS )\002)";
+ static char fmt_9942[] = "(3x,i2,\002: norm( Q'*C - Q'*C )/ \002,\002("
+ " \002,a1,\002 * norm(C) * EPS )\002)";
+ static char fmt_9941[] = "(3x,i2,\002: norm( C*Q' - C*Q' )/ \002,\002("
+ " \002,a1,\002 * norm(C) * EPS )\002)";
+ static char fmt_6660[] = "(3x,i2,\002: diagonal is not non-negative\002)";
+ static char fmt_9949[] = "(3x,i2,\002: norm( L - A * Q' ) / ( N * norm(A"
+ ") * EPS )\002)";
+ static char fmt_9945[] = "(3x,i2,\002: norm( I - Q*Q' ) / ( N * EPS "
+ ")\002)";
+ static char fmt_9948[] = "(3x,i2,\002: norm( L - Q' * A ) / ( M * norm(A"
+ ") * EPS )\002)";
+ static char fmt_9947[] = "(3x,i2,\002: norm( R - A * Q' ) / ( N * norm(A"
+ ") * EPS )\002)";
+ static char fmt_9986[] = "(/1x,a3,\002: QR factorization with column pi"
+ "voting\002)";
+ static char fmt_9969[] = "(\002 Matrix types (2-6 have condition 1/EPS)"
+ ":\002,/4x,\0021. Zero matrix\002,21x,\0024. First n/2 columns fi"
+ "xed\002,/4x,\0022. One small eigenvalue\002,12x,\0025. Last n/2 "
+ "columns fixed\002,/4x,\0023. Geometric distribution\002,10x,\002"
+ "6. Every second column fixed\002)";
+ static char fmt_9940[] = "(3x,i2,\002: norm(svd(A) - svd(R)) / \002,\002"
+ "( M * norm(svd(R)) * EPS )\002)";
+ static char fmt_9939[] = "(3x,i2,\002: norm( A*P - Q*R ) / ( M * nor"
+ "m(A) * EPS )\002)";
+ static char fmt_9938[] = "(3x,i2,\002: norm( I - Q'*Q ) / ( M * EPS"
+ " )\002)";
+ static char fmt_9985[] = "(/1x,a3,\002: RQ factorization of trapezoidal"
+ " matrix\002)";
+ static char fmt_9968[] = "(\002 Matrix types (2-3 have condition 1/EPS)"
+ ":\002,/4x,\0021. Zero matrix\002,/4x,\0022. One small eigenvalu"
+ "e\002,/4x,\0023. Geometric distribution\002)";
+ static char fmt_9929[] = "(\002 Test ratios (1-3: \002,a1,\002TZRQF, 4-6"
+ ": \002,a1,\002TZRZF):\002)";
+ static char fmt_9937[] = "(3x,i2,\002: norm( A - R*Q ) / ( M * nor"
+ "m(A) * EPS )\002)";
+ static char fmt_9984[] = "(/1x,a3,\002: Least squares driver routine"
+ "s\002)";
+ static char fmt_9967[] = "(\002 Matrix types (1-3: full rank, 4-6: rank "
+ "deficient):\002,/4x,\0021 and 4. Normal scaling\002,/4x,\0022 an"
+ "d 5. Scaled near overflow\002,/4x,\0023 and 6. Scaled near under"
+ "flow\002)";
+ static char fmt_9921[] = "(\002 Test ratios:\002,/\002 (1-2: \002,a1"
+ ",\002GELS, 3-6: \002,a1,\002GELSX, 7-10: \002,a1,\002GELSY, 11-1"
+ "4: \002,a1,\002GELSS, 15-18: \002,a1,\002GELSD)\002)";
+ static char fmt_9935[] = "(3x,i2,\002: norm( B - A * X ) / \002,\002( "
+ "max(M,N) * norm(A) * norm(X) * EPS )\002)";
+ static char fmt_9931[] = "(3x,i2,\002: norm( (A*X-B)' *A ) / \002,\002( "
+ "max(M,N,NRHS) * norm(A) * norm(B) * EPS )\002,/7x,\002if TRANS='"
+ "N' and M.GE.N or TRANS='T' and M.LT.N, \002,\002otherwise\002,/7"
+ "x,\002check if X is in the row space of A or A' \002,\002(overde"
+ "termined case)\002)";
+ static char fmt_9933[] = "(3x,i2,\002: norm(svd(A)-svd(R)) / \002,\002( "
+ "min(M,N) * norm(svd(R)) * EPS )\002)";
+ static char fmt_9934[] = "(3x,i2,\002: norm( (A*X-B)' *A ) / \002,\002( "
+ "max(M,N,NRHS) * norm(A) * norm(B) * EPS )\002)";
+ static char fmt_9932[] = "(3x,i2,\002: Check if X is in the row space of"
+ " A or A'\002)";
+ static char fmt_9920[] = "(3x,\002 7-10: same as 3-6\002,3x,\002 11-14: "
+ "same as 3-6\002,3x,\002 15-18: same as 3-6\002)";
+ static char fmt_9983[] = "(/1x,a3,\002: LU factorization variants\002)";
+ static char fmt_9982[] = "(/1x,a3,\002: Cholesky factorization variant"
+ "s\002)";
+ static char fmt_9974[] = "(4x,\0021. Diagonal\002,24x,\0026. Random, CND"
+ "NUM = sqrt(0.1/EPS)\002,/4x,\0022. Random, CNDNUM = 2\002,14x"
+ ",\0027. Random, CNDNUM = 0.1/EPS\002,/3x,\002*3. First row and c"
+ "olumn zero\002,7x,\0028. Scaled near underflow\002,/3x,\002*4. L"
+ "ast row and column zero\002,8x,\0029. Scaled near overflow\002,/"
+ "3x,\002*5. Middle row and column zero\002,/3x,\002(* - tests err"
+ "or exits, no test ratios are computed)\002)";
+ static char fmt_9981[] = "(/1x,a3,\002: QR factorization variants\002)";
+ static char fmt_9980[] = "(/1x,a3,\002: No header available\002)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1[2];
+ cilist ci__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+ integer i_len_trim(char *, ftnlen);
+
+ /* Local variables */
+ char c1[1], c3[1], p2[2], sym[9];
+ logical sord, corz;
+ extern logical lsame_(char *, char *);
+ char eigcnm[4];
+ extern logical lsamen_(integer *, char *, char *);
+ char subnam[32];
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___7 = { 0, 0, 0, fmt_9979, 0 };
+ static cilist io___8 = { 0, 0, 0, fmt_9962, 0 };
+ static cilist io___9 = { 0, 0, 0, fmt_9961, 0 };
+ static cilist io___10 = { 0, 0, 0, fmt_9960, 0 };
+ static cilist io___11 = { 0, 0, 0, fmt_9959, 0 };
+ static cilist io___12 = { 0, 0, 0, fmt_9958, 0 };
+ static cilist io___13 = { 0, 0, 0, fmt_9957, 0 };
+ static cilist io___14 = { 0, 0, 0, fmt_9956, 0 };
+ static cilist io___15 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___16 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___17 = { 0, 0, 0, fmt_9978, 0 };
+ static cilist io___18 = { 0, 0, 0, fmt_9962, 0 };
+ static cilist io___19 = { 0, 0, 0, fmt_9960, 0 };
+ static cilist io___20 = { 0, 0, 0, fmt_9959, 0 };
+ static cilist io___21 = { 0, 0, 0, fmt_9958, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9957, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9956, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___25 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___26 = { 0, 0, 0, fmt_9977, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9962, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9960, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9959, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9958, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9957, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9956, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9975, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9954, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9961, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9960, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9959, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9958, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9957, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9956, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_8973, 0 };
+ static cilist io___49 = { 0, 0, 0, fmt_8972, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_8950, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9973, 0 };
+ static cilist io___54 = { 0, 0, 0, fmt_9954, 0 };
+ static cilist io___55 = { 0, 0, 0, fmt_9960, 0 };
+ static cilist io___56 = { 0, 0, 0, fmt_9959, 0 };
+ static cilist io___57 = { 0, 0, 0, fmt_9958, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9957, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9956, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9993, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9976, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9952, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9960, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9959, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9958, 0 };
+ static cilist io___68 = { 0, 0, 0, fmt_9957, 0 };
+ static cilist io___69 = { 0, 0, 0, fmt_9956, 0 };
+ static cilist io___70 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___71 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___72 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___73 = { 0, 0, 0, fmt_9972, 0 };
+ static cilist io___74 = { 0, 0, 0, fmt_9971, 0 };
+ static cilist io___75 = { 0, 0, 0, fmt_9953, 0 };
+ static cilist io___76 = { 0, 0, 0, fmt_9961, 0 };
+ static cilist io___77 = { 0, 0, 0, fmt_9960, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9959, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9958, 0 };
+ static cilist io___80 = { 0, 0, 0, fmt_9956, 0 };
+ static cilist io___81 = { 0, 0, 0, fmt_9957, 0 };
+ static cilist io___82 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___83 = { 0, 0, 0, fmt_9992, 0 };
+ static cilist io___84 = { 0, 0, 0, fmt_9991, 0 };
+ static cilist io___85 = { 0, 0, 0, fmt_9972, 0 };
+ static cilist io___86 = { 0, 0, 0, fmt_9953, 0 };
+ static cilist io___87 = { 0, 0, 0, fmt_9961, 0 };
+ static cilist io___88 = { 0, 0, 0, fmt_9960, 0 };
+ static cilist io___89 = { 0, 0, 0, fmt_9959, 0 };
+ static cilist io___90 = { 0, 0, 0, fmt_9958, 0 };
+ static cilist io___91 = { 0, 0, 0, fmt_9956, 0 };
+ static cilist io___92 = { 0, 0, 0, fmt_9957, 0 };
+ static cilist io___93 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___94 = { 0, 0, 0, fmt_9990, 0 };
+ static cilist io___96 = { 0, 0, 0, fmt_9989, 0 };
+ static cilist io___97 = { 0, 0, 0, fmt_9966, 0 };
+ static cilist io___98 = { 0, 0, 0, fmt_9965, 0 };
+ static cilist io___99 = { 0, 0, 0, fmt_9961, 0 };
+ static cilist io___100 = { 0, 0, 0, fmt_9960, 0 };
+ static cilist io___101 = { 0, 0, 0, fmt_9959, 0 };
+ static cilist io___102 = { 0, 0, 0, fmt_9958, 0 };
+ static cilist io___103 = { 0, 0, 0, fmt_9957, 0 };
+ static cilist io___104 = { 0, 0, 0, fmt_9956, 0 };
+ static cilist io___105 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___106 = { 0, 0, 0, fmt_9951, 0 };
+ static cilist io___107 = { 0, 0, 0, fmt_9988, 0 };
+ static cilist io___108 = { 0, 0, 0, fmt_9964, 0 };
+ static cilist io___109 = { 0, 0, 0, fmt_9963, 0 };
+ static cilist io___110 = { 0, 0, 0, fmt_9960, 0 };
+ static cilist io___111 = { 0, 0, 0, fmt_9959, 0 };
+ static cilist io___112 = { 0, 0, 0, fmt_9958, 0 };
+ static cilist io___113 = { 0, 0, 0, fmt_9957, 0 };
+ static cilist io___114 = { 0, 0, 0, fmt_9956, 0 };
+ static cilist io___115 = { 0, 0, 0, fmt_9955, 0 };
+ static cilist io___116 = { 0, 0, 0, fmt_9951, 0 };
+ static cilist io___117 = { 0, 0, 0, fmt_9987, 0 };
+ static cilist io___118 = { 0, 0, 0, fmt_9970, 0 };
+ static cilist io___119 = { 0, 0, 0, fmt_9950, 0 };
+ static cilist io___120 = { 0, 0, 0, fmt_9946, 0 };
+ static cilist io___121 = { 0, 0, 0, fmt_9944, 0 };
+ static cilist io___122 = { 0, 0, 0, fmt_9943, 0 };
+ static cilist io___123 = { 0, 0, 0, fmt_9942, 0 };
+ static cilist io___124 = { 0, 0, 0, fmt_9941, 0 };
+ static cilist io___125 = { 0, 0, 0, fmt_9960, 0 };
+ static cilist io___126 = { 0, 0, 0, fmt_6660, 0 };
+ static cilist io___127 = { 0, 0, 0, fmt_9987, 0 };
+ static cilist io___128 = { 0, 0, 0, fmt_9970, 0 };
+ static cilist io___129 = { 0, 0, 0, fmt_9949, 0 };
+ static cilist io___130 = { 0, 0, 0, fmt_9945, 0 };
+ static cilist io___131 = { 0, 0, 0, fmt_9944, 0 };
+ static cilist io___132 = { 0, 0, 0, fmt_9943, 0 };
+ static cilist io___133 = { 0, 0, 0, fmt_9942, 0 };
+ static cilist io___134 = { 0, 0, 0, fmt_9941, 0 };
+ static cilist io___135 = { 0, 0, 0, fmt_9960, 0 };
+ static cilist io___136 = { 0, 0, 0, fmt_9987, 0 };
+ static cilist io___137 = { 0, 0, 0, fmt_9970, 0 };
+ static cilist io___138 = { 0, 0, 0, fmt_9948, 0 };
+ static cilist io___139 = { 0, 0, 0, fmt_9946, 0 };
+ static cilist io___140 = { 0, 0, 0, fmt_9944, 0 };
+ static cilist io___141 = { 0, 0, 0, fmt_9943, 0 };
+ static cilist io___142 = { 0, 0, 0, fmt_9942, 0 };
+ static cilist io___143 = { 0, 0, 0, fmt_9941, 0 };
+ static cilist io___144 = { 0, 0, 0, fmt_9960, 0 };
+ static cilist io___145 = { 0, 0, 0, fmt_9987, 0 };
+ static cilist io___146 = { 0, 0, 0, fmt_9970, 0 };
+ static cilist io___147 = { 0, 0, 0, fmt_9947, 0 };
+ static cilist io___148 = { 0, 0, 0, fmt_9945, 0 };
+ static cilist io___149 = { 0, 0, 0, fmt_9944, 0 };
+ static cilist io___150 = { 0, 0, 0, fmt_9943, 0 };
+ static cilist io___151 = { 0, 0, 0, fmt_9942, 0 };
+ static cilist io___152 = { 0, 0, 0, fmt_9941, 0 };
+ static cilist io___153 = { 0, 0, 0, fmt_9960, 0 };
+ static cilist io___154 = { 0, 0, 0, fmt_9986, 0 };
+ static cilist io___155 = { 0, 0, 0, fmt_9969, 0 };
+ static cilist io___156 = { 0, 0, 0, fmt_9940, 0 };
+ static cilist io___157 = { 0, 0, 0, fmt_9939, 0 };
+ static cilist io___158 = { 0, 0, 0, fmt_9938, 0 };
+ static cilist io___159 = { 0, 0, 0, fmt_9985, 0 };
+ static cilist io___160 = { 0, 0, 0, fmt_9968, 0 };
+ static cilist io___161 = { 0, 0, 0, fmt_9929, 0 };
+ static cilist io___162 = { 0, 0, 0, fmt_9940, 0 };
+ static cilist io___163 = { 0, 0, 0, fmt_9937, 0 };
+ static cilist io___164 = { 0, 0, 0, fmt_9938, 0 };
+ static cilist io___165 = { 0, 0, 0, fmt_9940, 0 };
+ static cilist io___166 = { 0, 0, 0, fmt_9937, 0 };
+ static cilist io___167 = { 0, 0, 0, fmt_9938, 0 };
+ static cilist io___168 = { 0, 0, 0, fmt_9984, 0 };
+ static cilist io___169 = { 0, 0, 0, fmt_9967, 0 };
+ static cilist io___170 = { 0, 0, 0, fmt_9921, 0 };
+ static cilist io___171 = { 0, 0, 0, fmt_9935, 0 };
+ static cilist io___172 = { 0, 0, 0, fmt_9931, 0 };
+ static cilist io___173 = { 0, 0, 0, fmt_9933, 0 };
+ static cilist io___174 = { 0, 0, 0, fmt_9935, 0 };
+ static cilist io___175 = { 0, 0, 0, fmt_9934, 0 };
+ static cilist io___176 = { 0, 0, 0, fmt_9932, 0 };
+ static cilist io___177 = { 0, 0, 0, fmt_9920, 0 };
+ static cilist io___178 = { 0, 0, 0, fmt_9983, 0 };
+ static cilist io___179 = { 0, 0, 0, fmt_9979, 0 };
+ static cilist io___180 = { 0, 0, 0, fmt_9962, 0 };
+ static cilist io___181 = { 0, 0, 0, fmt_9982, 0 };
+ static cilist io___182 = { 0, 0, 0, fmt_9974, 0 };
+ static cilist io___183 = { 0, 0, 0, fmt_9954, 0 };
+ static cilist io___184 = { 0, 0, 0, fmt_9981, 0 };
+ static cilist io___185 = { 0, 0, 0, fmt_9970, 0 };
+ static cilist io___186 = { 0, 0, 0, fmt_9980, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ALAHD prints header information for the different test paths. */
+
+/* Arguments */
+/* ========= */
+
+/* IOUNIT (input) INTEGER */
+/* The unit number to which the header information should be */
+/* printed. */
+
+/* PATH (input) CHARACTER*3 */
+/* The name of the path for which the header information is to */
+/* be printed. Current paths are */
+/* _GE: General matrices */
+/* _GB: General band */
+/* _GT: General Tridiagonal */
+/* _PO: Symmetric or Hermitian positive definite */
+/* _PS: Symmetric or Hermitian positive semi-definite */
+/* _PP: Symmetric or Hermitian positive definite packed */
+/* _PB: Symmetric or Hermitian positive definite band */
+/* _PT: Symmetric or Hermitian positive definite tridiagonal */
+/* _SY: Symmetric indefinite */
+/* _SP: Symmetric indefinite packed */
+/* _HE: (complex) Hermitian indefinite */
+/* _HP: (complex) Hermitian indefinite packed */
+/* _TR: Triangular */
+/* _TP: Triangular packed */
+/* _TB: Triangular band */
+/* _QR: QR (general matrices) */
+/* _LQ: LQ (general matrices) */
+/* _QL: QL (general matrices) */
+/* _RQ: RQ (general matrices) */
+/* _QP: QR with column pivoting */
+/* _TZ: Trapezoidal */
+/* _LS: Least Squares driver routines */
+/* _LU: LU variants */
+/* _CH: Cholesky variants */
+/* _QS: QR variants */
+/* The first character must be one of S, D, C, or Z (C or Z only */
+/* if complex). */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (*iounit <= 0) {
+ return 0;
+ }
+ *(unsigned char *)c1 = *(unsigned char *)path;
+ *(unsigned char *)c3 = *(unsigned char *)&path[2];
+ s_copy(p2, path + 1, (ftnlen)2, (ftnlen)2);
+ sord = lsame_(c1, "S") || lsame_(c1, "D");
+ corz = lsame_(c1, "C") || lsame_(c1, "Z");
+ if (! (sord || corz)) {
+ return 0;
+ }
+
+ if (lsamen_(&c__2, p2, "GE")) {
+
+/* GE: General dense */
+
+ io___6.ciunit = *iounit;
+ s_wsfe(&io___6);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___7.ciunit = *iounit;
+ s_wsfe(&io___7);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___8.ciunit = *iounit;
+ s_wsfe(&io___8);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___9.ciunit = *iounit;
+ s_wsfe(&io___9);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___10.ciunit = *iounit;
+ s_wsfe(&io___10);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___11.ciunit = *iounit;
+ s_wsfe(&io___11);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___12.ciunit = *iounit;
+ s_wsfe(&io___12);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___13.ciunit = *iounit;
+ s_wsfe(&io___13);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___14.ciunit = *iounit;
+ s_wsfe(&io___14);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___15.ciunit = *iounit;
+ s_wsfe(&io___15);
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "GB")) {
+
+/* GB: General band */
+
+ io___16.ciunit = *iounit;
+ s_wsfe(&io___16);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___17.ciunit = *iounit;
+ s_wsfe(&io___17);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___18.ciunit = *iounit;
+ s_wsfe(&io___18);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___19.ciunit = *iounit;
+ s_wsfe(&io___19);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___20.ciunit = *iounit;
+ s_wsfe(&io___20);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___21.ciunit = *iounit;
+ s_wsfe(&io___21);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___22.ciunit = *iounit;
+ s_wsfe(&io___22);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___23.ciunit = *iounit;
+ s_wsfe(&io___23);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___24.ciunit = *iounit;
+ s_wsfe(&io___24);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "GT")) {
+
+/* GT: General tridiagonal */
+
+ io___25.ciunit = *iounit;
+ s_wsfe(&io___25);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___26.ciunit = *iounit;
+ s_wsfe(&io___26);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___27.ciunit = *iounit;
+ s_wsfe(&io___27);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___28.ciunit = *iounit;
+ s_wsfe(&io___28);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___29.ciunit = *iounit;
+ s_wsfe(&io___29);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___30.ciunit = *iounit;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___31.ciunit = *iounit;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___32.ciunit = *iounit;
+ s_wsfe(&io___32);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___33.ciunit = *iounit;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "PO") || lsamen_(&
+ c__2, p2, "PP")) {
+
+/* PO: Positive definite full */
+/* PP: Positive definite packed */
+
+ if (sord) {
+ s_copy(sym, "Symmetric", (ftnlen)9, (ftnlen)9);
+ } else {
+ s_copy(sym, "Hermitian", (ftnlen)9, (ftnlen)9);
+ }
+ if (lsame_(c3, "O")) {
+ io___35.ciunit = *iounit;
+ s_wsfe(&io___35);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, sym, (ftnlen)9);
+ e_wsfe();
+ } else {
+ io___36.ciunit = *iounit;
+ s_wsfe(&io___36);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, sym, (ftnlen)9);
+ e_wsfe();
+ }
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___37.ciunit = *iounit;
+ s_wsfe(&io___37);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___38.ciunit = *iounit;
+ s_wsfe(&io___38);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___39.ciunit = *iounit;
+ s_wsfe(&io___39);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___40.ciunit = *iounit;
+ s_wsfe(&io___40);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___41.ciunit = *iounit;
+ s_wsfe(&io___41);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___42.ciunit = *iounit;
+ s_wsfe(&io___42);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___43.ciunit = *iounit;
+ s_wsfe(&io___43);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___44.ciunit = *iounit;
+ s_wsfe(&io___44);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___45.ciunit = *iounit;
+ s_wsfe(&io___45);
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "PS")) {
+
+/* PS: Positive semi-definite full */
+
+ if (sord) {
+ s_copy(sym, "Symmetric", (ftnlen)9, (ftnlen)9);
+ } else {
+ s_copy(sym, "Hermitian", (ftnlen)9, (ftnlen)9);
+ }
+ if (lsame_(c1, "S") || lsame_(c1, "C")) {
+ s_copy(eigcnm, "1E04", (ftnlen)4, (ftnlen)4);
+ } else {
+ s_copy(eigcnm, "1D12", (ftnlen)4, (ftnlen)4);
+ }
+ io___47.ciunit = *iounit;
+ s_wsfe(&io___47);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, sym, (ftnlen)9);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___48.ciunit = *iounit;
+ s_wsfe(&io___48);
+ do_fio(&c__1, eigcnm, (ftnlen)4);
+ do_fio(&c__1, eigcnm, (ftnlen)4);
+ do_fio(&c__1, eigcnm, (ftnlen)4);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Difference:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___49.ciunit = *iounit;
+ s_wsfe(&io___49);
+ do_fio(&c__1, c1, (ftnlen)1);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratio:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___50.ciunit = *iounit;
+ s_wsfe(&io___50);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ } else if (lsamen_(&c__2, p2, "PB")) {
+
+/* PB: Positive definite band */
+
+ if (sord) {
+ io___51.ciunit = *iounit;
+ s_wsfe(&io___51);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, "Symmetric", (ftnlen)9);
+ e_wsfe();
+ } else {
+ io___52.ciunit = *iounit;
+ s_wsfe(&io___52);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, "Hermitian", (ftnlen)9);
+ e_wsfe();
+ }
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___53.ciunit = *iounit;
+ s_wsfe(&io___53);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___54.ciunit = *iounit;
+ s_wsfe(&io___54);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___55.ciunit = *iounit;
+ s_wsfe(&io___55);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___56.ciunit = *iounit;
+ s_wsfe(&io___56);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___57.ciunit = *iounit;
+ s_wsfe(&io___57);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___58.ciunit = *iounit;
+ s_wsfe(&io___58);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___59.ciunit = *iounit;
+ s_wsfe(&io___59);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___60.ciunit = *iounit;
+ s_wsfe(&io___60);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "PT")) {
+
+/* PT: Positive definite tridiagonal */
+
+ if (sord) {
+ io___61.ciunit = *iounit;
+ s_wsfe(&io___61);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, "Symmetric", (ftnlen)9);
+ e_wsfe();
+ } else {
+ io___62.ciunit = *iounit;
+ s_wsfe(&io___62);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, "Hermitian", (ftnlen)9);
+ e_wsfe();
+ }
+ io___63.ciunit = *iounit;
+ s_wsfe(&io___63);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___64.ciunit = *iounit;
+ s_wsfe(&io___64);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___65.ciunit = *iounit;
+ s_wsfe(&io___65);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___66.ciunit = *iounit;
+ s_wsfe(&io___66);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___67.ciunit = *iounit;
+ s_wsfe(&io___67);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___68.ciunit = *iounit;
+ s_wsfe(&io___68);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___69.ciunit = *iounit;
+ s_wsfe(&io___69);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___70.ciunit = *iounit;
+ s_wsfe(&io___70);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "SY") || lsamen_(&
+ c__2, p2, "SP")) {
+
+/* SY: Symmetric indefinite full */
+/* SP: Symmetric indefinite packed */
+
+ if (lsame_(c3, "Y")) {
+ io___71.ciunit = *iounit;
+ s_wsfe(&io___71);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, "Symmetric", (ftnlen)9);
+ e_wsfe();
+ } else {
+ io___72.ciunit = *iounit;
+ s_wsfe(&io___72);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, "Symmetric", (ftnlen)9);
+ e_wsfe();
+ }
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ if (sord) {
+ io___73.ciunit = *iounit;
+ s_wsfe(&io___73);
+ e_wsfe();
+ } else {
+ io___74.ciunit = *iounit;
+ s_wsfe(&io___74);
+ e_wsfe();
+ }
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___75.ciunit = *iounit;
+ s_wsfe(&io___75);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___76.ciunit = *iounit;
+ s_wsfe(&io___76);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___77.ciunit = *iounit;
+ s_wsfe(&io___77);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___78.ciunit = *iounit;
+ s_wsfe(&io___78);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___79.ciunit = *iounit;
+ s_wsfe(&io___79);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___80.ciunit = *iounit;
+ s_wsfe(&io___80);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___81.ciunit = *iounit;
+ s_wsfe(&io___81);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___82.ciunit = *iounit;
+ s_wsfe(&io___82);
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "HE") || lsamen_(&
+ c__2, p2, "HP")) {
+
+/* HE: Hermitian indefinite full */
+/* HP: Hermitian indefinite packed */
+
+ if (lsame_(c3, "E")) {
+ io___83.ciunit = *iounit;
+ s_wsfe(&io___83);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, "Hermitian", (ftnlen)9);
+ e_wsfe();
+ } else {
+ io___84.ciunit = *iounit;
+ s_wsfe(&io___84);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, "Hermitian", (ftnlen)9);
+ e_wsfe();
+ }
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___85.ciunit = *iounit;
+ s_wsfe(&io___85);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___86.ciunit = *iounit;
+ s_wsfe(&io___86);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___87.ciunit = *iounit;
+ s_wsfe(&io___87);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___88.ciunit = *iounit;
+ s_wsfe(&io___88);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___89.ciunit = *iounit;
+ s_wsfe(&io___89);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___90.ciunit = *iounit;
+ s_wsfe(&io___90);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___91.ciunit = *iounit;
+ s_wsfe(&io___91);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___92.ciunit = *iounit;
+ s_wsfe(&io___92);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___93.ciunit = *iounit;
+ s_wsfe(&io___93);
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "TR") || lsamen_(&
+ c__2, p2, "TP")) {
+
+/* TR: Triangular full */
+/* TP: Triangular packed */
+
+ if (lsame_(c3, "R")) {
+ io___94.ciunit = *iounit;
+ s_wsfe(&io___94);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = path;
+ i__1[1] = 5, a__1[1] = "LATRS";
+ s_cat(subnam, a__1, i__1, &c__2, (ftnlen)32);
+ } else {
+ io___96.ciunit = *iounit;
+ s_wsfe(&io___96);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = path;
+ i__1[1] = 5, a__1[1] = "LATPS";
+ s_cat(subnam, a__1, i__1, &c__2, (ftnlen)32);
+ }
+ io___97.ciunit = *iounit;
+ s_wsfe(&io___97);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___98.ciunit = *iounit;
+ s_wsfe(&io___98);
+ do_fio(&c__1, subnam, i_len_trim(subnam, (ftnlen)32));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___99.ciunit = *iounit;
+ s_wsfe(&io___99);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___100.ciunit = *iounit;
+ s_wsfe(&io___100);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___101.ciunit = *iounit;
+ s_wsfe(&io___101);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___102.ciunit = *iounit;
+ s_wsfe(&io___102);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___103.ciunit = *iounit;
+ s_wsfe(&io___103);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___104.ciunit = *iounit;
+ s_wsfe(&io___104);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___105.ciunit = *iounit;
+ s_wsfe(&io___105);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___106.ciunit = *iounit;
+ s_wsfe(&io___106);
+ do_fio(&c__1, subnam, i_len_trim(subnam, (ftnlen)32));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "TB")) {
+
+/* TB: Triangular band */
+
+ io___107.ciunit = *iounit;
+ s_wsfe(&io___107);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+/* Writing concatenation */
+ i__1[0] = 1, a__1[0] = path;
+ i__1[1] = 5, a__1[1] = "LATBS";
+ s_cat(subnam, a__1, i__1, &c__2, (ftnlen)32);
+ io___108.ciunit = *iounit;
+ s_wsfe(&io___108);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___109.ciunit = *iounit;
+ s_wsfe(&io___109);
+ do_fio(&c__1, subnam, i_len_trim(subnam, (ftnlen)32));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___110.ciunit = *iounit;
+ s_wsfe(&io___110);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___111.ciunit = *iounit;
+ s_wsfe(&io___111);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___112.ciunit = *iounit;
+ s_wsfe(&io___112);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___113.ciunit = *iounit;
+ s_wsfe(&io___113);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___114.ciunit = *iounit;
+ s_wsfe(&io___114);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___115.ciunit = *iounit;
+ s_wsfe(&io___115);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___116.ciunit = *iounit;
+ s_wsfe(&io___116);
+ do_fio(&c__1, subnam, i_len_trim(subnam, (ftnlen)32));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "QR")) {
+
+/* QR decomposition of rectangular matrices */
+
+ io___117.ciunit = *iounit;
+ s_wsfe(&io___117);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, "QR", (ftnlen)2);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___118.ciunit = *iounit;
+ s_wsfe(&io___118);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___119.ciunit = *iounit;
+ s_wsfe(&io___119);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___120.ciunit = *iounit;
+ s_wsfe(&io___120);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___121.ciunit = *iounit;
+ s_wsfe(&io___121);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ do_fio(&c__1, "M", (ftnlen)1);
+ e_wsfe();
+ io___122.ciunit = *iounit;
+ s_wsfe(&io___122);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ do_fio(&c__1, "M", (ftnlen)1);
+ e_wsfe();
+ io___123.ciunit = *iounit;
+ s_wsfe(&io___123);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ do_fio(&c__1, "M", (ftnlen)1);
+ e_wsfe();
+ io___124.ciunit = *iounit;
+ s_wsfe(&io___124);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ do_fio(&c__1, "M", (ftnlen)1);
+ e_wsfe();
+ io___125.ciunit = *iounit;
+ s_wsfe(&io___125);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___126.ciunit = *iounit;
+ s_wsfe(&io___126);
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "LQ")) {
+
+/* LQ decomposition of rectangular matrices */
+
+ io___127.ciunit = *iounit;
+ s_wsfe(&io___127);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, "LQ", (ftnlen)2);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___128.ciunit = *iounit;
+ s_wsfe(&io___128);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___129.ciunit = *iounit;
+ s_wsfe(&io___129);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___130.ciunit = *iounit;
+ s_wsfe(&io___130);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___131.ciunit = *iounit;
+ s_wsfe(&io___131);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ do_fio(&c__1, "N", (ftnlen)1);
+ e_wsfe();
+ io___132.ciunit = *iounit;
+ s_wsfe(&io___132);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ do_fio(&c__1, "N", (ftnlen)1);
+ e_wsfe();
+ io___133.ciunit = *iounit;
+ s_wsfe(&io___133);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ do_fio(&c__1, "N", (ftnlen)1);
+ e_wsfe();
+ io___134.ciunit = *iounit;
+ s_wsfe(&io___134);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ do_fio(&c__1, "N", (ftnlen)1);
+ e_wsfe();
+ io___135.ciunit = *iounit;
+ s_wsfe(&io___135);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "QL")) {
+
+/* QL decomposition of rectangular matrices */
+
+ io___136.ciunit = *iounit;
+ s_wsfe(&io___136);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, "QL", (ftnlen)2);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___137.ciunit = *iounit;
+ s_wsfe(&io___137);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___138.ciunit = *iounit;
+ s_wsfe(&io___138);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___139.ciunit = *iounit;
+ s_wsfe(&io___139);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___140.ciunit = *iounit;
+ s_wsfe(&io___140);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ do_fio(&c__1, "M", (ftnlen)1);
+ e_wsfe();
+ io___141.ciunit = *iounit;
+ s_wsfe(&io___141);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ do_fio(&c__1, "M", (ftnlen)1);
+ e_wsfe();
+ io___142.ciunit = *iounit;
+ s_wsfe(&io___142);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ do_fio(&c__1, "M", (ftnlen)1);
+ e_wsfe();
+ io___143.ciunit = *iounit;
+ s_wsfe(&io___143);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ do_fio(&c__1, "M", (ftnlen)1);
+ e_wsfe();
+ io___144.ciunit = *iounit;
+ s_wsfe(&io___144);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "RQ")) {
+
+/* RQ decomposition of rectangular matrices */
+
+ io___145.ciunit = *iounit;
+ s_wsfe(&io___145);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, "RQ", (ftnlen)2);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___146.ciunit = *iounit;
+ s_wsfe(&io___146);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___147.ciunit = *iounit;
+ s_wsfe(&io___147);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___148.ciunit = *iounit;
+ s_wsfe(&io___148);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___149.ciunit = *iounit;
+ s_wsfe(&io___149);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ do_fio(&c__1, "N", (ftnlen)1);
+ e_wsfe();
+ io___150.ciunit = *iounit;
+ s_wsfe(&io___150);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ do_fio(&c__1, "N", (ftnlen)1);
+ e_wsfe();
+ io___151.ciunit = *iounit;
+ s_wsfe(&io___151);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ do_fio(&c__1, "N", (ftnlen)1);
+ e_wsfe();
+ io___152.ciunit = *iounit;
+ s_wsfe(&io___152);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ do_fio(&c__1, "N", (ftnlen)1);
+ e_wsfe();
+ io___153.ciunit = *iounit;
+ s_wsfe(&io___153);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "QP")) {
+
+/* QR decomposition with column pivoting */
+
+ io___154.ciunit = *iounit;
+ s_wsfe(&io___154);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___155.ciunit = *iounit;
+ s_wsfe(&io___155);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___156.ciunit = *iounit;
+ s_wsfe(&io___156);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___157.ciunit = *iounit;
+ s_wsfe(&io___157);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___158.ciunit = *iounit;
+ s_wsfe(&io___158);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "TZ")) {
+
+/* TZ: Trapezoidal */
+
+ io___159.ciunit = *iounit;
+ s_wsfe(&io___159);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___160.ciunit = *iounit;
+ s_wsfe(&io___160);
+ e_wsfe();
+ io___161.ciunit = *iounit;
+ s_wsfe(&io___161);
+ do_fio(&c__1, c1, (ftnlen)1);
+ do_fio(&c__1, c1, (ftnlen)1);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___162.ciunit = *iounit;
+ s_wsfe(&io___162);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___163.ciunit = *iounit;
+ s_wsfe(&io___163);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___164.ciunit = *iounit;
+ s_wsfe(&io___164);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___165.ciunit = *iounit;
+ s_wsfe(&io___165);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___166.ciunit = *iounit;
+ s_wsfe(&io___166);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___167.ciunit = *iounit;
+ s_wsfe(&io___167);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "LS")) {
+
+/* LS: Least Squares driver routines for */
+/* LS, LSD, LSS, LSX and LSY. */
+
+ io___168.ciunit = *iounit;
+ s_wsfe(&io___168);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___169.ciunit = *iounit;
+ s_wsfe(&io___169);
+ e_wsfe();
+ io___170.ciunit = *iounit;
+ s_wsfe(&io___170);
+ do_fio(&c__1, c1, (ftnlen)1);
+ do_fio(&c__1, c1, (ftnlen)1);
+ do_fio(&c__1, c1, (ftnlen)1);
+ do_fio(&c__1, c1, (ftnlen)1);
+ do_fio(&c__1, c1, (ftnlen)1);
+ e_wsfe();
+ io___171.ciunit = *iounit;
+ s_wsfe(&io___171);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___172.ciunit = *iounit;
+ s_wsfe(&io___172);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___173.ciunit = *iounit;
+ s_wsfe(&io___173);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___174.ciunit = *iounit;
+ s_wsfe(&io___174);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___175.ciunit = *iounit;
+ s_wsfe(&io___175);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___176.ciunit = *iounit;
+ s_wsfe(&io___176);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ io___177.ciunit = *iounit;
+ s_wsfe(&io___177);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "LU")) {
+
+/* LU factorization variants */
+
+ io___178.ciunit = *iounit;
+ s_wsfe(&io___178);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___179.ciunit = *iounit;
+ s_wsfe(&io___179);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratio:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___180.ciunit = *iounit;
+ s_wsfe(&io___180);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "CH")) {
+
+/* Cholesky factorization variants */
+
+ io___181.ciunit = *iounit;
+ s_wsfe(&io___181);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___182.ciunit = *iounit;
+ s_wsfe(&io___182);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratio:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___183.ciunit = *iounit;
+ s_wsfe(&io___183);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, p2, "QS")) {
+
+/* QR factorization variants */
+
+ io___184.ciunit = *iounit;
+ s_wsfe(&io___184);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___185.ciunit = *iounit;
+ s_wsfe(&io___185);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *iounit;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+
+ } else {
+
+/* Print error message if no header is available. */
+
+ io___186.ciunit = *iounit;
+ s_wsfe(&io___186);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+/* First line of header */
+
+
+/* GE matrix types */
+
+
+/* GB matrix types */
+
+
+/* GT matrix types */
+
+
+/* PT matrix types */
+
+
+/* PO, PP matrix types */
+
+
+/* CH matrix types */
+
+
+/* PS matrix types */
+
+
+/* PB matrix types */
+
+
+/* SSY, SSP, CHE, CHP matrix types */
+
+
+/* CSY, CSP matrix types */
+
+
+/* QR matrix types */
+
+
+/* QP matrix types */
+
+
+/* TZ matrix types */
+
+
+/* LS matrix types */
+
+
+/* TR, TP matrix types */
+
+
+/* TB matrix types */
+
+
+/* Test ratios */
+
+/* L9936: */
+/* L9930: */
+
+ return 0;
+
+/* End of ALAHD */
+
+} /* alahd_ */
diff --git a/TESTING/LIN/alareq.c b/TESTING/LIN/alareq.c
new file mode 100644
index 0000000..1b87394
--- /dev/null
+++ b/TESTING/LIN/alareq.c
@@ -0,0 +1,277 @@
+/* alareq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int alareq_(char *path, integer *nmats, logical *dotype,
+ integer *ntypes, integer *nin, integer *nout)
+{
+ /* Initialized data */
+
+ static char intstr[10] = "0123456789";
+
+ /* Format strings */
+ static char fmt_9995[] = "(//\002 *** Not enough matrix types on input l"
+ "ine\002,/a79)";
+ static char fmt_9994[] = "(\002 ==> Specify \002,i4,\002 matrix types on"
+ " this line or \002,\002adjust NTYPES on previous line\002)";
+ static char fmt_9996[] = "(//\002 *** Invalid integer value in column"
+ " \002,i2,\002 of input\002,\002 line:\002,/a79)";
+ static char fmt_9997[] = "(\002 *** Warning: duplicate request of matri"
+ "x type \002,i2,\002 for \002,a3)";
+ static char fmt_9999[] = "(\002 *** Invalid type request for \002,a3,"
+ "\002, type \002,i4,\002: must satisfy 1 <= type <= \002,i2)";
+ static char fmt_9998[] = "(/\002 *** End of file reached when trying to "
+ "read matrix \002,\002types for \002,a3,/\002 *** Check that you "
+ "are requesting the\002,\002 right number of types for each pat"
+ "h\002,/)";
+
+ /* System generated locals */
+ integer i__1;
+ cilist ci__1;
+
+ /* Builtin functions */
+ integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
+ i_len(char *, ftnlen), s_wsfe(cilist *), e_wsfe(void), s_wsle(
+ cilist *), e_wsle(void);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k;
+ char c1[1];
+ integer i1, ic, nt;
+ char line[80];
+ integer lenp, nreq[100];
+ logical firstt;
+
+ /* Fortran I/O blocks */
+ static cilist io___9 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___10 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___14 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___15 = { 0, 0, 0, fmt_9994, 0 };
+ static cilist io___17 = { 0, 0, 0, 0, 0 };
+ static cilist io___18 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___19 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___20 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___21 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ALAREQ handles input for the LAPACK test program. It is called */
+/* to evaluate the input line which requested NMATS matrix types for */
+/* PATH. The flow of control is as follows: */
+
+/* If NMATS = NTYPES then */
+/* DOTYPE(1:NTYPES) = .TRUE. */
+/* else */
+/* Read the next input line for NMATS matrix types */
+/* Set DOTYPE(I) = .TRUE. for each valid type I */
+/* endif */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* An LAPACK path name for testing. */
+
+/* NMATS (input) INTEGER */
+/* The number of matrix types to be used in testing this path. */
+
+/* DOTYPE (output) LOGICAL array, dimension (NTYPES) */
+/* The vector of flags indicating if each type will be tested. */
+
+/* NTYPES (input) INTEGER */
+/* The maximum number of matrix types for this path. */
+
+/* NIN (input) INTEGER */
+/* The unit number for input. NIN >= 1. */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. NOUT >= 1. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (*nmats >= *ntypes) {
+
+/* Test everything if NMATS >= NTYPES. */
+
+ i__1 = *ntypes;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dotype[i__] = TRUE_;
+/* L10: */
+ }
+ } else {
+ i__1 = *ntypes;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dotype[i__] = FALSE_;
+/* L20: */
+ }
+ firstt = TRUE_;
+
+/* Read a line of matrix types if 0 < NMATS < NTYPES. */
+
+ if (*nmats > 0) {
+ ci__1.cierr = 0;
+ ci__1.ciend = 1;
+ ci__1.ciunit = *nin;
+ ci__1.cifmt = "(A80)";
+ i__1 = s_rsfe(&ci__1);
+ if (i__1 != 0) {
+ goto L90;
+ }
+ i__1 = do_fio(&c__1, line, (ftnlen)80);
+ if (i__1 != 0) {
+ goto L90;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L90;
+ }
+ lenp = i_len(line, (ftnlen)80);
+ i__ = 0;
+ i__1 = *nmats;
+ for (j = 1; j <= i__1; ++j) {
+ nreq[j - 1] = 0;
+ i1 = 0;
+L30:
+ ++i__;
+ if (i__ > lenp) {
+ if (j == *nmats && i1 > 0) {
+ goto L60;
+ } else {
+ io___9.ciunit = *nout;
+ s_wsfe(&io___9);
+ do_fio(&c__1, line, (ftnlen)80);
+ e_wsfe();
+ io___10.ciunit = *nout;
+ s_wsfe(&io___10);
+ do_fio(&c__1, (char *)&(*nmats), (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ goto L80;
+ }
+ }
+ if (*(unsigned char *)&line[i__ - 1] != ' ' && *(unsigned
+ char *)&line[i__ - 1] != ',') {
+ i1 = i__;
+ *(unsigned char *)c1 = *(unsigned char *)&line[i1 - 1];
+
+/* Check that a valid integer was read */
+
+ for (k = 1; k <= 10; ++k) {
+ if (*(unsigned char *)c1 == *(unsigned char *)&intstr[
+ k - 1]) {
+ ic = k - 1;
+ goto L50;
+ }
+/* L40: */
+ }
+ io___14.ciunit = *nout;
+ s_wsfe(&io___14);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, line, (ftnlen)80);
+ e_wsfe();
+ io___15.ciunit = *nout;
+ s_wsfe(&io___15);
+ do_fio(&c__1, (char *)&(*nmats), (ftnlen)sizeof(integer));
+ e_wsfe();
+ goto L80;
+L50:
+ nreq[j - 1] = nreq[j - 1] * 10 + ic;
+ goto L30;
+ } else if (i1 > 0) {
+ goto L60;
+ } else {
+ goto L30;
+ }
+L60:
+ ;
+ }
+ }
+ i__1 = *nmats;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nt = nreq[i__ - 1];
+ if (nt > 0 && nt <= *ntypes) {
+ if (dotype[nt]) {
+ if (firstt) {
+ io___17.ciunit = *nout;
+ s_wsle(&io___17);
+ e_wsle();
+ }
+ firstt = FALSE_;
+ io___18.ciunit = *nout;
+ s_wsfe(&io___18);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+ dotype[nt] = TRUE_;
+ } else {
+ io___19.ciunit = *nout;
+ s_wsfe(&io___19);
+ do_fio(&c__1, path, (ftnlen)3);
+ do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*ntypes), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+/* L70: */
+ }
+L80:
+ ;
+ }
+ return 0;
+
+L90:
+ io___20.ciunit = *nout;
+ s_wsfe(&io___20);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ io___21.ciunit = *nout;
+ s_wsle(&io___21);
+ e_wsle();
+ s_stop("", (ftnlen)0);
+
+/* End of ALAREQ */
+
+ return 0;
+} /* alareq_ */
diff --git a/TESTING/LIN/alasum.c b/TESTING/LIN/alasum.c
new file mode 100644
index 0000000..1337db7
--- /dev/null
+++ b/TESTING/LIN/alasum.c
@@ -0,0 +1,100 @@
+/* alasum.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int alasum_(char *type__, integer *nout, integer *nfail,
+ integer *nrun, integer *nerrs)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002: \002,i6,\002 out of \002,i6,\002 "
+ "tests failed to pass the threshold\002)";
+ static char fmt_9998[] = "(/1x,\002All tests for \002,a3,\002 routines p"
+ "assed the threshold (\002,i6,\002 tests run)\002)";
+ static char fmt_9997[] = "(6x,i6,\002 error messages recorded\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___2 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___3 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ALASUM prints a summary of results from one of the -CHK- routines. */
+
+/* Arguments */
+/* ========= */
+
+/* TYPE (input) CHARACTER*3 */
+/* The LAPACK path name. */
+
+/* NOUT (input) INTEGER */
+/* The unit number on which results are to be printed. */
+/* NOUT >= 0. */
+
+/* NFAIL (input) INTEGER */
+/* The number of tests which did not pass the threshold ratio. */
+
+/* NRUN (input) INTEGER */
+/* The total number of tests. */
+
+/* NERRS (input) INTEGER */
+/* The number of error messages recorded. */
+
+/* ===================================================================== */
+
+/* .. Executable Statements .. */
+
+ if (*nfail > 0) {
+ io___1.ciunit = *nout;
+ s_wsfe(&io___1);
+ do_fio(&c__1, type__, (ftnlen)3);
+ do_fio(&c__1, (char *)&(*nfail), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*nrun), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___2.ciunit = *nout;
+ s_wsfe(&io___2);
+ do_fio(&c__1, type__, (ftnlen)3);
+ do_fio(&c__1, (char *)&(*nrun), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*nerrs > 0) {
+ io___3.ciunit = *nout;
+ s_wsfe(&io___3);
+ do_fio(&c__1, (char *)&(*nerrs), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ return 0;
+
+/* End of ALASUM */
+
+} /* alasum_ */
diff --git a/TESTING/LIN/alasvm.c b/TESTING/LIN/alasvm.c
new file mode 100644
index 0000000..980e9c7
--- /dev/null
+++ b/TESTING/LIN/alasvm.c
@@ -0,0 +1,100 @@
+/* alasvm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int alasvm_(char *type__, integer *nout, integer *nfail,
+ integer *nrun, integer *nerrs)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 drivers: \002,i6,\002 out of \002,"
+ "i6,\002 tests failed to pass the threshold\002)";
+ static char fmt_9998[] = "(/1x,\002All tests for \002,a3,\002 drivers p"
+ "assed the \002,\002threshold (\002,i6,\002 tests run)\002)";
+ static char fmt_9997[] = "(14x,i6,\002 error messages recorded\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___2 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___3 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ALASVM prints a summary of results from one of the -DRV- routines. */
+
+/* Arguments */
+/* ========= */
+
+/* TYPE (input) CHARACTER*3 */
+/* The LAPACK path name. */
+
+/* NOUT (input) INTEGER */
+/* The unit number on which results are to be printed. */
+/* NOUT >= 0. */
+
+/* NFAIL (input) INTEGER */
+/* The number of tests which did not pass the threshold ratio. */
+
+/* NRUN (input) INTEGER */
+/* The total number of tests. */
+
+/* NERRS (input) INTEGER */
+/* The number of error messages recorded. */
+
+/* ===================================================================== */
+
+/* .. Executable Statements .. */
+
+ if (*nfail > 0) {
+ io___1.ciunit = *nout;
+ s_wsfe(&io___1);
+ do_fio(&c__1, type__, (ftnlen)3);
+ do_fio(&c__1, (char *)&(*nfail), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&(*nrun), (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___2.ciunit = *nout;
+ s_wsfe(&io___2);
+ do_fio(&c__1, type__, (ftnlen)3);
+ do_fio(&c__1, (char *)&(*nrun), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (*nerrs > 0) {
+ io___3.ciunit = *nout;
+ s_wsfe(&io___3);
+ do_fio(&c__1, (char *)&(*nerrs), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+ return 0;
+
+/* End of ALASVM */
+
+} /* alasvm_ */
diff --git a/TESTING/LIN/cchkaa.c b/TESTING/LIN/cchkaa.c
new file mode 100644
index 0000000..02bdb9c
--- /dev/null
+++ b/TESTING/LIN/cchkaa.c
@@ -0,0 +1,1435 @@
+/* cchkaa.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer iparms[100];
+} claenv_;
+
+#define claenv_1 claenv_
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__12 = 12;
+static integer c__0 = 0;
+static integer c__132 = 132;
+static integer c__16 = 16;
+static integer c__100 = 100;
+static integer c__4 = 4;
+static integer c__8 = 8;
+static integer c__2 = 2;
+static integer c__5 = 5;
+static integer c__6 = 6;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Initialized data */
+
+ static real threq = 2.f;
+ static char intstr[10] = "0123456789";
+
+ /* Format strings */
+ static char fmt_9994[] = "(\002 Tests of the COMPLEX LAPACK routines "
+ "\002,/\002 LAPACK VERSION \002,i1,\002.\002,i1,\002.\002,i1,/"
+ "/\002 The following parameter values will be used:\002)";
+ static char fmt_9996[] = "(\002 Invalid input value: \002,a4,\002=\002,i"
+ "6,\002; must be >=\002,i6)";
+ static char fmt_9995[] = "(\002 Invalid input value: \002,a4,\002=\002,i"
+ "6,\002; must be <=\002,i6)";
+ static char fmt_9993[] = "(4x,a4,\002: \002,10i6,/11x,10i6)";
+ static char fmt_9992[] = "(/\002 Routines pass computational tests if te"
+ "st ratio is \002,\002less than\002,f8.2,/)";
+ static char fmt_9999[] = "(/\002 Execution not attempted due to input er"
+ "rors\002)";
+ static char fmt_9991[] = "(\002 Relative machine \002,a,\002 is taken to"
+ " be\002,e16.6)";
+ static char fmt_9990[] = "(/1x,a3,\002: Unrecognized path name\002)";
+ static char fmt_9989[] = "(/1x,a3,\002 routines were not tested\002)";
+ static char fmt_9988[] = "(/1x,a3,\002 driver routines were not teste"
+ "d\002)";
+ static char fmt_9998[] = "(/\002 End of tests\002)";
+ static char fmt_9997[] = "(\002 Total time used = \002,f12.2,\002 seco"
+ "nds\002,/)";
+
+ /* System generated locals */
+ integer i__1, i__2;
+ real r__1;
+ cilist ci__1;
+ cllist cl__1;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), e_rsle(void), s_wsfe(cilist *), do_fio(integer *
+ , char *, ftnlen), e_wsfe(void), do_lio(integer *, integer *,
+ char *, ftnlen);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_rsfe(cilist *), e_rsfe(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer f_clos(cllist *);
+
+ /* Local variables */
+ complex a[153384] /* was [21912][7] */, b[8448] /* was [2112][4] */;
+ integer i__, j, k;
+ real s[264];
+ char c1[1], c2[2];
+ real s1, s2;
+ integer ic, la, nb, nm, nn, vers_patch__, vers_major__, vers_minor__, lda,
+ nnb;
+ real eps;
+ integer nns, piv[132], nnb2;
+ char path[3];
+ integer mval[12], nval[12], nrhs;
+ complex work[20856] /* was [132][158] */;
+ integer lafac;
+ logical fatal;
+ char aline[72];
+ extern logical lsame_(char *, char *);
+ integer nbval[12], nrank, nmats, nsval[12], nxval[12], iwork[3300];
+ real rwork[19832];
+ extern /* Subroutine */ int cchkq3_(logical *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, real *,
+ complex *, complex *, real *, real *, complex *, complex *, real *
+, integer *, integer *);
+ integer nbval2[12];
+ extern /* Subroutine */ int cchkgb_(logical *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ real *, logical *, complex *, integer *, complex *, integer *,
+ complex *, complex *, complex *, complex *, real *, integer *,
+ integer *), cchkge_(logical *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, real *,
+ logical *, integer *, complex *, complex *, complex *, complex *,
+ complex *, complex *, complex *, real *, integer *, integer *),
+ cchkhe_(logical *, integer *, integer *, integer *, integer *,
+ integer *, integer *, real *, logical *, integer *, complex *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ real *, integer *, integer *), cchkpb_(logical *, integer *,
+ integer *, integer *, integer *, integer *, integer *, real *,
+ logical *, integer *, complex *, complex *, complex *, complex *,
+ complex *, complex *, complex *, real *, integer *), cchkeq_(real
+ *, integer *), cchktb_(logical *, integer *, integer *, integer *,
+ integer *, real *, logical *, integer *, complex *, complex *,
+ complex *, complex *, complex *, complex *, real *, integer *),
+ cchkhp_(logical *, integer *, integer *, integer *, integer *,
+ real *, logical *, integer *, complex *, complex *, complex *,
+ complex *, complex *, complex *, complex *, real *, integer *,
+ integer *), cchkgt_(logical *, integer *, integer *, integer *,
+ integer *, real *, logical *, complex *, complex *, complex *,
+ complex *, complex *, complex *, real *, integer *, integer *),
+ alareq_(char *, integer *, logical *, integer *, integer *,
+ integer *), cchklq_(logical *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ real *, logical *, integer *, complex *, complex *, complex *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ complex *, real *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int cchkpo_(logical *, integer *, integer *,
+ integer *, integer *, integer *, integer *, real *, logical *,
+ integer *, complex *, complex *, complex *, complex *, complex *,
+ complex *, complex *, real *, integer *), cchkpp_(logical *,
+ integer *, integer *, integer *, integer *, real *, logical *,
+ integer *, complex *, complex *, complex *, complex *, complex *,
+ complex *, complex *, real *, integer *), cchkql_(logical *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, real *, logical *, integer *, complex *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ complex *, complex *, complex *, real *, integer *, integer *);
+ extern doublereal second_(void);
+ extern /* Subroutine */ int cchkps_(logical *, integer *, integer *,
+ integer *, integer *, integer *, integer *, real *, logical *,
+ integer *, complex *, complex *, complex *, integer *, complex *,
+ real *, integer *), cchkpt_(logical *, integer *, integer *,
+ integer *, integer *, real *, logical *, complex *, real *,
+ complex *, complex *, complex *, complex *, complex *, real *,
+ integer *), cchkqp_(logical *, integer *, integer *, integer *,
+ integer *, real *, logical *, complex *, complex *, real *, real *
+, complex *, complex *, real *, integer *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int cchkqr_(logical *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ real *, logical *, integer *, complex *, complex *, complex *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ complex *, real *, integer *, integer *), cchkrq_(logical *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, real *, logical *, integer *, complex *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ complex *, complex *, complex *, real *, integer *, integer *),
+ cchksp_(logical *, integer *, integer *, integer *, integer *,
+ real *, logical *, integer *, complex *, complex *, complex *,
+ complex *, complex *, complex *, complex *, real *, integer *,
+ integer *), cchktp_(logical *, integer *, integer *, integer *,
+ integer *, real *, logical *, integer *, complex *, complex *,
+ complex *, complex *, complex *, complex *, real *, integer *),
+ cchksy_(logical *, integer *, integer *, integer *, integer *,
+ integer *, integer *, real *, logical *, integer *, complex *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ real *, integer *, integer *), cchktr_(logical *, integer *,
+ integer *, integer *, integer *, integer *, integer *, real *,
+ logical *, integer *, complex *, complex *, complex *, complex *,
+ complex *, complex *, real *, integer *), cchktz_(logical *,
+ integer *, integer *, integer *, integer *, real *, logical *,
+ complex *, complex *, real *, real *, complex *, complex *, real *
+, integer *), cdrvgb_(logical *, integer *, integer *, integer *,
+ real *, logical *, complex *, integer *, complex *, integer *,
+ complex *, complex *, complex *, complex *, complex *, real *,
+ complex *, real *, integer *, integer *), cdrvge_(logical *,
+ integer *, integer *, integer *, real *, logical *, integer *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ complex *, real *, complex *, real *, integer *, integer *),
+ cdrvgt_(logical *, integer *, integer *, integer *, real *,
+ logical *, complex *, complex *, complex *, complex *, complex *,
+ complex *, real *, integer *, integer *), cdrvhe_(logical *,
+ integer *, integer *, integer *, real *, logical *, integer *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ complex *, real *, integer *, integer *), cdrvhp_(logical *,
+ integer *, integer *, integer *, real *, logical *, integer *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ complex *, real *, integer *, integer *);
+ real thresh;
+ extern /* Subroutine */ int cdrvls_(logical *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, real *, logical *, complex *, complex *, complex *,
+ complex *, complex *, real *, real *, complex *, real *, integer *
+, integer *), cdrvpb_(logical *, integer *, integer *, integer *,
+ real *, logical *, integer *, complex *, complex *, complex *,
+ complex *, complex *, complex *, complex *, real *, complex *,
+ real *, integer *);
+ logical tstchk;
+ extern /* Subroutine */ int cdrvpo_(logical *, integer *, integer *,
+ integer *, real *, logical *, integer *, complex *, complex *,
+ complex *, complex *, complex *, complex *, complex *, real *,
+ complex *, real *, integer *), cdrvpp_(logical *, integer *,
+ integer *, integer *, real *, logical *, integer *, complex *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ real *, complex *, real *, integer *);
+ logical dotype[30];
+ extern /* Subroutine */ int cdrvpt_(logical *, integer *, integer *,
+ integer *, real *, logical *, complex *, real *, complex *,
+ complex *, complex *, complex *, complex *, real *, integer *),
+ cdrvsp_(logical *, integer *, integer *, integer *, real *,
+ logical *, integer *, complex *, complex *, complex *, complex *,
+ complex *, complex *, complex *, real *, integer *, integer *),
+ ilaver_(integer *, integer *, integer *), cdrvsy_(logical *,
+ integer *, integer *, integer *, real *, logical *, integer *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ complex *, real *, integer *, integer *);
+ integer ntypes;
+ logical tsterr, tstdrv;
+ integer rankval[12];
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 5, 0, 0, 0 };
+ static cilist io___10 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___11 = { 0, 5, 0, 0, 0 };
+ static cilist io___13 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___14 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___15 = { 0, 5, 0, 0, 0 };
+ static cilist io___18 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___19 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___20 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___21 = { 0, 5, 0, 0, 0 };
+ static cilist io___23 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___24 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___25 = { 0, 5, 0, 0, 0 };
+ static cilist io___27 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___28 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___29 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___30 = { 0, 5, 0, 0, 0 };
+ static cilist io___32 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___33 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___34 = { 0, 5, 0, 0, 0 };
+ static cilist io___36 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___37 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___38 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___39 = { 0, 5, 0, 0, 0 };
+ static cilist io___41 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___42 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___43 = { 0, 5, 0, 0, 0 };
+ static cilist io___45 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___46 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___51 = { 0, 5, 0, 0, 0 };
+ static cilist io___53 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___54 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___55 = { 0, 5, 0, 0, 0 };
+ static cilist io___57 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___58 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___59 = { 0, 5, 0, 0, 0 };
+ static cilist io___61 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___62 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___63 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___64 = { 0, 5, 0, 0, 0 };
+ static cilist io___66 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___67 = { 0, 5, 0, 0, 0 };
+ static cilist io___69 = { 0, 5, 0, 0, 0 };
+ static cilist io___71 = { 0, 5, 0, 0, 0 };
+ static cilist io___73 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___75 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___76 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___77 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___78 = { 0, 6, 0, 0, 0 };
+ static cilist io___87 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___88 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___96 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___98 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___101 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___102 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___103 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___104 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___105 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___106 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___108 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___109 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___110 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___111 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___112 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___113 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___114 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___115 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___116 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___117 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___118 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___119 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___120 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___121 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___122 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___123 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___124 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___125 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___126 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___127 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___128 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___129 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___130 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___131 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___132 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___133 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___134 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___136 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___137 = { 0, 6, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKAA is the main test program for the COMPLEX linear equation */
+/* routines. */
+
+/* The program must be driven by a short data file. The first 14 records */
+/* specify problem dimensions and program options using list-directed */
+/* input. The remaining lines specify the LAPACK test paths and the */
+/* number of matrix types to use in testing. An annotated example of a */
+/* data file can be obtained by deleting the first 3 characters from the */
+/* following 38 lines: */
+/* Data file for testing COMPLEX LAPACK linear equation routines */
+/* 7 Number of values of M */
+/* 0 1 2 3 5 10 16 Values of M (row dimension) */
+/* 7 Number of values of N */
+/* 0 1 2 3 5 10 16 Values of N (column dimension) */
+/* 1 Number of values of NRHS */
+/* 2 Values of NRHS (number of right hand sides) */
+/* 5 Number of values of NB */
+/* 1 3 3 3 20 Values of NB (the blocksize) */
+/* 1 0 5 9 1 Values of NX (crossover point) */
+/* 3 Number of values of RANK */
+/* 30 50 90 Values of rank (as a % of N) */
+/* 30.0 Threshold value of test ratio */
+/* T Put T to test the LAPACK routines */
+/* T Put T to test the driver routines */
+/* T Put T to test the error exits */
+/* CGE 11 List types on next line if 0 < NTYPES < 11 */
+/* CGB 8 List types on next line if 0 < NTYPES < 8 */
+/* CGT 12 List types on next line if 0 < NTYPES < 12 */
+/* CPO 9 List types on next line if 0 < NTYPES < 9 */
+/* CPO 9 List types on next line if 0 < NTYPES < 9 */
+/* CPP 9 List types on next line if 0 < NTYPES < 9 */
+/* CPB 8 List types on next line if 0 < NTYPES < 8 */
+/* CPT 12 List types on next line if 0 < NTYPES < 12 */
+/* CHE 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 */
+/* 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 */
+/* CTB 17 List types on next line if 0 < NTYPES < 17 */
+/* CQR 8 List types on next line if 0 < NTYPES < 8 */
+/* CRQ 8 List types on next line if 0 < NTYPES < 8 */
+/* CLQ 8 List types on next line if 0 < NTYPES < 8 */
+/* CQL 8 List types on next line if 0 < NTYPES < 8 */
+/* CQP 6 List types on next line if 0 < NTYPES < 6 */
+/* CTZ 3 List types on next line if 0 < NTYPES < 3 */
+/* CLS 6 List types on next line if 0 < NTYPES < 6 */
+/* CEQ */
+
+/* Internal Parameters */
+/* =================== */
+
+/* NMAX INTEGER */
+/* The maximum allowable value for N. */
+
+/* MAXIN INTEGER */
+/* The number of different values that can be used for each of */
+/* M, N, or NB */
+
+/* MAXRHS INTEGER */
+/* The maximum number of right hand sides */
+
+/* NIN INTEGER */
+/* The unit number for input */
+
+/* NOUT INTEGER */
+/* The unit number for output */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ s1 = second_();
+ lda = 132;
+ fatal = FALSE_;
+
+/* Read a dummy line. */
+
+ s_rsle(&io___6);
+ e_rsle();
+
+/* Report values of parameters. */
+
+ ilaver_(&vers_major__, &vers_minor__, &vers_patch__);
+ s_wsfe(&io___10);
+ do_fio(&c__1, (char *)&vers_major__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_minor__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_patch__, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+/* Read the values of M */
+
+ s_rsle(&io___11);
+ do_lio(&c__3, &c__1, (char *)&nm, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nm < 1) {
+ s_wsfe(&io___13);
+ do_fio(&c__1, " NM ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nm, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nm = 0;
+ fatal = TRUE_;
+ } else if (nm > 12) {
+ s_wsfe(&io___14);
+ do_fio(&c__1, " NM ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nm, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nm = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___15);
+ i__1 = nm;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nm;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (mval[i__ - 1] < 0) {
+ s_wsfe(&io___18);
+ do_fio(&c__1, " M ", (ftnlen)4);
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (mval[i__ - 1] > 132) {
+ s_wsfe(&io___19);
+ do_fio(&c__1, " M ", (ftnlen)4);
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L10: */
+ }
+ if (nm > 0) {
+ s_wsfe(&io___20);
+ do_fio(&c__1, "M ", (ftnlen)4);
+ i__1 = nm;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of N */
+
+ s_rsle(&io___21);
+ do_lio(&c__3, &c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nn < 1) {
+ s_wsfe(&io___23);
+ do_fio(&c__1, " NN ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ } else if (nn > 12) {
+ s_wsfe(&io___24);
+ do_fio(&c__1, " NN ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___25);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nval[i__ - 1] < 0) {
+ s_wsfe(&io___27);
+ do_fio(&c__1, " N ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nval[i__ - 1] > 132) {
+ s_wsfe(&io___28);
+ do_fio(&c__1, " N ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L20: */
+ }
+ if (nn > 0) {
+ s_wsfe(&io___29);
+ do_fio(&c__1, "N ", (ftnlen)4);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of NRHS */
+
+ s_rsle(&io___30);
+ do_lio(&c__3, &c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nns < 1) {
+ s_wsfe(&io___32);
+ do_fio(&c__1, " NNS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nns = 0;
+ fatal = TRUE_;
+ } else if (nns > 12) {
+ s_wsfe(&io___33);
+ do_fio(&c__1, " NNS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nns = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___34);
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nsval[i__ - 1] < 0) {
+ s_wsfe(&io___36);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nsval[i__ - 1] > 16) {
+ s_wsfe(&io___37);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__16, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L30: */
+ }
+ if (nns > 0) {
+ s_wsfe(&io___38);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of NB */
+
+ s_rsle(&io___39);
+ do_lio(&c__3, &c__1, (char *)&nnb, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nnb < 1) {
+ s_wsfe(&io___41);
+ do_fio(&c__1, "NNB ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nnb, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nnb = 0;
+ fatal = TRUE_;
+ } else if (nnb > 12) {
+ s_wsfe(&io___42);
+ do_fio(&c__1, "NNB ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nnb, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nnb = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___43);
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nbval[i__ - 1] < 0) {
+ s_wsfe(&io___45);
+ do_fio(&c__1, " NB ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L40: */
+ }
+ if (nnb > 0) {
+ s_wsfe(&io___46);
+ do_fio(&c__1, "NB ", (ftnlen)4);
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Set NBVAL2 to be the set of unique values of NB */
+
+ nnb2 = 0;
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nb = nbval[i__ - 1];
+ i__2 = nnb2;
+ for (j = 1; j <= i__2; ++j) {
+ if (nb == nbval2[j - 1]) {
+ goto L60;
+ }
+/* L50: */
+ }
+ ++nnb2;
+ nbval2[nnb2 - 1] = nb;
+L60:
+ ;
+ }
+
+/* Read the values of NX */
+
+ s_rsle(&io___51);
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nxval[i__ - 1] < 0) {
+ s_wsfe(&io___53);
+ do_fio(&c__1, " NX ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L70: */
+ }
+ if (nnb > 0) {
+ s_wsfe(&io___54);
+ do_fio(&c__1, "NX ", (ftnlen)4);
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of RANKVAL */
+
+ s_rsle(&io___55);
+ do_lio(&c__3, &c__1, (char *)&nrank, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nn < 1) {
+ s_wsfe(&io___57);
+ do_fio(&c__1, " NRANK ", (ftnlen)7);
+ do_fio(&c__1, (char *)&nrank, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nrank = 0;
+ fatal = TRUE_;
+ } else if (nn > 12) {
+ s_wsfe(&io___58);
+ do_fio(&c__1, " NRANK ", (ftnlen)7);
+ do_fio(&c__1, (char *)&nrank, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nrank = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___59);
+ i__1 = nrank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&rankval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nrank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (rankval[i__ - 1] < 0) {
+ s_wsfe(&io___61);
+ do_fio(&c__1, " RANK ", (ftnlen)7);
+ do_fio(&c__1, (char *)&rankval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (rankval[i__ - 1] > 100) {
+ s_wsfe(&io___62);
+ do_fio(&c__1, " RANK ", (ftnlen)7);
+ do_fio(&c__1, (char *)&rankval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__100, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+ }
+ if (nrank > 0) {
+ s_wsfe(&io___63);
+ do_fio(&c__1, "RANK % OF N", (ftnlen)11);
+ i__1 = nrank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&rankval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the threshold value for the test ratios. */
+
+ s_rsle(&io___64);
+ do_lio(&c__4, &c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_rsle();
+ s_wsfe(&io___66);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_wsfe();
+
+/* Read the flag that indicates whether to test the LAPACK routines. */
+
+ s_rsle(&io___67);
+ do_lio(&c__8, &c__1, (char *)&tstchk, (ftnlen)sizeof(logical));
+ e_rsle();
+
+/* Read the flag that indicates whether to test the driver routines. */
+
+ s_rsle(&io___69);
+ do_lio(&c__8, &c__1, (char *)&tstdrv, (ftnlen)sizeof(logical));
+ e_rsle();
+
+/* Read the flag that indicates whether to test the error exits. */
+
+ s_rsle(&io___71);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+
+ if (fatal) {
+ s_wsfe(&io___73);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Calculate and print the machine dependent constants. */
+
+ eps = slamch_("Underflow threshold");
+ s_wsfe(&io___75);
+ do_fio(&c__1, "underflow", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+ eps = slamch_("Overflow threshold");
+ s_wsfe(&io___76);
+ do_fio(&c__1, "overflow ", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+ eps = slamch_("Epsilon");
+ s_wsfe(&io___77);
+ do_fio(&c__1, "precision", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_wsle(&io___78);
+ e_wsle();
+ nrhs = nsval[0];
+
+L80:
+
+/* Read a test path and the number of matrix types to use. */
+
+ ci__1.cierr = 0;
+ ci__1.ciend = 1;
+ ci__1.ciunit = 5;
+ ci__1.cifmt = "(A72)";
+ i__1 = s_rsfe(&ci__1);
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = do_fio(&c__1, aline, (ftnlen)72);
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L140;
+ }
+ s_copy(path, aline, (ftnlen)3, (ftnlen)3);
+ nmats = 30;
+ i__ = 3;
+L90:
+ ++i__;
+ if (i__ > 72) {
+ goto L130;
+ }
+ if (*(unsigned char *)&aline[i__ - 1] == ' ') {
+ goto L90;
+ }
+ nmats = 0;
+L100:
+ *(unsigned char *)c1 = *(unsigned char *)&aline[i__ - 1];
+ for (k = 1; k <= 10; ++k) {
+ if (*(unsigned char *)c1 == *(unsigned char *)&intstr[k - 1]) {
+ ic = k - 1;
+ goto L120;
+ }
+/* L110: */
+ }
+ goto L130;
+L120:
+ nmats = nmats * 10 + ic;
+ ++i__;
+ if (i__ > 72) {
+ goto L130;
+ }
+ goto L100;
+L130:
+ *(unsigned char *)c1 = *(unsigned char *)path;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Check first character for correct precision. */
+
+ if (! lsame_(c1, "Complex precision")) {
+ s_wsfe(&io___87);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+ } else if (nmats <= 0) {
+
+/* Check for a positive number of tests requested. */
+
+ s_wsfe(&io___88);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, c2, "GE")) {
+
+/* GE: general matrices */
+
+ ntypes = 11;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ cchkge_(dotype, &nm, mval, &nn, nval, &nnb2, nbval2, &nns, nsval,
+ &thresh, &tsterr, &lda, a, &a[21912], &a[43824], b, &b[
+ 2112], &b[4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___96);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ cdrvge_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
+ work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___98);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* GB: general banded matrices */
+
+ la = 43692;
+ lafac = 65472;
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ cchkgb_(dotype, &nm, mval, &nn, nval, &nnb2, nbval2, &nns, nsval,
+ &thresh, &tsterr, a, &la, &a[43824], &lafac, b, &b[2112],
+ &b[4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___101);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ cdrvgb_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, a, &la, &a[
+ 43824], &lafac, &a[109560], b, &b[2112], &b[4224], &b[
+ 6336], s, work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___102);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "GT")) {
+
+/* GT: general tridiagonal matrices */
+
+ ntypes = 12;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ cchkgt_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, a, &a[
+ 21912], b, &b[2112], &b[4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___103);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ cdrvgt_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, a, &a[21912],
+ b, &b[2112], &b[4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___104);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "PO")) {
+
+/* PO: positive definite matrices */
+
+ ntypes = 9;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ cchkpo_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
+ tsterr, &lda, a, &a[21912], &a[43824], b, &b[2112], &b[
+ 4224], work, rwork, &c__6);
+ } else {
+ s_wsfe(&io___105);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ cdrvpo_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
+ work, rwork, &c__6);
+ } else {
+ s_wsfe(&io___106);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "PS")) {
+
+/* PS: positive semi-definite matrices */
+
+ ntypes = 9;
+
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ cchkps_(dotype, &nn, nval, &nnb2, nbval2, &nrank, rankval, &
+ thresh, &tsterr, &lda, a, &a[21912], &a[43824], piv, work,
+ rwork, &c__6);
+ } else {
+ s_wsfe(&io___108);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "PP")) {
+
+/* PP: positive definite packed matrices */
+
+ ntypes = 9;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ cchkpp_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
+ &a[21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
+ &c__6);
+ } else {
+ s_wsfe(&io___109);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ cdrvpp_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
+ work, rwork, &c__6);
+ } else {
+ s_wsfe(&io___110);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* PB: positive definite banded matrices */
+
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ cchkpb_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
+ tsterr, &lda, a, &a[21912], &a[43824], b, &b[2112], &b[
+ 4224], work, rwork, &c__6);
+ } else {
+ s_wsfe(&io___111);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ cdrvpb_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
+ work, rwork, &c__6);
+ } else {
+ s_wsfe(&io___112);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "PT")) {
+
+/* PT: positive definite tridiagonal matrices */
+
+ ntypes = 12;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ cchkpt_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, a, s, &
+ a[21912], b, &b[2112], &b[4224], work, rwork, &c__6);
+ } else {
+ s_wsfe(&io___113);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ cdrvpt_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, a, s, &a[
+ 21912], b, &b[2112], &b[4224], work, rwork, &c__6);
+ } else {
+ s_wsfe(&io___114);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "HE")) {
+
+/* HE: Hermitian indefinite matrices */
+
+ ntypes = 10;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ cchkhe_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
+ tsterr, &lda, a, &a[21912], &a[43824], b, &b[2112], &b[
+ 4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___115);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ cdrvhe_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
+ iwork, &c__6);
+ } else {
+ s_wsfe(&io___116);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "HP")) {
+
+/* HP: Hermitian indefinite packed matrices */
+
+ ntypes = 10;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ cchkhp_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
+ &a[21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
+ iwork, &c__6);
+ } else {
+ s_wsfe(&io___117);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ cdrvhp_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
+ iwork, &c__6);
+ } else {
+ s_wsfe(&io___118);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "SY")) {
+
+/* SY: symmetric indefinite matrices */
+
+ ntypes = 11;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ cchksy_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
+ tsterr, &lda, a, &a[21912], &a[43824], b, &b[2112], &b[
+ 4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___119);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ cdrvsy_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
+ iwork, &c__6);
+ } else {
+ s_wsfe(&io___120);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "SP")) {
+
+/* SP: symmetric indefinite packed matrices */
+
+ ntypes = 11;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ cchksp_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
+ &a[21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
+ iwork, &c__6);
+ } else {
+ s_wsfe(&io___121);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ cdrvsp_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
+ iwork, &c__6);
+ } else {
+ s_wsfe(&io___122);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "TR")) {
+
+/* TR: triangular matrices */
+
+ ntypes = 18;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ cchktr_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
+ tsterr, &lda, a, &a[21912], b, &b[2112], &b[4224], work,
+ rwork, &c__6);
+ } else {
+ s_wsfe(&io___123);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "TP")) {
+
+/* TP: triangular packed matrices */
+
+ ntypes = 18;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ cchktp_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
+ &a[21912], b, &b[2112], &b[4224], work, rwork, &c__6);
+ } else {
+ s_wsfe(&io___124);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "TB")) {
+
+/* TB: triangular banded matrices */
+
+ ntypes = 17;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ cchktb_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
+ &a[21912], b, &b[2112], &b[4224], work, rwork, &c__6);
+ } else {
+ s_wsfe(&io___125);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "QR")) {
+
+/* QR: QR factorization */
+
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ cchkqr_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
+ thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
+ 65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
+ rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___126);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "LQ")) {
+
+/* LQ: LQ factorization */
+
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ cchklq_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
+ thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
+ 65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
+ rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___127);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "QL")) {
+
+/* QL: QL factorization */
+
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ cchkql_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
+ thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
+ 65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
+ rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___128);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "RQ")) {
+
+/* RQ: RQ factorization */
+
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ cchkrq_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
+ thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
+ 65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
+ rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___129);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "EQ")) {
+
+/* EQ: Equilibration routines for general and positive definite */
+/* matrices (THREQ should be between 2 and 10) */
+
+ if (tstchk) {
+ cchkeq_(&threq, &c__6);
+ } else {
+ s_wsfe(&io___130);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "TZ")) {
+
+/* TZ: Trapezoidal matrix */
+
+ ntypes = 3;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ cchktz_(dotype, &nm, mval, &nn, nval, &thresh, &tsterr, a, &a[
+ 21912], s, &s[132], b, work, rwork, &c__6);
+ } else {
+ s_wsfe(&io___131);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "QP")) {
+
+/* QP: QR factorization with pivoting */
+
+ ntypes = 6;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ cchkqp_(dotype, &nm, mval, &nn, nval, &thresh, &tsterr, a, &a[
+ 21912], s, &s[132], b, work, rwork, iwork, &c__6);
+ cchkq3_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &thresh,
+ a, &a[21912], s, &s[132], b, work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___132);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "LS")) {
+
+/* LS: Least squares drivers */
+
+ ntypes = 6;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstdrv) {
+ cdrvls_(dotype, &nm, mval, &nn, nval, &nns, nsval, &nnb, nbval,
+ nxval, &thresh, &tsterr, a, &a[21912], &a[43824], &a[
+ 65736], &a[87648], s, &s[132], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___133);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else {
+
+ s_wsfe(&io___134);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+/* Go back to get another input line. */
+
+ goto L80;
+
+/* Branch to this line when the last record is read. */
+
+L140:
+ cl__1.cerr = 0;
+ cl__1.cunit = 5;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ s2 = second_();
+ s_wsfe(&io___136);
+ e_wsfe();
+ s_wsfe(&io___137);
+ r__1 = s2 - s1;
+ do_fio(&c__1, (char *)&r__1, (ftnlen)sizeof(real));
+ e_wsfe();
+
+
+/* End of CCHKAA */
+
+ return 0;
+} /* MAIN__ */
+
+/* Main program alias */ int cchkaa_ () { MAIN__ (); return 0; }
diff --git a/TESTING/LIN/cchkeq.c b/TESTING/LIN/cchkeq.c
new file mode 100644
index 0000000..a7d8a98
--- /dev/null
+++ b/TESTING/LIN/cchkeq.c
@@ -0,0 +1,703 @@
+/* cchkeq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b9 = 10.f;
+static integer c_n1 = -1;
+static integer c__5 = 5;
+static integer c__13 = 13;
+static integer c__1 = 1;
+
+/* Subroutine */ int cchkeq_(real *thresh, integer *nout)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002All tests for \002,a3,\002 routines pa"
+ "ssed the threshold\002)";
+ static char fmt_9998[] = "(\002 CGEEQU failed test with value \002,e10"
+ ".3,\002 exceeding\002,\002 threshold \002,e10.3)";
+ static char fmt_9997[] = "(\002 CGBEQU failed test with value \002,e10"
+ ".3,\002 exceeding\002,\002 threshold \002,e10.3)";
+ static char fmt_9996[] = "(\002 CPOEQU failed test with value \002,e10"
+ ".3,\002 exceeding\002,\002 threshold \002,e10.3)";
+ static char fmt_9995[] = "(\002 CPPEQU failed test with value \002,e10"
+ ".3,\002 exceeding\002,\002 threshold \002,e10.3)";
+ static char fmt_9994[] = "(\002 CPBEQU failed test with value \002,e10"
+ ".3,\002 exceeding\002,\002 threshold \002,e10.3)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
+ real r__1, r__2, r__3;
+ complex q__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double pow_ri(real *, integer *);
+ integer pow_ii(integer *, integer *), s_wsle(cilist *), e_wsle(void),
+ s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ complex a[25] /* was [5][5] */;
+ real c__[5];
+ integer i__, j, m, n;
+ real r__[5];
+ complex ab[65] /* was [13][5] */, ap[15];
+ integer kl;
+ logical ok;
+ integer ku;
+ real eps, pow[11];
+ integer info;
+ char path[3];
+ real norm, rpow[11], ccond, rcond, rcmin, rcmax, ratio;
+ extern /* Subroutine */ int cgbequ_(integer *, integer *, integer *,
+ integer *, complex *, integer *, real *, real *, real *, real *,
+ real *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int cgeequ_(integer *, integer *, complex *,
+ integer *, real *, real *, real *, real *, real *, integer *),
+ cpbequ_(char *, integer *, integer *, complex *, integer *, real *
+, real *, real *, integer *), cpoequ_(integer *, complex *
+, integer *, real *, real *, real *, integer *), cppequ_(char *,
+ integer *, complex *, real *, real *, real *, integer *);
+ real reslts[5];
+
+ /* Fortran I/O blocks */
+ static cilist io___25 = { 0, 0, 0, 0, 0 };
+ static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKEQ tests CGEEQU, CGBEQU, CPOEQU, CPPEQU and CPBEQU */
+
+/* Arguments */
+/* ========= */
+
+/* THRESH (input) REAL */
+/* Threshold for testing routines. Should be between 2 and 10. */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "EQ", (ftnlen)2, (ftnlen)2);
+
+ eps = slamch_("P");
+ for (i__ = 1; i__ <= 5; ++i__) {
+ reslts[i__ - 1] = 0.f;
+/* L10: */
+ }
+ for (i__ = 1; i__ <= 11; ++i__) {
+ i__1 = i__ - 1;
+ pow[i__ - 1] = pow_ri(&c_b9, &i__1);
+ rpow[i__ - 1] = 1.f / pow[i__ - 1];
+/* L20: */
+ }
+
+/* Test CGEEQU */
+
+ for (n = 0; n <= 5; ++n) {
+ for (m = 0; m <= 5; ++m) {
+
+ for (j = 1; j <= 5; ++j) {
+ for (i__ = 1; i__ <= 5; ++i__) {
+ if (i__ <= m && j <= n) {
+ i__1 = i__ + j * 5 - 6;
+ i__2 = i__ + j;
+ r__1 = pow[i__ + j] * pow_ii(&c_n1, &i__2);
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ } else {
+ i__1 = i__ + j * 5 - 6;
+ a[i__1].r = 0.f, a[i__1].i = 0.f;
+ }
+/* L30: */
+ }
+/* L40: */
+ }
+
+ cgeequ_(&m, &n, a, &c__5, r__, c__, &rcond, &ccond, &norm, &info);
+
+ if (info != 0) {
+ reslts[0] = 1.f;
+ } else {
+ if (n != 0 && m != 0) {
+/* Computing MAX */
+ r__2 = reslts[0], r__3 = (r__1 = (rcond - rpow[m - 1]) /
+ rpow[m - 1], dabs(r__1));
+ reslts[0] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = reslts[0], r__3 = (r__1 = (ccond - rpow[n - 1]) /
+ rpow[n - 1], dabs(r__1));
+ reslts[0] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = reslts[0], r__3 = (r__1 = (norm - pow[n + m]) /
+ pow[n + m], dabs(r__1));
+ reslts[0] = dmax(r__2,r__3);
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = reslts[0], r__3 = (r__1 = (r__[i__ - 1] - rpow[
+ i__ + n]) / rpow[i__ + n], dabs(r__1));
+ reslts[0] = dmax(r__2,r__3);
+/* L50: */
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ r__2 = reslts[0], r__3 = (r__1 = (c__[j - 1] - pow[n
+ - j]) / pow[n - j], dabs(r__1));
+ reslts[0] = dmax(r__2,r__3);
+/* L60: */
+ }
+ }
+ }
+
+/* L70: */
+ }
+/* L80: */
+ }
+
+/* Test with zero rows and columns */
+
+ for (j = 1; j <= 5; ++j) {
+ i__1 = j * 5 - 2;
+ a[i__1].r = 0.f, a[i__1].i = 0.f;
+/* L90: */
+ }
+ cgeequ_(&c__5, &c__5, a, &c__5, r__, c__, &rcond, &ccond, &norm, &info);
+ if (info != 4) {
+ reslts[0] = 1.f;
+ }
+
+ for (j = 1; j <= 5; ++j) {
+ i__1 = j * 5 - 2;
+ a[i__1].r = 1.f, a[i__1].i = 0.f;
+/* L100: */
+ }
+ for (i__ = 1; i__ <= 5; ++i__) {
+ i__1 = i__ + 14;
+ a[i__1].r = 0.f, a[i__1].i = 0.f;
+/* L110: */
+ }
+ cgeequ_(&c__5, &c__5, a, &c__5, r__, c__, &rcond, &ccond, &norm, &info);
+ if (info != 9) {
+ reslts[0] = 1.f;
+ }
+ reslts[0] /= eps;
+
+/* Test CGBEQU */
+
+ for (n = 0; n <= 5; ++n) {
+ for (m = 0; m <= 5; ++m) {
+/* Computing MAX */
+ i__2 = m - 1;
+ i__1 = max(i__2,0);
+ for (kl = 0; kl <= i__1; ++kl) {
+/* Computing MAX */
+ i__3 = n - 1;
+ i__2 = max(i__3,0);
+ for (ku = 0; ku <= i__2; ++ku) {
+
+ for (j = 1; j <= 5; ++j) {
+ for (i__ = 1; i__ <= 13; ++i__) {
+ i__3 = i__ + j * 13 - 14;
+ ab[i__3].r = 0.f, ab[i__3].i = 0.f;
+/* L120: */
+ }
+/* L130: */
+ }
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = m;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+/* Computing MIN */
+ i__5 = m, i__6 = j + kl;
+/* Computing MAX */
+ i__7 = 1, i__8 = j - ku;
+ if (i__ <= min(i__5,i__6) && i__ >= max(i__7,i__8)
+ && j <= n) {
+ i__5 = ku + 1 + i__ - j + j * 13 - 14;
+ i__6 = i__ + j;
+ r__1 = pow[i__ + j] * pow_ii(&c_n1, &i__6);
+ ab[i__5].r = r__1, ab[i__5].i = 0.f;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+ cgbequ_(&m, &n, &kl, &ku, ab, &c__13, r__, c__, &rcond, &
+ ccond, &norm, &info);
+
+ if (info != 0) {
+ if (! (n + kl < m && info == n + kl + 1 || m + ku < n
+ && info == (m << 1) + ku + 1)) {
+ reslts[1] = 1.f;
+ }
+ } else {
+ if (n != 0 && m != 0) {
+
+ rcmin = r__[0];
+ rcmax = r__[0];
+ i__3 = m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = r__[i__ - 1];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = r__[i__ - 1];
+ rcmax = dmax(r__1,r__2);
+/* L160: */
+ }
+ ratio = rcmin / rcmax;
+/* Computing MAX */
+ r__2 = reslts[1], r__3 = (r__1 = (rcond - ratio) /
+ ratio, dabs(r__1));
+ reslts[1] = dmax(r__2,r__3);
+
+ rcmin = c__[0];
+ rcmax = c__[0];
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = c__[j - 1];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = c__[j - 1];
+ rcmax = dmax(r__1,r__2);
+/* L170: */
+ }
+ ratio = rcmin / rcmax;
+/* Computing MAX */
+ r__2 = reslts[1], r__3 = (r__1 = (ccond - ratio) /
+ ratio, dabs(r__1));
+ reslts[1] = dmax(r__2,r__3);
+
+/* Computing MAX */
+ r__2 = reslts[1], r__3 = (r__1 = (norm - pow[n +
+ m]) / pow[n + m], dabs(r__1));
+ reslts[1] = dmax(r__2,r__3);
+ i__3 = m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ rcmax = 0.f;
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ if (i__ <= j + kl && i__ >= j - ku) {
+ ratio = (r__1 = r__[i__ - 1] * pow[
+ i__ + j] * c__[j - 1], dabs(
+ r__1));
+ rcmax = dmax(rcmax,ratio);
+ }
+/* L180: */
+ }
+/* Computing MAX */
+ r__2 = reslts[1], r__3 = (r__1 = 1.f - rcmax,
+ dabs(r__1));
+ reslts[1] = dmax(r__2,r__3);
+/* L190: */
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ rcmax = 0.f;
+ i__4 = m;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ if (i__ <= j + kl && i__ >= j - ku) {
+ ratio = (r__1 = r__[i__ - 1] * pow[
+ i__ + j] * c__[j - 1], dabs(
+ r__1));
+ rcmax = dmax(rcmax,ratio);
+ }
+/* L200: */
+ }
+/* Computing MAX */
+ r__2 = reslts[1], r__3 = (r__1 = 1.f - rcmax,
+ dabs(r__1));
+ reslts[1] = dmax(r__2,r__3);
+/* L210: */
+ }
+ }
+ }
+
+/* L220: */
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+/* L250: */
+ }
+ reslts[1] /= eps;
+
+/* Test CPOEQU */
+
+ for (n = 0; n <= 5; ++n) {
+
+ for (i__ = 1; i__ <= 5; ++i__) {
+ for (j = 1; j <= 5; ++j) {
+ if (i__ <= n && j == i__) {
+ i__1 = i__ + j * 5 - 6;
+ i__2 = i__ + j;
+ r__1 = pow[i__ + j] * pow_ii(&c_n1, &i__2);
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ } else {
+ i__1 = i__ + j * 5 - 6;
+ a[i__1].r = 0.f, a[i__1].i = 0.f;
+ }
+/* L260: */
+ }
+/* L270: */
+ }
+
+ cpoequ_(&n, a, &c__5, r__, &rcond, &norm, &info);
+
+ if (info != 0) {
+ reslts[2] = 1.f;
+ } else {
+ if (n != 0) {
+/* Computing MAX */
+ r__2 = reslts[2], r__3 = (r__1 = (rcond - rpow[n - 1]) / rpow[
+ n - 1], dabs(r__1));
+ reslts[2] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = reslts[2], r__3 = (r__1 = (norm - pow[n * 2]) / pow[n *
+ 2], dabs(r__1));
+ reslts[2] = dmax(r__2,r__3);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = reslts[2], r__3 = (r__1 = (r__[i__ - 1] - rpow[i__]
+ ) / rpow[i__], dabs(r__1));
+ reslts[2] = dmax(r__2,r__3);
+/* L280: */
+ }
+ }
+ }
+/* L290: */
+ }
+ q__1.r = -1.f, q__1.i = -0.f;
+ a[18].r = q__1.r, a[18].i = q__1.i;
+ cpoequ_(&c__5, a, &c__5, r__, &rcond, &norm, &info);
+ if (info != 4) {
+ reslts[2] = 1.f;
+ }
+ reslts[2] /= eps;
+
+/* Test CPPEQU */
+
+ for (n = 0; n <= 5; ++n) {
+
+/* Upper triangular packed storage */
+
+ i__1 = n * (n + 1) / 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ - 1;
+ ap[i__2].r = 0.f, ap[i__2].i = 0.f;
+/* L300: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ * (i__ + 1) / 2 - 1;
+ i__3 = i__ << 1;
+ ap[i__2].r = pow[i__3], ap[i__2].i = 0.f;
+/* L310: */
+ }
+
+ cppequ_("U", &n, ap, r__, &rcond, &norm, &info);
+
+ if (info != 0) {
+ reslts[3] = 1.f;
+ } else {
+ if (n != 0) {
+/* Computing MAX */
+ r__2 = reslts[3], r__3 = (r__1 = (rcond - rpow[n - 1]) / rpow[
+ n - 1], dabs(r__1));
+ reslts[3] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = reslts[3], r__3 = (r__1 = (norm - pow[n * 2]) / pow[n *
+ 2], dabs(r__1));
+ reslts[3] = dmax(r__2,r__3);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = reslts[3], r__3 = (r__1 = (r__[i__ - 1] - rpow[i__]
+ ) / rpow[i__], dabs(r__1));
+ reslts[3] = dmax(r__2,r__3);
+/* L320: */
+ }
+ }
+ }
+
+/* Lower triangular packed storage */
+
+ i__1 = n * (n + 1) / 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ - 1;
+ ap[i__2].r = 0.f, ap[i__2].i = 0.f;
+/* L330: */
+ }
+ j = 1;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = j - 1;
+ i__3 = i__ << 1;
+ ap[i__2].r = pow[i__3], ap[i__2].i = 0.f;
+ j += n - i__ + 1;
+/* L340: */
+ }
+
+ cppequ_("L", &n, ap, r__, &rcond, &norm, &info);
+
+ if (info != 0) {
+ reslts[3] = 1.f;
+ } else {
+ if (n != 0) {
+/* Computing MAX */
+ r__2 = reslts[3], r__3 = (r__1 = (rcond - rpow[n - 1]) / rpow[
+ n - 1], dabs(r__1));
+ reslts[3] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = reslts[3], r__3 = (r__1 = (norm - pow[n * 2]) / pow[n *
+ 2], dabs(r__1));
+ reslts[3] = dmax(r__2,r__3);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = reslts[3], r__3 = (r__1 = (r__[i__ - 1] - rpow[i__]
+ ) / rpow[i__], dabs(r__1));
+ reslts[3] = dmax(r__2,r__3);
+/* L350: */
+ }
+ }
+ }
+
+/* L360: */
+ }
+ i__ = 13;
+ i__1 = i__ - 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ cppequ_("L", &c__5, ap, r__, &rcond, &norm, &info);
+ if (info != 4) {
+ reslts[3] = 1.f;
+ }
+ reslts[3] /= eps;
+
+/* Test CPBEQU */
+
+ for (n = 0; n <= 5; ++n) {
+/* Computing MAX */
+ i__2 = n - 1;
+ i__1 = max(i__2,0);
+ for (kl = 0; kl <= i__1; ++kl) {
+
+/* Test upper triangular storage */
+
+ for (j = 1; j <= 5; ++j) {
+ for (i__ = 1; i__ <= 13; ++i__) {
+ i__2 = i__ + j * 13 - 14;
+ ab[i__2].r = 0.f, ab[i__2].i = 0.f;
+/* L370: */
+ }
+/* L380: */
+ }
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = kl + 1 + j * 13 - 14;
+ i__4 = j << 1;
+ ab[i__3].r = pow[i__4], ab[i__3].i = 0.f;
+/* L390: */
+ }
+
+ cpbequ_("U", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
+
+ if (info != 0) {
+ reslts[4] = 1.f;
+ } else {
+ if (n != 0) {
+/* Computing MAX */
+ r__2 = reslts[4], r__3 = (r__1 = (rcond - rpow[n - 1]) /
+ rpow[n - 1], dabs(r__1));
+ reslts[4] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = reslts[4], r__3 = (r__1 = (norm - pow[n * 2]) /
+ pow[n * 2], dabs(r__1));
+ reslts[4] = dmax(r__2,r__3);
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = reslts[4], r__3 = (r__1 = (r__[i__ - 1] - rpow[
+ i__]) / rpow[i__], dabs(r__1));
+ reslts[4] = dmax(r__2,r__3);
+/* L400: */
+ }
+ }
+ }
+ if (n != 0) {
+/* Computing MAX */
+ i__3 = n - 1;
+ i__2 = kl + 1 + max(i__3,1) * 13 - 14;
+ q__1.r = -1.f, q__1.i = -0.f;
+ ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
+ cpbequ_("U", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
+/* Computing MAX */
+ i__2 = n - 1;
+ if (info != max(i__2,1)) {
+ reslts[4] = 1.f;
+ }
+ }
+
+/* Test lower triangular storage */
+
+ for (j = 1; j <= 5; ++j) {
+ for (i__ = 1; i__ <= 13; ++i__) {
+ i__2 = i__ + j * 13 - 14;
+ ab[i__2].r = 0.f, ab[i__2].i = 0.f;
+/* L410: */
+ }
+/* L420: */
+ }
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j * 13 - 13;
+ i__4 = j << 1;
+ ab[i__3].r = pow[i__4], ab[i__3].i = 0.f;
+/* L430: */
+ }
+
+ cpbequ_("L", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
+
+ if (info != 0) {
+ reslts[4] = 1.f;
+ } else {
+ if (n != 0) {
+/* Computing MAX */
+ r__2 = reslts[4], r__3 = (r__1 = (rcond - rpow[n - 1]) /
+ rpow[n - 1], dabs(r__1));
+ reslts[4] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = reslts[4], r__3 = (r__1 = (norm - pow[n * 2]) /
+ pow[n * 2], dabs(r__1));
+ reslts[4] = dmax(r__2,r__3);
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = reslts[4], r__3 = (r__1 = (r__[i__ - 1] - rpow[
+ i__]) / rpow[i__], dabs(r__1));
+ reslts[4] = dmax(r__2,r__3);
+/* L440: */
+ }
+ }
+ }
+ if (n != 0) {
+/* Computing MAX */
+ i__3 = n - 1;
+ i__2 = max(i__3,1) * 13 - 13;
+ q__1.r = -1.f, q__1.i = -0.f;
+ ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
+ cpbequ_("L", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
+/* Computing MAX */
+ i__2 = n - 1;
+ if (info != max(i__2,1)) {
+ reslts[4] = 1.f;
+ }
+ }
+/* L450: */
+ }
+/* L460: */
+ }
+ reslts[4] /= eps;
+ ok = reslts[0] <= *thresh && reslts[1] <= *thresh && reslts[2] <= *thresh
+ && reslts[3] <= *thresh && reslts[4] <= *thresh;
+ io___25.ciunit = *nout;
+ s_wsle(&io___25);
+ e_wsle();
+ if (ok) {
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (reslts[0] > *thresh) {
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__1, (char *)&reslts[0], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ if (reslts[1] > *thresh) {
+ io___28.ciunit = *nout;
+ s_wsfe(&io___28);
+ do_fio(&c__1, (char *)&reslts[1], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ if (reslts[2] > *thresh) {
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ do_fio(&c__1, (char *)&reslts[2], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ if (reslts[3] > *thresh) {
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&reslts[3], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ if (reslts[4] > *thresh) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&reslts[4], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ }
+ return 0;
+
+/* End of CCHKEQ */
+
+} /* cchkeq_ */
diff --git a/TESTING/LIN/cchkgb.c b/TESTING/LIN/cchkgb.c
new file mode 100644
index 0000000..97272e7
--- /dev/null
+++ b/TESTING/LIN/cchkgb.c
@@ -0,0 +1,871 @@
+/* cchkgb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static complex c_b61 = {0.f,0.f};
+static complex c_b62 = {1.f,0.f};
+static integer c__7 = 7;
+
+/* Subroutine */ int cchkgb_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nns, integer *nsval, real *thresh, logical *tsterr, complex *a,
+ integer *la, complex *afac, integer *lafac, complex *b, complex *x,
+ complex *xact, complex *work, real *rwork, integer *iwork, integer *
+ nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 *** In CCHKGB, LA=\002,i5,\002 is too sm"
+ "all for M=\002,i5,\002, N=\002,i5,\002, KL=\002,i4,\002, KU=\002"
+ ",i4,/\002 ==> Increase LA to at least \002,i5)";
+ static char fmt_9998[] = "(\002 *** In CCHKGB, LAFAC=\002,i5,\002 is too"
+ " small for M=\002,i5,\002, N=\002,i5,\002, KL=\002,i4,\002, KU"
+ "=\002,i4,/\002 ==> Increase LAFAC to at least \002,i5)";
+ static char fmt_9997[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, KL="
+ "\002,i5,\002, KU=\002,i5,\002, NB =\002,i4,\002, type \002,i1"
+ ",\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9996[] = "(\002 TRANS='\002,a1,\002', N=\002,i5,\002, "
+ "KL=\002,i5,\002, KU=\002,i5,\002, NRHS=\002,i3,\002, type \002,i"
+ "1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9995[] = "(\002 NORM ='\002,a1,\002', N=\002,i5,\002, "
+ "KL=\002,i5,\002, KU=\002,i5,\002,\002,10x,\002 type \002,i1,\002"
+ ", test(\002,i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10,
+ i__11;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, m, n, i1, i2, nb, im, in, kl, ku, lda, ldb, inb, ikl,
+ nkl, iku, nku, ioff, mode, koff, imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char norm[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), cgbt01_(
+ integer *, integer *, integer *, integer *, complex *, integer *,
+ complex *, integer *, integer *, complex *, real *), cgbt02_(char
+ *, integer *, integer *, integer *, integer *, integer *, complex
+ *, integer *, complex *, integer *, complex *, integer *, real *), cgbt05_(char *, integer *, integer *, integer *, integer
+ *, complex *, integer *, complex *, integer *, complex *, integer
+ *, complex *, integer *, real *, real *, real *), cget04_(
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ real *, real *);
+ integer nfail, iseed[4];
+ real rcond;
+ integer nimat, klval[4];
+ extern doublereal sget06_(real *, real *);
+ real anorm;
+ integer itran;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer kuval[4];
+ char trans[1];
+ integer izero, nerrs;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+);
+ integer ldafac;
+ extern doublereal clangb_(char *, integer *, integer *, integer *,
+ complex *, integer *, real *), clange_(char *, integer *,
+ integer *, complex *, integer *, real *);
+ extern /* Subroutine */ int cgbcon_(char *, integer *, integer *, integer
+ *, complex *, integer *, integer *, real *, real *, complex *,
+ real *, integer *), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *), cgbrfs_(char *, integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, integer *,
+ complex *, integer *, complex *, integer *, real *, real *,
+ complex *, real *, integer *), cerrge_(char *, integer *);
+ real rcondc;
+ extern /* Subroutine */ int cgbtrf_(integer *, integer *, integer *,
+ integer *, complex *, integer *, integer *, integer *), clacpy_(
+ char *, integer *, integer *, complex *, integer *, complex *,
+ integer *), clarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, integer *,
+ integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *);
+ real rcondi;
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ real cndnum, anormi, rcondo;
+ extern /* Subroutine */ int cgbtrs_(char *, integer *, integer *, integer
+ *, integer *, complex *, integer *, integer *, complex *, integer
+ *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, complex *, integer *, complex *, integer *);
+ logical trfcon;
+ real anormo;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *);
+ real result[7];
+
+ /* Fortran I/O blocks */
+ static cilist io___25 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___26 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKGB tests CGBTRF, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) COMPLEX array, dimension (LA) */
+
+/* LA (input) INTEGER */
+/* The length of the array A. LA >= (KLMAX+KUMAX+1)*NMAX */
+/* where KLMAX is the largest entry in the local array KLVAL, */
+/* KUMAX is the largest entry in the local array KUVAL and */
+/* NMAX is the largest entry in the input array NVAL. */
+
+/* AFAC (workspace) COMPLEX array, dimension (LAFAC) */
+
+/* LAFAC (input) INTEGER */
+/* The length of the array AFAC. LAFAC >= (2*KLMAX+KUMAX+1)*NMAX */
+/* where KLMAX is the largest entry in the local array KLVAL, */
+/* KUMAX is the largest entry in the local array KUVAL and */
+/* NMAX is the largest entry in the input array NVAL. */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(3,NSMAX,NMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --afac;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "GB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrge_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Initialize the first value for the lower and upper bandwidths. */
+
+ klval[0] = 0;
+ kuval[0] = 0;
+
+/* Do for each value of M in MVAL */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Set values to use for the lower bandwidth. */
+
+ klval[1] = m + (m + 1) / 4;
+
+/* KLVAL( 2 ) = MAX( M-1, 0 ) */
+
+ klval[2] = (m * 3 - 1) / 4;
+ klval[3] = (m + 1) / 4;
+
+/* Do for each value of N in NVAL */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ *(unsigned char *)xtype = 'N';
+
+/* Set values to use for the upper bandwidth. */
+
+ kuval[1] = n + (n + 1) / 4;
+
+/* KUVAL( 2 ) = MAX( N-1, 0 ) */
+
+ kuval[2] = (n * 3 - 1) / 4;
+ kuval[3] = (n + 1) / 4;
+
+/* Set limits on the number of loop iterations. */
+
+/* Computing MIN */
+ i__3 = m + 1;
+ nkl = min(i__3,4);
+ if (n == 0) {
+ nkl = 2;
+ }
+/* Computing MIN */
+ i__3 = n + 1;
+ nku = min(i__3,4);
+ if (m == 0) {
+ nku = 2;
+ }
+ nimat = 8;
+ if (m <= 0 || n <= 0) {
+ nimat = 1;
+ }
+
+ i__3 = nkl;
+ for (ikl = 1; ikl <= i__3; ++ikl) {
+
+/* Do for KL = 0, (5*M+1)/4, (3M-1)/4, and (M+1)/4. This */
+/* order makes it easier to skip redundant values for small */
+/* values of M. */
+
+ kl = klval[ikl - 1];
+ i__4 = nku;
+ for (iku = 1; iku <= i__4; ++iku) {
+
+/* Do for KU = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This */
+/* order makes it easier to skip redundant values for */
+/* small values of N. */
+
+ ku = kuval[iku - 1];
+
+/* Check that A and AFAC are big enough to generate this */
+/* matrix. */
+
+ lda = kl + ku + 1;
+ ldafac = (kl << 1) + ku + 1;
+ if (lda * n > *la || ldafac * n > *lafac) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ if (n * (kl + ku + 1) > *la) {
+ io___25.ciunit = *nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, (char *)&(*la), (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)
+ );
+ i__5 = n * (kl + ku + 1);
+ do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ if (n * ((kl << 1) + ku + 1) > *lafac) {
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, (char *)&(*lafac), (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)
+ );
+ i__5 = n * ((kl << 1) + ku + 1);
+ do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ goto L130;
+ }
+
+ i__5 = nimat;
+ for (imat = 1; imat <= i__5; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+/* Skip types 2, 3, or 4 if the matrix size is too */
+/* small. */
+
+ zerot = imat >= 2 && imat <= 4;
+ if (zerot && n < imat - 1) {
+ goto L120;
+ }
+
+ if (! zerot || ! dotype[1]) {
+
+/* Set up parameters with CLATB4 and generate a */
+/* test matrix with CLATMS. */
+
+ clatb4_(path, &imat, &m, &n, type__, &kl, &ku, &
+ anorm, &mode, &cndnum, dist);
+
+/* Computing MAX */
+ i__6 = 1, i__7 = ku + 2 - n;
+ koff = max(i__6,i__7);
+ i__6 = koff - 1;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ i__7 = i__;
+ a[i__7].r = 0.f, a[i__7].i = 0.f;
+/* L20: */
+ }
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (
+ ftnlen)6);
+ clatms_(&m, &n, dist, iseed, type__, &rwork[1], &
+ mode, &cndnum, &anorm, &kl, &ku, "Z", &a[
+ koff], &lda, &work[1], &info);
+
+/* Check the error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, " ", &m,
+ &n, &kl, &ku, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ goto L120;
+ }
+ } else if (izero > 0) {
+
+/* Use the same matrix for types 3 and 4 as for */
+/* type 2 by copying back the zeroed out column. */
+
+ i__6 = i2 - i1 + 1;
+ ccopy_(&i__6, &b[1], &c__1, &a[ioff + i1], &c__1);
+ }
+
+/* For types 2, 3, and 4, zero one or more columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ izero = 0;
+ if (zerot) {
+ if (imat == 2) {
+ izero = 1;
+ } else if (imat == 3) {
+ izero = min(m,n);
+ } else {
+ izero = min(m,n) / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 4) {
+
+/* Store the column to be zeroed out in B. */
+
+/* Computing MAX */
+ i__6 = 1, i__7 = ku + 2 - izero;
+ i1 = max(i__6,i__7);
+/* Computing MIN */
+ i__6 = kl + ku + 1, i__7 = ku + 1 + (m -
+ izero);
+ i2 = min(i__6,i__7);
+ i__6 = i2 - i1 + 1;
+ ccopy_(&i__6, &a[ioff + i1], &c__1, &b[1], &
+ c__1);
+
+ i__6 = i2;
+ for (i__ = i1; i__ <= i__6; ++i__) {
+ i__7 = ioff + i__;
+ a[i__7].r = 0.f, a[i__7].i = 0.f;
+/* L30: */
+ }
+ } else {
+ i__6 = n;
+ for (j = izero; j <= i__6; ++j) {
+/* Computing MAX */
+ i__7 = 1, i__8 = ku + 2 - j;
+/* Computing MIN */
+ i__10 = kl + ku + 1, i__11 = ku + 1 + (m
+ - j);
+ i__9 = min(i__10,i__11);
+ for (i__ = max(i__7,i__8); i__ <= i__9;
+ ++i__) {
+ i__7 = ioff + i__;
+ a[i__7].r = 0.f, a[i__7].i = 0.f;
+/* L40: */
+ }
+ ioff += lda;
+/* L50: */
+ }
+ }
+ }
+
+/* These lines, if used in place of the calls in the */
+/* loop over INB, cause the code to bomb on a Sun */
+/* SPARCstation. */
+
+/* ANORMO = CLANGB( 'O', N, KL, KU, A, LDA, RWORK ) */
+/* ANORMI = CLANGB( 'I', N, KL, KU, A, LDA, RWORK ) */
+
+/* Do for each blocksize in NBVAL */
+
+ i__6 = *nnb;
+ for (inb = 1; inb <= i__6; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the LU factorization of the band matrix. */
+
+ if (m > 0 && n > 0) {
+ i__9 = kl + ku + 1;
+ clacpy_("Full", &i__9, &n, &a[1], &lda, &afac[
+ kl + 1], &ldafac);
+ }
+ s_copy(srnamc_1.srnamt, "CGBTRF", (ftnlen)32, (
+ ftnlen)6);
+ cgbtrf_(&m, &n, &kl, &ku, &afac[1], &ldafac, &
+ iwork[1], &info);
+
+/* Check error code from CGBTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "CGBTRF", &info, &izero, " ", &
+ m, &n, &kl, &ku, &nb, &imat, &nfail, &
+ nerrs, nout);
+ }
+ trfcon = FALSE_;
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ cgbt01_(&m, &n, &kl, &ku, &a[1], &lda, &afac[1], &
+ ldafac, &iwork[1], &work[1], result);
+
+/* Print information about the tests so far that */
+/* did not pass the threshold. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+/* Skip the remaining tests if this is not the */
+/* first block size or if M .ne. N. */
+
+ if (inb > 1 || m != n) {
+ goto L110;
+ }
+
+ anormo = clangb_("O", &n, &kl, &ku, &a[1], &lda, &
+ rwork[1]);
+ anormi = clangb_("I", &n, &kl, &ku, &a[1], &lda, &
+ rwork[1]);
+
+ if (info == 0) {
+
+/* Form the inverse of A so we can get a good */
+/* estimate of CNDNUM = norm(A) * norm(inv(A)). */
+
+ ldb = max(1,n);
+ claset_("Full", &n, &n, &c_b61, &c_b62, &work[
+ 1], &ldb);
+ s_copy(srnamc_1.srnamt, "CGBTRS", (ftnlen)32,
+ (ftnlen)6);
+ cgbtrs_("No transpose", &n, &kl, &ku, &n, &
+ afac[1], &ldafac, &iwork[1], &work[1],
+ &ldb, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = clange_("O", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormo <= 0.f || ainvnm <= 0.f) {
+ rcondo = 1.f;
+ } else {
+ rcondo = 1.f / anormo / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number of */
+/* A. */
+
+ ainvnm = clange_("I", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormi <= 0.f || ainvnm <= 0.f) {
+ rcondi = 1.f;
+ } else {
+ rcondi = 1.f / anormi / ainvnm;
+ }
+ } else {
+
+/* Do only the condition estimate if INFO.NE.0. */
+
+ trfcon = TRUE_;
+ rcondo = 0.f;
+ rcondi = 0.f;
+ }
+
+/* Skip the solve tests if the matrix is singular. */
+
+ if (trfcon) {
+ goto L90;
+ }
+
+ i__9 = *nns;
+ for (irhs = 1; irhs <= i__9; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+
+ for (itran = 1; itran <= 3; ++itran) {
+ *(unsigned char *)trans = *(unsigned char
+ *)&transs[itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ *(unsigned char *)norm = 'O';
+ } else {
+ rcondc = rcondi;
+ *(unsigned char *)norm = 'I';
+ }
+
+/* + TEST 2: */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)
+ 32, (ftnlen)6);
+ clarhs_(path, xtype, " ", trans, &n, &n, &
+ kl, &ku, &nrhs, &a[1], &lda, &
+ xact[1], &ldb, &b[1], &ldb, iseed,
+ &info);
+ *(unsigned char *)xtype = 'C';
+ clacpy_("Full", &n, &nrhs, &b[1], &ldb, &
+ x[1], &ldb);
+
+ s_copy(srnamc_1.srnamt, "CGBTRS", (ftnlen)
+ 32, (ftnlen)6);
+ cgbtrs_(trans, &n, &kl, &ku, &nrhs, &afac[
+ 1], &ldafac, &iwork[1], &x[1], &
+ ldb, &info);
+
+/* Check error code from CGBTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "CGBTRS", &info, &c__0,
+ trans, &n, &n, &kl, &ku, &
+ c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ clacpy_("Full", &n, &nrhs, &b[1], &ldb, &
+ work[1], &ldb);
+ cgbt02_(trans, &m, &n, &kl, &ku, &nrhs, &
+ a[1], &lda, &x[1], &ldb, &work[1],
+ &ldb, &result[1]);
+
+/* + TEST 3: */
+/* Check solution from generated exact */
+/* solution. */
+
+ cget04_(&n, &nrhs, &x[1], &ldb, &xact[1],
+ &ldb, &rcondc, &result[2]);
+
+/* + TESTS 4, 5, 6: */
+/* Use iterative refinement to improve the */
+/* solution. */
+
+ s_copy(srnamc_1.srnamt, "CGBRFS", (ftnlen)
+ 32, (ftnlen)6);
+ cgbrfs_(trans, &n, &kl, &ku, &nrhs, &a[1],
+ &lda, &afac[1], &ldafac, &iwork[
+ 1], &b[1], &ldb, &x[1], &ldb, &
+ rwork[1], &rwork[nrhs + 1], &work[
+ 1], &rwork[(nrhs << 1) + 1], &
+ info);
+
+/* Check error code from CGBRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "CGBRFS", &info, &c__0,
+ trans, &n, &n, &kl, &ku, &
+ nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ cget04_(&n, &nrhs, &x[1], &ldb, &xact[1],
+ &ldb, &rcondc, &result[3]);
+ cgbt05_(trans, &n, &kl, &ku, &nrhs, &a[1],
+ &lda, &b[1], &ldb, &x[1], &ldb, &
+ xact[1], &ldb, &rwork[1], &rwork[
+ nrhs + 1], &result[4]);
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___59.ciunit = *nout;
+ s_wsfe(&io___59);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrhs, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k -
+ 1], (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += 5;
+/* L70: */
+ }
+/* L80: */
+ }
+
+/* + TEST 7: */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+L90:
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ anorm = anormo;
+ rcondc = rcondo;
+ *(unsigned char *)norm = 'O';
+ } else {
+ anorm = anormi;
+ rcondc = rcondi;
+ *(unsigned char *)norm = 'I';
+ }
+ s_copy(srnamc_1.srnamt, "CGBCON", (ftnlen)32,
+ (ftnlen)6);
+ cgbcon_(norm, &n, &kl, &ku, &afac[1], &ldafac,
+ &iwork[1], &anorm, &rcond, &work[1],
+ &rwork[1], &info);
+
+/* Check error code from CGBCON. */
+
+ if (info != 0) {
+ alaerh_(path, "CGBCON", &info, &c__0,
+ norm, &n, &n, &kl, &ku, &c_n1, &
+ imat, &nfail, &nerrs, nout);
+ }
+
+ result[6] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___61.ciunit = *nout;
+ s_wsfe(&io___61);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L100: */
+ }
+L110:
+ ;
+ }
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+
+ return 0;
+
+/* End of CCHKGB */
+
+} /* cchkgb_ */
diff --git a/TESTING/LIN/cchkge.c b/TESTING/LIN/cchkge.c
new file mode 100644
index 0000000..17b7c70
--- /dev/null
+++ b/TESTING/LIN/cchkge.c
@@ -0,0 +1,685 @@
+/* cchkge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static complex c_b23 = {0.f,0.f};
+static logical c_true = TRUE_;
+static integer c__8 = 8;
+
+/* Subroutine */ int cchkge_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nns, integer *nsval, real *thresh, logical *tsterr, integer *nmax,
+ complex *a, complex *afac, complex *ainv, complex *b, complex *x,
+ complex *xact, complex *work, real *rwork, integer *iwork, integer *
+ nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M = \002,i5,\002, N =\002,i5,\002, NB "
+ "=\002,i4,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
+ ;
+ static char fmt_9998[] = "(\002 TRANS='\002,a1,\002', N =\002,i5,\002, N"
+ "RHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g1"
+ "2.5)";
+ static char fmt_9997[] = "(\002 NORM ='\002,a1,\002', N =\002,i5,\002"
+ ",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
+ ;
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, im, in, kl, ku, nt, lda, inb, ioff, mode, imat,
+ info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char norm[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), cget01_(
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ integer *, real *, real *), cget02_(char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, real *, real *), cget03_(integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, real *,
+ real *, real *), cget04_(integer *, integer *, complex *, integer
+ *, complex *, integer *, real *, real *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int cget07_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, complex *, integer *, complex
+ *, integer *, real *, logical *, real *, real *);
+ real rcond;
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ real anorm;
+ integer itran;
+ char trans[1];
+ integer izero, nerrs;
+ real dummy;
+ integer lwork;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *), cgecon_(char *, integer *, complex *, integer *, real *,
+ real *, complex *, real *, integer *), cerrge_(char *,
+ integer *);
+ real rcondc;
+ extern /* Subroutine */ int cgerfs_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, integer *, complex *, integer
+ *, complex *, integer *, real *, real *, complex *, real *,
+ integer *), cgetrf_(integer *, integer *, complex *,
+ integer *, integer *, integer *), clacpy_(char *, integer *,
+ integer *, complex *, integer *, complex *, integer *),
+ clarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, complex *, integer *, complex *,
+ integer *, complex *, integer *, integer *, integer *), cgetri_(integer *, complex *, integer *,
+ integer *, complex *, integer *, integer *);
+ real rcondi;
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), alasum_(char *,
+ integer *, integer *, integer *, integer *);
+ real cndnum, anormi, rcondo;
+ extern /* Subroutine */ int cgetrs_(char *, integer *, integer *, complex
+ *, integer *, integer *, complex *, integer *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, complex *, integer *, complex *, integer *);
+ logical trfcon;
+ real anormo;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *);
+ real result[8];
+
+ /* Fortran I/O blocks */
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKGE tests CGETRF, -TRI, -TRS, -RFS, and -CON. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(2*NMAX,2*NSMAX+NWORK)) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "GE", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ xlaenv_(&c__1, &c__1);
+ if (*tsterr) {
+ cerrge_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+/* Do for each value of M in MVAL */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+ lda = max(1,m);
+
+/* Do for each value of N in NVAL */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ *(unsigned char *)xtype = 'N';
+ nimat = 11;
+ if (m <= 0 || n <= 0) {
+ nimat = 1;
+ }
+
+ i__3 = nimat;
+ for (imat = 1; imat <= i__3; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L100;
+ }
+
+/* Skip types 5, 6, or 7 if the matrix size is too small. */
+
+ zerot = imat >= 5 && imat <= 7;
+ if (zerot && n < imat - 4) {
+ goto L100;
+ }
+
+/* Set up parameters with CLATB4 and generate a test matrix */
+/* with CLATMS. */
+
+ clatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, " ", &m, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L100;
+ }
+
+/* For types 5-7, zero one or more columns of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 5) {
+ izero = 1;
+ } else if (imat == 6) {
+ izero = min(m,n);
+ } else {
+ izero = min(m,n) / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 7) {
+ i__4 = m;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+/* L20: */
+ }
+ } else {
+ i__4 = n - izero + 1;
+ claset_("Full", &m, &i__4, &c_b23, &c_b23, &a[ioff +
+ 1], &lda);
+ }
+ } else {
+ izero = 0;
+ }
+
+/* These lines, if used in place of the calls in the DO 60 */
+/* loop, cause the code to bomb on a Sun SPARCstation. */
+
+/* ANORMO = CLANGE( 'O', M, N, A, LDA, RWORK ) */
+/* ANORMI = CLANGE( 'I', M, N, A, LDA, RWORK ) */
+
+/* Do for each blocksize in NBVAL */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the LU factorization of the matrix. */
+
+ clacpy_("Full", &m, &n, &a[1], &lda, &afac[1], &lda);
+ s_copy(srnamc_1.srnamt, "CGETRF", (ftnlen)32, (ftnlen)6);
+ cgetrf_(&m, &n, &afac[1], &lda, &iwork[1], &info);
+
+/* Check error code from CGETRF. */
+
+ if (info != izero) {
+ alaerh_(path, "CGETRF", &info, &izero, " ", &m, &n, &
+ c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
+ }
+ trfcon = FALSE_;
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ clacpy_("Full", &m, &n, &afac[1], &lda, &ainv[1], &lda);
+ cget01_(&m, &n, &a[1], &lda, &ainv[1], &lda, &iwork[1], &
+ rwork[1], result);
+ nt = 1;
+
+/* + TEST 2 */
+/* Form the inverse if the factorization was successful */
+/* and compute the residual. */
+
+ if (m == n && info == 0) {
+ clacpy_("Full", &n, &n, &afac[1], &lda, &ainv[1], &
+ lda);
+ s_copy(srnamc_1.srnamt, "CGETRI", (ftnlen)32, (ftnlen)
+ 6);
+ nrhs = nsval[1];
+ lwork = *nmax * max(3,nrhs);
+ cgetri_(&n, &ainv[1], &lda, &iwork[1], &work[1], &
+ lwork, &info);
+
+/* Check error code from CGETRI. */
+
+ if (info != 0) {
+ alaerh_(path, "CGETRI", &info, &c__0, " ", &n, &n,
+ &c_n1, &c_n1, &nb, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+/* Compute the residual for the matrix times its */
+/* inverse. Also compute the 1-norm condition number */
+/* of A. */
+
+ cget03_(&n, &a[1], &lda, &ainv[1], &lda, &work[1], &
+ lda, &rwork[1], &rcondo, &result[1]);
+ anormo = clange_("O", &m, &n, &a[1], &lda, &rwork[1]);
+
+/* Compute the infinity-norm condition number of A. */
+
+ anormi = clange_("I", &m, &n, &a[1], &lda, &rwork[1]);
+ ainvnm = clange_("I", &n, &n, &ainv[1], &lda, &rwork[
+ 1]);
+ if (anormi <= 0.f || ainvnm <= 0.f) {
+ rcondi = 1.f;
+ } else {
+ rcondi = 1.f / anormi / ainvnm;
+ }
+ nt = 2;
+ } else {
+
+/* Do only the condition estimate if INFO > 0. */
+
+ trfcon = TRUE_;
+ anormo = clange_("O", &m, &n, &a[1], &lda, &rwork[1]);
+ anormi = clange_("I", &m, &n, &a[1], &lda, &rwork[1]);
+ rcondo = 0.f;
+ rcondi = 0.f;
+ }
+
+/* Print information about the tests so far that did not */
+/* pass the threshold. */
+
+ i__5 = nt;
+ for (k = 1; k <= i__5; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L30: */
+ }
+ nrun += nt;
+
+/* Skip the remaining tests if this is not the first */
+/* block size or if M .ne. N. Skip the solve tests if */
+/* the matrix is singular. */
+
+ if (inb > 1 || m != n) {
+ goto L90;
+ }
+ if (trfcon) {
+ goto L70;
+ }
+
+ i__5 = *nns;
+ for (irhs = 1; irhs <= i__5; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+
+ for (itran = 1; itran <= 3; ++itran) {
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (
+ ftnlen)6);
+ clarhs_(path, xtype, " ", trans, &n, &n, &kl, &ku,
+ &nrhs, &a[1], &lda, &xact[1], &lda, &b[1]
+, &lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
+ lda);
+ s_copy(srnamc_1.srnamt, "CGETRS", (ftnlen)32, (
+ ftnlen)6);
+ cgetrs_(trans, &n, &nrhs, &afac[1], &lda, &iwork[
+ 1], &x[1], &lda, &info);
+
+/* Check error code from CGETRS. */
+
+ if (info != 0) {
+ alaerh_(path, "CGETRS", &info, &c__0, trans, &
+ n, &n, &c_n1, &c_n1, &nrhs, &imat, &
+ nfail, &nerrs, nout);
+ }
+
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1],
+ &lda);
+ cget02_(trans, &n, &n, &nrhs, &a[1], &lda, &x[1],
+ &lda, &work[1], &lda, &rwork[1], &result[
+ 2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the */
+/* solution. */
+
+ s_copy(srnamc_1.srnamt, "CGERFS", (ftnlen)32, (
+ ftnlen)6);
+ cgerfs_(trans, &n, &nrhs, &a[1], &lda, &afac[1], &
+ lda, &iwork[1], &b[1], &lda, &x[1], &lda,
+ &rwork[1], &rwork[nrhs + 1], &work[1], &
+ rwork[(nrhs << 1) + 1], &info);
+
+/* Check error code from CGERFS. */
+
+ if (info != 0) {
+ alaerh_(path, "CGERFS", &info, &c__0, trans, &
+ n, &n, &c_n1, &c_n1, &nrhs, &imat, &
+ nfail, &nerrs, nout);
+ }
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[4]);
+ cget07_(trans, &n, &nrhs, &a[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &c_true, &rwork[nrhs + 1], &result[5]);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___46.ciunit = *nout;
+ s_wsfe(&io___46);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L40: */
+ }
+ nrun += 5;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+L70:
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ anorm = anormo;
+ rcondc = rcondo;
+ *(unsigned char *)norm = 'O';
+ } else {
+ anorm = anormi;
+ rcondc = rcondi;
+ *(unsigned char *)norm = 'I';
+ }
+ s_copy(srnamc_1.srnamt, "CGECON", (ftnlen)32, (ftnlen)
+ 6);
+ cgecon_(norm, &n, &afac[1], &lda, &anorm, &rcond, &
+ work[1], &rwork[1], &info);
+
+/* Check error code from CGECON. */
+
+ if (info != 0) {
+ alaerh_(path, "CGECON", &info, &c__0, norm, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+/* This line is needed on a Sun SPARCstation. */
+
+ dummy = rcond;
+
+ result[7] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___50.ciunit = *nout;
+ s_wsfe(&io___50);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L80: */
+ }
+L90:
+ ;
+ }
+L100:
+ ;
+ }
+
+/* L110: */
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CCHKGE */
+
+} /* cchkge_ */
diff --git a/TESTING/LIN/cchkgt.c b/TESTING/LIN/cchkgt.c
new file mode 100644
index 0000000..d4f7aea
--- /dev/null
+++ b/TESTING/LIN/cchkgt.c
@@ -0,0 +1,664 @@
+/* cchkgt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__7 = 7;
+static real c_b63 = 1.f;
+static real c_b64 = 0.f;
+
+/* Subroutine */ int cchkgt_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, real *thresh, logical *tsterr, complex *
+ a, complex *af, complex *b, complex *x, complex *xact, complex *work,
+ real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 0,0,0,1 };
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(12x,\002N =\002,i5,\002,\002,10x,\002 type"
+ " \002,i2,\002, test(\002,i2,\002) = \002,g12.5)";
+ static char fmt_9997[] = "(\002 NORM ='\002,a1,\002', N =\002,i5,\002"
+ ",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) = \002,g12."
+ "5)";
+ static char fmt_9998[] = "(\002 TRANS='\002,a1,\002', N =\002,i5,\002, N"
+ "RHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) = \002,g"
+ "12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, m, n;
+ complex z__[3];
+ integer in, kl, ku, ix, lda;
+ real cond;
+ integer mode, koff, imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char norm[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), cget04_(
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ real *, real *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int cgtt01_(integer *, complex *, complex *,
+ complex *, complex *, complex *, complex *, complex *, integer *,
+ complex *, integer *, real *, real *), cgtt02_(char *, integer *,
+ integer *, complex *, complex *, complex *, complex *, integer *,
+ complex *, integer *, real *, real *);
+ real rcond;
+ extern /* Subroutine */ int cgtt05_(char *, integer *, integer *, complex
+ *, complex *, complex *, complex *, integer *, complex *, integer
+ *, complex *, integer *, real *, real *, real *);
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ real anorm;
+ integer itran;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ char trans[1];
+ integer izero, nerrs;
+ logical zerot;
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *), cerrge_(char *, integer *);
+ real rcondc;
+ extern doublereal clangt_(char *, integer *, complex *, complex *,
+ complex *);
+ extern /* Subroutine */ int clagtm_(char *, integer *, integer *, real *,
+ complex *, complex *, complex *, complex *, integer *, real *,
+ complex *, integer *), clacpy_(char *, integer *, integer
+ *, complex *, integer *, complex *, integer *), csscal_(
+ integer *, real *, complex *, integer *), cgtcon_(char *, integer
+ *, complex *, complex *, complex *, complex *, integer *, real *,
+ real *, complex *, integer *);
+ real rcondi;
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ real rcondo;
+ extern /* Subroutine */ int clarnv_(integer *, integer *, integer *,
+ complex *), clatms_(integer *, integer *, char *, integer *, char
+ *, real *, integer *, real *, real *, integer *, integer *, char *
+, complex *, integer *, complex *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int cgtrfs_(char *, integer *, integer *, complex
+ *, complex *, complex *, complex *, complex *, complex *, complex
+ *, integer *, complex *, integer *, complex *, integer *, real *,
+ real *, complex *, real *, integer *), cgttrf_(integer *,
+ complex *, complex *, complex *, complex *, integer *, integer *);
+ logical trfcon;
+ extern doublereal scasum_(integer *, complex *, integer *);
+ extern /* Subroutine */ int cgttrs_(char *, integer *, integer *, complex
+ *, complex *, complex *, complex *, integer *, complex *, integer
+ *, integer *);
+ real result[7];
+
+ /* Fortran I/O blocks */
+ static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKGT tests CGTTRF, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*4) */
+
+/* AF (workspace) COMPLEX array, dimension (NMAX*4) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX)+2*NSMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --af;
+ --a;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "GT", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrge_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+/* Computing MAX */
+ i__2 = n - 1;
+ m = max(i__2,0);
+ lda = max(1,n);
+ nimat = 12;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L100;
+ }
+
+/* Set up parameters with CLATB4. */
+
+ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cond, dist);
+
+ zerot = imat >= 8 && imat <= 10;
+ if (imat <= 6) {
+
+/* Types 1-6: generate matrices of known condition number. */
+
+/* Computing MAX */
+ i__3 = 2 - ku, i__4 = 3 - max(1,n);
+ koff = max(i__3,i__4);
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
+ &anorm, &kl, &ku, "Z", &af[koff], &c__3, &work[1], &
+ info);
+
+/* Check the error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, " ", &n, &n, &kl, &
+ ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L100;
+ }
+ izero = 0;
+
+ if (n > 1) {
+ i__3 = n - 1;
+ ccopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
+ i__3 = n - 1;
+ ccopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
+ }
+ ccopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
+ } else {
+
+/* Types 7-12: generate tridiagonal matrices with */
+/* unknown condition numbers. */
+
+ if (! zerot || ! dotype[7]) {
+
+/* Generate a matrix with elements whose real and */
+/* imaginary parts are from [-1,1]. */
+
+ i__3 = n + (m << 1);
+ clarnv_(&c__2, iseed, &i__3, &a[1]);
+ if (anorm != 1.f) {
+ i__3 = n + (m << 1);
+ csscal_(&i__3, &anorm, &a[1], &c__1);
+ }
+ } else if (izero > 0) {
+
+/* Reuse the last matrix by copying back the zeroed out */
+/* elements. */
+
+ if (izero == 1) {
+ i__3 = n;
+ a[i__3].r = z__[1].r, a[i__3].i = z__[1].i;
+ if (n > 1) {
+ a[1].r = z__[2].r, a[1].i = z__[2].i;
+ }
+ } else if (izero == n) {
+ i__3 = n * 3 - 2;
+ a[i__3].r = z__[0].r, a[i__3].i = z__[0].i;
+ i__3 = (n << 1) - 1;
+ a[i__3].r = z__[1].r, a[i__3].i = z__[1].i;
+ } else {
+ i__3 = (n << 1) - 2 + izero;
+ a[i__3].r = z__[0].r, a[i__3].i = z__[0].i;
+ i__3 = n - 1 + izero;
+ a[i__3].r = z__[1].r, a[i__3].i = z__[1].i;
+ i__3 = izero;
+ a[i__3].r = z__[2].r, a[i__3].i = z__[2].i;
+ }
+ }
+
+/* If IMAT > 7, set one column of the matrix to 0. */
+
+ if (! zerot) {
+ izero = 0;
+ } else if (imat == 8) {
+ izero = 1;
+ i__3 = n;
+ z__[1].r = a[i__3].r, z__[1].i = a[i__3].i;
+ i__3 = n;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ if (n > 1) {
+ z__[2].r = a[1].r, z__[2].i = a[1].i;
+ a[1].r = 0.f, a[1].i = 0.f;
+ }
+ } else if (imat == 9) {
+ izero = n;
+ i__3 = n * 3 - 2;
+ z__[0].r = a[i__3].r, z__[0].i = a[i__3].i;
+ i__3 = (n << 1) - 1;
+ z__[1].r = a[i__3].r, z__[1].i = a[i__3].i;
+ i__3 = n * 3 - 2;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ i__3 = (n << 1) - 1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ } else {
+ izero = (n + 1) / 2;
+ i__3 = n - 1;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = (n << 1) - 2 + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ i__4 = n - 1 + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ i__4 = i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L20: */
+ }
+ i__3 = n * 3 - 2;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ i__3 = (n << 1) - 1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ }
+ }
+
+/* + TEST 1 */
+/* Factor A as L*U and compute the ratio */
+/* norm(L*U - A) / (n * norm(A) * EPS ) */
+
+ i__3 = n + (m << 1);
+ ccopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
+ s_copy(srnamc_1.srnamt, "CGTTRF", (ftnlen)32, (ftnlen)6);
+ cgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (m << 1)
+ + 1], &iwork[1], &info);
+
+/* Check error code from CGTTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "CGTTRF", &info, &izero, " ", &n, &n, &c__1, &
+ c__1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+ trfcon = info != 0;
+
+ cgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &af[m + 1], &
+ af[n + m + 1], &af[n + (m << 1) + 1], &iwork[1], &work[1],
+ &lda, &rwork[1], result);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+ for (itran = 1; itran <= 2; ++itran) {
+ *(unsigned char *)trans = *(unsigned char *)&transs[itran - 1]
+ ;
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ } else {
+ *(unsigned char *)norm = 'I';
+ }
+ anorm = clangt_(norm, &n, &a[1], &a[m + 1], &a[n + m + 1]);
+
+ if (! trfcon) {
+
+/* Use CGTTRS to solve for one column at a time of */
+/* inv(A), computing the maximum column sum as we go. */
+
+ ainvnm = 0.f;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__5 = j;
+ x[i__5].r = 0.f, x[i__5].i = 0.f;
+/* L30: */
+ }
+ i__4 = i__;
+ x[i__4].r = 1.f, x[i__4].i = 0.f;
+ cgttrs_(trans, &n, &c__1, &af[1], &af[m + 1], &af[n +
+ m + 1], &af[n + (m << 1) + 1], &iwork[1], &x[
+ 1], &lda, &info);
+/* Computing MAX */
+ r__1 = ainvnm, r__2 = scasum_(&n, &x[1], &c__1);
+ ainvnm = dmax(r__1,r__2);
+/* L40: */
+ }
+
+/* Compute RCONDC = 1 / (norm(A) * norm(inv(A)) */
+
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondc = 1.f;
+ } else {
+ rcondc = 1.f / anorm / ainvnm;
+ }
+ if (itran == 1) {
+ rcondo = rcondc;
+ } else {
+ rcondi = rcondc;
+ }
+ } else {
+ rcondc = 0.f;
+ }
+
+/* + TEST 7 */
+/* Estimate the reciprocal of the condition number of the */
+/* matrix. */
+
+ s_copy(srnamc_1.srnamt, "CGTCON", (ftnlen)32, (ftnlen)6);
+ cgtcon_(norm, &n, &af[1], &af[m + 1], &af[n + m + 1], &af[n +
+ (m << 1) + 1], &iwork[1], &anorm, &rcond, &work[1], &
+ info);
+
+/* Check error code from CGTCON. */
+
+ if (info != 0) {
+ alaerh_(path, "CGTCON", &info, &c__0, norm, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+ result[6] = sget06_(&rcond, &rcondc);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L50: */
+ }
+
+/* Skip the remaining tests if the matrix is singular. */
+
+ if (trfcon) {
+ goto L100;
+ }
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* Generate NRHS random solution vectors. */
+
+ ix = 1;
+ i__4 = nrhs;
+ for (j = 1; j <= i__4; ++j) {
+ clarnv_(&c__2, iseed, &n, &xact[ix]);
+ ix += lda;
+/* L60: */
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+ *(unsigned char *)trans = *(unsigned char *)&transs[itran
+ - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Set the right hand side. */
+
+ clagtm_(trans, &n, &nrhs, &c_b63, &a[1], &a[m + 1], &a[n
+ + m + 1], &xact[1], &lda, &c_b64, &b[1], &lda);
+
+/* + TEST 2 */
+/* Solve op(A) * X = B and compute the residual. */
+
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+ s_copy(srnamc_1.srnamt, "CGTTRS", (ftnlen)32, (ftnlen)6);
+ cgttrs_(trans, &n, &nrhs, &af[1], &af[m + 1], &af[n + m +
+ 1], &af[n + (m << 1) + 1], &iwork[1], &x[1], &lda,
+ &info);
+
+/* Check error code from CGTTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "CGTTRS", &info, &c__0, trans, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
+ cgtt02_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
+ &x[1], &lda, &work[1], &lda, &rwork[1], &result[
+ 1]);
+
+/* + TEST 3 */
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[2]);
+
+/* + TESTS 4, 5, and 6 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "CGTRFS", (ftnlen)32, (ftnlen)6);
+ cgtrfs_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
+ &af[1], &af[m + 1], &af[n + m + 1], &af[n + (m <<
+ 1) + 1], &iwork[1], &b[1], &lda, &x[1], &lda, &
+ rwork[1], &rwork[nrhs + 1], &work[1], &rwork[(
+ nrhs << 1) + 1], &info);
+
+/* Check error code from CGTRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "CGTRFS", &info, &c__0, trans, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[3]);
+ cgtt05_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
+ &b[1], &lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &rwork[nrhs + 1], &result[4]);
+
+/* Print information about the tests that did not pass the */
+/* threshold. */
+
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L70: */
+ }
+ nrun += 5;
+/* L80: */
+ }
+/* L90: */
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CCHKGT */
+
+} /* cchkgt_ */
diff --git a/TESTING/LIN/cchkhe.c b/TESTING/LIN/cchkhe.c
new file mode 100644
index 0000000..c07d1e0
--- /dev/null
+++ b/TESTING/LIN/cchkhe.c
@@ -0,0 +1,682 @@
+/* cchkhe.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__8 = 8;
+
+/* Subroutine */ int cchkhe_(logical *dotype, integer *nn, integer *nval,
+ integer *nnb, integer *nbval, integer *nns, integer *nsval, real *
+ thresh, logical *tsterr, integer *nmax, complex *a, complex *afac,
+ complex *ainv, complex *b, complex *x, complex *xact, complex *work,
+ real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
+ "=\002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
+ "12.5)";
+ static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002"
+ ",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
+ ;
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, nb, in, kl, ku, nt, lda, inb, ioff, mode,
+ imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), chet01_(
+ char *, integer *, complex *, integer *, complex *, integer *,
+ integer *, complex *, integer *, real *, real *), cget04_(
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ real *, real *);
+ integer nfail, iseed[4];
+ real rcond;
+ extern /* Subroutine */ int cpot02_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, complex *, integer *, real *,
+ real *);
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int cpot03_(char *, integer *, complex *, integer
+ *, complex *, integer *, complex *, integer *, real *, real *,
+ real *), cpot05_(char *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, real *, real *, real *);
+ real anorm;
+ integer iuplo, izero, nerrs, lwork;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+);
+ extern doublereal clanhe_(char *, char *, integer *, complex *, integer *,
+ real *);
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *), claipd_(integer *, complex *, integer *, integer *),
+ checon_(char *, integer *, complex *, integer *, integer *, real *
+, real *, complex *, integer *);
+ real rcondc;
+ extern /* Subroutine */ int cerrhe_(char *, integer *), cherfs_(
+ char *, integer *, integer *, complex *, integer *, complex *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ real *, real *, complex *, real *, integer *), chetrf_(
+ char *, integer *, complex *, integer *, integer *, complex *,
+ integer *, integer *), clacpy_(char *, integer *, integer
+ *, complex *, integer *, complex *, integer *), clarhs_(
+ char *, char *, char *, char *, integer *, integer *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, integer *, integer *), chetri_(char *, integer *, complex *, integer *,
+ integer *, complex *, integer *), alasum_(char *, integer
+ *, integer *, integer *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, complex *, integer *, complex *, integer *), chetrs_(char *, integer *, integer *, complex *,
+ integer *, integer *, complex *, integer *, integer *);
+ logical trfcon;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *);
+ real result[8];
+
+ /* Fortran I/O blocks */
+ static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKHE tests CHETRF, -TRI, -TRS, -RFS, and -CON. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "HE", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrhe_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 10;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ izero = 0;
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L170;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L170;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Set up parameters with CLATB4 and generate a test matrix */
+/* with CLATMS. */
+
+ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
+ &info);
+
+/* Check error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L160;
+ }
+
+/* For types 3-6, zero one or more rows and columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * lda;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ ioff = 0;
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+/* L60: */
+ }
+ ioff += lda;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+/* L80: */
+ }
+ ioff += lda;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ i__3 = lda + 1;
+ claipd_(&n, &a[1], &i__3, &c__0);
+
+/* Do for each value of NB in NBVAL */
+
+ i__3 = *nnb;
+ for (inb = 1; inb <= i__3; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the L*D*L' or U*D*U' factorization of the */
+/* matrix. */
+
+ clacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ lwork = max(2,nb) * lda;
+ s_copy(srnamc_1.srnamt, "CHETRF", (ftnlen)32, (ftnlen)6);
+ chetrf_(uplo, &n, &afac[1], &lda, &iwork[1], &ainv[1], &
+ lwork, &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from CHETRF. */
+
+ if (info != k) {
+ alaerh_(path, "CHETRF", &info, &k, uplo, &n, &n, &
+ c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
+ }
+ if (info != 0) {
+ trfcon = TRUE_;
+ } else {
+ trfcon = FALSE_;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ chet01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &iwork[1],
+ &ainv[1], &lda, &rwork[1], result);
+ nt = 1;
+
+/* + TEST 2 */
+/* Form the inverse and compute the residual. */
+
+ if (inb == 1 && ! trfcon) {
+ clacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
+ s_copy(srnamc_1.srnamt, "CHETRI", (ftnlen)32, (ftnlen)
+ 6);
+ chetri_(uplo, &n, &ainv[1], &lda, &iwork[1], &work[1],
+ &info);
+
+/* Check error code from CHETRI. */
+
+ if (info != 0) {
+ alaerh_(path, "CHETRI", &info, &c_n1, uplo, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ cpot03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &work[
+ 1], &lda, &rwork[1], &rcondc, &result[1]);
+ nt = 2;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+
+/* Skip the other tests if this is not the first block */
+/* size. */
+
+ if (inb > 1) {
+ goto L150;
+ }
+
+/* Do only the condition estimate if INFO is not 0. */
+
+ if (trfcon) {
+ rcondc = 0.f;
+ goto L140;
+ }
+
+ i__4 = *nns;
+ for (irhs = 1; irhs <= i__4; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ clarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "CHETRS", (ftnlen)32, (ftnlen)
+ 6);
+ chetrs_(uplo, &n, &nrhs, &afac[1], &lda, &iwork[1], &
+ x[1], &lda, &info);
+
+/* Check error code from CHETRS. */
+
+ if (info != 0) {
+ alaerh_(path, "CHETRS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &
+ lda);
+ cpot02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
+ work[1], &lda, &rwork[1], &result[2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "CHERFS", (ftnlen)32, (ftnlen)
+ 6);
+ cherfs_(uplo, &n, &nrhs, &a[1], &lda, &afac[1], &lda,
+ &iwork[1], &b[1], &lda, &x[1], &lda, &rwork[1]
+, &rwork[nrhs + 1], &work[1], &rwork[(nrhs <<
+ 1) + 1], &info);
+
+/* Check error code from CHERFS. */
+
+ if (info != 0) {
+ alaerh_(path, "CHERFS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[4]);
+ cpot05_(uplo, &n, &nrhs, &a[1], &lda, &b[1], &lda, &x[
+ 1], &lda, &xact[1], &lda, &rwork[1], &rwork[
+ nrhs + 1], &result[5]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L120: */
+ }
+ nrun += 5;
+/* L130: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+L140:
+ anorm = clanhe_("1", uplo, &n, &a[1], &lda, &rwork[1]);
+ s_copy(srnamc_1.srnamt, "CHECON", (ftnlen)32, (ftnlen)6);
+ checon_(uplo, &n, &afac[1], &lda, &iwork[1], &anorm, &
+ rcond, &work[1], &info);
+
+/* Check error code from CHECON. */
+
+ if (info != 0) {
+ alaerh_(path, "CHECON", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ result[7] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L150:
+ ;
+ }
+L160:
+ ;
+ }
+L170:
+ ;
+ }
+/* L180: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CCHKHE */
+
+} /* cchkhe_ */
diff --git a/TESTING/LIN/cchkhp.c b/TESTING/LIN/cchkhp.c
new file mode 100644
index 0000000..31e15ae
--- /dev/null
+++ b/TESTING/LIN/cchkhp.c
@@ -0,0 +1,651 @@
+/* cchkhp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c__8 = 8;
+
+/* Subroutine */ int cchkhp_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, real *thresh, logical *tsterr, integer *
+ nmax, complex *a, complex *afac, complex *ainv, complex *b, complex *
+ x, complex *xact, complex *work, real *rwork, integer *iwork, integer
+ *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
+ "12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, in, kl, ku, nt, lda, npp, ioff, mode, imat,
+ info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), cget04_(
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ real *, real *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int chpt01_(char *, integer *, complex *, complex
+ *, integer *, complex *, integer *, real *, real *);
+ extern logical lsame_(char *, char *);
+ real rcond;
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int cppt02_(char *, integer *, integer *, complex
+ *, complex *, integer *, complex *, integer *, real *, real *), cppt03_(char *, integer *, complex *, complex *, complex
+ *, integer *, real *, real *, real *);
+ real anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), cppt05_(char *, integer *, integer *,
+ complex *, complex *, integer *, complex *, integer *, complex *,
+ integer *, real *, real *, real *);
+ integer iuplo, izero, nerrs;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *), claipd_(integer *, complex *, integer *, integer
+ *);
+ extern doublereal clanhp_(char *, char *, integer *, complex *, real *);
+ real rcondc;
+ extern /* Subroutine */ int chpcon_(char *, integer *, complex *, integer
+ *, real *, real *, complex *, integer *);
+ char packit[1];
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), clarhs_(char *, char
+ *, char *, char *, integer *, integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, integer *, integer *),
+ alasum_(char *, integer *, integer *, integer *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int chprfs_(char *, integer *, integer *, complex
+ *, complex *, integer *, complex *, integer *, complex *, integer
+ *, real *, real *, complex *, real *, integer *), chptrf_(
+ char *, integer *, complex *, integer *, integer *),
+ clatms_(integer *, integer *, char *, integer *, char *, real *,
+ integer *, real *, real *, integer *, integer *, char *, complex *
+, integer *, complex *, integer *),
+ chptri_(char *, integer *, complex *, integer *, complex *,
+ integer *);
+ logical trfcon;
+ extern /* Subroutine */ int chptrs_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, integer *), cerrsy_(
+ char *, integer *);
+ real result[8];
+
+ /* Fortran I/O blocks */
+ static cilist io___38 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKHP tests CHPTRF, -TRI, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AFAC (workspace) COMPLEX array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AINV (workspace) COMPLEX array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(2,NSMAX)) */
+
+/* RWORK (workspace) REAL array, */
+/* dimension (NMAX+2*NSMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "HP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrsy_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 10;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ izero = 0;
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L160;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L160;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ if (lsame_(uplo, "U")) {
+ *(unsigned char *)packit = 'C';
+ } else {
+ *(unsigned char *)packit = 'R';
+ }
+
+/* Set up parameters with CLATB4 and generate a test matrix */
+/* with CLATMS. */
+
+ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
+ 1], &info);
+
+/* Check error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L150;
+ }
+
+/* For types 3-6, zero one or more rows and columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * izero / 2;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff += i__;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff = ioff + n - i__;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ ioff = 0;
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+/* L60: */
+ }
+ ioff += j;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+/* L80: */
+ }
+ ioff = ioff + n - j;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ if (iuplo == 1) {
+ claipd_(&n, &a[1], &c__2, &c__1);
+ } else {
+ claipd_(&n, &a[1], &n, &c_n1);
+ }
+
+/* Compute the L*D*L' or U*D*U' factorization of the matrix. */
+
+ npp = n * (n + 1) / 2;
+ ccopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ s_copy(srnamc_1.srnamt, "CHPTRF", (ftnlen)32, (ftnlen)6);
+ chptrf_(uplo, &n, &afac[1], &iwork[1], &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from CHPTRF. */
+
+ if (info != k) {
+ alaerh_(path, "CHPTRF", &info, &k, uplo, &n, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+ if (info != 0) {
+ trfcon = TRUE_;
+ } else {
+ trfcon = FALSE_;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ chpt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &ainv[1], &lda,
+ &rwork[1], result);
+ nt = 1;
+
+/* + TEST 2 */
+/* Form the inverse and compute the residual. */
+
+ if (! trfcon) {
+ ccopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
+ s_copy(srnamc_1.srnamt, "CHPTRI", (ftnlen)32, (ftnlen)6);
+ chptri_(uplo, &n, &ainv[1], &iwork[1], &work[1], &info);
+
+/* Check error code from CHPTRI. */
+
+ if (info != 0) {
+ alaerh_(path, "CHPTRI", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ cppt03_(uplo, &n, &a[1], &ainv[1], &work[1], &lda, &rwork[
+ 1], &rcondc, &result[1]);
+ nt = 2;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+
+/* Do only the condition estimate if INFO is not 0. */
+
+ if (trfcon) {
+ rcondc = 0.f;
+ goto L140;
+ }
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (ftnlen)6);
+ clarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &nrhs, &
+ a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
+ info);
+ *(unsigned char *)xtype = 'C';
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "CHPTRS", (ftnlen)32, (ftnlen)6);
+ chptrs_(uplo, &n, &nrhs, &afac[1], &iwork[1], &x[1], &lda,
+ &info);
+
+/* Check error code from CHPTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "CHPTRS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
+ cppt02_(uplo, &n, &nrhs, &a[1], &x[1], &lda, &work[1], &
+ lda, &rwork[1], &result[2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "CHPRFS", (ftnlen)32, (ftnlen)6);
+ chprfs_(uplo, &n, &nrhs, &a[1], &afac[1], &iwork[1], &b[1]
+, &lda, &x[1], &lda, &rwork[1], &rwork[nrhs + 1],
+ &work[1], &rwork[(nrhs << 1) + 1], &info);
+
+/* Check error code from CHPRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "CHPRFS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[4]);
+ cppt05_(uplo, &n, &nrhs, &a[1], &b[1], &lda, &x[1], &lda,
+ &xact[1], &lda, &rwork[1], &rwork[nrhs + 1], &
+ result[5]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L120: */
+ }
+ nrun += 5;
+/* L130: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+L140:
+ anorm = clanhp_("1", uplo, &n, &a[1], &rwork[1]);
+ s_copy(srnamc_1.srnamt, "CHPCON", (ftnlen)32, (ftnlen)6);
+ chpcon_(uplo, &n, &afac[1], &iwork[1], &anorm, &rcond, &work[
+ 1], &info);
+
+/* Check error code from CHPCON. */
+
+ if (info != 0) {
+ alaerh_(path, "CHPCON", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+ result[7] = sget06_(&rcond, &rcondc);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___43.ciunit = *nout;
+ s_wsfe(&io___43);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L150:
+ ;
+ }
+L160:
+ ;
+ }
+/* L170: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CCHKHP */
+
+} /* cchkhp_ */
diff --git a/TESTING/LIN/cchklq.c b/TESTING/LIN/cchklq.c
new file mode 100644
index 0000000..a8baf32
--- /dev/null
+++ b/TESTING/LIN/cchklq.c
@@ -0,0 +1,467 @@
+/* cchklq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int cchklq_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nxval, integer *nrhs, real *thresh, logical *tsterr, integer *nmax,
+ complex *a, complex *af, complex *aq, complex *al, complex *ac,
+ complex *b, complex *x, complex *xact, complex *tau, complex *work,
+ real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
+ "5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
+ "t(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, ik, im, in, kl, nk, ku, nt, nx, lda, inb, mode,
+ imat, info;
+ char path[3];
+ integer kval[4];
+ char dist[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), cget02_(
+ char *, integer *, integer *, integer *, complex *, integer *,
+ complex *, integer *, complex *, integer *, real *, real *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int clqt01_(integer *, integer *, complex *,
+ complex *, complex *, complex *, integer *, complex *, complex *,
+ integer *, real *, real *), clqt02_(integer *, integer *, integer
+ *, complex *, complex *, complex *, complex *, integer *, complex
+ *, complex *, integer *, real *, real *), clqt03_(integer *,
+ integer *, integer *, complex *, complex *, complex *, complex *,
+ integer *, complex *, complex *, integer *, real *, real *);
+ real anorm;
+ integer minmn, nerrs, lwork;
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ extern logical cgennd_(integer *, integer *, complex *, integer *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), clarhs_(char *, char
+ *, char *, char *, integer *, integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, integer *, integer *),
+ cgelqs_(integer *, integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *, complex *, integer *, integer *),
+ alasum_(char *, integer *, integer *, integer *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, complex *, integer *, complex *, integer *), cerrlq_(char *, integer *), xlaenv_(
+ integer *, integer *);
+ real result[8];
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKLQ tests CGELQF, CUNGLQ and CUNMLQ. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AQ (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AL (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* TAU (workspace) COMPLEX array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --tau;
+ --xact;
+ --x;
+ --b;
+ --ac;
+ --al;
+ --aq;
+ --af;
+ --a;
+ --nxval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "LQ", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrlq_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+ lda = *nmax;
+ lwork = *nmax * max(*nmax,*nrhs);
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Do for each value of N in NVAL. */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ minmn = min(m,n);
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L50;
+ }
+
+/* Set up parameters with CLATB4 and generate a test matrix */
+/* with CLATMS. */
+
+ clatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, " ", &m, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L50;
+ }
+
+/* Set some values for K: the first value must be MINMN, */
+/* corresponding to the call of CLQT01; other values are */
+/* used in the calls of CLQT02, and must not exceed MINMN. */
+
+ kval[0] = minmn;
+ kval[1] = 0;
+ kval[2] = 1;
+ kval[3] = minmn / 2;
+ if (minmn == 0) {
+ nk = 1;
+ } else if (minmn == 1) {
+ nk = 2;
+ } else if (minmn <= 3) {
+ nk = 3;
+ } else {
+ nk = 4;
+ }
+
+/* Do for each value of K in KVAL */
+
+ i__3 = nk;
+ for (ik = 1; ik <= i__3; ++ik) {
+ k = kval[ik - 1];
+
+/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ nx = nxval[inb];
+ xlaenv_(&c__3, &nx);
+ for (i__ = 1; i__ <= 8; ++i__) {
+ result[i__ - 1] = 0.f;
+ }
+ nt = 2;
+ if (ik == 1) {
+
+/* Test CGELQF */
+
+ clqt01_(&m, &n, &a[1], &af[1], &aq[1], &al[1], &
+ lda, &tau[1], &work[1], &lwork, &rwork[1],
+ result);
+ if (! cgennd_(&m, &n, &af[1], &lda)) {
+ result[7] = *thresh * 2;
+ }
+ ++nt;
+ } else if (m <= n) {
+
+/* Test CUNGLQ, using factorization */
+/* returned by CLQT01 */
+
+ clqt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &al[1],
+ &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], result);
+ } else {
+ result[0] = 0.f;
+ result[1] = 0.f;
+ }
+ if (m >= k) {
+
+/* Test CUNMLQ, using factorization returned */
+/* by CLQT01 */
+
+ clqt03_(&m, &n, &k, &af[1], &ac[1], &al[1], &aq[1]
+, &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], &result[2]);
+ nt += 4;
+
+/* If M>=N and K=N, call CGELQS to solve a system */
+/* with NRHS right hand sides and compute the */
+/* residual. */
+
+ if (k == m && inb == 1) {
+
+/* Generate a solution and set the right */
+/* hand side. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32,
+ (ftnlen)6);
+ clarhs_(path, "New", "Full", "No transpose", &
+ m, &n, &c__0, &c__0, nrhs, &a[1], &
+ lda, &xact[1], &lda, &b[1], &lda,
+ iseed, &info);
+
+ clacpy_("Full", &m, nrhs, &b[1], &lda, &x[1],
+ &lda);
+ s_copy(srnamc_1.srnamt, "CGELQS", (ftnlen)32,
+ (ftnlen)6);
+ cgelqs_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
+ x[1], &lda, &work[1], &lwork, &info);
+
+/* Check error code from CGELQS. */
+
+ if (info != 0) {
+ alaerh_(path, "CGELQS", &info, &c__0,
+ " ", &m, &n, nrhs, &c_n1, &nb, &
+ imat, &nfail, &nerrs, nout);
+ }
+
+ cget02_("No transpose", &m, &n, nrhs, &a[1], &
+ lda, &x[1], &lda, &b[1], &lda, &rwork[
+ 1], &result[6]);
+ ++nt;
+ } else {
+ result[6] = 0.f;
+ }
+ } else {
+ result[2] = 0.f;
+ result[3] = 0.f;
+ result[4] = 0.f;
+ result[5] = 0.f;
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__5 = nt;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+/* L30: */
+ }
+/* L40: */
+ }
+L50:
+ ;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CCHKLQ */
+
+} /* cchklq_ */
diff --git a/TESTING/LIN/cchkpb.c b/TESTING/LIN/cchkpb.c
new file mode 100644
index 0000000..9fdb688
--- /dev/null
+++ b/TESTING/LIN/cchkpb.c
@@ -0,0 +1,708 @@
+/* cchkpb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static complex c_b50 = {0.f,0.f};
+static complex c_b51 = {1.f,0.f};
+static integer c__7 = 7;
+
+/* Subroutine */ int cchkpb_(logical *dotype, integer *nn, integer *nval,
+ integer *nnb, integer *nbval, integer *nns, integer *nsval, real *
+ thresh, logical *tsterr, integer *nmax, complex *a, complex *afac,
+ complex *ainv, complex *b, complex *x, complex *xact, complex *work,
+ real *rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
+ "=\002,i5,\002, NB=\002,i4,\002, type \002,i2,\002, test \002,i2"
+ ",\002, ratio= \002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
+ "=\002,i5,\002, NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i"
+ "2,\002) = \002,g12.5)";
+ static char fmt_9997[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
+ "=\002,i5,\002,\002,10x,\002 type \002,i2,\002, test(\002,i2,\002"
+ ") = \002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, i1, i2, kd, nb, in, kl, iw, ku, lda, ikd, inb, nkd,
+ ldab, ioff, mode, koff, imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), cget04_(
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ real *, real *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int cpbt01_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, real *, real *),
+ cpbt02_(char *, integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, real *,
+ real *), cpbt05_(char *, integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, real *, real *);
+ integer kdval[4];
+ real rcond;
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ real anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer iuplo, izero, nerrs;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+);
+ extern doublereal clanhb_(char *, char *, integer *, integer *, complex *,
+ integer *, real *), clange_(char *, integer *,
+ integer *, complex *, integer *, real *);
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *), claipd_(integer *, complex *, integer *, integer *),
+ cpbcon_(char *, integer *, integer *, complex *, integer *, real *
+, real *, complex *, real *, integer *);
+ real rcondc;
+ char packit[1];
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), clarhs_(char *, char
+ *, char *, char *, integer *, integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, integer *, integer *),
+ claset_(char *, integer *, integer *, complex *, complex *,
+ complex *, integer *), cpbrfs_(char *, integer *, integer
+ *, integer *, complex *, integer *, complex *, integer *, complex
+ *, integer *, complex *, integer *, real *, real *, complex *,
+ real *, integer *), cpbtrf_(char *, integer *, integer *,
+ complex *, integer *, integer *), alasum_(char *, integer
+ *, integer *, integer *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, complex *, integer *, complex *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int cerrpo_(char *, integer *), cpbtrs_(
+ char *, integer *, integer *, integer *, complex *, integer *,
+ complex *, integer *, integer *), xlaenv_(integer *,
+ integer *);
+ real result[7];
+
+ /* Fortran I/O blocks */
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKPB tests CPBTRF, -TRS, -RFS, and -CON. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* B (workspace) REAL array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "PB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrpo_(path, nout);
+ }
+ infoc_1.infot = 0;
+ kdval[0] = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+
+/* Set limits on the number of loop iterations. */
+
+/* Computing MAX */
+ i__2 = 1, i__3 = min(n,4);
+ nkd = max(i__2,i__3);
+ nimat = 8;
+ if (n == 0) {
+ nimat = 1;
+ }
+
+ kdval[1] = n + (n + 1) / 4;
+ kdval[2] = (n * 3 - 1) / 4;
+ kdval[3] = (n + 1) / 4;
+
+ i__2 = nkd;
+ for (ikd = 1; ikd <= i__2; ++ikd) {
+
+/* Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order */
+/* makes it easier to skip redundant values for small values */
+/* of N. */
+
+ kd = kdval[ikd - 1];
+ ldab = kd + 1;
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ koff = 1;
+ if (iuplo == 1) {
+ *(unsigned char *)uplo = 'U';
+/* Computing MAX */
+ i__3 = 1, i__4 = kd + 2 - n;
+ koff = max(i__3,i__4);
+ *(unsigned char *)packit = 'Q';
+ } else {
+ *(unsigned char *)uplo = 'L';
+ *(unsigned char *)packit = 'B';
+ }
+
+ i__3 = nimat;
+ for (imat = 1; imat <= i__3; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L60;
+ }
+
+/* Skip types 2, 3, or 4 if the matrix size is too small. */
+
+ zerot = imat >= 2 && imat <= 4;
+ if (zerot && n < imat - 1) {
+ goto L60;
+ }
+
+ if (! zerot || ! dotype[1]) {
+
+/* Set up parameters with CLATB4 and generate a test */
+/* matrix with CLATMS. */
+
+ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm,
+ &mode, &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)
+ 6);
+ clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode,
+ &cndnum, &anorm, &kd, &kd, packit, &a[koff],
+ &ldab, &work[1], &info);
+
+/* Check error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, uplo, &n, &
+ n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ goto L60;
+ }
+ } else if (izero > 0) {
+
+/* Use the same matrix for types 3 and 4 as for type */
+/* 2 by copying back the zeroed out column, */
+
+ iw = (lda << 1) + 1;
+ if (iuplo == 1) {
+ ioff = (izero - 1) * ldab + kd + 1;
+ i__4 = izero - i1;
+ ccopy_(&i__4, &work[iw], &c__1, &a[ioff - izero +
+ i1], &c__1);
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ ccopy_(&i__4, &work[iw], &c__1, &a[ioff], &i__5);
+ } else {
+ ioff = (i1 - 1) * ldab + 1;
+ i__4 = izero - i1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ ccopy_(&i__4, &work[iw], &c__1, &a[ioff + izero -
+ i1], &i__5);
+ ioff = (izero - 1) * ldab + 1;
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+ ccopy_(&i__4, &work[iw], &c__1, &a[ioff], &c__1);
+ }
+ }
+
+/* For types 2-4, zero one row and column of the matrix */
+/* to test that INFO is returned correctly. */
+
+ izero = 0;
+ if (zerot) {
+ if (imat == 2) {
+ izero = 1;
+ } else if (imat == 3) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+/* Save the zeroed out row and column in WORK(*,3) */
+
+ iw = lda << 1;
+/* Computing MIN */
+ i__5 = (kd << 1) + 1;
+ i__4 = min(i__5,n);
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = iw + i__;
+ work[i__5].r = 0.f, work[i__5].i = 0.f;
+/* L20: */
+ }
+ ++iw;
+/* Computing MAX */
+ i__4 = izero - kd;
+ i1 = max(i__4,1);
+/* Computing MIN */
+ i__4 = izero + kd;
+ i2 = min(i__4,n);
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * ldab + kd + 1;
+ i__4 = izero - i1;
+ cswap_(&i__4, &a[ioff - izero + i1], &c__1, &work[
+ iw], &c__1);
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ cswap_(&i__4, &a[ioff], &i__5, &work[iw], &c__1);
+ } else {
+ ioff = (i1 - 1) * ldab + 1;
+ i__4 = izero - i1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ cswap_(&i__4, &a[ioff + izero - i1], &i__5, &work[
+ iw], &c__1);
+ ioff = (izero - 1) * ldab + 1;
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+ cswap_(&i__4, &a[ioff], &c__1, &work[iw], &c__1);
+ }
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ if (iuplo == 1) {
+ claipd_(&n, &a[kd + 1], &ldab, &c__0);
+ } else {
+ claipd_(&n, &a[1], &ldab, &c__0);
+ }
+
+/* Do for each value of NB in NBVAL */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the L*L' or U'*U factorization of the band */
+/* matrix. */
+
+ i__5 = kd + 1;
+ clacpy_("Full", &i__5, &n, &a[1], &ldab, &afac[1], &
+ ldab);
+ s_copy(srnamc_1.srnamt, "CPBTRF", (ftnlen)32, (ftnlen)
+ 6);
+ cpbtrf_(uplo, &n, &kd, &afac[1], &ldab, &info);
+
+/* Check error code from CPBTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "CPBTRF", &info, &izero, uplo, &n, &
+ n, &kd, &kd, &nb, &imat, &nfail, &nerrs,
+ nout);
+ goto L50;
+ }
+
+/* Skip the tests if INFO is not 0. */
+
+ if (info != 0) {
+ goto L50;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ i__5 = kd + 1;
+ clacpy_("Full", &i__5, &n, &afac[1], &ldab, &ainv[1],
+ &ldab);
+ cpbt01_(uplo, &n, &kd, &a[1], &ldab, &ainv[1], &ldab,
+ &rwork[1], result);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+/* Only do other tests if this is the first blocksize. */
+
+ if (inb > 1) {
+ goto L50;
+ }
+
+/* Form the inverse of A so we can get a good estimate */
+/* of RCONDC = 1/(norm(A) * norm(inv(A))). */
+
+ claset_("Full", &n, &n, &c_b50, &c_b51, &ainv[1], &
+ lda);
+ s_copy(srnamc_1.srnamt, "CPBTRS", (ftnlen)32, (ftnlen)
+ 6);
+ cpbtrs_(uplo, &n, &kd, &n, &afac[1], &ldab, &ainv[1],
+ &lda, &info);
+
+/* Compute RCONDC = 1/(norm(A) * norm(inv(A))). */
+
+ anorm = clanhb_("1", uplo, &n, &kd, &a[1], &ldab, &
+ rwork[1]);
+ ainvnm = clange_("1", &n, &n, &ainv[1], &lda, &rwork[
+ 1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondc = 1.f;
+ } else {
+ rcondc = 1.f / anorm / ainvnm;
+ }
+
+ i__5 = *nns;
+ for (irhs = 1; irhs <= i__5; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 2 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (
+ ftnlen)6);
+ clarhs_(path, xtype, uplo, " ", &n, &n, &kd, &kd,
+ &nrhs, &a[1], &ldab, &xact[1], &lda, &b[1]
+, &lda, iseed, &info);
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "CPBTRS", (ftnlen)32, (
+ ftnlen)6);
+ cpbtrs_(uplo, &n, &kd, &nrhs, &afac[1], &ldab, &x[
+ 1], &lda, &info);
+
+/* Check error code from CPBTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "CPBTRS", &info, &c__0, uplo, &
+ n, &n, &kd, &kd, &nrhs, &imat, &nfail,
+ &nerrs, nout);
+ }
+
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1],
+ &lda);
+ cpbt02_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &x[1],
+ &lda, &work[1], &lda, &rwork[1], &result[
+ 1]);
+
+/* + TEST 3 */
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* + TESTS 4, 5, and 6 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "CPBRFS", (ftnlen)32, (
+ ftnlen)6);
+ cpbrfs_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &afac[
+ 1], &ldab, &b[1], &lda, &x[1], &lda, &
+ rwork[1], &rwork[nrhs + 1], &work[1], &
+ rwork[(nrhs << 1) + 1], &info);
+
+/* Check error code from CPBRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "CPBRFS", &info, &c__0, uplo, &
+ n, &n, &kd, &kd, &nrhs, &imat, &nfail,
+ &nerrs, nout);
+ }
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+ cpbt05_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &b[1],
+ &lda, &x[1], &lda, &xact[1], &lda, &
+ rwork[1], &rwork[nrhs + 1], &result[4]);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___46.ciunit = *nout;
+ s_wsfe(&io___46);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L30: */
+ }
+ nrun += 5;
+/* L40: */
+ }
+
+/* + TEST 7 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ s_copy(srnamc_1.srnamt, "CPBCON", (ftnlen)32, (ftnlen)
+ 6);
+ cpbcon_(uplo, &n, &kd, &afac[1], &ldab, &anorm, &
+ rcond, &work[1], &rwork[1], &info);
+
+/* Check error code from CPBCON. */
+
+ if (info != 0) {
+ alaerh_(path, "CPBCON", &info, &c__0, uplo, &n, &
+ n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ result[6] = sget06_(&rcond, &rcondc);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___48.ciunit = *nout;
+ s_wsfe(&io___48);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L50:
+ ;
+ }
+L60:
+ ;
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CCHKPB */
+
+} /* cchkpb_ */
diff --git a/TESTING/LIN/cchkpo.c b/TESTING/LIN/cchkpo.c
new file mode 100644
index 0000000..2df09af
--- /dev/null
+++ b/TESTING/LIN/cchkpo.c
@@ -0,0 +1,604 @@
+/* cchkpo.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__8 = 8;
+
+/* Subroutine */ int cchkpo_(logical *dotype, integer *nn, integer *nval,
+ integer *nnb, integer *nbval, integer *nns, integer *nsval, real *
+ thresh, logical *tsterr, integer *nmax, complex *a, complex *afac,
+ complex *ainv, complex *b, complex *x, complex *xact, complex *work,
+ real *rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
+ "=\002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
+ "12.5)";
+ static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002"
+ ",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
+ ;
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, nb, in, kl, ku, lda, inb, ioff, mode, imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), cget04_(
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ real *, real *);
+ integer nfail, iseed[4];
+ real rcond;
+ extern /* Subroutine */ int cpot01_(char *, integer *, complex *, integer
+ *, complex *, integer *, real *, real *), cpot02_(char *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, real *);
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int cpot03_(char *, integer *, complex *, integer
+ *, complex *, integer *, complex *, integer *, real *, real *,
+ real *), cpot05_(char *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, real *, real *, real *);
+ real anorm;
+ integer iuplo, izero, nerrs;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+);
+ extern doublereal clanhe_(char *, char *, integer *, complex *, integer *,
+ real *);
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *), claipd_(integer *, complex *, integer *, integer *);
+ real rcondc;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), clarhs_(char *, char
+ *, char *, char *, integer *, integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, integer *, integer *),
+ cpocon_(char *, integer *, complex *, integer *, real *, real *,
+ complex *, real *, integer *), alasum_(char *, integer *,
+ integer *, integer *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, complex *, integer *, complex *, integer *), cerrpo_(char *, integer *), cporfs_(char
+ *, integer *, integer *, complex *, integer *, complex *, integer
+ *, complex *, integer *, complex *, integer *, real *, real *,
+ complex *, real *, integer *), cpotrf_(char *, integer *,
+ complex *, integer *, integer *), xlaenv_(integer *,
+ integer *), cpotri_(char *, integer *, complex *, integer *,
+ integer *), cpotrs_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, integer *);
+ real result[8];
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKPO tests CPOTRF, -TRI, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (NMAX+2*NSMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "PO", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrpo_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ izero = 0;
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L110;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot && n < imat - 2) {
+ goto L110;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Set up parameters with CLATB4 and generate a test matrix */
+/* with CLATMS. */
+
+ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
+ &info);
+
+/* Check error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L100;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ i__3 = lda + 1;
+ claipd_(&n, &a[1], &i__3, &c__0);
+
+/* Do for each value of NB in NBVAL */
+
+ i__3 = *nnb;
+ for (inb = 1; inb <= i__3; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the L*L' or U'*U factorization of the matrix. */
+
+ clacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ s_copy(srnamc_1.srnamt, "CPOTRF", (ftnlen)32, (ftnlen)6);
+ cpotrf_(uplo, &n, &afac[1], &lda, &info);
+
+/* Check error code from CPOTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "CPOTRF", &info, &izero, uplo, &n, &n, &
+ c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+
+/* Skip the tests if INFO is not 0. */
+
+ if (info != 0) {
+ goto L90;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ clacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
+ cpot01_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &rwork[1],
+ result);
+
+/* + TEST 2 */
+/* Form the inverse and compute the residual. */
+
+ clacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
+ s_copy(srnamc_1.srnamt, "CPOTRI", (ftnlen)32, (ftnlen)6);
+ cpotri_(uplo, &n, &ainv[1], &lda, &info);
+
+/* Check error code from CPOTRI. */
+
+ if (info != 0) {
+ alaerh_(path, "CPOTRI", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ cpot03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &work[1], &
+ lda, &rwork[1], &rcondc, &result[1]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 1; k <= 2; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += 2;
+
+/* Skip the rest of the tests unless this is the first */
+/* blocksize. */
+
+ if (inb != 1) {
+ goto L90;
+ }
+
+ i__4 = *nns;
+ for (irhs = 1; irhs <= i__4; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B . */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ clarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "CPOTRS", (ftnlen)32, (ftnlen)
+ 6);
+ cpotrs_(uplo, &n, &nrhs, &afac[1], &lda, &x[1], &lda,
+ &info);
+
+/* Check error code from CPOTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "CPOTRS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &
+ lda);
+ cpot02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
+ work[1], &lda, &rwork[1], &result[2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "CPORFS", (ftnlen)32, (ftnlen)
+ 6);
+ cporfs_(uplo, &n, &nrhs, &a[1], &lda, &afac[1], &lda,
+ &b[1], &lda, &x[1], &lda, &rwork[1], &rwork[
+ nrhs + 1], &work[1], &rwork[(nrhs << 1) + 1],
+ &info);
+
+/* Check error code from CPORFS. */
+
+ if (info != 0) {
+ alaerh_(path, "CPORFS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[4]);
+ cpot05_(uplo, &n, &nrhs, &a[1], &lda, &b[1], &lda, &x[
+ 1], &lda, &xact[1], &lda, &rwork[1], &rwork[
+ nrhs + 1], &result[5]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L70: */
+ }
+ nrun += 5;
+/* L80: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ anorm = clanhe_("1", uplo, &n, &a[1], &lda, &rwork[1]);
+ s_copy(srnamc_1.srnamt, "CPOCON", (ftnlen)32, (ftnlen)6);
+ cpocon_(uplo, &n, &afac[1], &lda, &anorm, &rcond, &work[1]
+, &rwork[1], &info);
+
+/* Check error code from CPOCON. */
+
+ if (info != 0) {
+ alaerh_(path, "CPOCON", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ result[7] = sget06_(&rcond, &rcondc);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L90:
+ ;
+ }
+L100:
+ ;
+ }
+L110:
+ ;
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CCHKPO */
+
+} /* cchkpo_ */
diff --git a/TESTING/LIN/cchkpp.c b/TESTING/LIN/cchkpp.c
new file mode 100644
index 0000000..9266905
--- /dev/null
+++ b/TESTING/LIN/cchkpp.c
@@ -0,0 +1,569 @@
+/* cchkpp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c__8 = 8;
+
+/* Subroutine */ int cchkpp_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, real *thresh, logical *tsterr, integer *
+ nmax, complex *a, complex *afac, complex *ainv, complex *b, complex *
+ x, complex *xact, complex *work, real *rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char packs[1*2] = "C" "R";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
+ "12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, in, kl, ku, lda, npp, ioff, mode, imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), cget04_(
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ real *, real *);
+ integer nfail, iseed[4];
+ real rcond;
+ extern /* Subroutine */ int cppt01_(char *, integer *, complex *, complex
+ *, real *, real *);
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int cppt02_(char *, integer *, integer *, complex
+ *, complex *, integer *, complex *, integer *, real *, real *), cppt03_(char *, integer *, complex *, complex *, complex
+ *, integer *, real *, real *, real *);
+ real anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), cppt05_(char *, integer *, integer *,
+ complex *, complex *, integer *, complex *, integer *, complex *,
+ integer *, real *, real *, real *);
+ integer iuplo, izero, nerrs;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *), claipd_(integer *, complex *, integer *, integer
+ *);
+ extern doublereal clanhp_(char *, char *, integer *, complex *, real *);
+ real rcondc;
+ char packit[1];
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), clarhs_(char *, char
+ *, char *, char *, integer *, integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, integer *, integer *),
+ alasum_(char *, integer *, integer *, integer *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, complex *, integer *, complex *, integer *), cppcon_(char *, integer *, complex *, real *,
+ real *, complex *, real *, integer *), cerrpo_(char *,
+ integer *), cpprfs_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *, complex *, integer *, real *,
+ real *, complex *, real *, integer *), cpptrf_(char *,
+ integer *, complex *, integer *), cpptri_(char *, integer
+ *, complex *, integer *), cpptrs_(char *, integer *,
+ integer *, complex *, complex *, integer *, integer *);
+ real result[8];
+
+ /* Fortran I/O blocks */
+ static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKPP tests CPPTRF, -TRI, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AFAC (workspace) COMPLEX array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AINV (workspace) COMPLEX array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "PP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrpo_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L100;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot && n < imat - 2) {
+ goto L100;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ *(unsigned char *)packit = *(unsigned char *)&packs[iuplo - 1]
+ ;
+
+/* Set up parameters with CLATB4 and generate a test matrix */
+/* with CLATMS. */
+
+ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
+ 1], &info);
+
+/* Check error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * izero / 2;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff += i__;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff = ioff + n - i__;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ if (iuplo == 1) {
+ claipd_(&n, &a[1], &c__2, &c__1);
+ } else {
+ claipd_(&n, &a[1], &n, &c_n1);
+ }
+
+/* Compute the L*L' or U'*U factorization of the matrix. */
+
+ npp = n * (n + 1) / 2;
+ ccopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ s_copy(srnamc_1.srnamt, "CPPTRF", (ftnlen)32, (ftnlen)6);
+ cpptrf_(uplo, &n, &afac[1], &info);
+
+/* Check error code from CPPTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "CPPTRF", &info, &izero, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+
+/* Skip the tests if INFO is not 0. */
+
+ if (info != 0) {
+ goto L90;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ ccopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
+ cppt01_(uplo, &n, &a[1], &ainv[1], &rwork[1], result);
+
+/* + TEST 2 */
+/* Form the inverse and compute the residual. */
+
+ ccopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
+ s_copy(srnamc_1.srnamt, "CPPTRI", (ftnlen)32, (ftnlen)6);
+ cpptri_(uplo, &n, &ainv[1], &info);
+
+/* Check error code from CPPTRI. */
+
+ if (info != 0) {
+ alaerh_(path, "CPPTRI", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+ cppt03_(uplo, &n, &a[1], &ainv[1], &work[1], &lda, &rwork[1],
+ &rcondc, &result[1]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 1; k <= 2; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += 2;
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (ftnlen)6);
+ clarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &nrhs, &
+ a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
+ info);
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "CPPTRS", (ftnlen)32, (ftnlen)6);
+ cpptrs_(uplo, &n, &nrhs, &afac[1], &x[1], &lda, &info);
+
+/* Check error code from CPPTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "CPPTRS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
+ cppt02_(uplo, &n, &nrhs, &a[1], &x[1], &lda, &work[1], &
+ lda, &rwork[1], &result[2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "CPPRFS", (ftnlen)32, (ftnlen)6);
+ cpprfs_(uplo, &n, &nrhs, &a[1], &afac[1], &b[1], &lda, &x[
+ 1], &lda, &rwork[1], &rwork[nrhs + 1], &work[1], &
+ rwork[(nrhs << 1) + 1], &info);
+
+/* Check error code from CPPRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "CPPRFS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[4]);
+ cppt05_(uplo, &n, &nrhs, &a[1], &b[1], &lda, &x[1], &lda,
+ &xact[1], &lda, &rwork[1], &rwork[nrhs + 1], &
+ result[5]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L70: */
+ }
+ nrun += 5;
+/* L80: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ anorm = clanhp_("1", uplo, &n, &a[1], &rwork[1]);
+ s_copy(srnamc_1.srnamt, "CPPCON", (ftnlen)32, (ftnlen)6);
+ cppcon_(uplo, &n, &afac[1], &anorm, &rcond, &work[1], &rwork[
+ 1], &info);
+
+/* Check error code from CPPCON. */
+
+ if (info != 0) {
+ alaerh_(path, "CPPCON", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+ result[7] = sget06_(&rcond, &rcondc);
+
+/* Print the test ratio if greater than or equal to THRESH. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+L90:
+ ;
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CCHKPP */
+
+} /* cchkpp_ */
diff --git a/TESTING/LIN/cchkps.c b/TESTING/LIN/cchkps.c
new file mode 100644
index 0000000..baea196
--- /dev/null
+++ b/TESTING/LIN/cchkps.c
@@ -0,0 +1,374 @@
+/* cchkps.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+
+/* Subroutine */ int cchkps_(logical *dotype, integer *nn, integer *nval,
+ integer *nnb, integer *nbval, integer *nrank, integer *rankval, real *
+ thresh, logical *tsterr, integer *nmax, complex *a, complex *afac,
+ complex *perm, integer *piv, complex *work, real *rwork, integer *
+ nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "RANK =\002,i3,\002, Diff =\002,i5,\002, NB =\002,i4,\002, type"
+ " \002,i2,\002, Ratio =\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer i_sceiling(real *), s_wsfe(cilist *), do_fio(integer *, char *,
+ ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer rankdiff, comprank, i__, n, nb, in, kl, ku, lda, inb;
+ real tol;
+ integer mode, imat, info, rank;
+ char path[3], dist[1], uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4], irank, nimat;
+ extern /* Subroutine */ int cpst01_(char *, integer *, complex *, integer
+ *, complex *, integer *, complex *, integer *, integer *, real *,
+ real *, integer *);
+ real anorm;
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int clatb5_(char *, integer *, integer *, char *,
+ integer *, integer *, real *, integer *, real *, char *), alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *), clacpy_(char *, integer *, integer *, complex *, integer
+ *, complex *, integer *), alasum_(char *, integer *,
+ integer *, integer *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int clatmt_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, integer *, char *, complex *, integer *, complex *, integer *), cerrps_(char *, integer *),
+ xlaenv_(integer *, integer *), cpstrf_(char *, integer *, complex
+ *, integer *, integer *, integer *, real *, real *, integer *);
+ real result;
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKPS tests CPSTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the block size NB. */
+
+/* NRANK (input) INTEGER */
+/* The number of values of RANK contained in the vector RANKVAL. */
+
+/* RANKVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the block size NB. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* PERM (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* PIV (workspace) INTEGER array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension (NMAX*3) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --piv;
+ --perm;
+ --afac;
+ --a;
+ --rankval;
+ --nbval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex Precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "PS", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L100: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrps_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ izero = 0;
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L140;
+ }
+
+/* Do for each value of RANK in RANKVAL */
+
+ i__3 = *nrank;
+ for (irank = 1; irank <= i__3; ++irank) {
+
+/* Only repeat test 3 to 5 for different ranks */
+/* Other tests use full rank */
+
+ if ((imat < 3 || imat > 5) && irank > 1) {
+ goto L130;
+ }
+
+ r__1 = n * (real) rankval[irank] / 100.f;
+ rank = i_sceiling(&r__1);
+
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+
+/* Set up parameters with CLATB5 and generate a test matrix */
+/* with CLATMT. */
+
+ clatb5_(path, &imat, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "CLATMT", (ftnlen)32, (ftnlen)6);
+ clatmt_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &rank, &kl, &ku, uplo, &a[1], &
+ lda, &work[1], &info);
+
+/* Check error code from CLATMT. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMT", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ goto L120;
+ }
+
+/* Do for each value of NB in NBVAL */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the pivoted L*L' or U'*U factorization */
+/* of the matrix. */
+
+ clacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ s_copy(srnamc_1.srnamt, "CPSTRF", (ftnlen)32, (ftnlen)
+ 6);
+
+/* Use default tolerance */
+
+ tol = -1.f;
+ cpstrf_(uplo, &n, &afac[1], &lda, &piv[1], &comprank,
+ &tol, &rwork[1], &info);
+
+/* Check error code from CPSTRF. */
+
+ if (info < izero || info != izero && rank == n ||
+ info <= izero && rank < n) {
+ alaerh_(path, "CPSTRF", &info, &izero, uplo, &n, &
+ n, &c_n1, &c_n1, &nb, &imat, &nfail, &
+ nerrs, nout);
+ goto L110;
+ }
+
+/* Skip the test if INFO is not 0. */
+
+ if (info != 0) {
+ goto L110;
+ }
+
+/* Reconstruct matrix from factors and compute residual. */
+
+/* PERM holds permuted L*L^T or U^T*U */
+
+ cpst01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &perm[
+ 1], &lda, &piv[1], &rwork[1], &result, &
+ comprank);
+
+/* Print information about the tests that did not pass */
+/* the threshold or where computed rank was not RANK. */
+
+ if (n == 0) {
+ comprank = 0;
+ }
+ rankdiff = rank - comprank;
+ if (result >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&rank, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&rankdiff, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result, (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L110:
+ ;
+ }
+
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+L140:
+ ;
+ }
+/* L150: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CCHKPS */
+
+} /* cchkps_ */
diff --git a/TESTING/LIN/cchkpt.c b/TESTING/LIN/cchkpt.c
new file mode 100644
index 0000000..03bdf1c
--- /dev/null
+++ b/TESTING/LIN/cchkpt.c
@@ -0,0 +1,653 @@
+/* cchkpt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static real c_b48 = 1.f;
+static real c_b49 = 0.f;
+static integer c__7 = 7;
+
+/* Subroutine */ int cchkpt_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, real *thresh, logical *tsterr, complex *
+ a, real *d__, complex *e, complex *b, complex *x, complex *xact,
+ complex *work, real *rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 0,0,0,1 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 N =\002,i5,\002, type \002,i2,\002, te"
+ "st \002,i2,\002, ratio = \002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NRHS =\002,i3,\002, type \002,i2,\002, test \002,i2,\002, ratio "
+ "= \002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double c_abs(complex *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n;
+ complex z__[3];
+ integer ia, in, kl, ku, ix, lda;
+ real cond;
+ integer mode;
+ real dmax__;
+ integer imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), cget04_(
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ real *, real *);
+ integer nfail, iseed[4];
+ real rcond;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int cptt01_(integer *, real *, complex *, real *,
+ complex *, complex *, real *);
+ real anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), cptt02_(char *, integer *, integer *, real
+ *, complex *, complex *, integer *, complex *, integer *, real *), cptt05_(integer *, integer *, real *, complex *, complex
+ *, integer *, complex *, integer *, complex *, integer *, real *,
+ real *, real *);
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ logical zerot;
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ real rcondc;
+ extern doublereal clanht_(char *, integer *, real *, complex *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), clacpy_(char *, integer *, integer *, complex *, integer *,
+ complex *, integer *), claptm_(char *, integer *, integer
+ *, real *, real *, complex *, complex *, integer *, real *,
+ complex *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *), clarnv_(integer *, integer *, integer *,
+ complex *), cerrgt_(char *, integer *), clatms_(integer *,
+ integer *, char *, integer *, char *, real *, integer *, real *,
+ real *, integer *, integer *, char *, complex *, integer *,
+ complex *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int cptcon_(integer *, real *, complex *, real *,
+ real *, real *, integer *);
+ extern doublereal scasum_(integer *, complex *, integer *);
+ extern /* Subroutine */ int cptrfs_(char *, integer *, integer *, real *,
+ complex *, real *, complex *, complex *, integer *, complex *,
+ integer *, real *, real *, complex *, real *, integer *),
+ cpttrf_(integer *, real *, complex *, integer *), slarnv_(integer
+ *, integer *, integer *, real *);
+ real result[7];
+ extern /* Subroutine */ int cpttrs_(char *, integer *, integer *, real *,
+ complex *, complex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKPT tests CPTTRF, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*2) */
+
+/* D (workspace) REAL array, dimension (NMAX*2) */
+
+/* E (workspace) COMPLEX array, dimension (NMAX*2) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --e;
+ --d__;
+ --a;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "PT", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrgt_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+ lda = max(1,n);
+ nimat = 12;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (n > 0 && ! dotype[imat]) {
+ goto L110;
+ }
+
+/* Set up parameters with CLATB4. */
+
+ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cond, dist);
+
+ zerot = imat >= 8 && imat <= 10;
+ if (imat <= 6) {
+
+/* Type 1-6: generate a Hermitian tridiagonal matrix of */
+/* known condition number in lower triangular band storage. */
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
+ &anorm, &kl, &ku, "B", &a[1], &c__2, &work[1], &info);
+
+/* Check the error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, " ", &n, &n, &kl, &
+ ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L110;
+ }
+ izero = 0;
+
+/* Copy the matrix to D and E. */
+
+ ia = 1;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ia;
+ d__[i__] = a[i__4].r;
+ i__4 = i__;
+ i__5 = ia + 1;
+ e[i__4].r = a[i__5].r, e[i__4].i = a[i__5].i;
+ ia += 2;
+/* L20: */
+ }
+ if (n > 0) {
+ i__3 = ia;
+ d__[n] = a[i__3].r;
+ }
+ } else {
+
+/* Type 7-12: generate a diagonally dominant matrix with */
+/* unknown condition number in the vectors D and E. */
+
+ if (! zerot || ! dotype[7]) {
+
+/* Let E be complex, D real, with values from [-1,1]. */
+
+ slarnv_(&c__2, iseed, &n, &d__[1]);
+ i__3 = n - 1;
+ clarnv_(&c__2, iseed, &i__3, &e[1]);
+
+/* Make the tridiagonal matrix diagonally dominant. */
+
+ if (n == 1) {
+ d__[1] = dabs(d__[1]);
+ } else {
+ d__[1] = dabs(d__[1]) + c_abs(&e[1]);
+ d__[n] = (r__1 = d__[n], dabs(r__1)) + c_abs(&e[n - 1]
+ );
+ i__3 = n - 1;
+ for (i__ = 2; i__ <= i__3; ++i__) {
+ d__[i__] = (r__1 = d__[i__], dabs(r__1)) + c_abs(&
+ e[i__]) + c_abs(&e[i__ - 1]);
+/* L30: */
+ }
+ }
+
+/* Scale D and E so the maximum element is ANORM. */
+
+ ix = isamax_(&n, &d__[1], &c__1);
+ dmax__ = d__[ix];
+ r__1 = anorm / dmax__;
+ sscal_(&n, &r__1, &d__[1], &c__1);
+ i__3 = n - 1;
+ r__1 = anorm / dmax__;
+ csscal_(&i__3, &r__1, &e[1], &c__1);
+
+ } else if (izero > 0) {
+
+/* Reuse the last matrix by copying back the zeroed out */
+/* elements. */
+
+ if (izero == 1) {
+ d__[1] = z__[1].r;
+ if (n > 1) {
+ e[1].r = z__[2].r, e[1].i = z__[2].i;
+ }
+ } else if (izero == n) {
+ i__3 = n - 1;
+ e[i__3].r = z__[0].r, e[i__3].i = z__[0].i;
+ i__3 = n;
+ d__[i__3] = z__[1].r;
+ } else {
+ i__3 = izero - 1;
+ e[i__3].r = z__[0].r, e[i__3].i = z__[0].i;
+ i__3 = izero;
+ d__[i__3] = z__[1].r;
+ i__3 = izero;
+ e[i__3].r = z__[2].r, e[i__3].i = z__[2].i;
+ }
+ }
+
+/* For types 8-10, set one row and column of the matrix to */
+/* zero. */
+
+ izero = 0;
+ if (imat == 8) {
+ izero = 1;
+ z__[1].r = d__[1], z__[1].i = 0.f;
+ d__[1] = 0.f;
+ if (n > 1) {
+ z__[2].r = e[1].r, z__[2].i = e[1].i;
+ e[1].r = 0.f, e[1].i = 0.f;
+ }
+ } else if (imat == 9) {
+ izero = n;
+ if (n > 1) {
+ i__3 = n - 1;
+ z__[0].r = e[i__3].r, z__[0].i = e[i__3].i;
+ i__3 = n - 1;
+ e[i__3].r = 0.f, e[i__3].i = 0.f;
+ }
+ i__3 = n;
+ z__[1].r = d__[i__3], z__[1].i = 0.f;
+ d__[n] = 0.f;
+ } else if (imat == 10) {
+ izero = (n + 1) / 2;
+ if (izero > 1) {
+ i__3 = izero - 1;
+ z__[0].r = e[i__3].r, z__[0].i = e[i__3].i;
+ i__3 = izero;
+ z__[2].r = e[i__3].r, z__[2].i = e[i__3].i;
+ i__3 = izero - 1;
+ e[i__3].r = 0.f, e[i__3].i = 0.f;
+ i__3 = izero;
+ e[i__3].r = 0.f, e[i__3].i = 0.f;
+ }
+ i__3 = izero;
+ z__[1].r = d__[i__3], z__[1].i = 0.f;
+ d__[izero] = 0.f;
+ }
+ }
+
+ scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
+ if (n > 1) {
+ i__3 = n - 1;
+ ccopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
+ }
+
+/* + TEST 1 */
+/* Factor A as L*D*L' and compute the ratio */
+/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
+
+ cpttrf_(&n, &d__[n + 1], &e[n + 1], &info);
+
+/* Check error code from CPTTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "CPTTRF", &info, &izero, " ", &n, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L110;
+ }
+
+ if (info > 0) {
+ rcondc = 0.f;
+ goto L100;
+ }
+
+ cptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &work[1],
+ result);
+
+/* Print the test ratio if greater than or equal to THRESH. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+/* Compute RCONDC = 1 / (norm(A) * norm(inv(A)) */
+
+/* Compute norm(A). */
+
+ anorm = clanht_("1", &n, &d__[1], &e[1]);
+
+/* Use CPTTRS to solve for one column at a time of inv(A), */
+/* computing the maximum column sum as we go. */
+
+ ainvnm = 0.f;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__5 = j;
+ x[i__5].r = 0.f, x[i__5].i = 0.f;
+/* L40: */
+ }
+ i__4 = i__;
+ x[i__4].r = 1.f, x[i__4].i = 0.f;
+ cpttrs_("Lower", &n, &c__1, &d__[n + 1], &e[n + 1], &x[1], &
+ lda, &info);
+/* Computing MAX */
+ r__1 = ainvnm, r__2 = scasum_(&n, &x[1], &c__1);
+ ainvnm = dmax(r__1,r__2);
+/* L50: */
+ }
+/* Computing MAX */
+ r__1 = 1.f, r__2 = anorm * ainvnm;
+ rcondc = 1.f / dmax(r__1,r__2);
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* Generate NRHS random solution vectors. */
+
+ ix = 1;
+ i__4 = nrhs;
+ for (j = 1; j <= i__4; ++j) {
+ clarnv_(&c__2, iseed, &n, &xact[ix]);
+ ix += lda;
+/* L60: */
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L'. */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+
+/* Set the right hand side. */
+
+ claptm_(uplo, &n, &nrhs, &c_b48, &d__[1], &e[1], &xact[1],
+ &lda, &c_b49, &b[1], &lda);
+
+/* + TEST 2 */
+/* Solve A*x = b and compute the residual. */
+
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+ cpttrs_(uplo, &n, &nrhs, &d__[n + 1], &e[n + 1], &x[1], &
+ lda, &info);
+
+/* Check error code from CPTTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "CPTTRS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
+ cptt02_(uplo, &n, &nrhs, &d__[1], &e[1], &x[1], &lda, &
+ work[1], &lda, &result[1]);
+
+/* + TEST 3 */
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[2]);
+
+/* + TESTS 4, 5, and 6 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "CPTRFS", (ftnlen)32, (ftnlen)6);
+ cptrfs_(uplo, &n, &nrhs, &d__[1], &e[1], &d__[n + 1], &e[
+ n + 1], &b[1], &lda, &x[1], &lda, &rwork[1], &
+ rwork[nrhs + 1], &work[1], &rwork[(nrhs << 1) + 1]
+, &info);
+
+/* Check error code from CPTRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "CPTRFS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[3]);
+ cptt05_(&n, &nrhs, &d__[1], &e[1], &b[1], &lda, &x[1], &
+ lda, &xact[1], &lda, &rwork[1], &rwork[nrhs + 1],
+ &result[4]);
+
+/* Print information about the tests that did not pass the */
+/* threshold. */
+
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L70: */
+ }
+ nrun += 5;
+
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* + TEST 7 */
+/* Estimate the reciprocal of the condition number of the */
+/* matrix. */
+
+L100:
+ s_copy(srnamc_1.srnamt, "CPTCON", (ftnlen)32, (ftnlen)6);
+ cptcon_(&n, &d__[n + 1], &e[n + 1], &anorm, &rcond, &rwork[1], &
+ info);
+
+/* Check error code from CPTCON. */
+
+ if (info != 0) {
+ alaerh_(path, "CPTCON", &info, &c__0, " ", &n, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+ result[6] = sget06_(&rcond, &rcondc);
+
+/* Print the test ratio if greater than or equal to THRESH. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L110:
+ ;
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CCHKPT */
+
+} /* cchkpt_ */
diff --git a/TESTING/LIN/cchkq3.c b/TESTING/LIN/cchkq3.c
new file mode 100644
index 0000000..cf5c3d4
--- /dev/null
+++ b/TESTING/LIN/cchkq3.c
@@ -0,0 +1,395 @@
+/* cchkq3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static real c_b15 = 1.f;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int cchkq3_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nxval, real *thresh, complex *a, complex *copya, real *s, real *copys,
+ complex *tau, complex *work, real *rwork, integer *iwork, integer *
+ nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002 M =\002,i5,\002, N =\002,i5,\002, N"
+ "B =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, im, in, lw, nx, lda, inb;
+ real eps;
+ integer mode, info;
+ char path[3];
+ integer ilow, nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer ihigh, nfail, iseed[4], imode;
+ extern doublereal cqpt01_(integer *, integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *),
+ cqrt11_(integer *, integer *, complex *, integer *, complex *,
+ complex *, integer *), cqrt12_(integer *, integer *, complex *,
+ integer *, real *, complex *, integer *, real *);
+ integer mnmin;
+ extern /* Subroutine */ int icopy_(integer *, integer *, integer *,
+ integer *, integer *);
+ integer istep, nerrs, lwork;
+ extern /* Subroutine */ int cgeqp3_(integer *, integer *, complex *,
+ integer *, integer *, complex *, complex *, integer *, real *,
+ integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), alasum_(char *, integer *, integer *, integer *, integer
+ *), clatms_(integer *, integer *, char *, integer *, char
+ *, real *, integer *, real *, real *, integer *, integer *, char *
+, complex *, integer *, complex *, integer *), slaord_(char *, integer *, real *, integer *),
+ xlaenv_(integer *, integer *);
+ real result[3];
+
+ /* Fortran I/O blocks */
+ static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKQ3 tests CGEQP3. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* THRESH (input) 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. */
+
+/* A (workspace) COMPLEX array, dimension (MMAX*NMAX) */
+/* where MMAX is the maximum value of M in MVAL and NMAX is the */
+/* maximum value of N in NVAL. */
+
+/* COPYA (workspace) COMPLEX array, dimension (MMAX*NMAX) */
+
+/* S (workspace) REAL array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* COPYS (workspace) REAL array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* TAU (workspace) COMPLEX array, dimension (MMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (max(M*max(M,N) + 4*min(M,N) + max(M,N))) */
+
+/* RWORK (workspace) REAL array, dimension (4*NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --tau;
+ --copys;
+ --s;
+ --copya;
+ --a;
+ --nxval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "Q3", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = slamch_("Epsilon");
+ infoc_1.infot = 0;
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+
+/* Do for each value of M in MVAL. */
+
+ m = mval[im];
+ lda = max(1,m);
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__3 = 1, i__4 = m * max(m,n) + (mnmin << 2) + max(m,n);
+ lwork = max(i__3,i__4);
+
+ for (imode = 1; imode <= 6; ++imode) {
+ if (! dotype[imode]) {
+ goto L70;
+ }
+
+/* Do for each type of matrix */
+/* 1: zero matrix */
+/* 2: one small singular value */
+/* 3: geometric distribution of singular values */
+/* 4: first n/2 columns fixed */
+/* 5: last n/2 columns fixed */
+/* 6: every second column fixed */
+
+ mode = imode;
+ if (imode > 3) {
+ mode = 1;
+ }
+
+/* Generate test matrix of size m by n using */
+/* singular value distribution indicated by `mode'. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ iwork[i__] = 0;
+/* L20: */
+ }
+ if (imode == 1) {
+ claset_("Full", &m, &n, &c_b1, &c_b1, ©a[1], &lda);
+ i__3 = mnmin;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ copys[i__] = 0.f;
+/* L30: */
+ }
+ } else {
+ r__1 = 1.f / eps;
+ clatms_(&m, &n, "Uniform", iseed, "Nonsymm", ©s[1], &
+ mode, &r__1, &c_b15, &m, &n, "No packing", ©a[
+ 1], &lda, &work[1], &info);
+ if (imode >= 4) {
+ if (imode == 4) {
+ ilow = 1;
+ istep = 1;
+/* Computing MAX */
+ i__3 = 1, i__4 = n / 2;
+ ihigh = max(i__3,i__4);
+ } else if (imode == 5) {
+/* Computing MAX */
+ i__3 = 1, i__4 = n / 2;
+ ilow = max(i__3,i__4);
+ istep = 1;
+ ihigh = n;
+ } else if (imode == 6) {
+ ilow = 1;
+ istep = 2;
+ ihigh = n;
+ }
+ i__3 = ihigh;
+ i__4 = istep;
+ for (i__ = ilow; i__4 < 0 ? i__ >= i__3 : i__ <= i__3;
+ i__ += i__4) {
+ iwork[i__] = 1;
+/* L40: */
+ }
+ }
+ slaord_("Decreasing", &mnmin, ©s[1], &c__1);
+ }
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+
+/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
+
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ nx = nxval[inb];
+ xlaenv_(&c__3, &nx);
+
+/* Save A and its singular values and a copy of */
+/* vector IWORK. */
+
+ clacpy_("All", &m, &n, ©a[1], &lda, &a[1], &lda);
+ icopy_(&n, &iwork[1], &c__1, &iwork[n + 1], &c__1);
+
+/* Workspace needed. */
+
+ lw = nb * (n + 1);
+
+ s_copy(srnamc_1.srnamt, "CGEQP3", (ftnlen)32, (ftnlen)6);
+ cgeqp3_(&m, &n, &a[1], &lda, &iwork[n + 1], &tau[1], &
+ work[1], &lw, &rwork[1], &info);
+
+/* Compute norm(svd(a) - svd(r)) */
+
+ result[0] = cqrt12_(&m, &n, &a[1], &lda, ©s[1], &work[
+ 1], &lwork, &rwork[1]);
+
+/* Compute norm( A*P - Q*R ) */
+
+ result[1] = cqpt01_(&m, &n, &mnmin, ©a[1], &a[1], &
+ lda, &tau[1], &iwork[n + 1], &work[1], &lwork);
+
+/* Compute Q'*Q */
+
+ result[2] = cqrt11_(&m, &mnmin, &a[1], &lda, &tau[1], &
+ work[1], &lwork);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 1; k <= 3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___28.ciunit = *nout;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "CGEQP3", (ftnlen)6);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L50: */
+ }
+ nrun += 3;
+
+/* L60: */
+ }
+L70:
+ ;
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+
+/* End of CCHKQ3 */
+
+ return 0;
+} /* cchkq3_ */
diff --git a/TESTING/LIN/cchkql.c b/TESTING/LIN/cchkql.c
new file mode 100644
index 0000000..5d609a8
--- /dev/null
+++ b/TESTING/LIN/cchkql.c
@@ -0,0 +1,475 @@
+/* cchkql.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int cchkql_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nxval, integer *nrhs, real *thresh, logical *tsterr, integer *nmax,
+ complex *a, complex *af, complex *aq, complex *al, complex *ac,
+ complex *b, complex *x, complex *xact, complex *tau, complex *work,
+ real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
+ "5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
+ "t(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, ik, im, in, kl, nk, ku, nt, nx, lda, inb, mode,
+ imat, info;
+ char path[3];
+ integer kval[4];
+ char dist[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), cget02_(
+ char *, integer *, integer *, integer *, complex *, integer *,
+ complex *, integer *, complex *, integer *, real *, real *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int cqlt01_(integer *, integer *, complex *,
+ complex *, complex *, complex *, integer *, complex *, complex *,
+ integer *, real *, real *), cqlt02_(integer *, integer *, integer
+ *, complex *, complex *, complex *, complex *, integer *, complex
+ *, complex *, integer *, real *, real *), cqlt03_(integer *,
+ integer *, integer *, complex *, complex *, complex *, complex *,
+ integer *, complex *, complex *, integer *, real *, real *);
+ real anorm;
+ integer minmn, nerrs, lwork;
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ extern logical cgennd_(integer *, integer *, complex *, integer *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), clarhs_(char *, char
+ *, char *, char *, integer *, integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, integer *, integer *),
+ cgeqls_(integer *, integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *, complex *, integer *, integer *),
+ alasum_(char *, integer *, integer *, integer *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, complex *, integer *, complex *, integer *), cerrql_(char *, integer *), xlaenv_(
+ integer *, integer *);
+ real result[8];
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKQL tests CGEQLF, CUNGQL and CUNMQL. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AQ (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AL (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* TAU (workspace) COMPLEX array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --tau;
+ --xact;
+ --x;
+ --b;
+ --ac;
+ --al;
+ --aq;
+ --af;
+ --a;
+ --nxval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "QL", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrql_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+ lda = *nmax;
+ lwork = *nmax * max(*nmax,*nrhs);
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Do for each value of N in NVAL. */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ minmn = min(m,n);
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L50;
+ }
+
+/* Set up parameters with CLATB4 and generate a test matrix */
+/* with CLATMS. */
+
+ clatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, " ", &m, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L50;
+ }
+
+/* Set some values for K: the first value must be MINMN, */
+/* corresponding to the call of CQLT01; other values are */
+/* used in the calls of CQLT02, and must not exceed MINMN. */
+
+ kval[0] = minmn;
+ kval[1] = 0;
+ kval[2] = 1;
+ kval[3] = minmn / 2;
+ if (minmn == 0) {
+ nk = 1;
+ } else if (minmn == 1) {
+ nk = 2;
+ } else if (minmn <= 3) {
+ nk = 3;
+ } else {
+ nk = 4;
+ }
+
+/* Do for each value of K in KVAL */
+
+ i__3 = nk;
+ for (ik = 1; ik <= i__3; ++ik) {
+ k = kval[ik - 1];
+
+/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ nx = nxval[inb];
+ xlaenv_(&c__3, &nx);
+ for (i__ = 1; i__ <= 8; ++i__) {
+ result[i__ - 1] = 0.f;
+ }
+ nt = 2;
+ if (ik == 1) {
+
+/* Test CGEQLF */
+
+ cqlt01_(&m, &n, &a[1], &af[1], &aq[1], &al[1], &
+ lda, &tau[1], &work[1], &lwork, &rwork[1],
+ result);
+ if (m >= n) {
+/* Check the lower-left n-by-n corner */
+ if (! cgennd_(&n, &n, &af[m - n + 1], &lda)) {
+ result[7] = *thresh * 2;
+ }
+ } else {
+/* Check the (n-m)th superdiagonal */
+ if (! cgennd_(&m, &m, &af[(n - m) * lda + 1],
+ &lda)) {
+ result[7] = *thresh * 2;
+ }
+ }
+ } else if (m >= n) {
+
+/* Test CUNGQL, using factorization */
+/* returned by CQLT01 */
+
+ cqlt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &al[1],
+ &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], result);
+ } else {
+ result[0] = 0.f;
+ result[1] = 0.f;
+ }
+ if (m >= k) {
+
+/* Test CUNMQL, using factorization returned */
+/* by CQLT01 */
+
+ cqlt03_(&m, &n, &k, &af[1], &ac[1], &al[1], &aq[1]
+, &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], &result[2]);
+ nt += 4;
+
+/* If M>=N and K=N, call CGEQLS to solve a system */
+/* with NRHS right hand sides and compute the */
+/* residual. */
+
+ if (k == n && inb == 1) {
+
+/* Generate a solution and set the right */
+/* hand side. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32,
+ (ftnlen)6);
+ clarhs_(path, "New", "Full", "No transpose", &
+ m, &n, &c__0, &c__0, nrhs, &a[1], &
+ lda, &xact[1], &lda, &b[1], &lda,
+ iseed, &info);
+
+ clacpy_("Full", &m, nrhs, &b[1], &lda, &x[1],
+ &lda);
+ s_copy(srnamc_1.srnamt, "CGEQLS", (ftnlen)32,
+ (ftnlen)6);
+ cgeqls_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
+ x[1], &lda, &work[1], &lwork, &info);
+
+/* Check error code from CGEQLS. */
+
+ if (info != 0) {
+ alaerh_(path, "CGEQLS", &info, &c__0,
+ " ", &m, &n, nrhs, &c_n1, &nb, &
+ imat, &nfail, &nerrs, nout);
+ }
+
+ cget02_("No transpose", &m, &n, nrhs, &a[1], &
+ lda, &x[m - n + 1], &lda, &b[1], &lda,
+ &rwork[1], &result[6]);
+ ++nt;
+ } else {
+ result[6] = 0.f;
+ }
+ } else {
+ result[2] = 0.f;
+ result[3] = 0.f;
+ result[4] = 0.f;
+ result[5] = 0.f;
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__5 = nt;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+/* L30: */
+ }
+/* L40: */
+ }
+L50:
+ ;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CCHKQL */
+
+} /* cchkql_ */
diff --git a/TESTING/LIN/cchkqp.c b/TESTING/LIN/cchkqp.c
new file mode 100644
index 0000000..a54ccff
--- /dev/null
+++ b/TESTING/LIN/cchkqp.c
@@ -0,0 +1,361 @@
+/* cchkqp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static complex c_b11 = {0.f,0.f};
+static real c_b16 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int cchkqp_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, real *thresh, logical *tsterr, complex *a,
+ complex *copya, real *s, real *copys, complex *tau, complex *work,
+ real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, type"
+ " \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, im, in, lda;
+ real eps;
+ integer mode, info;
+ char path[3];
+ integer ilow, nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer ihigh, nfail, iseed[4], imode;
+ extern doublereal cqpt01_(integer *, integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *),
+ cqrt11_(integer *, integer *, complex *, integer *, complex *,
+ complex *, integer *), cqrt12_(integer *, integer *, complex *,
+ integer *, real *, complex *, integer *, real *);
+ integer mnmin, istep, nerrs, lwork;
+ extern /* Subroutine */ int cgeqpf_(integer *, integer *, complex *,
+ integer *, integer *, complex *, complex *, real *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), alasum_(char *, integer *, integer *, integer *, integer
+ *), clatms_(integer *, integer *, char *, integer *, char
+ *, real *, integer *, real *, real *, integer *, integer *, char *
+, complex *, integer *, complex *, integer *), slaord_(char *, integer *, real *, integer *),
+ cerrqp_(char *, integer *);
+ real result[3];
+
+ /* Fortran I/O blocks */
+ static cilist io___24 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKQP tests CGEQPF. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) COMPLEX array, dimension (MMAX*NMAX) */
+/* where MMAX is the maximum value of M in MVAL and NMAX is the */
+/* maximum value of N in NVAL. */
+
+/* COPYA (workspace) COMPLEX array, dimension (MMAX*NMAX) */
+
+/* S (workspace) REAL array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* COPYS (workspace) REAL array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* TAU (workspace) COMPLEX array, dimension (MMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (max(M*max(M,N) + 4*min(M,N) + max(M,N))) */
+
+/* RWORK (workspace) REAL array, dimension (4*NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --tau;
+ --copys;
+ --s;
+ --copya;
+ --a;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "QP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = slamch_("Epsilon");
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrqp_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+
+/* Do for each value of M in MVAL. */
+
+ m = mval[im];
+ lda = max(1,m);
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__3 = 1, i__4 = m * max(m,n) + (mnmin << 2) + max(m,n);
+ lwork = max(i__3,i__4);
+
+ for (imode = 1; imode <= 6; ++imode) {
+ if (! dotype[imode]) {
+ goto L60;
+ }
+
+/* Do for each type of matrix */
+/* 1: zero matrix */
+/* 2: one small singular value */
+/* 3: geometric distribution of singular values */
+/* 4: first n/2 columns fixed */
+/* 5: last n/2 columns fixed */
+/* 6: every second column fixed */
+
+ mode = imode;
+ if (imode > 3) {
+ mode = 1;
+ }
+
+/* Generate test matrix of size m by n using */
+/* singular value distribution indicated by `mode'. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ iwork[i__] = 0;
+/* L20: */
+ }
+ if (imode == 1) {
+ claset_("Full", &m, &n, &c_b11, &c_b11, ©a[1], &lda);
+ i__3 = mnmin;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ copys[i__] = 0.f;
+/* L30: */
+ }
+ } else {
+ r__1 = 1.f / eps;
+ clatms_(&m, &n, "Uniform", iseed, "Nonsymm", ©s[1], &
+ mode, &r__1, &c_b16, &m, &n, "No packing", ©a[
+ 1], &lda, &work[1], &info);
+ if (imode >= 4) {
+ if (imode == 4) {
+ ilow = 1;
+ istep = 1;
+/* Computing MAX */
+ i__3 = 1, i__4 = n / 2;
+ ihigh = max(i__3,i__4);
+ } else if (imode == 5) {
+/* Computing MAX */
+ i__3 = 1, i__4 = n / 2;
+ ilow = max(i__3,i__4);
+ istep = 1;
+ ihigh = n;
+ } else if (imode == 6) {
+ ilow = 1;
+ istep = 2;
+ ihigh = n;
+ }
+ i__3 = ihigh;
+ i__4 = istep;
+ for (i__ = ilow; i__4 < 0 ? i__ >= i__3 : i__ <= i__3;
+ i__ += i__4) {
+ iwork[i__] = 1;
+/* L40: */
+ }
+ }
+ slaord_("Decreasing", &mnmin, ©s[1], &c__1);
+ }
+
+/* Save A and its singular values */
+
+ clacpy_("All", &m, &n, ©a[1], &lda, &a[1], &lda);
+
+/* Compute the QR factorization with pivoting of A */
+
+ s_copy(srnamc_1.srnamt, "CGEQPF", (ftnlen)32, (ftnlen)6);
+ cgeqpf_(&m, &n, &a[1], &lda, &iwork[1], &tau[1], &work[1], &
+ rwork[1], &info);
+
+/* Compute norm(svd(a) - svd(r)) */
+
+ result[0] = cqrt12_(&m, &n, &a[1], &lda, ©s[1], &work[1],
+ &lwork, &rwork[1]);
+
+/* Compute norm( A*P - Q*R ) */
+
+ result[1] = cqpt01_(&m, &n, &mnmin, ©a[1], &a[1], &lda, &
+ tau[1], &iwork[1], &work[1], &lwork);
+
+/* Compute Q'*Q */
+
+ result[2] = cqrt11_(&m, &mnmin, &a[1], &lda, &tau[1], &work[1]
+, &lwork);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 1; k <= 3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___24.ciunit = *nout;
+ s_wsfe(&io___24);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L50: */
+ }
+ nrun += 3;
+L60:
+ ;
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+
+/* End of CCHKQP */
+
+ return 0;
+} /* cchkqp_ */
diff --git a/TESTING/LIN/cchkqr.c b/TESTING/LIN/cchkqr.c
new file mode 100644
index 0000000..5bbb1b4
--- /dev/null
+++ b/TESTING/LIN/cchkqr.c
@@ -0,0 +1,457 @@
+/* cchkqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int cchkqr_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nxval, integer *nrhs, real *thresh, logical *tsterr, integer *nmax,
+ complex *a, complex *af, complex *aq, complex *ar, complex *ac,
+ complex *b, complex *x, complex *xact, complex *tau, complex *work,
+ real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
+ "5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
+ "t(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, ik, im, in, kl, nk, ku, nt, nx, lda, inb, mode,
+ imat, info;
+ char path[3];
+ integer kval[4];
+ char dist[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), cget02_(
+ char *, integer *, integer *, integer *, complex *, integer *,
+ complex *, integer *, complex *, integer *, real *, real *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int cqrt01_(integer *, integer *, complex *,
+ complex *, complex *, complex *, integer *, complex *, complex *,
+ integer *, real *, real *), cqrt02_(integer *, integer *, integer
+ *, complex *, complex *, complex *, complex *, integer *, complex
+ *, complex *, integer *, real *, real *);
+ real anorm;
+ extern /* Subroutine */ int cqrt03_(integer *, integer *, integer *,
+ complex *, complex *, complex *, complex *, integer *, complex *,
+ complex *, integer *, real *, real *);
+ integer minmn, nerrs, lwork;
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ extern logical cgennd_(integer *, integer *, complex *, integer *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), clarhs_(char *, char
+ *, char *, char *, integer *, integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, integer *, integer *),
+ alasum_(char *, integer *, integer *, integer *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int cgeqrs_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, complex *,
+ integer *, integer *), clatms_(integer *, integer *, char *,
+ integer *, char *, real *, integer *, real *, real *, integer *,
+ integer *, char *, complex *, integer *, complex *, integer *), cerrqr_(char *, integer *),
+ xlaenv_(integer *, integer *);
+ real result[8];
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKQR tests CGEQRF, CUNGQR and CUNMQR. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AQ (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AR (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* TAU (workspace) COMPLEX array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Fuinctions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --tau;
+ --xact;
+ --x;
+ --b;
+ --ac;
+ --ar;
+ --aq;
+ --af;
+ --a;
+ --nxval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "QR", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrqr_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+ lda = *nmax;
+ lwork = *nmax * max(*nmax,*nrhs);
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Do for each value of N in NVAL. */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ minmn = min(m,n);
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L50;
+ }
+
+/* Set up parameters with CLATB4 and generate a test matrix */
+/* with CLATMS. */
+
+ clatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, " ", &m, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L50;
+ }
+
+/* Set some values for K: the first value must be MINMN, */
+/* corresponding to the call of CQRT01; other values are */
+/* used in the calls of CQRT02, and must not exceed MINMN. */
+
+ kval[0] = minmn;
+ kval[1] = 0;
+ kval[2] = 1;
+ kval[3] = minmn / 2;
+ if (minmn == 0) {
+ nk = 1;
+ } else if (minmn == 1) {
+ nk = 2;
+ } else if (minmn <= 3) {
+ nk = 3;
+ } else {
+ nk = 4;
+ }
+
+/* Do for each value of K in KVAL */
+
+ i__3 = nk;
+ for (ik = 1; ik <= i__3; ++ik) {
+ k = kval[ik - 1];
+
+/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ nx = nxval[inb];
+ xlaenv_(&c__3, &nx);
+ for (i__ = 1; i__ <= 8; ++i__) {
+ result[i__ - 1] = 0.f;
+ }
+ nt = 2;
+ if (ik == 1) {
+
+/* Test CGEQRF */
+
+ cqrt01_(&m, &n, &a[1], &af[1], &aq[1], &ar[1], &
+ lda, &tau[1], &work[1], &lwork, &rwork[1],
+ result);
+ if (! cgennd_(&m, &n, &af[1], &lda)) {
+ result[7] = *thresh * 2;
+ }
+ ++nt;
+ } else if (m >= n) {
+
+/* Test CUNGQR, using factorization */
+/* returned by CQRT01 */
+
+ cqrt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &ar[1],
+ &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], result);
+ }
+ if (m >= k) {
+
+/* Test CUNMQR, using factorization returned */
+/* by CQRT01 */
+
+ cqrt03_(&m, &n, &k, &af[1], &ac[1], &ar[1], &aq[1]
+, &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], &result[2]);
+ nt += 4;
+
+/* If M>=N and K=N, call CGEQRS to solve a system */
+/* with NRHS right hand sides and compute the */
+/* residual. */
+
+ if (k == n && inb == 1) {
+
+/* Generate a solution and set the right */
+/* hand side. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32,
+ (ftnlen)6);
+ clarhs_(path, "New", "Full", "No transpose", &
+ m, &n, &c__0, &c__0, nrhs, &a[1], &
+ lda, &xact[1], &lda, &b[1], &lda,
+ iseed, &info);
+
+ clacpy_("Full", &m, nrhs, &b[1], &lda, &x[1],
+ &lda);
+ s_copy(srnamc_1.srnamt, "CGEQRS", (ftnlen)32,
+ (ftnlen)6);
+ cgeqrs_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
+ x[1], &lda, &work[1], &lwork, &info);
+
+/* Check error code from CGEQRS. */
+
+ if (info != 0) {
+ alaerh_(path, "CGEQRS", &info, &c__0,
+ " ", &m, &n, nrhs, &c_n1, &nb, &
+ imat, &nfail, &nerrs, nout);
+ }
+
+ cget02_("No transpose", &m, &n, nrhs, &a[1], &
+ lda, &x[1], &lda, &b[1], &lda, &rwork[
+ 1], &result[6]);
+ ++nt;
+ }
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (i__ = 1; i__ <= 8; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+/* L30: */
+ }
+/* L40: */
+ }
+L50:
+ ;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CCHKQR */
+
+} /* cchkqr_ */
diff --git a/TESTING/LIN/cchkrfp.c b/TESTING/LIN/cchkrfp.c
new file mode 100644
index 0000000..d546f3d
--- /dev/null
+++ b/TESTING/LIN/cchkrfp.c
@@ -0,0 +1,478 @@
+/* cchkrfp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__12 = 12;
+static integer c__0 = 0;
+static integer c__50 = 50;
+static integer c__16 = 16;
+static integer c__9 = 9;
+static integer c__4 = 4;
+static integer c__8 = 8;
+static integer c__6 = 6;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Format strings */
+ static char fmt_9994[] = "(/\002 Tests of the COMPLEX LAPACK RFP routine"
+ "s \002,/\002 LAPACK VERSION \002,i1,\002.\002,i1,\002.\002,i1,/"
+ "/\002 The following parameter values will be used:\002)";
+ static char fmt_9996[] = "(\002 !! Invalid input value: \002,a4,\002="
+ "\002,i6,\002; must be >=\002,i6)";
+ static char fmt_9995[] = "(\002 !! Invalid input value: \002,a4,\002="
+ "\002,i6,\002; must be <=\002,i6)";
+ static char fmt_9993[] = "(4x,a4,\002: \002,10i6,/11x,10i6)";
+ static char fmt_9992[] = "(/\002 Routines pass computational tests if te"
+ "st ratio is \002,\002less than\002,f8.2,/)";
+ static char fmt_9999[] = "(/\002 Execution not attempted due to input er"
+ "rors\002)";
+ static char fmt_9991[] = "(\002 Relative machine \002,a,\002 is taken to"
+ " be\002,d16.6)";
+ static char fmt_9998[] = "(/\002 End of tests\002)";
+ static char fmt_9997[] = "(\002 Total time used = \002,f12.2,\002 seco"
+ "nds\002,/)";
+
+ /* System generated locals */
+ integer i__1;
+ real r__1;
+ cllist cl__1;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), e_rsle(void), s_wsfe(cilist *), do_fio(integer *
+ , char *, ftnlen), e_wsfe(void), do_lio(integer *, integer *,
+ char *, ftnlen);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), f_clos(cllist *);
+
+ /* Local variables */
+ complex workafac[2500] /* was [50][50] */, workasav[2500] /*
+ was [50][50] */, workbsav[800] /* was [50][16] */, workainv[
+ 2500] /* was [50][50] */, workxact[800] /* was [50][
+ 16] */;
+ integer i__;
+ real s1, s2;
+ integer nn, vers_patch__, vers_major__, vers_minor__;
+ complex workarfinv[1275];
+ real eps;
+ integer nns, nnt, nval[12];
+ complex c_work_cpot01__[50], c_work_cpot02__[800] /* was [50][16] */,
+ c_work_cpot03__[2500] /* was [50][50] */;
+ real s_work_cpot02__[50], s_work_cpot03__[50];
+ logical fatal;
+ integer nsval[12], ntval[9];
+ complex worka[2500] /* was [50][50] */, workb[800] /* was [50][16] */,
+ workx[800] /* was [50][16] */;
+ real s_work_clanhe__[50];
+ complex c_work_clatms__[150];
+ real s_work_clatms__[50];
+ extern doublereal slamch_(char *), second_(void);
+ extern /* Subroutine */ int ilaver_(integer *, integer *, integer *);
+ real thresh;
+ complex workap[1275];
+ logical tsterr;
+ extern /* Subroutine */ int cdrvrf1_(integer *, integer *, integer *,
+ real *, complex *, integer *, complex *, real *), cdrvrf2_(
+ integer *, integer *, integer *, complex *, integer *, complex *,
+ complex *, complex *), cdrvrf3_(integer *, integer *, integer *,
+ real *, complex *, integer *, complex *, complex *, complex *,
+ real *, complex *, complex *), cdrvrf4_(integer *, integer *,
+ integer *, real *, complex *, complex *, integer *, complex *,
+ complex *, integer *, real *), cerrrfp_(integer *), cdrvrfp_(
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, real *, complex *, complex *, complex *, complex *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ complex *, complex *, complex *, complex *, real *, real *, real *
+, real *);
+ complex workarf[1275];
+
+ /* Fortran I/O blocks */
+ static cilist io___3 = { 0, 5, 0, 0, 0 };
+ static cilist io___7 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___8 = { 0, 5, 0, 0, 0 };
+ static cilist io___10 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___11 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___12 = { 0, 5, 0, 0, 0 };
+ static cilist io___15 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___16 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___17 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___18 = { 0, 5, 0, 0, 0 };
+ static cilist io___20 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___21 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___22 = { 0, 5, 0, 0, 0 };
+ static cilist io___24 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___25 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___26 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___27 = { 0, 5, 0, 0, 0 };
+ static cilist io___29 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___30 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___31 = { 0, 5, 0, 0, 0 };
+ static cilist io___33 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___34 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___35 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___36 = { 0, 5, 0, 0, 0 };
+ static cilist io___38 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___39 = { 0, 5, 0, 0, 0 };
+ static cilist io___41 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___45 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___46 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___47 = { 0, 6, 0, 0, 0 };
+ static cilist io___68 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___69 = { 0, 6, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKRFP is the main test program for the COMPLEX linear equation */
+/* routines with RFP storage format */
+
+
+/* Internal Parameters */
+/* =================== */
+
+/* MAXIN INTEGER */
+/* The number of different values that can be used for each of */
+/* M, N, or NB */
+
+/* MAXRHS INTEGER */
+/* The maximum number of right hand sides */
+
+/* NTYPES INTEGER */
+
+/* NMAX INTEGER */
+/* The maximum allowable value for N. */
+
+/* NIN INTEGER */
+/* The unit number for input */
+
+/* NOUT INTEGER */
+/* The unit number for output */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ s1 = second_();
+ fatal = FALSE_;
+
+/* Read a dummy line. */
+
+ s_rsle(&io___3);
+ e_rsle();
+
+/* Report LAPACK version tag (e.g. LAPACK-3.2.0) */
+
+ ilaver_(&vers_major__, &vers_minor__, &vers_patch__);
+ s_wsfe(&io___7);
+ do_fio(&c__1, (char *)&vers_major__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_minor__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_patch__, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+/* Read the values of N */
+
+ s_rsle(&io___8);
+ do_lio(&c__3, &c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nn < 1) {
+ s_wsfe(&io___10);
+ do_fio(&c__1, " NN ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ } else if (nn > 12) {
+ s_wsfe(&io___11);
+ do_fio(&c__1, " NN ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___12);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nval[i__ - 1] < 0) {
+ s_wsfe(&io___15);
+ do_fio(&c__1, " M ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nval[i__ - 1] > 50) {
+ s_wsfe(&io___16);
+ do_fio(&c__1, " M ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__50, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L10: */
+ }
+ if (nn > 0) {
+ s_wsfe(&io___17);
+ do_fio(&c__1, "N ", (ftnlen)4);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of NRHS */
+
+ s_rsle(&io___18);
+ do_lio(&c__3, &c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nns < 1) {
+ s_wsfe(&io___20);
+ do_fio(&c__1, " NNS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nns = 0;
+ fatal = TRUE_;
+ } else if (nns > 12) {
+ s_wsfe(&io___21);
+ do_fio(&c__1, " NNS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nns = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___22);
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nsval[i__ - 1] < 0) {
+ s_wsfe(&io___24);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nsval[i__ - 1] > 16) {
+ s_wsfe(&io___25);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__16, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L30: */
+ }
+ if (nns > 0) {
+ s_wsfe(&io___26);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the matrix types */
+
+ s_rsle(&io___27);
+ do_lio(&c__3, &c__1, (char *)&nnt, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nnt < 1) {
+ s_wsfe(&io___29);
+ do_fio(&c__1, " NMA", (ftnlen)4);
+ do_fio(&c__1, (char *)&nnt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nnt = 0;
+ fatal = TRUE_;
+ } else if (nnt > 9) {
+ s_wsfe(&io___30);
+ do_fio(&c__1, " NMA", (ftnlen)4);
+ do_fio(&c__1, (char *)&nnt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nnt = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___31);
+ i__1 = nnt;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = nnt;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (ntval[i__ - 1] < 0) {
+ s_wsfe(&io___33);
+ do_fio(&c__1, "TYPE", (ftnlen)4);
+ do_fio(&c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (ntval[i__ - 1] > 9) {
+ s_wsfe(&io___34);
+ do_fio(&c__1, "TYPE", (ftnlen)4);
+ do_fio(&c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L320: */
+ }
+ if (nnt > 0) {
+ s_wsfe(&io___35);
+ do_fio(&c__1, "TYPE", (ftnlen)4);
+ i__1 = nnt;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the threshold value for the test ratios. */
+
+ s_rsle(&io___36);
+ do_lio(&c__4, &c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_rsle();
+ s_wsfe(&io___38);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_wsfe();
+
+/* Read the flag that indicates whether to test the error exits. */
+
+ s_rsle(&io___39);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+
+ if (fatal) {
+ s_wsfe(&io___41);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+ if (fatal) {
+ s_wsfe(&io___42);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Calculate and print the machine dependent constants. */
+
+ eps = slamch_("Underflow threshold");
+ s_wsfe(&io___44);
+ do_fio(&c__1, "underflow", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+ eps = slamch_("Overflow threshold");
+ s_wsfe(&io___45);
+ do_fio(&c__1, "overflow ", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+ eps = slamch_("Epsilon");
+ s_wsfe(&io___46);
+ do_fio(&c__1, "precision", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_wsle(&io___47);
+ e_wsle();
+
+/* Test the error exit of: */
+
+ if (tsterr) {
+ cerrrfp_(&c__6);
+ }
+
+/* Test the routines: cpftrf, cpftri, cpftrs (as in CDRVPO). */
+/* This also tests the routines: ctfsm, ctftri, ctfttr, ctrttf. */
+
+ cdrvrfp_(&c__6, &nn, nval, &nns, nsval, &nnt, ntval, &thresh, worka,
+ workasav, workafac, workainv, workb, workbsav, workxact, workx,
+ workarf, workarfinv, c_work_clatms__, c_work_cpot01__,
+ c_work_cpot02__, c_work_cpot03__, s_work_clatms__,
+ s_work_clanhe__, s_work_cpot02__, s_work_cpot03__);
+
+/* Test the routine: clanhf */
+
+ cdrvrf1_(&c__6, &nn, nval, &thresh, worka, &c__50, workarf,
+ s_work_clanhe__);
+
+/* Test the convertion routines: */
+/* chfttp, ctpthf, ctfttr, ctrttf, ctrttp and ctpttr. */
+
+ cdrvrf2_(&c__6, &nn, nval, worka, &c__50, workarf, workap, workasav);
+
+/* Test the routine: ctfsm */
+
+ cdrvrf3_(&c__6, &nn, nval, &thresh, worka, &c__50, workarf, workainv,
+ workafac, s_work_clanhe__, c_work_cpot03__, c_work_cpot01__);
+
+
+/* Test the routine: chfrk */
+
+ cdrvrf4_(&c__6, &nn, nval, &thresh, worka, workafac, &c__50, workarf,
+ workainv, &c__50, s_work_clanhe__);
+
+ cl__1.cerr = 0;
+ cl__1.cunit = 5;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ s2 = second_();
+ s_wsfe(&io___68);
+ e_wsfe();
+ s_wsfe(&io___69);
+ r__1 = s2 - s1;
+ do_fio(&c__1, (char *)&r__1, (ftnlen)sizeof(real));
+ e_wsfe();
+
+
+/* End of CCHKRFP */
+
+ return 0;
+} /* MAIN__ */
+
+/* Main program alias */ int cchkrfp_ () { MAIN__ (); return 0; }
diff --git a/TESTING/LIN/cchkrq.c b/TESTING/LIN/cchkrq.c
new file mode 100644
index 0000000..996f06c
--- /dev/null
+++ b/TESTING/LIN/cchkrq.c
@@ -0,0 +1,477 @@
+/* cchkrq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int cchkrq_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nxval, integer *nrhs, real *thresh, logical *tsterr, integer *nmax,
+ complex *a, complex *af, complex *aq, complex *ar, complex *ac,
+ complex *b, complex *x, complex *xact, complex *tau, complex *work,
+ real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
+ "5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
+ "t(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, ik, im, in, kl, nk, ku, nt, nx, lda, inb, mode,
+ imat, info;
+ char path[3];
+ integer kval[4];
+ char dist[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), cget02_(
+ char *, integer *, integer *, integer *, complex *, integer *,
+ complex *, integer *, complex *, integer *, real *, real *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int crqt01_(integer *, integer *, complex *,
+ complex *, complex *, complex *, integer *, complex *, complex *,
+ integer *, real *, real *), crqt02_(integer *, integer *, integer
+ *, complex *, complex *, complex *, complex *, integer *, complex
+ *, complex *, integer *, real *, real *);
+ real anorm;
+ extern /* Subroutine */ int crqt03_(integer *, integer *, integer *,
+ complex *, complex *, complex *, complex *, integer *, complex *,
+ complex *, integer *, real *, real *);
+ integer minmn, nerrs, lwork;
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ extern logical cgennd_(integer *, integer *, complex *, integer *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), clarhs_(char *, char
+ *, char *, char *, integer *, integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, integer *, integer *),
+ alasum_(char *, integer *, integer *, integer *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int cgerqs_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, complex *,
+ integer *, integer *), clatms_(integer *, integer *, char *,
+ integer *, char *, real *, integer *, real *, real *, integer *,
+ integer *, char *, complex *, integer *, complex *, integer *), cerrrq_(char *, integer *),
+ xlaenv_(integer *, integer *);
+ real result[8];
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKRQ tests CGERQF, CUNGRQ and CUNMRQ. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AQ (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AR (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* TAU (workspace) COMPLEX array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --tau;
+ --xact;
+ --x;
+ --b;
+ --ac;
+ --ar;
+ --aq;
+ --af;
+ --a;
+ --nxval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "RQ", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrrq_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+ lda = *nmax;
+ lwork = *nmax * max(*nmax,*nrhs);
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Do for each value of N in NVAL. */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ minmn = min(m,n);
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L50;
+ }
+
+/* Set up parameters with CLATB4 and generate a test matrix */
+/* with CLATMS. */
+
+ clatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, " ", &m, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L50;
+ }
+
+/* Set some values for K: the first value must be MINMN, */
+/* corresponding to the call of CRQT01; other values are */
+/* used in the calls of CRQT02, and must not exceed MINMN. */
+
+ kval[0] = minmn;
+ kval[1] = 0;
+ kval[2] = 1;
+ kval[3] = minmn / 2;
+ if (minmn == 0) {
+ nk = 1;
+ } else if (minmn == 1) {
+ nk = 2;
+ } else if (minmn <= 3) {
+ nk = 3;
+ } else {
+ nk = 4;
+ }
+
+/* Do for each value of K in KVAL */
+
+ i__3 = nk;
+ for (ik = 1; ik <= i__3; ++ik) {
+ k = kval[ik - 1];
+
+/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ nx = nxval[inb];
+ xlaenv_(&c__3, &nx);
+ for (i__ = 1; i__ <= 8; ++i__) {
+ result[i__ - 1] = 0.f;
+ }
+ nt = 2;
+ if (ik == 1) {
+
+/* Test CGERQF */
+
+ crqt01_(&m, &n, &a[1], &af[1], &aq[1], &ar[1], &
+ lda, &tau[1], &work[1], &lwork, &rwork[1],
+ result);
+ if (m <= n) {
+/* Check the upper-right m-by-m corner */
+ if (! cgennd_(&m, &m, &af[lda * (n - m) + 1],
+ &lda)) {
+ result[7] = *thresh * 2;
+ }
+ } else {
+/* Check the (m-n)th subdiagonal */
+ i__ = m - n;
+ if (! cgennd_(&n, &n, &af[i__ + 1], &lda)) {
+ result[7] = *thresh * 2;
+ }
+ }
+ } else if (m <= n) {
+
+/* Test CUNGRQ, using factorization */
+/* returned by CRQT01 */
+
+ crqt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &ar[1],
+ &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], result);
+ } else {
+ result[0] = 0.f;
+ result[1] = 0.f;
+ }
+ if (m >= k) {
+
+/* Test CUNMRQ, using factorization returned */
+/* by CRQT01 */
+
+ crqt03_(&m, &n, &k, &af[1], &ac[1], &ar[1], &aq[1]
+, &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], &result[2]);
+ nt += 4;
+
+/* If M>=N and K=N, call CGERQS to solve a system */
+/* with NRHS right hand sides and compute the */
+/* residual. */
+
+ if (k == m && inb == 1) {
+
+/* Generate a solution and set the right */
+/* hand side. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32,
+ (ftnlen)6);
+ clarhs_(path, "New", "Full", "No transpose", &
+ m, &n, &c__0, &c__0, nrhs, &a[1], &
+ lda, &xact[1], &lda, &b[1], &lda,
+ iseed, &info);
+
+ clacpy_("Full", &m, nrhs, &b[1], &lda, &x[n -
+ m + 1], &lda);
+ s_copy(srnamc_1.srnamt, "CGERQS", (ftnlen)32,
+ (ftnlen)6);
+ cgerqs_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
+ x[1], &lda, &work[1], &lwork, &info);
+
+/* Check error code from CGERQS. */
+
+ if (info != 0) {
+ alaerh_(path, "CGERQS", &info, &c__0,
+ " ", &m, &n, nrhs, &c_n1, &nb, &
+ imat, &nfail, &nerrs, nout);
+ }
+
+ cget02_("No transpose", &m, &n, nrhs, &a[1], &
+ lda, &x[1], &lda, &b[1], &lda, &rwork[
+ 1], &result[6]);
+ ++nt;
+ } else {
+ result[6] = 0.f;
+ }
+ } else {
+ result[2] = 0.f;
+ result[3] = 0.f;
+ result[4] = 0.f;
+ result[5] = 0.f;
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__5 = nt;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+/* L30: */
+ }
+/* L40: */
+ }
+L50:
+ ;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CCHKRQ */
+
+} /* cchkrq_ */
diff --git a/TESTING/LIN/cchksp.c b/TESTING/LIN/cchksp.c
new file mode 100644
index 0000000..b7847e7
--- /dev/null
+++ b/TESTING/LIN/cchksp.c
@@ -0,0 +1,650 @@
+/* cchksp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__8 = 8;
+
+/* Subroutine */ int cchksp_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, real *thresh, logical *tsterr, integer *
+ nmax, complex *a, complex *afac, complex *ainv, complex *b, complex *
+ x, complex *xact, complex *work, real *rwork, integer *iwork, integer
+ *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
+ "12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, in, kl, ku, nt, lda, npp, ioff, mode, imat,
+ info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), cget04_(
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ real *, real *);
+ integer nfail, iseed[4];
+ extern logical lsame_(char *, char *);
+ real rcond;
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int cspt01_(char *, integer *, complex *, complex
+ *, integer *, complex *, integer *, real *, real *),
+ cppt05_(char *, integer *, integer *, complex *, complex *,
+ integer *, complex *, integer *, complex *, integer *, real *,
+ real *, real *);
+ real anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), cspt02_(char *, integer *, integer *,
+ complex *, complex *, integer *, complex *, integer *, real *,
+ real *), cspt03_(char *, integer *, complex *, complex *,
+ complex *, integer *, real *, real *, real *);
+ integer iuplo, izero, nerrs;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ real rcondc;
+ char packit[1];
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), clarhs_(char *, char
+ *, char *, char *, integer *, integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, integer *, integer *);
+ extern doublereal clansp_(char *, char *, integer *, complex *, real *);
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, complex *, integer *, complex *, integer *), clatsp_(char *, integer *, complex *, integer *), cspcon_(char *, integer *, complex *, integer *, real *,
+ real *, complex *, integer *);
+ logical trfcon;
+ extern /* Subroutine */ int csprfs_(char *, integer *, integer *, complex
+ *, complex *, integer *, complex *, integer *, complex *, integer
+ *, real *, real *, complex *, real *, integer *), csptrf_(
+ char *, integer *, complex *, integer *, integer *),
+ csptri_(char *, integer *, complex *, integer *, complex *,
+ integer *), cerrsy_(char *, integer *);
+ real result[8];
+ extern /* Subroutine */ int csptrs_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___38 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKSP tests CSPTRF, -TRI, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AFAC (workspace) COMPLEX array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AINV (workspace) COMPLEX array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(2,NSMAX)) */
+
+/* RWORK (workspace) REAL array, */
+/* dimension (NMAX+2*NSMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "SP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrsy_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 11;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L160;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L160;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ if (lsame_(uplo, "U")) {
+ *(unsigned char *)packit = 'C';
+ } else {
+ *(unsigned char *)packit = 'R';
+ }
+
+ if (imat != 11) {
+
+/* Set up parameters with CLATB4 and generate a test */
+/* matrix with CLATMS. */
+
+ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
+ mode, &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ goto L150;
+ }
+
+/* For types 3-6, zero one or more rows and columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * izero / 2;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff += i__;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff = ioff + n - i__;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows and columns to zero. */
+
+ ioff = 0;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+/* L60: */
+ }
+ ioff += j;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows and columns to zero. */
+
+ ioff = 0;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+/* L80: */
+ }
+ ioff = ioff + n - j;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+ } else {
+
+/* Use a special block diagonal matrix to test alternate */
+/* code for the 2 x 2 blocks. */
+
+ clatsp_(uplo, &n, &a[1], iseed);
+ }
+
+/* Compute the L*D*L' or U*D*U' factorization of the matrix. */
+
+ npp = n * (n + 1) / 2;
+ ccopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ s_copy(srnamc_1.srnamt, "CSPTRF", (ftnlen)32, (ftnlen)6);
+ csptrf_(uplo, &n, &afac[1], &iwork[1], &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from CSPTRF. */
+
+ if (info != k) {
+ alaerh_(path, "CSPTRF", &info, &k, uplo, &n, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+ if (info != 0) {
+ trfcon = TRUE_;
+ } else {
+ trfcon = FALSE_;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ cspt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &ainv[1], &lda,
+ &rwork[1], result);
+ nt = 1;
+
+/* + TEST 2 */
+/* Form the inverse and compute the residual. */
+
+ if (! trfcon) {
+ ccopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
+ s_copy(srnamc_1.srnamt, "CSPTRI", (ftnlen)32, (ftnlen)6);
+ csptri_(uplo, &n, &ainv[1], &iwork[1], &work[1], &info);
+
+/* Check error code from CSPTRI. */
+
+ if (info != 0) {
+ alaerh_(path, "CSPTRI", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ cspt03_(uplo, &n, &a[1], &ainv[1], &work[1], &lda, &rwork[
+ 1], &rcondc, &result[1]);
+ nt = 2;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+
+/* Do only the condition estimate if INFO is not 0. */
+
+ if (trfcon) {
+ rcondc = 0.f;
+ goto L140;
+ }
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (ftnlen)6);
+ clarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &nrhs, &
+ a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
+ info);
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "CSPTRS", (ftnlen)32, (ftnlen)6);
+ csptrs_(uplo, &n, &nrhs, &afac[1], &iwork[1], &x[1], &lda,
+ &info);
+
+/* Check error code from CSPTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "CSPTRS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
+ cspt02_(uplo, &n, &nrhs, &a[1], &x[1], &lda, &work[1], &
+ lda, &rwork[1], &result[2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "CSPRFS", (ftnlen)32, (ftnlen)6);
+ csprfs_(uplo, &n, &nrhs, &a[1], &afac[1], &iwork[1], &b[1]
+, &lda, &x[1], &lda, &rwork[1], &rwork[nrhs + 1],
+ &work[1], &rwork[(nrhs << 1) + 1], &info);
+
+/* Check error code from CSPRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "CSPRFS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[4]);
+ cppt05_(uplo, &n, &nrhs, &a[1], &b[1], &lda, &x[1], &lda,
+ &xact[1], &lda, &rwork[1], &rwork[nrhs + 1], &
+ result[5]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L120: */
+ }
+ nrun += 5;
+/* L130: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+L140:
+ anorm = clansp_("1", uplo, &n, &a[1], &rwork[1]);
+ s_copy(srnamc_1.srnamt, "CSPCON", (ftnlen)32, (ftnlen)6);
+ cspcon_(uplo, &n, &afac[1], &iwork[1], &anorm, &rcond, &work[
+ 1], &info);
+
+/* Check error code from CSPCON. */
+
+ if (info != 0) {
+ alaerh_(path, "CSPCON", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+ result[7] = sget06_(&rcond, &rcondc);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___43.ciunit = *nout;
+ s_wsfe(&io___43);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L150:
+ ;
+ }
+L160:
+ ;
+ }
+/* L170: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CCHKSP */
+
+} /* cchksp_ */
diff --git a/TESTING/LIN/cchksy.c b/TESTING/LIN/cchksy.c
new file mode 100644
index 0000000..80c5949
--- /dev/null
+++ b/TESTING/LIN/cchksy.c
@@ -0,0 +1,688 @@
+/* cchksy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__8 = 8;
+
+/* Subroutine */ int cchksy_(logical *dotype, integer *nn, integer *nval,
+ integer *nnb, integer *nbval, integer *nns, integer *nsval, real *
+ thresh, logical *tsterr, integer *nmax, complex *a, complex *afac,
+ complex *ainv, complex *b, complex *x, complex *xact, complex *work,
+ real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
+ "=\002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
+ "12.5)";
+ static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002"
+ ",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
+ ;
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, nb, in, kl, ku, nt, lda, inb, ioff, mode,
+ imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), cget04_(
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ real *, real *);
+ integer nfail, iseed[4];
+ real rcond;
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int cpot05_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, complex *, integer *, complex
+ *, integer *, real *, real *, real *);
+ real anorm;
+ extern /* Subroutine */ int csyt01_(char *, integer *, complex *, integer
+ *, complex *, integer *, integer *, complex *, integer *, real *,
+ real *), csyt02_(char *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, real *,
+ real *), csyt03_(char *, integer *, complex *, integer *,
+ complex *, integer *, complex *, integer *, real *, real *, real *
+);
+ integer iuplo, izero, nerrs, lwork;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ real rcondc;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), clarhs_(char *, char
+ *, char *, char *, integer *, integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, integer *, integer *),
+ alasum_(char *, integer *, integer *, integer *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, complex *, integer *, complex *, integer *);
+ extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
+ real *);
+ logical trfcon;
+ extern /* Subroutine */ int csycon_(char *, integer *, complex *, integer
+ *, integer *, real *, real *, complex *, integer *),
+ clatsy_(char *, integer *, complex *, integer *, integer *), xlaenv_(integer *, integer *), cerrsy_(char *, integer *), csyrfs_(char *, integer *, integer *, complex *,
+ integer *, complex *, integer *, integer *, complex *, integer *,
+ complex *, integer *, real *, real *, complex *, real *, integer *
+), csytrf_(char *, integer *, complex *, integer *,
+ integer *, complex *, integer *, integer *), csytri_(char
+ *, integer *, complex *, integer *, integer *, complex *, integer
+ *);
+ real result[8];
+ extern /* Subroutine */ int csytrs_(char *, integer *, integer *, complex
+ *, integer *, integer *, complex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKSY tests CSYTRF, -TRI, -TRS, -RFS, and -CON. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(2,NSMAX)) */
+
+/* RWORK (workspace) REAL array, */
+/* dimension (NMAX+2*NSMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "SY", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrsy_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 11;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ izero = 0;
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L170;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L170;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+ if (imat != 11) {
+
+/* Set up parameters with CLATB4 and generate a test */
+/* matrix with CLATMS. */
+
+ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
+ mode, &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "N", &a[1], &lda, &work[
+ 1], &info);
+
+/* Check error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ goto L160;
+ }
+
+/* For types 3-6, zero one or more rows and columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * lda;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows to zero. */
+
+ ioff = 0;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+/* L60: */
+ }
+ ioff += lda;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows to zero. */
+
+ ioff = 0;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+/* L80: */
+ }
+ ioff += lda;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+ } else {
+
+/* Use a special block diagonal matrix to test alternate */
+/* code for the 2 x 2 blocks. */
+
+ clatsy_(uplo, &n, &a[1], &lda, iseed);
+ }
+
+/* Do for each value of NB in NBVAL */
+
+ i__3 = *nnb;
+ for (inb = 1; inb <= i__3; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the L*D*L' or U*D*U' factorization of the */
+/* matrix. */
+
+ clacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ lwork = max(2,nb) * lda;
+ s_copy(srnamc_1.srnamt, "CSYTRF", (ftnlen)32, (ftnlen)6);
+ csytrf_(uplo, &n, &afac[1], &lda, &iwork[1], &ainv[1], &
+ lwork, &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from CSYTRF. */
+
+ if (info != k) {
+ alaerh_(path, "CSYTRF", &info, &k, uplo, &n, &n, &
+ c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
+ }
+ if (info != 0) {
+ trfcon = TRUE_;
+ } else {
+ trfcon = FALSE_;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ csyt01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &iwork[1],
+ &ainv[1], &lda, &rwork[1], result);
+ nt = 1;
+
+/* + TEST 2 */
+/* Form the inverse and compute the residual. */
+
+ if (inb == 1 && ! trfcon) {
+ clacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
+ s_copy(srnamc_1.srnamt, "CSYTRI", (ftnlen)32, (ftnlen)
+ 6);
+ csytri_(uplo, &n, &ainv[1], &lda, &iwork[1], &work[1],
+ &info);
+
+/* Check error code from CSYTRI. */
+
+ if (info != 0) {
+ alaerh_(path, "CSYTRI", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ csyt03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &work[
+ 1], &lda, &rwork[1], &rcondc, &result[1]);
+ nt = 2;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+
+/* Skip the other tests if this is not the first block */
+/* size. */
+
+ if (inb > 1) {
+ goto L150;
+ }
+
+/* Do only the condition estimate if INFO is not 0. */
+
+ if (trfcon) {
+ rcondc = 0.f;
+ goto L140;
+ }
+
+ i__4 = *nns;
+ for (irhs = 1; irhs <= i__4; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ clarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "CSYTRS", (ftnlen)32, (ftnlen)
+ 6);
+ csytrs_(uplo, &n, &nrhs, &afac[1], &lda, &iwork[1], &
+ x[1], &lda, &info);
+
+/* Check error code from CSYTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "CSYTRS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &
+ lda);
+ csyt02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
+ work[1], &lda, &rwork[1], &result[2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "CSYRFS", (ftnlen)32, (ftnlen)
+ 6);
+ csyrfs_(uplo, &n, &nrhs, &a[1], &lda, &afac[1], &lda,
+ &iwork[1], &b[1], &lda, &x[1], &lda, &rwork[1]
+, &rwork[nrhs + 1], &work[1], &rwork[(nrhs <<
+ 1) + 1], &info);
+
+/* Check error code from CSYRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "CSYRFS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[4]);
+ cpot05_(uplo, &n, &nrhs, &a[1], &lda, &b[1], &lda, &x[
+ 1], &lda, &xact[1], &lda, &rwork[1], &rwork[
+ nrhs + 1], &result[5]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L120: */
+ }
+ nrun += 5;
+/* L130: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+L140:
+ anorm = clansy_("1", uplo, &n, &a[1], &lda, &rwork[1]);
+ s_copy(srnamc_1.srnamt, "CSYCON", (ftnlen)32, (ftnlen)6);
+ csycon_(uplo, &n, &afac[1], &lda, &iwork[1], &anorm, &
+ rcond, &work[1], &info);
+
+/* Check error code from CSYCON. */
+
+ if (info != 0) {
+ alaerh_(path, "CSYCON", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ result[7] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L150:
+ ;
+ }
+L160:
+ ;
+ }
+L170:
+ ;
+ }
+/* L180: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CCHKSY */
+
+} /* cchksy_ */
diff --git a/TESTING/LIN/cchktb.c b/TESTING/LIN/cchktb.c
new file mode 100644
index 0000000..7e33c97
--- /dev/null
+++ b/TESTING/LIN/cchktb.c
@@ -0,0 +1,734 @@
+/* cchktb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static complex c_b14 = {0.f,0.f};
+static complex c_b15 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c__3 = 3;
+static integer c_n1 = -1;
+static integer c__6 = 6;
+static integer c__4 = 4;
+static real c_b90 = 1.f;
+static integer c__7 = 7;
+static integer c__8 = 8;
+
+/* Subroutine */ int cchktb_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, real *thresh, logical *tsterr, integer *
+ nmax, complex *ab, complex *ainv, complex *b, complex *x, complex *
+ xact, complex *work, real *rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', TRANS='\002,a1,\002"
+ "', DIAG='\002,a1,\002', N=\002,i5,\002, K"
+ "D=\002,i5,\002, NRHS=\002,i5,\002, type \002,i2,\002, test(\002,"
+ "i2,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
+ "'\002,a1,\002',\002,i5,\002,\002,i5,\002, ... ), type \002,i2"
+ ",\002, test(\002,i2,\002)=\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
+ "'\002,a1,\002', '\002,a1,\002',\002,i5,\002,\002,i5,\002, ... )"
+ ", type \002,i2,\002, test(\002,i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[3], a__2[4];
+ integer i__1, i__2, i__3, i__4, i__5, i__6[3], i__7[4];
+ char ch__1[3], ch__2[4];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
+ char **, integer *, integer *, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n, kd, ik, in, nk, lda, ldab;
+ char diag[1];
+ integer imat, info;
+ char path[3];
+ integer irhs, nrhs;
+ char norm[1], uplo[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer idiag;
+ extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *);
+ real scale;
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int ctbt02_(char *, char *, char *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, complex *, real *, real *), ctbt03_(char *, char *, char *, integer *, integer *,
+ integer *, complex *, integer *, real *, real *, real *, complex *
+, integer *, complex *, integer *, complex *, real *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ctbt05_(char *, char *, char *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, complex *, integer *, real *, real *, real *
+), ctbt06_(real *, real *, char *, char *,
+ integer *, integer *, complex *, integer *, real *, real *);
+ real rcond;
+ integer nimat;
+ real anorm;
+ integer itran;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), ctbsv_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *);
+ char trans[1];
+ integer iuplo, nerrs;
+ char xtype[1];
+ integer nimat2;
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ extern doublereal clantb_(char *, char *, char *, integer *, integer *,
+ complex *, integer *, real *);
+ real rcondc;
+ extern /* Subroutine */ int clatbs_(char *, char *, char *, char *,
+ integer *, integer *, complex *, integer *, complex *, real *,
+ real *, integer *), clattb_(
+ integer *, char *, char *, char *, integer *, integer *, integer *
+, complex *, integer *, complex *, complex *, real *, integer *), clacpy_(char *, integer *, integer *,
+ complex *, integer *, complex *, integer *), clarhs_(char
+ *, char *, char *, char *, integer *, integer *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, integer *, integer *), claset_(char *, integer *, integer *, complex *,
+ complex *, complex *, integer *);
+ real rcondi;
+ extern /* Subroutine */ int ctbcon_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, real *, complex *, real *,
+ integer *);
+ extern doublereal clantr_(char *, char *, char *, integer *, integer *,
+ complex *, integer *, real *);
+ real rcondo;
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *), ctbrfs_(char *, char *, char *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, real *, complex *, real *, integer *
+);
+ real ainvnm;
+ extern /* Subroutine */ int cerrtr_(char *, integer *), ctbtrs_(
+ char *, char *, char *, integer *, integer *, integer *, complex *
+, integer *, complex *, integer *, integer *);
+ real result[8];
+
+ /* Fortran I/O blocks */
+ static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKTB tests CTBTRS, -RFS, and -CON, and CLATBS. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The leading dimension of the work arrays. */
+/* NMAX >= the maximum value of N in NVAL. */
+
+/* AB (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --ab;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "TB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrtr_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL */
+
+ n = nval[in];
+ lda = max(1,n);
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ nimat2 = 17;
+ if (n <= 0) {
+ nimat = 1;
+ nimat2 = 10;
+ }
+
+/* Computing MIN */
+ i__2 = n + 1;
+ nk = min(i__2,4);
+ i__2 = nk;
+ for (ik = 1; ik <= i__2; ++ik) {
+
+/* Do for KD = 0, N, (3N-1)/4, and (N+1)/4. This order makes */
+/* it easier to skip redundant values for small values of N. */
+
+ if (ik == 1) {
+ kd = 0;
+ } else if (ik == 2) {
+ kd = max(n,0);
+ } else if (ik == 3) {
+ kd = (n * 3 - 1) / 4;
+ } else if (ik == 4) {
+ kd = (n + 1) / 4;
+ }
+ ldab = kd + 1;
+
+ i__3 = nimat;
+ for (imat = 1; imat <= i__3; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L90;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+
+/* Call CLATTB to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "CLATTB", (ftnlen)32, (ftnlen)6);
+ clattb_(&imat, uplo, "No transpose", diag, iseed, &n, &kd,
+ &ab[1], &ldab, &x[1], &work[1], &rwork[1], &info);
+
+/* Set IDIAG = 1 for non-unit matrices, 2 for unit. */
+
+ if (lsame_(diag, "N")) {
+ idiag = 1;
+ } else {
+ idiag = 2;
+ }
+
+/* Form the inverse of A so we can get a good estimate */
+/* of RCONDC = 1/(norm(A) * norm(inv(A))). */
+
+ claset_("Full", &n, &n, &c_b14, &c_b15, &ainv[1], &lda);
+ if (lsame_(uplo, "U")) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ ctbsv_(uplo, "No transpose", diag, &j, &kd, &ab[1]
+, &ldab, &ainv[(j - 1) * lda + 1], &c__1);
+/* L20: */
+ }
+ } else {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__5 = n - j + 1;
+ ctbsv_(uplo, "No transpose", diag, &i__5, &kd, &
+ ab[(j - 1) * ldab + 1], &ldab, &ainv[(j -
+ 1) * lda + j], &c__1);
+/* L30: */
+ }
+ }
+
+/* Compute the 1-norm condition number of A. */
+
+ anorm = clantb_("1", uplo, diag, &n, &kd, &ab[1], &ldab, &
+ rwork[1]);
+ ainvnm = clantr_("1", uplo, diag, &n, &n, &ainv[1], &lda,
+ &rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondo = 1.f;
+ } else {
+ rcondo = 1.f / anorm / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ anorm = clantb_("I", uplo, diag, &n, &kd, &ab[1], &ldab, &
+ rwork[1]);
+ ainvnm = clantr_("I", uplo, diag, &n, &n, &ainv[1], &lda,
+ &rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondi = 1.f;
+ } else {
+ rcondi = 1.f / anorm / ainvnm;
+ }
+
+ i__4 = *nns;
+ for (irhs = 1; irhs <= i__4; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, or A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itran - 1];
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+
+/* + TEST 1 */
+/* Solve and compute residual for op(A)*x = b. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (
+ ftnlen)6);
+ clarhs_(path, xtype, uplo, trans, &n, &n, &kd, &
+ idiag, &nrhs, &ab[1], &ldab, &xact[1], &
+ lda, &b[1], &lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "CTBTRS", (ftnlen)32, (
+ ftnlen)6);
+ ctbtrs_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1],
+ &ldab, &x[1], &lda, &info);
+
+/* Check error code from CTBTRS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__6[0] = 1, a__1[0] = uplo;
+ i__6[1] = 1, a__1[1] = trans;
+ i__6[2] = 1, a__1[2] = diag;
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)3);
+ alaerh_(path, "CTBTRS", &info, &c__0, ch__1, &
+ n, &n, &kd, &kd, &nrhs, &imat, &nfail,
+ &nerrs, nout);
+ }
+
+ ctbt02_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1],
+ &ldab, &x[1], &lda, &b[1], &lda, &work[1]
+, &rwork[1], result);
+
+/* + TEST 2 */
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[1]);
+
+/* + TESTS 3, 4, and 5 */
+/* Use iterative refinement to improve the solution */
+/* and compute error bounds. */
+
+ s_copy(srnamc_1.srnamt, "CTBRFS", (ftnlen)32, (
+ ftnlen)6);
+ ctbrfs_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1],
+ &ldab, &b[1], &lda, &x[1], &lda, &rwork[
+ 1], &rwork[nrhs + 1], &work[1], &rwork[(
+ nrhs << 1) + 1], &info);
+
+/* Check error code from CTBRFS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__6[0] = 1, a__1[0] = uplo;
+ i__6[1] = 1, a__1[1] = trans;
+ i__6[2] = 1, a__1[2] = diag;
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)3);
+ alaerh_(path, "CTBRFS", &info, &c__0, ch__1, &
+ n, &n, &kd, &kd, &nrhs, &imat, &nfail,
+ &nerrs, nout);
+ }
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ ctbt05_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1],
+ &ldab, &b[1], &lda, &x[1], &lda, &xact[1]
+, &lda, &rwork[1], &rwork[nrhs + 1], &
+ result[3]);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 1; k <= 5; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L40: */
+ }
+ nrun += 5;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* + TEST 6 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+ s_copy(srnamc_1.srnamt, "CTBCON", (ftnlen)32, (ftnlen)
+ 6);
+ ctbcon_(norm, uplo, diag, &n, &kd, &ab[1], &ldab, &
+ rcond, &work[1], &rwork[1], &info);
+
+/* Check error code from CTBCON. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__6[0] = 1, a__1[0] = norm;
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = diag;
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)3);
+ alaerh_(path, "CTBCON", &info, &c__0, ch__1, &n, &
+ n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ ctbt06_(&rcond, &rcondc, uplo, diag, &n, &kd, &ab[1],
+ &ldab, &rwork[1], &result[5]);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "CTBCON", (ftnlen)6);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L70: */
+ }
+/* L80: */
+ }
+L90:
+ ;
+ }
+
+/* Use pathological test matrices to test CLATBS. */
+
+ i__3 = nimat2;
+ for (imat = 10; imat <= i__3; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, and A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[
+ itran - 1];
+
+/* Call CLATTB to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "CLATTB", (ftnlen)32, (ftnlen)
+ 6);
+ clattb_(&imat, uplo, trans, diag, iseed, &n, &kd, &ab[
+ 1], &ldab, &x[1], &work[1], &rwork[1], &info);
+
+/* + TEST 7 */
+/* Solve the system op(A)*x = b */
+
+ s_copy(srnamc_1.srnamt, "CLATBS", (ftnlen)32, (ftnlen)
+ 6);
+ ccopy_(&n, &x[1], &c__1, &b[1], &c__1);
+ clatbs_(uplo, trans, diag, "N", &n, &kd, &ab[1], &
+ ldab, &b[1], &scale, &rwork[1], &info);
+
+/* Check error code from CLATBS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__7[0] = 1, a__2[0] = uplo;
+ i__7[1] = 1, a__2[1] = trans;
+ i__7[2] = 1, a__2[2] = diag;
+ i__7[3] = 1, a__2[3] = "N";
+ s_cat(ch__2, a__2, i__7, &c__4, (ftnlen)4);
+ alaerh_(path, "CLATBS", &info, &c__0, ch__2, &n, &
+ n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ ctbt03_(uplo, trans, diag, &n, &kd, &c__1, &ab[1], &
+ ldab, &scale, &rwork[1], &c_b90, &b[1], &lda,
+ &x[1], &lda, &work[1], &result[6]);
+
+/* + TEST 8 */
+/* Solve op(A)*x = b again with NORMIN = 'Y'. */
+
+ ccopy_(&n, &x[1], &c__1, &b[1], &c__1);
+ clatbs_(uplo, trans, diag, "Y", &n, &kd, &ab[1], &
+ ldab, &b[1], &scale, &rwork[1], &info);
+
+/* Check error code from CLATBS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__7[0] = 1, a__2[0] = uplo;
+ i__7[1] = 1, a__2[1] = trans;
+ i__7[2] = 1, a__2[2] = diag;
+ i__7[3] = 1, a__2[3] = "Y";
+ s_cat(ch__2, a__2, i__7, &c__4, (ftnlen)4);
+ alaerh_(path, "CLATBS", &info, &c__0, ch__2, &n, &
+ n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ ctbt03_(uplo, trans, diag, &n, &kd, &c__1, &ab[1], &
+ ldab, &scale, &rwork[1], &c_b90, &b[1], &lda,
+ &x[1], &lda, &work[1], &result[7]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___43.ciunit = *nout;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "CLATBS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "CLATBS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "Y", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+ nrun += 2;
+/* L100: */
+ }
+/* L110: */
+ }
+L120:
+ ;
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CCHKTB */
+
+} /* cchktb_ */
diff --git a/TESTING/LIN/cchktp.c b/TESTING/LIN/cchktp.c
new file mode 100644
index 0000000..966718f
--- /dev/null
+++ b/TESTING/LIN/cchktp.c
@@ -0,0 +1,684 @@
+/* cchktp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__7 = 7;
+static integer c__4 = 4;
+static real c_b103 = 1.f;
+static integer c__8 = 8;
+static integer c__9 = 9;
+
+/* Subroutine */ int cchktp_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, real *thresh, logical *tsterr, integer *
+ nmax, complex *ap, complex *ainvp, complex *b, complex *x, complex *
+ xact, complex *work, real *rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', DIAG='\002,a1,\002'"
+ ", N=\002,i5,\002, type \002,i2,\002, test(\002,i2,\002)= \002,g1"
+ "2.5)";
+ static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', TRANS='\002,a1,\002"
+ "', DIAG='\002,a1,\002', N=\002,i5,\002', NRHS=\002,i5,\002, type "
+ "\002,i2,\002, test(\002,i2,\002)= \002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
+ "'\002,a1,\002',\002,i5,\002, ... ), type \002,i2,\002, test(\002"
+ ",i2,\002)=\002,g12.5)";
+ static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
+ "'\002,a1,\002', '\002,a1,\002',\002,i5,\002, ... ), type \002,i2,"
+ "\002, test(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2], a__2[3], a__3[4];
+ integer i__1, i__2[2], i__3, i__4[3], i__5[4];
+ char ch__1[2], ch__2[3], ch__3[4];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
+ char **, integer *, integer *, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, in, lda, lap;
+ char diag[1];
+ integer imat, info;
+ char path[3];
+ integer irhs, nrhs;
+ char norm[1], uplo[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer idiag;
+ extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *);
+ real scale;
+ integer nfail, iseed[4];
+ extern logical lsame_(char *, char *);
+ real rcond;
+ extern /* Subroutine */ int ctpt01_(char *, char *, integer *, complex *,
+ complex *, real *, real *, real *);
+ real anorm;
+ integer itran;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), ctpt02_(char *, char *, char *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, real *, real *), ctpt03_(char *
+, char *, char *, integer *, integer *, complex *, real *, real *,
+ real *, complex *, integer *, complex *, integer *, complex *,
+ real *), ctpt05_(char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *, real *), ctpt06_(real *, real *, char *, char *, integer *
+, complex *, real *, real *);
+ char trans[1];
+ integer iuplo, nerrs;
+ char xtype[1];
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ real rcondc;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), clarhs_(char *, char
+ *, char *, char *, integer *, integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, integer *, integer *);
+ real rcondi;
+ extern doublereal clantp_(char *, char *, char *, integer *, complex *,
+ real *);
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ real rcondo;
+ extern /* Subroutine */ int clatps_(char *, char *, char *, char *,
+ integer *, complex *, complex *, real *, real *, integer *), clattp_(integer *, char *, char *
+, char *, integer *, integer *, complex *, complex *, complex *,
+ real *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int ctpcon_(char *, char *, char *, integer *,
+ complex *, real *, complex *, real *, integer *), cerrtr_(char *, integer *), ctprfs_(char *, char
+ *, char *, integer *, integer *, complex *, complex *, integer *,
+ complex *, integer *, real *, real *, complex *, real *, integer *
+), ctptri_(char *, char *, integer *,
+ complex *, integer *);
+ real result[9];
+ extern /* Subroutine */ int ctptrs_(char *, char *, char *, integer *,
+ integer *, complex *, complex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKTP tests CTPTRI, -TRS, -RFS, and -CON, and CLATPS */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The leading dimension of the work arrays. NMAX >= the */
+/* maximumm value of N in NVAL. */
+
+/* AP (workspace) COMPLEX array, dimension (NMAX*(NMAX+1)/2) */
+
+/* AINVP (workspace) COMPLEX array, dimension (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainvp;
+ --ap;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "TP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrtr_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL */
+
+ n = nval[in];
+ lda = max(1,n);
+ lap = lda * (lda + 1) / 2;
+ *(unsigned char *)xtype = 'N';
+
+ for (imat = 1; imat <= 10; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L70;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Call CLATTP to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "CLATTP", (ftnlen)32, (ftnlen)6);
+ clattp_(&imat, uplo, "No transpose", diag, iseed, &n, &ap[1],
+ &x[1], &work[1], &rwork[1], &info);
+
+/* Set IDIAG = 1 for non-unit matrices, 2 for unit. */
+
+ if (lsame_(diag, "N")) {
+ idiag = 1;
+ } else {
+ idiag = 2;
+ }
+
+/* + TEST 1 */
+/* Form the inverse of A. */
+
+ if (n > 0) {
+ ccopy_(&lap, &ap[1], &c__1, &ainvp[1], &c__1);
+ }
+ s_copy(srnamc_1.srnamt, "CTPTRI", (ftnlen)32, (ftnlen)6);
+ ctptri_(uplo, diag, &n, &ainvp[1], &info);
+
+/* Check error code from CTPTRI. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__2[0] = 1, a__1[0] = uplo;
+ i__2[1] = 1, a__1[1] = diag;
+ s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2);
+ alaerh_(path, "CTPTRI", &info, &c__0, ch__1, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ anorm = clantp_("I", uplo, diag, &n, &ap[1], &rwork[1]);
+ ainvnm = clantp_("I", uplo, diag, &n, &ainvp[1], &rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondi = 1.f;
+ } else {
+ rcondi = 1.f / anorm / ainvnm;
+ }
+
+/* Compute the residual for the triangular matrix times its */
+/* inverse. Also compute the 1-norm condition number of A. */
+
+ ctpt01_(uplo, diag, &n, &ap[1], &ainvp[1], &rcondo, &rwork[1],
+ result);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, or A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[
+ itran - 1];
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+
+/* + TEST 2 */
+/* Solve and compute residual for op(A)*x = b. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ clarhs_(path, xtype, uplo, trans, &n, &n, &c__0, &
+ idiag, &nrhs, &ap[1], &lap, &xact[1], &lda, &
+ b[1], &lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "CTPTRS", (ftnlen)32, (ftnlen)
+ 6);
+ ctptrs_(uplo, trans, diag, &n, &nrhs, &ap[1], &x[1], &
+ lda, &info);
+
+/* Check error code from CTPTRS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__4[0] = 1, a__2[0] = uplo;
+ i__4[1] = 1, a__2[1] = trans;
+ i__4[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)3);
+ alaerh_(path, "CTPTRS", &info, &c__0, ch__2, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ ctpt02_(uplo, trans, diag, &n, &nrhs, &ap[1], &x[1], &
+ lda, &b[1], &lda, &work[1], &rwork[1], &
+ result[1]);
+
+/* + TEST 3 */
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* + TESTS 4, 5, and 6 */
+/* Use iterative refinement to improve the solution and */
+/* compute error bounds. */
+
+ s_copy(srnamc_1.srnamt, "CTPRFS", (ftnlen)32, (ftnlen)
+ 6);
+ ctprfs_(uplo, trans, diag, &n, &nrhs, &ap[1], &b[1], &
+ lda, &x[1], &lda, &rwork[1], &rwork[nrhs + 1],
+ &work[1], &rwork[(nrhs << 1) + 1], &info);
+
+/* Check error code from CTPRFS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__4[0] = 1, a__2[0] = uplo;
+ i__4[1] = 1, a__2[1] = trans;
+ i__4[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)3);
+ alaerh_(path, "CTPRFS", &info, &c__0, ch__2, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+ ctpt05_(uplo, trans, diag, &n, &nrhs, &ap[1], &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[1], &
+ rwork[nrhs + 1], &result[4]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += 5;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* + TEST 7 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+ s_copy(srnamc_1.srnamt, "CTPCON", (ftnlen)32, (ftnlen)6);
+ ctpcon_(norm, uplo, diag, &n, &ap[1], &rcond, &work[1], &
+ rwork[1], &info);
+
+/* Check error code from CTPCON. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__4[0] = 1, a__2[0] = norm;
+ i__4[1] = 1, a__2[1] = uplo;
+ i__4[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)3);
+ alaerh_(path, "CTPCON", &info, &c__0, ch__2, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ ctpt06_(&rcond, &rcondc, uplo, diag, &n, &ap[1], &rwork[1]
+, &result[6]);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, "CTPCON", (ftnlen)6);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L50: */
+ }
+/* L60: */
+ }
+L70:
+ ;
+ }
+
+/* Use pathological test matrices to test CLATPS. */
+
+ for (imat = 11; imat <= 18; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L100;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, or A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[itran
+ - 1];
+
+/* Call CLATTP to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "CLATTP", (ftnlen)32, (ftnlen)6);
+ clattp_(&imat, uplo, trans, diag, iseed, &n, &ap[1], &x[1]
+, &work[1], &rwork[1], &info);
+
+/* + TEST 8 */
+/* Solve the system op(A)*x = b. */
+
+ s_copy(srnamc_1.srnamt, "CLATPS", (ftnlen)32, (ftnlen)6);
+ ccopy_(&n, &x[1], &c__1, &b[1], &c__1);
+ clatps_(uplo, trans, diag, "N", &n, &ap[1], &b[1], &scale,
+ &rwork[1], &info);
+
+/* Check error code from CLATPS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__5[0] = 1, a__3[0] = uplo;
+ i__5[1] = 1, a__3[1] = trans;
+ i__5[2] = 1, a__3[2] = diag;
+ i__5[3] = 1, a__3[3] = "N";
+ s_cat(ch__3, a__3, i__5, &c__4, (ftnlen)4);
+ alaerh_(path, "CLATPS", &info, &c__0, ch__3, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ ctpt03_(uplo, trans, diag, &n, &c__1, &ap[1], &scale, &
+ rwork[1], &c_b103, &b[1], &lda, &x[1], &lda, &
+ work[1], &result[7]);
+
+/* + TEST 9 */
+/* Solve op(A)*x = b again with NORMIN = 'Y'. */
+
+ ccopy_(&n, &x[1], &c__1, &b[n + 1], &c__1);
+ clatps_(uplo, trans, diag, "Y", &n, &ap[1], &b[n + 1], &
+ scale, &rwork[1], &info);
+
+/* Check error code from CLATPS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__5[0] = 1, a__3[0] = uplo;
+ i__5[1] = 1, a__3[1] = trans;
+ i__5[2] = 1, a__3[2] = diag;
+ i__5[3] = 1, a__3[3] = "Y";
+ s_cat(ch__3, a__3, i__5, &c__4, (ftnlen)4);
+ alaerh_(path, "CLATPS", &info, &c__0, ch__3, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ ctpt03_(uplo, trans, diag, &n, &c__1, &ap[1], &scale, &
+ rwork[1], &c_b103, &b[n + 1], &lda, &x[1], &lda, &
+ work[1], &result[8]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, "CLATPS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ ++nfail;
+ }
+ if (result[8] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, "CLATPS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "Y", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[8], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ ++nfail;
+ }
+ nrun += 2;
+/* L80: */
+ }
+/* L90: */
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CCHKTP */
+
+} /* cchktp_ */
diff --git a/TESTING/LIN/cchktr.c b/TESTING/LIN/cchktr.c
new file mode 100644
index 0000000..8cbb955
--- /dev/null
+++ b/TESTING/LIN/cchktr.c
@@ -0,0 +1,725 @@
+/* cchktr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__7 = 7;
+static integer c__4 = 4;
+static real c_b99 = 1.f;
+static integer c__8 = 8;
+static integer c__9 = 9;
+
+/* Subroutine */ int cchktr_(logical *dotype, integer *nn, integer *nval,
+ integer *nnb, integer *nbval, integer *nns, integer *nsval, real *
+ thresh, logical *tsterr, integer *nmax, complex *a, complex *ainv,
+ complex *b, complex *x, complex *xact, complex *work, real *rwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', DIAG='\002,a1,\002'"
+ ", N=\002,i5,\002, NB=\002,i4,\002, type \002,i2,\002, test(\002,"
+ "i2,\002)= \002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', TRANS='\002,a1,\002"
+ "', DIAG='\002,a1,\002', N=\002,i5,\002, NB=\002,i4,\002, type"
+ " \002,i2,\002, test(\002,i2,\002)= \002,g12"
+ ".5)";
+ static char fmt_9997[] = "(\002 NORM='\002,a1,\002', UPLO ='\002,a1,\002"
+ "', N=\002,i5,\002,\002,11x,\002 type \002,i2,\002, test(\002,i2"
+ ",\002)=\002,g12.5)";
+ static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
+ "'\002,a1,\002', '\002,a1,\002',\002,i5,\002, ... ), type \002,i2,"
+ "\002, test(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2], a__2[3], a__3[4];
+ integer i__1, i__2, i__3[2], i__4, i__5[3], i__6[4];
+ char ch__1[2], ch__2[3], ch__3[4];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
+ char **, integer *, integer *, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, nb, in, lda, inb;
+ char diag[1];
+ integer imat, info;
+ char path[3];
+ integer irhs, nrhs;
+ char norm[1], uplo[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer idiag;
+ extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *);
+ real scale;
+ integer nfail, iseed[4];
+ extern logical lsame_(char *, char *);
+ real rcond, anorm;
+ integer itran;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), ctrt01_(char *, char *, integer *, complex
+ *, integer *, complex *, integer *, real *, real *, real *), ctrt02_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, complex *, real *, real *),
+ ctrt03_(char *, char *, char *, integer *, integer *, complex *,
+ integer *, real *, real *, real *, complex *, integer *, complex *
+, integer *, complex *, real *), ctrt05_(
+ char *, char *, char *, integer *, integer *, complex *, integer *
+, complex *, integer *, complex *, integer *, complex *, integer *
+, real *, real *, real *), ctrt06_(real *,
+ real *, char *, char *, integer *, complex *, integer *, real *,
+ real *);
+ char trans[1];
+ integer iuplo, nerrs;
+ real dummy;
+ char xtype[1];
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ real rcondc;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), clarhs_(char *, char
+ *, char *, char *, integer *, integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, integer *, integer *);
+ real rcondi;
+ extern doublereal clantr_(char *, char *, char *, integer *, integer *,
+ complex *, integer *, real *);
+ real rcondo;
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int clatrs_(char *, char *, char *, char *,
+ integer *, complex *, integer *, complex *, real *, real *,
+ integer *), clattr_(integer *,
+ char *, char *, char *, integer *, integer *, complex *, integer *
+, complex *, complex *, real *, integer *)
+ , ctrcon_(char *, char *, char *, integer *, complex *, integer *,
+ real *, complex *, real *, integer *),
+ xlaenv_(integer *, integer *), cerrtr_(char *, integer *),
+ ctrrfs_(char *, char *, char *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, real *,
+ real *, complex *, real *, integer *),
+ ctrtri_(char *, char *, integer *, complex *, integer *, integer *
+);
+ real result[9];
+ extern /* Subroutine */ int ctrtrs_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___27 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKTR tests CTRTRI, -TRS, -RFS, and -CON, and CLATRS */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The leading dimension of the work arrays. */
+/* NMAX >= the maximum value of N in NVAL. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "TR", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrtr_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL */
+
+ n = nval[in];
+ lda = max(1,n);
+ *(unsigned char *)xtype = 'N';
+
+ for (imat = 1; imat <= 10; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L80;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Call CLATTR to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "CLATTR", (ftnlen)32, (ftnlen)6);
+ clattr_(&imat, uplo, "No transpose", diag, iseed, &n, &a[1], &
+ lda, &x[1], &work[1], &rwork[1], &info);
+
+/* Set IDIAG = 1 for non-unit matrices, 2 for unit. */
+
+ if (lsame_(diag, "N")) {
+ idiag = 1;
+ } else {
+ idiag = 2;
+ }
+
+ i__2 = *nnb;
+ for (inb = 1; inb <= i__2; ++inb) {
+
+/* Do for each blocksize in NBVAL */
+
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* + TEST 1 */
+/* Form the inverse of A. */
+
+ clacpy_(uplo, &n, &n, &a[1], &lda, &ainv[1], &lda);
+ s_copy(srnamc_1.srnamt, "CTRTRI", (ftnlen)32, (ftnlen)6);
+ ctrtri_(uplo, diag, &n, &ainv[1], &lda, &info);
+
+/* Check error code from CTRTRI. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = uplo;
+ i__3[1] = 1, a__1[1] = diag;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ alaerh_(path, "CTRTRI", &info, &c__0, ch__1, &n, &n, &
+ c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ anorm = clantr_("I", uplo, diag, &n, &n, &a[1], &lda, &
+ rwork[1]);
+ ainvnm = clantr_("I", uplo, diag, &n, &n, &ainv[1], &lda,
+ &rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondi = 1.f;
+ } else {
+ rcondi = 1.f / anorm / ainvnm;
+ }
+
+/* Compute the residual for the triangular matrix times */
+/* its inverse. Also compute the 1-norm condition number */
+/* of A. */
+
+ ctrt01_(uplo, diag, &n, &a[1], &lda, &ainv[1], &lda, &
+ rcondo, &rwork[1], result);
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+/* Skip remaining tests if not the first block size. */
+
+ if (inb != 1) {
+ goto L60;
+ }
+
+ i__4 = *nns;
+ for (irhs = 1; irhs <= i__4; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, or A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itran - 1];
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+
+/* + TEST 2 */
+/* Solve and compute residual for op(A)*x = b. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (
+ ftnlen)6);
+ clarhs_(path, xtype, uplo, trans, &n, &n, &c__0, &
+ idiag, &nrhs, &a[1], &lda, &xact[1], &lda,
+ &b[1], &lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "CTRTRS", (ftnlen)32, (
+ ftnlen)6);
+ ctrtrs_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
+ &x[1], &lda, &info);
+
+/* Check error code from CTRTRS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__5[0] = 1, a__2[0] = uplo;
+ i__5[1] = 1, a__2[1] = trans;
+ i__5[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3);
+ alaerh_(path, "CTRTRS", &info, &c__0, ch__2, &
+ n, &n, &c_n1, &c_n1, &nrhs, &imat, &
+ nfail, &nerrs, nout);
+ }
+
+/* This line is needed on a Sun SPARCstation. */
+
+ if (n > 0) {
+ dummy = a[1].r;
+ }
+
+ ctrt02_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
+ &x[1], &lda, &b[1], &lda, &work[1], &
+ rwork[1], &result[1]);
+
+/* + TEST 3 */
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* + TESTS 4, 5, and 6 */
+/* Use iterative refinement to improve the solution */
+/* and compute error bounds. */
+
+ s_copy(srnamc_1.srnamt, "CTRRFS", (ftnlen)32, (
+ ftnlen)6);
+ ctrrfs_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
+ &b[1], &lda, &x[1], &lda, &rwork[1], &
+ rwork[nrhs + 1], &work[1], &rwork[(nrhs <<
+ 1) + 1], &info);
+
+/* Check error code from CTRRFS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__5[0] = 1, a__2[0] = uplo;
+ i__5[1] = 1, a__2[1] = trans;
+ i__5[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3);
+ alaerh_(path, "CTRRFS", &info, &c__0, ch__2, &
+ n, &n, &c_n1, &c_n1, &nrhs, &imat, &
+ nfail, &nerrs, nout);
+ }
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+ ctrt05_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
+ &b[1], &lda, &x[1], &lda, &xact[1], &lda,
+ &rwork[1], &rwork[nrhs + 1], &result[4]);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += 5;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* + TEST 7 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+ s_copy(srnamc_1.srnamt, "CTRCON", (ftnlen)32, (ftnlen)
+ 6);
+ ctrcon_(norm, uplo, diag, &n, &a[1], &lda, &rcond, &
+ work[1], &rwork[1], &info);
+
+/* Check error code from CTRCON. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__5[0] = 1, a__2[0] = norm;
+ i__5[1] = 1, a__2[1] = uplo;
+ i__5[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3);
+ alaerh_(path, "CTRCON", &info, &c__0, ch__2, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ ctrt06_(&rcond, &rcondc, uplo, diag, &n, &a[1], &lda,
+ &rwork[1], &result[6]);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L50: */
+ }
+L60:
+ ;
+ }
+/* L70: */
+ }
+L80:
+ ;
+ }
+
+/* Use pathological test matrices to test CLATRS. */
+
+ for (imat = 11; imat <= 18; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L110;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, and A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[itran
+ - 1];
+
+/* Call CLATTR to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "CLATTR", (ftnlen)32, (ftnlen)6);
+ clattr_(&imat, uplo, trans, diag, iseed, &n, &a[1], &lda,
+ &x[1], &work[1], &rwork[1], &info);
+
+/* + TEST 8 */
+/* Solve the system op(A)*x = b. */
+
+ s_copy(srnamc_1.srnamt, "CLATRS", (ftnlen)32, (ftnlen)6);
+ ccopy_(&n, &x[1], &c__1, &b[1], &c__1);
+ clatrs_(uplo, trans, diag, "N", &n, &a[1], &lda, &b[1], &
+ scale, &rwork[1], &info);
+
+/* Check error code from CLATRS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__6[0] = 1, a__3[0] = uplo;
+ i__6[1] = 1, a__3[1] = trans;
+ i__6[2] = 1, a__3[2] = diag;
+ i__6[3] = 1, a__3[3] = "N";
+ s_cat(ch__3, a__3, i__6, &c__4, (ftnlen)4);
+ alaerh_(path, "CLATRS", &info, &c__0, ch__3, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ ctrt03_(uplo, trans, diag, &n, &c__1, &a[1], &lda, &scale,
+ &rwork[1], &c_b99, &b[1], &lda, &x[1], &lda, &
+ work[1], &result[7]);
+
+/* + TEST 9 */
+/* Solve op(A)*X = b again with NORMIN = 'Y'. */
+
+ ccopy_(&n, &x[1], &c__1, &b[n + 1], &c__1);
+ clatrs_(uplo, trans, diag, "Y", &n, &a[1], &lda, &b[n + 1]
+, &scale, &rwork[1], &info);
+
+/* Check error code from CLATRS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__6[0] = 1, a__3[0] = uplo;
+ i__6[1] = 1, a__3[1] = trans;
+ i__6[2] = 1, a__3[2] = diag;
+ i__6[3] = 1, a__3[3] = "Y";
+ s_cat(ch__3, a__3, i__6, &c__4, (ftnlen)4);
+ alaerh_(path, "CLATRS", &info, &c__0, ch__3, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ ctrt03_(uplo, trans, diag, &n, &c__1, &a[1], &lda, &scale,
+ &rwork[1], &c_b99, &b[n + 1], &lda, &x[1], &lda,
+ &work[1], &result[8]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "CLATRS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ ++nfail;
+ }
+ if (result[8] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "CLATRS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "Y", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[8], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ ++nfail;
+ }
+ nrun += 2;
+/* L90: */
+ }
+/* L100: */
+ }
+L110:
+ ;
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CCHKTR */
+
+} /* cchktr_ */
diff --git a/TESTING/LIN/cchktz.c b/TESTING/LIN/cchktz.c
new file mode 100644
index 0000000..67cce04
--- /dev/null
+++ b/TESTING/LIN/cchktz.c
@@ -0,0 +1,387 @@
+/* cchktz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static complex c_b10 = {0.f,0.f};
+static real c_b15 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int cchktz_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, real *thresh, logical *tsterr, complex *a,
+ complex *copya, real *s, real *copys, complex *tau, complex *work,
+ real *rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, type"
+ " \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, im, in, lda;
+ real eps;
+ integer mode, info;
+ char path[3];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4], imode;
+ extern doublereal cqrt12_(integer *, integer *, complex *, integer *,
+ real *, complex *, integer *, real *);
+ integer mnmin;
+ extern doublereal crzt01_(integer *, integer *, complex *, complex *,
+ integer *, complex *, complex *, integer *), crzt02_(integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *),
+ ctzt01_(integer *, integer *, complex *, complex *, integer *,
+ complex *, complex *, integer *), ctzt02_(integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *);
+ integer nerrs, lwork;
+ extern /* Subroutine */ int cgeqr2_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), alasum_(char *, integer *, integer *, integer *, integer
+ *), clatms_(integer *, integer *, char *, integer *, char
+ *, real *, integer *, real *, real *, integer *, integer *, char *
+, complex *, integer *, complex *, integer *), slaord_(char *, integer *, real *, integer *),
+ cerrtz_(char *, integer *), ctzrqf_(integer *, integer *,
+ complex *, integer *, complex *, integer *);
+ real result[6];
+ extern /* Subroutine */ int ctzrzf_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___21 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CCHKTZ tests CTZRQF and CTZRZF. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) COMPLEX array, dimension (MMAX*NMAX) */
+/* where MMAX is the maximum value of M in MVAL and NMAX is the */
+/* maximum value of N in NVAL. */
+
+/* COPYA (workspace) COMPLEX array, dimension (MMAX*NMAX) */
+
+/* S (workspace) REAL array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* COPYS (workspace) REAL array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* TAU (workspace) COMPLEX array, dimension (MMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (MMAX*NMAX + 4*NMAX + MMAX) */
+
+/* RWORK (workspace) REAL array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --tau;
+ --copys;
+ --s;
+ --copya;
+ --a;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "TZ", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = slamch_("Epsilon");
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrtz_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+
+/* Do for each value of M in MVAL. */
+
+ m = mval[im];
+ lda = max(1,m);
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+
+/* Do for each value of N in NVAL for which M .LE. N. */
+
+ n = nval[in];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__3 = 1, i__4 = n * n + (m << 2) + n;
+ lwork = max(i__3,i__4);
+
+ if (m <= n) {
+ for (imode = 1; imode <= 3; ++imode) {
+
+/* Do for each type of singular value distribution. */
+/* 0: zero matrix */
+/* 1: one small singular value */
+/* 2: exponential distribution */
+
+ mode = imode - 1;
+
+/* Test CTZRQF */
+
+/* Generate test matrix of size m by n using */
+/* singular value distribution indicated by `mode'. */
+
+ if (mode == 0) {
+ claset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
+ i__3 = mnmin;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ copys[i__] = 0.f;
+/* L20: */
+ }
+ } else {
+ r__1 = 1.f / eps;
+ clatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
+ copys[1], &imode, &r__1, &c_b15, &m, &n,
+ "No packing", &a[1], &lda, &work[1], &info);
+ cgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
+ 1], &info);
+ i__3 = m - 1;
+ claset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
+ lda);
+ slaord_("Decreasing", &mnmin, ©s[1], &c__1);
+ }
+
+/* Save A and its singular values */
+
+ clacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
+
+/* Call CTZRQF to reduce the upper trapezoidal matrix to */
+/* upper triangular form. */
+
+ s_copy(srnamc_1.srnamt, "CTZRQF", (ftnlen)32, (ftnlen)6);
+ ctzrqf_(&m, &n, &a[1], &lda, &tau[1], &info);
+
+/* Compute norm(svd(a) - svd(r)) */
+
+ result[0] = cqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
+ 1], &lwork, &rwork[1]);
+
+/* Compute norm( A - R*Q ) */
+
+ result[1] = ctzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
+ 1], &work[1], &lwork);
+
+/* Compute norm(Q'*Q - I). */
+
+ result[2] = ctzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
+, &lwork);
+
+/* Test CTZRZF */
+
+/* Generate test matrix of size m by n using */
+/* singular value distribution indicated by `mode'. */
+
+ if (mode == 0) {
+ claset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
+ i__3 = mnmin;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ copys[i__] = 0.f;
+/* L30: */
+ }
+ } else {
+ r__1 = 1.f / eps;
+ clatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
+ copys[1], &imode, &r__1, &c_b15, &m, &n,
+ "No packing", &a[1], &lda, &work[1], &info);
+ cgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
+ 1], &info);
+ i__3 = m - 1;
+ claset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
+ lda);
+ slaord_("Decreasing", &mnmin, ©s[1], &c__1);
+ }
+
+/* Save A and its singular values */
+
+ clacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
+
+/* Call CTZRZF to reduce the upper trapezoidal matrix to */
+/* upper triangular form. */
+
+ s_copy(srnamc_1.srnamt, "CTZRZF", (ftnlen)32, (ftnlen)6);
+ ctzrzf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lwork, &
+ info);
+
+/* Compute norm(svd(a) - svd(r)) */
+
+ result[3] = cqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
+ 1], &lwork, &rwork[1]);
+
+/* Compute norm( A - R*Q ) */
+
+ result[4] = crzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
+ 1], &work[1], &lwork);
+
+/* Compute norm(Q'*Q - I). */
+
+ result[5] = crzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
+, &lwork);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___21.ciunit = *nout;
+ s_wsfe(&io___21);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L40: */
+ }
+ nrun += 6;
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+
+/* End if CCHKTZ */
+
+ return 0;
+} /* cchktz_ */
diff --git a/TESTING/LIN/cdrvgb.c b/TESTING/LIN/cdrvgb.c
new file mode 100644
index 0000000..6fb3097
--- /dev/null
+++ b/TESTING/LIN/cdrvgb.c
@@ -0,0 +1,1122 @@
+/* cdrvgb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static complex c_b48 = {0.f,0.f};
+static complex c_b49 = {1.f,0.f};
+static integer c__6 = 6;
+static integer c__7 = 7;
+
+/* Subroutine */ int cdrvgb_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, complex *a, integer *la,
+ complex *afb, integer *lafb, complex *asav, complex *b, complex *
+ bsav, complex *x, complex *xact, real *s, complex *work, real *rwork,
+ integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*4] = "N" "R" "C" "B";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 *** In CDRVGB, LA=\002,i5,\002 is too sm"
+ "all for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> In"
+ "crease LA to at least \002,i5)";
+ static char fmt_9998[] = "(\002 *** In CDRVGB, LAFB=\002,i5,\002 is too "
+ "small for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> "
+ "Increase LAFB to at least \002,i5)";
+ static char fmt_9997[] = "(1x,a,\002, N=\002,i5,\002, KL=\002,i5,\002, K"
+ "U=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)"
+ ;
+ static char fmt_9995[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002"
+ ",i5,\002,\002,i5,\002,\002,i5,\002,...), EQUED='\002,a1,\002', t"
+ "ype \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002"
+ ",i5,\002,\002,i5,\002,\002,i5,\002,...), type \002,i1,\002, test("
+ "\002,i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10,
+ i__11[2];
+ real r__1, r__2;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+ double c_abs(complex *);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, k1, nb, in, kl, ku, nt, lda, ldb, ikl, nkl,
+ iku, nku;
+ char fact[1];
+ integer ioff, mode;
+ real amax;
+ char path[3];
+ integer imat, info;
+ char dist[1];
+ real rdum[1];
+ char type__[1];
+ integer nrun, ldafb;
+ extern /* Subroutine */ int cgbt01_(integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, integer *,
+ complex *, real *), cgbt02_(char *, integer *, integer *, integer
+ *, integer *, integer *, complex *, integer *, complex *, integer
+ *, complex *, integer *, real *), cgbt05_(char *, integer
+ *, integer *, integer *, integer *, complex *, integer *, complex
+ *, integer *, complex *, integer *, complex *, integer *, real *,
+ real *, real *);
+ integer ifact;
+ extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *);
+ integer nfail, iseed[4], nfact;
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ real rcond, roldc;
+ extern /* Subroutine */ int cgbsv_(integer *, integer *, integer *,
+ integer *, complex *, integer *, integer *, complex *, integer *,
+ integer *);
+ integer nimat;
+ real roldi;
+ extern doublereal sget06_(real *, real *);
+ real anorm;
+ integer itran;
+ logical equil;
+ real roldo;
+ char trans[1];
+ integer izero, nerrs;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), aladhd_(integer *, char *);
+ extern doublereal clangb_(char *, integer *, integer *, integer *,
+ complex *, integer *, real *), clange_(char *, integer *,
+ integer *, complex *, integer *, real *);
+ extern /* Subroutine */ int claqgb_(integer *, integer *, integer *,
+ integer *, complex *, integer *, real *, real *, real *, real *,
+ real *, char *), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ logical prefac;
+ real colcnd;
+ extern doublereal clantb_(char *, char *, char *, integer *, integer *,
+ complex *, integer *, real *);
+ extern /* Subroutine */ int cgbequ_(integer *, integer *, integer *,
+ integer *, complex *, integer *, real *, real *, real *, real *,
+ real *, integer *);
+ real rcondc;
+ extern doublereal slamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int cgbtrf_(integer *, integer *, integer *,
+ integer *, complex *, integer *, integer *, integer *);
+ integer iequed;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *);
+ real rcondi;
+ extern /* Subroutine */ int clarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, integer *,
+ integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), alasvm_(char *, integer *, integer *, integer *, integer
+ *);
+ real cndnum, anormi, rcondo, ainvnm;
+ extern /* Subroutine */ int cgbtrs_(char *, integer *, integer *, integer
+ *, integer *, complex *, integer *, integer *, complex *, integer
+ *, integer *), clatms_(integer *, integer *, char *,
+ integer *, char *, real *, integer *, real *, real *, integer *,
+ integer *, char *, complex *, integer *, complex *, integer *);
+ logical trfcon;
+ real anormo, rowcnd;
+ extern /* Subroutine */ int cgbsvx_(char *, char *, integer *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ integer *, char *, real *, real *, complex *, integer *, complex *
+, integer *, real *, real *, real *, complex *, real *, integer *), xlaenv_(integer *, integer *);
+ real anrmpv;
+ extern /* Subroutine */ int cerrvx_(char *, integer *);
+ real result[7], rpvgrw;
+
+ /* Fortran I/O blocks */
+ static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___73 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___74 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___75 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___76 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___77 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___80 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVGB tests the driver routines CGBSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) COMPLEX array, dimension (LA) */
+
+/* LA (input) INTEGER */
+/* The length of the array A. LA >= (2*NMAX-1)*NMAX */
+/* where NMAX is the largest entry in NVAL. */
+
+/* AFB (workspace) COMPLEX array, dimension (LAFB) */
+
+/* LAFB (input) INTEGER */
+/* The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX */
+/* where NMAX is the largest entry in NVAL. */
+
+/* ASAV (workspace) COMPLEX array, dimension (LA) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* S (workspace) REAL array, dimension (2*NMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(3,NRHS,NMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NRHS)) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afb;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "GB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ ldb = max(n,1);
+ *(unsigned char *)xtype = 'N';
+
+/* Set limits on the number of loop iterations. */
+
+/* Computing MAX */
+ i__2 = 1, i__3 = min(n,4);
+ nkl = max(i__2,i__3);
+ if (n == 0) {
+ nkl = 1;
+ }
+ nku = nkl;
+ nimat = 8;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nkl;
+ for (ikl = 1; ikl <= i__2; ++ikl) {
+
+/* Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes */
+/* it easier to skip redundant values for small values of N. */
+
+ if (ikl == 1) {
+ kl = 0;
+ } else if (ikl == 2) {
+/* Computing MAX */
+ i__3 = n - 1;
+ kl = max(i__3,0);
+ } else if (ikl == 3) {
+ kl = (n * 3 - 1) / 4;
+ } else if (ikl == 4) {
+ kl = (n + 1) / 4;
+ }
+ i__3 = nku;
+ for (iku = 1; iku <= i__3; ++iku) {
+
+/* Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order */
+/* makes it easier to skip redundant values for small */
+/* values of N. */
+
+ if (iku == 1) {
+ ku = 0;
+ } else if (iku == 2) {
+/* Computing MAX */
+ i__4 = n - 1;
+ ku = max(i__4,0);
+ } else if (iku == 3) {
+ ku = (n * 3 - 1) / 4;
+ } else if (iku == 4) {
+ ku = (n + 1) / 4;
+ }
+
+/* Check that A and AFB are big enough to generate this */
+/* matrix. */
+
+ lda = kl + ku + 1;
+ ldafb = (kl << 1) + ku + 1;
+ if (lda * n > *la || ldafb * n > *lafb) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (lda * n > *la) {
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, (char *)&(*la), (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ i__4 = n * (kl + ku + 1);
+ do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ if (ldafb * n > *lafb) {
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__1, (char *)&(*lafb), (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ i__4 = n * ((kl << 1) + ku + 1);
+ do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ goto L130;
+ }
+
+ i__4 = nimat;
+ for (imat = 1; imat <= i__4; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+/* Skip types 2, 3, or 4 if the matrix is too small. */
+
+ zerot = imat >= 2 && imat <= 4;
+ if (zerot && n < imat - 1) {
+ goto L120;
+ }
+
+/* Set up parameters with CLATB4 and generate a */
+/* test matrix with CLATMS. */
+
+ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
+ mode, &cndnum, dist);
+ rcondc = 1.f / cndnum;
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "Z", &a[1], &lda, &work[
+ 1], &info);
+
+/* Check the error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, " ", &n, &n, &
+ kl, &ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L120;
+ }
+
+/* For types 2, 3, and 4, zero one or more columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ izero = 0;
+ if (zerot) {
+ if (imat == 2) {
+ izero = 1;
+ } else if (imat == 3) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 4) {
+/* Computing MAX */
+ i__5 = 1, i__6 = ku + 2 - izero;
+ i1 = max(i__5,i__6);
+/* Computing MIN */
+ i__5 = kl + ku + 1, i__6 = ku + 1 + (n - izero);
+ i2 = min(i__5,i__6);
+ i__5 = i2;
+ for (i__ = i1; i__ <= i__5; ++i__) {
+ i__6 = ioff + i__;
+ a[i__6].r = 0.f, a[i__6].i = 0.f;
+/* L20: */
+ }
+ } else {
+ i__5 = n;
+ for (j = izero; j <= i__5; ++j) {
+/* Computing MAX */
+ i__6 = 1, i__7 = ku + 2 - j;
+/* Computing MIN */
+ i__9 = kl + ku + 1, i__10 = ku + 1 + (n - j);
+ i__8 = min(i__9,i__10);
+ for (i__ = max(i__6,i__7); i__ <= i__8; ++i__)
+ {
+ i__6 = ioff + i__;
+ a[i__6].r = 0.f, a[i__6].i = 0.f;
+/* L30: */
+ }
+ ioff += lda;
+/* L40: */
+ }
+ }
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ i__5 = kl + ku + 1;
+ clacpy_("Full", &i__5, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 4; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__5 = nfact;
+ for (ifact = 1; ifact <= i__5; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L100;
+ }
+ rcondo = 0.f;
+ rcondi = 0.f;
+
+ } else if (! nofact) {
+
+/* Compute the condition number for comparison */
+/* with the value returned by SGESVX (FACT = */
+/* 'N' reuses the condition number from the */
+/* previous iteration with FACT = 'F'). */
+
+ i__8 = kl + ku + 1;
+ clacpy_("Full", &i__8, &n, &asav[1], &lda, &
+ afb[kl + 1], &ldafb);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ cgbequ_(&n, &n, &kl, &ku, &afb[kl + 1], &
+ ldafb, &s[1], &s[n + 1], &rowcnd,
+ &colcnd, &amax, &info);
+ if (info == 0 && n > 0) {
+ if (lsame_(equed, "R")) {
+ rowcnd = 0.f;
+ colcnd = 1.f;
+ } else if (lsame_(equed, "C")) {
+ rowcnd = 1.f;
+ colcnd = 0.f;
+ } else if (lsame_(equed, "B")) {
+ rowcnd = 0.f;
+ colcnd = 0.f;
+ }
+
+/* Equilibrate the matrix. */
+
+ claqgb_(&n, &n, &kl, &ku, &afb[kl + 1]
+, &ldafb, &s[1], &s[n + 1], &
+ rowcnd, &colcnd, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in CGET04. */
+
+ if (equil) {
+ roldo = rcondo;
+ roldi = rcondi;
+ }
+
+/* Compute the 1-norm and infinity-norm of A. */
+
+ anormo = clangb_("1", &n, &kl, &ku, &afb[kl +
+ 1], &ldafb, &rwork[1]);
+ anormi = clangb_("I", &n, &kl, &ku, &afb[kl +
+ 1], &ldafb, &rwork[1]);
+
+/* Factor the matrix A. */
+
+ cgbtrf_(&n, &n, &kl, &ku, &afb[1], &ldafb, &
+ iwork[1], &info);
+
+/* Form the inverse of A. */
+
+ claset_("Full", &n, &n, &c_b48, &c_b49, &work[
+ 1], &ldb);
+ s_copy(srnamc_1.srnamt, "CGBTRS", (ftnlen)32,
+ (ftnlen)6);
+ cgbtrs_("No transpose", &n, &kl, &ku, &n, &
+ afb[1], &ldafb, &iwork[1], &work[1], &
+ ldb, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = clange_("1", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormo <= 0.f || ainvnm <= 0.f) {
+ rcondo = 1.f;
+ } else {
+ rcondo = 1.f / anormo / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number */
+/* of A. */
+
+ ainvnm = clange_("I", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormi <= 0.f || ainvnm <= 0.f) {
+ rcondi = 1.f;
+ } else {
+ rcondi = 1.f / anormi / ainvnm;
+ }
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for each value of TRANS. */
+
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Restore the matrix A. */
+
+ i__8 = kl + ku + 1;
+ clacpy_("Full", &i__8, &n, &asav[1], &lda, &a[
+ 1], &lda);
+
+/* Form an exact solution and set the right hand */
+/* side. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32,
+ (ftnlen)6);
+ clarhs_(path, xtype, "Full", trans, &n, &n, &
+ kl, &ku, nrhs, &a[1], &lda, &xact[1],
+ &ldb, &b[1], &ldb, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ clacpy_("Full", &n, nrhs, &b[1], &ldb, &bsav[
+ 1], &ldb);
+
+ if (nofact && itran == 1) {
+
+/* --- Test CGBSV --- */
+
+/* Compute the LU factorization of the matrix */
+/* and solve the system. */
+
+ i__8 = kl + ku + 1;
+ clacpy_("Full", &i__8, &n, &a[1], &lda, &
+ afb[kl + 1], &ldafb);
+ clacpy_("Full", &n, nrhs, &b[1], &ldb, &x[
+ 1], &ldb);
+
+ s_copy(srnamc_1.srnamt, "CGBSV ", (ftnlen)
+ 32, (ftnlen)6);
+ cgbsv_(&n, &kl, &ku, nrhs, &afb[1], &
+ ldafb, &iwork[1], &x[1], &ldb, &
+ info);
+
+/* Check error code from CGBSV . */
+
+ if (info != izero) {
+ alaerh_(path, "CGBSV ", &info, &izero,
+ " ", &n, &n, &kl, &ku, nrhs,
+ &imat, &nfail, &nerrs, nout);
+ }
+
+/* Reconstruct matrix from factors and */
+/* compute residual. */
+
+ cgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
+ afb[1], &ldafb, &iwork[1], &work[
+ 1], result);
+ nt = 1;
+ if (izero == 0) {
+
+/* Compute residual of the computed */
+/* solution. */
+
+ clacpy_("Full", &n, nrhs, &b[1], &ldb,
+ &work[1], &ldb);
+ cgbt02_("No transpose", &n, &n, &kl, &
+ ku, nrhs, &a[1], &lda, &x[1],
+ &ldb, &work[1], &ldb, &result[
+ 1]);
+
+/* Check solution from generated exact */
+/* solution. */
+
+ cget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &rcondc, &result[2])
+ ;
+ nt = 3;
+ }
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ i__8 = nt;
+ for (k = 1; k <= i__8; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___65.ciunit = *nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, "CGBSV ", (ftnlen)6)
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k -
+ 1], (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L50: */
+ }
+ nrun += nt;
+ }
+
+/* --- Test CGBSVX --- */
+
+ if (! prefac) {
+ i__8 = (kl << 1) + ku + 1;
+ claset_("Full", &i__8, &n, &c_b48, &c_b48,
+ &afb[1], &ldafb);
+ }
+ claset_("Full", &n, nrhs, &c_b48, &c_b48, &x[
+ 1], &ldb);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ claqgb_(&n, &n, &kl, &ku, &a[1], &lda, &s[
+ 1], &s[n + 1], &rowcnd, &colcnd, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition */
+/* number and error bounds using CGBSVX. */
+
+ s_copy(srnamc_1.srnamt, "CGBSVX", (ftnlen)32,
+ (ftnlen)6);
+ cgbsvx_(fact, trans, &n, &kl, &ku, nrhs, &a[1]
+, &lda, &afb[1], &ldafb, &iwork[1],
+ equed, &s[1], &s[ldb + 1], &b[1], &
+ ldb, &x[1], &ldb, &rcond, &rwork[1], &
+ rwork[*nrhs + 1], &work[1], &rwork[(*
+ nrhs << 1) + 1], &info);
+
+/* Check the error code from CGBSVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__11[0] = 1, a__1[0] = fact;
+ i__11[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__11, &c__2, (ftnlen)
+ 2);
+ alaerh_(path, "CGBSVX", &info, &izero,
+ ch__1, &n, &n, &kl, &ku, nrhs, &
+ imat, &nfail, &nerrs, nout);
+ }
+/* Compare RWORK(2*NRHS+1) from CGBSVX with the */
+/* computed reciprocal pivot growth RPVGRW */
+
+ if (info != 0) {
+ anrmpv = 0.f;
+ i__8 = info;
+ for (j = 1; j <= i__8; ++j) {
+/* Computing MAX */
+ i__6 = ku + 2 - j;
+/* Computing MIN */
+ i__9 = n + ku + 1 - j, i__10 = kl +
+ ku + 1;
+ i__7 = min(i__9,i__10);
+ for (i__ = max(i__6,1); i__ <= i__7;
+ ++i__) {
+/* Computing MAX */
+ r__1 = anrmpv, r__2 = c_abs(&a[
+ i__ + (j - 1) * lda]);
+ anrmpv = dmax(r__1,r__2);
+/* L60: */
+ }
+/* L70: */
+ }
+/* Computing MIN */
+ i__7 = info - 1, i__6 = kl + ku;
+ i__8 = min(i__7,i__6);
+/* Computing MAX */
+ i__9 = 1, i__10 = kl + ku + 2 - info;
+ rpvgrw = clantb_("M", "U", "N", &info, &
+ i__8, &afb[max(i__9, i__10)], &
+ ldafb, rdum);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = anrmpv / rpvgrw;
+ }
+ } else {
+ i__8 = kl + ku;
+ rpvgrw = clantb_("M", "U", "N", &n, &i__8,
+ &afb[1], &ldafb, rdum);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = clangb_("M", &n, &kl, &ku, &
+ a[1], &lda, rdum) /
+ rpvgrw;
+ }
+ }
+/* Computing MAX */
+ r__2 = rwork[(*nrhs << 1) + 1];
+ result[6] = (r__1 = rpvgrw - rwork[(*nrhs <<
+ 1) + 1], dabs(r__1)) / dmax(r__2,
+ rpvgrw) / slamch_("E");
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and */
+/* compute residual. */
+
+ cgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
+ afb[1], &ldafb, &iwork[1], &work[
+ 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &bsav[1], &ldb,
+ &work[1], &ldb);
+ cgbt02_(trans, &n, &n, &kl, &ku, nrhs, &
+ asav[1], &lda, &x[1], &ldb, &work[
+ 1], &ldb, &result[1]);
+
+/* Check solution from generated exact */
+/* solution. */
+
+ if (nofact || prefac && lsame_(equed,
+ "N")) {
+ cget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &rcondc, &result[2])
+ ;
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ cget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ cgbt05_(trans, &n, &kl, &ku, nrhs, &asav[
+ 1], &lda, &bsav[1], &ldb, &x[1], &
+ ldb, &xact[1], &ldb, &rwork[1], &
+ rwork[*nrhs + 1], &result[3]);
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from CGBSVX with the computed */
+/* value in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___73.ciunit = *nout;
+ s_wsfe(&io___73);
+ do_fio(&c__1, "CGBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___74.ciunit = *nout;
+ s_wsfe(&io___74);
+ do_fio(&c__1, "CGBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___75.ciunit = *nout;
+ s_wsfe(&io___75);
+ do_fio(&c__1, "CGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___76.ciunit = *nout;
+ s_wsfe(&io___76);
+ do_fio(&c__1, "CGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___77.ciunit = *nout;
+ s_wsfe(&io___77);
+ do_fio(&c__1, "CGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___78.ciunit = *nout;
+ s_wsfe(&io___78);
+ do_fio(&c__1, "CGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___79.ciunit = *nout;
+ s_wsfe(&io___79);
+ do_fio(&c__1, "CGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___80.ciunit = *nout;
+ s_wsfe(&io___80);
+ do_fio(&c__1, "CGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ }
+/* L90: */
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+
+ return 0;
+
+/* End of CDRVGB */
+
+} /* cdrvgb_ */
diff --git a/TESTING/LIN/cdrvgbx.c b/TESTING/LIN/cdrvgbx.c
new file mode 100644
index 0000000..27c0b7d
--- /dev/null
+++ b/TESTING/LIN/cdrvgbx.c
@@ -0,0 +1,1474 @@
+/* cdrvgbx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "memory_alloc.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static complex c_b48 = {0.f,0.f};
+static complex c_b49 = {1.f,0.f};
+static integer c__6 = 6;
+static integer c__7 = 7;
+static real c_b197 = 0.f;
+
+/* Subroutine */ int cdrvgb_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, complex *a, integer *la,
+ complex *afb, integer *lafb, complex *asav, complex *b, complex *
+ bsav, complex *x, complex *xact, real *s, complex *work, real *rwork,
+ integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*4] = "N" "R" "C" "B";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 *** In CDRVGB, LA=\002,i5,\002 is too sm"
+ "all for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> In"
+ "crease LA to at least \002,i5)";
+ static char fmt_9998[] = "(\002 *** In CDRVGB, LAFB=\002,i5,\002 is too "
+ "small for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> "
+ "Increase LAFB to at least \002,i5)";
+ static char fmt_9997[] = "(1x,a,\002, N=\002,i5,\002, KL=\002,i5,\002, K"
+ "U=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)"
+ ;
+ static char fmt_9995[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002"
+ ",i5,\002,\002,i5,\002,\002,i5,\002,...), EQUED='\002,a1,\002', t"
+ "ype \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002"
+ ",i5,\002,\002,i5,\002,\002,i5,\002,...), type \002,i1,\002, test("
+ "\002,i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10,
+ i__11[2];
+ real r__1, r__2;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+ double c_abs(complex *);
+
+ /* Local variables */
+ extern /* Subroutine */ int cebchvxx_(real *, char *);
+ integer i__, j, k, n;
+ real *errbnds_c__;
+ integer i1, i2, k1;
+ real *errbnds_n__;
+ integer nb, in, kl, ku, nt, n_err_bnds__, lda, ldb, ikl, nkl, iku, nku;
+ char fact[1];
+ integer ioff, mode;
+ real amax;
+ char path[3];
+ integer imat, info;
+ real *berr;
+ char dist[1];
+ real rdum[1], rpvgrw_svxx__;
+ char type__[1];
+ integer nrun;
+ extern doublereal cla_gbrpvgrw__(integer *, integer *, integer *, integer
+ *, complex *, integer *, complex *, integer *);
+ integer ldafb;
+ extern /* Subroutine */ int cgbt01_(), cgbt02_(), cgbt05_(char *, integer
+ *, integer *, integer *, integer *, complex *, integer *, complex
+ *, integer *, complex *, integer *, complex *, integer *, real *,
+ real *, real *);
+ integer ifact;
+ extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *);
+ integer nfail, iseed[4], nfact;
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ real rcond, roldc;
+ extern /* Subroutine */ int cgbsv_(integer *, integer *, integer *,
+ integer *, complex *, integer *, integer *, complex *, integer *,
+ integer *);
+ integer nimat;
+ real roldi;
+ extern doublereal sget06_(real *, real *);
+ real anorm;
+ integer itran;
+ logical equil;
+ real roldo;
+ char trans[1];
+ integer izero, nerrs;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), aladhd_(integer *, char *);
+ extern doublereal clangb_(char *, integer *, integer *, integer *,
+ complex *, integer *, real *), clange_(char *, integer *,
+ integer *, complex *, integer *, real *);
+ extern /* Subroutine */ int claqgb_(integer *, integer *, integer *,
+ integer *, complex *, integer *, real *, real *, real *, real *,
+ real *, char *), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ logical prefac;
+ real colcnd;
+ extern doublereal clantb_(char *, char *, char *, integer *, integer *,
+ complex *, integer *, real *);
+ extern /* Subroutine */ int cgbequ_(integer *, integer *, integer *,
+ integer *, complex *, integer *, real *, real *, real *, real *,
+ real *, integer *);
+ real rcondc;
+ extern doublereal slamch_(char *);
+ logical nofact;
+ extern /* Subroutine */ int cgbtrf_(integer *, integer *, integer *,
+ integer *, complex *, integer *, integer *, integer *);
+ integer iequed;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *);
+ real rcondi;
+ extern /* Subroutine */ int clarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, integer *,
+ integer *), claset_(), alasvm_(
+ char *, integer *, integer *, integer *, integer *);
+ real cndnum, anormi, rcondo, ainvnm;
+ extern /* Subroutine */ int cgbtrs_(char *, integer *, integer *, integer
+ *, integer *, complex *, integer *, integer *, complex *, integer
+ *, integer *), clatms_(integer *, integer *, char *,
+ integer *, char *, real *, integer *, real *, real *, integer *,
+ integer *, char *, complex *, integer *, complex *, integer *);
+ logical trfcon;
+ real anormo, rowcnd;
+ extern /* Subroutine */ int cgbsvx_(char *, char *, integer *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ integer *, char *, real *, real *, complex *, integer *, complex *
+, integer *, real *, real *, real *, complex *, real *, integer *), xlaenv_(integer *, integer *);
+ real anrmpv;
+ extern /* Subroutine */ int cerrvx_(char *, integer *);
+ real result[7], rpvgrw;
+ extern /* Subroutine */ int cgbsvxx_(char *, char *, integer *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ integer *, char *, real *, real *, complex *, integer *, complex
+ *, integer *, real *, real *, real *, integer *, real *, real *,
+ integer *, real *, complex *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___73 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___74 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___75 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___76 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___77 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___80 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___86 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___87 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___88 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___89 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___90 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___91 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___92 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___93 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVGB tests the driver routines CGBSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) COMPLEX array, dimension (LA) */
+
+/* LA (input) INTEGER */
+/* The length of the array A. LA >= (2*NMAX-1)*NMAX */
+/* where NMAX is the largest entry in NVAL. */
+
+/* AFB (workspace) COMPLEX array, dimension (LAFB) */
+
+/* LAFB (input) INTEGER */
+/* The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX */
+/* where NMAX is the largest entry in NVAL. */
+
+/* ASAV (workspace) COMPLEX array, dimension (LA) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* S (workspace) REAL array, dimension (2*NMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(3,NRHS,NMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NRHS)) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* replace NRHS with 99 to make f2c work through */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afb;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "GB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ ldb = max(n,1);
+ *(unsigned char *)xtype = 'N';
+
+/* Set limits on the number of loop iterations. */
+
+/* Computing MAX */
+ i__2 = 1, i__3 = min(n,4);
+ nkl = max(i__2,i__3);
+ if (n == 0) {
+ nkl = 1;
+ }
+ nku = nkl;
+ nimat = 8;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nkl;
+ for (ikl = 1; ikl <= i__2; ++ikl) {
+
+/* Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes */
+/* it easier to skip redundant values for small values of N. */
+
+ if (ikl == 1) {
+ kl = 0;
+ } else if (ikl == 2) {
+/* Computing MAX */
+ i__3 = n - 1;
+ kl = max(i__3,0);
+ } else if (ikl == 3) {
+ kl = (n * 3 - 1) / 4;
+ } else if (ikl == 4) {
+ kl = (n + 1) / 4;
+ }
+ i__3 = nku;
+ for (iku = 1; iku <= i__3; ++iku) {
+
+/* Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order */
+/* makes it easier to skip redundant values for small */
+/* values of N. */
+
+ if (iku == 1) {
+ ku = 0;
+ } else if (iku == 2) {
+/* Computing MAX */
+ i__4 = n - 1;
+ ku = max(i__4,0);
+ } else if (iku == 3) {
+ ku = (n * 3 - 1) / 4;
+ } else if (iku == 4) {
+ ku = (n + 1) / 4;
+ }
+
+/* Check that A and AFB are big enough to generate this */
+/* matrix. */
+
+ lda = kl + ku + 1;
+ ldafb = (kl << 1) + ku + 1;
+ if (lda * n > *la || ldafb * n > *lafb) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (lda * n > *la) {
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, (char *)&(*la), (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ i__4 = n * (kl + ku + 1);
+ do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ if (ldafb * n > *lafb) {
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__1, (char *)&(*lafb), (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ i__4 = n * ((kl << 1) + ku + 1);
+ do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ goto L130;
+ }
+
+ i__4 = nimat;
+ for (imat = 1; imat <= i__4; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+/* Skip types 2, 3, or 4 if the matrix is too small. */
+
+ zerot = imat >= 2 && imat <= 4;
+ if (zerot && n < imat - 1) {
+ goto L120;
+ }
+
+/* Set up parameters with CLATB4 and generate a */
+/* test matrix with CLATMS. */
+
+ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
+ mode, &cndnum, dist);
+ rcondc = 1.f / cndnum;
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "Z", &a[1], &lda, &work[
+ 1], &info);
+
+/* Check the error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, " ", &n, &n, &
+ kl, &ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L120;
+ }
+
+/* For types 2, 3, and 4, zero one or more columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ izero = 0;
+ if (zerot) {
+ if (imat == 2) {
+ izero = 1;
+ } else if (imat == 3) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 4) {
+/* Computing MAX */
+ i__5 = 1, i__6 = ku + 2 - izero;
+ i1 = max(i__5,i__6);
+/* Computing MIN */
+ i__5 = kl + ku + 1, i__6 = ku + 1 + (n - izero);
+ i2 = min(i__5,i__6);
+ i__5 = i2;
+ for (i__ = i1; i__ <= i__5; ++i__) {
+ i__6 = ioff + i__;
+ a[i__6].r = 0.f, a[i__6].i = 0.f;
+/* L20: */
+ }
+ } else {
+ i__5 = n;
+ for (j = izero; j <= i__5; ++j) {
+/* Computing MAX */
+ i__6 = 1, i__7 = ku + 2 - j;
+/* Computing MIN */
+ i__9 = kl + ku + 1, i__10 = ku + 1 + (n - j);
+ i__8 = min(i__9,i__10);
+ for (i__ = max(i__6,i__7); i__ <= i__8; ++i__)
+ {
+ i__6 = ioff + i__;
+ a[i__6].r = 0.f, a[i__6].i = 0.f;
+/* L30: */
+ }
+ ioff += lda;
+/* L40: */
+ }
+ }
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ i__5 = kl + ku + 1;
+ clacpy_("Full", &i__5, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 4; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__5 = nfact;
+ for (ifact = 1; ifact <= i__5; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L100;
+ }
+ rcondo = 0.f;
+ rcondi = 0.f;
+
+ } else if (! nofact) {
+
+/* Compute the condition number for comparison */
+/* with the value returned by SGESVX (FACT = */
+/* 'N' reuses the condition number from the */
+/* previous iteration with FACT = 'F'). */
+
+ i__8 = kl + ku + 1;
+ clacpy_("Full", &i__8, &n, &asav[1], &lda, &
+ afb[kl + 1], &ldafb);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ cgbequ_(&n, &n, &kl, &ku, &afb[kl + 1], &
+ ldafb, &s[1], &s[n + 1], &rowcnd,
+ &colcnd, &amax, &info);
+ if (info == 0 && n > 0) {
+ if (lsame_(equed, "R")) {
+ rowcnd = 0.f;
+ colcnd = 1.f;
+ } else if (lsame_(equed, "C")) {
+ rowcnd = 1.f;
+ colcnd = 0.f;
+ } else if (lsame_(equed, "B")) {
+ rowcnd = 0.f;
+ colcnd = 0.f;
+ }
+
+/* Equilibrate the matrix. */
+
+ claqgb_(&n, &n, &kl, &ku, &afb[kl + 1]
+, &ldafb, &s[1], &s[n + 1], &
+ rowcnd, &colcnd, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in CGET04. */
+
+ if (equil) {
+ roldo = rcondo;
+ roldi = rcondi;
+ }
+
+/* Compute the 1-norm and infinity-norm of A. */
+
+ anormo = clangb_("1", &n, &kl, &ku, &afb[kl +
+ 1], &ldafb, &rwork[1]);
+ anormi = clangb_("I", &n, &kl, &ku, &afb[kl +
+ 1], &ldafb, &rwork[1]);
+
+/* Factor the matrix A. */
+
+ cgbtrf_(&n, &n, &kl, &ku, &afb[1], &ldafb, &
+ iwork[1], &info);
+
+/* Form the inverse of A. */
+
+ claset_("Full", &n, &n, &c_b48, &c_b49, &work[
+ 1], &ldb);
+ s_copy(srnamc_1.srnamt, "CGBTRS", (ftnlen)32,
+ (ftnlen)6);
+ cgbtrs_("No transpose", &n, &kl, &ku, &n, &
+ afb[1], &ldafb, &iwork[1], &work[1], &
+ ldb, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = clange_("1", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormo <= 0.f || ainvnm <= 0.f) {
+ rcondo = 1.f;
+ } else {
+ rcondo = 1.f / anormo / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number */
+/* of A. */
+
+ ainvnm = clange_("I", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormi <= 0.f || ainvnm <= 0.f) {
+ rcondi = 1.f;
+ } else {
+ rcondi = 1.f / anormi / ainvnm;
+ }
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for each value of TRANS. */
+
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Restore the matrix A. */
+
+ i__8 = kl + ku + 1;
+ clacpy_("Full", &i__8, &n, &asav[1], &lda, &a[
+ 1], &lda);
+
+/* Form an exact solution and set the right hand */
+/* side. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32,
+ (ftnlen)6);
+ clarhs_(path, xtype, "Full", trans, &n, &n, &
+ kl, &ku, nrhs, &a[1], &lda, &xact[1],
+ &ldb, &b[1], &ldb, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ clacpy_("Full", &n, nrhs, &b[1], &ldb, &bsav[
+ 1], &ldb);
+
+ if (nofact && itran == 1) {
+
+/* --- Test CGBSV --- */
+
+/* Compute the LU factorization of the matrix */
+/* and solve the system. */
+
+ i__8 = kl + ku + 1;
+ clacpy_("Full", &i__8, &n, &a[1], &lda, &
+ afb[kl + 1], &ldafb);
+ clacpy_("Full", &n, nrhs, &b[1], &ldb, &x[
+ 1], &ldb);
+
+ s_copy(srnamc_1.srnamt, "CGBSV ", (ftnlen)
+ 32, (ftnlen)6);
+ cgbsv_(&n, &kl, &ku, nrhs, &afb[1], &
+ ldafb, &iwork[1], &x[1], &ldb, &
+ info);
+
+/* Check error code from CGBSV . */
+
+ if (info == n + 1) {
+ goto L90;
+ }
+ if (info != izero) {
+ alaerh_(path, "CGBSV ", &info, &izero,
+ " ", &n, &n, &kl, &ku, nrhs,
+ &imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+
+/* Reconstruct matrix from factors and */
+/* compute residual. */
+
+ cgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
+ afb[1], &ldafb, &iwork[1], &work[
+ 1], result);
+ nt = 1;
+ if (izero == 0) {
+
+/* Compute residual of the computed */
+/* solution. */
+
+ clacpy_("Full", &n, nrhs, &b[1], &ldb,
+ &work[1], &ldb);
+ cgbt02_("No transpose", &n, &n, &kl, &
+ ku, nrhs, &a[1], &lda, &x[1],
+ &ldb, &work[1], &ldb, &result[
+ 1]);
+
+/* Check solution from generated exact */
+/* solution. */
+
+ cget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &rcondc, &result[2])
+ ;
+ nt = 3;
+ }
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ i__8 = nt;
+ for (k = 1; k <= i__8; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___65.ciunit = *nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, "CGBSV ", (ftnlen)6)
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k -
+ 1], (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L50: */
+ }
+ nrun += nt;
+ }
+
+/* --- Test CGBSVX --- */
+
+ if (! prefac) {
+ i__8 = (kl << 1) + ku + 1;
+ claset_("Full", &i__8, &n, &c_b48, &c_b48,
+ &afb[1], &ldafb);
+ }
+ claset_("Full", &n, nrhs, &c_b48, &c_b48, &x[
+ 1], &ldb);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ claqgb_(&n, &n, &kl, &ku, &a[1], &lda, &s[
+ 1], &s[n + 1], &rowcnd, &colcnd, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition */
+/* number and error bounds using CGBSVX. */
+
+ s_copy(srnamc_1.srnamt, "CGBSVX", (ftnlen)32,
+ (ftnlen)6);
+ cgbsvx_(fact, trans, &n, &kl, &ku, nrhs, &a[1]
+, &lda, &afb[1], &ldafb, &iwork[1],
+ equed, &s[1], &s[ldb + 1], &b[1], &
+ ldb, &x[1], &ldb, &rcond, &rwork[1], &
+ rwork[*nrhs + 1], &work[1], &rwork[(*
+ nrhs << 1) + 1], &info);
+
+/* Check the error code from CGBSVX. */
+
+ if (info == n + 1) {
+ goto L90;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__11[0] = 1, a__1[0] = fact;
+ i__11[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__11, &c__2, (ftnlen)
+ 2);
+ alaerh_(path, "CGBSVX", &info, &izero,
+ ch__1, &n, &n, &kl, &ku, nrhs, &
+ imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+/* Compare RWORK(2*NRHS+1) from CGBSVX with the */
+/* computed reciprocal pivot growth RPVGRW */
+
+ if (info != 0) {
+ anrmpv = 0.f;
+ i__8 = info;
+ for (j = 1; j <= i__8; ++j) {
+/* Computing MAX */
+ i__6 = ku + 2 - j;
+/* Computing MIN */
+ i__9 = n + ku + 1 - j, i__10 = kl +
+ ku + 1;
+ i__7 = min(i__9,i__10);
+ for (i__ = max(i__6,1); i__ <= i__7;
+ ++i__) {
+/* Computing MAX */
+ r__1 = anrmpv, r__2 = c_abs(&a[
+ i__ + (j - 1) * lda]);
+ anrmpv = dmax(r__1,r__2);
+/* L60: */
+ }
+/* L70: */
+ }
+/* Computing MIN */
+ i__7 = info - 1, i__6 = kl + ku;
+ i__8 = min(i__7,i__6);
+/* Computing MAX */
+ i__9 = 1, i__10 = kl + ku + 2 - info;
+ rpvgrw = clantb_("M", "U", "N", &info, &
+ i__8, &afb[max(i__9, i__10)], &
+ ldafb, rdum);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = anrmpv / rpvgrw;
+ }
+ } else {
+ i__8 = kl + ku;
+ rpvgrw = clantb_("M", "U", "N", &n, &i__8,
+ &afb[1], &ldafb, rdum);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = clangb_("M", &n, &kl, &ku, &
+ a[1], &lda, rdum) /
+ rpvgrw;
+ }
+ }
+/* Computing MAX */
+ r__2 = rwork[(*nrhs << 1) + 1];
+ result[6] = (r__1 = rpvgrw - rwork[(*nrhs <<
+ 1) + 1], dabs(r__1)) / dmax(r__2,
+ rpvgrw) / slamch_("E");
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and */
+/* compute residual. */
+
+ cgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
+ afb[1], &ldafb, &iwork[1], &work[
+ 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &bsav[1], &ldb,
+ &work[1], &ldb);
+ cgbt02_(trans, &n, &n, &kl, &ku, nrhs, &
+ asav[1], &lda, &x[1], &ldb, &work[
+ 1], &ldb, &result[1]);
+
+/* Check solution from generated exact */
+/* solution. */
+
+ if (nofact || prefac && lsame_(equed,
+ "N")) {
+ cget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &rcondc, &result[2])
+ ;
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ cget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ cgbt05_(trans, &n, &kl, &ku, nrhs, &asav[
+ 1], &lda, &bsav[1], &ldb, &x[1], &
+ ldb, &xact[1], &ldb, &rwork[1], &
+ rwork[*nrhs + 1], &result[3]);
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from CGBSVX with the computed */
+/* value in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___73.ciunit = *nout;
+ s_wsfe(&io___73);
+ do_fio(&c__1, "CGBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___74.ciunit = *nout;
+ s_wsfe(&io___74);
+ do_fio(&c__1, "CGBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___75.ciunit = *nout;
+ s_wsfe(&io___75);
+ do_fio(&c__1, "CGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___76.ciunit = *nout;
+ s_wsfe(&io___76);
+ do_fio(&c__1, "CGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___77.ciunit = *nout;
+ s_wsfe(&io___77);
+ do_fio(&c__1, "CGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___78.ciunit = *nout;
+ s_wsfe(&io___78);
+ do_fio(&c__1, "CGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___79.ciunit = *nout;
+ s_wsfe(&io___79);
+ do_fio(&c__1, "CGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___80.ciunit = *nout;
+ s_wsfe(&io___80);
+ do_fio(&c__1, "CGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ }
+/* --- Test CGBSVXX --- */
+/* Restore the matrices A and B. */
+/* write(*,*) 'begin cgbsvxx testing' */
+ i__8 = kl + ku + 1;
+ clacpy_("Full", &i__8, &n, &asav[1], &lda, &a[
+ 1], &lda);
+ clacpy_("Full", &n, nrhs, &bsav[1], &ldb, &b[
+ 1], &ldb);
+ if (! prefac) {
+ i__8 = (kl << 1) + ku + 1;
+ claset_("Full", &i__8, &n, &c_b197, &
+ c_b197, &afb[1], &ldafb);
+ }
+ claset_("Full", &n, nrhs, &c_b197, &c_b197, &
+ x[1], &ldb);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ claqgb_(&n, &n, &kl, &ku, &a[1], &lda, &s[
+ 1], &s[n + 1], &rowcnd, &colcnd, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using CGBSVXX. */
+
+ s_copy(srnamc_1.srnamt, "CGBSVXX", (ftnlen)32,
+ (ftnlen)7);
+ n_err_bnds__ = 3;
+
+ salloc3();
+
+ cgbsvxx_(fact, trans, &n, &kl, &ku, nrhs, &a[
+ 1], &lda, &afb[1], &ldafb, &iwork[1],
+ equed, &s[1], &s[n + 1], &b[1], &ldb,
+ &x[1], &ldb, &rcond, &rpvgrw_svxx__,
+ berr, &n_err_bnds__, errbnds_n__,
+ errbnds_c__, &c__0, &c_b197, &work[1],
+ &rwork[1], &info);
+
+ free3();
+
+/* Check the error code from CGBSVXX. */
+
+ if (info == n + 1) {
+ goto L90;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__11[0] = 1, a__1[0] = fact;
+ i__11[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__11, &c__2, (ftnlen)
+ 2);
+ alaerh_(path, "CGBSVXX", &info, &izero,
+ ch__1, &n, &n, &c_n1, &c_n1, nrhs,
+ &imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+
+/* Compare rpvgrw_svxx from CGESVXX with the computed */
+/* reciprocal pivot growth factor RPVGRW */
+
+ if (info > 0 && info < n + 1) {
+ rpvgrw = cla_gbrpvgrw__(&n, &kl, &ku, &
+ info, &a[1], &lda, &afb[1], &
+ ldafb);
+ } else {
+ rpvgrw = cla_gbrpvgrw__(&n, &kl, &ku, &n,
+ &a[1], &lda, &afb[1], &ldafb);
+ }
+ result[6] = (r__1 = rpvgrw - rpvgrw_svxx__,
+ dabs(r__1)) / dmax(rpvgrw_svxx__,
+ rpvgrw) / slamch_("E");
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ cgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
+ afb[1], &ldafb, &iwork[1], &rwork[
+ (*nrhs << 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &bsav[1], &ldb,
+ &work[1], &ldb);
+ cgbt02_(trans, &n, &n, &kl, &ku, nrhs, &
+ asav[1], &lda, &x[1], &ldb, &work[
+ 1], &ldb, &rwork[(*nrhs << 1) + 1]
+, &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed,
+ "N")) {
+ cget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &rcondc, &result[2])
+ ;
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ cget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &roldc, &result[2]);
+ }
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from CGBSVXX with the computed value */
+/* in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___86.ciunit = *nout;
+ s_wsfe(&io___86);
+ do_fio(&c__1, "CGBSVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___87.ciunit = *nout;
+ s_wsfe(&io___87);
+ do_fio(&c__1, "CGBSVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L45: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___88.ciunit = *nout;
+ s_wsfe(&io___88);
+ do_fio(&c__1, "CGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___89.ciunit = *nout;
+ s_wsfe(&io___89);
+ do_fio(&c__1, "CGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___90.ciunit = *nout;
+ s_wsfe(&io___90);
+ do_fio(&c__1, "CGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___91.ciunit = *nout;
+ s_wsfe(&io___91);
+ do_fio(&c__1, "CGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___92.ciunit = *nout;
+ s_wsfe(&io___92);
+ do_fio(&c__1, "CGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___93.ciunit = *nout;
+ s_wsfe(&io___93);
+ do_fio(&c__1, "CGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+
+ }
+
+L90:
+ ;
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+/* Test Error Bounds from CGBSVXX */
+ cebchvxx_(thresh, path);
+
+ return 0;
+
+/* End of CDRVGB */
+
+} /* cdrvgb_ */
diff --git a/TESTING/LIN/cdrvge.c b/TESTING/LIN/cdrvge.c
new file mode 100644
index 0000000..b7d582a
--- /dev/null
+++ b/TESTING/LIN/cdrvge.c
@@ -0,0 +1,901 @@
+/* cdrvge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static complex c_b20 = {0.f,0.f};
+static logical c_true = TRUE_;
+static integer c__6 = 6;
+static integer c__7 = 7;
+
+/* Subroutine */ int cdrvge_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, integer *nmax, complex *
+ a, complex *afac, complex *asav, complex *b, complex *bsav, complex *
+ x, complex *xact, real *s, complex *work, real *rwork, integer *iwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*4] = "N" "R" "C" "B";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
+ ", test(\002,i2,\002) =\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
+ "1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i2,\002"
+ ", test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
+ "1,\002', N=\002,i5,\002, type \002,i2,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ real r__1, r__2;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, k, n, k1, nb, in, kl, ku, nt, lda;
+ char fact[1];
+ integer ioff, mode;
+ real amax;
+ char path[3];
+ integer imat, info;
+ char dist[1];
+ real rdum[1];
+ char type__[1];
+ integer nrun;
+ extern /* Subroutine */ int cget01_(integer *, integer *, complex *,
+ integer *, complex *, integer *, integer *, real *, real *),
+ cget02_(char *, integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, real *,
+ real *);
+ integer ifact;
+ extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *);
+ integer nfail, iseed[4], nfact;
+ extern /* Subroutine */ int cget07_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, complex *, integer *, complex
+ *, integer *, real *, logical *, real *, real *);
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ real rcond, roldc;
+ extern /* Subroutine */ int cgesv_(integer *, integer *, complex *,
+ integer *, integer *, complex *, integer *, integer *);
+ integer nimat;
+ real roldi;
+ extern doublereal sget06_(real *, real *);
+ real anorm;
+ integer itran;
+ logical equil;
+ real roldo;
+ char trans[1];
+ integer izero, nerrs, lwork;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), aladhd_(integer *, char *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *), claqge_(integer *, integer *, complex *, integer *, real
+ *, real *, real *, real *, real *, char *);
+ logical prefac;
+ real colcnd;
+ extern doublereal slamch_(char *);
+ real rcondc;
+ extern /* Subroutine */ int cgeequ_(integer *, integer *, complex *,
+ integer *, real *, real *, real *, real *, real *, integer *);
+ logical nofact;
+ integer iequed;
+ extern /* Subroutine */ int cgetrf_(integer *, integer *, complex *,
+ integer *, integer *, integer *);
+ real rcondi;
+ extern /* Subroutine */ int cgetri_(integer *, complex *, integer *,
+ integer *, complex *, integer *, integer *), clacpy_(char *,
+ integer *, integer *, complex *, integer *, complex *, integer *), clarhs_(char *, char *, char *, char *, integer *,
+ integer *, integer *, integer *, integer *, complex *, integer *,
+ complex *, integer *, complex *, integer *, integer *, integer *);
+ extern doublereal clantr_(char *, char *, char *, integer *, integer *,
+ complex *, integer *, real *);
+ real cndnum, anormi, rcondo, ainvnm;
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *), claset_(char *, integer *, integer *,
+ complex *, complex *, complex *, integer *);
+ logical trfcon;
+ real anormo, rowcnd;
+ extern /* Subroutine */ int cgesvx_(char *, char *, integer *, integer *,
+ complex *, integer *, complex *, integer *, integer *, char *,
+ real *, real *, complex *, integer *, complex *, integer *, real *
+, real *, real *, complex *, real *, integer *), clatms_(integer *, integer *, char *, integer *, char *,
+ real *, integer *, real *, real *, integer *, integer *, char *,
+ complex *, integer *, complex *, integer *), xlaenv_(integer *, integer *), cerrvx_(char *, integer *);
+ real result[7], rpvgrw;
+
+ /* Fortran I/O blocks */
+ static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___68 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___69 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVGE tests the driver routines CGESV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* S (workspace) REAL array, dimension (2*NMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) REAL array, dimension (2*NRHS+NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "GE", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 11;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L80;
+ }
+
+/* Skip types 5, 6, or 7 if the matrix size is too small. */
+
+ zerot = imat >= 5 && imat <= 7;
+ if (zerot && n < imat - 4) {
+ goto L80;
+ }
+
+/* Set up parameters with CLATB4 and generate a test matrix */
+/* with CLATMS. */
+
+ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cndnum, dist);
+ rcondc = 1.f / cndnum;
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cndnum, &
+ anorm, &kl, &ku, "No packing", &a[1], &lda, &work[1], &
+ info);
+
+/* Check error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, " ", &n, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L80;
+ }
+
+/* For types 5-7, zero one or more columns of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 5) {
+ izero = 1;
+ } else if (imat == 6) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 7) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L20: */
+ }
+ } else {
+ i__3 = n - izero + 1;
+ claset_("Full", &n, &i__3, &c_b20, &c_b20, &a[ioff + 1], &
+ lda);
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ clacpy_("Full", &n, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 4; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[iequed -
+ 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__3 = nfact;
+ for (ifact = 1; ifact <= i__3; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[ifact -
+ 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L60;
+ }
+ rcondo = 0.f;
+ rcondi = 0.f;
+
+ } else if (! nofact) {
+
+/* Compute the condition number for comparison with */
+/* the value returned by CGESVX (FACT = 'N' reuses */
+/* the condition number from the previous iteration */
+/* with FACT = 'F'). */
+
+ clacpy_("Full", &n, &n, &asav[1], &lda, &afac[1], &
+ lda);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ cgeequ_(&n, &n, &afac[1], &lda, &s[1], &s[n + 1],
+ &rowcnd, &colcnd, &amax, &info);
+ if (info == 0 && n > 0) {
+ if (lsame_(equed, "R"))
+ {
+ rowcnd = 0.f;
+ colcnd = 1.f;
+ } else if (lsame_(equed, "C")) {
+ rowcnd = 1.f;
+ colcnd = 0.f;
+ } else if (lsame_(equed, "B")) {
+ rowcnd = 0.f;
+ colcnd = 0.f;
+ }
+
+/* Equilibrate the matrix. */
+
+ claqge_(&n, &n, &afac[1], &lda, &s[1], &s[n +
+ 1], &rowcnd, &colcnd, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the non-equilibrated */
+/* system for use in CGET04. */
+
+ if (equil) {
+ roldo = rcondo;
+ roldi = rcondi;
+ }
+
+/* Compute the 1-norm and infinity-norm of A. */
+
+ anormo = clange_("1", &n, &n, &afac[1], &lda, &rwork[
+ 1]);
+ anormi = clange_("I", &n, &n, &afac[1], &lda, &rwork[
+ 1]);
+
+/* Factor the matrix A. */
+
+ cgetrf_(&n, &n, &afac[1], &lda, &iwork[1], &info);
+
+/* Form the inverse of A. */
+
+ clacpy_("Full", &n, &n, &afac[1], &lda, &a[1], &lda);
+ lwork = *nmax * max(3,*nrhs);
+ cgetri_(&n, &a[1], &lda, &iwork[1], &work[1], &lwork,
+ &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = clange_("1", &n, &n, &a[1], &lda, &rwork[1]);
+ if (anormo <= 0.f || ainvnm <= 0.f) {
+ rcondo = 1.f;
+ } else {
+ rcondo = 1.f / anormo / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ ainvnm = clange_("I", &n, &n, &a[1], &lda, &rwork[1]);
+ if (anormi <= 0.f || ainvnm <= 0.f) {
+ rcondi = 1.f;
+ } else {
+ rcondi = 1.f / anormi / ainvnm;
+ }
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for each value of TRANS. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[
+ itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Restore the matrix A. */
+
+ clacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ clarhs_(path, xtype, "Full", trans, &n, &n, &kl, &ku,
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
+
+ if (nofact && itran == 1) {
+
+/* --- Test CGESV --- */
+
+/* Compute the LU factorization of the matrix and */
+/* solve the system. */
+
+ clacpy_("Full", &n, &n, &a[1], &lda, &afac[1], &
+ lda);
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "CGESV ", (ftnlen)32, (
+ ftnlen)6);
+ cgesv_(&n, nrhs, &afac[1], &lda, &iwork[1], &x[1],
+ &lda, &info);
+
+/* Check error code from CGESV . */
+
+ if (info != izero) {
+ alaerh_(path, "CGESV ", &info, &izero, " ", &
+ n, &n, &c_n1, &c_n1, nrhs, &imat, &
+ nfail, &nerrs, nout);
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ cget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &rwork[1], result);
+ nt = 1;
+ if (izero == 0) {
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &work[
+ 1], &lda);
+ cget02_("No transpose", &n, &n, nrhs, &a[1], &
+ lda, &x[1], &lda, &work[1], &lda, &
+ rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ nt = 3;
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___55.ciunit = *nout;
+ s_wsfe(&io___55);
+ do_fio(&c__1, "CGESV ", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L30: */
+ }
+ nrun += nt;
+ }
+
+/* --- Test CGESVX --- */
+
+ if (! prefac) {
+ claset_("Full", &n, &n, &c_b20, &c_b20, &afac[1],
+ &lda);
+ }
+ claset_("Full", &n, nrhs, &c_b20, &c_b20, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ claqge_(&n, &n, &a[1], &lda, &s[1], &s[n + 1], &
+ rowcnd, &colcnd, &amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using CGESVX. */
+
+ s_copy(srnamc_1.srnamt, "CGESVX", (ftnlen)32, (ftnlen)
+ 6);
+ cgesvx_(fact, trans, &n, nrhs, &a[1], &lda, &afac[1],
+ &lda, &iwork[1], equed, &s[1], &s[n + 1], &b[
+ 1], &lda, &x[1], &lda, &rcond, &rwork[1], &
+ rwork[*nrhs + 1], &work[1], &rwork[(*nrhs <<
+ 1) + 1], &info);
+
+/* Check the error code from CGESVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "CGESVX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+/* Compare RWORK(2*NRHS+1) from CGESVX with the */
+/* computed reciprocal pivot growth factor RPVGRW */
+
+ if (info != 0) {
+ rpvgrw = clantr_("M", "U", "N", &info, &info, &
+ afac[1], &lda, rdum);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = clange_("M", &n, &info, &a[1], &lda,
+ rdum) / rpvgrw;
+ }
+ } else {
+ rpvgrw = clantr_("M", "U", "N", &n, &n, &afac[1],
+ &lda, rdum);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = clange_("M", &n, &n, &a[1], &lda,
+ rdum) / rpvgrw;
+ }
+ }
+/* Computing MAX */
+ r__2 = rwork[(*nrhs << 1) + 1];
+ result[6] = (r__1 = rpvgrw - rwork[(*nrhs << 1) + 1],
+ dabs(r__1)) / dmax(r__2,rpvgrw) / slamch_(
+ "E");
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ cget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &rwork[(*nrhs << 1) + 1],
+ result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ cget02_(trans, &n, &n, nrhs, &asav[1], &lda, &x[1]
+, &lda, &work[1], &lda, &rwork[(*nrhs <<
+ 1) + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ cget07_(trans, &n, nrhs, &asav[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &c_true, &rwork[*nrhs + 1], &result[3]
+);
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from CGESVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___62.ciunit = *nout;
+ s_wsfe(&io___62);
+ do_fio(&c__1, "CGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___63.ciunit = *nout;
+ s_wsfe(&io___63);
+ do_fio(&c__1, "CGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L40: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___64.ciunit = *nout;
+ s_wsfe(&io___64);
+ do_fio(&c__1, "CGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___65.ciunit = *nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, "CGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___66.ciunit = *nout;
+ s_wsfe(&io___66);
+ do_fio(&c__1, "CGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___67.ciunit = *nout;
+ s_wsfe(&io___67);
+ do_fio(&c__1, "CGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___68.ciunit = *nout;
+ s_wsfe(&io___68);
+ do_fio(&c__1, "CGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___69.ciunit = *nout;
+ s_wsfe(&io___69);
+ do_fio(&c__1, "CGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+
+ }
+
+/* L50: */
+ }
+L60:
+ ;
+ }
+/* L70: */
+ }
+L80:
+ ;
+ }
+/* L90: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CDRVGE */
+
+} /* cdrvge_ */
diff --git a/TESTING/LIN/cdrvgex.c b/TESTING/LIN/cdrvgex.c
new file mode 100644
index 0000000..a94ba74
--- /dev/null
+++ b/TESTING/LIN/cdrvgex.c
@@ -0,0 +1,1218 @@
+/* cdrvgex.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "memory_alloc.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static complex c_b20 = {0.f,0.f};
+static logical c_true = TRUE_;
+static integer c__6 = 6;
+static integer c__7 = 7;
+static real c_b166 = 0.f;
+
+/* Subroutine */ int cdrvge_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, integer *nmax, complex *
+ a, complex *afac, complex *asav, complex *b, complex *bsav, complex *
+ x, complex *xact, real *s, complex *work, real *rwork, integer *iwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*4] = "N" "R" "C" "B";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
+ ", test(\002,i2,\002) =\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
+ "1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i2,\002"
+ ", test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
+ "1,\002', N=\002,i5,\002, type \002,i2,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ real r__1, r__2;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ extern /* Subroutine */ int cebchvxx_(real *, char *);
+ integer i__, k, n;
+ real *errbnds_c__, *errbnds_n__;
+ integer k1, nb, in, kl, ku, nt, n_err_bnds__;
+ extern doublereal cla_rpvgrw__(integer *, integer *, complex *, integer *,
+ complex *, integer *);
+ integer lda;
+ char fact[1];
+ integer ioff, mode;
+ real amax;
+ char path[3];
+ integer imat, info;
+ real *berr;
+ char dist[1];
+ real rdum[1], rpvgrw_svxx__;
+ char type__[1];
+ integer nrun;
+ extern /* Subroutine */ int cget01_(integer *, integer *, complex *,
+ integer *, complex *, integer *, integer *, real *, real *),
+ cget02_(char *, integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, real *,
+ real *);
+ integer ifact;
+ extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *);
+ integer nfail, iseed[4], nfact;
+ extern /* Subroutine */ int cget07_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, complex *, integer *, complex
+ *, integer *, real *, logical *, real *, real *);
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ real rcond, roldc;
+ extern /* Subroutine */ int cgesv_(integer *, integer *, complex *,
+ integer *, integer *, complex *, integer *, integer *);
+ integer nimat;
+ real roldi;
+ extern doublereal sget06_(real *, real *);
+ real anorm;
+ integer itran;
+ logical equil;
+ real roldo;
+ char trans[1];
+ integer izero, nerrs, lwork;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), aladhd_(integer *, char *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *), claqge_(integer *, integer *, complex *, integer *, real
+ *, real *, real *, real *, real *, char *);
+ logical prefac;
+ real colcnd;
+ extern doublereal slamch_(char *);
+ real rcondc;
+ extern /* Subroutine */ int cgeequ_(integer *, integer *, complex *,
+ integer *, real *, real *, real *, real *, real *, integer *);
+ logical nofact;
+ integer iequed;
+ extern /* Subroutine */ int cgetrf_(integer *, integer *, complex *,
+ integer *, integer *, integer *);
+ real rcondi;
+ extern /* Subroutine */ int cgetri_(integer *, complex *, integer *,
+ integer *, complex *, integer *, integer *), clacpy_(char *,
+ integer *, integer *, complex *, integer *, complex *, integer *), clarhs_(char *, char *, char *, char *, integer *,
+ integer *, integer *, integer *, integer *, complex *, integer *,
+ complex *, integer *, complex *, integer *, integer *, integer *);
+ extern doublereal clantr_(char *, char *, char *, integer *, integer *,
+ complex *, integer *, real *);
+ real cndnum, anormi, rcondo, ainvnm;
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *), claset_();
+ logical trfcon;
+ real anormo, rowcnd;
+ extern /* Subroutine */ int cgesvx_(char *, char *, integer *, integer *,
+ complex *, integer *, complex *, integer *, integer *, char *,
+ real *, real *, complex *, integer *, complex *, integer *, real *
+, real *, real *, complex *, real *, integer *), clatms_(integer *, integer *, char *, integer *, char *,
+ real *, integer *, real *, real *, integer *, integer *, char *,
+ complex *, integer *, complex *, integer *), xlaenv_(integer *, integer *), cerrvx_(char *, integer *);
+ real result[7], rpvgrw;
+ extern /* Subroutine */ int cgesvxx_(char *, char *, integer *, integer *,
+ complex *, integer *, complex *, integer *, integer *, char *,
+ real *, real *, complex *, integer *, complex *, integer *, real *
+, real *, real *, integer *, real *, real *, integer *, real *,
+ complex *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___68 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___69 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___75 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___76 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___77 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___80 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___81 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___82 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVGE tests the driver routines CGESV, -SVX, and -SVXX. */
+
+/* Note that this file is used only when the XBLAS are available, */
+/* otherwise cdrvge.f defines this subroutine. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* S (workspace) REAL array, dimension (2*NMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) REAL array, dimension (2*NRHS+NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "GE", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 11;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L80;
+ }
+
+/* Skip types 5, 6, or 7 if the matrix size is too small. */
+
+ zerot = imat >= 5 && imat <= 7;
+ if (zerot && n < imat - 4) {
+ goto L80;
+ }
+
+/* Set up parameters with CLATB4 and generate a test matrix */
+/* with CLATMS. */
+
+ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cndnum, dist);
+ rcondc = 1.f / cndnum;
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cndnum, &
+ anorm, &kl, &ku, "No packing", &a[1], &lda, &work[1], &
+ info);
+
+/* Check error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, " ", &n, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L80;
+ }
+
+/* For types 5-7, zero one or more columns of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 5) {
+ izero = 1;
+ } else if (imat == 6) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 7) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L20: */
+ }
+ } else {
+ i__3 = n - izero + 1;
+ claset_("Full", &n, &i__3, &c_b20, &c_b20, &a[ioff + 1], &
+ lda);
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ clacpy_("Full", &n, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 4; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[iequed -
+ 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__3 = nfact;
+ for (ifact = 1; ifact <= i__3; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[ifact -
+ 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L60;
+ }
+ rcondo = 0.f;
+ rcondi = 0.f;
+
+ } else if (! nofact) {
+
+/* Compute the condition number for comparison with */
+/* the value returned by CGESVX (FACT = 'N' reuses */
+/* the condition number from the previous iteration */
+/* with FACT = 'F'). */
+
+ clacpy_("Full", &n, &n, &asav[1], &lda, &afac[1], &
+ lda);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ cgeequ_(&n, &n, &afac[1], &lda, &s[1], &s[n + 1],
+ &rowcnd, &colcnd, &amax, &info);
+ if (info == 0 && n > 0) {
+ if (lsame_(equed, "R"))
+ {
+ rowcnd = 0.f;
+ colcnd = 1.f;
+ } else if (lsame_(equed, "C")) {
+ rowcnd = 1.f;
+ colcnd = 0.f;
+ } else if (lsame_(equed, "B")) {
+ rowcnd = 0.f;
+ colcnd = 0.f;
+ }
+
+/* Equilibrate the matrix. */
+
+ claqge_(&n, &n, &afac[1], &lda, &s[1], &s[n +
+ 1], &rowcnd, &colcnd, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the non-equilibrated */
+/* system for use in CGET04. */
+
+ if (equil) {
+ roldo = rcondo;
+ roldi = rcondi;
+ }
+
+/* Compute the 1-norm and infinity-norm of A. */
+
+ anormo = clange_("1", &n, &n, &afac[1], &lda, &rwork[
+ 1]);
+ anormi = clange_("I", &n, &n, &afac[1], &lda, &rwork[
+ 1]);
+
+/* Factor the matrix A. */
+
+ cgetrf_(&n, &n, &afac[1], &lda, &iwork[1], &info);
+
+/* Form the inverse of A. */
+
+ clacpy_("Full", &n, &n, &afac[1], &lda, &a[1], &lda);
+ lwork = *nmax * max(3,*nrhs);
+ cgetri_(&n, &a[1], &lda, &iwork[1], &work[1], &lwork,
+ &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = clange_("1", &n, &n, &a[1], &lda, &rwork[1]);
+ if (anormo <= 0.f || ainvnm <= 0.f) {
+ rcondo = 1.f;
+ } else {
+ rcondo = 1.f / anormo / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ ainvnm = clange_("I", &n, &n, &a[1], &lda, &rwork[1]);
+ if (anormi <= 0.f || ainvnm <= 0.f) {
+ rcondi = 1.f;
+ } else {
+ rcondi = 1.f / anormi / ainvnm;
+ }
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+ for (i__ = 1; i__ <= 7; ++i__) {
+ result[i__ - 1] = 0.f;
+ }
+
+/* Do for each value of TRANS. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[
+ itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Restore the matrix A. */
+
+ clacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ clarhs_(path, xtype, "Full", trans, &n, &n, &kl, &ku,
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
+
+ if (nofact && itran == 1) {
+
+/* --- Test CGESV --- */
+
+/* Compute the LU factorization of the matrix and */
+/* solve the system. */
+
+ clacpy_("Full", &n, &n, &a[1], &lda, &afac[1], &
+ lda);
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "CGESV ", (ftnlen)32, (
+ ftnlen)6);
+ cgesv_(&n, nrhs, &afac[1], &lda, &iwork[1], &x[1],
+ &lda, &info);
+
+/* Check error code from CGESV . */
+
+ if (info != izero) {
+ alaerh_(path, "CGESV ", &info, &izero, " ", &
+ n, &n, &c_n1, &c_n1, nrhs, &imat, &
+ nfail, &nerrs, nout);
+ goto L50;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ cget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &rwork[1], result);
+ nt = 1;
+ if (izero == 0) {
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &work[
+ 1], &lda);
+ cget02_("No transpose", &n, &n, nrhs, &a[1], &
+ lda, &x[1], &lda, &work[1], &lda, &
+ rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ nt = 3;
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___55.ciunit = *nout;
+ s_wsfe(&io___55);
+ do_fio(&c__1, "CGESV ", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L30: */
+ }
+ nrun += nt;
+ }
+
+/* --- Test CGESVX --- */
+
+ if (! prefac) {
+ claset_("Full", &n, &n, &c_b20, &c_b20, &afac[1],
+ &lda);
+ }
+ claset_("Full", &n, nrhs, &c_b20, &c_b20, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ claqge_(&n, &n, &a[1], &lda, &s[1], &s[n + 1], &
+ rowcnd, &colcnd, &amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using CGESVX. */
+
+ s_copy(srnamc_1.srnamt, "CGESVX", (ftnlen)32, (ftnlen)
+ 6);
+ cgesvx_(fact, trans, &n, nrhs, &a[1], &lda, &afac[1],
+ &lda, &iwork[1], equed, &s[1], &s[n + 1], &b[
+ 1], &lda, &x[1], &lda, &rcond, &rwork[1], &
+ rwork[*nrhs + 1], &work[1], &rwork[(*nrhs <<
+ 1) + 1], &info);
+
+/* Check the error code from CGESVX. */
+
+ if (info == n + 1) {
+ goto L50;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "CGESVX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L50;
+ }
+
+/* Compare RWORK(2*NRHS+1) from CGESVX with the */
+/* computed reciprocal pivot growth factor RPVGRW */
+
+ if (info != 0) {
+ rpvgrw = clantr_("M", "U", "N", &info, &info, &
+ afac[1], &lda, rdum);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = clange_("M", &n, &info, &a[1], &lda,
+ rdum) / rpvgrw;
+ }
+ } else {
+ rpvgrw = clantr_("M", "U", "N", &n, &n, &afac[1],
+ &lda, rdum);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = clange_("M", &n, &n, &a[1], &lda,
+ rdum) / rpvgrw;
+ }
+ }
+/* Computing MAX */
+ r__2 = rwork[(*nrhs << 1) + 1];
+ result[6] = (r__1 = rpvgrw - rwork[(*nrhs << 1) + 1],
+ dabs(r__1)) / dmax(r__2,rpvgrw) / slamch_(
+ "E");
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ cget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &rwork[(*nrhs << 1) + 1],
+ result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ cget02_(trans, &n, &n, nrhs, &asav[1], &lda, &x[1]
+, &lda, &work[1], &lda, &rwork[(*nrhs <<
+ 1) + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ cget07_(trans, &n, nrhs, &asav[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &c_true, &rwork[*nrhs + 1], &result[3]
+);
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from CGESVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___62.ciunit = *nout;
+ s_wsfe(&io___62);
+ do_fio(&c__1, "CGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___63.ciunit = *nout;
+ s_wsfe(&io___63);
+ do_fio(&c__1, "CGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L40: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___64.ciunit = *nout;
+ s_wsfe(&io___64);
+ do_fio(&c__1, "CGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___65.ciunit = *nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, "CGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___66.ciunit = *nout;
+ s_wsfe(&io___66);
+ do_fio(&c__1, "CGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___67.ciunit = *nout;
+ s_wsfe(&io___67);
+ do_fio(&c__1, "CGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___68.ciunit = *nout;
+ s_wsfe(&io___68);
+ do_fio(&c__1, "CGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___69.ciunit = *nout;
+ s_wsfe(&io___69);
+ do_fio(&c__1, "CGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+
+ }
+
+/* --- Test CGESVXX --- */
+
+/* Restore the matrices A and B. */
+
+ clacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
+ clacpy_("Full", &n, nrhs, &bsav[1], &lda, &b[1], &lda);
+ if (! prefac) {
+ claset_("Full", &n, &n, &c_b166, &c_b166, &afac[1]
+, &lda);
+ }
+ claset_("Full", &n, nrhs, &c_b166, &c_b166, &x[1], &
+ lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ claqge_(&n, &n, &a[1], &lda, &s[1], &s[n + 1], &
+ rowcnd, &colcnd, &amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using CGESVXX. */
+
+ s_copy(srnamc_1.srnamt, "CGESVXX", (ftnlen)32, (
+ ftnlen)7);
+ n_err_bnds__ = 3;
+
+ salloc3();
+
+ cgesvxx_(fact, trans, &n, nrhs, &a[1], &lda, &afac[1],
+ &lda, &iwork[1], equed, &s[1], &s[n + 1], &b[
+ 1], &lda, &x[1], &lda, &rcond, &rpvgrw_svxx__,
+ berr, &n_err_bnds__, errbnds_n__,
+ errbnds_c__, &c__0, &c_b166, &work[1], &rwork[
+ 1], &info);
+
+ free3();
+
+/* Check the error code from CGESVXX. */
+
+ if (info == n + 1) {
+ goto L50;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "CGESVXX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L50;
+ }
+
+/* Compare rpvgrw_svxx from CGESVXX with the computed */
+/* reciprocal pivot growth factor RPVGRW */
+
+ if (info > 0 && info < n + 1) {
+ rpvgrw = cla_rpvgrw__(&n, &info, &a[1], &lda, &
+ afac[1], &lda);
+ } else {
+ rpvgrw = cla_rpvgrw__(&n, &n, &a[1], &lda, &afac[
+ 1], &lda);
+ }
+ result[6] = (r__1 = rpvgrw - rpvgrw_svxx__, dabs(r__1)
+ ) / dmax(rpvgrw_svxx__,rpvgrw) / slamch_(
+ "E");
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ cget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &rwork[(*nrhs << 1) + 1],
+ result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ cget02_(trans, &n, &n, nrhs, &asav[1], &lda, &x[1]
+, &lda, &work[1], &lda, &rwork[(*nrhs <<
+ 1) + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from CGESVXX with the computed value */
+/* in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___75.ciunit = *nout;
+ s_wsfe(&io___75);
+ do_fio(&c__1, "CGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___76.ciunit = *nout;
+ s_wsfe(&io___76);
+ do_fio(&c__1, "CGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L45: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___77.ciunit = *nout;
+ s_wsfe(&io___77);
+ do_fio(&c__1, "CGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___78.ciunit = *nout;
+ s_wsfe(&io___78);
+ do_fio(&c__1, "CGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___79.ciunit = *nout;
+ s_wsfe(&io___79);
+ do_fio(&c__1, "CGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___80.ciunit = *nout;
+ s_wsfe(&io___80);
+ do_fio(&c__1, "CGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___81.ciunit = *nout;
+ s_wsfe(&io___81);
+ do_fio(&c__1, "CGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___82.ciunit = *nout;
+ s_wsfe(&io___82);
+ do_fio(&c__1, "CGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+
+ }
+
+L50:
+ ;
+ }
+L60:
+ ;
+ }
+/* L70: */
+ }
+L80:
+ ;
+ }
+/* L90: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+/* Test Error Bounds for CGESVXX */
+ cebchvxx_(thresh, path);
+ return 0;
+
+/* End of CDRVGE */
+
+} /* cdrvge_ */
diff --git a/TESTING/LIN/cdrvgt.c b/TESTING/LIN/cdrvgt.c
new file mode 100644
index 0000000..c0cc264
--- /dev/null
+++ b/TESTING/LIN/cdrvgt.c
@@ -0,0 +1,726 @@
+/* cdrvgt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static real c_b43 = 1.f;
+static real c_b44 = 0.f;
+static complex c_b65 = {0.f,0.f};
+
+/* Subroutine */ int cdrvgt_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, complex *a, complex *af,
+ complex *b, complex *x, complex *xact, complex *work, real *rwork,
+ integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 0,0,0,1 };
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
+ ", test \002,i2,\002, ratio = \002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
+ "1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002, "
+ "ratio = \002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5, i__6[2];
+ real r__1, r__2;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k, m, n;
+ real z__[3];
+ integer k1, in, kl, ku, ix, nt, lda;
+ char fact[1];
+ real cond;
+ integer mode, koff, imat, info;
+ char path[3], dist[1], type__[1];
+ integer nrun, ifact;
+ extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int cgtt01_(integer *, complex *, complex *,
+ complex *, complex *, complex *, complex *, complex *, integer *,
+ complex *, integer *, real *, real *), cgtt02_(char *, integer *,
+ integer *, complex *, complex *, complex *, complex *, integer *,
+ complex *, integer *, real *, real *);
+ real rcond;
+ extern /* Subroutine */ int cgtt05_(char *, integer *, integer *, complex
+ *, complex *, complex *, complex *, integer *, complex *, integer
+ *, complex *, integer *, real *, real *, real *);
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ real anorm;
+ integer itran;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), cgtsv_(integer *, integer *, complex *,
+ complex *, complex *, complex *, integer *, integer *);
+ char trans[1];
+ integer izero, nerrs;
+ logical zerot;
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), aladhd_(integer *, char *),
+ alaerh_(char *, char *, integer *, integer *, char *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *), clagtm_(char *,
+ integer *, integer *, real *, complex *, complex *, complex *,
+ complex *, integer *, real *, complex *, integer *);
+ real rcondc;
+ extern doublereal clangt_(char *, integer *, complex *, complex *,
+ complex *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), clacpy_(char *, integer *, integer *, complex *, integer *,
+ complex *, integer *), claset_(char *, integer *, integer
+ *, complex *, complex *, complex *, integer *);
+ real rcondi;
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ real rcondo, anormi;
+ extern /* Subroutine */ int clarnv_(integer *, integer *, integer *,
+ complex *), clatms_(integer *, integer *, char *, integer *, char
+ *, real *, integer *, real *, real *, integer *, integer *, char *
+, complex *, integer *, complex *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int cgttrf_(integer *, complex *, complex *,
+ complex *, complex *, integer *, integer *);
+ logical trfcon;
+ real anormo;
+ extern doublereal scasum_(integer *, complex *, integer *);
+ extern /* Subroutine */ int cgttrs_(char *, integer *, integer *, complex
+ *, complex *, complex *, complex *, integer *, complex *, integer
+ *, integer *), cerrvx_(char *, integer *);
+ real result[6];
+ extern /* Subroutine */ int cgtsvx_(char *, char *, integer *, integer *,
+ complex *, complex *, complex *, complex *, complex *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ real *, real *, real *, complex *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVGT tests CGTSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*4) */
+
+/* AF (workspace) COMPLEX array, dimension (NMAX*4) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --af;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "GT", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+/* Computing MAX */
+ i__2 = n - 1;
+ m = max(i__2,0);
+ lda = max(1,n);
+ nimat = 12;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L130;
+ }
+
+/* Set up parameters with CLATB4. */
+
+ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cond, dist);
+
+ zerot = imat >= 8 && imat <= 10;
+ if (imat <= 6) {
+
+/* Types 1-6: generate matrices of known condition number. */
+
+/* Computing MAX */
+ i__3 = 2 - ku, i__4 = 3 - max(1,n);
+ koff = max(i__3,i__4);
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
+ &anorm, &kl, &ku, "Z", &af[koff], &c__3, &work[1], &
+ info);
+
+/* Check the error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, " ", &n, &n, &kl, &
+ ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L130;
+ }
+ izero = 0;
+
+ if (n > 1) {
+ i__3 = n - 1;
+ ccopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
+ i__3 = n - 1;
+ ccopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
+ }
+ ccopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
+ } else {
+
+/* Types 7-12: generate tridiagonal matrices with */
+/* unknown condition numbers. */
+
+ if (! zerot || ! dotype[7]) {
+
+/* Generate a matrix with elements from [-1,1]. */
+
+ i__3 = n + (m << 1);
+ clarnv_(&c__2, iseed, &i__3, &a[1]);
+ if (anorm != 1.f) {
+ i__3 = n + (m << 1);
+ csscal_(&i__3, &anorm, &a[1], &c__1);
+ }
+ } else if (izero > 0) {
+
+/* Reuse the last matrix by copying back the zeroed out */
+/* elements. */
+
+ if (izero == 1) {
+ i__3 = n;
+ a[i__3].r = z__[1], a[i__3].i = 0.f;
+ if (n > 1) {
+ a[1].r = z__[2], a[1].i = 0.f;
+ }
+ } else if (izero == n) {
+ i__3 = n * 3 - 2;
+ a[i__3].r = z__[0], a[i__3].i = 0.f;
+ i__3 = (n << 1) - 1;
+ a[i__3].r = z__[1], a[i__3].i = 0.f;
+ } else {
+ i__3 = (n << 1) - 2 + izero;
+ a[i__3].r = z__[0], a[i__3].i = 0.f;
+ i__3 = n - 1 + izero;
+ a[i__3].r = z__[1], a[i__3].i = 0.f;
+ i__3 = izero;
+ a[i__3].r = z__[2], a[i__3].i = 0.f;
+ }
+ }
+
+/* If IMAT > 7, set one column of the matrix to 0. */
+
+ if (! zerot) {
+ izero = 0;
+ } else if (imat == 8) {
+ izero = 1;
+ i__3 = n;
+ z__[1] = a[i__3].r;
+ i__3 = n;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ if (n > 1) {
+ z__[2] = a[1].r;
+ a[1].r = 0.f, a[1].i = 0.f;
+ }
+ } else if (imat == 9) {
+ izero = n;
+ i__3 = n * 3 - 2;
+ z__[0] = a[i__3].r;
+ i__3 = (n << 1) - 1;
+ z__[1] = a[i__3].r;
+ i__3 = n * 3 - 2;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ i__3 = (n << 1) - 1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ } else {
+ izero = (n + 1) / 2;
+ i__3 = n - 1;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = (n << 1) - 2 + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ i__4 = n - 1 + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ i__4 = i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L20: */
+ }
+ i__3 = n * 3 - 2;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ i__3 = (n << 1) - 1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ }
+ }
+
+ for (ifact = 1; ifact <= 2; ++ifact) {
+ if (ifact == 1) {
+ *(unsigned char *)fact = 'F';
+ } else {
+ *(unsigned char *)fact = 'N';
+ }
+
+/* Compute the condition number for comparison with */
+/* the value returned by CGTSVX. */
+
+ if (zerot) {
+ if (ifact == 1) {
+ goto L120;
+ }
+ rcondo = 0.f;
+ rcondi = 0.f;
+
+ } else if (ifact == 1) {
+ i__3 = n + (m << 1);
+ ccopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
+
+/* Compute the 1-norm and infinity-norm of A. */
+
+ anormo = clangt_("1", &n, &a[1], &a[m + 1], &a[n + m + 1]);
+ anormi = clangt_("I", &n, &a[1], &a[m + 1], &a[n + m + 1]);
+
+/* Factor the matrix A. */
+
+ cgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (
+ m << 1) + 1], &iwork[1], &info);
+
+/* Use CGTTRS to solve for one column at a time of */
+/* inv(A), computing the maximum column sum as we go. */
+
+ ainvnm = 0.f;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__5 = j;
+ x[i__5].r = 0.f, x[i__5].i = 0.f;
+/* L30: */
+ }
+ i__4 = i__;
+ x[i__4].r = 1.f, x[i__4].i = 0.f;
+ cgttrs_("No transpose", &n, &c__1, &af[1], &af[m + 1],
+ &af[n + m + 1], &af[n + (m << 1) + 1], &
+ iwork[1], &x[1], &lda, &info);
+/* Computing MAX */
+ r__1 = ainvnm, r__2 = scasum_(&n, &x[1], &c__1);
+ ainvnm = dmax(r__1,r__2);
+/* L40: */
+ }
+
+/* Compute the 1-norm condition number of A. */
+
+ if (anormo <= 0.f || ainvnm <= 0.f) {
+ rcondo = 1.f;
+ } else {
+ rcondo = 1.f / anormo / ainvnm;
+ }
+
+/* Use CGTTRS to solve for one column at a time of */
+/* inv(A'), computing the maximum column sum as we go. */
+
+ ainvnm = 0.f;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__5 = j;
+ x[i__5].r = 0.f, x[i__5].i = 0.f;
+/* L50: */
+ }
+ i__4 = i__;
+ x[i__4].r = 1.f, x[i__4].i = 0.f;
+ cgttrs_("Conjugate transpose", &n, &c__1, &af[1], &af[
+ m + 1], &af[n + m + 1], &af[n + (m << 1) + 1],
+ &iwork[1], &x[1], &lda, &info);
+/* Computing MAX */
+ r__1 = ainvnm, r__2 = scasum_(&n, &x[1], &c__1);
+ ainvnm = dmax(r__1,r__2);
+/* L60: */
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ if (anormi <= 0.f || ainvnm <= 0.f) {
+ rcondi = 1.f;
+ } else {
+ rcondi = 1.f / anormi / ainvnm;
+ }
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+ *(unsigned char *)trans = *(unsigned char *)&transs[itran
+ - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Generate NRHS random solution vectors. */
+
+ ix = 1;
+ i__3 = *nrhs;
+ for (j = 1; j <= i__3; ++j) {
+ clarnv_(&c__2, iseed, &n, &xact[ix]);
+ ix += lda;
+/* L70: */
+ }
+
+/* Set the right hand side. */
+
+ clagtm_(trans, &n, nrhs, &c_b43, &a[1], &a[m + 1], &a[n +
+ m + 1], &xact[1], &lda, &c_b44, &b[1], &lda);
+
+ if (ifact == 2 && itran == 1) {
+
+/* --- Test CGTSV --- */
+
+/* Solve the system using Gaussian elimination with */
+/* partial pivoting. */
+
+ i__3 = n + (m << 1);
+ ccopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "CGTSV ", (ftnlen)32, (ftnlen)
+ 6);
+ cgtsv_(&n, nrhs, &af[1], &af[m + 1], &af[n + m + 1], &
+ x[1], &lda, &info);
+
+/* Check error code from CGTSV . */
+
+ if (info != izero) {
+ alaerh_(path, "CGTSV ", &info, &izero, " ", &n, &
+ n, &c__1, &c__1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+ nt = 1;
+ if (izero == 0) {
+
+/* Check residual of computed solution. */
+
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
+ lda);
+ cgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n +
+ m + 1], &x[1], &lda, &work[1], &lda, &
+ rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 2; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "CGTSV ", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + nt - 1;
+ }
+
+/* --- Test CGTSVX --- */
+
+ if (ifact > 1) {
+
+/* Initialize AF to zero. */
+
+ i__3 = n * 3 - 2;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ af[i__4].r = 0.f, af[i__4].i = 0.f;
+/* L90: */
+ }
+ }
+ claset_("Full", &n, nrhs, &c_b65, &c_b65, &x[1], &lda);
+
+/* Solve the system and compute the condition number and */
+/* error bounds using CGTSVX. */
+
+ s_copy(srnamc_1.srnamt, "CGTSVX", (ftnlen)32, (ftnlen)6);
+ cgtsvx_(fact, trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m
+ + 1], &af[1], &af[m + 1], &af[n + m + 1], &af[n +
+ (m << 1) + 1], &iwork[1], &b[1], &lda, &x[1], &
+ lda, &rcond, &rwork[1], &rwork[*nrhs + 1], &work[
+ 1], &rwork[(*nrhs << 1) + 1], &info);
+
+/* Check the error code from CGTSVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__6[0] = 1, a__1[0] = fact;
+ i__6[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__6, &c__2, (ftnlen)2);
+ alaerh_(path, "CGTSVX", &info, &izero, ch__1, &n, &n,
+ &c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ if (ifact >= 2) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ cgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &
+ af[m + 1], &af[n + m + 1], &af[n + (m << 1) +
+ 1], &iwork[1], &work[1], &lda, &rwork[1],
+ result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Check residual of computed solution. */
+
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ cgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
+ 1], &x[1], &lda, &work[1], &lda, &rwork[1], &
+ result[1]);
+
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* Check the error bounds from iterative refinement. */
+
+ cgtt05_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
+ 1], &b[1], &lda, &x[1], &lda, &xact[1], &lda,
+ &rwork[1], &rwork[*nrhs + 1], &result[3]);
+ nt = 5;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = k1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___46.ciunit = *nout;
+ s_wsfe(&io___46);
+ do_fio(&c__1, "CGTSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L100: */
+ }
+
+/* Check the reciprocal of the condition number. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___47.ciunit = *nout;
+ s_wsfe(&io___47);
+ do_fio(&c__1, "CGTSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+ nrun = nrun + nt - k1 + 2;
+
+/* L110: */
+ }
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CDRVGT */
+
+} /* cdrvgt_ */
diff --git a/TESTING/LIN/cdrvhe.c b/TESTING/LIN/cdrvhe.c
new file mode 100644
index 0000000..01be325
--- /dev/null
+++ b/TESTING/LIN/cdrvhe.c
@@ -0,0 +1,687 @@
+/* cdrvhe.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static complex c_b50 = {0.f,0.f};
+
+/* Subroutine */ int cdrvhe_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, integer *nmax, complex *
+ a, complex *afac, complex *ainv, complex *b, complex *x, complex *
+ xact, complex *work, real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char facts[1*2] = "F" "N";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002,"
+ " ratio =\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5, i__6[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, k1, nb, in, kl, ku, nt, lda;
+ char fact[1];
+ integer ioff, mode, imat, info;
+ char path[3], dist[1], uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int chet01_(char *, integer *, complex *, integer
+ *, complex *, integer *, integer *, complex *, integer *, real *,
+ real *);
+ integer ifact;
+ extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *);
+ integer nfail, iseed[4], nbmin;
+ real rcond;
+ extern /* Subroutine */ int cpot02_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, complex *, integer *, real *,
+ real *);
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int chesv_(char *, integer *, integer *, complex *
+, integer *, integer *, complex *, integer *, complex *, integer *
+, integer *), cpot05_(char *, integer *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, real *, real *);
+ real anorm;
+ integer iuplo, izero, nerrs, lwork;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), aladhd_(integer *, char *);
+ extern doublereal clanhe_(char *, char *, integer *, complex *, integer *,
+ real *);
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *), claipd_(integer *, complex *, integer *, integer *);
+ real rcondc;
+ extern /* Subroutine */ int chetrf_(char *, integer *, complex *, integer
+ *, integer *, complex *, integer *, integer *), clacpy_(
+ char *, integer *, integer *, complex *, integer *, complex *,
+ integer *), chetri_(char *, integer *, complex *, integer
+ *, integer *, complex *, integer *), clarhs_(char *, char
+ *, char *, char *, integer *, integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, integer *, integer *),
+ claset_(char *, integer *, integer *, complex *, complex *,
+ complex *, integer *), alasvm_(char *, integer *, integer
+ *, integer *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, complex *, integer *, complex *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), chesvx_(char *,
+ char *, integer *, integer *, complex *, integer *, complex *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ real *, real *, real *, complex *, integer *, real *, integer *), cerrvx_(char *, integer *);
+ real result[6];
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVHE tests the driver routines CHESV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(2,NRHS)) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ *(unsigned char *)path = 'C';
+ s_copy(path + 1, "HE", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+/* Computing MAX */
+ i__1 = *nmax << 1, i__2 = *nmax * *nrhs;
+ lwork = max(i__1,i__2);
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 10;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L170;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L170;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Set up parameters with CLATB4 and generate a test matrix */
+/* with CLATMS. */
+
+ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
+ &info);
+
+/* Check error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L160;
+ }
+
+/* For types 3-6, zero one or more rows and columns of the */
+/* matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * lda;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ ioff = 0;
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+/* L60: */
+ }
+ ioff += lda;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+/* L80: */
+ }
+ ioff += lda;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ i__3 = lda + 1;
+ claipd_(&n, &a[1], &i__3, &c__0);
+
+ for (ifact = 1; ifact <= 2; ++ifact) {
+
+/* Do first for FACT = 'F', then for other values. */
+
+ *(unsigned char *)fact = *(unsigned char *)&facts[ifact -
+ 1];
+
+/* Compute the condition number for comparison with */
+/* the value returned by CHESVX. */
+
+ if (zerot) {
+ if (ifact == 1) {
+ goto L150;
+ }
+ rcondc = 0.f;
+
+ } else if (ifact == 1) {
+
+/* Compute the 1-norm of A. */
+
+ anorm = clanhe_("1", uplo, &n, &a[1], &lda, &rwork[1]);
+
+/* Factor the matrix A. */
+
+ clacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ chetrf_(uplo, &n, &afac[1], &lda, &iwork[1], &work[1],
+ &lwork, &info);
+
+/* Compute inv(A) and take its norm. */
+
+ clacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
+ chetri_(uplo, &n, &ainv[1], &lda, &iwork[1], &work[1],
+ &info);
+ ainvnm = clanhe_("1", uplo, &n, &ainv[1], &lda, &
+ rwork[1]);
+
+/* Compute the 1-norm condition number of A. */
+
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondc = 1.f;
+ } else {
+ rcondc = 1.f / anorm / ainvnm;
+ }
+ }
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (ftnlen)6);
+ clarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, nrhs, &
+ a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
+ info);
+ *(unsigned char *)xtype = 'C';
+
+/* --- Test CHESV --- */
+
+ if (ifact == 2) {
+ clacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
+
+/* Factor the matrix and solve the system using CHESV. */
+
+ s_copy(srnamc_1.srnamt, "CHESV ", (ftnlen)32, (ftnlen)
+ 6);
+ chesv_(uplo, &n, nrhs, &afac[1], &lda, &iwork[1], &x[
+ 1], &lda, &work[1], &lwork, &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from CHESV . */
+
+ if (info != k) {
+ alaerh_(path, "CHESV ", &info, &k, uplo, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L120;
+ } else if (info != 0) {
+ goto L120;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ chet01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &iwork[
+ 1], &ainv[1], &lda, &rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ cpot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda, &
+ work[1], &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "CHESV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+L120:
+ ;
+ }
+
+/* --- Test CHESVX --- */
+
+ if (ifact == 2) {
+ claset_(uplo, &n, &n, &c_b50, &c_b50, &afac[1], &lda);
+ }
+ claset_("Full", &n, nrhs, &c_b50, &c_b50, &x[1], &lda);
+
+/* Solve the system and compute the condition number and */
+/* error bounds using CHESVX. */
+
+ s_copy(srnamc_1.srnamt, "CHESVX", (ftnlen)32, (ftnlen)6);
+ chesvx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1], &lda,
+ &iwork[1], &b[1], &lda, &x[1], &lda, &rcond, &
+ rwork[1], &rwork[*nrhs + 1], &work[1], &lwork, &
+ rwork[(*nrhs << 1) + 1], &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L130:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L130;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L130;
+ }
+ }
+
+/* Check the error code from CHESVX. */
+
+ if (info != k) {
+/* Writing concatenation */
+ i__6[0] = 1, a__1[0] = fact;
+ i__6[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__6, &c__2, (ftnlen)2);
+ alaerh_(path, "CHESVX", &info, &k, ch__1, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L150;
+ }
+
+ if (info == 0) {
+ if (ifact >= 2) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ chet01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &ainv[1], &lda, &rwork[(*nrhs <<
+ 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ cpot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda, &
+ work[1], &lda, &rwork[(*nrhs << 1) + 1], &
+ result[1]);
+
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* Check the error bounds from iterative refinement. */
+
+ cpot05_(uplo, &n, nrhs, &a[1], &lda, &b[1], &lda, &x[
+ 1], &lda, &xact[1], &lda, &rwork[1], &rwork[*
+ nrhs + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from CHESVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "CHESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L140: */
+ }
+ nrun = nrun + 7 - k1;
+
+L150:
+ ;
+ }
+
+L160:
+ ;
+ }
+L170:
+ ;
+ }
+/* L180: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CDRVHE */
+
+} /* cdrvhe_ */
diff --git a/TESTING/LIN/cdrvhp.c b/TESTING/LIN/cdrvhp.c
new file mode 100644
index 0000000..6613956
--- /dev/null
+++ b/TESTING/LIN/cdrvhp.c
@@ -0,0 +1,693 @@
+/* cdrvhp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static complex c_b64 = {0.f,0.f};
+
+/* Subroutine */ int cdrvhp_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, integer *nmax, complex *
+ a, complex *afac, complex *ainv, complex *b, complex *x, complex *
+ xact, complex *work, real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char facts[1*2] = "F" "N";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002,"
+ " ratio =\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5, i__6[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, k1, nb, in, kl, ku, nt, lda, npp;
+ char fact[1];
+ integer ioff, mode, imat, info;
+ char path[3], dist[1], uplo[1], type__[1];
+ integer nrun, ifact;
+ extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int chpt01_(char *, integer *, complex *, complex
+ *, integer *, complex *, integer *, real *, real *);
+ integer nbmin;
+ real rcond;
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int cppt02_(char *, integer *, integer *, complex
+ *, complex *, integer *, complex *, integer *, real *, real *), cppt05_(char *, integer *, integer *, complex *, complex
+ *, integer *, complex *, integer *, complex *, integer *, real *,
+ real *, real *);
+ real anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), chpsv_(char *, integer *, integer *,
+ complex *, integer *, complex *, integer *, integer *);
+ integer iuplo, izero, nerrs;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), aladhd_(integer *, char *),
+ alaerh_(char *, char *, integer *, integer *, char *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *), claipd_(integer *,
+ complex *, integer *, integer *);
+ extern doublereal clanhp_(char *, char *, integer *, complex *, real *);
+ real rcondc;
+ char packit[1];
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), clarhs_(char *, char
+ *, char *, char *, integer *, integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, integer *, integer *),
+ claset_(char *, integer *, integer *, complex *, complex *,
+ complex *, integer *), alasvm_(char *, integer *, integer
+ *, integer *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, complex *, integer *, complex *, integer *), chptrf_(char *, integer *, complex *, integer *,
+ integer *);
+ real ainvnm;
+ extern /* Subroutine */ int chptri_(char *, integer *, complex *, integer
+ *, complex *, integer *), xlaenv_(integer *, integer *),
+ cerrvx_(char *, integer *), chpsvx_(char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *, real *, complex *
+, real *, integer *);
+ real result[6];
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVHP tests the driver routines CHPSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AFAC (workspace) COMPLEX array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AINV (workspace) COMPLEX array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(2,NRHS)) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ *(unsigned char *)path = 'C';
+ s_copy(path + 1, "HP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ npp = n * (n + 1) / 2;
+ *(unsigned char *)xtype = 'N';
+ nimat = 10;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L170;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L170;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ if (iuplo == 1) {
+ *(unsigned char *)uplo = 'U';
+ *(unsigned char *)packit = 'C';
+ } else {
+ *(unsigned char *)uplo = 'L';
+ *(unsigned char *)packit = 'R';
+ }
+
+/* Set up parameters with CLATB4 and generate a test matrix */
+/* with CLATMS. */
+
+ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
+ 1], &info);
+
+/* Check error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L160;
+ }
+
+/* For types 3-6, zero one or more rows and columns of the */
+/* matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * izero / 2;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff += i__;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff = ioff + n - i__;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ ioff = 0;
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+/* L60: */
+ }
+ ioff += j;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+/* L80: */
+ }
+ ioff = ioff + n - j;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ if (iuplo == 1) {
+ claipd_(&n, &a[1], &c__2, &c__1);
+ } else {
+ claipd_(&n, &a[1], &n, &c_n1);
+ }
+
+ for (ifact = 1; ifact <= 2; ++ifact) {
+
+/* Do first for FACT = 'F', then for other values. */
+
+ *(unsigned char *)fact = *(unsigned char *)&facts[ifact -
+ 1];
+
+/* Compute the condition number for comparison with */
+/* the value returned by CHPSVX. */
+
+ if (zerot) {
+ if (ifact == 1) {
+ goto L150;
+ }
+ rcondc = 0.f;
+
+ } else if (ifact == 1) {
+
+/* Compute the 1-norm of A. */
+
+ anorm = clanhp_("1", uplo, &n, &a[1], &rwork[1]);
+
+/* Factor the matrix A. */
+
+ ccopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ chptrf_(uplo, &n, &afac[1], &iwork[1], &info);
+
+/* Compute inv(A) and take its norm. */
+
+ ccopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
+ chptri_(uplo, &n, &ainv[1], &iwork[1], &work[1], &
+ info);
+ ainvnm = clanhp_("1", uplo, &n, &ainv[1], &rwork[1]);
+
+/* Compute the 1-norm condition number of A. */
+
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondc = 1.f;
+ } else {
+ rcondc = 1.f / anorm / ainvnm;
+ }
+ }
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (ftnlen)6);
+ clarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, nrhs, &
+ a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
+ info);
+ *(unsigned char *)xtype = 'C';
+
+/* --- Test CHPSV --- */
+
+ if (ifact == 2) {
+ ccopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
+
+/* Factor the matrix and solve the system using CHPSV. */
+
+ s_copy(srnamc_1.srnamt, "CHPSV ", (ftnlen)32, (ftnlen)
+ 6);
+ chpsv_(uplo, &n, nrhs, &afac[1], &iwork[1], &x[1], &
+ lda, &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from CHPSV . */
+
+ if (info != k) {
+ alaerh_(path, "CHPSV ", &info, &k, uplo, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L120;
+ } else if (info != 0) {
+ goto L120;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ chpt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &ainv[1]
+, &lda, &rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ cppt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[1],
+ &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "CHPSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+L120:
+ ;
+ }
+
+/* --- Test CHPSVX --- */
+
+ if (ifact == 2 && npp > 0) {
+ claset_("Full", &npp, &c__1, &c_b64, &c_b64, &afac[1],
+ &npp);
+ }
+ claset_("Full", &n, nrhs, &c_b64, &c_b64, &x[1], &lda);
+
+/* Solve the system and compute the condition number and */
+/* error bounds using CHPSVX. */
+
+ s_copy(srnamc_1.srnamt, "CHPSVX", (ftnlen)32, (ftnlen)6);
+ chpsvx_(fact, uplo, &n, nrhs, &a[1], &afac[1], &iwork[1],
+ &b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &
+ rwork[*nrhs + 1], &work[1], &rwork[(*nrhs << 1) +
+ 1], &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L130:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L130;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L130;
+ }
+ }
+
+/* Check the error code from CHPSVX. */
+
+ if (info != k) {
+/* Writing concatenation */
+ i__6[0] = 1, a__1[0] = fact;
+ i__6[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__6, &c__2, (ftnlen)2);
+ alaerh_(path, "CHPSVX", &info, &k, ch__1, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L150;
+ }
+
+ if (info == 0) {
+ if (ifact >= 2) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ chpt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &
+ ainv[1], &lda, &rwork[(*nrhs << 1) + 1],
+ result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ cppt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[1],
+ &lda, &rwork[(*nrhs << 1) + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* Check the error bounds from iterative refinement. */
+
+ cppt05_(uplo, &n, nrhs, &a[1], &b[1], &lda, &x[1], &
+ lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs
+ + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from CHPSVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "CHPSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L140: */
+ }
+ nrun = nrun + 7 - k1;
+
+L150:
+ ;
+ }
+
+L160:
+ ;
+ }
+L170:
+ ;
+ }
+/* L180: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CDRVHP */
+
+} /* cdrvhp_ */
diff --git a/TESTING/LIN/cdrvls.c b/TESTING/LIN/cdrvls.c
new file mode 100644
index 0000000..19f2928
--- /dev/null
+++ b/TESTING/LIN/cdrvls.c
@@ -0,0 +1,847 @@
+/* cdrvls.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static complex c_b2 = {0.f,0.f};
+static integer c__9 = 9;
+static integer c__25 = 25;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static real c_b91 = -1.f;
+
+/* Subroutine */ int cdrvls_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nns, integer *nsval, integer *
+ nnb, integer *nbval, integer *nxval, real *thresh, logical *tsterr,
+ complex *a, complex *copya, complex *b, complex *copyb, complex *c__,
+ real *s, real *copys, complex *work, real *rwork, integer *iwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 TRANS='\002,a1,\002', M=\002,i5,\002, N"
+ "=\002,i5,\002, NRHS=\002,i4,\002, NB=\002,i4,\002, type\002,i2"
+ ",\002, test(\002,i2,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, NRHS="
+ "\002,i4,\002, NB=\002,i4,\002, type\002,i2,\002, test(\002,i2"
+ ",\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, m, n, nb, im, in, lda, ldb, inb;
+ real eps;
+ integer ins, info;
+ char path[3];
+ integer rank, nrhs, nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), cgemm_(
+ char *, char *, integer *, integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, complex *,
+ integer *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int cgels_(char *, integer *, integer *, integer *
+, complex *, integer *, complex *, integer *, complex *, integer *
+, integer *);
+ integer crank, irank;
+ real rcond;
+ integer itran, mnmin, ncols;
+ real norma, normb;
+ extern doublereal cqrt12_(integer *, integer *, complex *, integer *,
+ real *, complex *, integer *, real *), cqrt14_(char *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *), cqrt17_(char *, integer *, integer
+ *, integer *, integer *, complex *, integer *, complex *, integer
+ *, complex *, integer *, complex *, complex *, integer *);
+ char trans[1];
+ integer nerrs, itype;
+ extern doublereal sasum_(integer *, real *, integer *);
+ integer lwork;
+ extern /* Subroutine */ int cqrt13_(integer *, integer *, integer *,
+ complex *, integer *, real *, integer *), cqrt15_(integer *,
+ integer *, integer *, integer *, integer *, complex *, integer *,
+ complex *, integer *, real *, integer *, real *, real *, integer *
+, complex *, integer *), cqrt16_(char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, real *, real *), saxpy_(integer *, real *,
+ real *, integer *, real *, integer *);
+ integer nrows, lwlsy;
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ integer iscale;
+ extern /* Subroutine */ int cgelsd_(integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, real *, real *,
+ integer *, complex *, integer *, real *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), clacpy_(char *, integer *, integer *, complex *, integer *,
+ complex *, integer *), cgelss_(integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, real *,
+ real *, integer *, complex *, integer *, real *, integer *),
+ alasvm_(char *, integer *, integer *, integer *, integer *), cgelsx_(integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, integer *, real *, integer *,
+ complex *, real *, integer *), cgelsy_(integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, integer *,
+ real *, integer *, complex *, integer *, real *, integer *),
+ clarnv_(integer *, integer *, integer *, complex *), cerrls_(char
+ *, integer *), xlaenv_(integer *, integer *);
+ integer ldwork;
+ real result[18];
+
+ /* Fortran I/O blocks */
+ static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVLS tests the least squares driver routines CGELS, CGELSX, CGELSS, */
+/* CGELSY and CGELSD. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+/* The matrix of type j is generated as follows: */
+/* j=1: A = U*D*V where U and V are random unitary matrices */
+/* and D has random entries (> 0.1) taken from a uniform */
+/* distribution (0,1). A is full rank. */
+/* j=2: The same of 1, but A is scaled up. */
+/* j=3: The same of 1, but A is scaled down. */
+/* j=4: A = U*D*V where U and V are random unitary matrices */
+/* and D has 3*min(M,N)/4 random entries (> 0.1) taken */
+/* from a uniform distribution (0,1) and the remaining */
+/* entries set to 0. A is rank-deficient. */
+/* j=5: The same of 4, but A is scaled up. */
+/* j=6: The same of 5, but A is scaled down. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) COMPLEX array, dimension (MMAX*NMAX) */
+/* where MMAX is the maximum value of M in MVAL and NMAX is the */
+/* maximum value of N in NVAL. */
+
+/* COPYA (workspace) COMPLEX array, dimension (MMAX*NMAX) */
+
+/* B (workspace) COMPLEX array, dimension (MMAX*NSMAX) */
+/* where MMAX is the maximum value of M in MVAL and NSMAX is the */
+/* maximum value of NRHS in NSVAL. */
+
+/* COPYB (workspace) COMPLEX array, dimension (MMAX*NSMAX) */
+
+/* C (workspace) COMPLEX array, dimension (MMAX*NSMAX) */
+
+/* S (workspace) REAL array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* COPYS (workspace) REAL array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (MMAX*NMAX + 4*NMAX + MMAX). */
+
+/* RWORK (workspace) REAL array, dimension (5*NMAX-1) */
+
+/* IWORK (workspace) INTEGER array, dimension (15*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --copys;
+ --s;
+ --c__;
+ --copyb;
+ --b;
+ --copya;
+ --a;
+ --nxval;
+ --nbval;
+ --nsval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "LS", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = slamch_("Epsilon");
+
+/* Threshold for rank estimation */
+
+ rcond = sqrt(eps) - (sqrt(eps) - eps) / 2;
+
+/* Test the error exits */
+
+ xlaenv_(&c__9, &c__25);
+ if (*tsterr) {
+ cerrls_(path, nout);
+ }
+
+/* Print the header if NM = 0 or NN = 0 and THRESH = 0. */
+
+ if ((*nm == 0 || *nn == 0) && *thresh == 0.f) {
+ alahd_(nout, path);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+ lda = max(1,m);
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__3 = max(1,m);
+ ldb = max(i__3,n);
+
+ i__3 = *nns;
+ for (ins = 1; ins <= i__3; ++ins) {
+ nrhs = nsval[ins];
+/* Computing MAX */
+ i__4 = 1, i__5 = (m + nrhs) * (n + 2), i__4 = max(i__4,i__5),
+ i__5 = (n + nrhs) * (m + 2), i__4 = max(i__4,i__5),
+ i__5 = m * n + (mnmin << 2) + max(m,n), i__4 = max(
+ i__4,i__5), i__5 = (n << 1) + m;
+ lwork = max(i__4,i__5);
+
+ for (irank = 1; irank <= 2; ++irank) {
+ for (iscale = 1; iscale <= 3; ++iscale) {
+ itype = (irank - 1) * 3 + iscale;
+ if (! dotype[itype]) {
+ goto L100;
+ }
+
+ if (irank == 1) {
+
+/* Test CGELS */
+
+/* Generate a matrix of scaling type ISCALE */
+
+ cqrt13_(&iscale, &m, &n, ©a[1], &lda, &norma,
+ iseed);
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__3, &nxval[inb]);
+
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ *(unsigned char *)trans = 'N';
+ nrows = m;
+ ncols = n;
+ } else {
+ *(unsigned char *)trans = 'C';
+ nrows = n;
+ ncols = m;
+ }
+ ldwork = max(1,ncols);
+
+/* Set up a consistent rhs */
+
+ if (ncols > 0) {
+ i__5 = ncols * nrhs;
+ clarnv_(&c__2, iseed, &i__5, &work[1])
+ ;
+ i__5 = ncols * nrhs;
+ r__1 = 1.f / (real) ncols;
+ csscal_(&i__5, &r__1, &work[1], &c__1)
+ ;
+ }
+ cgemm_(trans, "No transpose", &nrows, &
+ nrhs, &ncols, &c_b1, ©a[1], &
+ lda, &work[1], &ldwork, &c_b2, &b[
+ 1], &ldb);
+ clacpy_("Full", &nrows, &nrhs, &b[1], &
+ ldb, ©b[1], &ldb);
+
+/* Solve LS or overdetermined system */
+
+ if (m > 0 && n > 0) {
+ clacpy_("Full", &m, &n, ©a[1], &
+ lda, &a[1], &lda);
+ clacpy_("Full", &nrows, &nrhs, ©b[
+ 1], &ldb, &b[1], &ldb);
+ }
+ s_copy(srnamc_1.srnamt, "CGELS ", (ftnlen)
+ 32, (ftnlen)6);
+ cgels_(trans, &m, &n, &nrhs, &a[1], &lda,
+ &b[1], &ldb, &work[1], &lwork, &
+ info);
+
+ if (info != 0) {
+ alaerh_(path, "CGELS ", &info, &c__0,
+ trans, &m, &n, &nrhs, &c_n1, &
+ nb, &itype, &nfail, &nerrs,
+ nout);
+ }
+
+/* Check correctness of results */
+
+ ldwork = max(1,nrows);
+ if (nrows > 0 && nrhs > 0) {
+ clacpy_("Full", &nrows, &nrhs, ©b[
+ 1], &ldb, &c__[1], &ldb);
+ }
+ cqrt16_(trans, &m, &n, &nrhs, ©a[1], &
+ lda, &b[1], &ldb, &c__[1], &ldb, &
+ rwork[1], result);
+
+ if (itran == 1 && m >= n || itran == 2 &&
+ m < n) {
+
+/* Solving LS system */
+
+ result[1] = cqrt17_(trans, &c__1, &m,
+ &n, &nrhs, ©a[1], &lda, &
+ b[1], &ldb, ©b[1], &ldb, &
+ c__[1], &work[1], &lwork);
+ } else {
+
+/* Solving overdetermined system */
+
+ result[1] = cqrt14_(trans, &m, &n, &
+ nrhs, ©a[1], &lda, &b[1],
+ &ldb, &work[1], &lwork);
+ }
+
+/* Print information about the tests that */
+/* did not pass the threshold. */
+
+ for (k = 1; k <= 2; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&nrhs, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nb, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&itype, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k -
+ 1], (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += 2;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+/* Generate a matrix of scaling type ISCALE and rank */
+/* type IRANK. */
+
+ cqrt15_(&iscale, &irank, &m, &n, &nrhs, ©a[1], &
+ lda, ©b[1], &ldb, ©s[1], &rank, &
+ norma, &normb, iseed, &work[1], &lwork);
+
+/* workspace used: MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M) */
+
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ iwork[j] = 0;
+/* L50: */
+ }
+ ldwork = max(1,m);
+
+/* Test CGELSX */
+
+/* CGELSX: Compute the minimum-norm solution X */
+/* to min( norm( A * X - B ) ) */
+/* using a complete orthogonal factorization. */
+
+ clacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &lda);
+ clacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1], &
+ ldb);
+
+ s_copy(srnamc_1.srnamt, "CGELSX", (ftnlen)32, (ftnlen)
+ 6);
+ cgelsx_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
+ iwork[1], &rcond, &crank, &work[1], &rwork[1],
+ &info);
+
+ if (info != 0) {
+ alaerh_(path, "CGELSX", &info, &c__0, " ", &m, &n,
+ &nrhs, &c_n1, &nb, &itype, &nfail, &
+ nerrs, nout);
+ }
+
+/* workspace used: MAX( MNMIN+3*N, 2*MNMIN+NRHS ) */
+
+/* Test 3: Compute relative error in svd */
+/* workspace: M*N + 4*MIN(M,N) + MAX(M,N) */
+
+ result[2] = cqrt12_(&crank, &crank, &a[1], &lda, &
+ copys[1], &work[1], &lwork, &rwork[1]);
+
+/* Test 4: Compute error in solution */
+/* workspace: M*NRHS + M */
+
+ clacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[1],
+ &ldwork);
+ cqrt16_("No transpose", &m, &n, &nrhs, ©a[1], &
+ lda, &b[1], &ldb, &work[1], &ldwork, &rwork[1]
+, &result[3]);
+
+/* Test 5: Check norm of r'*A */
+/* workspace: NRHS*(M+N) */
+
+ result[4] = 0.f;
+ if (m > crank) {
+ result[4] = cqrt17_("No transpose", &c__1, &m, &n,
+ &nrhs, ©a[1], &lda, &b[1], &ldb, &
+ copyb[1], &ldb, &c__[1], &work[1], &lwork);
+ }
+
+/* Test 6: Check if x is in the rowspace of A */
+/* workspace: (M+NRHS)*(N+2) */
+
+ result[5] = 0.f;
+
+ if (n > crank) {
+ result[5] = cqrt14_("No transpose", &m, &n, &nrhs,
+ ©a[1], &lda, &b[1], &ldb, &work[1], &
+ lwork);
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 3; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&itype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += 4;
+
+/* Loop for testing different block sizes. */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__3, &nxval[inb]);
+
+/* Test CGELSY */
+
+/* CGELSY: Compute the minimum-norm solution */
+/* X to min( norm( A * X - B ) ) */
+/* using the rank-revealing orthogonal */
+/* factorization. */
+
+ clacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
+ lda);
+ clacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
+ &ldb);
+
+/* Initialize vector IWORK. */
+
+ i__5 = n;
+ for (j = 1; j <= i__5; ++j) {
+ iwork[j] = 0;
+/* L70: */
+ }
+
+/* Set LWLSY to the adequate value. */
+
+/* Computing MAX */
+ i__5 = mnmin << 1, i__6 = nb * (n + 1), i__5 =
+ max(i__5,i__6), i__6 = mnmin + nb * nrhs;
+ lwlsy = mnmin + max(i__5,i__6);
+ lwlsy = max(1,lwlsy);
+
+ s_copy(srnamc_1.srnamt, "CGELSY", (ftnlen)32, (
+ ftnlen)6);
+ cgelsy_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
+ iwork[1], &rcond, &crank, &work[1], &
+ lwlsy, &rwork[1], &info);
+ if (info != 0) {
+ alaerh_(path, "CGELSY", &info, &c__0, " ", &m,
+ &n, &nrhs, &c_n1, &nb, &itype, &
+ nfail, &nerrs, nout);
+ }
+
+/* workspace used: 2*MNMIN+NB*NB+NB*MAX(N,NRHS) */
+
+/* Test 7: Compute relative error in svd */
+/* workspace: M*N + 4*MIN(M,N) + MAX(M,N) */
+
+ result[6] = cqrt12_(&crank, &crank, &a[1], &lda, &
+ copys[1], &work[1], &lwork, &rwork[1]);
+
+/* Test 8: Compute error in solution */
+/* workspace: M*NRHS + M */
+
+ clacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
+ 1], &ldwork);
+ cqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
+ &lda, &b[1], &ldb, &work[1], &ldwork, &
+ rwork[1], &result[7]);
+
+/* Test 9: Check norm of r'*A */
+/* workspace: NRHS*(M+N) */
+
+ result[8] = 0.f;
+ if (m > crank) {
+ result[8] = cqrt17_("No transpose", &c__1, &m,
+ &n, &nrhs, ©a[1], &lda, &b[1], &
+ ldb, ©b[1], &ldb, &c__[1], &work[
+ 1], &lwork);
+ }
+
+/* Test 10: Check if x is in the rowspace of A */
+/* workspace: (M+NRHS)*(N+2) */
+
+ result[9] = 0.f;
+
+ if (n > crank) {
+ result[9] = cqrt14_("No transpose", &m, &n, &
+ nrhs, ©a[1], &lda, &b[1], &ldb, &
+ work[1], &lwork);
+ }
+
+/* Test CGELSS */
+
+/* CGELSS: Compute the minimum-norm solution */
+/* X to min( norm( A * X - B ) ) */
+/* using the SVD. */
+
+ clacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
+ lda);
+ clacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
+ &ldb);
+ s_copy(srnamc_1.srnamt, "CGELSS", (ftnlen)32, (
+ ftnlen)6);
+ cgelss_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
+ s[1], &rcond, &crank, &work[1], &lwork, &
+ rwork[1], &info);
+
+ if (info != 0) {
+ alaerh_(path, "CGELSS", &info, &c__0, " ", &m,
+ &n, &nrhs, &c_n1, &nb, &itype, &
+ nfail, &nerrs, nout);
+ }
+
+/* workspace used: 3*min(m,n) + */
+/* max(2*min(m,n),nrhs,max(m,n)) */
+
+/* Test 11: Compute relative error in svd */
+
+ if (rank > 0) {
+ saxpy_(&mnmin, &c_b91, ©s[1], &c__1, &s[1]
+, &c__1);
+ result[10] = sasum_(&mnmin, &s[1], &c__1) /
+ sasum_(&mnmin, ©s[1], &c__1) / (
+ eps * (real) mnmin);
+ } else {
+ result[10] = 0.f;
+ }
+
+/* Test 12: Compute error in solution */
+
+ clacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
+ 1], &ldwork);
+ cqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
+ &lda, &b[1], &ldb, &work[1], &ldwork, &
+ rwork[1], &result[11]);
+
+/* Test 13: Check norm of r'*A */
+
+ result[12] = 0.f;
+ if (m > crank) {
+ result[12] = cqrt17_("No transpose", &c__1, &
+ m, &n, &nrhs, ©a[1], &lda, &b[1],
+ &ldb, ©b[1], &ldb, &c__[1], &work[
+ 1], &lwork);
+ }
+
+/* Test 14: Check if x is in the rowspace of A */
+
+ result[13] = 0.f;
+ if (n > crank) {
+ result[13] = cqrt14_("No transpose", &m, &n, &
+ nrhs, ©a[1], &lda, &b[1], &ldb, &
+ work[1], &lwork);
+ }
+
+/* Test CGELSD */
+
+/* CGELSD: Compute the minimum-norm solution X */
+/* to min( norm( A * X - B ) ) using a */
+/* divide and conquer SVD. */
+
+ xlaenv_(&c__9, &c__25);
+
+ clacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
+ lda);
+ clacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
+ &ldb);
+
+ s_copy(srnamc_1.srnamt, "CGELSD", (ftnlen)32, (
+ ftnlen)6);
+ cgelsd_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
+ s[1], &rcond, &crank, &work[1], &lwork, &
+ rwork[1], &iwork[1], &info);
+ if (info != 0) {
+ alaerh_(path, "CGELSD", &info, &c__0, " ", &m,
+ &n, &nrhs, &c_n1, &nb, &itype, &
+ nfail, &nerrs, nout);
+ }
+
+/* Test 15: Compute relative error in svd */
+
+ if (rank > 0) {
+ saxpy_(&mnmin, &c_b91, ©s[1], &c__1, &s[1]
+, &c__1);
+ result[14] = sasum_(&mnmin, &s[1], &c__1) /
+ sasum_(&mnmin, ©s[1], &c__1) / (
+ eps * (real) mnmin);
+ } else {
+ result[14] = 0.f;
+ }
+
+/* Test 16: Compute error in solution */
+
+ clacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
+ 1], &ldwork);
+ cqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
+ &lda, &b[1], &ldb, &work[1], &ldwork, &
+ rwork[1], &result[15]);
+
+/* Test 17: Check norm of r'*A */
+
+ result[16] = 0.f;
+ if (m > crank) {
+ result[16] = cqrt17_("No transpose", &c__1, &
+ m, &n, &nrhs, ©a[1], &lda, &b[1],
+ &ldb, ©b[1], &ldb, &c__[1], &work[
+ 1], &lwork);
+ }
+
+/* Test 18: Check if x is in the rowspace of A */
+
+ result[17] = 0.f;
+ if (n > crank) {
+ result[17] = cqrt14_("No transpose", &m, &n, &
+ nrhs, ©a[1], &lda, &b[1], &ldb, &
+ work[1], &lwork);
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 7; k <= 18; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&itype, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun += 12;
+
+/* L90: */
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CDRVLS */
+
+} /* cdrvls_ */
diff --git a/TESTING/LIN/cdrvpb.c b/TESTING/LIN/cdrvpb.c
new file mode 100644
index 0000000..18764bd
--- /dev/null
+++ b/TESTING/LIN/cdrvpb.c
@@ -0,0 +1,827 @@
+/* cdrvpb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static complex c_b47 = {0.f,0.f};
+static complex c_b48 = {1.f,0.f};
+
+/* Subroutine */ int cdrvpb_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, integer *nmax, complex *
+ a, complex *afac, complex *asav, complex *b, complex *bsav, complex *
+ x, complex *xact, real *s, complex *work, real *rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*2] = "N" "Y";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, KD =\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002',"
+ " \002,i5,\002, \002,i5,\002, ... ), EQUED='\002,a1,\002', type"
+ " \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002',"
+ " \002,i5,\002, \002,i5,\002, ... ), type \002,i1,\002, test(\002"
+ ",i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, k, n, i1, i2, k1, kd, nb, in, kl, iw, ku, nt, lda, ikd, nkd,
+ ldab;
+ char fact[1];
+ integer ioff, mode, koff;
+ real amax;
+ char path[3];
+ integer imat, info;
+ char dist[1], uplo[1], type__[1];
+ integer nrun, ifact;
+ extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *);
+ integer nfail, iseed[4], nfact;
+ extern /* Subroutine */ int cpbt01_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, real *, real *),
+ cpbt02_(char *, integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, real *,
+ real *), cpbt05_(char *, integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, real *, real *);
+ integer kdval[4];
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ real rcond, roldc, scond;
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ real anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), cpbsv_(char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, integer *);
+ logical equil;
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer iuplo, izero, nerrs;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), aladhd_(integer *, char *);
+ extern doublereal clanhb_(char *, char *, integer *, integer *, complex *,
+ integer *, real *), clange_(char *, integer *,
+ integer *, complex *, integer *, real *);
+ extern /* Subroutine */ int claqhb_(char *, integer *, integer *, complex
+ *, integer *, real *, real *, real *, char *),
+ alaerh_(char *, char *, integer *, integer *, char *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *), claipd_(integer *,
+ complex *, integer *, integer *);
+ logical prefac;
+ real rcondc;
+ logical nofact;
+ char packit[1];
+ integer iequed;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), clarhs_(char *, char
+ *, char *, char *, integer *, integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, integer *, integer *),
+ claset_(char *, integer *, integer *, complex *, complex *,
+ complex *, integer *), cpbequ_(char *, integer *, integer
+ *, complex *, integer *, real *, real *, real *, integer *), alasvm_(char *, integer *, integer *, integer *, integer
+ *);
+ real cndnum;
+ extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, complex *, integer *, complex *, integer *), cpbtrf_(char *, integer *, integer *, complex *,
+ integer *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int cpbtrs_(char *, integer *, integer *, integer
+ *, complex *, integer *, complex *, integer *, integer *),
+ xlaenv_(integer *, integer *), cpbsvx_(char *, char *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ char *, real *, complex *, integer *, complex *, integer *, real
+ *, real *, real *, complex *, real *, integer *), cerrvx_(char *, integer *);
+ real result[6];
+
+ /* Fortran I/O blocks */
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVPB tests the driver routines CPBSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* S (workspace) REAL array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "PB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+ kdval[0] = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+
+/* Set limits on the number of loop iterations. */
+
+/* Computing MAX */
+ i__2 = 1, i__3 = min(n,4);
+ nkd = max(i__2,i__3);
+ nimat = 8;
+ if (n == 0) {
+ nimat = 1;
+ }
+
+ kdval[1] = n + (n + 1) / 4;
+ kdval[2] = (n * 3 - 1) / 4;
+ kdval[3] = (n + 1) / 4;
+
+ i__2 = nkd;
+ for (ikd = 1; ikd <= i__2; ++ikd) {
+
+/* Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order */
+/* makes it easier to skip redundant values for small values */
+/* of N. */
+
+ kd = kdval[ikd - 1];
+ ldab = kd + 1;
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ koff = 1;
+ if (iuplo == 1) {
+ *(unsigned char *)uplo = 'U';
+ *(unsigned char *)packit = 'Q';
+/* Computing MAX */
+ i__3 = 1, i__4 = kd + 2 - n;
+ koff = max(i__3,i__4);
+ } else {
+ *(unsigned char *)uplo = 'L';
+ *(unsigned char *)packit = 'B';
+ }
+
+ i__3 = nimat;
+ for (imat = 1; imat <= i__3; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L80;
+ }
+
+/* Skip types 2, 3, or 4 if the matrix size is too small. */
+
+ zerot = imat >= 2 && imat <= 4;
+ if (zerot && n < imat - 1) {
+ goto L80;
+ }
+
+ if (! zerot || ! dotype[1]) {
+
+/* Set up parameters with CLATB4 and generate a test */
+/* matrix with CLATMS. */
+
+ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm,
+ &mode, &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)
+ 6);
+ clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode,
+ &cndnum, &anorm, &kd, &kd, packit, &a[koff],
+ &ldab, &work[1], &info);
+
+/* Check error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ goto L80;
+ }
+ } else if (izero > 0) {
+
+/* Use the same matrix for types 3 and 4 as for type */
+/* 2 by copying back the zeroed out column, */
+
+ iw = (lda << 1) + 1;
+ if (iuplo == 1) {
+ ioff = (izero - 1) * ldab + kd + 1;
+ i__4 = izero - i1;
+ ccopy_(&i__4, &work[iw], &c__1, &a[ioff - izero +
+ i1], &c__1);
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ ccopy_(&i__4, &work[iw], &c__1, &a[ioff], &i__5);
+ } else {
+ ioff = (i1 - 1) * ldab + 1;
+ i__4 = izero - i1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ ccopy_(&i__4, &work[iw], &c__1, &a[ioff + izero -
+ i1], &i__5);
+ ioff = (izero - 1) * ldab + 1;
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+ ccopy_(&i__4, &work[iw], &c__1, &a[ioff], &c__1);
+ }
+ }
+
+/* For types 2-4, zero one row and column of the matrix */
+/* to test that INFO is returned correctly. */
+
+ izero = 0;
+ if (zerot) {
+ if (imat == 2) {
+ izero = 1;
+ } else if (imat == 3) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+/* Save the zeroed out row and column in WORK(*,3) */
+
+ iw = lda << 1;
+/* Computing MIN */
+ i__5 = (kd << 1) + 1;
+ i__4 = min(i__5,n);
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = iw + i__;
+ work[i__5].r = 0.f, work[i__5].i = 0.f;
+/* L20: */
+ }
+ ++iw;
+/* Computing MAX */
+ i__4 = izero - kd;
+ i1 = max(i__4,1);
+/* Computing MIN */
+ i__4 = izero + kd;
+ i2 = min(i__4,n);
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * ldab + kd + 1;
+ i__4 = izero - i1;
+ cswap_(&i__4, &a[ioff - izero + i1], &c__1, &work[
+ iw], &c__1);
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ cswap_(&i__4, &a[ioff], &i__5, &work[iw], &c__1);
+ } else {
+ ioff = (i1 - 1) * ldab + 1;
+ i__4 = izero - i1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ cswap_(&i__4, &a[ioff + izero - i1], &i__5, &work[
+ iw], &c__1);
+ ioff = (izero - 1) * ldab + 1;
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+ cswap_(&i__4, &a[ioff], &c__1, &work[iw], &c__1);
+ }
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ if (iuplo == 1) {
+ claipd_(&n, &a[kd + 1], &ldab, &c__0);
+ } else {
+ claipd_(&n, &a[1], &ldab, &c__0);
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ i__4 = kd + 1;
+ clacpy_("Full", &i__4, &n, &a[1], &ldab, &asav[1], &ldab);
+
+ for (iequed = 1; iequed <= 2; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__4 = nfact;
+ for (ifact = 1; ifact <= i__4; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L60;
+ }
+ rcondc = 0.f;
+
+ } else if (! lsame_(fact, "N")) {
+
+/* Compute the condition number for comparison */
+/* with the value returned by CPBSVX (FACT = */
+/* 'N' reuses the condition number from the */
+/* previous iteration with FACT = 'F'). */
+
+ i__5 = kd + 1;
+ clacpy_("Full", &i__5, &n, &asav[1], &ldab, &
+ afac[1], &ldab);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ cpbequ_(uplo, &n, &kd, &afac[1], &ldab, &
+ s[1], &scond, &amax, &info);
+ if (info == 0 && n > 0) {
+ if (iequed > 1) {
+ scond = 0.f;
+ }
+
+/* Equilibrate the matrix. */
+
+ claqhb_(uplo, &n, &kd, &afac[1], &
+ ldab, &s[1], &scond, &amax,
+ equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in CGET04. */
+
+ if (equil) {
+ roldc = rcondc;
+ }
+
+/* Compute the 1-norm of A. */
+
+ anorm = clanhb_("1", uplo, &n, &kd, &afac[1],
+ &ldab, &rwork[1]);
+
+/* Factor the matrix A. */
+
+ cpbtrf_(uplo, &n, &kd, &afac[1], &ldab, &info);
+
+/* Form the inverse of A. */
+
+ claset_("Full", &n, &n, &c_b47, &c_b48, &a[1],
+ &lda);
+ s_copy(srnamc_1.srnamt, "CPBTRS", (ftnlen)32,
+ (ftnlen)6);
+ cpbtrs_(uplo, &n, &kd, &n, &afac[1], &ldab, &
+ a[1], &lda, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = clange_("1", &n, &n, &a[1], &lda, &
+ rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondc = 1.f;
+ } else {
+ rcondc = 1.f / anorm / ainvnm;
+ }
+ }
+
+/* Restore the matrix A. */
+
+ i__5 = kd + 1;
+ clacpy_("Full", &i__5, &n, &asav[1], &ldab, &a[1],
+ &ldab);
+
+/* Form an exact solution and set the right hand */
+/* side. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (
+ ftnlen)6);
+ clarhs_(path, xtype, uplo, " ", &n, &n, &kd, &kd,
+ nrhs, &a[1], &ldab, &xact[1], &lda, &b[1],
+ &lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &
+ lda);
+
+ if (nofact) {
+
+/* --- Test CPBSV --- */
+
+/* Compute the L*L' or U'*U factorization of the */
+/* matrix and solve the system. */
+
+ i__5 = kd + 1;
+ clacpy_("Full", &i__5, &n, &a[1], &ldab, &
+ afac[1], &ldab);
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1],
+ &lda);
+
+ s_copy(srnamc_1.srnamt, "CPBSV ", (ftnlen)32,
+ (ftnlen)6);
+ cpbsv_(uplo, &n, &kd, nrhs, &afac[1], &ldab, &
+ x[1], &lda, &info);
+
+/* Check error code from CPBSV . */
+
+ if (info != izero) {
+ alaerh_(path, "CPBSV ", &info, &izero,
+ uplo, &n, &n, &kd, &kd, nrhs, &
+ imat, &nfail, &nerrs, nout);
+ goto L40;
+ } else if (info != 0) {
+ goto L40;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ cpbt01_(uplo, &n, &kd, &a[1], &ldab, &afac[1],
+ &ldab, &rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &work[
+ 1], &lda);
+ cpbt02_(uplo, &n, &kd, nrhs, &a[1], &ldab, &x[
+ 1], &lda, &work[1], &lda, &rwork[1], &
+ result[1]);
+
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ i__5 = nt;
+ for (k = 1; k <= i__5; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___57.ciunit = *nout;
+ s_wsfe(&io___57);
+ do_fio(&c__1, "CPBSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L30: */
+ }
+ nrun += nt;
+L40:
+ ;
+ }
+
+/* --- Test CPBSVX --- */
+
+ if (! prefac) {
+ i__5 = kd + 1;
+ claset_("Full", &i__5, &n, &c_b47, &c_b47, &
+ afac[1], &ldab);
+ }
+ claset_("Full", &n, nrhs, &c_b47, &c_b47, &x[1], &
+ lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT='F' and */
+/* EQUED='Y' */
+
+ claqhb_(uplo, &n, &kd, &a[1], &ldab, &s[1], &
+ scond, &amax, equed);
+ }
+
+/* Solve the system and compute the condition */
+/* number and error bounds using CPBSVX. */
+
+ s_copy(srnamc_1.srnamt, "CPBSVX", (ftnlen)32, (
+ ftnlen)6);
+ cpbsvx_(fact, uplo, &n, &kd, nrhs, &a[1], &ldab, &
+ afac[1], &ldab, equed, &s[1], &b[1], &lda,
+ &x[1], &lda, &rcond, &rwork[1], &rwork[*
+ nrhs + 1], &work[1], &rwork[(*nrhs << 1)
+ + 1], &info);
+
+/* Check the error code from CPBSVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__7[0] = 1, a__1[0] = fact;
+ i__7[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__7, &c__2, (ftnlen)2);
+ alaerh_(path, "CPBSVX", &info, &izero, ch__1,
+ &n, &n, &kd, &kd, nrhs, &imat, &nfail,
+ &nerrs, nout);
+ goto L60;
+ }
+
+ if (info == 0) {
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and */
+/* compute residual. */
+
+ cpbt01_(uplo, &n, &kd, &a[1], &ldab, &
+ afac[1], &ldab, &rwork[(*nrhs <<
+ 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &bsav[1], &lda, &
+ work[1], &lda);
+ cpbt02_(uplo, &n, &kd, nrhs, &asav[1], &ldab,
+ &x[1], &lda, &work[1], &lda, &rwork[(*
+ nrhs << 1) + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &
+ lda, &rcondc, &result[2]);
+ } else {
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &
+ lda, &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ cpbt05_(uplo, &n, &kd, nrhs, &asav[1], &ldab,
+ &b[1], &lda, &x[1], &lda, &xact[1], &
+ lda, &rwork[1], &rwork[*nrhs + 1], &
+ result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from CPBSVX with the computed */
+/* value in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___60.ciunit = *nout;
+ s_wsfe(&io___60);
+ do_fio(&c__1, "CPBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___61.ciunit = *nout;
+ s_wsfe(&io___61);
+ do_fio(&c__1, "CPBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L50: */
+ }
+ nrun = nrun + 7 - k1;
+L60:
+ ;
+ }
+/* L70: */
+ }
+L80:
+ ;
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CDRVPB */
+
+} /* cdrvpb_ */
diff --git a/TESTING/LIN/cdrvpo.c b/TESTING/LIN/cdrvpo.c
new file mode 100644
index 0000000..f7aa1a9
--- /dev/null
+++ b/TESTING/LIN/cdrvpo.c
@@ -0,0 +1,718 @@
+/* cdrvpo.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static complex c_b51 = {0.f,0.f};
+
+/* Subroutine */ int cdrvpo_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, integer *nmax, complex *
+ a, complex *afac, complex *asav, complex *b, complex *bsav, complex *
+ x, complex *xact, real *s, complex *work, real *rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*2] = "N" "Y";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,"
+ "\002, test(\002,i1,\002) =\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, k, n, k1, nb, in, kl, ku, nt, lda;
+ char fact[1];
+ integer ioff, mode;
+ real amax;
+ char path[3];
+ integer imat, info;
+ char dist[1], uplo[1], type__[1];
+ integer nrun, ifact;
+ extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *);
+ integer nfail, iseed[4], nfact;
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ real rcond, roldc, scond;
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int cpot01_(char *, integer *, complex *, integer
+ *, complex *, integer *, real *, real *), cpot02_(char *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, real *);
+ real anorm;
+ extern /* Subroutine */ int cpot05_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, complex *, integer *, complex
+ *, integer *, real *, real *, real *);
+ logical equil;
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int cposv_(char *, integer *, integer *, complex *
+, integer *, complex *, integer *, integer *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), aladhd_(integer *, char *);
+ extern doublereal clanhe_(char *, char *, integer *, complex *, integer *,
+ real *);
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *), claipd_(integer *, complex *, integer *, integer *),
+ claqhe_(char *, integer *, complex *, integer *, real *, real *,
+ real *, char *);
+ logical prefac;
+ real rcondc;
+ logical nofact;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *);
+ integer iequed;
+ extern /* Subroutine */ int clarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, integer *,
+ integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), alasvm_(char *, integer *, integer *, integer *, integer
+ *);
+ real cndnum;
+ extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, complex *, integer *, complex *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int cpoequ_(integer *, complex *, integer *, real
+ *, real *, real *, integer *), cpotrf_(char *, integer *, complex
+ *, integer *, integer *), cpotri_(char *, integer *,
+ complex *, integer *, integer *), xlaenv_(integer *,
+ integer *), cerrvx_(char *, integer *);
+ real result[6];
+ extern /* Subroutine */ int cposvx_(char *, char *, integer *, integer *,
+ complex *, integer *, complex *, integer *, char *, real *,
+ complex *, integer *, complex *, integer *, real *, real *, real *
+, complex *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVPO tests the driver routines CPOSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* S (workspace) REAL array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "PO", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot && n < imat - 2) {
+ goto L120;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Set up parameters with CLATB4 and generate a test matrix */
+/* with CLATMS. */
+
+ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
+ &info);
+
+/* Check error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L110;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ i__3 = lda + 1;
+ claipd_(&n, &a[1], &i__3, &c__0);
+
+/* Save a copy of the matrix A in ASAV. */
+
+ clacpy_(uplo, &n, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 2; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__3 = nfact;
+ for (ifact = 1; ifact <= i__3; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L90;
+ }
+ rcondc = 0.f;
+
+ } else if (! lsame_(fact, "N"))
+ {
+
+/* Compute the condition number for comparison with */
+/* the value returned by CPOSVX (FACT = 'N' reuses */
+/* the condition number from the previous iteration */
+/* with FACT = 'F'). */
+
+ clacpy_(uplo, &n, &n, &asav[1], &lda, &afac[1], &
+ lda);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ cpoequ_(&n, &afac[1], &lda, &s[1], &scond, &
+ amax, &info);
+ if (info == 0 && n > 0) {
+ if (iequed > 1) {
+ scond = 0.f;
+ }
+
+/* Equilibrate the matrix. */
+
+ claqhe_(uplo, &n, &afac[1], &lda, &s[1], &
+ scond, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in CGET04. */
+
+ if (equil) {
+ roldc = rcondc;
+ }
+
+/* Compute the 1-norm of A. */
+
+ anorm = clanhe_("1", uplo, &n, &afac[1], &lda, &
+ rwork[1]);
+
+/* Factor the matrix A. */
+
+ cpotrf_(uplo, &n, &afac[1], &lda, &info);
+
+/* Form the inverse of A. */
+
+ clacpy_(uplo, &n, &n, &afac[1], &lda, &a[1], &lda);
+ cpotri_(uplo, &n, &a[1], &lda, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = clanhe_("1", uplo, &n, &a[1], &lda, &
+ rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondc = 1.f;
+ } else {
+ rcondc = 1.f / anorm / ainvnm;
+ }
+ }
+
+/* Restore the matrix A. */
+
+ clacpy_(uplo, &n, &n, &asav[1], &lda, &a[1], &lda);
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ clarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku,
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
+
+ if (nofact) {
+
+/* --- Test CPOSV --- */
+
+/* Compute the L*L' or U'*U factorization of the */
+/* matrix and solve the system. */
+
+ clacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "CPOSV ", (ftnlen)32, (
+ ftnlen)6);
+ cposv_(uplo, &n, nrhs, &afac[1], &lda, &x[1], &
+ lda, &info);
+
+/* Check error code from CPOSV . */
+
+ if (info != izero) {
+ alaerh_(path, "CPOSV ", &info, &izero, uplo, &
+ n, &n, &c_n1, &c_n1, nrhs, &imat, &
+ nfail, &nerrs, nout);
+ goto L70;
+ } else if (info != 0) {
+ goto L70;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ cpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
+ rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
+ lda);
+ cpot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda,
+ &work[1], &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___48.ciunit = *nout;
+ s_wsfe(&io___48);
+ do_fio(&c__1, "CPOSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += nt;
+L70:
+ ;
+ }
+
+/* --- Test CPOSVX --- */
+
+ if (! prefac) {
+ claset_(uplo, &n, &n, &c_b51, &c_b51, &afac[1], &
+ lda);
+ }
+ claset_("Full", &n, nrhs, &c_b51, &c_b51, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT='F' and */
+/* EQUED='Y'. */
+
+ claqhe_(uplo, &n, &a[1], &lda, &s[1], &scond, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using CPOSVX. */
+
+ s_copy(srnamc_1.srnamt, "CPOSVX", (ftnlen)32, (ftnlen)
+ 6);
+ cposvx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1], &
+ lda, equed, &s[1], &b[1], &lda, &x[1], &lda, &
+ rcond, &rwork[1], &rwork[*nrhs + 1], &work[1],
+ &rwork[(*nrhs << 1) + 1], &info);
+
+/* Check the error code from CPOSVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "CPOSVX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L90;
+ }
+
+ if (info == 0) {
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ cpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda,
+ &rwork[(*nrhs << 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ cpot02_(uplo, &n, nrhs, &asav[1], &lda, &x[1], &
+ lda, &work[1], &lda, &rwork[(*nrhs << 1)
+ + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ cpot05_(uplo, &n, nrhs, &asav[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &rwork[*nrhs + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from CPOSVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___51.ciunit = *nout;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "CPOSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___52.ciunit = *nout;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "CPOSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + 7 - k1;
+L90:
+ ;
+ }
+/* L100: */
+ }
+L110:
+ ;
+ }
+L120:
+ ;
+ }
+/* L130: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CDRVPO */
+
+} /* cdrvpo_ */
diff --git a/TESTING/LIN/cdrvpox.c b/TESTING/LIN/cdrvpox.c
new file mode 100644
index 0000000..43ba4f9
--- /dev/null
+++ b/TESTING/LIN/cdrvpox.c
@@ -0,0 +1,883 @@
+/* cdrvpox.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "memory_alloc.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static complex c_b51 = {0.f,0.f};
+static real c_b94 = 0.f;
+
+/* Subroutine */ int cdrvpo_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, integer *nmax, complex *
+ a, complex *afac, complex *asav, complex *b, complex *bsav, complex *
+ x, complex *xact, real *s, complex *work, real *rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*2] = "N" "Y";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,"
+ "\002, test(\002,i1,\002) =\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ extern /* Subroutine */ int cebchvxx_(real *, char *);
+ integer i__, k, n;
+ real *errbnds_c__, *errbnds_n__;
+ integer k1, nb, in, kl, ku, nt, n_err_bnds__, lda;
+ char fact[1];
+ integer ioff, mode;
+ real amax;
+ char path[3];
+ integer imat, info;
+ real *berr;
+ char dist[1];
+ real rpvgrw_svxx__;
+ char uplo[1], type__[1];
+ integer nrun, ifact;
+ extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *);
+ integer nfail, iseed[4], nfact;
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ real rcond, roldc, scond;
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int cpot01_(char *, integer *, complex *, integer
+ *, complex *, integer *, real *, real *), cpot02_(char *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, real *);
+ real anorm;
+ extern /* Subroutine */ int cpot05_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, complex *, integer *, complex
+ *, integer *, real *, real *, real *);
+ logical equil;
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int cposv_(char *, integer *, integer *, complex *
+, integer *, complex *, integer *, integer *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), aladhd_(integer *, char *);
+ extern doublereal clanhe_(char *, char *, integer *, complex *, integer *,
+ real *);
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *), claipd_(integer *, complex *, integer *, integer *),
+ claqhe_(char *, integer *, complex *, integer *, real *, real *,
+ real *, char *);
+ logical prefac;
+ real rcondc;
+ logical nofact;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *);
+ integer iequed;
+ extern /* Subroutine */ int clarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, integer *,
+ integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), alasvm_(char *, integer *, integer *, integer *, integer
+ *);
+ real cndnum;
+ extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, complex *, integer *, complex *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int cpoequ_(integer *, complex *, integer *, real
+ *, real *, real *, integer *), cpotrf_(char *, integer *, complex
+ *, integer *, integer *), cpotri_(char *, integer *,
+ complex *, integer *, integer *), xlaenv_(integer *,
+ integer *), cerrvx_(char *, integer *);
+ real result[6];
+ extern /* Subroutine */ int cposvx_(char *, char *, integer *, integer *,
+ complex *, integer *, complex *, integer *, char *, real *,
+ complex *, integer *, complex *, integer *, real *, real *, real *
+, complex *, real *, integer *), cposvxx_(
+ char *, char *, integer *, integer *, complex *, integer *,
+ complex *, integer *, char *, real *, complex *, integer *,
+ complex *, integer *, real *, real *, real *, integer *, real *,
+ real *, integer *, real *, complex *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVPO tests the driver routines CPOSV, -SVX, and -SVXX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* S (workspace) REAL array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "PO", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot && n < imat - 2) {
+ goto L120;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Set up parameters with CLATB4 and generate a test matrix */
+/* with CLATMS. */
+
+ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
+ &info);
+
+/* Check error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L110;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ i__3 = lda + 1;
+ claipd_(&n, &a[1], &i__3, &c__0);
+
+/* Save a copy of the matrix A in ASAV. */
+
+ clacpy_(uplo, &n, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 2; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__3 = nfact;
+ for (ifact = 1; ifact <= i__3; ++ifact) {
+ for (i__ = 1; i__ <= 6; ++i__) {
+ result[i__ - 1] = 0.f;
+ }
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L90;
+ }
+ rcondc = 0.f;
+
+ } else if (! lsame_(fact, "N"))
+ {
+
+/* Compute the condition number for comparison with */
+/* the value returned by CPOSVX (FACT = 'N' reuses */
+/* the condition number from the previous iteration */
+/* with FACT = 'F'). */
+
+ clacpy_(uplo, &n, &n, &asav[1], &lda, &afac[1], &
+ lda);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ cpoequ_(&n, &afac[1], &lda, &s[1], &scond, &
+ amax, &info);
+ if (info == 0 && n > 0) {
+ if (iequed > 1) {
+ scond = 0.f;
+ }
+
+/* Equilibrate the matrix. */
+
+ claqhe_(uplo, &n, &afac[1], &lda, &s[1], &
+ scond, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in CGET04. */
+
+ if (equil) {
+ roldc = rcondc;
+ }
+
+/* Compute the 1-norm of A. */
+
+ anorm = clanhe_("1", uplo, &n, &afac[1], &lda, &
+ rwork[1]);
+
+/* Factor the matrix A. */
+
+ cpotrf_(uplo, &n, &afac[1], &lda, &info);
+
+/* Form the inverse of A. */
+
+ clacpy_(uplo, &n, &n, &afac[1], &lda, &a[1], &lda);
+ cpotri_(uplo, &n, &a[1], &lda, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = clanhe_("1", uplo, &n, &a[1], &lda, &
+ rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondc = 1.f;
+ } else {
+ rcondc = 1.f / anorm / ainvnm;
+ }
+ }
+
+/* Restore the matrix A. */
+
+ clacpy_(uplo, &n, &n, &asav[1], &lda, &a[1], &lda);
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ clarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku,
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
+
+ if (nofact) {
+
+/* --- Test CPOSV --- */
+
+/* Compute the L*L' or U'*U factorization of the */
+/* matrix and solve the system. */
+
+ clacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "CPOSV ", (ftnlen)32, (
+ ftnlen)6);
+ cposv_(uplo, &n, nrhs, &afac[1], &lda, &x[1], &
+ lda, &info);
+
+/* Check error code from CPOSV . */
+
+ if (info != izero) {
+ alaerh_(path, "CPOSV ", &info, &izero, uplo, &
+ n, &n, &c_n1, &c_n1, nrhs, &imat, &
+ nfail, &nerrs, nout);
+ goto L70;
+ } else if (info != 0) {
+ goto L70;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ cpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
+ rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
+ lda);
+ cpot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda,
+ &work[1], &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___48.ciunit = *nout;
+ s_wsfe(&io___48);
+ do_fio(&c__1, "CPOSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += nt;
+L70:
+ ;
+ }
+
+/* --- Test CPOSVX --- */
+
+ if (! prefac) {
+ claset_(uplo, &n, &n, &c_b51, &c_b51, &afac[1], &
+ lda);
+ }
+ claset_("Full", &n, nrhs, &c_b51, &c_b51, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT='F' and */
+/* EQUED='Y'. */
+
+ claqhe_(uplo, &n, &a[1], &lda, &s[1], &scond, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using CPOSVX. */
+
+ s_copy(srnamc_1.srnamt, "CPOSVX", (ftnlen)32, (ftnlen)
+ 6);
+ cposvx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1], &
+ lda, equed, &s[1], &b[1], &lda, &x[1], &lda, &
+ rcond, &rwork[1], &rwork[*nrhs + 1], &work[1],
+ &rwork[(*nrhs << 1) + 1], &info);
+
+/* Check the error code from CPOSVX. */
+
+ if (info == n + 1) {
+ goto L90;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "CPOSVX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L90;
+ }
+
+ if (info == 0) {
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ cpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda,
+ &rwork[(*nrhs << 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ cpot02_(uplo, &n, nrhs, &asav[1], &lda, &x[1], &
+ lda, &work[1], &lda, &rwork[(*nrhs << 1)
+ + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ cpot05_(uplo, &n, nrhs, &asav[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &rwork[*nrhs + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from CPOSVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___51.ciunit = *nout;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "CPOSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___52.ciunit = *nout;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "CPOSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + 7 - k1;
+
+/* --- Test CPOSVXX --- */
+
+/* Restore the matrices A and B. */
+
+ clacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
+ clacpy_("Full", &n, nrhs, &bsav[1], &lda, &b[1], &lda);
+ if (! prefac) {
+ claset_(uplo, &n, &n, &c_b51, &c_b51, &afac[1], &
+ lda);
+ }
+ claset_("Full", &n, nrhs, &c_b51, &c_b51, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT='F' and */
+/* EQUED='Y'. */
+
+ claqhe_(uplo, &n, &a[1], &lda, &s[1], &scond, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using CPOSVXX. */
+
+ s_copy(srnamc_1.srnamt, "CPOSVXX", (ftnlen)32, (
+ ftnlen)7);
+
+ salloc3();
+
+ cposvxx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1],
+ &lda, equed, &s[1], &b[1], &lda, &x[1], &lda,
+ &rcond, &rpvgrw_svxx__, berr, &n_err_bnds__,
+ errbnds_n__, errbnds_c__, &c__0, &c_b94, &
+ work[1], &rwork[(*nrhs << 1) + 1], &info);
+
+ free3();
+
+/* Check the error code from CPOSVXX. */
+
+ if (info == n + 1) {
+ goto L90;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "CPOSVXX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L90;
+ }
+
+ if (info == 0) {
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ cpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda,
+ &rwork[(*nrhs << 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ cpot02_(uplo, &n, nrhs, &asav[1], &lda, &x[1], &
+ lda, &work[1], &lda, &rwork[(*nrhs << 1)
+ + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ cpot05_(uplo, &n, nrhs, &asav[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &rwork[*nrhs + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from CPOSVXX with the computed value */
+/* in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___58.ciunit = *nout;
+ s_wsfe(&io___58);
+ do_fio(&c__1, "CPOSVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___59.ciunit = *nout;
+ s_wsfe(&io___59);
+ do_fio(&c__1, "CPOSVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L85: */
+ }
+ nrun = nrun + 7 - k1;
+L90:
+ ;
+ }
+/* L100: */
+ }
+L110:
+ ;
+ }
+L120:
+ ;
+ }
+/* L130: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+/* Test Error Bounds for CGESVXX */
+ cebchvxx_(thresh, path);
+ return 0;
+
+/* End of CDRVPO */
+
+} /* cdrvpo_ */
diff --git a/TESTING/LIN/cdrvpp.c b/TESTING/LIN/cdrvpp.c
new file mode 100644
index 0000000..7074062
--- /dev/null
+++ b/TESTING/LIN/cdrvpp.c
@@ -0,0 +1,718 @@
+/* cdrvpp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static complex c_b63 = {0.f,0.f};
+
+/* Subroutine */ int cdrvpp_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, integer *nmax, complex *
+ a, complex *afac, complex *asav, complex *b, complex *bsav, complex *
+ x, complex *xact, real *s, complex *work, real *rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char facts[1*3] = "F" "N" "E";
+ static char packs[1*2] = "C" "R";
+ static char equeds[1*2] = "N" "Y";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,"
+ "\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, k, n, k1, in, kl, ku, nt, lda, npp;
+ char fact[1];
+ integer ioff, mode;
+ real amax;
+ char path[3];
+ integer imat, info;
+ char dist[1], uplo[1], type__[1];
+ integer nrun, ifact;
+ extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *);
+ integer nfail, iseed[4], nfact;
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ real roldc, rcond, scond;
+ extern /* Subroutine */ int cppt01_(char *, integer *, complex *, complex
+ *, real *, real *);
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int cppt02_(char *, integer *, integer *, complex
+ *, complex *, integer *, complex *, integer *, real *, real *), cppt05_(char *, integer *, integer *, complex *, complex
+ *, integer *, complex *, integer *, complex *, integer *, real *,
+ real *, real *);
+ real anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ logical equil;
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int cppsv_(char *, integer *, integer *, complex *
+, complex *, integer *, integer *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), aladhd_(integer *, char *),
+ alaerh_(char *, char *, integer *, integer *, char *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *), claipd_(integer *,
+ complex *, integer *, integer *);
+ logical prefac;
+ extern doublereal clanhp_(char *, char *, integer *, complex *, real *);
+ real rcondc;
+ extern /* Subroutine */ int claqhp_(char *, integer *, complex *, real *,
+ real *, real *, char *);
+ logical nofact;
+ char packit[1];
+ integer iequed;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), clarhs_(char *, char
+ *, char *, char *, integer *, integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, integer *, integer *),
+ claset_(char *, integer *, integer *, complex *, complex *,
+ complex *, integer *), alasvm_(char *, integer *, integer
+ *, integer *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, complex *, integer *, complex *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int cppequ_(char *, integer *, complex *, real *,
+ real *, real *, integer *), cpptrf_(char *, integer *,
+ complex *, integer *), cpptri_(char *, integer *, complex
+ *, integer *), cerrvx_(char *, integer *);
+ real result[6];
+ extern /* Subroutine */ int cppsvx_(char *, char *, integer *, integer *,
+ complex *, complex *, char *, real *, complex *, integer *,
+ complex *, integer *, real *, real *, real *, complex *, real *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVPP tests the driver routines CPPSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*(NMAX+1)/2) */
+
+/* AFAC (workspace) COMPLEX array, dimension (NMAX*(NMAX+1)/2) */
+
+/* ASAV (workspace) COMPLEX array, dimension (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* S (workspace) REAL array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "PP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ npp = n * (n + 1) / 2;
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L130;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot && n < imat - 2) {
+ goto L130;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ *(unsigned char *)packit = *(unsigned char *)&packs[iuplo - 1]
+ ;
+
+/* Set up parameters with CLATB4 and generate a test matrix */
+/* with CLATMS. */
+
+ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+ rcondc = 1.f / cndnum;
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
+ 1], &info);
+
+/* Check error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L120;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * izero / 2;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff += i__;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff = ioff + n - i__;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ if (iuplo == 1) {
+ claipd_(&n, &a[1], &c__2, &c__1);
+ } else {
+ claipd_(&n, &a[1], &n, &c_n1);
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ ccopy_(&npp, &a[1], &c__1, &asav[1], &c__1);
+
+ for (iequed = 1; iequed <= 2; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__3 = nfact;
+ for (ifact = 1; ifact <= i__3; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L100;
+ }
+ rcondc = 0.f;
+
+ } else if (! lsame_(fact, "N"))
+ {
+
+/* Compute the condition number for comparison with */
+/* the value returned by CPPSVX (FACT = 'N' reuses */
+/* the condition number from the previous iteration */
+/* with FACT = 'F'). */
+
+ ccopy_(&npp, &asav[1], &c__1, &afac[1], &c__1);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ cppequ_(uplo, &n, &afac[1], &s[1], &scond, &
+ amax, &info);
+ if (info == 0 && n > 0) {
+ if (iequed > 1) {
+ scond = 0.f;
+ }
+
+/* Equilibrate the matrix. */
+
+ claqhp_(uplo, &n, &afac[1], &s[1], &scond,
+ &amax, equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in CGET04. */
+
+ if (equil) {
+ roldc = rcondc;
+ }
+
+/* Compute the 1-norm of A. */
+
+ anorm = clanhp_("1", uplo, &n, &afac[1], &rwork[1]
+);
+
+/* Factor the matrix A. */
+
+ cpptrf_(uplo, &n, &afac[1], &info);
+
+/* Form the inverse of A. */
+
+ ccopy_(&npp, &afac[1], &c__1, &a[1], &c__1);
+ cpptri_(uplo, &n, &a[1], &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = clanhp_("1", uplo, &n, &a[1], &rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondc = 1.f;
+ } else {
+ rcondc = 1.f / anorm / ainvnm;
+ }
+ }
+
+/* Restore the matrix A. */
+
+ ccopy_(&npp, &asav[1], &c__1, &a[1], &c__1);
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ clarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku,
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
+
+ if (nofact) {
+
+/* --- Test CPPSV --- */
+
+/* Compute the L*L' or U'*U factorization of the */
+/* matrix and solve the system. */
+
+ ccopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "CPPSV ", (ftnlen)32, (
+ ftnlen)6);
+ cppsv_(uplo, &n, nrhs, &afac[1], &x[1], &lda, &
+ info);
+
+/* Check error code from CPPSV . */
+
+ if (info != izero) {
+ alaerh_(path, "CPPSV ", &info, &izero, uplo, &
+ n, &n, &c_n1, &c_n1, nrhs, &imat, &
+ nfail, &nerrs, nout);
+ goto L70;
+ } else if (info != 0) {
+ goto L70;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ cppt01_(uplo, &n, &a[1], &afac[1], &rwork[1],
+ result);
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
+ lda);
+ cppt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[
+ 1], &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___49.ciunit = *nout;
+ s_wsfe(&io___49);
+ do_fio(&c__1, "CPPSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += nt;
+L70:
+ ;
+ }
+
+/* --- Test CPPSVX --- */
+
+ if (! prefac && npp > 0) {
+ claset_("Full", &npp, &c__1, &c_b63, &c_b63, &
+ afac[1], &npp);
+ }
+ claset_("Full", &n, nrhs, &c_b63, &c_b63, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT='F' and */
+/* EQUED='Y'. */
+
+ claqhp_(uplo, &n, &a[1], &s[1], &scond, &amax,
+ equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using CPPSVX. */
+
+ s_copy(srnamc_1.srnamt, "CPPSVX", (ftnlen)32, (ftnlen)
+ 6);
+ cppsvx_(fact, uplo, &n, nrhs, &a[1], &afac[1], equed,
+ &s[1], &b[1], &lda, &x[1], &lda, &rcond, &
+ rwork[1], &rwork[*nrhs + 1], &work[1], &rwork[
+ (*nrhs << 1) + 1], &info);
+
+/* Check the error code from CPPSVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "CPPSVX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L90;
+ }
+
+ if (info == 0) {
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ cppt01_(uplo, &n, &a[1], &afac[1], &rwork[(*
+ nrhs << 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ cppt02_(uplo, &n, nrhs, &asav[1], &x[1], &lda, &
+ work[1], &lda, &rwork[(*nrhs << 1) + 1], &
+ result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ cppt05_(uplo, &n, nrhs, &asav[1], &b[1], &lda, &x[
+ 1], &lda, &xact[1], &lda, &rwork[1], &
+ rwork[*nrhs + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from CPPSVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___52.ciunit = *nout;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "CPPSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___53.ciunit = *nout;
+ s_wsfe(&io___53);
+ do_fio(&c__1, "CPPSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + 7 - k1;
+L90:
+L100:
+ ;
+ }
+/* L110: */
+ }
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CDRVPP */
+
+} /* cdrvpp_ */
diff --git a/TESTING/LIN/cdrvpt.c b/TESTING/LIN/cdrvpt.c
new file mode 100644
index 0000000..47577f2
--- /dev/null
+++ b/TESTING/LIN/cdrvpt.c
@@ -0,0 +1,676 @@
+/* cdrvpt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static real c_b24 = 1.f;
+static real c_b25 = 0.f;
+static complex c_b62 = {0.f,0.f};
+
+/* Subroutine */ int cdrvpt_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, complex *a, real *d__,
+ complex *e, complex *b, complex *x, complex *xact, complex *work,
+ real *rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 0,0,0,1 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
+ ", test \002,i2,\002, ratio = \002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i2,\002, test \002,i2,\002, ratio = \002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double c_abs(complex *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n;
+ real z__[3];
+ integer k1, ia, in, kl, ku, ix, nt, lda;
+ char fact[1];
+ real cond;
+ integer mode;
+ real dmax__;
+ integer imat, info;
+ char path[3], dist[1], type__[1];
+ integer nrun, ifact;
+ extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *);
+ integer nfail, iseed[4];
+ real rcond;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int cptt01_(integer *, real *, complex *, real *,
+ complex *, complex *, real *);
+ real anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), cptt02_(char *, integer *, integer *, real
+ *, complex *, complex *, integer *, complex *, integer *, real *), cptt05_(integer *, integer *, real *, complex *, complex
+ *, integer *, complex *, integer *, complex *, integer *, real *,
+ real *, real *);
+ integer izero, nerrs;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), cptsv_(integer *, integer *, real *, complex *,
+ complex *, integer *, integer *);
+ logical zerot;
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), aladhd_(integer *, char *),
+ alaerh_(char *, char *, integer *, integer *, char *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *);
+ real rcondc;
+ extern doublereal clanht_(char *, integer *, real *, complex *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), clacpy_(char *, integer *, integer *, complex *, integer *,
+ complex *, integer *), claset_(char *, integer *, integer
+ *, complex *, complex *, complex *, integer *), claptm_(
+ char *, integer *, integer *, real *, real *, complex *, complex *
+, integer *, real *, complex *, integer *);
+ extern integer isamax_(integer *, real *, integer *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *), clarnv_(integer *, integer *, integer *,
+ complex *), clatms_(integer *, integer *, char *, integer *, char
+ *, real *, integer *, real *, real *, integer *, integer *, char *
+, complex *, integer *, complex *, integer *);
+ real ainvnm;
+ extern doublereal scasum_(integer *, complex *, integer *);
+ extern /* Subroutine */ int cpttrf_(integer *, real *, complex *, integer
+ *), slarnv_(integer *, integer *, integer *, real *), cerrvx_(
+ char *, integer *);
+ real result[6];
+ extern /* Subroutine */ int cpttrs_(char *, integer *, integer *, real *,
+ complex *, complex *, integer *, integer *), cptsvx_(char
+ *, integer *, integer *, real *, complex *, real *, complex *,
+ complex *, integer *, complex *, integer *, real *, real *, real *
+, complex *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVPT tests CPTSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*2) */
+
+/* D (workspace) REAL array, dimension (NMAX*2) */
+
+/* E (workspace) COMPLEX array, dimension (NMAX*2) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --e;
+ --d__;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "PT", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+ lda = max(1,n);
+ nimat = 12;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (n > 0 && ! dotype[imat]) {
+ goto L110;
+ }
+
+/* Set up parameters with CLATB4. */
+
+ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cond, dist);
+
+ zerot = imat >= 8 && imat <= 10;
+ if (imat <= 6) {
+
+/* Type 1-6: generate a symmetric tridiagonal matrix of */
+/* known condition number in lower triangular band storage. */
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
+ &anorm, &kl, &ku, "B", &a[1], &c__2, &work[1], &info);
+
+/* Check the error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, " ", &n, &n, &kl, &
+ ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L110;
+ }
+ izero = 0;
+
+/* Copy the matrix to D and E. */
+
+ ia = 1;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = ia;
+ d__[i__4] = a[i__5].r;
+ i__4 = i__;
+ i__5 = ia + 1;
+ e[i__4].r = a[i__5].r, e[i__4].i = a[i__5].i;
+ ia += 2;
+/* L20: */
+ }
+ if (n > 0) {
+ i__3 = n;
+ i__4 = ia;
+ d__[i__3] = a[i__4].r;
+ }
+ } else {
+
+/* Type 7-12: generate a diagonally dominant matrix with */
+/* unknown condition number in the vectors D and E. */
+
+ if (! zerot || ! dotype[7]) {
+
+/* Let D and E have values from [-1,1]. */
+
+ slarnv_(&c__2, iseed, &n, &d__[1]);
+ i__3 = n - 1;
+ clarnv_(&c__2, iseed, &i__3, &e[1]);
+
+/* Make the tridiagonal matrix diagonally dominant. */
+
+ if (n == 1) {
+ d__[1] = dabs(d__[1]);
+ } else {
+ d__[1] = dabs(d__[1]) + c_abs(&e[1]);
+ d__[n] = (r__1 = d__[n], dabs(r__1)) + c_abs(&e[n - 1]
+ );
+ i__3 = n - 1;
+ for (i__ = 2; i__ <= i__3; ++i__) {
+ d__[i__] = (r__1 = d__[i__], dabs(r__1)) + c_abs(&
+ e[i__]) + c_abs(&e[i__ - 1]);
+/* L30: */
+ }
+ }
+
+/* Scale D and E so the maximum element is ANORM. */
+
+ ix = isamax_(&n, &d__[1], &c__1);
+ dmax__ = d__[ix];
+ r__1 = anorm / dmax__;
+ sscal_(&n, &r__1, &d__[1], &c__1);
+ if (n > 1) {
+ i__3 = n - 1;
+ r__1 = anorm / dmax__;
+ csscal_(&i__3, &r__1, &e[1], &c__1);
+ }
+
+ } else if (izero > 0) {
+
+/* Reuse the last matrix by copying back the zeroed out */
+/* elements. */
+
+ if (izero == 1) {
+ d__[1] = z__[1];
+ if (n > 1) {
+ e[1].r = z__[2], e[1].i = 0.f;
+ }
+ } else if (izero == n) {
+ i__3 = n - 1;
+ e[i__3].r = z__[0], e[i__3].i = 0.f;
+ d__[n] = z__[1];
+ } else {
+ i__3 = izero - 1;
+ e[i__3].r = z__[0], e[i__3].i = 0.f;
+ d__[izero] = z__[1];
+ i__3 = izero;
+ e[i__3].r = z__[2], e[i__3].i = 0.f;
+ }
+ }
+
+/* For types 8-10, set one row and column of the matrix to */
+/* zero. */
+
+ izero = 0;
+ if (imat == 8) {
+ izero = 1;
+ z__[1] = d__[1];
+ d__[1] = 0.f;
+ if (n > 1) {
+ z__[2] = e[1].r;
+ e[1].r = 0.f, e[1].i = 0.f;
+ }
+ } else if (imat == 9) {
+ izero = n;
+ if (n > 1) {
+ i__3 = n - 1;
+ z__[0] = e[i__3].r;
+ i__3 = n - 1;
+ e[i__3].r = 0.f, e[i__3].i = 0.f;
+ }
+ z__[1] = d__[n];
+ d__[n] = 0.f;
+ } else if (imat == 10) {
+ izero = (n + 1) / 2;
+ if (izero > 1) {
+ i__3 = izero - 1;
+ z__[0] = e[i__3].r;
+ i__3 = izero - 1;
+ e[i__3].r = 0.f, e[i__3].i = 0.f;
+ i__3 = izero;
+ z__[2] = e[i__3].r;
+ i__3 = izero;
+ e[i__3].r = 0.f, e[i__3].i = 0.f;
+ }
+ z__[1] = d__[izero];
+ d__[izero] = 0.f;
+ }
+ }
+
+/* Generate NRHS random solution vectors. */
+
+ ix = 1;
+ i__3 = *nrhs;
+ for (j = 1; j <= i__3; ++j) {
+ clarnv_(&c__2, iseed, &n, &xact[ix]);
+ ix += lda;
+/* L40: */
+ }
+
+/* Set the right hand side. */
+
+ claptm_("Lower", &n, nrhs, &c_b24, &d__[1], &e[1], &xact[1], &lda,
+ &c_b25, &b[1], &lda);
+
+ for (ifact = 1; ifact <= 2; ++ifact) {
+ if (ifact == 1) {
+ *(unsigned char *)fact = 'F';
+ } else {
+ *(unsigned char *)fact = 'N';
+ }
+
+/* Compute the condition number for comparison with */
+/* the value returned by CPTSVX. */
+
+ if (zerot) {
+ if (ifact == 1) {
+ goto L100;
+ }
+ rcondc = 0.f;
+
+ } else if (ifact == 1) {
+
+/* Compute the 1-norm of A. */
+
+ anorm = clanht_("1", &n, &d__[1], &e[1]);
+
+ scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
+ if (n > 1) {
+ i__3 = n - 1;
+ ccopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
+ }
+
+/* Factor the matrix A. */
+
+ cpttrf_(&n, &d__[n + 1], &e[n + 1], &info);
+
+/* Use CPTTRS to solve for one column at a time of */
+/* inv(A), computing the maximum column sum as we go. */
+
+ ainvnm = 0.f;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__5 = j;
+ x[i__5].r = 0.f, x[i__5].i = 0.f;
+/* L50: */
+ }
+ i__4 = i__;
+ x[i__4].r = 1.f, x[i__4].i = 0.f;
+ cpttrs_("Lower", &n, &c__1, &d__[n + 1], &e[n + 1], &
+ x[1], &lda, &info);
+/* Computing MAX */
+ r__1 = ainvnm, r__2 = scasum_(&n, &x[1], &c__1);
+ ainvnm = dmax(r__1,r__2);
+/* L60: */
+ }
+
+/* Compute the 1-norm condition number of A. */
+
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondc = 1.f;
+ } else {
+ rcondc = 1.f / anorm / ainvnm;
+ }
+ }
+
+ if (ifact == 2) {
+
+/* --- Test CPTSV -- */
+
+ scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
+ if (n > 1) {
+ i__3 = n - 1;
+ ccopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
+ }
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
+
+/* Factor A as L*D*L' and solve the system A*X = B. */
+
+ s_copy(srnamc_1.srnamt, "CPTSV ", (ftnlen)32, (ftnlen)6);
+ cptsv_(&n, nrhs, &d__[n + 1], &e[n + 1], &x[1], &lda, &
+ info);
+
+/* Check error code from CPTSV . */
+
+ if (info != izero) {
+ alaerh_(path, "CPTSV ", &info, &izero, " ", &n, &n, &
+ c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+ nt = 0;
+ if (izero == 0) {
+
+/* Check the factorization by computing the ratio */
+/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
+
+ cptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
+ work[1], result);
+
+/* Compute the residual in the solution. */
+
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ cptt02_("Lower", &n, nrhs, &d__[1], &e[1], &x[1], &
+ lda, &work[1], &lda, &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, "CPTSV ", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L70: */
+ }
+ nrun += nt;
+ }
+
+/* --- Test CPTSVX --- */
+
+ if (ifact > 1) {
+
+/* Initialize D( N+1:2*N ) and E( N+1:2*N ) to zero. */
+
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d__[n + i__] = 0.f;
+ i__4 = n + i__;
+ e[i__4].r = 0.f, e[i__4].i = 0.f;
+/* L80: */
+ }
+ if (n > 0) {
+ d__[n + n] = 0.f;
+ }
+ }
+
+ claset_("Full", &n, nrhs, &c_b62, &c_b62, &x[1], &lda);
+
+/* Solve the system and compute the condition number and */
+/* error bounds using CPTSVX. */
+
+ s_copy(srnamc_1.srnamt, "CPTSVX", (ftnlen)32, (ftnlen)6);
+ cptsvx_(fact, &n, nrhs, &d__[1], &e[1], &d__[n + 1], &e[n + 1]
+, &b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &rwork[
+ *nrhs + 1], &work[1], &rwork[(*nrhs << 1) + 1], &info);
+
+/* Check the error code from CPTSVX. */
+
+ if (info != izero) {
+ alaerh_(path, "CPTSVX", &info, &izero, fact, &n, &n, &
+ c__1, &c__1, nrhs, &imat, &nfail, &nerrs, nout);
+ }
+ if (izero == 0) {
+ if (ifact == 2) {
+
+/* Check the factorization by computing the ratio */
+/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
+
+ k1 = 1;
+ cptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
+ work[1], result);
+ } else {
+ k1 = 2;
+ }
+
+/* Compute the residual in the solution. */
+
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ cptt02_("Lower", &n, nrhs, &d__[1], &e[1], &x[1], &lda, &
+ work[1], &lda, &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[2]);
+
+/* Check error bounds from iterative refinement. */
+
+ cptt05_(&n, nrhs, &d__[1], &e[1], &b[1], &lda, &x[1], &
+ lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs + 1],
+ &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Check the reciprocal of the condition number. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, "CPTSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L90: */
+ }
+ nrun = nrun + 7 - k1;
+L100:
+ ;
+ }
+L110:
+ ;
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CDRVPT */
+
+} /* cdrvpt_ */
diff --git a/TESTING/LIN/cdrvrf1.c b/TESTING/LIN/cdrvrf1.c
new file mode 100644
index 0000000..4c501a6
--- /dev/null
+++ b/TESTING/LIN/cdrvrf1.c
@@ -0,0 +1,353 @@
+/* cdrvrf1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__4 = 4;
+static integer c__1 = 1;
+
+/* Subroutine */ int cdrvrf1_(integer *nout, integer *nn, integer *nval, real
+ *thresh, complex *a, integer *lda, complex *arf, real *work)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char forms[1*2] = "N" "C";
+ static char norms[1*4] = "M" "1" "I" "F";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002 *** Error(s) or Failure(s) while test"
+ "ing CLANHF ***\002)";
+ static char fmt_9998[] = "(1x,\002 Error in \002,a6,\002 with UPLO="
+ "'\002,a1,\002', FORM='\002,a1,\002', N=\002,i5)";
+ static char fmt_9997[] = "(1x,\002 Failure in \002,a6,\002 N=\002,"
+ "i5,\002 TYPE=\002,i5,\002 UPLO='\002,a1,\002', FORM ='\002,a1"
+ ",\002', NORM='\002,a1,\002', test=\002,g12.5)";
+ static char fmt_9996[] = "(1x,\002All tests for \002,a6,\002 auxiliary r"
+ "outine passed the \002,\002threshold (\002,i5,\002 tests run)"
+ "\002)";
+ static char fmt_9995[] = "(1x,a6,\002 auxiliary routine:\002,i5,\002 out"
+ " of \002,i5,\002 tests failed to pass the threshold\002)";
+ static char fmt_9994[] = "(26x,i5,\002 error message recorded (\002,a6"
+ ",\002)\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void),
+ do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, n, iin, iit;
+ real eps;
+ integer info;
+ char norm[1], uplo[1];
+ integer nrun, nfail;
+ real large;
+ integer iseed[4];
+ char cform[1];
+ real small;
+ integer iform;
+ real norma;
+ integer inorm, iuplo, nerrs;
+ extern doublereal clanhe_(char *, char *, integer *, complex *, integer *,
+ real *), clanhf_(char *, char *, char *, integer
+ *, complex *, real *);
+ extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int ctrttf_(char *, char *, integer *, complex *,
+ integer *, complex *, integer *);
+ real result[1], normarf;
+
+ /* Fortran I/O blocks */
+ static cilist io___22 = { 0, 0, 0, 0, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___30 = { 0, 0, 0, 0, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVRF1 tests the LAPACK RFP routines: */
+/* CLANHF.F */
+
+/* Arguments */
+/* ========= */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* THRESH (input) 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. */
+
+/* A (workspace) COMPLEX array, dimension (LDA,NMAX) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,NMAX). */
+
+/* ARF (workspace) COMPLEX array, dimension ((NMAX*(NMAX+1))/2). */
+
+/* WORK (workspace) COMPLEX array, dimension ( NMAX ) */
+
+/* ===================================================================== */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nval;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --arf;
+ --work;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ info = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+ eps = slamch_("Precision");
+ small = slamch_("Safe minimum");
+ large = 1.f / small;
+ small = small * *lda * *lda;
+ large = large / *lda / *lda;
+
+ i__1 = *nn;
+ for (iin = 1; iin <= i__1; ++iin) {
+
+ n = nval[iin];
+
+ for (iit = 1; iit <= 3; ++iit) {
+
+/* IIT = 1 : random matrix */
+/* IIT = 2 : random matrix scaled near underflow */
+/* IIT = 3 : random matrix scaled near overflow */
+
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ clarnd_(&q__1, &c__4, iseed);
+ a[i__4].r = q__1.r, a[i__4].i = q__1.i;
+ }
+ }
+
+ if (iit == 2) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__ + j * a_dim1;
+ q__1.r = large * a[i__5].r, q__1.i = large * a[i__5]
+ .i;
+ a[i__4].r = q__1.r, a[i__4].i = q__1.i;
+ }
+ }
+ }
+
+ if (iit == 3) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__ + j * a_dim1;
+ q__1.r = small * a[i__5].r, q__1.i = small * a[i__5]
+ .i;
+ a[i__4].r = q__1.r, a[i__4].i = q__1.i;
+ }
+ }
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Do first for CFORM = 'N', then for CFORM = 'C' */
+
+ for (iform = 1; iform <= 2; ++iform) {
+
+ *(unsigned char *)cform = *(unsigned char *)&forms[iform
+ - 1];
+
+ s_copy(srnamc_1.srnamt, "CTRTTF", (ftnlen)32, (ftnlen)6);
+ ctrttf_(cform, uplo, &n, &a[a_offset], lda, &arf[1], &
+ info);
+
+/* Check error code from CTRTTF */
+
+ if (info != 0) {
+ if (nfail == 0 && nerrs == 0) {
+ io___22.ciunit = *nout;
+ s_wsle(&io___22);
+ e_wsle();
+ io___23.ciunit = *nout;
+ s_wsfe(&io___23);
+ e_wsfe();
+ }
+ io___24.ciunit = *nout;
+ s_wsfe(&io___24);
+ do_fio(&c__1, srnamc_1.srnamt, (ftnlen)32);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, cform, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ++nerrs;
+ goto L100;
+ }
+
+ for (inorm = 1; inorm <= 4; ++inorm) {
+
+/* Check all four norms: 'M', '1', 'I', 'F' */
+
+ *(unsigned char *)norm = *(unsigned char *)&norms[
+ inorm - 1];
+ normarf = clanhf_(norm, cform, uplo, &n, &arf[1], &
+ work[1]);
+ norma = clanhe_(norm, uplo, &n, &a[a_offset], lda, &
+ work[1]);
+
+ result[0] = (norma - normarf) / norma / eps;
+ ++nrun;
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ io___30.ciunit = *nout;
+ s_wsle(&io___30);
+ e_wsle();
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ e_wsfe();
+ }
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "CLANHF", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iit, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, cform, (ftnlen)1);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L90: */
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+
+/* Print a summary of the results. */
+
+ if (nfail == 0) {
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, "CLANHF", (ftnlen)6);
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "CLANHF", (ftnlen)6);
+ do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (nerrs != 0) {
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, (char *)&nerrs, (ftnlen)sizeof(integer));
+ do_fio(&c__1, "CLANHF", (ftnlen)6);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of CDRVRF1 */
+
+} /* cdrvrf1_ */
diff --git a/TESTING/LIN/cdrvrf2.c b/TESTING/LIN/cdrvrf2.c
new file mode 100644
index 0000000..e2e350d
--- /dev/null
+++ b/TESTING/LIN/cdrvrf2.c
@@ -0,0 +1,323 @@
+/* cdrvrf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__4 = 4;
+static integer c__1 = 1;
+
+/* Subroutine */ int cdrvrf2_(integer *nout, integer *nn, integer *nval,
+ complex *a, integer *lda, complex *arf, complex *ap, complex *asav)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char forms[1*2] = "N" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002 *** Error(s) while testing the RFP co"
+ "nvertion\002,\002 routines ***\002)";
+ static char fmt_9998[] = "(1x,\002 Error in RFP,convertion routines "
+ "N=\002,i5,\002 UPLO='\002,a1,\002', FORM ='\002,a1,\002'\002)";
+ static char fmt_9997[] = "(1x,\002All tests for the RFP convertion routi"
+ "nes passed (\002,i5,\002 tests run)\002)";
+ static char fmt_9996[] = "(1x,\002RFP convertion routines:\002,i5,\002 o"
+ "ut of \002,i5,\002 error message recorded\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, asav_dim1, asav_offset, i__1, i__2, i__3, i__4,
+ i__5;
+ complex q__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void),
+ do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, n;
+ logical ok1, ok2;
+ integer iin, info;
+ char uplo[1];
+ integer nrun, iseed[4];
+ char cform[1];
+ integer iform;
+ logical lower;
+ integer iuplo, nerrs;
+ extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+ extern /* Subroutine */ int ctfttp_(char *, char *, integer *, complex *,
+ complex *, integer *), ctpttf_(char *, char *,
+ integer *, complex *, complex *, integer *),
+ ctfttr_(char *, char *, integer *, complex *, complex *, integer *
+, integer *), ctrttf_(char *, char *, integer *,
+ complex *, integer *, complex *, integer *),
+ ctrttp_(char *, integer *, complex *, integer *, complex *,
+ integer *), ctpttr_(char *, integer *, complex *, complex
+ *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___19 = { 0, 0, 0, 0, 0 };
+ static cilist io___20 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___21 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVRF2 tests the LAPACK RFP convertion routines. */
+
+/* Arguments */
+/* ========= */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* A (workspace) COMPLEX array, dimension (LDA,NMAX) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,NMAX). */
+
+/* ARF (workspace) COMPLEX array, dimension ((NMAX*(NMAX+1))/2). */
+
+/* AP (workspace) COMPLEX array, dimension ((NMAX*(NMAX+1))/2). */
+
+/* A2 (workspace) COMPLEX6 array, dimension (LDA,NMAX) */
+
+/* ===================================================================== */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nval;
+ asav_dim1 = *lda;
+ asav_offset = 1 + asav_dim1;
+ asav -= asav_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --arf;
+ --ap;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ nrun = 0;
+ nerrs = 0;
+ info = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+ i__1 = *nn;
+ for (iin = 1; iin <= i__1; ++iin) {
+
+ n = nval[iin];
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ lower = TRUE_;
+ if (iuplo == 1) {
+ lower = FALSE_;
+ }
+
+/* Do first for CFORM = 'N', then for CFORM = 'C' */
+
+ for (iform = 1; iform <= 2; ++iform) {
+
+ *(unsigned char *)cform = *(unsigned char *)&forms[iform - 1];
+
+ ++nrun;
+
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ clarnd_(&q__1, &c__4, iseed);
+ a[i__4].r = q__1.r, a[i__4].i = q__1.i;
+ }
+ }
+
+ s_copy(srnamc_1.srnamt, "CTRTTF", (ftnlen)32, (ftnlen)6);
+ ctrttf_(cform, uplo, &n, &a[a_offset], lda, &arf[1], &info);
+
+ s_copy(srnamc_1.srnamt, "CTFTTP", (ftnlen)32, (ftnlen)6);
+ ctfttp_(cform, uplo, &n, &arf[1], &ap[1], &info);
+
+ s_copy(srnamc_1.srnamt, "CTPTTR", (ftnlen)32, (ftnlen)6);
+ ctpttr_(uplo, &n, &ap[1], &asav[asav_offset], lda, &info);
+
+ ok1 = TRUE_;
+ if (lower) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__ + j * asav_dim1;
+ if (a[i__4].r != asav[i__5].r || a[i__4].i !=
+ asav[i__5].i) {
+ ok1 = FALSE_;
+ }
+ }
+ }
+ } else {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__ + j * asav_dim1;
+ if (a[i__4].r != asav[i__5].r || a[i__4].i !=
+ asav[i__5].i) {
+ ok1 = FALSE_;
+ }
+ }
+ }
+ }
+
+ ++nrun;
+
+ s_copy(srnamc_1.srnamt, "CTRTTP", (ftnlen)32, (ftnlen)6);
+ ctrttp_(uplo, &n, &a[a_offset], lda, &ap[1], &info)
+ ;
+
+ s_copy(srnamc_1.srnamt, "CTPTTF", (ftnlen)32, (ftnlen)6);
+ ctpttf_(cform, uplo, &n, &ap[1], &arf[1], &info);
+
+ s_copy(srnamc_1.srnamt, "CTFTTR", (ftnlen)32, (ftnlen)6);
+ ctfttr_(cform, uplo, &n, &arf[1], &asav[asav_offset], lda, &
+ info);
+
+ ok2 = TRUE_;
+ if (lower) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__ + j * asav_dim1;
+ if (a[i__4].r != asav[i__5].r || a[i__4].i !=
+ asav[i__5].i) {
+ ok2 = FALSE_;
+ }
+ }
+ }
+ } else {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__ + j * asav_dim1;
+ if (a[i__4].r != asav[i__5].r || a[i__4].i !=
+ asav[i__5].i) {
+ ok2 = FALSE_;
+ }
+ }
+ }
+ }
+
+ if (! ok1 || ! ok2) {
+ if (nerrs == 0) {
+ io___19.ciunit = *nout;
+ s_wsle(&io___19);
+ e_wsle();
+ io___20.ciunit = *nout;
+ s_wsfe(&io___20);
+ e_wsfe();
+ }
+ io___21.ciunit = *nout;
+ s_wsfe(&io___21);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, cform, (ftnlen)1);
+ e_wsfe();
+ ++nerrs;
+ }
+
+/* L100: */
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ if (nerrs == 0) {
+ io___22.ciunit = *nout;
+ s_wsfe(&io___22);
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___23.ciunit = *nout;
+ s_wsfe(&io___23);
+ do_fio(&c__1, (char *)&nerrs, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of CDRVRF2 */
+
+} /* cdrvrf2_ */
diff --git a/TESTING/LIN/cdrvrf3.c b/TESTING/LIN/cdrvrf3.c
new file mode 100644
index 0000000..cc2d23e
--- /dev/null
+++ b/TESTING/LIN/cdrvrf3.c
@@ -0,0 +1,470 @@
+/* cdrvrf3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__4 = 4;
+static integer c__5 = 5;
+static integer c__1 = 1;
+
+/* Subroutine */ int cdrvrf3_(integer *nout, integer *nn, integer *nval, real
+ *thresh, complex *a, integer *lda, complex *arf, complex *b1, complex
+ *b2, real *s_work_clange__, complex *c_work_cgeqrf__, complex *tau)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char forms[1*2] = "N" "C";
+ static char sides[1*2] = "L" "R";
+ static char transs[1*2] = "N" "C";
+ static char diags[1*2] = "N" "U";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002 *** Error(s) or Failure(s) while test"
+ "ing CTFSM ***\002)";
+ static char fmt_9997[] = "(1x,\002 Failure in \002,a5,\002, CFORM="
+ "'\002,a1,\002',\002,\002 SIDE='\002,a1,\002',\002,\002 UPLO='"
+ "\002,a1,\002',\002,\002 TRANS='\002,a1,\002',\002,\002 DIAG='"
+ "\002,a1,\002',\002,\002 M=\002,i3,\002, N =\002,i3,\002, test"
+ "=\002,g12.5)";
+ static char fmt_9996[] = "(1x,\002All tests for \002,a5,\002 auxiliary r"
+ "outine passed the \002,\002threshold (\002,i5,\002 tests run)"
+ "\002)";
+ static char fmt_9995[] = "(1x,a6,\002 auxiliary routine:\002,i5,\002 out"
+ " of \002,i5,\002 tests failed to pass the threshold\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b1_dim1, b1_offset, b2_dim1, b2_offset, i__1,
+ i__2, i__3, i__4, i__5, i__6, i__7;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void),
+ do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, m, n, na, iim, iin;
+ real eps;
+ char diag[1], side[1];
+ integer info;
+ char uplo[1];
+ integer nrun, idiag;
+ complex alpha;
+ integer nfail, iseed[4], iside;
+ char cform[1];
+ integer iform;
+ extern /* Subroutine */ int ctfsm_(char *, char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, complex *, integer *);
+ char trans[1];
+ integer iuplo;
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ integer ialpha;
+ extern /* Subroutine */ int cgelqf_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *);
+ extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int cgeqrf_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *);
+ integer itrans;
+ extern /* Subroutine */ int ctrttf_(char *, char *, integer *, complex *,
+ integer *, complex *, integer *);
+ real result[1];
+
+ /* Fortran I/O blocks */
+ static cilist io___32 = { 0, 0, 0, 0, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVRF3 tests the LAPACK RFP routines: */
+/* CTFSM */
+
+/* Arguments */
+/* ========= */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* THRESH (input) 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. */
+
+/* A (workspace) COMPLEX*16 array, dimension (LDA,NMAX) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,NMAX). */
+
+/* ARF (workspace) COMPLEX array, dimension ((NMAX*(NMAX+1))/2). */
+
+/* B1 (workspace) COMPLEX array, dimension (LDA,NMAX) */
+
+/* B2 (workspace) COMPLEX array, dimension (LDA,NMAX) */
+
+/* S_WORK_CLANGE (workspace) REAL array, dimension (NMAX) */
+
+/* C_WORK_CGEQRF (workspace) COMPLEX array, dimension (NMAX) */
+
+/* TAU (workspace) COMPLEX array, dimension (NMAX) */
+
+/* ===================================================================== */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nval;
+ b2_dim1 = *lda;
+ b2_offset = 1 + b2_dim1;
+ b2 -= b2_offset;
+ b1_dim1 = *lda;
+ b1_offset = 1 + b1_dim1;
+ b1 -= b1_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --arf;
+ --s_work_clange__;
+ --c_work_cgeqrf__;
+ --tau;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ nrun = 0;
+ nfail = 0;
+ info = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = slamch_("Precision");
+
+ i__1 = *nn;
+ for (iim = 1; iim <= i__1; ++iim) {
+
+ m = nval[iim];
+
+ i__2 = *nn;
+ for (iin = 1; iin <= i__2; ++iin) {
+
+ n = nval[iin];
+
+ for (iform = 1; iform <= 2; ++iform) {
+
+ *(unsigned char *)cform = *(unsigned char *)&forms[iform - 1];
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+
+ for (iside = 1; iside <= 2; ++iside) {
+
+ *(unsigned char *)side = *(unsigned char *)&sides[
+ iside - 1];
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itrans - 1];
+
+ for (idiag = 1; idiag <= 2; ++idiag) {
+
+ *(unsigned char *)diag = *(unsigned char *)&
+ diags[idiag - 1];
+
+ for (ialpha = 1; ialpha <= 3; ++ialpha) {
+
+ if (ialpha == 1) {
+ alpha.r = 0.f, alpha.i = 0.f;
+ } else if (ialpha == 1) {
+ alpha.r = 1.f, alpha.i = 0.f;
+ } else {
+ clarnd_(&q__1, &c__4, iseed);
+ alpha.r = q__1.r, alpha.i = q__1.i;
+ }
+
+/* All the parameters are set: */
+/* CFORM, SIDE, UPLO, TRANS, DIAG, M, N, */
+/* and ALPHA */
+/* READY TO TEST! */
+
+ ++nrun;
+
+ if (iside == 1) {
+
+/* The case ISIDE.EQ.1 is when SIDE.EQ.'L' */
+/* -> A is M-by-M ( B is M-by-N ) */
+
+ na = m;
+
+ } else {
+
+/* The case ISIDE.EQ.2 is when SIDE.EQ.'R' */
+/* -> A is N-by-N ( B is M-by-N ) */
+
+ na = n;
+
+ }
+
+/* Generate A our NA--by--NA triangular */
+/* matrix. */
+/* Our test is based on forward error so we */
+/* do want A to be well conditionned! To get */
+/* a well-conditionned triangular matrix, we */
+/* take the R factor of the QR/LQ factorization */
+/* of a random matrix. */
+
+ i__3 = na;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = na;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__ + j * a_dim1;
+ clarnd_(&q__1, &c__4, iseed);
+ a[i__5].r = q__1.r, a[i__5].i =
+ q__1.i;
+ }
+ }
+
+ if (iuplo == 1) {
+
+/* The case IUPLO.EQ.1 is when SIDE.EQ.'U' */
+/* -> QR factorization. */
+
+ s_copy(srnamc_1.srnamt, "CGEQRF", (
+ ftnlen)32, (ftnlen)6);
+ cgeqrf_(&na, &na, &a[a_offset], lda, &
+ tau[1], &c_work_cgeqrf__[1],
+ lda, &info);
+ } else {
+
+/* The case IUPLO.EQ.2 is when SIDE.EQ.'L' */
+/* -> QL factorization. */
+
+ s_copy(srnamc_1.srnamt, "CGELQF", (
+ ftnlen)32, (ftnlen)6);
+ cgelqf_(&na, &na, &a[a_offset], lda, &
+ tau[1], &c_work_cgeqrf__[1],
+ lda, &info);
+ }
+
+/* After the QR factorization, the diagonal */
+/* of A is made of real numbers, we multiply */
+/* by a random complex number of absolute */
+/* value 1.0E+00. */
+
+ i__3 = na;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j + j * a_dim1;
+ i__5 = j + j * a_dim1;
+ clarnd_(&q__2, &c__5, iseed);
+ q__1.r = a[i__5].r * q__2.r - a[i__5]
+ .i * q__2.i, q__1.i = a[i__5]
+ .r * q__2.i + a[i__5].i *
+ q__2.r;
+ a[i__4].r = q__1.r, a[i__4].i =
+ q__1.i;
+ }
+
+/* Store a copy of A in RFP format (in ARF). */
+
+ s_copy(srnamc_1.srnamt, "CTRTTF", (ftnlen)
+ 32, (ftnlen)6);
+ ctrttf_(cform, uplo, &na, &a[a_offset],
+ lda, &arf[1], &info);
+
+/* Generate B1 our M--by--N right-hand side */
+/* and store a copy in B2. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = m;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__ + j * b1_dim1;
+ clarnd_(&q__1, &c__4, iseed);
+ b1[i__5].r = q__1.r, b1[i__5].i =
+ q__1.i;
+ i__5 = i__ + j * b2_dim1;
+ i__6 = i__ + j * b1_dim1;
+ b2[i__5].r = b1[i__6].r, b2[i__5]
+ .i = b1[i__6].i;
+ }
+ }
+
+/* Solve op( A ) X = B or X op( A ) = B */
+/* with CTRSM */
+
+ s_copy(srnamc_1.srnamt, "CTRSM", (ftnlen)
+ 32, (ftnlen)5);
+ ctrsm_(side, uplo, trans, diag, &m, &n, &
+ alpha, &a[a_offset], lda, &b1[
+ b1_offset], lda);
+
+/* Solve op( A ) X = B or X op( A ) = B */
+/* with CTFSM */
+
+ s_copy(srnamc_1.srnamt, "CTFSM", (ftnlen)
+ 32, (ftnlen)5);
+ ctfsm_(cform, side, uplo, trans, diag, &m,
+ &n, &alpha, &arf[1], &b2[
+ b2_offset], lda);
+
+/* Check that the result agrees. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = m;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__ + j * b1_dim1;
+ i__6 = i__ + j * b2_dim1;
+ i__7 = i__ + j * b1_dim1;
+ q__1.r = b2[i__6].r - b1[i__7].r,
+ q__1.i = b2[i__6].i - b1[
+ i__7].i;
+ b1[i__5].r = q__1.r, b1[i__5].i =
+ q__1.i;
+ }
+ }
+
+ result[0] = clange_("I", &m, &n, &b1[
+ b1_offset], lda, &s_work_clange__[
+ 1]);
+
+/* Computing MAX */
+ i__3 = max(m,n);
+ result[0] = result[0] / sqrt(eps) / max(
+ i__3,1);
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0) {
+ io___32.ciunit = *nout;
+ s_wsle(&io___32);
+ e_wsle();
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ e_wsfe();
+ }
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "CTFSM", (ftnlen)5);
+ do_fio(&c__1, cform, (ftnlen)1);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+
+/* L100: */
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+
+/* Print a summary of the results. */
+
+ if (nfail == 0) {
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, "CTFSM", (ftnlen)5);
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, "CTFSM", (ftnlen)5);
+ do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of CDRVRF3 */
+
+} /* cdrvrf3_ */
diff --git a/TESTING/LIN/cdrvrf4.c b/TESTING/LIN/cdrvrf4.c
new file mode 100644
index 0000000..340a457
--- /dev/null
+++ b/TESTING/LIN/cdrvrf4.c
@@ -0,0 +1,422 @@
+/* cdrvrf4.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__4 = 4;
+static integer c__1 = 1;
+
+/* Subroutine */ int cdrvrf4_(integer *nout, integer *nn, integer *nval, real
+ *thresh, complex *c1, complex *c2, integer *ldc, complex *crf,
+ complex *a, integer *lda, real *s_work_clange__)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char forms[1*2] = "N" "C";
+ static char transs[1*2] = "N" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002 *** Error(s) or Failure(s) while test"
+ "ing CHFRK ***\002)";
+ static char fmt_9997[] = "(1x,\002 Failure in \002,a5,\002, CFORM="
+ "'\002,a1,\002',\002,\002 UPLO='\002,a1,\002',\002,\002 TRANS="
+ "'\002,a1,\002',\002,\002 N=\002,i3,\002, K =\002,i3,\002, test"
+ "=\002,g12.5)";
+ static char fmt_9996[] = "(1x,\002All tests for \002,a5,\002 auxiliary r"
+ "outine passed the \002,\002threshold (\002,i5,\002 tests run)"
+ "\002)";
+ static char fmt_9995[] = "(1x,a6,\002 auxiliary routine:\002,i5,\002 out"
+ " of \002,i5,\002 tests failed to pass the threshold\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, c1_dim1, c1_offset, c2_dim1, c2_offset, i__1,
+ i__2, i__3, i__4, i__5, i__6, i__7;
+ real r__1;
+ complex q__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void),
+ do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k, n, iik, iin;
+ real eps, beta;
+ integer info;
+ char uplo[1];
+ integer nrun;
+ real alpha;
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int cherk_(char *, char *, integer *, integer *,
+ real *, complex *, integer *, real *, complex *, integer *), chfrk_(char *, char *, char *, integer *,
+ integer *, real *, complex *, integer *, real *, complex *);
+ char cform[1];
+ integer iform;
+ real norma, normc;
+ char trans[1];
+ integer iuplo;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ integer ialpha;
+ extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+ extern doublereal slamch_(char *), slarnd_(integer *, integer *);
+ integer itrans;
+ extern /* Subroutine */ int ctfttr_(char *, char *, integer *, complex *,
+ complex *, integer *, integer *), ctrttf_(char *,
+ char *, integer *, complex *, integer *, complex *, integer *);
+ real result[1];
+
+ /* Fortran I/O blocks */
+ static cilist io___28 = { 0, 0, 0, 0, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVRF4 tests the LAPACK RFP routines: */
+/* CHFRK */
+
+/* Arguments */
+/* ========= */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* THRESH (input) 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. */
+
+/* C1 (workspace) COMPLEX array, dimension (LDC,NMAX) */
+
+/* C2 (workspace) COMPLEX array, dimension (LDC,NMAX) */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,NMAX). */
+
+/* CRF (workspace) COMPLEX array, dimension ((NMAX*(NMAX+1))/2). */
+
+/* A (workspace) COMPLEX array, dimension (LDA,NMAX) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,NMAX). */
+
+/* S_WORK_CLANGE (workspace) REAL array, dimension (NMAX) */
+
+/* ===================================================================== */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nval;
+ c2_dim1 = *ldc;
+ c2_offset = 1 + c2_dim1;
+ c2 -= c2_offset;
+ c1_dim1 = *ldc;
+ c1_offset = 1 + c1_dim1;
+ c1 -= c1_offset;
+ --crf;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s_work_clange__;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ nrun = 0;
+ nfail = 0;
+ info = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = slamch_("Precision");
+
+ i__1 = *nn;
+ for (iin = 1; iin <= i__1; ++iin) {
+
+ n = nval[iin];
+
+ i__2 = *nn;
+ for (iik = 1; iik <= i__2; ++iik) {
+
+ k = nval[iin];
+
+ for (iform = 1; iform <= 2; ++iform) {
+
+ *(unsigned char *)cform = *(unsigned char *)&forms[iform - 1];
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[
+ itrans - 1];
+
+ for (ialpha = 1; ialpha <= 4; ++ialpha) {
+
+ if (ialpha == 1) {
+ alpha = 0.f;
+ beta = 0.f;
+ } else if (ialpha == 1) {
+ alpha = 1.f;
+ beta = 0.f;
+ } else if (ialpha == 1) {
+ alpha = 0.f;
+ beta = 1.f;
+ } else {
+ alpha = slarnd_(&c__2, iseed);
+ beta = slarnd_(&c__2, iseed);
+ }
+
+/* All the parameters are set: */
+/* CFORM, UPLO, TRANS, M, N, */
+/* ALPHA, and BETA */
+/* READY TO TEST! */
+
+ ++nrun;
+
+ if (itrans == 1) {
+
+/* In this case we are NOTRANS, so A is N-by-K */
+
+ i__3 = k;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__ + j * a_dim1;
+ clarnd_(&q__1, &c__4, iseed);
+ a[i__5].r = q__1.r, a[i__5].i =
+ q__1.i;
+ }
+ }
+
+ norma = clange_("I", &n, &k, &a[a_offset],
+ lda, &s_work_clange__[1]);
+
+ } else {
+
+/* In this case we are TRANS, so A is K-by-N */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = k;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__ + j * a_dim1;
+ clarnd_(&q__1, &c__4, iseed);
+ a[i__5].r = q__1.r, a[i__5].i =
+ q__1.i;
+ }
+ }
+
+ norma = clange_("I", &k, &n, &a[a_offset],
+ lda, &s_work_clange__[1]);
+
+ }
+
+
+/* Generate C1 our N--by--N Hermitian matrix. */
+/* Make sure C2 has the same upper/lower part, */
+/* (the one that we do not touch), so */
+/* copy the initial C1 in C2 in it. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__ + j * c1_dim1;
+ clarnd_(&q__1, &c__4, iseed);
+ c1[i__5].r = q__1.r, c1[i__5].i = q__1.i;
+ i__5 = i__ + j * c2_dim1;
+ i__6 = i__ + j * c1_dim1;
+ c2[i__5].r = c1[i__6].r, c2[i__5].i = c1[
+ i__6].i;
+ }
+ }
+
+/* (See comment later on for why we use CLANGE and */
+/* not CLANHE for C1.) */
+
+ normc = clange_("I", &n, &n, &c1[c1_offset], ldc,
+ &s_work_clange__[1]);
+
+ s_copy(srnamc_1.srnamt, "CTRTTF", (ftnlen)32, (
+ ftnlen)6);
+ ctrttf_(cform, uplo, &n, &c1[c1_offset], ldc, &
+ crf[1], &info);
+
+/* call zherk the BLAS routine -> gives C1 */
+
+ s_copy(srnamc_1.srnamt, "CHERK ", (ftnlen)32, (
+ ftnlen)6);
+ cherk_(uplo, trans, &n, &k, &alpha, &a[a_offset],
+ lda, &beta, &c1[c1_offset], ldc);
+
+/* call zhfrk the RFP routine -> gives CRF */
+
+ s_copy(srnamc_1.srnamt, "CHFRK ", (ftnlen)32, (
+ ftnlen)6);
+ chfrk_(cform, uplo, trans, &n, &k, &alpha, &a[
+ a_offset], lda, &beta, &crf[1]);
+
+/* convert CRF in full format -> gives C2 */
+
+ s_copy(srnamc_1.srnamt, "CTFTTR", (ftnlen)32, (
+ ftnlen)6);
+ ctfttr_(cform, uplo, &n, &crf[1], &c2[c2_offset],
+ ldc, &info);
+
+/* compare C1 and C2 */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__ + j * c1_dim1;
+ i__6 = i__ + j * c1_dim1;
+ i__7 = i__ + j * c2_dim1;
+ q__1.r = c1[i__6].r - c2[i__7].r, q__1.i =
+ c1[i__6].i - c2[i__7].i;
+ c1[i__5].r = q__1.r, c1[i__5].i = q__1.i;
+ }
+ }
+
+/* Yes, C1 is Hermitian so we could call CLANHE, */
+/* but we want to check the upper part that is */
+/* supposed to be unchanged and the diagonal that */
+/* is supposed to be real -> CLANGE */
+
+ result[0] = clange_("I", &n, &n, &c1[c1_offset],
+ ldc, &s_work_clange__[1]);
+/* Computing MAX */
+ r__1 = dabs(alpha) * norma * norma + dabs(beta) *
+ normc;
+ result[0] = result[0] / dmax(r__1,1.f) / max(n,1)
+ / eps;
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0) {
+ io___28.ciunit = *nout;
+ s_wsle(&io___28);
+ e_wsle();
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ e_wsfe();
+ }
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, "CHFRK", (ftnlen)5);
+ do_fio(&c__1, cform, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+
+/* L100: */
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+/* Print a summary of the results. */
+
+ if (nfail == 0) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, "CHFRK", (ftnlen)5);
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "CHFRK", (ftnlen)5);
+ do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of CDRVRF4 */
+
+} /* cdrvrf4_ */
diff --git a/TESTING/LIN/cdrvrfp.c b/TESTING/LIN/cdrvrfp.c
new file mode 100644
index 0000000..58821f6
--- /dev/null
+++ b/TESTING/LIN/cdrvrfp.c
@@ -0,0 +1,595 @@
+/* cdrvrfp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+
+/* Subroutine */ int cdrvrfp_(integer *nout, integer *nn, integer *nval,
+ integer *nns, integer *nsval, integer *nnt, integer *ntval, real *
+ thresh, complex *a, complex *asav, complex *afac, complex *ainv,
+ complex *b, complex *bsav, complex *xact, complex *x, complex *arf,
+ complex *arfinv, complex *c_work_clatms__, complex *c_work_cpot01__,
+ complex *c_work_cpot02__, complex *c_work_cpot03__, real *
+ s_work_clatms__, real *s_work_clanhe__, real *s_work_cpot02__, real *
+ s_work_cpot03__)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char forms[1*2] = "N" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a6,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, kl, ku, nt, lda, ldb, iin, iis, iit, ioff, mode, info,
+ imat;
+ char dist[1];
+ integer nrhs;
+ char uplo[1];
+ integer nrun;
+ extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *);
+ integer nfail, iseed[4];
+ char cform[1];
+ extern /* Subroutine */ int cpot01_(char *, integer *, complex *, integer
+ *, complex *, integer *, complex *, real *), cpot02_(char
+ *, integer *, integer *, complex *, integer *, complex *, integer
+ *, complex *, integer *, real *, real *), cpot03_(char *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, real *, real *, real *);
+ integer iform;
+ real anorm;
+ char ctype[1];
+ integer iuplo, nerrs, izero;
+ logical zerot;
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), aladhd_(integer *, char *);
+ extern doublereal clanhe_(char *, char *, integer *, complex *, integer *,
+ real *);
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *), claipd_(integer *, complex *, integer *, integer *);
+ real rcondc;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), clarhs_(char *, char
+ *, char *, char *, integer *, integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, integer *, integer *),
+ alasvm_(char *, integer *, integer *, integer *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, complex *, integer *, complex *, integer *), cpftri_(char *, char *, integer *, complex *,
+ integer *);
+ real ainvnm;
+ extern /* Subroutine */ int cpftrf_(char *, char *, integer *, complex *,
+ integer *), cpotrf_(char *, integer *, complex *,
+ integer *, integer *), cpotri_(char *, integer *, complex
+ *, integer *, integer *), cpftrs_(char *, char *, integer
+ *, integer *, complex *, complex *, integer *, integer *), ctfttr_(char *, char *, integer *, complex *, complex *,
+ integer *, integer *), ctrttf_(char *, char *,
+ integer *, complex *, integer *, complex *, integer *);
+ real result[4];
+
+ /* Fortran I/O blocks */
+ static cilist io___37 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVRFP tests the LAPACK RFP routines: */
+/* CPFTRF, CPFTRS, and CPFTRI. */
+
+/* This testing routine follow the same tests as CDRVPO (test for the full */
+/* format Symmetric Positive Definite solver). */
+
+/* The tests are performed in Full Format, convertion back and forth from */
+/* full format to RFP format are performed using the routines CTRTTF and */
+/* CTFTTR. */
+
+/* First, a specific matrix A of size N is created. There is nine types of */
+/* different matrixes possible. */
+/* 1. Diagonal 6. Random, CNDNUM = sqrt(0.1/EPS) */
+/* 2. Random, CNDNUM = 2 7. Random, CNDNUM = 0.1/EPS */
+/* *3. First row and column zero 8. Scaled near underflow */
+/* *4. Last row and column zero 9. Scaled near overflow */
+/* *5. Middle row and column zero */
+/* (* - tests error exits from CPFTRF, no test ratios are computed) */
+/* A solution XACT of size N-by-NRHS is created and the associated right */
+/* hand side B as well. Then CPFTRF is called to compute L (or U), the */
+/* Cholesky factor of A. Then L (or U) is used to solve the linear system */
+/* of equations AX = B. This gives X. Then L (or U) is used to compute the */
+/* inverse of A, AINV. The following four tests are then performed: */
+/* (1) norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
+/* norm( U'*U - A ) / ( N * norm(A) * EPS ), */
+/* (2) norm(B - A*X) / ( norm(A) * norm(X) * EPS ), */
+/* (3) norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* (4) ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ), */
+/* where EPS is the machine precision, RCOND the condition number of A, and */
+/* norm( . ) the 1-norm for (1,2,3) and the inf-norm for (4). */
+/* Errors occur when INFO parameter is not as expected. Failures occur when */
+/* a test ratios is greater than THRES. */
+
+/* Arguments */
+/* ========= */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right-hand sides NRHS. */
+
+/* NNT (input) INTEGER */
+/* The number of values of MATRIX TYPE contained in the vector NTVAL. */
+
+/* NTVAL (input) INTEGER array, dimension (NNT) */
+/* The values of matrix type (between 0 and 9 for PO/PP/PF matrices). */
+
+/* THRESH (input) 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. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*MAXRHS) */
+
+/* BSAV (workspace) COMPLEX array, dimension (NMAX*MAXRHS) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*MAXRHS) */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*MAXRHS) */
+
+/* ARF (workspace) COMPLEX array, dimension ((NMAX*(NMAX+1))/2) */
+
+/* ARFINV (workspace) COMPLEX array, dimension ((NMAX*(NMAX+1))/2) */
+
+/* C_WORK_CLATMS (workspace) COMPLEX array, dimension ( 3*NMAX ) */
+
+/* C_WORK_CPOT01 (workspace) COMPLEX array, dimension ( NMAX ) */
+
+/* C_WORK_CPOT02 (workspace) COMPLEX array, dimension ( NMAX*MAXRHS ) */
+
+/* C_WORK_CPOT03 (workspace) COMPLEX array, dimension ( NMAX*NMAX ) */
+
+/* S_WORK_CLATMS (workspace) REAL array, dimension ( NMAX ) */
+
+/* S_WORK_CLANHE (workspace) REAL array, dimension ( NMAX ) */
+
+/* S_WORK_CPOT02 (workspace) REAL array, dimension ( NMAX ) */
+
+/* S_WORK_CPOT03 (workspace) REAL array, dimension ( NMAX ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nval;
+ --nsval;
+ --ntval;
+ --a;
+ --asav;
+ --afac;
+ --ainv;
+ --b;
+ --bsav;
+ --xact;
+ --x;
+ --arf;
+ --arfinv;
+ --c_work_clatms__;
+ --c_work_cpot01__;
+ --c_work_cpot02__;
+ --c_work_cpot03__;
+ --s_work_clatms__;
+ --s_work_clanhe__;
+ --s_work_cpot02__;
+ --s_work_cpot03__;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+ i__1 = *nn;
+ for (iin = 1; iin <= i__1; ++iin) {
+
+ n = nval[iin];
+ lda = max(n,1);
+ ldb = max(n,1);
+
+ i__2 = *nns;
+ for (iis = 1; iis <= i__2; ++iis) {
+
+ nrhs = nsval[iis];
+
+ i__3 = *nnt;
+ for (iit = 1; iit <= i__3; ++iit) {
+
+ imat = ntval[iit];
+
+/* If N.EQ.0, only consider the first type */
+
+ if (n == 0 && iit > 1) {
+ goto L120;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ if (imat == 4 && n <= 1) {
+ goto L120;
+ }
+ if (imat == 5 && n <= 2) {
+ goto L120;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+
+/* Do first for CFORM = 'N', then for CFORM = 'C' */
+
+ for (iform = 1; iform <= 2; ++iform) {
+ *(unsigned char *)cform = *(unsigned char *)&forms[
+ iform - 1];
+
+/* Set up parameters with CLATB4 and generate a test */
+/* matrix with CLATMS. */
+
+ clatb4_("CPO", &imat, &n, &n, ctype, &kl, &ku, &anorm,
+ &mode, &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)
+ 6);
+ clatms_(&n, &n, dist, iseed, ctype, &s_work_clatms__[
+ 1], &mode, &cndnum, &anorm, &kl, &ku, uplo, &
+ a[1], &lda, &c_work_clatms__[1], &info);
+
+/* Check error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_("CPF", "CLATMS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &c_n1, &iit, &nfail, &
+ nerrs, nout);
+ goto L100;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot) {
+ if (iit == 3) {
+ izero = 1;
+ } else if (iit == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ i__4 = izero - 1;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__4 = n;
+ for (i__ = izero; i__ <= i__4; ++i__) {
+ i__5 = ioff;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__4 = izero - 1;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ioff;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__4 = n;
+ for (i__ = izero; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ i__4 = lda + 1;
+ claipd_(&n, &a[1], &i__4, &c__0);
+
+/* Save a copy of the matrix A in ASAV. */
+
+ clacpy_(uplo, &n, &n, &a[1], &lda, &asav[1], &lda);
+
+/* Compute the condition number of A (RCONDC). */
+
+ if (zerot) {
+ rcondc = 0.f;
+ } else {
+
+/* Compute the 1-norm of A. */
+
+ anorm = clanhe_("1", uplo, &n, &a[1], &lda, &
+ s_work_clanhe__[1]);
+
+/* Factor the matrix A. */
+
+ cpotrf_(uplo, &n, &a[1], &lda, &info);
+
+/* Form the inverse of A. */
+
+ cpotri_(uplo, &n, &a[1], &lda, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = clanhe_("1", uplo, &n, &a[1], &lda, &
+ s_work_clanhe__[1]);
+ rcondc = 1.f / anorm / ainvnm;
+
+/* Restore the matrix A. */
+
+ clacpy_(uplo, &n, &n, &asav[1], &lda, &a[1], &lda);
+
+ }
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ clarhs_("CPO", "N", uplo, " ", &n, &n, &kl, &ku, &
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &bsav[1], &
+ lda);
+
+/* Compute the L*L' or U'*U factorization of the */
+/* matrix and solve the system. */
+
+ clacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ clacpy_("Full", &n, &nrhs, &b[1], &ldb, &x[1], &ldb);
+
+ s_copy(srnamc_1.srnamt, "CTRTTF", (ftnlen)32, (ftnlen)
+ 6);
+ ctrttf_(cform, uplo, &n, &afac[1], &lda, &arf[1], &
+ info);
+ s_copy(srnamc_1.srnamt, "CPFTRF", (ftnlen)32, (ftnlen)
+ 6);
+ cpftrf_(cform, uplo, &n, &arf[1], &info);
+
+/* Check error code from CPFTRF. */
+
+ if (info != izero) {
+
+/* LANGOU: there is a small hick here: IZERO should */
+/* always be INFO however if INFO is ZERO, ALAERH does not */
+/* complain. */
+
+ alaerh_("CPF", "CPFSV ", &info, &izero, uplo, &n,
+ &n, &c_n1, &c_n1, &nrhs, &iit, &nfail, &
+ nerrs, nout);
+ goto L100;
+ }
+
+/* Skip the tests if INFO is not 0. */
+
+ if (info != 0) {
+ goto L100;
+ }
+
+ s_copy(srnamc_1.srnamt, "CPFTRS", (ftnlen)32, (ftnlen)
+ 6);
+ cpftrs_(cform, uplo, &n, &nrhs, &arf[1], &x[1], &ldb,
+ &info);
+
+ s_copy(srnamc_1.srnamt, "CTFTTR", (ftnlen)32, (ftnlen)
+ 6);
+ ctfttr_(cform, uplo, &n, &arf[1], &afac[1], &lda, &
+ info);
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ clacpy_(uplo, &n, &n, &afac[1], &lda, &asav[1], &lda);
+ cpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
+ c_work_cpot01__[1], result);
+ clacpy_(uplo, &n, &n, &asav[1], &lda, &afac[1], &lda);
+
+/* Form the inverse and compute the residual. */
+
+ if (n % 2 == 0) {
+ i__4 = n + 1;
+ i__5 = n / 2;
+ i__6 = n + 1;
+ i__7 = n + 1;
+ clacpy_("A", &i__4, &i__5, &arf[1], &i__6, &
+ arfinv[1], &i__7);
+ } else {
+ i__4 = (n + 1) / 2;
+ clacpy_("A", &n, &i__4, &arf[1], &n, &arfinv[1], &
+ n);
+ }
+
+ s_copy(srnamc_1.srnamt, "CPFTRI", (ftnlen)32, (ftnlen)
+ 6);
+ cpftri_(cform, uplo, &n, &arfinv[1], &info);
+
+ s_copy(srnamc_1.srnamt, "CTFTTR", (ftnlen)32, (ftnlen)
+ 6);
+ ctfttr_(cform, uplo, &n, &arfinv[1], &ainv[1], &lda, &
+ info);
+
+/* Check error code from CPFTRI. */
+
+ if (info != 0) {
+ alaerh_("CPO", "CPFTRI", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ cpot03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &
+ c_work_cpot03__[1], &lda, &s_work_cpot03__[1],
+ &rcondc, &result[1]);
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, &nrhs, &b[1], &lda, &
+ c_work_cpot02__[1], &lda);
+ cpot02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
+ c_work_cpot02__[1], &lda, &s_work_cpot02__[1],
+ &result[2]);
+
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+ nt = 4;
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, "CPF");
+ }
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, "CPFSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iit, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += nt;
+L100:
+ ;
+ }
+/* L110: */
+ }
+L120:
+ ;
+ }
+/* L980: */
+ }
+/* L130: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_("CPF", nout, &nfail, &nrun, &nerrs);
+
+
+ return 0;
+
+/* End of CDRVRFP */
+
+} /* cdrvrfp_ */
diff --git a/TESTING/LIN/cdrvsp.c b/TESTING/LIN/cdrvsp.c
new file mode 100644
index 0000000..e303c82
--- /dev/null
+++ b/TESTING/LIN/cdrvsp.c
@@ -0,0 +1,696 @@
+/* cdrvsp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static complex c_b61 = {0.f,0.f};
+
+/* Subroutine */ int cdrvsp_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, integer *nmax, complex *
+ a, complex *afac, complex *ainv, complex *b, complex *x, complex *
+ xact, complex *work, real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char facts[1*2] = "F" "N";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002,"
+ " ratio =\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5, i__6[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, k1, nb, in, kl, ku, nt, lda, npp;
+ char fact[1];
+ integer ioff, mode, imat, info;
+ char path[3], dist[1], uplo[1], type__[1];
+ integer nrun, ifact;
+ extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *);
+ integer nfail, iseed[4], nbmin;
+ real rcond;
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int cspt01_(char *, integer *, complex *, complex
+ *, integer *, complex *, integer *, real *, real *),
+ cppt05_(char *, integer *, integer *, complex *, complex *,
+ integer *, complex *, integer *, complex *, integer *, real *,
+ real *, real *);
+ real anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), cspt02_(char *, integer *, integer *,
+ complex *, complex *, integer *, complex *, integer *, real *,
+ real *);
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int cspsv_(char *, integer *, integer *, complex *
+, integer *, complex *, integer *, integer *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), aladhd_(integer *, char *),
+ alaerh_(char *, char *, integer *, integer *, char *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *);
+ real rcondc;
+ char packit[1];
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), clarhs_(char *, char
+ *, char *, char *, integer *, integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, integer *, integer *),
+ claset_(char *, integer *, integer *, complex *, complex *,
+ complex *, integer *);
+ extern doublereal clansp_(char *, char *, integer *, complex *, real *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, complex *, integer *, complex *, integer *), clatsp_(char *, integer *, complex *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), csptrf_(char *,
+ integer *, complex *, integer *, integer *), csptri_(
+ char *, integer *, complex *, integer *, complex *, integer *), cerrvx_(char *, integer *);
+ real result[6];
+ extern /* Subroutine */ int cspsvx_(char *, char *, integer *, integer *,
+ complex *, complex *, integer *, complex *, integer *, complex *,
+ integer *, real *, real *, real *, complex *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVSP tests the driver routines CSPSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AFAC (workspace) COMPLEX array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AINV (workspace) COMPLEX array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(2,NRHS)) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "SP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ npp = n * (n + 1) / 2;
+ *(unsigned char *)xtype = 'N';
+ nimat = 11;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L170;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L170;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ if (iuplo == 1) {
+ *(unsigned char *)uplo = 'U';
+ *(unsigned char *)packit = 'C';
+ } else {
+ *(unsigned char *)uplo = 'L';
+ *(unsigned char *)packit = 'R';
+ }
+
+ if (imat != 11) {
+
+/* Set up parameters with CLATB4 and generate a test */
+/* matrix with CLATMS. */
+
+ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
+ mode, &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ goto L160;
+ }
+
+/* For types 3-6, zero one or more rows and columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * izero / 2;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff += i__;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff = ioff + n - i__;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows and columns to zero. */
+
+ ioff = 0;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+/* L60: */
+ }
+ ioff += j;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows and columns to zero. */
+
+ ioff = 0;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+/* L80: */
+ }
+ ioff = ioff + n - j;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+ } else {
+
+/* Use a special block diagonal matrix to test alternate */
+/* code for the 2-by-2 blocks. */
+
+ clatsp_(uplo, &n, &a[1], iseed);
+ }
+
+ for (ifact = 1; ifact <= 2; ++ifact) {
+
+/* Do first for FACT = 'F', then for other values. */
+
+ *(unsigned char *)fact = *(unsigned char *)&facts[ifact -
+ 1];
+
+/* Compute the condition number for comparison with */
+/* the value returned by CSPSVX. */
+
+ if (zerot) {
+ if (ifact == 1) {
+ goto L150;
+ }
+ rcondc = 0.f;
+
+ } else if (ifact == 1) {
+
+/* Compute the 1-norm of A. */
+
+ anorm = clansp_("1", uplo, &n, &a[1], &rwork[1]);
+
+/* Factor the matrix A. */
+
+ ccopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ csptrf_(uplo, &n, &afac[1], &iwork[1], &info);
+
+/* Compute inv(A) and take its norm. */
+
+ ccopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
+ csptri_(uplo, &n, &ainv[1], &iwork[1], &work[1], &
+ info);
+ ainvnm = clansp_("1", uplo, &n, &ainv[1], &rwork[1]);
+
+/* Compute the 1-norm condition number of A. */
+
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondc = 1.f;
+ } else {
+ rcondc = 1.f / anorm / ainvnm;
+ }
+ }
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (ftnlen)6);
+ clarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, nrhs, &
+ a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
+ info);
+ *(unsigned char *)xtype = 'C';
+
+/* --- Test CSPSV --- */
+
+ if (ifact == 2) {
+ ccopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
+
+/* Factor the matrix and solve the system using CSPSV. */
+
+ s_copy(srnamc_1.srnamt, "CSPSV ", (ftnlen)32, (ftnlen)
+ 6);
+ cspsv_(uplo, &n, nrhs, &afac[1], &iwork[1], &x[1], &
+ lda, &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from CSPSV . */
+
+ if (info != k) {
+ alaerh_(path, "CSPSV ", &info, &k, uplo, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L120;
+ } else if (info != 0) {
+ goto L120;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ cspt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &ainv[1]
+, &lda, &rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ cspt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[1],
+ &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "CSPSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+L120:
+ ;
+ }
+
+/* --- Test CSPSVX --- */
+
+ if (ifact == 2 && npp > 0) {
+ claset_("Full", &npp, &c__1, &c_b61, &c_b61, &afac[1],
+ &npp);
+ }
+ claset_("Full", &n, nrhs, &c_b61, &c_b61, &x[1], &lda);
+
+/* Solve the system and compute the condition number and */
+/* error bounds using CSPSVX. */
+
+ s_copy(srnamc_1.srnamt, "CSPSVX", (ftnlen)32, (ftnlen)6);
+ cspsvx_(fact, uplo, &n, nrhs, &a[1], &afac[1], &iwork[1],
+ &b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &
+ rwork[*nrhs + 1], &work[1], &rwork[(*nrhs << 1) +
+ 1], &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L130:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L130;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L130;
+ }
+ }
+
+/* Check the error code from CSPSVX. */
+
+ if (info != k) {
+/* Writing concatenation */
+ i__6[0] = 1, a__1[0] = fact;
+ i__6[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__6, &c__2, (ftnlen)2);
+ alaerh_(path, "CSPSVX", &info, &k, ch__1, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L150;
+ }
+
+ if (info == 0) {
+ if (ifact >= 2) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ cspt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &
+ ainv[1], &lda, &rwork[(*nrhs << 1) + 1],
+ result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ cspt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[1],
+ &lda, &rwork[(*nrhs << 1) + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* Check the error bounds from iterative refinement. */
+
+ cppt05_(uplo, &n, nrhs, &a[1], &b[1], &lda, &x[1], &
+ lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs
+ + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from CSPSVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "CSPSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L140: */
+ }
+ nrun = nrun + 7 - k1;
+
+L150:
+ ;
+ }
+
+L160:
+ ;
+ }
+L170:
+ ;
+ }
+/* L180: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CDRVSP */
+
+} /* cdrvsp_ */
diff --git a/TESTING/LIN/cdrvsy.c b/TESTING/LIN/cdrvsy.c
new file mode 100644
index 0000000..f047f7f
--- /dev/null
+++ b/TESTING/LIN/cdrvsy.c
@@ -0,0 +1,695 @@
+/* cdrvsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static complex c_b49 = {0.f,0.f};
+
+/* Subroutine */ int cdrvsy_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, integer *nmax, complex *
+ a, complex *afac, complex *ainv, complex *b, complex *x, complex *
+ xact, complex *work, real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char facts[1*2] = "F" "N";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002,"
+ " ratio =\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5, i__6[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, k1, nb, in, kl, ku, nt, lda;
+ char fact[1];
+ integer ioff, mode, imat, info;
+ char path[3], dist[1], uplo[1], type__[1];
+ integer nrun, ifact;
+ extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *);
+ integer nfail, iseed[4], nbmin;
+ real rcond;
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int cpot05_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, complex *, integer *, complex
+ *, integer *, real *, real *, real *);
+ real anorm;
+ extern /* Subroutine */ int csyt01_(char *, integer *, complex *, integer
+ *, complex *, integer *, integer *, complex *, integer *, real *,
+ real *), csyt02_(char *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, real *,
+ real *);
+ integer iuplo, izero, nerrs, lwork;
+ logical zerot;
+ extern /* Subroutine */ int csysv_(char *, integer *, integer *, complex *
+, integer *, integer *, complex *, integer *, complex *, integer *
+, integer *);
+ char xtype[1];
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), aladhd_(integer *, char *),
+ alaerh_(char *, char *, integer *, integer *, char *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *);
+ real rcondc;
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), clarhs_(char *, char
+ *, char *, char *, integer *, integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, integer *, integer *),
+ claset_(char *, integer *, integer *, complex *, complex *,
+ complex *, integer *), alasvm_(char *, integer *, integer
+ *, integer *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, complex *, integer *, complex *, integer *);
+ real ainvnm;
+ extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
+ real *);
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), clatsy_(char *,
+ integer *, complex *, integer *, integer *), cerrvx_(
+ char *, integer *), csytrf_(char *, integer *, complex *,
+ integer *, integer *, complex *, integer *, integer *),
+ csytri_(char *, integer *, complex *, integer *, integer *,
+ complex *, integer *);
+ real result[6];
+ extern /* Subroutine */ int csysvx_(char *, char *, integer *, integer *,
+ complex *, integer *, complex *, integer *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *, real *, complex *
+, integer *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CDRVSY tests the driver routines CSYSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) COMPLEX array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
+
+/* WORK (workspace) COMPLEX array, dimension */
+/* (NMAX*max(2,NRHS)) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "SY", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+/* Computing MAX */
+ i__1 = *nmax << 1, i__2 = *nmax * *nrhs;
+ lwork = max(i__1,i__2);
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ cerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 11;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L170;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L170;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+ if (imat != 11) {
+
+/* Set up parameters with CLATB4 and generate a test */
+/* matrix with CLATMS. */
+
+ clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
+ mode, &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
+ clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from CLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "CLATMS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ goto L160;
+ }
+
+/* For types 3-6, zero one or more rows and columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * lda;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows to zero. */
+
+ ioff = 0;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+/* L60: */
+ }
+ ioff += lda;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows to zero. */
+
+ ioff = 0;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0.f, a[i__5].i = 0.f;
+/* L80: */
+ }
+ ioff += lda;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+ } else {
+
+/* IMAT = NTYPES: Use a special block diagonal matrix to */
+/* test alternate code for the 2-by-2 blocks. */
+
+ clatsy_(uplo, &n, &a[1], &lda, iseed);
+ }
+
+ for (ifact = 1; ifact <= 2; ++ifact) {
+
+/* Do first for FACT = 'F', then for other values. */
+
+ *(unsigned char *)fact = *(unsigned char *)&facts[ifact -
+ 1];
+
+/* Compute the condition number for comparison with */
+/* the value returned by CSYSVX. */
+
+ if (zerot) {
+ if (ifact == 1) {
+ goto L150;
+ }
+ rcondc = 0.f;
+
+ } else if (ifact == 1) {
+
+/* Compute the 1-norm of A. */
+
+ anorm = clansy_("1", uplo, &n, &a[1], &lda, &rwork[1]);
+
+/* Factor the matrix A. */
+
+ clacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ csytrf_(uplo, &n, &afac[1], &lda, &iwork[1], &work[1],
+ &lwork, &info);
+
+/* Compute inv(A) and take its norm. */
+
+ clacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
+ csytri_(uplo, &n, &ainv[1], &lda, &iwork[1], &work[1],
+ &info);
+ ainvnm = clansy_("1", uplo, &n, &ainv[1], &lda, &
+ rwork[1]);
+
+/* Compute the 1-norm condition number of A. */
+
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondc = 1.f;
+ } else {
+ rcondc = 1.f / anorm / ainvnm;
+ }
+ }
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (ftnlen)6);
+ clarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, nrhs, &
+ a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
+ info);
+ *(unsigned char *)xtype = 'C';
+
+/* --- Test CSYSV --- */
+
+ if (ifact == 2) {
+ clacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
+
+/* Factor the matrix and solve the system using CSYSV. */
+
+ s_copy(srnamc_1.srnamt, "CSYSV ", (ftnlen)32, (ftnlen)
+ 6);
+ csysv_(uplo, &n, nrhs, &afac[1], &lda, &iwork[1], &x[
+ 1], &lda, &work[1], &lwork, &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from CSYSV . */
+
+ if (info != k) {
+ alaerh_(path, "CSYSV ", &info, &k, uplo, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L120;
+ } else if (info != 0) {
+ goto L120;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ csyt01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &iwork[
+ 1], &ainv[1], &lda, &rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ csyt02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda, &
+ work[1], &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "CSYSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+L120:
+ ;
+ }
+
+/* --- Test CSYSVX --- */
+
+ if (ifact == 2) {
+ claset_(uplo, &n, &n, &c_b49, &c_b49, &afac[1], &lda);
+ }
+ claset_("Full", &n, nrhs, &c_b49, &c_b49, &x[1], &lda);
+
+/* Solve the system and compute the condition number and */
+/* error bounds using CSYSVX. */
+
+ s_copy(srnamc_1.srnamt, "CSYSVX", (ftnlen)32, (ftnlen)6);
+ csysvx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1], &lda,
+ &iwork[1], &b[1], &lda, &x[1], &lda, &rcond, &
+ rwork[1], &rwork[*nrhs + 1], &work[1], &lwork, &
+ rwork[(*nrhs << 1) + 1], &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L130:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L130;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L130;
+ }
+ }
+
+/* Check the error code from CSYSVX. */
+
+ if (info != k) {
+/* Writing concatenation */
+ i__6[0] = 1, a__1[0] = fact;
+ i__6[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__6, &c__2, (ftnlen)2);
+ alaerh_(path, "CSYSVX", &info, &k, ch__1, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L150;
+ }
+
+ if (info == 0) {
+ if (ifact >= 2) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ csyt01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &ainv[1], &lda, &rwork[(*nrhs <<
+ 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ csyt02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda, &
+ work[1], &lda, &rwork[(*nrhs << 1) + 1], &
+ result[1]);
+
+/* Check solution from generated exact solution. */
+
+ cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* Check the error bounds from iterative refinement. */
+
+ cpot05_(uplo, &n, nrhs, &a[1], &lda, &b[1], &lda, &x[
+ 1], &lda, &xact[1], &lda, &rwork[1], &rwork[*
+ nrhs + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from CSYSVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "CSYSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L140: */
+ }
+ nrun = nrun + 7 - k1;
+
+L150:
+ ;
+ }
+
+L160:
+ ;
+ }
+L170:
+ ;
+ }
+/* L180: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of CDRVSY */
+
+} /* cdrvsy_ */
diff --git a/TESTING/LIN/cebchvxx.c b/TESTING/LIN/cebchvxx.c
new file mode 100644
index 0000000..29c193b
--- /dev/null
+++ b/TESTING/LIN/cebchvxx.c
@@ -0,0 +1,675 @@
+/* cebchvxx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__6 = 6;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c__5 = 5;
+static integer c__7 = 7;
+static integer c__8 = 8;
+
+/* Subroutine */ int cebchvxx_(real *thresh, char *path)
+{
+ /* Format strings */
+ static char fmt_8000[] = "(\002 C\002,a2,\002SVXX: N =\002,i2,\002, INFO"
+ " = \002,i3,\002, ORCOND = \002,g12.5,\002, real RCOND = \002,g12"
+ ".5)";
+ static char fmt_9996[] = "(3x,i2,\002: Normwise guaranteed forward erro"
+ "r\002,/5x,\002Guaranteed case: if norm ( abs( Xc - Xt )\002,\002"
+ " / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ), then\002,/5x"
+ ",\002ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS\002)"
+ ;
+ static char fmt_9995[] = "(3x,i2,\002: Componentwise guaranteed forward "
+ "error\002)";
+ static char fmt_9994[] = "(3x,i2,\002: Backwards error\002)";
+ static char fmt_9993[] = "(3x,i2,\002: Reciprocal condition number\002)";
+ static char fmt_9992[] = "(3x,i2,\002: Reciprocal normwise condition num"
+ "ber\002)";
+ static char fmt_9991[] = "(3x,i2,\002: Raw normwise error estimate\002)";
+ static char fmt_9990[] = "(3x,i2,\002: Reciprocal componentwise conditio"
+ "n number\002)";
+ static char fmt_9989[] = "(3x,i2,\002: Raw componentwise error estimat"
+ "e\002)";
+ static char fmt_9999[] = "(\002 C\002,a2,\002SVXX: N =\002,i2,\002, RHS "
+ "= \002,i2,\002, NWISE GUAR. = \002,a,\002, CWISE GUAR. = \002,a"
+ ",\002 test(\002,i1,\002) =\002,g12.5)";
+ static char fmt_9998[] = "(\002 C\002,a2,\002SVXX: \002,i6,\002 out of"
+ " \002,i6,\002 tests failed to pass the threshold\002)";
+ static char fmt_9997[] = "(\002 C\002,a2,\002SVXX passed the tests of er"
+ "ror bounds\002)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1, r__2, r__3, r__4, r__5;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double r_imag(complex *);
+ void c_div(complex *, complex *, complex *);
+ integer s_wsle(cilist *), e_wsle(void);
+
+ /* Local variables */
+ extern /* Subroutine */ int csysvxx_(char *, char *, integer *, integer *,
+ complex *, integer *, complex *, integer *, integer *, char *,
+ real *, complex *, integer *, complex *, integer *, real *, real *
+, real *, integer *, real *, real *, integer *, real *, complex *,
+ real *, integer *);
+ real errbnd_c__[18], errbnd_n__[18];
+ complex a[36] /* was [6][6] */, b[36] /* was [6][6] */;
+ real c__[6];
+ integer i__, j, k;
+ real m;
+ integer n;
+ real r__[6], s[6];
+ complex x[36] /* was [6][6] */;
+ real cwise_bnd__;
+ char c2[2];
+ real nwise_bnd__, cwise_err__, nwise_err__, errthresh;
+ complex ab[66] /* was [11][6] */, af[36] /* was [6][6] */;
+ integer kl, ku;
+ real condthresh;
+ complex afb[96] /* was [16][6] */;
+ integer lda;
+ real eps, cwise_rcond__, nwise_rcond__;
+ integer n_aux_tests__, ldab;
+ real diff[36] /* was [6][6] */;
+ char fact[1];
+ real berr[6];
+ integer info, ipiv[6], nrhs;
+ real rinv[6];
+ char uplo[1];
+ complex work[90];
+ real sumr;
+ integer ldafb;
+ real ccond;
+ integer nfail;
+ char cguar[3];
+ real ncond;
+ char equed[1];
+ real rcond;
+ complex acopy[36] /* was [6][6] */;
+ char nguar[3], trans[1];
+ real rnorm, normt, sumri, rwork[18];
+ logical printed_guide__;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), dlacpy_(char *,
+ integer *, integer *, complex *, integer *, complex *, integer *);
+ complex abcopy[66] /* was [11][6] */;
+ extern logical lsamen_(integer *, char *, char *);
+ real params[2], orcond, rinorm, tstrat[6], rpvgrw;
+ extern /* Subroutine */ int clahilb_(integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, char *);
+ complex invhilb[36] /* was [6][6] */;
+ real normdif;
+ extern /* Subroutine */ int cgbsvxx_(char *, char *, integer *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ integer *, char *, real *, real *, complex *, integer *, complex
+ *, integer *, real *, real *, real *, integer *, real *, real *,
+ integer *, real *, complex *, real *, integer *), cgesvxx_(char *, char *, integer *, integer *, complex *,
+ integer *, complex *, integer *, integer *, char *, real *, real
+ *, complex *, integer *, complex *, integer *, real *, real *,
+ real *, integer *, real *, real *, integer *, real *, complex *,
+ real *, integer *), chesvxx_(char *, char
+ *, integer *, integer *, complex *, integer *, complex *, integer
+ *, integer *, char *, real *, complex *, integer *, complex *,
+ integer *, real *, real *, real *, integer *, real *, real *,
+ integer *, real *, complex *, real *, integer *), cposvxx_(char *, char *, integer *, integer *, complex *,
+ integer *, complex *, integer *, char *, real *, complex *,
+ integer *, complex *, integer *, real *, real *, real *, integer *
+, real *, real *, integer *, real *, complex *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 6, 0, fmt_8000, 0 };
+ static cilist io___66 = { 0, 6, 0, 0, 0 };
+ static cilist io___67 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___68 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___69 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___70 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___71 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___72 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___73 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___74 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___75 = { 0, 6, 0, 0, 0 };
+ static cilist io___76 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___77 = { 0, 6, 0, 0, 0 };
+ static cilist io___78 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___79 = { 0, 6, 0, fmt_9997, 0 };
+
+
+/* .. Scalar Arguments .. */
+
+/* Purpose */
+/* ====== */
+
+/* CEBCHVXX will run CGESVXX on a series of Hilbert matrices and then */
+/* compare the error bounds returned by CGESVXX to see if the returned */
+/* answer indeed falls within those bounds. */
+
+/* Eight test ratios will be computed. The tests will pass if they are .LT. */
+/* THRESH. There are two cases that are determined by 1 / (SQRT( N ) * EPS). */
+/* If that value is .LE. to the component wise reciprocal condition number, */
+/* it uses the guaranteed case, other wise it uses the unguaranteed case. */
+
+/* Test ratios: */
+/* Let Xc be X_computed and Xt be X_truth. */
+/* The norm used is the infinity norm. */
+/* Let A be the guaranteed case and B be the unguaranteed case. */
+
+/* 1. Normwise guaranteed forward error bound. */
+/* A: norm ( abs( Xc - Xt ) / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ) and */
+/* ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N),10) * EPS. */
+/* If these conditions are met, the test ratio is set to be */
+/* ERRBND( *, nwise_i, bnd_i ) / MAX(SQRT(N), 10). Otherwise it is 1/EPS. */
+/* B: For this case, CGESVXX should just return 1. If it is less than */
+/* one, treat it the same as in 1A. Otherwise it fails. (Set test */
+/* ratio to ERRBND( *, nwise_i, bnd_i ) * THRESH?) */
+
+/* 2. Componentwise guaranteed forward error bound. */
+/* A: norm ( abs( Xc(j) - Xt(j) ) ) / norm (Xt(j)) .LE. ERRBND( *, cwise_i, bnd_i ) */
+/* for all j .AND. ERRBND( *, cwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS. */
+/* If these conditions are met, the test ratio is set to be */
+/* ERRBND( *, cwise_i, bnd_i ) / MAX(SQRT(N), 10). Otherwise it is 1/EPS. */
+/* B: Same as normwise test ratio. */
+
+/* 3. Backwards error. */
+/* A: The test ratio is set to BERR/EPS. */
+/* B: Same test ratio. */
+
+/* 4. Reciprocal condition number. */
+/* A: A condition number is computed with Xt and compared with the one */
+/* returned from CGESVXX. Let RCONDc be the RCOND returned by CGESVXX */
+/* and RCONDt be the RCOND from the truth value. Test ratio is set to */
+/* MAX(RCONDc/RCONDt, RCONDt/RCONDc). */
+/* B: Test ratio is set to 1 / (EPS * RCONDc). */
+
+/* 5. Reciprocal normwise condition number. */
+/* A: The test ratio is set to */
+/* MAX(ERRBND( *, nwise_i, cond_i ) / NCOND, NCOND / ERRBND( *, nwise_i, cond_i )). */
+/* B: Test ratio is set to 1 / (EPS * ERRBND( *, nwise_i, cond_i )). */
+
+/* 6. Reciprocal componentwise condition number. */
+/* A: Test ratio is set to */
+/* MAX(ERRBND( *, cwise_i, cond_i ) / CCOND, CCOND / ERRBND( *, cwise_i, cond_i )). */
+/* B: Test ratio is set to 1 / (EPS * ERRBND( *, cwise_i, cond_i )). */
+
+/* .. Parameters .. */
+/* NMAX is determined by the largest number in the inverse of the hilbert */
+/* matrix. Precision is exhausted when the largest entry in it is greater */
+/* than 2 to the power of the number of bits in the fraction of the data */
+/* type used plus one, which is 24 for single precision. */
+/* NMAX should be 6 for single and 11 for double. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function Definitions .. */
+/* .. Parameters .. */
+/* Create the loop to test out the Hilbert matrices */
+ *(unsigned char *)fact = 'E';
+ *(unsigned char *)uplo = 'U';
+ *(unsigned char *)trans = 'N';
+ *(unsigned char *)equed = 'N';
+ eps = slamch_("Epsilon");
+ nfail = 0;
+ n_aux_tests__ = 0;
+ lda = 6;
+ ldab = 11;
+ ldafb = 16;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+/* Main loop to test the different Hilbert Matrices. */
+ printed_guide__ = FALSE_;
+ for (n = 1; n <= 6; ++n) {
+ params[0] = -1.f;
+ params[1] = -1.f;
+ kl = n - 1;
+ ku = n - 1;
+ nrhs = n;
+/* Computing MAX */
+ r__1 = sqrt((real) n);
+ m = dmax(r__1,10.f);
+/* Generate the Hilbert matrix, its inverse, and the */
+/* right hand side, all scaled by the LCM(1,..,2N-1). */
+ clahilb_(&n, &n, a, &lda, invhilb, &lda, b, &lda, work, &info, path);
+/* Copy A into ACOPY. */
+ clacpy_("ALL", &n, &n, a, &c__6, acopy, &c__6);
+/* Store A in band format for GB tests */
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = kl + ku + 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 11 - 12;
+ ab[i__3].r = 0.f, ab[i__3].i = 0.f;
+ }
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = 1, i__3 = j - ku;
+/* Computing MIN */
+ i__5 = n, i__6 = j + kl;
+ i__4 = min(i__5,i__6);
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ i__2 = ku + 1 + i__ - j + j * 11 - 12;
+ i__3 = i__ + j * 6 - 7;
+ ab[i__2].r = a[i__3].r, ab[i__2].i = a[i__3].i;
+ }
+ }
+/* Copy AB into ABCOPY. */
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = kl + ku + 1;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__2 = i__ + j * 11 - 12;
+ abcopy[i__2].r = 0.f, abcopy[i__2].i = 0.f;
+ }
+ }
+ i__1 = kl + ku + 1;
+ dlacpy_("ALL", &i__1, &n, ab, &ldab, abcopy, &ldab);
+/* Call C**SVXX with default PARAMS and N_ERR_BND = 3. */
+ if (lsamen_(&c__2, c2, "SY")) {
+ csysvxx_(fact, uplo, &n, &nrhs, acopy, &lda, af, &lda, ipiv,
+ equed, s, b, &lda, x, &lda, &orcond, &rpvgrw, berr, &c__3,
+ errbnd_n__, errbnd_c__, &c__2, params, work, rwork, &
+ info);
+ } else if (lsamen_(&c__2, c2, "PO")) {
+ cposvxx_(fact, uplo, &n, &nrhs, acopy, &lda, af, &lda, equed, s,
+ b, &lda, x, &lda, &orcond, &rpvgrw, berr, &c__3,
+ errbnd_n__, errbnd_c__, &c__2, params, work, rwork, &info);
+ } else if (lsamen_(&c__2, c2, "HE")) {
+ chesvxx_(fact, uplo, &n, &nrhs, acopy, &lda, af, &lda, ipiv,
+ equed, s, b, &lda, x, &lda, &orcond, &rpvgrw, berr, &c__3,
+ errbnd_n__, errbnd_c__, &c__2, params, work, rwork, &
+ info);
+ } else if (lsamen_(&c__2, c2, "GB")) {
+ cgbsvxx_(fact, trans, &n, &kl, &ku, &nrhs, abcopy, &ldab, afb, &
+ ldafb, ipiv, equed, r__, c__, b, &lda, x, &lda, &orcond, &
+ rpvgrw, berr, &c__3, errbnd_n__, errbnd_c__, &c__2,
+ params, work, rwork, &info);
+ } else {
+ cgesvxx_(fact, trans, &n, &nrhs, acopy, &lda, af, &lda, ipiv,
+ equed, r__, c__, b, &lda, x, &lda, &orcond, &rpvgrw, berr,
+ &c__3, errbnd_n__, errbnd_c__, &c__2, params, work,
+ rwork, &info);
+ }
+ ++n_aux_tests__;
+ if (orcond < eps) {
+/* Either factorization failed or the matrix is flagged, and 1 <= */
+/* INFO <= N+1. We don't decide based on rcond anymore. */
+/* IF (INFO .EQ. 0 .OR. INFO .GT. N+1) THEN */
+/* NFAIL = NFAIL + 1 */
+/* WRITE (*, FMT=8000) N, INFO, ORCOND, RCOND */
+/* END IF */
+ } else {
+/* Either everything succeeded (INFO == 0) or some solution failed */
+/* to converge (INFO > N+1). */
+ if (info > 0 && info <= n + 1) {
+ ++nfail;
+ s_wsfe(&io___42);
+ do_fio(&c__1, c2, (ftnlen)2);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&orcond, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&rcond, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ }
+/* Calculating the difference between C**SVXX's X and the true X. */
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__4 = nrhs;
+ for (j = 1; j <= i__4; ++j) {
+ i__2 = i__ + j * 6 - 7;
+ i__3 = i__ + j * 6 - 7;
+ i__5 = i__ + j * 6 - 7;
+ q__1.r = x[i__3].r - invhilb[i__5].r, q__1.i = x[i__3].i -
+ invhilb[i__5].i;
+ diff[i__2] = q__1.r;
+ }
+ }
+/* Calculating the RCOND */
+ rnorm = 0.f;
+ rinorm = 0.f;
+ if (lsamen_(&c__2, c2, "PO") || lsamen_(&c__2,
+ c2, "SY") || lsamen_(&c__2, c2, "HE")) {
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sumr = 0.f;
+ sumri = 0.f;
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__2 = i__ + j * 6 - 7;
+ sumr += s[i__ - 1] * ((r__1 = a[i__2].r, dabs(r__1)) + (
+ r__2 = r_imag(&a[i__ + j * 6 - 7]), dabs(r__2))) *
+ s[j - 1];
+ i__2 = i__ + j * 6 - 7;
+ sumri += ((r__1 = invhilb[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&invhilb[i__ + j * 6 - 7]), dabs(r__2))) /
+ (s[j - 1] * s[i__ - 1]);
+ }
+ rnorm = dmax(rnorm,sumr);
+ rinorm = dmax(rinorm,sumri);
+ }
+ } else if (lsamen_(&c__2, c2, "GE") || lsamen_(&
+ c__2, c2, "GB")) {
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sumr = 0.f;
+ sumri = 0.f;
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__2 = i__ + j * 6 - 7;
+ sumr += r__[i__ - 1] * ((r__1 = a[i__2].r, dabs(r__1)) + (
+ r__2 = r_imag(&a[i__ + j * 6 - 7]), dabs(r__2))) *
+ c__[j - 1];
+ i__2 = i__ + j * 6 - 7;
+ sumri += ((r__1 = invhilb[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&invhilb[i__ + j * 6 - 7]), dabs(r__2))) /
+ (r__[j - 1] * c__[i__ - 1]);
+ }
+ rnorm = dmax(rnorm,sumr);
+ rinorm = dmax(rinorm,sumri);
+ }
+ }
+ rnorm /= (r__1 = a[0].r, dabs(r__1)) + (r__2 = r_imag(a), dabs(r__2));
+ rcond = 1.f / (rnorm * rinorm);
+/* Calculating the R for normwise rcond. */
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ rinv[i__ - 1] = 0.f;
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__2 = i__ + j * 6 - 7;
+ rinv[i__ - 1] += (r__1 = a[i__2].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * 6 - 7]), dabs(r__2));
+ }
+ }
+/* Calculating the Normwise rcond. */
+ rinorm = 0.f;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sumri = 0.f;
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__2 = i__ + j * 6 - 7;
+ i__3 = j - 1;
+ q__2.r = rinv[i__3] * invhilb[i__2].r, q__2.i = rinv[i__3] *
+ invhilb[i__2].i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ sumri += (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
+ dabs(r__2));
+ }
+ rinorm = dmax(rinorm,sumri);
+ }
+/* invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm */
+/* by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix) */
+ ncond = ((r__1 = a[0].r, dabs(r__1)) + (r__2 = r_imag(a), dabs(r__2)))
+ / rinorm;
+ condthresh = m * eps;
+ errthresh = m * eps;
+ i__1 = nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ normt = 0.f;
+ normdif = 0.f;
+ cwise_err__ = 0.f;
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+/* Computing MAX */
+ i__2 = i__ + k * 6 - 7;
+ r__3 = (r__1 = invhilb[i__2].r, dabs(r__1)) + (r__2 = r_imag(&
+ invhilb[i__ + k * 6 - 7]), dabs(r__2));
+ normt = dmax(r__3,normt);
+ i__2 = i__ + k * 6 - 7;
+ i__3 = i__ + k * 6 - 7;
+ q__2.r = x[i__2].r - invhilb[i__3].r, q__2.i = x[i__2].i -
+ invhilb[i__3].i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+/* Computing MAX */
+ r__3 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1),
+ dabs(r__2));
+ normdif = dmax(r__3,normdif);
+ i__2 = i__ + k * 6 - 7;
+ if (invhilb[i__2].r != 0.f || invhilb[i__2].i != 0.f) {
+ i__2 = i__ + k * 6 - 7;
+ i__3 = i__ + k * 6 - 7;
+ q__2.r = x[i__2].r - invhilb[i__3].r, q__2.i = x[i__2].i
+ - invhilb[i__3].i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+/* Computing MAX */
+ i__5 = i__ + k * 6 - 7;
+ r__5 = ((r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
+ q__1), dabs(r__2))) / ((r__3 = invhilb[i__5].r,
+ dabs(r__3)) + (r__4 = r_imag(&invhilb[i__ + k * 6
+ - 7]), dabs(r__4)));
+ cwise_err__ = dmax(r__5,cwise_err__);
+ } else /* if(complicated condition) */ {
+ i__2 = i__ + k * 6 - 7;
+ if (x[i__2].r != 0.f || x[i__2].i != 0.f) {
+ cwise_err__ = slamch_("OVERFLOW");
+ }
+ }
+ }
+ if (normt != 0.f) {
+ nwise_err__ = normdif / normt;
+ } else if (normdif != 0.f) {
+ nwise_err__ = slamch_("OVERFLOW");
+ } else {
+ nwise_err__ = 0.f;
+ }
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ rinv[i__ - 1] = 0.f;
+ }
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 6 - 7;
+ i__5 = j + k * 6 - 7;
+ q__2.r = a[i__3].r * invhilb[i__5].r - a[i__3].i *
+ invhilb[i__5].i, q__2.i = a[i__3].r * invhilb[
+ i__5].i + a[i__3].i * invhilb[i__5].r;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ rinv[i__ - 1] += (r__1 = q__1.r, dabs(r__1)) + (r__2 =
+ r_imag(&q__1), dabs(r__2));
+ }
+ }
+ rinorm = 0.f;
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ sumri = 0.f;
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * 6 - 7;
+ i__5 = j - 1;
+ q__3.r = rinv[i__5] * invhilb[i__3].r, q__3.i = rinv[i__5]
+ * invhilb[i__3].i;
+ c_div(&q__2, &q__3, &invhilb[i__ + k * 6 - 7]);
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ sumri += (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
+ q__1), dabs(r__2));
+ }
+ rinorm = dmax(rinorm,sumri);
+ }
+/* invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm */
+/* by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix) */
+ ccond = ((r__1 = a[0].r, dabs(r__1)) + (r__2 = r_imag(a), dabs(
+ r__2))) / rinorm;
+/* Forward error bound tests */
+ nwise_bnd__ = errbnd_n__[k + nrhs - 1];
+ cwise_bnd__ = errbnd_c__[k + nrhs - 1];
+ nwise_rcond__ = errbnd_n__[k + (nrhs << 1) - 1];
+ cwise_rcond__ = errbnd_c__[k + (nrhs << 1) - 1];
+/* write (*,*) 'nwise : ', n, k, ncond, nwise_rcond, */
+/* $ condthresh, ncond.ge.condthresh */
+/* write (*,*) 'nwise2: ', k, nwise_bnd, nwise_err, errthresh */
+ if (ncond >= condthresh) {
+ s_copy(nguar, "YES", (ftnlen)3, (ftnlen)3);
+ if (nwise_bnd__ > errthresh) {
+ tstrat[0] = 1 / (eps * 2.f);
+ } else {
+ if (nwise_bnd__ != 0.f) {
+ tstrat[0] = nwise_err__ / nwise_bnd__;
+ } else if (nwise_err__ != 0.f) {
+ tstrat[0] = 1 / (eps * 16.f);
+ } else {
+ tstrat[0] = 0.f;
+ }
+ if (tstrat[0] > 1.f) {
+ tstrat[0] = 1 / (eps * 4.f);
+ }
+ }
+ } else {
+ s_copy(nguar, "NO", (ftnlen)3, (ftnlen)2);
+ if (nwise_bnd__ < 1.f) {
+ tstrat[0] = 1 / (eps * 8.f);
+ } else {
+ tstrat[0] = 1.f;
+ }
+ }
+/* write (*,*) 'cwise : ', n, k, ccond, cwise_rcond, */
+/* $ condthresh, ccond.ge.condthresh */
+/* write (*,*) 'cwise2: ', k, cwise_bnd, cwise_err, errthresh */
+ if (ccond >= condthresh) {
+ s_copy(cguar, "YES", (ftnlen)3, (ftnlen)3);
+ if (cwise_bnd__ > errthresh) {
+ tstrat[1] = 1 / (eps * 2.f);
+ } else {
+ if (cwise_bnd__ != 0.f) {
+ tstrat[1] = cwise_err__ / cwise_bnd__;
+ } else if (cwise_err__ != 0.f) {
+ tstrat[1] = 1 / (eps * 16.f);
+ } else {
+ tstrat[1] = 0.f;
+ }
+ if (tstrat[1] > 1.f) {
+ tstrat[1] = 1 / (eps * 4.f);
+ }
+ }
+ } else {
+ s_copy(cguar, "NO", (ftnlen)3, (ftnlen)2);
+ if (cwise_bnd__ < 1.f) {
+ tstrat[1] = 1 / (eps * 8.f);
+ } else {
+ tstrat[1] = 1.f;
+ }
+ }
+/* Backwards error test */
+ tstrat[2] = berr[k - 1] / eps;
+/* Condition number tests */
+ tstrat[3] = rcond / orcond;
+ if (rcond >= condthresh && tstrat[3] < 1.f) {
+ tstrat[3] = 1.f / tstrat[3];
+ }
+ tstrat[4] = ncond / nwise_rcond__;
+ if (ncond >= condthresh && tstrat[4] < 1.f) {
+ tstrat[4] = 1.f / tstrat[4];
+ }
+ tstrat[5] = ccond / nwise_rcond__;
+ if (ccond >= condthresh && tstrat[5] < 1.f) {
+ tstrat[5] = 1.f / tstrat[5];
+ }
+ for (i__ = 1; i__ <= 6; ++i__) {
+ if (tstrat[i__ - 1] > *thresh) {
+ if (! printed_guide__) {
+ s_wsle(&io___66);
+ e_wsle();
+ s_wsfe(&io___67);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___68);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___69);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___70);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___71);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___72);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___73);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___74);
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsle(&io___75);
+ e_wsle();
+ printed_guide__ = TRUE_;
+ }
+ s_wsfe(&io___76);
+ do_fio(&c__1, c2, (ftnlen)2);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, nguar, (ftnlen)3);
+ do_fio(&c__1, cguar, (ftnlen)3);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&tstrat[i__ - 1], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+ }
+ }
+/* $$$ WRITE(*,*) */
+/* $$$ WRITE(*,*) 'Normwise Error Bounds' */
+/* $$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,nwise_i,bnd_i) */
+/* $$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,nwise_i,cond_i) */
+/* $$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,nwise_i,rawbnd_i) */
+/* $$$ WRITE(*,*) */
+/* $$$ WRITE(*,*) 'Componentwise Error Bounds' */
+/* $$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,cwise_i,bnd_i) */
+/* $$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,cwise_i,cond_i) */
+/* $$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,cwise_i,rawbnd_i) */
+/* $$$ print *, 'Info: ', info */
+/* $$$ WRITE(*,*) */
+/* WRITE(*,*) 'TSTRAT: ',TSTRAT */
+ }
+ s_wsle(&io___77);
+ e_wsle();
+ if (nfail > 0) {
+ s_wsfe(&io___78);
+ do_fio(&c__1, c2, (ftnlen)2);
+ do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
+ i__1 = n * 6 + n_aux_tests__;
+ do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ s_wsfe(&io___79);
+ do_fio(&c__1, c2, (ftnlen)2);
+ e_wsfe();
+ }
+/* Test ratios. */
+ return 0;
+} /* cebchvxx_ */
diff --git a/TESTING/LIN/cerrge.c b/TESTING/LIN/cerrge.c
new file mode 100644
index 0000000..8772957
--- /dev/null
+++ b/TESTING/LIN/cerrge.c
@@ -0,0 +1,532 @@
+/* cerrge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__4 = 4;
+
+/* Subroutine */ int cerrge_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ complex a[16] /* was [4][4] */, b[4];
+ integer i__, j;
+ real r__[4];
+ complex w[8], x[4];
+ char c2[2];
+ real r1[4], r2[4];
+ complex af[16] /* was [4][4] */;
+ integer ip[4], info;
+ real anrm, ccond, rcond;
+ extern /* Subroutine */ int cgbtf2_(integer *, integer *, integer *,
+ integer *, complex *, integer *, integer *, integer *), cgetf2_(
+ integer *, integer *, complex *, integer *, integer *, integer *),
+ cgbcon_(char *, integer *, integer *, integer *, complex *,
+ integer *, integer *, real *, real *, complex *, real *, integer *
+), cgecon_(char *, integer *, complex *, integer *, real *
+, real *, complex *, real *, integer *), alaesm_(char *,
+ logical *, integer *), cgbequ_(integer *, integer *,
+ integer *, integer *, complex *, integer *, real *, real *, real *
+, real *, real *, integer *), cgbrfs_(char *, integer *, integer *
+, integer *, integer *, complex *, integer *, complex *, integer *
+, integer *, complex *, integer *, complex *, integer *, real *,
+ real *, complex *, real *, integer *), cgbtrf_(integer *,
+ integer *, integer *, integer *, complex *, integer *, integer *,
+ integer *), cgeequ_(integer *, integer *, complex *, integer *,
+ real *, real *, real *, real *, real *, integer *), cgerfs_(char *
+, integer *, integer *, complex *, integer *, complex *, integer *
+, integer *, complex *, integer *, complex *, integer *, real *,
+ real *, complex *, real *, integer *), cgetrf_(integer *,
+ integer *, complex *, integer *, integer *, integer *), cgetri_(
+ integer *, complex *, integer *, integer *, complex *, integer *,
+ integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int cgbtrs_(char *, integer *, integer *, integer
+ *, integer *, complex *, integer *, integer *, complex *, integer
+ *, integer *), chkxer_(char *, integer *, integer *,
+ logical *, logical *), cgetrs_(char *, integer *, integer
+ *, complex *, integer *, integer *, complex *, integer *, integer
+ *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERRGE tests the error exits for the COMPLEX routines */
+/* for general matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ r__1 = 1.f / (real) (i__ + j);
+ r__2 = -1.f / (real) (i__ + j);
+ q__1.r = r__1, q__1.i = r__2;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = i__ + (j << 2) - 5;
+ r__1 = 1.f / (real) (i__ + j);
+ r__2 = -1.f / (real) (i__ + j);
+ q__1.r = r__1, q__1.i = r__2;
+ af[i__1].r = q__1.r, af[i__1].i = q__1.i;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0.f, b[i__1].i = 0.f;
+ r1[j - 1] = 0.f;
+ r2[j - 1] = 0.f;
+ i__1 = j - 1;
+ w[i__1].r = 0.f, w[i__1].i = 0.f;
+ i__1 = j - 1;
+ x[i__1].r = 0.f, x[i__1].i = 0.f;
+ ip[j - 1] = j;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+/* Test error exits of the routines that use the LU decomposition */
+/* of a general matrix. */
+
+ if (lsamen_(&c__2, c2, "GE")) {
+
+/* CGETRF */
+
+ s_copy(srnamc_1.srnamt, "CGETRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgetrf_(&c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("CGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgetrf_(&c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("CGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgetrf_(&c__2, &c__1, a, &c__1, ip, &info);
+ chkxer_("CGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGETF2 */
+
+ s_copy(srnamc_1.srnamt, "CGETF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgetf2_(&c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("CGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgetf2_(&c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("CGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgetf2_(&c__2, &c__1, a, &c__1, ip, &info);
+ chkxer_("CGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGETRI */
+
+ s_copy(srnamc_1.srnamt, "CGETRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgetri_(&c_n1, a, &c__1, ip, w, &c__1, &info);
+ chkxer_("CGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgetri_(&c__2, a, &c__1, ip, w, &c__2, &info);
+ chkxer_("CGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cgetri_(&c__2, a, &c__2, ip, w, &c__1, &info);
+ chkxer_("CGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGETRS */
+
+ s_copy(srnamc_1.srnamt, "CGETRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgetrs_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("CGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgetrs_("N", &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("CGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgetrs_("N", &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("CGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgetrs_("N", &c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
+ chkxer_("CGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cgetrs_("N", &c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
+ chkxer_("CGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGERFS */
+
+ s_copy(srnamc_1.srnamt, "CGERFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgerfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgerfs_("N", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgerfs_("N", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgerfs_("N", &c__2, &c__1, a, &c__1, af, &c__2, ip, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("CGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__1, ip, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("CGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__1, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("CGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__2, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGECON */
+
+ s_copy(srnamc_1.srnamt, "CGECON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgecon_("/", &c__0, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("CGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgecon_("1", &c_n1, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("CGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgecon_("1", &c__2, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("CGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGEEQU */
+
+ s_copy(srnamc_1.srnamt, "CGEEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgeequ_(&c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("CGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgeequ_(&c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("CGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgeequ_(&c__2, &c__2, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("CGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Test error exits of the routines that use the LU decomposition */
+/* of a general band matrix. */
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* CGBTRF */
+
+ s_copy(srnamc_1.srnamt, "CGBTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgbtrf_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("CGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgbtrf_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("CGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgbtrf_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("CGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgbtrf_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("CGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cgbtrf_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
+ chkxer_("CGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGBTF2 */
+
+ s_copy(srnamc_1.srnamt, "CGBTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgbtf2_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("CGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgbtf2_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("CGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgbtf2_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("CGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgbtf2_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("CGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cgbtf2_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
+ chkxer_("CGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGBTRS */
+
+ s_copy(srnamc_1.srnamt, "CGBTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgbtrs_("/", &c__0, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("CGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgbtrs_("N", &c_n1, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("CGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgbtrs_("N", &c__1, &c_n1, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("CGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgbtrs_("N", &c__1, &c__0, &c_n1, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("CGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgbtrs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("CGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cgbtrs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, ip, b, &c__2, &
+ info);
+ chkxer_("CGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cgbtrs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("CGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGBRFS */
+
+ s_copy(srnamc_1.srnamt, "CGBRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgbrfs_("/", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgbrfs_("N", &c_n1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgbrfs_("N", &c__1, &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgbrfs_("N", &c__1, &c__0, &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgbrfs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__2, af, &c__4, ip, b, &
+ c__2, x, &c__2, r1, r2, w, r__, &info);
+ chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ cgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__3, ip, b, &
+ c__2, x, &c__2, r1, r2, w, r__, &info);
+ chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__2, r1, r2, w, r__, &info);
+ chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ cgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
+ c__2, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGBCON */
+
+ s_copy(srnamc_1.srnamt, "CGBCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgbcon_("/", &c__0, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, r__,
+ &info);
+ chkxer_("CGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgbcon_("1", &c_n1, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, r__,
+ &info);
+ chkxer_("CGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgbcon_("1", &c__1, &c_n1, &c__0, a, &c__1, ip, &anrm, &rcond, w, r__,
+ &info);
+ chkxer_("CGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgbcon_("1", &c__1, &c__0, &c_n1, a, &c__1, ip, &anrm, &rcond, w, r__,
+ &info);
+ chkxer_("CGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cgbcon_("1", &c__2, &c__1, &c__1, a, &c__3, ip, &anrm, &rcond, w, r__,
+ &info);
+ chkxer_("CGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGBEQU */
+
+ s_copy(srnamc_1.srnamt, "CGBEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgbequ_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("CGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgbequ_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("CGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgbequ_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("CGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgbequ_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("CGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cgbequ_(&c__2, &c__2, &c__1, &c__1, a, &c__2, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("CGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of CERRGE */
+
+} /* cerrge_ */
diff --git a/TESTING/LIN/cerrgex.c b/TESTING/LIN/cerrgex.c
new file mode 100644
index 0000000..7804553
--- /dev/null
+++ b/TESTING/LIN/cerrgex.c
@@ -0,0 +1,737 @@
+/* cerrgex.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static integer c__5 = 5;
+
+/* Subroutine */ int cerrge_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ complex a[16] /* was [4][4] */, b[4];
+ integer i__, j;
+ real r__[4];
+ complex w[8], x[4];
+ char c2[2];
+ real r1[4], r2[4];
+ complex af[16] /* was [4][4] */;
+ char eq[1];
+ real cs[4];
+ integer ip[4];
+ real rs[4];
+ complex err_bnds_c__[12] /* was [4][3] */;
+ integer n_err_bnds__;
+ complex err_bnds_n__[12] /* was [4][3] */;
+ real berr;
+ integer info;
+ real anrm, ccond, rcond;
+ extern /* Subroutine */ int cgbtf2_(integer *, integer *, integer *,
+ integer *, complex *, integer *, integer *, integer *), cgetf2_(
+ integer *, integer *, complex *, integer *, integer *, integer *),
+ cgbcon_(char *, integer *, integer *, integer *, complex *,
+ integer *, integer *, real *, real *, complex *, real *, integer *
+), cgecon_(char *, integer *, complex *, integer *, real *
+, real *, complex *, real *, integer *), alaesm_(char *,
+ logical *, integer *), cgbequ_(integer *, integer *,
+ integer *, integer *, complex *, integer *, real *, real *, real *
+, real *, real *, integer *), cgbrfs_(char *, integer *, integer *
+, integer *, integer *, complex *, integer *, complex *, integer *
+, integer *, complex *, integer *, complex *, integer *, real *,
+ real *, complex *, real *, integer *), cgbtrf_(integer *,
+ integer *, integer *, integer *, complex *, integer *, integer *,
+ integer *), cgeequ_(integer *, integer *, complex *, integer *,
+ real *, real *, real *, real *, real *, integer *), cgerfs_(char *
+, integer *, integer *, complex *, integer *, complex *, integer *
+, integer *, complex *, integer *, complex *, integer *, real *,
+ real *, complex *, real *, integer *), cgetrf_(integer *,
+ integer *, complex *, integer *, integer *, integer *), cgetri_(
+ integer *, complex *, integer *, integer *, complex *, integer *,
+ integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ complex params[1];
+ extern /* Subroutine */ int cgbtrs_(char *, integer *, integer *, integer
+ *, integer *, complex *, integer *, integer *, complex *, integer
+ *, integer *), chkxer_(char *, integer *, integer *,
+ logical *, logical *), cgetrs_(char *, integer *, integer
+ *, complex *, integer *, integer *, complex *, integer *, integer
+ *), cgbequb_(integer *, integer *, integer *, integer *,
+ complex *, integer *, real *, real *, real *, real *, real *,
+ integer *), cgeequb_(integer *, integer *, complex *, integer *,
+ real *, real *, real *, real *, real *, integer *), cgbrfsx_(char
+ *, char *, integer *, integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, integer *, real *, real *,
+ complex *, integer *, complex *, integer *, real *, real *,
+ integer *, complex *, complex *, integer *, complex *, complex *,
+ real *, integer *);
+ integer nparams;
+ extern /* Subroutine */ int cgerfsx_(char *, char *, integer *, integer *,
+ complex *, integer *, complex *, integer *, integer *, real *,
+ real *, complex *, integer *, complex *, integer *, real *, real *
+, integer *, complex *, complex *, integer *, complex *, complex *
+, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERRGE tests the error exits for the COMPLEX routines */
+/* for general matrices. */
+
+/* Note that this file is used only when the XBLAS are available, */
+/* otherwise cerrge.f defines this subroutine. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. LOCAL ARRAYS .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ r__1 = 1.f / (real) (i__ + j);
+ r__2 = -1.f / (real) (i__ + j);
+ q__1.r = r__1, q__1.i = r__2;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = i__ + (j << 2) - 5;
+ r__1 = 1.f / (real) (i__ + j);
+ r__2 = -1.f / (real) (i__ + j);
+ q__1.r = r__1, q__1.i = r__2;
+ af[i__1].r = q__1.r, af[i__1].i = q__1.i;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0.f, b[i__1].i = 0.f;
+ r1[j - 1] = 0.f;
+ r2[j - 1] = 0.f;
+ i__1 = j - 1;
+ w[i__1].r = 0.f, w[i__1].i = 0.f;
+ i__1 = j - 1;
+ x[i__1].r = 0.f, x[i__1].i = 0.f;
+ cs[j - 1] = 0.f;
+ rs[j - 1] = 0.f;
+ ip[j - 1] = j;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+/* Test error exits of the routines that use the LU decomposition */
+/* of a general matrix. */
+
+ if (lsamen_(&c__2, c2, "GE")) {
+
+/* CGETRF */
+
+ s_copy(srnamc_1.srnamt, "CGETRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgetrf_(&c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("CGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgetrf_(&c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("CGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgetrf_(&c__2, &c__1, a, &c__1, ip, &info);
+ chkxer_("CGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGETF2 */
+
+ s_copy(srnamc_1.srnamt, "CGETF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgetf2_(&c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("CGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgetf2_(&c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("CGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgetf2_(&c__2, &c__1, a, &c__1, ip, &info);
+ chkxer_("CGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGETRI */
+
+ s_copy(srnamc_1.srnamt, "CGETRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgetri_(&c_n1, a, &c__1, ip, w, &c__1, &info);
+ chkxer_("CGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgetri_(&c__2, a, &c__1, ip, w, &c__2, &info);
+ chkxer_("CGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cgetri_(&c__2, a, &c__2, ip, w, &c__1, &info);
+ chkxer_("CGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGETRS */
+
+ s_copy(srnamc_1.srnamt, "CGETRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgetrs_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("CGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgetrs_("N", &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("CGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgetrs_("N", &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("CGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgetrs_("N", &c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
+ chkxer_("CGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cgetrs_("N", &c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
+ chkxer_("CGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGERFS */
+
+ s_copy(srnamc_1.srnamt, "CGERFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgerfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgerfs_("N", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgerfs_("N", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgerfs_("N", &c__2, &c__1, a, &c__1, af, &c__2, ip, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("CGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__1, ip, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("CGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__1, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("CGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__2, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGERFSX */
+
+ n_err_bnds__ = 3;
+ nparams = 0;
+ s_copy(srnamc_1.srnamt, "CGERFSX", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ cgerfsx_("/", eq, &c__0, &c__0, a, &c__1, af, &c__1, ip, rs, cs, b, &
+ c__1, x, &c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, r__, &info);
+ chkxer_("CGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ *(unsigned char *)eq = '/';
+ cgerfsx_("N", eq, &c__2, &c__1, a, &c__1, af, &c__2, ip, rs, cs, b, &
+ c__2, x, &c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, r__, &info);
+ chkxer_("CGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ *(unsigned char *)eq = 'R';
+ cgerfsx_("N", eq, &c_n1, &c__0, a, &c__1, af, &c__1, ip, rs, cs, b, &
+ c__1, x, &c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, r__, &info);
+ chkxer_("CGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgerfsx_("N", eq, &c__0, &c_n1, a, &c__1, af, &c__1, ip, rs, cs, b, &
+ c__1, x, &c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, r__, &info);
+ chkxer_("CGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cgerfsx_("N", eq, &c__2, &c__1, a, &c__1, af, &c__2, ip, rs, cs, b, &
+ c__2, x, &c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, r__, &info);
+ chkxer_("CGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cgerfsx_("N", eq, &c__2, &c__1, a, &c__2, af, &c__1, ip, rs, cs, b, &
+ c__2, x, &c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, r__, &info);
+ chkxer_("CGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ *(unsigned char *)eq = 'C';
+ cgerfsx_("N", eq, &c__2, &c__1, a, &c__2, af, &c__2, ip, rs, cs, b, &
+ c__1, x, &c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, r__, &info);
+ chkxer_("CGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ cgerfsx_("N", eq, &c__2, &c__1, a, &c__2, af, &c__2, ip, rs, cs, b, &
+ c__2, x, &c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, r__, &info);
+ chkxer_("CGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGECON */
+
+ s_copy(srnamc_1.srnamt, "CGECON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgecon_("/", &c__0, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("CGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgecon_("1", &c_n1, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("CGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgecon_("1", &c__2, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("CGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGEEQU */
+
+ s_copy(srnamc_1.srnamt, "CGEEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgeequ_(&c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("CGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgeequ_(&c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("CGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgeequ_(&c__2, &c__2, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("CGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGEEQUB */
+
+ s_copy(srnamc_1.srnamt, "CGEEQUB", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ cgeequb_(&c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info)
+ ;
+ chkxer_("CGEEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgeequb_(&c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info)
+ ;
+ chkxer_("CGEEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgeequb_(&c__2, &c__2, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info)
+ ;
+ chkxer_("CGEEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Test error exits of the routines that use the LU decomposition */
+/* of a general band matrix. */
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* CGBTRF */
+
+ s_copy(srnamc_1.srnamt, "CGBTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgbtrf_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("CGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgbtrf_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("CGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgbtrf_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("CGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgbtrf_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("CGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cgbtrf_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
+ chkxer_("CGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGBTF2 */
+
+ s_copy(srnamc_1.srnamt, "CGBTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgbtf2_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("CGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgbtf2_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("CGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgbtf2_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("CGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgbtf2_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("CGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cgbtf2_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
+ chkxer_("CGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGBTRS */
+
+ s_copy(srnamc_1.srnamt, "CGBTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgbtrs_("/", &c__0, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("CGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgbtrs_("N", &c_n1, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("CGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgbtrs_("N", &c__1, &c_n1, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("CGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgbtrs_("N", &c__1, &c__0, &c_n1, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("CGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgbtrs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("CGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cgbtrs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, ip, b, &c__2, &
+ info);
+ chkxer_("CGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cgbtrs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("CGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGBRFS */
+
+ s_copy(srnamc_1.srnamt, "CGBRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgbrfs_("/", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgbrfs_("N", &c_n1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgbrfs_("N", &c__1, &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgbrfs_("N", &c__1, &c__0, &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgbrfs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__2, af, &c__4, ip, b, &
+ c__2, x, &c__2, r1, r2, w, r__, &info);
+ chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ cgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__3, ip, b, &
+ c__2, x, &c__2, r1, r2, w, r__, &info);
+ chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__2, r1, r2, w, r__, &info);
+ chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ cgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
+ c__2, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("CGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGBRFSX */
+
+ n_err_bnds__ = 3;
+ nparams = 0;
+ s_copy(srnamc_1.srnamt, "CGBRFSX", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ cgbrfsx_("/", eq, &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ rs, cs, b, &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, r__, &info);
+ chkxer_("CGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ *(unsigned char *)eq = '/';
+ cgbrfsx_("N", eq, &c__2, &c__1, &c__1, &c__1, a, &c__1, af, &c__2, ip,
+ rs, cs, b, &c__2, x, &c__2, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, r__, &info);
+ chkxer_("CGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ *(unsigned char *)eq = 'R';
+ cgbrfsx_("N", eq, &c_n1, &c__1, &c__1, &c__0, a, &c__1, af, &c__1, ip,
+ rs, cs, b, &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, r__, &info);
+ chkxer_("CGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ *(unsigned char *)eq = 'R';
+ cgbrfsx_("N", eq, &c__2, &c_n1, &c__1, &c__1, a, &c__3, af, &c__4, ip,
+ rs, cs, b, &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, r__, &info);
+ chkxer_("CGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ *(unsigned char *)eq = 'R';
+ cgbrfsx_("N", eq, &c__2, &c__1, &c_n1, &c__1, a, &c__3, af, &c__4, ip,
+ rs, cs, b, &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, r__, &info);
+ chkxer_("CGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cgbrfsx_("N", eq, &c__0, &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, ip,
+ rs, cs, b, &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, r__, &info);
+ chkxer_("CGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cgbrfsx_("N", eq, &c__2, &c__1, &c__1, &c__1, a, &c__1, af, &c__2, ip,
+ rs, cs, b, &c__2, x, &c__2, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, r__, &info);
+ chkxer_("CGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cgbrfsx_("N", eq, &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__3, ip,
+ rs, cs, b, &c__2, x, &c__2, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, r__, &info);
+ chkxer_("CGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ *(unsigned char *)eq = 'C';
+ cgbrfsx_("N", eq, &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__5, ip,
+ rs, cs, b, &c__1, x, &c__2, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, r__, &info);
+ chkxer_("CGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ cgbrfsx_("N", eq, &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__5, ip,
+ rs, cs, b, &c__2, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, r__, &info);
+ chkxer_("CGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGBCON */
+
+ s_copy(srnamc_1.srnamt, "CGBCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgbcon_("/", &c__0, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, r__,
+ &info);
+ chkxer_("CGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgbcon_("1", &c_n1, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, r__,
+ &info);
+ chkxer_("CGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgbcon_("1", &c__1, &c_n1, &c__0, a, &c__1, ip, &anrm, &rcond, w, r__,
+ &info);
+ chkxer_("CGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgbcon_("1", &c__1, &c__0, &c_n1, a, &c__1, ip, &anrm, &rcond, w, r__,
+ &info);
+ chkxer_("CGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cgbcon_("1", &c__2, &c__1, &c__1, a, &c__3, ip, &anrm, &rcond, w, r__,
+ &info);
+ chkxer_("CGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGBEQU */
+
+ s_copy(srnamc_1.srnamt, "CGBEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgbequ_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("CGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgbequ_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("CGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgbequ_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("CGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgbequ_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("CGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cgbequ_(&c__2, &c__2, &c__1, &c__1, a, &c__2, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("CGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGBEQUB */
+
+ s_copy(srnamc_1.srnamt, "CGBEQUB", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ cgbequb_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("CGBEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgbequb_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("CGBEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgbequb_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("CGBEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgbequb_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("CGBEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cgbequb_(&c__2, &c__2, &c__1, &c__1, a, &c__2, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("CGBEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of CERRGE */
+
+} /* cerrge_ */
diff --git a/TESTING/LIN/cerrgt.c b/TESTING/LIN/cerrgt.c
new file mode 100644
index 0000000..526b763
--- /dev/null
+++ b/TESTING/LIN/cerrgt.c
@@ -0,0 +1,308 @@
+/* cerrgt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int cerrgt_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ complex b[2];
+ real d__[2];
+ complex e[2];
+ integer i__;
+ complex w[2], x[2];
+ char c2[2];
+ real r1[2], r2[2], df[2];
+ complex ef[2], dl[2];
+ integer ip[2];
+ complex du[2];
+ real rw[2];
+ complex du2[2], dlf[2], duf[2];
+ integer info;
+ real rcond, anorm;
+ extern /* Subroutine */ int alaesm_(char *, logical *, integer *),
+ cgtcon_(char *, integer *, complex *, complex *, complex *,
+ complex *, integer *, real *, real *, complex *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), cptcon_(integer *, real *, complex *, real
+ *, real *, real *, integer *), cgtrfs_(char *, integer *, integer
+ *, complex *, complex *, complex *, complex *, complex *, complex
+ *, complex *, integer *, complex *, integer *, complex *, integer
+ *, real *, real *, complex *, real *, integer *), cgttrf_(
+ integer *, complex *, complex *, complex *, complex *, integer *,
+ integer *), cptrfs_(char *, integer *, integer *, real *, complex
+ *, real *, complex *, complex *, integer *, complex *, integer *,
+ real *, real *, complex *, real *, integer *), cpttrf_(
+ integer *, real *, complex *, integer *), cgttrs_(char *, integer
+ *, integer *, complex *, complex *, complex *, complex *, integer
+ *, complex *, integer *, integer *), cpttrs_(char *,
+ integer *, integer *, real *, complex *, complex *, integer *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERRGT tests the error exits for the COMPLEX tridiagonal */
+/* routines. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ for (i__ = 1; i__ <= 2; ++i__) {
+ d__[i__ - 1] = 1.f;
+ i__1 = i__ - 1;
+ e[i__1].r = 2.f, e[i__1].i = 0.f;
+ i__1 = i__ - 1;
+ dl[i__1].r = 3.f, dl[i__1].i = 0.f;
+ i__1 = i__ - 1;
+ du[i__1].r = 4.f, du[i__1].i = 0.f;
+/* L10: */
+ }
+ anorm = 1.f;
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "GT")) {
+
+/* Test error exits for the general tridiagonal routines. */
+
+/* CGTTRF */
+
+ s_copy(srnamc_1.srnamt, "CGTTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgttrf_(&c_n1, dl, e, du, du2, ip, &info);
+ chkxer_("CGTTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGTTRS */
+
+ s_copy(srnamc_1.srnamt, "CGTTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgttrs_("/", &c__0, &c__0, dl, e, du, du2, ip, x, &c__1, &info);
+ chkxer_("CGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgttrs_("N", &c_n1, &c__0, dl, e, du, du2, ip, x, &c__1, &info);
+ chkxer_("CGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgttrs_("N", &c__0, &c_n1, dl, e, du, du2, ip, x, &c__1, &info);
+ chkxer_("CGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cgttrs_("N", &c__2, &c__1, dl, e, du, du2, ip, x, &c__1, &info);
+ chkxer_("CGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGTRFS */
+
+ s_copy(srnamc_1.srnamt, "CGTRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgtrfs_("/", &c__0, &c__0, dl, e, du, dlf, ef, duf, du2, ip, b, &c__1,
+ x, &c__1, r1, r2, w, rw, &info);
+ chkxer_("CGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgtrfs_("N", &c_n1, &c__0, dl, e, du, dlf, ef, duf, du2, ip, b, &c__1,
+ x, &c__1, r1, r2, w, rw, &info);
+ chkxer_("CGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgtrfs_("N", &c__0, &c_n1, dl, e, du, dlf, ef, duf, du2, ip, b, &c__1,
+ x, &c__1, r1, r2, w, rw, &info);
+ chkxer_("CGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ cgtrfs_("N", &c__2, &c__1, dl, e, du, dlf, ef, duf, du2, ip, b, &c__1,
+ x, &c__2, r1, r2, w, rw, &info);
+ chkxer_("CGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ cgtrfs_("N", &c__2, &c__1, dl, e, du, dlf, ef, duf, du2, ip, b, &c__2,
+ x, &c__1, r1, r2, w, rw, &info);
+ chkxer_("CGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGTCON */
+
+ s_copy(srnamc_1.srnamt, "CGTCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgtcon_("/", &c__0, dl, e, du, du2, ip, &anorm, &rcond, w, &info);
+ chkxer_("CGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgtcon_("I", &c_n1, dl, e, du, du2, ip, &anorm, &rcond, w, &info);
+ chkxer_("CGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ r__1 = -anorm;
+ cgtcon_("I", &c__0, dl, e, du, du2, ip, &r__1, &rcond, w, &info);
+ chkxer_("CGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PT")) {
+
+/* Test error exits for the positive definite tridiagonal */
+/* routines. */
+
+/* CPTTRF */
+
+ s_copy(srnamc_1.srnamt, "CPTTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpttrf_(&c_n1, d__, e, &info);
+ chkxer_("CPTTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPTTRS */
+
+ s_copy(srnamc_1.srnamt, "CPTTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpttrs_("/", &c__1, &c__0, d__, e, x, &c__1, &info);
+ chkxer_("CPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpttrs_("U", &c_n1, &c__0, d__, e, x, &c__1, &info);
+ chkxer_("CPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpttrs_("U", &c__0, &c_n1, d__, e, x, &c__1, &info);
+ chkxer_("CPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cpttrs_("U", &c__2, &c__1, d__, e, x, &c__1, &info);
+ chkxer_("CPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPTRFS */
+
+ s_copy(srnamc_1.srnamt, "CPTRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cptrfs_("/", &c__1, &c__0, d__, e, df, ef, b, &c__1, x, &c__1, r1, r2,
+ w, rw, &info);
+ chkxer_("CPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cptrfs_("U", &c_n1, &c__0, d__, e, df, ef, b, &c__1, x, &c__1, r1, r2,
+ w, rw, &info);
+ chkxer_("CPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cptrfs_("U", &c__0, &c_n1, d__, e, df, ef, b, &c__1, x, &c__1, r1, r2,
+ w, rw, &info);
+ chkxer_("CPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ cptrfs_("U", &c__2, &c__1, d__, e, df, ef, b, &c__1, x, &c__2, r1, r2,
+ w, rw, &info);
+ chkxer_("CPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ cptrfs_("U", &c__2, &c__1, d__, e, df, ef, b, &c__2, x, &c__1, r1, r2,
+ w, rw, &info);
+ chkxer_("CPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPTCON */
+
+ s_copy(srnamc_1.srnamt, "CPTCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cptcon_(&c_n1, d__, e, &anorm, &rcond, rw, &info);
+ chkxer_("CPTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ r__1 = -anorm;
+ cptcon_(&c__0, d__, e, &r__1, &rcond, rw, &info);
+ chkxer_("CPTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of CERRGT */
+
+} /* cerrgt_ */
diff --git a/TESTING/LIN/cerrhe.c b/TESTING/LIN/cerrhe.c
new file mode 100644
index 0000000..4d831a9
--- /dev/null
+++ b/TESTING/LIN/cerrhe.c
@@ -0,0 +1,406 @@
+/* cerrhe.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__4 = 4;
+
+/* Subroutine */ int cerrhe_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ complex a[16] /* was [4][4] */, b[4];
+ integer i__, j;
+ real r__[4];
+ complex w[8], x[4];
+ char c2[2];
+ real r1[4], r2[4];
+ complex af[16] /* was [4][4] */;
+ integer ip[4], info;
+ real anrm, rcond;
+ extern /* Subroutine */ int chetf2_(char *, integer *, complex *, integer
+ *, integer *, integer *), checon_(char *, integer *,
+ complex *, integer *, integer *, real *, real *, complex *,
+ integer *), alaesm_(char *, logical *, integer *),
+ cherfs_(char *, integer *, integer *, complex *, integer *,
+ complex *, integer *, integer *, complex *, integer *, complex *,
+ integer *, real *, real *, complex *, real *, integer *),
+ chetrf_(char *, integer *, complex *, integer *, integer *,
+ complex *, integer *, integer *), chpcon_(char *, integer
+ *, complex *, integer *, real *, real *, complex *, integer *), chetri_(char *, integer *, complex *, integer *, integer
+ *, complex *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), chprfs_(char *, integer *, integer *,
+ complex *, complex *, integer *, complex *, integer *, complex *,
+ integer *, real *, real *, complex *, real *, integer *),
+ chptrf_(char *, integer *, complex *, integer *, integer *), chetrs_(char *, integer *, integer *, complex *, integer
+ *, integer *, complex *, integer *, integer *), chptri_(
+ char *, integer *, complex *, integer *, complex *, integer *), chptrs_(char *, integer *, integer *, complex *, integer
+ *, complex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERRHE tests the error exits for the COMPLEX routines */
+/* for Hermitian indefinite matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ r__1 = 1.f / (real) (i__ + j);
+ r__2 = -1.f / (real) (i__ + j);
+ q__1.r = r__1, q__1.i = r__2;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = i__ + (j << 2) - 5;
+ r__1 = 1.f / (real) (i__ + j);
+ r__2 = -1.f / (real) (i__ + j);
+ q__1.r = r__1, q__1.i = r__2;
+ af[i__1].r = q__1.r, af[i__1].i = q__1.i;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0.f, b[i__1].i = 0.f;
+ r1[j - 1] = 0.f;
+ r2[j - 1] = 0.f;
+ i__1 = j - 1;
+ w[i__1].r = 0.f, w[i__1].i = 0.f;
+ i__1 = j - 1;
+ x[i__1].r = 0.f, x[i__1].i = 0.f;
+ ip[j - 1] = j;
+/* L20: */
+ }
+ anrm = 1.f;
+ infoc_1.ok = TRUE_;
+
+/* Test error exits of the routines that use the diagonal pivoting */
+/* factorization of a Hermitian indefinite matrix. */
+
+ if (lsamen_(&c__2, c2, "HE")) {
+
+/* CHETRF */
+
+ s_copy(srnamc_1.srnamt, "CHETRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chetrf_("/", &c__0, a, &c__1, ip, w, &c__1, &info);
+ chkxer_("CHETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chetrf_("U", &c_n1, a, &c__1, ip, w, &c__1, &info);
+ chkxer_("CHETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ chetrf_("U", &c__2, a, &c__1, ip, w, &c__4, &info);
+ chkxer_("CHETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CHETF2 */
+
+ s_copy(srnamc_1.srnamt, "CHETF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chetf2_("/", &c__0, a, &c__1, ip, &info);
+ chkxer_("CHETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chetf2_("U", &c_n1, a, &c__1, ip, &info);
+ chkxer_("CHETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ chetf2_("U", &c__2, a, &c__1, ip, &info);
+ chkxer_("CHETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CHETRI */
+
+ s_copy(srnamc_1.srnamt, "CHETRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chetri_("/", &c__0, a, &c__1, ip, w, &info);
+ chkxer_("CHETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chetri_("U", &c_n1, a, &c__1, ip, w, &info);
+ chkxer_("CHETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ chetri_("U", &c__2, a, &c__1, ip, w, &info);
+ chkxer_("CHETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CHETRS */
+
+ s_copy(srnamc_1.srnamt, "CHETRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chetrs_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("CHETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chetrs_("U", &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("CHETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ chetrs_("U", &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("CHETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ chetrs_("U", &c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
+ chkxer_("CHETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ chetrs_("U", &c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
+ chkxer_("CHETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CHERFS */
+
+ s_copy(srnamc_1.srnamt, "CHERFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cherfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CHERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cherfs_("U", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CHERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cherfs_("U", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CHERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cherfs_("U", &c__2, &c__1, a, &c__1, af, &c__2, ip, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("CHERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cherfs_("U", &c__2, &c__1, a, &c__2, af, &c__1, ip, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("CHERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cherfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__1, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("CHERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cherfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__2, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CHERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CHECON */
+
+ s_copy(srnamc_1.srnamt, "CHECON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ checon_("/", &c__0, a, &c__1, ip, &anrm, &rcond, w, &info);
+ chkxer_("CHECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ checon_("U", &c_n1, a, &c__1, ip, &anrm, &rcond, w, &info);
+ chkxer_("CHECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ checon_("U", &c__2, a, &c__1, ip, &anrm, &rcond, w, &info);
+ chkxer_("CHECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ r__1 = -anrm;
+ checon_("U", &c__1, a, &c__1, ip, &r__1, &rcond, w, &info);
+ chkxer_("CHECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Test error exits of the routines that use the diagonal pivoting */
+/* factorization of a Hermitian indefinite packed matrix. */
+
+ } else if (lsamen_(&c__2, c2, "HP")) {
+
+/* CHPTRF */
+
+ s_copy(srnamc_1.srnamt, "CHPTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chptrf_("/", &c__0, a, ip, &info);
+ chkxer_("CHPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chptrf_("U", &c_n1, a, ip, &info);
+ chkxer_("CHPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CHPTRI */
+
+ s_copy(srnamc_1.srnamt, "CHPTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chptri_("/", &c__0, a, ip, w, &info);
+ chkxer_("CHPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chptri_("U", &c_n1, a, ip, w, &info);
+ chkxer_("CHPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CHPTRS */
+
+ s_copy(srnamc_1.srnamt, "CHPTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chptrs_("/", &c__0, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("CHPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chptrs_("U", &c_n1, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("CHPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ chptrs_("U", &c__0, &c_n1, a, ip, b, &c__1, &info);
+ chkxer_("CHPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ chptrs_("U", &c__2, &c__1, a, ip, b, &c__1, &info);
+ chkxer_("CHPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CHPRFS */
+
+ s_copy(srnamc_1.srnamt, "CHPRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chprfs_("/", &c__0, &c__0, a, af, ip, b, &c__1, x, &c__1, r1, r2, w,
+ r__, &info);
+ chkxer_("CHPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chprfs_("U", &c_n1, &c__0, a, af, ip, b, &c__1, x, &c__1, r1, r2, w,
+ r__, &info);
+ chkxer_("CHPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ chprfs_("U", &c__0, &c_n1, a, af, ip, b, &c__1, x, &c__1, r1, r2, w,
+ r__, &info);
+ chkxer_("CHPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ chprfs_("U", &c__2, &c__1, a, af, ip, b, &c__1, x, &c__2, r1, r2, w,
+ r__, &info);
+ chkxer_("CHPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ chprfs_("U", &c__2, &c__1, a, af, ip, b, &c__2, x, &c__1, r1, r2, w,
+ r__, &info);
+ chkxer_("CHPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CHPCON */
+
+ s_copy(srnamc_1.srnamt, "CHPCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chpcon_("/", &c__0, a, ip, &anrm, &rcond, w, &info);
+ chkxer_("CHPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chpcon_("U", &c_n1, a, ip, &anrm, &rcond, w, &info);
+ chkxer_("CHPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ r__1 = -anrm;
+ chpcon_("U", &c__1, a, ip, &r__1, &rcond, w, &info);
+ chkxer_("CHPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of CERRHE */
+
+} /* cerrhe_ */
diff --git a/TESTING/LIN/cerrlq.c b/TESTING/LIN/cerrlq.c
new file mode 100644
index 0000000..fbc4006
--- /dev/null
+++ b/TESTING/LIN/cerrlq.c
@@ -0,0 +1,392 @@
+/* cerrlq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int cerrlq_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ complex a[4] /* was [2][2] */, b[2];
+ integer i__, j;
+ complex w[2], x[2], af[4] /* was [2][2] */;
+ integer info;
+ extern /* Subroutine */ int cgelq2_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *), cungl2_(integer *,
+ integer *, integer *, complex *, integer *, complex *, complex *,
+ integer *), cunml2_(char *, char *, integer *, integer *, integer
+ *, complex *, integer *, complex *, complex *, integer *, complex
+ *, integer *), cgelqf_(integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *),
+ alaesm_(char *, logical *, integer *), cgelqs_(integer *,
+ integer *, integer *, complex *, integer *, complex *, complex *,
+ integer *, complex *, integer *, integer *), chkxer_(char *,
+ integer *, integer *, logical *, logical *), cunglq_(
+ integer *, integer *, integer *, complex *, integer *, complex *,
+ complex *, integer *, integer *), cunmlq_(char *, char *, integer
+ *, integer *, integer *, complex *, integer *, complex *, complex
+ *, integer *, complex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERRLQ tests the error exits for the COMPLEX routines */
+/* that use the LQ decomposition of a general matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 2; ++j) {
+ for (i__ = 1; i__ <= 2; ++i__) {
+ i__1 = i__ + (j << 1) - 3;
+ r__1 = 1.f / (real) (i__ + j);
+ r__2 = -1.f / (real) (i__ + j);
+ q__1.r = r__1, q__1.i = r__2;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = i__ + (j << 1) - 3;
+ r__1 = 1.f / (real) (i__ + j);
+ r__2 = -1.f / (real) (i__ + j);
+ q__1.r = r__1, q__1.i = r__2;
+ af[i__1].r = q__1.r, af[i__1].i = q__1.i;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0.f, b[i__1].i = 0.f;
+ i__1 = j - 1;
+ w[i__1].r = 0.f, w[i__1].i = 0.f;
+ i__1 = j - 1;
+ x[i__1].r = 0.f, x[i__1].i = 0.f;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+/* Error exits for LQ factorization */
+
+/* CGELQF */
+
+ s_copy(srnamc_1.srnamt, "CGELQF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgelqf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
+ chkxer_("CGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgelqf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("CGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgelqf_(&c__2, &c__1, a, &c__1, b, w, &c__2, &info);
+ chkxer_("CGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cgelqf_(&c__2, &c__1, a, &c__2, b, w, &c__1, &info);
+ chkxer_("CGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGELQ2 */
+
+ s_copy(srnamc_1.srnamt, "CGELQ2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgelq2_(&c_n1, &c__0, a, &c__1, b, w, &info);
+ chkxer_("CGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgelq2_(&c__0, &c_n1, a, &c__1, b, w, &info);
+ chkxer_("CGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgelq2_(&c__2, &c__1, a, &c__1, b, w, &info);
+ chkxer_("CGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGELQS */
+
+ s_copy(srnamc_1.srnamt, "CGELQS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgelqs_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("CGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgelqs_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("CGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgelqs_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
+ chkxer_("CGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgelqs_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("CGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgelqs_(&c__2, &c__2, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
+ chkxer_("CGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cgelqs_(&c__1, &c__2, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("CGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cgelqs_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("CGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CUNGLQ */
+
+ s_copy(srnamc_1.srnamt, "CUNGLQ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cunglq_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("CUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cunglq_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("CUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cunglq_(&c__2, &c__1, &c__0, a, &c__2, x, w, &c__2, &info);
+ chkxer_("CUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cunglq_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
+ chkxer_("CUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cunglq_(&c__1, &c__1, &c__2, a, &c__1, x, w, &c__1, &info);
+ chkxer_("CUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunglq_(&c__2, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
+ chkxer_("CUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cunglq_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
+ chkxer_("CUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CUNGL2 */
+
+ s_copy(srnamc_1.srnamt, "CUNGL2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cungl2_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
+ chkxer_("CUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cungl2_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("CUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cungl2_(&c__2, &c__1, &c__0, a, &c__2, x, w, &info);
+ chkxer_("CUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cungl2_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
+ chkxer_("CUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cungl2_(&c__1, &c__1, &c__2, a, &c__1, x, w, &info);
+ chkxer_("CUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cungl2_(&c__2, &c__2, &c__0, a, &c__1, x, w, &info);
+ chkxer_("CUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CUNMLQ */
+
+ s_copy(srnamc_1.srnamt, "CUNMLQ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cunmlq_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cunmlq_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cunmlq_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cunmlq_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunmlq_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunmlq_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunmlq_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cunmlq_("L", "N", &c__2, &c__0, &c__2, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("CUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cunmlq_("R", "N", &c__0, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cunmlq_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cunmlq_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cunmlq_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("CUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CUNML2 */
+
+ s_copy(srnamc_1.srnamt, "CUNML2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cunml2_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cunml2_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cunml2_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cunml2_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunml2_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunml2_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunml2_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cunml2_("L", "N", &c__2, &c__1, &c__2, a, &c__1, x, af, &c__2, w, &info);
+ chkxer_("CUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cunml2_("R", "N", &c__1, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cunml2_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &info);
+ chkxer_("CUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of CERRLQ */
+
+} /* cerrlq_ */
diff --git a/TESTING/LIN/cerrls.c b/TESTING/LIN/cerrls.c
new file mode 100644
index 0000000..4e9a776
--- /dev/null
+++ b/TESTING/LIN/cerrls.c
@@ -0,0 +1,300 @@
+/* cerrls.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__10 = 10;
+static integer c__3 = 3;
+
+/* Subroutine */ int cerrls_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void);
+
+ /* Local variables */
+ complex a[4] /* was [2][2] */, b[4] /* was [2][2] */;
+ real s[2];
+ complex w[2];
+ char c2[2];
+ integer ip[2];
+ real rw[2];
+ integer info, irnk;
+ extern /* Subroutine */ int cgels_(char *, integer *, integer *, integer *
+, complex *, integer *, complex *, integer *, complex *, integer *
+, integer *);
+ real rcond;
+ extern /* Subroutine */ int cgelsd_(integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, real *, real *,
+ integer *, complex *, integer *, real *, integer *, integer *),
+ alaesm_(char *, logical *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int cgelss_(integer *, integer *, integer *,
+ complex *, integer *, complex *, integer *, real *, real *,
+ integer *, complex *, integer *, real *, integer *), chkxer_(char
+ *, integer *, integer *, logical *, logical *), cgelsx_(
+ integer *, integer *, integer *, complex *, integer *, complex *,
+ integer *, integer *, real *, integer *, complex *, real *,
+ integer *), cgelsy_(integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, integer *, real *, integer *,
+ complex *, integer *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___3 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERRLS tests the error exits for the COMPLEX least squares */
+/* driver routines (CGELS, CGELSS, CGELSX, CGELSY, CGELSD). */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ a[0].r = 1.f, a[0].i = 0.f;
+ a[2].r = 2.f, a[2].i = 0.f;
+ a[3].r = 3.f, a[3].i = 0.f;
+ a[1].r = 4.f, a[1].i = 0.f;
+ infoc_1.ok = TRUE_;
+ io___3.ciunit = infoc_1.nout;
+ s_wsle(&io___3);
+ e_wsle();
+
+/* Test error exits for the least squares driver routines. */
+
+ if (lsamen_(&c__2, c2, "LS")) {
+
+/* CGELS */
+
+ s_copy(srnamc_1.srnamt, "CGELS ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgels_("/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, w, &c__1, &info);
+ chkxer_("CGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgels_("N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, w, &c__1, &info);
+ chkxer_("CGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgels_("N", &c__0, &c_n1, &c__0, a, &c__1, b, &c__1, w, &c__1, &info);
+ chkxer_("CGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgels_("N", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, w, &c__1, &info);
+ chkxer_("CGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cgels_("N", &c__2, &c__0, &c__0, a, &c__1, b, &c__2, w, &c__2, &info);
+ chkxer_("CGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cgels_("N", &c__2, &c__0, &c__0, a, &c__2, b, &c__1, w, &c__2, &info);
+ chkxer_("CGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cgels_("N", &c__1, &c__1, &c__0, a, &c__1, b, &c__1, w, &c__1, &info);
+ chkxer_("CGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGELSS */
+
+ s_copy(srnamc_1.srnamt, "CGELSS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgelss_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__1, rw, &info);
+ chkxer_("CGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgelss_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__1, rw, &info);
+ chkxer_("CGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgelss_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__1, rw, &info);
+ chkxer_("CGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgelss_(&c__2, &c__0, &c__0, a, &c__1, b, &c__2, s, &rcond, &irnk, w,
+ &c__2, rw, &info);
+ chkxer_("CGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cgelss_(&c__2, &c__0, &c__0, a, &c__2, b, &c__1, s, &rcond, &irnk, w,
+ &c__2, rw, &info);
+ chkxer_("CGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGELSX */
+
+ s_copy(srnamc_1.srnamt, "CGELSX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgelsx_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ rw, &info);
+ chkxer_("CGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgelsx_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ rw, &info);
+ chkxer_("CGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgelsx_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ rw, &info);
+ chkxer_("CGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgelsx_(&c__2, &c__0, &c__0, a, &c__1, b, &c__2, ip, &rcond, &irnk, w,
+ rw, &info);
+ chkxer_("CGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cgelsx_(&c__2, &c__0, &c__0, a, &c__2, b, &c__1, ip, &rcond, &irnk, w,
+ rw, &info);
+ chkxer_("CGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGELSY */
+
+ s_copy(srnamc_1.srnamt, "CGELSY", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgelsy_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ &c__10, rw, &info);
+ chkxer_("CGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgelsy_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ &c__10, rw, &info);
+ chkxer_("CGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgelsy_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ &c__10, rw, &info);
+ chkxer_("CGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgelsy_(&c__2, &c__0, &c__0, a, &c__1, b, &c__2, ip, &rcond, &irnk, w,
+ &c__10, rw, &info);
+ chkxer_("CGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cgelsy_(&c__2, &c__0, &c__0, a, &c__2, b, &c__1, ip, &rcond, &irnk, w,
+ &c__10, rw, &info);
+ chkxer_("CGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cgelsy_(&c__0, &c__3, &c__0, a, &c__1, b, &c__3, ip, &rcond, &irnk, w,
+ &c__1, rw, &info);
+ chkxer_("CGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGELSD */
+
+ s_copy(srnamc_1.srnamt, "CGELSD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgelsd_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__10, rw, ip, &info);
+ chkxer_("CGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgelsd_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__10, rw, ip, &info);
+ chkxer_("CGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgelsd_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__10, rw, ip, &info);
+ chkxer_("CGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgelsd_(&c__2, &c__0, &c__0, a, &c__1, b, &c__2, s, &rcond, &irnk, w,
+ &c__10, rw, ip, &info);
+ chkxer_("CGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cgelsd_(&c__2, &c__0, &c__0, a, &c__2, b, &c__1, s, &rcond, &irnk, w,
+ &c__10, rw, ip, &info);
+ chkxer_("CGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cgelsd_(&c__2, &c__2, &c__1, a, &c__2, b, &c__2, s, &rcond, &irnk, w,
+ &c__1, rw, ip, &info);
+ chkxer_("CGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of CERRLS */
+
+} /* cerrls_ */
diff --git a/TESTING/LIN/cerrpo.c b/TESTING/LIN/cerrpo.c
new file mode 100644
index 0000000..9e4860c
--- /dev/null
+++ b/TESTING/LIN/cerrpo.c
@@ -0,0 +1,605 @@
+/* cerrpo.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cerrpo_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ complex a[16] /* was [4][4] */, b[4];
+ integer i__, j;
+ real r__[4];
+ complex w[8], x[4];
+ char c2[2];
+ real r1[4], r2[4];
+ complex af[16] /* was [4][4] */;
+ integer info;
+ real anrm, rcond;
+ extern /* Subroutine */ int cpbtf2_(char *, integer *, integer *, complex
+ *, integer *, integer *), cpotf2_(char *, integer *,
+ complex *, integer *, integer *), alaesm_(char *, logical
+ *, integer *), cpbcon_(char *, integer *, integer *,
+ complex *, integer *, real *, real *, complex *, real *, integer *
+);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int cpbequ_(char *, integer *, integer *, complex
+ *, integer *, real *, real *, real *, integer *), cpbrfs_(
+ char *, integer *, integer *, integer *, complex *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ real *, real *, complex *, real *, integer *), cpbtrf_(
+ char *, integer *, integer *, complex *, integer *, integer *), cpocon_(char *, integer *, complex *, integer *, real *,
+ real *, complex *, real *, integer *), chkxer_(char *,
+ integer *, integer *, logical *, logical *), cppcon_(char
+ *, integer *, complex *, real *, real *, complex *, real *,
+ integer *), cpoequ_(integer *, complex *, integer *, real
+ *, real *, real *, integer *), cpbtrs_(char *, integer *, integer
+ *, integer *, complex *, integer *, complex *, integer *, integer
+ *), cporfs_(char *, integer *, integer *, complex *,
+ integer *, complex *, integer *, complex *, integer *, complex *,
+ integer *, real *, real *, complex *, real *, integer *),
+ cpotrf_(char *, integer *, complex *, integer *, integer *), cpotri_(char *, integer *, complex *, integer *, integer
+ *), cppequ_(char *, integer *, complex *, real *, real *,
+ real *, integer *), cpprfs_(char *, integer *, integer *,
+ complex *, complex *, complex *, integer *, complex *, integer *,
+ real *, real *, complex *, real *, integer *), cpptrf_(
+ char *, integer *, complex *, integer *), cpptri_(char *,
+ integer *, complex *, integer *), cpotrs_(char *, integer
+ *, integer *, complex *, integer *, complex *, integer *, integer
+ *), cpptrs_(char *, integer *, integer *, complex *,
+ complex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERRPO tests the error exits for the COMPLEX routines */
+/* for Hermitian positive definite matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ r__1 = 1.f / (real) (i__ + j);
+ r__2 = -1.f / (real) (i__ + j);
+ q__1.r = r__1, q__1.i = r__2;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = i__ + (j << 2) - 5;
+ r__1 = 1.f / (real) (i__ + j);
+ r__2 = -1.f / (real) (i__ + j);
+ q__1.r = r__1, q__1.i = r__2;
+ af[i__1].r = q__1.r, af[i__1].i = q__1.i;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0.f, b[i__1].i = 0.f;
+ r1[j - 1] = 0.f;
+ r2[j - 1] = 0.f;
+ i__1 = j - 1;
+ w[i__1].r = 0.f, w[i__1].i = 0.f;
+ i__1 = j - 1;
+ x[i__1].r = 0.f, x[i__1].i = 0.f;
+/* L20: */
+ }
+ anrm = 1.f;
+ infoc_1.ok = TRUE_;
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a Hermitian positive definite matrix. */
+
+ if (lsamen_(&c__2, c2, "PO")) {
+
+/* CPOTRF */
+
+ s_copy(srnamc_1.srnamt, "CPOTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpotrf_("/", &c__0, a, &c__1, &info);
+ chkxer_("CPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpotrf_("U", &c_n1, a, &c__1, &info);
+ chkxer_("CPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cpotrf_("U", &c__2, a, &c__1, &info);
+ chkxer_("CPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPOTF2 */
+
+ s_copy(srnamc_1.srnamt, "CPOTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpotf2_("/", &c__0, a, &c__1, &info);
+ chkxer_("CPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpotf2_("U", &c_n1, a, &c__1, &info);
+ chkxer_("CPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cpotf2_("U", &c__2, a, &c__1, &info);
+ chkxer_("CPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPOTRI */
+
+ s_copy(srnamc_1.srnamt, "CPOTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpotri_("/", &c__0, a, &c__1, &info);
+ chkxer_("CPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpotri_("U", &c_n1, a, &c__1, &info);
+ chkxer_("CPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cpotri_("U", &c__2, a, &c__1, &info);
+ chkxer_("CPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPOTRS */
+
+ s_copy(srnamc_1.srnamt, "CPOTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpotrs_("/", &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("CPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpotrs_("U", &c_n1, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("CPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpotrs_("U", &c__0, &c_n1, a, &c__1, b, &c__1, &info);
+ chkxer_("CPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cpotrs_("U", &c__2, &c__1, a, &c__1, b, &c__2, &info);
+ chkxer_("CPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cpotrs_("U", &c__2, &c__1, a, &c__2, b, &c__1, &info);
+ chkxer_("CPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPORFS */
+
+ s_copy(srnamc_1.srnamt, "CPORFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cporfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, r__, &info);
+ chkxer_("CPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cporfs_("U", &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, r__, &info);
+ chkxer_("CPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cporfs_("U", &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, r__, &info);
+ chkxer_("CPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cporfs_("U", &c__2, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &c__2,
+ r1, r2, w, r__, &info);
+ chkxer_("CPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cporfs_("U", &c__2, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &c__2,
+ r1, r2, w, r__, &info);
+ chkxer_("CPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ cporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__1, x, &c__2,
+ r1, r2, w, r__, &info);
+ chkxer_("CPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ cporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__2, x, &c__1,
+ r1, r2, w, r__, &info);
+ chkxer_("CPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPOCON */
+
+ s_copy(srnamc_1.srnamt, "CPOCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpocon_("/", &c__0, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("CPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpocon_("U", &c_n1, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("CPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cpocon_("U", &c__2, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("CPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ r__1 = -anrm;
+ cpocon_("U", &c__1, a, &c__1, &r__1, &rcond, w, r__, &info)
+ ;
+ chkxer_("CPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPOEQU */
+
+ s_copy(srnamc_1.srnamt, "CPOEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpoequ_(&c_n1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("CPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpoequ_(&c__2, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("CPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a Hermitian positive definite packed matrix. */
+
+ } else if (lsamen_(&c__2, c2, "PP")) {
+
+/* CPPTRF */
+
+ s_copy(srnamc_1.srnamt, "CPPTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpptrf_("/", &c__0, a, &info);
+ chkxer_("CPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpptrf_("U", &c_n1, a, &info);
+ chkxer_("CPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPPTRI */
+
+ s_copy(srnamc_1.srnamt, "CPPTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpptri_("/", &c__0, a, &info);
+ chkxer_("CPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpptri_("U", &c_n1, a, &info);
+ chkxer_("CPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPPTRS */
+
+ s_copy(srnamc_1.srnamt, "CPPTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpptrs_("/", &c__0, &c__0, a, b, &c__1, &info);
+ chkxer_("CPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpptrs_("U", &c_n1, &c__0, a, b, &c__1, &info);
+ chkxer_("CPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpptrs_("U", &c__0, &c_n1, a, b, &c__1, &info);
+ chkxer_("CPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cpptrs_("U", &c__2, &c__1, a, b, &c__1, &info);
+ chkxer_("CPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPPRFS */
+
+ s_copy(srnamc_1.srnamt, "CPPRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpprfs_("/", &c__0, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, r__,
+ &info);
+ chkxer_("CPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpprfs_("U", &c_n1, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, r__,
+ &info);
+ chkxer_("CPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpprfs_("U", &c__0, &c_n1, a, af, b, &c__1, x, &c__1, r1, r2, w, r__,
+ &info);
+ chkxer_("CPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cpprfs_("U", &c__2, &c__1, a, af, b, &c__1, x, &c__2, r1, r2, w, r__,
+ &info);
+ chkxer_("CPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ cpprfs_("U", &c__2, &c__1, a, af, b, &c__2, x, &c__1, r1, r2, w, r__,
+ &info);
+ chkxer_("CPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPPCON */
+
+ s_copy(srnamc_1.srnamt, "CPPCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cppcon_("/", &c__0, a, &anrm, &rcond, w, r__, &info);
+ chkxer_("CPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cppcon_("U", &c_n1, a, &anrm, &rcond, w, r__, &info);
+ chkxer_("CPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ r__1 = -anrm;
+ cppcon_("U", &c__1, a, &r__1, &rcond, w, r__, &info);
+ chkxer_("CPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPPEQU */
+
+ s_copy(srnamc_1.srnamt, "CPPEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cppequ_("/", &c__0, a, r1, &rcond, &anrm, &info);
+ chkxer_("CPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cppequ_("U", &c_n1, a, r1, &rcond, &anrm, &info);
+ chkxer_("CPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a Hermitian positive definite band matrix. */
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* CPBTRF */
+
+ s_copy(srnamc_1.srnamt, "CPBTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpbtrf_("/", &c__0, &c__0, a, &c__1, &info);
+ chkxer_("CPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpbtrf_("U", &c_n1, &c__0, a, &c__1, &info);
+ chkxer_("CPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpbtrf_("U", &c__1, &c_n1, a, &c__1, &info);
+ chkxer_("CPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cpbtrf_("U", &c__2, &c__1, a, &c__1, &info);
+ chkxer_("CPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPBTF2 */
+
+ s_copy(srnamc_1.srnamt, "CPBTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpbtf2_("/", &c__0, &c__0, a, &c__1, &info);
+ chkxer_("CPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpbtf2_("U", &c_n1, &c__0, a, &c__1, &info);
+ chkxer_("CPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpbtf2_("U", &c__1, &c_n1, a, &c__1, &info);
+ chkxer_("CPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cpbtf2_("U", &c__2, &c__1, a, &c__1, &info);
+ chkxer_("CPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPBTRS */
+
+ s_copy(srnamc_1.srnamt, "CPBTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpbtrs_("/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("CPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpbtrs_("U", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("CPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpbtrs_("U", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("CPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cpbtrs_("U", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, &info);
+ chkxer_("CPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cpbtrs_("U", &c__2, &c__1, &c__1, a, &c__1, b, &c__1, &info);
+ chkxer_("CPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cpbtrs_("U", &c__2, &c__0, &c__1, a, &c__1, b, &c__1, &info);
+ chkxer_("CPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPBRFS */
+
+ s_copy(srnamc_1.srnamt, "CPBRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpbrfs_("/", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpbrfs_("U", &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpbrfs_("U", &c__1, &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cpbrfs_("U", &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cpbrfs_("U", &c__2, &c__1, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cpbrfs_("U", &c__2, &c__1, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cpbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cpbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__2, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPBCON */
+
+ s_copy(srnamc_1.srnamt, "CPBCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpbcon_("/", &c__0, &c__0, a, &c__1, &anrm, &rcond, w, r__, &info);
+ chkxer_("CPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpbcon_("U", &c_n1, &c__0, a, &c__1, &anrm, &rcond, w, r__, &info);
+ chkxer_("CPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpbcon_("U", &c__1, &c_n1, a, &c__1, &anrm, &rcond, w, r__, &info);
+ chkxer_("CPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cpbcon_("U", &c__2, &c__1, a, &c__1, &anrm, &rcond, w, r__, &info);
+ chkxer_("CPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ r__1 = -anrm;
+ cpbcon_("U", &c__1, &c__0, a, &c__1, &r__1, &rcond, w, r__, &info);
+ chkxer_("CPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPBEQU */
+
+ s_copy(srnamc_1.srnamt, "CPBEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpbequ_("/", &c__0, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("CPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpbequ_("U", &c_n1, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("CPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpbequ_("U", &c__1, &c_n1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("CPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cpbequ_("U", &c__2, &c__1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("CPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of CERRPO */
+
+} /* cerrpo_ */
diff --git a/TESTING/LIN/cerrpox.c b/TESTING/LIN/cerrpox.c
new file mode 100644
index 0000000..4cf972f
--- /dev/null
+++ b/TESTING/LIN/cerrpox.c
@@ -0,0 +1,685 @@
+/* cerrpox.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cerrpo_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ complex a[16] /* was [4][4] */, b[4];
+ integer i__, j;
+ real r__[4], s[4];
+ complex w[8], x[4];
+ char c2[2];
+ real r1[4], r2[4];
+ complex af[16] /* was [4][4] */;
+ char eq[1];
+ real err_bnds_c__[12] /* was [4][3] */;
+ integer n_err_bnds__;
+ real err_bnds_n__[12] /* was [4][3] */, berr;
+ integer info;
+ real anrm, rcond;
+ extern /* Subroutine */ int cpbtf2_(char *, integer *, integer *, complex
+ *, integer *, integer *), cpotf2_(char *, integer *,
+ complex *, integer *, integer *), alaesm_(char *, logical
+ *, integer *), cpbcon_(char *, integer *, integer *,
+ complex *, integer *, real *, real *, complex *, real *, integer *
+);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int cpbequ_(char *, integer *, integer *, complex
+ *, integer *, real *, real *, real *, integer *), cpbrfs_(
+ char *, integer *, integer *, integer *, complex *, integer *,
+ complex *, integer *, complex *, integer *, complex *, integer *,
+ real *, real *, complex *, real *, integer *), cpbtrf_(
+ char *, integer *, integer *, complex *, integer *, integer *);
+ real params;
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), cpocon_(char *, integer *, complex *,
+ integer *, real *, real *, complex *, real *, integer *),
+ cppcon_(char *, integer *, complex *, real *, real *, complex *,
+ real *, integer *), cpoequ_(integer *, complex *, integer
+ *, real *, real *, real *, integer *), cpbtrs_(char *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ integer *), cporfs_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *, complex *, integer *, complex
+ *, integer *, real *, real *, complex *, real *, integer *), cpotrf_(char *, integer *, complex *, integer *, integer
+ *), cpotri_(char *, integer *, complex *, integer *,
+ integer *), cppequ_(char *, integer *, complex *, real *,
+ real *, real *, integer *), cpprfs_(char *, integer *,
+ integer *, complex *, complex *, complex *, integer *, complex *,
+ integer *, real *, real *, complex *, real *, integer *),
+ cpptrf_(char *, integer *, complex *, integer *), cpptri_(
+ char *, integer *, complex *, integer *), cpotrs_(char *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ integer *), cpptrs_(char *, integer *, integer *, complex
+ *, complex *, integer *, integer *), cpoequb_(integer *,
+ complex *, integer *, real *, real *, real *, integer *);
+ integer nparams;
+ extern /* Subroutine */ int cporfsx_(char *, char *, integer *, integer *,
+ complex *, integer *, complex *, integer *, real *, complex *,
+ integer *, complex *, integer *, real *, real *, integer *, real *
+, real *, integer *, real *, complex *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERRPO tests the error exits for the COMPLEX routines */
+/* for Hermitian positive definite matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ r__1 = 1.f / (real) (i__ + j);
+ r__2 = -1.f / (real) (i__ + j);
+ q__1.r = r__1, q__1.i = r__2;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = i__ + (j << 2) - 5;
+ r__1 = 1.f / (real) (i__ + j);
+ r__2 = -1.f / (real) (i__ + j);
+ q__1.r = r__1, q__1.i = r__2;
+ af[i__1].r = q__1.r, af[i__1].i = q__1.i;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0.f, b[i__1].i = 0.f;
+ r1[j - 1] = 0.f;
+ r2[j - 1] = 0.f;
+ i__1 = j - 1;
+ w[i__1].r = 0.f, w[i__1].i = 0.f;
+ i__1 = j - 1;
+ x[i__1].r = 0.f, x[i__1].i = 0.f;
+ s[j - 1] = 0.f;
+/* L20: */
+ }
+ anrm = 1.f;
+ infoc_1.ok = TRUE_;
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a Hermitian positive definite matrix. */
+
+ if (lsamen_(&c__2, c2, "PO")) {
+
+/* CPOTRF */
+
+ s_copy(srnamc_1.srnamt, "CPOTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpotrf_("/", &c__0, a, &c__1, &info);
+ chkxer_("CPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpotrf_("U", &c_n1, a, &c__1, &info);
+ chkxer_("CPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cpotrf_("U", &c__2, a, &c__1, &info);
+ chkxer_("CPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPOTF2 */
+
+ s_copy(srnamc_1.srnamt, "CPOTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpotf2_("/", &c__0, a, &c__1, &info);
+ chkxer_("CPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpotf2_("U", &c_n1, a, &c__1, &info);
+ chkxer_("CPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cpotf2_("U", &c__2, a, &c__1, &info);
+ chkxer_("CPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPOTRI */
+
+ s_copy(srnamc_1.srnamt, "CPOTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpotri_("/", &c__0, a, &c__1, &info);
+ chkxer_("CPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpotri_("U", &c_n1, a, &c__1, &info);
+ chkxer_("CPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cpotri_("U", &c__2, a, &c__1, &info);
+ chkxer_("CPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPOTRS */
+
+ s_copy(srnamc_1.srnamt, "CPOTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpotrs_("/", &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("CPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpotrs_("U", &c_n1, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("CPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpotrs_("U", &c__0, &c_n1, a, &c__1, b, &c__1, &info);
+ chkxer_("CPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cpotrs_("U", &c__2, &c__1, a, &c__1, b, &c__2, &info);
+ chkxer_("CPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cpotrs_("U", &c__2, &c__1, a, &c__2, b, &c__1, &info);
+ chkxer_("CPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPORFS */
+
+ s_copy(srnamc_1.srnamt, "CPORFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cporfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, r__, &info);
+ chkxer_("CPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cporfs_("U", &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, r__, &info);
+ chkxer_("CPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cporfs_("U", &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, r__, &info);
+ chkxer_("CPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cporfs_("U", &c__2, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &c__2,
+ r1, r2, w, r__, &info);
+ chkxer_("CPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cporfs_("U", &c__2, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &c__2,
+ r1, r2, w, r__, &info);
+ chkxer_("CPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ cporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__1, x, &c__2,
+ r1, r2, w, r__, &info);
+ chkxer_("CPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ cporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__2, x, &c__1,
+ r1, r2, w, r__, &info);
+ chkxer_("CPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPORFSX */
+
+ n_err_bnds__ = 3;
+ nparams = 0;
+ s_copy(srnamc_1.srnamt, "CPORFSX", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ cporfsx_("/", eq, &c__0, &c__0, a, &c__1, af, &c__1, s, b, &c__1, x, &
+ c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("CPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cporfsx_("U", eq, &c_n1, &c__0, a, &c__1, af, &c__1, s, b, &c__1, x, &
+ c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("CPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ *(unsigned char *)eq = 'N';
+ infoc_1.infot = 3;
+ cporfsx_("U", eq, &c_n1, &c__0, a, &c__1, af, &c__1, s, b, &c__1, x, &
+ c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("CPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cporfsx_("U", eq, &c__0, &c_n1, a, &c__1, af, &c__1, s, b, &c__1, x, &
+ c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("CPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cporfsx_("U", eq, &c__2, &c__1, a, &c__1, af, &c__2, s, b, &c__2, x, &
+ c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("CPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cporfsx_("U", eq, &c__2, &c__1, a, &c__2, af, &c__1, s, b, &c__2, x, &
+ c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("CPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ cporfsx_("U", eq, &c__2, &c__1, a, &c__2, af, &c__2, s, b, &c__1, x, &
+ c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("CPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ cporfsx_("U", eq, &c__2, &c__1, a, &c__2, af, &c__2, s, b, &c__2, x, &
+ c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("CPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPOCON */
+
+ s_copy(srnamc_1.srnamt, "CPOCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpocon_("/", &c__0, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("CPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpocon_("U", &c_n1, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("CPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cpocon_("U", &c__2, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("CPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ r__1 = -anrm;
+ cpocon_("U", &c__1, a, &c__1, &r__1, &rcond, w, r__, &info)
+ ;
+ chkxer_("CPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPOEQU */
+
+ s_copy(srnamc_1.srnamt, "CPOEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpoequ_(&c_n1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("CPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpoequ_(&c__2, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("CPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPOEQUB */
+
+ s_copy(srnamc_1.srnamt, "CPOEQUB", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ cpoequb_(&c_n1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("CPOEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpoequb_(&c__2, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("CPOEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a Hermitian positive definite packed matrix. */
+
+ } else if (lsamen_(&c__2, c2, "PP")) {
+
+/* CPPTRF */
+
+ s_copy(srnamc_1.srnamt, "CPPTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpptrf_("/", &c__0, a, &info);
+ chkxer_("CPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpptrf_("U", &c_n1, a, &info);
+ chkxer_("CPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPPTRI */
+
+ s_copy(srnamc_1.srnamt, "CPPTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpptri_("/", &c__0, a, &info);
+ chkxer_("CPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpptri_("U", &c_n1, a, &info);
+ chkxer_("CPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPPTRS */
+
+ s_copy(srnamc_1.srnamt, "CPPTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpptrs_("/", &c__0, &c__0, a, b, &c__1, &info);
+ chkxer_("CPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpptrs_("U", &c_n1, &c__0, a, b, &c__1, &info);
+ chkxer_("CPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpptrs_("U", &c__0, &c_n1, a, b, &c__1, &info);
+ chkxer_("CPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cpptrs_("U", &c__2, &c__1, a, b, &c__1, &info);
+ chkxer_("CPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPPRFS */
+
+ s_copy(srnamc_1.srnamt, "CPPRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpprfs_("/", &c__0, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, r__,
+ &info);
+ chkxer_("CPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpprfs_("U", &c_n1, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, r__,
+ &info);
+ chkxer_("CPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpprfs_("U", &c__0, &c_n1, a, af, b, &c__1, x, &c__1, r1, r2, w, r__,
+ &info);
+ chkxer_("CPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cpprfs_("U", &c__2, &c__1, a, af, b, &c__1, x, &c__2, r1, r2, w, r__,
+ &info);
+ chkxer_("CPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ cpprfs_("U", &c__2, &c__1, a, af, b, &c__2, x, &c__1, r1, r2, w, r__,
+ &info);
+ chkxer_("CPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPPCON */
+
+ s_copy(srnamc_1.srnamt, "CPPCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cppcon_("/", &c__0, a, &anrm, &rcond, w, r__, &info);
+ chkxer_("CPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cppcon_("U", &c_n1, a, &anrm, &rcond, w, r__, &info);
+ chkxer_("CPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ r__1 = -anrm;
+ cppcon_("U", &c__1, a, &r__1, &rcond, w, r__, &info);
+ chkxer_("CPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPPEQU */
+
+ s_copy(srnamc_1.srnamt, "CPPEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cppequ_("/", &c__0, a, r1, &rcond, &anrm, &info);
+ chkxer_("CPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cppequ_("U", &c_n1, a, r1, &rcond, &anrm, &info);
+ chkxer_("CPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a Hermitian positive definite band matrix. */
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* CPBTRF */
+
+ s_copy(srnamc_1.srnamt, "CPBTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpbtrf_("/", &c__0, &c__0, a, &c__1, &info);
+ chkxer_("CPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpbtrf_("U", &c_n1, &c__0, a, &c__1, &info);
+ chkxer_("CPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpbtrf_("U", &c__1, &c_n1, a, &c__1, &info);
+ chkxer_("CPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cpbtrf_("U", &c__2, &c__1, a, &c__1, &info);
+ chkxer_("CPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPBTF2 */
+
+ s_copy(srnamc_1.srnamt, "CPBTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpbtf2_("/", &c__0, &c__0, a, &c__1, &info);
+ chkxer_("CPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpbtf2_("U", &c_n1, &c__0, a, &c__1, &info);
+ chkxer_("CPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpbtf2_("U", &c__1, &c_n1, a, &c__1, &info);
+ chkxer_("CPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cpbtf2_("U", &c__2, &c__1, a, &c__1, &info);
+ chkxer_("CPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPBTRS */
+
+ s_copy(srnamc_1.srnamt, "CPBTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpbtrs_("/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("CPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpbtrs_("U", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("CPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpbtrs_("U", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("CPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cpbtrs_("U", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, &info);
+ chkxer_("CPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cpbtrs_("U", &c__2, &c__1, &c__1, a, &c__1, b, &c__1, &info);
+ chkxer_("CPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cpbtrs_("U", &c__2, &c__0, &c__1, a, &c__1, b, &c__1, &info);
+ chkxer_("CPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPBRFS */
+
+ s_copy(srnamc_1.srnamt, "CPBRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpbrfs_("/", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpbrfs_("U", &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpbrfs_("U", &c__1, &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cpbrfs_("U", &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cpbrfs_("U", &c__2, &c__1, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cpbrfs_("U", &c__2, &c__1, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cpbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cpbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__2, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPBCON */
+
+ s_copy(srnamc_1.srnamt, "CPBCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpbcon_("/", &c__0, &c__0, a, &c__1, &anrm, &rcond, w, r__, &info);
+ chkxer_("CPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpbcon_("U", &c_n1, &c__0, a, &c__1, &anrm, &rcond, w, r__, &info);
+ chkxer_("CPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpbcon_("U", &c__1, &c_n1, a, &c__1, &anrm, &rcond, w, r__, &info);
+ chkxer_("CPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cpbcon_("U", &c__2, &c__1, a, &c__1, &anrm, &rcond, w, r__, &info);
+ chkxer_("CPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ r__1 = -anrm;
+ cpbcon_("U", &c__1, &c__0, a, &c__1, &r__1, &rcond, w, r__, &info);
+ chkxer_("CPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPBEQU */
+
+ s_copy(srnamc_1.srnamt, "CPBEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpbequ_("/", &c__0, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("CPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpbequ_("U", &c_n1, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("CPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpbequ_("U", &c__1, &c_n1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("CPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cpbequ_("U", &c__2, &c__1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("CPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of CERRPO */
+
+} /* cerrpo_ */
diff --git a/TESTING/LIN/cerrps.c b/TESTING/LIN/cerrps.c
new file mode 100644
index 0000000..03bd4d1
--- /dev/null
+++ b/TESTING/LIN/cerrps.c
@@ -0,0 +1,173 @@
+/* cerrps.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c__1 = 1;
+static real c_b9 = -1.f;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int cerrps_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ complex a[16] /* was [4][4] */;
+ integer i__, j, piv[4], info;
+ real rwork[8];
+ extern /* Subroutine */ int cpstf2_(char *, integer *, complex *, integer
+ *, integer *, integer *, real *, real *, integer *),
+ alaesm_(char *, logical *, integer *), chkxer_(char *,
+ integer *, integer *, logical *, logical *), cpstrf_(char
+ *, integer *, complex *, integer *, integer *, integer *, real *,
+ real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERRPS tests the error exits for the COMPLEX routines */
+/* for CPSTRF.. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ r__1 = 1.f / (real) (i__ + j);
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+
+/* L100: */
+ }
+ piv[j - 1] = j;
+ rwork[j - 1] = 0.f;
+ rwork[j + 3] = 0.f;
+
+/* L110: */
+ }
+ infoc_1.ok = TRUE_;
+
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of an Hermitian positive semidefinite matrix. */
+
+/* CPSTRF */
+
+ s_copy(srnamc_1.srnamt, "CPSTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpstrf_("/", &c__0, a, &c__1, piv, &c__1, &c_b9, rwork, &info);
+ chkxer_("CPSTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpstrf_("U", &c_n1, a, &c__1, piv, &c__1, &c_b9, rwork, &info);
+ chkxer_("CPSTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cpstrf_("U", &c__2, a, &c__1, piv, &c__1, &c_b9, rwork, &info);
+ chkxer_("CPSTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPSTF2 */
+
+ s_copy(srnamc_1.srnamt, "CPSTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpstf2_("/", &c__0, a, &c__1, piv, &c__1, &c_b9, rwork, &info);
+ chkxer_("CPSTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpstf2_("U", &c_n1, a, &c__1, piv, &c__1, &c_b9, rwork, &info);
+ chkxer_("CPSTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cpstf2_("U", &c__2, a, &c__1, piv, &c__1, &c_b9, rwork, &info);
+ chkxer_("CPSTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of CERRPS */
+
+} /* cerrps_ */
diff --git a/TESTING/LIN/cerrql.c b/TESTING/LIN/cerrql.c
new file mode 100644
index 0000000..169b755
--- /dev/null
+++ b/TESTING/LIN/cerrql.c
@@ -0,0 +1,392 @@
+/* cerrql.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int cerrql_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ complex a[4] /* was [2][2] */, b[2];
+ integer i__, j;
+ complex w[2], x[2], af[4] /* was [2][2] */;
+ integer info;
+ extern /* Subroutine */ int cgeql2_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *), cung2l_(integer *,
+ integer *, integer *, complex *, integer *, complex *, complex *,
+ integer *), cunm2l_(char *, char *, integer *, integer *, integer
+ *, complex *, integer *, complex *, complex *, integer *, complex
+ *, integer *), cgeqlf_(integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *),
+ alaesm_(char *, logical *, integer *), cgeqls_(integer *,
+ integer *, integer *, complex *, integer *, complex *, complex *,
+ integer *, complex *, integer *, integer *), chkxer_(char *,
+ integer *, integer *, logical *, logical *), cungql_(
+ integer *, integer *, integer *, complex *, integer *, complex *,
+ complex *, integer *, integer *), cunmql_(char *, char *, integer
+ *, integer *, integer *, complex *, integer *, complex *, complex
+ *, integer *, complex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERRQL tests the error exits for the COMPLEX routines */
+/* that use the QL decomposition of a general matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 2; ++j) {
+ for (i__ = 1; i__ <= 2; ++i__) {
+ i__1 = i__ + (j << 1) - 3;
+ r__1 = 1.f / (real) (i__ + j);
+ r__2 = -1.f / (real) (i__ + j);
+ q__1.r = r__1, q__1.i = r__2;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = i__ + (j << 1) - 3;
+ r__1 = 1.f / (real) (i__ + j);
+ r__2 = -1.f / (real) (i__ + j);
+ q__1.r = r__1, q__1.i = r__2;
+ af[i__1].r = q__1.r, af[i__1].i = q__1.i;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0.f, b[i__1].i = 0.f;
+ i__1 = j - 1;
+ w[i__1].r = 0.f, w[i__1].i = 0.f;
+ i__1 = j - 1;
+ x[i__1].r = 0.f, x[i__1].i = 0.f;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+/* Error exits for QL factorization */
+
+/* CGEQLF */
+
+ s_copy(srnamc_1.srnamt, "CGEQLF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgeqlf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
+ chkxer_("CGEQLF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgeqlf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("CGEQLF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgeqlf_(&c__2, &c__1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("CGEQLF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cgeqlf_(&c__1, &c__2, a, &c__1, b, w, &c__1, &info);
+ chkxer_("CGEQLF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGEQL2 */
+
+ s_copy(srnamc_1.srnamt, "CGEQL2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgeql2_(&c_n1, &c__0, a, &c__1, b, w, &info);
+ chkxer_("CGEQL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgeql2_(&c__0, &c_n1, a, &c__1, b, w, &info);
+ chkxer_("CGEQL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgeql2_(&c__2, &c__1, a, &c__1, b, w, &info);
+ chkxer_("CGEQL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGEQLS */
+
+ s_copy(srnamc_1.srnamt, "CGEQLS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgeqls_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("CGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgeqls_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("CGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgeqls_(&c__1, &c__2, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("CGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgeqls_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("CGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgeqls_(&c__2, &c__1, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
+ chkxer_("CGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cgeqls_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
+ chkxer_("CGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cgeqls_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("CGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CUNGQL */
+
+ s_copy(srnamc_1.srnamt, "CUNGQL", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cungql_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("CUNGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cungql_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("CUNGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cungql_(&c__1, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
+ chkxer_("CUNGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cungql_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
+ chkxer_("CUNGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cungql_(&c__1, &c__1, &c__2, a, &c__1, x, w, &c__1, &info);
+ chkxer_("CUNGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cungql_(&c__2, &c__1, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("CUNGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cungql_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
+ chkxer_("CUNGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CUNG2L */
+
+ s_copy(srnamc_1.srnamt, "CUNG2L", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cung2l_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
+ chkxer_("CUNG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cung2l_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("CUNG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cung2l_(&c__1, &c__2, &c__0, a, &c__1, x, w, &info);
+ chkxer_("CUNG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cung2l_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
+ chkxer_("CUNG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cung2l_(&c__2, &c__1, &c__2, a, &c__2, x, w, &info);
+ chkxer_("CUNG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cung2l_(&c__2, &c__1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("CUNG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CUNMQL */
+
+ s_copy(srnamc_1.srnamt, "CUNMQL", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cunmql_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cunmql_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cunmql_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cunmql_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunmql_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunmql_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunmql_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cunmql_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("CUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cunmql_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cunmql_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cunmql_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cunmql_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("CUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CUNM2L */
+
+ s_copy(srnamc_1.srnamt, "CUNM2L", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cunm2l_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cunm2l_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cunm2l_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cunm2l_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunm2l_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunm2l_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunm2l_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cunm2l_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &info);
+ chkxer_("CUNM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cunm2l_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cunm2l_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &info);
+ chkxer_("CUNM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of CERRQL */
+
+} /* cerrql_ */
diff --git a/TESTING/LIN/cerrqp.c b/TESTING/LIN/cerrqp.c
new file mode 100644
index 0000000..0eea7d7
--- /dev/null
+++ b/TESTING/LIN/cerrqp.c
@@ -0,0 +1,172 @@
+/* cerrqp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int cerrqp_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void);
+
+ /* Local variables */
+ complex a[9] /* was [3][3] */, w[15];
+ char c2[2];
+ integer ip[3], lw;
+ real rw[6];
+ complex tau[3];
+ integer info;
+ extern /* Subroutine */ int cgeqp3_(integer *, integer *, complex *,
+ integer *, integer *, complex *, complex *, integer *, real *,
+ integer *), alaesm_(char *, logical *, integer *),
+ cgeqpf_(integer *, integer *, complex *, integer *, integer *,
+ complex *, complex *, real *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *);
+
+ /* Fortran I/O blocks */
+ static cilist io___4 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERRQP tests the error exits for CGEQPF and CGEQP3. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ lw = 4;
+ a[0].r = 1.f, a[0].i = -1.f;
+ a[3].r = 2.f, a[3].i = -2.f;
+ a[4].r = 3.f, a[4].i = -3.f;
+ a[1].r = 4.f, a[1].i = -4.f;
+ infoc_1.ok = TRUE_;
+ io___4.ciunit = infoc_1.nout;
+ s_wsle(&io___4);
+ e_wsle();
+
+/* Test error exits for QR factorization with pivoting */
+
+ if (lsamen_(&c__2, c2, "QP")) {
+
+/* CGEQPF */
+
+ s_copy(srnamc_1.srnamt, "CGEQPF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgeqpf_(&c_n1, &c__0, a, &c__1, ip, tau, w, rw, &info);
+ chkxer_("CGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgeqpf_(&c__0, &c_n1, a, &c__1, ip, tau, w, rw, &info);
+ chkxer_("CGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgeqpf_(&c__2, &c__0, a, &c__1, ip, tau, w, rw, &info);
+ chkxer_("CGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGEQP3 */
+
+ s_copy(srnamc_1.srnamt, "CGEQP3", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgeqp3_(&c_n1, &c__0, a, &c__1, ip, tau, w, &lw, rw, &info);
+ chkxer_("CGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgeqp3_(&c__1, &c_n1, a, &c__1, ip, tau, w, &lw, rw, &info);
+ chkxer_("CGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgeqp3_(&c__2, &c__3, a, &c__1, ip, tau, w, &lw, rw, &info);
+ chkxer_("CGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ i__1 = lw - 10;
+ cgeqp3_(&c__2, &c__2, a, &c__2, ip, tau, w, &i__1, rw, &info);
+ chkxer_("CGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of CERRQP */
+
+} /* cerrqp_ */
diff --git a/TESTING/LIN/cerrqr.c b/TESTING/LIN/cerrqr.c
new file mode 100644
index 0000000..e9373a2
--- /dev/null
+++ b/TESTING/LIN/cerrqr.c
@@ -0,0 +1,392 @@
+/* cerrqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int cerrqr_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ complex a[4] /* was [2][2] */, b[2];
+ integer i__, j;
+ complex w[2], x[2], af[4] /* was [2][2] */;
+ integer info;
+ extern /* Subroutine */ int cgeqr2_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *), cung2r_(integer *,
+ integer *, integer *, complex *, integer *, complex *, complex *,
+ integer *), cunm2r_(char *, char *, integer *, integer *, integer
+ *, complex *, integer *, complex *, complex *, integer *, complex
+ *, integer *), alaesm_(char *, logical *, integer
+ *), cgeqrf_(integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *, integer *), cgeqrs_(integer *,
+ integer *, integer *, complex *, integer *, complex *, complex *,
+ integer *, complex *, integer *, integer *), chkxer_(char *,
+ integer *, integer *, logical *, logical *), cungqr_(
+ integer *, integer *, integer *, complex *, integer *, complex *,
+ complex *, integer *, integer *), cunmqr_(char *, char *, integer
+ *, integer *, integer *, complex *, integer *, complex *, complex
+ *, integer *, complex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERRQR tests the error exits for the COMPLEX routines */
+/* that use the QR decomposition of a general matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 2; ++j) {
+ for (i__ = 1; i__ <= 2; ++i__) {
+ i__1 = i__ + (j << 1) - 3;
+ r__1 = 1.f / (real) (i__ + j);
+ r__2 = -1.f / (real) (i__ + j);
+ q__1.r = r__1, q__1.i = r__2;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = i__ + (j << 1) - 3;
+ r__1 = 1.f / (real) (i__ + j);
+ r__2 = -1.f / (real) (i__ + j);
+ q__1.r = r__1, q__1.i = r__2;
+ af[i__1].r = q__1.r, af[i__1].i = q__1.i;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0.f, b[i__1].i = 0.f;
+ i__1 = j - 1;
+ w[i__1].r = 0.f, w[i__1].i = 0.f;
+ i__1 = j - 1;
+ x[i__1].r = 0.f, x[i__1].i = 0.f;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+/* Error exits for QR factorization */
+
+/* CGEQRF */
+
+ s_copy(srnamc_1.srnamt, "CGEQRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgeqrf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
+ chkxer_("CGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgeqrf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("CGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgeqrf_(&c__2, &c__1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("CGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cgeqrf_(&c__1, &c__2, a, &c__1, b, w, &c__1, &info);
+ chkxer_("CGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGEQR2 */
+
+ s_copy(srnamc_1.srnamt, "CGEQR2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgeqr2_(&c_n1, &c__0, a, &c__1, b, w, &info);
+ chkxer_("CGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgeqr2_(&c__0, &c_n1, a, &c__1, b, w, &info);
+ chkxer_("CGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgeqr2_(&c__2, &c__1, a, &c__1, b, w, &info);
+ chkxer_("CGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGEQRS */
+
+ s_copy(srnamc_1.srnamt, "CGEQRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgeqrs_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("CGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgeqrs_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("CGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgeqrs_(&c__1, &c__2, &c__0, a, &c__2, x, b, &c__2, w, &c__1, &info);
+ chkxer_("CGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgeqrs_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("CGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgeqrs_(&c__2, &c__1, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
+ chkxer_("CGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cgeqrs_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
+ chkxer_("CGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cgeqrs_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("CGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CUNGQR */
+
+ s_copy(srnamc_1.srnamt, "CUNGQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cungqr_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("CUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cungqr_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("CUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cungqr_(&c__1, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
+ chkxer_("CUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cungqr_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
+ chkxer_("CUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cungqr_(&c__1, &c__1, &c__2, a, &c__1, x, w, &c__1, &info);
+ chkxer_("CUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cungqr_(&c__2, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
+ chkxer_("CUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cungqr_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
+ chkxer_("CUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CUNG2R */
+
+ s_copy(srnamc_1.srnamt, "CUNG2R", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cung2r_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
+ chkxer_("CUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cung2r_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("CUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cung2r_(&c__1, &c__2, &c__0, a, &c__1, x, w, &info);
+ chkxer_("CUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cung2r_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
+ chkxer_("CUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cung2r_(&c__2, &c__1, &c__2, a, &c__2, x, w, &info);
+ chkxer_("CUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cung2r_(&c__2, &c__1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("CUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CUNMQR */
+
+ s_copy(srnamc_1.srnamt, "CUNMQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cunmqr_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cunmqr_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cunmqr_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cunmqr_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunmqr_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunmqr_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunmqr_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cunmqr_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cunmqr_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cunmqr_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cunmqr_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cunmqr_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("CUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CUNM2R */
+
+ s_copy(srnamc_1.srnamt, "CUNM2R", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cunm2r_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cunm2r_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cunm2r_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cunm2r_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunm2r_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunm2r_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunm2r_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cunm2r_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &info);
+ chkxer_("CUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cunm2r_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cunm2r_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &info);
+ chkxer_("CUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of CERRQR */
+
+} /* cerrqr_ */
diff --git a/TESTING/LIN/cerrrfp.c b/TESTING/LIN/cerrrfp.c
new file mode 100644
index 0000000..e4c407d
--- /dev/null
+++ b/TESTING/LIN/cerrrfp.c
@@ -0,0 +1,360 @@
+/* cerrrfp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+
+/* Subroutine */ int cerrrfp_(integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002COMPLEX RFP routines passed the tests "
+ "of the \002,\002error exits\002)";
+ static char fmt_9998[] = "(\002 *** RFP routines failed the tests of the"
+ " error \002,\002exits ***\002)";
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), e_wsfe(void);
+
+ /* Local variables */
+ complex a[1] /* was [1][1] */, b[1] /* was [1][1] */, beta;
+ integer info;
+ complex alpha;
+ extern /* Subroutine */ int chfrk_(char *, char *, char *, integer *,
+ integer *, complex *, complex *, integer *, complex *, complex *), ctfsm_(char *, char *, char *, char *,
+ char *, integer *, integer *, complex *, complex *, complex *,
+ integer *), chkxer_(char *
+, integer *, integer *, logical *, logical *), cpftrf_(
+ char *, char *, integer *, complex *, integer *),
+ cpftri_(char *, char *, integer *, complex *, integer *), ctftri_(char *, char *, char *, integer *, complex *,
+ integer *), cpftrs_(char *, char *,
+ integer *, integer *, complex *, complex *, integer *, integer *), ctfttp_(char *, char *, integer *, complex *,
+ complex *, integer *), ctpttf_(char *, char *,
+ integer *, complex *, complex *, integer *),
+ ctfttr_(char *, char *, integer *, complex *, complex *, integer *
+, integer *), ctrttf_(char *, char *, integer *,
+ complex *, integer *, complex *, integer *),
+ ctpttr_(char *, integer *, complex *, complex *, integer *,
+ integer *), ctrttp_(char *, integer *, complex *, integer
+ *, complex *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___7 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERRRFP tests the error exits for the COMPLEX driver routines */
+/* for solving linear systems of equations. */
+
+/* CDRVRFP tests the COMPLEX LAPACK RFP routines: */
+/* CTFSM, CTFTRI, CHFRK, CTFTTP, CTFTTR, CPFTRF, CPFTRS, CTPTTF, */
+/* CTPTTR, CTRTTF, and CTRTTP */
+
+/* Arguments */
+/* ========= */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ infoc_1.ok = TRUE_;
+ a[0].r = 1.f, a[0].i = 1.f;
+ b[0].r = 1.f, b[0].i = 1.f;
+ alpha.r = 1.f, alpha.i = 1.f;
+ beta.r = 1.f, beta.i = 1.f;
+
+ s_copy(srnamc_1.srnamt, "CPFTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpftrf_("/", "U", &c__0, a, &info);
+ chkxer_("CPFTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpftrf_("N", "/", &c__0, a, &info);
+ chkxer_("CPFTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpftrf_("N", "U", &c_n1, a, &info);
+ chkxer_("CPFTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "CPFTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpftrs_("/", "U", &c__0, &c__0, a, b, &c__1, &info);
+ chkxer_("CPFTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpftrs_("N", "/", &c__0, &c__0, a, b, &c__1, &info);
+ chkxer_("CPFTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpftrs_("N", "U", &c_n1, &c__0, a, b, &c__1, &info);
+ chkxer_("CPFTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cpftrs_("N", "U", &c__0, &c_n1, a, b, &c__1, &info);
+ chkxer_("CPFTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cpftrs_("N", "U", &c__0, &c__0, a, b, &c__0, &info);
+ chkxer_("CPFTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "CPFTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpftri_("/", "U", &c__0, a, &info);
+ chkxer_("CPFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpftri_("N", "/", &c__0, a, &info);
+ chkxer_("CPFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpftri_("N", "U", &c_n1, a, &info);
+ chkxer_("CPFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "CTFSM ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctfsm_("/", "L", "U", "C", "U", &c__0, &c__0, &alpha, a, b, &c__1);
+ chkxer_("CTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctfsm_("N", "/", "U", "C", "U", &c__0, &c__0, &alpha, a, b, &c__1);
+ chkxer_("CTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ctfsm_("N", "L", "/", "C", "U", &c__0, &c__0, &alpha, a, b, &c__1);
+ chkxer_("CTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ctfsm_("N", "L", "U", "/", "U", &c__0, &c__0, &alpha, a, b, &c__1);
+ chkxer_("CTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ctfsm_("N", "L", "U", "C", "/", &c__0, &c__0, &alpha, a, b, &c__1);
+ chkxer_("CTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ctfsm_("N", "L", "U", "C", "U", &c_n1, &c__0, &alpha, a, b, &c__1);
+ chkxer_("CTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ctfsm_("N", "L", "U", "C", "U", &c__0, &c_n1, &alpha, a, b, &c__1);
+ chkxer_("CTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ ctfsm_("N", "L", "U", "C", "U", &c__0, &c__0, &alpha, a, b, &c__0);
+ chkxer_("CTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "CTFTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctftri_("/", "L", "N", &c__0, a, &info);
+ chkxer_("CTFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctftri_("N", "/", "N", &c__0, a, &info);
+ chkxer_("CTFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ctftri_("N", "L", "/", &c__0, a, &info);
+ chkxer_("CTFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ctftri_("N", "L", "N", &c_n1, a, &info);
+ chkxer_("CTFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "CTFTTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctfttr_("/", "U", &c__0, a, b, &c__1, &info);
+ chkxer_("CTFTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctfttr_("N", "/", &c__0, a, b, &c__1, &info);
+ chkxer_("CTFTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ctfttr_("N", "U", &c_n1, a, b, &c__1, &info);
+ chkxer_("CTFTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ctfttr_("N", "U", &c__0, a, b, &c__0, &info);
+ chkxer_("CTFTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "CTRTTF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctrttf_("/", "U", &c__0, a, &c__1, b, &info);
+ chkxer_("CTRTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctrttf_("N", "/", &c__0, a, &c__1, b, &info);
+ chkxer_("CTRTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ctrttf_("N", "U", &c_n1, a, &c__1, b, &info);
+ chkxer_("CTRTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrttf_("N", "U", &c__0, a, &c__0, b, &info);
+ chkxer_("CTRTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "CTFTTP", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctfttp_("/", "U", &c__0, a, b, &info);
+ chkxer_("CTFTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctfttp_("N", "/", &c__0, a, b, &info);
+ chkxer_("CTFTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ctfttp_("N", "U", &c_n1, a, b, &info);
+ chkxer_("CTFTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "CTPTTF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctpttf_("/", "U", &c__0, a, b, &info);
+ chkxer_("CTPTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctpttf_("N", "/", &c__0, a, b, &info);
+ chkxer_("CTPTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ctpttf_("N", "U", &c_n1, a, b, &info);
+ chkxer_("CTPTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "CTRTTP", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctrttp_("/", &c__0, a, &c__1, b, &info);
+ chkxer_("CTRTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctrttp_("U", &c_n1, a, &c__1, b, &info);
+ chkxer_("CTRTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ctrttp_("U", &c__0, a, &c__0, b, &info);
+ chkxer_("CTRTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "CTPTTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctpttr_("/", &c__0, a, b, &c__1, &info);
+ chkxer_("CTPTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctpttr_("U", &c_n1, a, b, &c__1, &info);
+ chkxer_("CTPTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ctpttr_("U", &c__0, a, b, &c__0, &info);
+ chkxer_("CTPTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "CHFRK ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chfrk_("/", "U", "N", &c__0, &c__0, &alpha, a, &c__1, &beta, b);
+ chkxer_("CHFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chfrk_("N", "/", "N", &c__0, &c__0, &alpha, a, &c__1, &beta, b);
+ chkxer_("CHFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ chfrk_("N", "U", "/", &c__0, &c__0, &alpha, a, &c__1, &beta, b);
+ chkxer_("CHFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ chfrk_("N", "U", "N", &c_n1, &c__0, &alpha, a, &c__1, &beta, b);
+ chkxer_("CHFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ chfrk_("N", "U", "N", &c__0, &c_n1, &alpha, a, &c__1, &beta, b);
+ chkxer_("CHFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ chfrk_("N", "U", "N", &c__0, &c__0, &alpha, a, &c__0, &beta, b);
+ chkxer_("CHFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___6.ciunit = infoc_1.nout;
+ s_wsfe(&io___6);
+ e_wsfe();
+ } else {
+ io___7.ciunit = infoc_1.nout;
+ s_wsfe(&io___7);
+ e_wsfe();
+ }
+
+ return 0;
+
+/* End of CERRRFP */
+
+} /* cerrrfp_ */
diff --git a/TESTING/LIN/cerrrq.c b/TESTING/LIN/cerrrq.c
new file mode 100644
index 0000000..ff1c6f0
--- /dev/null
+++ b/TESTING/LIN/cerrrq.c
@@ -0,0 +1,392 @@
+/* cerrrq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int cerrrq_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ complex a[4] /* was [2][2] */, b[2];
+ integer i__, j;
+ complex w[2], x[2], af[4] /* was [2][2] */;
+ integer info;
+ extern /* Subroutine */ int cgerq2_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *), cungr2_(integer *,
+ integer *, integer *, complex *, integer *, complex *, complex *,
+ integer *), cunmr2_(char *, char *, integer *, integer *, integer
+ *, complex *, integer *, complex *, complex *, integer *, complex
+ *, integer *), alaesm_(char *, logical *, integer
+ *), cgerqf_(integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *, integer *), cgerqs_(integer *,
+ integer *, integer *, complex *, integer *, complex *, complex *,
+ integer *, complex *, integer *, integer *), chkxer_(char *,
+ integer *, integer *, logical *, logical *), cungrq_(
+ integer *, integer *, integer *, complex *, integer *, complex *,
+ complex *, integer *, integer *), cunmrq_(char *, char *, integer
+ *, integer *, integer *, complex *, integer *, complex *, complex
+ *, integer *, complex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERRRQ tests the error exits for the COMPLEX routines */
+/* that use the RQ decomposition of a general matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 2; ++j) {
+ for (i__ = 1; i__ <= 2; ++i__) {
+ i__1 = i__ + (j << 1) - 3;
+ r__1 = 1.f / (real) (i__ + j);
+ r__2 = -1.f / (real) (i__ + j);
+ q__1.r = r__1, q__1.i = r__2;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = i__ + (j << 1) - 3;
+ r__1 = 1.f / (real) (i__ + j);
+ r__2 = -1.f / (real) (i__ + j);
+ q__1.r = r__1, q__1.i = r__2;
+ af[i__1].r = q__1.r, af[i__1].i = q__1.i;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0.f, b[i__1].i = 0.f;
+ i__1 = j - 1;
+ w[i__1].r = 0.f, w[i__1].i = 0.f;
+ i__1 = j - 1;
+ x[i__1].r = 0.f, x[i__1].i = 0.f;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+/* Error exits for RQ factorization */
+
+/* CGERQF */
+
+ s_copy(srnamc_1.srnamt, "CGERQF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgerqf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
+ chkxer_("CGERQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgerqf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("CGERQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgerqf_(&c__2, &c__1, a, &c__1, b, w, &c__2, &info);
+ chkxer_("CGERQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cgerqf_(&c__2, &c__1, a, &c__2, b, w, &c__1, &info);
+ chkxer_("CGERQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGERQ2 */
+
+ s_copy(srnamc_1.srnamt, "CGERQ2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgerq2_(&c_n1, &c__0, a, &c__1, b, w, &info);
+ chkxer_("CGERQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgerq2_(&c__0, &c_n1, a, &c__1, b, w, &info);
+ chkxer_("CGERQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgerq2_(&c__2, &c__1, a, &c__1, b, w, &info);
+ chkxer_("CGERQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGERQS */
+
+ s_copy(srnamc_1.srnamt, "CGERQS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgerqs_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("CGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgerqs_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("CGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgerqs_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
+ chkxer_("CGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgerqs_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("CGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgerqs_(&c__2, &c__2, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
+ chkxer_("CGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cgerqs_(&c__2, &c__2, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
+ chkxer_("CGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cgerqs_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("CGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CUNGRQ */
+
+ s_copy(srnamc_1.srnamt, "CUNGRQ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cungrq_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("CUNGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cungrq_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("CUNGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cungrq_(&c__2, &c__1, &c__0, a, &c__2, x, w, &c__2, &info);
+ chkxer_("CUNGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cungrq_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
+ chkxer_("CUNGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cungrq_(&c__1, &c__2, &c__2, a, &c__1, x, w, &c__1, &info);
+ chkxer_("CUNGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cungrq_(&c__2, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
+ chkxer_("CUNGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cungrq_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
+ chkxer_("CUNGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CUNGR2 */
+
+ s_copy(srnamc_1.srnamt, "CUNGR2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cungr2_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
+ chkxer_("CUNGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cungr2_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("CUNGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cungr2_(&c__2, &c__1, &c__0, a, &c__2, x, w, &info);
+ chkxer_("CUNGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cungr2_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
+ chkxer_("CUNGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cungr2_(&c__1, &c__2, &c__2, a, &c__2, x, w, &info);
+ chkxer_("CUNGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cungr2_(&c__2, &c__2, &c__0, a, &c__1, x, w, &info);
+ chkxer_("CUNGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CUNMRQ */
+
+ s_copy(srnamc_1.srnamt, "CUNMRQ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cunmrq_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cunmrq_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cunmrq_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cunmrq_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunmrq_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunmrq_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunmrq_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cunmrq_("L", "N", &c__2, &c__1, &c__2, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("CUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cunmrq_("R", "N", &c__1, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cunmrq_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cunmrq_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("CUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cunmrq_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("CUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CUNMR2 */
+
+ s_copy(srnamc_1.srnamt, "CUNMR2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cunmr2_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cunmr2_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cunmr2_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cunmr2_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunmr2_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunmr2_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cunmr2_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cunmr2_("L", "N", &c__2, &c__1, &c__2, a, &c__1, x, af, &c__2, w, &info);
+ chkxer_("CUNMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cunmr2_("R", "N", &c__1, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cunmr2_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("CUNMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of CERRRQ */
+
+} /* cerrrq_ */
diff --git a/TESTING/LIN/cerrsy.c b/TESTING/LIN/cerrsy.c
new file mode 100644
index 0000000..ff7917c
--- /dev/null
+++ b/TESTING/LIN/cerrsy.c
@@ -0,0 +1,406 @@
+/* cerrsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__4 = 4;
+
+/* Subroutine */ int cerrsy_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ complex a[16] /* was [4][4] */, b[4];
+ integer i__, j;
+ real r__[4];
+ complex w[8], x[4];
+ char c2[2];
+ real r1[4], r2[4];
+ complex af[16] /* was [4][4] */;
+ integer ip[4], info;
+ real anrm, rcond;
+ extern /* Subroutine */ int csytf2_(char *, integer *, complex *, integer
+ *, integer *, integer *), alaesm_(char *, logical *,
+ integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), cspcon_(char *, integer *, complex *,
+ integer *, real *, real *, complex *, integer *), csycon_(
+ char *, integer *, complex *, integer *, integer *, real *, real *
+, complex *, integer *), csprfs_(char *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, real *, complex *, real *, integer *
+), csptrf_(char *, integer *, complex *, integer *,
+ integer *), csptri_(char *, integer *, complex *, integer
+ *, complex *, integer *), csyrfs_(char *, integer *,
+ integer *, complex *, integer *, complex *, integer *, integer *,
+ complex *, integer *, complex *, integer *, real *, real *,
+ complex *, real *, integer *), csytrf_(char *, integer *,
+ complex *, integer *, integer *, complex *, integer *, integer *), csytri_(char *, integer *, complex *, integer *, integer
+ *, complex *, integer *), csptrs_(char *, integer *,
+ integer *, complex *, integer *, complex *, integer *, integer *), csytrs_(char *, integer *, integer *, complex *, integer
+ *, integer *, complex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERRSY tests the error exits for the COMPLEX routines */
+/* for symmetric indefinite matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ r__1 = 1.f / (real) (i__ + j);
+ r__2 = -1.f / (real) (i__ + j);
+ q__1.r = r__1, q__1.i = r__2;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = i__ + (j << 2) - 5;
+ r__1 = 1.f / (real) (i__ + j);
+ r__2 = -1.f / (real) (i__ + j);
+ q__1.r = r__1, q__1.i = r__2;
+ af[i__1].r = q__1.r, af[i__1].i = q__1.i;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0.f, b[i__1].i = 0.f;
+ r1[j - 1] = 0.f;
+ r2[j - 1] = 0.f;
+ i__1 = j - 1;
+ w[i__1].r = 0.f, w[i__1].i = 0.f;
+ i__1 = j - 1;
+ x[i__1].r = 0.f, x[i__1].i = 0.f;
+ ip[j - 1] = j;
+/* L20: */
+ }
+ anrm = 1.f;
+ infoc_1.ok = TRUE_;
+
+/* Test error exits of the routines that use the diagonal pivoting */
+/* factorization of a symmetric indefinite matrix. */
+
+ if (lsamen_(&c__2, c2, "SY")) {
+
+/* CSYTRF */
+
+ s_copy(srnamc_1.srnamt, "CSYTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ csytrf_("/", &c__0, a, &c__1, ip, w, &c__1, &info);
+ chkxer_("CSYTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ csytrf_("U", &c_n1, a, &c__1, ip, w, &c__1, &info);
+ chkxer_("CSYTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ csytrf_("U", &c__2, a, &c__1, ip, w, &c__4, &info);
+ chkxer_("CSYTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CSYTF2 */
+
+ s_copy(srnamc_1.srnamt, "CSYTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ csytf2_("/", &c__0, a, &c__1, ip, &info);
+ chkxer_("CSYTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ csytf2_("U", &c_n1, a, &c__1, ip, &info);
+ chkxer_("CSYTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ csytf2_("U", &c__2, a, &c__1, ip, &info);
+ chkxer_("CSYTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CSYTRI */
+
+ s_copy(srnamc_1.srnamt, "CSYTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ csytri_("/", &c__0, a, &c__1, ip, w, &info);
+ chkxer_("CSYTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ csytri_("U", &c_n1, a, &c__1, ip, w, &info);
+ chkxer_("CSYTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ csytri_("U", &c__2, a, &c__1, ip, w, &info);
+ chkxer_("CSYTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CSYTRS */
+
+ s_copy(srnamc_1.srnamt, "CSYTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ csytrs_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("CSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ csytrs_("U", &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("CSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ csytrs_("U", &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("CSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ csytrs_("U", &c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
+ chkxer_("CSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ csytrs_("U", &c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
+ chkxer_("CSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CSYRFS */
+
+ s_copy(srnamc_1.srnamt, "CSYRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ csyrfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ csyrfs_("U", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ csyrfs_("U", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ csyrfs_("U", &c__2, &c__1, a, &c__1, af, &c__2, ip, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("CSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ csyrfs_("U", &c__2, &c__1, a, &c__2, af, &c__1, ip, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("CSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ csyrfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__1, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("CSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ csyrfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__2, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("CSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CSYCON */
+
+ s_copy(srnamc_1.srnamt, "CSYCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ csycon_("/", &c__0, a, &c__1, ip, &anrm, &rcond, w, &info);
+ chkxer_("CSYCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ csycon_("U", &c_n1, a, &c__1, ip, &anrm, &rcond, w, &info);
+ chkxer_("CSYCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ csycon_("U", &c__2, a, &c__1, ip, &anrm, &rcond, w, &info);
+ chkxer_("CSYCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ r__1 = -anrm;
+ csycon_("U", &c__1, a, &c__1, ip, &r__1, &rcond, w, &info);
+ chkxer_("CSYCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Test error exits of the routines that use the diagonal pivoting */
+/* factorization of a symmetric indefinite packed matrix. */
+
+ } else if (lsamen_(&c__2, c2, "SP")) {
+
+/* CSPTRF */
+
+ s_copy(srnamc_1.srnamt, "CSPTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ csptrf_("/", &c__0, a, ip, &info);
+ chkxer_("CSPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ csptrf_("U", &c_n1, a, ip, &info);
+ chkxer_("CSPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CSPTRI */
+
+ s_copy(srnamc_1.srnamt, "CSPTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ csptri_("/", &c__0, a, ip, w, &info);
+ chkxer_("CSPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ csptri_("U", &c_n1, a, ip, w, &info);
+ chkxer_("CSPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CSPTRS */
+
+ s_copy(srnamc_1.srnamt, "CSPTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ csptrs_("/", &c__0, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("CSPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ csptrs_("U", &c_n1, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("CSPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ csptrs_("U", &c__0, &c_n1, a, ip, b, &c__1, &info);
+ chkxer_("CSPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ csptrs_("U", &c__2, &c__1, a, ip, b, &c__1, &info);
+ chkxer_("CSPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CSPRFS */
+
+ s_copy(srnamc_1.srnamt, "CSPRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ csprfs_("/", &c__0, &c__0, a, af, ip, b, &c__1, x, &c__1, r1, r2, w,
+ r__, &info);
+ chkxer_("CSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ csprfs_("U", &c_n1, &c__0, a, af, ip, b, &c__1, x, &c__1, r1, r2, w,
+ r__, &info);
+ chkxer_("CSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ csprfs_("U", &c__0, &c_n1, a, af, ip, b, &c__1, x, &c__1, r1, r2, w,
+ r__, &info);
+ chkxer_("CSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ csprfs_("U", &c__2, &c__1, a, af, ip, b, &c__1, x, &c__2, r1, r2, w,
+ r__, &info);
+ chkxer_("CSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ csprfs_("U", &c__2, &c__1, a, af, ip, b, &c__2, x, &c__1, r1, r2, w,
+ r__, &info);
+ chkxer_("CSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CSPCON */
+
+ s_copy(srnamc_1.srnamt, "CSPCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cspcon_("/", &c__0, a, ip, &anrm, &rcond, w, &info);
+ chkxer_("CSPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cspcon_("U", &c_n1, a, ip, &anrm, &rcond, w, &info);
+ chkxer_("CSPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ r__1 = -anrm;
+ cspcon_("U", &c__1, a, ip, &r__1, &rcond, w, &info);
+ chkxer_("CSPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of CERRSY */
+
+} /* cerrsy_ */
diff --git a/TESTING/LIN/cerrtr.c b/TESTING/LIN/cerrtr.c
new file mode 100644
index 0000000..817e6ad
--- /dev/null
+++ b/TESTING/LIN/cerrtr.c
@@ -0,0 +1,600 @@
+/* cerrtr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cerrtr_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ complex a[4] /* was [2][2] */, b[2], w[2], x[2];
+ char c2[2];
+ real r1[2], r2[2], rw[2];
+ integer info;
+ real scale, rcond;
+ extern /* Subroutine */ int ctrti2_(char *, char *, integer *, complex *,
+ integer *, integer *), alaesm_(char *, logical *,
+ integer *), clatbs_(char *, char *, char *, char *,
+ integer *, integer *, complex *, integer *, complex *, real *,
+ real *, integer *), ctbcon_(char *
+, char *, char *, integer *, integer *, complex *, integer *,
+ real *, complex *, real *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int ctbrfs_(char *, char *, char *, integer *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, real *, complex *, real *, integer *
+), chkxer_(char *, integer *, integer *,
+ logical *, logical *), clatps_(char *, char *, char *,
+ char *, integer *, complex *, complex *, real *, real *, integer *
+), ctpcon_(char *, char *, char *,
+ integer *, complex *, real *, complex *, real *, integer *), clatrs_(char *, char *, char *, char *,
+ integer *, complex *, integer *, complex *, real *, real *,
+ integer *), ctrcon_(char *, char *
+, char *, integer *, complex *, integer *, real *, complex *,
+ real *, integer *), ctbtrs_(char *, char *
+, char *, integer *, integer *, integer *, complex *, integer *,
+ complex *, integer *, integer *), ctprfs_(
+ char *, char *, char *, integer *, integer *, complex *, complex *
+, integer *, complex *, integer *, real *, real *, complex *,
+ real *, integer *), ctrrfs_(char *, char *
+, char *, integer *, integer *, complex *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *, complex *, real *
+, integer *), ctptri_(char *, char *,
+ integer *, complex *, integer *), ctrtri_(char *,
+ char *, integer *, complex *, integer *, integer *), ctptrs_(char *, char *, char *, integer *, integer *,
+ complex *, complex *, integer *, integer *), ctrtrs_(char *, char *, char *, integer *, integer *,
+ complex *, integer *, complex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERRTR tests the error exits for the COMPLEX triangular routines. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ a[0].r = 1.f, a[0].i = 0.f;
+ a[2].r = 2.f, a[2].i = 0.f;
+ a[3].r = 3.f, a[3].i = 0.f;
+ a[1].r = 4.f, a[1].i = 0.f;
+ infoc_1.ok = TRUE_;
+
+/* Test error exits for the general triangular routines. */
+
+ if (lsamen_(&c__2, c2, "TR")) {
+
+/* CTRTRI */
+
+ s_copy(srnamc_1.srnamt, "CTRTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctrtri_("/", "N", &c__0, a, &c__1, &info);
+ chkxer_("CTRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctrtri_("U", "/", &c__0, a, &c__1, &info);
+ chkxer_("CTRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ctrtri_("U", "N", &c_n1, a, &c__1, &info);
+ chkxer_("CTRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrtri_("U", "N", &c__2, a, &c__1, &info);
+ chkxer_("CTRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CTRTI2 */
+
+ s_copy(srnamc_1.srnamt, "CTRTI2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctrti2_("/", "N", &c__0, a, &c__1, &info);
+ chkxer_("CTRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctrti2_("U", "/", &c__0, a, &c__1, &info);
+ chkxer_("CTRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ctrti2_("U", "N", &c_n1, a, &c__1, &info);
+ chkxer_("CTRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrti2_("U", "N", &c__2, a, &c__1, &info);
+ chkxer_("CTRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+
+/* CTRTRS */
+
+ s_copy(srnamc_1.srnamt, "CTRTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctrtrs_("/", "N", "N", &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("CTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctrtrs_("U", "/", "N", &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("CTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ctrtrs_("U", "N", "/", &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("CTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ctrtrs_("U", "N", "N", &c_n1, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("CTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrtrs_("U", "N", "N", &c__0, &c_n1, a, &c__1, x, &c__1, &info);
+ chkxer_("CTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+
+/* CTRRFS */
+
+ s_copy(srnamc_1.srnamt, "CTRRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctrrfs_("/", "N", "N", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
+ r2, w, rw, &info);
+ chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctrrfs_("U", "/", "N", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
+ r2, w, rw, &info);
+ chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ctrrfs_("U", "N", "/", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
+ r2, w, rw, &info);
+ chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ctrrfs_("U", "N", "N", &c_n1, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
+ r2, w, rw, &info);
+ chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ctrrfs_("U", "N", "N", &c__0, &c_n1, a, &c__1, b, &c__1, x, &c__1, r1,
+ r2, w, rw, &info);
+ chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ctrrfs_("U", "N", "N", &c__2, &c__1, a, &c__1, b, &c__2, x, &c__2, r1,
+ r2, w, rw, &info);
+ chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ ctrrfs_("U", "N", "N", &c__2, &c__1, a, &c__2, b, &c__1, x, &c__2, r1,
+ r2, w, rw, &info);
+ chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ ctrrfs_("U", "N", "N", &c__2, &c__1, a, &c__2, b, &c__2, x, &c__1, r1,
+ r2, w, rw, &info);
+ chkxer_("CTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CTRCON */
+
+ s_copy(srnamc_1.srnamt, "CTRCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctrcon_("/", "U", "N", &c__0, a, &c__1, &rcond, w, rw, &info);
+ chkxer_("CTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctrcon_("1", "/", "N", &c__0, a, &c__1, &rcond, w, rw, &info);
+ chkxer_("CTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ctrcon_("1", "U", "/", &c__0, a, &c__1, &rcond, w, rw, &info);
+ chkxer_("CTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ctrcon_("1", "U", "N", &c_n1, a, &c__1, &rcond, w, rw, &info);
+ chkxer_("CTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ctrcon_("1", "U", "N", &c__2, a, &c__1, &rcond, w, rw, &info);
+ chkxer_("CTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CLATRS */
+
+ s_copy(srnamc_1.srnamt, "CLATRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ clatrs_("/", "N", "N", "N", &c__0, a, &c__1, x, &scale, rw, &info);
+ chkxer_("CLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ clatrs_("U", "/", "N", "N", &c__0, a, &c__1, x, &scale, rw, &info);
+ chkxer_("CLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ clatrs_("U", "N", "/", "N", &c__0, a, &c__1, x, &scale, rw, &info);
+ chkxer_("CLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ clatrs_("U", "N", "N", "/", &c__0, a, &c__1, x, &scale, rw, &info);
+ chkxer_("CLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ clatrs_("U", "N", "N", "N", &c_n1, a, &c__1, x, &scale, rw, &info);
+ chkxer_("CLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ clatrs_("U", "N", "N", "N", &c__2, a, &c__1, x, &scale, rw, &info);
+ chkxer_("CLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Test error exits for the packed triangular routines. */
+
+ } else if (lsamen_(&c__2, c2, "TP")) {
+
+/* CTPTRI */
+
+ s_copy(srnamc_1.srnamt, "CTPTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctptri_("/", "N", &c__0, a, &info);
+ chkxer_("CTPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctptri_("U", "/", &c__0, a, &info);
+ chkxer_("CTPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ctptri_("U", "N", &c_n1, a, &info);
+ chkxer_("CTPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CTPTRS */
+
+ s_copy(srnamc_1.srnamt, "CTPTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctptrs_("/", "N", "N", &c__0, &c__0, a, x, &c__1, &info);
+ chkxer_("CTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctptrs_("U", "/", "N", &c__0, &c__0, a, x, &c__1, &info);
+ chkxer_("CTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ctptrs_("U", "N", "/", &c__0, &c__0, a, x, &c__1, &info);
+ chkxer_("CTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ctptrs_("U", "N", "N", &c_n1, &c__0, a, x, &c__1, &info);
+ chkxer_("CTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ctptrs_("U", "N", "N", &c__0, &c_n1, a, x, &c__1, &info);
+ chkxer_("CTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ctptrs_("U", "N", "N", &c__2, &c__1, a, x, &c__1, &info);
+ chkxer_("CTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CTPRFS */
+
+ s_copy(srnamc_1.srnamt, "CTPRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctprfs_("/", "N", "N", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
+ rw, &info);
+ chkxer_("CTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctprfs_("U", "/", "N", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
+ rw, &info);
+ chkxer_("CTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ctprfs_("U", "N", "/", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
+ rw, &info);
+ chkxer_("CTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ctprfs_("U", "N", "N", &c_n1, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
+ rw, &info);
+ chkxer_("CTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ctprfs_("U", "N", "N", &c__0, &c_n1, a, b, &c__1, x, &c__1, r1, r2, w,
+ rw, &info);
+ chkxer_("CTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ctprfs_("U", "N", "N", &c__2, &c__1, a, b, &c__1, x, &c__2, r1, r2, w,
+ rw, &info);
+ chkxer_("CTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ctprfs_("U", "N", "N", &c__2, &c__1, a, b, &c__2, x, &c__1, r1, r2, w,
+ rw, &info);
+ chkxer_("CTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CTPCON */
+
+ s_copy(srnamc_1.srnamt, "CTPCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctpcon_("/", "U", "N", &c__0, a, &rcond, w, rw, &info);
+ chkxer_("CTPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctpcon_("1", "/", "N", &c__0, a, &rcond, w, rw, &info);
+ chkxer_("CTPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ctpcon_("1", "U", "/", &c__0, a, &rcond, w, rw, &info);
+ chkxer_("CTPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ctpcon_("1", "U", "N", &c_n1, a, &rcond, w, rw, &info);
+ chkxer_("CTPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CLATPS */
+
+ s_copy(srnamc_1.srnamt, "CLATPS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ clatps_("/", "N", "N", "N", &c__0, a, x, &scale, rw, &info);
+ chkxer_("CLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ clatps_("U", "/", "N", "N", &c__0, a, x, &scale, rw, &info);
+ chkxer_("CLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ clatps_("U", "N", "/", "N", &c__0, a, x, &scale, rw, &info);
+ chkxer_("CLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ clatps_("U", "N", "N", "/", &c__0, a, x, &scale, rw, &info);
+ chkxer_("CLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ clatps_("U", "N", "N", "N", &c_n1, a, x, &scale, rw, &info);
+ chkxer_("CLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Test error exits for the banded triangular routines. */
+
+ } else if (lsamen_(&c__2, c2, "TB")) {
+
+/* CTBTRS */
+
+ s_copy(srnamc_1.srnamt, "CTBTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctbtrs_("/", "N", "N", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctbtrs_("U", "/", "N", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ctbtrs_("U", "N", "/", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ctbtrs_("U", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ctbtrs_("U", "N", "N", &c__0, &c_n1, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ctbtrs_("U", "N", "N", &c__0, &c__0, &c_n1, a, &c__1, x, &c__1, &info);
+ chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ctbtrs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__1, x, &c__2, &info);
+ chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ctbtrs_("U", "N", "N", &c__2, &c__0, &c__1, a, &c__1, x, &c__1, &info);
+ chkxer_("CTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CTBRFS */
+
+ s_copy(srnamc_1.srnamt, "CTBRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctbrfs_("/", "N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, rw, &info);
+ chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctbrfs_("U", "/", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, rw, &info);
+ chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ctbrfs_("U", "N", "/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, rw, &info);
+ chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ctbrfs_("U", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, rw, &info);
+ chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ctbrfs_("U", "N", "N", &c__0, &c_n1, &c__0, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, rw, &info);
+ chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ctbrfs_("U", "N", "N", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, rw, &info);
+ chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ctbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__1, b, &c__2, x, &
+ c__2, r1, r2, w, rw, &info);
+ chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ctbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__1, x, &
+ c__2, r1, r2, w, rw, &info);
+ chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ ctbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, x, &
+ c__1, r1, r2, w, rw, &info);
+ chkxer_("CTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CTBCON */
+
+ s_copy(srnamc_1.srnamt, "CTBCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctbcon_("/", "U", "N", &c__0, &c__0, a, &c__1, &rcond, w, rw, &info);
+ chkxer_("CTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctbcon_("1", "/", "N", &c__0, &c__0, a, &c__1, &rcond, w, rw, &info);
+ chkxer_("CTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ctbcon_("1", "U", "/", &c__0, &c__0, a, &c__1, &rcond, w, rw, &info);
+ chkxer_("CTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ctbcon_("1", "U", "N", &c_n1, &c__0, a, &c__1, &rcond, w, rw, &info);
+ chkxer_("CTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ctbcon_("1", "U", "N", &c__0, &c_n1, a, &c__1, &rcond, w, rw, &info);
+ chkxer_("CTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ctbcon_("1", "U", "N", &c__2, &c__1, a, &c__1, &rcond, w, rw, &info);
+ chkxer_("CTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CLATBS */
+
+ s_copy(srnamc_1.srnamt, "CLATBS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ clatbs_("/", "N", "N", "N", &c__0, &c__0, a, &c__1, x, &scale, rw, &
+ info);
+ chkxer_("CLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ clatbs_("U", "/", "N", "N", &c__0, &c__0, a, &c__1, x, &scale, rw, &
+ info);
+ chkxer_("CLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ clatbs_("U", "N", "/", "N", &c__0, &c__0, a, &c__1, x, &scale, rw, &
+ info);
+ chkxer_("CLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ clatbs_("U", "N", "N", "/", &c__0, &c__0, a, &c__1, x, &scale, rw, &
+ info);
+ chkxer_("CLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ clatbs_("U", "N", "N", "N", &c_n1, &c__0, a, &c__1, x, &scale, rw, &
+ info);
+ chkxer_("CLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ clatbs_("U", "N", "N", "N", &c__1, &c_n1, a, &c__1, x, &scale, rw, &
+ info);
+ chkxer_("CLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ clatbs_("U", "N", "N", "N", &c__2, &c__1, a, &c__1, x, &scale, rw, &
+ info);
+ chkxer_("CLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of CERRTR */
+
+} /* cerrtr_ */
diff --git a/TESTING/LIN/cerrtz.c b/TESTING/LIN/cerrtz.c
new file mode 100644
index 0000000..bcfe3fc
--- /dev/null
+++ b/TESTING/LIN/cerrtz.c
@@ -0,0 +1,164 @@
+/* cerrtz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int cerrtz_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void);
+
+ /* Local variables */
+ complex a[4] /* was [2][2] */, w[2];
+ char c2[2];
+ complex tau[2];
+ integer info;
+ extern /* Subroutine */ int alaesm_(char *, logical *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), ctzrqf_(integer *, integer *, complex *,
+ integer *, complex *, integer *), ctzrzf_(integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___4 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERRTZ tests the error exits for CTZRQF and CTZRZF. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ a[0].r = 1.f, a[0].i = -1.f;
+ a[2].r = 2.f, a[2].i = -2.f;
+ a[3].r = 3.f, a[3].i = -3.f;
+ a[1].r = 4.f, a[1].i = -4.f;
+ w[0].r = 0.f, w[0].i = 0.f;
+ w[1].r = 0.f, w[1].i = 0.f;
+ infoc_1.ok = TRUE_;
+
+/* Test error exits for the trapezoidal routines. */
+
+ io___4.ciunit = infoc_1.nout;
+ s_wsle(&io___4);
+ e_wsle();
+ if (lsamen_(&c__2, c2, "TZ")) {
+
+/* CTZRQF */
+
+ s_copy(srnamc_1.srnamt, "CTZRQF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctzrqf_(&c_n1, &c__0, a, &c__1, tau, &info);
+ chkxer_("CTZRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctzrqf_(&c__1, &c__0, a, &c__1, tau, &info);
+ chkxer_("CTZRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ctzrqf_(&c__2, &c__2, a, &c__1, tau, &info);
+ chkxer_("CTZRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CTZRZF */
+
+ s_copy(srnamc_1.srnamt, "CTZRZF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ctzrzf_(&c_n1, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("CTZRZF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ctzrzf_(&c__1, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("CTZRZF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ctzrzf_(&c__2, &c__2, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("CTZRZF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ctzrzf_(&c__2, &c__2, a, &c__2, tau, w, &c__1, &info);
+ chkxer_("CTZRZF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of CERRTZ */
+
+} /* cerrtz_ */
diff --git a/TESTING/LIN/cerrvx.c b/TESTING/LIN/cerrvx.c
new file mode 100644
index 0000000..6948822
--- /dev/null
+++ b/TESTING/LIN/cerrvx.c
@@ -0,0 +1,1042 @@
+/* cerrvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__4 = 4;
+
+/* Subroutine */ int cerrvx_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 drivers passed the tests of the er"
+ "ror exits\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 drivers failed the test"
+ "s of the error \002,\002exits ***\002)";
+
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ complex a[16] /* was [4][4] */, b[4];
+ real c__[4];
+ integer i__, j;
+ real r__[4];
+ complex w[8], x[4];
+ char c2[2];
+ real r1[4], r2[4];
+ complex af[16] /* was [4][4] */;
+ char eq[1];
+ real rf[4];
+ integer ip[4];
+ real rw[4];
+ integer info;
+ extern /* Subroutine */ int cgbsv_(integer *, integer *, integer *,
+ integer *, complex *, integer *, integer *, complex *, integer *,
+ integer *);
+ real rcond;
+ extern /* Subroutine */ int cgesv_(integer *, integer *, complex *,
+ integer *, integer *, complex *, integer *, integer *), chesv_(
+ char *, integer *, integer *, complex *, integer *, integer *,
+ complex *, integer *, complex *, integer *, integer *),
+ cpbsv_(char *, integer *, integer *, integer *, complex *,
+ integer *, complex *, integer *, integer *), chpsv_(char *
+, integer *, integer *, complex *, integer *, complex *, integer *
+, integer *), cgtsv_(integer *, integer *, complex *,
+ complex *, complex *, complex *, integer *, integer *), cposv_(
+ char *, integer *, integer *, complex *, integer *, complex *,
+ integer *, integer *), cppsv_(char *, integer *, integer *
+, complex *, complex *, integer *, integer *), cspsv_(
+ char *, integer *, integer *, complex *, integer *, complex *,
+ integer *, integer *), cptsv_(integer *, integer *, real *
+, complex *, complex *, integer *, integer *), csysv_(char *,
+ integer *, integer *, complex *, integer *, integer *, complex *,
+ integer *, complex *, integer *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), cgbsvx_(char *, char *, integer *, integer
+ *, integer *, integer *, complex *, integer *, complex *, integer
+ *, integer *, char *, real *, real *, complex *, integer *,
+ complex *, integer *, real *, real *, real *, complex *, real *,
+ integer *), cgesvx_(char *, char *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ integer *, char *, real *, real *, complex *, integer *, complex *
+, integer *, real *, real *, real *, complex *, real *, integer *), chesvx_(char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *, integer *,
+ complex *, integer *, complex *, integer *, real *, real *, real *
+, complex *, integer *, real *, integer *),
+ cpbsvx_(char *, char *, integer *, integer *, integer *, complex *
+, integer *, complex *, integer *, char *, real *, complex *,
+ integer *, complex *, integer *, real *, real *, real *, complex *
+, real *, integer *), chpsvx_(char *,
+ char *, integer *, integer *, complex *, complex *, integer *,
+ complex *, integer *, complex *, integer *, real *, real *, real *
+, complex *, real *, integer *), cgtsvx_(char *,
+ char *, integer *, integer *, complex *, complex *, complex *,
+ complex *, complex *, complex *, complex *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *, real *, complex *
+, real *, integer *), cposvx_(char *, char *,
+ integer *, integer *, complex *, integer *, complex *, integer *,
+ char *, real *, complex *, integer *, complex *, integer *, real *
+, real *, real *, complex *, real *, integer *), cppsvx_(char *, char *, integer *, integer *, complex *,
+ complex *, char *, real *, complex *, integer *, complex *,
+ integer *, real *, real *, real *, complex *, real *, integer *), cspsvx_(char *, char *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, integer *, real *, real *, real *, complex *, real *,
+ integer *), cptsvx_(char *, integer *, integer *,
+ real *, complex *, real *, complex *, complex *, integer *,
+ complex *, integer *, real *, real *, real *, complex *, real *,
+ integer *), csysvx_(char *, char *, integer *, integer *,
+ complex *, integer *, complex *, integer *, integer *, complex *,
+ integer *, complex *, integer *, real *, real *, real *, complex *
+, integer *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___20 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___21 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CERRVX tests the error exits for the COMPLEX driver routines */
+/* for solving linear systems of equations. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ r__1 = 1.f / (real) (i__ + j);
+ r__2 = -1.f / (real) (i__ + j);
+ q__1.r = r__1, q__1.i = r__2;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = i__ + (j << 2) - 5;
+ r__1 = 1.f / (real) (i__ + j);
+ r__2 = -1.f / (real) (i__ + j);
+ q__1.r = r__1, q__1.i = r__2;
+ af[i__1].r = q__1.r, af[i__1].i = q__1.i;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0.f, b[i__1].i = 0.f;
+ r1[j - 1] = 0.f;
+ r2[j - 1] = 0.f;
+ i__1 = j - 1;
+ w[i__1].r = 0.f, w[i__1].i = 0.f;
+ i__1 = j - 1;
+ x[i__1].r = 0.f, x[i__1].i = 0.f;
+ c__[j - 1] = 0.f;
+ r__[j - 1] = 0.f;
+ ip[j - 1] = j;
+/* L20: */
+ }
+ *(unsigned char *)eq = ' ';
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "GE")) {
+
+/* CGESV */
+
+ s_copy(srnamc_1.srnamt, "CGESV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgesv_(&c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("CGESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgesv_(&c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("CGESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgesv_(&c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
+ chkxer_("CGESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cgesv_(&c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
+ chkxer_("CGESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGESVX */
+
+ s_copy(srnamc_1.srnamt, "CGESVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgesvx_("/", "N", &c__0, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgesvx_("N", "/", &c__0, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgesvx_("N", "N", &c_n1, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgesvx_("N", "N", &c__0, &c_n1, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cgesvx_("N", "N", &c__2, &c__1, a, &c__1, af, &c__2, ip, eq, r__, c__,
+ b, &c__2, x, &c__2, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cgesvx_("N", "N", &c__2, &c__1, a, &c__2, af, &c__1, ip, eq, r__, c__,
+ b, &c__2, x, &c__2, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ *(unsigned char *)eq = '/';
+ cgesvx_("F", "N", &c__0, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ *(unsigned char *)eq = 'R';
+ cgesvx_("F", "N", &c__1, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ *(unsigned char *)eq = 'C';
+ cgesvx_("F", "N", &c__1, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ cgesvx_("N", "N", &c__2, &c__1, a, &c__2, af, &c__2, ip, eq, r__, c__,
+ b, &c__1, x, &c__2, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ cgesvx_("N", "N", &c__2, &c__1, a, &c__2, af, &c__2, ip, eq, r__, c__,
+ b, &c__2, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* CGBSV */
+
+ s_copy(srnamc_1.srnamt, "CGBSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgbsv_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("CGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgbsv_(&c__1, &c_n1, &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("CGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgbsv_(&c__1, &c__0, &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("CGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgbsv_(&c__0, &c__0, &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("CGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cgbsv_(&c__1, &c__1, &c__1, &c__0, a, &c__3, ip, b, &c__1, &info);
+ chkxer_("CGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ cgbsv_(&c__2, &c__0, &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("CGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGBSVX */
+
+ s_copy(srnamc_1.srnamt, "CGBSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgbsvx_("/", "N", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("CGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgbsvx_("N", "/", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("CGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgbsvx_("N", "N", &c_n1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("CGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgbsvx_("N", "N", &c__1, &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("CGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cgbsvx_("N", "N", &c__1, &c__0, &c_n1, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("CGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cgbsvx_("N", "N", &c__0, &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("CGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cgbsvx_("N", "N", &c__1, &c__1, &c__1, &c__0, a, &c__2, af, &c__4, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("CGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cgbsvx_("N", "N", &c__1, &c__1, &c__1, &c__0, a, &c__3, af, &c__3, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("CGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ *(unsigned char *)eq = '/';
+ cgbsvx_("F", "N", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("CGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ *(unsigned char *)eq = 'R';
+ cgbsvx_("F", "N", &c__1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("CGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ *(unsigned char *)eq = 'C';
+ cgbsvx_("F", "N", &c__1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("CGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ cgbsvx_("N", "N", &c__2, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__2, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("CGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ cgbsvx_("N", "N", &c__2, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__2, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("CGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "GT")) {
+
+/* CGTSV */
+
+ s_copy(srnamc_1.srnamt, "CGTSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgtsv_(&c_n1, &c__0, a, &a[4], &a[8], b, &c__1, &info);
+ chkxer_("CGTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgtsv_(&c__0, &c_n1, a, &a[4], &a[8], b, &c__1, &info);
+ chkxer_("CGTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cgtsv_(&c__2, &c__0, a, &a[4], &a[8], b, &c__1, &info);
+ chkxer_("CGTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CGTSVX */
+
+ s_copy(srnamc_1.srnamt, "CGTSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cgtsvx_("/", "N", &c__0, &c__0, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cgtsvx_("N", "/", &c__0, &c__0, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cgtsvx_("N", "N", &c_n1, &c__0, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cgtsvx_("N", "N", &c__0, &c_n1, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ cgtsvx_("N", "N", &c__2, &c__0, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__1, x, &c__2, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ cgtsvx_("N", "N", &c__2, &c__0, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__2, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PO")) {
+
+/* CPOSV */
+
+ s_copy(srnamc_1.srnamt, "CPOSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cposv_("/", &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("CPOSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cposv_("U", &c_n1, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("CPOSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cposv_("U", &c__0, &c_n1, a, &c__1, b, &c__1, &info);
+ chkxer_("CPOSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cposv_("U", &c__2, &c__0, a, &c__1, b, &c__2, &info);
+ chkxer_("CPOSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cposv_("U", &c__2, &c__0, a, &c__2, b, &c__1, &info);
+ chkxer_("CPOSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPOSVX */
+
+ s_copy(srnamc_1.srnamt, "CPOSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cposvx_("/", "U", &c__0, &c__0, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cposvx_("N", "/", &c__0, &c__0, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cposvx_("N", "U", &c_n1, &c__0, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cposvx_("N", "U", &c__0, &c_n1, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cposvx_("N", "U", &c__2, &c__0, a, &c__1, af, &c__2, eq, c__, b, &
+ c__2, x, &c__2, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cposvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__1, eq, c__, b, &
+ c__2, x, &c__2, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ *(unsigned char *)eq = '/';
+ cposvx_("F", "U", &c__0, &c__0, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ *(unsigned char *)eq = 'Y';
+ cposvx_("F", "U", &c__1, &c__0, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cposvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, eq, c__, b, &
+ c__1, x, &c__2, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ cposvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, eq, c__, b, &
+ c__2, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PP")) {
+
+/* CPPSV */
+
+ s_copy(srnamc_1.srnamt, "CPPSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cppsv_("/", &c__0, &c__0, a, b, &c__1, &info);
+ chkxer_("CPPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cppsv_("U", &c_n1, &c__0, a, b, &c__1, &info);
+ chkxer_("CPPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cppsv_("U", &c__0, &c_n1, a, b, &c__1, &info);
+ chkxer_("CPPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cppsv_("U", &c__2, &c__0, a, b, &c__1, &info);
+ chkxer_("CPPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPPSVX */
+
+ s_copy(srnamc_1.srnamt, "CPPSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cppsvx_("/", "U", &c__0, &c__0, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, rw, &info);
+ chkxer_("CPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cppsvx_("N", "/", &c__0, &c__0, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, rw, &info);
+ chkxer_("CPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cppsvx_("N", "U", &c_n1, &c__0, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, rw, &info);
+ chkxer_("CPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cppsvx_("N", "U", &c__0, &c_n1, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, rw, &info);
+ chkxer_("CPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ *(unsigned char *)eq = '/';
+ cppsvx_("F", "U", &c__0, &c__0, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, rw, &info);
+ chkxer_("CPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ *(unsigned char *)eq = 'Y';
+ cppsvx_("F", "U", &c__1, &c__0, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, rw, &info);
+ chkxer_("CPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ cppsvx_("N", "U", &c__2, &c__0, a, af, eq, c__, b, &c__1, x, &c__2, &
+ rcond, r1, r2, w, rw, &info);
+ chkxer_("CPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ cppsvx_("N", "U", &c__2, &c__0, a, af, eq, c__, b, &c__2, x, &c__1, &
+ rcond, r1, r2, w, rw, &info);
+ chkxer_("CPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* CPBSV */
+
+ s_copy(srnamc_1.srnamt, "CPBSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpbsv_("/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &info)
+ ;
+ chkxer_("CPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpbsv_("U", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, &info)
+ ;
+ chkxer_("CPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpbsv_("U", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, &info)
+ ;
+ chkxer_("CPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cpbsv_("U", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, &info)
+ ;
+ chkxer_("CPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cpbsv_("U", &c__1, &c__1, &c__0, a, &c__1, b, &c__2, &info)
+ ;
+ chkxer_("CPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ cpbsv_("U", &c__2, &c__0, &c__0, a, &c__1, b, &c__1, &info)
+ ;
+ chkxer_("CPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPBSVX */
+
+ s_copy(srnamc_1.srnamt, "CPBSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cpbsvx_("/", "U", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cpbsvx_("N", "/", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cpbsvx_("N", "U", &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cpbsvx_("N", "U", &c__1, &c_n1, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ cpbsvx_("N", "U", &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cpbsvx_("N", "U", &c__1, &c__1, &c__0, a, &c__1, af, &c__2, eq, c__,
+ b, &c__2, x, &c__2, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ cpbsvx_("N", "U", &c__1, &c__1, &c__0, a, &c__2, af, &c__1, eq, c__,
+ b, &c__2, x, &c__2, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ *(unsigned char *)eq = '/';
+ cpbsvx_("F", "U", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ *(unsigned char *)eq = 'Y';
+ cpbsvx_("F", "U", &c__1, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ cpbsvx_("N", "U", &c__2, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__2, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ cpbsvx_("N", "U", &c__2, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__2, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("CPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PT")) {
+
+/* CPTSV */
+
+ s_copy(srnamc_1.srnamt, "CPTSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cptsv_(&c_n1, &c__0, r__, a, b, &c__1, &info);
+ chkxer_("CPTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cptsv_(&c__0, &c_n1, r__, a, b, &c__1, &info);
+ chkxer_("CPTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ cptsv_(&c__2, &c__0, r__, a, b, &c__1, &info);
+ chkxer_("CPTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CPTSVX */
+
+ s_copy(srnamc_1.srnamt, "CPTSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cptsvx_("/", &c__0, &c__0, r__, a, rf, af, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("CPTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cptsvx_("N", &c_n1, &c__0, r__, a, rf, af, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("CPTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cptsvx_("N", &c__0, &c_n1, r__, a, rf, af, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("CPTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ cptsvx_("N", &c__2, &c__0, r__, a, rf, af, b, &c__1, x, &c__2, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("CPTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ cptsvx_("N", &c__2, &c__0, r__, a, rf, af, b, &c__2, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("CPTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "HE")) {
+
+/* CHESV */
+
+ s_copy(srnamc_1.srnamt, "CHESV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chesv_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("CHESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chesv_("U", &c_n1, &c__0, a, &c__1, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("CHESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ chesv_("U", &c__0, &c_n1, a, &c__1, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("CHESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ chesv_("U", &c__2, &c__0, a, &c__1, ip, b, &c__2, w, &c__1, &info);
+ chkxer_("CHESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ chesv_("U", &c__2, &c__0, a, &c__2, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("CHESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CHESVX */
+
+ s_copy(srnamc_1.srnamt, "CHESVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chesvx_("/", "U", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, rw, &info);
+ chkxer_("CHESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chesvx_("N", "/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, rw, &info);
+ chkxer_("CHESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ chesvx_("N", "U", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, rw, &info);
+ chkxer_("CHESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ chesvx_("N", "U", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, rw, &info);
+ chkxer_("CHESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ chesvx_("N", "U", &c__2, &c__0, a, &c__1, af, &c__2, ip, b, &c__2, x,
+ &c__2, &rcond, r1, r2, w, &c__4, rw, &info);
+ chkxer_("CHESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ chesvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__1, ip, b, &c__2, x,
+ &c__2, &rcond, r1, r2, w, &c__4, rw, &info);
+ chkxer_("CHESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ chesvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, ip, b, &c__1, x,
+ &c__2, &rcond, r1, r2, w, &c__4, rw, &info);
+ chkxer_("CHESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ chesvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, ip, b, &c__2, x,
+ &c__1, &rcond, r1, r2, w, &c__4, rw, &info);
+ chkxer_("CHESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ chesvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, ip, b, &c__2, x,
+ &c__2, &rcond, r1, r2, w, &c__3, rw, &info);
+ chkxer_("CHESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "HP")) {
+
+/* CHPSV */
+
+ s_copy(srnamc_1.srnamt, "CHPSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chpsv_("/", &c__0, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("CHPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chpsv_("U", &c_n1, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("CHPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ chpsv_("U", &c__0, &c_n1, a, ip, b, &c__1, &info);
+ chkxer_("CHPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ chpsv_("U", &c__2, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("CHPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CHPSVX */
+
+ s_copy(srnamc_1.srnamt, "CHPSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ chpsvx_("/", "U", &c__0, &c__0, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("CHPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ chpsvx_("N", "/", &c__0, &c__0, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("CHPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ chpsvx_("N", "U", &c_n1, &c__0, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("CHPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ chpsvx_("N", "U", &c__0, &c_n1, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("CHPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ chpsvx_("N", "U", &c__2, &c__0, a, af, ip, b, &c__1, x, &c__2, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("CHPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ chpsvx_("N", "U", &c__2, &c__0, a, af, ip, b, &c__2, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("CHPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "SY")) {
+
+/* CSYSV */
+
+ s_copy(srnamc_1.srnamt, "CSYSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ csysv_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("CSYSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ csysv_("U", &c_n1, &c__0, a, &c__1, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("CSYSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ csysv_("U", &c__0, &c_n1, a, &c__1, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("CSYSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ csysv_("U", &c__2, &c__0, a, &c__2, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("CSYSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CSYSVX */
+
+ s_copy(srnamc_1.srnamt, "CSYSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ csysvx_("/", "U", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, rw, &info);
+ chkxer_("CSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ csysvx_("N", "/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, rw, &info);
+ chkxer_("CSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ csysvx_("N", "U", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, rw, &info);
+ chkxer_("CSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ csysvx_("N", "U", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, rw, &info);
+ chkxer_("CSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ csysvx_("N", "U", &c__2, &c__0, a, &c__1, af, &c__2, ip, b, &c__2, x,
+ &c__2, &rcond, r1, r2, w, &c__4, rw, &info);
+ chkxer_("CSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ csysvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__1, ip, b, &c__2, x,
+ &c__2, &rcond, r1, r2, w, &c__4, rw, &info);
+ chkxer_("CSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ csysvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, ip, b, &c__1, x,
+ &c__2, &rcond, r1, r2, w, &c__4, rw, &info);
+ chkxer_("CSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ csysvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, ip, b, &c__2, x,
+ &c__1, &rcond, r1, r2, w, &c__4, rw, &info);
+ chkxer_("CSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ csysvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, ip, b, &c__2, x,
+ &c__2, &rcond, r1, r2, w, &c__3, rw, &info);
+ chkxer_("CSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "SP")) {
+
+/* CSPSV */
+
+ s_copy(srnamc_1.srnamt, "CSPSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cspsv_("/", &c__0, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("CSPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cspsv_("U", &c_n1, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("CSPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cspsv_("U", &c__0, &c_n1, a, ip, b, &c__1, &info);
+ chkxer_("CSPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ cspsv_("U", &c__2, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("CSPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* CSPSVX */
+
+ s_copy(srnamc_1.srnamt, "CSPSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ cspsvx_("/", "U", &c__0, &c__0, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("CSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ cspsvx_("N", "/", &c__0, &c__0, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("CSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ cspsvx_("N", "U", &c_n1, &c__0, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("CSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ cspsvx_("N", "U", &c__0, &c_n1, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("CSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ cspsvx_("N", "U", &c__2, &c__0, a, af, ip, b, &c__1, x, &c__2, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("CSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ cspsvx_("N", "U", &c__2, &c__0, a, af, ip, b, &c__2, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("CSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___20.ciunit = infoc_1.nout;
+ s_wsfe(&io___20);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ } else {
+ io___21.ciunit = infoc_1.nout;
+ s_wsfe(&io___21);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of CERRVX */
+
+} /* cerrvx_ */
diff --git a/TESTING/LIN/cgbt01.c b/TESTING/LIN/cgbt01.c
new file mode 100644
index 0000000..8491278
--- /dev/null
+++ b/TESTING/LIN/cgbt01.c
@@ -0,0 +1,247 @@
+/* cgbt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static complex c_b12 = {-1.f,-0.f};
+
+/* Subroutine */ int cgbt01_(integer *m, integer *n, integer *kl, integer *ku,
+ complex *a, integer *lda, complex *afac, integer *ldafac, integer *
+ ipiv, complex *work, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer i__, j;
+ complex t;
+ integer i1, i2, kd, il, jl, ip, ju, iw, jua;
+ real eps;
+ integer lenj;
+ real anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ extern doublereal slamch_(char *), scasum_(integer *, complex *,
+ integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGBT01 reconstructs a band matrix A from its L*U factorization and */
+/* computes the residual: */
+/* norm(L*U - A) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* The expression L*U - A is computed one column at a time, so A and */
+/* AFAC are not modified. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* The original matrix A in band storage, stored in rows 1 to */
+/* KL+KU+1. */
+
+/* LDA (input) INTEGER. */
+/* The leading dimension of the array A. LDA >= max(1,KL+KU+1). */
+
+/* AFAC (input) COMPLEX array, dimension (LDAFAC,N) */
+/* The factored form of the matrix A. AFAC contains the banded */
+/* factors L and U from the L*U factorization, as computed by */
+/* CGBTRF. U is stored as an upper triangular band matrix with */
+/* KL+KU superdiagonals in rows 1 to KL+KU+1, and the */
+/* multipliers used during the factorization are stored in rows */
+/* KL+KU+2 to 2*KL+KU+1. See CGBTRF for further details. */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. */
+/* LDAFAC >= max(1,2*KL*KU+1). */
+
+/* IPIV (input) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices from CGBTRF. */
+
+/* WORK (workspace) COMPLEX array, dimension (2*KL+KU+1) */
+
+/* RESID (output) REAL */
+/* norm(L*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if M = 0 or N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *resid = 0.f;
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+/* Determine EPS and the norm of A. */
+
+ eps = slamch_("Epsilon");
+ kd = *ku + 1;
+ anorm = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = kd + 1 - j;
+ i1 = max(i__2,1);
+/* Computing MIN */
+ i__2 = kd + *m - j, i__3 = *kl + kd;
+ i2 = min(i__2,i__3);
+ if (i2 >= i1) {
+/* Computing MAX */
+ i__2 = i2 - i1 + 1;
+ r__1 = anorm, r__2 = scasum_(&i__2, &a[i1 + j * a_dim1], &c__1);
+ anorm = dmax(r__1,r__2);
+ }
+/* L10: */
+ }
+
+/* Compute one column at a time of L*U - A. */
+
+ kd = *kl + *ku + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Copy the J-th column of U to WORK. */
+
+/* Computing MIN */
+ i__2 = *kl + *ku, i__3 = j - 1;
+ ju = min(i__2,i__3);
+/* Computing MIN */
+ i__2 = *kl, i__3 = *m - j;
+ jl = min(i__2,i__3);
+ lenj = min(*m,j) - j + ju + 1;
+ if (lenj > 0) {
+ ccopy_(&lenj, &afac[kd - ju + j * afac_dim1], &c__1, &work[1], &
+ c__1);
+ i__2 = ju + jl + 1;
+ for (i__ = lenj + 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ work[i__3].r = 0.f, work[i__3].i = 0.f;
+/* L20: */
+ }
+
+/* Multiply by the unit lower triangular matrix L. Note that L */
+/* is stored as a product of transformations and permutations. */
+
+/* Computing MIN */
+ i__2 = *m - 1;
+ i__3 = j - ju;
+ for (i__ = min(i__2,j); i__ >= i__3; --i__) {
+/* Computing MIN */
+ i__2 = *kl, i__4 = *m - i__;
+ il = min(i__2,i__4);
+ if (il > 0) {
+ iw = i__ - j + ju + 1;
+ i__2 = iw;
+ t.r = work[i__2].r, t.i = work[i__2].i;
+ caxpy_(&il, &t, &afac[kd + 1 + i__ * afac_dim1], &c__1, &
+ work[iw + 1], &c__1);
+ ip = ipiv[i__];
+ if (i__ != ip) {
+ ip = ip - j + ju + 1;
+ i__2 = iw;
+ i__4 = ip;
+ work[i__2].r = work[i__4].r, work[i__2].i = work[i__4]
+ .i;
+ i__2 = ip;
+ work[i__2].r = t.r, work[i__2].i = t.i;
+ }
+ }
+/* L30: */
+ }
+
+/* Subtract the corresponding column of A. */
+
+ jua = min(ju,*ku);
+ if (jua + jl + 1 > 0) {
+ i__3 = jua + jl + 1;
+ caxpy_(&i__3, &c_b12, &a[*ku + 1 - jua + j * a_dim1], &c__1, &
+ work[ju + 1 - jua], &c__1);
+ }
+
+/* Compute the 1-norm of the column. */
+
+/* Computing MAX */
+ i__3 = ju + jl + 1;
+ r__1 = *resid, r__2 = scasum_(&i__3, &work[1], &c__1);
+ *resid = dmax(r__1,r__2);
+ }
+/* L40: */
+ }
+
+/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
+
+ if (anorm <= 0.f) {
+ if (*resid != 0.f) {
+ *resid = 1.f / eps;
+ }
+ } else {
+ *resid = *resid / (real) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of CGBT01 */
+
+} /* cgbt01_ */
diff --git a/TESTING/LIN/cgbt02.c b/TESTING/LIN/cgbt02.c
new file mode 100644
index 0000000..a7dcc7f
--- /dev/null
+++ b/TESTING/LIN/cgbt02.c
@@ -0,0 +1,207 @@
+/* cgbt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cgbt02_(char *trans, integer *m, integer *n, integer *kl,
+ integer *ku, integer *nrhs, complex *a, integer *lda, complex *x,
+ integer *ldx, complex *b, integer *ldb, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2,
+ i__3;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Local variables */
+ integer j, i1, i2, n1, kd;
+ real eps;
+ extern /* Subroutine */ int cgbmv_(char *, integer *, integer *, integer *
+, integer *, complex *, complex *, integer *, complex *, integer *
+, complex *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ real anorm, bnorm, xnorm;
+ extern doublereal slamch_(char *), scasum_(integer *, complex *,
+ integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGBT02 computes the residual for a solution of a banded system of */
+/* equations A*x = b or A'*x = b: */
+/* RESID = norm( B - A*X ) / ( norm(A) * norm(X) * EPS). */
+/* where EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A *x = b */
+/* = 'T': A'*x = b, where A' is the transpose of A */
+/* = 'C': A'*x = b, where A' is the transpose of A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The original matrix A in band storage, stored in rows 1 to */
+/* KL+KU+1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,KL+KU+1). */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. IF TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if N = 0 pr NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ kd = *ku + 1;
+ anorm = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = kd + 1 - j;
+ i1 = max(i__2,1);
+/* Computing MIN */
+ i__2 = kd + *m - j, i__3 = *kl + kd;
+ i2 = min(i__2,i__3);
+/* Computing MAX */
+ i__2 = i2 - i1 + 1;
+ r__1 = anorm, r__2 = scasum_(&i__2, &a[i1 + j * a_dim1], &c__1);
+ anorm = dmax(r__1,r__2);
+/* L10: */
+ }
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+ if (lsame_(trans, "T") || lsame_(trans, "C")) {
+ n1 = *n;
+ } else {
+ n1 = *m;
+ }
+
+/* Compute B - A*X (or B - A'*X ) */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgbmv_(trans, m, n, kl, ku, &q__1, &a[a_offset], lda, &x[j * x_dim1 +
+ 1], &c__1, &c_b1, &b[j * b_dim1 + 1], &c__1);
+/* L20: */
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = scasum_(&n1, &b[j * b_dim1 + 1], &c__1);
+ xnorm = scasum_(&n1, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L30: */
+ }
+
+ return 0;
+
+/* End of CGBT02 */
+
+} /* cgbt02_ */
diff --git a/TESTING/LIN/cgbt05.c b/TESTING/LIN/cgbt05.c
new file mode 100644
index 0000000..5f64a32
--- /dev/null
+++ b/TESTING/LIN/cgbt05.c
@@ -0,0 +1,306 @@
+/* cgbt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cgbt05_(char *trans, integer *n, integer *kl, integer *
+ ku, integer *nrhs, complex *ab, integer *ldab, complex *b, integer *
+ ldb, complex *x, integer *ldx, complex *xact, integer *ldxact, real *
+ ferr, real *berr, real *reslts)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k, nz;
+ real eps, tmp, diff, axbi;
+ integer imax;
+ real unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ real xnorm;
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ real errbnd;
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGBT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations op(A)*X = B, where A is a */
+/* general band matrix of order n with kl subdiagonals and ku */
+/* superdiagonals and op(A) = A or A**T, depending on TRANS. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+/* and NZ = max. number of nonzeros in any row of A, plus 1 */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* The original band matrix A, stored in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) REAL array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) REAL array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.f;
+ reslts[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ notran = lsame_(trans, "N");
+/* Computing MIN */
+ i__1 = *kl + *ku + 2, i__2 = *n + 1;
+ nz = min(i__1,i__2);
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = icamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__2 = imax + j * x_dim1;
+ r__3 = (r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x[imax + j *
+ x_dim1]), dabs(r__2));
+ xnorm = dmax(r__3,unfl);
+ diff = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * xact_dim1;
+ q__2.r = x[i__3].r - xact[i__4].r, q__2.i = x[i__3].i - xact[i__4]
+ .i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+/* Computing MAX */
+ r__3 = diff, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
+ q__1), dabs(r__2));
+ diff = dmax(r__3,r__4);
+/* L10: */
+ }
+
+ if (xnorm > 1.f) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1.f / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
+ errbnd = dmax(r__1,r__2);
+ } else {
+ errbnd = 1.f / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ tmp = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[i__ + k *
+ b_dim1]), dabs(r__2));
+ if (notran) {
+/* Computing MAX */
+ i__3 = i__ - *kl;
+/* Computing MIN */
+ i__5 = i__ + *ku;
+ i__4 = min(i__5,*n);
+ for (j = max(i__3,1); j <= i__4; ++j) {
+ i__3 = *ku + 1 + i__ - j + j * ab_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = ab[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ ab[*ku + 1 + i__ - j + j * ab_dim1]), dabs(r__2)))
+ * ((r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
+ r_imag(&x[j + k * x_dim1]), dabs(r__4)));
+/* L40: */
+ }
+ } else {
+/* Computing MAX */
+ i__4 = i__ - *ku;
+/* Computing MIN */
+ i__5 = i__ + *kl;
+ i__3 = min(i__5,*n);
+ for (j = max(i__4,1); j <= i__3; ++j) {
+ i__4 = *ku + 1 + j - i__ + i__ * ab_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = ab[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
+ ab[*ku + 1 + j - i__ + i__ * ab_dim1]), dabs(r__2)
+ )) * ((r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
+ r_imag(&x[j + k * x_dim1]), dabs(r__4)));
+/* L50: */
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = dmin(axbi,tmp);
+ }
+/* L60: */
+ }
+/* Computing MAX */
+ r__1 = axbi, r__2 = nz * unfl;
+ tmp = berr[k] / (nz * eps + nz * unfl / dmax(r__1,r__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = dmax(reslts[2],tmp);
+ }
+/* L70: */
+ }
+
+ return 0;
+
+/* End of CGBT05 */
+
+} /* cgbt05_ */
diff --git a/TESTING/LIN/cgelqs.c b/TESTING/LIN/cgelqs.c
new file mode 100644
index 0000000..9fbe675
--- /dev/null
+++ b/TESTING/LIN/cgelqs.c
@@ -0,0 +1,165 @@
+/* cgelqs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+
+/* Subroutine */ int cgelqs_(integer *m, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *tau, complex *b, integer *ldb, complex *
+ work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), xerbla_(char *, integer *), cunmlq_(char *, char
+ *, integer *, integer *, integer *, complex *, integer *, complex
+ *, complex *, integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Compute a minimum-norm solution */
+/* min || A*X - B || */
+/* using the LQ factorization */
+/* A = L*Q */
+/* computed by CGELQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= M >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* Details of the LQ factorization of the original matrix A as */
+/* returned by CGELQF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* TAU (input) COMPLEX array, dimension (M) */
+/* Details of the orthogonal matrix Q. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the m-by-nrhs right hand side matrix B. */
+/* On exit, the n-by-nrhs solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= N. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK must be at least NRHS, */
+/* and should be at least NRHS*NB, where NB is the block size */
+/* for this environment. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *m > *n) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*lwork < 1 || *lwork < *nrhs && *m > 0 && *n > 0) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGELQS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0 || *m == 0) {
+ return 0;
+ }
+
+/* Solve L*X = B(1:m,:) */
+
+ ctrsm_("Left", "Lower", "No transpose", "Non-unit", m, nrhs, &c_b2, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+/* Set B(m+1:n,:) to zero */
+
+ if (*m < *n) {
+ i__1 = *n - *m;
+ claset_("Full", &i__1, nrhs, &c_b1, &c_b1, &b[*m + 1 + b_dim1], ldb);
+ }
+
+/* B := Q' * B */
+
+ cunmlq_("Left", "Conjugate transpose", n, nrhs, m, &a[a_offset], lda, &
+ tau[1], &b[b_offset], ldb, &work[1], lwork, info);
+
+ return 0;
+
+/* End of CGELQS */
+
+} /* cgelqs_ */
diff --git a/TESTING/LIN/cgennd.c b/TESTING/LIN/cgennd.c
new file mode 100644
index 0000000..68b063c
--- /dev/null
+++ b/TESTING/LIN/cgennd.c
@@ -0,0 +1,86 @@
+/* cgennd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+logical cgennd_(integer *m, integer *n, complex *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ logical ret_val;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, k;
+ complex aii;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGENND tests that its argument has a real, non-negative diagonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows in A. */
+
+/* N (input) INTEGER */
+/* The number of columns in A. */
+
+/* A (input) COMPLEX array, dimension (LDA, N) */
+/* The matrix. */
+
+/* LDA (input) INTEGER */
+/* Leading dimension of A. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsics .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ k = min(*m,*n);
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ aii.r = a[i__2].r, aii.i = a[i__2].i;
+ if (aii.r < 0.f || r_imag(&aii) != 0.f) {
+ ret_val = FALSE_;
+ return ret_val;
+ }
+ }
+ ret_val = TRUE_;
+ return ret_val;
+} /* cgennd_ */
diff --git a/TESTING/LIN/cgeqls.c b/TESTING/LIN/cgeqls.c
new file mode 100644
index 0000000..11a642c
--- /dev/null
+++ b/TESTING/LIN/cgeqls.c
@@ -0,0 +1,158 @@
+/* cgeqls.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+
+/* Subroutine */ int cgeqls_(integer *m, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *tau, complex *b, integer *ldb, complex *
+ work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *), xerbla_(char *,
+ integer *), cunmql_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Solve the least squares problem */
+/* min || A*X - B || */
+/* using the QL factorization */
+/* A = Q*L */
+/* computed by CGEQLF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. M >= N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* Details of the QL factorization of the original matrix A as */
+/* returned by CGEQLF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* TAU (input) COMPLEX array, dimension (N) */
+/* Details of the orthogonal matrix Q. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the m-by-nrhs right hand side matrix B. */
+/* On exit, the n-by-nrhs solution matrix X, stored in rows */
+/* m-n+1:m. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= M. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK must be at least NRHS, */
+/* and should be at least NRHS*NB, where NB is the block size */
+/* for this environment. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*m)) {
+ *info = -8;
+ } else if (*lwork < 1 || *lwork < *nrhs && *m > 0 && *n > 0) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGEQLS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0 || *m == 0) {
+ return 0;
+ }
+
+/* B := Q' * B */
+
+ cunmql_("Left", "Conjugate transpose", m, nrhs, n, &a[a_offset], lda, &
+ tau[1], &b[b_offset], ldb, &work[1], lwork, info);
+
+/* Solve L*X = B(m-n+1:m,:) */
+
+ ctrsm_("Left", "Lower", "No transpose", "Non-unit", n, nrhs, &c_b1, &a[*m
+ - *n + 1 + a_dim1], lda, &b[*m - *n + 1 + b_dim1], ldb);
+
+ return 0;
+
+/* End of CGEQLS */
+
+} /* cgeqls_ */
diff --git a/TESTING/LIN/cgeqrs.c b/TESTING/LIN/cgeqrs.c
new file mode 100644
index 0000000..aaf1285
--- /dev/null
+++ b/TESTING/LIN/cgeqrs.c
@@ -0,0 +1,157 @@
+/* cgeqrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+
+/* Subroutine */ int cgeqrs_(integer *m, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *tau, complex *b, integer *ldb, complex *
+ work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *), xerbla_(char *,
+ integer *), cunmqr_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Solve the least squares problem */
+/* min || A*X - B || */
+/* using the QR factorization */
+/* A = Q*R */
+/* computed by CGEQRF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. M >= N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* Details of the QR factorization of the original matrix A as */
+/* returned by CGEQRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* TAU (input) COMPLEX array, dimension (N) */
+/* Details of the orthogonal matrix Q. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the m-by-nrhs right hand side matrix B. */
+/* On exit, the n-by-nrhs solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= M. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK must be at least NRHS, */
+/* and should be at least NRHS*NB, where NB is the block size */
+/* for this environment. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*m)) {
+ *info = -8;
+ } else if (*lwork < 1 || *lwork < *nrhs && *m > 0 && *n > 0) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGEQRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0 || *m == 0) {
+ return 0;
+ }
+
+/* B := Q' * B */
+
+ cunmqr_("Left", "Conjugate transpose", m, nrhs, n, &a[a_offset], lda, &
+ tau[1], &b[b_offset], ldb, &work[1], lwork, info);
+
+/* Solve R*X = B(1:n,:) */
+
+ ctrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b1, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+ return 0;
+
+/* End of CGEQRS */
+
+} /* cgeqrs_ */
diff --git a/TESTING/LIN/cgerqs.c b/TESTING/LIN/cgerqs.c
new file mode 100644
index 0000000..ae08d90
--- /dev/null
+++ b/TESTING/LIN/cgerqs.c
@@ -0,0 +1,164 @@
+/* cgerqs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+
+/* Subroutine */ int cgerqs_(integer *m, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *tau, complex *b, integer *ldb, complex *
+ work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
+ integer *, integer *, complex *, complex *, integer *, complex *,
+ integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), xerbla_(char *, integer *), cunmrq_(char *, char
+ *, integer *, integer *, integer *, complex *, integer *, complex
+ *, complex *, integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Compute a minimum-norm solution */
+/* min || A*X - B || */
+/* using the RQ factorization */
+/* A = R*Q */
+/* computed by CGERQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= M >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* Details of the RQ factorization of the original matrix A as */
+/* returned by CGERQF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* TAU (input) COMPLEX array, dimension (M) */
+/* Details of the orthogonal matrix Q. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the linear system. */
+/* On exit, the solution vectors X. Each solution vector */
+/* is contained in rows 1:N of a column of B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK must be at least NRHS, */
+/* and should be at least NRHS*NB, where NB is the block size */
+/* for this environment. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *m > *n) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*lwork < 1 || *lwork < *nrhs && *m > 0 && *n > 0) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CGERQS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0 || *m == 0) {
+ return 0;
+ }
+
+/* Solve R*X = B(n-m+1:n,:) */
+
+ ctrsm_("Left", "Upper", "No transpose", "Non-unit", m, nrhs, &c_b2, &a[(*
+ n - *m + 1) * a_dim1 + 1], lda, &b[*n - *m + 1 + b_dim1], ldb);
+
+/* Set B(1:n-m,:) to zero */
+
+ i__1 = *n - *m;
+ claset_("Full", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+
+/* B := Q' * B */
+
+ cunmrq_("Left", "Conjugate transpose", n, nrhs, m, &a[a_offset], lda, &
+ tau[1], &b[b_offset], ldb, &work[1], lwork, info);
+
+ return 0;
+
+/* End of CGERQS */
+
+} /* cgerqs_ */
diff --git a/TESTING/LIN/cget01.c b/TESTING/LIN/cget01.c
new file mode 100644
index 0000000..0dd5467
--- /dev/null
+++ b/TESTING/LIN/cget01.c
@@ -0,0 +1,214 @@
+/* cget01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int cget01_(integer *m, integer *n, complex *a, integer *lda,
+ complex *afac, integer *ldafac, integer *ipiv, real *rwork, real *
+ resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3, i__4,
+ i__5;
+ complex q__1, q__2;
+
+ /* Local variables */
+ integer i__, j, k;
+ complex t;
+ real eps;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *), cgemv_(char *, integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, complex *,
+ integer *);
+ real anorm;
+ extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
+ complex *, integer *, complex *, integer *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int claswp_(integer *, complex *, integer *,
+ integer *, integer *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGET01 reconstructs a matrix A from its L*U factorization and */
+/* computes the residual */
+/* norm(L*U - A) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The original M x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* AFAC (input/output) COMPLEX array, dimension (LDAFAC,N) */
+/* The factored form of the matrix A. AFAC contains the factors */
+/* L and U from the L*U factorization as computed by CGETRF. */
+/* Overwritten with the reconstructed matrix, and then with the */
+/* difference L*U - A. */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. LDAFAC >= max(1,M). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from CGETRF. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESID (output) REAL */
+/* norm(L*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if M = 0 or N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ --ipiv;
+ --rwork;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Determine EPS and the norm of A. */
+
+ eps = slamch_("Epsilon");
+ anorm = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+
+/* Compute the product L*U and overwrite AFAC with the result. */
+/* A column at a time of the product is obtained, starting with */
+/* column N. */
+
+ for (k = *n; k >= 1; --k) {
+ if (k > *m) {
+ ctrmv_("Lower", "No transpose", "Unit", m, &afac[afac_offset],
+ ldafac, &afac[k * afac_dim1 + 1], &c__1);
+ } else {
+
+/* Compute elements (K+1:M,K) */
+
+ i__1 = k + k * afac_dim1;
+ t.r = afac[i__1].r, t.i = afac[i__1].i;
+ if (k + 1 <= *m) {
+ i__1 = *m - k;
+ cscal_(&i__1, &t, &afac[k + 1 + k * afac_dim1], &c__1);
+ i__1 = *m - k;
+ i__2 = k - 1;
+ cgemv_("No transpose", &i__1, &i__2, &c_b1, &afac[k + 1 +
+ afac_dim1], ldafac, &afac[k * afac_dim1 + 1], &c__1, &
+ c_b1, &afac[k + 1 + k * afac_dim1], &c__1)
+ ;
+ }
+
+/* Compute the (K,K) element */
+
+ i__1 = k + k * afac_dim1;
+ i__2 = k - 1;
+ cdotu_(&q__2, &i__2, &afac[k + afac_dim1], ldafac, &afac[k *
+ afac_dim1 + 1], &c__1);
+ q__1.r = t.r + q__2.r, q__1.i = t.i + q__2.i;
+ afac[i__1].r = q__1.r, afac[i__1].i = q__1.i;
+
+/* Compute elements (1:K-1,K) */
+
+ i__1 = k - 1;
+ ctrmv_("Lower", "No transpose", "Unit", &i__1, &afac[afac_offset],
+ ldafac, &afac[k * afac_dim1 + 1], &c__1);
+ }
+/* L10: */
+ }
+ i__1 = min(*m,*n);
+ claswp_(n, &afac[afac_offset], ldafac, &c__1, &i__1, &ipiv[1], &c_n1);
+
+/* Compute the difference L*U - A and store in AFAC. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * afac_dim1;
+ i__4 = i__ + j * afac_dim1;
+ i__5 = i__ + j * a_dim1;
+ q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[i__5]
+ .i;
+ afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = clange_("1", m, n, &afac[afac_offset], ldafac, &rwork[1]);
+
+ if (anorm <= 0.f) {
+ if (*resid != 0.f) {
+ *resid = 1.f / eps;
+ }
+ } else {
+ *resid = *resid / (real) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of CGET01 */
+
+} /* cget01_ */
diff --git a/TESTING/LIN/cget02.c b/TESTING/LIN/cget02.c
new file mode 100644
index 0000000..45503af
--- /dev/null
+++ b/TESTING/LIN/cget02.c
@@ -0,0 +1,188 @@
+/* cget02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cget02_(char *trans, integer *m, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *x, integer *ldx, complex *b,
+ integer *ldb, real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Local variables */
+ integer j, n1, n2;
+ real eps;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ real anorm, bnorm, xnorm;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *), scasum_(
+ integer *, complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGET02 computes the residual for a solution of a system of linear */
+/* equations A*x = b or A'*x = b: */
+/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A *x = b */
+/* = 'T': A^T*x = b, where A^T is the transpose of A */
+/* = 'C': A^H*x = b, where A^H is the conjugate transpose of A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The original M x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. IF TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if M = 0 or N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0 || *nrhs == 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+ if (lsame_(trans, "T") || lsame_(trans, "C")) {
+ n1 = *n;
+ n2 = *m;
+ } else {
+ n1 = *m;
+ n2 = *n;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = clange_("1", &n1, &n2, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute B - A*X (or B - A'*X ) and store in B. */
+
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_(trans, "No transpose", &n1, nrhs, &n2, &q__1, &a[a_offset], lda, &
+ x[x_offset], ldx, &c_b1, &b[b_offset], ldb)
+ ;
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = scasum_(&n1, &b[j * b_dim1 + 1], &c__1);
+ xnorm = scasum_(&n2, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of CGET02 */
+
+} /* cget02_ */
diff --git a/TESTING/LIN/cget03.c b/TESTING/LIN/cget03.c
new file mode 100644
index 0000000..8bd0f2b
--- /dev/null
+++ b/TESTING/LIN/cget03.c
@@ -0,0 +1,160 @@
+/* cget03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+
+/* Subroutine */ int cget03_(integer *n, complex *a, integer *lda, complex *
+ ainv, integer *ldainv, complex *work, integer *ldwork, real *rwork,
+ real *rcond, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, ainv_dim1, ainv_offset, work_dim1, work_offset,
+ i__1, i__2, i__3;
+ complex q__1;
+
+ /* Local variables */
+ integer i__;
+ real eps;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ real anorm;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ real ainvnm;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGET03 computes the residual for a general matrix times its inverse: */
+/* norm( I - AINV*A ) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The original N x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AINV (input) COMPLEX array, dimension (LDAINV,N) */
+/* The inverse of the matrix A. */
+
+/* LDAINV (input) INTEGER */
+/* The leading dimension of the array AINV. LDAINV >= max(1,N). */
+
+/* WORK (workspace) COMPLEX array, dimension (LDWORK,N) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RCOND (output) REAL */
+/* The reciprocal of the condition number of A, computed as */
+/* ( 1/norm(A) ) / norm(AINV). */
+
+/* RESID (output) REAL */
+/* norm(I - AINV*A) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ ainv_dim1 = *ldainv;
+ ainv_offset = 1 + ainv_dim1;
+ ainv -= ainv_offset;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.f;
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = clange_("1", n, n, &a[a_offset], lda, &rwork[1]);
+ ainvnm = clange_("1", n, n, &ainv[ainv_offset], ldainv, &rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ *rcond = 0.f;
+ *resid = 1.f / eps;
+ return 0;
+ }
+ *rcond = 1.f / anorm / ainvnm;
+
+/* Compute I - A * AINV */
+
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("No transpose", "No transpose", n, n, n, &q__1, &ainv[ainv_offset],
+ ldainv, &a[a_offset], lda, &c_b1, &work[work_offset], ldwork);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * work_dim1;
+ i__3 = i__ + i__ * work_dim1;
+ q__1.r = work[i__3].r + 1.f, q__1.i = work[i__3].i + 0.f;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L10: */
+ }
+
+/* Compute norm(I - AINV*A) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = clange_("1", n, n, &work[work_offset], ldwork, &rwork[1]);
+
+ *resid = *resid * *rcond / eps / (real) (*n);
+
+ return 0;
+
+/* End of CGET03 */
+
+} /* cget03_ */
diff --git a/TESTING/LIN/cget04.c b/TESTING/LIN/cget04.c
new file mode 100644
index 0000000..f443018
--- /dev/null
+++ b/TESTING/LIN/cget04.c
@@ -0,0 +1,173 @@
+/* cget04.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cget04_(integer *n, integer *nrhs, complex *x, integer *
+ ldx, complex *xact, integer *ldxact, real *rcond, real *resid)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, xact_dim1, xact_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, ix;
+ real eps, xnorm;
+ extern integer icamax_(integer *, complex *, integer *);
+ real diffnm;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGET04 computes the difference between a computed solution and the */
+/* true solution to a system of linear equations. */
+
+/* RESID = ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ), */
+/* where RCOND is the reciprocal of the condition number and EPS is the */
+/* machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X and XACT. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X and XACT. NRHS >= 0. */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* RCOND (input) REAL */
+/* The reciprocal of the condition number of the coefficient */
+/* matrix in the system of equations. */
+
+/* RESID (output) REAL */
+/* The maximum over the NRHS solution vectors of */
+/* ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if RCOND is invalid. */
+
+ eps = slamch_("Epsilon");
+ if (*rcond < 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute the maximum of */
+/* norm(X - XACT) / ( norm(XACT) * EPS ) */
+/* over all the vectors X and XACT . */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ix = icamax_(n, &xact[j * xact_dim1 + 1], &c__1);
+ i__2 = ix + j * xact_dim1;
+ xnorm = (r__1 = xact[i__2].r, dabs(r__1)) + (r__2 = r_imag(&xact[ix +
+ j * xact_dim1]), dabs(r__2));
+ diffnm = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * xact_dim1;
+ q__2.r = x[i__3].r - xact[i__4].r, q__2.i = x[i__3].i - xact[i__4]
+ .i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+/* Computing MAX */
+ r__3 = diffnm, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 =
+ r_imag(&q__1), dabs(r__2));
+ diffnm = dmax(r__3,r__4);
+/* L10: */
+ }
+ if (xnorm <= 0.f) {
+ if (diffnm > 0.f) {
+ *resid = 1.f / eps;
+ }
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = diffnm / xnorm * *rcond;
+ *resid = dmax(r__1,r__2);
+ }
+/* L20: */
+ }
+ if (*resid * eps < 1.f) {
+ *resid /= eps;
+ }
+
+ return 0;
+
+/* End of CGET04 */
+
+} /* cget04_ */
diff --git a/TESTING/LIN/cget07.c b/TESTING/LIN/cget07.c
new file mode 100644
index 0000000..22db743
--- /dev/null
+++ b/TESTING/LIN/cget07.c
@@ -0,0 +1,289 @@
+/* cget07.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cget07_(char *trans, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *b, integer *ldb, complex *x, integer *ldx,
+ complex *xact, integer *ldxact, real *ferr, logical *chkferr, real *
+ berr, real *reslts)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ real eps, tmp, diff, axbi;
+ integer imax;
+ real unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ real xnorm;
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ real errbnd;
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGET07 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations op(A)*X = B, where A is a */
+/* general n by n matrix and op(A) = A or A**T, depending on TRANS. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X and XACT. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X and XACT. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The original n by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) REAL array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* CHKFERR (input) LOGICAL */
+/* Set to .TRUE. to check FERR, .FALSE. not to check FERR. */
+/* When the test system is ill-conditioned, the "true" */
+/* solution in XACT may be incorrect. */
+
+/* BERR (input) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) REAL array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.f;
+ reslts[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ notran = lsame_(trans, "N");
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.f;
+ if (*chkferr) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = icamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__2 = imax + j * x_dim1;
+ r__3 = (r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x[imax +
+ j * x_dim1]), dabs(r__2));
+ xnorm = dmax(r__3,unfl);
+ diff = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * xact_dim1;
+ q__2.r = x[i__3].r - xact[i__4].r, q__2.i = x[i__3].i - xact[
+ i__4].i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+/* Computing MAX */
+ r__3 = diff, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 =
+ r_imag(&q__1), dabs(r__2));
+ diff = dmax(r__3,r__4);
+/* L10: */
+ }
+
+ if (xnorm > 1.f) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1.f / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
+ errbnd = dmax(r__1,r__2);
+ } else {
+ errbnd = 1.f / eps;
+ }
+L30:
+ ;
+ }
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ tmp = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[i__ + k *
+ b_dim1]), dabs(r__2));
+ if (notran) {
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = i__ + j * a_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[i__ + j * a_dim1]), dabs(r__2))) * ((r__3 = x[
+ i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[j + k *
+ x_dim1]), dabs(r__4)));
+/* L40: */
+ }
+ } else {
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j + i__ * a_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[j + i__ * a_dim1]), dabs(r__2))) * ((r__3 = x[
+ i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[j + k *
+ x_dim1]), dabs(r__4)));
+/* L50: */
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = dmin(axbi,tmp);
+ }
+/* L60: */
+ }
+/* Computing MAX */
+ r__1 = axbi, r__2 = (*n + 1) * unfl;
+ tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / dmax(r__1,r__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = dmax(reslts[2],tmp);
+ }
+/* L70: */
+ }
+
+ return 0;
+
+/* End of CGET07 */
+
+} /* cget07_ */
diff --git a/TESTING/LIN/cgtt01.c b/TESTING/LIN/cgtt01.c
new file mode 100644
index 0000000..06b1775
--- /dev/null
+++ b/TESTING/LIN/cgtt01.c
@@ -0,0 +1,279 @@
+/* cgtt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cgtt01_(integer *n, complex *dl, complex *d__, complex *
+ du, complex *dlf, complex *df, complex *duf, complex *du2, integer *
+ ipiv, complex *work, integer *ldwork, real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer work_dim1, work_offset, i__1, i__2, i__3, i__4;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j;
+ complex li;
+ integer ip;
+ real eps, anorm;
+ integer lastj;
+ extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
+ complex *, integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ extern doublereal slamch_(char *), clangt_(char *, integer *,
+ complex *, complex *, complex *), clanhs_(char *, integer
+ *, complex *, integer *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGTT01 reconstructs a tridiagonal matrix A from its LU factorization */
+/* and computes the residual */
+/* norm(L*U - A) / ( norm(A) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGTER */
+/* The order of the matrix A. N >= 0. */
+
+/* DL (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) sub-diagonal elements of A. */
+
+/* D (input) COMPLEX array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* DU (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) super-diagonal elements of A. */
+
+/* DLF (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) multipliers that define the matrix L from the */
+/* LU factorization of A. */
+
+/* DF (input) COMPLEX array, dimension (N) */
+/* The n diagonal elements of the upper triangular matrix U from */
+/* the LU factorization of A. */
+
+/* DUF (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) elements of the first super-diagonal of U. */
+
+/* DU2 (input) COMPLEX array, dimension (N-2) */
+/* The (n-2) elements of the second super-diagonal of U. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* WORK (workspace) COMPLEX array, dimension (LDWORK,N) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* The scaled residual: norm(L*U - A) / (norm(A) * EPS) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ --dlf;
+ --df;
+ --duf;
+ --du2;
+ --ipiv;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+
+/* Copy the matrix U to WORK. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * work_dim1;
+ work[i__3].r = 0.f, work[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (i__ == 1) {
+ i__2 = i__ + i__ * work_dim1;
+ i__3 = i__;
+ work[i__2].r = df[i__3].r, work[i__2].i = df[i__3].i;
+ if (*n >= 2) {
+ i__2 = i__ + (i__ + 1) * work_dim1;
+ i__3 = i__;
+ work[i__2].r = duf[i__3].r, work[i__2].i = duf[i__3].i;
+ }
+ if (*n >= 3) {
+ i__2 = i__ + (i__ + 2) * work_dim1;
+ i__3 = i__;
+ work[i__2].r = du2[i__3].r, work[i__2].i = du2[i__3].i;
+ }
+ } else if (i__ == *n) {
+ i__2 = i__ + i__ * work_dim1;
+ i__3 = i__;
+ work[i__2].r = df[i__3].r, work[i__2].i = df[i__3].i;
+ } else {
+ i__2 = i__ + i__ * work_dim1;
+ i__3 = i__;
+ work[i__2].r = df[i__3].r, work[i__2].i = df[i__3].i;
+ i__2 = i__ + (i__ + 1) * work_dim1;
+ i__3 = i__;
+ work[i__2].r = duf[i__3].r, work[i__2].i = duf[i__3].i;
+ if (i__ < *n - 1) {
+ i__2 = i__ + (i__ + 2) * work_dim1;
+ i__3 = i__;
+ work[i__2].r = du2[i__3].r, work[i__2].i = du2[i__3].i;
+ }
+ }
+/* L30: */
+ }
+
+/* Multiply on the left by L. */
+
+ lastj = *n;
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ i__1 = i__;
+ li.r = dlf[i__1].r, li.i = dlf[i__1].i;
+ i__1 = lastj - i__ + 1;
+ caxpy_(&i__1, &li, &work[i__ + i__ * work_dim1], ldwork, &work[i__ +
+ 1 + i__ * work_dim1], ldwork);
+ ip = ipiv[i__];
+ if (ip == i__) {
+/* Computing MIN */
+ i__1 = i__ + 2;
+ lastj = min(i__1,*n);
+ } else {
+ i__1 = lastj - i__ + 1;
+ cswap_(&i__1, &work[i__ + i__ * work_dim1], ldwork, &work[i__ + 1
+ + i__ * work_dim1], ldwork);
+ }
+/* L40: */
+ }
+
+/* Subtract the matrix A. */
+
+ i__1 = work_dim1 + 1;
+ i__2 = work_dim1 + 1;
+ q__1.r = work[i__2].r - d__[1].r, q__1.i = work[i__2].i - d__[1].i;
+ work[i__1].r = q__1.r, work[i__1].i = q__1.i;
+ if (*n > 1) {
+ i__1 = (work_dim1 << 1) + 1;
+ i__2 = (work_dim1 << 1) + 1;
+ q__1.r = work[i__2].r - du[1].r, q__1.i = work[i__2].i - du[1].i;
+ work[i__1].r = q__1.r, work[i__1].i = q__1.i;
+ i__1 = *n + (*n - 1) * work_dim1;
+ i__2 = *n + (*n - 1) * work_dim1;
+ i__3 = *n - 1;
+ q__1.r = work[i__2].r - dl[i__3].r, q__1.i = work[i__2].i - dl[i__3]
+ .i;
+ work[i__1].r = q__1.r, work[i__1].i = q__1.i;
+ i__1 = *n + *n * work_dim1;
+ i__2 = *n + *n * work_dim1;
+ i__3 = *n;
+ q__1.r = work[i__2].r - d__[i__3].r, q__1.i = work[i__2].i - d__[i__3]
+ .i;
+ work[i__1].r = q__1.r, work[i__1].i = q__1.i;
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__ + (i__ - 1) * work_dim1;
+ i__3 = i__ + (i__ - 1) * work_dim1;
+ i__4 = i__ - 1;
+ q__1.r = work[i__3].r - dl[i__4].r, q__1.i = work[i__3].i - dl[
+ i__4].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ i__2 = i__ + i__ * work_dim1;
+ i__3 = i__ + i__ * work_dim1;
+ i__4 = i__;
+ q__1.r = work[i__3].r - d__[i__4].r, q__1.i = work[i__3].i - d__[
+ i__4].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ i__2 = i__ + (i__ + 1) * work_dim1;
+ i__3 = i__ + (i__ + 1) * work_dim1;
+ i__4 = i__;
+ q__1.r = work[i__3].r - du[i__4].r, q__1.i = work[i__3].i - du[
+ i__4].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L50: */
+ }
+ }
+
+/* Compute the 1-norm of the tridiagonal matrix A. */
+
+ anorm = clangt_("1", n, &dl[1], &d__[1], &du[1]);
+
+/* Compute the 1-norm of WORK, which is only guaranteed to be */
+/* upper Hessenberg. */
+
+ *resid = clanhs_("1", n, &work[work_offset], ldwork, &rwork[1])
+ ;
+
+/* Compute norm(L*U - A) / (norm(A) * EPS) */
+
+ if (anorm <= 0.f) {
+ if (*resid != 0.f) {
+ *resid = 1.f / eps;
+ }
+ } else {
+ *resid = *resid / anorm / eps;
+ }
+
+ return 0;
+
+/* End of CGTT01 */
+
+} /* cgtt01_ */
diff --git a/TESTING/LIN/cgtt02.c b/TESTING/LIN/cgtt02.c
new file mode 100644
index 0000000..9322101
--- /dev/null
+++ b/TESTING/LIN/cgtt02.c
@@ -0,0 +1,178 @@
+/* cgtt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b6 = -1.f;
+static real c_b7 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int cgtt02_(char *trans, integer *n, integer *nrhs, complex *
+ dl, complex *d__, complex *du, complex *x, integer *ldx, complex *b,
+ integer *ldb, real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j;
+ real eps;
+ extern logical lsame_(char *, char *);
+ real anorm, bnorm, xnorm;
+ extern doublereal slamch_(char *), clangt_(char *, integer *,
+ complex *, complex *, complex *);
+ extern /* Subroutine */ int clagtm_(char *, integer *, integer *, real *,
+ complex *, complex *, complex *, complex *, integer *, real *,
+ complex *, integer *);
+ extern doublereal scasum_(integer *, complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGTT02 computes the residual for the solution to a tridiagonal */
+/* system of equations: */
+/* RESID = norm(B - op(A)*X) / (norm(A) * norm(X) * EPS), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER */
+/* Specifies the form of the residual. */
+/* = 'N': B - A * X (No transpose) */
+/* = 'T': B - A**T * X (Transpose) */
+/* = 'C': B - A**H * X (Conjugate transpose) */
+
+/* N (input) INTEGTER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* DL (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) sub-diagonal elements of A. */
+
+/* D (input) COMPLEX array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* DU (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) super-diagonal elements of A. */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - op(A)*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* norm(B - op(A)*X) / (norm(A) * norm(X) * EPS) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ *resid = 0.f;
+ if (*n <= 0 || *nrhs == 0) {
+ return 0;
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - op(A)*X) / ( norm(A) * norm(X) * EPS ). */
+
+ if (lsame_(trans, "N")) {
+ anorm = clangt_("1", n, &dl[1], &d__[1], &du[1]);
+ } else {
+ anorm = clangt_("I", n, &dl[1], &d__[1], &du[1]);
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute B - op(A)*X. */
+
+ clagtm_(trans, n, nrhs, &c_b6, &dl[1], &d__[1], &du[1], &x[x_offset], ldx,
+ &c_b7, &b[b_offset], ldb);
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = scasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = scasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of CGTT02 */
+
+} /* cgtt02_ */
diff --git a/TESTING/LIN/cgtt05.c b/TESTING/LIN/cgtt05.c
new file mode 100644
index 0000000..f826252
--- /dev/null
+++ b/TESTING/LIN/cgtt05.c
@@ -0,0 +1,377 @@
+/* cgtt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cgtt05_(char *trans, integer *n, integer *nrhs, complex *
+ dl, complex *d__, complex *du, complex *b, integer *ldb, complex *x,
+ integer *ldx, complex *xact, integer *ldxact, real *ferr, real *berr,
+ real *reslts)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1,
+ i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9;
+ real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10, r__11,
+ r__12, r__13, r__14;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k, nz;
+ real eps, tmp, diff, axbi;
+ integer imax;
+ real unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ real xnorm;
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ real errbnd;
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CGTT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* general tridiagonal matrix of order n and op(A) = A or A**T, */
+/* depending on TRANS. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+/* and NZ = max. number of nonzeros in any row of A, plus 1 */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X and XACT. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X and XACT. NRHS >= 0. */
+
+/* DL (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) sub-diagonal elements of A. */
+
+/* D (input) COMPLEX array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* DU (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) super-diagonal elements of A. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) REAL array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) REAL array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.f;
+ reslts[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ notran = lsame_(trans, "N");
+ nz = 4;
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = icamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__2 = imax + j * x_dim1;
+ r__3 = (r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x[imax + j *
+ x_dim1]), dabs(r__2));
+ xnorm = dmax(r__3,unfl);
+ diff = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * xact_dim1;
+ q__2.r = x[i__3].r - xact[i__4].r, q__2.i = x[i__3].i - xact[i__4]
+ .i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+/* Computing MAX */
+ r__3 = diff, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
+ q__1), dabs(r__2));
+ diff = dmax(r__3,r__4);
+/* L10: */
+ }
+
+ if (xnorm > 1.f) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1.f / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
+ errbnd = dmax(r__1,r__2);
+ } else {
+ errbnd = 1.f / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ if (notran) {
+ if (*n == 1) {
+ i__2 = k * b_dim1 + 1;
+ i__3 = k * x_dim1 + 1;
+ axbi = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b[k *
+ b_dim1 + 1]), dabs(r__2)) + ((r__3 = d__[1].r, dabs(
+ r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((
+ r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x[k *
+ x_dim1 + 1]), dabs(r__6)));
+ } else {
+ i__2 = k * b_dim1 + 1;
+ i__3 = k * x_dim1 + 1;
+ i__4 = k * x_dim1 + 2;
+ axbi = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b[k *
+ b_dim1 + 1]), dabs(r__2)) + ((r__3 = d__[1].r, dabs(
+ r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((
+ r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x[k *
+ x_dim1 + 1]), dabs(r__6))) + ((r__7 = du[1].r, dabs(
+ r__7)) + (r__8 = r_imag(&du[1]), dabs(r__8))) * ((
+ r__9 = x[i__4].r, dabs(r__9)) + (r__10 = r_imag(&x[k *
+ x_dim1 + 2]), dabs(r__10)));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ i__4 = i__ - 1;
+ i__5 = i__ - 1 + k * x_dim1;
+ i__6 = i__;
+ i__7 = i__ + k * x_dim1;
+ i__8 = i__;
+ i__9 = i__ + 1 + k * x_dim1;
+ tmp = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[
+ i__ + k * b_dim1]), dabs(r__2)) + ((r__3 = dl[
+ i__4].r, dabs(r__3)) + (r__4 = r_imag(&dl[i__ - 1]
+ ), dabs(r__4))) * ((r__5 = x[i__5].r, dabs(r__5))
+ + (r__6 = r_imag(&x[i__ - 1 + k * x_dim1]), dabs(
+ r__6))) + ((r__7 = d__[i__6].r, dabs(r__7)) + (
+ r__8 = r_imag(&d__[i__]), dabs(r__8))) * ((r__9 =
+ x[i__7].r, dabs(r__9)) + (r__10 = r_imag(&x[i__ +
+ k * x_dim1]), dabs(r__10))) + ((r__11 = du[i__8]
+ .r, dabs(r__11)) + (r__12 = r_imag(&du[i__]),
+ dabs(r__12))) * ((r__13 = x[i__9].r, dabs(r__13))
+ + (r__14 = r_imag(&x[i__ + 1 + k * x_dim1]), dabs(
+ r__14)));
+ axbi = dmin(axbi,tmp);
+/* L40: */
+ }
+ i__2 = *n + k * b_dim1;
+ i__3 = *n - 1;
+ i__4 = *n - 1 + k * x_dim1;
+ i__5 = *n;
+ i__6 = *n + k * x_dim1;
+ tmp = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b[*n +
+ k * b_dim1]), dabs(r__2)) + ((r__3 = dl[i__3].r, dabs(
+ r__3)) + (r__4 = r_imag(&dl[*n - 1]), dabs(r__4))) * (
+ (r__5 = x[i__4].r, dabs(r__5)) + (r__6 = r_imag(&x[*n
+ - 1 + k * x_dim1]), dabs(r__6))) + ((r__7 = d__[i__5]
+ .r, dabs(r__7)) + (r__8 = r_imag(&d__[*n]), dabs(r__8)
+ )) * ((r__9 = x[i__6].r, dabs(r__9)) + (r__10 =
+ r_imag(&x[*n + k * x_dim1]), dabs(r__10)));
+ axbi = dmin(axbi,tmp);
+ }
+ } else {
+ if (*n == 1) {
+ i__2 = k * b_dim1 + 1;
+ i__3 = k * x_dim1 + 1;
+ axbi = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b[k *
+ b_dim1 + 1]), dabs(r__2)) + ((r__3 = d__[1].r, dabs(
+ r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((
+ r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x[k *
+ x_dim1 + 1]), dabs(r__6)));
+ } else {
+ i__2 = k * b_dim1 + 1;
+ i__3 = k * x_dim1 + 1;
+ i__4 = k * x_dim1 + 2;
+ axbi = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b[k *
+ b_dim1 + 1]), dabs(r__2)) + ((r__3 = d__[1].r, dabs(
+ r__3)) + (r__4 = r_imag(&d__[1]), dabs(r__4))) * ((
+ r__5 = x[i__3].r, dabs(r__5)) + (r__6 = r_imag(&x[k *
+ x_dim1 + 1]), dabs(r__6))) + ((r__7 = dl[1].r, dabs(
+ r__7)) + (r__8 = r_imag(&dl[1]), dabs(r__8))) * ((
+ r__9 = x[i__4].r, dabs(r__9)) + (r__10 = r_imag(&x[k *
+ x_dim1 + 2]), dabs(r__10)));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ i__4 = i__ - 1;
+ i__5 = i__ - 1 + k * x_dim1;
+ i__6 = i__;
+ i__7 = i__ + k * x_dim1;
+ i__8 = i__;
+ i__9 = i__ + 1 + k * x_dim1;
+ tmp = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[
+ i__ + k * b_dim1]), dabs(r__2)) + ((r__3 = du[
+ i__4].r, dabs(r__3)) + (r__4 = r_imag(&du[i__ - 1]
+ ), dabs(r__4))) * ((r__5 = x[i__5].r, dabs(r__5))
+ + (r__6 = r_imag(&x[i__ - 1 + k * x_dim1]), dabs(
+ r__6))) + ((r__7 = d__[i__6].r, dabs(r__7)) + (
+ r__8 = r_imag(&d__[i__]), dabs(r__8))) * ((r__9 =
+ x[i__7].r, dabs(r__9)) + (r__10 = r_imag(&x[i__ +
+ k * x_dim1]), dabs(r__10))) + ((r__11 = dl[i__8]
+ .r, dabs(r__11)) + (r__12 = r_imag(&dl[i__]),
+ dabs(r__12))) * ((r__13 = x[i__9].r, dabs(r__13))
+ + (r__14 = r_imag(&x[i__ + 1 + k * x_dim1]), dabs(
+ r__14)));
+ axbi = dmin(axbi,tmp);
+/* L50: */
+ }
+ i__2 = *n + k * b_dim1;
+ i__3 = *n - 1;
+ i__4 = *n - 1 + k * x_dim1;
+ i__5 = *n;
+ i__6 = *n + k * x_dim1;
+ tmp = (r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b[*n +
+ k * b_dim1]), dabs(r__2)) + ((r__3 = du[i__3].r, dabs(
+ r__3)) + (r__4 = r_imag(&du[*n - 1]), dabs(r__4))) * (
+ (r__5 = x[i__4].r, dabs(r__5)) + (r__6 = r_imag(&x[*n
+ - 1 + k * x_dim1]), dabs(r__6))) + ((r__7 = d__[i__5]
+ .r, dabs(r__7)) + (r__8 = r_imag(&d__[*n]), dabs(r__8)
+ )) * ((r__9 = x[i__6].r, dabs(r__9)) + (r__10 =
+ r_imag(&x[*n + k * x_dim1]), dabs(r__10)));
+ axbi = dmin(axbi,tmp);
+ }
+ }
+/* Computing MAX */
+ r__1 = axbi, r__2 = nz * unfl;
+ tmp = berr[k] / (nz * eps + nz * unfl / dmax(r__1,r__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = dmax(reslts[2],tmp);
+ }
+/* L60: */
+ }
+
+ return 0;
+
+/* End of CGTT05 */
+
+} /* cgtt05_ */
diff --git a/TESTING/LIN/chet01.c b/TESTING/LIN/chet01.c
new file mode 100644
index 0000000..32fd2f4
--- /dev/null
+++ b/TESTING/LIN/chet01.c
@@ -0,0 +1,238 @@
+/* chet01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+
+/* Subroutine */ int chet01_(char *uplo, integer *n, complex *a, integer *lda,
+ complex *afac, integer *ldafac, integer *ipiv, complex *c__, integer
+ *ldc, real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, c_dim1, c_offset, i__1,
+ i__2, i__3, i__4, i__5;
+ real r__1;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j;
+ real eps;
+ integer info;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern doublereal clanhe_(char *, char *, integer *, complex *, integer *,
+ real *);
+ extern /* Subroutine */ int clavhe_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, integer *, complex *, integer *,
+ integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHET01 reconstructs a Hermitian indefinite matrix A from its */
+/* block L*D*L' or U*D*U' factorization and computes the residual */
+/* norm( C - A ) / ( N * norm(A) * EPS ), */
+/* where C is the reconstructed matrix, EPS is the machine epsilon, */
+/* L' is the conjugate transpose of L, and U' is the conjugate transpose */
+/* of U. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The original Hermitian matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* AFAC (input) COMPLEX array, dimension (LDAFAC,N) */
+/* The factored form of the matrix A. AFAC contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor L or U from the block L*D*L' or U*D*U' factorization */
+/* as computed by CHETRF. */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from CHETRF. */
+
+/* C (workspace) COMPLEX array, dimension (LDC,N) */
+
+/* LDC (integer) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) 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 ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ --ipiv;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Determine EPS and the norm of A. */
+
+ eps = slamch_("Epsilon");
+ anorm = clanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+
+/* Check the imaginary parts of the diagonal elements and return with */
+/* an error code if any are nonzero. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (r_imag(&afac[j + j * afac_dim1]) != 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+/* L10: */
+ }
+
+/* Initialize C to the identity matrix. */
+
+ claset_("Full", n, n, &c_b1, &c_b2, &c__[c_offset], ldc);
+
+/* Call CLAVHE to form the product D * U' (or D * L' ). */
+
+ clavhe_(uplo, "Conjugate", "Non-unit", n, n, &afac[afac_offset], ldafac, &
+ ipiv[1], &c__[c_offset], ldc, &info);
+
+/* Call CLAVHE again to multiply by U (or L ). */
+
+ clavhe_(uplo, "No transpose", "Unit", n, n, &afac[afac_offset], ldafac, &
+ ipiv[1], &c__[c_offset], ldc, &info);
+
+/* Compute the difference C - A . */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * a_dim1;
+ q__1.r = c__[i__4].r - a[i__5].r, q__1.i = c__[i__4].i - a[
+ i__5].i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L20: */
+ }
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ i__4 = j + j * a_dim1;
+ r__1 = a[i__4].r;
+ q__1.r = c__[i__3].r - r__1, q__1.i = c__[i__3].i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+/* L30: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ i__4 = j + j * a_dim1;
+ r__1 = a[i__4].r;
+ q__1.r = c__[i__3].r - r__1, q__1.i = c__[i__3].i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * a_dim1;
+ q__1.r = c__[i__4].r - a[i__5].r, q__1.i = c__[i__4].i - a[
+ i__5].i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+/* Compute norm( C - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = clanhe_("1", uplo, n, &c__[c_offset], ldc, &rwork[1]);
+
+ if (anorm <= 0.f) {
+ if (*resid != 0.f) {
+ *resid = 1.f / eps;
+ }
+ } else {
+ *resid = *resid / (real) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of CHET01 */
+
+} /* chet01_ */
diff --git a/TESTING/LIN/chkxer.c b/TESTING/LIN/chkxer.c
new file mode 100644
index 0000000..24b04b6
--- /dev/null
+++ b/TESTING/LIN/chkxer.c
@@ -0,0 +1,70 @@
+/* chkxer.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+#include "string.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int chkxer_(char *srnamt, integer *infot, integer *nout,
+ logical *lerr, logical *ok)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 *** Illegal value of parameter number"
+ " \002,i2,\002 not detected by \002,a6,\002 ***\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), i_len_trim(
+ char *, ftnlen), e_wsfe(void);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, fmt_9999, 0 };
+
+ int srnamt_len;
+
+ srnamt_len = strlen (srnamt);
+
+
+
+/* Tests whether XERBLA has detected an error when it should. */
+
+/* Auxiliary routine for test program for Level 2 Blas. */
+
+/* -- Written on 10-August-1987. */
+/* Richard Hanson, Sandia National Labs. */
+/* Jeremy Du Croz, NAG Central Office. */
+
+/* ===================================================================== */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ if (! (*lerr)) {
+ io___1.ciunit = *nout;
+ s_wsfe(&io___1);
+ do_fio(&c__1, (char *)&(*infot), (ftnlen)sizeof(integer));
+ do_fio(&c__1, srnamt, i_len_trim(srnamt, srnamt_len));
+ e_wsfe();
+ *ok = FALSE_;
+ }
+ *lerr = FALSE_;
+ return 0;
+
+
+/* End of CHKXER. */
+
+} /* chkxer_ */
diff --git a/TESTING/LIN/chpt01.c b/TESTING/LIN/chpt01.c
new file mode 100644
index 0000000..30651a1
--- /dev/null
+++ b/TESTING/LIN/chpt01.c
@@ -0,0 +1,245 @@
+/* chpt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+
+/* Subroutine */ int chpt01_(char *uplo, integer *n, complex *a, complex *
+ afac, integer *ipiv, complex *c__, integer *ldc, real *rwork, real *
+ resid)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, jc;
+ real eps;
+ integer info;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern doublereal clanhe_(char *, char *, integer *, complex *, integer *,
+ real *), clanhp_(char *, char *, integer *,
+ complex *, real *), slamch_(char *);
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), clavhp_(char *, char
+ *, char *, integer *, integer *, complex *, integer *, complex *,
+ integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CHPT01 reconstructs a Hermitian indefinite packed matrix A from its */
+/* block L*D*L' or U*D*U' factorization and computes the residual */
+/* norm( C - A ) / ( N * norm(A) * EPS ), */
+/* where C is the reconstructed matrix, EPS is the machine epsilon, */
+/* L' is the conjugate transpose of L, and U' is the conjugate transpose */
+/* of U. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The original Hermitian matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* AFAC (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The factored form of the matrix A, stored as a packed */
+/* triangular matrix. AFAC contains the block diagonal matrix D */
+/* and the multipliers used to obtain the factor L or U from the */
+/* block L*D*L' or U*D*U' factorization as computed by CHPTRF. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from CHPTRF. */
+
+/* C (workspace) COMPLEX array, dimension (LDC,N) */
+
+/* LDC (integer) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) 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 ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ --a;
+ --afac;
+ --ipiv;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Determine EPS and the norm of A. */
+
+ eps = slamch_("Epsilon");
+ anorm = clanhp_("1", uplo, n, &a[1], &rwork[1]);
+
+/* Check the imaginary parts of the diagonal elements and return with */
+/* an error code if any are nonzero. */
+
+ jc = 1;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (r_imag(&afac[jc]) != 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+ jc = jc + j + 1;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (r_imag(&afac[jc]) != 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+ jc = jc + *n - j + 1;
+/* L20: */
+ }
+ }
+
+/* Initialize C to the identity matrix. */
+
+ claset_("Full", n, n, &c_b1, &c_b2, &c__[c_offset], ldc);
+
+/* Call CLAVHP to form the product D * U' (or D * L' ). */
+
+ clavhp_(uplo, "Conjugate", "Non-unit", n, n, &afac[1], &ipiv[1], &c__[
+ c_offset], ldc, &info);
+
+/* Call CLAVHP again to multiply by U ( or L ). */
+
+ clavhp_(uplo, "No transpose", "Unit", n, n, &afac[1], &ipiv[1], &c__[
+ c_offset], ldc, &info);
+
+/* Compute the difference C - A . */
+
+ if (lsame_(uplo, "U")) {
+ jc = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = jc + i__;
+ q__1.r = c__[i__4].r - a[i__5].r, q__1.i = c__[i__4].i - a[
+ i__5].i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L30: */
+ }
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ i__4 = jc + j;
+ r__1 = a[i__4].r;
+ q__1.r = c__[i__3].r - r__1, q__1.i = c__[i__3].i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ jc += j;
+/* L40: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ i__4 = jc;
+ r__1 = a[i__4].r;
+ q__1.r = c__[i__3].r - r__1, q__1.i = c__[i__3].i;
+ c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = jc + i__ - j;
+ q__1.r = c__[i__4].r - a[i__5].r, q__1.i = c__[i__4].i - a[
+ i__5].i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L50: */
+ }
+ jc = jc + *n - j + 1;
+/* L60: */
+ }
+ }
+
+/* Compute norm( C - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = clanhe_("1", uplo, n, &c__[c_offset], ldc, &rwork[1]);
+
+ if (anorm <= 0.f) {
+ if (*resid != 0.f) {
+ *resid = 1.f / eps;
+ }
+ } else {
+ *resid = *resid / (real) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of CHPT01 */
+
+} /* chpt01_ */
diff --git a/TESTING/LIN/clahilb.c b/TESTING/LIN/clahilb.c
new file mode 100644
index 0000000..3f2216e
--- /dev/null
+++ b/TESTING/LIN/clahilb.c
@@ -0,0 +1,277 @@
+/* clahilb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static complex c_b6 = {0.f,0.f};
+
+/* Subroutine */ int clahilb_(integer *n, integer *nrhs, complex *a, integer *
+ lda, complex *x, integer *ldx, complex *b, integer *ldb, real *work,
+ integer *info, char *path)
+{
+ /* Initialized data */
+
+ static complex d1[8] = { {-1.f,0.f},{0.f,1.f},{-1.f,-1.f},{0.f,-1.f},{1.f,
+ 0.f},{-1.f,1.f},{1.f,1.f},{1.f,-1.f} };
+ static complex d2[8] = { {-1.f,0.f},{0.f,-1.f},{-1.f,1.f},{0.f,1.f},{1.f,
+ 0.f},{-1.f,-1.f},{1.f,-1.f},{1.f,1.f} };
+ static complex invd1[8] = { {-1.f,0.f},{0.f,-1.f},{-.5f,.5f},{0.f,1.f},{
+ 1.f,0.f},{-.5f,-.5f},{.5f,-.5f},{.5f,.5f} };
+ static complex invd2[8] = { {-1.f,0.f},{0.f,1.f},{-.5f,-.5f},{0.f,-1.f},{
+ 1.f,0.f},{-.5f,.5f},{.5f,.5f},{.5f,-.5f} };
+
+ /* System generated locals */
+ integer a_dim1, a_offset, x_dim1, x_offset, b_dim1, b_offset, i__1, i__2,
+ i__3, i__4, i__5;
+ real r__1;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer i__, j, m, r__;
+ char c2[2];
+ integer ti, tm;
+ complex tmp;
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), xerbla_(char *,
+ integer *);
+ extern logical lsamen_(integer *, char *, char *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
+/* Courant Institute, Argonne National Lab, and Rice University */
+/* 28 August, 2006 */
+
+/* David Vu <dtv at cs.berkeley.edu> */
+/* Yozo Hida <yozo at cs.berkeley.edu> */
+/* Jason Riedy <ejr at cs.berkeley.edu> */
+/* D. Halligan <dhalligan at berkeley.edu> */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAHILB generates an N by N scaled Hilbert matrix in A along with */
+/* NRHS right-hand sides in B and solutions in X such that A*X=B. */
+
+/* The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all */
+/* entries are integers. The right-hand sides are the first NRHS */
+/* columns of M * the identity matrix, and the solutions are the */
+/* first NRHS columns of the inverse Hilbert matrix. */
+
+/* The condition number of the Hilbert matrix grows exponentially with */
+/* its size, roughly as O(e ** (3.5*N)). Additionally, the inverse */
+/* Hilbert matrices beyond a relatively small dimension cannot be */
+/* generated exactly without extra precision. Precision is exhausted */
+/* when the largest entry in the inverse Hilbert matrix is greater than */
+/* 2 to the power of the number of bits in the fraction of the data type */
+/* used plus one, which is 24 for single precision. */
+
+/* In single, the generated solution is exact for N <= 6 and has */
+/* small componentwise error for 7 <= N <= 11. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The dimension of the matrix A. */
+
+/* NRHS (input) NRHS */
+/* The requested number of right-hand sides. */
+
+/* A (output) COMPLEX array, dimension (LDA, N) */
+/* The generated scaled Hilbert matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= N. */
+
+/* X (output) COMPLEX array, dimension (LDX, NRHS) */
+/* The generated exact solutions. Currently, the first NRHS */
+/* columns of the inverse Hilbert matrix. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= N. */
+
+/* B (output) REAL array, dimension (LDB, NRHS) */
+/* The generated right-hand sides. Currently, the first NRHS */
+/* columns of LCM(1, 2, ..., 2*N-1) * the identity matrix. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= N. */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* = 1: N is too large; the data is still generated but may not */
+/* be not exact. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+/* .. Local Scalars .. */
+/* .. Parameters .. */
+/* NMAX_EXACT the largest dimension where the generated data is */
+/* exact. */
+/* NMAX_APPROX the largest dimension where the generated data has */
+/* a small componentwise relative error. */
+/* ??? complex uses how many bits ??? */
+/* d's are generated from random permuation of those eight elements. */
+ /* Parameter adjustments */
+ --work;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+/* .. */
+/* .. External Functions */
+/* .. */
+/* .. Executable Statements .. */
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Test the input arguments */
+
+ *info = 0;
+ if (*n < 0 || *n > 11) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*lda < *n) {
+ *info = -4;
+ } else if (*ldx < *n) {
+ *info = -6;
+ } else if (*ldb < *n) {
+ *info = -8;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("CLAHILB", &i__1);
+ return 0;
+ }
+ if (*n > 6) {
+ *info = 1;
+ }
+/* Compute M = the LCM of the integers [1, 2*N-1]. The largest */
+/* reasonable N is small enough that integers suffice (up to N = 11). */
+ m = 1;
+ i__1 = (*n << 1) - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ tm = m;
+ ti = i__;
+ r__ = tm % ti;
+ while(r__ != 0) {
+ tm = ti;
+ ti = r__;
+ r__ = tm % ti;
+ }
+ m = m / ti * i__;
+ }
+/* Generate the scaled Hilbert matrix in A */
+/* If we are testing SY routines, take D1_i = D2_i, else, D1_i = D2_i* */
+ if (lsamen_(&c__2, c2, "SY")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = j % 8;
+ r__1 = (real) m / (i__ + j - 1);
+ q__2.r = r__1 * d1[i__4].r, q__2.i = r__1 * d1[i__4].i;
+ i__5 = i__ % 8;
+ q__1.r = q__2.r * d1[i__5].r - q__2.i * d1[i__5].i, q__1.i =
+ q__2.r * d1[i__5].i + q__2.i * d1[i__5].r;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ }
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = j % 8;
+ r__1 = (real) m / (i__ + j - 1);
+ q__2.r = r__1 * d1[i__4].r, q__2.i = r__1 * d1[i__4].i;
+ i__5 = i__ % 8;
+ q__1.r = q__2.r * d2[i__5].r - q__2.i * d2[i__5].i, q__1.i =
+ q__2.r * d2[i__5].i + q__2.i * d2[i__5].r;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ }
+ }
+ }
+/* Generate matrix B as simply the first NRHS columns of M * the */
+/* identity. */
+ r__1 = (real) m;
+ tmp.r = r__1, tmp.i = 0.f;
+ claset_("Full", n, nrhs, &c_b6, &tmp, &b[b_offset], ldb);
+/* Generate the true solutions in X. Because B = the first NRHS */
+/* columns of M*I, the true solutions are just the first NRHS columns */
+/* of the inverse Hilbert matrix. */
+ work[1] = (real) (*n);
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ work[j] = work[j - 1] / (j - 1) * (j - 1 - *n) / (j - 1) * (*n + j -
+ 1);
+ }
+/* If we are testing SY routines, take D1_i = D2_i, else, D1_i = D2_i* */
+ if (lsamen_(&c__2, c2, "SY")) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = j % 8;
+ r__1 = work[i__] * work[j] / (i__ + j - 1);
+ q__2.r = r__1 * invd1[i__4].r, q__2.i = r__1 * invd1[i__4].i;
+ i__5 = i__ % 8;
+ q__1.r = q__2.r * invd1[i__5].r - q__2.i * invd1[i__5].i,
+ q__1.i = q__2.r * invd1[i__5].i + q__2.i * invd1[i__5]
+ .r;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ }
+ }
+ } else {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = j % 8;
+ r__1 = work[i__] * work[j] / (i__ + j - 1);
+ q__2.r = r__1 * invd2[i__4].r, q__2.i = r__1 * invd2[i__4].i;
+ i__5 = i__ % 8;
+ q__1.r = q__2.r * invd1[i__5].r - q__2.i * invd1[i__5].i,
+ q__1.i = q__2.r * invd1[i__5].i + q__2.i * invd1[i__5]
+ .r;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ }
+ }
+ }
+ return 0;
+} /* clahilb_ */
diff --git a/TESTING/LIN/claipd.c b/TESTING/LIN/claipd.c
new file mode 100644
index 0000000..87c1161
--- /dev/null
+++ b/TESTING/LIN/claipd.c
@@ -0,0 +1,103 @@
+/* claipd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int claipd_(integer *n, complex *a, integer *inda, integer *
+ vinda)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real r__1;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, ia, ixa;
+ extern doublereal slamch_(char *);
+ real bignum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAIPD sets the imaginary part of the diagonal elements of a complex */
+/* matrix A to a large value. This is used to test LAPACK routines for */
+/* complex Hermitian matrices, which are not supposed to access or use */
+/* the imaginary parts of the diagonals. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of diagonal elements of A. */
+
+/* A (input/output) COMPLEX array, dimension */
+/* (1+(N-1)*INDA+(N-2)*VINDA) */
+/* On entry, the complex (Hermitian) matrix A. */
+/* On exit, the imaginary parts of the diagonal elements are set */
+/* to BIGNUM = EPS / SAFMIN, where EPS is the machine epsilon and */
+/* SAFMIN is the safe minimum. */
+
+/* INDA (input) INTEGER */
+/* The increment between A(1) and the next diagonal element of A. */
+/* Typical values are */
+/* = LDA+1: square matrices with leading dimension LDA */
+/* = 2: packed upper triangular matrix, starting at A(1,1) */
+/* = N: packed lower triangular matrix, starting at A(1,1) */
+
+/* VINDA (input) INTEGER */
+/* The change in the diagonal increment between columns of A. */
+/* Typical values are */
+/* = 0: no change, the row and column increments in A are fixed */
+/* = 1: packed upper triangular matrix */
+/* = -1: packed lower triangular matrix */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --a;
+
+ /* Function Body */
+ bignum = slamch_("Epsilon") / slamch_("Safe minimum");
+ ia = 1;
+ ixa = *inda;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ia;
+ i__3 = ia;
+ r__1 = a[i__3].r;
+ q__1.r = r__1, q__1.i = bignum;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ ia += ixa;
+ ixa += *vinda;
+/* L10: */
+ }
+ return 0;
+} /* claipd_ */
diff --git a/TESTING/LIN/claptm.c b/TESTING/LIN/claptm.c
new file mode 100644
index 0000000..002c9a3
--- /dev/null
+++ b/TESTING/LIN/claptm.c
@@ -0,0 +1,423 @@
+/* claptm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int claptm_(char *uplo, integer *n, integer *nrhs, real *
+ alpha, real *d__, complex *e, complex *x, integer *ldx, real *beta,
+ complex *b, integer *ldb)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6, i__7, i__8, i__9;
+ complex q__1, q__2, q__3, q__4, q__5, q__6, q__7;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j;
+ extern logical lsame_(char *, char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAPTM multiplies an N by NRHS matrix X by a Hermitian tridiagonal */
+/* matrix A and stores the result in a matrix B. The operation has the */
+/* form */
+
+/* B := alpha * A * X + beta * B */
+
+/* where alpha may be either 1. or -1. and beta may be 0., 1., or -1. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER */
+/* Specifies whether the superdiagonal or the subdiagonal of the */
+/* tridiagonal matrix A is stored. */
+/* = 'U': Upper, E is the superdiagonal of A. */
+/* = 'L': Lower, E is the subdiagonal of A. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. */
+
+/* ALPHA (input) REAL */
+/* The scalar alpha. ALPHA must be 1. or -1.; otherwise, */
+/* it is assumed to be 0. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) subdiagonal or superdiagonal elements of A. */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The N by NRHS matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(N,1). */
+
+/* BETA (input) REAL */
+/* The scalar beta. BETA must be 0., 1., or -1.; otherwise, */
+/* it is assumed to be 1. */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the N by NRHS matrix B. */
+/* On exit, B is overwritten by the matrix expression */
+/* B := alpha * A * X + beta * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(N,1). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*beta == 0.f) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0.f, b[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (*beta == -1.f) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ q__1.r = -b[i__4].r, q__1.i = -b[i__4].i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+ if (*alpha == 1.f) {
+ if (lsame_(uplo, "U")) {
+
+/* Compute B := B + A*X, where E is the superdiagonal of A. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ q__2.r = d__[1] * x[i__4].r, q__2.i = d__[1] * x[i__4].i;
+ q__1.r = b[i__3].r + q__2.r, q__1.i = b[i__3].i + q__2.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ q__3.r = d__[1] * x[i__4].r, q__3.i = d__[1] * x[i__4].i;
+ q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i;
+ i__5 = j * x_dim1 + 2;
+ q__4.r = e[1].r * x[i__5].r - e[1].i * x[i__5].i, q__4.i =
+ e[1].r * x[i__5].i + e[1].i * x[i__5].r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ r_cnjg(&q__4, &e[*n - 1]);
+ i__4 = *n - 1 + j * x_dim1;
+ q__3.r = q__4.r * x[i__4].r - q__4.i * x[i__4].i, q__3.i =
+ q__4.r * x[i__4].i + q__4.i * x[i__4].r;
+ q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i;
+ i__5 = *n;
+ i__6 = *n + j * x_dim1;
+ q__5.r = d__[i__5] * x[i__6].r, q__5.i = d__[i__5] * x[
+ i__6].i;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ r_cnjg(&q__5, &e[i__ - 1]);
+ i__5 = i__ - 1 + j * x_dim1;
+ q__4.r = q__5.r * x[i__5].r - q__5.i * x[i__5].i,
+ q__4.i = q__5.r * x[i__5].i + q__5.i * x[i__5]
+ .r;
+ q__3.r = b[i__4].r + q__4.r, q__3.i = b[i__4].i +
+ q__4.i;
+ i__6 = i__;
+ i__7 = i__ + j * x_dim1;
+ q__6.r = d__[i__6] * x[i__7].r, q__6.i = d__[i__6] *
+ x[i__7].i;
+ q__2.r = q__3.r + q__6.r, q__2.i = q__3.i + q__6.i;
+ i__8 = i__;
+ i__9 = i__ + 1 + j * x_dim1;
+ q__7.r = e[i__8].r * x[i__9].r - e[i__8].i * x[i__9]
+ .i, q__7.i = e[i__8].r * x[i__9].i + e[i__8]
+ .i * x[i__9].r;
+ q__1.r = q__2.r + q__7.r, q__1.i = q__2.i + q__7.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else {
+
+/* Compute B := B + A*X, where E is the subdiagonal of A. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ q__2.r = d__[1] * x[i__4].r, q__2.i = d__[1] * x[i__4].i;
+ q__1.r = b[i__3].r + q__2.r, q__1.i = b[i__3].i + q__2.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ q__3.r = d__[1] * x[i__4].r, q__3.i = d__[1] * x[i__4].i;
+ q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i;
+ r_cnjg(&q__5, &e[1]);
+ i__5 = j * x_dim1 + 2;
+ q__4.r = q__5.r * x[i__5].r - q__5.i * x[i__5].i, q__4.i =
+ q__5.r * x[i__5].i + q__5.i * x[i__5].r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ i__4 = *n - 1;
+ i__5 = *n - 1 + j * x_dim1;
+ q__3.r = e[i__4].r * x[i__5].r - e[i__4].i * x[i__5].i,
+ q__3.i = e[i__4].r * x[i__5].i + e[i__4].i * x[
+ i__5].r;
+ q__2.r = b[i__3].r + q__3.r, q__2.i = b[i__3].i + q__3.i;
+ i__6 = *n;
+ i__7 = *n + j * x_dim1;
+ q__4.r = d__[i__6] * x[i__7].r, q__4.i = d__[i__6] * x[
+ i__7].i;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ - 1;
+ i__6 = i__ - 1 + j * x_dim1;
+ q__4.r = e[i__5].r * x[i__6].r - e[i__5].i * x[i__6]
+ .i, q__4.i = e[i__5].r * x[i__6].i + e[i__5]
+ .i * x[i__6].r;
+ q__3.r = b[i__4].r + q__4.r, q__3.i = b[i__4].i +
+ q__4.i;
+ i__7 = i__;
+ i__8 = i__ + j * x_dim1;
+ q__5.r = d__[i__7] * x[i__8].r, q__5.i = d__[i__7] *
+ x[i__8].i;
+ q__2.r = q__3.r + q__5.r, q__2.i = q__3.i + q__5.i;
+ r_cnjg(&q__7, &e[i__]);
+ i__9 = i__ + 1 + j * x_dim1;
+ q__6.r = q__7.r * x[i__9].r - q__7.i * x[i__9].i,
+ q__6.i = q__7.r * x[i__9].i + q__7.i * x[i__9]
+ .r;
+ q__1.r = q__2.r + q__6.r, q__1.i = q__2.i + q__6.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L70: */
+ }
+ }
+/* L80: */
+ }
+ }
+ } else if (*alpha == -1.f) {
+ if (lsame_(uplo, "U")) {
+
+/* Compute B := B - A*X, where E is the superdiagonal of A. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ q__2.r = d__[1] * x[i__4].r, q__2.i = d__[1] * x[i__4].i;
+ q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ q__3.r = d__[1] * x[i__4].r, q__3.i = d__[1] * x[i__4].i;
+ q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
+ i__5 = j * x_dim1 + 2;
+ q__4.r = e[1].r * x[i__5].r - e[1].i * x[i__5].i, q__4.i =
+ e[1].r * x[i__5].i + e[1].i * x[i__5].r;
+ q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ r_cnjg(&q__4, &e[*n - 1]);
+ i__4 = *n - 1 + j * x_dim1;
+ q__3.r = q__4.r * x[i__4].r - q__4.i * x[i__4].i, q__3.i =
+ q__4.r * x[i__4].i + q__4.i * x[i__4].r;
+ q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
+ i__5 = *n;
+ i__6 = *n + j * x_dim1;
+ q__5.r = d__[i__5] * x[i__6].r, q__5.i = d__[i__5] * x[
+ i__6].i;
+ q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - q__5.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ r_cnjg(&q__5, &e[i__ - 1]);
+ i__5 = i__ - 1 + j * x_dim1;
+ q__4.r = q__5.r * x[i__5].r - q__5.i * x[i__5].i,
+ q__4.i = q__5.r * x[i__5].i + q__5.i * x[i__5]
+ .r;
+ q__3.r = b[i__4].r - q__4.r, q__3.i = b[i__4].i -
+ q__4.i;
+ i__6 = i__;
+ i__7 = i__ + j * x_dim1;
+ q__6.r = d__[i__6] * x[i__7].r, q__6.i = d__[i__6] *
+ x[i__7].i;
+ q__2.r = q__3.r - q__6.r, q__2.i = q__3.i - q__6.i;
+ i__8 = i__;
+ i__9 = i__ + 1 + j * x_dim1;
+ q__7.r = e[i__8].r * x[i__9].r - e[i__8].i * x[i__9]
+ .i, q__7.i = e[i__8].r * x[i__9].i + e[i__8]
+ .i * x[i__9].r;
+ q__1.r = q__2.r - q__7.r, q__1.i = q__2.i - q__7.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L90: */
+ }
+ }
+/* L100: */
+ }
+ } else {
+
+/* Compute B := B - A*X, where E is the subdiagonal of A. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ q__2.r = d__[1] * x[i__4].r, q__2.i = d__[1] * x[i__4].i;
+ q__1.r = b[i__3].r - q__2.r, q__1.i = b[i__3].i - q__2.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ q__3.r = d__[1] * x[i__4].r, q__3.i = d__[1] * x[i__4].i;
+ q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
+ r_cnjg(&q__5, &e[1]);
+ i__5 = j * x_dim1 + 2;
+ q__4.r = q__5.r * x[i__5].r - q__5.i * x[i__5].i, q__4.i =
+ q__5.r * x[i__5].i + q__5.i * x[i__5].r;
+ q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ i__4 = *n - 1;
+ i__5 = *n - 1 + j * x_dim1;
+ q__3.r = e[i__4].r * x[i__5].r - e[i__4].i * x[i__5].i,
+ q__3.i = e[i__4].r * x[i__5].i + e[i__4].i * x[
+ i__5].r;
+ q__2.r = b[i__3].r - q__3.r, q__2.i = b[i__3].i - q__3.i;
+ i__6 = *n;
+ i__7 = *n + j * x_dim1;
+ q__4.r = d__[i__6] * x[i__7].r, q__4.i = d__[i__6] * x[
+ i__7].i;
+ q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ - 1;
+ i__6 = i__ - 1 + j * x_dim1;
+ q__4.r = e[i__5].r * x[i__6].r - e[i__5].i * x[i__6]
+ .i, q__4.i = e[i__5].r * x[i__6].i + e[i__5]
+ .i * x[i__6].r;
+ q__3.r = b[i__4].r - q__4.r, q__3.i = b[i__4].i -
+ q__4.i;
+ i__7 = i__;
+ i__8 = i__ + j * x_dim1;
+ q__5.r = d__[i__7] * x[i__8].r, q__5.i = d__[i__7] *
+ x[i__8].i;
+ q__2.r = q__3.r - q__5.r, q__2.i = q__3.i - q__5.i;
+ r_cnjg(&q__7, &e[i__]);
+ i__9 = i__ + 1 + j * x_dim1;
+ q__6.r = q__7.r * x[i__9].r - q__7.i * x[i__9].i,
+ q__6.i = q__7.r * x[i__9].i + q__7.i * x[i__9]
+ .r;
+ q__1.r = q__2.r - q__6.r, q__1.i = q__2.i - q__6.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L110: */
+ }
+ }
+/* L120: */
+ }
+ }
+ }
+ return 0;
+
+/* End of CLAPTM */
+
+} /* claptm_ */
diff --git a/TESTING/LIN/clarhs.c b/TESTING/LIN/clarhs.c
new file mode 100644
index 0000000..c85a49b
--- /dev/null
+++ b/TESTING/LIN/clarhs.c
@@ -0,0 +1,433 @@
+/* clarhs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static complex c_b2 = {0.f,0.f};
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* Subroutine */ int clarhs_(char *path, char *xtype, char *uplo, char *trans,
+ integer *m, integer *n, integer *kl, integer *ku, integer *nrhs,
+ complex *a, integer *lda, complex *x, integer *ldx, complex *b,
+ integer *ldb, integer *iseed, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j;
+ char c1[1], c2[2];
+ integer mb, nx;
+ logical gen, tri, qrs, sym, band;
+ char diag[1];
+ logical tran;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), chemm_(char *,
+ char *, integer *, integer *, complex *, complex *, integer *,
+ complex *, integer *, complex *, complex *, integer *), cgbmv_(char *, integer *, integer *, integer *, integer *
+, complex *, complex *, integer *, complex *, integer *, complex *
+, complex *, integer *), chbmv_(char *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int csbmv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *), ctbmv_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *), chpmv_(char *, integer *, complex *, complex *,
+ complex *, integer *, complex *, complex *, integer *),
+ ctrmm_(char *, char *, char *, char *, integer *, integer *,
+ complex *, complex *, integer *, complex *, integer *), cspmv_(char *, integer *, complex *,
+ complex *, complex *, integer *, complex *, complex *, integer *), csymm_(char *, char *, integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, complex *,
+ integer *), ctpmv_(char *, char *, char *,
+ integer *, complex *, complex *, integer *), clacpy_(char *, integer *, integer *, complex *, integer
+ *, complex *, integer *), xerbla_(char *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int clarnv_(integer *, integer *, integer *,
+ complex *);
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLARHS chooses a set of NRHS random solution vectors and sets */
+/* up the right hand sides for the linear system */
+/* op( A ) * X = B, */
+/* where op( A ) may be A, A**T (transpose of A), or A**H (conjugate */
+/* transpose of A). */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The type of the complex matrix A. PATH may be given in any */
+/* combination of upper and lower case. Valid paths include */
+/* xGE: General m x n matrix */
+/* xGB: General banded matrix */
+/* xPO: Hermitian positive definite, 2-D storage */
+/* xPP: Hermitian positive definite packed */
+/* xPB: Hermitian positive definite banded */
+/* xHE: Hermitian indefinite, 2-D storage */
+/* xHP: Hermitian indefinite packed */
+/* xHB: Hermitian indefinite banded */
+/* xSY: Symmetric indefinite, 2-D storage */
+/* xSP: Symmetric indefinite packed */
+/* xSB: Symmetric indefinite banded */
+/* xTR: Triangular */
+/* xTP: Triangular packed */
+/* xTB: Triangular banded */
+/* xQR: General m x n matrix */
+/* xLQ: General m x n matrix */
+/* xQL: General m x n matrix */
+/* xRQ: General m x n matrix */
+/* where the leading character indicates the precision. */
+
+/* XTYPE (input) CHARACTER*1 */
+/* Specifies how the exact solution X will be determined: */
+/* = 'N': New solution; generate a random X. */
+/* = 'C': Computed; use value of X on entry. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Used only if A is symmetric or triangular; specifies whether */
+/* the upper or lower triangular part of the matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Used only if A is nonsymmetric; specifies the operation */
+/* applied to the matrix A. */
+/* = 'N': B := A * X */
+/* = 'T': B := A**T * X */
+/* = 'C': B := A**H * X */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* Used only if A is a band matrix; specifies the number of */
+/* subdiagonals of A if A is a general band matrix or if A is */
+/* symmetric or triangular and UPLO = 'L'; specifies the number */
+/* of superdiagonals of A if A is symmetric or triangular and */
+/* UPLO = 'U'. 0 <= KL <= M-1. */
+
+/* KU (input) INTEGER */
+/* Used only if A is a general band matrix or if A is */
+/* triangular. */
+
+/* If PATH = xGB, specifies the number of superdiagonals of A, */
+/* and 0 <= KU <= N-1. */
+
+/* If PATH = xTR, xTP, or xTB, specifies whether or not the */
+/* matrix has unit diagonal: */
+/* = 1: matrix has non-unit diagonal (default) */
+/* = 2: matrix has unit diagonal */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors in the system A*X = B. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The test matrix whose type is given by PATH. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If PATH = xGB, LDA >= KL+KU+1. */
+/* If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1. */
+/* Otherwise, LDA >= max(1,M). */
+
+/* X (input or output) COMPLEX array, dimension (LDX,NRHS) */
+/* On entry, if XTYPE = 'C' (for 'Computed'), then X contains */
+/* the exact solution to the system of linear equations. */
+/* On exit, if XTYPE = 'N' (for 'New'), then X is initialized */
+/* with random values. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M). */
+
+/* B (output) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side vector(s) for the system of equations, */
+/* computed from B = op(A) * X, where op(A) is determined by */
+/* TRANS. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. If TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N). */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* The seed vector for the random number generator (used in */
+/* CLATMS). Modified on exit. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --iseed;
+
+ /* Function Body */
+ *info = 0;
+ *(unsigned char *)c1 = *(unsigned char *)path;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ tran = lsame_(trans, "T") || lsame_(trans, "C");
+ notran = ! tran;
+ gen = lsame_(path + 1, "G");
+ qrs = lsame_(path + 1, "Q") || lsame_(path + 2,
+ "Q");
+ sym = lsame_(path + 1, "P") || lsame_(path + 1,
+ "S") || lsame_(path + 1, "H");
+ tri = lsame_(path + 1, "T");
+ band = lsame_(path + 2, "B");
+ if (! lsame_(c1, "Complex precision")) {
+ *info = -1;
+ } else if (! (lsame_(xtype, "N") || lsame_(xtype,
+ "C"))) {
+ *info = -2;
+ } else if ((sym || tri) && ! (lsame_(uplo, "U") ||
+ lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if ((gen || qrs) && ! (tran || lsame_(trans, "N"))) {
+ *info = -4;
+ } else if (*m < 0) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (band && *kl < 0) {
+ *info = -7;
+ } else if (band && *ku < 0) {
+ *info = -8;
+ } else if (*nrhs < 0) {
+ *info = -9;
+ } else if (! band && *lda < max(1,*m) || band && (sym || tri) && *lda < *
+ kl + 1 || band && gen && *lda < *kl + *ku + 1) {
+ *info = -11;
+ } else if (notran && *ldx < max(1,*n) || tran && *ldx < max(1,*m)) {
+ *info = -13;
+ } else if (notran && *ldb < max(1,*m) || tran && *ldb < max(1,*n)) {
+ *info = -15;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLARHS", &i__1);
+ return 0;
+ }
+
+/* Initialize X to NRHS random vectors unless XTYPE = 'C'. */
+
+ if (tran) {
+ nx = *m;
+ mb = *n;
+ } else {
+ nx = *n;
+ mb = *m;
+ }
+ if (! lsame_(xtype, "C")) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ clarnv_(&c__2, &iseed[1], n, &x[j * x_dim1 + 1]);
+/* L10: */
+ }
+ }
+
+/* Multiply X by op( A ) using an appropriate */
+/* matrix multiply routine. */
+
+ if (lsamen_(&c__2, c2, "GE") || lsamen_(&c__2, c2,
+ "QR") || lsamen_(&c__2, c2, "LQ") || lsamen_(&c__2, c2, "QL") ||
+ lsamen_(&c__2, c2, "RQ")) {
+
+/* General matrix */
+
+ cgemm_(trans, "N", &mb, nrhs, &nx, &c_b1, &a[a_offset], lda, &x[
+ x_offset], ldx, &c_b2, &b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "PO") || lsamen_(&
+ c__2, c2, "HE")) {
+
+/* Hermitian matrix, 2-D storage */
+
+ chemm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset],
+ ldx, &c_b2, &b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "SY")) {
+
+/* Symmetric matrix, 2-D storage */
+
+ csymm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset],
+ ldx, &c_b2, &b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* General matrix, band storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ cgbmv_(trans, m, n, kl, ku, &c_b1, &a[a_offset], lda, &x[j *
+ x_dim1 + 1], &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
+/* L20: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "PB") || lsamen_(&
+ c__2, c2, "HB")) {
+
+/* Hermitian matrix, band storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ chbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1],
+ &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
+/* L30: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "SB")) {
+
+/* Symmetric matrix, band storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ csbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1],
+ &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
+/* L40: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "PP") || lsamen_(&
+ c__2, c2, "HP")) {
+
+/* Hermitian matrix, packed storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ chpmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
+ c_b2, &b[j * b_dim1 + 1], &c__1);
+/* L50: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "SP")) {
+
+/* Symmetric matrix, packed storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ cspmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
+ c_b2, &b[j * b_dim1 + 1], &c__1);
+/* L60: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "TR")) {
+
+/* Triangular matrix. Note that for triangular matrices, */
+/* KU = 1 => non-unit triangular */
+/* KU = 2 => unit triangular */
+
+ clacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ ctrmm_("Left", uplo, trans, diag, n, nrhs, &c_b1, &a[a_offset], lda, &
+ b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "TP")) {
+
+/* Triangular matrix, packed storage */
+
+ clacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ctpmv_(uplo, trans, diag, n, &a[a_offset], &b[j * b_dim1 + 1], &
+ c__1);
+/* L70: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "TB")) {
+
+/* Triangular matrix, banded storage */
+
+ clacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ctbmv_(uplo, trans, diag, n, kl, &a[a_offset], lda, &b[j * b_dim1
+ + 1], &c__1);
+/* L80: */
+ }
+
+ } else {
+
+/* If none of the above, set INFO = -1 and return */
+
+ *info = -1;
+ i__1 = -(*info);
+ xerbla_("CLARHS", &i__1);
+ }
+
+ return 0;
+
+/* End of CLARHS */
+
+} /* clarhs_ */
diff --git a/TESTING/LIN/clatb4.c b/TESTING/LIN/clatb4.c
new file mode 100644
index 0000000..f6e365d
--- /dev/null
+++ b/TESTING/LIN/clatb4.c
@@ -0,0 +1,482 @@
+/* clatb4.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+
+/* Subroutine */ int clatb4_(char *path, integer *imat, integer *m, integer *
+ n, char *type__, integer *kl, integer *ku, real *anorm, integer *mode,
+ real *cndnum, char *dist)
+{
+ /* Initialized data */
+
+ static logical first = TRUE_;
+
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ char c2[2];
+ integer mat;
+ static real eps, badc1, badc2, large, small;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ extern logical lsamen_(integer *, char *, char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLATB4 sets parameters for the matrix generator based on the type of */
+/* matrix to be generated. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name. */
+
+/* IMAT (input) INTEGER */
+/* An integer key describing which matrix to generate for this */
+/* path. */
+
+/* M (input) INTEGER */
+/* The number of rows in the matrix to be generated. */
+
+/* N (input) INTEGER */
+/* The number of columns in the matrix to be generated. */
+
+/* TYPE (output) CHARACTER*1 */
+/* The type of the matrix to be generated: */
+/* = 'S': symmetric matrix */
+/* = 'P': symmetric positive (semi)definite matrix */
+/* = 'N': nonsymmetric matrix */
+
+/* KL (output) INTEGER */
+/* The lower band width of the matrix to be generated. */
+
+/* KU (output) INTEGER */
+/* The upper band width of the matrix to be generated. */
+
+/* ANORM (output) REAL */
+/* The desired norm of the matrix to be generated. The diagonal */
+/* matrix of singular values or eigenvalues is scaled by this */
+/* value. */
+
+/* MODE (output) INTEGER */
+/* A key indicating how to choose the vector of eigenvalues. */
+
+/* CNDNUM (output) REAL */
+/* The desired condition number. */
+
+/* DIST (output) CHARACTER*1 */
+/* The type of distribution to be used by the random number */
+/* generator. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Set some constants for use in the subroutine. */
+
+ if (first) {
+ first = FALSE_;
+ eps = slamch_("Precision");
+ badc2 = .1f / eps;
+ badc1 = sqrt(badc2);
+ small = slamch_("Safe minimum");
+ large = 1.f / small;
+
+/* If it looks like we're on a Cray, take the square root of */
+/* SMALL and LARGE to avoid overflow and underflow problems. */
+
+ slabad_(&small, &large);
+ small = small / eps * .25f;
+ large = 1.f / small;
+ }
+
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set some parameters we don't plan to change. */
+
+ *(unsigned char *)dist = 'S';
+ *mode = 3;
+
+/* xQR, xLQ, xQL, xRQ: Set parameters to generate a general */
+/* M x N matrix. */
+
+ if (lsamen_(&c__2, c2, "QR") || lsamen_(&c__2, c2,
+ "LQ") || lsamen_(&c__2, c2, "QL") || lsamen_(&c__2, c2, "RQ")) {
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the lower and upper bandwidths. */
+
+ if (*imat == 1) {
+ *kl = 0;
+ *ku = 0;
+ } else if (*imat == 2) {
+ *kl = 0;
+/* Computing MAX */
+ i__1 = *n - 1;
+ *ku = max(i__1,0);
+ } else if (*imat == 3) {
+/* Computing MAX */
+ i__1 = *m - 1;
+ *kl = max(i__1,0);
+ *ku = 0;
+ } else {
+/* Computing MAX */
+ i__1 = *m - 1;
+ *kl = max(i__1,0);
+/* Computing MAX */
+ i__1 = *n - 1;
+ *ku = max(i__1,0);
+ }
+
+/* Set the condition number and norm. */
+
+ if (*imat == 5) {
+ *cndnum = badc1;
+ } else if (*imat == 6) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.f;
+ }
+
+ if (*imat == 7) {
+ *anorm = small;
+ } else if (*imat == 8) {
+ *anorm = large;
+ } else {
+ *anorm = 1.f;
+ }
+
+ } else if (lsamen_(&c__2, c2, "GE")) {
+
+/* xGE: Set parameters to generate a general M x N matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the lower and upper bandwidths. */
+
+ if (*imat == 1) {
+ *kl = 0;
+ *ku = 0;
+ } else if (*imat == 2) {
+ *kl = 0;
+/* Computing MAX */
+ i__1 = *n - 1;
+ *ku = max(i__1,0);
+ } else if (*imat == 3) {
+/* Computing MAX */
+ i__1 = *m - 1;
+ *kl = max(i__1,0);
+ *ku = 0;
+ } else {
+/* Computing MAX */
+ i__1 = *m - 1;
+ *kl = max(i__1,0);
+/* Computing MAX */
+ i__1 = *n - 1;
+ *ku = max(i__1,0);
+ }
+
+/* Set the condition number and norm. */
+
+ if (*imat == 8) {
+ *cndnum = badc1;
+ } else if (*imat == 9) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.f;
+ }
+
+ if (*imat == 10) {
+ *anorm = small;
+ } else if (*imat == 11) {
+ *anorm = large;
+ } else {
+ *anorm = 1.f;
+ }
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* xGB: Set parameters to generate a general banded matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the condition number and norm. */
+
+ if (*imat == 5) {
+ *cndnum = badc1;
+ } else if (*imat == 6) {
+ *cndnum = badc2 * .1f;
+ } else {
+ *cndnum = 2.f;
+ }
+
+ if (*imat == 7) {
+ *anorm = small;
+ } else if (*imat == 8) {
+ *anorm = large;
+ } else {
+ *anorm = 1.f;
+ }
+
+ } else if (lsamen_(&c__2, c2, "GT")) {
+
+/* xGT: Set parameters to generate a general tridiagonal matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the lower and upper bandwidths. */
+
+ if (*imat == 1) {
+ *kl = 0;
+ } else {
+ *kl = 1;
+ }
+ *ku = *kl;
+
+/* Set the condition number and norm. */
+
+ if (*imat == 3) {
+ *cndnum = badc1;
+ } else if (*imat == 4) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.f;
+ }
+
+ if (*imat == 5 || *imat == 11) {
+ *anorm = small;
+ } else if (*imat == 6 || *imat == 12) {
+ *anorm = large;
+ } else {
+ *anorm = 1.f;
+ }
+
+ } else if (lsamen_(&c__2, c2, "PO") || lsamen_(&
+ c__2, c2, "PP") || lsamen_(&c__2, c2, "HE") || lsamen_(&c__2, c2, "HP") || lsamen_(&c__2, c2, "SY") ||
+ lsamen_(&c__2, c2, "SP")) {
+
+/* xPO, xPP, xHE, xHP, xSY, xSP: Set parameters to generate a */
+/* symmetric or Hermitian matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = *(unsigned char *)c2;
+
+/* Set the lower and upper bandwidths. */
+
+ if (*imat == 1) {
+ *kl = 0;
+ } else {
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kl = max(i__1,0);
+ }
+ *ku = *kl;
+
+/* Set the condition number and norm. */
+
+ if (*imat == 6) {
+ *cndnum = badc1;
+ } else if (*imat == 7) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.f;
+ }
+
+ if (*imat == 8) {
+ *anorm = small;
+ } else if (*imat == 9) {
+ *anorm = large;
+ } else {
+ *anorm = 1.f;
+ }
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* xPB: Set parameters to generate a symmetric band matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'P';
+
+/* Set the norm and condition number. */
+
+ if (*imat == 5) {
+ *cndnum = badc1;
+ } else if (*imat == 6) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.f;
+ }
+
+ if (*imat == 7) {
+ *anorm = small;
+ } else if (*imat == 8) {
+ *anorm = large;
+ } else {
+ *anorm = 1.f;
+ }
+
+ } else if (lsamen_(&c__2, c2, "PT")) {
+
+/* xPT: Set parameters to generate a symmetric positive definite */
+/* tridiagonal matrix. */
+
+ *(unsigned char *)type__ = 'P';
+ if (*imat == 1) {
+ *kl = 0;
+ } else {
+ *kl = 1;
+ }
+ *ku = *kl;
+
+/* Set the condition number and norm. */
+
+ if (*imat == 3) {
+ *cndnum = badc1;
+ } else if (*imat == 4) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.f;
+ }
+
+ if (*imat == 5 || *imat == 11) {
+ *anorm = small;
+ } else if (*imat == 6 || *imat == 12) {
+ *anorm = large;
+ } else {
+ *anorm = 1.f;
+ }
+
+ } else if (lsamen_(&c__2, c2, "TR") || lsamen_(&
+ c__2, c2, "TP")) {
+
+/* xTR, xTP: Set parameters to generate a triangular matrix */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the lower and upper bandwidths. */
+
+ mat = abs(*imat);
+ if (mat == 1 || mat == 7) {
+ *kl = 0;
+ *ku = 0;
+ } else if (*imat < 0) {
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kl = max(i__1,0);
+ *ku = 0;
+ } else {
+ *kl = 0;
+/* Computing MAX */
+ i__1 = *n - 1;
+ *ku = max(i__1,0);
+ }
+
+/* Set the condition number and norm. */
+
+ if (mat == 3 || mat == 9) {
+ *cndnum = badc1;
+ } else if (mat == 4 || mat == 10) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.f;
+ }
+
+ if (mat == 5) {
+ *anorm = small;
+ } else if (mat == 6) {
+ *anorm = large;
+ } else {
+ *anorm = 1.f;
+ }
+
+ } else if (lsamen_(&c__2, c2, "TB")) {
+
+/* xTB: Set parameters to generate a triangular band matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the norm and condition number. */
+
+ if (*imat == 2 || *imat == 8) {
+ *cndnum = badc1;
+ } else if (*imat == 3 || *imat == 9) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.f;
+ }
+
+ if (*imat == 4) {
+ *anorm = small;
+ } else if (*imat == 5) {
+ *anorm = large;
+ } else {
+ *anorm = 1.f;
+ }
+ }
+ if (*n <= 1) {
+ *cndnum = 1.f;
+ }
+
+ return 0;
+
+/* End of CLATB4 */
+
+} /* clatb4_ */
diff --git a/TESTING/LIN/clatb5.c b/TESTING/LIN/clatb5.c
new file mode 100644
index 0000000..74172da
--- /dev/null
+++ b/TESTING/LIN/clatb5.c
@@ -0,0 +1,184 @@
+/* clatb5.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int clatb5_(char *path, integer *imat, integer *n, char *
+ type__, integer *kl, integer *ku, real *anorm, integer *mode, real *
+ cndnum, char *dist)
+{
+ /* Initialized data */
+
+ static logical first = TRUE_;
+
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ char c2[2];
+ static real eps, badc1, badc2, large, small;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLATB5 sets parameters for the matrix generator based on the type */
+/* of matrix to be generated. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name. */
+
+/* IMAT (input) INTEGER */
+/* An integer key describing which matrix to generate for this */
+/* path. */
+
+/* N (input) INTEGER */
+/* The number of rows and columns in the matrix to be generated. */
+
+/* TYPE (output) CHARACTER*1 */
+/* The type of the matrix to be generated: */
+/* = 'S': symmetric matrix */
+/* = 'P': symmetric positive (semi)definite matrix */
+/* = 'N': nonsymmetric matrix */
+
+/* KL (output) INTEGER */
+/* The lower band width of the matrix to be generated. */
+
+/* KU (output) INTEGER */
+/* The upper band width of the matrix to be generated. */
+
+/* ANORM (output) REAL */
+/* The desired norm of the matrix to be generated. The diagonal */
+/* matrix of singular values or eigenvalues is scaled by this */
+/* value. */
+
+/* MODE (output) INTEGER */
+/* A key indicating how to choose the vector of eigenvalues. */
+
+/* CNDNUM (output) REAL */
+/* The desired condition number. */
+
+/* DIST (output) CHARACTER*1 */
+/* The type of distribution to be used by the random number */
+/* generator. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Set some constants for use in the subroutine. */
+
+ if (first) {
+ first = FALSE_;
+ eps = slamch_("Precision");
+ badc2 = .1f / eps;
+ badc1 = sqrt(badc2);
+ small = slamch_("Safe minimum");
+ large = 1.f / small;
+
+/* If it looks like we're on a Cray, take the square root of */
+/* SMALL and LARGE to avoid overflow and underflow problems. */
+
+ slabad_(&small, &large);
+ small = small / eps * .25f;
+ large = 1.f / small;
+ }
+
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set some parameters */
+
+ *(unsigned char *)dist = 'S';
+ *mode = 3;
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = *(unsigned char *)c2;
+
+/* Set the lower and upper bandwidths. */
+
+ if (*imat == 1) {
+ *kl = 0;
+ } else {
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kl = max(i__1,0);
+ }
+ *ku = *kl;
+
+/* Set the condition number and norm.etc */
+
+ if (*imat == 3) {
+ *cndnum = 1e4f;
+ *mode = 2;
+ } else if (*imat == 4) {
+ *cndnum = 1e4f;
+ *mode = 1;
+ } else if (*imat == 5) {
+ *cndnum = 1e4f;
+ *mode = 3;
+ } else if (*imat == 6) {
+ *cndnum = badc1;
+ } else if (*imat == 7) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.f;
+ }
+
+ if (*imat == 8) {
+ *anorm = small;
+ } else if (*imat == 9) {
+ *anorm = large;
+ } else {
+ *anorm = 1.f;
+ }
+
+ if (*n <= 1) {
+ *cndnum = 1.f;
+ }
+
+ return 0;
+
+/* End of SLATB5 */
+
+} /* clatb5_ */
diff --git a/TESTING/LIN/clatsp.c b/TESTING/LIN/clatsp.c
new file mode 100644
index 0000000..384ab29
--- /dev/null
+++ b/TESTING/LIN/clatsp.c
@@ -0,0 +1,357 @@
+/* clatsp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__5 = 5;
+static integer c__2 = 2;
+
+/* Subroutine */ int clatsp_(char *uplo, integer *n, complex *x, integer *
+ iseed)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal), c_abs(complex *);
+
+ /* Local variables */
+ complex a, b, c__;
+ integer j;
+ complex r__;
+ integer n5, jj;
+ real beta, alpha, alpha3;
+ extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLATSP generates a special test matrix for the complex symmetric */
+/* (indefinite) factorization for packed matrices. The pivot blocks of */
+/* the generated matrix will be in the following order: */
+/* 2x2 pivot block, non diagonalizable */
+/* 1x1 pivot block */
+/* 2x2 pivot block, diagonalizable */
+/* (cycle repeats) */
+/* A row interchange is required for each non-diagonalizable 2x2 block. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER */
+/* Specifies whether the generated matrix is to be upper or */
+/* lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The dimension of the matrix to be generated. */
+
+/* X (output) COMPLEX array, dimension (N*(N+1)/2) */
+/* The generated matrix in packed storage format. The matrix */
+/* consists of 3x3 and 2x2 diagonal blocks which result in the */
+/* pivot sequence given above. The matrix outside these */
+/* diagonal blocks is zero. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed for the random number generator. The last */
+/* of the four integers must be odd. (modified on exit) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants */
+
+ /* Parameter adjustments */
+ --iseed;
+ --x;
+
+ /* Function Body */
+ alpha = (sqrt(17.f) + 1.f) / 8.f;
+ beta = alpha - .001f;
+ alpha3 = alpha * alpha * alpha;
+
+/* Fill the matrix with zeros. */
+
+ i__1 = *n * (*n + 1) / 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ x[i__2].r = 0.f, x[i__2].i = 0.f;
+/* L10: */
+ }
+
+/* UPLO = 'U': Upper triangular storage */
+
+ if (*(unsigned char *)uplo == 'U') {
+ n5 = *n / 5;
+ n5 = *n - n5 * 5 + 1;
+
+ jj = *n * (*n + 1) / 2;
+ i__1 = n5;
+ for (j = *n; j >= i__1; j += -5) {
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = alpha3 * q__2.r, q__1.i = alpha3 * q__2.i;
+ a.r = q__1.r, a.i = q__1.i;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = q__2.r / alpha, q__1.i = q__2.i / alpha;
+ b.r = q__1.r, b.i = q__1.i;
+ q__3.r = b.r * 2.f, q__3.i = b.i * 2.f;
+ q__2.r = q__3.r * 0.f - q__3.i * 1.f, q__2.i = q__3.r * 1.f +
+ q__3.i * 0.f;
+ q__1.r = a.r - q__2.r, q__1.i = a.i - q__2.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__1.r = c__.r / beta, q__1.i = c__.i / beta;
+ r__.r = q__1.r, r__.i = q__1.i;
+ i__2 = jj;
+ x[i__2].r = a.r, x[i__2].i = a.i;
+ i__2 = jj - 2;
+ x[i__2].r = b.r, x[i__2].i = b.i;
+ jj -= j;
+ i__2 = jj;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ i__2 = jj - 1;
+ x[i__2].r = r__.r, x[i__2].i = r__.i;
+ jj -= j - 1;
+ i__2 = jj;
+ x[i__2].r = c__.r, x[i__2].i = c__.i;
+ jj -= j - 2;
+ i__2 = jj;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ jj -= j - 3;
+ i__2 = jj;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ if (c_abs(&x[jj + (j - 3)]) > c_abs(&x[jj])) {
+ i__2 = jj + (j - 4);
+ i__3 = jj + (j - 3);
+ q__1.r = x[i__3].r * 2.f, q__1.i = x[i__3].i * 2.f;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ } else {
+ i__2 = jj + (j - 4);
+ i__3 = jj;
+ q__1.r = x[i__3].r * 2.f, q__1.i = x[i__3].i * 2.f;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ }
+ jj -= j - 4;
+/* L20: */
+ }
+
+/* Clean-up for N not a multiple of 5. */
+
+ j = n5 - 1;
+ if (j > 2) {
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = alpha3 * q__2.r, q__1.i = alpha3 * q__2.i;
+ a.r = q__1.r, a.i = q__1.i;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = q__2.r / alpha, q__1.i = q__2.i / alpha;
+ b.r = q__1.r, b.i = q__1.i;
+ q__3.r = b.r * 2.f, q__3.i = b.i * 2.f;
+ q__2.r = q__3.r * 0.f - q__3.i * 1.f, q__2.i = q__3.r * 1.f +
+ q__3.i * 0.f;
+ q__1.r = a.r - q__2.r, q__1.i = a.i - q__2.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__1.r = c__.r / beta, q__1.i = c__.i / beta;
+ r__.r = q__1.r, r__.i = q__1.i;
+ i__1 = jj;
+ x[i__1].r = a.r, x[i__1].i = a.i;
+ i__1 = jj - 2;
+ x[i__1].r = b.r, x[i__1].i = b.i;
+ jj -= j;
+ i__1 = jj;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ i__1 = jj - 1;
+ x[i__1].r = r__.r, x[i__1].i = r__.i;
+ jj -= j - 1;
+ i__1 = jj;
+ x[i__1].r = c__.r, x[i__1].i = c__.i;
+ jj -= j - 2;
+ j += -3;
+ }
+ if (j > 1) {
+ i__1 = jj;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ i__1 = jj - j;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ if (c_abs(&x[jj]) > c_abs(&x[jj - j])) {
+ i__1 = jj - 1;
+ i__2 = jj;
+ q__1.r = x[i__2].r * 2.f, q__1.i = x[i__2].i * 2.f;
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ } else {
+ i__1 = jj - 1;
+ i__2 = jj - j;
+ q__1.r = x[i__2].r * 2.f, q__1.i = x[i__2].i * 2.f;
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ }
+ jj = jj - j - (j - 1);
+ j += -2;
+ } else if (j == 1) {
+ i__1 = jj;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ --j;
+ }
+
+/* UPLO = 'L': Lower triangular storage */
+
+ } else {
+ n5 = *n / 5;
+ n5 *= 5;
+
+ jj = 1;
+ i__1 = n5;
+ for (j = 1; j <= i__1; j += 5) {
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = alpha3 * q__2.r, q__1.i = alpha3 * q__2.i;
+ a.r = q__1.r, a.i = q__1.i;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = q__2.r / alpha, q__1.i = q__2.i / alpha;
+ b.r = q__1.r, b.i = q__1.i;
+ q__3.r = b.r * 2.f, q__3.i = b.i * 2.f;
+ q__2.r = q__3.r * 0.f - q__3.i * 1.f, q__2.i = q__3.r * 1.f +
+ q__3.i * 0.f;
+ q__1.r = a.r - q__2.r, q__1.i = a.i - q__2.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__1.r = c__.r / beta, q__1.i = c__.i / beta;
+ r__.r = q__1.r, r__.i = q__1.i;
+ i__2 = jj;
+ x[i__2].r = a.r, x[i__2].i = a.i;
+ i__2 = jj + 2;
+ x[i__2].r = b.r, x[i__2].i = b.i;
+ jj += *n - j + 1;
+ i__2 = jj;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ i__2 = jj + 1;
+ x[i__2].r = r__.r, x[i__2].i = r__.i;
+ jj += *n - j;
+ i__2 = jj;
+ x[i__2].r = c__.r, x[i__2].i = c__.i;
+ jj += *n - j - 1;
+ i__2 = jj;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ jj += *n - j - 2;
+ i__2 = jj;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ if (c_abs(&x[jj - (*n - j - 2)]) > c_abs(&x[jj])) {
+ i__2 = jj - (*n - j - 2) + 1;
+ i__3 = jj - (*n - j - 2);
+ q__1.r = x[i__3].r * 2.f, q__1.i = x[i__3].i * 2.f;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ } else {
+ i__2 = jj - (*n - j - 2) + 1;
+ i__3 = jj;
+ q__1.r = x[i__3].r * 2.f, q__1.i = x[i__3].i * 2.f;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ }
+ jj += *n - j - 3;
+/* L30: */
+ }
+
+/* Clean-up for N not a multiple of 5. */
+
+ j = n5 + 1;
+ if (j < *n - 1) {
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = alpha3 * q__2.r, q__1.i = alpha3 * q__2.i;
+ a.r = q__1.r, a.i = q__1.i;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = q__2.r / alpha, q__1.i = q__2.i / alpha;
+ b.r = q__1.r, b.i = q__1.i;
+ q__3.r = b.r * 2.f, q__3.i = b.i * 2.f;
+ q__2.r = q__3.r * 0.f - q__3.i * 1.f, q__2.i = q__3.r * 1.f +
+ q__3.i * 0.f;
+ q__1.r = a.r - q__2.r, q__1.i = a.i - q__2.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__1.r = c__.r / beta, q__1.i = c__.i / beta;
+ r__.r = q__1.r, r__.i = q__1.i;
+ i__1 = jj;
+ x[i__1].r = a.r, x[i__1].i = a.i;
+ i__1 = jj + 2;
+ x[i__1].r = b.r, x[i__1].i = b.i;
+ jj += *n - j + 1;
+ i__1 = jj;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ i__1 = jj + 1;
+ x[i__1].r = r__.r, x[i__1].i = r__.i;
+ jj += *n - j;
+ i__1 = jj;
+ x[i__1].r = c__.r, x[i__1].i = c__.i;
+ jj += *n - j - 1;
+ j += 3;
+ }
+ if (j < *n) {
+ i__1 = jj;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ i__1 = jj + (*n - j + 1);
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ if (c_abs(&x[jj]) > c_abs(&x[jj + (*n - j + 1)])) {
+ i__1 = jj + 1;
+ i__2 = jj;
+ q__1.r = x[i__2].r * 2.f, q__1.i = x[i__2].i * 2.f;
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ } else {
+ i__1 = jj + 1;
+ i__2 = jj + (*n - j + 1);
+ q__1.r = x[i__2].r * 2.f, q__1.i = x[i__2].i * 2.f;
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ }
+ jj = jj + (*n - j + 1) + (*n - j);
+ j += 2;
+ } else if (j == *n) {
+ i__1 = jj;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ jj += *n - j + 1;
+ ++j;
+ }
+ }
+
+ return 0;
+
+/* End of CLATSP */
+
+} /* clatsp_ */
diff --git a/TESTING/LIN/clatsy.c b/TESTING/LIN/clatsy.c
new file mode 100644
index 0000000..43f17e8
--- /dev/null
+++ b/TESTING/LIN/clatsy.c
@@ -0,0 +1,361 @@
+/* clatsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__5 = 5;
+static integer c__2 = 2;
+
+/* Subroutine */ int clatsy_(char *uplo, integer *n, complex *x, integer *ldx,
+ integer *iseed)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, i__1, i__2, i__3;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal), c_abs(complex *);
+
+ /* Local variables */
+ complex a, b, c__;
+ integer i__, j;
+ complex r__;
+ integer n5;
+ real beta, alpha, alpha3;
+ extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLATSY generates a special test matrix for the complex symmetric */
+/* (indefinite) factorization. The pivot blocks of the generated matrix */
+/* will be in the following order: */
+/* 2x2 pivot block, non diagonalizable */
+/* 1x1 pivot block */
+/* 2x2 pivot block, diagonalizable */
+/* (cycle repeats) */
+/* A row interchange is required for each non-diagonalizable 2x2 block. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER */
+/* Specifies whether the generated matrix is to be upper or */
+/* lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The dimension of the matrix to be generated. */
+
+/* X (output) COMPLEX array, dimension (LDX,N) */
+/* The generated matrix, consisting of 3x3 and 2x2 diagonal */
+/* blocks which result in the pivot sequence given above. */
+/* The matrix outside of these diagonal blocks is zero. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed for the random number generator. The last */
+/* of the four integers must be odd. (modified on exit) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants */
+
+ /* Parameter adjustments */
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --iseed;
+
+ /* Function Body */
+ alpha = (sqrt(17.f) + 1.f) / 8.f;
+ beta = alpha - .001f;
+ alpha3 = alpha * alpha * alpha;
+
+/* UPLO = 'U': Upper triangular storage */
+
+ if (*(unsigned char *)uplo == 'U') {
+
+/* Fill the upper triangle of the matrix with zeros. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ x[i__3].r = 0.f, x[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ n5 = *n / 5;
+ n5 = *n - n5 * 5 + 1;
+
+ i__1 = n5;
+ for (i__ = *n; i__ >= i__1; i__ += -5) {
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = alpha3 * q__2.r, q__1.i = alpha3 * q__2.i;
+ a.r = q__1.r, a.i = q__1.i;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = q__2.r / alpha, q__1.i = q__2.i / alpha;
+ b.r = q__1.r, b.i = q__1.i;
+ q__3.r = b.r * 2.f, q__3.i = b.i * 2.f;
+ q__2.r = q__3.r * 0.f - q__3.i * 1.f, q__2.i = q__3.r * 1.f +
+ q__3.i * 0.f;
+ q__1.r = a.r - q__2.r, q__1.i = a.i - q__2.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__1.r = c__.r / beta, q__1.i = c__.i / beta;
+ r__.r = q__1.r, r__.i = q__1.i;
+ i__2 = i__ + i__ * x_dim1;
+ x[i__2].r = a.r, x[i__2].i = a.i;
+ i__2 = i__ - 2 + i__ * x_dim1;
+ x[i__2].r = b.r, x[i__2].i = b.i;
+ i__2 = i__ - 2 + (i__ - 1) * x_dim1;
+ x[i__2].r = r__.r, x[i__2].i = r__.i;
+ i__2 = i__ - 2 + (i__ - 2) * x_dim1;
+ x[i__2].r = c__.r, x[i__2].i = c__.i;
+ i__2 = i__ - 1 + (i__ - 1) * x_dim1;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ i__2 = i__ - 3 + (i__ - 3) * x_dim1;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ i__2 = i__ - 4 + (i__ - 4) * x_dim1;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ if (c_abs(&x[i__ - 3 + (i__ - 3) * x_dim1]) > c_abs(&x[i__ - 4 + (
+ i__ - 4) * x_dim1])) {
+ i__2 = i__ - 4 + (i__ - 3) * x_dim1;
+ i__3 = i__ - 3 + (i__ - 3) * x_dim1;
+ q__1.r = x[i__3].r * 2.f, q__1.i = x[i__3].i * 2.f;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ } else {
+ i__2 = i__ - 4 + (i__ - 3) * x_dim1;
+ i__3 = i__ - 4 + (i__ - 4) * x_dim1;
+ q__1.r = x[i__3].r * 2.f, q__1.i = x[i__3].i * 2.f;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ }
+/* L30: */
+ }
+
+/* Clean-up for N not a multiple of 5. */
+
+ i__ = n5 - 1;
+ if (i__ > 2) {
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = alpha3 * q__2.r, q__1.i = alpha3 * q__2.i;
+ a.r = q__1.r, a.i = q__1.i;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = q__2.r / alpha, q__1.i = q__2.i / alpha;
+ b.r = q__1.r, b.i = q__1.i;
+ q__3.r = b.r * 2.f, q__3.i = b.i * 2.f;
+ q__2.r = q__3.r * 0.f - q__3.i * 1.f, q__2.i = q__3.r * 1.f +
+ q__3.i * 0.f;
+ q__1.r = a.r - q__2.r, q__1.i = a.i - q__2.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__1.r = c__.r / beta, q__1.i = c__.i / beta;
+ r__.r = q__1.r, r__.i = q__1.i;
+ i__1 = i__ + i__ * x_dim1;
+ x[i__1].r = a.r, x[i__1].i = a.i;
+ i__1 = i__ - 2 + i__ * x_dim1;
+ x[i__1].r = b.r, x[i__1].i = b.i;
+ i__1 = i__ - 2 + (i__ - 1) * x_dim1;
+ x[i__1].r = r__.r, x[i__1].i = r__.i;
+ i__1 = i__ - 2 + (i__ - 2) * x_dim1;
+ x[i__1].r = c__.r, x[i__1].i = c__.i;
+ i__1 = i__ - 1 + (i__ - 1) * x_dim1;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ i__ += -3;
+ }
+ if (i__ > 1) {
+ i__1 = i__ + i__ * x_dim1;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ i__1 = i__ - 1 + (i__ - 1) * x_dim1;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ if (c_abs(&x[i__ + i__ * x_dim1]) > c_abs(&x[i__ - 1 + (i__ - 1) *
+ x_dim1])) {
+ i__1 = i__ - 1 + i__ * x_dim1;
+ i__2 = i__ + i__ * x_dim1;
+ q__1.r = x[i__2].r * 2.f, q__1.i = x[i__2].i * 2.f;
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ } else {
+ i__1 = i__ - 1 + i__ * x_dim1;
+ i__2 = i__ - 1 + (i__ - 1) * x_dim1;
+ q__1.r = x[i__2].r * 2.f, q__1.i = x[i__2].i * 2.f;
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ }
+ i__ += -2;
+ } else if (i__ == 1) {
+ i__1 = i__ + i__ * x_dim1;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ --i__;
+ }
+
+/* UPLO = 'L': Lower triangular storage */
+
+ } else {
+
+/* Fill the lower triangle of the matrix with zeros. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ x[i__3].r = 0.f, x[i__3].i = 0.f;
+/* L40: */
+ }
+/* L50: */
+ }
+ n5 = *n / 5;
+ n5 *= 5;
+
+ i__1 = n5;
+ for (i__ = 1; i__ <= i__1; i__ += 5) {
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = alpha3 * q__2.r, q__1.i = alpha3 * q__2.i;
+ a.r = q__1.r, a.i = q__1.i;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = q__2.r / alpha, q__1.i = q__2.i / alpha;
+ b.r = q__1.r, b.i = q__1.i;
+ q__3.r = b.r * 2.f, q__3.i = b.i * 2.f;
+ q__2.r = q__3.r * 0.f - q__3.i * 1.f, q__2.i = q__3.r * 1.f +
+ q__3.i * 0.f;
+ q__1.r = a.r - q__2.r, q__1.i = a.i - q__2.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__1.r = c__.r / beta, q__1.i = c__.i / beta;
+ r__.r = q__1.r, r__.i = q__1.i;
+ i__2 = i__ + i__ * x_dim1;
+ x[i__2].r = a.r, x[i__2].i = a.i;
+ i__2 = i__ + 2 + i__ * x_dim1;
+ x[i__2].r = b.r, x[i__2].i = b.i;
+ i__2 = i__ + 2 + (i__ + 1) * x_dim1;
+ x[i__2].r = r__.r, x[i__2].i = r__.i;
+ i__2 = i__ + 2 + (i__ + 2) * x_dim1;
+ x[i__2].r = c__.r, x[i__2].i = c__.i;
+ i__2 = i__ + 1 + (i__ + 1) * x_dim1;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ i__2 = i__ + 3 + (i__ + 3) * x_dim1;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ i__2 = i__ + 4 + (i__ + 4) * x_dim1;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ if (c_abs(&x[i__ + 3 + (i__ + 3) * x_dim1]) > c_abs(&x[i__ + 4 + (
+ i__ + 4) * x_dim1])) {
+ i__2 = i__ + 4 + (i__ + 3) * x_dim1;
+ i__3 = i__ + 3 + (i__ + 3) * x_dim1;
+ q__1.r = x[i__3].r * 2.f, q__1.i = x[i__3].i * 2.f;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ } else {
+ i__2 = i__ + 4 + (i__ + 3) * x_dim1;
+ i__3 = i__ + 4 + (i__ + 4) * x_dim1;
+ q__1.r = x[i__3].r * 2.f, q__1.i = x[i__3].i * 2.f;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ }
+/* L60: */
+ }
+
+/* Clean-up for N not a multiple of 5. */
+
+ i__ = n5 + 1;
+ if (i__ < *n - 1) {
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = alpha3 * q__2.r, q__1.i = alpha3 * q__2.i;
+ a.r = q__1.r, a.i = q__1.i;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = q__2.r / alpha, q__1.i = q__2.i / alpha;
+ b.r = q__1.r, b.i = q__1.i;
+ q__3.r = b.r * 2.f, q__3.i = b.i * 2.f;
+ q__2.r = q__3.r * 0.f - q__3.i * 1.f, q__2.i = q__3.r * 1.f +
+ q__3.i * 0.f;
+ q__1.r = a.r - q__2.r, q__1.i = a.i - q__2.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__1.r = c__.r / beta, q__1.i = c__.i / beta;
+ r__.r = q__1.r, r__.i = q__1.i;
+ i__1 = i__ + i__ * x_dim1;
+ x[i__1].r = a.r, x[i__1].i = a.i;
+ i__1 = i__ + 2 + i__ * x_dim1;
+ x[i__1].r = b.r, x[i__1].i = b.i;
+ i__1 = i__ + 2 + (i__ + 1) * x_dim1;
+ x[i__1].r = r__.r, x[i__1].i = r__.i;
+ i__1 = i__ + 2 + (i__ + 2) * x_dim1;
+ x[i__1].r = c__.r, x[i__1].i = c__.i;
+ i__1 = i__ + 1 + (i__ + 1) * x_dim1;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ i__ += 3;
+ }
+ if (i__ < *n) {
+ i__1 = i__ + i__ * x_dim1;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ i__1 = i__ + 1 + (i__ + 1) * x_dim1;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ if (c_abs(&x[i__ + i__ * x_dim1]) > c_abs(&x[i__ + 1 + (i__ + 1) *
+ x_dim1])) {
+ i__1 = i__ + 1 + i__ * x_dim1;
+ i__2 = i__ + i__ * x_dim1;
+ q__1.r = x[i__2].r * 2.f, q__1.i = x[i__2].i * 2.f;
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ } else {
+ i__1 = i__ + 1 + i__ * x_dim1;
+ i__2 = i__ + 1 + (i__ + 1) * x_dim1;
+ q__1.r = x[i__2].r * 2.f, q__1.i = x[i__2].i * 2.f;
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ }
+ i__ += 2;
+ } else if (i__ == *n) {
+ i__1 = i__ + i__ * x_dim1;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ ++i__;
+ }
+ }
+
+ return 0;
+
+/* End of CLATSY */
+
+} /* clatsy_ */
diff --git a/TESTING/LIN/clattb.c b/TESTING/LIN/clattb.c
new file mode 100644
index 0000000..a1424ba
--- /dev/null
+++ b/TESTING/LIN/clattb.c
@@ -0,0 +1,998 @@
+/* clattb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__5 = 5;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static real c_b91 = 2.f;
+static integer c_n1 = -1;
+
+/* Subroutine */ int clattb_(integer *imat, char *uplo, char *trans, char *
+ diag, integer *iseed, integer *n, integer *kd, complex *ab, integer *
+ ldab, complex *b, complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1;
+ doublereal d__1, d__2;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ void c_div(complex *, complex *, complex *);
+ double pow_dd(doublereal *, doublereal *), c_abs(complex *);
+
+ /* Local variables */
+ integer i__, j, kl, ku, iy;
+ real ulp, sfac;
+ integer ioff, mode, lenj;
+ char path[3], dist[1];
+ real unfl, rexp;
+ char type__[1];
+ real texp;
+ complex star1, plus1, plus2;
+ real bscal;
+ extern logical lsame_(char *, char *);
+ real tscal, anorm, bnorm, tleft;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), cswap_(integer *, complex *, integer *,
+ complex *, integer *);
+ logical upper;
+ real tnorm;
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), slabad_(real *, real *);
+ extern integer icamax_(integer *, complex *, integer *);
+ extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *);
+ char packit[1];
+ real bignum;
+ extern doublereal slarnd_(integer *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int clarnv_(integer *, integer *, integer *,
+ complex *), clatms_(integer *, integer *, char *, integer *, char
+ *, real *, integer *, real *, real *, integer *, integer *, char *
+, complex *, integer *, complex *, integer *);
+ integer jcount;
+ extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
+ *);
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLATTB generates a triangular test matrix in 2-dimensional storage. */
+/* IMAT and UPLO uniquely specify the properties of the test matrix, */
+/* which is returned in the array A. */
+
+/* Arguments */
+/* ========= */
+
+/* IMAT (input) INTEGER */
+/* An integer key describing which matrix to generate for this */
+/* path. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A will be upper or lower */
+/* triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies whether the matrix or its transpose will be used. */
+/* = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose (= transpose) */
+
+/* DIAG (output) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* The seed vector for the random number generator (used in */
+/* CLATMS). Modified on exit. */
+
+/* N (input) INTEGER */
+/* The order of the matrix to be generated. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the banded */
+/* triangular matrix A. KD >= 0. */
+
+/* AB (output) COMPLEX array, dimension (LDAB,N) */
+/* The upper or lower triangular banded matrix A, stored in the */
+/* first KD+1 rows of AB. Let j be a column of A, 1<=j<=n. */
+/* If UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j. */
+/* If UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (workspace) COMPLEX array, dimension (N) */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iseed;
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --b;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "TB", (ftnlen)2, (ftnlen)2);
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ smlnum = unfl;
+ bignum = (1.f - ulp) / smlnum;
+ slabad_(&smlnum, &bignum);
+ if (*imat >= 6 && *imat <= 9 || *imat == 17) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ *info = 0;
+
+/* Quick return if N.LE.0. */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Call CLATB4 to set parameters for CLATMS. */
+
+ upper = lsame_(uplo, "U");
+ if (upper) {
+ clatb4_(path, imat, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ ku = *kd;
+/* Computing MAX */
+ i__1 = 0, i__2 = *kd - *n + 1;
+ ioff = max(i__1,i__2) + 1;
+ kl = 0;
+ *(unsigned char *)packit = 'Q';
+ } else {
+ i__1 = -(*imat);
+ clatb4_(path, &i__1, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ kl = *kd;
+ ioff = 1;
+ ku = 0;
+ *(unsigned char *)packit = 'B';
+ }
+
+/* IMAT <= 5: Non-unit triangular matrix */
+
+ if (*imat <= 5) {
+ clatms_(n, n, dist, &iseed[1], type__, &rwork[1], &mode, &cndnum, &
+ anorm, &kl, &ku, packit, &ab[ioff + ab_dim1], ldab, &work[1],
+ info);
+
+/* IMAT > 5: Unit triangular matrix */
+/* The diagonal is deliberately set to something other than 1. */
+
+/* IMAT = 6: Matrix is the identity */
+
+ } else if (*imat == 6) {
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = 1, i__3 = *kd + 2 - j;
+ i__4 = *kd;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ i__2 = i__ + j * ab_dim1;
+ ab[i__2].r = 0.f, ab[i__2].i = 0.f;
+/* L10: */
+ }
+ i__4 = *kd + 1 + j * ab_dim1;
+ ab[i__4].r = (real) j, ab[i__4].i = 0.f;
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = j * ab_dim1 + 1;
+ ab[i__4].r = (real) j, ab[i__4].i = 0.f;
+/* Computing MIN */
+ i__2 = *kd + 1, i__3 = *n - j + 1;
+ i__4 = min(i__2,i__3);
+ for (i__ = 2; i__ <= i__4; ++i__) {
+ i__2 = i__ + j * ab_dim1;
+ ab[i__2].r = 0.f, ab[i__2].i = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+/* IMAT > 6: Non-trivial unit triangular matrix */
+
+/* A unit triangular matrix T with condition CNDNUM is formed. */
+/* In this version, T only has bandwidth 2, the rest of it is zero. */
+
+ } else if (*imat <= 9) {
+ tnorm = sqrt(cndnum);
+
+/* Initialize AB to zero. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__2 = *kd + 2 - j;
+ i__3 = *kd;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ i__4 = i__ + j * ab_dim1;
+ ab[i__4].r = 0.f, ab[i__4].i = 0.f;
+/* L50: */
+ }
+ i__3 = *kd + 1 + j * ab_dim1;
+ r__1 = (real) j;
+ ab[i__3].r = r__1, ab[i__3].i = 0.f;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = *kd + 1, i__2 = *n - j + 1;
+ i__3 = min(i__4,i__2);
+ for (i__ = 2; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * ab_dim1;
+ ab[i__4].r = 0.f, ab[i__4].i = 0.f;
+/* L70: */
+ }
+ i__3 = j * ab_dim1 + 1;
+ r__1 = (real) j;
+ ab[i__3].r = r__1, ab[i__3].i = 0.f;
+/* L80: */
+ }
+ }
+
+/* Special case: T is tridiagonal. Set every other offdiagonal */
+/* so that the matrix has norm TNORM+1. */
+
+ if (*kd == 1) {
+ if (upper) {
+ i__1 = (ab_dim1 << 1) + 1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = tnorm * q__2.r, q__1.i = tnorm * q__2.i;
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+ lenj = (*n - 3) / 2;
+ clarnv_(&c__2, &iseed[1], &lenj, &work[1]);
+ i__1 = lenj;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = (j + 1 << 1) * ab_dim1 + 1;
+ i__4 = j;
+ q__1.r = tnorm * work[i__4].r, q__1.i = tnorm * work[i__4]
+ .i;
+ ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
+/* L90: */
+ }
+ } else {
+ i__1 = ab_dim1 + 2;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = tnorm * q__2.r, q__1.i = tnorm * q__2.i;
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+ lenj = (*n - 3) / 2;
+ clarnv_(&c__2, &iseed[1], &lenj, &work[1]);
+ i__1 = lenj;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = ((j << 1) + 1) * ab_dim1 + 2;
+ i__4 = j;
+ q__1.r = tnorm * work[i__4].r, q__1.i = tnorm * work[i__4]
+ .i;
+ ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
+/* L100: */
+ }
+ }
+ } else if (*kd > 1) {
+
+/* Form a unit triangular matrix T with condition CNDNUM. T is */
+/* given by */
+/* | 1 + * | */
+/* | 1 + | */
+/* T = | 1 + * | */
+/* | 1 + | */
+/* | 1 + * | */
+/* | 1 + | */
+/* | . . . | */
+/* Each element marked with a '*' is formed by taking the product */
+/* of the adjacent elements marked with '+'. The '*'s can be */
+/* chosen freely, and the '+'s are chosen so that the inverse of */
+/* T will have elements of the same magnitude as T. */
+
+/* The two offdiagonals of T are stored in WORK. */
+
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = tnorm * q__2.r, q__1.i = tnorm * q__2.i;
+ star1.r = q__1.r, star1.i = q__1.i;
+ sfac = sqrt(tnorm);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = sfac * q__2.r, q__1.i = sfac * q__2.i;
+ plus1.r = q__1.r, plus1.i = q__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; j += 2) {
+ c_div(&q__1, &star1, &plus1);
+ plus2.r = q__1.r, plus2.i = q__1.i;
+ i__3 = j;
+ work[i__3].r = plus1.r, work[i__3].i = plus1.i;
+ i__3 = *n + j;
+ work[i__3].r = star1.r, work[i__3].i = star1.i;
+ if (j + 1 <= *n) {
+ i__3 = j + 1;
+ work[i__3].r = plus2.r, work[i__3].i = plus2.i;
+ i__3 = *n + j + 1;
+ work[i__3].r = 0.f, work[i__3].i = 0.f;
+ c_div(&q__1, &star1, &plus2);
+ plus1.r = q__1.r, plus1.i = q__1.i;
+
+/* Generate a new *-value with norm between sqrt(TNORM) */
+/* and TNORM. */
+
+ rexp = slarnd_(&c__2, &iseed[1]);
+ if (rexp < 0.f) {
+ d__1 = (doublereal) sfac;
+ d__2 = (doublereal) (1.f - rexp);
+ r__1 = -pow_dd(&d__1, &d__2);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ star1.r = q__1.r, star1.i = q__1.i;
+ } else {
+ d__1 = (doublereal) sfac;
+ d__2 = (doublereal) (rexp + 1.f);
+ r__1 = pow_dd(&d__1, &d__2);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ star1.r = q__1.r, star1.i = q__1.i;
+ }
+ }
+/* L110: */
+ }
+
+/* Copy the tridiagonal T to AB. */
+
+ if (upper) {
+ i__1 = *n - 1;
+ ccopy_(&i__1, &work[1], &c__1, &ab[*kd + (ab_dim1 << 1)],
+ ldab);
+ i__1 = *n - 2;
+ ccopy_(&i__1, &work[*n + 1], &c__1, &ab[*kd - 1 + ab_dim1 * 3]
+, ldab);
+ } else {
+ i__1 = *n - 1;
+ ccopy_(&i__1, &work[1], &c__1, &ab[ab_dim1 + 2], ldab);
+ i__1 = *n - 2;
+ ccopy_(&i__1, &work[*n + 1], &c__1, &ab[ab_dim1 + 3], ldab);
+ }
+ }
+
+/* IMAT > 9: Pathological test cases. These triangular matrices */
+/* are badly scaled or badly conditioned, so when used in solving a */
+/* triangular system they may cause overflow in the solution vector. */
+
+ } else if (*imat == 10) {
+
+/* Type 10: Generate a triangular matrix with elements between */
+/* -1 and 1. Give the diagonal norm 2 to make it well-conditioned. */
+/* Make the right hand side large so that it requires scaling. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j - 1;
+ lenj = min(i__3,*kd);
+ clarnv_(&c__4, &iseed[1], &lenj, &ab[*kd + 1 - lenj + j *
+ ab_dim1]);
+ i__3 = *kd + 1 + j * ab_dim1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = q__2.r * 2.f, q__1.i = q__2.i * 2.f;
+ ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
+/* L120: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n - j;
+ lenj = min(i__3,*kd);
+ if (lenj > 0) {
+ clarnv_(&c__4, &iseed[1], &lenj, &ab[j * ab_dim1 + 2]);
+ }
+ i__3 = j * ab_dim1 + 1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = q__2.r * 2.f, q__1.i = q__2.i * 2.f;
+ ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
+/* L130: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ clarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = icamax_(n, &b[1], &c__1);
+ bnorm = c_abs(&b[iy]);
+ bscal = bignum / dmax(1.f,bnorm);
+ csscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 11) {
+
+/* Type 11: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 11, the offdiagonal elements are small (CNORM(j) < 1). */
+
+ clarnv_(&c__2, &iseed[1], n, &b[1]);
+ tscal = 1.f / (real) (*kd + 1);
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j - 1;
+ lenj = min(i__3,*kd);
+ if (lenj > 0) {
+ clarnv_(&c__4, &iseed[1], &lenj, &ab[*kd + 2 - lenj + j *
+ ab_dim1]);
+ csscal_(&lenj, &tscal, &ab[*kd + 2 - lenj + j * ab_dim1],
+ &c__1);
+ }
+ i__3 = *kd + 1 + j * ab_dim1;
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
+/* L140: */
+ }
+ i__1 = *kd + 1 + *n * ab_dim1;
+ i__3 = *kd + 1 + *n * ab_dim1;
+ q__1.r = smlnum * ab[i__3].r, q__1.i = smlnum * ab[i__3].i;
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n - j;
+ lenj = min(i__3,*kd);
+ if (lenj > 0) {
+ clarnv_(&c__4, &iseed[1], &lenj, &ab[j * ab_dim1 + 2]);
+ csscal_(&lenj, &tscal, &ab[j * ab_dim1 + 2], &c__1);
+ }
+ i__3 = j * ab_dim1 + 1;
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
+/* L150: */
+ }
+ i__1 = ab_dim1 + 1;
+ i__3 = ab_dim1 + 1;
+ q__1.r = smlnum * ab[i__3].r, q__1.i = smlnum * ab[i__3].i;
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+ }
+
+ } else if (*imat == 12) {
+
+/* Type 12: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 12, the offdiagonal elements are O(1) (CNORM(j) > 1). */
+
+ clarnv_(&c__2, &iseed[1], n, &b[1]);
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j - 1;
+ lenj = min(i__3,*kd);
+ if (lenj > 0) {
+ clarnv_(&c__4, &iseed[1], &lenj, &ab[*kd + 2 - lenj + j *
+ ab_dim1]);
+ }
+ i__3 = *kd + 1 + j * ab_dim1;
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
+/* L160: */
+ }
+ i__1 = *kd + 1 + *n * ab_dim1;
+ i__3 = *kd + 1 + *n * ab_dim1;
+ q__1.r = smlnum * ab[i__3].r, q__1.i = smlnum * ab[i__3].i;
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n - j;
+ lenj = min(i__3,*kd);
+ if (lenj > 0) {
+ clarnv_(&c__4, &iseed[1], &lenj, &ab[j * ab_dim1 + 2]);
+ }
+ i__3 = j * ab_dim1 + 1;
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
+/* L170: */
+ }
+ i__1 = ab_dim1 + 1;
+ i__3 = ab_dim1 + 1;
+ q__1.r = smlnum * ab[i__3].r, q__1.i = smlnum * ab[i__3].i;
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+ }
+
+ } else if (*imat == 13) {
+
+/* Type 13: T is diagonal with small numbers on the diagonal to */
+/* make the growth factor underflow, but a small right hand side */
+/* chosen so that the solution does not overflow. */
+
+ if (upper) {
+ jcount = 1;
+ for (j = *n; j >= 1; --j) {
+/* Computing MAX */
+ i__1 = 1, i__3 = *kd + 1 - (j - 1);
+ i__4 = *kd;
+ for (i__ = max(i__1,i__3); i__ <= i__4; ++i__) {
+ i__1 = i__ + j * ab_dim1;
+ ab[i__1].r = 0.f, ab[i__1].i = 0.f;
+/* L180: */
+ }
+ if (jcount <= 2) {
+ i__4 = *kd + 1 + j * ab_dim1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = smlnum * q__2.r, q__1.i = smlnum * q__2.i;
+ ab[i__4].r = q__1.r, ab[i__4].i = q__1.i;
+ } else {
+ i__4 = *kd + 1 + j * ab_dim1;
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ ab[i__4].r = q__1.r, ab[i__4].i = q__1.i;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+/* L190: */
+ }
+ } else {
+ jcount = 1;
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MIN */
+ i__3 = *n - j + 1, i__2 = *kd + 1;
+ i__1 = min(i__3,i__2);
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__3 = i__ + j * ab_dim1;
+ ab[i__3].r = 0.f, ab[i__3].i = 0.f;
+/* L200: */
+ }
+ if (jcount <= 2) {
+ i__1 = j * ab_dim1 + 1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = smlnum * q__2.r, q__1.i = smlnum * q__2.i;
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+ } else {
+ i__1 = j * ab_dim1 + 1;
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+/* L210: */
+ }
+ }
+
+/* Set the right hand side alternately zero and small. */
+
+ if (upper) {
+ b[1].r = 0.f, b[1].i = 0.f;
+ for (i__ = *n; i__ >= 2; i__ += -2) {
+ i__4 = i__;
+ b[i__4].r = 0.f, b[i__4].i = 0.f;
+ i__4 = i__ - 1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = smlnum * q__2.r, q__1.i = smlnum * q__2.i;
+ b[i__4].r = q__1.r, b[i__4].i = q__1.i;
+/* L220: */
+ }
+ } else {
+ i__4 = *n;
+ b[i__4].r = 0.f, b[i__4].i = 0.f;
+ i__4 = *n - 1;
+ for (i__ = 1; i__ <= i__4; i__ += 2) {
+ i__1 = i__;
+ b[i__1].r = 0.f, b[i__1].i = 0.f;
+ i__1 = i__ + 1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = smlnum * q__2.r, q__1.i = smlnum * q__2.i;
+ b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+/* L230: */
+ }
+ }
+
+ } else if (*imat == 14) {
+
+/* Type 14: Make the diagonal elements small to cause gradual */
+/* overflow when dividing by T(j,j). To control the amount of */
+/* scaling needed, the matrix is bidiagonal. */
+
+ texp = 1.f / (real) (*kd + 1);
+ d__1 = (doublereal) smlnum;
+ d__2 = (doublereal) texp;
+ tscal = pow_dd(&d__1, &d__2);
+ clarnv_(&c__4, &iseed[1], n, &b[1]);
+ if (upper) {
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MAX */
+ i__1 = 1, i__3 = *kd + 2 - j;
+ i__2 = *kd;
+ for (i__ = max(i__1,i__3); i__ <= i__2; ++i__) {
+ i__1 = i__ + j * ab_dim1;
+ ab[i__1].r = 0.f, ab[i__1].i = 0.f;
+/* L240: */
+ }
+ if (j > 1 && *kd > 0) {
+ i__2 = *kd + j * ab_dim1;
+ ab[i__2].r = -1.f, ab[i__2].i = -1.f;
+ }
+ i__2 = *kd + 1 + j * ab_dim1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
+ ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
+/* L250: */
+ }
+ i__4 = *n;
+ b[i__4].r = 1.f, b[i__4].i = 1.f;
+ } else {
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MIN */
+ i__1 = *n - j + 1, i__3 = *kd + 1;
+ i__2 = min(i__1,i__3);
+ for (i__ = 3; i__ <= i__2; ++i__) {
+ i__1 = i__ + j * ab_dim1;
+ ab[i__1].r = 0.f, ab[i__1].i = 0.f;
+/* L260: */
+ }
+ if (j < *n && *kd > 0) {
+ i__2 = j * ab_dim1 + 2;
+ ab[i__2].r = -1.f, ab[i__2].i = -1.f;
+ }
+ i__2 = j * ab_dim1 + 1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
+ ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
+/* L270: */
+ }
+ b[1].r = 1.f, b[1].i = 1.f;
+ }
+
+ } else if (*imat == 15) {
+
+/* Type 15: One zero diagonal element. */
+
+ iy = *n / 2 + 1;
+ if (upper) {
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MIN */
+ i__2 = j, i__1 = *kd + 1;
+ lenj = min(i__2,i__1);
+ clarnv_(&c__4, &iseed[1], &lenj, &ab[*kd + 2 - lenj + j *
+ ab_dim1]);
+ if (j != iy) {
+ i__2 = *kd + 1 + j * ab_dim1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = q__2.r * 2.f, q__1.i = q__2.i * 2.f;
+ ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
+ } else {
+ i__2 = *kd + 1 + j * ab_dim1;
+ ab[i__2].r = 0.f, ab[i__2].i = 0.f;
+ }
+/* L280: */
+ }
+ } else {
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MIN */
+ i__2 = *n - j + 1, i__1 = *kd + 1;
+ lenj = min(i__2,i__1);
+ clarnv_(&c__4, &iseed[1], &lenj, &ab[j * ab_dim1 + 1]);
+ if (j != iy) {
+ i__2 = j * ab_dim1 + 1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = q__2.r * 2.f, q__1.i = q__2.i * 2.f;
+ ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
+ } else {
+ i__2 = j * ab_dim1 + 1;
+ ab[i__2].r = 0.f, ab[i__2].i = 0.f;
+ }
+/* L290: */
+ }
+ }
+ clarnv_(&c__2, &iseed[1], n, &b[1]);
+ csscal_(n, &c_b91, &b[1], &c__1);
+
+ } else if (*imat == 16) {
+
+/* Type 16: Make the offdiagonal elements large to cause overflow */
+/* when adding a column of T. In the non-transposed case, the */
+/* matrix is constructed to cause overflow when adding a column in */
+/* every other step. */
+
+ tscal = unfl / ulp;
+ tscal = (1.f - ulp) / tscal;
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+ i__2 = *kd + 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__1 = i__ + j * ab_dim1;
+ ab[i__1].r = 0.f, ab[i__1].i = 0.f;
+/* L300: */
+ }
+/* L310: */
+ }
+ texp = 1.f;
+ if (*kd > 0) {
+ if (upper) {
+ i__4 = -(*kd);
+ for (j = *n; i__4 < 0 ? j >= 1 : j <= 1; j += i__4) {
+/* Computing MAX */
+ i__1 = 1, i__3 = j - *kd + 1;
+ i__2 = max(i__1,i__3);
+ for (i__ = j; i__ >= i__2; i__ += -2) {
+ i__1 = j - i__ + 1 + i__ * ab_dim1;
+ r__1 = -tscal / (real) (*kd + 2);
+ ab[i__1].r = r__1, ab[i__1].i = 0.f;
+ i__1 = *kd + 1 + i__ * ab_dim1;
+ ab[i__1].r = 1.f, ab[i__1].i = 0.f;
+ i__1 = i__;
+ r__1 = texp * (1.f - ulp);
+ b[i__1].r = r__1, b[i__1].i = 0.f;
+/* Computing MAX */
+ i__1 = 1, i__3 = j - *kd + 1;
+ if (i__ > max(i__1,i__3)) {
+ i__1 = j - i__ + 2 + (i__ - 1) * ab_dim1;
+ r__1 = -(tscal / (real) (*kd + 2)) / (real) (*kd
+ + 3);
+ ab[i__1].r = r__1, ab[i__1].i = 0.f;
+ i__1 = *kd + 1 + (i__ - 1) * ab_dim1;
+ ab[i__1].r = 1.f, ab[i__1].i = 0.f;
+ i__1 = i__ - 1;
+ r__1 = texp * (real) ((*kd + 1) * (*kd + 1) + *kd)
+ ;
+ b[i__1].r = r__1, b[i__1].i = 0.f;
+ }
+ texp *= 2.f;
+/* L320: */
+ }
+/* Computing MAX */
+ i__1 = 1, i__3 = j - *kd + 1;
+ i__2 = max(i__1,i__3);
+ r__1 = (real) (*kd + 2) / (real) (*kd + 3) * tscal;
+ b[i__2].r = r__1, b[i__2].i = 0.f;
+/* L330: */
+ }
+ } else {
+ i__4 = *n;
+ i__2 = *kd;
+ for (j = 1; i__2 < 0 ? j >= i__4 : j <= i__4; j += i__2) {
+ texp = 1.f;
+/* Computing MIN */
+ i__1 = *kd + 1, i__3 = *n - j + 1;
+ lenj = min(i__1,i__3);
+/* Computing MIN */
+ i__3 = *n, i__5 = j + *kd - 1;
+ i__1 = min(i__3,i__5);
+ for (i__ = j; i__ <= i__1; i__ += 2) {
+ i__3 = lenj - (i__ - j) + j * ab_dim1;
+ r__1 = -tscal / (real) (*kd + 2);
+ ab[i__3].r = r__1, ab[i__3].i = 0.f;
+ i__3 = j * ab_dim1 + 1;
+ ab[i__3].r = 1.f, ab[i__3].i = 0.f;
+ i__3 = j;
+ r__1 = texp * (1.f - ulp);
+ b[i__3].r = r__1, b[i__3].i = 0.f;
+/* Computing MIN */
+ i__3 = *n, i__5 = j + *kd - 1;
+ if (i__ < min(i__3,i__5)) {
+ i__3 = lenj - (i__ - j + 1) + (i__ + 1) * ab_dim1;
+ r__1 = -(tscal / (real) (*kd + 2)) / (real) (*kd
+ + 3);
+ ab[i__3].r = r__1, ab[i__3].i = 0.f;
+ i__3 = (i__ + 1) * ab_dim1 + 1;
+ ab[i__3].r = 1.f, ab[i__3].i = 0.f;
+ i__3 = i__ + 1;
+ r__1 = texp * (real) ((*kd + 1) * (*kd + 1) + *kd)
+ ;
+ b[i__3].r = r__1, b[i__3].i = 0.f;
+ }
+ texp *= 2.f;
+/* L340: */
+ }
+/* Computing MIN */
+ i__3 = *n, i__5 = j + *kd - 1;
+ i__1 = min(i__3,i__5);
+ r__1 = (real) (*kd + 2) / (real) (*kd + 3) * tscal;
+ b[i__1].r = r__1, b[i__1].i = 0.f;
+/* L350: */
+ }
+ }
+ }
+
+ } else if (*imat == 17) {
+
+/* Type 17: Generate a unit triangular matrix with elements */
+/* between -1 and 1, and make the right hand side large so that it */
+/* requires scaling. */
+
+ if (upper) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = j - 1;
+ lenj = min(i__4,*kd);
+ clarnv_(&c__4, &iseed[1], &lenj, &ab[*kd + 1 - lenj + j *
+ ab_dim1]);
+ i__4 = *kd + 1 + j * ab_dim1;
+ r__1 = (real) j;
+ ab[i__4].r = r__1, ab[i__4].i = 0.f;
+/* L360: */
+ }
+ } else {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = *n - j;
+ lenj = min(i__4,*kd);
+ if (lenj > 0) {
+ clarnv_(&c__4, &iseed[1], &lenj, &ab[j * ab_dim1 + 2]);
+ }
+ i__4 = j * ab_dim1 + 1;
+ r__1 = (real) j;
+ ab[i__4].r = r__1, ab[i__4].i = 0.f;
+/* L370: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ clarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = icamax_(n, &b[1], &c__1);
+ bnorm = c_abs(&b[iy]);
+ bscal = bignum / dmax(1.f,bnorm);
+ csscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 18) {
+
+/* Type 18: Generate a triangular matrix with elements between */
+/* BIGNUM/(KD+1) and BIGNUM so that at least one of the column */
+/* norms will exceed BIGNUM. */
+/* 1/3/91: CLATBS no longer can handle this case */
+
+ tleft = bignum / (real) (*kd + 1);
+ tscal = bignum * ((real) (*kd + 1) / (real) (*kd + 2));
+ if (upper) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = j, i__1 = *kd + 1;
+ lenj = min(i__4,i__1);
+ clarnv_(&c__5, &iseed[1], &lenj, &ab[*kd + 2 - lenj + j *
+ ab_dim1]);
+ slarnv_(&c__1, &iseed[1], &lenj, &rwork[*kd + 2 - lenj]);
+ i__4 = *kd + 1;
+ for (i__ = *kd + 2 - lenj; i__ <= i__4; ++i__) {
+ i__1 = i__ + j * ab_dim1;
+ i__3 = i__ + j * ab_dim1;
+ r__1 = tleft + rwork[i__] * tscal;
+ q__1.r = r__1 * ab[i__3].r, q__1.i = r__1 * ab[i__3].i;
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+/* L380: */
+ }
+/* L390: */
+ }
+ } else {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = *n - j + 1, i__1 = *kd + 1;
+ lenj = min(i__4,i__1);
+ clarnv_(&c__5, &iseed[1], &lenj, &ab[j * ab_dim1 + 1]);
+ slarnv_(&c__1, &iseed[1], &lenj, &rwork[1]);
+ i__4 = lenj;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__1 = i__ + j * ab_dim1;
+ i__3 = i__ + j * ab_dim1;
+ r__1 = tleft + rwork[i__] * tscal;
+ q__1.r = r__1 * ab[i__3].r, q__1.i = r__1 * ab[i__3].i;
+ ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
+/* L400: */
+ }
+/* L410: */
+ }
+ }
+ clarnv_(&c__2, &iseed[1], n, &b[1]);
+ csscal_(n, &c_b91, &b[1], &c__1);
+ }
+
+/* Flip the matrix if the transpose will be used. */
+
+ if (! lsame_(trans, "N")) {
+ if (upper) {
+ i__2 = *n / 2;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = *n - (j << 1) + 1, i__1 = *kd + 1;
+ lenj = min(i__4,i__1);
+ i__4 = *ldab - 1;
+ cswap_(&lenj, &ab[*kd + 1 + j * ab_dim1], &i__4, &ab[*kd + 2
+ - lenj + (*n - j + 1) * ab_dim1], &c_n1);
+/* L420: */
+ }
+ } else {
+ i__2 = *n / 2;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = *n - (j << 1) + 1, i__1 = *kd + 1;
+ lenj = min(i__4,i__1);
+ i__4 = -(*ldab) + 1;
+ cswap_(&lenj, &ab[j * ab_dim1 + 1], &c__1, &ab[lenj + (*n - j
+ + 2 - lenj) * ab_dim1], &i__4);
+/* L430: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CLATTB */
+
+} /* clattb_ */
diff --git a/TESTING/LIN/clattp.c b/TESTING/LIN/clattp.c
new file mode 100644
index 0000000..e70521f
--- /dev/null
+++ b/TESTING/LIN/clattp.c
@@ -0,0 +1,1146 @@
+/* clattp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__5 = 5;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static real c_b93 = 2.f;
+
+/* Subroutine */ int clattp_(integer *imat, char *uplo, char *trans, char *
+ diag, integer *iseed, integer *n, complex *ap, complex *b, complex *
+ work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2;
+ doublereal d__1, d__2;
+ complex q__1, q__2, q__3, q__4, q__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ void c_div(complex *, complex *, complex *);
+ double pow_dd(doublereal *, doublereal *), sqrt(doublereal);
+ void r_cnjg(complex *, complex *);
+ double c_abs(complex *);
+
+ /* Local variables */
+ real c__;
+ integer i__, j;
+ complex s;
+ real t, x, y, z__;
+ integer jc;
+ complex ra;
+ integer jj;
+ complex rb;
+ integer jl, kl, jr, ku, iy, jx;
+ real ulp, sfac;
+ integer mode;
+ char path[3], dist[1];
+ real unfl;
+ extern /* Subroutine */ int crot_(integer *, complex *, integer *,
+ complex *, integer *, real *, complex *);
+ real rexp;
+ char type__[1];
+ real texp;
+ complex star1, plus1, plus2;
+ real bscal;
+ extern logical lsame_(char *, char *);
+ real tscal;
+ complex ctemp;
+ real anorm, bnorm, tleft;
+ extern /* Subroutine */ int crotg_(complex *, complex *, real *, complex *
+);
+ logical upper;
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), slabad_(real *, real *);
+ extern integer icamax_(integer *, complex *, integer *);
+ extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *);
+ char packit[1];
+ real bignum;
+ extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, complex *, integer *, complex *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int clarnv_(integer *, integer *, integer *,
+ complex *);
+ integer jcnext, jcount;
+ extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
+ *);
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLATTP generates a triangular test matrix in packed storage. */
+/* IMAT and UPLO uniquely specify the properties of the test matrix, */
+/* which is returned in the array AP. */
+
+/* Arguments */
+/* ========= */
+
+/* IMAT (input) INTEGER */
+/* An integer key describing which matrix to generate for this */
+/* path. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A will be upper or lower */
+/* triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies whether the matrix or its transpose will be used. */
+/* = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose */
+
+/* DIAG (output) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* The seed vector for the random number generator (used in */
+/* CLATMS). Modified on exit. */
+
+/* N (input) INTEGER */
+/* The order of the matrix to be generated. */
+
+/* AP (output) COMPLEX array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
+
+/* B (output) COMPLEX array, dimension (N) */
+/* The right hand side vector, if IMAT > 10. */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --b;
+ --ap;
+ --iseed;
+
+ /* Function Body */
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "TP", (ftnlen)2, (ftnlen)2);
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ smlnum = unfl;
+ bignum = (1.f - ulp) / smlnum;
+ slabad_(&smlnum, &bignum);
+ if (*imat >= 7 && *imat <= 10 || *imat == 18) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ *info = 0;
+
+/* Quick return if N.LE.0. */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Call CLATB4 to set parameters for CLATMS. */
+
+ upper = lsame_(uplo, "U");
+ if (upper) {
+ clatb4_(path, imat, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ *(unsigned char *)packit = 'C';
+ } else {
+ i__1 = -(*imat);
+ clatb4_(path, &i__1, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ *(unsigned char *)packit = 'R';
+ }
+
+/* IMAT <= 6: Non-unit triangular matrix */
+
+ if (*imat <= 6) {
+ clatms_(n, n, dist, &iseed[1], type__, &rwork[1], &mode, &cndnum, &
+ anorm, &kl, &ku, packit, &ap[1], n, &work[1], info);
+
+/* IMAT > 6: Unit triangular matrix */
+/* The diagonal is deliberately set to something other than 1. */
+
+/* IMAT = 7: Matrix is the identity */
+
+ } else if (*imat == 7) {
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - 1;
+ ap[i__3].r = 0.f, ap[i__3].i = 0.f;
+/* L10: */
+ }
+ i__2 = jc + j - 1;
+ ap[i__2].r = (real) j, ap[i__2].i = 0.f;
+ jc += j;
+/* L20: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jc;
+ ap[i__2].r = (real) j, ap[i__2].i = 0.f;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - j;
+ ap[i__3].r = 0.f, ap[i__3].i = 0.f;
+/* L30: */
+ }
+ jc = jc + *n - j + 1;
+/* L40: */
+ }
+ }
+
+/* IMAT > 7: Non-trivial unit triangular matrix */
+
+/* Generate a unit triangular matrix T with condition CNDNUM by */
+/* forming a triangular matrix with known singular values and */
+/* filling in the zero entries with Givens rotations. */
+
+ } else if (*imat <= 10) {
+ if (upper) {
+ jc = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = jc + i__;
+ ap[i__3].r = 0.f, ap[i__3].i = 0.f;
+/* L50: */
+ }
+ i__2 = jc + j;
+ ap[i__2].r = (real) j, ap[i__2].i = 0.f;
+ jc += j;
+/* L60: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jc;
+ ap[i__2].r = (real) j, ap[i__2].i = 0.f;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - j;
+ ap[i__3].r = 0.f, ap[i__3].i = 0.f;
+/* L70: */
+ }
+ jc = jc + *n - j + 1;
+/* L80: */
+ }
+ }
+
+/* Since the trace of a unit triangular matrix is 1, the product */
+/* of its singular values must be 1. Let s = sqrt(CNDNUM), */
+/* x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2. */
+/* The following triangular matrix has singular values s, 1, 1, */
+/* ..., 1, 1/s: */
+
+/* 1 y y y ... y y z */
+/* 1 0 0 ... 0 0 y */
+/* 1 0 ... 0 0 y */
+/* . ... . . . */
+/* . . . . */
+/* 1 0 y */
+/* 1 y */
+/* 1 */
+
+/* To fill in the zeros, we first multiply by a matrix with small */
+/* condition number of the form */
+
+/* 1 0 0 0 0 ... */
+/* 1 + * 0 0 ... */
+/* 1 + 0 0 0 */
+/* 1 + * 0 0 */
+/* 1 + 0 0 */
+/* ... */
+/* 1 + 0 */
+/* 1 0 */
+/* 1 */
+
+/* Each element marked with a '*' is formed by taking the product */
+/* of the adjacent elements marked with '+'. The '*'s can be */
+/* chosen freely, and the '+'s are chosen so that the inverse of */
+/* T will have elements of the same magnitude as T. If the *'s in */
+/* both T and inv(T) have small magnitude, T is well conditioned. */
+/* The two offdiagonals of T are stored in WORK. */
+
+/* The product of these two matrices has the form */
+
+/* 1 y y y y y . y y z */
+/* 1 + * 0 0 . 0 0 y */
+/* 1 + 0 0 . 0 0 y */
+/* 1 + * . . . . */
+/* 1 + . . . . */
+/* . . . . . */
+/* . . . . */
+/* 1 + y */
+/* 1 y */
+/* 1 */
+
+/* Now we multiply by Givens rotations, using the fact that */
+
+/* [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ] */
+/* [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ] */
+/* and */
+/* [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ] */
+/* [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ] */
+
+/* where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4). */
+
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = q__2.r * .25f, q__1.i = q__2.i * .25f;
+ star1.r = q__1.r, star1.i = q__1.i;
+ sfac = .5f;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = sfac * q__2.r, q__1.i = sfac * q__2.i;
+ plus1.r = q__1.r, plus1.i = q__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; j += 2) {
+ c_div(&q__1, &star1, &plus1);
+ plus2.r = q__1.r, plus2.i = q__1.i;
+ i__2 = j;
+ work[i__2].r = plus1.r, work[i__2].i = plus1.i;
+ i__2 = *n + j;
+ work[i__2].r = star1.r, work[i__2].i = star1.i;
+ if (j + 1 <= *n) {
+ i__2 = j + 1;
+ work[i__2].r = plus2.r, work[i__2].i = plus2.i;
+ i__2 = *n + j + 1;
+ work[i__2].r = 0.f, work[i__2].i = 0.f;
+ c_div(&q__1, &star1, &plus2);
+ plus1.r = q__1.r, plus1.i = q__1.i;
+ clarnd_(&q__1, &c__2, &iseed[1]);
+ rexp = q__1.r;
+ if (rexp < 0.f) {
+ d__1 = (doublereal) sfac;
+ d__2 = (doublereal) (1.f - rexp);
+ r__1 = -pow_dd(&d__1, &d__2);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ star1.r = q__1.r, star1.i = q__1.i;
+ } else {
+ d__1 = (doublereal) sfac;
+ d__2 = (doublereal) (rexp + 1.f);
+ r__1 = pow_dd(&d__1, &d__2);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ star1.r = q__1.r, star1.i = q__1.i;
+ }
+ }
+/* L90: */
+ }
+
+ x = sqrt(cndnum) - 1.f / sqrt(cndnum);
+ if (*n > 2) {
+ y = sqrt(2.f / (real) (*n - 2)) * x;
+ } else {
+ y = 0.f;
+ }
+ z__ = x * x;
+
+ if (upper) {
+
+/* Set the upper triangle of A with a unit triangular matrix */
+/* of known condition number. */
+
+ jc = 1;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = jc + 1;
+ ap[i__2].r = y, ap[i__2].i = 0.f;
+ if (j > 2) {
+ i__2 = jc + j - 1;
+ i__3 = j - 2;
+ ap[i__2].r = work[i__3].r, ap[i__2].i = work[i__3].i;
+ }
+ if (j > 3) {
+ i__2 = jc + j - 2;
+ i__3 = *n + j - 3;
+ ap[i__2].r = work[i__3].r, ap[i__2].i = work[i__3].i;
+ }
+ jc += j;
+/* L100: */
+ }
+ jc -= *n;
+ i__1 = jc + 1;
+ ap[i__1].r = z__, ap[i__1].i = 0.f;
+ i__1 = *n - 1;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = jc + j;
+ ap[i__2].r = y, ap[i__2].i = 0.f;
+/* L110: */
+ }
+ } else {
+
+/* Set the lower triangle of A with a unit triangular matrix */
+/* of known condition number. */
+
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ ap[i__2].r = y, ap[i__2].i = 0.f;
+/* L120: */
+ }
+ i__1 = *n;
+ ap[i__1].r = z__, ap[i__1].i = 0.f;
+ jc = *n + 1;
+ i__1 = *n - 1;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = jc + 1;
+ i__3 = j - 1;
+ ap[i__2].r = work[i__3].r, ap[i__2].i = work[i__3].i;
+ if (j < *n - 1) {
+ i__2 = jc + 2;
+ i__3 = *n + j - 1;
+ ap[i__2].r = work[i__3].r, ap[i__2].i = work[i__3].i;
+ }
+ i__2 = jc + *n - j;
+ ap[i__2].r = y, ap[i__2].i = 0.f;
+ jc = jc + *n - j + 1;
+/* L130: */
+ }
+ }
+
+/* Fill in the zeros using Givens rotations */
+
+ if (upper) {
+ jc = 1;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ jcnext = jc + j;
+ i__2 = jcnext + j - 1;
+ ra.r = ap[i__2].r, ra.i = ap[i__2].i;
+ rb.r = 2.f, rb.i = 0.f;
+ crotg_(&ra, &rb, &c__, &s);
+
+/* Multiply by [ c s; -conjg(s) c] on the left. */
+
+ if (*n > j + 1) {
+ jx = jcnext + j;
+ i__2 = *n;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+ i__3 = jx + j;
+ q__2.r = c__ * ap[i__3].r, q__2.i = c__ * ap[i__3].i;
+ i__4 = jx + j + 1;
+ q__3.r = s.r * ap[i__4].r - s.i * ap[i__4].i, q__3.i =
+ s.r * ap[i__4].i + s.i * ap[i__4].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__3 = jx + j + 1;
+ r_cnjg(&q__4, &s);
+ q__3.r = -q__4.r, q__3.i = -q__4.i;
+ i__4 = jx + j;
+ q__2.r = q__3.r * ap[i__4].r - q__3.i * ap[i__4].i,
+ q__2.i = q__3.r * ap[i__4].i + q__3.i * ap[
+ i__4].r;
+ i__5 = jx + j + 1;
+ q__5.r = c__ * ap[i__5].r, q__5.i = c__ * ap[i__5].i;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+ i__3 = jx + j;
+ ap[i__3].r = ctemp.r, ap[i__3].i = ctemp.i;
+ jx += i__;
+/* L140: */
+ }
+ }
+
+/* Multiply by [-c -s; conjg(s) -c] on the right. */
+
+ if (j > 1) {
+ i__2 = j - 1;
+ r__1 = -c__;
+ q__1.r = -s.r, q__1.i = -s.i;
+ crot_(&i__2, &ap[jcnext], &c__1, &ap[jc], &c__1, &r__1, &
+ q__1);
+ }
+
+/* Negate A(J,J+1). */
+
+ i__2 = jcnext + j - 1;
+ i__3 = jcnext + j - 1;
+ q__1.r = -ap[i__3].r, q__1.i = -ap[i__3].i;
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ jc = jcnext;
+/* L150: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ jcnext = jc + *n - j + 1;
+ i__2 = jc + 1;
+ ra.r = ap[i__2].r, ra.i = ap[i__2].i;
+ rb.r = 2.f, rb.i = 0.f;
+ crotg_(&ra, &rb, &c__, &s);
+ r_cnjg(&q__1, &s);
+ s.r = q__1.r, s.i = q__1.i;
+
+/* Multiply by [ c -s; conjg(s) c] on the right. */
+
+ if (*n > j + 1) {
+ i__2 = *n - j - 1;
+ q__1.r = -s.r, q__1.i = -s.i;
+ crot_(&i__2, &ap[jcnext + 1], &c__1, &ap[jc + 2], &c__1, &
+ c__, &q__1);
+ }
+
+/* Multiply by [-c s; -conjg(s) -c] on the left. */
+
+ if (j > 1) {
+ jx = 1;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ r__1 = -c__;
+ i__3 = jx + j - i__;
+ q__2.r = r__1 * ap[i__3].r, q__2.i = r__1 * ap[i__3]
+ .i;
+ i__4 = jx + j - i__ + 1;
+ q__3.r = s.r * ap[i__4].r - s.i * ap[i__4].i, q__3.i =
+ s.r * ap[i__4].i + s.i * ap[i__4].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__3 = jx + j - i__ + 1;
+ r_cnjg(&q__4, &s);
+ q__3.r = -q__4.r, q__3.i = -q__4.i;
+ i__4 = jx + j - i__;
+ q__2.r = q__3.r * ap[i__4].r - q__3.i * ap[i__4].i,
+ q__2.i = q__3.r * ap[i__4].i + q__3.i * ap[
+ i__4].r;
+ i__5 = jx + j - i__ + 1;
+ q__5.r = c__ * ap[i__5].r, q__5.i = c__ * ap[i__5].i;
+ q__1.r = q__2.r - q__5.r, q__1.i = q__2.i - q__5.i;
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+ i__3 = jx + j - i__;
+ ap[i__3].r = ctemp.r, ap[i__3].i = ctemp.i;
+ jx = jx + *n - i__ + 1;
+/* L160: */
+ }
+ }
+
+/* Negate A(J+1,J). */
+
+ i__2 = jc + 1;
+ i__3 = jc + 1;
+ q__1.r = -ap[i__3].r, q__1.i = -ap[i__3].i;
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ jc = jcnext;
+/* L170: */
+ }
+ }
+
+/* IMAT > 10: Pathological test cases. These triangular matrices */
+/* are badly scaled or badly conditioned, so when used in solving a */
+/* triangular system they may cause overflow in the solution vector. */
+
+ } else if (*imat == 11) {
+
+/* Type 11: Generate a triangular matrix with elements between */
+/* -1 and 1. Give the diagonal norm 2 to make it well-conditioned. */
+/* Make the right hand side large so that it requires scaling. */
+
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ clarnv_(&c__4, &iseed[1], &i__2, &ap[jc]);
+ i__2 = jc + j - 1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = q__2.r * 2.f, q__1.i = q__2.i * 2.f;
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ jc += j;
+/* L180: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (j < *n) {
+ i__2 = *n - j;
+ clarnv_(&c__4, &iseed[1], &i__2, &ap[jc + 1]);
+ }
+ i__2 = jc;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = q__2.r * 2.f, q__1.i = q__2.i * 2.f;
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ jc = jc + *n - j + 1;
+/* L190: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ clarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = icamax_(n, &b[1], &c__1);
+ bnorm = c_abs(&b[iy]);
+ bscal = bignum / dmax(1.f,bnorm);
+ csscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 12) {
+
+/* Type 12: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 12, the offdiagonal elements are small (CNORM(j) < 1). */
+
+ clarnv_(&c__2, &iseed[1], n, &b[1]);
+/* Computing MAX */
+ r__1 = 1.f, r__2 = (real) (*n - 1);
+ tscal = 1.f / dmax(r__1,r__2);
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ clarnv_(&c__4, &iseed[1], &i__2, &ap[jc]);
+ i__2 = j - 1;
+ csscal_(&i__2, &tscal, &ap[jc], &c__1);
+ i__2 = jc + j - 1;
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ jc += j;
+/* L200: */
+ }
+ i__1 = *n * (*n + 1) / 2;
+ i__2 = *n * (*n + 1) / 2;
+ q__1.r = smlnum * ap[i__2].r, q__1.i = smlnum * ap[i__2].i;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ clarnv_(&c__2, &iseed[1], &i__2, &ap[jc + 1]);
+ i__2 = *n - j;
+ csscal_(&i__2, &tscal, &ap[jc + 1], &c__1);
+ i__2 = jc;
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ jc = jc + *n - j + 1;
+/* L210: */
+ }
+ q__1.r = smlnum * ap[1].r, q__1.i = smlnum * ap[1].i;
+ ap[1].r = q__1.r, ap[1].i = q__1.i;
+ }
+
+ } else if (*imat == 13) {
+
+/* Type 13: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1). */
+
+ clarnv_(&c__2, &iseed[1], n, &b[1]);
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ clarnv_(&c__4, &iseed[1], &i__2, &ap[jc]);
+ i__2 = jc + j - 1;
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ jc += j;
+/* L220: */
+ }
+ i__1 = *n * (*n + 1) / 2;
+ i__2 = *n * (*n + 1) / 2;
+ q__1.r = smlnum * ap[i__2].r, q__1.i = smlnum * ap[i__2].i;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ clarnv_(&c__4, &iseed[1], &i__2, &ap[jc + 1]);
+ i__2 = jc;
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ jc = jc + *n - j + 1;
+/* L230: */
+ }
+ q__1.r = smlnum * ap[1].r, q__1.i = smlnum * ap[1].i;
+ ap[1].r = q__1.r, ap[1].i = q__1.i;
+ }
+
+ } else if (*imat == 14) {
+
+/* Type 14: T is diagonal with small numbers on the diagonal to */
+/* make the growth factor underflow, but a small right hand side */
+/* chosen so that the solution does not overflow. */
+
+ if (upper) {
+ jcount = 1;
+ jc = (*n - 1) * *n / 2 + 1;
+ for (j = *n; j >= 1; --j) {
+ i__1 = j - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = jc + i__ - 1;
+ ap[i__2].r = 0.f, ap[i__2].i = 0.f;
+/* L240: */
+ }
+ if (jcount <= 2) {
+ i__1 = jc + j - 1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = smlnum * q__2.r, q__1.i = smlnum * q__2.i;
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ } else {
+ i__1 = jc + j - 1;
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+ jc = jc - j + 1;
+/* L250: */
+ }
+ } else {
+ jcount = 1;
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - j;
+ ap[i__3].r = 0.f, ap[i__3].i = 0.f;
+/* L260: */
+ }
+ if (jcount <= 2) {
+ i__2 = jc;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = smlnum * q__2.r, q__1.i = smlnum * q__2.i;
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ } else {
+ i__2 = jc;
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+ jc = jc + *n - j + 1;
+/* L270: */
+ }
+ }
+
+/* Set the right hand side alternately zero and small. */
+
+ if (upper) {
+ b[1].r = 0.f, b[1].i = 0.f;
+ for (i__ = *n; i__ >= 2; i__ += -2) {
+ i__1 = i__;
+ b[i__1].r = 0.f, b[i__1].i = 0.f;
+ i__1 = i__ - 1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = smlnum * q__2.r, q__1.i = smlnum * q__2.i;
+ b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+/* L280: */
+ }
+ } else {
+ i__1 = *n;
+ b[i__1].r = 0.f, b[i__1].i = 0.f;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; i__ += 2) {
+ i__2 = i__;
+ b[i__2].r = 0.f, b[i__2].i = 0.f;
+ i__2 = i__ + 1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = smlnum * q__2.r, q__1.i = smlnum * q__2.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L290: */
+ }
+ }
+
+ } else if (*imat == 15) {
+
+/* Type 15: Make the diagonal elements small to cause gradual */
+/* overflow when dividing by T(j,j). To control the amount of */
+/* scaling needed, the matrix is bidiagonal. */
+
+/* Computing MAX */
+ r__1 = 1.f, r__2 = (real) (*n - 1);
+ texp = 1.f / dmax(r__1,r__2);
+ d__1 = (doublereal) smlnum;
+ d__2 = (doublereal) texp;
+ tscal = pow_dd(&d__1, &d__2);
+ clarnv_(&c__4, &iseed[1], n, &b[1]);
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 2;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - 1;
+ ap[i__3].r = 0.f, ap[i__3].i = 0.f;
+/* L300: */
+ }
+ if (j > 1) {
+ i__2 = jc + j - 2;
+ ap[i__2].r = -1.f, ap[i__2].i = -1.f;
+ }
+ i__2 = jc + j - 1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ jc += j;
+/* L310: */
+ }
+ i__1 = *n;
+ b[i__1].r = 1.f, b[i__1].i = 1.f;
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - j;
+ ap[i__3].r = 0.f, ap[i__3].i = 0.f;
+/* L320: */
+ }
+ if (j < *n) {
+ i__2 = jc + 1;
+ ap[i__2].r = -1.f, ap[i__2].i = -1.f;
+ }
+ i__2 = jc;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ jc = jc + *n - j + 1;
+/* L330: */
+ }
+ b[1].r = 1.f, b[1].i = 1.f;
+ }
+
+ } else if (*imat == 16) {
+
+/* Type 16: One zero diagonal element. */
+
+ iy = *n / 2 + 1;
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ clarnv_(&c__4, &iseed[1], &j, &ap[jc]);
+ if (j != iy) {
+ i__2 = jc + j - 1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = q__2.r * 2.f, q__1.i = q__2.i * 2.f;
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ } else {
+ i__2 = jc + j - 1;
+ ap[i__2].r = 0.f, ap[i__2].i = 0.f;
+ }
+ jc += j;
+/* L340: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ clarnv_(&c__4, &iseed[1], &i__2, &ap[jc]);
+ if (j != iy) {
+ i__2 = jc;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = q__2.r * 2.f, q__1.i = q__2.i * 2.f;
+ ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
+ } else {
+ i__2 = jc;
+ ap[i__2].r = 0.f, ap[i__2].i = 0.f;
+ }
+ jc = jc + *n - j + 1;
+/* L350: */
+ }
+ }
+ clarnv_(&c__2, &iseed[1], n, &b[1]);
+ csscal_(n, &c_b93, &b[1], &c__1);
+
+ } else if (*imat == 17) {
+
+/* Type 17: Make the offdiagonal elements large to cause overflow */
+/* when adding a column of T. In the non-transposed case, the */
+/* matrix is constructed to cause overflow when adding a column in */
+/* every other step. */
+
+ tscal = unfl / ulp;
+ tscal = (1.f - ulp) / tscal;
+ i__1 = *n * (*n + 1) / 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ ap[i__2].r = 0.f, ap[i__2].i = 0.f;
+/* L360: */
+ }
+ texp = 1.f;
+ if (upper) {
+ jc = (*n - 1) * *n / 2 + 1;
+ for (j = *n; j >= 2; j += -2) {
+ i__1 = jc;
+ r__1 = -tscal / (real) (*n + 1);
+ ap[i__1].r = r__1, ap[i__1].i = 0.f;
+ i__1 = jc + j - 1;
+ ap[i__1].r = 1.f, ap[i__1].i = 0.f;
+ i__1 = j;
+ r__1 = texp * (1.f - ulp);
+ b[i__1].r = r__1, b[i__1].i = 0.f;
+ jc = jc - j + 1;
+ i__1 = jc;
+ r__1 = -(tscal / (real) (*n + 1)) / (real) (*n + 2);
+ ap[i__1].r = r__1, ap[i__1].i = 0.f;
+ i__1 = jc + j - 2;
+ ap[i__1].r = 1.f, ap[i__1].i = 0.f;
+ i__1 = j - 1;
+ r__1 = texp * (real) (*n * *n + *n - 1);
+ b[i__1].r = r__1, b[i__1].i = 0.f;
+ texp *= 2.f;
+ jc = jc - j + 2;
+/* L370: */
+ }
+ r__1 = (real) (*n + 1) / (real) (*n + 2) * tscal;
+ b[1].r = r__1, b[1].i = 0.f;
+ } else {
+ jc = 1;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; j += 2) {
+ i__2 = jc + *n - j;
+ r__1 = -tscal / (real) (*n + 1);
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+ i__2 = jc;
+ ap[i__2].r = 1.f, ap[i__2].i = 0.f;
+ i__2 = j;
+ r__1 = texp * (1.f - ulp);
+ b[i__2].r = r__1, b[i__2].i = 0.f;
+ jc = jc + *n - j + 1;
+ i__2 = jc + *n - j - 1;
+ r__1 = -(tscal / (real) (*n + 1)) / (real) (*n + 2);
+ ap[i__2].r = r__1, ap[i__2].i = 0.f;
+ i__2 = jc;
+ ap[i__2].r = 1.f, ap[i__2].i = 0.f;
+ i__2 = j + 1;
+ r__1 = texp * (real) (*n * *n + *n - 1);
+ b[i__2].r = r__1, b[i__2].i = 0.f;
+ texp *= 2.f;
+ jc = jc + *n - j;
+/* L380: */
+ }
+ i__1 = *n;
+ r__1 = (real) (*n + 1) / (real) (*n + 2) * tscal;
+ b[i__1].r = r__1, b[i__1].i = 0.f;
+ }
+
+ } else if (*imat == 18) {
+
+/* Type 18: Generate a unit triangular matrix with elements */
+/* between -1 and 1, and make the right hand side large so that it */
+/* requires scaling. */
+
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ clarnv_(&c__4, &iseed[1], &i__2, &ap[jc]);
+ i__2 = jc + j - 1;
+ ap[i__2].r = 0.f, ap[i__2].i = 0.f;
+ jc += j;
+/* L390: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (j < *n) {
+ i__2 = *n - j;
+ clarnv_(&c__4, &iseed[1], &i__2, &ap[jc + 1]);
+ }
+ i__2 = jc;
+ ap[i__2].r = 0.f, ap[i__2].i = 0.f;
+ jc = jc + *n - j + 1;
+/* L400: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ clarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = icamax_(n, &b[1], &c__1);
+ bnorm = c_abs(&b[iy]);
+ bscal = bignum / dmax(1.f,bnorm);
+ csscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 19) {
+
+/* Type 19: Generate a triangular matrix with elements between */
+/* BIGNUM/(n-1) and BIGNUM so that at least one of the column */
+/* norms will exceed BIGNUM. */
+/* 1/3/91: CLATPS no longer can handle this case */
+
+/* Computing MAX */
+ r__1 = 1.f, r__2 = (real) (*n - 1);
+ tleft = bignum / dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = 1.f, r__2 = (real) (*n);
+ tscal = bignum * ((real) (*n - 1) / dmax(r__1,r__2));
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ clarnv_(&c__5, &iseed[1], &j, &ap[jc]);
+ slarnv_(&c__1, &iseed[1], &j, &rwork[1]);
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - 1;
+ i__4 = jc + i__ - 1;
+ r__1 = tleft + rwork[i__] * tscal;
+ q__1.r = r__1 * ap[i__4].r, q__1.i = r__1 * ap[i__4].i;
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+/* L410: */
+ }
+ jc += j;
+/* L420: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ clarnv_(&c__5, &iseed[1], &i__2, &ap[jc]);
+ i__2 = *n - j + 1;
+ slarnv_(&c__1, &iseed[1], &i__2, &rwork[1]);
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - j;
+ i__4 = jc + i__ - j;
+ r__1 = tleft + rwork[i__ - j + 1] * tscal;
+ q__1.r = r__1 * ap[i__4].r, q__1.i = r__1 * ap[i__4].i;
+ ap[i__3].r = q__1.r, ap[i__3].i = q__1.i;
+/* L430: */
+ }
+ jc = jc + *n - j + 1;
+/* L440: */
+ }
+ }
+ clarnv_(&c__2, &iseed[1], n, &b[1]);
+ csscal_(n, &c_b93, &b[1], &c__1);
+ }
+
+/* Flip the matrix across its counter-diagonal if the transpose will */
+/* be used. */
+
+ if (! lsame_(trans, "N")) {
+ if (upper) {
+ jj = 1;
+ jr = *n * (*n + 1) / 2;
+ i__1 = *n / 2;
+ for (j = 1; j <= i__1; ++j) {
+ jl = jj;
+ i__2 = *n - j;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = jr - i__ + j;
+ t = ap[i__3].r;
+ i__3 = jr - i__ + j;
+ i__4 = jl;
+ ap[i__3].r = ap[i__4].r, ap[i__3].i = ap[i__4].i;
+ i__3 = jl;
+ ap[i__3].r = t, ap[i__3].i = 0.f;
+ jl += i__;
+/* L450: */
+ }
+ jj = jj + j + 1;
+ jr -= *n - j + 1;
+/* L460: */
+ }
+ } else {
+ jl = 1;
+ jj = *n * (*n + 1) / 2;
+ i__1 = *n / 2;
+ for (j = 1; j <= i__1; ++j) {
+ jr = jj;
+ i__2 = *n - j;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = jl + i__ - j;
+ t = ap[i__3].r;
+ i__3 = jl + i__ - j;
+ i__4 = jr;
+ ap[i__3].r = ap[i__4].r, ap[i__3].i = ap[i__4].i;
+ i__3 = jr;
+ ap[i__3].r = t, ap[i__3].i = 0.f;
+ jr -= i__;
+/* L470: */
+ }
+ jl = jl + *n - j + 1;
+ jj = jj - j - 1;
+/* L480: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CLATTP */
+
+} /* clattp_ */
diff --git a/TESTING/LIN/clattr.c b/TESTING/LIN/clattr.c
new file mode 100644
index 0000000..a7c6f7b
--- /dev/null
+++ b/TESTING/LIN/clattr.c
@@ -0,0 +1,1018 @@
+/* clattr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__5 = 5;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static real c_b92 = 2.f;
+static integer c_n1 = -1;
+
+/* Subroutine */ int clattr_(integer *imat, char *uplo, char *trans, char *
+ diag, integer *iseed, integer *n, complex *a, integer *lda, complex *
+ b, complex *work, real *rwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2;
+ doublereal d__1, d__2;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ void c_div(complex *, complex *, complex *);
+ double pow_dd(doublereal *, doublereal *), sqrt(doublereal);
+ void r_cnjg(complex *, complex *);
+ double c_abs(complex *);
+
+ /* Local variables */
+ real c__;
+ integer i__, j;
+ complex s;
+ real x, y, z__;
+ complex ra, rb;
+ integer kl, ku, iy;
+ real ulp, sfac;
+ integer mode;
+ char path[3], dist[1];
+ real unfl;
+ extern /* Subroutine */ int crot_(integer *, complex *, integer *,
+ complex *, integer *, real *, complex *);
+ real rexp;
+ char type__[1];
+ real texp;
+ complex star1, plus1, plus2;
+ real bscal;
+ extern logical lsame_(char *, char *);
+ real tscal, anorm, bnorm, tleft;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), crotg_(complex *, complex *, real *,
+ complex *), cswap_(integer *, complex *, integer *, complex *,
+ integer *);
+ logical upper;
+ extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), slabad_(real *, real *);
+ extern integer icamax_(integer *, complex *, integer *);
+ extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *);
+ real bignum;
+ extern doublereal slarnd_(integer *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int clarnv_(integer *, integer *, integer *,
+ complex *), clatms_(integer *, integer *, char *, integer *, char
+ *, real *, integer *, real *, real *, integer *, integer *, char *
+, complex *, integer *, complex *, integer *);
+ integer jcount;
+ extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
+ *);
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLATTR generates a triangular test matrix in 2-dimensional storage. */
+/* IMAT and UPLO uniquely specify the properties of the test matrix, */
+/* which is returned in the array A. */
+
+/* Arguments */
+/* ========= */
+
+/* IMAT (input) INTEGER */
+/* An integer key describing which matrix to generate for this */
+/* path. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A will be upper or lower */
+/* triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies whether the matrix or its transpose will be used. */
+/* = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose */
+
+/* DIAG (output) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* The seed vector for the random number generator (used in */
+/* CLATMS). Modified on exit. */
+
+/* N (input) INTEGER */
+/* The order of the matrix to be generated. */
+
+/* A (output) COMPLEX array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading N x N */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading N x N lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix and the strictly upper triangular part of A is not */
+/* referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (output) COMPLEX array, dimension (N) */
+/* The right hand side vector, if IMAT > 10. */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --b;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "TR", (ftnlen)2, (ftnlen)2);
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ smlnum = unfl;
+ bignum = (1.f - ulp) / smlnum;
+ slabad_(&smlnum, &bignum);
+ if (*imat >= 7 && *imat <= 10 || *imat == 18) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ *info = 0;
+
+/* Quick return if N.LE.0. */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Call CLATB4 to set parameters for CLATMS. */
+
+ upper = lsame_(uplo, "U");
+ if (upper) {
+ clatb4_(path, imat, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ } else {
+ i__1 = -(*imat);
+ clatb4_(path, &i__1, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ }
+
+/* IMAT <= 6: Non-unit triangular matrix */
+
+ if (*imat <= 6) {
+ clatms_(n, n, dist, &iseed[1], type__, &rwork[1], &mode, &cndnum, &
+ anorm, &kl, &ku, "No packing", &a[a_offset], lda, &work[1],
+ info);
+
+/* IMAT > 6: Unit triangular matrix */
+/* The diagonal is deliberately set to something other than 1. */
+
+/* IMAT = 7: Matrix is the identity */
+
+ } else if (*imat == 7) {
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L10: */
+ }
+ i__2 = j + j * a_dim1;
+ a[i__2].r = (real) j, a[i__2].i = 0.f;
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * a_dim1;
+ a[i__2].r = (real) j, a[i__2].i = 0.f;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+/* IMAT > 7: Non-trivial unit triangular matrix */
+
+/* Generate a unit triangular matrix T with condition CNDNUM by */
+/* forming a triangular matrix with known singular values and */
+/* filling in the zero entries with Givens rotations. */
+
+ } else if (*imat <= 10) {
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L50: */
+ }
+ i__2 = j + j * a_dim1;
+ a[i__2].r = (real) j, a[i__2].i = 0.f;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * a_dim1;
+ a[i__2].r = (real) j, a[i__2].i = 0.f;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+
+/* Since the trace of a unit triangular matrix is 1, the product */
+/* of its singular values must be 1. Let s = sqrt(CNDNUM), */
+/* x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2. */
+/* The following triangular matrix has singular values s, 1, 1, */
+/* ..., 1, 1/s: */
+
+/* 1 y y y ... y y z */
+/* 1 0 0 ... 0 0 y */
+/* 1 0 ... 0 0 y */
+/* . ... . . . */
+/* . . . . */
+/* 1 0 y */
+/* 1 y */
+/* 1 */
+
+/* To fill in the zeros, we first multiply by a matrix with small */
+/* condition number of the form */
+
+/* 1 0 0 0 0 ... */
+/* 1 + * 0 0 ... */
+/* 1 + 0 0 0 */
+/* 1 + * 0 0 */
+/* 1 + 0 0 */
+/* ... */
+/* 1 + 0 */
+/* 1 0 */
+/* 1 */
+
+/* Each element marked with a '*' is formed by taking the product */
+/* of the adjacent elements marked with '+'. The '*'s can be */
+/* chosen freely, and the '+'s are chosen so that the inverse of */
+/* T will have elements of the same magnitude as T. If the *'s in */
+/* both T and inv(T) have small magnitude, T is well conditioned. */
+/* The two offdiagonals of T are stored in WORK. */
+
+/* The product of these two matrices has the form */
+
+/* 1 y y y y y . y y z */
+/* 1 + * 0 0 . 0 0 y */
+/* 1 + 0 0 . 0 0 y */
+/* 1 + * . . . . */
+/* 1 + . . . . */
+/* . . . . . */
+/* . . . . */
+/* 1 + y */
+/* 1 y */
+/* 1 */
+
+/* Now we multiply by Givens rotations, using the fact that */
+
+/* [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ] */
+/* [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ] */
+/* and */
+/* [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ] */
+/* [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ] */
+
+/* where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4). */
+
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = q__2.r * .25f, q__1.i = q__2.i * .25f;
+ star1.r = q__1.r, star1.i = q__1.i;
+ sfac = .5f;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = sfac * q__2.r, q__1.i = sfac * q__2.i;
+ plus1.r = q__1.r, plus1.i = q__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; j += 2) {
+ c_div(&q__1, &star1, &plus1);
+ plus2.r = q__1.r, plus2.i = q__1.i;
+ i__2 = j;
+ work[i__2].r = plus1.r, work[i__2].i = plus1.i;
+ i__2 = *n + j;
+ work[i__2].r = star1.r, work[i__2].i = star1.i;
+ if (j + 1 <= *n) {
+ i__2 = j + 1;
+ work[i__2].r = plus2.r, work[i__2].i = plus2.i;
+ i__2 = *n + j + 1;
+ work[i__2].r = 0.f, work[i__2].i = 0.f;
+ c_div(&q__1, &star1, &plus2);
+ plus1.r = q__1.r, plus1.i = q__1.i;
+ rexp = slarnd_(&c__2, &iseed[1]);
+ if (rexp < 0.f) {
+ d__1 = (doublereal) sfac;
+ d__2 = (doublereal) (1.f - rexp);
+ r__1 = -pow_dd(&d__1, &d__2);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ star1.r = q__1.r, star1.i = q__1.i;
+ } else {
+ d__1 = (doublereal) sfac;
+ d__2 = (doublereal) (rexp + 1.f);
+ r__1 = pow_dd(&d__1, &d__2);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ star1.r = q__1.r, star1.i = q__1.i;
+ }
+ }
+/* L90: */
+ }
+
+ x = sqrt(cndnum) - 1 / sqrt(cndnum);
+ if (*n > 2) {
+ y = sqrt(2.f / (*n - 2)) * x;
+ } else {
+ y = 0.f;
+ }
+ z__ = x * x;
+
+ if (upper) {
+ if (*n > 3) {
+ i__1 = *n - 3;
+ i__2 = *lda + 1;
+ ccopy_(&i__1, &work[1], &c__1, &a[a_dim1 * 3 + 2], &i__2);
+ if (*n > 4) {
+ i__1 = *n - 4;
+ i__2 = *lda + 1;
+ ccopy_(&i__1, &work[*n + 1], &c__1, &a[(a_dim1 << 2) + 2],
+ &i__2);
+ }
+ }
+ i__1 = *n - 1;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j * a_dim1 + 1;
+ a[i__2].r = y, a[i__2].i = 0.f;
+ i__2 = j + *n * a_dim1;
+ a[i__2].r = y, a[i__2].i = 0.f;
+/* L100: */
+ }
+ i__1 = *n * a_dim1 + 1;
+ a[i__1].r = z__, a[i__1].i = 0.f;
+ } else {
+ if (*n > 3) {
+ i__1 = *n - 3;
+ i__2 = *lda + 1;
+ ccopy_(&i__1, &work[1], &c__1, &a[(a_dim1 << 1) + 3], &i__2);
+ if (*n > 4) {
+ i__1 = *n - 4;
+ i__2 = *lda + 1;
+ ccopy_(&i__1, &work[*n + 1], &c__1, &a[(a_dim1 << 1) + 4],
+ &i__2);
+ }
+ }
+ i__1 = *n - 1;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j + a_dim1;
+ a[i__2].r = y, a[i__2].i = 0.f;
+ i__2 = *n + j * a_dim1;
+ a[i__2].r = y, a[i__2].i = 0.f;
+/* L110: */
+ }
+ i__1 = *n + a_dim1;
+ a[i__1].r = z__, a[i__1].i = 0.f;
+ }
+
+/* Fill in the zeros using Givens rotations. */
+
+ if (upper) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + (j + 1) * a_dim1;
+ ra.r = a[i__2].r, ra.i = a[i__2].i;
+ rb.r = 2.f, rb.i = 0.f;
+ crotg_(&ra, &rb, &c__, &s);
+
+/* Multiply by [ c s; -conjg(s) c] on the left. */
+
+ if (*n > j + 1) {
+ i__2 = *n - j - 1;
+ crot_(&i__2, &a[j + (j + 2) * a_dim1], lda, &a[j + 1 + (j
+ + 2) * a_dim1], lda, &c__, &s);
+ }
+
+/* Multiply by [-c -s; conjg(s) -c] on the right. */
+
+ if (j > 1) {
+ i__2 = j - 1;
+ r__1 = -c__;
+ q__1.r = -s.r, q__1.i = -s.i;
+ crot_(&i__2, &a[(j + 1) * a_dim1 + 1], &c__1, &a[j *
+ a_dim1 + 1], &c__1, &r__1, &q__1);
+ }
+
+/* Negate A(J,J+1). */
+
+ i__2 = j + (j + 1) * a_dim1;
+ i__3 = j + (j + 1) * a_dim1;
+ q__1.r = -a[i__3].r, q__1.i = -a[i__3].i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L120: */
+ }
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + 1 + j * a_dim1;
+ ra.r = a[i__2].r, ra.i = a[i__2].i;
+ rb.r = 2.f, rb.i = 0.f;
+ crotg_(&ra, &rb, &c__, &s);
+ r_cnjg(&q__1, &s);
+ s.r = q__1.r, s.i = q__1.i;
+
+/* Multiply by [ c -s; conjg(s) c] on the right. */
+
+ if (*n > j + 1) {
+ i__2 = *n - j - 1;
+ q__1.r = -s.r, q__1.i = -s.i;
+ crot_(&i__2, &a[j + 2 + (j + 1) * a_dim1], &c__1, &a[j +
+ 2 + j * a_dim1], &c__1, &c__, &q__1);
+ }
+
+/* Multiply by [-c s; -conjg(s) -c] on the left. */
+
+ if (j > 1) {
+ i__2 = j - 1;
+ r__1 = -c__;
+ crot_(&i__2, &a[j + a_dim1], lda, &a[j + 1 + a_dim1], lda,
+ &r__1, &s);
+ }
+
+/* Negate A(J+1,J). */
+
+ i__2 = j + 1 + j * a_dim1;
+ i__3 = j + 1 + j * a_dim1;
+ q__1.r = -a[i__3].r, q__1.i = -a[i__3].i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L130: */
+ }
+ }
+
+/* IMAT > 10: Pathological test cases. These triangular matrices */
+/* are badly scaled or badly conditioned, so when used in solving a */
+/* triangular system they may cause overflow in the solution vector. */
+
+ } else if (*imat == 11) {
+
+/* Type 11: Generate a triangular matrix with elements between */
+/* -1 and 1. Give the diagonal norm 2 to make it well-conditioned. */
+/* Make the right hand side large so that it requires scaling. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ clarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
+ i__2 = j + j * a_dim1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = q__2.r * 2.f, q__1.i = q__2.i * 2.f;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L140: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (j < *n) {
+ i__2 = *n - j;
+ clarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
+ }
+ i__2 = j + j * a_dim1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = q__2.r * 2.f, q__1.i = q__2.i * 2.f;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L150: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ clarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = icamax_(n, &b[1], &c__1);
+ bnorm = c_abs(&b[iy]);
+ bscal = bignum / dmax(1.f,bnorm);
+ csscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 12) {
+
+/* Type 12: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 12, the offdiagonal elements are small (CNORM(j) < 1). */
+
+ clarnv_(&c__2, &iseed[1], n, &b[1]);
+/* Computing MAX */
+ r__1 = 1.f, r__2 = (real) (*n - 1);
+ tscal = 1.f / dmax(r__1,r__2);
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ clarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
+ i__2 = j - 1;
+ csscal_(&i__2, &tscal, &a[j * a_dim1 + 1], &c__1);
+ i__2 = j + j * a_dim1;
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L160: */
+ }
+ i__1 = *n + *n * a_dim1;
+ i__2 = *n + *n * a_dim1;
+ q__1.r = smlnum * a[i__2].r, q__1.i = smlnum * a[i__2].i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (j < *n) {
+ i__2 = *n - j;
+ clarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
+ i__2 = *n - j;
+ csscal_(&i__2, &tscal, &a[j + 1 + j * a_dim1], &c__1);
+ }
+ i__2 = j + j * a_dim1;
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L170: */
+ }
+ i__1 = a_dim1 + 1;
+ i__2 = a_dim1 + 1;
+ q__1.r = smlnum * a[i__2].r, q__1.i = smlnum * a[i__2].i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ }
+
+ } else if (*imat == 13) {
+
+/* Type 13: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1). */
+
+ clarnv_(&c__2, &iseed[1], n, &b[1]);
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ clarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
+ i__2 = j + j * a_dim1;
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L180: */
+ }
+ i__1 = *n + *n * a_dim1;
+ i__2 = *n + *n * a_dim1;
+ q__1.r = smlnum * a[i__2].r, q__1.i = smlnum * a[i__2].i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (j < *n) {
+ i__2 = *n - j;
+ clarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
+ }
+ i__2 = j + j * a_dim1;
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L190: */
+ }
+ i__1 = a_dim1 + 1;
+ i__2 = a_dim1 + 1;
+ q__1.r = smlnum * a[i__2].r, q__1.i = smlnum * a[i__2].i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ }
+
+ } else if (*imat == 14) {
+
+/* Type 14: T is diagonal with small numbers on the diagonal to */
+/* make the growth factor underflow, but a small right hand side */
+/* chosen so that the solution does not overflow. */
+
+ if (upper) {
+ jcount = 1;
+ for (j = *n; j >= 1; --j) {
+ i__1 = j - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * a_dim1;
+ a[i__2].r = 0.f, a[i__2].i = 0.f;
+/* L200: */
+ }
+ if (jcount <= 2) {
+ i__1 = j + j * a_dim1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = smlnum * q__2.r, q__1.i = smlnum * q__2.i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ } else {
+ i__1 = j + j * a_dim1;
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+/* L210: */
+ }
+ } else {
+ jcount = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L220: */
+ }
+ if (jcount <= 2) {
+ i__2 = j + j * a_dim1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = smlnum * q__2.r, q__1.i = smlnum * q__2.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ } else {
+ i__2 = j + j * a_dim1;
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+/* L230: */
+ }
+ }
+
+/* Set the right hand side alternately zero and small. */
+
+ if (upper) {
+ b[1].r = 0.f, b[1].i = 0.f;
+ for (i__ = *n; i__ >= 2; i__ += -2) {
+ i__1 = i__;
+ b[i__1].r = 0.f, b[i__1].i = 0.f;
+ i__1 = i__ - 1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = smlnum * q__2.r, q__1.i = smlnum * q__2.i;
+ b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+/* L240: */
+ }
+ } else {
+ i__1 = *n;
+ b[i__1].r = 0.f, b[i__1].i = 0.f;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; i__ += 2) {
+ i__2 = i__;
+ b[i__2].r = 0.f, b[i__2].i = 0.f;
+ i__2 = i__ + 1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = smlnum * q__2.r, q__1.i = smlnum * q__2.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L250: */
+ }
+ }
+
+ } else if (*imat == 15) {
+
+/* Type 15: Make the diagonal elements small to cause gradual */
+/* overflow when dividing by T(j,j). To control the amount of */
+/* scaling needed, the matrix is bidiagonal. */
+
+/* Computing MAX */
+ r__1 = 1.f, r__2 = (real) (*n - 1);
+ texp = 1.f / dmax(r__1,r__2);
+ d__1 = (doublereal) smlnum;
+ d__2 = (doublereal) texp;
+ tscal = pow_dd(&d__1, &d__2);
+ clarnv_(&c__4, &iseed[1], n, &b[1]);
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 2;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L260: */
+ }
+ if (j > 1) {
+ i__2 = j - 1 + j * a_dim1;
+ a[i__2].r = -1.f, a[i__2].i = -1.f;
+ }
+ i__2 = j + j * a_dim1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L270: */
+ }
+ i__1 = *n;
+ b[i__1].r = 1.f, b[i__1].i = 1.f;
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L280: */
+ }
+ if (j < *n) {
+ i__2 = j + 1 + j * a_dim1;
+ a[i__2].r = -1.f, a[i__2].i = -1.f;
+ }
+ i__2 = j + j * a_dim1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L290: */
+ }
+ b[1].r = 1.f, b[1].i = 1.f;
+ }
+
+ } else if (*imat == 16) {
+
+/* Type 16: One zero diagonal element. */
+
+ iy = *n / 2 + 1;
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ clarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
+ if (j != iy) {
+ i__2 = j + j * a_dim1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = q__2.r * 2.f, q__1.i = q__2.i * 2.f;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ } else {
+ i__2 = j + j * a_dim1;
+ a[i__2].r = 0.f, a[i__2].i = 0.f;
+ }
+/* L300: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (j < *n) {
+ i__2 = *n - j;
+ clarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
+ }
+ if (j != iy) {
+ i__2 = j + j * a_dim1;
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = q__2.r * 2.f, q__1.i = q__2.i * 2.f;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ } else {
+ i__2 = j + j * a_dim1;
+ a[i__2].r = 0.f, a[i__2].i = 0.f;
+ }
+/* L310: */
+ }
+ }
+ clarnv_(&c__2, &iseed[1], n, &b[1]);
+ csscal_(n, &c_b92, &b[1], &c__1);
+
+ } else if (*imat == 17) {
+
+/* Type 17: Make the offdiagonal elements large to cause overflow */
+/* when adding a column of T. In the non-transposed case, the */
+/* matrix is constructed to cause overflow when adding a column in */
+/* every other step. */
+
+ tscal = unfl / ulp;
+ tscal = (1.f - ulp) / tscal;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L320: */
+ }
+/* L330: */
+ }
+ texp = 1.f;
+ if (upper) {
+ for (j = *n; j >= 2; j += -2) {
+ i__1 = j * a_dim1 + 1;
+ r__1 = -tscal / (real) (*n + 1);
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ i__1 = j + j * a_dim1;
+ a[i__1].r = 1.f, a[i__1].i = 0.f;
+ i__1 = j;
+ r__1 = texp * (1.f - ulp);
+ b[i__1].r = r__1, b[i__1].i = 0.f;
+ i__1 = (j - 1) * a_dim1 + 1;
+ r__1 = -(tscal / (real) (*n + 1)) / (real) (*n + 2);
+ a[i__1].r = r__1, a[i__1].i = 0.f;
+ i__1 = j - 1 + (j - 1) * a_dim1;
+ a[i__1].r = 1.f, a[i__1].i = 0.f;
+ i__1 = j - 1;
+ r__1 = texp * (real) (*n * *n + *n - 1);
+ b[i__1].r = r__1, b[i__1].i = 0.f;
+ texp *= 2.f;
+/* L340: */
+ }
+ r__1 = (real) (*n + 1) / (real) (*n + 2) * tscal;
+ b[1].r = r__1, b[1].i = 0.f;
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; j += 2) {
+ i__2 = *n + j * a_dim1;
+ r__1 = -tscal / (real) (*n + 1);
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ i__2 = j + j * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+ i__2 = j;
+ r__1 = texp * (1.f - ulp);
+ b[i__2].r = r__1, b[i__2].i = 0.f;
+ i__2 = *n + (j + 1) * a_dim1;
+ r__1 = -(tscal / (real) (*n + 1)) / (real) (*n + 2);
+ a[i__2].r = r__1, a[i__2].i = 0.f;
+ i__2 = j + 1 + (j + 1) * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+ i__2 = j + 1;
+ r__1 = texp * (real) (*n * *n + *n - 1);
+ b[i__2].r = r__1, b[i__2].i = 0.f;
+ texp *= 2.f;
+/* L350: */
+ }
+ i__1 = *n;
+ r__1 = (real) (*n + 1) / (real) (*n + 2) * tscal;
+ b[i__1].r = r__1, b[i__1].i = 0.f;
+ }
+
+ } else if (*imat == 18) {
+
+/* Type 18: Generate a unit triangular matrix with elements */
+/* between -1 and 1, and make the right hand side large so that it */
+/* requires scaling. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ clarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
+ i__2 = j + j * a_dim1;
+ a[i__2].r = 0.f, a[i__2].i = 0.f;
+/* L360: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (j < *n) {
+ i__2 = *n - j;
+ clarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
+ }
+ i__2 = j + j * a_dim1;
+ a[i__2].r = 0.f, a[i__2].i = 0.f;
+/* L370: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ clarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = icamax_(n, &b[1], &c__1);
+ bnorm = c_abs(&b[iy]);
+ bscal = bignum / dmax(1.f,bnorm);
+ csscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 19) {
+
+/* Type 19: Generate a triangular matrix with elements between */
+/* BIGNUM/(n-1) and BIGNUM so that at least one of the column */
+/* norms will exceed BIGNUM. */
+/* 1/3/91: CLATRS no longer can handle this case */
+
+/* Computing MAX */
+ r__1 = 1.f, r__2 = (real) (*n - 1);
+ tleft = bignum / dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = 1.f, r__2 = (real) (*n);
+ tscal = bignum * ((real) (*n - 1) / dmax(r__1,r__2));
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ clarnv_(&c__5, &iseed[1], &j, &a[j * a_dim1 + 1]);
+ slarnv_(&c__1, &iseed[1], &j, &rwork[1]);
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ r__1 = tleft + rwork[i__] * tscal;
+ q__1.r = r__1 * a[i__4].r, q__1.i = r__1 * a[i__4].i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L380: */
+ }
+/* L390: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ clarnv_(&c__5, &iseed[1], &i__2, &a[j + j * a_dim1]);
+ i__2 = *n - j + 1;
+ slarnv_(&c__1, &iseed[1], &i__2, &rwork[1]);
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ r__1 = tleft + rwork[i__ - j + 1] * tscal;
+ q__1.r = r__1 * a[i__4].r, q__1.i = r__1 * a[i__4].i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L400: */
+ }
+/* L410: */
+ }
+ }
+ clarnv_(&c__2, &iseed[1], n, &b[1]);
+ csscal_(n, &c_b92, &b[1], &c__1);
+ }
+
+/* Flip the matrix if the transpose will be used. */
+
+ if (! lsame_(trans, "N")) {
+ if (upper) {
+ i__1 = *n / 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - (j << 1) + 1;
+ cswap_(&i__2, &a[j + j * a_dim1], lda, &a[j + 1 + (*n - j + 1)
+ * a_dim1], &c_n1);
+/* L420: */
+ }
+ } else {
+ i__1 = *n / 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - (j << 1) + 1;
+ i__3 = -(*lda);
+ cswap_(&i__2, &a[j + j * a_dim1], &c__1, &a[*n - j + 1 + (j +
+ 1) * a_dim1], &i__3);
+/* L430: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CLATTR */
+
+} /* clattr_ */
diff --git a/TESTING/LIN/clavhe.c b/TESTING/LIN/clavhe.c
new file mode 100644
index 0000000..982c920
--- /dev/null
+++ b/TESTING/LIN/clavhe.c
@@ -0,0 +1,679 @@
+/* clavhe.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int clavhe_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, complex *a, integer *lda, integer *ipiv, complex *b,
+ integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer j, k;
+ complex t1, t2, d11, d12, d21, d22;
+ integer kp;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *), cgeru_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *),
+ cswap_(integer *, complex *, integer *, complex *, integer *),
+ clacgv_(integer *, complex *, integer *), xerbla_(char *, integer
+ *);
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAVHE performs one of the matrix-vector operations */
+/* x := A*x or x := A^H*x, */
+/* where x is an N element vector and A is one of the factors */
+/* from the symmetric factorization computed by CHETRF. */
+/* CHETRF produces a factorization of the form */
+/* U * D * U^H or L * D * L^H, */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, U^H (or L^H) is the conjugate transpose of */
+/* U (or L), and D is Hermitian and block diagonal with 1 x 1 and */
+/* 2 x 2 diagonal blocks. The multipliers for the transformations */
+/* and the upper or lower triangular parts of the diagonal blocks */
+/* are stored in the leading upper or lower triangle of the 2-D */
+/* array A. */
+
+/* If TRANS = 'N' or 'n', CLAVHE multiplies either by U or U * D */
+/* (or L or L * D). */
+/* If TRANS = 'C' or 'c', CLAVHE multiplies either by U^H or D * U^H */
+/* (or L^H or D * L^H ). */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1 */
+/* On entry, UPLO specifies whether the triangular matrix */
+/* stored in A is upper or lower triangular. */
+/* UPLO = 'U' or 'u' The matrix is upper triangular. */
+/* UPLO = 'L' or 'l' The matrix is lower triangular. */
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1 */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+/* TRANS = 'N' or 'n' x := A*x. */
+/* TRANS = 'C' or 'c' x := A^H*x. */
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1 */
+/* On entry, DIAG specifies whether the diagonal blocks are */
+/* assumed to be unit matrices: */
+/* DIAG = 'U' or 'u' Diagonal blocks are unit matrices. */
+/* DIAG = 'N' or 'n' Diagonal blocks are non-unit. */
+/* Unchanged on exit. */
+
+/* N - INTEGER */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* NRHS - INTEGER */
+/* On entry, NRHS specifies the number of right hand sides, */
+/* i.e., the number of vectors x to be multiplied by A. */
+/* NRHS must be at least zero. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array, dimension( LDA, N ) */
+/* On entry, A contains a block diagonal matrix and the */
+/* multipliers of the transformations used to obtain it, */
+/* stored as a 2-D triangular matrix. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling ( sub ) program. LDA must be at least */
+/* max( 1, N ). */
+/* Unchanged on exit. */
+
+/* IPIV - INTEGER array, dimension( N ) */
+/* On entry, IPIV contains the vector of pivot indices as */
+/* determined by CSYTRF or CHETRF. */
+/* If IPIV( K ) = K, no interchange was done. */
+/* If IPIV( K ) <> K but IPIV( K ) > 0, then row K was inter- */
+/* changed with row IPIV( K ) and a 1 x 1 pivot block was used. */
+/* If IPIV( K ) < 0 and UPLO = 'U', then row K-1 was exchanged */
+/* with row | IPIV( K ) | and a 2 x 2 pivot block was used. */
+/* If IPIV( K ) < 0 and UPLO = 'L', then row K+1 was exchanged */
+/* with row | IPIV( K ) | and a 2 x 2 pivot block was used. */
+
+/* B - COMPLEX array, dimension( LDB, NRHS ) */
+/* On entry, B contains NRHS vectors of length N. */
+/* On exit, B is overwritten with the product A * B. */
+
+/* LDB - INTEGER */
+/* On entry, LDB contains the leading dimension of B as */
+/* declared in the calling program. LDB must be at least */
+/* max( 1, N ). */
+/* Unchanged on exit. */
+
+/* INFO - INTEGER */
+/* INFO is the error flag. */
+/* On exit, a value of 0 indicates a successful exit. */
+/* A negative value, say -K, indicates that the K-th argument */
+/* has an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "C")) {
+ *info = -2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLAVHE ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+/* ------------------------------------------ */
+
+/* Compute B := A * B (No transpose) */
+
+/* ------------------------------------------ */
+ if (lsame_(trans, "N")) {
+
+/* Compute B := U*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop forward applying the transformations. */
+
+ k = 1;
+L10:
+ if (k > *n) {
+ goto L30;
+ }
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 pivot block */
+
+/* Multiply by the diagonal element if forming U * D. */
+
+ if (nounit) {
+ cscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformation. */
+
+ i__1 = k - 1;
+ cgeru_(&i__1, nrhs, &c_b1, &a[k * a_dim1 + 1], &c__1, &b[
+ k + b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ ++k;
+ } else {
+
+/* 2 x 2 pivot block */
+
+/* Multiply by the diagonal block if forming U * D. */
+
+ if (nounit) {
+ i__1 = k + k * a_dim1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = k + (k + 1) * a_dim1;
+ d12.r = a[i__1].r, d12.i = a[i__1].i;
+ r_cnjg(&q__1, &d12);
+ d21.r = q__1.r, d21.i = q__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + 1 + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ q__2.r = d11.r * t1.r - d11.i * t1.i, q__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ q__3.r = d12.r * t2.r - d12.i * t2.i, q__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ q__2.r = d21.r * t1.r - d21.i * t1.i, q__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ q__3.r = d22.r * t2.r - d22.i * t2.i, q__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L20: */
+ }
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformations. */
+
+ i__1 = k - 1;
+ cgeru_(&i__1, nrhs, &c_b1, &a[k * a_dim1 + 1], &c__1, &b[
+ k + b_dim1], ldb, &b[b_dim1 + 1], ldb);
+ i__1 = k - 1;
+ cgeru_(&i__1, nrhs, &c_b1, &a[(k + 1) * a_dim1 + 1], &
+ c__1, &b[k + 1 + b_dim1], ldb, &b[b_dim1 + 1],
+ ldb);
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ k += 2;
+ }
+ goto L10;
+L30:
+
+/* Compute B := L*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . */
+
+ ;
+ } else {
+
+/* Loop backward applying the transformations to B. */
+
+ k = *n;
+L40:
+ if (k < 1) {
+ goto L60;
+ }
+
+/* Test the pivot index. If greater than zero, a 1 x 1 */
+/* pivot was used, otherwise a 2 x 2 pivot was used. */
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 pivot block: */
+
+/* Multiply by the diagonal element if forming L * D. */
+
+ if (nounit) {
+ cscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+ kp = ipiv[k];
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ cgeru_(&i__1, nrhs, &c_b1, &a[k + 1 + k * a_dim1], &c__1,
+ &b[k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ --k;
+
+ } else {
+
+/* 2 x 2 pivot block: */
+
+/* Multiply by the diagonal block if forming L * D. */
+
+ if (nounit) {
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = k + k * a_dim1;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = k + (k - 1) * a_dim1;
+ d21.r = a[i__1].r, d21.i = a[i__1].i;
+ r_cnjg(&q__1, &d21);
+ d12.r = q__1.r, d12.i = q__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k - 1 + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k - 1 + j * b_dim1;
+ q__2.r = d11.r * t1.r - d11.i * t1.i, q__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ q__3.r = d12.r * t2.r - d12.i * t2.i, q__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + j * b_dim1;
+ q__2.r = d21.r * t1.r - d21.i * t1.i, q__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ q__3.r = d22.r * t2.r - d22.i * t2.i, q__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L50: */
+ }
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ cgeru_(&i__1, nrhs, &c_b1, &a[k + 1 + k * a_dim1], &c__1,
+ &b[k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+ i__1 = *n - k;
+ cgeru_(&i__1, nrhs, &c_b1, &a[k + 1 + (k - 1) * a_dim1], &
+ c__1, &b[k - 1 + b_dim1], ldb, &b[k + 1 + b_dim1],
+ ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ k += -2;
+ }
+ goto L40;
+L60:
+ ;
+ }
+/* -------------------------------------------------- */
+
+/* Compute B := A^H * B (conjugate transpose) */
+
+/* -------------------------------------------------- */
+ } else {
+
+/* Form B := U^H*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+/* and U^H = inv(U^H(1))*P(1)* ... *inv(U^H(m))*P(m) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop backward applying the transformations. */
+
+ k = *n;
+L70:
+ if (k < 1) {
+ goto L90;
+ }
+
+/* 1 x 1 pivot block. */
+
+ if (ipiv[k] > 0) {
+ if (k > 1) {
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+/* y = y - B' conjg(x), */
+/* where x is a column of A and y is a row of B. */
+
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = k - 1;
+ cgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[k * a_dim1 + 1], &c__1, &c_b1, &b[k + b_dim1],
+ ldb);
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ }
+ if (nounit) {
+ cscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+ --k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ if (k > 2) {
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k - 1) {
+ cswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformations */
+/* y = y - B' conjg(x), */
+/* where x is a block column of A and y is a block */
+/* row of B. */
+
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = k - 2;
+ cgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[k * a_dim1 + 1], &c__1, &c_b1, &b[k + b_dim1],
+ ldb);
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+
+ clacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
+ i__1 = k - 2;
+ cgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[(k - 1) * a_dim1 + 1], &c__1, &c_b1, &b[k - 1
+ + b_dim1], ldb);
+ clacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = k + k * a_dim1;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = k - 1 + k * a_dim1;
+ d12.r = a[i__1].r, d12.i = a[i__1].i;
+ r_cnjg(&q__1, &d12);
+ d21.r = q__1.r, d21.i = q__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k - 1 + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k - 1 + j * b_dim1;
+ q__2.r = d11.r * t1.r - d11.i * t1.i, q__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ q__3.r = d12.r * t2.r - d12.i * t2.i, q__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + j * b_dim1;
+ q__2.r = d21.r * t1.r - d21.i * t1.i, q__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ q__3.r = d22.r * t2.r - d22.i * t2.i, q__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L80: */
+ }
+ }
+ k += -2;
+ }
+ goto L70;
+L90:
+
+/* Form B := L^H*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) */
+/* and L^H = inv(L^H(m))*P(m)* ... *inv(L^H(1))*P(1) */
+
+ ;
+ } else {
+
+/* Loop forward applying the L-transformations. */
+
+ k = 1;
+L100:
+ if (k > *n) {
+ goto L120;
+ }
+
+/* 1 x 1 pivot block */
+
+ if (ipiv[k] > 0) {
+ if (k < *n) {
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = *n - k;
+ cgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[k + 1 + b_dim1]
+, ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, &b[k
+ + b_dim1], ldb);
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ }
+ if (nounit) {
+ cscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+ ++k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ if (k < *n - 1) {
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k + 1) {
+ cswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ clacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ cgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[k + 2 + b_dim1]
+, ldb, &a[k + 2 + (k + 1) * a_dim1], &c__1, &c_b1,
+ &b[k + 1 + b_dim1], ldb);
+ clacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
+
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ cgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[k + 2 + b_dim1]
+, ldb, &a[k + 2 + k * a_dim1], &c__1, &c_b1, &b[k
+ + b_dim1], ldb);
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ i__1 = k + k * a_dim1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = k + 1 + k * a_dim1;
+ d21.r = a[i__1].r, d21.i = a[i__1].i;
+ r_cnjg(&q__1, &d21);
+ d12.r = q__1.r, d12.i = q__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + 1 + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ q__2.r = d11.r * t1.r - d11.i * t1.i, q__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ q__3.r = d12.r * t2.r - d12.i * t2.i, q__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ q__2.r = d21.r * t1.r - d21.i * t1.i, q__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ q__3.r = d22.r * t2.r - d22.i * t2.i, q__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L110: */
+ }
+ }
+ k += 2;
+ }
+ goto L100;
+L120:
+ ;
+ }
+
+ }
+ return 0;
+
+/* End of CLAVHE */
+
+} /* clavhe_ */
diff --git a/TESTING/LIN/clavhp.c b/TESTING/LIN/clavhp.c
new file mode 100644
index 0000000..f1afd4c
--- /dev/null
+++ b/TESTING/LIN/clavhp.c
@@ -0,0 +1,681 @@
+/* clavhp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int clavhp_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, complex *a, integer *ipiv, complex *b, integer *ldb,
+ integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer j, k;
+ complex t1, t2, d11, d12, d21, d22;
+ integer kc, kp;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *), cgeru_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *),
+ cswap_(integer *, complex *, integer *, complex *, integer *),
+ clacgv_(integer *, complex *, integer *), xerbla_(char *, integer
+ *);
+ integer kcnext;
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAVHP performs one of the matrix-vector operations */
+/* x := A*x or x := A^H*x, */
+/* where x is an N element vector and A is one of the factors */
+/* from the symmetric factorization computed by CHPTRF. */
+/* CHPTRF produces a factorization of the form */
+/* U * D * U^H or L * D * L^H, */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, U^H (or L^H) is the conjugate transpose of */
+/* U (or L), and D is Hermitian and block diagonal with 1 x 1 and */
+/* 2 x 2 diagonal blocks. The multipliers for the transformations */
+/* and the upper or lower triangular parts of the diagonal blocks */
+/* are stored columnwise in packed format in the linear array A. */
+
+/* If TRANS = 'N' or 'n', CLAVHP multiplies either by U or U * D */
+/* (or L or L * D). */
+/* If TRANS = 'C' or 'c', CLAVHP multiplies either by U^H or D * U^H */
+/* (or L^H or D * L^H ). */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1 */
+/* On entry, UPLO specifies whether the triangular matrix */
+/* stored in A is upper or lower triangular. */
+/* UPLO = 'U' or 'u' The matrix is upper triangular. */
+/* UPLO = 'L' or 'l' The matrix is lower triangular. */
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1 */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+/* TRANS = 'N' or 'n' x := A*x. */
+/* TRANS = 'C' or 'c' x := A^H*x. */
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1 */
+/* On entry, DIAG specifies whether the diagonal blocks are */
+/* assumed to be unit matrices, as follows: */
+/* DIAG = 'U' or 'u' Diagonal blocks are unit matrices. */
+/* DIAG = 'N' or 'n' Diagonal blocks are non-unit. */
+/* Unchanged on exit. */
+
+/* N - INTEGER */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* NRHS - INTEGER */
+/* On entry, NRHS specifies the number of right hand sides, */
+/* i.e., the number of vectors x to be multiplied by A. */
+/* NRHS must be at least zero. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array, dimension( N*(N+1)/2 ) */
+/* On entry, A contains a block diagonal matrix and the */
+/* multipliers of the transformations used to obtain it, */
+/* stored as a packed triangular matrix. */
+/* Unchanged on exit. */
+
+/* IPIV - INTEGER array, dimension( N ) */
+/* On entry, IPIV contains the vector of pivot indices as */
+/* determined by CSPTRF or CHPTRF. */
+/* If IPIV( K ) = K, no interchange was done. */
+/* If IPIV( K ) <> K but IPIV( K ) > 0, then row K was inter- */
+/* changed with row IPIV( K ) and a 1 x 1 pivot block was used. */
+/* If IPIV( K ) < 0 and UPLO = 'U', then row K-1 was exchanged */
+/* with row | IPIV( K ) | and a 2 x 2 pivot block was used. */
+/* If IPIV( K ) < 0 and UPLO = 'L', then row K+1 was exchanged */
+/* with row | IPIV( K ) | and a 2 x 2 pivot block was used. */
+
+/* B - COMPLEX array, dimension( LDB, NRHS ) */
+/* On entry, B contains NRHS vectors of length N. */
+/* On exit, B is overwritten with the product A * B. */
+
+/* LDB - INTEGER */
+/* On entry, LDB contains the leading dimension of B as */
+/* declared in the calling program. LDB must be at least */
+/* max( 1, N ). */
+/* Unchanged on exit. */
+
+/* INFO - INTEGER */
+/* INFO is the error flag. */
+/* On exit, a value of 0 indicates a successful exit. */
+/* A negative value, say -K, indicates that the K-th argument */
+/* has an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --a;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "C")) {
+ *info = -2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLAVHP ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+/* ------------------------------------------ */
+
+/* Compute B := A * B (No transpose) */
+
+/* ------------------------------------------ */
+ if (lsame_(trans, "N")) {
+
+/* Compute B := U*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop forward applying the transformations. */
+
+ k = 1;
+ kc = 1;
+L10:
+ if (k > *n) {
+ goto L30;
+ }
+
+/* 1 x 1 pivot block */
+
+ if (ipiv[k] > 0) {
+
+/* Multiply by the diagonal element if forming U * D. */
+
+ if (nounit) {
+ cscal_(nrhs, &a[kc + k - 1], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformation. */
+
+ i__1 = k - 1;
+ cgeru_(&i__1, nrhs, &c_b1, &a[kc], &c__1, &b[k + b_dim1],
+ ldb, &b[b_dim1 + 1], ldb);
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ kc += k;
+ ++k;
+ } else {
+
+/* 2 x 2 pivot block */
+
+ kcnext = kc + k;
+
+/* Multiply by the diagonal block if forming U * D. */
+
+ if (nounit) {
+ i__1 = kcnext - 1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = kcnext + k;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = kcnext + k - 1;
+ d12.r = a[i__1].r, d12.i = a[i__1].i;
+ r_cnjg(&q__1, &d12);
+ d21.r = q__1.r, d21.i = q__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + 1 + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ q__2.r = d11.r * t1.r - d11.i * t1.i, q__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ q__3.r = d12.r * t2.r - d12.i * t2.i, q__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ q__2.r = d21.r * t1.r - d21.i * t1.i, q__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ q__3.r = d22.r * t2.r - d22.i * t2.i, q__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L20: */
+ }
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformations. */
+
+ i__1 = k - 1;
+ cgeru_(&i__1, nrhs, &c_b1, &a[kc], &c__1, &b[k + b_dim1],
+ ldb, &b[b_dim1 + 1], ldb);
+ i__1 = k - 1;
+ cgeru_(&i__1, nrhs, &c_b1, &a[kcnext], &c__1, &b[k + 1 +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ kc = kcnext + k + 1;
+ k += 2;
+ }
+ goto L10;
+L30:
+
+/* Compute B := L*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . */
+
+ ;
+ } else {
+
+/* Loop backward applying the transformations to B. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L40:
+ if (k < 1) {
+ goto L60;
+ }
+ kc -= *n - k + 1;
+
+/* Test the pivot index. If greater than zero, a 1 x 1 */
+/* pivot was used, otherwise a 2 x 2 pivot was used. */
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 pivot block: */
+
+/* Multiply by the diagonal element if forming L * D. */
+
+ if (nounit) {
+ cscal_(nrhs, &a[kc], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+ kp = ipiv[k];
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ cgeru_(&i__1, nrhs, &c_b1, &a[kc + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ --k;
+
+ } else {
+
+/* 2 x 2 pivot block: */
+
+ kcnext = kc - (*n - k + 2);
+
+/* Multiply by the diagonal block if forming L * D. */
+
+ if (nounit) {
+ i__1 = kcnext;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = kc;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = kcnext + 1;
+ d21.r = a[i__1].r, d21.i = a[i__1].i;
+ r_cnjg(&q__1, &d21);
+ d12.r = q__1.r, d12.i = q__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k - 1 + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k - 1 + j * b_dim1;
+ q__2.r = d11.r * t1.r - d11.i * t1.i, q__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ q__3.r = d12.r * t2.r - d12.i * t2.i, q__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + j * b_dim1;
+ q__2.r = d21.r * t1.r - d21.i * t1.i, q__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ q__3.r = d22.r * t2.r - d22.i * t2.i, q__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L50: */
+ }
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ cgeru_(&i__1, nrhs, &c_b1, &a[kc + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+ i__1 = *n - k;
+ cgeru_(&i__1, nrhs, &c_b1, &a[kcnext + 2], &c__1, &b[k -
+ 1 + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ kc = kcnext;
+ k += -2;
+ }
+ goto L40;
+L60:
+ ;
+ }
+/* ------------------------------------------------- */
+
+/* Compute B := A^H * B (conjugate transpose) */
+
+/* ------------------------------------------------- */
+ } else {
+
+/* Form B := U^H*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+/* and U^H = inv(U^H(1))*P(1)* ... *inv(U^H(m))*P(m) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop backward applying the transformations. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L70:
+ if (k < 1) {
+ goto L90;
+ }
+ kc -= k;
+
+/* 1 x 1 pivot block. */
+
+ if (ipiv[k] > 0) {
+ if (k > 1) {
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation: */
+/* y := y - B' * conjg(x) */
+/* where x is a column of A and y is a row of B. */
+
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = k - 1;
+ cgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[kc], &c__1, &c_b1, &b[k + b_dim1], ldb);
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ }
+ if (nounit) {
+ cscal_(nrhs, &a[kc + k - 1], &b[k + b_dim1], ldb);
+ }
+ --k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ kcnext = kc - (k - 1);
+ if (k > 2) {
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k - 1) {
+ cswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformations. */
+
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = k - 2;
+ cgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[kc], &c__1, &c_b1, &b[k + b_dim1], ldb);
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+
+ clacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
+ i__1 = k - 2;
+ cgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[kcnext], &c__1, &c_b1, &b[k - 1 + b_dim1],
+ ldb);
+ clacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ i__1 = kc - 1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = kc + k - 1;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = kc + k - 2;
+ d12.r = a[i__1].r, d12.i = a[i__1].i;
+ r_cnjg(&q__1, &d12);
+ d21.r = q__1.r, d21.i = q__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k - 1 + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k - 1 + j * b_dim1;
+ q__2.r = d11.r * t1.r - d11.i * t1.i, q__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ q__3.r = d12.r * t2.r - d12.i * t2.i, q__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + j * b_dim1;
+ q__2.r = d21.r * t1.r - d21.i * t1.i, q__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ q__3.r = d22.r * t2.r - d22.i * t2.i, q__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L80: */
+ }
+ }
+ kc = kcnext;
+ k += -2;
+ }
+ goto L70;
+L90:
+
+/* Form B := L^H*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) */
+/* and L^H = inv(L(m))*P(m)* ... *inv(L(1))*P(1) */
+
+ ;
+ } else {
+
+/* Loop forward applying the L-transformations. */
+
+ k = 1;
+ kc = 1;
+L100:
+ if (k > *n) {
+ goto L120;
+ }
+
+/* 1 x 1 pivot block */
+
+ if (ipiv[k] > 0) {
+ if (k < *n) {
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = *n - k;
+ cgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[k + 1 + b_dim1]
+, ldb, &a[kc + 1], &c__1, &c_b1, &b[k + b_dim1],
+ ldb);
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ }
+ if (nounit) {
+ cscal_(nrhs, &a[kc], &b[k + b_dim1], ldb);
+ }
+ kc = kc + *n - k + 1;
+ ++k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ kcnext = kc + *n - k + 1;
+ if (k < *n - 1) {
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k + 1) {
+ cswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ clacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ cgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[k + 2 + b_dim1]
+, ldb, &a[kcnext + 1], &c__1, &c_b1, &b[k + 1 +
+ b_dim1], ldb);
+ clacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
+
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ cgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[k + 2 + b_dim1]
+, ldb, &a[kc + 2], &c__1, &c_b1, &b[k + b_dim1],
+ ldb);
+ clacgv_(nrhs, &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ i__1 = kc;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = kcnext;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = kc + 1;
+ d21.r = a[i__1].r, d21.i = a[i__1].i;
+ r_cnjg(&q__1, &d21);
+ d12.r = q__1.r, d12.i = q__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + 1 + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ q__2.r = d11.r * t1.r - d11.i * t1.i, q__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ q__3.r = d12.r * t2.r - d12.i * t2.i, q__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ q__2.r = d21.r * t1.r - d21.i * t1.i, q__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ q__3.r = d22.r * t2.r - d22.i * t2.i, q__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L110: */
+ }
+ }
+ kc = kcnext + (*n - k);
+ k += 2;
+ }
+ goto L100;
+L120:
+ ;
+ }
+
+ }
+ return 0;
+
+/* End of CLAVHP */
+
+} /* clavhp_ */
diff --git a/TESTING/LIN/clavsp.c b/TESTING/LIN/clavsp.c
new file mode 100644
index 0000000..4353482
--- /dev/null
+++ b/TESTING/LIN/clavsp.c
@@ -0,0 +1,661 @@
+/* clavsp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int clavsp_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, complex *a, integer *ipiv, complex *b, integer *ldb,
+ integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2;
+ complex q__1, q__2, q__3;
+
+ /* Local variables */
+ integer j, k;
+ complex t1, t2, d11, d12, d21, d22;
+ integer kc, kp;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *), cgeru_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *),
+ cswap_(integer *, complex *, integer *, complex *, integer *),
+ xerbla_(char *, integer *);
+ integer kcnext;
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAVSP performs one of the matrix-vector operations */
+/* x := A*x or x := A^T*x, */
+/* where x is an N element vector and A is one of the factors */
+/* from the symmetric factorization computed by CSPTRF. */
+/* CSPTRF produces a factorization of the form */
+/* U * D * U^T or L * D * L^T, */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, U^T (or L^T) is the transpose of */
+/* U (or L), and D is symmetric and block diagonal with 1 x 1 and */
+/* 2 x 2 diagonal blocks. The multipliers for the transformations */
+/* and the upper or lower triangular parts of the diagonal blocks */
+/* are stored columnwise in packed format in the linear array A. */
+
+/* If TRANS = 'N' or 'n', CLAVSP multiplies either by U or U * D */
+/* (or L or L * D). */
+/* If TRANS = 'C' or 'c', CLAVSP multiplies either by U^T or D * U^T */
+/* (or L^T or D * L^T ). */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1 */
+/* On entry, UPLO specifies whether the triangular matrix */
+/* stored in A is upper or lower triangular. */
+/* UPLO = 'U' or 'u' The matrix is upper triangular. */
+/* UPLO = 'L' or 'l' The matrix is lower triangular. */
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1 */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+/* TRANS = 'N' or 'n' x := A*x. */
+/* TRANS = 'T' or 't' x := A^T*x. */
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1 */
+/* On entry, DIAG specifies whether the diagonal blocks are */
+/* assumed to be unit matrices, as follows: */
+/* DIAG = 'U' or 'u' Diagonal blocks are unit matrices. */
+/* DIAG = 'N' or 'n' Diagonal blocks are non-unit. */
+/* Unchanged on exit. */
+
+/* N - INTEGER */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* NRHS - INTEGER */
+/* On entry, NRHS specifies the number of right hand sides, */
+/* i.e., the number of vectors x to be multiplied by A. */
+/* NRHS must be at least zero. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array, dimension( N*(N+1)/2 ) */
+/* On entry, A contains a block diagonal matrix and the */
+/* multipliers of the transformations used to obtain it, */
+/* stored as a packed triangular matrix. */
+/* Unchanged on exit. */
+
+/* IPIV - INTEGER array, dimension( N ) */
+/* On entry, IPIV contains the vector of pivot indices as */
+/* determined by CSPTRF. */
+/* If IPIV( K ) = K, no interchange was done. */
+/* If IPIV( K ) <> K but IPIV( K ) > 0, then row K was inter- */
+/* changed with row IPIV( K ) and a 1 x 1 pivot block was used. */
+/* If IPIV( K ) < 0 and UPLO = 'U', then row K-1 was exchanged */
+/* with row | IPIV( K ) | and a 2 x 2 pivot block was used. */
+/* If IPIV( K ) < 0 and UPLO = 'L', then row K+1 was exchanged */
+/* with row | IPIV( K ) | and a 2 x 2 pivot block was used. */
+
+/* B - COMPLEX array, dimension( LDB, NRHS ) */
+/* On entry, B contains NRHS vectors of length N. */
+/* On exit, B is overwritten with the product A * B. */
+
+/* LDB - INTEGER */
+/* On entry, LDB contains the leading dimension of B as */
+/* declared in the calling program. LDB must be at least */
+/* max( 1, N ). */
+/* Unchanged on exit. */
+
+/* INFO - INTEGER */
+/* INFO is the error flag. */
+/* On exit, a value of 0 indicates a successful exit. */
+/* A negative value, say -K, indicates that the K-th argument */
+/* has an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --a;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T")) {
+ *info = -2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLAVSP ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+/* ------------------------------------------ */
+
+/* Compute B := A * B (No transpose) */
+
+/* ------------------------------------------ */
+ if (lsame_(trans, "N")) {
+
+/* Compute B := U*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop forward applying the transformations. */
+
+ k = 1;
+ kc = 1;
+L10:
+ if (k > *n) {
+ goto L30;
+ }
+
+/* 1 x 1 pivot block */
+
+ if (ipiv[k] > 0) {
+
+/* Multiply by the diagonal element if forming U * D. */
+
+ if (nounit) {
+ cscal_(nrhs, &a[kc + k - 1], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformation. */
+
+ i__1 = k - 1;
+ cgeru_(&i__1, nrhs, &c_b1, &a[kc], &c__1, &b[k + b_dim1],
+ ldb, &b[b_dim1 + 1], ldb);
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ kc += k;
+ ++k;
+ } else {
+
+/* 2 x 2 pivot block */
+
+ kcnext = kc + k;
+
+/* Multiply by the diagonal block if forming U * D. */
+
+ if (nounit) {
+ i__1 = kcnext - 1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = kcnext + k;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = kcnext + k - 1;
+ d12.r = a[i__1].r, d12.i = a[i__1].i;
+ d21.r = d12.r, d21.i = d12.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + 1 + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ q__2.r = d11.r * t1.r - d11.i * t1.i, q__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ q__3.r = d12.r * t2.r - d12.i * t2.i, q__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ q__2.r = d21.r * t1.r - d21.i * t1.i, q__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ q__3.r = d22.r * t2.r - d22.i * t2.i, q__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L20: */
+ }
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformations. */
+
+ i__1 = k - 1;
+ cgeru_(&i__1, nrhs, &c_b1, &a[kc], &c__1, &b[k + b_dim1],
+ ldb, &b[b_dim1 + 1], ldb);
+ i__1 = k - 1;
+ cgeru_(&i__1, nrhs, &c_b1, &a[kcnext], &c__1, &b[k + 1 +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ kc = kcnext + k + 1;
+ k += 2;
+ }
+ goto L10;
+L30:
+
+/* Compute B := L*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . */
+
+ ;
+ } else {
+
+/* Loop backward applying the transformations to B. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L40:
+ if (k < 1) {
+ goto L60;
+ }
+ kc -= *n - k + 1;
+
+/* Test the pivot index. If greater than zero, a 1 x 1 */
+/* pivot was used, otherwise a 2 x 2 pivot was used. */
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 pivot block: */
+
+/* Multiply by the diagonal element if forming L * D. */
+
+ if (nounit) {
+ cscal_(nrhs, &a[kc], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+ kp = ipiv[k];
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ cgeru_(&i__1, nrhs, &c_b1, &a[kc + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ --k;
+
+ } else {
+
+/* 2 x 2 pivot block: */
+
+ kcnext = kc - (*n - k + 2);
+
+/* Multiply by the diagonal block if forming L * D. */
+
+ if (nounit) {
+ i__1 = kcnext;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = kc;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = kcnext + 1;
+ d21.r = a[i__1].r, d21.i = a[i__1].i;
+ d12.r = d21.r, d12.i = d21.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k - 1 + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k - 1 + j * b_dim1;
+ q__2.r = d11.r * t1.r - d11.i * t1.i, q__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ q__3.r = d12.r * t2.r - d12.i * t2.i, q__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + j * b_dim1;
+ q__2.r = d21.r * t1.r - d21.i * t1.i, q__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ q__3.r = d22.r * t2.r - d22.i * t2.i, q__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L50: */
+ }
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ cgeru_(&i__1, nrhs, &c_b1, &a[kc + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+ i__1 = *n - k;
+ cgeru_(&i__1, nrhs, &c_b1, &a[kcnext + 2], &c__1, &b[k -
+ 1 + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ kc = kcnext;
+ k += -2;
+ }
+ goto L40;
+L60:
+ ;
+ }
+/* ------------------------------------------------- */
+
+/* Compute B := A^T * B (transpose) */
+
+/* ------------------------------------------------- */
+ } else {
+
+/* Form B := U^T*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+/* and U^T = inv(U^T(1))*P(1)* ... *inv(U^T(m))*P(m) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop backward applying the transformations. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L70:
+ if (k < 1) {
+ goto L90;
+ }
+ kc -= k;
+
+/* 1 x 1 pivot block. */
+
+ if (ipiv[k] > 0) {
+ if (k > 1) {
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation: */
+/* y := y - B' * conjg(x) */
+/* where x is a column of A and y is a row of B. */
+
+ i__1 = k - 1;
+ cgemv_("Transpose", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[kc], &c__1, &c_b1, &b[k + b_dim1], ldb);
+ }
+ if (nounit) {
+ cscal_(nrhs, &a[kc + k - 1], &b[k + b_dim1], ldb);
+ }
+ --k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ kcnext = kc - (k - 1);
+ if (k > 2) {
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k - 1) {
+ cswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformations. */
+
+ i__1 = k - 2;
+ cgemv_("Transpose", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[kc], &c__1, &c_b1, &b[k + b_dim1], ldb);
+
+ i__1 = k - 2;
+ cgemv_("Transpose", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[kcnext], &c__1, &c_b1, &b[k - 1 + b_dim1],
+ ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ i__1 = kc - 1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = kc + k - 1;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = kc + k - 2;
+ d12.r = a[i__1].r, d12.i = a[i__1].i;
+ d21.r = d12.r, d21.i = d12.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k - 1 + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k - 1 + j * b_dim1;
+ q__2.r = d11.r * t1.r - d11.i * t1.i, q__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ q__3.r = d12.r * t2.r - d12.i * t2.i, q__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + j * b_dim1;
+ q__2.r = d21.r * t1.r - d21.i * t1.i, q__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ q__3.r = d22.r * t2.r - d22.i * t2.i, q__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L80: */
+ }
+ }
+ kc = kcnext;
+ k += -2;
+ }
+ goto L70;
+L90:
+
+/* Form B := L^T*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) */
+/* and L^T = inv(L(m))*P(m)* ... *inv(L(1))*P(1) */
+
+ ;
+ } else {
+
+/* Loop forward applying the L-transformations. */
+
+ k = 1;
+ kc = 1;
+L100:
+ if (k > *n) {
+ goto L120;
+ }
+
+/* 1 x 1 pivot block */
+
+ if (ipiv[k] > 0) {
+ if (k < *n) {
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ i__1 = *n - k;
+ cgemv_("Transpose", &i__1, nrhs, &c_b1, &b[k + 1 + b_dim1]
+, ldb, &a[kc + 1], &c__1, &c_b1, &b[k + b_dim1],
+ ldb);
+ }
+ if (nounit) {
+ cscal_(nrhs, &a[kc], &b[k + b_dim1], ldb);
+ }
+ kc = kc + *n - k + 1;
+ ++k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ kcnext = kc + *n - k + 1;
+ if (k < *n - 1) {
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k + 1) {
+ cswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ i__1 = *n - k - 1;
+ cgemv_("Transpose", &i__1, nrhs, &c_b1, &b[k + 2 + b_dim1]
+, ldb, &a[kcnext + 1], &c__1, &c_b1, &b[k + 1 +
+ b_dim1], ldb);
+
+ i__1 = *n - k - 1;
+ cgemv_("Transpose", &i__1, nrhs, &c_b1, &b[k + 2 + b_dim1]
+, ldb, &a[kc + 2], &c__1, &c_b1, &b[k + b_dim1],
+ ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ i__1 = kc;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = kcnext;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = kc + 1;
+ d21.r = a[i__1].r, d21.i = a[i__1].i;
+ d12.r = d21.r, d12.i = d21.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + 1 + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ q__2.r = d11.r * t1.r - d11.i * t1.i, q__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ q__3.r = d12.r * t2.r - d12.i * t2.i, q__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ q__2.r = d21.r * t1.r - d21.i * t1.i, q__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ q__3.r = d22.r * t2.r - d22.i * t2.i, q__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L110: */
+ }
+ }
+ kc = kcnext + (*n - k);
+ k += 2;
+ }
+ goto L100;
+L120:
+ ;
+ }
+
+ }
+ return 0;
+
+/* End of CLAVSP */
+
+} /* clavsp_ */
diff --git a/TESTING/LIN/clavsy.c b/TESTING/LIN/clavsy.c
new file mode 100644
index 0000000..6085fdc
--- /dev/null
+++ b/TESTING/LIN/clavsy.c
@@ -0,0 +1,651 @@
+/* clavsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int clavsy_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, complex *a, integer *lda, integer *ipiv, complex *b,
+ integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+ complex q__1, q__2, q__3;
+
+ /* Local variables */
+ integer j, k;
+ complex t1, t2, d11, d12, d21, d22;
+ integer kp;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *), cgeru_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *),
+ cswap_(integer *, complex *, integer *, complex *, integer *),
+ xerbla_(char *, integer *);
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAVSY performs one of the matrix-vector operations */
+/* x := A*x or x := A'*x, */
+/* where x is an N element vector and A is one of the factors */
+/* from the symmetric factorization computed by CSYTRF. */
+/* CSYTRF produces a factorization of the form */
+/* U * D * U' or L * D * L' , */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, U' (or L') is the transpose of */
+/* U (or L), and D is symmetric and block diagonal with 1 x 1 and */
+/* 2 x 2 diagonal blocks. The multipliers for the transformations */
+/* and the upper or lower triangular parts of the diagonal blocks */
+/* are stored in the leading upper or lower triangle of the 2-D */
+/* array A. */
+
+/* If TRANS = 'N' or 'n', CLAVSY multiplies either by U or U * D */
+/* (or L or L * D). */
+/* If TRANS = 'T' or 't', CLAVSY multiplies either by U' or D * U' */
+/* (or L' or D * L' ). */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1 */
+/* On entry, UPLO specifies whether the triangular matrix */
+/* stored in A is upper or lower triangular. */
+/* UPLO = 'U' or 'u' The matrix is upper triangular. */
+/* UPLO = 'L' or 'l' The matrix is lower triangular. */
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1 */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+/* TRANS = 'N' or 'n' x := A*x. */
+/* TRANS = 'T' or 't' x := A'*x. */
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1 */
+/* On entry, DIAG specifies whether the diagonal blocks are */
+/* assumed to be unit matrices: */
+/* DIAG = 'U' or 'u' Diagonal blocks are unit matrices. */
+/* DIAG = 'N' or 'n' Diagonal blocks are non-unit. */
+/* Unchanged on exit. */
+
+/* N - INTEGER */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* NRHS - INTEGER */
+/* On entry, NRHS specifies the number of right hand sides, */
+/* i.e., the number of vectors x to be multiplied by A. */
+/* NRHS must be at least zero. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array, dimension( LDA, N ) */
+/* On entry, A contains a block diagonal matrix and the */
+/* multipliers of the transformations used to obtain it, */
+/* stored as a 2-D triangular matrix. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling ( sub ) program. LDA must be at least */
+/* max( 1, N ). */
+/* Unchanged on exit. */
+
+/* IPIV - INTEGER array, dimension( N ) */
+/* On entry, IPIV contains the vector of pivot indices as */
+/* determined by CSYTRF or CHETRF. */
+/* If IPIV( K ) = K, no interchange was done. */
+/* If IPIV( K ) <> K but IPIV( K ) > 0, then row K was inter- */
+/* changed with row IPIV( K ) and a 1 x 1 pivot block was used. */
+/* If IPIV( K ) < 0 and UPLO = 'U', then row K-1 was exchanged */
+/* with row | IPIV( K ) | and a 2 x 2 pivot block was used. */
+/* If IPIV( K ) < 0 and UPLO = 'L', then row K+1 was exchanged */
+/* with row | IPIV( K ) | and a 2 x 2 pivot block was used. */
+
+/* B - COMPLEX array, dimension( LDB, NRHS ) */
+/* On entry, B contains NRHS vectors of length N. */
+/* On exit, B is overwritten with the product A * B. */
+
+/* LDB - INTEGER */
+/* On entry, LDB contains the leading dimension of B as */
+/* declared in the calling program. LDB must be at least */
+/* max( 1, N ). */
+/* Unchanged on exit. */
+
+/* INFO - INTEGER */
+/* INFO is the error flag. */
+/* On exit, a value of 0 indicates a successful exit. */
+/* A negative value, say -K, indicates that the K-th argument */
+/* has an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T")) {
+ *info = -2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLAVSY ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+/* ------------------------------------------ */
+
+/* Compute B := A * B (No transpose) */
+
+/* ------------------------------------------ */
+ if (lsame_(trans, "N")) {
+
+/* Compute B := U*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop forward applying the transformations. */
+
+ k = 1;
+L10:
+ if (k > *n) {
+ goto L30;
+ }
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 pivot block */
+
+/* Multiply by the diagonal element if forming U * D. */
+
+ if (nounit) {
+ cscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformation. */
+
+ i__1 = k - 1;
+ cgeru_(&i__1, nrhs, &c_b1, &a[k * a_dim1 + 1], &c__1, &b[
+ k + b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ ++k;
+ } else {
+
+/* 2 x 2 pivot block */
+
+/* Multiply by the diagonal block if forming U * D. */
+
+ if (nounit) {
+ i__1 = k + k * a_dim1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = k + (k + 1) * a_dim1;
+ d12.r = a[i__1].r, d12.i = a[i__1].i;
+ d21.r = d12.r, d21.i = d12.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + 1 + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ q__2.r = d11.r * t1.r - d11.i * t1.i, q__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ q__3.r = d12.r * t2.r - d12.i * t2.i, q__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ q__2.r = d21.r * t1.r - d21.i * t1.i, q__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ q__3.r = d22.r * t2.r - d22.i * t2.i, q__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L20: */
+ }
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformations. */
+
+ i__1 = k - 1;
+ cgeru_(&i__1, nrhs, &c_b1, &a[k * a_dim1 + 1], &c__1, &b[
+ k + b_dim1], ldb, &b[b_dim1 + 1], ldb);
+ i__1 = k - 1;
+ cgeru_(&i__1, nrhs, &c_b1, &a[(k + 1) * a_dim1 + 1], &
+ c__1, &b[k + 1 + b_dim1], ldb, &b[b_dim1 + 1],
+ ldb);
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ k += 2;
+ }
+ goto L10;
+L30:
+
+/* Compute B := L*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . */
+
+ ;
+ } else {
+
+/* Loop backward applying the transformations to B. */
+
+ k = *n;
+L40:
+ if (k < 1) {
+ goto L60;
+ }
+
+/* Test the pivot index. If greater than zero, a 1 x 1 */
+/* pivot was used, otherwise a 2 x 2 pivot was used. */
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 pivot block: */
+
+/* Multiply by the diagonal element if forming L * D. */
+
+ if (nounit) {
+ cscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+ kp = ipiv[k];
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ cgeru_(&i__1, nrhs, &c_b1, &a[k + 1 + k * a_dim1], &c__1,
+ &b[k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ --k;
+
+ } else {
+
+/* 2 x 2 pivot block: */
+
+/* Multiply by the diagonal block if forming L * D. */
+
+ if (nounit) {
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = k + k * a_dim1;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = k + (k - 1) * a_dim1;
+ d21.r = a[i__1].r, d21.i = a[i__1].i;
+ d12.r = d21.r, d12.i = d21.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k - 1 + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k - 1 + j * b_dim1;
+ q__2.r = d11.r * t1.r - d11.i * t1.i, q__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ q__3.r = d12.r * t2.r - d12.i * t2.i, q__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + j * b_dim1;
+ q__2.r = d21.r * t1.r - d21.i * t1.i, q__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ q__3.r = d22.r * t2.r - d22.i * t2.i, q__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L50: */
+ }
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ cgeru_(&i__1, nrhs, &c_b1, &a[k + 1 + k * a_dim1], &c__1,
+ &b[k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+ i__1 = *n - k;
+ cgeru_(&i__1, nrhs, &c_b1, &a[k + 1 + (k - 1) * a_dim1], &
+ c__1, &b[k - 1 + b_dim1], ldb, &b[k + 1 + b_dim1],
+ ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ k += -2;
+ }
+ goto L40;
+L60:
+ ;
+ }
+/* ---------------------------------------- */
+
+/* Compute B := A' * B (transpose) */
+
+/* ---------------------------------------- */
+ } else if (lsame_(trans, "T")) {
+
+/* Form B := U'*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+/* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop backward applying the transformations. */
+
+ k = *n;
+L70:
+ if (k < 1) {
+ goto L90;
+ }
+
+/* 1 x 1 pivot block. */
+
+ if (ipiv[k] > 0) {
+ if (k > 1) {
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ i__1 = k - 1;
+ cgemv_("Transpose", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[k * a_dim1 + 1], &c__1, &c_b1, &b[k + b_dim1],
+ ldb);
+ }
+ if (nounit) {
+ cscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+ --k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ if (k > 2) {
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k - 1) {
+ cswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformations */
+
+ i__1 = k - 2;
+ cgemv_("Transpose", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[k * a_dim1 + 1], &c__1, &c_b1, &b[k + b_dim1],
+ ldb);
+ i__1 = k - 2;
+ cgemv_("Transpose", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[(k - 1) * a_dim1 + 1], &c__1, &c_b1, &b[k - 1
+ + b_dim1], ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = k + k * a_dim1;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = k - 1 + k * a_dim1;
+ d12.r = a[i__1].r, d12.i = a[i__1].i;
+ d21.r = d12.r, d21.i = d12.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k - 1 + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k - 1 + j * b_dim1;
+ q__2.r = d11.r * t1.r - d11.i * t1.i, q__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ q__3.r = d12.r * t2.r - d12.i * t2.i, q__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + j * b_dim1;
+ q__2.r = d21.r * t1.r - d21.i * t1.i, q__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ q__3.r = d22.r * t2.r - d22.i * t2.i, q__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L80: */
+ }
+ }
+ k += -2;
+ }
+ goto L70;
+L90:
+
+/* Form B := L'*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) */
+/* and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1) */
+
+ ;
+ } else {
+
+/* Loop forward applying the L-transformations. */
+
+ k = 1;
+L100:
+ if (k > *n) {
+ goto L120;
+ }
+
+/* 1 x 1 pivot block */
+
+ if (ipiv[k] > 0) {
+ if (k < *n) {
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ i__1 = *n - k;
+ cgemv_("Transpose", &i__1, nrhs, &c_b1, &b[k + 1 + b_dim1]
+, ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, &b[k
+ + b_dim1], ldb);
+ }
+ if (nounit) {
+ cscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+ ++k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ if (k < *n - 1) {
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k + 1) {
+ cswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ i__1 = *n - k - 1;
+ cgemv_("Transpose", &i__1, nrhs, &c_b1, &b[k + 2 + b_dim1]
+, ldb, &a[k + 2 + (k + 1) * a_dim1], &c__1, &c_b1,
+ &b[k + 1 + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ cgemv_("Transpose", &i__1, nrhs, &c_b1, &b[k + 2 + b_dim1]
+, ldb, &a[k + 2 + k * a_dim1], &c__1, &c_b1, &b[k
+ + b_dim1], ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ i__1 = k + k * a_dim1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = k + 1 + k * a_dim1;
+ d21.r = a[i__1].r, d21.i = a[i__1].i;
+ d12.r = d21.r, d12.i = d21.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + 1 + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ q__2.r = d11.r * t1.r - d11.i * t1.i, q__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ q__3.r = d12.r * t2.r - d12.i * t2.i, q__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ q__2.r = d21.r * t1.r - d21.i * t1.i, q__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ q__3.r = d22.r * t2.r - d22.i * t2.i, q__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+/* L110: */
+ }
+ }
+ k += 2;
+ }
+ goto L100;
+L120:
+ ;
+ }
+ }
+ return 0;
+
+/* End of CLAVSY */
+
+} /* clavsy_ */
diff --git a/TESTING/LIN/clqt01.c b/TESTING/LIN/clqt01.c
new file mode 100644
index 0000000..3f3d60a
--- /dev/null
+++ b/TESTING/LIN/clqt01.c
@@ -0,0 +1,226 @@
+/* clqt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static complex c_b1 = {-1e10f,-1e10f};
+static complex c_b10 = {0.f,0.f};
+static complex c_b15 = {-1.f,0.f};
+static complex c_b16 = {1.f,0.f};
+static real c_b24 = -1.f;
+static real c_b25 = 1.f;
+
+/* Subroutine */ int clqt01_(integer *m, integer *n, complex *a, complex *af,
+ complex *q, complex *l, integer *lda, complex *tau, complex *work,
+ integer *lwork, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
+ q_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real eps;
+ integer info;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), cherk_(char *,
+ char *, integer *, integer *, real *, complex *, integer *, real *
+, complex *, integer *);
+ real resid, anorm;
+ integer minmn;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int cgelqf_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *);
+ extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
+ real *);
+ extern /* Subroutine */ int cunglq_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLQT01 tests CGELQF, which computes the LQ factorization of an m-by-n */
+/* matrix A, and partially tests CUNGLQ which forms the n-by-n */
+/* orthogonal matrix Q. */
+
+/* CLQT01 compares L with A*Q', and checks that Q is orthogonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The m-by-n matrix A. */
+
+/* AF (output) COMPLEX array, dimension (LDA,N) */
+/* Details of the LQ factorization of A, as returned by CGELQF. */
+/* See CGELQF for further details. */
+
+/* Q (output) COMPLEX array, dimension (LDA,N) */
+/* The n-by-n orthogonal matrix Q. */
+
+/* L (workspace) COMPLEX array, dimension (LDA,max(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and L. */
+/* LDA >= max(M,N). */
+
+/* TAU (output) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by CGELQF. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) REAL array, dimension (max(M,N)) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ l_dim1 = *lda;
+ l_offset = 1 + l_dim1;
+ l -= l_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ minmn = min(*m,*n);
+ eps = slamch_("Epsilon");
+
+/* Copy the matrix A to the array AF. */
+
+ clacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+
+/* Factorize the matrix A in the array AF. */
+
+ s_copy(srnamc_1.srnamt, "CGELQF", (ftnlen)32, (ftnlen)6);
+ cgelqf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy details of Q */
+
+ claset_("Full", n, n, &c_b1, &c_b1, &q[q_offset], lda);
+ if (*n > 1) {
+ i__1 = *n - 1;
+ clacpy_("Upper", m, &i__1, &af[(af_dim1 << 1) + 1], lda, &q[(q_dim1 <<
+ 1) + 1], lda);
+ }
+
+/* Generate the n-by-n matrix Q */
+
+ s_copy(srnamc_1.srnamt, "CUNGLQ", (ftnlen)32, (ftnlen)6);
+ cunglq_(n, n, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy L */
+
+ claset_("Full", m, n, &c_b10, &c_b10, &l[l_offset], lda);
+ clacpy_("Lower", m, n, &af[af_offset], lda, &l[l_offset], lda);
+
+/* Compute L - A*Q' */
+
+ cgemm_("No transpose", "Conjugate transpose", m, n, n, &c_b15, &a[
+ a_offset], lda, &q[q_offset], lda, &c_b16, &l[l_offset], lda);
+
+/* Compute norm( L - Q'*A ) / ( N * norm(A) * EPS ) . */
+
+ anorm = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ resid = clange_("1", m, n, &l[l_offset], lda, &rwork[1]);
+ if (anorm > 0.f) {
+ result[1] = resid / (real) max(1,*n) / anorm / eps;
+ } else {
+ result[1] = 0.f;
+ }
+
+/* Compute I - Q*Q' */
+
+ claset_("Full", n, n, &c_b10, &c_b16, &l[l_offset], lda);
+ cherk_("Upper", "No transpose", n, n, &c_b24, &q[q_offset], lda, &c_b25, &
+ l[l_offset], lda);
+
+/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
+
+ resid = clansy_("1", "Upper", n, &l[l_offset], lda, &rwork[1]);
+
+ result[2] = resid / (real) max(1,*n) / eps;
+
+ return 0;
+
+/* End of CLQT01 */
+
+} /* clqt01_ */
diff --git a/TESTING/LIN/clqt02.c b/TESTING/LIN/clqt02.c
new file mode 100644
index 0000000..bdce948
--- /dev/null
+++ b/TESTING/LIN/clqt02.c
@@ -0,0 +1,216 @@
+/* clqt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static complex c_b1 = {-1e10f,-1e10f};
+static complex c_b8 = {0.f,0.f};
+static complex c_b13 = {-1.f,0.f};
+static complex c_b14 = {1.f,0.f};
+static real c_b22 = -1.f;
+static real c_b23 = 1.f;
+
+/* Subroutine */ int clqt02_(integer *m, integer *n, integer *k, complex *a,
+ complex *af, complex *q, complex *l, integer *lda, complex *tau,
+ complex *work, integer *lwork, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
+ q_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real eps;
+ integer info;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), cherk_(char *,
+ char *, integer *, integer *, real *, complex *, integer *, real *
+, complex *, integer *);
+ real resid, anorm;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *);
+ extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
+ real *);
+ extern /* Subroutine */ int cunglq_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLQT02 tests CUNGLQ, which generates an m-by-n matrix Q with */
+/* orthonornmal rows that is defined as the product of k elementary */
+/* reflectors. */
+
+/* Given the LQ factorization of an m-by-n matrix A, CLQT02 generates */
+/* the orthogonal matrix Q defined by the factorization of the first k */
+/* rows of A; it compares L(1:k,1:m) with A(1:k,1:n)*Q(1:m,1:n)', and */
+/* checks that the rows of Q are orthonormal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q to be generated. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q to be generated. */
+/* N >= M >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The m-by-n matrix A which was factorized by CLQT01. */
+
+/* AF (input) COMPLEX array, dimension (LDA,N) */
+/* Details of the LQ factorization of A, as returned by CGELQF. */
+/* See CGELQF for further details. */
+
+/* Q (workspace) COMPLEX array, dimension (LDA,N) */
+
+/* L (workspace) COMPLEX array, dimension (LDA,M) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and L. LDA >= N. */
+
+/* TAU (input) COMPLEX array, dimension (M) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the LQ factorization in AF. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ l_dim1 = *lda;
+ l_offset = 1 + l_dim1;
+ l -= l_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ eps = slamch_("Epsilon");
+
+/* Copy the first k rows of the factorization to the array Q */
+
+ claset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
+ i__1 = *n - 1;
+ clacpy_("Upper", k, &i__1, &af[(af_dim1 << 1) + 1], lda, &q[(q_dim1 << 1)
+ + 1], lda);
+
+/* Generate the first n columns of the matrix Q */
+
+ s_copy(srnamc_1.srnamt, "CUNGLQ", (ftnlen)32, (ftnlen)6);
+ cunglq_(m, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy L(1:k,1:m) */
+
+ claset_("Full", k, m, &c_b8, &c_b8, &l[l_offset], lda);
+ clacpy_("Lower", k, m, &af[af_offset], lda, &l[l_offset], lda);
+
+/* Compute L(1:k,1:m) - A(1:k,1:n) * Q(1:m,1:n)' */
+
+ cgemm_("No transpose", "Conjugate transpose", k, m, n, &c_b13, &a[
+ a_offset], lda, &q[q_offset], lda, &c_b14, &l[l_offset], lda);
+
+/* Compute norm( L - A*Q' ) / ( N * norm(A) * EPS ) . */
+
+ anorm = clange_("1", k, n, &a[a_offset], lda, &rwork[1]);
+ resid = clange_("1", k, m, &l[l_offset], lda, &rwork[1]);
+ if (anorm > 0.f) {
+ result[1] = resid / (real) max(1,*n) / anorm / eps;
+ } else {
+ result[1] = 0.f;
+ }
+
+/* Compute I - Q*Q' */
+
+ claset_("Full", m, m, &c_b8, &c_b14, &l[l_offset], lda);
+ cherk_("Upper", "No transpose", m, n, &c_b22, &q[q_offset], lda, &c_b23, &
+ l[l_offset], lda);
+
+/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
+
+ resid = clansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
+
+ result[2] = resid / (real) max(1,*n) / eps;
+
+ return 0;
+
+/* End of CLQT02 */
+
+} /* clqt02_ */
diff --git a/TESTING/LIN/clqt03.c b/TESTING/LIN/clqt03.c
new file mode 100644
index 0000000..c5e5e2c
--- /dev/null
+++ b/TESTING/LIN/clqt03.c
@@ -0,0 +1,259 @@
+/* clqt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static complex c_b1 = {-1e10f,-1e10f};
+static integer c__2 = 2;
+static complex c_b20 = {-1.f,0.f};
+static complex c_b21 = {1.f,0.f};
+
+/* Subroutine */ int clqt03_(integer *m, integer *n, integer *k, complex *af,
+ complex *c__, complex *cc, complex *q, integer *lda, complex *tau,
+ complex *work, integer *lwork, real *rwork, real *result)
+{
+ /* Initialized data */
+
+ static integer iseed[4] = { 1988,1989,1990,1991 };
+
+ /* System generated locals */
+ integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1,
+ q_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j, mc, nc;
+ real eps;
+ char side[1];
+ integer info;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ integer iside;
+ extern logical lsame_(char *, char *);
+ real resid, cnorm;
+ char trans[1];
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), clarnv_(integer *, integer *, integer *, complex *),
+ cunglq_(integer *, integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *, integer *), cunmlq_(char *, char
+ *, integer *, integer *, integer *, complex *, integer *, complex
+ *, complex *, integer *, complex *, integer *, integer *);
+ integer itrans;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLQT03 tests CUNMLQ, which computes Q*C, Q'*C, C*Q or C*Q'. */
+
+/* CLQT03 compares the results of a call to CUNMLQ with the results of */
+/* forming Q explicitly by a call to CUNGLQ and then performing matrix */
+/* multiplication by a call to CGEMM. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows or columns of the matrix C; C is n-by-m if */
+/* Q is applied from the left, or m-by-n if Q is applied from */
+/* the right. M >= 0. */
+
+/* N (input) INTEGER */
+/* The order of the orthogonal matrix Q. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* orthogonal matrix Q. N >= K >= 0. */
+
+/* AF (input) COMPLEX array, dimension (LDA,N) */
+/* Details of the LQ factorization of an m-by-n matrix, as */
+/* returned by CGELQF. See CGELQF for further details. */
+
+/* C (workspace) COMPLEX array, dimension (LDA,N) */
+
+/* CC (workspace) COMPLEX array, dimension (LDA,N) */
+
+/* Q (workspace) COMPLEX array, dimension (LDA,N) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays AF, C, CC, and Q. */
+
+/* TAU (input) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the LQ factorization in AF. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK must be at least M, and should be */
+/* M*NB, where NB is the blocksize for this environment. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (4) */
+/* The test ratios compare two techniques for multiplying a */
+/* random matrix C by an n-by-n orthogonal matrix Q. */
+/* RESULT(1) = norm( Q*C - Q*C ) / ( N * norm(C) * EPS ) */
+/* RESULT(2) = norm( C*Q - C*Q ) / ( N * norm(C) * EPS ) */
+/* RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS ) */
+/* RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ cc_dim1 = *lda;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+ c_dim1 = *lda;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = slamch_("Epsilon");
+
+/* Copy the first k rows of the factorization to the array Q */
+
+ claset_("Full", n, n, &c_b1, &c_b1, &q[q_offset], lda);
+ i__1 = *n - 1;
+ clacpy_("Upper", k, &i__1, &af[(af_dim1 << 1) + 1], lda, &q[(q_dim1 << 1)
+ + 1], lda);
+
+/* Generate the n-by-n matrix Q */
+
+ s_copy(srnamc_1.srnamt, "CUNGLQ", (ftnlen)32, (ftnlen)6);
+ cunglq_(n, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+ for (iside = 1; iside <= 2; ++iside) {
+ if (iside == 1) {
+ *(unsigned char *)side = 'L';
+ mc = *n;
+ nc = *m;
+ } else {
+ *(unsigned char *)side = 'R';
+ mc = *m;
+ nc = *n;
+ }
+
+/* Generate MC by NC matrix C */
+
+ i__1 = nc;
+ for (j = 1; j <= i__1; ++j) {
+ clarnv_(&c__2, iseed, &mc, &c__[j * c_dim1 + 1]);
+/* L10: */
+ }
+ cnorm = clange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]);
+ if (cnorm == 0.f) {
+ cnorm = 1.f;
+ }
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+ if (itrans == 1) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'C';
+ }
+
+/* Copy C */
+
+ clacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
+ lda);
+
+/* Apply Q or Q' to C */
+
+ s_copy(srnamc_1.srnamt, "CUNMLQ", (ftnlen)32, (ftnlen)6);
+ cunmlq_(side, trans, &mc, &nc, k, &af[af_offset], lda, &tau[1], &
+ cc[cc_offset], lda, &work[1], lwork, &info);
+
+/* Form explicit product and subtract */
+
+ if (lsame_(side, "L")) {
+ cgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b20, &q[
+ q_offset], lda, &c__[c_offset], lda, &c_b21, &cc[
+ cc_offset], lda);
+ } else {
+ cgemm_("No transpose", trans, &mc, &nc, &nc, &c_b20, &c__[
+ c_offset], lda, &q[q_offset], lda, &c_b21, &cc[
+ cc_offset], lda);
+ }
+
+/* Compute error in the difference */
+
+ resid = clange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
+ result[(iside - 1 << 1) + itrans] = resid / ((real) max(1,*n) *
+ cnorm * eps);
+
+/* L20: */
+ }
+/* L30: */
+ }
+
+ return 0;
+
+/* End of CLQT03 */
+
+} /* clqt03_ */
diff --git a/TESTING/LIN/cpbt01.c b/TESTING/LIN/cpbt01.c
new file mode 100644
index 0000000..fcd4263
--- /dev/null
+++ b/TESTING/LIN/cpbt01.c
@@ -0,0 +1,284 @@
+/* cpbt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b17 = 1.f;
+
+/* Subroutine */ int cpbt01_(char *uplo, integer *n, integer *kd, complex *a,
+ integer *lda, complex *afac, integer *ldafac, real *rwork, real *
+ resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3, i__4,
+ i__5;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k, kc, ml, mu;
+ real akk, eps;
+ extern /* Subroutine */ int cher_(char *, integer *, real *, complex *,
+ integer *, complex *, integer *);
+ integer klen;
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
+ complex *, integer *, complex *, integer *);
+ extern doublereal clanhb_(char *, char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPBT01 reconstructs a Hermitian positive definite band matrix A from */
+/* its L*L' or U'*U factorization and computes the residual */
+/* norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
+/* norm( U'*U - A ) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon, L' is the conjugate transpose of */
+/* L, and U' is the conjugate transpose of U. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The original Hermitian band matrix A. If UPLO = 'U', the */
+/* upper triangular part of A is stored as a band matrix; if */
+/* UPLO = 'L', the lower triangular part of A is stored. The */
+/* columns of the appropriate triangle are stored in the columns */
+/* of A and the diagonals of the triangle are stored in the rows */
+/* of A. See CPBTRF for further details. */
+
+/* LDA (input) INTEGER. */
+/* The leading dimension of the array A. LDA >= max(1,KD+1). */
+
+/* AFAC (input) COMPLEX array, dimension (LDAFAC,N) */
+/* The factored form of the matrix A. AFAC contains the factor */
+/* L or U from the L*L' or U'*U factorization in band storage */
+/* format, as computed by CPBTRF. */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. */
+/* LDAFAC >= max(1,KD+1). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
+/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = clanhb_("1", uplo, n, kd, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Check the imaginary parts of the diagonal elements and return with */
+/* an error code if any are nonzero. */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (r_imag(&afac[*kd + 1 + j * afac_dim1]) != 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (r_imag(&afac[j * afac_dim1 + 1]) != 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+/* L20: */
+ }
+ }
+
+/* Compute the product U'*U, overwriting U. */
+
+ if (lsame_(uplo, "U")) {
+ for (k = *n; k >= 1; --k) {
+/* Computing MAX */
+ i__1 = 1, i__2 = *kd + 2 - k;
+ kc = max(i__1,i__2);
+ klen = *kd + 1 - kc;
+
+/* Compute the (K,K) element of the result. */
+
+ i__1 = klen + 1;
+ cdotc_(&q__1, &i__1, &afac[kc + k * afac_dim1], &c__1, &afac[kc +
+ k * afac_dim1], &c__1);
+ akk = q__1.r;
+ i__1 = *kd + 1 + k * afac_dim1;
+ afac[i__1].r = akk, afac[i__1].i = 0.f;
+
+/* Compute the rest of column K. */
+
+ if (klen > 0) {
+ i__1 = *ldafac - 1;
+ ctrmv_("Upper", "Conjugate", "Non-unit", &klen, &afac[*kd + 1
+ + (k - klen) * afac_dim1], &i__1, &afac[kc + k *
+ afac_dim1], &c__1);
+ }
+
+/* L30: */
+ }
+
+/* UPLO = 'L': Compute the product L*L', overwriting L. */
+
+ } else {
+ for (k = *n; k >= 1; --k) {
+/* Computing MIN */
+ i__1 = *kd, i__2 = *n - k;
+ klen = min(i__1,i__2);
+
+/* Add a multiple of column K of the factor L to each of */
+/* columns K+1 through N. */
+
+ if (klen > 0) {
+ i__1 = *ldafac - 1;
+ cher_("Lower", &klen, &c_b17, &afac[k * afac_dim1 + 2], &c__1,
+ &afac[(k + 1) * afac_dim1 + 1], &i__1);
+ }
+
+/* Scale column K by the diagonal element. */
+
+ i__1 = k * afac_dim1 + 1;
+ akk = afac[i__1].r;
+ i__1 = klen + 1;
+ csscal_(&i__1, &akk, &afac[k * afac_dim1 + 1], &c__1);
+
+/* L40: */
+ }
+ }
+
+/* Compute the difference L*L' - A or U'*U - A. */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = 1, i__3 = *kd + 2 - j;
+ mu = max(i__2,i__3);
+ i__2 = *kd + 1;
+ for (i__ = mu; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * afac_dim1;
+ i__4 = i__ + j * afac_dim1;
+ i__5 = i__ + j * a_dim1;
+ q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
+ i__5].i;
+ afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *kd + 1, i__3 = *n - j + 1;
+ ml = min(i__2,i__3);
+ i__2 = ml;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * afac_dim1;
+ i__4 = i__ + j * afac_dim1;
+ i__5 = i__ + j * a_dim1;
+ q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
+ i__5].i;
+ afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+
+/* Compute norm( L*L' - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = clanhb_("1", uplo, n, kd, &afac[afac_offset], ldafac, &rwork[1]);
+
+ *resid = *resid / (real) (*n) / anorm / eps;
+
+ return 0;
+
+/* End of CPBT01 */
+
+} /* cpbt01_ */
diff --git a/TESTING/LIN/cpbt02.c b/TESTING/LIN/cpbt02.c
new file mode 100644
index 0000000..ce49e8d
--- /dev/null
+++ b/TESTING/LIN/cpbt02.c
@@ -0,0 +1,182 @@
+/* cpbt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cpbt02_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, complex *a, integer *lda, complex *x, integer *ldx, complex *b,
+ integer *ldb, real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Local variables */
+ integer j;
+ real eps;
+ extern /* Subroutine */ int chbmv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *);
+ real anorm, bnorm, xnorm;
+ extern doublereal clanhb_(char *, char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *),
+ scasum_(integer *, complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPBT02 computes the residual for a solution of a Hermitian banded */
+/* system of equations A*x = b: */
+/* RESID = norm( B - A*X ) / ( norm(A) * norm(X) * EPS) */
+/* where EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The original Hermitian band matrix A. If UPLO = 'U', the */
+/* upper triangular part of A is stored as a band matrix; if */
+/* UPLO = 'L', the lower triangular part of A is stored. The */
+/* columns of the appropriate triangle are stored in the columns */
+/* of A and the diagonals of the triangle are stored in the rows */
+/* of A. See CPBTRF for further details. */
+
+/* LDA (input) INTEGER. */
+/* The leading dimension of the array A. LDA >= max(1,KD+1). */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = clanhb_("1", uplo, n, kd, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute B - A*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ q__1.r = -1.f, q__1.i = -0.f;
+ chbmv_(uplo, n, kd, &q__1, &a[a_offset], lda, &x[j * x_dim1 + 1], &
+ c__1, &c_b1, &b[j * b_dim1 + 1], &c__1);
+/* L10: */
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = scasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = scasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L20: */
+ }
+
+ return 0;
+
+/* End of CPBT02 */
+
+} /* cpbt02_ */
diff --git a/TESTING/LIN/cpbt05.c b/TESTING/LIN/cpbt05.c
new file mode 100644
index 0000000..572bf85
--- /dev/null
+++ b/TESTING/LIN/cpbt05.c
@@ -0,0 +1,334 @@
+/* cpbt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cpbt05_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, complex *ab, integer *ldab, complex *b, integer *ldb, complex *
+ x, integer *ldx, complex *xact, integer *ldxact, real *ferr, real *
+ berr, real *reslts)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k, nz;
+ real eps, tmp, diff, axbi;
+ integer imax;
+ real unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ real xnorm;
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ real errbnd;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPBT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* Hermitian band matrix. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+/* and NZ = max. number of nonzeros in any row of A, plus 1 */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* The upper or lower triangle of the Hermitian band matrix A, */
+/* stored in the first KD+1 rows of the array. The j-th column */
+/* of A is stored in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) REAL array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) REAL array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.f;
+ reslts[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ upper = lsame_(uplo, "U");
+/* Computing MAX */
+ i__1 = *kd, i__2 = *n - 1;
+ nz = (max(i__1,i__2) << 1) + 1;
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = icamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__2 = imax + j * x_dim1;
+ r__3 = (r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x[imax + j *
+ x_dim1]), dabs(r__2));
+ xnorm = dmax(r__3,unfl);
+ diff = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * xact_dim1;
+ q__2.r = x[i__3].r - xact[i__4].r, q__2.i = x[i__3].i - xact[i__4]
+ .i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+/* Computing MAX */
+ r__3 = diff, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
+ q__1), dabs(r__2));
+ diff = dmax(r__3,r__4);
+/* L10: */
+ }
+
+ if (xnorm > 1.f) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1.f / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
+ errbnd = dmax(r__1,r__2);
+ } else {
+ errbnd = 1.f / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ tmp = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[i__ + k *
+ b_dim1]), dabs(r__2));
+ if (upper) {
+/* Computing MAX */
+ i__3 = i__ - *kd;
+ i__4 = i__ - 1;
+ for (j = max(i__3,1); j <= i__4; ++j) {
+ i__3 = *kd + 1 - i__ + j + i__ * ab_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = ab[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ ab[*kd + 1 - i__ + j + i__ * ab_dim1]), dabs(r__2)
+ )) * ((r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
+ r_imag(&x[j + k * x_dim1]), dabs(r__4)));
+/* L40: */
+ }
+ i__4 = *kd + 1 + i__ * ab_dim1;
+ i__3 = i__ + k * x_dim1;
+ tmp += (r__1 = ab[i__4].r, dabs(r__1)) * ((r__2 = x[i__3].r,
+ dabs(r__2)) + (r__3 = r_imag(&x[i__ + k * x_dim1]),
+ dabs(r__3)));
+/* Computing MIN */
+ i__3 = i__ + *kd;
+ i__4 = min(i__3,*n);
+ for (j = i__ + 1; j <= i__4; ++j) {
+ i__3 = *kd + 1 + i__ - j + j * ab_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = ab[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
+ ab[*kd + 1 + i__ - j + j * ab_dim1]), dabs(r__2)))
+ * ((r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
+ r_imag(&x[j + k * x_dim1]), dabs(r__4)));
+/* L50: */
+ }
+ } else {
+/* Computing MAX */
+ i__4 = i__ - *kd;
+ i__3 = i__ - 1;
+ for (j = max(i__4,1); j <= i__3; ++j) {
+ i__4 = i__ + 1 - j + j * ab_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = ab[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
+ ab[i__ + 1 - j + j * ab_dim1]), dabs(r__2))) * ((
+ r__3 = x[i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[
+ j + k * x_dim1]), dabs(r__4)));
+/* L60: */
+ }
+ i__3 = i__ * ab_dim1 + 1;
+ i__4 = i__ + k * x_dim1;
+ tmp += (r__1 = ab[i__3].r, dabs(r__1)) * ((r__2 = x[i__4].r,
+ dabs(r__2)) + (r__3 = r_imag(&x[i__ + k * x_dim1]),
+ dabs(r__3)));
+/* Computing MIN */
+ i__4 = i__ + *kd;
+ i__3 = min(i__4,*n);
+ for (j = i__ + 1; j <= i__3; ++j) {
+ i__4 = j + 1 - i__ + i__ * ab_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = ab[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
+ ab[j + 1 - i__ + i__ * ab_dim1]), dabs(r__2))) * (
+ (r__3 = x[i__5].r, dabs(r__3)) + (r__4 = r_imag(&
+ x[j + k * x_dim1]), dabs(r__4)));
+/* L70: */
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = dmin(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ r__1 = axbi, r__2 = nz * unfl;
+ tmp = berr[k] / (nz * eps + nz * unfl / dmax(r__1,r__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = dmax(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of CPBT05 */
+
+} /* cpbt05_ */
diff --git a/TESTING/LIN/cpot01.c b/TESTING/LIN/cpot01.c
new file mode 100644
index 0000000..5dcf5b2
--- /dev/null
+++ b/TESTING/LIN/cpot01.c
@@ -0,0 +1,257 @@
+/* cpot01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b15 = 1.f;
+
+/* Subroutine */ int cpot01_(char *uplo, integer *n, complex *a, integer *lda,
+ complex *afac, integer *ldafac, real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3, i__4,
+ i__5;
+ real r__1;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ complex tc;
+ real tr, eps;
+ extern /* Subroutine */ int cher_(char *, integer *, real *, complex *,
+ integer *, complex *, integer *), cscal_(integer *,
+ complex *, complex *, integer *);
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
+ complex *, integer *, complex *, integer *);
+ extern doublereal clanhe_(char *, char *, integer *, complex *, integer *,
+ real *), slamch_(char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPOT01 reconstructs a Hermitian positive definite matrix A from */
+/* its L*L' or U'*U factorization and computes the residual */
+/* norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
+/* norm( U'*U - A ) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon, L' is the conjugate transpose of L, */
+/* and U' is the conjugate transpose of U. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The original Hermitian matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* AFAC (input/output) COMPLEX array, dimension (LDAFAC,N) */
+/* On entry, the factor L or U from the L*L' or U'*U */
+/* factorization of A. */
+/* Overwritten with the reconstructed matrix, and then with the */
+/* difference L*L' - A (or U'*U - A). */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
+/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = clanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Check the imaginary parts of the diagonal elements and return with */
+/* an error code if any are nonzero. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (r_imag(&afac[j + j * afac_dim1]) != 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+/* L10: */
+ }
+
+/* Compute the product U'*U, overwriting U. */
+
+ if (lsame_(uplo, "U")) {
+ for (k = *n; k >= 1; --k) {
+
+/* Compute the (K,K) element of the result. */
+
+ cdotc_(&q__1, &k, &afac[k * afac_dim1 + 1], &c__1, &afac[k *
+ afac_dim1 + 1], &c__1);
+ tr = q__1.r;
+ i__1 = k + k * afac_dim1;
+ afac[i__1].r = tr, afac[i__1].i = 0.f;
+
+/* Compute the rest of column K. */
+
+ i__1 = k - 1;
+ ctrmv_("Upper", "Conjugate", "Non-unit", &i__1, &afac[afac_offset]
+, ldafac, &afac[k * afac_dim1 + 1], &c__1);
+
+/* L20: */
+ }
+
+/* Compute the product L*L', overwriting L. */
+
+ } else {
+ for (k = *n; k >= 1; --k) {
+
+/* Add a multiple of column K of the factor L to each of */
+/* columns K+1 through N. */
+
+ if (k + 1 <= *n) {
+ i__1 = *n - k;
+ cher_("Lower", &i__1, &c_b15, &afac[k + 1 + k * afac_dim1], &
+ c__1, &afac[k + 1 + (k + 1) * afac_dim1], ldafac);
+ }
+
+/* Scale column K by the diagonal element. */
+
+ i__1 = k + k * afac_dim1;
+ tc.r = afac[i__1].r, tc.i = afac[i__1].i;
+ i__1 = *n - k + 1;
+ cscal_(&i__1, &tc, &afac[k + k * afac_dim1], &c__1);
+
+/* L30: */
+ }
+ }
+
+/* Compute the difference L*L' - A (or U'*U - A). */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * afac_dim1;
+ i__4 = i__ + j * afac_dim1;
+ i__5 = i__ + j * a_dim1;
+ q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
+ i__5].i;
+ afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
+/* L40: */
+ }
+ i__2 = j + j * afac_dim1;
+ i__3 = j + j * afac_dim1;
+ i__4 = j + j * a_dim1;
+ r__1 = a[i__4].r;
+ q__1.r = afac[i__3].r - r__1, q__1.i = afac[i__3].i;
+ afac[i__2].r = q__1.r, afac[i__2].i = q__1.i;
+/* L50: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * afac_dim1;
+ i__3 = j + j * afac_dim1;
+ i__4 = j + j * a_dim1;
+ r__1 = a[i__4].r;
+ q__1.r = afac[i__3].r - r__1, q__1.i = afac[i__3].i;
+ afac[i__2].r = q__1.r, afac[i__2].i = q__1.i;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * afac_dim1;
+ i__4 = i__ + j * afac_dim1;
+ i__5 = i__ + j * a_dim1;
+ q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
+ i__5].i;
+ afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
+/* L60: */
+ }
+/* L70: */
+ }
+ }
+
+/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = clanhe_("1", uplo, n, &afac[afac_offset], ldafac, &rwork[1]);
+
+ *resid = *resid / (real) (*n) / anorm / eps;
+
+ return 0;
+
+/* End of CPOT01 */
+
+} /* cpot01_ */
diff --git a/TESTING/LIN/cpot02.c b/TESTING/LIN/cpot02.c
new file mode 100644
index 0000000..43b8903
--- /dev/null
+++ b/TESTING/LIN/cpot02.c
@@ -0,0 +1,175 @@
+/* cpot02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cpot02_(char *uplo, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *x, integer *ldx, complex *b, integer *ldb,
+ real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Local variables */
+ integer j;
+ real eps;
+ extern /* Subroutine */ int chemm_(char *, char *, integer *, integer *,
+ complex *, complex *, integer *, complex *, integer *, complex *,
+ complex *, integer *);
+ real anorm, bnorm, xnorm;
+ extern doublereal clanhe_(char *, char *, integer *, complex *, integer *,
+ real *), slamch_(char *), scasum_(
+ integer *, complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPOT02 computes the residual for the solution of a Hermitian system */
+/* of linear equations A*x = b: */
+
+/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ), */
+
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The original Hermitian matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = clanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute B - A*X */
+
+ q__1.r = -1.f, q__1.i = -0.f;
+ chemm_("Left", uplo, n, nrhs, &q__1, &a[a_offset], lda, &x[x_offset], ldx,
+ &c_b1, &b[b_offset], ldb);
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = scasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = scasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of CPOT02 */
+
+} /* cpot02_ */
diff --git a/TESTING/LIN/cpot03.c b/TESTING/LIN/cpot03.c
new file mode 100644
index 0000000..4963764
--- /dev/null
+++ b/TESTING/LIN/cpot03.c
@@ -0,0 +1,206 @@
+/* cpot03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+
+/* Subroutine */ int cpot03_(char *uplo, integer *n, complex *a, integer *lda,
+ complex *ainv, integer *ldainv, complex *work, integer *ldwork, real
+ *rwork, real *rcond, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, ainv_dim1, ainv_offset, work_dim1, work_offset,
+ i__1, i__2, i__3;
+ complex q__1;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j;
+ real eps;
+ extern /* Subroutine */ int chemm_(char *, char *, integer *, integer *,
+ complex *, complex *, integer *, complex *, integer *, complex *,
+ complex *, integer *);
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), clanhe_(char *, char *, integer *,
+ complex *, integer *, real *), slamch_(char *);
+ real ainvnm;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPOT03 computes the residual for a Hermitian matrix times its */
+/* inverse: */
+/* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The original Hermitian matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* AINV (input/output) COMPLEX array, dimension (LDAINV,N) */
+/* On entry, the inverse of the matrix A, stored as a Hermitian */
+/* matrix in the same format as A. */
+/* In this version, AINV is expanded into a full matrix and */
+/* multiplied by A, so the opposing triangle of AINV will be */
+/* changed; i.e., if the upper triangular part of AINV is */
+/* stored, the lower triangular part will be used as work space. */
+
+/* LDAINV (input) INTEGER */
+/* The leading dimension of the array AINV. LDAINV >= max(1,N). */
+
+/* WORK (workspace) COMPLEX array, dimension (LDWORK,N) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RCOND (output) REAL */
+/* The reciprocal of the condition number of A, computed as */
+/* ( 1/norm(A) ) / norm(AINV). */
+
+/* RESID (output) REAL */
+/* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ ainv_dim1 = *ldainv;
+ ainv_offset = 1 + ainv_dim1;
+ ainv -= ainv_offset;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.f;
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = clanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+ ainvnm = clanhe_("1", uplo, n, &ainv[ainv_offset], ldainv, &rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ *rcond = 0.f;
+ *resid = 1.f / eps;
+ return 0;
+ }
+ *rcond = 1.f / anorm / ainvnm;
+
+/* Expand AINV into a full matrix and call CHEMM to multiply */
+/* AINV on the left by A. */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * ainv_dim1;
+ r_cnjg(&q__1, &ainv[i__ + j * ainv_dim1]);
+ ainv[i__3].r = q__1.r, ainv[i__3].i = q__1.i;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * ainv_dim1;
+ r_cnjg(&q__1, &ainv[i__ + j * ainv_dim1]);
+ ainv[i__3].r = q__1.r, ainv[i__3].i = q__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ q__1.r = -1.f, q__1.i = -0.f;
+ chemm_("Left", uplo, n, n, &q__1, &a[a_offset], lda, &ainv[ainv_offset],
+ ldainv, &c_b1, &work[work_offset], ldwork);
+
+/* Add the identity matrix to WORK . */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * work_dim1;
+ i__3 = i__ + i__ * work_dim1;
+ q__1.r = work[i__3].r + 1.f, q__1.i = work[i__3].i + 0.f;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L50: */
+ }
+
+/* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = clange_("1", n, n, &work[work_offset], ldwork, &rwork[1]);
+
+ *resid = *resid * *rcond / eps / (real) (*n);
+
+ return 0;
+
+/* End of CPOT03 */
+
+} /* cpot03_ */
diff --git a/TESTING/LIN/cpot05.c b/TESTING/LIN/cpot05.c
new file mode 100644
index 0000000..b2d5842
--- /dev/null
+++ b/TESTING/LIN/cpot05.c
@@ -0,0 +1,319 @@
+/* cpot05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cpot05_(char *uplo, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *b, integer *ldb, complex *x, integer *ldx,
+ complex *xact, integer *ldxact, real *ferr, real *berr, real *reslts)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ real eps, tmp, diff, axbi;
+ integer imax;
+ real unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ real xnorm;
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ real errbnd;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPOT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* Hermitian n by n matrix. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* 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. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) REAL array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) REAL array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.f;
+ reslts[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ upper = lsame_(uplo, "U");
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = icamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__2 = imax + j * x_dim1;
+ r__3 = (r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x[imax + j *
+ x_dim1]), dabs(r__2));
+ xnorm = dmax(r__3,unfl);
+ diff = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * xact_dim1;
+ q__2.r = x[i__3].r - xact[i__4].r, q__2.i = x[i__3].i - xact[i__4]
+ .i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+/* Computing MAX */
+ r__3 = diff, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
+ q__1), dabs(r__2));
+ diff = dmax(r__3,r__4);
+/* L10: */
+ }
+
+ if (xnorm > 1.f) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1.f / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
+ errbnd = dmax(r__1,r__2);
+ } else {
+ errbnd = 1.f / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ tmp = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[i__ + k *
+ b_dim1]), dabs(r__2));
+ if (upper) {
+ i__3 = i__ - 1;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j + i__ * a_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[j + i__ * a_dim1]), dabs(r__2))) * ((r__3 = x[
+ i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[j + k *
+ x_dim1]), dabs(r__4)));
+/* L40: */
+ }
+ i__3 = i__ + i__ * a_dim1;
+ i__4 = i__ + k * x_dim1;
+ tmp += (r__1 = a[i__3].r, dabs(r__1)) * ((r__2 = x[i__4].r,
+ dabs(r__2)) + (r__3 = r_imag(&x[i__ + k * x_dim1]),
+ dabs(r__3)));
+ i__3 = *n;
+ for (j = i__ + 1; j <= i__3; ++j) {
+ i__4 = i__ + j * a_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[i__ + j * a_dim1]), dabs(r__2))) * ((r__3 = x[
+ i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[j + k *
+ x_dim1]), dabs(r__4)));
+/* L50: */
+ }
+ } else {
+ i__3 = i__ - 1;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = i__ + j * a_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[i__ + j * a_dim1]), dabs(r__2))) * ((r__3 = x[
+ i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[j + k *
+ x_dim1]), dabs(r__4)));
+/* L60: */
+ }
+ i__3 = i__ + i__ * a_dim1;
+ i__4 = i__ + k * x_dim1;
+ tmp += (r__1 = a[i__3].r, dabs(r__1)) * ((r__2 = x[i__4].r,
+ dabs(r__2)) + (r__3 = r_imag(&x[i__ + k * x_dim1]),
+ dabs(r__3)));
+ i__3 = *n;
+ for (j = i__ + 1; j <= i__3; ++j) {
+ i__4 = j + i__ * a_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
+ a[j + i__ * a_dim1]), dabs(r__2))) * ((r__3 = x[
+ i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[j + k *
+ x_dim1]), dabs(r__4)));
+/* L70: */
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = dmin(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ r__1 = axbi, r__2 = (*n + 1) * unfl;
+ tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / dmax(r__1,r__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = dmax(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of CPOT05 */
+
+} /* cpot05_ */
diff --git a/TESTING/LIN/cppt01.c b/TESTING/LIN/cppt01.c
new file mode 100644
index 0000000..0a8529a
--- /dev/null
+++ b/TESTING/LIN/cppt01.c
@@ -0,0 +1,268 @@
+/* cppt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b19 = 1.f;
+
+/* Subroutine */ int cppt01_(char *uplo, integer *n, complex *a, complex *
+ afac, real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ real r__1;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, k, kc;
+ complex tc;
+ real tr, eps;
+ extern /* Subroutine */ int chpr_(char *, integer *, real *, complex *,
+ integer *, complex *), cscal_(integer *, complex *,
+ complex *, integer *);
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern /* Subroutine */ int ctpmv_(char *, char *, char *, integer *,
+ complex *, complex *, integer *);
+ extern doublereal clanhp_(char *, char *, integer *, complex *, real *), slamch_(char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPPT01 reconstructs a Hermitian positive definite packed matrix A */
+/* from its L*L' or U'*U factorization and computes the residual */
+/* norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
+/* norm( U'*U - A ) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon, L' is the conjugate transpose of */
+/* L, and U' is the conjugate transpose of U. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The original Hermitian matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* AFAC (input/output) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the factor L or U from the L*L' or U'*U */
+/* factorization of A, stored as a packed triangular matrix. */
+/* Overwritten with the reconstructed matrix, and then with the */
+/* difference L*L' - A (or U'*U - A). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
+/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 */
+
+ /* Parameter adjustments */
+ --rwork;
+ --afac;
+ --a;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = clanhp_("1", uplo, n, &a[1], &rwork[1]);
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Check the imaginary parts of the diagonal elements and return with */
+/* an error code if any are nonzero. */
+
+ kc = 1;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (r_imag(&afac[kc]) != 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+ kc = kc + k + 1;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (r_imag(&afac[kc]) != 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+ kc = kc + *n - k + 1;
+/* L20: */
+ }
+ }
+
+/* Compute the product U'*U, overwriting U. */
+
+ if (lsame_(uplo, "U")) {
+ kc = *n * (*n - 1) / 2 + 1;
+ for (k = *n; k >= 1; --k) {
+
+/* Compute the (K,K) element of the result. */
+
+ cdotc_(&q__1, &k, &afac[kc], &c__1, &afac[kc], &c__1);
+ tr = q__1.r;
+ i__1 = kc + k - 1;
+ afac[i__1].r = tr, afac[i__1].i = 0.f;
+
+/* Compute the rest of column K. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ ctpmv_("Upper", "Conjugate", "Non-unit", &i__1, &afac[1], &
+ afac[kc], &c__1);
+ kc -= k - 1;
+ }
+/* L30: */
+ }
+
+/* Compute the difference L*L' - A */
+
+ kc = 1;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = k - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = kc + i__ - 1;
+ i__4 = kc + i__ - 1;
+ i__5 = kc + i__ - 1;
+ q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
+ i__5].i;
+ afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
+/* L40: */
+ }
+ i__2 = kc + k - 1;
+ i__3 = kc + k - 1;
+ i__4 = kc + k - 1;
+ r__1 = a[i__4].r;
+ q__1.r = afac[i__3].r - r__1, q__1.i = afac[i__3].i;
+ afac[i__2].r = q__1.r, afac[i__2].i = q__1.i;
+ kc += k;
+/* L50: */
+ }
+
+/* Compute the product L*L', overwriting L. */
+
+ } else {
+ kc = *n * (*n + 1) / 2;
+ for (k = *n; k >= 1; --k) {
+
+/* Add a multiple of column K of the factor L to each of */
+/* columns K+1 through N. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ chpr_("Lower", &i__1, &c_b19, &afac[kc + 1], &c__1, &afac[kc
+ + *n - k + 1]);
+ }
+
+/* Scale column K by the diagonal element. */
+
+ i__1 = kc;
+ tc.r = afac[i__1].r, tc.i = afac[i__1].i;
+ i__1 = *n - k + 1;
+ cscal_(&i__1, &tc, &afac[kc], &c__1);
+
+ kc -= *n - k + 2;
+/* L60: */
+ }
+
+/* Compute the difference U'*U - A */
+
+ kc = 1;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = kc;
+ i__3 = kc;
+ i__4 = kc;
+ r__1 = a[i__4].r;
+ q__1.r = afac[i__3].r - r__1, q__1.i = afac[i__3].i;
+ afac[i__2].r = q__1.r, afac[i__2].i = q__1.i;
+ i__2 = *n;
+ for (i__ = k + 1; i__ <= i__2; ++i__) {
+ i__3 = kc + i__ - k;
+ i__4 = kc + i__ - k;
+ i__5 = kc + i__ - k;
+ q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
+ i__5].i;
+ afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
+/* L70: */
+ }
+ kc = kc + *n - k + 1;
+/* L80: */
+ }
+ }
+
+/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = clanhp_("1", uplo, n, &afac[1], &rwork[1]);
+
+ *resid = *resid / (real) (*n) / anorm / eps;
+
+ return 0;
+
+/* End of CPPT01 */
+
+} /* cppt01_ */
diff --git a/TESTING/LIN/cppt02.c b/TESTING/LIN/cppt02.c
new file mode 100644
index 0000000..85e36a7
--- /dev/null
+++ b/TESTING/LIN/cppt02.c
@@ -0,0 +1,174 @@
+/* cppt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cppt02_(char *uplo, integer *n, integer *nrhs, complex *
+ a, complex *x, integer *ldx, complex *b, integer *ldb, real *rwork,
+ real *resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Local variables */
+ integer j;
+ real eps, anorm, bnorm;
+ extern /* Subroutine */ int chpmv_(char *, integer *, complex *, complex *
+, complex *, integer *, complex *, complex *, integer *);
+ real xnorm;
+ extern doublereal clanhp_(char *, char *, integer *, complex *, real *), slamch_(char *), scasum_(integer *,
+ complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPPT02 computes the residual in the solution of a Hermitian system */
+/* of linear equations A*x = b when packed storage is used for the */
+/* coefficient matrix. The ratio computed is */
+
+/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS), */
+
+/* where EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The original Hermitian matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ --a;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = clanhp_("1", uplo, n, &a[1], &rwork[1]);
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute B - A*X for the matrix of right hand sides B. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ q__1.r = -1.f, q__1.i = -0.f;
+ chpmv_(uplo, n, &q__1, &a[1], &x[j * x_dim1 + 1], &c__1, &c_b1, &b[j *
+ b_dim1 + 1], &c__1);
+/* L10: */
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = scasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = scasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L20: */
+ }
+
+ return 0;
+
+/* End of CPPT02 */
+
+} /* cppt02_ */
diff --git a/TESTING/LIN/cppt03.c b/TESTING/LIN/cppt03.c
new file mode 100644
index 0000000..27dc49a
--- /dev/null
+++ b/TESTING/LIN/cppt03.c
@@ -0,0 +1,253 @@
+/* cppt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cppt03_(char *uplo, integer *n, complex *a, complex *
+ ainv, complex *work, integer *ldwork, real *rwork, real *rcond, real *
+ resid)
+{
+ /* System generated locals */
+ integer work_dim1, work_offset, i__1, i__2, i__3;
+ complex q__1;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, jj;
+ real eps;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), chpmv_(char *, integer *, complex *,
+ complex *, complex *, integer *, complex *, complex *, integer *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), clanhp_(char *, char *, integer *,
+ complex *, real *), slamch_(char *);
+ real ainvnm;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPPT03 computes the residual for a Hermitian packed matrix times its */
+/* inverse: */
+/* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The original Hermitian matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* AINV (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The (Hermitian) inverse of the matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* WORK (workspace) COMPLEX array, dimension (LDWORK,N) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RCOND (output) REAL */
+/* The reciprocal of the condition number of A, computed as */
+/* ( 1/norm(A) ) / norm(AINV). */
+
+/* RESID (output) REAL */
+/* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ --a;
+ --ainv;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.f;
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = clanhp_("1", uplo, n, &a[1], &rwork[1]);
+ ainvnm = clanhp_("1", uplo, n, &ainv[1], &rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ *rcond = 0.f;
+ *resid = 1.f / eps;
+ return 0;
+ }
+ *rcond = 1.f / anorm / ainvnm;
+
+/* UPLO = 'U': */
+/* Copy the leading N-1 x N-1 submatrix of AINV to WORK(1:N,2:N) and */
+/* expand it to a full matrix, then multiply by A one column at a */
+/* time, moving the result one column to the left. */
+
+ if (lsame_(uplo, "U")) {
+
+/* Copy AINV */
+
+ jj = 1;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(&j, &ainv[jj], &c__1, &work[(j + 1) * work_dim1 + 1], &
+ c__1);
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = j + (i__ + 1) * work_dim1;
+ r_cnjg(&q__1, &ainv[jj + i__ - 1]);
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L10: */
+ }
+ jj += j;
+/* L20: */
+ }
+ jj = (*n - 1) * *n / 2 + 1;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n + (i__ + 1) * work_dim1;
+ r_cnjg(&q__1, &ainv[jj + i__ - 1]);
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L30: */
+ }
+
+/* Multiply by A */
+
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ q__1.r = -1.f, q__1.i = -0.f;
+ chpmv_("Upper", n, &q__1, &a[1], &work[(j + 1) * work_dim1 + 1], &
+ c__1, &c_b1, &work[j * work_dim1 + 1], &c__1);
+/* L40: */
+ }
+ q__1.r = -1.f, q__1.i = -0.f;
+ chpmv_("Upper", n, &q__1, &a[1], &ainv[jj], &c__1, &c_b1, &work[*n *
+ work_dim1 + 1], &c__1);
+
+/* UPLO = 'L': */
+/* Copy the trailing N-1 x N-1 submatrix of AINV to WORK(1:N,1:N-1) */
+/* and multiply by A, moving each column to the right. */
+
+ } else {
+
+/* Copy AINV */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ * work_dim1 + 1;
+ r_cnjg(&q__1, &ainv[i__ + 1]);
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L50: */
+ }
+ jj = *n + 1;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ ccopy_(&i__2, &ainv[jj], &c__1, &work[j + (j - 1) * work_dim1], &
+ c__1);
+ i__2 = *n - j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = j + (j + i__ - 1) * work_dim1;
+ r_cnjg(&q__1, &ainv[jj + i__]);
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L60: */
+ }
+ jj = jj + *n - j + 1;
+/* L70: */
+ }
+
+/* Multiply by A */
+
+ for (j = *n; j >= 2; --j) {
+ q__1.r = -1.f, q__1.i = -0.f;
+ chpmv_("Lower", n, &q__1, &a[1], &work[(j - 1) * work_dim1 + 1], &
+ c__1, &c_b1, &work[j * work_dim1 + 1], &c__1);
+/* L80: */
+ }
+ q__1.r = -1.f, q__1.i = -0.f;
+ chpmv_("Lower", n, &q__1, &a[1], &ainv[1], &c__1, &c_b1, &work[
+ work_dim1 + 1], &c__1);
+
+ }
+
+/* Add the identity matrix to WORK . */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * work_dim1;
+ i__3 = i__ + i__ * work_dim1;
+ q__1.r = work[i__3].r + 1.f, q__1.i = work[i__3].i + 0.f;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L90: */
+ }
+
+/* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = clange_("1", n, n, &work[work_offset], ldwork, &rwork[1]);
+
+ *resid = *resid * *rcond / eps / (real) (*n);
+
+ return 0;
+
+/* End of CPPT03 */
+
+} /* cppt03_ */
diff --git a/TESTING/LIN/cppt05.c b/TESTING/LIN/cppt05.c
new file mode 100644
index 0000000..b068cd6
--- /dev/null
+++ b/TESTING/LIN/cppt05.c
@@ -0,0 +1,317 @@
+/* cppt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cppt05_(char *uplo, integer *n, integer *nrhs, complex *
+ ap, complex *b, integer *ldb, complex *x, integer *ldx, complex *xact,
+ integer *ldxact, real *ferr, real *berr, real *reslts)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1,
+ i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k, jc;
+ real eps, tmp, diff, axbi;
+ integer imax;
+ real unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ real xnorm;
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ real errbnd;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPPT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* Hermitian matrix in packed storage format. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the Hermitian matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) REAL array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) REAL array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.f;
+ reslts[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ upper = lsame_(uplo, "U");
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = icamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__2 = imax + j * x_dim1;
+ r__3 = (r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x[imax + j *
+ x_dim1]), dabs(r__2));
+ xnorm = dmax(r__3,unfl);
+ diff = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * xact_dim1;
+ q__2.r = x[i__3].r - xact[i__4].r, q__2.i = x[i__3].i - xact[i__4]
+ .i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+/* Computing MAX */
+ r__3 = diff, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
+ q__1), dabs(r__2));
+ diff = dmax(r__3,r__4);
+/* L10: */
+ }
+
+ if (xnorm > 1.f) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1.f / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
+ errbnd = dmax(r__1,r__2);
+ } else {
+ errbnd = 1.f / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ tmp = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[i__ + k *
+ b_dim1]), dabs(r__2));
+ if (upper) {
+ jc = (i__ - 1) * i__ / 2;
+ i__3 = i__ - 1;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = jc + j;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
+ ap[jc + j]), dabs(r__2))) * ((r__3 = x[i__5].r,
+ dabs(r__3)) + (r__4 = r_imag(&x[j + k * x_dim1]),
+ dabs(r__4)));
+/* L40: */
+ }
+ i__3 = jc + i__;
+ i__4 = i__ + k * x_dim1;
+ tmp += (r__1 = ap[i__3].r, dabs(r__1)) * ((r__2 = x[i__4].r,
+ dabs(r__2)) + (r__3 = r_imag(&x[i__ + k * x_dim1]),
+ dabs(r__3)));
+ jc = jc + i__ + i__;
+ i__3 = *n;
+ for (j = i__ + 1; j <= i__3; ++j) {
+ i__4 = jc;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
+ ap[jc]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs(
+ r__3)) + (r__4 = r_imag(&x[j + k * x_dim1]), dabs(
+ r__4)));
+ jc += j;
+/* L50: */
+ }
+ } else {
+ jc = i__;
+ i__3 = i__ - 1;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = jc;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
+ ap[jc]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs(
+ r__3)) + (r__4 = r_imag(&x[j + k * x_dim1]), dabs(
+ r__4)));
+ jc = jc + *n - j;
+/* L60: */
+ }
+ i__3 = jc;
+ i__4 = i__ + k * x_dim1;
+ tmp += (r__1 = ap[i__3].r, dabs(r__1)) * ((r__2 = x[i__4].r,
+ dabs(r__2)) + (r__3 = r_imag(&x[i__ + k * x_dim1]),
+ dabs(r__3)));
+ i__3 = *n;
+ for (j = i__ + 1; j <= i__3; ++j) {
+ i__4 = jc + j - i__;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
+ ap[jc + j - i__]), dabs(r__2))) * ((r__3 = x[i__5]
+ .r, dabs(r__3)) + (r__4 = r_imag(&x[j + k *
+ x_dim1]), dabs(r__4)));
+/* L70: */
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = dmin(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ r__1 = axbi, r__2 = (*n + 1) * unfl;
+ tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / dmax(r__1,r__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = dmax(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of CPPT05 */
+
+} /* cppt05_ */
diff --git a/TESTING/LIN/cpst01.c b/TESTING/LIN/cpst01.c
new file mode 100644
index 0000000..2e1af07
--- /dev/null
+++ b/TESTING/LIN/cpst01.c
@@ -0,0 +1,353 @@
+/* cpst01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b20 = 1.f;
+
+/* Subroutine */ int cpst01_(char *uplo, integer *n, complex *a, integer *lda,
+ complex *afac, integer *ldafac, complex *perm, integer *ldperm,
+ integer *piv, real *rwork, real *resid, integer *rank)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, perm_dim1, perm_offset,
+ i__1, i__2, i__3, i__4, i__5;
+ real r__1;
+ complex q__1;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ complex tc;
+ real tr, eps;
+ extern /* Subroutine */ int cher_(char *, integer *, real *, complex *,
+ integer *, complex *, integer *), cscal_(integer *,
+ complex *, complex *, integer *);
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
+ complex *, integer *, complex *, integer *);
+ extern doublereal clanhe_(char *, char *, integer *, complex *, integer *,
+ real *), slamch_(char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPST01 reconstructs an Hermitian positive semidefinite matrix A */
+/* from its L or U factors and the permutation matrix P and computes */
+/* the residual */
+/* norm( P*L*L'*P' - A ) / ( N * norm(A) * EPS ) or */
+/* norm( P*U'*U*P' - A ) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon, L' is the conjugate transpose of L, */
+/* and U' is the conjugate transpose of U. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The original Hermitian matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* AFAC (input) COMPLEX array, dimension (LDAFAC,N) */
+/* The factor L or U from the L*L' or U'*U */
+/* factorization of A. */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
+
+/* PERM (output) COMPLEX array, dimension (LDPERM,N) */
+/* Overwritten with the reconstructed matrix, and then with the */
+/* difference P*L*L'*P' - A (or P*U'*U*P' - A) */
+
+/* LDPERM (input) INTEGER */
+/* The leading dimension of the array PERM. */
+/* LDAPERM >= max(1,N). */
+
+/* PIV (input) INTEGER array, dimension (N) */
+/* PIV is such that the nonzero entries are */
+/* P( PIV( K ), K ) = 1. */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
+/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ perm_dim1 = *ldperm;
+ perm_offset = 1 + perm_dim1;
+ perm -= perm_offset;
+ --piv;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = clanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Check the imaginary parts of the diagonal elements and return with */
+/* an error code if any are nonzero. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (r_imag(&afac[j + j * afac_dim1]) != 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+/* L100: */
+ }
+
+/* Compute the product U'*U, overwriting U. */
+
+ if (lsame_(uplo, "U")) {
+
+ if (*rank < *n) {
+ i__1 = *n;
+ for (j = *rank + 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = *rank + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * afac_dim1;
+ afac[i__3].r = 0.f, afac[i__3].i = 0.f;
+/* L110: */
+ }
+/* L120: */
+ }
+ }
+
+ for (k = *n; k >= 1; --k) {
+
+/* Compute the (K,K) element of the result. */
+
+ cdotc_(&q__1, &k, &afac[k * afac_dim1 + 1], &c__1, &afac[k *
+ afac_dim1 + 1], &c__1);
+ tr = q__1.r;
+ i__1 = k + k * afac_dim1;
+ afac[i__1].r = tr, afac[i__1].i = 0.f;
+
+/* Compute the rest of column K. */
+
+ i__1 = k - 1;
+ ctrmv_("Upper", "Conjugate", "Non-unit", &i__1, &afac[afac_offset]
+, ldafac, &afac[k * afac_dim1 + 1], &c__1);
+
+/* L130: */
+ }
+
+/* Compute the product L*L', overwriting L. */
+
+ } else {
+
+ if (*rank < *n) {
+ i__1 = *n;
+ for (j = *rank + 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * afac_dim1;
+ afac[i__3].r = 0.f, afac[i__3].i = 0.f;
+/* L140: */
+ }
+/* L150: */
+ }
+ }
+
+ for (k = *n; k >= 1; --k) {
+/* Add a multiple of column K of the factor L to each of */
+/* columns K+1 through N. */
+
+ if (k + 1 <= *n) {
+ i__1 = *n - k;
+ cher_("Lower", &i__1, &c_b20, &afac[k + 1 + k * afac_dim1], &
+ c__1, &afac[k + 1 + (k + 1) * afac_dim1], ldafac);
+ }
+
+/* Scale column K by the diagonal element. */
+
+ i__1 = k + k * afac_dim1;
+ tc.r = afac[i__1].r, tc.i = afac[i__1].i;
+ i__1 = *n - k + 1;
+ cscal_(&i__1, &tc, &afac[k + k * afac_dim1], &c__1);
+/* L160: */
+ }
+
+ }
+
+/* Form P*L*L'*P' or P*U'*U*P' */
+
+ if (lsame_(uplo, "U")) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (piv[i__] <= piv[j]) {
+ if (i__ <= j) {
+ i__3 = piv[i__] + piv[j] * perm_dim1;
+ i__4 = i__ + j * afac_dim1;
+ perm[i__3].r = afac[i__4].r, perm[i__3].i = afac[i__4]
+ .i;
+ } else {
+ i__3 = piv[i__] + piv[j] * perm_dim1;
+ r_cnjg(&q__1, &afac[j + i__ * afac_dim1]);
+ perm[i__3].r = q__1.r, perm[i__3].i = q__1.i;
+ }
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+
+
+ } else {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (piv[i__] >= piv[j]) {
+ if (i__ >= j) {
+ i__3 = piv[i__] + piv[j] * perm_dim1;
+ i__4 = i__ + j * afac_dim1;
+ perm[i__3].r = afac[i__4].r, perm[i__3].i = afac[i__4]
+ .i;
+ } else {
+ i__3 = piv[i__] + piv[j] * perm_dim1;
+ r_cnjg(&q__1, &afac[j + i__ * afac_dim1]);
+ perm[i__3].r = q__1.r, perm[i__3].i = q__1.i;
+ }
+ }
+/* L190: */
+ }
+/* L200: */
+ }
+
+ }
+
+/* Compute the difference P*L*L'*P' - A (or P*U'*U*P' - A). */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * perm_dim1;
+ i__4 = i__ + j * perm_dim1;
+ i__5 = i__ + j * a_dim1;
+ q__1.r = perm[i__4].r - a[i__5].r, q__1.i = perm[i__4].i - a[
+ i__5].i;
+ perm[i__3].r = q__1.r, perm[i__3].i = q__1.i;
+/* L210: */
+ }
+ i__2 = j + j * perm_dim1;
+ i__3 = j + j * perm_dim1;
+ i__4 = j + j * a_dim1;
+ r__1 = a[i__4].r;
+ q__1.r = perm[i__3].r - r__1, q__1.i = perm[i__3].i;
+ perm[i__2].r = q__1.r, perm[i__2].i = q__1.i;
+/* L220: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * perm_dim1;
+ i__3 = j + j * perm_dim1;
+ i__4 = j + j * a_dim1;
+ r__1 = a[i__4].r;
+ q__1.r = perm[i__3].r - r__1, q__1.i = perm[i__3].i;
+ perm[i__2].r = q__1.r, perm[i__2].i = q__1.i;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * perm_dim1;
+ i__4 = i__ + j * perm_dim1;
+ i__5 = i__ + j * a_dim1;
+ q__1.r = perm[i__4].r - a[i__5].r, q__1.i = perm[i__4].i - a[
+ i__5].i;
+ perm[i__3].r = q__1.r, perm[i__3].i = q__1.i;
+/* L230: */
+ }
+/* L240: */
+ }
+ }
+
+/* Compute norm( P*L*L'P - A ) / ( N * norm(A) * EPS ), or */
+/* ( P*U'*U*P' - A )/ ( N * norm(A) * EPS ). */
+
+ *resid = clanhe_("1", uplo, n, &perm[perm_offset], ldafac, &rwork[1]);
+
+ *resid = *resid / (real) (*n) / anorm / eps;
+
+ return 0;
+
+/* End of CPST01 */
+
+} /* cpst01_ */
diff --git a/TESTING/LIN/cptt01.c b/TESTING/LIN/cptt01.c
new file mode 100644
index 0000000..f092774
--- /dev/null
+++ b/TESTING/LIN/cptt01.c
@@ -0,0 +1,173 @@
+/* cptt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int cptt01_(integer *n, real *d__, complex *e, real *df,
+ complex *ef, complex *work, real *resid)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1, r__2;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+ double c_abs(complex *);
+
+ /* Local variables */
+ integer i__;
+ complex de;
+ real eps, anorm;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPTT01 reconstructs a tridiagonal matrix A from its L*D*L' */
+/* factorization and computes the residual */
+/* norm(L*D*L' - A) / ( n * norm(A) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGTER */
+/* The order of the matrix A. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
+
+/* DF (input) REAL array, dimension (N) */
+/* The n diagonal elements of the factor L from the L*D*L' */
+/* factorization of A. */
+
+/* EF (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the factor L from the */
+/* L*D*L' factorization of A. */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* RESID (output) REAL */
+/* norm(L*D*L' - A) / (n * norm(A) * EPS) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --work;
+ --ef;
+ --df;
+ --e;
+ --d__;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+
+/* Construct the difference L*D*L' - A. */
+
+ r__1 = df[1] - d__[1];
+ work[1].r = r__1, work[1].i = 0.f;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ q__1.r = df[i__2] * ef[i__3].r, q__1.i = df[i__2] * ef[i__3].i;
+ de.r = q__1.r, de.i = q__1.i;
+ i__2 = *n + i__;
+ i__3 = i__;
+ q__1.r = de.r - e[i__3].r, q__1.i = de.i - e[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+ i__2 = i__ + 1;
+ r_cnjg(&q__4, &ef[i__]);
+ q__3.r = de.r * q__4.r - de.i * q__4.i, q__3.i = de.r * q__4.i + de.i
+ * q__4.r;
+ i__3 = i__ + 1;
+ q__2.r = q__3.r + df[i__3], q__2.i = q__3.i;
+ i__4 = i__ + 1;
+ q__1.r = q__2.r - d__[i__4], q__1.i = q__2.i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L10: */
+ }
+
+/* Compute the 1-norms of the tridiagonal matrices A and WORK. */
+
+ if (*n == 1) {
+ anorm = d__[1];
+ *resid = c_abs(&work[1]);
+ } else {
+/* Computing MAX */
+ r__1 = d__[1] + c_abs(&e[1]), r__2 = d__[*n] + c_abs(&e[*n - 1]);
+ anorm = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = c_abs(&work[1]) + c_abs(&work[*n + 1]), r__2 = c_abs(&work[*n])
+ + c_abs(&work[(*n << 1) - 1]);
+ *resid = dmax(r__1,r__2);
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = anorm, r__2 = d__[i__] + c_abs(&e[i__]) + c_abs(&e[i__ - 1]
+ );
+ anorm = dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = *resid, r__2 = c_abs(&work[i__]) + c_abs(&work[*n + i__ -
+ 1]) + c_abs(&work[*n + i__]);
+ *resid = dmax(r__1,r__2);
+/* L20: */
+ }
+ }
+
+/* Compute norm(L*D*L' - A) / (n * norm(A) * EPS) */
+
+ if (anorm <= 0.f) {
+ if (*resid != 0.f) {
+ *resid = 1.f / eps;
+ }
+ } else {
+ *resid = *resid / (real) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of CPTT01 */
+
+} /* cptt01_ */
diff --git a/TESTING/LIN/cptt02.c b/TESTING/LIN/cptt02.c
new file mode 100644
index 0000000..7b247b4
--- /dev/null
+++ b/TESTING/LIN/cptt02.c
@@ -0,0 +1,167 @@
+/* cptt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b4 = -1.f;
+static real c_b5 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int cptt02_(char *uplo, integer *n, integer *nrhs, real *d__,
+ complex *e, complex *x, integer *ldx, complex *b, integer *ldb, real
+ *resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j;
+ real eps, anorm, bnorm, xnorm;
+ extern doublereal slamch_(char *), clanht_(char *, integer *,
+ real *, complex *);
+ extern /* Subroutine */ int claptm_(char *, integer *, integer *, real *,
+ real *, complex *, complex *, integer *, real *, complex *,
+ integer *);
+ extern doublereal scasum_(integer *, complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPTT02 computes the residual for the solution to a symmetric */
+/* tridiagonal system of equations: */
+/* RESID = norm(B - A*X) / (norm(A) * norm(X) * EPS), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the superdiagonal or the subdiagonal of the */
+/* tridiagonal matrix A is stored. */
+/* = 'U': E is the superdiagonal of A */
+/* = 'L': E is the subdiagonal of A */
+
+/* N (input) INTEGTER */
+/* The order of the matrix A. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The n by nrhs matrix of solution vectors X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the n by nrhs matrix of right hand side vectors B. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RESID (output) REAL */
+/* norm(B - A*X) / (norm(A) * norm(X) * EPS) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Compute the 1-norm of the tridiagonal matrix A. */
+
+ anorm = clanht_("1", n, &d__[1], &e[1]);
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute B - A*X. */
+
+ claptm_(uplo, n, nrhs, &c_b4, &d__[1], &e[1], &x[x_offset], ldx, &c_b5, &
+ b[b_offset], ldb);
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = scasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = scasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of CPTT02 */
+
+} /* cptt02_ */
diff --git a/TESTING/LIN/cptt05.c b/TESTING/LIN/cptt05.c
new file mode 100644
index 0000000..074c655
--- /dev/null
+++ b/TESTING/LIN/cptt05.c
@@ -0,0 +1,300 @@
+/* cptt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cptt05_(integer *n, integer *nrhs, real *d__, complex *e,
+ complex *b, integer *ldb, complex *x, integer *ldx, complex *xact,
+ integer *ldxact, real *ferr, real *berr, real *reslts)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1,
+ i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9;
+ real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10, r__11,
+ r__12;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k, nz;
+ real eps, tmp, diff, axbi;
+ integer imax;
+ real unfl, ovfl, xnorm;
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ real errbnd;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CPTT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* Hermitian tridiagonal matrix of order n. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+/* and NZ = max. number of nonzeros in any row of A, plus 1 */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) COMPLEX array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) REAL array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) REAL array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.f;
+ reslts[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ nz = 4;
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = icamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__2 = imax + j * x_dim1;
+ r__3 = (r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x[imax + j *
+ x_dim1]), dabs(r__2));
+ xnorm = dmax(r__3,unfl);
+ diff = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * xact_dim1;
+ q__2.r = x[i__3].r - xact[i__4].r, q__2.i = x[i__3].i - xact[i__4]
+ .i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+/* Computing MAX */
+ r__3 = diff, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
+ q__1), dabs(r__2));
+ diff = dmax(r__3,r__4);
+/* L10: */
+ }
+
+ if (xnorm > 1.f) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1.f / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
+ errbnd = dmax(r__1,r__2);
+ } else {
+ errbnd = 1.f / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ if (*n == 1) {
+ i__2 = k * x_dim1 + 1;
+ q__2.r = d__[1] * x[i__2].r, q__2.i = d__[1] * x[i__2].i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ i__3 = k * b_dim1 + 1;
+ axbi = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[k *
+ b_dim1 + 1]), dabs(r__2)) + ((r__3 = q__1.r, dabs(r__3))
+ + (r__4 = r_imag(&q__1), dabs(r__4)));
+ } else {
+ i__2 = k * x_dim1 + 1;
+ q__2.r = d__[1] * x[i__2].r, q__2.i = d__[1] * x[i__2].i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ i__3 = k * b_dim1 + 1;
+ i__4 = k * x_dim1 + 2;
+ axbi = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[k *
+ b_dim1 + 1]), dabs(r__2)) + ((r__3 = q__1.r, dabs(r__3))
+ + (r__4 = r_imag(&q__1), dabs(r__4))) + ((r__5 = e[1].r,
+ dabs(r__5)) + (r__6 = r_imag(&e[1]), dabs(r__6))) * ((
+ r__7 = x[i__4].r, dabs(r__7)) + (r__8 = r_imag(&x[k *
+ x_dim1 + 2]), dabs(r__8)));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__ + k * x_dim1;
+ q__2.r = d__[i__3] * x[i__4].r, q__2.i = d__[i__3] * x[i__4]
+ .i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ i__5 = i__ + k * b_dim1;
+ i__6 = i__ - 1;
+ i__7 = i__ - 1 + k * x_dim1;
+ i__8 = i__;
+ i__9 = i__ + 1 + k * x_dim1;
+ tmp = (r__1 = b[i__5].r, dabs(r__1)) + (r__2 = r_imag(&b[i__
+ + k * b_dim1]), dabs(r__2)) + ((r__3 = e[i__6].r,
+ dabs(r__3)) + (r__4 = r_imag(&e[i__ - 1]), dabs(r__4))
+ ) * ((r__5 = x[i__7].r, dabs(r__5)) + (r__6 = r_imag(&
+ x[i__ - 1 + k * x_dim1]), dabs(r__6))) + ((r__7 =
+ q__1.r, dabs(r__7)) + (r__8 = r_imag(&q__1), dabs(
+ r__8))) + ((r__9 = e[i__8].r, dabs(r__9)) + (r__10 =
+ r_imag(&e[i__]), dabs(r__10))) * ((r__11 = x[i__9].r,
+ dabs(r__11)) + (r__12 = r_imag(&x[i__ + 1 + k *
+ x_dim1]), dabs(r__12)));
+ axbi = dmin(axbi,tmp);
+/* L40: */
+ }
+ i__2 = *n;
+ i__3 = *n + k * x_dim1;
+ q__2.r = d__[i__2] * x[i__3].r, q__2.i = d__[i__2] * x[i__3].i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+ i__4 = *n + k * b_dim1;
+ i__5 = *n - 1;
+ i__6 = *n - 1 + k * x_dim1;
+ tmp = (r__1 = b[i__4].r, dabs(r__1)) + (r__2 = r_imag(&b[*n + k *
+ b_dim1]), dabs(r__2)) + ((r__3 = e[i__5].r, dabs(r__3)) +
+ (r__4 = r_imag(&e[*n - 1]), dabs(r__4))) * ((r__5 = x[
+ i__6].r, dabs(r__5)) + (r__6 = r_imag(&x[*n - 1 + k *
+ x_dim1]), dabs(r__6))) + ((r__7 = q__1.r, dabs(r__7)) + (
+ r__8 = r_imag(&q__1), dabs(r__8)));
+ axbi = dmin(axbi,tmp);
+ }
+/* Computing MAX */
+ r__1 = axbi, r__2 = nz * unfl;
+ tmp = berr[k] / (nz * eps + nz * unfl / dmax(r__1,r__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = dmax(reslts[2],tmp);
+ }
+/* L50: */
+ }
+
+ return 0;
+
+/* End of CPTT05 */
+
+} /* cptt05_ */
diff --git a/TESTING/LIN/cqlt01.c b/TESTING/LIN/cqlt01.c
new file mode 100644
index 0000000..3bd65c7
--- /dev/null
+++ b/TESTING/LIN/cqlt01.c
@@ -0,0 +1,255 @@
+/* cqlt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static complex c_b1 = {-1e10f,-1e10f};
+static complex c_b12 = {0.f,0.f};
+static complex c_b19 = {-1.f,0.f};
+static complex c_b20 = {1.f,0.f};
+static real c_b28 = -1.f;
+static real c_b29 = 1.f;
+
+/* Subroutine */ int cqlt01_(integer *m, integer *n, complex *a, complex *af,
+ complex *q, complex *l, integer *lda, complex *tau, complex *work,
+ integer *lwork, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
+ q_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real eps;
+ integer info;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), cherk_(char *,
+ char *, integer *, integer *, real *, complex *, integer *, real *
+, complex *, integer *);
+ real resid, anorm;
+ integer minmn;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int cgeqlf_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *);
+ extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
+ real *);
+ extern /* Subroutine */ int cungql_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CQLT01 tests CGEQLF, which computes the QL factorization of an m-by-n */
+/* matrix A, and partially tests CUNGQL which forms the m-by-m */
+/* orthogonal matrix Q. */
+
+/* CQLT01 compares L with Q'*A, and checks that Q is orthogonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The m-by-n matrix A. */
+
+/* AF (output) COMPLEX array, dimension (LDA,N) */
+/* Details of the QL factorization of A, as returned by CGEQLF. */
+/* See CGEQLF for further details. */
+
+/* Q (output) COMPLEX array, dimension (LDA,M) */
+/* The m-by-m orthogonal matrix Q. */
+
+/* L (workspace) COMPLEX array, dimension (LDA,max(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and R. */
+/* LDA >= max(M,N). */
+
+/* TAU (output) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by CGEQLF. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ l_dim1 = *lda;
+ l_offset = 1 + l_dim1;
+ l -= l_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ minmn = min(*m,*n);
+ eps = slamch_("Epsilon");
+
+/* Copy the matrix A to the array AF. */
+
+ clacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+
+/* Factorize the matrix A in the array AF. */
+
+ s_copy(srnamc_1.srnamt, "CGEQLF", (ftnlen)32, (ftnlen)6);
+ cgeqlf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy details of Q */
+
+ claset_("Full", m, m, &c_b1, &c_b1, &q[q_offset], lda);
+ if (*m >= *n) {
+ if (*n < *m && *n > 0) {
+ i__1 = *m - *n;
+ clacpy_("Full", &i__1, n, &af[af_offset], lda, &q[(*m - *n + 1) *
+ q_dim1 + 1], lda);
+ }
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ clacpy_("Upper", &i__1, &i__2, &af[*m - *n + 1 + (af_dim1 << 1)],
+ lda, &q[*m - *n + 1 + (*m - *n + 2) * q_dim1], lda);
+ }
+ } else {
+ if (*m > 1) {
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ clacpy_("Upper", &i__1, &i__2, &af[(*n - *m + 2) * af_dim1 + 1],
+ lda, &q[(q_dim1 << 1) + 1], lda);
+ }
+ }
+
+/* Generate the m-by-m matrix Q */
+
+ s_copy(srnamc_1.srnamt, "CUNGQL", (ftnlen)32, (ftnlen)6);
+ cungql_(m, m, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy L */
+
+ claset_("Full", m, n, &c_b12, &c_b12, &l[l_offset], lda);
+ if (*m >= *n) {
+ if (*n > 0) {
+ clacpy_("Lower", n, n, &af[*m - *n + 1 + af_dim1], lda, &l[*m - *
+ n + 1 + l_dim1], lda);
+ }
+ } else {
+ if (*n > *m && *m > 0) {
+ i__1 = *n - *m;
+ clacpy_("Full", m, &i__1, &af[af_offset], lda, &l[l_offset], lda);
+ }
+ if (*m > 0) {
+ clacpy_("Lower", m, m, &af[(*n - *m + 1) * af_dim1 + 1], lda, &l[(
+ *n - *m + 1) * l_dim1 + 1], lda);
+ }
+ }
+
+/* Compute L - Q'*A */
+
+ cgemm_("Conjugate transpose", "No transpose", m, n, m, &c_b19, &q[
+ q_offset], lda, &a[a_offset], lda, &c_b20, &l[l_offset], lda);
+
+/* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */
+
+ anorm = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ resid = clange_("1", m, n, &l[l_offset], lda, &rwork[1]);
+ if (anorm > 0.f) {
+ result[1] = resid / (real) max(1,*m) / anorm / eps;
+ } else {
+ result[1] = 0.f;
+ }
+
+/* Compute I - Q'*Q */
+
+ claset_("Full", m, m, &c_b12, &c_b20, &l[l_offset], lda);
+ cherk_("Upper", "Conjugate transpose", m, m, &c_b28, &q[q_offset], lda, &
+ c_b29, &l[l_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
+
+ resid = clansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
+
+ result[2] = resid / (real) max(1,*m) / eps;
+
+ return 0;
+
+/* End of CQLT01 */
+
+} /* cqlt01_ */
diff --git a/TESTING/LIN/cqlt02.c b/TESTING/LIN/cqlt02.c
new file mode 100644
index 0000000..ae9fb4b
--- /dev/null
+++ b/TESTING/LIN/cqlt02.c
@@ -0,0 +1,239 @@
+/* cqlt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static complex c_b1 = {-1e10f,-1e10f};
+static complex c_b9 = {0.f,0.f};
+static complex c_b14 = {-1.f,0.f};
+static complex c_b15 = {1.f,0.f};
+static real c_b23 = -1.f;
+static real c_b24 = 1.f;
+
+/* Subroutine */ int cqlt02_(integer *m, integer *n, integer *k, complex *a,
+ complex *af, complex *q, complex *l, integer *lda, complex *tau,
+ complex *work, integer *lwork, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
+ q_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real eps;
+ integer info;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), cherk_(char *,
+ char *, integer *, integer *, real *, complex *, integer *, real *
+, complex *, integer *);
+ real resid, anorm;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *);
+ extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
+ real *);
+ extern /* Subroutine */ int cungql_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CQLT02 tests CUNGQL, which generates an m-by-n matrix Q with */
+/* orthonornmal columns that is defined as the product of k elementary */
+/* reflectors. */
+
+/* Given the QL factorization of an m-by-n matrix A, CQLT02 generates */
+/* the orthogonal matrix Q defined by the factorization of the last k */
+/* columns of A; it compares L(m-n+1:m,n-k+1:n) with */
+/* Q(1:m,m-n+1:m)'*A(1:m,n-k+1:n), and checks that the columns of Q are */
+/* orthonormal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q to be generated. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q to be generated. */
+/* M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The m-by-n matrix A which was factorized by CQLT01. */
+
+/* AF (input) COMPLEX array, dimension (LDA,N) */
+/* Details of the QL factorization of A, as returned by CGEQLF. */
+/* See CGEQLF for further details. */
+
+/* Q (workspace) COMPLEX array, dimension (LDA,N) */
+
+/* L (workspace) COMPLEX array, dimension (LDA,N) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and L. LDA >= M. */
+
+/* TAU (input) COMPLEX array, dimension (N) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the QL factorization in AF. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ l_dim1 = *lda;
+ l_offset = 1 + l_dim1;
+ l -= l_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ if (*m == 0 || *n == 0 || *k == 0) {
+ result[1] = 0.f;
+ result[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+
+/* Copy the last k columns of the factorization to the array Q */
+
+ claset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
+ if (*k < *m) {
+ i__1 = *m - *k;
+ clacpy_("Full", &i__1, k, &af[(*n - *k + 1) * af_dim1 + 1], lda, &q[(*
+ n - *k + 1) * q_dim1 + 1], lda);
+ }
+ if (*k > 1) {
+ i__1 = *k - 1;
+ i__2 = *k - 1;
+ clacpy_("Upper", &i__1, &i__2, &af[*m - *k + 1 + (*n - *k + 2) *
+ af_dim1], lda, &q[*m - *k + 1 + (*n - *k + 2) * q_dim1], lda);
+ }
+
+/* Generate the last n columns of the matrix Q */
+
+ s_copy(srnamc_1.srnamt, "CUNGQL", (ftnlen)32, (ftnlen)6);
+ cungql_(m, n, k, &q[q_offset], lda, &tau[*n - *k + 1], &work[1], lwork, &
+ info);
+
+/* Copy L(m-n+1:m,n-k+1:n) */
+
+ claset_("Full", n, k, &c_b9, &c_b9, &l[*m - *n + 1 + (*n - *k + 1) *
+ l_dim1], lda);
+ clacpy_("Lower", k, k, &af[*m - *k + 1 + (*n - *k + 1) * af_dim1], lda, &
+ l[*m - *k + 1 + (*n - *k + 1) * l_dim1], lda);
+
+/* Compute L(m-n+1:m,n-k+1:n) - Q(1:m,m-n+1:m)' * A(1:m,n-k+1:n) */
+
+ cgemm_("Conjugate transpose", "No transpose", n, k, m, &c_b14, &q[
+ q_offset], lda, &a[(*n - *k + 1) * a_dim1 + 1], lda, &c_b15, &l[*
+ m - *n + 1 + (*n - *k + 1) * l_dim1], lda)
+ ;
+
+/* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */
+
+ anorm = clange_("1", m, k, &a[(*n - *k + 1) * a_dim1 + 1], lda, &rwork[1]);
+ resid = clange_("1", n, k, &l[*m - *n + 1 + (*n - *k + 1) * l_dim1], lda,
+ &rwork[1]);
+ if (anorm > 0.f) {
+ result[1] = resid / (real) max(1,*m) / anorm / eps;
+ } else {
+ result[1] = 0.f;
+ }
+
+/* Compute I - Q'*Q */
+
+ claset_("Full", n, n, &c_b9, &c_b15, &l[l_offset], lda);
+ cherk_("Upper", "Conjugate transpose", n, m, &c_b23, &q[q_offset], lda, &
+ c_b24, &l[l_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
+
+ resid = clansy_("1", "Upper", n, &l[l_offset], lda, &rwork[1]);
+
+ result[2] = resid / (real) max(1,*m) / eps;
+
+ return 0;
+
+/* End of CQLT02 */
+
+} /* cqlt02_ */
diff --git a/TESTING/LIN/cqlt03.c b/TESTING/LIN/cqlt03.c
new file mode 100644
index 0000000..1d28308
--- /dev/null
+++ b/TESTING/LIN/cqlt03.c
@@ -0,0 +1,284 @@
+/* cqlt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static complex c_b1 = {-1e10f,-1e10f};
+static integer c__2 = 2;
+static complex c_b21 = {-1.f,0.f};
+static complex c_b22 = {1.f,0.f};
+
+/* Subroutine */ int cqlt03_(integer *m, integer *n, integer *k, complex *af,
+ complex *c__, complex *cc, complex *q, integer *lda, complex *tau,
+ complex *work, integer *lwork, real *rwork, real *result)
+{
+ /* Initialized data */
+
+ static integer iseed[4] = { 1988,1989,1990,1991 };
+
+ /* System generated locals */
+ integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1,
+ q_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j, mc, nc;
+ real eps;
+ char side[1];
+ integer info;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ integer iside;
+ extern logical lsame_(char *, char *);
+ real resid;
+ integer minmn;
+ real cnorm;
+ char trans[1];
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), clarnv_(integer *, integer *, integer *, complex *),
+ cungql_(integer *, integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *, integer *), cunmql_(char *, char
+ *, integer *, integer *, integer *, complex *, integer *, complex
+ *, complex *, integer *, complex *, integer *, integer *);
+ integer itrans;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CQLT03 tests CUNMQL, which computes Q*C, Q'*C, C*Q or C*Q'. */
+
+/* CQLT03 compares the results of a call to CUNMQL with the results of */
+/* forming Q explicitly by a call to CUNGQL and then performing matrix */
+/* multiplication by a call to CGEMM. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The order of the orthogonal matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of rows or columns of the matrix C; C is m-by-n if */
+/* Q is applied from the left, or n-by-m if Q is applied from */
+/* the right. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* orthogonal matrix Q. M >= K >= 0. */
+
+/* AF (input) COMPLEX array, dimension (LDA,N) */
+/* Details of the QL factorization of an m-by-n matrix, as */
+/* returned by CGEQLF. See CGEQLF for further details. */
+
+/* C (workspace) COMPLEX array, dimension (LDA,N) */
+
+/* CC (workspace) COMPLEX array, dimension (LDA,N) */
+
+/* Q (workspace) COMPLEX array, dimension (LDA,M) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays AF, C, CC, and Q. */
+
+/* TAU (input) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the QL factorization in AF. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK must be at least M, and should be */
+/* M*NB, where NB is the blocksize for this environment. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (4) */
+/* The test ratios compare two techniques for multiplying a */
+/* random matrix C by an m-by-m orthogonal matrix Q. */
+/* RESULT(1) = norm( Q*C - Q*C ) / ( M * norm(C) * EPS ) */
+/* RESULT(2) = norm( C*Q - C*Q ) / ( M * norm(C) * EPS ) */
+/* RESULT(3) = norm( Q'*C - Q'*C )/ ( M * norm(C) * EPS ) */
+/* RESULT(4) = norm( C*Q' - C*Q' )/ ( M * norm(C) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ cc_dim1 = *lda;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+ c_dim1 = *lda;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = slamch_("Epsilon");
+ minmn = min(*m,*n);
+
+/* Quick return if possible */
+
+ if (minmn == 0) {
+ result[1] = 0.f;
+ result[2] = 0.f;
+ result[3] = 0.f;
+ result[4] = 0.f;
+ return 0;
+ }
+
+/* Copy the last k columns of the factorization to the array Q */
+
+ claset_("Full", m, m, &c_b1, &c_b1, &q[q_offset], lda);
+ if (*k > 0 && *m > *k) {
+ i__1 = *m - *k;
+ clacpy_("Full", &i__1, k, &af[(*n - *k + 1) * af_dim1 + 1], lda, &q[(*
+ m - *k + 1) * q_dim1 + 1], lda);
+ }
+ if (*k > 1) {
+ i__1 = *k - 1;
+ i__2 = *k - 1;
+ clacpy_("Upper", &i__1, &i__2, &af[*m - *k + 1 + (*n - *k + 2) *
+ af_dim1], lda, &q[*m - *k + 1 + (*m - *k + 2) * q_dim1], lda);
+ }
+
+/* Generate the m-by-m matrix Q */
+
+ s_copy(srnamc_1.srnamt, "CUNGQL", (ftnlen)32, (ftnlen)6);
+ cungql_(m, m, k, &q[q_offset], lda, &tau[minmn - *k + 1], &work[1], lwork,
+ &info);
+
+ for (iside = 1; iside <= 2; ++iside) {
+ if (iside == 1) {
+ *(unsigned char *)side = 'L';
+ mc = *m;
+ nc = *n;
+ } else {
+ *(unsigned char *)side = 'R';
+ mc = *n;
+ nc = *m;
+ }
+
+/* Generate MC by NC matrix C */
+
+ i__1 = nc;
+ for (j = 1; j <= i__1; ++j) {
+ clarnv_(&c__2, iseed, &mc, &c__[j * c_dim1 + 1]);
+/* L10: */
+ }
+ cnorm = clange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]);
+ if (cnorm == 0.f) {
+ cnorm = 1.f;
+ }
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+ if (itrans == 1) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'C';
+ }
+
+/* Copy C */
+
+ clacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
+ lda);
+
+/* Apply Q or Q' to C */
+
+ s_copy(srnamc_1.srnamt, "CUNMQL", (ftnlen)32, (ftnlen)6);
+ if (*k > 0) {
+ cunmql_(side, trans, &mc, &nc, k, &af[(*n - *k + 1) * af_dim1
+ + 1], lda, &tau[minmn - *k + 1], &cc[cc_offset], lda,
+ &work[1], lwork, &info);
+ }
+
+/* Form explicit product and subtract */
+
+ if (lsame_(side, "L")) {
+ cgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b21, &q[
+ q_offset], lda, &c__[c_offset], lda, &c_b22, &cc[
+ cc_offset], lda);
+ } else {
+ cgemm_("No transpose", trans, &mc, &nc, &nc, &c_b21, &c__[
+ c_offset], lda, &q[q_offset], lda, &c_b22, &cc[
+ cc_offset], lda);
+ }
+
+/* Compute error in the difference */
+
+ resid = clange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
+ result[(iside - 1 << 1) + itrans] = resid / ((real) max(1,*m) *
+ cnorm * eps);
+
+/* L20: */
+ }
+/* L30: */
+ }
+
+ return 0;
+
+/* End of CQLT03 */
+
+} /* cqlt03_ */
diff --git a/TESTING/LIN/cqpt01.c b/TESTING/LIN/cqpt01.c
new file mode 100644
index 0000000..dc9e75f
--- /dev/null
+++ b/TESTING/LIN/cqpt01.c
@@ -0,0 +1,197 @@
+/* cqpt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__10 = 10;
+static integer c__1 = 1;
+static complex c_b16 = {-1.f,0.f};
+
+doublereal cqpt01_(integer *m, integer *n, integer *k, complex *a, complex *
+ af, integer *lda, complex *tau, integer *jpvt, complex *work, integer
+ *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
+ real ret_val;
+
+ /* Local variables */
+ integer i__, j, info;
+ real norma;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ real rwork[1];
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), cunmqr_(
+ char *, char *, integer *, integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CQPT01 tests the QR-factorization with pivoting of a matrix A. The */
+/* array AF contains the (possibly partial) QR-factorization of A, where */
+/* the upper triangle of AF(1:k,1:k) is a partial triangular factor, */
+/* the entries below the diagonal in the first k columns are the */
+/* Householder vectors, and the rest of AF contains a partially updated */
+/* matrix. */
+
+/* This function returns ||A*P - Q*R||/(||norm(A)||*eps*M) */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices A and AF. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and AF. */
+
+/* K (input) INTEGER */
+/* The number of columns of AF that have been reduced */
+/* to upper triangular form. */
+
+/* A (input) COMPLEX array, dimension (LDA, N) */
+/* The original matrix A. */
+
+/* AF (input) COMPLEX array, dimension (LDA,N) */
+/* The (possibly partial) output of CGEQPF. The upper triangle */
+/* of AF(1:k,1:k) is a partial triangular factor, the entries */
+/* below the diagonal in the first k columns are the Householder */
+/* vectors, and the rest of AF contains a partially updated */
+/* matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A and AF. */
+
+/* TAU (input) COMPLEX array, dimension (K) */
+/* Details of the Householder transformations as returned by */
+/* CGEQPF. */
+
+/* JPVT (input) INTEGER array, dimension (N) */
+/* Pivot information as returned by CGEQPF. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= M*N+N. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --jpvt;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+/* Test if there is enough workspace */
+
+ if (*lwork < *m * *n + *n) {
+ xerbla_("CQPT01", &c__10);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return ret_val;
+ }
+
+ norma = clange_("One-norm", m, n, &a[a_offset], lda, rwork);
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(j,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = (j - 1) * *m + i__;
+ i__4 = i__ + j * af_dim1;
+ work[i__3].r = af[i__4].r, work[i__3].i = af[i__4].i;
+/* L10: */
+ }
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = (j - 1) * *m + i__;
+ work[i__3].r = 0.f, work[i__3].i = 0.f;
+/* L20: */
+ }
+/* L30: */
+ }
+ i__1 = *n;
+ for (j = *k + 1; j <= i__1; ++j) {
+ ccopy_(m, &af[j * af_dim1 + 1], &c__1, &work[(j - 1) * *m + 1], &c__1)
+ ;
+/* L40: */
+ }
+
+ i__1 = *lwork - *m * *n;
+ cunmqr_("Left", "No transpose", m, n, k, &af[af_offset], lda, &tau[1], &
+ work[1], m, &work[*m * *n + 1], &i__1, &info);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compare i-th column of QR and jpvt(i)-th column of A */
+
+ caxpy_(m, &c_b16, &a[jpvt[j] * a_dim1 + 1], &c__1, &work[(j - 1) * *m
+ + 1], &c__1);
+/* L50: */
+ }
+
+ ret_val = clange_("One-norm", m, n, &work[1], m, rwork) / ((
+ real) max(*m,*n) * slamch_("Epsilon"));
+ if (norma != 0.f) {
+ ret_val /= norma;
+ }
+
+ return ret_val;
+
+/* End of CQPT01 */
+
+} /* cqpt01_ */
diff --git a/TESTING/LIN/cqrt01.c b/TESTING/LIN/cqrt01.c
new file mode 100644
index 0000000..195e15e
--- /dev/null
+++ b/TESTING/LIN/cqrt01.c
@@ -0,0 +1,222 @@
+/* cqrt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static complex c_b1 = {-1e10f,-1e10f};
+static complex c_b10 = {0.f,0.f};
+static complex c_b15 = {-1.f,0.f};
+static complex c_b16 = {1.f,0.f};
+static real c_b24 = -1.f;
+static real c_b25 = 1.f;
+
+/* Subroutine */ int cqrt01_(integer *m, integer *n, complex *a, complex *af,
+ complex *q, complex *r__, integer *lda, complex *tau, complex *work,
+ integer *lwork, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
+ r_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real eps;
+ integer info;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), cherk_(char *,
+ char *, integer *, integer *, real *, complex *, integer *, real *
+, complex *, integer *);
+ real resid, anorm;
+ integer minmn;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int cgeqrf_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *), clacpy_(
+ char *, integer *, integer *, complex *, integer *, complex *,
+ integer *), claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *);
+ extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
+ real *);
+ extern /* Subroutine */ int cungqr_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CQRT01 tests CGEQRF, which computes the QR factorization of an m-by-n */
+/* matrix A, and partially tests CUNGQR which forms the m-by-m */
+/* orthogonal matrix Q. */
+
+/* CQRT01 compares R with Q'*A, and checks that Q is orthogonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The m-by-n matrix A. */
+
+/* AF (output) COMPLEX array, dimension (LDA,N) */
+/* Details of the QR factorization of A, as returned by CGEQRF. */
+/* See CGEQRF for further details. */
+
+/* Q (output) COMPLEX array, dimension (LDA,M) */
+/* The m-by-m orthogonal matrix Q. */
+
+/* R (workspace) COMPLEX array, dimension (LDA,max(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and R. */
+/* LDA >= max(M,N). */
+
+/* TAU (output) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by CGEQRF. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - Q'*A ) / ( M * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ minmn = min(*m,*n);
+ eps = slamch_("Epsilon");
+
+/* Copy the matrix A to the array AF. */
+
+ clacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+
+/* Factorize the matrix A in the array AF. */
+
+ s_copy(srnamc_1.srnamt, "CGEQRF", (ftnlen)32, (ftnlen)6);
+ cgeqrf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy details of Q */
+
+ claset_("Full", m, m, &c_b1, &c_b1, &q[q_offset], lda);
+ i__1 = *m - 1;
+ clacpy_("Lower", &i__1, n, &af[af_dim1 + 2], lda, &q[q_dim1 + 2], lda);
+
+/* Generate the m-by-m matrix Q */
+
+ s_copy(srnamc_1.srnamt, "CUNGQR", (ftnlen)32, (ftnlen)6);
+ cungqr_(m, m, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy R */
+
+ claset_("Full", m, n, &c_b10, &c_b10, &r__[r_offset], lda);
+ clacpy_("Upper", m, n, &af[af_offset], lda, &r__[r_offset], lda);
+
+/* Compute R - Q'*A */
+
+ cgemm_("Conjugate transpose", "No transpose", m, n, m, &c_b15, &q[
+ q_offset], lda, &a[a_offset], lda, &c_b16, &r__[r_offset], lda);
+
+/* Compute norm( R - Q'*A ) / ( M * norm(A) * EPS ) . */
+
+ anorm = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ resid = clange_("1", m, n, &r__[r_offset], lda, &rwork[1]);
+ if (anorm > 0.f) {
+ result[1] = resid / (real) max(1,*m) / anorm / eps;
+ } else {
+ result[1] = 0.f;
+ }
+
+/* Compute I - Q'*Q */
+
+ claset_("Full", m, m, &c_b10, &c_b16, &r__[r_offset], lda);
+ cherk_("Upper", "Conjugate transpose", m, m, &c_b24, &q[q_offset], lda, &
+ c_b25, &r__[r_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
+
+ resid = clansy_("1", "Upper", m, &r__[r_offset], lda, &rwork[1]);
+
+ result[2] = resid / (real) max(1,*m) / eps;
+
+ return 0;
+
+/* End of CQRT01 */
+
+} /* cqrt01_ */
diff --git a/TESTING/LIN/cqrt02.c b/TESTING/LIN/cqrt02.c
new file mode 100644
index 0000000..8710b46
--- /dev/null
+++ b/TESTING/LIN/cqrt02.c
@@ -0,0 +1,215 @@
+/* cqrt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static complex c_b1 = {-1e10f,-1e10f};
+static complex c_b8 = {0.f,0.f};
+static complex c_b13 = {-1.f,0.f};
+static complex c_b14 = {1.f,0.f};
+static real c_b22 = -1.f;
+static real c_b23 = 1.f;
+
+/* Subroutine */ int cqrt02_(integer *m, integer *n, integer *k, complex *a,
+ complex *af, complex *q, complex *r__, integer *lda, complex *tau,
+ complex *work, integer *lwork, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
+ r_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real eps;
+ integer info;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), cherk_(char *,
+ char *, integer *, integer *, real *, complex *, integer *, real *
+, complex *, integer *);
+ real resid, anorm;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *);
+ extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
+ real *);
+ extern /* Subroutine */ int cungqr_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CQRT02 tests CUNGQR, which generates an m-by-n matrix Q with */
+/* orthonornmal columns that is defined as the product of k elementary */
+/* reflectors. */
+
+/* Given the QR factorization of an m-by-n matrix A, CQRT02 generates */
+/* the orthogonal matrix Q defined by the factorization of the first k */
+/* columns of A; it compares R(1:n,1:k) with Q(1:m,1:n)'*A(1:m,1:k), */
+/* and checks that the columns of Q are orthonormal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q to be generated. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q to be generated. */
+/* M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The m-by-n matrix A which was factorized by CQRT01. */
+
+/* AF (input) COMPLEX array, dimension (LDA,N) */
+/* Details of the QR factorization of A, as returned by CGEQRF. */
+/* See CGEQRF for further details. */
+
+/* Q (workspace) COMPLEX array, dimension (LDA,N) */
+
+/* R (workspace) COMPLEX array, dimension (LDA,N) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and R. LDA >= M. */
+
+/* TAU (input) COMPLEX array, dimension (N) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the QR factorization in AF. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - Q'*A ) / ( M * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ eps = slamch_("Epsilon");
+
+/* Copy the first k columns of the factorization to the array Q */
+
+ claset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
+ i__1 = *m - 1;
+ clacpy_("Lower", &i__1, k, &af[af_dim1 + 2], lda, &q[q_dim1 + 2], lda);
+
+/* Generate the first n columns of the matrix Q */
+
+ s_copy(srnamc_1.srnamt, "CUNGQR", (ftnlen)32, (ftnlen)6);
+ cungqr_(m, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy R(1:n,1:k) */
+
+ claset_("Full", n, k, &c_b8, &c_b8, &r__[r_offset], lda);
+ clacpy_("Upper", n, k, &af[af_offset], lda, &r__[r_offset], lda);
+
+/* Compute R(1:n,1:k) - Q(1:m,1:n)' * A(1:m,1:k) */
+
+ cgemm_("Conjugate transpose", "No transpose", n, k, m, &c_b13, &q[
+ q_offset], lda, &a[a_offset], lda, &c_b14, &r__[r_offset], lda);
+
+/* Compute norm( R - Q'*A ) / ( M * norm(A) * EPS ) . */
+
+ anorm = clange_("1", m, k, &a[a_offset], lda, &rwork[1]);
+ resid = clange_("1", n, k, &r__[r_offset], lda, &rwork[1]);
+ if (anorm > 0.f) {
+ result[1] = resid / (real) max(1,*m) / anorm / eps;
+ } else {
+ result[1] = 0.f;
+ }
+
+/* Compute I - Q'*Q */
+
+ claset_("Full", n, n, &c_b8, &c_b14, &r__[r_offset], lda);
+ cherk_("Upper", "Conjugate transpose", n, m, &c_b22, &q[q_offset], lda, &
+ c_b23, &r__[r_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
+
+ resid = clansy_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
+
+ result[2] = resid / (real) max(1,*m) / eps;
+
+ return 0;
+
+/* End of CQRT02 */
+
+} /* cqrt02_ */
diff --git a/TESTING/LIN/cqrt03.c b/TESTING/LIN/cqrt03.c
new file mode 100644
index 0000000..0d924c7
--- /dev/null
+++ b/TESTING/LIN/cqrt03.c
@@ -0,0 +1,259 @@
+/* cqrt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static complex c_b1 = {-1e10f,-1e10f};
+static integer c__2 = 2;
+static complex c_b20 = {-1.f,0.f};
+static complex c_b21 = {1.f,0.f};
+
+/* Subroutine */ int cqrt03_(integer *m, integer *n, integer *k, complex *af,
+ complex *c__, complex *cc, complex *q, integer *lda, complex *tau,
+ complex *work, integer *lwork, real *rwork, real *result)
+{
+ /* Initialized data */
+
+ static integer iseed[4] = { 1988,1989,1990,1991 };
+
+ /* System generated locals */
+ integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1,
+ q_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j, mc, nc;
+ real eps;
+ char side[1];
+ integer info;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ integer iside;
+ extern logical lsame_(char *, char *);
+ real resid, cnorm;
+ char trans[1];
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), clarnv_(integer *, integer *, integer *, complex *),
+ cungqr_(integer *, integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *, integer *);
+ integer itrans;
+ extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CQRT03 tests CUNMQR, which computes Q*C, Q'*C, C*Q or C*Q'. */
+
+/* CQRT03 compares the results of a call to CUNMQR with the results of */
+/* forming Q explicitly by a call to CUNGQR and then performing matrix */
+/* multiplication by a call to CGEMM. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The order of the orthogonal matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of rows or columns of the matrix C; C is m-by-n if */
+/* Q is applied from the left, or n-by-m if Q is applied from */
+/* the right. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* orthogonal matrix Q. M >= K >= 0. */
+
+/* AF (input) COMPLEX array, dimension (LDA,N) */
+/* Details of the QR factorization of an m-by-n matrix, as */
+/* returnedby CGEQRF. See CGEQRF for further details. */
+
+/* C (workspace) COMPLEX array, dimension (LDA,N) */
+
+/* CC (workspace) COMPLEX array, dimension (LDA,N) */
+
+/* Q (workspace) COMPLEX array, dimension (LDA,M) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays AF, C, CC, and Q. */
+
+/* TAU (input) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the QR factorization in AF. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK must be at least M, and should be */
+/* M*NB, where NB is the blocksize for this environment. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (4) */
+/* The test ratios compare two techniques for multiplying a */
+/* random matrix C by an m-by-m orthogonal matrix Q. */
+/* RESULT(1) = norm( Q*C - Q*C ) / ( M * norm(C) * EPS ) */
+/* RESULT(2) = norm( C*Q - C*Q ) / ( M * norm(C) * EPS ) */
+/* RESULT(3) = norm( Q'*C - Q'*C )/ ( M * norm(C) * EPS ) */
+/* RESULT(4) = norm( C*Q' - C*Q' )/ ( M * norm(C) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ cc_dim1 = *lda;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+ c_dim1 = *lda;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = slamch_("Epsilon");
+
+/* Copy the first k columns of the factorization to the array Q */
+
+ claset_("Full", m, m, &c_b1, &c_b1, &q[q_offset], lda);
+ i__1 = *m - 1;
+ clacpy_("Lower", &i__1, k, &af[af_dim1 + 2], lda, &q[q_dim1 + 2], lda);
+
+/* Generate the m-by-m matrix Q */
+
+ s_copy(srnamc_1.srnamt, "CUNGQR", (ftnlen)32, (ftnlen)6);
+ cungqr_(m, m, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+ for (iside = 1; iside <= 2; ++iside) {
+ if (iside == 1) {
+ *(unsigned char *)side = 'L';
+ mc = *m;
+ nc = *n;
+ } else {
+ *(unsigned char *)side = 'R';
+ mc = *n;
+ nc = *m;
+ }
+
+/* Generate MC by NC matrix C */
+
+ i__1 = nc;
+ for (j = 1; j <= i__1; ++j) {
+ clarnv_(&c__2, iseed, &mc, &c__[j * c_dim1 + 1]);
+/* L10: */
+ }
+ cnorm = clange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]);
+ if (cnorm == 0.f) {
+ cnorm = 1.f;
+ }
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+ if (itrans == 1) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'C';
+ }
+
+/* Copy C */
+
+ clacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
+ lda);
+
+/* Apply Q or Q' to C */
+
+ s_copy(srnamc_1.srnamt, "CUNMQR", (ftnlen)32, (ftnlen)6);
+ cunmqr_(side, trans, &mc, &nc, k, &af[af_offset], lda, &tau[1], &
+ cc[cc_offset], lda, &work[1], lwork, &info);
+
+/* Form explicit product and subtract */
+
+ if (lsame_(side, "L")) {
+ cgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b20, &q[
+ q_offset], lda, &c__[c_offset], lda, &c_b21, &cc[
+ cc_offset], lda);
+ } else {
+ cgemm_("No transpose", trans, &mc, &nc, &nc, &c_b20, &c__[
+ c_offset], lda, &q[q_offset], lda, &c_b21, &cc[
+ cc_offset], lda);
+ }
+
+/* Compute error in the difference */
+
+ resid = clange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
+ result[(iside - 1 << 1) + itrans] = resid / ((real) max(1,*m) *
+ cnorm * eps);
+
+/* L20: */
+ }
+/* L30: */
+ }
+
+ return 0;
+
+/* End of CQRT03 */
+
+} /* cqrt03_ */
diff --git a/TESTING/LIN/cqrt11.c b/TESTING/LIN/cqrt11.c
new file mode 100644
index 0000000..25459b3
--- /dev/null
+++ b/TESTING/LIN/cqrt11.c
@@ -0,0 +1,160 @@
+/* cqrt11.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__7 = 7;
+static complex c_b5 = {0.f,0.f};
+static complex c_b6 = {1.f,0.f};
+
+doublereal cqrt11_(integer *m, integer *k, complex *a, integer *lda, complex *
+ tau, complex *work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real ret_val;
+ complex q__1;
+
+ /* Local variables */
+ integer j, info;
+ extern /* Subroutine */ int cunm2r_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), xerbla_(char *,
+ integer *);
+ real rdummy[1];
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CQRT11 computes the test ratio */
+
+/* || Q'*Q - I || / (eps * m) */
+
+/* where the orthogonal matrix Q is represented as a product of */
+/* elementary transformations. Each transformation has the form */
+
+/* H(k) = I - tau(k) v(k) v(k)' */
+
+/* where tau(k) is stored in TAU(k) and v(k) is an m-vector of the form */
+/* [ 0 ... 0 1 x(k) ]', where x(k) is a vector of length m-k stored */
+/* in A(k+1:m,k). */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* K (input) INTEGER */
+/* The number of columns of A whose subdiagonal entries */
+/* contain information about orthogonal transformations. */
+
+/* A (input) COMPLEX array, dimension (LDA,K) */
+/* The (possibly partial) output of a QR reduction routine. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* TAU (input) COMPLEX array, dimension (K) */
+/* The scaling factors tau for the elementary transformations as */
+/* computed by the QR factorization routine. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= M*M + M. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+/* Test for sufficient workspace */
+
+ if (*lwork < *m * *m + *m) {
+ xerbla_("CQRT11", &c__7);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0) {
+ return ret_val;
+ }
+
+ claset_("Full", m, m, &c_b5, &c_b6, &work[1], m);
+
+/* Form Q */
+
+ cunm2r_("Left", "No transpose", m, m, k, &a[a_offset], lda, &tau[1], &
+ work[1], m, &work[*m * *m + 1], &info);
+
+/* Form Q'*Q */
+
+ cunm2r_("Left", "Conjugate transpose", m, m, k, &a[a_offset], lda, &tau[1]
+, &work[1], m, &work[*m * *m + 1], &info);
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (j - 1) * *m + j;
+ i__3 = (j - 1) * *m + j;
+ q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L10: */
+ }
+
+ ret_val = clange_("One-norm", m, m, &work[1], m, rdummy) / ((
+ real) (*m) * slamch_("Epsilon"));
+
+ return ret_val;
+
+/* End of CQRT11 */
+
+} /* cqrt11_ */
diff --git a/TESTING/LIN/cqrt12.c b/TESTING/LIN/cqrt12.c
new file mode 100644
index 0000000..8484550
--- /dev/null
+++ b/TESTING/LIN/cqrt12.c
@@ -0,0 +1,227 @@
+/* cqrt12.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__7 = 7;
+static integer c__1 = 1;
+static complex c_b6 = {0.f,0.f};
+static integer c__0 = 0;
+static real c_b33 = -1.f;
+
+doublereal cqrt12_(integer *m, integer *n, complex *a, integer *lda, real *s,
+ complex *work, integer *lwork, real *rwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ real ret_val;
+
+ /* Local variables */
+ integer i__, j, mn, iscl, info;
+ real anrm;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ extern /* Subroutine */ int cgebd2_(integer *, integer *, complex *,
+ integer *, real *, real *, complex *, complex *, complex *,
+ integer *);
+ extern doublereal sasum_(integer *, real *, integer *);
+ real dummy[1];
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *), slabad_(real *, real *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), xerbla_(char *,
+ integer *);
+ real bignum;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *), sbdsqr_(char *, integer *, integer *, integer *, integer
+ *, real *, real *, real *, integer *, real *, integer *, real *,
+ integer *, real *, integer *);
+ real smlnum, nrmsvl;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CQRT12 computes the singular values `svlues' of the upper trapezoid */
+/* of A(1:M,1:N) and returns the ratio */
+
+/* || s - svlues||/(||svlues||*eps*max(M,N)) */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The M-by-N matrix A. Only the upper trapezoid is referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* S (input) REAL array, dimension (min(M,N)) */
+/* The singular values of the matrix A. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= M*N + 2*min(M,N) + */
+/* max(M,N). */
+
+/* RWORK (workspace) REAL array, dimension (4*min(M,N)) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+/* Test that enough workspace is supplied */
+
+ if (*lwork < *m * *n + (min(*m,*n) << 1) + max(*m,*n)) {
+ xerbla_("CQRT12", &c__7);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ mn = min(*m,*n);
+ if ((real) mn <= 0.f) {
+ return ret_val;
+ }
+
+ nrmsvl = snrm2_(&mn, &s[1], &c__1);
+
+/* Copy upper triangle of A into work */
+
+ claset_("Full", m, n, &c_b6, &c_b6, &work[1], m);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(j,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = (j - 1) * *m + i__;
+ i__4 = i__ + j * a_dim1;
+ work[i__3].r = a[i__4].r, work[i__3].i = a[i__4].i;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Get machine parameters */
+
+ smlnum = slamch_("S") / slamch_("P");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Scale work if max entry outside range [SMLNUM,BIGNUM] */
+
+ anrm = clange_("M", m, n, &work[1], m, dummy);
+ iscl = 0;
+ if (anrm > 0.f && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ clascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &work[1], m, &info);
+ iscl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ clascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &work[1], m, &info);
+ iscl = 1;
+ }
+
+ if (anrm != 0.f) {
+
+/* Compute SVD of work */
+
+ cgebd2_(m, n, &work[1], m, &rwork[1], &rwork[mn + 1], &work[*m * *n +
+ 1], &work[*m * *n + mn + 1], &work[*m * *n + (mn << 1) + 1], &
+ info);
+ sbdsqr_("Upper", &mn, &c__0, &c__0, &c__0, &rwork[1], &rwork[mn + 1],
+ dummy, &mn, dummy, &c__1, dummy, &mn, &rwork[(mn << 1) + 1], &
+ info);
+
+ if (iscl == 1) {
+ if (anrm > bignum) {
+ slascl_("G", &c__0, &c__0, &bignum, &anrm, &mn, &c__1, &rwork[
+ 1], &mn, &info);
+ }
+ if (anrm < smlnum) {
+ slascl_("G", &c__0, &c__0, &smlnum, &anrm, &mn, &c__1, &rwork[
+ 1], &mn, &info);
+ }
+ }
+
+ } else {
+
+ i__1 = mn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ rwork[i__] = 0.f;
+/* L30: */
+ }
+ }
+
+/* Compare s and singular values of work */
+
+ saxpy_(&mn, &c_b33, &s[1], &c__1, &rwork[1], &c__1);
+ ret_val = sasum_(&mn, &rwork[1], &c__1) / (slamch_("Epsilon") *
+ (real) max(*m,*n));
+ if (nrmsvl != 0.f) {
+ ret_val /= nrmsvl;
+ }
+
+ return ret_val;
+
+/* End of CQRT12 */
+
+} /* cqrt12_ */
diff --git a/TESTING/LIN/cqrt13.c b/TESTING/LIN/cqrt13.c
new file mode 100644
index 0000000..b8aa062
--- /dev/null
+++ b/TESTING/LIN/cqrt13.c
@@ -0,0 +1,166 @@
+/* cqrt13.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c__0 = 0;
+
+/* Subroutine */ int cqrt13_(integer *scale, integer *m, integer *n, complex *
+ a, integer *lda, real *norma, integer *iseed)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_sign(real *, real *);
+
+ /* Local variables */
+ integer j, info;
+ real dummy[1];
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ real bignum;
+ extern /* Subroutine */ int clarnv_(integer *, integer *, integer *,
+ complex *);
+ extern doublereal scasum_(integer *, complex *, integer *);
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CQRT13 generates a full-rank matrix that may be scaled to have large */
+/* or small norm. */
+
+/* Arguments */
+/* ========= */
+
+/* SCALE (input) INTEGER */
+/* SCALE = 1: normally scaled matrix */
+/* SCALE = 2: matrix scaled up */
+/* SCALE = 3: matrix scaled down */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of A. */
+
+/* A (output) COMPLEX array, dimension (LDA,N) */
+/* The M-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* NORMA (output) REAL */
+/* The one-norm of A. */
+
+/* ISEED (input/output) integer array, dimension (4) */
+/* Seed for random number generator */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iseed;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+/* benign matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ clarnv_(&c__2, &iseed[1], m, &a[j * a_dim1 + 1]);
+ if (j <= *m) {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ r__2 = scasum_(m, &a[j * a_dim1 + 1], &c__1);
+ i__4 = j + j * a_dim1;
+ r__3 = a[i__4].r;
+ r__1 = r_sign(&r__2, &r__3);
+ q__2.r = r__1, q__2.i = 0.f;
+ q__1.r = a[i__3].r + q__2.r, q__1.i = a[i__3].i + q__2.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ }
+/* L10: */
+ }
+
+/* scaled versions */
+
+ if (*scale != 1) {
+ *norma = clange_("Max", m, n, &a[a_offset], lda, dummy);
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ smlnum /= slamch_("Epsilon");
+ bignum = 1.f / smlnum;
+
+ if (*scale == 2) {
+
+/* matrix scaled up */
+
+ clascl_("General", &c__0, &c__0, norma, &bignum, m, n, &a[
+ a_offset], lda, &info);
+ } else if (*scale == 3) {
+
+/* matrix scaled down */
+
+ clascl_("General", &c__0, &c__0, norma, &smlnum, m, n, &a[
+ a_offset], lda, &info);
+ }
+ }
+
+ *norma = clange_("One-norm", m, n, &a[a_offset], lda, dummy);
+ return 0;
+
+/* End of CQRT13 */
+
+} /* cqrt13_ */
diff --git a/TESTING/LIN/cqrt14.c b/TESTING/LIN/cqrt14.c
new file mode 100644
index 0000000..f763e50
--- /dev/null
+++ b/TESTING/LIN/cqrt14.c
@@ -0,0 +1,268 @@
+/* cqrt14.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__10 = 10;
+static integer c__1 = 1;
+static integer c__0 = 0;
+static real c_b15 = 1.f;
+
+doublereal cqrt14_(char *trans, integer *m, integer *n, integer *nrhs,
+ complex *a, integer *lda, complex *x, integer *ldx, complex *work,
+ integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, x_dim1, x_offset, i__1, i__2, i__3;
+ real ret_val, r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j;
+ real err;
+ integer info;
+ real anrm;
+ logical tpsd;
+ real xnrm;
+ extern logical lsame_(char *, char *);
+ real rwork[1];
+ extern /* Subroutine */ int cgelq2_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *), cgeqr2_(integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), xerbla_(char *,
+ integer *);
+ integer ldwork;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CQRT14 checks whether X is in the row space of A or A'. It does so */
+/* by scaling both X and A such that their norms are in the range */
+/* [sqrt(eps), 1/sqrt(eps)], then computing a QR factorization of [A,X] */
+/* (if TRANS = 'C') or an LQ factorization of [A',X]' (if TRANS = 'N'), */
+/* and returning the norm of the trailing triangle, scaled by */
+/* MAX(M,N,NRHS)*eps. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, check for X in the row space of A */
+/* = 'C': Conjugate transpose, check for X in row space of A'. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of X. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The M-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* If TRANS = 'N', the N-by-NRHS matrix X. */
+/* IF TRANS = 'C', the M-by-NRHS matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. */
+
+/* WORK (workspace) COMPLEX array dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* length of workspace array required */
+/* If TRANS = 'N', LWORK >= (M+NRHS)*(N+2); */
+/* if TRANS = 'C', LWORK >= (N+NRHS)*(M+2). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.f;
+ if (lsame_(trans, "N")) {
+ ldwork = *m + *nrhs;
+ tpsd = FALSE_;
+ if (*lwork < (*m + *nrhs) * (*n + 2)) {
+ xerbla_("CQRT14", &c__10);
+ return ret_val;
+ } else if (*n <= 0 || *nrhs <= 0) {
+ return ret_val;
+ }
+ } else if (lsame_(trans, "C")) {
+ ldwork = *m;
+ tpsd = TRUE_;
+ if (*lwork < (*n + *nrhs) * (*m + 2)) {
+ xerbla_("CQRT14", &c__10);
+ return ret_val;
+ } else if (*m <= 0 || *nrhs <= 0) {
+ return ret_val;
+ }
+ } else {
+ xerbla_("CQRT14", &c__1);
+ return ret_val;
+ }
+
+/* Copy and scale A */
+
+ clacpy_("All", m, n, &a[a_offset], lda, &work[1], &ldwork);
+ anrm = clange_("M", m, n, &work[1], &ldwork, rwork);
+ if (anrm != 0.f) {
+ clascl_("G", &c__0, &c__0, &anrm, &c_b15, m, n, &work[1], &ldwork, &
+ info);
+ }
+
+/* Copy X or X' into the right place and scale it */
+
+ if (tpsd) {
+
+/* Copy X into columns n+1:n+nrhs of work */
+
+ clacpy_("All", m, nrhs, &x[x_offset], ldx, &work[*n * ldwork + 1], &
+ ldwork);
+ xnrm = clange_("M", m, nrhs, &work[*n * ldwork + 1], &ldwork, rwork);
+ if (xnrm != 0.f) {
+ clascl_("G", &c__0, &c__0, &xnrm, &c_b15, m, nrhs, &work[*n *
+ ldwork + 1], &ldwork, &info);
+ }
+ i__1 = *n + *nrhs;
+ anrm = clange_("One-norm", m, &i__1, &work[1], &ldwork, rwork);
+
+/* Compute QR factorization of X */
+
+ i__1 = *n + *nrhs;
+/* Computing MIN */
+ i__2 = *m, i__3 = *n + *nrhs;
+ cgeqr2_(m, &i__1, &work[1], &ldwork, &work[ldwork * (*n + *nrhs) + 1],
+ &work[ldwork * (*n + *nrhs) + min(i__2, i__3)+ 1], &info);
+
+/* Compute largest entry in upper triangle of */
+/* work(n+1:m,n+1:n+nrhs) */
+
+ err = 0.f;
+ i__1 = *n + *nrhs;
+ for (j = *n + 1; j <= i__1; ++j) {
+ i__2 = min(*m,j);
+ for (i__ = *n + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = err, r__2 = c_abs(&work[i__ + (j - 1) * *m]);
+ err = dmax(r__1,r__2);
+/* L10: */
+ }
+/* L20: */
+ }
+
+ } else {
+
+/* Copy X' into rows m+1:m+nrhs of work */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *nrhs;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = *m + j + (i__ - 1) * ldwork;
+ r_cnjg(&q__1, &x[i__ + j * x_dim1]);
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+
+ xnrm = clange_("M", nrhs, n, &work[*m + 1], &ldwork, rwork)
+ ;
+ if (xnrm != 0.f) {
+ clascl_("G", &c__0, &c__0, &xnrm, &c_b15, nrhs, n, &work[*m + 1],
+ &ldwork, &info);
+ }
+
+/* Compute LQ factorization of work */
+
+ cgelq2_(&ldwork, n, &work[1], &ldwork, &work[ldwork * *n + 1], &work[
+ ldwork * (*n + 1) + 1], &info);
+
+/* Compute largest entry in lower triangle in */
+/* work(m+1:m+nrhs,m+1:n) */
+
+ err = 0.f;
+ i__1 = *n;
+ for (j = *m + 1; j <= i__1; ++j) {
+ i__2 = ldwork;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__1 = err, r__2 = c_abs(&work[i__ + (j - 1) * ldwork]);
+ err = dmax(r__1,r__2);
+/* L50: */
+ }
+/* L60: */
+ }
+
+ }
+
+/* Computing MAX */
+ i__1 = max(*m,*n);
+ ret_val = err / ((real) max(i__1,*nrhs) * slamch_("Epsilon"));
+
+ return ret_val;
+
+/* End of CQRT14 */
+
+} /* cqrt14_ */
diff --git a/TESTING/LIN/cqrt15.c b/TESTING/LIN/cqrt15.c
new file mode 100644
index 0000000..8b9dba1
--- /dev/null
+++ b/TESTING/LIN/cqrt15.c
@@ -0,0 +1,304 @@
+/* cqrt15.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__16 = 16;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static complex c_b22 = {2.f,0.f};
+static integer c__0 = 0;
+
+/* Subroutine */ int cqrt15_(integer *scale, integer *rksel, integer *m,
+ integer *n, integer *nrhs, complex *a, integer *lda, complex *b,
+ integer *ldb, real *s, integer *rank, real *norma, real *normb,
+ integer *iseed, complex *work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+ real r__1;
+
+ /* Local variables */
+ integer j, mn;
+ real eps;
+ integer info;
+ real temp;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), clarf_(char *,
+ integer *, integer *, complex *, integer *, complex *, complex *,
+ integer *, complex *);
+ extern doublereal sasum_(integer *, real *, integer *);
+ real dummy[1];
+ extern doublereal scnrm2_(integer *, complex *, integer *);
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), claset_(char *, integer *, integer *, complex *, complex *,
+ complex *, integer *), xerbla_(char *, integer *);
+ real bignum;
+ extern /* Subroutine */ int claror_(char *, char *, integer *, integer *,
+ complex *, integer *, integer *, complex *, integer *);
+ extern doublereal slarnd_(integer *, integer *);
+ extern /* Subroutine */ int slaord_(char *, integer *, real *, integer *), clarnv_(integer *, integer *, integer *, complex *),
+ slascl_(char *, integer *, integer *, real *, real *, integer *,
+ integer *, real *, integer *, integer *);
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CQRT15 generates a matrix with full or deficient rank and of various */
+/* norms. */
+
+/* Arguments */
+/* ========= */
+
+/* SCALE (input) INTEGER */
+/* SCALE = 1: normally scaled matrix */
+/* SCALE = 2: matrix scaled up */
+/* SCALE = 3: matrix scaled down */
+
+/* RKSEL (input) INTEGER */
+/* RKSEL = 1: full rank matrix */
+/* RKSEL = 2: rank-deficient matrix */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of A. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. */
+
+/* A (output) COMPLEX array, dimension (LDA,N) */
+/* The M-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* B (output) COMPLEX array, dimension (LDB, NRHS) */
+/* A matrix that is in the range space of matrix A. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. */
+
+/* S (output) REAL array, dimension MIN(M,N) */
+/* Singular values of A. */
+
+/* RANK (output) INTEGER */
+/* number of nonzero singular values of A. */
+
+/* NORMA (output) REAL */
+/* one-norm norm of A. */
+
+/* NORMB (output) REAL */
+/* one-norm norm of B. */
+
+/* ISEED (input/output) integer array, dimension (4) */
+/* seed for random number generator. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* length of work space required. */
+/* LWORK >= MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --s;
+ --iseed;
+ --work;
+
+ /* Function Body */
+ mn = min(*m,*n);
+/* Computing MAX */
+ i__1 = *m + mn, i__2 = mn * *nrhs, i__1 = max(i__1,i__2), i__2 = (*n << 1)
+ + *m;
+ if (*lwork < max(i__1,i__2)) {
+ xerbla_("CQRT15", &c__16);
+ return 0;
+ }
+
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ eps = slamch_("Epsilon");
+ smlnum = smlnum / eps / eps;
+ bignum = 1.f / smlnum;
+
+/* Determine rank and (unscaled) singular values */
+
+ if (*rksel == 1) {
+ *rank = mn;
+ } else if (*rksel == 2) {
+ *rank = mn * 3 / 4;
+ i__1 = mn;
+ for (j = *rank + 1; j <= i__1; ++j) {
+ s[j] = 0.f;
+/* L10: */
+ }
+ } else {
+ xerbla_("CQRT15", &c__2);
+ }
+
+ if (*rank > 0) {
+
+/* Nontrivial case */
+
+ s[1] = 1.f;
+ i__1 = *rank;
+ for (j = 2; j <= i__1; ++j) {
+L20:
+ temp = slarnd_(&c__1, &iseed[1]);
+ if (temp > .1f) {
+ s[j] = dabs(temp);
+ } else {
+ goto L20;
+ }
+/* L30: */
+ }
+ slaord_("Decreasing", rank, &s[1], &c__1);
+
+/* Generate 'rank' columns of a random orthogonal matrix in A */
+
+ clarnv_(&c__2, &iseed[1], m, &work[1]);
+ r__1 = 1.f / scnrm2_(m, &work[1], &c__1);
+ csscal_(m, &r__1, &work[1], &c__1);
+ claset_("Full", m, rank, &c_b1, &c_b2, &a[a_offset], lda);
+ clarf_("Left", m, rank, &work[1], &c__1, &c_b22, &a[a_offset], lda, &
+ work[*m + 1]);
+
+/* workspace used: m+mn */
+
+/* Generate consistent rhs in the range space of A */
+
+ i__1 = *rank * *nrhs;
+ clarnv_(&c__2, &iseed[1], &i__1, &work[1]);
+ cgemm_("No transpose", "No transpose", m, nrhs, rank, &c_b2, &a[
+ a_offset], lda, &work[1], rank, &c_b1, &b[b_offset], ldb);
+
+/* work space used: <= mn *nrhs */
+
+/* generate (unscaled) matrix A */
+
+ i__1 = *rank;
+ for (j = 1; j <= i__1; ++j) {
+ csscal_(m, &s[j], &a[j * a_dim1 + 1], &c__1);
+/* L40: */
+ }
+ if (*rank < *n) {
+ i__1 = *n - *rank;
+ claset_("Full", m, &i__1, &c_b1, &c_b1, &a[(*rank + 1) * a_dim1 +
+ 1], lda);
+ }
+ claror_("Right", "No initialization", m, n, &a[a_offset], lda, &iseed[
+ 1], &work[1], &info);
+
+ } else {
+
+/* work space used 2*n+m */
+
+/* Generate null matrix and rhs */
+
+ i__1 = mn;
+ for (j = 1; j <= i__1; ++j) {
+ s[j] = 0.f;
+/* L50: */
+ }
+ claset_("Full", m, n, &c_b1, &c_b1, &a[a_offset], lda);
+ claset_("Full", m, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+
+ }
+
+/* Scale the matrix */
+
+ if (*scale != 1) {
+ *norma = clange_("Max", m, n, &a[a_offset], lda, dummy);
+ if (*norma != 0.f) {
+ if (*scale == 2) {
+
+/* matrix scaled up */
+
+ clascl_("General", &c__0, &c__0, norma, &bignum, m, n, &a[
+ a_offset], lda, &info);
+ slascl_("General", &c__0, &c__0, norma, &bignum, &mn, &c__1, &
+ s[1], &mn, &info);
+ clascl_("General", &c__0, &c__0, norma, &bignum, m, nrhs, &b[
+ b_offset], ldb, &info);
+ } else if (*scale == 3) {
+
+/* matrix scaled down */
+
+ clascl_("General", &c__0, &c__0, norma, &smlnum, m, n, &a[
+ a_offset], lda, &info);
+ slascl_("General", &c__0, &c__0, norma, &smlnum, &mn, &c__1, &
+ s[1], &mn, &info);
+ clascl_("General", &c__0, &c__0, norma, &smlnum, m, nrhs, &b[
+ b_offset], ldb, &info);
+ } else {
+ xerbla_("CQRT15", &c__1);
+ return 0;
+ }
+ }
+ }
+
+ *norma = sasum_(&mn, &s[1], &c__1);
+ *normb = clange_("One-norm", m, nrhs, &b[b_offset], ldb, dummy)
+ ;
+
+ return 0;
+
+/* End of CQRT15 */
+
+} /* cqrt15_ */
diff --git a/TESTING/LIN/cqrt16.c b/TESTING/LIN/cqrt16.c
new file mode 100644
index 0000000..c870088
--- /dev/null
+++ b/TESTING/LIN/cqrt16.c
@@ -0,0 +1,185 @@
+/* cqrt16.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cqrt16_(char *trans, integer *m, integer *n, integer *
+ nrhs, complex *a, integer *lda, complex *x, integer *ldx, complex *b,
+ integer *ldb, real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Local variables */
+ integer j, n1, n2;
+ real eps;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ real anorm, bnorm, xnorm;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *), scasum_(
+ integer *, complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CQRT16 computes the residual for a solution of a system of linear */
+/* equations A*x = b or A'*x = b: */
+/* RESID = norm(B - A*X) / ( max(m,n) * norm(A) * norm(X) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A *x = b */
+/* = 'T': A^T*x = b, where A^T is the transpose of A */
+/* = 'C': A^H*x = b, where A^H is the conjugate transpose of A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The original M x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. IF TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( max(m,n) * norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if M = 0 or N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0 || *nrhs == 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+ if (lsame_(trans, "T") || lsame_(trans, "C")) {
+ anorm = clange_("I", m, n, &a[a_offset], lda, &rwork[1]);
+ n1 = *n;
+ n2 = *m;
+ } else {
+ anorm = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ n1 = *m;
+ n2 = *n;
+ }
+
+ eps = slamch_("Epsilon");
+
+/* Compute B - A*X (or B - A'*X ) and store in B. */
+
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_(trans, "No transpose", &n1, nrhs, &n2, &q__1, &a[a_offset], lda, &
+ x[x_offset], ldx, &c_b1, &b[b_offset], ldb)
+ ;
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( max(m,n) * norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = scasum_(&n1, &b[j * b_dim1 + 1], &c__1);
+ xnorm = scasum_(&n2, &x[j * x_dim1 + 1], &c__1);
+ if (anorm == 0.f && bnorm == 0.f) {
+ *resid = 0.f;
+ } else if (anorm <= 0.f || xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / (max(*m,*n) * eps);
+ *resid = dmax(r__1,r__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of CQRT16 */
+
+} /* cqrt16_ */
diff --git a/TESTING/LIN/cqrt17.c b/TESTING/LIN/cqrt17.c
new file mode 100644
index 0000000..0d32374
--- /dev/null
+++ b/TESTING/LIN/cqrt17.c
@@ -0,0 +1,240 @@
+/* cqrt17.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__13 = 13;
+static complex c_b13 = {-1.f,0.f};
+static complex c_b14 = {1.f,0.f};
+static integer c__0 = 0;
+static real c_b19 = 1.f;
+static complex c_b22 = {0.f,0.f};
+
+doublereal cqrt17_(char *trans, integer *iresid, integer *m, integer *n,
+ integer *nrhs, complex *a, integer *lda, complex *x, integer *ldx,
+ complex *b, integer *ldb, complex *c__, complex *work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, x_dim1,
+ x_offset, i__1;
+ real ret_val;
+
+ /* Local variables */
+ real err;
+ integer iscl, info;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ real norma, normb;
+ integer ncols;
+ real normx, rwork[1];
+ integer nrows;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, complex *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), xerbla_(char *,
+ integer *);
+ real bignum, smlnum, normrs;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CQRT17 computes the ratio */
+
+/* || R'*op(A) ||/(||A||*alpha*max(M,N,NRHS)*eps) */
+
+/* where R = op(A)*X - B, op(A) is A or A', and */
+
+/* alpha = ||B|| if IRESID = 1 (zero-residual problem) */
+/* alpha = ||R|| if IRESID = 2 (otherwise). */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies whether or not the transpose of A is used. */
+/* = 'N': No transpose, op(A) = A. */
+/* = 'C': Conjugate transpose, op(A) = A'. */
+
+/* IRESID (input) INTEGER */
+/* IRESID = 1 indicates zero-residual problem. */
+/* IRESID = 2 indicates non-zero residual. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+/* If TRANS = 'N', the number of rows of the matrix B. */
+/* If TRANS = 'C', the number of rows of the matrix X. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+/* If TRANS = 'N', the number of rows of the matrix X. */
+/* If TRANS = 'C', the number of rows of the matrix B. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X and B. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The m-by-n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* If TRANS = 'N', the n-by-nrhs matrix X. */
+/* If TRANS = 'C', the m-by-nrhs matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. */
+/* If TRANS = 'N', LDX >= N. */
+/* If TRANS = 'C', LDX >= M. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* If TRANS = 'N', the m-by-nrhs matrix B. */
+/* If TRANS = 'C', the n-by-nrhs matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. */
+/* If TRANS = 'N', LDB >= M. */
+/* If TRANS = 'C', LDB >= N. */
+
+/* C (workspace) COMPLEX array, dimension (LDB,NRHS) */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= NRHS*(M+N). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ c_dim1 = *ldb;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ if (lsame_(trans, "N")) {
+ nrows = *m;
+ ncols = *n;
+ } else if (lsame_(trans, "C")) {
+ nrows = *n;
+ ncols = *m;
+ } else {
+ xerbla_("CQRT17", &c__1);
+ return ret_val;
+ }
+
+ if (*lwork < ncols * *nrhs) {
+ xerbla_("CQRT17", &c__13);
+ return ret_val;
+ }
+
+ if (*m <= 0 || *n <= 0 || *nrhs <= 0) {
+ return ret_val;
+ }
+
+ norma = clange_("One-norm", m, n, &a[a_offset], lda, rwork);
+ smlnum = slamch_("Safe minimum") / slamch_("Precision");
+ bignum = 1.f / smlnum;
+ iscl = 0;
+
+/* compute residual and scale it */
+
+ clacpy_("All", &nrows, nrhs, &b[b_offset], ldb, &c__[c_offset], ldb);
+ cgemm_(trans, "No transpose", &nrows, nrhs, &ncols, &c_b13, &a[a_offset],
+ lda, &x[x_offset], ldx, &c_b14, &c__[c_offset], ldb);
+ normrs = clange_("Max", &nrows, nrhs, &c__[c_offset], ldb, rwork);
+ if (normrs > smlnum) {
+ iscl = 1;
+ clascl_("General", &c__0, &c__0, &normrs, &c_b19, &nrows, nrhs, &c__[
+ c_offset], ldb, &info);
+ }
+
+/* compute R'*A */
+
+ cgemm_("Conjugate transpose", trans, nrhs, &ncols, &nrows, &c_b14, &c__[
+ c_offset], ldb, &a[a_offset], lda, &c_b22, &work[1], nrhs);
+
+/* compute and properly scale error */
+
+ err = clange_("One-norm", nrhs, &ncols, &work[1], nrhs, rwork);
+ if (norma != 0.f) {
+ err /= norma;
+ }
+
+ if (iscl == 1) {
+ err *= normrs;
+ }
+
+ if (*iresid == 1) {
+ normb = clange_("One-norm", &nrows, nrhs, &b[b_offset], ldb, rwork);
+ if (normb != 0.f) {
+ err /= normb;
+ }
+ } else {
+ normx = clange_("One-norm", &ncols, nrhs, &x[x_offset], ldx, rwork);
+ if (normx != 0.f) {
+ err /= normx;
+ }
+ }
+
+/* Computing MAX */
+ i__1 = max(*m,*n);
+ ret_val = err / (slamch_("Epsilon") * (real) max(i__1,*nrhs));
+ return ret_val;
+
+/* End of CQRT17 */
+
+} /* cqrt17_ */
diff --git a/TESTING/LIN/crqt01.c b/TESTING/LIN/crqt01.c
new file mode 100644
index 0000000..0fee9f5
--- /dev/null
+++ b/TESTING/LIN/crqt01.c
@@ -0,0 +1,255 @@
+/* crqt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static complex c_b1 = {-1e10f,-1e10f};
+static complex c_b12 = {0.f,0.f};
+static complex c_b19 = {-1.f,0.f};
+static complex c_b20 = {1.f,0.f};
+static real c_b28 = -1.f;
+static real c_b29 = 1.f;
+
+/* Subroutine */ int crqt01_(integer *m, integer *n, complex *a, complex *af,
+ complex *q, complex *r__, integer *lda, complex *tau, complex *work,
+ integer *lwork, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
+ r_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real eps;
+ integer info;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), cherk_(char *,
+ char *, integer *, integer *, real *, complex *, integer *, real *
+, complex *, integer *);
+ real resid, anorm;
+ integer minmn;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int cgerqf_(integer *, integer *, complex *,
+ integer *, complex *, complex *, integer *, integer *), clacpy_(
+ char *, integer *, integer *, complex *, integer *, complex *,
+ integer *), claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *);
+ extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
+ real *);
+ extern /* Subroutine */ int cungrq_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CRQT01 tests CGERQF, which computes the RQ factorization of an m-by-n */
+/* matrix A, and partially tests CUNGRQ which forms the n-by-n */
+/* orthogonal matrix Q. */
+
+/* CRQT01 compares R with A*Q', and checks that Q is orthogonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The m-by-n matrix A. */
+
+/* AF (output) COMPLEX array, dimension (LDA,N) */
+/* Details of the RQ factorization of A, as returned by CGERQF. */
+/* See CGERQF for further details. */
+
+/* Q (output) COMPLEX array, dimension (LDA,N) */
+/* The n-by-n orthogonal matrix Q. */
+
+/* R (workspace) COMPLEX array, dimension (LDA,max(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and L. */
+/* LDA >= max(M,N). */
+
+/* TAU (output) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by CGERQF. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) REAL array, dimension (max(M,N)) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ minmn = min(*m,*n);
+ eps = slamch_("Epsilon");
+
+/* Copy the matrix A to the array AF. */
+
+ clacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+
+/* Factorize the matrix A in the array AF. */
+
+ s_copy(srnamc_1.srnamt, "CGERQF", (ftnlen)32, (ftnlen)6);
+ cgerqf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy details of Q */
+
+ claset_("Full", n, n, &c_b1, &c_b1, &q[q_offset], lda);
+ if (*m <= *n) {
+ if (*m > 0 && *m < *n) {
+ i__1 = *n - *m;
+ clacpy_("Full", m, &i__1, &af[af_offset], lda, &q[*n - *m + 1 +
+ q_dim1], lda);
+ }
+ if (*m > 1) {
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ clacpy_("Lower", &i__1, &i__2, &af[(*n - *m + 1) * af_dim1 + 2],
+ lda, &q[*n - *m + 2 + (*n - *m + 1) * q_dim1], lda);
+ }
+ } else {
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ clacpy_("Lower", &i__1, &i__2, &af[*m - *n + 2 + af_dim1], lda, &
+ q[q_dim1 + 2], lda);
+ }
+ }
+
+/* Generate the n-by-n matrix Q */
+
+ s_copy(srnamc_1.srnamt, "CUNGRQ", (ftnlen)32, (ftnlen)6);
+ cungrq_(n, n, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy R */
+
+ claset_("Full", m, n, &c_b12, &c_b12, &r__[r_offset], lda);
+ if (*m <= *n) {
+ if (*m > 0) {
+ clacpy_("Upper", m, m, &af[(*n - *m + 1) * af_dim1 + 1], lda, &
+ r__[(*n - *m + 1) * r_dim1 + 1], lda);
+ }
+ } else {
+ if (*m > *n && *n > 0) {
+ i__1 = *m - *n;
+ clacpy_("Full", &i__1, n, &af[af_offset], lda, &r__[r_offset],
+ lda);
+ }
+ if (*n > 0) {
+ clacpy_("Upper", n, n, &af[*m - *n + 1 + af_dim1], lda, &r__[*m -
+ *n + 1 + r_dim1], lda);
+ }
+ }
+
+/* Compute R - A*Q' */
+
+ cgemm_("No transpose", "Conjugate transpose", m, n, n, &c_b19, &a[
+ a_offset], lda, &q[q_offset], lda, &c_b20, &r__[r_offset], lda);
+
+/* Compute norm( R - Q'*A ) / ( N * norm(A) * EPS ) . */
+
+ anorm = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ resid = clange_("1", m, n, &r__[r_offset], lda, &rwork[1]);
+ if (anorm > 0.f) {
+ result[1] = resid / (real) max(1,*n) / anorm / eps;
+ } else {
+ result[1] = 0.f;
+ }
+
+/* Compute I - Q*Q' */
+
+ claset_("Full", n, n, &c_b12, &c_b20, &r__[r_offset], lda);
+ cherk_("Upper", "No transpose", n, n, &c_b28, &q[q_offset], lda, &c_b29, &
+ r__[r_offset], lda);
+
+/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
+
+ resid = clansy_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
+
+ result[2] = resid / (real) max(1,*n) / eps;
+
+ return 0;
+
+/* End of CRQT01 */
+
+} /* crqt01_ */
diff --git a/TESTING/LIN/crqt02.c b/TESTING/LIN/crqt02.c
new file mode 100644
index 0000000..b9a73ac
--- /dev/null
+++ b/TESTING/LIN/crqt02.c
@@ -0,0 +1,238 @@
+/* crqt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static complex c_b1 = {-1e10f,-1e10f};
+static complex c_b9 = {0.f,0.f};
+static complex c_b14 = {-1.f,0.f};
+static complex c_b15 = {1.f,0.f};
+static real c_b23 = -1.f;
+static real c_b24 = 1.f;
+
+/* Subroutine */ int crqt02_(integer *m, integer *n, integer *k, complex *a,
+ complex *af, complex *q, complex *r__, integer *lda, complex *tau,
+ complex *work, integer *lwork, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
+ r_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real eps;
+ integer info;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *), cherk_(char *,
+ char *, integer *, integer *, real *, complex *, integer *, real *
+, complex *, integer *);
+ real resid, anorm;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *);
+ extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
+ real *);
+ extern /* Subroutine */ int cungrq_(integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CRQT02 tests CUNGRQ, which generates an m-by-n matrix Q with */
+/* orthonornmal rows that is defined as the product of k elementary */
+/* reflectors. */
+
+/* Given the RQ factorization of an m-by-n matrix A, CRQT02 generates */
+/* the orthogonal matrix Q defined by the factorization of the last k */
+/* rows of A; it compares R(m-k+1:m,n-m+1:n) with */
+/* A(m-k+1:m,1:n)*Q(n-m+1:n,1:n)', and checks that the rows of Q are */
+/* orthonormal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q to be generated. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q to be generated. */
+/* N >= M >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The m-by-n matrix A which was factorized by CRQT01. */
+
+/* AF (input) COMPLEX array, dimension (LDA,N) */
+/* Details of the RQ factorization of A, as returned by CGERQF. */
+/* See CGERQF for further details. */
+
+/* Q (workspace) COMPLEX array, dimension (LDA,N) */
+
+/* R (workspace) COMPLEX array, dimension (LDA,M) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and L. LDA >= N. */
+
+/* TAU (input) COMPLEX array, dimension (M) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the RQ factorization in AF. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ if (*m == 0 || *n == 0 || *k == 0) {
+ result[1] = 0.f;
+ result[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+
+/* Copy the last k rows of the factorization to the array Q */
+
+ claset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
+ if (*k < *n) {
+ i__1 = *n - *k;
+ clacpy_("Full", k, &i__1, &af[*m - *k + 1 + af_dim1], lda, &q[*m - *k
+ + 1 + q_dim1], lda);
+ }
+ if (*k > 1) {
+ i__1 = *k - 1;
+ i__2 = *k - 1;
+ clacpy_("Lower", &i__1, &i__2, &af[*m - *k + 2 + (*n - *k + 1) *
+ af_dim1], lda, &q[*m - *k + 2 + (*n - *k + 1) * q_dim1], lda);
+ }
+
+/* Generate the last n rows of the matrix Q */
+
+ s_copy(srnamc_1.srnamt, "CUNGRQ", (ftnlen)32, (ftnlen)6);
+ cungrq_(m, n, k, &q[q_offset], lda, &tau[*m - *k + 1], &work[1], lwork, &
+ info);
+
+/* Copy R(m-k+1:m,n-m+1:n) */
+
+ claset_("Full", k, m, &c_b9, &c_b9, &r__[*m - *k + 1 + (*n - *m + 1) *
+ r_dim1], lda);
+ clacpy_("Upper", k, k, &af[*m - *k + 1 + (*n - *k + 1) * af_dim1], lda, &
+ r__[*m - *k + 1 + (*n - *k + 1) * r_dim1], lda);
+
+/* Compute R(m-k+1:m,n-m+1:n) - A(m-k+1:m,1:n) * Q(n-m+1:n,1:n)' */
+
+ cgemm_("No transpose", "Conjugate transpose", k, m, n, &c_b14, &a[*m - *k
+ + 1 + a_dim1], lda, &q[q_offset], lda, &c_b15, &r__[*m - *k + 1 +
+ (*n - *m + 1) * r_dim1], lda);
+
+/* Compute norm( R - A*Q' ) / ( N * norm(A) * EPS ) . */
+
+ anorm = clange_("1", k, n, &a[*m - *k + 1 + a_dim1], lda, &rwork[1]);
+ resid = clange_("1", k, m, &r__[*m - *k + 1 + (*n - *m + 1) * r_dim1],
+ lda, &rwork[1]);
+ if (anorm > 0.f) {
+ result[1] = resid / (real) max(1,*n) / anorm / eps;
+ } else {
+ result[1] = 0.f;
+ }
+
+/* Compute I - Q*Q' */
+
+ claset_("Full", m, m, &c_b9, &c_b15, &r__[r_offset], lda);
+ cherk_("Upper", "No transpose", m, n, &c_b23, &q[q_offset], lda, &c_b24, &
+ r__[r_offset], lda);
+
+/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
+
+ resid = clansy_("1", "Upper", m, &r__[r_offset], lda, &rwork[1]);
+
+ result[2] = resid / (real) max(1,*n) / eps;
+
+ return 0;
+
+/* End of CRQT02 */
+
+} /* crqt02_ */
diff --git a/TESTING/LIN/crqt03.c b/TESTING/LIN/crqt03.c
new file mode 100644
index 0000000..434b369
--- /dev/null
+++ b/TESTING/LIN/crqt03.c
@@ -0,0 +1,285 @@
+/* crqt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static complex c_b1 = {-1e10f,-1e10f};
+static integer c__2 = 2;
+static complex c_b21 = {-1.f,0.f};
+static complex c_b22 = {1.f,0.f};
+
+/* Subroutine */ int crqt03_(integer *m, integer *n, integer *k, complex *af,
+ complex *c__, complex *cc, complex *q, integer *lda, complex *tau,
+ complex *work, integer *lwork, real *rwork, real *result)
+{
+ /* Initialized data */
+
+ static integer iseed[4] = { 1988,1989,1990,1991 };
+
+ /* System generated locals */
+ integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1,
+ q_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j, mc, nc;
+ real eps;
+ char side[1];
+ integer info;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ integer iside;
+ extern logical lsame_(char *, char *);
+ real resid;
+ integer minmn;
+ real cnorm;
+ char trans[1];
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
+ *, integer *, complex *, integer *), claset_(char *,
+ integer *, integer *, complex *, complex *, complex *, integer *), clarnv_(integer *, integer *, integer *, complex *),
+ cungrq_(integer *, integer *, integer *, complex *, integer *,
+ complex *, complex *, integer *, integer *);
+ integer itrans;
+ extern /* Subroutine */ int cunmrq_(char *, char *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ complex *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CRQT03 tests CUNMRQ, which computes Q*C, Q'*C, C*Q or C*Q'. */
+
+/* CRQT03 compares the results of a call to CUNMRQ with the results of */
+/* forming Q explicitly by a call to CUNGRQ and then performing matrix */
+/* multiplication by a call to CGEMM. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows or columns of the matrix C; C is n-by-m if */
+/* Q is applied from the left, or m-by-n if Q is applied from */
+/* the right. M >= 0. */
+
+/* N (input) INTEGER */
+/* The order of the orthogonal matrix Q. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* orthogonal matrix Q. N >= K >= 0. */
+
+/* AF (input) COMPLEX array, dimension (LDA,N) */
+/* Details of the RQ factorization of an m-by-n matrix, as */
+/* returned by CGERQF. See CGERQF for further details. */
+
+/* C (workspace) COMPLEX array, dimension (LDA,N) */
+
+/* CC (workspace) COMPLEX array, dimension (LDA,N) */
+
+/* Q (workspace) COMPLEX array, dimension (LDA,N) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays AF, C, CC, and Q. */
+
+/* TAU (input) COMPLEX array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the RQ factorization in AF. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK must be at least M, and should be */
+/* M*NB, where NB is the blocksize for this environment. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (4) */
+/* The test ratios compare two techniques for multiplying a */
+/* random matrix C by an n-by-n orthogonal matrix Q. */
+/* RESULT(1) = norm( Q*C - Q*C ) / ( N * norm(C) * EPS ) */
+/* RESULT(2) = norm( C*Q - C*Q ) / ( N * norm(C) * EPS ) */
+/* RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS ) */
+/* RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ cc_dim1 = *lda;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+ c_dim1 = *lda;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = slamch_("Epsilon");
+ minmn = min(*m,*n);
+
+/* Quick return if possible */
+
+ if (minmn == 0) {
+ result[1] = 0.f;
+ result[2] = 0.f;
+ result[3] = 0.f;
+ result[4] = 0.f;
+ return 0;
+ }
+
+/* Copy the last k rows of the factorization to the array Q */
+
+ claset_("Full", n, n, &c_b1, &c_b1, &q[q_offset], lda);
+ if (*k > 0 && *n > *k) {
+ i__1 = *n - *k;
+ clacpy_("Full", k, &i__1, &af[*m - *k + 1 + af_dim1], lda, &q[*n - *k
+ + 1 + q_dim1], lda);
+ }
+ if (*k > 1) {
+ i__1 = *k - 1;
+ i__2 = *k - 1;
+ clacpy_("Lower", &i__1, &i__2, &af[*m - *k + 2 + (*n - *k + 1) *
+ af_dim1], lda, &q[*n - *k + 2 + (*n - *k + 1) * q_dim1], lda);
+ }
+
+/* Generate the n-by-n matrix Q */
+
+ s_copy(srnamc_1.srnamt, "CUNGRQ", (ftnlen)32, (ftnlen)6);
+ cungrq_(n, n, k, &q[q_offset], lda, &tau[minmn - *k + 1], &work[1], lwork,
+ &info);
+
+ for (iside = 1; iside <= 2; ++iside) {
+ if (iside == 1) {
+ *(unsigned char *)side = 'L';
+ mc = *n;
+ nc = *m;
+ } else {
+ *(unsigned char *)side = 'R';
+ mc = *m;
+ nc = *n;
+ }
+
+/* Generate MC by NC matrix C */
+
+ i__1 = nc;
+ for (j = 1; j <= i__1; ++j) {
+ clarnv_(&c__2, iseed, &mc, &c__[j * c_dim1 + 1]);
+/* L10: */
+ }
+ cnorm = clange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]);
+ if (cnorm == 0.f) {
+ cnorm = 1.f;
+ }
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+ if (itrans == 1) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'C';
+ }
+
+/* Copy C */
+
+ clacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
+ lda);
+
+/* Apply Q or Q' to C */
+
+ s_copy(srnamc_1.srnamt, "CUNMRQ", (ftnlen)32, (ftnlen)6);
+ if (*k > 0) {
+ cunmrq_(side, trans, &mc, &nc, k, &af[*m - *k + 1 + af_dim1],
+ lda, &tau[minmn - *k + 1], &cc[cc_offset], lda, &work[
+ 1], lwork, &info);
+ }
+
+/* Form explicit product and subtract */
+
+ if (lsame_(side, "L")) {
+ cgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b21, &q[
+ q_offset], lda, &c__[c_offset], lda, &c_b22, &cc[
+ cc_offset], lda);
+ } else {
+ cgemm_("No transpose", trans, &mc, &nc, &nc, &c_b21, &c__[
+ c_offset], lda, &q[q_offset], lda, &c_b22, &cc[
+ cc_offset], lda);
+ }
+
+/* Compute error in the difference */
+
+ resid = clange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
+ result[(iside - 1 << 1) + itrans] = resid / ((real) max(1,*n) *
+ cnorm * eps);
+
+/* L20: */
+ }
+/* L30: */
+ }
+
+ return 0;
+
+/* End of CRQT03 */
+
+} /* crqt03_ */
diff --git a/TESTING/LIN/crzt01.c b/TESTING/LIN/crzt01.c
new file mode 100644
index 0000000..24f2d02
--- /dev/null
+++ b/TESTING/LIN/crzt01.c
@@ -0,0 +1,173 @@
+/* crzt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static complex c_b6 = {0.f,0.f};
+static integer c__1 = 1;
+static complex c_b15 = {-1.f,0.f};
+
+doublereal crzt01_(integer *m, integer *n, complex *a, complex *af, integer *
+ lda, complex *tau, complex *work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
+ real ret_val;
+
+ /* Local variables */
+ integer i__, j, info;
+ real norma;
+ extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ real rwork[1];
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), xerbla_(char *,
+ integer *), cunmrz_(char *, char *, integer *, integer *,
+ integer *, integer *, complex *, integer *, complex *, complex *,
+ integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CRZT01 returns */
+/* || A - R*Q || / ( M * eps * ||A|| ) */
+/* for an upper trapezoidal A that was factored with CTZRZF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices A and AF. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and AF. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The original upper trapezoidal M by N matrix A. */
+
+/* AF (input) COMPLEX array, dimension (LDA,N) */
+/* The output of CTZRZF for input matrix A. */
+/* The lower triangle is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A and AF. */
+
+/* TAU (input) COMPLEX array, dimension (M) */
+/* Details of the Householder transformations as returned by */
+/* CTZRZF. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= m*n + m. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ if (*lwork < *m * *n + *m) {
+ xerbla_("CRZT01", &c__8);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return ret_val;
+ }
+
+ norma = clange_("One-norm", m, n, &a[a_offset], lda, rwork);
+
+/* Copy upper triangle R */
+
+ claset_("Full", m, n, &c_b6, &c_b6, &work[1], m);
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = (j - 1) * *m + i__;
+ i__4 = i__ + j * af_dim1;
+ work[i__3].r = af[i__4].r, work[i__3].i = af[i__4].i;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* R = R * P(1) * ... *P(m) */
+
+ i__1 = *n - *m;
+ i__2 = *lwork - *m * *n;
+ cunmrz_("Right", "No tranpose", m, n, m, &i__1, &af[af_offset], lda, &tau[
+ 1], &work[1], m, &work[*m * *n + 1], &i__2, &info);
+
+/* R = R - A */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ caxpy_(m, &c_b15, &a[i__ * a_dim1 + 1], &c__1, &work[(i__ - 1) * *m +
+ 1], &c__1);
+/* L30: */
+ }
+
+ ret_val = clange_("One-norm", m, n, &work[1], m, rwork);
+
+ ret_val /= slamch_("Epsilon") * (real) max(*m,*n);
+ if (norma != 0.f) {
+ ret_val /= norma;
+ }
+
+ return ret_val;
+
+/* End of CRZT01 */
+
+} /* crzt01_ */
diff --git a/TESTING/LIN/crzt02.c b/TESTING/LIN/crzt02.c
new file mode 100644
index 0000000..004a739
--- /dev/null
+++ b/TESTING/LIN/crzt02.c
@@ -0,0 +1,155 @@
+/* crzt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__7 = 7;
+static complex c_b5 = {0.f,0.f};
+static complex c_b6 = {1.f,0.f};
+
+doublereal crzt02_(integer *m, integer *n, complex *af, integer *lda, complex
+ *tau, complex *work, integer *lwork)
+{
+ /* System generated locals */
+ integer af_dim1, af_offset, i__1, i__2, i__3;
+ real ret_val;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, info;
+ real rwork[1];
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), xerbla_(char *,
+ integer *), cunmrz_(char *, char *, integer *, integer *,
+ integer *, integer *, complex *, integer *, complex *, complex *,
+ integer *, complex *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CRZT02 returns */
+/* || I - Q'*Q || / ( M * eps) */
+/* where the matrix Q is defined by the Householder transformations */
+/* generated by CTZRZF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix AF. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix AF. */
+
+/* AF (input) COMPLEX array, dimension (LDA,N) */
+/* The output of CTZRZF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array AF. */
+
+/* TAU (input) COMPLEX array, dimension (M) */
+/* Details of the Householder transformations as returned by */
+/* CTZRZF. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* Length of WORK array. LWORK >= N*N+N. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ if (*lwork < *n * *n + *n) {
+ xerbla_("CRZT02", &c__7);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return ret_val;
+ }
+
+/* Q := I */
+
+ claset_("Full", n, n, &c_b5, &c_b6, &work[1], n);
+
+/* Q := P(1) * ... * P(m) * Q */
+
+ i__1 = *n - *m;
+ i__2 = *lwork - *n * *n;
+ cunmrz_("Left", "No transpose", n, n, m, &i__1, &af[af_offset], lda, &tau[
+ 1], &work[1], n, &work[*n * *n + 1], &i__2, &info);
+
+/* Q := P(m)' * ... * P(1)' * Q */
+
+ i__1 = *n - *m;
+ i__2 = *lwork - *n * *n;
+ cunmrz_("Left", "Conjugate transpose", n, n, m, &i__1, &af[af_offset],
+ lda, &tau[1], &work[1], n, &work[*n * *n + 1], &i__2, &info);
+
+/* Q := Q - I */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = (i__ - 1) * *n + i__;
+ i__3 = (i__ - 1) * *n + i__;
+ q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L10: */
+ }
+
+ ret_val = clange_("One-norm", n, n, &work[1], n, rwork) / (
+ slamch_("Epsilon") * (real) max(*m,*n));
+ return ret_val;
+
+/* End of CRZT02 */
+
+} /* crzt02_ */
diff --git a/TESTING/LIN/csbmv.c b/TESTING/LIN/csbmv.c
new file mode 100644
index 0000000..09fcad9
--- /dev/null
+++ b/TESTING/LIN/csbmv.c
@@ -0,0 +1,479 @@
+/* csbmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int csbmv_(char *uplo, integer *n, integer *k, complex *
+ alpha, complex *a, integer *lda, complex *x, integer *incx, complex *
+ beta, complex *y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Local variables */
+ integer i__, j, l, ix, iy, jx, jy, kx, ky, info;
+ complex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ integer kplus1;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSBMV performs the matrix-vector operation */
+
+/* y := alpha*A*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are n element vectors and */
+/* A is an n by n symmetric band matrix, with k super-diagonals. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1 */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the band matrix A is being supplied as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* being supplied. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* being supplied. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER */
+/* On entry, K specifies the number of super-diagonals of the */
+/* matrix A. K must satisfy 0 .le. K. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX array, dimension( LDA, N ) */
+/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
+/* by n part of the array A must contain the upper triangular */
+/* band part of the symmetric matrix, supplied column by */
+/* column, with the leading diagonal of the matrix in row */
+/* ( k + 1 ) of the array, the first super-diagonal starting at */
+/* position 2 in row k, and so on. The top left k by k triangle */
+/* of the array A is not referenced. */
+/* The following program segment will transfer the upper */
+/* triangular part of a symmetric band matrix from conventional */
+/* full matrix storage to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = K + 1 - J */
+/* DO 10, I = MAX( 1, J - K ), J */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
+/* by n part of the array A must contain the lower triangular */
+/* band part of the symmetric matrix, supplied column by */
+/* column, with the leading diagonal of the matrix in row 1 of */
+/* the array, the first sub-diagonal starting at position 1 in */
+/* row 2, and so on. The bottom right k by k triangle of the */
+/* array A is not referenced. */
+/* The following program segment will transfer the lower */
+/* triangular part of a symmetric band matrix from conventional */
+/* full matrix storage to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = 1 - J */
+/* DO 10, I = J, MIN( N, J + K ) */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Unchanged on exit. */
+
+/* LDA - INTEGER */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* ( k + 1 ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+/* Y - COMPLEX array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the */
+/* vector y. On exit, Y is overwritten by the updated vector y. */
+
+/* INCY - INTEGER */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*k < 0) {
+ info = 3;
+ } else if (*lda < *k + 1) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ } else if (*incy == 0) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("CSBMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f &&
+ beta->i == 0.f)) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of the array A */
+/* are accessed sequentially with one pass through A. */
+
+/* First form y := beta*y. */
+
+ if (beta->r != 1.f || beta->i != 0.f) {
+ if (*incy == 1) {
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ y[i__2].r = 0.f, y[i__2].i = 0.f;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (beta->r == 0.f && beta->i == 0.f) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ y[i__2].r = 0.f, y[i__2].i = 0.f;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ i__3 = iy;
+ q__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ q__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (alpha->r == 0.f && alpha->i == 0.f) {
+ return 0;
+ }
+ if (lsame_(uplo, "U")) {
+
+/* Form y when upper triangle of A is stored. */
+
+ kplus1 = *k + 1;
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ q__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, q__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__5 = l + i__ + j * a_dim1;
+ q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ q__1.r = y[i__3].r + q__2.r, q__1.i = y[i__3].i + q__2.i;
+ y[i__2].r = q__1.r, y[i__2].i = q__1.i;
+ i__2 = l + i__ + j * a_dim1;
+ i__3 = i__;
+ q__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[i__3].i,
+ q__2.i = a[i__2].r * x[i__3].i + a[i__2].i * x[
+ i__3].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L50: */
+ }
+ i__4 = j;
+ i__2 = j;
+ i__3 = kplus1 + j * a_dim1;
+ q__3.r = temp1.r * a[i__3].r - temp1.i * a[i__3].i, q__3.i =
+ temp1.r * a[i__3].i + temp1.i * a[i__3].r;
+ q__2.r = y[i__2].r + q__3.r, q__2.i = y[i__2].i + q__3.i;
+ q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ y[i__4].r = q__1.r, y[i__4].i = q__1.i;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = jx;
+ q__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i, q__1.i =
+ alpha->r * x[i__4].i + alpha->i * x[i__4].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ ix = kx;
+ iy = ky;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *k;
+ i__3 = j - 1;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ i__4 = iy;
+ i__2 = iy;
+ i__5 = l + i__ + j * a_dim1;
+ q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
+ y[i__4].r = q__1.r, y[i__4].i = q__1.i;
+ i__4 = l + i__ + j * a_dim1;
+ i__2 = ix;
+ q__2.r = a[i__4].r * x[i__2].r - a[i__4].i * x[i__2].i,
+ q__2.i = a[i__4].r * x[i__2].i + a[i__4].i * x[
+ i__2].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ i__3 = jy;
+ i__4 = jy;
+ i__2 = kplus1 + j * a_dim1;
+ q__3.r = temp1.r * a[i__2].r - temp1.i * a[i__2].i, q__3.i =
+ temp1.r * a[i__2].i + temp1.i * a[i__2].r;
+ q__2.r = y[i__4].r + q__3.r, q__2.i = y[i__4].i + q__3.i;
+ q__4.r = alpha->r * temp2.r - alpha->i * temp2.i, q__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ jx += *incx;
+ jy += *incy;
+ if (j > *k) {
+ kx += *incx;
+ ky += *incy;
+ }
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y when lower triangle of A is stored. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = j;
+ q__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, q__1.i =
+ alpha->r * x[i__3].i + alpha->i * x[i__3].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__3 = j;
+ i__4 = j;
+ i__2 = j * a_dim1 + 1;
+ q__2.r = temp1.r * a[i__2].r - temp1.i * a[i__2].i, q__2.i =
+ temp1.r * a[i__2].i + temp1.i * a[i__2].r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ l = 1 - j;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__2 = i__;
+ i__5 = l + i__ + j * a_dim1;
+ q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
+ y[i__4].r = q__1.r, y[i__4].i = q__1.i;
+ i__4 = l + i__ + j * a_dim1;
+ i__2 = i__;
+ q__2.r = a[i__4].r * x[i__2].r - a[i__4].i * x[i__2].i,
+ q__2.i = a[i__4].r * x[i__2].i + a[i__4].i * x[
+ i__2].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L90: */
+ }
+ i__3 = j;
+ i__4 = j;
+ q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = jx;
+ q__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, q__1.i =
+ alpha->r * x[i__3].i + alpha->i * x[i__3].r;
+ temp1.r = q__1.r, temp1.i = q__1.i;
+ temp2.r = 0.f, temp2.i = 0.f;
+ i__3 = jy;
+ i__4 = jy;
+ i__2 = j * a_dim1 + 1;
+ q__2.r = temp1.r * a[i__2].r - temp1.i * a[i__2].i, q__2.i =
+ temp1.r * a[i__2].i + temp1.i * a[i__2].r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ l = 1 - j;
+ ix = jx;
+ iy = jy;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ ix += *incx;
+ iy += *incy;
+ i__4 = iy;
+ i__2 = iy;
+ i__5 = l + i__ + j * a_dim1;
+ q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ q__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ q__1.r = y[i__2].r + q__2.r, q__1.i = y[i__2].i + q__2.i;
+ y[i__4].r = q__1.r, y[i__4].i = q__1.i;
+ i__4 = l + i__ + j * a_dim1;
+ i__2 = ix;
+ q__2.r = a[i__4].r * x[i__2].r - a[i__4].i * x[i__2].i,
+ q__2.i = a[i__4].r * x[i__2].i + a[i__4].i * x[
+ i__2].r;
+ q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
+ temp2.r = q__1.r, temp2.i = q__1.i;
+/* L110: */
+ }
+ i__3 = jy;
+ i__4 = jy;
+ q__2.r = alpha->r * temp2.r - alpha->i * temp2.i, q__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ q__1.r = y[i__4].r + q__2.r, q__1.i = y[i__4].i + q__2.i;
+ y[i__3].r = q__1.r, y[i__3].i = q__1.i;
+ jx += *incx;
+ jy += *incy;
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CSBMV */
+
+} /* csbmv_ */
diff --git a/TESTING/LIN/cspt01.c b/TESTING/LIN/cspt01.c
new file mode 100644
index 0000000..c656616
--- /dev/null
+++ b/TESTING/LIN/cspt01.c
@@ -0,0 +1,203 @@
+/* cspt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+
+/* Subroutine */ int cspt01_(char *uplo, integer *n, complex *a, complex *
+ afac, integer *ipiv, complex *c__, integer *ldc, real *rwork, real *
+ resid)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j, jc;
+ real eps;
+ integer info;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *);
+ extern doublereal clansp_(char *, char *, integer *, complex *, real *);
+ extern /* Subroutine */ int clavsp_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *, integer *);
+ extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
+ real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSPT01 reconstructs a symmetric indefinite packed matrix A from its */
+/* diagonal pivoting factorization A = U*D*U' or A = L*D*L' and computes */
+/* the residual */
+/* norm( C - A ) / ( N * norm(A) * EPS ), */
+/* where C is the reconstructed matrix and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The original symmetric matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* AFAC (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The factored form of the matrix A, stored as a packed */
+/* triangular matrix. AFAC contains the block diagonal matrix D */
+/* and the multipliers used to obtain the factor L or U from the */
+/* L*D*L' or U*D*U' factorization as computed by CSPTRF. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from CSPTRF. */
+
+/* C (workspace) COMPLEX array, dimension (LDC,N) */
+
+/* LDC (integer) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) 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 ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ --a;
+ --afac;
+ --ipiv;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Determine EPS and the norm of A. */
+
+ eps = slamch_("Epsilon");
+ anorm = clansp_("1", uplo, n, &a[1], &rwork[1]);
+
+/* Initialize C to the identity matrix. */
+
+ claset_("Full", n, n, &c_b1, &c_b2, &c__[c_offset], ldc);
+
+/* Call CLAVSP to form the product D * U' (or D * L' ). */
+
+ clavsp_(uplo, "Transpose", "Non-unit", n, n, &afac[1], &ipiv[1], &c__[
+ c_offset], ldc, &info);
+
+/* Call CLAVSP again to multiply by U ( or L ). */
+
+ clavsp_(uplo, "No transpose", "Unit", n, n, &afac[1], &ipiv[1], &c__[
+ c_offset], ldc, &info);
+
+/* Compute the difference C - A . */
+
+ if (lsame_(uplo, "U")) {
+ jc = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = jc + i__;
+ q__1.r = c__[i__4].r - a[i__5].r, q__1.i = c__[i__4].i - a[
+ i__5].i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L10: */
+ }
+ jc += j;
+/* L20: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = jc + i__ - j;
+ q__1.r = c__[i__4].r - a[i__5].r, q__1.i = c__[i__4].i - a[
+ i__5].i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L30: */
+ }
+ jc = jc + *n - j + 1;
+/* L40: */
+ }
+ }
+
+/* Compute norm( C - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = clansy_("1", uplo, n, &c__[c_offset], ldc, &rwork[1]);
+
+ if (anorm <= 0.f) {
+ if (*resid != 0.f) {
+ *resid = 1.f / eps;
+ }
+ } else {
+ *resid = *resid / (real) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of CSPT01 */
+
+} /* cspt01_ */
diff --git a/TESTING/LIN/cspt02.c b/TESTING/LIN/cspt02.c
new file mode 100644
index 0000000..0804e76
--- /dev/null
+++ b/TESTING/LIN/cspt02.c
@@ -0,0 +1,175 @@
+/* cspt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int cspt02_(char *uplo, integer *n, integer *nrhs, complex *
+ a, complex *x, integer *ldx, complex *b, integer *ldb, real *rwork,
+ real *resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Local variables */
+ integer j;
+ real eps, anorm, bnorm;
+ extern /* Subroutine */ int cspmv_(char *, integer *, complex *, complex *
+, complex *, integer *, complex *, complex *, integer *);
+ real xnorm;
+ extern doublereal slamch_(char *), clansp_(char *, char *,
+ integer *, complex *, real *), scasum_(integer *,
+ complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSPT02 computes the residual in the solution of a complex symmetric */
+/* system of linear equations A*x = b when packed storage is used for */
+/* the coefficient matrix. The ratio computed is */
+
+/* RESID = norm( B - A*X ) / ( norm(A) * norm(X) * EPS). */
+
+/* where EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* complex symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The original complex symmetric matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ --a;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = clansp_("1", uplo, n, &a[1], &rwork[1]);
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute B - A*X for the matrix of right hand sides B. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ q__1.r = -1.f, q__1.i = -0.f;
+ cspmv_(uplo, n, &q__1, &a[1], &x[j * x_dim1 + 1], &c__1, &c_b1, &b[j *
+ b_dim1 + 1], &c__1);
+/* L10: */
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = scasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = scasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L20: */
+ }
+
+ return 0;
+
+/* End of CSPT02 */
+
+} /* cspt02_ */
diff --git a/TESTING/LIN/cspt03.c b/TESTING/LIN/cspt03.c
new file mode 100644
index 0000000..0cd83a0
--- /dev/null
+++ b/TESTING/LIN/cspt03.c
@@ -0,0 +1,347 @@
+/* cspt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int cspt03_(char *uplo, integer *n, complex *a, complex *
+ ainv, complex *work, integer *ldw, real *rwork, real *rcond, real *
+ resid)
+{
+ /* System generated locals */
+ integer work_dim1, work_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1, q__2;
+
+ /* Local variables */
+ integer i__, j, k;
+ complex t;
+ real eps;
+ integer icol, jcol, kcol, nall;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *), clansp_(char
+ *, char *, integer *, complex *, real *);
+ real ainvnm;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSPT03 computes the residual for a complex symmetric packed matrix */
+/* times its inverse: */
+/* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* complex symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The original complex symmetric matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* AINV (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The (symmetric) inverse of the matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* WORK (workspace) COMPLEX array, dimension (LDWORK,N) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RCOND (output) REAL */
+/* The reciprocal of the condition number of A, computed as */
+/* ( 1/norm(A) ) / norm(AINV). */
+
+/* RESID (output) REAL */
+/* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ --a;
+ --ainv;
+ work_dim1 = *ldw;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.f;
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = clansp_("1", uplo, n, &a[1], &rwork[1]);
+ ainvnm = clansp_("1", uplo, n, &ainv[1], &rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ *rcond = 0.f;
+ *resid = 1.f / eps;
+ return 0;
+ }
+ *rcond = 1.f / anorm / ainvnm;
+
+/* Case where both A and AINV are upper triangular: */
+/* Each element of - A * AINV is computed by taking the dot product */
+/* of a row of A with a column of AINV. */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ icol = (i__ - 1) * i__ / 2 + 1;
+
+/* Code when J <= I */
+
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ jcol = (j - 1) * j / 2 + 1;
+ cdotu_(&q__1, &j, &a[icol], &c__1, &ainv[jcol], &c__1);
+ t.r = q__1.r, t.i = q__1.i;
+ jcol = jcol + (j << 1) - 1;
+ kcol = icol - 1;
+ i__3 = i__;
+ for (k = j + 1; k <= i__3; ++k) {
+ i__4 = kcol + k;
+ i__5 = jcol;
+ q__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
+ .i, q__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
+ * ainv[i__5].r;
+ q__1.r = t.r + q__2.r, q__1.i = t.i + q__2.i;
+ t.r = q__1.r, t.i = q__1.i;
+ jcol += k;
+/* L10: */
+ }
+ kcol += i__ << 1;
+ i__3 = *n;
+ for (k = i__ + 1; k <= i__3; ++k) {
+ i__4 = kcol;
+ i__5 = jcol;
+ q__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
+ .i, q__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
+ * ainv[i__5].r;
+ q__1.r = t.r + q__2.r, q__1.i = t.i + q__2.i;
+ t.r = q__1.r, t.i = q__1.i;
+ kcol += k;
+ jcol += k;
+/* L20: */
+ }
+ i__3 = i__ + j * work_dim1;
+ q__1.r = -t.r, q__1.i = -t.i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L30: */
+ }
+
+/* Code when J > I */
+
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ jcol = (j - 1) * j / 2 + 1;
+ cdotu_(&q__1, &i__, &a[icol], &c__1, &ainv[jcol], &c__1);
+ t.r = q__1.r, t.i = q__1.i;
+ --jcol;
+ kcol = icol + (i__ << 1) - 1;
+ i__3 = j;
+ for (k = i__ + 1; k <= i__3; ++k) {
+ i__4 = kcol;
+ i__5 = jcol + k;
+ q__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
+ .i, q__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
+ * ainv[i__5].r;
+ q__1.r = t.r + q__2.r, q__1.i = t.i + q__2.i;
+ t.r = q__1.r, t.i = q__1.i;
+ kcol += k;
+/* L40: */
+ }
+ jcol += j << 1;
+ i__3 = *n;
+ for (k = j + 1; k <= i__3; ++k) {
+ i__4 = kcol;
+ i__5 = jcol;
+ q__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
+ .i, q__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
+ * ainv[i__5].r;
+ q__1.r = t.r + q__2.r, q__1.i = t.i + q__2.i;
+ t.r = q__1.r, t.i = q__1.i;
+ kcol += k;
+ jcol += k;
+/* L50: */
+ }
+ i__3 = i__ + j * work_dim1;
+ q__1.r = -t.r, q__1.i = -t.i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L60: */
+ }
+/* L70: */
+ }
+ } else {
+
+/* Case where both A and AINV are lower triangular */
+
+ nall = *n * (*n + 1) / 2;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Code when J <= I */
+
+ icol = nall - (*n - i__ + 1) * (*n - i__ + 2) / 2 + 1;
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ jcol = nall - (*n - j) * (*n - j + 1) / 2 - (*n - i__);
+ i__3 = *n - i__ + 1;
+ cdotu_(&q__1, &i__3, &a[icol], &c__1, &ainv[jcol], &c__1);
+ t.r = q__1.r, t.i = q__1.i;
+ kcol = i__;
+ jcol = j;
+ i__3 = j - 1;
+ for (k = 1; k <= i__3; ++k) {
+ i__4 = kcol;
+ i__5 = jcol;
+ q__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
+ .i, q__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
+ * ainv[i__5].r;
+ q__1.r = t.r + q__2.r, q__1.i = t.i + q__2.i;
+ t.r = q__1.r, t.i = q__1.i;
+ jcol = jcol + *n - k;
+ kcol = kcol + *n - k;
+/* L80: */
+ }
+ jcol -= j;
+ i__3 = i__ - 1;
+ for (k = j; k <= i__3; ++k) {
+ i__4 = kcol;
+ i__5 = jcol + k;
+ q__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
+ .i, q__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
+ * ainv[i__5].r;
+ q__1.r = t.r + q__2.r, q__1.i = t.i + q__2.i;
+ t.r = q__1.r, t.i = q__1.i;
+ kcol = kcol + *n - k;
+/* L90: */
+ }
+ i__3 = i__ + j * work_dim1;
+ q__1.r = -t.r, q__1.i = -t.i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L100: */
+ }
+
+/* Code when J > I */
+
+ icol = nall - (*n - i__) * (*n - i__ + 1) / 2;
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ jcol = nall - (*n - j + 1) * (*n - j + 2) / 2 + 1;
+ i__3 = *n - j + 1;
+ cdotu_(&q__1, &i__3, &a[icol - *n + j], &c__1, &ainv[jcol], &
+ c__1);
+ t.r = q__1.r, t.i = q__1.i;
+ kcol = i__;
+ jcol = j;
+ i__3 = i__ - 1;
+ for (k = 1; k <= i__3; ++k) {
+ i__4 = kcol;
+ i__5 = jcol;
+ q__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
+ .i, q__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
+ * ainv[i__5].r;
+ q__1.r = t.r + q__2.r, q__1.i = t.i + q__2.i;
+ t.r = q__1.r, t.i = q__1.i;
+ jcol = jcol + *n - k;
+ kcol = kcol + *n - k;
+/* L110: */
+ }
+ kcol -= i__;
+ i__3 = j - 1;
+ for (k = i__; k <= i__3; ++k) {
+ i__4 = kcol + k;
+ i__5 = jcol;
+ q__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
+ .i, q__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
+ * ainv[i__5].r;
+ q__1.r = t.r + q__2.r, q__1.i = t.i + q__2.i;
+ t.r = q__1.r, t.i = q__1.i;
+ jcol = jcol + *n - k;
+/* L120: */
+ }
+ i__3 = i__ + j * work_dim1;
+ q__1.r = -t.r, q__1.i = -t.i;
+ work[i__3].r = q__1.r, work[i__3].i = q__1.i;
+/* L130: */
+ }
+/* L140: */
+ }
+ }
+
+/* Add the identity matrix to WORK . */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * work_dim1;
+ i__3 = i__ + i__ * work_dim1;
+ q__1.r = work[i__3].r + 1.f, q__1.i = work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L150: */
+ }
+
+/* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = clange_("1", n, n, &work[work_offset], ldw, &rwork[1])
+ ;
+
+ *resid = *resid * *rcond / eps / (real) (*n);
+
+ return 0;
+
+/* End of CSPT03 */
+
+} /* cspt03_ */
diff --git a/TESTING/LIN/csyt01.c b/TESTING/LIN/csyt01.c
new file mode 100644
index 0000000..f3b8825
--- /dev/null
+++ b/TESTING/LIN/csyt01.c
@@ -0,0 +1,209 @@
+/* csyt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+
+/* Subroutine */ int csyt01_(char *uplo, integer *n, complex *a, integer *lda,
+ complex *afac, integer *ldafac, integer *ipiv, complex *c__, integer
+ *ldc, real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, c_dim1, c_offset, i__1,
+ i__2, i__3, i__4, i__5;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j;
+ real eps;
+ integer info;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *);
+ extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
+ real *);
+ extern /* Subroutine */ int clavsy_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, integer *, complex *, integer *,
+ integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSYT01 reconstructs a complex symmetric indefinite matrix A from its */
+/* block L*D*L' or U*D*U' factorization and computes the residual */
+/* norm( C - A ) / ( N * norm(A) * EPS ), */
+/* where C is the reconstructed matrix, EPS is the machine epsilon, */
+/* L' is the transpose of L, and U' is the transpose of U. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* complex symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The original complex symmetric matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* AFAC (input) COMPLEX array, dimension (LDAFAC,N) */
+/* The factored form of the matrix A. AFAC contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor L or U from the block L*D*L' or U*D*U' factorization */
+/* as computed by CSYTRF. */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from CSYTRF. */
+
+/* C (workspace) COMPLEX array, dimension (LDC,N) */
+
+/* LDC (integer) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) 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 ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ --ipiv;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Determine EPS and the norm of A. */
+
+ eps = slamch_("Epsilon");
+ anorm = clansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+
+/* Initialize C to the identity matrix. */
+
+ claset_("Full", n, n, &c_b1, &c_b2, &c__[c_offset], ldc);
+
+/* Call CLAVSY to form the product D * U' (or D * L' ). */
+
+ clavsy_(uplo, "Transpose", "Non-unit", n, n, &afac[afac_offset], ldafac, &
+ ipiv[1], &c__[c_offset], ldc, &info);
+
+/* Call CLAVSY again to multiply by U (or L ). */
+
+ clavsy_(uplo, "No transpose", "Unit", n, n, &afac[afac_offset], ldafac, &
+ ipiv[1], &c__[c_offset], ldc, &info);
+
+/* Compute the difference C - A . */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * a_dim1;
+ q__1.r = c__[i__4].r - a[i__5].r, q__1.i = c__[i__4].i - a[
+ i__5].i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * a_dim1;
+ q__1.r = c__[i__4].r - a[i__5].r, q__1.i = c__[i__4].i - a[
+ i__5].i;
+ c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+/* Compute norm( C - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = clansy_("1", uplo, n, &c__[c_offset], ldc, &rwork[1]);
+
+ if (anorm <= 0.f) {
+ if (*resid != 0.f) {
+ *resid = 1.f / eps;
+ }
+ } else {
+ *resid = *resid / (real) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of CSYT01 */
+
+} /* csyt01_ */
diff --git a/TESTING/LIN/csyt02.c b/TESTING/LIN/csyt02.c
new file mode 100644
index 0000000..3de0201
--- /dev/null
+++ b/TESTING/LIN/csyt02.c
@@ -0,0 +1,175 @@
+/* csyt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static integer c__1 = 1;
+
+/* Subroutine */ int csyt02_(char *uplo, integer *n, integer *nrhs, complex *
+ a, integer *lda, complex *x, integer *ldx, complex *b, integer *ldb,
+ real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Local variables */
+ integer j;
+ real eps, anorm, bnorm;
+ extern /* Subroutine */ int csymm_(char *, char *, integer *, integer *,
+ complex *, complex *, integer *, complex *, integer *, complex *,
+ complex *, integer *);
+ real xnorm;
+ extern doublereal slamch_(char *), clansy_(char *, char *,
+ integer *, complex *, integer *, real *), scasum_(
+ integer *, complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSYT02 computes the residual for a solution to a complex symmetric */
+/* system of linear equations A*x = b: */
+
+/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ), */
+
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The original complex symmetric matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = clansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute B - A*X (or B - A'*X ) and store in B . */
+
+ q__1.r = -1.f, q__1.i = -0.f;
+ csymm_("Left", uplo, n, nrhs, &q__1, &a[a_offset], lda, &x[x_offset], ldx,
+ &c_b1, &b[b_offset], ldb);
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = scasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = scasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of CSYT02 */
+
+} /* csyt02_ */
diff --git a/TESTING/LIN/csyt03.c b/TESTING/LIN/csyt03.c
new file mode 100644
index 0000000..4dcbb34
--- /dev/null
+++ b/TESTING/LIN/csyt03.c
@@ -0,0 +1,205 @@
+/* csyt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+
+/* Subroutine */ int csyt03_(char *uplo, integer *n, complex *a, integer *lda,
+ complex *ainv, integer *ldainv, complex *work, integer *ldwork, real
+ *rwork, real *rcond, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, ainv_dim1, ainv_offset, work_dim1, work_offset,
+ i__1, i__2, i__3, i__4;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j;
+ real eps;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern /* Subroutine */ int csymm_(char *, char *, integer *, integer *,
+ complex *, complex *, integer *, complex *, integer *, complex *,
+ complex *, integer *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ real ainvnm;
+ extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
+ real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CSYT03 computes the residual for a complex symmetric matrix times */
+/* its inverse: */
+/* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ) */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* complex symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The original complex symmetric matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* AINV (input/output) COMPLEX array, dimension (LDAINV,N) */
+/* On entry, the inverse of the matrix A, stored as a symmetric */
+/* matrix in the same format as A. */
+/* In this version, AINV is expanded into a full matrix and */
+/* multiplied by A, so the opposing triangle of AINV will be */
+/* changed; i.e., if the upper triangular part of AINV is */
+/* stored, the lower triangular part will be used as work space. */
+
+/* LDAINV (input) INTEGER */
+/* The leading dimension of the array AINV. LDAINV >= max(1,N). */
+
+/* WORK (workspace) COMPLEX array, dimension (LDWORK,N) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RCOND (output) REAL */
+/* The reciprocal of the condition number of A, computed as */
+/* RCOND = 1/ (norm(A) * norm(AINV)). */
+
+/* RESID (output) REAL */
+/* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ ainv_dim1 = *ldainv;
+ ainv_offset = 1 + ainv_dim1;
+ ainv -= ainv_offset;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.f;
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = clansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+ ainvnm = clansy_("1", uplo, n, &ainv[ainv_offset], ldainv, &rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ *rcond = 0.f;
+ *resid = 1.f / eps;
+ return 0;
+ }
+ *rcond = 1.f / anorm / ainvnm;
+
+/* Expand AINV into a full matrix and call CSYMM to multiply */
+/* AINV on the left by A (store the result in WORK). */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * ainv_dim1;
+ i__4 = i__ + j * ainv_dim1;
+ ainv[i__3].r = ainv[i__4].r, ainv[i__3].i = ainv[i__4].i;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * ainv_dim1;
+ i__4 = i__ + j * ainv_dim1;
+ ainv[i__3].r = ainv[i__4].r, ainv[i__3].i = ainv[i__4].i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ q__1.r = -1.f, q__1.i = -0.f;
+ csymm_("Left", uplo, n, n, &q__1, &a[a_offset], lda, &ainv[ainv_offset],
+ ldainv, &c_b1, &work[work_offset], ldwork);
+
+/* Add the identity matrix to WORK . */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * work_dim1;
+ i__3 = i__ + i__ * work_dim1;
+ q__1.r = work[i__3].r + 1.f, q__1.i = work[i__3].i + 0.f;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L50: */
+ }
+
+/* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = clange_("1", n, n, &work[work_offset], ldwork, &rwork[1]);
+
+ *resid = *resid * *rcond / eps / (real) (*n);
+
+ return 0;
+
+/* End of CSYT03 */
+
+} /* csyt03_ */
diff --git a/TESTING/LIN/ctbt02.c b/TESTING/LIN/ctbt02.c
new file mode 100644
index 0000000..554de02
--- /dev/null
+++ b/TESTING/LIN/ctbt02.c
@@ -0,0 +1,208 @@
+/* ctbt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static complex c_b12 = {-1.f,0.f};
+
+/* Subroutine */ int ctbt02_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, complex *ab, integer *ldab, complex *x,
+ integer *ldx, complex *b, integer *ldb, complex *work, real *rwork,
+ real *resid)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j;
+ real eps;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int ctbmv_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *);
+ real anorm, bnorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ real xnorm;
+ extern doublereal clantb_(char *, char *, char *, integer *, integer *,
+ complex *, integer *, real *), slamch_(
+ char *), scasum_(integer *, complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTBT02 computes the residual for the computed solution to a */
+/* triangular system of linear equations A*x = b, A**T *x = b, or */
+/* A**H *x = b when A is a triangular band matrix. Here A**T denotes */
+/* the transpose of A, A**H denotes the conjugate transpose of A, and */
+/* x and b are N by NRHS matrices. The test ratio is the maximum over */
+/* the number of right hand sides of */
+/* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A, A**T, or A**H, and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = b (No transpose) */
+/* = 'T': A**T *x = b (Transpose) */
+/* = 'C': A**H *x = b (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDA,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= max(1,KD+1). */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Compute the 1-norm of A or A'. */
+
+ if (lsame_(trans, "N")) {
+ anorm = clantb_("1", uplo, diag, n, kd, &ab[ab_offset], ldab, &rwork[
+ 1]);
+ } else {
+ anorm = clantb_("I", uplo, diag, n, kd, &ab[ab_offset], ldab, &rwork[
+ 1]);
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ctbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[1], &
+ c__1);
+ caxpy_(n, &c_b12, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ bnorm = scasum_(n, &work[1], &c__1);
+ xnorm = scasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of CTBT02 */
+
+} /* ctbt02_ */
diff --git a/TESTING/LIN/ctbt03.c b/TESTING/LIN/ctbt03.c
new file mode 100644
index 0000000..eb93165
--- /dev/null
+++ b/TESTING/LIN/ctbt03.c
@@ -0,0 +1,261 @@
+/* ctbt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ctbt03_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, complex *ab, integer *ldab, real *scale,
+ real *cnorm, real *tscal, complex *x, integer *ldx, complex *b,
+ integer *ldb, complex *work, real *resid)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+
+ /* Local variables */
+ integer j, ix;
+ real eps, err;
+ extern logical lsame_(char *, char *);
+ real xscal;
+ extern /* Subroutine */ int ctbmv_(char *, char *, char *, integer *,
+ integer *, complex *, integer *, complex *, integer *), ccopy_(integer *, complex *, integer *, complex *
+, integer *), caxpy_(integer *, complex *, complex *, integer *,
+ complex *, integer *);
+ real tnorm, xnorm;
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *);
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTBT03 computes the residual for the solution to a scaled triangular */
+/* system of equations A*x = s*b, A**T *x = s*b, or A**H *x = s*b */
+/* when A is a triangular band matrix. Here A**T denotes the transpose */
+/* of A, A**H denotes the conjugate transpose of A, s is a scalar, and */
+/* x and b are N by NRHS matrices. The test ratio is the maximum over */
+/* the number of right hand sides of */
+/* norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A, A**T, or A**H, and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = s*b (No transpose) */
+/* = 'T': A**T *x = s*b (Transpose) */
+/* = 'C': A**H *x = s*b (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* SCALE (input) REAL */
+/* The scaling factor s used in solving the triangular system. */
+
+/* CNORM (input) REAL array, dimension (N) */
+/* The 1-norms of the columns of A, not counting the diagonal. */
+
+/* TSCAL (input) REAL */
+/* The scaling factor used in computing the 1-norms in CNORM. */
+/* CNORM actually contains the column norms of TSCAL*A. */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --cnorm;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+ eps = slamch_("Epsilon");
+ smlnum = slamch_("Safe minimum");
+
+/* Compute the norm of the triangular matrix A using the column */
+/* norms already computed by CLATBS. */
+
+ tnorm = 0.f;
+ if (lsame_(diag, "N")) {
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ r__1 = tnorm, r__2 = *tscal * c_abs(&ab[*kd + 1 + j * ab_dim1]
+ ) + cnorm[j];
+ tnorm = dmax(r__1,r__2);
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ r__1 = tnorm, r__2 = *tscal * c_abs(&ab[j * ab_dim1 + 1]) +
+ cnorm[j];
+ tnorm = dmax(r__1,r__2);
+/* L20: */
+ }
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ r__1 = tnorm, r__2 = *tscal + cnorm[j];
+ tnorm = dmax(r__1,r__2);
+/* L30: */
+ }
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = icamax_(n, &work[1], &c__1);
+/* Computing MAX */
+ r__1 = 1.f, r__2 = c_abs(&x[ix + j * x_dim1]);
+ xnorm = dmax(r__1,r__2);
+ xscal = 1.f / xnorm / (real) (*kd + 1);
+ csscal_(n, &xscal, &work[1], &c__1);
+ ctbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[1], &
+ c__1);
+ r__1 = -(*scale) * xscal;
+ q__1.r = r__1, q__1.i = 0.f;
+ caxpy_(n, &q__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = icamax_(n, &work[1], &c__1);
+ err = *tscal * c_abs(&work[ix]);
+ ix = icamax_(n, &x[j * x_dim1 + 1], &c__1);
+ xnorm = c_abs(&x[ix + j * x_dim1]);
+ if (err * smlnum <= xnorm) {
+ if (xnorm > 0.f) {
+ err /= xnorm;
+ }
+ } else {
+ if (err > 0.f) {
+ err = 1.f / eps;
+ }
+ }
+ if (err * smlnum <= tnorm) {
+ if (tnorm > 0.f) {
+ err /= tnorm;
+ }
+ } else {
+ if (err > 0.f) {
+ err = 1.f / eps;
+ }
+ }
+ *resid = dmax(*resid,err);
+/* L40: */
+ }
+
+ return 0;
+
+/* End of CTBT03 */
+
+} /* ctbt03_ */
diff --git a/TESTING/LIN/ctbt05.c b/TESTING/LIN/ctbt05.c
new file mode 100644
index 0000000..daa7569
--- /dev/null
+++ b/TESTING/LIN/ctbt05.c
@@ -0,0 +1,374 @@
+/* ctbt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ctbt05_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, complex *ab, integer *ldab, complex *b,
+ integer *ldb, complex *x, integer *ldx, complex *xact, integer *
+ ldxact, real *ferr, real *berr, real *reslts)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k, nz, ifu;
+ real eps, tmp, diff, axbi;
+ integer imax;
+ real unfl, ovfl;
+ logical unit;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ real xnorm;
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ real errbnd;
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTBT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* triangular band matrix. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+/* and NZ = max. number of nonzeros in any row of A, plus 1 */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A'* X = B (Transpose) */
+/* = 'C': A'* X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) REAL array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) REAL array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.f;
+ reslts[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ unit = lsame_(diag, "U");
+/* Computing MIN */
+ i__1 = *kd, i__2 = *n - 1;
+ nz = min(i__1,i__2) + 1;
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = icamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__2 = imax + j * x_dim1;
+ r__3 = (r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x[imax + j *
+ x_dim1]), dabs(r__2));
+ xnorm = dmax(r__3,unfl);
+ diff = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * xact_dim1;
+ q__2.r = x[i__3].r - xact[i__4].r, q__2.i = x[i__3].i - xact[i__4]
+ .i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+/* Computing MAX */
+ r__3 = diff, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
+ q__1), dabs(r__2));
+ diff = dmax(r__3,r__4);
+/* L10: */
+ }
+
+ if (xnorm > 1.f) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1.f / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
+ errbnd = dmax(r__1,r__2);
+ } else {
+ errbnd = 1.f / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ ifu = 0;
+ if (unit) {
+ ifu = 1;
+ }
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ tmp = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[i__ + k *
+ b_dim1]), dabs(r__2));
+ if (upper) {
+ if (! notran) {
+/* Computing MAX */
+ i__3 = i__ - *kd;
+ i__4 = i__ - ifu;
+ for (j = max(i__3,1); j <= i__4; ++j) {
+ i__3 = *kd + 1 - i__ + j + i__ * ab_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = ab[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&ab[*kd + 1 - i__ + j + i__ * ab_dim1])
+ , dabs(r__2))) * ((r__3 = x[i__5].r, dabs(
+ r__3)) + (r__4 = r_imag(&x[j + k * x_dim1]),
+ dabs(r__4)));
+/* L40: */
+ }
+ if (unit) {
+ i__4 = i__ + k * x_dim1;
+ tmp += (r__1 = x[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + k * x_dim1]), dabs(r__2));
+ }
+ } else {
+ if (unit) {
+ i__4 = i__ + k * x_dim1;
+ tmp += (r__1 = x[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + k * x_dim1]), dabs(r__2));
+ }
+/* Computing MIN */
+ i__3 = i__ + *kd;
+ i__4 = min(i__3,*n);
+ for (j = i__ + ifu; j <= i__4; ++j) {
+ i__3 = *kd + 1 + i__ - j + j * ab_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = ab[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&ab[*kd + 1 + i__ - j + j * ab_dim1]),
+ dabs(r__2))) * ((r__3 = x[i__5].r, dabs(r__3))
+ + (r__4 = r_imag(&x[j + k * x_dim1]), dabs(
+ r__4)));
+/* L50: */
+ }
+ }
+ } else {
+ if (notran) {
+/* Computing MAX */
+ i__4 = i__ - *kd;
+ i__3 = i__ - ifu;
+ for (j = max(i__4,1); j <= i__3; ++j) {
+ i__4 = i__ + 1 - j + j * ab_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = ab[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&ab[i__ + 1 - j + j * ab_dim1]), dabs(
+ r__2))) * ((r__3 = x[i__5].r, dabs(r__3)) + (
+ r__4 = r_imag(&x[j + k * x_dim1]), dabs(r__4))
+ );
+/* L60: */
+ }
+ if (unit) {
+ i__3 = i__ + k * x_dim1;
+ tmp += (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + k * x_dim1]), dabs(r__2));
+ }
+ } else {
+ if (unit) {
+ i__3 = i__ + k * x_dim1;
+ tmp += (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + k * x_dim1]), dabs(r__2));
+ }
+/* Computing MIN */
+ i__4 = i__ + *kd;
+ i__3 = min(i__4,*n);
+ for (j = i__ + ifu; j <= i__3; ++j) {
+ i__4 = j + 1 - i__ + i__ * ab_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = ab[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&ab[j + 1 - i__ + i__ * ab_dim1]),
+ dabs(r__2))) * ((r__3 = x[i__5].r, dabs(r__3))
+ + (r__4 = r_imag(&x[j + k * x_dim1]), dabs(
+ r__4)));
+/* L70: */
+ }
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = dmin(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ r__1 = axbi, r__2 = nz * unfl;
+ tmp = berr[k] / (nz * eps + nz * unfl / dmax(r__1,r__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = dmax(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of CTBT05 */
+
+} /* ctbt05_ */
diff --git a/TESTING/LIN/ctbt06.c b/TESTING/LIN/ctbt06.c
new file mode 100644
index 0000000..cbbb361
--- /dev/null
+++ b/TESTING/LIN/ctbt06.c
@@ -0,0 +1,160 @@
+/* ctbt06.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ctbt06_(real *rcond, real *rcondc, char *uplo, char *
+ diag, integer *n, integer *kd, complex *ab, integer *ldab, real *
+ rwork, real *rat)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset;
+ real r__1, r__2;
+
+ /* Local variables */
+ real eps, rmin, rmax, anorm;
+ extern doublereal clantb_(char *, char *, char *, integer *, integer *,
+ complex *, integer *, real *), slamch_(
+ char *);
+ real bignum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTBT06 computes a test ratio comparing RCOND (the reciprocal */
+/* condition number of a triangular matrix A) and RCONDC, the estimate */
+/* computed by CTBCON. Information about the triangular matrix A is */
+/* used if one estimate is zero and the other is non-zero to decide if */
+/* underflow in the estimate is justified. */
+
+/* Arguments */
+/* ========= */
+
+/* RCOND (input) REAL */
+/* The estimate of the reciprocal condition number obtained by */
+/* forming the explicit inverse of the matrix A and computing */
+/* RCOND = 1/( norm(A) * norm(inv(A)) ). */
+
+/* RCONDC (input) REAL */
+/* The estimate of the reciprocal condition number computed by */
+/* CTBCON. */
+
+/* UPLO (input) CHARACTER */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* AB (input) COMPLEX array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RAT (output) REAL */
+/* The test ratio. If both RCOND and RCONDC are nonzero, */
+/* RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1. */
+/* If RAT = 0, the two estimates are exactly the same. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --rwork;
+
+ /* Function Body */
+ eps = slamch_("Epsilon");
+ rmax = dmax(*rcond,*rcondc);
+ rmin = dmin(*rcond,*rcondc);
+
+/* Do the easy cases first. */
+
+ if (rmin < 0.f) {
+
+/* Invalid value for RCOND or RCONDC, return 1/EPS. */
+
+ *rat = 1.f / eps;
+
+ } else if (rmin > 0.f) {
+
+/* Both estimates are positive, return RMAX/RMIN - 1. */
+
+ *rat = rmax / rmin - 1.f;
+
+ } else if (rmax == 0.f) {
+
+/* Both estimates zero. */
+
+ *rat = 0.f;
+
+ } else {
+
+/* One estimate is zero, the other is non-zero. If the matrix is */
+/* ill-conditioned, return the nonzero estimate multiplied by */
+/* 1/EPS; if the matrix is badly scaled, return the nonzero */
+/* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum */
+/* element in absolute value in A. */
+
+ bignum = 1.f / slamch_("Safe minimum");
+ anorm = clantb_("M", uplo, diag, n, kd, &ab[ab_offset], ldab, &rwork[
+ 1]);
+
+/* Computing MIN */
+ r__1 = bignum / dmax(1.f,anorm), r__2 = 1.f / eps;
+ *rat = rmax * dmin(r__1,r__2);
+ }
+
+ return 0;
+
+/* End of CTBT06 */
+
+} /* ctbt06_ */
diff --git a/TESTING/LIN/ctpt01.c b/TESTING/LIN/ctpt01.c
new file mode 100644
index 0000000..de88dd4
--- /dev/null
+++ b/TESTING/LIN/ctpt01.c
@@ -0,0 +1,197 @@
+/* ctpt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ctpt01_(char *uplo, char *diag, integer *n, complex *ap,
+ complex *ainvp, real *rcond, real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ complex q__1;
+
+ /* Local variables */
+ integer j, jc;
+ real eps;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ logical unitd;
+ extern /* Subroutine */ int ctpmv_(char *, char *, char *, integer *,
+ complex *, complex *, integer *);
+ extern doublereal slamch_(char *), clantp_(char *, char *, char *,
+ integer *, complex *, real *);
+ real ainvnm;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTPT01 computes the residual for a triangular matrix A times its */
+/* inverse when A is stored in packed format: */
+/* RESID = norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The original upper or lower triangular matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
+
+/* AINVP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* On entry, the (triangular) inverse of the matrix A, packed */
+/* columnwise in a linear array as in AP. */
+/* On exit, the contents of AINVP are destroyed. */
+
+/* RCOND (output) REAL */
+/* The reciprocal condition number of A, computed as */
+/* 1/(norm(A) * norm(AINV)). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --ainvp;
+ --ap;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.f;
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = clantp_("1", uplo, diag, n, &ap[1], &rwork[1]);
+ ainvnm = clantp_("1", uplo, diag, n, &ainvp[1], &rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ *rcond = 0.f;
+ *resid = 1.f / eps;
+ return 0;
+ }
+ *rcond = 1.f / anorm / ainvnm;
+
+/* Compute A * AINV, overwriting AINV. */
+
+ unitd = lsame_(diag, "U");
+ if (lsame_(uplo, "U")) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (unitd) {
+ i__2 = jc + j - 1;
+ ainvp[i__2].r = 1.f, ainvp[i__2].i = 0.f;
+ }
+
+/* Form the j-th column of A*AINV. */
+
+ ctpmv_("Upper", "No transpose", diag, &j, &ap[1], &ainvp[jc], &
+ c__1);
+
+/* Subtract 1 from the diagonal to form A*AINV - I. */
+
+ i__2 = jc + j - 1;
+ i__3 = jc + j - 1;
+ q__1.r = ainvp[i__3].r - 1.f, q__1.i = ainvp[i__3].i;
+ ainvp[i__2].r = q__1.r, ainvp[i__2].i = q__1.i;
+ jc += j;
+/* L10: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (unitd) {
+ i__2 = jc;
+ ainvp[i__2].r = 1.f, ainvp[i__2].i = 0.f;
+ }
+
+/* Form the j-th column of A*AINV. */
+
+ i__2 = *n - j + 1;
+ ctpmv_("Lower", "No transpose", diag, &i__2, &ap[jc], &ainvp[jc],
+ &c__1);
+
+/* Subtract 1 from the diagonal to form A*AINV - I. */
+
+ i__2 = jc;
+ i__3 = jc;
+ q__1.r = ainvp[i__3].r - 1.f, q__1.i = ainvp[i__3].i;
+ ainvp[i__2].r = q__1.r, ainvp[i__2].i = q__1.i;
+ jc = jc + *n - j + 1;
+/* L20: */
+ }
+ }
+
+/* Compute norm(A*AINV - I) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = clantp_("1", uplo, "Non-unit", n, &ainvp[1], &rwork[1]);
+
+ *resid = *resid * *rcond / (real) (*n) / eps;
+
+ return 0;
+
+/* End of CTPT01 */
+
+} /* ctpt01_ */
diff --git a/TESTING/LIN/ctpt02.c b/TESTING/LIN/ctpt02.c
new file mode 100644
index 0000000..13b6077
--- /dev/null
+++ b/TESTING/LIN/ctpt02.c
@@ -0,0 +1,196 @@
+/* ctpt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static complex c_b12 = {-1.f,0.f};
+
+/* Subroutine */ int ctpt02_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, complex *ap, complex *x, integer *ldx, complex *b,
+ integer *ldb, complex *work, real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j;
+ real eps;
+ extern logical lsame_(char *, char *);
+ real anorm, bnorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *), ctpmv_(char *, char *, char *,
+ integer *, complex *, complex *, integer *);
+ real xnorm;
+ extern doublereal slamch_(char *), clantp_(char *, char *, char *,
+ integer *, complex *, real *), scasum_(
+ integer *, complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTPT02 computes the residual for the computed solution to a */
+/* triangular system of linear equations A*x = b, A**T *x = b, or */
+/* A**H *x = b, when the triangular matrix A is stored in packed format. */
+/* Here A**T denotes the transpose of A, A**H denotes the conjugate */
+/* transpose of A, and x and b are N by NRHS matrices. The test ratio */
+/* is the maximum over the number of right hand sides of */
+/* the maximum over the number of right hand sides of */
+/* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A, A**T, or A**H, and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = b (No transpose) */
+/* = 'T': A**T *x = b (Transpose) */
+/* = 'C': A**H *x = b (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ --ap;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Compute the 1-norm of A or A**H. */
+
+ if (lsame_(trans, "N")) {
+ anorm = clantp_("1", uplo, diag, n, &ap[1], &rwork[1]);
+ } else {
+ anorm = clantp_("I", uplo, diag, n, &ap[1], &rwork[1]);
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ctpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1);
+ caxpy_(n, &c_b12, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ bnorm = scasum_(n, &work[1], &c__1);
+ xnorm = scasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of CTPT02 */
+
+} /* ctpt02_ */
diff --git a/TESTING/LIN/ctpt03.c b/TESTING/LIN/ctpt03.c
new file mode 100644
index 0000000..e8f00ce
--- /dev/null
+++ b/TESTING/LIN/ctpt03.c
@@ -0,0 +1,253 @@
+/* ctpt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ctpt03_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, complex *ap, real *scale, real *cnorm, real *tscal,
+ complex *x, integer *ldx, complex *b, integer *ldb, complex *work,
+ real *resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+
+ /* Local variables */
+ integer j, jj, ix;
+ real eps, err;
+ extern logical lsame_(char *, char *);
+ real xscal;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *), ctpmv_(char *, char *, char *,
+ integer *, complex *, complex *, integer *);
+ real tnorm, xnorm;
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *);
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTPT03 computes the residual for the solution to a scaled triangular */
+/* system of equations A*x = s*b, A**T *x = s*b, or A**H *x = s*b, */
+/* when the triangular matrix A is stored in packed format. Here A**T */
+/* denotes the transpose of A, A**H denotes the conjugate transpose of */
+/* A, s is a scalar, and x and b are N by NRHS matrices. The test ratio */
+/* is the maximum over the number of right hand sides of */
+/* norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A, A**T, or A**H, and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = s*b (No transpose) */
+/* = 'T': A**T *x = s*b (Transpose) */
+/* = 'C': A**H *x = s*b (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
+
+/* SCALE (input) REAL */
+/* The scaling factor s used in solving the triangular system. */
+
+/* CNORM (input) REAL array, dimension (N) */
+/* The 1-norms of the columns of A, not counting the diagonal. */
+
+/* TSCAL (input) REAL */
+/* The scaling factor used in computing the 1-norms in CNORM. */
+/* CNORM actually contains the column norms of TSCAL*A. */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ --ap;
+ --cnorm;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+ eps = slamch_("Epsilon");
+ smlnum = slamch_("Safe minimum");
+
+/* Compute the norm of the triangular matrix A using the column */
+/* norms already computed by CLATPS. */
+
+ tnorm = 0.f;
+ if (lsame_(diag, "N")) {
+ if (lsame_(uplo, "U")) {
+ jj = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ r__1 = tnorm, r__2 = *tscal * c_abs(&ap[jj]) + cnorm[j];
+ tnorm = dmax(r__1,r__2);
+ jj = jj + j + 1;
+/* L10: */
+ }
+ } else {
+ jj = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ r__1 = tnorm, r__2 = *tscal * c_abs(&ap[jj]) + cnorm[j];
+ tnorm = dmax(r__1,r__2);
+ jj = jj + *n - j + 1;
+/* L20: */
+ }
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ r__1 = tnorm, r__2 = *tscal + cnorm[j];
+ tnorm = dmax(r__1,r__2);
+/* L30: */
+ }
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(A) * norm(x) * EPS ). */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = icamax_(n, &work[1], &c__1);
+/* Computing MAX */
+ r__1 = 1.f, r__2 = c_abs(&x[ix + j * x_dim1]);
+ xnorm = dmax(r__1,r__2);
+ xscal = 1.f / xnorm / (real) (*n);
+ csscal_(n, &xscal, &work[1], &c__1);
+ ctpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1);
+ r__1 = -(*scale) * xscal;
+ q__1.r = r__1, q__1.i = 0.f;
+ caxpy_(n, &q__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = icamax_(n, &work[1], &c__1);
+ err = *tscal * c_abs(&work[ix]);
+ ix = icamax_(n, &x[j * x_dim1 + 1], &c__1);
+ xnorm = c_abs(&x[ix + j * x_dim1]);
+ if (err * smlnum <= xnorm) {
+ if (xnorm > 0.f) {
+ err /= xnorm;
+ }
+ } else {
+ if (err > 0.f) {
+ err = 1.f / eps;
+ }
+ }
+ if (err * smlnum <= tnorm) {
+ if (tnorm > 0.f) {
+ err /= tnorm;
+ }
+ } else {
+ if (err > 0.f) {
+ err = 1.f / eps;
+ }
+ }
+ *resid = dmax(*resid,err);
+/* L40: */
+ }
+
+ return 0;
+
+/* End of CTPT03 */
+
+} /* ctpt03_ */
diff --git a/TESTING/LIN/ctpt05.c b/TESTING/LIN/ctpt05.c
new file mode 100644
index 0000000..2b01334
--- /dev/null
+++ b/TESTING/LIN/ctpt05.c
@@ -0,0 +1,356 @@
+/* ctpt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ctpt05_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, complex *ap, complex *b, integer *ldb, complex *x,
+ integer *ldx, complex *xact, integer *ldxact, real *ferr, real *berr,
+ real *reslts)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1,
+ i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k, jc, ifu;
+ real eps, tmp, diff, axbi;
+ integer imax;
+ real unfl, ovfl;
+ logical unit;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ real xnorm;
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ real errbnd;
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTPT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* triangular matrix in packed storage format. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A'* X = B (Transpose) */
+/* = 'C': A'* X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) REAL array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) REAL array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.f;
+ reslts[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ unit = lsame_(diag, "U");
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = icamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__2 = imax + j * x_dim1;
+ r__3 = (r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x[imax + j *
+ x_dim1]), dabs(r__2));
+ xnorm = dmax(r__3,unfl);
+ diff = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * xact_dim1;
+ q__2.r = x[i__3].r - xact[i__4].r, q__2.i = x[i__3].i - xact[i__4]
+ .i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+/* Computing MAX */
+ r__3 = diff, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
+ q__1), dabs(r__2));
+ diff = dmax(r__3,r__4);
+/* L10: */
+ }
+
+ if (xnorm > 1.f) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1.f / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
+ errbnd = dmax(r__1,r__2);
+ } else {
+ errbnd = 1.f / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ ifu = 0;
+ if (unit) {
+ ifu = 1;
+ }
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ tmp = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[i__ + k *
+ b_dim1]), dabs(r__2));
+ if (upper) {
+ jc = (i__ - 1) * i__ / 2;
+ if (! notran) {
+ i__3 = i__ - ifu;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = jc + j;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&ap[jc + j]), dabs(r__2))) * ((r__3 =
+ x[i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[j
+ + k * x_dim1]), dabs(r__4)));
+/* L40: */
+ }
+ if (unit) {
+ i__3 = i__ + k * x_dim1;
+ tmp += (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + k * x_dim1]), dabs(r__2));
+ }
+ } else {
+ jc += i__;
+ if (unit) {
+ i__3 = i__ + k * x_dim1;
+ tmp += (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + k * x_dim1]), dabs(r__2));
+ jc += i__;
+ }
+ i__3 = *n;
+ for (j = i__ + ifu; j <= i__3; ++j) {
+ i__4 = jc;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&ap[jc]), dabs(r__2))) * ((r__3 = x[
+ i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[j +
+ k * x_dim1]), dabs(r__4)));
+ jc += j;
+/* L50: */
+ }
+ }
+ } else {
+ if (notran) {
+ jc = i__;
+ i__3 = i__ - ifu;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = jc;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&ap[jc]), dabs(r__2))) * ((r__3 = x[
+ i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[j +
+ k * x_dim1]), dabs(r__4)));
+ jc = jc + *n - j;
+/* L60: */
+ }
+ if (unit) {
+ i__3 = i__ + k * x_dim1;
+ tmp += (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + k * x_dim1]), dabs(r__2));
+ }
+ } else {
+ jc = (i__ - 1) * (*n - i__) + i__ * (i__ + 1) / 2;
+ if (unit) {
+ i__3 = i__ + k * x_dim1;
+ tmp += (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + k * x_dim1]), dabs(r__2));
+ }
+ i__3 = *n;
+ for (j = i__ + ifu; j <= i__3; ++j) {
+ i__4 = jc + j - i__;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&ap[jc + j - i__]), dabs(r__2))) * ((
+ r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
+ r_imag(&x[j + k * x_dim1]), dabs(r__4)));
+/* L70: */
+ }
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = dmin(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ r__1 = axbi, r__2 = (*n + 1) * unfl;
+ tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / dmax(r__1,r__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = dmax(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of CTPT05 */
+
+} /* ctpt05_ */
diff --git a/TESTING/LIN/ctpt06.c b/TESTING/LIN/ctpt06.c
new file mode 100644
index 0000000..e3805fa
--- /dev/null
+++ b/TESTING/LIN/ctpt06.c
@@ -0,0 +1,149 @@
+/* ctpt06.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ctpt06_(real *rcond, real *rcondc, char *uplo, char *
+ diag, integer *n, complex *ap, real *rwork, real *rat)
+{
+ /* System generated locals */
+ real r__1, r__2;
+
+ /* Local variables */
+ real eps, rmin, rmax, anorm;
+ extern doublereal slamch_(char *);
+ real bignum;
+ extern doublereal clantp_(char *, char *, char *, integer *, complex *,
+ real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTPT06 computes a test ratio comparing RCOND (the reciprocal */
+/* condition number of the triangular matrix A) and RCONDC, the estimate */
+/* computed by CTPCON. Information about the triangular matrix is used */
+/* if one estimate is zero and the other is non-zero to decide if */
+/* underflow in the estimate is justified. */
+
+/* Arguments */
+/* ========= */
+
+/* RCOND (input) REAL */
+/* The estimate of the reciprocal condition number obtained by */
+/* forming the explicit inverse of the matrix A and computing */
+/* RCOND = 1/( norm(A) * norm(inv(A)) ). */
+
+/* RCONDC (input) REAL */
+/* The estimate of the reciprocal condition number computed by */
+/* CTPCON. */
+
+/* UPLO (input) CHARACTER */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RAT (output) REAL */
+/* The test ratio. If both RCOND and RCONDC are nonzero, */
+/* RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1. */
+/* If RAT = 0, the two estimates are exactly the same. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --ap;
+
+ /* Function Body */
+ eps = slamch_("Epsilon");
+ rmax = dmax(*rcond,*rcondc);
+ rmin = dmin(*rcond,*rcondc);
+
+/* Do the easy cases first. */
+
+ if (rmin < 0.f) {
+
+/* Invalid value for RCOND or RCONDC, return 1/EPS. */
+
+ *rat = 1.f / eps;
+
+ } else if (rmin > 0.f) {
+
+/* Both estimates are positive, return RMAX/RMIN - 1. */
+
+ *rat = rmax / rmin - 1.f;
+
+ } else if (rmax == 0.f) {
+
+/* Both estimates zero. */
+
+ *rat = 0.f;
+
+ } else {
+
+/* One estimate is zero, the other is non-zero. If the matrix is */
+/* ill-conditioned, return the nonzero estimate multiplied by */
+/* 1/EPS; if the matrix is badly scaled, return the nonzero */
+/* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum */
+/* element in absolute value in A. */
+
+ bignum = 1.f / slamch_("Safe minimum");
+ anorm = clantp_("M", uplo, diag, n, &ap[1], &rwork[1]);
+
+/* Computing MIN */
+ r__1 = bignum / dmax(1.f,anorm), r__2 = 1.f / eps;
+ *rat = rmax * dmin(r__1,r__2);
+ }
+
+ return 0;
+
+/* End of CTPT06 */
+
+} /* ctpt06_ */
diff --git a/TESTING/LIN/ctrt01.c b/TESTING/LIN/ctrt01.c
new file mode 100644
index 0000000..8a04c77
--- /dev/null
+++ b/TESTING/LIN/ctrt01.c
@@ -0,0 +1,200 @@
+/* ctrt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ctrt01_(char *uplo, char *diag, integer *n, complex *a,
+ integer *lda, complex *ainv, integer *ldainv, real *rcond, real *
+ rwork, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, ainv_dim1, ainv_offset, i__1, i__2, i__3;
+ complex q__1;
+
+ /* Local variables */
+ integer j;
+ real eps;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
+ complex *, integer *, complex *, integer *);
+ extern doublereal slamch_(char *), clantr_(char *, char *, char *,
+ integer *, integer *, complex *, integer *, real *);
+ real ainvnm;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTRT01 computes the residual for a triangular matrix A times its */
+/* inverse: */
+/* RESID = norm( A*AINV - I ) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AINV (input) COMPLEX array, dimension (LDAINV,N) */
+/* On entry, the (triangular) inverse of the matrix A, in the */
+/* same storage format as A. */
+/* On exit, the contents of AINV are destroyed. */
+
+/* LDAINV (input) INTEGER */
+/* The leading dimension of the array AINV. LDAINV >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The reciprocal condition number of A, computed as */
+/* 1/(norm(A) * norm(AINV)). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ ainv_dim1 = *ldainv;
+ ainv_offset = 1 + ainv_dim1;
+ ainv -= ainv_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.f;
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = clantr_("1", uplo, diag, n, n, &a[a_offset], lda, &rwork[1]);
+ ainvnm = clantr_("1", uplo, diag, n, n, &ainv[ainv_offset], ldainv, &
+ rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ *rcond = 0.f;
+ *resid = 1.f / eps;
+ return 0;
+ }
+ *rcond = 1.f / anorm / ainvnm;
+
+/* Set the diagonal of AINV to 1 if AINV has unit diagonal. */
+
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * ainv_dim1;
+ ainv[i__2].r = 1.f, ainv[i__2].i = 0.f;
+/* L10: */
+ }
+ }
+
+/* Compute A * AINV, overwriting AINV. */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ctrmv_("Upper", "No transpose", diag, &j, &a[a_offset], lda, &
+ ainv[j * ainv_dim1 + 1], &c__1);
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ ctrmv_("Lower", "No transpose", diag, &i__2, &a[j + j * a_dim1],
+ lda, &ainv[j + j * ainv_dim1], &c__1);
+/* L30: */
+ }
+ }
+
+/* Subtract 1 from each diagonal element to form A*AINV - I. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * ainv_dim1;
+ i__3 = j + j * ainv_dim1;
+ q__1.r = ainv[i__3].r - 1.f, q__1.i = ainv[i__3].i;
+ ainv[i__2].r = q__1.r, ainv[i__2].i = q__1.i;
+/* L40: */
+ }
+
+/* Compute norm(A*AINV - I) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = clantr_("1", uplo, "Non-unit", n, n, &ainv[ainv_offset], ldainv,
+ &rwork[1]);
+
+ *resid = *resid * *rcond / (real) (*n) / eps;
+
+ return 0;
+
+/* End of CTRT01 */
+
+} /* ctrt01_ */
diff --git a/TESTING/LIN/ctrt02.c b/TESTING/LIN/ctrt02.c
new file mode 100644
index 0000000..982c579
--- /dev/null
+++ b/TESTING/LIN/ctrt02.c
@@ -0,0 +1,201 @@
+/* ctrt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static complex c_b12 = {-1.f,0.f};
+
+/* Subroutine */ int ctrt02_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, complex *a, integer *lda, complex *x, integer *ldx,
+ complex *b, integer *ldb, complex *work, real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j;
+ real eps;
+ extern logical lsame_(char *, char *);
+ real anorm, bnorm;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *), ctrmv_(char *, char *, char *,
+ integer *, complex *, integer *, complex *, integer *);
+ real xnorm;
+ extern doublereal slamch_(char *), clantr_(char *, char *, char *,
+ integer *, integer *, complex *, integer *, real *), scasum_(integer *, complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTRT02 computes the residual for the computed solution to a */
+/* triangular system of linear equations A*x = b, A**T *x = b, */
+/* or A**H *x = b. Here A is a triangular matrix, A**T is the transpose */
+/* of A, A**H is the conjugate transpose of A, and x and b are N by NRHS */
+/* matrices. The test ratio is the maximum over the number of right */
+/* hand sides of */
+/* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A, A**T, or A**H, and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = b (No transpose) */
+/* = 'T': A**T *x = b (Transpose) */
+/* = 'C': A**H *x = b (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Compute the 1-norm of A or A**H. */
+
+ if (lsame_(trans, "N")) {
+ anorm = clantr_("1", uplo, diag, n, n, &a[a_offset], lda, &rwork[1]);
+ } else {
+ anorm = clantr_("I", uplo, diag, n, n, &a[a_offset], lda, &rwork[1]);
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ) */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ctrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
+ caxpy_(n, &c_b12, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ bnorm = scasum_(n, &work[1], &c__1);
+ xnorm = scasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of CTRT02 */
+
+} /* ctrt02_ */
diff --git a/TESTING/LIN/ctrt03.c b/TESTING/LIN/ctrt03.c
new file mode 100644
index 0000000..9d5bceb
--- /dev/null
+++ b/TESTING/LIN/ctrt03.c
@@ -0,0 +1,247 @@
+/* ctrt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ctrt03_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, complex *a, integer *lda, real *scale, real *cnorm,
+ real *tscal, complex *x, integer *ldx, complex *b, integer *ldb,
+ complex *work, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+ complex q__1;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+
+ /* Local variables */
+ integer j, ix;
+ real eps, err;
+ extern logical lsame_(char *, char *);
+ real xscal;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *), ctrmv_(char *, char *, char *,
+ integer *, complex *, integer *, complex *, integer *);
+ real tnorm, xnorm;
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *);
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTRT03 computes the residual for the solution to a scaled triangular */
+/* system of equations A*x = s*b, A**T *x = s*b, or A**H *x = s*b. */
+/* Here A is a triangular matrix, A**T denotes the transpose of A, A**H */
+/* denotes the conjugate transpose of A, s is a scalar, and x and b are */
+/* N by NRHS matrices. The test ratio is the maximum over the number of */
+/* right hand sides of */
+/* norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A, A**T, or A**H, and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = s*b (No transpose) */
+/* = 'T': A**T *x = s*b (Transpose) */
+/* = 'C': A**H *x = s*b (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* SCALE (input) REAL */
+/* The scaling factor s used in solving the triangular system. */
+
+/* CNORM (input) REAL array, dimension (N) */
+/* The 1-norms of the columns of A, not counting the diagonal. */
+
+/* TSCAL (input) REAL */
+/* The scaling factor used in computing the 1-norms in CNORM. */
+/* CNORM actually contains the column norms of TSCAL*A. */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) COMPLEX array, dimension (N) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --cnorm;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+ eps = slamch_("Epsilon");
+ smlnum = slamch_("Safe minimum");
+
+/* Compute the norm of the triangular matrix A using the column */
+/* norms already computed by CLATRS. */
+
+ tnorm = 0.f;
+ if (lsame_(diag, "N")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ r__1 = tnorm, r__2 = *tscal * c_abs(&a[j + j * a_dim1]) + cnorm[j]
+ ;
+ tnorm = dmax(r__1,r__2);
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ r__1 = tnorm, r__2 = *tscal + cnorm[j];
+ tnorm = dmax(r__1,r__2);
+/* L20: */
+ }
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = icamax_(n, &work[1], &c__1);
+/* Computing MAX */
+ r__1 = 1.f, r__2 = c_abs(&x[ix + j * x_dim1]);
+ xnorm = dmax(r__1,r__2);
+ xscal = 1.f / xnorm / (real) (*n);
+ csscal_(n, &xscal, &work[1], &c__1);
+ ctrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
+ r__1 = -(*scale) * xscal;
+ q__1.r = r__1, q__1.i = 0.f;
+ caxpy_(n, &q__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = icamax_(n, &work[1], &c__1);
+ err = *tscal * c_abs(&work[ix]);
+ ix = icamax_(n, &x[j * x_dim1 + 1], &c__1);
+ xnorm = c_abs(&x[ix + j * x_dim1]);
+ if (err * smlnum <= xnorm) {
+ if (xnorm > 0.f) {
+ err /= xnorm;
+ }
+ } else {
+ if (err > 0.f) {
+ err = 1.f / eps;
+ }
+ }
+ if (err * smlnum <= tnorm) {
+ if (tnorm > 0.f) {
+ err /= tnorm;
+ }
+ } else {
+ if (err > 0.f) {
+ err = 1.f / eps;
+ }
+ }
+ *resid = dmax(*resid,err);
+/* L30: */
+ }
+
+ return 0;
+
+/* End of CTRT03 */
+
+} /* ctrt03_ */
diff --git a/TESTING/LIN/ctrt05.c b/TESTING/LIN/ctrt05.c
new file mode 100644
index 0000000..e6b8587
--- /dev/null
+++ b/TESTING/LIN/ctrt05.c
@@ -0,0 +1,355 @@
+/* ctrt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ctrt05_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, complex *a, integer *lda, complex *b, integer *ldb,
+ complex *x, integer *ldx, complex *xact, integer *ldxact, real *ferr,
+ real *berr, real *reslts)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3, r__4;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double r_imag(complex *);
+
+ /* Local variables */
+ integer i__, j, k, ifu;
+ real eps, tmp, diff, axbi;
+ integer imax;
+ real unfl, ovfl;
+ logical unit;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ real xnorm;
+ extern integer icamax_(integer *, complex *, integer *);
+ extern doublereal slamch_(char *);
+ real errbnd;
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTRT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* triangular n by n matrix. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A'* X = B (Transpose) */
+/* = 'C': A'* X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) COMPLEX array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) COMPLEX array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) REAL array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) REAL array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.f;
+ reslts[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ unit = lsame_(diag, "U");
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = icamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__2 = imax + j * x_dim1;
+ r__3 = (r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x[imax + j *
+ x_dim1]), dabs(r__2));
+ xnorm = dmax(r__3,unfl);
+ diff = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * xact_dim1;
+ q__2.r = x[i__3].r - xact[i__4].r, q__2.i = x[i__3].i - xact[i__4]
+ .i;
+ q__1.r = q__2.r, q__1.i = q__2.i;
+/* Computing MAX */
+ r__3 = diff, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
+ q__1), dabs(r__2));
+ diff = dmax(r__3,r__4);
+/* L10: */
+ }
+
+ if (xnorm > 1.f) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1.f / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
+ errbnd = dmax(r__1,r__2);
+ } else {
+ errbnd = 1.f / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ ifu = 0;
+ if (unit) {
+ ifu = 1;
+ }
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ tmp = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[i__ + k *
+ b_dim1]), dabs(r__2));
+ if (upper) {
+ if (! notran) {
+ i__3 = i__ - ifu;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j + i__ * a_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[j + i__ * a_dim1]), dabs(r__2))) * (
+ (r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
+ r_imag(&x[j + k * x_dim1]), dabs(r__4)));
+/* L40: */
+ }
+ if (unit) {
+ i__3 = i__ + k * x_dim1;
+ tmp += (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + k * x_dim1]), dabs(r__2));
+ }
+ } else {
+ if (unit) {
+ i__3 = i__ + k * x_dim1;
+ tmp += (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + k * x_dim1]), dabs(r__2));
+ }
+ i__3 = *n;
+ for (j = i__ + ifu; j <= i__3; ++j) {
+ i__4 = i__ + j * a_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2))) * (
+ (r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
+ r_imag(&x[j + k * x_dim1]), dabs(r__4)));
+/* L50: */
+ }
+ }
+ } else {
+ if (notran) {
+ i__3 = i__ - ifu;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = i__ + j * a_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[i__ + j * a_dim1]), dabs(r__2))) * (
+ (r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
+ r_imag(&x[j + k * x_dim1]), dabs(r__4)));
+/* L60: */
+ }
+ if (unit) {
+ i__3 = i__ + k * x_dim1;
+ tmp += (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + k * x_dim1]), dabs(r__2));
+ }
+ } else {
+ if (unit) {
+ i__3 = i__ + k * x_dim1;
+ tmp += (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
+ r_imag(&x[i__ + k * x_dim1]), dabs(r__2));
+ }
+ i__3 = *n;
+ for (j = i__ + ifu; j <= i__3; ++j) {
+ i__4 = j + i__ * a_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
+ r_imag(&a[j + i__ * a_dim1]), dabs(r__2))) * (
+ (r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
+ r_imag(&x[j + k * x_dim1]), dabs(r__4)));
+/* L70: */
+ }
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = dmin(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ r__1 = axbi, r__2 = (*n + 1) * unfl;
+ tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / dmax(r__1,r__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = dmax(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of CTRT05 */
+
+} /* ctrt05_ */
diff --git a/TESTING/LIN/ctrt06.c b/TESTING/LIN/ctrt06.c
new file mode 100644
index 0000000..5aa7c2c
--- /dev/null
+++ b/TESTING/LIN/ctrt06.c
@@ -0,0 +1,157 @@
+/* ctrt06.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ctrt06_(real *rcond, real *rcondc, char *uplo, char *
+ diag, integer *n, complex *a, integer *lda, real *rwork, real *rat)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset;
+ real r__1, r__2;
+
+ /* Local variables */
+ real eps, rmin, rmax, anorm;
+ extern doublereal slamch_(char *);
+ real bignum;
+ extern doublereal clantr_(char *, char *, char *, integer *, integer *,
+ complex *, integer *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTRT06 computes a test ratio comparing RCOND (the reciprocal */
+/* condition number of a triangular matrix A) and RCONDC, the estimate */
+/* computed by CTRCON. Information about the triangular matrix A is */
+/* used if one estimate is zero and the other is non-zero to decide if */
+/* underflow in the estimate is justified. */
+
+/* Arguments */
+/* ========= */
+
+/* RCOND (input) REAL */
+/* The estimate of the reciprocal condition number obtained by */
+/* forming the explicit inverse of the matrix A and computing */
+/* RCOND = 1/( norm(A) * norm(inv(A)) ). */
+
+/* RCONDC (input) REAL */
+/* The estimate of the reciprocal condition number computed by */
+/* CTRCON. */
+
+/* UPLO (input) CHARACTER */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RAT (output) REAL */
+/* The test ratio. If both RCOND and RCONDC are nonzero, */
+/* RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1. */
+/* If RAT = 0, the two estimates are exactly the same. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --rwork;
+
+ /* Function Body */
+ eps = slamch_("Epsilon");
+ rmax = dmax(*rcond,*rcondc);
+ rmin = dmin(*rcond,*rcondc);
+
+/* Do the easy cases first. */
+
+ if (rmin < 0.f) {
+
+/* Invalid value for RCOND or RCONDC, return 1/EPS. */
+
+ *rat = 1.f / eps;
+
+ } else if (rmin > 0.f) {
+
+/* Both estimates are positive, return RMAX/RMIN - 1. */
+
+ *rat = rmax / rmin - 1.f;
+
+ } else if (rmax == 0.f) {
+
+/* Both estimates zero. */
+
+ *rat = 0.f;
+
+ } else {
+
+/* One estimate is zero, the other is non-zero. If the matrix is */
+/* ill-conditioned, return the nonzero estimate multiplied by */
+/* 1/EPS; if the matrix is badly scaled, return the nonzero */
+/* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum */
+/* element in absolute value in A. */
+
+ bignum = 1.f / slamch_("Safe minimum");
+ anorm = clantr_("M", uplo, diag, n, n, &a[a_offset], lda, &rwork[1]);
+
+/* Computing MIN */
+ r__1 = bignum / dmax(1.f,anorm), r__2 = 1.f / eps;
+ *rat = rmax * dmin(r__1,r__2);
+ }
+
+ return 0;
+
+/* End of CTRT06 */
+
+} /* ctrt06_ */
diff --git a/TESTING/LIN/ctzt01.c b/TESTING/LIN/ctzt01.c
new file mode 100644
index 0000000..ae748ae
--- /dev/null
+++ b/TESTING/LIN/ctzt01.c
@@ -0,0 +1,177 @@
+/* ctzt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static complex c_b6 = {0.f,0.f};
+static integer c__1 = 1;
+static complex c_b15 = {-1.f,0.f};
+
+doublereal ctzt01_(integer *m, integer *n, complex *a, complex *af, integer *
+ lda, complex *tau, complex *work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
+ real ret_val;
+
+ /* Local variables */
+ integer i__, j;
+ real norma;
+ extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ real rwork[1];
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), xerbla_(char *,
+ integer *), clatzm_(char *, integer *, integer *, complex
+ *, integer *, complex *, complex *, complex *, integer *, complex
+ *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTZT01 returns */
+/* || A - R*Q || / ( M * eps * ||A|| ) */
+/* for an upper trapezoidal A that was factored with CTZRQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices A and AF. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and AF. */
+
+/* A (input) COMPLEX array, dimension (LDA,N) */
+/* The original upper trapezoidal M by N matrix A. */
+
+/* AF (input) COMPLEX array, dimension (LDA,N) */
+/* The output of CTZRQF for input matrix A. */
+/* The lower triangle is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A and AF. */
+
+/* TAU (input) COMPLEX array, dimension (M) */
+/* Details of the Householder transformations as returned by */
+/* CTZRQF. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= m*n + m. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ if (*lwork < *m * *n + *m) {
+ xerbla_("CTZT01", &c__8);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return ret_val;
+ }
+
+ norma = clange_("One-norm", m, n, &a[a_offset], lda, rwork);
+
+/* Copy upper triangle R */
+
+ claset_("Full", m, n, &c_b6, &c_b6, &work[1], m);
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = (j - 1) * *m + i__;
+ i__4 = i__ + j * af_dim1;
+ work[i__3].r = af[i__4].r, work[i__3].i = af[i__4].i;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* R = R * P(1) * ... *P(m) */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n - *m + 1;
+ clatzm_("Right", &i__, &i__2, &af[i__ + (*m + 1) * af_dim1], lda, &
+ tau[i__], &work[(i__ - 1) * *m + 1], &work[*m * *m + 1], m, &
+ work[*m * *n + 1]);
+/* L30: */
+ }
+
+/* R = R - A */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ caxpy_(m, &c_b15, &a[i__ * a_dim1 + 1], &c__1, &work[(i__ - 1) * *m +
+ 1], &c__1);
+/* L40: */
+ }
+
+ ret_val = clange_("One-norm", m, n, &work[1], m, rwork);
+
+ ret_val /= slamch_("Epsilon") * (real) max(*m,*n);
+ if (norma != 0.f) {
+ ret_val /= norma;
+ }
+
+ return ret_val;
+
+/* End of CTZT01 */
+
+} /* ctzt01_ */
diff --git a/TESTING/LIN/ctzt02.c b/TESTING/LIN/ctzt02.c
new file mode 100644
index 0000000..22680a2
--- /dev/null
+++ b/TESTING/LIN/ctzt02.c
@@ -0,0 +1,164 @@
+/* ctzt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__7 = 7;
+static complex c_b5 = {0.f,0.f};
+static complex c_b6 = {1.f,0.f};
+
+doublereal ctzt02_(integer *m, integer *n, complex *af, integer *lda, complex
+ *tau, complex *work, integer *lwork)
+{
+ /* System generated locals */
+ integer af_dim1, af_offset, i__1, i__2, i__3;
+ real ret_val;
+ complex q__1;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__;
+ real rwork[1];
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *), slamch_(char *);
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), xerbla_(char *,
+ integer *), clatzm_(char *, integer *, integer *, complex
+ *, integer *, complex *, complex *, complex *, integer *, complex
+ *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CTZT02 returns */
+/* || I - Q'*Q || / ( M * eps) */
+/* where the matrix Q is defined by the Householder transformations */
+/* generated by CTZRQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix AF. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix AF. */
+
+/* AF (input) COMPLEX array, dimension (LDA,N) */
+/* The output of CTZRQF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array AF. */
+
+/* TAU (input) COMPLEX array, dimension (M) */
+/* Details of the Householder transformations as returned by */
+/* CTZRQF. */
+
+/* WORK (workspace) COMPLEX array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* length of WORK array. Must be >= N*N+N */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ if (*lwork < *n * *n + *n) {
+ xerbla_("CTZT02", &c__7);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return ret_val;
+ }
+
+/* Q := I */
+
+ claset_("Full", n, n, &c_b5, &c_b6, &work[1], n);
+
+/* Q := P(1) * ... * P(m) * Q */
+
+ for (i__ = *m; i__ >= 1; --i__) {
+ i__1 = *n - *m + 1;
+ clatzm_("Left", &i__1, n, &af[i__ + (*m + 1) * af_dim1], lda, &tau[
+ i__], &work[i__], &work[*m + 1], n, &work[*n * *n + 1]);
+/* L10: */
+ }
+
+/* Q := P(m)' * ... * P(1)' * Q */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n - *m + 1;
+ r_cnjg(&q__1, &tau[i__]);
+ clatzm_("Left", &i__2, n, &af[i__ + (*m + 1) * af_dim1], lda, &q__1, &
+ work[i__], &work[*m + 1], n, &work[*n * *n + 1]);
+/* L20: */
+ }
+
+/* Q := Q - I */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = (i__ - 1) * *n + i__;
+ i__3 = (i__ - 1) * *n + i__;
+ q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i;
+ work[i__2].r = q__1.r, work[i__2].i = q__1.i;
+/* L30: */
+ }
+
+ ret_val = clange_("One-norm", n, n, &work[1], n, rwork) / (
+ slamch_("Epsilon") * (real) max(*m,*n));
+ return ret_val;
+
+/* End of CTZT02 */
+
+} /* ctzt02_ */
diff --git a/TESTING/LIN/dchkaa.c b/TESTING/LIN/dchkaa.c
new file mode 100644
index 0000000..1294235
--- /dev/null
+++ b/TESTING/LIN/dchkaa.c
@@ -0,0 +1,1387 @@
+/* dchkaa.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+struct {
+ integer iparms[100];
+} claenv_;
+
+#define claenv_1 claenv_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__12 = 12;
+static integer c__0 = 0;
+static integer c__132 = 132;
+static integer c__16 = 16;
+static integer c__100 = 100;
+static integer c__5 = 5;
+static integer c__8 = 8;
+static integer c__2 = 2;
+static integer c__6 = 6;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Initialized data */
+
+ static doublereal threq = 2.;
+ static char intstr[10] = "0123456789";
+
+ /* Format strings */
+ static char fmt_9994[] = "(\002 Tests of the DOUBLE PRECISION LAPACK rou"
+ "tines \002,/\002 LAPACK VERSION \002,i1,\002.\002,i1,\002.\002,i"
+ "1,//\002 The following parameter values will be used:\002)";
+ static char fmt_9996[] = "(\002 Invalid input value: \002,a4,\002=\002,i"
+ "6,\002; must be >=\002,i6)";
+ static char fmt_9995[] = "(\002 Invalid input value: \002,a4,\002=\002,i"
+ "6,\002; must be <=\002,i6)";
+ static char fmt_9993[] = "(4x,a4,\002: \002,10i6,/11x,10i6)";
+ static char fmt_9992[] = "(/\002 Routines pass computational tests if te"
+ "st ratio is \002,\002less than\002,f8.2,/)";
+ static char fmt_9999[] = "(/\002 Execution not attempted due to input er"
+ "rors\002)";
+ static char fmt_9991[] = "(\002 Relative machine \002,a,\002 is taken to"
+ " be\002,d16.6)";
+ static char fmt_9990[] = "(/1x,a3,\002: Unrecognized path name\002)";
+ static char fmt_9989[] = "(/1x,a3,\002 routines were not tested\002)";
+ static char fmt_9988[] = "(/1x,a3,\002 driver routines were not teste"
+ "d\002)";
+ static char fmt_9998[] = "(/\002 End of tests\002)";
+ static char fmt_9997[] = "(\002 Total time used = \002,f12.2,\002 seco"
+ "nds\002,/)";
+
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1;
+ cilist ci__1;
+ cllist cl__1;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), e_rsle(void), s_wsfe(cilist *), do_fio(integer *
+ , char *, ftnlen), e_wsfe(void), do_lio(integer *, integer *,
+ char *, ftnlen);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_rsfe(cilist *), e_rsfe(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer f_clos(cllist *);
+
+ /* Local variables */
+ doublereal a[153384] /* was [21912][7] */, b[8448] /* was [2112][
+ 4] */;
+ integer i__, j, k;
+ doublereal s[264];
+ char c1[1], c2[2];
+ doublereal s1, s2;
+ integer ic, la, nb, nm, nn, vers_patch__, vers_major__, vers_minor__, lda,
+ nnb;
+ doublereal eps;
+ integer nns, piv[132], nnb2;
+ char path[3];
+ integer mval[12], nval[12], nrhs;
+ doublereal work[23496] /* was [132][178] */;
+ integer lafac;
+ logical fatal;
+ char aline[72];
+ extern logical lsame_(char *, char *);
+ integer nbval[12], nrank, nmats, nsval[12], nxval[12], iwork[3300];
+ doublereal rwork[692];
+ extern /* Subroutine */ int dchkq3_(logical *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, doublereal
+ *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *);
+ integer nbval2[12];
+ extern /* Subroutine */ int dchkgb_(logical *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ doublereal *, logical *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *), dchkge_(logical *, integer *
+, integer *, integer *, integer *, integer *, integer *, integer *
+, integer *, doublereal *, logical *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dchkpb_(logical *, integer *, integer *,
+ integer *, integer *, integer *, integer *, doublereal *, logical
+ *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *), dchkeq_(doublereal *,
+ integer *);
+ extern doublereal dsecnd_(void);
+ extern /* Subroutine */ int dchktb_(logical *, integer *, integer *,
+ integer *, integer *, doublereal *, logical *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *),
+ dchkgt_(logical *, integer *, integer *, integer *, integer *,
+ doublereal *, logical *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *
+, integer *), alareq_(char *, integer *, logical *, integer *,
+ integer *, integer *), dchklq_(logical *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, doublereal *, logical *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *), dchkql_(
+ logical *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, logical *, integer
+ *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *),
+ dchkpo_(logical *, integer *, integer *, integer *, integer *,
+ integer *, integer *, doublereal *, logical *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *), dchkpp_(logical *, integer *, integer *, integer *,
+ integer *, doublereal *, logical *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *),
+ dchkqp_(logical *, integer *, integer *, integer *, integer *,
+ doublereal *, logical *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *),
+ ddrvgb_(logical *, integer *, integer *, integer *, doublereal *,
+ logical *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *), dchkps_(logical *, integer *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, logical *, integer
+ *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dchkpt_(logical *,
+ integer *, integer *, integer *, integer *, doublereal *, logical
+ *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *)
+ , dchkqr_(logical *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, doublereal *, logical
+ *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int dchkrq_(logical *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ doublereal *, logical *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *), dchksp_(logical *, integer *,
+ integer *, integer *, integer *, doublereal *, logical *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *
+, integer *), dchktp_(logical *, integer *, integer *, integer *,
+ integer *, doublereal *, logical *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *), dchktr_(
+ logical *, integer *, integer *, integer *, integer *, integer *,
+ integer *, doublereal *, logical *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *), ddrvge_(
+ logical *, integer *, integer *, integer *, doublereal *, logical
+ *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *),
+ dchksy_(logical *, integer *, integer *, integer *, integer *,
+ integer *, integer *, doublereal *, logical *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *), ddrvpb_(logical *, integer *, integer *, integer *,
+ doublereal *, logical *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *), dchktz_(logical *, integer *, integer *, integer *,
+ integer *, doublereal *, logical *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *)
+ , ilaver_(integer *, integer *, integer *), ddrvgt_(logical *,
+ integer *, integer *, integer *, doublereal *, logical *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *);
+ doublereal thresh;
+ extern /* Subroutine */ int ddrvls_(logical *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, doublereal *, logical *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *), ddrvpo_(
+ logical *, integer *, integer *, integer *, doublereal *, logical
+ *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *);
+ logical tstchk;
+ extern /* Subroutine */ int ddrvpp_(logical *, integer *, integer *,
+ integer *, doublereal *, logical *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *), ddrvpt_(logical *, integer *,
+ integer *, integer *, doublereal *, logical *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ logical dotype[30];
+ extern /* Subroutine */ int ddrvsp_(logical *, integer *, integer *,
+ integer *, doublereal *, logical *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *),
+ ddrvsy_(logical *, integer *, integer *, integer *, doublereal *,
+ logical *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *);
+ integer ntypes;
+ logical tsterr, tstdrv;
+ integer rankval[12];
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 5, 0, 0, 0 };
+ static cilist io___10 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___11 = { 0, 5, 0, 0, 0 };
+ static cilist io___13 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___14 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___15 = { 0, 5, 0, 0, 0 };
+ static cilist io___18 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___19 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___20 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___21 = { 0, 5, 0, 0, 0 };
+ static cilist io___23 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___24 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___25 = { 0, 5, 0, 0, 0 };
+ static cilist io___27 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___28 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___29 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___30 = { 0, 5, 0, 0, 0 };
+ static cilist io___32 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___33 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___34 = { 0, 5, 0, 0, 0 };
+ static cilist io___36 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___37 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___38 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___39 = { 0, 5, 0, 0, 0 };
+ static cilist io___41 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___42 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___43 = { 0, 5, 0, 0, 0 };
+ static cilist io___45 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___46 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___51 = { 0, 5, 0, 0, 0 };
+ static cilist io___53 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___54 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___55 = { 0, 5, 0, 0, 0 };
+ static cilist io___57 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___58 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___59 = { 0, 5, 0, 0, 0 };
+ static cilist io___61 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___62 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___63 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___64 = { 0, 5, 0, 0, 0 };
+ static cilist io___66 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___67 = { 0, 5, 0, 0, 0 };
+ static cilist io___69 = { 0, 5, 0, 0, 0 };
+ static cilist io___71 = { 0, 5, 0, 0, 0 };
+ static cilist io___73 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___75 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___76 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___77 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___78 = { 0, 6, 0, 0, 0 };
+ static cilist io___87 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___88 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___96 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___98 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___101 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___102 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___103 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___104 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___105 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___106 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___108 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___109 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___110 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___111 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___112 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___113 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___114 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___115 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___116 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___117 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___118 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___119 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___120 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___121 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___122 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___123 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___124 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___125 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___126 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___127 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___128 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___129 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___130 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___132 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___133 = { 0, 6, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKAA is the main test program for the DOUBLE PRECISION LAPACK */
+/* linear equation routines */
+
+/* The program must be driven by a short data file. The first 14 records */
+/* specify problem dimensions and program options using list-directed */
+/* input. The remaining lines specify the LAPACK test paths and the */
+/* number of matrix types to use in testing. An annotated example of a */
+/* data file can be obtained by deleting the first 3 characters from the */
+/* following 36 lines: */
+/* Data file for testing DOUBLE PRECISION LAPACK linear eqn. routines */
+/* 7 Number of values of M */
+/* 0 1 2 3 5 10 16 Values of M (row dimension) */
+/* 7 Number of values of N */
+/* 0 1 2 3 5 10 16 Values of N (column dimension) */
+/* 1 Number of values of NRHS */
+/* 2 Values of NRHS (number of right hand sides) */
+/* 5 Number of values of NB */
+/* 1 3 3 3 20 Values of NB (the blocksize) */
+/* 1 0 5 9 1 Values of NX (crossover point) */
+/* 3 Number of values of RANK */
+/* 30 50 90 Values of rank (as a % of N) */
+/* 20.0 Threshold value of test ratio */
+/* T Put T to test the LAPACK routines */
+/* T Put T to test the driver routines */
+/* T Put T to test the error exits */
+/* DGE 11 List types on next line if 0 < NTYPES < 11 */
+/* DGB 8 List types on next line if 0 < NTYPES < 8 */
+/* DGT 12 List types on next line if 0 < NTYPES < 12 */
+/* DPO 9 List types on next line if 0 < NTYPES < 9 */
+/* DPS 9 List types on next line if 0 < NTYPES < 9 */
+/* 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 */
+/* DSY 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 */
+/* DTB 17 List types on next line if 0 < NTYPES < 17 */
+/* DQR 8 List types on next line if 0 < NTYPES < 8 */
+/* DRQ 8 List types on next line if 0 < NTYPES < 8 */
+/* DLQ 8 List types on next line if 0 < NTYPES < 8 */
+/* DQL 8 List types on next line if 0 < NTYPES < 8 */
+/* DQP 6 List types on next line if 0 < NTYPES < 6 */
+/* DTZ 3 List types on next line if 0 < NTYPES < 3 */
+/* DLS 6 List types on next line if 0 < NTYPES < 6 */
+/* DEQ */
+
+/* Internal Parameters */
+/* =================== */
+
+/* NMAX INTEGER */
+/* The maximum allowable value for N */
+
+/* MAXIN INTEGER */
+/* The number of different values that can be used for each of */
+/* M, N, NRHS, NB, and NX */
+
+/* MAXRHS INTEGER */
+/* The maximum number of right hand sides */
+
+/* NIN INTEGER */
+/* The unit number for input */
+
+/* NOUT INTEGER */
+/* The unit number for output */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ s1 = dsecnd_();
+ lda = 132;
+ fatal = FALSE_;
+
+/* Read a dummy line. */
+
+ s_rsle(&io___6);
+ e_rsle();
+
+/* Report values of parameters. */
+
+ ilaver_(&vers_major__, &vers_minor__, &vers_patch__);
+ s_wsfe(&io___10);
+ do_fio(&c__1, (char *)&vers_major__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_minor__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_patch__, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+/* Read the values of M */
+
+ s_rsle(&io___11);
+ do_lio(&c__3, &c__1, (char *)&nm, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nm < 1) {
+ s_wsfe(&io___13);
+ do_fio(&c__1, " NM ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nm, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nm = 0;
+ fatal = TRUE_;
+ } else if (nm > 12) {
+ s_wsfe(&io___14);
+ do_fio(&c__1, " NM ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nm, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nm = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___15);
+ i__1 = nm;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nm;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (mval[i__ - 1] < 0) {
+ s_wsfe(&io___18);
+ do_fio(&c__1, " M ", (ftnlen)4);
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (mval[i__ - 1] > 132) {
+ s_wsfe(&io___19);
+ do_fio(&c__1, " M ", (ftnlen)4);
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L10: */
+ }
+ if (nm > 0) {
+ s_wsfe(&io___20);
+ do_fio(&c__1, "M ", (ftnlen)4);
+ i__1 = nm;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of N */
+
+ s_rsle(&io___21);
+ do_lio(&c__3, &c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nn < 1) {
+ s_wsfe(&io___23);
+ do_fio(&c__1, " NN ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ } else if (nn > 12) {
+ s_wsfe(&io___24);
+ do_fio(&c__1, " NN ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___25);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nval[i__ - 1] < 0) {
+ s_wsfe(&io___27);
+ do_fio(&c__1, " N ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nval[i__ - 1] > 132) {
+ s_wsfe(&io___28);
+ do_fio(&c__1, " N ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L20: */
+ }
+ if (nn > 0) {
+ s_wsfe(&io___29);
+ do_fio(&c__1, "N ", (ftnlen)4);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of NRHS */
+
+ s_rsle(&io___30);
+ do_lio(&c__3, &c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nns < 1) {
+ s_wsfe(&io___32);
+ do_fio(&c__1, " NNS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nns = 0;
+ fatal = TRUE_;
+ } else if (nns > 12) {
+ s_wsfe(&io___33);
+ do_fio(&c__1, " NNS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nns = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___34);
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nsval[i__ - 1] < 0) {
+ s_wsfe(&io___36);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nsval[i__ - 1] > 16) {
+ s_wsfe(&io___37);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__16, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L30: */
+ }
+ if (nns > 0) {
+ s_wsfe(&io___38);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of NB */
+
+ s_rsle(&io___39);
+ do_lio(&c__3, &c__1, (char *)&nnb, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nnb < 1) {
+ s_wsfe(&io___41);
+ do_fio(&c__1, "NNB ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nnb, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nnb = 0;
+ fatal = TRUE_;
+ } else if (nnb > 12) {
+ s_wsfe(&io___42);
+ do_fio(&c__1, "NNB ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nnb, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nnb = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___43);
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nbval[i__ - 1] < 0) {
+ s_wsfe(&io___45);
+ do_fio(&c__1, " NB ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L40: */
+ }
+ if (nnb > 0) {
+ s_wsfe(&io___46);
+ do_fio(&c__1, "NB ", (ftnlen)4);
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Set NBVAL2 to be the set of unique values of NB */
+
+ nnb2 = 0;
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nb = nbval[i__ - 1];
+ i__2 = nnb2;
+ for (j = 1; j <= i__2; ++j) {
+ if (nb == nbval2[j - 1]) {
+ goto L60;
+ }
+/* L50: */
+ }
+ ++nnb2;
+ nbval2[nnb2 - 1] = nb;
+L60:
+ ;
+ }
+
+/* Read the values of NX */
+
+ s_rsle(&io___51);
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nxval[i__ - 1] < 0) {
+ s_wsfe(&io___53);
+ do_fio(&c__1, " NX ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L70: */
+ }
+ if (nnb > 0) {
+ s_wsfe(&io___54);
+ do_fio(&c__1, "NX ", (ftnlen)4);
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of RANKVAL */
+
+ s_rsle(&io___55);
+ do_lio(&c__3, &c__1, (char *)&nrank, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nn < 1) {
+ s_wsfe(&io___57);
+ do_fio(&c__1, " NRANK ", (ftnlen)7);
+ do_fio(&c__1, (char *)&nrank, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nrank = 0;
+ fatal = TRUE_;
+ } else if (nn > 12) {
+ s_wsfe(&io___58);
+ do_fio(&c__1, " NRANK ", (ftnlen)7);
+ do_fio(&c__1, (char *)&nrank, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nrank = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___59);
+ i__1 = nrank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&rankval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nrank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (rankval[i__ - 1] < 0) {
+ s_wsfe(&io___61);
+ do_fio(&c__1, " RANK ", (ftnlen)7);
+ do_fio(&c__1, (char *)&rankval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (rankval[i__ - 1] > 100) {
+ s_wsfe(&io___62);
+ do_fio(&c__1, " RANK ", (ftnlen)7);
+ do_fio(&c__1, (char *)&rankval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__100, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+ }
+ if (nrank > 0) {
+ s_wsfe(&io___63);
+ do_fio(&c__1, "RANK % OF N", (ftnlen)11);
+ i__1 = nrank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&rankval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the threshold value for the test ratios. */
+
+ s_rsle(&io___64);
+ do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_rsle();
+ s_wsfe(&io___66);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+/* Read the flag that indicates whether to test the LAPACK routines. */
+
+ s_rsle(&io___67);
+ do_lio(&c__8, &c__1, (char *)&tstchk, (ftnlen)sizeof(logical));
+ e_rsle();
+
+/* Read the flag that indicates whether to test the driver routines. */
+
+ s_rsle(&io___69);
+ do_lio(&c__8, &c__1, (char *)&tstdrv, (ftnlen)sizeof(logical));
+ e_rsle();
+
+/* Read the flag that indicates whether to test the error exits. */
+
+ s_rsle(&io___71);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+
+ if (fatal) {
+ s_wsfe(&io___73);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Calculate and print the machine dependent constants. */
+
+ eps = dlamch_("Underflow threshold");
+ s_wsfe(&io___75);
+ do_fio(&c__1, "underflow", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ eps = dlamch_("Overflow threshold");
+ s_wsfe(&io___76);
+ do_fio(&c__1, "overflow ", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ eps = dlamch_("Epsilon");
+ s_wsfe(&io___77);
+ do_fio(&c__1, "precision", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_wsle(&io___78);
+ e_wsle();
+
+L80:
+
+/* Read a test path and the number of matrix types to use. */
+
+ ci__1.cierr = 0;
+ ci__1.ciend = 1;
+ ci__1.ciunit = 5;
+ ci__1.cifmt = "(A72)";
+ i__1 = s_rsfe(&ci__1);
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = do_fio(&c__1, aline, (ftnlen)72);
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L140;
+ }
+ s_copy(path, aline, (ftnlen)3, (ftnlen)3);
+ nmats = 30;
+ i__ = 3;
+L90:
+ ++i__;
+ if (i__ > 72) {
+ nmats = 30;
+ goto L130;
+ }
+ if (*(unsigned char *)&aline[i__ - 1] == ' ') {
+ goto L90;
+ }
+ nmats = 0;
+L100:
+ *(unsigned char *)c1 = *(unsigned char *)&aline[i__ - 1];
+ for (k = 1; k <= 10; ++k) {
+ if (*(unsigned char *)c1 == *(unsigned char *)&intstr[k - 1]) {
+ ic = k - 1;
+ goto L120;
+ }
+/* L110: */
+ }
+ goto L130;
+L120:
+ nmats = nmats * 10 + ic;
+ ++i__;
+ if (i__ > 72) {
+ goto L130;
+ }
+ goto L100;
+L130:
+ *(unsigned char *)c1 = *(unsigned char *)path;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ nrhs = nsval[0];
+
+/* Check first character for correct precision. */
+
+ if (! lsame_(c1, "Double precision")) {
+ s_wsfe(&io___87);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+ } else if (nmats <= 0) {
+
+/* Check for a positive number of tests requested. */
+
+ s_wsfe(&io___88);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, c2, "GE")) {
+
+/* GE: general matrices */
+
+ ntypes = 11;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ dchkge_(dotype, &nm, mval, &nn, nval, &nnb2, nbval2, &nns, nsval,
+ &thresh, &tsterr, &lda, a, &a[21912], &a[43824], b, &b[
+ 2112], &b[4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___96);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ ddrvge_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
+ work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___98);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* GB: general banded matrices */
+
+ la = 43692;
+ lafac = 65472;
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ dchkgb_(dotype, &nm, mval, &nn, nval, &nnb2, nbval2, &nns, nsval,
+ &thresh, &tsterr, a, &la, &a[43824], &lafac, b, &b[2112],
+ &b[4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___101);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ ddrvgb_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, a, &la, &a[
+ 43824], &lafac, &a[109560], b, &b[2112], &b[4224], &b[
+ 6336], s, work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___102);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "GT")) {
+
+/* GT: general tridiagonal matrices */
+
+ ntypes = 12;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ dchkgt_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, a, &a[
+ 21912], b, &b[2112], &b[4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___103);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ ddrvgt_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, a, &a[21912],
+ b, &b[2112], &b[4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___104);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "PO")) {
+
+/* PO: positive definite matrices */
+
+ ntypes = 9;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ dchkpo_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
+ tsterr, &lda, a, &a[21912], &a[43824], b, &b[2112], &b[
+ 4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___105);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ ddrvpo_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
+ work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___106);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "PS")) {
+
+/* PS: positive semi-definite matrices */
+
+ ntypes = 9;
+
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ dchkps_(dotype, &nn, nval, &nnb2, nbval2, &nrank, rankval, &
+ thresh, &tsterr, &lda, a, &a[21912], &a[43824], piv, work,
+ rwork, &c__6);
+ } else {
+ s_wsfe(&io___108);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "PP")) {
+
+/* PP: positive definite packed matrices */
+
+ ntypes = 9;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ dchkpp_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
+ &a[21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
+ iwork, &c__6);
+ } else {
+ s_wsfe(&io___109);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ ddrvpp_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
+ work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___110);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* PB: positive definite banded matrices */
+
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ dchkpb_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
+ tsterr, &lda, a, &a[21912], &a[43824], b, &b[2112], &b[
+ 4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___111);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ ddrvpb_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
+ work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___112);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "PT")) {
+
+/* PT: positive definite tridiagonal matrices */
+
+ ntypes = 12;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ dchkpt_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], work, rwork, &
+ c__6);
+ } else {
+ s_wsfe(&io___113);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ ddrvpt_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, a, &a[21912],
+ &a[43824], b, &b[2112], &b[4224], work, rwork, &c__6);
+ } else {
+ s_wsfe(&io___114);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "SY")) {
+
+/* SY: symmetric indefinite matrices */
+
+ ntypes = 10;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ dchksy_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
+ tsterr, &lda, a, &a[21912], &a[43824], b, &b[2112], &b[
+ 4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___115);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ ddrvsy_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
+ iwork, &c__6);
+ } else {
+ s_wsfe(&io___116);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "SP")) {
+
+/* SP: symmetric indefinite packed matrices */
+
+ ntypes = 10;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ dchksp_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
+ &a[21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
+ iwork, &c__6);
+ } else {
+ s_wsfe(&io___117);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ ddrvsp_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
+ iwork, &c__6);
+ } else {
+ s_wsfe(&io___118);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "TR")) {
+
+/* TR: triangular matrices */
+
+ ntypes = 18;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ dchktr_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
+ tsterr, &lda, a, &a[21912], b, &b[2112], &b[4224], work,
+ rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___119);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "TP")) {
+
+/* TP: triangular packed matrices */
+
+ ntypes = 18;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ dchktp_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
+ &a[21912], b, &b[2112], &b[4224], work, rwork, iwork, &
+ c__6);
+ } else {
+ s_wsfe(&io___120);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "TB")) {
+
+/* TB: triangular banded matrices */
+
+ ntypes = 17;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ dchktb_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
+ &a[21912], b, &b[2112], &b[4224], work, rwork, iwork, &
+ c__6);
+ } else {
+ s_wsfe(&io___121);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "QR")) {
+
+/* QR: QR factorization */
+
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ dchkqr_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
+ thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
+ 65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
+ rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___122);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "LQ")) {
+
+/* LQ: LQ factorization */
+
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ dchklq_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
+ thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
+ 65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
+ rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___123);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "QL")) {
+
+/* QL: QL factorization */
+
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ dchkql_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
+ thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
+ 65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
+ rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___124);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "RQ")) {
+
+/* RQ: RQ factorization */
+
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ dchkrq_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
+ thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
+ 65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
+ rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___125);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "QP")) {
+
+/* QP: QR factorization with pivoting */
+
+ ntypes = 6;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ dchkqp_(dotype, &nm, mval, &nn, nval, &thresh, &tsterr, a, &a[
+ 21912], b, &b[2112], &b[4224], work, iwork, &c__6);
+ dchkq3_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &thresh,
+ a, &a[21912], b, &b[2112], &b[4224], work, iwork, &c__6);
+ } else {
+ s_wsfe(&io___126);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "TZ")) {
+
+/* TZ: Trapezoidal matrix */
+
+ ntypes = 3;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ dchktz_(dotype, &nm, mval, &nn, nval, &thresh, &tsterr, a, &a[
+ 21912], b, &b[2112], &b[4224], work, &c__6);
+ } else {
+ s_wsfe(&io___127);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "LS")) {
+
+/* LS: Least squares drivers */
+
+ ntypes = 6;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstdrv) {
+ ddrvls_(dotype, &nm, mval, &nn, nval, &nns, nsval, &nnb, nbval,
+ nxval, &thresh, &tsterr, a, &a[21912], b, &b[2112], &b[
+ 4224], rwork, &rwork[132], work, iwork, &c__6);
+ } else {
+ s_wsfe(&io___128);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "EQ")) {
+
+/* EQ: Equilibration routines for general and positive definite */
+/* matrices (THREQ should be between 2 and 10) */
+
+ if (tstchk) {
+ dchkeq_(&threq, &c__6);
+ } else {
+ s_wsfe(&io___129);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else {
+
+ s_wsfe(&io___130);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+/* Go back to get another input line. */
+
+ goto L80;
+
+/* Branch to this line when the last record is read. */
+
+L140:
+ cl__1.cerr = 0;
+ cl__1.cunit = 5;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ s2 = dsecnd_();
+ s_wsfe(&io___132);
+ e_wsfe();
+ s_wsfe(&io___133);
+ d__1 = s2 - s1;
+ do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+
+/* End of DCHKAA */
+
+ return 0;
+} /* MAIN__ */
+
+/* Main program alias */ int dchkaa_ () { MAIN__ (); return 0; }
diff --git a/TESTING/LIN/dchkab.c b/TESTING/LIN/dchkab.c
new file mode 100644
index 0000000..0b89041
--- /dev/null
+++ b/TESTING/LIN/dchkab.c
@@ -0,0 +1,573 @@
+/* dchkab.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__12 = 12;
+static integer c__0 = 0;
+static integer c__132 = 132;
+static integer c__16 = 16;
+static integer c__5 = 5;
+static integer c__8 = 8;
+static integer c__2 = 2;
+static integer c__6 = 6;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Initialized data */
+
+ static char intstr[10] = "0123456789";
+
+ /* Format strings */
+ static char fmt_9994[] = "(\002 Tests of the DOUBLE PRECISION LAPACK DSG"
+ "ESV/DSPOSV\002,\002 routines \002,/\002 LAPACK VERSION \002,i1"
+ ",\002.\002,i1,\002.\002,i1,//\002 The following parameter values"
+ " will be used:\002)";
+ static char fmt_9996[] = "(\002 Invalid input value: \002,a4,\002=\002,i"
+ "6,\002; must be >=\002,i6)";
+ static char fmt_9995[] = "(\002 Invalid input value: \002,a4,\002=\002,i"
+ "6,\002; must be <=\002,i6)";
+ static char fmt_9993[] = "(4x,a4,\002: \002,10i6,/11x,10i6)";
+ static char fmt_9992[] = "(/\002 Routines pass computational tests if te"
+ "st ratio is \002,\002less than\002,f8.2,/)";
+ static char fmt_9999[] = "(/\002 Execution not attempted due to input er"
+ "rors\002)";
+ static char fmt_9991[] = "(\002 Relative machine \002,a,\002 is taken to"
+ " be\002,d16.6)";
+ static char fmt_9990[] = "(/1x,a6,\002 routines were not tested\002)";
+ static char fmt_9989[] = "(/1x,a6,\002 driver routines were not teste"
+ "d\002)";
+ static char fmt_9998[] = "(/\002 End of tests\002)";
+ static char fmt_9997[] = "(\002 Total time used = \002,f12.2,\002 seco"
+ "nds\002,/)";
+
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+ cilist ci__1;
+ cllist cl__1;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), e_rsle(void), s_wsfe(cilist *), do_fio(integer *
+ , char *, ftnlen), e_wsfe(void), do_lio(integer *, integer *,
+ char *, ftnlen);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_rsfe(cilist *), e_rsfe(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer f_clos(cllist *);
+
+ /* Local variables */
+ doublereal a[34848] /* was [17424][2] */, b[4224] /* was [2112][2] */;
+ integer i__, k;
+ char c1[1], c2[2];
+ doublereal s1, s2;
+ integer ic, nm, vers_patch__, vers_major__, vers_minor__, lda;
+ doublereal eps;
+ integer nns;
+ char path[3];
+ integer mval[12], nrhs;
+ real seps;
+ doublereal work[4224];
+ logical fatal;
+ char aline[72];
+ extern logical lsame_(char *, char *);
+ integer nmats, nsval[12], iwork[132];
+ doublereal rwork[132];
+ real swork[19536];
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int derrab_(integer *);
+ extern doublereal dsecnd_(void);
+ extern /* Subroutine */ int derrac_(integer *), ddrvab_(logical *,
+ integer *, integer *, integer *, integer *, doublereal *, integer
+ *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, real *, integer *, integer *),
+ ddrvac_(logical *, integer *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, real *, integer *),
+ alareq_(char *, integer *, logical *, integer *, integer *,
+ integer *);
+ extern doublereal slamch_(char *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int ilaver_(integer *, integer *, integer *);
+ doublereal thresh;
+ logical dotype[30];
+ integer ntypes;
+ logical tsterr, tstdrv;
+
+ /* Fortran I/O blocks */
+ static cilist io___5 = { 0, 5, 0, 0, 0 };
+ static cilist io___9 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___10 = { 0, 5, 0, 0, 0 };
+ static cilist io___12 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___13 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___14 = { 0, 5, 0, 0, 0 };
+ static cilist io___17 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___18 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___19 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___20 = { 0, 5, 0, 0, 0 };
+ static cilist io___22 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___23 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___24 = { 0, 5, 0, 0, 0 };
+ static cilist io___26 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___27 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___28 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___29 = { 0, 5, 0, 0, 0 };
+ static cilist io___31 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___32 = { 0, 5, 0, 0, 0 };
+ static cilist io___34 = { 0, 5, 0, 0, 0 };
+ static cilist io___36 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___38 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___39 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___40 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___41 = { 0, 6, 0, 0, 0 };
+ static cilist io___43 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___44 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___45 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___46 = { 0, 6, 0, 0, 0 };
+ static cilist io___55 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___56 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___65 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___66 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___68 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___69 = { 0, 6, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKAB is the test program for the DOUBLE PRECISION LAPACK */
+/* DSGESV/DSPOSV routine */
+
+/* The program must be driven by a short data file. The first 5 records */
+/* specify problem dimensions and program options using list-directed */
+/* input. The remaining lines specify the LAPACK test paths and the */
+/* number of matrix types to use in testing. An annotated example of a */
+/* data file can be obtained by deleting the first 3 characters from the */
+/* following 10 lines: */
+/* Data file for testing DOUBLE PRECISION LAPACK DSGESV */
+/* 7 Number of values of M */
+/* 0 1 2 3 5 10 16 Values of M (row dimension) */
+/* 1 Number of values of NRHS */
+/* 2 Values of NRHS (number of right hand sides) */
+/* 20.0 Threshold value of test ratio */
+/* T Put T to test the LAPACK routines */
+/* T Put T to test the error exits */
+/* DGE 11 List types on next line if 0 < NTYPES < 11 */
+/* DPO 9 List types on next line if 0 < NTYPES < 9 */
+
+/* Internal Parameters */
+/* =================== */
+
+/* NMAX INTEGER */
+/* The maximum allowable value for N */
+
+/* MAXIN INTEGER */
+/* The number of different values that can be used for each of */
+/* M, N, NRHS, NB, and NX */
+
+/* MAXRHS INTEGER */
+/* The maximum number of right hand sides */
+
+/* NIN INTEGER */
+/* The unit number for input */
+
+/* NOUT INTEGER */
+/* The unit number for output */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ s1 = dsecnd_();
+ lda = 132;
+ fatal = FALSE_;
+
+/* Read a dummy line. */
+
+ s_rsle(&io___5);
+ e_rsle();
+
+/* Report values of parameters. */
+
+ ilaver_(&vers_major__, &vers_minor__, &vers_patch__);
+ s_wsfe(&io___9);
+ do_fio(&c__1, (char *)&vers_major__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_minor__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_patch__, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+/* Read the values of M */
+
+ s_rsle(&io___10);
+ do_lio(&c__3, &c__1, (char *)&nm, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nm < 1) {
+ s_wsfe(&io___12);
+ do_fio(&c__1, " NM ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nm, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nm = 0;
+ fatal = TRUE_;
+ } else if (nm > 12) {
+ s_wsfe(&io___13);
+ do_fio(&c__1, " NM ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nm, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nm = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___14);
+ i__1 = nm;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nm;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (mval[i__ - 1] < 0) {
+ s_wsfe(&io___17);
+ do_fio(&c__1, " M ", (ftnlen)4);
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (mval[i__ - 1] > 132) {
+ s_wsfe(&io___18);
+ do_fio(&c__1, " M ", (ftnlen)4);
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L10: */
+ }
+ if (nm > 0) {
+ s_wsfe(&io___19);
+ do_fio(&c__1, "M ", (ftnlen)4);
+ i__1 = nm;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of NRHS */
+
+ s_rsle(&io___20);
+ do_lio(&c__3, &c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nns < 1) {
+ s_wsfe(&io___22);
+ do_fio(&c__1, " NNS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nns = 0;
+ fatal = TRUE_;
+ } else if (nns > 12) {
+ s_wsfe(&io___23);
+ do_fio(&c__1, " NNS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nns = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___24);
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nsval[i__ - 1] < 0) {
+ s_wsfe(&io___26);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nsval[i__ - 1] > 16) {
+ s_wsfe(&io___27);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__16, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L30: */
+ }
+ if (nns > 0) {
+ s_wsfe(&io___28);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the threshold value for the test ratios. */
+
+ s_rsle(&io___29);
+ do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_rsle();
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+/* Read the flag that indicates whether to test the driver routine. */
+
+ s_rsle(&io___32);
+ do_lio(&c__8, &c__1, (char *)&tstdrv, (ftnlen)sizeof(logical));
+ e_rsle();
+
+/* Read the flag that indicates whether to test the error exits. */
+
+ s_rsle(&io___34);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+
+ if (fatal) {
+ s_wsfe(&io___36);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Calculate and print the machine dependent constants. */
+
+ seps = slamch_("Underflow threshold");
+ s_wsfe(&io___38);
+ do_fio(&c__1, "(single precision) underflow", (ftnlen)28);
+ do_fio(&c__1, (char *)&seps, (ftnlen)sizeof(real));
+ e_wsfe();
+ seps = slamch_("Overflow threshold");
+ s_wsfe(&io___39);
+ do_fio(&c__1, "(single precision) overflow ", (ftnlen)28);
+ do_fio(&c__1, (char *)&seps, (ftnlen)sizeof(real));
+ e_wsfe();
+ seps = slamch_("Epsilon");
+ s_wsfe(&io___40);
+ do_fio(&c__1, "(single precision) precision", (ftnlen)28);
+ do_fio(&c__1, (char *)&seps, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_wsle(&io___41);
+ e_wsle();
+
+ eps = dlamch_("Underflow threshold");
+ s_wsfe(&io___43);
+ do_fio(&c__1, "(double precision) underflow", (ftnlen)28);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ eps = dlamch_("Overflow threshold");
+ s_wsfe(&io___44);
+ do_fio(&c__1, "(double precision) overflow ", (ftnlen)28);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ eps = dlamch_("Epsilon");
+ s_wsfe(&io___45);
+ do_fio(&c__1, "(double precision) precision", (ftnlen)28);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_wsle(&io___46);
+ e_wsle();
+
+L80:
+
+/* Read a test path and the number of matrix types to use. */
+
+ ci__1.cierr = 0;
+ ci__1.ciend = 1;
+ ci__1.ciunit = 5;
+ ci__1.cifmt = "(A72)";
+ i__1 = s_rsfe(&ci__1);
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = do_fio(&c__1, aline, (ftnlen)72);
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L140;
+ }
+ s_copy(path, aline, (ftnlen)3, (ftnlen)3);
+ nmats = 30;
+ i__ = 3;
+L90:
+ ++i__;
+ if (i__ > 72) {
+ nmats = 30;
+ goto L130;
+ }
+ if (*(unsigned char *)&aline[i__ - 1] == ' ') {
+ goto L90;
+ }
+ nmats = 0;
+L100:
+ *(unsigned char *)c1 = *(unsigned char *)&aline[i__ - 1];
+ for (k = 1; k <= 10; ++k) {
+ if (*(unsigned char *)c1 == *(unsigned char *)&intstr[k - 1]) {
+ ic = k - 1;
+ goto L120;
+ }
+/* L110: */
+ }
+ goto L130;
+L120:
+ nmats = nmats * 10 + ic;
+ ++i__;
+ if (i__ > 72) {
+ goto L130;
+ }
+ goto L100;
+L130:
+ *(unsigned char *)c1 = *(unsigned char *)path;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ nrhs = nsval[0];
+
+/* Check first character for correct precision. */
+
+ if (! lsame_(c1, "Double precision")) {
+ s_wsfe(&io___55);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+ } else if (nmats <= 0) {
+
+/* Check for a positive number of tests requested. */
+
+ s_wsfe(&io___56);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ goto L140;
+
+ } else if (lsamen_(&c__2, c2, "GE")) {
+
+/* GE: general matrices */
+
+ ntypes = 11;
+ alareq_("DGE", &nmats, dotype, &ntypes, &c__5, &c__6);
+
+/* Test the error exits */
+
+ if (tsterr) {
+ derrab_(&c__6);
+ }
+
+ if (tstdrv) {
+ ddrvab_(dotype, &nm, mval, &nns, nsval, &thresh, &lda, a, &a[
+ 17424], b, &b[2112], work, rwork, swork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___65);
+ do_fio(&c__1, "DSGESV", (ftnlen)6);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "PO")) {
+
+/* PO: positive definite matrices */
+
+ ntypes = 9;
+ alareq_("DPO", &nmats, dotype, &ntypes, &c__5, &c__6);
+
+
+ if (tsterr) {
+ derrac_(&c__6);
+ }
+
+
+ if (tstdrv) {
+ ddrvac_(dotype, &nm, mval, &nns, nsval, &thresh, &lda, a, &a[
+ 17424], b, &b[2112], work, rwork, swork, &c__6);
+ } else {
+ s_wsfe(&io___66);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+ } else {
+
+ }
+
+/* Go back to get another input line. */
+
+ goto L80;
+
+/* Branch to this line when the last record is read. */
+
+L140:
+ cl__1.cerr = 0;
+ cl__1.cunit = 5;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ s2 = dsecnd_();
+ s_wsfe(&io___68);
+ e_wsfe();
+ s_wsfe(&io___69);
+ d__1 = s2 - s1;
+ do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+/* L9988: */
+
+/* End of DCHKAB */
+
+ return 0;
+} /* MAIN__ */
+
+/* Main program alias */ int dchkab_ () { MAIN__ (); return 0; }
diff --git a/TESTING/LIN/dchkeq.c b/TESTING/LIN/dchkeq.c
new file mode 100644
index 0000000..2fd2b02
--- /dev/null
+++ b/TESTING/LIN/dchkeq.c
@@ -0,0 +1,673 @@
+/* dchkeq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b7 = 10.;
+static integer c_n1 = -1;
+static integer c__5 = 5;
+static integer c__13 = 13;
+static integer c__1 = 1;
+
+/* Subroutine */ int dchkeq_(doublereal *thresh, integer *nout)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002All tests for \002,a3,\002 routines pa"
+ "ssed the threshold\002)";
+ static char fmt_9998[] = "(\002 DGEEQU failed test with value \002,d10"
+ ".3,\002 exceeding\002,\002 threshold \002,d10.3)";
+ static char fmt_9997[] = "(\002 DGBEQU failed test with value \002,d10"
+ ".3,\002 exceeding\002,\002 threshold \002,d10.3)";
+ static char fmt_9996[] = "(\002 DPOEQU failed test with value \002,d10"
+ ".3,\002 exceeding\002,\002 threshold \002,d10.3)";
+ static char fmt_9995[] = "(\002 DPPEQU failed test with value \002,d10"
+ ".3,\002 exceeding\002,\002 threshold \002,d10.3)";
+ static char fmt_9994[] = "(\002 DPBEQU failed test with value \002,d10"
+ ".3,\002 exceeding\002,\002 threshold \002,d10.3)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double pow_di(doublereal *, integer *);
+ integer pow_ii(integer *, integer *), s_wsle(cilist *), e_wsle(void),
+ s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublereal a[25] /* was [5][5] */, c__[5];
+ integer i__, j, m, n;
+ doublereal r__[5], ab[65] /* was [13][5] */, ap[15];
+ integer kl;
+ logical ok;
+ integer ku;
+ doublereal eps, pow[11];
+ integer info;
+ char path[3];
+ doublereal norm, rpow[11], ccond, rcond, rcmin, rcmax, ratio;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dgbequ_(integer *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *), dgeequ_(
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *)
+ , dpbequ_(char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ dpoequ_(integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *), dppequ_(char *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *
+);
+ doublereal reslts[5];
+
+ /* Fortran I/O blocks */
+ static cilist io___25 = { 0, 0, 0, 0, 0 };
+ static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKEQ tests DGEEQU, DGBEQU, DPOEQU, DPPEQU and DPBEQU */
+
+/* Arguments */
+/* ========= */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* Threshold for testing routines. Should be between 2 and 10. */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "EQ", (ftnlen)2, (ftnlen)2);
+
+ eps = dlamch_("P");
+ for (i__ = 1; i__ <= 5; ++i__) {
+ reslts[i__ - 1] = 0.;
+/* L10: */
+ }
+ for (i__ = 1; i__ <= 11; ++i__) {
+ i__1 = i__ - 1;
+ pow[i__ - 1] = pow_di(&c_b7, &i__1);
+ rpow[i__ - 1] = 1. / pow[i__ - 1];
+/* L20: */
+ }
+
+/* Test DGEEQU */
+
+ for (n = 0; n <= 5; ++n) {
+ for (m = 0; m <= 5; ++m) {
+
+ for (j = 1; j <= 5; ++j) {
+ for (i__ = 1; i__ <= 5; ++i__) {
+ if (i__ <= m && j <= n) {
+ i__1 = i__ + j;
+ a[i__ + j * 5 - 6] = pow[i__ + j] * pow_ii(&c_n1, &
+ i__1);
+ } else {
+ a[i__ + j * 5 - 6] = 0.;
+ }
+/* L30: */
+ }
+/* L40: */
+ }
+
+ dgeequ_(&m, &n, a, &c__5, r__, c__, &rcond, &ccond, &norm, &info);
+
+ if (info != 0) {
+ reslts[0] = 1.;
+ } else {
+ if (n != 0 && m != 0) {
+/* Computing MAX */
+ d__2 = reslts[0], d__3 = (d__1 = (rcond - rpow[m - 1]) /
+ rpow[m - 1], abs(d__1));
+ reslts[0] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = reslts[0], d__3 = (d__1 = (ccond - rpow[n - 1]) /
+ rpow[n - 1], abs(d__1));
+ reslts[0] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = reslts[0], d__3 = (d__1 = (norm - pow[n + m]) /
+ pow[n + m], abs(d__1));
+ reslts[0] = max(d__2,d__3);
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = reslts[0], d__3 = (d__1 = (r__[i__ - 1] - rpow[
+ i__ + n]) / rpow[i__ + n], abs(d__1));
+ reslts[0] = max(d__2,d__3);
+/* L50: */
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ d__2 = reslts[0], d__3 = (d__1 = (c__[j - 1] - pow[n
+ - j]) / pow[n - j], abs(d__1));
+ reslts[0] = max(d__2,d__3);
+/* L60: */
+ }
+ }
+ }
+
+/* L70: */
+ }
+/* L80: */
+ }
+
+/* Test with zero rows and columns */
+
+ for (j = 1; j <= 5; ++j) {
+ a[j * 5 - 2] = 0.;
+/* L90: */
+ }
+ dgeequ_(&c__5, &c__5, a, &c__5, r__, c__, &rcond, &ccond, &norm, &info);
+ if (info != 4) {
+ reslts[0] = 1.;
+ }
+
+ for (j = 1; j <= 5; ++j) {
+ a[j * 5 - 2] = 1.;
+/* L100: */
+ }
+ for (i__ = 1; i__ <= 5; ++i__) {
+ a[i__ + 14] = 0.;
+/* L110: */
+ }
+ dgeequ_(&c__5, &c__5, a, &c__5, r__, c__, &rcond, &ccond, &norm, &info);
+ if (info != 9) {
+ reslts[0] = 1.;
+ }
+ reslts[0] /= eps;
+
+/* Test DGBEQU */
+
+ for (n = 0; n <= 5; ++n) {
+ for (m = 0; m <= 5; ++m) {
+/* Computing MAX */
+ i__2 = m - 1;
+ i__1 = max(i__2,0);
+ for (kl = 0; kl <= i__1; ++kl) {
+/* Computing MAX */
+ i__3 = n - 1;
+ i__2 = max(i__3,0);
+ for (ku = 0; ku <= i__2; ++ku) {
+
+ for (j = 1; j <= 5; ++j) {
+ for (i__ = 1; i__ <= 13; ++i__) {
+ ab[i__ + j * 13 - 14] = 0.;
+/* L120: */
+ }
+/* L130: */
+ }
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = m;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+/* Computing MIN */
+ i__5 = m, i__6 = j + kl;
+/* Computing MAX */
+ i__7 = 1, i__8 = j - ku;
+ if (i__ <= min(i__5,i__6) && i__ >= max(i__7,i__8)
+ && j <= n) {
+ i__5 = i__ + j;
+ ab[ku + 1 + i__ - j + j * 13 - 14] = pow[i__
+ + j] * pow_ii(&c_n1, &i__5);
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+ dgbequ_(&m, &n, &kl, &ku, ab, &c__13, r__, c__, &rcond, &
+ ccond, &norm, &info);
+
+ if (info != 0) {
+ if (! (n + kl < m && info == n + kl + 1 || m + ku < n
+ && info == (m << 1) + ku + 1)) {
+ reslts[1] = 1.;
+ }
+ } else {
+ if (n != 0 && m != 0) {
+
+ rcmin = r__[0];
+ rcmax = r__[0];
+ i__3 = m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = r__[i__ - 1];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = r__[i__ - 1];
+ rcmax = max(d__1,d__2);
+/* L160: */
+ }
+ ratio = rcmin / rcmax;
+/* Computing MAX */
+ d__2 = reslts[1], d__3 = (d__1 = (rcond - ratio) /
+ ratio, abs(d__1));
+ reslts[1] = max(d__2,d__3);
+
+ rcmin = c__[0];
+ rcmax = c__[0];
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = c__[j - 1];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = c__[j - 1];
+ rcmax = max(d__1,d__2);
+/* L170: */
+ }
+ ratio = rcmin / rcmax;
+/* Computing MAX */
+ d__2 = reslts[1], d__3 = (d__1 = (ccond - ratio) /
+ ratio, abs(d__1));
+ reslts[1] = max(d__2,d__3);
+
+/* Computing MAX */
+ d__2 = reslts[1], d__3 = (d__1 = (norm - pow[n +
+ m]) / pow[n + m], abs(d__1));
+ reslts[1] = max(d__2,d__3);
+ i__3 = m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ rcmax = 0.;
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ if (i__ <= j + kl && i__ >= j - ku) {
+ ratio = (d__1 = r__[i__ - 1] * pow[
+ i__ + j] * c__[j - 1], abs(
+ d__1));
+ rcmax = max(rcmax,ratio);
+ }
+/* L180: */
+ }
+/* Computing MAX */
+ d__2 = reslts[1], d__3 = (d__1 = 1. - rcmax,
+ abs(d__1));
+ reslts[1] = max(d__2,d__3);
+/* L190: */
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ rcmax = 0.;
+ i__4 = m;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ if (i__ <= j + kl && i__ >= j - ku) {
+ ratio = (d__1 = r__[i__ - 1] * pow[
+ i__ + j] * c__[j - 1], abs(
+ d__1));
+ rcmax = max(rcmax,ratio);
+ }
+/* L200: */
+ }
+/* Computing MAX */
+ d__2 = reslts[1], d__3 = (d__1 = 1. - rcmax,
+ abs(d__1));
+ reslts[1] = max(d__2,d__3);
+/* L210: */
+ }
+ }
+ }
+
+/* L220: */
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+/* L250: */
+ }
+ reslts[1] /= eps;
+
+/* Test DPOEQU */
+
+ for (n = 0; n <= 5; ++n) {
+
+ for (i__ = 1; i__ <= 5; ++i__) {
+ for (j = 1; j <= 5; ++j) {
+ if (i__ <= n && j == i__) {
+ i__1 = i__ + j;
+ a[i__ + j * 5 - 6] = pow[i__ + j] * pow_ii(&c_n1, &i__1);
+ } else {
+ a[i__ + j * 5 - 6] = 0.;
+ }
+/* L260: */
+ }
+/* L270: */
+ }
+
+ dpoequ_(&n, a, &c__5, r__, &rcond, &norm, &info);
+
+ if (info != 0) {
+ reslts[2] = 1.;
+ } else {
+ if (n != 0) {
+/* Computing MAX */
+ d__2 = reslts[2], d__3 = (d__1 = (rcond - rpow[n - 1]) / rpow[
+ n - 1], abs(d__1));
+ reslts[2] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = reslts[2], d__3 = (d__1 = (norm - pow[n * 2]) / pow[n *
+ 2], abs(d__1));
+ reslts[2] = max(d__2,d__3);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = reslts[2], d__3 = (d__1 = (r__[i__ - 1] - rpow[i__]
+ ) / rpow[i__], abs(d__1));
+ reslts[2] = max(d__2,d__3);
+/* L280: */
+ }
+ }
+ }
+/* L290: */
+ }
+ a[18] = -1.;
+ dpoequ_(&c__5, a, &c__5, r__, &rcond, &norm, &info);
+ if (info != 4) {
+ reslts[2] = 1.;
+ }
+ reslts[2] /= eps;
+
+/* Test DPPEQU */
+
+ for (n = 0; n <= 5; ++n) {
+
+/* Upper triangular packed storage */
+
+ i__1 = n * (n + 1) / 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ap[i__ - 1] = 0.;
+/* L300: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ap[i__ * (i__ + 1) / 2 - 1] = pow[i__ * 2];
+/* L310: */
+ }
+
+ dppequ_("U", &n, ap, r__, &rcond, &norm, &info);
+
+ if (info != 0) {
+ reslts[3] = 1.;
+ } else {
+ if (n != 0) {
+/* Computing MAX */
+ d__2 = reslts[3], d__3 = (d__1 = (rcond - rpow[n - 1]) / rpow[
+ n - 1], abs(d__1));
+ reslts[3] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = reslts[3], d__3 = (d__1 = (norm - pow[n * 2]) / pow[n *
+ 2], abs(d__1));
+ reslts[3] = max(d__2,d__3);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = reslts[3], d__3 = (d__1 = (r__[i__ - 1] - rpow[i__]
+ ) / rpow[i__], abs(d__1));
+ reslts[3] = max(d__2,d__3);
+/* L320: */
+ }
+ }
+ }
+
+/* Lower triangular packed storage */
+
+ i__1 = n * (n + 1) / 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ap[i__ - 1] = 0.;
+/* L330: */
+ }
+ j = 1;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ap[j - 1] = pow[i__ * 2];
+ j += n - i__ + 1;
+/* L340: */
+ }
+
+ dppequ_("L", &n, ap, r__, &rcond, &norm, &info);
+
+ if (info != 0) {
+ reslts[3] = 1.;
+ } else {
+ if (n != 0) {
+/* Computing MAX */
+ d__2 = reslts[3], d__3 = (d__1 = (rcond - rpow[n - 1]) / rpow[
+ n - 1], abs(d__1));
+ reslts[3] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = reslts[3], d__3 = (d__1 = (norm - pow[n * 2]) / pow[n *
+ 2], abs(d__1));
+ reslts[3] = max(d__2,d__3);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = reslts[3], d__3 = (d__1 = (r__[i__ - 1] - rpow[i__]
+ ) / rpow[i__], abs(d__1));
+ reslts[3] = max(d__2,d__3);
+/* L350: */
+ }
+ }
+ }
+
+/* L360: */
+ }
+ i__ = 13;
+ ap[i__ - 1] = -1.;
+ dppequ_("L", &c__5, ap, r__, &rcond, &norm, &info);
+ if (info != 4) {
+ reslts[3] = 1.;
+ }
+ reslts[3] /= eps;
+
+/* Test DPBEQU */
+
+ for (n = 0; n <= 5; ++n) {
+/* Computing MAX */
+ i__2 = n - 1;
+ i__1 = max(i__2,0);
+ for (kl = 0; kl <= i__1; ++kl) {
+
+/* Test upper triangular storage */
+
+ for (j = 1; j <= 5; ++j) {
+ for (i__ = 1; i__ <= 13; ++i__) {
+ ab[i__ + j * 13 - 14] = 0.;
+/* L370: */
+ }
+/* L380: */
+ }
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ ab[kl + 1 + j * 13 - 14] = pow[j * 2];
+/* L390: */
+ }
+
+ dpbequ_("U", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
+
+ if (info != 0) {
+ reslts[4] = 1.;
+ } else {
+ if (n != 0) {
+/* Computing MAX */
+ d__2 = reslts[4], d__3 = (d__1 = (rcond - rpow[n - 1]) /
+ rpow[n - 1], abs(d__1));
+ reslts[4] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = reslts[4], d__3 = (d__1 = (norm - pow[n * 2]) /
+ pow[n * 2], abs(d__1));
+ reslts[4] = max(d__2,d__3);
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = reslts[4], d__3 = (d__1 = (r__[i__ - 1] - rpow[
+ i__]) / rpow[i__], abs(d__1));
+ reslts[4] = max(d__2,d__3);
+/* L400: */
+ }
+ }
+ }
+ if (n != 0) {
+/* Computing MAX */
+ i__2 = n - 1;
+ ab[kl + 1 + max(i__2,1) * 13 - 14] = -1.;
+ dpbequ_("U", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
+/* Computing MAX */
+ i__2 = n - 1;
+ if (info != max(i__2,1)) {
+ reslts[4] = 1.;
+ }
+ }
+
+/* Test lower triangular storage */
+
+ for (j = 1; j <= 5; ++j) {
+ for (i__ = 1; i__ <= 13; ++i__) {
+ ab[i__ + j * 13 - 14] = 0.;
+/* L410: */
+ }
+/* L420: */
+ }
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ ab[j * 13 - 13] = pow[j * 2];
+/* L430: */
+ }
+
+ dpbequ_("L", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
+
+ if (info != 0) {
+ reslts[4] = 1.;
+ } else {
+ if (n != 0) {
+/* Computing MAX */
+ d__2 = reslts[4], d__3 = (d__1 = (rcond - rpow[n - 1]) /
+ rpow[n - 1], abs(d__1));
+ reslts[4] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = reslts[4], d__3 = (d__1 = (norm - pow[n * 2]) /
+ pow[n * 2], abs(d__1));
+ reslts[4] = max(d__2,d__3);
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = reslts[4], d__3 = (d__1 = (r__[i__ - 1] - rpow[
+ i__]) / rpow[i__], abs(d__1));
+ reslts[4] = max(d__2,d__3);
+/* L440: */
+ }
+ }
+ }
+ if (n != 0) {
+/* Computing MAX */
+ i__2 = n - 1;
+ ab[max(i__2,1) * 13 - 13] = -1.;
+ dpbequ_("L", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
+/* Computing MAX */
+ i__2 = n - 1;
+ if (info != max(i__2,1)) {
+ reslts[4] = 1.;
+ }
+ }
+/* L450: */
+ }
+/* L460: */
+ }
+ reslts[4] /= eps;
+ ok = reslts[0] <= *thresh && reslts[1] <= *thresh && reslts[2] <= *thresh
+ && reslts[3] <= *thresh && reslts[4] <= *thresh;
+ io___25.ciunit = *nout;
+ s_wsle(&io___25);
+ e_wsle();
+ if (ok) {
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (reslts[0] > *thresh) {
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__1, (char *)&reslts[0], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ if (reslts[1] > *thresh) {
+ io___28.ciunit = *nout;
+ s_wsfe(&io___28);
+ do_fio(&c__1, (char *)&reslts[1], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ if (reslts[2] > *thresh) {
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ do_fio(&c__1, (char *)&reslts[2], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ if (reslts[3] > *thresh) {
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&reslts[3], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ if (reslts[4] > *thresh) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&reslts[4], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ }
+ return 0;
+
+/* End of DCHKEQ */
+
+} /* dchkeq_ */
diff --git a/TESTING/LIN/dchkgb.c b/TESTING/LIN/dchkgb.c
new file mode 100644
index 0000000..7aa78a7
--- /dev/null
+++ b/TESTING/LIN/dchkgb.c
@@ -0,0 +1,873 @@
+/* dchkgb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublereal c_b63 = 0.;
+static doublereal c_b64 = 1.;
+static integer c__7 = 7;
+
+/* Subroutine */ int dchkgb_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nns, integer *nsval, doublereal *thresh, logical *tsterr, doublereal *
+ a, integer *la, doublereal *afac, integer *lafac, doublereal *b,
+ doublereal *x, doublereal *xact, doublereal *work, doublereal *rwork,
+ integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 *** In DCHKGB, LA=\002,i5,\002 is too sm"
+ "all for M=\002,i5,\002, N=\002,i5,\002, KL=\002,i4,\002, KU=\002"
+ ",i4,/\002 ==> Increase LA to at least \002,i5)";
+ static char fmt_9998[] = "(\002 *** In DCHKGB, LAFAC=\002,i5,\002 is too"
+ " small for M=\002,i5,\002, N=\002,i5,\002, KL=\002,i4,\002, KU"
+ "=\002,i4,/\002 ==> Increase LAFAC to at least \002,i5)";
+ static char fmt_9997[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, KL="
+ "\002,i5,\002, KU=\002,i5,\002, NB =\002,i4,\002, type \002,i1"
+ ",\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9996[] = "(\002 TRANS='\002,a1,\002', N=\002,i5,\002, "
+ "KL=\002,i5,\002, KU=\002,i5,\002, NRHS=\002,i3,\002, type \002,i"
+ "1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9995[] = "(\002 NORM ='\002,a1,\002', N=\002,i5,\002, "
+ "KL=\002,i5,\002, KU=\002,i5,\002,\002,10x,\002 type \002,i1,\002"
+ ", test(\002,i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10,
+ i__11;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, m, n, i1, i2, nb, im, in, kl, ku, lda, ldb, inb, ikl,
+ nkl, iku, nku, ioff, mode, koff, imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char norm[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), dgbt01_(
+ integer *, integer *, integer *, integer *, doublereal *, integer
+ *, doublereal *, integer *, integer *, doublereal *, doublereal *)
+ , dgbt02_(char *, integer *, integer *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *), dgbt05_(char *,
+ integer *, integer *, integer *, integer *, doublereal *, integer
+ *, doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *),
+ dget04_(integer *, integer *, doublereal *, integer *, doublereal
+ *, integer *, doublereal *, doublereal *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ doublereal rcond;
+ integer nimat, klval[4];
+ doublereal anorm;
+ integer itran;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer kuval[4];
+ char trans[1];
+ integer izero, nerrs;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *);
+ integer ldafac;
+ extern doublereal dlangb_(char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *), dlange_(char *,
+ integer *, integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *), dgbcon_(char *, integer *, integer *, integer *,
+ doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *), dgbrfs_(char *,
+ integer *, integer *, integer *, integer *, doublereal *, integer
+ *, doublereal *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *);
+ doublereal rcondc;
+ extern /* Subroutine */ int derrge_(char *, integer *), dgbtrf_(
+ integer *, integer *, integer *, integer *, doublereal *, integer
+ *, integer *, integer *), dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *);
+ doublereal rcondi;
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ alasum_(char *, integer *, integer *, integer *, integer *);
+ doublereal cndnum, anormi, rcondo;
+ extern /* Subroutine */ int dgbtrs_(char *, integer *, integer *, integer
+ *, integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublereal *, integer *, doublereal
+ *, integer *);
+ logical trfcon;
+ doublereal anormo;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *);
+ doublereal result[7];
+
+ /* Fortran I/O blocks */
+ static cilist io___25 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___26 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKGB tests DGBTRF, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (LA) */
+
+/* LA (input) INTEGER */
+/* The length of the array A. LA >= (KLMAX+KUMAX+1)*NMAX */
+/* where KLMAX is the largest entry in the local array KLVAL, */
+/* KUMAX is the largest entry in the local array KUVAL and */
+/* NMAX is the largest entry in the input array NVAL. */
+
+/* AFAC (workspace) DOUBLE PRECISION array, dimension (LAFAC) */
+
+/* LAFAC (input) INTEGER */
+/* The length of the array AFAC. LAFAC >= (2*KLMAX+KUMAX+1)*NMAX */
+/* where KLMAX is the largest entry in the local array KLVAL, */
+/* KUMAX is the largest entry in the local array KUVAL and */
+/* NMAX is the largest entry in the input array NVAL. */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NSMAX,NMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --afac;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "GB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrge_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+/* Initialize the first value for the lower and upper bandwidths. */
+
+ klval[0] = 0;
+ kuval[0] = 0;
+
+/* Do for each value of M in MVAL */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Set values to use for the lower bandwidth. */
+
+ klval[1] = m + (m + 1) / 4;
+
+/* KLVAL( 2 ) = MAX( M-1, 0 ) */
+
+ klval[2] = (m * 3 - 1) / 4;
+ klval[3] = (m + 1) / 4;
+
+/* Do for each value of N in NVAL */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ *(unsigned char *)xtype = 'N';
+
+/* Set values to use for the upper bandwidth. */
+
+ kuval[1] = n + (n + 1) / 4;
+
+/* KUVAL( 2 ) = MAX( N-1, 0 ) */
+
+ kuval[2] = (n * 3 - 1) / 4;
+ kuval[3] = (n + 1) / 4;
+
+/* Set limits on the number of loop iterations. */
+
+/* Computing MIN */
+ i__3 = m + 1;
+ nkl = min(i__3,4);
+ if (n == 0) {
+ nkl = 2;
+ }
+/* Computing MIN */
+ i__3 = n + 1;
+ nku = min(i__3,4);
+ if (m == 0) {
+ nku = 2;
+ }
+ nimat = 8;
+ if (m <= 0 || n <= 0) {
+ nimat = 1;
+ }
+
+ i__3 = nkl;
+ for (ikl = 1; ikl <= i__3; ++ikl) {
+
+/* Do for KL = 0, (5*M+1)/4, (3M-1)/4, and (M+1)/4. This */
+/* order makes it easier to skip redundant values for small */
+/* values of M. */
+
+ kl = klval[ikl - 1];
+ i__4 = nku;
+ for (iku = 1; iku <= i__4; ++iku) {
+
+/* Do for KU = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This */
+/* order makes it easier to skip redundant values for */
+/* small values of N. */
+
+ ku = kuval[iku - 1];
+
+/* Check that A and AFAC are big enough to generate this */
+/* matrix. */
+
+ lda = kl + ku + 1;
+ ldafac = (kl << 1) + ku + 1;
+ if (lda * n > *la || ldafac * n > *lafac) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ if (n * (kl + ku + 1) > *la) {
+ io___25.ciunit = *nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, (char *)&(*la), (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)
+ );
+ i__5 = n * (kl + ku + 1);
+ do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ if (n * ((kl << 1) + ku + 1) > *lafac) {
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, (char *)&(*lafac), (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)
+ );
+ i__5 = n * ((kl << 1) + ku + 1);
+ do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ goto L130;
+ }
+
+ i__5 = nimat;
+ for (imat = 1; imat <= i__5; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+/* Skip types 2, 3, or 4 if the matrix size is too */
+/* small. */
+
+ zerot = imat >= 2 && imat <= 4;
+ if (zerot && n < imat - 1) {
+ goto L120;
+ }
+
+ if (! zerot || ! dotype[1]) {
+
+/* Set up parameters with DLATB4 and generate a */
+/* test matrix with DLATMS. */
+
+ dlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &
+ anorm, &mode, &cndnum, dist);
+
+/* Computing MAX */
+ i__6 = 1, i__7 = ku + 2 - n;
+ koff = max(i__6,i__7);
+ i__6 = koff - 1;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ a[i__] = 0.;
+/* L20: */
+ }
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (
+ ftnlen)6);
+ dlatms_(&m, &n, dist, iseed, type__, &rwork[1], &
+ mode, &cndnum, &anorm, &kl, &ku, "Z", &a[
+ koff], &lda, &work[1], &info);
+
+/* Check the error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, " ", &m,
+ &n, &kl, &ku, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ goto L120;
+ }
+ } else if (izero > 0) {
+
+/* Use the same matrix for types 3 and 4 as for */
+/* type 2 by copying back the zeroed out column. */
+
+ i__6 = i2 - i1 + 1;
+ dcopy_(&i__6, &b[1], &c__1, &a[ioff + i1], &c__1);
+ }
+
+/* For types 2, 3, and 4, zero one or more columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ izero = 0;
+ if (zerot) {
+ if (imat == 2) {
+ izero = 1;
+ } else if (imat == 3) {
+ izero = min(m,n);
+ } else {
+ izero = min(m,n) / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 4) {
+
+/* Store the column to be zeroed out in B. */
+
+/* Computing MAX */
+ i__6 = 1, i__7 = ku + 2 - izero;
+ i1 = max(i__6,i__7);
+/* Computing MIN */
+ i__6 = kl + ku + 1, i__7 = ku + 1 + (m -
+ izero);
+ i2 = min(i__6,i__7);
+ i__6 = i2 - i1 + 1;
+ dcopy_(&i__6, &a[ioff + i1], &c__1, &b[1], &
+ c__1);
+
+ i__6 = i2;
+ for (i__ = i1; i__ <= i__6; ++i__) {
+ a[ioff + i__] = 0.;
+/* L30: */
+ }
+ } else {
+ i__6 = n;
+ for (j = izero; j <= i__6; ++j) {
+/* Computing MAX */
+ i__7 = 1, i__8 = ku + 2 - j;
+/* Computing MIN */
+ i__10 = kl + ku + 1, i__11 = ku + 1 + (m
+ - j);
+ i__9 = min(i__10,i__11);
+ for (i__ = max(i__7,i__8); i__ <= i__9;
+ ++i__) {
+ a[ioff + i__] = 0.;
+/* L40: */
+ }
+ ioff += lda;
+/* L50: */
+ }
+ }
+ }
+
+/* These lines, if used in place of the calls in the */
+/* loop over INB, cause the code to bomb on a Sun */
+/* SPARCstation. */
+
+/* ANORMO = DLANGB( 'O', N, KL, KU, A, LDA, RWORK ) */
+/* ANORMI = DLANGB( 'I', N, KL, KU, A, LDA, RWORK ) */
+
+/* Do for each blocksize in NBVAL */
+
+ i__6 = *nnb;
+ for (inb = 1; inb <= i__6; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the LU factorization of the band matrix. */
+
+ if (m > 0 && n > 0) {
+ i__9 = kl + ku + 1;
+ dlacpy_("Full", &i__9, &n, &a[1], &lda, &afac[
+ kl + 1], &ldafac);
+ }
+ s_copy(srnamc_1.srnamt, "DGBTRF", (ftnlen)32, (
+ ftnlen)6);
+ dgbtrf_(&m, &n, &kl, &ku, &afac[1], &ldafac, &
+ iwork[1], &info);
+
+/* Check error code from DGBTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "DGBTRF", &info, &izero, " ", &
+ m, &n, &kl, &ku, &nb, &imat, &nfail, &
+ nerrs, nout);
+ }
+ trfcon = FALSE_;
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ dgbt01_(&m, &n, &kl, &ku, &a[1], &lda, &afac[1], &
+ ldafac, &iwork[1], &work[1], result);
+
+/* Print information about the tests so far that */
+/* did not pass the threshold. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+/* Skip the remaining tests if this is not the */
+/* first block size or if M .ne. N. */
+
+ if (inb > 1 || m != n) {
+ goto L110;
+ }
+
+ anormo = dlangb_("O", &n, &kl, &ku, &a[1], &lda, &
+ rwork[1]);
+ anormi = dlangb_("I", &n, &kl, &ku, &a[1], &lda, &
+ rwork[1]);
+
+ if (info == 0) {
+
+/* Form the inverse of A so we can get a good */
+/* estimate of CNDNUM = norm(A) * norm(inv(A)). */
+
+ ldb = max(1,n);
+ dlaset_("Full", &n, &n, &c_b63, &c_b64, &work[
+ 1], &ldb);
+ s_copy(srnamc_1.srnamt, "DGBTRS", (ftnlen)32,
+ (ftnlen)6);
+ dgbtrs_("No transpose", &n, &kl, &ku, &n, &
+ afac[1], &ldafac, &iwork[1], &work[1],
+ &ldb, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = dlange_("O", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormo <= 0. || ainvnm <= 0.) {
+ rcondo = 1.;
+ } else {
+ rcondo = 1. / anormo / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number of */
+/* A. */
+
+ ainvnm = dlange_("I", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormi <= 0. || ainvnm <= 0.) {
+ rcondi = 1.;
+ } else {
+ rcondi = 1. / anormi / ainvnm;
+ }
+ } else {
+
+/* Do only the condition estimate if INFO.NE.0. */
+
+ trfcon = TRUE_;
+ rcondo = 0.;
+ rcondi = 0.;
+ }
+
+/* Skip the solve tests if the matrix is singular. */
+
+ if (trfcon) {
+ goto L90;
+ }
+
+ i__9 = *nns;
+ for (irhs = 1; irhs <= i__9; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+
+ for (itran = 1; itran <= 3; ++itran) {
+ *(unsigned char *)trans = *(unsigned char
+ *)&transs[itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ *(unsigned char *)norm = 'O';
+ } else {
+ rcondc = rcondi;
+ *(unsigned char *)norm = 'I';
+ }
+
+/* + TEST 2: */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)
+ 32, (ftnlen)6);
+ dlarhs_(path, xtype, " ", trans, &n, &n, &
+ kl, &ku, &nrhs, &a[1], &lda, &
+ xact[1], &ldb, &b[1], &ldb, iseed,
+ &info);
+ *(unsigned char *)xtype = 'C';
+ dlacpy_("Full", &n, &nrhs, &b[1], &ldb, &
+ x[1], &ldb);
+
+ s_copy(srnamc_1.srnamt, "DGBTRS", (ftnlen)
+ 32, (ftnlen)6);
+ dgbtrs_(trans, &n, &kl, &ku, &nrhs, &afac[
+ 1], &ldafac, &iwork[1], &x[1], &
+ ldb, &info);
+
+/* Check error code from DGBTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "DGBTRS", &info, &c__0,
+ trans, &n, &n, &kl, &ku, &
+ c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ dlacpy_("Full", &n, &nrhs, &b[1], &ldb, &
+ work[1], &ldb);
+ dgbt02_(trans, &m, &n, &kl, &ku, &nrhs, &
+ a[1], &lda, &x[1], &ldb, &work[1],
+ &ldb, &result[1]);
+
+/* + TEST 3: */
+/* Check solution from generated exact */
+/* solution. */
+
+ dget04_(&n, &nrhs, &x[1], &ldb, &xact[1],
+ &ldb, &rcondc, &result[2]);
+
+/* + TESTS 4, 5, 6: */
+/* Use iterative refinement to improve the */
+/* solution. */
+
+ s_copy(srnamc_1.srnamt, "DGBRFS", (ftnlen)
+ 32, (ftnlen)6);
+ dgbrfs_(trans, &n, &kl, &ku, &nrhs, &a[1],
+ &lda, &afac[1], &ldafac, &iwork[
+ 1], &b[1], &ldb, &x[1], &ldb, &
+ rwork[1], &rwork[nrhs + 1], &work[
+ 1], &iwork[n + 1], &info);
+
+/* Check error code from DGBRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "DGBRFS", &info, &c__0,
+ trans, &n, &n, &kl, &ku, &
+ nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ dget04_(&n, &nrhs, &x[1], &ldb, &xact[1],
+ &ldb, &rcondc, &result[3]);
+ dgbt05_(trans, &n, &kl, &ku, &nrhs, &a[1],
+ &lda, &b[1], &ldb, &x[1], &ldb, &
+ xact[1], &ldb, &rwork[1], &rwork[
+ nrhs + 1], &result[4]);
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___59.ciunit = *nout;
+ s_wsfe(&io___59);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrhs, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k -
+ 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += 5;
+/* L70: */
+ }
+/* L80: */
+ }
+
+/* + TEST 7: */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+L90:
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ anorm = anormo;
+ rcondc = rcondo;
+ *(unsigned char *)norm = 'O';
+ } else {
+ anorm = anormi;
+ rcondc = rcondi;
+ *(unsigned char *)norm = 'I';
+ }
+ s_copy(srnamc_1.srnamt, "DGBCON", (ftnlen)32,
+ (ftnlen)6);
+ dgbcon_(norm, &n, &kl, &ku, &afac[1], &ldafac,
+ &iwork[1], &anorm, &rcond, &work[1],
+ &iwork[n + 1], &info);
+
+/* Check error code from DGBCON. */
+
+ if (info != 0) {
+ alaerh_(path, "DGBCON", &info, &c__0,
+ norm, &n, &n, &kl, &ku, &c_n1, &
+ imat, &nfail, &nerrs, nout);
+ }
+
+ result[6] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___61.ciunit = *nout;
+ s_wsfe(&io___61);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L100: */
+ }
+
+L110:
+ ;
+ }
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+
+ return 0;
+
+/* End of DCHKGB */
+
+} /* dchkgb_ */
diff --git a/TESTING/LIN/dchkge.c b/TESTING/LIN/dchkge.c
new file mode 100644
index 0000000..df5f1b6
--- /dev/null
+++ b/TESTING/LIN/dchkge.c
@@ -0,0 +1,685 @@
+/* dchkge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublereal c_b23 = 0.;
+static logical c_true = TRUE_;
+static integer c__8 = 8;
+
+/* Subroutine */ int dchkge_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nns, integer *nsval, doublereal *thresh, logical *tsterr, integer *
+ nmax, doublereal *a, doublereal *afac, doublereal *ainv, doublereal *
+ b, doublereal *x, doublereal *xact, doublereal *work, doublereal *
+ rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M = \002,i5,\002, N =\002,i5,\002, NB "
+ "=\002,i4,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
+ ;
+ static char fmt_9998[] = "(\002 TRANS='\002,a1,\002', N =\002,i5,\002, N"
+ "RHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g1"
+ "2.5)";
+ static char fmt_9997[] = "(\002 NORM ='\002,a1,\002', N =\002,i5,\002"
+ ",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
+ ;
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, im, in, kl, ku, nt, lda, inb, ioff, mode, imat,
+ info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char norm[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), dget01_(
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *, doublereal *, doublereal *), dget02_(char *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *), dget03_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *), dget04_(integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ extern /* Subroutine */ int dget07_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, logical *,
+ doublereal *, doublereal *);
+ doublereal rcond;
+ integer nimat;
+ doublereal anorm;
+ integer itran;
+ char trans[1];
+ integer izero, nerrs;
+ doublereal dummy;
+ integer lwork;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *);
+ extern doublereal dlange_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *), dgecon_(char *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *);
+ doublereal rcondc;
+ extern /* Subroutine */ int derrge_(char *, integer *), dgerfs_(
+ char *, integer *, integer *, doublereal *, integer *, doublereal
+ *, integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *), dgetrf_(integer *, integer *, doublereal *,
+ integer *, integer *, integer *), dlacpy_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *), dlarhs_(char *, char *, char *, char *, integer *,
+ integer *, integer *, integer *, integer *, doublereal *, integer
+ *, doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *);
+ doublereal rcondi;
+ extern /* Subroutine */ int dgetri_(integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, integer *), dlaset_(char *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *), alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum, anormi, rcondo;
+ extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublereal *, integer *, doublereal
+ *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int dgetrs_(char *, integer *, integer *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ integer *);
+ logical trfcon;
+ doublereal anormo;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *);
+ doublereal result[8];
+
+ /* Fortran I/O blocks */
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKGE tests DGETRF, -TRI, -TRS, -RFS, and -CON. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(2*NMAX,2*NSMAX+NWORK)) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "GE", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ xlaenv_(&c__1, &c__1);
+ if (*tsterr) {
+ derrge_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+/* Do for each value of M in MVAL */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+ lda = max(1,m);
+
+/* Do for each value of N in NVAL */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ *(unsigned char *)xtype = 'N';
+ nimat = 11;
+ if (m <= 0 || n <= 0) {
+ nimat = 1;
+ }
+
+ i__3 = nimat;
+ for (imat = 1; imat <= i__3; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L100;
+ }
+
+/* Skip types 5, 6, or 7 if the matrix size is too small. */
+
+ zerot = imat >= 5 && imat <= 7;
+ if (zerot && n < imat - 4) {
+ goto L100;
+ }
+
+/* Set up parameters with DLATB4 and generate a test matrix */
+/* with DLATMS. */
+
+ dlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, " ", &m, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L100;
+ }
+
+/* For types 5-7, zero one or more columns of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 5) {
+ izero = 1;
+ } else if (imat == 6) {
+ izero = min(m,n);
+ } else {
+ izero = min(m,n) / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 7) {
+ i__4 = m;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ a[ioff + i__] = 0.;
+/* L20: */
+ }
+ } else {
+ i__4 = n - izero + 1;
+ dlaset_("Full", &m, &i__4, &c_b23, &c_b23, &a[ioff +
+ 1], &lda);
+ }
+ } else {
+ izero = 0;
+ }
+
+/* These lines, if used in place of the calls in the DO 60 */
+/* loop, cause the code to bomb on a Sun SPARCstation. */
+
+/* ANORMO = DLANGE( 'O', M, N, A, LDA, RWORK ) */
+/* ANORMI = DLANGE( 'I', M, N, A, LDA, RWORK ) */
+
+/* Do for each blocksize in NBVAL */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the LU factorization of the matrix. */
+
+ dlacpy_("Full", &m, &n, &a[1], &lda, &afac[1], &lda);
+ s_copy(srnamc_1.srnamt, "DGETRF", (ftnlen)32, (ftnlen)6);
+ dgetrf_(&m, &n, &afac[1], &lda, &iwork[1], &info);
+
+/* Check error code from DGETRF. */
+
+ if (info != izero) {
+ alaerh_(path, "DGETRF", &info, &izero, " ", &m, &n, &
+ c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
+ }
+ trfcon = FALSE_;
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ dlacpy_("Full", &m, &n, &afac[1], &lda, &ainv[1], &lda);
+ dget01_(&m, &n, &a[1], &lda, &ainv[1], &lda, &iwork[1], &
+ rwork[1], result);
+ nt = 1;
+
+/* + TEST 2 */
+/* Form the inverse if the factorization was successful */
+/* and compute the residual. */
+
+ if (m == n && info == 0) {
+ dlacpy_("Full", &n, &n, &afac[1], &lda, &ainv[1], &
+ lda);
+ s_copy(srnamc_1.srnamt, "DGETRI", (ftnlen)32, (ftnlen)
+ 6);
+ nrhs = nsval[1];
+ lwork = *nmax * max(3,nrhs);
+ dgetri_(&n, &ainv[1], &lda, &iwork[1], &work[1], &
+ lwork, &info);
+
+/* Check error code from DGETRI. */
+
+ if (info != 0) {
+ alaerh_(path, "DGETRI", &info, &c__0, " ", &n, &n,
+ &c_n1, &c_n1, &nb, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+/* Compute the residual for the matrix times its */
+/* inverse. Also compute the 1-norm condition number */
+/* of A. */
+
+ dget03_(&n, &a[1], &lda, &ainv[1], &lda, &work[1], &
+ lda, &rwork[1], &rcondo, &result[1]);
+ anormo = dlange_("O", &m, &n, &a[1], &lda, &rwork[1]);
+
+/* Compute the infinity-norm condition number of A. */
+
+ anormi = dlange_("I", &m, &n, &a[1], &lda, &rwork[1]);
+ ainvnm = dlange_("I", &n, &n, &ainv[1], &lda, &rwork[
+ 1]);
+ if (anormi <= 0. || ainvnm <= 0.) {
+ rcondi = 1.;
+ } else {
+ rcondi = 1. / anormi / ainvnm;
+ }
+ nt = 2;
+ } else {
+
+/* Do only the condition estimate if INFO > 0. */
+
+ trfcon = TRUE_;
+ anormo = dlange_("O", &m, &n, &a[1], &lda, &rwork[1]);
+ anormi = dlange_("I", &m, &n, &a[1], &lda, &rwork[1]);
+ rcondo = 0.;
+ rcondi = 0.;
+ }
+
+/* Print information about the tests so far that did not */
+/* pass the threshold. */
+
+ i__5 = nt;
+ for (k = 1; k <= i__5; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L30: */
+ }
+ nrun += nt;
+
+/* Skip the remaining tests if this is not the first */
+/* block size or if M .ne. N. Skip the solve tests if */
+/* the matrix is singular. */
+
+ if (inb > 1 || m != n) {
+ goto L90;
+ }
+ if (trfcon) {
+ goto L70;
+ }
+
+ i__5 = *nns;
+ for (irhs = 1; irhs <= i__5; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+
+ for (itran = 1; itran <= 3; ++itran) {
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (
+ ftnlen)6);
+ dlarhs_(path, xtype, " ", trans, &n, &n, &kl, &ku,
+ &nrhs, &a[1], &lda, &xact[1], &lda, &b[1]
+, &lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+
+ dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
+ lda);
+ s_copy(srnamc_1.srnamt, "DGETRS", (ftnlen)32, (
+ ftnlen)6);
+ dgetrs_(trans, &n, &nrhs, &afac[1], &lda, &iwork[
+ 1], &x[1], &lda, &info);
+
+/* Check error code from DGETRS. */
+
+ if (info != 0) {
+ alaerh_(path, "DGETRS", &info, &c__0, trans, &
+ n, &n, &c_n1, &c_n1, &nrhs, &imat, &
+ nfail, &nerrs, nout);
+ }
+
+ dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1],
+ &lda);
+ dget02_(trans, &n, &n, &nrhs, &a[1], &lda, &x[1],
+ &lda, &work[1], &lda, &rwork[1], &result[
+ 2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the */
+/* solution. */
+
+ s_copy(srnamc_1.srnamt, "DGERFS", (ftnlen)32, (
+ ftnlen)6);
+ dgerfs_(trans, &n, &nrhs, &a[1], &lda, &afac[1], &
+ lda, &iwork[1], &b[1], &lda, &x[1], &lda,
+ &rwork[1], &rwork[nrhs + 1], &work[1], &
+ iwork[n + 1], &info);
+
+/* Check error code from DGERFS. */
+
+ if (info != 0) {
+ alaerh_(path, "DGERFS", &info, &c__0, trans, &
+ n, &n, &c_n1, &c_n1, &nrhs, &imat, &
+ nfail, &nerrs, nout);
+ }
+
+ dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[4]);
+ dget07_(trans, &n, &nrhs, &a[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &c_true, &rwork[nrhs + 1], &result[5]);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___46.ciunit = *nout;
+ s_wsfe(&io___46);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L40: */
+ }
+ nrun += 5;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+L70:
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ anorm = anormo;
+ rcondc = rcondo;
+ *(unsigned char *)norm = 'O';
+ } else {
+ anorm = anormi;
+ rcondc = rcondi;
+ *(unsigned char *)norm = 'I';
+ }
+ s_copy(srnamc_1.srnamt, "DGECON", (ftnlen)32, (ftnlen)
+ 6);
+ dgecon_(norm, &n, &afac[1], &lda, &anorm, &rcond, &
+ work[1], &iwork[n + 1], &info);
+
+/* Check error code from DGECON. */
+
+ if (info != 0) {
+ alaerh_(path, "DGECON", &info, &c__0, norm, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+/* This line is needed on a Sun SPARCstation. */
+
+ dummy = rcond;
+
+ result[7] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___50.ciunit = *nout;
+ s_wsfe(&io___50);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L80: */
+ }
+L90:
+ ;
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DCHKGE */
+
+} /* dchkge_ */
diff --git a/TESTING/LIN/dchkgt.c b/TESTING/LIN/dchkgt.c
new file mode 100644
index 0000000..0ed54bd
--- /dev/null
+++ b/TESTING/LIN/dchkgt.c
@@ -0,0 +1,655 @@
+/* dchkgt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__7 = 7;
+static doublereal c_b63 = 1.;
+static doublereal c_b64 = 0.;
+
+/* Subroutine */ int dchkgt_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, doublereal *thresh, logical *tsterr,
+ doublereal *a, doublereal *af, doublereal *b, doublereal *x,
+ doublereal *xact, doublereal *work, doublereal *rwork, integer *iwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 0,0,0,1 };
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(12x,\002N =\002,i5,\002,\002,10x,\002 type"
+ " \002,i2,\002, test(\002,i2,\002) = \002,g12.5)";
+ static char fmt_9997[] = "(\002 NORM ='\002,a1,\002', N =\002,i5,\002"
+ ",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) = \002,g12."
+ "5)";
+ static char fmt_9998[] = "(\002 TRANS='\002,a1,\002', N =\002,i5,\002, N"
+ "RHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) = \002,g"
+ "12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, m, n;
+ doublereal z__[3];
+ integer in, kl, ku, ix, lda;
+ doublereal cond;
+ integer mode, koff, imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char norm[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), dscal_(
+ integer *, doublereal *, doublereal *, integer *), dget04_(
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ extern /* Subroutine */ int dgtt01_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *), dgtt02_(char *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *
+, integer *, doublereal *, doublereal *);
+ doublereal rcond;
+ extern /* Subroutine */ int dgtt05_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *);
+ integer nimat;
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal anorm;
+ integer itran;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ char trans[1];
+ integer izero, nerrs;
+ logical zerot;
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *);
+ doublereal rcondc;
+ extern doublereal dlangt_(char *, integer *, doublereal *, doublereal *,
+ doublereal *);
+ extern /* Subroutine */ int derrge_(char *, integer *), dlagtm_(
+ char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *), dlacpy_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *);
+ doublereal rcondi;
+ extern /* Subroutine */ int dgtcon_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *),
+ alasum_(char *, integer *, integer *, integer *, integer *);
+ doublereal rcondo;
+ extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublereal *, integer *, doublereal
+ *, integer *), dlarnv_(integer *, integer
+ *, integer *, doublereal *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int dgtrfs_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *), dgttrf_(integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *);
+ logical trfcon;
+ extern /* Subroutine */ int dgttrs_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *);
+ doublereal result[7];
+
+ /* Fortran I/O blocks */
+ static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKGT tests DGTTRF, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*4) */
+
+/* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*4) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --af;
+ --a;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "GT", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrge_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+/* Computing MAX */
+ i__2 = n - 1;
+ m = max(i__2,0);
+ lda = max(1,n);
+ nimat = 12;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L100;
+ }
+
+/* Set up parameters with DLATB4. */
+
+ dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cond, dist);
+
+ zerot = imat >= 8 && imat <= 10;
+ if (imat <= 6) {
+
+/* Types 1-6: generate matrices of known condition number. */
+
+/* Computing MAX */
+ i__3 = 2 - ku, i__4 = 3 - max(1,n);
+ koff = max(i__3,i__4);
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
+ &anorm, &kl, &ku, "Z", &af[koff], &c__3, &work[1], &
+ info);
+
+/* Check the error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, " ", &n, &n, &kl, &
+ ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L100;
+ }
+ izero = 0;
+
+ if (n > 1) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
+ i__3 = n - 1;
+ dcopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
+ }
+ dcopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
+ } else {
+
+/* Types 7-12: generate tridiagonal matrices with */
+/* unknown condition numbers. */
+
+ if (! zerot || ! dotype[7]) {
+
+/* Generate a matrix with elements from [-1,1]. */
+
+ i__3 = n + (m << 1);
+ dlarnv_(&c__2, iseed, &i__3, &a[1]);
+ if (anorm != 1.) {
+ i__3 = n + (m << 1);
+ dscal_(&i__3, &anorm, &a[1], &c__1);
+ }
+ } else if (izero > 0) {
+
+/* Reuse the last matrix by copying back the zeroed out */
+/* elements. */
+
+ if (izero == 1) {
+ a[n] = z__[1];
+ if (n > 1) {
+ a[1] = z__[2];
+ }
+ } else if (izero == n) {
+ a[n * 3 - 2] = z__[0];
+ a[(n << 1) - 1] = z__[1];
+ } else {
+ a[(n << 1) - 2 + izero] = z__[0];
+ a[n - 1 + izero] = z__[1];
+ a[izero] = z__[2];
+ }
+ }
+
+/* If IMAT > 7, set one column of the matrix to 0. */
+
+ if (! zerot) {
+ izero = 0;
+ } else if (imat == 8) {
+ izero = 1;
+ z__[1] = a[n];
+ a[n] = 0.;
+ if (n > 1) {
+ z__[2] = a[1];
+ a[1] = 0.;
+ }
+ } else if (imat == 9) {
+ izero = n;
+ z__[0] = a[n * 3 - 2];
+ z__[1] = a[(n << 1) - 1];
+ a[n * 3 - 2] = 0.;
+ a[(n << 1) - 1] = 0.;
+ } else {
+ izero = (n + 1) / 2;
+ i__3 = n - 1;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[(n << 1) - 2 + i__] = 0.;
+ a[n - 1 + i__] = 0.;
+ a[i__] = 0.;
+/* L20: */
+ }
+ a[n * 3 - 2] = 0.;
+ a[(n << 1) - 1] = 0.;
+ }
+ }
+
+/* + TEST 1 */
+/* Factor A as L*U and compute the ratio */
+/* norm(L*U - A) / (n * norm(A) * EPS ) */
+
+ i__3 = n + (m << 1);
+ dcopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
+ s_copy(srnamc_1.srnamt, "DGTTRF", (ftnlen)32, (ftnlen)6);
+ dgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (m << 1)
+ + 1], &iwork[1], &info);
+
+/* Check error code from DGTTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "DGTTRF", &info, &izero, " ", &n, &n, &c__1, &
+ c__1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+ trfcon = info != 0;
+
+ dgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &af[m + 1], &
+ af[n + m + 1], &af[n + (m << 1) + 1], &iwork[1], &work[1],
+ &lda, &rwork[1], result);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+ for (itran = 1; itran <= 2; ++itran) {
+ *(unsigned char *)trans = *(unsigned char *)&transs[itran - 1]
+ ;
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ } else {
+ *(unsigned char *)norm = 'I';
+ }
+ anorm = dlangt_(norm, &n, &a[1], &a[m + 1], &a[n + m + 1]);
+
+ if (! trfcon) {
+
+/* Use DGTTRS to solve for one column at a time of inv(A) */
+/* or inv(A^T), computing the maximum column sum as we */
+/* go. */
+
+ ainvnm = 0.;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ x[j] = 0.;
+/* L30: */
+ }
+ x[i__] = 1.;
+ dgttrs_(trans, &n, &c__1, &af[1], &af[m + 1], &af[n +
+ m + 1], &af[n + (m << 1) + 1], &iwork[1], &x[
+ 1], &lda, &info);
+/* Computing MAX */
+ d__1 = ainvnm, d__2 = dasum_(&n, &x[1], &c__1);
+ ainvnm = max(d__1,d__2);
+/* L40: */
+ }
+
+/* Compute RCONDC = 1 / (norm(A) * norm(inv(A)) */
+
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondc = 1.;
+ } else {
+ rcondc = 1. / anorm / ainvnm;
+ }
+ if (itran == 1) {
+ rcondo = rcondc;
+ } else {
+ rcondi = rcondc;
+ }
+ } else {
+ rcondc = 0.;
+ }
+
+/* + TEST 7 */
+/* Estimate the reciprocal of the condition number of the */
+/* matrix. */
+
+ s_copy(srnamc_1.srnamt, "DGTCON", (ftnlen)32, (ftnlen)6);
+ dgtcon_(norm, &n, &af[1], &af[m + 1], &af[n + m + 1], &af[n +
+ (m << 1) + 1], &iwork[1], &anorm, &rcond, &work[1], &
+ iwork[n + 1], &info);
+
+/* Check error code from DGTCON. */
+
+ if (info != 0) {
+ alaerh_(path, "DGTCON", &info, &c__0, norm, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+ result[6] = dget06_(&rcond, &rcondc);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L50: */
+ }
+
+/* Skip the remaining tests if the matrix is singular. */
+
+ if (trfcon) {
+ goto L100;
+ }
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* Generate NRHS random solution vectors. */
+
+ ix = 1;
+ i__4 = nrhs;
+ for (j = 1; j <= i__4; ++j) {
+ dlarnv_(&c__2, iseed, &n, &xact[ix]);
+ ix += lda;
+/* L60: */
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+ *(unsigned char *)trans = *(unsigned char *)&transs[itran
+ - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Set the right hand side. */
+
+ dlagtm_(trans, &n, &nrhs, &c_b63, &a[1], &a[m + 1], &a[n
+ + m + 1], &xact[1], &lda, &c_b64, &b[1], &lda);
+
+/* + TEST 2 */
+/* Solve op(A) * X = B and compute the residual. */
+
+ dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+ s_copy(srnamc_1.srnamt, "DGTTRS", (ftnlen)32, (ftnlen)6);
+ dgttrs_(trans, &n, &nrhs, &af[1], &af[m + 1], &af[n + m +
+ 1], &af[n + (m << 1) + 1], &iwork[1], &x[1], &lda,
+ &info);
+
+/* Check error code from DGTTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "DGTTRS", &info, &c__0, trans, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
+ dgtt02_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
+ &x[1], &lda, &work[1], &lda, &rwork[1], &result[
+ 1]);
+
+/* + TEST 3 */
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[2]);
+
+/* + TESTS 4, 5, and 6 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "DGTRFS", (ftnlen)32, (ftnlen)6);
+ dgtrfs_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
+ &af[1], &af[m + 1], &af[n + m + 1], &af[n + (m <<
+ 1) + 1], &iwork[1], &b[1], &lda, &x[1], &lda, &
+ rwork[1], &rwork[nrhs + 1], &work[1], &iwork[n +
+ 1], &info);
+
+/* Check error code from DGTRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "DGTRFS", &info, &c__0, trans, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[3]);
+ dgtt05_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
+ &b[1], &lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &rwork[nrhs + 1], &result[4]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L70: */
+ }
+ nrun += 5;
+/* L80: */
+ }
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+/* L110: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DCHKGT */
+
+} /* dchkgt_ */
diff --git a/TESTING/LIN/dchklq.c b/TESTING/LIN/dchklq.c
new file mode 100644
index 0000000..54efe56
--- /dev/null
+++ b/TESTING/LIN/dchklq.c
@@ -0,0 +1,473 @@
+/* dchklq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int dchklq_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nxval, integer *nrhs, doublereal *thresh, logical *tsterr, integer *
+ nmax, doublereal *a, doublereal *af, doublereal *aq, doublereal *al,
+ doublereal *ac, doublereal *b, doublereal *x, doublereal *xact,
+ doublereal *tau, doublereal *work, doublereal *rwork, integer *iwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
+ "5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
+ "t(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, ik, im, in, kl, nk, ku, nt, nx, lda, inb, mode,
+ imat, info;
+ char path[3];
+ integer kval[4];
+ char dist[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), dget02_(
+ char *, integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int dlqt01_(integer *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *), dlqt02_(
+ integer *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, doublereal *), dlqt03_(integer *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *);
+ doublereal anorm;
+ integer minmn, nerrs, lwork;
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *);
+ extern logical dgennd_(integer *, integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *), dgelqs_(integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *),
+ alasum_(char *, integer *, integer *, integer *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublereal *, integer *, doublereal
+ *, integer *), derrlq_(char *, integer *), xlaenv_(integer *, integer *);
+ doublereal result[8];
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKLQ tests DGELQF, DORGLQ and DORMLQ. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AQ (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AL (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* TAU (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --tau;
+ --xact;
+ --x;
+ --b;
+ --ac;
+ --al;
+ --aq;
+ --af;
+ --a;
+ --nxval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "LQ", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrlq_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+ lda = *nmax;
+ lwork = *nmax * max(*nmax,*nrhs);
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Do for each value of N in NVAL. */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ minmn = min(m,n);
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L50;
+ }
+
+/* Set up parameters with DLATB4 and generate a test matrix */
+/* with DLATMS. */
+
+ dlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, " ", &m, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L50;
+ }
+
+/* Set some values for K: the first value must be MINMN, */
+/* corresponding to the call of DLQT01; other values are */
+/* used in the calls of DLQT02, and must not exceed MINMN. */
+
+ kval[0] = minmn;
+ kval[1] = 0;
+ kval[2] = 1;
+ kval[3] = minmn / 2;
+ if (minmn == 0) {
+ nk = 1;
+ } else if (minmn == 1) {
+ nk = 2;
+ } else if (minmn <= 3) {
+ nk = 3;
+ } else {
+ nk = 4;
+ }
+
+/* Do for each value of K in KVAL */
+
+ i__3 = nk;
+ for (ik = 1; ik <= i__3; ++ik) {
+ k = kval[ik - 1];
+
+/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ nx = nxval[inb];
+ xlaenv_(&c__3, &nx);
+ for (i__ = 1; i__ <= 8; ++i__) {
+ result[i__ - 1] = 0.;
+ }
+ nt = 2;
+ if (ik == 1) {
+
+/* Test DGELQF */
+
+ dlqt01_(&m, &n, &a[1], &af[1], &aq[1], &al[1], &
+ lda, &tau[1], &work[1], &lwork, &rwork[1],
+ result);
+ if (! dgennd_(&m, &n, &af[1], &lda)) {
+ result[7] = *thresh * 2;
+ }
+ ++nt;
+ } else if (m <= n) {
+
+/* Test DORGLQ, using factorization */
+/* returned by DLQT01 */
+
+ dlqt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &al[1],
+ &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], result);
+ } else {
+ result[0] = 0.;
+ result[1] = 0.;
+ }
+ if (m >= k) {
+
+/* Test DORMLQ, using factorization returned */
+/* by DLQT01 */
+
+ dlqt03_(&m, &n, &k, &af[1], &ac[1], &al[1], &aq[1]
+, &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], &result[2]);
+ nt += 4;
+
+/* If M>=N and K=N, call DGELQS to solve a system */
+/* with NRHS right hand sides and compute the */
+/* residual. */
+
+ if (k == m && inb == 1) {
+
+/* Generate a solution and set the right */
+/* hand side. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32,
+ (ftnlen)6);
+ dlarhs_(path, "New", "Full", "No transpose", &
+ m, &n, &c__0, &c__0, nrhs, &a[1], &
+ lda, &xact[1], &lda, &b[1], &lda,
+ iseed, &info);
+
+ dlacpy_("Full", &m, nrhs, &b[1], &lda, &x[1],
+ &lda);
+ s_copy(srnamc_1.srnamt, "DGELQS", (ftnlen)32,
+ (ftnlen)6);
+ dgelqs_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
+ x[1], &lda, &work[1], &lwork, &info);
+
+/* Check error code from DGELQS. */
+
+ if (info != 0) {
+ alaerh_(path, "DGELQS", &info, &c__0,
+ " ", &m, &n, nrhs, &c_n1, &nb, &
+ imat, &nfail, &nerrs, nout);
+ }
+
+ dget02_("No transpose", &m, &n, nrhs, &a[1], &
+ lda, &x[1], &lda, &b[1], &lda, &rwork[
+ 1], &result[6]);
+ ++nt;
+ } else {
+ result[6] = 0.;
+ }
+ } else {
+ result[2] = 0.;
+ result[3] = 0.;
+ result[4] = 0.;
+ result[5] = 0.;
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__5 = nt;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+/* L30: */
+ }
+/* L40: */
+ }
+L50:
+ ;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DCHKLQ */
+
+} /* dchklq_ */
diff --git a/TESTING/LIN/dchkpb.c b/TESTING/LIN/dchkpb.c
new file mode 100644
index 0000000..9d620c8
--- /dev/null
+++ b/TESTING/LIN/dchkpb.c
@@ -0,0 +1,710 @@
+/* dchkpb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static doublereal c_b50 = 0.;
+static doublereal c_b51 = 1.;
+static integer c__7 = 7;
+
+/* Subroutine */ int dchkpb_(logical *dotype, integer *nn, integer *nval,
+ integer *nnb, integer *nbval, integer *nns, integer *nsval,
+ doublereal *thresh, logical *tsterr, integer *nmax, doublereal *a,
+ doublereal *afac, doublereal *ainv, doublereal *b, doublereal *x,
+ doublereal *xact, doublereal *work, doublereal *rwork, integer *iwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
+ "=\002,i5,\002, NB=\002,i4,\002, type \002,i2,\002, test \002,i2"
+ ",\002, ratio= \002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
+ "=\002,i5,\002, NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i"
+ "2,\002) = \002,g12.5)";
+ static char fmt_9997[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
+ "=\002,i5,\002,\002,10x,\002 type \002,i2,\002, test(\002,i2,\002"
+ ") = \002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, i1, i2, kd, nb, in, kl, iw, ku, lda, ikd, inb, nkd,
+ ldab, ioff, mode, koff, imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), dget04_(
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ extern /* Subroutine */ int dpbt01_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *), dpbt02_(char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *),
+ dpbt05_(char *, integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *);
+ integer kdval[4];
+ doublereal rcond;
+ integer nimat;
+ doublereal anorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dswap_(integer *, doublereal *, integer
+ *, doublereal *, integer *);
+ integer iuplo, izero, nerrs;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *);
+ extern doublereal dlange_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ extern doublereal dlansb_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dpbcon_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *);
+ doublereal rcondc;
+ char packit[1];
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *), dlaset_(char *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *), dpbrfs_(char *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *), dpbtrf_(char *,
+ integer *, integer *, doublereal *, integer *, integer *),
+ alasum_(char *, integer *, integer *, integer *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublereal *, integer *, doublereal
+ *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int derrpo_(char *, integer *), dpbtrs_(
+ char *, integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, integer *), xlaenv_(integer *,
+ integer *);
+ doublereal result[7];
+
+ /* Fortran I/O blocks */
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKPB tests DPBTRF, -TRS, -RFS, and -CON. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "PB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrpo_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+ kdval[0] = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+
+/* Set limits on the number of loop iterations. */
+
+/* Computing MAX */
+ i__2 = 1, i__3 = min(n,4);
+ nkd = max(i__2,i__3);
+ nimat = 8;
+ if (n == 0) {
+ nimat = 1;
+ }
+
+ kdval[1] = n + (n + 1) / 4;
+ kdval[2] = (n * 3 - 1) / 4;
+ kdval[3] = (n + 1) / 4;
+
+ i__2 = nkd;
+ for (ikd = 1; ikd <= i__2; ++ikd) {
+
+/* Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order */
+/* makes it easier to skip redundant values for small values */
+/* of N. */
+
+ kd = kdval[ikd - 1];
+ ldab = kd + 1;
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ koff = 1;
+ if (iuplo == 1) {
+ *(unsigned char *)uplo = 'U';
+/* Computing MAX */
+ i__3 = 1, i__4 = kd + 2 - n;
+ koff = max(i__3,i__4);
+ *(unsigned char *)packit = 'Q';
+ } else {
+ *(unsigned char *)uplo = 'L';
+ *(unsigned char *)packit = 'B';
+ }
+
+ i__3 = nimat;
+ for (imat = 1; imat <= i__3; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L60;
+ }
+
+/* Skip types 2, 3, or 4 if the matrix size is too small. */
+
+ zerot = imat >= 2 && imat <= 4;
+ if (zerot && n < imat - 1) {
+ goto L60;
+ }
+
+ if (! zerot || ! dotype[1]) {
+
+/* Set up parameters with DLATB4 and generate a test */
+/* matrix with DLATMS. */
+
+ dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm,
+ &mode, &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)
+ 6);
+ dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode,
+ &cndnum, &anorm, &kd, &kd, packit, &a[koff],
+ &ldab, &work[1], &info);
+
+/* Check error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &
+ n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ goto L60;
+ }
+ } else if (izero > 0) {
+
+/* Use the same matrix for types 3 and 4 as for type */
+/* 2 by copying back the zeroed out column, */
+
+ iw = (lda << 1) + 1;
+ if (iuplo == 1) {
+ ioff = (izero - 1) * ldab + kd + 1;
+ i__4 = izero - i1;
+ dcopy_(&i__4, &work[iw], &c__1, &a[ioff - izero +
+ i1], &c__1);
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ dcopy_(&i__4, &work[iw], &c__1, &a[ioff], &i__5);
+ } else {
+ ioff = (i1 - 1) * ldab + 1;
+ i__4 = izero - i1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ dcopy_(&i__4, &work[iw], &c__1, &a[ioff + izero -
+ i1], &i__5);
+ ioff = (izero - 1) * ldab + 1;
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+ dcopy_(&i__4, &work[iw], &c__1, &a[ioff], &c__1);
+ }
+ }
+
+/* For types 2-4, zero one row and column of the matrix */
+/* to test that INFO is returned correctly. */
+
+ izero = 0;
+ if (zerot) {
+ if (imat == 2) {
+ izero = 1;
+ } else if (imat == 3) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+/* Save the zeroed out row and column in WORK(*,3) */
+
+ iw = lda << 1;
+/* Computing MIN */
+ i__5 = (kd << 1) + 1;
+ i__4 = min(i__5,n);
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ work[iw + i__] = 0.;
+/* L20: */
+ }
+ ++iw;
+/* Computing MAX */
+ i__4 = izero - kd;
+ i1 = max(i__4,1);
+/* Computing MIN */
+ i__4 = izero + kd;
+ i2 = min(i__4,n);
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * ldab + kd + 1;
+ i__4 = izero - i1;
+ dswap_(&i__4, &a[ioff - izero + i1], &c__1, &work[
+ iw], &c__1);
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ dswap_(&i__4, &a[ioff], &i__5, &work[iw], &c__1);
+ } else {
+ ioff = (i1 - 1) * ldab + 1;
+ i__4 = izero - i1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ dswap_(&i__4, &a[ioff + izero - i1], &i__5, &work[
+ iw], &c__1);
+ ioff = (izero - 1) * ldab + 1;
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+ dswap_(&i__4, &a[ioff], &c__1, &work[iw], &c__1);
+ }
+ }
+
+/* Do for each value of NB in NBVAL */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the L*L' or U'*U factorization of the band */
+/* matrix. */
+
+ i__5 = kd + 1;
+ dlacpy_("Full", &i__5, &n, &a[1], &ldab, &afac[1], &
+ ldab);
+ s_copy(srnamc_1.srnamt, "DPBTRF", (ftnlen)32, (ftnlen)
+ 6);
+ dpbtrf_(uplo, &n, &kd, &afac[1], &ldab, &info);
+
+/* Check error code from DPBTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "DPBTRF", &info, &izero, uplo, &n, &
+ n, &kd, &kd, &nb, &imat, &nfail, &nerrs,
+ nout);
+ goto L50;
+ }
+
+/* Skip the tests if INFO is not 0. */
+
+ if (info != 0) {
+ goto L50;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ i__5 = kd + 1;
+ dlacpy_("Full", &i__5, &n, &afac[1], &ldab, &ainv[1],
+ &ldab);
+ dpbt01_(uplo, &n, &kd, &a[1], &ldab, &ainv[1], &ldab,
+ &rwork[1], result);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+/* Only do other tests if this is the first blocksize. */
+
+ if (inb > 1) {
+ goto L50;
+ }
+
+/* Form the inverse of A so we can get a good estimate */
+/* of RCONDC = 1/(norm(A) * norm(inv(A))). */
+
+ dlaset_("Full", &n, &n, &c_b50, &c_b51, &ainv[1], &
+ lda);
+ s_copy(srnamc_1.srnamt, "DPBTRS", (ftnlen)32, (ftnlen)
+ 6);
+ dpbtrs_(uplo, &n, &kd, &n, &afac[1], &ldab, &ainv[1],
+ &lda, &info);
+
+/* Compute RCONDC = 1/(norm(A) * norm(inv(A))). */
+
+ anorm = dlansb_("1", uplo, &n, &kd, &a[1], &ldab, &
+ rwork[1]);
+ ainvnm = dlange_("1", &n, &n, &ainv[1], &lda, &rwork[
+ 1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondc = 1.;
+ } else {
+ rcondc = 1. / anorm / ainvnm;
+ }
+
+ i__5 = *nns;
+ for (irhs = 1; irhs <= i__5; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 2 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (
+ ftnlen)6);
+ dlarhs_(path, xtype, uplo, " ", &n, &n, &kd, &kd,
+ &nrhs, &a[1], &ldab, &xact[1], &lda, &b[1]
+, &lda, iseed, &info);
+ dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "DPBTRS", (ftnlen)32, (
+ ftnlen)6);
+ dpbtrs_(uplo, &n, &kd, &nrhs, &afac[1], &ldab, &x[
+ 1], &lda, &info);
+
+/* Check error code from DPBTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "DPBTRS", &info, &c__0, uplo, &
+ n, &n, &kd, &kd, &nrhs, &imat, &nfail,
+ &nerrs, nout);
+ }
+
+ dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1],
+ &lda);
+ dpbt02_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &x[1],
+ &lda, &work[1], &lda, &rwork[1], &result[
+ 1]);
+
+/* + TEST 3 */
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* + TESTS 4, 5, and 6 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "DPBRFS", (ftnlen)32, (
+ ftnlen)6);
+ dpbrfs_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &afac[
+ 1], &ldab, &b[1], &lda, &x[1], &lda, &
+ rwork[1], &rwork[nrhs + 1], &work[1], &
+ iwork[1], &info);
+
+/* Check error code from DPBRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "DPBRFS", &info, &c__0, uplo, &
+ n, &n, &kd, &kd, &nrhs, &imat, &nfail,
+ &nerrs, nout);
+ }
+
+ dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+ dpbt05_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &b[1],
+ &lda, &x[1], &lda, &xact[1], &lda, &
+ rwork[1], &rwork[nrhs + 1], &result[4]);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___46.ciunit = *nout;
+ s_wsfe(&io___46);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L30: */
+ }
+ nrun += 5;
+/* L40: */
+ }
+
+/* + TEST 7 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ s_copy(srnamc_1.srnamt, "DPBCON", (ftnlen)32, (ftnlen)
+ 6);
+ dpbcon_(uplo, &n, &kd, &afac[1], &ldab, &anorm, &
+ rcond, &work[1], &iwork[1], &info);
+
+/* Check error code from DPBCON. */
+
+ if (info != 0) {
+ alaerh_(path, "DPBCON", &info, &c__0, uplo, &n, &
+ n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ result[6] = dget06_(&rcond, &rcondc);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___48.ciunit = *nout;
+ s_wsfe(&io___48);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L50:
+ ;
+ }
+L60:
+ ;
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DCHKPB */
+
+} /* dchkpb_ */
diff --git a/TESTING/LIN/dchkpo.c b/TESTING/LIN/dchkpo.c
new file mode 100644
index 0000000..8415d29
--- /dev/null
+++ b/TESTING/LIN/dchkpo.c
@@ -0,0 +1,603 @@
+/* dchkpo.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__8 = 8;
+
+/* Subroutine */ int dchkpo_(logical *dotype, integer *nn, integer *nval,
+ integer *nnb, integer *nbval, integer *nns, integer *nsval,
+ doublereal *thresh, logical *tsterr, integer *nmax, doublereal *a,
+ doublereal *afac, doublereal *ainv, doublereal *b, doublereal *x,
+ doublereal *xact, doublereal *work, doublereal *rwork, integer *iwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
+ "=\002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
+ "12.5)";
+ static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002"
+ ",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
+ ;
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, nb, in, kl, ku, lda, inb, ioff, mode, imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), dget04_(
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ doublereal rcond;
+ extern /* Subroutine */ int dpot01_(char *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *);
+ integer nimat;
+ extern /* Subroutine */ int dpot02_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *), dpot03_(char *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *), dpot05_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *);
+ doublereal anorm;
+ integer iuplo, izero, nerrs;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *);
+ doublereal rcondc;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *), alasum_(char *,
+ integer *, integer *, integer *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublereal *, integer *, doublereal
+ *, integer *), dpocon_(char *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int derrpo_(char *, integer *), dporfs_(
+ char *, integer *, integer *, doublereal *, integer *, doublereal
+ *, integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *), dpotrf_(char *, integer *, doublereal *, integer *,
+ integer *), xlaenv_(integer *, integer *), dpotri_(char *,
+ integer *, doublereal *, integer *, integer *), dpotrs_(
+ char *, integer *, integer *, doublereal *, integer *, doublereal
+ *, integer *, integer *);
+ doublereal result[8];
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKPO tests DPOTRF, -TRI, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "PO", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrpo_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ izero = 0;
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L110;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot && n < imat - 2) {
+ goto L110;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Set up parameters with DLATB4 and generate a test matrix */
+/* with DLATMS. */
+
+ dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
+ &info);
+
+/* Check error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L100;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff] = 0.;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff] = 0.;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Do for each value of NB in NBVAL */
+
+ i__3 = *nnb;
+ for (inb = 1; inb <= i__3; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the L*L' or U'*U factorization of the matrix. */
+
+ dlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ s_copy(srnamc_1.srnamt, "DPOTRF", (ftnlen)32, (ftnlen)6);
+ dpotrf_(uplo, &n, &afac[1], &lda, &info);
+
+/* Check error code from DPOTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "DPOTRF", &info, &izero, uplo, &n, &n, &
+ c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+
+/* Skip the tests if INFO is not 0. */
+
+ if (info != 0) {
+ goto L90;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ dlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
+ dpot01_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &rwork[1],
+ result);
+
+/* + TEST 2 */
+/* Form the inverse and compute the residual. */
+
+ dlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
+ s_copy(srnamc_1.srnamt, "DPOTRI", (ftnlen)32, (ftnlen)6);
+ dpotri_(uplo, &n, &ainv[1], &lda, &info);
+
+/* Check error code from DPOTRI. */
+
+ if (info != 0) {
+ alaerh_(path, "DPOTRI", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ dpot03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &work[1], &
+ lda, &rwork[1], &rcondc, &result[1]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 1; k <= 2; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += 2;
+
+/* Skip the rest of the tests unless this is the first */
+/* blocksize. */
+
+ if (inb != 1) {
+ goto L90;
+ }
+
+ i__4 = *nns;
+ for (irhs = 1; irhs <= i__4; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B . */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "DPOTRS", (ftnlen)32, (ftnlen)
+ 6);
+ dpotrs_(uplo, &n, &nrhs, &afac[1], &lda, &x[1], &lda,
+ &info);
+
+/* Check error code from DPOTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "DPOTRS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &
+ lda);
+ dpot02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
+ work[1], &lda, &rwork[1], &result[2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "DPORFS", (ftnlen)32, (ftnlen)
+ 6);
+ dporfs_(uplo, &n, &nrhs, &a[1], &lda, &afac[1], &lda,
+ &b[1], &lda, &x[1], &lda, &rwork[1], &rwork[
+ nrhs + 1], &work[1], &iwork[1], &info);
+
+/* Check error code from DPORFS. */
+
+ if (info != 0) {
+ alaerh_(path, "DPORFS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[4]);
+ dpot05_(uplo, &n, &nrhs, &a[1], &lda, &b[1], &lda, &x[
+ 1], &lda, &xact[1], &lda, &rwork[1], &rwork[
+ nrhs + 1], &result[5]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L70: */
+ }
+ nrun += 5;
+/* L80: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ anorm = dlansy_("1", uplo, &n, &a[1], &lda, &rwork[1]);
+ s_copy(srnamc_1.srnamt, "DPOCON", (ftnlen)32, (ftnlen)6);
+ dpocon_(uplo, &n, &afac[1], &lda, &anorm, &rcond, &work[1]
+, &iwork[1], &info);
+
+/* Check error code from DPOCON. */
+
+ if (info != 0) {
+ alaerh_(path, "DPOCON", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ result[7] = dget06_(&rcond, &rcondc);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L90:
+ ;
+ }
+L100:
+ ;
+ }
+L110:
+ ;
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DCHKPO */
+
+} /* dchkpo_ */
diff --git a/TESTING/LIN/dchkpp.c b/TESTING/LIN/dchkpp.c
new file mode 100644
index 0000000..95525c3
--- /dev/null
+++ b/TESTING/LIN/dchkpp.c
@@ -0,0 +1,567 @@
+/* dchkpp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__8 = 8;
+
+/* Subroutine */ int dchkpp_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, doublereal *thresh, logical *tsterr,
+ integer *nmax, doublereal *a, doublereal *afac, doublereal *ainv,
+ doublereal *b, doublereal *x, doublereal *xact, doublereal *work,
+ doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char packs[1*2] = "C" "R";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
+ "12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, in, kl, ku, lda, npp, ioff, mode, imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), dget04_(
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ doublereal rcond;
+ integer nimat;
+ extern /* Subroutine */ int dppt01_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *), dppt02_(char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *),
+ dppt03_(char *, integer *, doublereal *, doublereal *, doublereal
+ *, integer *, doublereal *, doublereal *, doublereal *);
+ doublereal anorm;
+ extern /* Subroutine */ int dppt05_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *), dcopy_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer iuplo, izero, nerrs;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *);
+ doublereal rcondc;
+ char packit[1];
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *);
+ extern doublereal dlansp_(char *, char *, integer *, doublereal *,
+ doublereal *);
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublereal *, integer *, doublereal
+ *, integer *), dppcon_(char *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *), derrpo_(char *, integer *), dpprfs_(
+ char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *),
+ dpptrf_(char *, integer *, doublereal *, integer *),
+ dpptri_(char *, integer *, doublereal *, integer *),
+ dpptrs_(char *, integer *, integer *, doublereal *, doublereal *,
+ integer *, integer *);
+ doublereal result[8];
+
+ /* Fortran I/O blocks */
+ static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKPP tests DPPTRF, -TRI, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AFAC (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AINV (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "PP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrpo_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L100;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot && n < imat - 2) {
+ goto L100;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ *(unsigned char *)packit = *(unsigned char *)&packs[iuplo - 1]
+ ;
+
+/* Set up parameters with DLATB4 and generate a test matrix */
+/* with DLATMS. */
+
+ dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
+ 1], &info);
+
+/* Check error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * izero / 2;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff] = 0.;
+ ioff += i__;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff] = 0.;
+ ioff = ioff + n - i__;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Compute the L*L' or U'*U factorization of the matrix. */
+
+ npp = n * (n + 1) / 2;
+ dcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ s_copy(srnamc_1.srnamt, "DPPTRF", (ftnlen)32, (ftnlen)6);
+ dpptrf_(uplo, &n, &afac[1], &info);
+
+/* Check error code from DPPTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "DPPTRF", &info, &izero, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+
+/* Skip the tests if INFO is not 0. */
+
+ if (info != 0) {
+ goto L90;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ dcopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
+ dppt01_(uplo, &n, &a[1], &ainv[1], &rwork[1], result);
+
+/* + TEST 2 */
+/* Form the inverse and compute the residual. */
+
+ dcopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
+ s_copy(srnamc_1.srnamt, "DPPTRI", (ftnlen)32, (ftnlen)6);
+ dpptri_(uplo, &n, &ainv[1], &info);
+
+/* Check error code from DPPTRI. */
+
+ if (info != 0) {
+ alaerh_(path, "DPPTRI", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+ dppt03_(uplo, &n, &a[1], &ainv[1], &work[1], &lda, &rwork[1],
+ &rcondc, &result[1]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 1; k <= 2; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += 2;
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)6);
+ dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &nrhs, &
+ a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
+ info);
+ dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "DPPTRS", (ftnlen)32, (ftnlen)6);
+ dpptrs_(uplo, &n, &nrhs, &afac[1], &x[1], &lda, &info);
+
+/* Check error code from DPPTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "DPPTRS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
+ dppt02_(uplo, &n, &nrhs, &a[1], &x[1], &lda, &work[1], &
+ lda, &rwork[1], &result[2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "DPPRFS", (ftnlen)32, (ftnlen)6);
+ dpprfs_(uplo, &n, &nrhs, &a[1], &afac[1], &b[1], &lda, &x[
+ 1], &lda, &rwork[1], &rwork[nrhs + 1], &work[1], &
+ iwork[1], &info);
+
+/* Check error code from DPPRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "DPPRFS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[4]);
+ dppt05_(uplo, &n, &nrhs, &a[1], &b[1], &lda, &x[1], &lda,
+ &xact[1], &lda, &rwork[1], &rwork[nrhs + 1], &
+ result[5]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L70: */
+ }
+ nrun += 5;
+/* L80: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ anorm = dlansp_("1", uplo, &n, &a[1], &rwork[1]);
+ s_copy(srnamc_1.srnamt, "DPPCON", (ftnlen)32, (ftnlen)6);
+ dppcon_(uplo, &n, &afac[1], &anorm, &rcond, &work[1], &iwork[
+ 1], &info);
+
+/* Check error code from DPPCON. */
+
+ if (info != 0) {
+ alaerh_(path, "DPPCON", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+ result[7] = dget06_(&rcond, &rcondc);
+
+/* Print the test ratio if greater than or equal to THRESH. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L90:
+ ;
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DCHKPP */
+
+} /* dchkpp_ */
diff --git a/TESTING/LIN/dchkps.c b/TESTING/LIN/dchkps.c
new file mode 100644
index 0000000..25bf4db
--- /dev/null
+++ b/TESTING/LIN/dchkps.c
@@ -0,0 +1,379 @@
+/* dchkps.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+
+/* Subroutine */ int dchkps_(logical *dotype, integer *nn, integer *nval,
+ integer *nnb, integer *nbval, integer *nrank, integer *rankval,
+ doublereal *thresh, logical *tsterr, integer *nmax, doublereal *a,
+ doublereal *afac, doublereal *perm, integer *piv, doublereal *work,
+ doublereal *rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "RANK =\002,i3,\002, Diff =\002,i5,\002, NB =\002,i4,\002, type"
+ " \002,i2,\002, Ratio =\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublereal d__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer i_dceiling(doublereal *), s_wsfe(cilist *), do_fio(integer *,
+ char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer rankdiff, comprank, i__, n, nb, in, kl, ku, lda, inb;
+ doublereal tol;
+ integer mode, imat, info, rank;
+ char path[3], dist[1], uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4], irank, nimat;
+ extern /* Subroutine */ int dpst01_(char *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, doublereal *, doublereal *, integer *);
+ doublereal anorm;
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int dlatb5_(char *, integer *, integer *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *, char
+ *), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *), dlacpy_(char *, integer *, integer *, doublereal
+ *, integer *, doublereal *, integer *), alasum_(char *,
+ integer *, integer *, integer *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int dlatmt_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, integer *, char *, doublereal *, integer *,
+ doublereal *, integer *), xlaenv_(integer
+ *, integer *), derrps_(char *, integer *), dpstrf_(char *,
+ integer *, doublereal *, integer *, integer *, integer *,
+ doublereal *, doublereal *, integer *);
+ doublereal result;
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKPS tests DPSTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the block size NB. */
+
+/* NRANK (input) INTEGER */
+/* The number of values of RANK contained in the vector RANKVAL. */
+
+/* RANKVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the block size NB. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* PERM (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* PIV (workspace) INTEGER array, dimension (NMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*3) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --piv;
+ --perm;
+ --afac;
+ --a;
+ --rankval;
+ --nbval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "PS", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L100: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrps_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ izero = 0;
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L140;
+ }
+
+/* Do for each value of RANK in RANKVAL */
+
+ i__3 = *nrank;
+ for (irank = 1; irank <= i__3; ++irank) {
+
+/* Only repeat test 3 to 5 for different ranks */
+/* Other tests use full rank */
+
+ if ((imat < 3 || imat > 5) && irank > 1) {
+ goto L130;
+ }
+
+ d__1 = n * (doublereal) rankval[irank] / 100.;
+ rank = i_dceiling(&d__1);
+
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+
+/* Set up parameters with DLATB5 and generate a test matrix */
+/* with DLATMT. */
+
+ dlatb5_(path, &imat, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "DLATMT", (ftnlen)32, (ftnlen)6);
+ dlatmt_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &rank, &kl, &ku, uplo, &a[1], &
+ lda, &work[1], &info);
+
+/* Check error code from DLATMT. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMT", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ goto L120;
+ }
+
+/* Do for each value of NB in NBVAL */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the pivoted L*L' or U'*U factorization */
+/* of the matrix. */
+
+ dlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ s_copy(srnamc_1.srnamt, "DPSTRF", (ftnlen)32, (ftnlen)
+ 6);
+
+/* Use default tolerance */
+
+ tol = -1.;
+ dpstrf_(uplo, &n, &afac[1], &lda, &piv[1], &comprank,
+ &tol, &work[1], &info);
+
+/* Check error code from DPSTRF. */
+
+ if (info < izero || info != izero && rank == n ||
+ info <= izero && rank < n) {
+ alaerh_(path, "DPSTRF", &info, &izero, uplo, &n, &
+ n, &c_n1, &c_n1, &nb, &imat, &nfail, &
+ nerrs, nout);
+ goto L110;
+ }
+
+/* Skip the test if INFO is not 0. */
+
+ if (info != 0) {
+ goto L110;
+ }
+
+/* Reconstruct matrix from factors and compute residual. */
+
+/* PERM holds permuted L*L^T or U^T*U */
+
+ dpst01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &perm[
+ 1], &lda, &piv[1], &rwork[1], &result, &
+ comprank);
+
+/* Print information about the tests that did not pass */
+/* the threshold or where computed rank was not RANK. */
+
+ if (n == 0) {
+ comprank = 0;
+ }
+ rankdiff = rank - comprank;
+ if (result >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&rank, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&rankdiff, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result, (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L110:
+ ;
+ }
+
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+L140:
+ ;
+ }
+/* L150: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DCHKPS */
+
+} /* dchkps_ */
diff --git a/TESTING/LIN/dchkpt.c b/TESTING/LIN/dchkpt.c
new file mode 100644
index 0000000..0e17c80
--- /dev/null
+++ b/TESTING/LIN/dchkpt.c
@@ -0,0 +1,614 @@
+/* dchkpt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static doublereal c_b46 = 1.;
+static doublereal c_b47 = 0.;
+static integer c__7 = 7;
+
+/* Subroutine */ int dchkpt_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, doublereal *thresh, logical *tsterr,
+ doublereal *a, doublereal *d__, doublereal *e, doublereal *b,
+ doublereal *x, doublereal *xact, doublereal *work, doublereal *rwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 0,0,0,1 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 N =\002,i5,\002, type \002,i2,\002, te"
+ "st \002,i2,\002, ratio = \002,g12.5)";
+ static char fmt_9998[] = "(\002 N =\002,i5,\002, NRHS=\002,i3,\002, ty"
+ "pe \002,i2,\002, test(\002,i2,\002) = \002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n;
+ doublereal z__[3];
+ integer ia, in, kl, ku, ix, lda;
+ doublereal cond;
+ integer mode;
+ doublereal dmax__;
+ integer imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), dscal_(
+ integer *, doublereal *, doublereal *, integer *), dget04_(
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ doublereal rcond;
+ integer nimat;
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal anorm;
+ extern /* Subroutine */ int dptt01_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *), dcopy_(
+ integer *, doublereal *, integer *, doublereal *, integer *),
+ dptt02_(integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *),
+ dptt05_(integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *);
+ integer izero, nerrs;
+ logical zerot;
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal rcondc;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlaptm_(integer *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *), alasum_(char *, integer *, integer *, integer *,
+ integer *), dlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublereal *, integer *, doublereal
+ *, integer *);
+ extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
+ extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *,
+ doublereal *), derrgt_(char *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int dptcon_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *), dptrfs_(
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *), dpttrf_(
+ integer *, doublereal *, doublereal *, integer *);
+ doublereal result[7];
+ extern /* Subroutine */ int dpttrs_(integer *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKPT tests DPTTRF, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*2) */
+
+/* D (workspace) DOUBLE PRECISION array, dimension (NMAX*2) */
+
+/* E (workspace) DOUBLE PRECISION array, dimension (NMAX*2) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --e;
+ --d__;
+ --a;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "PT", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrgt_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+ lda = max(1,n);
+ nimat = 12;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (n > 0 && ! dotype[imat]) {
+ goto L100;
+ }
+
+/* Set up parameters with DLATB4. */
+
+ dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cond, dist);
+
+ zerot = imat >= 8 && imat <= 10;
+ if (imat <= 6) {
+
+/* Type 1-6: generate a symmetric tridiagonal matrix of */
+/* known condition number in lower triangular band storage. */
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
+ &anorm, &kl, &ku, "B", &a[1], &c__2, &work[1], &info);
+
+/* Check the error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, " ", &n, &n, &kl, &
+ ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L100;
+ }
+ izero = 0;
+
+/* Copy the matrix to D and E. */
+
+ ia = 1;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d__[i__] = a[ia];
+ e[i__] = a[ia + 1];
+ ia += 2;
+/* L20: */
+ }
+ if (n > 0) {
+ d__[n] = a[ia];
+ }
+ } else {
+
+/* Type 7-12: generate a diagonally dominant matrix with */
+/* unknown condition number in the vectors D and E. */
+
+ if (! zerot || ! dotype[7]) {
+
+/* Let D and E have values from [-1,1]. */
+
+ dlarnv_(&c__2, iseed, &n, &d__[1]);
+ i__3 = n - 1;
+ dlarnv_(&c__2, iseed, &i__3, &e[1]);
+
+/* Make the tridiagonal matrix diagonally dominant. */
+
+ if (n == 1) {
+ d__[1] = abs(d__[1]);
+ } else {
+ d__[1] = abs(d__[1]) + abs(e[1]);
+ d__[n] = (d__1 = d__[n], abs(d__1)) + (d__2 = e[n - 1]
+ , abs(d__2));
+ i__3 = n - 1;
+ for (i__ = 2; i__ <= i__3; ++i__) {
+ d__[i__] = (d__1 = d__[i__], abs(d__1)) + (d__2 =
+ e[i__], abs(d__2)) + (d__3 = e[i__ - 1],
+ abs(d__3));
+/* L30: */
+ }
+ }
+
+/* Scale D and E so the maximum element is ANORM. */
+
+ ix = idamax_(&n, &d__[1], &c__1);
+ dmax__ = d__[ix];
+ d__1 = anorm / dmax__;
+ dscal_(&n, &d__1, &d__[1], &c__1);
+ i__3 = n - 1;
+ d__1 = anorm / dmax__;
+ dscal_(&i__3, &d__1, &e[1], &c__1);
+
+ } else if (izero > 0) {
+
+/* Reuse the last matrix by copying back the zeroed out */
+/* elements. */
+
+ if (izero == 1) {
+ d__[1] = z__[1];
+ if (n > 1) {
+ e[1] = z__[2];
+ }
+ } else if (izero == n) {
+ e[n - 1] = z__[0];
+ d__[n] = z__[1];
+ } else {
+ e[izero - 1] = z__[0];
+ d__[izero] = z__[1];
+ e[izero] = z__[2];
+ }
+ }
+
+/* For types 8-10, set one row and column of the matrix to */
+/* zero. */
+
+ izero = 0;
+ if (imat == 8) {
+ izero = 1;
+ z__[1] = d__[1];
+ d__[1] = 0.;
+ if (n > 1) {
+ z__[2] = e[1];
+ e[1] = 0.;
+ }
+ } else if (imat == 9) {
+ izero = n;
+ if (n > 1) {
+ z__[0] = e[n - 1];
+ e[n - 1] = 0.;
+ }
+ z__[1] = d__[n];
+ d__[n] = 0.;
+ } else if (imat == 10) {
+ izero = (n + 1) / 2;
+ if (izero > 1) {
+ z__[0] = e[izero - 1];
+ e[izero - 1] = 0.;
+ z__[2] = e[izero];
+ e[izero] = 0.;
+ }
+ z__[1] = d__[izero];
+ d__[izero] = 0.;
+ }
+ }
+
+ dcopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
+ if (n > 1) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
+ }
+
+/* + TEST 1 */
+/* Factor A as L*D*L' and compute the ratio */
+/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
+
+ dpttrf_(&n, &d__[n + 1], &e[n + 1], &info);
+
+/* Check error code from DPTTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "DPTTRF", &info, &izero, " ", &n, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L100;
+ }
+
+ if (info > 0) {
+ rcondc = 0.;
+ goto L90;
+ }
+
+ dptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &work[1],
+ result);
+
+/* Print the test ratio if greater than or equal to THRESH. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+/* Compute RCONDC = 1 / (norm(A) * norm(inv(A)) */
+
+/* Compute norm(A). */
+
+ anorm = dlanst_("1", &n, &d__[1], &e[1]);
+
+/* Use DPTTRS to solve for one column at a time of inv(A), */
+/* computing the maximum column sum as we go. */
+
+ ainvnm = 0.;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ x[j] = 0.;
+/* L40: */
+ }
+ x[i__] = 1.;
+ dpttrs_(&n, &c__1, &d__[n + 1], &e[n + 1], &x[1], &lda, &info)
+ ;
+/* Computing MAX */
+ d__1 = ainvnm, d__2 = dasum_(&n, &x[1], &c__1);
+ ainvnm = max(d__1,d__2);
+/* L50: */
+ }
+/* Computing MAX */
+ d__1 = 1., d__2 = anorm * ainvnm;
+ rcondc = 1. / max(d__1,d__2);
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* Generate NRHS random solution vectors. */
+
+ ix = 1;
+ i__4 = nrhs;
+ for (j = 1; j <= i__4; ++j) {
+ dlarnv_(&c__2, iseed, &n, &xact[ix]);
+ ix += lda;
+/* L60: */
+ }
+
+/* Set the right hand side. */
+
+ dlaptm_(&n, &nrhs, &c_b46, &d__[1], &e[1], &xact[1], &lda, &
+ c_b47, &b[1], &lda);
+
+/* + TEST 2 */
+/* Solve A*x = b and compute the residual. */
+
+ dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+ dpttrs_(&n, &nrhs, &d__[n + 1], &e[n + 1], &x[1], &lda, &info)
+ ;
+
+/* Check error code from DPTTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "DPTTRS", &info, &c__0, " ", &n, &n, &c_n1,
+ &c_n1, &nrhs, &imat, &nfail, &nerrs, nout);
+ }
+
+ dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
+ dptt02_(&n, &nrhs, &d__[1], &e[1], &x[1], &lda, &work[1], &
+ lda, &result[1]);
+
+/* + TEST 3 */
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[2]);
+
+/* + TESTS 4, 5, and 6 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "DPTRFS", (ftnlen)32, (ftnlen)6);
+ dptrfs_(&n, &nrhs, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &b[
+ 1], &lda, &x[1], &lda, &rwork[1], &rwork[nrhs + 1], &
+ work[1], &info);
+
+/* Check error code from DPTRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "DPTRFS", &info, &c__0, " ", &n, &n, &c_n1,
+ &c_n1, &nrhs, &imat, &nfail, &nerrs, nout);
+ }
+
+ dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[3]);
+ dptt05_(&n, &nrhs, &d__[1], &e[1], &b[1], &lda, &x[1], &lda, &
+ xact[1], &lda, &rwork[1], &rwork[nrhs + 1], &result[4]
+);
+
+/* Print information about the tests that did not pass the */
+/* threshold. */
+
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L70: */
+ }
+ nrun += 5;
+/* L80: */
+ }
+
+/* + TEST 7 */
+/* Estimate the reciprocal of the condition number of the */
+/* matrix. */
+
+L90:
+ s_copy(srnamc_1.srnamt, "DPTCON", (ftnlen)32, (ftnlen)6);
+ dptcon_(&n, &d__[n + 1], &e[n + 1], &anorm, &rcond, &rwork[1], &
+ info);
+
+/* Check error code from DPTCON. */
+
+ if (info != 0) {
+ alaerh_(path, "DPTCON", &info, &c__0, " ", &n, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+ result[6] = dget06_(&rcond, &rcondc);
+
+/* Print the test ratio if greater than or equal to THRESH. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L100:
+ ;
+ }
+/* L110: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DCHKPT */
+
+} /* dchkpt_ */
diff --git a/TESTING/LIN/dchkq3.c b/TESTING/LIN/dchkq3.c
new file mode 100644
index 0000000..caa5291
--- /dev/null
+++ b/TESTING/LIN/dchkq3.c
@@ -0,0 +1,400 @@
+/* dchkq3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublereal c_b11 = 0.;
+static doublereal c_b16 = 1.;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int dchkq3_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nxval, doublereal *thresh, doublereal *a, doublereal *copya,
+ doublereal *s, doublereal *copys, doublereal *tau, doublereal *work,
+ integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002 M =\002,i5,\002, N =\002,i5,\002, N"
+ "B =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, im, in, lw, nx, lda, inb;
+ doublereal eps;
+ integer mode, info;
+ char path[3];
+ integer ilow, nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer ihigh, nfail, iseed[4], imode;
+ extern doublereal dqpt01_(integer *, integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dqrt11_(integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dqrt12_(integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ integer mnmin;
+ extern /* Subroutine */ int icopy_(integer *, integer *, integer *,
+ integer *, integer *);
+ integer istep, nerrs, lwork;
+ extern /* Subroutine */ int dgeqp3_(integer *, integer *, doublereal *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *,
+ integer *), dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), alasum_(char *, integer *,
+ integer *, integer *, integer *), dlatms_(integer *,
+ integer *, char *, integer *, char *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *, char *,
+ doublereal *, integer *, doublereal *, integer *), xlaenv_(integer *, integer *);
+ doublereal result[3];
+
+ /* Fortran I/O blocks */
+ static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKQ3 tests DGEQP3. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* THRESH (input) 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. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX) */
+/* where MMAX is the maximum value of M in MVAL and NMAX is the */
+/* maximum value of N in NVAL. */
+
+/* COPYA (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* COPYS (workspace) DOUBLE PRECISION array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* TAU (workspace) DOUBLE PRECISION array, dimension (MMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (MMAX*NMAX + 4*NMAX + MMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --tau;
+ --copys;
+ --s;
+ --copya;
+ --a;
+ --nxval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "Q3", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = dlamch_("Epsilon");
+ infoc_1.infot = 0;
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+
+/* Do for each value of M in MVAL. */
+
+ m = mval[im];
+ lda = max(1,m);
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__3 = 1, i__4 = m * max(m,n) + (mnmin << 2) + max(m,n), i__3 =
+ max(i__3,i__4), i__4 = m * n + (mnmin << 1) + (n << 2);
+ lwork = max(i__3,i__4);
+
+ for (imode = 1; imode <= 6; ++imode) {
+ if (! dotype[imode]) {
+ goto L70;
+ }
+
+/* Do for each type of matrix */
+/* 1: zero matrix */
+/* 2: one small singular value */
+/* 3: geometric distribution of singular values */
+/* 4: first n/2 columns fixed */
+/* 5: last n/2 columns fixed */
+/* 6: every second column fixed */
+
+ mode = imode;
+ if (imode > 3) {
+ mode = 1;
+ }
+
+/* Generate test matrix of size m by n using */
+/* singular value distribution indicated by `mode'. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ iwork[i__] = 0;
+/* L20: */
+ }
+ if (imode == 1) {
+ dlaset_("Full", &m, &n, &c_b11, &c_b11, ©a[1], &lda);
+ i__3 = mnmin;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ copys[i__] = 0.;
+/* L30: */
+ }
+ } else {
+ d__1 = 1. / eps;
+ dlatms_(&m, &n, "Uniform", iseed, "Nonsymm", ©s[1], &
+ mode, &d__1, &c_b16, &m, &n, "No packing", ©a[
+ 1], &lda, &work[1], &info);
+ if (imode >= 4) {
+ if (imode == 4) {
+ ilow = 1;
+ istep = 1;
+/* Computing MAX */
+ i__3 = 1, i__4 = n / 2;
+ ihigh = max(i__3,i__4);
+ } else if (imode == 5) {
+/* Computing MAX */
+ i__3 = 1, i__4 = n / 2;
+ ilow = max(i__3,i__4);
+ istep = 1;
+ ihigh = n;
+ } else if (imode == 6) {
+ ilow = 1;
+ istep = 2;
+ ihigh = n;
+ }
+ i__3 = ihigh;
+ i__4 = istep;
+ for (i__ = ilow; i__4 < 0 ? i__ >= i__3 : i__ <= i__3;
+ i__ += i__4) {
+ iwork[i__] = 1;
+/* L40: */
+ }
+ }
+ dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
+ }
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+
+/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
+
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ nx = nxval[inb];
+ xlaenv_(&c__3, &nx);
+
+/* Get a working copy of COPYA into A and a copy of */
+/* vector IWORK. */
+
+ dlacpy_("All", &m, &n, ©a[1], &lda, &a[1], &lda);
+ icopy_(&n, &iwork[1], &c__1, &iwork[n + 1], &c__1);
+
+/* Compute the QR factorization with pivoting of A */
+
+/* Computing MAX */
+ i__3 = 1, i__5 = (n << 1) + nb * (n + 1);
+ lw = max(i__3,i__5);
+
+/* Compute the QP3 factorization of A */
+
+ s_copy(srnamc_1.srnamt, "DGEQP3", (ftnlen)32, (ftnlen)6);
+ dgeqp3_(&m, &n, &a[1], &lda, &iwork[n + 1], &tau[1], &
+ work[1], &lw, &info);
+
+/* Compute norm(svd(a) - svd(r)) */
+
+ result[0] = dqrt12_(&m, &n, &a[1], &lda, ©s[1], &work[
+ 1], &lwork);
+
+/* Compute norm( A*P - Q*R ) */
+
+ result[1] = dqpt01_(&m, &n, &mnmin, ©a[1], &a[1], &
+ lda, &tau[1], &iwork[n + 1], &work[1], &lwork);
+
+/* Compute Q'*Q */
+
+ result[2] = dqrt11_(&m, &mnmin, &a[1], &lda, &tau[1], &
+ work[1], &lwork);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 1; k <= 3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___28.ciunit = *nout;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "DGEQP3", (ftnlen)6);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L50: */
+ }
+ nrun += 3;
+
+/* L60: */
+ }
+L70:
+ ;
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+
+/* End of DCHKQ3 */
+
+ return 0;
+} /* dchkq3_ */
diff --git a/TESTING/LIN/dchkql.c b/TESTING/LIN/dchkql.c
new file mode 100644
index 0000000..ff8746d
--- /dev/null
+++ b/TESTING/LIN/dchkql.c
@@ -0,0 +1,481 @@
+/* dchkql.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int dchkql_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nxval, integer *nrhs, doublereal *thresh, logical *tsterr, integer *
+ nmax, doublereal *a, doublereal *af, doublereal *aq, doublereal *al,
+ doublereal *ac, doublereal *b, doublereal *x, doublereal *xact,
+ doublereal *tau, doublereal *work, doublereal *rwork, integer *iwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
+ "5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
+ "t(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, ik, im, in, kl, nk, ku, nt, nx, lda, inb, mode,
+ imat, info;
+ char path[3];
+ integer kval[4];
+ char dist[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), dget02_(
+ char *, integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int dqlt01_(integer *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *), dqlt02_(
+ integer *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, doublereal *), dqlt03_(integer *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *);
+ doublereal anorm;
+ integer minmn, nerrs, lwork;
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *);
+ extern logical dgennd_(integer *, integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *), dgeqls_(integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *),
+ alasum_(char *, integer *, integer *, integer *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublereal *, integer *, doublereal
+ *, integer *), derrql_(char *, integer *), xlaenv_(integer *, integer *);
+ doublereal result[8];
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKQL tests DGEQLF, DORGQL and DORMQL. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AQ (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AL (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* TAU (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --tau;
+ --xact;
+ --x;
+ --b;
+ --ac;
+ --al;
+ --aq;
+ --af;
+ --a;
+ --nxval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "QL", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrql_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+ lda = *nmax;
+ lwork = *nmax * max(*nmax,*nrhs);
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Do for each value of N in NVAL. */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ minmn = min(m,n);
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L50;
+ }
+
+/* Set up parameters with DLATB4 and generate a test matrix */
+/* with DLATMS. */
+
+ dlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, " ", &m, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L50;
+ }
+
+/* Set some values for K: the first value must be MINMN, */
+/* corresponding to the call of DQLT01; other values are */
+/* used in the calls of DQLT02, and must not exceed MINMN. */
+
+ kval[0] = minmn;
+ kval[1] = 0;
+ kval[2] = 1;
+ kval[3] = minmn / 2;
+ if (minmn == 0) {
+ nk = 1;
+ } else if (minmn == 1) {
+ nk = 2;
+ } else if (minmn <= 3) {
+ nk = 3;
+ } else {
+ nk = 4;
+ }
+
+/* Do for each value of K in KVAL */
+
+ i__3 = nk;
+ for (ik = 1; ik <= i__3; ++ik) {
+ k = kval[ik - 1];
+
+/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ nx = nxval[inb];
+ xlaenv_(&c__3, &nx);
+ for (i__ = 1; i__ <= 8; ++i__) {
+ result[i__ - 1] = 0.;
+ }
+ nt = 2;
+ if (ik == 1) {
+
+/* Test DGEQLF */
+
+ dqlt01_(&m, &n, &a[1], &af[1], &aq[1], &al[1], &
+ lda, &tau[1], &work[1], &lwork, &rwork[1],
+ result);
+ if (m >= n) {
+/* Check the lower-left n-by-n corner */
+ if (! dgennd_(&n, &n, &af[m - n + 1], &lda)) {
+ result[7] = *thresh * 2;
+ }
+ } else {
+/* Check the (n-m)th superdiagonal */
+ if (! dgennd_(&m, &m, &af[(n - m) * lda + 1],
+ &lda)) {
+ result[7] = *thresh * 2;
+ }
+ }
+ } else if (m >= n) {
+
+/* Test DORGQL, using factorization */
+/* returned by DQLT01 */
+
+ dqlt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &al[1],
+ &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], result);
+ } else {
+ result[0] = 0.;
+ result[1] = 0.;
+ }
+ if (m >= k) {
+
+/* Test DORMQL, using factorization returned */
+/* by DQLT01 */
+
+ dqlt03_(&m, &n, &k, &af[1], &ac[1], &al[1], &aq[1]
+, &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], &result[2]);
+ nt += 4;
+
+/* If M>=N and K=N, call DGEQLS to solve a system */
+/* with NRHS right hand sides and compute the */
+/* residual. */
+
+ if (k == n && inb == 1) {
+
+/* Generate a solution and set the right */
+/* hand side. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32,
+ (ftnlen)6);
+ dlarhs_(path, "New", "Full", "No transpose", &
+ m, &n, &c__0, &c__0, nrhs, &a[1], &
+ lda, &xact[1], &lda, &b[1], &lda,
+ iseed, &info);
+
+ dlacpy_("Full", &m, nrhs, &b[1], &lda, &x[1],
+ &lda);
+ s_copy(srnamc_1.srnamt, "DGEQLS", (ftnlen)32,
+ (ftnlen)6);
+ dgeqls_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
+ x[1], &lda, &work[1], &lwork, &info);
+
+/* Check error code from DGEQLS. */
+
+ if (info != 0) {
+ alaerh_(path, "DGEQLS", &info, &c__0,
+ " ", &m, &n, nrhs, &c_n1, &nb, &
+ imat, &nfail, &nerrs, nout);
+ }
+
+ dget02_("No transpose", &m, &n, nrhs, &a[1], &
+ lda, &x[m - n + 1], &lda, &b[1], &lda,
+ &rwork[1], &result[6]);
+ ++nt;
+ } else {
+ result[6] = 0.;
+ }
+ } else {
+ result[2] = 0.;
+ result[3] = 0.;
+ result[4] = 0.;
+ result[5] = 0.;
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__5 = nt;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+/* L30: */
+ }
+/* L40: */
+ }
+L50:
+ ;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DCHKQL */
+
+} /* dchkql_ */
diff --git a/TESTING/LIN/dchkqp.c b/TESTING/LIN/dchkqp.c
new file mode 100644
index 0000000..1c57c1e
--- /dev/null
+++ b/TESTING/LIN/dchkqp.c
@@ -0,0 +1,361 @@
+/* dchkqp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublereal c_b11 = 0.;
+static doublereal c_b16 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dchkqp_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, doublereal *thresh, logical *tsterr,
+ doublereal *a, doublereal *copya, doublereal *s, doublereal *copys,
+ doublereal *tau, doublereal *work, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, type"
+ " \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublereal d__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, im, in, lda;
+ doublereal eps;
+ integer mode, info;
+ char path[3];
+ integer ilow, nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer ihigh, nfail, iseed[4], imode;
+ extern doublereal dqpt01_(integer *, integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dqrt11_(integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dqrt12_(integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ integer mnmin, istep, nerrs, lwork;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *,
+ integer *), dgeqpf_(integer *, integer *, doublereal *,
+ integer *, integer *, doublereal *, doublereal *, integer *),
+ dlacpy_(char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *), dlaset_(char *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *), alasum_(char *, integer *, integer *, integer *, integer
+ *), dlatms_(integer *, integer *, char *, integer *, char
+ *, doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublereal *, integer *, doublereal *,
+ integer *), derrqp_(char *, integer *);
+ doublereal result[3];
+
+ /* Fortran I/O blocks */
+ static cilist io___24 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKQP tests DGEQPF. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX) */
+/* where MMAX is the maximum value of M in MVAL and NMAX is the */
+/* maximum value of N in NVAL. */
+
+/* COPYA (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* COPYS (workspace) DOUBLE PRECISION array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* TAU (workspace) DOUBLE PRECISION array, dimension (MMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (MMAX*NMAX + 4*NMAX + MMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --tau;
+ --copys;
+ --s;
+ --copya;
+ --a;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "QP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = dlamch_("Epsilon");
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrqp_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+
+/* Do for each value of M in MVAL. */
+
+ m = mval[im];
+ lda = max(1,m);
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__3 = 1, i__4 = m * max(m,n) + (mnmin << 2) + max(m,n), i__3 =
+ max(i__3,i__4), i__4 = m * n + (mnmin << 1) + (n << 2);
+ lwork = max(i__3,i__4);
+
+ for (imode = 1; imode <= 6; ++imode) {
+ if (! dotype[imode]) {
+ goto L60;
+ }
+
+/* Do for each type of matrix */
+/* 1: zero matrix */
+/* 2: one small singular value */
+/* 3: geometric distribution of singular values */
+/* 4: first n/2 columns fixed */
+/* 5: last n/2 columns fixed */
+/* 6: every second column fixed */
+
+ mode = imode;
+ if (imode > 3) {
+ mode = 1;
+ }
+
+/* Generate test matrix of size m by n using */
+/* singular value distribution indicated by `mode'. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ iwork[i__] = 0;
+/* L20: */
+ }
+ if (imode == 1) {
+ dlaset_("Full", &m, &n, &c_b11, &c_b11, ©a[1], &lda);
+ i__3 = mnmin;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ copys[i__] = 0.;
+/* L30: */
+ }
+ } else {
+ d__1 = 1. / eps;
+ dlatms_(&m, &n, "Uniform", iseed, "Nonsymm", ©s[1], &
+ mode, &d__1, &c_b16, &m, &n, "No packing", ©a[
+ 1], &lda, &work[1], &info);
+ if (imode >= 4) {
+ if (imode == 4) {
+ ilow = 1;
+ istep = 1;
+/* Computing MAX */
+ i__3 = 1, i__4 = n / 2;
+ ihigh = max(i__3,i__4);
+ } else if (imode == 5) {
+/* Computing MAX */
+ i__3 = 1, i__4 = n / 2;
+ ilow = max(i__3,i__4);
+ istep = 1;
+ ihigh = n;
+ } else if (imode == 6) {
+ ilow = 1;
+ istep = 2;
+ ihigh = n;
+ }
+ i__3 = ihigh;
+ i__4 = istep;
+ for (i__ = ilow; i__4 < 0 ? i__ >= i__3 : i__ <= i__3;
+ i__ += i__4) {
+ iwork[i__] = 1;
+/* L40: */
+ }
+ }
+ dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
+ }
+
+/* Save A and its singular values */
+
+ dlacpy_("All", &m, &n, ©a[1], &lda, &a[1], &lda);
+
+/* Compute the QR factorization with pivoting of A */
+
+ s_copy(srnamc_1.srnamt, "DGEQPF", (ftnlen)32, (ftnlen)6);
+ dgeqpf_(&m, &n, &a[1], &lda, &iwork[1], &tau[1], &work[1], &
+ info);
+
+/* Compute norm(svd(a) - svd(r)) */
+
+ result[0] = dqrt12_(&m, &n, &a[1], &lda, ©s[1], &work[1],
+ &lwork);
+
+/* Compute norm( A*P - Q*R ) */
+
+ result[1] = dqpt01_(&m, &n, &mnmin, ©a[1], &a[1], &lda, &
+ tau[1], &iwork[1], &work[1], &lwork);
+
+/* Compute Q'*Q */
+
+ result[2] = dqrt11_(&m, &mnmin, &a[1], &lda, &tau[1], &work[1]
+, &lwork);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 1; k <= 3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___24.ciunit = *nout;
+ s_wsfe(&io___24);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L50: */
+ }
+ nrun += 3;
+L60:
+ ;
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+
+/* End of DCHKQP */
+
+ return 0;
+} /* dchkqp_ */
diff --git a/TESTING/LIN/dchkqr.c b/TESTING/LIN/dchkqr.c
new file mode 100644
index 0000000..b40e1de
--- /dev/null
+++ b/TESTING/LIN/dchkqr.c
@@ -0,0 +1,467 @@
+/* dchkqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int dchkqr_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nxval, integer *nrhs, doublereal *thresh, logical *tsterr, integer *
+ nmax, doublereal *a, doublereal *af, doublereal *aq, doublereal *ar,
+ doublereal *ac, doublereal *b, doublereal *x, doublereal *xact,
+ doublereal *tau, doublereal *work, doublereal *rwork, integer *iwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
+ "5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
+ "t(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, ik, im, in, kl, nk, ku, nt, nx, lda, inb, mode,
+ imat, info;
+ char path[3];
+ integer kval[4];
+ char dist[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), dget02_(
+ char *, integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int dqrt01_(integer *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ doublereal anorm;
+ extern /* Subroutine */ int dqrt02_(integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *
+);
+ integer minmn;
+ extern /* Subroutine */ int dqrt03_(integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *
+);
+ integer nerrs, lwork;
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *);
+ extern logical dgennd_(integer *, integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *), alasum_(char *,
+ integer *, integer *, integer *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int dgeqrs_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *), dlatms_(integer *, integer *,
+ char *, integer *, char *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *, char *, doublereal *,
+ integer *, doublereal *, integer *),
+ xlaenv_(integer *, integer *), derrqr_(char *, integer *);
+ doublereal result[8];
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKQR tests DGEQRF, DORGQR and DORMQR. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AQ (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AR (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* TAU (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --tau;
+ --xact;
+ --x;
+ --b;
+ --ac;
+ --ar;
+ --aq;
+ --af;
+ --a;
+ --nxval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "QR", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrqr_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+ lda = *nmax;
+ lwork = *nmax * max(*nmax,*nrhs);
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Do for each value of N in NVAL. */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ minmn = min(m,n);
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L50;
+ }
+
+/* Set up parameters with DLATB4 and generate a test matrix */
+/* with DLATMS. */
+
+ dlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, " ", &m, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L50;
+ }
+
+/* Set some values for K: the first value must be MINMN, */
+/* corresponding to the call of DQRT01; other values are */
+/* used in the calls of DQRT02, and must not exceed MINMN. */
+
+ kval[0] = minmn;
+ kval[1] = 0;
+ kval[2] = 1;
+ kval[3] = minmn / 2;
+ if (minmn == 0) {
+ nk = 1;
+ } else if (minmn == 1) {
+ nk = 2;
+ } else if (minmn <= 3) {
+ nk = 3;
+ } else {
+ nk = 4;
+ }
+
+/* Do for each value of K in KVAL */
+
+ i__3 = nk;
+ for (ik = 1; ik <= i__3; ++ik) {
+ k = kval[ik - 1];
+
+/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ nx = nxval[inb];
+ xlaenv_(&c__3, &nx);
+ for (i__ = 1; i__ <= 8; ++i__) {
+ result[i__ - 1] = 0.;
+ }
+ nt = 2;
+ if (ik == 1) {
+
+/* Test DGEQRF */
+
+ dqrt01_(&m, &n, &a[1], &af[1], &aq[1], &ar[1], &
+ lda, &tau[1], &work[1], &lwork, &rwork[1],
+ result);
+ if (! dgennd_(&m, &n, &af[1], &lda)) {
+ result[7] = *thresh * 2;
+ }
+ ++nt;
+ } else if (m >= n) {
+
+/* Test DORGQR, using factorization */
+/* returned by DQRT01 */
+
+ dqrt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &ar[1],
+ &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], result);
+ }
+ if (m >= k) {
+
+/* Test DORMQR, using factorization returned */
+/* by DQRT01 */
+
+ dqrt03_(&m, &n, &k, &af[1], &ac[1], &ar[1], &aq[1]
+, &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], &result[2]);
+ nt += 4;
+
+/* If M>=N and K=N, call DGEQRS to solve a system */
+/* with NRHS right hand sides and compute the */
+/* residual. */
+
+ if (k == n && inb == 1) {
+
+/* Generate a solution and set the right */
+/* hand side. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32,
+ (ftnlen)6);
+ dlarhs_(path, "New", "Full", "No transpose", &
+ m, &n, &c__0, &c__0, nrhs, &a[1], &
+ lda, &xact[1], &lda, &b[1], &lda,
+ iseed, &info);
+
+ dlacpy_("Full", &m, nrhs, &b[1], &lda, &x[1],
+ &lda);
+ s_copy(srnamc_1.srnamt, "DGEQRS", (ftnlen)32,
+ (ftnlen)6);
+ dgeqrs_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
+ x[1], &lda, &work[1], &lwork, &info);
+
+/* Check error code from DGEQRS. */
+
+ if (info != 0) {
+ alaerh_(path, "DGEQRS", &info, &c__0,
+ " ", &m, &n, nrhs, &c_n1, &nb, &
+ imat, &nfail, &nerrs, nout);
+ }
+
+ dget02_("No transpose", &m, &n, nrhs, &a[1], &
+ lda, &x[1], &lda, &b[1], &lda, &rwork[
+ 1], &result[6]);
+ ++nt;
+ }
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__5 = nt;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+/* L30: */
+ }
+/* L40: */
+ }
+L50:
+ ;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DCHKQR */
+
+} /* dchkqr_ */
diff --git a/TESTING/LIN/dchkrfp.c b/TESTING/LIN/dchkrfp.c
new file mode 100644
index 0000000..7bc4761
--- /dev/null
+++ b/TESTING/LIN/dchkrfp.c
@@ -0,0 +1,477 @@
+/* dchkrfp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__12 = 12;
+static integer c__0 = 0;
+static integer c__50 = 50;
+static integer c__16 = 16;
+static integer c__9 = 9;
+static integer c__5 = 5;
+static integer c__8 = 8;
+static integer c__6 = 6;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Format strings */
+ static char fmt_9994[] = "(/\002 Tests of the DOUBLE PRECISION LAPACK RF"
+ "P routines \002,/\002 LAPACK VERSION \002,i1,\002.\002,i1,\002"
+ ".\002,i1,//\002 The following parameter values will be used:\002)"
+ ;
+ static char fmt_9996[] = "(\002 !! Invalid input value: \002,a4,\002="
+ "\002,i6,\002; must be >=\002,i6)";
+ static char fmt_9995[] = "(\002 !! Invalid input value: \002,a4,\002="
+ "\002,i6,\002; must be <=\002,i6)";
+ static char fmt_9993[] = "(4x,a4,\002: \002,10i6,/11x,10i6)";
+ static char fmt_9992[] = "(/\002 Routines pass computational tests if te"
+ "st ratio is \002,\002less than\002,f8.2,/)";
+ static char fmt_9999[] = "(/\002 Execution not attempted due to input er"
+ "rors\002)";
+ static char fmt_9991[] = "(\002 Relative machine \002,a,\002 is taken to"
+ " be\002,d16.6)";
+ static char fmt_9998[] = "(/\002 End of tests\002)";
+ static char fmt_9997[] = "(\002 Total time used = \002,f12.2,\002 seco"
+ "nds\002,/)";
+
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+ cllist cl__1;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), e_rsle(void), s_wsfe(cilist *), do_fio(integer *
+ , char *, ftnlen), e_wsfe(void), do_lio(integer *, integer *,
+ char *, ftnlen);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), f_clos(cllist *);
+
+ /* Local variables */
+ doublereal workafac[2500] /* was [50][50] */, workasav[2500] /*
+ was [50][50] */, workbsav[800] /* was [50][16] */, workainv[
+ 2500] /* was [50][50] */, workxact[800] /* was [50][
+ 16] */;
+ integer i__;
+ doublereal s1, s2;
+ integer nn, vers_patch__, vers_major__, vers_minor__;
+ doublereal workarfinv[1275], eps;
+ integer nns, nnt, nval[12];
+ doublereal d_temp_dpot02__[800] /* was [50][16] */, d_temp_dpot03__[
+ 2500] /* was [50][50] */, d_work_dpot01__[50],
+ d_work_dpot02__[50], d_work_dpot03__[50];
+ logical fatal;
+ integer nsval[12], ntval[9];
+ doublereal worka[2500] /* was [50][50] */, workb[800] /* was [50][
+ 16] */, workx[800] /* was [50][16] */, d_work_dlatms__[150],
+ d_work_dlansy__[50];
+ extern doublereal dlamch_(char *), dsecnd_(void);
+ extern /* Subroutine */ int ilaver_(integer *, integer *, integer *);
+ doublereal thresh, workap[1275];
+ logical tsterr;
+ extern /* Subroutine */ int ddrvrf1_(integer *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *)
+ , ddrvrf2_(integer *, integer *, integer *, doublereal *, integer
+ *, doublereal *, doublereal *, doublereal *), ddrvrf3_(integer *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *), ddrvrf4_(integer *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *), derrrfp_(
+ integer *), ddrvrfp_(integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *);
+ doublereal workarf[1275];
+
+ /* Fortran I/O blocks */
+ static cilist io___3 = { 0, 5, 0, 0, 0 };
+ static cilist io___7 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___8 = { 0, 5, 0, 0, 0 };
+ static cilist io___10 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___11 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___12 = { 0, 5, 0, 0, 0 };
+ static cilist io___15 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___16 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___17 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___18 = { 0, 5, 0, 0, 0 };
+ static cilist io___20 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___21 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___22 = { 0, 5, 0, 0, 0 };
+ static cilist io___24 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___25 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___26 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___27 = { 0, 5, 0, 0, 0 };
+ static cilist io___29 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___30 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___31 = { 0, 5, 0, 0, 0 };
+ static cilist io___33 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___34 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___35 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___36 = { 0, 5, 0, 0, 0 };
+ static cilist io___38 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___39 = { 0, 5, 0, 0, 0 };
+ static cilist io___41 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___45 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___46 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___47 = { 0, 6, 0, 0, 0 };
+ static cilist io___67 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___68 = { 0, 6, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKRFP is the main test program for the DOUBLE PRECISION linear */
+/* equation routines with RFP storage format */
+
+
+/* Internal Parameters */
+/* =================== */
+
+/* MAXIN INTEGER */
+/* The number of different values that can be used for each of */
+/* M, N, or NB */
+
+/* MAXRHS INTEGER */
+/* The maximum number of right hand sides */
+
+/* NTYPES INTEGER */
+
+/* NMAX INTEGER */
+/* The maximum allowable value for N. */
+
+/* NIN INTEGER */
+/* The unit number for input */
+
+/* NOUT INTEGER */
+/* The unit number for output */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ s1 = dsecnd_();
+ fatal = FALSE_;
+
+/* Read a dummy line. */
+
+ s_rsle(&io___3);
+ e_rsle();
+
+/* Report LAPACK version tag (e.g. LAPACK-3.2.0) */
+
+ ilaver_(&vers_major__, &vers_minor__, &vers_patch__);
+ s_wsfe(&io___7);
+ do_fio(&c__1, (char *)&vers_major__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_minor__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_patch__, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+/* Read the values of N */
+
+ s_rsle(&io___8);
+ do_lio(&c__3, &c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nn < 1) {
+ s_wsfe(&io___10);
+ do_fio(&c__1, " NN ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ } else if (nn > 12) {
+ s_wsfe(&io___11);
+ do_fio(&c__1, " NN ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___12);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nval[i__ - 1] < 0) {
+ s_wsfe(&io___15);
+ do_fio(&c__1, " M ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nval[i__ - 1] > 50) {
+ s_wsfe(&io___16);
+ do_fio(&c__1, " M ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__50, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L10: */
+ }
+ if (nn > 0) {
+ s_wsfe(&io___17);
+ do_fio(&c__1, "N ", (ftnlen)4);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of NRHS */
+
+ s_rsle(&io___18);
+ do_lio(&c__3, &c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nns < 1) {
+ s_wsfe(&io___20);
+ do_fio(&c__1, " NNS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nns = 0;
+ fatal = TRUE_;
+ } else if (nns > 12) {
+ s_wsfe(&io___21);
+ do_fio(&c__1, " NNS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nns = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___22);
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nsval[i__ - 1] < 0) {
+ s_wsfe(&io___24);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nsval[i__ - 1] > 16) {
+ s_wsfe(&io___25);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__16, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L30: */
+ }
+ if (nns > 0) {
+ s_wsfe(&io___26);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the matrix types */
+
+ s_rsle(&io___27);
+ do_lio(&c__3, &c__1, (char *)&nnt, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nnt < 1) {
+ s_wsfe(&io___29);
+ do_fio(&c__1, " NMA", (ftnlen)4);
+ do_fio(&c__1, (char *)&nnt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nnt = 0;
+ fatal = TRUE_;
+ } else if (nnt > 9) {
+ s_wsfe(&io___30);
+ do_fio(&c__1, " NMA", (ftnlen)4);
+ do_fio(&c__1, (char *)&nnt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nnt = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___31);
+ i__1 = nnt;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = nnt;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (ntval[i__ - 1] < 0) {
+ s_wsfe(&io___33);
+ do_fio(&c__1, "TYPE", (ftnlen)4);
+ do_fio(&c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (ntval[i__ - 1] > 9) {
+ s_wsfe(&io___34);
+ do_fio(&c__1, "TYPE", (ftnlen)4);
+ do_fio(&c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L320: */
+ }
+ if (nnt > 0) {
+ s_wsfe(&io___35);
+ do_fio(&c__1, "TYPE", (ftnlen)4);
+ i__1 = nnt;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the threshold value for the test ratios. */
+
+ s_rsle(&io___36);
+ do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_rsle();
+ s_wsfe(&io___38);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+/* Read the flag that indicates whether to test the error exits. */
+
+ s_rsle(&io___39);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+
+ if (fatal) {
+ s_wsfe(&io___41);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+ if (fatal) {
+ s_wsfe(&io___42);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Calculate and print the machine dependent constants. */
+
+ eps = dlamch_("Underflow threshold");
+ s_wsfe(&io___44);
+ do_fio(&c__1, "underflow", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ eps = dlamch_("Overflow threshold");
+ s_wsfe(&io___45);
+ do_fio(&c__1, "overflow ", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ eps = dlamch_("Epsilon");
+ s_wsfe(&io___46);
+ do_fio(&c__1, "precision", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_wsle(&io___47);
+ e_wsle();
+
+/* Test the error exit of: */
+
+ if (tsterr) {
+ derrrfp_(&c__6);
+ }
+
+/* Test the routines: dpftrf, dpftri, dpftrs (as in DDRVPO). */
+/* This also tests the routines: dtfsm, dtftri, dtfttr, dtrttf. */
+
+ ddrvrfp_(&c__6, &nn, nval, &nns, nsval, &nnt, ntval, &thresh, worka,
+ workasav, workafac, workainv, workb, workbsav, workxact, workx,
+ workarf, workarfinv, d_work_dlatms__, d_work_dpot01__,
+ d_temp_dpot02__, d_temp_dpot03__, d_work_dlansy__,
+ d_work_dpot02__, d_work_dpot03__);
+
+/* Test the routine: dlansf */
+
+ ddrvrf1_(&c__6, &nn, nval, &thresh, worka, &c__50, workarf,
+ d_work_dlansy__);
+
+/* Test the convertion routines: */
+/* dtfttp, dtpttf, dtfttr, dtrttf, dtrttp and dtpttr. */
+
+ ddrvrf2_(&c__6, &nn, nval, worka, &c__50, workarf, workap, workasav);
+
+/* Test the routine: dtfsm */
+
+ ddrvrf3_(&c__6, &nn, nval, &thresh, worka, &c__50, workarf, workainv,
+ workafac, d_work_dlansy__, d_work_dpot03__, d_work_dpot01__);
+
+
+/* Test the routine: dsfrk */
+
+ ddrvrf4_(&c__6, &nn, nval, &thresh, worka, workafac, &c__50, workarf,
+ workainv, &c__50, d_work_dlansy__);
+
+ cl__1.cerr = 0;
+ cl__1.cunit = 5;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ s2 = dsecnd_();
+ s_wsfe(&io___67);
+ e_wsfe();
+ s_wsfe(&io___68);
+ d__1 = s2 - s1;
+ do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+
+/* End of DCHKRFP */
+
+ return 0;
+} /* MAIN__ */
+
+/* Main program alias */ int dchkrfp_ () { MAIN__ (); return 0; }
diff --git a/TESTING/LIN/dchkrq.c b/TESTING/LIN/dchkrq.c
new file mode 100644
index 0000000..2a31c6a
--- /dev/null
+++ b/TESTING/LIN/dchkrq.c
@@ -0,0 +1,486 @@
+/* dchkrq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int dchkrq_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nxval, integer *nrhs, doublereal *thresh, logical *tsterr, integer *
+ nmax, doublereal *a, doublereal *af, doublereal *aq, doublereal *ar,
+ doublereal *ac, doublereal *b, doublereal *x, doublereal *xact,
+ doublereal *tau, doublereal *work, doublereal *rwork, integer *iwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
+ "5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
+ "t(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, ik, im, in, kl, nk, ku, nt, nx, lda, inb, mode,
+ imat, info;
+ char path[3];
+ integer kval[4];
+ char dist[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), dget02_(
+ char *, integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int drqt01_(integer *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ doublereal anorm;
+ extern /* Subroutine */ int drqt02_(integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *
+);
+ integer minmn;
+ extern /* Subroutine */ int drqt03_(integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *
+);
+ integer nerrs, lwork;
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *);
+ extern logical dgennd_(integer *, integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *), alasum_(char *,
+ integer *, integer *, integer *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int dgerqs_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *), dlatms_(integer *, integer *,
+ char *, integer *, char *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *, char *, doublereal *,
+ integer *, doublereal *, integer *),
+ xlaenv_(integer *, integer *), derrrq_(char *, integer *);
+ doublereal result[8];
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKRQ tests DGERQF, DORGRQ and DORMRQ. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AQ (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AR (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* TAU (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --tau;
+ --xact;
+ --x;
+ --b;
+ --ac;
+ --ar;
+ --aq;
+ --af;
+ --a;
+ --nxval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "RQ", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrrq_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+ lda = *nmax;
+ lwork = *nmax * max(*nmax,*nrhs);
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Do for each value of N in NVAL. */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ minmn = min(m,n);
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L50;
+ }
+
+/* Set up parameters with DLATB4 and generate a test matrix */
+/* with DLATMS. */
+
+ dlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, " ", &m, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L50;
+ }
+
+/* Set some values for K: the first value must be MINMN, */
+/* corresponding to the call of DRQT01; other values are */
+/* used in the calls of DRQT02, and must not exceed MINMN. */
+
+ kval[0] = minmn;
+ kval[1] = 0;
+ kval[2] = 1;
+ kval[3] = minmn / 2;
+ if (minmn == 0) {
+ nk = 1;
+ } else if (minmn == 1) {
+ nk = 2;
+ } else if (minmn <= 3) {
+ nk = 3;
+ } else {
+ nk = 4;
+ }
+
+/* Do for each value of K in KVAL */
+
+ i__3 = nk;
+ for (ik = 1; ik <= i__3; ++ik) {
+ k = kval[ik - 1];
+
+/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ nx = nxval[inb];
+ xlaenv_(&c__3, &nx);
+ for (i__ = 1; i__ <= 8; ++i__) {
+ result[i__ - 1] = 0.;
+ }
+ nt = 2;
+ if (ik == 1) {
+
+/* Test DGERQF */
+
+ drqt01_(&m, &n, &a[1], &af[1], &aq[1], &ar[1], &
+ lda, &tau[1], &work[1], &lwork, &rwork[1],
+ result);
+ if (m <= n) {
+/* Check the upper-right m-by-m corner */
+ if (! dgennd_(&m, &m, &af[lda * (n - m) + 1],
+ &lda)) {
+ result[7] = *thresh * 2;
+ }
+ } else {
+/* Check the (m-n)th subdiagonal */
+ i__ = m - n;
+ if (! dgennd_(&n, &n, &af[i__ + 1], &lda)) {
+ result[7] = *thresh * 2;
+ }
+ }
+ } else if (m <= n) {
+
+/* Test DORGRQ, using factorization */
+/* returned by DRQT01 */
+
+ drqt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &ar[1],
+ &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], result);
+ } else {
+ result[0] = 0.;
+ result[1] = 0.;
+ }
+ if (m >= k) {
+
+/* Test DORMRQ, using factorization returned */
+/* by DRQT01 */
+
+ drqt03_(&m, &n, &k, &af[1], &ac[1], &ar[1], &aq[1]
+, &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], &result[2]);
+ nt += 4;
+
+/* If M>=N and K=N, call DGERQS to solve a system */
+/* with NRHS right hand sides and compute the */
+/* residual. */
+
+ if (k == m && inb == 1) {
+
+/* Generate a solution and set the right */
+/* hand side. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32,
+ (ftnlen)6);
+ dlarhs_(path, "New", "Full", "No transpose", &
+ m, &n, &c__0, &c__0, nrhs, &a[1], &
+ lda, &xact[1], &lda, &b[1], &lda,
+ iseed, &info);
+
+ dlacpy_("Full", &m, nrhs, &b[1], &lda, &x[n -
+ m + 1], &lda);
+ s_copy(srnamc_1.srnamt, "DGERQS", (ftnlen)32,
+ (ftnlen)6);
+ dgerqs_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
+ x[1], &lda, &work[1], &lwork, &info);
+
+/* Check error code from DGERQS. */
+
+ if (info != 0) {
+ alaerh_(path, "DGERQS", &info, &c__0,
+ " ", &m, &n, nrhs, &c_n1, &nb, &
+ imat, &nfail, &nerrs, nout);
+ }
+
+ dget02_("No transpose", &m, &n, nrhs, &a[1], &
+ lda, &x[1], &lda, &b[1], &lda, &rwork[
+ 1], &result[6]);
+ ++nt;
+ } else {
+ result[6] = 0.;
+ }
+ } else {
+ result[2] = 0.;
+ result[3] = 0.;
+ result[4] = 0.;
+ result[5] = 0.;
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__5 = nt;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+/* L30: */
+ }
+/* L40: */
+ }
+L50:
+ ;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DCHKRQ */
+
+} /* dchkrq_ */
diff --git a/TESTING/LIN/dchksp.c b/TESTING/LIN/dchksp.c
new file mode 100644
index 0000000..c0cd75e
--- /dev/null
+++ b/TESTING/LIN/dchksp.c
@@ -0,0 +1,641 @@
+/* dchksp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__8 = 8;
+
+/* Subroutine */ int dchksp_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, doublereal *thresh, logical *tsterr,
+ integer *nmax, doublereal *a, doublereal *afac, doublereal *ainv,
+ doublereal *b, doublereal *x, doublereal *xact, doublereal *work,
+ doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
+ "12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, in, kl, ku, nt, lda, npp, ioff, mode, imat,
+ info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), dget04_(
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ extern logical lsame_(char *, char *);
+ doublereal rcond;
+ integer nimat;
+ extern /* Subroutine */ int dppt02_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *), dppt03_(char *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *), dspt01_(char *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *);
+ doublereal anorm;
+ extern /* Subroutine */ int dppt05_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *), dcopy_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer iuplo, izero, nerrs;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *);
+ doublereal rcondc;
+ char packit[1];
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *);
+ extern doublereal dlansp_(char *, char *, integer *, doublereal *,
+ doublereal *);
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublereal *, integer *, doublereal
+ *, integer *), dspcon_(char *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *);
+ logical trfcon;
+ extern /* Subroutine */ int dsprfs_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *), dsptrf_(char *, integer *,
+ doublereal *, integer *, integer *), dsptri_(char *,
+ integer *, doublereal *, integer *, doublereal *, integer *), derrsy_(char *, integer *);
+ doublereal result[8];
+ extern /* Subroutine */ int dsptrs_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___38 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKSP tests DSPTRF, -TRI, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AFAC (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AINV (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(2,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, */
+/* dimension (NMAX+2*NSMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "SP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrsy_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 10;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ izero = 0;
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L160;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L160;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ if (lsame_(uplo, "U")) {
+ *(unsigned char *)packit = 'C';
+ } else {
+ *(unsigned char *)packit = 'R';
+ }
+
+/* Set up parameters with DLATB4 and generate a test matrix */
+/* with DLATMS. */
+
+ dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
+ 1], &info);
+
+/* Check error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L150;
+ }
+
+/* For types 3-6, zero one or more rows and columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * izero / 2;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff] = 0.;
+ ioff += i__;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff] = 0.;
+ ioff = ioff + n - i__;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ ioff = 0;
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ a[ioff + i__] = 0.;
+/* L60: */
+ }
+ ioff += j;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ a[ioff + i__] = 0.;
+/* L80: */
+ }
+ ioff = ioff + n - j;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Compute the L*D*L' or U*D*U' factorization of the matrix. */
+
+ npp = n * (n + 1) / 2;
+ dcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ s_copy(srnamc_1.srnamt, "DSPTRF", (ftnlen)32, (ftnlen)6);
+ dsptrf_(uplo, &n, &afac[1], &iwork[1], &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from DSPTRF. */
+
+ if (info != k) {
+ alaerh_(path, "DSPTRF", &info, &k, uplo, &n, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+ if (info != 0) {
+ trfcon = TRUE_;
+ } else {
+ trfcon = FALSE_;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ dspt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &ainv[1], &lda,
+ &rwork[1], result);
+ nt = 1;
+
+/* + TEST 2 */
+/* Form the inverse and compute the residual. */
+
+ if (! trfcon) {
+ dcopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
+ s_copy(srnamc_1.srnamt, "DSPTRI", (ftnlen)32, (ftnlen)6);
+ dsptri_(uplo, &n, &ainv[1], &iwork[1], &work[1], &info);
+
+/* Check error code from DSPTRI. */
+
+ if (info != 0) {
+ alaerh_(path, "DSPTRI", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ dppt03_(uplo, &n, &a[1], &ainv[1], &work[1], &lda, &rwork[
+ 1], &rcondc, &result[1]);
+ nt = 2;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+
+/* Do only the condition estimate if INFO is not 0. */
+
+ if (trfcon) {
+ rcondc = 0.;
+ goto L140;
+ }
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)6);
+ dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &nrhs, &
+ a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
+ info);
+ dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "DSPTRS", (ftnlen)32, (ftnlen)6);
+ dsptrs_(uplo, &n, &nrhs, &afac[1], &iwork[1], &x[1], &lda,
+ &info);
+
+/* Check error code from DSPTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "DSPTRS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
+ dppt02_(uplo, &n, &nrhs, &a[1], &x[1], &lda, &work[1], &
+ lda, &rwork[1], &result[2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "DSPRFS", (ftnlen)32, (ftnlen)6);
+ dsprfs_(uplo, &n, &nrhs, &a[1], &afac[1], &iwork[1], &b[1]
+, &lda, &x[1], &lda, &rwork[1], &rwork[nrhs + 1],
+ &work[1], &iwork[n + 1], &info);
+
+/* Check error code from DSPRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "DSPRFS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[4]);
+ dppt05_(uplo, &n, &nrhs, &a[1], &b[1], &lda, &x[1], &lda,
+ &xact[1], &lda, &rwork[1], &rwork[nrhs + 1], &
+ result[5]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L120: */
+ }
+ nrun += 5;
+/* L130: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+L140:
+ anorm = dlansp_("1", uplo, &n, &a[1], &rwork[1]);
+ s_copy(srnamc_1.srnamt, "DSPCON", (ftnlen)32, (ftnlen)6);
+ dspcon_(uplo, &n, &afac[1], &iwork[1], &anorm, &rcond, &work[
+ 1], &iwork[n + 1], &info);
+
+/* Check error code from DSPCON. */
+
+ if (info != 0) {
+ alaerh_(path, "DSPCON", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+ result[7] = dget06_(&rcond, &rcondc);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___43.ciunit = *nout;
+ s_wsfe(&io___43);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L150:
+ ;
+ }
+L160:
+ ;
+ }
+/* L170: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DCHKSP */
+
+} /* dchksp_ */
diff --git a/TESTING/LIN/dchksy.c b/TESTING/LIN/dchksy.c
new file mode 100644
index 0000000..f3eb42b
--- /dev/null
+++ b/TESTING/LIN/dchksy.c
@@ -0,0 +1,679 @@
+/* dchksy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__8 = 8;
+
+/* Subroutine */ int dchksy_(logical *dotype, integer *nn, integer *nval,
+ integer *nnb, integer *nbval, integer *nns, integer *nsval,
+ doublereal *thresh, logical *tsterr, integer *nmax, doublereal *a,
+ doublereal *afac, doublereal *ainv, doublereal *b, doublereal *x,
+ doublereal *xact, doublereal *work, doublereal *rwork, integer *iwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
+ "=\002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
+ "12.5)";
+ static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002"
+ ",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
+ ;
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, nb, in, kl, ku, nt, lda, inb, ioff, mode,
+ imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), dget04_(
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ doublereal rcond;
+ integer nimat;
+ extern /* Subroutine */ int dpot02_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *), dpot03_(char *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *), dpot05_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *);
+ doublereal anorm;
+ extern /* Subroutine */ int dsyt01_(char *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *);
+ integer iuplo, izero, nerrs, lwork;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *);
+ doublereal rcondc;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *), alasum_(char *,
+ integer *, integer *, integer *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublereal *, integer *, doublereal
+ *, integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ logical trfcon;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), dsycon_(char *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *),
+ derrsy_(char *, integer *), dsyrfs_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *), dsytrf_(char *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, integer *);
+ doublereal result[8];
+ extern /* Subroutine */ int dsytri_(char *, integer *, doublereal *,
+ integer *, integer *, doublereal *, integer *), dsytrs_(
+ char *, integer *, integer *, doublereal *, integer *, integer *,
+ doublereal *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKSY tests DSYTRF, -TRI, -TRS, -RFS, and -CON. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "SY", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrsy_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 10;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ izero = 0;
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L170;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L170;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Set up parameters with DLATB4 and generate a test matrix */
+/* with DLATMS. */
+
+ dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
+ &info);
+
+/* Check error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L160;
+ }
+
+/* For types 3-6, zero one or more rows and columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * lda;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff] = 0.;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff] = 0.;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ ioff = 0;
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ a[ioff + i__] = 0.;
+/* L60: */
+ }
+ ioff += lda;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ a[ioff + i__] = 0.;
+/* L80: */
+ }
+ ioff += lda;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Do for each value of NB in NBVAL */
+
+ i__3 = *nnb;
+ for (inb = 1; inb <= i__3; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the L*D*L' or U*D*U' factorization of the */
+/* matrix. */
+
+ dlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ lwork = max(2,nb) * lda;
+ s_copy(srnamc_1.srnamt, "DSYTRF", (ftnlen)32, (ftnlen)6);
+ dsytrf_(uplo, &n, &afac[1], &lda, &iwork[1], &ainv[1], &
+ lwork, &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from DSYTRF. */
+
+ if (info != k) {
+ alaerh_(path, "DSYTRF", &info, &k, uplo, &n, &n, &
+ c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
+ }
+ if (info != 0) {
+ trfcon = TRUE_;
+ } else {
+ trfcon = FALSE_;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ dsyt01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &iwork[1],
+ &ainv[1], &lda, &rwork[1], result);
+ nt = 1;
+
+/* + TEST 2 */
+/* Form the inverse and compute the residual. */
+
+ if (inb == 1 && ! trfcon) {
+ dlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
+ s_copy(srnamc_1.srnamt, "DSYTRI", (ftnlen)32, (ftnlen)
+ 6);
+ dsytri_(uplo, &n, &ainv[1], &lda, &iwork[1], &work[1],
+ &info);
+
+/* Check error code from DSYTRI. */
+
+ if (info != 0) {
+ alaerh_(path, "DSYTRI", &info, &c_n1, uplo, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ dpot03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &work[
+ 1], &lda, &rwork[1], &rcondc, &result[1]);
+ nt = 2;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+
+/* Skip the other tests if this is not the first block */
+/* size. */
+
+ if (inb > 1) {
+ goto L150;
+ }
+
+/* Do only the condition estimate if INFO is not 0. */
+
+ if (trfcon) {
+ rcondc = 0.;
+ goto L140;
+ }
+
+ i__4 = *nns;
+ for (irhs = 1; irhs <= i__4; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "DSYTRS", (ftnlen)32, (ftnlen)
+ 6);
+ dsytrs_(uplo, &n, &nrhs, &afac[1], &lda, &iwork[1], &
+ x[1], &lda, &info);
+
+/* Check error code from DSYTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "DSYTRS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &
+ lda);
+ dpot02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
+ work[1], &lda, &rwork[1], &result[2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "DSYRFS", (ftnlen)32, (ftnlen)
+ 6);
+ dsyrfs_(uplo, &n, &nrhs, &a[1], &lda, &afac[1], &lda,
+ &iwork[1], &b[1], &lda, &x[1], &lda, &rwork[1]
+, &rwork[nrhs + 1], &work[1], &iwork[n + 1], &
+ info);
+
+/* Check error code from DSYRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "DSYRFS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[4]);
+ dpot05_(uplo, &n, &nrhs, &a[1], &lda, &b[1], &lda, &x[
+ 1], &lda, &xact[1], &lda, &rwork[1], &rwork[
+ nrhs + 1], &result[5]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L120: */
+ }
+ nrun += 5;
+/* L130: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+L140:
+ anorm = dlansy_("1", uplo, &n, &a[1], &lda, &rwork[1]);
+ s_copy(srnamc_1.srnamt, "DSYCON", (ftnlen)32, (ftnlen)6);
+ dsycon_(uplo, &n, &afac[1], &lda, &iwork[1], &anorm, &
+ rcond, &work[1], &iwork[n + 1], &info);
+
+/* Check error code from DSYCON. */
+
+ if (info != 0) {
+ alaerh_(path, "DSYCON", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ result[7] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L150:
+ ;
+ }
+
+L160:
+ ;
+ }
+L170:
+ ;
+ }
+/* L180: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DCHKSY */
+
+} /* dchksy_ */
diff --git a/TESTING/LIN/dchktb.c b/TESTING/LIN/dchktb.c
new file mode 100644
index 0000000..91732ed
--- /dev/null
+++ b/TESTING/LIN/dchktb.c
@@ -0,0 +1,741 @@
+/* dchktb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublereal c_b14 = 0.;
+static doublereal c_b15 = 1.;
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c__3 = 3;
+static integer c_n1 = -1;
+static integer c__6 = 6;
+static integer c__4 = 4;
+static integer c__7 = 7;
+static integer c__8 = 8;
+
+/* Subroutine */ int dchktb_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, doublereal *thresh, logical *tsterr,
+ integer *nmax, doublereal *ab, doublereal *ainv, doublereal *b,
+ doublereal *x, doublereal *xact, doublereal *work, doublereal *rwork,
+ integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', TRANS='\002,a1,\002"
+ "', DIAG='\002,a1,\002', N=\002,i5,\002, K"
+ "D=\002,i5,\002, NRHS=\002,i5,\002, type \002,i2,\002, test(\002,"
+ "i2,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
+ "'\002,a1,\002',\002,i5,\002,\002,i5,\002, ... ), type \002,i2"
+ ",\002, test(\002,i2,\002)=\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
+ "'\002,a1,\002', '\002,a1,\002',\002,i5,\002,\002,i5,\002, ... )"
+ ", type \002,i2,\002, test(\002,i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[3], a__2[4];
+ integer i__1, i__2, i__3, i__4, i__5, i__6[3], i__7[4];
+ char ch__1[3], ch__2[4];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
+ char **, integer *, integer *, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n, kd, ik, in, nk, lda, ldab;
+ char diag[1];
+ integer imat, info;
+ char path[3];
+ integer irhs, nrhs;
+ char norm[1], uplo[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer idiag;
+ doublereal scale;
+ extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int dtbt02_(char *, char *, char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *), dtbt03_(char *, char *, char *, integer *
+, integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dtbt05_(char *, char *, char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *),
+ dtbt06_(doublereal *, doublereal *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *);
+ doublereal rcond;
+ integer nimat;
+ doublereal anorm;
+ integer itran;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dtbsv_(char *, char *, char *, integer *
+, integer *, doublereal *, integer *, doublereal *, integer *);
+ char trans[1];
+ integer iuplo, nerrs;
+ char xtype[1];
+ integer nimat2;
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ extern doublereal dlantb_(char *, char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *);
+ doublereal rcondc;
+ extern /* Subroutine */ int dlatbs_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *), dlattb_(integer *, char *, char *, char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *), dtbcon_(char *,
+ char *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *), dlacpy_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *), dlarhs_(char *, char
+ *, char *, char *, integer *, integer *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, integer *, integer *);
+ doublereal rcondi;
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ alasum_(char *, integer *, integer *, integer *, integer *);
+ doublereal rcondo;
+ extern doublereal dlantr_(char *, char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dtbrfs_(char *, char *, char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int derrtr_(char *, integer *), dtbtrs_(
+ char *, char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+ doublereal result[8];
+
+ /* Fortran I/O blocks */
+ static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKTB tests DTBTRS, -RFS, and -CON, and DLATBS. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The leading dimension of the work arrays. */
+/* NMAX >= the maximum value of N in NVAL. */
+
+/* AB (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --ab;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "TB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrtr_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL */
+
+ n = nval[in];
+ lda = max(1,n);
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ nimat2 = 17;
+ if (n <= 0) {
+ nimat = 1;
+ nimat2 = 10;
+ }
+
+/* Computing MIN */
+ i__2 = n + 1;
+ nk = min(i__2,4);
+ i__2 = nk;
+ for (ik = 1; ik <= i__2; ++ik) {
+
+/* Do for KD = 0, N, (3N-1)/4, and (N+1)/4. This order makes */
+/* it easier to skip redundant values for small values of N. */
+
+ if (ik == 1) {
+ kd = 0;
+ } else if (ik == 2) {
+ kd = max(n,0);
+ } else if (ik == 3) {
+ kd = (n * 3 - 1) / 4;
+ } else if (ik == 4) {
+ kd = (n + 1) / 4;
+ }
+ ldab = kd + 1;
+
+ i__3 = nimat;
+ for (imat = 1; imat <= i__3; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L90;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+
+/* Call DLATTB to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "DLATTB", (ftnlen)32, (ftnlen)6);
+ dlattb_(&imat, uplo, "No transpose", diag, iseed, &n, &kd,
+ &ab[1], &ldab, &x[1], &work[1], &info);
+
+/* Set IDIAG = 1 for non-unit matrices, 2 for unit. */
+
+ if (lsame_(diag, "N")) {
+ idiag = 1;
+ } else {
+ idiag = 2;
+ }
+
+/* Form the inverse of A so we can get a good estimate */
+/* of RCONDC = 1/(norm(A) * norm(inv(A))). */
+
+ dlaset_("Full", &n, &n, &c_b14, &c_b15, &ainv[1], &lda);
+ if (lsame_(uplo, "U")) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ dtbsv_(uplo, "No transpose", diag, &j, &kd, &ab[1]
+, &ldab, &ainv[(j - 1) * lda + 1], &c__1);
+/* L20: */
+ }
+ } else {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__5 = n - j + 1;
+ dtbsv_(uplo, "No transpose", diag, &i__5, &kd, &
+ ab[(j - 1) * ldab + 1], &ldab, &ainv[(j -
+ 1) * lda + j], &c__1);
+/* L30: */
+ }
+ }
+
+/* Compute the 1-norm condition number of A. */
+
+ anorm = dlantb_("1", uplo, diag, &n, &kd, &ab[1], &ldab, &
+ rwork[1]);
+ ainvnm = dlantr_("1", uplo, diag, &n, &n, &ainv[1], &lda,
+ &rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondo = 1.;
+ } else {
+ rcondo = 1. / anorm / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ anorm = dlantb_("I", uplo, diag, &n, &kd, &ab[1], &ldab, &
+ rwork[1]);
+ ainvnm = dlantr_("I", uplo, diag, &n, &n, &ainv[1], &lda,
+ &rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondi = 1.;
+ } else {
+ rcondi = 1. / anorm / ainvnm;
+ }
+
+ i__4 = *nns;
+ for (irhs = 1; irhs <= i__4; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, or A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itran - 1];
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+
+/* + TEST 1 */
+/* Solve and compute residual for op(A)*x = b. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (
+ ftnlen)6);
+ dlarhs_(path, xtype, uplo, trans, &n, &n, &kd, &
+ idiag, &nrhs, &ab[1], &ldab, &xact[1], &
+ lda, &b[1], &lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "DTBTRS", (ftnlen)32, (
+ ftnlen)6);
+ dtbtrs_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1],
+ &ldab, &x[1], &lda, &info);
+
+/* Check error code from DTBTRS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__6[0] = 1, a__1[0] = uplo;
+ i__6[1] = 1, a__1[1] = trans;
+ i__6[2] = 1, a__1[2] = diag;
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)3);
+ alaerh_(path, "DTBTRS", &info, &c__0, ch__1, &
+ n, &n, &kd, &kd, &nrhs, &imat, &nfail,
+ &nerrs, nout);
+ }
+
+ dtbt02_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1],
+ &ldab, &x[1], &lda, &b[1], &lda, &work[1]
+, result)
+ ;
+
+/* + TEST 2 */
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[1]);
+
+/* + TESTS 3, 4, and 5 */
+/* Use iterative refinement to improve the solution */
+/* and compute error bounds. */
+
+ s_copy(srnamc_1.srnamt, "DTBRFS", (ftnlen)32, (
+ ftnlen)6);
+ dtbrfs_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1],
+ &ldab, &b[1], &lda, &x[1], &lda, &rwork[
+ 1], &rwork[nrhs + 1], &work[1], &iwork[1],
+ &info);
+
+/* Check error code from DTBRFS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__6[0] = 1, a__1[0] = uplo;
+ i__6[1] = 1, a__1[1] = trans;
+ i__6[2] = 1, a__1[2] = diag;
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)3);
+ alaerh_(path, "DTBRFS", &info, &c__0, ch__1, &
+ n, &n, &kd, &kd, &nrhs, &imat, &nfail,
+ &nerrs, nout);
+ }
+
+ dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ dtbt05_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1],
+ &ldab, &b[1], &lda, &x[1], &lda, &xact[1]
+, &lda, &rwork[1], &rwork[nrhs + 1], &
+ result[3]);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 1; k <= 5; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L40: */
+ }
+ nrun += 5;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* + TEST 6 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+ s_copy(srnamc_1.srnamt, "DTBCON", (ftnlen)32, (ftnlen)
+ 6);
+ dtbcon_(norm, uplo, diag, &n, &kd, &ab[1], &ldab, &
+ rcond, &work[1], &iwork[1], &info);
+
+/* Check error code from DTBCON. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__6[0] = 1, a__1[0] = norm;
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = diag;
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)3);
+ alaerh_(path, "DTBCON", &info, &c__0, ch__1, &n, &
+ n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ dtbt06_(&rcond, &rcondc, uplo, diag, &n, &kd, &ab[1],
+ &ldab, &rwork[1], &result[5]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "DTBCON", (ftnlen)6);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L70: */
+ }
+/* L80: */
+ }
+L90:
+ ;
+ }
+
+/* Use pathological test matrices to test DLATBS. */
+
+ i__3 = nimat2;
+ for (imat = 10; imat <= i__3; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, and A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[
+ itran - 1];
+
+/* Call DLATTB to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "DLATTB", (ftnlen)32, (ftnlen)
+ 6);
+ dlattb_(&imat, uplo, trans, diag, iseed, &n, &kd, &ab[
+ 1], &ldab, &x[1], &work[1], &info);
+
+/* + TEST 7 */
+/* Solve the system op(A)*x = b */
+
+ s_copy(srnamc_1.srnamt, "DLATBS", (ftnlen)32, (ftnlen)
+ 6);
+ dcopy_(&n, &x[1], &c__1, &b[1], &c__1);
+ dlatbs_(uplo, trans, diag, "N", &n, &kd, &ab[1], &
+ ldab, &b[1], &scale, &rwork[1], &info);
+
+/* Check error code from DLATBS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__7[0] = 1, a__2[0] = uplo;
+ i__7[1] = 1, a__2[1] = trans;
+ i__7[2] = 1, a__2[2] = diag;
+ i__7[3] = 1, a__2[3] = "N";
+ s_cat(ch__2, a__2, i__7, &c__4, (ftnlen)4);
+ alaerh_(path, "DLATBS", &info, &c__0, ch__2, &n, &
+ n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ dtbt03_(uplo, trans, diag, &n, &kd, &c__1, &ab[1], &
+ ldab, &scale, &rwork[1], &c_b15, &b[1], &lda,
+ &x[1], &lda, &work[1], &result[6]);
+
+/* + TEST 8 */
+/* Solve op(A)*x = b again with NORMIN = 'Y'. */
+
+ dcopy_(&n, &x[1], &c__1, &b[1], &c__1);
+ dlatbs_(uplo, trans, diag, "Y", &n, &kd, &ab[1], &
+ ldab, &b[1], &scale, &rwork[1], &info);
+
+/* Check error code from DLATBS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__7[0] = 1, a__2[0] = uplo;
+ i__7[1] = 1, a__2[1] = trans;
+ i__7[2] = 1, a__2[2] = diag;
+ i__7[3] = 1, a__2[3] = "Y";
+ s_cat(ch__2, a__2, i__7, &c__4, (ftnlen)4);
+ alaerh_(path, "DLATBS", &info, &c__0, ch__2, &n, &
+ n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ dtbt03_(uplo, trans, diag, &n, &kd, &c__1, &ab[1], &
+ ldab, &scale, &rwork[1], &c_b15, &b[1], &lda,
+ &x[1], &lda, &work[1], &result[7]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___43.ciunit = *nout;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "DLATBS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "DLATBS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "Y", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ nrun += 2;
+/* L100: */
+ }
+/* L110: */
+ }
+L120:
+ ;
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DCHKTB */
+
+} /* dchktb_ */
diff --git a/TESTING/LIN/dchktp.c b/TESTING/LIN/dchktp.c
new file mode 100644
index 0000000..e4f9130
--- /dev/null
+++ b/TESTING/LIN/dchktp.c
@@ -0,0 +1,693 @@
+/* dchktp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__7 = 7;
+static integer c__4 = 4;
+static doublereal c_b103 = 1.;
+static integer c__8 = 8;
+static integer c__9 = 9;
+
+/* Subroutine */ int dchktp_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, doublereal *thresh, logical *tsterr,
+ integer *nmax, doublereal *ap, doublereal *ainvp, doublereal *b,
+ doublereal *x, doublereal *xact, doublereal *work, doublereal *rwork,
+ integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', DIAG='\002,a1,\002'"
+ ", N=\002,i5,\002, type \002,i2,\002, test(\002,i2,\002)= \002,g1"
+ "2.5)";
+ static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', TRANS='\002,a1,\002"
+ "', DIAG='\002,a1,\002', N=\002,i5,\002', NRHS=\002,i5,\002, type "
+ "\002,i2,\002, test(\002,i2,\002)= \002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
+ "'\002,a1,\002',\002,i5,\002, ... ), type \002,i2,\002, test(\002"
+ ",i2,\002)=\002,g12.5)";
+ static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
+ "'\002,a1,\002', '\002,a1,\002',\002,i5,\002, ... ), type \002,i2,"
+ "\002, test(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2], a__2[3], a__3[4];
+ integer i__1, i__2[2], i__3, i__4[3], i__5[4];
+ char ch__1[2], ch__2[3], ch__3[4];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
+ char **, integer *, integer *, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, in, lda, lap;
+ char diag[1];
+ integer imat, info;
+ char path[3];
+ integer irhs, nrhs;
+ char norm[1], uplo[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer idiag;
+ doublereal scale;
+ extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *);
+ integer nfail, iseed[4];
+ extern logical lsame_(char *, char *);
+ doublereal rcond, anorm;
+ integer itran;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dtpt01_(char *, char *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *), dtpt02_(char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *), dtpt03_(char *, char *, char *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *), dtpt05_(char *, char *,
+ char *, integer *, integer *, doublereal *, doublereal *, integer
+ *, doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *), dtpt06_(
+ doublereal *, doublereal *, char *, char *, integer *, doublereal
+ *, doublereal *, doublereal *);
+ char trans[1];
+ integer iuplo, nerrs;
+ char xtype[1];
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ doublereal rcondc;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ doublereal rcondi;
+ extern /* Subroutine */ int dlarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *, doublereal
+ *, integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *);
+ extern doublereal dlantp_(char *, char *, char *, integer *, doublereal *,
+ doublereal *);
+ doublereal rcondo;
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *), dlatps_(char *, char *, char *, char *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int dlattp_(integer *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *), dtpcon_(char *, char *, char *
+, integer *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *), derrtr_(char *, integer *), dtprfs_(char *, char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *), dtptri_(char *, char *, integer *,
+ doublereal *, integer *);
+ doublereal result[9];
+ extern /* Subroutine */ int dtptrs_(char *, char *, char *, integer *,
+ integer *, doublereal *, doublereal *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKTP tests DTPTRI, -TRS, -RFS, and -CON, and DLATPS */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The leading dimension of the work arrays. NMAX >= the */
+/* maximumm value of N in NVAL. */
+
+/* AP (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AINVP (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainvp;
+ --ap;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "TP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrtr_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL */
+
+ n = nval[in];
+ lda = max(1,n);
+ lap = lda * (lda + 1) / 2;
+ *(unsigned char *)xtype = 'N';
+
+ for (imat = 1; imat <= 10; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L70;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Call DLATTP to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "DLATTP", (ftnlen)32, (ftnlen)6);
+ dlattp_(&imat, uplo, "No transpose", diag, iseed, &n, &ap[1],
+ &x[1], &work[1], &info);
+
+/* Set IDIAG = 1 for non-unit matrices, 2 for unit. */
+
+ if (lsame_(diag, "N")) {
+ idiag = 1;
+ } else {
+ idiag = 2;
+ }
+
+/* + TEST 1 */
+/* Form the inverse of A. */
+
+ if (n > 0) {
+ dcopy_(&lap, &ap[1], &c__1, &ainvp[1], &c__1);
+ }
+ s_copy(srnamc_1.srnamt, "DTPTRI", (ftnlen)32, (ftnlen)6);
+ dtptri_(uplo, diag, &n, &ainvp[1], &info);
+
+/* Check error code from DTPTRI. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__2[0] = 1, a__1[0] = uplo;
+ i__2[1] = 1, a__1[1] = diag;
+ s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2);
+ alaerh_(path, "DTPTRI", &info, &c__0, ch__1, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ anorm = dlantp_("I", uplo, diag, &n, &ap[1], &rwork[1]);
+ ainvnm = dlantp_("I", uplo, diag, &n, &ainvp[1], &rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondi = 1.;
+ } else {
+ rcondi = 1. / anorm / ainvnm;
+ }
+
+/* Compute the residual for the triangular matrix times its */
+/* inverse. Also compute the 1-norm condition number of A. */
+
+ dtpt01_(uplo, diag, &n, &ap[1], &ainvp[1], &rcondo, &rwork[1],
+ result);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, or A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[
+ itran - 1];
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+
+/* + TEST 2 */
+/* Solve and compute residual for op(A)*x = b. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ dlarhs_(path, xtype, uplo, trans, &n, &n, &c__0, &
+ idiag, &nrhs, &ap[1], &lap, &xact[1], &lda, &
+ b[1], &lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "DTPTRS", (ftnlen)32, (ftnlen)
+ 6);
+ dtptrs_(uplo, trans, diag, &n, &nrhs, &ap[1], &x[1], &
+ lda, &info);
+
+/* Check error code from DTPTRS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__4[0] = 1, a__2[0] = uplo;
+ i__4[1] = 1, a__2[1] = trans;
+ i__4[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)3);
+ alaerh_(path, "DTPTRS", &info, &c__0, ch__2, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ dtpt02_(uplo, trans, diag, &n, &nrhs, &ap[1], &x[1], &
+ lda, &b[1], &lda, &work[1], &result[1]);
+
+/* + TEST 3 */
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* + TESTS 4, 5, and 6 */
+/* Use iterative refinement to improve the solution and */
+/* compute error bounds. */
+
+ s_copy(srnamc_1.srnamt, "DTPRFS", (ftnlen)32, (ftnlen)
+ 6);
+ dtprfs_(uplo, trans, diag, &n, &nrhs, &ap[1], &b[1], &
+ lda, &x[1], &lda, &rwork[1], &rwork[nrhs + 1],
+ &work[1], &iwork[1], &info);
+
+/* Check error code from DTPRFS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__4[0] = 1, a__2[0] = uplo;
+ i__4[1] = 1, a__2[1] = trans;
+ i__4[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)3);
+ alaerh_(path, "DTPRFS", &info, &c__0, ch__2, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+ dtpt05_(uplo, trans, diag, &n, &nrhs, &ap[1], &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[1], &
+ rwork[nrhs + 1], &result[4]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += 5;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* + TEST 7 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+
+ s_copy(srnamc_1.srnamt, "DTPCON", (ftnlen)32, (ftnlen)6);
+ dtpcon_(norm, uplo, diag, &n, &ap[1], &rcond, &work[1], &
+ iwork[1], &info);
+
+/* Check error code from DTPCON. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__4[0] = 1, a__2[0] = norm;
+ i__4[1] = 1, a__2[1] = uplo;
+ i__4[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)3);
+ alaerh_(path, "DTPCON", &info, &c__0, ch__2, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ dtpt06_(&rcond, &rcondc, uplo, diag, &n, &ap[1], &rwork[1]
+, &result[6]);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, "DTPCON", (ftnlen)6);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L50: */
+ }
+/* L60: */
+ }
+L70:
+ ;
+ }
+
+/* Use pathological test matrices to test DLATPS. */
+
+ for (imat = 11; imat <= 18; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L100;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, or A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[itran
+ - 1];
+
+/* Call DLATTP to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "DLATTP", (ftnlen)32, (ftnlen)6);
+ dlattp_(&imat, uplo, trans, diag, iseed, &n, &ap[1], &x[1]
+, &work[1], &info);
+
+/* + TEST 8 */
+/* Solve the system op(A)*x = b. */
+
+ s_copy(srnamc_1.srnamt, "DLATPS", (ftnlen)32, (ftnlen)6);
+ dcopy_(&n, &x[1], &c__1, &b[1], &c__1);
+ dlatps_(uplo, trans, diag, "N", &n, &ap[1], &b[1], &scale,
+ &rwork[1], &info);
+
+/* Check error code from DLATPS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__5[0] = 1, a__3[0] = uplo;
+ i__5[1] = 1, a__3[1] = trans;
+ i__5[2] = 1, a__3[2] = diag;
+ i__5[3] = 1, a__3[3] = "N";
+ s_cat(ch__3, a__3, i__5, &c__4, (ftnlen)4);
+ alaerh_(path, "DLATPS", &info, &c__0, ch__3, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ dtpt03_(uplo, trans, diag, &n, &c__1, &ap[1], &scale, &
+ rwork[1], &c_b103, &b[1], &lda, &x[1], &lda, &
+ work[1], &result[7]);
+
+/* + TEST 9 */
+/* Solve op(A)*x = b again with NORMIN = 'Y'. */
+
+ dcopy_(&n, &x[1], &c__1, &b[n + 1], &c__1);
+ dlatps_(uplo, trans, diag, "Y", &n, &ap[1], &b[n + 1], &
+ scale, &rwork[1], &info);
+
+/* Check error code from DLATPS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__5[0] = 1, a__3[0] = uplo;
+ i__5[1] = 1, a__3[1] = trans;
+ i__5[2] = 1, a__3[2] = diag;
+ i__5[3] = 1, a__3[3] = "Y";
+ s_cat(ch__3, a__3, i__5, &c__4, (ftnlen)4);
+ alaerh_(path, "DLATPS", &info, &c__0, ch__3, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ dtpt03_(uplo, trans, diag, &n, &c__1, &ap[1], &scale, &
+ rwork[1], &c_b103, &b[n + 1], &lda, &x[1], &lda, &
+ work[1], &result[8]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, "DLATPS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ if (result[8] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, "DLATPS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "Y", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[8], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ nrun += 2;
+/* L80: */
+ }
+/* L90: */
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DCHKTP */
+
+} /* dchktp_ */
diff --git a/TESTING/LIN/dchktr.c b/TESTING/LIN/dchktr.c
new file mode 100644
index 0000000..e52c815
--- /dev/null
+++ b/TESTING/LIN/dchktr.c
@@ -0,0 +1,734 @@
+/* dchktr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__7 = 7;
+static integer c__4 = 4;
+static doublereal c_b101 = 1.;
+static integer c__8 = 8;
+static integer c__9 = 9;
+
+/* Subroutine */ int dchktr_(logical *dotype, integer *nn, integer *nval,
+ integer *nnb, integer *nbval, integer *nns, integer *nsval,
+ doublereal *thresh, logical *tsterr, integer *nmax, doublereal *a,
+ doublereal *ainv, doublereal *b, doublereal *x, doublereal *xact,
+ doublereal *work, doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', DIAG='\002,a1,\002'"
+ ", N=\002,i5,\002, NB=\002,i4,\002, type \002,i2,\002, test(\002,"
+ "i2,\002)= \002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', TRANS='\002,a1,\002"
+ "', DIAG='\002,a1,\002', N=\002,i5,\002, NB=\002,i4,\002, type"
+ " \002,i2,\002, test(\002,i2,\002)= \002,g12"
+ ".5)";
+ static char fmt_9997[] = "(\002 NORM='\002,a1,\002', UPLO ='\002,a1,\002"
+ "', N=\002,i5,\002,\002,11x,\002 type \002,i2,\002, test(\002,i2"
+ ",\002)=\002,g12.5)";
+ static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
+ "'\002,a1,\002', '\002,a1,\002',\002,i5,\002, ... ), type \002,i2,"
+ "\002, test(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2], a__2[3], a__3[4];
+ integer i__1, i__2, i__3[2], i__4, i__5[3], i__6[4];
+ char ch__1[2], ch__2[3], ch__3[4];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
+ char **, integer *, integer *, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, nb, in, lda, inb;
+ char diag[1];
+ integer imat, info;
+ char path[3];
+ integer irhs, nrhs;
+ char norm[1], uplo[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer idiag;
+ doublereal scale;
+ extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *);
+ integer nfail, iseed[4];
+ extern logical lsame_(char *, char *);
+ doublereal rcond, anorm;
+ integer itran;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dtrt01_(char *, char *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *), dtrt02_(char *, char
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *), dtrt03_(char *, char *,
+ char *, integer *, integer *, doublereal *, integer *, doublereal
+ *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *), dtrt05_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *), dtrt06_(
+ doublereal *, doublereal *, char *, char *, integer *, doublereal
+ *, integer *, doublereal *, doublereal *);
+ char trans[1];
+ integer iuplo, nerrs;
+ doublereal dummy;
+ char xtype[1];
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ doublereal rcondc;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *);
+ doublereal rcondi;
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal rcondo;
+ extern doublereal dlantr_(char *, char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int dlatrs_(char *, char *, char *, char *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), dlattr_(
+ integer *, char *, char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *), dtrcon_(char *, char *, char *, integer *
+, doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), xlaenv_(integer *, integer *),
+ derrtr_(char *, integer *), dtrrfs_(char *, char *, char
+ *, integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *),
+ dtrtri_(char *, char *, integer *, doublereal *, integer *,
+ integer *);
+ doublereal result[9];
+ extern /* Subroutine */ int dtrtrs_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___27 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKTR tests DTRTRI, -TRS, -RFS, and -CON, and DLATRS */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The leading dimension of the work arrays. */
+/* NMAX >= the maximum value of N in NVAL. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "TR", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrtr_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL */
+
+ n = nval[in];
+ lda = max(1,n);
+ *(unsigned char *)xtype = 'N';
+
+ for (imat = 1; imat <= 10; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L80;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Call DLATTR to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "DLATTR", (ftnlen)32, (ftnlen)6);
+ dlattr_(&imat, uplo, "No transpose", diag, iseed, &n, &a[1], &
+ lda, &x[1], &work[1], &info);
+
+/* Set IDIAG = 1 for non-unit matrices, 2 for unit. */
+
+ if (lsame_(diag, "N")) {
+ idiag = 1;
+ } else {
+ idiag = 2;
+ }
+
+ i__2 = *nnb;
+ for (inb = 1; inb <= i__2; ++inb) {
+
+/* Do for each blocksize in NBVAL */
+
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* + TEST 1 */
+/* Form the inverse of A. */
+
+ dlacpy_(uplo, &n, &n, &a[1], &lda, &ainv[1], &lda);
+ s_copy(srnamc_1.srnamt, "DTRTRI", (ftnlen)32, (ftnlen)6);
+ dtrtri_(uplo, diag, &n, &ainv[1], &lda, &info);
+
+/* Check error code from DTRTRI. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = uplo;
+ i__3[1] = 1, a__1[1] = diag;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ alaerh_(path, "DTRTRI", &info, &c__0, ch__1, &n, &n, &
+ c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ anorm = dlantr_("I", uplo, diag, &n, &n, &a[1], &lda, &
+ rwork[1]);
+ ainvnm = dlantr_("I", uplo, diag, &n, &n, &ainv[1], &lda,
+ &rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondi = 1.;
+ } else {
+ rcondi = 1. / anorm / ainvnm;
+ }
+
+/* Compute the residual for the triangular matrix times */
+/* its inverse. Also compute the 1-norm condition number */
+/* of A. */
+
+ dtrt01_(uplo, diag, &n, &a[1], &lda, &ainv[1], &lda, &
+ rcondo, &rwork[1], result);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+/* Skip remaining tests if not the first block size. */
+
+ if (inb != 1) {
+ goto L60;
+ }
+
+ i__4 = *nns;
+ for (irhs = 1; irhs <= i__4; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, or A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itran - 1];
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+
+/* + TEST 2 */
+/* Solve and compute residual for op(A)*x = b. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (
+ ftnlen)6);
+ dlarhs_(path, xtype, uplo, trans, &n, &n, &c__0, &
+ idiag, &nrhs, &a[1], &lda, &xact[1], &lda,
+ &b[1], &lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "DTRTRS", (ftnlen)32, (
+ ftnlen)6);
+ dtrtrs_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
+ &x[1], &lda, &info);
+
+/* Check error code from DTRTRS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__5[0] = 1, a__2[0] = uplo;
+ i__5[1] = 1, a__2[1] = trans;
+ i__5[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3);
+ alaerh_(path, "DTRTRS", &info, &c__0, ch__2, &
+ n, &n, &c_n1, &c_n1, &nrhs, &imat, &
+ nfail, &nerrs, nout);
+ }
+
+/* This line is needed on a Sun SPARCstation. */
+
+ if (n > 0) {
+ dummy = a[1];
+ }
+
+ dtrt02_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
+ &x[1], &lda, &b[1], &lda, &work[1], &
+ result[1]);
+
+/* + TEST 3 */
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* + TESTS 4, 5, and 6 */
+/* Use iterative refinement to improve the solution */
+/* and compute error bounds. */
+
+ s_copy(srnamc_1.srnamt, "DTRRFS", (ftnlen)32, (
+ ftnlen)6);
+ dtrrfs_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
+ &b[1], &lda, &x[1], &lda, &rwork[1], &
+ rwork[nrhs + 1], &work[1], &iwork[1], &
+ info);
+
+/* Check error code from DTRRFS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__5[0] = 1, a__2[0] = uplo;
+ i__5[1] = 1, a__2[1] = trans;
+ i__5[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3);
+ alaerh_(path, "DTRRFS", &info, &c__0, ch__2, &
+ n, &n, &c_n1, &c_n1, &nrhs, &imat, &
+ nfail, &nerrs, nout);
+ }
+
+ dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+ dtrt05_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
+ &b[1], &lda, &x[1], &lda, &xact[1], &lda,
+ &rwork[1], &rwork[nrhs + 1], &result[4]);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += 5;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* + TEST 7 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+ s_copy(srnamc_1.srnamt, "DTRCON", (ftnlen)32, (ftnlen)
+ 6);
+ dtrcon_(norm, uplo, diag, &n, &a[1], &lda, &rcond, &
+ work[1], &iwork[1], &info);
+
+/* Check error code from DTRCON. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__5[0] = 1, a__2[0] = norm;
+ i__5[1] = 1, a__2[1] = uplo;
+ i__5[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3);
+ alaerh_(path, "DTRCON", &info, &c__0, ch__2, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ dtrt06_(&rcond, &rcondc, uplo, diag, &n, &a[1], &lda,
+ &rwork[1], &result[6]);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L50: */
+ }
+L60:
+ ;
+ }
+/* L70: */
+ }
+L80:
+ ;
+ }
+
+/* Use pathological test matrices to test DLATRS. */
+
+ for (imat = 11; imat <= 18; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L110;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, and A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[itran
+ - 1];
+
+/* Call DLATTR to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "DLATTR", (ftnlen)32, (ftnlen)6);
+ dlattr_(&imat, uplo, trans, diag, iseed, &n, &a[1], &lda,
+ &x[1], &work[1], &info);
+
+/* + TEST 8 */
+/* Solve the system op(A)*x = b. */
+
+ s_copy(srnamc_1.srnamt, "DLATRS", (ftnlen)32, (ftnlen)6);
+ dcopy_(&n, &x[1], &c__1, &b[1], &c__1);
+ dlatrs_(uplo, trans, diag, "N", &n, &a[1], &lda, &b[1], &
+ scale, &rwork[1], &info);
+
+/* Check error code from DLATRS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__6[0] = 1, a__3[0] = uplo;
+ i__6[1] = 1, a__3[1] = trans;
+ i__6[2] = 1, a__3[2] = diag;
+ i__6[3] = 1, a__3[3] = "N";
+ s_cat(ch__3, a__3, i__6, &c__4, (ftnlen)4);
+ alaerh_(path, "DLATRS", &info, &c__0, ch__3, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ dtrt03_(uplo, trans, diag, &n, &c__1, &a[1], &lda, &scale,
+ &rwork[1], &c_b101, &b[1], &lda, &x[1], &lda, &
+ work[1], &result[7]);
+
+/* + TEST 9 */
+/* Solve op(A)*X = b again with NORMIN = 'Y'. */
+
+ dcopy_(&n, &x[1], &c__1, &b[n + 1], &c__1);
+ dlatrs_(uplo, trans, diag, "Y", &n, &a[1], &lda, &b[n + 1]
+, &scale, &rwork[1], &info);
+
+/* Check error code from DLATRS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__6[0] = 1, a__3[0] = uplo;
+ i__6[1] = 1, a__3[1] = trans;
+ i__6[2] = 1, a__3[2] = diag;
+ i__6[3] = 1, a__3[3] = "Y";
+ s_cat(ch__3, a__3, i__6, &c__4, (ftnlen)4);
+ alaerh_(path, "DLATRS", &info, &c__0, ch__3, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ dtrt03_(uplo, trans, diag, &n, &c__1, &a[1], &lda, &scale,
+ &rwork[1], &c_b101, &b[n + 1], &lda, &x[1], &lda,
+ &work[1], &result[8]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "DLATRS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ if (result[8] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "DLATRS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "Y", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[8], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ nrun += 2;
+/* L90: */
+ }
+/* L100: */
+ }
+L110:
+ ;
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DCHKTR */
+
+} /* dchktr_ */
diff --git a/TESTING/LIN/dchktz.c b/TESTING/LIN/dchktz.c
new file mode 100644
index 0000000..5aa0272
--- /dev/null
+++ b/TESTING/LIN/dchktz.c
@@ -0,0 +1,392 @@
+/* dchktz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublereal c_b10 = 0.;
+static doublereal c_b15 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dchktz_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, doublereal *thresh, logical *tsterr,
+ doublereal *a, doublereal *copya, doublereal *s, doublereal *copys,
+ doublereal *tau, doublereal *work, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, type"
+ " \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublereal d__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, im, in, lda;
+ doublereal eps;
+ integer mode, info;
+ char path[3];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4], imode;
+ extern doublereal dqrt12_(integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ integer mnmin;
+ extern doublereal drzt01_(integer *, integer *, doublereal *, doublereal *
+, integer *, doublereal *, doublereal *, integer *), drzt02_(
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *), dtzt01_(integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *), dtzt02_(integer *, integer *, doublereal *, integer *
+, doublereal *, doublereal *, integer *);
+ integer nerrs, lwork;
+ extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *,
+ integer *), dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), alasum_(char *, integer *,
+ integer *, integer *, integer *), dlatms_(integer *,
+ integer *, char *, integer *, char *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *, char *,
+ doublereal *, integer *, doublereal *, integer *), derrtz_(char *, integer *), dtzrqf_(integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *);
+ doublereal result[6];
+ extern /* Subroutine */ int dtzrzf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___21 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DCHKTZ tests DTZRQF and STZRZF. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX) */
+/* where MMAX is the maximum value of M in MVAL and NMAX is the */
+/* maximum value of N in NVAL. */
+
+/* COPYA (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* COPYS (workspace) DOUBLE PRECISION array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* TAU (workspace) DOUBLE PRECISION array, dimension (MMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (MMAX*NMAX + 4*NMAX + MMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --work;
+ --tau;
+ --copys;
+ --s;
+ --copya;
+ --a;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "TZ", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = dlamch_("Epsilon");
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrtz_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+
+/* Do for each value of M in MVAL. */
+
+ m = mval[im];
+ lda = max(1,m);
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+
+/* Do for each value of N in NVAL for which M .LE. N. */
+
+ n = nval[in];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__3 = 1, i__4 = n * n + (m << 2) + n, i__3 = max(i__3,i__4),
+ i__4 = m * n + (mnmin << 1) + (n << 2);
+ lwork = max(i__3,i__4);
+
+ if (m <= n) {
+ for (imode = 1; imode <= 3; ++imode) {
+ if (! dotype[imode]) {
+ goto L50;
+ }
+
+/* Do for each type of singular value distribution. */
+/* 0: zero matrix */
+/* 1: one small singular value */
+/* 2: exponential distribution */
+
+ mode = imode - 1;
+
+/* Test DTZRQF */
+
+/* Generate test matrix of size m by n using */
+/* singular value distribution indicated by `mode'. */
+
+ if (mode == 0) {
+ dlaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
+ i__3 = mnmin;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ copys[i__] = 0.;
+/* L20: */
+ }
+ } else {
+ d__1 = 1. / eps;
+ dlatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
+ copys[1], &imode, &d__1, &c_b15, &m, &n,
+ "No packing", &a[1], &lda, &work[1], &info);
+ dgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
+ 1], &info);
+ i__3 = m - 1;
+ dlaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
+ lda);
+ dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
+ }
+
+/* Save A and its singular values */
+
+ dlacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
+
+/* Call DTZRQF to reduce the upper trapezoidal matrix to */
+/* upper triangular form. */
+
+ s_copy(srnamc_1.srnamt, "DTZRQF", (ftnlen)32, (ftnlen)6);
+ dtzrqf_(&m, &n, &a[1], &lda, &tau[1], &info);
+
+/* Compute norm(svd(a) - svd(r)) */
+
+ result[0] = dqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
+ 1], &lwork);
+
+/* Compute norm( A - R*Q ) */
+
+ result[1] = dtzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
+ 1], &work[1], &lwork);
+
+/* Compute norm(Q'*Q - I). */
+
+ result[2] = dtzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
+, &lwork);
+
+/* Test DTZRZF */
+
+/* Generate test matrix of size m by n using */
+/* singular value distribution indicated by `mode'. */
+
+ if (mode == 0) {
+ dlaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
+ i__3 = mnmin;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ copys[i__] = 0.;
+/* L30: */
+ }
+ } else {
+ d__1 = 1. / eps;
+ dlatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
+ copys[1], &imode, &d__1, &c_b15, &m, &n,
+ "No packing", &a[1], &lda, &work[1], &info);
+ dgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
+ 1], &info);
+ i__3 = m - 1;
+ dlaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
+ lda);
+ dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
+ }
+
+/* Save A and its singular values */
+
+ dlacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
+
+/* Call DTZRZF to reduce the upper trapezoidal matrix to */
+/* upper triangular form. */
+
+ s_copy(srnamc_1.srnamt, "DTZRZF", (ftnlen)32, (ftnlen)6);
+ dtzrzf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lwork, &
+ info);
+
+/* Compute norm(svd(a) - svd(r)) */
+
+ result[3] = dqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
+ 1], &lwork);
+
+/* Compute norm( A - R*Q ) */
+
+ result[4] = drzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
+ 1], &work[1], &lwork);
+
+/* Compute norm(Q'*Q - I). */
+
+ result[5] = drzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
+, &lwork);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___21.ciunit = *nout;
+ s_wsfe(&io___21);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L40: */
+ }
+ nrun += 6;
+L50:
+ ;
+ }
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+
+/* End if DCHKTZ */
+
+ return 0;
+} /* dchktz_ */
diff --git a/TESTING/LIN/ddrvab.c b/TESTING/LIN/ddrvab.c
new file mode 100644
index 0000000..4c9ac24
--- /dev/null
+++ b/TESTING/LIN/ddrvab.c
@@ -0,0 +1,494 @@
+/* ddrvab.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublereal c_b17 = 0.;
+static integer c__1 = 1;
+
+/* Subroutine */ int ddrvab_(logical *dotype, integer *nm, integer *mval,
+ integer *nns, integer *nsval, doublereal *thresh, integer *nmax,
+ doublereal *a, doublereal *afac, doublereal *b, doublereal *x,
+ doublereal *work, doublereal *rwork, real *swork, integer *iwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 2006,2007,2008,2009 };
+
+ /* Format strings */
+ static char fmt_9988[] = "(\002 *** \002,a6,\002 returned with INFO ="
+ "\002,i5,\002 instead of \002,i5,/\002 ==> M =\002,i5,\002, type"
+ " \002,i2)";
+ static char fmt_9975[] = "(\002 *** Error code from \002,a6,\002=\002,"
+ "i5,\002 for M=\002,i5,\002, type \002,i2)";
+ static char fmt_8999[] = "(/1x,a3,\002: General dense matrices\002)";
+ static char fmt_8979[] = "(4x,\0021. Diagonal\002,24x,\0027. Last n/2 co"
+ "lumns zero\002,/4x,\0022. Upper triangular\002,16x,\0028. Random"
+ ", CNDNUM = sqrt(0.1/EPS)\002,/4x,\0023. Lower triangular\002,16x,"
+ "\0029. Random, CNDNUM = 0.1/EPS\002,/4x,\0024. Random, CNDNUM = 2"
+ "\002,13x,\00210. Scaled near underflow\002,/4x,\0025. First colu"
+ "mn zero\002,14x,\00211. Scaled near overflow\002,/4x,\0026. Last"
+ " column zero\002)";
+ static char fmt_8960[] = "(3x,i2,\002: norm_1( B - A * X ) / \002,\002("
+ " norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF\002,/4x"
+ ",\002or norm_1( B - A * X ) / \002,\002( norm_1(A) * norm_1(X) "
+ "* EPS ) > THRES if DGETRF\002)";
+ static char fmt_9998[] = "(\002 TRANS='\002,a1,\002', N =\002,i5,\002, N"
+ "RHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g1"
+ "2.5)";
+ static char fmt_9996[] = "(1x,a6,\002: \002,i6,\002 out of \002,i6,\002 "
+ "tests failed to pass the threshold\002)";
+ static char fmt_9995[] = "(/1x,\002All tests for \002,a6,\002 routines p"
+ "assed the threshold (\002,i6,\002 tests run)\002)";
+ static char fmt_9994[] = "(6x,i6,\002 error messages recorded\002)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ cilist ci__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, m, n, im, kl, ku, lda, ioff, mode, kase, imat, info;
+ char path[3], dist[1];
+ integer irhs, iter, nrhs;
+ char type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int dget08_(char *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *);
+ integer nimat;
+ doublereal anorm;
+ char trans[1];
+ integer izero, nerrs;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *), dlacpy_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *), dlarhs_(char *, char *, char *, char *, integer *,
+ integer *, integer *, integer *, integer *, doublereal *, integer
+ *, doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *), dlaset_(char *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublereal *, integer *, doublereal
+ *, integer *), dsgesv_(integer *, integer
+ *, doublereal *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, real *, integer *, integer
+ *);
+ doublereal result[1];
+
+ /* Fortran I/O blocks */
+ static cilist io___31 = { 0, 0, 0, fmt_9988, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9975, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_8999, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_8979, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_8960, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVAB tests DSGESV */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(2*NMAX,2*NSMAX+NWORK)) */
+
+/* SWORK (workspace) REAL array, dimension */
+/* (NMAX*(NSMAX+NMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension */
+/* NMAX */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Local Variables .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --swork;
+ --rwork;
+ --work;
+ --x;
+ --b;
+ --afac;
+ --a;
+ --nsval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ kase = 0;
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "GE", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+ infoc_1.infot = 0;
+
+/* Do for each value of M in MVAL */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+ lda = max(1,m);
+
+ n = m;
+ nimat = 11;
+ if (m <= 0 || n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L100;
+ }
+
+/* Skip types 5, 6, or 7 if the matrix size is too small. */
+
+ zerot = imat >= 5 && imat <= 7;
+ if (zerot && n < imat - 4) {
+ goto L100;
+ }
+
+/* Set up parameters with DLATB4 and generate a test matrix */
+/* with DLATMS. */
+
+ dlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode, &
+ cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &cndnum, &
+ anorm, &kl, &ku, "No packing", &a[1], &lda, &work[1], &
+ info);
+
+/* Check error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, " ", &m, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L100;
+ }
+
+/* For types 5-7, zero one or more columns of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 5) {
+ izero = 1;
+ } else if (imat == 6) {
+ izero = min(m,n);
+ } else {
+ izero = min(m,n) / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 7) {
+ i__3 = m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.;
+/* L20: */
+ }
+ } else {
+ i__3 = n - izero + 1;
+ dlaset_("Full", &m, &i__3, &c_b17, &c_b17, &a[ioff + 1], &
+ lda);
+ }
+ } else {
+ izero = 0;
+ }
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+ *(unsigned char *)trans = 'N';
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)6);
+ dlarhs_(path, xtype, " ", trans, &n, &n, &kl, &ku, &nrhs, &a[
+ 1], &lda, &x[1], &lda, &b[1], &lda, iseed, &info);
+
+ s_copy(srnamc_1.srnamt, "DSGESV", (ftnlen)32, (ftnlen)6);
+
+ ++kase;
+
+ dlacpy_("Full", &m, &n, &a[1], &lda, &afac[1], &lda);
+
+ dsgesv_(&n, &nrhs, &a[1], &lda, &iwork[1], &b[1], &lda, &x[1],
+ &lda, &work[1], &swork[1], &iter, &info);
+
+ if (iter < 0) {
+ dlacpy_("Full", &m, &n, &afac[1], &lda, &a[1], &lda);
+ }
+
+/* Check error code from DSGESV. This should be the same as */
+/* the one of DGETRF. */
+
+ if (info != izero) {
+
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ ++nerrs;
+
+ if (info != izero && izero != 0) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, "DSGESV", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&izero, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "DSGESV", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+
+/* Skip the remaining test if the matrix is singular. */
+
+ if (info != 0) {
+ goto L100;
+ }
+
+/* Check the quality of the solution */
+
+ dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
+
+ dget08_(trans, &n, &n, &nrhs, &a[1], &lda, &x[1], &lda, &work[
+ 1], &lda, &rwork[1], result);
+
+/* Check if the test passes the tesing. */
+/* Print information about the tests that did not */
+/* pass the testing. */
+
+/* If iterative refinement has been used and claimed to */
+/* be successful (ITER>0), we want */
+/* NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS*SRQT(N)) < 1 */
+
+/* If double precision has been used (ITER<0), we want */
+/* NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS) < THRES */
+/* (Cf. the linear solver testing routines) */
+
+ if (*thresh <= 0.f || iter >= 0 && n > 0 && result[0] >= sqrt(
+ (doublereal) n) || iter < 0 && result[0] >= *thresh) {
+
+ if (nfail == 0 && nerrs == 0) {
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "DGE", (ftnlen)3);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *nout;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *nout;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *nout;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ }
+
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L60: */
+ }
+L100:
+ ;
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ if (nfail > 0) {
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, "DSGESV", (ftnlen)6);
+ do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, "DSGESV", (ftnlen)6);
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (nerrs > 0) {
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, (char *)&nerrs, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+
+/* SUBNAM, INFO, INFOE, M, IMAT */
+
+
+/* SUBNAM, INFO, M, IMAT */
+
+ return 0;
+
+/* End of DDRVAB */
+
+} /* ddrvab_ */
diff --git a/TESTING/LIN/ddrvac.c b/TESTING/LIN/ddrvac.c
new file mode 100644
index 0000000..0a42b1b
--- /dev/null
+++ b/TESTING/LIN/ddrvac.c
@@ -0,0 +1,529 @@
+/* ddrvac.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+
+/* Subroutine */ int ddrvac_(logical *dotype, integer *nm, integer *mval,
+ integer *nns, integer *nsval, doublereal *thresh, integer *nmax,
+ doublereal *a, doublereal *afac, doublereal *b, doublereal *x,
+ doublereal *work, doublereal *rwork, real *swork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9988[] = "(\002 *** \002,a6,\002 returned with INFO ="
+ "\002,i5,\002 instead of \002,i5,/\002 ==> N =\002,i5,\002, type"
+ " \002,i2)";
+ static char fmt_9975[] = "(\002 *** Error code from \002,a6,\002=\002,"
+ "i5,\002 for M=\002,i5,\002, type \002,i2)";
+ static char fmt_8999[] = "(/1x,a3,\002: positive definite dense matri"
+ "ces\002)";
+ static char fmt_8979[] = "(4x,\0021. Diagonal\002,24x,\0027. Last n/2 co"
+ "lumns zero\002,/4x,\0022. Upper triangular\002,16x,\0028. Random"
+ ", CNDNUM = sqrt(0.1/EPS)\002,/4x,\0023. Lower triangular\002,16x,"
+ "\0029. Random, CNDNUM = 0.1/EPS\002,/4x,\0024. Random, CNDNUM = 2"
+ "\002,13x,\00210. Scaled near underflow\002,/4x,\0025. First colu"
+ "mn zero\002,14x,\00211. Scaled near overflow\002,/4x,\0026. Last"
+ " column zero\002)";
+ static char fmt_8960[] = "(3x,i2,\002: norm_1( B - A * X ) / \002,\002("
+ " norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF\002,/4x"
+ ",\002or norm_1( B - A * X ) / \002,\002( norm_1(A) * norm_1(X) "
+ "* EPS ) > THRES if DPOTRF\002)";
+ static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', N =\002,i5,\002, NR"
+ "HS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g12"
+ ".5)";
+ static char fmt_9996[] = "(1x,a6,\002: \002,i6,\002 out of \002,i6,\002 "
+ "tests failed to pass the threshold\002)";
+ static char fmt_9995[] = "(/1x,\002All tests for \002,a6,\002 routines p"
+ "assed the threshold (\002,i6,\002 tests run)\002)";
+ static char fmt_9994[] = "(6x,i6,\002 error messages recorded\002)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ cilist ci__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, n, im, kl, ku, lda, ioff, mode, kase, imat, info;
+ char path[3], dist[1];
+ integer irhs, iter, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4], nimat;
+ doublereal anorm;
+ extern /* Subroutine */ int dpot06_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *);
+ integer iuplo, izero, nerrs;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *), dlacpy_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *), dlarhs_(char *, char *, char *, char *, integer *,
+ integer *, integer *, integer *, integer *, doublereal *, integer
+ *, doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublereal *, integer *, doublereal
+ *, integer *);
+ doublereal result[1];
+ extern /* Subroutine */ int dsposv_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___32 = { 0, 0, 0, fmt_9988, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9975, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_8999, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_8979, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_8960, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* April 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVAC tests DSPOSV. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of N contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(2*NMAX,2*NSMAX+NWORK)) */
+
+/* SWORK (workspace) REAL array, dimension */
+/* (NMAX*(NSMAX+NMAX)) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Local Variables .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --swork;
+ --rwork;
+ --work;
+ --x;
+ --b;
+ --afac;
+ --a;
+ --nsval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ kase = 0;
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "PO", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+ infoc_1.infot = 0;
+
+/* Do for each value of N in MVAL */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ n = mval[im];
+ lda = max(n,1);
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L110;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot && n < imat - 2) {
+ goto L110;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Set up parameters with DLATB4 and generate a test matrix */
+/* with DLATMS. */
+
+ dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
+ &info);
+
+/* Check error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L100;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff] = 0.;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff] = 0.;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)6);
+ dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &nrhs, &
+ a[1], &lda, &x[1], &lda, &b[1], &lda, iseed, &
+ info);
+
+/* Compute the L*L' or U'*U factorization of the */
+/* matrix and solve the system. */
+
+ s_copy(srnamc_1.srnamt, "DSPOSV ", (ftnlen)32, (ftnlen)7);
+ ++kase;
+
+ dlacpy_("All", &n, &n, &a[1], &lda, &afac[1], &lda);
+
+ dsposv_(uplo, &n, &nrhs, &afac[1], &lda, &b[1], &lda, &x[
+ 1], &lda, &work[1], &swork[1], &iter, &info);
+ if (iter < 0) {
+ dlacpy_("All", &n, &n, &a[1], &lda, &afac[1], &lda);
+ }
+
+/* Check error code from DSPOSV . */
+
+ if (info != izero) {
+
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ ++nerrs;
+
+ if (info != izero && izero != 0) {
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "DSPOSV", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&izero, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ } else {
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, "DSPOSV", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ }
+
+/* Skip the remaining test if the matrix is singular. */
+
+ if (info != 0) {
+ goto L110;
+ }
+
+/* Check the quality of the solution */
+
+ dlacpy_("All", &n, &nrhs, &b[1], &lda, &work[1], &lda);
+
+ dpot06_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &work[
+ 1], &lda, &rwork[1], result);
+
+/* Check if the test passes the tesing. */
+/* Print information about the tests that did not */
+/* pass the testing. */
+
+/* If iterative refinement has been used and claimed to */
+/* be successful (ITER>0), we want */
+/* NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS*SRQT(N)) < 1 */
+
+/* If double precision has been used (ITER<0), we want */
+/* NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS) < THRES */
+/* (Cf. the linear solver testing routines) */
+
+ if (*thresh <= 0.f || iter >= 0 && n > 0 && result[0] >=
+ sqrt((doublereal) n) || iter < 0 && result[0] >= *
+ thresh) {
+
+ if (nfail == 0 && nerrs == 0) {
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, "DPO", (ftnlen)3);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *nout;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *nout;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *nout;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ }
+
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+
+ ++nfail;
+
+ }
+
+ ++nrun;
+
+/* L60: */
+ }
+L100:
+ ;
+ }
+L110:
+ ;
+ }
+/* L120: */
+ }
+
+/* L130: */
+
+/* Print a summary of the results. */
+
+ if (nfail > 0) {
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, "DSPOSV", (ftnlen)6);
+ do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "DSPOSV", (ftnlen)6);
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (nerrs > 0) {
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, (char *)&nerrs, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+
+/* SUBNAM, INFO, INFOE, N, IMAT */
+
+
+/* SUBNAM, INFO, N, IMAT */
+
+ return 0;
+
+/* End of DDRVAC */
+
+} /* ddrvac_ */
diff --git a/TESTING/LIN/ddrvgb.c b/TESTING/LIN/ddrvgb.c
new file mode 100644
index 0000000..ca498a3
--- /dev/null
+++ b/TESTING/LIN/ddrvgb.c
@@ -0,0 +1,1129 @@
+/* ddrvgb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublereal c_b48 = 0.;
+static doublereal c_b49 = 1.;
+static integer c__6 = 6;
+static integer c__7 = 7;
+
+/* Subroutine */ int ddrvgb_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, doublereal *a,
+ integer *la, doublereal *afb, integer *lafb, doublereal *asav,
+ doublereal *b, doublereal *bsav, doublereal *x, doublereal *xact,
+ doublereal *s, doublereal *work, doublereal *rwork, integer *iwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*4] = "N" "R" "C" "B";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 *** In DDRVGB, LA=\002,i5,\002 is too sm"
+ "all for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> In"
+ "crease LA to at least \002,i5)";
+ static char fmt_9998[] = "(\002 *** In DDRVGB, LAFB=\002,i5,\002 is too "
+ "small for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> "
+ "Increase LAFB to at least \002,i5)";
+ static char fmt_9997[] = "(1x,a,\002, N=\002,i5,\002, KL=\002,i5,\002, K"
+ "U=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)"
+ ;
+ static char fmt_9995[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002"
+ ",i5,\002,\002,i5,\002,\002,i5,\002,...), EQUED='\002,a1,\002', t"
+ "ype \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002"
+ ",i5,\002,\002,i5,\002,\002,i5,\002,...), type \002,i1,\002, test("
+ "\002,i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10,
+ i__11[2];
+ doublereal d__1, d__2, d__3;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, k1, nb, in, kl, ku, nt, lda, ldb, ikl, nkl,
+ iku, nku;
+ char fact[1];
+ integer ioff, mode;
+ doublereal amax;
+ char path[3];
+ integer imat, info;
+ char dist[1], type__[1];
+ integer nrun, ldafb;
+ extern /* Subroutine */ int dgbt01_(integer *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, doublereal *, doublereal *), dgbt02_(char *, integer *,
+ integer *, integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *), dgbt05_(char *, integer *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *);
+ integer ifact;
+ extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *);
+ integer nfail, iseed[4], nfact;
+ extern doublereal dget06_(doublereal *, doublereal *);
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ doublereal rcond, roldc;
+ extern /* Subroutine */ int dgbsv_(integer *, integer *, integer *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ integer nimat;
+ doublereal roldi, anorm;
+ integer itran;
+ logical equil;
+ doublereal roldo;
+ char trans[1];
+ integer izero, nerrs;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), aladhd_(integer *,
+ char *);
+ extern doublereal dlangb_(char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *), dlamch_(char *), dlange_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dlaqgb_(integer *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, char *),
+ alaerh_(char *, char *, integer *, integer *, char *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *);
+ logical prefac;
+ doublereal colcnd;
+ extern doublereal dlantb_(char *, char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dgbequ_(integer *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ doublereal rcondc;
+ logical nofact;
+ extern /* Subroutine */ int dgbtrf_(integer *, integer *, integer *,
+ integer *, doublereal *, integer *, integer *, integer *);
+ integer iequed;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ doublereal rcondi;
+ extern /* Subroutine */ int dlarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *, doublereal
+ *, integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *), dlaset_(
+ char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), alasvm_(char *, integer *,
+ integer *, integer *, integer *);
+ doublereal cndnum, anormi, rcondo, ainvnm;
+ extern /* Subroutine */ int dgbtrs_(char *, integer *, integer *, integer
+ *, integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), dlatms_(integer *, integer *, char
+ *, integer *, char *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *, char *, doublereal *, integer
+ *, doublereal *, integer *);
+ logical trfcon;
+ doublereal anormo, rowcnd;
+ extern /* Subroutine */ int dgbsvx_(char *, char *, integer *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *, char *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *), xlaenv_(integer *, integer *);
+ doublereal anrmpv;
+ extern /* Subroutine */ int derrvx_(char *, integer *);
+ doublereal result[7], rpvgrw;
+
+ /* Fortran I/O blocks */
+ static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___72 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___73 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___74 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___75 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___76 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___77 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVGB tests the driver routines DGBSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (LA) */
+
+/* LA (input) INTEGER */
+/* The length of the array A. LA >= (2*NMAX-1)*NMAX */
+/* where NMAX is the largest entry in NVAL. */
+
+/* AFB (workspace) DOUBLE PRECISION array, dimension (LAFB) */
+
+/* LAFB (input) INTEGER */
+/* The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX */
+/* where NMAX is the largest entry in NVAL. */
+
+/* ASAV (workspace) DOUBLE PRECISION array, dimension (LA) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension (2*NMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NRHS,NMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NRHS)) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afb;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "GB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ ldb = max(n,1);
+ *(unsigned char *)xtype = 'N';
+
+/* Set limits on the number of loop iterations. */
+
+/* Computing MAX */
+ i__2 = 1, i__3 = min(n,4);
+ nkl = max(i__2,i__3);
+ if (n == 0) {
+ nkl = 1;
+ }
+ nku = nkl;
+ nimat = 8;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nkl;
+ for (ikl = 1; ikl <= i__2; ++ikl) {
+
+/* Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes */
+/* it easier to skip redundant values for small values of N. */
+
+ if (ikl == 1) {
+ kl = 0;
+ } else if (ikl == 2) {
+/* Computing MAX */
+ i__3 = n - 1;
+ kl = max(i__3,0);
+ } else if (ikl == 3) {
+ kl = (n * 3 - 1) / 4;
+ } else if (ikl == 4) {
+ kl = (n + 1) / 4;
+ }
+ i__3 = nku;
+ for (iku = 1; iku <= i__3; ++iku) {
+
+/* Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order */
+/* makes it easier to skip redundant values for small */
+/* values of N. */
+
+ if (iku == 1) {
+ ku = 0;
+ } else if (iku == 2) {
+/* Computing MAX */
+ i__4 = n - 1;
+ ku = max(i__4,0);
+ } else if (iku == 3) {
+ ku = (n * 3 - 1) / 4;
+ } else if (iku == 4) {
+ ku = (n + 1) / 4;
+ }
+
+/* Check that A and AFB are big enough to generate this */
+/* matrix. */
+
+ lda = kl + ku + 1;
+ ldafb = (kl << 1) + ku + 1;
+ if (lda * n > *la || ldafb * n > *lafb) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (lda * n > *la) {
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, (char *)&(*la), (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ i__4 = n * (kl + ku + 1);
+ do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ if (ldafb * n > *lafb) {
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__1, (char *)&(*lafb), (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ i__4 = n * ((kl << 1) + ku + 1);
+ do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ goto L130;
+ }
+
+ i__4 = nimat;
+ for (imat = 1; imat <= i__4; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+/* Skip types 2, 3, or 4 if the matrix is too small. */
+
+ zerot = imat >= 2 && imat <= 4;
+ if (zerot && n < imat - 1) {
+ goto L120;
+ }
+
+/* Set up parameters with DLATB4 and generate a */
+/* test matrix with DLATMS. */
+
+ dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
+ mode, &cndnum, dist);
+ rcondc = 1. / cndnum;
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "Z", &a[1], &lda, &work[
+ 1], &info);
+
+/* Check the error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, " ", &n, &n, &
+ kl, &ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L120;
+ }
+
+/* For types 2, 3, and 4, zero one or more columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ izero = 0;
+ if (zerot) {
+ if (imat == 2) {
+ izero = 1;
+ } else if (imat == 3) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 4) {
+/* Computing MAX */
+ i__5 = 1, i__6 = ku + 2 - izero;
+ i1 = max(i__5,i__6);
+/* Computing MIN */
+ i__5 = kl + ku + 1, i__6 = ku + 1 + (n - izero);
+ i2 = min(i__5,i__6);
+ i__5 = i2;
+ for (i__ = i1; i__ <= i__5; ++i__) {
+ a[ioff + i__] = 0.;
+/* L20: */
+ }
+ } else {
+ i__5 = n;
+ for (j = izero; j <= i__5; ++j) {
+/* Computing MAX */
+ i__6 = 1, i__7 = ku + 2 - j;
+/* Computing MIN */
+ i__9 = kl + ku + 1, i__10 = ku + 1 + (n - j);
+ i__8 = min(i__9,i__10);
+ for (i__ = max(i__6,i__7); i__ <= i__8; ++i__)
+ {
+ a[ioff + i__] = 0.;
+/* L30: */
+ }
+ ioff += lda;
+/* L40: */
+ }
+ }
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ i__5 = kl + ku + 1;
+ dlacpy_("Full", &i__5, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 4; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__5 = nfact;
+ for (ifact = 1; ifact <= i__5; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L100;
+ }
+ rcondo = 0.;
+ rcondi = 0.;
+
+ } else if (! nofact) {
+
+/* Compute the condition number for comparison */
+/* with the value returned by DGESVX (FACT = */
+/* 'N' reuses the condition number from the */
+/* previous iteration with FACT = 'F'). */
+
+ i__8 = kl + ku + 1;
+ dlacpy_("Full", &i__8, &n, &asav[1], &lda, &
+ afb[kl + 1], &ldafb);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ dgbequ_(&n, &n, &kl, &ku, &afb[kl + 1], &
+ ldafb, &s[1], &s[n + 1], &rowcnd,
+ &colcnd, &amax, &info);
+ if (info == 0 && n > 0) {
+ if (lsame_(equed, "R")) {
+ rowcnd = 0.;
+ colcnd = 1.;
+ } else if (lsame_(equed, "C")) {
+ rowcnd = 1.;
+ colcnd = 0.;
+ } else if (lsame_(equed, "B")) {
+ rowcnd = 0.;
+ colcnd = 0.;
+ }
+
+/* Equilibrate the matrix. */
+
+ dlaqgb_(&n, &n, &kl, &ku, &afb[kl + 1]
+, &ldafb, &s[1], &s[n + 1], &
+ rowcnd, &colcnd, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in DGET04. */
+
+ if (equil) {
+ roldo = rcondo;
+ roldi = rcondi;
+ }
+
+/* Compute the 1-norm and infinity-norm of A. */
+
+ anormo = dlangb_("1", &n, &kl, &ku, &afb[kl +
+ 1], &ldafb, &rwork[1]);
+ anormi = dlangb_("I", &n, &kl, &ku, &afb[kl +
+ 1], &ldafb, &rwork[1]);
+
+/* Factor the matrix A. */
+
+ dgbtrf_(&n, &n, &kl, &ku, &afb[1], &ldafb, &
+ iwork[1], &info);
+
+/* Form the inverse of A. */
+
+ dlaset_("Full", &n, &n, &c_b48, &c_b49, &work[
+ 1], &ldb);
+ s_copy(srnamc_1.srnamt, "DGBTRS", (ftnlen)32,
+ (ftnlen)6);
+ dgbtrs_("No transpose", &n, &kl, &ku, &n, &
+ afb[1], &ldafb, &iwork[1], &work[1], &
+ ldb, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = dlange_("1", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormo <= 0. || ainvnm <= 0.) {
+ rcondo = 1.;
+ } else {
+ rcondo = 1. / anormo / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number */
+/* of A. */
+
+ ainvnm = dlange_("I", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormi <= 0. || ainvnm <= 0.) {
+ rcondi = 1.;
+ } else {
+ rcondi = 1. / anormi / ainvnm;
+ }
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for each value of TRANS. */
+
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Restore the matrix A. */
+
+ i__8 = kl + ku + 1;
+ dlacpy_("Full", &i__8, &n, &asav[1], &lda, &a[
+ 1], &lda);
+
+/* Form an exact solution and set the right hand */
+/* side. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32,
+ (ftnlen)6);
+ dlarhs_(path, xtype, "Full", trans, &n, &n, &
+ kl, &ku, nrhs, &a[1], &lda, &xact[1],
+ &ldb, &b[1], &ldb, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ dlacpy_("Full", &n, nrhs, &b[1], &ldb, &bsav[
+ 1], &ldb);
+
+ if (nofact && itran == 1) {
+
+/* --- Test DGBSV --- */
+
+/* Compute the LU factorization of the matrix */
+/* and solve the system. */
+
+ i__8 = kl + ku + 1;
+ dlacpy_("Full", &i__8, &n, &a[1], &lda, &
+ afb[kl + 1], &ldafb);
+ dlacpy_("Full", &n, nrhs, &b[1], &ldb, &x[
+ 1], &ldb);
+
+ s_copy(srnamc_1.srnamt, "DGBSV ", (ftnlen)
+ 32, (ftnlen)6);
+ dgbsv_(&n, &kl, &ku, nrhs, &afb[1], &
+ ldafb, &iwork[1], &x[1], &ldb, &
+ info);
+
+/* Check error code from DGBSV . */
+
+ if (info != izero) {
+ alaerh_(path, "DGBSV ", &info, &izero,
+ " ", &n, &n, &kl, &ku, nrhs,
+ &imat, &nfail, &nerrs, nout);
+ }
+
+/* Reconstruct matrix from factors and */
+/* compute residual. */
+
+ dgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
+ afb[1], &ldafb, &iwork[1], &work[
+ 1], result);
+ nt = 1;
+ if (izero == 0) {
+
+/* Compute residual of the computed */
+/* solution. */
+
+ dlacpy_("Full", &n, nrhs, &b[1], &ldb,
+ &work[1], &ldb);
+ dgbt02_("No transpose", &n, &n, &kl, &
+ ku, nrhs, &a[1], &lda, &x[1],
+ &ldb, &work[1], &ldb, &result[
+ 1]);
+
+/* Check solution from generated exact */
+/* solution. */
+
+ dget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &rcondc, &result[2])
+ ;
+ nt = 3;
+ }
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ i__8 = nt;
+ for (k = 1; k <= i__8; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___65.ciunit = *nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, "DGBSV ", (ftnlen)6)
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k -
+ 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L50: */
+ }
+ nrun += nt;
+ }
+
+/* --- Test DGBSVX --- */
+
+ if (! prefac) {
+ i__8 = (kl << 1) + ku + 1;
+ dlaset_("Full", &i__8, &n, &c_b48, &c_b48,
+ &afb[1], &ldafb);
+ }
+ dlaset_("Full", &n, nrhs, &c_b48, &c_b48, &x[
+ 1], &ldb);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ dlaqgb_(&n, &n, &kl, &ku, &a[1], &lda, &s[
+ 1], &s[n + 1], &rowcnd, &colcnd, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition */
+/* number and error bounds using DGBSVX. */
+
+ s_copy(srnamc_1.srnamt, "DGBSVX", (ftnlen)32,
+ (ftnlen)6);
+ dgbsvx_(fact, trans, &n, &kl, &ku, nrhs, &a[1]
+, &lda, &afb[1], &ldafb, &iwork[1],
+ equed, &s[1], &s[n + 1], &b[1], &ldb,
+ &x[1], &ldb, &rcond, &rwork[1], &
+ rwork[*nrhs + 1], &work[1], &iwork[n
+ + 1], &info);
+
+/* Check the error code from DGBSVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__11[0] = 1, a__1[0] = fact;
+ i__11[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__11, &c__2, (ftnlen)
+ 2);
+ alaerh_(path, "DGBSVX", &info, &izero,
+ ch__1, &n, &n, &kl, &ku, nrhs, &
+ imat, &nfail, &nerrs, nout);
+ }
+
+/* Compare WORK(1) from DGBSVX with the computed */
+/* reciprocal pivot growth factor RPVGRW */
+
+ if (info != 0) {
+ anrmpv = 0.;
+ i__8 = info;
+ for (j = 1; j <= i__8; ++j) {
+/* Computing MAX */
+ i__6 = ku + 2 - j;
+/* Computing MIN */
+ i__9 = n + ku + 1 - j, i__10 = kl +
+ ku + 1;
+ i__7 = min(i__9,i__10);
+ for (i__ = max(i__6,1); i__ <= i__7;
+ ++i__) {
+/* Computing MAX */
+ d__2 = anrmpv, d__3 = (d__1 = a[
+ i__ + (j - 1) * lda], abs(
+ d__1));
+ anrmpv = max(d__2,d__3);
+/* L60: */
+ }
+/* L70: */
+ }
+/* Computing MIN */
+ i__7 = info - 1, i__6 = kl + ku;
+ i__8 = min(i__7,i__6);
+/* Computing MAX */
+ i__9 = 1, i__10 = kl + ku + 2 - info;
+ rpvgrw = dlantb_("M", "U", "N", &info, &
+ i__8, &afb[max(i__9, i__10)], &
+ ldafb, &work[1]);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = anrmpv / rpvgrw;
+ }
+ } else {
+ i__8 = kl + ku;
+ rpvgrw = dlantb_("M", "U", "N", &n, &i__8,
+ &afb[1], &ldafb, &work[1]);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = dlangb_("M", &n, &kl, &ku, &
+ a[1], &lda, &work[1]) / rpvgrw;
+ }
+ }
+ result[6] = (d__1 = rpvgrw - work[1], abs(
+ d__1)) / max(work[1],rpvgrw) /
+ dlamch_("E");
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and */
+/* compute residual. */
+
+ dgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
+ afb[1], &ldafb, &iwork[1], &work[
+ 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ dlacpy_("Full", &n, nrhs, &bsav[1], &ldb,
+ &work[1], &ldb);
+ dgbt02_(trans, &n, &n, &kl, &ku, nrhs, &
+ asav[1], &lda, &x[1], &ldb, &work[
+ 1], &ldb, &result[1]);
+
+/* Check solution from generated exact */
+/* solution. */
+
+ if (nofact || prefac && lsame_(equed,
+ "N")) {
+ dget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &rcondc, &result[2])
+ ;
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ dget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ dgbt05_(trans, &n, &kl, &ku, nrhs, &asav[
+ 1], &lda, &b[1], &ldb, &x[1], &
+ ldb, &xact[1], &ldb, &rwork[1], &
+ rwork[*nrhs + 1], &result[3]);
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from DGBSVX with the computed */
+/* value in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___72.ciunit = *nout;
+ s_wsfe(&io___72);
+ do_fio(&c__1, "DGBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___73.ciunit = *nout;
+ s_wsfe(&io___73);
+ do_fio(&c__1, "DGBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___74.ciunit = *nout;
+ s_wsfe(&io___74);
+ do_fio(&c__1, "DGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ } else {
+ io___75.ciunit = *nout;
+ s_wsfe(&io___75);
+ do_fio(&c__1, "DGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___76.ciunit = *nout;
+ s_wsfe(&io___76);
+ do_fio(&c__1, "DGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ } else {
+ io___77.ciunit = *nout;
+ s_wsfe(&io___77);
+ do_fio(&c__1, "DGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___78.ciunit = *nout;
+ s_wsfe(&io___78);
+ do_fio(&c__1, "DGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ } else {
+ io___79.ciunit = *nout;
+ s_wsfe(&io___79);
+ do_fio(&c__1, "DGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+
+ }
+/* L90: */
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+
+ return 0;
+
+/* End of DDRVGB */
+
+} /* ddrvgb_ */
diff --git a/TESTING/LIN/ddrvgbx.c b/TESTING/LIN/ddrvgbx.c
new file mode 100644
index 0000000..8efbf96
--- /dev/null
+++ b/TESTING/LIN/ddrvgbx.c
@@ -0,0 +1,1489 @@
+/* ddrvgbx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "memory_alloc.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublereal c_b48 = 0.;
+static doublereal c_b49 = 1.;
+static integer c__6 = 6;
+static integer c__7 = 7;
+
+/* Subroutine */ int ddrvgb_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, doublereal *a,
+ integer *la, doublereal *afb, integer *lafb, doublereal *asav,
+ doublereal *b, doublereal *bsav, doublereal *x, doublereal *xact,
+ doublereal *s, doublereal *work, doublereal *rwork, integer *iwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*4] = "N" "R" "C" "B";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 *** In DDRVGB, LA=\002,i5,\002 is too sm"
+ "all for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> In"
+ "crease LA to at least \002,i5)";
+ static char fmt_9998[] = "(\002 *** In DDRVGB, LAFB=\002,i5,\002 is too "
+ "small for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> "
+ "Increase LAFB to at least \002,i5)";
+ static char fmt_9997[] = "(1x,a,\002, N=\002,i5,\002, KL=\002,i5,\002, K"
+ "U=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)"
+ ;
+ static char fmt_9995[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002"
+ ",i5,\002,\002,i5,\002,\002,i5,\002,...), EQUED='\002,a1,\002', t"
+ "ype \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002"
+ ",i5,\002,\002,i5,\002,\002,i5,\002,...), type \002,i1,\002, test("
+ "\002,i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10,
+ i__11[2];
+ doublereal d__1, d__2, d__3;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ extern /* Subroutine */ int debchvxx_(doublereal *, char *);
+ integer i__, j, k, n;
+ doublereal *errbnds_c__;
+ integer i1, i2, k1;
+ doublereal *errbnds_n__;
+ integer nb, in, kl, ku, nt, n_err_bnds__, lda, ldb, ikl, nkl, iku, nku;
+ char fact[1];
+ integer ioff, mode;
+ doublereal amax;
+ char path[3];
+ integer imat, info;
+ doublereal *berr;
+ char dist[1];
+ doublereal rpvgrw_svxx__;
+ char type__[1];
+ integer nrun;
+ extern doublereal dla_gbrpvgrw__(integer *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, integer *);
+ integer ldafb;
+ extern /* Subroutine */ int dgbt01_(integer *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, doublereal *, doublereal *), dgbt02_(), dgbt05_(char *,
+ integer *, integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *);
+ integer ifact;
+ extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *);
+ integer nfail, iseed[4], nfact;
+ extern doublereal dget06_(doublereal *, doublereal *);
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ doublereal rcond, roldc;
+ extern /* Subroutine */ int dgbsv_(integer *, integer *, integer *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ integer nimat;
+ doublereal roldi, anorm;
+ integer itran;
+ logical equil;
+ doublereal roldo;
+ char trans[1];
+ integer izero, nerrs;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), aladhd_(integer *,
+ char *);
+ extern doublereal dlangb_(char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *), dlamch_(char *), dlange_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dlaqgb_(integer *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, char *),
+ alaerh_(char *, char *, integer *, integer *, char *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *);
+ logical prefac;
+ doublereal colcnd;
+ extern doublereal dlantb_(char *, char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dgbequ_(integer *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ doublereal rcondc;
+ logical nofact;
+ extern /* Subroutine */ int dgbtrf_(integer *, integer *, integer *,
+ integer *, doublereal *, integer *, integer *, integer *);
+ integer iequed;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ doublereal rcondi;
+ extern /* Subroutine */ int dlarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *, doublereal
+ *, integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *), dlaset_(
+ char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), alasvm_(char *, integer *,
+ integer *, integer *, integer *);
+ doublereal cndnum, anormi, rcondo, ainvnm;
+ extern /* Subroutine */ int dgbtrs_(char *, integer *, integer *, integer
+ *, integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), dlatms_(integer *, integer *, char
+ *, integer *, char *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *, char *, doublereal *, integer
+ *, doublereal *, integer *);
+ logical trfcon;
+ doublereal anormo, rowcnd;
+ extern /* Subroutine */ int dgbsvx_(char *, char *, integer *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *, char *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *), xlaenv_(integer *, integer *);
+ doublereal anrmpv;
+ extern /* Subroutine */ int derrvx_(char *, integer *);
+ doublereal result[7], rpvgrw;
+ extern /* Subroutine */ int dgbsvxx_(char *, char *, integer *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *, char *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___72 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___73 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___74 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___75 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___76 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___77 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___85 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___86 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___87 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___88 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___89 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___90 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___91 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___92 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVGB tests the driver routines DGBSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (LA) */
+
+/* LA (input) INTEGER */
+/* The length of the array A. LA >= (2*NMAX-1)*NMAX */
+/* where NMAX is the largest entry in NVAL. */
+
+/* AFB (workspace) DOUBLE PRECISION array, dimension (LAFB) */
+
+/* LAFB (input) INTEGER */
+/* The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX */
+/* where NMAX is the largest entry in NVAL. */
+
+/* ASAV (workspace) DOUBLE PRECISION array, dimension (LA) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension (2*NMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NRHS,NMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NRHS)) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afb;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "GB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ ldb = max(n,1);
+ *(unsigned char *)xtype = 'N';
+
+/* Set limits on the number of loop iterations. */
+
+/* Computing MAX */
+ i__2 = 1, i__3 = min(n,4);
+ nkl = max(i__2,i__3);
+ if (n == 0) {
+ nkl = 1;
+ }
+ nku = nkl;
+ nimat = 8;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nkl;
+ for (ikl = 1; ikl <= i__2; ++ikl) {
+
+/* Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes */
+/* it easier to skip redundant values for small values of N. */
+
+ if (ikl == 1) {
+ kl = 0;
+ } else if (ikl == 2) {
+/* Computing MAX */
+ i__3 = n - 1;
+ kl = max(i__3,0);
+ } else if (ikl == 3) {
+ kl = (n * 3 - 1) / 4;
+ } else if (ikl == 4) {
+ kl = (n + 1) / 4;
+ }
+ i__3 = nku;
+ for (iku = 1; iku <= i__3; ++iku) {
+
+/* Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order */
+/* makes it easier to skip redundant values for small */
+/* values of N. */
+
+ if (iku == 1) {
+ ku = 0;
+ } else if (iku == 2) {
+/* Computing MAX */
+ i__4 = n - 1;
+ ku = max(i__4,0);
+ } else if (iku == 3) {
+ ku = (n * 3 - 1) / 4;
+ } else if (iku == 4) {
+ ku = (n + 1) / 4;
+ }
+
+/* Check that A and AFB are big enough to generate this */
+/* matrix. */
+
+ lda = kl + ku + 1;
+ ldafb = (kl << 1) + ku + 1;
+ if (lda * n > *la || ldafb * n > *lafb) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (lda * n > *la) {
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, (char *)&(*la), (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ i__4 = n * (kl + ku + 1);
+ do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ if (ldafb * n > *lafb) {
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__1, (char *)&(*lafb), (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ i__4 = n * ((kl << 1) + ku + 1);
+ do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ goto L130;
+ }
+
+ i__4 = nimat;
+ for (imat = 1; imat <= i__4; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+/* Skip types 2, 3, or 4 if the matrix is too small. */
+
+ zerot = imat >= 2 && imat <= 4;
+ if (zerot && n < imat - 1) {
+ goto L120;
+ }
+
+/* Set up parameters with DLATB4 and generate a */
+/* test matrix with DLATMS. */
+
+ dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
+ mode, &cndnum, dist);
+ rcondc = 1. / cndnum;
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "Z", &a[1], &lda, &work[
+ 1], &info);
+
+/* Check the error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, " ", &n, &n, &
+ kl, &ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L120;
+ }
+
+/* For types 2, 3, and 4, zero one or more columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ izero = 0;
+ if (zerot) {
+ if (imat == 2) {
+ izero = 1;
+ } else if (imat == 3) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 4) {
+/* Computing MAX */
+ i__5 = 1, i__6 = ku + 2 - izero;
+ i1 = max(i__5,i__6);
+/* Computing MIN */
+ i__5 = kl + ku + 1, i__6 = ku + 1 + (n - izero);
+ i2 = min(i__5,i__6);
+ i__5 = i2;
+ for (i__ = i1; i__ <= i__5; ++i__) {
+ a[ioff + i__] = 0.;
+/* L20: */
+ }
+ } else {
+ i__5 = n;
+ for (j = izero; j <= i__5; ++j) {
+/* Computing MAX */
+ i__6 = 1, i__7 = ku + 2 - j;
+/* Computing MIN */
+ i__9 = kl + ku + 1, i__10 = ku + 1 + (n - j);
+ i__8 = min(i__9,i__10);
+ for (i__ = max(i__6,i__7); i__ <= i__8; ++i__)
+ {
+ a[ioff + i__] = 0.;
+/* L30: */
+ }
+ ioff += lda;
+/* L40: */
+ }
+ }
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ i__5 = kl + ku + 1;
+ dlacpy_("Full", &i__5, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 4; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__5 = nfact;
+ for (ifact = 1; ifact <= i__5; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L100;
+ }
+ rcondo = 0.;
+ rcondi = 0.;
+
+ } else if (! nofact) {
+
+/* Compute the condition number for comparison */
+/* with the value returned by DGESVX (FACT = */
+/* 'N' reuses the condition number from the */
+/* previous iteration with FACT = 'F'). */
+
+ i__8 = kl + ku + 1;
+ dlacpy_("Full", &i__8, &n, &asav[1], &lda, &
+ afb[kl + 1], &ldafb);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ dgbequ_(&n, &n, &kl, &ku, &afb[kl + 1], &
+ ldafb, &s[1], &s[n + 1], &rowcnd,
+ &colcnd, &amax, &info);
+ if (info == 0 && n > 0) {
+ if (lsame_(equed, "R")) {
+ rowcnd = 0.;
+ colcnd = 1.;
+ } else if (lsame_(equed, "C")) {
+ rowcnd = 1.;
+ colcnd = 0.;
+ } else if (lsame_(equed, "B")) {
+ rowcnd = 0.;
+ colcnd = 0.;
+ }
+
+/* Equilibrate the matrix. */
+
+ dlaqgb_(&n, &n, &kl, &ku, &afb[kl + 1]
+, &ldafb, &s[1], &s[n + 1], &
+ rowcnd, &colcnd, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in DGET04. */
+
+ if (equil) {
+ roldo = rcondo;
+ roldi = rcondi;
+ }
+
+/* Compute the 1-norm and infinity-norm of A. */
+
+ anormo = dlangb_("1", &n, &kl, &ku, &afb[kl +
+ 1], &ldafb, &rwork[1]);
+ anormi = dlangb_("I", &n, &kl, &ku, &afb[kl +
+ 1], &ldafb, &rwork[1]);
+
+/* Factor the matrix A. */
+
+ dgbtrf_(&n, &n, &kl, &ku, &afb[1], &ldafb, &
+ iwork[1], &info);
+
+/* Form the inverse of A. */
+
+ dlaset_("Full", &n, &n, &c_b48, &c_b49, &work[
+ 1], &ldb);
+ s_copy(srnamc_1.srnamt, "DGBTRS", (ftnlen)32,
+ (ftnlen)6);
+ dgbtrs_("No transpose", &n, &kl, &ku, &n, &
+ afb[1], &ldafb, &iwork[1], &work[1], &
+ ldb, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = dlange_("1", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormo <= 0. || ainvnm <= 0.) {
+ rcondo = 1.;
+ } else {
+ rcondo = 1. / anormo / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number */
+/* of A. */
+
+ ainvnm = dlange_("I", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormi <= 0. || ainvnm <= 0.) {
+ rcondi = 1.;
+ } else {
+ rcondi = 1. / anormi / ainvnm;
+ }
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for each value of TRANS. */
+
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Restore the matrix A. */
+
+ i__8 = kl + ku + 1;
+ dlacpy_("Full", &i__8, &n, &asav[1], &lda, &a[
+ 1], &lda);
+
+/* Form an exact solution and set the right hand */
+/* side. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32,
+ (ftnlen)6);
+ dlarhs_(path, xtype, "Full", trans, &n, &n, &
+ kl, &ku, nrhs, &a[1], &lda, &xact[1],
+ &ldb, &b[1], &ldb, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ dlacpy_("Full", &n, nrhs, &b[1], &ldb, &bsav[
+ 1], &ldb);
+
+ if (nofact && itran == 1) {
+
+/* --- Test DGBSV --- */
+
+/* Compute the LU factorization of the matrix */
+/* and solve the system. */
+
+ i__8 = kl + ku + 1;
+ dlacpy_("Full", &i__8, &n, &a[1], &lda, &
+ afb[kl + 1], &ldafb);
+ dlacpy_("Full", &n, nrhs, &b[1], &ldb, &x[
+ 1], &ldb);
+
+ s_copy(srnamc_1.srnamt, "DGBSV ", (ftnlen)
+ 32, (ftnlen)6);
+ dgbsv_(&n, &kl, &ku, nrhs, &afb[1], &
+ ldafb, &iwork[1], &x[1], &ldb, &
+ info);
+
+/* Check error code from DGBSV . */
+
+ if (info == n + 1) {
+ goto L90;
+ }
+ if (info != izero) {
+ alaerh_(path, "DGBSV ", &info, &izero,
+ " ", &n, &n, &kl, &ku, nrhs,
+ &imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+
+/* Reconstruct matrix from factors and */
+/* compute residual. */
+
+ dgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
+ afb[1], &ldafb, &iwork[1], &work[
+ 1], result);
+ nt = 1;
+ if (izero == 0) {
+
+/* Compute residual of the computed */
+/* solution. */
+
+ dlacpy_("Full", &n, nrhs, &b[1], &ldb,
+ &work[1], &ldb);
+ dgbt02_("No transpose", &n, &n, &kl, &
+ ku, nrhs, &a[1], &lda, &x[1],
+ &ldb, &work[1], &ldb, &result[
+ 1]);
+
+/* Check solution from generated exact */
+/* solution. */
+
+ dget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &rcondc, &result[2])
+ ;
+ nt = 3;
+ }
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ i__8 = nt;
+ for (k = 1; k <= i__8; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___65.ciunit = *nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, "DGBSV ", (ftnlen)6)
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k -
+ 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L50: */
+ }
+ nrun += nt;
+ }
+
+/* --- Test DGBSVX --- */
+
+ if (! prefac) {
+ i__8 = (kl << 1) + ku + 1;
+ dlaset_("Full", &i__8, &n, &c_b48, &c_b48,
+ &afb[1], &ldafb);
+ }
+ dlaset_("Full", &n, nrhs, &c_b48, &c_b48, &x[
+ 1], &ldb);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ dlaqgb_(&n, &n, &kl, &ku, &a[1], &lda, &s[
+ 1], &s[n + 1], &rowcnd, &colcnd, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition */
+/* number and error bounds using DGBSVX. */
+
+ s_copy(srnamc_1.srnamt, "DGBSVX", (ftnlen)32,
+ (ftnlen)6);
+ dgbsvx_(fact, trans, &n, &kl, &ku, nrhs, &a[1]
+, &lda, &afb[1], &ldafb, &iwork[1],
+ equed, &s[1], &s[n + 1], &b[1], &ldb,
+ &x[1], &ldb, &rcond, &rwork[1], &
+ rwork[*nrhs + 1], &work[1], &iwork[n
+ + 1], &info);
+
+/* Check the error code from DGBSVX. */
+
+ if (info == n + 1) {
+ goto L90;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__11[0] = 1, a__1[0] = fact;
+ i__11[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__11, &c__2, (ftnlen)
+ 2);
+ alaerh_(path, "DGBSVX", &info, &izero,
+ ch__1, &n, &n, &kl, &ku, nrhs, &
+ imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+
+/* Compare WORK(1) from DGBSVX with the computed */
+/* reciprocal pivot growth factor RPVGRW */
+
+ if (info != 0) {
+ anrmpv = 0.;
+ i__8 = info;
+ for (j = 1; j <= i__8; ++j) {
+/* Computing MAX */
+ i__6 = ku + 2 - j;
+/* Computing MIN */
+ i__9 = n + ku + 1 - j, i__10 = kl +
+ ku + 1;
+ i__7 = min(i__9,i__10);
+ for (i__ = max(i__6,1); i__ <= i__7;
+ ++i__) {
+/* Computing MAX */
+ d__2 = anrmpv, d__3 = (d__1 = a[
+ i__ + (j - 1) * lda], abs(
+ d__1));
+ anrmpv = max(d__2,d__3);
+/* L60: */
+ }
+/* L70: */
+ }
+/* Computing MIN */
+ i__7 = info - 1, i__6 = kl + ku;
+ i__8 = min(i__7,i__6);
+/* Computing MAX */
+ i__9 = 1, i__10 = kl + ku + 2 - info;
+ rpvgrw = dlantb_("M", "U", "N", &info, &
+ i__8, &afb[max(i__9, i__10)], &
+ ldafb, &work[1]);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = anrmpv / rpvgrw;
+ }
+ } else {
+ i__8 = kl + ku;
+ rpvgrw = dlantb_("M", "U", "N", &n, &i__8,
+ &afb[1], &ldafb, &work[1]);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = dlangb_("M", &n, &kl, &ku, &
+ a[1], &lda, &work[1]) / rpvgrw;
+ }
+ }
+ result[6] = (d__1 = rpvgrw - work[1], abs(
+ d__1)) / max(work[1],rpvgrw) /
+ dlamch_("E");
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and */
+/* compute residual. */
+
+ dgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
+ afb[1], &ldafb, &iwork[1], &work[
+ 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ dlacpy_("Full", &n, nrhs, &bsav[1], &ldb,
+ &work[1], &ldb);
+ dgbt02_(trans, &n, &n, &kl, &ku, nrhs, &
+ asav[1], &lda, &x[1], &ldb, &work[
+ 1], &ldb, &result[1]);
+
+/* Check solution from generated exact */
+/* solution. */
+
+ if (nofact || prefac && lsame_(equed,
+ "N")) {
+ dget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &rcondc, &result[2])
+ ;
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ dget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ dgbt05_(trans, &n, &kl, &ku, nrhs, &asav[
+ 1], &lda, &b[1], &ldb, &x[1], &
+ ldb, &xact[1], &ldb, &rwork[1], &
+ rwork[*nrhs + 1], &result[3]);
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from DGBSVX with the computed */
+/* value in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___72.ciunit = *nout;
+ s_wsfe(&io___72);
+ do_fio(&c__1, "DGBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___73.ciunit = *nout;
+ s_wsfe(&io___73);
+ do_fio(&c__1, "DGBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___74.ciunit = *nout;
+ s_wsfe(&io___74);
+ do_fio(&c__1, "DGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ } else {
+ io___75.ciunit = *nout;
+ s_wsfe(&io___75);
+ do_fio(&c__1, "DGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___76.ciunit = *nout;
+ s_wsfe(&io___76);
+ do_fio(&c__1, "DGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ } else {
+ io___77.ciunit = *nout;
+ s_wsfe(&io___77);
+ do_fio(&c__1, "DGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___78.ciunit = *nout;
+ s_wsfe(&io___78);
+ do_fio(&c__1, "DGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ } else {
+ io___79.ciunit = *nout;
+ s_wsfe(&io___79);
+ do_fio(&c__1, "DGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+
+ }
+
+/* --- Test DGBSVXX --- */
+
+/* Restore the matrices A and B. */
+
+ i__8 = kl + ku + 1;
+ dlacpy_("Full", &i__8, &n, &asav[1], &lda, &a[
+ 1], &lda);
+ dlacpy_("Full", &n, nrhs, &bsav[1], &ldb, &b[
+ 1], &ldb);
+ if (! prefac) {
+ i__8 = (kl << 1) + ku + 1;
+ dlaset_("Full", &i__8, &n, &c_b48, &c_b48,
+ &afb[1], &ldafb);
+ }
+ dlaset_("Full", &n, nrhs, &c_b48, &c_b48, &x[
+ 1], &ldb);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ dlaqgb_(&n, &n, &kl, &ku, &a[1], &lda, &s[
+ 1], &s[n + 1], &rowcnd, &colcnd, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using DGBSVXX. */
+
+ s_copy(srnamc_1.srnamt, "DGBSVXX", (ftnlen)32,
+ (ftnlen)7);
+ n_err_bnds__ = 3;
+
+ dalloc3();
+
+ dgbsvxx_(fact, trans, &n, &kl, &ku, nrhs, &a[
+ 1], &lda, &afb[1], &ldafb, &iwork[1],
+ equed, &s[1], &s[n + 1], &b[1], &ldb,
+ &x[1], &ldb, &rcond, &rpvgrw_svxx__,
+ berr, &n_err_bnds__, errbnds_n__,
+ errbnds_c__, &c__0, &c_b48, &work[1],
+ &iwork[n + 1], &info);
+
+ free3();
+
+/* Check the error code from DGBSVXX. */
+
+ if (info == n + 1) {
+ goto L90;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__11[0] = 1, a__1[0] = fact;
+ i__11[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__11, &c__2, (ftnlen)
+ 2);
+ alaerh_(path, "DGBSVXX", &info, &izero,
+ ch__1, &n, &n, &c_n1, &c_n1, nrhs,
+ &imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+
+/* Compare rpvgrw_svxx from DGBSVXX with the computed */
+/* reciprocal pivot growth factor RPVGRW */
+
+ if (info > 0 && info < n + 1) {
+ rpvgrw = dla_gbrpvgrw__(&n, &kl, &ku, &
+ info, &a[1], &lda, &afb[1], &
+ ldafb);
+ } else {
+ rpvgrw = dla_gbrpvgrw__(&n, &kl, &ku, &n,
+ &a[1], &lda, &afb[1], &ldafb);
+ }
+ result[6] = (d__1 = rpvgrw - rpvgrw_svxx__,
+ abs(d__1)) / max(rpvgrw_svxx__,rpvgrw)
+ / dlamch_("E");
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ dgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
+ afb[1], &ldafb, &iwork[1], &work[
+ 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ dlacpy_("Full", &n, nrhs, &bsav[1], &ldb,
+ &work[1], &ldb);
+ dgbt02_(trans, &n, &n, &kl, &ku, nrhs, &
+ asav[1], &lda, &x[1], &ldb, &work[
+ 1], &ldb, &work[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed,
+ "N")) {
+ dget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &rcondc, &result[2])
+ ;
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ dget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &roldc, &result[2]);
+ }
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from DGBSVXX with the computed value */
+/* in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___85.ciunit = *nout;
+ s_wsfe(&io___85);
+ do_fio(&c__1, "DGBSVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___86.ciunit = *nout;
+ s_wsfe(&io___86);
+ do_fio(&c__1, "DGBSVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L45: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___87.ciunit = *nout;
+ s_wsfe(&io___87);
+ do_fio(&c__1, "DGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ } else {
+ io___88.ciunit = *nout;
+ s_wsfe(&io___88);
+ do_fio(&c__1, "DGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___89.ciunit = *nout;
+ s_wsfe(&io___89);
+ do_fio(&c__1, "DGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ } else {
+ io___90.ciunit = *nout;
+ s_wsfe(&io___90);
+ do_fio(&c__1, "DGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___91.ciunit = *nout;
+ s_wsfe(&io___91);
+ do_fio(&c__1, "DGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ } else {
+ io___92.ciunit = *nout;
+ s_wsfe(&io___92);
+ do_fio(&c__1, "DGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+
+ }
+L90:
+ ;
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+/* Test Error Bounds from DGBSVXX */
+ debchvxx_(thresh, path);
+
+ return 0;
+
+/* End of DDRVGB */
+
+} /* ddrvgb_ */
diff --git a/TESTING/LIN/ddrvge.c b/TESTING/LIN/ddrvge.c
new file mode 100644
index 0000000..b1d0d98
--- /dev/null
+++ b/TESTING/LIN/ddrvge.c
@@ -0,0 +1,902 @@
+/* ddrvge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublereal c_b20 = 0.;
+static logical c_true = TRUE_;
+static integer c__6 = 6;
+static integer c__7 = 7;
+
+/* Subroutine */ int ddrvge_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
+ doublereal *a, doublereal *afac, doublereal *asav, doublereal *b,
+ doublereal *bsav, doublereal *x, doublereal *xact, doublereal *s,
+ doublereal *work, doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*4] = "N" "R" "C" "B";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
+ ", test(\002,i2,\002) =\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
+ "1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i2,\002"
+ ", test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
+ "1,\002', N=\002,i5,\002, type \002,i2,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ doublereal d__1;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, k, n, k1, nb, in, kl, ku, nt, lda;
+ char fact[1];
+ integer ioff, mode;
+ doublereal amax;
+ char path[3];
+ integer imat, info;
+ char dist[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int dget01_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ doublereal *), dget02_(char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *);
+ integer ifact;
+ extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *);
+ integer nfail, iseed[4], nfact;
+ extern doublereal dget06_(doublereal *, doublereal *);
+ extern /* Subroutine */ int dget07_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, logical *,
+ doublereal *, doublereal *);
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ doublereal rcond, roldc;
+ integer nimat;
+ doublereal roldi;
+ extern /* Subroutine */ int dgesv_(integer *, integer *, doublereal *,
+ integer *, integer *, doublereal *, integer *, integer *);
+ doublereal anorm;
+ integer itran;
+ logical equil;
+ doublereal roldo;
+ char trans[1];
+ integer izero, nerrs, lwork;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), aladhd_(integer *,
+ char *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *), dlaqge_(integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, char *);
+ logical prefac;
+ doublereal colcnd, rcondc;
+ logical nofact;
+ integer iequed;
+ extern /* Subroutine */ int dgeequ_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *);
+ doublereal rcondi;
+ extern /* Subroutine */ int dgetrf_(integer *, integer *, doublereal *,
+ integer *, integer *, integer *), dgetri_(integer *, doublereal *,
+ integer *, integer *, doublereal *, integer *, integer *),
+ dlacpy_(char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *), alasvm_(char *, integer *,
+ integer *, integer *, integer *);
+ doublereal cndnum, anormi, rcondo, ainvnm;
+ extern doublereal dlantr_(char *, char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *, doublereal
+ *, integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *);
+ logical trfcon;
+ doublereal anormo, rowcnd;
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ dgesvx_(char *, char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, char *, doublereal
+ *, doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *
+, integer *), dlatms_(integer *, integer *
+, char *, integer *, char *, doublereal *, integer *, doublereal *
+, doublereal *, integer *, integer *, char *, doublereal *,
+ integer *, doublereal *, integer *),
+ xlaenv_(integer *, integer *), derrvx_(char *, integer *);
+ doublereal result[7], rpvgrw;
+
+ /* Fortran I/O blocks */
+ static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___68 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVGE tests the driver routines DGESV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension (2*NMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*NRHS+NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "GE", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 11;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L80;
+ }
+
+/* Skip types 5, 6, or 7 if the matrix size is too small. */
+
+ zerot = imat >= 5 && imat <= 7;
+ if (zerot && n < imat - 4) {
+ goto L80;
+ }
+
+/* Set up parameters with DLATB4 and generate a test matrix */
+/* with DLATMS. */
+
+ dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cndnum, dist);
+ rcondc = 1. / cndnum;
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cndnum, &
+ anorm, &kl, &ku, "No packing", &a[1], &lda, &work[1], &
+ info);
+
+/* Check error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, " ", &n, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L80;
+ }
+
+/* For types 5-7, zero one or more columns of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 5) {
+ izero = 1;
+ } else if (imat == 6) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 7) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.;
+/* L20: */
+ }
+ } else {
+ i__3 = n - izero + 1;
+ dlaset_("Full", &n, &i__3, &c_b20, &c_b20, &a[ioff + 1], &
+ lda);
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ dlacpy_("Full", &n, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 4; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[iequed -
+ 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__3 = nfact;
+ for (ifact = 1; ifact <= i__3; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[ifact -
+ 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L60;
+ }
+ rcondo = 0.;
+ rcondi = 0.;
+
+ } else if (! nofact) {
+
+/* Compute the condition number for comparison with */
+/* the value returned by DGESVX (FACT = 'N' reuses */
+/* the condition number from the previous iteration */
+/* with FACT = 'F'). */
+
+ dlacpy_("Full", &n, &n, &asav[1], &lda, &afac[1], &
+ lda);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ dgeequ_(&n, &n, &afac[1], &lda, &s[1], &s[n + 1],
+ &rowcnd, &colcnd, &amax, &info);
+ if (info == 0 && n > 0) {
+ if (lsame_(equed, "R"))
+ {
+ rowcnd = 0.;
+ colcnd = 1.;
+ } else if (lsame_(equed, "C")) {
+ rowcnd = 1.;
+ colcnd = 0.;
+ } else if (lsame_(equed, "B")) {
+ rowcnd = 0.;
+ colcnd = 0.;
+ }
+
+/* Equilibrate the matrix. */
+
+ dlaqge_(&n, &n, &afac[1], &lda, &s[1], &s[n +
+ 1], &rowcnd, &colcnd, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the non-equilibrated */
+/* system for use in DGET04. */
+
+ if (equil) {
+ roldo = rcondo;
+ roldi = rcondi;
+ }
+
+/* Compute the 1-norm and infinity-norm of A. */
+
+ anormo = dlange_("1", &n, &n, &afac[1], &lda, &rwork[
+ 1]);
+ anormi = dlange_("I", &n, &n, &afac[1], &lda, &rwork[
+ 1]);
+
+/* Factor the matrix A. */
+
+ dgetrf_(&n, &n, &afac[1], &lda, &iwork[1], &info);
+
+/* Form the inverse of A. */
+
+ dlacpy_("Full", &n, &n, &afac[1], &lda, &a[1], &lda);
+ lwork = *nmax * max(3,*nrhs);
+ dgetri_(&n, &a[1], &lda, &iwork[1], &work[1], &lwork,
+ &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = dlange_("1", &n, &n, &a[1], &lda, &rwork[1]);
+ if (anormo <= 0. || ainvnm <= 0.) {
+ rcondo = 1.;
+ } else {
+ rcondo = 1. / anormo / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ ainvnm = dlange_("I", &n, &n, &a[1], &lda, &rwork[1]);
+ if (anormi <= 0. || ainvnm <= 0.) {
+ rcondi = 1.;
+ } else {
+ rcondi = 1. / anormi / ainvnm;
+ }
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for each value of TRANS. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[
+ itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Restore the matrix A. */
+
+ dlacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ dlarhs_(path, xtype, "Full", trans, &n, &n, &kl, &ku,
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
+
+ if (nofact && itran == 1) {
+
+/* --- Test DGESV --- */
+
+/* Compute the LU factorization of the matrix and */
+/* solve the system. */
+
+ dlacpy_("Full", &n, &n, &a[1], &lda, &afac[1], &
+ lda);
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "DGESV ", (ftnlen)32, (
+ ftnlen)6);
+ dgesv_(&n, nrhs, &afac[1], &lda, &iwork[1], &x[1],
+ &lda, &info);
+
+/* Check error code from DGESV . */
+
+ if (info != izero) {
+ alaerh_(path, "DGESV ", &info, &izero, " ", &
+ n, &n, &c_n1, &c_n1, nrhs, &imat, &
+ nfail, &nerrs, nout);
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ dget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &rwork[1], result);
+ nt = 1;
+ if (izero == 0) {
+
+/* Compute residual of the computed solution. */
+
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[
+ 1], &lda);
+ dget02_("No transpose", &n, &n, nrhs, &a[1], &
+ lda, &x[1], &lda, &work[1], &lda, &
+ rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ nt = 3;
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___55.ciunit = *nout;
+ s_wsfe(&io___55);
+ do_fio(&c__1, "DGESV ", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L30: */
+ }
+ nrun += nt;
+ }
+
+/* --- Test DGESVX --- */
+
+ if (! prefac) {
+ dlaset_("Full", &n, &n, &c_b20, &c_b20, &afac[1],
+ &lda);
+ }
+ dlaset_("Full", &n, nrhs, &c_b20, &c_b20, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ dlaqge_(&n, &n, &a[1], &lda, &s[1], &s[n + 1], &
+ rowcnd, &colcnd, &amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using DGESVX. */
+
+ s_copy(srnamc_1.srnamt, "DGESVX", (ftnlen)32, (ftnlen)
+ 6);
+ dgesvx_(fact, trans, &n, nrhs, &a[1], &lda, &afac[1],
+ &lda, &iwork[1], equed, &s[1], &s[n + 1], &b[
+ 1], &lda, &x[1], &lda, &rcond, &rwork[1], &
+ rwork[*nrhs + 1], &work[1], &iwork[n + 1], &
+ info);
+
+/* Check the error code from DGESVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "DGESVX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+/* Compare WORK(1) from DGESVX with the computed */
+/* reciprocal pivot growth factor RPVGRW */
+
+ if (info != 0) {
+ rpvgrw = dlantr_("M", "U", "N", &info, &info, &
+ afac[1], &lda, &work[1]);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = dlange_("M", &n, &info, &a[1], &lda,
+ &work[1]) / rpvgrw;
+ }
+ } else {
+ rpvgrw = dlantr_("M", "U", "N", &n, &n, &afac[1],
+ &lda, &work[1]);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = dlange_("M", &n, &n, &a[1], &lda, &
+ work[1]) / rpvgrw;
+ }
+ }
+ result[6] = (d__1 = rpvgrw - work[1], abs(d__1)) /
+ max(work[1],rpvgrw) / dlamch_("E");
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ dget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &rwork[(*nrhs << 1) + 1],
+ result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ dlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ dget02_(trans, &n, &n, nrhs, &asav[1], &lda, &x[1]
+, &lda, &work[1], &lda, &rwork[(*nrhs <<
+ 1) + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ dget07_(trans, &n, nrhs, &asav[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &c_true, &rwork[*nrhs + 1], &result[3]
+);
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from DGESVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___61.ciunit = *nout;
+ s_wsfe(&io___61);
+ do_fio(&c__1, "DGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___62.ciunit = *nout;
+ s_wsfe(&io___62);
+ do_fio(&c__1, "DGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L40: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___63.ciunit = *nout;
+ s_wsfe(&io___63);
+ do_fio(&c__1, "DGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___64.ciunit = *nout;
+ s_wsfe(&io___64);
+ do_fio(&c__1, "DGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___65.ciunit = *nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, "DGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___66.ciunit = *nout;
+ s_wsfe(&io___66);
+ do_fio(&c__1, "DGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___67.ciunit = *nout;
+ s_wsfe(&io___67);
+ do_fio(&c__1, "DGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___68.ciunit = *nout;
+ s_wsfe(&io___68);
+ do_fio(&c__1, "DGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+
+ }
+
+/* L50: */
+ }
+L60:
+ ;
+ }
+/* L70: */
+ }
+L80:
+ ;
+ }
+/* L90: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DDRVGE */
+
+} /* ddrvge_ */
diff --git a/TESTING/LIN/ddrvgex.c b/TESTING/LIN/ddrvgex.c
new file mode 100644
index 0000000..112d51c
--- /dev/null
+++ b/TESTING/LIN/ddrvgex.c
@@ -0,0 +1,1220 @@
+/* ddrvgex.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "memory_alloc.h"
+:
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublereal c_b20 = 0.;
+static logical c_true = TRUE_;
+static integer c__6 = 6;
+static integer c__7 = 7;
+
+/* Subroutine */ int ddrvge_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
+ doublereal *a, doublereal *afac, doublereal *asav, doublereal *b,
+ doublereal *bsav, doublereal *x, doublereal *xact, doublereal *s,
+ doublereal *work, doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*4] = "N" "R" "C" "B";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
+ ", test(\002,i2,\002) =\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
+ "1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i2,\002"
+ ", test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
+ "1,\002', N=\002,i5,\002, type \002,i2,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ doublereal d__1;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ extern /* Subroutine */ int debchvxx_(doublereal *, char *);
+ integer i__, k, n;
+ doublereal *errbnds_c__, *errbnds_n__;
+ integer k1, nb, in, kl, ku, nt, n_err_bnds__;
+ extern doublereal dla_rpvgrw__(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *);
+ integer lda;
+ char fact[1];
+ integer ioff, mode;
+ doublereal amax;
+ char path[3];
+ integer imat, info;
+ doublereal *berr;
+ char dist[1];
+ doublereal rpvgrw_svxx__;
+ char type__[1];
+ integer nrun;
+ extern /* Subroutine */ int dget01_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ doublereal *), dget02_(char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *);
+ integer ifact;
+ extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *);
+ integer nfail, iseed[4], nfact;
+ extern doublereal dget06_(doublereal *, doublereal *);
+ extern /* Subroutine */ int dget07_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, logical *,
+ doublereal *, doublereal *);
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ doublereal rcond, roldc;
+ integer nimat;
+ doublereal roldi;
+ extern /* Subroutine */ int dgesv_(integer *, integer *, doublereal *,
+ integer *, integer *, doublereal *, integer *, integer *);
+ doublereal anorm;
+ integer itran;
+ logical equil;
+ doublereal roldo;
+ char trans[1];
+ integer izero, nerrs, lwork;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), aladhd_(integer *,
+ char *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *), dlaqge_(integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, char *);
+ logical prefac;
+ doublereal colcnd, rcondc;
+ logical nofact;
+ integer iequed;
+ extern /* Subroutine */ int dgeequ_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *);
+ doublereal rcondi;
+ extern /* Subroutine */ int dgetrf_(integer *, integer *, doublereal *,
+ integer *, integer *, integer *), dgetri_(integer *, doublereal *,
+ integer *, integer *, doublereal *, integer *, integer *),
+ dlacpy_(char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *), alasvm_(char *, integer *,
+ integer *, integer *, integer *);
+ doublereal cndnum, anormi, rcondo, ainvnm;
+ extern doublereal dlantr_(char *, char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *, doublereal
+ *, integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, integer *);
+ logical trfcon;
+ doublereal anormo, rowcnd;
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ dgesvx_(char *, char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, char *, doublereal
+ *, doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *
+, integer *), dlatms_(integer *, integer *
+, char *, integer *, char *, doublereal *, integer *, doublereal *
+, doublereal *, integer *, integer *, char *, doublereal *,
+ integer *, doublereal *, integer *),
+ xlaenv_(integer *, integer *), derrvx_(char *, integer *);
+ doublereal result[7], rpvgrw;
+ extern /* Subroutine */ int dgesvxx_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ char *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___68 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___74 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___75 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___76 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___77 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___80 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___81 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVGE tests the driver routines DGESV, -SVX, and -SVXX. */
+
+/* Note that this file is used only when the XBLAS are available, */
+/* otherwise ddrvge.f defines this subroutine. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension (2*NMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*NRHS+NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "GE", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 11;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L80;
+ }
+
+/* Skip types 5, 6, or 7 if the matrix size is too small. */
+
+ zerot = imat >= 5 && imat <= 7;
+ if (zerot && n < imat - 4) {
+ goto L80;
+ }
+
+/* Set up parameters with DLATB4 and generate a test matrix */
+/* with DLATMS. */
+
+ dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cndnum, dist);
+ rcondc = 1. / cndnum;
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cndnum, &
+ anorm, &kl, &ku, "No packing", &a[1], &lda, &work[1], &
+ info);
+
+/* Check error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, " ", &n, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L80;
+ }
+
+/* For types 5-7, zero one or more columns of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 5) {
+ izero = 1;
+ } else if (imat == 6) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 7) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.;
+/* L20: */
+ }
+ } else {
+ i__3 = n - izero + 1;
+ dlaset_("Full", &n, &i__3, &c_b20, &c_b20, &a[ioff + 1], &
+ lda);
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ dlacpy_("Full", &n, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 4; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[iequed -
+ 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__3 = nfact;
+ for (ifact = 1; ifact <= i__3; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[ifact -
+ 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L60;
+ }
+ rcondo = 0.;
+ rcondi = 0.;
+
+ } else if (! nofact) {
+
+/* Compute the condition number for comparison with */
+/* the value returned by DGESVX (FACT = 'N' reuses */
+/* the condition number from the previous iteration */
+/* with FACT = 'F'). */
+
+ dlacpy_("Full", &n, &n, &asav[1], &lda, &afac[1], &
+ lda);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ dgeequ_(&n, &n, &afac[1], &lda, &s[1], &s[n + 1],
+ &rowcnd, &colcnd, &amax, &info);
+ if (info == 0 && n > 0) {
+ if (lsame_(equed, "R"))
+ {
+ rowcnd = 0.;
+ colcnd = 1.;
+ } else if (lsame_(equed, "C")) {
+ rowcnd = 1.;
+ colcnd = 0.;
+ } else if (lsame_(equed, "B")) {
+ rowcnd = 0.;
+ colcnd = 0.;
+ }
+
+/* Equilibrate the matrix. */
+
+ dlaqge_(&n, &n, &afac[1], &lda, &s[1], &s[n +
+ 1], &rowcnd, &colcnd, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the non-equilibrated */
+/* system for use in DGET04. */
+
+ if (equil) {
+ roldo = rcondo;
+ roldi = rcondi;
+ }
+
+/* Compute the 1-norm and infinity-norm of A. */
+
+ anormo = dlange_("1", &n, &n, &afac[1], &lda, &rwork[
+ 1]);
+ anormi = dlange_("I", &n, &n, &afac[1], &lda, &rwork[
+ 1]);
+
+/* Factor the matrix A. */
+
+ dgetrf_(&n, &n, &afac[1], &lda, &iwork[1], &info);
+
+/* Form the inverse of A. */
+
+ dlacpy_("Full", &n, &n, &afac[1], &lda, &a[1], &lda);
+ lwork = *nmax * max(3,*nrhs);
+ dgetri_(&n, &a[1], &lda, &iwork[1], &work[1], &lwork,
+ &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = dlange_("1", &n, &n, &a[1], &lda, &rwork[1]);
+ if (anormo <= 0. || ainvnm <= 0.) {
+ rcondo = 1.;
+ } else {
+ rcondo = 1. / anormo / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ ainvnm = dlange_("I", &n, &n, &a[1], &lda, &rwork[1]);
+ if (anormi <= 0. || ainvnm <= 0.) {
+ rcondi = 1.;
+ } else {
+ rcondi = 1. / anormi / ainvnm;
+ }
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+ for (i__ = 1; i__ <= 7; ++i__) {
+ result[i__ - 1] = 0.;
+ }
+
+/* Do for each value of TRANS. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[
+ itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Restore the matrix A. */
+
+ dlacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ dlarhs_(path, xtype, "Full", trans, &n, &n, &kl, &ku,
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
+
+ if (nofact && itran == 1) {
+
+/* --- Test DGESV --- */
+
+/* Compute the LU factorization of the matrix and */
+/* solve the system. */
+
+ dlacpy_("Full", &n, &n, &a[1], &lda, &afac[1], &
+ lda);
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "DGESV ", (ftnlen)32, (
+ ftnlen)6);
+ dgesv_(&n, nrhs, &afac[1], &lda, &iwork[1], &x[1],
+ &lda, &info);
+
+/* Check error code from DGESV . */
+
+ if (info != izero) {
+ alaerh_(path, "DGESV ", &info, &izero, " ", &
+ n, &n, &c_n1, &c_n1, nrhs, &imat, &
+ nfail, &nerrs, nout);
+ goto L50;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ dget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &rwork[1], result);
+ nt = 1;
+ if (izero == 0) {
+
+/* Compute residual of the computed solution. */
+
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[
+ 1], &lda);
+ dget02_("No transpose", &n, &n, nrhs, &a[1], &
+ lda, &x[1], &lda, &work[1], &lda, &
+ rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ nt = 3;
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___55.ciunit = *nout;
+ s_wsfe(&io___55);
+ do_fio(&c__1, "DGESV ", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L30: */
+ }
+ nrun += nt;
+ }
+
+/* --- Test DGESVX --- */
+
+ if (! prefac) {
+ dlaset_("Full", &n, &n, &c_b20, &c_b20, &afac[1],
+ &lda);
+ }
+ dlaset_("Full", &n, nrhs, &c_b20, &c_b20, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ dlaqge_(&n, &n, &a[1], &lda, &s[1], &s[n + 1], &
+ rowcnd, &colcnd, &amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using DGESVX. */
+
+ s_copy(srnamc_1.srnamt, "DGESVX", (ftnlen)32, (ftnlen)
+ 6);
+ dgesvx_(fact, trans, &n, nrhs, &a[1], &lda, &afac[1],
+ &lda, &iwork[1], equed, &s[1], &s[n + 1], &b[
+ 1], &lda, &x[1], &lda, &rcond, &rwork[1], &
+ rwork[*nrhs + 1], &work[1], &iwork[n + 1], &
+ info);
+
+/* Check the error code from DGESVX. */
+
+ if (info == n + 1) {
+ goto L50;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "DGESVX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L50;
+ }
+
+/* Compare WORK(1) from DGESVX with the computed */
+/* reciprocal pivot growth factor RPVGRW */
+
+ if (info != 0) {
+ rpvgrw = dlantr_("M", "U", "N", &info, &info, &
+ afac[1], &lda, &work[1]);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = dlange_("M", &n, &info, &a[1], &lda,
+ &work[1]) / rpvgrw;
+ }
+ } else {
+ rpvgrw = dlantr_("M", "U", "N", &n, &n, &afac[1],
+ &lda, &work[1]);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = dlange_("M", &n, &n, &a[1], &lda, &
+ work[1]) / rpvgrw;
+ }
+ }
+ result[6] = (d__1 = rpvgrw - work[1], abs(d__1)) /
+ max(work[1],rpvgrw) / dlamch_("E");
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ dget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &rwork[(*nrhs << 1) + 1],
+ result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ dlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ dget02_(trans, &n, &n, nrhs, &asav[1], &lda, &x[1]
+, &lda, &work[1], &lda, &rwork[(*nrhs <<
+ 1) + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ dget07_(trans, &n, nrhs, &asav[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &c_true, &rwork[*nrhs + 1], &result[3]
+);
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from DGESVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___61.ciunit = *nout;
+ s_wsfe(&io___61);
+ do_fio(&c__1, "DGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___62.ciunit = *nout;
+ s_wsfe(&io___62);
+ do_fio(&c__1, "DGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L40: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___63.ciunit = *nout;
+ s_wsfe(&io___63);
+ do_fio(&c__1, "DGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___64.ciunit = *nout;
+ s_wsfe(&io___64);
+ do_fio(&c__1, "DGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___65.ciunit = *nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, "DGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___66.ciunit = *nout;
+ s_wsfe(&io___66);
+ do_fio(&c__1, "DGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___67.ciunit = *nout;
+ s_wsfe(&io___67);
+ do_fio(&c__1, "DGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___68.ciunit = *nout;
+ s_wsfe(&io___68);
+ do_fio(&c__1, "DGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+
+ }
+
+/* --- Test DGESVXX --- */
+
+/* Restore the matrices A and B. */
+
+ dlacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
+ dlacpy_("Full", &n, nrhs, &bsav[1], &lda, &b[1], &lda);
+ if (! prefac) {
+ dlaset_("Full", &n, &n, &c_b20, &c_b20, &afac[1],
+ &lda);
+ }
+ dlaset_("Full", &n, nrhs, &c_b20, &c_b20, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ dlaqge_(&n, &n, &a[1], &lda, &s[1], &s[n + 1], &
+ rowcnd, &colcnd, &amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using DGESVXX. */
+
+ s_copy(srnamc_1.srnamt, "DGESVXX", (ftnlen)32, (
+ ftnlen)7);
+ n_err_bnds__ = 3;
+
+ dalloc3();
+
+ dgesvxx_(fact, trans, &n, nrhs, &a[1], &lda, &afac[1],
+ &lda, &iwork[1], equed, &s[1], &s[n + 1], &b[
+ 1], &lda, &x[1], &lda, &rcond, &rpvgrw_svxx__,
+ berr, &n_err_bnds__, errbnds_n__,
+ errbnds_c__, &c__0, &c_b20, &work[1], &iwork[
+ n + 1], &info);
+
+ free3();
+
+/* Check the error code from DGESVXX. */
+
+ if (info == n + 1) {
+ goto L50;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "DGESVXX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L50;
+ }
+
+/* Compare rpvgrw_svxx from DGESVXX with the computed */
+/* reciprocal pivot growth factor RPVGRW */
+
+ if (info > 0 && info < n + 1) {
+ rpvgrw = dla_rpvgrw__(&n, &info, &a[1], &lda, &
+ afac[1], &lda);
+ } else {
+ rpvgrw = dla_rpvgrw__(&n, &n, &a[1], &lda, &afac[
+ 1], &lda);
+ }
+ result[6] = (d__1 = rpvgrw - rpvgrw_svxx__, abs(d__1))
+ / max(rpvgrw_svxx__,rpvgrw) / dlamch_("E");
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ dget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &rwork[(*nrhs << 1) + 1],
+ result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ dlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ dget02_(trans, &n, &n, nrhs, &asav[1], &lda, &x[1]
+, &lda, &work[1], &lda, &rwork[(*nrhs <<
+ 1) + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from DGESVXX with the computed value */
+/* in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___74.ciunit = *nout;
+ s_wsfe(&io___74);
+ do_fio(&c__1, "DGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___75.ciunit = *nout;
+ s_wsfe(&io___75);
+ do_fio(&c__1, "DGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L45: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___76.ciunit = *nout;
+ s_wsfe(&io___76);
+ do_fio(&c__1, "DGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___77.ciunit = *nout;
+ s_wsfe(&io___77);
+ do_fio(&c__1, "DGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___78.ciunit = *nout;
+ s_wsfe(&io___78);
+ do_fio(&c__1, "DGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___79.ciunit = *nout;
+ s_wsfe(&io___79);
+ do_fio(&c__1, "DGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___80.ciunit = *nout;
+ s_wsfe(&io___80);
+ do_fio(&c__1, "DGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___81.ciunit = *nout;
+ s_wsfe(&io___81);
+ do_fio(&c__1, "DGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+
+ }
+
+L50:
+ ;
+ }
+L60:
+ ;
+ }
+/* L70: */
+ }
+L80:
+ ;
+ }
+/* L90: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+/* Test Error Bounds from DGESVXX */
+ debchvxx_(thresh, path);
+ return 0;
+
+/* End of DDRVGE */
+
+} /* ddrvge_ */
diff --git a/TESTING/LIN/ddrvgt.c b/TESTING/LIN/ddrvgt.c
new file mode 100644
index 0000000..2d18709
--- /dev/null
+++ b/TESTING/LIN/ddrvgt.c
@@ -0,0 +1,709 @@
+/* ddrvgt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static doublereal c_b43 = 1.;
+static doublereal c_b44 = 0.;
+
+/* Subroutine */ int ddrvgt_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, doublereal *a,
+ doublereal *af, doublereal *b, doublereal *x, doublereal *xact,
+ doublereal *work, doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 0,0,0,1 };
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
+ ", test \002,i2,\002, ratio = \002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
+ "1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002, "
+ "ratio = \002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ doublereal d__1, d__2;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k, m, n;
+ doublereal z__[3];
+ integer k1, in, kl, ku, ix, nt, lda;
+ char fact[1];
+ doublereal cond;
+ integer mode, koff, imat, info;
+ char path[3], dist[1], type__[1];
+ integer nrun, ifact;
+ extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *),
+ dscal_(integer *, doublereal *, doublereal *, integer *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ extern /* Subroutine */ int dgtt01_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *), dgtt02_(char *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *
+, integer *, doublereal *, doublereal *);
+ doublereal rcond;
+ extern /* Subroutine */ int dgtt05_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *);
+ integer nimat;
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal anorm;
+ integer itran;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ char trans[1];
+ integer izero, nerrs;
+ extern /* Subroutine */ int dgtsv_(integer *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *);
+ logical zerot;
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), aladhd_(integer *,
+ char *), alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ doublereal rcondc;
+ extern doublereal dlangt_(char *, integer *, doublereal *, doublereal *,
+ doublereal *);
+ extern /* Subroutine */ int dlagtm_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *), dlacpy_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *), dlaset_(char *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *);
+ doublereal rcondi;
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal rcondo, anormi;
+ extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *,
+ doublereal *), dlatms_(integer *, integer *, char *, integer *,
+ char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublereal *, integer *, doublereal
+ *, integer *);
+ doublereal ainvnm;
+ logical trfcon;
+ doublereal anormo;
+ extern /* Subroutine */ int dgttrf_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *), dgttrs_(char *
+, integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *), derrvx_(char *, integer *);
+ doublereal result[6];
+ extern /* Subroutine */ int dgtsvx_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVGT tests DGTSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*4) */
+
+/* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*4) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NRHS)) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --af;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "GT", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+/* Computing MAX */
+ i__2 = n - 1;
+ m = max(i__2,0);
+ lda = max(1,n);
+ nimat = 12;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L130;
+ }
+
+/* Set up parameters with DLATB4. */
+
+ dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cond, dist);
+
+ zerot = imat >= 8 && imat <= 10;
+ if (imat <= 6) {
+
+/* Types 1-6: generate matrices of known condition number. */
+
+/* Computing MAX */
+ i__3 = 2 - ku, i__4 = 3 - max(1,n);
+ koff = max(i__3,i__4);
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
+ &anorm, &kl, &ku, "Z", &af[koff], &c__3, &work[1], &
+ info);
+
+/* Check the error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, " ", &n, &n, &kl, &
+ ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L130;
+ }
+ izero = 0;
+
+ if (n > 1) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
+ i__3 = n - 1;
+ dcopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
+ }
+ dcopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
+ } else {
+
+/* Types 7-12: generate tridiagonal matrices with */
+/* unknown condition numbers. */
+
+ if (! zerot || ! dotype[7]) {
+
+/* Generate a matrix with elements from [-1,1]. */
+
+ i__3 = n + (m << 1);
+ dlarnv_(&c__2, iseed, &i__3, &a[1]);
+ if (anorm != 1.) {
+ i__3 = n + (m << 1);
+ dscal_(&i__3, &anorm, &a[1], &c__1);
+ }
+ } else if (izero > 0) {
+
+/* Reuse the last matrix by copying back the zeroed out */
+/* elements. */
+
+ if (izero == 1) {
+ a[n] = z__[1];
+ if (n > 1) {
+ a[1] = z__[2];
+ }
+ } else if (izero == n) {
+ a[n * 3 - 2] = z__[0];
+ a[(n << 1) - 1] = z__[1];
+ } else {
+ a[(n << 1) - 2 + izero] = z__[0];
+ a[n - 1 + izero] = z__[1];
+ a[izero] = z__[2];
+ }
+ }
+
+/* If IMAT > 7, set one column of the matrix to 0. */
+
+ if (! zerot) {
+ izero = 0;
+ } else if (imat == 8) {
+ izero = 1;
+ z__[1] = a[n];
+ a[n] = 0.;
+ if (n > 1) {
+ z__[2] = a[1];
+ a[1] = 0.;
+ }
+ } else if (imat == 9) {
+ izero = n;
+ z__[0] = a[n * 3 - 2];
+ z__[1] = a[(n << 1) - 1];
+ a[n * 3 - 2] = 0.;
+ a[(n << 1) - 1] = 0.;
+ } else {
+ izero = (n + 1) / 2;
+ i__3 = n - 1;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[(n << 1) - 2 + i__] = 0.;
+ a[n - 1 + i__] = 0.;
+ a[i__] = 0.;
+/* L20: */
+ }
+ a[n * 3 - 2] = 0.;
+ a[(n << 1) - 1] = 0.;
+ }
+ }
+
+ for (ifact = 1; ifact <= 2; ++ifact) {
+ if (ifact == 1) {
+ *(unsigned char *)fact = 'F';
+ } else {
+ *(unsigned char *)fact = 'N';
+ }
+
+/* Compute the condition number for comparison with */
+/* the value returned by DGTSVX. */
+
+ if (zerot) {
+ if (ifact == 1) {
+ goto L120;
+ }
+ rcondo = 0.;
+ rcondi = 0.;
+
+ } else if (ifact == 1) {
+ i__3 = n + (m << 1);
+ dcopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
+
+/* Compute the 1-norm and infinity-norm of A. */
+
+ anormo = dlangt_("1", &n, &a[1], &a[m + 1], &a[n + m + 1]);
+ anormi = dlangt_("I", &n, &a[1], &a[m + 1], &a[n + m + 1]);
+
+/* Factor the matrix A. */
+
+ dgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (
+ m << 1) + 1], &iwork[1], &info);
+
+/* Use DGTTRS to solve for one column at a time of */
+/* inv(A), computing the maximum column sum as we go. */
+
+ ainvnm = 0.;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ x[j] = 0.;
+/* L30: */
+ }
+ x[i__] = 1.;
+ dgttrs_("No transpose", &n, &c__1, &af[1], &af[m + 1],
+ &af[n + m + 1], &af[n + (m << 1) + 1], &
+ iwork[1], &x[1], &lda, &info);
+/* Computing MAX */
+ d__1 = ainvnm, d__2 = dasum_(&n, &x[1], &c__1);
+ ainvnm = max(d__1,d__2);
+/* L40: */
+ }
+
+/* Compute the 1-norm condition number of A. */
+
+ if (anormo <= 0. || ainvnm <= 0.) {
+ rcondo = 1.;
+ } else {
+ rcondo = 1. / anormo / ainvnm;
+ }
+
+/* Use DGTTRS to solve for one column at a time of */
+/* inv(A'), computing the maximum column sum as we go. */
+
+ ainvnm = 0.;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ x[j] = 0.;
+/* L50: */
+ }
+ x[i__] = 1.;
+ dgttrs_("Transpose", &n, &c__1, &af[1], &af[m + 1], &
+ af[n + m + 1], &af[n + (m << 1) + 1], &iwork[
+ 1], &x[1], &lda, &info);
+/* Computing MAX */
+ d__1 = ainvnm, d__2 = dasum_(&n, &x[1], &c__1);
+ ainvnm = max(d__1,d__2);
+/* L60: */
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ if (anormi <= 0. || ainvnm <= 0.) {
+ rcondi = 1.;
+ } else {
+ rcondi = 1. / anormi / ainvnm;
+ }
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+ *(unsigned char *)trans = *(unsigned char *)&transs[itran
+ - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Generate NRHS random solution vectors. */
+
+ ix = 1;
+ i__3 = *nrhs;
+ for (j = 1; j <= i__3; ++j) {
+ dlarnv_(&c__2, iseed, &n, &xact[ix]);
+ ix += lda;
+/* L70: */
+ }
+
+/* Set the right hand side. */
+
+ dlagtm_(trans, &n, nrhs, &c_b43, &a[1], &a[m + 1], &a[n +
+ m + 1], &xact[1], &lda, &c_b44, &b[1], &lda);
+
+ if (ifact == 2 && itran == 1) {
+
+/* --- Test DGTSV --- */
+
+/* Solve the system using Gaussian elimination with */
+/* partial pivoting. */
+
+ i__3 = n + (m << 1);
+ dcopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "DGTSV ", (ftnlen)32, (ftnlen)
+ 6);
+ dgtsv_(&n, nrhs, &af[1], &af[m + 1], &af[n + m + 1], &
+ x[1], &lda, &info);
+
+/* Check error code from DGTSV . */
+
+ if (info != izero) {
+ alaerh_(path, "DGTSV ", &info, &izero, " ", &n, &
+ n, &c__1, &c__1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+ nt = 1;
+ if (izero == 0) {
+
+/* Check residual of computed solution. */
+
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
+ lda);
+ dgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n +
+ m + 1], &x[1], &lda, &work[1], &lda, &
+ rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 2; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "DGTSV ", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + nt - 1;
+ }
+
+/* --- Test DGTSVX --- */
+
+ if (ifact > 1) {
+
+/* Initialize AF to zero. */
+
+ i__3 = n * 3 - 2;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ af[i__] = 0.;
+/* L90: */
+ }
+ }
+ dlaset_("Full", &n, nrhs, &c_b44, &c_b44, &x[1], &lda);
+
+/* Solve the system and compute the condition number and */
+/* error bounds using DGTSVX. */
+
+ s_copy(srnamc_1.srnamt, "DGTSVX", (ftnlen)32, (ftnlen)6);
+ dgtsvx_(fact, trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m
+ + 1], &af[1], &af[m + 1], &af[n + m + 1], &af[n +
+ (m << 1) + 1], &iwork[1], &b[1], &lda, &x[1], &
+ lda, &rcond, &rwork[1], &rwork[*nrhs + 1], &work[
+ 1], &iwork[n + 1], &info);
+
+/* Check the error code from DGTSVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "DGTSVX", &info, &izero, ch__1, &n, &n,
+ &c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ if (ifact >= 2) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ dgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &
+ af[m + 1], &af[n + m + 1], &af[n + (m << 1) +
+ 1], &iwork[1], &work[1], &lda, &rwork[1],
+ result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Check residual of computed solution. */
+
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ dgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
+ 1], &x[1], &lda, &work[1], &lda, &rwork[1], &
+ result[1]);
+
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* Check the error bounds from iterative refinement. */
+
+ dgtt05_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
+ 1], &b[1], &lda, &x[1], &lda, &xact[1], &lda,
+ &rwork[1], &rwork[*nrhs + 1], &result[3]);
+ nt = 5;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = k1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___46.ciunit = *nout;
+ s_wsfe(&io___46);
+ do_fio(&c__1, "DGTSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L100: */
+ }
+
+/* Check the reciprocal of the condition number. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___47.ciunit = *nout;
+ s_wsfe(&io___47);
+ do_fio(&c__1, "DGTSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ nrun = nrun + nt - k1 + 2;
+
+/* L110: */
+ }
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DDRVGT */
+
+} /* ddrvgt_ */
diff --git a/TESTING/LIN/ddrvls.c b/TESTING/LIN/ddrvls.c
new file mode 100644
index 0000000..1ef3349
--- /dev/null
+++ b/TESTING/LIN/ddrvls.c
@@ -0,0 +1,862 @@
+/* ddrvls.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__9 = 9;
+static integer c__25 = 25;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static doublereal c_b28 = 1.;
+static doublereal c_b29 = 0.;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublereal c_b96 = -1.;
+
+/* Subroutine */ int ddrvls_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nns, integer *nsval, integer *
+ nnb, integer *nbval, integer *nxval, doublereal *thresh, logical *
+ tsterr, doublereal *a, doublereal *copya, doublereal *b, doublereal *
+ copyb, doublereal *c__, doublereal *s, doublereal *copys, doublereal *
+ work, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 TRANS='\002,a1,\002', M=\002,i5,\002, N"
+ "=\002,i5,\002, NRHS=\002,i4,\002, NB=\002,i4,\002, type\002,i2"
+ ",\002, test(\002,i2,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, NRHS="
+ "\002,i4,\002, NB=\002,i4,\002, type\002,i2,\002, test(\002,i2"
+ ",\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal), log(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, m, n, nb, im, in, lda, ldb, inb;
+ doublereal eps;
+ integer ins, info;
+ char path[3];
+ integer rank, nrhs, nlvl, nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), dscal_(
+ integer *, doublereal *, doublereal *, integer *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ integer crank;
+ extern /* Subroutine */ int dgels_(char *, integer *, integer *, integer *
+, doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *);
+ integer irank;
+ doublereal rcond;
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ integer itran, mnmin, ncols;
+ doublereal norma, normb;
+ extern doublereal dqrt12_(integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dqrt14_(char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *), dqrt17_(char *,
+ integer *, integer *, integer *, integer *, doublereal *, integer
+ *, doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *);
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *);
+ char trans[1];
+ integer nerrs, itype;
+ extern /* Subroutine */ int dqrt13_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ integer lwork;
+ extern /* Subroutine */ int dqrt15_(integer *, integer *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *), dqrt16_(char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *);
+ integer nrows, lwlsy;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ integer iscale;
+ extern /* Subroutine */ int dgelsd_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *), dlacpy_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *), dgelss_(integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, integer *), alasvm_(char *, integer *, integer *,
+ integer *, integer *), dgelsx_(integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *),
+ dgelsy_(integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, integer *), dlarnv_(integer *, integer *,
+ integer *, doublereal *), derrls_(char *, integer *),
+ xlaenv_(integer *, integer *);
+ integer ldwork;
+ doublereal result[18];
+
+ /* Fortran I/O blocks */
+ static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVLS tests the least squares driver routines DGELS, DGELSS, DGELSX, */
+/* DGELSY and DGELSD. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+/* The matrix of type j is generated as follows: */
+/* j=1: A = U*D*V where U and V are random orthogonal matrices */
+/* and D has random entries (> 0.1) taken from a uniform */
+/* distribution (0,1). A is full rank. */
+/* j=2: The same of 1, but A is scaled up. */
+/* j=3: The same of 1, but A is scaled down. */
+/* j=4: A = U*D*V where U and V are random orthogonal matrices */
+/* and D has 3*min(M,N)/4 random entries (> 0.1) taken */
+/* from a uniform distribution (0,1) and the remaining */
+/* entries set to 0. A is rank-deficient. */
+/* j=5: The same of 4, but A is scaled up. */
+/* j=6: The same of 5, but A is scaled down. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX) */
+/* where MMAX is the maximum value of M in MVAL and NMAX is the */
+/* maximum value of N in NVAL. */
+
+/* COPYA (workspace) DOUBLE PRECISION array, dimension (MMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (MMAX*NSMAX) */
+/* where MMAX is the maximum value of M in MVAL and NSMAX is the */
+/* maximum value of NRHS in NSVAL. */
+
+/* COPYB (workspace) DOUBLE PRECISION array, dimension (MMAX*NSMAX) */
+
+/* C (workspace) DOUBLE PRECISION array, dimension (MMAX*NSMAX) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* COPYS (workspace) DOUBLE PRECISION array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* WORK (workspace) DOUBLE PRECISION array, */
+/* dimension (MMAX*NMAX + 4*NMAX + MMAX). */
+
+/* IWORK (workspace) INTEGER array, dimension (15*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --copys;
+ --s;
+ --c__;
+ --copyb;
+ --b;
+ --copya;
+ --a;
+ --nxval;
+ --nbval;
+ --nsval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "LS", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = dlamch_("Epsilon");
+
+/* Threshold for rank estimation */
+
+ rcond = sqrt(eps) - (sqrt(eps) - eps) / 2;
+
+/* Test the error exits */
+
+ xlaenv_(&c__2, &c__2);
+ xlaenv_(&c__9, &c__25);
+ if (*tsterr) {
+ derrls_(path, nout);
+ }
+
+/* Print the header if NM = 0 or NN = 0 and THRESH = 0. */
+
+ if ((*nm == 0 || *nn == 0) && *thresh == 0.) {
+ alahd_(nout, path);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+ xlaenv_(&c__9, &c__25);
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+ lda = max(1,m);
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__3 = max(1,m);
+ ldb = max(i__3,n);
+
+ i__3 = *nns;
+ for (ins = 1; ins <= i__3; ++ins) {
+ nrhs = nsval[ins];
+/* Computing MAX */
+/* Computing MAX */
+ d__1 = 1., d__2 = (doublereal) mnmin;
+ i__4 = (integer) (log(max(d__1,d__2) / 26.) / log(2.)) + 1;
+ nlvl = max(i__4,0);
+/* Computing MAX */
+ i__4 = 1, i__5 = (m + nrhs) * (n + 2), i__4 = max(i__4,i__5),
+ i__5 = (n + nrhs) * (m + 2), i__4 = max(i__4,i__5),
+ i__5 = m * n + (mnmin << 2) + max(m,n), i__4 = max(
+ i__4,i__5), i__5 = mnmin * 12 + mnmin * 50 + (mnmin <<
+ 3) * nlvl + mnmin * nrhs + 676;
+ lwork = max(i__4,i__5);
+
+ for (irank = 1; irank <= 2; ++irank) {
+ for (iscale = 1; iscale <= 3; ++iscale) {
+ itype = (irank - 1) * 3 + iscale;
+ if (! dotype[itype]) {
+ goto L110;
+ }
+
+ if (irank == 1) {
+
+/* Test DGELS */
+
+/* Generate a matrix of scaling type ISCALE */
+
+ dqrt13_(&iscale, &m, &n, ©a[1], &lda, &norma,
+ iseed);
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__3, &nxval[inb]);
+
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ *(unsigned char *)trans = 'N';
+ nrows = m;
+ ncols = n;
+ } else {
+ *(unsigned char *)trans = 'T';
+ nrows = n;
+ ncols = m;
+ }
+ ldwork = max(1,ncols);
+
+/* Set up a consistent rhs */
+
+ if (ncols > 0) {
+ i__5 = ncols * nrhs;
+ dlarnv_(&c__2, iseed, &i__5, &work[1])
+ ;
+ i__5 = ncols * nrhs;
+ d__1 = 1. / (doublereal) ncols;
+ dscal_(&i__5, &d__1, &work[1], &c__1);
+ }
+ dgemm_(trans, "No transpose", &nrows, &
+ nrhs, &ncols, &c_b28, ©a[1], &
+ lda, &work[1], &ldwork, &c_b29, &
+ b[1], &ldb)
+ ;
+ dlacpy_("Full", &nrows, &nrhs, &b[1], &
+ ldb, ©b[1], &ldb);
+
+/* Solve LS or overdetermined system */
+
+ if (m > 0 && n > 0) {
+ dlacpy_("Full", &m, &n, ©a[1], &
+ lda, &a[1], &lda);
+ dlacpy_("Full", &nrows, &nrhs, ©b[
+ 1], &ldb, &b[1], &ldb);
+ }
+ s_copy(srnamc_1.srnamt, "DGELS ", (ftnlen)
+ 32, (ftnlen)6);
+ dgels_(trans, &m, &n, &nrhs, &a[1], &lda,
+ &b[1], &ldb, &work[1], &lwork, &
+ info);
+ if (info != 0) {
+ alaerh_(path, "DGELS ", &info, &c__0,
+ trans, &m, &n, &nrhs, &c_n1, &
+ nb, &itype, &nfail, &nerrs,
+ nout);
+ }
+
+/* Check correctness of results */
+
+ ldwork = max(1,nrows);
+ if (nrows > 0 && nrhs > 0) {
+ dlacpy_("Full", &nrows, &nrhs, ©b[
+ 1], &ldb, &c__[1], &ldb);
+ }
+ dqrt16_(trans, &m, &n, &nrhs, ©a[1], &
+ lda, &b[1], &ldb, &c__[1], &ldb, &
+ work[1], result);
+
+ if (itran == 1 && m >= n || itran == 2 &&
+ m < n) {
+
+/* Solving LS system */
+
+ result[1] = dqrt17_(trans, &c__1, &m,
+ &n, &nrhs, ©a[1], &lda, &
+ b[1], &ldb, ©b[1], &ldb, &
+ c__[1], &work[1], &lwork);
+ } else {
+
+/* Solving overdetermined system */
+
+ result[1] = dqrt14_(trans, &m, &n, &
+ nrhs, ©a[1], &lda, &b[1],
+ &ldb, &work[1], &lwork);
+ }
+
+/* Print information about the tests that */
+/* did not pass the threshold. */
+
+ for (k = 1; k <= 2; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&nrhs, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nb, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&itype, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k -
+ 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += 2;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+/* Generate a matrix of scaling type ISCALE and rank */
+/* type IRANK. */
+
+ dqrt15_(&iscale, &irank, &m, &n, &nrhs, ©a[1], &
+ lda, ©b[1], &ldb, ©s[1], &rank, &
+ norma, &normb, iseed, &work[1], &lwork);
+
+/* workspace used: MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M) */
+
+/* Initialize vector IWORK. */
+
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ iwork[j] = 0;
+/* L50: */
+ }
+ ldwork = max(1,m);
+
+/* Test DGELSX */
+
+/* DGELSX: Compute the minimum-norm solution X */
+/* to min( norm( A * X - B ) ) using a complete */
+/* orthogonal factorization. */
+
+ dlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &lda);
+ dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1], &
+ ldb);
+
+ s_copy(srnamc_1.srnamt, "DGELSX", (ftnlen)32, (ftnlen)
+ 6);
+ dgelsx_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
+ iwork[1], &rcond, &crank, &work[1], &info);
+ if (info != 0) {
+ alaerh_(path, "DGELSX", &info, &c__0, " ", &m, &n,
+ &nrhs, &c_n1, &nb, &itype, &nfail, &
+ nerrs, nout);
+ }
+
+/* workspace used: MAX( MNMIN+3*N, 2*MNMIN+NRHS ) */
+
+/* Test 3: Compute relative error in svd */
+/* workspace: M*N + 4*MIN(M,N) + MAX(M,N) */
+
+ result[2] = dqrt12_(&crank, &crank, &a[1], &lda, &
+ copys[1], &work[1], &lwork);
+
+/* Test 4: Compute error in solution */
+/* workspace: M*NRHS + M */
+
+ dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[1],
+ &ldwork);
+ dqrt16_("No transpose", &m, &n, &nrhs, ©a[1], &
+ lda, &b[1], &ldb, &work[1], &ldwork, &work[m *
+ nrhs + 1], &result[3]);
+
+/* Test 5: Check norm of r'*A */
+/* workspace: NRHS*(M+N) */
+
+ result[4] = 0.;
+ if (m > crank) {
+ result[4] = dqrt17_("No transpose", &c__1, &m, &n,
+ &nrhs, ©a[1], &lda, &b[1], &ldb, &
+ copyb[1], &ldb, &c__[1], &work[1], &lwork);
+ }
+
+/* Test 6: Check if x is in the rowspace of A */
+/* workspace: (M+NRHS)*(N+2) */
+
+ result[5] = 0.;
+
+ if (n > crank) {
+ result[5] = dqrt14_("No transpose", &m, &n, &nrhs,
+ ©a[1], &lda, &b[1], &ldb, &work[1], &
+ lwork);
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 3; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&itype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += 4;
+
+/* Loop for testing different block sizes. */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__3, &nxval[inb]);
+
+/* Test DGELSY */
+
+/* DGELSY: Compute the minimum-norm solution X */
+/* to min( norm( A * X - B ) ) */
+/* using the rank-revealing orthogonal */
+/* factorization. */
+
+/* Initialize vector IWORK. */
+
+ i__5 = n;
+ for (j = 1; j <= i__5; ++j) {
+ iwork[j] = 0;
+/* L70: */
+ }
+
+/* Set LWLSY to the adequate value. */
+
+/* Computing MAX */
+ i__5 = 1, i__6 = mnmin + (n << 1) + nb * (n + 1),
+ i__5 = max(i__5,i__6), i__6 = (mnmin << 1)
+ + nb * nrhs;
+ lwlsy = max(i__5,i__6);
+
+ dlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
+ lda);
+ dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
+ &ldb);
+
+ s_copy(srnamc_1.srnamt, "DGELSY", (ftnlen)32, (
+ ftnlen)6);
+ dgelsy_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
+ iwork[1], &rcond, &crank, &work[1], &
+ lwlsy, &info);
+ if (info != 0) {
+ alaerh_(path, "DGELSY", &info, &c__0, " ", &m,
+ &n, &nrhs, &c_n1, &nb, &itype, &
+ nfail, &nerrs, nout);
+ }
+
+/* Test 7: Compute relative error in svd */
+/* workspace: M*N + 4*MIN(M,N) + MAX(M,N) */
+
+ result[6] = dqrt12_(&crank, &crank, &a[1], &lda, &
+ copys[1], &work[1], &lwork);
+
+/* Test 8: Compute error in solution */
+/* workspace: M*NRHS + M */
+
+ dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
+ 1], &ldwork);
+ dqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
+ &lda, &b[1], &ldb, &work[1], &ldwork, &
+ work[m * nrhs + 1], &result[7]);
+
+/* Test 9: Check norm of r'*A */
+/* workspace: NRHS*(M+N) */
+
+ result[8] = 0.;
+ if (m > crank) {
+ result[8] = dqrt17_("No transpose", &c__1, &m,
+ &n, &nrhs, ©a[1], &lda, &b[1], &
+ ldb, ©b[1], &ldb, &c__[1], &work[
+ 1], &lwork);
+ }
+
+/* Test 10: Check if x is in the rowspace of A */
+/* workspace: (M+NRHS)*(N+2) */
+
+ result[9] = 0.;
+
+ if (n > crank) {
+ result[9] = dqrt14_("No transpose", &m, &n, &
+ nrhs, ©a[1], &lda, &b[1], &ldb, &
+ work[1], &lwork);
+ }
+
+/* Test DGELSS */
+
+/* DGELSS: Compute the minimum-norm solution X */
+/* to min( norm( A * X - B ) ) */
+/* using the SVD. */
+
+ dlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
+ lda);
+ dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
+ &ldb);
+ s_copy(srnamc_1.srnamt, "DGELSS", (ftnlen)32, (
+ ftnlen)6);
+ dgelss_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
+ s[1], &rcond, &crank, &work[1], &lwork, &
+ info);
+ if (info != 0) {
+ alaerh_(path, "DGELSS", &info, &c__0, " ", &m,
+ &n, &nrhs, &c_n1, &nb, &itype, &
+ nfail, &nerrs, nout);
+ }
+
+/* workspace used: 3*min(m,n) + */
+/* max(2*min(m,n),nrhs,max(m,n)) */
+
+/* Test 11: Compute relative error in svd */
+
+ if (rank > 0) {
+ daxpy_(&mnmin, &c_b96, ©s[1], &c__1, &s[1]
+, &c__1);
+ result[10] = dasum_(&mnmin, &s[1], &c__1) /
+ dasum_(&mnmin, ©s[1], &c__1) / (
+ eps * (doublereal) mnmin);
+ } else {
+ result[10] = 0.;
+ }
+
+/* Test 12: Compute error in solution */
+
+ dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
+ 1], &ldwork);
+ dqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
+ &lda, &b[1], &ldb, &work[1], &ldwork, &
+ work[m * nrhs + 1], &result[11]);
+
+/* Test 13: Check norm of r'*A */
+
+ result[12] = 0.;
+ if (m > crank) {
+ result[12] = dqrt17_("No transpose", &c__1, &
+ m, &n, &nrhs, ©a[1], &lda, &b[1],
+ &ldb, ©b[1], &ldb, &c__[1], &work[
+ 1], &lwork);
+ }
+
+/* Test 14: Check if x is in the rowspace of A */
+
+ result[13] = 0.;
+ if (n > crank) {
+ result[13] = dqrt14_("No transpose", &m, &n, &
+ nrhs, ©a[1], &lda, &b[1], &ldb, &
+ work[1], &lwork);
+ }
+
+/* Test DGELSD */
+
+/* DGELSD: Compute the minimum-norm solution X */
+/* to min( norm( A * X - B ) ) using a */
+/* divide and conquer SVD. */
+
+/* Initialize vector IWORK. */
+
+ i__5 = n;
+ for (j = 1; j <= i__5; ++j) {
+ iwork[j] = 0;
+/* L80: */
+ }
+
+ dlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
+ lda);
+ dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
+ &ldb);
+
+ s_copy(srnamc_1.srnamt, "DGELSD", (ftnlen)32, (
+ ftnlen)6);
+ dgelsd_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
+ s[1], &rcond, &crank, &work[1], &lwork, &
+ iwork[1], &info);
+ if (info != 0) {
+ alaerh_(path, "DGELSD", &info, &c__0, " ", &m,
+ &n, &nrhs, &c_n1, &nb, &itype, &
+ nfail, &nerrs, nout);
+ }
+
+/* Test 15: Compute relative error in svd */
+
+ if (rank > 0) {
+ daxpy_(&mnmin, &c_b96, ©s[1], &c__1, &s[1]
+, &c__1);
+ result[14] = dasum_(&mnmin, &s[1], &c__1) /
+ dasum_(&mnmin, ©s[1], &c__1) / (
+ eps * (doublereal) mnmin);
+ } else {
+ result[14] = 0.;
+ }
+
+/* Test 16: Compute error in solution */
+
+ dlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
+ 1], &ldwork);
+ dqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
+ &lda, &b[1], &ldb, &work[1], &ldwork, &
+ work[m * nrhs + 1], &result[15]);
+
+/* Test 17: Check norm of r'*A */
+
+ result[16] = 0.;
+ if (m > crank) {
+ result[16] = dqrt17_("No transpose", &c__1, &
+ m, &n, &nrhs, ©a[1], &lda, &b[1],
+ &ldb, ©b[1], &ldb, &c__[1], &work[
+ 1], &lwork);
+ }
+
+/* Test 18: Check if x is in the rowspace of A */
+
+ result[17] = 0.;
+ if (n > crank) {
+ result[17] = dqrt14_("No transpose", &m, &n, &
+ nrhs, ©a[1], &lda, &b[1], &ldb, &
+ work[1], &lwork);
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 7; k <= 18; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&itype, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L90: */
+ }
+ nrun += 12;
+
+/* L100: */
+ }
+L110:
+ ;
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DDRVLS */
+
+} /* ddrvls_ */
diff --git a/TESTING/LIN/ddrvpb.c b/TESTING/LIN/ddrvpb.c
new file mode 100644
index 0000000..053a7de
--- /dev/null
+++ b/TESTING/LIN/ddrvpb.c
@@ -0,0 +1,827 @@
+/* ddrvpb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublereal c_b45 = 0.;
+static doublereal c_b46 = 1.;
+
+/* Subroutine */ int ddrvpb_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
+ doublereal *a, doublereal *afac, doublereal *asav, doublereal *b,
+ doublereal *bsav, doublereal *x, doublereal *xact, doublereal *s,
+ doublereal *work, doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*2] = "N" "Y";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, KD =\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002',"
+ " \002,i5,\002, \002,i5,\002, ... ), EQUED='\002,a1,\002', type"
+ " \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002',"
+ " \002,i5,\002, \002,i5,\002, ... ), type \002,i1,\002, test(\002"
+ ",i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, k, n, i1, i2, k1, kd, nb, in, kl, iw, ku, nt, lda, ikd, nkd,
+ ldab;
+ char fact[1];
+ integer ioff, mode, koff;
+ doublereal amax;
+ char path[3];
+ integer imat, info;
+ char dist[1], uplo[1], type__[1];
+ integer nrun, ifact;
+ extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *);
+ integer nfail, iseed[4], nfact;
+ extern doublereal dget06_(doublereal *, doublereal *);
+ extern /* Subroutine */ int dpbt01_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *), dpbt02_(char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *),
+ dpbt05_(char *, integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *);
+ integer kdval[4];
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ doublereal rcond, roldc, scond;
+ integer nimat;
+ doublereal anorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ logical equil;
+ extern /* Subroutine */ int dpbsv_(char *, integer *, integer *, integer *
+, doublereal *, integer *, doublereal *, integer *, integer *), dswap_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer iuplo, izero, nerrs;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), aladhd_(integer *,
+ char *);
+ extern doublereal dlange_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ logical prefac;
+ extern doublereal dlansb_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlaqsb_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ char *);
+ doublereal rcondc;
+ logical nofact;
+ char packit[1];
+ integer iequed;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *), dlaset_(char *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *), dpbequ_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *), alasvm_(char *, integer *, integer *,
+ integer *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublereal *, integer *, doublereal
+ *, integer *), dpbtrf_(char *, integer *,
+ integer *, doublereal *, integer *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int dpbtrs_(char *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, integer *, integer *), xlaenv_(integer *, integer *), dpbsvx_(char *, char *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, char *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *), derrvx_(char *, integer *);
+ doublereal result[6];
+
+ /* Fortran I/O blocks */
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVPB tests the driver routines DPBSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "PB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+ kdval[0] = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+
+/* Set limits on the number of loop iterations. */
+
+/* Computing MAX */
+ i__2 = 1, i__3 = min(n,4);
+ nkd = max(i__2,i__3);
+ nimat = 8;
+ if (n == 0) {
+ nimat = 1;
+ }
+
+ kdval[1] = n + (n + 1) / 4;
+ kdval[2] = (n * 3 - 1) / 4;
+ kdval[3] = (n + 1) / 4;
+
+ i__2 = nkd;
+ for (ikd = 1; ikd <= i__2; ++ikd) {
+
+/* Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order */
+/* makes it easier to skip redundant values for small values */
+/* of N. */
+
+ kd = kdval[ikd - 1];
+ ldab = kd + 1;
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ koff = 1;
+ if (iuplo == 1) {
+ *(unsigned char *)uplo = 'U';
+ *(unsigned char *)packit = 'Q';
+/* Computing MAX */
+ i__3 = 1, i__4 = kd + 2 - n;
+ koff = max(i__3,i__4);
+ } else {
+ *(unsigned char *)uplo = 'L';
+ *(unsigned char *)packit = 'B';
+ }
+
+ i__3 = nimat;
+ for (imat = 1; imat <= i__3; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L80;
+ }
+
+/* Skip types 2, 3, or 4 if the matrix size is too small. */
+
+ zerot = imat >= 2 && imat <= 4;
+ if (zerot && n < imat - 1) {
+ goto L80;
+ }
+
+ if (! zerot || ! dotype[1]) {
+
+/* Set up parameters with DLATB4 and generate a test */
+/* matrix with DLATMS. */
+
+ dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm,
+ &mode, &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)
+ 6);
+ dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode,
+ &cndnum, &anorm, &kd, &kd, packit, &a[koff],
+ &ldab, &work[1], &info);
+
+/* Check error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ goto L80;
+ }
+ } else if (izero > 0) {
+
+/* Use the same matrix for types 3 and 4 as for type */
+/* 2 by copying back the zeroed out column, */
+
+ iw = (lda << 1) + 1;
+ if (iuplo == 1) {
+ ioff = (izero - 1) * ldab + kd + 1;
+ i__4 = izero - i1;
+ dcopy_(&i__4, &work[iw], &c__1, &a[ioff - izero +
+ i1], &c__1);
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ dcopy_(&i__4, &work[iw], &c__1, &a[ioff], &i__5);
+ } else {
+ ioff = (i1 - 1) * ldab + 1;
+ i__4 = izero - i1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ dcopy_(&i__4, &work[iw], &c__1, &a[ioff + izero -
+ i1], &i__5);
+ ioff = (izero - 1) * ldab + 1;
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+ dcopy_(&i__4, &work[iw], &c__1, &a[ioff], &c__1);
+ }
+ }
+
+/* For types 2-4, zero one row and column of the matrix */
+/* to test that INFO is returned correctly. */
+
+ izero = 0;
+ if (zerot) {
+ if (imat == 2) {
+ izero = 1;
+ } else if (imat == 3) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+/* Save the zeroed out row and column in WORK(*,3) */
+
+ iw = lda << 1;
+/* Computing MIN */
+ i__5 = (kd << 1) + 1;
+ i__4 = min(i__5,n);
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ work[iw + i__] = 0.;
+/* L20: */
+ }
+ ++iw;
+/* Computing MAX */
+ i__4 = izero - kd;
+ i1 = max(i__4,1);
+/* Computing MIN */
+ i__4 = izero + kd;
+ i2 = min(i__4,n);
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * ldab + kd + 1;
+ i__4 = izero - i1;
+ dswap_(&i__4, &a[ioff - izero + i1], &c__1, &work[
+ iw], &c__1);
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ dswap_(&i__4, &a[ioff], &i__5, &work[iw], &c__1);
+ } else {
+ ioff = (i1 - 1) * ldab + 1;
+ i__4 = izero - i1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ dswap_(&i__4, &a[ioff + izero - i1], &i__5, &work[
+ iw], &c__1);
+ ioff = (izero - 1) * ldab + 1;
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+ dswap_(&i__4, &a[ioff], &c__1, &work[iw], &c__1);
+ }
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ i__4 = kd + 1;
+ dlacpy_("Full", &i__4, &n, &a[1], &ldab, &asav[1], &ldab);
+
+ for (iequed = 1; iequed <= 2; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__4 = nfact;
+ for (ifact = 1; ifact <= i__4; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L60;
+ }
+ rcondc = 0.;
+
+ } else if (! lsame_(fact, "N")) {
+
+/* Compute the condition number for comparison */
+/* with the value returned by DPBSVX (FACT = */
+/* 'N' reuses the condition number from the */
+/* previous iteration with FACT = 'F'). */
+
+ i__5 = kd + 1;
+ dlacpy_("Full", &i__5, &n, &asav[1], &ldab, &
+ afac[1], &ldab);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ dpbequ_(uplo, &n, &kd, &afac[1], &ldab, &
+ s[1], &scond, &amax, &info);
+ if (info == 0 && n > 0) {
+ if (iequed > 1) {
+ scond = 0.;
+ }
+
+/* Equilibrate the matrix. */
+
+ dlaqsb_(uplo, &n, &kd, &afac[1], &
+ ldab, &s[1], &scond, &amax,
+ equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in DGET04. */
+
+ if (equil) {
+ roldc = rcondc;
+ }
+
+/* Compute the 1-norm of A. */
+
+ anorm = dlansb_("1", uplo, &n, &kd, &afac[1],
+ &ldab, &rwork[1]);
+
+/* Factor the matrix A. */
+
+ dpbtrf_(uplo, &n, &kd, &afac[1], &ldab, &info);
+
+/* Form the inverse of A. */
+
+ dlaset_("Full", &n, &n, &c_b45, &c_b46, &a[1],
+ &lda);
+ s_copy(srnamc_1.srnamt, "DPBTRS", (ftnlen)32,
+ (ftnlen)6);
+ dpbtrs_(uplo, &n, &kd, &n, &afac[1], &ldab, &
+ a[1], &lda, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = dlange_("1", &n, &n, &a[1], &lda, &
+ rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondc = 1.;
+ } else {
+ rcondc = 1. / anorm / ainvnm;
+ }
+ }
+
+/* Restore the matrix A. */
+
+ i__5 = kd + 1;
+ dlacpy_("Full", &i__5, &n, &asav[1], &ldab, &a[1],
+ &ldab);
+
+/* Form an exact solution and set the right hand */
+/* side. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (
+ ftnlen)6);
+ dlarhs_(path, xtype, uplo, " ", &n, &n, &kd, &kd,
+ nrhs, &a[1], &ldab, &xact[1], &lda, &b[1],
+ &lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &
+ lda);
+
+ if (nofact) {
+
+/* --- Test DPBSV --- */
+
+/* Compute the L*L' or U'*U factorization of the */
+/* matrix and solve the system. */
+
+ i__5 = kd + 1;
+ dlacpy_("Full", &i__5, &n, &a[1], &ldab, &
+ afac[1], &ldab);
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1],
+ &lda);
+
+ s_copy(srnamc_1.srnamt, "DPBSV ", (ftnlen)32,
+ (ftnlen)6);
+ dpbsv_(uplo, &n, &kd, nrhs, &afac[1], &ldab, &
+ x[1], &lda, &info);
+
+/* Check error code from DPBSV . */
+
+ if (info != izero) {
+ alaerh_(path, "DPBSV ", &info, &izero,
+ uplo, &n, &n, &kd, &kd, nrhs, &
+ imat, &nfail, &nerrs, nout);
+ goto L40;
+ } else if (info != 0) {
+ goto L40;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ dpbt01_(uplo, &n, &kd, &a[1], &ldab, &afac[1],
+ &ldab, &rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[
+ 1], &lda);
+ dpbt02_(uplo, &n, &kd, nrhs, &a[1], &ldab, &x[
+ 1], &lda, &work[1], &lda, &rwork[1], &
+ result[1]);
+
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ i__5 = nt;
+ for (k = 1; k <= i__5; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___57.ciunit = *nout;
+ s_wsfe(&io___57);
+ do_fio(&c__1, "DPBSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L30: */
+ }
+ nrun += nt;
+L40:
+ ;
+ }
+
+/* --- Test DPBSVX --- */
+
+ if (! prefac) {
+ i__5 = kd + 1;
+ dlaset_("Full", &i__5, &n, &c_b45, &c_b45, &
+ afac[1], &ldab);
+ }
+ dlaset_("Full", &n, nrhs, &c_b45, &c_b45, &x[1], &
+ lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT='F' and */
+/* EQUED='Y' */
+
+ dlaqsb_(uplo, &n, &kd, &a[1], &ldab, &s[1], &
+ scond, &amax, equed);
+ }
+
+/* Solve the system and compute the condition */
+/* number and error bounds using DPBSVX. */
+
+ s_copy(srnamc_1.srnamt, "DPBSVX", (ftnlen)32, (
+ ftnlen)6);
+ dpbsvx_(fact, uplo, &n, &kd, nrhs, &a[1], &ldab, &
+ afac[1], &ldab, equed, &s[1], &b[1], &lda,
+ &x[1], &lda, &rcond, &rwork[1], &rwork[*
+ nrhs + 1], &work[1], &iwork[1], &info);
+
+/* Check the error code from DPBSVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__7[0] = 1, a__1[0] = fact;
+ i__7[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__7, &c__2, (ftnlen)2);
+ alaerh_(path, "DPBSVX", &info, &izero, ch__1,
+ &n, &n, &kd, &kd, nrhs, &imat, &nfail,
+ &nerrs, nout);
+ goto L60;
+ }
+
+ if (info == 0) {
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and */
+/* compute residual. */
+
+ dpbt01_(uplo, &n, &kd, &a[1], &ldab, &
+ afac[1], &ldab, &rwork[(*nrhs <<
+ 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ dlacpy_("Full", &n, nrhs, &bsav[1], &lda, &
+ work[1], &lda);
+ dpbt02_(uplo, &n, &kd, nrhs, &asav[1], &ldab,
+ &x[1], &lda, &work[1], &lda, &rwork[(*
+ nrhs << 1) + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &
+ lda, &rcondc, &result[2]);
+ } else {
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &
+ lda, &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ dpbt05_(uplo, &n, &kd, nrhs, &asav[1], &ldab,
+ &b[1], &lda, &x[1], &lda, &xact[1], &
+ lda, &rwork[1], &rwork[*nrhs + 1], &
+ result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from DPBSVX with the computed */
+/* value in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___60.ciunit = *nout;
+ s_wsfe(&io___60);
+ do_fio(&c__1, "DPBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___61.ciunit = *nout;
+ s_wsfe(&io___61);
+ do_fio(&c__1, "DPBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L50: */
+ }
+ nrun = nrun + 7 - k1;
+L60:
+ ;
+ }
+/* L70: */
+ }
+L80:
+ ;
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DDRVPB */
+
+} /* ddrvpb_ */
diff --git a/TESTING/LIN/ddrvpo.c b/TESTING/LIN/ddrvpo.c
new file mode 100644
index 0000000..635dba5
--- /dev/null
+++ b/TESTING/LIN/ddrvpo.c
@@ -0,0 +1,714 @@
+/* ddrvpo.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublereal c_b50 = 0.;
+
+/* Subroutine */ int ddrvpo_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
+ doublereal *a, doublereal *afac, doublereal *asav, doublereal *b,
+ doublereal *bsav, doublereal *x, doublereal *xact, doublereal *s,
+ doublereal *work, doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*2] = "N" "Y";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,"
+ "\002, test(\002,i1,\002) =\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, k, n, k1, nb, in, kl, ku, nt, lda;
+ char fact[1];
+ integer ioff, mode;
+ doublereal amax;
+ char path[3];
+ integer imat, info;
+ char dist[1], uplo[1], type__[1];
+ integer nrun, ifact;
+ extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *);
+ integer nfail, iseed[4], nfact;
+ extern doublereal dget06_(doublereal *, doublereal *);
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ doublereal rcond, roldc, scond;
+ integer nimat;
+ extern /* Subroutine */ int dpot01_(char *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *), dpot02_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *), dpot05_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *);
+ doublereal anorm;
+ logical equil;
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int dposv_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), aladhd_(integer *,
+ char *), alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ logical prefac;
+ doublereal rcondc;
+ logical nofact;
+ integer iequed;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *), dlaset_(char *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *), alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublereal *, integer *, doublereal
+ *, integer *);
+ doublereal ainvnm;
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dlaqsy_(char *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, char *), dpoequ_(integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *), dpotrf_(
+ char *, integer *, doublereal *, integer *, integer *),
+ dpotri_(char *, integer *, doublereal *, integer *, integer *), xlaenv_(integer *, integer *), derrvx_(char *, integer *);
+ doublereal result[6];
+ extern /* Subroutine */ int dposvx_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, char *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVPO tests the driver routines DPOSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "PO", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot && n < imat - 2) {
+ goto L120;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Set up parameters with DLATB4 and generate a test matrix */
+/* with DLATMS. */
+
+ dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
+ &info);
+
+/* Check error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L110;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff] = 0.;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff] = 0.;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ dlacpy_(uplo, &n, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 2; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__3 = nfact;
+ for (ifact = 1; ifact <= i__3; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L90;
+ }
+ rcondc = 0.;
+
+ } else if (! lsame_(fact, "N"))
+ {
+
+/* Compute the condition number for comparison with */
+/* the value returned by DPOSVX (FACT = 'N' reuses */
+/* the condition number from the previous iteration */
+/* with FACT = 'F'). */
+
+ dlacpy_(uplo, &n, &n, &asav[1], &lda, &afac[1], &
+ lda);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ dpoequ_(&n, &afac[1], &lda, &s[1], &scond, &
+ amax, &info);
+ if (info == 0 && n > 0) {
+ if (iequed > 1) {
+ scond = 0.;
+ }
+
+/* Equilibrate the matrix. */
+
+ dlaqsy_(uplo, &n, &afac[1], &lda, &s[1], &
+ scond, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in DGET04. */
+
+ if (equil) {
+ roldc = rcondc;
+ }
+
+/* Compute the 1-norm of A. */
+
+ anorm = dlansy_("1", uplo, &n, &afac[1], &lda, &
+ rwork[1]);
+
+/* Factor the matrix A. */
+
+ dpotrf_(uplo, &n, &afac[1], &lda, &info);
+
+/* Form the inverse of A. */
+
+ dlacpy_(uplo, &n, &n, &afac[1], &lda, &a[1], &lda);
+ dpotri_(uplo, &n, &a[1], &lda, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = dlansy_("1", uplo, &n, &a[1], &lda, &
+ rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondc = 1.;
+ } else {
+ rcondc = 1. / anorm / ainvnm;
+ }
+ }
+
+/* Restore the matrix A. */
+
+ dlacpy_(uplo, &n, &n, &asav[1], &lda, &a[1], &lda);
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku,
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
+
+ if (nofact) {
+
+/* --- Test DPOSV --- */
+
+/* Compute the L*L' or U'*U factorization of the */
+/* matrix and solve the system. */
+
+ dlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "DPOSV ", (ftnlen)32, (
+ ftnlen)6);
+ dposv_(uplo, &n, nrhs, &afac[1], &lda, &x[1], &
+ lda, &info);
+
+/* Check error code from DPOSV . */
+
+ if (info != izero) {
+ alaerh_(path, "DPOSV ", &info, &izero, uplo, &
+ n, &n, &c_n1, &c_n1, nrhs, &imat, &
+ nfail, &nerrs, nout);
+ goto L70;
+ } else if (info != 0) {
+ goto L70;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ dpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
+ rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
+ lda);
+ dpot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda,
+ &work[1], &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___48.ciunit = *nout;
+ s_wsfe(&io___48);
+ do_fio(&c__1, "DPOSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += nt;
+L70:
+ ;
+ }
+
+/* --- Test DPOSVX --- */
+
+ if (! prefac) {
+ dlaset_(uplo, &n, &n, &c_b50, &c_b50, &afac[1], &
+ lda);
+ }
+ dlaset_("Full", &n, nrhs, &c_b50, &c_b50, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT='F' and */
+/* EQUED='Y'. */
+
+ dlaqsy_(uplo, &n, &a[1], &lda, &s[1], &scond, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using DPOSVX. */
+
+ s_copy(srnamc_1.srnamt, "DPOSVX", (ftnlen)32, (ftnlen)
+ 6);
+ dposvx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1], &
+ lda, equed, &s[1], &b[1], &lda, &x[1], &lda, &
+ rcond, &rwork[1], &rwork[*nrhs + 1], &work[1],
+ &iwork[1], &info);
+
+/* Check the error code from DPOSVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "DPOSVX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L90;
+ }
+
+ if (info == 0) {
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ dpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda,
+ &rwork[(*nrhs << 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ dlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ dpot02_(uplo, &n, nrhs, &asav[1], &lda, &x[1], &
+ lda, &work[1], &lda, &rwork[(*nrhs << 1)
+ + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ dpot05_(uplo, &n, nrhs, &asav[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &rwork[*nrhs + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from DPOSVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___51.ciunit = *nout;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "DPOSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___52.ciunit = *nout;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "DPOSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + 7 - k1;
+L90:
+ ;
+ }
+/* L100: */
+ }
+L110:
+ ;
+ }
+L120:
+ ;
+ }
+/* L130: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DDRVPO */
+
+} /* ddrvpo_ */
diff --git a/TESTING/LIN/ddrvpox.c b/TESTING/LIN/ddrvpox.c
new file mode 100644
index 0000000..891ab13
--- /dev/null
+++ b/TESTING/LIN/ddrvpox.c
@@ -0,0 +1,879 @@
+/* ddrvpox.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "memory_alloc.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublereal c_b50 = 0.;
+
+/* Subroutine */ int ddrvpo_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
+ doublereal *a, doublereal *afac, doublereal *asav, doublereal *b,
+ doublereal *bsav, doublereal *x, doublereal *xact, doublereal *s,
+ doublereal *work, doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*2] = "N" "Y";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,"
+ "\002, test(\002,i1,\002) =\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ extern /* Subroutine */ int debchvxx_(doublereal *, char *);
+ integer i__, k, n;
+ doublereal *errbnds_c__, *errbnds_n__;
+ integer k1, nb, in, kl, ku, nt, n_err_bnds__, lda;
+ char fact[1];
+ integer ioff, mode;
+ doublereal amax;
+ char path[3];
+ integer imat, info;
+ doublereal *berr;
+ char dist[1];
+ doublereal rpvgrw_svxx__;
+ char uplo[1], type__[1];
+ integer nrun, ifact;
+ extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *);
+ integer nfail, iseed[4], nfact;
+ extern doublereal dget06_(doublereal *, doublereal *);
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ doublereal rcond, roldc, scond;
+ integer nimat;
+ extern /* Subroutine */ int dpot01_(char *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *), dpot02_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *), dpot05_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *);
+ doublereal anorm;
+ logical equil;
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int dposv_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), aladhd_(integer *,
+ char *), alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ logical prefac;
+ doublereal rcondc;
+ logical nofact;
+ integer iequed;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *), dlaset_(char *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *), alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublereal *, integer *, doublereal
+ *, integer *);
+ doublereal ainvnm;
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dlaqsy_(char *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, char *), dpoequ_(integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *), dpotrf_(
+ char *, integer *, doublereal *, integer *, integer *),
+ dpotri_(char *, integer *, doublereal *, integer *, integer *), xlaenv_(integer *, integer *), derrvx_(char *, integer *);
+ doublereal result[6];
+ extern /* Subroutine */ int dposvx_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, char *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *), dposvxx_(char *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, char *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVPO tests the driver routines DPOSV, -SVX, and -SVXX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "PO", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot && n < imat - 2) {
+ goto L120;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Set up parameters with DLATB4 and generate a test matrix */
+/* with DLATMS. */
+
+ dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
+ &info);
+
+/* Check error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L110;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff] = 0.;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff] = 0.;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ dlacpy_(uplo, &n, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 2; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__3 = nfact;
+ for (ifact = 1; ifact <= i__3; ++ifact) {
+ for (i__ = 1; i__ <= 6; ++i__) {
+ result[i__ - 1] = 0.;
+ }
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L90;
+ }
+ rcondc = 0.;
+
+ } else if (! lsame_(fact, "N"))
+ {
+
+/* Compute the condition number for comparison with */
+/* the value returned by DPOSVX (FACT = 'N' reuses */
+/* the condition number from the previous iteration */
+/* with FACT = 'F'). */
+
+ dlacpy_(uplo, &n, &n, &asav[1], &lda, &afac[1], &
+ lda);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ dpoequ_(&n, &afac[1], &lda, &s[1], &scond, &
+ amax, &info);
+ if (info == 0 && n > 0) {
+ if (iequed > 1) {
+ scond = 0.;
+ }
+
+/* Equilibrate the matrix. */
+
+ dlaqsy_(uplo, &n, &afac[1], &lda, &s[1], &
+ scond, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in DGET04. */
+
+ if (equil) {
+ roldc = rcondc;
+ }
+
+/* Compute the 1-norm of A. */
+
+ anorm = dlansy_("1", uplo, &n, &afac[1], &lda, &
+ rwork[1]);
+
+/* Factor the matrix A. */
+
+ dpotrf_(uplo, &n, &afac[1], &lda, &info);
+
+/* Form the inverse of A. */
+
+ dlacpy_(uplo, &n, &n, &afac[1], &lda, &a[1], &lda);
+ dpotri_(uplo, &n, &a[1], &lda, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = dlansy_("1", uplo, &n, &a[1], &lda, &
+ rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondc = 1.;
+ } else {
+ rcondc = 1. / anorm / ainvnm;
+ }
+ }
+
+/* Restore the matrix A. */
+
+ dlacpy_(uplo, &n, &n, &asav[1], &lda, &a[1], &lda);
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku,
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
+
+ if (nofact) {
+
+/* --- Test DPOSV --- */
+
+/* Compute the L*L' or U'*U factorization of the */
+/* matrix and solve the system. */
+
+ dlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "DPOSV ", (ftnlen)32, (
+ ftnlen)6);
+ dposv_(uplo, &n, nrhs, &afac[1], &lda, &x[1], &
+ lda, &info);
+
+/* Check error code from DPOSV . */
+
+ if (info != izero) {
+ alaerh_(path, "DPOSV ", &info, &izero, uplo, &
+ n, &n, &c_n1, &c_n1, nrhs, &imat, &
+ nfail, &nerrs, nout);
+ goto L70;
+ } else if (info != 0) {
+ goto L70;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ dpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
+ rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
+ lda);
+ dpot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda,
+ &work[1], &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___48.ciunit = *nout;
+ s_wsfe(&io___48);
+ do_fio(&c__1, "DPOSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += nt;
+L70:
+ ;
+ }
+
+/* --- Test DPOSVX --- */
+
+ if (! prefac) {
+ dlaset_(uplo, &n, &n, &c_b50, &c_b50, &afac[1], &
+ lda);
+ }
+ dlaset_("Full", &n, nrhs, &c_b50, &c_b50, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT='F' and */
+/* EQUED='Y'. */
+
+ dlaqsy_(uplo, &n, &a[1], &lda, &s[1], &scond, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using DPOSVX. */
+
+ s_copy(srnamc_1.srnamt, "DPOSVX", (ftnlen)32, (ftnlen)
+ 6);
+ dposvx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1], &
+ lda, equed, &s[1], &b[1], &lda, &x[1], &lda, &
+ rcond, &rwork[1], &rwork[*nrhs + 1], &work[1],
+ &iwork[1], &info);
+
+/* Check the error code from DPOSVX. */
+
+ if (info == n + 1) {
+ goto L90;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "DPOSVX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L90;
+ }
+
+ if (info == 0) {
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ dpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda,
+ &rwork[(*nrhs << 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ dlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ dpot02_(uplo, &n, nrhs, &asav[1], &lda, &x[1], &
+ lda, &work[1], &lda, &rwork[(*nrhs << 1)
+ + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ dpot05_(uplo, &n, nrhs, &asav[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &rwork[*nrhs + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from DPOSVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___51.ciunit = *nout;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "DPOSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___52.ciunit = *nout;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "DPOSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + 7 - k1;
+
+/* --- Test DPOSVXX --- */
+
+/* Restore the matrices A and B. */
+
+ dlacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
+ dlacpy_("Full", &n, nrhs, &bsav[1], &lda, &b[1], &lda);
+ if (! prefac) {
+ dlaset_(uplo, &n, &n, &c_b50, &c_b50, &afac[1], &
+ lda);
+ }
+ dlaset_("Full", &n, nrhs, &c_b50, &c_b50, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT='F' and */
+/* EQUED='Y'. */
+
+ dlaqsy_(uplo, &n, &a[1], &lda, &s[1], &scond, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using DPOSVXX. */
+
+ s_copy(srnamc_1.srnamt, "DPOSVXX", (ftnlen)32, (
+ ftnlen)7);
+
+ dalloc3();
+
+ dposvxx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1],
+ &lda, equed, &s[1], &b[1], &lda, &x[1], &lda,
+ &rcond, &rpvgrw_svxx__, berr, &n_err_bnds__,
+ errbnds_n__, errbnds_c__, &c__0, &c_b50, &
+ work[1], &iwork[1], &info);
+
+ free3();
+
+/* Check the error code from DPOSVXX. */
+
+ if (info == n + 1) {
+ goto L90;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "DPOSVXX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L90;
+ }
+
+ if (info == 0) {
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ dpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda,
+ &rwork[(*nrhs << 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ dlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ dpot02_(uplo, &n, nrhs, &asav[1], &lda, &x[1], &
+ lda, &work[1], &lda, &rwork[(*nrhs << 1)
+ + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ dpot05_(uplo, &n, nrhs, &asav[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &rwork[*nrhs + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from DPOSVXX with the computed value */
+/* in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___58.ciunit = *nout;
+ s_wsfe(&io___58);
+ do_fio(&c__1, "DPOSVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___59.ciunit = *nout;
+ s_wsfe(&io___59);
+ do_fio(&c__1, "DPOSVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L85: */
+ }
+ nrun = nrun + 7 - k1;
+L90:
+ ;
+ }
+/* L100: */
+ }
+L110:
+ ;
+ }
+L120:
+ ;
+ }
+/* L130: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+/* Test Error Bounds from DPOSVXX */
+ debchvxx_(thresh, path);
+ return 0;
+
+/* End of DDRVPO */
+
+} /* ddrvpo_ */
diff --git a/TESTING/LIN/ddrvpp.c b/TESTING/LIN/ddrvpp.c
new file mode 100644
index 0000000..23b9415
--- /dev/null
+++ b/TESTING/LIN/ddrvpp.c
@@ -0,0 +1,717 @@
+/* ddrvpp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static doublereal c_b60 = 0.;
+static integer c__2 = 2;
+
+/* Subroutine */ int ddrvpp_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
+ doublereal *a, doublereal *afac, doublereal *asav, doublereal *b,
+ doublereal *bsav, doublereal *x, doublereal *xact, doublereal *s,
+ doublereal *work, doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char facts[1*3] = "F" "N" "E";
+ static char packs[1*2] = "C" "R";
+ static char equeds[1*2] = "N" "Y";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,"
+ "\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, k, n, k1, in, kl, ku, nt, lda, npp;
+ char fact[1];
+ integer ioff, mode;
+ doublereal amax;
+ char path[3];
+ integer imat, info;
+ char dist[1], uplo[1], type__[1];
+ integer nrun, ifact;
+ extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *);
+ integer nfail, iseed[4], nfact;
+ extern doublereal dget06_(doublereal *, doublereal *);
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ doublereal roldc, rcond, scond;
+ integer nimat;
+ extern /* Subroutine */ int dppt01_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *), dppt02_(char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ doublereal anorm;
+ extern /* Subroutine */ int dppt05_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *), dcopy_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ logical equil;
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int dppsv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), aladhd_(integer *,
+ char *), alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ logical prefac;
+ doublereal rcondc;
+ logical nofact;
+ char packit[1];
+ integer iequed;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *), dlaset_(char *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *);
+ extern doublereal dlansp_(char *, char *, integer *, doublereal *,
+ doublereal *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int dlaqsp_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, char *),
+ dlatms_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublereal *, integer *, doublereal *, integer
+ *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int dppequ_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ dpptrf_(char *, integer *, doublereal *, integer *),
+ dpptri_(char *, integer *, doublereal *, integer *),
+ derrvx_(char *, integer *);
+ doublereal result[6];
+ extern /* Subroutine */ int dppsvx_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, char *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVPP tests the driver routines DPPSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AFAC (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* ASAV (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "PP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ npp = n * (n + 1) / 2;
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L130;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot && n < imat - 2) {
+ goto L130;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ *(unsigned char *)packit = *(unsigned char *)&packs[iuplo - 1]
+ ;
+
+/* Set up parameters with DLATB4 and generate a test matrix */
+/* with DLATMS. */
+
+ dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+ rcondc = 1. / cndnum;
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
+ 1], &info);
+
+/* Check error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L120;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * izero / 2;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff] = 0.;
+ ioff += i__;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff] = 0.;
+ ioff = ioff + n - i__;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ dcopy_(&npp, &a[1], &c__1, &asav[1], &c__1);
+
+ for (iequed = 1; iequed <= 2; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__3 = nfact;
+ for (ifact = 1; ifact <= i__3; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L100;
+ }
+ rcondc = 0.;
+
+ } else if (! lsame_(fact, "N"))
+ {
+
+/* Compute the condition number for comparison with */
+/* the value returned by DPPSVX (FACT = 'N' reuses */
+/* the condition number from the previous iteration */
+/* with FACT = 'F'). */
+
+ dcopy_(&npp, &asav[1], &c__1, &afac[1], &c__1);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ dppequ_(uplo, &n, &afac[1], &s[1], &scond, &
+ amax, &info);
+ if (info == 0 && n > 0) {
+ if (iequed > 1) {
+ scond = 0.;
+ }
+
+/* Equilibrate the matrix. */
+
+ dlaqsp_(uplo, &n, &afac[1], &s[1], &scond,
+ &amax, equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in DGET04. */
+
+ if (equil) {
+ roldc = rcondc;
+ }
+
+/* Compute the 1-norm of A. */
+
+ anorm = dlansp_("1", uplo, &n, &afac[1], &rwork[1]
+);
+
+/* Factor the matrix A. */
+
+ dpptrf_(uplo, &n, &afac[1], &info);
+
+/* Form the inverse of A. */
+
+ dcopy_(&npp, &afac[1], &c__1, &a[1], &c__1);
+ dpptri_(uplo, &n, &a[1], &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = dlansp_("1", uplo, &n, &a[1], &rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondc = 1.;
+ } else {
+ rcondc = 1. / anorm / ainvnm;
+ }
+ }
+
+/* Restore the matrix A. */
+
+ dcopy_(&npp, &asav[1], &c__1, &a[1], &c__1);
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku,
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
+
+ if (nofact) {
+
+/* --- Test DPPSV --- */
+
+/* Compute the L*L' or U'*U factorization of the */
+/* matrix and solve the system. */
+
+ dcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "DPPSV ", (ftnlen)32, (
+ ftnlen)6);
+ dppsv_(uplo, &n, nrhs, &afac[1], &x[1], &lda, &
+ info);
+
+/* Check error code from DPPSV . */
+
+ if (info != izero) {
+ alaerh_(path, "DPPSV ", &info, &izero, uplo, &
+ n, &n, &c_n1, &c_n1, nrhs, &imat, &
+ nfail, &nerrs, nout);
+ goto L70;
+ } else if (info != 0) {
+ goto L70;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ dppt01_(uplo, &n, &a[1], &afac[1], &rwork[1],
+ result);
+
+/* Compute residual of the computed solution. */
+
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
+ lda);
+ dppt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[
+ 1], &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___49.ciunit = *nout;
+ s_wsfe(&io___49);
+ do_fio(&c__1, "DPPSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += nt;
+L70:
+ ;
+ }
+
+/* --- Test DPPSVX --- */
+
+ if (! prefac && npp > 0) {
+ dlaset_("Full", &npp, &c__1, &c_b60, &c_b60, &
+ afac[1], &npp);
+ }
+ dlaset_("Full", &n, nrhs, &c_b60, &c_b60, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT='F' and */
+/* EQUED='Y'. */
+
+ dlaqsp_(uplo, &n, &a[1], &s[1], &scond, &amax,
+ equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using DPPSVX. */
+
+ s_copy(srnamc_1.srnamt, "DPPSVX", (ftnlen)32, (ftnlen)
+ 6);
+ dppsvx_(fact, uplo, &n, nrhs, &a[1], &afac[1], equed,
+ &s[1], &b[1], &lda, &x[1], &lda, &rcond, &
+ rwork[1], &rwork[*nrhs + 1], &work[1], &iwork[
+ 1], &info);
+
+/* Check the error code from DPPSVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "DPPSVX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L90;
+ }
+
+ if (info == 0) {
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ dppt01_(uplo, &n, &a[1], &afac[1], &rwork[(*
+ nrhs << 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ dlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ dppt02_(uplo, &n, nrhs, &asav[1], &x[1], &lda, &
+ work[1], &lda, &rwork[(*nrhs << 1) + 1], &
+ result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ dppt05_(uplo, &n, nrhs, &asav[1], &b[1], &lda, &x[
+ 1], &lda, &xact[1], &lda, &rwork[1], &
+ rwork[*nrhs + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from DPPSVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___52.ciunit = *nout;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "DPPSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___53.ciunit = *nout;
+ s_wsfe(&io___53);
+ do_fio(&c__1, "DPPSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + 7 - k1;
+L90:
+L100:
+ ;
+ }
+/* L110: */
+ }
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DDRVPP */
+
+} /* ddrvpp_ */
diff --git a/TESTING/LIN/ddrvpt.c b/TESTING/LIN/ddrvpt.c
new file mode 100644
index 0000000..ff2e5a2
--- /dev/null
+++ b/TESTING/LIN/ddrvpt.c
@@ -0,0 +1,658 @@
+/* ddrvpt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static doublereal c_b23 = 1.;
+static doublereal c_b24 = 0.;
+
+/* Subroutine */ int ddrvpt_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, doublereal *a,
+ doublereal *d__, doublereal *e, doublereal *b, doublereal *x,
+ doublereal *xact, doublereal *work, doublereal *rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 0,0,0,1 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
+ ", test \002,i2,\002, ratio = \002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i2,\002, test \002,i2,\002, ratio = \002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n;
+ doublereal z__[3];
+ integer k1, ia, in, kl, ku, ix, nt, lda;
+ char fact[1];
+ doublereal cond;
+ integer mode;
+ doublereal dmax__;
+ integer imat, info;
+ char path[3], dist[1], type__[1];
+ integer nrun, ifact;
+ extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *),
+ dscal_(integer *, doublereal *, doublereal *, integer *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ doublereal rcond;
+ integer nimat;
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal anorm;
+ extern /* Subroutine */ int dptt01_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *), dcopy_(
+ integer *, doublereal *, integer *, doublereal *, integer *),
+ dptt02_(integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *),
+ dptt05_(integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *);
+ integer izero, nerrs;
+ extern /* Subroutine */ int dptsv_(integer *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *);
+ logical zerot;
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), aladhd_(integer *,
+ char *), alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal rcondc;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), dlaptm_(integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), alasvm_(char *, integer *
+, integer *, integer *, integer *), dlatms_(integer *,
+ integer *, char *, integer *, char *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *, char *,
+ doublereal *, integer *, doublereal *, integer *);
+ extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
+ extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *,
+ doublereal *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int dpttrf_(integer *, doublereal *, doublereal *,
+ integer *), derrvx_(char *, integer *);
+ doublereal result[6];
+ extern /* Subroutine */ int dpttrs_(integer *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *), dptsvx_(char *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVPT tests DPTSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*2) */
+
+/* D (workspace) DOUBLE PRECISION array, dimension (NMAX*2) */
+
+/* E (workspace) DOUBLE PRECISION array, dimension (NMAX*2) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NRHS)) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --e;
+ --d__;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "PT", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+ lda = max(1,n);
+ nimat = 12;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (n > 0 && ! dotype[imat]) {
+ goto L110;
+ }
+
+/* Set up parameters with DLATB4. */
+
+ dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cond, dist);
+
+ zerot = imat >= 8 && imat <= 10;
+ if (imat <= 6) {
+
+/* Type 1-6: generate a symmetric tridiagonal matrix of */
+/* known condition number in lower triangular band storage. */
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
+ &anorm, &kl, &ku, "B", &a[1], &c__2, &work[1], &info);
+
+/* Check the error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, " ", &n, &n, &kl, &
+ ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L110;
+ }
+ izero = 0;
+
+/* Copy the matrix to D and E. */
+
+ ia = 1;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d__[i__] = a[ia];
+ e[i__] = a[ia + 1];
+ ia += 2;
+/* L20: */
+ }
+ if (n > 0) {
+ d__[n] = a[ia];
+ }
+ } else {
+
+/* Type 7-12: generate a diagonally dominant matrix with */
+/* unknown condition number in the vectors D and E. */
+
+ if (! zerot || ! dotype[7]) {
+
+/* Let D and E have values from [-1,1]. */
+
+ dlarnv_(&c__2, iseed, &n, &d__[1]);
+ i__3 = n - 1;
+ dlarnv_(&c__2, iseed, &i__3, &e[1]);
+
+/* Make the tridiagonal matrix diagonally dominant. */
+
+ if (n == 1) {
+ d__[1] = abs(d__[1]);
+ } else {
+ d__[1] = abs(d__[1]) + abs(e[1]);
+ d__[n] = (d__1 = d__[n], abs(d__1)) + (d__2 = e[n - 1]
+ , abs(d__2));
+ i__3 = n - 1;
+ for (i__ = 2; i__ <= i__3; ++i__) {
+ d__[i__] = (d__1 = d__[i__], abs(d__1)) + (d__2 =
+ e[i__], abs(d__2)) + (d__3 = e[i__ - 1],
+ abs(d__3));
+/* L30: */
+ }
+ }
+
+/* Scale D and E so the maximum element is ANORM. */
+
+ ix = idamax_(&n, &d__[1], &c__1);
+ dmax__ = d__[ix];
+ d__1 = anorm / dmax__;
+ dscal_(&n, &d__1, &d__[1], &c__1);
+ if (n > 1) {
+ i__3 = n - 1;
+ d__1 = anorm / dmax__;
+ dscal_(&i__3, &d__1, &e[1], &c__1);
+ }
+
+ } else if (izero > 0) {
+
+/* Reuse the last matrix by copying back the zeroed out */
+/* elements. */
+
+ if (izero == 1) {
+ d__[1] = z__[1];
+ if (n > 1) {
+ e[1] = z__[2];
+ }
+ } else if (izero == n) {
+ e[n - 1] = z__[0];
+ d__[n] = z__[1];
+ } else {
+ e[izero - 1] = z__[0];
+ d__[izero] = z__[1];
+ e[izero] = z__[2];
+ }
+ }
+
+/* For types 8-10, set one row and column of the matrix to */
+/* zero. */
+
+ izero = 0;
+ if (imat == 8) {
+ izero = 1;
+ z__[1] = d__[1];
+ d__[1] = 0.;
+ if (n > 1) {
+ z__[2] = e[1];
+ e[1] = 0.;
+ }
+ } else if (imat == 9) {
+ izero = n;
+ if (n > 1) {
+ z__[0] = e[n - 1];
+ e[n - 1] = 0.;
+ }
+ z__[1] = d__[n];
+ d__[n] = 0.;
+ } else if (imat == 10) {
+ izero = (n + 1) / 2;
+ if (izero > 1) {
+ z__[0] = e[izero - 1];
+ z__[2] = e[izero];
+ e[izero - 1] = 0.;
+ e[izero] = 0.;
+ }
+ z__[1] = d__[izero];
+ d__[izero] = 0.;
+ }
+ }
+
+/* Generate NRHS random solution vectors. */
+
+ ix = 1;
+ i__3 = *nrhs;
+ for (j = 1; j <= i__3; ++j) {
+ dlarnv_(&c__2, iseed, &n, &xact[ix]);
+ ix += lda;
+/* L40: */
+ }
+
+/* Set the right hand side. */
+
+ dlaptm_(&n, nrhs, &c_b23, &d__[1], &e[1], &xact[1], &lda, &c_b24,
+ &b[1], &lda);
+
+ for (ifact = 1; ifact <= 2; ++ifact) {
+ if (ifact == 1) {
+ *(unsigned char *)fact = 'F';
+ } else {
+ *(unsigned char *)fact = 'N';
+ }
+
+/* Compute the condition number for comparison with */
+/* the value returned by DPTSVX. */
+
+ if (zerot) {
+ if (ifact == 1) {
+ goto L100;
+ }
+ rcondc = 0.;
+
+ } else if (ifact == 1) {
+
+/* Compute the 1-norm of A. */
+
+ anorm = dlanst_("1", &n, &d__[1], &e[1]);
+
+ dcopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
+ if (n > 1) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
+ }
+
+/* Factor the matrix A. */
+
+ dpttrf_(&n, &d__[n + 1], &e[n + 1], &info);
+
+/* Use DPTTRS to solve for one column at a time of */
+/* inv(A), computing the maximum column sum as we go. */
+
+ ainvnm = 0.;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ x[j] = 0.;
+/* L50: */
+ }
+ x[i__] = 1.;
+ dpttrs_(&n, &c__1, &d__[n + 1], &e[n + 1], &x[1], &
+ lda, &info);
+/* Computing MAX */
+ d__1 = ainvnm, d__2 = dasum_(&n, &x[1], &c__1);
+ ainvnm = max(d__1,d__2);
+/* L60: */
+ }
+
+/* Compute the 1-norm condition number of A. */
+
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondc = 1.;
+ } else {
+ rcondc = 1. / anorm / ainvnm;
+ }
+ }
+
+ if (ifact == 2) {
+
+/* --- Test DPTSV -- */
+
+ dcopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
+ if (n > 1) {
+ i__3 = n - 1;
+ dcopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
+ }
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
+
+/* Factor A as L*D*L' and solve the system A*X = B. */
+
+ s_copy(srnamc_1.srnamt, "DPTSV ", (ftnlen)32, (ftnlen)6);
+ dptsv_(&n, nrhs, &d__[n + 1], &e[n + 1], &x[1], &lda, &
+ info);
+
+/* Check error code from DPTSV . */
+
+ if (info != izero) {
+ alaerh_(path, "DPTSV ", &info, &izero, " ", &n, &n, &
+ c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+ nt = 0;
+ if (izero == 0) {
+
+/* Check the factorization by computing the ratio */
+/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
+
+ dptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
+ work[1], result);
+
+/* Compute the residual in the solution. */
+
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ dptt02_(&n, nrhs, &d__[1], &e[1], &x[1], &lda, &work[
+ 1], &lda, &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, "DPTSV ", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L70: */
+ }
+ nrun += nt;
+ }
+
+/* --- Test DPTSVX --- */
+
+ if (ifact > 1) {
+
+/* Initialize D( N+1:2*N ) and E( N+1:2*N ) to zero. */
+
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d__[n + i__] = 0.;
+ e[n + i__] = 0.;
+/* L80: */
+ }
+ if (n > 0) {
+ d__[n + n] = 0.;
+ }
+ }
+
+ dlaset_("Full", &n, nrhs, &c_b24, &c_b24, &x[1], &lda);
+
+/* Solve the system and compute the condition number and */
+/* error bounds using DPTSVX. */
+
+ s_copy(srnamc_1.srnamt, "DPTSVX", (ftnlen)32, (ftnlen)6);
+ dptsvx_(fact, &n, nrhs, &d__[1], &e[1], &d__[n + 1], &e[n + 1]
+, &b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &rwork[
+ *nrhs + 1], &work[1], &info);
+
+/* Check the error code from DPTSVX. */
+
+ if (info != izero) {
+ alaerh_(path, "DPTSVX", &info, &izero, fact, &n, &n, &
+ c__1, &c__1, nrhs, &imat, &nfail, &nerrs, nout);
+ }
+ if (izero == 0) {
+ if (ifact == 2) {
+
+/* Check the factorization by computing the ratio */
+/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
+
+ k1 = 1;
+ dptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
+ work[1], result);
+ } else {
+ k1 = 2;
+ }
+
+/* Compute the residual in the solution. */
+
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ dptt02_(&n, nrhs, &d__[1], &e[1], &x[1], &lda, &work[1], &
+ lda, &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[2]);
+
+/* Check error bounds from iterative refinement. */
+
+ dptt05_(&n, nrhs, &d__[1], &e[1], &b[1], &lda, &x[1], &
+ lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs + 1],
+ &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Check the reciprocal of the condition number. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, "DPTSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L90: */
+ }
+ nrun = nrun + 7 - k1;
+L100:
+ ;
+ }
+L110:
+ ;
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DDRVPT */
+
+} /* ddrvpt_ */
diff --git a/TESTING/LIN/ddrvrf1.c b/TESTING/LIN/ddrvrf1.c
new file mode 100644
index 0000000..cdda2e9
--- /dev/null
+++ b/TESTING/LIN/ddrvrf1.c
@@ -0,0 +1,342 @@
+/* ddrvrf1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* Subroutine */ int ddrvrf1_(integer *nout, integer *nn, integer *nval,
+ doublereal *thresh, doublereal *a, integer *lda, doublereal *arf,
+ doublereal *work)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char forms[1*2] = "N" "T";
+ static char norms[1*4] = "M" "1" "I" "F";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002 *** Error(s) or Failure(s) while test"
+ "ing DLANSF ***\002)";
+ static char fmt_9998[] = "(1x,\002 Error in \002,a6,\002 with UPLO="
+ "'\002,a1,\002', FORM='\002,a1,\002', N=\002,i5)";
+ static char fmt_9997[] = "(1x,\002 Failure in \002,a6,\002 N=\002,"
+ "i5,\002 TYPE=\002,i5,\002 UPLO='\002,a1,\002', FORM ='\002,a1"
+ ",\002', NORM='\002,a1,\002', test=\002,g12.5)";
+ static char fmt_9996[] = "(1x,\002All tests for \002,a6,\002 auxiliary r"
+ "outine passed the \002,\002threshold (\002,i5,\002 tests run)"
+ "\002)";
+ static char fmt_9995[] = "(1x,a6,\002 auxiliary routine:\002,i5,\002 out"
+ " of \002,i5,\002 tests failed to pass the threshold\002)";
+ static char fmt_9994[] = "(26x,i5,\002 error message recorded (\002,a6"
+ ",\002)\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void),
+ do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, n, iin, iit;
+ doublereal eps;
+ integer info;
+ char norm[1], uplo[1];
+ integer nrun, nfail;
+ doublereal large;
+ integer iseed[4];
+ char cform[1];
+ doublereal small;
+ integer iform;
+ doublereal norma;
+ integer inorm, iuplo, nerrs;
+ extern doublereal dlamch_(char *), dlarnd_(integer *, integer *),
+ dlansf_(char *, char *, char *, integer *, doublereal *,
+ doublereal *), dlansy_(char *, char *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dtrttf_(char *, char *, integer *, doublereal
+ *, integer *, doublereal *, integer *);
+ doublereal result[1], normarf;
+
+ /* Fortran I/O blocks */
+ static cilist io___22 = { 0, 0, 0, 0, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___30 = { 0, 0, 0, 0, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVRF1 tests the LAPACK RFP routines: */
+/* DLANSF */
+
+/* Arguments */
+/* ========= */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* THRESH (input) 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. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,NMAX). */
+
+/* ARF (workspace) DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension ( NMAX ) */
+
+/* ===================================================================== */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nval;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --arf;
+ --work;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ info = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+ eps = dlamch_("Precision");
+ small = dlamch_("Safe minimum");
+ large = 1. / small;
+ small = small * *lda * *lda;
+ large = large / *lda / *lda;
+
+ i__1 = *nn;
+ for (iin = 1; iin <= i__1; ++iin) {
+
+ n = nval[iin];
+
+ for (iit = 1; iit <= 3; ++iit) {
+
+/* IIT = 1 : random matrix */
+/* IIT = 2 : random matrix scaled near underflow */
+/* IIT = 3 : random matrix scaled near overflow */
+
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[i__ + j * a_dim1] = dlarnd_(&c__2, iseed);
+ }
+ }
+
+ if (iit == 2) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[i__ + j * a_dim1] *= large;
+ }
+ }
+ }
+
+ if (iit == 3) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[i__ + j * a_dim1] *= small;
+ }
+ }
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Do first for CFORM = 'N', then for CFORM = 'C' */
+
+ for (iform = 1; iform <= 2; ++iform) {
+
+ *(unsigned char *)cform = *(unsigned char *)&forms[iform
+ - 1];
+
+ s_copy(srnamc_1.srnamt, "DTRTTF", (ftnlen)32, (ftnlen)6);
+ dtrttf_(cform, uplo, &n, &a[a_offset], lda, &arf[1], &
+ info);
+
+/* Check error code from DTRTTF */
+
+ if (info != 0) {
+ if (nfail == 0 && nerrs == 0) {
+ io___22.ciunit = *nout;
+ s_wsle(&io___22);
+ e_wsle();
+ io___23.ciunit = *nout;
+ s_wsfe(&io___23);
+ e_wsfe();
+ }
+ io___24.ciunit = *nout;
+ s_wsfe(&io___24);
+ do_fio(&c__1, srnamc_1.srnamt, (ftnlen)32);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, cform, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ++nerrs;
+ goto L100;
+ }
+
+ for (inorm = 1; inorm <= 4; ++inorm) {
+
+/* Check all four norms: 'M', '1', 'I', 'F' */
+
+ *(unsigned char *)norm = *(unsigned char *)&norms[
+ inorm - 1];
+ normarf = dlansf_(norm, cform, uplo, &n, &arf[1], &
+ work[1]);
+ norma = dlansy_(norm, uplo, &n, &a[a_offset], lda, &
+ work[1]);
+
+ result[0] = (norma - normarf) / norma / eps;
+ ++nrun;
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ io___30.ciunit = *nout;
+ s_wsle(&io___30);
+ e_wsle();
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ e_wsfe();
+ }
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "DLANSF", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iit, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, cform, (ftnlen)1);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L90: */
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+
+/* Print a summary of the results. */
+
+ if (nfail == 0) {
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, "DLANSF", (ftnlen)6);
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "DLANSF", (ftnlen)6);
+ do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (nerrs != 0) {
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, (char *)&nerrs, (ftnlen)sizeof(integer));
+ do_fio(&c__1, "DLANSF", (ftnlen)6);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of DDRVRF1 */
+
+} /* ddrvrf1_ */
diff --git a/TESTING/LIN/ddrvrf2.c b/TESTING/LIN/ddrvrf2.c
new file mode 100644
index 0000000..bf71603
--- /dev/null
+++ b/TESTING/LIN/ddrvrf2.c
@@ -0,0 +1,311 @@
+/* ddrvrf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* Subroutine */ int ddrvrf2_(integer *nout, integer *nn, integer *nval,
+ doublereal *a, integer *lda, doublereal *arf, doublereal *ap,
+ doublereal *asav)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char forms[1*2] = "N" "T";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002 *** Error(s) while testing the RFP co"
+ "nvertion\002,\002 routines ***\002)";
+ static char fmt_9998[] = "(1x,\002 Error in RFP,convertion routines "
+ "N=\002,i5,\002 UPLO='\002,a1,\002', FORM ='\002,a1,\002'\002)";
+ static char fmt_9997[] = "(1x,\002All tests for the RFP convertion routi"
+ "nes passed (\002,i5,\002 tests run)\002)";
+ static char fmt_9996[] = "(1x,\002RFP convertion routines:\002,i5,\002 o"
+ "ut of \002,i5,\002 error message recorded\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, asav_dim1, asav_offset, i__1, i__2, i__3;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void),
+ do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, n;
+ logical ok1, ok2;
+ integer iin, info;
+ char uplo[1];
+ integer nrun, iseed[4];
+ char cform[1];
+ integer iform;
+ logical lower;
+ integer iuplo, nerrs;
+ extern doublereal dlarnd_(integer *, integer *);
+ extern /* Subroutine */ int dtfttp_(char *, char *, integer *, doublereal
+ *, doublereal *, integer *), dtpttf_(char *, char
+ *, integer *, doublereal *, doublereal *, integer *), dtfttr_(char *, char *, integer *, doublereal *,
+ doublereal *, integer *, integer *), dtrttf_(char
+ *, char *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dtrttp_(char *, integer *, doublereal
+ *, integer *, doublereal *, integer *), dtpttr_(char *,
+ integer *, doublereal *, doublereal *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___19 = { 0, 0, 0, 0, 0 };
+ static cilist io___20 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___21 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVRF2 tests the LAPACK RFP convertion routines. */
+
+/* Arguments */
+/* ========= */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,NMAX). */
+
+/* ARF (workspace) DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2). */
+
+/* AP (workspace) DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2). */
+
+/* A2 (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) */
+
+/* ===================================================================== */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nval;
+ asav_dim1 = *lda;
+ asav_offset = 1 + asav_dim1;
+ asav -= asav_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --arf;
+ --ap;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ nrun = 0;
+ nerrs = 0;
+ info = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+ i__1 = *nn;
+ for (iin = 1; iin <= i__1; ++iin) {
+
+ n = nval[iin];
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ lower = TRUE_;
+ if (iuplo == 1) {
+ lower = FALSE_;
+ }
+
+/* Do first for CFORM = 'N', then for CFORM = 'T' */
+
+ for (iform = 1; iform <= 2; ++iform) {
+
+ *(unsigned char *)cform = *(unsigned char *)&forms[iform - 1];
+
+ ++nrun;
+
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[i__ + j * a_dim1] = dlarnd_(&c__2, iseed);
+ }
+ }
+
+ s_copy(srnamc_1.srnamt, "DTRTTF", (ftnlen)32, (ftnlen)6);
+ dtrttf_(cform, uplo, &n, &a[a_offset], lda, &arf[1], &info);
+
+ s_copy(srnamc_1.srnamt, "DTFTTP", (ftnlen)32, (ftnlen)6);
+ dtfttp_(cform, uplo, &n, &arf[1], &ap[1], &info);
+
+ s_copy(srnamc_1.srnamt, "DTPTTR", (ftnlen)32, (ftnlen)6);
+ dtpttr_(uplo, &n, &ap[1], &asav[asav_offset], lda, &info);
+
+ ok1 = TRUE_;
+ if (lower) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ if (a[i__ + j * a_dim1] != asav[i__ + j *
+ asav_dim1]) {
+ ok1 = FALSE_;
+ }
+ }
+ }
+ } else {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (a[i__ + j * a_dim1] != asav[i__ + j *
+ asav_dim1]) {
+ ok1 = FALSE_;
+ }
+ }
+ }
+ }
+
+ ++nrun;
+
+ s_copy(srnamc_1.srnamt, "DTRTTP", (ftnlen)32, (ftnlen)6);
+ dtrttp_(uplo, &n, &a[a_offset], lda, &ap[1], &info)
+ ;
+
+ s_copy(srnamc_1.srnamt, "DTPTTF", (ftnlen)32, (ftnlen)6);
+ dtpttf_(cform, uplo, &n, &ap[1], &arf[1], &info);
+
+ s_copy(srnamc_1.srnamt, "DTFTTR", (ftnlen)32, (ftnlen)6);
+ dtfttr_(cform, uplo, &n, &arf[1], &asav[asav_offset], lda, &
+ info);
+
+ ok2 = TRUE_;
+ if (lower) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ if (a[i__ + j * a_dim1] != asav[i__ + j *
+ asav_dim1]) {
+ ok2 = FALSE_;
+ }
+ }
+ }
+ } else {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (a[i__ + j * a_dim1] != asav[i__ + j *
+ asav_dim1]) {
+ ok2 = FALSE_;
+ }
+ }
+ }
+ }
+
+ if (! ok1 || ! ok2) {
+ if (nerrs == 0) {
+ io___19.ciunit = *nout;
+ s_wsle(&io___19);
+ e_wsle();
+ io___20.ciunit = *nout;
+ s_wsfe(&io___20);
+ e_wsfe();
+ }
+ io___21.ciunit = *nout;
+ s_wsfe(&io___21);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, cform, (ftnlen)1);
+ e_wsfe();
+ ++nerrs;
+ }
+
+/* L100: */
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ if (nerrs == 0) {
+ io___22.ciunit = *nout;
+ s_wsfe(&io___22);
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___23.ciunit = *nout;
+ s_wsfe(&io___23);
+ do_fio(&c__1, (char *)&nerrs, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of DDRVRF2 */
+
+} /* ddrvrf2_ */
diff --git a/TESTING/LIN/ddrvrf3.c b/TESTING/LIN/ddrvrf3.c
new file mode 100644
index 0000000..110668b
--- /dev/null
+++ b/TESTING/LIN/ddrvrf3.c
@@ -0,0 +1,439 @@
+/* ddrvrf3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* Subroutine */ int ddrvrf3_(integer *nout, integer *nn, integer *nval,
+ doublereal *thresh, doublereal *a, integer *lda, doublereal *arf,
+ doublereal *b1, doublereal *b2, doublereal *d_work_dlange__,
+ doublereal *d_work_dgeqrf__, doublereal *tau)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char forms[1*2] = "N" "T";
+ static char sides[1*2] = "L" "R";
+ static char transs[1*2] = "N" "T";
+ static char diags[1*2] = "N" "U";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002 *** Error(s) or Failure(s) while test"
+ "ing DTFSM ***\002)";
+ static char fmt_9997[] = "(1x,\002 Failure in \002,a5,\002, CFORM="
+ "'\002,a1,\002',\002,\002 SIDE='\002,a1,\002',\002,\002 UPLO='"
+ "\002,a1,\002',\002,\002 TRANS='\002,a1,\002',\002,\002 DIAG='"
+ "\002,a1,\002',\002,\002 M=\002,i3,\002, N =\002,i3,\002, test"
+ "=\002,g12.5)";
+ static char fmt_9996[] = "(1x,\002All tests for \002,a5,\002 auxiliary r"
+ "outine passed the \002,\002threshold (\002,i5,\002 tests run)"
+ "\002)";
+ static char fmt_9995[] = "(1x,a6,\002 auxiliary routine:\002,i5,\002 out"
+ " of \002,i5,\002 tests failed to pass the threshold\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b1_dim1, b1_offset, b2_dim1, b2_offset, i__1,
+ i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void),
+ do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, m, n, na, iim, iin;
+ doublereal eps;
+ char diag[1], side[1];
+ integer info;
+ char uplo[1];
+ integer nrun, idiag;
+ doublereal alpha;
+ integer nfail, iseed[4], iside;
+ char cform[1];
+ integer iform;
+ extern /* Subroutine */ int dtfsm_(char *, char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *);
+ char trans[1];
+ integer iuplo;
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ integer ialpha;
+ extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *);
+ extern doublereal dlarnd_(integer *, integer *);
+ extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *);
+ integer itrans;
+ extern /* Subroutine */ int dtrttf_(char *, char *, integer *, doublereal
+ *, integer *, doublereal *, integer *);
+ doublereal result[1];
+
+ /* Fortran I/O blocks */
+ static cilist io___32 = { 0, 0, 0, 0, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVRF3 tests the LAPACK RFP routines: */
+/* DTFSM */
+
+/* Arguments */
+/* ========= */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* THRESH (input) 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. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,NMAX). */
+
+/* ARF (workspace) DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2). */
+
+/* B1 (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) */
+
+/* B2 (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) */
+
+/* D_WORK_DLANGE (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* D_WORK_DGEQRF (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* TAU (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* ===================================================================== */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nval;
+ b2_dim1 = *lda;
+ b2_offset = 1 + b2_dim1;
+ b2 -= b2_offset;
+ b1_dim1 = *lda;
+ b1_offset = 1 + b1_dim1;
+ b1 -= b1_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --arf;
+ --d_work_dlange__;
+ --d_work_dgeqrf__;
+ --tau;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ nrun = 0;
+ nfail = 0;
+ info = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = dlamch_("Precision");
+
+ i__1 = *nn;
+ for (iim = 1; iim <= i__1; ++iim) {
+
+ m = nval[iim];
+
+ i__2 = *nn;
+ for (iin = 1; iin <= i__2; ++iin) {
+
+ n = nval[iin];
+
+ for (iform = 1; iform <= 2; ++iform) {
+
+ *(unsigned char *)cform = *(unsigned char *)&forms[iform - 1];
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+
+ for (iside = 1; iside <= 2; ++iside) {
+
+ *(unsigned char *)side = *(unsigned char *)&sides[
+ iside - 1];
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itrans - 1];
+
+ for (idiag = 1; idiag <= 2; ++idiag) {
+
+ *(unsigned char *)diag = *(unsigned char *)&
+ diags[idiag - 1];
+
+ for (ialpha = 1; ialpha <= 3; ++ialpha) {
+
+ if (ialpha == 1) {
+ alpha = 0.;
+ } else if (ialpha == 1) {
+ alpha = 1.;
+ } else {
+ alpha = dlarnd_(&c__2, iseed);
+ }
+
+/* All the parameters are set: */
+/* CFORM, SIDE, UPLO, TRANS, DIAG, M, N, */
+/* and ALPHA */
+/* READY TO TEST! */
+
+ ++nrun;
+
+ if (iside == 1) {
+
+/* The case ISIDE.EQ.1 is when SIDE.EQ.'L' */
+/* -> A is M-by-M ( B is M-by-N ) */
+
+ na = m;
+
+ } else {
+
+/* The case ISIDE.EQ.2 is when SIDE.EQ.'R' */
+/* -> A is N-by-N ( B is M-by-N ) */
+
+ na = n;
+
+ }
+
+/* Generate A our NA--by--NA triangular */
+/* matrix. */
+/* Our test is based on forward error so we */
+/* do want A to be well conditionned! To get */
+/* a well-conditionned triangular matrix, we */
+/* take the R factor of the QR/LQ factorization */
+/* of a random matrix. */
+
+ i__3 = na;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = na;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ a[i__ + j * a_dim1] = dlarnd_(&
+ c__2, iseed);
+ }
+ }
+
+ if (iuplo == 1) {
+
+/* The case IUPLO.EQ.1 is when SIDE.EQ.'U' */
+/* -> QR factorization. */
+
+ s_copy(srnamc_1.srnamt, "DGEQRF", (
+ ftnlen)32, (ftnlen)6);
+ dgeqrf_(&na, &na, &a[a_offset], lda, &
+ tau[1], &d_work_dgeqrf__[1],
+ lda, &info);
+ } else {
+
+/* The case IUPLO.EQ.2 is when SIDE.EQ.'L' */
+/* -> QL factorization. */
+
+ s_copy(srnamc_1.srnamt, "DGELQF", (
+ ftnlen)32, (ftnlen)6);
+ dgelqf_(&na, &na, &a[a_offset], lda, &
+ tau[1], &d_work_dgeqrf__[1],
+ lda, &info);
+ }
+
+/* Store a copy of A in RFP format (in ARF). */
+
+ s_copy(srnamc_1.srnamt, "DTRTTF", (ftnlen)
+ 32, (ftnlen)6);
+ dtrttf_(cform, uplo, &na, &a[a_offset],
+ lda, &arf[1], &info);
+
+/* Generate B1 our M--by--N right-hand side */
+/* and store a copy in B2. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = m;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ b1[i__ + j * b1_dim1] = dlarnd_(&
+ c__2, iseed);
+ b2[i__ + j * b2_dim1] = b1[i__ +
+ j * b1_dim1];
+ }
+ }
+
+/* Solve op( A ) X = B or X op( A ) = B */
+/* with DTRSM */
+
+ s_copy(srnamc_1.srnamt, "DTRSM", (ftnlen)
+ 32, (ftnlen)5);
+ dtrsm_(side, uplo, trans, diag, &m, &n, &
+ alpha, &a[a_offset], lda, &b1[
+ b1_offset], lda);
+
+/* Solve op( A ) X = B or X op( A ) = B */
+/* with DTFSM */
+
+ s_copy(srnamc_1.srnamt, "DTFSM", (ftnlen)
+ 32, (ftnlen)5);
+ dtfsm_(cform, side, uplo, trans, diag, &m,
+ &n, &alpha, &arf[1], &b2[
+ b2_offset], lda);
+
+/* Check that the result agrees. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = m;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ b1[i__ + j * b1_dim1] = b2[i__ +
+ j * b2_dim1] - b1[i__ + j
+ * b1_dim1];
+ }
+ }
+
+ result[0] = dlange_("I", &m, &n, &b1[
+ b1_offset], lda, &d_work_dlange__[
+ 1]);
+
+/* Computing MAX */
+ i__3 = max(m,n);
+ result[0] = result[0] / sqrt(eps) / max(
+ i__3,1);
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0) {
+ io___32.ciunit = *nout;
+ s_wsle(&io___32);
+ e_wsle();
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ e_wsfe();
+ }
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "DTFSM", (ftnlen)5);
+ do_fio(&c__1, cform, (ftnlen)1);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+
+/* L100: */
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+
+/* Print a summary of the results. */
+
+ if (nfail == 0) {
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, "DTFSM", (ftnlen)5);
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, "DTFSM", (ftnlen)5);
+ do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of DDRVRF3 */
+
+} /* ddrvrf3_ */
diff --git a/TESTING/LIN/ddrvrf4.c b/TESTING/LIN/ddrvrf4.c
new file mode 100644
index 0000000..b7fd5ac
--- /dev/null
+++ b/TESTING/LIN/ddrvrf4.c
@@ -0,0 +1,416 @@
+/* ddrvrf4.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* Subroutine */ int ddrvrf4_(integer *nout, integer *nn, integer *nval,
+ doublereal *thresh, doublereal *c1, doublereal *c2, integer *ldc,
+ doublereal *crf, doublereal *a, integer *lda, doublereal *
+ d_work_dlange__)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char forms[1*2] = "N" "T";
+ static char transs[1*2] = "N" "T";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002 *** Error(s) or Failure(s) while test"
+ "ing DSFRK ***\002)";
+ static char fmt_9997[] = "(1x,\002 Failure in \002,a5,\002, CFORM="
+ "'\002,a1,\002',\002,\002 UPLO='\002,a1,\002',\002,\002 TRANS="
+ "'\002,a1,\002',\002,\002 N=\002,i3,\002, K =\002,i3,\002, test"
+ "=\002,g12.5)";
+ static char fmt_9996[] = "(1x,\002All tests for \002,a5,\002 auxiliary r"
+ "outine passed the \002,\002threshold (\002,i5,\002 tests run)"
+ "\002)";
+ static char fmt_9995[] = "(1x,a6,\002 auxiliary routine:\002,i5,\002 out"
+ " of \002,i5,\002 tests failed to pass the threshold\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, c1_dim1, c1_offset, c2_dim1, c2_offset, i__1,
+ i__2, i__3, i__4;
+ doublereal d__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void),
+ do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k, n, iik, iin;
+ doublereal eps, beta;
+ integer info;
+ char uplo[1];
+ integer nrun;
+ doublereal alpha;
+ integer nfail, iseed[4];
+ char cform[1];
+ extern /* Subroutine */ int dsfrk_(char *, char *, char *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *);
+ integer iform;
+ doublereal norma, normc;
+ char trans[1];
+ integer iuplo;
+ extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ integer ialpha;
+ extern doublereal dlarnd_(integer *, integer *);
+ integer itrans;
+ extern /* Subroutine */ int dtfttr_(char *, char *, integer *, doublereal
+ *, doublereal *, integer *, integer *), dtrttf_(
+ char *, char *, integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal result[1];
+
+ /* Fortran I/O blocks */
+ static cilist io___28 = { 0, 0, 0, 0, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVRF4 tests the LAPACK RFP routines: */
+/* DSFRK */
+
+/* Arguments */
+/* ========= */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* THRESH (input) 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. */
+
+/* C1 (workspace) DOUBLE PRECISION array, */
+/* dimension (LDC,NMAX) */
+
+/* C2 (workspace) DOUBLE PRECISION array, */
+/* dimension (LDC,NMAX) */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array A. */
+/* LDA >= max(1,NMAX). */
+
+/* CRF (workspace) DOUBLE PRECISION array, */
+/* dimension ((NMAX*(NMAX+1))/2). */
+
+/* A (workspace) DOUBLE PRECISION array, */
+/* dimension (LDA,NMAX) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,NMAX). */
+
+/* D_WORK_DLANGE (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* ===================================================================== */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nval;
+ c2_dim1 = *ldc;
+ c2_offset = 1 + c2_dim1;
+ c2 -= c2_offset;
+ c1_dim1 = *ldc;
+ c1_offset = 1 + c1_dim1;
+ c1 -= c1_offset;
+ --crf;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d_work_dlange__;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ nrun = 0;
+ nfail = 0;
+ info = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = dlamch_("Precision");
+
+ i__1 = *nn;
+ for (iin = 1; iin <= i__1; ++iin) {
+
+ n = nval[iin];
+
+ i__2 = *nn;
+ for (iik = 1; iik <= i__2; ++iik) {
+
+ k = nval[iin];
+
+ for (iform = 1; iform <= 2; ++iform) {
+
+ *(unsigned char *)cform = *(unsigned char *)&forms[iform - 1];
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[
+ itrans - 1];
+
+ for (ialpha = 1; ialpha <= 4; ++ialpha) {
+
+ if (ialpha == 1) {
+ alpha = 0.;
+ beta = 0.;
+ } else if (ialpha == 2) {
+ alpha = 1.;
+ beta = 0.;
+ } else if (ialpha == 3) {
+ alpha = 0.;
+ beta = 1.;
+ } else {
+ alpha = dlarnd_(&c__2, iseed);
+ beta = dlarnd_(&c__2, iseed);
+ }
+
+/* All the parameters are set: */
+/* CFORM, UPLO, TRANS, M, N, */
+/* ALPHA, and BETA */
+/* READY TO TEST! */
+
+ ++nrun;
+
+ if (itrans == 1) {
+
+/* In this case we are NOTRANS, so A is N-by-K */
+
+ i__3 = k;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ a[i__ + j * a_dim1] = dlarnd_(&c__2,
+ iseed);
+ }
+ }
+
+ norma = dlange_("I", &n, &k, &a[a_offset],
+ lda, &d_work_dlange__[1]);
+
+ } else {
+
+/* In this case we are TRANS, so A is K-by-N */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = k;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ a[i__ + j * a_dim1] = dlarnd_(&c__2,
+ iseed);
+ }
+ }
+
+ norma = dlange_("I", &k, &n, &a[a_offset],
+ lda, &d_work_dlange__[1]);
+
+ }
+
+/* Generate C1 our N--by--N symmetric matrix. */
+/* Make sure C2 has the same upper/lower part, */
+/* (the one that we do not touch), so */
+/* copy the initial C1 in C2 in it. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ c1[i__ + j * c1_dim1] = dlarnd_(&c__2,
+ iseed);
+ c2[i__ + j * c2_dim1] = c1[i__ + j *
+ c1_dim1];
+ }
+ }
+
+/* (See comment later on for why we use DLANGE and */
+/* not DLANSY for C1.) */
+
+ normc = dlange_("I", &n, &n, &c1[c1_offset], ldc,
+ &d_work_dlange__[1]);
+
+ s_copy(srnamc_1.srnamt, "DTRTTF", (ftnlen)32, (
+ ftnlen)6);
+ dtrttf_(cform, uplo, &n, &c1[c1_offset], ldc, &
+ crf[1], &info);
+
+/* call dsyrk the BLAS routine -> gives C1 */
+
+ s_copy(srnamc_1.srnamt, "DSYRK ", (ftnlen)32, (
+ ftnlen)6);
+ dsyrk_(uplo, trans, &n, &k, &alpha, &a[a_offset],
+ lda, &beta, &c1[c1_offset], ldc);
+
+/* call dsfrk the RFP routine -> gives CRF */
+
+ s_copy(srnamc_1.srnamt, "DSFRK ", (ftnlen)32, (
+ ftnlen)6);
+ dsfrk_(cform, uplo, trans, &n, &k, &alpha, &a[
+ a_offset], lda, &beta, &crf[1]);
+
+/* convert CRF in full format -> gives C2 */
+
+ s_copy(srnamc_1.srnamt, "DTFTTR", (ftnlen)32, (
+ ftnlen)6);
+ dtfttr_(cform, uplo, &n, &crf[1], &c2[c2_offset],
+ ldc, &info);
+
+/* compare C1 and C2 */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ c1[i__ + j * c1_dim1] -= c2[i__ + j *
+ c2_dim1];
+ }
+ }
+
+/* Yes, C1 is symmetric so we could call DLANSY, */
+/* but we want to check the upper part that is */
+/* supposed to be unchanged and the diagonal that */
+/* is supposed to be real -> DLANGE */
+
+ result[0] = dlange_("I", &n, &n, &c1[c1_offset],
+ ldc, &d_work_dlange__[1]);
+/* Computing MAX */
+ d__1 = abs(alpha) * norma + abs(beta);
+ result[0] = result[0] / max(d__1,1.) / max(n,1) /
+ eps;
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0) {
+ io___28.ciunit = *nout;
+ s_wsle(&io___28);
+ e_wsle();
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ e_wsfe();
+ }
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, "DSFRK", (ftnlen)5);
+ do_fio(&c__1, cform, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+
+/* L100: */
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+/* Print a summary of the results. */
+
+ if (nfail == 0) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, "DSFRK", (ftnlen)5);
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "DSFRK", (ftnlen)5);
+ do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of DDRVRF4 */
+
+} /* ddrvrf4_ */
diff --git a/TESTING/LIN/ddrvrfp.c b/TESTING/LIN/ddrvrfp.c
new file mode 100644
index 0000000..d592c14
--- /dev/null
+++ b/TESTING/LIN/ddrvrfp.c
@@ -0,0 +1,590 @@
+/* ddrvrfp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+
+/* Subroutine */ int ddrvrfp_(integer *nout, integer *nn, integer *nval,
+ integer *nns, integer *nsval, integer *nnt, integer *ntval,
+ doublereal *thresh, doublereal *a, doublereal *asav, doublereal *afac,
+ doublereal *ainv, doublereal *b, doublereal *bsav, doublereal *xact,
+ doublereal *x, doublereal *arf, doublereal *arfinv, doublereal *
+ d_work_dlatms__, doublereal *d_work_dpot01__, doublereal *
+ d_temp_dpot02__, doublereal *d_temp_dpot03__, doublereal *
+ d_work_dlansy__, doublereal *d_work_dpot02__, doublereal *
+ d_work_dpot03__)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char forms[1*2] = "N" "T";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a6,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, kl, ku, nt, lda, ldb, iin, iis, iit, ioff, mode, info,
+ imat;
+ char dist[1];
+ integer nrhs;
+ char uplo[1];
+ integer nrun;
+ extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *);
+ integer nfail, iseed[4];
+ char cform[1];
+ extern /* Subroutine */ int dpot01_(char *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *), dpot02_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *), dpot03_(char *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *);
+ integer iform;
+ doublereal anorm;
+ char ctype[1];
+ integer iuplo, nerrs, izero;
+ logical zerot;
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), aladhd_(integer *,
+ char *), alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ doublereal rcondc;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *), alasvm_(char *,
+ integer *, integer *, integer *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublereal *, integer *, doublereal
+ *, integer *), dpftrf_(char *, char *,
+ integer *, doublereal *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int dpftri_(char *, char *, integer *, doublereal
+ *, integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dpotrf_(char *, integer *, doublereal *,
+ integer *, integer *), dpotri_(char *, integer *,
+ doublereal *, integer *, integer *), dpftrs_(char *, char
+ *, integer *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dtfttr_(char *, char *, integer *,
+ doublereal *, doublereal *, integer *, integer *),
+ dtrttf_(char *, char *, integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ doublereal result[4];
+
+ /* Fortran I/O blocks */
+ static cilist io___37 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVRFP tests the LAPACK RFP routines: */
+/* DPFTRF, DPFTRS, and DPFTRI. */
+
+/* This testing routine follow the same tests as DDRVPO (test for the full */
+/* format Symmetric Positive Definite solver). */
+
+/* The tests are performed in Full Format, convertion back and forth from */
+/* full format to RFP format are performed using the routines DTRTTF and */
+/* DTFTTR. */
+
+/* First, a specific matrix A of size N is created. There is nine types of */
+/* different matrixes possible. */
+/* 1. Diagonal 6. Random, CNDNUM = sqrt(0.1/EPS) */
+/* 2. Random, CNDNUM = 2 7. Random, CNDNUM = 0.1/EPS */
+/* *3. First row and column zero 8. Scaled near underflow */
+/* *4. Last row and column zero 9. Scaled near overflow */
+/* *5. Middle row and column zero */
+/* (* - tests error exits from DPFTRF, no test ratios are computed) */
+/* A solution XACT of size N-by-NRHS is created and the associated right */
+/* hand side B as well. Then DPFTRF is called to compute L (or U), the */
+/* Cholesky factor of A. Then L (or U) is used to solve the linear system */
+/* of equations AX = B. This gives X. Then L (or U) is used to compute the */
+/* inverse of A, AINV. The following four tests are then performed: */
+/* (1) norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
+/* norm( U'*U - A ) / ( N * norm(A) * EPS ), */
+/* (2) norm(B - A*X) / ( norm(A) * norm(X) * EPS ), */
+/* (3) norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* (4) ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ), */
+/* where EPS is the machine precision, RCOND the condition number of A, and */
+/* norm( . ) the 1-norm for (1,2,3) and the inf-norm for (4). */
+/* Errors occur when INFO parameter is not as expected. Failures occur when */
+/* a test ratios is greater than THRES. */
+
+/* Arguments */
+/* ========= */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right-hand sides NRHS. */
+
+/* NNT (input) INTEGER */
+/* The number of values of MATRIX TYPE contained in the vector NTVAL. */
+
+/* NTVAL (input) INTEGER array, dimension (NNT) */
+/* The values of matrix type (between 0 and 9 for PO/PP/PF matrices). */
+
+/* THRESH (input) 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. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*MAXRHS) */
+
+/* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*MAXRHS) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*MAXRHS) */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*MAXRHS) */
+
+/* ARF (workspace) DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2) */
+
+/* ARFINV (workspace) DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2) */
+
+/* D_WORK_DLATMS (workspace) DOUBLE PRECISION array, dimension ( 3*NMAX ) */
+
+/* D_WORK_DPOT01 (workspace) DOUBLE PRECISION array, dimension ( NMAX ) */
+
+/* D_TEMP_DPOT02 (workspace) DOUBLE PRECISION array, dimension ( NMAX*MAXRHS ) */
+
+/* D_TEMP_DPOT03 (workspace) DOUBLE PRECISION array, dimension ( NMAX*NMAX ) */
+
+/* D_WORK_DLATMS (workspace) DOUBLE PRECISION array, dimension ( NMAX ) */
+
+/* D_WORK_DLANSY (workspace) DOUBLE PRECISION array, dimension ( NMAX ) */
+
+/* D_WORK_DPOT02 (workspace) DOUBLE PRECISION array, dimension ( NMAX ) */
+
+/* D_WORK_DPOT03 (workspace) DOUBLE PRECISION array, dimension ( NMAX ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nval;
+ --nsval;
+ --ntval;
+ --a;
+ --asav;
+ --afac;
+ --ainv;
+ --b;
+ --bsav;
+ --xact;
+ --x;
+ --arf;
+ --arfinv;
+ --d_work_dlatms__;
+ --d_work_dpot01__;
+ --d_temp_dpot02__;
+ --d_temp_dpot03__;
+ --d_work_dlansy__;
+ --d_work_dpot02__;
+ --d_work_dpot03__;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+ i__1 = *nn;
+ for (iin = 1; iin <= i__1; ++iin) {
+
+ n = nval[iin];
+ lda = max(n,1);
+ ldb = max(n,1);
+
+ i__2 = *nns;
+ for (iis = 1; iis <= i__2; ++iis) {
+
+ nrhs = nsval[iis];
+
+ i__3 = *nnt;
+ for (iit = 1; iit <= i__3; ++iit) {
+
+ imat = ntval[iit];
+
+/* If N.EQ.0, only consider the first type */
+
+ if (n == 0 && iit > 1) {
+ goto L120;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ if (imat == 4 && n <= 1) {
+ goto L120;
+ }
+ if (imat == 5 && n <= 2) {
+ goto L120;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+
+/* Do first for CFORM = 'N', then for CFORM = 'C' */
+
+ for (iform = 1; iform <= 2; ++iform) {
+ *(unsigned char *)cform = *(unsigned char *)&forms[
+ iform - 1];
+
+/* Set up parameters with DLATB4 and generate a test */
+/* matrix with DLATMS. */
+
+ dlatb4_("DPO", &imat, &n, &n, ctype, &kl, &ku, &anorm,
+ &mode, &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)
+ 6);
+ dlatms_(&n, &n, dist, iseed, ctype, &d_work_dlatms__[
+ 1], &mode, &cndnum, &anorm, &kl, &ku, uplo, &
+ a[1], &lda, &d_work_dlatms__[1], &info);
+
+/* Check error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_("DPF", "DLATMS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &c_n1, &iit, &nfail, &
+ nerrs, nout);
+ goto L100;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot) {
+ if (iit == 3) {
+ izero = 1;
+ } else if (iit == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ i__4 = izero - 1;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ a[ioff + i__] = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__4 = n;
+ for (i__ = izero; i__ <= i__4; ++i__) {
+ a[ioff] = 0.;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__4 = izero - 1;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ a[ioff] = 0.;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__4 = n;
+ for (i__ = izero; i__ <= i__4; ++i__) {
+ a[ioff + i__] = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ dlacpy_(uplo, &n, &n, &a[1], &lda, &asav[1], &lda);
+
+/* Compute the condition number of A (RCONDC). */
+
+ if (zerot) {
+ rcondc = 0.;
+ } else {
+
+/* Compute the 1-norm of A. */
+
+ anorm = dlansy_("1", uplo, &n, &a[1], &lda, &
+ d_work_dlansy__[1]);
+
+/* Factor the matrix A. */
+
+ dpotrf_(uplo, &n, &a[1], &lda, &info);
+
+/* Form the inverse of A. */
+
+ dpotri_(uplo, &n, &a[1], &lda, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = dlansy_("1", uplo, &n, &a[1], &lda, &
+ d_work_dlansy__[1]);
+ rcondc = 1. / anorm / ainvnm;
+
+/* Restore the matrix A. */
+
+ dlacpy_(uplo, &n, &n, &asav[1], &lda, &a[1], &lda);
+
+ }
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ dlarhs_("DPO", "N", uplo, " ", &n, &n, &kl, &ku, &
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ dlacpy_("Full", &n, &nrhs, &b[1], &lda, &bsav[1], &
+ lda);
+
+/* Compute the L*L' or U'*U factorization of the */
+/* matrix and solve the system. */
+
+ dlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ dlacpy_("Full", &n, &nrhs, &b[1], &ldb, &x[1], &ldb);
+
+ s_copy(srnamc_1.srnamt, "DTRTTF", (ftnlen)32, (ftnlen)
+ 6);
+ dtrttf_(cform, uplo, &n, &afac[1], &lda, &arf[1], &
+ info);
+ s_copy(srnamc_1.srnamt, "DPFTRF", (ftnlen)32, (ftnlen)
+ 6);
+ dpftrf_(cform, uplo, &n, &arf[1], &info);
+
+/* Check error code from DPFTRF. */
+
+ if (info != izero) {
+
+/* LANGOU: there is a small hick here: IZERO should */
+/* always be INFO however if INFO is ZERO, ALAERH does not */
+/* complain. */
+
+ alaerh_("DPF", "DPFSV ", &info, &izero, uplo, &n,
+ &n, &c_n1, &c_n1, &nrhs, &iit, &nfail, &
+ nerrs, nout);
+ goto L100;
+ }
+
+/* Skip the tests if INFO is not 0. */
+
+ if (info != 0) {
+ goto L100;
+ }
+
+ s_copy(srnamc_1.srnamt, "DPFTRS", (ftnlen)32, (ftnlen)
+ 6);
+ dpftrs_(cform, uplo, &n, &nrhs, &arf[1], &x[1], &ldb,
+ &info);
+
+ s_copy(srnamc_1.srnamt, "DTFTTR", (ftnlen)32, (ftnlen)
+ 6);
+ dtfttr_(cform, uplo, &n, &arf[1], &afac[1], &lda, &
+ info);
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ dlacpy_(uplo, &n, &n, &afac[1], &lda, &asav[1], &lda);
+ dpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
+ d_work_dpot01__[1], result);
+ dlacpy_(uplo, &n, &n, &asav[1], &lda, &afac[1], &lda);
+
+/* Form the inverse and compute the residual. */
+
+ if (n % 2 == 0) {
+ i__4 = n + 1;
+ i__5 = n / 2;
+ i__6 = n + 1;
+ i__7 = n + 1;
+ dlacpy_("A", &i__4, &i__5, &arf[1], &i__6, &
+ arfinv[1], &i__7);
+ } else {
+ i__4 = (n + 1) / 2;
+ dlacpy_("A", &n, &i__4, &arf[1], &n, &arfinv[1], &
+ n);
+ }
+
+ s_copy(srnamc_1.srnamt, "DPFTRI", (ftnlen)32, (ftnlen)
+ 6);
+ dpftri_(cform, uplo, &n, &arfinv[1], &info);
+
+ s_copy(srnamc_1.srnamt, "DTFTTR", (ftnlen)32, (ftnlen)
+ 6);
+ dtfttr_(cform, uplo, &n, &arfinv[1], &ainv[1], &lda, &
+ info);
+
+/* Check error code from DPFTRI. */
+
+ if (info != 0) {
+ alaerh_("DPO", "DPFTRI", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ dpot03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &
+ d_temp_dpot03__[1], &lda, &d_work_dpot03__[1],
+ &rcondc, &result[1]);
+
+/* Compute residual of the computed solution. */
+
+ dlacpy_("Full", &n, &nrhs, &b[1], &lda, &
+ d_temp_dpot02__[1], &lda);
+ dpot02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
+ d_temp_dpot02__[1], &lda, &d_work_dpot02__[1],
+ &result[2]);
+
+/* Check solution from generated exact solution. */
+ dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+ nt = 4;
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, "DPF");
+ }
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, "DPFSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iit, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += nt;
+L100:
+ ;
+ }
+/* L110: */
+ }
+L120:
+ ;
+ }
+/* L980: */
+ }
+/* L130: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_("DPF", nout, &nfail, &nrun, &nerrs);
+
+
+ return 0;
+
+/* End of DDRVRFP */
+
+} /* ddrvrfp_ */
diff --git a/TESTING/LIN/ddrvsp.c b/TESTING/LIN/ddrvsp.c
new file mode 100644
index 0000000..e8bd67d
--- /dev/null
+++ b/TESTING/LIN/ddrvsp.c
@@ -0,0 +1,680 @@
+/* ddrvsp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static doublereal c_b59 = 0.;
+static integer c__2 = 2;
+
+/* Subroutine */ int ddrvsp_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
+ doublereal *a, doublereal *afac, doublereal *ainv, doublereal *b,
+ doublereal *x, doublereal *xact, doublereal *work, doublereal *rwork,
+ integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char facts[1*2] = "F" "N";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002,"
+ " ratio =\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, k1, in, kl, ku, nt, lda, npp;
+ char fact[1];
+ integer ioff, mode, imat, info;
+ char path[3], dist[1], uplo[1], type__[1];
+ integer nrun, ifact;
+ extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ doublereal rcond;
+ integer nimat;
+ extern /* Subroutine */ int dppt02_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *), dspt01_(char *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *);
+ doublereal anorm;
+ extern /* Subroutine */ int dppt05_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *), dcopy_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer iuplo, izero, nerrs, lwork;
+ extern /* Subroutine */ int dspsv_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), aladhd_(integer *,
+ char *), alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ doublereal rcondc;
+ char packit[1];
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *), dlaset_(char *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *);
+ extern doublereal dlansp_(char *, char *, integer *, doublereal *,
+ doublereal *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublereal *, integer *, doublereal
+ *, integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int dsptrf_(char *, integer *, doublereal *,
+ integer *, integer *), dsptri_(char *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ derrvx_(char *, integer *);
+ doublereal result[6];
+ extern /* Subroutine */ int dspsvx_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVSP tests the driver routines DSPSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AFAC (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AINV (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(2,NRHS)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "SP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+/* Computing MAX */
+ i__1 = *nmax << 1, i__2 = *nmax * *nrhs;
+ lwork = max(i__1,i__2);
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ npp = n * (n + 1) / 2;
+ *(unsigned char *)xtype = 'N';
+ nimat = 10;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L170;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L170;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ if (iuplo == 1) {
+ *(unsigned char *)uplo = 'U';
+ *(unsigned char *)packit = 'C';
+ } else {
+ *(unsigned char *)uplo = 'L';
+ *(unsigned char *)packit = 'R';
+ }
+
+/* Set up parameters with DLATB4 and generate a test matrix */
+/* with DLATMS. */
+
+ dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
+ 1], &info);
+
+/* Check error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L160;
+ }
+
+/* For types 3-6, zero one or more rows and columns of the */
+/* matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * izero / 2;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff] = 0.;
+ ioff += i__;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff] = 0.;
+ ioff = ioff + n - i__;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ ioff = 0;
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ a[ioff + i__] = 0.;
+/* L60: */
+ }
+ ioff += j;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ a[ioff + i__] = 0.;
+/* L80: */
+ }
+ ioff = ioff + n - j;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+ for (ifact = 1; ifact <= 2; ++ifact) {
+
+/* Do first for FACT = 'F', then for other values. */
+
+ *(unsigned char *)fact = *(unsigned char *)&facts[ifact -
+ 1];
+
+/* Compute the condition number for comparison with */
+/* the value returned by DSPSVX. */
+
+ if (zerot) {
+ if (ifact == 1) {
+ goto L150;
+ }
+ rcondc = 0.;
+
+ } else if (ifact == 1) {
+
+/* Compute the 1-norm of A. */
+
+ anorm = dlansp_("1", uplo, &n, &a[1], &rwork[1]);
+
+/* Factor the matrix A. */
+
+ dcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ dsptrf_(uplo, &n, &afac[1], &iwork[1], &info);
+
+/* Compute inv(A) and take its norm. */
+
+ dcopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
+ dsptri_(uplo, &n, &ainv[1], &iwork[1], &work[1], &
+ info);
+ ainvnm = dlansp_("1", uplo, &n, &ainv[1], &rwork[1]);
+
+/* Compute the 1-norm condition number of A. */
+
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondc = 1.;
+ } else {
+ rcondc = 1. / anorm / ainvnm;
+ }
+ }
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)6);
+ dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, nrhs, &
+ a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
+ info);
+ *(unsigned char *)xtype = 'C';
+
+/* --- Test DSPSV --- */
+
+ if (ifact == 2) {
+ dcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
+
+/* Factor the matrix and solve the system using DSPSV. */
+
+ s_copy(srnamc_1.srnamt, "DSPSV ", (ftnlen)32, (ftnlen)
+ 6);
+ dspsv_(uplo, &n, nrhs, &afac[1], &iwork[1], &x[1], &
+ lda, &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from DSPSV . */
+
+ if (info != k) {
+ alaerh_(path, "DSPSV ", &info, &k, uplo, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L120;
+ } else if (info != 0) {
+ goto L120;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ dspt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &ainv[1]
+, &lda, &rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ dppt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[1],
+ &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "DSPSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+L120:
+ ;
+ }
+
+/* --- Test DSPSVX --- */
+
+ if (ifact == 2 && npp > 0) {
+ dlaset_("Full", &npp, &c__1, &c_b59, &c_b59, &afac[1],
+ &npp);
+ }
+ dlaset_("Full", &n, nrhs, &c_b59, &c_b59, &x[1], &lda);
+
+/* Solve the system and compute the condition number and */
+/* error bounds using DSPSVX. */
+
+ s_copy(srnamc_1.srnamt, "DSPSVX", (ftnlen)32, (ftnlen)6);
+ dspsvx_(fact, uplo, &n, nrhs, &a[1], &afac[1], &iwork[1],
+ &b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &
+ rwork[*nrhs + 1], &work[1], &iwork[n + 1], &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L130:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L130;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L130;
+ }
+ }
+
+/* Check the error code from DSPSVX. */
+
+ if (info != k) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "DSPSVX", &info, &k, ch__1, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L150;
+ }
+
+ if (info == 0) {
+ if (ifact >= 2) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ dspt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &
+ ainv[1], &lda, &rwork[(*nrhs << 1) + 1],
+ result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ dppt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[1],
+ &lda, &rwork[(*nrhs << 1) + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* Check the error bounds from iterative refinement. */
+
+ dppt05_(uplo, &n, nrhs, &a[1], &b[1], &lda, &x[1], &
+ lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs
+ + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from DSPSVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "DSPSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L140: */
+ }
+ nrun = nrun + 7 - k1;
+
+L150:
+ ;
+ }
+
+L160:
+ ;
+ }
+L170:
+ ;
+ }
+/* L180: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DDRVSP */
+
+} /* ddrvsp_ */
diff --git a/TESTING/LIN/ddrvsy.c b/TESTING/LIN/ddrvsy.c
new file mode 100644
index 0000000..49f16b2
--- /dev/null
+++ b/TESTING/LIN/ddrvsy.c
@@ -0,0 +1,682 @@
+/* ddrvsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublereal c_b49 = 0.;
+
+/* Subroutine */ int ddrvsy_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
+ doublereal *a, doublereal *afac, doublereal *ainv, doublereal *b,
+ doublereal *x, doublereal *xact, doublereal *work, doublereal *rwork,
+ integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char facts[1*2] = "F" "N";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002,"
+ " ratio =\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, k1, nb, in, kl, ku, nt, lda;
+ char fact[1];
+ integer ioff, mode, imat, info;
+ char path[3], dist[1], uplo[1], type__[1];
+ integer nrun, ifact;
+ extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ integer nbmin;
+ doublereal rcond;
+ integer nimat;
+ extern /* Subroutine */ int dpot02_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *), dpot05_(char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *);
+ doublereal anorm;
+ extern /* Subroutine */ int dsyt01_(char *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *);
+ integer iuplo, izero, nerrs, lwork;
+ logical zerot;
+ extern /* Subroutine */ int dsysv_(char *, integer *, integer *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, integer *);
+ char xtype[1];
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), aladhd_(integer *,
+ char *), alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ doublereal rcondc;
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ integer *), dlaset_(char *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *), alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublereal *, integer *, doublereal
+ *, integer *);
+ doublereal ainvnm;
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), derrvx_(char *,
+ integer *), dsytrf_(char *, integer *, doublereal *,
+ integer *, integer *, doublereal *, integer *, integer *);
+ doublereal result[6];
+ extern /* Subroutine */ int dsytri_(char *, integer *, doublereal *,
+ integer *, integer *, doublereal *, integer *), dsysvx_(
+ char *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DDRVSY tests the driver routines DSYSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(2,NRHS)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "SY", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+/* Computing MAX */
+ i__1 = *nmax << 1, i__2 = *nmax * *nrhs;
+ lwork = max(i__1,i__2);
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ derrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 10;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L170;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L170;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Set up parameters with DLATB4 and generate a test matrix */
+/* with DLATMS. */
+
+ dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
+ dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
+ &info);
+
+/* Check error code from DLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L160;
+ }
+
+/* For types 3-6, zero one or more rows and columns of the */
+/* matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * lda;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff] = 0.;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff] = 0.;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ ioff = 0;
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ a[ioff + i__] = 0.;
+/* L60: */
+ }
+ ioff += lda;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ a[ioff + i__] = 0.;
+/* L80: */
+ }
+ ioff += lda;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+ for (ifact = 1; ifact <= 2; ++ifact) {
+
+/* Do first for FACT = 'F', then for other values. */
+
+ *(unsigned char *)fact = *(unsigned char *)&facts[ifact -
+ 1];
+
+/* Compute the condition number for comparison with */
+/* the value returned by DSYSVX. */
+
+ if (zerot) {
+ if (ifact == 1) {
+ goto L150;
+ }
+ rcondc = 0.;
+
+ } else if (ifact == 1) {
+
+/* Compute the 1-norm of A. */
+
+ anorm = dlansy_("1", uplo, &n, &a[1], &lda, &rwork[1]);
+
+/* Factor the matrix A. */
+
+ dlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ dsytrf_(uplo, &n, &afac[1], &lda, &iwork[1], &work[1],
+ &lwork, &info);
+
+/* Compute inv(A) and take its norm. */
+
+ dlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
+ dsytri_(uplo, &n, &ainv[1], &lda, &iwork[1], &work[1],
+ &info);
+ ainvnm = dlansy_("1", uplo, &n, &ainv[1], &lda, &
+ rwork[1]);
+
+/* Compute the 1-norm condition number of A. */
+
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondc = 1.;
+ } else {
+ rcondc = 1. / anorm / ainvnm;
+ }
+ }
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)6);
+ dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, nrhs, &
+ a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
+ info);
+ *(unsigned char *)xtype = 'C';
+
+/* --- Test DSYSV --- */
+
+ if (ifact == 2) {
+ dlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
+
+/* Factor the matrix and solve the system using DSYSV. */
+
+ s_copy(srnamc_1.srnamt, "DSYSV ", (ftnlen)32, (ftnlen)
+ 6);
+ dsysv_(uplo, &n, nrhs, &afac[1], &lda, &iwork[1], &x[
+ 1], &lda, &work[1], &lwork, &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from DSYSV . */
+
+ if (info != k) {
+ alaerh_(path, "DSYSV ", &info, &k, uplo, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L120;
+ } else if (info != 0) {
+ goto L120;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ dsyt01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &iwork[
+ 1], &ainv[1], &lda, &rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ dpot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda, &
+ work[1], &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "DSYSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+L120:
+ ;
+ }
+
+/* --- Test DSYSVX --- */
+
+ if (ifact == 2) {
+ dlaset_(uplo, &n, &n, &c_b49, &c_b49, &afac[1], &lda);
+ }
+ dlaset_("Full", &n, nrhs, &c_b49, &c_b49, &x[1], &lda);
+
+/* Solve the system and compute the condition number and */
+/* error bounds using DSYSVX. */
+
+ s_copy(srnamc_1.srnamt, "DSYSVX", (ftnlen)32, (ftnlen)6);
+ dsysvx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1], &lda,
+ &iwork[1], &b[1], &lda, &x[1], &lda, &rcond, &
+ rwork[1], &rwork[*nrhs + 1], &work[1], &lwork, &
+ iwork[n + 1], &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L130:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L130;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L130;
+ }
+ }
+
+/* Check the error code from DSYSVX. */
+
+ if (info != k) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "DSYSVX", &info, &k, ch__1, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L150;
+ }
+
+ if (info == 0) {
+ if (ifact >= 2) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ dsyt01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &ainv[1], &lda, &rwork[(*nrhs <<
+ 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ dpot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda, &
+ work[1], &lda, &rwork[(*nrhs << 1) + 1], &
+ result[1]);
+
+/* Check solution from generated exact solution. */
+
+ dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* Check the error bounds from iterative refinement. */
+
+ dpot05_(uplo, &n, nrhs, &a[1], &lda, &b[1], &lda, &x[
+ 1], &lda, &xact[1], &lda, &rwork[1], &rwork[*
+ nrhs + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from DSYSVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "DSYSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L140: */
+ }
+ nrun = nrun + 7 - k1;
+
+L150:
+ ;
+ }
+
+L160:
+ ;
+ }
+L170:
+ ;
+ }
+/* L180: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of DDRVSY */
+
+} /* ddrvsy_ */
diff --git a/TESTING/LIN/debchvxx.c b/TESTING/LIN/debchvxx.c
new file mode 100644
index 0000000..c389e00
--- /dev/null
+++ b/TESTING/LIN/debchvxx.c
@@ -0,0 +1,604 @@
+/* debchvxx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__10 = 10;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c__5 = 5;
+static integer c__6 = 6;
+static integer c__7 = 7;
+static integer c__8 = 8;
+
+/* Subroutine */ int debchvxx_(doublereal *thresh, char *path)
+{
+ /* Format strings */
+ static char fmt_8000[] = "(\002 D\002,a2,\002SVXX: N =\002,i2,\002, INFO"
+ " = \002,i3,\002, ORCOND = \002,g12.5,\002, real RCOND = \002,g12"
+ ".5)";
+ static char fmt_9996[] = "(3x,i2,\002: Normwise guaranteed forward erro"
+ "r\002,/5x,\002Guaranteed case: if norm ( abs( Xc - Xt )\002,\002"
+ " / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ), then\002,/5x"
+ ",\002ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS\002)"
+ ;
+ static char fmt_9995[] = "(3x,i2,\002: Componentwise guaranteed forward "
+ "error\002)";
+ static char fmt_9994[] = "(3x,i2,\002: Backwards error\002)";
+ static char fmt_9993[] = "(3x,i2,\002: Reciprocal condition number\002)";
+ static char fmt_9992[] = "(3x,i2,\002: Reciprocal normwise condition num"
+ "ber\002)";
+ static char fmt_9991[] = "(3x,i2,\002: Raw normwise error estimate\002)";
+ static char fmt_9990[] = "(3x,i2,\002: Reciprocal componentwise conditio"
+ "n number\002)";
+ static char fmt_9989[] = "(3x,i2,\002: Raw componentwise error estimat"
+ "e\002)";
+ static char fmt_9999[] = "(\002 D\002,a2,\002SVXX: N =\002,i2,\002, RHS "
+ "= \002,i2,\002, NWISE GUAR. = \002,a,\002, CWISE GUAR. = \002,a"
+ ",\002 test(\002,i1,\002) =\002,g12.5)";
+ static char fmt_9998[] = "(\002 D\002,a2,\002SVXX: \002,i6,\002 out of"
+ " \002,i6,\002 tests failed to pass the threshold\002)";
+ static char fmt_9997[] = "(\002 D\002,a2,\002SVXX passed the tests of er"
+ "ror bounds\002)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1, d__2, d__3;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_wsle(cilist *), e_wsle(void);
+
+ /* Local variables */
+ extern /* Subroutine */ int dsysvxx_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ char *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *);
+ doublereal errbnd_c__[30], errbnd_n__[30], a[100] /* was [10][10] */, b[
+ 100] /* was [10][10] */, c__[10];
+ integer i__, j, k;
+ doublereal m;
+ integer n;
+ doublereal r__[10], s[10], x[100] /* was [10][10] */, cwise_bnd__;
+ char c2[2];
+ doublereal nwise_bnd__, cwise_err__, nwise_err__, errthresh, ab[190]
+ /* was [19][10] */, af[100] /* was [10][10] */;
+ integer kl, ku;
+ doublereal condthresh, afb[280] /* was [28][10] */;
+ integer lda;
+ doublereal eps, cwise_rcond__, nwise_rcond__;
+ integer n_aux_tests__, ldab;
+ doublereal diff[100] /* was [10][10] */;
+ char fact[1];
+ doublereal berr[10];
+ integer info, ipiv[10], nrhs;
+ doublereal rinv[10];
+ char uplo[1];
+ doublereal work[150], sumr;
+ integer ldafb;
+ doublereal ccond;
+ integer nfail;
+ char cguar[3];
+ doublereal ncond;
+ char equed[1];
+ doublereal rcond, acopy[100] /* was [10][10] */;
+ char nguar[3], trans[1];
+ integer iwork[30];
+ doublereal rnorm, normt, sumri;
+ logical printed_guide__;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ doublereal abcopy[190] /* was [19][10] */;
+ extern logical lsamen_(integer *, char *, char *);
+ doublereal params[2], orcond, rinorm, tstrat[6], rpvgrw;
+ extern /* Subroutine */ int dlahilb_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ doublereal invhilb[100] /* was [10][10] */, normdif;
+ extern /* Subroutine */ int dgbsvxx_(char *, char *, integer *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *, char *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *), dgesvxx_(char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, char *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *), dposvxx_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, char *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 6, 0, fmt_8000, 0 };
+ static cilist io___66 = { 0, 6, 0, 0, 0 };
+ static cilist io___67 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___68 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___69 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___70 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___71 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___72 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___73 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___74 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___75 = { 0, 6, 0, 0, 0 };
+ static cilist io___76 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___77 = { 0, 6, 0, 0, 0 };
+ static cilist io___78 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___79 = { 0, 6, 0, fmt_9997, 0 };
+
+
+/* .. Scalar Arguments .. */
+
+/* Purpose */
+/* ====== */
+
+/* DEBCHVXX will run D**SVXX on a series of Hilbert matrices and then */
+/* compare the error bounds returned by D**SVXX to see if the returned */
+/* answer indeed falls within those bounds. */
+
+/* Eight test ratios will be computed. The tests will pass if they are .LT. */
+/* THRESH. There are two cases that are determined by 1 / (SQRT( N ) * EPS). */
+/* If that value is .LE. to the component wise reciprocal condition number, */
+/* it uses the guaranteed case, other wise it uses the unguaranteed case. */
+
+/* Test ratios: */
+/* Let Xc be X_computed and Xt be X_truth. */
+/* The norm used is the infinity norm. */
+/* Let A be the guaranteed case and B be the unguaranteed case. */
+
+/* 1. Normwise guaranteed forward error bound. */
+/* A: norm ( abs( Xc - Xt ) / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ) and */
+/* ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N),10) * EPS. */
+/* If these conditions are met, the test ratio is set to be */
+/* ERRBND( *, nwise_i, bnd_i ) / MAX(SQRT(N), 10). Otherwise it is 1/EPS. */
+/* B: For this case, CGESVXX should just return 1. If it is less than */
+/* one, treat it the same as in 1A. Otherwise it fails. (Set test */
+/* ratio to ERRBND( *, nwise_i, bnd_i ) * THRESH?) */
+
+/* 2. Componentwise guaranteed forward error bound. */
+/* A: norm ( abs( Xc(j) - Xt(j) ) ) / norm (Xt(j)) .LE. ERRBND( *, cwise_i, bnd_i ) */
+/* for all j .AND. ERRBND( *, cwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS. */
+/* If these conditions are met, the test ratio is set to be */
+/* ERRBND( *, cwise_i, bnd_i ) / MAX(SQRT(N), 10). Otherwise it is 1/EPS. */
+/* B: Same as normwise test ratio. */
+
+/* 3. Backwards error. */
+/* A: The test ratio is set to BERR/EPS. */
+/* B: Same test ratio. */
+
+/* 4. Reciprocal condition number. */
+/* A: A condition number is computed with Xt and compared with the one */
+/* returned from CGESVXX. Let RCONDc be the RCOND returned by D**SVXX */
+/* and RCONDt be the RCOND from the truth value. Test ratio is set to */
+/* MAX(RCONDc/RCONDt, RCONDt/RCONDc). */
+/* B: Test ratio is set to 1 / (EPS * RCONDc). */
+
+/* 5. Reciprocal normwise condition number. */
+/* A: The test ratio is set to */
+/* MAX(ERRBND( *, nwise_i, cond_i ) / NCOND, NCOND / ERRBND( *, nwise_i, cond_i )). */
+/* B: Test ratio is set to 1 / (EPS * ERRBND( *, nwise_i, cond_i )). */
+
+/* 6. Reciprocal componentwise condition number. */
+/* A: Test ratio is set to */
+/* MAX(ERRBND( *, cwise_i, cond_i ) / CCOND, CCOND / ERRBND( *, cwise_i, cond_i )). */
+/* B: Test ratio is set to 1 / (EPS * ERRBND( *, cwise_i, cond_i )). */
+
+/* .. Parameters .. */
+/* NMAX is determined by the largest number in the inverse of the hilbert */
+/* matrix. Precision is exhausted when the largest entry in it is greater */
+/* than 2 to the power of the number of bits in the fraction of the data */
+/* type used plus one, which is 24 for single precision. */
+/* NMAX should be 6 for single and 11 for double. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Parameters .. */
+/* Create the loop to test out the Hilbert matrices */
+ *(unsigned char *)fact = 'E';
+ *(unsigned char *)uplo = 'U';
+ *(unsigned char *)trans = 'N';
+ *(unsigned char *)equed = 'N';
+ eps = dlamch_("Epsilon");
+ nfail = 0;
+ n_aux_tests__ = 0;
+ lda = 10;
+ ldab = 19;
+ ldafb = 28;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+/* Main loop to test the different Hilbert Matrices. */
+ printed_guide__ = FALSE_;
+ for (n = 1; n <= 10; ++n) {
+ params[0] = -1.;
+ params[1] = -1.;
+ kl = n - 1;
+ ku = n - 1;
+ nrhs = n;
+/* Computing MAX */
+ d__1 = sqrt((doublereal) n);
+ m = max(d__1,10.);
+/* Generate the Hilbert matrix, its inverse, and the */
+/* right hand side, all scaled by the LCM(1,..,2N-1). */
+ dlahilb_(&n, &n, a, &lda, invhilb, &lda, b, &lda, work, &info);
+/* Copy A into ACOPY. */
+ dlacpy_("ALL", &n, &n, a, &c__10, acopy, &c__10);
+/* Store A in band format for GB tests */
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = kl + ku + 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ab[i__ + j * 19 - 20] = 0.;
+ }
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = 1, i__3 = j - ku;
+/* Computing MIN */
+ i__5 = n, i__6 = j + kl;
+ i__4 = min(i__5,i__6);
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ ab[ku + 1 + i__ - j + j * 19 - 20] = a[i__ + j * 10 - 11];
+ }
+ }
+/* Copy AB into ABCOPY. */
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = kl + ku + 1;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ abcopy[i__ + j * 19 - 20] = 0.;
+ }
+ }
+ i__1 = kl + ku + 1;
+ dlacpy_("ALL", &i__1, &n, ab, &ldab, abcopy, &ldab);
+/* Call D**SVXX with default PARAMS and N_ERR_BND = 3. */
+ if (lsamen_(&c__2, c2, "SY")) {
+ dsysvxx_(fact, uplo, &n, &nrhs, acopy, &lda, af, &lda, ipiv,
+ equed, s, b, &lda, x, &lda, &orcond, &rpvgrw, berr, &c__3,
+ errbnd_n__, errbnd_c__, &c__2, params, work, iwork, &
+ info);
+ } else if (lsamen_(&c__2, c2, "PO")) {
+ dposvxx_(fact, uplo, &n, &nrhs, acopy, &lda, af, &lda, equed, s,
+ b, &lda, x, &lda, &orcond, &rpvgrw, berr, &c__3,
+ errbnd_n__, errbnd_c__, &c__2, params, work, iwork, &info);
+ } else if (lsamen_(&c__2, c2, "GB")) {
+ dgbsvxx_(fact, trans, &n, &kl, &ku, &nrhs, abcopy, &ldab, afb, &
+ ldafb, ipiv, equed, r__, c__, b, &lda, x, &lda, &orcond, &
+ rpvgrw, berr, &c__3, errbnd_n__, errbnd_c__, &c__2,
+ params, work, iwork, &info);
+ } else {
+ dgesvxx_(fact, trans, &n, &nrhs, acopy, &lda, af, &lda, ipiv,
+ equed, r__, c__, b, &lda, x, &lda, &orcond, &rpvgrw, berr,
+ &c__3, errbnd_n__, errbnd_c__, &c__2, params, work,
+ iwork, &info);
+ }
+ ++n_aux_tests__;
+ if (orcond < eps) {
+/* Either factorization failed or the matrix is flagged, and 1 <= */
+/* INFO <= N+1. We don't decide based on rcond anymore. */
+/* IF (INFO .EQ. 0 .OR. INFO .GT. N+1) THEN */
+/* NFAIL = NFAIL + 1 */
+/* WRITE (*, FMT=8000) N, INFO, ORCOND, RCOND */
+/* END IF */
+ } else {
+/* Either everything succeeded (INFO == 0) or some solution failed */
+/* to converge (INFO > N+1). */
+ if (info > 0 && info <= n + 1) {
+ ++nfail;
+ s_wsfe(&io___42);
+ do_fio(&c__1, c2, (ftnlen)2);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&orcond, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&rcond, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ }
+/* Calculating the difference between D**SVXX's X and the true X. */
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__4 = nrhs;
+ for (j = 1; j <= i__4; ++j) {
+ diff[i__ + j * 10 - 11] = x[i__ + j * 10 - 11] - invhilb[i__
+ + j * 10 - 11];
+ }
+ }
+/* Calculating the RCOND */
+ rnorm = 0.;
+ rinorm = 0.;
+ if (lsamen_(&c__2, c2, "PO") || lsamen_(&c__2,
+ c2, "SY")) {
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sumr = 0.;
+ sumri = 0.;
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ sumr += s[i__ - 1] * (d__1 = a[i__ + j * 10 - 11], abs(
+ d__1)) * s[j - 1];
+ sumri += (d__1 = invhilb[i__ + j * 10 - 11], abs(d__1)) /
+ (s[j - 1] * s[i__ - 1]);
+ }
+ rnorm = max(rnorm,sumr);
+ rinorm = max(rinorm,sumri);
+ }
+ } else if (lsamen_(&c__2, c2, "GE") || lsamen_(&
+ c__2, c2, "GB")) {
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sumr = 0.;
+ sumri = 0.;
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ sumr += r__[i__ - 1] * (d__1 = a[i__ + j * 10 - 11], abs(
+ d__1)) * c__[j - 1];
+ sumri += (d__1 = invhilb[i__ + j * 10 - 11], abs(d__1)) /
+ (r__[j - 1] * c__[i__ - 1]);
+ }
+ rnorm = max(rnorm,sumr);
+ rinorm = max(rinorm,sumri);
+ }
+ }
+ rnorm /= abs(a[0]);
+ rcond = 1. / (rnorm * rinorm);
+/* Calculating the R for normwise rcond. */
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ rinv[i__ - 1] = 0.;
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ rinv[i__ - 1] += (d__1 = a[i__ + j * 10 - 11], abs(d__1));
+ }
+ }
+/* Calculating the Normwise rcond. */
+ rinorm = 0.;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sumri = 0.;
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ sumri += (d__1 = invhilb[i__ + j * 10 - 11] * rinv[j - 1],
+ abs(d__1));
+ }
+ rinorm = max(rinorm,sumri);
+ }
+/* invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm */
+/* by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix) */
+ ncond = abs(a[0]) / rinorm;
+ condthresh = m * eps;
+ errthresh = m * eps;
+ i__1 = nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ normt = 0.;
+ normdif = 0.;
+ cwise_err__ = 0.;
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+/* Computing MAX */
+ d__2 = (d__1 = invhilb[i__ + k * 10 - 11], abs(d__1));
+ normt = max(d__2,normt);
+/* Computing MAX */
+ d__2 = (d__1 = x[i__ + k * 10 - 11] - invhilb[i__ + k * 10 -
+ 11], abs(d__1));
+ normdif = max(d__2,normdif);
+ if (invhilb[i__ + k * 10 - 11] != 0.) {
+/* Computing MAX */
+ d__3 = (d__1 = x[i__ + k * 10 - 11] - invhilb[i__ + k *
+ 10 - 11], abs(d__1)) / (d__2 = invhilb[i__ + k *
+ 10 - 11], abs(d__2));
+ cwise_err__ = max(d__3,cwise_err__);
+ } else if (x[i__ + k * 10 - 11] != 0.) {
+ cwise_err__ = dlamch_("OVERFLOW");
+ }
+ }
+ if (normt != 0.) {
+ nwise_err__ = normdif / normt;
+ } else if (normdif != 0.) {
+ nwise_err__ = dlamch_("OVERFLOW");
+ } else {
+ nwise_err__ = 0.;
+ }
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ rinv[i__ - 1] = 0.;
+ }
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ rinv[i__ - 1] += (d__1 = a[i__ + j * 10 - 11] * invhilb[j
+ + k * 10 - 11], abs(d__1));
+ }
+ }
+ rinorm = 0.;
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ sumri = 0.;
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ sumri += (d__1 = invhilb[i__ + j * 10 - 11] * rinv[j - 1]
+ / invhilb[i__ + k * 10 - 11], abs(d__1));
+ }
+ rinorm = max(rinorm,sumri);
+ }
+/* invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm */
+/* by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix) */
+ ccond = abs(a[0]) / rinorm;
+/* Forward error bound tests */
+ nwise_bnd__ = errbnd_n__[k + nrhs - 1];
+ cwise_bnd__ = errbnd_c__[k + nrhs - 1];
+ nwise_rcond__ = errbnd_n__[k + (nrhs << 1) - 1];
+ cwise_rcond__ = errbnd_c__[k + (nrhs << 1) - 1];
+/* write (*,*) 'nwise : ', n, k, ncond, nwise_rcond, */
+/* $ condthresh, ncond.ge.condthresh */
+/* write (*,*) 'nwise2: ', k, nwise_bnd, nwise_err, errthresh */
+ if (ncond >= condthresh) {
+ s_copy(nguar, "YES", (ftnlen)3, (ftnlen)3);
+ if (nwise_bnd__ > errthresh) {
+ tstrat[0] = 1 / (eps * 2.);
+ } else {
+ if (nwise_bnd__ != 0.) {
+ tstrat[0] = nwise_err__ / nwise_bnd__;
+ } else if (nwise_err__ != 0.) {
+ tstrat[0] = 1 / (eps * 16.f);
+ } else {
+ tstrat[0] = 0.;
+ }
+ if (tstrat[0] > 1.) {
+ tstrat[0] = 1 / (eps * 4.);
+ }
+ }
+ } else {
+ s_copy(nguar, "NO", (ftnlen)3, (ftnlen)2);
+ if (nwise_bnd__ < 1.) {
+ tstrat[0] = 1 / (eps * 8.);
+ } else {
+ tstrat[0] = 1.;
+ }
+ }
+/* write (*,*) 'cwise : ', n, k, ccond, cwise_rcond, */
+/* $ condthresh, ccond.ge.condthresh */
+/* write (*,*) 'cwise2: ', k, cwise_bnd, cwise_err, errthresh */
+ if (ccond >= condthresh) {
+ s_copy(cguar, "YES", (ftnlen)3, (ftnlen)3);
+ if (cwise_bnd__ > errthresh) {
+ tstrat[1] = 1 / (eps * 2.);
+ } else {
+ if (cwise_bnd__ != 0.) {
+ tstrat[1] = cwise_err__ / cwise_bnd__;
+ } else if (cwise_err__ != 0.) {
+ tstrat[1] = 1 / (eps * 16.);
+ } else {
+ tstrat[1] = 0.;
+ }
+ if (tstrat[1] > 1.) {
+ tstrat[1] = 1 / (eps * 4.);
+ }
+ }
+ } else {
+ s_copy(cguar, "NO", (ftnlen)3, (ftnlen)2);
+ if (cwise_bnd__ < 1.) {
+ tstrat[1] = 1 / (eps * 8.);
+ } else {
+ tstrat[1] = 1.;
+ }
+ }
+/* Backwards error test */
+ tstrat[2] = berr[k - 1] / eps;
+/* Condition number tests */
+ tstrat[3] = rcond / orcond;
+ if (rcond >= condthresh && tstrat[3] < 1.) {
+ tstrat[3] = 1. / tstrat[3];
+ }
+ tstrat[4] = ncond / nwise_rcond__;
+ if (ncond >= condthresh && tstrat[4] < 1.) {
+ tstrat[4] = 1. / tstrat[4];
+ }
+ tstrat[5] = ccond / nwise_rcond__;
+ if (ccond >= condthresh && tstrat[5] < 1.) {
+ tstrat[5] = 1. / tstrat[5];
+ }
+ for (i__ = 1; i__ <= 6; ++i__) {
+ if (tstrat[i__ - 1] > *thresh) {
+ if (! printed_guide__) {
+ s_wsle(&io___66);
+ e_wsle();
+ s_wsfe(&io___67);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___68);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___69);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___70);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___71);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___72);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___73);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___74);
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsle(&io___75);
+ e_wsle();
+ printed_guide__ = TRUE_;
+ }
+ s_wsfe(&io___76);
+ do_fio(&c__1, c2, (ftnlen)2);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, nguar, (ftnlen)3);
+ do_fio(&c__1, cguar, (ftnlen)3);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&tstrat[i__ - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ }
+ }
+/* $$$ WRITE(*,*) */
+/* $$$ WRITE(*,*) 'Normwise Error Bounds' */
+/* $$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,nwise_i,bnd_i) */
+/* $$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,nwise_i,cond_i) */
+/* $$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,nwise_i,rawbnd_i) */
+/* $$$ WRITE(*,*) */
+/* $$$ WRITE(*,*) 'Componentwise Error Bounds' */
+/* $$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,cwise_i,bnd_i) */
+/* $$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,cwise_i,cond_i) */
+/* $$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,cwise_i,rawbnd_i) */
+/* $$$ print *, 'Info: ', info */
+/* $$$ WRITE(*,*) */
+/* WRITE(*,*) 'TSTRAT: ',TSTRAT */
+ }
+ s_wsle(&io___77);
+ e_wsle();
+ if (nfail > 0) {
+ s_wsfe(&io___78);
+ do_fio(&c__1, c2, (ftnlen)2);
+ do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
+ i__1 = n * 6 + n_aux_tests__;
+ do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ s_wsfe(&io___79);
+ do_fio(&c__1, c2, (ftnlen)2);
+ e_wsfe();
+ }
+/* Test ratios. */
+ return 0;
+} /* debchvxx_ */
diff --git a/TESTING/LIN/derrab.c b/TESTING/LIN/derrab.c
new file mode 100644
index 0000000..9263d53
--- /dev/null
+++ b/TESTING/LIN/derrab.c
@@ -0,0 +1,177 @@
+/* derrab.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int derrab_(integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a6,\002 drivers passed the tests of the er"
+ "ror exits\002)";
+ static char fmt_9998[] = "(\002 *** \002,a6,\002 drivers failed the test"
+ "s of the error \002,\002exits ***\002)";
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublereal a[16] /* was [4][4] */, b[4], c__[4];
+ integer i__, j;
+ doublereal r__[4], w[8], x[4], r1[4], r2[4], af[16] /* was [4][4] */;
+ integer ip[4], info, iter;
+ doublereal work[1];
+ real swork[1];
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), dsgesv_(integer *, integer *, doublereal *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___18 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___19 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRAB tests the error exits for DSGESV. */
+
+/* Arguments */
+/* ========= */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
+ af[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
+/* L10: */
+ }
+ b[j - 1] = 0.;
+ r1[j - 1] = 0.;
+ r2[j - 1] = 0.;
+ w[j - 1] = 0.;
+ x[j - 1] = 0.;
+ c__[j - 1] = 0.;
+ r__[j - 1] = 0.;
+ ip[j - 1] = j;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+ s_copy(srnamc_1.srnamt, "DSGESV", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsgesv_(&c_n1, &c__0, a, &c__1, ip, b, &c__1, x, &c__1, work, swork, &
+ iter, &info);
+ chkxer_("DSGESV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsgesv_(&c__0, &c_n1, a, &c__1, ip, b, &c__1, x, &c__1, work, swork, &
+ iter, &info);
+ chkxer_("DSGESV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dsgesv_(&c__2, &c__1, a, &c__1, ip, b, &c__2, x, &c__2, work, swork, &
+ iter, &info);
+ chkxer_("DSGESV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dsgesv_(&c__2, &c__1, a, &c__2, ip, b, &c__1, x, &c__2, work, swork, &
+ iter, &info);
+ chkxer_("DSGESV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dsgesv_(&c__2, &c__1, a, &c__2, ip, b, &c__2, x, &c__1, work, swork, &
+ iter, &info);
+ chkxer_("DSGESV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___18.ciunit = infoc_1.nout;
+ s_wsfe(&io___18);
+ do_fio(&c__1, "DSGESV", (ftnlen)6);
+ e_wsfe();
+ } else {
+ io___19.ciunit = infoc_1.nout;
+ s_wsfe(&io___19);
+ do_fio(&c__1, "DSGESV", (ftnlen)6);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of DERRAB */
+
+} /* derrab_ */
diff --git a/TESTING/LIN/derrac.c b/TESTING/LIN/derrac.c
new file mode 100644
index 0000000..c95ea4e
--- /dev/null
+++ b/TESTING/LIN/derrac.c
@@ -0,0 +1,181 @@
+/* derrac.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int derrac_(integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a6,\002 drivers passed the tests of the er"
+ "ror exits\002)";
+ static char fmt_9998[] = "(\002 *** \002,a6,\002 drivers failed the test"
+ "s of the error \002,\002exits ***\002)";
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublereal a[16] /* was [4][4] */, b[4], c__[4];
+ integer i__, j;
+ doublereal r__[4], w[8], x[4], r1[4], r2[4], af[16] /* was [4][4] */;
+ integer info, iter;
+ doublereal work[16];
+ real swork[16];
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), dsposv_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___17 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___18 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* May 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRAC tests the error exits for DSPOSV. */
+
+/* Arguments */
+/* ========= */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
+ af[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
+/* L10: */
+ }
+ b[j - 1] = 0.;
+ r1[j - 1] = 0.;
+ r2[j - 1] = 0.;
+ w[j - 1] = 0.;
+ x[j - 1] = 0.;
+ c__[j - 1] = 0.;
+ r__[j - 1] = 0.;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+ s_copy(srnamc_1.srnamt, "DSPOSV", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsposv_("/", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, work, swork, &
+ iter, &info);
+ chkxer_("DSPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsposv_("U", &c_n1, &c__0, a, &c__1, b, &c__1, x, &c__1, work, swork, &
+ iter, &info);
+ chkxer_("DSPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dsposv_("U", &c__0, &c_n1, a, &c__1, b, &c__1, x, &c__1, work, swork, &
+ iter, &info);
+ chkxer_("DSPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dsposv_("U", &c__2, &c__1, a, &c__1, b, &c__2, x, &c__2, work, swork, &
+ iter, &info);
+ chkxer_("DSPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dsposv_("U", &c__2, &c__1, a, &c__2, b, &c__1, x, &c__2, work, swork, &
+ iter, &info);
+ chkxer_("DSPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dsposv_("U", &c__2, &c__1, a, &c__2, b, &c__2, x, &c__1, work, swork, &
+ iter, &info);
+ chkxer_("DSPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___17.ciunit = infoc_1.nout;
+ s_wsfe(&io___17);
+ do_fio(&c__1, "DSPOSV", (ftnlen)6);
+ e_wsfe();
+ } else {
+ io___18.ciunit = infoc_1.nout;
+ s_wsfe(&io___18);
+ do_fio(&c__1, "DSPOSV", (ftnlen)6);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of DERRAC */
+
+} /* derrac_ */
diff --git a/TESTING/LIN/derrge.c b/TESTING/LIN/derrge.c
new file mode 100644
index 0000000..08a82ac
--- /dev/null
+++ b/TESTING/LIN/derrge.c
@@ -0,0 +1,511 @@
+/* derrge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__12 = 12;
+static integer c__3 = 3;
+static integer c__4 = 4;
+
+/* Subroutine */ int derrge_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal a[16] /* was [4][4] */, b[4];
+ integer i__, j;
+ doublereal w[12], x[4];
+ char c2[2];
+ doublereal r1[4], r2[4], af[16] /* was [4][4] */;
+ integer ip[4], iw[4], info;
+ doublereal anrm, ccond, rcond;
+ extern /* Subroutine */ int dgbtf2_(integer *, integer *, integer *,
+ integer *, doublereal *, integer *, integer *, integer *),
+ dgetf2_(integer *, integer *, doublereal *, integer *, integer *,
+ integer *), dgbcon_(char *, integer *, integer *, integer *,
+ doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *), dgecon_(char *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *), alaesm_(char *,
+ logical *, integer *), dgbequ_(integer *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *)
+ , dgbrfs_(char *, integer *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *),
+ dgbtrf_(integer *, integer *, integer *, integer *, doublereal *,
+ integer *, integer *, integer *), dgeequ_(integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *), dgerfs_(char *, integer *
+, integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *), dgetrf_(integer *, integer *, doublereal *, integer *,
+ integer *, integer *), dgetri_(integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), dgbtrs_(char *, integer *, integer *,
+ integer *, integer *, doublereal *, integer *, integer *,
+ doublereal *, integer *, integer *), dgetrs_(char *,
+ integer *, integer *, doublereal *, integer *, integer *,
+ doublereal *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRGE tests the error exits for the DOUBLE PRECISION routines */
+/* for general matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
+ af[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
+/* L10: */
+ }
+ b[j - 1] = 0.;
+ r1[j - 1] = 0.;
+ r2[j - 1] = 0.;
+ w[j - 1] = 0.;
+ x[j - 1] = 0.;
+ ip[j - 1] = j;
+ iw[j - 1] = j;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "GE")) {
+
+/* Test error exits of the routines that use the LU decomposition */
+/* of a general matrix. */
+
+/* DGETRF */
+
+ s_copy(srnamc_1.srnamt, "DGETRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgetrf_(&c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("DGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgetrf_(&c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("DGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgetrf_(&c__2, &c__1, a, &c__1, ip, &info);
+ chkxer_("DGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGETF2 */
+
+ s_copy(srnamc_1.srnamt, "DGETF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgetf2_(&c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("DGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgetf2_(&c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("DGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgetf2_(&c__2, &c__1, a, &c__1, ip, &info);
+ chkxer_("DGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGETRI */
+
+ s_copy(srnamc_1.srnamt, "DGETRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgetri_(&c_n1, a, &c__1, ip, w, &c__12, &info);
+ chkxer_("DGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgetri_(&c__2, a, &c__1, ip, w, &c__12, &info);
+ chkxer_("DGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGETRS */
+
+ s_copy(srnamc_1.srnamt, "DGETRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgetrs_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgetrs_("N", &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgetrs_("N", &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgetrs_("N", &c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
+ chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dgetrs_("N", &c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
+ chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGERFS */
+
+ s_copy(srnamc_1.srnamt, "DGERFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgerfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgerfs_("N", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgerfs_("N", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgerfs_("N", &c__2, &c__1, a, &c__1, af, &c__2, ip, b, &c__2, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__1, ip, b, &c__2, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__1, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__2, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGECON */
+
+ s_copy(srnamc_1.srnamt, "DGECON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgecon_("/", &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("DGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgecon_("1", &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("DGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgecon_("1", &c__2, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("DGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGEEQU */
+
+ s_copy(srnamc_1.srnamt, "DGEEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgeequ_(&c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("DGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgeequ_(&c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("DGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgeequ_(&c__2, &c__2, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("DGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* Test error exits of the routines that use the LU decomposition */
+/* of a general band matrix. */
+
+/* DGBTRF */
+
+ s_copy(srnamc_1.srnamt, "DGBTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgbtrf_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgbtrf_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgbtrf_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgbtrf_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dgbtrf_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
+ chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGBTF2 */
+
+ s_copy(srnamc_1.srnamt, "DGBTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgbtf2_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgbtf2_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgbtf2_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgbtf2_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dgbtf2_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
+ chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGBTRS */
+
+ s_copy(srnamc_1.srnamt, "DGBTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgbtrs_("/", &c__0, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgbtrs_("N", &c_n1, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgbtrs_("N", &c__1, &c_n1, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgbtrs_("N", &c__1, &c__0, &c_n1, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgbtrs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dgbtrs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, ip, b, &c__2, &
+ info);
+ chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dgbtrs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGBRFS */
+
+ s_copy(srnamc_1.srnamt, "DGBRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgbrfs_("/", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgbrfs_("N", &c_n1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgbrfs_("N", &c__1, &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgbrfs_("N", &c__1, &c__0, &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgbrfs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__2, af, &c__4, ip, b, &
+ c__2, x, &c__2, r1, r2, w, iw, &info);
+ chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__3, ip, b, &
+ c__2, x, &c__2, r1, r2, w, iw, &info);
+ chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__2, r1, r2, w, iw, &info);
+ chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ dgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
+ c__2, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGBCON */
+
+ s_copy(srnamc_1.srnamt, "DGBCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgbcon_("/", &c__0, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, iw,
+ &info);
+ chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgbcon_("1", &c_n1, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, iw,
+ &info);
+ chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgbcon_("1", &c__1, &c_n1, &c__0, a, &c__1, ip, &anrm, &rcond, w, iw,
+ &info);
+ chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgbcon_("1", &c__1, &c__0, &c_n1, a, &c__1, ip, &anrm, &rcond, w, iw,
+ &info);
+ chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dgbcon_("1", &c__2, &c__1, &c__1, a, &c__3, ip, &anrm, &rcond, w, iw,
+ &info);
+ chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGBEQU */
+
+ s_copy(srnamc_1.srnamt, "DGBEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgbequ_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgbequ_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgbequ_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgbequ_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dgbequ_(&c__2, &c__2, &c__1, &c__1, a, &c__2, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of DERRGE */
+
+} /* derrge_ */
diff --git a/TESTING/LIN/derrgex.c b/TESTING/LIN/derrgex.c
new file mode 100644
index 0000000..c7b3631
--- /dev/null
+++ b/TESTING/LIN/derrgex.c
@@ -0,0 +1,716 @@
+/* derrgex.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__12 = 12;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static integer c__5 = 5;
+
+/* Subroutine */ int derrge_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal a[16] /* was [4][4] */, b[4], c__[4];
+ integer i__, j;
+ doublereal r__[4], w[12], x[4];
+ char c2[2];
+ doublereal r1[4], r2[4], af[16] /* was [4][4] */;
+ char eq[1];
+ integer ip[4], iw[4];
+ doublereal err_bnds_c__[12] /* was [4][3] */;
+ integer n_err_bnds__;
+ doublereal err_bnds_n__[12] /* was [4][3] */, berr;
+ integer info;
+ doublereal anrm, ccond, rcond;
+ extern /* Subroutine */ int dgbtf2_(integer *, integer *, integer *,
+ integer *, doublereal *, integer *, integer *, integer *),
+ dgetf2_(integer *, integer *, doublereal *, integer *, integer *,
+ integer *), dgbcon_(char *, integer *, integer *, integer *,
+ doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *), dgecon_(char *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *), alaesm_(char *,
+ logical *, integer *), dgbequ_(integer *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *)
+ , dgbrfs_(char *, integer *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *),
+ dgbtrf_(integer *, integer *, integer *, integer *, doublereal *,
+ integer *, integer *, integer *), dgeequ_(integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *), dgerfs_(char *, integer *
+, integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *), dgetrf_(integer *, integer *, doublereal *, integer *,
+ integer *, integer *), dgetri_(integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ doublereal params[1];
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), dgbtrs_(char *, integer *, integer *,
+ integer *, integer *, doublereal *, integer *, integer *,
+ doublereal *, integer *, integer *), dgetrs_(char *,
+ integer *, integer *, doublereal *, integer *, integer *,
+ doublereal *, integer *, integer *), dgbequb_(integer *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *), dgeequb_(integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *), dgbrfsx_(char *, char *,
+ integer *, integer *, integer *, integer *, doublereal *, integer
+ *, doublereal *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *);
+ integer nparams;
+ extern /* Subroutine */ int dgerfsx_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRGE tests the error exits for the DOUBLE PRECISION routines */
+/* for general matrices. */
+
+/* Note that this file is used only when the XBLAS are available, */
+/* otherwise derrge.f defines this subroutine. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
+ af[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
+/* L10: */
+ }
+ b[j - 1] = 0.;
+ r1[j - 1] = 0.;
+ r2[j - 1] = 0.;
+ w[j - 1] = 0.;
+ x[j - 1] = 0.;
+ c__[j - 1] = 0.;
+ r__[j - 1] = 0.;
+ ip[j - 1] = j;
+ iw[j - 1] = j;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "GE")) {
+
+/* Test error exits of the routines that use the LU decomposition */
+/* of a general matrix. */
+
+/* DGETRF */
+
+ s_copy(srnamc_1.srnamt, "DGETRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgetrf_(&c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("DGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgetrf_(&c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("DGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgetrf_(&c__2, &c__1, a, &c__1, ip, &info);
+ chkxer_("DGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGETF2 */
+
+ s_copy(srnamc_1.srnamt, "DGETF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgetf2_(&c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("DGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgetf2_(&c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("DGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgetf2_(&c__2, &c__1, a, &c__1, ip, &info);
+ chkxer_("DGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGETRI */
+
+ s_copy(srnamc_1.srnamt, "DGETRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgetri_(&c_n1, a, &c__1, ip, w, &c__12, &info);
+ chkxer_("DGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgetri_(&c__2, a, &c__1, ip, w, &c__12, &info);
+ chkxer_("DGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGETRS */
+
+ s_copy(srnamc_1.srnamt, "DGETRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgetrs_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgetrs_("N", &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgetrs_("N", &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgetrs_("N", &c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
+ chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dgetrs_("N", &c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
+ chkxer_("DGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGERFS */
+
+ s_copy(srnamc_1.srnamt, "DGERFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgerfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgerfs_("N", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgerfs_("N", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgerfs_("N", &c__2, &c__1, a, &c__1, af, &c__2, ip, b, &c__2, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__1, ip, b, &c__2, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__1, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__2, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGERFSX */
+
+ n_err_bnds__ = 3;
+ nparams = 0;
+ s_copy(srnamc_1.srnamt, "DGERFSX", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ dgerfsx_("/", eq, &c__0, &c__0, a, &c__1, af, &c__1, ip, r__, c__, b,
+ &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("DGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ *(unsigned char *)eq = '/';
+ dgerfsx_("N", eq, &c__2, &c__1, a, &c__1, af, &c__2, ip, r__, c__, b,
+ &c__2, x, &c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("DGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ *(unsigned char *)eq = 'R';
+ dgerfsx_("N", eq, &c_n1, &c__0, a, &c__1, af, &c__1, ip, r__, c__, b,
+ &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("DGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgerfsx_("N", eq, &c__0, &c_n1, a, &c__1, af, &c__1, ip, r__, c__, b,
+ &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("DGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dgerfsx_("N", eq, &c__2, &c__1, a, &c__1, af, &c__2, ip, r__, c__, b,
+ &c__2, x, &c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("DGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dgerfsx_("N", eq, &c__2, &c__1, a, &c__2, af, &c__1, ip, r__, c__, b,
+ &c__2, x, &c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("DGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ *(unsigned char *)eq = 'C';
+ dgerfsx_("N", eq, &c__2, &c__1, a, &c__2, af, &c__2, ip, r__, c__, b,
+ &c__1, x, &c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("DGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ dgerfsx_("N", eq, &c__2, &c__1, a, &c__2, af, &c__2, ip, r__, c__, b,
+ &c__2, x, &c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("DGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGECON */
+
+ s_copy(srnamc_1.srnamt, "DGECON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgecon_("/", &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("DGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgecon_("1", &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("DGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgecon_("1", &c__2, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("DGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGEEQU */
+
+ s_copy(srnamc_1.srnamt, "DGEEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgeequ_(&c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("DGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgeequ_(&c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("DGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgeequ_(&c__2, &c__2, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("DGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGEEQUB */
+
+ s_copy(srnamc_1.srnamt, "DGEEQUB", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ dgeequb_(&c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info)
+ ;
+ chkxer_("DGEEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgeequb_(&c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info)
+ ;
+ chkxer_("DGEEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgeequb_(&c__2, &c__2, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info)
+ ;
+ chkxer_("DGEEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* Test error exits of the routines that use the LU decomposition */
+/* of a general band matrix. */
+
+/* DGBTRF */
+
+ s_copy(srnamc_1.srnamt, "DGBTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgbtrf_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgbtrf_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgbtrf_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgbtrf_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dgbtrf_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
+ chkxer_("DGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGBTF2 */
+
+ s_copy(srnamc_1.srnamt, "DGBTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgbtf2_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgbtf2_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgbtf2_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgbtf2_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dgbtf2_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
+ chkxer_("DGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGBTRS */
+
+ s_copy(srnamc_1.srnamt, "DGBTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgbtrs_("/", &c__0, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgbtrs_("N", &c_n1, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgbtrs_("N", &c__1, &c_n1, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgbtrs_("N", &c__1, &c__0, &c_n1, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgbtrs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dgbtrs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, ip, b, &c__2, &
+ info);
+ chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dgbtrs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("DGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGBRFS */
+
+ s_copy(srnamc_1.srnamt, "DGBRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgbrfs_("/", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgbrfs_("N", &c_n1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgbrfs_("N", &c__1, &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgbrfs_("N", &c__1, &c__0, &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgbrfs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__2, af, &c__4, ip, b, &
+ c__2, x, &c__2, r1, r2, w, iw, &info);
+ chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__3, ip, b, &
+ c__2, x, &c__2, r1, r2, w, iw, &info);
+ chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__2, r1, r2, w, iw, &info);
+ chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ dgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
+ c__2, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("DGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGBRFSX */
+
+ n_err_bnds__ = 3;
+ nparams = 0;
+ s_copy(srnamc_1.srnamt, "DGBRFSX", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ dgbrfsx_("/", eq, &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ r__, c__, b, &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("DGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ *(unsigned char *)eq = '/';
+ dgbrfsx_("N", eq, &c__2, &c__1, &c__1, &c__1, a, &c__1, af, &c__2, ip,
+ r__, c__, b, &c__2, x, &c__2, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("DGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ *(unsigned char *)eq = 'R';
+ dgbrfsx_("N", eq, &c_n1, &c__1, &c__1, &c__0, a, &c__1, af, &c__1, ip,
+ r__, c__, b, &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("DGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ *(unsigned char *)eq = 'R';
+ dgbrfsx_("N", eq, &c__2, &c_n1, &c__1, &c__1, a, &c__3, af, &c__4, ip,
+ r__, c__, b, &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("DGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ *(unsigned char *)eq = 'R';
+ dgbrfsx_("N", eq, &c__2, &c__1, &c_n1, &c__1, a, &c__3, af, &c__4, ip,
+ r__, c__, b, &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("DGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dgbrfsx_("N", eq, &c__0, &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, ip,
+ r__, c__, b, &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("DGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dgbrfsx_("N", eq, &c__2, &c__1, &c__1, &c__1, a, &c__1, af, &c__2, ip,
+ r__, c__, b, &c__2, x, &c__2, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("DGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dgbrfsx_("N", eq, &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__3, ip,
+ r__, c__, b, &c__2, x, &c__2, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("DGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ *(unsigned char *)eq = 'C';
+ dgbrfsx_("N", eq, &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__5, ip,
+ r__, c__, b, &c__1, x, &c__2, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("DGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ dgbrfsx_("N", eq, &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__5, ip,
+ r__, c__, b, &c__2, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("DGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGBCON */
+
+ s_copy(srnamc_1.srnamt, "DGBCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgbcon_("/", &c__0, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, iw,
+ &info);
+ chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgbcon_("1", &c_n1, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, iw,
+ &info);
+ chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgbcon_("1", &c__1, &c_n1, &c__0, a, &c__1, ip, &anrm, &rcond, w, iw,
+ &info);
+ chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgbcon_("1", &c__1, &c__0, &c_n1, a, &c__1, ip, &anrm, &rcond, w, iw,
+ &info);
+ chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dgbcon_("1", &c__2, &c__1, &c__1, a, &c__3, ip, &anrm, &rcond, w, iw,
+ &info);
+ chkxer_("DGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGBEQU */
+
+ s_copy(srnamc_1.srnamt, "DGBEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgbequ_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgbequ_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgbequ_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgbequ_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dgbequ_(&c__2, &c__2, &c__1, &c__1, a, &c__2, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("DGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGBEQUB */
+
+ s_copy(srnamc_1.srnamt, "DGBEQUB", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ dgbequb_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("DGBEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgbequb_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("DGBEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgbequb_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("DGBEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgbequb_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("DGBEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dgbequb_(&c__2, &c__2, &c__1, &c__1, a, &c__2, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("DGBEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of DERRGE */
+
+} /* derrge_ */
diff --git a/TESTING/LIN/derrgt.c b/TESTING/LIN/derrgt.c
new file mode 100644
index 0000000..b262fd9
--- /dev/null
+++ b/TESTING/LIN/derrgt.c
@@ -0,0 +1,289 @@
+/* derrgt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int derrgt_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ doublereal d__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal b[2], c__[2], d__[2], e[2], f[2], w[2], x[2];
+ char c2[2];
+ doublereal r1[2], r2[2], cf[2], df[2], ef[2];
+ integer ip[2], iw[2], info;
+ doublereal rcond, anorm;
+ extern /* Subroutine */ int alaesm_(char *, logical *, integer *),
+ dgtcon_(char *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), dptcon_(integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *)
+ , dgtrfs_(char *, integer *, integer *, doublereal *, doublereal *
+, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *), dgttrf_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *), dptrfs_(
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *), dpttrf_(
+ integer *, doublereal *, doublereal *, integer *), dgttrs_(char *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dpttrs_(integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRGT tests the error exits for the DOUBLE PRECISION tridiagonal */
+/* routines. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ d__[0] = 1.;
+ d__[1] = 2.;
+ df[0] = 1.;
+ df[1] = 2.;
+ e[0] = 3.;
+ e[1] = 4.;
+ ef[0] = 3.;
+ ef[1] = 4.;
+ anorm = 1.;
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "GT")) {
+
+/* Test error exits for the general tridiagonal routines. */
+
+/* DGTTRF */
+
+ s_copy(srnamc_1.srnamt, "DGTTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgttrf_(&c_n1, c__, d__, e, f, ip, &info);
+ chkxer_("DGTTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGTTRS */
+
+ s_copy(srnamc_1.srnamt, "DGTTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgttrs_("/", &c__0, &c__0, c__, d__, e, f, ip, x, &c__1, &info);
+ chkxer_("DGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgttrs_("N", &c_n1, &c__0, c__, d__, e, f, ip, x, &c__1, &info);
+ chkxer_("DGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgttrs_("N", &c__0, &c_n1, c__, d__, e, f, ip, x, &c__1, &info);
+ chkxer_("DGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dgttrs_("N", &c__2, &c__1, c__, d__, e, f, ip, x, &c__1, &info);
+ chkxer_("DGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGTRFS */
+
+ s_copy(srnamc_1.srnamt, "DGTRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgtrfs_("/", &c__0, &c__0, c__, d__, e, cf, df, ef, f, ip, b, &c__1,
+ x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("DGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgtrfs_("N", &c_n1, &c__0, c__, d__, e, cf, df, ef, f, ip, b, &c__1,
+ x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("DGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgtrfs_("N", &c__0, &c_n1, c__, d__, e, cf, df, ef, f, ip, b, &c__1,
+ x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("DGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ dgtrfs_("N", &c__2, &c__1, c__, d__, e, cf, df, ef, f, ip, b, &c__1,
+ x, &c__2, r1, r2, w, iw, &info);
+ chkxer_("DGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ dgtrfs_("N", &c__2, &c__1, c__, d__, e, cf, df, ef, f, ip, b, &c__2,
+ x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("DGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGTCON */
+
+ s_copy(srnamc_1.srnamt, "DGTCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgtcon_("/", &c__0, c__, d__, e, f, ip, &anorm, &rcond, w, iw, &info);
+ chkxer_("DGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgtcon_("I", &c_n1, c__, d__, e, f, ip, &anorm, &rcond, w, iw, &info);
+ chkxer_("DGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ d__1 = -anorm;
+ dgtcon_("I", &c__0, c__, d__, e, f, ip, &d__1, &rcond, w, iw, &info);
+ chkxer_("DGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PT")) {
+
+/* Test error exits for the positive definite tridiagonal */
+/* routines. */
+
+/* DPTTRF */
+
+ s_copy(srnamc_1.srnamt, "DPTTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpttrf_(&c_n1, d__, e, &info);
+ chkxer_("DPTTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPTTRS */
+
+ s_copy(srnamc_1.srnamt, "DPTTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpttrs_(&c_n1, &c__0, d__, e, x, &c__1, &info);
+ chkxer_("DPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpttrs_(&c__0, &c_n1, d__, e, x, &c__1, &info);
+ chkxer_("DPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dpttrs_(&c__2, &c__1, d__, e, x, &c__1, &info);
+ chkxer_("DPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPTRFS */
+
+ s_copy(srnamc_1.srnamt, "DPTRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dptrfs_(&c_n1, &c__0, d__, e, df, ef, b, &c__1, x, &c__1, r1, r2, w, &
+ info);
+ chkxer_("DPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dptrfs_(&c__0, &c_n1, d__, e, df, ef, b, &c__1, x, &c__1, r1, r2, w, &
+ info);
+ chkxer_("DPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dptrfs_(&c__2, &c__1, d__, e, df, ef, b, &c__1, x, &c__2, r1, r2, w, &
+ info);
+ chkxer_("DPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dptrfs_(&c__2, &c__1, d__, e, df, ef, b, &c__2, x, &c__1, r1, r2, w, &
+ info);
+ chkxer_("DPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPTCON */
+
+ s_copy(srnamc_1.srnamt, "DPTCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dptcon_(&c_n1, d__, e, &anorm, &rcond, w, &info);
+ chkxer_("DPTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ d__1 = -anorm;
+ dptcon_(&c__0, d__, e, &d__1, &rcond, w, &info);
+ chkxer_("DPTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of DERRGT */
+
+} /* derrgt_ */
diff --git a/TESTING/LIN/derrlq.c b/TESTING/LIN/derrlq.c
new file mode 100644
index 0000000..9115748
--- /dev/null
+++ b/TESTING/LIN/derrlq.c
@@ -0,0 +1,376 @@
+/* derrlq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int derrlq_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal a[4] /* was [2][2] */, b[2];
+ integer i__, j;
+ doublereal w[2], x[2], af[4] /* was [2][2] */;
+ integer info;
+ extern /* Subroutine */ int dgelq2_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *), dorgl2_(
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dorml2_(char *, char *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *), alaesm_(char *, logical *, integer *),
+ dgelqf_(integer *, integer *, doublereal *, integer *, doublereal
+ *, doublereal *, integer *, integer *), dgelqs_(integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *),
+ chkxer_(char *, integer *, integer *, logical *, logical *), dorglq_(integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *),
+ dormlq_(char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRLQ tests the error exits for the DOUBLE PRECISION routines */
+/* that use the LQ decomposition of a general matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 2; ++j) {
+ for (i__ = 1; i__ <= 2; ++i__) {
+ a[i__ + (j << 1) - 3] = 1. / (doublereal) (i__ + j);
+ af[i__ + (j << 1) - 3] = 1. / (doublereal) (i__ + j);
+/* L10: */
+ }
+ b[j - 1] = 0.;
+ w[j - 1] = 0.;
+ x[j - 1] = 0.;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+/* Error exits for LQ factorization */
+
+/* DGELQF */
+
+ s_copy(srnamc_1.srnamt, "DGELQF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgelqf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
+ chkxer_("DGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgelqf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("DGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgelqf_(&c__2, &c__1, a, &c__1, b, w, &c__2, &info);
+ chkxer_("DGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dgelqf_(&c__2, &c__1, a, &c__2, b, w, &c__1, &info);
+ chkxer_("DGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGELQ2 */
+
+ s_copy(srnamc_1.srnamt, "DGELQ2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgelq2_(&c_n1, &c__0, a, &c__1, b, w, &info);
+ chkxer_("DGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgelq2_(&c__0, &c_n1, a, &c__1, b, w, &info);
+ chkxer_("DGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgelq2_(&c__2, &c__1, a, &c__1, b, w, &info);
+ chkxer_("DGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGELQS */
+
+ s_copy(srnamc_1.srnamt, "DGELQS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgelqs_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("DGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgelqs_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("DGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgelqs_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
+ chkxer_("DGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgelqs_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("DGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgelqs_(&c__2, &c__2, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
+ chkxer_("DGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dgelqs_(&c__1, &c__2, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("DGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dgelqs_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("DGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DORGLQ */
+
+ s_copy(srnamc_1.srnamt, "DORGLQ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dorglq_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("DORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dorglq_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("DORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dorglq_(&c__2, &c__1, &c__0, a, &c__2, x, w, &c__2, &info);
+ chkxer_("DORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorglq_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
+ chkxer_("DORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorglq_(&c__1, &c__1, &c__2, a, &c__1, x, w, &c__1, &info);
+ chkxer_("DORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dorglq_(&c__2, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
+ chkxer_("DORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dorglq_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
+ chkxer_("DORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DORGL2 */
+
+ s_copy(srnamc_1.srnamt, "DORGL2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dorgl2_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
+ chkxer_("DORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dorgl2_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("DORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dorgl2_(&c__2, &c__1, &c__0, a, &c__2, x, w, &info);
+ chkxer_("DORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorgl2_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
+ chkxer_("DORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorgl2_(&c__1, &c__1, &c__2, a, &c__1, x, w, &info);
+ chkxer_("DORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dorgl2_(&c__2, &c__2, &c__0, a, &c__1, x, w, &info);
+ chkxer_("DORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DORMLQ */
+
+ s_copy(srnamc_1.srnamt, "DORMLQ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dormlq_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dormlq_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dormlq_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dormlq_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dormlq_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dormlq_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dormlq_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dormlq_("L", "N", &c__2, &c__0, &c__2, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("DORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dormlq_("R", "N", &c__0, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dormlq_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dormlq_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dormlq_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("DORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DORML2 */
+
+ s_copy(srnamc_1.srnamt, "DORML2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dorml2_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dorml2_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorml2_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dorml2_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dorml2_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dorml2_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dorml2_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dorml2_("L", "N", &c__2, &c__1, &c__2, a, &c__1, x, af, &c__2, w, &info);
+ chkxer_("DORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dorml2_("R", "N", &c__1, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dorml2_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &info);
+ chkxer_("DORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of DERRLQ */
+
+} /* derrlq_ */
diff --git a/TESTING/LIN/derrls.c b/TESTING/LIN/derrls.c
new file mode 100644
index 0000000..051fa46
--- /dev/null
+++ b/TESTING/LIN/derrls.c
@@ -0,0 +1,295 @@
+/* derrls.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__10 = 10;
+
+/* Subroutine */ int derrls_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal a[4] /* was [2][2] */, b[4] /* was [2][2] */, s[2], w[2];
+ char c2[2];
+ integer ip[2], info, irnk;
+ extern /* Subroutine */ int dgels_(char *, integer *, integer *, integer *
+, doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *);
+ doublereal rcond;
+ extern /* Subroutine */ int alaesm_(char *, logical *, integer *),
+ dgelsd_(integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int dgelss_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *),
+ chkxer_(char *, integer *, integer *, logical *, logical *), dgelsx_(integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *), dgelsy_(integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRLS tests the error exits for the DOUBLE PRECISION least squares */
+/* driver routines (DGELS, SGELSS, SGELSX, SGELSY, SGELSD). */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ a[0] = 1.;
+ a[2] = 2.;
+ a[3] = 3.;
+ a[1] = 4.;
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "LS")) {
+
+/* Test error exits for the least squares driver routines. */
+
+/* DGELS */
+
+ s_copy(srnamc_1.srnamt, "DGELS ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgels_("/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, w, &c__1, &info);
+ chkxer_("DGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgels_("N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, w, &c__1, &info);
+ chkxer_("DGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgels_("N", &c__0, &c_n1, &c__0, a, &c__1, b, &c__1, w, &c__1, &info);
+ chkxer_("DGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgels_("N", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, w, &c__1, &info);
+ chkxer_("DGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dgels_("N", &c__2, &c__0, &c__0, a, &c__1, b, &c__2, w, &c__2, &info);
+ chkxer_("DGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dgels_("N", &c__2, &c__0, &c__0, a, &c__2, b, &c__1, w, &c__2, &info);
+ chkxer_("DGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dgels_("N", &c__1, &c__1, &c__0, a, &c__1, b, &c__1, w, &c__1, &info);
+ chkxer_("DGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGELSS */
+
+ s_copy(srnamc_1.srnamt, "DGELSS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgelss_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__1, &info);
+ chkxer_("DGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgelss_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__1, &info);
+ chkxer_("DGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgelss_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__1, &info);
+ chkxer_("DGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgelss_(&c__2, &c__0, &c__0, a, &c__1, b, &c__2, s, &rcond, &irnk, w,
+ &c__2, &info);
+ chkxer_("DGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dgelss_(&c__2, &c__0, &c__0, a, &c__2, b, &c__1, s, &rcond, &irnk, w,
+ &c__2, &info);
+ chkxer_("DGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGELSX */
+
+ s_copy(srnamc_1.srnamt, "DGELSX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgelsx_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ &info);
+ chkxer_("DGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgelsx_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ &info);
+ chkxer_("DGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgelsx_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ &info);
+ chkxer_("DGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgelsx_(&c__2, &c__0, &c__0, a, &c__1, b, &c__2, ip, &rcond, &irnk, w,
+ &info);
+ chkxer_("DGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dgelsx_(&c__2, &c__0, &c__0, a, &c__2, b, &c__1, ip, &rcond, &irnk, w,
+ &info);
+ chkxer_("DGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGELSY */
+
+ s_copy(srnamc_1.srnamt, "DGELSY", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgelsy_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ &c__10, &info);
+ chkxer_("DGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgelsy_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ &c__10, &info);
+ chkxer_("DGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgelsy_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ &c__10, &info);
+ chkxer_("DGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgelsy_(&c__2, &c__0, &c__0, a, &c__1, b, &c__2, ip, &rcond, &irnk, w,
+ &c__10, &info);
+ chkxer_("DGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dgelsy_(&c__2, &c__0, &c__0, a, &c__2, b, &c__1, ip, &rcond, &irnk, w,
+ &c__10, &info);
+ chkxer_("DGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dgelsy_(&c__2, &c__2, &c__1, a, &c__2, b, &c__2, ip, &rcond, &irnk, w,
+ &c__1, &info);
+ chkxer_("DGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGELSD */
+
+ s_copy(srnamc_1.srnamt, "DGELSD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgelsd_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__10, ip, &info);
+ chkxer_("DGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgelsd_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__10, ip, &info);
+ chkxer_("DGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgelsd_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__10, ip, &info);
+ chkxer_("DGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgelsd_(&c__2, &c__0, &c__0, a, &c__1, b, &c__2, s, &rcond, &irnk, w,
+ &c__10, ip, &info);
+ chkxer_("DGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dgelsd_(&c__2, &c__0, &c__0, a, &c__2, b, &c__1, s, &rcond, &irnk, w,
+ &c__10, ip, &info);
+ chkxer_("DGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dgelsd_(&c__2, &c__2, &c__1, a, &c__2, b, &c__2, s, &rcond, &irnk, w,
+ &c__1, ip, &info);
+ chkxer_("DGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of DERRLS */
+
+} /* derrls_ */
diff --git a/TESTING/LIN/derrpo.c b/TESTING/LIN/derrpo.c
new file mode 100644
index 0000000..0659dc5
--- /dev/null
+++ b/TESTING/LIN/derrpo.c
@@ -0,0 +1,573 @@
+/* derrpo.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int derrpo_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal a[16] /* was [4][4] */, b[4];
+ integer i__, j;
+ doublereal w[12], x[4];
+ char c2[2];
+ doublereal r1[4], r2[4], af[16] /* was [4][4] */;
+ integer iw[4], info;
+ doublereal anrm, rcond;
+ extern /* Subroutine */ int dpbtf2_(char *, integer *, integer *,
+ doublereal *, integer *, integer *), dpotf2_(char *,
+ integer *, doublereal *, integer *, integer *), alaesm_(
+ char *, logical *, integer *), dpbcon_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int dpbequ_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *), dpbrfs_(char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *),
+ dpbtrf_(char *, integer *, integer *, doublereal *, integer *,
+ integer *), dpocon_(char *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *), chkxer_(char *, integer *, integer *, logical
+ *, logical *), dppcon_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *), dpoequ_(integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *), dpbtrs_(char *, integer *
+, integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *), dporfs_(char *, integer *, integer
+ *, doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *), dpotrf_(char *,
+ integer *, doublereal *, integer *, integer *), dpotri_(
+ char *, integer *, doublereal *, integer *, integer *),
+ dppequ_(char *, integer *, doublereal *, doublereal *, doublereal
+ *, doublereal *, integer *), dpprfs_(char *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *), dpptrf_(char *, integer *,
+ doublereal *, integer *), dpptri_(char *, integer *,
+ doublereal *, integer *), dpotrs_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *), dpptrs_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRPO tests the error exits for the DOUBLE PRECISION routines */
+/* for symmetric positive definite matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
+ af[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
+/* L10: */
+ }
+ b[j - 1] = 0.;
+ r1[j - 1] = 0.;
+ r2[j - 1] = 0.;
+ w[j - 1] = 0.;
+ x[j - 1] = 0.;
+ iw[j - 1] = j;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "PO")) {
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a symmetric positive definite matrix. */
+
+/* DPOTRF */
+
+ s_copy(srnamc_1.srnamt, "DPOTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpotrf_("/", &c__0, a, &c__1, &info);
+ chkxer_("DPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpotrf_("U", &c_n1, a, &c__1, &info);
+ chkxer_("DPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dpotrf_("U", &c__2, a, &c__1, &info);
+ chkxer_("DPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPOTF2 */
+
+ s_copy(srnamc_1.srnamt, "DPOTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpotf2_("/", &c__0, a, &c__1, &info);
+ chkxer_("DPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpotf2_("U", &c_n1, a, &c__1, &info);
+ chkxer_("DPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dpotf2_("U", &c__2, a, &c__1, &info);
+ chkxer_("DPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPOTRI */
+
+ s_copy(srnamc_1.srnamt, "DPOTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpotri_("/", &c__0, a, &c__1, &info);
+ chkxer_("DPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpotri_("U", &c_n1, a, &c__1, &info);
+ chkxer_("DPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dpotri_("U", &c__2, a, &c__1, &info);
+ chkxer_("DPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPOTRS */
+
+ s_copy(srnamc_1.srnamt, "DPOTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpotrs_("/", &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("DPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpotrs_("U", &c_n1, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("DPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpotrs_("U", &c__0, &c_n1, a, &c__1, b, &c__1, &info);
+ chkxer_("DPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dpotrs_("U", &c__2, &c__1, a, &c__1, b, &c__2, &info);
+ chkxer_("DPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dpotrs_("U", &c__2, &c__1, a, &c__2, b, &c__1, &info);
+ chkxer_("DPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPORFS */
+
+ s_copy(srnamc_1.srnamt, "DPORFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dporfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, iw, &info);
+ chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dporfs_("U", &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, iw, &info);
+ chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dporfs_("U", &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, iw, &info);
+ chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dporfs_("U", &c__2, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &c__2,
+ r1, r2, w, iw, &info);
+ chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dporfs_("U", &c__2, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &c__2,
+ r1, r2, w, iw, &info);
+ chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__1, x, &c__2,
+ r1, r2, w, iw, &info);
+ chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__2, x, &c__1,
+ r1, r2, w, iw, &info);
+ chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPOCON */
+
+ s_copy(srnamc_1.srnamt, "DPOCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpocon_("/", &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("DPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpocon_("U", &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("DPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dpocon_("U", &c__2, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("DPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPOEQU */
+
+ s_copy(srnamc_1.srnamt, "DPOEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpoequ_(&c_n1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("DPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpoequ_(&c__2, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("DPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PP")) {
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a symmetric positive definite packed matrix. */
+
+/* DPPTRF */
+
+ s_copy(srnamc_1.srnamt, "DPPTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpptrf_("/", &c__0, a, &info);
+ chkxer_("DPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpptrf_("U", &c_n1, a, &info);
+ chkxer_("DPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPPTRI */
+
+ s_copy(srnamc_1.srnamt, "DPPTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpptri_("/", &c__0, a, &info);
+ chkxer_("DPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpptri_("U", &c_n1, a, &info);
+ chkxer_("DPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPPTRS */
+
+ s_copy(srnamc_1.srnamt, "DPPTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpptrs_("/", &c__0, &c__0, a, b, &c__1, &info);
+ chkxer_("DPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpptrs_("U", &c_n1, &c__0, a, b, &c__1, &info);
+ chkxer_("DPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpptrs_("U", &c__0, &c_n1, a, b, &c__1, &info);
+ chkxer_("DPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dpptrs_("U", &c__2, &c__1, a, b, &c__1, &info);
+ chkxer_("DPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPPRFS */
+
+ s_copy(srnamc_1.srnamt, "DPPRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpprfs_("/", &c__0, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
+ info);
+ chkxer_("DPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpprfs_("U", &c_n1, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
+ info);
+ chkxer_("DPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpprfs_("U", &c__0, &c_n1, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
+ info);
+ chkxer_("DPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dpprfs_("U", &c__2, &c__1, a, af, b, &c__1, x, &c__2, r1, r2, w, iw, &
+ info);
+ chkxer_("DPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dpprfs_("U", &c__2, &c__1, a, af, b, &c__2, x, &c__1, r1, r2, w, iw, &
+ info);
+ chkxer_("DPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPPCON */
+
+ s_copy(srnamc_1.srnamt, "DPPCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dppcon_("/", &c__0, a, &anrm, &rcond, w, iw, &info);
+ chkxer_("DPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dppcon_("U", &c_n1, a, &anrm, &rcond, w, iw, &info);
+ chkxer_("DPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPPEQU */
+
+ s_copy(srnamc_1.srnamt, "DPPEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dppequ_("/", &c__0, a, r1, &rcond, &anrm, &info);
+ chkxer_("DPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dppequ_("U", &c_n1, a, r1, &rcond, &anrm, &info);
+ chkxer_("DPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a symmetric positive definite band matrix. */
+
+/* DPBTRF */
+
+ s_copy(srnamc_1.srnamt, "DPBTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpbtrf_("/", &c__0, &c__0, a, &c__1, &info);
+ chkxer_("DPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpbtrf_("U", &c_n1, &c__0, a, &c__1, &info);
+ chkxer_("DPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpbtrf_("U", &c__1, &c_n1, a, &c__1, &info);
+ chkxer_("DPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dpbtrf_("U", &c__2, &c__1, a, &c__1, &info);
+ chkxer_("DPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPBTF2 */
+
+ s_copy(srnamc_1.srnamt, "DPBTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpbtf2_("/", &c__0, &c__0, a, &c__1, &info);
+ chkxer_("DPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpbtf2_("U", &c_n1, &c__0, a, &c__1, &info);
+ chkxer_("DPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpbtf2_("U", &c__1, &c_n1, a, &c__1, &info);
+ chkxer_("DPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dpbtf2_("U", &c__2, &c__1, a, &c__1, &info);
+ chkxer_("DPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPBTRS */
+
+ s_copy(srnamc_1.srnamt, "DPBTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpbtrs_("/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpbtrs_("U", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpbtrs_("U", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dpbtrs_("U", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, &info);
+ chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dpbtrs_("U", &c__2, &c__1, &c__1, a, &c__1, b, &c__1, &info);
+ chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dpbtrs_("U", &c__2, &c__0, &c__1, a, &c__1, b, &c__1, &info);
+ chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPBRFS */
+
+ s_copy(srnamc_1.srnamt, "DPBRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpbrfs_("/", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpbrfs_("U", &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpbrfs_("U", &c__1, &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dpbrfs_("U", &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dpbrfs_("U", &c__2, &c__1, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dpbrfs_("U", &c__2, &c__1, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dpbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dpbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__2, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPBCON */
+
+ s_copy(srnamc_1.srnamt, "DPBCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpbcon_("/", &c__0, &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("DPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpbcon_("U", &c_n1, &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("DPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpbcon_("U", &c__1, &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("DPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dpbcon_("U", &c__2, &c__1, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("DPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPBEQU */
+
+ s_copy(srnamc_1.srnamt, "DPBEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpbequ_("/", &c__0, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("DPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpbequ_("U", &c_n1, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("DPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpbequ_("U", &c__1, &c_n1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("DPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dpbequ_("U", &c__2, &c__1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("DPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of DERRPO */
+
+} /* derrpo_ */
diff --git a/TESTING/LIN/derrpox.c b/TESTING/LIN/derrpox.c
new file mode 100644
index 0000000..50b1587
--- /dev/null
+++ b/TESTING/LIN/derrpox.c
@@ -0,0 +1,656 @@
+/* derrpox.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int derrpo_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal a[16] /* was [4][4] */, b[4];
+ integer i__, j;
+ doublereal s[4], w[12], x[4];
+ char c2[2];
+ doublereal r1[4], r2[4], af[16] /* was [4][4] */;
+ char eq[1];
+ integer iw[4];
+ doublereal err_bnds_c__[12] /* was [4][3] */;
+ integer n_err_bnds__;
+ doublereal err_bnds_n__[12] /* was [4][3] */, berr;
+ integer info;
+ doublereal anrm, rcond;
+ extern /* Subroutine */ int dpbtf2_(char *, integer *, integer *,
+ doublereal *, integer *, integer *), dpotf2_(char *,
+ integer *, doublereal *, integer *, integer *), alaesm_(
+ char *, logical *, integer *), dpbcon_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int dpbequ_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *), dpbrfs_(char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *),
+ dpbtrf_(char *, integer *, integer *, doublereal *, integer *,
+ integer *);
+ doublereal params;
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), dpocon_(char *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *), dppcon_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *), dpoequ_(integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *), dpbtrs_(char *, integer *
+, integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *), dporfs_(char *, integer *, integer
+ *, doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *), dpotrf_(char *,
+ integer *, doublereal *, integer *, integer *), dpotri_(
+ char *, integer *, doublereal *, integer *, integer *),
+ dppequ_(char *, integer *, doublereal *, doublereal *, doublereal
+ *, doublereal *, integer *), dpprfs_(char *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *), dpptrf_(char *, integer *,
+ doublereal *, integer *), dpptri_(char *, integer *,
+ doublereal *, integer *), dpotrs_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *), dpptrs_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *),
+ dpoequb_(integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *);
+ integer nparams;
+ extern /* Subroutine */ int dporfsx_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRPO tests the error exits for the DOUBLE PRECISION routines */
+/* for symmetric positive definite matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
+ af[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
+/* L10: */
+ }
+ b[j - 1] = 0.;
+ r1[j - 1] = 0.;
+ r2[j - 1] = 0.;
+ w[j - 1] = 0.;
+ x[j - 1] = 0.;
+ s[j - 1] = 0.;
+ iw[j - 1] = j;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "PO")) {
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a symmetric positive definite matrix. */
+
+/* DPOTRF */
+
+ s_copy(srnamc_1.srnamt, "DPOTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpotrf_("/", &c__0, a, &c__1, &info);
+ chkxer_("DPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpotrf_("U", &c_n1, a, &c__1, &info);
+ chkxer_("DPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dpotrf_("U", &c__2, a, &c__1, &info);
+ chkxer_("DPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPOTF2 */
+
+ s_copy(srnamc_1.srnamt, "DPOTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpotf2_("/", &c__0, a, &c__1, &info);
+ chkxer_("DPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpotf2_("U", &c_n1, a, &c__1, &info);
+ chkxer_("DPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dpotf2_("U", &c__2, a, &c__1, &info);
+ chkxer_("DPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPOTRI */
+
+ s_copy(srnamc_1.srnamt, "DPOTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpotri_("/", &c__0, a, &c__1, &info);
+ chkxer_("DPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpotri_("U", &c_n1, a, &c__1, &info);
+ chkxer_("DPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dpotri_("U", &c__2, a, &c__1, &info);
+ chkxer_("DPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPOTRS */
+
+ s_copy(srnamc_1.srnamt, "DPOTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpotrs_("/", &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("DPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpotrs_("U", &c_n1, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("DPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpotrs_("U", &c__0, &c_n1, a, &c__1, b, &c__1, &info);
+ chkxer_("DPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dpotrs_("U", &c__2, &c__1, a, &c__1, b, &c__2, &info);
+ chkxer_("DPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dpotrs_("U", &c__2, &c__1, a, &c__2, b, &c__1, &info);
+ chkxer_("DPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPORFS */
+
+ s_copy(srnamc_1.srnamt, "DPORFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dporfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, iw, &info);
+ chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dporfs_("U", &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, iw, &info);
+ chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dporfs_("U", &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, iw, &info);
+ chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dporfs_("U", &c__2, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &c__2,
+ r1, r2, w, iw, &info);
+ chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dporfs_("U", &c__2, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &c__2,
+ r1, r2, w, iw, &info);
+ chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__1, x, &c__2,
+ r1, r2, w, iw, &info);
+ chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__2, x, &c__1,
+ r1, r2, w, iw, &info);
+ chkxer_("DPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPORFSX */
+
+ n_err_bnds__ = 3;
+ nparams = 0;
+ s_copy(srnamc_1.srnamt, "DPORFSX", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ dporfsx_("/", eq, &c__0, &c__0, a, &c__1, af, &c__1, s, b, &c__1, x, &
+ c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, iw, &info);
+ chkxer_("DPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dporfsx_("U", eq, &c_n1, &c__0, a, &c__1, af, &c__1, s, b, &c__1, x, &
+ c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, iw, &info);
+ chkxer_("DPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ *(unsigned char *)eq = 'N';
+ infoc_1.infot = 3;
+ dporfsx_("U", eq, &c_n1, &c__0, a, &c__1, af, &c__1, s, b, &c__1, x, &
+ c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, iw, &info);
+ chkxer_("DPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dporfsx_("U", eq, &c__0, &c_n1, a, &c__1, af, &c__1, s, b, &c__1, x, &
+ c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, iw, &info);
+ chkxer_("DPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dporfsx_("U", eq, &c__2, &c__1, a, &c__1, af, &c__2, s, b, &c__2, x, &
+ c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, iw, &info);
+ chkxer_("DPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dporfsx_("U", eq, &c__2, &c__1, a, &c__2, af, &c__1, s, b, &c__2, x, &
+ c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, iw, &info);
+ chkxer_("DPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dporfsx_("U", eq, &c__2, &c__1, a, &c__2, af, &c__2, s, b, &c__1, x, &
+ c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, iw, &info);
+ chkxer_("DPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ dporfsx_("U", eq, &c__2, &c__1, a, &c__2, af, &c__2, s, b, &c__2, x, &
+ c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, iw, &info);
+ chkxer_("DPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPOCON */
+
+ s_copy(srnamc_1.srnamt, "DPOCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpocon_("/", &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("DPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpocon_("U", &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("DPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dpocon_("U", &c__2, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("DPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPOEQU */
+
+ s_copy(srnamc_1.srnamt, "DPOEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpoequ_(&c_n1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("DPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpoequ_(&c__2, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("DPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPOEQUB */
+
+ s_copy(srnamc_1.srnamt, "DPOEQUB", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ dpoequb_(&c_n1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("DPOEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpoequb_(&c__2, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("DPOEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PP")) {
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a symmetric positive definite packed matrix. */
+
+/* DPPTRF */
+
+ s_copy(srnamc_1.srnamt, "DPPTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpptrf_("/", &c__0, a, &info);
+ chkxer_("DPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpptrf_("U", &c_n1, a, &info);
+ chkxer_("DPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPPTRI */
+
+ s_copy(srnamc_1.srnamt, "DPPTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpptri_("/", &c__0, a, &info);
+ chkxer_("DPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpptri_("U", &c_n1, a, &info);
+ chkxer_("DPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPPTRS */
+
+ s_copy(srnamc_1.srnamt, "DPPTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpptrs_("/", &c__0, &c__0, a, b, &c__1, &info);
+ chkxer_("DPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpptrs_("U", &c_n1, &c__0, a, b, &c__1, &info);
+ chkxer_("DPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpptrs_("U", &c__0, &c_n1, a, b, &c__1, &info);
+ chkxer_("DPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dpptrs_("U", &c__2, &c__1, a, b, &c__1, &info);
+ chkxer_("DPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPPRFS */
+
+ s_copy(srnamc_1.srnamt, "DPPRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpprfs_("/", &c__0, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
+ info);
+ chkxer_("DPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpprfs_("U", &c_n1, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
+ info);
+ chkxer_("DPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpprfs_("U", &c__0, &c_n1, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
+ info);
+ chkxer_("DPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dpprfs_("U", &c__2, &c__1, a, af, b, &c__1, x, &c__2, r1, r2, w, iw, &
+ info);
+ chkxer_("DPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dpprfs_("U", &c__2, &c__1, a, af, b, &c__2, x, &c__1, r1, r2, w, iw, &
+ info);
+ chkxer_("DPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPPCON */
+
+ s_copy(srnamc_1.srnamt, "DPPCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dppcon_("/", &c__0, a, &anrm, &rcond, w, iw, &info);
+ chkxer_("DPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dppcon_("U", &c_n1, a, &anrm, &rcond, w, iw, &info);
+ chkxer_("DPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPPEQU */
+
+ s_copy(srnamc_1.srnamt, "DPPEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dppequ_("/", &c__0, a, r1, &rcond, &anrm, &info);
+ chkxer_("DPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dppequ_("U", &c_n1, a, r1, &rcond, &anrm, &info);
+ chkxer_("DPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a symmetric positive definite band matrix. */
+
+/* DPBTRF */
+
+ s_copy(srnamc_1.srnamt, "DPBTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpbtrf_("/", &c__0, &c__0, a, &c__1, &info);
+ chkxer_("DPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpbtrf_("U", &c_n1, &c__0, a, &c__1, &info);
+ chkxer_("DPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpbtrf_("U", &c__1, &c_n1, a, &c__1, &info);
+ chkxer_("DPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dpbtrf_("U", &c__2, &c__1, a, &c__1, &info);
+ chkxer_("DPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPBTF2 */
+
+ s_copy(srnamc_1.srnamt, "DPBTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpbtf2_("/", &c__0, &c__0, a, &c__1, &info);
+ chkxer_("DPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpbtf2_("U", &c_n1, &c__0, a, &c__1, &info);
+ chkxer_("DPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpbtf2_("U", &c__1, &c_n1, a, &c__1, &info);
+ chkxer_("DPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dpbtf2_("U", &c__2, &c__1, a, &c__1, &info);
+ chkxer_("DPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPBTRS */
+
+ s_copy(srnamc_1.srnamt, "DPBTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpbtrs_("/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpbtrs_("U", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpbtrs_("U", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dpbtrs_("U", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, &info);
+ chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dpbtrs_("U", &c__2, &c__1, &c__1, a, &c__1, b, &c__1, &info);
+ chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dpbtrs_("U", &c__2, &c__0, &c__1, a, &c__1, b, &c__1, &info);
+ chkxer_("DPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPBRFS */
+
+ s_copy(srnamc_1.srnamt, "DPBRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpbrfs_("/", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpbrfs_("U", &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpbrfs_("U", &c__1, &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dpbrfs_("U", &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dpbrfs_("U", &c__2, &c__1, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dpbrfs_("U", &c__2, &c__1, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dpbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dpbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__2, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPBCON */
+
+ s_copy(srnamc_1.srnamt, "DPBCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpbcon_("/", &c__0, &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("DPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpbcon_("U", &c_n1, &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("DPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpbcon_("U", &c__1, &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("DPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dpbcon_("U", &c__2, &c__1, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("DPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPBEQU */
+
+ s_copy(srnamc_1.srnamt, "DPBEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpbequ_("/", &c__0, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("DPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpbequ_("U", &c_n1, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("DPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpbequ_("U", &c__1, &c_n1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("DPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dpbequ_("U", &c__2, &c__1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("DPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of DERRPO */
+
+} /* derrpo_ */
diff --git a/TESTING/LIN/derrps.c b/TESTING/LIN/derrps.c
new file mode 100644
index 0000000..2e95216
--- /dev/null
+++ b/TESTING/LIN/derrps.c
@@ -0,0 +1,166 @@
+/* derrps.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c__1 = 1;
+static doublereal c_b9 = -1.;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int derrps_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal a[16] /* was [4][4] */;
+ integer i__, j, piv[4], info;
+ doublereal work[8];
+ extern /* Subroutine */ int dpstf2_(char *, integer *, doublereal *,
+ integer *, integer *, integer *, doublereal *, doublereal *,
+ integer *), alaesm_(char *, logical *, integer *),
+ chkxer_(char *, integer *, integer *, logical *, logical *), dpstrf_(char *, integer *, doublereal *, integer *,
+ integer *, integer *, doublereal *, doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRPS tests the error exits for the DOUBLE PRECISION routines */
+/* for DPSTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
+
+/* L100: */
+ }
+ piv[j - 1] = j;
+ work[j - 1] = 0.;
+ work[j + 3] = 0.;
+
+/* L110: */
+ }
+ infoc_1.ok = TRUE_;
+
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a symmetric positive semidefinite matrix. */
+
+/* DPSTRF */
+
+ s_copy(srnamc_1.srnamt, "DPSTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpstrf_("/", &c__0, a, &c__1, piv, &c__1, &c_b9, work, &info);
+ chkxer_("DPSTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpstrf_("U", &c_n1, a, &c__1, piv, &c__1, &c_b9, work, &info);
+ chkxer_("DPSTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dpstrf_("U", &c__2, a, &c__1, piv, &c__1, &c_b9, work, &info);
+ chkxer_("DPSTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPSTF2 */
+
+ s_copy(srnamc_1.srnamt, "DPSTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpstf2_("/", &c__0, a, &c__1, piv, &c__1, &c_b9, work, &info);
+ chkxer_("DPSTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpstf2_("U", &c_n1, a, &c__1, piv, &c__1, &c_b9, work, &info);
+ chkxer_("DPSTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dpstf2_("U", &c__2, a, &c__1, piv, &c__1, &c_b9, work, &info);
+ chkxer_("DPSTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of DERRPS */
+
+} /* derrps_ */
diff --git a/TESTING/LIN/derrql.c b/TESTING/LIN/derrql.c
new file mode 100644
index 0000000..2f59d22
--- /dev/null
+++ b/TESTING/LIN/derrql.c
@@ -0,0 +1,376 @@
+/* derrql.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int derrql_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal a[4] /* was [2][2] */, b[2];
+ integer i__, j;
+ doublereal w[2], x[2], af[4] /* was [2][2] */;
+ integer info;
+ extern /* Subroutine */ int dgeql2_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *), dorg2l_(
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dorm2l_(char *, char *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *), alaesm_(char *, logical *, integer *),
+ dgeqlf_(integer *, integer *, doublereal *, integer *, doublereal
+ *, doublereal *, integer *, integer *), dgeqls_(integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *),
+ chkxer_(char *, integer *, integer *, logical *, logical *), dorgql_(integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *),
+ dormql_(char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRQL tests the error exits for the DOUBLE PRECISION routines */
+/* that use the QL decomposition of a general matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 2; ++j) {
+ for (i__ = 1; i__ <= 2; ++i__) {
+ a[i__ + (j << 1) - 3] = 1. / (doublereal) (i__ + j);
+ af[i__ + (j << 1) - 3] = 1. / (doublereal) (i__ + j);
+/* L10: */
+ }
+ b[j - 1] = 0.;
+ w[j - 1] = 0.;
+ x[j - 1] = 0.;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+/* Error exits for QL factorization */
+
+/* DGEQLF */
+
+ s_copy(srnamc_1.srnamt, "DGEQLF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgeqlf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
+ chkxer_("DGEQLF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgeqlf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("DGEQLF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgeqlf_(&c__2, &c__1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("DGEQLF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dgeqlf_(&c__1, &c__2, a, &c__1, b, w, &c__1, &info);
+ chkxer_("DGEQLF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGEQL2 */
+
+ s_copy(srnamc_1.srnamt, "DGEQL2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgeql2_(&c_n1, &c__0, a, &c__1, b, w, &info);
+ chkxer_("DGEQL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgeql2_(&c__0, &c_n1, a, &c__1, b, w, &info);
+ chkxer_("DGEQL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgeql2_(&c__2, &c__1, a, &c__1, b, w, &info);
+ chkxer_("DGEQL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGEQLS */
+
+ s_copy(srnamc_1.srnamt, "DGEQLS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgeqls_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("DGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgeqls_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("DGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgeqls_(&c__1, &c__2, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("DGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgeqls_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("DGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgeqls_(&c__2, &c__1, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
+ chkxer_("DGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dgeqls_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
+ chkxer_("DGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dgeqls_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("DGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DORGQL */
+
+ s_copy(srnamc_1.srnamt, "DORGQL", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dorgql_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("DORGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dorgql_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("DORGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dorgql_(&c__1, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
+ chkxer_("DORGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorgql_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
+ chkxer_("DORGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorgql_(&c__1, &c__1, &c__2, a, &c__1, x, w, &c__1, &info);
+ chkxer_("DORGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dorgql_(&c__2, &c__1, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("DORGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dorgql_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
+ chkxer_("DORGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DORG2L */
+
+ s_copy(srnamc_1.srnamt, "DORG2L", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dorg2l_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
+ chkxer_("DORG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dorg2l_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("DORG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dorg2l_(&c__1, &c__2, &c__0, a, &c__1, x, w, &info);
+ chkxer_("DORG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorg2l_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
+ chkxer_("DORG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorg2l_(&c__2, &c__1, &c__2, a, &c__2, x, w, &info);
+ chkxer_("DORG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dorg2l_(&c__2, &c__1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("DORG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DORMQL */
+
+ s_copy(srnamc_1.srnamt, "DORMQL", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dormql_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dormql_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dormql_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dormql_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dormql_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dormql_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dormql_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dormql_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("DORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dormql_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dormql_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dormql_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dormql_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("DORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DORM2L */
+
+ s_copy(srnamc_1.srnamt, "DORM2L", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dorm2l_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dorm2l_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorm2l_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dorm2l_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dorm2l_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dorm2l_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dorm2l_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dorm2l_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &info);
+ chkxer_("DORM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dorm2l_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dorm2l_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &info);
+ chkxer_("DORM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of DERRQL */
+
+} /* derrql_ */
diff --git a/TESTING/LIN/derrqp.c b/TESTING/LIN/derrqp.c
new file mode 100644
index 0000000..1b27ba8
--- /dev/null
+++ b/TESTING/LIN/derrqp.c
@@ -0,0 +1,169 @@
+/* derrqp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int derrqp_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal a[9] /* was [3][3] */, w[10];
+ char c2[2];
+ integer ip[3], lw;
+ doublereal tau[3];
+ integer info;
+ extern /* Subroutine */ int dgeqp3_(integer *, integer *, doublereal *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ integer *), alaesm_(char *, logical *, integer *),
+ dgeqpf_(integer *, integer *, doublereal *, integer *, integer *,
+ doublereal *, doublereal *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRQP tests the error exits for DGEQPF and DGEQP3. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ lw = 10;
+ a[0] = 1.;
+ a[3] = 2.;
+ a[4] = 3.;
+ a[1] = 4.;
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "QP")) {
+
+/* Test error exits for QR factorization with pivoting */
+
+/* DGEQPF */
+
+ s_copy(srnamc_1.srnamt, "DGEQPF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgeqpf_(&c_n1, &c__0, a, &c__1, ip, tau, w, &info);
+ chkxer_("DGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgeqpf_(&c__0, &c_n1, a, &c__1, ip, tau, w, &info);
+ chkxer_("DGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgeqpf_(&c__2, &c__0, a, &c__1, ip, tau, w, &info);
+ chkxer_("DGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGEQP3 */
+
+ s_copy(srnamc_1.srnamt, "DGEQP3", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgeqp3_(&c_n1, &c__0, a, &c__1, ip, tau, w, &lw, &info);
+ chkxer_("DGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgeqp3_(&c__1, &c_n1, a, &c__1, ip, tau, w, &lw, &info);
+ chkxer_("DGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgeqp3_(&c__2, &c__3, a, &c__1, ip, tau, w, &lw, &info);
+ chkxer_("DGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ i__1 = lw - 10;
+ dgeqp3_(&c__2, &c__2, a, &c__2, ip, tau, w, &i__1, &info);
+ chkxer_("DGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of DERRQP */
+
+} /* derrqp_ */
diff --git a/TESTING/LIN/derrqr.c b/TESTING/LIN/derrqr.c
new file mode 100644
index 0000000..ea2c63f
--- /dev/null
+++ b/TESTING/LIN/derrqr.c
@@ -0,0 +1,377 @@
+/* derrqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int derrqr_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal a[4] /* was [2][2] */, b[2];
+ integer i__, j;
+ doublereal w[2], x[2], af[4] /* was [2][2] */;
+ integer info;
+ extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *), dorg2r_(
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dorm2r_(char *, char *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *), alaesm_(char *, logical *, integer *),
+ dgeqrf_(integer *, integer *, doublereal *, integer *, doublereal
+ *, doublereal *, integer *, integer *), chkxer_(char *, integer *,
+ integer *, logical *, logical *), dgeqrs_(integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *),
+ dorgqr_(integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *), dormqr_(char *,
+ char *, integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRQR tests the error exits for the DOUBLE PRECISION routines */
+/* that use the QR decomposition of a general matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 2; ++j) {
+ for (i__ = 1; i__ <= 2; ++i__) {
+ a[i__ + (j << 1) - 3] = 1. / (doublereal) (i__ + j);
+ af[i__ + (j << 1) - 3] = 1. / (doublereal) (i__ + j);
+/* L10: */
+ }
+ b[j - 1] = 0.;
+ w[j - 1] = 0.;
+ x[j - 1] = 0.;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+/* Error exits for QR factorization */
+
+/* DGEQRF */
+
+ s_copy(srnamc_1.srnamt, "DGEQRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgeqrf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
+ chkxer_("DGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgeqrf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("DGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgeqrf_(&c__2, &c__1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("DGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dgeqrf_(&c__1, &c__2, a, &c__1, b, w, &c__1, &info);
+ chkxer_("DGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGEQR2 */
+
+ s_copy(srnamc_1.srnamt, "DGEQR2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgeqr2_(&c_n1, &c__0, a, &c__1, b, w, &info);
+ chkxer_("DGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgeqr2_(&c__0, &c_n1, a, &c__1, b, w, &info);
+ chkxer_("DGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgeqr2_(&c__2, &c__1, a, &c__1, b, w, &info);
+ chkxer_("DGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGEQRS */
+
+ s_copy(srnamc_1.srnamt, "DGEQRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgeqrs_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("DGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgeqrs_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("DGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgeqrs_(&c__1, &c__2, &c__0, a, &c__2, x, b, &c__2, w, &c__1, &info);
+ chkxer_("DGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgeqrs_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("DGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgeqrs_(&c__2, &c__1, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
+ chkxer_("DGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dgeqrs_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
+ chkxer_("DGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dgeqrs_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("DGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DORGQR */
+
+ s_copy(srnamc_1.srnamt, "DORGQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dorgqr_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("DORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dorgqr_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("DORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dorgqr_(&c__1, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
+ chkxer_("DORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorgqr_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
+ chkxer_("DORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorgqr_(&c__1, &c__1, &c__2, a, &c__1, x, w, &c__1, &info);
+ chkxer_("DORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dorgqr_(&c__2, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
+ chkxer_("DORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dorgqr_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
+ chkxer_("DORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DORG2R */
+
+ s_copy(srnamc_1.srnamt, "DORG2R", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dorg2r_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
+ chkxer_("DORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dorg2r_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("DORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dorg2r_(&c__1, &c__2, &c__0, a, &c__1, x, w, &info);
+ chkxer_("DORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorg2r_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
+ chkxer_("DORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorg2r_(&c__2, &c__1, &c__2, a, &c__2, x, w, &info);
+ chkxer_("DORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dorg2r_(&c__2, &c__1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("DORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DORMQR */
+
+ s_copy(srnamc_1.srnamt, "DORMQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dormqr_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dormqr_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dormqr_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dormqr_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dormqr_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dormqr_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dormqr_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dormqr_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dormqr_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dormqr_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dormqr_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dormqr_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("DORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DORM2R */
+
+ s_copy(srnamc_1.srnamt, "DORM2R", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dorm2r_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dorm2r_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorm2r_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dorm2r_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dorm2r_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dorm2r_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dorm2r_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dorm2r_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &info);
+ chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dorm2r_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dorm2r_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &info);
+ chkxer_("DORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of DERRQR */
+
+} /* derrqr_ */
diff --git a/TESTING/LIN/derrrfp.c b/TESTING/LIN/derrrfp.c
new file mode 100644
index 0000000..da06df0
--- /dev/null
+++ b/TESTING/LIN/derrrfp.c
@@ -0,0 +1,357 @@
+/* derrrfp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+
+/* Subroutine */ int derrrfp_(integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002DOUBLE PRECISION RFP routines passed t"
+ "he tests of \002,\002the error exits\002)";
+ static char fmt_9998[] = "(\002 *** RFP routines failed the tests of the"
+ " error \002,\002exits ***\002)";
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), e_wsfe(void);
+
+ /* Local variables */
+ doublereal a[1] /* was [1][1] */, b[1] /* was [1][1] */, beta;
+ integer info;
+ doublereal alpha;
+ extern /* Subroutine */ int dsfrk_(char *, char *, char *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *), dtfsm_(char *, char *,
+ char *, char *, char *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *), chkxer_(char *, integer *, integer *, logical *,
+ logical *), dpftrf_(char *, char *, integer *, doublereal
+ *, integer *), dpftri_(char *, char *, integer *,
+ doublereal *, integer *), dtftri_(char *, char *,
+ char *, integer *, doublereal *, integer *), dpftrs_(char *, char *, integer *, integer *, doublereal
+ *, doublereal *, integer *, integer *), dtfttp_(
+ char *, char *, integer *, doublereal *, doublereal *, integer *), dtpttf_(char *, char *, integer *, doublereal *,
+ doublereal *, integer *), dtfttr_(char *, char *,
+ integer *, doublereal *, doublereal *, integer *, integer *), dtrttf_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *, integer *), dtpttr_(char
+ *, integer *, doublereal *, doublereal *, integer *, integer *), dtrttp_(char *, integer *, doublereal *, integer *,
+ doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___7 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRRFP tests the error exits for the DOUBLE PRECISION driver routines */
+/* for solving linear systems of equations. */
+
+/* DDRVRFP tests the DOUBLE PRECISION LAPACK RFP routines: */
+/* DTFSM, DTFTRI, DSFRK, DTFTTP, DTFTTR, DPFTRF, DPFTRS, DTPTTF, */
+/* DTPTTR, DTRTTF, and DTRTTP */
+
+/* Arguments */
+/* ========= */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ infoc_1.ok = TRUE_;
+ a[0] = 1.;
+ b[0] = 1.;
+ alpha = 1.;
+ beta = 1.;
+
+ s_copy(srnamc_1.srnamt, "DPFTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpftrf_("/", "U", &c__0, a, &info);
+ chkxer_("DPFTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpftrf_("N", "/", &c__0, a, &info);
+ chkxer_("DPFTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpftrf_("N", "U", &c_n1, a, &info);
+ chkxer_("DPFTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "DPFTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpftrs_("/", "U", &c__0, &c__0, a, b, &c__1, &info);
+ chkxer_("DPFTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpftrs_("N", "/", &c__0, &c__0, a, b, &c__1, &info);
+ chkxer_("DPFTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpftrs_("N", "U", &c_n1, &c__0, a, b, &c__1, &info);
+ chkxer_("DPFTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dpftrs_("N", "U", &c__0, &c_n1, a, b, &c__1, &info);
+ chkxer_("DPFTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dpftrs_("N", "U", &c__0, &c__0, a, b, &c__0, &info);
+ chkxer_("DPFTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "DPFTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpftri_("/", "U", &c__0, a, &info);
+ chkxer_("DPFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpftri_("N", "/", &c__0, a, &info);
+ chkxer_("DPFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpftri_("N", "U", &c_n1, a, &info);
+ chkxer_("DPFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "DTFSM ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtfsm_("/", "L", "U", "T", "U", &c__0, &c__0, &alpha, a, b, &c__1);
+ chkxer_("DTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtfsm_("N", "/", "U", "T", "U", &c__0, &c__0, &alpha, a, b, &c__1);
+ chkxer_("DTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dtfsm_("N", "L", "/", "T", "U", &c__0, &c__0, &alpha, a, b, &c__1);
+ chkxer_("DTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dtfsm_("N", "L", "U", "/", "U", &c__0, &c__0, &alpha, a, b, &c__1);
+ chkxer_("DTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dtfsm_("N", "L", "U", "T", "/", &c__0, &c__0, &alpha, a, b, &c__1);
+ chkxer_("DTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dtfsm_("N", "L", "U", "T", "U", &c_n1, &c__0, &alpha, a, b, &c__1);
+ chkxer_("DTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dtfsm_("N", "L", "U", "T", "U", &c__0, &c_n1, &alpha, a, b, &c__1);
+ chkxer_("DTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dtfsm_("N", "L", "U", "T", "U", &c__0, &c__0, &alpha, a, b, &c__0);
+ chkxer_("DTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "DTFTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtftri_("/", "L", "N", &c__0, a, &info);
+ chkxer_("DTFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtftri_("N", "/", "N", &c__0, a, &info);
+ chkxer_("DTFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dtftri_("N", "L", "/", &c__0, a, &info);
+ chkxer_("DTFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dtftri_("N", "L", "N", &c_n1, a, &info);
+ chkxer_("DTFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "DTFTTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtfttr_("/", "U", &c__0, a, b, &c__1, &info);
+ chkxer_("DTFTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtfttr_("N", "/", &c__0, a, b, &c__1, &info);
+ chkxer_("DTFTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dtfttr_("N", "U", &c_n1, a, b, &c__1, &info);
+ chkxer_("DTFTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dtfttr_("N", "U", &c__0, a, b, &c__0, &info);
+ chkxer_("DTFTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "DTRTTF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtrttf_("/", "U", &c__0, a, &c__1, b, &info);
+ chkxer_("DTRTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtrttf_("N", "/", &c__0, a, &c__1, b, &info);
+ chkxer_("DTRTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dtrttf_("N", "U", &c_n1, a, &c__1, b, &info);
+ chkxer_("DTRTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dtrttf_("N", "U", &c__0, a, &c__0, b, &info);
+ chkxer_("DTRTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "DTFTTP", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtfttp_("/", "U", &c__0, a, b, &info);
+ chkxer_("DTFTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtfttp_("N", "/", &c__0, a, b, &info);
+ chkxer_("DTFTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dtfttp_("N", "U", &c_n1, a, b, &info);
+ chkxer_("DTFTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "DTPTTF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtpttf_("/", "U", &c__0, a, b, &info);
+ chkxer_("DTPTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtpttf_("N", "/", &c__0, a, b, &info);
+ chkxer_("DTPTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dtpttf_("N", "U", &c_n1, a, b, &info);
+ chkxer_("DTPTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "DTRTTP", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtrttp_("/", &c__0, a, &c__1, b, &info);
+ chkxer_("DTRTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtrttp_("U", &c_n1, a, &c__1, b, &info);
+ chkxer_("DTRTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dtrttp_("U", &c__0, a, &c__0, b, &info);
+ chkxer_("DTRTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "DTPTTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtpttr_("/", &c__0, a, b, &c__1, &info);
+ chkxer_("DTPTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtpttr_("U", &c_n1, a, b, &c__1, &info);
+ chkxer_("DTPTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dtpttr_("U", &c__0, a, b, &c__0, &info);
+ chkxer_("DTPTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "DSFRK ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsfrk_("/", "U", "N", &c__0, &c__0, &alpha, a, &c__1, &beta, b);
+ chkxer_("DSFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsfrk_("N", "/", "N", &c__0, &c__0, &alpha, a, &c__1, &beta, b);
+ chkxer_("DSFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dsfrk_("N", "U", "/", &c__0, &c__0, &alpha, a, &c__1, &beta, b);
+ chkxer_("DSFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dsfrk_("N", "U", "N", &c_n1, &c__0, &alpha, a, &c__1, &beta, b);
+ chkxer_("DSFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dsfrk_("N", "U", "N", &c__0, &c_n1, &alpha, a, &c__1, &beta, b);
+ chkxer_("DSFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dsfrk_("N", "U", "N", &c__0, &c__0, &alpha, a, &c__0, &beta, b);
+ chkxer_("DSFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___6.ciunit = infoc_1.nout;
+ s_wsfe(&io___6);
+ e_wsfe();
+ } else {
+ io___7.ciunit = infoc_1.nout;
+ s_wsfe(&io___7);
+ e_wsfe();
+ }
+
+ return 0;
+
+/* End of DERRRFP */
+
+} /* derrrfp_ */
diff --git a/TESTING/LIN/derrrq.c b/TESTING/LIN/derrrq.c
new file mode 100644
index 0000000..98ab29b
--- /dev/null
+++ b/TESTING/LIN/derrrq.c
@@ -0,0 +1,377 @@
+/* derrrq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int derrrq_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal a[4] /* was [2][2] */, b[2];
+ integer i__, j;
+ doublereal w[2], x[2], af[4] /* was [2][2] */;
+ integer info;
+ extern /* Subroutine */ int dgerq2_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *), dorgr2_(
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dormr2_(char *, char *,
+ integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *), alaesm_(char *, logical *, integer *),
+ dgerqf_(integer *, integer *, doublereal *, integer *, doublereal
+ *, doublereal *, integer *, integer *), chkxer_(char *, integer *,
+ integer *, logical *, logical *), dgerqs_(integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *),
+ dorgrq_(integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *), dormrq_(char *,
+ char *, integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRRQ tests the error exits for the DOUBLE PRECISION routines */
+/* that use the RQ decomposition of a general matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 2; ++j) {
+ for (i__ = 1; i__ <= 2; ++i__) {
+ a[i__ + (j << 1) - 3] = 1. / (doublereal) (i__ + j);
+ af[i__ + (j << 1) - 3] = 1. / (doublereal) (i__ + j);
+/* L10: */
+ }
+ b[j - 1] = 0.;
+ w[j - 1] = 0.;
+ x[j - 1] = 0.;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+/* Error exits for RQ factorization */
+
+/* DGERQF */
+
+ s_copy(srnamc_1.srnamt, "DGERQF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgerqf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
+ chkxer_("DGERQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgerqf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("DGERQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgerqf_(&c__2, &c__1, a, &c__1, b, w, &c__2, &info);
+ chkxer_("DGERQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dgerqf_(&c__2, &c__1, a, &c__2, b, w, &c__1, &info);
+ chkxer_("DGERQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGERQ2 */
+
+ s_copy(srnamc_1.srnamt, "DGERQ2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgerq2_(&c_n1, &c__0, a, &c__1, b, w, &info);
+ chkxer_("DGERQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgerq2_(&c__0, &c_n1, a, &c__1, b, w, &info);
+ chkxer_("DGERQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgerq2_(&c__2, &c__1, a, &c__1, b, w, &info);
+ chkxer_("DGERQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGERQS */
+
+ s_copy(srnamc_1.srnamt, "DGERQS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgerqs_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("DGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgerqs_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("DGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgerqs_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
+ chkxer_("DGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgerqs_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("DGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgerqs_(&c__2, &c__2, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
+ chkxer_("DGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dgerqs_(&c__2, &c__2, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
+ chkxer_("DGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dgerqs_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("DGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DORGRQ */
+
+ s_copy(srnamc_1.srnamt, "DORGRQ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dorgrq_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("DORGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dorgrq_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("DORGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dorgrq_(&c__2, &c__1, &c__0, a, &c__2, x, w, &c__2, &info);
+ chkxer_("DORGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorgrq_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
+ chkxer_("DORGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorgrq_(&c__1, &c__2, &c__2, a, &c__1, x, w, &c__1, &info);
+ chkxer_("DORGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dorgrq_(&c__2, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
+ chkxer_("DORGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dorgrq_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
+ chkxer_("DORGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DORGR2 */
+
+ s_copy(srnamc_1.srnamt, "DORGR2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dorgr2_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
+ chkxer_("DORGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dorgr2_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("DORGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dorgr2_(&c__2, &c__1, &c__0, a, &c__2, x, w, &info);
+ chkxer_("DORGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorgr2_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
+ chkxer_("DORGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dorgr2_(&c__1, &c__2, &c__2, a, &c__2, x, w, &info);
+ chkxer_("DORGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dorgr2_(&c__2, &c__2, &c__0, a, &c__1, x, w, &info);
+ chkxer_("DORGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DORMRQ */
+
+ s_copy(srnamc_1.srnamt, "DORMRQ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dormrq_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dormrq_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dormrq_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dormrq_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dormrq_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dormrq_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dormrq_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dormrq_("L", "N", &c__2, &c__1, &c__2, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("DORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dormrq_("R", "N", &c__1, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dormrq_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dormrq_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("DORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dormrq_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("DORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DORMR2 */
+
+ s_copy(srnamc_1.srnamt, "DORMR2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dormr2_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dormr2_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dormr2_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dormr2_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dormr2_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dormr2_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dormr2_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dormr2_("L", "N", &c__2, &c__1, &c__2, a, &c__1, x, af, &c__2, w, &info);
+ chkxer_("DORMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dormr2_("R", "N", &c__1, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dormr2_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("DORMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of DERRRQ */
+
+} /* derrrq_ */
diff --git a/TESTING/LIN/derrsy.c b/TESTING/LIN/derrsy.c
new file mode 100644
index 0000000..974bd64
--- /dev/null
+++ b/TESTING/LIN/derrsy.c
@@ -0,0 +1,392 @@
+/* derrsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__4 = 4;
+static doublereal c_b152 = -1.;
+
+/* Subroutine */ int derrsy_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal a[16] /* was [4][4] */, b[4];
+ integer i__, j;
+ doublereal w[12], x[4];
+ char c2[2];
+ doublereal r1[4], r2[4], af[16] /* was [4][4] */;
+ integer ip[4], iw[4], info;
+ doublereal anrm, rcond;
+ extern /* Subroutine */ int dsytf2_(char *, integer *, doublereal *,
+ integer *, integer *, integer *), alaesm_(char *, logical
+ *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), dspcon_(char *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *), dsycon_(char *, integer *, doublereal *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *), dsprfs_(char *, integer *, integer
+ *, doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *
+, integer *, integer *), dsptrf_(char *, integer *,
+ doublereal *, integer *, integer *), dsptri_(char *,
+ integer *, doublereal *, integer *, doublereal *, integer *), dsyrfs_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *), dsytrf_(char *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), dsytri_(char *, integer *,
+ doublereal *, integer *, integer *, doublereal *, integer *), dsptrs_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *, integer *), dsytrs_(
+ char *, integer *, integer *, doublereal *, integer *, integer *,
+ doublereal *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRSY tests the error exits for the DOUBLE PRECISION routines */
+/* for symmetric indefinite matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
+ af[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
+/* L10: */
+ }
+ b[j - 1] = 0.;
+ r1[j - 1] = 0.;
+ r2[j - 1] = 0.;
+ w[j - 1] = 0.;
+ x[j - 1] = 0.;
+ ip[j - 1] = j;
+ iw[j - 1] = j;
+/* L20: */
+ }
+ anrm = 1.;
+ rcond = 1.;
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "SY")) {
+
+/* Test error exits of the routines that use the Bunch-Kaufman */
+/* factorization of a symmetric indefinite matrix. */
+
+/* DSYTRF */
+
+ s_copy(srnamc_1.srnamt, "DSYTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsytrf_("/", &c__0, a, &c__1, ip, w, &c__1, &info);
+ chkxer_("DSYTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsytrf_("U", &c_n1, a, &c__1, ip, w, &c__1, &info);
+ chkxer_("DSYTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dsytrf_("U", &c__2, a, &c__1, ip, w, &c__4, &info);
+ chkxer_("DSYTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DSYTF2 */
+
+ s_copy(srnamc_1.srnamt, "DSYTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsytf2_("/", &c__0, a, &c__1, ip, &info);
+ chkxer_("DSYTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsytf2_("U", &c_n1, a, &c__1, ip, &info);
+ chkxer_("DSYTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dsytf2_("U", &c__2, a, &c__1, ip, &info);
+ chkxer_("DSYTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DSYTRI */
+
+ s_copy(srnamc_1.srnamt, "DSYTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsytri_("/", &c__0, a, &c__1, ip, w, &info);
+ chkxer_("DSYTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsytri_("U", &c_n1, a, &c__1, ip, w, &info);
+ chkxer_("DSYTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dsytri_("U", &c__2, a, &c__1, ip, w, &info);
+ chkxer_("DSYTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DSYTRS */
+
+ s_copy(srnamc_1.srnamt, "DSYTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsytrs_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("DSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsytrs_("U", &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("DSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dsytrs_("U", &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("DSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dsytrs_("U", &c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
+ chkxer_("DSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dsytrs_("U", &c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
+ chkxer_("DSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DSYRFS */
+
+ s_copy(srnamc_1.srnamt, "DSYRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsyrfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsyrfs_("U", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dsyrfs_("U", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dsyrfs_("U", &c__2, &c__1, a, &c__1, af, &c__2, ip, b, &c__2, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("DSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dsyrfs_("U", &c__2, &c__1, a, &c__2, af, &c__1, ip, b, &c__2, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("DSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dsyrfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__1, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("DSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dsyrfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__2, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DSYCON */
+
+ s_copy(srnamc_1.srnamt, "DSYCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsycon_("/", &c__0, a, &c__1, ip, &anrm, &rcond, w, iw, &info);
+ chkxer_("DSYCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsycon_("U", &c_n1, a, &c__1, ip, &anrm, &rcond, w, iw, &info);
+ chkxer_("DSYCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dsycon_("U", &c__2, a, &c__1, ip, &anrm, &rcond, w, iw, &info);
+ chkxer_("DSYCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dsycon_("U", &c__1, a, &c__1, ip, &c_b152, &rcond, w, iw, &info);
+ chkxer_("DSYCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "SP")) {
+
+/* Test error exits of the routines that use the Bunch-Kaufman */
+/* factorization of a symmetric indefinite packed matrix. */
+
+/* DSPTRF */
+
+ s_copy(srnamc_1.srnamt, "DSPTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsptrf_("/", &c__0, a, ip, &info);
+ chkxer_("DSPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsptrf_("U", &c_n1, a, ip, &info);
+ chkxer_("DSPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DSPTRI */
+
+ s_copy(srnamc_1.srnamt, "DSPTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsptri_("/", &c__0, a, ip, w, &info);
+ chkxer_("DSPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsptri_("U", &c_n1, a, ip, w, &info);
+ chkxer_("DSPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DSPTRS */
+
+ s_copy(srnamc_1.srnamt, "DSPTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsptrs_("/", &c__0, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("DSPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsptrs_("U", &c_n1, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("DSPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dsptrs_("U", &c__0, &c_n1, a, ip, b, &c__1, &info);
+ chkxer_("DSPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dsptrs_("U", &c__2, &c__1, a, ip, b, &c__1, &info);
+ chkxer_("DSPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DSPRFS */
+
+ s_copy(srnamc_1.srnamt, "DSPRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsprfs_("/", &c__0, &c__0, a, af, ip, b, &c__1, x, &c__1, r1, r2, w,
+ iw, &info);
+ chkxer_("DSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsprfs_("U", &c_n1, &c__0, a, af, ip, b, &c__1, x, &c__1, r1, r2, w,
+ iw, &info);
+ chkxer_("DSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dsprfs_("U", &c__0, &c_n1, a, af, ip, b, &c__1, x, &c__1, r1, r2, w,
+ iw, &info);
+ chkxer_("DSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dsprfs_("U", &c__2, &c__1, a, af, ip, b, &c__1, x, &c__2, r1, r2, w,
+ iw, &info);
+ chkxer_("DSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dsprfs_("U", &c__2, &c__1, a, af, ip, b, &c__2, x, &c__1, r1, r2, w,
+ iw, &info);
+ chkxer_("DSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DSPCON */
+
+ s_copy(srnamc_1.srnamt, "DSPCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dspcon_("/", &c__0, a, ip, &anrm, &rcond, w, iw, &info);
+ chkxer_("DSPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dspcon_("U", &c_n1, a, ip, &anrm, &rcond, w, iw, &info);
+ chkxer_("DSPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dspcon_("U", &c__1, a, ip, &c_b152, &rcond, w, iw, &info);
+ chkxer_("DSPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of DERRSY */
+
+} /* derrsy_ */
diff --git a/TESTING/LIN/derrtr.c b/TESTING/LIN/derrtr.c
new file mode 100644
index 0000000..49ef2d2
--- /dev/null
+++ b/TESTING/LIN/derrtr.c
@@ -0,0 +1,609 @@
+/* derrtr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int derrtr_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal a[4] /* was [2][2] */, b[2], w[2], x[2];
+ char c2[2];
+ doublereal r1[2], r2[2];
+ integer iw[2], info;
+ doublereal scale, rcond;
+ extern /* Subroutine */ int dtrti2_(char *, char *, integer *, doublereal
+ *, integer *, integer *), alaesm_(char *, logical
+ *, integer *), dlatbs_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *), dtbcon_(char *, char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), dtbrfs_(char *, char *, char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, integer *),
+ dlatps_(char *, char *, char *, char *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *), dtpcon_(char *, char *, char *, integer *
+, doublereal *, doublereal *, doublereal *, integer *, integer *), dlatrs_(char *, char *, char *, char *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), dtrcon_(
+ char *, char *, char *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *), dtbtrs_(char *, char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *), dtprfs_(char *, char *, char *
+, integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *), dtrrfs_(char *,
+ char *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *), dtptri_(char *, char *, integer *, doublereal *, integer
+ *), dtrtri_(char *, char *, integer *, doublereal
+ *, integer *, integer *), dtptrs_(char *, char *,
+ char *, integer *, integer *, doublereal *, doublereal *, integer
+ *, integer *), dtrtrs_(char *, char *,
+ char *, integer *, integer *, doublereal *, integer *, doublereal
+ *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRTR tests the error exits for the DOUBLE PRECISION triangular */
+/* routines. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ a[0] = 1.;
+ a[2] = 2.;
+ a[3] = 3.;
+ a[1] = 4.;
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "TR")) {
+
+/* Test error exits for the general triangular routines. */
+
+/* DTRTRI */
+
+ s_copy(srnamc_1.srnamt, "DTRTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtrtri_("/", "N", &c__0, a, &c__1, &info);
+ chkxer_("DTRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtrtri_("U", "/", &c__0, a, &c__1, &info);
+ chkxer_("DTRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dtrtri_("U", "N", &c_n1, a, &c__1, &info);
+ chkxer_("DTRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dtrtri_("U", "N", &c__2, a, &c__1, &info);
+ chkxer_("DTRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DTRTI2 */
+
+ s_copy(srnamc_1.srnamt, "DTRTI2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtrti2_("/", "N", &c__0, a, &c__1, &info);
+ chkxer_("DTRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtrti2_("U", "/", &c__0, a, &c__1, &info);
+ chkxer_("DTRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dtrti2_("U", "N", &c_n1, a, &c__1, &info);
+ chkxer_("DTRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dtrti2_("U", "N", &c__2, a, &c__1, &info);
+ chkxer_("DTRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DTRTRS */
+
+ s_copy(srnamc_1.srnamt, "DTRTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtrtrs_("/", "N", "N", &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("DTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtrtrs_("U", "/", "N", &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("DTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dtrtrs_("U", "N", "/", &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("DTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dtrtrs_("U", "N", "N", &c_n1, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("DTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dtrtrs_("U", "N", "N", &c__0, &c_n1, a, &c__1, x, &c__1, &info);
+ chkxer_("DTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dtrtrs_("U", "N", "N", &c__2, &c__1, a, &c__1, x, &c__2, &info);
+ chkxer_("DTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dtrtrs_("U", "N", "N", &c__2, &c__1, a, &c__2, x, &c__1, &info);
+ chkxer_("DTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DTRRFS */
+
+ s_copy(srnamc_1.srnamt, "DTRRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtrrfs_("/", "N", "N", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
+ r2, w, iw, &info);
+ chkxer_("DTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtrrfs_("U", "/", "N", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
+ r2, w, iw, &info);
+ chkxer_("DTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dtrrfs_("U", "N", "/", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
+ r2, w, iw, &info);
+ chkxer_("DTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dtrrfs_("U", "N", "N", &c_n1, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
+ r2, w, iw, &info);
+ chkxer_("DTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dtrrfs_("U", "N", "N", &c__0, &c_n1, a, &c__1, b, &c__1, x, &c__1, r1,
+ r2, w, iw, &info);
+ chkxer_("DTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dtrrfs_("U", "N", "N", &c__2, &c__1, a, &c__1, b, &c__2, x, &c__2, r1,
+ r2, w, iw, &info);
+ chkxer_("DTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dtrrfs_("U", "N", "N", &c__2, &c__1, a, &c__2, b, &c__1, x, &c__2, r1,
+ r2, w, iw, &info);
+ chkxer_("DTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dtrrfs_("U", "N", "N", &c__2, &c__1, a, &c__2, b, &c__2, x, &c__1, r1,
+ r2, w, iw, &info);
+ chkxer_("DTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DTRCON */
+
+ s_copy(srnamc_1.srnamt, "DTRCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtrcon_("/", "U", "N", &c__0, a, &c__1, &rcond, w, iw, &info);
+ chkxer_("DTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtrcon_("1", "/", "N", &c__0, a, &c__1, &rcond, w, iw, &info);
+ chkxer_("DTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dtrcon_("1", "U", "/", &c__0, a, &c__1, &rcond, w, iw, &info);
+ chkxer_("DTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dtrcon_("1", "U", "N", &c_n1, a, &c__1, &rcond, w, iw, &info);
+ chkxer_("DTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dtrcon_("1", "U", "N", &c__2, a, &c__1, &rcond, w, iw, &info);
+ chkxer_("DTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DLATRS */
+
+ s_copy(srnamc_1.srnamt, "DLATRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dlatrs_("/", "N", "N", "N", &c__0, a, &c__1, x, &scale, w, &info);
+ chkxer_("DLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dlatrs_("U", "/", "N", "N", &c__0, a, &c__1, x, &scale, w, &info);
+ chkxer_("DLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dlatrs_("U", "N", "/", "N", &c__0, a, &c__1, x, &scale, w, &info);
+ chkxer_("DLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dlatrs_("U", "N", "N", "/", &c__0, a, &c__1, x, &scale, w, &info);
+ chkxer_("DLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dlatrs_("U", "N", "N", "N", &c_n1, a, &c__1, x, &scale, w, &info);
+ chkxer_("DLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dlatrs_("U", "N", "N", "N", &c__2, a, &c__1, x, &scale, w, &info);
+ chkxer_("DLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "TP")) {
+
+/* Test error exits for the packed triangular routines. */
+
+/* DTPTRI */
+
+ s_copy(srnamc_1.srnamt, "DTPTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtptri_("/", "N", &c__0, a, &info);
+ chkxer_("DTPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtptri_("U", "/", &c__0, a, &info);
+ chkxer_("DTPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dtptri_("U", "N", &c_n1, a, &info);
+ chkxer_("DTPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DTPTRS */
+
+ s_copy(srnamc_1.srnamt, "DTPTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtptrs_("/", "N", "N", &c__0, &c__0, a, x, &c__1, &info);
+ chkxer_("DTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtptrs_("U", "/", "N", &c__0, &c__0, a, x, &c__1, &info);
+ chkxer_("DTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dtptrs_("U", "N", "/", &c__0, &c__0, a, x, &c__1, &info);
+ chkxer_("DTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dtptrs_("U", "N", "N", &c_n1, &c__0, a, x, &c__1, &info);
+ chkxer_("DTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dtptrs_("U", "N", "N", &c__0, &c_n1, a, x, &c__1, &info);
+ chkxer_("DTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dtptrs_("U", "N", "N", &c__2, &c__1, a, x, &c__1, &info);
+ chkxer_("DTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DTPRFS */
+
+ s_copy(srnamc_1.srnamt, "DTPRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtprfs_("/", "N", "N", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
+ iw, &info);
+ chkxer_("DTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtprfs_("U", "/", "N", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
+ iw, &info);
+ chkxer_("DTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dtprfs_("U", "N", "/", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
+ iw, &info);
+ chkxer_("DTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dtprfs_("U", "N", "N", &c_n1, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
+ iw, &info);
+ chkxer_("DTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dtprfs_("U", "N", "N", &c__0, &c_n1, a, b, &c__1, x, &c__1, r1, r2, w,
+ iw, &info);
+ chkxer_("DTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dtprfs_("U", "N", "N", &c__2, &c__1, a, b, &c__1, x, &c__2, r1, r2, w,
+ iw, &info);
+ chkxer_("DTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dtprfs_("U", "N", "N", &c__2, &c__1, a, b, &c__2, x, &c__1, r1, r2, w,
+ iw, &info);
+ chkxer_("DTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DTPCON */
+
+ s_copy(srnamc_1.srnamt, "DTPCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtpcon_("/", "U", "N", &c__0, a, &rcond, w, iw, &info);
+ chkxer_("DTPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtpcon_("1", "/", "N", &c__0, a, &rcond, w, iw, &info);
+ chkxer_("DTPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dtpcon_("1", "U", "/", &c__0, a, &rcond, w, iw, &info);
+ chkxer_("DTPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dtpcon_("1", "U", "N", &c_n1, a, &rcond, w, iw, &info);
+ chkxer_("DTPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DLATPS */
+
+ s_copy(srnamc_1.srnamt, "DLATPS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dlatps_("/", "N", "N", "N", &c__0, a, x, &scale, w, &info);
+ chkxer_("DLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dlatps_("U", "/", "N", "N", &c__0, a, x, &scale, w, &info);
+ chkxer_("DLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dlatps_("U", "N", "/", "N", &c__0, a, x, &scale, w, &info);
+ chkxer_("DLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dlatps_("U", "N", "N", "/", &c__0, a, x, &scale, w, &info);
+ chkxer_("DLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dlatps_("U", "N", "N", "N", &c_n1, a, x, &scale, w, &info);
+ chkxer_("DLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "TB")) {
+
+/* Test error exits for the banded triangular routines. */
+
+/* DTBTRS */
+
+ s_copy(srnamc_1.srnamt, "DTBTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtbtrs_("/", "N", "N", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("DTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtbtrs_("U", "/", "N", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("DTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dtbtrs_("U", "N", "/", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("DTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dtbtrs_("U", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("DTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dtbtrs_("U", "N", "N", &c__0, &c_n1, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("DTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dtbtrs_("U", "N", "N", &c__0, &c__0, &c_n1, a, &c__1, x, &c__1, &info);
+ chkxer_("DTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dtbtrs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__1, x, &c__2, &info);
+ chkxer_("DTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dtbtrs_("U", "N", "N", &c__2, &c__0, &c__1, a, &c__1, x, &c__1, &info);
+ chkxer_("DTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DTBRFS */
+
+ s_copy(srnamc_1.srnamt, "DTBRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtbrfs_("/", "N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtbrfs_("U", "/", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dtbrfs_("U", "N", "/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dtbrfs_("U", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dtbrfs_("U", "N", "N", &c__0, &c_n1, &c__0, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dtbrfs_("U", "N", "N", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dtbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__1, b, &c__2, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("DTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dtbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__1, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("DTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dtbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("DTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DTBCON */
+
+ s_copy(srnamc_1.srnamt, "DTBCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtbcon_("/", "U", "N", &c__0, &c__0, a, &c__1, &rcond, w, iw, &info);
+ chkxer_("DTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtbcon_("1", "/", "N", &c__0, &c__0, a, &c__1, &rcond, w, iw, &info);
+ chkxer_("DTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dtbcon_("1", "U", "/", &c__0, &c__0, a, &c__1, &rcond, w, iw, &info);
+ chkxer_("DTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dtbcon_("1", "U", "N", &c_n1, &c__0, a, &c__1, &rcond, w, iw, &info);
+ chkxer_("DTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dtbcon_("1", "U", "N", &c__0, &c_n1, a, &c__1, &rcond, w, iw, &info);
+ chkxer_("DTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dtbcon_("1", "U", "N", &c__2, &c__1, a, &c__1, &rcond, w, iw, &info);
+ chkxer_("DTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DLATBS */
+
+ s_copy(srnamc_1.srnamt, "DLATBS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dlatbs_("/", "N", "N", "N", &c__0, &c__0, a, &c__1, x, &scale, w, &
+ info);
+ chkxer_("DLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dlatbs_("U", "/", "N", "N", &c__0, &c__0, a, &c__1, x, &scale, w, &
+ info);
+ chkxer_("DLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dlatbs_("U", "N", "/", "N", &c__0, &c__0, a, &c__1, x, &scale, w, &
+ info);
+ chkxer_("DLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dlatbs_("U", "N", "N", "/", &c__0, &c__0, a, &c__1, x, &scale, w, &
+ info);
+ chkxer_("DLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dlatbs_("U", "N", "N", "N", &c_n1, &c__0, a, &c__1, x, &scale, w, &
+ info);
+ chkxer_("DLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dlatbs_("U", "N", "N", "N", &c__1, &c_n1, a, &c__1, x, &scale, w, &
+ info);
+ chkxer_("DLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dlatbs_("U", "N", "N", "N", &c__2, &c__1, a, &c__1, x, &scale, w, &
+ info);
+ chkxer_("DLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of DERRTR */
+
+} /* derrtr_ */
diff --git a/TESTING/LIN/derrtz.c b/TESTING/LIN/derrtz.c
new file mode 100644
index 0000000..c4e740e
--- /dev/null
+++ b/TESTING/LIN/derrtz.c
@@ -0,0 +1,163 @@
+/* derrtz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int derrtz_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal a[4] /* was [2][2] */, w[2];
+ char c2[2];
+ doublereal tau[2];
+ integer info;
+ extern /* Subroutine */ int alaesm_(char *, logical *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), dtzrqf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, integer *), dtzrzf_(integer *, integer *
+, doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRTZ tests the error exits for DTZRQF and STZRZF. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ a[0] = 1.;
+ a[2] = 2.;
+ a[3] = 3.;
+ a[1] = 4.;
+ w[0] = 0.;
+ w[1] = 0.;
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "TZ")) {
+
+/* Test error exits for the trapezoidal routines. */
+
+/* DTZRQF */
+
+ s_copy(srnamc_1.srnamt, "DTZRQF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtzrqf_(&c_n1, &c__0, a, &c__1, tau, &info);
+ chkxer_("DTZRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtzrqf_(&c__1, &c__0, a, &c__1, tau, &info);
+ chkxer_("DTZRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dtzrqf_(&c__2, &c__2, a, &c__1, tau, &info);
+ chkxer_("DTZRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DTZRZF */
+
+ s_copy(srnamc_1.srnamt, "DTZRZF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dtzrzf_(&c_n1, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("DTZRZF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dtzrzf_(&c__1, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("DTZRZF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dtzrzf_(&c__2, &c__2, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("DTZRZF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dtzrzf_(&c__2, &c__2, a, &c__2, tau, w, &c__1, &info);
+ chkxer_("DTZRZF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of DERRTZ */
+
+} /* derrtz_ */
diff --git a/TESTING/LIN/derrvx.c b/TESTING/LIN/derrvx.c
new file mode 100644
index 0000000..8a185be
--- /dev/null
+++ b/TESTING/LIN/derrvx.c
@@ -0,0 +1,884 @@
+/* derrvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__4 = 4;
+
+/* Subroutine */ int derrvx_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 drivers passed the tests of the er"
+ "ror exits\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 drivers failed the test"
+ "s of the error \002,\002exits ***\002)";
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublereal a[16] /* was [4][4] */, b[4], c__[4];
+ integer i__, j;
+ doublereal r__[4], w[8], x[4];
+ char c2[2];
+ doublereal r1[4], r2[4], af[16] /* was [4][4] */;
+ char eq[1];
+ integer ip[4], iw[4], info;
+ doublereal rcond;
+ extern /* Subroutine */ int dgbsv_(integer *, integer *, integer *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), dgesv_(integer *, integer *, doublereal *,
+ integer *, integer *, doublereal *, integer *, integer *), dpbsv_(
+ char *, integer *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *, integer *), dgtsv_(integer *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *), dposv_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dppsv_(char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, integer *), dspsv_(char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *), dptsv_(integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *),
+ dsysv_(char *, integer *, integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), dgbsvx_(char *, char *, integer *, integer
+ *, integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, integer *, char *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *), dgesvx_(char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *, char *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, integer *), dpbsvx_(char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, char *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *), dgtsvx_(char *, char *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *), dposvx_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *, char *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *), dppsvx_(char *, char *,
+ integer *, integer *, doublereal *, doublereal *, char *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *,
+ integer *), dspsvx_(char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, integer *), dptsvx_(char *, integer *, integer *, doublereal
+ *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *), dsysvx_(char *,
+ char *, integer *, integer *, doublereal *, integer *, doublereal
+ *, integer *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___19 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___20 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRVX tests the error exits for the DOUBLE PRECISION driver routines */
+/* for solving linear systems of equations. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
+ af[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
+/* L10: */
+ }
+ b[j - 1] = 0.;
+ r1[j - 1] = 0.;
+ r2[j - 1] = 0.;
+ w[j - 1] = 0.;
+ x[j - 1] = 0.;
+ c__[j - 1] = 0.;
+ r__[j - 1] = 0.;
+ ip[j - 1] = j;
+/* L20: */
+ }
+ *(unsigned char *)eq = ' ';
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "GE")) {
+
+/* DGESV */
+
+ s_copy(srnamc_1.srnamt, "DGESV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgesv_(&c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("DGESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgesv_(&c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("DGESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgesv_(&c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
+ chkxer_("DGESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dgesv_(&c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
+ chkxer_("DGESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGESVX */
+
+ s_copy(srnamc_1.srnamt, "DGESVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgesvx_("/", "N", &c__0, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgesvx_("N", "/", &c__0, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgesvx_("N", "N", &c_n1, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgesvx_("N", "N", &c__0, &c_n1, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dgesvx_("N", "N", &c__2, &c__1, a, &c__1, af, &c__2, ip, eq, r__, c__,
+ b, &c__2, x, &c__2, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dgesvx_("N", "N", &c__2, &c__1, a, &c__2, af, &c__1, ip, eq, r__, c__,
+ b, &c__2, x, &c__2, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ *(unsigned char *)eq = '/';
+ dgesvx_("F", "N", &c__0, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ *(unsigned char *)eq = 'R';
+ dgesvx_("F", "N", &c__1, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ *(unsigned char *)eq = 'C';
+ dgesvx_("F", "N", &c__1, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ dgesvx_("N", "N", &c__2, &c__1, a, &c__2, af, &c__2, ip, eq, r__, c__,
+ b, &c__1, x, &c__2, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ dgesvx_("N", "N", &c__2, &c__1, a, &c__2, af, &c__2, ip, eq, r__, c__,
+ b, &c__2, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* DGBSV */
+
+ s_copy(srnamc_1.srnamt, "DGBSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgbsv_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("DGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgbsv_(&c__1, &c_n1, &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("DGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgbsv_(&c__1, &c__0, &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("DGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgbsv_(&c__0, &c__0, &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("DGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dgbsv_(&c__1, &c__1, &c__1, &c__0, a, &c__3, ip, b, &c__1, &info);
+ chkxer_("DGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dgbsv_(&c__2, &c__0, &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("DGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGBSVX */
+
+ s_copy(srnamc_1.srnamt, "DGBSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgbsvx_("/", "N", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("DGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgbsvx_("N", "/", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("DGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgbsvx_("N", "N", &c_n1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("DGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgbsvx_("N", "N", &c__1, &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("DGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dgbsvx_("N", "N", &c__1, &c__0, &c_n1, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("DGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dgbsvx_("N", "N", &c__0, &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("DGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dgbsvx_("N", "N", &c__1, &c__1, &c__1, &c__0, a, &c__2, af, &c__4, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("DGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dgbsvx_("N", "N", &c__1, &c__1, &c__1, &c__0, a, &c__3, af, &c__3, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("DGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ *(unsigned char *)eq = '/';
+ dgbsvx_("F", "N", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("DGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ *(unsigned char *)eq = 'R';
+ dgbsvx_("F", "N", &c__1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("DGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ *(unsigned char *)eq = 'C';
+ dgbsvx_("F", "N", &c__1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("DGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ dgbsvx_("N", "N", &c__2, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__2, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("DGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ dgbsvx_("N", "N", &c__2, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__2, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("DGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "GT")) {
+
+/* DGTSV */
+
+ s_copy(srnamc_1.srnamt, "DGTSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgtsv_(&c_n1, &c__0, a, &a[4], &a[8], b, &c__1, &info);
+ chkxer_("DGTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgtsv_(&c__0, &c_n1, a, &a[4], &a[8], b, &c__1, &info);
+ chkxer_("DGTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dgtsv_(&c__2, &c__0, a, &a[4], &a[8], b, &c__1, &info);
+ chkxer_("DGTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DGTSVX */
+
+ s_copy(srnamc_1.srnamt, "DGTSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dgtsvx_("/", "N", &c__0, &c__0, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dgtsvx_("N", "/", &c__0, &c__0, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dgtsvx_("N", "N", &c_n1, &c__0, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dgtsvx_("N", "N", &c__0, &c_n1, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ dgtsvx_("N", "N", &c__2, &c__0, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__1, x, &c__2, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ dgtsvx_("N", "N", &c__2, &c__0, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__2, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PO")) {
+
+/* DPOSV */
+
+ s_copy(srnamc_1.srnamt, "DPOSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dposv_("/", &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("DPOSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dposv_("U", &c_n1, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("DPOSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dposv_("U", &c__0, &c_n1, a, &c__1, b, &c__1, &info);
+ chkxer_("DPOSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dposv_("U", &c__2, &c__0, a, &c__1, b, &c__2, &info);
+ chkxer_("DPOSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dposv_("U", &c__2, &c__0, a, &c__2, b, &c__1, &info);
+ chkxer_("DPOSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPOSVX */
+
+ s_copy(srnamc_1.srnamt, "DPOSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dposvx_("/", "U", &c__0, &c__0, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dposvx_("N", "/", &c__0, &c__0, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dposvx_("N", "U", &c_n1, &c__0, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dposvx_("N", "U", &c__0, &c_n1, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dposvx_("N", "U", &c__2, &c__0, a, &c__1, af, &c__2, eq, c__, b, &
+ c__2, x, &c__2, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dposvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__1, eq, c__, b, &
+ c__2, x, &c__2, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ *(unsigned char *)eq = '/';
+ dposvx_("F", "U", &c__0, &c__0, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ *(unsigned char *)eq = 'Y';
+ dposvx_("F", "U", &c__1, &c__0, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dposvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, eq, c__, b, &
+ c__1, x, &c__2, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ dposvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, eq, c__, b, &
+ c__2, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PP")) {
+
+/* DPPSV */
+
+ s_copy(srnamc_1.srnamt, "DPPSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dppsv_("/", &c__0, &c__0, a, b, &c__1, &info);
+ chkxer_("DPPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dppsv_("U", &c_n1, &c__0, a, b, &c__1, &info);
+ chkxer_("DPPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dppsv_("U", &c__0, &c_n1, a, b, &c__1, &info);
+ chkxer_("DPPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dppsv_("U", &c__2, &c__0, a, b, &c__1, &info);
+ chkxer_("DPPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPPSVX */
+
+ s_copy(srnamc_1.srnamt, "DPPSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dppsvx_("/", "U", &c__0, &c__0, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, iw, &info);
+ chkxer_("DPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dppsvx_("N", "/", &c__0, &c__0, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, iw, &info);
+ chkxer_("DPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dppsvx_("N", "U", &c_n1, &c__0, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, iw, &info);
+ chkxer_("DPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dppsvx_("N", "U", &c__0, &c_n1, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, iw, &info);
+ chkxer_("DPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ *(unsigned char *)eq = '/';
+ dppsvx_("F", "U", &c__0, &c__0, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, iw, &info);
+ chkxer_("DPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ *(unsigned char *)eq = 'Y';
+ dppsvx_("F", "U", &c__1, &c__0, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, iw, &info);
+ chkxer_("DPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ dppsvx_("N", "U", &c__2, &c__0, a, af, eq, c__, b, &c__1, x, &c__2, &
+ rcond, r1, r2, w, iw, &info);
+ chkxer_("DPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ dppsvx_("N", "U", &c__2, &c__0, a, af, eq, c__, b, &c__2, x, &c__1, &
+ rcond, r1, r2, w, iw, &info);
+ chkxer_("DPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* DPBSV */
+
+ s_copy(srnamc_1.srnamt, "DPBSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpbsv_("/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &info)
+ ;
+ chkxer_("DPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpbsv_("U", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, &info)
+ ;
+ chkxer_("DPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpbsv_("U", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, &info)
+ ;
+ chkxer_("DPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dpbsv_("U", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, &info)
+ ;
+ chkxer_("DPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dpbsv_("U", &c__1, &c__1, &c__0, a, &c__1, b, &c__2, &info)
+ ;
+ chkxer_("DPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dpbsv_("U", &c__2, &c__0, &c__0, a, &c__1, b, &c__1, &info)
+ ;
+ chkxer_("DPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPBSVX */
+
+ s_copy(srnamc_1.srnamt, "DPBSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dpbsvx_("/", "U", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dpbsvx_("N", "/", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dpbsvx_("N", "U", &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dpbsvx_("N", "U", &c__1, &c_n1, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ dpbsvx_("N", "U", &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dpbsvx_("N", "U", &c__1, &c__1, &c__0, a, &c__1, af, &c__2, eq, c__,
+ b, &c__2, x, &c__2, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dpbsvx_("N", "U", &c__1, &c__1, &c__0, a, &c__2, af, &c__1, eq, c__,
+ b, &c__2, x, &c__2, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ *(unsigned char *)eq = '/';
+ dpbsvx_("F", "U", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ *(unsigned char *)eq = 'Y';
+ dpbsvx_("F", "U", &c__1, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ dpbsvx_("N", "U", &c__2, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__2, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ dpbsvx_("N", "U", &c__2, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__2, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("DPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PT")) {
+
+/* DPTSV */
+
+ s_copy(srnamc_1.srnamt, "DPTSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dptsv_(&c_n1, &c__0, a, &a[4], b, &c__1, &info);
+ chkxer_("DPTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dptsv_(&c__0, &c_n1, a, &a[4], b, &c__1, &info);
+ chkxer_("DPTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dptsv_(&c__2, &c__0, a, &a[4], b, &c__1, &info);
+ chkxer_("DPTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DPTSVX */
+
+ s_copy(srnamc_1.srnamt, "DPTSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dptsvx_("/", &c__0, &c__0, a, &a[4], af, &af[4], b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, &info);
+ chkxer_("DPTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dptsvx_("N", &c_n1, &c__0, a, &a[4], af, &af[4], b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, &info);
+ chkxer_("DPTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dptsvx_("N", &c__0, &c_n1, a, &a[4], af, &af[4], b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, &info);
+ chkxer_("DPTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dptsvx_("N", &c__2, &c__0, a, &a[4], af, &af[4], b, &c__1, x, &c__2, &
+ rcond, r1, r2, w, &info);
+ chkxer_("DPTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dptsvx_("N", &c__2, &c__0, a, &a[4], af, &af[4], b, &c__2, x, &c__1, &
+ rcond, r1, r2, w, &info);
+ chkxer_("DPTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "SY")) {
+
+/* DSYSV */
+
+ s_copy(srnamc_1.srnamt, "DSYSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsysv_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("DSYSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsysv_("U", &c_n1, &c__0, a, &c__1, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("DSYSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dsysv_("U", &c__0, &c_n1, a, &c__1, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("DSYSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dsysv_("U", &c__2, &c__0, a, &c__2, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("DSYSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DSYSVX */
+
+ s_copy(srnamc_1.srnamt, "DSYSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dsysvx_("/", "U", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, iw, &info);
+ chkxer_("DSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dsysvx_("N", "/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, iw, &info);
+ chkxer_("DSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dsysvx_("N", "U", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, iw, &info);
+ chkxer_("DSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dsysvx_("N", "U", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, iw, &info);
+ chkxer_("DSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ dsysvx_("N", "U", &c__2, &c__0, a, &c__1, af, &c__2, ip, b, &c__2, x,
+ &c__2, &rcond, r1, r2, w, &c__4, iw, &info);
+ chkxer_("DSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ dsysvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__1, ip, b, &c__2, x,
+ &c__2, &rcond, r1, r2, w, &c__4, iw, &info);
+ chkxer_("DSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dsysvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, ip, b, &c__1, x,
+ &c__2, &rcond, r1, r2, w, &c__4, iw, &info);
+ chkxer_("DSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ dsysvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, ip, b, &c__2, x,
+ &c__1, &rcond, r1, r2, w, &c__4, iw, &info);
+ chkxer_("DSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ dsysvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, ip, b, &c__2, x,
+ &c__2, &rcond, r1, r2, w, &c__3, iw, &info);
+ chkxer_("DSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "SP")) {
+
+/* DSPSV */
+
+ s_copy(srnamc_1.srnamt, "DSPSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dspsv_("/", &c__0, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("DSPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dspsv_("U", &c_n1, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("DSPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dspsv_("U", &c__0, &c_n1, a, ip, b, &c__1, &info);
+ chkxer_("DSPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ dspsv_("U", &c__2, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("DSPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* DSPSVX */
+
+ s_copy(srnamc_1.srnamt, "DSPSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ dspsvx_("/", "U", &c__0, &c__0, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, iw, &info);
+ chkxer_("DSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ dspsvx_("N", "/", &c__0, &c__0, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, iw, &info);
+ chkxer_("DSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ dspsvx_("N", "U", &c_n1, &c__0, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, iw, &info);
+ chkxer_("DSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ dspsvx_("N", "U", &c__0, &c_n1, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, iw, &info);
+ chkxer_("DSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ dspsvx_("N", "U", &c__2, &c__0, a, af, ip, b, &c__1, x, &c__2, &rcond,
+ r1, r2, w, iw, &info);
+ chkxer_("DSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ dspsvx_("N", "U", &c__2, &c__0, a, af, ip, b, &c__2, x, &c__1, &rcond,
+ r1, r2, w, iw, &info);
+ chkxer_("DSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___19.ciunit = infoc_1.nout;
+ s_wsfe(&io___19);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ } else {
+ io___20.ciunit = infoc_1.nout;
+ s_wsfe(&io___20);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of DERRVX */
+
+} /* derrvx_ */
diff --git a/TESTING/LIN/dgbt01.c b/TESTING/LIN/dgbt01.c
new file mode 100644
index 0000000..3aed173
--- /dev/null
+++ b/TESTING/LIN/dgbt01.c
@@ -0,0 +1,241 @@
+/* dgbt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b12 = -1.;
+
+/* Subroutine */ int dgbt01_(integer *m, integer *n, integer *kl, integer *ku,
+ doublereal *a, integer *lda, doublereal *afac, integer *ldafac,
+ integer *ipiv, doublereal *work, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal t;
+ integer i1, i2, kd, il, jl, ip, ju, iw, jua;
+ doublereal eps;
+ integer lenj;
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal anorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *);
+ extern doublereal dlamch_(char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGBT01 reconstructs a band matrix A from its L*U factorization and */
+/* computes the residual: */
+/* norm(L*U - A) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* The expression L*U - A is computed one column at a time, so A and */
+/* AFAC are not modified. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The original matrix A in band storage, stored in rows 1 to */
+/* KL+KU+1. */
+
+/* LDA (input) INTEGER. */
+/* The leading dimension of the array A. LDA >= max(1,KL+KU+1). */
+
+/* AFAC (input) DOUBLE PRECISION array, dimension (LDAFAC,N) */
+/* The factored form of the matrix A. AFAC contains the banded */
+/* factors L and U from the L*U factorization, as computed by */
+/* DGBTRF. U is stored as an upper triangular band matrix with */
+/* KL+KU superdiagonals in rows 1 to KL+KU+1, and the */
+/* multipliers used during the factorization are stored in rows */
+/* KL+KU+2 to 2*KL+KU+1. See DGBTRF for further details. */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. */
+/* LDAFAC >= max(1,2*KL*KU+1). */
+
+/* IPIV (input) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices from DGBTRF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (2*KL+KU+1) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* norm(L*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if M = 0 or N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *resid = 0.;
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+/* Determine EPS and the norm of A. */
+
+ eps = dlamch_("Epsilon");
+ kd = *ku + 1;
+ anorm = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = kd + 1 - j;
+ i1 = max(i__2,1);
+/* Computing MIN */
+ i__2 = kd + *m - j, i__3 = *kl + kd;
+ i2 = min(i__2,i__3);
+ if (i2 >= i1) {
+/* Computing MAX */
+ i__2 = i2 - i1 + 1;
+ d__1 = anorm, d__2 = dasum_(&i__2, &a[i1 + j * a_dim1], &c__1);
+ anorm = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+/* Compute one column at a time of L*U - A. */
+
+ kd = *kl + *ku + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Copy the J-th column of U to WORK. */
+
+/* Computing MIN */
+ i__2 = *kl + *ku, i__3 = j - 1;
+ ju = min(i__2,i__3);
+/* Computing MIN */
+ i__2 = *kl, i__3 = *m - j;
+ jl = min(i__2,i__3);
+ lenj = min(*m,j) - j + ju + 1;
+ if (lenj > 0) {
+ dcopy_(&lenj, &afac[kd - ju + j * afac_dim1], &c__1, &work[1], &
+ c__1);
+ i__2 = ju + jl + 1;
+ for (i__ = lenj + 1; i__ <= i__2; ++i__) {
+ work[i__] = 0.;
+/* L20: */
+ }
+
+/* Multiply by the unit lower triangular matrix L. Note that L */
+/* is stored as a product of transformations and permutations. */
+
+/* Computing MIN */
+ i__2 = *m - 1;
+ i__3 = j - ju;
+ for (i__ = min(i__2,j); i__ >= i__3; --i__) {
+/* Computing MIN */
+ i__2 = *kl, i__4 = *m - i__;
+ il = min(i__2,i__4);
+ if (il > 0) {
+ iw = i__ - j + ju + 1;
+ t = work[iw];
+ daxpy_(&il, &t, &afac[kd + 1 + i__ * afac_dim1], &c__1, &
+ work[iw + 1], &c__1);
+ ip = ipiv[i__];
+ if (i__ != ip) {
+ ip = ip - j + ju + 1;
+ work[iw] = work[ip];
+ work[ip] = t;
+ }
+ }
+/* L30: */
+ }
+
+/* Subtract the corresponding column of A. */
+
+ jua = min(ju,*ku);
+ if (jua + jl + 1 > 0) {
+ i__3 = jua + jl + 1;
+ daxpy_(&i__3, &c_b12, &a[*ku + 1 - jua + j * a_dim1], &c__1, &
+ work[ju + 1 - jua], &c__1);
+ }
+
+/* Compute the 1-norm of the column. */
+
+/* Computing MAX */
+ i__3 = ju + jl + 1;
+ d__1 = *resid, d__2 = dasum_(&i__3, &work[1], &c__1);
+ *resid = max(d__1,d__2);
+ }
+/* L40: */
+ }
+
+/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
+
+ if (anorm <= 0.) {
+ if (*resid != 0.) {
+ *resid = 1. / eps;
+ }
+ } else {
+ *resid = *resid / (doublereal) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of DGBT01 */
+
+} /* dgbt01_ */
diff --git a/TESTING/LIN/dgbt02.c b/TESTING/LIN/dgbt02.c
new file mode 100644
index 0000000..20ccaea
--- /dev/null
+++ b/TESTING/LIN/dgbt02.c
@@ -0,0 +1,206 @@
+/* dgbt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b8 = -1.;
+static doublereal c_b10 = 1.;
+
+/* Subroutine */ int dgbt02_(char *trans, integer *m, integer *n, integer *kl,
+ integer *ku, integer *nrhs, doublereal *a, integer *lda, doublereal *
+ x, integer *ldx, doublereal *b, integer *ldb, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2,
+ i__3;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j, i1, i2, n1, kd;
+ doublereal eps;
+ extern /* Subroutine */ int dgbmv_(char *, integer *, integer *, integer *
+, integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal anorm, bnorm, xnorm;
+ extern doublereal dlamch_(char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGBT02 computes the residual for a solution of a banded system of */
+/* equations A*x = b or A'*x = b: */
+/* RESID = norm( B - A*X ) / ( norm(A) * norm(X) * EPS). */
+/* where EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A *x = b */
+/* = 'T': A'*x = b, where A' is the transpose of A */
+/* = 'C': A'*x = b, where A' is the transpose of A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The original matrix A in band storage, stored in rows 1 to */
+/* KL+KU+1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,KL+KU+1). */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. IF TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if N = 0 pr NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ kd = *ku + 1;
+ anorm = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = kd + 1 - j;
+ i1 = max(i__2,1);
+/* Computing MIN */
+ i__2 = kd + *m - j, i__3 = *kl + kd;
+ i2 = min(i__2,i__3);
+/* Computing MAX */
+ i__2 = i2 - i1 + 1;
+ d__1 = anorm, d__2 = dasum_(&i__2, &a[i1 + j * a_dim1], &c__1);
+ anorm = max(d__1,d__2);
+/* L10: */
+ }
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+ if (lsame_(trans, "T") || lsame_(trans, "C")) {
+ n1 = *n;
+ } else {
+ n1 = *m;
+ }
+
+/* Compute B - A*X (or B - A'*X ) */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ dgbmv_(trans, m, n, kl, ku, &c_b8, &a[a_offset], lda, &x[j * x_dim1 +
+ 1], &c__1, &c_b10, &b[j * b_dim1 + 1], &c__1);
+/* L20: */
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = dasum_(&n1, &b[j * b_dim1 + 1], &c__1);
+ xnorm = dasum_(&n1, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L30: */
+ }
+
+ return 0;
+
+/* End of DGBT02 */
+
+} /* dgbt02_ */
diff --git a/TESTING/LIN/dgbt05.c b/TESTING/LIN/dgbt05.c
new file mode 100644
index 0000000..36ac963
--- /dev/null
+++ b/TESTING/LIN/dgbt05.c
@@ -0,0 +1,281 @@
+/* dgbt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dgbt05_(char *trans, integer *n, integer *kl, integer *
+ ku, integer *nrhs, doublereal *ab, integer *ldab, doublereal *b,
+ integer *ldb, doublereal *x, integer *ldx, doublereal *xact, integer *
+ ldxact, doublereal *ferr, doublereal *berr, doublereal *reslts)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, k, nz;
+ doublereal eps, tmp, diff, axbi;
+ integer imax;
+ doublereal unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ doublereal xnorm;
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal errbnd;
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGBT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations op(A)*X = B, where A is a */
+/* general band matrix of order n with kl subdiagonals and ku */
+/* superdiagonals and op(A) = A or A**T, depending on TRANS. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+/* and NZ = max. number of nonzeros in any row of A, plus 1 */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The original band matrix A, stored in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.;
+ reslts[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ notran = lsame_(trans, "N");
+/* Computing MIN */
+ i__1 = *kl + *ku + 2, i__2 = *n + 1;
+ nz = min(i__1,i__2);
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = idamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ d__2 = (d__1 = x[imax + j * x_dim1], abs(d__1));
+ xnorm = max(d__2,unfl);
+ diff = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = diff, d__3 = (d__1 = x[i__ + j * x_dim1] - xact[i__ + j *
+ xact_dim1], abs(d__1));
+ diff = max(d__2,d__3);
+/* L10: */
+ }
+
+ if (xnorm > 1.) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1. / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
+ errbnd = max(d__1,d__2);
+ } else {
+ errbnd = 1. / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ tmp = (d__1 = b[i__ + k * b_dim1], abs(d__1));
+ if (notran) {
+/* Computing MAX */
+ i__3 = i__ - *kl;
+/* Computing MIN */
+ i__5 = i__ + *ku;
+ i__4 = min(i__5,*n);
+ for (j = max(i__3,1); j <= i__4; ++j) {
+ tmp += (d__1 = ab[*ku + 1 + i__ - j + j * ab_dim1], abs(
+ d__1)) * (d__2 = x[j + k * x_dim1], abs(d__2));
+/* L40: */
+ }
+ } else {
+/* Computing MAX */
+ i__4 = i__ - *ku;
+/* Computing MIN */
+ i__5 = i__ + *kl;
+ i__3 = min(i__5,*n);
+ for (j = max(i__4,1); j <= i__3; ++j) {
+ tmp += (d__1 = ab[*ku + 1 + j - i__ + i__ * ab_dim1], abs(
+ d__1)) * (d__2 = x[j + k * x_dim1], abs(d__2));
+/* L50: */
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = min(axbi,tmp);
+ }
+/* L60: */
+ }
+/* Computing MAX */
+ d__1 = axbi, d__2 = nz * unfl;
+ tmp = berr[k] / (nz * eps + nz * unfl / max(d__1,d__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = max(reslts[2],tmp);
+ }
+/* L70: */
+ }
+
+ return 0;
+
+/* End of DGBT05 */
+
+} /* dgbt05_ */
diff --git a/TESTING/LIN/dgelqs.c b/TESTING/LIN/dgelqs.c
new file mode 100644
index 0000000..169d571
--- /dev/null
+++ b/TESTING/LIN/dgelqs.c
@@ -0,0 +1,166 @@
+/* dgelqs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b7 = 1.;
+static doublereal c_b9 = 0.;
+
+/* Subroutine */ int dgelqs_(integer *m, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *tau, doublereal *b, integer *
+ ldb, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), dlaset_(
+ char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), xerbla_(char *, integer *), dormlq_(char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Compute a minimum-norm solution */
+/* min || A*X - B || */
+/* using the LQ factorization */
+/* A = L*Q */
+/* computed by DGELQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= M >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* Details of the LQ factorization of the original matrix A as */
+/* returned by DGELQF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (M) */
+/* Details of the orthogonal matrix Q. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the m-by-nrhs right hand side matrix B. */
+/* On exit, the n-by-nrhs solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= N. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK must be at least NRHS, */
+/* and should be at least NRHS*NB, where NB is the block size */
+/* for this environment. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *m > *n) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*lwork < 1 || *lwork < *nrhs && *m > 0 && *n > 0) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGELQS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0 || *m == 0) {
+ return 0;
+ }
+
+/* Solve L*X = B(1:m,:) */
+
+ dtrsm_("Left", "Lower", "No transpose", "Non-unit", m, nrhs, &c_b7, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+/* Set B(m+1:n,:) to zero */
+
+ if (*m < *n) {
+ i__1 = *n - *m;
+ dlaset_("Full", &i__1, nrhs, &c_b9, &c_b9, &b[*m + 1 + b_dim1], ldb);
+ }
+
+/* B := Q' * B */
+
+ dormlq_("Left", "Transpose", n, nrhs, m, &a[a_offset], lda, &tau[1], &b[
+ b_offset], ldb, &work[1], lwork, info);
+
+ return 0;
+
+/* End of DGELQS */
+
+} /* dgelqs_ */
diff --git a/TESTING/LIN/dgennd.c b/TESTING/LIN/dgennd.c
new file mode 100644
index 0000000..9101003
--- /dev/null
+++ b/TESTING/LIN/dgennd.c
@@ -0,0 +1,80 @@
+/* dgennd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+logical dgennd_(integer *m, integer *n, doublereal *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ logical ret_val;
+
+ /* Local variables */
+ integer i__, k;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGENND tests that its argument has a non-negative diagonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows in A. */
+
+/* N (input) INTEGER */
+/* The number of columns in A. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA, N) */
+/* The matrix. */
+
+/* LDA (input) INTEGER */
+/* Leading dimension of A. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsics .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ k = min(*m,*n);
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (a[i__ + i__ * a_dim1] < 0.) {
+ ret_val = FALSE_;
+ return ret_val;
+ }
+ }
+ ret_val = TRUE_;
+ return ret_val;
+} /* dgennd_ */
diff --git a/TESTING/LIN/dgeqls.c b/TESTING/LIN/dgeqls.c
new file mode 100644
index 0000000..1387caa
--- /dev/null
+++ b/TESTING/LIN/dgeqls.c
@@ -0,0 +1,158 @@
+/* dgeqls.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b9 = 1.;
+
+/* Subroutine */ int dgeqls_(integer *m, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *tau, doublereal *b, integer *
+ ldb, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), xerbla_(
+ char *, integer *), dormql_(char *, char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Solve the least squares problem */
+/* min || A*X - B || */
+/* using the QL factorization */
+/* A = Q*L */
+/* computed by DGEQLF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. M >= N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* Details of the QL factorization of the original matrix A as */
+/* returned by DGEQLF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (N) */
+/* Details of the orthogonal matrix Q. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the m-by-nrhs right hand side matrix B. */
+/* On exit, the n-by-nrhs solution matrix X, stored in rows */
+/* m-n+1:m. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= M. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK must be at least NRHS, */
+/* and should be at least NRHS*NB, where NB is the block size */
+/* for this environment. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*m)) {
+ *info = -8;
+ } else if (*lwork < 1 || *lwork < *nrhs && *m > 0 && *n > 0) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGEQLS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0 || *m == 0) {
+ return 0;
+ }
+
+/* B := Q' * B */
+
+ dormql_("Left", "Transpose", m, nrhs, n, &a[a_offset], lda, &tau[1], &b[
+ b_offset], ldb, &work[1], lwork, info);
+
+/* Solve L*X = B(m-n+1:m,:) */
+
+ dtrsm_("Left", "Lower", "No transpose", "Non-unit", n, nrhs, &c_b9, &a[*m
+ - *n + 1 + a_dim1], lda, &b[*m - *n + 1 + b_dim1], ldb);
+
+ return 0;
+
+/* End of DGEQLS */
+
+} /* dgeqls_ */
diff --git a/TESTING/LIN/dgeqrs.c b/TESTING/LIN/dgeqrs.c
new file mode 100644
index 0000000..650e59c
--- /dev/null
+++ b/TESTING/LIN/dgeqrs.c
@@ -0,0 +1,157 @@
+/* dgeqrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b9 = 1.;
+
+/* Subroutine */ int dgeqrs_(integer *m, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *tau, doublereal *b, integer *
+ ldb, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), xerbla_(
+ char *, integer *), dormqr_(char *, char *, integer *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Solve the least squares problem */
+/* min || A*X - B || */
+/* using the QR factorization */
+/* A = Q*R */
+/* computed by DGEQRF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. M >= N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* Details of the QR factorization of the original matrix A as */
+/* returned by DGEQRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (N) */
+/* Details of the orthogonal matrix Q. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the m-by-nrhs right hand side matrix B. */
+/* On exit, the n-by-nrhs solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= M. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK must be at least NRHS, */
+/* and should be at least NRHS*NB, where NB is the block size */
+/* for this environment. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*m)) {
+ *info = -8;
+ } else if (*lwork < 1 || *lwork < *nrhs && *m > 0 && *n > 0) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGEQRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0 || *m == 0) {
+ return 0;
+ }
+
+/* B := Q' * B */
+
+ dormqr_("Left", "Transpose", m, nrhs, n, &a[a_offset], lda, &tau[1], &b[
+ b_offset], ldb, &work[1], lwork, info);
+
+/* Solve R*X = B(1:n,:) */
+
+ dtrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b9, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+ return 0;
+
+/* End of DGEQRS */
+
+} /* dgeqrs_ */
diff --git a/TESTING/LIN/dgerqs.c b/TESTING/LIN/dgerqs.c
new file mode 100644
index 0000000..0e2b30d
--- /dev/null
+++ b/TESTING/LIN/dgerqs.c
@@ -0,0 +1,165 @@
+/* dgerqs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b7 = 1.;
+static doublereal c_b9 = 0.;
+
+/* Subroutine */ int dgerqs_(integer *m, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *tau, doublereal *b, integer *
+ ldb, doublereal *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *), dlaset_(
+ char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), xerbla_(char *, integer *), dormrq_(char *, char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Compute a minimum-norm solution */
+/* min || A*X - B || */
+/* using the RQ factorization */
+/* A = R*Q */
+/* computed by DGERQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= M >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* Details of the RQ factorization of the original matrix A as */
+/* returned by DGERQF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (M) */
+/* Details of the orthogonal matrix Q. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the linear system. */
+/* On exit, the solution vectors X. Each solution vector */
+/* is contained in rows 1:N of a column of B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK must be at least NRHS, */
+/* and should be at least NRHS*NB, where NB is the block size */
+/* for this environment. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *m > *n) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*lwork < 1 || *lwork < *nrhs && *m > 0 && *n > 0) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DGERQS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0 || *m == 0) {
+ return 0;
+ }
+
+/* Solve R*X = B(n-m+1:n,:) */
+
+ dtrsm_("Left", "Upper", "No transpose", "Non-unit", m, nrhs, &c_b7, &a[(*
+ n - *m + 1) * a_dim1 + 1], lda, &b[*n - *m + 1 + b_dim1], ldb);
+
+/* Set B(1:n-m,:) to zero */
+
+ i__1 = *n - *m;
+ dlaset_("Full", &i__1, nrhs, &c_b9, &c_b9, &b[b_offset], ldb);
+
+/* B := Q' * B */
+
+ dormrq_("Left", "Transpose", n, nrhs, m, &a[a_offset], lda, &tau[1], &b[
+ b_offset], ldb, &work[1], lwork, info);
+
+ return 0;
+
+/* End of DGERQS */
+
+} /* dgerqs_ */
diff --git a/TESTING/LIN/dget01.c b/TESTING/LIN/dget01.c
new file mode 100644
index 0000000..70bcfa7
--- /dev/null
+++ b/TESTING/LIN/dget01.c
@@ -0,0 +1,202 @@
+/* dget01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b11 = 1.;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dget01_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *afac, integer *ldafac, integer *ipiv, doublereal *
+ rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal t, eps;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *), dgemv_(char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *);
+ doublereal anorm;
+ extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlaswp_(integer *, doublereal *, integer *,
+ integer *, integer *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET01 reconstructs a matrix A from its L*U factorization and */
+/* computes the residual */
+/* norm(L*U - A) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The original M x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* AFAC (input/output) DOUBLE PRECISION array, dimension (LDAFAC,N) */
+/* The factored form of the matrix A. AFAC contains the factors */
+/* L and U from the L*U factorization as computed by DGETRF. */
+/* Overwritten with the reconstructed matrix, and then with the */
+/* difference L*U - A. */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. LDAFAC >= max(1,M). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from DGETRF. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* norm(L*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if M = 0 or N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ --ipiv;
+ --rwork;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Determine EPS and the norm of A. */
+
+ eps = dlamch_("Epsilon");
+ anorm = dlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+
+/* Compute the product L*U and overwrite AFAC with the result. */
+/* A column at a time of the product is obtained, starting with */
+/* column N. */
+
+ for (k = *n; k >= 1; --k) {
+ if (k > *m) {
+ dtrmv_("Lower", "No transpose", "Unit", m, &afac[afac_offset],
+ ldafac, &afac[k * afac_dim1 + 1], &c__1);
+ } else {
+
+/* Compute elements (K+1:M,K) */
+
+ t = afac[k + k * afac_dim1];
+ if (k + 1 <= *m) {
+ i__1 = *m - k;
+ dscal_(&i__1, &t, &afac[k + 1 + k * afac_dim1], &c__1);
+ i__1 = *m - k;
+ i__2 = k - 1;
+ dgemv_("No transpose", &i__1, &i__2, &c_b11, &afac[k + 1 +
+ afac_dim1], ldafac, &afac[k * afac_dim1 + 1], &c__1, &
+ c_b11, &afac[k + 1 + k * afac_dim1], &c__1);
+ }
+
+/* Compute the (K,K) element */
+
+ i__1 = k - 1;
+ afac[k + k * afac_dim1] = t + ddot_(&i__1, &afac[k + afac_dim1],
+ ldafac, &afac[k * afac_dim1 + 1], &c__1);
+
+/* Compute elements (1:K-1,K) */
+
+ i__1 = k - 1;
+ dtrmv_("Lower", "No transpose", "Unit", &i__1, &afac[afac_offset],
+ ldafac, &afac[k * afac_dim1 + 1], &c__1);
+ }
+/* L10: */
+ }
+ i__1 = min(*m,*n);
+ dlaswp_(n, &afac[afac_offset], ldafac, &c__1, &i__1, &ipiv[1], &c_n1);
+
+/* Compute the difference L*U - A and store in AFAC. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ afac[i__ + j * afac_dim1] -= a[i__ + j * a_dim1];
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = dlange_("1", m, n, &afac[afac_offset], ldafac, &rwork[1]);
+
+ if (anorm <= 0.) {
+ if (*resid != 0.) {
+ *resid = 1. / eps;
+ }
+ } else {
+ *resid = *resid / (doublereal) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of DGET01 */
+
+} /* dget01_ */
diff --git a/TESTING/LIN/dget02.c b/TESTING/LIN/dget02.c
new file mode 100644
index 0000000..1499a49
--- /dev/null
+++ b/TESTING/LIN/dget02.c
@@ -0,0 +1,187 @@
+/* dget02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b7 = -1.;
+static doublereal c_b8 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dget02_(char *trans, integer *m, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *x, integer *ldx,
+ doublereal *b, integer *ldb, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j, n1, n2;
+ doublereal eps;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal anorm, bnorm, xnorm;
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET02 computes the residual for a solution of a system of linear */
+/* equations A*x = b or A'*x = b: */
+/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A *x = b */
+/* = 'T': A'*x = b, where A' is the transpose of A */
+/* = 'C': A'*x = b, where A' is the transpose of A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The original M x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. IF TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if M = 0 or N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0 || *nrhs == 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+ if (lsame_(trans, "T") || lsame_(trans, "C")) {
+ n1 = *n;
+ n2 = *m;
+ } else {
+ n1 = *m;
+ n2 = *n;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = dlange_("1", &n1, &n2, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute B - A*X (or B - A'*X ) and store in B. */
+
+ dgemm_(trans, "No transpose", &n1, nrhs, &n2, &c_b7, &a[a_offset], lda, &
+ x[x_offset], ldx, &c_b8, &b[b_offset], ldb)
+ ;
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = dasum_(&n1, &b[j * b_dim1 + 1], &c__1);
+ xnorm = dasum_(&n2, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of DGET02 */
+
+} /* dget02_ */
diff --git a/TESTING/LIN/dget03.c b/TESTING/LIN/dget03.c
new file mode 100644
index 0000000..7c6e4ab
--- /dev/null
+++ b/TESTING/LIN/dget03.c
@@ -0,0 +1,156 @@
+/* dget03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b7 = -1.;
+static doublereal c_b8 = 0.;
+
+/* Subroutine */ int dget03_(integer *n, doublereal *a, integer *lda,
+ doublereal *ainv, integer *ldainv, doublereal *work, integer *ldwork,
+ doublereal *rwork, doublereal *rcond, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, ainv_dim1, ainv_offset, work_dim1, work_offset,
+ i__1;
+
+ /* Local variables */
+ integer i__;
+ doublereal eps;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ doublereal anorm;
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ doublereal ainvnm;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET03 computes the residual for a general matrix times its inverse: */
+/* norm( I - AINV*A ) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The original N x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AINV (input) DOUBLE PRECISION array, dimension (LDAINV,N) */
+/* The inverse of the matrix A. */
+
+/* LDAINV (input) INTEGER */
+/* The leading dimension of the array AINV. LDAINV >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal of the condition number of A, computed as */
+/* ( 1/norm(A) ) / norm(AINV). */
+
+/* RESID (output) DOUBLE PRECISION */
+/* norm(I - AINV*A) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ ainv_dim1 = *ldainv;
+ ainv_offset = 1 + ainv_dim1;
+ ainv -= ainv_offset;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.;
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = dlange_("1", n, n, &a[a_offset], lda, &rwork[1]);
+ ainvnm = dlange_("1", n, n, &ainv[ainv_offset], ldainv, &rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ *rcond = 0.;
+ *resid = 1. / eps;
+ return 0;
+ }
+ *rcond = 1. / anorm / ainvnm;
+
+/* Compute I - A * AINV */
+
+ dgemm_("No transpose", "No transpose", n, n, n, &c_b7, &ainv[ainv_offset],
+ ldainv, &a[a_offset], lda, &c_b8, &work[work_offset], ldwork);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__ + i__ * work_dim1] += 1.;
+/* L10: */
+ }
+
+/* Compute norm(I - AINV*A) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = dlange_("1", n, n, &work[work_offset], ldwork, &rwork[1]);
+
+ *resid = *resid * *rcond / eps / (doublereal) (*n);
+
+ return 0;
+
+/* End of DGET03 */
+
+} /* dget03_ */
diff --git a/TESTING/LIN/dget04.c b/TESTING/LIN/dget04.c
new file mode 100644
index 0000000..29ca4c1
--- /dev/null
+++ b/TESTING/LIN/dget04.c
@@ -0,0 +1,159 @@
+/* dget04.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dget04_(integer *n, integer *nrhs, doublereal *x,
+ integer *ldx, doublereal *xact, integer *ldxact, doublereal *rcond,
+ doublereal *resid)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, xact_dim1, xact_offset, i__1, i__2;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, ix;
+ doublereal eps, xnorm;
+ extern doublereal dlamch_(char *);
+ doublereal diffnm;
+ extern integer idamax_(integer *, doublereal *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET04 computes the difference between a computed solution and the */
+/* true solution to a system of linear equations. */
+
+/* RESID = ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ), */
+/* where RCOND is the reciprocal of the condition number and EPS is the */
+/* machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X and XACT. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X and XACT. NRHS >= 0. */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) DOUBLE PRECISION array, dimension( LDX, NRHS ) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* The reciprocal of the condition number of the coefficient */
+/* matrix in the system of equations. */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the NRHS solution vectors of */
+/* ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if RCOND is invalid. */
+
+ eps = dlamch_("Epsilon");
+ if (*rcond < 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute the maximum of */
+/* norm(X - XACT) / ( norm(XACT) * EPS ) */
+/* over all the vectors X and XACT . */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ix = idamax_(n, &xact[j * xact_dim1 + 1], &c__1);
+ xnorm = (d__1 = xact[ix + j * xact_dim1], abs(d__1));
+ diffnm = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = diffnm, d__3 = (d__1 = x[i__ + j * x_dim1] - xact[i__ + j *
+ xact_dim1], abs(d__1));
+ diffnm = max(d__2,d__3);
+/* L10: */
+ }
+ if (xnorm <= 0.) {
+ if (diffnm > 0.) {
+ *resid = 1. / eps;
+ }
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = diffnm / xnorm * *rcond;
+ *resid = max(d__1,d__2);
+ }
+/* L20: */
+ }
+ if (*resid * eps < 1.) {
+ *resid /= eps;
+ }
+
+ return 0;
+
+/* End of DGET04 */
+
+} /* dget04_ */
diff --git a/TESTING/LIN/dget06.c b/TESTING/LIN/dget06.c
new file mode 100644
index 0000000..aa14a06
--- /dev/null
+++ b/TESTING/LIN/dget06.c
@@ -0,0 +1,80 @@
+/* dget06.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dget06_(doublereal *rcond, doublereal *rcondc)
+{
+ /* System generated locals */
+ doublereal ret_val;
+
+ /* Local variables */
+ doublereal rat, eps;
+ extern doublereal dlamch_(char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET06 computes a test ratio to compare two values for RCOND. */
+
+/* Arguments */
+/* ========== */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* The estimate of the reciprocal of the condition number of A, */
+/* as computed by DGECON. */
+
+/* RCONDC (input) DOUBLE PRECISION */
+/* The reciprocal of the condition number of A, computed as */
+/* ( 1/norm(A) ) / norm(inv(A)). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = dlamch_("Epsilon");
+ if (*rcond > 0.) {
+ if (*rcondc > 0.) {
+ rat = max(*rcond,*rcondc) / min(*rcond,*rcondc) - (1. - eps);
+ } else {
+ rat = *rcond / eps;
+ }
+ } else {
+ if (*rcondc > 0.) {
+ rat = *rcondc / eps;
+ } else {
+ rat = 0.;
+ }
+ }
+ ret_val = rat;
+ return ret_val;
+
+/* End of DGET06 */
+
+} /* dget06_ */
diff --git a/TESTING/LIN/dget07.c b/TESTING/LIN/dget07.c
new file mode 100644
index 0000000..bfa4933
--- /dev/null
+++ b/TESTING/LIN/dget07.c
@@ -0,0 +1,264 @@
+/* dget07.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dget07_(char *trans, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
+ x, integer *ldx, doublereal *xact, integer *ldxact, doublereal *ferr,
+ logical *chkferr, doublereal *berr, doublereal *reslts)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal eps, tmp, diff, axbi;
+ integer imax;
+ doublereal unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ doublereal xnorm;
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal errbnd;
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET07 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations op(A)*X = B, where A is a */
+/* general n by n matrix and op(A) = A or A**T, depending on TRANS. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X and XACT. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X and XACT. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The original n by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* CHKFERR (input) LOGICAL */
+/* Set to .TRUE. to check FERR, .FALSE. not to check FERR. */
+/* When the test system is ill-conditioned, the "true" */
+/* solution in XACT may be incorrect. */
+
+/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.;
+ reslts[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ notran = lsame_(trans, "N");
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.;
+ if (*chkferr) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = idamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ d__2 = (d__1 = x[imax + j * x_dim1], abs(d__1));
+ xnorm = max(d__2,unfl);
+ diff = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = diff, d__3 = (d__1 = x[i__ + j * x_dim1] - xact[i__ +
+ j * xact_dim1], abs(d__1));
+ diff = max(d__2,d__3);
+/* L10: */
+ }
+
+ if (xnorm > 1.) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1. / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
+ errbnd = max(d__1,d__2);
+ } else {
+ errbnd = 1. / eps;
+ }
+L30:
+ ;
+ }
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ tmp = (d__1 = b[i__ + k * b_dim1], abs(d__1));
+ if (notran) {
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * (d__2 =
+ x[j + k * x_dim1], abs(d__2));
+/* L40: */
+ }
+ } else {
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1)) * (d__2 =
+ x[j + k * x_dim1], abs(d__2));
+/* L50: */
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = min(axbi,tmp);
+ }
+/* L60: */
+ }
+/* Computing MAX */
+ d__1 = axbi, d__2 = (*n + 1) * unfl;
+ tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / max(d__1,d__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = max(reslts[2],tmp);
+ }
+/* L70: */
+ }
+
+ return 0;
+
+/* End of DGET07 */
+
+} /* dget07_ */
diff --git a/TESTING/LIN/dget08.c b/TESTING/LIN/dget08.c
new file mode 100644
index 0000000..da207bb
--- /dev/null
+++ b/TESTING/LIN/dget08.c
@@ -0,0 +1,189 @@
+/* dget08.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b7 = -1.;
+static doublereal c_b8 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dget08_(char *trans, integer *m, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *x, integer *ldx,
+ doublereal *b, integer *ldb, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j, n1, n2;
+ doublereal eps;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ doublereal anorm, bnorm, xnorm;
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGET02 computes the residual for a solution of a system of linear */
+/* equations A*x = b or A'*x = b: */
+/* RESID = norm(B - A*X,inf) / ( norm(A,inf) * norm(X,inf) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A *x = b */
+/* = 'T': A'*x = b, where A' is the transpose of A */
+/* = 'C': A'*x = b, where A' is the transpose of A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The original M x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. IF TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if M = 0 or N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0 || *nrhs == 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+ if (lsame_(trans, "T") || lsame_(trans, "C")) {
+ n1 = *n;
+ n2 = *m;
+ } else {
+ n1 = *m;
+ n2 = *n;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = dlange_("I", &n1, &n2, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute B - A*X (or B - A'*X ) and store in B. */
+
+ dgemm_(trans, "No transpose", &n1, nrhs, &n2, &c_b7, &a[a_offset], lda, &
+ x[x_offset], ldx, &c_b8, &b[b_offset], ldb)
+ ;
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = (d__1 = b[idamax_(&n1, &b[j * b_dim1 + 1], &c__1) + j *
+ b_dim1], abs(d__1));
+ xnorm = (d__1 = x[idamax_(&n2, &x[j * x_dim1 + 1], &c__1) + j *
+ x_dim1], abs(d__1));
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of DGET02 */
+
+} /* dget08_ */
diff --git a/TESTING/LIN/dgtt01.c b/TESTING/LIN/dgtt01.c
new file mode 100644
index 0000000..1fee372
--- /dev/null
+++ b/TESTING/LIN/dgtt01.c
@@ -0,0 +1,232 @@
+/* dgtt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgtt01_(integer *n, doublereal *dl, doublereal *d__,
+ doublereal *du, doublereal *dlf, doublereal *df, doublereal *duf,
+ doublereal *du2, integer *ipiv, doublereal *work, integer *ldwork,
+ doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer work_dim1, work_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal li;
+ integer ip;
+ doublereal eps, anorm;
+ integer lastj;
+ extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
+ doublereal *, integer *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlangt_(char *, integer *,
+ doublereal *, doublereal *, doublereal *), dlanhs_(char *,
+ integer *, doublereal *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGTT01 reconstructs a tridiagonal matrix A from its LU factorization */
+/* and computes the residual */
+/* norm(L*U - A) / ( norm(A) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGTER */
+/* The order of the matrix A. N >= 0. */
+
+/* DL (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) sub-diagonal elements of A. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* DU (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) super-diagonal elements of A. */
+
+/* DLF (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) multipliers that define the matrix L from the */
+/* LU factorization of A. */
+
+/* DF (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the upper triangular matrix U from */
+/* the LU factorization of A. */
+
+/* DUF (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) elements of the first super-diagonal of U. */
+
+/* DU2F (input) DOUBLE PRECISION array, dimension (N-2) */
+/* The (n-2) elements of the second super-diagonal of U. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The scaled residual: norm(L*U - A) / (norm(A) * EPS) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ --dlf;
+ --df;
+ --duf;
+ --du2;
+ --ipiv;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+
+/* Copy the matrix U to WORK. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__ + j * work_dim1] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (i__ == 1) {
+ work[i__ + i__ * work_dim1] = df[i__];
+ if (*n >= 2) {
+ work[i__ + (i__ + 1) * work_dim1] = duf[i__];
+ }
+ if (*n >= 3) {
+ work[i__ + (i__ + 2) * work_dim1] = du2[i__];
+ }
+ } else if (i__ == *n) {
+ work[i__ + i__ * work_dim1] = df[i__];
+ } else {
+ work[i__ + i__ * work_dim1] = df[i__];
+ work[i__ + (i__ + 1) * work_dim1] = duf[i__];
+ if (i__ < *n - 1) {
+ work[i__ + (i__ + 2) * work_dim1] = du2[i__];
+ }
+ }
+/* L30: */
+ }
+
+/* Multiply on the left by L. */
+
+ lastj = *n;
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ li = dlf[i__];
+ i__1 = lastj - i__ + 1;
+ daxpy_(&i__1, &li, &work[i__ + i__ * work_dim1], ldwork, &work[i__ +
+ 1 + i__ * work_dim1], ldwork);
+ ip = ipiv[i__];
+ if (ip == i__) {
+/* Computing MIN */
+ i__1 = i__ + 2;
+ lastj = min(i__1,*n);
+ } else {
+ i__1 = lastj - i__ + 1;
+ dswap_(&i__1, &work[i__ + i__ * work_dim1], ldwork, &work[i__ + 1
+ + i__ * work_dim1], ldwork);
+ }
+/* L40: */
+ }
+
+/* Subtract the matrix A. */
+
+ work[work_dim1 + 1] -= d__[1];
+ if (*n > 1) {
+ work[(work_dim1 << 1) + 1] -= du[1];
+ work[*n + (*n - 1) * work_dim1] -= dl[*n - 1];
+ work[*n + *n * work_dim1] -= d__[*n];
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ work[i__ + (i__ - 1) * work_dim1] -= dl[i__ - 1];
+ work[i__ + i__ * work_dim1] -= d__[i__];
+ work[i__ + (i__ + 1) * work_dim1] -= du[i__];
+/* L50: */
+ }
+ }
+
+/* Compute the 1-norm of the tridiagonal matrix A. */
+
+ anorm = dlangt_("1", n, &dl[1], &d__[1], &du[1]);
+
+/* Compute the 1-norm of WORK, which is only guaranteed to be */
+/* upper Hessenberg. */
+
+ *resid = dlanhs_("1", n, &work[work_offset], ldwork, &rwork[1])
+ ;
+
+/* Compute norm(L*U - A) / (norm(A) * EPS) */
+
+ if (anorm <= 0.) {
+ if (*resid != 0.) {
+ *resid = 1. / eps;
+ }
+ } else {
+ *resid = *resid / anorm / eps;
+ }
+
+ return 0;
+
+/* End of DGTT01 */
+
+} /* dgtt01_ */
diff --git a/TESTING/LIN/dgtt02.c b/TESTING/LIN/dgtt02.c
new file mode 100644
index 0000000..81933c3
--- /dev/null
+++ b/TESTING/LIN/dgtt02.c
@@ -0,0 +1,180 @@
+/* dgtt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b6 = -1.;
+static doublereal c_b7 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dgtt02_(char *trans, integer *n, integer *nrhs,
+ doublereal *dl, doublereal *d__, doublereal *du, doublereal *x,
+ integer *ldx, doublereal *b, integer *ldb, doublereal *rwork,
+ doublereal *resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal anorm, bnorm, xnorm;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlagtm_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *);
+ extern doublereal dlangt_(char *, integer *, doublereal *, doublereal *,
+ doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGTT02 computes the residual for the solution to a tridiagonal */
+/* system of equations: */
+/* RESID = norm(B - op(A)*X) / (norm(A) * norm(X) * EPS), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER */
+/* Specifies the form of the residual. */
+/* = 'N': B - A * X (No transpose) */
+/* = 'T': B - A'* X (Transpose) */
+/* = 'C': B - A'* X (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGTER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* DL (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) sub-diagonal elements of A. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* DU (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) super-diagonal elements of A. */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - op(A)*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* norm(B - op(A)*X) / (norm(A) * norm(X) * EPS) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ *resid = 0.;
+ if (*n <= 0 || *nrhs == 0) {
+ return 0;
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - op(A)*X) / ( norm(A) * norm(X) * EPS ). */
+
+ if (lsame_(trans, "N")) {
+ anorm = dlangt_("1", n, &dl[1], &d__[1], &du[1]);
+ } else {
+ anorm = dlangt_("I", n, &dl[1], &d__[1], &du[1]);
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute B - op(A)*X. */
+
+ dlagtm_(trans, n, nrhs, &c_b6, &dl[1], &d__[1], &du[1], &x[x_offset], ldx,
+ &c_b7, &b[b_offset], ldb);
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = dasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = dasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of DGTT02 */
+
+} /* dgtt02_ */
diff --git a/TESTING/LIN/dgtt05.c b/TESTING/LIN/dgtt05.c
new file mode 100644
index 0000000..3fa299b
--- /dev/null
+++ b/TESTING/LIN/dgtt05.c
@@ -0,0 +1,285 @@
+/* dgtt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dgtt05_(char *trans, integer *n, integer *nrhs,
+ doublereal *dl, doublereal *d__, doublereal *du, doublereal *b,
+ integer *ldb, doublereal *x, integer *ldx, doublereal *xact, integer *
+ ldxact, doublereal *ferr, doublereal *berr, doublereal *reslts)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1,
+ i__2;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Local variables */
+ integer i__, j, k, nz;
+ doublereal eps, tmp, diff, axbi;
+ integer imax;
+ doublereal unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ doublereal xnorm;
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal errbnd;
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DGTT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* general tridiagonal matrix of order n and op(A) = A or A**T, */
+/* depending on TRANS. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+/* and NZ = max. number of nonzeros in any row of A, plus 1 */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X and XACT. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X and XACT. NRHS >= 0. */
+
+/* DL (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) sub-diagonal elements of A. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* DU (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) super-diagonal elements of A. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.;
+ reslts[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ notran = lsame_(trans, "N");
+ nz = 4;
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = idamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ d__2 = (d__1 = x[imax + j * x_dim1], abs(d__1));
+ xnorm = max(d__2,unfl);
+ diff = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = diff, d__3 = (d__1 = x[i__ + j * x_dim1] - xact[i__ + j *
+ xact_dim1], abs(d__1));
+ diff = max(d__2,d__3);
+/* L10: */
+ }
+
+ if (xnorm > 1.) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1. / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
+ errbnd = max(d__1,d__2);
+ } else {
+ errbnd = 1. / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ if (notran) {
+ if (*n == 1) {
+ axbi = (d__1 = b[k * b_dim1 + 1], abs(d__1)) + (d__2 = d__[1]
+ * x[k * x_dim1 + 1], abs(d__2));
+ } else {
+ axbi = (d__1 = b[k * b_dim1 + 1], abs(d__1)) + (d__2 = d__[1]
+ * x[k * x_dim1 + 1], abs(d__2)) + (d__3 = du[1] * x[k
+ * x_dim1 + 2], abs(d__3));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ tmp = (d__1 = b[i__ + k * b_dim1], abs(d__1)) + (d__2 =
+ dl[i__ - 1] * x[i__ - 1 + k * x_dim1], abs(d__2))
+ + (d__3 = d__[i__] * x[i__ + k * x_dim1], abs(
+ d__3)) + (d__4 = du[i__] * x[i__ + 1 + k * x_dim1]
+ , abs(d__4));
+ axbi = min(axbi,tmp);
+/* L40: */
+ }
+ tmp = (d__1 = b[*n + k * b_dim1], abs(d__1)) + (d__2 = dl[*n
+ - 1] * x[*n - 1 + k * x_dim1], abs(d__2)) + (d__3 =
+ d__[*n] * x[*n + k * x_dim1], abs(d__3));
+ axbi = min(axbi,tmp);
+ }
+ } else {
+ if (*n == 1) {
+ axbi = (d__1 = b[k * b_dim1 + 1], abs(d__1)) + (d__2 = d__[1]
+ * x[k * x_dim1 + 1], abs(d__2));
+ } else {
+ axbi = (d__1 = b[k * b_dim1 + 1], abs(d__1)) + (d__2 = d__[1]
+ * x[k * x_dim1 + 1], abs(d__2)) + (d__3 = dl[1] * x[k
+ * x_dim1 + 2], abs(d__3));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ tmp = (d__1 = b[i__ + k * b_dim1], abs(d__1)) + (d__2 =
+ du[i__ - 1] * x[i__ - 1 + k * x_dim1], abs(d__2))
+ + (d__3 = d__[i__] * x[i__ + k * x_dim1], abs(
+ d__3)) + (d__4 = dl[i__] * x[i__ + 1 + k * x_dim1]
+ , abs(d__4));
+ axbi = min(axbi,tmp);
+/* L50: */
+ }
+ tmp = (d__1 = b[*n + k * b_dim1], abs(d__1)) + (d__2 = du[*n
+ - 1] * x[*n - 1 + k * x_dim1], abs(d__2)) + (d__3 =
+ d__[*n] * x[*n + k * x_dim1], abs(d__3));
+ axbi = min(axbi,tmp);
+ }
+ }
+/* Computing MAX */
+ d__1 = axbi, d__2 = nz * unfl;
+ tmp = berr[k] / (nz * eps + nz * unfl / max(d__1,d__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = max(reslts[2],tmp);
+ }
+/* L60: */
+ }
+
+ return 0;
+
+/* End of DGTT05 */
+
+} /* dgtt05_ */
diff --git a/TESTING/LIN/dlahilb.c b/TESTING/LIN/dlahilb.c
new file mode 100644
index 0000000..57902cd
--- /dev/null
+++ b/TESTING/LIN/dlahilb.c
@@ -0,0 +1,202 @@
+/* dlahilb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b4 = 0.;
+
+/* Subroutine */ int dlahilb_(integer *n, integer *nrhs, doublereal *a,
+ integer *lda, doublereal *x, integer *ldx, doublereal *b, integer *
+ ldb, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, x_dim1, x_offset, b_dim1, b_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, j, m, r__, ti, tm;
+ doublecomplex tmp;
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublecomplex *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
+/* Courant Institute, Argonne National Lab, and Rice University */
+/* 28 August, 2006 */
+
+/* David Vu <dtv at cs.berkeley.edu> */
+/* Yozo Hida <yozo at cs.berkeley.edu> */
+/* Jason Riedy <ejr at cs.berkeley.edu> */
+/* D. Halligan <dhalligan at berkeley.edu> */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAHILB generates an N by N scaled Hilbert matrix in A along with */
+/* NRHS right-hand sides in B and solutions in X such that A*X=B. */
+
+/* The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all */
+/* entries are integers. The right-hand sides are the first NRHS */
+/* columns of M * the identity matrix, and the solutions are the */
+/* first NRHS columns of the inverse Hilbert matrix. */
+
+/* The condition number of the Hilbert matrix grows exponentially with */
+/* its size, roughly as O(e ** (3.5*N)). Additionally, the inverse */
+/* Hilbert matrices beyond a relatively small dimension cannot be */
+/* generated exactly without extra precision. Precision is exhausted */
+/* when the largest entry in the inverse Hilbert matrix is greater than */
+/* 2 to the power of the number of bits in the fraction of the data type */
+/* used plus one, which is 24 for single precision. */
+
+/* In single, the generated solution is exact for N <= 6 and has */
+/* small componentwise error for 7 <= N <= 11. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The dimension of the matrix A. */
+
+/* NRHS (input) NRHS */
+/* The requested number of right-hand sides. */
+
+/* A (output) DOUBLE PRECISION array, dimension (LDA, N) */
+/* The generated scaled Hilbert matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= N. */
+
+/* X (output) DOUBLE PRECISION array, dimension (LDX, NRHS) */
+/* The generated exact solutions. Currently, the first NRHS */
+/* columns of the inverse Hilbert matrix. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= N. */
+
+/* B (output) DOUBLE PRECISION array, dimension (LDB, NRHS) */
+/* The generated right-hand sides. Currently, the first NRHS */
+/* columns of LCM(1, 2, ..., 2*N-1) * the identity matrix. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= N. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* = 1: N is too large; the data is still generated but may not */
+/* be not exact. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+/* .. Local Scalars .. */
+/* .. Parameters .. */
+/* NMAX_EXACT the largest dimension where the generated data is */
+/* exact. */
+/* NMAX_APPROX the largest dimension where the generated data has */
+/* a small componentwise relative error. */
+/* .. */
+/* .. External Functions */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --work;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0 || *n > 11) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*lda < *n) {
+ *info = -4;
+ } else if (*ldx < *n) {
+ *info = -6;
+ } else if (*ldb < *n) {
+ *info = -8;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("DLAHILB", &i__1);
+ return 0;
+ }
+ if (*n > 6) {
+ *info = 1;
+ }
+/* Compute M = the LCM of the integers [1, 2*N-1]. The largest */
+/* reasonable N is small enough that integers suffice (up to N = 11). */
+ m = 1;
+ i__1 = (*n << 1) - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ tm = m;
+ ti = i__;
+ r__ = tm % ti;
+ while(r__ != 0) {
+ tm = ti;
+ ti = r__;
+ r__ = tm % ti;
+ }
+ m = m / ti * i__;
+ }
+/* Generate the scaled Hilbert matrix in A */
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = (doublereal) m / (i__ + j - 1);
+ }
+ }
+/* Generate matrix B as simply the first NRHS columns of M * the */
+/* identity. */
+ d__1 = (doublereal) m;
+ tmp.r = d__1, tmp.i = 0.;
+ dlaset_("Full", n, nrhs, &c_b4, &tmp, &b[b_offset], ldb);
+/* Generate the true solutions in X. Because B = the first NRHS */
+/* columns of M*I, the true solutions are just the first NRHS columns */
+/* of the inverse Hilbert matrix. */
+ work[1] = (doublereal) (*n);
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ work[j] = work[j - 1] / (j - 1) * (j - 1 - *n) / (j - 1) * (*n + j -
+ 1);
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__ + j * x_dim1] = work[i__] * work[j] / (i__ + j - 1);
+ }
+ }
+ return 0;
+} /* dlahilb_ */
diff --git a/TESTING/LIN/dlaord.c b/TESTING/LIN/dlaord.c
new file mode 100644
index 0000000..958fabd
--- /dev/null
+++ b/TESTING/LIN/dlaord.c
@@ -0,0 +1,131 @@
+/* dlaord.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlaord_(char *job, integer *n, doublereal *x, integer *
+ incx)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, ix, inc;
+ doublereal temp;
+ extern logical lsame_(char *, char *);
+ integer ixnext;
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAORD sorts the elements of a vector x in increasing or decreasing */
+/* order. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER */
+/* = 'I': Sort in increasing order */
+/* = 'D': Sort in decreasing order */
+
+/* N (input) INTEGER */
+/* The length of the vector X. */
+
+/* X (input/output) DOUBLE PRECISION array, dimension */
+/* (1+(N-1)*INCX) */
+/* On entry, the vector of length n to be sorted. */
+/* On exit, the vector x is sorted in the prescribed order. */
+
+/* INCX (input) INTEGER */
+/* The spacing between successive elements of X. INCX >= 0. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --x;
+
+ /* Function Body */
+ inc = abs(*incx);
+ if (lsame_(job, "I")) {
+
+/* Sort in increasing order */
+
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ ix = (i__ - 1) * inc + 1;
+L10:
+ if (ix == 1) {
+ goto L20;
+ }
+ ixnext = ix - inc;
+ if (x[ix] > x[ixnext]) {
+ goto L20;
+ } else {
+ temp = x[ix];
+ x[ix] = x[ixnext];
+ x[ixnext] = temp;
+ }
+ ix = ixnext;
+ goto L10;
+L20:
+ ;
+ }
+
+ } else if (lsame_(job, "D")) {
+
+/* Sort in decreasing order */
+
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ ix = (i__ - 1) * inc + 1;
+L30:
+ if (ix == 1) {
+ goto L40;
+ }
+ ixnext = ix - inc;
+ if (x[ix] < x[ixnext]) {
+ goto L40;
+ } else {
+ temp = x[ix];
+ x[ix] = x[ixnext];
+ x[ixnext] = temp;
+ }
+ ix = ixnext;
+ goto L30;
+L40:
+ ;
+ }
+ }
+ return 0;
+
+/* End of DLAORD */
+
+} /* dlaord_ */
diff --git a/TESTING/LIN/dlaptm.c b/TESTING/LIN/dlaptm.c
new file mode 100644
index 0000000..78719f0
--- /dev/null
+++ b/TESTING/LIN/dlaptm.c
@@ -0,0 +1,183 @@
+/* dlaptm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlaptm_(integer *n, integer *nrhs, doublereal *alpha,
+ doublereal *d__, doublereal *e, doublereal *x, integer *ldx,
+ doublereal *beta, doublereal *b, integer *ldb)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAPTM multiplies an N by NRHS matrix X by a symmetric tridiagonal */
+/* matrix A and stores the result in a matrix B. The operation has the */
+/* form */
+
+/* B := alpha * A * X + beta * B */
+
+/* where alpha may be either 1. or -1. and beta may be 0., 1., or -1. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. */
+
+/* ALPHA (input) DOUBLE PRECISION */
+/* The scalar alpha. ALPHA must be 1. or -1.; otherwise, */
+/* it is assumed to be 0. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) subdiagonal or superdiagonal elements of A. */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The N by NRHS matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(N,1). */
+
+/* BETA (input) DOUBLE PRECISION */
+/* The scalar beta. BETA must be 0., 1., or -1.; otherwise, */
+/* it is assumed to be 1. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the N by NRHS matrix B. */
+/* On exit, B is overwritten by the matrix expression */
+/* B := alpha * A * X + beta * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(N,1). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Multiply B by BETA if BETA.NE.1. */
+
+ if (*beta == 0.) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (*beta == -1.) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = -b[i__ + j * b_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+ if (*alpha == 1.) {
+
+/* Compute B := B + A*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ b[j * b_dim1 + 1] += d__[1] * x[j * x_dim1 + 1];
+ } else {
+ b[j * b_dim1 + 1] = b[j * b_dim1 + 1] + d__[1] * x[j * x_dim1
+ + 1] + e[1] * x[j * x_dim1 + 2];
+ b[*n + j * b_dim1] = b[*n + j * b_dim1] + e[*n - 1] * x[*n -
+ 1 + j * x_dim1] + d__[*n] * x[*n + j * x_dim1];
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = b[i__ + j * b_dim1] + e[i__ - 1] *
+ x[i__ - 1 + j * x_dim1] + d__[i__] * x[i__ + j *
+ x_dim1] + e[i__] * x[i__ + 1 + j * x_dim1];
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else if (*alpha == -1.) {
+
+/* Compute B := B - A*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ b[j * b_dim1 + 1] -= d__[1] * x[j * x_dim1 + 1];
+ } else {
+ b[j * b_dim1 + 1] = b[j * b_dim1 + 1] - d__[1] * x[j * x_dim1
+ + 1] - e[1] * x[j * x_dim1 + 2];
+ b[*n + j * b_dim1] = b[*n + j * b_dim1] - e[*n - 1] * x[*n -
+ 1 + j * x_dim1] - d__[*n] * x[*n + j * x_dim1];
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = b[i__ + j * b_dim1] - e[i__ - 1] *
+ x[i__ - 1 + j * x_dim1] - d__[i__] * x[i__ + j *
+ x_dim1] - e[i__] * x[i__ + 1 + j * x_dim1];
+/* L70: */
+ }
+ }
+/* L80: */
+ }
+ }
+ return 0;
+
+/* End of DLAPTM */
+
+} /* dlaptm_ */
diff --git a/TESTING/LIN/dlarhs.c b/TESTING/LIN/dlarhs.c
new file mode 100644
index 0000000..a9e10ab
--- /dev/null
+++ b/TESTING/LIN/dlarhs.c
@@ -0,0 +1,398 @@
+/* dlarhs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static doublereal c_b32 = 1.;
+static doublereal c_b33 = 0.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dlarhs_(char *path, char *xtype, char *uplo, char *trans,
+ integer *m, integer *n, integer *kl, integer *ku, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *x, integer *ldx, doublereal *
+ b, integer *ldb, integer *iseed, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j;
+ char c1[1], c2[2];
+ integer mb, nx;
+ logical gen, tri, qrs, sym, band;
+ char diag[1];
+ logical tran;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *),
+ dgbmv_(char *, integer *, integer *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dsbmv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dtbmv_(char *,
+ char *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *), dtrmm_(char *,
+ char *, char *, char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *), dspmv_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *), dsymm_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dtpmv_(
+ char *, char *, char *, integer *, doublereal *, doublereal *,
+ integer *), dlacpy_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *,
+ doublereal *);
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARHS chooses a set of NRHS random solution vectors and sets */
+/* up the right hand sides for the linear system */
+/* op( A ) * X = B, */
+/* where op( A ) may be A or A' (transpose of A). */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The type of the real matrix A. PATH may be given in any */
+/* combination of upper and lower case. Valid types include */
+/* xGE: General m x n matrix */
+/* xGB: General banded matrix */
+/* xPO: Symmetric positive definite, 2-D storage */
+/* xPP: Symmetric positive definite packed */
+/* xPB: Symmetric positive definite banded */
+/* xSY: Symmetric indefinite, 2-D storage */
+/* xSP: Symmetric indefinite packed */
+/* xSB: Symmetric indefinite banded */
+/* xTR: Triangular */
+/* xTP: Triangular packed */
+/* xTB: Triangular banded */
+/* xQR: General m x n matrix */
+/* xLQ: General m x n matrix */
+/* xQL: General m x n matrix */
+/* xRQ: General m x n matrix */
+/* where the leading character indicates the precision. */
+
+/* XTYPE (input) CHARACTER*1 */
+/* Specifies how the exact solution X will be determined: */
+/* = 'N': New solution; generate a random X. */
+/* = 'C': Computed; use value of X on entry. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* matrix A is stored, if A is symmetric. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to the matrix A. */
+/* = 'N': System is A * x = b */
+/* = 'T': System is A'* x = b */
+/* = 'C': System is A'* x = b */
+
+/* M (input) INTEGER */
+/* The number or rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* Used only if A is a band matrix; specifies the number of */
+/* subdiagonals of A if A is a general band matrix or if A is */
+/* symmetric or triangular and UPLO = 'L'; specifies the number */
+/* of superdiagonals of A if A is symmetric or triangular and */
+/* UPLO = 'U'. 0 <= KL <= M-1. */
+
+/* KU (input) INTEGER */
+/* Used only if A is a general band matrix or if A is */
+/* triangular. */
+
+/* If PATH = xGB, specifies the number of superdiagonals of A, */
+/* and 0 <= KU <= N-1. */
+
+/* If PATH = xTR, xTP, or xTB, specifies whether or not the */
+/* matrix has unit diagonal: */
+/* = 1: matrix has non-unit diagonal (default) */
+/* = 2: matrix has unit diagonal */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors in the system A*X = B. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The test matrix whose type is given by PATH. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If PATH = xGB, LDA >= KL+KU+1. */
+/* If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1. */
+/* Otherwise, LDA >= max(1,M). */
+
+/* X (input or output) DOUBLE PRECISION array, dimension(LDX,NRHS) */
+/* On entry, if XTYPE = 'C' (for 'Computed'), then X contains */
+/* the exact solution to the system of linear equations. */
+/* On exit, if XTYPE = 'N' (for 'New'), then X is initialized */
+/* with random values. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M). */
+
+/* B (output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side vector(s) for the system of equations, */
+/* computed from B = op(A) * X, where op(A) is determined by */
+/* TRANS. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. If TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N). */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* The seed vector for the random number generator (used in */
+/* DLATMS). Modified on exit. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --iseed;
+
+ /* Function Body */
+ *info = 0;
+ *(unsigned char *)c1 = *(unsigned char *)path;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ tran = lsame_(trans, "T") || lsame_(trans, "C");
+ notran = ! tran;
+ gen = lsame_(path + 1, "G");
+ qrs = lsame_(path + 1, "Q") || lsame_(path + 2,
+ "Q");
+ sym = lsame_(path + 1, "P") || lsame_(path + 1,
+ "S");
+ tri = lsame_(path + 1, "T");
+ band = lsame_(path + 2, "B");
+ if (! lsame_(c1, "Double precision")) {
+ *info = -1;
+ } else if (! (lsame_(xtype, "N") || lsame_(xtype,
+ "C"))) {
+ *info = -2;
+ } else if ((sym || tri) && ! (lsame_(uplo, "U") ||
+ lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if ((gen || qrs) && ! (tran || lsame_(trans, "N"))) {
+ *info = -4;
+ } else if (*m < 0) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (band && *kl < 0) {
+ *info = -7;
+ } else if (band && *ku < 0) {
+ *info = -8;
+ } else if (*nrhs < 0) {
+ *info = -9;
+ } else if (! band && *lda < max(1,*m) || band && (sym || tri) && *lda < *
+ kl + 1 || band && gen && *lda < *kl + *ku + 1) {
+ *info = -11;
+ } else if (notran && *ldx < max(1,*n) || tran && *ldx < max(1,*m)) {
+ *info = -13;
+ } else if (notran && *ldb < max(1,*m) || tran && *ldb < max(1,*n)) {
+ *info = -15;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLARHS", &i__1);
+ return 0;
+ }
+
+/* Initialize X to NRHS random vectors unless XTYPE = 'C'. */
+
+ if (tran) {
+ nx = *m;
+ mb = *n;
+ } else {
+ nx = *n;
+ mb = *m;
+ }
+ if (! lsame_(xtype, "C")) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ dlarnv_(&c__2, &iseed[1], n, &x[j * x_dim1 + 1]);
+/* L10: */
+ }
+ }
+
+/* Multiply X by op( A ) using an appropriate */
+/* matrix multiply routine. */
+
+ if (lsamen_(&c__2, c2, "GE") || lsamen_(&c__2, c2,
+ "QR") || lsamen_(&c__2, c2, "LQ") || lsamen_(&c__2, c2, "QL") ||
+ lsamen_(&c__2, c2, "RQ")) {
+
+/* General matrix */
+
+ dgemm_(trans, "N", &mb, nrhs, &nx, &c_b32, &a[a_offset], lda, &x[
+ x_offset], ldx, &c_b33, &b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "PO") || lsamen_(&
+ c__2, c2, "SY")) {
+
+/* Symmetric matrix, 2-D storage */
+
+ dsymm_("Left", uplo, n, nrhs, &c_b32, &a[a_offset], lda, &x[x_offset],
+ ldx, &c_b33, &b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* General matrix, band storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ dgbmv_(trans, &mb, &nx, kl, ku, &c_b32, &a[a_offset], lda, &x[j *
+ x_dim1 + 1], &c__1, &c_b33, &b[j * b_dim1 + 1], &c__1);
+/* L20: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* Symmetric matrix, band storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ dsbmv_(uplo, n, kl, &c_b32, &a[a_offset], lda, &x[j * x_dim1 + 1],
+ &c__1, &c_b33, &b[j * b_dim1 + 1], &c__1);
+/* L30: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "PP") || lsamen_(&
+ c__2, c2, "SP")) {
+
+/* Symmetric matrix, packed storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ dspmv_(uplo, n, &c_b32, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
+ c_b33, &b[j * b_dim1 + 1], &c__1);
+/* L40: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "TR")) {
+
+/* Triangular matrix. Note that for triangular matrices, */
+/* KU = 1 => non-unit triangular */
+/* KU = 2 => unit triangular */
+
+ dlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ dtrmm_("Left", uplo, trans, diag, n, nrhs, &c_b32, &a[a_offset], lda,
+ &b[b_offset], ldb)
+ ;
+
+ } else if (lsamen_(&c__2, c2, "TP")) {
+
+/* Triangular matrix, packed storage */
+
+ dlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ dtpmv_(uplo, trans, diag, n, &a[a_offset], &b[j * b_dim1 + 1], &
+ c__1);
+/* L50: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "TB")) {
+
+/* Triangular matrix, banded storage */
+
+ dlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ dtbmv_(uplo, trans, diag, n, kl, &a[a_offset], lda, &b[j * b_dim1
+ + 1], &c__1);
+/* L60: */
+ }
+
+ } else {
+
+/* If PATH is none of the above, return with an error code. */
+
+ *info = -1;
+ i__1 = -(*info);
+ xerbla_("DLARHS", &i__1);
+ }
+
+ return 0;
+
+/* End of DLARHS */
+
+} /* dlarhs_ */
diff --git a/TESTING/LIN/dlatb4.c b/TESTING/LIN/dlatb4.c
new file mode 100644
index 0000000..2534508
--- /dev/null
+++ b/TESTING/LIN/dlatb4.c
@@ -0,0 +1,483 @@
+/* dlatb4.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+
+/* Subroutine */ int dlatb4_(char *path, integer *imat, integer *m, integer *
+ n, char *type__, integer *kl, integer *ku, doublereal *anorm, integer
+ *mode, doublereal *cndnum, char *dist)
+{
+ /* Initialized data */
+
+ static logical first = TRUE_;
+
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ char c2[2];
+ integer mat;
+ static doublereal eps, badc1, badc2, large, small;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern logical lsamen_(integer *, char *, char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLATB4 sets parameters for the matrix generator based on the type of */
+/* matrix to be generated. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name. */
+
+/* IMAT (input) INTEGER */
+/* An integer key describing which matrix to generate for this */
+/* path. */
+
+/* M (input) INTEGER */
+/* The number of rows in the matrix to be generated. */
+
+/* N (input) INTEGER */
+/* The number of columns in the matrix to be generated. */
+
+/* TYPE (output) CHARACTER*1 */
+/* The type of the matrix to be generated: */
+/* = 'S': symmetric matrix */
+/* = 'P': symmetric positive (semi)definite matrix */
+/* = 'N': nonsymmetric matrix */
+
+/* KL (output) INTEGER */
+/* The lower band width of the matrix to be generated. */
+
+/* KU (output) INTEGER */
+/* The upper band width of the matrix to be generated. */
+
+/* ANORM (output) DOUBLE PRECISION */
+/* The desired norm of the matrix to be generated. The diagonal */
+/* matrix of singular values or eigenvalues is scaled by this */
+/* value. */
+
+/* MODE (output) INTEGER */
+/* A key indicating how to choose the vector of eigenvalues. */
+
+/* CNDNUM (output) DOUBLE PRECISION */
+/* The desired condition number. */
+
+/* DIST (output) CHARACTER*1 */
+/* The type of distribution to be used by the random number */
+/* generator. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Set some constants for use in the subroutine. */
+
+ if (first) {
+ first = FALSE_;
+ eps = dlamch_("Precision");
+ badc2 = .1 / eps;
+ badc1 = sqrt(badc2);
+ small = dlamch_("Safe minimum");
+ large = 1. / small;
+
+/* If it looks like we're on a Cray, take the square root of */
+/* SMALL and LARGE to avoid overflow and underflow problems. */
+
+ dlabad_(&small, &large);
+ small = small / eps * .25;
+ large = 1. / small;
+ }
+
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set some parameters we don't plan to change. */
+
+ *(unsigned char *)dist = 'S';
+ *mode = 3;
+
+ if (lsamen_(&c__2, c2, "QR") || lsamen_(&c__2, c2,
+ "LQ") || lsamen_(&c__2, c2, "QL") || lsamen_(&c__2, c2, "RQ")) {
+
+/* xQR, xLQ, xQL, xRQ: Set parameters to generate a general */
+/* M x N matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the lower and upper bandwidths. */
+
+ if (*imat == 1) {
+ *kl = 0;
+ *ku = 0;
+ } else if (*imat == 2) {
+ *kl = 0;
+/* Computing MAX */
+ i__1 = *n - 1;
+ *ku = max(i__1,0);
+ } else if (*imat == 3) {
+/* Computing MAX */
+ i__1 = *m - 1;
+ *kl = max(i__1,0);
+ *ku = 0;
+ } else {
+/* Computing MAX */
+ i__1 = *m - 1;
+ *kl = max(i__1,0);
+/* Computing MAX */
+ i__1 = *n - 1;
+ *ku = max(i__1,0);
+ }
+
+/* Set the condition number and norm. */
+
+ if (*imat == 5) {
+ *cndnum = badc1;
+ } else if (*imat == 6) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.;
+ }
+
+ if (*imat == 7) {
+ *anorm = small;
+ } else if (*imat == 8) {
+ *anorm = large;
+ } else {
+ *anorm = 1.;
+ }
+
+ } else if (lsamen_(&c__2, c2, "GE")) {
+
+/* xGE: Set parameters to generate a general M x N matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the lower and upper bandwidths. */
+
+ if (*imat == 1) {
+ *kl = 0;
+ *ku = 0;
+ } else if (*imat == 2) {
+ *kl = 0;
+/* Computing MAX */
+ i__1 = *n - 1;
+ *ku = max(i__1,0);
+ } else if (*imat == 3) {
+/* Computing MAX */
+ i__1 = *m - 1;
+ *kl = max(i__1,0);
+ *ku = 0;
+ } else {
+/* Computing MAX */
+ i__1 = *m - 1;
+ *kl = max(i__1,0);
+/* Computing MAX */
+ i__1 = *n - 1;
+ *ku = max(i__1,0);
+ }
+
+/* Set the condition number and norm. */
+
+ if (*imat == 8) {
+ *cndnum = badc1;
+ } else if (*imat == 9) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.;
+ }
+
+ if (*imat == 10) {
+ *anorm = small;
+ } else if (*imat == 11) {
+ *anorm = large;
+ } else {
+ *anorm = 1.;
+ }
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* xGB: Set parameters to generate a general banded matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the condition number and norm. */
+
+ if (*imat == 5) {
+ *cndnum = badc1;
+ } else if (*imat == 6) {
+ *cndnum = badc2 * .1;
+ } else {
+ *cndnum = 2.;
+ }
+
+ if (*imat == 7) {
+ *anorm = small;
+ } else if (*imat == 8) {
+ *anorm = large;
+ } else {
+ *anorm = 1.;
+ }
+
+ } else if (lsamen_(&c__2, c2, "GT")) {
+
+/* xGT: Set parameters to generate a general tridiagonal matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the lower and upper bandwidths. */
+
+ if (*imat == 1) {
+ *kl = 0;
+ } else {
+ *kl = 1;
+ }
+ *ku = *kl;
+
+/* Set the condition number and norm. */
+
+ if (*imat == 3) {
+ *cndnum = badc1;
+ } else if (*imat == 4) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.;
+ }
+
+ if (*imat == 5 || *imat == 11) {
+ *anorm = small;
+ } else if (*imat == 6 || *imat == 12) {
+ *anorm = large;
+ } else {
+ *anorm = 1.;
+ }
+
+ } else if (lsamen_(&c__2, c2, "PO") || lsamen_(&
+ c__2, c2, "PP") || lsamen_(&c__2, c2, "SY") || lsamen_(&c__2, c2, "SP")) {
+
+/* xPO, xPP, xSY, xSP: Set parameters to generate a */
+/* symmetric matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = *(unsigned char *)c2;
+
+/* Set the lower and upper bandwidths. */
+
+ if (*imat == 1) {
+ *kl = 0;
+ } else {
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kl = max(i__1,0);
+ }
+ *ku = *kl;
+
+/* Set the condition number and norm. */
+
+ if (*imat == 6) {
+ *cndnum = badc1;
+ } else if (*imat == 7) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.;
+ }
+
+ if (*imat == 8) {
+ *anorm = small;
+ } else if (*imat == 9) {
+ *anorm = large;
+ } else {
+ *anorm = 1.;
+ }
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* xPB: Set parameters to generate a symmetric band matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'P';
+
+/* Set the norm and condition number. */
+
+ if (*imat == 5) {
+ *cndnum = badc1;
+ } else if (*imat == 6) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.;
+ }
+
+ if (*imat == 7) {
+ *anorm = small;
+ } else if (*imat == 8) {
+ *anorm = large;
+ } else {
+ *anorm = 1.;
+ }
+
+ } else if (lsamen_(&c__2, c2, "PT")) {
+
+/* xPT: Set parameters to generate a symmetric positive definite */
+/* tridiagonal matrix. */
+
+ *(unsigned char *)type__ = 'P';
+ if (*imat == 1) {
+ *kl = 0;
+ } else {
+ *kl = 1;
+ }
+ *ku = *kl;
+
+/* Set the condition number and norm. */
+
+ if (*imat == 3) {
+ *cndnum = badc1;
+ } else if (*imat == 4) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.;
+ }
+
+ if (*imat == 5 || *imat == 11) {
+ *anorm = small;
+ } else if (*imat == 6 || *imat == 12) {
+ *anorm = large;
+ } else {
+ *anorm = 1.;
+ }
+
+ } else if (lsamen_(&c__2, c2, "TR") || lsamen_(&
+ c__2, c2, "TP")) {
+
+/* xTR, xTP: Set parameters to generate a triangular matrix */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the lower and upper bandwidths. */
+
+ mat = abs(*imat);
+ if (mat == 1 || mat == 7) {
+ *kl = 0;
+ *ku = 0;
+ } else if (*imat < 0) {
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kl = max(i__1,0);
+ *ku = 0;
+ } else {
+ *kl = 0;
+/* Computing MAX */
+ i__1 = *n - 1;
+ *ku = max(i__1,0);
+ }
+
+/* Set the condition number and norm. */
+
+ if (mat == 3 || mat == 9) {
+ *cndnum = badc1;
+ } else if (mat == 4) {
+ *cndnum = badc2;
+ } else if (mat == 10) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.;
+ }
+
+ if (mat == 5) {
+ *anorm = small;
+ } else if (mat == 6) {
+ *anorm = large;
+ } else {
+ *anorm = 1.;
+ }
+
+ } else if (lsamen_(&c__2, c2, "TB")) {
+
+/* xTB: Set parameters to generate a triangular band matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the norm and condition number. */
+
+ if (*imat == 2 || *imat == 8) {
+ *cndnum = badc1;
+ } else if (*imat == 3 || *imat == 9) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.;
+ }
+
+ if (*imat == 4) {
+ *anorm = small;
+ } else if (*imat == 5) {
+ *anorm = large;
+ } else {
+ *anorm = 1.;
+ }
+ }
+ if (*n <= 1) {
+ *cndnum = 1.;
+ }
+
+ return 0;
+
+/* End of DLATB4 */
+
+} /* dlatb4_ */
diff --git a/TESTING/LIN/dlatb5.c b/TESTING/LIN/dlatb5.c
new file mode 100644
index 0000000..8bf7eab
--- /dev/null
+++ b/TESTING/LIN/dlatb5.c
@@ -0,0 +1,184 @@
+/* dlatb5.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlatb5_(char *path, integer *imat, integer *n, char *
+ type__, integer *kl, integer *ku, doublereal *anorm, integer *mode,
+ doublereal *cndnum, char *dist)
+{
+ /* Initialized data */
+
+ static logical first = TRUE_;
+
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ char c2[2];
+ static doublereal eps, badc1, badc2, large, small;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLATB5 sets parameters for the matrix generator based on the type */
+/* of matrix to be generated. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name. */
+
+/* IMAT (input) INTEGER */
+/* An integer key describing which matrix to generate for this */
+/* path. */
+
+/* N (input) INTEGER */
+/* The number of rows and columns in the matrix to be generated. */
+
+/* TYPE (output) CHARACTER*1 */
+/* The type of the matrix to be generated: */
+/* = 'S': symmetric matrix */
+/* = 'P': symmetric positive (semi)definite matrix */
+/* = 'N': nonsymmetric matrix */
+
+/* KL (output) INTEGER */
+/* The lower band width of the matrix to be generated. */
+
+/* KU (output) INTEGER */
+/* The upper band width of the matrix to be generated. */
+
+/* ANORM (output) DOUBLE PRECISION */
+/* The desired norm of the matrix to be generated. The diagonal */
+/* matrix of singular values or eigenvalues is scaled by this */
+/* value. */
+
+/* MODE (output) INTEGER */
+/* A key indicating how to choose the vector of eigenvalues. */
+
+/* CNDNUM (output) DOUBLE PRECISION */
+/* The desired condition number. */
+
+/* DIST (output) CHARACTER*1 */
+/* The type of distribution to be used by the random number */
+/* generator. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Set some constants for use in the subroutine. */
+
+ if (first) {
+ first = FALSE_;
+ eps = dlamch_("Precision");
+ badc2 = .1 / eps;
+ badc1 = sqrt(badc2);
+ small = dlamch_("Safe minimum");
+ large = 1. / small;
+
+/* If it looks like we're on a Cray, take the square root of */
+/* SMALL and LARGE to avoid overflow and underflow problems. */
+
+ dlabad_(&small, &large);
+ small = small / eps * .25;
+ large = 1. / small;
+ }
+
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set some parameters */
+
+ *(unsigned char *)dist = 'S';
+ *mode = 3;
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = *(unsigned char *)c2;
+
+/* Set the lower and upper bandwidths. */
+
+ if (*imat == 1) {
+ *kl = 0;
+ } else {
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kl = max(i__1,0);
+ }
+ *ku = *kl;
+
+/* Set the condition number and norm.etc */
+
+ if (*imat == 3) {
+ *cndnum = 1e12;
+ *mode = 2;
+ } else if (*imat == 4) {
+ *cndnum = 1e12;
+ *mode = 1;
+ } else if (*imat == 5) {
+ *cndnum = 1e12;
+ *mode = 3;
+ } else if (*imat == 6) {
+ *cndnum = badc1;
+ } else if (*imat == 7) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.;
+ }
+
+ if (*imat == 8) {
+ *anorm = small;
+ } else if (*imat == 9) {
+ *anorm = large;
+ } else {
+ *anorm = 1.;
+ }
+
+ if (*n <= 1) {
+ *cndnum = 1.;
+ }
+
+ return 0;
+
+/* End of DLATB5 */
+
+} /* dlatb5_ */
diff --git a/TESTING/LIN/dlattb.c b/TESTING/LIN/dlattb.c
new file mode 100644
index 0000000..3f662e1
--- /dev/null
+++ b/TESTING/LIN/dlattb.c
@@ -0,0 +1,858 @@
+/* dlattb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static doublereal c_b36 = 2.;
+static doublereal c_b47 = 1.;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dlattb_(integer *imat, char *uplo, char *trans, char *
+ diag, integer *iseed, integer *n, integer *kd, doublereal *ab,
+ integer *ldab, doublereal *b, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal), d_sign(doublereal *, doublereal *), pow_dd(
+ doublereal *, doublereal *);
+
+ /* Local variables */
+ integer i__, j, kl, ku, iy;
+ doublereal ulp, sfac;
+ integer ioff, mode, lenj;
+ char path[3], dist[1];
+ doublereal unfl, rexp;
+ char type__[1];
+ doublereal texp, star1, plus1, plus2, bscal;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ doublereal tscal, anorm, bnorm, tleft;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dswap_(integer *, doublereal *, integer
+ *, doublereal *, integer *);
+ logical upper;
+ doublereal tnorm;
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), dlabad_(doublereal
+ *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern doublereal dlarnd_(integer *, integer *);
+ char packit[1];
+ doublereal bignum, cndnum;
+ extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublereal *, integer *, doublereal
+ *, integer *), dlarnv_(integer *, integer
+ *, integer *, doublereal *);
+ integer jcount;
+ doublereal smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLATTB generates a triangular test matrix in 2-dimensional storage. */
+/* IMAT and UPLO uniquely specify the properties of the test matrix, */
+/* which is returned in the array A. */
+
+/* Arguments */
+/* ========= */
+
+/* IMAT (input) INTEGER */
+/* An integer key describing which matrix to generate for this */
+/* path. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A will be upper or lower */
+/* triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies whether the matrix or its transpose will be used. */
+/* = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose (= transpose) */
+
+/* DIAG (output) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* The seed vector for the random number generator (used in */
+/* DLATMS). Modified on exit. */
+
+/* N (input) INTEGER */
+/* The order of the matrix to be generated. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the banded */
+/* triangular matrix A. KD >= 0. */
+
+/* AB (output) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The upper or lower triangular banded matrix A, stored in the */
+/* first KD+1 rows of AB. Let j be a column of A, 1<=j<=n. */
+/* If UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j. */
+/* If UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iseed;
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --b;
+ --work;
+
+ /* Function Body */
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "TB", (ftnlen)2, (ftnlen)2);
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ smlnum = unfl;
+ bignum = (1. - ulp) / smlnum;
+ dlabad_(&smlnum, &bignum);
+ if (*imat >= 6 && *imat <= 9 || *imat == 17) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ *info = 0;
+
+/* Quick return if N.LE.0. */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Call DLATB4 to set parameters for SLATMS. */
+
+ upper = lsame_(uplo, "U");
+ if (upper) {
+ dlatb4_(path, imat, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ ku = *kd;
+/* Computing MAX */
+ i__1 = 0, i__2 = *kd - *n + 1;
+ ioff = max(i__1,i__2) + 1;
+ kl = 0;
+ *(unsigned char *)packit = 'Q';
+ } else {
+ i__1 = -(*imat);
+ dlatb4_(path, &i__1, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ kl = *kd;
+ ioff = 1;
+ ku = 0;
+ *(unsigned char *)packit = 'B';
+ }
+
+/* IMAT <= 5: Non-unit triangular matrix */
+
+ if (*imat <= 5) {
+ dlatms_(n, n, dist, &iseed[1], type__, &b[1], &mode, &cndnum, &anorm,
+ &kl, &ku, packit, &ab[ioff + ab_dim1], ldab, &work[1], info);
+
+/* IMAT > 5: Unit triangular matrix */
+/* The diagonal is deliberately set to something other than 1. */
+
+/* IMAT = 6: Matrix is the identity */
+
+ } else if (*imat == 6) {
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = 1, i__3 = *kd + 2 - j;
+ i__4 = *kd;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ ab[i__ + j * ab_dim1] = 0.;
+/* L10: */
+ }
+ ab[*kd + 1 + j * ab_dim1] = (doublereal) j;
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ab[j * ab_dim1 + 1] = (doublereal) j;
+/* Computing MIN */
+ i__2 = *kd + 1, i__3 = *n - j + 1;
+ i__4 = min(i__2,i__3);
+ for (i__ = 2; i__ <= i__4; ++i__) {
+ ab[i__ + j * ab_dim1] = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+/* IMAT > 6: Non-trivial unit triangular matrix */
+
+/* A unit triangular matrix T with condition CNDNUM is formed. */
+/* In this version, T only has bandwidth 2, the rest of it is zero. */
+
+ } else if (*imat <= 9) {
+ tnorm = sqrt(cndnum);
+
+/* Initialize AB to zero. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__2 = *kd + 2 - j;
+ i__3 = *kd;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ ab[i__ + j * ab_dim1] = 0.;
+/* L50: */
+ }
+ ab[*kd + 1 + j * ab_dim1] = (doublereal) j;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = *kd + 1, i__2 = *n - j + 1;
+ i__3 = min(i__4,i__2);
+ for (i__ = 2; i__ <= i__3; ++i__) {
+ ab[i__ + j * ab_dim1] = 0.;
+/* L70: */
+ }
+ ab[j * ab_dim1 + 1] = (doublereal) j;
+/* L80: */
+ }
+ }
+
+/* Special case: T is tridiagonal. Set every other offdiagonal */
+/* so that the matrix has norm TNORM+1. */
+
+ if (*kd == 1) {
+ if (upper) {
+ d__1 = dlarnd_(&c__2, &iseed[1]);
+ ab[(ab_dim1 << 1) + 1] = d_sign(&tnorm, &d__1);
+ lenj = (*n - 3) / 2;
+ dlarnv_(&c__2, &iseed[1], &lenj, &work[1]);
+ i__1 = lenj;
+ for (j = 1; j <= i__1; ++j) {
+ ab[(j + 1 << 1) * ab_dim1 + 1] = tnorm * work[j];
+/* L90: */
+ }
+ } else {
+ d__1 = dlarnd_(&c__2, &iseed[1]);
+ ab[ab_dim1 + 2] = d_sign(&tnorm, &d__1);
+ lenj = (*n - 3) / 2;
+ dlarnv_(&c__2, &iseed[1], &lenj, &work[1]);
+ i__1 = lenj;
+ for (j = 1; j <= i__1; ++j) {
+ ab[((j << 1) + 1) * ab_dim1 + 2] = tnorm * work[j];
+/* L100: */
+ }
+ }
+ } else if (*kd > 1) {
+
+/* Form a unit triangular matrix T with condition CNDNUM. T is */
+/* given by */
+/* | 1 + * | */
+/* | 1 + | */
+/* T = | 1 + * | */
+/* | 1 + | */
+/* | 1 + * | */
+/* | 1 + | */
+/* | . . . | */
+/* Each element marked with a '*' is formed by taking the product */
+/* of the adjacent elements marked with '+'. The '*'s can be */
+/* chosen freely, and the '+'s are chosen so that the inverse of */
+/* T will have elements of the same magnitude as T. */
+
+/* The two offdiagonals of T are stored in WORK. */
+
+ d__1 = dlarnd_(&c__2, &iseed[1]);
+ star1 = d_sign(&tnorm, &d__1);
+ sfac = sqrt(tnorm);
+ d__1 = dlarnd_(&c__2, &iseed[1]);
+ plus1 = d_sign(&sfac, &d__1);
+ i__1 = *n;
+ for (j = 1; j <= i__1; j += 2) {
+ plus2 = star1 / plus1;
+ work[j] = plus1;
+ work[*n + j] = star1;
+ if (j + 1 <= *n) {
+ work[j + 1] = plus2;
+ work[*n + j + 1] = 0.;
+ plus1 = star1 / plus2;
+
+/* Generate a new *-value with norm between sqrt(TNORM) */
+/* and TNORM. */
+
+ rexp = dlarnd_(&c__2, &iseed[1]);
+ if (rexp < 0.) {
+ d__1 = 1. - rexp;
+ star1 = -pow_dd(&sfac, &d__1);
+ } else {
+ d__1 = rexp + 1.;
+ star1 = pow_dd(&sfac, &d__1);
+ }
+ }
+/* L110: */
+ }
+
+/* Copy the tridiagonal T to AB. */
+
+ if (upper) {
+ i__1 = *n - 1;
+ dcopy_(&i__1, &work[1], &c__1, &ab[*kd + (ab_dim1 << 1)],
+ ldab);
+ i__1 = *n - 2;
+ dcopy_(&i__1, &work[*n + 1], &c__1, &ab[*kd - 1 + ab_dim1 * 3]
+, ldab);
+ } else {
+ i__1 = *n - 1;
+ dcopy_(&i__1, &work[1], &c__1, &ab[ab_dim1 + 2], ldab);
+ i__1 = *n - 2;
+ dcopy_(&i__1, &work[*n + 1], &c__1, &ab[ab_dim1 + 3], ldab);
+ }
+ }
+
+/* IMAT > 9: Pathological test cases. These triangular matrices */
+/* are badly scaled or badly conditioned, so when used in solving a */
+/* triangular system they may cause overflow in the solution vector. */
+
+ } else if (*imat == 10) {
+
+/* Type 10: Generate a triangular matrix with elements between */
+/* -1 and 1. Give the diagonal norm 2 to make it well-conditioned. */
+/* Make the right hand side large so that it requires scaling. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j, i__4 = *kd + 1;
+ lenj = min(i__3,i__4);
+ dlarnv_(&c__2, &iseed[1], &lenj, &ab[*kd + 2 - lenj + j *
+ ab_dim1]);
+ ab[*kd + 1 + j * ab_dim1] = d_sign(&c_b36, &ab[*kd + 1 + j *
+ ab_dim1]);
+/* L120: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n - j + 1, i__4 = *kd + 1;
+ lenj = min(i__3,i__4);
+ if (lenj > 0) {
+ dlarnv_(&c__2, &iseed[1], &lenj, &ab[j * ab_dim1 + 1]);
+ }
+ ab[j * ab_dim1 + 1] = d_sign(&c_b36, &ab[j * ab_dim1 + 1]);
+/* L130: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ dlarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = idamax_(n, &b[1], &c__1);
+ bnorm = (d__1 = b[iy], abs(d__1));
+ bscal = bignum / max(1.,bnorm);
+ dscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 11) {
+
+/* Type 11: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 11, the offdiagonal elements are small (CNORM(j) < 1). */
+
+ dlarnv_(&c__2, &iseed[1], n, &b[1]);
+ tscal = 1. / (doublereal) (*kd + 1);
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j, i__4 = *kd + 1;
+ lenj = min(i__3,i__4);
+ dlarnv_(&c__2, &iseed[1], &lenj, &ab[*kd + 2 - lenj + j *
+ ab_dim1]);
+ i__3 = lenj - 1;
+ dscal_(&i__3, &tscal, &ab[*kd + 2 - lenj + j * ab_dim1], &
+ c__1);
+ ab[*kd + 1 + j * ab_dim1] = d_sign(&c_b47, &ab[*kd + 1 + j *
+ ab_dim1]);
+/* L140: */
+ }
+ ab[*kd + 1 + *n * ab_dim1] = smlnum * ab[*kd + 1 + *n * ab_dim1];
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n - j + 1, i__4 = *kd + 1;
+ lenj = min(i__3,i__4);
+ dlarnv_(&c__2, &iseed[1], &lenj, &ab[j * ab_dim1 + 1]);
+ if (lenj > 1) {
+ i__3 = lenj - 1;
+ dscal_(&i__3, &tscal, &ab[j * ab_dim1 + 2], &c__1);
+ }
+ ab[j * ab_dim1 + 1] = d_sign(&c_b47, &ab[j * ab_dim1 + 1]);
+/* L150: */
+ }
+ ab[ab_dim1 + 1] = smlnum * ab[ab_dim1 + 1];
+ }
+
+ } else if (*imat == 12) {
+
+/* Type 12: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 12, the offdiagonal elements are O(1) (CNORM(j) > 1). */
+
+ dlarnv_(&c__2, &iseed[1], n, &b[1]);
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j, i__4 = *kd + 1;
+ lenj = min(i__3,i__4);
+ dlarnv_(&c__2, &iseed[1], &lenj, &ab[*kd + 2 - lenj + j *
+ ab_dim1]);
+ ab[*kd + 1 + j * ab_dim1] = d_sign(&c_b47, &ab[*kd + 1 + j *
+ ab_dim1]);
+/* L160: */
+ }
+ ab[*kd + 1 + *n * ab_dim1] = smlnum * ab[*kd + 1 + *n * ab_dim1];
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n - j + 1, i__4 = *kd + 1;
+ lenj = min(i__3,i__4);
+ dlarnv_(&c__2, &iseed[1], &lenj, &ab[j * ab_dim1 + 1]);
+ ab[j * ab_dim1 + 1] = d_sign(&c_b47, &ab[j * ab_dim1 + 1]);
+/* L170: */
+ }
+ ab[ab_dim1 + 1] = smlnum * ab[ab_dim1 + 1];
+ }
+
+ } else if (*imat == 13) {
+
+/* Type 13: T is diagonal with small numbers on the diagonal to */
+/* make the growth factor underflow, but a small right hand side */
+/* chosen so that the solution does not overflow. */
+
+ if (upper) {
+ jcount = 1;
+ for (j = *n; j >= 1; --j) {
+/* Computing MAX */
+ i__1 = 1, i__3 = *kd + 1 - (j - 1);
+ i__4 = *kd;
+ for (i__ = max(i__1,i__3); i__ <= i__4; ++i__) {
+ ab[i__ + j * ab_dim1] = 0.;
+/* L180: */
+ }
+ if (jcount <= 2) {
+ ab[*kd + 1 + j * ab_dim1] = smlnum;
+ } else {
+ ab[*kd + 1 + j * ab_dim1] = 1.;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+/* L190: */
+ }
+ } else {
+ jcount = 1;
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MIN */
+ i__3 = *n - j + 1, i__2 = *kd + 1;
+ i__1 = min(i__3,i__2);
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ ab[i__ + j * ab_dim1] = 0.;
+/* L200: */
+ }
+ if (jcount <= 2) {
+ ab[j * ab_dim1 + 1] = smlnum;
+ } else {
+ ab[j * ab_dim1 + 1] = 1.;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+/* L210: */
+ }
+ }
+
+/* Set the right hand side alternately zero and small. */
+
+ if (upper) {
+ b[1] = 0.;
+ for (i__ = *n; i__ >= 2; i__ += -2) {
+ b[i__] = 0.;
+ b[i__ - 1] = smlnum;
+/* L220: */
+ }
+ } else {
+ b[*n] = 0.;
+ i__4 = *n - 1;
+ for (i__ = 1; i__ <= i__4; i__ += 2) {
+ b[i__] = 0.;
+ b[i__ + 1] = smlnum;
+/* L230: */
+ }
+ }
+
+ } else if (*imat == 14) {
+
+/* Type 14: Make the diagonal elements small to cause gradual */
+/* overflow when dividing by T(j,j). To control the amount of */
+/* scaling needed, the matrix is bidiagonal. */
+
+ texp = 1. / (doublereal) (*kd + 1);
+ tscal = pow_dd(&smlnum, &texp);
+ dlarnv_(&c__2, &iseed[1], n, &b[1]);
+ if (upper) {
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MAX */
+ i__1 = 1, i__3 = *kd + 2 - j;
+ i__2 = *kd;
+ for (i__ = max(i__1,i__3); i__ <= i__2; ++i__) {
+ ab[i__ + j * ab_dim1] = 0.;
+/* L240: */
+ }
+ if (j > 1 && *kd > 0) {
+ ab[*kd + j * ab_dim1] = -1.;
+ }
+ ab[*kd + 1 + j * ab_dim1] = tscal;
+/* L250: */
+ }
+ b[*n] = 1.;
+ } else {
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MIN */
+ i__1 = *n - j + 1, i__3 = *kd + 1;
+ i__2 = min(i__1,i__3);
+ for (i__ = 3; i__ <= i__2; ++i__) {
+ ab[i__ + j * ab_dim1] = 0.;
+/* L260: */
+ }
+ if (j < *n && *kd > 0) {
+ ab[j * ab_dim1 + 2] = -1.;
+ }
+ ab[j * ab_dim1 + 1] = tscal;
+/* L270: */
+ }
+ b[1] = 1.;
+ }
+
+ } else if (*imat == 15) {
+
+/* Type 15: One zero diagonal element. */
+
+ iy = *n / 2 + 1;
+ if (upper) {
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MIN */
+ i__2 = j, i__1 = *kd + 1;
+ lenj = min(i__2,i__1);
+ dlarnv_(&c__2, &iseed[1], &lenj, &ab[*kd + 2 - lenj + j *
+ ab_dim1]);
+ if (j != iy) {
+ ab[*kd + 1 + j * ab_dim1] = d_sign(&c_b36, &ab[*kd + 1 +
+ j * ab_dim1]);
+ } else {
+ ab[*kd + 1 + j * ab_dim1] = 0.;
+ }
+/* L280: */
+ }
+ } else {
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MIN */
+ i__2 = *n - j + 1, i__1 = *kd + 1;
+ lenj = min(i__2,i__1);
+ dlarnv_(&c__2, &iseed[1], &lenj, &ab[j * ab_dim1 + 1]);
+ if (j != iy) {
+ ab[j * ab_dim1 + 1] = d_sign(&c_b36, &ab[j * ab_dim1 + 1])
+ ;
+ } else {
+ ab[j * ab_dim1 + 1] = 0.;
+ }
+/* L290: */
+ }
+ }
+ dlarnv_(&c__2, &iseed[1], n, &b[1]);
+ dscal_(n, &c_b36, &b[1], &c__1);
+
+ } else if (*imat == 16) {
+
+/* Type 16: Make the offdiagonal elements large to cause overflow */
+/* when adding a column of T. In the non-transposed case, the */
+/* matrix is constructed to cause overflow when adding a column in */
+/* every other step. */
+
+ tscal = unfl / ulp;
+ tscal = (1. - ulp) / tscal;
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+ i__2 = *kd + 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ab[i__ + j * ab_dim1] = 0.;
+/* L300: */
+ }
+/* L310: */
+ }
+ texp = 1.;
+ if (*kd > 0) {
+ if (upper) {
+ i__4 = -(*kd);
+ for (j = *n; i__4 < 0 ? j >= 1 : j <= 1; j += i__4) {
+/* Computing MAX */
+ i__1 = 1, i__3 = j - *kd + 1;
+ i__2 = max(i__1,i__3);
+ for (i__ = j; i__ >= i__2; i__ += -2) {
+ ab[j - i__ + 1 + i__ * ab_dim1] = -tscal / (
+ doublereal) (*kd + 2);
+ ab[*kd + 1 + i__ * ab_dim1] = 1.;
+ b[i__] = texp * (1. - ulp);
+/* Computing MAX */
+ i__1 = 1, i__3 = j - *kd + 1;
+ if (i__ > max(i__1,i__3)) {
+ ab[j - i__ + 2 + (i__ - 1) * ab_dim1] = -(tscal /
+ (doublereal) (*kd + 2)) / (doublereal) (*
+ kd + 3);
+ ab[*kd + 1 + (i__ - 1) * ab_dim1] = 1.;
+ b[i__ - 1] = texp * (doublereal) ((*kd + 1) * (*
+ kd + 1) + *kd);
+ }
+ texp *= 2.;
+/* L320: */
+ }
+/* Computing MAX */
+ i__2 = 1, i__1 = j - *kd + 1;
+ b[max(i__2,i__1)] = (doublereal) (*kd + 2) / (doublereal)
+ (*kd + 3) * tscal;
+/* L330: */
+ }
+ } else {
+ i__4 = *n;
+ i__2 = *kd;
+ for (j = 1; i__2 < 0 ? j >= i__4 : j <= i__4; j += i__2) {
+ texp = 1.;
+/* Computing MIN */
+ i__1 = *kd + 1, i__3 = *n - j + 1;
+ lenj = min(i__1,i__3);
+/* Computing MIN */
+ i__3 = *n, i__5 = j + *kd - 1;
+ i__1 = min(i__3,i__5);
+ for (i__ = j; i__ <= i__1; i__ += 2) {
+ ab[lenj - (i__ - j) + j * ab_dim1] = -tscal / (
+ doublereal) (*kd + 2);
+ ab[j * ab_dim1 + 1] = 1.;
+ b[j] = texp * (1. - ulp);
+/* Computing MIN */
+ i__3 = *n, i__5 = j + *kd - 1;
+ if (i__ < min(i__3,i__5)) {
+ ab[lenj - (i__ - j + 1) + (i__ + 1) * ab_dim1] =
+ -(tscal / (doublereal) (*kd + 2)) / (
+ doublereal) (*kd + 3);
+ ab[(i__ + 1) * ab_dim1 + 1] = 1.;
+ b[i__ + 1] = texp * (doublereal) ((*kd + 1) * (*
+ kd + 1) + *kd);
+ }
+ texp *= 2.;
+/* L340: */
+ }
+/* Computing MIN */
+ i__1 = *n, i__3 = j + *kd - 1;
+ b[min(i__1,i__3)] = (doublereal) (*kd + 2) / (doublereal)
+ (*kd + 3) * tscal;
+/* L350: */
+ }
+ }
+ } else {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ ab[j * ab_dim1 + 1] = 1.;
+ b[j] = (doublereal) j;
+/* L360: */
+ }
+ }
+
+ } else if (*imat == 17) {
+
+/* Type 17: Generate a unit triangular matrix with elements */
+/* between -1 and 1, and make the right hand side large so that it */
+/* requires scaling. */
+
+ if (upper) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = j - 1;
+ lenj = min(i__4,*kd);
+ dlarnv_(&c__2, &iseed[1], &lenj, &ab[*kd + 1 - lenj + j *
+ ab_dim1]);
+ ab[*kd + 1 + j * ab_dim1] = (doublereal) j;
+/* L370: */
+ }
+ } else {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = *n - j;
+ lenj = min(i__4,*kd);
+ if (lenj > 0) {
+ dlarnv_(&c__2, &iseed[1], &lenj, &ab[j * ab_dim1 + 2]);
+ }
+ ab[j * ab_dim1 + 1] = (doublereal) j;
+/* L380: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ dlarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = idamax_(n, &b[1], &c__1);
+ bnorm = (d__1 = b[iy], abs(d__1));
+ bscal = bignum / max(1.,bnorm);
+ dscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 18) {
+
+/* Type 18: Generate a triangular matrix with elements between */
+/* BIGNUM/KD and BIGNUM so that at least one of the column */
+/* norms will exceed BIGNUM. */
+
+/* Computing MAX */
+ d__1 = 1., d__2 = (doublereal) (*kd);
+ tleft = bignum / max(d__1,d__2);
+ tscal = bignum * ((doublereal) (*kd) / (doublereal) (*kd + 1));
+ if (upper) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = j, i__1 = *kd + 1;
+ lenj = min(i__4,i__1);
+ dlarnv_(&c__2, &iseed[1], &lenj, &ab[*kd + 2 - lenj + j *
+ ab_dim1]);
+ i__4 = *kd + 1;
+ for (i__ = *kd + 2 - lenj; i__ <= i__4; ++i__) {
+ ab[i__ + j * ab_dim1] = d_sign(&tleft, &ab[i__ + j *
+ ab_dim1]) + tscal * ab[i__ + j * ab_dim1];
+/* L390: */
+ }
+/* L400: */
+ }
+ } else {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = *n - j + 1, i__1 = *kd + 1;
+ lenj = min(i__4,i__1);
+ dlarnv_(&c__2, &iseed[1], &lenj, &ab[j * ab_dim1 + 1]);
+ i__4 = lenj;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ ab[i__ + j * ab_dim1] = d_sign(&tleft, &ab[i__ + j *
+ ab_dim1]) + tscal * ab[i__ + j * ab_dim1];
+/* L410: */
+ }
+/* L420: */
+ }
+ }
+ dlarnv_(&c__2, &iseed[1], n, &b[1]);
+ dscal_(n, &c_b36, &b[1], &c__1);
+ }
+
+/* Flip the matrix if the transpose will be used. */
+
+ if (! lsame_(trans, "N")) {
+ if (upper) {
+ i__2 = *n / 2;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = *n - (j << 1) + 1, i__1 = *kd + 1;
+ lenj = min(i__4,i__1);
+ i__4 = *ldab - 1;
+ dswap_(&lenj, &ab[*kd + 1 + j * ab_dim1], &i__4, &ab[*kd + 2
+ - lenj + (*n - j + 1) * ab_dim1], &c_n1);
+/* L430: */
+ }
+ } else {
+ i__2 = *n / 2;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = *n - (j << 1) + 1, i__1 = *kd + 1;
+ lenj = min(i__4,i__1);
+ i__4 = -(*ldab) + 1;
+ dswap_(&lenj, &ab[j * ab_dim1 + 1], &c__1, &ab[lenj + (*n - j
+ + 2 - lenj) * ab_dim1], &i__4);
+/* L440: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DLATTB */
+
+} /* dlattb_ */
diff --git a/TESTING/LIN/dlattp.c b/TESTING/LIN/dlattp.c
new file mode 100644
index 0000000..e8feaa2
--- /dev/null
+++ b/TESTING/LIN/dlattp.c
@@ -0,0 +1,943 @@
+/* dlattp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static doublereal c_b36 = 2.;
+static doublereal c_b48 = 1.;
+
+/* Subroutine */ int dlattp_(integer *imat, char *uplo, char *trans, char *
+ diag, integer *iseed, integer *n, doublereal *a, doublereal *b,
+ doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double pow_dd(doublereal *, doublereal *), sqrt(doublereal), d_sign(
+ doublereal *, doublereal *);
+
+ /* Local variables */
+ doublereal c__;
+ integer i__, j;
+ doublereal s, t, x, y, z__;
+ integer jc;
+ doublereal ra;
+ integer jj;
+ doublereal rb;
+ integer jl, kl, jr, ku, iy, jx;
+ doublereal ulp, sfac;
+ integer mode;
+ char path[3], dist[1];
+ doublereal unfl;
+ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ doublereal rexp;
+ char type__[1];
+ doublereal texp, star1, plus1, plus2, bscal;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ doublereal tscal, anorm, bnorm, tleft;
+ extern /* Subroutine */ int drotg_(doublereal *, doublereal *, doublereal
+ *, doublereal *);
+ doublereal stemp;
+ logical upper;
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), dlabad_(doublereal
+ *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern doublereal dlarnd_(integer *, integer *);
+ char packit[1];
+ doublereal bignum, cndnum;
+ extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublereal *, integer *, doublereal
+ *, integer *), dlarnv_(integer *, integer
+ *, integer *, doublereal *);
+ integer jcnext, jcount;
+ doublereal smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLATTP generates a triangular test matrix in packed storage. */
+/* IMAT and UPLO uniquely specify the properties of the test */
+/* matrix, which is returned in the array AP. */
+
+/* Arguments */
+/* ========= */
+
+/* IMAT (input) INTEGER */
+/* An integer key describing which matrix to generate for this */
+/* path. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A will be upper or lower */
+/* triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies whether the matrix or its transpose will be used. */
+/* = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose (= Transpose) */
+
+/* DIAG (output) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* The seed vector for the random number generator (used in */
+/* DLATMS). Modified on exit. */
+
+/* N (input) INTEGER */
+/* The order of the matrix to be generated. */
+
+/* A (output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
+
+/* B (output) DOUBLE PRECISION array, dimension (N) */
+/* The right hand side vector, if IMAT > 10. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --b;
+ --a;
+ --iseed;
+
+ /* Function Body */
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "TP", (ftnlen)2, (ftnlen)2);
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ smlnum = unfl;
+ bignum = (1. - ulp) / smlnum;
+ dlabad_(&smlnum, &bignum);
+ if (*imat >= 7 && *imat <= 10 || *imat == 18) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ *info = 0;
+
+/* Quick return if N.LE.0. */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Call DLATB4 to set parameters for SLATMS. */
+
+ upper = lsame_(uplo, "U");
+ if (upper) {
+ dlatb4_(path, imat, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ *(unsigned char *)packit = 'C';
+ } else {
+ i__1 = -(*imat);
+ dlatb4_(path, &i__1, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ *(unsigned char *)packit = 'R';
+ }
+
+/* IMAT <= 6: Non-unit triangular matrix */
+
+ if (*imat <= 6) {
+ dlatms_(n, n, dist, &iseed[1], type__, &b[1], &mode, &cndnum, &anorm,
+ &kl, &ku, packit, &a[1], n, &work[1], info);
+
+/* IMAT > 6: Unit triangular matrix */
+/* The diagonal is deliberately set to something other than 1. */
+
+/* IMAT = 7: Matrix is the identity */
+
+ } else if (*imat == 7) {
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[jc + i__ - 1] = 0.;
+/* L10: */
+ }
+ a[jc + j - 1] = (doublereal) j;
+ jc += j;
+/* L20: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ a[jc] = (doublereal) j;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[jc + i__ - j] = 0.;
+/* L30: */
+ }
+ jc = jc + *n - j + 1;
+/* L40: */
+ }
+ }
+
+/* IMAT > 7: Non-trivial unit triangular matrix */
+
+/* Generate a unit triangular matrix T with condition CNDNUM by */
+/* forming a triangular matrix with known singular values and */
+/* filling in the zero entries with Givens rotations. */
+
+ } else if (*imat <= 10) {
+ if (upper) {
+ jc = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[jc + i__] = 0.;
+/* L50: */
+ }
+ a[jc + j] = (doublereal) j;
+ jc += j;
+/* L60: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ a[jc] = (doublereal) j;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[jc + i__ - j] = 0.;
+/* L70: */
+ }
+ jc = jc + *n - j + 1;
+/* L80: */
+ }
+ }
+
+/* Since the trace of a unit triangular matrix is 1, the product */
+/* of its singular values must be 1. Let s = sqrt(CNDNUM), */
+/* x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2. */
+/* The following triangular matrix has singular values s, 1, 1, */
+/* ..., 1, 1/s: */
+
+/* 1 y y y ... y y z */
+/* 1 0 0 ... 0 0 y */
+/* 1 0 ... 0 0 y */
+/* . ... . . . */
+/* . . . . */
+/* 1 0 y */
+/* 1 y */
+/* 1 */
+
+/* To fill in the zeros, we first multiply by a matrix with small */
+/* condition number of the form */
+
+/* 1 0 0 0 0 ... */
+/* 1 + * 0 0 ... */
+/* 1 + 0 0 0 */
+/* 1 + * 0 0 */
+/* 1 + 0 0 */
+/* ... */
+/* 1 + 0 */
+/* 1 0 */
+/* 1 */
+
+/* Each element marked with a '*' is formed by taking the product */
+/* of the adjacent elements marked with '+'. The '*'s can be */
+/* chosen freely, and the '+'s are chosen so that the inverse of */
+/* T will have elements of the same magnitude as T. If the *'s in */
+/* both T and inv(T) have small magnitude, T is well conditioned. */
+/* The two offdiagonals of T are stored in WORK. */
+
+/* The product of these two matrices has the form */
+
+/* 1 y y y y y . y y z */
+/* 1 + * 0 0 . 0 0 y */
+/* 1 + 0 0 . 0 0 y */
+/* 1 + * . . . . */
+/* 1 + . . . . */
+/* . . . . . */
+/* . . . . */
+/* 1 + y */
+/* 1 y */
+/* 1 */
+
+/* Now we multiply by Givens rotations, using the fact that */
+
+/* [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ] */
+/* [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ] */
+/* and */
+/* [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ] */
+/* [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ] */
+
+/* where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4). */
+
+ star1 = .25;
+ sfac = .5;
+ plus1 = sfac;
+ i__1 = *n;
+ for (j = 1; j <= i__1; j += 2) {
+ plus2 = star1 / plus1;
+ work[j] = plus1;
+ work[*n + j] = star1;
+ if (j + 1 <= *n) {
+ work[j + 1] = plus2;
+ work[*n + j + 1] = 0.;
+ plus1 = star1 / plus2;
+ rexp = dlarnd_(&c__2, &iseed[1]);
+ star1 *= pow_dd(&sfac, &rexp);
+ if (rexp < 0.) {
+ d__1 = 1. - rexp;
+ star1 = -pow_dd(&sfac, &d__1);
+ } else {
+ d__1 = rexp + 1.;
+ star1 = pow_dd(&sfac, &d__1);
+ }
+ }
+/* L90: */
+ }
+
+ x = sqrt(cndnum) - 1. / sqrt(cndnum);
+ if (*n > 2) {
+ y = sqrt(2. / (doublereal) (*n - 2)) * x;
+ } else {
+ y = 0.;
+ }
+ z__ = x * x;
+
+ if (upper) {
+
+/* Set the upper triangle of A with a unit triangular matrix */
+/* of known condition number. */
+
+ jc = 1;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ a[jc + 1] = y;
+ if (j > 2) {
+ a[jc + j - 1] = work[j - 2];
+ }
+ if (j > 3) {
+ a[jc + j - 2] = work[*n + j - 3];
+ }
+ jc += j;
+/* L100: */
+ }
+ jc -= *n;
+ a[jc + 1] = z__;
+ i__1 = *n - 1;
+ for (j = 2; j <= i__1; ++j) {
+ a[jc + j] = y;
+/* L110: */
+ }
+ } else {
+
+/* Set the lower triangle of A with a unit triangular matrix */
+/* of known condition number. */
+
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ a[i__] = y;
+/* L120: */
+ }
+ a[*n] = z__;
+ jc = *n + 1;
+ i__1 = *n - 1;
+ for (j = 2; j <= i__1; ++j) {
+ a[jc + 1] = work[j - 1];
+ if (j < *n - 1) {
+ a[jc + 2] = work[*n + j - 1];
+ }
+ a[jc + *n - j] = y;
+ jc = jc + *n - j + 1;
+/* L130: */
+ }
+ }
+
+/* Fill in the zeros using Givens rotations */
+
+ if (upper) {
+ jc = 1;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ jcnext = jc + j;
+ ra = a[jcnext + j - 1];
+ rb = 2.;
+ drotg_(&ra, &rb, &c__, &s);
+
+/* Multiply by [ c s; -s c] on the left. */
+
+ if (*n > j + 1) {
+ jx = jcnext + j;
+ i__2 = *n;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+ stemp = c__ * a[jx + j] + s * a[jx + j + 1];
+ a[jx + j + 1] = -s * a[jx + j] + c__ * a[jx + j + 1];
+ a[jx + j] = stemp;
+ jx += i__;
+/* L140: */
+ }
+ }
+
+/* Multiply by [-c -s; s -c] on the right. */
+
+ if (j > 1) {
+ i__2 = j - 1;
+ d__1 = -c__;
+ d__2 = -s;
+ drot_(&i__2, &a[jcnext], &c__1, &a[jc], &c__1, &d__1, &
+ d__2);
+ }
+
+/* Negate A(J,J+1). */
+
+ a[jcnext + j - 1] = -a[jcnext + j - 1];
+ jc = jcnext;
+/* L150: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ jcnext = jc + *n - j + 1;
+ ra = a[jc + 1];
+ rb = 2.;
+ drotg_(&ra, &rb, &c__, &s);
+
+/* Multiply by [ c -s; s c] on the right. */
+
+ if (*n > j + 1) {
+ i__2 = *n - j - 1;
+ d__1 = -s;
+ drot_(&i__2, &a[jcnext + 1], &c__1, &a[jc + 2], &c__1, &
+ c__, &d__1);
+ }
+
+/* Multiply by [-c s; -s -c] on the left. */
+
+ if (j > 1) {
+ jx = 1;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ stemp = -c__ * a[jx + j - i__] + s * a[jx + j - i__ +
+ 1];
+ a[jx + j - i__ + 1] = -s * a[jx + j - i__] - c__ * a[
+ jx + j - i__ + 1];
+ a[jx + j - i__] = stemp;
+ jx = jx + *n - i__ + 1;
+/* L160: */
+ }
+ }
+
+/* Negate A(J+1,J). */
+
+ a[jc + 1] = -a[jc + 1];
+ jc = jcnext;
+/* L170: */
+ }
+ }
+
+/* IMAT > 10: Pathological test cases. These triangular matrices */
+/* are badly scaled or badly conditioned, so when used in solving a */
+/* triangular system they may cause overflow in the solution vector. */
+
+ } else if (*imat == 11) {
+
+/* Type 11: Generate a triangular matrix with elements between */
+/* -1 and 1. Give the diagonal norm 2 to make it well-conditioned. */
+/* Make the right hand side large so that it requires scaling. */
+
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dlarnv_(&c__2, &iseed[1], &j, &a[jc]);
+ a[jc + j - 1] = d_sign(&c_b36, &a[jc + j - 1]);
+ jc += j;
+/* L180: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ dlarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
+ a[jc] = d_sign(&c_b36, &a[jc]);
+ jc = jc + *n - j + 1;
+/* L190: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ dlarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = idamax_(n, &b[1], &c__1);
+ bnorm = (d__1 = b[iy], abs(d__1));
+ bscal = bignum / max(1.,bnorm);
+ dscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 12) {
+
+/* Type 12: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 12, the offdiagonal elements are small (CNORM(j) < 1). */
+
+ dlarnv_(&c__2, &iseed[1], n, &b[1]);
+/* Computing MAX */
+ d__1 = 1., d__2 = (doublereal) (*n - 1);
+ tscal = 1. / max(d__1,d__2);
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ dlarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
+ i__2 = j - 1;
+ dscal_(&i__2, &tscal, &a[jc], &c__1);
+ d__1 = dlarnd_(&c__2, &iseed[1]);
+ a[jc + j - 1] = d_sign(&c_b48, &d__1);
+ jc += j;
+/* L200: */
+ }
+ a[*n * (*n + 1) / 2] = smlnum;
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ dlarnv_(&c__2, &iseed[1], &i__2, &a[jc + 1]);
+ i__2 = *n - j;
+ dscal_(&i__2, &tscal, &a[jc + 1], &c__1);
+ d__1 = dlarnd_(&c__2, &iseed[1]);
+ a[jc] = d_sign(&c_b48, &d__1);
+ jc = jc + *n - j + 1;
+/* L210: */
+ }
+ a[1] = smlnum;
+ }
+
+ } else if (*imat == 13) {
+
+/* Type 13: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1). */
+
+ dlarnv_(&c__2, &iseed[1], n, &b[1]);
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ dlarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
+ d__1 = dlarnd_(&c__2, &iseed[1]);
+ a[jc + j - 1] = d_sign(&c_b48, &d__1);
+ jc += j;
+/* L220: */
+ }
+ a[*n * (*n + 1) / 2] = smlnum;
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ dlarnv_(&c__2, &iseed[1], &i__2, &a[jc + 1]);
+ d__1 = dlarnd_(&c__2, &iseed[1]);
+ a[jc] = d_sign(&c_b48, &d__1);
+ jc = jc + *n - j + 1;
+/* L230: */
+ }
+ a[1] = smlnum;
+ }
+
+ } else if (*imat == 14) {
+
+/* Type 14: T is diagonal with small numbers on the diagonal to */
+/* make the growth factor underflow, but a small right hand side */
+/* chosen so that the solution does not overflow. */
+
+ if (upper) {
+ jcount = 1;
+ jc = (*n - 1) * *n / 2 + 1;
+ for (j = *n; j >= 1; --j) {
+ i__1 = j - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ a[jc + i__ - 1] = 0.;
+/* L240: */
+ }
+ if (jcount <= 2) {
+ a[jc + j - 1] = smlnum;
+ } else {
+ a[jc + j - 1] = 1.;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+ jc = jc - j + 1;
+/* L250: */
+ }
+ } else {
+ jcount = 1;
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[jc + i__ - j] = 0.;
+/* L260: */
+ }
+ if (jcount <= 2) {
+ a[jc] = smlnum;
+ } else {
+ a[jc] = 1.;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+ jc = jc + *n - j + 1;
+/* L270: */
+ }
+ }
+
+/* Set the right hand side alternately zero and small. */
+
+ if (upper) {
+ b[1] = 0.;
+ for (i__ = *n; i__ >= 2; i__ += -2) {
+ b[i__] = 0.;
+ b[i__ - 1] = smlnum;
+/* L280: */
+ }
+ } else {
+ b[*n] = 0.;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; i__ += 2) {
+ b[i__] = 0.;
+ b[i__ + 1] = smlnum;
+/* L290: */
+ }
+ }
+
+ } else if (*imat == 15) {
+
+/* Type 15: Make the diagonal elements small to cause gradual */
+/* overflow when dividing by T(j,j). To control the amount of */
+/* scaling needed, the matrix is bidiagonal. */
+
+/* Computing MAX */
+ d__1 = 1., d__2 = (doublereal) (*n - 1);
+ texp = 1. / max(d__1,d__2);
+ tscal = pow_dd(&smlnum, &texp);
+ dlarnv_(&c__2, &iseed[1], n, &b[1]);
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 2;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[jc + i__ - 1] = 0.;
+/* L300: */
+ }
+ if (j > 1) {
+ a[jc + j - 2] = -1.;
+ }
+ a[jc + j - 1] = tscal;
+ jc += j;
+/* L310: */
+ }
+ b[*n] = 1.;
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+ a[jc + i__ - j] = 0.;
+/* L320: */
+ }
+ if (j < *n) {
+ a[jc + 1] = -1.;
+ }
+ a[jc] = tscal;
+ jc = jc + *n - j + 1;
+/* L330: */
+ }
+ b[1] = 1.;
+ }
+
+ } else if (*imat == 16) {
+
+/* Type 16: One zero diagonal element. */
+
+ iy = *n / 2 + 1;
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dlarnv_(&c__2, &iseed[1], &j, &a[jc]);
+ if (j != iy) {
+ a[jc + j - 1] = d_sign(&c_b36, &a[jc + j - 1]);
+ } else {
+ a[jc + j - 1] = 0.;
+ }
+ jc += j;
+/* L340: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ dlarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
+ if (j != iy) {
+ a[jc] = d_sign(&c_b36, &a[jc]);
+ } else {
+ a[jc] = 0.;
+ }
+ jc = jc + *n - j + 1;
+/* L350: */
+ }
+ }
+ dlarnv_(&c__2, &iseed[1], n, &b[1]);
+ dscal_(n, &c_b36, &b[1], &c__1);
+
+ } else if (*imat == 17) {
+
+/* Type 17: Make the offdiagonal elements large to cause overflow */
+/* when adding a column of T. In the non-transposed case, the */
+/* matrix is constructed to cause overflow when adding a column in */
+/* every other step. */
+
+ tscal = unfl / ulp;
+ tscal = (1. - ulp) / tscal;
+ i__1 = *n * (*n + 1) / 2;
+ for (j = 1; j <= i__1; ++j) {
+ a[j] = 0.;
+/* L360: */
+ }
+ texp = 1.;
+ if (upper) {
+ jc = (*n - 1) * *n / 2 + 1;
+ for (j = *n; j >= 2; j += -2) {
+ a[jc] = -tscal / (doublereal) (*n + 1);
+ a[jc + j - 1] = 1.;
+ b[j] = texp * (1. - ulp);
+ jc = jc - j + 1;
+ a[jc] = -(tscal / (doublereal) (*n + 1)) / (doublereal) (*n +
+ 2);
+ a[jc + j - 2] = 1.;
+ b[j - 1] = texp * (doublereal) (*n * *n + *n - 1);
+ texp *= 2.;
+ jc = jc - j + 2;
+/* L370: */
+ }
+ b[1] = (doublereal) (*n + 1) / (doublereal) (*n + 2) * tscal;
+ } else {
+ jc = 1;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; j += 2) {
+ a[jc + *n - j] = -tscal / (doublereal) (*n + 1);
+ a[jc] = 1.;
+ b[j] = texp * (1. - ulp);
+ jc = jc + *n - j + 1;
+ a[jc + *n - j - 1] = -(tscal / (doublereal) (*n + 1)) / (
+ doublereal) (*n + 2);
+ a[jc] = 1.;
+ b[j + 1] = texp * (doublereal) (*n * *n + *n - 1);
+ texp *= 2.;
+ jc = jc + *n - j;
+/* L380: */
+ }
+ b[*n] = (doublereal) (*n + 1) / (doublereal) (*n + 2) * tscal;
+ }
+
+ } else if (*imat == 18) {
+
+/* Type 18: Generate a unit triangular matrix with elements */
+/* between -1 and 1, and make the right hand side large so that it */
+/* requires scaling. */
+
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ dlarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
+ a[jc + j - 1] = 0.;
+ jc += j;
+/* L390: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (j < *n) {
+ i__2 = *n - j;
+ dlarnv_(&c__2, &iseed[1], &i__2, &a[jc + 1]);
+ }
+ a[jc] = 0.;
+ jc = jc + *n - j + 1;
+/* L400: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ dlarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = idamax_(n, &b[1], &c__1);
+ bnorm = (d__1 = b[iy], abs(d__1));
+ bscal = bignum / max(1.,bnorm);
+ dscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 19) {
+
+/* Type 19: Generate a triangular matrix with elements between */
+/* BIGNUM/(n-1) and BIGNUM so that at least one of the column */
+/* norms will exceed BIGNUM. */
+
+/* Computing MAX */
+ d__1 = 1., d__2 = (doublereal) (*n - 1);
+ tleft = bignum / max(d__1,d__2);
+/* Computing MAX */
+ d__1 = 1., d__2 = (doublereal) (*n);
+ tscal = bignum * ((doublereal) (*n - 1) / max(d__1,d__2));
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dlarnv_(&c__2, &iseed[1], &j, &a[jc]);
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[jc + i__ - 1] = d_sign(&tleft, &a[jc + i__ - 1]) +
+ tscal * a[jc + i__ - 1];
+/* L410: */
+ }
+ jc += j;
+/* L420: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ dlarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ a[jc + i__ - j] = d_sign(&tleft, &a[jc + i__ - j]) +
+ tscal * a[jc + i__ - j];
+/* L430: */
+ }
+ jc = jc + *n - j + 1;
+/* L440: */
+ }
+ }
+ dlarnv_(&c__2, &iseed[1], n, &b[1]);
+ dscal_(n, &c_b36, &b[1], &c__1);
+ }
+
+/* Flip the matrix across its counter-diagonal if the transpose will */
+/* be used. */
+
+ if (! lsame_(trans, "N")) {
+ if (upper) {
+ jj = 1;
+ jr = *n * (*n + 1) / 2;
+ i__1 = *n / 2;
+ for (j = 1; j <= i__1; ++j) {
+ jl = jj;
+ i__2 = *n - j;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ t = a[jr - i__ + j];
+ a[jr - i__ + j] = a[jl];
+ a[jl] = t;
+ jl += i__;
+/* L450: */
+ }
+ jj = jj + j + 1;
+ jr -= *n - j + 1;
+/* L460: */
+ }
+ } else {
+ jl = 1;
+ jj = *n * (*n + 1) / 2;
+ i__1 = *n / 2;
+ for (j = 1; j <= i__1; ++j) {
+ jr = jj;
+ i__2 = *n - j;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ t = a[jl + i__ - j];
+ a[jl + i__ - j] = a[jr];
+ a[jr] = t;
+ jr -= i__;
+/* L470: */
+ }
+ jl = jl + *n - j + 1;
+ jj = jj - j - 1;
+/* L480: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DLATTP */
+
+} /* dlattp_ */
diff --git a/TESTING/LIN/dlattr.c b/TESTING/LIN/dlattr.c
new file mode 100644
index 0000000..418bf96
--- /dev/null
+++ b/TESTING/LIN/dlattr.c
@@ -0,0 +1,852 @@
+/* dlattr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static doublereal c_b35 = 2.;
+static doublereal c_b46 = 1.;
+static integer c_n1 = -1;
+
+/* Subroutine */ int dlattr_(integer *imat, char *uplo, char *trans, char *
+ diag, integer *iseed, integer *n, doublereal *a, integer *lda,
+ doublereal *b, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double pow_dd(doublereal *, doublereal *), sqrt(doublereal), d_sign(
+ doublereal *, doublereal *);
+
+ /* Local variables */
+ doublereal c__;
+ integer i__, j;
+ doublereal s, x, y, z__, ra, rb;
+ integer kl, ku, iy;
+ doublereal ulp, sfac;
+ integer mode;
+ char path[3], dist[1];
+ doublereal unfl;
+ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ doublereal rexp;
+ char type__[1];
+ doublereal texp, star1, plus1, plus2, bscal;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ doublereal tscal, anorm, bnorm, tleft;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), drotg_(doublereal *, doublereal *,
+ doublereal *, doublereal *), dswap_(integer *, doublereal *,
+ integer *, doublereal *, integer *);
+ logical upper;
+ extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), dlabad_(doublereal
+ *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern doublereal dlarnd_(integer *, integer *);
+ doublereal bignum, cndnum;
+ extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublereal *, integer *, doublereal
+ *, integer *), dlarnv_(integer *, integer
+ *, integer *, doublereal *);
+ integer jcount;
+ doublereal smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLATTR generates a triangular test matrix. */
+/* IMAT and UPLO uniquely specify the properties of the test */
+/* matrix, which is returned in the array A. */
+
+/* Arguments */
+/* ========= */
+
+/* IMAT (input) INTEGER */
+/* An integer key describing which matrix to generate for this */
+/* path. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A will be upper or lower */
+/* triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies whether the matrix or its transpose will be used. */
+/* = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose (= Transpose) */
+
+/* DIAG (output) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* The seed vector for the random number generator (used in */
+/* DLATMS). Modified on exit. */
+
+/* N (input) INTEGER */
+/* The order of the matrix to be generated. */
+
+/* A (output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* set so that A(k,k) = k for 1 <= k <= n. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (output) DOUBLE PRECISION array, dimension (N) */
+/* The right hand side vector, if IMAT > 10. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --b;
+ --work;
+
+ /* Function Body */
+ s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "TR", (ftnlen)2, (ftnlen)2);
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ smlnum = unfl;
+ bignum = (1. - ulp) / smlnum;
+ dlabad_(&smlnum, &bignum);
+ if (*imat >= 7 && *imat <= 10 || *imat == 18) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ *info = 0;
+
+/* Quick return if N.LE.0. */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Call DLATB4 to set parameters for SLATMS. */
+
+ upper = lsame_(uplo, "U");
+ if (upper) {
+ dlatb4_(path, imat, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ } else {
+ i__1 = -(*imat);
+ dlatb4_(path, &i__1, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ }
+
+/* IMAT <= 6: Non-unit triangular matrix */
+
+ if (*imat <= 6) {
+ dlatms_(n, n, dist, &iseed[1], type__, &b[1], &mode, &cndnum, &anorm,
+ &kl, &ku, "No packing", &a[a_offset], lda, &work[1], info);
+
+/* IMAT > 6: Unit triangular matrix */
+/* The diagonal is deliberately set to something other than 1. */
+
+/* IMAT = 7: Matrix is the identity */
+
+ } else if (*imat == 7) {
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L10: */
+ }
+ a[j + j * a_dim1] = (doublereal) j;
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ a[j + j * a_dim1] = (doublereal) j;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+/* IMAT > 7: Non-trivial unit triangular matrix */
+
+/* Generate a unit triangular matrix T with condition CNDNUM by */
+/* forming a triangular matrix with known singular values and */
+/* filling in the zero entries with Givens rotations. */
+
+ } else if (*imat <= 10) {
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L50: */
+ }
+ a[j + j * a_dim1] = (doublereal) j;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ a[j + j * a_dim1] = (doublereal) j;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+
+/* Since the trace of a unit triangular matrix is 1, the product */
+/* of its singular values must be 1. Let s = sqrt(CNDNUM), */
+/* x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2. */
+/* The following triangular matrix has singular values s, 1, 1, */
+/* ..., 1, 1/s: */
+
+/* 1 y y y ... y y z */
+/* 1 0 0 ... 0 0 y */
+/* 1 0 ... 0 0 y */
+/* . ... . . . */
+/* . . . . */
+/* 1 0 y */
+/* 1 y */
+/* 1 */
+
+/* To fill in the zeros, we first multiply by a matrix with small */
+/* condition number of the form */
+
+/* 1 0 0 0 0 ... */
+/* 1 + * 0 0 ... */
+/* 1 + 0 0 0 */
+/* 1 + * 0 0 */
+/* 1 + 0 0 */
+/* ... */
+/* 1 + 0 */
+/* 1 0 */
+/* 1 */
+
+/* Each element marked with a '*' is formed by taking the product */
+/* of the adjacent elements marked with '+'. The '*'s can be */
+/* chosen freely, and the '+'s are chosen so that the inverse of */
+/* T will have elements of the same magnitude as T. If the *'s in */
+/* both T and inv(T) have small magnitude, T is well conditioned. */
+/* The two offdiagonals of T are stored in WORK. */
+
+/* The product of these two matrices has the form */
+
+/* 1 y y y y y . y y z */
+/* 1 + * 0 0 . 0 0 y */
+/* 1 + 0 0 . 0 0 y */
+/* 1 + * . . . . */
+/* 1 + . . . . */
+/* . . . . . */
+/* . . . . */
+/* 1 + y */
+/* 1 y */
+/* 1 */
+
+/* Now we multiply by Givens rotations, using the fact that */
+
+/* [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ] */
+/* [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ] */
+/* and */
+/* [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ] */
+/* [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ] */
+
+/* where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4). */
+
+ star1 = .25;
+ sfac = .5;
+ plus1 = sfac;
+ i__1 = *n;
+ for (j = 1; j <= i__1; j += 2) {
+ plus2 = star1 / plus1;
+ work[j] = plus1;
+ work[*n + j] = star1;
+ if (j + 1 <= *n) {
+ work[j + 1] = plus2;
+ work[*n + j + 1] = 0.;
+ plus1 = star1 / plus2;
+ rexp = dlarnd_(&c__2, &iseed[1]);
+ star1 *= pow_dd(&sfac, &rexp);
+ if (rexp < 0.) {
+ d__1 = 1. - rexp;
+ star1 = -pow_dd(&sfac, &d__1);
+ } else {
+ d__1 = rexp + 1.;
+ star1 = pow_dd(&sfac, &d__1);
+ }
+ }
+/* L90: */
+ }
+
+ x = sqrt(cndnum) - 1 / sqrt(cndnum);
+ if (*n > 2) {
+ y = sqrt(2. / (*n - 2)) * x;
+ } else {
+ y = 0.;
+ }
+ z__ = x * x;
+
+ if (upper) {
+ if (*n > 3) {
+ i__1 = *n - 3;
+ i__2 = *lda + 1;
+ dcopy_(&i__1, &work[1], &c__1, &a[a_dim1 * 3 + 2], &i__2);
+ if (*n > 4) {
+ i__1 = *n - 4;
+ i__2 = *lda + 1;
+ dcopy_(&i__1, &work[*n + 1], &c__1, &a[(a_dim1 << 2) + 2],
+ &i__2);
+ }
+ }
+ i__1 = *n - 1;
+ for (j = 2; j <= i__1; ++j) {
+ a[j * a_dim1 + 1] = y;
+ a[j + *n * a_dim1] = y;
+/* L100: */
+ }
+ a[*n * a_dim1 + 1] = z__;
+ } else {
+ if (*n > 3) {
+ i__1 = *n - 3;
+ i__2 = *lda + 1;
+ dcopy_(&i__1, &work[1], &c__1, &a[(a_dim1 << 1) + 3], &i__2);
+ if (*n > 4) {
+ i__1 = *n - 4;
+ i__2 = *lda + 1;
+ dcopy_(&i__1, &work[*n + 1], &c__1, &a[(a_dim1 << 1) + 4],
+ &i__2);
+ }
+ }
+ i__1 = *n - 1;
+ for (j = 2; j <= i__1; ++j) {
+ a[j + a_dim1] = y;
+ a[*n + j * a_dim1] = y;
+/* L110: */
+ }
+ a[*n + a_dim1] = z__;
+ }
+
+/* Fill in the zeros using Givens rotations. */
+
+ if (upper) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ ra = a[j + (j + 1) * a_dim1];
+ rb = 2.;
+ drotg_(&ra, &rb, &c__, &s);
+
+/* Multiply by [ c s; -s c] on the left. */
+
+ if (*n > j + 1) {
+ i__2 = *n - j - 1;
+ drot_(&i__2, &a[j + (j + 2) * a_dim1], lda, &a[j + 1 + (j
+ + 2) * a_dim1], lda, &c__, &s);
+ }
+
+/* Multiply by [-c -s; s -c] on the right. */
+
+ if (j > 1) {
+ i__2 = j - 1;
+ d__1 = -c__;
+ d__2 = -s;
+ drot_(&i__2, &a[(j + 1) * a_dim1 + 1], &c__1, &a[j *
+ a_dim1 + 1], &c__1, &d__1, &d__2);
+ }
+
+/* Negate A(J,J+1). */
+
+ a[j + (j + 1) * a_dim1] = -a[j + (j + 1) * a_dim1];
+/* L120: */
+ }
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ ra = a[j + 1 + j * a_dim1];
+ rb = 2.;
+ drotg_(&ra, &rb, &c__, &s);
+
+/* Multiply by [ c -s; s c] on the right. */
+
+ if (*n > j + 1) {
+ i__2 = *n - j - 1;
+ d__1 = -s;
+ drot_(&i__2, &a[j + 2 + (j + 1) * a_dim1], &c__1, &a[j +
+ 2 + j * a_dim1], &c__1, &c__, &d__1);
+ }
+
+/* Multiply by [-c s; -s -c] on the left. */
+
+ if (j > 1) {
+ i__2 = j - 1;
+ d__1 = -c__;
+ drot_(&i__2, &a[j + a_dim1], lda, &a[j + 1 + a_dim1], lda,
+ &d__1, &s);
+ }
+
+/* Negate A(J+1,J). */
+
+ a[j + 1 + j * a_dim1] = -a[j + 1 + j * a_dim1];
+/* L130: */
+ }
+ }
+
+/* IMAT > 10: Pathological test cases. These triangular matrices */
+/* are badly scaled or badly conditioned, so when used in solving a */
+/* triangular system they may cause overflow in the solution vector. */
+
+ } else if (*imat == 11) {
+
+/* Type 11: Generate a triangular matrix with elements between */
+/* -1 and 1. Give the diagonal norm 2 to make it well-conditioned. */
+/* Make the right hand side large so that it requires scaling. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dlarnv_(&c__2, &iseed[1], &j, &a[j * a_dim1 + 1]);
+ a[j + j * a_dim1] = d_sign(&c_b35, &a[j + j * a_dim1]);
+/* L140: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ dlarnv_(&c__2, &iseed[1], &i__2, &a[j + j * a_dim1]);
+ a[j + j * a_dim1] = d_sign(&c_b35, &a[j + j * a_dim1]);
+/* L150: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ dlarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = idamax_(n, &b[1], &c__1);
+ bnorm = (d__1 = b[iy], abs(d__1));
+ bscal = bignum / max(1.,bnorm);
+ dscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 12) {
+
+/* Type 12: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 12, the offdiagonal elements are small (CNORM(j) < 1). */
+
+ dlarnv_(&c__2, &iseed[1], n, &b[1]);
+/* Computing MAX */
+ d__1 = 1., d__2 = (doublereal) (*n - 1);
+ tscal = 1. / max(d__1,d__2);
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dlarnv_(&c__2, &iseed[1], &j, &a[j * a_dim1 + 1]);
+ i__2 = j - 1;
+ dscal_(&i__2, &tscal, &a[j * a_dim1 + 1], &c__1);
+ a[j + j * a_dim1] = d_sign(&c_b46, &a[j + j * a_dim1]);
+/* L160: */
+ }
+ a[*n + *n * a_dim1] = smlnum * a[*n + *n * a_dim1];
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ dlarnv_(&c__2, &iseed[1], &i__2, &a[j + j * a_dim1]);
+ if (*n > j) {
+ i__2 = *n - j;
+ dscal_(&i__2, &tscal, &a[j + 1 + j * a_dim1], &c__1);
+ }
+ a[j + j * a_dim1] = d_sign(&c_b46, &a[j + j * a_dim1]);
+/* L170: */
+ }
+ a[a_dim1 + 1] = smlnum * a[a_dim1 + 1];
+ }
+
+ } else if (*imat == 13) {
+
+/* Type 13: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1). */
+
+ dlarnv_(&c__2, &iseed[1], n, &b[1]);
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dlarnv_(&c__2, &iseed[1], &j, &a[j * a_dim1 + 1]);
+ a[j + j * a_dim1] = d_sign(&c_b46, &a[j + j * a_dim1]);
+/* L180: */
+ }
+ a[*n + *n * a_dim1] = smlnum * a[*n + *n * a_dim1];
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ dlarnv_(&c__2, &iseed[1], &i__2, &a[j + j * a_dim1]);
+ a[j + j * a_dim1] = d_sign(&c_b46, &a[j + j * a_dim1]);
+/* L190: */
+ }
+ a[a_dim1 + 1] = smlnum * a[a_dim1 + 1];
+ }
+
+ } else if (*imat == 14) {
+
+/* Type 14: T is diagonal with small numbers on the diagonal to */
+/* make the growth factor underflow, but a small right hand side */
+/* chosen so that the solution does not overflow. */
+
+ if (upper) {
+ jcount = 1;
+ for (j = *n; j >= 1; --j) {
+ i__1 = j - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L200: */
+ }
+ if (jcount <= 2) {
+ a[j + j * a_dim1] = smlnum;
+ } else {
+ a[j + j * a_dim1] = 1.;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+/* L210: */
+ }
+ } else {
+ jcount = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L220: */
+ }
+ if (jcount <= 2) {
+ a[j + j * a_dim1] = smlnum;
+ } else {
+ a[j + j * a_dim1] = 1.;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+/* L230: */
+ }
+ }
+
+/* Set the right hand side alternately zero and small. */
+
+ if (upper) {
+ b[1] = 0.;
+ for (i__ = *n; i__ >= 2; i__ += -2) {
+ b[i__] = 0.;
+ b[i__ - 1] = smlnum;
+/* L240: */
+ }
+ } else {
+ b[*n] = 0.;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; i__ += 2) {
+ b[i__] = 0.;
+ b[i__ + 1] = smlnum;
+/* L250: */
+ }
+ }
+
+ } else if (*imat == 15) {
+
+/* Type 15: Make the diagonal elements small to cause gradual */
+/* overflow when dividing by T(j,j). To control the amount of */
+/* scaling needed, the matrix is bidiagonal. */
+
+/* Computing MAX */
+ d__1 = 1., d__2 = (doublereal) (*n - 1);
+ texp = 1. / max(d__1,d__2);
+ tscal = pow_dd(&smlnum, &texp);
+ dlarnv_(&c__2, &iseed[1], n, &b[1]);
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 2;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L260: */
+ }
+ if (j > 1) {
+ a[j - 1 + j * a_dim1] = -1.;
+ }
+ a[j + j * a_dim1] = tscal;
+/* L270: */
+ }
+ b[*n] = 1.;
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L280: */
+ }
+ if (j < *n) {
+ a[j + 1 + j * a_dim1] = -1.;
+ }
+ a[j + j * a_dim1] = tscal;
+/* L290: */
+ }
+ b[1] = 1.;
+ }
+
+ } else if (*imat == 16) {
+
+/* Type 16: One zero diagonal element. */
+
+ iy = *n / 2 + 1;
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dlarnv_(&c__2, &iseed[1], &j, &a[j * a_dim1 + 1]);
+ if (j != iy) {
+ a[j + j * a_dim1] = d_sign(&c_b35, &a[j + j * a_dim1]);
+ } else {
+ a[j + j * a_dim1] = 0.;
+ }
+/* L300: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ dlarnv_(&c__2, &iseed[1], &i__2, &a[j + j * a_dim1]);
+ if (j != iy) {
+ a[j + j * a_dim1] = d_sign(&c_b35, &a[j + j * a_dim1]);
+ } else {
+ a[j + j * a_dim1] = 0.;
+ }
+/* L310: */
+ }
+ }
+ dlarnv_(&c__2, &iseed[1], n, &b[1]);
+ dscal_(n, &c_b35, &b[1], &c__1);
+
+ } else if (*imat == 17) {
+
+/* Type 17: Make the offdiagonal elements large to cause overflow */
+/* when adding a column of T. In the non-transposed case, the */
+/* matrix is constructed to cause overflow when adding a column in */
+/* every other step. */
+
+ tscal = unfl / ulp;
+ tscal = (1. - ulp) / tscal;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L320: */
+ }
+/* L330: */
+ }
+ texp = 1.;
+ if (upper) {
+ for (j = *n; j >= 2; j += -2) {
+ a[j * a_dim1 + 1] = -tscal / (doublereal) (*n + 1);
+ a[j + j * a_dim1] = 1.;
+ b[j] = texp * (1. - ulp);
+ a[(j - 1) * a_dim1 + 1] = -(tscal / (doublereal) (*n + 1)) / (
+ doublereal) (*n + 2);
+ a[j - 1 + (j - 1) * a_dim1] = 1.;
+ b[j - 1] = texp * (doublereal) (*n * *n + *n - 1);
+ texp *= 2.;
+/* L340: */
+ }
+ b[1] = (doublereal) (*n + 1) / (doublereal) (*n + 2) * tscal;
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; j += 2) {
+ a[*n + j * a_dim1] = -tscal / (doublereal) (*n + 1);
+ a[j + j * a_dim1] = 1.;
+ b[j] = texp * (1. - ulp);
+ a[*n + (j + 1) * a_dim1] = -(tscal / (doublereal) (*n + 1)) /
+ (doublereal) (*n + 2);
+ a[j + 1 + (j + 1) * a_dim1] = 1.;
+ b[j + 1] = texp * (doublereal) (*n * *n + *n - 1);
+ texp *= 2.;
+/* L350: */
+ }
+ b[*n] = (doublereal) (*n + 1) / (doublereal) (*n + 2) * tscal;
+ }
+
+ } else if (*imat == 18) {
+
+/* Type 18: Generate a unit triangular matrix with elements */
+/* between -1 and 1, and make the right hand side large so that it */
+/* requires scaling. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ dlarnv_(&c__2, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
+ a[j + j * a_dim1] = 0.;
+/* L360: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (j < *n) {
+ i__2 = *n - j;
+ dlarnv_(&c__2, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
+ }
+ a[j + j * a_dim1] = 0.;
+/* L370: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ dlarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = idamax_(n, &b[1], &c__1);
+ bnorm = (d__1 = b[iy], abs(d__1));
+ bscal = bignum / max(1.,bnorm);
+ dscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 19) {
+
+/* Type 19: Generate a triangular matrix with elements between */
+/* BIGNUM/(n-1) and BIGNUM so that at least one of the column */
+/* norms will exceed BIGNUM. */
+/* 1/3/91: DLATRS no longer can handle this case */
+
+/* Computing MAX */
+ d__1 = 1., d__2 = (doublereal) (*n - 1);
+ tleft = bignum / max(d__1,d__2);
+/* Computing MAX */
+ d__1 = 1., d__2 = (doublereal) (*n);
+ tscal = bignum * ((doublereal) (*n - 1) / max(d__1,d__2));
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dlarnv_(&c__2, &iseed[1], &j, &a[j * a_dim1 + 1]);
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = d_sign(&tleft, &a[i__ + j * a_dim1])
+ + tscal * a[i__ + j * a_dim1];
+/* L380: */
+ }
+/* L390: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ dlarnv_(&c__2, &iseed[1], &i__2, &a[j + j * a_dim1]);
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = d_sign(&tleft, &a[i__ + j * a_dim1])
+ + tscal * a[i__ + j * a_dim1];
+/* L400: */
+ }
+/* L410: */
+ }
+ }
+ dlarnv_(&c__2, &iseed[1], n, &b[1]);
+ dscal_(n, &c_b35, &b[1], &c__1);
+ }
+
+/* Flip the matrix if the transpose will be used. */
+
+ if (! lsame_(trans, "N")) {
+ if (upper) {
+ i__1 = *n / 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - (j << 1) + 1;
+ dswap_(&i__2, &a[j + j * a_dim1], lda, &a[j + 1 + (*n - j + 1)
+ * a_dim1], &c_n1);
+/* L420: */
+ }
+ } else {
+ i__1 = *n / 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - (j << 1) + 1;
+ i__3 = -(*lda);
+ dswap_(&i__2, &a[j + j * a_dim1], &c__1, &a[*n - j + 1 + (j +
+ 1) * a_dim1], &i__3);
+/* L430: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DLATTR */
+
+} /* dlattr_ */
diff --git a/TESTING/LIN/dlavsp.c b/TESTING/LIN/dlavsp.c
new file mode 100644
index 0000000..fdfeb3b
--- /dev/null
+++ b/TESTING/LIN/dlavsp.c
@@ -0,0 +1,560 @@
+/* dlavsp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b15 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dlavsp_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublereal *a, integer *ipiv, doublereal *b, integer *
+ ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ integer j, k;
+ doublereal t1, t2, d11, d12, d21, d22;
+ integer kc, kp;
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dscal_(integer *, doublereal *, doublereal *, integer
+ *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dswap_(integer *,
+ doublereal *, integer *, doublereal *, integer *), xerbla_(char *,
+ integer *);
+ integer kcnext;
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAVSP performs one of the matrix-vector operations */
+/* x := A*x or x := A'*x, */
+/* where x is an N element vector and A is one of the factors */
+/* from the block U*D*U' or L*D*L' factorization computed by DSPTRF. */
+
+/* If TRANS = 'N', multiplies by U or U * D (or L or L * D) */
+/* If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L' ) */
+/* If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L' ) */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the factor stored in A is upper or lower */
+/* triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation to be performed: */
+/* = 'N': x := A*x */
+/* = 'T': x := A'*x */
+/* = 'C': x := A'*x */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the diagonal blocks are unit */
+/* matrices. If the diagonal blocks are assumed to be unit, */
+/* then A = U or A = L, otherwise A = U*D or A = L*D. */
+/* = 'U': Diagonal blocks are assumed to be unit matrices. */
+/* = 'N': Diagonal blocks are assumed to be non-unit matrices. */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of vectors */
+/* x to be multiplied by A. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L, stored as a packed triangular */
+/* matrix as computed by DSPTRF. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from DSPTRF. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, B contains NRHS vectors of length N. */
+/* On exit, B is overwritten with the product A * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --a;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLAVSP ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+/* ------------------------------------------ */
+
+/* Compute B := A * B (No transpose) */
+
+/* ------------------------------------------ */
+ if (lsame_(trans, "N")) {
+
+/* Compute B := U*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop forward applying the transformations. */
+
+ k = 1;
+ kc = 1;
+L10:
+ if (k > *n) {
+ goto L30;
+ }
+
+/* 1 x 1 pivot block */
+
+ if (ipiv[k] > 0) {
+
+/* Multiply by the diagonal element if forming U * D. */
+
+ if (nounit) {
+ dscal_(nrhs, &a[kc + k - 1], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformation. */
+
+ i__1 = k - 1;
+ dger_(&i__1, nrhs, &c_b15, &a[kc], &c__1, &b[k + b_dim1],
+ ldb, &b[b_dim1 + 1], ldb);
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ kc += k;
+ ++k;
+ } else {
+
+/* 2 x 2 pivot block */
+
+ kcnext = kc + k;
+
+/* Multiply by the diagonal block if forming U * D. */
+
+ if (nounit) {
+ d11 = a[kcnext - 1];
+ d22 = a[kcnext + k];
+ d12 = a[kcnext + k - 1];
+ d21 = d12;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ t1 = b[k + j * b_dim1];
+ t2 = b[k + 1 + j * b_dim1];
+ b[k + j * b_dim1] = d11 * t1 + d12 * t2;
+ b[k + 1 + j * b_dim1] = d21 * t1 + d22 * t2;
+/* L20: */
+ }
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformations. */
+
+ i__1 = k - 1;
+ dger_(&i__1, nrhs, &c_b15, &a[kc], &c__1, &b[k + b_dim1],
+ ldb, &b[b_dim1 + 1], ldb);
+ i__1 = k - 1;
+ dger_(&i__1, nrhs, &c_b15, &a[kcnext], &c__1, &b[k + 1 +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ kc = kcnext + k + 1;
+ k += 2;
+ }
+ goto L10;
+L30:
+
+/* Compute B := L*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . */
+
+ ;
+ } else {
+
+/* Loop backward applying the transformations to B. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L40:
+ if (k < 1) {
+ goto L60;
+ }
+ kc -= *n - k + 1;
+
+/* Test the pivot index. If greater than zero, a 1 x 1 */
+/* pivot was used, otherwise a 2 x 2 pivot was used. */
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 pivot block: */
+
+/* Multiply by the diagonal element if forming L * D. */
+
+ if (nounit) {
+ dscal_(nrhs, &a[kc], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+ kp = ipiv[k];
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ dger_(&i__1, nrhs, &c_b15, &a[kc + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ --k;
+
+ } else {
+
+/* 2 x 2 pivot block: */
+
+ kcnext = kc - (*n - k + 2);
+
+/* Multiply by the diagonal block if forming L * D. */
+
+ if (nounit) {
+ d11 = a[kcnext];
+ d22 = a[kc];
+ d21 = a[kcnext + 1];
+ d12 = d21;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ t1 = b[k - 1 + j * b_dim1];
+ t2 = b[k + j * b_dim1];
+ b[k - 1 + j * b_dim1] = d11 * t1 + d12 * t2;
+ b[k + j * b_dim1] = d21 * t1 + d22 * t2;
+/* L50: */
+ }
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ dger_(&i__1, nrhs, &c_b15, &a[kc + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+ i__1 = *n - k;
+ dger_(&i__1, nrhs, &c_b15, &a[kcnext + 2], &c__1, &b[k -
+ 1 + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ kc = kcnext;
+ k += -2;
+ }
+ goto L40;
+L60:
+ ;
+ }
+/* ---------------------------------------- */
+
+/* Compute B := A' * B (transpose) */
+
+/* ---------------------------------------- */
+ } else {
+
+/* Form B := U'*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+/* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop backward applying the transformations. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L70:
+ if (k < 1) {
+ goto L90;
+ }
+ kc -= k;
+
+/* 1 x 1 pivot block. */
+
+ if (ipiv[k] > 0) {
+ if (k > 1) {
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ i__1 = k - 1;
+ dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[b_offset],
+ ldb, &a[kc], &c__1, &c_b15, &b[k + b_dim1], ldb);
+ }
+ if (nounit) {
+ dscal_(nrhs, &a[kc + k - 1], &b[k + b_dim1], ldb);
+ }
+ --k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ kcnext = kc - (k - 1);
+ if (k > 2) {
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k - 1) {
+ dswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformations */
+
+ i__1 = k - 2;
+ dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[b_offset],
+ ldb, &a[kc], &c__1, &c_b15, &b[k + b_dim1], ldb);
+ i__1 = k - 2;
+ dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[b_offset],
+ ldb, &a[kcnext], &c__1, &c_b15, &b[k - 1 + b_dim1]
+, ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ d11 = a[kc - 1];
+ d22 = a[kc + k - 1];
+ d12 = a[kc + k - 2];
+ d21 = d12;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ t1 = b[k - 1 + j * b_dim1];
+ t2 = b[k + j * b_dim1];
+ b[k - 1 + j * b_dim1] = d11 * t1 + d12 * t2;
+ b[k + j * b_dim1] = d21 * t1 + d22 * t2;
+/* L80: */
+ }
+ }
+ kc = kcnext;
+ k += -2;
+ }
+ goto L70;
+L90:
+
+/* Form B := L'*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) */
+/* and L' = inv(L(m))*P(m)* ... *inv(L(1))*P(1) */
+
+ ;
+ } else {
+
+/* Loop forward applying the L-transformations. */
+
+ k = 1;
+ kc = 1;
+L100:
+ if (k > *n) {
+ goto L120;
+ }
+
+/* 1 x 1 pivot block */
+
+ if (ipiv[k] > 0) {
+ if (k < *n) {
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ i__1 = *n - k;
+ dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[k + 1 +
+ b_dim1], ldb, &a[kc + 1], &c__1, &c_b15, &b[k +
+ b_dim1], ldb);
+ }
+ if (nounit) {
+ dscal_(nrhs, &a[kc], &b[k + b_dim1], ldb);
+ }
+ kc = kc + *n - k + 1;
+ ++k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ kcnext = kc + *n - k + 1;
+ if (k < *n - 1) {
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k + 1) {
+ dswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ i__1 = *n - k - 1;
+ dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[k + 2 +
+ b_dim1], ldb, &a[kcnext + 1], &c__1, &c_b15, &b[k
+ + 1 + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[k + 2 +
+ b_dim1], ldb, &a[kc + 2], &c__1, &c_b15, &b[k +
+ b_dim1], ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ d11 = a[kc];
+ d22 = a[kcnext];
+ d21 = a[kc + 1];
+ d12 = d21;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ t1 = b[k + j * b_dim1];
+ t2 = b[k + 1 + j * b_dim1];
+ b[k + j * b_dim1] = d11 * t1 + d12 * t2;
+ b[k + 1 + j * b_dim1] = d21 * t1 + d22 * t2;
+/* L110: */
+ }
+ }
+ kc = kcnext + (*n - k);
+ k += 2;
+ }
+ goto L100;
+L120:
+ ;
+ }
+
+ }
+ return 0;
+
+/* End of DLAVSP */
+
+} /* dlavsp_ */
diff --git a/TESTING/LIN/dlavsy.c b/TESTING/LIN/dlavsy.c
new file mode 100644
index 0000000..a82f5db
--- /dev/null
+++ b/TESTING/LIN/dlavsy.c
@@ -0,0 +1,550 @@
+/* dlavsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b15 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dlavsy_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublereal *a, integer *lda, integer *ipiv, doublereal
+ *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ integer j, k;
+ doublereal t1, t2, d11, d12, d21, d22;
+ integer kp;
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *), dscal_(integer *, doublereal *, doublereal *, integer
+ *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *), dswap_(integer *,
+ doublereal *, integer *, doublereal *, integer *), xerbla_(char *,
+ integer *);
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAVSY performs one of the matrix-vector operations */
+/* x := A*x or x := A'*x, */
+/* where x is an N element vector and A is one of the factors */
+/* from the block U*D*U' or L*D*L' factorization computed by DSYTRF. */
+
+/* If TRANS = 'N', multiplies by U or U * D (or L or L * D) */
+/* If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L') */
+/* If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L') */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the factor stored in A is upper or lower */
+/* triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation to be performed: */
+/* = 'N': x := A*x */
+/* = 'T': x := A'*x */
+/* = 'C': x := A'*x */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the diagonal blocks are unit */
+/* matrices. If the diagonal blocks are assumed to be unit, */
+/* then A = U or A = L, otherwise A = U*D or A = L*D. */
+/* = 'U': Diagonal blocks are assumed to be unit matrices. */
+/* = 'N': Diagonal blocks are assumed to be non-unit matrices. */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of vectors */
+/* x to be multiplied by A. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by DSYTRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from DSYTRF. */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, B contains NRHS vectors of length N. */
+/* On exit, B is overwritten with the product A * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLAVSY ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+/* ------------------------------------------ */
+
+/* Compute B := A * B (No transpose) */
+
+/* ------------------------------------------ */
+ if (lsame_(trans, "N")) {
+
+/* Compute B := U*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop forward applying the transformations. */
+
+ k = 1;
+L10:
+ if (k > *n) {
+ goto L30;
+ }
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 pivot block */
+
+/* Multiply by the diagonal element if forming U * D. */
+
+ if (nounit) {
+ dscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformation. */
+
+ i__1 = k - 1;
+ dger_(&i__1, nrhs, &c_b15, &a[k * a_dim1 + 1], &c__1, &b[
+ k + b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Interchange if P(K) .ne. I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ ++k;
+ } else {
+
+/* 2 x 2 pivot block */
+
+/* Multiply by the diagonal block if forming U * D. */
+
+ if (nounit) {
+ d11 = a[k + k * a_dim1];
+ d22 = a[k + 1 + (k + 1) * a_dim1];
+ d12 = a[k + (k + 1) * a_dim1];
+ d21 = d12;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ t1 = b[k + j * b_dim1];
+ t2 = b[k + 1 + j * b_dim1];
+ b[k + j * b_dim1] = d11 * t1 + d12 * t2;
+ b[k + 1 + j * b_dim1] = d21 * t1 + d22 * t2;
+/* L20: */
+ }
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformations. */
+
+ i__1 = k - 1;
+ dger_(&i__1, nrhs, &c_b15, &a[k * a_dim1 + 1], &c__1, &b[
+ k + b_dim1], ldb, &b[b_dim1 + 1], ldb);
+ i__1 = k - 1;
+ dger_(&i__1, nrhs, &c_b15, &a[(k + 1) * a_dim1 + 1], &
+ c__1, &b[k + 1 + b_dim1], ldb, &b[b_dim1 + 1],
+ ldb);
+
+/* Interchange if P(K) .ne. I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ k += 2;
+ }
+ goto L10;
+L30:
+
+/* Compute B := L*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . */
+
+ ;
+ } else {
+
+/* Loop backward applying the transformations to B. */
+
+ k = *n;
+L40:
+ if (k < 1) {
+ goto L60;
+ }
+
+/* Test the pivot index. If greater than zero, a 1 x 1 */
+/* pivot was used, otherwise a 2 x 2 pivot was used. */
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 pivot block: */
+
+/* Multiply by the diagonal element if forming L * D. */
+
+ if (nounit) {
+ dscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+ kp = ipiv[k];
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ dger_(&i__1, nrhs, &c_b15, &a[k + 1 + k * a_dim1], &c__1,
+ &b[k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ --k;
+
+ } else {
+
+/* 2 x 2 pivot block: */
+
+/* Multiply by the diagonal block if forming L * D. */
+
+ if (nounit) {
+ d11 = a[k - 1 + (k - 1) * a_dim1];
+ d22 = a[k + k * a_dim1];
+ d21 = a[k + (k - 1) * a_dim1];
+ d12 = d21;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ t1 = b[k - 1 + j * b_dim1];
+ t2 = b[k + j * b_dim1];
+ b[k - 1 + j * b_dim1] = d11 * t1 + d12 * t2;
+ b[k + j * b_dim1] = d21 * t1 + d22 * t2;
+/* L50: */
+ }
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ dger_(&i__1, nrhs, &c_b15, &a[k + 1 + k * a_dim1], &c__1,
+ &b[k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+ i__1 = *n - k;
+ dger_(&i__1, nrhs, &c_b15, &a[k + 1 + (k - 1) * a_dim1], &
+ c__1, &b[k - 1 + b_dim1], ldb, &b[k + 1 + b_dim1],
+ ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ k += -2;
+ }
+ goto L40;
+L60:
+ ;
+ }
+/* ---------------------------------------- */
+
+/* Compute B := A' * B (transpose) */
+
+/* ---------------------------------------- */
+ } else {
+
+/* Form B := U'*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+/* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop backward applying the transformations. */
+
+ k = *n;
+L70:
+ if (k < 1) {
+ goto L90;
+ }
+
+/* 1 x 1 pivot block. */
+
+ if (ipiv[k] > 0) {
+ if (k > 1) {
+
+/* Interchange if P(K) .ne. I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ i__1 = k - 1;
+ dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[b_offset],
+ ldb, &a[k * a_dim1 + 1], &c__1, &c_b15, &b[k +
+ b_dim1], ldb);
+ }
+ if (nounit) {
+ dscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+ --k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ if (k > 2) {
+
+/* Interchange if P(K) .ne. I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k - 1) {
+ dswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformations */
+
+ i__1 = k - 2;
+ dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[b_offset],
+ ldb, &a[k * a_dim1 + 1], &c__1, &c_b15, &b[k +
+ b_dim1], ldb);
+ i__1 = k - 2;
+ dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[b_offset],
+ ldb, &a[(k - 1) * a_dim1 + 1], &c__1, &c_b15, &b[
+ k - 1 + b_dim1], ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ d11 = a[k - 1 + (k - 1) * a_dim1];
+ d22 = a[k + k * a_dim1];
+ d12 = a[k - 1 + k * a_dim1];
+ d21 = d12;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ t1 = b[k - 1 + j * b_dim1];
+ t2 = b[k + j * b_dim1];
+ b[k - 1 + j * b_dim1] = d11 * t1 + d12 * t2;
+ b[k + j * b_dim1] = d21 * t1 + d22 * t2;
+/* L80: */
+ }
+ }
+ k += -2;
+ }
+ goto L70;
+L90:
+
+/* Form B := L'*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) */
+/* and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1) */
+
+ ;
+ } else {
+
+/* Loop forward applying the L-transformations. */
+
+ k = 1;
+L100:
+ if (k > *n) {
+ goto L120;
+ }
+
+/* 1 x 1 pivot block */
+
+ if (ipiv[k] > 0) {
+ if (k < *n) {
+
+/* Interchange if P(K) .ne. I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ i__1 = *n - k;
+ dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[k + 1 +
+ b_dim1], ldb, &a[k + 1 + k * a_dim1], &c__1, &
+ c_b15, &b[k + b_dim1], ldb);
+ }
+ if (nounit) {
+ dscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+ ++k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ if (k < *n - 1) {
+
+/* Interchange if P(K) .ne. I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k + 1) {
+ dswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ i__1 = *n - k - 1;
+ dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[k + 2 +
+ b_dim1], ldb, &a[k + 2 + (k + 1) * a_dim1], &c__1,
+ &c_b15, &b[k + 1 + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ dgemv_("Transpose", &i__1, nrhs, &c_b15, &b[k + 2 +
+ b_dim1], ldb, &a[k + 2 + k * a_dim1], &c__1, &
+ c_b15, &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ d11 = a[k + k * a_dim1];
+ d22 = a[k + 1 + (k + 1) * a_dim1];
+ d21 = a[k + 1 + k * a_dim1];
+ d12 = d21;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ t1 = b[k + j * b_dim1];
+ t2 = b[k + 1 + j * b_dim1];
+ b[k + j * b_dim1] = d11 * t1 + d12 * t2;
+ b[k + 1 + j * b_dim1] = d21 * t1 + d22 * t2;
+/* L110: */
+ }
+ }
+ k += 2;
+ }
+ goto L100;
+L120:
+ ;
+ }
+
+ }
+ return 0;
+
+/* End of DLAVSY */
+
+} /* dlavsy_ */
diff --git a/TESTING/LIN/dlqt01.c b/TESTING/LIN/dlqt01.c
new file mode 100644
index 0000000..ecd368e
--- /dev/null
+++ b/TESTING/LIN/dlqt01.c
@@ -0,0 +1,224 @@
+/* dlqt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublereal c_b6 = -1e10;
+static doublereal c_b11 = 0.;
+static doublereal c_b16 = -1.;
+static doublereal c_b17 = 1.;
+
+/* Subroutine */ int dlqt01_(integer *m, integer *n, doublereal *a,
+ doublereal *af, doublereal *q, doublereal *l, integer *lda,
+ doublereal *tau, doublereal *work, integer *lwork, doublereal *rwork,
+ doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
+ q_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal eps;
+ integer info;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ doublereal resid, anorm;
+ integer minmn;
+ extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *),
+ dlacpy_(char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *), dlaset_(char *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *), dorglq_(integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLQT01 tests DGELQF, which computes the LQ factorization of an m-by-n */
+/* matrix A, and partially tests DORGLQ which forms the n-by-n */
+/* orthogonal matrix Q. */
+
+/* DLQT01 compares L with A*Q', and checks that Q is orthogonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The m-by-n matrix A. */
+
+/* AF (output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* Details of the LQ factorization of A, as returned by DGELQF. */
+/* See DGELQF for further details. */
+
+/* Q (output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The n-by-n orthogonal matrix Q. */
+
+/* L (workspace) DOUBLE PRECISION array, dimension (LDA,max(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and L. */
+/* LDA >= max(M,N). */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by DGELQF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(M,N)) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ l_dim1 = *lda;
+ l_offset = 1 + l_dim1;
+ l -= l_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ minmn = min(*m,*n);
+ eps = dlamch_("Epsilon");
+
+/* Copy the matrix A to the array AF. */
+
+ dlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+
+/* Factorize the matrix A in the array AF. */
+
+ s_copy(srnamc_1.srnamt, "DGELQF", (ftnlen)32, (ftnlen)6);
+ dgelqf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy details of Q */
+
+ dlaset_("Full", n, n, &c_b6, &c_b6, &q[q_offset], lda);
+ if (*n > 1) {
+ i__1 = *n - 1;
+ dlacpy_("Upper", m, &i__1, &af[(af_dim1 << 1) + 1], lda, &q[(q_dim1 <<
+ 1) + 1], lda);
+ }
+
+/* Generate the n-by-n matrix Q */
+
+ s_copy(srnamc_1.srnamt, "DORGLQ", (ftnlen)32, (ftnlen)6);
+ dorglq_(n, n, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy L */
+
+ dlaset_("Full", m, n, &c_b11, &c_b11, &l[l_offset], lda);
+ dlacpy_("Lower", m, n, &af[af_offset], lda, &l[l_offset], lda);
+
+/* Compute L - A*Q' */
+
+ dgemm_("No transpose", "Transpose", m, n, n, &c_b16, &a[a_offset], lda, &
+ q[q_offset], lda, &c_b17, &l[l_offset], lda);
+
+/* Compute norm( L - Q'*A ) / ( N * norm(A) * EPS ) . */
+
+ anorm = dlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ resid = dlange_("1", m, n, &l[l_offset], lda, &rwork[1]);
+ if (anorm > 0.) {
+ result[1] = resid / (doublereal) max(1,*n) / anorm / eps;
+ } else {
+ result[1] = 0.;
+ }
+
+/* Compute I - Q*Q' */
+
+ dlaset_("Full", n, n, &c_b11, &c_b17, &l[l_offset], lda);
+ dsyrk_("Upper", "No transpose", n, n, &c_b16, &q[q_offset], lda, &c_b17, &
+ l[l_offset], lda);
+
+/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
+
+ resid = dlansy_("1", "Upper", n, &l[l_offset], lda, &rwork[1]);
+
+ result[2] = resid / (doublereal) max(1,*n) / eps;
+
+ return 0;
+
+/* End of DLQT01 */
+
+} /* dlqt01_ */
diff --git a/TESTING/LIN/dlqt02.c b/TESTING/LIN/dlqt02.c
new file mode 100644
index 0000000..d60b447
--- /dev/null
+++ b/TESTING/LIN/dlqt02.c
@@ -0,0 +1,217 @@
+/* dlqt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublereal c_b4 = -1e10;
+static doublereal c_b9 = 0.;
+static doublereal c_b14 = -1.;
+static doublereal c_b15 = 1.;
+
+/* Subroutine */ int dlqt02_(integer *m, integer *n, integer *k, doublereal *
+ a, doublereal *af, doublereal *q, doublereal *l, integer *lda,
+ doublereal *tau, doublereal *work, integer *lwork, doublereal *rwork,
+ doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
+ q_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal eps;
+ integer info;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ doublereal resid, anorm;
+ extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), dorglq_(integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLQT02 tests DORGLQ, which generates an m-by-n matrix Q with */
+/* orthonornmal rows that is defined as the product of k elementary */
+/* reflectors. */
+
+/* Given the LQ factorization of an m-by-n matrix A, DLQT02 generates */
+/* the orthogonal matrix Q defined by the factorization of the first k */
+/* rows of A; it compares L(1:k,1:m) with A(1:k,1:n)*Q(1:m,1:n)', and */
+/* checks that the rows of Q are orthonormal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q to be generated. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q to be generated. */
+/* N >= M >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The m-by-n matrix A which was factorized by DLQT01. */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* Details of the LQ factorization of A, as returned by DGELQF. */
+/* See DGELQF for further details. */
+
+/* Q (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
+
+/* L (workspace) DOUBLE PRECISION array, dimension (LDA,M) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and L. LDA >= N. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (M) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the LQ factorization in AF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ l_dim1 = *lda;
+ l_offset = 1 + l_dim1;
+ l -= l_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ eps = dlamch_("Epsilon");
+
+/* Copy the first k rows of the factorization to the array Q */
+
+ dlaset_("Full", m, n, &c_b4, &c_b4, &q[q_offset], lda);
+ i__1 = *n - 1;
+ dlacpy_("Upper", k, &i__1, &af[(af_dim1 << 1) + 1], lda, &q[(q_dim1 << 1)
+ + 1], lda);
+
+/* Generate the first n columns of the matrix Q */
+
+ s_copy(srnamc_1.srnamt, "DORGLQ", (ftnlen)32, (ftnlen)6);
+ dorglq_(m, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy L(1:k,1:m) */
+
+ dlaset_("Full", k, m, &c_b9, &c_b9, &l[l_offset], lda);
+ dlacpy_("Lower", k, m, &af[af_offset], lda, &l[l_offset], lda);
+
+/* Compute L(1:k,1:m) - A(1:k,1:n) * Q(1:m,1:n)' */
+
+ dgemm_("No transpose", "Transpose", k, m, n, &c_b14, &a[a_offset], lda, &
+ q[q_offset], lda, &c_b15, &l[l_offset], lda);
+
+/* Compute norm( L - A*Q' ) / ( N * norm(A) * EPS ) . */
+
+ anorm = dlange_("1", k, n, &a[a_offset], lda, &rwork[1]);
+ resid = dlange_("1", k, m, &l[l_offset], lda, &rwork[1]);
+ if (anorm > 0.) {
+ result[1] = resid / (doublereal) max(1,*n) / anorm / eps;
+ } else {
+ result[1] = 0.;
+ }
+
+/* Compute I - Q*Q' */
+
+ dlaset_("Full", m, m, &c_b9, &c_b15, &l[l_offset], lda);
+ dsyrk_("Upper", "No transpose", m, n, &c_b14, &q[q_offset], lda, &c_b15, &
+ l[l_offset], lda);
+
+/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
+
+ resid = dlansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
+
+ result[2] = resid / (doublereal) max(1,*n) / eps;
+
+ return 0;
+
+/* End of DLQT02 */
+
+} /* dlqt02_ */
diff --git a/TESTING/LIN/dlqt03.c b/TESTING/LIN/dlqt03.c
new file mode 100644
index 0000000..24ae04f
--- /dev/null
+++ b/TESTING/LIN/dlqt03.c
@@ -0,0 +1,262 @@
+/* dlqt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublereal c_b4 = -1e10;
+static integer c__2 = 2;
+static doublereal c_b21 = -1.;
+static doublereal c_b22 = 1.;
+
+/* Subroutine */ int dlqt03_(integer *m, integer *n, integer *k, doublereal *
+ af, doublereal *c__, doublereal *cc, doublereal *q, integer *lda,
+ doublereal *tau, doublereal *work, integer *lwork, doublereal *rwork,
+ doublereal *result)
+{
+ /* Initialized data */
+
+ static integer iseed[4] = { 1988,1989,1990,1991 };
+
+ /* System generated locals */
+ integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1,
+ q_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j, mc, nc;
+ doublereal eps;
+ char side[1];
+ integer info;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ integer iside;
+ extern logical lsame_(char *, char *);
+ doublereal resid, cnorm;
+ char trans[1];
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), dlarnv_(integer *, integer *,
+ integer *, doublereal *), dorglq_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dormlq_(char *, char *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *);
+ integer itrans;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLQT03 tests DORMLQ, which computes Q*C, Q'*C, C*Q or C*Q'. */
+
+/* DLQT03 compares the results of a call to DORMLQ with the results of */
+/* forming Q explicitly by a call to DORGLQ and then performing matrix */
+/* multiplication by a call to DGEMM. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows or columns of the matrix C; C is n-by-m if */
+/* Q is applied from the left, or m-by-n if Q is applied from */
+/* the right. M >= 0. */
+
+/* N (input) INTEGER */
+/* The order of the orthogonal matrix Q. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* orthogonal matrix Q. N >= K >= 0. */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* Details of the LQ factorization of an m-by-n matrix, as */
+/* returned by DGELQF. See SGELQF for further details. */
+
+/* C (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
+
+/* CC (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
+
+/* Q (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays AF, C, CC, and Q. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the LQ factorization in AF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK must be at least M, and should be */
+/* M*NB, where NB is the blocksize for this environment. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
+/* The test ratios compare two techniques for multiplying a */
+/* random matrix C by an n-by-n orthogonal matrix Q. */
+/* RESULT(1) = norm( Q*C - Q*C ) / ( N * norm(C) * EPS ) */
+/* RESULT(2) = norm( C*Q - C*Q ) / ( N * norm(C) * EPS ) */
+/* RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS ) */
+/* RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ cc_dim1 = *lda;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+ c_dim1 = *lda;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = dlamch_("Epsilon");
+
+/* Copy the first k rows of the factorization to the array Q */
+
+ dlaset_("Full", n, n, &c_b4, &c_b4, &q[q_offset], lda);
+ i__1 = *n - 1;
+ dlacpy_("Upper", k, &i__1, &af[(af_dim1 << 1) + 1], lda, &q[(q_dim1 << 1)
+ + 1], lda);
+
+/* Generate the n-by-n matrix Q */
+
+ s_copy(srnamc_1.srnamt, "DORGLQ", (ftnlen)32, (ftnlen)6);
+ dorglq_(n, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+ for (iside = 1; iside <= 2; ++iside) {
+ if (iside == 1) {
+ *(unsigned char *)side = 'L';
+ mc = *n;
+ nc = *m;
+ } else {
+ *(unsigned char *)side = 'R';
+ mc = *m;
+ nc = *n;
+ }
+
+/* Generate MC by NC matrix C */
+
+ i__1 = nc;
+ for (j = 1; j <= i__1; ++j) {
+ dlarnv_(&c__2, iseed, &mc, &c__[j * c_dim1 + 1]);
+/* L10: */
+ }
+ cnorm = dlange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]);
+ if (cnorm == 0.) {
+ cnorm = 1.;
+ }
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+ if (itrans == 1) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'T';
+ }
+
+/* Copy C */
+
+ dlacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
+ lda);
+
+/* Apply Q or Q' to C */
+
+ s_copy(srnamc_1.srnamt, "DORMLQ", (ftnlen)32, (ftnlen)6);
+ dormlq_(side, trans, &mc, &nc, k, &af[af_offset], lda, &tau[1], &
+ cc[cc_offset], lda, &work[1], lwork, &info);
+
+/* Form explicit product and subtract */
+
+ if (lsame_(side, "L")) {
+ dgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b21, &q[
+ q_offset], lda, &c__[c_offset], lda, &c_b22, &cc[
+ cc_offset], lda);
+ } else {
+ dgemm_("No transpose", trans, &mc, &nc, &nc, &c_b21, &c__[
+ c_offset], lda, &q[q_offset], lda, &c_b22, &cc[
+ cc_offset], lda);
+ }
+
+/* Compute error in the difference */
+
+ resid = dlange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
+ result[(iside - 1 << 1) + itrans] = resid / ((doublereal) max(1,*
+ n) * cnorm * eps);
+
+/* L20: */
+ }
+/* L30: */
+ }
+
+ return 0;
+
+/* End of DLQT03 */
+
+} /* dlqt03_ */
diff --git a/TESTING/LIN/dpbt01.c b/TESTING/LIN/dpbt01.c
new file mode 100644
index 0000000..ada9356
--- /dev/null
+++ b/TESTING/LIN/dpbt01.c
@@ -0,0 +1,244 @@
+/* dpbt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b14 = 1.;
+
+/* Subroutine */ int dpbt01_(char *uplo, integer *n, integer *kd, doublereal *
+ a, integer *lda, doublereal *afac, integer *ldafac, doublereal *rwork,
+ doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal t;
+ integer kc, ml, mu;
+ doublereal eps;
+ integer klen;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ extern /* Subroutine */ int dsyr_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *), dscal_(
+ integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlansb_(char *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPBT01 reconstructs a symmetric positive definite band matrix A from */
+/* its L*L' or U'*U factorization and computes the residual */
+/* norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
+/* norm( U'*U - A ) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon, L' is the conjugate transpose of */
+/* L, and U' is the conjugate transpose of U. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The original symmetric band matrix A. If UPLO = 'U', the */
+/* upper triangular part of A is stored as a band matrix; if */
+/* UPLO = 'L', the lower triangular part of A is stored. The */
+/* columns of the appropriate triangle are stored in the columns */
+/* of A and the diagonals of the triangle are stored in the rows */
+/* of A. See DPBTRF for further details. */
+
+/* LDA (input) INTEGER. */
+/* The leading dimension of the array A. LDA >= max(1,KD+1). */
+
+/* AFAC (input) DOUBLE PRECISION array, dimension (LDAFAC,N) */
+/* The factored form of the matrix A. AFAC contains the factor */
+/* L or U from the L*L' or U'*U factorization in band storage */
+/* format, as computed by DPBTRF. */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. */
+/* LDAFAC >= max(1,KD+1). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
+/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = dlansb_("1", uplo, n, kd, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute the product U'*U, overwriting U. */
+
+ if (lsame_(uplo, "U")) {
+ for (k = *n; k >= 1; --k) {
+/* Computing MAX */
+ i__1 = 1, i__2 = *kd + 2 - k;
+ kc = max(i__1,i__2);
+ klen = *kd + 1 - kc;
+
+/* Compute the (K,K) element of the result. */
+
+ i__1 = klen + 1;
+ t = ddot_(&i__1, &afac[kc + k * afac_dim1], &c__1, &afac[kc + k *
+ afac_dim1], &c__1);
+ afac[*kd + 1 + k * afac_dim1] = t;
+
+/* Compute the rest of column K. */
+
+ if (klen > 0) {
+ i__1 = *ldafac - 1;
+ dtrmv_("Upper", "Transpose", "Non-unit", &klen, &afac[*kd + 1
+ + (k - klen) * afac_dim1], &i__1, &afac[kc + k *
+ afac_dim1], &c__1);
+ }
+
+/* L10: */
+ }
+
+/* UPLO = 'L': Compute the product L*L', overwriting L. */
+
+ } else {
+ for (k = *n; k >= 1; --k) {
+/* Computing MIN */
+ i__1 = *kd, i__2 = *n - k;
+ klen = min(i__1,i__2);
+
+/* Add a multiple of column K of the factor L to each of */
+/* columns K+1 through N. */
+
+ if (klen > 0) {
+ i__1 = *ldafac - 1;
+ dsyr_("Lower", &klen, &c_b14, &afac[k * afac_dim1 + 2], &c__1,
+ &afac[(k + 1) * afac_dim1 + 1], &i__1);
+ }
+
+/* Scale column K by the diagonal element. */
+
+ t = afac[k * afac_dim1 + 1];
+ i__1 = klen + 1;
+ dscal_(&i__1, &t, &afac[k * afac_dim1 + 1], &c__1);
+
+/* L20: */
+ }
+ }
+
+/* Compute the difference L*L' - A or U'*U - A. */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = 1, i__3 = *kd + 2 - j;
+ mu = max(i__2,i__3);
+ i__2 = *kd + 1;
+ for (i__ = mu; i__ <= i__2; ++i__) {
+ afac[i__ + j * afac_dim1] -= a[i__ + j * a_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *kd + 1, i__3 = *n - j + 1;
+ ml = min(i__2,i__3);
+ i__2 = ml;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ afac[i__ + j * afac_dim1] -= a[i__ + j * a_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+
+/* Compute norm( L*L' - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = dlansb_("I", uplo, n, kd, &afac[afac_offset], ldafac, &rwork[1]);
+
+ *resid = *resid / (doublereal) (*n) / anorm / eps;
+
+ return 0;
+
+/* End of DPBT01 */
+
+} /* dpbt01_ */
diff --git a/TESTING/LIN/dpbt02.c b/TESTING/LIN/dpbt02.c
new file mode 100644
index 0000000..4e5a39f
--- /dev/null
+++ b/TESTING/LIN/dpbt02.c
@@ -0,0 +1,181 @@
+/* dpbt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b5 = -1.;
+static integer c__1 = 1;
+static doublereal c_b7 = 1.;
+
+/* Subroutine */ int dpbt02_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *x, integer *ldx,
+ doublereal *b, integer *ldb, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ doublereal eps;
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dsbmv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ doublereal anorm, bnorm, xnorm;
+ extern doublereal dlamch_(char *), dlansb_(char *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPBT02 computes the residual for a solution of a symmetric banded */
+/* system of equations A*x = b: */
+/* RESID = norm( B - A*X ) / ( norm(A) * norm(X) * EPS) */
+/* where EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The original symmetric band matrix A. If UPLO = 'U', the */
+/* upper triangular part of A is stored as a band matrix; if */
+/* UPLO = 'L', the lower triangular part of A is stored. The */
+/* columns of the appropriate triangle are stored in the columns */
+/* of A and the diagonals of the triangle are stored in the rows */
+/* of A. See DPBTRF for further details. */
+
+/* LDA (input) INTEGER. */
+/* The leading dimension of the array A. LDA >= max(1,KD+1). */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = dlansb_("1", uplo, n, kd, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute B - A*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ dsbmv_(uplo, n, kd, &c_b5, &a[a_offset], lda, &x[j * x_dim1 + 1], &
+ c__1, &c_b7, &b[j * b_dim1 + 1], &c__1);
+/* L10: */
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = dasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = dasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L20: */
+ }
+
+ return 0;
+
+/* End of DPBT02 */
+
+} /* dpbt02_ */
diff --git a/TESTING/LIN/dpbt05.c b/TESTING/LIN/dpbt05.c
new file mode 100644
index 0000000..d712f59
--- /dev/null
+++ b/TESTING/LIN/dpbt05.c
@@ -0,0 +1,291 @@
+/* dpbt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dpbt05_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, doublereal *ab, integer *ldab, doublereal *b, integer *ldb,
+ doublereal *x, integer *ldx, doublereal *xact, integer *ldxact,
+ doublereal *ferr, doublereal *berr, doublereal *reslts)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, k, nz;
+ doublereal eps, tmp, diff, axbi;
+ integer imax;
+ doublereal unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ doublereal xnorm;
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal errbnd;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPBT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* symmetric band matrix. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+/* and NZ = max. number of nonzeros in any row of A, plus 1 */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The upper or lower triangle of the symmetric band matrix A, */
+/* stored in the first KD+1 rows of the array. The j-th column */
+/* of A is stored in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.;
+ reslts[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ upper = lsame_(uplo, "U");
+/* Computing MAX */
+ i__1 = *kd, i__2 = *n - 1;
+ nz = (max(i__1,i__2) << 1) + 1;
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = idamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ d__2 = (d__1 = x[imax + j * x_dim1], abs(d__1));
+ xnorm = max(d__2,unfl);
+ diff = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = diff, d__3 = (d__1 = x[i__ + j * x_dim1] - xact[i__ + j *
+ xact_dim1], abs(d__1));
+ diff = max(d__2,d__3);
+/* L10: */
+ }
+
+ if (xnorm > 1.) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1. / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
+ errbnd = max(d__1,d__2);
+ } else {
+ errbnd = 1. / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ tmp = (d__1 = b[i__ + k * b_dim1], abs(d__1));
+ if (upper) {
+/* Computing MAX */
+ i__3 = i__ - *kd;
+ i__4 = i__;
+ for (j = max(i__3,1); j <= i__4; ++j) {
+ tmp += (d__1 = ab[*kd + 1 - i__ + j + i__ * ab_dim1], abs(
+ d__1)) * (d__2 = x[j + k * x_dim1], abs(d__2));
+/* L40: */
+ }
+/* Computing MIN */
+ i__3 = i__ + *kd;
+ i__4 = min(i__3,*n);
+ for (j = i__ + 1; j <= i__4; ++j) {
+ tmp += (d__1 = ab[*kd + 1 + i__ - j + j * ab_dim1], abs(
+ d__1)) * (d__2 = x[j + k * x_dim1], abs(d__2));
+/* L50: */
+ }
+ } else {
+/* Computing MAX */
+ i__4 = i__ - *kd;
+ i__3 = i__ - 1;
+ for (j = max(i__4,1); j <= i__3; ++j) {
+ tmp += (d__1 = ab[i__ + 1 - j + j * ab_dim1], abs(d__1)) *
+ (d__2 = x[j + k * x_dim1], abs(d__2));
+/* L60: */
+ }
+/* Computing MIN */
+ i__4 = i__ + *kd;
+ i__3 = min(i__4,*n);
+ for (j = i__; j <= i__3; ++j) {
+ tmp += (d__1 = ab[j + 1 - i__ + i__ * ab_dim1], abs(d__1))
+ * (d__2 = x[j + k * x_dim1], abs(d__2));
+/* L70: */
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = min(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ d__1 = axbi, d__2 = nz * unfl;
+ tmp = berr[k] / (nz * eps + nz * unfl / max(d__1,d__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = max(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of DPBT05 */
+
+} /* dpbt05_ */
diff --git a/TESTING/LIN/dpot01.c b/TESTING/LIN/dpot01.c
new file mode 100644
index 0000000..ac47355
--- /dev/null
+++ b/TESTING/LIN/dpot01.c
@@ -0,0 +1,213 @@
+/* dpot01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b14 = 1.;
+
+/* Subroutine */ int dpot01_(char *uplo, integer *n, doublereal *a, integer *
+ lda, doublereal *afac, integer *ldafac, doublereal *rwork, doublereal
+ *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal t, eps;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ extern /* Subroutine */ int dsyr_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *), dscal_(
+ integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlansy_(char *, char *,
+ integer *, doublereal *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPOT01 reconstructs a symmetric positive definite matrix A from */
+/* its L*L' or U'*U factorization and computes the residual */
+/* norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
+/* norm( U'*U - A ) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The original symmetric matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* AFAC (input/output) DOUBLE PRECISION array, dimension (LDAFAC,N) */
+/* On entry, the factor L or U from the L*L' or U'*U */
+/* factorization of A. */
+/* Overwritten with the reconstructed matrix, and then with the */
+/* difference L*L' - A (or U'*U - A). */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
+/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = dlansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute the product U'*U, overwriting U. */
+
+ if (lsame_(uplo, "U")) {
+ for (k = *n; k >= 1; --k) {
+
+/* Compute the (K,K) element of the result. */
+
+ t = ddot_(&k, &afac[k * afac_dim1 + 1], &c__1, &afac[k *
+ afac_dim1 + 1], &c__1);
+ afac[k + k * afac_dim1] = t;
+
+/* Compute the rest of column K. */
+
+ i__1 = k - 1;
+ dtrmv_("Upper", "Transpose", "Non-unit", &i__1, &afac[afac_offset]
+, ldafac, &afac[k * afac_dim1 + 1], &c__1);
+
+/* L10: */
+ }
+
+/* Compute the product L*L', overwriting L. */
+
+ } else {
+ for (k = *n; k >= 1; --k) {
+
+/* Add a multiple of column K of the factor L to each of */
+/* columns K+1 through N. */
+
+ if (k + 1 <= *n) {
+ i__1 = *n - k;
+ dsyr_("Lower", &i__1, &c_b14, &afac[k + 1 + k * afac_dim1], &
+ c__1, &afac[k + 1 + (k + 1) * afac_dim1], ldafac);
+ }
+
+/* Scale column K by the diagonal element. */
+
+ t = afac[k + k * afac_dim1];
+ i__1 = *n - k + 1;
+ dscal_(&i__1, &t, &afac[k + k * afac_dim1], &c__1);
+
+/* L20: */
+ }
+ }
+
+/* Compute the difference L*L' - A (or U'*U - A). */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ afac[i__ + j * afac_dim1] -= a[i__ + j * a_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ afac[i__ + j * afac_dim1] -= a[i__ + j * a_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+
+/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = dlansy_("1", uplo, n, &afac[afac_offset], ldafac, &rwork[1]);
+
+ *resid = *resid / (doublereal) (*n) / anorm / eps;
+
+ return 0;
+
+/* End of DPOT01 */
+
+} /* dpot01_ */
diff --git a/TESTING/LIN/dpot02.c b/TESTING/LIN/dpot02.c
new file mode 100644
index 0000000..99cd14d
--- /dev/null
+++ b/TESTING/LIN/dpot02.c
@@ -0,0 +1,175 @@
+/* dpot02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b5 = -1.;
+static doublereal c_b6 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dpot02_(char *uplo, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *x, integer *ldx, doublereal *
+ b, integer *ldb, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ doublereal eps;
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal anorm, bnorm;
+ extern /* Subroutine */ int dsymm_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ doublereal xnorm;
+ extern doublereal dlamch_(char *), dlansy_(char *, char *,
+ integer *, doublereal *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPOT02 computes the residual for the solution of a symmetric system */
+/* of linear equations A*x = b: */
+
+/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ), */
+
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The original symmetric matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = dlansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute B - A*X */
+
+ dsymm_("Left", uplo, n, nrhs, &c_b5, &a[a_offset], lda, &x[x_offset], ldx,
+ &c_b6, &b[b_offset], ldb);
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = dasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = dasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of DPOT02 */
+
+} /* dpot02_ */
diff --git a/TESTING/LIN/dpot03.c b/TESTING/LIN/dpot03.c
new file mode 100644
index 0000000..e9b82d3
--- /dev/null
+++ b/TESTING/LIN/dpot03.c
@@ -0,0 +1,196 @@
+/* dpot03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b11 = -1.;
+static doublereal c_b12 = 0.;
+
+/* Subroutine */ int dpot03_(char *uplo, integer *n, doublereal *a, integer *
+ lda, doublereal *ainv, integer *ldainv, doublereal *work, integer *
+ ldwork, doublereal *rwork, doublereal *rcond, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, ainv_dim1, ainv_offset, work_dim1, work_offset,
+ i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int dsymm_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ doublereal ainvnm;
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPOT03 computes the residual for a symmetric matrix times its */
+/* inverse: */
+/* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The original symmetric matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* AINV (input/output) DOUBLE PRECISION array, dimension (LDAINV,N) */
+/* On entry, the inverse of the matrix A, stored as a symmetric */
+/* matrix in the same format as A. */
+/* In this version, AINV is expanded into a full matrix and */
+/* multiplied by A, so the opposing triangle of AINV will be */
+/* changed; i.e., if the upper triangular part of AINV is */
+/* stored, the lower triangular part will be used as work space. */
+
+/* LDAINV (input) INTEGER */
+/* The leading dimension of the array AINV. LDAINV >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal of the condition number of A, computed as */
+/* ( 1/norm(A) ) / norm(AINV). */
+
+/* RESID (output) DOUBLE PRECISION */
+/* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ ainv_dim1 = *ldainv;
+ ainv_offset = 1 + ainv_dim1;
+ ainv -= ainv_offset;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.;
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = dlansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+ ainvnm = dlansy_("1", uplo, n, &ainv[ainv_offset], ldainv, &rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ *rcond = 0.;
+ *resid = 1. / eps;
+ return 0;
+ }
+ *rcond = 1. / anorm / ainvnm;
+
+/* Expand AINV into a full matrix and call DSYMM to multiply */
+/* AINV on the left by A. */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ainv[j + i__ * ainv_dim1] = ainv[i__ + j * ainv_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ ainv[j + i__ * ainv_dim1] = ainv[i__ + j * ainv_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ dsymm_("Left", uplo, n, n, &c_b11, &a[a_offset], lda, &ainv[ainv_offset],
+ ldainv, &c_b12, &work[work_offset], ldwork);
+
+/* Add the identity matrix to WORK . */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__ + i__ * work_dim1] += 1.;
+/* L50: */
+ }
+
+/* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = dlange_("1", n, n, &work[work_offset], ldwork, &rwork[1]);
+
+ *resid = *resid * *rcond / eps / (doublereal) (*n);
+
+ return 0;
+
+/* End of DPOT03 */
+
+} /* dpot03_ */
diff --git a/TESTING/LIN/dpot05.c b/TESTING/LIN/dpot05.c
new file mode 100644
index 0000000..296c902
--- /dev/null
+++ b/TESTING/LIN/dpot05.c
@@ -0,0 +1,277 @@
+/* dpot05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dpot05_(char *uplo, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
+ x, integer *ldx, doublereal *xact, integer *ldxact, doublereal *ferr,
+ doublereal *berr, doublereal *reslts)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal eps, tmp, diff, axbi;
+ integer imax;
+ doublereal unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ doublereal xnorm;
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal errbnd;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPOT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* symmetric n by n matrix. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of A contains the upper triangular part */
+/* of the matrix A, and the strictly lower triangular part of A */
+/* is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of A contains the lower triangular part of */
+/* the matrix A, and the strictly upper triangular part of A is */
+/* not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.;
+ reslts[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ upper = lsame_(uplo, "U");
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = idamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ d__2 = (d__1 = x[imax + j * x_dim1], abs(d__1));
+ xnorm = max(d__2,unfl);
+ diff = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = diff, d__3 = (d__1 = x[i__ + j * x_dim1] - xact[i__ + j *
+ xact_dim1], abs(d__1));
+ diff = max(d__2,d__3);
+/* L10: */
+ }
+
+ if (xnorm > 1.) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1. / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
+ errbnd = max(d__1,d__2);
+ } else {
+ errbnd = 1. / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ tmp = (d__1 = b[i__ + k * b_dim1], abs(d__1));
+ if (upper) {
+ i__3 = i__;
+ for (j = 1; j <= i__3; ++j) {
+ tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1)) * (d__2 =
+ x[j + k * x_dim1], abs(d__2));
+/* L40: */
+ }
+ i__3 = *n;
+ for (j = i__ + 1; j <= i__3; ++j) {
+ tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * (d__2 =
+ x[j + k * x_dim1], abs(d__2));
+/* L50: */
+ }
+ } else {
+ i__3 = i__ - 1;
+ for (j = 1; j <= i__3; ++j) {
+ tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * (d__2 =
+ x[j + k * x_dim1], abs(d__2));
+/* L60: */
+ }
+ i__3 = *n;
+ for (j = i__; j <= i__3; ++j) {
+ tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1)) * (d__2 =
+ x[j + k * x_dim1], abs(d__2));
+/* L70: */
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = min(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ d__1 = axbi, d__2 = (*n + 1) * unfl;
+ tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / max(d__1,d__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = max(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of DPOT05 */
+
+} /* dpot05_ */
diff --git a/TESTING/LIN/dpot06.c b/TESTING/LIN/dpot06.c
new file mode 100644
index 0000000..a5742d6
--- /dev/null
+++ b/TESTING/LIN/dpot06.c
@@ -0,0 +1,180 @@
+/* dpot06.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b5 = -1.;
+static doublereal c_b6 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dpot06_(char *uplo, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *x, integer *ldx, doublereal *
+ b, integer *ldb, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ doublereal eps;
+ integer ifail;
+ doublereal anorm, bnorm;
+ extern /* Subroutine */ int dsymm_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ doublereal xnorm;
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* April 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPOT06 computes the residual for a solution of a system of linear */
+/* equations A*x = b : */
+/* RESID = norm(B - A*X,inf) / ( norm(A,inf) * norm(X,inf) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The original M x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,N). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. IF TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs == 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = dlansy_("I", uplo, n, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute B - A*X and store in B. */
+ ifail = 0;
+
+ dsymm_("Left", uplo, n, nrhs, &c_b5, &a[a_offset], lda, &x[x_offset], ldx,
+ &c_b6, &b[b_offset], ldb);
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = (d__1 = b[idamax_(n, &b[j * b_dim1 + 1], &c__1) + j * b_dim1],
+ abs(d__1));
+ xnorm = (d__1 = x[idamax_(n, &x[j * x_dim1 + 1], &c__1) + j * x_dim1],
+ abs(d__1));
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of DPOT06 */
+
+} /* dpot06_ */
diff --git a/TESTING/LIN/dppt01.c b/TESTING/LIN/dppt01.c
new file mode 100644
index 0000000..7a48f6f
--- /dev/null
+++ b/TESTING/LIN/dppt01.c
@@ -0,0 +1,195 @@
+/* dppt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b14 = 1.;
+
+/* Subroutine */ int dppt01_(char *uplo, integer *n, doublereal *a,
+ doublereal *afac, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, k;
+ doublereal t;
+ integer kc;
+ doublereal eps;
+ integer npp;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ extern /* Subroutine */ int dspr_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *), dscal_(integer *,
+ doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *,
+ doublereal *, doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlansp_(char *, char *,
+ integer *, doublereal *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPPT01 reconstructs a symmetric positive definite packed matrix A */
+/* from its L*L' or U'*U factorization and computes the residual */
+/* norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
+/* norm( U'*U - A ) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The original symmetric matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* AFAC (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* On entry, the factor L or U from the L*L' or U'*U */
+/* factorization of A, stored as a packed triangular matrix. */
+/* Overwritten with the reconstructed matrix, and then with the */
+/* difference L*L' - A (or U'*U - A). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
+/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 */
+
+ /* Parameter adjustments */
+ --rwork;
+ --afac;
+ --a;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = dlansp_("1", uplo, n, &a[1], &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute the product U'*U, overwriting U. */
+
+ if (lsame_(uplo, "U")) {
+ kc = *n * (*n - 1) / 2 + 1;
+ for (k = *n; k >= 1; --k) {
+
+/* Compute the (K,K) element of the result. */
+
+ t = ddot_(&k, &afac[kc], &c__1, &afac[kc], &c__1);
+ afac[kc + k - 1] = t;
+
+/* Compute the rest of column K. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ dtpmv_("Upper", "Transpose", "Non-unit", &i__1, &afac[1], &
+ afac[kc], &c__1);
+ kc -= k - 1;
+ }
+/* L10: */
+ }
+
+/* Compute the product L*L', overwriting L. */
+
+ } else {
+ kc = *n * (*n + 1) / 2;
+ for (k = *n; k >= 1; --k) {
+
+/* Add a multiple of column K of the factor L to each of */
+/* columns K+1 through N. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ dspr_("Lower", &i__1, &c_b14, &afac[kc + 1], &c__1, &afac[kc
+ + *n - k + 1]);
+ }
+
+/* Scale column K by the diagonal element. */
+
+ t = afac[kc];
+ i__1 = *n - k + 1;
+ dscal_(&i__1, &t, &afac[kc], &c__1);
+
+ kc -= *n - k + 2;
+/* L20: */
+ }
+ }
+
+/* Compute the difference L*L' - A (or U'*U - A). */
+
+ npp = *n * (*n + 1) / 2;
+ i__1 = npp;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ afac[i__] -= a[i__];
+/* L30: */
+ }
+
+/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = dlansp_("1", uplo, n, &afac[1], &rwork[1]);
+
+ *resid = *resid / (doublereal) (*n) / anorm / eps;
+
+ return 0;
+
+/* End of DPPT01 */
+
+} /* dppt01_ */
diff --git a/TESTING/LIN/dppt02.c b/TESTING/LIN/dppt02.c
new file mode 100644
index 0000000..c6d6036
--- /dev/null
+++ b/TESTING/LIN/dppt02.c
@@ -0,0 +1,176 @@
+/* dppt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b5 = -1.;
+static integer c__1 = 1;
+static doublereal c_b7 = 1.;
+
+/* Subroutine */ int dppt02_(char *uplo, integer *n, integer *nrhs,
+ doublereal *a, doublereal *x, integer *ldx, doublereal *b, integer *
+ ldb, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ doublereal eps;
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal anorm, bnorm;
+ extern /* Subroutine */ int dspmv_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ doublereal xnorm;
+ extern doublereal dlamch_(char *), dlansp_(char *, char *,
+ integer *, doublereal *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPPT02 computes the residual in the solution of a symmetric system */
+/* of linear equations A*x = b when packed storage is used for the */
+/* coefficient matrix. The ratio computed is */
+
+/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS), */
+
+/* where EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The original symmetric matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ --a;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = dlansp_("1", uplo, n, &a[1], &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute B - A*X for the matrix of right hand sides B. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ dspmv_(uplo, n, &c_b5, &a[1], &x[j * x_dim1 + 1], &c__1, &c_b7, &b[j *
+ b_dim1 + 1], &c__1);
+/* L10: */
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = dasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = dasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L20: */
+ }
+
+ return 0;
+
+/* End of DPPT02 */
+
+} /* dppt02_ */
diff --git a/TESTING/LIN/dppt03.c b/TESTING/LIN/dppt03.c
new file mode 100644
index 0000000..95a7db7
--- /dev/null
+++ b/TESTING/LIN/dppt03.c
@@ -0,0 +1,228 @@
+/* dppt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b13 = -1.;
+static doublereal c_b15 = 0.;
+
+/* Subroutine */ int dppt03_(char *uplo, integer *n, doublereal *a,
+ doublereal *ainv, doublereal *work, integer *ldwork, doublereal *
+ rwork, doublereal *rcond, doublereal *resid)
+{
+ /* System generated locals */
+ integer work_dim1, work_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, jj;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dspmv_(char *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *),
+ dlansp_(char *, char *, integer *, doublereal *, doublereal *);
+ doublereal ainvnm;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPPT03 computes the residual for a symmetric packed matrix times its */
+/* inverse: */
+/* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The original symmetric matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* AINV (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The (symmetric) inverse of the matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal of the condition number of A, computed as */
+/* ( 1/norm(A) ) / norm(AINV). */
+
+/* RESID (output) DOUBLE PRECISION */
+/* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ --a;
+ --ainv;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.;
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = dlansp_("1", uplo, n, &a[1], &rwork[1]);
+ ainvnm = dlansp_("1", uplo, n, &ainv[1], &rwork[1]);
+ if (anorm <= 0. || ainvnm == 0.) {
+ *rcond = 0.;
+ *resid = 1. / eps;
+ return 0;
+ }
+ *rcond = 1. / anorm / ainvnm;
+
+/* UPLO = 'U': */
+/* Copy the leading N-1 x N-1 submatrix of AINV to WORK(1:N,2:N) and */
+/* expand it to a full matrix, then multiply by A one column at a */
+/* time, moving the result one column to the left. */
+
+ if (lsame_(uplo, "U")) {
+
+/* Copy AINV */
+
+ jj = 1;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(&j, &ainv[jj], &c__1, &work[(j + 1) * work_dim1 + 1], &
+ c__1);
+ i__2 = j - 1;
+ dcopy_(&i__2, &ainv[jj], &c__1, &work[j + (work_dim1 << 1)],
+ ldwork);
+ jj += j;
+/* L10: */
+ }
+ jj = (*n - 1) * *n / 2 + 1;
+ i__1 = *n - 1;
+ dcopy_(&i__1, &ainv[jj], &c__1, &work[*n + (work_dim1 << 1)], ldwork);
+
+/* Multiply by A */
+
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ dspmv_("Upper", n, &c_b13, &a[1], &work[(j + 1) * work_dim1 + 1],
+ &c__1, &c_b15, &work[j * work_dim1 + 1], &c__1)
+ ;
+/* L20: */
+ }
+ dspmv_("Upper", n, &c_b13, &a[1], &ainv[jj], &c__1, &c_b15, &work[*n *
+ work_dim1 + 1], &c__1);
+
+/* UPLO = 'L': */
+/* Copy the trailing N-1 x N-1 submatrix of AINV to WORK(1:N,1:N-1) */
+/* and multiply by A, moving each column to the right. */
+
+ } else {
+
+/* Copy AINV */
+
+ i__1 = *n - 1;
+ dcopy_(&i__1, &ainv[2], &c__1, &work[work_dim1 + 1], ldwork);
+ jj = *n + 1;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ dcopy_(&i__2, &ainv[jj], &c__1, &work[j + (j - 1) * work_dim1], &
+ c__1);
+ i__2 = *n - j;
+ dcopy_(&i__2, &ainv[jj + 1], &c__1, &work[j + j * work_dim1],
+ ldwork);
+ jj = jj + *n - j + 1;
+/* L30: */
+ }
+
+/* Multiply by A */
+
+ for (j = *n; j >= 2; --j) {
+ dspmv_("Lower", n, &c_b13, &a[1], &work[(j - 1) * work_dim1 + 1],
+ &c__1, &c_b15, &work[j * work_dim1 + 1], &c__1)
+ ;
+/* L40: */
+ }
+ dspmv_("Lower", n, &c_b13, &a[1], &ainv[1], &c__1, &c_b15, &work[
+ work_dim1 + 1], &c__1);
+
+ }
+
+/* Add the identity matrix to WORK . */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__ + i__ * work_dim1] += 1.;
+/* L50: */
+ }
+
+/* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = dlange_("1", n, n, &work[work_offset], ldwork, &rwork[1]);
+
+ *resid = *resid * *rcond / eps / (doublereal) (*n);
+
+ return 0;
+
+/* End of DPPT03 */
+
+} /* dppt03_ */
diff --git a/TESTING/LIN/dppt05.c b/TESTING/LIN/dppt05.c
new file mode 100644
index 0000000..c7781a9
--- /dev/null
+++ b/TESTING/LIN/dppt05.c
@@ -0,0 +1,275 @@
+/* dppt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dppt05_(char *uplo, integer *n, integer *nrhs,
+ doublereal *ap, doublereal *b, integer *ldb, doublereal *x, integer *
+ ldx, doublereal *xact, integer *ldxact, doublereal *ferr, doublereal *
+ berr, doublereal *reslts)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1,
+ i__2, i__3;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, k, jc;
+ doublereal eps, tmp, diff, axbi;
+ integer imax;
+ doublereal unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ doublereal xnorm;
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal errbnd;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPPT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* symmetric matrix in packed storage format. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the symmetric matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.;
+ reslts[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ upper = lsame_(uplo, "U");
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = idamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ d__2 = (d__1 = x[imax + j * x_dim1], abs(d__1));
+ xnorm = max(d__2,unfl);
+ diff = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = diff, d__3 = (d__1 = x[i__ + j * x_dim1] - xact[i__ + j *
+ xact_dim1], abs(d__1));
+ diff = max(d__2,d__3);
+/* L10: */
+ }
+
+ if (xnorm > 1.) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1. / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
+ errbnd = max(d__1,d__2);
+ } else {
+ errbnd = 1. / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ tmp = (d__1 = b[i__ + k * b_dim1], abs(d__1));
+ if (upper) {
+ jc = (i__ - 1) * i__ / 2;
+ i__3 = i__;
+ for (j = 1; j <= i__3; ++j) {
+ tmp += (d__1 = ap[jc + j], abs(d__1)) * (d__2 = x[j + k *
+ x_dim1], abs(d__2));
+/* L40: */
+ }
+ jc += i__;
+ i__3 = *n;
+ for (j = i__ + 1; j <= i__3; ++j) {
+ tmp += (d__1 = ap[jc], abs(d__1)) * (d__2 = x[j + k *
+ x_dim1], abs(d__2));
+ jc += j;
+/* L50: */
+ }
+ } else {
+ jc = i__;
+ i__3 = i__ - 1;
+ for (j = 1; j <= i__3; ++j) {
+ tmp += (d__1 = ap[jc], abs(d__1)) * (d__2 = x[j + k *
+ x_dim1], abs(d__2));
+ jc = jc + *n - j;
+/* L60: */
+ }
+ i__3 = *n;
+ for (j = i__; j <= i__3; ++j) {
+ tmp += (d__1 = ap[jc + j - i__], abs(d__1)) * (d__2 = x[j
+ + k * x_dim1], abs(d__2));
+/* L70: */
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = min(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ d__1 = axbi, d__2 = (*n + 1) * unfl;
+ tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / max(d__1,d__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = max(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of DPPT05 */
+
+} /* dppt05_ */
diff --git a/TESTING/LIN/dpst01.c b/TESTING/LIN/dpst01.c
new file mode 100644
index 0000000..586a6c7
--- /dev/null
+++ b/TESTING/LIN/dpst01.c
@@ -0,0 +1,301 @@
+/* dpst01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b18 = 1.;
+
+/* Subroutine */ int dpst01_(char *uplo, integer *n, doublereal *a, integer *
+ lda, doublereal *afac, integer *ldafac, doublereal *perm, integer *
+ ldperm, integer *piv, doublereal *rwork, doublereal *resid, integer *
+ rank)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, perm_dim1, perm_offset,
+ i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal t, eps;
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ extern /* Subroutine */ int dsyr_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *), dscal_(
+ integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlansy_(char *, char *,
+ integer *, doublereal *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPST01 reconstructs a symmetric positive semidefinite matrix A */
+/* from its L or U factors and the permutation matrix P and computes */
+/* the residual */
+/* norm( P*L*L'*P' - A ) / ( N * norm(A) * EPS ) or */
+/* norm( P*U'*U*P' - A ) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The original symmetric matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* AFAC (input) DOUBLE PRECISION array, dimension (LDAFAC,N) */
+/* The factor L or U from the L*L' or U'*U */
+/* factorization of A. */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
+
+/* PERM (output) DOUBLE PRECISION array, dimension (LDPERM,N) */
+/* Overwritten with the reconstructed matrix, and then with the */
+/* difference P*L*L'*P' - A (or P*U'*U*P' - A) */
+
+/* LDPERM (input) INTEGER */
+/* The leading dimension of the array PERM. */
+/* LDAPERM >= max(1,N). */
+
+/* PIV (input) INTEGER array, dimension (N) */
+/* PIV is such that the nonzero entries are */
+/* P( PIV( K ), K ) = 1. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
+/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ perm_dim1 = *ldperm;
+ perm_offset = 1 + perm_dim1;
+ perm -= perm_offset;
+ --piv;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = dlansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute the product U'*U, overwriting U. */
+
+ if (lsame_(uplo, "U")) {
+
+ if (*rank < *n) {
+ i__1 = *n;
+ for (j = *rank + 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = *rank + 1; i__ <= i__2; ++i__) {
+ afac[i__ + j * afac_dim1] = 0.;
+/* L100: */
+ }
+/* L110: */
+ }
+ }
+
+ for (k = *n; k >= 1; --k) {
+
+/* Compute the (K,K) element of the result. */
+
+ t = ddot_(&k, &afac[k * afac_dim1 + 1], &c__1, &afac[k *
+ afac_dim1 + 1], &c__1);
+ afac[k + k * afac_dim1] = t;
+
+/* Compute the rest of column K. */
+
+ i__1 = k - 1;
+ dtrmv_("Upper", "Transpose", "Non-unit", &i__1, &afac[afac_offset]
+, ldafac, &afac[k * afac_dim1 + 1], &c__1);
+
+/* L120: */
+ }
+
+/* Compute the product L*L', overwriting L. */
+
+ } else {
+
+ if (*rank < *n) {
+ i__1 = *n;
+ for (j = *rank + 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ afac[i__ + j * afac_dim1] = 0.;
+/* L130: */
+ }
+/* L140: */
+ }
+ }
+
+ for (k = *n; k >= 1; --k) {
+/* Add a multiple of column K of the factor L to each of */
+/* columns K+1 through N. */
+
+ if (k + 1 <= *n) {
+ i__1 = *n - k;
+ dsyr_("Lower", &i__1, &c_b18, &afac[k + 1 + k * afac_dim1], &
+ c__1, &afac[k + 1 + (k + 1) * afac_dim1], ldafac);
+ }
+
+/* Scale column K by the diagonal element. */
+
+ t = afac[k + k * afac_dim1];
+ i__1 = *n - k + 1;
+ dscal_(&i__1, &t, &afac[k + k * afac_dim1], &c__1);
+/* L150: */
+ }
+
+ }
+
+/* Form P*L*L'*P' or P*U'*U*P' */
+
+ if (lsame_(uplo, "U")) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (piv[i__] <= piv[j]) {
+ if (i__ <= j) {
+ perm[piv[i__] + piv[j] * perm_dim1] = afac[i__ + j *
+ afac_dim1];
+ } else {
+ perm[piv[i__] + piv[j] * perm_dim1] = afac[j + i__ *
+ afac_dim1];
+ }
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+
+
+ } else {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (piv[i__] >= piv[j]) {
+ if (i__ >= j) {
+ perm[piv[i__] + piv[j] * perm_dim1] = afac[i__ + j *
+ afac_dim1];
+ } else {
+ perm[piv[i__] + piv[j] * perm_dim1] = afac[j + i__ *
+ afac_dim1];
+ }
+ }
+/* L180: */
+ }
+/* L190: */
+ }
+
+ }
+
+/* Compute the difference P*L*L'*P' - A (or P*U'*U*P' - A). */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ perm[i__ + j * perm_dim1] -= a[i__ + j * a_dim1];
+/* L200: */
+ }
+/* L210: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ perm[i__ + j * perm_dim1] -= a[i__ + j * a_dim1];
+/* L220: */
+ }
+/* L230: */
+ }
+ }
+
+/* Compute norm( P*L*L'P - A ) / ( N * norm(A) * EPS ), or */
+/* ( P*U'*U*P' - A )/ ( N * norm(A) * EPS ). */
+
+ *resid = dlansy_("1", uplo, n, &perm[perm_offset], ldafac, &rwork[1]);
+
+ *resid = *resid / (doublereal) (*n) / anorm / eps;
+
+ return 0;
+
+/* End of DPST01 */
+
+} /* dpst01_ */
diff --git a/TESTING/LIN/dptt01.c b/TESTING/LIN/dptt01.c
new file mode 100644
index 0000000..5d0332d
--- /dev/null
+++ b/TESTING/LIN/dptt01.c
@@ -0,0 +1,155 @@
+/* dptt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dptt01_(integer *n, doublereal *d__, doublereal *e,
+ doublereal *df, doublereal *ef, doublereal *work, doublereal *resid)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2, d__3, d__4, d__5;
+
+ /* Local variables */
+ integer i__;
+ doublereal de, eps, anorm;
+ extern doublereal dlamch_(char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPTT01 reconstructs a tridiagonal matrix A from its L*D*L' */
+/* factorization and computes the residual */
+/* norm(L*D*L' - A) / ( n * norm(A) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGTER */
+/* The order of the matrix A. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
+
+/* DF (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the factor L from the L*D*L' */
+/* factorization of A. */
+
+/* EF (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the factor L from the */
+/* L*D*L' factorization of A. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* norm(L*D*L' - A) / (n * norm(A) * EPS) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --work;
+ --ef;
+ --df;
+ --e;
+ --d__;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+
+/* Construct the difference L*D*L' - A. */
+
+ work[1] = df[1] - d__[1];
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ de = df[i__] * ef[i__];
+ work[*n + i__] = de - e[i__];
+ work[i__ + 1] = de * ef[i__] + df[i__ + 1] - d__[i__ + 1];
+/* L10: */
+ }
+
+/* Compute the 1-norms of the tridiagonal matrices A and WORK. */
+
+ if (*n == 1) {
+ anorm = d__[1];
+ *resid = abs(work[1]);
+ } else {
+/* Computing MAX */
+ d__2 = d__[1] + abs(e[1]), d__3 = d__[*n] + (d__1 = e[*n - 1], abs(
+ d__1));
+ anorm = max(d__2,d__3);
+/* Computing MAX */
+ d__4 = abs(work[1]) + (d__1 = work[*n + 1], abs(d__1)), d__5 = (d__2 =
+ work[*n], abs(d__2)) + (d__3 = work[(*n << 1) - 1], abs(d__3)
+ );
+ *resid = max(d__4,d__5);
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__3 = anorm, d__4 = d__[i__] + (d__1 = e[i__], abs(d__1)) + (
+ d__2 = e[i__ - 1], abs(d__2));
+ anorm = max(d__3,d__4);
+/* Computing MAX */
+ d__4 = *resid, d__5 = (d__1 = work[i__], abs(d__1)) + (d__2 =
+ work[*n + i__ - 1], abs(d__2)) + (d__3 = work[*n + i__],
+ abs(d__3));
+ *resid = max(d__4,d__5);
+/* L20: */
+ }
+ }
+
+/* Compute norm(L*D*L' - A) / (n * norm(A) * EPS) */
+
+ if (anorm <= 0.) {
+ if (*resid != 0.) {
+ *resid = 1. / eps;
+ }
+ } else {
+ *resid = *resid / (doublereal) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of DPTT01 */
+
+} /* dptt01_ */
diff --git a/TESTING/LIN/dptt02.c b/TESTING/LIN/dptt02.c
new file mode 100644
index 0000000..ca92e19
--- /dev/null
+++ b/TESTING/LIN/dptt02.c
@@ -0,0 +1,162 @@
+/* dptt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b4 = -1.;
+static doublereal c_b5 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dptt02_(integer *n, integer *nrhs, doublereal *d__,
+ doublereal *e, doublereal *x, integer *ldx, doublereal *b, integer *
+ ldb, doublereal *resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ doublereal eps;
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal anorm, bnorm, xnorm;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlaptm_(integer *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *);
+ extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPTT02 computes the residual for the solution to a symmetric */
+/* tridiagonal system of equations: */
+/* RESID = norm(B - A*X) / (norm(A) * norm(X) * EPS), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGTER */
+/* The order of the matrix A. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The n by nrhs matrix of solution vectors X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the n by nrhs matrix of right hand side vectors B. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RESID (output) DOUBLE PRECISION */
+/* norm(B - A*X) / (norm(A) * norm(X) * EPS) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Compute the 1-norm of the tridiagonal matrix A. */
+
+ anorm = dlanst_("1", n, &d__[1], &e[1]);
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute B - A*X. */
+
+ dlaptm_(n, nrhs, &c_b4, &d__[1], &e[1], &x[x_offset], ldx, &c_b5, &b[
+ b_offset], ldb);
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = dasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = dasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of DPTT02 */
+
+} /* dptt02_ */
diff --git a/TESTING/LIN/dptt05.c b/TESTING/LIN/dptt05.c
new file mode 100644
index 0000000..b452573
--- /dev/null
+++ b/TESTING/LIN/dptt05.c
@@ -0,0 +1,246 @@
+/* dptt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dptt05_(integer *n, integer *nrhs, doublereal *d__,
+ doublereal *e, doublereal *b, integer *ldb, doublereal *x, integer *
+ ldx, doublereal *xact, integer *ldxact, doublereal *ferr, doublereal *
+ berr, doublereal *reslts)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1,
+ i__2;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Local variables */
+ integer i__, j, k, nz;
+ doublereal eps, tmp, diff, axbi;
+ integer imax;
+ doublereal unfl, ovfl, xnorm;
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal errbnd;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DPTT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* symmetric tridiagonal matrix of order n. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+/* and NZ = max. number of nonzeros in any row of A, plus 1 */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) DOUBLE PRECISION array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.;
+ reslts[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ nz = 4;
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = idamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ d__2 = (d__1 = x[imax + j * x_dim1], abs(d__1));
+ xnorm = max(d__2,unfl);
+ diff = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = diff, d__3 = (d__1 = x[i__ + j * x_dim1] - xact[i__ + j *
+ xact_dim1], abs(d__1));
+ diff = max(d__2,d__3);
+/* L10: */
+ }
+
+ if (xnorm > 1.) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1. / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
+ errbnd = max(d__1,d__2);
+ } else {
+ errbnd = 1. / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ if (*n == 1) {
+ axbi = (d__1 = b[k * b_dim1 + 1], abs(d__1)) + (d__2 = d__[1] * x[
+ k * x_dim1 + 1], abs(d__2));
+ } else {
+ axbi = (d__1 = b[k * b_dim1 + 1], abs(d__1)) + (d__2 = d__[1] * x[
+ k * x_dim1 + 1], abs(d__2)) + (d__3 = e[1] * x[k * x_dim1
+ + 2], abs(d__3));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ tmp = (d__1 = b[i__ + k * b_dim1], abs(d__1)) + (d__2 = e[i__
+ - 1] * x[i__ - 1 + k * x_dim1], abs(d__2)) + (d__3 =
+ d__[i__] * x[i__ + k * x_dim1], abs(d__3)) + (d__4 =
+ e[i__] * x[i__ + 1 + k * x_dim1], abs(d__4));
+ axbi = min(axbi,tmp);
+/* L40: */
+ }
+ tmp = (d__1 = b[*n + k * b_dim1], abs(d__1)) + (d__2 = e[*n - 1] *
+ x[*n - 1 + k * x_dim1], abs(d__2)) + (d__3 = d__[*n] * x[
+ *n + k * x_dim1], abs(d__3));
+ axbi = min(axbi,tmp);
+ }
+/* Computing MAX */
+ d__1 = axbi, d__2 = nz * unfl;
+ tmp = berr[k] / (nz * eps + nz * unfl / max(d__1,d__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = max(reslts[2],tmp);
+ }
+/* L50: */
+ }
+
+ return 0;
+
+/* End of DPTT05 */
+
+} /* dptt05_ */
diff --git a/TESTING/LIN/dqlt01.c b/TESTING/LIN/dqlt01.c
new file mode 100644
index 0000000..33b5e6e
--- /dev/null
+++ b/TESTING/LIN/dqlt01.c
@@ -0,0 +1,253 @@
+/* dqlt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublereal c_b6 = -1e10;
+static doublereal c_b13 = 0.;
+static doublereal c_b20 = -1.;
+static doublereal c_b21 = 1.;
+
+/* Subroutine */ int dqlt01_(integer *m, integer *n, doublereal *a,
+ doublereal *af, doublereal *q, doublereal *l, integer *lda,
+ doublereal *tau, doublereal *work, integer *lwork, doublereal *rwork,
+ doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
+ q_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal eps;
+ integer info;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ doublereal resid, anorm;
+ integer minmn;
+ extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dgeqlf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *),
+ dlacpy_(char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *), dlaset_(char *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *), dorgql_(integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DQLT01 tests DGEQLF, which computes the QL factorization of an m-by-n */
+/* matrix A, and partially tests DORGQL which forms the m-by-m */
+/* orthogonal matrix Q. */
+
+/* DQLT01 compares L with Q'*A, and checks that Q is orthogonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The m-by-n matrix A. */
+
+/* AF (output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* Details of the QL factorization of A, as returned by DGEQLF. */
+/* See DGEQLF for further details. */
+
+/* Q (output) DOUBLE PRECISION array, dimension (LDA,M) */
+/* The m-by-m orthogonal matrix Q. */
+
+/* L (workspace) DOUBLE PRECISION array, dimension (LDA,max(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and R. */
+/* LDA >= max(M,N). */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by DGEQLF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ l_dim1 = *lda;
+ l_offset = 1 + l_dim1;
+ l -= l_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ minmn = min(*m,*n);
+ eps = dlamch_("Epsilon");
+
+/* Copy the matrix A to the array AF. */
+
+ dlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+
+/* Factorize the matrix A in the array AF. */
+
+ s_copy(srnamc_1.srnamt, "DGEQLF", (ftnlen)32, (ftnlen)6);
+ dgeqlf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy details of Q */
+
+ dlaset_("Full", m, m, &c_b6, &c_b6, &q[q_offset], lda);
+ if (*m >= *n) {
+ if (*n < *m && *n > 0) {
+ i__1 = *m - *n;
+ dlacpy_("Full", &i__1, n, &af[af_offset], lda, &q[(*m - *n + 1) *
+ q_dim1 + 1], lda);
+ }
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ dlacpy_("Upper", &i__1, &i__2, &af[*m - *n + 1 + (af_dim1 << 1)],
+ lda, &q[*m - *n + 1 + (*m - *n + 2) * q_dim1], lda);
+ }
+ } else {
+ if (*m > 1) {
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ dlacpy_("Upper", &i__1, &i__2, &af[(*n - *m + 2) * af_dim1 + 1],
+ lda, &q[(q_dim1 << 1) + 1], lda);
+ }
+ }
+
+/* Generate the m-by-m matrix Q */
+
+ s_copy(srnamc_1.srnamt, "DORGQL", (ftnlen)32, (ftnlen)6);
+ dorgql_(m, m, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy L */
+
+ dlaset_("Full", m, n, &c_b13, &c_b13, &l[l_offset], lda);
+ if (*m >= *n) {
+ if (*n > 0) {
+ dlacpy_("Lower", n, n, &af[*m - *n + 1 + af_dim1], lda, &l[*m - *
+ n + 1 + l_dim1], lda);
+ }
+ } else {
+ if (*n > *m && *m > 0) {
+ i__1 = *n - *m;
+ dlacpy_("Full", m, &i__1, &af[af_offset], lda, &l[l_offset], lda);
+ }
+ if (*m > 0) {
+ dlacpy_("Lower", m, m, &af[(*n - *m + 1) * af_dim1 + 1], lda, &l[(
+ *n - *m + 1) * l_dim1 + 1], lda);
+ }
+ }
+
+/* Compute L - Q'*A */
+
+ dgemm_("Transpose", "No transpose", m, n, m, &c_b20, &q[q_offset], lda, &
+ a[a_offset], lda, &c_b21, &l[l_offset], lda);
+
+/* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */
+
+ anorm = dlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ resid = dlange_("1", m, n, &l[l_offset], lda, &rwork[1]);
+ if (anorm > 0.) {
+ result[1] = resid / (doublereal) max(1,*m) / anorm / eps;
+ } else {
+ result[1] = 0.;
+ }
+
+/* Compute I - Q'*Q */
+
+ dlaset_("Full", m, m, &c_b13, &c_b21, &l[l_offset], lda);
+ dsyrk_("Upper", "Transpose", m, m, &c_b20, &q[q_offset], lda, &c_b21, &l[
+ l_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
+
+ resid = dlansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
+
+ result[2] = resid / (doublereal) max(1,*m) / eps;
+
+ return 0;
+
+/* End of DQLT01 */
+
+} /* dqlt01_ */
diff --git a/TESTING/LIN/dqlt02.c b/TESTING/LIN/dqlt02.c
new file mode 100644
index 0000000..432ff98
--- /dev/null
+++ b/TESTING/LIN/dqlt02.c
@@ -0,0 +1,239 @@
+/* dqlt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublereal c_b4 = -1e10;
+static doublereal c_b10 = 0.;
+static doublereal c_b15 = -1.;
+static doublereal c_b16 = 1.;
+
+/* Subroutine */ int dqlt02_(integer *m, integer *n, integer *k, doublereal *
+ a, doublereal *af, doublereal *q, doublereal *l, integer *lda,
+ doublereal *tau, doublereal *work, integer *lwork, doublereal *rwork,
+ doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
+ q_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal eps;
+ integer info;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ doublereal resid, anorm;
+ extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), dorgql_(integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DQLT02 tests DORGQL, which generates an m-by-n matrix Q with */
+/* orthonornmal columns that is defined as the product of k elementary */
+/* reflectors. */
+
+/* Given the QL factorization of an m-by-n matrix A, DQLT02 generates */
+/* the orthogonal matrix Q defined by the factorization of the last k */
+/* columns of A; it compares L(m-n+1:m,n-k+1:n) with */
+/* Q(1:m,m-n+1:m)'*A(1:m,n-k+1:n), and checks that the columns of Q are */
+/* orthonormal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q to be generated. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q to be generated. */
+/* M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The m-by-n matrix A which was factorized by DQLT01. */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* Details of the QL factorization of A, as returned by DGEQLF. */
+/* See DGEQLF for further details. */
+
+/* Q (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
+
+/* L (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and L. LDA >= M. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (N) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the QL factorization in AF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ l_dim1 = *lda;
+ l_offset = 1 + l_dim1;
+ l -= l_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ if (*m == 0 || *n == 0 || *k == 0) {
+ result[1] = 0.;
+ result[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+
+/* Copy the last k columns of the factorization to the array Q */
+
+ dlaset_("Full", m, n, &c_b4, &c_b4, &q[q_offset], lda);
+ if (*k < *m) {
+ i__1 = *m - *k;
+ dlacpy_("Full", &i__1, k, &af[(*n - *k + 1) * af_dim1 + 1], lda, &q[(*
+ n - *k + 1) * q_dim1 + 1], lda);
+ }
+ if (*k > 1) {
+ i__1 = *k - 1;
+ i__2 = *k - 1;
+ dlacpy_("Upper", &i__1, &i__2, &af[*m - *k + 1 + (*n - *k + 2) *
+ af_dim1], lda, &q[*m - *k + 1 + (*n - *k + 2) * q_dim1], lda);
+ }
+
+/* Generate the last n columns of the matrix Q */
+
+ s_copy(srnamc_1.srnamt, "DORGQL", (ftnlen)32, (ftnlen)6);
+ dorgql_(m, n, k, &q[q_offset], lda, &tau[*n - *k + 1], &work[1], lwork, &
+ info);
+
+/* Copy L(m-n+1:m,n-k+1:n) */
+
+ dlaset_("Full", n, k, &c_b10, &c_b10, &l[*m - *n + 1 + (*n - *k + 1) *
+ l_dim1], lda);
+ dlacpy_("Lower", k, k, &af[*m - *k + 1 + (*n - *k + 1) * af_dim1], lda, &
+ l[*m - *k + 1 + (*n - *k + 1) * l_dim1], lda);
+
+/* Compute L(m-n+1:m,n-k+1:n) - Q(1:m,m-n+1:m)' * A(1:m,n-k+1:n) */
+
+ dgemm_("Transpose", "No transpose", n, k, m, &c_b15, &q[q_offset], lda, &
+ a[(*n - *k + 1) * a_dim1 + 1], lda, &c_b16, &l[*m - *n + 1 + (*n
+ - *k + 1) * l_dim1], lda);
+
+/* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */
+
+ anorm = dlange_("1", m, k, &a[(*n - *k + 1) * a_dim1 + 1], lda, &rwork[1]);
+ resid = dlange_("1", n, k, &l[*m - *n + 1 + (*n - *k + 1) * l_dim1], lda,
+ &rwork[1]);
+ if (anorm > 0.) {
+ result[1] = resid / (doublereal) max(1,*m) / anorm / eps;
+ } else {
+ result[1] = 0.;
+ }
+
+/* Compute I - Q'*Q */
+
+ dlaset_("Full", n, n, &c_b10, &c_b16, &l[l_offset], lda);
+ dsyrk_("Upper", "Transpose", n, m, &c_b15, &q[q_offset], lda, &c_b16, &l[
+ l_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
+
+ resid = dlansy_("1", "Upper", n, &l[l_offset], lda, &rwork[1]);
+
+ result[2] = resid / (doublereal) max(1,*m) / eps;
+
+ return 0;
+
+/* End of DQLT02 */
+
+} /* dqlt02_ */
diff --git a/TESTING/LIN/dqlt03.c b/TESTING/LIN/dqlt03.c
new file mode 100644
index 0000000..1cd5cdd
--- /dev/null
+++ b/TESTING/LIN/dqlt03.c
@@ -0,0 +1,287 @@
+/* dqlt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublereal c_b4 = -1e10;
+static integer c__2 = 2;
+static doublereal c_b22 = -1.;
+static doublereal c_b23 = 1.;
+
+/* Subroutine */ int dqlt03_(integer *m, integer *n, integer *k, doublereal *
+ af, doublereal *c__, doublereal *cc, doublereal *q, integer *lda,
+ doublereal *tau, doublereal *work, integer *lwork, doublereal *rwork,
+ doublereal *result)
+{
+ /* Initialized data */
+
+ static integer iseed[4] = { 1988,1989,1990,1991 };
+
+ /* System generated locals */
+ integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1,
+ q_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j, mc, nc;
+ doublereal eps;
+ char side[1];
+ integer info;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ integer iside;
+ extern logical lsame_(char *, char *);
+ doublereal resid;
+ integer minmn;
+ doublereal cnorm;
+ char trans[1];
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), dlarnv_(integer *, integer *,
+ integer *, doublereal *), dorgql_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *), dormql_(char *, char *, integer *, integer *, integer
+ *, doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, integer *);
+ integer itrans;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DQLT03 tests DORMQL, which computes Q*C, Q'*C, C*Q or C*Q'. */
+
+/* DQLT03 compares the results of a call to DORMQL with the results of */
+/* forming Q explicitly by a call to DORGQL and then performing matrix */
+/* multiplication by a call to DGEMM. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The order of the orthogonal matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of rows or columns of the matrix C; C is m-by-n if */
+/* Q is applied from the left, or n-by-m if Q is applied from */
+/* the right. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* orthogonal matrix Q. M >= K >= 0. */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* Details of the QL factorization of an m-by-n matrix, as */
+/* returned by DGEQLF. See SGEQLF for further details. */
+
+/* C (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
+
+/* CC (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
+
+/* Q (workspace) DOUBLE PRECISION array, dimension (LDA,M) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays AF, C, CC, and Q. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the QL factorization in AF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK must be at least M, and should be */
+/* M*NB, where NB is the blocksize for this environment. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
+/* The test ratios compare two techniques for multiplying a */
+/* random matrix C by an m-by-m orthogonal matrix Q. */
+/* RESULT(1) = norm( Q*C - Q*C ) / ( M * norm(C) * EPS ) */
+/* RESULT(2) = norm( C*Q - C*Q ) / ( M * norm(C) * EPS ) */
+/* RESULT(3) = norm( Q'*C - Q'*C )/ ( M * norm(C) * EPS ) */
+/* RESULT(4) = norm( C*Q' - C*Q' )/ ( M * norm(C) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ cc_dim1 = *lda;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+ c_dim1 = *lda;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = dlamch_("Epsilon");
+ minmn = min(*m,*n);
+
+/* Quick return if possible */
+
+ if (minmn == 0) {
+ result[1] = 0.;
+ result[2] = 0.;
+ result[3] = 0.;
+ result[4] = 0.;
+ return 0;
+ }
+
+/* Copy the last k columns of the factorization to the array Q */
+
+ dlaset_("Full", m, m, &c_b4, &c_b4, &q[q_offset], lda);
+ if (*k > 0 && *m > *k) {
+ i__1 = *m - *k;
+ dlacpy_("Full", &i__1, k, &af[(*n - *k + 1) * af_dim1 + 1], lda, &q[(*
+ m - *k + 1) * q_dim1 + 1], lda);
+ }
+ if (*k > 1) {
+ i__1 = *k - 1;
+ i__2 = *k - 1;
+ dlacpy_("Upper", &i__1, &i__2, &af[*m - *k + 1 + (*n - *k + 2) *
+ af_dim1], lda, &q[*m - *k + 1 + (*m - *k + 2) * q_dim1], lda);
+ }
+
+/* Generate the m-by-m matrix Q */
+
+ s_copy(srnamc_1.srnamt, "DORGQL", (ftnlen)32, (ftnlen)6);
+ dorgql_(m, m, k, &q[q_offset], lda, &tau[minmn - *k + 1], &work[1], lwork,
+ &info);
+
+ for (iside = 1; iside <= 2; ++iside) {
+ if (iside == 1) {
+ *(unsigned char *)side = 'L';
+ mc = *m;
+ nc = *n;
+ } else {
+ *(unsigned char *)side = 'R';
+ mc = *n;
+ nc = *m;
+ }
+
+/* Generate MC by NC matrix C */
+
+ i__1 = nc;
+ for (j = 1; j <= i__1; ++j) {
+ dlarnv_(&c__2, iseed, &mc, &c__[j * c_dim1 + 1]);
+/* L10: */
+ }
+ cnorm = dlange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]);
+ if (cnorm == 0.) {
+ cnorm = 1.;
+ }
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+ if (itrans == 1) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'T';
+ }
+
+/* Copy C */
+
+ dlacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
+ lda);
+
+/* Apply Q or Q' to C */
+
+ s_copy(srnamc_1.srnamt, "DORMQL", (ftnlen)32, (ftnlen)6);
+ if (*k > 0) {
+ dormql_(side, trans, &mc, &nc, k, &af[(*n - *k + 1) * af_dim1
+ + 1], lda, &tau[minmn - *k + 1], &cc[cc_offset], lda,
+ &work[1], lwork, &info);
+ }
+
+/* Form explicit product and subtract */
+
+ if (lsame_(side, "L")) {
+ dgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b22, &q[
+ q_offset], lda, &c__[c_offset], lda, &c_b23, &cc[
+ cc_offset], lda);
+ } else {
+ dgemm_("No transpose", trans, &mc, &nc, &nc, &c_b22, &c__[
+ c_offset], lda, &q[q_offset], lda, &c_b23, &cc[
+ cc_offset], lda);
+ }
+
+/* Compute error in the difference */
+
+ resid = dlange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
+ result[(iside - 1 << 1) + itrans] = resid / ((doublereal) max(1,*
+ m) * cnorm * eps);
+
+/* L20: */
+ }
+/* L30: */
+ }
+
+ return 0;
+
+/* End of DQLT03 */
+
+} /* dqlt03_ */
diff --git a/TESTING/LIN/dqpt01.c b/TESTING/LIN/dqpt01.c
new file mode 100644
index 0000000..53f711a
--- /dev/null
+++ b/TESTING/LIN/dqpt01.c
@@ -0,0 +1,194 @@
+/* dqpt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__10 = 10;
+static integer c__1 = 1;
+static doublereal c_b14 = -1.;
+
+doublereal dqpt01_(integer *m, integer *n, integer *k, doublereal *a,
+ doublereal *af, integer *lda, doublereal *tau, integer *jpvt,
+ doublereal *work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2;
+ doublereal ret_val;
+
+ /* Local variables */
+ integer i__, j, info;
+ doublereal norma;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *);
+ doublereal rwork[1];
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), dormqr_(
+ char *, char *, integer *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DQPT01 tests the QR-factorization with pivoting of a matrix A. The */
+/* array AF contains the (possibly partial) QR-factorization of A, where */
+/* the upper triangle of AF(1:k,1:k) is a partial triangular factor, */
+/* the entries below the diagonal in the first k columns are the */
+/* Householder vectors, and the rest of AF contains a partially updated */
+/* matrix. */
+
+/* This function returns ||A*P - Q*R||/(||norm(A)||*eps*M) */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices A and AF. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and AF. */
+
+/* K (input) INTEGER */
+/* The number of columns of AF that have been reduced */
+/* to upper triangular form. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA, N) */
+/* The original matrix A. */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The (possibly partial) output of DGEQPF. The upper triangle */
+/* of AF(1:k,1:k) is a partial triangular factor, the entries */
+/* below the diagonal in the first k columns are the Householder */
+/* vectors, and the rest of AF contains a partially updated */
+/* matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A and AF. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (K) */
+/* Details of the Householder transformations as returned by */
+/* DGEQPF. */
+
+/* JPVT (input) INTEGER array, dimension (N) */
+/* Pivot information as returned by DGEQPF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= M*N+N. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --jpvt;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.;
+
+/* Test if there is enough workspace */
+
+ if (*lwork < *m * *n + *n) {
+ xerbla_("DQPT01", &c__10);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return ret_val;
+ }
+
+ norma = dlange_("One-norm", m, n, &a[a_offset], lda, rwork);
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(j,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[(j - 1) * *m + i__] = af[i__ + j * af_dim1];
+/* L10: */
+ }
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ work[(j - 1) * *m + i__] = 0.;
+/* L20: */
+ }
+/* L30: */
+ }
+ i__1 = *n;
+ for (j = *k + 1; j <= i__1; ++j) {
+ dcopy_(m, &af[j * af_dim1 + 1], &c__1, &work[(j - 1) * *m + 1], &c__1)
+ ;
+/* L40: */
+ }
+
+ i__1 = *lwork - *m * *n;
+ dormqr_("Left", "No transpose", m, n, k, &af[af_offset], lda, &tau[1], &
+ work[1], m, &work[*m * *n + 1], &i__1, &info);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compare i-th column of QR and jpvt(i)-th column of A */
+
+ daxpy_(m, &c_b14, &a[jpvt[j] * a_dim1 + 1], &c__1, &work[(j - 1) * *m
+ + 1], &c__1);
+/* L50: */
+ }
+
+ ret_val = dlange_("One-norm", m, n, &work[1], m, rwork) / ((
+ doublereal) max(*m,*n) * dlamch_("Epsilon"));
+ if (norma != 0.) {
+ ret_val /= norma;
+ }
+
+ return ret_val;
+
+/* End of DQPT01 */
+
+} /* dqpt01_ */
diff --git a/TESTING/LIN/dqrt01.c b/TESTING/LIN/dqrt01.c
new file mode 100644
index 0000000..b0f69bf
--- /dev/null
+++ b/TESTING/LIN/dqrt01.c
@@ -0,0 +1,223 @@
+/* dqrt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublereal c_b6 = -1e10;
+static doublereal c_b11 = 0.;
+static doublereal c_b16 = -1.;
+static doublereal c_b17 = 1.;
+
+/* Subroutine */ int dqrt01_(integer *m, integer *n, doublereal *a,
+ doublereal *af, doublereal *q, doublereal *r__, integer *lda,
+ doublereal *tau, doublereal *work, integer *lwork, doublereal *rwork,
+ doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
+ r_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal eps;
+ integer info;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ doublereal resid, anorm;
+ integer minmn;
+ extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dgeqrf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *),
+ dlacpy_(char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *), dlaset_(char *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DQRT01 tests DGEQRF, which computes the QR factorization of an m-by-n */
+/* matrix A, and partially tests DORGQR which forms the m-by-m */
+/* orthogonal matrix Q. */
+
+/* DQRT01 compares R with Q'*A, and checks that Q is orthogonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The m-by-n matrix A. */
+
+/* AF (output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* Details of the QR factorization of A, as returned by DGEQRF. */
+/* See DGEQRF for further details. */
+
+/* Q (output) DOUBLE PRECISION array, dimension (LDA,M) */
+/* The m-by-m orthogonal matrix Q. */
+
+/* R (workspace) DOUBLE PRECISION array, dimension (LDA,max(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and R. */
+/* LDA >= max(M,N). */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by DGEQRF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - Q'*A ) / ( M * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ minmn = min(*m,*n);
+ eps = dlamch_("Epsilon");
+
+/* Copy the matrix A to the array AF. */
+
+ dlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+
+/* Factorize the matrix A in the array AF. */
+
+ s_copy(srnamc_1.srnamt, "DGEQRF", (ftnlen)32, (ftnlen)6);
+ dgeqrf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy details of Q */
+
+ dlaset_("Full", m, m, &c_b6, &c_b6, &q[q_offset], lda);
+ i__1 = *m - 1;
+ dlacpy_("Lower", &i__1, n, &af[af_dim1 + 2], lda, &q[q_dim1 + 2], lda);
+
+/* Generate the m-by-m matrix Q */
+
+ s_copy(srnamc_1.srnamt, "DORGQR", (ftnlen)32, (ftnlen)6);
+ dorgqr_(m, m, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy R */
+
+ dlaset_("Full", m, n, &c_b11, &c_b11, &r__[r_offset], lda);
+ dlacpy_("Upper", m, n, &af[af_offset], lda, &r__[r_offset], lda);
+
+/* Compute R - Q'*A */
+
+ dgemm_("Transpose", "No transpose", m, n, m, &c_b16, &q[q_offset], lda, &
+ a[a_offset], lda, &c_b17, &r__[r_offset], lda);
+
+/* Compute norm( R - Q'*A ) / ( M * norm(A) * EPS ) . */
+
+ anorm = dlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ resid = dlange_("1", m, n, &r__[r_offset], lda, &rwork[1]);
+ if (anorm > 0.) {
+ result[1] = resid / (doublereal) max(1,*m) / anorm / eps;
+ } else {
+ result[1] = 0.;
+ }
+
+/* Compute I - Q'*Q */
+
+ dlaset_("Full", m, m, &c_b11, &c_b17, &r__[r_offset], lda);
+ dsyrk_("Upper", "Transpose", m, m, &c_b16, &q[q_offset], lda, &c_b17, &
+ r__[r_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
+
+ resid = dlansy_("1", "Upper", m, &r__[r_offset], lda, &rwork[1]);
+
+ result[2] = resid / (doublereal) max(1,*m) / eps;
+
+ return 0;
+
+/* End of DQRT01 */
+
+} /* dqrt01_ */
diff --git a/TESTING/LIN/dqrt02.c b/TESTING/LIN/dqrt02.c
new file mode 100644
index 0000000..2d994da
--- /dev/null
+++ b/TESTING/LIN/dqrt02.c
@@ -0,0 +1,217 @@
+/* dqrt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublereal c_b4 = -1e10;
+static doublereal c_b9 = 0.;
+static doublereal c_b14 = -1.;
+static doublereal c_b15 = 1.;
+
+/* Subroutine */ int dqrt02_(integer *m, integer *n, integer *k, doublereal *
+ a, doublereal *af, doublereal *q, doublereal *r__, integer *lda,
+ doublereal *tau, doublereal *work, integer *lwork, doublereal *rwork,
+ doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
+ r_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal eps;
+ integer info;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ doublereal resid, anorm;
+ extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DQRT02 tests DORGQR, which generates an m-by-n matrix Q with */
+/* orthonornmal columns that is defined as the product of k elementary */
+/* reflectors. */
+
+/* Given the QR factorization of an m-by-n matrix A, DQRT02 generates */
+/* the orthogonal matrix Q defined by the factorization of the first k */
+/* columns of A; it compares R(1:n,1:k) with Q(1:m,1:n)'*A(1:m,1:k), */
+/* and checks that the columns of Q are orthonormal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q to be generated. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q to be generated. */
+/* M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The m-by-n matrix A which was factorized by DQRT01. */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* Details of the QR factorization of A, as returned by DGEQRF. */
+/* See DGEQRF for further details. */
+
+/* Q (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
+
+/* R (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and R. LDA >= M. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (N) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the QR factorization in AF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - Q'*A ) / ( M * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ eps = dlamch_("Epsilon");
+
+/* Copy the first k columns of the factorization to the array Q */
+
+ dlaset_("Full", m, n, &c_b4, &c_b4, &q[q_offset], lda);
+ i__1 = *m - 1;
+ dlacpy_("Lower", &i__1, k, &af[af_dim1 + 2], lda, &q[q_dim1 + 2], lda);
+
+/* Generate the first n columns of the matrix Q */
+
+ s_copy(srnamc_1.srnamt, "DORGQR", (ftnlen)32, (ftnlen)6);
+ dorgqr_(m, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy R(1:n,1:k) */
+
+ dlaset_("Full", n, k, &c_b9, &c_b9, &r__[r_offset], lda);
+ dlacpy_("Upper", n, k, &af[af_offset], lda, &r__[r_offset], lda);
+
+/* Compute R(1:n,1:k) - Q(1:m,1:n)' * A(1:m,1:k) */
+
+ dgemm_("Transpose", "No transpose", n, k, m, &c_b14, &q[q_offset], lda, &
+ a[a_offset], lda, &c_b15, &r__[r_offset], lda);
+
+/* Compute norm( R - Q'*A ) / ( M * norm(A) * EPS ) . */
+
+ anorm = dlange_("1", m, k, &a[a_offset], lda, &rwork[1]);
+ resid = dlange_("1", n, k, &r__[r_offset], lda, &rwork[1]);
+ if (anorm > 0.) {
+ result[1] = resid / (doublereal) max(1,*m) / anorm / eps;
+ } else {
+ result[1] = 0.;
+ }
+
+/* Compute I - Q'*Q */
+
+ dlaset_("Full", n, n, &c_b9, &c_b15, &r__[r_offset], lda);
+ dsyrk_("Upper", "Transpose", n, m, &c_b14, &q[q_offset], lda, &c_b15, &
+ r__[r_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
+
+ resid = dlansy_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
+
+ result[2] = resid / (doublereal) max(1,*m) / eps;
+
+ return 0;
+
+/* End of DQRT02 */
+
+} /* dqrt02_ */
diff --git a/TESTING/LIN/dqrt03.c b/TESTING/LIN/dqrt03.c
new file mode 100644
index 0000000..7b8dedc
--- /dev/null
+++ b/TESTING/LIN/dqrt03.c
@@ -0,0 +1,262 @@
+/* dqrt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublereal c_b4 = -1e10;
+static integer c__2 = 2;
+static doublereal c_b21 = -1.;
+static doublereal c_b22 = 1.;
+
+/* Subroutine */ int dqrt03_(integer *m, integer *n, integer *k, doublereal *
+ af, doublereal *c__, doublereal *cc, doublereal *q, integer *lda,
+ doublereal *tau, doublereal *work, integer *lwork, doublereal *rwork,
+ doublereal *result)
+{
+ /* Initialized data */
+
+ static integer iseed[4] = { 1988,1989,1990,1991 };
+
+ /* System generated locals */
+ integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1,
+ q_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j, mc, nc;
+ doublereal eps;
+ char side[1];
+ integer info;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ integer iside;
+ extern logical lsame_(char *, char *);
+ doublereal resid, cnorm;
+ char trans[1];
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), dlarnv_(integer *, integer *,
+ integer *, doublereal *), dorgqr_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+ integer itrans;
+ extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DQRT03 tests DORMQR, which computes Q*C, Q'*C, C*Q or C*Q'. */
+
+/* DQRT03 compares the results of a call to DORMQR with the results of */
+/* forming Q explicitly by a call to DORGQR and then performing matrix */
+/* multiplication by a call to DGEMM. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The order of the orthogonal matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of rows or columns of the matrix C; C is m-by-n if */
+/* Q is applied from the left, or n-by-m if Q is applied from */
+/* the right. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* orthogonal matrix Q. M >= K >= 0. */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* Details of the QR factorization of an m-by-n matrix, as */
+/* returnedby DGEQRF. See SGEQRF for further details. */
+
+/* C (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
+
+/* CC (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
+
+/* Q (workspace) DOUBLE PRECISION array, dimension (LDA,M) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays AF, C, CC, and Q. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the QR factorization in AF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK must be at least M, and should be */
+/* M*NB, where NB is the blocksize for this environment. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
+/* The test ratios compare two techniques for multiplying a */
+/* random matrix C by an m-by-m orthogonal matrix Q. */
+/* RESULT(1) = norm( Q*C - Q*C ) / ( M * norm(C) * EPS ) */
+/* RESULT(2) = norm( C*Q - C*Q ) / ( M * norm(C) * EPS ) */
+/* RESULT(3) = norm( Q'*C - Q'*C )/ ( M * norm(C) * EPS ) */
+/* RESULT(4) = norm( C*Q' - C*Q' )/ ( M * norm(C) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ cc_dim1 = *lda;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+ c_dim1 = *lda;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = dlamch_("Epsilon");
+
+/* Copy the first k columns of the factorization to the array Q */
+
+ dlaset_("Full", m, m, &c_b4, &c_b4, &q[q_offset], lda);
+ i__1 = *m - 1;
+ dlacpy_("Lower", &i__1, k, &af[af_dim1 + 2], lda, &q[q_dim1 + 2], lda);
+
+/* Generate the m-by-m matrix Q */
+
+ s_copy(srnamc_1.srnamt, "DORGQR", (ftnlen)32, (ftnlen)6);
+ dorgqr_(m, m, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+ for (iside = 1; iside <= 2; ++iside) {
+ if (iside == 1) {
+ *(unsigned char *)side = 'L';
+ mc = *m;
+ nc = *n;
+ } else {
+ *(unsigned char *)side = 'R';
+ mc = *n;
+ nc = *m;
+ }
+
+/* Generate MC by NC matrix C */
+
+ i__1 = nc;
+ for (j = 1; j <= i__1; ++j) {
+ dlarnv_(&c__2, iseed, &mc, &c__[j * c_dim1 + 1]);
+/* L10: */
+ }
+ cnorm = dlange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]);
+ if (cnorm == 0.) {
+ cnorm = 1.;
+ }
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+ if (itrans == 1) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'T';
+ }
+
+/* Copy C */
+
+ dlacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
+ lda);
+
+/* Apply Q or Q' to C */
+
+ s_copy(srnamc_1.srnamt, "DORMQR", (ftnlen)32, (ftnlen)6);
+ dormqr_(side, trans, &mc, &nc, k, &af[af_offset], lda, &tau[1], &
+ cc[cc_offset], lda, &work[1], lwork, &info);
+
+/* Form explicit product and subtract */
+
+ if (lsame_(side, "L")) {
+ dgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b21, &q[
+ q_offset], lda, &c__[c_offset], lda, &c_b22, &cc[
+ cc_offset], lda);
+ } else {
+ dgemm_("No transpose", trans, &mc, &nc, &nc, &c_b21, &c__[
+ c_offset], lda, &q[q_offset], lda, &c_b22, &cc[
+ cc_offset], lda);
+ }
+
+/* Compute error in the difference */
+
+ resid = dlange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
+ result[(iside - 1 << 1) + itrans] = resid / ((doublereal) max(1,*
+ m) * cnorm * eps);
+
+/* L20: */
+ }
+/* L30: */
+ }
+
+ return 0;
+
+/* End of DQRT03 */
+
+} /* dqrt03_ */
diff --git a/TESTING/LIN/dqrt11.c b/TESTING/LIN/dqrt11.c
new file mode 100644
index 0000000..b312886
--- /dev/null
+++ b/TESTING/LIN/dqrt11.c
@@ -0,0 +1,156 @@
+/* dqrt11.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__7 = 7;
+static doublereal c_b5 = 0.;
+static doublereal c_b6 = 1.;
+
+doublereal dqrt11_(integer *m, integer *k, doublereal *a, integer *lda,
+ doublereal *tau, doublereal *work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ doublereal ret_val;
+
+ /* Local variables */
+ integer j, info;
+ extern /* Subroutine */ int dorm2r_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ doublereal rdummy[1];
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DQRT11 computes the test ratio */
+
+/* || Q'*Q - I || / (eps * m) */
+
+/* where the orthogonal matrix Q is represented as a product of */
+/* elementary transformations. Each transformation has the form */
+
+/* H(k) = I - tau(k) v(k) v(k)' */
+
+/* where tau(k) is stored in TAU(k) and v(k) is an m-vector of the form */
+/* [ 0 ... 0 1 x(k) ]', where x(k) is a vector of length m-k stored */
+/* in A(k+1:m,k). */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* K (input) INTEGER */
+/* The number of columns of A whose subdiagonal entries */
+/* contain information about orthogonal transformations. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,K) */
+/* The (possibly partial) output of a QR reduction routine. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (K) */
+/* The scaling factors tau for the elementary transformations as */
+/* computed by the QR factorization routine. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= M*M + M. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.;
+
+/* Test for sufficient workspace */
+
+ if (*lwork < *m * *m + *m) {
+ xerbla_("DQRT11", &c__7);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0) {
+ return ret_val;
+ }
+
+ dlaset_("Full", m, m, &c_b5, &c_b6, &work[1], m);
+
+/* Form Q */
+
+ dorm2r_("Left", "No transpose", m, m, k, &a[a_offset], lda, &tau[1], &
+ work[1], m, &work[*m * *m + 1], &info);
+
+/* Form Q'*Q */
+
+ dorm2r_("Left", "Transpose", m, m, k, &a[a_offset], lda, &tau[1], &work[1]
+, m, &work[*m * *m + 1], &info);
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ work[(j - 1) * *m + j] += -1.;
+/* L10: */
+ }
+
+ ret_val = dlange_("One-norm", m, m, &work[1], m, rdummy) / ((
+ doublereal) (*m) * dlamch_("Epsilon"));
+
+ return ret_val;
+
+/* End of DQRT11 */
+
+} /* dqrt11_ */
diff --git a/TESTING/LIN/dqrt12.c b/TESTING/LIN/dqrt12.c
new file mode 100644
index 0000000..4a7d3a0
--- /dev/null
+++ b/TESTING/LIN/dqrt12.c
@@ -0,0 +1,221 @@
+/* dqrt12.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__7 = 7;
+static integer c__1 = 1;
+static doublereal c_b6 = 0.;
+static integer c__0 = 0;
+static doublereal c_b33 = -1.;
+
+doublereal dqrt12_(integer *m, integer *n, doublereal *a, integer *lda,
+ doublereal *s, doublereal *work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal ret_val;
+
+ /* Local variables */
+ integer i__, j, mn, iscl, info;
+ doublereal anrm;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *), dasum_(
+ integer *, doublereal *, integer *);
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *), dgebd2_(integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *
+, doublereal *, doublereal *, integer *);
+ doublereal dummy[1];
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), dlaset_(char *, integer *, integer
+ *, doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *), dbdsqr_(char *, integer *,
+ integer *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *);
+ doublereal bignum, smlnum, nrmsvl;
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DQRT12 computes the singular values `svlues' of the upper trapezoid */
+/* of A(1:M,1:N) and returns the ratio */
+
+/* || s - svlues||/(||svlues||*eps*max(M,N)) */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The M-by-N matrix A. Only the upper trapezoid is referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* S (input) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The singular values of the matrix A. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(M*N + 4*min(M,N) + */
+/* max(M,N), M*N+2*MIN( M, N )+4*N). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.;
+
+/* Test that enough workspace is supplied */
+
+/* Computing MAX */
+ i__1 = *m * *n + (min(*m,*n) << 2) + max(*m,*n), i__2 = *m * *n + (min(*m,
+ *n) << 1) + (*n << 2);
+ if (*lwork < max(i__1,i__2)) {
+ xerbla_("DQRT12", &c__7);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ mn = min(*m,*n);
+ if ((doublereal) mn <= 0.) {
+ return ret_val;
+ }
+
+ nrmsvl = dnrm2_(&mn, &s[1], &c__1);
+
+/* Copy upper triangle of A into work */
+
+ dlaset_("Full", m, n, &c_b6, &c_b6, &work[1], m);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(j,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[(j - 1) * *m + i__] = a[i__ + j * a_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Get machine parameters */
+
+ smlnum = dlamch_("S") / dlamch_("P");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Scale work if max entry outside range [SMLNUM,BIGNUM] */
+
+ anrm = dlange_("M", m, n, &work[1], m, dummy);
+ iscl = 0;
+ if (anrm > 0. && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &work[1], m, &info);
+ iscl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &work[1], m, &info);
+ iscl = 1;
+ }
+
+ if (anrm != 0.) {
+
+/* Compute SVD of work */
+
+ dgebd2_(m, n, &work[1], m, &work[*m * *n + 1], &work[*m * *n + mn + 1]
+, &work[*m * *n + (mn << 1) + 1], &work[*m * *n + mn * 3 + 1],
+ &work[*m * *n + (mn << 2) + 1], &info);
+ dbdsqr_("Upper", &mn, &c__0, &c__0, &c__0, &work[*m * *n + 1], &work[*
+ m * *n + mn + 1], dummy, &mn, dummy, &c__1, dummy, &mn, &work[
+ *m * *n + (mn << 1) + 1], &info);
+
+ if (iscl == 1) {
+ if (anrm > bignum) {
+ dlascl_("G", &c__0, &c__0, &bignum, &anrm, &mn, &c__1, &work[*
+ m * *n + 1], &mn, &info);
+ }
+ if (anrm < smlnum) {
+ dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &mn, &c__1, &work[*
+ m * *n + 1], &mn, &info);
+ }
+ }
+
+ } else {
+
+ i__1 = mn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[*m * *n + i__] = 0.;
+/* L30: */
+ }
+ }
+
+/* Compare s and singular values of work */
+
+ daxpy_(&mn, &c_b33, &s[1], &c__1, &work[*m * *n + 1], &c__1);
+ ret_val = dasum_(&mn, &work[*m * *n + 1], &c__1) / (dlamch_("Epsilon") * (doublereal) max(*m,*n));
+ if (nrmsvl != 0.) {
+ ret_val /= nrmsvl;
+ }
+
+ return ret_val;
+
+/* End of DQRT12 */
+
+} /* dqrt12_ */
diff --git a/TESTING/LIN/dqrt13.c b/TESTING/LIN/dqrt13.c
new file mode 100644
index 0000000..28a22ba
--- /dev/null
+++ b/TESTING/LIN/dqrt13.c
@@ -0,0 +1,158 @@
+/* dqrt13.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c__0 = 0;
+
+/* Subroutine */ int dqrt13_(integer *scale, integer *m, integer *n,
+ doublereal *a, integer *lda, doublereal *norma, integer *iseed)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer j, info;
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal dummy[1];
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *,
+ doublereal *);
+ doublereal smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DQRT13 generates a full-rank matrix that may be scaled to have large */
+/* or small norm. */
+
+/* Arguments */
+/* ========= */
+
+/* SCALE (input) INTEGER */
+/* SCALE = 1: normally scaled matrix */
+/* SCALE = 2: matrix scaled up */
+/* SCALE = 3: matrix scaled down */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of A. */
+
+/* A (output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The M-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* NORMA (output) DOUBLE PRECISION */
+/* The one-norm of A. */
+
+/* ISEED (input/output) integer array, dimension (4) */
+/* Seed for random number generator */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iseed;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+/* benign matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dlarnv_(&c__2, &iseed[1], m, &a[j * a_dim1 + 1]);
+ if (j <= *m) {
+ d__1 = dasum_(m, &a[j * a_dim1 + 1], &c__1);
+ a[j + j * a_dim1] += d_sign(&d__1, &a[j + j * a_dim1]);
+ }
+/* L10: */
+ }
+
+/* scaled versions */
+
+ if (*scale != 1) {
+ *norma = dlange_("Max", m, n, &a[a_offset], lda, dummy);
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ smlnum /= dlamch_("Epsilon");
+ bignum = 1. / smlnum;
+
+ if (*scale == 2) {
+
+/* matrix scaled up */
+
+ dlascl_("General", &c__0, &c__0, norma, &bignum, m, n, &a[
+ a_offset], lda, &info);
+ } else if (*scale == 3) {
+
+/* matrix scaled down */
+
+ dlascl_("General", &c__0, &c__0, norma, &smlnum, m, n, &a[
+ a_offset], lda, &info);
+ }
+ }
+
+ *norma = dlange_("One-norm", m, n, &a[a_offset], lda, dummy);
+ return 0;
+
+/* End of DQRT13 */
+
+} /* dqrt13_ */
diff --git a/TESTING/LIN/dqrt14.c b/TESTING/LIN/dqrt14.c
new file mode 100644
index 0000000..f7ff004
--- /dev/null
+++ b/TESTING/LIN/dqrt14.c
@@ -0,0 +1,263 @@
+/* dqrt14.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__10 = 10;
+static integer c__1 = 1;
+static integer c__0 = 0;
+static doublereal c_b15 = 1.;
+
+doublereal dqrt14_(char *trans, integer *m, integer *n, integer *nrhs,
+ doublereal *a, integer *lda, doublereal *x, integer *ldx, doublereal *
+ work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, x_dim1, x_offset, i__1, i__2, i__3;
+ doublereal ret_val, d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal err;
+ integer info;
+ doublereal anrm;
+ logical tpsd;
+ doublereal xnrm;
+ extern logical lsame_(char *, char *);
+ doublereal rwork[1];
+ extern /* Subroutine */ int dgelq2_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *), dgeqr2_(
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), dlacpy_(char *, integer *, integer
+ *, doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ integer ldwork;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DQRT14 checks whether X is in the row space of A or A'. It does so */
+/* by scaling both X and A such that their norms are in the range */
+/* [sqrt(eps), 1/sqrt(eps)], then computing a QR factorization of [A,X] */
+/* (if TRANS = 'T') or an LQ factorization of [A',X]' (if TRANS = 'N'), */
+/* and returning the norm of the trailing triangle, scaled by */
+/* MAX(M,N,NRHS)*eps. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, check for X in the row space of A */
+/* = 'T': Transpose, check for X in the row space of A'. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of X. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The M-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* If TRANS = 'N', the N-by-NRHS matrix X. */
+/* IF TRANS = 'T', the M-by-NRHS matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. */
+
+/* WORK (workspace) DOUBLE PRECISION array dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* length of workspace array required */
+/* If TRANS = 'N', LWORK >= (M+NRHS)*(N+2); */
+/* if TRANS = 'T', LWORK >= (N+NRHS)*(M+2). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.;
+ if (lsame_(trans, "N")) {
+ ldwork = *m + *nrhs;
+ tpsd = FALSE_;
+ if (*lwork < (*m + *nrhs) * (*n + 2)) {
+ xerbla_("DQRT14", &c__10);
+ return ret_val;
+ } else if (*n <= 0 || *nrhs <= 0) {
+ return ret_val;
+ }
+ } else if (lsame_(trans, "T")) {
+ ldwork = *m;
+ tpsd = TRUE_;
+ if (*lwork < (*n + *nrhs) * (*m + 2)) {
+ xerbla_("DQRT14", &c__10);
+ return ret_val;
+ } else if (*m <= 0 || *nrhs <= 0) {
+ return ret_val;
+ }
+ } else {
+ xerbla_("DQRT14", &c__1);
+ return ret_val;
+ }
+
+/* Copy and scale A */
+
+ dlacpy_("All", m, n, &a[a_offset], lda, &work[1], &ldwork);
+ anrm = dlange_("M", m, n, &work[1], &ldwork, rwork);
+ if (anrm != 0.) {
+ dlascl_("G", &c__0, &c__0, &anrm, &c_b15, m, n, &work[1], &ldwork, &
+ info);
+ }
+
+/* Copy X or X' into the right place and scale it */
+
+ if (tpsd) {
+
+/* Copy X into columns n+1:n+nrhs of work */
+
+ dlacpy_("All", m, nrhs, &x[x_offset], ldx, &work[*n * ldwork + 1], &
+ ldwork);
+ xnrm = dlange_("M", m, nrhs, &work[*n * ldwork + 1], &ldwork, rwork);
+ if (xnrm != 0.) {
+ dlascl_("G", &c__0, &c__0, &xnrm, &c_b15, m, nrhs, &work[*n *
+ ldwork + 1], &ldwork, &info);
+ }
+ i__1 = *n + *nrhs;
+ anrm = dlange_("One-norm", m, &i__1, &work[1], &ldwork, rwork);
+
+/* Compute QR factorization of X */
+
+ i__1 = *n + *nrhs;
+/* Computing MIN */
+ i__2 = *m, i__3 = *n + *nrhs;
+ dgeqr2_(m, &i__1, &work[1], &ldwork, &work[ldwork * (*n + *nrhs) + 1],
+ &work[ldwork * (*n + *nrhs) + min(i__2, i__3)+ 1], &info);
+
+/* Compute largest entry in upper triangle of */
+/* work(n+1:m,n+1:n+nrhs) */
+
+ err = 0.;
+ i__1 = *n + *nrhs;
+ for (j = *n + 1; j <= i__1; ++j) {
+ i__2 = min(*m,j);
+ for (i__ = *n + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = err, d__3 = (d__1 = work[i__ + (j - 1) * *m], abs(d__1)
+ );
+ err = max(d__2,d__3);
+/* L10: */
+ }
+/* L20: */
+ }
+
+ } else {
+
+/* Copy X' into rows m+1:m+nrhs of work */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *nrhs;
+ for (j = 1; j <= i__2; ++j) {
+ work[*m + j + (i__ - 1) * ldwork] = x[i__ + j * x_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+
+ xnrm = dlange_("M", nrhs, n, &work[*m + 1], &ldwork, rwork)
+ ;
+ if (xnrm != 0.) {
+ dlascl_("G", &c__0, &c__0, &xnrm, &c_b15, nrhs, n, &work[*m + 1],
+ &ldwork, &info);
+ }
+
+/* Compute LQ factorization of work */
+
+ dgelq2_(&ldwork, n, &work[1], &ldwork, &work[ldwork * *n + 1], &work[
+ ldwork * (*n + 1) + 1], &info);
+
+/* Compute largest entry in lower triangle in */
+/* work(m+1:m+nrhs,m+1:n) */
+
+ err = 0.;
+ i__1 = *n;
+ for (j = *m + 1; j <= i__1; ++j) {
+ i__2 = ldwork;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = err, d__3 = (d__1 = work[i__ + (j - 1) * ldwork], abs(
+ d__1));
+ err = max(d__2,d__3);
+/* L50: */
+ }
+/* L60: */
+ }
+
+ }
+
+/* Computing MAX */
+ i__1 = max(*m,*n);
+ ret_val = err / ((doublereal) max(i__1,*nrhs) * dlamch_("Epsilon"));
+
+ return ret_val;
+
+/* End of DQRT14 */
+
+} /* dqrt14_ */
diff --git a/TESTING/LIN/dqrt15.c b/TESTING/LIN/dqrt15.c
new file mode 100644
index 0000000..5e7a432
--- /dev/null
+++ b/TESTING/LIN/dqrt15.c
@@ -0,0 +1,303 @@
+/* dqrt15.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__16 = 16;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static doublereal c_b18 = 0.;
+static doublereal c_b19 = 1.;
+static doublereal c_b22 = 2.;
+static integer c__0 = 0;
+
+/* Subroutine */ int dqrt15_(integer *scale, integer *rksel, integer *m,
+ integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b,
+ integer *ldb, doublereal *s, integer *rank, doublereal *norma,
+ doublereal *normb, integer *iseed, doublereal *work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Local variables */
+ integer j, mn;
+ doublereal eps;
+ integer info;
+ doublereal temp;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *), dlarf_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *), dgemm_(char *, char *, integer *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal dummy[1];
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ extern doublereal dlarnd_(integer *, integer *);
+ extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *,
+ integer *), dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ doublereal bignum;
+ extern /* Subroutine */ int dlaror_(char *, char *, integer *, integer *,
+ doublereal *, integer *, integer *, doublereal *, integer *), dlarnv_(integer *, integer *, integer *,
+ doublereal *);
+ doublereal smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DQRT15 generates a matrix with full or deficient rank and of various */
+/* norms. */
+
+/* Arguments */
+/* ========= */
+
+/* SCALE (input) INTEGER */
+/* SCALE = 1: normally scaled matrix */
+/* SCALE = 2: matrix scaled up */
+/* SCALE = 3: matrix scaled down */
+
+/* RKSEL (input) INTEGER */
+/* RKSEL = 1: full rank matrix */
+/* RKSEL = 2: rank-deficient matrix */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of A. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. */
+
+/* A (output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The M-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* B (output) DOUBLE PRECISION array, dimension (LDB, NRHS) */
+/* A matrix that is in the range space of matrix A. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. */
+
+/* S (output) DOUBLE PRECISION array, dimension MIN(M,N) */
+/* Singular values of A. */
+
+/* RANK (output) INTEGER */
+/* number of nonzero singular values of A. */
+
+/* NORMA (output) DOUBLE PRECISION */
+/* one-norm of A. */
+
+/* NORMB (output) DOUBLE PRECISION */
+/* one-norm of B. */
+
+/* ISEED (input/output) integer array, dimension (4) */
+/* seed for random number generator. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* length of work space required. */
+/* LWORK >= MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --s;
+ --iseed;
+ --work;
+
+ /* Function Body */
+ mn = min(*m,*n);
+/* Computing MAX */
+ i__1 = *m + mn, i__2 = mn * *nrhs, i__1 = max(i__1,i__2), i__2 = (*n << 1)
+ + *m;
+ if (*lwork < max(i__1,i__2)) {
+ xerbla_("DQRT15", &c__16);
+ return 0;
+ }
+
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ eps = dlamch_("Epsilon");
+ smlnum = smlnum / eps / eps;
+ bignum = 1. / smlnum;
+
+/* Determine rank and (unscaled) singular values */
+
+ if (*rksel == 1) {
+ *rank = mn;
+ } else if (*rksel == 2) {
+ *rank = mn * 3 / 4;
+ i__1 = mn;
+ for (j = *rank + 1; j <= i__1; ++j) {
+ s[j] = 0.;
+/* L10: */
+ }
+ } else {
+ xerbla_("DQRT15", &c__2);
+ }
+
+ if (*rank > 0) {
+
+/* Nontrivial case */
+
+ s[1] = 1.;
+ i__1 = *rank;
+ for (j = 2; j <= i__1; ++j) {
+L20:
+ temp = dlarnd_(&c__1, &iseed[1]);
+ if (temp > .1) {
+ s[j] = abs(temp);
+ } else {
+ goto L20;
+ }
+/* L30: */
+ }
+ dlaord_("Decreasing", rank, &s[1], &c__1);
+
+/* Generate 'rank' columns of a random orthogonal matrix in A */
+
+ dlarnv_(&c__2, &iseed[1], m, &work[1]);
+ d__1 = 1. / dnrm2_(m, &work[1], &c__1);
+ dscal_(m, &d__1, &work[1], &c__1);
+ dlaset_("Full", m, rank, &c_b18, &c_b19, &a[a_offset], lda)
+ ;
+ dlarf_("Left", m, rank, &work[1], &c__1, &c_b22, &a[a_offset], lda, &
+ work[*m + 1]);
+
+/* workspace used: m+mn */
+
+/* Generate consistent rhs in the range space of A */
+
+ i__1 = *rank * *nrhs;
+ dlarnv_(&c__2, &iseed[1], &i__1, &work[1]);
+ dgemm_("No transpose", "No transpose", m, nrhs, rank, &c_b19, &a[
+ a_offset], lda, &work[1], rank, &c_b18, &b[b_offset], ldb);
+
+/* work space used: <= mn *nrhs */
+
+/* generate (unscaled) matrix A */
+
+ i__1 = *rank;
+ for (j = 1; j <= i__1; ++j) {
+ dscal_(m, &s[j], &a[j * a_dim1 + 1], &c__1);
+/* L40: */
+ }
+ if (*rank < *n) {
+ i__1 = *n - *rank;
+ dlaset_("Full", m, &i__1, &c_b18, &c_b18, &a[(*rank + 1) * a_dim1
+ + 1], lda);
+ }
+ dlaror_("Right", "No initialization", m, n, &a[a_offset], lda, &iseed[
+ 1], &work[1], &info);
+
+ } else {
+
+/* work space used 2*n+m */
+
+/* Generate null matrix and rhs */
+
+ i__1 = mn;
+ for (j = 1; j <= i__1; ++j) {
+ s[j] = 0.;
+/* L50: */
+ }
+ dlaset_("Full", m, n, &c_b18, &c_b18, &a[a_offset], lda);
+ dlaset_("Full", m, nrhs, &c_b18, &c_b18, &b[b_offset], ldb)
+ ;
+
+ }
+
+/* Scale the matrix */
+
+ if (*scale != 1) {
+ *norma = dlange_("Max", m, n, &a[a_offset], lda, dummy);
+ if (*norma != 0.) {
+ if (*scale == 2) {
+
+/* matrix scaled up */
+
+ dlascl_("General", &c__0, &c__0, norma, &bignum, m, n, &a[
+ a_offset], lda, &info);
+ dlascl_("General", &c__0, &c__0, norma, &bignum, &mn, &c__1, &
+ s[1], &mn, &info);
+ dlascl_("General", &c__0, &c__0, norma, &bignum, m, nrhs, &b[
+ b_offset], ldb, &info);
+ } else if (*scale == 3) {
+
+/* matrix scaled down */
+
+ dlascl_("General", &c__0, &c__0, norma, &smlnum, m, n, &a[
+ a_offset], lda, &info);
+ dlascl_("General", &c__0, &c__0, norma, &smlnum, &mn, &c__1, &
+ s[1], &mn, &info);
+ dlascl_("General", &c__0, &c__0, norma, &smlnum, m, nrhs, &b[
+ b_offset], ldb, &info);
+ } else {
+ xerbla_("DQRT15", &c__1);
+ return 0;
+ }
+ }
+ }
+
+ *norma = dasum_(&mn, &s[1], &c__1);
+ *normb = dlange_("One-norm", m, nrhs, &b[b_offset], ldb, dummy)
+ ;
+
+ return 0;
+
+/* End of DQRT15 */
+
+} /* dqrt15_ */
diff --git a/TESTING/LIN/dqrt16.c b/TESTING/LIN/dqrt16.c
new file mode 100644
index 0000000..316a9a5
--- /dev/null
+++ b/TESTING/LIN/dqrt16.c
@@ -0,0 +1,184 @@
+/* dqrt16.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b8 = -1.;
+static doublereal c_b9 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dqrt16_(char *trans, integer *m, integer *n, integer *
+ nrhs, doublereal *a, integer *lda, doublereal *x, integer *ldx,
+ doublereal *b, integer *ldb, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j, n1, n2;
+ doublereal eps;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal anorm, bnorm, xnorm;
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DQRT16 computes the residual for a solution of a system of linear */
+/* equations A*x = b or A'*x = b: */
+/* RESID = norm(B - A*X) / ( max(m,n) * norm(A) * norm(X) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A *x = b */
+/* = 'T': A'*x = b, where A' is the transpose of A */
+/* = 'C': A'*x = b, where A' is the transpose of A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The original M x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M). */
+
+/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. IF TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( max(m,n) * norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if M = 0 or N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0 || *nrhs == 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+ if (lsame_(trans, "T") || lsame_(trans, "C")) {
+ anorm = dlange_("I", m, n, &a[a_offset], lda, &rwork[1]);
+ n1 = *n;
+ n2 = *m;
+ } else {
+ anorm = dlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ n1 = *m;
+ n2 = *n;
+ }
+
+ eps = dlamch_("Epsilon");
+
+/* Compute B - A*X (or B - A'*X ) and store in B. */
+
+ dgemm_(trans, "No transpose", &n1, nrhs, &n2, &c_b8, &a[a_offset], lda, &
+ x[x_offset], ldx, &c_b9, &b[b_offset], ldb)
+ ;
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( max(m,n) * norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = dasum_(&n1, &b[j * b_dim1 + 1], &c__1);
+ xnorm = dasum_(&n2, &x[j * x_dim1 + 1], &c__1);
+ if (anorm == 0. && bnorm == 0.) {
+ *resid = 0.;
+ } else if (anorm <= 0. || xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / (max(*m,*n) * eps);
+ *resid = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of DQRT16 */
+
+} /* dqrt16_ */
diff --git a/TESTING/LIN/dqrt17.c b/TESTING/LIN/dqrt17.c
new file mode 100644
index 0000000..7313ae1
--- /dev/null
+++ b/TESTING/LIN/dqrt17.c
@@ -0,0 +1,240 @@
+/* dqrt17.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__13 = 13;
+static doublereal c_b13 = -1.;
+static doublereal c_b14 = 1.;
+static integer c__0 = 0;
+static doublereal c_b22 = 0.;
+
+doublereal dqrt17_(char *trans, integer *iresid, integer *m, integer *n,
+ integer *nrhs, doublereal *a, integer *lda, doublereal *x, integer *
+ ldx, doublereal *b, integer *ldb, doublereal *c__, doublereal *work,
+ integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, x_dim1,
+ x_offset, i__1;
+ doublereal ret_val;
+
+ /* Local variables */
+ doublereal err;
+ integer iscl, info;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ extern logical lsame_(char *, char *);
+ doublereal norma, normb;
+ integer ncols;
+ doublereal normx, rwork[1];
+ integer nrows;
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), dlacpy_(char *, integer *, integer
+ *, doublereal *, integer *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ doublereal bignum, smlnum, normrs;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DQRT17 computes the ratio */
+
+/* || R'*op(A) ||/(||A||*alpha*max(M,N,NRHS)*eps) */
+
+/* where R = op(A)*X - B, op(A) is A or A', and */
+
+/* alpha = ||B|| if IRESID = 1 (zero-residual problem) */
+/* alpha = ||R|| if IRESID = 2 (otherwise). */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies whether or not the transpose of A is used. */
+/* = 'N': No transpose, op(A) = A. */
+/* = 'T': Transpose, op(A) = A'. */
+
+/* IRESID (input) INTEGER */
+/* IRESID = 1 indicates zero-residual problem. */
+/* IRESID = 2 indicates non-zero residual. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+/* If TRANS = 'N', the number of rows of the matrix B. */
+/* If TRANS = 'T', the number of rows of the matrix X. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+/* If TRANS = 'N', the number of rows of the matrix X. */
+/* If TRANS = 'T', the number of rows of the matrix B. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X and B. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The m-by-n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* If TRANS = 'N', the n-by-nrhs matrix X. */
+/* If TRANS = 'T', the m-by-nrhs matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. */
+/* If TRANS = 'N', LDX >= N. */
+/* If TRANS = 'T', LDX >= M. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* If TRANS = 'N', the m-by-nrhs matrix B. */
+/* If TRANS = 'T', the n-by-nrhs matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. */
+/* If TRANS = 'N', LDB >= M. */
+/* If TRANS = 'T', LDB >= N. */
+
+/* C (workspace) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= NRHS*(M+N). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ c_dim1 = *ldb;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ if (lsame_(trans, "N")) {
+ nrows = *m;
+ ncols = *n;
+ } else if (lsame_(trans, "T")) {
+ nrows = *n;
+ ncols = *m;
+ } else {
+ xerbla_("DQRT17", &c__1);
+ return ret_val;
+ }
+
+ if (*lwork < ncols * *nrhs) {
+ xerbla_("DQRT17", &c__13);
+ return ret_val;
+ }
+
+ if (*m <= 0 || *n <= 0 || *nrhs <= 0) {
+ return ret_val;
+ }
+
+ norma = dlange_("One-norm", m, n, &a[a_offset], lda, rwork);
+ smlnum = dlamch_("Safe minimum") / dlamch_("Precision");
+ bignum = 1. / smlnum;
+ iscl = 0;
+
+/* compute residual and scale it */
+
+ dlacpy_("All", &nrows, nrhs, &b[b_offset], ldb, &c__[c_offset], ldb);
+ dgemm_(trans, "No transpose", &nrows, nrhs, &ncols, &c_b13, &a[a_offset],
+ lda, &x[x_offset], ldx, &c_b14, &c__[c_offset], ldb);
+ normrs = dlange_("Max", &nrows, nrhs, &c__[c_offset], ldb, rwork);
+ if (normrs > smlnum) {
+ iscl = 1;
+ dlascl_("General", &c__0, &c__0, &normrs, &c_b14, &nrows, nrhs, &c__[
+ c_offset], ldb, &info);
+ }
+
+/* compute R'*A */
+
+ dgemm_("Transpose", trans, nrhs, &ncols, &nrows, &c_b14, &c__[c_offset],
+ ldb, &a[a_offset], lda, &c_b22, &work[1], nrhs);
+
+/* compute and properly scale error */
+
+ err = dlange_("One-norm", nrhs, &ncols, &work[1], nrhs, rwork);
+ if (norma != 0.) {
+ err /= norma;
+ }
+
+ if (iscl == 1) {
+ err *= normrs;
+ }
+
+ if (*iresid == 1) {
+ normb = dlange_("One-norm", &nrows, nrhs, &b[b_offset], ldb, rwork);
+ if (normb != 0.) {
+ err /= normb;
+ }
+ } else {
+ normx = dlange_("One-norm", &ncols, nrhs, &x[x_offset], ldx, rwork);
+ if (normx != 0.) {
+ err /= normx;
+ }
+ }
+
+/* Computing MAX */
+ i__1 = max(*m,*n);
+ ret_val = err / (dlamch_("Epsilon") * (doublereal) max(i__1,*
+ nrhs));
+ return ret_val;
+
+/* End of DQRT17 */
+
+} /* dqrt17_ */
diff --git a/TESTING/LIN/drqt01.c b/TESTING/LIN/drqt01.c
new file mode 100644
index 0000000..8eac375
--- /dev/null
+++ b/TESTING/LIN/drqt01.c
@@ -0,0 +1,256 @@
+/* drqt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublereal c_b6 = -1e10;
+static doublereal c_b13 = 0.;
+static doublereal c_b20 = -1.;
+static doublereal c_b21 = 1.;
+
+/* Subroutine */ int drqt01_(integer *m, integer *n, doublereal *a,
+ doublereal *af, doublereal *q, doublereal *r__, integer *lda,
+ doublereal *tau, doublereal *work, integer *lwork, doublereal *rwork,
+ doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
+ r_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal eps;
+ integer info;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ doublereal resid, anorm;
+ integer minmn;
+ extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dgerqf_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *),
+ dlacpy_(char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, integer *), dlaset_(char *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dorgrq_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DRQT01 tests DGERQF, which computes the RQ factorization of an m-by-n */
+/* matrix A, and partially tests DORGRQ which forms the n-by-n */
+/* orthogonal matrix Q. */
+
+/* DRQT01 compares R with A*Q', and checks that Q is orthogonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The m-by-n matrix A. */
+
+/* AF (output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* Details of the RQ factorization of A, as returned by DGERQF. */
+/* See DGERQF for further details. */
+
+/* Q (output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The n-by-n orthogonal matrix Q. */
+
+/* R (workspace) DOUBLE PRECISION array, dimension (LDA,max(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and L. */
+/* LDA >= max(M,N). */
+
+/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by DGERQF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(M,N)) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ minmn = min(*m,*n);
+ eps = dlamch_("Epsilon");
+
+/* Copy the matrix A to the array AF. */
+
+ dlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+
+/* Factorize the matrix A in the array AF. */
+
+ s_copy(srnamc_1.srnamt, "DGERQF", (ftnlen)32, (ftnlen)6);
+ dgerqf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy details of Q */
+
+ dlaset_("Full", n, n, &c_b6, &c_b6, &q[q_offset], lda);
+ if (*m <= *n) {
+ if (*m > 0 && *m < *n) {
+ i__1 = *n - *m;
+ dlacpy_("Full", m, &i__1, &af[af_offset], lda, &q[*n - *m + 1 +
+ q_dim1], lda);
+ }
+ if (*m > 1) {
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ dlacpy_("Lower", &i__1, &i__2, &af[(*n - *m + 1) * af_dim1 + 2],
+ lda, &q[*n - *m + 2 + (*n - *m + 1) * q_dim1], lda);
+ }
+ } else {
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ dlacpy_("Lower", &i__1, &i__2, &af[*m - *n + 2 + af_dim1], lda, &
+ q[q_dim1 + 2], lda);
+ }
+ }
+
+/* Generate the n-by-n matrix Q */
+
+ s_copy(srnamc_1.srnamt, "DORGRQ", (ftnlen)32, (ftnlen)6);
+ dorgrq_(n, n, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy R */
+
+ dlaset_("Full", m, n, &c_b13, &c_b13, &r__[r_offset], lda);
+ if (*m <= *n) {
+ if (*m > 0) {
+ dlacpy_("Upper", m, m, &af[(*n - *m + 1) * af_dim1 + 1], lda, &
+ r__[(*n - *m + 1) * r_dim1 + 1], lda);
+ }
+ } else {
+ if (*m > *n && *n > 0) {
+ i__1 = *m - *n;
+ dlacpy_("Full", &i__1, n, &af[af_offset], lda, &r__[r_offset],
+ lda);
+ }
+ if (*n > 0) {
+ dlacpy_("Upper", n, n, &af[*m - *n + 1 + af_dim1], lda, &r__[*m -
+ *n + 1 + r_dim1], lda);
+ }
+ }
+
+/* Compute R - A*Q' */
+
+ dgemm_("No transpose", "Transpose", m, n, n, &c_b20, &a[a_offset], lda, &
+ q[q_offset], lda, &c_b21, &r__[r_offset], lda);
+
+/* Compute norm( R - Q'*A ) / ( N * norm(A) * EPS ) . */
+
+ anorm = dlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ resid = dlange_("1", m, n, &r__[r_offset], lda, &rwork[1]);
+ if (anorm > 0.) {
+ result[1] = resid / (doublereal) max(1,*n) / anorm / eps;
+ } else {
+ result[1] = 0.;
+ }
+
+/* Compute I - Q*Q' */
+
+ dlaset_("Full", n, n, &c_b13, &c_b21, &r__[r_offset], lda);
+ dsyrk_("Upper", "No transpose", n, n, &c_b20, &q[q_offset], lda, &c_b21, &
+ r__[r_offset], lda);
+
+/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
+
+ resid = dlansy_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
+
+ result[2] = resid / (doublereal) max(1,*n) / eps;
+
+ return 0;
+
+/* End of DRQT01 */
+
+} /* drqt01_ */
diff --git a/TESTING/LIN/drqt02.c b/TESTING/LIN/drqt02.c
new file mode 100644
index 0000000..908f7c7
--- /dev/null
+++ b/TESTING/LIN/drqt02.c
@@ -0,0 +1,240 @@
+/* drqt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublereal c_b4 = -1e10;
+static doublereal c_b10 = 0.;
+static doublereal c_b15 = -1.;
+static doublereal c_b16 = 1.;
+
+/* Subroutine */ int drqt02_(integer *m, integer *n, integer *k, doublereal *
+ a, doublereal *af, doublereal *q, doublereal *r__, integer *lda,
+ doublereal *tau, doublereal *work, integer *lwork, doublereal *rwork,
+ doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
+ r_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal eps;
+ integer info;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ doublereal resid, anorm;
+ extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *);
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dorgrq_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DRQT02 tests DORGRQ, which generates an m-by-n matrix Q with */
+/* orthonornmal rows that is defined as the product of k elementary */
+/* reflectors. */
+
+/* Given the RQ factorization of an m-by-n matrix A, DRQT02 generates */
+/* the orthogonal matrix Q defined by the factorization of the last k */
+/* rows of A; it compares R(m-k+1:m,n-m+1:n) with */
+/* A(m-k+1:m,1:n)*Q(n-m+1:n,1:n)', and checks that the rows of Q are */
+/* orthonormal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q to be generated. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q to be generated. */
+/* N >= M >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The m-by-n matrix A which was factorized by DRQT01. */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* Details of the RQ factorization of A, as returned by DGERQF. */
+/* See DGERQF for further details. */
+
+/* Q (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
+
+/* R (workspace) DOUBLE PRECISION array, dimension (LDA,M) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and L. LDA >= N. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (M) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the RQ factorization in AF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ if (*m == 0 || *n == 0 || *k == 0) {
+ result[1] = 0.;
+ result[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+
+/* Copy the last k rows of the factorization to the array Q */
+
+ dlaset_("Full", m, n, &c_b4, &c_b4, &q[q_offset], lda);
+ if (*k < *n) {
+ i__1 = *n - *k;
+ dlacpy_("Full", k, &i__1, &af[*m - *k + 1 + af_dim1], lda, &q[*m - *k
+ + 1 + q_dim1], lda);
+ }
+ if (*k > 1) {
+ i__1 = *k - 1;
+ i__2 = *k - 1;
+ dlacpy_("Lower", &i__1, &i__2, &af[*m - *k + 2 + (*n - *k + 1) *
+ af_dim1], lda, &q[*m - *k + 2 + (*n - *k + 1) * q_dim1], lda);
+ }
+
+/* Generate the last n rows of the matrix Q */
+
+ s_copy(srnamc_1.srnamt, "DORGRQ", (ftnlen)32, (ftnlen)6);
+ dorgrq_(m, n, k, &q[q_offset], lda, &tau[*m - *k + 1], &work[1], lwork, &
+ info);
+
+/* Copy R(m-k+1:m,n-m+1:n) */
+
+ dlaset_("Full", k, m, &c_b10, &c_b10, &r__[*m - *k + 1 + (*n - *m + 1) *
+ r_dim1], lda);
+ dlacpy_("Upper", k, k, &af[*m - *k + 1 + (*n - *k + 1) * af_dim1], lda, &
+ r__[*m - *k + 1 + (*n - *k + 1) * r_dim1], lda);
+
+/* Compute R(m-k+1:m,n-m+1:n) - A(m-k+1:m,1:n) * Q(n-m+1:n,1:n)' */
+
+ dgemm_("No transpose", "Transpose", k, m, n, &c_b15, &a[*m - *k + 1 +
+ a_dim1], lda, &q[q_offset], lda, &c_b16, &r__[*m - *k + 1 + (*n -
+ *m + 1) * r_dim1], lda);
+
+/* Compute norm( R - A*Q' ) / ( N * norm(A) * EPS ) . */
+
+ anorm = dlange_("1", k, n, &a[*m - *k + 1 + a_dim1], lda, &rwork[1]);
+ resid = dlange_("1", k, m, &r__[*m - *k + 1 + (*n - *m + 1) * r_dim1],
+ lda, &rwork[1]);
+ if (anorm > 0.) {
+ result[1] = resid / (doublereal) max(1,*n) / anorm / eps;
+ } else {
+ result[1] = 0.;
+ }
+
+/* Compute I - Q*Q' */
+
+ dlaset_("Full", m, m, &c_b10, &c_b16, &r__[r_offset], lda);
+ dsyrk_("Upper", "No transpose", m, n, &c_b15, &q[q_offset], lda, &c_b16, &
+ r__[r_offset], lda);
+
+/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
+
+ resid = dlansy_("1", "Upper", m, &r__[r_offset], lda, &rwork[1]);
+
+ result[2] = resid / (doublereal) max(1,*n) / eps;
+
+ return 0;
+
+/* End of DRQT02 */
+
+} /* drqt02_ */
diff --git a/TESTING/LIN/drqt03.c b/TESTING/LIN/drqt03.c
new file mode 100644
index 0000000..69f65c7
--- /dev/null
+++ b/TESTING/LIN/drqt03.c
@@ -0,0 +1,288 @@
+/* drqt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublereal c_b4 = -1e10;
+static integer c__2 = 2;
+static doublereal c_b22 = -1.;
+static doublereal c_b23 = 1.;
+
+/* Subroutine */ int drqt03_(integer *m, integer *n, integer *k, doublereal *
+ af, doublereal *c__, doublereal *cc, doublereal *q, integer *lda,
+ doublereal *tau, doublereal *work, integer *lwork, doublereal *rwork,
+ doublereal *result)
+{
+ /* Initialized data */
+
+ static integer iseed[4] = { 1988,1989,1990,1991 };
+
+ /* System generated locals */
+ integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1,
+ q_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j, mc, nc;
+ doublereal eps;
+ char side[1];
+ integer info;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ integer iside;
+ extern logical lsame_(char *, char *);
+ doublereal resid;
+ integer minmn;
+ doublereal cnorm;
+ char trans[1];
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, integer *),
+ dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *), dlarnv_(integer *, integer *,
+ integer *, doublereal *), dorgrq_(integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *);
+ integer itrans;
+ extern /* Subroutine */ int dormrq_(char *, char *, integer *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DRQT03 tests DORMRQ, which computes Q*C, Q'*C, C*Q or C*Q'. */
+
+/* DRQT03 compares the results of a call to DORMRQ with the results of */
+/* forming Q explicitly by a call to DORGRQ and then performing matrix */
+/* multiplication by a call to DGEMM. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows or columns of the matrix C; C is n-by-m if */
+/* Q is applied from the left, or m-by-n if Q is applied from */
+/* the right. M >= 0. */
+
+/* N (input) INTEGER */
+/* The order of the orthogonal matrix Q. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* orthogonal matrix Q. N >= K >= 0. */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* Details of the RQ factorization of an m-by-n matrix, as */
+/* returned by DGERQF. See SGERQF for further details. */
+
+/* C (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
+
+/* CC (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
+
+/* Q (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays AF, C, CC, and Q. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the RQ factorization in AF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK must be at least M, and should be */
+/* M*NB, where NB is the blocksize for this environment. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
+/* The test ratios compare two techniques for multiplying a */
+/* random matrix C by an n-by-n orthogonal matrix Q. */
+/* RESULT(1) = norm( Q*C - Q*C ) / ( N * norm(C) * EPS ) */
+/* RESULT(2) = norm( C*Q - C*Q ) / ( N * norm(C) * EPS ) */
+/* RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS ) */
+/* RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ cc_dim1 = *lda;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+ c_dim1 = *lda;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = dlamch_("Epsilon");
+ minmn = min(*m,*n);
+
+/* Quick return if possible */
+
+ if (minmn == 0) {
+ result[1] = 0.;
+ result[2] = 0.;
+ result[3] = 0.;
+ result[4] = 0.;
+ return 0;
+ }
+
+/* Copy the last k rows of the factorization to the array Q */
+
+ dlaset_("Full", n, n, &c_b4, &c_b4, &q[q_offset], lda);
+ if (*k > 0 && *n > *k) {
+ i__1 = *n - *k;
+ dlacpy_("Full", k, &i__1, &af[*m - *k + 1 + af_dim1], lda, &q[*n - *k
+ + 1 + q_dim1], lda);
+ }
+ if (*k > 1) {
+ i__1 = *k - 1;
+ i__2 = *k - 1;
+ dlacpy_("Lower", &i__1, &i__2, &af[*m - *k + 2 + (*n - *k + 1) *
+ af_dim1], lda, &q[*n - *k + 2 + (*n - *k + 1) * q_dim1], lda);
+ }
+
+/* Generate the n-by-n matrix Q */
+
+ s_copy(srnamc_1.srnamt, "DORGRQ", (ftnlen)32, (ftnlen)6);
+ dorgrq_(n, n, k, &q[q_offset], lda, &tau[minmn - *k + 1], &work[1], lwork,
+ &info);
+
+ for (iside = 1; iside <= 2; ++iside) {
+ if (iside == 1) {
+ *(unsigned char *)side = 'L';
+ mc = *n;
+ nc = *m;
+ } else {
+ *(unsigned char *)side = 'R';
+ mc = *m;
+ nc = *n;
+ }
+
+/* Generate MC by NC matrix C */
+
+ i__1 = nc;
+ for (j = 1; j <= i__1; ++j) {
+ dlarnv_(&c__2, iseed, &mc, &c__[j * c_dim1 + 1]);
+/* L10: */
+ }
+ cnorm = dlange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]);
+ if (cnorm == 0.) {
+ cnorm = 1.;
+ }
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+ if (itrans == 1) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'T';
+ }
+
+/* Copy C */
+
+ dlacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
+ lda);
+
+/* Apply Q or Q' to C */
+
+ s_copy(srnamc_1.srnamt, "DORMRQ", (ftnlen)32, (ftnlen)6);
+ if (*k > 0) {
+ dormrq_(side, trans, &mc, &nc, k, &af[*m - *k + 1 + af_dim1],
+ lda, &tau[minmn - *k + 1], &cc[cc_offset], lda, &work[
+ 1], lwork, &info);
+ }
+
+/* Form explicit product and subtract */
+
+ if (lsame_(side, "L")) {
+ dgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b22, &q[
+ q_offset], lda, &c__[c_offset], lda, &c_b23, &cc[
+ cc_offset], lda);
+ } else {
+ dgemm_("No transpose", trans, &mc, &nc, &nc, &c_b22, &c__[
+ c_offset], lda, &q[q_offset], lda, &c_b23, &cc[
+ cc_offset], lda);
+ }
+
+/* Compute error in the difference */
+
+ resid = dlange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
+ result[(iside - 1 << 1) + itrans] = resid / ((doublereal) max(1,*
+ n) * cnorm * eps);
+
+/* L20: */
+ }
+/* L30: */
+ }
+
+ return 0;
+
+/* End of DRQT03 */
+
+} /* drqt03_ */
diff --git a/TESTING/LIN/drzt01.c b/TESTING/LIN/drzt01.c
new file mode 100644
index 0000000..96ac824
--- /dev/null
+++ b/TESTING/LIN/drzt01.c
@@ -0,0 +1,172 @@
+/* drzt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static doublereal c_b6 = 0.;
+static doublereal c_b13 = -1.;
+static integer c__1 = 1;
+
+doublereal drzt01_(integer *m, integer *n, doublereal *a, doublereal *af,
+ integer *lda, doublereal *tau, doublereal *work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2;
+ doublereal ret_val;
+
+ /* Local variables */
+ integer i__, j, info;
+ doublereal norma;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *);
+ doublereal rwork[1];
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *), dormrz_(char *, char *,
+ integer *, integer *, integer *, integer *, doublereal *, integer
+ *, doublereal *, doublereal *, integer *, doublereal *, integer *,
+ integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DRZT01 returns */
+/* || A - R*Q || / ( M * eps * ||A|| ) */
+/* for an upper trapezoidal A that was factored with DTZRZF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices A and AF. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and AF. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The original upper trapezoidal M by N matrix A. */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The output of DTZRZF for input matrix A. */
+/* The lower triangle is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A and AF. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (M) */
+/* Details of the Householder transformations as returned by */
+/* DTZRZF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= m*n + m*nb. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ if (*lwork < *m * *n + *m) {
+ xerbla_("DRZT01", &c__8);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return ret_val;
+ }
+
+ norma = dlange_("One-norm", m, n, &a[a_offset], lda, rwork);
+
+/* Copy upper triangle R */
+
+ dlaset_("Full", m, n, &c_b6, &c_b6, &work[1], m);
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[(j - 1) * *m + i__] = af[i__ + j * af_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* R = R * P(1) * ... *P(m) */
+
+ i__1 = *n - *m;
+ i__2 = *lwork - *m * *n;
+ dormrz_("Right", "No tranpose", m, n, m, &i__1, &af[af_offset], lda, &tau[
+ 1], &work[1], m, &work[*m * *n + 1], &i__2, &info);
+
+/* R = R - A */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ daxpy_(m, &c_b13, &a[i__ * a_dim1 + 1], &c__1, &work[(i__ - 1) * *m +
+ 1], &c__1);
+/* L30: */
+ }
+
+ ret_val = dlange_("One-norm", m, n, &work[1], m, rwork);
+
+ ret_val /= dlamch_("Epsilon") * (doublereal) max(*m,*n);
+ if (norma != 0.) {
+ ret_val /= norma;
+ }
+
+ return ret_val;
+
+/* End of DRZT01 */
+
+} /* drzt01_ */
diff --git a/TESTING/LIN/drzt02.c b/TESTING/LIN/drzt02.c
new file mode 100644
index 0000000..ba5b081
--- /dev/null
+++ b/TESTING/LIN/drzt02.c
@@ -0,0 +1,152 @@
+/* drzt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__7 = 7;
+static doublereal c_b5 = 0.;
+static doublereal c_b6 = 1.;
+
+doublereal drzt02_(integer *m, integer *n, doublereal *af, integer *lda,
+ doublereal *tau, doublereal *work, integer *lwork)
+{
+ /* System generated locals */
+ integer af_dim1, af_offset, i__1, i__2;
+ doublereal ret_val;
+
+ /* Local variables */
+ integer i__, info;
+ doublereal rwork[1];
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *), dormrz_(char *, char *,
+ integer *, integer *, integer *, integer *, doublereal *, integer
+ *, doublereal *, doublereal *, integer *, doublereal *, integer *,
+ integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DRZT02 returns */
+/* || I - Q'*Q || / ( M * eps) */
+/* where the matrix Q is defined by the Householder transformations */
+/* generated by DTZRZF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix AF. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix AF. */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The output of DTZRZF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array AF. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (M) */
+/* Details of the Householder transformations as returned by */
+/* DTZRZF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* length of WORK array. LWORK >= N*N+N*NB. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ if (*lwork < *n * *n + *n) {
+ xerbla_("DRZT02", &c__7);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return ret_val;
+ }
+
+/* Q := I */
+
+ dlaset_("Full", n, n, &c_b5, &c_b6, &work[1], n);
+
+/* Q := P(1) * ... * P(m) * Q */
+
+ i__1 = *n - *m;
+ i__2 = *lwork - *n * *n;
+ dormrz_("Left", "No transpose", n, n, m, &i__1, &af[af_offset], lda, &tau[
+ 1], &work[1], n, &work[*n * *n + 1], &i__2, &info);
+
+/* Q := P(m) * ... * P(1) * Q */
+
+ i__1 = *n - *m;
+ i__2 = *lwork - *n * *n;
+ dormrz_("Left", "Transpose", n, n, m, &i__1, &af[af_offset], lda, &tau[1],
+ &work[1], n, &work[*n * *n + 1], &i__2, &info);
+
+/* Q := Q - I */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[(i__ - 1) * *n + i__] += -1.;
+/* L10: */
+ }
+
+ ret_val = dlange_("One-norm", n, n, &work[1], n, rwork) / (
+ dlamch_("Epsilon") * (doublereal) max(*m,*n));
+ return ret_val;
+
+/* End of DRZT02 */
+
+} /* drzt02_ */
diff --git a/TESTING/LIN/dspt01.c b/TESTING/LIN/dspt01.c
new file mode 100644
index 0000000..043fb48
--- /dev/null
+++ b/TESTING/LIN/dspt01.c
@@ -0,0 +1,193 @@
+/* dspt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b5 = 0.;
+static doublereal c_b6 = 1.;
+
+/* Subroutine */ int dspt01_(char *uplo, integer *n, doublereal *a,
+ doublereal *afac, integer *ipiv, doublereal *c__, integer *ldc,
+ doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, jc;
+ doublereal eps;
+ integer info;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ extern doublereal dlansp_(char *, char *, integer *, doublereal *,
+ doublereal *);
+ extern /* Subroutine */ int dlavsp_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *,
+ integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSPT01 reconstructs a symmetric indefinite packed matrix A from its */
+/* block L*D*L' or U*D*U' factorization and computes the residual */
+/* norm( C - A ) / ( N * norm(A) * EPS ), */
+/* where C is the reconstructed matrix and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The original symmetric matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* AFAC (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The factored form of the matrix A, stored as a packed */
+/* triangular matrix. AFAC contains the block diagonal matrix D */
+/* and the multipliers used to obtain the factor L or U from the */
+/* block L*D*L' or U*D*U' factorization as computed by DSPTRF. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from DSPTRF. */
+
+/* C (workspace) DOUBLE PRECISION array, dimension (LDC,N) */
+
+/* LDC (integer) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) 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 ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ --a;
+ --afac;
+ --ipiv;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Determine EPS and the norm of A. */
+
+ eps = dlamch_("Epsilon");
+ anorm = dlansp_("1", uplo, n, &a[1], &rwork[1]);
+
+/* Initialize C to the identity matrix. */
+
+ dlaset_("Full", n, n, &c_b5, &c_b6, &c__[c_offset], ldc);
+
+/* Call DLAVSP to form the product D * U' (or D * L' ). */
+
+ dlavsp_(uplo, "Transpose", "Non-unit", n, n, &afac[1], &ipiv[1], &c__[
+ c_offset], ldc, &info);
+
+/* Call DLAVSP again to multiply by U ( or L ). */
+
+ dlavsp_(uplo, "No transpose", "Unit", n, n, &afac[1], &ipiv[1], &c__[
+ c_offset], ldc, &info);
+
+/* Compute the difference C - A . */
+
+ if (lsame_(uplo, "U")) {
+ jc = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] -= a[jc + i__];
+/* L10: */
+ }
+ jc += j;
+/* L20: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] -= a[jc + i__ - j];
+/* L30: */
+ }
+ jc = jc + *n - j + 1;
+/* L40: */
+ }
+ }
+
+/* Compute norm( C - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = dlansy_("1", uplo, n, &c__[c_offset], ldc, &rwork[1]);
+
+ if (anorm <= 0.) {
+ if (*resid != 0.) {
+ *resid = 1. / eps;
+ }
+ } else {
+ *resid = *resid / (doublereal) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of DSPT01 */
+
+} /* dspt01_ */
diff --git a/TESTING/LIN/dsyt01.c b/TESTING/LIN/dsyt01.c
new file mode 100644
index 0000000..7d45031
--- /dev/null
+++ b/TESTING/LIN/dsyt01.c
@@ -0,0 +1,197 @@
+/* dsyt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b5 = 0.;
+static doublereal c_b6 = 1.;
+
+/* Subroutine */ int dsyt01_(char *uplo, integer *n, doublereal *a, integer *
+ lda, doublereal *afac, integer *ldafac, integer *ipiv, doublereal *
+ c__, integer *ldc, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, c_dim1, c_offset, i__1,
+ i__2;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal eps;
+ integer info;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *);
+ extern doublereal dlansy_(char *, char *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dlavsy_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DSYT01 reconstructs a symmetric indefinite matrix A from its */
+/* block L*D*L' or U*D*U' factorization and computes the residual */
+/* norm( C - A ) / ( N * norm(A) * EPS ), */
+/* where C is the reconstructed matrix and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The original symmetric matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* AFAC (input) DOUBLE PRECISION array, dimension (LDAFAC,N) */
+/* The factored form of the matrix A. AFAC contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor L or U from the block L*D*L' or U*D*U' factorization */
+/* as computed by DSYTRF. */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from DSYTRF. */
+
+/* C (workspace) DOUBLE PRECISION array, dimension (LDC,N) */
+
+/* LDC (integer) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) 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 ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ --ipiv;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Determine EPS and the norm of A. */
+
+ eps = dlamch_("Epsilon");
+ anorm = dlansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+
+/* Initialize C to the identity matrix. */
+
+ dlaset_("Full", n, n, &c_b5, &c_b6, &c__[c_offset], ldc);
+
+/* Call DLAVSY to form the product D * U' (or D * L' ). */
+
+ dlavsy_(uplo, "Transpose", "Non-unit", n, n, &afac[afac_offset], ldafac, &
+ ipiv[1], &c__[c_offset], ldc, &info);
+
+/* Call DLAVSY again to multiply by U (or L ). */
+
+ dlavsy_(uplo, "No transpose", "Unit", n, n, &afac[afac_offset], ldafac, &
+ ipiv[1], &c__[c_offset], ldc, &info);
+
+/* Compute the difference C - A . */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] -= a[i__ + j * a_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] -= a[i__ + j * a_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+/* Compute norm( C - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = dlansy_("1", uplo, n, &c__[c_offset], ldc, &rwork[1]);
+
+ if (anorm <= 0.) {
+ if (*resid != 0.) {
+ *resid = 1. / eps;
+ }
+ } else {
+ *resid = *resid / (doublereal) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of DSYT01 */
+
+} /* dsyt01_ */
diff --git a/TESTING/LIN/dtbt02.c b/TESTING/LIN/dtbt02.c
new file mode 100644
index 0000000..bd10625
--- /dev/null
+++ b/TESTING/LIN/dtbt02.c
@@ -0,0 +1,203 @@
+/* dtbt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b10 = -1.;
+
+/* Subroutine */ int dtbt02_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, doublereal *ab, integer *ldab, doublereal
+ *x, integer *ldx, doublereal *b, integer *ldb, doublereal *work,
+ doublereal *resid)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal anorm, bnorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), dtbmv_(char *, char *, char *, integer *
+, integer *, doublereal *, integer *, doublereal *, integer *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *);
+ doublereal xnorm;
+ extern doublereal dlamch_(char *), dlantb_(char *, char *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTBT02 computes the residual for the computed solution to a */
+/* triangular system of linear equations A*x = b or A' *x = b when */
+/* A is a triangular band matrix. Here A' is the transpose of A and */
+/* x and b are N by NRHS matrices. The test ratio is the maximum over */
+/* the number of right hand sides of */
+/* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A or A' and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = b (No transpose) */
+/* = 'T': A'*x = b (Transpose) */
+/* = 'C': A'*x = b (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Compute the 1-norm of A or A'. */
+
+ if (lsame_(trans, "N")) {
+ anorm = dlantb_("1", uplo, diag, n, kd, &ab[ab_offset], ldab, &work[1]
+);
+ } else {
+ anorm = dlantb_("I", uplo, diag, n, kd, &ab[ab_offset], ldab, &work[1]
+);
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ dtbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[1], &
+ c__1);
+ daxpy_(n, &c_b10, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ bnorm = dasum_(n, &work[1], &c__1);
+ xnorm = dasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of DTBT02 */
+
+} /* dtbt02_ */
diff --git a/TESTING/LIN/dtbt03.c b/TESTING/LIN/dtbt03.c
new file mode 100644
index 0000000..2a9902b
--- /dev/null
+++ b/TESTING/LIN/dtbt03.c
@@ -0,0 +1,257 @@
+/* dtbt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dtbt03_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, doublereal *ab, integer *ldab, doublereal
+ *scale, doublereal *cnorm, doublereal *tscal, doublereal *x, integer *
+ ldx, doublereal *b, integer *ldb, doublereal *work, doublereal *resid)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer j, ix;
+ doublereal eps, err;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ doublereal xscal;
+ extern /* Subroutine */ int dtbmv_(char *, char *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, integer *), dcopy_(integer *, doublereal *, integer *
+, doublereal *, integer *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *);
+ doublereal tnorm, xnorm;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal bignum, smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTBT03 computes the residual for the solution to a scaled triangular */
+/* system of equations A*x = s*b or A'*x = s*b when A is a */
+/* triangular band matrix. Here A' is the transpose of A, s is a scalar, */
+/* and x and b are N by NRHS matrices. The test ratio is the maximum */
+/* over the number of right hand sides of */
+/* norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A or A' and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = b (No transpose) */
+/* = 'T': A'*x = b (Transpose) */
+/* = 'C': A'*x = b (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* SCALE (input) DOUBLE PRECISION */
+/* The scaling factor s used in solving the triangular system. */
+
+/* CNORM (input) DOUBLE PRECISION array, dimension (N) */
+/* The 1-norms of the columns of A, not counting the diagonal. */
+
+/* TSCAL (input) DOUBLE PRECISION */
+/* The scaling factor used in computing the 1-norms in CNORM. */
+/* CNORM actually contains the column norms of TSCAL*A. */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --cnorm;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+ eps = dlamch_("Epsilon");
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Compute the norm of the triangular matrix A using the column */
+/* norms already computed by DLATBS. */
+
+ tnorm = 0.;
+ if (lsame_(diag, "N")) {
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ d__2 = tnorm, d__3 = *tscal * (d__1 = ab[*kd + 1 + j *
+ ab_dim1], abs(d__1)) + cnorm[j];
+ tnorm = max(d__2,d__3);
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ d__2 = tnorm, d__3 = *tscal * (d__1 = ab[j * ab_dim1 + 1],
+ abs(d__1)) + cnorm[j];
+ tnorm = max(d__2,d__3);
+/* L20: */
+ }
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ d__1 = tnorm, d__2 = *tscal + cnorm[j];
+ tnorm = max(d__1,d__2);
+/* L30: */
+ }
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = idamax_(n, &work[1], &c__1);
+/* Computing MAX */
+ d__2 = 1., d__3 = (d__1 = x[ix + j * x_dim1], abs(d__1));
+ xnorm = max(d__2,d__3);
+ xscal = 1. / xnorm / (doublereal) (*kd + 1);
+ dscal_(n, &xscal, &work[1], &c__1);
+ dtbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[1], &
+ c__1);
+ d__1 = -(*scale) * xscal;
+ daxpy_(n, &d__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = idamax_(n, &work[1], &c__1);
+ err = *tscal * (d__1 = work[ix], abs(d__1));
+ ix = idamax_(n, &x[j * x_dim1 + 1], &c__1);
+ xnorm = (d__1 = x[ix + j * x_dim1], abs(d__1));
+ if (err * smlnum <= xnorm) {
+ if (xnorm > 0.) {
+ err /= xnorm;
+ }
+ } else {
+ if (err > 0.) {
+ err = 1. / eps;
+ }
+ }
+ if (err * smlnum <= tnorm) {
+ if (tnorm > 0.) {
+ err /= tnorm;
+ }
+ } else {
+ if (err > 0.) {
+ err = 1. / eps;
+ }
+ }
+ *resid = max(*resid,err);
+/* L40: */
+ }
+
+ return 0;
+
+/* End of DTBT03 */
+
+} /* dtbt03_ */
diff --git a/TESTING/LIN/dtbt05.c b/TESTING/LIN/dtbt05.c
new file mode 100644
index 0000000..03a9b6d
--- /dev/null
+++ b/TESTING/LIN/dtbt05.c
@@ -0,0 +1,334 @@
+/* dtbt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dtbt05_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, doublereal *ab, integer *ldab, doublereal
+ *b, integer *ldb, doublereal *x, integer *ldx, doublereal *xact,
+ integer *ldxact, doublereal *ferr, doublereal *berr, doublereal *
+ reslts)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, k, nz, ifu;
+ doublereal eps, tmp, diff, axbi;
+ integer imax;
+ doublereal unfl, ovfl;
+ logical unit;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ doublereal xnorm;
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal errbnd;
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTBT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* triangular band matrix. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+/* and NZ = max. number of nonzeros in any row of A, plus 1 */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A'* X = B (Transpose) */
+/* = 'C': A'* X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.;
+ reslts[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ unit = lsame_(diag, "U");
+/* Computing MIN */
+ i__1 = *kd, i__2 = *n - 1;
+ nz = min(i__1,i__2) + 1;
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = idamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ d__2 = (d__1 = x[imax + j * x_dim1], abs(d__1));
+ xnorm = max(d__2,unfl);
+ diff = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = diff, d__3 = (d__1 = x[i__ + j * x_dim1] - xact[i__ + j *
+ xact_dim1], abs(d__1));
+ diff = max(d__2,d__3);
+/* L10: */
+ }
+
+ if (xnorm > 1.) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1. / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
+ errbnd = max(d__1,d__2);
+ } else {
+ errbnd = 1. / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ ifu = 0;
+ if (unit) {
+ ifu = 1;
+ }
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ tmp = (d__1 = b[i__ + k * b_dim1], abs(d__1));
+ if (upper) {
+ if (! notran) {
+/* Computing MAX */
+ i__3 = i__ - *kd;
+ i__4 = i__ - ifu;
+ for (j = max(i__3,1); j <= i__4; ++j) {
+ tmp += (d__1 = ab[*kd + 1 - i__ + j + i__ * ab_dim1],
+ abs(d__1)) * (d__2 = x[j + k * x_dim1], abs(
+ d__2));
+/* L40: */
+ }
+ if (unit) {
+ tmp += (d__1 = x[i__ + k * x_dim1], abs(d__1));
+ }
+ } else {
+ if (unit) {
+ tmp += (d__1 = x[i__ + k * x_dim1], abs(d__1));
+ }
+/* Computing MIN */
+ i__3 = i__ + *kd;
+ i__4 = min(i__3,*n);
+ for (j = i__ + ifu; j <= i__4; ++j) {
+ tmp += (d__1 = ab[*kd + 1 + i__ - j + j * ab_dim1],
+ abs(d__1)) * (d__2 = x[j + k * x_dim1], abs(
+ d__2));
+/* L50: */
+ }
+ }
+ } else {
+ if (notran) {
+/* Computing MAX */
+ i__4 = i__ - *kd;
+ i__3 = i__ - ifu;
+ for (j = max(i__4,1); j <= i__3; ++j) {
+ tmp += (d__1 = ab[i__ + 1 - j + j * ab_dim1], abs(
+ d__1)) * (d__2 = x[j + k * x_dim1], abs(d__2))
+ ;
+/* L60: */
+ }
+ if (unit) {
+ tmp += (d__1 = x[i__ + k * x_dim1], abs(d__1));
+ }
+ } else {
+ if (unit) {
+ tmp += (d__1 = x[i__ + k * x_dim1], abs(d__1));
+ }
+/* Computing MIN */
+ i__4 = i__ + *kd;
+ i__3 = min(i__4,*n);
+ for (j = i__ + ifu; j <= i__3; ++j) {
+ tmp += (d__1 = ab[j + 1 - i__ + i__ * ab_dim1], abs(
+ d__1)) * (d__2 = x[j + k * x_dim1], abs(d__2))
+ ;
+/* L70: */
+ }
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = min(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ d__1 = axbi, d__2 = nz * unfl;
+ tmp = berr[k] / (nz * eps + nz * unfl / max(d__1,d__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = max(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of DTBT05 */
+
+} /* dtbt05_ */
diff --git a/TESTING/LIN/dtbt06.c b/TESTING/LIN/dtbt06.c
new file mode 100644
index 0000000..ae5333e
--- /dev/null
+++ b/TESTING/LIN/dtbt06.c
@@ -0,0 +1,164 @@
+/* dtbt06.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtbt06_(doublereal *rcond, doublereal *rcondc, char *
+ uplo, char *diag, integer *n, integer *kd, doublereal *ab, integer *
+ ldab, doublereal *work, doublereal *rat)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ doublereal eps, rmin, rmax, anorm;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *), dlantb_(char *, char *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *);
+ doublereal bignum, smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTBT06 computes a test ratio comparing RCOND (the reciprocal */
+/* condition number of a triangular matrix A) and RCONDC, the estimate */
+/* computed by DTBCON. Information about the triangular matrix A is */
+/* used if one estimate is zero and the other is non-zero to decide if */
+/* underflow in the estimate is justified. */
+
+/* Arguments */
+/* ========= */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number obtained by */
+/* forming the explicit inverse of the matrix A and computing */
+/* RCOND = 1/( norm(A) * norm(inv(A)) ). */
+
+/* RCONDC (input) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number computed by */
+/* DTBCON. */
+
+/* UPLO (input) CHARACTER */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RAT (output) DOUBLE PRECISION */
+/* The test ratio. If both RCOND and RCONDC are nonzero, */
+/* RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1. */
+/* If RAT = 0, the two estimates are exactly the same. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+
+ /* Function Body */
+ eps = dlamch_("Epsilon");
+ rmax = max(*rcond,*rcondc);
+ rmin = min(*rcond,*rcondc);
+
+/* Do the easy cases first. */
+
+ if (rmin < 0.) {
+
+/* Invalid value for RCOND or RCONDC, return 1/EPS. */
+
+ *rat = 1. / eps;
+
+ } else if (rmin > 0.) {
+
+/* Both estimates are positive, return RMAX/RMIN - 1. */
+
+ *rat = rmax / rmin - 1.;
+
+ } else if (rmax == 0.) {
+
+/* Both estimates zero. */
+
+ *rat = 0.;
+
+ } else {
+
+/* One estimate is zero, the other is non-zero. If the matrix is */
+/* ill-conditioned, return the nonzero estimate multiplied by */
+/* 1/EPS; if the matrix is badly scaled, return the nonzero */
+/* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum */
+/* element in absolute value in A. */
+
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ anorm = dlantb_("M", uplo, diag, n, kd, &ab[ab_offset], ldab, &work[1]
+);
+
+/* Computing MIN */
+ d__1 = bignum / max(1.,anorm), d__2 = 1. / eps;
+ *rat = rmax * min(d__1,d__2);
+ }
+
+ return 0;
+
+/* End of DTBT06 */
+
+} /* dtbt06_ */
diff --git a/TESTING/LIN/dtpt01.c b/TESTING/LIN/dtpt01.c
new file mode 100644
index 0000000..f3e27c8
--- /dev/null
+++ b/TESTING/LIN/dtpt01.c
@@ -0,0 +1,189 @@
+/* dtpt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dtpt01_(char *uplo, char *diag, integer *n, doublereal *
+ ap, doublereal *ainvp, doublereal *rcond, doublereal *work,
+ doublereal *resid)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer j, jc;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ logical unitd;
+ extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *,
+ doublereal *, doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlantp_(char *, char *, char *,
+ integer *, doublereal *, doublereal *);
+ doublereal ainvnm;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTPT01 computes the residual for a triangular matrix A times its */
+/* inverse when A is stored in packed format: */
+/* RESID = norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The original upper or lower triangular matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
+
+/* AINVP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* On entry, the (triangular) inverse of the matrix A, packed */
+/* columnwise in a linear array as in AP. */
+/* On exit, the contents of AINVP are destroyed. */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal condition number of A, computed as */
+/* 1/(norm(A) * norm(AINV)). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ --work;
+ --ainvp;
+ --ap;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.;
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = dlantp_("1", uplo, diag, n, &ap[1], &work[1]);
+ ainvnm = dlantp_("1", uplo, diag, n, &ainvp[1], &work[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ *rcond = 0.;
+ *resid = 1. / eps;
+ return 0;
+ }
+ *rcond = 1. / anorm / ainvnm;
+
+/* Compute A * AINV, overwriting AINV. */
+
+ unitd = lsame_(diag, "U");
+ if (lsame_(uplo, "U")) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (unitd) {
+ ainvp[jc + j - 1] = 1.;
+ }
+
+/* Form the j-th column of A*AINV */
+
+ dtpmv_("Upper", "No transpose", diag, &j, &ap[1], &ainvp[jc], &
+ c__1);
+
+/* Subtract 1 from the diagonal */
+
+ ainvp[jc + j - 1] += -1.;
+ jc += j;
+/* L10: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (unitd) {
+ ainvp[jc] = 1.;
+ }
+
+/* Form the j-th column of A*AINV */
+
+ i__2 = *n - j + 1;
+ dtpmv_("Lower", "No transpose", diag, &i__2, &ap[jc], &ainvp[jc],
+ &c__1);
+
+/* Subtract 1 from the diagonal */
+
+ ainvp[jc] += -1.;
+ jc = jc + *n - j + 1;
+/* L20: */
+ }
+ }
+
+/* Compute norm(A*AINV - I) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = dlantp_("1", uplo, "Non-unit", n, &ainvp[1], &work[1]);
+
+ *resid = *resid * *rcond / (doublereal) (*n) / eps;
+
+ return 0;
+
+/* End of DTPT01 */
+
+} /* dtpt01_ */
diff --git a/TESTING/LIN/dtpt02.c b/TESTING/LIN/dtpt02.c
new file mode 100644
index 0000000..930d0f8
--- /dev/null
+++ b/TESTING/LIN/dtpt02.c
@@ -0,0 +1,191 @@
+/* dtpt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b10 = -1.;
+
+/* Subroutine */ int dtpt02_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublereal *ap, doublereal *x, integer *ldx,
+ doublereal *b, integer *ldb, doublereal *work, doublereal *resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal anorm, bnorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *), dtpmv_(char *,
+ char *, char *, integer *, doublereal *, doublereal *, integer *);
+ doublereal xnorm;
+ extern doublereal dlamch_(char *), dlantp_(char *, char *, char *,
+ integer *, doublereal *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTPT02 computes the residual for the computed solution to a */
+/* triangular system of linear equations A*x = b or A'*x = b when */
+/* the triangular matrix A is stored in packed format. Here A' is the */
+/* transpose of A and x and b are N by NRHS matrices. The test ratio is */
+/* the maximum over the number of right hand sides of */
+/* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A or A' and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = b (No transpose) */
+/* = 'T': A'*x = b (Transpose) */
+/* = 'C': A'*x = b (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ --ap;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Compute the 1-norm of A or A'. */
+
+ if (lsame_(trans, "N")) {
+ anorm = dlantp_("1", uplo, diag, n, &ap[1], &work[1]);
+ } else {
+ anorm = dlantp_("I", uplo, diag, n, &ap[1], &work[1]);
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ dtpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1);
+ daxpy_(n, &c_b10, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ bnorm = dasum_(n, &work[1], &c__1);
+ xnorm = dasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of DTPT02 */
+
+} /* dtpt02_ */
diff --git a/TESTING/LIN/dtpt03.c b/TESTING/LIN/dtpt03.c
new file mode 100644
index 0000000..653ec63
--- /dev/null
+++ b/TESTING/LIN/dtpt03.c
@@ -0,0 +1,252 @@
+/* dtpt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dtpt03_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublereal *ap, doublereal *scale, doublereal *cnorm,
+ doublereal *tscal, doublereal *x, integer *ldx, doublereal *b,
+ integer *ldb, doublereal *work, doublereal *resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer j, jj, ix;
+ doublereal eps, err;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ doublereal xscal;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *), dtpmv_(char *,
+ char *, char *, integer *, doublereal *, doublereal *, integer *);
+ doublereal tnorm, xnorm;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal bignum, smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTPT03 computes the residual for the solution to a scaled triangular */
+/* system of equations A*x = s*b or A'*x = s*b when the triangular */
+/* matrix A is stored in packed format. Here A' is the transpose of A, */
+/* s is a scalar, and x and b are N by NRHS matrices. The test ratio is */
+/* the maximum over the number of right hand sides of */
+/* norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A or A' and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = s*b (No transpose) */
+/* = 'T': A'*x = s*b (Transpose) */
+/* = 'C': A'*x = s*b (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
+
+/* SCALE (input) DOUBLE PRECISION */
+/* The scaling factor s used in solving the triangular system. */
+
+/* CNORM (input) DOUBLE PRECISION array, dimension (N) */
+/* The 1-norms of the columns of A, not counting the diagonal. */
+
+/* TSCAL (input) DOUBLE PRECISION */
+/* The scaling factor used in computing the 1-norms in CNORM. */
+/* CNORM actually contains the column norms of TSCAL*A. */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ --ap;
+ --cnorm;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+ eps = dlamch_("Epsilon");
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Compute the norm of the triangular matrix A using the column */
+/* norms already computed by DLATPS. */
+
+ tnorm = 0.;
+ if (lsame_(diag, "N")) {
+ if (lsame_(uplo, "U")) {
+ jj = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ d__2 = tnorm, d__3 = *tscal * (d__1 = ap[jj], abs(d__1)) +
+ cnorm[j];
+ tnorm = max(d__2,d__3);
+ jj = jj + j + 1;
+/* L10: */
+ }
+ } else {
+ jj = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ d__2 = tnorm, d__3 = *tscal * (d__1 = ap[jj], abs(d__1)) +
+ cnorm[j];
+ tnorm = max(d__2,d__3);
+ jj = jj + *n - j + 1;
+/* L20: */
+ }
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ d__1 = tnorm, d__2 = *tscal + cnorm[j];
+ tnorm = max(d__1,d__2);
+/* L30: */
+ }
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = idamax_(n, &work[1], &c__1);
+/* Computing MAX */
+ d__2 = 1., d__3 = (d__1 = x[ix + j * x_dim1], abs(d__1));
+ xnorm = max(d__2,d__3);
+ xscal = 1. / xnorm / (doublereal) (*n);
+ dscal_(n, &xscal, &work[1], &c__1);
+ dtpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1);
+ d__1 = -(*scale) * xscal;
+ daxpy_(n, &d__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = idamax_(n, &work[1], &c__1);
+ err = *tscal * (d__1 = work[ix], abs(d__1));
+ ix = idamax_(n, &x[j * x_dim1 + 1], &c__1);
+ xnorm = (d__1 = x[ix + j * x_dim1], abs(d__1));
+ if (err * smlnum <= xnorm) {
+ if (xnorm > 0.) {
+ err /= xnorm;
+ }
+ } else {
+ if (err > 0.) {
+ err = 1. / eps;
+ }
+ }
+ if (err * smlnum <= tnorm) {
+ if (tnorm > 0.) {
+ err /= tnorm;
+ }
+ } else {
+ if (err > 0.) {
+ err = 1. / eps;
+ }
+ }
+ *resid = max(*resid,err);
+/* L40: */
+ }
+
+ return 0;
+
+/* End of DTPT03 */
+
+} /* dtpt03_ */
diff --git a/TESTING/LIN/dtpt05.c b/TESTING/LIN/dtpt05.c
new file mode 100644
index 0000000..68416a3
--- /dev/null
+++ b/TESTING/LIN/dtpt05.c
@@ -0,0 +1,315 @@
+/* dtpt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dtpt05_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublereal *ap, doublereal *b, integer *ldb,
+ doublereal *x, integer *ldx, doublereal *xact, integer *ldxact,
+ doublereal *ferr, doublereal *berr, doublereal *reslts)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1,
+ i__2, i__3;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, k, jc, ifu;
+ doublereal eps, tmp, diff, axbi;
+ integer imax;
+ doublereal unfl, ovfl;
+ logical unit;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ doublereal xnorm;
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal errbnd;
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTPT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* triangular matrix in packed storage format. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A'* X = B (Transpose) */
+/* = 'C': A'* X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.;
+ reslts[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ unit = lsame_(diag, "U");
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = idamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ d__2 = (d__1 = x[imax + j * x_dim1], abs(d__1));
+ xnorm = max(d__2,unfl);
+ diff = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = diff, d__3 = (d__1 = x[i__ + j * x_dim1] - xact[i__ + j *
+ xact_dim1], abs(d__1));
+ diff = max(d__2,d__3);
+/* L10: */
+ }
+
+ if (xnorm > 1.) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1. / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
+ errbnd = max(d__1,d__2);
+ } else {
+ errbnd = 1. / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ ifu = 0;
+ if (unit) {
+ ifu = 1;
+ }
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ tmp = (d__1 = b[i__ + k * b_dim1], abs(d__1));
+ if (upper) {
+ jc = (i__ - 1) * i__ / 2;
+ if (! notran) {
+ i__3 = i__ - ifu;
+ for (j = 1; j <= i__3; ++j) {
+ tmp += (d__1 = ap[jc + j], abs(d__1)) * (d__2 = x[j +
+ k * x_dim1], abs(d__2));
+/* L40: */
+ }
+ if (unit) {
+ tmp += (d__1 = x[i__ + k * x_dim1], abs(d__1));
+ }
+ } else {
+ jc += i__;
+ if (unit) {
+ tmp += (d__1 = x[i__ + k * x_dim1], abs(d__1));
+ jc += i__;
+ }
+ i__3 = *n;
+ for (j = i__ + ifu; j <= i__3; ++j) {
+ tmp += (d__1 = ap[jc], abs(d__1)) * (d__2 = x[j + k *
+ x_dim1], abs(d__2));
+ jc += j;
+/* L50: */
+ }
+ }
+ } else {
+ if (notran) {
+ jc = i__;
+ i__3 = i__ - ifu;
+ for (j = 1; j <= i__3; ++j) {
+ tmp += (d__1 = ap[jc], abs(d__1)) * (d__2 = x[j + k *
+ x_dim1], abs(d__2));
+ jc = jc + *n - j;
+/* L60: */
+ }
+ if (unit) {
+ tmp += (d__1 = x[i__ + k * x_dim1], abs(d__1));
+ }
+ } else {
+ jc = (i__ - 1) * (*n - i__) + i__ * (i__ + 1) / 2;
+ if (unit) {
+ tmp += (d__1 = x[i__ + k * x_dim1], abs(d__1));
+ }
+ i__3 = *n;
+ for (j = i__ + ifu; j <= i__3; ++j) {
+ tmp += (d__1 = ap[jc + j - i__], abs(d__1)) * (d__2 =
+ x[j + k * x_dim1], abs(d__2));
+/* L70: */
+ }
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = min(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ d__1 = axbi, d__2 = (*n + 1) * unfl;
+ tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / max(d__1,d__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = max(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of DTPT05 */
+
+} /* dtpt05_ */
diff --git a/TESTING/LIN/dtpt06.c b/TESTING/LIN/dtpt06.c
new file mode 100644
index 0000000..b46b921
--- /dev/null
+++ b/TESTING/LIN/dtpt06.c
@@ -0,0 +1,156 @@
+/* dtpt06.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtpt06_(doublereal *rcond, doublereal *rcondc, char *
+ uplo, char *diag, integer *n, doublereal *ap, doublereal *work,
+ doublereal *rat)
+{
+ /* System generated locals */
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ doublereal eps, rmin, rmax, anorm;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ doublereal bignum;
+ extern doublereal dlantp_(char *, char *, char *, integer *, doublereal *,
+ doublereal *);
+ doublereal smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTPT06 computes a test ratio comparing RCOND (the reciprocal */
+/* condition number of a triangular matrix A) and RCONDC, the estimate */
+/* computed by DTPCON. Information about the triangular matrix A is */
+/* used if one estimate is zero and the other is non-zero to decide if */
+/* underflow in the estimate is justified. */
+
+/* Arguments */
+/* ========= */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number obtained by */
+/* forming the explicit inverse of the matrix A and computing */
+/* RCOND = 1/( norm(A) * norm(inv(A)) ). */
+
+/* RCONDC (input) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number computed by */
+/* DTPCON. */
+
+/* UPLO (input) CHARACTER */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RAT (output) DOUBLE PRECISION */
+/* The test ratio. If both RCOND and RCONDC are nonzero, */
+/* RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1. */
+/* If RAT = 0, the two estimates are exactly the same. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --ap;
+
+ /* Function Body */
+ eps = dlamch_("Epsilon");
+ rmax = max(*rcond,*rcondc);
+ rmin = min(*rcond,*rcondc);
+
+/* Do the easy cases first. */
+
+ if (rmin < 0.) {
+
+/* Invalid value for RCOND or RCONDC, return 1/EPS. */
+
+ *rat = 1. / eps;
+
+ } else if (rmin > 0.) {
+
+/* Both estimates are positive, return RMAX/RMIN - 1. */
+
+ *rat = rmax / rmin - 1.;
+
+ } else if (rmax == 0.) {
+
+/* Both estimates zero. */
+
+ *rat = 0.;
+
+ } else {
+
+/* One estimate is zero, the other is non-zero. If the matrix is */
+/* ill-conditioned, return the nonzero estimate multiplied by */
+/* 1/EPS; if the matrix is badly scaled, return the nonzero */
+/* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum */
+/* element in absolute value in A. */
+
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ anorm = dlantp_("M", uplo, diag, n, &ap[1], &work[1]);
+
+/* Computing MIN */
+ d__1 = bignum / max(1.,anorm), d__2 = 1. / eps;
+ *rat = rmax * min(d__1,d__2);
+ }
+
+ return 0;
+
+/* End of DTPT06 */
+
+} /* dtpt06_ */
diff --git a/TESTING/LIN/dtrt01.c b/TESTING/LIN/dtrt01.c
new file mode 100644
index 0000000..e3cb594
--- /dev/null
+++ b/TESTING/LIN/dtrt01.c
@@ -0,0 +1,195 @@
+/* dtrt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dtrt01_(char *uplo, char *diag, integer *n, doublereal *
+ a, integer *lda, doublereal *ainv, integer *ldainv, doublereal *rcond,
+ doublereal *work, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, ainv_dim1, ainv_offset, i__1, i__2;
+
+ /* Local variables */
+ integer j;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *,
+ doublereal *, integer *, doublereal *, integer *);
+ extern doublereal dlamch_(char *), dlantr_(char *, char *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *);
+ doublereal ainvnm;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTRT01 computes the residual for a triangular matrix A times its */
+/* inverse: */
+/* RESID = norm( A*AINV - I ) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AINV (input/output) DOUBLE PRECISION array, dimension (LDAINV,N) */
+/* On entry, the (triangular) inverse of the matrix A, in the */
+/* same storage format as A. */
+/* On exit, the contents of AINV are destroyed. */
+
+/* LDAINV (input) INTEGER */
+/* The leading dimension of the array AINV. LDAINV >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal condition number of A, computed as */
+/* 1/(norm(A) * norm(AINV)). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ ainv_dim1 = *ldainv;
+ ainv_offset = 1 + ainv_dim1;
+ ainv -= ainv_offset;
+ --work;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.;
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = dlantr_("1", uplo, diag, n, n, &a[a_offset], lda, &work[1]);
+ ainvnm = dlantr_("1", uplo, diag, n, n, &ainv[ainv_offset], ldainv, &work[
+ 1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ *rcond = 0.;
+ *resid = 1. / eps;
+ return 0;
+ }
+ *rcond = 1. / anorm / ainvnm;
+
+/* Set the diagonal of AINV to 1 if AINV has unit diagonal. */
+
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ainv[j + j * ainv_dim1] = 1.;
+/* L10: */
+ }
+ }
+
+/* Compute A * AINV, overwriting AINV. */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dtrmv_("Upper", "No transpose", diag, &j, &a[a_offset], lda, &
+ ainv[j * ainv_dim1 + 1], &c__1);
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ dtrmv_("Lower", "No transpose", diag, &i__2, &a[j + j * a_dim1],
+ lda, &ainv[j + j * ainv_dim1], &c__1);
+/* L30: */
+ }
+ }
+
+/* Subtract 1 from each diagonal element to form A*AINV - I. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ainv[j + j * ainv_dim1] += -1.;
+/* L40: */
+ }
+
+/* Compute norm(A*AINV - I) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = dlantr_("1", uplo, "Non-unit", n, n, &ainv[ainv_offset], ldainv,
+ &work[1]);
+
+ *resid = *resid * *rcond / (doublereal) (*n) / eps;
+
+ return 0;
+
+/* End of DTRT01 */
+
+} /* dtrt01_ */
diff --git a/TESTING/LIN/dtrt02.c b/TESTING/LIN/dtrt02.c
new file mode 100644
index 0000000..419b23b
--- /dev/null
+++ b/TESTING/LIN/dtrt02.c
@@ -0,0 +1,199 @@
+/* dtrt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b10 = -1.;
+
+/* Subroutine */ int dtrt02_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublereal *a, integer *lda, doublereal *x, integer *
+ ldx, doublereal *b, integer *ldb, doublereal *work, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ doublereal anorm, bnorm;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *), dtrmv_(char *,
+ char *, char *, integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal xnorm;
+ extern doublereal dlamch_(char *), dlantr_(char *, char *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTRT02 computes the residual for the computed solution to a */
+/* triangular system of linear equations A*x = b or A'*x = b. */
+/* Here A is a triangular matrix, A' is the transpose of A, and x and b */
+/* are N by NRHS matrices. The test ratio is the maximum over the */
+/* number of right hand sides of */
+/* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A or A' and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = b (No transpose) */
+/* = 'T': A'*x = b (Transpose) */
+/* = 'C': A'*x = b (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Compute the 1-norm of A or A'. */
+
+ if (lsame_(trans, "N")) {
+ anorm = dlantr_("1", uplo, diag, n, n, &a[a_offset], lda, &work[1]);
+ } else {
+ anorm = dlantr_("I", uplo, diag, n, n, &a[a_offset], lda, &work[1]);
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ) */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ dtrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
+ daxpy_(n, &c_b10, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ bnorm = dasum_(n, &work[1], &c__1);
+ xnorm = dasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of DTRT02 */
+
+} /* dtrt02_ */
diff --git a/TESTING/LIN/dtrt03.c b/TESTING/LIN/dtrt03.c
new file mode 100644
index 0000000..fe523fd
--- /dev/null
+++ b/TESTING/LIN/dtrt03.c
@@ -0,0 +1,245 @@
+/* dtrt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dtrt03_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublereal *a, integer *lda, doublereal *scale,
+ doublereal *cnorm, doublereal *tscal, doublereal *x, integer *ldx,
+ doublereal *b, integer *ldb, doublereal *work, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer j, ix;
+ doublereal eps, err;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ doublereal xscal;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *), dtrmv_(char *,
+ char *, char *, integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal tnorm, xnorm;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal bignum, smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTRT03 computes the residual for the solution to a scaled triangular */
+/* system of equations A*x = s*b or A'*x = s*b. */
+/* Here A is a triangular matrix, A' is the transpose of A, s is a */
+/* scalar, and x and b are N by NRHS matrices. The test ratio is the */
+/* maximum over the number of right hand sides of */
+/* norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A or A' and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = s*b (No transpose) */
+/* = 'T': A'*x = s*b (Transpose) */
+/* = 'C': A'*x = s*b (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* SCALE (input) DOUBLE PRECISION */
+/* The scaling factor s used in solving the triangular system. */
+
+/* CNORM (input) DOUBLE PRECISION array, dimension (N) */
+/* The 1-norms of the columns of A, not counting the diagonal. */
+
+/* TSCAL (input) DOUBLE PRECISION */
+/* The scaling factor used in computing the 1-norms in CNORM. */
+/* CNORM actually contains the column norms of TSCAL*A. */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --cnorm;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+ eps = dlamch_("Epsilon");
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Compute the norm of the triangular matrix A using the column */
+/* norms already computed by DLATRS. */
+
+ tnorm = 0.;
+ if (lsame_(diag, "N")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ d__2 = tnorm, d__3 = *tscal * (d__1 = a[j + j * a_dim1], abs(d__1)
+ ) + cnorm[j];
+ tnorm = max(d__2,d__3);
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ d__1 = tnorm, d__2 = *tscal + cnorm[j];
+ tnorm = max(d__1,d__2);
+/* L20: */
+ }
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = idamax_(n, &work[1], &c__1);
+/* Computing MAX */
+ d__2 = 1., d__3 = (d__1 = x[ix + j * x_dim1], abs(d__1));
+ xnorm = max(d__2,d__3);
+ xscal = 1. / xnorm / (doublereal) (*n);
+ dscal_(n, &xscal, &work[1], &c__1);
+ dtrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
+ d__1 = -(*scale) * xscal;
+ daxpy_(n, &d__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = idamax_(n, &work[1], &c__1);
+ err = *tscal * (d__1 = work[ix], abs(d__1));
+ ix = idamax_(n, &x[j * x_dim1 + 1], &c__1);
+ xnorm = (d__1 = x[ix + j * x_dim1], abs(d__1));
+ if (err * smlnum <= xnorm) {
+ if (xnorm > 0.) {
+ err /= xnorm;
+ }
+ } else {
+ if (err > 0.) {
+ err = 1. / eps;
+ }
+ }
+ if (err * smlnum <= tnorm) {
+ if (tnorm > 0.) {
+ err /= tnorm;
+ }
+ } else {
+ if (err > 0.) {
+ err = 1. / eps;
+ }
+ }
+ *resid = max(*resid,err);
+/* L30: */
+ }
+
+ return 0;
+
+/* End of DTRT03 */
+
+} /* dtrt03_ */
diff --git a/TESTING/LIN/dtrt05.c b/TESTING/LIN/dtrt05.c
new file mode 100644
index 0000000..61479cd
--- /dev/null
+++ b/TESTING/LIN/dtrt05.c
@@ -0,0 +1,314 @@
+/* dtrt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dtrt05_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *
+ ldb, doublereal *x, integer *ldx, doublereal *xact, integer *ldxact,
+ doublereal *ferr, doublereal *berr, doublereal *reslts)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, k, ifu;
+ doublereal eps, tmp, diff, axbi;
+ integer imax;
+ doublereal unfl, ovfl;
+ logical unit;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ doublereal xnorm;
+ extern doublereal dlamch_(char *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal errbnd;
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTRT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* triangular n by n matrix. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A'* X = B (Transpose) */
+/* = 'C': A'* X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.;
+ reslts[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ unit = lsame_(diag, "U");
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = idamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ d__2 = (d__1 = x[imax + j * x_dim1], abs(d__1));
+ xnorm = max(d__2,unfl);
+ diff = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = diff, d__3 = (d__1 = x[i__ + j * x_dim1] - xact[i__ + j *
+ xact_dim1], abs(d__1));
+ diff = max(d__2,d__3);
+/* L10: */
+ }
+
+ if (xnorm > 1.) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1. / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
+ errbnd = max(d__1,d__2);
+ } else {
+ errbnd = 1. / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ ifu = 0;
+ if (unit) {
+ ifu = 1;
+ }
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ tmp = (d__1 = b[i__ + k * b_dim1], abs(d__1));
+ if (upper) {
+ if (! notran) {
+ i__3 = i__ - ifu;
+ for (j = 1; j <= i__3; ++j) {
+ tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1)) * (
+ d__2 = x[j + k * x_dim1], abs(d__2));
+/* L40: */
+ }
+ if (unit) {
+ tmp += (d__1 = x[i__ + k * x_dim1], abs(d__1));
+ }
+ } else {
+ if (unit) {
+ tmp += (d__1 = x[i__ + k * x_dim1], abs(d__1));
+ }
+ i__3 = *n;
+ for (j = i__ + ifu; j <= i__3; ++j) {
+ tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * (
+ d__2 = x[j + k * x_dim1], abs(d__2));
+/* L50: */
+ }
+ }
+ } else {
+ if (notran) {
+ i__3 = i__ - ifu;
+ for (j = 1; j <= i__3; ++j) {
+ tmp += (d__1 = a[i__ + j * a_dim1], abs(d__1)) * (
+ d__2 = x[j + k * x_dim1], abs(d__2));
+/* L60: */
+ }
+ if (unit) {
+ tmp += (d__1 = x[i__ + k * x_dim1], abs(d__1));
+ }
+ } else {
+ if (unit) {
+ tmp += (d__1 = x[i__ + k * x_dim1], abs(d__1));
+ }
+ i__3 = *n;
+ for (j = i__ + ifu; j <= i__3; ++j) {
+ tmp += (d__1 = a[j + i__ * a_dim1], abs(d__1)) * (
+ d__2 = x[j + k * x_dim1], abs(d__2));
+/* L70: */
+ }
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = min(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ d__1 = axbi, d__2 = (*n + 1) * unfl;
+ tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / max(d__1,d__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = max(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of DTRT05 */
+
+} /* dtrt05_ */
diff --git a/TESTING/LIN/dtrt06.c b/TESTING/LIN/dtrt06.c
new file mode 100644
index 0000000..bfd1529
--- /dev/null
+++ b/TESTING/LIN/dtrt06.c
@@ -0,0 +1,164 @@
+/* dtrt06.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtrt06_(doublereal *rcond, doublereal *rcondc, char *
+ uplo, char *diag, integer *n, doublereal *a, integer *lda, doublereal
+ *work, doublereal *rat)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ doublereal eps, rmin, rmax, anorm;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ doublereal bignum;
+ extern doublereal dlantr_(char *, char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *);
+ doublereal smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTRT06 computes a test ratio comparing RCOND (the reciprocal */
+/* condition number of a triangular matrix A) and RCONDC, the estimate */
+/* computed by DTRCON. Information about the triangular matrix A is */
+/* used if one estimate is zero and the other is non-zero to decide if */
+/* underflow in the estimate is justified. */
+
+/* Arguments */
+/* ========= */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number obtained by */
+/* forming the explicit inverse of the matrix A and computing */
+/* RCOND = 1/( norm(A) * norm(inv(A)) ). */
+
+/* RCONDC (input) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number computed by */
+/* DTRCON. */
+
+/* UPLO (input) CHARACTER */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RAT (output) DOUBLE PRECISION */
+/* The test ratio. If both RCOND and RCONDC are nonzero, */
+/* RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1. */
+/* If RAT = 0, the two estimates are exactly the same. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ eps = dlamch_("Epsilon");
+ rmax = max(*rcond,*rcondc);
+ rmin = min(*rcond,*rcondc);
+
+/* Do the easy cases first. */
+
+ if (rmin < 0.) {
+
+/* Invalid value for RCOND or RCONDC, return 1/EPS. */
+
+ *rat = 1. / eps;
+
+ } else if (rmin > 0.) {
+
+/* Both estimates are positive, return RMAX/RMIN - 1. */
+
+ *rat = rmax / rmin - 1.;
+
+ } else if (rmax == 0.) {
+
+/* Both estimates zero. */
+
+ *rat = 0.;
+
+ } else {
+
+/* One estimate is zero, the other is non-zero. If the matrix is */
+/* ill-conditioned, return the nonzero estimate multiplied by */
+/* 1/EPS; if the matrix is badly scaled, return the nonzero */
+/* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum */
+/* element in absolute value in A. */
+
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ anorm = dlantr_("M", uplo, diag, n, n, &a[a_offset], lda, &work[1]);
+
+/* Computing MIN */
+ d__1 = bignum / max(1.,anorm), d__2 = 1. / eps;
+ *rat = rmax * min(d__1,d__2);
+ }
+
+ return 0;
+
+/* End of DTRT06 */
+
+} /* dtrt06_ */
diff --git a/TESTING/LIN/dtzt01.c b/TESTING/LIN/dtzt01.c
new file mode 100644
index 0000000..a8106ad
--- /dev/null
+++ b/TESTING/LIN/dtzt01.c
@@ -0,0 +1,175 @@
+/* dtzt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static doublereal c_b6 = 0.;
+static doublereal c_b13 = -1.;
+static integer c__1 = 1;
+
+doublereal dtzt01_(integer *m, integer *n, doublereal *a, doublereal *af,
+ integer *lda, doublereal *tau, doublereal *work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2;
+ doublereal ret_val;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal norma;
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *);
+ doublereal rwork[1];
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *), dlatzm_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTZT01 returns */
+/* || A - R*Q || / ( M * eps * ||A|| ) */
+/* for an upper trapezoidal A that was factored with DTZRQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices A and AF. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and AF. */
+
+/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The original upper trapezoidal M by N matrix A. */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The output of DTZRQF for input matrix A. */
+/* The lower triangle is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A and AF. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (M) */
+/* Details of the Householder transformations as returned by */
+/* DTZRQF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= m*n + m. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ if (*lwork < *m * *n + *m) {
+ xerbla_("DTZT01", &c__8);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return ret_val;
+ }
+
+ norma = dlange_("One-norm", m, n, &a[a_offset], lda, rwork);
+
+/* Copy upper triangle R */
+
+ dlaset_("Full", m, n, &c_b6, &c_b6, &work[1], m);
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[(j - 1) * *m + i__] = af[i__ + j * af_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* R = R * P(1) * ... *P(m) */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n - *m + 1;
+ dlatzm_("Right", &i__, &i__2, &af[i__ + (*m + 1) * af_dim1], lda, &
+ tau[i__], &work[(i__ - 1) * *m + 1], &work[*m * *m + 1], m, &
+ work[*m * *n + 1]);
+/* L30: */
+ }
+
+/* R = R - A */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ daxpy_(m, &c_b13, &a[i__ * a_dim1 + 1], &c__1, &work[(i__ - 1) * *m +
+ 1], &c__1);
+/* L40: */
+ }
+
+ ret_val = dlange_("One-norm", m, n, &work[1], m, rwork);
+
+ ret_val /= dlamch_("Epsilon") * (doublereal) max(*m,*n);
+ if (norma != 0.) {
+ ret_val /= norma;
+ }
+
+ return ret_val;
+
+/* End of DTZT01 */
+
+} /* dtzt01_ */
diff --git a/TESTING/LIN/dtzt02.c b/TESTING/LIN/dtzt02.c
new file mode 100644
index 0000000..d40c71c
--- /dev/null
+++ b/TESTING/LIN/dtzt02.c
@@ -0,0 +1,156 @@
+/* dtzt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__7 = 7;
+static doublereal c_b5 = 0.;
+static doublereal c_b6 = 1.;
+
+doublereal dtzt02_(integer *m, integer *n, doublereal *af, integer *lda,
+ doublereal *tau, doublereal *work, integer *lwork)
+{
+ /* System generated locals */
+ integer af_dim1, af_offset, i__1, i__2;
+ doublereal ret_val;
+
+ /* Local variables */
+ integer i__;
+ doublereal rwork[1];
+ extern doublereal dlamch_(char *), dlange_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *);
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *), dlatzm_(char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DTZT02 returns */
+/* || I - Q'*Q || / ( M * eps) */
+/* where the matrix Q is defined by the Householder transformations */
+/* generated by DTZRQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix AF. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix AF. */
+
+/* AF (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The output of DTZRQF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array AF. */
+
+/* TAU (input) DOUBLE PRECISION array, dimension (M) */
+/* Details of the Householder transformations as returned by */
+/* DTZRQF. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* length of WORK array. Must be >= N*N+N */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ if (*lwork < *n * *n + *n) {
+ xerbla_("DTZT02", &c__7);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return ret_val;
+ }
+
+/* Q := I */
+
+ dlaset_("Full", n, n, &c_b5, &c_b6, &work[1], n);
+
+/* Q := P(1) * ... * P(m) * Q */
+
+ for (i__ = *m; i__ >= 1; --i__) {
+ i__1 = *n - *m + 1;
+ dlatzm_("Left", &i__1, n, &af[i__ + (*m + 1) * af_dim1], lda, &tau[
+ i__], &work[i__], &work[*m + 1], n, &work[*n * *n + 1]);
+/* L10: */
+ }
+
+/* Q := P(m) * ... * P(1) * Q */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n - *m + 1;
+ dlatzm_("Left", &i__2, n, &af[i__ + (*m + 1) * af_dim1], lda, &tau[
+ i__], &work[i__], &work[*m + 1], n, &work[*n * *n + 1]);
+/* L20: */
+ }
+
+/* Q := Q - I */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[(i__ - 1) * *n + i__] += -1.;
+/* L30: */
+ }
+
+ ret_val = dlange_("One-norm", n, n, &work[1], n, rwork) / (
+ dlamch_("Epsilon") * (doublereal) max(*m,*n));
+ return ret_val;
+
+/* End of DTZT02 */
+
+} /* dtzt02_ */
diff --git a/TESTING/LIN/icopy.c b/TESTING/LIN/icopy.c
new file mode 100644
index 0000000..2d94286
--- /dev/null
+++ b/TESTING/LIN/icopy.c
@@ -0,0 +1,132 @@
+/* icopy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int icopy_(integer *n, integer *sx, integer *incx, integer *
+ sy, integer *incy)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, m, ix, iy, mp1;
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ICOPY copies an integer vector x to an integer vector y. */
+/* Uses unrolled loops for increments equal to 1. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The length of the vectors SX and SY. */
+
+/* SX (input) INTEGER array, dimension (1+(N-1)*abs(INCX)) */
+/* The vector X. */
+
+/* INCX (input) INTEGER */
+/* The spacing between consecutive elements of SX. */
+
+/* SY (output) INTEGER array, dimension (1+(N-1)*abs(INCY)) */
+/* The vector Y. */
+
+/* INCY (input) INTEGER */
+/* The spacing between consecutive elements of SY. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --sy;
+ --sx;
+
+ /* Function Body */
+ if (*n <= 0) {
+ return 0;
+ }
+ if (*incx == 1 && *incy == 1) {
+ goto L20;
+ }
+
+/* Code for unequal increments or equal increments not equal to 1 */
+
+ ix = 1;
+ iy = 1;
+ if (*incx < 0) {
+ ix = (-(*n) + 1) * *incx + 1;
+ }
+ if (*incy < 0) {
+ iy = (-(*n) + 1) * *incy + 1;
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sy[iy] = sx[ix];
+ ix += *incx;
+ iy += *incy;
+/* L10: */
+ }
+ return 0;
+
+/* Code for both increments equal to 1 */
+
+/* Clean-up loop */
+
+L20:
+ m = *n % 7;
+ if (m == 0) {
+ goto L40;
+ }
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sy[i__] = sx[i__];
+/* L30: */
+ }
+ if (*n < 7) {
+ return 0;
+ }
+L40:
+ mp1 = m + 1;
+ i__1 = *n;
+ for (i__ = mp1; i__ <= i__1; i__ += 7) {
+ sy[i__] = sx[i__];
+ sy[i__ + 1] = sx[i__ + 1];
+ sy[i__ + 2] = sx[i__ + 2];
+ sy[i__ + 3] = sx[i__ + 3];
+ sy[i__ + 4] = sx[i__ + 4];
+ sy[i__ + 5] = sx[i__ + 5];
+ sy[i__ + 6] = sx[i__ + 6];
+/* L50: */
+ }
+ return 0;
+
+/* End of ICOPY */
+
+} /* icopy_ */
diff --git a/TESTING/LIN/ilaenv.c b/TESTING/LIN/ilaenv.c
new file mode 100644
index 0000000..4b799c3
--- /dev/null
+++ b/TESTING/LIN/ilaenv.c
@@ -0,0 +1,194 @@
+/* ilaenv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer iparms[100];
+} claenv_;
+
+#define claenv_1 claenv_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b3 = 0.f;
+static real c_b4 = 1.f;
+static integer c__0 = 0;
+
+integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1,
+ integer *n2, integer *n3, integer *n4)
+{
+ /* System generated locals */
+ integer ret_val;
+
+ /* Local variables */
+ extern integer ieeeck_(integer *, real *, real *);
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ILAENV returns problem-dependent parameters for the local */
+/* environment. See ISPEC for a description of the parameters. */
+
+/* In this version, the problem-dependent parameters are contained in */
+/* the integer array IPARMS in the common block CLAENV and the value */
+/* with index ISPEC is copied to ILAENV. This version of ILAENV is */
+/* to be used in conjunction with XLAENV in TESTING and TIMING. */
+
+/* Arguments */
+/* ========= */
+
+/* ISPEC (input) INTEGER */
+/* Specifies the parameter to be returned as the value of */
+/* ILAENV. */
+/* = 1: the optimal blocksize; if this value is 1, an unblocked */
+/* algorithm will give the best performance. */
+/* = 2: the minimum block size for which the block routine */
+/* should be used; if the usable block size is less than */
+/* this value, an unblocked routine should be used. */
+/* = 3: the crossover point (in a block routine, for N less */
+/* than this value, an unblocked routine should be used) */
+/* = 4: the number of shifts, used in the nonsymmetric */
+/* eigenvalue routines */
+/* = 5: the minimum column dimension for blocking to be used; */
+/* rectangular blocks must have dimension at least k by m, */
+/* where k is given by ILAENV(2,...) and m by ILAENV(5,...) */
+/* = 6: the crossover point for the SVD (when reducing an m by n */
+/* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds */
+/* this value, a QR factorization is used first to reduce */
+/* the matrix to a triangular form.) */
+/* = 7: the number of processors */
+/* = 8: the crossover point for the multishift QR and QZ methods */
+/* for nonsymmetric eigenvalue problems. */
+/* = 9: maximum size of the subproblems at the bottom of the */
+/* computation tree in the divide-and-conquer algorithm */
+/* =10: ieee NaN arithmetic can be trusted not to trap */
+/* =11: infinity arithmetic can be trusted not to trap */
+
+/* Other specifications (up to 100) can be added later. */
+
+/* NAME (input) CHARACTER*(*) */
+/* The name of the calling subroutine. */
+
+/* OPTS (input) CHARACTER*(*) */
+/* The character options to the subroutine NAME, concatenated */
+/* into a single character string. For example, UPLO = 'U', */
+/* TRANS = 'T', and DIAG = 'N' for a triangular routine would */
+/* be specified as OPTS = 'UTN'. */
+
+/* N1 (input) INTEGER */
+/* N2 (input) INTEGER */
+/* N3 (input) INTEGER */
+/* N4 (input) INTEGER */
+/* Problem dimensions for the subroutine NAME; these may not all */
+/* be required. */
+
+/* (ILAENV) (output) INTEGER */
+/* >= 0: the value of the parameter specified by ISPEC */
+/* < 0: if ILAENV = -k, the k-th argument had an illegal value. */
+
+/* Further Details */
+/* =============== */
+
+/* The following conventions have been used when calling ILAENV from the */
+/* LAPACK routines: */
+/* 1) OPTS is a concatenation of all of the character options to */
+/* subroutine NAME, in the same order that they appear in the */
+/* argument list for NAME, even if they are not used in determining */
+/* the value of the parameter specified by ISPEC. */
+/* 2) The problem dimensions N1, N2, N3, N4 are specified in the order */
+/* that they appear in the argument list for NAME. N1 is used */
+/* first, N2 second, and so on, and unused problem dimensions are */
+/* passed a value of -1. */
+/* 3) The parameter value returned by ILAENV is checked for validity in */
+/* the calling subroutine. For example, ILAENV is used to retrieve */
+/* the optimal blocksize for STRTRI as follows: */
+
+/* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) */
+/* IF( NB.LE.1 ) NB = MAX( 1, N ) */
+
+/* ===================================================================== */
+
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (*ispec >= 1 && *ispec <= 5) {
+
+/* Return a value from the common block. */
+
+ ret_val = claenv_1.iparms[*ispec - 1];
+
+ } else if (*ispec == 6) {
+
+/* Compute SVD crossover point. */
+
+ ret_val = (integer) ((real) min(*n1,*n2) * 1.6f);
+
+ } else if (*ispec >= 7 && *ispec <= 9) {
+
+/* Return a value from the common block. */
+
+ ret_val = claenv_1.iparms[*ispec - 1];
+
+ } else if (*ispec == 10) {
+
+/* IEEE NaN arithmetic can be trusted not to trap */
+
+/* ILAENV = 0 */
+ ret_val = 1;
+ if (ret_val == 1) {
+ ret_val = ieeeck_(&c__1, &c_b3, &c_b4);
+ }
+
+ } else if (*ispec == 11) {
+
+/* Infinity arithmetic can be trusted not to trap */
+
+/* ILAENV = 0 */
+ ret_val = 1;
+ if (ret_val == 1) {
+ ret_val = ieeeck_(&c__0, &c_b3, &c_b4);
+ }
+
+ } else {
+
+/* Invalid value for ISPEC */
+
+ ret_val = -1;
+ }
+
+ return ret_val;
+
+/* End of ILAENV */
+
+} /* ilaenv_ */
diff --git a/TESTING/LIN/memory_alloc.h b/TESTING/LIN/memory_alloc.h
new file mode 100644
index 0000000..c9041e5
--- /dev/null
+++ b/TESTING/LIN/memory_alloc.h
@@ -0,0 +1,12 @@
+#define salloc3(); errbnds_n__ = (real *)malloc(nrhs*n_err_bnds__*sizeof(real));\
+ errbnds_c__ = (real *)malloc(nrhs*n_err_bnds__*sizeof(real));\
+ berr = (real *)malloc(nrhs*sizeof(real));
+
+#define dalloc3(); errbnds_n__ = (doublereal *)malloc(nrhs*n_err_bnds__*sizeof(doublereal));\
+ errbnds_c__ = (doublereal *)malloc(nrhs*n_err_bnds__*sizeof(doublereal));\
+ berr = (doublereal *)malloc(nrhs*sizeof(doublereal));
+
+#define free3(); free (errbnds_n__);\
+ free (errbnds_c__);\
+ free (berr);
+
diff --git a/TESTING/LIN/schkaa.c b/TESTING/LIN/schkaa.c
new file mode 100644
index 0000000..d07fc8d
--- /dev/null
+++ b/TESTING/LIN/schkaa.c
@@ -0,0 +1,1360 @@
+/* schkaa.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer iparms[100];
+} claenv_;
+
+#define claenv_1 claenv_
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__12 = 12;
+static integer c__0 = 0;
+static integer c__132 = 132;
+static integer c__16 = 16;
+static integer c__100 = 100;
+static integer c__4 = 4;
+static integer c__8 = 8;
+static integer c__2 = 2;
+static integer c__5 = 5;
+static integer c__6 = 6;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Initialized data */
+
+ static real threq = 2.f;
+ static char intstr[10] = "0123456789";
+
+ /* Format strings */
+ static char fmt_9994[] = "(\002 Tests of the REAL LAPACK routines \002,"
+ "/\002 LAPACK VERSION \002,i1,\002.\002,i1,\002.\002,i1,//\002 Th"
+ "e following parameter values will be used:\002)";
+ static char fmt_9996[] = "(\002 Invalid input value: \002,a4,\002=\002,i"
+ "6,\002; must be >=\002,i6)";
+ static char fmt_9995[] = "(\002 Invalid input value: \002,a4,\002=\002,i"
+ "6,\002; must be <=\002,i6)";
+ static char fmt_9993[] = "(4x,a4,\002: \002,10i6,/11x,10i6)";
+ static char fmt_9992[] = "(/\002 Routines pass computational tests if te"
+ "st ratio is \002,\002less than\002,f8.2,/)";
+ static char fmt_9999[] = "(/\002 Execution not attempted due to input er"
+ "rors\002)";
+ static char fmt_9991[] = "(\002 Relative machine \002,a,\002 is taken to"
+ " be\002,e16.6)";
+ static char fmt_9990[] = "(/1x,a3,\002: Unrecognized path name\002)";
+ static char fmt_9989[] = "(/1x,a3,\002 routines were not tested\002)";
+ static char fmt_9988[] = "(/1x,a3,\002 driver routines were not teste"
+ "d\002)";
+ static char fmt_9998[] = "(/\002 End of tests\002)";
+ static char fmt_9997[] = "(\002 Total time used = \002,f12.2,\002 seco"
+ "nds\002,/)";
+
+ /* System generated locals */
+ integer i__1, i__2;
+ real r__1;
+ cilist ci__1;
+ cllist cl__1;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), e_rsle(void), s_wsfe(cilist *), do_fio(integer *
+ , char *, ftnlen), e_wsfe(void), do_lio(integer *, integer *,
+ char *, ftnlen);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_rsfe(cilist *), e_rsfe(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer f_clos(cllist *);
+
+ /* Local variables */
+ real a[153384] /* was [21912][7] */, b[8448] /* was [2112][4] */;
+ integer i__, j, k;
+ real s[264];
+ char c1[1], c2[2];
+ real s1, s2;
+ integer ic, la, nb, nm, nn, vers_patch__, vers_major__, vers_minor__, lda,
+ nnb;
+ real eps;
+ integer nns, piv[132], nnb2;
+ char path[3];
+ integer mval[12], nval[12], nrhs;
+ real work[23496] /* was [132][178] */;
+ integer lafac;
+ logical fatal;
+ char aline[72];
+ extern logical lsame_(char *, char *);
+ integer nbval[12], nrank, nmats, nsval[12], nxval[12], iwork[3300];
+ real rwork[692];
+ integer nbval2[12];
+ extern /* Subroutine */ int schkq3_(logical *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, real *,
+ real *, real *, real *, real *, real *, real *, integer *,
+ integer *), schkgb_(logical *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, real *,
+ logical *, real *, integer *, real *, integer *, real *, real *,
+ real *, real *, real *, integer *, integer *), schkge_(logical *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, real *, logical *, integer *, real *, real *
+, real *, real *, real *, real *, real *, real *, integer *,
+ integer *), alareq_(char *, integer *, logical *, integer *,
+ integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int schkpb_(logical *, integer *, integer *,
+ integer *, integer *, integer *, integer *, real *, logical *,
+ integer *, real *, real *, real *, real *, real *, real *, real *,
+ real *, integer *, integer *);
+ extern doublereal second_(void);
+ extern /* Subroutine */ int schkeq_(real *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int schktb_(logical *, integer *, integer *,
+ integer *, integer *, real *, logical *, integer *, real *, real *
+, real *, real *, real *, real *, real *, integer *, integer *),
+ ilaver_(integer *, integer *, integer *), schkgt_(logical *,
+ integer *, integer *, integer *, integer *, real *, logical *,
+ real *, real *, real *, real *, real *, real *, real *, integer *,
+ integer *), schklq_(logical *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, real *,
+ logical *, integer *, real *, real *, real *, real *, real *,
+ real *, real *, real *, real *, real *, real *, integer *,
+ integer *), schkql_(logical *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, real *,
+ logical *, integer *, real *, real *, real *, real *, real *,
+ real *, real *, real *, real *, real *, real *, integer *,
+ integer *), schkpo_(logical *, integer *, integer *, integer *,
+ integer *, integer *, integer *, real *, logical *, integer *,
+ real *, real *, real *, real *, real *, real *, real *, real *,
+ integer *, integer *), schkpp_(logical *, integer *, integer *,
+ integer *, integer *, real *, logical *, integer *, real *, real *
+, real *, real *, real *, real *, real *, real *, integer *,
+ integer *), schkqp_(logical *, integer *, integer *, integer *,
+ integer *, real *, logical *, real *, real *, real *, real *,
+ real *, real *, integer *, integer *), schkps_(logical *, integer
+ *, integer *, integer *, integer *, integer *, integer *, real *,
+ logical *, integer *, real *, real *, real *, integer *, real *,
+ real *, integer *), schkpt_(logical *, integer *, integer *,
+ integer *, integer *, real *, logical *, real *, real *, real *,
+ real *, real *, real *, real *, real *, integer *);
+ real thresh;
+ extern /* Subroutine */ int schkqr_(logical *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ real *, logical *, integer *, real *, real *, real *, real *,
+ real *, real *, real *, real *, real *, real *, real *, integer *,
+ integer *), schkrq_(logical *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, real *,
+ logical *, integer *, real *, real *, real *, real *, real *,
+ real *, real *, real *, real *, real *, real *, integer *,
+ integer *);
+ logical tstchk;
+ extern /* Subroutine */ int schksp_(logical *, integer *, integer *,
+ integer *, integer *, real *, logical *, integer *, real *, real *
+, real *, real *, real *, real *, real *, real *, integer *,
+ integer *), schktp_(logical *, integer *, integer *, integer *,
+ integer *, real *, logical *, integer *, real *, real *, real *,
+ real *, real *, real *, real *, integer *, integer *);
+ logical dotype[30];
+ extern /* Subroutine */ int schksy_(logical *, integer *, integer *,
+ integer *, integer *, integer *, integer *, real *, logical *,
+ integer *, real *, real *, real *, real *, real *, real *, real *,
+ real *, integer *, integer *), schktr_(logical *, integer *,
+ integer *, integer *, integer *, integer *, integer *, real *,
+ logical *, integer *, real *, real *, real *, real *, real *,
+ real *, real *, integer *, integer *), schktz_(logical *, integer
+ *, integer *, integer *, integer *, real *, logical *, real *,
+ real *, real *, real *, real *, real *, integer *), sdrvgb_(
+ logical *, integer *, integer *, integer *, real *, logical *,
+ real *, integer *, real *, integer *, real *, real *, real *,
+ real *, real *, real *, real *, real *, integer *, integer *),
+ sdrvge_(logical *, integer *, integer *, integer *, real *,
+ logical *, integer *, real *, real *, real *, real *, real *,
+ real *, real *, real *, real *, real *, integer *, integer *),
+ sdrvgt_(logical *, integer *, integer *, integer *, real *,
+ logical *, real *, real *, real *, real *, real *, real *, real *,
+ integer *, integer *), sdrvpb_(logical *, integer *, integer *,
+ integer *, real *, logical *, integer *, real *, real *, real *,
+ real *, real *, real *, real *, real *, real *, real *, integer *,
+ integer *), sdrvls_(logical *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ real *, logical *, real *, real *, real *, real *, real *, real *,
+ real *, real *, integer *, integer *), sdrvpo_(logical *,
+ integer *, integer *, integer *, real *, logical *, integer *,
+ real *, real *, real *, real *, real *, real *, real *, real *,
+ real *, real *, integer *, integer *), sdrvpp_(logical *, integer
+ *, integer *, integer *, real *, logical *, integer *, real *,
+ real *, real *, real *, real *, real *, real *, real *, real *,
+ real *, integer *, integer *), sdrvsp_(logical *, integer *,
+ integer *, integer *, real *, logical *, integer *, real *, real *
+, real *, real *, real *, real *, real *, real *, integer *,
+ integer *);
+ integer ntypes;
+ logical tsterr;
+ extern /* Subroutine */ int sdrvpt_(logical *, integer *, integer *,
+ integer *, real *, logical *, real *, real *, real *, real *,
+ real *, real *, real *, real *, integer *);
+ logical tstdrv;
+ extern /* Subroutine */ int sdrvsy_(logical *, integer *, integer *,
+ integer *, real *, logical *, integer *, real *, real *, real *,
+ real *, real *, real *, real *, real *, integer *, integer *);
+ integer rankval[12];
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 5, 0, 0, 0 };
+ static cilist io___10 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___11 = { 0, 5, 0, 0, 0 };
+ static cilist io___13 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___14 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___15 = { 0, 5, 0, 0, 0 };
+ static cilist io___18 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___19 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___20 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___21 = { 0, 5, 0, 0, 0 };
+ static cilist io___23 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___24 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___25 = { 0, 5, 0, 0, 0 };
+ static cilist io___27 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___28 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___29 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___30 = { 0, 5, 0, 0, 0 };
+ static cilist io___32 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___33 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___34 = { 0, 5, 0, 0, 0 };
+ static cilist io___36 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___37 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___38 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___39 = { 0, 5, 0, 0, 0 };
+ static cilist io___41 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___42 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___43 = { 0, 5, 0, 0, 0 };
+ static cilist io___45 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___46 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___51 = { 0, 5, 0, 0, 0 };
+ static cilist io___53 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___54 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___55 = { 0, 5, 0, 0, 0 };
+ static cilist io___57 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___58 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___59 = { 0, 5, 0, 0, 0 };
+ static cilist io___61 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___62 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___63 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___64 = { 0, 5, 0, 0, 0 };
+ static cilist io___66 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___67 = { 0, 5, 0, 0, 0 };
+ static cilist io___69 = { 0, 5, 0, 0, 0 };
+ static cilist io___71 = { 0, 5, 0, 0, 0 };
+ static cilist io___73 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___75 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___76 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___77 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___78 = { 0, 6, 0, 0, 0 };
+ static cilist io___87 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___88 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___96 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___98 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___101 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___102 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___103 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___104 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___105 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___106 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___108 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___109 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___110 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___111 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___112 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___113 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___114 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___115 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___116 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___117 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___118 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___119 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___120 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___121 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___122 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___123 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___124 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___125 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___126 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___127 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___128 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___129 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___130 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___132 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___133 = { 0, 6, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKAA is the main test program for the REAL LAPACK */
+/* linear equation routines */
+
+/* The program must be driven by a short data file. The first 14 records */
+/* specify problem dimensions and program options using list-directed */
+/* input. The remaining lines specify the LAPACK test paths and the */
+/* number of matrix types to use in testing. An annotated example of a */
+/* data file can be obtained by deleting the first 3 characters from the */
+/* following 36 lines: */
+/* Data file for testing REAL LAPACK linear eqn. routines */
+/* 7 Number of values of M */
+/* 0 1 2 3 5 10 16 Values of M (row dimension) */
+/* 7 Number of values of N */
+/* 0 1 2 3 5 10 16 Values of N (column dimension) */
+/* 1 Number of values of NRHS */
+/* 2 Values of NRHS (number of right hand sides) */
+/* 5 Number of values of NB */
+/* 1 3 3 3 20 Values of NB (the blocksize) */
+/* 1 0 5 9 1 Values of NX (crossover point) */
+/* 3 Number of values of RANK */
+/* 30 50 90 Values of rank (as a % of N) */
+/* 20.0 Threshold value of test ratio */
+/* T Put T to test the LAPACK routines */
+/* T Put T to test the driver routines */
+/* T Put T to test the error exits */
+/* SGE 11 List types on next line if 0 < NTYPES < 11 */
+/* SGB 8 List types on next line if 0 < NTYPES < 8 */
+/* SGT 12 List types on next line if 0 < NTYPES < 12 */
+/* SPO 9 List types on next line if 0 < NTYPES < 9 */
+/* SPS 9 List types on next line if 0 < NTYPES < 9 */
+/* 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 */
+/* SSY 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 */
+/* STB 17 List types on next line if 0 < NTYPES < 17 */
+/* SQR 8 List types on next line if 0 < NTYPES < 8 */
+/* SRQ 8 List types on next line if 0 < NTYPES < 8 */
+/* SLQ 8 List types on next line if 0 < NTYPES < 8 */
+/* SQL 8 List types on next line if 0 < NTYPES < 8 */
+/* SQP 6 List types on next line if 0 < NTYPES < 6 */
+/* STZ 3 List types on next line if 0 < NTYPES < 3 */
+/* SLS 6 List types on next line if 0 < NTYPES < 6 */
+/* SEQ */
+
+/* Internal Parameters */
+/* =================== */
+
+/* NMAX INTEGER */
+/* The maximum allowable value for N */
+
+/* MAXIN INTEGER */
+/* The number of different values that can be used for each of */
+/* M, N, NRHS, NB, and NX */
+
+/* MAXRHS INTEGER */
+/* The maximum number of right hand sides */
+
+/* NIN INTEGER */
+/* The unit number for input */
+
+/* NOUT INTEGER */
+/* The unit number for output */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ s1 = second_();
+ lda = 132;
+ fatal = FALSE_;
+
+/* Read a dummy line. */
+
+ s_rsle(&io___6);
+ e_rsle();
+
+/* Report values of parameters. */
+
+ ilaver_(&vers_major__, &vers_minor__, &vers_patch__);
+ s_wsfe(&io___10);
+ do_fio(&c__1, (char *)&vers_major__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_minor__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_patch__, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+/* Read the values of M */
+
+ s_rsle(&io___11);
+ do_lio(&c__3, &c__1, (char *)&nm, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nm < 1) {
+ s_wsfe(&io___13);
+ do_fio(&c__1, " NM ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nm, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nm = 0;
+ fatal = TRUE_;
+ } else if (nm > 12) {
+ s_wsfe(&io___14);
+ do_fio(&c__1, " NM ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nm, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nm = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___15);
+ i__1 = nm;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nm;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (mval[i__ - 1] < 0) {
+ s_wsfe(&io___18);
+ do_fio(&c__1, " M ", (ftnlen)4);
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (mval[i__ - 1] > 132) {
+ s_wsfe(&io___19);
+ do_fio(&c__1, " M ", (ftnlen)4);
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L10: */
+ }
+ if (nm > 0) {
+ s_wsfe(&io___20);
+ do_fio(&c__1, "M ", (ftnlen)4);
+ i__1 = nm;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of N */
+
+ s_rsle(&io___21);
+ do_lio(&c__3, &c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nn < 1) {
+ s_wsfe(&io___23);
+ do_fio(&c__1, " NN ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ } else if (nn > 12) {
+ s_wsfe(&io___24);
+ do_fio(&c__1, " NN ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___25);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nval[i__ - 1] < 0) {
+ s_wsfe(&io___27);
+ do_fio(&c__1, " N ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nval[i__ - 1] > 132) {
+ s_wsfe(&io___28);
+ do_fio(&c__1, " N ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L20: */
+ }
+ if (nn > 0) {
+ s_wsfe(&io___29);
+ do_fio(&c__1, "N ", (ftnlen)4);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of NRHS */
+
+ s_rsle(&io___30);
+ do_lio(&c__3, &c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nns < 1) {
+ s_wsfe(&io___32);
+ do_fio(&c__1, " NNS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nns = 0;
+ fatal = TRUE_;
+ } else if (nns > 12) {
+ s_wsfe(&io___33);
+ do_fio(&c__1, " NNS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nns = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___34);
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nsval[i__ - 1] < 0) {
+ s_wsfe(&io___36);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nsval[i__ - 1] > 16) {
+ s_wsfe(&io___37);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__16, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L30: */
+ }
+ if (nns > 0) {
+ s_wsfe(&io___38);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of NB */
+
+ s_rsle(&io___39);
+ do_lio(&c__3, &c__1, (char *)&nnb, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nnb < 1) {
+ s_wsfe(&io___41);
+ do_fio(&c__1, "NNB ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nnb, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nnb = 0;
+ fatal = TRUE_;
+ } else if (nnb > 12) {
+ s_wsfe(&io___42);
+ do_fio(&c__1, "NNB ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nnb, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nnb = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___43);
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nbval[i__ - 1] < 0) {
+ s_wsfe(&io___45);
+ do_fio(&c__1, " NB ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L40: */
+ }
+ if (nnb > 0) {
+ s_wsfe(&io___46);
+ do_fio(&c__1, "NB ", (ftnlen)4);
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Set NBVAL2 to be the set of unique values of NB */
+
+ nnb2 = 0;
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nb = nbval[i__ - 1];
+ i__2 = nnb2;
+ for (j = 1; j <= i__2; ++j) {
+ if (nb == nbval2[j - 1]) {
+ goto L60;
+ }
+/* L50: */
+ }
+ ++nnb2;
+ nbval2[nnb2 - 1] = nb;
+L60:
+ ;
+ }
+
+/* Read the values of NX */
+
+ s_rsle(&io___51);
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nxval[i__ - 1] < 0) {
+ s_wsfe(&io___53);
+ do_fio(&c__1, " NX ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L70: */
+ }
+ if (nnb > 0) {
+ s_wsfe(&io___54);
+ do_fio(&c__1, "NX ", (ftnlen)4);
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of RANKVAL */
+
+ s_rsle(&io___55);
+ do_lio(&c__3, &c__1, (char *)&nrank, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nn < 1) {
+ s_wsfe(&io___57);
+ do_fio(&c__1, " NRANK ", (ftnlen)7);
+ do_fio(&c__1, (char *)&nrank, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nrank = 0;
+ fatal = TRUE_;
+ } else if (nn > 12) {
+ s_wsfe(&io___58);
+ do_fio(&c__1, " NRANK ", (ftnlen)7);
+ do_fio(&c__1, (char *)&nrank, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nrank = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___59);
+ i__1 = nrank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&rankval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nrank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (rankval[i__ - 1] < 0) {
+ s_wsfe(&io___61);
+ do_fio(&c__1, " RANK ", (ftnlen)7);
+ do_fio(&c__1, (char *)&rankval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (rankval[i__ - 1] > 100) {
+ s_wsfe(&io___62);
+ do_fio(&c__1, " RANK ", (ftnlen)7);
+ do_fio(&c__1, (char *)&rankval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__100, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+ }
+ if (nrank > 0) {
+ s_wsfe(&io___63);
+ do_fio(&c__1, "RANK % OF N", (ftnlen)11);
+ i__1 = nrank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&rankval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the threshold value for the test ratios. */
+
+ s_rsle(&io___64);
+ do_lio(&c__4, &c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_rsle();
+ s_wsfe(&io___66);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_wsfe();
+
+/* Read the flag that indicates whether to test the LAPACK routines. */
+
+ s_rsle(&io___67);
+ do_lio(&c__8, &c__1, (char *)&tstchk, (ftnlen)sizeof(logical));
+ e_rsle();
+
+/* Read the flag that indicates whether to test the driver routines. */
+
+ s_rsle(&io___69);
+ do_lio(&c__8, &c__1, (char *)&tstdrv, (ftnlen)sizeof(logical));
+ e_rsle();
+
+/* Read the flag that indicates whether to test the error exits. */
+
+ s_rsle(&io___71);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+
+ if (fatal) {
+ s_wsfe(&io___73);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Calculate and print the machine dependent constants. */
+
+ eps = slamch_("Underflow threshold");
+ s_wsfe(&io___75);
+ do_fio(&c__1, "underflow", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+ eps = slamch_("Overflow threshold");
+ s_wsfe(&io___76);
+ do_fio(&c__1, "overflow ", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+ eps = slamch_("Epsilon");
+ s_wsfe(&io___77);
+ do_fio(&c__1, "precision", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_wsle(&io___78);
+ e_wsle();
+
+L80:
+
+/* Read a test path and the number of matrix types to use. */
+
+ ci__1.cierr = 0;
+ ci__1.ciend = 1;
+ ci__1.ciunit = 5;
+ ci__1.cifmt = "(A72)";
+ i__1 = s_rsfe(&ci__1);
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = do_fio(&c__1, aline, (ftnlen)72);
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L140;
+ }
+ s_copy(path, aline, (ftnlen)3, (ftnlen)3);
+ nmats = 30;
+ i__ = 3;
+L90:
+ ++i__;
+ if (i__ > 72) {
+ nmats = 30;
+ goto L130;
+ }
+ if (*(unsigned char *)&aline[i__ - 1] == ' ') {
+ goto L90;
+ }
+ nmats = 0;
+L100:
+ *(unsigned char *)c1 = *(unsigned char *)&aline[i__ - 1];
+ for (k = 1; k <= 10; ++k) {
+ if (*(unsigned char *)c1 == *(unsigned char *)&intstr[k - 1]) {
+ ic = k - 1;
+ goto L120;
+ }
+/* L110: */
+ }
+ goto L130;
+L120:
+ nmats = nmats * 10 + ic;
+ ++i__;
+ if (i__ > 72) {
+ goto L130;
+ }
+ goto L100;
+L130:
+ *(unsigned char *)c1 = *(unsigned char *)path;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ nrhs = nsval[0];
+
+/* Check first character for correct precision. */
+
+ if (! lsame_(c1, "Single precision")) {
+ s_wsfe(&io___87);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+ } else if (nmats <= 0) {
+
+/* Check for a positive number of tests requested. */
+
+ s_wsfe(&io___88);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, c2, "GE")) {
+
+/* GE: general matrices */
+
+ ntypes = 11;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ schkge_(dotype, &nm, mval, &nn, nval, &nnb2, nbval2, &nns, nsval,
+ &thresh, &tsterr, &lda, a, &a[21912], &a[43824], b, &b[
+ 2112], &b[4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___96);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ sdrvge_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
+ work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___98);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* GB: general banded matrices */
+
+ la = 43692;
+ lafac = 65472;
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ schkgb_(dotype, &nm, mval, &nn, nval, &nnb2, nbval2, &nns, nsval,
+ &thresh, &tsterr, a, &la, &a[43824], &lafac, b, &b[2112],
+ &b[4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___101);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ sdrvgb_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, a, &la, &a[
+ 43824], &lafac, &a[109560], b, &b[2112], &b[4224], &b[
+ 6336], s, work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___102);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "GT")) {
+
+/* GT: general tridiagonal matrices */
+
+ ntypes = 12;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ schkgt_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, a, &a[
+ 21912], b, &b[2112], &b[4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___103);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ sdrvgt_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, a, &a[21912],
+ b, &b[2112], &b[4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___104);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "PO")) {
+
+/* PO: positive definite matrices */
+
+ ntypes = 9;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ schkpo_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
+ tsterr, &lda, a, &a[21912], &a[43824], b, &b[2112], &b[
+ 4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___105);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ sdrvpo_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
+ work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___106);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "PS")) {
+
+/* PS: positive semi-definite matrices */
+
+ ntypes = 9;
+
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ schkps_(dotype, &nn, nval, &nnb2, nbval2, &nrank, rankval, &
+ thresh, &tsterr, &lda, a, &a[21912], &a[43824], piv, work,
+ rwork, &c__6);
+ } else {
+ s_wsfe(&io___108);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "PP")) {
+
+/* PP: positive definite packed matrices */
+
+ ntypes = 9;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ schkpp_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
+ &a[21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
+ iwork, &c__6);
+ } else {
+ s_wsfe(&io___109);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ sdrvpp_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
+ work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___110);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* PB: positive definite banded matrices */
+
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ schkpb_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
+ tsterr, &lda, a, &a[21912], &a[43824], b, &b[2112], &b[
+ 4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___111);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ sdrvpb_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
+ work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___112);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "PT")) {
+
+/* PT: positive definite tridiagonal matrices */
+
+ ntypes = 12;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ schkpt_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], work, rwork, &
+ c__6);
+ } else {
+ s_wsfe(&io___113);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ sdrvpt_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, a, &a[21912],
+ &a[43824], b, &b[2112], &b[4224], work, rwork, &c__6);
+ } else {
+ s_wsfe(&io___114);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "SY")) {
+
+/* SY: symmetric indefinite matrices */
+
+ ntypes = 10;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ schksy_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
+ tsterr, &lda, a, &a[21912], &a[43824], b, &b[2112], &b[
+ 4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___115);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ sdrvsy_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
+ iwork, &c__6);
+ } else {
+ s_wsfe(&io___116);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "SP")) {
+
+/* SP: symmetric indefinite packed matrices */
+
+ ntypes = 10;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ schksp_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
+ &a[21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
+ iwork, &c__6);
+ } else {
+ s_wsfe(&io___117);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ sdrvsp_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
+ iwork, &c__6);
+ } else {
+ s_wsfe(&io___118);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "TR")) {
+
+/* TR: triangular matrices */
+
+ ntypes = 18;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ schktr_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
+ tsterr, &lda, a, &a[21912], b, &b[2112], &b[4224], work,
+ rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___119);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "TP")) {
+
+/* TP: triangular packed matrices */
+
+ ntypes = 18;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ schktp_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
+ &a[21912], b, &b[2112], &b[4224], work, rwork, iwork, &
+ c__6);
+ } else {
+ s_wsfe(&io___120);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "TB")) {
+
+/* TB: triangular banded matrices */
+
+ ntypes = 17;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ schktb_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
+ &a[21912], b, &b[2112], &b[4224], work, rwork, iwork, &
+ c__6);
+ } else {
+ s_wsfe(&io___121);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "QR")) {
+
+/* QR: QR factorization */
+
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ schkqr_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
+ thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
+ 65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
+ rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___122);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "LQ")) {
+
+/* LQ: LQ factorization */
+
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ schklq_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
+ thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
+ 65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
+ rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___123);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "QL")) {
+
+/* QL: QL factorization */
+
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ schkql_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
+ thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
+ 65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
+ rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___124);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "RQ")) {
+
+/* RQ: RQ factorization */
+
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ schkrq_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
+ thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
+ 65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
+ rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___125);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "QP")) {
+
+/* QP: QR factorization with pivoting */
+
+ ntypes = 6;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ schkqp_(dotype, &nm, mval, &nn, nval, &thresh, &tsterr, a, &a[
+ 21912], b, &b[2112], &b[4224], work, iwork, &c__6);
+ schkq3_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &thresh,
+ a, &a[21912], b, &b[2112], &b[4224], work, iwork, &c__6);
+ } else {
+ s_wsfe(&io___126);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "TZ")) {
+
+/* TZ: Trapezoidal matrix */
+
+ ntypes = 3;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ schktz_(dotype, &nm, mval, &nn, nval, &thresh, &tsterr, a, &a[
+ 21912], b, &b[2112], &b[4224], work, &c__6);
+ } else {
+ s_wsfe(&io___127);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "LS")) {
+
+/* LS: Least squares drivers */
+
+ ntypes = 6;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstdrv) {
+ sdrvls_(dotype, &nm, mval, &nn, nval, &nns, nsval, &nnb, nbval,
+ nxval, &thresh, &tsterr, a, &a[21912], b, &b[2112], &b[
+ 4224], rwork, &rwork[132], work, iwork, &c__6);
+ } else {
+ s_wsfe(&io___128);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "EQ")) {
+
+/* EQ: Equilibration routines for general and positive definite */
+/* matrices (THREQ should be between 2 and 10) */
+
+ if (tstchk) {
+ schkeq_(&threq, &c__6);
+ } else {
+ s_wsfe(&io___129);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else {
+
+ s_wsfe(&io___130);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+/* Go back to get another input line. */
+
+ goto L80;
+
+/* Branch to this line when the last record is read. */
+
+L140:
+ cl__1.cerr = 0;
+ cl__1.cunit = 5;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ s2 = second_();
+ s_wsfe(&io___132);
+ e_wsfe();
+ s_wsfe(&io___133);
+ r__1 = s2 - s1;
+ do_fio(&c__1, (char *)&r__1, (ftnlen)sizeof(real));
+ e_wsfe();
+
+
+/* End of SCHKAA */
+
+ return 0;
+} /* MAIN__ */
+
+/* Main program alias */ int schkaa_ () { MAIN__ (); return 0; }
diff --git a/TESTING/LIN/schkeq.c b/TESTING/LIN/schkeq.c
new file mode 100644
index 0000000..b7b1b7f
--- /dev/null
+++ b/TESTING/LIN/schkeq.c
@@ -0,0 +1,671 @@
+/* schkeq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b7 = 10.f;
+static integer c_n1 = -1;
+static integer c__5 = 5;
+static integer c__13 = 13;
+static integer c__1 = 1;
+
+/* Subroutine */ int schkeq_(real *thresh, integer *nout)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002All tests for \002,a3,\002 routines pa"
+ "ssed the threshold\002)";
+ static char fmt_9998[] = "(\002 SGEEQU failed test with value \002,e10"
+ ".3,\002 exceeding\002,\002 threshold \002,e10.3)";
+ static char fmt_9997[] = "(\002 SGBEQU failed test with value \002,e10"
+ ".3,\002 exceeding\002,\002 threshold \002,e10.3)";
+ static char fmt_9996[] = "(\002 SPOEQU failed test with value \002,e10"
+ ".3,\002 exceeding\002,\002 threshold \002,e10.3)";
+ static char fmt_9995[] = "(\002 SPPEQU failed test with value \002,e10"
+ ".3,\002 exceeding\002,\002 threshold \002,e10.3)";
+ static char fmt_9994[] = "(\002 SPBEQU failed test with value \002,e10"
+ ".3,\002 exceeding\002,\002 threshold \002,e10.3)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double pow_ri(real *, integer *);
+ integer pow_ii(integer *, integer *), s_wsle(cilist *), e_wsle(void),
+ s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ real a[25] /* was [5][5] */, c__[5];
+ integer i__, j, m, n;
+ real r__[5], ab[65] /* was [13][5] */, ap[15];
+ integer kl;
+ logical ok;
+ integer ku;
+ real eps, pow[11];
+ integer info;
+ char path[3];
+ real norm, rpow[11], ccond, rcond, rcmin, rcmax, ratio;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int sgbequ_(integer *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ real *, integer *), sgeequ_(integer *, integer *, real *, integer
+ *, real *, real *, real *, real *, real *, integer *), spbequ_(
+ char *, integer *, integer *, real *, integer *, real *, real *,
+ real *, integer *);
+ real reslts[5];
+ extern /* Subroutine */ int spoequ_(integer *, real *, integer *, real *,
+ real *, real *, integer *), sppequ_(char *, integer *, real *,
+ real *, real *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___25 = { 0, 0, 0, 0, 0 };
+ static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKEQ tests SGEEQU, SGBEQU, SPOEQU, SPPEQU and SPBEQU */
+
+/* Arguments */
+/* ========= */
+
+/* THRESH (input) REAL */
+/* Threshold for testing routines. Should be between 2 and 10. */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "EQ", (ftnlen)2, (ftnlen)2);
+
+ eps = slamch_("P");
+ for (i__ = 1; i__ <= 5; ++i__) {
+ reslts[i__ - 1] = 0.f;
+/* L10: */
+ }
+ for (i__ = 1; i__ <= 11; ++i__) {
+ i__1 = i__ - 1;
+ pow[i__ - 1] = pow_ri(&c_b7, &i__1);
+ rpow[i__ - 1] = 1.f / pow[i__ - 1];
+/* L20: */
+ }
+
+/* Test SGEEQU */
+
+ for (n = 0; n <= 5; ++n) {
+ for (m = 0; m <= 5; ++m) {
+
+ for (j = 1; j <= 5; ++j) {
+ for (i__ = 1; i__ <= 5; ++i__) {
+ if (i__ <= m && j <= n) {
+ i__1 = i__ + j;
+ a[i__ + j * 5 - 6] = pow[i__ + j] * pow_ii(&c_n1, &
+ i__1);
+ } else {
+ a[i__ + j * 5 - 6] = 0.f;
+ }
+/* L30: */
+ }
+/* L40: */
+ }
+
+ sgeequ_(&m, &n, a, &c__5, r__, c__, &rcond, &ccond, &norm, &info);
+
+ if (info != 0) {
+ reslts[0] = 1.f;
+ } else {
+ if (n != 0 && m != 0) {
+/* Computing MAX */
+ r__2 = reslts[0], r__3 = (r__1 = (rcond - rpow[m - 1]) /
+ rpow[m - 1], dabs(r__1));
+ reslts[0] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = reslts[0], r__3 = (r__1 = (ccond - rpow[n - 1]) /
+ rpow[n - 1], dabs(r__1));
+ reslts[0] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = reslts[0], r__3 = (r__1 = (norm - pow[n + m]) /
+ pow[n + m], dabs(r__1));
+ reslts[0] = dmax(r__2,r__3);
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = reslts[0], r__3 = (r__1 = (r__[i__ - 1] - rpow[
+ i__ + n]) / rpow[i__ + n], dabs(r__1));
+ reslts[0] = dmax(r__2,r__3);
+/* L50: */
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ r__2 = reslts[0], r__3 = (r__1 = (c__[j - 1] - pow[n
+ - j]) / pow[n - j], dabs(r__1));
+ reslts[0] = dmax(r__2,r__3);
+/* L60: */
+ }
+ }
+ }
+
+/* L70: */
+ }
+/* L80: */
+ }
+
+/* Test with zero rows and columns */
+
+ for (j = 1; j <= 5; ++j) {
+ a[j * 5 - 2] = 0.f;
+/* L90: */
+ }
+ sgeequ_(&c__5, &c__5, a, &c__5, r__, c__, &rcond, &ccond, &norm, &info);
+ if (info != 4) {
+ reslts[0] = 1.f;
+ }
+
+ for (j = 1; j <= 5; ++j) {
+ a[j * 5 - 2] = 1.f;
+/* L100: */
+ }
+ for (i__ = 1; i__ <= 5; ++i__) {
+ a[i__ + 14] = 0.f;
+/* L110: */
+ }
+ sgeequ_(&c__5, &c__5, a, &c__5, r__, c__, &rcond, &ccond, &norm, &info);
+ if (info != 9) {
+ reslts[0] = 1.f;
+ }
+ reslts[0] /= eps;
+
+/* Test SGBEQU */
+
+ for (n = 0; n <= 5; ++n) {
+ for (m = 0; m <= 5; ++m) {
+/* Computing MAX */
+ i__2 = m - 1;
+ i__1 = max(i__2,0);
+ for (kl = 0; kl <= i__1; ++kl) {
+/* Computing MAX */
+ i__3 = n - 1;
+ i__2 = max(i__3,0);
+ for (ku = 0; ku <= i__2; ++ku) {
+
+ for (j = 1; j <= 5; ++j) {
+ for (i__ = 1; i__ <= 13; ++i__) {
+ ab[i__ + j * 13 - 14] = 0.f;
+/* L120: */
+ }
+/* L130: */
+ }
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = m;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+/* Computing MIN */
+ i__5 = m, i__6 = j + kl;
+/* Computing MAX */
+ i__7 = 1, i__8 = j - ku;
+ if (i__ <= min(i__5,i__6) && i__ >= max(i__7,i__8)
+ && j <= n) {
+ i__5 = i__ + j;
+ ab[ku + 1 + i__ - j + j * 13 - 14] = pow[i__
+ + j] * pow_ii(&c_n1, &i__5);
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+ sgbequ_(&m, &n, &kl, &ku, ab, &c__13, r__, c__, &rcond, &
+ ccond, &norm, &info);
+
+ if (info != 0) {
+ if (! (n + kl < m && info == n + kl + 1 || m + ku < n
+ && info == (m << 1) + ku + 1)) {
+ reslts[1] = 1.f;
+ }
+ } else {
+ if (n != 0 && m != 0) {
+
+ rcmin = r__[0];
+ rcmax = r__[0];
+ i__3 = m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = r__[i__ - 1];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = r__[i__ - 1];
+ rcmax = dmax(r__1,r__2);
+/* L160: */
+ }
+ ratio = rcmin / rcmax;
+/* Computing MAX */
+ r__2 = reslts[1], r__3 = (r__1 = (rcond - ratio) /
+ ratio, dabs(r__1));
+ reslts[1] = dmax(r__2,r__3);
+
+ rcmin = c__[0];
+ rcmax = c__[0];
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ r__1 = rcmin, r__2 = c__[j - 1];
+ rcmin = dmin(r__1,r__2);
+/* Computing MAX */
+ r__1 = rcmax, r__2 = c__[j - 1];
+ rcmax = dmax(r__1,r__2);
+/* L170: */
+ }
+ ratio = rcmin / rcmax;
+/* Computing MAX */
+ r__2 = reslts[1], r__3 = (r__1 = (ccond - ratio) /
+ ratio, dabs(r__1));
+ reslts[1] = dmax(r__2,r__3);
+
+/* Computing MAX */
+ r__2 = reslts[1], r__3 = (r__1 = (norm - pow[n +
+ m]) / pow[n + m], dabs(r__1));
+ reslts[1] = dmax(r__2,r__3);
+ i__3 = m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ rcmax = 0.f;
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ if (i__ <= j + kl && i__ >= j - ku) {
+ ratio = (r__1 = r__[i__ - 1] * pow[
+ i__ + j] * c__[j - 1], dabs(
+ r__1));
+ rcmax = dmax(rcmax,ratio);
+ }
+/* L180: */
+ }
+/* Computing MAX */
+ r__2 = reslts[1], r__3 = (r__1 = 1.f - rcmax,
+ dabs(r__1));
+ reslts[1] = dmax(r__2,r__3);
+/* L190: */
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ rcmax = 0.f;
+ i__4 = m;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ if (i__ <= j + kl && i__ >= j - ku) {
+ ratio = (r__1 = r__[i__ - 1] * pow[
+ i__ + j] * c__[j - 1], dabs(
+ r__1));
+ rcmax = dmax(rcmax,ratio);
+ }
+/* L200: */
+ }
+/* Computing MAX */
+ r__2 = reslts[1], r__3 = (r__1 = 1.f - rcmax,
+ dabs(r__1));
+ reslts[1] = dmax(r__2,r__3);
+/* L210: */
+ }
+ }
+ }
+
+/* L220: */
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+/* L250: */
+ }
+ reslts[1] /= eps;
+
+/* Test SPOEQU */
+
+ for (n = 0; n <= 5; ++n) {
+
+ for (i__ = 1; i__ <= 5; ++i__) {
+ for (j = 1; j <= 5; ++j) {
+ if (i__ <= n && j == i__) {
+ i__1 = i__ + j;
+ a[i__ + j * 5 - 6] = pow[i__ + j] * pow_ii(&c_n1, &i__1);
+ } else {
+ a[i__ + j * 5 - 6] = 0.f;
+ }
+/* L260: */
+ }
+/* L270: */
+ }
+
+ spoequ_(&n, a, &c__5, r__, &rcond, &norm, &info);
+
+ if (info != 0) {
+ reslts[2] = 1.f;
+ } else {
+ if (n != 0) {
+/* Computing MAX */
+ r__2 = reslts[2], r__3 = (r__1 = (rcond - rpow[n - 1]) / rpow[
+ n - 1], dabs(r__1));
+ reslts[2] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = reslts[2], r__3 = (r__1 = (norm - pow[n * 2]) / pow[n *
+ 2], dabs(r__1));
+ reslts[2] = dmax(r__2,r__3);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = reslts[2], r__3 = (r__1 = (r__[i__ - 1] - rpow[i__]
+ ) / rpow[i__], dabs(r__1));
+ reslts[2] = dmax(r__2,r__3);
+/* L280: */
+ }
+ }
+ }
+/* L290: */
+ }
+ a[18] = -1.f;
+ spoequ_(&c__5, a, &c__5, r__, &rcond, &norm, &info);
+ if (info != 4) {
+ reslts[2] = 1.f;
+ }
+ reslts[2] /= eps;
+
+/* Test SPPEQU */
+
+ for (n = 0; n <= 5; ++n) {
+
+/* Upper triangular packed storage */
+
+ i__1 = n * (n + 1) / 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ap[i__ - 1] = 0.f;
+/* L300: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ap[i__ * (i__ + 1) / 2 - 1] = pow[i__ * 2];
+/* L310: */
+ }
+
+ sppequ_("U", &n, ap, r__, &rcond, &norm, &info);
+
+ if (info != 0) {
+ reslts[3] = 1.f;
+ } else {
+ if (n != 0) {
+/* Computing MAX */
+ r__2 = reslts[3], r__3 = (r__1 = (rcond - rpow[n - 1]) / rpow[
+ n - 1], dabs(r__1));
+ reslts[3] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = reslts[3], r__3 = (r__1 = (norm - pow[n * 2]) / pow[n *
+ 2], dabs(r__1));
+ reslts[3] = dmax(r__2,r__3);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = reslts[3], r__3 = (r__1 = (r__[i__ - 1] - rpow[i__]
+ ) / rpow[i__], dabs(r__1));
+ reslts[3] = dmax(r__2,r__3);
+/* L320: */
+ }
+ }
+ }
+
+/* Lower triangular packed storage */
+
+ i__1 = n * (n + 1) / 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ap[i__ - 1] = 0.f;
+/* L330: */
+ }
+ j = 1;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ ap[j - 1] = pow[i__ * 2];
+ j += n - i__ + 1;
+/* L340: */
+ }
+
+ sppequ_("L", &n, ap, r__, &rcond, &norm, &info);
+
+ if (info != 0) {
+ reslts[3] = 1.f;
+ } else {
+ if (n != 0) {
+/* Computing MAX */
+ r__2 = reslts[3], r__3 = (r__1 = (rcond - rpow[n - 1]) / rpow[
+ n - 1], dabs(r__1));
+ reslts[3] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = reslts[3], r__3 = (r__1 = (norm - pow[n * 2]) / pow[n *
+ 2], dabs(r__1));
+ reslts[3] = dmax(r__2,r__3);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = reslts[3], r__3 = (r__1 = (r__[i__ - 1] - rpow[i__]
+ ) / rpow[i__], dabs(r__1));
+ reslts[3] = dmax(r__2,r__3);
+/* L350: */
+ }
+ }
+ }
+
+/* L360: */
+ }
+ i__ = 13;
+ ap[i__ - 1] = -1.f;
+ sppequ_("L", &c__5, ap, r__, &rcond, &norm, &info);
+ if (info != 4) {
+ reslts[3] = 1.f;
+ }
+ reslts[3] /= eps;
+
+/* Test SPBEQU */
+
+ for (n = 0; n <= 5; ++n) {
+/* Computing MAX */
+ i__2 = n - 1;
+ i__1 = max(i__2,0);
+ for (kl = 0; kl <= i__1; ++kl) {
+
+/* Test upper triangular storage */
+
+ for (j = 1; j <= 5; ++j) {
+ for (i__ = 1; i__ <= 13; ++i__) {
+ ab[i__ + j * 13 - 14] = 0.f;
+/* L370: */
+ }
+/* L380: */
+ }
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ ab[kl + 1 + j * 13 - 14] = pow[j * 2];
+/* L390: */
+ }
+
+ spbequ_("U", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
+
+ if (info != 0) {
+ reslts[4] = 1.f;
+ } else {
+ if (n != 0) {
+/* Computing MAX */
+ r__2 = reslts[4], r__3 = (r__1 = (rcond - rpow[n - 1]) /
+ rpow[n - 1], dabs(r__1));
+ reslts[4] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = reslts[4], r__3 = (r__1 = (norm - pow[n * 2]) /
+ pow[n * 2], dabs(r__1));
+ reslts[4] = dmax(r__2,r__3);
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = reslts[4], r__3 = (r__1 = (r__[i__ - 1] - rpow[
+ i__]) / rpow[i__], dabs(r__1));
+ reslts[4] = dmax(r__2,r__3);
+/* L400: */
+ }
+ }
+ }
+ if (n != 0) {
+/* Computing MAX */
+ i__2 = n - 1;
+ ab[kl + 1 + max(i__2,1) * 13 - 14] = -1.f;
+ spbequ_("U", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
+/* Computing MAX */
+ i__2 = n - 1;
+ if (info != max(i__2,1)) {
+ reslts[4] = 1.f;
+ }
+ }
+
+/* Test lower triangular storage */
+
+ for (j = 1; j <= 5; ++j) {
+ for (i__ = 1; i__ <= 13; ++i__) {
+ ab[i__ + j * 13 - 14] = 0.f;
+/* L410: */
+ }
+/* L420: */
+ }
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ ab[j * 13 - 13] = pow[j * 2];
+/* L430: */
+ }
+
+ spbequ_("L", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
+
+ if (info != 0) {
+ reslts[4] = 1.f;
+ } else {
+ if (n != 0) {
+/* Computing MAX */
+ r__2 = reslts[4], r__3 = (r__1 = (rcond - rpow[n - 1]) /
+ rpow[n - 1], dabs(r__1));
+ reslts[4] = dmax(r__2,r__3);
+/* Computing MAX */
+ r__2 = reslts[4], r__3 = (r__1 = (norm - pow[n * 2]) /
+ pow[n * 2], dabs(r__1));
+ reslts[4] = dmax(r__2,r__3);
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = reslts[4], r__3 = (r__1 = (r__[i__ - 1] - rpow[
+ i__]) / rpow[i__], dabs(r__1));
+ reslts[4] = dmax(r__2,r__3);
+/* L440: */
+ }
+ }
+ }
+ if (n != 0) {
+/* Computing MAX */
+ i__2 = n - 1;
+ ab[max(i__2,1) * 13 - 13] = -1.f;
+ spbequ_("L", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
+/* Computing MAX */
+ i__2 = n - 1;
+ if (info != max(i__2,1)) {
+ reslts[4] = 1.f;
+ }
+ }
+/* L450: */
+ }
+/* L460: */
+ }
+ reslts[4] /= eps;
+ ok = reslts[0] <= *thresh && reslts[1] <= *thresh && reslts[2] <= *thresh
+ && reslts[3] <= *thresh && reslts[4] <= *thresh;
+ io___25.ciunit = *nout;
+ s_wsle(&io___25);
+ e_wsle();
+ if (ok) {
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (reslts[0] > *thresh) {
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__1, (char *)&reslts[0], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ if (reslts[1] > *thresh) {
+ io___28.ciunit = *nout;
+ s_wsfe(&io___28);
+ do_fio(&c__1, (char *)&reslts[1], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ if (reslts[2] > *thresh) {
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ do_fio(&c__1, (char *)&reslts[2], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ if (reslts[3] > *thresh) {
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&reslts[3], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ if (reslts[4] > *thresh) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&reslts[4], (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ }
+ return 0;
+
+/* End of SCHKEQ */
+
+} /* schkeq_ */
diff --git a/TESTING/LIN/schkgb.c b/TESTING/LIN/schkgb.c
new file mode 100644
index 0000000..8fbe16f
--- /dev/null
+++ b/TESTING/LIN/schkgb.c
@@ -0,0 +1,867 @@
+/* schkgb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static real c_b63 = 0.f;
+static real c_b64 = 1.f;
+static integer c__7 = 7;
+
+/* Subroutine */ int schkgb_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nns, integer *nsval, real *thresh, logical *tsterr, real *a, integer *
+ la, real *afac, integer *lafac, real *b, real *x, real *xact, real *
+ work, real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 *** In SCHKGB, LA=\002,i5,\002 is too sm"
+ "all for M=\002,i5,\002, N=\002,i5,\002, KL=\002,i4,\002, KU=\002"
+ ",i4,/\002 ==> Increase LA to at least \002,i5)";
+ static char fmt_9998[] = "(\002 *** In SCHKGB, LAFAC=\002,i5,\002 is too"
+ " small for M=\002,i5,\002, N=\002,i5,\002, KL=\002,i4,\002, KU"
+ "=\002,i4,/\002 ==> Increase LAFAC to at least \002,i5)";
+ static char fmt_9997[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, KL="
+ "\002,i5,\002, KU=\002,i5,\002, NB =\002,i4,\002, type \002,i1"
+ ",\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9996[] = "(\002 TRANS='\002,a1,\002', N=\002,i5,\002, "
+ "KL=\002,i5,\002, KU=\002,i5,\002, NRHS=\002,i3,\002, type \002,i"
+ "1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9995[] = "(\002 NORM ='\002,a1,\002', N=\002,i5,\002, "
+ "KL=\002,i5,\002, KU=\002,i5,\002,\002,10x,\002 type \002,i1,\002"
+ ", test(\002,i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10,
+ i__11;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, m, n, i1, i2, nb, im, in, kl, ku, lda, ldb, inb, ikl,
+ nkl, iku, nku, ioff, mode, koff, imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char norm[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int sgbt01_(integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *, real *
+, real *), sgbt02_(char *, integer *, integer *, integer *,
+ integer *, integer *, real *, integer *, real *, integer *, real *
+, integer *, real *), sgbt05_(char *, integer *, integer *
+, integer *, integer *, real *, integer *, real *, integer *,
+ real *, integer *, real *, integer *, real *, real *, real *);
+ real rcond;
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *);
+ integer nimat, klval[4];
+ extern doublereal sget06_(real *, real *);
+ real anorm;
+ integer itran, kuval[4];
+ char trans[1];
+ integer izero, nerrs;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+);
+ integer ldafac;
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ extern doublereal slangb_(char *, integer *, integer *, integer *, real *,
+ integer *, real *);
+ real rcondc;
+ extern doublereal slange_(char *, integer *, integer *, real *, integer *,
+ real *);
+ extern /* Subroutine */ int sgbcon_(char *, integer *, integer *, integer
+ *, real *, integer *, integer *, real *, real *, real *, integer *
+, integer *);
+ real rcondi;
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ real cndnum, anormi, rcondo;
+ extern /* Subroutine */ int serrge_(char *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int sgbrfs_(char *, integer *, integer *, integer
+ *, integer *, real *, integer *, real *, integer *, integer *,
+ real *, integer *, real *, integer *, real *, real *, real *,
+ integer *, integer *), sgbtrf_(integer *, integer *,
+ integer *, integer *, real *, integer *, integer *, integer *);
+ logical trfcon;
+ real anormo;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, integer *, integer *), slaset_(
+ char *, integer *, integer *, real *, real *, real *, integer *), xlaenv_(integer *, integer *), slatms_(integer *,
+ integer *, char *, integer *, char *, real *, integer *, real *,
+ real *, integer *, integer *, char *, real *, integer *, real *,
+ integer *), sgbtrs_(char *, integer *,
+ integer *, integer *, integer *, real *, integer *, integer *,
+ real *, integer *, integer *);
+ real result[7];
+
+ /* Fortran I/O blocks */
+ static cilist io___25 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___26 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKGB tests SGBTRF, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) REAL array, dimension (LA) */
+
+/* LA (input) INTEGER */
+/* The length of the array A. LA >= (KLMAX+KUMAX+1)*NMAX */
+/* where KLMAX is the largest entry in the local array KLVAL, */
+/* KUMAX is the largest entry in the local array KUVAL and */
+/* NMAX is the largest entry in the input array NVAL. */
+
+/* AFAC (workspace) REAL array, dimension (LAFAC) */
+
+/* LAFAC (input) INTEGER */
+/* The length of the array AFAC. LAFAC >= (2*KLMAX+KUMAX+1)*NMAX */
+/* where KLMAX is the largest entry in the local array KLVAL, */
+/* KUMAX is the largest entry in the local array KUVAL and */
+/* NMAX is the largest entry in the input array NVAL. */
+
+/* B (workspace) REAL array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(3,NSMAX,NMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --afac;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "GB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrge_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+/* Initialize the first value for the lower and upper bandwidths. */
+
+ klval[0] = 0;
+ kuval[0] = 0;
+
+/* Do for each value of M in MVAL */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Set values to use for the lower bandwidth. */
+
+ klval[1] = m + (m + 1) / 4;
+
+/* KLVAL( 2 ) = MAX( M-1, 0 ) */
+
+ klval[2] = (m * 3 - 1) / 4;
+ klval[3] = (m + 1) / 4;
+
+/* Do for each value of N in NVAL */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ *(unsigned char *)xtype = 'N';
+
+/* Set values to use for the upper bandwidth. */
+
+ kuval[1] = n + (n + 1) / 4;
+
+/* KUVAL( 2 ) = MAX( N-1, 0 ) */
+
+ kuval[2] = (n * 3 - 1) / 4;
+ kuval[3] = (n + 1) / 4;
+
+/* Set limits on the number of loop iterations. */
+
+/* Computing MIN */
+ i__3 = m + 1;
+ nkl = min(i__3,4);
+ if (n == 0) {
+ nkl = 2;
+ }
+/* Computing MIN */
+ i__3 = n + 1;
+ nku = min(i__3,4);
+ if (m == 0) {
+ nku = 2;
+ }
+ nimat = 8;
+ if (m <= 0 || n <= 0) {
+ nimat = 1;
+ }
+
+ i__3 = nkl;
+ for (ikl = 1; ikl <= i__3; ++ikl) {
+
+/* Do for KL = 0, (5*M+1)/4, (3M-1)/4, and (M+1)/4. This */
+/* order makes it easier to skip redundant values for small */
+/* values of M. */
+
+ kl = klval[ikl - 1];
+ i__4 = nku;
+ for (iku = 1; iku <= i__4; ++iku) {
+
+/* Do for KU = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This */
+/* order makes it easier to skip redundant values for */
+/* small values of N. */
+
+ ku = kuval[iku - 1];
+
+/* Check that A and AFAC are big enough to generate this */
+/* matrix. */
+
+ lda = kl + ku + 1;
+ ldafac = (kl << 1) + ku + 1;
+ if (lda * n > *la || ldafac * n > *lafac) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ if (n * (kl + ku + 1) > *la) {
+ io___25.ciunit = *nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, (char *)&(*la), (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)
+ );
+ i__5 = n * (kl + ku + 1);
+ do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ if (n * ((kl << 1) + ku + 1) > *lafac) {
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, (char *)&(*lafac), (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)
+ );
+ i__5 = n * ((kl << 1) + ku + 1);
+ do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ goto L130;
+ }
+
+ i__5 = nimat;
+ for (imat = 1; imat <= i__5; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+/* Skip types 2, 3, or 4 if the matrix size is too */
+/* small. */
+
+ zerot = imat >= 2 && imat <= 4;
+ if (zerot && n < imat - 1) {
+ goto L120;
+ }
+
+ if (! zerot || ! dotype[1]) {
+
+/* Set up parameters with SLATB4 and generate a */
+/* test matrix with SLATMS. */
+
+ slatb4_(path, &imat, &m, &n, type__, &kl, &ku, &
+ anorm, &mode, &cndnum, dist);
+
+/* Computing MAX */
+ i__6 = 1, i__7 = ku + 2 - n;
+ koff = max(i__6,i__7);
+ i__6 = koff - 1;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ a[i__] = 0.f;
+/* L20: */
+ }
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (
+ ftnlen)6);
+ slatms_(&m, &n, dist, iseed, type__, &rwork[1], &
+ mode, &cndnum, &anorm, &kl, &ku, "Z", &a[
+ koff], &lda, &work[1], &info);
+
+/* Check the error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, " ", &m,
+ &n, &kl, &ku, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ goto L120;
+ }
+ } else if (izero > 0) {
+
+/* Use the same matrix for types 3 and 4 as for */
+/* type 2 by copying back the zeroed out column. */
+
+ i__6 = i2 - i1 + 1;
+ scopy_(&i__6, &b[1], &c__1, &a[ioff + i1], &c__1);
+ }
+
+/* For types 2, 3, and 4, zero one or more columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ izero = 0;
+ if (zerot) {
+ if (imat == 2) {
+ izero = 1;
+ } else if (imat == 3) {
+ izero = min(m,n);
+ } else {
+ izero = min(m,n) / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 4) {
+
+/* Store the column to be zeroed out in B. */
+
+/* Computing MAX */
+ i__6 = 1, i__7 = ku + 2 - izero;
+ i1 = max(i__6,i__7);
+/* Computing MIN */
+ i__6 = kl + ku + 1, i__7 = ku + 1 + (m -
+ izero);
+ i2 = min(i__6,i__7);
+ i__6 = i2 - i1 + 1;
+ scopy_(&i__6, &a[ioff + i1], &c__1, &b[1], &
+ c__1);
+
+ i__6 = i2;
+ for (i__ = i1; i__ <= i__6; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L30: */
+ }
+ } else {
+ i__6 = n;
+ for (j = izero; j <= i__6; ++j) {
+/* Computing MAX */
+ i__7 = 1, i__8 = ku + 2 - j;
+/* Computing MIN */
+ i__10 = kl + ku + 1, i__11 = ku + 1 + (m
+ - j);
+ i__9 = min(i__10,i__11);
+ for (i__ = max(i__7,i__8); i__ <= i__9;
+ ++i__) {
+ a[ioff + i__] = 0.f;
+/* L40: */
+ }
+ ioff += lda;
+/* L50: */
+ }
+ }
+ }
+
+/* These lines, if used in place of the calls in the */
+/* loop over INB, cause the code to bomb on a Sun */
+/* SPARCstation. */
+
+/* ANORMO = SLANGB( 'O', N, KL, KU, A, LDA, RWORK ) */
+/* ANORMI = SLANGB( 'I', N, KL, KU, A, LDA, RWORK ) */
+
+/* Do for each blocksize in NBVAL */
+
+ i__6 = *nnb;
+ for (inb = 1; inb <= i__6; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the LU factorization of the band matrix. */
+
+ if (m > 0 && n > 0) {
+ i__9 = kl + ku + 1;
+ slacpy_("Full", &i__9, &n, &a[1], &lda, &afac[
+ kl + 1], &ldafac);
+ }
+ s_copy(srnamc_1.srnamt, "SGBTRF", (ftnlen)32, (
+ ftnlen)6);
+ sgbtrf_(&m, &n, &kl, &ku, &afac[1], &ldafac, &
+ iwork[1], &info);
+
+/* Check error code from SGBTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "SGBTRF", &info, &izero, " ", &
+ m, &n, &kl, &ku, &nb, &imat, &nfail, &
+ nerrs, nout);
+ }
+ trfcon = FALSE_;
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ sgbt01_(&m, &n, &kl, &ku, &a[1], &lda, &afac[1], &
+ ldafac, &iwork[1], &work[1], result);
+
+/* Print information about the tests so far that */
+/* did not pass the threshold. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+/* Skip the remaining tests if this is not the */
+/* first block size or if M .ne. N. */
+
+ if (inb > 1 || m != n) {
+ goto L110;
+ }
+
+ anormo = slangb_("O", &n, &kl, &ku, &a[1], &lda, &
+ rwork[1]);
+ anormi = slangb_("I", &n, &kl, &ku, &a[1], &lda, &
+ rwork[1]);
+
+ if (info == 0) {
+
+/* Form the inverse of A so we can get a good */
+/* estimate of CNDNUM = norm(A) * norm(inv(A)). */
+
+ ldb = max(1,n);
+ slaset_("Full", &n, &n, &c_b63, &c_b64, &work[
+ 1], &ldb);
+ s_copy(srnamc_1.srnamt, "SGBTRS", (ftnlen)32,
+ (ftnlen)6);
+ sgbtrs_("No transpose", &n, &kl, &ku, &n, &
+ afac[1], &ldafac, &iwork[1], &work[1],
+ &ldb, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = slange_("O", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormo <= 0.f || ainvnm <= 0.f) {
+ rcondo = 1.f;
+ } else {
+ rcondo = 1.f / anormo / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number of */
+/* A. */
+
+ ainvnm = slange_("I", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormi <= 0.f || ainvnm <= 0.f) {
+ rcondi = 1.f;
+ } else {
+ rcondi = 1.f / anormi / ainvnm;
+ }
+ } else {
+
+/* Do only the condition estimate if INFO.NE.0. */
+
+ trfcon = TRUE_;
+ rcondo = 0.f;
+ rcondi = 0.f;
+ }
+
+/* Skip the solve tests if the matrix is singular. */
+
+ if (trfcon) {
+ goto L90;
+ }
+
+ i__9 = *nns;
+ for (irhs = 1; irhs <= i__9; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+
+ for (itran = 1; itran <= 3; ++itran) {
+ *(unsigned char *)trans = *(unsigned char
+ *)&transs[itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ *(unsigned char *)norm = 'O';
+ } else {
+ rcondc = rcondi;
+ *(unsigned char *)norm = 'I';
+ }
+
+/* + TEST 2: */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)
+ 32, (ftnlen)6);
+ slarhs_(path, xtype, " ", trans, &n, &n, &
+ kl, &ku, &nrhs, &a[1], &lda, &
+ xact[1], &ldb, &b[1], &ldb, iseed,
+ &info);
+ *(unsigned char *)xtype = 'C';
+ slacpy_("Full", &n, &nrhs, &b[1], &ldb, &
+ x[1], &ldb);
+
+ s_copy(srnamc_1.srnamt, "SGBTRS", (ftnlen)
+ 32, (ftnlen)6);
+ sgbtrs_(trans, &n, &kl, &ku, &nrhs, &afac[
+ 1], &ldafac, &iwork[1], &x[1], &
+ ldb, &info);
+
+/* Check error code from SGBTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "SGBTRS", &info, &c__0,
+ trans, &n, &n, &kl, &ku, &
+ c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ slacpy_("Full", &n, &nrhs, &b[1], &ldb, &
+ work[1], &ldb);
+ sgbt02_(trans, &m, &n, &kl, &ku, &nrhs, &
+ a[1], &lda, &x[1], &ldb, &work[1],
+ &ldb, &result[1]);
+
+/* + TEST 3: */
+/* Check solution from generated exact */
+/* solution. */
+
+ sget04_(&n, &nrhs, &x[1], &ldb, &xact[1],
+ &ldb, &rcondc, &result[2]);
+
+/* + TESTS 4, 5, 6: */
+/* Use iterative refinement to improve the */
+/* solution. */
+
+ s_copy(srnamc_1.srnamt, "SGBRFS", (ftnlen)
+ 32, (ftnlen)6);
+ sgbrfs_(trans, &n, &kl, &ku, &nrhs, &a[1],
+ &lda, &afac[1], &ldafac, &iwork[
+ 1], &b[1], &ldb, &x[1], &ldb, &
+ rwork[1], &rwork[nrhs + 1], &work[
+ 1], &iwork[n + 1], &info);
+
+/* Check error code from SGBRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "SGBRFS", &info, &c__0,
+ trans, &n, &n, &kl, &ku, &
+ nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ sget04_(&n, &nrhs, &x[1], &ldb, &xact[1],
+ &ldb, &rcondc, &result[3]);
+ sgbt05_(trans, &n, &kl, &ku, &nrhs, &a[1],
+ &lda, &b[1], &ldb, &x[1], &ldb, &
+ xact[1], &ldb, &rwork[1], &rwork[
+ nrhs + 1], &result[4]);
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___59.ciunit = *nout;
+ s_wsfe(&io___59);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrhs, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k -
+ 1], (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += 5;
+/* L70: */
+ }
+/* L80: */
+ }
+
+/* + TEST 7: */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+L90:
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ anorm = anormo;
+ rcondc = rcondo;
+ *(unsigned char *)norm = 'O';
+ } else {
+ anorm = anormi;
+ rcondc = rcondi;
+ *(unsigned char *)norm = 'I';
+ }
+ s_copy(srnamc_1.srnamt, "SGBCON", (ftnlen)32,
+ (ftnlen)6);
+ sgbcon_(norm, &n, &kl, &ku, &afac[1], &ldafac,
+ &iwork[1], &anorm, &rcond, &work[1],
+ &iwork[n + 1], &info);
+
+/* Check error code from SGBCON. */
+
+ if (info != 0) {
+ alaerh_(path, "SGBCON", &info, &c__0,
+ norm, &n, &n, &kl, &ku, &c_n1, &
+ imat, &nfail, &nerrs, nout);
+ }
+
+ result[6] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___61.ciunit = *nout;
+ s_wsfe(&io___61);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L100: */
+ }
+
+L110:
+ ;
+ }
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+
+ return 0;
+
+/* End of SCHKGB */
+
+} /* schkgb_ */
diff --git a/TESTING/LIN/schkge.c b/TESTING/LIN/schkge.c
new file mode 100644
index 0000000..b3e6dac
--- /dev/null
+++ b/TESTING/LIN/schkge.c
@@ -0,0 +1,679 @@
+/* schkge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static real c_b23 = 0.f;
+static logical c_true = TRUE_;
+static integer c__8 = 8;
+
+/* Subroutine */ int schkge_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nns, integer *nsval, real *thresh, logical *tsterr, integer *nmax,
+ real *a, real *afac, real *ainv, real *b, real *x, real *xact, real *
+ work, real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M = \002,i5,\002, N =\002,i5,\002, NB "
+ "=\002,i4,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
+ ;
+ static char fmt_9998[] = "(\002 TRANS='\002,a1,\002', N =\002,i5,\002, N"
+ "RHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g1"
+ "2.5)";
+ static char fmt_9997[] = "(\002 NORM ='\002,a1,\002', N =\002,i5,\002"
+ ",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
+ ;
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, im, in, kl, ku, nt, lda, inb, ioff, mode, imat,
+ info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char norm[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int sget01_(integer *, integer *, real *, integer
+ *, real *, integer *, integer *, real *, real *), sget02_(char *,
+ integer *, integer *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, real *, real *);
+ real rcond;
+ extern /* Subroutine */ int sget03_(integer *, real *, integer *, real *,
+ integer *, real *, integer *, real *, real *, real *), sget04_(
+ integer *, integer *, real *, integer *, real *, integer *, real *
+, real *);
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int sget07_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, logical *, real *, real *);
+ real anorm;
+ integer itran;
+ char trans[1];
+ integer izero, nerrs;
+ real dummy;
+ integer lwork;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ real rcondc;
+ extern doublereal slange_(char *, integer *, integer *, real *, integer *,
+ real *);
+ real rcondi;
+ extern /* Subroutine */ int sgecon_(char *, integer *, real *, integer *,
+ real *, real *, real *, integer *, integer *), alasum_(
+ char *, integer *, integer *, integer *, integer *);
+ real cndnum, anormi, rcondo;
+ extern /* Subroutine */ int serrge_(char *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int sgerfs_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, integer *, real *, integer *, real *
+, integer *, real *, real *, real *, integer *, integer *)
+ , sgetrf_(integer *, integer *, real *, integer *, integer *,
+ integer *);
+ logical trfcon;
+ real anormo;
+ extern /* Subroutine */ int sgetri_(integer *, real *, integer *, integer
+ *, real *, integer *, integer *), slacpy_(char *, integer *,
+ integer *, real *, integer *, real *, integer *), slarhs_(
+ char *, char *, char *, char *, integer *, integer *, integer *,
+ integer *, integer *, real *, integer *, real *, integer *, real *
+, integer *, integer *, integer *)
+ , slaset_(char *, integer *, integer *, real *, real *, real *,
+ integer *), xlaenv_(integer *, integer *), slatms_(
+ integer *, integer *, char *, integer *, char *, real *, integer *
+, real *, real *, integer *, integer *, char *, real *, integer *,
+ real *, integer *), sgetrs_(char *,
+ integer *, integer *, real *, integer *, integer *, real *,
+ integer *, integer *);
+ real result[8];
+
+ /* Fortran I/O blocks */
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKGE tests SGETRF, -TRI, -TRS, -RFS, and -CON. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* B (workspace) REAL array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(2*NMAX,2*NSMAX+NWORK)) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "GE", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ xlaenv_(&c__1, &c__1);
+ if (*tsterr) {
+ serrge_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+/* Do for each value of M in MVAL */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+ lda = max(1,m);
+
+/* Do for each value of N in NVAL */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ *(unsigned char *)xtype = 'N';
+ nimat = 11;
+ if (m <= 0 || n <= 0) {
+ nimat = 1;
+ }
+
+ i__3 = nimat;
+ for (imat = 1; imat <= i__3; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L100;
+ }
+
+/* Skip types 5, 6, or 7 if the matrix size is too small. */
+
+ zerot = imat >= 5 && imat <= 7;
+ if (zerot && n < imat - 4) {
+ goto L100;
+ }
+
+/* Set up parameters with SLATB4 and generate a test matrix */
+/* with SLATMS. */
+
+ slatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
+ slatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, " ", &m, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L100;
+ }
+
+/* For types 5-7, zero one or more columns of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 5) {
+ izero = 1;
+ } else if (imat == 6) {
+ izero = min(m,n);
+ } else {
+ izero = min(m,n) / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 7) {
+ i__4 = m;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L20: */
+ }
+ } else {
+ i__4 = n - izero + 1;
+ slaset_("Full", &m, &i__4, &c_b23, &c_b23, &a[ioff +
+ 1], &lda);
+ }
+ } else {
+ izero = 0;
+ }
+
+/* These lines, if used in place of the calls in the DO 60 */
+/* loop, cause the code to bomb on a Sun SPARCstation. */
+
+/* ANORMO = SLANGE( 'O', M, N, A, LDA, RWORK ) */
+/* ANORMI = SLANGE( 'I', M, N, A, LDA, RWORK ) */
+
+/* Do for each blocksize in NBVAL */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the LU factorization of the matrix. */
+
+ slacpy_("Full", &m, &n, &a[1], &lda, &afac[1], &lda);
+ s_copy(srnamc_1.srnamt, "SGETRF", (ftnlen)32, (ftnlen)6);
+ sgetrf_(&m, &n, &afac[1], &lda, &iwork[1], &info);
+
+/* Check error code from SGETRF. */
+
+ if (info != izero) {
+ alaerh_(path, "SGETRF", &info, &izero, " ", &m, &n, &
+ c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
+ }
+ trfcon = FALSE_;
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ slacpy_("Full", &m, &n, &afac[1], &lda, &ainv[1], &lda);
+ sget01_(&m, &n, &a[1], &lda, &ainv[1], &lda, &iwork[1], &
+ rwork[1], result);
+ nt = 1;
+
+/* + TEST 2 */
+/* Form the inverse if the factorization was successful */
+/* and compute the residual. */
+
+ if (m == n && info == 0) {
+ slacpy_("Full", &n, &n, &afac[1], &lda, &ainv[1], &
+ lda);
+ s_copy(srnamc_1.srnamt, "SGETRI", (ftnlen)32, (ftnlen)
+ 6);
+ nrhs = nsval[1];
+ lwork = *nmax * max(3,nrhs);
+ sgetri_(&n, &ainv[1], &lda, &iwork[1], &work[1], &
+ lwork, &info);
+
+/* Check error code from SGETRI. */
+
+ if (info != 0) {
+ alaerh_(path, "SGETRI", &info, &c__0, " ", &n, &n,
+ &c_n1, &c_n1, &nb, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+/* Compute the residual for the matrix times its */
+/* inverse. Also compute the 1-norm condition number */
+/* of A. */
+
+ sget03_(&n, &a[1], &lda, &ainv[1], &lda, &work[1], &
+ lda, &rwork[1], &rcondo, &result[1]);
+ anormo = slange_("O", &m, &n, &a[1], &lda, &rwork[1]);
+
+/* Compute the infinity-norm condition number of A. */
+
+ anormi = slange_("I", &m, &n, &a[1], &lda, &rwork[1]);
+ ainvnm = slange_("I", &n, &n, &ainv[1], &lda, &rwork[
+ 1]);
+ if (anormi <= 0.f || ainvnm <= 0.f) {
+ rcondi = 1.f;
+ } else {
+ rcondi = 1.f / anormi / ainvnm;
+ }
+ nt = 2;
+ } else {
+
+/* Do only the condition estimate if INFO > 0. */
+
+ trfcon = TRUE_;
+ anormo = slange_("O", &m, &n, &a[1], &lda, &rwork[1]);
+ anormi = slange_("I", &m, &n, &a[1], &lda, &rwork[1]);
+ rcondo = 0.f;
+ rcondi = 0.f;
+ }
+
+/* Print information about the tests so far that did not */
+/* pass the threshold. */
+
+ i__5 = nt;
+ for (k = 1; k <= i__5; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L30: */
+ }
+ nrun += nt;
+
+/* Skip the remaining tests if this is not the first */
+/* block size or if M .ne. N. Skip the solve tests if */
+/* the matrix is singular. */
+
+ if (inb > 1 || m != n) {
+ goto L90;
+ }
+ if (trfcon) {
+ goto L70;
+ }
+
+ i__5 = *nns;
+ for (irhs = 1; irhs <= i__5; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+
+ for (itran = 1; itran <= 3; ++itran) {
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, (
+ ftnlen)6);
+ slarhs_(path, xtype, " ", trans, &n, &n, &kl, &ku,
+ &nrhs, &a[1], &lda, &xact[1], &lda, &b[1]
+, &lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+
+ slacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
+ lda);
+ s_copy(srnamc_1.srnamt, "SGETRS", (ftnlen)32, (
+ ftnlen)6);
+ sgetrs_(trans, &n, &nrhs, &afac[1], &lda, &iwork[
+ 1], &x[1], &lda, &info);
+
+/* Check error code from SGETRS. */
+
+ if (info != 0) {
+ alaerh_(path, "SGETRS", &info, &c__0, trans, &
+ n, &n, &c_n1, &c_n1, &nrhs, &imat, &
+ nfail, &nerrs, nout);
+ }
+
+ slacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1],
+ &lda);
+ sget02_(trans, &n, &n, &nrhs, &a[1], &lda, &x[1],
+ &lda, &work[1], &lda, &rwork[1], &result[
+ 2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the */
+/* solution. */
+
+ s_copy(srnamc_1.srnamt, "SGERFS", (ftnlen)32, (
+ ftnlen)6);
+ sgerfs_(trans, &n, &nrhs, &a[1], &lda, &afac[1], &
+ lda, &iwork[1], &b[1], &lda, &x[1], &lda,
+ &rwork[1], &rwork[nrhs + 1], &work[1], &
+ iwork[n + 1], &info);
+
+/* Check error code from SGERFS. */
+
+ if (info != 0) {
+ alaerh_(path, "SGERFS", &info, &c__0, trans, &
+ n, &n, &c_n1, &c_n1, &nrhs, &imat, &
+ nfail, &nerrs, nout);
+ }
+
+ sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[4]);
+ sget07_(trans, &n, &nrhs, &a[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &c_true, &rwork[nrhs + 1], &result[5]);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___46.ciunit = *nout;
+ s_wsfe(&io___46);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L40: */
+ }
+ nrun += 5;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+L70:
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ anorm = anormo;
+ rcondc = rcondo;
+ *(unsigned char *)norm = 'O';
+ } else {
+ anorm = anormi;
+ rcondc = rcondi;
+ *(unsigned char *)norm = 'I';
+ }
+ s_copy(srnamc_1.srnamt, "SGECON", (ftnlen)32, (ftnlen)
+ 6);
+ sgecon_(norm, &n, &afac[1], &lda, &anorm, &rcond, &
+ work[1], &iwork[n + 1], &info);
+
+/* Check error code from SGECON. */
+
+ if (info != 0) {
+ alaerh_(path, "SGECON", &info, &c__0, norm, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+/* This line is needed on a Sun SPARCstation. */
+
+ dummy = rcond;
+
+ result[7] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___50.ciunit = *nout;
+ s_wsfe(&io___50);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L80: */
+ }
+L90:
+ ;
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SCHKGE */
+
+} /* schkge_ */
diff --git a/TESTING/LIN/schkgt.c b/TESTING/LIN/schkgt.c
new file mode 100644
index 0000000..9565bff
--- /dev/null
+++ b/TESTING/LIN/schkgt.c
@@ -0,0 +1,641 @@
+/* schkgt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__7 = 7;
+static real c_b63 = 1.f;
+static real c_b64 = 0.f;
+
+/* Subroutine */ int schkgt_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, real *thresh, logical *tsterr, real *a,
+ real *af, real *b, real *x, real *xact, real *work, real *rwork,
+ integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 0,0,0,1 };
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(12x,\002N =\002,i5,\002,\002,10x,\002 type"
+ " \002,i2,\002, test(\002,i2,\002) = \002,g12.5)";
+ static char fmt_9997[] = "(\002 NORM ='\002,a1,\002', N =\002,i5,\002"
+ ",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) = \002,g12."
+ "5)";
+ static char fmt_9998[] = "(\002 TRANS='\002,a1,\002', N =\002,i5,\002, N"
+ "RHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) = \002,g"
+ "12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, m, n;
+ real z__[3];
+ integer in, kl, ku, ix, lda;
+ real cond;
+ integer mode, koff, imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char norm[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ real rcond;
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *), sscal_(integer *, real *,
+ real *, integer *);
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ real anorm;
+ integer itran;
+ extern /* Subroutine */ int sgtt01_(integer *, real *, real *, real *,
+ real *, real *, real *, real *, integer *, real *, integer *,
+ real *, real *), sgtt02_(char *, integer *, integer *, real *,
+ real *, real *, real *, integer *, real *, integer *, real *,
+ real *), sgtt05_(char *, integer *, integer *, real *,
+ real *, real *, real *, integer *, real *, integer *, real *,
+ integer *, real *, real *, real *);
+ char trans[1];
+ integer izero, nerrs;
+ extern doublereal sasum_(integer *, real *, integer *);
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ logical zerot;
+ extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ real rcondc, rcondi, rcondo;
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *), serrge_(char *, integer *);
+ real ainvnm;
+ extern doublereal slangt_(char *, integer *, real *, real *, real *);
+ extern /* Subroutine */ int slagtm_(char *, integer *, integer *, real *,
+ real *, real *, real *, real *, integer *, real *, real *,
+ integer *);
+ logical trfcon;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), sgtcon_(char *, integer *,
+ real *, real *, real *, real *, integer *, real *, real *, real *,
+ integer *, integer *), slatms_(integer *, integer *,
+ char *, integer *, char *, real *, integer *, real *, real *,
+ integer *, integer *, char *, real *, integer *, real *, integer *
+), slarnv_(integer *, integer *, integer *
+, real *), sgtrfs_(char *, integer *, integer *, real *, real *,
+ real *, real *, real *, real *, real *, integer *, real *,
+ integer *, real *, integer *, real *, real *, real *, integer *,
+ integer *), sgttrf_(integer *, real *, real *, real *,
+ real *, integer *, integer *);
+ real result[7];
+ extern /* Subroutine */ int sgttrs_(char *, integer *, integer *, real *,
+ real *, real *, real *, integer *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKGT tests SGTTRF, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) REAL array, dimension (NMAX*4) */
+
+/* AF (workspace) REAL array, dimension (NMAX*4) */
+
+/* B (workspace) REAL array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --af;
+ --a;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "GT", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrge_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+/* Computing MAX */
+ i__2 = n - 1;
+ m = max(i__2,0);
+ lda = max(1,n);
+ nimat = 12;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L100;
+ }
+
+/* Set up parameters with SLATB4. */
+
+ slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cond, dist);
+
+ zerot = imat >= 8 && imat <= 10;
+ if (imat <= 6) {
+
+/* Types 1-6: generate matrices of known condition number. */
+
+/* Computing MAX */
+ i__3 = 2 - ku, i__4 = 3 - max(1,n);
+ koff = max(i__3,i__4);
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
+ slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
+ &anorm, &kl, &ku, "Z", &af[koff], &c__3, &work[1], &
+ info);
+
+/* Check the error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, " ", &n, &n, &kl, &
+ ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L100;
+ }
+ izero = 0;
+
+ if (n > 1) {
+ i__3 = n - 1;
+ scopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
+ i__3 = n - 1;
+ scopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
+ }
+ scopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
+ } else {
+
+/* Types 7-12: generate tridiagonal matrices with */
+/* unknown condition numbers. */
+
+ if (! zerot || ! dotype[7]) {
+
+/* Generate a matrix with elements from [-1,1]. */
+
+ i__3 = n + (m << 1);
+ slarnv_(&c__2, iseed, &i__3, &a[1]);
+ if (anorm != 1.f) {
+ i__3 = n + (m << 1);
+ sscal_(&i__3, &anorm, &a[1], &c__1);
+ }
+ } else if (izero > 0) {
+
+/* Reuse the last matrix by copying back the zeroed out */
+/* elements. */
+
+ if (izero == 1) {
+ a[n] = z__[1];
+ if (n > 1) {
+ a[1] = z__[2];
+ }
+ } else if (izero == n) {
+ a[n * 3 - 2] = z__[0];
+ a[(n << 1) - 1] = z__[1];
+ } else {
+ a[(n << 1) - 2 + izero] = z__[0];
+ a[n - 1 + izero] = z__[1];
+ a[izero] = z__[2];
+ }
+ }
+
+/* If IMAT > 7, set one column of the matrix to 0. */
+
+ if (! zerot) {
+ izero = 0;
+ } else if (imat == 8) {
+ izero = 1;
+ z__[1] = a[n];
+ a[n] = 0.f;
+ if (n > 1) {
+ z__[2] = a[1];
+ a[1] = 0.f;
+ }
+ } else if (imat == 9) {
+ izero = n;
+ z__[0] = a[n * 3 - 2];
+ z__[1] = a[(n << 1) - 1];
+ a[n * 3 - 2] = 0.f;
+ a[(n << 1) - 1] = 0.f;
+ } else {
+ izero = (n + 1) / 2;
+ i__3 = n - 1;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[(n << 1) - 2 + i__] = 0.f;
+ a[n - 1 + i__] = 0.f;
+ a[i__] = 0.f;
+/* L20: */
+ }
+ a[n * 3 - 2] = 0.f;
+ a[(n << 1) - 1] = 0.f;
+ }
+ }
+
+/* + TEST 1 */
+/* Factor A as L*U and compute the ratio */
+/* norm(L*U - A) / (n * norm(A) * EPS ) */
+
+ i__3 = n + (m << 1);
+ scopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
+ s_copy(srnamc_1.srnamt, "SGTTRF", (ftnlen)32, (ftnlen)6);
+ sgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (m << 1)
+ + 1], &iwork[1], &info);
+
+/* Check error code from SGTTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "SGTTRF", &info, &izero, " ", &n, &n, &c__1, &
+ c__1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+ trfcon = info != 0;
+
+ sgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &af[m + 1], &
+ af[n + m + 1], &af[n + (m << 1) + 1], &iwork[1], &work[1],
+ &lda, &rwork[1], result);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+ for (itran = 1; itran <= 2; ++itran) {
+ *(unsigned char *)trans = *(unsigned char *)&transs[itran - 1]
+ ;
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ } else {
+ *(unsigned char *)norm = 'I';
+ }
+ anorm = slangt_(norm, &n, &a[1], &a[m + 1], &a[n + m + 1]);
+
+ if (! trfcon) {
+
+/* Use SGTTRS to solve for one column at a time of inv(A) */
+/* or inv(A^T), computing the maximum column sum as we */
+/* go. */
+
+ ainvnm = 0.f;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ x[j] = 0.f;
+/* L30: */
+ }
+ x[i__] = 1.f;
+ sgttrs_(trans, &n, &c__1, &af[1], &af[m + 1], &af[n +
+ m + 1], &af[n + (m << 1) + 1], &iwork[1], &x[
+ 1], &lda, &info);
+/* Computing MAX */
+ r__1 = ainvnm, r__2 = sasum_(&n, &x[1], &c__1);
+ ainvnm = dmax(r__1,r__2);
+/* L40: */
+ }
+
+/* Compute RCONDC = 1 / (norm(A) * norm(inv(A)) */
+
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondc = 1.f;
+ } else {
+ rcondc = 1.f / anorm / ainvnm;
+ }
+ if (itran == 1) {
+ rcondo = rcondc;
+ } else {
+ rcondi = rcondc;
+ }
+ } else {
+ rcondc = 0.f;
+ }
+
+/* + TEST 7 */
+/* Estimate the reciprocal of the condition number of the */
+/* matrix. */
+
+ s_copy(srnamc_1.srnamt, "SGTCON", (ftnlen)32, (ftnlen)6);
+ sgtcon_(norm, &n, &af[1], &af[m + 1], &af[n + m + 1], &af[n +
+ (m << 1) + 1], &iwork[1], &anorm, &rcond, &work[1], &
+ iwork[n + 1], &info);
+
+/* Check error code from SGTCON. */
+
+ if (info != 0) {
+ alaerh_(path, "SGTCON", &info, &c__0, norm, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+ result[6] = sget06_(&rcond, &rcondc);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L50: */
+ }
+
+/* Skip the remaining tests if the matrix is singular. */
+
+ if (trfcon) {
+ goto L100;
+ }
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* Generate NRHS random solution vectors. */
+
+ ix = 1;
+ i__4 = nrhs;
+ for (j = 1; j <= i__4; ++j) {
+ slarnv_(&c__2, iseed, &n, &xact[ix]);
+ ix += lda;
+/* L60: */
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+ *(unsigned char *)trans = *(unsigned char *)&transs[itran
+ - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Set the right hand side. */
+
+ slagtm_(trans, &n, &nrhs, &c_b63, &a[1], &a[m + 1], &a[n
+ + m + 1], &xact[1], &lda, &c_b64, &b[1], &lda);
+
+/* + TEST 2 */
+/* Solve op(A) * X = B and compute the residual. */
+
+ slacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+ s_copy(srnamc_1.srnamt, "SGTTRS", (ftnlen)32, (ftnlen)6);
+ sgttrs_(trans, &n, &nrhs, &af[1], &af[m + 1], &af[n + m +
+ 1], &af[n + (m << 1) + 1], &iwork[1], &x[1], &lda,
+ &info);
+
+/* Check error code from SGTTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "SGTTRS", &info, &c__0, trans, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ slacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
+ sgtt02_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
+ &x[1], &lda, &work[1], &lda, &rwork[1], &result[
+ 1]);
+
+/* + TEST 3 */
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[2]);
+
+/* + TESTS 4, 5, and 6 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "SGTRFS", (ftnlen)32, (ftnlen)6);
+ sgtrfs_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
+ &af[1], &af[m + 1], &af[n + m + 1], &af[n + (m <<
+ 1) + 1], &iwork[1], &b[1], &lda, &x[1], &lda, &
+ rwork[1], &rwork[nrhs + 1], &work[1], &iwork[n +
+ 1], &info);
+
+/* Check error code from SGTRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "SGTRFS", &info, &c__0, trans, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[3]);
+ sgtt05_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
+ &b[1], &lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &rwork[nrhs + 1], &result[4]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L70: */
+ }
+ nrun += 5;
+/* L80: */
+ }
+/* L90: */
+ }
+
+L100:
+ ;
+ }
+/* L110: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SCHKGT */
+
+} /* schkgt_ */
diff --git a/TESTING/LIN/schklq.c b/TESTING/LIN/schklq.c
new file mode 100644
index 0000000..d33b1ab
--- /dev/null
+++ b/TESTING/LIN/schklq.c
@@ -0,0 +1,459 @@
+/* schklq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int schklq_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nxval, integer *nrhs, real *thresh, logical *tsterr, integer *nmax,
+ real *a, real *af, real *aq, real *al, real *ac, real *b, real *x,
+ real *xact, real *tau, real *work, real *rwork, integer *iwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
+ "5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
+ "t(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, ik, im, in, kl, nk, ku, nt, nx, lda, inb, mode,
+ imat, info;
+ char path[3];
+ integer kval[4];
+ char dist[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int sget02_(char *, integer *, integer *, integer
+ *, real *, integer *, real *, integer *, real *, integer *, real *
+, real *);
+ real anorm;
+ integer minmn;
+ extern /* Subroutine */ int slqt01_(integer *, integer *, real *, real *,
+ real *, real *, integer *, real *, real *, integer *, real *,
+ real *), slqt02_(integer *, integer *, integer *, real *, real *,
+ real *, real *, integer *, real *, real *, integer *, real *,
+ real *), slqt03_(integer *, integer *, integer *, real *, real *,
+ real *, real *, integer *, real *, real *, integer *, real *,
+ real *);
+ integer nerrs, lwork;
+ extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ extern logical sgennd_(integer *, integer *, real *, integer *);
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, integer *, integer *), sgelqs_(
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, integer *, real *, integer *, integer *), xlaenv_(integer *,
+ integer *), slatms_(integer *, integer *, char *, integer *, char
+ *, real *, integer *, real *, real *, integer *, integer *, char *
+, real *, integer *, real *, integer *),
+ serrlq_(char *, integer *);
+ real result[8];
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKLQ tests SGELQF, SORGLQ and SORMLQ. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AQ (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AL (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AC (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* B (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* X (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* TAU (workspace) REAL array, dimension (NMAX) */
+
+/* WORK (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --tau;
+ --xact;
+ --x;
+ --b;
+ --ac;
+ --al;
+ --aq;
+ --af;
+ --a;
+ --nxval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "LQ", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrlq_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+ lda = *nmax;
+ lwork = *nmax * max(*nmax,*nrhs);
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Do for each value of N in NVAL. */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ minmn = min(m,n);
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L50;
+ }
+
+/* Set up parameters with SLATB4 and generate a test matrix */
+/* with SLATMS. */
+
+ slatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
+ slatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, " ", &m, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L50;
+ }
+
+/* Set some values for K: the first value must be MINMN, */
+/* corresponding to the call of SLQT01; other values are */
+/* used in the calls of SLQT02, and must not exceed MINMN. */
+
+ kval[0] = minmn;
+ kval[1] = 0;
+ kval[2] = 1;
+ kval[3] = minmn / 2;
+ if (minmn == 0) {
+ nk = 1;
+ } else if (minmn == 1) {
+ nk = 2;
+ } else if (minmn <= 3) {
+ nk = 3;
+ } else {
+ nk = 4;
+ }
+
+/* Do for each value of K in KVAL */
+
+ i__3 = nk;
+ for (ik = 1; ik <= i__3; ++ik) {
+ k = kval[ik - 1];
+
+/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ nx = nxval[inb];
+ xlaenv_(&c__3, &nx);
+ for (i__ = 1; i__ <= 8; ++i__) {
+ result[i__ - 1] = 0.f;
+ }
+ nt = 2;
+ if (ik == 1) {
+
+/* Test SGELQF */
+
+ slqt01_(&m, &n, &a[1], &af[1], &aq[1], &al[1], &
+ lda, &tau[1], &work[1], &lwork, &rwork[1],
+ result);
+ if (! sgennd_(&m, &n, &af[1], &lda)) {
+ result[7] = *thresh * 2;
+ }
+ ++nt;
+ } else if (m <= n) {
+
+/* Test SORGLQ, using factorization */
+/* returned by SLQT01 */
+
+ slqt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &al[1],
+ &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], result);
+ }
+ if (m >= k) {
+
+/* Test SORMLQ, using factorization returned */
+/* by SLQT01 */
+
+ slqt03_(&m, &n, &k, &af[1], &ac[1], &al[1], &aq[1]
+, &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], &result[2]);
+ nt += 4;
+
+/* If M>=N and K=N, call SGELQS to solve a system */
+/* with NRHS right hand sides and compute the */
+/* residual. */
+
+ if (k == m && inb == 1) {
+
+/* Generate a solution and set the right */
+/* hand side. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32,
+ (ftnlen)6);
+ slarhs_(path, "New", "Full", "No transpose", &
+ m, &n, &c__0, &c__0, nrhs, &a[1], &
+ lda, &xact[1], &lda, &b[1], &lda,
+ iseed, &info);
+
+ slacpy_("Full", &m, nrhs, &b[1], &lda, &x[1],
+ &lda);
+ s_copy(srnamc_1.srnamt, "SGELQS", (ftnlen)32,
+ (ftnlen)6);
+ sgelqs_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
+ x[1], &lda, &work[1], &lwork, &info);
+
+/* Check error code from SGELQS. */
+
+ if (info != 0) {
+ alaerh_(path, "SGELQS", &info, &c__0,
+ " ", &m, &n, nrhs, &c_n1, &nb, &
+ imat, &nfail, &nerrs, nout);
+ }
+
+ sget02_("No transpose", &m, &n, nrhs, &a[1], &
+ lda, &x[1], &lda, &b[1], &lda, &rwork[
+ 1], &result[6]);
+ ++nt;
+ }
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (i__ = 1; i__ <= 8; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+/* L30: */
+ }
+/* L40: */
+ }
+L50:
+ ;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SCHKLQ */
+
+} /* schklq_ */
diff --git a/TESTING/LIN/schkpb.c b/TESTING/LIN/schkpb.c
new file mode 100644
index 0000000..5a0fe87
--- /dev/null
+++ b/TESTING/LIN/schkpb.c
@@ -0,0 +1,698 @@
+/* schkpb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static real c_b50 = 0.f;
+static real c_b51 = 1.f;
+static integer c__7 = 7;
+
+/* Subroutine */ int schkpb_(logical *dotype, integer *nn, integer *nval,
+ integer *nnb, integer *nbval, integer *nns, integer *nsval, real *
+ thresh, logical *tsterr, integer *nmax, real *a, real *afac, real *
+ ainv, real *b, real *x, real *xact, real *work, real *rwork, integer *
+ iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
+ "=\002,i5,\002, NB=\002,i4,\002, type \002,i2,\002, test \002,i2"
+ ",\002, ratio= \002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
+ "=\002,i5,\002, NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i"
+ "2,\002) = \002,g12.5)";
+ static char fmt_9997[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
+ "=\002,i5,\002,\002,10x,\002 type \002,i2,\002, test(\002,i2,\002"
+ ") = \002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, i1, i2, kd, nb, in, kl, iw, ku, lda, ikd, inb, nkd,
+ ldab, ioff, mode, koff, imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4], kdval[4];
+ real rcond;
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *);
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int spbt01_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, real *, real *), spbt02_(
+ char *, integer *, integer *, integer *, real *, integer *, real *
+, integer *, real *, integer *, real *, real *);
+ real anorm;
+ extern /* Subroutine */ int spbt05_(char *, integer *, integer *, integer
+ *, real *, integer *, real *, integer *, real *, integer *, real *
+, integer *, real *, real *, real *);
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), sswap_(integer *, real *, integer *, real *, integer *
+);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ real rcondc;
+ extern doublereal slange_(char *, integer *, integer *, real *, integer *,
+ real *);
+ char packit[1];
+ extern doublereal slansb_(char *, char *, integer *, integer *, real *,
+ integer *, real *);
+ real cndnum;
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *), spbcon_(char *, integer *, integer *, real
+ *, integer *, real *, real *, real *, integer *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, integer *, integer *), slaset_(
+ char *, integer *, integer *, real *, real *, real *, integer *), spbrfs_(char *, integer *, integer *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, real *, real *, integer *, integer *), spbtrf_(
+ char *, integer *, integer *, real *, integer *, integer *), xlaenv_(integer *, integer *), slatms_(integer *,
+ integer *, char *, integer *, char *, real *, integer *, real *,
+ real *, integer *, integer *, char *, real *, integer *, real *,
+ integer *), serrpo_(char *, integer *), spbtrs_(char *, integer *, integer *, integer *, real *,
+ integer *, real *, integer *, integer *);
+ real result[7];
+
+ /* Fortran I/O blocks */
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKPB tests SPBTRF, -TRS, -RFS, and -CON. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* B (workspace) REAL array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "PB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrpo_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+ kdval[0] = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+
+/* Set limits on the number of loop iterations. */
+
+/* Computing MAX */
+ i__2 = 1, i__3 = min(n,4);
+ nkd = max(i__2,i__3);
+ nimat = 8;
+ if (n == 0) {
+ nimat = 1;
+ }
+
+ kdval[1] = n + (n + 1) / 4;
+ kdval[2] = (n * 3 - 1) / 4;
+ kdval[3] = (n + 1) / 4;
+
+ i__2 = nkd;
+ for (ikd = 1; ikd <= i__2; ++ikd) {
+
+/* Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order */
+/* makes it easier to skip redundant values for small values */
+/* of N. */
+
+ kd = kdval[ikd - 1];
+ ldab = kd + 1;
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ koff = 1;
+ if (iuplo == 1) {
+ *(unsigned char *)uplo = 'U';
+/* Computing MAX */
+ i__3 = 1, i__4 = kd + 2 - n;
+ koff = max(i__3,i__4);
+ *(unsigned char *)packit = 'Q';
+ } else {
+ *(unsigned char *)uplo = 'L';
+ *(unsigned char *)packit = 'B';
+ }
+
+ i__3 = nimat;
+ for (imat = 1; imat <= i__3; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L60;
+ }
+
+/* Skip types 2, 3, or 4 if the matrix size is too small. */
+
+ zerot = imat >= 2 && imat <= 4;
+ if (zerot && n < imat - 1) {
+ goto L60;
+ }
+
+ if (! zerot || ! dotype[1]) {
+
+/* Set up parameters with SLATB4 and generate a test */
+/* matrix with SLATMS. */
+
+ slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm,
+ &mode, &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)
+ 6);
+ slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode,
+ &cndnum, &anorm, &kd, &kd, packit, &a[koff],
+ &ldab, &work[1], &info);
+
+/* Check error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, uplo, &n, &
+ n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ goto L60;
+ }
+ } else if (izero > 0) {
+
+/* Use the same matrix for types 3 and 4 as for type */
+/* 2 by copying back the zeroed out column, */
+
+ iw = (lda << 1) + 1;
+ if (iuplo == 1) {
+ ioff = (izero - 1) * ldab + kd + 1;
+ i__4 = izero - i1;
+ scopy_(&i__4, &work[iw], &c__1, &a[ioff - izero +
+ i1], &c__1);
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ scopy_(&i__4, &work[iw], &c__1, &a[ioff], &i__5);
+ } else {
+ ioff = (i1 - 1) * ldab + 1;
+ i__4 = izero - i1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ scopy_(&i__4, &work[iw], &c__1, &a[ioff + izero -
+ i1], &i__5);
+ ioff = (izero - 1) * ldab + 1;
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+ scopy_(&i__4, &work[iw], &c__1, &a[ioff], &c__1);
+ }
+ }
+
+/* For types 2-4, zero one row and column of the matrix */
+/* to test that INFO is returned correctly. */
+
+ izero = 0;
+ if (zerot) {
+ if (imat == 2) {
+ izero = 1;
+ } else if (imat == 3) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+/* Save the zeroed out row and column in WORK(*,3) */
+
+ iw = lda << 1;
+/* Computing MIN */
+ i__5 = (kd << 1) + 1;
+ i__4 = min(i__5,n);
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ work[iw + i__] = 0.f;
+/* L20: */
+ }
+ ++iw;
+/* Computing MAX */
+ i__4 = izero - kd;
+ i1 = max(i__4,1);
+/* Computing MIN */
+ i__4 = izero + kd;
+ i2 = min(i__4,n);
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * ldab + kd + 1;
+ i__4 = izero - i1;
+ sswap_(&i__4, &a[ioff - izero + i1], &c__1, &work[
+ iw], &c__1);
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ sswap_(&i__4, &a[ioff], &i__5, &work[iw], &c__1);
+ } else {
+ ioff = (i1 - 1) * ldab + 1;
+ i__4 = izero - i1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ sswap_(&i__4, &a[ioff + izero - i1], &i__5, &work[
+ iw], &c__1);
+ ioff = (izero - 1) * ldab + 1;
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+ sswap_(&i__4, &a[ioff], &c__1, &work[iw], &c__1);
+ }
+ }
+
+/* Do for each value of NB in NBVAL */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the L*L' or U'*U factorization of the band */
+/* matrix. */
+
+ i__5 = kd + 1;
+ slacpy_("Full", &i__5, &n, &a[1], &ldab, &afac[1], &
+ ldab);
+ s_copy(srnamc_1.srnamt, "SPBTRF", (ftnlen)32, (ftnlen)
+ 6);
+ spbtrf_(uplo, &n, &kd, &afac[1], &ldab, &info);
+
+/* Check error code from SPBTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "SPBTRF", &info, &izero, uplo, &n, &
+ n, &kd, &kd, &nb, &imat, &nfail, &nerrs,
+ nout);
+ goto L50;
+ }
+
+/* Skip the tests if INFO is not 0. */
+
+ if (info != 0) {
+ goto L50;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ i__5 = kd + 1;
+ slacpy_("Full", &i__5, &n, &afac[1], &ldab, &ainv[1],
+ &ldab);
+ spbt01_(uplo, &n, &kd, &a[1], &ldab, &ainv[1], &ldab,
+ &rwork[1], result);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+/* Only do other tests if this is the first blocksize. */
+
+ if (inb > 1) {
+ goto L50;
+ }
+
+/* Form the inverse of A so we can get a good estimate */
+/* of RCONDC = 1/(norm(A) * norm(inv(A))). */
+
+ slaset_("Full", &n, &n, &c_b50, &c_b51, &ainv[1], &
+ lda);
+ s_copy(srnamc_1.srnamt, "SPBTRS", (ftnlen)32, (ftnlen)
+ 6);
+ spbtrs_(uplo, &n, &kd, &n, &afac[1], &ldab, &ainv[1],
+ &lda, &info);
+
+/* Compute RCONDC = 1/(norm(A) * norm(inv(A))). */
+
+ anorm = slansb_("1", uplo, &n, &kd, &a[1], &ldab, &
+ rwork[1]);
+ ainvnm = slange_("1", &n, &n, &ainv[1], &lda, &rwork[
+ 1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondc = 1.f;
+ } else {
+ rcondc = 1.f / anorm / ainvnm;
+ }
+
+ i__5 = *nns;
+ for (irhs = 1; irhs <= i__5; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 2 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, (
+ ftnlen)6);
+ slarhs_(path, xtype, uplo, " ", &n, &n, &kd, &kd,
+ &nrhs, &a[1], &ldab, &xact[1], &lda, &b[1]
+, &lda, iseed, &info);
+ slacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "SPBTRS", (ftnlen)32, (
+ ftnlen)6);
+ spbtrs_(uplo, &n, &kd, &nrhs, &afac[1], &ldab, &x[
+ 1], &lda, &info);
+
+/* Check error code from SPBTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "SPBTRS", &info, &c__0, uplo, &
+ n, &n, &kd, &kd, &nrhs, &imat, &nfail,
+ &nerrs, nout);
+ }
+
+ slacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1],
+ &lda);
+ spbt02_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &x[1],
+ &lda, &work[1], &lda, &rwork[1], &result[
+ 1]);
+
+/* + TEST 3 */
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* + TESTS 4, 5, and 6 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "SPBRFS", (ftnlen)32, (
+ ftnlen)6);
+ spbrfs_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &afac[
+ 1], &ldab, &b[1], &lda, &x[1], &lda, &
+ rwork[1], &rwork[nrhs + 1], &work[1], &
+ iwork[1], &info);
+
+/* Check error code from SPBRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "SPBRFS", &info, &c__0, uplo, &
+ n, &n, &kd, &kd, &nrhs, &imat, &nfail,
+ &nerrs, nout);
+ }
+
+ sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+ spbt05_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &b[1],
+ &lda, &x[1], &lda, &xact[1], &lda, &
+ rwork[1], &rwork[nrhs + 1], &result[4]);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___46.ciunit = *nout;
+ s_wsfe(&io___46);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L30: */
+ }
+ nrun += 5;
+/* L40: */
+ }
+
+/* + TEST 7 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ s_copy(srnamc_1.srnamt, "SPBCON", (ftnlen)32, (ftnlen)
+ 6);
+ spbcon_(uplo, &n, &kd, &afac[1], &ldab, &anorm, &
+ rcond, &work[1], &iwork[1], &info);
+
+/* Check error code from SPBCON. */
+
+ if (info != 0) {
+ alaerh_(path, "SPBCON", &info, &c__0, uplo, &n, &
+ n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ result[6] = sget06_(&rcond, &rcondc);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___48.ciunit = *nout;
+ s_wsfe(&io___48);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L50:
+ ;
+ }
+L60:
+ ;
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SCHKPB */
+
+} /* schkpb_ */
diff --git a/TESTING/LIN/schkpo.c b/TESTING/LIN/schkpo.c
new file mode 100644
index 0000000..6617fe5
--- /dev/null
+++ b/TESTING/LIN/schkpo.c
@@ -0,0 +1,599 @@
+/* schkpo.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__8 = 8;
+
+/* Subroutine */ int schkpo_(logical *dotype, integer *nn, integer *nval,
+ integer *nnb, integer *nbval, integer *nns, integer *nsval, real *
+ thresh, logical *tsterr, integer *nmax, real *a, real *afac, real *
+ ainv, real *b, real *x, real *xact, real *work, real *rwork, integer *
+ iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
+ "=\002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
+ "12.5)";
+ static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002"
+ ",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
+ ;
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, nb, in, kl, ku, lda, inb, ioff, mode, imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ real rcond;
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *);
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ real anorm;
+ extern /* Subroutine */ int spot01_(char *, integer *, real *, integer *,
+ real *, integer *, real *, real *), spot02_(char *,
+ integer *, integer *, real *, integer *, real *, integer *, real *
+, integer *, real *, real *);
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int spot03_(char *, integer *, real *, integer *,
+ real *, integer *, real *, integer *, real *, real *, real *), spot05_(char *, integer *, integer *, real *, integer *,
+ real *, integer *, real *, integer *, real *, integer *, real *,
+ real *, real *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ real rcondc;
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, integer *, integer *), xlaenv_(
+ integer *, integer *), spocon_(char *, integer *, real *, integer
+ *, real *, real *, real *, integer *, integer *), slatms_(
+ integer *, integer *, char *, integer *, char *, real *, integer *
+, real *, real *, integer *, integer *, char *, real *, integer *,
+ real *, integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+ extern /* Subroutine */ int serrpo_(char *, integer *), sporfs_(
+ char *, integer *, integer *, real *, integer *, real *, integer *
+, real *, integer *, real *, integer *, real *, real *, real *,
+ integer *, integer *), spotrf_(char *, integer *, real *,
+ integer *, integer *);
+ real result[8];
+ extern /* Subroutine */ int spotri_(char *, integer *, real *, integer *,
+ integer *), spotrs_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKPO tests SPOTRF, -TRI, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* B (workspace) REAL array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "PO", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrpo_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ izero = 0;
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L110;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot && n < imat - 2) {
+ goto L110;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Set up parameters with SLATB4 and generate a test matrix */
+/* with SLATMS. */
+
+ slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
+ slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
+ &info);
+
+/* Check error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L100;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff] = 0.f;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff] = 0.f;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Do for each value of NB in NBVAL */
+
+ i__3 = *nnb;
+ for (inb = 1; inb <= i__3; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the L*L' or U'*U factorization of the matrix. */
+
+ slacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ s_copy(srnamc_1.srnamt, "SPOTRF", (ftnlen)32, (ftnlen)6);
+ spotrf_(uplo, &n, &afac[1], &lda, &info);
+
+/* Check error code from SPOTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "SPOTRF", &info, &izero, uplo, &n, &n, &
+ c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+
+/* Skip the tests if INFO is not 0. */
+
+ if (info != 0) {
+ goto L90;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ slacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
+ spot01_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &rwork[1],
+ result);
+
+/* + TEST 2 */
+/* Form the inverse and compute the residual. */
+
+ slacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
+ s_copy(srnamc_1.srnamt, "SPOTRI", (ftnlen)32, (ftnlen)6);
+ spotri_(uplo, &n, &ainv[1], &lda, &info);
+
+/* Check error code from SPOTRI. */
+
+ if (info != 0) {
+ alaerh_(path, "SPOTRI", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ spot03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &work[1], &
+ lda, &rwork[1], &rcondc, &result[1]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 1; k <= 2; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += 2;
+
+/* Skip the rest of the tests unless this is the first */
+/* blocksize. */
+
+ if (inb != 1) {
+ goto L90;
+ }
+
+ i__4 = *nns;
+ for (irhs = 1; irhs <= i__4; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B . */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ slarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ slacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "SPOTRS", (ftnlen)32, (ftnlen)
+ 6);
+ spotrs_(uplo, &n, &nrhs, &afac[1], &lda, &x[1], &lda,
+ &info);
+
+/* Check error code from SPOTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "SPOTRS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ slacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &
+ lda);
+ spot02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
+ work[1], &lda, &rwork[1], &result[2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "SPORFS", (ftnlen)32, (ftnlen)
+ 6);
+ sporfs_(uplo, &n, &nrhs, &a[1], &lda, &afac[1], &lda,
+ &b[1], &lda, &x[1], &lda, &rwork[1], &rwork[
+ nrhs + 1], &work[1], &iwork[1], &info);
+
+/* Check error code from SPORFS. */
+
+ if (info != 0) {
+ alaerh_(path, "SPORFS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[4]);
+ spot05_(uplo, &n, &nrhs, &a[1], &lda, &b[1], &lda, &x[
+ 1], &lda, &xact[1], &lda, &rwork[1], &rwork[
+ nrhs + 1], &result[5]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L70: */
+ }
+ nrun += 5;
+/* L80: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ anorm = slansy_("1", uplo, &n, &a[1], &lda, &rwork[1]);
+ s_copy(srnamc_1.srnamt, "SPOCON", (ftnlen)32, (ftnlen)6);
+ spocon_(uplo, &n, &afac[1], &lda, &anorm, &rcond, &work[1]
+, &iwork[1], &info);
+
+/* Check error code from SPOCON. */
+
+ if (info != 0) {
+ alaerh_(path, "SPOCON", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ result[7] = sget06_(&rcond, &rcondc);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L90:
+ ;
+ }
+L100:
+ ;
+ }
+L110:
+ ;
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SCHKPO */
+
+} /* schkpo_ */
diff --git a/TESTING/LIN/schkpp.c b/TESTING/LIN/schkpp.c
new file mode 100644
index 0000000..0a03593
--- /dev/null
+++ b/TESTING/LIN/schkpp.c
@@ -0,0 +1,558 @@
+/* schkpp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__8 = 8;
+
+/* Subroutine */ int schkpp_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, real *thresh, logical *tsterr, integer *
+ nmax, real *a, real *afac, real *ainv, real *b, real *x, real *xact,
+ real *work, real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char packs[1*2] = "C" "R";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
+ "12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, in, kl, ku, lda, npp, ioff, mode, imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ real rcond;
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *);
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ real anorm;
+ extern /* Subroutine */ int sppt01_(char *, integer *, real *, real *,
+ real *, real *);
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int sppt02_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *),
+ scopy_(integer *, real *, integer *, real *, integer *), sppt03_(
+ char *, integer *, real *, real *, real *, integer *, real *,
+ real *, real *), sppt05_(char *, integer *, integer *,
+ real *, real *, integer *, real *, integer *, real *, integer *,
+ real *, real *, real *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ real rcondc;
+ char packit[1];
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, integer *, integer *);
+ extern doublereal slansp_(char *, char *, integer *, real *, real *);
+ extern /* Subroutine */ int sppcon_(char *, integer *, real *, real *,
+ real *, real *, integer *, integer *), slatms_(integer *,
+ integer *, char *, integer *, char *, real *, integer *, real *,
+ real *, integer *, integer *, char *, real *, integer *, real *,
+ integer *), serrpo_(char *, integer *), spprfs_(char *, integer *, integer *, real *, real *,
+ real *, integer *, real *, integer *, real *, real *, real *,
+ integer *, integer *);
+ real result[8];
+ extern /* Subroutine */ int spptrf_(char *, integer *, real *, integer *), spptri_(char *, integer *, real *, integer *),
+ spptrs_(char *, integer *, integer *, real *, real *, integer *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKPP tests SPPTRF, -TRI, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) REAL array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AFAC (workspace) REAL array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AINV (workspace) REAL array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) REAL array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "PP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrpo_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L100;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot && n < imat - 2) {
+ goto L100;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ *(unsigned char *)packit = *(unsigned char *)&packs[iuplo - 1]
+ ;
+
+/* Set up parameters with SLATB4 and generate a test matrix */
+/* with SLATMS. */
+
+ slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
+ slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
+ 1], &info);
+
+/* Check error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * izero / 2;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff] = 0.f;
+ ioff += i__;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff] = 0.f;
+ ioff = ioff + n - i__;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Compute the L*L' or U'*U factorization of the matrix. */
+
+ npp = n * (n + 1) / 2;
+ scopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ s_copy(srnamc_1.srnamt, "SPPTRF", (ftnlen)32, (ftnlen)6);
+ spptrf_(uplo, &n, &afac[1], &info);
+
+/* Check error code from SPPTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "SPPTRF", &info, &izero, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+
+/* Skip the tests if INFO is not 0. */
+
+ if (info != 0) {
+ goto L90;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ scopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
+ sppt01_(uplo, &n, &a[1], &ainv[1], &rwork[1], result);
+
+/* + TEST 2 */
+/* Form the inverse and compute the residual. */
+
+ scopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
+ s_copy(srnamc_1.srnamt, "SPPTRI", (ftnlen)32, (ftnlen)6);
+ spptri_(uplo, &n, &ainv[1], &info);
+
+/* Check error code from SPPTRI. */
+
+ if (info != 0) {
+ alaerh_(path, "SPPTRI", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+ sppt03_(uplo, &n, &a[1], &ainv[1], &work[1], &lda, &rwork[1],
+ &rcondc, &result[1]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 1; k <= 2; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += 2;
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, (ftnlen)6);
+ slarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &nrhs, &
+ a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
+ info);
+ slacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "SPPTRS", (ftnlen)32, (ftnlen)6);
+ spptrs_(uplo, &n, &nrhs, &afac[1], &x[1], &lda, &info);
+
+/* Check error code from SPPTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "SPPTRS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ slacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
+ sppt02_(uplo, &n, &nrhs, &a[1], &x[1], &lda, &work[1], &
+ lda, &rwork[1], &result[2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "SPPRFS", (ftnlen)32, (ftnlen)6);
+ spprfs_(uplo, &n, &nrhs, &a[1], &afac[1], &b[1], &lda, &x[
+ 1], &lda, &rwork[1], &rwork[nrhs + 1], &work[1], &
+ iwork[1], &info);
+
+/* Check error code from SPPRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "SPPRFS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[4]);
+ sppt05_(uplo, &n, &nrhs, &a[1], &b[1], &lda, &x[1], &lda,
+ &xact[1], &lda, &rwork[1], &rwork[nrhs + 1], &
+ result[5]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L70: */
+ }
+ nrun += 5;
+/* L80: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ anorm = slansp_("1", uplo, &n, &a[1], &rwork[1]);
+ s_copy(srnamc_1.srnamt, "SPPCON", (ftnlen)32, (ftnlen)6);
+ sppcon_(uplo, &n, &afac[1], &anorm, &rcond, &work[1], &iwork[
+ 1], &info);
+
+/* Check error code from SPPCON. */
+
+ if (info != 0) {
+ alaerh_(path, "SPPCON", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+ result[7] = sget06_(&rcond, &rcondc);
+
+/* Print the test ratio if greater than or equal to THRESH. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L90:
+ ;
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SCHKPP */
+
+} /* schkpp_ */
diff --git a/TESTING/LIN/schkps.c b/TESTING/LIN/schkps.c
new file mode 100644
index 0000000..d0f18cf
--- /dev/null
+++ b/TESTING/LIN/schkps.c
@@ -0,0 +1,376 @@
+/* schkps.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+
+/* Subroutine */ int schkps_(logical *dotype, integer *nn, integer *nval,
+ integer *nnb, integer *nbval, integer *nrank, integer *rankval, real *
+ thresh, logical *tsterr, integer *nmax, real *a, real *afac, real *
+ perm, integer *piv, real *work, real *rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "RANK =\002,i3,\002, Diff =\002,i5,\002, NB =\002,i4,\002, type"
+ " \002,i2,\002, Ratio =\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer i_sceiling(real *), s_wsfe(cilist *), do_fio(integer *, char *,
+ ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer rankdiff, comprank, i__, n, nb, in, kl, ku, lda, inb;
+ real tol;
+ integer mode, imat, info, rank;
+ char path[3], dist[1], uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4], irank, nimat;
+ real anorm;
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int spst01_(char *, integer *, real *, integer *,
+ real *, integer *, real *, integer *, integer *, real *, real *,
+ integer *), slatb5_(char *, integer *, integer *, char *,
+ integer *, integer *, real *, integer *, real *, char *), alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *), alasum_(char *, integer *, integer *, integer *, integer
+ *);
+ real cndnum;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), xlaenv_(integer *, integer
+ *), slatmt_(integer *, integer *, char *, integer *, char *, real
+ *, integer *, real *, real *, integer *, integer *, integer *,
+ char *, real *, integer *, real *, integer *);
+ real result;
+ extern /* Subroutine */ int serrps_(char *, integer *), spstrf_(
+ char *, integer *, real *, integer *, integer *, integer *, real *
+, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKPS tests SPSTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the block size NB. */
+
+/* NRANK (input) INTEGER */
+/* The number of values of RANK contained in the vector RANKVAL. */
+
+/* RANKVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the block size NB. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* PERM (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* PIV (workspace) INTEGER array, dimension (NMAX) */
+
+/* WORK (workspace) REAL array, dimension (NMAX*3) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --piv;
+ --perm;
+ --afac;
+ --a;
+ --rankval;
+ --nbval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single Precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "PS", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L100: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrps_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ izero = 0;
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L140;
+ }
+
+/* Do for each value of RANK in RANKVAL */
+
+ i__3 = *nrank;
+ for (irank = 1; irank <= i__3; ++irank) {
+
+/* Only repeat test 3 to 5 for different ranks */
+/* Other tests use full rank */
+
+ if ((imat < 3 || imat > 5) && irank > 1) {
+ goto L130;
+ }
+
+ r__1 = n * (real) rankval[irank] / 100.f;
+ rank = i_sceiling(&r__1);
+
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+
+/* Set up parameters with SLATB5 and generate a test matrix */
+/* with SLATMT. */
+
+ slatb5_(path, &imat, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "SLATMT", (ftnlen)32, (ftnlen)6);
+ slatmt_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &rank, &kl, &ku, uplo, &a[1], &
+ lda, &work[1], &info);
+
+/* Check error code from SLATMT. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMT", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ goto L120;
+ }
+
+/* Do for each value of NB in NBVAL */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the pivoted L*L' or U'*U factorization */
+/* of the matrix. */
+
+ slacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ s_copy(srnamc_1.srnamt, "SPSTRF", (ftnlen)32, (ftnlen)
+ 6);
+
+/* Use default tolerance */
+
+ tol = -1.f;
+ spstrf_(uplo, &n, &afac[1], &lda, &piv[1], &comprank,
+ &tol, &work[1], &info);
+
+/* Check error code from SPSTRF. */
+
+ if (info < izero || info != izero && rank == n ||
+ info <= izero && rank < n) {
+ alaerh_(path, "SPSTRF", &info, &izero, uplo, &n, &
+ n, &c_n1, &c_n1, &nb, &imat, &nfail, &
+ nerrs, nout);
+ goto L110;
+ }
+
+/* Skip the test if INFO is not 0. */
+
+ if (info != 0) {
+ goto L110;
+ }
+
+/* Reconstruct matrix from factors and compute residual. */
+
+/* PERM holds permuted L*L^T or U^T*U */
+
+ spst01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &perm[
+ 1], &lda, &piv[1], &rwork[1], &result, &
+ comprank);
+
+/* Print information about the tests that did not pass */
+/* the threshold or where computed rank was not RANK. */
+
+ if (n == 0) {
+ comprank = 0;
+ }
+ rankdiff = rank - comprank;
+ if (result >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&rank, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&rankdiff, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result, (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L110:
+ ;
+ }
+
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+L140:
+ ;
+ }
+/* L150: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SCHKPS */
+
+} /* schkps_ */
diff --git a/TESTING/LIN/schkpt.c b/TESTING/LIN/schkpt.c
new file mode 100644
index 0000000..7076539
--- /dev/null
+++ b/TESTING/LIN/schkpt.c
@@ -0,0 +1,607 @@
+/* schkpt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static real c_b46 = 1.f;
+static real c_b47 = 0.f;
+static integer c__7 = 7;
+
+/* Subroutine */ int schkpt_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, real *thresh, logical *tsterr, real *a,
+ real *d__, real *e, real *b, real *x, real *xact, real *work, real *
+ rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 0,0,0,1 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 N =\002,i5,\002, type \002,i2,\002, te"
+ "st \002,i2,\002, ratio = \002,g12.5)";
+ static char fmt_9998[] = "(\002 N =\002,i5,\002, NRHS=\002,i3,\002, ty"
+ "pe \002,i2,\002, test(\002,i2,\002) = \002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n;
+ real z__[3];
+ integer ia, in, kl, ku, ix, lda;
+ real cond;
+ integer mode;
+ real dmax__;
+ integer imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ real rcond;
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *), sscal_(integer *, real *,
+ real *, integer *);
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ real anorm;
+ integer izero, nerrs;
+ extern doublereal sasum_(integer *, real *, integer *);
+ extern /* Subroutine */ int sptt01_(integer *, real *, real *, real *,
+ real *, real *, real *), sptt02_(integer *, integer *, real *,
+ real *, real *, integer *, real *, integer *, real *), scopy_(
+ integer *, real *, integer *, real *, integer *), sptt05_(integer
+ *, integer *, real *, real *, real *, integer *, real *, integer *
+, real *, integer *, real *, real *, real *);
+ logical zerot;
+ extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ real rcondc;
+ extern integer isamax_(integer *, real *, integer *);
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaptm_(integer *, integer
+ *, real *, real *, real *, real *, integer *, real *, real *,
+ integer *), slatms_(integer *, integer *, char *, integer *, char
+ *, real *, integer *, real *, real *, integer *, integer *, char *
+, real *, integer *, real *, integer *);
+ extern doublereal slanst_(char *, integer *, real *, real *);
+ extern /* Subroutine */ int serrgt_(char *, integer *), slarnv_(
+ integer *, integer *, integer *, real *), sptcon_(integer *, real
+ *, real *, real *, real *, real *, integer *);
+ real result[7];
+ extern /* Subroutine */ int sptrfs_(integer *, integer *, real *, real *,
+ real *, real *, real *, integer *, real *, integer *, real *,
+ real *, real *, integer *), spttrf_(integer *, real *, real *,
+ integer *), spttrs_(integer *, integer *, real *, real *, real *,
+ integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKPT tests SPTTRF, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) REAL array, dimension (NMAX*2) */
+
+/* D (workspace) REAL array, dimension (NMAX*2) */
+
+/* E (workspace) REAL array, dimension (NMAX*2) */
+
+/* B (workspace) REAL array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --e;
+ --d__;
+ --a;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "PT", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrgt_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+ lda = max(1,n);
+ nimat = 12;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (n > 0 && ! dotype[imat]) {
+ goto L100;
+ }
+
+/* Set up parameters with SLATB4. */
+
+ slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cond, dist);
+
+ zerot = imat >= 8 && imat <= 10;
+ if (imat <= 6) {
+
+/* Type 1-6: generate a symmetric tridiagonal matrix of */
+/* known condition number in lower triangular band storage. */
+
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
+ slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
+ &anorm, &kl, &ku, "B", &a[1], &c__2, &work[1], &info);
+
+/* Check the error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, " ", &n, &n, &kl, &
+ ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L100;
+ }
+ izero = 0;
+
+/* Copy the matrix to D and E. */
+
+ ia = 1;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d__[i__] = a[ia];
+ e[i__] = a[ia + 1];
+ ia += 2;
+/* L20: */
+ }
+ if (n > 0) {
+ d__[n] = a[ia];
+ }
+ } else {
+
+/* Type 7-12: generate a diagonally dominant matrix with */
+/* unknown condition number in the vectors D and E. */
+
+ if (! zerot || ! dotype[7]) {
+
+/* Let D and E have values from [-1,1]. */
+
+ slarnv_(&c__2, iseed, &n, &d__[1]);
+ i__3 = n - 1;
+ slarnv_(&c__2, iseed, &i__3, &e[1]);
+
+/* Make the tridiagonal matrix diagonally dominant. */
+
+ if (n == 1) {
+ d__[1] = dabs(d__[1]);
+ } else {
+ d__[1] = dabs(d__[1]) + dabs(e[1]);
+ d__[n] = (r__1 = d__[n], dabs(r__1)) + (r__2 = e[n -
+ 1], dabs(r__2));
+ i__3 = n - 1;
+ for (i__ = 2; i__ <= i__3; ++i__) {
+ d__[i__] = (r__1 = d__[i__], dabs(r__1)) + (r__2 =
+ e[i__], dabs(r__2)) + (r__3 = e[i__ - 1],
+ dabs(r__3));
+/* L30: */
+ }
+ }
+
+/* Scale D and E so the maximum element is ANORM. */
+
+ ix = isamax_(&n, &d__[1], &c__1);
+ dmax__ = d__[ix];
+ r__1 = anorm / dmax__;
+ sscal_(&n, &r__1, &d__[1], &c__1);
+ i__3 = n - 1;
+ r__1 = anorm / dmax__;
+ sscal_(&i__3, &r__1, &e[1], &c__1);
+
+ } else if (izero > 0) {
+
+/* Reuse the last matrix by copying back the zeroed out */
+/* elements. */
+
+ if (izero == 1) {
+ d__[1] = z__[1];
+ if (n > 1) {
+ e[1] = z__[2];
+ }
+ } else if (izero == n) {
+ e[n - 1] = z__[0];
+ d__[n] = z__[1];
+ } else {
+ e[izero - 1] = z__[0];
+ d__[izero] = z__[1];
+ e[izero] = z__[2];
+ }
+ }
+
+/* For types 8-10, set one row and column of the matrix to */
+/* zero. */
+
+ izero = 0;
+ if (imat == 8) {
+ izero = 1;
+ z__[1] = d__[1];
+ d__[1] = 0.f;
+ if (n > 1) {
+ z__[2] = e[1];
+ e[1] = 0.f;
+ }
+ } else if (imat == 9) {
+ izero = n;
+ if (n > 1) {
+ z__[0] = e[n - 1];
+ e[n - 1] = 0.f;
+ }
+ z__[1] = d__[n];
+ d__[n] = 0.f;
+ } else if (imat == 10) {
+ izero = (n + 1) / 2;
+ if (izero > 1) {
+ z__[0] = e[izero - 1];
+ e[izero - 1] = 0.f;
+ z__[2] = e[izero];
+ e[izero] = 0.f;
+ }
+ z__[1] = d__[izero];
+ d__[izero] = 0.f;
+ }
+ }
+
+ scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
+ if (n > 1) {
+ i__3 = n - 1;
+ scopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
+ }
+
+/* + TEST 1 */
+/* Factor A as L*D*L' and compute the ratio */
+/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
+
+ spttrf_(&n, &d__[n + 1], &e[n + 1], &info);
+
+/* Check error code from SPTTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "SPTTRF", &info, &izero, " ", &n, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L100;
+ }
+
+ if (info > 0) {
+ rcondc = 0.f;
+ goto L90;
+ }
+
+ sptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &work[1],
+ result);
+
+/* Print the test ratio if greater than or equal to THRESH. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+/* Compute RCONDC = 1 / (norm(A) * norm(inv(A)) */
+
+/* Compute norm(A). */
+
+ anorm = slanst_("1", &n, &d__[1], &e[1]);
+
+/* Use SPTTRS to solve for one column at a time of inv(A), */
+/* computing the maximum column sum as we go. */
+
+ ainvnm = 0.f;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ x[j] = 0.f;
+/* L40: */
+ }
+ x[i__] = 1.f;
+ spttrs_(&n, &c__1, &d__[n + 1], &e[n + 1], &x[1], &lda, &info)
+ ;
+/* Computing MAX */
+ r__1 = ainvnm, r__2 = sasum_(&n, &x[1], &c__1);
+ ainvnm = dmax(r__1,r__2);
+/* L50: */
+ }
+/* Computing MAX */
+ r__1 = 1.f, r__2 = anorm * ainvnm;
+ rcondc = 1.f / dmax(r__1,r__2);
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* Generate NRHS random solution vectors. */
+
+ ix = 1;
+ i__4 = nrhs;
+ for (j = 1; j <= i__4; ++j) {
+ slarnv_(&c__2, iseed, &n, &xact[ix]);
+ ix += lda;
+/* L60: */
+ }
+
+/* Set the right hand side. */
+
+ slaptm_(&n, &nrhs, &c_b46, &d__[1], &e[1], &xact[1], &lda, &
+ c_b47, &b[1], &lda);
+
+/* + TEST 2 */
+/* Solve A*x = b and compute the residual. */
+
+ slacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+ spttrs_(&n, &nrhs, &d__[n + 1], &e[n + 1], &x[1], &lda, &info)
+ ;
+
+/* Check error code from SPTTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "SPTTRS", &info, &c__0, " ", &n, &n, &c_n1,
+ &c_n1, &nrhs, &imat, &nfail, &nerrs, nout);
+ }
+
+ slacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
+ sptt02_(&n, &nrhs, &d__[1], &e[1], &x[1], &lda, &work[1], &
+ lda, &result[1]);
+
+/* + TEST 3 */
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[2]);
+
+/* + TESTS 4, 5, and 6 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "SPTRFS", (ftnlen)32, (ftnlen)6);
+ sptrfs_(&n, &nrhs, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &b[
+ 1], &lda, &x[1], &lda, &rwork[1], &rwork[nrhs + 1], &
+ work[1], &info);
+
+/* Check error code from SPTRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "SPTRFS", &info, &c__0, " ", &n, &n, &c_n1,
+ &c_n1, &nrhs, &imat, &nfail, &nerrs, nout);
+ }
+
+ sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[3]);
+ sptt05_(&n, &nrhs, &d__[1], &e[1], &b[1], &lda, &x[1], &lda, &
+ xact[1], &lda, &rwork[1], &rwork[nrhs + 1], &result[4]
+);
+
+/* Print information about the tests that did not pass the */
+/* threshold. */
+
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L70: */
+ }
+ nrun += 5;
+/* L80: */
+ }
+
+/* + TEST 7 */
+/* Estimate the reciprocal of the condition number of the */
+/* matrix. */
+
+L90:
+ s_copy(srnamc_1.srnamt, "SPTCON", (ftnlen)32, (ftnlen)6);
+ sptcon_(&n, &d__[n + 1], &e[n + 1], &anorm, &rcond, &rwork[1], &
+ info);
+
+/* Check error code from SPTCON. */
+
+ if (info != 0) {
+ alaerh_(path, "SPTCON", &info, &c__0, " ", &n, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+ result[6] = sget06_(&rcond, &rcondc);
+
+/* Print the test ratio if greater than or equal to THRESH. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L100:
+ ;
+ }
+/* L110: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SCHKPT */
+
+} /* schkpt_ */
diff --git a/TESTING/LIN/schkq3.c b/TESTING/LIN/schkq3.c
new file mode 100644
index 0000000..ee272fe
--- /dev/null
+++ b/TESTING/LIN/schkq3.c
@@ -0,0 +1,397 @@
+/* schkq3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static real c_b11 = 0.f;
+static real c_b16 = 1.f;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int schkq3_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nxval, real *thresh, real *a, real *copya, real *s, real *copys, real
+ *tau, real *work, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002 M =\002,i5,\002, N =\002,i5,\002, N"
+ "B =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ real r__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, im, in, lw, nx, lda, inb;
+ real eps;
+ integer mode, info;
+ char path[3];
+ integer ilow, nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer ihigh, nfail, iseed[4], imode, mnmin;
+ extern /* Subroutine */ int icopy_(integer *, integer *, integer *,
+ integer *, integer *);
+ integer istep, nerrs;
+ extern doublereal sqpt01_(integer *, integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *), sqrt11_(
+ integer *, integer *, real *, integer *, real *, real *, integer *
+);
+ integer lwork;
+ extern doublereal sqrt12_(integer *, integer *, real *, integer *, real *,
+ real *, integer *);
+ extern /* Subroutine */ int sgeqp3_(integer *, integer *, real *, integer
+ *, integer *, real *, real *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *), slaord_(char *, integer *, real *, integer
+ *), slacpy_(char *, integer *, integer *, real *, integer
+ *, real *, integer *), slaset_(char *, integer *, integer
+ *, real *, real *, real *, integer *), xlaenv_(integer *,
+ integer *), slatms_(integer *, integer *, char *, integer *, char
+ *, real *, integer *, real *, real *, integer *, integer *, char *
+, real *, integer *, real *, integer *);
+ real result[3];
+
+ /* Fortran I/O blocks */
+ static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKQ3 tests SGEQP3. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* THRESH (input) 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. */
+
+/* A (workspace) REAL array, dimension (MMAX*NMAX) */
+/* where MMAX is the maximum value of M in MVAL and NMAX is the */
+/* maximum value of N in NVAL. */
+
+/* COPYA (workspace) REAL array, dimension (MMAX*NMAX) */
+
+/* S (workspace) REAL array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* COPYS (workspace) REAL array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* TAU (workspace) REAL array, dimension (MMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (MMAX*NMAX + 4*NMAX + MMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --tau;
+ --copys;
+ --s;
+ --copya;
+ --a;
+ --nxval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "Q3", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = slamch_("Epsilon");
+ infoc_1.infot = 0;
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+
+/* Do for each value of M in MVAL. */
+
+ m = mval[im];
+ lda = max(1,m);
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__3 = 1, i__4 = m * max(m,n) + (mnmin << 2) + max(m,n), i__3 =
+ max(i__3,i__4), i__4 = m * n + (mnmin << 1) + (n << 2);
+ lwork = max(i__3,i__4);
+
+ for (imode = 1; imode <= 6; ++imode) {
+ if (! dotype[imode]) {
+ goto L70;
+ }
+
+/* Do for each type of matrix */
+/* 1: zero matrix */
+/* 2: one small singular value */
+/* 3: geometric distribution of singular values */
+/* 4: first n/2 columns fixed */
+/* 5: last n/2 columns fixed */
+/* 6: every second column fixed */
+
+ mode = imode;
+ if (imode > 3) {
+ mode = 1;
+ }
+
+/* Generate test matrix of size m by n using */
+/* singular value distribution indicated by `mode'. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ iwork[i__] = 0;
+/* L20: */
+ }
+ if (imode == 1) {
+ slaset_("Full", &m, &n, &c_b11, &c_b11, ©a[1], &lda);
+ i__3 = mnmin;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ copys[i__] = 0.f;
+/* L30: */
+ }
+ } else {
+ r__1 = 1.f / eps;
+ slatms_(&m, &n, "Uniform", iseed, "Nonsymm", ©s[1], &
+ mode, &r__1, &c_b16, &m, &n, "No packing", ©a[
+ 1], &lda, &work[1], &info);
+ if (imode >= 4) {
+ if (imode == 4) {
+ ilow = 1;
+ istep = 1;
+/* Computing MAX */
+ i__3 = 1, i__4 = n / 2;
+ ihigh = max(i__3,i__4);
+ } else if (imode == 5) {
+/* Computing MAX */
+ i__3 = 1, i__4 = n / 2;
+ ilow = max(i__3,i__4);
+ istep = 1;
+ ihigh = n;
+ } else if (imode == 6) {
+ ilow = 1;
+ istep = 2;
+ ihigh = n;
+ }
+ i__3 = ihigh;
+ i__4 = istep;
+ for (i__ = ilow; i__4 < 0 ? i__ >= i__3 : i__ <= i__3;
+ i__ += i__4) {
+ iwork[i__] = 1;
+/* L40: */
+ }
+ }
+ slaord_("Decreasing", &mnmin, ©s[1], &c__1);
+ }
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+
+/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
+
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ nx = nxval[inb];
+ xlaenv_(&c__3, &nx);
+
+/* Get a working copy of COPYA into A and a copy of */
+/* vector IWORK. */
+
+ slacpy_("All", &m, &n, ©a[1], &lda, &a[1], &lda);
+ icopy_(&n, &iwork[1], &c__1, &iwork[n + 1], &c__1);
+
+/* Compute the QR factorization with pivoting of A */
+
+/* Computing MAX */
+ i__3 = 1, i__5 = (n << 1) + nb * (n + 1);
+ lw = max(i__3,i__5);
+
+/* Compute the QP3 factorization of A */
+
+ s_copy(srnamc_1.srnamt, "SGEQP3", (ftnlen)32, (ftnlen)6);
+ sgeqp3_(&m, &n, &a[1], &lda, &iwork[n + 1], &tau[1], &
+ work[1], &lw, &info);
+
+/* Compute norm(svd(a) - svd(r)) */
+
+ result[0] = sqrt12_(&m, &n, &a[1], &lda, ©s[1], &work[
+ 1], &lwork);
+
+/* Compute norm( A*P - Q*R ) */
+
+ result[1] = sqpt01_(&m, &n, &mnmin, ©a[1], &a[1], &
+ lda, &tau[1], &iwork[n + 1], &work[1], &lwork);
+
+/* Compute Q'*Q */
+
+ result[2] = sqrt11_(&m, &mnmin, &a[1], &lda, &tau[1], &
+ work[1], &lwork);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 1; k <= 3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___28.ciunit = *nout;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "SGEQP3", (ftnlen)6);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L50: */
+ }
+ nrun += 3;
+
+/* L60: */
+ }
+L70:
+ ;
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+
+/* End of SCHKQ3 */
+
+ return 0;
+} /* schkq3_ */
diff --git a/TESTING/LIN/schkql.c b/TESTING/LIN/schkql.c
new file mode 100644
index 0000000..ad1245a
--- /dev/null
+++ b/TESTING/LIN/schkql.c
@@ -0,0 +1,469 @@
+/* schkql.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int schkql_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nxval, integer *nrhs, real *thresh, logical *tsterr, integer *nmax,
+ real *a, real *af, real *aq, real *al, real *ac, real *b, real *x,
+ real *xact, real *tau, real *work, real *rwork, integer *iwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
+ "5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
+ "t(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, ik, im, in, kl, nk, ku, nt, nx, lda, inb, mode,
+ imat, info;
+ char path[3];
+ integer kval[4];
+ char dist[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int sget02_(char *, integer *, integer *, integer
+ *, real *, integer *, real *, integer *, real *, integer *, real *
+, real *);
+ real anorm;
+ integer minmn;
+ extern /* Subroutine */ int sqlt01_(integer *, integer *, real *, real *,
+ real *, real *, integer *, real *, real *, integer *, real *,
+ real *), sqlt02_(integer *, integer *, integer *, real *, real *,
+ real *, real *, integer *, real *, real *, integer *, real *,
+ real *), sqlt03_(integer *, integer *, integer *, real *, real *,
+ real *, real *, integer *, real *, real *, integer *, real *,
+ real *);
+ integer nerrs, lwork;
+ extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ extern logical sgennd_(integer *, integer *, real *, integer *);
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, integer *, integer *), sgeqls_(
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, integer *, real *, integer *, integer *), xlaenv_(integer *,
+ integer *), slatms_(integer *, integer *, char *, integer *, char
+ *, real *, integer *, real *, real *, integer *, integer *, char *
+, real *, integer *, real *, integer *),
+ serrql_(char *, integer *);
+ real result[8];
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKQL tests SGEQLF, SORGQL and SORMQL. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AQ (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AL (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AC (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* B (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* X (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* TAU (workspace) REAL array, dimension (NMAX) */
+
+/* WORK (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --tau;
+ --xact;
+ --x;
+ --b;
+ --ac;
+ --al;
+ --aq;
+ --af;
+ --a;
+ --nxval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "QL", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrql_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+ lda = *nmax;
+ lwork = *nmax * max(*nmax,*nrhs);
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Do for each value of N in NVAL. */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ minmn = min(m,n);
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L50;
+ }
+
+/* Set up parameters with SLATB4 and generate a test matrix */
+/* with SLATMS. */
+
+ slatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
+ slatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, " ", &m, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L50;
+ }
+
+/* Set some values for K: the first value must be MINMN, */
+/* corresponding to the call of SQLT01; other values are */
+/* used in the calls of SQLT02, and must not exceed MINMN. */
+
+ kval[0] = minmn;
+ kval[1] = 0;
+ kval[2] = 1;
+ kval[3] = minmn / 2;
+ if (minmn == 0) {
+ nk = 1;
+ } else if (minmn == 1) {
+ nk = 2;
+ } else if (minmn <= 3) {
+ nk = 3;
+ } else {
+ nk = 4;
+ }
+
+/* Do for each value of K in KVAL */
+
+ i__3 = nk;
+ for (ik = 1; ik <= i__3; ++ik) {
+ k = kval[ik - 1];
+
+/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ nx = nxval[inb];
+ xlaenv_(&c__3, &nx);
+ for (i__ = 1; i__ <= 8; ++i__) {
+ result[i__ - 1] = 0.f;
+ }
+ nt = 2;
+ if (ik == 1) {
+
+/* Test SGEQLF */
+
+ sqlt01_(&m, &n, &a[1], &af[1], &aq[1], &al[1], &
+ lda, &tau[1], &work[1], &lwork, &rwork[1],
+ result);
+ if (m >= n) {
+/* Check the lower-left n-by-n corner */
+ if (! sgennd_(&n, &n, &af[m - n + 1], &lda)) {
+ result[7] = *thresh * 2;
+ }
+ } else {
+/* Check the (n-m)th superdiagonal */
+ if (! sgennd_(&m, &m, &af[(n - m) * lda + 1],
+ &lda)) {
+ result[7] = *thresh * 2;
+ }
+ }
+ ++nt;
+ } else if (m >= n) {
+
+/* Test SORGQL, using factorization */
+/* returned by SQLT01 */
+
+ sqlt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &al[1],
+ &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], result);
+ }
+ if (m >= k) {
+
+/* Test SORMQL, using factorization returned */
+/* by SQLT01 */
+
+ sqlt03_(&m, &n, &k, &af[1], &ac[1], &al[1], &aq[1]
+, &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], &result[2]);
+ nt += 4;
+
+/* If M>=N and K=N, call SGEQLS to solve a system */
+/* with NRHS right hand sides and compute the */
+/* residual. */
+
+ if (k == n && inb == 1) {
+
+/* Generate a solution and set the right */
+/* hand side. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32,
+ (ftnlen)6);
+ slarhs_(path, "New", "Full", "No transpose", &
+ m, &n, &c__0, &c__0, nrhs, &a[1], &
+ lda, &xact[1], &lda, &b[1], &lda,
+ iseed, &info);
+
+ slacpy_("Full", &m, nrhs, &b[1], &lda, &x[1],
+ &lda);
+ s_copy(srnamc_1.srnamt, "SGEQLS", (ftnlen)32,
+ (ftnlen)6);
+ sgeqls_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
+ x[1], &lda, &work[1], &lwork, &info);
+
+/* Check error code from SGEQLS. */
+
+ if (info != 0) {
+ alaerh_(path, "SGEQLS", &info, &c__0,
+ " ", &m, &n, nrhs, &c_n1, &nb, &
+ imat, &nfail, &nerrs, nout);
+ }
+
+ sget02_("No transpose", &m, &n, nrhs, &a[1], &
+ lda, &x[m - n + 1], &lda, &b[1], &lda,
+ &rwork[1], &result[6]);
+ ++nt;
+ }
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__5 = nt;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+/* L30: */
+ }
+/* L40: */
+ }
+L50:
+ ;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SCHKQL */
+
+} /* schkql_ */
diff --git a/TESTING/LIN/schkqp.c b/TESTING/LIN/schkqp.c
new file mode 100644
index 0000000..71af4af
--- /dev/null
+++ b/TESTING/LIN/schkqp.c
@@ -0,0 +1,360 @@
+/* schkqp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static real c_b11 = 0.f;
+static real c_b16 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int schkqp_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, real *thresh, logical *tsterr, real *a,
+ real *copya, real *s, real *copys, real *tau, real *work, integer *
+ iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, type"
+ " \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, im, in, lda;
+ real eps;
+ integer mode, info;
+ char path[3];
+ integer ilow, nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer ihigh, nfail, iseed[4], imode, mnmin, istep;
+ extern doublereal sqpt01_(integer *, integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ integer nerrs;
+ extern doublereal sqrt11_(integer *, integer *, real *, integer *, real *,
+ real *, integer *);
+ integer lwork;
+ extern doublereal sqrt12_(integer *, integer *, real *, integer *, real *,
+ real *, integer *), slamch_(char *);
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *), slaord_(char *, integer *, real *, integer
+ *), sgeqpf_(integer *, integer *, real *, integer *,
+ integer *, real *, real *, integer *), slacpy_(char *, integer *,
+ integer *, real *, integer *, real *, integer *), slaset_(
+ char *, integer *, integer *, real *, real *, real *, integer *), slatms_(integer *, integer *, char *, integer *, char *,
+ real *, integer *, real *, real *, integer *, integer *, char *,
+ real *, integer *, real *, integer *),
+ serrqp_(char *, integer *);
+ real result[3];
+
+ /* Fortran I/O blocks */
+ static cilist io___24 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKQP tests SGEQPF. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) REAL array, dimension (MMAX*NMAX) */
+/* where MMAX is the maximum value of M in MVAL and NMAX is the */
+/* maximum value of N in NVAL. */
+
+/* COPYA (workspace) REAL array, dimension (MMAX*NMAX) */
+
+/* S (workspace) REAL array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* COPYS (workspace) REAL array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* TAU (workspace) REAL array, dimension (MMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (MMAX*NMAX + 4*NMAX + MMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --tau;
+ --copys;
+ --s;
+ --copya;
+ --a;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "QP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = slamch_("Epsilon");
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrqp_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+
+/* Do for each value of M in MVAL. */
+
+ m = mval[im];
+ lda = max(1,m);
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__3 = 1, i__4 = m * max(m,n) + (mnmin << 2) + max(m,n), i__3 =
+ max(i__3,i__4), i__4 = m * n + (mnmin << 1) + (n << 2);
+ lwork = max(i__3,i__4);
+
+ for (imode = 1; imode <= 6; ++imode) {
+ if (! dotype[imode]) {
+ goto L60;
+ }
+
+/* Do for each type of matrix */
+/* 1: zero matrix */
+/* 2: one small singular value */
+/* 3: geometric distribution of singular values */
+/* 4: first n/2 columns fixed */
+/* 5: last n/2 columns fixed */
+/* 6: every second column fixed */
+
+ mode = imode;
+ if (imode > 3) {
+ mode = 1;
+ }
+
+/* Generate test matrix of size m by n using */
+/* singular value distribution indicated by `mode'. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ iwork[i__] = 0;
+/* L20: */
+ }
+ if (imode == 1) {
+ slaset_("Full", &m, &n, &c_b11, &c_b11, ©a[1], &lda);
+ i__3 = mnmin;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ copys[i__] = 0.f;
+/* L30: */
+ }
+ } else {
+ r__1 = 1.f / eps;
+ slatms_(&m, &n, "Uniform", iseed, "Nonsymm", ©s[1], &
+ mode, &r__1, &c_b16, &m, &n, "No packing", ©a[
+ 1], &lda, &work[1], &info);
+ if (imode >= 4) {
+ if (imode == 4) {
+ ilow = 1;
+ istep = 1;
+/* Computing MAX */
+ i__3 = 1, i__4 = n / 2;
+ ihigh = max(i__3,i__4);
+ } else if (imode == 5) {
+/* Computing MAX */
+ i__3 = 1, i__4 = n / 2;
+ ilow = max(i__3,i__4);
+ istep = 1;
+ ihigh = n;
+ } else if (imode == 6) {
+ ilow = 1;
+ istep = 2;
+ ihigh = n;
+ }
+ i__3 = ihigh;
+ i__4 = istep;
+ for (i__ = ilow; i__4 < 0 ? i__ >= i__3 : i__ <= i__3;
+ i__ += i__4) {
+ iwork[i__] = 1;
+/* L40: */
+ }
+ }
+ slaord_("Decreasing", &mnmin, ©s[1], &c__1);
+ }
+
+/* Save A and its singular values */
+
+ slacpy_("All", &m, &n, ©a[1], &lda, &a[1], &lda);
+
+/* Compute the QR factorization with pivoting of A */
+
+ s_copy(srnamc_1.srnamt, "SGEQPF", (ftnlen)32, (ftnlen)6);
+ sgeqpf_(&m, &n, &a[1], &lda, &iwork[1], &tau[1], &work[1], &
+ info);
+
+/* Compute norm(svd(a) - svd(r)) */
+
+ result[0] = sqrt12_(&m, &n, &a[1], &lda, ©s[1], &work[1],
+ &lwork);
+
+/* Compute norm( A*P - Q*R ) */
+
+ result[1] = sqpt01_(&m, &n, &mnmin, ©a[1], &a[1], &lda, &
+ tau[1], &iwork[1], &work[1], &lwork);
+
+/* Compute Q'*Q */
+
+ result[2] = sqrt11_(&m, &mnmin, &a[1], &lda, &tau[1], &work[1]
+, &lwork);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 1; k <= 3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___24.ciunit = *nout;
+ s_wsfe(&io___24);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L50: */
+ }
+ nrun += 3;
+L60:
+ ;
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+
+/* End of SCHKQP */
+
+ return 0;
+} /* schkqp_ */
diff --git a/TESTING/LIN/schkqr.c b/TESTING/LIN/schkqr.c
new file mode 100644
index 0000000..919ad7e
--- /dev/null
+++ b/TESTING/LIN/schkqr.c
@@ -0,0 +1,459 @@
+/* schkqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int schkqr_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nxval, integer *nrhs, real *thresh, logical *tsterr, integer *nmax,
+ real *a, real *af, real *aq, real *ar, real *ac, real *b, real *x,
+ real *xact, real *tau, real *work, real *rwork, integer *iwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
+ "5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
+ "t(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, ik, im, in, kl, nk, ku, nt, nx, lda, inb, mode,
+ imat, info;
+ char path[3];
+ integer kval[4];
+ char dist[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int sget02_(char *, integer *, integer *, integer
+ *, real *, integer *, real *, integer *, real *, integer *, real *
+, real *);
+ real anorm;
+ integer minmn, nerrs;
+ extern /* Subroutine */ int sqrt01_(integer *, integer *, real *, real *,
+ real *, real *, integer *, real *, real *, integer *, real *,
+ real *), sqrt02_(integer *, integer *, integer *, real *, real *,
+ real *, real *, integer *, real *, real *, integer *, real *,
+ real *), sqrt03_(integer *, integer *, integer *, real *, real *,
+ real *, real *, integer *, real *, real *, integer *, real *,
+ real *);
+ integer lwork;
+ extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ extern logical sgennd_(integer *, integer *, real *, integer *);
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, integer *, integer *), xlaenv_(
+ integer *, integer *), slatms_(integer *, integer *, char *,
+ integer *, char *, real *, integer *, real *, real *, integer *,
+ integer *, char *, real *, integer *, real *, integer *), sgeqrs_(integer *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *, integer *, integer *
+);
+ real result[8];
+ extern /* Subroutine */ int serrqr_(char *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKQR tests SGEQRF, SORGQR and SORMQR. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AQ (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AR (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AC (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* B (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* X (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* TAU (workspace) REAL array, dimension (NMAX) */
+
+/* WORK (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --tau;
+ --xact;
+ --x;
+ --b;
+ --ac;
+ --ar;
+ --aq;
+ --af;
+ --a;
+ --nxval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "QR", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrqr_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+ lda = *nmax;
+ lwork = *nmax * max(*nmax,*nrhs);
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Do for each value of N in NVAL. */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ minmn = min(m,n);
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L50;
+ }
+
+/* Set up parameters with SLATB4 and generate a test matrix */
+/* with SLATMS. */
+
+ slatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
+ slatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, " ", &m, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L50;
+ }
+
+/* Set some values for K: the first value must be MINMN, */
+/* corresponding to the call of SQRT01; other values are */
+/* used in the calls of SQRT02, and must not exceed MINMN. */
+
+ kval[0] = minmn;
+ kval[1] = 0;
+ kval[2] = 1;
+ kval[3] = minmn / 2;
+ if (minmn == 0) {
+ nk = 1;
+ } else if (minmn == 1) {
+ nk = 2;
+ } else if (minmn <= 3) {
+ nk = 3;
+ } else {
+ nk = 4;
+ }
+
+/* Do for each value of K in KVAL */
+
+ i__3 = nk;
+ for (ik = 1; ik <= i__3; ++ik) {
+ k = kval[ik - 1];
+
+/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ nx = nxval[inb];
+ xlaenv_(&c__3, &nx);
+ for (i__ = 1; i__ <= 8; ++i__) {
+ result[i__ - 1] = 0.f;
+ }
+ nt = 2;
+ if (ik == 1) {
+
+/* Test SGEQRF */
+
+ sqrt01_(&m, &n, &a[1], &af[1], &aq[1], &ar[1], &
+ lda, &tau[1], &work[1], &lwork, &rwork[1],
+ result);
+ if (! sgennd_(&m, &n, &af[1], &lda)) {
+ result[7] = *thresh * 2;
+ }
+ ++nt;
+ } else if (m >= n) {
+
+/* Test SORGQR, using factorization */
+/* returned by SQRT01 */
+
+ sqrt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &ar[1],
+ &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], result);
+ }
+ if (m >= k) {
+
+/* Test SORMQR, using factorization returned */
+/* by SQRT01 */
+
+ sqrt03_(&m, &n, &k, &af[1], &ac[1], &ar[1], &aq[1]
+, &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], &result[2]);
+ nt += 4;
+
+/* If M>=N and K=N, call SGEQRS to solve a system */
+/* with NRHS right hand sides and compute the */
+/* residual. */
+
+ if (k == n && inb == 1) {
+
+/* Generate a solution and set the right */
+/* hand side. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32,
+ (ftnlen)6);
+ slarhs_(path, "New", "Full", "No transpose", &
+ m, &n, &c__0, &c__0, nrhs, &a[1], &
+ lda, &xact[1], &lda, &b[1], &lda,
+ iseed, &info);
+
+ slacpy_("Full", &m, nrhs, &b[1], &lda, &x[1],
+ &lda);
+ s_copy(srnamc_1.srnamt, "SGEQRS", (ftnlen)32,
+ (ftnlen)6);
+ sgeqrs_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
+ x[1], &lda, &work[1], &lwork, &info);
+
+/* Check error code from SGEQRS. */
+
+ if (info != 0) {
+ alaerh_(path, "SGEQRS", &info, &c__0,
+ " ", &m, &n, nrhs, &c_n1, &nb, &
+ imat, &nfail, &nerrs, nout);
+ }
+
+ sget02_("No transpose", &m, &n, nrhs, &a[1], &
+ lda, &x[1], &lda, &b[1], &lda, &rwork[
+ 1], &result[6]);
+ ++nt;
+ }
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (i__ = 1; i__ <= 8; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+/* L30: */
+ }
+/* L40: */
+ }
+L50:
+ ;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SCHKQR */
+
+} /* schkqr_ */
diff --git a/TESTING/LIN/schkrfp.c b/TESTING/LIN/schkrfp.c
new file mode 100644
index 0000000..6f6878f
--- /dev/null
+++ b/TESTING/LIN/schkrfp.c
@@ -0,0 +1,472 @@
+/* schkrfp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__12 = 12;
+static integer c__0 = 0;
+static integer c__50 = 50;
+static integer c__16 = 16;
+static integer c__9 = 9;
+static integer c__4 = 4;
+static integer c__8 = 8;
+static integer c__6 = 6;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Format strings */
+ static char fmt_9994[] = "(/\002 Tests of the REAL LAPACK RFP routines"
+ " \002,/\002 LAPACK VERSION \002,i1,\002.\002,i1,\002.\002,i1,/"
+ "/\002 The following parameter values will be used:\002)";
+ static char fmt_9996[] = "(\002 !! Invalid input value: \002,a4,\002="
+ "\002,i6,\002; must be >=\002,i6)";
+ static char fmt_9995[] = "(\002 !! Invalid input value: \002,a4,\002="
+ "\002,i6,\002; must be <=\002,i6)";
+ static char fmt_9993[] = "(4x,a4,\002: \002,10i6,/11x,10i6)";
+ static char fmt_9992[] = "(/\002 Routines pass computational tests if te"
+ "st ratio is \002,\002less than\002,f8.2,/)";
+ static char fmt_9999[] = "(/\002 Execution not attempted due to input er"
+ "rors\002)";
+ static char fmt_9991[] = "(\002 Relative machine \002,a,\002 is taken to"
+ " be\002,d16.6)";
+ static char fmt_9998[] = "(/\002 End of tests\002)";
+ static char fmt_9997[] = "(\002 Total time used = \002,f12.2,\002 seco"
+ "nds\002,/)";
+
+ /* System generated locals */
+ integer i__1;
+ real r__1;
+ cllist cl__1;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), e_rsle(void), s_wsfe(cilist *), do_fio(integer *
+ , char *, ftnlen), e_wsfe(void), do_lio(integer *, integer *,
+ char *, ftnlen);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), f_clos(cllist *);
+
+ /* Local variables */
+ real workafac[2500] /* was [50][50] */, workasav[2500] /* was [50][
+ 50] */, workbsav[800] /* was [50][16] */, workainv[2500]
+ /* was [50][50] */, workxact[800] /* was [50][16] */;
+ integer i__;
+ real s1, s2;
+ integer nn, vers_patch__, vers_major__, vers_minor__;
+ real workarfinv[1275], eps;
+ integer nns, nnt, nval[12];
+ real s_temp_spot02__[800] /* was [50][16] */, s_temp_spot03__[2500]
+ /* was [50][50] */, s_work_spot01__[50], s_work_spot02__[50],
+ s_work_spot03__[50];
+ logical fatal;
+ integer nsval[12], ntval[9];
+ real worka[2500] /* was [50][50] */, workb[800] /* was [50][16] */,
+ workx[800] /* was [50][16] */, s_work_slatms__[150],
+ s_work_slansy__[50];
+ extern doublereal slamch_(char *), second_(void);
+ extern /* Subroutine */ int ilaver_(integer *, integer *, integer *);
+ real thresh, workap[1275];
+ logical tsterr;
+ extern /* Subroutine */ int sdrvrf1_(integer *, integer *, integer *,
+ real *, real *, integer *, real *, real *), sdrvrf2_(integer *,
+ integer *, integer *, real *, integer *, real *, real *, real *),
+ sdrvrf3_(integer *, integer *, integer *, real *, real *, integer
+ *, real *, real *, real *, real *, real *, real *), sdrvrf4_(
+ integer *, integer *, integer *, real *, real *, real *, integer *
+, real *, real *, integer *, real *);
+ real workarf[1275];
+ extern /* Subroutine */ int serrrfp_(integer *), sdrvrfp_(integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ real *, real *, real *, real *, real *, real *, real *, real *,
+ real *, real *, real *, real *, real *, real *, real *, real *,
+ real *, real *);
+
+ /* Fortran I/O blocks */
+ static cilist io___3 = { 0, 5, 0, 0, 0 };
+ static cilist io___7 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___8 = { 0, 5, 0, 0, 0 };
+ static cilist io___10 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___11 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___12 = { 0, 5, 0, 0, 0 };
+ static cilist io___15 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___16 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___17 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___18 = { 0, 5, 0, 0, 0 };
+ static cilist io___20 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___21 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___22 = { 0, 5, 0, 0, 0 };
+ static cilist io___24 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___25 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___26 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___27 = { 0, 5, 0, 0, 0 };
+ static cilist io___29 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___30 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___31 = { 0, 5, 0, 0, 0 };
+ static cilist io___33 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___34 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___35 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___36 = { 0, 5, 0, 0, 0 };
+ static cilist io___38 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___39 = { 0, 5, 0, 0, 0 };
+ static cilist io___41 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___45 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___46 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___47 = { 0, 6, 0, 0, 0 };
+ static cilist io___67 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___68 = { 0, 6, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKRFP is the main test program for the REAL linear */
+/* equation routines with RFP storage format */
+
+
+/* Internal Parameters */
+/* =================== */
+
+/* MAXIN INTEGER */
+/* The number of different values that can be used for each of */
+/* M, N, or NB */
+
+/* MAXRHS INTEGER */
+/* The maximum number of right hand sides */
+
+/* NTYPES INTEGER */
+
+/* NMAX INTEGER */
+/* The maximum allowable value for N. */
+
+/* NIN INTEGER */
+/* The unit number for input */
+
+/* NOUT INTEGER */
+/* The unit number for output */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ s1 = second_();
+ fatal = FALSE_;
+
+/* Read a dummy line. */
+
+ s_rsle(&io___3);
+ e_rsle();
+
+/* Report LAPACK version tag (e.g. LAPACK-3.2.0) */
+
+ ilaver_(&vers_major__, &vers_minor__, &vers_patch__);
+ s_wsfe(&io___7);
+ do_fio(&c__1, (char *)&vers_major__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_minor__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_patch__, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+/* Read the values of N */
+
+ s_rsle(&io___8);
+ do_lio(&c__3, &c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nn < 1) {
+ s_wsfe(&io___10);
+ do_fio(&c__1, " NN ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ } else if (nn > 12) {
+ s_wsfe(&io___11);
+ do_fio(&c__1, " NN ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___12);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nval[i__ - 1] < 0) {
+ s_wsfe(&io___15);
+ do_fio(&c__1, " M ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nval[i__ - 1] > 50) {
+ s_wsfe(&io___16);
+ do_fio(&c__1, " M ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__50, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L10: */
+ }
+ if (nn > 0) {
+ s_wsfe(&io___17);
+ do_fio(&c__1, "N ", (ftnlen)4);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of NRHS */
+
+ s_rsle(&io___18);
+ do_lio(&c__3, &c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nns < 1) {
+ s_wsfe(&io___20);
+ do_fio(&c__1, " NNS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nns = 0;
+ fatal = TRUE_;
+ } else if (nns > 12) {
+ s_wsfe(&io___21);
+ do_fio(&c__1, " NNS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nns = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___22);
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nsval[i__ - 1] < 0) {
+ s_wsfe(&io___24);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nsval[i__ - 1] > 16) {
+ s_wsfe(&io___25);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__16, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L30: */
+ }
+ if (nns > 0) {
+ s_wsfe(&io___26);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the matrix types */
+
+ s_rsle(&io___27);
+ do_lio(&c__3, &c__1, (char *)&nnt, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nnt < 1) {
+ s_wsfe(&io___29);
+ do_fio(&c__1, " NMA", (ftnlen)4);
+ do_fio(&c__1, (char *)&nnt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nnt = 0;
+ fatal = TRUE_;
+ } else if (nnt > 9) {
+ s_wsfe(&io___30);
+ do_fio(&c__1, " NMA", (ftnlen)4);
+ do_fio(&c__1, (char *)&nnt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nnt = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___31);
+ i__1 = nnt;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = nnt;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (ntval[i__ - 1] < 0) {
+ s_wsfe(&io___33);
+ do_fio(&c__1, "TYPE", (ftnlen)4);
+ do_fio(&c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (ntval[i__ - 1] > 9) {
+ s_wsfe(&io___34);
+ do_fio(&c__1, "TYPE", (ftnlen)4);
+ do_fio(&c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L320: */
+ }
+ if (nnt > 0) {
+ s_wsfe(&io___35);
+ do_fio(&c__1, "TYPE", (ftnlen)4);
+ i__1 = nnt;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the threshold value for the test ratios. */
+
+ s_rsle(&io___36);
+ do_lio(&c__4, &c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_rsle();
+ s_wsfe(&io___38);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(real));
+ e_wsfe();
+
+/* Read the flag that indicates whether to test the error exits. */
+
+ s_rsle(&io___39);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+
+ if (fatal) {
+ s_wsfe(&io___41);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+ if (fatal) {
+ s_wsfe(&io___42);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Calculate and print the machine dependent constants. */
+
+ eps = slamch_("Underflow threshold");
+ s_wsfe(&io___44);
+ do_fio(&c__1, "underflow", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+ eps = slamch_("Overflow threshold");
+ s_wsfe(&io___45);
+ do_fio(&c__1, "overflow ", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+ eps = slamch_("Epsilon");
+ s_wsfe(&io___46);
+ do_fio(&c__1, "precision", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_wsle(&io___47);
+ e_wsle();
+
+/* Test the error exit of: */
+
+ if (tsterr) {
+ serrrfp_(&c__6);
+ }
+
+/* Test the routines: spftrf, spftri, spftrs (as in SDRVPO). */
+/* This also tests the routines: stfsm, stftri, stfttr, strttf. */
+
+ sdrvrfp_(&c__6, &nn, nval, &nns, nsval, &nnt, ntval, &thresh, worka,
+ workasav, workafac, workainv, workb, workbsav, workxact, workx,
+ workarf, workarfinv, s_work_slatms__, s_work_spot01__,
+ s_temp_spot02__, s_temp_spot03__, s_work_slansy__,
+ s_work_spot02__, s_work_spot03__);
+
+/* Test the routine: slansf */
+
+ sdrvrf1_(&c__6, &nn, nval, &thresh, worka, &c__50, workarf,
+ s_work_slansy__);
+
+/* Test the convertion routines: */
+/* stfttp, stpttf, stfttr, strttf, strttp and stpttr. */
+
+ sdrvrf2_(&c__6, &nn, nval, worka, &c__50, workarf, workap, workasav);
+
+/* Test the routine: stfsm */
+
+ sdrvrf3_(&c__6, &nn, nval, &thresh, worka, &c__50, workarf, workainv,
+ workafac, s_work_slansy__, s_work_spot03__, s_work_spot01__);
+
+
+/* Test the routine: ssfrk */
+
+ sdrvrf4_(&c__6, &nn, nval, &thresh, worka, workafac, &c__50, workarf,
+ workainv, &c__50, s_work_slansy__);
+
+ cl__1.cerr = 0;
+ cl__1.cunit = 5;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ s2 = second_();
+ s_wsfe(&io___67);
+ e_wsfe();
+ s_wsfe(&io___68);
+ r__1 = s2 - s1;
+ do_fio(&c__1, (char *)&r__1, (ftnlen)sizeof(real));
+ e_wsfe();
+
+
+/* End of SCHKRFP */
+
+ return 0;
+} /* MAIN__ */
+
+/* Main program alias */ int schkrfp_ () { MAIN__ (); return 0; }
diff --git a/TESTING/LIN/schkrq.c b/TESTING/LIN/schkrq.c
new file mode 100644
index 0000000..84faf01
--- /dev/null
+++ b/TESTING/LIN/schkrq.c
@@ -0,0 +1,469 @@
+/* schkrq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int schkrq_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nxval, integer *nrhs, real *thresh, logical *tsterr, integer *nmax,
+ real *a, real *af, real *aq, real *ar, real *ac, real *b, real *x,
+ real *xact, real *tau, real *work, real *rwork, integer *iwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
+ "5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
+ "t(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, ik, im, in, kl, nk, ku, nt, nx, lda, inb, mode,
+ imat, info;
+ char path[3];
+ integer kval[4];
+ char dist[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int sget02_(char *, integer *, integer *, integer
+ *, real *, integer *, real *, integer *, real *, integer *, real *
+, real *);
+ real anorm;
+ integer minmn, nerrs;
+ extern /* Subroutine */ int srqt01_(integer *, integer *, real *, real *,
+ real *, real *, integer *, real *, real *, integer *, real *,
+ real *), srqt02_(integer *, integer *, integer *, real *, real *,
+ real *, real *, integer *, real *, real *, integer *, real *,
+ real *), srqt03_(integer *, integer *, integer *, real *, real *,
+ real *, real *, integer *, real *, real *, integer *, real *,
+ real *);
+ integer lwork;
+ extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ extern logical sgennd_(integer *, integer *, real *, integer *);
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ real cndnum;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, integer *, integer *), xlaenv_(
+ integer *, integer *), slatms_(integer *, integer *, char *,
+ integer *, char *, real *, integer *, real *, real *, integer *,
+ integer *, char *, real *, integer *, real *, integer *), sgerqs_(integer *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *, integer *, integer *
+);
+ real result[8];
+ extern /* Subroutine */ int serrrq_(char *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKRQ tests SGERQF, SORGRQ and SORMRQ. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AQ (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AR (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AC (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* B (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* X (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* TAU (workspace) REAL array, dimension (NMAX) */
+
+/* WORK (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --tau;
+ --xact;
+ --x;
+ --b;
+ --ac;
+ --ar;
+ --aq;
+ --af;
+ --a;
+ --nxval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "RQ", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrrq_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+ lda = *nmax;
+ lwork = *nmax * max(*nmax,*nrhs);
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Do for each value of N in NVAL. */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ minmn = min(m,n);
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L50;
+ }
+
+/* Set up parameters with SLATB4 and generate a test matrix */
+/* with SLATMS. */
+
+ slatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
+ slatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, " ", &m, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L50;
+ }
+
+/* Set some values for K: the first value must be MINMN, */
+/* corresponding to the call of SRQT01; other values are */
+/* used in the calls of SRQT02, and must not exceed MINMN. */
+
+ kval[0] = minmn;
+ kval[1] = 0;
+ kval[2] = 1;
+ kval[3] = minmn / 2;
+ if (minmn == 0) {
+ nk = 1;
+ } else if (minmn == 1) {
+ nk = 2;
+ } else if (minmn <= 3) {
+ nk = 3;
+ } else {
+ nk = 4;
+ }
+
+/* Do for each value of K in KVAL */
+
+ i__3 = nk;
+ for (ik = 1; ik <= i__3; ++ik) {
+ k = kval[ik - 1];
+
+/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ nx = nxval[inb];
+ xlaenv_(&c__3, &nx);
+ for (i__ = 1; i__ <= 8; ++i__) {
+ result[i__ - 1] = 0.f;
+ }
+ nt = 2;
+ if (ik == 1) {
+
+/* Test SGERQF */
+
+ srqt01_(&m, &n, &a[1], &af[1], &aq[1], &ar[1], &
+ lda, &tau[1], &work[1], &lwork, &rwork[1],
+ result);
+ if (m <= n) {
+/* Check the upper-right m-by-m corner */
+ if (! sgennd_(&m, &m, &af[lda * (n - m) + 1],
+ &lda)) {
+ result[7] = *thresh * 2;
+ }
+ } else {
+/* Check the (m-n)th subdiagonal */
+ i__ = m - n;
+ if (! sgennd_(&n, &n, &af[i__ + 1], &lda)) {
+ result[7] = *thresh * 2;
+ }
+ }
+ ++nt;
+ } else if (m <= n) {
+
+/* Test SORGRQ, using factorization */
+/* returned by SRQT01 */
+
+ srqt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &ar[1],
+ &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], result);
+ }
+ if (m >= k) {
+
+/* Test SORMRQ, using factorization returned */
+/* by SRQT01 */
+
+ srqt03_(&m, &n, &k, &af[1], &ac[1], &ar[1], &aq[1]
+, &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], &result[2]);
+ nt += 4;
+
+/* If M>=N and K=N, call SGERQS to solve a system */
+/* with NRHS right hand sides and compute the */
+/* residual. */
+
+ if (k == m && inb == 1) {
+
+/* Generate a solution and set the right */
+/* hand side. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32,
+ (ftnlen)6);
+ slarhs_(path, "New", "Full", "No transpose", &
+ m, &n, &c__0, &c__0, nrhs, &a[1], &
+ lda, &xact[1], &lda, &b[1], &lda,
+ iseed, &info);
+
+ slacpy_("Full", &m, nrhs, &b[1], &lda, &x[n -
+ m + 1], &lda);
+ s_copy(srnamc_1.srnamt, "SGERQS", (ftnlen)32,
+ (ftnlen)6);
+ sgerqs_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
+ x[1], &lda, &work[1], &lwork, &info);
+
+/* Check error code from SGERQS. */
+
+ if (info != 0) {
+ alaerh_(path, "SGERQS", &info, &c__0,
+ " ", &m, &n, nrhs, &c_n1, &nb, &
+ imat, &nfail, &nerrs, nout);
+ }
+
+ sget02_("No transpose", &m, &n, nrhs, &a[1], &
+ lda, &x[1], &lda, &b[1], &lda, &rwork[
+ 1], &result[6]);
+ ++nt;
+ }
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (i__ = 1; i__ <= 8; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+/* L30: */
+ }
+/* L40: */
+ }
+L50:
+ ;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SCHKRQ */
+
+} /* schkrq_ */
diff --git a/TESTING/LIN/schksp.c b/TESTING/LIN/schksp.c
new file mode 100644
index 0000000..2c14c02
--- /dev/null
+++ b/TESTING/LIN/schksp.c
@@ -0,0 +1,630 @@
+/* schksp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__8 = 8;
+
+/* Subroutine */ int schksp_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, real *thresh, logical *tsterr, integer *
+ nmax, real *a, real *afac, real *ainv, real *b, real *x, real *xact,
+ real *work, real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
+ "12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, in, kl, ku, nt, lda, npp, ioff, mode, imat,
+ info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ extern logical lsame_(char *, char *);
+ real rcond;
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *);
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ real anorm;
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int sppt02_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *),
+ scopy_(integer *, real *, integer *, real *, integer *), sppt03_(
+ char *, integer *, real *, real *, real *, integer *, real *,
+ real *, real *), sppt05_(char *, integer *, integer *,
+ real *, real *, integer *, real *, integer *, real *, integer *,
+ real *, real *, real *), sspt01_(char *, integer *, real *
+, real *, integer *, real *, integer *, real *, real *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ real rcondc;
+ char packit[1];
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ real cndnum;
+ logical trfcon;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, integer *, integer *);
+ extern doublereal slansp_(char *, char *, integer *, real *, real *);
+ extern /* Subroutine */ int slatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, real *, integer *, real *, integer *), sspcon_(char *, integer *, real *, integer *, real *,
+ real *, real *, integer *, integer *);
+ real result[8];
+ extern /* Subroutine */ int ssprfs_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, integer *, real *,
+ real *, real *, integer *, integer *), ssptrf_(char *,
+ integer *, real *, integer *, integer *), ssptri_(char *,
+ integer *, real *, integer *, real *, integer *), serrsy_(
+ char *, integer *), ssptrs_(char *, integer *, integer *,
+ real *, integer *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___38 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKSP tests SSPTRF, -TRI, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) REAL array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AFAC (workspace) REAL array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AINV (workspace) REAL array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) REAL array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(2,NSMAX)) */
+
+/* RWORK (workspace) REAL array, */
+/* dimension (NMAX+2*NSMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "SP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrsy_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 10;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ izero = 0;
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L160;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L160;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ if (lsame_(uplo, "U")) {
+ *(unsigned char *)packit = 'C';
+ } else {
+ *(unsigned char *)packit = 'R';
+ }
+
+/* Set up parameters with SLATB4 and generate a test matrix */
+/* with SLATMS. */
+
+ slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
+ slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
+ 1], &info);
+
+/* Check error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L150;
+ }
+
+/* For types 3-6, zero one or more rows and columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * izero / 2;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff] = 0.f;
+ ioff += i__;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff] = 0.f;
+ ioff = ioff + n - i__;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ ioff = 0;
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L60: */
+ }
+ ioff += j;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L80: */
+ }
+ ioff = ioff + n - j;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Compute the L*D*L' or U*D*U' factorization of the matrix. */
+
+ npp = n * (n + 1) / 2;
+ scopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ s_copy(srnamc_1.srnamt, "SSPTRF", (ftnlen)32, (ftnlen)6);
+ ssptrf_(uplo, &n, &afac[1], &iwork[1], &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from SSPTRF. */
+
+ if (info != k) {
+ alaerh_(path, "SSPTRF", &info, &k, uplo, &n, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+ if (info != 0) {
+ trfcon = TRUE_;
+ } else {
+ trfcon = FALSE_;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ sspt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &ainv[1], &lda,
+ &rwork[1], result);
+ nt = 1;
+
+/* + TEST 2 */
+/* Form the inverse and compute the residual. */
+
+ if (! trfcon) {
+ scopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
+ s_copy(srnamc_1.srnamt, "SSPTRI", (ftnlen)32, (ftnlen)6);
+ ssptri_(uplo, &n, &ainv[1], &iwork[1], &work[1], &info);
+
+/* Check error code from SSPTRI. */
+
+ if (info != 0) {
+ alaerh_(path, "SSPTRI", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ sppt03_(uplo, &n, &a[1], &ainv[1], &work[1], &lda, &rwork[
+ 1], &rcondc, &result[1]);
+ nt = 2;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+
+/* Do only the condition estimate if INFO is not 0. */
+
+ if (trfcon) {
+ rcondc = 0.f;
+ goto L140;
+ }
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, (ftnlen)6);
+ slarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &nrhs, &
+ a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
+ info);
+ slacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "SSPTRS", (ftnlen)32, (ftnlen)6);
+ ssptrs_(uplo, &n, &nrhs, &afac[1], &iwork[1], &x[1], &lda,
+ &info);
+
+/* Check error code from SSPTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "SSPTRS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ slacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
+ sppt02_(uplo, &n, &nrhs, &a[1], &x[1], &lda, &work[1], &
+ lda, &rwork[1], &result[2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "SSPRFS", (ftnlen)32, (ftnlen)6);
+ ssprfs_(uplo, &n, &nrhs, &a[1], &afac[1], &iwork[1], &b[1]
+, &lda, &x[1], &lda, &rwork[1], &rwork[nrhs + 1],
+ &work[1], &iwork[n + 1], &info);
+
+/* Check error code from SSPRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "SSPRFS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[4]);
+ sppt05_(uplo, &n, &nrhs, &a[1], &b[1], &lda, &x[1], &lda,
+ &xact[1], &lda, &rwork[1], &rwork[nrhs + 1], &
+ result[5]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L120: */
+ }
+ nrun += 5;
+/* L130: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+L140:
+ anorm = slansp_("1", uplo, &n, &a[1], &rwork[1]);
+ s_copy(srnamc_1.srnamt, "SSPCON", (ftnlen)32, (ftnlen)6);
+ sspcon_(uplo, &n, &afac[1], &iwork[1], &anorm, &rcond, &work[
+ 1], &iwork[n + 1], &info);
+
+/* Check error code from SSPCON. */
+
+ if (info != 0) {
+ alaerh_(path, "SSPCON", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+ result[7] = sget06_(&rcond, &rcondc);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___43.ciunit = *nout;
+ s_wsfe(&io___43);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L150:
+ ;
+ }
+L160:
+ ;
+ }
+/* L170: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SCHKSP */
+
+} /* schksp_ */
diff --git a/TESTING/LIN/schksy.c b/TESTING/LIN/schksy.c
new file mode 100644
index 0000000..fc66414
--- /dev/null
+++ b/TESTING/LIN/schksy.c
@@ -0,0 +1,672 @@
+/* schksy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__8 = 8;
+
+/* Subroutine */ int schksy_(logical *dotype, integer *nn, integer *nval,
+ integer *nnb, integer *nbval, integer *nns, integer *nsval, real *
+ thresh, logical *tsterr, integer *nmax, real *a, real *afac, real *
+ ainv, real *b, real *x, real *xact, real *work, real *rwork, integer *
+ iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
+ "=\002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
+ "12.5)";
+ static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002"
+ ",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
+ ;
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, nb, in, kl, ku, nt, lda, inb, ioff, mode,
+ imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ real rcond;
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *);
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ real anorm;
+ extern /* Subroutine */ int spot02_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, real *, real *);
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int spot03_(char *, integer *, real *, integer *,
+ real *, integer *, real *, integer *, real *, real *, real *), spot05_(char *, integer *, integer *, real *, integer *,
+ real *, integer *, real *, integer *, real *, integer *, real *,
+ real *, real *);
+ integer lwork;
+ logical zerot;
+ extern /* Subroutine */ int ssyt01_(char *, integer *, real *, integer *,
+ real *, integer *, integer *, real *, integer *, real *, real *);
+ char xtype[1];
+ extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ real rcondc;
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ real cndnum;
+ logical trfcon;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, integer *, integer *), xlaenv_(
+ integer *, integer *), slatms_(integer *, integer *, char *,
+ integer *, char *, real *, integer *, real *, real *, integer *,
+ integer *, char *, real *, integer *, real *, integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+ real result[8];
+ extern /* Subroutine */ int ssycon_(char *, integer *, real *, integer *,
+ integer *, real *, real *, real *, integer *, integer *),
+ serrsy_(char *, integer *), ssyrfs_(char *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *, real *
+, integer *, real *, integer *, real *, real *, real *, integer *,
+ integer *), ssytrf_(char *, integer *, real *, integer *,
+ integer *, real *, integer *, integer *), ssytri_(char *,
+ integer *, real *, integer *, integer *, real *, integer *), ssytrs_(char *, integer *, integer *, real *, integer *,
+ integer *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKSY tests SSYTRF, -TRI, -TRS, -RFS, and -CON. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* B (workspace) REAL array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "SY", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrsy_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 10;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ izero = 0;
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L170;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L170;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Set up parameters with SLATB4 and generate a test matrix */
+/* with SLATMS. */
+
+ slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
+ slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
+ &info);
+
+/* Check error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L160;
+ }
+
+/* For types 3-6, zero one or more rows and columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * lda;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff] = 0.f;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff] = 0.f;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ ioff = 0;
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L60: */
+ }
+ ioff += lda;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L80: */
+ }
+ ioff += lda;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Do for each value of NB in NBVAL */
+
+ i__3 = *nnb;
+ for (inb = 1; inb <= i__3; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the L*D*L' or U*D*U' factorization of the */
+/* matrix. */
+
+ slacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ lwork = max(2,nb) * lda;
+ s_copy(srnamc_1.srnamt, "SSYTRF", (ftnlen)32, (ftnlen)6);
+ ssytrf_(uplo, &n, &afac[1], &lda, &iwork[1], &ainv[1], &
+ lwork, &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from SSYTRF. */
+
+ if (info != k) {
+ alaerh_(path, "SSYTRF", &info, &k, uplo, &n, &n, &
+ c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
+ }
+ if (info != 0) {
+ trfcon = TRUE_;
+ } else {
+ trfcon = FALSE_;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ ssyt01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &iwork[1],
+ &ainv[1], &lda, &rwork[1], result);
+ nt = 1;
+
+/* + TEST 2 */
+/* Form the inverse and compute the residual. */
+
+ if (inb == 1 && ! trfcon) {
+ slacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
+ s_copy(srnamc_1.srnamt, "SSYTRI", (ftnlen)32, (ftnlen)
+ 6);
+ ssytri_(uplo, &n, &ainv[1], &lda, &iwork[1], &work[1],
+ &info);
+
+/* Check error code from SSYTRI. */
+
+ if (info != 0) {
+ alaerh_(path, "SSYTRI", &info, &c_n1, uplo, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ spot03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &work[
+ 1], &lda, &rwork[1], &rcondc, &result[1]);
+ nt = 2;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+
+/* Skip the other tests if this is not the first block */
+/* size. */
+
+ if (inb > 1) {
+ goto L150;
+ }
+
+/* Do only the condition estimate if INFO is not 0. */
+
+ if (trfcon) {
+ rcondc = 0.f;
+ goto L140;
+ }
+
+ i__4 = *nns;
+ for (irhs = 1; irhs <= i__4; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ slarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ slacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "SSYTRS", (ftnlen)32, (ftnlen)
+ 6);
+ ssytrs_(uplo, &n, &nrhs, &afac[1], &lda, &iwork[1], &
+ x[1], &lda, &info);
+
+/* Check error code from SSYTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "SSYTRS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ slacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &
+ lda);
+ spot02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
+ work[1], &lda, &rwork[1], &result[2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "SSYRFS", (ftnlen)32, (ftnlen)
+ 6);
+ ssyrfs_(uplo, &n, &nrhs, &a[1], &lda, &afac[1], &lda,
+ &iwork[1], &b[1], &lda, &x[1], &lda, &rwork[1]
+, &rwork[nrhs + 1], &work[1], &iwork[n + 1], &
+ info);
+
+/* Check error code from SSYRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "SSYRFS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[4]);
+ spot05_(uplo, &n, &nrhs, &a[1], &lda, &b[1], &lda, &x[
+ 1], &lda, &xact[1], &lda, &rwork[1], &rwork[
+ nrhs + 1], &result[5]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L120: */
+ }
+ nrun += 5;
+/* L130: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+L140:
+ anorm = slansy_("1", uplo, &n, &a[1], &lda, &rwork[1]);
+ s_copy(srnamc_1.srnamt, "SSYCON", (ftnlen)32, (ftnlen)6);
+ ssycon_(uplo, &n, &afac[1], &lda, &iwork[1], &anorm, &
+ rcond, &work[1], &iwork[n + 1], &info);
+
+/* Check error code from SSYCON. */
+
+ if (info != 0) {
+ alaerh_(path, "SSYCON", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ result[7] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L150:
+ ;
+ }
+
+L160:
+ ;
+ }
+L170:
+ ;
+ }
+/* L180: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SCHKSY */
+
+} /* schksy_ */
diff --git a/TESTING/LIN/schktb.c b/TESTING/LIN/schktb.c
new file mode 100644
index 0000000..269a8f6
--- /dev/null
+++ b/TESTING/LIN/schktb.c
@@ -0,0 +1,738 @@
+/* schktb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static real c_b14 = 0.f;
+static real c_b15 = 1.f;
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c__3 = 3;
+static integer c_n1 = -1;
+static integer c__6 = 6;
+static integer c__4 = 4;
+static integer c__7 = 7;
+static integer c__8 = 8;
+
+/* Subroutine */ int schktb_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, real *thresh, logical *tsterr, integer *
+ nmax, real *ab, real *ainv, real *b, real *x, real *xact, real *work,
+ real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', TRANS='\002,a1,\002"
+ "', DIAG='\002,a1,\002', N=\002,i5,\002, K"
+ "D=\002,i5,\002, NRHS=\002,i5,\002, type \002,i2,\002, test(\002,"
+ "i2,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
+ "'\002,a1,\002',\002,i5,\002,\002,i5,\002, ... ), type \002,i2"
+ ",\002, test(\002,i2,\002)=\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
+ "'\002,a1,\002', '\002,a1,\002',\002,i5,\002,\002,i5,\002, ... )"
+ ", type \002,i2,\002, test(\002,i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[3], a__2[4];
+ integer i__1, i__2, i__3, i__4, i__5, i__6[3], i__7[4];
+ char ch__1[3], ch__2[4];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
+ char **, integer *, integer *, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n, kd, ik, in, nk, lda, ldab;
+ char diag[1];
+ integer imat, info;
+ char path[3];
+ integer irhs, nrhs;
+ char norm[1], uplo[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer idiag;
+ real scale;
+ integer nfail, iseed[4];
+ extern logical lsame_(char *, char *);
+ real rcond;
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *);
+ integer nimat;
+ real anorm;
+ integer itran;
+ extern /* Subroutine */ int stbt02_(char *, char *, char *, integer *,
+ integer *, integer *, real *, integer *, real *, integer *, real *
+, integer *, real *, real *), stbt03_(
+ char *, char *, char *, integer *, integer *, integer *, real *,
+ integer *, real *, real *, real *, real *, integer *, real *,
+ integer *, real *, real *), stbt05_(char *
+, char *, char *, integer *, integer *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, real *, real *), stbt06_(real *,
+ real *, char *, char *, integer *, integer *, real *, integer *,
+ real *, real *);
+ char trans[1];
+ integer iuplo, nerrs;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), stbsv_(char *, char *, char *, integer *, integer *,
+ real *, integer *, real *, integer *);
+ char xtype[1];
+ integer nimat2;
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ real rcondc, rcondi;
+ extern doublereal slantb_(char *, char *, char *, integer *, integer *,
+ real *, integer *, real *);
+ real rcondo;
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int slatbs_(char *, char *, char *, char *,
+ integer *, integer *, real *, integer *, real *, real *, real *,
+ integer *), slattb_(integer *,
+ char *, char *, char *, integer *, integer *, integer *, real *,
+ integer *, real *, real *, integer *),
+ slacpy_(char *, integer *, integer *, real *, integer *, real *,
+ integer *), slarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, integer *,
+ integer *), slaset_(char *,
+ integer *, integer *, real *, real *, real *, integer *),
+ stbcon_(char *, char *, char *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, integer *);
+ extern doublereal slantr_(char *, char *, char *, integer *, integer *,
+ real *, integer *, real *);
+ extern /* Subroutine */ int stbrfs_(char *, char *, char *, integer *,
+ integer *, integer *, real *, integer *, real *, integer *, real *
+, integer *, real *, real *, real *, integer *, integer *);
+ real result[8];
+ extern /* Subroutine */ int serrtr_(char *, integer *), stbtrs_(
+ char *, char *, char *, integer *, integer *, integer *, real *,
+ integer *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKTB tests STBTRS, -RFS, and -CON, and SLATBS. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The leading dimension of the work arrays. */
+/* NMAX >= the maximum value of N in NVAL. */
+
+/* AB (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* B (workspace) REAL array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --ab;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "TB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrtr_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL */
+
+ n = nval[in];
+ lda = max(1,n);
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ nimat2 = 17;
+ if (n <= 0) {
+ nimat = 1;
+ nimat2 = 10;
+ }
+
+/* Computing MIN */
+ i__2 = n + 1;
+ nk = min(i__2,4);
+ i__2 = nk;
+ for (ik = 1; ik <= i__2; ++ik) {
+
+/* Do for KD = 0, N, (3N-1)/4, and (N+1)/4. This order makes */
+/* it easier to skip redundant values for small values of N. */
+
+ if (ik == 1) {
+ kd = 0;
+ } else if (ik == 2) {
+ kd = max(n,0);
+ } else if (ik == 3) {
+ kd = (n * 3 - 1) / 4;
+ } else if (ik == 4) {
+ kd = (n + 1) / 4;
+ }
+ ldab = kd + 1;
+
+ i__3 = nimat;
+ for (imat = 1; imat <= i__3; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L90;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+
+/* Call SLATTB to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "SLATTB", (ftnlen)32, (ftnlen)6);
+ slattb_(&imat, uplo, "No transpose", diag, iseed, &n, &kd,
+ &ab[1], &ldab, &x[1], &work[1], &info);
+
+/* Set IDIAG = 1 for non-unit matrices, 2 for unit. */
+
+ if (lsame_(diag, "N")) {
+ idiag = 1;
+ } else {
+ idiag = 2;
+ }
+
+/* Form the inverse of A so we can get a good estimate */
+/* of RCONDC = 1/(norm(A) * norm(inv(A))). */
+
+ slaset_("Full", &n, &n, &c_b14, &c_b15, &ainv[1], &lda);
+ if (lsame_(uplo, "U")) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ stbsv_(uplo, "No transpose", diag, &j, &kd, &ab[1]
+, &ldab, &ainv[(j - 1) * lda + 1], &c__1);
+/* L20: */
+ }
+ } else {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__5 = n - j + 1;
+ stbsv_(uplo, "No transpose", diag, &i__5, &kd, &
+ ab[(j - 1) * ldab + 1], &ldab, &ainv[(j -
+ 1) * lda + j], &c__1);
+/* L30: */
+ }
+ }
+
+/* Compute the 1-norm condition number of A. */
+
+ anorm = slantb_("1", uplo, diag, &n, &kd, &ab[1], &ldab, &
+ rwork[1]);
+ ainvnm = slantr_("1", uplo, diag, &n, &n, &ainv[1], &lda,
+ &rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondo = 1.f;
+ } else {
+ rcondo = 1.f / anorm / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ anorm = slantb_("I", uplo, diag, &n, &kd, &ab[1], &ldab, &
+ rwork[1]);
+ ainvnm = slantr_("I", uplo, diag, &n, &n, &ainv[1], &lda,
+ &rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondi = 1.f;
+ } else {
+ rcondi = 1.f / anorm / ainvnm;
+ }
+
+ i__4 = *nns;
+ for (irhs = 1; irhs <= i__4; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, or A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itran - 1];
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+
+/* + TEST 1 */
+/* Solve and compute residual for op(A)*x = b. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, (
+ ftnlen)6);
+ slarhs_(path, xtype, uplo, trans, &n, &n, &kd, &
+ idiag, &nrhs, &ab[1], &ldab, &xact[1], &
+ lda, &b[1], &lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ slacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "STBTRS", (ftnlen)32, (
+ ftnlen)6);
+ stbtrs_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1],
+ &ldab, &x[1], &lda, &info);
+
+/* Check error code from STBTRS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__6[0] = 1, a__1[0] = uplo;
+ i__6[1] = 1, a__1[1] = trans;
+ i__6[2] = 1, a__1[2] = diag;
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)3);
+ alaerh_(path, "STBTRS", &info, &c__0, ch__1, &
+ n, &n, &kd, &kd, &nrhs, &imat, &nfail,
+ &nerrs, nout);
+ }
+
+ stbt02_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1],
+ &ldab, &x[1], &lda, &b[1], &lda, &work[1]
+, result)
+ ;
+
+/* + TEST 2 */
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[1]);
+
+/* + TESTS 3, 4, and 5 */
+/* Use iterative refinement to improve the solution */
+/* and compute error bounds. */
+
+ s_copy(srnamc_1.srnamt, "STBRFS", (ftnlen)32, (
+ ftnlen)6);
+ stbrfs_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1],
+ &ldab, &b[1], &lda, &x[1], &lda, &rwork[
+ 1], &rwork[nrhs + 1], &work[1], &iwork[1],
+ &info);
+
+/* Check error code from STBRFS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__6[0] = 1, a__1[0] = uplo;
+ i__6[1] = 1, a__1[1] = trans;
+ i__6[2] = 1, a__1[2] = diag;
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)3);
+ alaerh_(path, "STBRFS", &info, &c__0, ch__1, &
+ n, &n, &kd, &kd, &nrhs, &imat, &nfail,
+ &nerrs, nout);
+ }
+
+ sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ stbt05_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1],
+ &ldab, &b[1], &lda, &x[1], &lda, &xact[1]
+, &lda, &rwork[1], &rwork[nrhs + 1], &
+ result[3]);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 1; k <= 5; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L40: */
+ }
+ nrun += 5;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* + TEST 6 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+ s_copy(srnamc_1.srnamt, "STBCON", (ftnlen)32, (ftnlen)
+ 6);
+ stbcon_(norm, uplo, diag, &n, &kd, &ab[1], &ldab, &
+ rcond, &work[1], &iwork[1], &info);
+
+/* Check error code from STBCON. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__6[0] = 1, a__1[0] = norm;
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = diag;
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)3);
+ alaerh_(path, "STBCON", &info, &c__0, ch__1, &n, &
+ n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ stbt06_(&rcond, &rcondc, uplo, diag, &n, &kd, &ab[1],
+ &ldab, &rwork[1], &result[5]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "STBCON", (ftnlen)6);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L70: */
+ }
+/* L80: */
+ }
+L90:
+ ;
+ }
+
+/* Use pathological test matrices to test SLATBS. */
+
+ i__3 = nimat2;
+ for (imat = 10; imat <= i__3; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, and A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[
+ itran - 1];
+
+/* Call SLATTB to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "SLATTB", (ftnlen)32, (ftnlen)
+ 6);
+ slattb_(&imat, uplo, trans, diag, iseed, &n, &kd, &ab[
+ 1], &ldab, &x[1], &work[1], &info);
+
+/* + TEST 7 */
+/* Solve the system op(A)*x = b */
+
+ s_copy(srnamc_1.srnamt, "SLATBS", (ftnlen)32, (ftnlen)
+ 6);
+ scopy_(&n, &x[1], &c__1, &b[1], &c__1);
+ slatbs_(uplo, trans, diag, "N", &n, &kd, &ab[1], &
+ ldab, &b[1], &scale, &rwork[1], &info);
+
+/* Check error code from SLATBS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__7[0] = 1, a__2[0] = uplo;
+ i__7[1] = 1, a__2[1] = trans;
+ i__7[2] = 1, a__2[2] = diag;
+ i__7[3] = 1, a__2[3] = "N";
+ s_cat(ch__2, a__2, i__7, &c__4, (ftnlen)4);
+ alaerh_(path, "SLATBS", &info, &c__0, ch__2, &n, &
+ n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ stbt03_(uplo, trans, diag, &n, &kd, &c__1, &ab[1], &
+ ldab, &scale, &rwork[1], &c_b15, &b[1], &lda,
+ &x[1], &lda, &work[1], &result[6]);
+
+/* + TEST 8 */
+/* Solve op(A)*x = b again with NORMIN = 'Y'. */
+
+ scopy_(&n, &x[1], &c__1, &b[1], &c__1);
+ slatbs_(uplo, trans, diag, "Y", &n, &kd, &ab[1], &
+ ldab, &b[1], &scale, &rwork[1], &info);
+
+/* Check error code from SLATBS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__7[0] = 1, a__2[0] = uplo;
+ i__7[1] = 1, a__2[1] = trans;
+ i__7[2] = 1, a__2[2] = diag;
+ i__7[3] = 1, a__2[3] = "Y";
+ s_cat(ch__2, a__2, i__7, &c__4, (ftnlen)4);
+ alaerh_(path, "SLATBS", &info, &c__0, ch__2, &n, &
+ n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ stbt03_(uplo, trans, diag, &n, &kd, &c__1, &ab[1], &
+ ldab, &scale, &rwork[1], &c_b15, &b[1], &lda,
+ &x[1], &lda, &work[1], &result[7]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___43.ciunit = *nout;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "SLATBS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "SLATBS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "Y", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+ nrun += 2;
+/* L100: */
+ }
+/* L110: */
+ }
+L120:
+ ;
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SCHKTB */
+
+} /* schktb_ */
diff --git a/TESTING/LIN/schktp.c b/TESTING/LIN/schktp.c
new file mode 100644
index 0000000..c7136a2
--- /dev/null
+++ b/TESTING/LIN/schktp.c
@@ -0,0 +1,685 @@
+/* schktp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__7 = 7;
+static integer c__4 = 4;
+static real c_b103 = 1.f;
+static integer c__8 = 8;
+static integer c__9 = 9;
+
+/* Subroutine */ int schktp_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, real *thresh, logical *tsterr, integer *
+ nmax, real *ap, real *ainvp, real *b, real *x, real *xact, real *work,
+ real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', DIAG='\002,a1,\002'"
+ ", N=\002,i5,\002, type \002,i2,\002, test(\002,i2,\002)= \002,g1"
+ "2.5)";
+ static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', TRANS='\002,a1,\002"
+ "', DIAG='\002,a1,\002', N=\002,i5,\002', NRHS=\002,i5,\002, type "
+ "\002,i2,\002, test(\002,i2,\002)= \002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
+ "'\002,a1,\002',\002,i5,\002, ... ), type \002,i2,\002, test(\002"
+ ",i2,\002)=\002,g12.5)";
+ static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
+ "'\002,a1,\002', '\002,a1,\002',\002,i5,\002, ... ), type \002,i2,"
+ "\002, test(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2], a__2[3], a__3[4];
+ integer i__1, i__2[2], i__3, i__4[3], i__5[4];
+ char ch__1[2], ch__2[3], ch__3[4];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
+ char **, integer *, integer *, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, in, lda, lap;
+ char diag[1];
+ integer imat, info;
+ char path[3];
+ integer irhs, nrhs;
+ char norm[1], uplo[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer idiag;
+ real scale;
+ integer nfail, iseed[4];
+ extern logical lsame_(char *, char *);
+ real rcond;
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *);
+ real anorm;
+ integer itran;
+ char trans[1];
+ integer iuplo, nerrs;
+ extern /* Subroutine */ int stpt01_(char *, char *, integer *, real *,
+ real *, real *, real *, real *), scopy_(integer *,
+ real *, integer *, real *, integer *), stpt02_(char *, char *,
+ char *, integer *, integer *, real *, real *, integer *, real *,
+ integer *, real *, real *), stpt03_(char *
+, char *, char *, integer *, integer *, real *, real *, real *,
+ real *, real *, integer *, real *, integer *, real *, real *), stpt05_(char *, char *, char *, integer *
+, integer *, real *, real *, integer *, real *, integer *, real *,
+ integer *, real *, real *, real *),
+ stpt06_(real *, real *, char *, char *, integer *, real *, real *,
+ real *);
+ char xtype[1];
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ real rcondc, rcondi;
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ real rcondo, ainvnm;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, integer *, integer *);
+ extern doublereal slantp_(char *, char *, char *, integer *, real *, real
+ *);
+ extern /* Subroutine */ int slatps_(char *, char *, char *, char *,
+ integer *, real *, real *, real *, real *, integer *), slattp_(integer *, char *, char *, char *
+, integer *, integer *, real *, real *, real *, integer *), stpcon_(char *, char *, char *, integer *, real
+ *, real *, real *, integer *, integer *);
+ real result[9];
+ extern /* Subroutine */ int serrtr_(char *, integer *), stprfs_(
+ char *, char *, char *, integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, real *, real *, integer *,
+ integer *), stptri_(char *, char *,
+ integer *, real *, integer *), stptrs_(char *,
+ char *, char *, integer *, integer *, real *, real *, integer *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKTP tests STPTRI, -TRS, -RFS, and -CON, and SLATPS */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The leading dimension of the work arrays. NMAX >= the */
+/* maximumm value of N in NVAL. */
+
+/* AP (workspace) REAL array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AINVP (workspace) REAL array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) REAL array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainvp;
+ --ap;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "TP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrtr_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL */
+
+ n = nval[in];
+ lda = max(1,n);
+ lap = lda * (lda + 1) / 2;
+ *(unsigned char *)xtype = 'N';
+
+ for (imat = 1; imat <= 10; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L70;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Call SLATTP to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "SLATTP", (ftnlen)32, (ftnlen)6);
+ slattp_(&imat, uplo, "No transpose", diag, iseed, &n, &ap[1],
+ &x[1], &work[1], &info);
+
+/* Set IDIAG = 1 for non-unit matrices, 2 for unit. */
+
+ if (lsame_(diag, "N")) {
+ idiag = 1;
+ } else {
+ idiag = 2;
+ }
+
+/* + TEST 1 */
+/* Form the inverse of A. */
+
+ if (n > 0) {
+ scopy_(&lap, &ap[1], &c__1, &ainvp[1], &c__1);
+ }
+ s_copy(srnamc_1.srnamt, "STPTRI", (ftnlen)32, (ftnlen)6);
+ stptri_(uplo, diag, &n, &ainvp[1], &info);
+
+/* Check error code from STPTRI. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__2[0] = 1, a__1[0] = uplo;
+ i__2[1] = 1, a__1[1] = diag;
+ s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2);
+ alaerh_(path, "STPTRI", &info, &c__0, ch__1, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ anorm = slantp_("I", uplo, diag, &n, &ap[1], &rwork[1]);
+ ainvnm = slantp_("I", uplo, diag, &n, &ainvp[1], &rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondi = 1.f;
+ } else {
+ rcondi = 1.f / anorm / ainvnm;
+ }
+
+/* Compute the residual for the triangular matrix times its */
+/* inverse. Also compute the 1-norm condition number of A. */
+
+ stpt01_(uplo, diag, &n, &ap[1], &ainvp[1], &rcondo, &rwork[1],
+ result);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, or A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[
+ itran - 1];
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+
+/* + TEST 2 */
+/* Solve and compute residual for op(A)*x = b. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ slarhs_(path, xtype, uplo, trans, &n, &n, &c__0, &
+ idiag, &nrhs, &ap[1], &lap, &xact[1], &lda, &
+ b[1], &lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ slacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "STPTRS", (ftnlen)32, (ftnlen)
+ 6);
+ stptrs_(uplo, trans, diag, &n, &nrhs, &ap[1], &x[1], &
+ lda, &info);
+
+/* Check error code from STPTRS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__4[0] = 1, a__2[0] = uplo;
+ i__4[1] = 1, a__2[1] = trans;
+ i__4[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)3);
+ alaerh_(path, "STPTRS", &info, &c__0, ch__2, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ stpt02_(uplo, trans, diag, &n, &nrhs, &ap[1], &x[1], &
+ lda, &b[1], &lda, &work[1], &result[1]);
+
+/* + TEST 3 */
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* + TESTS 4, 5, and 6 */
+/* Use iterative refinement to improve the solution and */
+/* compute error bounds. */
+
+ s_copy(srnamc_1.srnamt, "STPRFS", (ftnlen)32, (ftnlen)
+ 6);
+ stprfs_(uplo, trans, diag, &n, &nrhs, &ap[1], &b[1], &
+ lda, &x[1], &lda, &rwork[1], &rwork[nrhs + 1],
+ &work[1], &iwork[1], &info);
+
+/* Check error code from STPRFS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__4[0] = 1, a__2[0] = uplo;
+ i__4[1] = 1, a__2[1] = trans;
+ i__4[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)3);
+ alaerh_(path, "STPRFS", &info, &c__0, ch__2, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+ stpt05_(uplo, trans, diag, &n, &nrhs, &ap[1], &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[1], &
+ rwork[nrhs + 1], &result[4]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += 5;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* + TEST 7 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+
+ s_copy(srnamc_1.srnamt, "STPCON", (ftnlen)32, (ftnlen)6);
+ stpcon_(norm, uplo, diag, &n, &ap[1], &rcond, &work[1], &
+ iwork[1], &info);
+
+/* Check error code from STPCON. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__4[0] = 1, a__2[0] = norm;
+ i__4[1] = 1, a__2[1] = uplo;
+ i__4[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)3);
+ alaerh_(path, "STPCON", &info, &c__0, ch__2, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ stpt06_(&rcond, &rcondc, uplo, diag, &n, &ap[1], &rwork[1]
+, &result[6]);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, "STPCON", (ftnlen)6);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L50: */
+ }
+/* L60: */
+ }
+L70:
+ ;
+ }
+
+/* Use pathological test matrices to test SLATPS. */
+
+ for (imat = 11; imat <= 18; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L100;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, or A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[itran
+ - 1];
+
+/* Call SLATTP to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "SLATTP", (ftnlen)32, (ftnlen)6);
+ slattp_(&imat, uplo, trans, diag, iseed, &n, &ap[1], &x[1]
+, &work[1], &info);
+
+/* + TEST 8 */
+/* Solve the system op(A)*x = b. */
+
+ s_copy(srnamc_1.srnamt, "SLATPS", (ftnlen)32, (ftnlen)6);
+ scopy_(&n, &x[1], &c__1, &b[1], &c__1);
+ slatps_(uplo, trans, diag, "N", &n, &ap[1], &b[1], &scale,
+ &rwork[1], &info);
+
+/* Check error code from SLATPS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__5[0] = 1, a__3[0] = uplo;
+ i__5[1] = 1, a__3[1] = trans;
+ i__5[2] = 1, a__3[2] = diag;
+ i__5[3] = 1, a__3[3] = "N";
+ s_cat(ch__3, a__3, i__5, &c__4, (ftnlen)4);
+ alaerh_(path, "SLATPS", &info, &c__0, ch__3, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ stpt03_(uplo, trans, diag, &n, &c__1, &ap[1], &scale, &
+ rwork[1], &c_b103, &b[1], &lda, &x[1], &lda, &
+ work[1], &result[7]);
+
+/* + TEST 9 */
+/* Solve op(A)*x = b again with NORMIN = 'Y'. */
+
+ scopy_(&n, &x[1], &c__1, &b[n + 1], &c__1);
+ slatps_(uplo, trans, diag, "Y", &n, &ap[1], &b[n + 1], &
+ scale, &rwork[1], &info);
+
+/* Check error code from SLATPS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__5[0] = 1, a__3[0] = uplo;
+ i__5[1] = 1, a__3[1] = trans;
+ i__5[2] = 1, a__3[2] = diag;
+ i__5[3] = 1, a__3[3] = "Y";
+ s_cat(ch__3, a__3, i__5, &c__4, (ftnlen)4);
+ alaerh_(path, "SLATPS", &info, &c__0, ch__3, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ stpt03_(uplo, trans, diag, &n, &c__1, &ap[1], &scale, &
+ rwork[1], &c_b103, &b[n + 1], &lda, &x[1], &lda, &
+ work[1], &result[8]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, "SLATPS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ ++nfail;
+ }
+ if (result[8] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, "SLATPS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "Y", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[8], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ ++nfail;
+ }
+ nrun += 2;
+/* L80: */
+ }
+/* L90: */
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SCHKTP */
+
+} /* schktp_ */
diff --git a/TESTING/LIN/schktr.c b/TESTING/LIN/schktr.c
new file mode 100644
index 0000000..353b0fc
--- /dev/null
+++ b/TESTING/LIN/schktr.c
@@ -0,0 +1,726 @@
+/* schktr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__7 = 7;
+static integer c__4 = 4;
+static real c_b101 = 1.f;
+static integer c__8 = 8;
+static integer c__9 = 9;
+
+/* Subroutine */ int schktr_(logical *dotype, integer *nn, integer *nval,
+ integer *nnb, integer *nbval, integer *nns, integer *nsval, real *
+ thresh, logical *tsterr, integer *nmax, real *a, real *ainv, real *b,
+ real *x, real *xact, real *work, real *rwork, integer *iwork, integer
+ *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', DIAG='\002,a1,\002'"
+ ", N=\002,i5,\002, NB=\002,i4,\002, type \002,i2,\002, test(\002,"
+ "i2,\002)= \002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', TRANS='\002,a1,\002"
+ "', DIAG='\002,a1,\002', N=\002,i5,\002, NB=\002,i4,\002, type"
+ " \002,i2,\002, test(\002,i2,\002)= \002,g12"
+ ".5)";
+ static char fmt_9997[] = "(\002 NORM='\002,a1,\002', UPLO ='\002,a1,\002"
+ "', N=\002,i5,\002,\002,11x,\002 type \002,i2,\002, test(\002,i2"
+ ",\002)=\002,g12.5)";
+ static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
+ "'\002,a1,\002', '\002,a1,\002',\002,i5,\002, ... ), type \002,i2,"
+ "\002, test(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2], a__2[3], a__3[4];
+ integer i__1, i__2, i__3[2], i__4, i__5[3], i__6[4];
+ char ch__1[2], ch__2[3], ch__3[4];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
+ char **, integer *, integer *, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, nb, in, lda, inb;
+ char diag[1];
+ integer imat, info;
+ char path[3];
+ integer irhs, nrhs;
+ char norm[1], uplo[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer idiag;
+ real scale;
+ integer nfail, iseed[4];
+ extern logical lsame_(char *, char *);
+ real rcond;
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *);
+ real anorm;
+ integer itran;
+ char trans[1];
+ integer iuplo, nerrs;
+ real dummy;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), strt01_(char *, char *, integer *, real *, integer *,
+ real *, integer *, real *, real *, real *),
+ strt02_(char *, char *, char *, integer *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, real *, real *), strt03_(char *, char *, char *, integer *
+, integer *, real *, integer *, real *, real *, real *, real *,
+ integer *, real *, integer *, real *, real *), strt05_(char *, char *, char *, integer *, integer *,
+ real *, integer *, real *, integer *, real *, integer *, real *,
+ integer *, real *, real *, real *),
+ strt06_(real *, real *, char *, char *, integer *, real *,
+ integer *, real *, real *);
+ char xtype[1];
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ real rcondc, rcondi;
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ real rcondo, ainvnm;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, integer *, integer *), xlaenv_(
+ integer *, integer *);
+ extern doublereal slantr_(char *, char *, char *, integer *, integer *,
+ real *, integer *, real *);
+ extern /* Subroutine */ int slatrs_(char *, char *, char *, char *,
+ integer *, real *, integer *, real *, real *, real *, integer *), slattr_(integer *, char *, char *
+, char *, integer *, integer *, real *, integer *, real *, real *,
+ integer *), strcon_(char *, char *, char
+ *, integer *, real *, integer *, real *, real *, integer *,
+ integer *);
+ real result[9];
+ extern /* Subroutine */ int serrtr_(char *, integer *), strrfs_(
+ char *, char *, char *, integer *, integer *, real *, integer *,
+ real *, integer *, real *, integer *, real *, real *, real *,
+ integer *, integer *), strtri_(char *,
+ char *, integer *, real *, integer *, integer *),
+ strtrs_(char *, char *, char *, integer *, integer *, real *,
+ integer *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___27 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKTR tests STRTRI, -TRS, -RFS, and -CON, and SLATRS */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The leading dimension of the work arrays. */
+/* NMAX >= the maximum value of N in NVAL. */
+
+/* A (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* B (workspace) REAL array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "TR", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrtr_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL */
+
+ n = nval[in];
+ lda = max(1,n);
+ *(unsigned char *)xtype = 'N';
+
+ for (imat = 1; imat <= 10; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L80;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Call SLATTR to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "SLATTR", (ftnlen)32, (ftnlen)6);
+ slattr_(&imat, uplo, "No transpose", diag, iseed, &n, &a[1], &
+ lda, &x[1], &work[1], &info);
+
+/* Set IDIAG = 1 for non-unit matrices, 2 for unit. */
+
+ if (lsame_(diag, "N")) {
+ idiag = 1;
+ } else {
+ idiag = 2;
+ }
+
+ i__2 = *nnb;
+ for (inb = 1; inb <= i__2; ++inb) {
+
+/* Do for each blocksize in NBVAL */
+
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* + TEST 1 */
+/* Form the inverse of A. */
+
+ slacpy_(uplo, &n, &n, &a[1], &lda, &ainv[1], &lda);
+ s_copy(srnamc_1.srnamt, "STRTRI", (ftnlen)32, (ftnlen)6);
+ strtri_(uplo, diag, &n, &ainv[1], &lda, &info);
+
+/* Check error code from STRTRI. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = uplo;
+ i__3[1] = 1, a__1[1] = diag;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ alaerh_(path, "STRTRI", &info, &c__0, ch__1, &n, &n, &
+ c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ anorm = slantr_("I", uplo, diag, &n, &n, &a[1], &lda, &
+ rwork[1]);
+ ainvnm = slantr_("I", uplo, diag, &n, &n, &ainv[1], &lda,
+ &rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondi = 1.f;
+ } else {
+ rcondi = 1.f / anorm / ainvnm;
+ }
+
+/* Compute the residual for the triangular matrix times */
+/* its inverse. Also compute the 1-norm condition number */
+/* of A. */
+
+ strt01_(uplo, diag, &n, &a[1], &lda, &ainv[1], &lda, &
+ rcondo, &rwork[1], result);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+/* Skip remaining tests if not the first block size. */
+
+ if (inb != 1) {
+ goto L60;
+ }
+
+ i__4 = *nns;
+ for (irhs = 1; irhs <= i__4; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, or A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itran - 1];
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+
+/* + TEST 2 */
+/* Solve and compute residual for op(A)*x = b. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, (
+ ftnlen)6);
+ slarhs_(path, xtype, uplo, trans, &n, &n, &c__0, &
+ idiag, &nrhs, &a[1], &lda, &xact[1], &lda,
+ &b[1], &lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ slacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "STRTRS", (ftnlen)32, (
+ ftnlen)6);
+ strtrs_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
+ &x[1], &lda, &info);
+
+/* Check error code from STRTRS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__5[0] = 1, a__2[0] = uplo;
+ i__5[1] = 1, a__2[1] = trans;
+ i__5[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3);
+ alaerh_(path, "STRTRS", &info, &c__0, ch__2, &
+ n, &n, &c_n1, &c_n1, &nrhs, &imat, &
+ nfail, &nerrs, nout);
+ }
+
+/* This line is needed on a Sun SPARCstation. */
+
+ if (n > 0) {
+ dummy = a[1];
+ }
+
+ strt02_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
+ &x[1], &lda, &b[1], &lda, &work[1], &
+ result[1]);
+
+/* + TEST 3 */
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* + TESTS 4, 5, and 6 */
+/* Use iterative refinement to improve the solution */
+/* and compute error bounds. */
+
+ s_copy(srnamc_1.srnamt, "STRRFS", (ftnlen)32, (
+ ftnlen)6);
+ strrfs_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
+ &b[1], &lda, &x[1], &lda, &rwork[1], &
+ rwork[nrhs + 1], &work[1], &iwork[1], &
+ info);
+
+/* Check error code from STRRFS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__5[0] = 1, a__2[0] = uplo;
+ i__5[1] = 1, a__2[1] = trans;
+ i__5[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3);
+ alaerh_(path, "STRRFS", &info, &c__0, ch__2, &
+ n, &n, &c_n1, &c_n1, &nrhs, &imat, &
+ nfail, &nerrs, nout);
+ }
+
+ sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+ strt05_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
+ &b[1], &lda, &x[1], &lda, &xact[1], &lda,
+ &rwork[1], &rwork[nrhs + 1], &result[4]);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += 5;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* + TEST 7 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+ s_copy(srnamc_1.srnamt, "STRCON", (ftnlen)32, (ftnlen)
+ 6);
+ strcon_(norm, uplo, diag, &n, &a[1], &lda, &rcond, &
+ work[1], &iwork[1], &info);
+
+/* Check error code from STRCON. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__5[0] = 1, a__2[0] = norm;
+ i__5[1] = 1, a__2[1] = uplo;
+ i__5[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3);
+ alaerh_(path, "STRCON", &info, &c__0, ch__2, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ strt06_(&rcond, &rcondc, uplo, diag, &n, &a[1], &lda,
+ &rwork[1], &result[6]);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L50: */
+ }
+L60:
+ ;
+ }
+/* L70: */
+ }
+L80:
+ ;
+ }
+
+/* Use pathological test matrices to test SLATRS. */
+
+ for (imat = 11; imat <= 18; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L110;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, and A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[itran
+ - 1];
+
+/* Call SLATTR to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "SLATTR", (ftnlen)32, (ftnlen)6);
+ slattr_(&imat, uplo, trans, diag, iseed, &n, &a[1], &lda,
+ &x[1], &work[1], &info);
+
+/* + TEST 8 */
+/* Solve the system op(A)*x = b. */
+
+ s_copy(srnamc_1.srnamt, "SLATRS", (ftnlen)32, (ftnlen)6);
+ scopy_(&n, &x[1], &c__1, &b[1], &c__1);
+ slatrs_(uplo, trans, diag, "N", &n, &a[1], &lda, &b[1], &
+ scale, &rwork[1], &info);
+
+/* Check error code from SLATRS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__6[0] = 1, a__3[0] = uplo;
+ i__6[1] = 1, a__3[1] = trans;
+ i__6[2] = 1, a__3[2] = diag;
+ i__6[3] = 1, a__3[3] = "N";
+ s_cat(ch__3, a__3, i__6, &c__4, (ftnlen)4);
+ alaerh_(path, "SLATRS", &info, &c__0, ch__3, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ strt03_(uplo, trans, diag, &n, &c__1, &a[1], &lda, &scale,
+ &rwork[1], &c_b101, &b[1], &lda, &x[1], &lda, &
+ work[1], &result[7]);
+
+/* + TEST 9 */
+/* Solve op(A)*X = b again with NORMIN = 'Y'. */
+
+ scopy_(&n, &x[1], &c__1, &b[n + 1], &c__1);
+ slatrs_(uplo, trans, diag, "Y", &n, &a[1], &lda, &b[n + 1]
+, &scale, &rwork[1], &info);
+
+/* Check error code from SLATRS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__6[0] = 1, a__3[0] = uplo;
+ i__6[1] = 1, a__3[1] = trans;
+ i__6[2] = 1, a__3[2] = diag;
+ i__6[3] = 1, a__3[3] = "Y";
+ s_cat(ch__3, a__3, i__6, &c__4, (ftnlen)4);
+ alaerh_(path, "SLATRS", &info, &c__0, ch__3, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ strt03_(uplo, trans, diag, &n, &c__1, &a[1], &lda, &scale,
+ &rwork[1], &c_b101, &b[n + 1], &lda, &x[1], &lda,
+ &work[1], &result[8]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "SLATRS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ ++nfail;
+ }
+ if (result[8] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "SLATRS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "Y", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[8], (ftnlen)sizeof(real)
+ );
+ e_wsfe();
+ ++nfail;
+ }
+ nrun += 2;
+/* L90: */
+ }
+/* L100: */
+ }
+L110:
+ ;
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SCHKTR */
+
+} /* schktr_ */
diff --git a/TESTING/LIN/schktz.c b/TESTING/LIN/schktz.c
new file mode 100644
index 0000000..77ce4ef
--- /dev/null
+++ b/TESTING/LIN/schktz.c
@@ -0,0 +1,390 @@
+/* schktz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static real c_b10 = 0.f;
+static real c_b15 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int schktz_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, real *thresh, logical *tsterr, real *a,
+ real *copya, real *s, real *copys, real *tau, real *work, integer *
+ nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, type"
+ " \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, im, in, lda;
+ real eps;
+ integer mode, info;
+ char path[3];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4], imode, mnmin, nerrs;
+ extern doublereal sqrt12_(integer *, integer *, real *, integer *, real *,
+ real *, integer *);
+ integer lwork;
+ extern doublereal srzt01_(integer *, integer *, real *, real *, integer *,
+ real *, real *, integer *), srzt02_(integer *, integer *, real *,
+ integer *, real *, real *, integer *), stzt01_(integer *,
+ integer *, real *, real *, integer *, real *, real *, integer *),
+ stzt02_(integer *, integer *, real *, integer *, real *, real *,
+ integer *);
+ extern /* Subroutine */ int sgeqr2_(integer *, integer *, real *, integer
+ *, real *, real *, integer *);
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *), slaord_(char *, integer *, real *, integer
+ *), slacpy_(char *, integer *, integer *, real *, integer
+ *, real *, integer *), slaset_(char *, integer *, integer
+ *, real *, real *, real *, integer *), slatms_(integer *,
+ integer *, char *, integer *, char *, real *, integer *, real *,
+ real *, integer *, integer *, char *, real *, integer *, real *,
+ integer *);
+ real result[6];
+ extern /* Subroutine */ int serrtz_(char *, integer *), stzrqf_(
+ integer *, integer *, real *, integer *, real *, integer *),
+ stzrzf_(integer *, integer *, real *, integer *, real *, real *,
+ integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___21 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SCHKTZ tests STZRQF and STZRZF. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) REAL array, dimension (MMAX*NMAX) */
+/* where MMAX is the maximum value of M in MVAL and NMAX is the */
+/* maximum value of N in NVAL. */
+
+/* COPYA (workspace) REAL array, dimension (MMAX*NMAX) */
+
+/* S (workspace) REAL array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* COPYS (workspace) REAL array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* TAU (workspace) REAL array, dimension (MMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (MMAX*NMAX + 4*NMAX + MMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --work;
+ --tau;
+ --copys;
+ --s;
+ --copya;
+ --a;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "TZ", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = slamch_("Epsilon");
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrtz_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+
+/* Do for each value of M in MVAL. */
+
+ m = mval[im];
+ lda = max(1,m);
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+
+/* Do for each value of N in NVAL for which M .LE. N. */
+
+ n = nval[in];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__3 = 1, i__4 = n * n + (m << 2) + n, i__3 = max(i__3,i__4),
+ i__4 = m * n + (mnmin << 1) + (n << 2);
+ lwork = max(i__3,i__4);
+
+ if (m <= n) {
+ for (imode = 1; imode <= 3; ++imode) {
+ if (! dotype[imode]) {
+ goto L50;
+ }
+
+/* Do for each type of singular value distribution. */
+/* 0: zero matrix */
+/* 1: one small singular value */
+/* 2: exponential distribution */
+
+ mode = imode - 1;
+
+/* Test STZRQF */
+
+/* Generate test matrix of size m by n using */
+/* singular value distribution indicated by `mode'. */
+
+ if (mode == 0) {
+ slaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
+ i__3 = mnmin;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ copys[i__] = 0.f;
+/* L20: */
+ }
+ } else {
+ r__1 = 1.f / eps;
+ slatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
+ copys[1], &imode, &r__1, &c_b15, &m, &n,
+ "No packing", &a[1], &lda, &work[1], &info);
+ sgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
+ 1], &info);
+ i__3 = m - 1;
+ slaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
+ lda);
+ slaord_("Decreasing", &mnmin, ©s[1], &c__1);
+ }
+
+/* Save A and its singular values */
+
+ slacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
+
+/* Call STZRQF to reduce the upper trapezoidal matrix to */
+/* upper triangular form. */
+
+ s_copy(srnamc_1.srnamt, "STZRQF", (ftnlen)32, (ftnlen)6);
+ stzrqf_(&m, &n, &a[1], &lda, &tau[1], &info);
+
+/* Compute norm(svd(a) - svd(r)) */
+
+ result[0] = sqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
+ 1], &lwork);
+
+/* Compute norm( A - R*Q ) */
+
+ result[1] = stzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
+ 1], &work[1], &lwork);
+
+/* Compute norm(Q'*Q - I). */
+
+ result[2] = stzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
+, &lwork);
+
+/* Test STZRZF */
+
+/* Generate test matrix of size m by n using */
+/* singular value distribution indicated by `mode'. */
+
+ if (mode == 0) {
+ slaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
+ i__3 = mnmin;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ copys[i__] = 0.f;
+/* L30: */
+ }
+ } else {
+ r__1 = 1.f / eps;
+ slatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
+ copys[1], &imode, &r__1, &c_b15, &m, &n,
+ "No packing", &a[1], &lda, &work[1], &info);
+ sgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
+ 1], &info);
+ i__3 = m - 1;
+ slaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
+ lda);
+ slaord_("Decreasing", &mnmin, ©s[1], &c__1);
+ }
+
+/* Save A and its singular values */
+
+ slacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
+
+/* Call STZRZF to reduce the upper trapezoidal matrix to */
+/* upper triangular form. */
+
+ s_copy(srnamc_1.srnamt, "STZRZF", (ftnlen)32, (ftnlen)6);
+ stzrzf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lwork, &
+ info);
+
+/* Compute norm(svd(a) - svd(r)) */
+
+ result[3] = sqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
+ 1], &lwork);
+
+/* Compute norm( A - R*Q ) */
+
+ result[4] = srzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
+ 1], &work[1], &lwork);
+
+/* Compute norm(Q'*Q - I). */
+
+ result[5] = srzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
+, &lwork);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___21.ciunit = *nout;
+ s_wsfe(&io___21);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L40: */
+ }
+ nrun += 6;
+L50:
+ ;
+ }
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+
+/* End if SCHKTZ */
+
+ return 0;
+} /* schktz_ */
diff --git a/TESTING/LIN/sdrvgb.c b/TESTING/LIN/sdrvgb.c
new file mode 100644
index 0000000..b83e6c3
--- /dev/null
+++ b/TESTING/LIN/sdrvgb.c
@@ -0,0 +1,1115 @@
+/* sdrvgb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static real c_b48 = 0.f;
+static real c_b49 = 1.f;
+static integer c__6 = 6;
+static integer c__7 = 7;
+
+/* Subroutine */ int sdrvgb_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, real *a, integer *la,
+ real *afb, integer *lafb, real *asav, real *b, real *bsav, real *x,
+ real *xact, real *s, real *work, real *rwork, integer *iwork, integer
+ *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*4] = "N" "R" "C" "B";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 *** In SDRVGB, LA=\002,i5,\002 is too sm"
+ "all for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> In"
+ "crease LA to at least \002,i5)";
+ static char fmt_9998[] = "(\002 *** In SDRVGB, LAFB=\002,i5,\002 is too "
+ "small for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> "
+ "Increase LAFB to at least \002,i5)";
+ static char fmt_9997[] = "(1x,a,\002, N=\002,i5,\002, KL=\002,i5,\002, K"
+ "U=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)"
+ ;
+ static char fmt_9995[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002"
+ ",i5,\002,\002,i5,\002,\002,i5,\002,...), EQUED='\002,a1,\002', t"
+ "ype \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002"
+ ",i5,\002,\002,i5,\002,\002,i5,\002,...), type \002,i1,\002, test("
+ "\002,i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10,
+ i__11[2];
+ real r__1, r__2, r__3;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, k1, nb, in, kl, ku, nt, lda, ldb, ikl, nkl,
+ iku, nku;
+ char fact[1];
+ integer ioff, mode;
+ real amax;
+ char path[3];
+ integer imat, info;
+ char dist[1], type__[1];
+ integer nrun, ldafb, ifact, nfail, iseed[4], nfact;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sgbt01_(integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *, real *
+, real *);
+ char equed[1];
+ integer nbmin;
+ real rcond, roldc;
+ extern /* Subroutine */ int sgbt02_(char *, integer *, integer *, integer
+ *, integer *, integer *, real *, integer *, real *, integer *,
+ real *, integer *, real *);
+ integer nimat;
+ real roldi;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int sgbt05_(char *, integer *, integer *, integer
+ *, integer *, real *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, real *, real *, real *);
+ real anorm;
+ integer itran;
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *);
+ logical equil;
+ real roldo;
+ extern /* Subroutine */ int sgbsv_(integer *, integer *, integer *,
+ integer *, real *, integer *, integer *, real *, integer *,
+ integer *);
+ char trans[1];
+ integer izero, nerrs;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), aladhd_(integer *, char *),
+ alaerh_(char *, char *, integer *, integer *, char *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *);
+ logical prefac;
+ real colcnd;
+ extern doublereal slangb_(char *, integer *, integer *, integer *, real *,
+ integer *, real *), slamch_(char *);
+ real rcondc;
+ extern doublereal slange_(char *, integer *, integer *, real *, integer *,
+ real *);
+ logical nofact;
+ extern /* Subroutine */ int slaqgb_(integer *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ real *, char *);
+ integer iequed;
+ real rcondi;
+ extern doublereal slantb_(char *, char *, char *, integer *, integer *,
+ real *, integer *, real *);
+ real cndnum, anormi, rcondo, ainvnm;
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ logical trfcon;
+ real anormo, rowcnd;
+ extern /* Subroutine */ int sgbequ_(integer *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ real *, integer *), sgbtrf_(integer *, integer *, integer *,
+ integer *, real *, integer *, integer *, integer *), slacpy_(char
+ *, integer *, integer *, real *, integer *, real *, integer *), slarhs_(char *, char *, char *, char *, integer *,
+ integer *, integer *, integer *, integer *, real *, integer *,
+ real *, integer *, real *, integer *, integer *, integer *);
+ real anrmpv;
+ extern /* Subroutine */ int sgbtrs_(char *, integer *, integer *, integer
+ *, integer *, real *, integer *, integer *, real *, integer *,
+ integer *), slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *), slatms_(integer *, integer *,
+ char *, integer *, char *, real *, integer *, real *, real *,
+ integer *, integer *, char *, real *, integer *, real *, integer *
+), xlaenv_(integer *, integer *), sgbsvx_(
+ char *, char *, integer *, integer *, integer *, integer *, real *
+, integer *, real *, integer *, integer *, char *, real *, real *,
+ real *, integer *, real *, integer *, real *, real *, real *,
+ real *, integer *, integer *);
+ real result[7], rpvgrw;
+ extern /* Subroutine */ int serrvx_(char *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___72 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___73 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___74 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___75 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___76 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___77 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVGB tests the driver routines SGBSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) REAL array, dimension (LA) */
+
+/* LA (input) INTEGER */
+/* The length of the array A. LA >= (2*NMAX-1)*NMAX */
+/* where NMAX is the largest entry in NVAL. */
+
+/* AFB (workspace) REAL array, dimension (LAFB) */
+
+/* LAFB (input) INTEGER */
+/* The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX */
+/* where NMAX is the largest entry in NVAL. */
+
+/* ASAV (workspace) REAL array, dimension (LA) */
+
+/* B (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* X (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* S (workspace) REAL array, dimension (2*NMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(3,NRHS,NMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NRHS)) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afb;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "GB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ ldb = max(n,1);
+ *(unsigned char *)xtype = 'N';
+
+/* Set limits on the number of loop iterations. */
+
+/* Computing MAX */
+ i__2 = 1, i__3 = min(n,4);
+ nkl = max(i__2,i__3);
+ if (n == 0) {
+ nkl = 1;
+ }
+ nku = nkl;
+ nimat = 8;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nkl;
+ for (ikl = 1; ikl <= i__2; ++ikl) {
+
+/* Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes */
+/* it easier to skip redundant values for small values of N. */
+
+ if (ikl == 1) {
+ kl = 0;
+ } else if (ikl == 2) {
+/* Computing MAX */
+ i__3 = n - 1;
+ kl = max(i__3,0);
+ } else if (ikl == 3) {
+ kl = (n * 3 - 1) / 4;
+ } else if (ikl == 4) {
+ kl = (n + 1) / 4;
+ }
+ i__3 = nku;
+ for (iku = 1; iku <= i__3; ++iku) {
+
+/* Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order */
+/* makes it easier to skip redundant values for small */
+/* values of N. */
+
+ if (iku == 1) {
+ ku = 0;
+ } else if (iku == 2) {
+/* Computing MAX */
+ i__4 = n - 1;
+ ku = max(i__4,0);
+ } else if (iku == 3) {
+ ku = (n * 3 - 1) / 4;
+ } else if (iku == 4) {
+ ku = (n + 1) / 4;
+ }
+
+/* Check that A and AFB are big enough to generate this */
+/* matrix. */
+
+ lda = kl + ku + 1;
+ ldafb = (kl << 1) + ku + 1;
+ if (lda * n > *la || ldafb * n > *lafb) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (lda * n > *la) {
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, (char *)&(*la), (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ i__4 = n * (kl + ku + 1);
+ do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ if (ldafb * n > *lafb) {
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__1, (char *)&(*lafb), (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ i__4 = n * ((kl << 1) + ku + 1);
+ do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ goto L130;
+ }
+
+ i__4 = nimat;
+ for (imat = 1; imat <= i__4; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+/* Skip types 2, 3, or 4 if the matrix is too small. */
+
+ zerot = imat >= 2 && imat <= 4;
+ if (zerot && n < imat - 1) {
+ goto L120;
+ }
+
+/* Set up parameters with SLATB4 and generate a */
+/* test matrix with SLATMS. */
+
+ slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
+ mode, &cndnum, dist);
+ rcondc = 1.f / cndnum;
+
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
+ slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "Z", &a[1], &lda, &work[
+ 1], &info);
+
+/* Check the error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, " ", &n, &n, &
+ kl, &ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L120;
+ }
+
+/* For types 2, 3, and 4, zero one or more columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ izero = 0;
+ if (zerot) {
+ if (imat == 2) {
+ izero = 1;
+ } else if (imat == 3) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 4) {
+/* Computing MAX */
+ i__5 = 1, i__6 = ku + 2 - izero;
+ i1 = max(i__5,i__6);
+/* Computing MIN */
+ i__5 = kl + ku + 1, i__6 = ku + 1 + (n - izero);
+ i2 = min(i__5,i__6);
+ i__5 = i2;
+ for (i__ = i1; i__ <= i__5; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L20: */
+ }
+ } else {
+ i__5 = n;
+ for (j = izero; j <= i__5; ++j) {
+/* Computing MAX */
+ i__6 = 1, i__7 = ku + 2 - j;
+/* Computing MIN */
+ i__9 = kl + ku + 1, i__10 = ku + 1 + (n - j);
+ i__8 = min(i__9,i__10);
+ for (i__ = max(i__6,i__7); i__ <= i__8; ++i__)
+ {
+ a[ioff + i__] = 0.f;
+/* L30: */
+ }
+ ioff += lda;
+/* L40: */
+ }
+ }
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ i__5 = kl + ku + 1;
+ slacpy_("Full", &i__5, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 4; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__5 = nfact;
+ for (ifact = 1; ifact <= i__5; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L100;
+ }
+ rcondo = 0.f;
+ rcondi = 0.f;
+
+ } else if (! nofact) {
+
+/* Compute the condition number for comparison */
+/* with the value returned by SGESVX (FACT = */
+/* 'N' reuses the condition number from the */
+/* previous iteration with FACT = 'F'). */
+
+ i__8 = kl + ku + 1;
+ slacpy_("Full", &i__8, &n, &asav[1], &lda, &
+ afb[kl + 1], &ldafb);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ sgbequ_(&n, &n, &kl, &ku, &afb[kl + 1], &
+ ldafb, &s[1], &s[n + 1], &rowcnd,
+ &colcnd, &amax, &info);
+ if (info == 0 && n > 0) {
+ if (lsame_(equed, "R")) {
+ rowcnd = 0.f;
+ colcnd = 1.f;
+ } else if (lsame_(equed, "C")) {
+ rowcnd = 1.f;
+ colcnd = 0.f;
+ } else if (lsame_(equed, "B")) {
+ rowcnd = 0.f;
+ colcnd = 0.f;
+ }
+
+/* Equilibrate the matrix. */
+
+ slaqgb_(&n, &n, &kl, &ku, &afb[kl + 1]
+, &ldafb, &s[1], &s[n + 1], &
+ rowcnd, &colcnd, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in SGET04. */
+
+ if (equil) {
+ roldo = rcondo;
+ roldi = rcondi;
+ }
+
+/* Compute the 1-norm and infinity-norm of A. */
+
+ anormo = slangb_("1", &n, &kl, &ku, &afb[kl +
+ 1], &ldafb, &rwork[1]);
+ anormi = slangb_("I", &n, &kl, &ku, &afb[kl +
+ 1], &ldafb, &rwork[1]);
+
+/* Factor the matrix A. */
+
+ sgbtrf_(&n, &n, &kl, &ku, &afb[1], &ldafb, &
+ iwork[1], &info);
+
+/* Form the inverse of A. */
+
+ slaset_("Full", &n, &n, &c_b48, &c_b49, &work[
+ 1], &ldb);
+ s_copy(srnamc_1.srnamt, "SGBTRS", (ftnlen)32,
+ (ftnlen)6);
+ sgbtrs_("No transpose", &n, &kl, &ku, &n, &
+ afb[1], &ldafb, &iwork[1], &work[1], &
+ ldb, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = slange_("1", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormo <= 0.f || ainvnm <= 0.f) {
+ rcondo = 1.f;
+ } else {
+ rcondo = 1.f / anormo / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number */
+/* of A. */
+
+ ainvnm = slange_("I", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormi <= 0.f || ainvnm <= 0.f) {
+ rcondi = 1.f;
+ } else {
+ rcondi = 1.f / anormi / ainvnm;
+ }
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for each value of TRANS. */
+
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Restore the matrix A. */
+
+ i__8 = kl + ku + 1;
+ slacpy_("Full", &i__8, &n, &asav[1], &lda, &a[
+ 1], &lda);
+
+/* Form an exact solution and set the right hand */
+/* side. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32,
+ (ftnlen)6);
+ slarhs_(path, xtype, "Full", trans, &n, &n, &
+ kl, &ku, nrhs, &a[1], &lda, &xact[1],
+ &ldb, &b[1], &ldb, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ slacpy_("Full", &n, nrhs, &b[1], &ldb, &bsav[
+ 1], &ldb);
+
+ if (nofact && itran == 1) {
+
+/* --- Test SGBSV --- */
+
+/* Compute the LU factorization of the matrix */
+/* and solve the system. */
+
+ i__8 = kl + ku + 1;
+ slacpy_("Full", &i__8, &n, &a[1], &lda, &
+ afb[kl + 1], &ldafb);
+ slacpy_("Full", &n, nrhs, &b[1], &ldb, &x[
+ 1], &ldb);
+
+ s_copy(srnamc_1.srnamt, "SGBSV ", (ftnlen)
+ 32, (ftnlen)6);
+ sgbsv_(&n, &kl, &ku, nrhs, &afb[1], &
+ ldafb, &iwork[1], &x[1], &ldb, &
+ info);
+
+/* Check error code from SGBSV . */
+
+ if (info != izero) {
+ alaerh_(path, "SGBSV ", &info, &izero,
+ " ", &n, &n, &kl, &ku, nrhs,
+ &imat, &nfail, &nerrs, nout);
+ }
+
+/* Reconstruct matrix from factors and */
+/* compute residual. */
+
+ sgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
+ afb[1], &ldafb, &iwork[1], &work[
+ 1], result);
+ nt = 1;
+ if (izero == 0) {
+
+/* Compute residual of the computed */
+/* solution. */
+
+ slacpy_("Full", &n, nrhs, &b[1], &ldb,
+ &work[1], &ldb);
+ sgbt02_("No transpose", &n, &n, &kl, &
+ ku, nrhs, &a[1], &lda, &x[1],
+ &ldb, &work[1], &ldb, &result[
+ 1]);
+
+/* Check solution from generated exact */
+/* solution. */
+
+ sget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &rcondc, &result[2])
+ ;
+ nt = 3;
+ }
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ i__8 = nt;
+ for (k = 1; k <= i__8; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___65.ciunit = *nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, "SGBSV ", (ftnlen)6)
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k -
+ 1], (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L50: */
+ }
+ nrun += nt;
+ }
+
+/* --- Test SGBSVX --- */
+
+ if (! prefac) {
+ i__8 = (kl << 1) + ku + 1;
+ slaset_("Full", &i__8, &n, &c_b48, &c_b48,
+ &afb[1], &ldafb);
+ }
+ slaset_("Full", &n, nrhs, &c_b48, &c_b48, &x[
+ 1], &ldb);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ slaqgb_(&n, &n, &kl, &ku, &a[1], &lda, &s[
+ 1], &s[n + 1], &rowcnd, &colcnd, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition */
+/* number and error bounds using SGBSVX. */
+
+ s_copy(srnamc_1.srnamt, "SGBSVX", (ftnlen)32,
+ (ftnlen)6);
+ sgbsvx_(fact, trans, &n, &kl, &ku, nrhs, &a[1]
+, &lda, &afb[1], &ldafb, &iwork[1],
+ equed, &s[1], &s[n + 1], &b[1], &ldb,
+ &x[1], &ldb, &rcond, &rwork[1], &
+ rwork[*nrhs + 1], &work[1], &iwork[n
+ + 1], &info);
+
+/* Check the error code from SGBSVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__11[0] = 1, a__1[0] = fact;
+ i__11[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__11, &c__2, (ftnlen)
+ 2);
+ alaerh_(path, "SGBSVX", &info, &izero,
+ ch__1, &n, &n, &kl, &ku, nrhs, &
+ imat, &nfail, &nerrs, nout);
+ }
+
+/* Compare WORK(1) from SGBSVX with the computed */
+/* reciprocal pivot growth factor RPVGRW */
+
+ if (info != 0) {
+ anrmpv = 0.f;
+ i__8 = info;
+ for (j = 1; j <= i__8; ++j) {
+/* Computing MAX */
+ i__6 = ku + 2 - j;
+/* Computing MIN */
+ i__9 = n + ku + 1 - j, i__10 = kl +
+ ku + 1;
+ i__7 = min(i__9,i__10);
+ for (i__ = max(i__6,1); i__ <= i__7;
+ ++i__) {
+/* Computing MAX */
+ r__2 = anrmpv, r__3 = (r__1 = a[
+ i__ + (j - 1) * lda],
+ dabs(r__1));
+ anrmpv = dmax(r__2,r__3);
+/* L60: */
+ }
+/* L70: */
+ }
+/* Computing MIN */
+ i__7 = info - 1, i__6 = kl + ku;
+ i__8 = min(i__7,i__6);
+/* Computing MAX */
+ i__9 = 1, i__10 = kl + ku + 2 - info;
+ rpvgrw = slantb_("M", "U", "N", &info, &
+ i__8, &afb[max(i__9, i__10)], &
+ ldafb, &work[1]);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = anrmpv / rpvgrw;
+ }
+ } else {
+ i__8 = kl + ku;
+ rpvgrw = slantb_("M", "U", "N", &n, &i__8,
+ &afb[1], &ldafb, &work[1]);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = slangb_("M", &n, &kl, &ku, &
+ a[1], &lda, &work[1]) / rpvgrw;
+ }
+ }
+ result[6] = (r__1 = rpvgrw - work[1], dabs(
+ r__1)) / dmax(work[1],rpvgrw) /
+ slamch_("E");
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and */
+/* compute residual. */
+
+ sgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
+ afb[1], &ldafb, &iwork[1], &work[
+ 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ slacpy_("Full", &n, nrhs, &bsav[1], &ldb,
+ &work[1], &ldb);
+ sgbt02_(trans, &n, &n, &kl, &ku, nrhs, &
+ asav[1], &lda, &x[1], &ldb, &work[
+ 1], &ldb, &result[1]);
+
+/* Check solution from generated exact */
+/* solution. */
+
+ if (nofact || prefac && lsame_(equed,
+ "N")) {
+ sget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &rcondc, &result[2])
+ ;
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ sget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ sgbt05_(trans, &n, &kl, &ku, nrhs, &asav[
+ 1], &lda, &b[1], &ldb, &x[1], &
+ ldb, &xact[1], &ldb, &rwork[1], &
+ rwork[*nrhs + 1], &result[3]);
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from SGBSVX with the computed */
+/* value in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___72.ciunit = *nout;
+ s_wsfe(&io___72);
+ do_fio(&c__1, "SGBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___73.ciunit = *nout;
+ s_wsfe(&io___73);
+ do_fio(&c__1, "SGBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___74.ciunit = *nout;
+ s_wsfe(&io___74);
+ do_fio(&c__1, "SGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___75.ciunit = *nout;
+ s_wsfe(&io___75);
+ do_fio(&c__1, "SGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___76.ciunit = *nout;
+ s_wsfe(&io___76);
+ do_fio(&c__1, "SGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___77.ciunit = *nout;
+ s_wsfe(&io___77);
+ do_fio(&c__1, "SGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___78.ciunit = *nout;
+ s_wsfe(&io___78);
+ do_fio(&c__1, "SGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___79.ciunit = *nout;
+ s_wsfe(&io___79);
+ do_fio(&c__1, "SGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+
+ }
+/* L90: */
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+
+ return 0;
+
+/* End of SDRVGB */
+
+} /* sdrvgb_ */
diff --git a/TESTING/LIN/sdrvgbx.c b/TESTING/LIN/sdrvgbx.c
new file mode 100644
index 0000000..ee8ae1e
--- /dev/null
+++ b/TESTING/LIN/sdrvgbx.c
@@ -0,0 +1,1472 @@
+/* sdrvgbx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "memory_alloc.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static real c_b48 = 0.f;
+static real c_b49 = 1.f;
+static integer c__6 = 6;
+static integer c__7 = 7;
+
+/* Subroutine */ int sdrvgb_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, real *a, integer *la,
+ real *afb, integer *lafb, real *asav, real *b, real *bsav, real *x,
+ real *xact, real *s, real *work, real *rwork, integer *iwork, integer
+ *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*4] = "N" "R" "C" "B";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 *** In SDRVGB, LA=\002,i5,\002 is too sm"
+ "all for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> In"
+ "crease LA to at least \002,i5)";
+ static char fmt_9998[] = "(\002 *** In SDRVGB, LAFB=\002,i5,\002 is too "
+ "small for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> "
+ "Increase LAFB to at least \002,i5)";
+ static char fmt_9997[] = "(1x,a,\002, N=\002,i5,\002, KL=\002,i5,\002, K"
+ "U=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)"
+ ;
+ static char fmt_9995[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002"
+ ",i5,\002,\002,i5,\002,\002,i5,\002,...), EQUED='\002,a1,\002', t"
+ "ype \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002"
+ ",i5,\002,\002,i5,\002,\002,i5,\002,...), type \002,i1,\002, test("
+ "\002,i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10,
+ i__11[2];
+ real r__1, r__2, r__3;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ extern /* Subroutine */ int sebchvxx_(real *, char *);
+ integer i__, j, k, n;
+ real *errbnds_c__;
+ integer i1, i2, k1;
+ real *errbnds_n__;
+ integer nb, in, kl, ku, nt, n_err_bnds__, lda, ldb, ikl, nkl, iku, nku;
+ char fact[1];
+ integer ioff, mode;
+ real amax;
+ char path[3];
+ integer imat, info;
+ real *berr;
+ char dist[1];
+ real rpvgrw_svxx__;
+ char type__[1];
+ integer nrun;
+ extern doublereal sla_gbrpvgrw__(integer *, integer *, integer *, integer
+ *, real *, integer *, real *, integer *);
+ integer ldafb, ifact, nfail, iseed[4], nfact;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sgbt01_(integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *, real *
+, real *);
+ char equed[1];
+ integer nbmin;
+ real rcond, roldc;
+ extern /* Subroutine */ int sgbt02_(char *, integer *, integer *, integer
+ *, integer *, integer *, real *, integer *, real *, integer *,
+ real *, integer *, real *);
+ integer nimat;
+ real roldi;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int sgbt05_(char *, integer *, integer *, integer
+ *, integer *, real *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, real *, real *, real *);
+ real anorm;
+ integer itran;
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *);
+ logical equil;
+ real roldo;
+ extern /* Subroutine */ int sgbsv_(integer *, integer *, integer *,
+ integer *, real *, integer *, integer *, real *, integer *,
+ integer *);
+ char trans[1];
+ integer izero, nerrs;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), aladhd_(integer *, char *),
+ alaerh_(char *, char *, integer *, integer *, char *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *);
+ logical prefac;
+ real colcnd;
+ extern doublereal slangb_(char *, integer *, integer *, integer *, real *,
+ integer *, real *), slamch_(char *);
+ real rcondc;
+ extern doublereal slange_(char *, integer *, integer *, real *, integer *,
+ real *);
+ logical nofact;
+ extern /* Subroutine */ int slaqgb_(integer *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ real *, char *);
+ integer iequed;
+ real rcondi;
+ extern doublereal slantb_(char *, char *, char *, integer *, integer *,
+ real *, integer *, real *);
+ real cndnum, anormi, rcondo, ainvnm;
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ logical trfcon;
+ real anormo, rowcnd;
+ extern /* Subroutine */ int sgbequ_(integer *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ real *, integer *), sgbtrf_(integer *, integer *, integer *,
+ integer *, real *, integer *, integer *, integer *), slacpy_(char
+ *, integer *, integer *, real *, integer *, real *, integer *), slarhs_(char *, char *, char *, char *, integer *,
+ integer *, integer *, integer *, integer *, real *, integer *,
+ real *, integer *, real *, integer *, integer *, integer *);
+ real anrmpv;
+ extern /* Subroutine */ int sgbtrs_(char *, integer *, integer *, integer
+ *, integer *, real *, integer *, integer *, real *, integer *,
+ integer *), slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *), slatms_(integer *, integer *,
+ char *, integer *, char *, real *, integer *, real *, real *,
+ integer *, integer *, char *, real *, integer *, real *, integer *
+), xlaenv_(integer *, integer *), sgbsvx_(
+ char *, char *, integer *, integer *, integer *, integer *, real *
+, integer *, real *, integer *, integer *, char *, real *, real *,
+ real *, integer *, real *, integer *, real *, real *, real *,
+ real *, integer *, integer *);
+ real result[7], rpvgrw;
+ extern /* Subroutine */ int serrvx_(char *, integer *), sgbsvxx_(
+ char *, char *, integer *, integer *, integer *, integer *, real *
+, integer *, real *, integer *, integer *, char *, real *, real *,
+ real *, integer *, real *, integer *, real *, real *, real *,
+ integer *, real *, real *, integer *, real *, real *, integer *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___72 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___73 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___74 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___75 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___76 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___77 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___85 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___86 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___87 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___88 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___89 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___90 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___91 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___92 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVGB tests the driver routines SGBSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) REAL array, dimension (LA) */
+
+/* LA (input) INTEGER */
+/* The length of the array A. LA >= (2*NMAX-1)*NMAX */
+/* where NMAX is the largest entry in NVAL. */
+
+/* AFB (workspace) REAL array, dimension (LAFB) */
+
+/* LAFB (input) INTEGER */
+/* The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX */
+/* where NMAX is the largest entry in NVAL. */
+
+/* ASAV (workspace) REAL array, dimension (LA) */
+
+/* B (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* X (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* S (workspace) REAL array, dimension (2*NMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(3,NRHS,NMAX)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NRHS)) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afb;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "GB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ ldb = max(n,1);
+ *(unsigned char *)xtype = 'N';
+
+/* Set limits on the number of loop iterations. */
+
+/* Computing MAX */
+ i__2 = 1, i__3 = min(n,4);
+ nkl = max(i__2,i__3);
+ if (n == 0) {
+ nkl = 1;
+ }
+ nku = nkl;
+ nimat = 8;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nkl;
+ for (ikl = 1; ikl <= i__2; ++ikl) {
+
+/* Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes */
+/* it easier to skip redundant values for small values of N. */
+
+ if (ikl == 1) {
+ kl = 0;
+ } else if (ikl == 2) {
+/* Computing MAX */
+ i__3 = n - 1;
+ kl = max(i__3,0);
+ } else if (ikl == 3) {
+ kl = (n * 3 - 1) / 4;
+ } else if (ikl == 4) {
+ kl = (n + 1) / 4;
+ }
+ i__3 = nku;
+ for (iku = 1; iku <= i__3; ++iku) {
+
+/* Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order */
+/* makes it easier to skip redundant values for small */
+/* values of N. */
+
+ if (iku == 1) {
+ ku = 0;
+ } else if (iku == 2) {
+/* Computing MAX */
+ i__4 = n - 1;
+ ku = max(i__4,0);
+ } else if (iku == 3) {
+ ku = (n * 3 - 1) / 4;
+ } else if (iku == 4) {
+ ku = (n + 1) / 4;
+ }
+
+/* Check that A and AFB are big enough to generate this */
+/* matrix. */
+
+ lda = kl + ku + 1;
+ ldafb = (kl << 1) + ku + 1;
+ if (lda * n > *la || ldafb * n > *lafb) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (lda * n > *la) {
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, (char *)&(*la), (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ i__4 = n * (kl + ku + 1);
+ do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ if (ldafb * n > *lafb) {
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__1, (char *)&(*lafb), (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ i__4 = n * ((kl << 1) + ku + 1);
+ do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ goto L130;
+ }
+
+ i__4 = nimat;
+ for (imat = 1; imat <= i__4; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+/* Skip types 2, 3, or 4 if the matrix is too small. */
+
+ zerot = imat >= 2 && imat <= 4;
+ if (zerot && n < imat - 1) {
+ goto L120;
+ }
+
+/* Set up parameters with SLATB4 and generate a */
+/* test matrix with SLATMS. */
+
+ slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
+ mode, &cndnum, dist);
+ rcondc = 1.f / cndnum;
+
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
+ slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "Z", &a[1], &lda, &work[
+ 1], &info);
+
+/* Check the error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, " ", &n, &n, &
+ kl, &ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L120;
+ }
+
+/* For types 2, 3, and 4, zero one or more columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ izero = 0;
+ if (zerot) {
+ if (imat == 2) {
+ izero = 1;
+ } else if (imat == 3) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 4) {
+/* Computing MAX */
+ i__5 = 1, i__6 = ku + 2 - izero;
+ i1 = max(i__5,i__6);
+/* Computing MIN */
+ i__5 = kl + ku + 1, i__6 = ku + 1 + (n - izero);
+ i2 = min(i__5,i__6);
+ i__5 = i2;
+ for (i__ = i1; i__ <= i__5; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L20: */
+ }
+ } else {
+ i__5 = n;
+ for (j = izero; j <= i__5; ++j) {
+/* Computing MAX */
+ i__6 = 1, i__7 = ku + 2 - j;
+/* Computing MIN */
+ i__9 = kl + ku + 1, i__10 = ku + 1 + (n - j);
+ i__8 = min(i__9,i__10);
+ for (i__ = max(i__6,i__7); i__ <= i__8; ++i__)
+ {
+ a[ioff + i__] = 0.f;
+/* L30: */
+ }
+ ioff += lda;
+/* L40: */
+ }
+ }
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ i__5 = kl + ku + 1;
+ slacpy_("Full", &i__5, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 4; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__5 = nfact;
+ for (ifact = 1; ifact <= i__5; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L100;
+ }
+ rcondo = 0.f;
+ rcondi = 0.f;
+
+ } else if (! nofact) {
+
+/* Compute the condition number for comparison */
+/* with the value returned by SGESVX (FACT = */
+/* 'N' reuses the condition number from the */
+/* previous iteration with FACT = 'F'). */
+
+ i__8 = kl + ku + 1;
+ slacpy_("Full", &i__8, &n, &asav[1], &lda, &
+ afb[kl + 1], &ldafb);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ sgbequ_(&n, &n, &kl, &ku, &afb[kl + 1], &
+ ldafb, &s[1], &s[n + 1], &rowcnd,
+ &colcnd, &amax, &info);
+ if (info == 0 && n > 0) {
+ if (lsame_(equed, "R")) {
+ rowcnd = 0.f;
+ colcnd = 1.f;
+ } else if (lsame_(equed, "C")) {
+ rowcnd = 1.f;
+ colcnd = 0.f;
+ } else if (lsame_(equed, "B")) {
+ rowcnd = 0.f;
+ colcnd = 0.f;
+ }
+
+/* Equilibrate the matrix. */
+
+ slaqgb_(&n, &n, &kl, &ku, &afb[kl + 1]
+, &ldafb, &s[1], &s[n + 1], &
+ rowcnd, &colcnd, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in SGET04. */
+
+ if (equil) {
+ roldo = rcondo;
+ roldi = rcondi;
+ }
+
+/* Compute the 1-norm and infinity-norm of A. */
+
+ anormo = slangb_("1", &n, &kl, &ku, &afb[kl +
+ 1], &ldafb, &rwork[1]);
+ anormi = slangb_("I", &n, &kl, &ku, &afb[kl +
+ 1], &ldafb, &rwork[1]);
+
+/* Factor the matrix A. */
+
+ sgbtrf_(&n, &n, &kl, &ku, &afb[1], &ldafb, &
+ iwork[1], &info);
+
+/* Form the inverse of A. */
+
+ slaset_("Full", &n, &n, &c_b48, &c_b49, &work[
+ 1], &ldb);
+ s_copy(srnamc_1.srnamt, "SGBTRS", (ftnlen)32,
+ (ftnlen)6);
+ sgbtrs_("No transpose", &n, &kl, &ku, &n, &
+ afb[1], &ldafb, &iwork[1], &work[1], &
+ ldb, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = slange_("1", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormo <= 0.f || ainvnm <= 0.f) {
+ rcondo = 1.f;
+ } else {
+ rcondo = 1.f / anormo / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number */
+/* of A. */
+
+ ainvnm = slange_("I", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormi <= 0.f || ainvnm <= 0.f) {
+ rcondi = 1.f;
+ } else {
+ rcondi = 1.f / anormi / ainvnm;
+ }
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for each value of TRANS. */
+
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Restore the matrix A. */
+
+ i__8 = kl + ku + 1;
+ slacpy_("Full", &i__8, &n, &asav[1], &lda, &a[
+ 1], &lda);
+
+/* Form an exact solution and set the right hand */
+/* side. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32,
+ (ftnlen)6);
+ slarhs_(path, xtype, "Full", trans, &n, &n, &
+ kl, &ku, nrhs, &a[1], &lda, &xact[1],
+ &ldb, &b[1], &ldb, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ slacpy_("Full", &n, nrhs, &b[1], &ldb, &bsav[
+ 1], &ldb);
+
+ if (nofact && itran == 1) {
+
+/* --- Test SGBSV --- */
+
+/* Compute the LU factorization of the matrix */
+/* and solve the system. */
+
+ i__8 = kl + ku + 1;
+ slacpy_("Full", &i__8, &n, &a[1], &lda, &
+ afb[kl + 1], &ldafb);
+ slacpy_("Full", &n, nrhs, &b[1], &ldb, &x[
+ 1], &ldb);
+
+ s_copy(srnamc_1.srnamt, "SGBSV ", (ftnlen)
+ 32, (ftnlen)6);
+ sgbsv_(&n, &kl, &ku, nrhs, &afb[1], &
+ ldafb, &iwork[1], &x[1], &ldb, &
+ info);
+
+/* Check error code from SGBSV . */
+
+ if (info == n + 1) {
+ goto L90;
+ }
+ if (info != izero) {
+ alaerh_(path, "SGBSV ", &info, &izero,
+ " ", &n, &n, &kl, &ku, nrhs,
+ &imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+
+/* Reconstruct matrix from factors and */
+/* compute residual. */
+
+ sgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
+ afb[1], &ldafb, &iwork[1], &work[
+ 1], result);
+ nt = 1;
+ if (izero == 0) {
+
+/* Compute residual of the computed */
+/* solution. */
+
+ slacpy_("Full", &n, nrhs, &b[1], &ldb,
+ &work[1], &ldb);
+ sgbt02_("No transpose", &n, &n, &kl, &
+ ku, nrhs, &a[1], &lda, &x[1],
+ &ldb, &work[1], &ldb, &result[
+ 1]);
+
+/* Check solution from generated exact */
+/* solution. */
+
+ sget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &rcondc, &result[2])
+ ;
+ nt = 3;
+ }
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ i__8 = nt;
+ for (k = 1; k <= i__8; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___65.ciunit = *nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, "SGBSV ", (ftnlen)6)
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k -
+ 1], (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L50: */
+ }
+ nrun += nt;
+ }
+
+/* --- Test SGBSVX --- */
+
+ if (! prefac) {
+ i__8 = (kl << 1) + ku + 1;
+ slaset_("Full", &i__8, &n, &c_b48, &c_b48,
+ &afb[1], &ldafb);
+ }
+ slaset_("Full", &n, nrhs, &c_b48, &c_b48, &x[
+ 1], &ldb);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ slaqgb_(&n, &n, &kl, &ku, &a[1], &lda, &s[
+ 1], &s[n + 1], &rowcnd, &colcnd, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition */
+/* number and error bounds using SGBSVX. */
+
+ s_copy(srnamc_1.srnamt, "SGBSVX", (ftnlen)32,
+ (ftnlen)6);
+ sgbsvx_(fact, trans, &n, &kl, &ku, nrhs, &a[1]
+, &lda, &afb[1], &ldafb, &iwork[1],
+ equed, &s[1], &s[n + 1], &b[1], &ldb,
+ &x[1], &ldb, &rcond, &rwork[1], &
+ rwork[*nrhs + 1], &work[1], &iwork[n
+ + 1], &info);
+
+/* Check the error code from SGBSVX. */
+
+ if (info == n + 1) {
+ goto L90;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__11[0] = 1, a__1[0] = fact;
+ i__11[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__11, &c__2, (ftnlen)
+ 2);
+ alaerh_(path, "SGBSVX", &info, &izero,
+ ch__1, &n, &n, &kl, &ku, nrhs, &
+ imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+
+/* Compare WORK(1) from SGBSVX with the computed */
+/* reciprocal pivot growth factor RPVGRW */
+
+ if (info != 0) {
+ anrmpv = 0.f;
+ i__8 = info;
+ for (j = 1; j <= i__8; ++j) {
+/* Computing MAX */
+ i__6 = ku + 2 - j;
+/* Computing MIN */
+ i__9 = n + ku + 1 - j, i__10 = kl +
+ ku + 1;
+ i__7 = min(i__9,i__10);
+ for (i__ = max(i__6,1); i__ <= i__7;
+ ++i__) {
+/* Computing MAX */
+ r__2 = anrmpv, r__3 = (r__1 = a[
+ i__ + (j - 1) * lda],
+ dabs(r__1));
+ anrmpv = dmax(r__2,r__3);
+/* L60: */
+ }
+/* L70: */
+ }
+/* Computing MIN */
+ i__7 = info - 1, i__6 = kl + ku;
+ i__8 = min(i__7,i__6);
+/* Computing MAX */
+ i__9 = 1, i__10 = kl + ku + 2 - info;
+ rpvgrw = slantb_("M", "U", "N", &info, &
+ i__8, &afb[max(i__9, i__10)], &
+ ldafb, &work[1]);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = anrmpv / rpvgrw;
+ }
+ } else {
+ i__8 = kl + ku;
+ rpvgrw = slantb_("M", "U", "N", &n, &i__8,
+ &afb[1], &ldafb, &work[1]);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = slangb_("M", &n, &kl, &ku, &
+ a[1], &lda, &work[1]) / rpvgrw;
+ }
+ }
+ result[6] = (r__1 = rpvgrw - work[1], dabs(
+ r__1)) / dmax(work[1],rpvgrw) /
+ slamch_("E");
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and */
+/* compute residual. */
+
+ sgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
+ afb[1], &ldafb, &iwork[1], &work[
+ 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ slacpy_("Full", &n, nrhs, &bsav[1], &ldb,
+ &work[1], &ldb);
+ sgbt02_(trans, &n, &n, &kl, &ku, nrhs, &
+ asav[1], &lda, &x[1], &ldb, &work[
+ 1], &ldb, &result[1]);
+
+/* Check solution from generated exact */
+/* solution. */
+
+ if (nofact || prefac && lsame_(equed,
+ "N")) {
+ sget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &rcondc, &result[2])
+ ;
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ sget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ sgbt05_(trans, &n, &kl, &ku, nrhs, &asav[
+ 1], &lda, &b[1], &ldb, &x[1], &
+ ldb, &xact[1], &ldb, &rwork[1], &
+ rwork[*nrhs + 1], &result[3]);
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from SGBSVX with the computed */
+/* value in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___72.ciunit = *nout;
+ s_wsfe(&io___72);
+ do_fio(&c__1, "SGBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___73.ciunit = *nout;
+ s_wsfe(&io___73);
+ do_fio(&c__1, "SGBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___74.ciunit = *nout;
+ s_wsfe(&io___74);
+ do_fio(&c__1, "SGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___75.ciunit = *nout;
+ s_wsfe(&io___75);
+ do_fio(&c__1, "SGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___76.ciunit = *nout;
+ s_wsfe(&io___76);
+ do_fio(&c__1, "SGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___77.ciunit = *nout;
+ s_wsfe(&io___77);
+ do_fio(&c__1, "SGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___78.ciunit = *nout;
+ s_wsfe(&io___78);
+ do_fio(&c__1, "SGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___79.ciunit = *nout;
+ s_wsfe(&io___79);
+ do_fio(&c__1, "SGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+
+ }
+
+/* --- Test SGBSVXX --- */
+
+/* Restore the matrices A and B. */
+
+ i__8 = kl + ku + 1;
+ slacpy_("Full", &i__8, &n, &asav[1], &lda, &a[
+ 1], &lda);
+ slacpy_("Full", &n, nrhs, &bsav[1], &ldb, &b[
+ 1], &ldb);
+ if (! prefac) {
+ i__8 = (kl << 1) + ku + 1;
+ slaset_("Full", &i__8, &n, &c_b48, &c_b48,
+ &afb[1], &ldafb);
+ }
+ slaset_("Full", &n, nrhs, &c_b48, &c_b48, &x[
+ 1], &ldb);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ slaqgb_(&n, &n, &kl, &ku, &a[1], &lda, &s[
+ 1], &s[n + 1], &rowcnd, &colcnd, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using SGBSVXX. */
+
+ s_copy(srnamc_1.srnamt, "SGBSVXX", (ftnlen)32,
+ (ftnlen)7);
+ n_err_bnds__ = 3;
+
+ salloc3();
+
+ sgbsvxx_(fact, trans, &n, &kl, &ku, nrhs, &a[
+ 1], &lda, &afb[1], &ldafb, &iwork[1],
+ equed, &s[1], &s[n + 1], &b[1], &ldb,
+ &x[1], &ldb, &rcond, &rpvgrw_svxx__,
+ berr, &n_err_bnds__, errbnds_n__,
+ errbnds_c__, &c__0, &c_b48, &work[1],
+ &iwork[n + 1], &info);
+
+ free3();
+
+/* Check the error code from SGBSVXX. */
+
+ if (info == n + 1) {
+ goto L90;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__11[0] = 1, a__1[0] = fact;
+ i__11[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__11, &c__2, (ftnlen)
+ 2);
+ alaerh_(path, "SGBSVXX", &info, &izero,
+ ch__1, &n, &n, &c_n1, &c_n1, nrhs,
+ &imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+
+/* Compare rpvgrw_svxx from SGBSVXX with the computed */
+/* reciprocal pivot growth factor RPVGRW */
+
+ if (info > 0 && info < n + 1) {
+ rpvgrw = sla_gbrpvgrw__(&n, &kl, &ku, &
+ info, &a[1], &lda, &afb[1], &
+ ldafb);
+ } else {
+ rpvgrw = sla_gbrpvgrw__(&n, &kl, &ku, &n,
+ &a[1], &lda, &afb[1], &ldafb);
+ }
+ result[6] = (r__1 = rpvgrw - rpvgrw_svxx__,
+ dabs(r__1)) / dmax(rpvgrw_svxx__,
+ rpvgrw) / slamch_("E");
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ sgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
+ afb[1], &ldafb, &iwork[1], &work[
+ 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ slacpy_("Full", &n, nrhs, &bsav[1], &ldb,
+ &work[1], &ldb);
+ sgbt02_(trans, &n, &n, &kl, &ku, nrhs, &
+ asav[1], &lda, &x[1], &ldb, &work[
+ 1], &ldb, &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed,
+ "N")) {
+ sget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &rcondc, &result[2])
+ ;
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ sget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &roldc, &result[2]);
+ }
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from SGBSVXX with the computed value */
+/* in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___85.ciunit = *nout;
+ s_wsfe(&io___85);
+ do_fio(&c__1, "SGBSVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___86.ciunit = *nout;
+ s_wsfe(&io___86);
+ do_fio(&c__1, "SGBSVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L45: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___87.ciunit = *nout;
+ s_wsfe(&io___87);
+ do_fio(&c__1, "SGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___88.ciunit = *nout;
+ s_wsfe(&io___88);
+ do_fio(&c__1, "SGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___89.ciunit = *nout;
+ s_wsfe(&io___89);
+ do_fio(&c__1, "SGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___90.ciunit = *nout;
+ s_wsfe(&io___90);
+ do_fio(&c__1, "SGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___91.ciunit = *nout;
+ s_wsfe(&io___91);
+ do_fio(&c__1, "SGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___92.ciunit = *nout;
+ s_wsfe(&io___92);
+ do_fio(&c__1, "SGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ }
+
+L90:
+ ;
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+/* Test Error Bounds from SGBSVXX */
+ sebchvxx_(thresh, path);
+
+ return 0;
+
+/* End of SDRVGB */
+
+} /* sdrvgb_ */
diff --git a/TESTING/LIN/sdrvge.c b/TESTING/LIN/sdrvge.c
new file mode 100644
index 0000000..ee81f4b
--- /dev/null
+++ b/TESTING/LIN/sdrvge.c
@@ -0,0 +1,899 @@
+/* sdrvge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static real c_b20 = 0.f;
+static logical c_true = TRUE_;
+static integer c__6 = 6;
+static integer c__7 = 7;
+
+/* Subroutine */ int sdrvge_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, integer *nmax, real *a,
+ real *afac, real *asav, real *b, real *bsav, real *x, real *xact,
+ real *s, real *work, real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*4] = "N" "R" "C" "B";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
+ ", test(\002,i2,\002) =\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
+ "1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i2,\002"
+ ", test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
+ "1,\002', N=\002,i5,\002, type \002,i2,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ real r__1;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, k, n, k1, nb, in, kl, ku, nt, lda;
+ char fact[1];
+ integer ioff, mode;
+ real amax;
+ char path[3];
+ integer imat, info;
+ char dist[1], type__[1];
+ integer nrun, ifact, nfail, iseed[4], nfact;
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ real rcond, roldc;
+ extern /* Subroutine */ int sget01_(integer *, integer *, real *, integer
+ *, real *, integer *, integer *, real *, real *);
+ integer nimat;
+ real roldi;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int sget02_(char *, integer *, integer *, integer
+ *, real *, integer *, real *, integer *, real *, integer *, real *
+, real *);
+ real anorm;
+ integer itran;
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *);
+ logical equil;
+ real roldo;
+ extern /* Subroutine */ int sget07_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, logical *, real *, real *);
+ char trans[1];
+ integer izero, nerrs;
+ extern /* Subroutine */ int sgesv_(integer *, integer *, real *, integer *
+, integer *, real *, integer *, integer *);
+ integer lwork;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), aladhd_(integer *, char *),
+ alaerh_(char *, char *, integer *, integer *, char *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *);
+ logical prefac;
+ real colcnd;
+ extern doublereal slamch_(char *);
+ real rcondc;
+ extern doublereal slange_(char *, integer *, integer *, real *, integer *,
+ real *);
+ logical nofact;
+ integer iequed;
+ extern /* Subroutine */ int slaqge_(integer *, integer *, real *, integer
+ *, real *, real *, real *, real *, real *, char *);
+ real rcondi;
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ real cndnum, anormi, rcondo, ainvnm;
+ extern /* Subroutine */ int sgeequ_(integer *, integer *, real *, integer
+ *, real *, real *, real *, real *, real *, integer *);
+ logical trfcon;
+ real anormo, rowcnd;
+ extern /* Subroutine */ int sgetrf_(integer *, integer *, real *, integer
+ *, integer *, integer *), sgetri_(integer *, real *, integer *,
+ integer *, real *, integer *, integer *), slacpy_(char *, integer
+ *, integer *, real *, integer *, real *, integer *),
+ slarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, integer *, integer *);
+ extern doublereal slantr_(char *, char *, char *, integer *, integer *,
+ real *, integer *, real *);
+ extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *), slatms_(integer *, integer *,
+ char *, integer *, char *, real *, integer *, real *, real *,
+ integer *, integer *, char *, real *, integer *, real *, integer *
+), xlaenv_(integer *, integer *);
+ real result[7];
+ extern /* Subroutine */ int sgesvx_(char *, char *, integer *, integer *,
+ real *, integer *, real *, integer *, integer *, char *, real *,
+ real *, real *, integer *, real *, integer *, real *, real *,
+ real *, real *, integer *, integer *);
+ real rpvgrw;
+ extern /* Subroutine */ int serrvx_(char *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___68 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVGE tests the driver routines SGESV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* B (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* X (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* S (workspace) REAL array, dimension (2*NMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) REAL array, dimension (2*NRHS+NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "GE", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 11;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L80;
+ }
+
+/* Skip types 5, 6, or 7 if the matrix size is too small. */
+
+ zerot = imat >= 5 && imat <= 7;
+ if (zerot && n < imat - 4) {
+ goto L80;
+ }
+
+/* Set up parameters with SLATB4 and generate a test matrix */
+/* with SLATMS. */
+
+ slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cndnum, dist);
+ rcondc = 1.f / cndnum;
+
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
+ slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cndnum, &
+ anorm, &kl, &ku, "No packing", &a[1], &lda, &work[1], &
+ info);
+
+/* Check error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, " ", &n, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L80;
+ }
+
+/* For types 5-7, zero one or more columns of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 5) {
+ izero = 1;
+ } else if (imat == 6) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 7) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L20: */
+ }
+ } else {
+ i__3 = n - izero + 1;
+ slaset_("Full", &n, &i__3, &c_b20, &c_b20, &a[ioff + 1], &
+ lda);
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ slacpy_("Full", &n, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 4; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[iequed -
+ 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__3 = nfact;
+ for (ifact = 1; ifact <= i__3; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[ifact -
+ 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L60;
+ }
+ rcondo = 0.f;
+ rcondi = 0.f;
+
+ } else if (! nofact) {
+
+/* Compute the condition number for comparison with */
+/* the value returned by SGESVX (FACT = 'N' reuses */
+/* the condition number from the previous iteration */
+/* with FACT = 'F'). */
+
+ slacpy_("Full", &n, &n, &asav[1], &lda, &afac[1], &
+ lda);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ sgeequ_(&n, &n, &afac[1], &lda, &s[1], &s[n + 1],
+ &rowcnd, &colcnd, &amax, &info);
+ if (info == 0 && n > 0) {
+ if (lsame_(equed, "R"))
+ {
+ rowcnd = 0.f;
+ colcnd = 1.f;
+ } else if (lsame_(equed, "C")) {
+ rowcnd = 1.f;
+ colcnd = 0.f;
+ } else if (lsame_(equed, "B")) {
+ rowcnd = 0.f;
+ colcnd = 0.f;
+ }
+
+/* Equilibrate the matrix. */
+
+ slaqge_(&n, &n, &afac[1], &lda, &s[1], &s[n +
+ 1], &rowcnd, &colcnd, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the non-equilibrated */
+/* system for use in SGET04. */
+
+ if (equil) {
+ roldo = rcondo;
+ roldi = rcondi;
+ }
+
+/* Compute the 1-norm and infinity-norm of A. */
+
+ anormo = slange_("1", &n, &n, &afac[1], &lda, &rwork[
+ 1]);
+ anormi = slange_("I", &n, &n, &afac[1], &lda, &rwork[
+ 1]);
+
+/* Factor the matrix A. */
+
+ sgetrf_(&n, &n, &afac[1], &lda, &iwork[1], &info);
+
+/* Form the inverse of A. */
+
+ slacpy_("Full", &n, &n, &afac[1], &lda, &a[1], &lda);
+ lwork = *nmax * max(3,*nrhs);
+ sgetri_(&n, &a[1], &lda, &iwork[1], &work[1], &lwork,
+ &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = slange_("1", &n, &n, &a[1], &lda, &rwork[1]);
+ if (anormo <= 0.f || ainvnm <= 0.f) {
+ rcondo = 1.f;
+ } else {
+ rcondo = 1.f / anormo / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ ainvnm = slange_("I", &n, &n, &a[1], &lda, &rwork[1]);
+ if (anormi <= 0.f || ainvnm <= 0.f) {
+ rcondi = 1.f;
+ } else {
+ rcondi = 1.f / anormi / ainvnm;
+ }
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for each value of TRANS. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[
+ itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Restore the matrix A. */
+
+ slacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ slarhs_(path, xtype, "Full", trans, &n, &n, &kl, &ku,
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
+
+ if (nofact && itran == 1) {
+
+/* --- Test SGESV --- */
+
+/* Compute the LU factorization of the matrix and */
+/* solve the system. */
+
+ slacpy_("Full", &n, &n, &a[1], &lda, &afac[1], &
+ lda);
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "SGESV ", (ftnlen)32, (
+ ftnlen)6);
+ sgesv_(&n, nrhs, &afac[1], &lda, &iwork[1], &x[1],
+ &lda, &info);
+
+/* Check error code from SGESV . */
+
+ if (info != izero) {
+ alaerh_(path, "SGESV ", &info, &izero, " ", &
+ n, &n, &c_n1, &c_n1, nrhs, &imat, &
+ nfail, &nerrs, nout);
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ sget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &rwork[1], result);
+ nt = 1;
+ if (izero == 0) {
+
+/* Compute residual of the computed solution. */
+
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &work[
+ 1], &lda);
+ sget02_("No transpose", &n, &n, nrhs, &a[1], &
+ lda, &x[1], &lda, &work[1], &lda, &
+ rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ nt = 3;
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___55.ciunit = *nout;
+ s_wsfe(&io___55);
+ do_fio(&c__1, "SGESV ", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L30: */
+ }
+ nrun += nt;
+ }
+
+/* --- Test SGESVX --- */
+
+ if (! prefac) {
+ slaset_("Full", &n, &n, &c_b20, &c_b20, &afac[1],
+ &lda);
+ }
+ slaset_("Full", &n, nrhs, &c_b20, &c_b20, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ slaqge_(&n, &n, &a[1], &lda, &s[1], &s[n + 1], &
+ rowcnd, &colcnd, &amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using SGESVX. */
+
+ s_copy(srnamc_1.srnamt, "SGESVX", (ftnlen)32, (ftnlen)
+ 6);
+ sgesvx_(fact, trans, &n, nrhs, &a[1], &lda, &afac[1],
+ &lda, &iwork[1], equed, &s[1], &s[n + 1], &b[
+ 1], &lda, &x[1], &lda, &rcond, &rwork[1], &
+ rwork[*nrhs + 1], &work[1], &iwork[n + 1], &
+ info);
+
+/* Check the error code from SGESVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "SGESVX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+/* Compare WORK(1) from SGESVX with the computed */
+/* reciprocal pivot growth factor RPVGRW */
+
+ if (info != 0) {
+ rpvgrw = slantr_("M", "U", "N", &info, &info, &
+ afac[1], &lda, &work[1]);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = slange_("M", &n, &info, &a[1], &lda,
+ &work[1]) / rpvgrw;
+ }
+ } else {
+ rpvgrw = slantr_("M", "U", "N", &n, &n, &afac[1],
+ &lda, &work[1]);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = slange_("M", &n, &n, &a[1], &lda, &
+ work[1]) / rpvgrw;
+ }
+ }
+ result[6] = (r__1 = rpvgrw - work[1], dabs(r__1)) /
+ dmax(work[1],rpvgrw) / slamch_("E")
+ ;
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ sget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &rwork[(*nrhs << 1) + 1],
+ result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ slacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ sget02_(trans, &n, &n, nrhs, &asav[1], &lda, &x[1]
+, &lda, &work[1], &lda, &rwork[(*nrhs <<
+ 1) + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ sget07_(trans, &n, nrhs, &asav[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &c_true, &rwork[*nrhs + 1], &result[3]
+);
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from SGESVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___61.ciunit = *nout;
+ s_wsfe(&io___61);
+ do_fio(&c__1, "SGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___62.ciunit = *nout;
+ s_wsfe(&io___62);
+ do_fio(&c__1, "SGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L40: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___63.ciunit = *nout;
+ s_wsfe(&io___63);
+ do_fio(&c__1, "SGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___64.ciunit = *nout;
+ s_wsfe(&io___64);
+ do_fio(&c__1, "SGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___65.ciunit = *nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, "SGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___66.ciunit = *nout;
+ s_wsfe(&io___66);
+ do_fio(&c__1, "SGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___67.ciunit = *nout;
+ s_wsfe(&io___67);
+ do_fio(&c__1, "SGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___68.ciunit = *nout;
+ s_wsfe(&io___68);
+ do_fio(&c__1, "SGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+
+ }
+
+/* L50: */
+ }
+L60:
+ ;
+ }
+/* L70: */
+ }
+L80:
+ ;
+ }
+/* L90: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SDRVGE */
+
+} /* sdrvge_ */
diff --git a/TESTING/LIN/sdrvgex.c b/TESTING/LIN/sdrvgex.c
new file mode 100644
index 0000000..b2dcee4
--- /dev/null
+++ b/TESTING/LIN/sdrvgex.c
@@ -0,0 +1,1216 @@
+/* sdrvgex.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "memory_alloc.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static real c_b20 = 0.f;
+static logical c_true = TRUE_;
+static integer c__6 = 6;
+static integer c__7 = 7;
+
+/* Subroutine */ int sdrvge_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, integer *nmax, real *a,
+ real *afac, real *asav, real *b, real *bsav, real *x, real *xact,
+ real *s, real *work, real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*4] = "N" "R" "C" "B";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
+ ", test(\002,i2,\002) =\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
+ "1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i2,\002"
+ ", test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
+ "1,\002', N=\002,i5,\002, type \002,i2,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ real r__1;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ extern /* Subroutine */ int sebchvxx_(real *, char *);
+ integer i__, k, n;
+ real *errbnds_c__, *errbnds_n__;
+ integer k1, nb, in, kl, ku, nt, n_err_bnds__;
+ extern doublereal sla_rpvgrw__(integer *, integer *, real *, integer *,
+ real *, integer *);
+ integer lda;
+ char fact[1];
+ integer ioff, mode;
+ real amax;
+ char path[3];
+ integer imat, info;
+ real *berr;
+ char dist[1];
+ real rpvgrw_svxx__;
+ char type__[1];
+ integer nrun, ifact, nfail, iseed[4], nfact;
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ real rcond, roldc;
+ extern /* Subroutine */ int sget01_(integer *, integer *, real *, integer
+ *, real *, integer *, integer *, real *, real *);
+ integer nimat;
+ real roldi;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int sget02_(char *, integer *, integer *, integer
+ *, real *, integer *, real *, integer *, real *, integer *, real *
+, real *);
+ real anorm;
+ integer itran;
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *);
+ logical equil;
+ real roldo;
+ extern /* Subroutine */ int sget07_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, logical *, real *, real *);
+ char trans[1];
+ integer izero, nerrs;
+ extern /* Subroutine */ int sgesv_(integer *, integer *, real *, integer *
+, integer *, real *, integer *, integer *);
+ integer lwork;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), aladhd_(integer *, char *),
+ alaerh_(char *, char *, integer *, integer *, char *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *);
+ logical prefac;
+ real colcnd;
+ extern doublereal slamch_(char *);
+ real rcondc;
+ extern doublereal slange_(char *, integer *, integer *, real *, integer *,
+ real *);
+ logical nofact;
+ integer iequed;
+ extern /* Subroutine */ int slaqge_(integer *, integer *, real *, integer
+ *, real *, real *, real *, real *, real *, char *);
+ real rcondi;
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ real cndnum, anormi, rcondo, ainvnm;
+ extern /* Subroutine */ int sgeequ_(integer *, integer *, real *, integer
+ *, real *, real *, real *, real *, real *, integer *);
+ logical trfcon;
+ real anormo, rowcnd;
+ extern /* Subroutine */ int sgetrf_(integer *, integer *, real *, integer
+ *, integer *, integer *), sgetri_(integer *, real *, integer *,
+ integer *, real *, integer *, integer *), slacpy_(char *, integer
+ *, integer *, real *, integer *, real *, integer *),
+ slarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, integer *, integer *);
+ extern doublereal slantr_(char *, char *, char *, integer *, integer *,
+ real *, integer *, real *);
+ extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *), slatms_(integer *, integer *,
+ char *, integer *, char *, real *, integer *, real *, real *,
+ integer *, integer *, char *, real *, integer *, real *, integer *
+), xlaenv_(integer *, integer *);
+ real result[7];
+ extern /* Subroutine */ int sgesvx_(char *, char *, integer *, integer *,
+ real *, integer *, real *, integer *, integer *, char *, real *,
+ real *, real *, integer *, real *, integer *, real *, real *,
+ real *, real *, integer *, integer *);
+ real rpvgrw;
+ extern /* Subroutine */ int serrvx_(char *, integer *), sgesvxx_(
+ char *, char *, integer *, integer *, real *, integer *, real *,
+ integer *, integer *, char *, real *, real *, real *, integer *,
+ real *, integer *, real *, real *, real *, integer *, real *,
+ real *, integer *, real *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___68 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___74 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___75 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___76 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___77 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___80 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___81 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVGE tests the driver routines SGESV, -SVX, and -SVXX. */
+
+/* Note that this file is used only when the XBLAS are available, */
+/* otherwise sdrvge.f defines this subroutine. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* B (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* X (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* S (workspace) REAL array, dimension (2*NMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) REAL array, dimension (2*NRHS+NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "GE", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 11;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L80;
+ }
+
+/* Skip types 5, 6, or 7 if the matrix size is too small. */
+
+ zerot = imat >= 5 && imat <= 7;
+ if (zerot && n < imat - 4) {
+ goto L80;
+ }
+
+/* Set up parameters with SLATB4 and generate a test matrix */
+/* with SLATMS. */
+
+ slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cndnum, dist);
+ rcondc = 1.f / cndnum;
+
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
+ slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cndnum, &
+ anorm, &kl, &ku, "No packing", &a[1], &lda, &work[1], &
+ info);
+
+/* Check error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, " ", &n, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L80;
+ }
+
+/* For types 5-7, zero one or more columns of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 5) {
+ izero = 1;
+ } else if (imat == 6) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 7) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L20: */
+ }
+ } else {
+ i__3 = n - izero + 1;
+ slaset_("Full", &n, &i__3, &c_b20, &c_b20, &a[ioff + 1], &
+ lda);
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ slacpy_("Full", &n, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 4; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[iequed -
+ 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__3 = nfact;
+ for (ifact = 1; ifact <= i__3; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[ifact -
+ 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L60;
+ }
+ rcondo = 0.f;
+ rcondi = 0.f;
+
+ } else if (! nofact) {
+
+/* Compute the condition number for comparison with */
+/* the value returned by SGESVX (FACT = 'N' reuses */
+/* the condition number from the previous iteration */
+/* with FACT = 'F'). */
+
+ slacpy_("Full", &n, &n, &asav[1], &lda, &afac[1], &
+ lda);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ sgeequ_(&n, &n, &afac[1], &lda, &s[1], &s[n + 1],
+ &rowcnd, &colcnd, &amax, &info);
+ if (info == 0 && n > 0) {
+ if (lsame_(equed, "R"))
+ {
+ rowcnd = 0.f;
+ colcnd = 1.f;
+ } else if (lsame_(equed, "C")) {
+ rowcnd = 1.f;
+ colcnd = 0.f;
+ } else if (lsame_(equed, "B")) {
+ rowcnd = 0.f;
+ colcnd = 0.f;
+ }
+
+/* Equilibrate the matrix. */
+
+ slaqge_(&n, &n, &afac[1], &lda, &s[1], &s[n +
+ 1], &rowcnd, &colcnd, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the non-equilibrated */
+/* system for use in SGET04. */
+
+ if (equil) {
+ roldo = rcondo;
+ roldi = rcondi;
+ }
+
+/* Compute the 1-norm and infinity-norm of A. */
+
+ anormo = slange_("1", &n, &n, &afac[1], &lda, &rwork[
+ 1]);
+ anormi = slange_("I", &n, &n, &afac[1], &lda, &rwork[
+ 1]);
+
+/* Factor the matrix A. */
+
+ sgetrf_(&n, &n, &afac[1], &lda, &iwork[1], &info);
+
+/* Form the inverse of A. */
+
+ slacpy_("Full", &n, &n, &afac[1], &lda, &a[1], &lda);
+ lwork = *nmax * max(3,*nrhs);
+ sgetri_(&n, &a[1], &lda, &iwork[1], &work[1], &lwork,
+ &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = slange_("1", &n, &n, &a[1], &lda, &rwork[1]);
+ if (anormo <= 0.f || ainvnm <= 0.f) {
+ rcondo = 1.f;
+ } else {
+ rcondo = 1.f / anormo / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ ainvnm = slange_("I", &n, &n, &a[1], &lda, &rwork[1]);
+ if (anormi <= 0.f || ainvnm <= 0.f) {
+ rcondi = 1.f;
+ } else {
+ rcondi = 1.f / anormi / ainvnm;
+ }
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+ for (i__ = 1; i__ <= 7; ++i__) {
+ result[i__ - 1] = 0.f;
+ }
+
+/* Do for each value of TRANS. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[
+ itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Restore the matrix A. */
+
+ slacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ slarhs_(path, xtype, "Full", trans, &n, &n, &kl, &ku,
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
+
+ if (nofact && itran == 1) {
+
+/* --- Test SGESV --- */
+
+/* Compute the LU factorization of the matrix and */
+/* solve the system. */
+
+ slacpy_("Full", &n, &n, &a[1], &lda, &afac[1], &
+ lda);
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "SGESV ", (ftnlen)32, (
+ ftnlen)6);
+ sgesv_(&n, nrhs, &afac[1], &lda, &iwork[1], &x[1],
+ &lda, &info);
+
+/* Check error code from SGESV . */
+
+ if (info != izero) {
+ alaerh_(path, "SGESV ", &info, &izero, " ", &
+ n, &n, &c_n1, &c_n1, nrhs, &imat, &
+ nfail, &nerrs, nout);
+ goto L50;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ sget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &rwork[1], result);
+ nt = 1;
+ if (izero == 0) {
+
+/* Compute residual of the computed solution. */
+
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &work[
+ 1], &lda);
+ sget02_("No transpose", &n, &n, nrhs, &a[1], &
+ lda, &x[1], &lda, &work[1], &lda, &
+ rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ nt = 3;
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___55.ciunit = *nout;
+ s_wsfe(&io___55);
+ do_fio(&c__1, "SGESV ", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L30: */
+ }
+ nrun += nt;
+ }
+
+/* --- Test SGESVX --- */
+
+ if (! prefac) {
+ slaset_("Full", &n, &n, &c_b20, &c_b20, &afac[1],
+ &lda);
+ }
+ slaset_("Full", &n, nrhs, &c_b20, &c_b20, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ slaqge_(&n, &n, &a[1], &lda, &s[1], &s[n + 1], &
+ rowcnd, &colcnd, &amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using SGESVX. */
+
+ s_copy(srnamc_1.srnamt, "SGESVX", (ftnlen)32, (ftnlen)
+ 6);
+ sgesvx_(fact, trans, &n, nrhs, &a[1], &lda, &afac[1],
+ &lda, &iwork[1], equed, &s[1], &s[n + 1], &b[
+ 1], &lda, &x[1], &lda, &rcond, &rwork[1], &
+ rwork[*nrhs + 1], &work[1], &iwork[n + 1], &
+ info);
+
+/* Check the error code from SGESVX. */
+
+ if (info == n + 1) {
+ goto L50;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "SGESVX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L50;
+ }
+
+/* Compare WORK(1) from SGESVX with the computed */
+/* reciprocal pivot growth factor RPVGRW */
+
+ if (info != 0) {
+ rpvgrw = slantr_("M", "U", "N", &info, &info, &
+ afac[1], &lda, &work[1]);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = slange_("M", &n, &info, &a[1], &lda,
+ &work[1]) / rpvgrw;
+ }
+ } else {
+ rpvgrw = slantr_("M", "U", "N", &n, &n, &afac[1],
+ &lda, &work[1]);
+ if (rpvgrw == 0.f) {
+ rpvgrw = 1.f;
+ } else {
+ rpvgrw = slange_("M", &n, &n, &a[1], &lda, &
+ work[1]) / rpvgrw;
+ }
+ }
+ result[6] = (r__1 = rpvgrw - work[1], dabs(r__1)) /
+ dmax(work[1],rpvgrw) / slamch_("E")
+ ;
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ sget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &rwork[(*nrhs << 1) + 1],
+ result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ slacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ sget02_(trans, &n, &n, nrhs, &asav[1], &lda, &x[1]
+, &lda, &work[1], &lda, &rwork[(*nrhs <<
+ 1) + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ sget07_(trans, &n, nrhs, &asav[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &c_true, &rwork[*nrhs + 1], &result[3]
+);
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from SGESVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___61.ciunit = *nout;
+ s_wsfe(&io___61);
+ do_fio(&c__1, "SGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___62.ciunit = *nout;
+ s_wsfe(&io___62);
+ do_fio(&c__1, "SGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L40: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___63.ciunit = *nout;
+ s_wsfe(&io___63);
+ do_fio(&c__1, "SGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___64.ciunit = *nout;
+ s_wsfe(&io___64);
+ do_fio(&c__1, "SGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___65.ciunit = *nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, "SGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___66.ciunit = *nout;
+ s_wsfe(&io___66);
+ do_fio(&c__1, "SGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___67.ciunit = *nout;
+ s_wsfe(&io___67);
+ do_fio(&c__1, "SGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___68.ciunit = *nout;
+ s_wsfe(&io___68);
+ do_fio(&c__1, "SGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+
+ }
+
+/* --- Test SGESVXX --- */
+
+/* Restore the matrices A and B. */
+
+ slacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
+ slacpy_("Full", &n, nrhs, &bsav[1], &lda, &b[1], &lda);
+ if (! prefac) {
+ slaset_("Full", &n, &n, &c_b20, &c_b20, &afac[1],
+ &lda);
+ }
+ slaset_("Full", &n, nrhs, &c_b20, &c_b20, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ slaqge_(&n, &n, &a[1], &lda, &s[1], &s[n + 1], &
+ rowcnd, &colcnd, &amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using SGESVXX. */
+
+ s_copy(srnamc_1.srnamt, "SGESVXX", (ftnlen)32, (
+ ftnlen)7);
+ n_err_bnds__ = 3;
+
+ salloc3();
+
+ sgesvxx_(fact, trans, &n, nrhs, &a[1], &lda, &afac[1],
+ &lda, &iwork[1], equed, &s[1], &s[n + 1], &b[
+ 1], &lda, &x[1], &lda, &rcond, &rpvgrw_svxx__,
+ berr, &n_err_bnds__, errbnds_n__,
+ errbnds_c__, &c__0, &c_b20, &work[1], &iwork[
+ n + 1], &info);
+
+ free3();
+
+/* Check the error code from SGESVXX. */
+
+ if (info == n + 1) {
+ goto L50;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "SGESVXX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L50;
+ }
+
+/* Compare rpvgrw_svxx from SGESVXX with the computed */
+/* reciprocal pivot growth factor RPVGRW */
+
+ if (info > 0 && info < n + 1) {
+ rpvgrw = sla_rpvgrw__(&n, &info, &a[1], &lda, &
+ afac[1], &lda);
+ } else {
+ rpvgrw = sla_rpvgrw__(&n, &n, &a[1], &lda, &afac[
+ 1], &lda);
+ }
+ result[6] = (r__1 = rpvgrw - rpvgrw_svxx__, dabs(r__1)
+ ) / dmax(rpvgrw_svxx__,rpvgrw) / slamch_(
+ "E");
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ sget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &rwork[(*nrhs << 1) + 1],
+ result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ slacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ sget02_(trans, &n, &n, nrhs, &asav[1], &lda, &x[1]
+, &lda, &work[1], &lda, &rwork[(*nrhs <<
+ 1) + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from SGESVXX with the computed value */
+/* in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___74.ciunit = *nout;
+ s_wsfe(&io___74);
+ do_fio(&c__1, "SGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___75.ciunit = *nout;
+ s_wsfe(&io___75);
+ do_fio(&c__1, "SGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L45: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___76.ciunit = *nout;
+ s_wsfe(&io___76);
+ do_fio(&c__1, "SGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___77.ciunit = *nout;
+ s_wsfe(&io___77);
+ do_fio(&c__1, "SGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___78.ciunit = *nout;
+ s_wsfe(&io___78);
+ do_fio(&c__1, "SGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___79.ciunit = *nout;
+ s_wsfe(&io___79);
+ do_fio(&c__1, "SGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___80.ciunit = *nout;
+ s_wsfe(&io___80);
+ do_fio(&c__1, "SGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ } else {
+ io___81.ciunit = *nout;
+ s_wsfe(&io___81);
+ do_fio(&c__1, "SGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+
+ }
+
+L50:
+ ;
+ }
+L60:
+ ;
+ }
+/* L70: */
+ }
+L80:
+ ;
+ }
+/* L90: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+/* Test Error Bounds from SGESVXX */
+ sebchvxx_(thresh, path);
+ return 0;
+
+/* End of SDRVGE */
+
+} /* sdrvge_ */
diff --git a/TESTING/LIN/sdrvgt.c b/TESTING/LIN/sdrvgt.c
new file mode 100644
index 0000000..9577b2f
--- /dev/null
+++ b/TESTING/LIN/sdrvgt.c
@@ -0,0 +1,698 @@
+/* sdrvgt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static real c_b43 = 1.f;
+static real c_b44 = 0.f;
+
+/* Subroutine */ int sdrvgt_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, real *a, real *af, real
+ *b, real *x, real *xact, real *work, real *rwork, integer *iwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 0,0,0,1 };
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
+ ", test \002,i2,\002, ratio = \002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
+ "1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002, "
+ "ratio = \002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ real r__1, r__2;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k, m, n;
+ real z__[3];
+ integer k1, in, kl, ku, ix, nt, lda;
+ char fact[1];
+ real cond;
+ integer mode, koff, imat, info;
+ char path[3], dist[1], type__[1];
+ integer nrun, ifact, nfail, iseed[4];
+ real rcond;
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *), sscal_(integer *, real *,
+ real *, integer *);
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ real anorm;
+ integer itran;
+ extern /* Subroutine */ int sgtt01_(integer *, real *, real *, real *,
+ real *, real *, real *, real *, integer *, real *, integer *,
+ real *, real *), sgtt02_(char *, integer *, integer *, real *,
+ real *, real *, real *, integer *, real *, integer *, real *,
+ real *), sgtt05_(char *, integer *, integer *, real *,
+ real *, real *, real *, integer *, real *, integer *, real *,
+ integer *, real *, real *, real *);
+ char trans[1];
+ integer izero, nerrs;
+ extern doublereal sasum_(integer *, real *, integer *);
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ logical zerot;
+ extern /* Subroutine */ int sgtsv_(integer *, integer *, real *, real *,
+ real *, real *, integer *, integer *), slatb4_(char *, integer *,
+ integer *, integer *, char *, integer *, integer *, real *,
+ integer *, real *, char *), aladhd_(
+ integer *, char *), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ real rcondc, rcondi;
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ real rcondo, anormi;
+ extern /* Subroutine */ int slagtm_(char *, integer *, integer *, real *,
+ real *, real *, real *, real *, integer *, real *, real *,
+ integer *);
+ real ainvnm;
+ extern doublereal slangt_(char *, integer *, real *, real *, real *);
+ logical trfcon;
+ real anormo;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *), slatms_(
+ integer *, integer *, char *, integer *, char *, real *, integer *
+, real *, real *, integer *, integer *, char *, real *, integer *,
+ real *, integer *), slarnv_(integer *,
+ integer *, integer *, real *), sgttrf_(integer *, real *, real *,
+ real *, real *, integer *, integer *);
+ real result[6];
+ extern /* Subroutine */ int sgttrs_(char *, integer *, integer *, real *,
+ real *, real *, real *, integer *, real *, integer *, integer *), serrvx_(char *, integer *), sgtsvx_(char *, char
+ *, integer *, integer *, real *, real *, real *, real *, real *,
+ real *, real *, integer *, real *, integer *, real *, integer *,
+ real *, real *, real *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVGT tests SGTSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) REAL array, dimension (NMAX*4) */
+
+/* AF (workspace) REAL array, dimension (NMAX*4) */
+
+/* B (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* X (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NRHS)) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --af;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "GT", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+/* Computing MAX */
+ i__2 = n - 1;
+ m = max(i__2,0);
+ lda = max(1,n);
+ nimat = 12;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L130;
+ }
+
+/* Set up parameters with SLATB4. */
+
+ slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cond, dist);
+
+ zerot = imat >= 8 && imat <= 10;
+ if (imat <= 6) {
+
+/* Types 1-6: generate matrices of known condition number. */
+
+/* Computing MAX */
+ i__3 = 2 - ku, i__4 = 3 - max(1,n);
+ koff = max(i__3,i__4);
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
+ slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
+ &anorm, &kl, &ku, "Z", &af[koff], &c__3, &work[1], &
+ info);
+
+/* Check the error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, " ", &n, &n, &kl, &
+ ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L130;
+ }
+ izero = 0;
+
+ if (n > 1) {
+ i__3 = n - 1;
+ scopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
+ i__3 = n - 1;
+ scopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
+ }
+ scopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
+ } else {
+
+/* Types 7-12: generate tridiagonal matrices with */
+/* unknown condition numbers. */
+
+ if (! zerot || ! dotype[7]) {
+
+/* Generate a matrix with elements from [-1,1]. */
+
+ i__3 = n + (m << 1);
+ slarnv_(&c__2, iseed, &i__3, &a[1]);
+ if (anorm != 1.f) {
+ i__3 = n + (m << 1);
+ sscal_(&i__3, &anorm, &a[1], &c__1);
+ }
+ } else if (izero > 0) {
+
+/* Reuse the last matrix by copying back the zeroed out */
+/* elements. */
+
+ if (izero == 1) {
+ a[n] = z__[1];
+ if (n > 1) {
+ a[1] = z__[2];
+ }
+ } else if (izero == n) {
+ a[n * 3 - 2] = z__[0];
+ a[(n << 1) - 1] = z__[1];
+ } else {
+ a[(n << 1) - 2 + izero] = z__[0];
+ a[n - 1 + izero] = z__[1];
+ a[izero] = z__[2];
+ }
+ }
+
+/* If IMAT > 7, set one column of the matrix to 0. */
+
+ if (! zerot) {
+ izero = 0;
+ } else if (imat == 8) {
+ izero = 1;
+ z__[1] = a[n];
+ a[n] = 0.f;
+ if (n > 1) {
+ z__[2] = a[1];
+ a[1] = 0.f;
+ }
+ } else if (imat == 9) {
+ izero = n;
+ z__[0] = a[n * 3 - 2];
+ z__[1] = a[(n << 1) - 1];
+ a[n * 3 - 2] = 0.f;
+ a[(n << 1) - 1] = 0.f;
+ } else {
+ izero = (n + 1) / 2;
+ i__3 = n - 1;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[(n << 1) - 2 + i__] = 0.f;
+ a[n - 1 + i__] = 0.f;
+ a[i__] = 0.f;
+/* L20: */
+ }
+ a[n * 3 - 2] = 0.f;
+ a[(n << 1) - 1] = 0.f;
+ }
+ }
+
+ for (ifact = 1; ifact <= 2; ++ifact) {
+ if (ifact == 1) {
+ *(unsigned char *)fact = 'F';
+ } else {
+ *(unsigned char *)fact = 'N';
+ }
+
+/* Compute the condition number for comparison with */
+/* the value returned by SGTSVX. */
+
+ if (zerot) {
+ if (ifact == 1) {
+ goto L120;
+ }
+ rcondo = 0.f;
+ rcondi = 0.f;
+
+ } else if (ifact == 1) {
+ i__3 = n + (m << 1);
+ scopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
+
+/* Compute the 1-norm and infinity-norm of A. */
+
+ anormo = slangt_("1", &n, &a[1], &a[m + 1], &a[n + m + 1]);
+ anormi = slangt_("I", &n, &a[1], &a[m + 1], &a[n + m + 1]);
+
+/* Factor the matrix A. */
+
+ sgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (
+ m << 1) + 1], &iwork[1], &info);
+
+/* Use SGTTRS to solve for one column at a time of */
+/* inv(A), computing the maximum column sum as we go. */
+
+ ainvnm = 0.f;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ x[j] = 0.f;
+/* L30: */
+ }
+ x[i__] = 1.f;
+ sgttrs_("No transpose", &n, &c__1, &af[1], &af[m + 1],
+ &af[n + m + 1], &af[n + (m << 1) + 1], &
+ iwork[1], &x[1], &lda, &info);
+/* Computing MAX */
+ r__1 = ainvnm, r__2 = sasum_(&n, &x[1], &c__1);
+ ainvnm = dmax(r__1,r__2);
+/* L40: */
+ }
+
+/* Compute the 1-norm condition number of A. */
+
+ if (anormo <= 0.f || ainvnm <= 0.f) {
+ rcondo = 1.f;
+ } else {
+ rcondo = 1.f / anormo / ainvnm;
+ }
+
+/* Use SGTTRS to solve for one column at a time of */
+/* inv(A'), computing the maximum column sum as we go. */
+
+ ainvnm = 0.f;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ x[j] = 0.f;
+/* L50: */
+ }
+ x[i__] = 1.f;
+ sgttrs_("Transpose", &n, &c__1, &af[1], &af[m + 1], &
+ af[n + m + 1], &af[n + (m << 1) + 1], &iwork[
+ 1], &x[1], &lda, &info);
+/* Computing MAX */
+ r__1 = ainvnm, r__2 = sasum_(&n, &x[1], &c__1);
+ ainvnm = dmax(r__1,r__2);
+/* L60: */
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ if (anormi <= 0.f || ainvnm <= 0.f) {
+ rcondi = 1.f;
+ } else {
+ rcondi = 1.f / anormi / ainvnm;
+ }
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+ *(unsigned char *)trans = *(unsigned char *)&transs[itran
+ - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Generate NRHS random solution vectors. */
+
+ ix = 1;
+ i__3 = *nrhs;
+ for (j = 1; j <= i__3; ++j) {
+ slarnv_(&c__2, iseed, &n, &xact[ix]);
+ ix += lda;
+/* L70: */
+ }
+
+/* Set the right hand side. */
+
+ slagtm_(trans, &n, nrhs, &c_b43, &a[1], &a[m + 1], &a[n +
+ m + 1], &xact[1], &lda, &c_b44, &b[1], &lda);
+
+ if (ifact == 2 && itran == 1) {
+
+/* --- Test SGTSV --- */
+
+/* Solve the system using Gaussian elimination with */
+/* partial pivoting. */
+
+ i__3 = n + (m << 1);
+ scopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "SGTSV ", (ftnlen)32, (ftnlen)
+ 6);
+ sgtsv_(&n, nrhs, &af[1], &af[m + 1], &af[n + m + 1], &
+ x[1], &lda, &info);
+
+/* Check error code from SGTSV . */
+
+ if (info != izero) {
+ alaerh_(path, "SGTSV ", &info, &izero, " ", &n, &
+ n, &c__1, &c__1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+ nt = 1;
+ if (izero == 0) {
+
+/* Check residual of computed solution. */
+
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
+ lda);
+ sgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n +
+ m + 1], &x[1], &lda, &work[1], &lda, &
+ rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 2; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "SGTSV ", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + nt - 1;
+ }
+
+/* --- Test SGTSVX --- */
+
+ if (ifact > 1) {
+
+/* Initialize AF to zero. */
+
+ i__3 = n * 3 - 2;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ af[i__] = 0.f;
+/* L90: */
+ }
+ }
+ slaset_("Full", &n, nrhs, &c_b44, &c_b44, &x[1], &lda);
+
+/* Solve the system and compute the condition number and */
+/* error bounds using SGTSVX. */
+
+ s_copy(srnamc_1.srnamt, "SGTSVX", (ftnlen)32, (ftnlen)6);
+ sgtsvx_(fact, trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m
+ + 1], &af[1], &af[m + 1], &af[n + m + 1], &af[n +
+ (m << 1) + 1], &iwork[1], &b[1], &lda, &x[1], &
+ lda, &rcond, &rwork[1], &rwork[*nrhs + 1], &work[
+ 1], &iwork[n + 1], &info);
+
+/* Check the error code from SGTSVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "SGTSVX", &info, &izero, ch__1, &n, &n,
+ &c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ if (ifact >= 2) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ sgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &
+ af[m + 1], &af[n + m + 1], &af[n + (m << 1) +
+ 1], &iwork[1], &work[1], &lda, &rwork[1],
+ result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Check residual of computed solution. */
+
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ sgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
+ 1], &x[1], &lda, &work[1], &lda, &rwork[1], &
+ result[1]);
+
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* Check the error bounds from iterative refinement. */
+
+ sgtt05_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
+ 1], &b[1], &lda, &x[1], &lda, &xact[1], &lda,
+ &rwork[1], &rwork[*nrhs + 1], &result[3]);
+ nt = 5;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = k1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___46.ciunit = *nout;
+ s_wsfe(&io___46);
+ do_fio(&c__1, "SGTSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L100: */
+ }
+
+/* Check the reciprocal of the condition number. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___47.ciunit = *nout;
+ s_wsfe(&io___47);
+ do_fio(&c__1, "SGTSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+ nrun = nrun + nt - k1 + 2;
+
+/* L110: */
+ }
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SDRVGT */
+
+} /* sdrvgt_ */
diff --git a/TESTING/LIN/sdrvls.c b/TESTING/LIN/sdrvls.c
new file mode 100644
index 0000000..49bd2b8
--- /dev/null
+++ b/TESTING/LIN/sdrvls.c
@@ -0,0 +1,850 @@
+/* sdrvls.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__9 = 9;
+static integer c__25 = 25;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static real c_b24 = 1.f;
+static real c_b25 = 0.f;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static real c_b92 = -1.f;
+
+/* Subroutine */ int sdrvls_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nns, integer *nsval, integer *
+ nnb, integer *nbval, integer *nxval, real *thresh, logical *tsterr,
+ real *a, real *copya, real *b, real *copyb, real *c__, real *s, real *
+ copys, real *work, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 TRANS='\002,a1,\002', M=\002,i5,\002, N"
+ "=\002,i5,\002, NRHS=\002,i4,\002, NB=\002,i4,\002, type\002,i2"
+ ",\002, test(\002,i2,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, NRHS="
+ "\002,i4,\002, NB=\002,i4,\002, type\002,i2,\002, test(\002,i2"
+ ",\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1, r__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal), log(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, m, n, nb, im, in, lda, ldb, inb;
+ real eps;
+ integer ins, info;
+ char path[3];
+ integer rank, nrhs, nlvl, nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4], crank, irank;
+ real rcond;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ sgemm_(char *, char *, integer *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ integer itran, mnmin, ncols;
+ real norma, normb;
+ extern /* Subroutine */ int sgels_(char *, integer *, integer *, integer *
+, real *, integer *, real *, integer *, real *, integer *,
+ integer *);
+ char trans[1];
+ integer nerrs, itype;
+ extern doublereal sasum_(integer *, real *, integer *);
+ integer lwork;
+ extern doublereal sqrt12_(integer *, integer *, real *, integer *, real *,
+ real *, integer *), sqrt14_(char *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+), sqrt17_(char *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, real *, integer *);
+ extern /* Subroutine */ int sqrt13_(integer *, integer *, integer *, real
+ *, integer *, real *, integer *), sqrt15_(integer *, integer *,
+ integer *, integer *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *), saxpy_(integer *, real *, real *, integer *, real *,
+ integer *), sqrt16_(char *, integer *, integer *, integer *, real
+ *, integer *, real *, integer *, real *, integer *, real *, real *
+);
+ integer nrows, lwlsy;
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ integer iscale;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int sgelsd_(integer *, integer *, integer *, real
+ *, integer *, real *, integer *, real *, real *, integer *, real *
+, integer *, integer *, integer *), alasvm_(char *, integer *,
+ integer *, integer *, integer *), slacpy_(char *, integer
+ *, integer *, real *, integer *, real *, integer *),
+ xlaenv_(integer *, integer *), sgelss_(integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, real *,
+ integer *, real *, integer *, integer *);
+ integer ldwork;
+ extern /* Subroutine */ int sgelsx_(integer *, integer *, integer *, real
+ *, integer *, real *, integer *, integer *, real *, integer *,
+ real *, integer *), sgelsy_(integer *, integer *, integer *, real
+ *, integer *, real *, integer *, integer *, real *, integer *,
+ real *, integer *, integer *), slarnv_(integer *, integer *,
+ integer *, real *), serrls_(char *, integer *);
+ real result[18];
+
+ /* Fortran I/O blocks */
+ static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVLS tests the least squares driver routines SGELS, SGELSS, SGELSX, */
+/* SGELSY and SGELSD. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+/* The matrix of type j is generated as follows: */
+/* j=1: A = U*D*V where U and V are random orthogonal matrices */
+/* and D has random entries (> 0.1) taken from a uniform */
+/* distribution (0,1). A is full rank. */
+/* j=2: The same of 1, but A is scaled up. */
+/* j=3: The same of 1, but A is scaled down. */
+/* j=4: A = U*D*V where U and V are random orthogonal matrices */
+/* and D has 3*min(M,N)/4 random entries (> 0.1) taken */
+/* from a uniform distribution (0,1) and the remaining */
+/* entries set to 0. A is rank-deficient. */
+/* j=5: The same of 4, but A is scaled up. */
+/* j=6: The same of 5, but A is scaled down. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) REAL array, dimension (MMAX*NMAX) */
+/* where MMAX is the maximum value of M in MVAL and NMAX is the */
+/* maximum value of N in NVAL. */
+
+/* COPYA (workspace) REAL array, dimension (MMAX*NMAX) */
+
+/* B (workspace) REAL array, dimension (MMAX*NSMAX) */
+/* where MMAX is the maximum value of M in MVAL and NSMAX is the */
+/* maximum value of NRHS in NSVAL. */
+
+/* COPYB (workspace) REAL array, dimension (MMAX*NSMAX) */
+
+/* C (workspace) REAL array, dimension (MMAX*NSMAX) */
+
+/* S (workspace) REAL array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* COPYS (workspace) REAL array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* WORK (workspace) REAL array, */
+/* dimension (MMAX*NMAX + 4*NMAX + MMAX). */
+
+/* IWORK (workspace) INTEGER array, dimension (15*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --work;
+ --copys;
+ --s;
+ --c__;
+ --copyb;
+ --b;
+ --copya;
+ --a;
+ --nxval;
+ --nbval;
+ --nsval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "LS", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = slamch_("Epsilon");
+
+/* Threshold for rank estimation */
+
+ rcond = sqrt(eps) - (sqrt(eps) - eps) / 2;
+
+/* Test the error exits */
+
+ xlaenv_(&c__2, &c__2);
+ xlaenv_(&c__9, &c__25);
+ if (*tsterr) {
+ serrls_(path, nout);
+ }
+
+/* Print the header if NM = 0 or NN = 0 and THRESH = 0. */
+
+ if ((*nm == 0 || *nn == 0) && *thresh == 0.f) {
+ alahd_(nout, path);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+ lda = max(1,m);
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__3 = max(1,m);
+ ldb = max(i__3,n);
+
+ i__3 = *nns;
+ for (ins = 1; ins <= i__3; ++ins) {
+ nrhs = nsval[ins];
+/* Computing MAX */
+/* Computing MAX */
+ r__1 = 1.f, r__2 = (real) mnmin;
+ i__4 = (integer) (log(dmax(r__1,r__2) / 26.f) / log(2.f)) + 1;
+ nlvl = max(i__4,0);
+/* Computing MAX */
+ i__4 = 1, i__5 = (m + nrhs) * (n + 2), i__4 = max(i__4,i__5),
+ i__5 = (n + nrhs) * (m + 2), i__4 = max(i__4,i__5),
+ i__5 = m * n + (mnmin << 2) + max(m,n), i__4 = max(
+ i__4,i__5), i__5 = mnmin * 12 + mnmin * 50 + (mnmin <<
+ 3) * nlvl + mnmin * nrhs + 676;
+ lwork = max(i__4,i__5);
+
+ for (irank = 1; irank <= 2; ++irank) {
+ for (iscale = 1; iscale <= 3; ++iscale) {
+ itype = (irank - 1) * 3 + iscale;
+ if (! dotype[itype]) {
+ goto L110;
+ }
+
+ if (irank == 1) {
+
+/* Test SGELS */
+
+/* Generate a matrix of scaling type ISCALE */
+
+ sqrt13_(&iscale, &m, &n, ©a[1], &lda, &norma,
+ iseed);
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__3, &nxval[inb]);
+
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ *(unsigned char *)trans = 'N';
+ nrows = m;
+ ncols = n;
+ } else {
+ *(unsigned char *)trans = 'T';
+ nrows = n;
+ ncols = m;
+ }
+ ldwork = max(1,ncols);
+
+/* Set up a consistent rhs */
+
+ if (ncols > 0) {
+ i__5 = ncols * nrhs;
+ slarnv_(&c__2, iseed, &i__5, &work[1])
+ ;
+ i__5 = ncols * nrhs;
+ r__1 = 1.f / (real) ncols;
+ sscal_(&i__5, &r__1, &work[1], &c__1);
+ }
+ sgemm_(trans, "No transpose", &nrows, &
+ nrhs, &ncols, &c_b24, ©a[1], &
+ lda, &work[1], &ldwork, &c_b25, &
+ b[1], &ldb)
+ ;
+ slacpy_("Full", &nrows, &nrhs, &b[1], &
+ ldb, ©b[1], &ldb);
+
+/* Solve LS or overdetermined system */
+
+ if (m > 0 && n > 0) {
+ slacpy_("Full", &m, &n, ©a[1], &
+ lda, &a[1], &lda);
+ slacpy_("Full", &nrows, &nrhs, ©b[
+ 1], &ldb, &b[1], &ldb);
+ }
+ s_copy(srnamc_1.srnamt, "SGELS ", (ftnlen)
+ 32, (ftnlen)6);
+ sgels_(trans, &m, &n, &nrhs, &a[1], &lda,
+ &b[1], &ldb, &work[1], &lwork, &
+ info);
+ if (info != 0) {
+ alaerh_(path, "SGELS ", &info, &c__0,
+ trans, &m, &n, &nrhs, &c_n1, &
+ nb, &itype, &nfail, &nerrs,
+ nout);
+ }
+
+/* Check correctness of results */
+
+ ldwork = max(1,nrows);
+ if (nrows > 0 && nrhs > 0) {
+ slacpy_("Full", &nrows, &nrhs, ©b[
+ 1], &ldb, &c__[1], &ldb);
+ }
+ sqrt16_(trans, &m, &n, &nrhs, ©a[1], &
+ lda, &b[1], &ldb, &c__[1], &ldb, &
+ work[1], result);
+
+ if (itran == 1 && m >= n || itran == 2 &&
+ m < n) {
+
+/* Solving LS system */
+
+ result[1] = sqrt17_(trans, &c__1, &m,
+ &n, &nrhs, ©a[1], &lda, &
+ b[1], &ldb, ©b[1], &ldb, &
+ c__[1], &work[1], &lwork);
+ } else {
+
+/* Solving overdetermined system */
+
+ result[1] = sqrt14_(trans, &m, &n, &
+ nrhs, ©a[1], &lda, &b[1],
+ &ldb, &work[1], &lwork);
+ }
+
+/* Print information about the tests that */
+/* did not pass the threshold. */
+
+ for (k = 1; k <= 2; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&nrhs, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nb, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&itype, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k -
+ 1], (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += 2;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+/* Generate a matrix of scaling type ISCALE and rank */
+/* type IRANK. */
+
+ sqrt15_(&iscale, &irank, &m, &n, &nrhs, ©a[1], &
+ lda, ©b[1], &ldb, ©s[1], &rank, &
+ norma, &normb, iseed, &work[1], &lwork);
+
+/* workspace used: MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M) */
+
+/* Initialize vector IWORK. */
+
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ iwork[j] = 0;
+/* L50: */
+ }
+ ldwork = max(1,m);
+
+/* Test SGELSX */
+
+/* SGELSX: Compute the minimum-norm solution X */
+/* to min( norm( A * X - B ) ) using a complete */
+/* orthogonal factorization. */
+
+ slacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &lda);
+ slacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1], &
+ ldb);
+
+ s_copy(srnamc_1.srnamt, "SGELSX", (ftnlen)32, (ftnlen)
+ 6);
+ sgelsx_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
+ iwork[1], &rcond, &crank, &work[1], &info);
+ if (info != 0) {
+ alaerh_(path, "SGELSX", &info, &c__0, " ", &m, &n,
+ &nrhs, &c_n1, &nb, &itype, &nfail, &
+ nerrs, nout);
+ }
+
+/* workspace used: MAX( MNMIN+3*N, 2*MNMIN+NRHS ) */
+
+/* Test 3: Compute relative error in svd */
+/* workspace: M*N + 4*MIN(M,N) + MAX(M,N) */
+
+ result[2] = sqrt12_(&crank, &crank, &a[1], &lda, &
+ copys[1], &work[1], &lwork);
+
+/* Test 4: Compute error in solution */
+/* workspace: M*NRHS + M */
+
+ slacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[1],
+ &ldwork);
+ sqrt16_("No transpose", &m, &n, &nrhs, ©a[1], &
+ lda, &b[1], &ldb, &work[1], &ldwork, &work[m *
+ nrhs + 1], &result[3]);
+
+/* Test 5: Check norm of r'*A */
+/* workspace: NRHS*(M+N) */
+
+ result[4] = 0.f;
+ if (m > crank) {
+ result[4] = sqrt17_("No transpose", &c__1, &m, &n,
+ &nrhs, ©a[1], &lda, &b[1], &ldb, &
+ copyb[1], &ldb, &c__[1], &work[1], &lwork);
+ }
+
+/* Test 6: Check if x is in the rowspace of A */
+/* workspace: (M+NRHS)*(N+2) */
+
+ result[5] = 0.f;
+
+ if (n > crank) {
+ result[5] = sqrt14_("No transpose", &m, &n, &nrhs,
+ ©a[1], &lda, &b[1], &ldb, &work[1], &
+ lwork);
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 3; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&itype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += 4;
+
+/* Loop for testing different block sizes. */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__3, &nxval[inb]);
+
+/* Test SGELSY */
+
+/* SGELSY: Compute the minimum-norm solution X */
+/* to min( norm( A * X - B ) ) */
+/* using the rank-revealing orthogonal */
+/* factorization. */
+
+/* Initialize vector IWORK. */
+
+ i__5 = n;
+ for (j = 1; j <= i__5; ++j) {
+ iwork[j] = 0;
+/* L70: */
+ }
+
+/* Set LWLSY to the adequate value. */
+
+/* Computing MAX */
+ i__5 = 1, i__6 = mnmin + (n << 1) + nb * (n + 1),
+ i__5 = max(i__5,i__6), i__6 = (mnmin << 1)
+ + nb * nrhs;
+ lwlsy = max(i__5,i__6);
+
+ slacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
+ lda);
+ slacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
+ &ldb);
+
+ s_copy(srnamc_1.srnamt, "SGELSY", (ftnlen)32, (
+ ftnlen)6);
+ sgelsy_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
+ iwork[1], &rcond, &crank, &work[1], &
+ lwlsy, &info);
+ if (info != 0) {
+ alaerh_(path, "SGELSY", &info, &c__0, " ", &m,
+ &n, &nrhs, &c_n1, &nb, &itype, &
+ nfail, &nerrs, nout);
+ }
+
+/* Test 7: Compute relative error in svd */
+/* workspace: M*N + 4*MIN(M,N) + MAX(M,N) */
+
+ result[6] = sqrt12_(&crank, &crank, &a[1], &lda, &
+ copys[1], &work[1], &lwork);
+
+/* Test 8: Compute error in solution */
+/* workspace: M*NRHS + M */
+
+ slacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
+ 1], &ldwork);
+ sqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
+ &lda, &b[1], &ldb, &work[1], &ldwork, &
+ work[m * nrhs + 1], &result[7]);
+
+/* Test 9: Check norm of r'*A */
+/* workspace: NRHS*(M+N) */
+
+ result[8] = 0.f;
+ if (m > crank) {
+ result[8] = sqrt17_("No transpose", &c__1, &m,
+ &n, &nrhs, ©a[1], &lda, &b[1], &
+ ldb, ©b[1], &ldb, &c__[1], &work[
+ 1], &lwork);
+ }
+
+/* Test 10: Check if x is in the rowspace of A */
+/* workspace: (M+NRHS)*(N+2) */
+
+ result[9] = 0.f;
+
+ if (n > crank) {
+ result[9] = sqrt14_("No transpose", &m, &n, &
+ nrhs, ©a[1], &lda, &b[1], &ldb, &
+ work[1], &lwork);
+ }
+
+/* Test SGELSS */
+
+/* SGELSS: Compute the minimum-norm solution X */
+/* to min( norm( A * X - B ) ) */
+/* using the SVD. */
+
+ slacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
+ lda);
+ slacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
+ &ldb);
+ s_copy(srnamc_1.srnamt, "SGELSS", (ftnlen)32, (
+ ftnlen)6);
+ sgelss_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
+ s[1], &rcond, &crank, &work[1], &lwork, &
+ info);
+ if (info != 0) {
+ alaerh_(path, "SGELSS", &info, &c__0, " ", &m,
+ &n, &nrhs, &c_n1, &nb, &itype, &
+ nfail, &nerrs, nout);
+ }
+
+/* workspace used: 3*min(m,n) + */
+/* max(2*min(m,n),nrhs,max(m,n)) */
+
+/* Test 11: Compute relative error in svd */
+
+ if (rank > 0) {
+ saxpy_(&mnmin, &c_b92, ©s[1], &c__1, &s[1]
+, &c__1);
+ result[10] = sasum_(&mnmin, &s[1], &c__1) /
+ sasum_(&mnmin, ©s[1], &c__1) / (
+ eps * (real) mnmin);
+ } else {
+ result[10] = 0.f;
+ }
+
+/* Test 12: Compute error in solution */
+
+ slacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
+ 1], &ldwork);
+ sqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
+ &lda, &b[1], &ldb, &work[1], &ldwork, &
+ work[m * nrhs + 1], &result[11]);
+
+/* Test 13: Check norm of r'*A */
+
+ result[12] = 0.f;
+ if (m > crank) {
+ result[12] = sqrt17_("No transpose", &c__1, &
+ m, &n, &nrhs, ©a[1], &lda, &b[1],
+ &ldb, ©b[1], &ldb, &c__[1], &work[
+ 1], &lwork);
+ }
+
+/* Test 14: Check if x is in the rowspace of A */
+
+ result[13] = 0.f;
+ if (n > crank) {
+ result[13] = sqrt14_("No transpose", &m, &n, &
+ nrhs, ©a[1], &lda, &b[1], &ldb, &
+ work[1], &lwork);
+ }
+
+/* Test SGELSD */
+
+/* SGELSD: Compute the minimum-norm solution X */
+/* to min( norm( A * X - B ) ) using a */
+/* divide and conquer SVD. */
+
+/* Initialize vector IWORK. */
+
+ i__5 = n;
+ for (j = 1; j <= i__5; ++j) {
+ iwork[j] = 0;
+/* L80: */
+ }
+
+ slacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
+ lda);
+ slacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
+ &ldb);
+
+ s_copy(srnamc_1.srnamt, "SGELSD", (ftnlen)32, (
+ ftnlen)6);
+ sgelsd_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
+ s[1], &rcond, &crank, &work[1], &lwork, &
+ iwork[1], &info);
+ if (info != 0) {
+ alaerh_(path, "SGELSD", &info, &c__0, " ", &m,
+ &n, &nrhs, &c_n1, &nb, &itype, &
+ nfail, &nerrs, nout);
+ }
+
+/* Test 15: Compute relative error in svd */
+
+ if (rank > 0) {
+ saxpy_(&mnmin, &c_b92, ©s[1], &c__1, &s[1]
+, &c__1);
+ result[14] = sasum_(&mnmin, &s[1], &c__1) /
+ sasum_(&mnmin, ©s[1], &c__1) / (
+ eps * (real) mnmin);
+ } else {
+ result[14] = 0.f;
+ }
+
+/* Test 16: Compute error in solution */
+
+ slacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
+ 1], &ldwork);
+ sqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
+ &lda, &b[1], &ldb, &work[1], &ldwork, &
+ work[m * nrhs + 1], &result[15]);
+
+/* Test 17: Check norm of r'*A */
+
+ result[16] = 0.f;
+ if (m > crank) {
+ result[16] = sqrt17_("No transpose", &c__1, &
+ m, &n, &nrhs, ©a[1], &lda, &b[1],
+ &ldb, ©b[1], &ldb, &c__[1], &work[
+ 1], &lwork);
+ }
+
+/* Test 18: Check if x is in the rowspace of A */
+
+ result[17] = 0.f;
+ if (n > crank) {
+ result[17] = sqrt14_("No transpose", &m, &n, &
+ nrhs, ©a[1], &lda, &b[1], &ldb, &
+ work[1], &lwork);
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 7; k <= 18; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&itype, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L90: */
+ }
+ nrun += 12;
+
+/* L100: */
+ }
+L110:
+ ;
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SDRVLS */
+
+} /* sdrvls_ */
diff --git a/TESTING/LIN/sdrvpb.c b/TESTING/LIN/sdrvpb.c
new file mode 100644
index 0000000..7a0367f
--- /dev/null
+++ b/TESTING/LIN/sdrvpb.c
@@ -0,0 +1,815 @@
+/* sdrvpb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static real c_b45 = 0.f;
+static real c_b46 = 1.f;
+
+/* Subroutine */ int sdrvpb_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, integer *nmax, real *a,
+ real *afac, real *asav, real *b, real *bsav, real *x, real *xact,
+ real *s, real *work, real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*2] = "N" "Y";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, KD =\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002',"
+ " \002,i5,\002, \002,i5,\002, ... ), EQUED='\002,a1,\002', type"
+ " \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002',"
+ " \002,i5,\002, \002,i5,\002, ... ), type \002,i1,\002, test(\002"
+ ",i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, k, n, i1, i2, k1, kd, nb, in, kl, iw, ku, nt, lda, ikd, nkd,
+ ldab;
+ char fact[1];
+ integer ioff, mode, koff;
+ real amax;
+ char path[3];
+ integer imat, info;
+ char dist[1], uplo[1], type__[1];
+ integer nrun, ifact, nfail, iseed[4], nfact, kdval[4];
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ real rcond, roldc, scond;
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *), spbt01_(char *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, real *);
+ real anorm;
+ extern /* Subroutine */ int spbt02_(char *, integer *, integer *, integer
+ *, real *, integer *, real *, integer *, real *, integer *, real *
+, real *), spbt05_(char *, integer *, integer *, integer *
+, real *, integer *, real *, integer *, real *, integer *, real *,
+ integer *, real *, real *, real *);
+ logical equil;
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), spbsv_(char *, integer *, integer *, integer *, real *
+, integer *, real *, integer *, integer *), sswap_(
+ integer *, real *, integer *, real *, integer *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), aladhd_(integer *, char *),
+ alaerh_(char *, char *, integer *, integer *, char *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *);
+ logical prefac;
+ real rcondc;
+ extern doublereal slange_(char *, integer *, integer *, real *, integer *,
+ real *);
+ logical nofact;
+ char packit[1];
+ integer iequed;
+ extern doublereal slansb_(char *, char *, integer *, integer *, real *,
+ integer *, real *);
+ real cndnum;
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *), slaqsb_(char *, integer *, integer *, real
+ *, integer *, real *, real *, real *, char *);
+ real ainvnm;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, integer *, integer *), slaset_(
+ char *, integer *, integer *, real *, real *, real *, integer *), spbequ_(char *, integer *, integer *, real *, integer *,
+ real *, real *, real *, integer *), spbtrf_(char *,
+ integer *, integer *, real *, integer *, integer *),
+ xlaenv_(integer *, integer *), slatms_(integer *, integer *, char
+ *, integer *, char *, real *, integer *, real *, real *, integer *
+, integer *, char *, real *, integer *, real *, integer *), spbtrs_(char *, integer *, integer *, integer *,
+ real *, integer *, real *, integer *, integer *);
+ real result[6];
+ extern /* Subroutine */ int spbsvx_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, char *, real *,
+ real *, integer *, real *, integer *, real *, real *, real *,
+ real *, integer *, integer *), serrvx_(
+ char *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVPB tests the driver routines SPBSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* B (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* X (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* S (workspace) REAL array, dimension (NMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "PB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+ kdval[0] = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+
+/* Set limits on the number of loop iterations. */
+
+/* Computing MAX */
+ i__2 = 1, i__3 = min(n,4);
+ nkd = max(i__2,i__3);
+ nimat = 8;
+ if (n == 0) {
+ nimat = 1;
+ }
+
+ kdval[1] = n + (n + 1) / 4;
+ kdval[2] = (n * 3 - 1) / 4;
+ kdval[3] = (n + 1) / 4;
+
+ i__2 = nkd;
+ for (ikd = 1; ikd <= i__2; ++ikd) {
+
+/* Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order */
+/* makes it easier to skip redundant values for small values */
+/* of N. */
+
+ kd = kdval[ikd - 1];
+ ldab = kd + 1;
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ koff = 1;
+ if (iuplo == 1) {
+ *(unsigned char *)uplo = 'U';
+ *(unsigned char *)packit = 'Q';
+/* Computing MAX */
+ i__3 = 1, i__4 = kd + 2 - n;
+ koff = max(i__3,i__4);
+ } else {
+ *(unsigned char *)uplo = 'L';
+ *(unsigned char *)packit = 'B';
+ }
+
+ i__3 = nimat;
+ for (imat = 1; imat <= i__3; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L80;
+ }
+
+/* Skip types 2, 3, or 4 if the matrix size is too small. */
+
+ zerot = imat >= 2 && imat <= 4;
+ if (zerot && n < imat - 1) {
+ goto L80;
+ }
+
+ if (! zerot || ! dotype[1]) {
+
+/* Set up parameters with SLATB4 and generate a test */
+/* matrix with SLATMS. */
+
+ slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm,
+ &mode, &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)
+ 6);
+ slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode,
+ &cndnum, &anorm, &kd, &kd, packit, &a[koff],
+ &ldab, &work[1], &info);
+
+/* Check error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ goto L80;
+ }
+ } else if (izero > 0) {
+
+/* Use the same matrix for types 3 and 4 as for type */
+/* 2 by copying back the zeroed out column, */
+
+ iw = (lda << 1) + 1;
+ if (iuplo == 1) {
+ ioff = (izero - 1) * ldab + kd + 1;
+ i__4 = izero - i1;
+ scopy_(&i__4, &work[iw], &c__1, &a[ioff - izero +
+ i1], &c__1);
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ scopy_(&i__4, &work[iw], &c__1, &a[ioff], &i__5);
+ } else {
+ ioff = (i1 - 1) * ldab + 1;
+ i__4 = izero - i1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ scopy_(&i__4, &work[iw], &c__1, &a[ioff + izero -
+ i1], &i__5);
+ ioff = (izero - 1) * ldab + 1;
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+ scopy_(&i__4, &work[iw], &c__1, &a[ioff], &c__1);
+ }
+ }
+
+/* For types 2-4, zero one row and column of the matrix */
+/* to test that INFO is returned correctly. */
+
+ izero = 0;
+ if (zerot) {
+ if (imat == 2) {
+ izero = 1;
+ } else if (imat == 3) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+/* Save the zeroed out row and column in WORK(*,3) */
+
+ iw = lda << 1;
+/* Computing MIN */
+ i__5 = (kd << 1) + 1;
+ i__4 = min(i__5,n);
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ work[iw + i__] = 0.f;
+/* L20: */
+ }
+ ++iw;
+/* Computing MAX */
+ i__4 = izero - kd;
+ i1 = max(i__4,1);
+/* Computing MIN */
+ i__4 = izero + kd;
+ i2 = min(i__4,n);
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * ldab + kd + 1;
+ i__4 = izero - i1;
+ sswap_(&i__4, &a[ioff - izero + i1], &c__1, &work[
+ iw], &c__1);
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ sswap_(&i__4, &a[ioff], &i__5, &work[iw], &c__1);
+ } else {
+ ioff = (i1 - 1) * ldab + 1;
+ i__4 = izero - i1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ sswap_(&i__4, &a[ioff + izero - i1], &i__5, &work[
+ iw], &c__1);
+ ioff = (izero - 1) * ldab + 1;
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+ sswap_(&i__4, &a[ioff], &c__1, &work[iw], &c__1);
+ }
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ i__4 = kd + 1;
+ slacpy_("Full", &i__4, &n, &a[1], &ldab, &asav[1], &ldab);
+
+ for (iequed = 1; iequed <= 2; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__4 = nfact;
+ for (ifact = 1; ifact <= i__4; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L60;
+ }
+ rcondc = 0.f;
+
+ } else if (! lsame_(fact, "N")) {
+
+/* Compute the condition number for comparison */
+/* with the value returned by SPBSVX (FACT = */
+/* 'N' reuses the condition number from the */
+/* previous iteration with FACT = 'F'). */
+
+ i__5 = kd + 1;
+ slacpy_("Full", &i__5, &n, &asav[1], &ldab, &
+ afac[1], &ldab);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ spbequ_(uplo, &n, &kd, &afac[1], &ldab, &
+ s[1], &scond, &amax, &info);
+ if (info == 0 && n > 0) {
+ if (iequed > 1) {
+ scond = 0.f;
+ }
+
+/* Equilibrate the matrix. */
+
+ slaqsb_(uplo, &n, &kd, &afac[1], &
+ ldab, &s[1], &scond, &amax,
+ equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in SGET04. */
+
+ if (equil) {
+ roldc = rcondc;
+ }
+
+/* Compute the 1-norm of A. */
+
+ anorm = slansb_("1", uplo, &n, &kd, &afac[1],
+ &ldab, &rwork[1]);
+
+/* Factor the matrix A. */
+
+ spbtrf_(uplo, &n, &kd, &afac[1], &ldab, &info);
+
+/* Form the inverse of A. */
+
+ slaset_("Full", &n, &n, &c_b45, &c_b46, &a[1],
+ &lda);
+ s_copy(srnamc_1.srnamt, "SPBTRS", (ftnlen)32,
+ (ftnlen)6);
+ spbtrs_(uplo, &n, &kd, &n, &afac[1], &ldab, &
+ a[1], &lda, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = slange_("1", &n, &n, &a[1], &lda, &
+ rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondc = 1.f;
+ } else {
+ rcondc = 1.f / anorm / ainvnm;
+ }
+ }
+
+/* Restore the matrix A. */
+
+ i__5 = kd + 1;
+ slacpy_("Full", &i__5, &n, &asav[1], &ldab, &a[1],
+ &ldab);
+
+/* Form an exact solution and set the right hand */
+/* side. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, (
+ ftnlen)6);
+ slarhs_(path, xtype, uplo, " ", &n, &n, &kd, &kd,
+ nrhs, &a[1], &ldab, &xact[1], &lda, &b[1],
+ &lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &
+ lda);
+
+ if (nofact) {
+
+/* --- Test SPBSV --- */
+
+/* Compute the L*L' or U'*U factorization of the */
+/* matrix and solve the system. */
+
+ i__5 = kd + 1;
+ slacpy_("Full", &i__5, &n, &a[1], &ldab, &
+ afac[1], &ldab);
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &x[1],
+ &lda);
+
+ s_copy(srnamc_1.srnamt, "SPBSV ", (ftnlen)32,
+ (ftnlen)6);
+ spbsv_(uplo, &n, &kd, nrhs, &afac[1], &ldab, &
+ x[1], &lda, &info);
+
+/* Check error code from SPBSV . */
+
+ if (info != izero) {
+ alaerh_(path, "SPBSV ", &info, &izero,
+ uplo, &n, &n, &kd, &kd, nrhs, &
+ imat, &nfail, &nerrs, nout);
+ goto L40;
+ } else if (info != 0) {
+ goto L40;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ spbt01_(uplo, &n, &kd, &a[1], &ldab, &afac[1],
+ &ldab, &rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &work[
+ 1], &lda);
+ spbt02_(uplo, &n, &kd, nrhs, &a[1], &ldab, &x[
+ 1], &lda, &work[1], &lda, &rwork[1], &
+ result[1]);
+
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ i__5 = nt;
+ for (k = 1; k <= i__5; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___57.ciunit = *nout;
+ s_wsfe(&io___57);
+ do_fio(&c__1, "SPBSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L30: */
+ }
+ nrun += nt;
+L40:
+ ;
+ }
+
+/* --- Test SPBSVX --- */
+
+ if (! prefac) {
+ i__5 = kd + 1;
+ slaset_("Full", &i__5, &n, &c_b45, &c_b45, &
+ afac[1], &ldab);
+ }
+ slaset_("Full", &n, nrhs, &c_b45, &c_b45, &x[1], &
+ lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT='F' and */
+/* EQUED='Y' */
+
+ slaqsb_(uplo, &n, &kd, &a[1], &ldab, &s[1], &
+ scond, &amax, equed);
+ }
+
+/* Solve the system and compute the condition */
+/* number and error bounds using SPBSVX. */
+
+ s_copy(srnamc_1.srnamt, "SPBSVX", (ftnlen)32, (
+ ftnlen)6);
+ spbsvx_(fact, uplo, &n, &kd, nrhs, &a[1], &ldab, &
+ afac[1], &ldab, equed, &s[1], &b[1], &lda,
+ &x[1], &lda, &rcond, &rwork[1], &rwork[*
+ nrhs + 1], &work[1], &iwork[1], &info);
+
+/* Check the error code from SPBSVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__7[0] = 1, a__1[0] = fact;
+ i__7[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__7, &c__2, (ftnlen)2);
+ alaerh_(path, "SPBSVX", &info, &izero, ch__1,
+ &n, &n, &kd, &kd, nrhs, &imat, &nfail,
+ &nerrs, nout);
+ goto L60;
+ }
+
+ if (info == 0) {
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and */
+/* compute residual. */
+
+ spbt01_(uplo, &n, &kd, &a[1], &ldab, &
+ afac[1], &ldab, &rwork[(*nrhs <<
+ 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ slacpy_("Full", &n, nrhs, &bsav[1], &lda, &
+ work[1], &lda);
+ spbt02_(uplo, &n, &kd, nrhs, &asav[1], &ldab,
+ &x[1], &lda, &work[1], &lda, &rwork[(*
+ nrhs << 1) + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &
+ lda, &rcondc, &result[2]);
+ } else {
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &
+ lda, &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ spbt05_(uplo, &n, &kd, nrhs, &asav[1], &ldab,
+ &b[1], &lda, &x[1], &lda, &xact[1], &
+ lda, &rwork[1], &rwork[*nrhs + 1], &
+ result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from SPBSVX with the computed */
+/* value in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___60.ciunit = *nout;
+ s_wsfe(&io___60);
+ do_fio(&c__1, "SPBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___61.ciunit = *nout;
+ s_wsfe(&io___61);
+ do_fio(&c__1, "SPBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L50: */
+ }
+ nrun = nrun + 7 - k1;
+L60:
+ ;
+ }
+/* L70: */
+ }
+L80:
+ ;
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SDRVPB */
+
+} /* sdrvpb_ */
diff --git a/TESTING/LIN/sdrvpo.c b/TESTING/LIN/sdrvpo.c
new file mode 100644
index 0000000..34f7fe2
--- /dev/null
+++ b/TESTING/LIN/sdrvpo.c
@@ -0,0 +1,707 @@
+/* sdrvpo.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static real c_b50 = 0.f;
+
+/* Subroutine */ int sdrvpo_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, integer *nmax, real *a,
+ real *afac, real *asav, real *b, real *bsav, real *x, real *xact,
+ real *s, real *work, real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*2] = "N" "Y";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,"
+ "\002, test(\002,i1,\002) =\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, k, n, k1, nb, in, kl, ku, nt, lda;
+ char fact[1];
+ integer ioff, mode;
+ real amax;
+ char path[3];
+ integer imat, info;
+ char dist[1], uplo[1], type__[1];
+ integer nrun, ifact, nfail, iseed[4], nfact;
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ real rcond, roldc, scond;
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *);
+ real anorm;
+ logical equil;
+ extern /* Subroutine */ int spot01_(char *, integer *, real *, integer *,
+ real *, integer *, real *, real *), spot02_(char *,
+ integer *, integer *, real *, integer *, real *, integer *, real *
+, integer *, real *, real *);
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int spot05_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, real *, real *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int sposv_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, integer *), slatb4_(char *,
+ integer *, integer *, integer *, char *, integer *, integer *,
+ real *, integer *, real *, char *),
+ aladhd_(integer *, char *), alaerh_(char *, char *,
+ integer *, integer *, char *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *);
+ logical prefac;
+ real rcondc;
+ logical nofact;
+ integer iequed;
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ real cndnum, ainvnm;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, integer *, integer *), slaset_(
+ char *, integer *, integer *, real *, real *, real *, integer *), xlaenv_(integer *, integer *), slatms_(integer *,
+ integer *, char *, integer *, char *, real *, integer *, real *,
+ real *, integer *, integer *, char *, real *, integer *, real *,
+ integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+ extern /* Subroutine */ int slaqsy_(char *, integer *, real *, integer *,
+ real *, real *, real *, char *);
+ real result[6];
+ extern /* Subroutine */ int spoequ_(integer *, real *, integer *, real *,
+ real *, real *, integer *), spotrf_(char *, integer *, real *,
+ integer *, integer *), spotri_(char *, integer *, real *,
+ integer *, integer *), serrvx_(char *, integer *),
+ sposvx_(char *, char *, integer *, integer *, real *, integer *,
+ real *, integer *, char *, real *, real *, integer *, real *,
+ integer *, real *, real *, real *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVPO tests the driver routines SPOSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* B (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* X (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* S (workspace) REAL array, dimension (NMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "PO", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot && n < imat - 2) {
+ goto L120;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Set up parameters with SLATB4 and generate a test matrix */
+/* with SLATMS. */
+
+ slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
+ slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
+ &info);
+
+/* Check error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L110;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff] = 0.f;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff] = 0.f;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ slacpy_(uplo, &n, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 2; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__3 = nfact;
+ for (ifact = 1; ifact <= i__3; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L90;
+ }
+ rcondc = 0.f;
+
+ } else if (! lsame_(fact, "N"))
+ {
+
+/* Compute the condition number for comparison with */
+/* the value returned by SPOSVX (FACT = 'N' reuses */
+/* the condition number from the previous iteration */
+/* with FACT = 'F'). */
+
+ slacpy_(uplo, &n, &n, &asav[1], &lda, &afac[1], &
+ lda);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ spoequ_(&n, &afac[1], &lda, &s[1], &scond, &
+ amax, &info);
+ if (info == 0 && n > 0) {
+ if (iequed > 1) {
+ scond = 0.f;
+ }
+
+/* Equilibrate the matrix. */
+
+ slaqsy_(uplo, &n, &afac[1], &lda, &s[1], &
+ scond, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in SGET04. */
+
+ if (equil) {
+ roldc = rcondc;
+ }
+
+/* Compute the 1-norm of A. */
+
+ anorm = slansy_("1", uplo, &n, &afac[1], &lda, &
+ rwork[1]);
+
+/* Factor the matrix A. */
+
+ spotrf_(uplo, &n, &afac[1], &lda, &info);
+
+/* Form the inverse of A. */
+
+ slacpy_(uplo, &n, &n, &afac[1], &lda, &a[1], &lda);
+ spotri_(uplo, &n, &a[1], &lda, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = slansy_("1", uplo, &n, &a[1], &lda, &
+ rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondc = 1.f;
+ } else {
+ rcondc = 1.f / anorm / ainvnm;
+ }
+ }
+
+/* Restore the matrix A. */
+
+ slacpy_(uplo, &n, &n, &asav[1], &lda, &a[1], &lda);
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ slarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku,
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
+
+ if (nofact) {
+
+/* --- Test SPOSV --- */
+
+/* Compute the L*L' or U'*U factorization of the */
+/* matrix and solve the system. */
+
+ slacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "SPOSV ", (ftnlen)32, (
+ ftnlen)6);
+ sposv_(uplo, &n, nrhs, &afac[1], &lda, &x[1], &
+ lda, &info);
+
+/* Check error code from SPOSV . */
+
+ if (info != izero) {
+ alaerh_(path, "SPOSV ", &info, &izero, uplo, &
+ n, &n, &c_n1, &c_n1, nrhs, &imat, &
+ nfail, &nerrs, nout);
+ goto L70;
+ } else if (info != 0) {
+ goto L70;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ spot01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
+ rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
+ lda);
+ spot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda,
+ &work[1], &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___48.ciunit = *nout;
+ s_wsfe(&io___48);
+ do_fio(&c__1, "SPOSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += nt;
+L70:
+ ;
+ }
+
+/* --- Test SPOSVX --- */
+
+ if (! prefac) {
+ slaset_(uplo, &n, &n, &c_b50, &c_b50, &afac[1], &
+ lda);
+ }
+ slaset_("Full", &n, nrhs, &c_b50, &c_b50, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT='F' and */
+/* EQUED='Y'. */
+
+ slaqsy_(uplo, &n, &a[1], &lda, &s[1], &scond, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using SPOSVX. */
+
+ s_copy(srnamc_1.srnamt, "SPOSVX", (ftnlen)32, (ftnlen)
+ 6);
+ sposvx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1], &
+ lda, equed, &s[1], &b[1], &lda, &x[1], &lda, &
+ rcond, &rwork[1], &rwork[*nrhs + 1], &work[1],
+ &iwork[1], &info);
+
+/* Check the error code from SPOSVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "SPOSVX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L90;
+ }
+
+ if (info == 0) {
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ spot01_(uplo, &n, &a[1], &lda, &afac[1], &lda,
+ &rwork[(*nrhs << 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ slacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ spot02_(uplo, &n, nrhs, &asav[1], &lda, &x[1], &
+ lda, &work[1], &lda, &rwork[(*nrhs << 1)
+ + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ spot05_(uplo, &n, nrhs, &asav[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &rwork[*nrhs + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from SPOSVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___51.ciunit = *nout;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "SPOSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___52.ciunit = *nout;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "SPOSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + 7 - k1;
+L90:
+ ;
+ }
+/* L100: */
+ }
+L110:
+ ;
+ }
+L120:
+ ;
+ }
+/* L130: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SDRVPO */
+
+} /* sdrvpo_ */
diff --git a/TESTING/LIN/sdrvpox.c b/TESTING/LIN/sdrvpox.c
new file mode 100644
index 0000000..741392f
--- /dev/null
+++ b/TESTING/LIN/sdrvpox.c
@@ -0,0 +1,871 @@
+/* sdrvpox.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "memory_alloc.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static real c_b50 = 0.f;
+
+/* Subroutine */ int sdrvpo_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, integer *nmax, real *a,
+ real *afac, real *asav, real *b, real *bsav, real *x, real *xact,
+ real *s, real *work, real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*2] = "N" "Y";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,"
+ "\002, test(\002,i1,\002) =\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ extern /* Subroutine */ int sposvxx_(char *, char *, integer *, integer *,
+ real *, integer *, real *, integer *, char *, real *, real *,
+ integer *, real *, integer *, real *, real *, real *, integer *,
+ real *, real *, integer *, real *, real *, integer *, integer *), sebchvxx_(real *, char *);
+ integer i__, k, n;
+ real *errbnds_c__, *errbnds_n__;
+ integer k1, nb, in, kl, ku, nt, n_err_bnds__, lda;
+ char fact[1];
+ integer ioff, mode;
+ real amax;
+ char path[3];
+ integer imat, info;
+ real *berr;
+ char dist[1];
+ real rpvgrw_svxx__;
+ char uplo[1], type__[1];
+ integer nrun, ifact, nfail, iseed[4], nfact;
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ real rcond, roldc, scond;
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *);
+ real anorm;
+ logical equil;
+ extern /* Subroutine */ int spot01_(char *, integer *, real *, integer *,
+ real *, integer *, real *, real *), spot02_(char *,
+ integer *, integer *, real *, integer *, real *, integer *, real *
+, integer *, real *, real *);
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int spot05_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, real *, real *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int sposv_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, integer *), slatb4_(char *,
+ integer *, integer *, integer *, char *, integer *, integer *,
+ real *, integer *, real *, char *),
+ aladhd_(integer *, char *), alaerh_(char *, char *,
+ integer *, integer *, char *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *);
+ logical prefac;
+ real rcondc;
+ logical nofact;
+ integer iequed;
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ real cndnum, ainvnm;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, integer *, integer *), slaset_(
+ char *, integer *, integer *, real *, real *, real *, integer *), xlaenv_(integer *, integer *), slatms_(integer *,
+ integer *, char *, integer *, char *, real *, integer *, real *,
+ real *, integer *, integer *, char *, real *, integer *, real *,
+ integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+ extern /* Subroutine */ int slaqsy_(char *, integer *, real *, integer *,
+ real *, real *, real *, char *);
+ real result[6];
+ extern /* Subroutine */ int spoequ_(integer *, real *, integer *, real *,
+ real *, real *, integer *), spotrf_(char *, integer *, real *,
+ integer *, integer *), spotri_(char *, integer *, real *,
+ integer *, integer *), serrvx_(char *, integer *),
+ sposvx_(char *, char *, integer *, integer *, real *, integer *,
+ real *, integer *, char *, real *, real *, integer *, real *,
+ integer *, real *, real *, real *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVPO tests the driver routines SPOSV, -SVX, and -SVXX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* B (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* X (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* S (workspace) REAL array, dimension (NMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "PO", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot && n < imat - 2) {
+ goto L120;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Set up parameters with SLATB4 and generate a test matrix */
+/* with SLATMS. */
+
+ slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
+ slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
+ &info);
+
+/* Check error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L110;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff] = 0.f;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff] = 0.f;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ slacpy_(uplo, &n, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 2; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__3 = nfact;
+ for (ifact = 1; ifact <= i__3; ++ifact) {
+ for (i__ = 1; i__ <= 6; ++i__) {
+ result[i__ - 1] = 0.f;
+ }
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L90;
+ }
+ rcondc = 0.f;
+
+ } else if (! lsame_(fact, "N"))
+ {
+
+/* Compute the condition number for comparison with */
+/* the value returned by SPOSVX (FACT = 'N' reuses */
+/* the condition number from the previous iteration */
+/* with FACT = 'F'). */
+
+ slacpy_(uplo, &n, &n, &asav[1], &lda, &afac[1], &
+ lda);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ spoequ_(&n, &afac[1], &lda, &s[1], &scond, &
+ amax, &info);
+ if (info == 0 && n > 0) {
+ if (iequed > 1) {
+ scond = 0.f;
+ }
+
+/* Equilibrate the matrix. */
+
+ slaqsy_(uplo, &n, &afac[1], &lda, &s[1], &
+ scond, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in SGET04. */
+
+ if (equil) {
+ roldc = rcondc;
+ }
+
+/* Compute the 1-norm of A. */
+
+ anorm = slansy_("1", uplo, &n, &afac[1], &lda, &
+ rwork[1]);
+
+/* Factor the matrix A. */
+
+ spotrf_(uplo, &n, &afac[1], &lda, &info);
+
+/* Form the inverse of A. */
+
+ slacpy_(uplo, &n, &n, &afac[1], &lda, &a[1], &lda);
+ spotri_(uplo, &n, &a[1], &lda, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = slansy_("1", uplo, &n, &a[1], &lda, &
+ rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondc = 1.f;
+ } else {
+ rcondc = 1.f / anorm / ainvnm;
+ }
+ }
+
+/* Restore the matrix A. */
+
+ slacpy_(uplo, &n, &n, &asav[1], &lda, &a[1], &lda);
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ slarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku,
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
+
+ if (nofact) {
+
+/* --- Test SPOSV --- */
+
+/* Compute the L*L' or U'*U factorization of the */
+/* matrix and solve the system. */
+
+ slacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "SPOSV ", (ftnlen)32, (
+ ftnlen)6);
+ sposv_(uplo, &n, nrhs, &afac[1], &lda, &x[1], &
+ lda, &info);
+
+/* Check error code from SPOSV . */
+
+ if (info != izero) {
+ alaerh_(path, "SPOSV ", &info, &izero, uplo, &
+ n, &n, &c_n1, &c_n1, nrhs, &imat, &
+ nfail, &nerrs, nout);
+ goto L70;
+ } else if (info != 0) {
+ goto L70;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ spot01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
+ rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
+ lda);
+ spot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda,
+ &work[1], &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___48.ciunit = *nout;
+ s_wsfe(&io___48);
+ do_fio(&c__1, "SPOSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += nt;
+L70:
+ ;
+ }
+
+/* --- Test SPOSVX --- */
+
+ if (! prefac) {
+ slaset_(uplo, &n, &n, &c_b50, &c_b50, &afac[1], &
+ lda);
+ }
+ slaset_("Full", &n, nrhs, &c_b50, &c_b50, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT='F' and */
+/* EQUED='Y'. */
+
+ slaqsy_(uplo, &n, &a[1], &lda, &s[1], &scond, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using SPOSVX. */
+
+ s_copy(srnamc_1.srnamt, "SPOSVX", (ftnlen)32, (ftnlen)
+ 6);
+ sposvx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1], &
+ lda, equed, &s[1], &b[1], &lda, &x[1], &lda, &
+ rcond, &rwork[1], &rwork[*nrhs + 1], &work[1],
+ &iwork[1], &info);
+
+/* Check the error code from SPOSVX. */
+
+ if (info == n + 1) {
+ goto L90;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "SPOSVX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L90;
+ }
+
+ if (info == 0) {
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ spot01_(uplo, &n, &a[1], &lda, &afac[1], &lda,
+ &rwork[(*nrhs << 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ slacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ spot02_(uplo, &n, nrhs, &asav[1], &lda, &x[1], &
+ lda, &work[1], &lda, &rwork[(*nrhs << 1)
+ + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ spot05_(uplo, &n, nrhs, &asav[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &rwork[*nrhs + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from SPOSVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___51.ciunit = *nout;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "SPOSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___52.ciunit = *nout;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "SPOSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + 7 - k1;
+
+/* --- Test SPOSVXX --- */
+
+/* Restore the matrices A and B. */
+
+ slacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
+ slacpy_("Full", &n, nrhs, &bsav[1], &lda, &b[1], &lda);
+ if (! prefac) {
+ slaset_(uplo, &n, &n, &c_b50, &c_b50, &afac[1], &
+ lda);
+ }
+ slaset_("Full", &n, nrhs, &c_b50, &c_b50, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT='F' and */
+/* EQUED='Y'. */
+
+ slaqsy_(uplo, &n, &a[1], &lda, &s[1], &scond, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using SPOSVXX. */
+
+ s_copy(srnamc_1.srnamt, "SPOSVXX", (ftnlen)32, (
+ ftnlen)7);
+ n_err_bnds__ = 3;
+
+ salloc3();
+
+ sposvxx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1],
+ &lda, equed, &s[1], &b[1], &lda, &x[1], &lda,
+ &rcond, &rpvgrw_svxx__, berr, &n_err_bnds__,
+ errbnds_n__, errbnds_c__, &c__0, &c_b50, &
+ work[1], &iwork[1], &info);
+
+ free3();
+
+/* Check the error code from SPOSVXX. */
+
+ if (info == n + 1) {
+ goto L90;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "SPOSVXX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L90;
+ }
+
+ if (info == 0) {
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ spot01_(uplo, &n, &a[1], &lda, &afac[1], &lda,
+ &rwork[(*nrhs << 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ slacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ spot02_(uplo, &n, nrhs, &asav[1], &lda, &x[1], &
+ lda, &work[1], &lda, &rwork[(*nrhs << 1)
+ + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ spot05_(uplo, &n, nrhs, &asav[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &rwork[*nrhs + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from SPOSVXX with the computed value */
+/* in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___58.ciunit = *nout;
+ s_wsfe(&io___58);
+ do_fio(&c__1, "SPOSVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___59.ciunit = *nout;
+ s_wsfe(&io___59);
+ do_fio(&c__1, "SPOSVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L85: */
+ }
+ nrun = nrun + 7 - k1;
+L90:
+ ;
+ }
+/* L100: */
+ }
+L110:
+ ;
+ }
+L120:
+ ;
+ }
+/* L130: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+/* Test Error Bounds from SPOSVXX */
+ sebchvxx_(thresh, path);
+ return 0;
+
+/* End of SDRVPO */
+
+} /* sdrvpo_ */
diff --git a/TESTING/LIN/sdrvpp.c b/TESTING/LIN/sdrvpp.c
new file mode 100644
index 0000000..fcfd617
--- /dev/null
+++ b/TESTING/LIN/sdrvpp.c
@@ -0,0 +1,705 @@
+/* sdrvpp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static real c_b60 = 0.f;
+static integer c__2 = 2;
+
+/* Subroutine */ int sdrvpp_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, integer *nmax, real *a,
+ real *afac, real *asav, real *b, real *bsav, real *x, real *xact,
+ real *s, real *work, real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char facts[1*3] = "F" "N" "E";
+ static char packs[1*2] = "C" "R";
+ static char equeds[1*2] = "N" "Y";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,"
+ "\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, k, n, k1, in, kl, ku, nt, lda, npp;
+ char fact[1];
+ integer ioff, mode;
+ real amax;
+ char path[3];
+ integer imat, info;
+ char dist[1], uplo[1], type__[1];
+ integer nrun, ifact, nfail, iseed[4], nfact;
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ real roldc, rcond, scond;
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *);
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ real anorm;
+ logical equil;
+ extern /* Subroutine */ int sppt01_(char *, integer *, real *, real *,
+ real *, real *);
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int sppt02_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *),
+ scopy_(integer *, real *, integer *, real *, integer *), sppt05_(
+ char *, integer *, integer *, real *, real *, integer *, real *,
+ integer *, real *, integer *, real *, real *, real *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int sppsv_(char *, integer *, integer *, real *,
+ real *, integer *, integer *), slatb4_(char *, integer *,
+ integer *, integer *, char *, integer *, integer *, real *,
+ integer *, real *, char *), aladhd_(
+ integer *, char *), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ logical prefac;
+ real rcondc;
+ logical nofact;
+ char packit[1];
+ integer iequed;
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ real cndnum, ainvnm;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, integer *, integer *), slaset_(
+ char *, integer *, integer *, real *, real *, real *, integer *);
+ extern doublereal slansp_(char *, char *, integer *, real *, real *);
+ extern /* Subroutine */ int slaqsp_(char *, integer *, real *, real *,
+ real *, real *, char *), slatms_(integer *,
+ integer *, char *, integer *, char *, real *, integer *, real *,
+ real *, integer *, integer *, char *, real *, integer *, real *,
+ integer *), sppequ_(char *, integer *,
+ real *, real *, real *, real *, integer *);
+ real result[6];
+ extern /* Subroutine */ int spptrf_(char *, integer *, real *, integer *), spptri_(char *, integer *, real *, integer *),
+ serrvx_(char *, integer *), sppsvx_(char *, char *,
+ integer *, integer *, real *, real *, char *, real *, real *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVPP tests the driver routines SPPSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) REAL array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AFAC (workspace) REAL array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* ASAV (workspace) REAL array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* X (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* S (workspace) REAL array, dimension (NMAX) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "PP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ npp = n * (n + 1) / 2;
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L130;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot && n < imat - 2) {
+ goto L130;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ *(unsigned char *)packit = *(unsigned char *)&packs[iuplo - 1]
+ ;
+
+/* Set up parameters with SLATB4 and generate a test matrix */
+/* with SLATMS. */
+
+ slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+ rcondc = 1.f / cndnum;
+
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
+ slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
+ 1], &info);
+
+/* Check error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L120;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * izero / 2;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff] = 0.f;
+ ioff += i__;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff] = 0.f;
+ ioff = ioff + n - i__;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ scopy_(&npp, &a[1], &c__1, &asav[1], &c__1);
+
+ for (iequed = 1; iequed <= 2; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__3 = nfact;
+ for (ifact = 1; ifact <= i__3; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L100;
+ }
+ rcondc = 0.f;
+
+ } else if (! lsame_(fact, "N"))
+ {
+
+/* Compute the condition number for comparison with */
+/* the value returned by SPPSVX (FACT = 'N' reuses */
+/* the condition number from the previous iteration */
+/* with FACT = 'F'). */
+
+ scopy_(&npp, &asav[1], &c__1, &afac[1], &c__1);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ sppequ_(uplo, &n, &afac[1], &s[1], &scond, &
+ amax, &info);
+ if (info == 0 && n > 0) {
+ if (iequed > 1) {
+ scond = 0.f;
+ }
+
+/* Equilibrate the matrix. */
+
+ slaqsp_(uplo, &n, &afac[1], &s[1], &scond,
+ &amax, equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in SGET04. */
+
+ if (equil) {
+ roldc = rcondc;
+ }
+
+/* Compute the 1-norm of A. */
+
+ anorm = slansp_("1", uplo, &n, &afac[1], &rwork[1]
+);
+
+/* Factor the matrix A. */
+
+ spptrf_(uplo, &n, &afac[1], &info);
+
+/* Form the inverse of A. */
+
+ scopy_(&npp, &afac[1], &c__1, &a[1], &c__1);
+ spptri_(uplo, &n, &a[1], &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = slansp_("1", uplo, &n, &a[1], &rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondc = 1.f;
+ } else {
+ rcondc = 1.f / anorm / ainvnm;
+ }
+ }
+
+/* Restore the matrix A. */
+
+ scopy_(&npp, &asav[1], &c__1, &a[1], &c__1);
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ slarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku,
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
+
+ if (nofact) {
+
+/* --- Test SPPSV --- */
+
+/* Compute the L*L' or U'*U factorization of the */
+/* matrix and solve the system. */
+
+ scopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "SPPSV ", (ftnlen)32, (
+ ftnlen)6);
+ sppsv_(uplo, &n, nrhs, &afac[1], &x[1], &lda, &
+ info);
+
+/* Check error code from SPPSV . */
+
+ if (info != izero) {
+ alaerh_(path, "SPPSV ", &info, &izero, uplo, &
+ n, &n, &c_n1, &c_n1, nrhs, &imat, &
+ nfail, &nerrs, nout);
+ goto L70;
+ } else if (info != 0) {
+ goto L70;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ sppt01_(uplo, &n, &a[1], &afac[1], &rwork[1],
+ result);
+
+/* Compute residual of the computed solution. */
+
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
+ lda);
+ sppt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[
+ 1], &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___49.ciunit = *nout;
+ s_wsfe(&io___49);
+ do_fio(&c__1, "SPPSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += nt;
+L70:
+ ;
+ }
+
+/* --- Test SPPSVX --- */
+
+ if (! prefac && npp > 0) {
+ slaset_("Full", &npp, &c__1, &c_b60, &c_b60, &
+ afac[1], &npp);
+ }
+ slaset_("Full", &n, nrhs, &c_b60, &c_b60, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT='F' and */
+/* EQUED='Y'. */
+
+ slaqsp_(uplo, &n, &a[1], &s[1], &scond, &amax,
+ equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using SPPSVX. */
+
+ s_copy(srnamc_1.srnamt, "SPPSVX", (ftnlen)32, (ftnlen)
+ 6);
+ sppsvx_(fact, uplo, &n, nrhs, &a[1], &afac[1], equed,
+ &s[1], &b[1], &lda, &x[1], &lda, &rcond, &
+ rwork[1], &rwork[*nrhs + 1], &work[1], &iwork[
+ 1], &info);
+
+/* Check the error code from SPPSVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "SPPSVX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L90;
+ }
+
+ if (info == 0) {
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ sppt01_(uplo, &n, &a[1], &afac[1], &rwork[(*
+ nrhs << 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ slacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ sppt02_(uplo, &n, nrhs, &asav[1], &x[1], &lda, &
+ work[1], &lda, &rwork[(*nrhs << 1) + 1], &
+ result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ sppt05_(uplo, &n, nrhs, &asav[1], &b[1], &lda, &x[
+ 1], &lda, &xact[1], &lda, &rwork[1], &
+ rwork[*nrhs + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from SPPSVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___52.ciunit = *nout;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "SPPSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ } else {
+ io___53.ciunit = *nout;
+ s_wsfe(&io___53);
+ do_fio(&c__1, "SPPSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + 7 - k1;
+L90:
+L100:
+ ;
+ }
+/* L110: */
+ }
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SDRVPP */
+
+} /* sdrvpp_ */
diff --git a/TESTING/LIN/sdrvpt.c b/TESTING/LIN/sdrvpt.c
new file mode 100644
index 0000000..f2d5d01
--- /dev/null
+++ b/TESTING/LIN/sdrvpt.c
@@ -0,0 +1,652 @@
+/* sdrvpt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static real c_b23 = 1.f;
+static real c_b24 = 0.f;
+
+/* Subroutine */ int sdrvpt_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, real *a, real *d__,
+ real *e, real *b, real *x, real *xact, real *work, real *rwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 0,0,0,1 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
+ ", test \002,i2,\002, ratio = \002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i2,\002, test \002,i2,\002, ratio = \002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n;
+ real z__[3];
+ integer k1, ia, in, kl, ku, ix, nt, lda;
+ char fact[1];
+ real cond;
+ integer mode;
+ real dmax__;
+ integer imat, info;
+ char path[3], dist[1], type__[1];
+ integer nrun, ifact, nfail, iseed[4];
+ real rcond;
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *), sscal_(integer *, real *,
+ real *, integer *);
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ real anorm;
+ integer izero, nerrs;
+ extern doublereal sasum_(integer *, real *, integer *);
+ extern /* Subroutine */ int sptt01_(integer *, real *, real *, real *,
+ real *, real *, real *), sptt02_(integer *, integer *, real *,
+ real *, real *, integer *, real *, integer *, real *), scopy_(
+ integer *, real *, integer *, real *, integer *), sptt05_(integer
+ *, integer *, real *, real *, real *, integer *, real *, integer *
+, real *, integer *, real *, real *, real *);
+ logical zerot;
+ extern /* Subroutine */ int sptsv_(integer *, integer *, real *, real *,
+ real *, integer *, integer *), slatb4_(char *, integer *, integer
+ *, integer *, char *, integer *, integer *, real *, integer *,
+ real *, char *), aladhd_(integer *, char *
+), alaerh_(char *, char *, integer *, integer *, char *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *);
+ real rcondc;
+ extern integer isamax_(integer *, real *, integer *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ real ainvnm;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *), slaptm_(
+ integer *, integer *, real *, real *, real *, real *, integer *,
+ real *, real *, integer *), slatms_(integer *, integer *, char *,
+ integer *, char *, real *, integer *, real *, real *, integer *,
+ integer *, char *, real *, integer *, real *, integer *);
+ extern doublereal slanst_(char *, integer *, real *, real *);
+ extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
+ *);
+ real result[6];
+ extern /* Subroutine */ int spttrf_(integer *, real *, real *, integer *),
+ serrvx_(char *, integer *), spttrs_(integer *, integer *,
+ real *, real *, real *, integer *, integer *), sptsvx_(char *,
+ integer *, integer *, real *, real *, real *, real *, real *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVPT tests SPTSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) REAL array, dimension (NMAX*2) */
+
+/* D (workspace) REAL array, dimension (NMAX*2) */
+
+/* E (workspace) REAL array, dimension (NMAX*2) */
+
+/* B (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* X (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) REAL array, dimension */
+/* (max(NMAX,2*NRHS)) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --e;
+ --d__;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "PT", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+ lda = max(1,n);
+ nimat = 12;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (n > 0 && ! dotype[imat]) {
+ goto L110;
+ }
+
+/* Set up parameters with SLATB4. */
+
+ slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cond, dist);
+
+ zerot = imat >= 8 && imat <= 10;
+ if (imat <= 6) {
+
+/* Type 1-6: generate a symmetric tridiagonal matrix of */
+/* known condition number in lower triangular band storage. */
+
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
+ slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
+ &anorm, &kl, &ku, "B", &a[1], &c__2, &work[1], &info);
+
+/* Check the error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, " ", &n, &n, &kl, &
+ ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L110;
+ }
+ izero = 0;
+
+/* Copy the matrix to D and E. */
+
+ ia = 1;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d__[i__] = a[ia];
+ e[i__] = a[ia + 1];
+ ia += 2;
+/* L20: */
+ }
+ if (n > 0) {
+ d__[n] = a[ia];
+ }
+ } else {
+
+/* Type 7-12: generate a diagonally dominant matrix with */
+/* unknown condition number in the vectors D and E. */
+
+ if (! zerot || ! dotype[7]) {
+
+/* Let D and E have values from [-1,1]. */
+
+ slarnv_(&c__2, iseed, &n, &d__[1]);
+ i__3 = n - 1;
+ slarnv_(&c__2, iseed, &i__3, &e[1]);
+
+/* Make the tridiagonal matrix diagonally dominant. */
+
+ if (n == 1) {
+ d__[1] = dabs(d__[1]);
+ } else {
+ d__[1] = dabs(d__[1]) + dabs(e[1]);
+ d__[n] = (r__1 = d__[n], dabs(r__1)) + (r__2 = e[n -
+ 1], dabs(r__2));
+ i__3 = n - 1;
+ for (i__ = 2; i__ <= i__3; ++i__) {
+ d__[i__] = (r__1 = d__[i__], dabs(r__1)) + (r__2 =
+ e[i__], dabs(r__2)) + (r__3 = e[i__ - 1],
+ dabs(r__3));
+/* L30: */
+ }
+ }
+
+/* Scale D and E so the maximum element is ANORM. */
+
+ ix = isamax_(&n, &d__[1], &c__1);
+ dmax__ = d__[ix];
+ r__1 = anorm / dmax__;
+ sscal_(&n, &r__1, &d__[1], &c__1);
+ if (n > 1) {
+ i__3 = n - 1;
+ r__1 = anorm / dmax__;
+ sscal_(&i__3, &r__1, &e[1], &c__1);
+ }
+
+ } else if (izero > 0) {
+
+/* Reuse the last matrix by copying back the zeroed out */
+/* elements. */
+
+ if (izero == 1) {
+ d__[1] = z__[1];
+ if (n > 1) {
+ e[1] = z__[2];
+ }
+ } else if (izero == n) {
+ e[n - 1] = z__[0];
+ d__[n] = z__[1];
+ } else {
+ e[izero - 1] = z__[0];
+ d__[izero] = z__[1];
+ e[izero] = z__[2];
+ }
+ }
+
+/* For types 8-10, set one row and column of the matrix to */
+/* zero. */
+
+ izero = 0;
+ if (imat == 8) {
+ izero = 1;
+ z__[1] = d__[1];
+ d__[1] = 0.f;
+ if (n > 1) {
+ z__[2] = e[1];
+ e[1] = 0.f;
+ }
+ } else if (imat == 9) {
+ izero = n;
+ if (n > 1) {
+ z__[0] = e[n - 1];
+ e[n - 1] = 0.f;
+ }
+ z__[1] = d__[n];
+ d__[n] = 0.f;
+ } else if (imat == 10) {
+ izero = (n + 1) / 2;
+ if (izero > 1) {
+ z__[0] = e[izero - 1];
+ z__[2] = e[izero];
+ e[izero - 1] = 0.f;
+ e[izero] = 0.f;
+ }
+ z__[1] = d__[izero];
+ d__[izero] = 0.f;
+ }
+ }
+
+/* Generate NRHS random solution vectors. */
+
+ ix = 1;
+ i__3 = *nrhs;
+ for (j = 1; j <= i__3; ++j) {
+ slarnv_(&c__2, iseed, &n, &xact[ix]);
+ ix += lda;
+/* L40: */
+ }
+
+/* Set the right hand side. */
+
+ slaptm_(&n, nrhs, &c_b23, &d__[1], &e[1], &xact[1], &lda, &c_b24,
+ &b[1], &lda);
+
+ for (ifact = 1; ifact <= 2; ++ifact) {
+ if (ifact == 1) {
+ *(unsigned char *)fact = 'F';
+ } else {
+ *(unsigned char *)fact = 'N';
+ }
+
+/* Compute the condition number for comparison with */
+/* the value returned by SPTSVX. */
+
+ if (zerot) {
+ if (ifact == 1) {
+ goto L100;
+ }
+ rcondc = 0.f;
+
+ } else if (ifact == 1) {
+
+/* Compute the 1-norm of A. */
+
+ anorm = slanst_("1", &n, &d__[1], &e[1]);
+
+ scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
+ if (n > 1) {
+ i__3 = n - 1;
+ scopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
+ }
+
+/* Factor the matrix A. */
+
+ spttrf_(&n, &d__[n + 1], &e[n + 1], &info);
+
+/* Use SPTTRS to solve for one column at a time of */
+/* inv(A), computing the maximum column sum as we go. */
+
+ ainvnm = 0.f;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ x[j] = 0.f;
+/* L50: */
+ }
+ x[i__] = 1.f;
+ spttrs_(&n, &c__1, &d__[n + 1], &e[n + 1], &x[1], &
+ lda, &info);
+/* Computing MAX */
+ r__1 = ainvnm, r__2 = sasum_(&n, &x[1], &c__1);
+ ainvnm = dmax(r__1,r__2);
+/* L60: */
+ }
+
+/* Compute the 1-norm condition number of A. */
+
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondc = 1.f;
+ } else {
+ rcondc = 1.f / anorm / ainvnm;
+ }
+ }
+
+ if (ifact == 2) {
+
+/* --- Test SPTSV -- */
+
+ scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
+ if (n > 1) {
+ i__3 = n - 1;
+ scopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
+ }
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
+
+/* Factor A as L*D*L' and solve the system A*X = B. */
+
+ s_copy(srnamc_1.srnamt, "SPTSV ", (ftnlen)32, (ftnlen)6);
+ sptsv_(&n, nrhs, &d__[n + 1], &e[n + 1], &x[1], &lda, &
+ info);
+
+/* Check error code from SPTSV . */
+
+ if (info != izero) {
+ alaerh_(path, "SPTSV ", &info, &izero, " ", &n, &n, &
+ c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+ nt = 0;
+ if (izero == 0) {
+
+/* Check the factorization by computing the ratio */
+/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
+
+ sptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
+ work[1], result);
+
+/* Compute the residual in the solution. */
+
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ sptt02_(&n, nrhs, &d__[1], &e[1], &x[1], &lda, &work[
+ 1], &lda, &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, "SPTSV ", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L70: */
+ }
+ nrun += nt;
+ }
+
+/* --- Test SPTSVX --- */
+
+ if (ifact > 1) {
+
+/* Initialize D( N+1:2*N ) and E( N+1:2*N ) to zero. */
+
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d__[n + i__] = 0.f;
+ e[n + i__] = 0.f;
+/* L80: */
+ }
+ if (n > 0) {
+ d__[n + n] = 0.f;
+ }
+ }
+
+ slaset_("Full", &n, nrhs, &c_b24, &c_b24, &x[1], &lda);
+
+/* Solve the system and compute the condition number and */
+/* error bounds using SPTSVX. */
+
+ s_copy(srnamc_1.srnamt, "SPTSVX", (ftnlen)32, (ftnlen)6);
+ sptsvx_(fact, &n, nrhs, &d__[1], &e[1], &d__[n + 1], &e[n + 1]
+, &b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &rwork[
+ *nrhs + 1], &work[1], &info);
+
+/* Check the error code from SPTSVX. */
+
+ if (info != izero) {
+ alaerh_(path, "SPTSVX", &info, &izero, fact, &n, &n, &
+ c__1, &c__1, nrhs, &imat, &nfail, &nerrs, nout);
+ }
+ if (izero == 0) {
+ if (ifact == 2) {
+
+/* Check the factorization by computing the ratio */
+/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
+
+ k1 = 1;
+ sptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
+ work[1], result);
+ } else {
+ k1 = 2;
+ }
+
+/* Compute the residual in the solution. */
+
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ sptt02_(&n, nrhs, &d__[1], &e[1], &x[1], &lda, &work[1], &
+ lda, &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[2]);
+
+/* Check error bounds from iterative refinement. */
+
+ sptt05_(&n, nrhs, &d__[1], &e[1], &b[1], &lda, &x[1], &
+ lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs + 1],
+ &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Check the reciprocal of the condition number. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, "SPTSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L90: */
+ }
+ nrun = nrun + 7 - k1;
+L100:
+ ;
+ }
+L110:
+ ;
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SDRVPT */
+
+} /* sdrvpt_ */
diff --git a/TESTING/LIN/sdrvrf1.c b/TESTING/LIN/sdrvrf1.c
new file mode 100644
index 0000000..73075f1
--- /dev/null
+++ b/TESTING/LIN/sdrvrf1.c
@@ -0,0 +1,341 @@
+/* sdrvrf1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* Subroutine */ int sdrvrf1_(integer *nout, integer *nn, integer *nval, real
+ *thresh, real *a, integer *lda, real *arf, real *work)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char forms[1*2] = "N" "T";
+ static char norms[1*4] = "M" "1" "I" "F";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002 *** Error(s) or Failure(s) while test"
+ "ing SLANSF ***\002)";
+ static char fmt_9998[] = "(1x,\002 Error in \002,a6,\002 with UPLO="
+ "'\002,a1,\002', FORM='\002,a1,\002', N=\002,i5)";
+ static char fmt_9997[] = "(1x,\002 Failure in \002,a6,\002 N=\002,"
+ "i5,\002 TYPE=\002,i5,\002 UPLO='\002,a1,\002', FORM ='\002,a1"
+ ",\002', NORM='\002,a1,\002', test=\002,g12.5)";
+ static char fmt_9996[] = "(1x,\002All tests for \002,a6,\002 auxiliary r"
+ "outine passed the \002,\002threshold (\002,i5,\002 tests run)"
+ "\002)";
+ static char fmt_9995[] = "(1x,a6,\002 auxiliary routine:\002,i5,\002 out"
+ " of \002,i5,\002 tests failed to pass the threshold\002)";
+ static char fmt_9994[] = "(26x,i5,\002 error message recorded (\002,a6"
+ ",\002)\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void),
+ do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, n, iin, iit;
+ real eps;
+ integer info;
+ char norm[1], uplo[1];
+ integer nrun, nfail;
+ real large;
+ integer iseed[4];
+ char cform[1];
+ real small;
+ integer iform;
+ real norma;
+ integer inorm, iuplo, nerrs;
+ extern doublereal slamch_(char *), slarnd_(integer *, integer *),
+ slansf_(char *, char *, char *, integer *, real *, real *), slansy_(char *, char *, integer *, real *,
+ integer *, real *);
+ real result[1];
+ extern /* Subroutine */ int strttf_(char *, char *, integer *, real *,
+ integer *, real *, integer *);
+ real normarf;
+
+ /* Fortran I/O blocks */
+ static cilist io___22 = { 0, 0, 0, 0, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___30 = { 0, 0, 0, 0, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVRF1 tests the LAPACK RFP routines: */
+/* SLANSF */
+
+/* Arguments */
+/* ========= */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* THRESH (input) 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. */
+
+/* A (workspace) REAL array, dimension (LDA,NMAX) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,NMAX). */
+
+/* ARF (workspace) REAL array, dimension ((NMAX*(NMAX+1))/2). */
+
+/* WORK (workspace) REAL array, dimension ( NMAX ) */
+
+/* ===================================================================== */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nval;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --arf;
+ --work;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ info = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+ eps = slamch_("Precision");
+ small = slamch_("Safe minimum");
+ large = 1.f / small;
+ small = small * *lda * *lda;
+ large = large / *lda / *lda;
+
+ i__1 = *nn;
+ for (iin = 1; iin <= i__1; ++iin) {
+
+ n = nval[iin];
+
+ for (iit = 1; iit <= 3; ++iit) {
+
+/* IIT = 1 : random matrix */
+/* IIT = 2 : random matrix scaled near underflow */
+/* IIT = 3 : random matrix scaled near overflow */
+
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[i__ + j * a_dim1] = slarnd_(&c__2, iseed);
+ }
+ }
+
+ if (iit == 2) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[i__ + j * a_dim1] *= large;
+ }
+ }
+ }
+
+ if (iit == 3) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[i__ + j * a_dim1] *= small;
+ }
+ }
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Do first for CFORM = 'N', then for CFORM = 'C' */
+
+ for (iform = 1; iform <= 2; ++iform) {
+
+ *(unsigned char *)cform = *(unsigned char *)&forms[iform
+ - 1];
+
+ s_copy(srnamc_1.srnamt, "STRTTF", (ftnlen)32, (ftnlen)6);
+ strttf_(cform, uplo, &n, &a[a_offset], lda, &arf[1], &
+ info);
+
+/* Check error code from STRTTF */
+
+ if (info != 0) {
+ if (nfail == 0 && nerrs == 0) {
+ io___22.ciunit = *nout;
+ s_wsle(&io___22);
+ e_wsle();
+ io___23.ciunit = *nout;
+ s_wsfe(&io___23);
+ e_wsfe();
+ }
+ io___24.ciunit = *nout;
+ s_wsfe(&io___24);
+ do_fio(&c__1, srnamc_1.srnamt, (ftnlen)32);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, cform, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ++nerrs;
+ goto L100;
+ }
+
+ for (inorm = 1; inorm <= 4; ++inorm) {
+
+/* Check all four norms: 'M', '1', 'I', 'F' */
+
+ *(unsigned char *)norm = *(unsigned char *)&norms[
+ inorm - 1];
+ normarf = slansf_(norm, cform, uplo, &n, &arf[1], &
+ work[1]);
+ norma = slansy_(norm, uplo, &n, &a[a_offset], lda, &
+ work[1]);
+
+ result[0] = (norma - normarf) / norma / eps;
+ ++nrun;
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ io___30.ciunit = *nout;
+ s_wsle(&io___30);
+ e_wsle();
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ e_wsfe();
+ }
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "SLANSF", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iit, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, cform, (ftnlen)1);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L90: */
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+
+/* Print a summary of the results. */
+
+ if (nfail == 0) {
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, "SLANSF", (ftnlen)6);
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "SLANSF", (ftnlen)6);
+ do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (nerrs != 0) {
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, (char *)&nerrs, (ftnlen)sizeof(integer));
+ do_fio(&c__1, "SLANSF", (ftnlen)6);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of SDRVRF1 */
+
+} /* sdrvrf1_ */
diff --git a/TESTING/LIN/sdrvrf2.c b/TESTING/LIN/sdrvrf2.c
new file mode 100644
index 0000000..ebf3fa9
--- /dev/null
+++ b/TESTING/LIN/sdrvrf2.c
@@ -0,0 +1,309 @@
+/* sdrvrf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* Subroutine */ int sdrvrf2_(integer *nout, integer *nn, integer *nval, real
+ *a, integer *lda, real *arf, real *ap, real *asav)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char forms[1*2] = "N" "T";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002 *** Error(s) while testing the RFP co"
+ "nvertion\002,\002 routines ***\002)";
+ static char fmt_9998[] = "(1x,\002 Error in RFP,convertion routines "
+ "N=\002,i5,\002 UPLO='\002,a1,\002', FORM ='\002,a1,\002'\002)";
+ static char fmt_9997[] = "(1x,\002All tests for the RFP convertion routi"
+ "nes passed (\002,i5,\002 tests run)\002)";
+ static char fmt_9996[] = "(1x,\002RFP convertion routines:\002,i5,\002 o"
+ "ut of \002,i5,\002 error message recorded\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, asav_dim1, asav_offset, i__1, i__2, i__3;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void),
+ do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, n;
+ logical ok1, ok2;
+ integer iin, info;
+ char uplo[1];
+ integer nrun, iseed[4];
+ char cform[1];
+ integer iform;
+ logical lower;
+ integer iuplo, nerrs;
+ extern doublereal slarnd_(integer *, integer *);
+ extern /* Subroutine */ int stfttp_(char *, char *, integer *, real *,
+ real *, integer *), stpttf_(char *, char *,
+ integer *, real *, real *, integer *), stfttr_(
+ char *, char *, integer *, real *, real *, integer *, integer *), strttf_(char *, char *, integer *, real *,
+ integer *, real *, integer *), strttp_(char *,
+ integer *, real *, integer *, real *, integer *), stpttr_(
+ char *, integer *, real *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___19 = { 0, 0, 0, 0, 0 };
+ static cilist io___20 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___21 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVRF2 tests the LAPACK RFP convertion routines. */
+
+/* Arguments */
+/* ========= */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* A (workspace) REAL array, dimension (LDA,NMAX) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,NMAX). */
+
+/* ARF (workspace) REAL array, dimension ((NMAX*(NMAX+1))/2). */
+
+/* AP (workspace) REAL array, dimension ((NMAX*(NMAX+1))/2). */
+
+/* A2 (workspace) REAL array, dimension (LDA,NMAX) */
+
+/* ===================================================================== */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nval;
+ asav_dim1 = *lda;
+ asav_offset = 1 + asav_dim1;
+ asav -= asav_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --arf;
+ --ap;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ nrun = 0;
+ nerrs = 0;
+ info = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+ i__1 = *nn;
+ for (iin = 1; iin <= i__1; ++iin) {
+
+ n = nval[iin];
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ lower = TRUE_;
+ if (iuplo == 1) {
+ lower = FALSE_;
+ }
+
+/* Do first for CFORM = 'N', then for CFORM = 'T' */
+
+ for (iform = 1; iform <= 2; ++iform) {
+
+ *(unsigned char *)cform = *(unsigned char *)&forms[iform - 1];
+
+ ++nrun;
+
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[i__ + j * a_dim1] = slarnd_(&c__2, iseed);
+ }
+ }
+
+ s_copy(srnamc_1.srnamt, "DTRTTF", (ftnlen)32, (ftnlen)6);
+ strttf_(cform, uplo, &n, &a[a_offset], lda, &arf[1], &info);
+
+ s_copy(srnamc_1.srnamt, "DTFTTP", (ftnlen)32, (ftnlen)6);
+ stfttp_(cform, uplo, &n, &arf[1], &ap[1], &info);
+
+ s_copy(srnamc_1.srnamt, "DTPTTR", (ftnlen)32, (ftnlen)6);
+ stpttr_(uplo, &n, &ap[1], &asav[asav_offset], lda, &info);
+
+ ok1 = TRUE_;
+ if (lower) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ if (a[i__ + j * a_dim1] != asav[i__ + j *
+ asav_dim1]) {
+ ok1 = FALSE_;
+ }
+ }
+ }
+ } else {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (a[i__ + j * a_dim1] != asav[i__ + j *
+ asav_dim1]) {
+ ok1 = FALSE_;
+ }
+ }
+ }
+ }
+
+ ++nrun;
+
+ s_copy(srnamc_1.srnamt, "DTRTTP", (ftnlen)32, (ftnlen)6);
+ strttp_(uplo, &n, &a[a_offset], lda, &ap[1], &info)
+ ;
+
+ s_copy(srnamc_1.srnamt, "DTPTTF", (ftnlen)32, (ftnlen)6);
+ stpttf_(cform, uplo, &n, &ap[1], &arf[1], &info);
+
+ s_copy(srnamc_1.srnamt, "DTFTTR", (ftnlen)32, (ftnlen)6);
+ stfttr_(cform, uplo, &n, &arf[1], &asav[asav_offset], lda, &
+ info);
+
+ ok2 = TRUE_;
+ if (lower) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ if (a[i__ + j * a_dim1] != asav[i__ + j *
+ asav_dim1]) {
+ ok2 = FALSE_;
+ }
+ }
+ }
+ } else {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ if (a[i__ + j * a_dim1] != asav[i__ + j *
+ asav_dim1]) {
+ ok2 = FALSE_;
+ }
+ }
+ }
+ }
+
+ if (! ok1 || ! ok2) {
+ if (nerrs == 0) {
+ io___19.ciunit = *nout;
+ s_wsle(&io___19);
+ e_wsle();
+ io___20.ciunit = *nout;
+ s_wsfe(&io___20);
+ e_wsfe();
+ }
+ io___21.ciunit = *nout;
+ s_wsfe(&io___21);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, cform, (ftnlen)1);
+ e_wsfe();
+ ++nerrs;
+ }
+
+/* L100: */
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ if (nerrs == 0) {
+ io___22.ciunit = *nout;
+ s_wsfe(&io___22);
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___23.ciunit = *nout;
+ s_wsfe(&io___23);
+ do_fio(&c__1, (char *)&nerrs, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of SDRVRF2 */
+
+} /* sdrvrf2_ */
diff --git a/TESTING/LIN/sdrvrf3.c b/TESTING/LIN/sdrvrf3.c
new file mode 100644
index 0000000..d5508b6
--- /dev/null
+++ b/TESTING/LIN/sdrvrf3.c
@@ -0,0 +1,436 @@
+/* sdrvrf3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* Subroutine */ int sdrvrf3_(integer *nout, integer *nn, integer *nval, real
+ *thresh, real *a, integer *lda, real *arf, real *b1, real *b2, real *
+ s_work_slange__, real *s_work_sgeqrf__, real *tau)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char forms[1*2] = "N" "T";
+ static char sides[1*2] = "L" "R";
+ static char transs[1*2] = "N" "T";
+ static char diags[1*2] = "N" "U";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002 *** Error(s) or Failure(s) while test"
+ "ing STFSM ***\002)";
+ static char fmt_9997[] = "(1x,\002 Failure in \002,a5,\002, CFORM="
+ "'\002,a1,\002',\002,\002 SIDE='\002,a1,\002',\002,\002 UPLO='"
+ "\002,a1,\002',\002,\002 TRANS='\002,a1,\002',\002,\002 DIAG='"
+ "\002,a1,\002',\002,\002 M=\002,i3,\002, N =\002,i3,\002, test"
+ "=\002,g12.5)";
+ static char fmt_9996[] = "(1x,\002All tests for \002,a5,\002 auxiliary r"
+ "outine passed the \002,\002threshold (\002,i5,\002 tests run)"
+ "\002)";
+ static char fmt_9995[] = "(1x,a6,\002 auxiliary routine:\002,i5,\002 out"
+ " of \002,i5,\002 tests failed to pass the threshold\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b1_dim1, b1_offset, b2_dim1, b2_offset, i__1,
+ i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void),
+ do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, m, n, na, iim, iin;
+ real eps;
+ char diag[1], side[1];
+ integer info;
+ char uplo[1];
+ integer nrun, idiag;
+ real alpha;
+ integer nfail, iseed[4], iside;
+ char cform[1];
+ integer iform;
+ char trans[1];
+ integer iuplo;
+ extern /* Subroutine */ int stfsm_(char *, char *, char *, char *, char *,
+ integer *, integer *, real *, real *, real *, integer *), strsm_(char *, char *, char *,
+ char *, integer *, integer *, real *, real *, integer *, real *,
+ integer *);
+ integer ialpha;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *), slarnd_(integer *,
+ integer *);
+ extern /* Subroutine */ int sgelqf_(integer *, integer *, real *, integer
+ *, real *, real *, integer *, integer *), sgeqrf_(integer *,
+ integer *, real *, integer *, real *, real *, integer *, integer *
+);
+ integer itrans;
+ real result[1];
+ extern /* Subroutine */ int strttf_(char *, char *, integer *, real *,
+ integer *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___32 = { 0, 0, 0, 0, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVRF3 tests the LAPACK RFP routines: */
+/* STFSM */
+
+/* Arguments */
+/* ========= */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* THRESH (input) 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. */
+
+/* A (workspace) REAL array, dimension (LDA,NMAX) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,NMAX). */
+
+/* ARF (workspace) REAL array, dimension ((NMAX*(NMAX+1))/2). */
+
+/* B1 (workspace) REAL array, dimension (LDA,NMAX) */
+
+/* B2 (workspace) REAL array, dimension (LDA,NMAX) */
+
+/* S_WORK_SLANGE (workspace) REAL array, dimension (NMAX) */
+
+/* S_WORK_SGEQRF (workspace) REAL array, dimension (NMAX) */
+
+/* TAU (workspace) REAL array, dimension (NMAX) */
+
+/* ===================================================================== */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nval;
+ b2_dim1 = *lda;
+ b2_offset = 1 + b2_dim1;
+ b2 -= b2_offset;
+ b1_dim1 = *lda;
+ b1_offset = 1 + b1_dim1;
+ b1 -= b1_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --arf;
+ --s_work_slange__;
+ --s_work_sgeqrf__;
+ --tau;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ nrun = 0;
+ nfail = 0;
+ info = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = slamch_("Precision");
+
+ i__1 = *nn;
+ for (iim = 1; iim <= i__1; ++iim) {
+
+ m = nval[iim];
+
+ i__2 = *nn;
+ for (iin = 1; iin <= i__2; ++iin) {
+
+ n = nval[iin];
+
+ for (iform = 1; iform <= 2; ++iform) {
+
+ *(unsigned char *)cform = *(unsigned char *)&forms[iform - 1];
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+
+ for (iside = 1; iside <= 2; ++iside) {
+
+ *(unsigned char *)side = *(unsigned char *)&sides[
+ iside - 1];
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itrans - 1];
+
+ for (idiag = 1; idiag <= 2; ++idiag) {
+
+ *(unsigned char *)diag = *(unsigned char *)&
+ diags[idiag - 1];
+
+ for (ialpha = 1; ialpha <= 3; ++ialpha) {
+
+ if (ialpha == 1) {
+ alpha = 0.f;
+ } else if (ialpha == 1) {
+ alpha = 1.f;
+ } else {
+ alpha = slarnd_(&c__2, iseed);
+ }
+
+/* All the parameters are set: */
+/* CFORM, SIDE, UPLO, TRANS, DIAG, M, N, */
+/* and ALPHA */
+/* READY TO TEST! */
+
+ ++nrun;
+
+ if (iside == 1) {
+
+/* The case ISIDE.EQ.1 is when SIDE.EQ.'L' */
+/* -> A is M-by-M ( B is M-by-N ) */
+
+ na = m;
+
+ } else {
+
+/* The case ISIDE.EQ.2 is when SIDE.EQ.'R' */
+/* -> A is N-by-N ( B is M-by-N ) */
+
+ na = n;
+
+ }
+
+/* Generate A our NA--by--NA triangular */
+/* matrix. */
+/* Our test is based on forward error so we */
+/* do want A to be well conditionned! To get */
+/* a well-conditionned triangular matrix, we */
+/* take the R factor of the QR/LQ factorization */
+/* of a random matrix. */
+
+ i__3 = na;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = na;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ a[i__ + j * a_dim1] = slarnd_(&
+ c__2, iseed);
+ }
+ }
+
+ if (iuplo == 1) {
+
+/* The case IUPLO.EQ.1 is when SIDE.EQ.'U' */
+/* -> QR factorization. */
+
+ s_copy(srnamc_1.srnamt, "SGEQRF", (
+ ftnlen)32, (ftnlen)6);
+ sgeqrf_(&na, &na, &a[a_offset], lda, &
+ tau[1], &s_work_sgeqrf__[1],
+ lda, &info);
+ } else {
+
+/* The case IUPLO.EQ.2 is when SIDE.EQ.'L' */
+/* -> QL factorization. */
+
+ s_copy(srnamc_1.srnamt, "SGELQF", (
+ ftnlen)32, (ftnlen)6);
+ sgelqf_(&na, &na, &a[a_offset], lda, &
+ tau[1], &s_work_sgeqrf__[1],
+ lda, &info);
+ }
+
+/* Store a copy of A in RFP format (in ARF). */
+
+ s_copy(srnamc_1.srnamt, "STRTTF", (ftnlen)
+ 32, (ftnlen)6);
+ strttf_(cform, uplo, &na, &a[a_offset],
+ lda, &arf[1], &info);
+
+/* Generate B1 our M--by--N right-hand side */
+/* and store a copy in B2. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = m;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ b1[i__ + j * b1_dim1] = slarnd_(&
+ c__2, iseed);
+ b2[i__ + j * b2_dim1] = b1[i__ +
+ j * b1_dim1];
+ }
+ }
+
+/* Solve op( A ) X = B or X op( A ) = B */
+/* with STRSM */
+
+ s_copy(srnamc_1.srnamt, "STRSM", (ftnlen)
+ 32, (ftnlen)5);
+ strsm_(side, uplo, trans, diag, &m, &n, &
+ alpha, &a[a_offset], lda, &b1[
+ b1_offset], lda);
+
+/* Solve op( A ) X = B or X op( A ) = B */
+/* with STFSM */
+
+ s_copy(srnamc_1.srnamt, "STFSM", (ftnlen)
+ 32, (ftnlen)5);
+ stfsm_(cform, side, uplo, trans, diag, &m,
+ &n, &alpha, &arf[1], &b2[
+ b2_offset], lda);
+
+/* Check that the result agrees. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = m;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ b1[i__ + j * b1_dim1] = b2[i__ +
+ j * b2_dim1] - b1[i__ + j
+ * b1_dim1];
+ }
+ }
+
+ result[0] = slange_("I", &m, &n, &b1[
+ b1_offset], lda, &s_work_slange__[
+ 1]);
+
+/* Computing MAX */
+ i__3 = max(m,n);
+ result[0] = result[0] / sqrt(eps) / max(
+ i__3,1);
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0) {
+ io___32.ciunit = *nout;
+ s_wsle(&io___32);
+ e_wsle();
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ e_wsfe();
+ }
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "STFSM", (ftnlen)5);
+ do_fio(&c__1, cform, (ftnlen)1);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (
+ ftnlen)sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+
+/* L100: */
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+
+/* Print a summary of the results. */
+
+ if (nfail == 0) {
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, "STFSM", (ftnlen)5);
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, "STFSM", (ftnlen)5);
+ do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of SDRVRF3 */
+
+} /* sdrvrf3_ */
diff --git a/TESTING/LIN/sdrvrf4.c b/TESTING/LIN/sdrvrf4.c
new file mode 100644
index 0000000..1d12323
--- /dev/null
+++ b/TESTING/LIN/sdrvrf4.c
@@ -0,0 +1,411 @@
+/* sdrvrf4.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* Subroutine */ int sdrvrf4_(integer *nout, integer *nn, integer *nval, real
+ *thresh, real *c1, real *c2, integer *ldc, real *crf, real *a,
+ integer *lda, real *s_work_slange__)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char forms[1*2] = "N" "T";
+ static char transs[1*2] = "N" "T";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002 *** Error(s) or Failure(s) while test"
+ "ing SSFRK ***\002)";
+ static char fmt_9997[] = "(1x,\002 Failure in \002,a5,\002, CFORM="
+ "'\002,a1,\002',\002,\002 UPLO='\002,a1,\002',\002,\002 TRANS="
+ "'\002,a1,\002',\002,\002 N=\002,i3,\002, K =\002,i3,\002, test"
+ "=\002,g12.5)";
+ static char fmt_9996[] = "(1x,\002All tests for \002,a5,\002 auxiliary r"
+ "outine passed the \002,\002threshold (\002,i5,\002 tests run)"
+ "\002)";
+ static char fmt_9995[] = "(1x,a6,\002 auxiliary routine:\002,i5,\002 out"
+ " of \002,i5,\002 tests failed to pass the threshold\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, c1_dim1, c1_offset, c2_dim1, c2_offset, i__1,
+ i__2, i__3, i__4;
+ real r__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void),
+ do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k, n, iik, iin;
+ real eps, beta;
+ integer info;
+ char uplo[1];
+ integer nrun;
+ real alpha;
+ integer nfail, iseed[4];
+ char cform[1];
+ integer iform;
+ real norma, normc;
+ char trans[1];
+ integer iuplo;
+ extern /* Subroutine */ int ssfrk_(char *, char *, char *, integer *,
+ integer *, real *, real *, integer *, real *, real *), ssyrk_(char *, char *, integer *, integer *,
+ real *, real *, integer *, real *, real *, integer *);
+ integer ialpha;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *), slarnd_(integer *,
+ integer *);
+ integer itrans;
+ real result[1];
+ extern /* Subroutine */ int stfttr_(char *, char *, integer *, real *,
+ real *, integer *, integer *), strttf_(char *,
+ char *, integer *, real *, integer *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___28 = { 0, 0, 0, 0, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVRF4 tests the LAPACK RFP routines: */
+/* SSFRK */
+
+/* Arguments */
+/* ========= */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* THRESH (input) 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. */
+
+/* C1 (workspace) REAL array, */
+/* dimension (LDC,NMAX) */
+
+/* C2 (workspace) REAL array, */
+/* dimension (LDC,NMAX) */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array A. */
+/* LDA >= max(1,NMAX). */
+
+/* CRF (workspace) REAL array, */
+/* dimension ((NMAX*(NMAX+1))/2). */
+
+/* A (workspace) REAL array, */
+/* dimension (LDA,NMAX) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,NMAX). */
+
+/* S_WORK_SLANGE (workspace) REAL array, dimension (NMAX) */
+
+/* ===================================================================== */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nval;
+ c2_dim1 = *ldc;
+ c2_offset = 1 + c2_dim1;
+ c2 -= c2_offset;
+ c1_dim1 = *ldc;
+ c1_offset = 1 + c1_dim1;
+ c1 -= c1_offset;
+ --crf;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s_work_slange__;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ nrun = 0;
+ nfail = 0;
+ info = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = slamch_("Precision");
+
+ i__1 = *nn;
+ for (iin = 1; iin <= i__1; ++iin) {
+
+ n = nval[iin];
+
+ i__2 = *nn;
+ for (iik = 1; iik <= i__2; ++iik) {
+
+ k = nval[iin];
+
+ for (iform = 1; iform <= 2; ++iform) {
+
+ *(unsigned char *)cform = *(unsigned char *)&forms[iform - 1];
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[
+ itrans - 1];
+
+ for (ialpha = 1; ialpha <= 4; ++ialpha) {
+
+ if (ialpha == 1) {
+ alpha = 0.f;
+ beta = 0.f;
+ } else if (ialpha == 2) {
+ alpha = 1.f;
+ beta = 0.f;
+ } else if (ialpha == 3) {
+ alpha = 0.f;
+ beta = 1.f;
+ } else {
+ alpha = slarnd_(&c__2, iseed);
+ beta = slarnd_(&c__2, iseed);
+ }
+
+/* All the parameters are set: */
+/* CFORM, UPLO, TRANS, M, N, */
+/* ALPHA, and BETA */
+/* READY TO TEST! */
+
+ ++nrun;
+
+ if (itrans == 1) {
+
+/* In this case we are NOTRANS, so A is N-by-K */
+
+ i__3 = k;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ a[i__ + j * a_dim1] = slarnd_(&c__2,
+ iseed);
+ }
+ }
+
+ norma = slange_("I", &n, &k, &a[a_offset],
+ lda, &s_work_slange__[1]);
+
+ } else {
+
+/* In this case we are TRANS, so A is K-by-N */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = k;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ a[i__ + j * a_dim1] = slarnd_(&c__2,
+ iseed);
+ }
+ }
+
+ norma = slange_("I", &k, &n, &a[a_offset],
+ lda, &s_work_slange__[1]);
+
+ }
+
+/* Generate C1 our N--by--N symmetric matrix. */
+/* Make sure C2 has the same upper/lower part, */
+/* (the one that we do not touch), so */
+/* copy the initial C1 in C2 in it. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ c1[i__ + j * c1_dim1] = slarnd_(&c__2,
+ iseed);
+ c2[i__ + j * c2_dim1] = c1[i__ + j *
+ c1_dim1];
+ }
+ }
+
+/* (See comment later on for why we use SLANGE and */
+/* not SLANSY for C1.) */
+
+ normc = slange_("I", &n, &n, &c1[c1_offset], ldc,
+ &s_work_slange__[1]);
+
+ s_copy(srnamc_1.srnamt, "STRTTF", (ftnlen)32, (
+ ftnlen)6);
+ strttf_(cform, uplo, &n, &c1[c1_offset], ldc, &
+ crf[1], &info);
+
+/* call ssyrk the BLAS routine -> gives C1 */
+
+ s_copy(srnamc_1.srnamt, "SSYRK ", (ftnlen)32, (
+ ftnlen)6);
+ ssyrk_(uplo, trans, &n, &k, &alpha, &a[a_offset],
+ lda, &beta, &c1[c1_offset], ldc);
+
+/* call ssfrk the RFP routine -> gives CRF */
+
+ s_copy(srnamc_1.srnamt, "SSFRK ", (ftnlen)32, (
+ ftnlen)6);
+ ssfrk_(cform, uplo, trans, &n, &k, &alpha, &a[
+ a_offset], lda, &beta, &crf[1]);
+
+/* convert CRF in full format -> gives C2 */
+
+ s_copy(srnamc_1.srnamt, "STFTTR", (ftnlen)32, (
+ ftnlen)6);
+ stfttr_(cform, uplo, &n, &crf[1], &c2[c2_offset],
+ ldc, &info);
+
+/* compare C1 and C2 */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ c1[i__ + j * c1_dim1] -= c2[i__ + j *
+ c2_dim1];
+ }
+ }
+
+/* Yes, C1 is symmetric so we could call SLANSY, */
+/* but we want to check the upper part that is */
+/* supposed to be unchanged and the diagonal that */
+/* is supposed to be real -> SLANGE */
+
+ result[0] = slange_("I", &n, &n, &c1[c1_offset],
+ ldc, &s_work_slange__[1]);
+/* Computing MAX */
+ r__1 = dabs(alpha) * norma + dabs(beta);
+ result[0] = result[0] / dmax(r__1,1.f) / max(n,1)
+ / eps;
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0) {
+ io___28.ciunit = *nout;
+ s_wsle(&io___28);
+ e_wsle();
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ e_wsfe();
+ }
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, "SSFRK", (ftnlen)5);
+ do_fio(&c__1, cform, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+
+/* L100: */
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+/* Print a summary of the results. */
+
+ if (nfail == 0) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, "SSFRK", (ftnlen)5);
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "SSFRK", (ftnlen)5);
+ do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of SDRVRF4 */
+
+} /* sdrvrf4_ */
diff --git a/TESTING/LIN/sdrvrfp.c b/TESTING/LIN/sdrvrfp.c
new file mode 100644
index 0000000..ed06935
--- /dev/null
+++ b/TESTING/LIN/sdrvrfp.c
@@ -0,0 +1,582 @@
+/* sdrvrfp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+
+/* Subroutine */ int sdrvrfp_(integer *nout, integer *nn, integer *nval,
+ integer *nns, integer *nsval, integer *nnt, integer *ntval, real *
+ thresh, real *a, real *asav, real *afac, real *ainv, real *b, real *
+ bsav, real *xact, real *x, real *arf, real *arfinv, real *
+ s_work_slatms__, real *s_work_spot01__, real *s_temp_spot02__, real *
+ s_temp_spot03__, real *s_work_slansy__, real *s_work_spot02__, real *
+ s_work_spot03__)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char forms[1*2] = "N" "T";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a6,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, kl, ku, nt, lda, ldb, iin, iis, iit, ioff, mode, info,
+ imat;
+ char dist[1];
+ integer nrhs;
+ char uplo[1];
+ integer nrun, nfail, iseed[4];
+ char cform[1];
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *);
+ integer iform;
+ real anorm;
+ char ctype[1];
+ extern /* Subroutine */ int spot01_(char *, integer *, real *, integer *,
+ real *, integer *, real *, real *);
+ integer iuplo, nerrs, izero;
+ extern /* Subroutine */ int spot02_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, real *, real *), spot03_(char *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, real *, real *, real *);
+ logical zerot;
+ extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), aladhd_(integer *, char *),
+ alaerh_(char *, char *, integer *, integer *, char *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *);
+ real rcondc;
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ real cndnum, ainvnm;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, integer *, integer *), slatms_(
+ integer *, integer *, char *, integer *, char *, real *, integer *
+, real *, real *, integer *, integer *, char *, real *, integer *,
+ real *, integer *), spftrf_(char *, char
+ *, integer *, real *, integer *), spftri_(char *,
+ char *, integer *, real *, integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+ extern /* Subroutine */ int spotrf_(char *, integer *, real *, integer *,
+ integer *);
+ real result[4];
+ extern /* Subroutine */ int spftrs_(char *, char *, integer *, integer *,
+ real *, real *, integer *, integer *), spotri_(
+ char *, integer *, real *, integer *, integer *), stfttr_(
+ char *, char *, integer *, real *, real *, integer *, integer *), strttf_(char *, char *, integer *, real *,
+ integer *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___37 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVRFP tests the LAPACK RFP routines: */
+/* SPFTRF, SPFTRS, and SPFTRI. */
+
+/* This testing routine follow the same tests as DDRVPO (test for the full */
+/* format Symmetric Positive Definite solver). */
+
+/* The tests are performed in Full Format, convertion back and forth from */
+/* full format to RFP format are performed using the routines STRTTF and */
+/* STFTTR. */
+
+/* First, a specific matrix A of size N is created. There is nine types of */
+/* different matrixes possible. */
+/* 1. Diagonal 6. Random, CNDNUM = sqrt(0.1/EPS) */
+/* 2. Random, CNDNUM = 2 7. Random, CNDNUM = 0.1/EPS */
+/* *3. First row and column zero 8. Scaled near underflow */
+/* *4. Last row and column zero 9. Scaled near overflow */
+/* *5. Middle row and column zero */
+/* (* - tests error exits from SPFTRF, no test ratios are computed) */
+/* A solution XACT of size N-by-NRHS is created and the associated right */
+/* hand side B as well. Then SPFTRF is called to compute L (or U), the */
+/* Cholesky factor of A. Then L (or U) is used to solve the linear system */
+/* of equations AX = B. This gives X. Then L (or U) is used to compute the */
+/* inverse of A, AINV. The following four tests are then performed: */
+/* (1) norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
+/* norm( U'*U - A ) / ( N * norm(A) * EPS ), */
+/* (2) norm(B - A*X) / ( norm(A) * norm(X) * EPS ), */
+/* (3) norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* (4) ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ), */
+/* where EPS is the machine precision, RCOND the condition number of A, and */
+/* norm( . ) the 1-norm for (1,2,3) and the inf-norm for (4). */
+/* Errors occur when INFO parameter is not as expected. Failures occur when */
+/* a test ratios is greater than THRES. */
+
+/* Arguments */
+/* ========= */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right-hand sides NRHS. */
+
+/* NNT (input) INTEGER */
+/* The number of values of MATRIX TYPE contained in the vector NTVAL. */
+
+/* NTVAL (input) INTEGER array, dimension (NNT) */
+/* The values of matrix type (between 0 and 9 for PO/PP/PF matrices). */
+
+/* THRESH (input) 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. */
+
+/* A (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* B (workspace) REAL array, dimension (NMAX*MAXRHS) */
+
+/* BSAV (workspace) REAL array, dimension (NMAX*MAXRHS) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*MAXRHS) */
+
+/* X (workspace) REAL array, dimension (NMAX*MAXRHS) */
+
+/* ARF (workspace) REAL array, dimension ((NMAX*(NMAX+1))/2) */
+
+/* ARFINV (workspace) REAL array, dimension ((NMAX*(NMAX+1))/2) */
+
+/* S_WORK_SLATMS (workspace) REAL array, dimension ( 3*NMAX ) */
+
+/* S_WORK_SPOT01 (workspace) REAL array, dimension ( NMAX ) */
+
+/* S_TEMP_SPOT02 (workspace) REAL array, dimension ( NMAX*MAXRHS ) */
+
+/* S_TEMP_SPOT03 (workspace) REAL array, dimension ( NMAX*NMAX ) */
+
+/* S_WORK_SLATMS (workspace) REAL array, dimension ( NMAX ) */
+
+/* S_WORK_SLANSY (workspace) REAL array, dimension ( NMAX ) */
+
+/* S_WORK_SPOT02 (workspace) REAL array, dimension ( NMAX ) */
+
+/* S_WORK_SPOT03 (workspace) REAL array, dimension ( NMAX ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nval;
+ --nsval;
+ --ntval;
+ --a;
+ --asav;
+ --afac;
+ --ainv;
+ --b;
+ --bsav;
+ --xact;
+ --x;
+ --arf;
+ --arfinv;
+ --s_work_slatms__;
+ --s_work_spot01__;
+ --s_temp_spot02__;
+ --s_temp_spot03__;
+ --s_work_slansy__;
+ --s_work_spot02__;
+ --s_work_spot03__;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+ i__1 = *nn;
+ for (iin = 1; iin <= i__1; ++iin) {
+
+ n = nval[iin];
+ lda = max(n,1);
+ ldb = max(n,1);
+
+ i__2 = *nns;
+ for (iis = 1; iis <= i__2; ++iis) {
+
+ nrhs = nsval[iis];
+
+ i__3 = *nnt;
+ for (iit = 1; iit <= i__3; ++iit) {
+
+ imat = ntval[iit];
+
+/* If N.EQ.0, only consider the first type */
+
+ if (n == 0 && iit > 1) {
+ goto L120;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ if (imat == 4 && n <= 1) {
+ goto L120;
+ }
+ if (imat == 5 && n <= 2) {
+ goto L120;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+
+/* Do first for CFORM = 'N', then for CFORM = 'C' */
+
+ for (iform = 1; iform <= 2; ++iform) {
+ *(unsigned char *)cform = *(unsigned char *)&forms[
+ iform - 1];
+
+/* Set up parameters with SLATB4 and generate a test */
+/* matrix with SLATMS. */
+
+ slatb4_("SPO", &imat, &n, &n, ctype, &kl, &ku, &anorm,
+ &mode, &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)
+ 6);
+ slatms_(&n, &n, dist, iseed, ctype, &s_work_slatms__[
+ 1], &mode, &cndnum, &anorm, &kl, &ku, uplo, &
+ a[1], &lda, &s_work_slatms__[1], &info);
+
+/* Check error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_("SPF", "SLATMS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &c_n1, &iit, &nfail, &
+ nerrs, nout);
+ goto L100;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot) {
+ if (iit == 3) {
+ izero = 1;
+ } else if (iit == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ i__4 = izero - 1;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__4 = n;
+ for (i__ = izero; i__ <= i__4; ++i__) {
+ a[ioff] = 0.f;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__4 = izero - 1;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ a[ioff] = 0.f;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__4 = n;
+ for (i__ = izero; i__ <= i__4; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ slacpy_(uplo, &n, &n, &a[1], &lda, &asav[1], &lda);
+
+/* Compute the condition number of A (RCONDC). */
+
+ if (zerot) {
+ rcondc = 0.f;
+ } else {
+
+/* Compute the 1-norm of A. */
+
+ anorm = slansy_("1", uplo, &n, &a[1], &lda, &
+ s_work_slansy__[1]);
+
+/* Factor the matrix A. */
+
+ spotrf_(uplo, &n, &a[1], &lda, &info);
+
+/* Form the inverse of A. */
+
+ spotri_(uplo, &n, &a[1], &lda, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = slansy_("1", uplo, &n, &a[1], &lda, &
+ s_work_slansy__[1]);
+ rcondc = 1.f / anorm / ainvnm;
+
+/* Restore the matrix A. */
+
+ slacpy_(uplo, &n, &n, &asav[1], &lda, &a[1], &lda);
+
+ }
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ slarhs_("SPO", "N", uplo, " ", &n, &n, &kl, &ku, &
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ slacpy_("Full", &n, &nrhs, &b[1], &lda, &bsav[1], &
+ lda);
+
+/* Compute the L*L' or U'*U factorization of the */
+/* matrix and solve the system. */
+
+ slacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ slacpy_("Full", &n, &nrhs, &b[1], &ldb, &x[1], &ldb);
+
+ s_copy(srnamc_1.srnamt, "STRTTF", (ftnlen)32, (ftnlen)
+ 6);
+ strttf_(cform, uplo, &n, &afac[1], &lda, &arf[1], &
+ info);
+ s_copy(srnamc_1.srnamt, "SPFTRF", (ftnlen)32, (ftnlen)
+ 6);
+ spftrf_(cform, uplo, &n, &arf[1], &info);
+
+/* Check error code from SPFTRF. */
+
+ if (info != izero) {
+
+/* LANGOU: there is a small hick here: IZERO should */
+/* always be INFO however if INFO is ZERO, ALAERH does not */
+/* complain. */
+
+ alaerh_("SPF", "SPFSV ", &info, &izero, uplo, &n,
+ &n, &c_n1, &c_n1, &nrhs, &iit, &nfail, &
+ nerrs, nout);
+ goto L100;
+ }
+
+/* Skip the tests if INFO is not 0. */
+
+ if (info != 0) {
+ goto L100;
+ }
+
+ s_copy(srnamc_1.srnamt, "SPFTRS", (ftnlen)32, (ftnlen)
+ 6);
+ spftrs_(cform, uplo, &n, &nrhs, &arf[1], &x[1], &ldb,
+ &info);
+
+ s_copy(srnamc_1.srnamt, "STFTTR", (ftnlen)32, (ftnlen)
+ 6);
+ stfttr_(cform, uplo, &n, &arf[1], &afac[1], &lda, &
+ info);
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ slacpy_(uplo, &n, &n, &afac[1], &lda, &asav[1], &lda);
+ spot01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
+ s_work_spot01__[1], result);
+ slacpy_(uplo, &n, &n, &asav[1], &lda, &afac[1], &lda);
+
+/* Form the inverse and compute the residual. */
+
+ if (n % 2 == 0) {
+ i__4 = n + 1;
+ i__5 = n / 2;
+ i__6 = n + 1;
+ i__7 = n + 1;
+ slacpy_("A", &i__4, &i__5, &arf[1], &i__6, &
+ arfinv[1], &i__7);
+ } else {
+ i__4 = (n + 1) / 2;
+ slacpy_("A", &n, &i__4, &arf[1], &n, &arfinv[1], &
+ n);
+ }
+
+ s_copy(srnamc_1.srnamt, "SPFTRI", (ftnlen)32, (ftnlen)
+ 6);
+ spftri_(cform, uplo, &n, &arfinv[1], &info);
+
+ s_copy(srnamc_1.srnamt, "STFTTR", (ftnlen)32, (ftnlen)
+ 6);
+ stfttr_(cform, uplo, &n, &arfinv[1], &ainv[1], &lda, &
+ info);
+
+/* Check error code from SPFTRI. */
+
+ if (info != 0) {
+ alaerh_("SPO", "SPFTRI", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ spot03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &
+ s_temp_spot03__[1], &lda, &s_work_spot03__[1],
+ &rcondc, &result[1]);
+
+/* Compute residual of the computed solution. */
+
+ slacpy_("Full", &n, &nrhs, &b[1], &lda, &
+ s_temp_spot02__[1], &lda);
+ spot02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
+ s_temp_spot02__[1], &lda, &s_work_spot02__[1],
+ &result[2]);
+
+/* Check solution from generated exact solution. */
+ sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+ nt = 4;
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, "SPF");
+ }
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, "SPFSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iit, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += nt;
+L100:
+ ;
+ }
+/* L110: */
+ }
+L120:
+ ;
+ }
+/* L980: */
+ }
+/* L130: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_("SPF", nout, &nfail, &nrun, &nerrs);
+
+
+ return 0;
+
+/* End of SDRVRFP */
+
+} /* sdrvrfp_ */
diff --git a/TESTING/LIN/sdrvsp.c b/TESTING/LIN/sdrvsp.c
new file mode 100644
index 0000000..40305f6
--- /dev/null
+++ b/TESTING/LIN/sdrvsp.c
@@ -0,0 +1,669 @@
+/* sdrvsp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static real c_b59 = 0.f;
+static integer c__2 = 2;
+
+/* Subroutine */ int sdrvsp_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, integer *nmax, real *a,
+ real *afac, real *ainv, real *b, real *x, real *xact, real *work,
+ real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char facts[1*2] = "F" "N";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002,"
+ " ratio =\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, k1, in, kl, ku, nt, lda, npp;
+ char fact[1];
+ integer ioff, mode, imat, info;
+ char path[3], dist[1], uplo[1], type__[1];
+ integer nrun, ifact, nfail, iseed[4];
+ real rcond;
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *);
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ real anorm;
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int sppt02_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *),
+ scopy_(integer *, real *, integer *, real *, integer *);
+ integer lwork;
+ extern /* Subroutine */ int sppt05_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, integer *, real *,
+ real *, real *), sspt01_(char *, integer *, real *, real *
+, integer *, real *, integer *, real *, real *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int sspsv_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, integer *), slatb4_(char *,
+ integer *, integer *, integer *, char *, integer *, integer *,
+ real *, integer *, real *, char *),
+ aladhd_(integer *, char *), alaerh_(char *, char *,
+ integer *, integer *, char *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *);
+ real rcondc;
+ char packit[1];
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ real cndnum, ainvnm;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, integer *, integer *), slaset_(
+ char *, integer *, integer *, real *, real *, real *, integer *);
+ extern doublereal slansp_(char *, char *, integer *, real *, real *);
+ extern /* Subroutine */ int slatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, real *, integer *, real *, integer *);
+ real result[6];
+ extern /* Subroutine */ int ssptrf_(char *, integer *, real *, integer *,
+ integer *), ssptri_(char *, integer *, real *, integer *,
+ real *, integer *), serrvx_(char *, integer *),
+ sspsvx_(char *, char *, integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *, real *, real *,
+ real *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVSP tests the driver routines SSPSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) REAL array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AFAC (workspace) REAL array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AINV (workspace) REAL array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* X (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(2,NRHS)) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "SP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+/* Computing MAX */
+ i__1 = *nmax << 1, i__2 = *nmax * *nrhs;
+ lwork = max(i__1,i__2);
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ npp = n * (n + 1) / 2;
+ *(unsigned char *)xtype = 'N';
+ nimat = 10;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L170;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L170;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ if (iuplo == 1) {
+ *(unsigned char *)uplo = 'U';
+ *(unsigned char *)packit = 'C';
+ } else {
+ *(unsigned char *)uplo = 'L';
+ *(unsigned char *)packit = 'R';
+ }
+
+/* Set up parameters with SLATB4 and generate a test matrix */
+/* with SLATMS. */
+
+ slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
+ slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
+ 1], &info);
+
+/* Check error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L160;
+ }
+
+/* For types 3-6, zero one or more rows and columns of the */
+/* matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * izero / 2;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff] = 0.f;
+ ioff += i__;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff] = 0.f;
+ ioff = ioff + n - i__;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ ioff = 0;
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L60: */
+ }
+ ioff += j;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L80: */
+ }
+ ioff = ioff + n - j;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+ for (ifact = 1; ifact <= 2; ++ifact) {
+
+/* Do first for FACT = 'F', then for other values. */
+
+ *(unsigned char *)fact = *(unsigned char *)&facts[ifact -
+ 1];
+
+/* Compute the condition number for comparison with */
+/* the value returned by SSPSVX. */
+
+ if (zerot) {
+ if (ifact == 1) {
+ goto L150;
+ }
+ rcondc = 0.f;
+
+ } else if (ifact == 1) {
+
+/* Compute the 1-norm of A. */
+
+ anorm = slansp_("1", uplo, &n, &a[1], &rwork[1]);
+
+/* Factor the matrix A. */
+
+ scopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ ssptrf_(uplo, &n, &afac[1], &iwork[1], &info);
+
+/* Compute inv(A) and take its norm. */
+
+ scopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
+ ssptri_(uplo, &n, &ainv[1], &iwork[1], &work[1], &
+ info);
+ ainvnm = slansp_("1", uplo, &n, &ainv[1], &rwork[1]);
+
+/* Compute the 1-norm condition number of A. */
+
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondc = 1.f;
+ } else {
+ rcondc = 1.f / anorm / ainvnm;
+ }
+ }
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, (ftnlen)6);
+ slarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, nrhs, &
+ a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
+ info);
+ *(unsigned char *)xtype = 'C';
+
+/* --- Test SSPSV --- */
+
+ if (ifact == 2) {
+ scopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
+
+/* Factor the matrix and solve the system using SSPSV. */
+
+ s_copy(srnamc_1.srnamt, "SSPSV ", (ftnlen)32, (ftnlen)
+ 6);
+ sspsv_(uplo, &n, nrhs, &afac[1], &iwork[1], &x[1], &
+ lda, &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from SSPSV . */
+
+ if (info != k) {
+ alaerh_(path, "SSPSV ", &info, &k, uplo, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L120;
+ } else if (info != 0) {
+ goto L120;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ sspt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &ainv[1]
+, &lda, &rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ sppt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[1],
+ &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "SSPSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+L120:
+ ;
+ }
+
+/* --- Test SSPSVX --- */
+
+ if (ifact == 2 && npp > 0) {
+ slaset_("Full", &npp, &c__1, &c_b59, &c_b59, &afac[1],
+ &npp);
+ }
+ slaset_("Full", &n, nrhs, &c_b59, &c_b59, &x[1], &lda);
+
+/* Solve the system and compute the condition number and */
+/* error bounds using SSPSVX. */
+
+ s_copy(srnamc_1.srnamt, "SSPSVX", (ftnlen)32, (ftnlen)6);
+ sspsvx_(fact, uplo, &n, nrhs, &a[1], &afac[1], &iwork[1],
+ &b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &
+ rwork[*nrhs + 1], &work[1], &iwork[n + 1], &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L130:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L130;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L130;
+ }
+ }
+
+/* Check the error code from SSPSVX. */
+
+ if (info != k) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "SSPSVX", &info, &k, ch__1, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L150;
+ }
+
+ if (info == 0) {
+ if (ifact >= 2) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ sspt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &
+ ainv[1], &lda, &rwork[(*nrhs << 1) + 1],
+ result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ sppt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[1],
+ &lda, &rwork[(*nrhs << 1) + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* Check the error bounds from iterative refinement. */
+
+ sppt05_(uplo, &n, nrhs, &a[1], &b[1], &lda, &x[1], &
+ lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs
+ + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from SSPSVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "SSPSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L140: */
+ }
+ nrun = nrun + 7 - k1;
+
+L150:
+ ;
+ }
+
+L160:
+ ;
+ }
+L170:
+ ;
+ }
+/* L180: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SDRVSP */
+
+} /* sdrvsp_ */
diff --git a/TESTING/LIN/sdrvsy.c b/TESTING/LIN/sdrvsy.c
new file mode 100644
index 0000000..5978688
--- /dev/null
+++ b/TESTING/LIN/sdrvsy.c
@@ -0,0 +1,672 @@
+/* sdrvsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static real c_b49 = 0.f;
+
+/* Subroutine */ int sdrvsy_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, real *thresh, logical *tsterr, integer *nmax, real *a,
+ real *afac, real *ainv, real *b, real *x, real *xact, real *work,
+ real *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char facts[1*2] = "F" "N";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002,"
+ " ratio =\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, k1, nb, in, kl, ku, nt, lda;
+ char fact[1];
+ integer ioff, mode, imat, info;
+ char path[3], dist[1], uplo[1], type__[1];
+ integer nrun, ifact, nfail, iseed[4], nbmin;
+ real rcond;
+ extern /* Subroutine */ int sget04_(integer *, integer *, real *, integer
+ *, real *, integer *, real *, real *);
+ integer nimat;
+ extern doublereal sget06_(real *, real *);
+ real anorm;
+ extern /* Subroutine */ int spot02_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, real *, real *);
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int spot05_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, real *, real *);
+ integer lwork;
+ logical zerot;
+ extern /* Subroutine */ int ssyt01_(char *, integer *, real *, integer *,
+ real *, integer *, integer *, real *, integer *, real *, real *);
+ char xtype[1];
+ extern /* Subroutine */ int ssysv_(char *, integer *, integer *, real *,
+ integer *, integer *, real *, integer *, real *, integer *,
+ integer *), slatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), aladhd_(integer *, char *),
+ alaerh_(char *, char *, integer *, integer *, char *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *);
+ real rcondc;
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ real cndnum, ainvnm;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, integer *, integer *), slaset_(
+ char *, integer *, integer *, real *, real *, real *, integer *), xlaenv_(integer *, integer *), slatms_(integer *,
+ integer *, char *, integer *, char *, real *, integer *, real *,
+ real *, integer *, integer *, char *, real *, integer *, real *,
+ integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+ real result[6];
+ extern /* Subroutine */ int serrvx_(char *, integer *), ssytrf_(
+ char *, integer *, real *, integer *, integer *, real *, integer *
+, integer *), ssytri_(char *, integer *, real *, integer *
+, integer *, real *, integer *), ssysvx_(char *, char *,
+ integer *, integer *, real *, integer *, real *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, real *,
+ real *, real *, integer *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SDRVSY tests the driver routines SSYSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) REAL array, dimension (NMAX*NMAX) */
+
+/* B (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* X (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
+
+/* WORK (workspace) REAL array, dimension */
+/* (NMAX*max(2,NRHS)) */
+
+/* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "SY", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+/* Computing MAX */
+ i__1 = *nmax << 1, i__2 = *nmax * *nrhs;
+ lwork = max(i__1,i__2);
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ serrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 10;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L170;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L170;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Set up parameters with SLATB4 and generate a test matrix */
+/* with SLATMS. */
+
+ slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
+ slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
+ &info);
+
+/* Check error code from SLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "SLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L160;
+ }
+
+/* For types 3-6, zero one or more rows and columns of the */
+/* matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * lda;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff] = 0.f;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ a[ioff] = 0.f;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L50: */
+ }
+ }
+ } else {
+ ioff = 0;
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L60: */
+ }
+ ioff += lda;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ a[ioff + i__] = 0.f;
+/* L80: */
+ }
+ ioff += lda;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+ for (ifact = 1; ifact <= 2; ++ifact) {
+
+/* Do first for FACT = 'F', then for other values. */
+
+ *(unsigned char *)fact = *(unsigned char *)&facts[ifact -
+ 1];
+
+/* Compute the condition number for comparison with */
+/* the value returned by SSYSVX. */
+
+ if (zerot) {
+ if (ifact == 1) {
+ goto L150;
+ }
+ rcondc = 0.f;
+
+ } else if (ifact == 1) {
+
+/* Compute the 1-norm of A. */
+
+ anorm = slansy_("1", uplo, &n, &a[1], &lda, &rwork[1]);
+
+/* Factor the matrix A. */
+
+ slacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ ssytrf_(uplo, &n, &afac[1], &lda, &iwork[1], &work[1],
+ &lwork, &info);
+
+/* Compute inv(A) and take its norm. */
+
+ slacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
+ ssytri_(uplo, &n, &ainv[1], &lda, &iwork[1], &work[1],
+ &info);
+ ainvnm = slansy_("1", uplo, &n, &ainv[1], &lda, &
+ rwork[1]);
+
+/* Compute the 1-norm condition number of A. */
+
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ rcondc = 1.f;
+ } else {
+ rcondc = 1.f / anorm / ainvnm;
+ }
+ }
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "SLARHS", (ftnlen)32, (ftnlen)6);
+ slarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, nrhs, &
+ a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
+ info);
+ *(unsigned char *)xtype = 'C';
+
+/* --- Test SSYSV --- */
+
+ if (ifact == 2) {
+ slacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
+
+/* Factor the matrix and solve the system using SSYSV. */
+
+ s_copy(srnamc_1.srnamt, "SSYSV ", (ftnlen)32, (ftnlen)
+ 6);
+ ssysv_(uplo, &n, nrhs, &afac[1], &lda, &iwork[1], &x[
+ 1], &lda, &work[1], &lwork, &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from SSYSV . */
+
+ if (info != k) {
+ alaerh_(path, "SSYSV ", &info, &k, uplo, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L120;
+ } else if (info != 0) {
+ goto L120;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ ssyt01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &iwork[
+ 1], &ainv[1], &lda, &rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ spot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda, &
+ work[1], &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "SSYSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+L120:
+ ;
+ }
+
+/* --- Test SSYSVX --- */
+
+ if (ifact == 2) {
+ slaset_(uplo, &n, &n, &c_b49, &c_b49, &afac[1], &lda);
+ }
+ slaset_("Full", &n, nrhs, &c_b49, &c_b49, &x[1], &lda);
+
+/* Solve the system and compute the condition number and */
+/* error bounds using SSYSVX. */
+
+ s_copy(srnamc_1.srnamt, "SSYSVX", (ftnlen)32, (ftnlen)6);
+ ssysvx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1], &lda,
+ &iwork[1], &b[1], &lda, &x[1], &lda, &rcond, &
+ rwork[1], &rwork[*nrhs + 1], &work[1], &lwork, &
+ iwork[n + 1], &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L130:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L130;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L130;
+ }
+ }
+
+/* Check the error code from SSYSVX. */
+
+ if (info != k) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "SSYSVX", &info, &k, ch__1, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L150;
+ }
+
+ if (info == 0) {
+ if (ifact >= 2) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ ssyt01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &ainv[1], &lda, &rwork[(*nrhs <<
+ 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ spot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda, &
+ work[1], &lda, &rwork[(*nrhs << 1) + 1], &
+ result[1]);
+
+/* Check solution from generated exact solution. */
+
+ sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* Check the error bounds from iterative refinement. */
+
+ spot05_(uplo, &n, nrhs, &a[1], &lda, &b[1], &lda, &x[
+ 1], &lda, &xact[1], &lda, &rwork[1], &rwork[*
+ nrhs + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from SSYSVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = sget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "SSYSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(real));
+ e_wsfe();
+ ++nfail;
+ }
+/* L140: */
+ }
+ nrun = nrun + 7 - k1;
+
+L150:
+ ;
+ }
+
+L160:
+ ;
+ }
+L170:
+ ;
+ }
+/* L180: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of SDRVSY */
+
+} /* sdrvsy_ */
diff --git a/TESTING/LIN/sebchvxx.c b/TESTING/LIN/sebchvxx.c
new file mode 100644
index 0000000..2f2d599
--- /dev/null
+++ b/TESTING/LIN/sebchvxx.c
@@ -0,0 +1,599 @@
+/* sebchvxx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__6 = 6;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c__5 = 5;
+static integer c__7 = 7;
+static integer c__8 = 8;
+
+/* Subroutine */ int sebchvxx_(real *thresh, char *path)
+{
+ /* Format strings */
+ static char fmt_8000[] = "(\002 S\002,a2,\002SVXX: N =\002,i2,\002, INFO"
+ " = \002,i3,\002, ORCOND = \002,g12.5,\002, real RCOND = \002,g12"
+ ".5)";
+ static char fmt_9996[] = "(3x,i2,\002: Normwise guaranteed forward erro"
+ "r\002,/5x,\002Guaranteed case: if norm ( abs( Xc - Xt )\002,\002"
+ " / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ), then\002,/5x"
+ ",\002ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS\002)"
+ ;
+ static char fmt_9995[] = "(3x,i2,\002: Componentwise guaranteed forward "
+ "error\002)";
+ static char fmt_9994[] = "(3x,i2,\002: Backwards error\002)";
+ static char fmt_9993[] = "(3x,i2,\002: Reciprocal condition number\002)";
+ static char fmt_9992[] = "(3x,i2,\002: Reciprocal normwise condition num"
+ "ber\002)";
+ static char fmt_9991[] = "(3x,i2,\002: Raw normwise error estimate\002)";
+ static char fmt_9990[] = "(3x,i2,\002: Reciprocal componentwise conditio"
+ "n number\002)";
+ static char fmt_9989[] = "(3x,i2,\002: Raw componentwise error estimat"
+ "e\002)";
+ static char fmt_9999[] = "(\002 S\002,a2,\002SVXX: N =\002,i2,\002, RHS "
+ "= \002,i2,\002, NWISE GUAR. = \002,a,\002, CWISE GUAR. = \002,a"
+ ",\002 test(\002,i1,\002) =\002,g12.5)";
+ static char fmt_9998[] = "(\002 S\002,a2,\002SVXX: \002,i6,\002 out of"
+ " \002,i6,\002 tests failed to pass the threshold\002)";
+ static char fmt_9997[] = "(\002 S\002,a2,\002SVXX passed the tests of er"
+ "ror bounds\002)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1, r__2, r__3;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
+ s_wsle(cilist *), e_wsle(void);
+
+ /* Local variables */
+ extern /* Subroutine */ int sposvxx_(char *, char *, integer *, integer *,
+ real *, integer *, real *, integer *, char *, real *, real *,
+ integer *, real *, integer *, real *, real *, real *, integer *,
+ real *, real *, integer *, real *, real *, integer *, integer *), ssysvxx_(char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *, char *
+, real *, real *, integer *, real *, integer *, real *, real *,
+ real *, integer *, real *, real *, integer *, real *, real *,
+ integer *, integer *);
+ real errbnd_c__[18], errbnd_n__[18], a[36] /* was [6][6] */, b[36] /*
+ was [6][6] */, c__[6];
+ integer i__, j, k;
+ real m;
+ integer n;
+ real r__[6], s[6], x[36] /* was [6][6] */, cwise_bnd__;
+ char c2[2];
+ real nwise_bnd__, cwise_err__, nwise_err__, errthresh, ab[66] /*
+ was [11][6] */, af[36] /* was [6][6] */;
+ integer kl, ku;
+ real condthresh, afb[96] /* was [16][6] */;
+ integer lda;
+ real eps, cwise_rcond__, nwise_rcond__;
+ integer n_aux_tests__, ldab;
+ real diff[36] /* was [6][6] */;
+ char fact[1];
+ real berr[6];
+ integer info, ipiv[6], nrhs;
+ real rinv[6];
+ char uplo[1];
+ real work[30], sumr;
+ integer ldafb;
+ real ccond;
+ integer nfail;
+ char cguar[3];
+ real ncond;
+ char equed[1];
+ real rcond, acopy[36] /* was [6][6] */;
+ char nguar[3], trans[1];
+ integer iwork[6];
+ real rnorm, normt, sumri;
+ logical printed_guide__;
+ extern doublereal slamch_(char *);
+ real abcopy[66] /* was [11][6] */;
+ extern logical lsamen_(integer *, char *, char *);
+ real params[2], orcond;
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+ real rinorm, tstrat[6], rpvgrw;
+ extern /* Subroutine */ int slahilb_(integer *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+);
+ real invhilb[36] /* was [6][6] */, normdif;
+ extern /* Subroutine */ int sgbsvxx_(char *, char *, integer *, integer *,
+ integer *, integer *, real *, integer *, real *, integer *,
+ integer *, char *, real *, real *, real *, integer *, real *,
+ integer *, real *, real *, real *, integer *, real *, real *,
+ integer *, real *, real *, integer *, integer *), sgesvxx_(char *, char *, integer *, integer *, real *,
+ integer *, real *, integer *, integer *, char *, real *, real *,
+ real *, integer *, real *, integer *, real *, real *, real *,
+ integer *, real *, real *, integer *, real *, real *, integer *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 6, 0, fmt_8000, 0 };
+ static cilist io___66 = { 0, 6, 0, 0, 0 };
+ static cilist io___67 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___68 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___69 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___70 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___71 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___72 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___73 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___74 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___75 = { 0, 6, 0, 0, 0 };
+ static cilist io___76 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___77 = { 0, 6, 0, 0, 0 };
+ static cilist io___78 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___79 = { 0, 6, 0, fmt_9997, 0 };
+
+
+/* .. Scalar Arguments .. */
+
+/* Purpose */
+/* ====== */
+
+/* SEBCHVXX will run S**SVXX on a series of Hilbert matrices and then */
+/* compare the error bounds returned by SGESVXX to see if the returned */
+/* answer indeed falls within those bounds. */
+
+/* Eight test ratios will be computed. The tests will pass if they are .LT. */
+/* THRESH. There are two cases that are determined by 1 / (SQRT( N ) * EPS). */
+/* If that value is .LE. to the component wise reciprocal condition number, */
+/* it uses the guaranteed case, other wise it uses the unguaranteed case. */
+
+/* Test ratios: */
+/* Let Xc be X_computed and Xt be X_truth. */
+/* The norm used is the infinity norm. */
+/* Let A be the guaranteed case and B be the unguaranteed case. */
+
+/* 1. Normwise guaranteed forward error bound. */
+/* A: norm ( abs( Xc - Xt ) / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ) and */
+/* ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N),10) * EPS. */
+/* If these conditions are met, the test ratio is set to be */
+/* ERRBND( *, nwise_i, bnd_i ) / MAX(SQRT(N), 10). Otherwise it is 1/EPS. */
+/* B: For this case, SGESVXX should just return 1. If it is less than */
+/* one, treat it the same as in 1A. Otherwise it fails. (Set test */
+/* ratio to ERRBND( *, nwise_i, bnd_i ) * THRESH?) */
+
+/* 2. Componentwise guaranteed forward error bound. */
+/* A: norm ( abs( Xc(j) - Xt(j) ) ) / norm (Xt(j)) .LE. ERRBND( *, cwise_i, bnd_i ) */
+/* for all j .AND. ERRBND( *, cwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS. */
+/* If these conditions are met, the test ratio is set to be */
+/* ERRBND( *, cwise_i, bnd_i ) / MAX(SQRT(N), 10). Otherwise it is 1/EPS. */
+/* B: Same as normwise test ratio. */
+
+/* 3. Backwards error. */
+/* A: The test ratio is set to BERR/EPS. */
+/* B: Same test ratio. */
+
+/* 4. Reciprocal condition number. */
+/* A: A condition number is computed with Xt and compared with the one */
+/* returned from SGESVXX. Let RCONDc be the RCOND returned by SGESVXX */
+/* and RCONDt be the RCOND from the truth value. Test ratio is set to */
+/* MAX(RCONDc/RCONDt, RCONDt/RCONDc). */
+/* B: Test ratio is set to 1 / (EPS * RCONDc). */
+
+/* 5. Reciprocal normwise condition number. */
+/* A: The test ratio is set to */
+/* MAX(ERRBND( *, nwise_i, cond_i ) / NCOND, NCOND / ERRBND( *, nwise_i, cond_i )). */
+/* B: Test ratio is set to 1 / (EPS * ERRBND( *, nwise_i, cond_i )). */
+
+/* 7. Reciprocal componentwise condition number. */
+/* A: Test ratio is set to */
+/* MAX(ERRBND( *, cwise_i, cond_i ) / CCOND, CCOND / ERRBND( *, cwise_i, cond_i )). */
+/* B: Test ratio is set to 1 / (EPS * ERRBND( *, cwise_i, cond_i )). */
+
+/* .. Parameters .. */
+/* NMAX is determined by the largest number in the inverse of the Hilbert */
+/* matrix. Precision is exhausted when the largest entry in it is greater */
+/* than 2 to the power of the number of bits in the fraction of the data */
+/* type used plus one, which is 24 for single precision. */
+/* NMAX should be 6 for single and 11 for double. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Parameters .. */
+/* Create the loop to test out the Hilbert matrices */
+ *(unsigned char *)fact = 'E';
+ *(unsigned char *)uplo = 'U';
+ *(unsigned char *)trans = 'N';
+ *(unsigned char *)equed = 'N';
+ eps = slamch_("Epsilon");
+ nfail = 0;
+ n_aux_tests__ = 0;
+ lda = 6;
+ ldab = 11;
+ ldafb = 16;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+/* Main loop to test the different Hilbert Matrices. */
+ printed_guide__ = FALSE_;
+ for (n = 1; n <= 6; ++n) {
+ params[0] = -1.f;
+ params[1] = -1.f;
+ kl = n - 1;
+ ku = n - 1;
+ nrhs = n;
+/* Computing MAX */
+ r__1 = sqrt((real) n);
+ m = dmax(r__1,10.f);
+/* Generate the Hilbert matrix, its inverse, and the */
+/* right hand side, all scaled by the LCM(1,..,2N-1). */
+ slahilb_(&n, &n, a, &lda, invhilb, &lda, b, &lda, work, &info);
+/* Copy A into ACOPY. */
+ slacpy_("ALL", &n, &n, a, &c__6, acopy, &c__6);
+/* Store A in band format for GB tests */
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = kl + ku + 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ab[i__ + j * 11 - 12] = 0.f;
+ }
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = 1, i__3 = j - ku;
+/* Computing MIN */
+ i__5 = n, i__6 = j + kl;
+ i__4 = min(i__5,i__6);
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ ab[ku + 1 + i__ - j + j * 11 - 12] = a[i__ + j * 6 - 7];
+ }
+ }
+/* Copy AB into ABCOPY. */
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = kl + ku + 1;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ abcopy[i__ + j * 11 - 12] = 0.f;
+ }
+ }
+ i__1 = kl + ku + 1;
+ slacpy_("ALL", &i__1, &n, ab, &ldab, abcopy, &ldab);
+/* Call S**SVXX with default PARAMS and N_ERR_BND = 3. */
+ if (lsamen_(&c__2, c2, "SY")) {
+ ssysvxx_(fact, uplo, &n, &nrhs, acopy, &lda, af, &lda, ipiv,
+ equed, s, b, &lda, x, &lda, &orcond, &rpvgrw, berr, &c__3,
+ errbnd_n__, errbnd_c__, &c__2, params, work, iwork, &
+ info);
+ } else if (lsamen_(&c__2, c2, "PO")) {
+ sposvxx_(fact, uplo, &n, &nrhs, acopy, &lda, af, &lda, equed, s,
+ b, &lda, x, &lda, &orcond, &rpvgrw, berr, &c__3,
+ errbnd_n__, errbnd_c__, &c__2, params, work, iwork, &info);
+ } else if (lsamen_(&c__2, c2, "GB")) {
+ sgbsvxx_(fact, trans, &n, &kl, &ku, &nrhs, abcopy, &ldab, afb, &
+ ldafb, ipiv, equed, r__, c__, b, &lda, x, &lda, &orcond, &
+ rpvgrw, berr, &c__3, errbnd_n__, errbnd_c__, &c__2,
+ params, work, iwork, &info);
+ } else {
+ sgesvxx_(fact, trans, &n, &nrhs, acopy, &lda, af, &lda, ipiv,
+ equed, r__, c__, b, &lda, x, &lda, &orcond, &rpvgrw, berr,
+ &c__3, errbnd_n__, errbnd_c__, &c__2, params, work,
+ iwork, &info);
+ }
+ ++n_aux_tests__;
+ if (orcond < eps) {
+/* Either factorization failed or the matrix is flagged, and 1 <= */
+/* INFO <= N+1. We don't decide based on rcond anymore. */
+/* IF (INFO .EQ. 0 .OR. INFO .GT. N+1) THEN */
+/* NFAIL = NFAIL + 1 */
+/* WRITE (*, FMT=8000) N, INFO, ORCOND, RCOND */
+/* END IF */
+ } else {
+/* Either everything succeeded (INFO == 0) or some solution failed */
+/* to converge (INFO > N+1). */
+ if (info > 0 && info <= n + 1) {
+ ++nfail;
+ s_wsfe(&io___42);
+ do_fio(&c__1, c2, (ftnlen)2);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&orcond, (ftnlen)sizeof(real));
+ do_fio(&c__1, (char *)&rcond, (ftnlen)sizeof(real));
+ e_wsfe();
+ }
+ }
+/* Calculating the difference between S**SVXX's X and the true X. */
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__4 = nrhs;
+ for (j = 1; j <= i__4; ++j) {
+ diff[i__ + j * 6 - 7] = x[i__ + j * 6 - 7] - invhilb[i__ + j *
+ 6 - 7];
+ }
+ }
+/* Calculating the RCOND */
+ rnorm = 0.f;
+ rinorm = 0.f;
+ if (lsamen_(&c__2, c2, "PO") || lsamen_(&c__2,
+ c2, "SY")) {
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sumr = 0.f;
+ sumri = 0.f;
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ sumr += (r__1 = s[i__ - 1] * a[i__ + j * 6 - 7] * s[j - 1]
+ , dabs(r__1));
+ sumri += (r__1 = invhilb[i__ + j * 6 - 7] / s[j - 1] / s[
+ i__ - 1], dabs(r__1));
+ }
+ rnorm = dmax(rnorm,sumr);
+ rinorm = dmax(rinorm,sumri);
+ }
+ } else if (lsamen_(&c__2, c2, "GE") || lsamen_(&
+ c__2, c2, "GB")) {
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sumr = 0.f;
+ sumri = 0.f;
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ sumr += (r__1 = r__[i__ - 1] * a[i__ + j * 6 - 7] * c__[j
+ - 1], dabs(r__1));
+ sumri += (r__1 = invhilb[i__ + j * 6 - 7] / r__[j - 1] /
+ c__[i__ - 1], dabs(r__1));
+ }
+ rnorm = dmax(rnorm,sumr);
+ rinorm = dmax(rinorm,sumri);
+ }
+ }
+ rnorm /= a[0];
+ rcond = 1.f / (rnorm * rinorm);
+/* Calculating the R for normwise rcond. */
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ rinv[i__ - 1] = 0.f;
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ rinv[i__ - 1] += (r__1 = a[i__ + j * 6 - 7], dabs(r__1));
+ }
+ }
+/* Calculating the Normwise rcond. */
+ rinorm = 0.f;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sumri = 0.f;
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ sumri += (r__1 = invhilb[i__ + j * 6 - 7] * rinv[j - 1], dabs(
+ r__1));
+ }
+ rinorm = dmax(rinorm,sumri);
+ }
+/* invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm */
+/* by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix) */
+ ncond = a[0] / rinorm;
+ condthresh = m * eps;
+ errthresh = m * eps;
+ i__1 = nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ normt = 0.f;
+ normdif = 0.f;
+ cwise_err__ = 0.f;
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+/* Computing MAX */
+ r__2 = (r__1 = invhilb[i__ + k * 6 - 7], dabs(r__1));
+ normt = dmax(r__2,normt);
+/* Computing MAX */
+ r__2 = (r__1 = x[i__ + k * 6 - 7] - invhilb[i__ + k * 6 - 7],
+ dabs(r__1));
+ normdif = dmax(r__2,normdif);
+ if (invhilb[i__ + k * 6 - 7] != 0.f) {
+/* Computing MAX */
+ r__3 = (r__1 = x[i__ + k * 6 - 7] - invhilb[i__ + k * 6 -
+ 7], dabs(r__1)) / (r__2 = invhilb[i__ + k * 6 - 7]
+ , dabs(r__2));
+ cwise_err__ = dmax(r__3,cwise_err__);
+ } else if (x[i__ + k * 6 - 7] != 0.f) {
+ cwise_err__ = slamch_("OVERFLOW");
+ }
+ }
+ if (normt != 0.f) {
+ nwise_err__ = normdif / normt;
+ } else if (normdif != 0.f) {
+ nwise_err__ = slamch_("OVERFLOW");
+ } else {
+ nwise_err__ = 0.f;
+ }
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ rinv[i__ - 1] = 0.f;
+ }
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ rinv[i__ - 1] += (r__1 = a[i__ + j * 6 - 7] * invhilb[j +
+ k * 6 - 7], dabs(r__1));
+ }
+ }
+ rinorm = 0.f;
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ sumri = 0.f;
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ sumri += (r__1 = invhilb[i__ + j * 6 - 7] * rinv[j - 1] /
+ invhilb[i__ + k * 6 - 7], dabs(r__1));
+ }
+ rinorm = dmax(rinorm,sumri);
+ }
+/* invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm */
+/* by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix) */
+ ccond = a[0] / rinorm;
+/* Forward error bound tests */
+ nwise_bnd__ = errbnd_n__[k + nrhs - 1];
+ cwise_bnd__ = errbnd_c__[k + nrhs - 1];
+ nwise_rcond__ = errbnd_n__[k + (nrhs << 1) - 1];
+ cwise_rcond__ = errbnd_c__[k + (nrhs << 1) - 1];
+/* write (*,*) 'nwise : ', n, k, ncond, nwise_rcond, */
+/* $ condthresh, ncond.ge.condthresh */
+/* write (*,*) 'nwise2: ', k, nwise_bnd, nwise_err, errthresh */
+ if (ncond >= condthresh) {
+ s_copy(nguar, "YES", (ftnlen)3, (ftnlen)3);
+ if (nwise_bnd__ > errthresh) {
+ tstrat[0] = 1 / (eps * 2.f);
+ } else {
+ if (nwise_bnd__ != 0.f) {
+ tstrat[0] = nwise_err__ / nwise_bnd__;
+ } else if (nwise_err__ != 0.f) {
+ tstrat[0] = 1 / (eps * 16.f);
+ } else {
+ tstrat[0] = 0.f;
+ }
+ if (tstrat[0] > 1.f) {
+ tstrat[0] = 1 / (eps * 4.f);
+ }
+ }
+ } else {
+ s_copy(nguar, "NO", (ftnlen)3, (ftnlen)2);
+ if (nwise_bnd__ < 1.f) {
+ tstrat[0] = 1 / (eps * 8.f);
+ } else {
+ tstrat[0] = 1.f;
+ }
+ }
+/* write (*,*) 'cwise : ', n, k, ccond, cwise_rcond, */
+/* $ condthresh, ccond.ge.condthresh */
+/* write (*,*) 'cwise2: ', k, cwise_bnd, cwise_err, errthresh */
+ if (ccond >= condthresh) {
+ s_copy(cguar, "YES", (ftnlen)3, (ftnlen)3);
+ if (cwise_bnd__ > errthresh) {
+ tstrat[1] = 1 / (eps * 2.f);
+ } else {
+ if (cwise_bnd__ != 0.f) {
+ tstrat[1] = cwise_err__ / cwise_bnd__;
+ } else if (cwise_err__ != 0.f) {
+ tstrat[1] = 1 / (eps * 16.f);
+ } else {
+ tstrat[1] = 0.f;
+ }
+ if (tstrat[1] > 1.f) {
+ tstrat[1] = 1 / (eps * 4.f);
+ }
+ }
+ } else {
+ s_copy(cguar, "NO", (ftnlen)3, (ftnlen)2);
+ if (cwise_bnd__ < 1.f) {
+ tstrat[1] = 1 / (eps * 8.f);
+ } else {
+ tstrat[1] = 1.f;
+ }
+ }
+/* Backwards error test */
+ tstrat[2] = berr[k - 1] / eps;
+/* Condition number tests */
+ tstrat[3] = rcond / orcond;
+ if (rcond >= condthresh && tstrat[3] < 1.f) {
+ tstrat[3] = 1.f / tstrat[3];
+ }
+ tstrat[4] = ncond / nwise_rcond__;
+ if (ncond >= condthresh && tstrat[4] < 1.f) {
+ tstrat[4] = 1.f / tstrat[4];
+ }
+ tstrat[5] = ccond / nwise_rcond__;
+ if (ccond >= condthresh && tstrat[5] < 1.f) {
+ tstrat[5] = 1.f / tstrat[5];
+ }
+ for (i__ = 1; i__ <= 6; ++i__) {
+ if (tstrat[i__ - 1] > *thresh) {
+ if (! printed_guide__) {
+ s_wsle(&io___66);
+ e_wsle();
+ s_wsfe(&io___67);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___68);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___69);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___70);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___71);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___72);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___73);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___74);
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsle(&io___75);
+ e_wsle();
+ printed_guide__ = TRUE_;
+ }
+ s_wsfe(&io___76);
+ do_fio(&c__1, c2, (ftnlen)2);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, nguar, (ftnlen)3);
+ do_fio(&c__1, cguar, (ftnlen)3);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&tstrat[i__ - 1], (ftnlen)sizeof(
+ real));
+ e_wsfe();
+ ++nfail;
+ }
+ }
+ }
+/* $$$ WRITE(*,*) */
+/* $$$ WRITE(*,*) 'Normwise Error Bounds' */
+/* $$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,nwise_i,bnd_i) */
+/* $$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,nwise_i,cond_i) */
+/* $$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,nwise_i,rawbnd_i) */
+/* $$$ WRITE(*,*) */
+/* $$$ WRITE(*,*) 'Componentwise Error Bounds' */
+/* $$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,cwise_i,bnd_i) */
+/* $$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,cwise_i,cond_i) */
+/* $$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,cwise_i,rawbnd_i) */
+/* $$$ print *, 'Info: ', info */
+/* $$$ WRITE(*,*) */
+/* WRITE(*,*) 'TSTRAT: ',TSTRAT */
+ }
+ s_wsle(&io___77);
+ e_wsle();
+ if (nfail > 0) {
+ s_wsfe(&io___78);
+ do_fio(&c__1, c2, (ftnlen)2);
+ do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
+ i__1 = n * 6 + n_aux_tests__;
+ do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ s_wsfe(&io___79);
+ do_fio(&c__1, c2, (ftnlen)2);
+ e_wsfe();
+ }
+/* Test ratios. */
+ return 0;
+} /* sebchvxx_ */
diff --git a/TESTING/LIN/serrge.c b/TESTING/LIN/serrge.c
new file mode 100644
index 0000000..05b8118
--- /dev/null
+++ b/TESTING/LIN/serrge.c
@@ -0,0 +1,508 @@
+/* serrge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__12 = 12;
+static integer c__3 = 3;
+static integer c__4 = 4;
+
+/* Subroutine */ int serrge_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real a[16] /* was [4][4] */, b[4];
+ integer i__, j;
+ real w[12], x[4];
+ char c2[2];
+ real r1[4], r2[4], af[16] /* was [4][4] */;
+ integer ip[4], iw[4], info;
+ real anrm, ccond, rcond;
+ extern /* Subroutine */ int sgbtf2_(integer *, integer *, integer *,
+ integer *, real *, integer *, integer *, integer *), sgetf2_(
+ integer *, integer *, real *, integer *, integer *, integer *),
+ alaesm_(char *, logical *, integer *), sgbcon_(char *,
+ integer *, integer *, integer *, real *, integer *, integer *,
+ real *, real *, real *, integer *, integer *), sgecon_(
+ char *, integer *, real *, integer *, real *, real *, real *,
+ integer *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), sgbequ_(integer *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ real *, integer *), sgbrfs_(char *, integer *, integer *, integer
+ *, integer *, real *, integer *, real *, integer *, integer *,
+ real *, integer *, real *, integer *, real *, real *, real *,
+ integer *, integer *), sgbtrf_(integer *, integer *,
+ integer *, integer *, real *, integer *, integer *, integer *),
+ sgeequ_(integer *, integer *, real *, integer *, real *, real *,
+ real *, real *, real *, integer *), sgerfs_(char *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *, real *
+, integer *, real *, integer *, real *, real *, real *, integer *,
+ integer *), sgetrf_(integer *, integer *, real *,
+ integer *, integer *, integer *), sgetri_(integer *, real *,
+ integer *, integer *, real *, integer *, integer *), sgbtrs_(char
+ *, integer *, integer *, integer *, integer *, real *, integer *,
+ integer *, real *, integer *, integer *), sgetrs_(char *,
+ integer *, integer *, real *, integer *, integer *, real *,
+ integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SERRGE tests the error exits for the REAL routines */
+/* for general matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (j << 2) - 5] = 1.f / (real) (i__ + j);
+ af[i__ + (j << 2) - 5] = 1.f / (real) (i__ + j);
+/* L10: */
+ }
+ b[j - 1] = 0.f;
+ r1[j - 1] = 0.f;
+ r2[j - 1] = 0.f;
+ w[j - 1] = 0.f;
+ x[j - 1] = 0.f;
+ ip[j - 1] = j;
+ iw[j - 1] = j;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "GE")) {
+
+/* Test error exits of the routines that use the LU decomposition */
+/* of a general matrix. */
+
+/* SGETRF */
+
+ s_copy(srnamc_1.srnamt, "SGETRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgetrf_(&c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("SGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgetrf_(&c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("SGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgetrf_(&c__2, &c__1, a, &c__1, ip, &info);
+ chkxer_("SGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGETF2 */
+
+ s_copy(srnamc_1.srnamt, "SGETF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgetf2_(&c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("SGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgetf2_(&c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("SGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgetf2_(&c__2, &c__1, a, &c__1, ip, &info);
+ chkxer_("SGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGETRI */
+
+ s_copy(srnamc_1.srnamt, "SGETRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgetri_(&c_n1, a, &c__1, ip, w, &c__12, &info);
+ chkxer_("SGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgetri_(&c__2, a, &c__1, ip, w, &c__12, &info);
+ chkxer_("SGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGETRS */
+
+ s_copy(srnamc_1.srnamt, "SGETRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgetrs_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("SGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgetrs_("N", &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("SGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgetrs_("N", &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("SGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgetrs_("N", &c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
+ chkxer_("SGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sgetrs_("N", &c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
+ chkxer_("SGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGERFS */
+
+ s_copy(srnamc_1.srnamt, "SGERFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgerfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("SGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgerfs_("N", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("SGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgerfs_("N", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("SGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgerfs_("N", &c__2, &c__1, a, &c__1, af, &c__2, ip, b, &c__2, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("SGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__1, ip, b, &c__2, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("SGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__1, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("SGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__2, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("SGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGECON */
+
+ s_copy(srnamc_1.srnamt, "SGECON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgecon_("/", &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("SGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgecon_("1", &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("SGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgecon_("1", &c__2, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("SGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGEEQU */
+
+ s_copy(srnamc_1.srnamt, "SGEEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgeequ_(&c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("SGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgeequ_(&c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("SGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgeequ_(&c__2, &c__2, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("SGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* Test error exits of the routines that use the LU decomposition */
+/* of a general band matrix. */
+
+/* SGBTRF */
+
+ s_copy(srnamc_1.srnamt, "SGBTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgbtrf_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("SGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgbtrf_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("SGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgbtrf_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("SGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgbtrf_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("SGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sgbtrf_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
+ chkxer_("SGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGBTF2 */
+
+ s_copy(srnamc_1.srnamt, "SGBTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgbtf2_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("SGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgbtf2_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("SGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgbtf2_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("SGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgbtf2_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("SGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sgbtf2_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
+ chkxer_("SGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGBTRS */
+
+ s_copy(srnamc_1.srnamt, "SGBTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgbtrs_("/", &c__0, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("SGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgbtrs_("N", &c_n1, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("SGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgbtrs_("N", &c__1, &c_n1, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("SGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgbtrs_("N", &c__1, &c__0, &c_n1, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("SGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgbtrs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("SGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sgbtrs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, ip, b, &c__2, &
+ info);
+ chkxer_("SGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sgbtrs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("SGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGBRFS */
+
+ s_copy(srnamc_1.srnamt, "SGBRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgbrfs_("/", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("SGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgbrfs_("N", &c_n1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("SGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgbrfs_("N", &c__1, &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("SGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgbrfs_("N", &c__1, &c__0, &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("SGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgbrfs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("SGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__2, af, &c__4, ip, b, &
+ c__2, x, &c__2, r1, r2, w, iw, &info);
+ chkxer_("SGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__3, ip, b, &
+ c__2, x, &c__2, r1, r2, w, iw, &info);
+ chkxer_("SGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__2, r1, r2, w, iw, &info);
+ chkxer_("SGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ sgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
+ c__2, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("SGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGBCON */
+
+ s_copy(srnamc_1.srnamt, "SGBCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgbcon_("/", &c__0, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, iw,
+ &info);
+ chkxer_("SGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgbcon_("1", &c_n1, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, iw,
+ &info);
+ chkxer_("SGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgbcon_("1", &c__1, &c_n1, &c__0, a, &c__1, ip, &anrm, &rcond, w, iw,
+ &info);
+ chkxer_("SGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgbcon_("1", &c__1, &c__0, &c_n1, a, &c__1, ip, &anrm, &rcond, w, iw,
+ &info);
+ chkxer_("SGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sgbcon_("1", &c__2, &c__1, &c__1, a, &c__3, ip, &anrm, &rcond, w, iw,
+ &info);
+ chkxer_("SGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGBEQU */
+
+ s_copy(srnamc_1.srnamt, "SGBEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgbequ_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("SGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgbequ_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("SGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgbequ_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("SGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgbequ_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("SGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sgbequ_(&c__2, &c__2, &c__1, &c__1, a, &c__2, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("SGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of SERRGE */
+
+} /* serrge_ */
diff --git a/TESTING/LIN/serrgex.c b/TESTING/LIN/serrgex.c
new file mode 100644
index 0000000..1d861cb
--- /dev/null
+++ b/TESTING/LIN/serrgex.c
@@ -0,0 +1,709 @@
+/* serrgex.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__12 = 12;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static integer c__5 = 5;
+
+/* Subroutine */ int serrge_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real a[16] /* was [4][4] */, b[4], c__[4];
+ integer i__, j;
+ real r__[4], w[12], x[4];
+ char c2[2];
+ real r1[4], r2[4], af[16] /* was [4][4] */;
+ char eq[1];
+ integer ip[4], iw[4];
+ real err_bnds_c__[12] /* was [4][3] */;
+ integer n_err_bnds__;
+ real err_bnds_n__[12] /* was [4][3] */, berr;
+ integer info;
+ real anrm, ccond, rcond;
+ extern /* Subroutine */ int sgbtf2_(integer *, integer *, integer *,
+ integer *, real *, integer *, integer *, integer *), sgetf2_(
+ integer *, integer *, real *, integer *, integer *, integer *),
+ alaesm_(char *, logical *, integer *), sgbcon_(char *,
+ integer *, integer *, integer *, real *, integer *, integer *,
+ real *, real *, real *, integer *, integer *), sgecon_(
+ char *, integer *, real *, integer *, real *, real *, real *,
+ integer *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ real params[1];
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), sgbequ_(integer *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ real *, integer *), sgbrfs_(char *, integer *, integer *, integer
+ *, integer *, real *, integer *, real *, integer *, integer *,
+ real *, integer *, real *, integer *, real *, real *, real *,
+ integer *, integer *), sgbtrf_(integer *, integer *,
+ integer *, integer *, real *, integer *, integer *, integer *),
+ sgeequ_(integer *, integer *, real *, integer *, real *, real *,
+ real *, real *, real *, integer *), sgerfs_(char *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *, real *
+, integer *, real *, integer *, real *, real *, real *, integer *,
+ integer *), sgetrf_(integer *, integer *, real *,
+ integer *, integer *, integer *), sgetri_(integer *, real *,
+ integer *, integer *, real *, integer *, integer *), sgbtrs_(char
+ *, integer *, integer *, integer *, integer *, real *, integer *,
+ integer *, real *, integer *, integer *), sgetrs_(char *,
+ integer *, integer *, real *, integer *, integer *, real *,
+ integer *, integer *), sgbequb_(integer *, integer *,
+ integer *, integer *, real *, integer *, real *, real *, real *,
+ real *, real *, integer *), sgeequb_(integer *, integer *, real *,
+ integer *, real *, real *, real *, real *, real *, integer *);
+ integer nparams;
+ extern /* Subroutine */ int sgbrfsx_(char *, char *, integer *, integer *,
+ integer *, integer *, real *, integer *, real *, integer *,
+ integer *, real *, real *, real *, integer *, real *, integer *,
+ real *, real *, integer *, real *, real *, integer *, real *,
+ real *, integer *, integer *), sgerfsx_(char *,
+ char *, integer *, integer *, real *, integer *, real *, integer *
+, integer *, real *, real *, real *, integer *, real *, integer *,
+ real *, real *, integer *, real *, real *, integer *, real *,
+ real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SERRGE tests the error exits for the REAL routines */
+/* for general matrices. */
+
+/* Note that this file is used only when the XBLAS are available, */
+/* otherwise serrge.f defines this subroutine. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (j << 2) - 5] = 1.f / (real) (i__ + j);
+ af[i__ + (j << 2) - 5] = 1.f / (real) (i__ + j);
+/* L10: */
+ }
+ b[j - 1] = 0.f;
+ r1[j - 1] = 0.f;
+ r2[j - 1] = 0.f;
+ w[j - 1] = 0.f;
+ x[j - 1] = 0.f;
+ c__[j - 1] = 0.f;
+ r__[j - 1] = 0.f;
+ ip[j - 1] = j;
+ iw[j - 1] = j;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "GE")) {
+
+/* Test error exits of the routines that use the LU decomposition */
+/* of a general matrix. */
+
+/* SGETRF */
+
+ s_copy(srnamc_1.srnamt, "SGETRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgetrf_(&c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("SGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgetrf_(&c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("SGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgetrf_(&c__2, &c__1, a, &c__1, ip, &info);
+ chkxer_("SGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGETF2 */
+
+ s_copy(srnamc_1.srnamt, "SGETF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgetf2_(&c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("SGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgetf2_(&c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("SGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgetf2_(&c__2, &c__1, a, &c__1, ip, &info);
+ chkxer_("SGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGETRI */
+
+ s_copy(srnamc_1.srnamt, "SGETRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgetri_(&c_n1, a, &c__1, ip, w, &c__12, &info);
+ chkxer_("SGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgetri_(&c__2, a, &c__1, ip, w, &c__12, &info);
+ chkxer_("SGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGETRS */
+
+ s_copy(srnamc_1.srnamt, "SGETRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgetrs_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("SGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgetrs_("N", &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("SGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgetrs_("N", &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("SGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgetrs_("N", &c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
+ chkxer_("SGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sgetrs_("N", &c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
+ chkxer_("SGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGERFS */
+
+ s_copy(srnamc_1.srnamt, "SGERFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgerfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("SGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgerfs_("N", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("SGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgerfs_("N", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("SGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgerfs_("N", &c__2, &c__1, a, &c__1, af, &c__2, ip, b, &c__2, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("SGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__1, ip, b, &c__2, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("SGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__1, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("SGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__2, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("SGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGERFSX */
+
+ n_err_bnds__ = 3;
+ nparams = 0;
+ s_copy(srnamc_1.srnamt, "SGERFSX", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ sgerfsx_("/", eq, &c__0, &c__0, a, &c__1, af, &c__1, ip, r__, c__, b,
+ &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("SGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ *(unsigned char *)eq = '/';
+ sgerfsx_("N", eq, &c__2, &c__1, a, &c__1, af, &c__2, ip, r__, c__, b,
+ &c__2, x, &c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("SGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ *(unsigned char *)eq = 'R';
+ sgerfsx_("N", eq, &c_n1, &c__0, a, &c__1, af, &c__1, ip, r__, c__, b,
+ &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("SGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgerfsx_("N", eq, &c__0, &c_n1, a, &c__1, af, &c__1, ip, r__, c__, b,
+ &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("SGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sgerfsx_("N", eq, &c__2, &c__1, a, &c__1, af, &c__2, ip, r__, c__, b,
+ &c__2, x, &c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("SGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sgerfsx_("N", eq, &c__2, &c__1, a, &c__2, af, &c__1, ip, r__, c__, b,
+ &c__2, x, &c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("SGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ *(unsigned char *)eq = 'C';
+ sgerfsx_("N", eq, &c__2, &c__1, a, &c__2, af, &c__2, ip, r__, c__, b,
+ &c__1, x, &c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("SGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ sgerfsx_("N", eq, &c__2, &c__1, a, &c__2, af, &c__2, ip, r__, c__, b,
+ &c__2, x, &c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("SGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGECON */
+
+ s_copy(srnamc_1.srnamt, "SGECON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgecon_("/", &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("SGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgecon_("1", &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("SGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgecon_("1", &c__2, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("SGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGEEQU */
+
+ s_copy(srnamc_1.srnamt, "SGEEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgeequ_(&c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("SGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgeequ_(&c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("SGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgeequ_(&c__2, &c__2, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("SGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGEEQUB */
+
+ s_copy(srnamc_1.srnamt, "SGEEQUB", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ sgeequb_(&c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info)
+ ;
+ chkxer_("SGEEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgeequb_(&c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info)
+ ;
+ chkxer_("SGEEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgeequb_(&c__2, &c__2, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info)
+ ;
+ chkxer_("SGEEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* Test error exits of the routines that use the LU decomposition */
+/* of a general band matrix. */
+
+/* SGBTRF */
+
+ s_copy(srnamc_1.srnamt, "SGBTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgbtrf_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("SGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgbtrf_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("SGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgbtrf_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("SGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgbtrf_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("SGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sgbtrf_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
+ chkxer_("SGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGBTF2 */
+
+ s_copy(srnamc_1.srnamt, "SGBTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgbtf2_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("SGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgbtf2_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("SGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgbtf2_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("SGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgbtf2_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("SGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sgbtf2_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
+ chkxer_("SGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGBTRS */
+
+ s_copy(srnamc_1.srnamt, "SGBTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgbtrs_("/", &c__0, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("SGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgbtrs_("N", &c_n1, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("SGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgbtrs_("N", &c__1, &c_n1, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("SGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgbtrs_("N", &c__1, &c__0, &c_n1, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("SGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgbtrs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("SGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sgbtrs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, ip, b, &c__2, &
+ info);
+ chkxer_("SGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sgbtrs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("SGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGBRFS */
+
+ s_copy(srnamc_1.srnamt, "SGBRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgbrfs_("/", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("SGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgbrfs_("N", &c_n1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("SGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgbrfs_("N", &c__1, &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("SGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgbrfs_("N", &c__1, &c__0, &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("SGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgbrfs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("SGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__2, af, &c__4, ip, b, &
+ c__2, x, &c__2, r1, r2, w, iw, &info);
+ chkxer_("SGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__3, ip, b, &
+ c__2, x, &c__2, r1, r2, w, iw, &info);
+ chkxer_("SGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__2, r1, r2, w, iw, &info);
+ chkxer_("SGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ sgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
+ c__2, x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("SGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGBRFSX */
+
+ n_err_bnds__ = 3;
+ nparams = 0;
+ s_copy(srnamc_1.srnamt, "SGBRFSX", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ sgbrfsx_("/", eq, &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ r__, c__, b, &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("SGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ *(unsigned char *)eq = '/';
+ sgbrfsx_("N", eq, &c__2, &c__1, &c__1, &c__1, a, &c__1, af, &c__2, ip,
+ r__, c__, b, &c__2, x, &c__2, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("SGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ *(unsigned char *)eq = 'R';
+ sgbrfsx_("N", eq, &c_n1, &c__1, &c__1, &c__0, a, &c__1, af, &c__1, ip,
+ r__, c__, b, &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("SGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ *(unsigned char *)eq = 'R';
+ sgbrfsx_("N", eq, &c__2, &c_n1, &c__1, &c__1, a, &c__3, af, &c__4, ip,
+ r__, c__, b, &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("SGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ *(unsigned char *)eq = 'R';
+ sgbrfsx_("N", eq, &c__2, &c__1, &c_n1, &c__1, a, &c__3, af, &c__4, ip,
+ r__, c__, b, &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("SGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sgbrfsx_("N", eq, &c__0, &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, ip,
+ r__, c__, b, &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("SGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sgbrfsx_("N", eq, &c__2, &c__1, &c__1, &c__1, a, &c__1, af, &c__2, ip,
+ r__, c__, b, &c__2, x, &c__2, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("SGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sgbrfsx_("N", eq, &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__3, ip,
+ r__, c__, b, &c__2, x, &c__2, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("SGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ *(unsigned char *)eq = 'C';
+ sgbrfsx_("N", eq, &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__5, ip,
+ r__, c__, b, &c__1, x, &c__2, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("SGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ sgbrfsx_("N", eq, &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__5, ip,
+ r__, c__, b, &c__2, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, params, w, iw, &info);
+ chkxer_("SGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGBCON */
+
+ s_copy(srnamc_1.srnamt, "SGBCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgbcon_("/", &c__0, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, iw,
+ &info);
+ chkxer_("SGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgbcon_("1", &c_n1, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, iw,
+ &info);
+ chkxer_("SGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgbcon_("1", &c__1, &c_n1, &c__0, a, &c__1, ip, &anrm, &rcond, w, iw,
+ &info);
+ chkxer_("SGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgbcon_("1", &c__1, &c__0, &c_n1, a, &c__1, ip, &anrm, &rcond, w, iw,
+ &info);
+ chkxer_("SGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sgbcon_("1", &c__2, &c__1, &c__1, a, &c__3, ip, &anrm, &rcond, w, iw,
+ &info);
+ chkxer_("SGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGBEQU */
+
+ s_copy(srnamc_1.srnamt, "SGBEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgbequ_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("SGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgbequ_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("SGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgbequ_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("SGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgbequ_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("SGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sgbequ_(&c__2, &c__2, &c__1, &c__1, a, &c__2, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("SGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGBEQUB */
+
+ s_copy(srnamc_1.srnamt, "SGBEQUB", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ sgbequb_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("SGBEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgbequb_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("SGBEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgbequb_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("SGBEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgbequb_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("SGBEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sgbequb_(&c__2, &c__2, &c__1, &c__1, a, &c__2, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("SGBEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of SERRGE */
+
+} /* serrge_ */
diff --git a/TESTING/LIN/serrgt.c b/TESTING/LIN/serrgt.c
new file mode 100644
index 0000000..01ec612
--- /dev/null
+++ b/TESTING/LIN/serrgt.c
@@ -0,0 +1,285 @@
+/* serrgt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int serrgt_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ real r__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real b[2], c__[2], d__[2], e[2], f[2], w[2], x[2];
+ char c2[2];
+ real r1[2], r2[2], cf[2], df[2], ef[2];
+ integer ip[2], iw[2], info;
+ real rcond, anorm;
+ extern /* Subroutine */ int alaesm_(char *, logical *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), sgtcon_(char *, integer *, real *, real *,
+ real *, real *, integer *, real *, real *, real *, integer *,
+ integer *), sptcon_(integer *, real *, real *, real *,
+ real *, real *, integer *), sgtrfs_(char *, integer *, integer *,
+ real *, real *, real *, real *, real *, real *, real *, integer *,
+ real *, integer *, real *, integer *, real *, real *, real *,
+ integer *, integer *), sgttrf_(integer *, real *, real *,
+ real *, real *, integer *, integer *), sptrfs_(integer *, integer
+ *, real *, real *, real *, real *, real *, integer *, real *,
+ integer *, real *, real *, real *, integer *), spttrf_(integer *,
+ real *, real *, integer *), sgttrs_(char *, integer *, integer *,
+ real *, real *, real *, real *, integer *, real *, integer *,
+ integer *), spttrs_(integer *, integer *, real *, real *,
+ real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SERRGT tests the error exits for the REAL tridiagonal */
+/* routines. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ d__[0] = 1.f;
+ d__[1] = 2.f;
+ df[0] = 1.f;
+ df[1] = 2.f;
+ e[0] = 3.f;
+ e[1] = 4.f;
+ ef[0] = 3.f;
+ ef[1] = 4.f;
+ anorm = 1.f;
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "GT")) {
+
+/* Test error exits for the general tridiagonal routines. */
+
+/* SGTTRF */
+
+ s_copy(srnamc_1.srnamt, "SGTTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgttrf_(&c_n1, c__, d__, e, f, ip, &info);
+ chkxer_("SGTTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGTTRS */
+
+ s_copy(srnamc_1.srnamt, "SGTTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgttrs_("/", &c__0, &c__0, c__, d__, e, f, ip, x, &c__1, &info);
+ chkxer_("SGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgttrs_("N", &c_n1, &c__0, c__, d__, e, f, ip, x, &c__1, &info);
+ chkxer_("SGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgttrs_("N", &c__0, &c_n1, c__, d__, e, f, ip, x, &c__1, &info);
+ chkxer_("SGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sgttrs_("N", &c__2, &c__1, c__, d__, e, f, ip, x, &c__1, &info);
+ chkxer_("SGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGTRFS */
+
+ s_copy(srnamc_1.srnamt, "SGTRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgtrfs_("/", &c__0, &c__0, c__, d__, e, cf, df, ef, f, ip, b, &c__1,
+ x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("SGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgtrfs_("N", &c_n1, &c__0, c__, d__, e, cf, df, ef, f, ip, b, &c__1,
+ x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("SGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgtrfs_("N", &c__0, &c_n1, c__, d__, e, cf, df, ef, f, ip, b, &c__1,
+ x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("SGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ sgtrfs_("N", &c__2, &c__1, c__, d__, e, cf, df, ef, f, ip, b, &c__1,
+ x, &c__2, r1, r2, w, iw, &info);
+ chkxer_("SGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ sgtrfs_("N", &c__2, &c__1, c__, d__, e, cf, df, ef, f, ip, b, &c__2,
+ x, &c__1, r1, r2, w, iw, &info);
+ chkxer_("SGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGTCON */
+
+ s_copy(srnamc_1.srnamt, "SGTCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgtcon_("/", &c__0, c__, d__, e, f, ip, &anorm, &rcond, w, iw, &info);
+ chkxer_("SGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgtcon_("I", &c_n1, c__, d__, e, f, ip, &anorm, &rcond, w, iw, &info);
+ chkxer_("SGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ r__1 = -anorm;
+ sgtcon_("I", &c__0, c__, d__, e, f, ip, &r__1, &rcond, w, iw, &info);
+ chkxer_("SGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PT")) {
+
+/* Test error exits for the positive definite tridiagonal */
+/* routines. */
+
+/* SPTTRF */
+
+ s_copy(srnamc_1.srnamt, "SPTTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spttrf_(&c_n1, d__, e, &info);
+ chkxer_("SPTTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPTTRS */
+
+ s_copy(srnamc_1.srnamt, "SPTTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spttrs_(&c_n1, &c__0, d__, e, x, &c__1, &info);
+ chkxer_("SPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spttrs_(&c__0, &c_n1, d__, e, x, &c__1, &info);
+ chkxer_("SPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ spttrs_(&c__2, &c__1, d__, e, x, &c__1, &info);
+ chkxer_("SPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPTRFS */
+
+ s_copy(srnamc_1.srnamt, "SPTRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sptrfs_(&c_n1, &c__0, d__, e, df, ef, b, &c__1, x, &c__1, r1, r2, w, &
+ info);
+ chkxer_("SPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sptrfs_(&c__0, &c_n1, d__, e, df, ef, b, &c__1, x, &c__1, r1, r2, w, &
+ info);
+ chkxer_("SPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sptrfs_(&c__2, &c__1, d__, e, df, ef, b, &c__1, x, &c__2, r1, r2, w, &
+ info);
+ chkxer_("SPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sptrfs_(&c__2, &c__1, d__, e, df, ef, b, &c__2, x, &c__1, r1, r2, w, &
+ info);
+ chkxer_("SPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPTCON */
+
+ s_copy(srnamc_1.srnamt, "SPTCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sptcon_(&c_n1, d__, e, &anorm, &rcond, w, &info);
+ chkxer_("SPTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ r__1 = -anorm;
+ sptcon_(&c__0, d__, e, &r__1, &rcond, w, &info);
+ chkxer_("SPTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of SERRGT */
+
+} /* serrgt_ */
diff --git a/TESTING/LIN/serrlq.c b/TESTING/LIN/serrlq.c
new file mode 100644
index 0000000..2541357
--- /dev/null
+++ b/TESTING/LIN/serrlq.c
@@ -0,0 +1,374 @@
+/* serrlq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int serrlq_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real a[4] /* was [2][2] */, b[2];
+ integer i__, j;
+ real w[2], x[2], af[4] /* was [2][2] */;
+ integer info;
+ extern /* Subroutine */ int sgelq2_(integer *, integer *, real *, integer
+ *, real *, real *, integer *), sorgl2_(integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *), sorml2_(
+ char *, char *, integer *, integer *, integer *, real *, integer *
+, real *, real *, integer *, real *, integer *),
+ alaesm_(char *, logical *, integer *), sgelqf_(integer *,
+ integer *, real *, integer *, real *, real *, integer *, integer *
+), chkxer_(char *, integer *, integer *, logical *, logical *), sgelqs_(integer *, integer *, integer *, real *, integer
+ *, real *, real *, integer *, real *, integer *, integer *),
+ sorglq_(integer *, integer *, integer *, real *, integer *, real *
+, real *, integer *, integer *), sormlq_(char *, char *, integer *
+, integer *, integer *, real *, integer *, real *, real *,
+ integer *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SERRLQ tests the error exits for the REAL routines */
+/* that use the LQ decomposition of a general matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 2; ++j) {
+ for (i__ = 1; i__ <= 2; ++i__) {
+ a[i__ + (j << 1) - 3] = 1.f / (real) (i__ + j);
+ af[i__ + (j << 1) - 3] = 1.f / (real) (i__ + j);
+/* L10: */
+ }
+ b[j - 1] = 0.f;
+ w[j - 1] = 0.f;
+ x[j - 1] = 0.f;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+/* Error exits for LQ factorization */
+
+/* SGELQF */
+
+ s_copy(srnamc_1.srnamt, "SGELQF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgelqf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
+ chkxer_("SGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgelqf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("SGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgelqf_(&c__2, &c__1, a, &c__1, b, w, &c__2, &info);
+ chkxer_("SGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sgelqf_(&c__2, &c__1, a, &c__2, b, w, &c__1, &info);
+ chkxer_("SGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGELQ2 */
+
+ s_copy(srnamc_1.srnamt, "SGELQ2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgelq2_(&c_n1, &c__0, a, &c__1, b, w, &info);
+ chkxer_("SGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgelq2_(&c__0, &c_n1, a, &c__1, b, w, &info);
+ chkxer_("SGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgelq2_(&c__2, &c__1, a, &c__1, b, w, &info);
+ chkxer_("SGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGELQS */
+
+ s_copy(srnamc_1.srnamt, "SGELQS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgelqs_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("SGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgelqs_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("SGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgelqs_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
+ chkxer_("SGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgelqs_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("SGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgelqs_(&c__2, &c__2, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
+ chkxer_("SGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sgelqs_(&c__1, &c__2, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("SGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sgelqs_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("SGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SORGLQ */
+
+ s_copy(srnamc_1.srnamt, "SORGLQ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sorglq_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("SORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sorglq_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("SORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sorglq_(&c__2, &c__1, &c__0, a, &c__2, x, w, &c__2, &info);
+ chkxer_("SORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorglq_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
+ chkxer_("SORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorglq_(&c__1, &c__1, &c__2, a, &c__1, x, w, &c__1, &info);
+ chkxer_("SORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sorglq_(&c__2, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
+ chkxer_("SORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sorglq_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
+ chkxer_("SORGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SORGL2 */
+
+ s_copy(srnamc_1.srnamt, "SORGL2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sorgl2_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
+ chkxer_("SORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sorgl2_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("SORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sorgl2_(&c__2, &c__1, &c__0, a, &c__2, x, w, &info);
+ chkxer_("SORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorgl2_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
+ chkxer_("SORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorgl2_(&c__1, &c__1, &c__2, a, &c__1, x, w, &info);
+ chkxer_("SORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sorgl2_(&c__2, &c__2, &c__0, a, &c__1, x, w, &info);
+ chkxer_("SORGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SORMLQ */
+
+ s_copy(srnamc_1.srnamt, "SORMLQ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sormlq_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sormlq_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sormlq_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sormlq_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sormlq_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sormlq_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sormlq_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sormlq_("L", "N", &c__2, &c__0, &c__2, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sormlq_("R", "N", &c__0, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sormlq_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sormlq_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sormlq_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("SORMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SORML2 */
+
+ s_copy(srnamc_1.srnamt, "SORML2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sorml2_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sorml2_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorml2_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sorml2_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sorml2_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sorml2_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sorml2_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sorml2_("L", "N", &c__2, &c__1, &c__2, a, &c__1, x, af, &c__2, w, &info);
+ chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sorml2_("R", "N", &c__1, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sorml2_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &info);
+ chkxer_("SORML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of SERRLQ */
+
+} /* serrlq_ */
diff --git a/TESTING/LIN/serrls.c b/TESTING/LIN/serrls.c
new file mode 100644
index 0000000..7c2bc20
--- /dev/null
+++ b/TESTING/LIN/serrls.c
@@ -0,0 +1,293 @@
+/* serrls.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__10 = 10;
+
+/* Subroutine */ int serrls_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real a[4] /* was [2][2] */, b[4] /* was [2][2] */, s[2], w[2];
+ char c2[2];
+ integer ip[2], info, irnk;
+ real rcond;
+ extern /* Subroutine */ int sgels_(char *, integer *, integer *, integer *
+, real *, integer *, real *, integer *, real *, integer *,
+ integer *), alaesm_(char *, logical *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int sgelsd_(integer *, integer *, integer *, real
+ *, integer *, real *, integer *, real *, real *, integer *, real *
+, integer *, integer *, integer *), chkxer_(char *, integer *,
+ integer *, logical *, logical *), sgelss_(integer *,
+ integer *, integer *, real *, integer *, real *, integer *, real *
+, real *, integer *, real *, integer *, integer *), sgelsx_(
+ integer *, integer *, integer *, real *, integer *, real *,
+ integer *, integer *, real *, integer *, real *, integer *),
+ sgelsy_(integer *, integer *, integer *, real *, integer *, real *
+, integer *, integer *, real *, integer *, real *, integer *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SERRLS tests the error exits for the REAL least squares */
+/* driver routines (SGELS, SGELSS, SGELSX, SGELSY, SGELSD). */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ a[0] = 1.f;
+ a[2] = 2.f;
+ a[3] = 3.f;
+ a[1] = 4.f;
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "LS")) {
+
+/* Test error exits for the least squares driver routines. */
+
+/* SGELS */
+
+ s_copy(srnamc_1.srnamt, "SGELS ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgels_("/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, w, &c__1, &info);
+ chkxer_("SGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgels_("N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, w, &c__1, &info);
+ chkxer_("SGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgels_("N", &c__0, &c_n1, &c__0, a, &c__1, b, &c__1, w, &c__1, &info);
+ chkxer_("SGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgels_("N", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, w, &c__1, &info);
+ chkxer_("SGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sgels_("N", &c__2, &c__0, &c__0, a, &c__1, b, &c__2, w, &c__2, &info);
+ chkxer_("SGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sgels_("N", &c__2, &c__0, &c__0, a, &c__2, b, &c__1, w, &c__2, &info);
+ chkxer_("SGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sgels_("N", &c__1, &c__1, &c__0, a, &c__1, b, &c__1, w, &c__1, &info);
+ chkxer_("SGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGELSS */
+
+ s_copy(srnamc_1.srnamt, "SGELSS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgelss_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__1, &info);
+ chkxer_("SGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgelss_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__1, &info);
+ chkxer_("SGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgelss_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__1, &info);
+ chkxer_("SGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgelss_(&c__2, &c__0, &c__0, a, &c__1, b, &c__2, s, &rcond, &irnk, w,
+ &c__2, &info);
+ chkxer_("SGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sgelss_(&c__2, &c__0, &c__0, a, &c__2, b, &c__1, s, &rcond, &irnk, w,
+ &c__2, &info);
+ chkxer_("SGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGELSX */
+
+ s_copy(srnamc_1.srnamt, "SGELSX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgelsx_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ &info);
+ chkxer_("SGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgelsx_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ &info);
+ chkxer_("SGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgelsx_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ &info);
+ chkxer_("SGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgelsx_(&c__2, &c__0, &c__0, a, &c__1, b, &c__2, ip, &rcond, &irnk, w,
+ &info);
+ chkxer_("SGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sgelsx_(&c__2, &c__0, &c__0, a, &c__2, b, &c__1, ip, &rcond, &irnk, w,
+ &info);
+ chkxer_("SGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGELSY */
+
+ s_copy(srnamc_1.srnamt, "SGELSY", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgelsy_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ &c__10, &info);
+ chkxer_("SGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgelsy_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ &c__10, &info);
+ chkxer_("SGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgelsy_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ &c__10, &info);
+ chkxer_("SGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgelsy_(&c__2, &c__0, &c__0, a, &c__1, b, &c__2, ip, &rcond, &irnk, w,
+ &c__10, &info);
+ chkxer_("SGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sgelsy_(&c__2, &c__0, &c__0, a, &c__2, b, &c__1, ip, &rcond, &irnk, w,
+ &c__10, &info);
+ chkxer_("SGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sgelsy_(&c__2, &c__2, &c__1, a, &c__2, b, &c__2, ip, &rcond, &irnk, w,
+ &c__1, &info);
+ chkxer_("SGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGELSD */
+
+ s_copy(srnamc_1.srnamt, "SGELSD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgelsd_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__10, ip, &info);
+ chkxer_("SGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgelsd_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__10, ip, &info);
+ chkxer_("SGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgelsd_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__10, ip, &info);
+ chkxer_("SGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgelsd_(&c__2, &c__0, &c__0, a, &c__1, b, &c__2, s, &rcond, &irnk, w,
+ &c__10, ip, &info);
+ chkxer_("SGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sgelsd_(&c__2, &c__0, &c__0, a, &c__2, b, &c__1, s, &rcond, &irnk, w,
+ &c__10, ip, &info);
+ chkxer_("SGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sgelsd_(&c__2, &c__2, &c__1, a, &c__2, b, &c__2, s, &rcond, &irnk, w,
+ &c__1, ip, &info);
+ chkxer_("SGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of SERRLS */
+
+} /* serrls_ */
diff --git a/TESTING/LIN/serrpo.c b/TESTING/LIN/serrpo.c
new file mode 100644
index 0000000..5d4df38
--- /dev/null
+++ b/TESTING/LIN/serrpo.c
@@ -0,0 +1,564 @@
+/* serrpo.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int serrpo_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real a[16] /* was [4][4] */, b[4];
+ integer i__, j;
+ real w[12], x[4];
+ char c2[2];
+ real r1[4], r2[4], af[16] /* was [4][4] */;
+ integer iw[4], info;
+ real anrm, rcond;
+ extern /* Subroutine */ int spbtf2_(char *, integer *, integer *, real *,
+ integer *, integer *), spotf2_(char *, integer *, real *,
+ integer *, integer *), alaesm_(char *, logical *, integer
+ *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), spbcon_(char *, integer *, integer *, real
+ *, integer *, real *, real *, real *, integer *, integer *), spbequ_(char *, integer *, integer *, real *, integer *,
+ real *, real *, real *, integer *), spbrfs_(char *,
+ integer *, integer *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, real *, real *,
+ real *, integer *, integer *), spbtrf_(char *, integer *,
+ integer *, real *, integer *, integer *), spocon_(char *,
+ integer *, real *, integer *, real *, real *, real *, integer *,
+ integer *), sppcon_(char *, integer *, real *, real *,
+ real *, real *, integer *, integer *), spoequ_(integer *,
+ real *, integer *, real *, real *, real *, integer *), spbtrs_(
+ char *, integer *, integer *, integer *, real *, integer *, real *
+, integer *, integer *), sporfs_(char *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, integer *, real *, real *, real *, integer *, integer *), spotrf_(char *, integer *, real *, integer *, integer *), spotri_(char *, integer *, real *, integer *, integer *), sppequ_(char *, integer *, real *, real *, real *, real
+ *, integer *), spprfs_(char *, integer *, integer *, real
+ *, real *, real *, integer *, real *, integer *, real *, real *,
+ real *, integer *, integer *), spptrf_(char *, integer *,
+ real *, integer *), spptri_(char *, integer *, real *,
+ integer *), spotrs_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, integer *), spptrs_(char *,
+ integer *, integer *, real *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SERRPO tests the error exits for the REAL routines */
+/* for symmetric positive definite matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (j << 2) - 5] = 1.f / (real) (i__ + j);
+ af[i__ + (j << 2) - 5] = 1.f / (real) (i__ + j);
+/* L10: */
+ }
+ b[j - 1] = 0.f;
+ r1[j - 1] = 0.f;
+ r2[j - 1] = 0.f;
+ w[j - 1] = 0.f;
+ x[j - 1] = 0.f;
+ iw[j - 1] = j;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "PO")) {
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a symmetric positive definite matrix. */
+
+/* SPOTRF */
+
+ s_copy(srnamc_1.srnamt, "SPOTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spotrf_("/", &c__0, a, &c__1, &info);
+ chkxer_("SPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spotrf_("U", &c_n1, a, &c__1, &info);
+ chkxer_("SPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ spotrf_("U", &c__2, a, &c__1, &info);
+ chkxer_("SPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPOTF2 */
+
+ s_copy(srnamc_1.srnamt, "SPOTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spotf2_("/", &c__0, a, &c__1, &info);
+ chkxer_("SPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spotf2_("U", &c_n1, a, &c__1, &info);
+ chkxer_("SPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ spotf2_("U", &c__2, a, &c__1, &info);
+ chkxer_("SPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPOTRI */
+
+ s_copy(srnamc_1.srnamt, "SPOTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spotri_("/", &c__0, a, &c__1, &info);
+ chkxer_("SPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spotri_("U", &c_n1, a, &c__1, &info);
+ chkxer_("SPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ spotri_("U", &c__2, a, &c__1, &info);
+ chkxer_("SPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPOTRS */
+
+ s_copy(srnamc_1.srnamt, "SPOTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spotrs_("/", &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spotrs_("U", &c_n1, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spotrs_("U", &c__0, &c_n1, a, &c__1, b, &c__1, &info);
+ chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ spotrs_("U", &c__2, &c__1, a, &c__1, b, &c__2, &info);
+ chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ spotrs_("U", &c__2, &c__1, a, &c__2, b, &c__1, &info);
+ chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPORFS */
+
+ s_copy(srnamc_1.srnamt, "SPORFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sporfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, iw, &info);
+ chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sporfs_("U", &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, iw, &info);
+ chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sporfs_("U", &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, iw, &info);
+ chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sporfs_("U", &c__2, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &c__2,
+ r1, r2, w, iw, &info);
+ chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sporfs_("U", &c__2, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &c__2,
+ r1, r2, w, iw, &info);
+ chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__1, x, &c__2,
+ r1, r2, w, iw, &info);
+ chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ sporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__2, x, &c__1,
+ r1, r2, w, iw, &info);
+ chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPOCON */
+
+ s_copy(srnamc_1.srnamt, "SPOCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spocon_("/", &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("SPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spocon_("U", &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("SPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ spocon_("U", &c__2, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("SPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPOEQU */
+
+ s_copy(srnamc_1.srnamt, "SPOEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spoequ_(&c_n1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("SPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spoequ_(&c__2, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("SPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PP")) {
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a symmetric positive definite packed matrix. */
+
+/* SPPTRF */
+
+ s_copy(srnamc_1.srnamt, "SPPTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spptrf_("/", &c__0, a, &info);
+ chkxer_("SPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spptrf_("U", &c_n1, a, &info);
+ chkxer_("SPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPPTRI */
+
+ s_copy(srnamc_1.srnamt, "SPPTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spptri_("/", &c__0, a, &info);
+ chkxer_("SPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spptri_("U", &c_n1, a, &info);
+ chkxer_("SPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPPTRS */
+
+ s_copy(srnamc_1.srnamt, "SPPTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spptrs_("/", &c__0, &c__0, a, b, &c__1, &info);
+ chkxer_("SPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spptrs_("U", &c_n1, &c__0, a, b, &c__1, &info);
+ chkxer_("SPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spptrs_("U", &c__0, &c_n1, a, b, &c__1, &info);
+ chkxer_("SPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ spptrs_("U", &c__2, &c__1, a, b, &c__1, &info);
+ chkxer_("SPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPPRFS */
+
+ s_copy(srnamc_1.srnamt, "SPPRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spprfs_("/", &c__0, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
+ info);
+ chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spprfs_("U", &c_n1, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
+ info);
+ chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spprfs_("U", &c__0, &c_n1, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
+ info);
+ chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ spprfs_("U", &c__2, &c__1, a, af, b, &c__1, x, &c__2, r1, r2, w, iw, &
+ info);
+ chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ spprfs_("U", &c__2, &c__1, a, af, b, &c__2, x, &c__1, r1, r2, w, iw, &
+ info);
+ chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPPCON */
+
+ s_copy(srnamc_1.srnamt, "SPPCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sppcon_("/", &c__0, a, &anrm, &rcond, w, iw, &info);
+ chkxer_("SPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sppcon_("U", &c_n1, a, &anrm, &rcond, w, iw, &info);
+ chkxer_("SPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPPEQU */
+
+ s_copy(srnamc_1.srnamt, "SPPEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sppequ_("/", &c__0, a, r1, &rcond, &anrm, &info);
+ chkxer_("SPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sppequ_("U", &c_n1, a, r1, &rcond, &anrm, &info);
+ chkxer_("SPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a symmetric positive definite band matrix. */
+
+/* SPBTRF */
+
+ s_copy(srnamc_1.srnamt, "SPBTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spbtrf_("/", &c__0, &c__0, a, &c__1, &info);
+ chkxer_("SPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spbtrf_("U", &c_n1, &c__0, a, &c__1, &info);
+ chkxer_("SPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spbtrf_("U", &c__1, &c_n1, a, &c__1, &info);
+ chkxer_("SPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ spbtrf_("U", &c__2, &c__1, a, &c__1, &info);
+ chkxer_("SPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPBTF2 */
+
+ s_copy(srnamc_1.srnamt, "SPBTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spbtf2_("/", &c__0, &c__0, a, &c__1, &info);
+ chkxer_("SPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spbtf2_("U", &c_n1, &c__0, a, &c__1, &info);
+ chkxer_("SPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spbtf2_("U", &c__1, &c_n1, a, &c__1, &info);
+ chkxer_("SPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ spbtf2_("U", &c__2, &c__1, a, &c__1, &info);
+ chkxer_("SPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPBTRS */
+
+ s_copy(srnamc_1.srnamt, "SPBTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spbtrs_("/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spbtrs_("U", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spbtrs_("U", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ spbtrs_("U", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, &info);
+ chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ spbtrs_("U", &c__2, &c__1, &c__1, a, &c__1, b, &c__1, &info);
+ chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ spbtrs_("U", &c__2, &c__0, &c__1, a, &c__1, b, &c__1, &info);
+ chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPBRFS */
+
+ s_copy(srnamc_1.srnamt, "SPBRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spbrfs_("/", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spbrfs_("U", &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spbrfs_("U", &c__1, &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ spbrfs_("U", &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ spbrfs_("U", &c__2, &c__1, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ spbrfs_("U", &c__2, &c__1, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ spbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ spbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__2, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPBCON */
+
+ s_copy(srnamc_1.srnamt, "SPBCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spbcon_("/", &c__0, &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("SPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spbcon_("U", &c_n1, &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("SPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spbcon_("U", &c__1, &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("SPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ spbcon_("U", &c__2, &c__1, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("SPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPBEQU */
+
+ s_copy(srnamc_1.srnamt, "SPBEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spbequ_("/", &c__0, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("SPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spbequ_("U", &c_n1, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("SPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spbequ_("U", &c__1, &c_n1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("SPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ spbequ_("U", &c__2, &c__1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("SPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of SERRPO */
+
+} /* serrpo_ */
diff --git a/TESTING/LIN/serrpox.c b/TESTING/LIN/serrpox.c
new file mode 100644
index 0000000..a40dcde
--- /dev/null
+++ b/TESTING/LIN/serrpox.c
@@ -0,0 +1,644 @@
+/* serrpox.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int serrpo_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real a[16] /* was [4][4] */, b[4];
+ integer i__, j;
+ real s[4], w[12], x[4];
+ char c2[2];
+ real r1[4], r2[4], af[16] /* was [4][4] */;
+ char eq[1];
+ integer iw[4];
+ real err_bnds_c__[12] /* was [4][3] */;
+ integer n_err_bnds__;
+ real err_bnds_n__[12] /* was [4][3] */, berr;
+ integer info;
+ real anrm, rcond;
+ extern /* Subroutine */ int spbtf2_(char *, integer *, integer *, real *,
+ integer *, integer *), spotf2_(char *, integer *, real *,
+ integer *, integer *), alaesm_(char *, logical *, integer
+ *);
+ extern logical lsamen_(integer *, char *, char *);
+ real params;
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), spbcon_(char *, integer *, integer *, real
+ *, integer *, real *, real *, real *, integer *, integer *), spbequ_(char *, integer *, integer *, real *, integer *,
+ real *, real *, real *, integer *), spbrfs_(char *,
+ integer *, integer *, integer *, real *, integer *, real *,
+ integer *, real *, integer *, real *, integer *, real *, real *,
+ real *, integer *, integer *), spbtrf_(char *, integer *,
+ integer *, real *, integer *, integer *), spocon_(char *,
+ integer *, real *, integer *, real *, real *, real *, integer *,
+ integer *), sppcon_(char *, integer *, real *, real *,
+ real *, real *, integer *, integer *), spoequ_(integer *,
+ real *, integer *, real *, real *, real *, integer *), spbtrs_(
+ char *, integer *, integer *, integer *, real *, integer *, real *
+, integer *, integer *), sporfs_(char *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, integer *
+, real *, integer *, real *, real *, real *, integer *, integer *), spotrf_(char *, integer *, real *, integer *, integer *), spotri_(char *, integer *, real *, integer *, integer *), sppequ_(char *, integer *, real *, real *, real *, real
+ *, integer *), spprfs_(char *, integer *, integer *, real
+ *, real *, real *, integer *, real *, integer *, real *, real *,
+ real *, integer *, integer *), spptrf_(char *, integer *,
+ real *, integer *), spptri_(char *, integer *, real *,
+ integer *), spotrs_(char *, integer *, integer *, real *,
+ integer *, real *, integer *, integer *), spptrs_(char *,
+ integer *, integer *, real *, real *, integer *, integer *);
+ integer nparams;
+ extern /* Subroutine */ int spoequb_(integer *, real *, integer *, real *,
+ real *, real *, integer *), sporfsx_(char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, real *, real *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ real *, integer *, real *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SERRPO tests the error exits for the REAL routines */
+/* for symmetric positive definite matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (j << 2) - 5] = 1.f / (real) (i__ + j);
+ af[i__ + (j << 2) - 5] = 1.f / (real) (i__ + j);
+/* L10: */
+ }
+ b[j - 1] = 0.f;
+ r1[j - 1] = 0.f;
+ r2[j - 1] = 0.f;
+ w[j - 1] = 0.f;
+ x[j - 1] = 0.f;
+ s[j - 1] = 0.f;
+ iw[j - 1] = j;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "PO")) {
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a symmetric positive definite matrix. */
+
+/* SPOTRF */
+
+ s_copy(srnamc_1.srnamt, "SPOTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spotrf_("/", &c__0, a, &c__1, &info);
+ chkxer_("SPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spotrf_("U", &c_n1, a, &c__1, &info);
+ chkxer_("SPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ spotrf_("U", &c__2, a, &c__1, &info);
+ chkxer_("SPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPOTF2 */
+
+ s_copy(srnamc_1.srnamt, "SPOTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spotf2_("/", &c__0, a, &c__1, &info);
+ chkxer_("SPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spotf2_("U", &c_n1, a, &c__1, &info);
+ chkxer_("SPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ spotf2_("U", &c__2, a, &c__1, &info);
+ chkxer_("SPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPOTRI */
+
+ s_copy(srnamc_1.srnamt, "SPOTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spotri_("/", &c__0, a, &c__1, &info);
+ chkxer_("SPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spotri_("U", &c_n1, a, &c__1, &info);
+ chkxer_("SPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ spotri_("U", &c__2, a, &c__1, &info);
+ chkxer_("SPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPOTRS */
+
+ s_copy(srnamc_1.srnamt, "SPOTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spotrs_("/", &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spotrs_("U", &c_n1, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spotrs_("U", &c__0, &c_n1, a, &c__1, b, &c__1, &info);
+ chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ spotrs_("U", &c__2, &c__1, a, &c__1, b, &c__2, &info);
+ chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ spotrs_("U", &c__2, &c__1, a, &c__2, b, &c__1, &info);
+ chkxer_("SPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPORFS */
+
+ s_copy(srnamc_1.srnamt, "SPORFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sporfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, iw, &info);
+ chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sporfs_("U", &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, iw, &info);
+ chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sporfs_("U", &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, iw, &info);
+ chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sporfs_("U", &c__2, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &c__2,
+ r1, r2, w, iw, &info);
+ chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sporfs_("U", &c__2, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &c__2,
+ r1, r2, w, iw, &info);
+ chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__1, x, &c__2,
+ r1, r2, w, iw, &info);
+ chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ sporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__2, x, &c__1,
+ r1, r2, w, iw, &info);
+ chkxer_("SPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPORFSX */
+
+ n_err_bnds__ = 3;
+ nparams = 0;
+ s_copy(srnamc_1.srnamt, "SPORFSX", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ sporfsx_("/", eq, &c__0, &c__0, a, &c__1, af, &c__1, s, b, &c__1, x, &
+ c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, iw, &info);
+ chkxer_("SPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sporfsx_("U", eq, &c_n1, &c__0, a, &c__1, af, &c__1, s, b, &c__1, x, &
+ c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, iw, &info);
+ chkxer_("SPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ *(unsigned char *)eq = 'N';
+ infoc_1.infot = 3;
+ sporfsx_("U", eq, &c_n1, &c__0, a, &c__1, af, &c__1, s, b, &c__1, x, &
+ c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, iw, &info);
+ chkxer_("SPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sporfsx_("U", eq, &c__0, &c_n1, a, &c__1, af, &c__1, s, b, &c__1, x, &
+ c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, iw, &info);
+ chkxer_("SPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sporfsx_("U", eq, &c__2, &c__1, a, &c__1, af, &c__2, s, b, &c__2, x, &
+ c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, iw, &info);
+ chkxer_("SPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sporfsx_("U", eq, &c__2, &c__1, a, &c__2, af, &c__1, s, b, &c__2, x, &
+ c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, iw, &info);
+ chkxer_("SPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ sporfsx_("U", eq, &c__2, &c__1, a, &c__2, af, &c__2, s, b, &c__1, x, &
+ c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, iw, &info);
+ chkxer_("SPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ sporfsx_("U", eq, &c__2, &c__1, a, &c__2, af, &c__2, s, b, &c__2, x, &
+ c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, iw, &info);
+ chkxer_("SPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPOCON */
+
+ s_copy(srnamc_1.srnamt, "SPOCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spocon_("/", &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("SPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spocon_("U", &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("SPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ spocon_("U", &c__2, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("SPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPOEQU */
+
+ s_copy(srnamc_1.srnamt, "SPOEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spoequ_(&c_n1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("SPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spoequ_(&c__2, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("SPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPOEQUB */
+
+ s_copy(srnamc_1.srnamt, "SPOEQUB", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ spoequb_(&c_n1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("SPOEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spoequb_(&c__2, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("SPOEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PP")) {
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a symmetric positive definite packed matrix. */
+
+/* SPPTRF */
+
+ s_copy(srnamc_1.srnamt, "SPPTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spptrf_("/", &c__0, a, &info);
+ chkxer_("SPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spptrf_("U", &c_n1, a, &info);
+ chkxer_("SPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPPTRI */
+
+ s_copy(srnamc_1.srnamt, "SPPTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spptri_("/", &c__0, a, &info);
+ chkxer_("SPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spptri_("U", &c_n1, a, &info);
+ chkxer_("SPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPPTRS */
+
+ s_copy(srnamc_1.srnamt, "SPPTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spptrs_("/", &c__0, &c__0, a, b, &c__1, &info);
+ chkxer_("SPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spptrs_("U", &c_n1, &c__0, a, b, &c__1, &info);
+ chkxer_("SPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spptrs_("U", &c__0, &c_n1, a, b, &c__1, &info);
+ chkxer_("SPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ spptrs_("U", &c__2, &c__1, a, b, &c__1, &info);
+ chkxer_("SPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPPRFS */
+
+ s_copy(srnamc_1.srnamt, "SPPRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spprfs_("/", &c__0, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
+ info);
+ chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spprfs_("U", &c_n1, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
+ info);
+ chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spprfs_("U", &c__0, &c_n1, a, af, b, &c__1, x, &c__1, r1, r2, w, iw, &
+ info);
+ chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ spprfs_("U", &c__2, &c__1, a, af, b, &c__1, x, &c__2, r1, r2, w, iw, &
+ info);
+ chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ spprfs_("U", &c__2, &c__1, a, af, b, &c__2, x, &c__1, r1, r2, w, iw, &
+ info);
+ chkxer_("SPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPPCON */
+
+ s_copy(srnamc_1.srnamt, "SPPCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sppcon_("/", &c__0, a, &anrm, &rcond, w, iw, &info);
+ chkxer_("SPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sppcon_("U", &c_n1, a, &anrm, &rcond, w, iw, &info);
+ chkxer_("SPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPPEQU */
+
+ s_copy(srnamc_1.srnamt, "SPPEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sppequ_("/", &c__0, a, r1, &rcond, &anrm, &info);
+ chkxer_("SPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sppequ_("U", &c_n1, a, r1, &rcond, &anrm, &info);
+ chkxer_("SPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a symmetric positive definite band matrix. */
+
+/* SPBTRF */
+
+ s_copy(srnamc_1.srnamt, "SPBTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spbtrf_("/", &c__0, &c__0, a, &c__1, &info);
+ chkxer_("SPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spbtrf_("U", &c_n1, &c__0, a, &c__1, &info);
+ chkxer_("SPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spbtrf_("U", &c__1, &c_n1, a, &c__1, &info);
+ chkxer_("SPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ spbtrf_("U", &c__2, &c__1, a, &c__1, &info);
+ chkxer_("SPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPBTF2 */
+
+ s_copy(srnamc_1.srnamt, "SPBTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spbtf2_("/", &c__0, &c__0, a, &c__1, &info);
+ chkxer_("SPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spbtf2_("U", &c_n1, &c__0, a, &c__1, &info);
+ chkxer_("SPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spbtf2_("U", &c__1, &c_n1, a, &c__1, &info);
+ chkxer_("SPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ spbtf2_("U", &c__2, &c__1, a, &c__1, &info);
+ chkxer_("SPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPBTRS */
+
+ s_copy(srnamc_1.srnamt, "SPBTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spbtrs_("/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spbtrs_("U", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spbtrs_("U", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ spbtrs_("U", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, &info);
+ chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ spbtrs_("U", &c__2, &c__1, &c__1, a, &c__1, b, &c__1, &info);
+ chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ spbtrs_("U", &c__2, &c__0, &c__1, a, &c__1, b, &c__1, &info);
+ chkxer_("SPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPBRFS */
+
+ s_copy(srnamc_1.srnamt, "SPBRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spbrfs_("/", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spbrfs_("U", &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spbrfs_("U", &c__1, &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ spbrfs_("U", &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ spbrfs_("U", &c__2, &c__1, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ spbrfs_("U", &c__2, &c__1, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ spbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ spbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__2, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("SPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPBCON */
+
+ s_copy(srnamc_1.srnamt, "SPBCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spbcon_("/", &c__0, &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("SPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spbcon_("U", &c_n1, &c__0, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("SPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spbcon_("U", &c__1, &c_n1, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("SPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ spbcon_("U", &c__2, &c__1, a, &c__1, &anrm, &rcond, w, iw, &info);
+ chkxer_("SPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPBEQU */
+
+ s_copy(srnamc_1.srnamt, "SPBEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spbequ_("/", &c__0, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("SPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spbequ_("U", &c_n1, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("SPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spbequ_("U", &c__1, &c_n1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("SPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ spbequ_("U", &c__2, &c__1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("SPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of SERRPO */
+
+} /* serrpo_ */
diff --git a/TESTING/LIN/serrps.c b/TESTING/LIN/serrps.c
new file mode 100644
index 0000000..cbe4f57
--- /dev/null
+++ b/TESTING/LIN/serrps.c
@@ -0,0 +1,167 @@
+/* serrps.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c__1 = 1;
+static real c_b9 = -1.f;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int serrps_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real a[16] /* was [4][4] */;
+ integer i__, j, piv[4], info;
+ real work[8];
+ extern /* Subroutine */ int spstf2_(char *, integer *, real *, integer *,
+ integer *, integer *, real *, real *, integer *), alaesm_(
+ char *, logical *, integer *), chkxer_(char *, integer *,
+ integer *, logical *, logical *), spstrf_(char *, integer
+ *, real *, integer *, integer *, integer *, real *, real *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SERRPS tests the error exits for the REAL routines */
+/* for SPSTRF.. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (j << 2) - 5] = 1.f / (real) (i__ + j);
+
+/* L100: */
+ }
+ piv[j - 1] = j;
+ work[j - 1] = 0.f;
+ work[j + 3] = 0.f;
+
+/* L110: */
+ }
+ infoc_1.ok = TRUE_;
+
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a symmetric positive semidefinite matrix. */
+
+/* SPSTRF */
+
+ s_copy(srnamc_1.srnamt, "SPSTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spstrf_("/", &c__0, a, &c__1, piv, &c__1, &c_b9, work, &info);
+ chkxer_("SPSTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spstrf_("U", &c_n1, a, &c__1, piv, &c__1, &c_b9, work, &info);
+ chkxer_("SPSTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ spstrf_("U", &c__2, a, &c__1, piv, &c__1, &c_b9, work, &info);
+ chkxer_("SPSTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPSTF2 */
+
+ s_copy(srnamc_1.srnamt, "SPSTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spstf2_("/", &c__0, a, &c__1, piv, &c__1, &c_b9, work, &info);
+ chkxer_("SPSTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spstf2_("U", &c_n1, a, &c__1, piv, &c__1, &c_b9, work, &info);
+ chkxer_("SPSTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ spstf2_("U", &c__2, a, &c__1, piv, &c__1, &c_b9, work, &info);
+ chkxer_("SPSTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of SERRPS */
+
+} /* serrps_ */
diff --git a/TESTING/LIN/serrql.c b/TESTING/LIN/serrql.c
new file mode 100644
index 0000000..eb5c6d5
--- /dev/null
+++ b/TESTING/LIN/serrql.c
@@ -0,0 +1,374 @@
+/* serrql.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int serrql_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real a[4] /* was [2][2] */, b[2];
+ integer i__, j;
+ real w[2], x[2], af[4] /* was [2][2] */;
+ integer info;
+ extern /* Subroutine */ int sgeql2_(integer *, integer *, real *, integer
+ *, real *, real *, integer *), sorg2l_(integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *), sorm2l_(
+ char *, char *, integer *, integer *, integer *, real *, integer *
+, real *, real *, integer *, real *, integer *),
+ alaesm_(char *, logical *, integer *), sgeqlf_(integer *,
+ integer *, real *, integer *, real *, real *, integer *, integer *
+), chkxer_(char *, integer *, integer *, logical *, logical *), sgeqls_(integer *, integer *, integer *, real *, integer
+ *, real *, real *, integer *, real *, integer *, integer *),
+ sorgql_(integer *, integer *, integer *, real *, integer *, real *
+, real *, integer *, integer *), sormql_(char *, char *, integer *
+, integer *, integer *, real *, integer *, real *, real *,
+ integer *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SERRQL tests the error exits for the REAL routines */
+/* that use the QL decomposition of a general matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 2; ++j) {
+ for (i__ = 1; i__ <= 2; ++i__) {
+ a[i__ + (j << 1) - 3] = 1.f / (real) (i__ + j);
+ af[i__ + (j << 1) - 3] = 1.f / (real) (i__ + j);
+/* L10: */
+ }
+ b[j - 1] = 0.f;
+ w[j - 1] = 0.f;
+ x[j - 1] = 0.f;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+/* Error exits for QL factorization */
+
+/* SGEQLF */
+
+ s_copy(srnamc_1.srnamt, "SGEQLF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgeqlf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
+ chkxer_("SGEQLF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgeqlf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("SGEQLF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgeqlf_(&c__2, &c__1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("SGEQLF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sgeqlf_(&c__1, &c__2, a, &c__1, b, w, &c__1, &info);
+ chkxer_("SGEQLF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGEQL2 */
+
+ s_copy(srnamc_1.srnamt, "SGEQL2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgeql2_(&c_n1, &c__0, a, &c__1, b, w, &info);
+ chkxer_("SGEQL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgeql2_(&c__0, &c_n1, a, &c__1, b, w, &info);
+ chkxer_("SGEQL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgeql2_(&c__2, &c__1, a, &c__1, b, w, &info);
+ chkxer_("SGEQL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGEQLS */
+
+ s_copy(srnamc_1.srnamt, "SGEQLS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgeqls_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("SGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgeqls_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("SGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgeqls_(&c__1, &c__2, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("SGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgeqls_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("SGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgeqls_(&c__2, &c__1, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
+ chkxer_("SGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sgeqls_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
+ chkxer_("SGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sgeqls_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("SGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SORGQL */
+
+ s_copy(srnamc_1.srnamt, "SORGQL", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sorgql_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("SORGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sorgql_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("SORGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sorgql_(&c__1, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
+ chkxer_("SORGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorgql_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
+ chkxer_("SORGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorgql_(&c__1, &c__1, &c__2, a, &c__1, x, w, &c__1, &info);
+ chkxer_("SORGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sorgql_(&c__2, &c__1, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("SORGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sorgql_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
+ chkxer_("SORGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SORG2L */
+
+ s_copy(srnamc_1.srnamt, "SORG2L", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sorg2l_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
+ chkxer_("SORG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sorg2l_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("SORG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sorg2l_(&c__1, &c__2, &c__0, a, &c__1, x, w, &info);
+ chkxer_("SORG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorg2l_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
+ chkxer_("SORG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorg2l_(&c__2, &c__1, &c__2, a, &c__2, x, w, &info);
+ chkxer_("SORG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sorg2l_(&c__2, &c__1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("SORG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SORMQL */
+
+ s_copy(srnamc_1.srnamt, "SORMQL", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sormql_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sormql_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sormql_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sormql_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sormql_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sormql_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sormql_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sormql_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("SORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sormql_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sormql_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sormql_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sormql_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("SORMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SORM2L */
+
+ s_copy(srnamc_1.srnamt, "SORM2L", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sorm2l_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sorm2l_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorm2l_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sorm2l_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sorm2l_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sorm2l_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sorm2l_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sorm2l_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &info);
+ chkxer_("SORM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sorm2l_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sorm2l_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &info);
+ chkxer_("SORM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of SERRQL */
+
+} /* serrql_ */
diff --git a/TESTING/LIN/serrqp.c b/TESTING/LIN/serrqp.c
new file mode 100644
index 0000000..3afe7f0
--- /dev/null
+++ b/TESTING/LIN/serrqp.c
@@ -0,0 +1,168 @@
+/* serrqp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int serrqp_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real a[9] /* was [3][3] */, w[10];
+ char c2[2];
+ integer ip[3], lw;
+ real tau[3];
+ integer info;
+ extern /* Subroutine */ int sgeqp3_(integer *, integer *, real *, integer
+ *, integer *, real *, real *, integer *, integer *), alaesm_(char
+ *, logical *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), sgeqpf_(integer *, integer *, real *,
+ integer *, integer *, real *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SERRQP tests the error exits for SGEQPF and SGEQP3. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ lw = 10;
+ a[0] = 1.f;
+ a[3] = 2.f;
+ a[4] = 3.f;
+ a[1] = 4.f;
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "QP")) {
+
+/* Test error exits for QR factorization with pivoting */
+
+/* SGEQPF */
+
+ s_copy(srnamc_1.srnamt, "SGEQPF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgeqpf_(&c_n1, &c__0, a, &c__1, ip, tau, w, &info);
+ chkxer_("SGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgeqpf_(&c__0, &c_n1, a, &c__1, ip, tau, w, &info);
+ chkxer_("SGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgeqpf_(&c__2, &c__0, a, &c__1, ip, tau, w, &info);
+ chkxer_("SGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGEQP3 */
+
+ s_copy(srnamc_1.srnamt, "SGEQP3", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgeqp3_(&c_n1, &c__0, a, &c__1, ip, tau, w, &lw, &info);
+ chkxer_("SGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgeqp3_(&c__1, &c_n1, a, &c__1, ip, tau, w, &lw, &info);
+ chkxer_("SGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgeqp3_(&c__2, &c__3, a, &c__1, ip, tau, w, &lw, &info);
+ chkxer_("SGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ i__1 = lw - 10;
+ sgeqp3_(&c__2, &c__2, a, &c__2, ip, tau, w, &i__1, &info);
+ chkxer_("SGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of SERRQP */
+
+} /* serrqp_ */
diff --git a/TESTING/LIN/serrqr.c b/TESTING/LIN/serrqr.c
new file mode 100644
index 0000000..1179dd6
--- /dev/null
+++ b/TESTING/LIN/serrqr.c
@@ -0,0 +1,375 @@
+/* serrqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int serrqr_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real a[4] /* was [2][2] */, b[2];
+ integer i__, j;
+ real w[2], x[2], af[4] /* was [2][2] */;
+ integer info;
+ extern /* Subroutine */ int sgeqr2_(integer *, integer *, real *, integer
+ *, real *, real *, integer *), sorg2r_(integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *), sorm2r_(
+ char *, char *, integer *, integer *, integer *, real *, integer *
+, real *, real *, integer *, real *, integer *),
+ alaesm_(char *, logical *, integer *), chkxer_(char *,
+ integer *, integer *, logical *, logical *), sgeqrf_(
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, integer *), sgeqrs_(integer *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *, integer *, integer *
+), sorgqr_(integer *, integer *, integer *, real *, integer *,
+ real *, real *, integer *, integer *), sormqr_(char *, char *,
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, integer *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SERRQR tests the error exits for the REAL routines */
+/* that use the QR decomposition of a general matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 2; ++j) {
+ for (i__ = 1; i__ <= 2; ++i__) {
+ a[i__ + (j << 1) - 3] = 1.f / (real) (i__ + j);
+ af[i__ + (j << 1) - 3] = 1.f / (real) (i__ + j);
+/* L10: */
+ }
+ b[j - 1] = 0.f;
+ w[j - 1] = 0.f;
+ x[j - 1] = 0.f;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+/* Error exits for QR factorization */
+
+/* SGEQRF */
+
+ s_copy(srnamc_1.srnamt, "SGEQRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgeqrf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
+ chkxer_("SGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgeqrf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("SGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgeqrf_(&c__2, &c__1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("SGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sgeqrf_(&c__1, &c__2, a, &c__1, b, w, &c__1, &info);
+ chkxer_("SGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGEQR2 */
+
+ s_copy(srnamc_1.srnamt, "SGEQR2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgeqr2_(&c_n1, &c__0, a, &c__1, b, w, &info);
+ chkxer_("SGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgeqr2_(&c__0, &c_n1, a, &c__1, b, w, &info);
+ chkxer_("SGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgeqr2_(&c__2, &c__1, a, &c__1, b, w, &info);
+ chkxer_("SGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGEQRS */
+
+ s_copy(srnamc_1.srnamt, "SGEQRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgeqrs_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("SGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgeqrs_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("SGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgeqrs_(&c__1, &c__2, &c__0, a, &c__2, x, b, &c__2, w, &c__1, &info);
+ chkxer_("SGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgeqrs_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("SGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgeqrs_(&c__2, &c__1, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
+ chkxer_("SGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sgeqrs_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
+ chkxer_("SGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sgeqrs_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("SGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SORGQR */
+
+ s_copy(srnamc_1.srnamt, "SORGQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sorgqr_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("SORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sorgqr_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("SORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sorgqr_(&c__1, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
+ chkxer_("SORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorgqr_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
+ chkxer_("SORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorgqr_(&c__1, &c__1, &c__2, a, &c__1, x, w, &c__1, &info);
+ chkxer_("SORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sorgqr_(&c__2, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
+ chkxer_("SORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sorgqr_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
+ chkxer_("SORGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SORG2R */
+
+ s_copy(srnamc_1.srnamt, "SORG2R", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sorg2r_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
+ chkxer_("SORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sorg2r_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("SORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sorg2r_(&c__1, &c__2, &c__0, a, &c__1, x, w, &info);
+ chkxer_("SORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorg2r_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
+ chkxer_("SORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorg2r_(&c__2, &c__1, &c__2, a, &c__2, x, w, &info);
+ chkxer_("SORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sorg2r_(&c__2, &c__1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("SORG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SORMQR */
+
+ s_copy(srnamc_1.srnamt, "SORMQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sormqr_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sormqr_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sormqr_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sormqr_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sormqr_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sormqr_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sormqr_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sormqr_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sormqr_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sormqr_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sormqr_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sormqr_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("SORMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SORM2R */
+
+ s_copy(srnamc_1.srnamt, "SORM2R", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sorm2r_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sorm2r_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorm2r_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sorm2r_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sorm2r_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sorm2r_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sorm2r_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sorm2r_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &info);
+ chkxer_("SORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sorm2r_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sorm2r_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &info);
+ chkxer_("SORM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of SERRQR */
+
+} /* serrqr_ */
diff --git a/TESTING/LIN/serrrfp.c b/TESTING/LIN/serrrfp.c
new file mode 100644
index 0000000..bf2f7c7
--- /dev/null
+++ b/TESTING/LIN/serrrfp.c
@@ -0,0 +1,355 @@
+/* serrrfp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+
+/* Subroutine */ int serrrfp_(integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002REAL RFP routines passed the tests of"
+ " \002,\002the error exits\002)";
+ static char fmt_9998[] = "(\002 *** RFP routines failed the tests of the"
+ " error \002,\002exits ***\002)";
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), e_wsfe(void);
+
+ /* Local variables */
+ real a[1] /* was [1][1] */, b[1] /* was [1][1] */, beta;
+ integer info;
+ real alpha;
+ extern /* Subroutine */ int ssfrk_(char *, char *, char *, integer *,
+ integer *, real *, real *, integer *, real *, real *), stfsm_(char *, char *, char *, char *, char *,
+ integer *, integer *, real *, real *, real *, integer *), chkxer_(char *, integer *,
+ integer *, logical *, logical *), spftrf_(char *, char *,
+ integer *, real *, integer *), spftri_(char *,
+ char *, integer *, real *, integer *), stftri_(
+ char *, char *, char *, integer *, real *, integer *), spftrs_(char *, char *, integer *, integer *,
+ real *, real *, integer *, integer *), stfttp_(
+ char *, char *, integer *, real *, real *, integer *), stpttf_(char *, char *, integer *, real *, real *,
+ integer *), stfttr_(char *, char *, integer *,
+ real *, real *, integer *, integer *), strttf_(
+ char *, char *, integer *, real *, integer *, real *, integer *), stpttr_(char *, integer *, real *, real *,
+ integer *, integer *), strttp_(char *, integer *, real *,
+ integer *, real *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___7 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SERRRFP tests the error exits for the REAL driver routines */
+/* for solving linear systems of equations. */
+
+/* SDRVRFP tests the REAL LAPACK RFP routines: */
+/* STFSM, STFTRI, SSFRK, STFTTP, STFTTR, SPFTRF, SPFTRS, STPTTF, */
+/* STPTTR, STRTTF, and STRTTP */
+
+/* Arguments */
+/* ========= */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ infoc_1.ok = TRUE_;
+ a[0] = 1.f;
+ b[0] = 1.f;
+ alpha = 1.f;
+ beta = 1.f;
+
+ s_copy(srnamc_1.srnamt, "SPFTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spftrf_("/", "U", &c__0, a, &info);
+ chkxer_("SPFTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spftrf_("N", "/", &c__0, a, &info);
+ chkxer_("SPFTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spftrf_("N", "U", &c_n1, a, &info);
+ chkxer_("SPFTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "SPFTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spftrs_("/", "U", &c__0, &c__0, a, b, &c__1, &info);
+ chkxer_("SPFTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spftrs_("N", "/", &c__0, &c__0, a, b, &c__1, &info);
+ chkxer_("SPFTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spftrs_("N", "U", &c_n1, &c__0, a, b, &c__1, &info);
+ chkxer_("SPFTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ spftrs_("N", "U", &c__0, &c_n1, a, b, &c__1, &info);
+ chkxer_("SPFTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ spftrs_("N", "U", &c__0, &c__0, a, b, &c__0, &info);
+ chkxer_("SPFTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "SPFTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spftri_("/", "U", &c__0, a, &info);
+ chkxer_("SPFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spftri_("N", "/", &c__0, a, &info);
+ chkxer_("SPFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spftri_("N", "U", &c_n1, a, &info);
+ chkxer_("SPFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "STFSM ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ stfsm_("/", "L", "U", "T", "U", &c__0, &c__0, &alpha, a, b, &c__1);
+ chkxer_("STFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ stfsm_("N", "/", "U", "T", "U", &c__0, &c__0, &alpha, a, b, &c__1);
+ chkxer_("STFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ stfsm_("N", "L", "/", "T", "U", &c__0, &c__0, &alpha, a, b, &c__1);
+ chkxer_("STFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ stfsm_("N", "L", "U", "/", "U", &c__0, &c__0, &alpha, a, b, &c__1);
+ chkxer_("STFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ stfsm_("N", "L", "U", "T", "/", &c__0, &c__0, &alpha, a, b, &c__1);
+ chkxer_("STFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ stfsm_("N", "L", "U", "T", "U", &c_n1, &c__0, &alpha, a, b, &c__1);
+ chkxer_("STFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ stfsm_("N", "L", "U", "T", "U", &c__0, &c_n1, &alpha, a, b, &c__1);
+ chkxer_("STFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ stfsm_("N", "L", "U", "T", "U", &c__0, &c__0, &alpha, a, b, &c__0);
+ chkxer_("STFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "STFTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ stftri_("/", "L", "N", &c__0, a, &info);
+ chkxer_("STFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ stftri_("N", "/", "N", &c__0, a, &info);
+ chkxer_("STFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ stftri_("N", "L", "/", &c__0, a, &info);
+ chkxer_("STFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ stftri_("N", "L", "N", &c_n1, a, &info);
+ chkxer_("STFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "STFTTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ stfttr_("/", "U", &c__0, a, b, &c__1, &info);
+ chkxer_("STFTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ stfttr_("N", "/", &c__0, a, b, &c__1, &info);
+ chkxer_("STFTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ stfttr_("N", "U", &c_n1, a, b, &c__1, &info);
+ chkxer_("STFTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ stfttr_("N", "U", &c__0, a, b, &c__0, &info);
+ chkxer_("STFTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "STRTTF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ strttf_("/", "U", &c__0, a, &c__1, b, &info);
+ chkxer_("STRTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ strttf_("N", "/", &c__0, a, &c__1, b, &info);
+ chkxer_("STRTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ strttf_("N", "U", &c_n1, a, &c__1, b, &info);
+ chkxer_("STRTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ strttf_("N", "U", &c__0, a, &c__0, b, &info);
+ chkxer_("STRTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "STFTTP", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ stfttp_("/", "U", &c__0, a, b, &info);
+ chkxer_("STFTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ stfttp_("N", "/", &c__0, a, b, &info);
+ chkxer_("STFTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ stfttp_("N", "U", &c_n1, a, b, &info);
+ chkxer_("STFTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "STPTTF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ stpttf_("/", "U", &c__0, a, b, &info);
+ chkxer_("STPTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ stpttf_("N", "/", &c__0, a, b, &info);
+ chkxer_("STPTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ stpttf_("N", "U", &c_n1, a, b, &info);
+ chkxer_("STPTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "STRTTP", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ strttp_("/", &c__0, a, &c__1, b, &info);
+ chkxer_("STRTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ strttp_("U", &c_n1, a, &c__1, b, &info);
+ chkxer_("STRTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ strttp_("U", &c__0, a, &c__0, b, &info);
+ chkxer_("STRTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "STPTTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ stpttr_("/", &c__0, a, b, &c__1, &info);
+ chkxer_("STPTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ stpttr_("U", &c_n1, a, b, &c__1, &info);
+ chkxer_("STPTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ stpttr_("U", &c__0, a, b, &c__0, &info);
+ chkxer_("STPTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "SSFRK ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssfrk_("/", "U", "N", &c__0, &c__0, &alpha, a, &c__1, &beta, b);
+ chkxer_("SSFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ssfrk_("N", "/", "N", &c__0, &c__0, &alpha, a, &c__1, &beta, b);
+ chkxer_("SSFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ssfrk_("N", "U", "/", &c__0, &c__0, &alpha, a, &c__1, &beta, b);
+ chkxer_("SSFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ssfrk_("N", "U", "N", &c_n1, &c__0, &alpha, a, &c__1, &beta, b);
+ chkxer_("SSFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ssfrk_("N", "U", "N", &c__0, &c_n1, &alpha, a, &c__1, &beta, b);
+ chkxer_("SSFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ssfrk_("N", "U", "N", &c__0, &c__0, &alpha, a, &c__0, &beta, b);
+ chkxer_("SSFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___6.ciunit = infoc_1.nout;
+ s_wsfe(&io___6);
+ e_wsfe();
+ } else {
+ io___7.ciunit = infoc_1.nout;
+ s_wsfe(&io___7);
+ e_wsfe();
+ }
+
+ return 0;
+
+/* End of SERRRFP */
+
+} /* serrrfp_ */
diff --git a/TESTING/LIN/serrrq.c b/TESTING/LIN/serrrq.c
new file mode 100644
index 0000000..cded4a1
--- /dev/null
+++ b/TESTING/LIN/serrrq.c
@@ -0,0 +1,375 @@
+/* serrrq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int serrrq_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real a[4] /* was [2][2] */, b[2];
+ integer i__, j;
+ real w[2], x[2], af[4] /* was [2][2] */;
+ integer info;
+ extern /* Subroutine */ int sgerq2_(integer *, integer *, real *, integer
+ *, real *, real *, integer *), sorgr2_(integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *), sormr2_(
+ char *, char *, integer *, integer *, integer *, real *, integer *
+, real *, real *, integer *, real *, integer *),
+ alaesm_(char *, logical *, integer *), chkxer_(char *,
+ integer *, integer *, logical *, logical *), sgerqf_(
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, integer *), sgerqs_(integer *, integer *, integer *, real *,
+ integer *, real *, real *, integer *, real *, integer *, integer *
+), sorgrq_(integer *, integer *, integer *, real *, integer *,
+ real *, real *, integer *, integer *), sormrq_(char *, char *,
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, integer *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SERRRQ tests the error exits for the REAL routines */
+/* that use the RQ decomposition of a general matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 2; ++j) {
+ for (i__ = 1; i__ <= 2; ++i__) {
+ a[i__ + (j << 1) - 3] = 1.f / (real) (i__ + j);
+ af[i__ + (j << 1) - 3] = 1.f / (real) (i__ + j);
+/* L10: */
+ }
+ b[j - 1] = 0.f;
+ w[j - 1] = 0.f;
+ x[j - 1] = 0.f;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+/* Error exits for RQ factorization */
+
+/* SGERQF */
+
+ s_copy(srnamc_1.srnamt, "SGERQF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgerqf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
+ chkxer_("SGERQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgerqf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("SGERQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgerqf_(&c__2, &c__1, a, &c__1, b, w, &c__2, &info);
+ chkxer_("SGERQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sgerqf_(&c__2, &c__1, a, &c__2, b, w, &c__1, &info);
+ chkxer_("SGERQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGERQ2 */
+
+ s_copy(srnamc_1.srnamt, "SGERQ2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgerq2_(&c_n1, &c__0, a, &c__1, b, w, &info);
+ chkxer_("SGERQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgerq2_(&c__0, &c_n1, a, &c__1, b, w, &info);
+ chkxer_("SGERQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgerq2_(&c__2, &c__1, a, &c__1, b, w, &info);
+ chkxer_("SGERQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGERQS */
+
+ s_copy(srnamc_1.srnamt, "SGERQS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgerqs_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("SGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgerqs_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("SGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgerqs_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
+ chkxer_("SGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgerqs_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("SGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgerqs_(&c__2, &c__2, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
+ chkxer_("SGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sgerqs_(&c__2, &c__2, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
+ chkxer_("SGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sgerqs_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("SGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SORGRQ */
+
+ s_copy(srnamc_1.srnamt, "SORGRQ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sorgrq_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("SORGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sorgrq_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("SORGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sorgrq_(&c__2, &c__1, &c__0, a, &c__2, x, w, &c__2, &info);
+ chkxer_("SORGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorgrq_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
+ chkxer_("SORGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorgrq_(&c__1, &c__2, &c__2, a, &c__1, x, w, &c__1, &info);
+ chkxer_("SORGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sorgrq_(&c__2, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
+ chkxer_("SORGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sorgrq_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
+ chkxer_("SORGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SORGR2 */
+
+ s_copy(srnamc_1.srnamt, "SORGR2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sorgr2_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
+ chkxer_("SORGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sorgr2_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("SORGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sorgr2_(&c__2, &c__1, &c__0, a, &c__2, x, w, &info);
+ chkxer_("SORGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorgr2_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
+ chkxer_("SORGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sorgr2_(&c__1, &c__2, &c__2, a, &c__2, x, w, &info);
+ chkxer_("SORGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sorgr2_(&c__2, &c__2, &c__0, a, &c__1, x, w, &info);
+ chkxer_("SORGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SORMRQ */
+
+ s_copy(srnamc_1.srnamt, "SORMRQ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sormrq_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sormrq_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sormrq_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sormrq_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sormrq_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sormrq_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sormrq_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sormrq_("L", "N", &c__2, &c__1, &c__2, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("SORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sormrq_("R", "N", &c__1, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sormrq_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sormrq_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("SORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sormrq_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("SORMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SORMR2 */
+
+ s_copy(srnamc_1.srnamt, "SORMR2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sormr2_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sormr2_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sormr2_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sormr2_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sormr2_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sormr2_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sormr2_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sormr2_("L", "N", &c__2, &c__1, &c__2, a, &c__1, x, af, &c__2, w, &info);
+ chkxer_("SORMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sormr2_("R", "N", &c__1, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sormr2_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("SORMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of SERRRQ */
+
+} /* serrrq_ */
diff --git a/TESTING/LIN/serrsy.c b/TESTING/LIN/serrsy.c
new file mode 100644
index 0000000..fbd112e
--- /dev/null
+++ b/TESTING/LIN/serrsy.c
@@ -0,0 +1,388 @@
+/* serrsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__4 = 4;
+static real c_b152 = -1.f;
+
+/* Subroutine */ int serrsy_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real a[16] /* was [4][4] */, b[4];
+ integer i__, j;
+ real w[12], x[4];
+ char c2[2];
+ real r1[4], r2[4], af[16] /* was [4][4] */;
+ integer ip[4], iw[4], info;
+ real anrm, rcond;
+ extern /* Subroutine */ int ssytf2_(char *, integer *, real *, integer *,
+ integer *, integer *), alaesm_(char *, logical *, integer
+ *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), sspcon_(char *, integer *, real *, integer
+ *, real *, real *, real *, integer *, integer *), ssycon_(
+ char *, integer *, real *, integer *, integer *, real *, real *,
+ real *, integer *, integer *), ssprfs_(char *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ integer *, real *, real *, real *, integer *, integer *),
+ ssptrf_(char *, integer *, real *, integer *, integer *),
+ ssptri_(char *, integer *, real *, integer *, real *, integer *), ssyrfs_(char *, integer *, integer *, real *, integer *,
+ real *, integer *, integer *, real *, integer *, real *, integer *
+, real *, real *, real *, integer *, integer *), ssytrf_(
+ char *, integer *, real *, integer *, integer *, real *, integer *
+, integer *), ssytri_(char *, integer *, real *, integer *
+, integer *, real *, integer *), ssptrs_(char *, integer *
+, integer *, real *, integer *, real *, integer *, integer *), ssytrs_(char *, integer *, integer *, real *, integer *,
+ integer *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SERRSY tests the error exits for the REAL routines */
+/* for symmetric indefinite matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (j << 2) - 5] = 1.f / (real) (i__ + j);
+ af[i__ + (j << 2) - 5] = 1.f / (real) (i__ + j);
+/* L10: */
+ }
+ b[j - 1] = 0.f;
+ r1[j - 1] = 0.f;
+ r2[j - 1] = 0.f;
+ w[j - 1] = 0.f;
+ x[j - 1] = 0.f;
+ ip[j - 1] = j;
+ iw[j - 1] = j;
+/* L20: */
+ }
+ anrm = 1.f;
+ rcond = 1.f;
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "SY")) {
+
+/* Test error exits of the routines that use the Bunch-Kaufman */
+/* factorization of a symmetric indefinite matrix. */
+
+/* SSYTRF */
+
+ s_copy(srnamc_1.srnamt, "SSYTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssytrf_("/", &c__0, a, &c__1, ip, w, &c__1, &info);
+ chkxer_("SSYTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ssytrf_("U", &c_n1, a, &c__1, ip, w, &c__1, &info);
+ chkxer_("SSYTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ssytrf_("U", &c__2, a, &c__1, ip, w, &c__4, &info);
+ chkxer_("SSYTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SSYTF2 */
+
+ s_copy(srnamc_1.srnamt, "SSYTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssytf2_("/", &c__0, a, &c__1, ip, &info);
+ chkxer_("SSYTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ssytf2_("U", &c_n1, a, &c__1, ip, &info);
+ chkxer_("SSYTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ssytf2_("U", &c__2, a, &c__1, ip, &info);
+ chkxer_("SSYTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SSYTRI */
+
+ s_copy(srnamc_1.srnamt, "SSYTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssytri_("/", &c__0, a, &c__1, ip, w, &info);
+ chkxer_("SSYTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ssytri_("U", &c_n1, a, &c__1, ip, w, &info);
+ chkxer_("SSYTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ssytri_("U", &c__2, a, &c__1, ip, w, &info);
+ chkxer_("SSYTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SSYTRS */
+
+ s_copy(srnamc_1.srnamt, "SSYTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssytrs_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("SSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ssytrs_("U", &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("SSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ssytrs_("U", &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("SSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ssytrs_("U", &c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
+ chkxer_("SSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ssytrs_("U", &c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
+ chkxer_("SSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SSYRFS */
+
+ s_copy(srnamc_1.srnamt, "SSYRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssyrfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("SSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ssyrfs_("U", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("SSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ssyrfs_("U", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("SSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ssyrfs_("U", &c__2, &c__1, a, &c__1, af, &c__2, ip, b, &c__2, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("SSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ssyrfs_("U", &c__2, &c__1, a, &c__2, af, &c__1, ip, b, &c__2, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("SSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ssyrfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__1, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("SSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ ssyrfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__2, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("SSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SSYCON */
+
+ s_copy(srnamc_1.srnamt, "SSYCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssycon_("/", &c__0, a, &c__1, ip, &anrm, &rcond, w, iw, &info);
+ chkxer_("SSYCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ssycon_("U", &c_n1, a, &c__1, ip, &anrm, &rcond, w, iw, &info);
+ chkxer_("SSYCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ssycon_("U", &c__2, a, &c__1, ip, &anrm, &rcond, w, iw, &info);
+ chkxer_("SSYCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ssycon_("U", &c__1, a, &c__1, ip, &c_b152, &rcond, w, iw, &info);
+ chkxer_("SSYCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "SP")) {
+
+/* Test error exits of the routines that use the Bunch-Kaufman */
+/* factorization of a symmetric indefinite packed matrix. */
+
+/* SSPTRF */
+
+ s_copy(srnamc_1.srnamt, "SSPTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssptrf_("/", &c__0, a, ip, &info);
+ chkxer_("SSPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ssptrf_("U", &c_n1, a, ip, &info);
+ chkxer_("SSPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SSPTRI */
+
+ s_copy(srnamc_1.srnamt, "SSPTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssptri_("/", &c__0, a, ip, w, &info);
+ chkxer_("SSPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ssptri_("U", &c_n1, a, ip, w, &info);
+ chkxer_("SSPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SSPTRS */
+
+ s_copy(srnamc_1.srnamt, "SSPTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssptrs_("/", &c__0, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("SSPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ssptrs_("U", &c_n1, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("SSPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ssptrs_("U", &c__0, &c_n1, a, ip, b, &c__1, &info);
+ chkxer_("SSPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ssptrs_("U", &c__2, &c__1, a, ip, b, &c__1, &info);
+ chkxer_("SSPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SSPRFS */
+
+ s_copy(srnamc_1.srnamt, "SSPRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssprfs_("/", &c__0, &c__0, a, af, ip, b, &c__1, x, &c__1, r1, r2, w,
+ iw, &info);
+ chkxer_("SSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ssprfs_("U", &c_n1, &c__0, a, af, ip, b, &c__1, x, &c__1, r1, r2, w,
+ iw, &info);
+ chkxer_("SSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ssprfs_("U", &c__0, &c_n1, a, af, ip, b, &c__1, x, &c__1, r1, r2, w,
+ iw, &info);
+ chkxer_("SSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ssprfs_("U", &c__2, &c__1, a, af, ip, b, &c__1, x, &c__2, r1, r2, w,
+ iw, &info);
+ chkxer_("SSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ssprfs_("U", &c__2, &c__1, a, af, ip, b, &c__2, x, &c__1, r1, r2, w,
+ iw, &info);
+ chkxer_("SSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SSPCON */
+
+ s_copy(srnamc_1.srnamt, "SSPCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sspcon_("/", &c__0, a, ip, &anrm, &rcond, w, iw, &info);
+ chkxer_("SSPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sspcon_("U", &c_n1, a, ip, &anrm, &rcond, w, iw, &info);
+ chkxer_("SSPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sspcon_("U", &c__1, a, ip, &c_b152, &rcond, w, iw, &info);
+ chkxer_("SSPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of SERRSY */
+
+} /* serrsy_ */
diff --git a/TESTING/LIN/serrtr.c b/TESTING/LIN/serrtr.c
new file mode 100644
index 0000000..e3f10a9
--- /dev/null
+++ b/TESTING/LIN/serrtr.c
@@ -0,0 +1,607 @@
+/* serrtr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int serrtr_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real a[4] /* was [2][2] */, b[2], w[2], x[2];
+ char c2[2];
+ real r1[2], r2[2];
+ integer iw[2], info;
+ real scale, rcond;
+ extern /* Subroutine */ int strti2_(char *, char *, integer *, real *,
+ integer *, integer *), alaesm_(char *, logical *,
+ integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), slatbs_(char *, char *, char *, char *,
+ integer *, integer *, real *, integer *, real *, real *, real *,
+ integer *), stbcon_(char *, char *
+, char *, integer *, integer *, real *, integer *, real *, real *,
+ integer *, integer *), stbrfs_(char *,
+ char *, char *, integer *, integer *, integer *, real *, integer *
+, real *, integer *, real *, integer *, real *, real *, real *,
+ integer *, integer *), slatps_(char *,
+ char *, char *, char *, integer *, real *, real *, real *, real *,
+ integer *), stpcon_(char *, char
+ *, char *, integer *, real *, real *, real *, integer *, integer *
+), slatrs_(char *, char *, char *, char *,
+ integer *, real *, integer *, real *, real *, real *, integer *), strcon_(char *, char *, char *,
+ integer *, real *, integer *, real *, real *, integer *, integer *
+), stbtrs_(char *, char *, char *,
+ integer *, integer *, integer *, real *, integer *, real *,
+ integer *, integer *), stprfs_(char *,
+ char *, char *, integer *, integer *, real *, real *, integer *,
+ real *, integer *, real *, real *, real *, integer *, integer *), strrfs_(char *, char *, char *, integer *
+, integer *, real *, integer *, real *, integer *, real *,
+ integer *, real *, real *, real *, integer *, integer *), stptri_(char *, char *, integer *, real *,
+ integer *), strtri_(char *, char *, integer *,
+ real *, integer *, integer *), stptrs_(char *,
+ char *, char *, integer *, integer *, real *, real *, integer *,
+ integer *), strtrs_(char *, char *, char *
+, integer *, integer *, real *, integer *, real *, integer *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SERRTR tests the error exits for the REAL triangular */
+/* routines. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ a[0] = 1.f;
+ a[2] = 2.f;
+ a[3] = 3.f;
+ a[1] = 4.f;
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "TR")) {
+
+/* Test error exits for the general triangular routines. */
+
+/* STRTRI */
+
+ s_copy(srnamc_1.srnamt, "STRTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ strtri_("/", "N", &c__0, a, &c__1, &info);
+ chkxer_("STRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ strtri_("U", "/", &c__0, a, &c__1, &info);
+ chkxer_("STRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ strtri_("U", "N", &c_n1, a, &c__1, &info);
+ chkxer_("STRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ strtri_("U", "N", &c__2, a, &c__1, &info);
+ chkxer_("STRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* STRTI2 */
+
+ s_copy(srnamc_1.srnamt, "STRTI2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ strti2_("/", "N", &c__0, a, &c__1, &info);
+ chkxer_("STRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ strti2_("U", "/", &c__0, a, &c__1, &info);
+ chkxer_("STRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ strti2_("U", "N", &c_n1, a, &c__1, &info);
+ chkxer_("STRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ strti2_("U", "N", &c__2, a, &c__1, &info);
+ chkxer_("STRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* STRTRS */
+
+ s_copy(srnamc_1.srnamt, "STRTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ strtrs_("/", "N", "N", &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("STRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ strtrs_("U", "/", "N", &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("STRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ strtrs_("U", "N", "/", &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("STRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ strtrs_("U", "N", "N", &c_n1, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("STRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ strtrs_("U", "N", "N", &c__0, &c_n1, a, &c__1, x, &c__1, &info);
+ chkxer_("STRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ strtrs_("U", "N", "N", &c__2, &c__1, a, &c__1, x, &c__2, &info);
+ chkxer_("STRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ strtrs_("U", "N", "N", &c__2, &c__1, a, &c__2, x, &c__1, &info);
+ chkxer_("STRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* STRRFS */
+
+ s_copy(srnamc_1.srnamt, "STRRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ strrfs_("/", "N", "N", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
+ r2, w, iw, &info);
+ chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ strrfs_("U", "/", "N", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
+ r2, w, iw, &info);
+ chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ strrfs_("U", "N", "/", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
+ r2, w, iw, &info);
+ chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ strrfs_("U", "N", "N", &c_n1, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
+ r2, w, iw, &info);
+ chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ strrfs_("U", "N", "N", &c__0, &c_n1, a, &c__1, b, &c__1, x, &c__1, r1,
+ r2, w, iw, &info);
+ chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ strrfs_("U", "N", "N", &c__2, &c__1, a, &c__1, b, &c__2, x, &c__2, r1,
+ r2, w, iw, &info);
+ chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ strrfs_("U", "N", "N", &c__2, &c__1, a, &c__2, b, &c__1, x, &c__2, r1,
+ r2, w, iw, &info);
+ chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ strrfs_("U", "N", "N", &c__2, &c__1, a, &c__2, b, &c__2, x, &c__1, r1,
+ r2, w, iw, &info);
+ chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* STRCON */
+
+ s_copy(srnamc_1.srnamt, "STRCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ strcon_("/", "U", "N", &c__0, a, &c__1, &rcond, w, iw, &info);
+ chkxer_("STRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ strcon_("1", "/", "N", &c__0, a, &c__1, &rcond, w, iw, &info);
+ chkxer_("STRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ strcon_("1", "U", "/", &c__0, a, &c__1, &rcond, w, iw, &info);
+ chkxer_("STRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ strcon_("1", "U", "N", &c_n1, a, &c__1, &rcond, w, iw, &info);
+ chkxer_("STRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ strcon_("1", "U", "N", &c__2, a, &c__1, &rcond, w, iw, &info);
+ chkxer_("STRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SLATRS */
+
+ s_copy(srnamc_1.srnamt, "SLATRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ slatrs_("/", "N", "N", "N", &c__0, a, &c__1, x, &scale, w, &info);
+ chkxer_("SLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ slatrs_("U", "/", "N", "N", &c__0, a, &c__1, x, &scale, w, &info);
+ chkxer_("SLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ slatrs_("U", "N", "/", "N", &c__0, a, &c__1, x, &scale, w, &info);
+ chkxer_("SLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ slatrs_("U", "N", "N", "/", &c__0, a, &c__1, x, &scale, w, &info);
+ chkxer_("SLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ slatrs_("U", "N", "N", "N", &c_n1, a, &c__1, x, &scale, w, &info);
+ chkxer_("SLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ slatrs_("U", "N", "N", "N", &c__2, a, &c__1, x, &scale, w, &info);
+ chkxer_("SLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "TP")) {
+
+/* Test error exits for the packed triangular routines. */
+
+/* STPTRI */
+
+ s_copy(srnamc_1.srnamt, "STPTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ stptri_("/", "N", &c__0, a, &info);
+ chkxer_("STPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ stptri_("U", "/", &c__0, a, &info);
+ chkxer_("STPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ stptri_("U", "N", &c_n1, a, &info);
+ chkxer_("STPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* STPTRS */
+
+ s_copy(srnamc_1.srnamt, "STPTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ stptrs_("/", "N", "N", &c__0, &c__0, a, x, &c__1, &info);
+ chkxer_("STPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ stptrs_("U", "/", "N", &c__0, &c__0, a, x, &c__1, &info);
+ chkxer_("STPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ stptrs_("U", "N", "/", &c__0, &c__0, a, x, &c__1, &info);
+ chkxer_("STPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ stptrs_("U", "N", "N", &c_n1, &c__0, a, x, &c__1, &info);
+ chkxer_("STPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ stptrs_("U", "N", "N", &c__0, &c_n1, a, x, &c__1, &info);
+ chkxer_("STPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ stptrs_("U", "N", "N", &c__2, &c__1, a, x, &c__1, &info);
+ chkxer_("STPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* STPRFS */
+
+ s_copy(srnamc_1.srnamt, "STPRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ stprfs_("/", "N", "N", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
+ iw, &info);
+ chkxer_("STPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ stprfs_("U", "/", "N", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
+ iw, &info);
+ chkxer_("STPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ stprfs_("U", "N", "/", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
+ iw, &info);
+ chkxer_("STPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ stprfs_("U", "N", "N", &c_n1, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
+ iw, &info);
+ chkxer_("STPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ stprfs_("U", "N", "N", &c__0, &c_n1, a, b, &c__1, x, &c__1, r1, r2, w,
+ iw, &info);
+ chkxer_("STPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ stprfs_("U", "N", "N", &c__2, &c__1, a, b, &c__1, x, &c__2, r1, r2, w,
+ iw, &info);
+ chkxer_("STPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ stprfs_("U", "N", "N", &c__2, &c__1, a, b, &c__2, x, &c__1, r1, r2, w,
+ iw, &info);
+ chkxer_("STPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* STPCON */
+
+ s_copy(srnamc_1.srnamt, "STPCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ stpcon_("/", "U", "N", &c__0, a, &rcond, w, iw, &info);
+ chkxer_("STPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ stpcon_("1", "/", "N", &c__0, a, &rcond, w, iw, &info);
+ chkxer_("STPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ stpcon_("1", "U", "/", &c__0, a, &rcond, w, iw, &info);
+ chkxer_("STPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ stpcon_("1", "U", "N", &c_n1, a, &rcond, w, iw, &info);
+ chkxer_("STPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SLATPS */
+
+ s_copy(srnamc_1.srnamt, "SLATPS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ slatps_("/", "N", "N", "N", &c__0, a, x, &scale, w, &info);
+ chkxer_("SLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ slatps_("U", "/", "N", "N", &c__0, a, x, &scale, w, &info);
+ chkxer_("SLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ slatps_("U", "N", "/", "N", &c__0, a, x, &scale, w, &info);
+ chkxer_("SLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ slatps_("U", "N", "N", "/", &c__0, a, x, &scale, w, &info);
+ chkxer_("SLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ slatps_("U", "N", "N", "N", &c_n1, a, x, &scale, w, &info);
+ chkxer_("SLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "TB")) {
+
+/* Test error exits for the banded triangular routines. */
+
+/* STBTRS */
+
+ s_copy(srnamc_1.srnamt, "STBTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ stbtrs_("/", "N", "N", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ stbtrs_("U", "/", "N", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ stbtrs_("U", "N", "/", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ stbtrs_("U", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ stbtrs_("U", "N", "N", &c__0, &c_n1, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ stbtrs_("U", "N", "N", &c__0, &c__0, &c_n1, a, &c__1, x, &c__1, &info);
+ chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ stbtrs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__1, x, &c__2, &info);
+ chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ stbtrs_("U", "N", "N", &c__2, &c__0, &c__1, a, &c__1, x, &c__1, &info);
+ chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* STBRFS */
+
+ s_copy(srnamc_1.srnamt, "STBRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ stbrfs_("/", "N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ stbrfs_("U", "/", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ stbrfs_("U", "N", "/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ stbrfs_("U", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ stbrfs_("U", "N", "N", &c__0, &c_n1, &c__0, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ stbrfs_("U", "N", "N", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ stbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__1, b, &c__2, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ stbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__1, x, &
+ c__2, r1, r2, w, iw, &info);
+ chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ stbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, x, &
+ c__1, r1, r2, w, iw, &info);
+ chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* STBCON */
+
+ s_copy(srnamc_1.srnamt, "STBCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ stbcon_("/", "U", "N", &c__0, &c__0, a, &c__1, &rcond, w, iw, &info);
+ chkxer_("STBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ stbcon_("1", "/", "N", &c__0, &c__0, a, &c__1, &rcond, w, iw, &info);
+ chkxer_("STBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ stbcon_("1", "U", "/", &c__0, &c__0, a, &c__1, &rcond, w, iw, &info);
+ chkxer_("STBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ stbcon_("1", "U", "N", &c_n1, &c__0, a, &c__1, &rcond, w, iw, &info);
+ chkxer_("STBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ stbcon_("1", "U", "N", &c__0, &c_n1, a, &c__1, &rcond, w, iw, &info);
+ chkxer_("STBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ stbcon_("1", "U", "N", &c__2, &c__1, a, &c__1, &rcond, w, iw, &info);
+ chkxer_("STBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SLATBS */
+
+ s_copy(srnamc_1.srnamt, "SLATBS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ slatbs_("/", "N", "N", "N", &c__0, &c__0, a, &c__1, x, &scale, w, &
+ info);
+ chkxer_("SLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ slatbs_("U", "/", "N", "N", &c__0, &c__0, a, &c__1, x, &scale, w, &
+ info);
+ chkxer_("SLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ slatbs_("U", "N", "/", "N", &c__0, &c__0, a, &c__1, x, &scale, w, &
+ info);
+ chkxer_("SLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ slatbs_("U", "N", "N", "/", &c__0, &c__0, a, &c__1, x, &scale, w, &
+ info);
+ chkxer_("SLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ slatbs_("U", "N", "N", "N", &c_n1, &c__0, a, &c__1, x, &scale, w, &
+ info);
+ chkxer_("SLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ slatbs_("U", "N", "N", "N", &c__1, &c_n1, a, &c__1, x, &scale, w, &
+ info);
+ chkxer_("SLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ slatbs_("U", "N", "N", "N", &c__2, &c__1, a, &c__1, x, &scale, w, &
+ info);
+ chkxer_("SLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of SERRTR */
+
+} /* serrtr_ */
diff --git a/TESTING/LIN/serrtz.c b/TESTING/LIN/serrtz.c
new file mode 100644
index 0000000..1ebda4c
--- /dev/null
+++ b/TESTING/LIN/serrtz.c
@@ -0,0 +1,162 @@
+/* serrtz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int serrtz_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real a[4] /* was [2][2] */, w[2];
+ char c2[2];
+ real tau[2];
+ integer info;
+ extern /* Subroutine */ int alaesm_(char *, logical *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), stzrqf_(integer *, integer *, real *,
+ integer *, real *, integer *), stzrzf_(integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SERRTZ tests the error exits for STZRQF and STZRZF. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ a[0] = 1.f;
+ a[2] = 2.f;
+ a[3] = 3.f;
+ a[1] = 4.f;
+ w[0] = 0.f;
+ w[1] = 0.f;
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "TZ")) {
+
+/* Test error exits for the trapezoidal routines. */
+
+/* STZRQF */
+
+ s_copy(srnamc_1.srnamt, "STZRQF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ stzrqf_(&c_n1, &c__0, a, &c__1, tau, &info);
+ chkxer_("STZRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ stzrqf_(&c__1, &c__0, a, &c__1, tau, &info);
+ chkxer_("STZRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ stzrqf_(&c__2, &c__2, a, &c__1, tau, &info);
+ chkxer_("STZRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* STZRZF */
+
+ s_copy(srnamc_1.srnamt, "STZRZF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ stzrzf_(&c_n1, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("STZRZF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ stzrzf_(&c__1, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("STZRZF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ stzrzf_(&c__2, &c__2, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("STZRZF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ stzrzf_(&c__2, &c__2, a, &c__2, tau, w, &c__1, &info);
+ chkxer_("STZRZF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of SERRTZ */
+
+} /* serrtz_ */
diff --git a/TESTING/LIN/serrvx.c b/TESTING/LIN/serrvx.c
new file mode 100644
index 0000000..cf09e98
--- /dev/null
+++ b/TESTING/LIN/serrvx.c
@@ -0,0 +1,874 @@
+/* serrvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__4 = 4;
+
+/* Subroutine */ int serrvx_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 drivers passed the tests of the er"
+ "ror exits\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 drivers failed the test"
+ "s of the error \002,\002exits ***\002)";
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ real a[16] /* was [4][4] */, b[4], c__[4];
+ integer i__, j;
+ real r__[4], w[8], x[4];
+ char c2[2];
+ real r1[4], r2[4], af[16] /* was [4][4] */;
+ char eq[1];
+ integer ip[4], iw[4], info;
+ real rcond;
+ extern /* Subroutine */ int sgbsv_(integer *, integer *, integer *,
+ integer *, real *, integer *, integer *, real *, integer *,
+ integer *), sgesv_(integer *, integer *, real *, integer *,
+ integer *, real *, integer *, integer *), spbsv_(char *, integer *
+, integer *, integer *, real *, integer *, real *, integer *,
+ integer *), sgtsv_(integer *, integer *, real *, real *,
+ real *, real *, integer *, integer *), sposv_(char *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *), sppsv_(char *, integer *, integer *, real *, real *,
+ integer *, integer *), sspsv_(char *, integer *, integer *
+, real *, integer *, real *, integer *, integer *),
+ sptsv_(integer *, integer *, real *, real *, real *, integer *,
+ integer *), ssysv_(char *, integer *, integer *, real *, integer *
+, integer *, real *, integer *, real *, integer *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), sgbsvx_(char *, char *, integer *, integer
+ *, integer *, integer *, real *, integer *, real *, integer *,
+ integer *, char *, real *, real *, real *, integer *, real *,
+ integer *, real *, real *, real *, real *, integer *, integer *), sgesvx_(char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *, char *
+, real *, real *, real *, integer *, real *, integer *, real *,
+ real *, real *, real *, integer *, integer *), spbsvx_(char *, char *, integer *, integer *, integer *,
+ real *, integer *, real *, integer *, char *, real *, real *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ integer *, integer *), sgtsvx_(char *,
+ char *, integer *, integer *, real *, real *, real *, real *,
+ real *, real *, real *, integer *, real *, integer *, real *,
+ integer *, real *, real *, real *, real *, integer *, integer *), sposvx_(char *, char *, integer *, integer *,
+ real *, integer *, real *, integer *, char *, real *, real *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ integer *, integer *), sppsvx_(char *,
+ char *, integer *, integer *, real *, real *, char *, real *,
+ real *, integer *, real *, integer *, real *, real *, real *,
+ real *, integer *, integer *), sspsvx_(
+ char *, char *, integer *, integer *, real *, real *, integer *,
+ real *, integer *, real *, integer *, real *, real *, real *,
+ real *, integer *, integer *), sptsvx_(char *,
+ integer *, integer *, real *, real *, real *, real *, real *,
+ integer *, real *, integer *, real *, real *, real *, real *,
+ integer *), ssysvx_(char *, char *, integer *, integer *,
+ real *, integer *, real *, integer *, integer *, real *, integer *
+, real *, integer *, real *, real *, real *, real *, integer *,
+ integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___19 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___20 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SERRVX tests the error exits for the REAL driver routines */
+/* for solving linear systems of equations. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ a[i__ + (j << 2) - 5] = 1.f / (real) (i__ + j);
+ af[i__ + (j << 2) - 5] = 1.f / (real) (i__ + j);
+/* L10: */
+ }
+ b[j - 1] = 0.f;
+ r1[j - 1] = 0.f;
+ r2[j - 1] = 0.f;
+ w[j - 1] = 0.f;
+ x[j - 1] = 0.f;
+ c__[j - 1] = 0.f;
+ r__[j - 1] = 0.f;
+ ip[j - 1] = j;
+/* L20: */
+ }
+ *(unsigned char *)eq = ' ';
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "GE")) {
+
+/* SGESV */
+
+ s_copy(srnamc_1.srnamt, "SGESV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgesv_(&c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("SGESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgesv_(&c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("SGESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgesv_(&c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
+ chkxer_("SGESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sgesv_(&c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
+ chkxer_("SGESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGESVX */
+
+ s_copy(srnamc_1.srnamt, "SGESVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgesvx_("/", "N", &c__0, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgesvx_("N", "/", &c__0, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgesvx_("N", "N", &c_n1, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgesvx_("N", "N", &c__0, &c_n1, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sgesvx_("N", "N", &c__2, &c__1, a, &c__1, af, &c__2, ip, eq, r__, c__,
+ b, &c__2, x, &c__2, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sgesvx_("N", "N", &c__2, &c__1, a, &c__2, af, &c__1, ip, eq, r__, c__,
+ b, &c__2, x, &c__2, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ *(unsigned char *)eq = '/';
+ sgesvx_("F", "N", &c__0, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ *(unsigned char *)eq = 'R';
+ sgesvx_("F", "N", &c__1, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ *(unsigned char *)eq = 'C';
+ sgesvx_("F", "N", &c__1, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ sgesvx_("N", "N", &c__2, &c__1, a, &c__2, af, &c__2, ip, eq, r__, c__,
+ b, &c__1, x, &c__2, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ sgesvx_("N", "N", &c__2, &c__1, a, &c__2, af, &c__2, ip, eq, r__, c__,
+ b, &c__2, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* SGBSV */
+
+ s_copy(srnamc_1.srnamt, "SGBSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgbsv_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("SGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgbsv_(&c__1, &c_n1, &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("SGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgbsv_(&c__1, &c__0, &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("SGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgbsv_(&c__0, &c__0, &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("SGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sgbsv_(&c__1, &c__1, &c__1, &c__0, a, &c__3, ip, b, &c__1, &info);
+ chkxer_("SGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sgbsv_(&c__2, &c__0, &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("SGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGBSVX */
+
+ s_copy(srnamc_1.srnamt, "SGBSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgbsvx_("/", "N", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("SGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgbsvx_("N", "/", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("SGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgbsvx_("N", "N", &c_n1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("SGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgbsvx_("N", "N", &c__1, &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("SGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sgbsvx_("N", "N", &c__1, &c__0, &c_n1, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("SGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sgbsvx_("N", "N", &c__0, &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("SGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sgbsvx_("N", "N", &c__1, &c__1, &c__1, &c__0, a, &c__2, af, &c__4, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("SGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sgbsvx_("N", "N", &c__1, &c__1, &c__1, &c__0, a, &c__3, af, &c__3, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("SGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ *(unsigned char *)eq = '/';
+ sgbsvx_("F", "N", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("SGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ *(unsigned char *)eq = 'R';
+ sgbsvx_("F", "N", &c__1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("SGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ *(unsigned char *)eq = 'C';
+ sgbsvx_("F", "N", &c__1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("SGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ sgbsvx_("N", "N", &c__2, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__2, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("SGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ sgbsvx_("N", "N", &c__2, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__2, x, &c__1, &rcond, r1, r2, w, iw, &
+ info);
+ chkxer_("SGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "GT")) {
+
+/* SGTSV */
+
+ s_copy(srnamc_1.srnamt, "SGTSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgtsv_(&c_n1, &c__0, a, &a[4], &a[8], b, &c__1, &info);
+ chkxer_("SGTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgtsv_(&c__0, &c_n1, a, &a[4], &a[8], b, &c__1, &info);
+ chkxer_("SGTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sgtsv_(&c__2, &c__0, a, &a[4], &a[8], b, &c__1, &info);
+ chkxer_("SGTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SGTSVX */
+
+ s_copy(srnamc_1.srnamt, "SGTSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sgtsvx_("/", "N", &c__0, &c__0, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sgtsvx_("N", "/", &c__0, &c__0, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sgtsvx_("N", "N", &c_n1, &c__0, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sgtsvx_("N", "N", &c__0, &c_n1, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ sgtsvx_("N", "N", &c__2, &c__0, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__1, x, &c__2, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ sgtsvx_("N", "N", &c__2, &c__0, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__2, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PO")) {
+
+/* SPOSV */
+
+ s_copy(srnamc_1.srnamt, "SPOSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sposv_("/", &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("SPOSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sposv_("U", &c_n1, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("SPOSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sposv_("U", &c__0, &c_n1, a, &c__1, b, &c__1, &info);
+ chkxer_("SPOSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ sposv_("U", &c__2, &c__0, a, &c__1, b, &c__2, &info);
+ chkxer_("SPOSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sposv_("U", &c__2, &c__0, a, &c__2, b, &c__1, &info);
+ chkxer_("SPOSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPOSVX */
+
+ s_copy(srnamc_1.srnamt, "SPOSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sposvx_("/", "U", &c__0, &c__0, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sposvx_("N", "/", &c__0, &c__0, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sposvx_("N", "U", &c_n1, &c__0, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sposvx_("N", "U", &c__0, &c_n1, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sposvx_("N", "U", &c__2, &c__0, a, &c__1, af, &c__2, eq, c__, b, &
+ c__2, x, &c__2, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ sposvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__1, eq, c__, b, &
+ c__2, x, &c__2, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ *(unsigned char *)eq = '/';
+ sposvx_("F", "U", &c__0, &c__0, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ *(unsigned char *)eq = 'Y';
+ sposvx_("F", "U", &c__1, &c__0, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sposvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, eq, c__, b, &
+ c__1, x, &c__2, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ sposvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, eq, c__, b, &
+ c__2, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PP")) {
+
+/* SPPSV */
+
+ s_copy(srnamc_1.srnamt, "SPPSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sppsv_("/", &c__0, &c__0, a, b, &c__1, &info);
+ chkxer_("SPPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sppsv_("U", &c_n1, &c__0, a, b, &c__1, &info);
+ chkxer_("SPPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sppsv_("U", &c__0, &c_n1, a, b, &c__1, &info);
+ chkxer_("SPPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sppsv_("U", &c__2, &c__0, a, b, &c__1, &info);
+ chkxer_("SPPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPPSVX */
+
+ s_copy(srnamc_1.srnamt, "SPPSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sppsvx_("/", "U", &c__0, &c__0, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, iw, &info);
+ chkxer_("SPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sppsvx_("N", "/", &c__0, &c__0, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, iw, &info);
+ chkxer_("SPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sppsvx_("N", "U", &c_n1, &c__0, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, iw, &info);
+ chkxer_("SPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sppsvx_("N", "U", &c__0, &c_n1, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, iw, &info);
+ chkxer_("SPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ *(unsigned char *)eq = '/';
+ sppsvx_("F", "U", &c__0, &c__0, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, iw, &info);
+ chkxer_("SPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ *(unsigned char *)eq = 'Y';
+ sppsvx_("F", "U", &c__1, &c__0, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, iw, &info);
+ chkxer_("SPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ sppsvx_("N", "U", &c__2, &c__0, a, af, eq, c__, b, &c__1, x, &c__2, &
+ rcond, r1, r2, w, iw, &info);
+ chkxer_("SPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ sppsvx_("N", "U", &c__2, &c__0, a, af, eq, c__, b, &c__2, x, &c__1, &
+ rcond, r1, r2, w, iw, &info);
+ chkxer_("SPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* SPBSV */
+
+ s_copy(srnamc_1.srnamt, "SPBSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spbsv_("/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &info)
+ ;
+ chkxer_("SPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spbsv_("U", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, &info)
+ ;
+ chkxer_("SPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spbsv_("U", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, &info)
+ ;
+ chkxer_("SPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ spbsv_("U", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, &info)
+ ;
+ chkxer_("SPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ spbsv_("U", &c__1, &c__1, &c__0, a, &c__1, b, &c__2, &info)
+ ;
+ chkxer_("SPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ spbsv_("U", &c__2, &c__0, &c__0, a, &c__1, b, &c__1, &info)
+ ;
+ chkxer_("SPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPBSVX */
+
+ s_copy(srnamc_1.srnamt, "SPBSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ spbsvx_("/", "U", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ spbsvx_("N", "/", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ spbsvx_("N", "U", &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ spbsvx_("N", "U", &c__1, &c_n1, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ spbsvx_("N", "U", &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ spbsvx_("N", "U", &c__1, &c__1, &c__0, a, &c__1, af, &c__2, eq, c__,
+ b, &c__2, x, &c__2, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ spbsvx_("N", "U", &c__1, &c__1, &c__0, a, &c__2, af, &c__1, eq, c__,
+ b, &c__2, x, &c__2, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ *(unsigned char *)eq = '/';
+ spbsvx_("F", "U", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ *(unsigned char *)eq = 'Y';
+ spbsvx_("F", "U", &c__1, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ spbsvx_("N", "U", &c__2, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__2, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ spbsvx_("N", "U", &c__2, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__2, x, &c__1, &rcond, r1, r2, w, iw, &info);
+ chkxer_("SPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PT")) {
+
+/* SPTSV */
+
+ s_copy(srnamc_1.srnamt, "SPTSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sptsv_(&c_n1, &c__0, a, &a[4], b, &c__1, &info);
+ chkxer_("SPTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sptsv_(&c__0, &c_n1, a, &a[4], b, &c__1, &info);
+ chkxer_("SPTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ sptsv_(&c__2, &c__0, a, &a[4], b, &c__1, &info);
+ chkxer_("SPTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SPTSVX */
+
+ s_copy(srnamc_1.srnamt, "SPTSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sptsvx_("/", &c__0, &c__0, a, &a[4], af, &af[4], b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, &info);
+ chkxer_("SPTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sptsvx_("N", &c_n1, &c__0, a, &a[4], af, &af[4], b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, &info);
+ chkxer_("SPTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sptsvx_("N", &c__0, &c_n1, a, &a[4], af, &af[4], b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, &info);
+ chkxer_("SPTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sptsvx_("N", &c__2, &c__0, a, &a[4], af, &af[4], b, &c__1, x, &c__2, &
+ rcond, r1, r2, w, &info);
+ chkxer_("SPTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ sptsvx_("N", &c__2, &c__0, a, &a[4], af, &af[4], b, &c__2, x, &c__1, &
+ rcond, r1, r2, w, &info);
+ chkxer_("SPTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "SY")) {
+
+/* SSYSV */
+
+ s_copy(srnamc_1.srnamt, "SSYSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssysv_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("SSYSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ssysv_("U", &c_n1, &c__0, a, &c__1, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("SSYSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ssysv_("U", &c__0, &c_n1, a, &c__1, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("SSYSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ssysv_("U", &c__2, &c__0, a, &c__2, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("SSYSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SSYSVX */
+
+ s_copy(srnamc_1.srnamt, "SSYSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ssysvx_("/", "U", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, iw, &info);
+ chkxer_("SSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ssysvx_("N", "/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, iw, &info);
+ chkxer_("SSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ssysvx_("N", "U", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, iw, &info);
+ chkxer_("SSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ssysvx_("N", "U", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, iw, &info);
+ chkxer_("SSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ssysvx_("N", "U", &c__2, &c__0, a, &c__1, af, &c__2, ip, b, &c__2, x,
+ &c__2, &rcond, r1, r2, w, &c__4, iw, &info);
+ chkxer_("SSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ssysvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__1, ip, b, &c__2, x,
+ &c__2, &rcond, r1, r2, w, &c__4, iw, &info);
+ chkxer_("SSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ ssysvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, ip, b, &c__1, x,
+ &c__2, &rcond, r1, r2, w, &c__4, iw, &info);
+ chkxer_("SSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ ssysvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, ip, b, &c__2, x,
+ &c__1, &rcond, r1, r2, w, &c__4, iw, &info);
+ chkxer_("SSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ ssysvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, ip, b, &c__2, x,
+ &c__2, &rcond, r1, r2, w, &c__3, iw, &info);
+ chkxer_("SSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "SP")) {
+
+/* SSPSV */
+
+ s_copy(srnamc_1.srnamt, "SSPSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sspsv_("/", &c__0, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("SSPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sspsv_("U", &c_n1, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("SSPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sspsv_("U", &c__0, &c_n1, a, ip, b, &c__1, &info);
+ chkxer_("SSPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ sspsv_("U", &c__2, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("SSPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* SSPSVX */
+
+ s_copy(srnamc_1.srnamt, "SSPSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ sspsvx_("/", "U", &c__0, &c__0, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, iw, &info);
+ chkxer_("SSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ sspsvx_("N", "/", &c__0, &c__0, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, iw, &info);
+ chkxer_("SSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ sspsvx_("N", "U", &c_n1, &c__0, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, iw, &info);
+ chkxer_("SSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ sspsvx_("N", "U", &c__0, &c_n1, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, iw, &info);
+ chkxer_("SSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ sspsvx_("N", "U", &c__2, &c__0, a, af, ip, b, &c__1, x, &c__2, &rcond,
+ r1, r2, w, iw, &info);
+ chkxer_("SSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ sspsvx_("N", "U", &c__2, &c__0, a, af, ip, b, &c__2, x, &c__1, &rcond,
+ r1, r2, w, iw, &info);
+ chkxer_("SSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___19.ciunit = infoc_1.nout;
+ s_wsfe(&io___19);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ } else {
+ io___20.ciunit = infoc_1.nout;
+ s_wsfe(&io___20);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of SERRVX */
+
+} /* serrvx_ */
diff --git a/TESTING/LIN/sgbt01.c b/TESTING/LIN/sgbt01.c
new file mode 100644
index 0000000..ec04a6e
--- /dev/null
+++ b/TESTING/LIN/sgbt01.c
@@ -0,0 +1,241 @@
+/* sgbt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b12 = -1.f;
+
+/* Subroutine */ int sgbt01_(integer *m, integer *n, integer *kl, integer *ku,
+ real *a, integer *lda, real *afac, integer *ldafac, integer *ipiv,
+ real *work, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer i__, j;
+ real t;
+ integer i1, i2, kd, il, jl, ip, ju, iw, jua;
+ real eps;
+ integer lenj;
+ real anorm;
+ extern doublereal sasum_(integer *, real *, integer *);
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), saxpy_(integer *, real *, real *, integer *, real *,
+ integer *);
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGBT01 reconstructs a band matrix A from its L*U factorization and */
+/* computes the residual: */
+/* norm(L*U - A) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* The expression L*U - A is computed one column at a time, so A and */
+/* AFAC are not modified. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* The original matrix A in band storage, stored in rows 1 to */
+/* KL+KU+1. */
+
+/* LDA (input) INTEGER. */
+/* The leading dimension of the array A. LDA >= max(1,KL+KU+1). */
+
+/* AFAC (input) REAL array, dimension (LDAFAC,N) */
+/* The factored form of the matrix A. AFAC contains the banded */
+/* factors L and U from the L*U factorization, as computed by */
+/* SGBTRF. U is stored as an upper triangular band matrix with */
+/* KL+KU superdiagonals in rows 1 to KL+KU+1, and the */
+/* multipliers used during the factorization are stored in rows */
+/* KL+KU+2 to 2*KL+KU+1. See SGBTRF for further details. */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. */
+/* LDAFAC >= max(1,2*KL*KU+1). */
+
+/* IPIV (input) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices from SGBTRF. */
+
+/* WORK (workspace) REAL array, dimension (2*KL+KU+1) */
+
+/* RESID (output) REAL */
+/* norm(L*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if M = 0 or N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *resid = 0.f;
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+/* Determine EPS and the norm of A. */
+
+ eps = slamch_("Epsilon");
+ kd = *ku + 1;
+ anorm = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = kd + 1 - j;
+ i1 = max(i__2,1);
+/* Computing MIN */
+ i__2 = kd + *m - j, i__3 = *kl + kd;
+ i2 = min(i__2,i__3);
+ if (i2 >= i1) {
+/* Computing MAX */
+ i__2 = i2 - i1 + 1;
+ r__1 = anorm, r__2 = sasum_(&i__2, &a[i1 + j * a_dim1], &c__1);
+ anorm = dmax(r__1,r__2);
+ }
+/* L10: */
+ }
+
+/* Compute one column at a time of L*U - A. */
+
+ kd = *kl + *ku + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Copy the J-th column of U to WORK. */
+
+/* Computing MIN */
+ i__2 = *kl + *ku, i__3 = j - 1;
+ ju = min(i__2,i__3);
+/* Computing MIN */
+ i__2 = *kl, i__3 = *m - j;
+ jl = min(i__2,i__3);
+ lenj = min(*m,j) - j + ju + 1;
+ if (lenj > 0) {
+ scopy_(&lenj, &afac[kd - ju + j * afac_dim1], &c__1, &work[1], &
+ c__1);
+ i__2 = ju + jl + 1;
+ for (i__ = lenj + 1; i__ <= i__2; ++i__) {
+ work[i__] = 0.f;
+/* L20: */
+ }
+
+/* Multiply by the unit lower triangular matrix L. Note that L */
+/* is stored as a product of transformations and permutations. */
+
+/* Computing MIN */
+ i__2 = *m - 1;
+ i__3 = j - ju;
+ for (i__ = min(i__2,j); i__ >= i__3; --i__) {
+/* Computing MIN */
+ i__2 = *kl, i__4 = *m - i__;
+ il = min(i__2,i__4);
+ if (il > 0) {
+ iw = i__ - j + ju + 1;
+ t = work[iw];
+ saxpy_(&il, &t, &afac[kd + 1 + i__ * afac_dim1], &c__1, &
+ work[iw + 1], &c__1);
+ ip = ipiv[i__];
+ if (i__ != ip) {
+ ip = ip - j + ju + 1;
+ work[iw] = work[ip];
+ work[ip] = t;
+ }
+ }
+/* L30: */
+ }
+
+/* Subtract the corresponding column of A. */
+
+ jua = min(ju,*ku);
+ if (jua + jl + 1 > 0) {
+ i__3 = jua + jl + 1;
+ saxpy_(&i__3, &c_b12, &a[*ku + 1 - jua + j * a_dim1], &c__1, &
+ work[ju + 1 - jua], &c__1);
+ }
+
+/* Compute the 1-norm of the column. */
+
+/* Computing MAX */
+ i__3 = ju + jl + 1;
+ r__1 = *resid, r__2 = sasum_(&i__3, &work[1], &c__1);
+ *resid = dmax(r__1,r__2);
+ }
+/* L40: */
+ }
+
+/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
+
+ if (anorm <= 0.f) {
+ if (*resid != 0.f) {
+ *resid = 1.f / eps;
+ }
+ } else {
+ *resid = *resid / (real) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of SGBT01 */
+
+} /* sgbt01_ */
diff --git a/TESTING/LIN/sgbt02.c b/TESTING/LIN/sgbt02.c
new file mode 100644
index 0000000..0bd34ae
--- /dev/null
+++ b/TESTING/LIN/sgbt02.c
@@ -0,0 +1,207 @@
+/* sgbt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b8 = -1.f;
+static real c_b10 = 1.f;
+
+/* Subroutine */ int sgbt02_(char *trans, integer *m, integer *n, integer *kl,
+ integer *ku, integer *nrhs, real *a, integer *lda, real *x, integer *
+ ldx, real *b, integer *ldb, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2,
+ i__3;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j, i1, i2, n1, kd;
+ real eps;
+ extern logical lsame_(char *, char *);
+ real anorm, bnorm;
+ extern /* Subroutine */ int sgbmv_(char *, integer *, integer *, integer *
+, integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ extern doublereal sasum_(integer *, real *, integer *);
+ real xnorm;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGBT02 computes the residual for a solution of a banded system of */
+/* equations A*x = b or A'*x = b: */
+/* RESID = norm( B - A*X ) / ( norm(A) * norm(X) * EPS). */
+/* where EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A *x = b */
+/* = 'T': A'*x = b, where A' is the transpose of A */
+/* = 'C': A'*x = b, where A' is the transpose of A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The original matrix A in band storage, stored in rows 1 to */
+/* KL+KU+1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,KL+KU+1). */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M). */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. IF TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if N = 0 pr NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ kd = *ku + 1;
+ anorm = 0.f;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = kd + 1 - j;
+ i1 = max(i__2,1);
+/* Computing MIN */
+ i__2 = kd + *m - j, i__3 = *kl + kd;
+ i2 = min(i__2,i__3);
+/* Computing MAX */
+ i__2 = i2 - i1 + 1;
+ r__1 = anorm, r__2 = sasum_(&i__2, &a[i1 + j * a_dim1], &c__1);
+ anorm = dmax(r__1,r__2);
+/* L10: */
+ }
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+ if (lsame_(trans, "T") || lsame_(trans, "C")) {
+ n1 = *n;
+ } else {
+ n1 = *m;
+ }
+
+/* Compute B - A*X (or B - A'*X ) */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ sgbmv_(trans, m, n, kl, ku, &c_b8, &a[a_offset], lda, &x[j * x_dim1 +
+ 1], &c__1, &c_b10, &b[j * b_dim1 + 1], &c__1);
+/* L20: */
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = sasum_(&n1, &b[j * b_dim1 + 1], &c__1);
+ xnorm = sasum_(&n1, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L30: */
+ }
+
+ return 0;
+
+/* End of SGBT02 */
+
+} /* sgbt02_ */
diff --git a/TESTING/LIN/sgbt05.c b/TESTING/LIN/sgbt05.c
new file mode 100644
index 0000000..4028e23
--- /dev/null
+++ b/TESTING/LIN/sgbt05.c
@@ -0,0 +1,282 @@
+/* sgbt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sgbt05_(char *trans, integer *n, integer *kl, integer *
+ ku, integer *nrhs, real *ab, integer *ldab, real *b, integer *ldb,
+ real *x, integer *ldx, real *xact, integer *ldxact, real *ferr, real *
+ berr, real *reslts)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, k, nz;
+ real eps, tmp, diff, axbi;
+ integer imax;
+ real unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ real xnorm;
+ extern doublereal slamch_(char *);
+ real errbnd;
+ extern integer isamax_(integer *, real *, integer *);
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGBT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations op(A)*X = B, where A is a */
+/* general band matrix of order n with kl subdiagonals and ku */
+/* superdiagonals and op(A) = A or A**T, depending on TRANS. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+/* and NZ = max. number of nonzeros in any row of A, plus 1 */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* AB (input) REAL array, dimension (LDAB,N) */
+/* The original band matrix A, stored in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) REAL array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) REAL array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) REAL array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.f;
+ reslts[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ notran = lsame_(trans, "N");
+/* Computing MIN */
+ i__1 = *kl + *ku + 2, i__2 = *n + 1;
+ nz = min(i__1,i__2);
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = isamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ r__2 = (r__1 = x[imax + j * x_dim1], dabs(r__1));
+ xnorm = dmax(r__2,unfl);
+ diff = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = diff, r__3 = (r__1 = x[i__ + j * x_dim1] - xact[i__ + j *
+ xact_dim1], dabs(r__1));
+ diff = dmax(r__2,r__3);
+/* L10: */
+ }
+
+ if (xnorm > 1.f) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1.f / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
+ errbnd = dmax(r__1,r__2);
+ } else {
+ errbnd = 1.f / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ tmp = (r__1 = b[i__ + k * b_dim1], dabs(r__1));
+ if (notran) {
+/* Computing MAX */
+ i__3 = i__ - *kl;
+/* Computing MIN */
+ i__5 = i__ + *ku;
+ i__4 = min(i__5,*n);
+ for (j = max(i__3,1); j <= i__4; ++j) {
+ tmp += (r__1 = ab[*ku + 1 + i__ - j + j * ab_dim1], dabs(
+ r__1)) * (r__2 = x[j + k * x_dim1], dabs(r__2));
+/* L40: */
+ }
+ } else {
+/* Computing MAX */
+ i__4 = i__ - *ku;
+/* Computing MIN */
+ i__5 = i__ + *kl;
+ i__3 = min(i__5,*n);
+ for (j = max(i__4,1); j <= i__3; ++j) {
+ tmp += (r__1 = ab[*ku + 1 + j - i__ + i__ * ab_dim1],
+ dabs(r__1)) * (r__2 = x[j + k * x_dim1], dabs(
+ r__2));
+/* L50: */
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = dmin(axbi,tmp);
+ }
+/* L60: */
+ }
+/* Computing MAX */
+ r__1 = axbi, r__2 = nz * unfl;
+ tmp = berr[k] / (nz * eps + nz * unfl / dmax(r__1,r__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = dmax(reslts[2],tmp);
+ }
+/* L70: */
+ }
+
+ return 0;
+
+/* End of SGBT05 */
+
+} /* sgbt05_ */
diff --git a/TESTING/LIN/sgelqs.c b/TESTING/LIN/sgelqs.c
new file mode 100644
index 0000000..466c047
--- /dev/null
+++ b/TESTING/LIN/sgelqs.c
@@ -0,0 +1,165 @@
+/* sgelqs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b7 = 1.f;
+static real c_b9 = 0.f;
+
+/* Subroutine */ int sgelqs_(integer *m, integer *n, integer *nrhs, real *a,
+ integer *lda, real *tau, real *b, integer *ldb, real *work, integer *
+ lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), xerbla_(char *, integer *), slaset_(char *, integer *, integer *, real *, real *,
+ real *, integer *), sormlq_(char *, char *, integer *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, real *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Compute a minimum-norm solution */
+/* min || A*X - B || */
+/* using the LQ factorization */
+/* A = L*Q */
+/* computed by SGELQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= M >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* Details of the LQ factorization of the original matrix A as */
+/* returned by SGELQF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* TAU (input) REAL array, dimension (M) */
+/* Details of the orthogonal matrix Q. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the m-by-nrhs right hand side matrix B. */
+/* On exit, the n-by-nrhs solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= N. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK must be at least NRHS, */
+/* and should be at least NRHS*NB, where NB is the block size */
+/* for this environment. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *m > *n) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*lwork < 1 || *lwork < *nrhs && *m > 0 && *n > 0) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGELQS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0 || *m == 0) {
+ return 0;
+ }
+
+/* Solve L*X = B(1:m,:) */
+
+ strsm_("Left", "Lower", "No transpose", "Non-unit", m, nrhs, &c_b7, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+/* Set B(m+1:n,:) to zero */
+
+ if (*m < *n) {
+ i__1 = *n - *m;
+ slaset_("Full", &i__1, nrhs, &c_b9, &c_b9, &b[*m + 1 + b_dim1], ldb);
+ }
+
+/* B := Q' * B */
+
+ sormlq_("Left", "Transpose", n, nrhs, m, &a[a_offset], lda, &tau[1], &b[
+ b_offset], ldb, &work[1], lwork, info);
+
+ return 0;
+
+/* End of SGELQS */
+
+} /* sgelqs_ */
diff --git a/TESTING/LIN/sgennd.c b/TESTING/LIN/sgennd.c
new file mode 100644
index 0000000..3a33282
--- /dev/null
+++ b/TESTING/LIN/sgennd.c
@@ -0,0 +1,80 @@
+/* sgennd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+logical sgennd_(integer *m, integer *n, real *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ logical ret_val;
+
+ /* Local variables */
+ integer i__, k;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGENND tests that its argument has a non-negative diagonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows in A. */
+
+/* N (input) INTEGER */
+/* The number of columns in A. */
+
+/* A (input) REAL array, dimension (LDA, N) */
+/* The matrix. */
+
+/* LDA (input) INTEGER */
+/* Leading dimension of A. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsics .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ k = min(*m,*n);
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (a[i__ + i__ * a_dim1] < 0.f) {
+ ret_val = FALSE_;
+ return ret_val;
+ }
+ }
+ ret_val = TRUE_;
+ return ret_val;
+} /* sgennd_ */
diff --git a/TESTING/LIN/sgeqls.c b/TESTING/LIN/sgeqls.c
new file mode 100644
index 0000000..03294e4
--- /dev/null
+++ b/TESTING/LIN/sgeqls.c
@@ -0,0 +1,157 @@
+/* sgeqls.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b9 = 1.f;
+
+/* Subroutine */ int sgeqls_(integer *m, integer *n, integer *nrhs, real *a,
+ integer *lda, real *tau, real *b, integer *ldb, real *work, integer *
+ lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), xerbla_(char *, integer *), sormql_(char *, char *, integer *, integer *, integer *,
+ real *, integer *, real *, real *, integer *, real *, integer *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Solve the least squares problem */
+/* min || A*X - B || */
+/* using the QL factorization */
+/* A = Q*L */
+/* computed by SGEQLF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. M >= N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* Details of the QL factorization of the original matrix A as */
+/* returned by SGEQLF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* TAU (input) REAL array, dimension (N) */
+/* Details of the orthogonal matrix Q. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the m-by-nrhs right hand side matrix B. */
+/* On exit, the n-by-nrhs solution matrix X, stored in rows */
+/* m-n+1:m. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= M. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK must be at least NRHS, */
+/* and should be at least NRHS*NB, where NB is the block size */
+/* for this environment. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*m)) {
+ *info = -8;
+ } else if (*lwork < 1 || *lwork < *nrhs && *m > 0 && *n > 0) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGEQLS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0 || *m == 0) {
+ return 0;
+ }
+
+/* B := Q' * B */
+
+ sormql_("Left", "Transpose", m, nrhs, n, &a[a_offset], lda, &tau[1], &b[
+ b_offset], ldb, &work[1], lwork, info);
+
+/* Solve L*X = B(m-n+1:m,:) */
+
+ strsm_("Left", "Lower", "No transpose", "Non-unit", n, nrhs, &c_b9, &a[*m
+ - *n + 1 + a_dim1], lda, &b[*m - *n + 1 + b_dim1], ldb);
+
+ return 0;
+
+/* End of SGEQLS */
+
+} /* sgeqls_ */
diff --git a/TESTING/LIN/sgeqrs.c b/TESTING/LIN/sgeqrs.c
new file mode 100644
index 0000000..ad8284e
--- /dev/null
+++ b/TESTING/LIN/sgeqrs.c
@@ -0,0 +1,156 @@
+/* sgeqrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b9 = 1.f;
+
+/* Subroutine */ int sgeqrs_(integer *m, integer *n, integer *nrhs, real *a,
+ integer *lda, real *tau, real *b, integer *ldb, real *work, integer *
+ lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), xerbla_(char *, integer *), sormqr_(char *, char *, integer *, integer *, integer *,
+ real *, integer *, real *, real *, integer *, real *, integer *,
+ integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Solve the least squares problem */
+/* min || A*X - B || */
+/* using the QR factorization */
+/* A = Q*R */
+/* computed by SGEQRF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. M >= N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* Details of the QR factorization of the original matrix A as */
+/* returned by SGEQRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* TAU (input) REAL array, dimension (N) */
+/* Details of the orthogonal matrix Q. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the m-by-nrhs right hand side matrix B. */
+/* On exit, the n-by-nrhs solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= M. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK must be at least NRHS, */
+/* and should be at least NRHS*NB, where NB is the block size */
+/* for this environment. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*m)) {
+ *info = -8;
+ } else if (*lwork < 1 || *lwork < *nrhs && *m > 0 && *n > 0) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGEQRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0 || *m == 0) {
+ return 0;
+ }
+
+/* B := Q' * B */
+
+ sormqr_("Left", "Transpose", m, nrhs, n, &a[a_offset], lda, &tau[1], &b[
+ b_offset], ldb, &work[1], lwork, info);
+
+/* Solve R*X = B(1:n,:) */
+
+ strsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b9, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+ return 0;
+
+/* End of SGEQRS */
+
+} /* sgeqrs_ */
diff --git a/TESTING/LIN/sgerqs.c b/TESTING/LIN/sgerqs.c
new file mode 100644
index 0000000..5b24b10
--- /dev/null
+++ b/TESTING/LIN/sgerqs.c
@@ -0,0 +1,164 @@
+/* sgerqs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b7 = 1.f;
+static real c_b9 = 0.f;
+
+/* Subroutine */ int sgerqs_(integer *m, integer *n, integer *nrhs, real *a,
+ integer *lda, real *tau, real *b, integer *ldb, real *work, integer *
+ lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), xerbla_(char *, integer *), slaset_(char *, integer *, integer *, real *, real *,
+ real *, integer *), sormrq_(char *, char *, integer *,
+ integer *, integer *, real *, integer *, real *, real *, integer *
+, real *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Compute a minimum-norm solution */
+/* min || A*X - B || */
+/* using the RQ factorization */
+/* A = R*Q */
+/* computed by SGERQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= M >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* Details of the RQ factorization of the original matrix A as */
+/* returned by SGERQF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* TAU (input) REAL array, dimension (M) */
+/* Details of the orthogonal matrix Q. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the linear system. */
+/* On exit, the solution vectors X. Each solution vector */
+/* is contained in rows 1:N of a column of B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK must be at least NRHS, */
+/* and should be at least NRHS*NB, where NB is the block size */
+/* for this environment. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *m > *n) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*lwork < 1 || *lwork < *nrhs && *m > 0 && *n > 0) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SGERQS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0 || *m == 0) {
+ return 0;
+ }
+
+/* Solve R*X = B(n-m+1:n,:) */
+
+ strsm_("Left", "Upper", "No transpose", "Non-unit", m, nrhs, &c_b7, &a[(*
+ n - *m + 1) * a_dim1 + 1], lda, &b[*n - *m + 1 + b_dim1], ldb);
+
+/* Set B(1:n-m,:) to zero */
+
+ i__1 = *n - *m;
+ slaset_("Full", &i__1, nrhs, &c_b9, &c_b9, &b[b_offset], ldb);
+
+/* B := Q' * B */
+
+ sormrq_("Left", "Transpose", n, nrhs, m, &a[a_offset], lda, &tau[1], &b[
+ b_offset], ldb, &work[1], lwork, info);
+
+ return 0;
+
+/* End of SGERQS */
+
+} /* sgerqs_ */
diff --git a/TESTING/LIN/sget01.c b/TESTING/LIN/sget01.c
new file mode 100644
index 0000000..d5ce497
--- /dev/null
+++ b/TESTING/LIN/sget01.c
@@ -0,0 +1,198 @@
+/* sget01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b11 = 1.f;
+static integer c_n1 = -1;
+
+/* Subroutine */ int sget01_(integer *m, integer *n, real *a, integer *lda,
+ real *afac, integer *ldafac, integer *ipiv, real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k;
+ real t, eps;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real anorm;
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *), strmv_(char *, char *, char *, integer *, real *,
+ integer *, real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int slaswp_(integer *, real *, integer *, integer
+ *, integer *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET01 reconstructs a matrix A from its L*U factorization and */
+/* computes the residual */
+/* norm(L*U - A) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The original M x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* AFAC (input/output) REAL array, dimension (LDAFAC,N) */
+/* The factored form of the matrix A. AFAC contains the factors */
+/* L and U from the L*U factorization as computed by SGETRF. */
+/* Overwritten with the reconstructed matrix, and then with the */
+/* difference L*U - A. */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. LDAFAC >= max(1,M). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from SGETRF. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESID (output) REAL */
+/* norm(L*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if M = 0 or N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ --ipiv;
+ --rwork;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Determine EPS and the norm of A. */
+
+ eps = slamch_("Epsilon");
+ anorm = slange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+
+/* Compute the product L*U and overwrite AFAC with the result. */
+/* A column at a time of the product is obtained, starting with */
+/* column N. */
+
+ for (k = *n; k >= 1; --k) {
+ if (k > *m) {
+ strmv_("Lower", "No transpose", "Unit", m, &afac[afac_offset],
+ ldafac, &afac[k * afac_dim1 + 1], &c__1);
+ } else {
+
+/* Compute elements (K+1:M,K) */
+
+ t = afac[k + k * afac_dim1];
+ if (k + 1 <= *m) {
+ i__1 = *m - k;
+ sscal_(&i__1, &t, &afac[k + 1 + k * afac_dim1], &c__1);
+ i__1 = *m - k;
+ i__2 = k - 1;
+ sgemv_("No transpose", &i__1, &i__2, &c_b11, &afac[k + 1 +
+ afac_dim1], ldafac, &afac[k * afac_dim1 + 1], &c__1, &
+ c_b11, &afac[k + 1 + k * afac_dim1], &c__1);
+ }
+
+/* Compute the (K,K) element */
+
+ i__1 = k - 1;
+ afac[k + k * afac_dim1] = t + sdot_(&i__1, &afac[k + afac_dim1],
+ ldafac, &afac[k * afac_dim1 + 1], &c__1);
+
+/* Compute elements (1:K-1,K) */
+
+ i__1 = k - 1;
+ strmv_("Lower", "No transpose", "Unit", &i__1, &afac[afac_offset],
+ ldafac, &afac[k * afac_dim1 + 1], &c__1);
+ }
+/* L10: */
+ }
+ i__1 = min(*m,*n);
+ slaswp_(n, &afac[afac_offset], ldafac, &c__1, &i__1, &ipiv[1], &c_n1);
+
+/* Compute the difference L*U - A and store in AFAC. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ afac[i__ + j * afac_dim1] -= a[i__ + j * a_dim1];
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = slange_("1", m, n, &afac[afac_offset], ldafac, &rwork[1]);
+
+ if (anorm <= 0.f) {
+ if (*resid != 0.f) {
+ *resid = 1.f / eps;
+ }
+ } else {
+ *resid = *resid / (real) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of SGET01 */
+
+} /* sget01_ */
diff --git a/TESTING/LIN/sget02.c b/TESTING/LIN/sget02.c
new file mode 100644
index 0000000..50c99e8
--- /dev/null
+++ b/TESTING/LIN/sget02.c
@@ -0,0 +1,188 @@
+/* sget02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b7 = -1.f;
+static real c_b8 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int sget02_(char *trans, integer *m, integer *n, integer *
+ nrhs, real *a, integer *lda, real *x, integer *ldx, real *b, integer *
+ ldb, real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j, n1, n2;
+ real eps;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm, bnorm;
+ extern doublereal sasum_(integer *, real *, integer *);
+ real xnorm;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET02 computes the residual for a solution of a system of linear */
+/* equations A*x = b or A'*x = b: */
+/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A *x = b */
+/* = 'T': A'*x = b, where A' is the transpose of A */
+/* = 'C': A'*x = b, where A' is the transpose of A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The original M x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M). */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. IF TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if M = 0 or N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0 || *nrhs == 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+ if (lsame_(trans, "T") || lsame_(trans, "C")) {
+ n1 = *n;
+ n2 = *m;
+ } else {
+ n1 = *m;
+ n2 = *n;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = slange_("1", &n1, &n2, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute B - A*X (or B - A'*X ) and store in B. */
+
+ sgemm_(trans, "No transpose", &n1, nrhs, &n2, &c_b7, &a[a_offset], lda, &
+ x[x_offset], ldx, &c_b8, &b[b_offset], ldb)
+ ;
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = sasum_(&n1, &b[j * b_dim1 + 1], &c__1);
+ xnorm = sasum_(&n2, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of SGET02 */
+
+} /* sget02_ */
diff --git a/TESTING/LIN/sget03.c b/TESTING/LIN/sget03.c
new file mode 100644
index 0000000..4f079e0
--- /dev/null
+++ b/TESTING/LIN/sget03.c
@@ -0,0 +1,156 @@
+/* sget03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b7 = -1.f;
+static real c_b8 = 0.f;
+
+/* Subroutine */ int sget03_(integer *n, real *a, integer *lda, real *ainv,
+ integer *ldainv, real *work, integer *ldwork, real *rwork, real *
+ rcond, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, ainv_dim1, ainv_offset, work_dim1, work_offset,
+ i__1;
+
+ /* Local variables */
+ integer i__;
+ real eps;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ real ainvnm;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET03 computes the residual for a general matrix times its inverse: */
+/* norm( I - AINV*A ) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The original N x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AINV (input) REAL array, dimension (LDAINV,N) */
+/* The inverse of the matrix A. */
+
+/* LDAINV (input) INTEGER */
+/* The leading dimension of the array AINV. LDAINV >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (LDWORK,N) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RCOND (output) REAL */
+/* The reciprocal of the condition number of A, computed as */
+/* ( 1/norm(A) ) / norm(AINV). */
+
+/* RESID (output) REAL */
+/* norm(I - AINV*A) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ ainv_dim1 = *ldainv;
+ ainv_offset = 1 + ainv_dim1;
+ ainv -= ainv_offset;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.f;
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = slange_("1", n, n, &a[a_offset], lda, &rwork[1]);
+ ainvnm = slange_("1", n, n, &ainv[ainv_offset], ldainv, &rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ *rcond = 0.f;
+ *resid = 1.f / eps;
+ return 0;
+ }
+ *rcond = 1.f / anorm / ainvnm;
+
+/* Compute I - A * AINV */
+
+ sgemm_("No transpose", "No transpose", n, n, n, &c_b7, &ainv[ainv_offset],
+ ldainv, &a[a_offset], lda, &c_b8, &work[work_offset], ldwork);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__ + i__ * work_dim1] += 1.f;
+/* L10: */
+ }
+
+/* Compute norm(I - AINV*A) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = slange_("1", n, n, &work[work_offset], ldwork, &rwork[1]);
+
+ *resid = *resid * *rcond / eps / (real) (*n);
+
+ return 0;
+
+/* End of SGET03 */
+
+} /* sget03_ */
diff --git a/TESTING/LIN/sget04.c b/TESTING/LIN/sget04.c
new file mode 100644
index 0000000..693f0e1
--- /dev/null
+++ b/TESTING/LIN/sget04.c
@@ -0,0 +1,157 @@
+/* sget04.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sget04_(integer *n, integer *nrhs, real *x, integer *ldx,
+ real *xact, integer *ldxact, real *rcond, real *resid)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, xact_dim1, xact_offset, i__1, i__2;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, ix;
+ real eps, xnorm, diffnm;
+ extern doublereal slamch_(char *);
+ extern integer isamax_(integer *, real *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET04 computes the difference between a computed solution and the */
+/* true solution to a system of linear equations. */
+
+/* RESID = ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ), */
+/* where RCOND is the reciprocal of the condition number and EPS is the */
+/* machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X and XACT. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X and XACT. NRHS >= 0. */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) REAL array, dimension( LDX, NRHS ) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* RCOND (input) REAL */
+/* The reciprocal of the condition number of the coefficient */
+/* matrix in the system of equations. */
+
+/* RESID (output) REAL */
+/* The maximum over the NRHS solution vectors of */
+/* ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if RCOND is invalid. */
+
+ eps = slamch_("Epsilon");
+ if (*rcond < 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute the maximum of */
+/* norm(X - XACT) / ( norm(XACT) * EPS ) */
+/* over all the vectors X and XACT . */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ix = isamax_(n, &xact[j * xact_dim1 + 1], &c__1);
+ xnorm = (r__1 = xact[ix + j * xact_dim1], dabs(r__1));
+ diffnm = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = diffnm, r__3 = (r__1 = x[i__ + j * x_dim1] - xact[i__ + j *
+ xact_dim1], dabs(r__1));
+ diffnm = dmax(r__2,r__3);
+/* L10: */
+ }
+ if (xnorm <= 0.f) {
+ if (diffnm > 0.f) {
+ *resid = 1.f / eps;
+ }
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = diffnm / xnorm * *rcond;
+ *resid = dmax(r__1,r__2);
+ }
+/* L20: */
+ }
+ if (*resid * eps < 1.f) {
+ *resid /= eps;
+ }
+
+ return 0;
+
+/* End of SGET04 */
+
+} /* sget04_ */
diff --git a/TESTING/LIN/sget06.c b/TESTING/LIN/sget06.c
new file mode 100644
index 0000000..b68ffb3
--- /dev/null
+++ b/TESTING/LIN/sget06.c
@@ -0,0 +1,80 @@
+/* sget06.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal sget06_(real *rcond, real *rcondc)
+{
+ /* System generated locals */
+ real ret_val;
+
+ /* Local variables */
+ real rat, eps;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET06 computes a test ratio to compare two values for RCOND. */
+
+/* Arguments */
+/* ========== */
+
+/* RCOND (input) REAL */
+/* The estimate of the reciprocal of the condition number of A, */
+/* as computed by SGECON. */
+
+/* RCONDC (input) REAL */
+/* The reciprocal of the condition number of A, computed as */
+/* ( 1/norm(A) ) / norm(inv(A)). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = slamch_("Epsilon");
+ if (*rcond > 0.f) {
+ if (*rcondc > 0.f) {
+ rat = dmax(*rcond,*rcondc) / dmin(*rcond,*rcondc) - (1.f - eps);
+ } else {
+ rat = *rcond / eps;
+ }
+ } else {
+ if (*rcondc > 0.f) {
+ rat = *rcondc / eps;
+ } else {
+ rat = 0.f;
+ }
+ }
+ ret_val = rat;
+ return ret_val;
+
+/* End of SGET06 */
+
+} /* sget06_ */
diff --git a/TESTING/LIN/sget07.c b/TESTING/LIN/sget07.c
new file mode 100644
index 0000000..06dd72c
--- /dev/null
+++ b/TESTING/LIN/sget07.c
@@ -0,0 +1,264 @@
+/* sget07.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sget07_(char *trans, integer *n, integer *nrhs, real *a,
+ integer *lda, real *b, integer *ldb, real *x, integer *ldx, real *
+ xact, integer *ldxact, real *ferr, logical *chkferr, real *berr, real
+ *reslts)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ real eps, tmp, diff, axbi;
+ integer imax;
+ real unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ real xnorm;
+ extern doublereal slamch_(char *);
+ real errbnd;
+ extern integer isamax_(integer *, real *, integer *);
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGET07 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations op(A)*X = B, where A is a */
+/* general n by n matrix and op(A) = A or A**T, depending on TRANS. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X and XACT. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X and XACT. NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The original n by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) REAL array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) REAL array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* CHKFERR (input) LOGICAL */
+/* Set to .TRUE. to check FERR, .FALSE. not to check FERR. */
+/* When the test system is ill-conditioned, the "true" */
+/* solution in XACT may be incorrect. */
+
+/* BERR (input) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) REAL array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.f;
+ reslts[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ notran = lsame_(trans, "N");
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.f;
+ if (*chkferr) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = isamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ r__2 = (r__1 = x[imax + j * x_dim1], dabs(r__1));
+ xnorm = dmax(r__2,unfl);
+ diff = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = diff, r__3 = (r__1 = x[i__ + j * x_dim1] - xact[i__ +
+ j * xact_dim1], dabs(r__1));
+ diff = dmax(r__2,r__3);
+/* L10: */
+ }
+
+ if (xnorm > 1.f) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1.f / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
+ errbnd = dmax(r__1,r__2);
+ } else {
+ errbnd = 1.f / eps;
+ }
+L30:
+ ;
+ }
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ tmp = (r__1 = b[i__ + k * b_dim1], dabs(r__1));
+ if (notran) {
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ tmp += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * (r__2 =
+ x[j + k * x_dim1], dabs(r__2));
+/* L40: */
+ }
+ } else {
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ tmp += (r__1 = a[j + i__ * a_dim1], dabs(r__1)) * (r__2 =
+ x[j + k * x_dim1], dabs(r__2));
+/* L50: */
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = dmin(axbi,tmp);
+ }
+/* L60: */
+ }
+/* Computing MAX */
+ r__1 = axbi, r__2 = (*n + 1) * unfl;
+ tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / dmax(r__1,r__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = dmax(reslts[2],tmp);
+ }
+/* L70: */
+ }
+
+ return 0;
+
+/* End of SGET07 */
+
+} /* sget07_ */
diff --git a/TESTING/LIN/sgtt01.c b/TESTING/LIN/sgtt01.c
new file mode 100644
index 0000000..c374efe
--- /dev/null
+++ b/TESTING/LIN/sgtt01.c
@@ -0,0 +1,231 @@
+/* sgtt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sgtt01_(integer *n, real *dl, real *d__, real *du, real *
+ dlf, real *df, real *duf, real *du2, integer *ipiv, real *work,
+ integer *ldwork, real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer work_dim1, work_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ real li;
+ integer ip;
+ real eps, anorm;
+ integer lastj;
+ extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
+ integer *), saxpy_(integer *, real *, real *, integer *, real *,
+ integer *);
+ extern doublereal slamch_(char *), slangt_(char *, integer *,
+ real *, real *, real *), slanhs_(char *, integer *, real *
+, integer *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGTT01 reconstructs a tridiagonal matrix A from its LU factorization */
+/* and computes the residual */
+/* norm(L*U - A) / ( norm(A) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGTER */
+/* The order of the matrix A. N >= 0. */
+
+/* DL (input) REAL array, dimension (N-1) */
+/* The (n-1) sub-diagonal elements of A. */
+
+/* D (input) REAL array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* DU (input) REAL array, dimension (N-1) */
+/* The (n-1) super-diagonal elements of A. */
+
+/* DLF (input) REAL array, dimension (N-1) */
+/* The (n-1) multipliers that define the matrix L from the */
+/* LU factorization of A. */
+
+/* DF (input) REAL array, dimension (N) */
+/* The n diagonal elements of the upper triangular matrix U from */
+/* the LU factorization of A. */
+
+/* DUF (input) REAL array, dimension (N-1) */
+/* The (n-1) elements of the first super-diagonal of U. */
+
+/* DU2F (input) REAL array, dimension (N-2) */
+/* The (n-2) elements of the second super-diagonal of U. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* WORK (workspace) REAL array, dimension (LDWORK,N) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* The scaled residual: norm(L*U - A) / (norm(A) * EPS) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ --dlf;
+ --df;
+ --duf;
+ --du2;
+ --ipiv;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+
+/* Copy the matrix U to WORK. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[i__ + j * work_dim1] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (i__ == 1) {
+ work[i__ + i__ * work_dim1] = df[i__];
+ if (*n >= 2) {
+ work[i__ + (i__ + 1) * work_dim1] = duf[i__];
+ }
+ if (*n >= 3) {
+ work[i__ + (i__ + 2) * work_dim1] = du2[i__];
+ }
+ } else if (i__ == *n) {
+ work[i__ + i__ * work_dim1] = df[i__];
+ } else {
+ work[i__ + i__ * work_dim1] = df[i__];
+ work[i__ + (i__ + 1) * work_dim1] = duf[i__];
+ if (i__ < *n - 1) {
+ work[i__ + (i__ + 2) * work_dim1] = du2[i__];
+ }
+ }
+/* L30: */
+ }
+
+/* Multiply on the left by L. */
+
+ lastj = *n;
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ li = dlf[i__];
+ i__1 = lastj - i__ + 1;
+ saxpy_(&i__1, &li, &work[i__ + i__ * work_dim1], ldwork, &work[i__ +
+ 1 + i__ * work_dim1], ldwork);
+ ip = ipiv[i__];
+ if (ip == i__) {
+/* Computing MIN */
+ i__1 = i__ + 2;
+ lastj = min(i__1,*n);
+ } else {
+ i__1 = lastj - i__ + 1;
+ sswap_(&i__1, &work[i__ + i__ * work_dim1], ldwork, &work[i__ + 1
+ + i__ * work_dim1], ldwork);
+ }
+/* L40: */
+ }
+
+/* Subtract the matrix A. */
+
+ work[work_dim1 + 1] -= d__[1];
+ if (*n > 1) {
+ work[(work_dim1 << 1) + 1] -= du[1];
+ work[*n + (*n - 1) * work_dim1] -= dl[*n - 1];
+ work[*n + *n * work_dim1] -= d__[*n];
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ work[i__ + (i__ - 1) * work_dim1] -= dl[i__ - 1];
+ work[i__ + i__ * work_dim1] -= d__[i__];
+ work[i__ + (i__ + 1) * work_dim1] -= du[i__];
+/* L50: */
+ }
+ }
+
+/* Compute the 1-norm of the tridiagonal matrix A. */
+
+ anorm = slangt_("1", n, &dl[1], &d__[1], &du[1]);
+
+/* Compute the 1-norm of WORK, which is only guaranteed to be */
+/* upper Hessenberg. */
+
+ *resid = slanhs_("1", n, &work[work_offset], ldwork, &rwork[1])
+ ;
+
+/* Compute norm(L*U - A) / (norm(A) * EPS) */
+
+ if (anorm <= 0.f) {
+ if (*resid != 0.f) {
+ *resid = 1.f / eps;
+ }
+ } else {
+ *resid = *resid / anorm / eps;
+ }
+
+ return 0;
+
+/* End of SGTT01 */
+
+} /* sgtt01_ */
diff --git a/TESTING/LIN/sgtt02.c b/TESTING/LIN/sgtt02.c
new file mode 100644
index 0000000..7e232b7
--- /dev/null
+++ b/TESTING/LIN/sgtt02.c
@@ -0,0 +1,179 @@
+/* sgtt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b6 = -1.f;
+static real c_b7 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int sgtt02_(char *trans, integer *n, integer *nrhs, real *dl,
+ real *d__, real *du, real *x, integer *ldx, real *b, integer *ldb,
+ real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j;
+ real eps;
+ extern logical lsame_(char *, char *);
+ real anorm, bnorm;
+ extern doublereal sasum_(integer *, real *, integer *);
+ real xnorm;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int slagtm_(char *, integer *, integer *, real *,
+ real *, real *, real *, real *, integer *, real *, real *,
+ integer *);
+ extern doublereal slangt_(char *, integer *, real *, real *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGTT02 computes the residual for the solution to a tridiagonal */
+/* system of equations: */
+/* RESID = norm(B - op(A)*X) / (norm(A) * norm(X) * EPS), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER */
+/* Specifies the form of the residual. */
+/* = 'N': B - A * X (No transpose) */
+/* = 'T': B - A'* X (Transpose) */
+/* = 'C': B - A'* X (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGTER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* DL (input) REAL array, dimension (N-1) */
+/* The (n-1) sub-diagonal elements of A. */
+
+/* D (input) REAL array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* DU (input) REAL array, dimension (N-1) */
+/* The (n-1) super-diagonal elements of A. */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - op(A)*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* norm(B - op(A)*X) / (norm(A) * norm(X) * EPS) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ *resid = 0.f;
+ if (*n <= 0 || *nrhs == 0) {
+ return 0;
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - op(A)*X) / ( norm(A) * norm(X) * EPS ). */
+
+ if (lsame_(trans, "N")) {
+ anorm = slangt_("1", n, &dl[1], &d__[1], &du[1]);
+ } else {
+ anorm = slangt_("I", n, &dl[1], &d__[1], &du[1]);
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute B - op(A)*X. */
+
+ slagtm_(trans, n, nrhs, &c_b6, &dl[1], &d__[1], &du[1], &x[x_offset], ldx,
+ &c_b7, &b[b_offset], ldb);
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = sasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = sasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of SGTT02 */
+
+} /* sgtt02_ */
diff --git a/TESTING/LIN/sgtt05.c b/TESTING/LIN/sgtt05.c
new file mode 100644
index 0000000..b255214
--- /dev/null
+++ b/TESTING/LIN/sgtt05.c
@@ -0,0 +1,284 @@
+/* sgtt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sgtt05_(char *trans, integer *n, integer *nrhs, real *dl,
+ real *d__, real *du, real *b, integer *ldb, real *x, integer *ldx,
+ real *xact, integer *ldxact, real *ferr, real *berr, real *reslts)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1,
+ i__2;
+ real r__1, r__2, r__3, r__4;
+
+ /* Local variables */
+ integer i__, j, k, nz;
+ real eps, tmp, diff, axbi;
+ integer imax;
+ real unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ real xnorm;
+ extern doublereal slamch_(char *);
+ real errbnd;
+ extern integer isamax_(integer *, real *, integer *);
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SGTT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* general tridiagonal matrix of order n and op(A) = A or A**T, */
+/* depending on TRANS. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+/* and NZ = max. number of nonzeros in any row of A, plus 1 */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X and XACT. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X and XACT. NRHS >= 0. */
+
+/* DL (input) REAL array, dimension (N-1) */
+/* The (n-1) sub-diagonal elements of A. */
+
+/* D (input) REAL array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* DU (input) REAL array, dimension (N-1) */
+/* The (n-1) super-diagonal elements of A. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) REAL array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) REAL array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) REAL array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.f;
+ reslts[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ notran = lsame_(trans, "N");
+ nz = 4;
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = isamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ r__2 = (r__1 = x[imax + j * x_dim1], dabs(r__1));
+ xnorm = dmax(r__2,unfl);
+ diff = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = diff, r__3 = (r__1 = x[i__ + j * x_dim1] - xact[i__ + j *
+ xact_dim1], dabs(r__1));
+ diff = dmax(r__2,r__3);
+/* L10: */
+ }
+
+ if (xnorm > 1.f) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1.f / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
+ errbnd = dmax(r__1,r__2);
+ } else {
+ errbnd = 1.f / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ if (notran) {
+ if (*n == 1) {
+ axbi = (r__1 = b[k * b_dim1 + 1], dabs(r__1)) + (r__2 = d__[1]
+ * x[k * x_dim1 + 1], dabs(r__2));
+ } else {
+ axbi = (r__1 = b[k * b_dim1 + 1], dabs(r__1)) + (r__2 = d__[1]
+ * x[k * x_dim1 + 1], dabs(r__2)) + (r__3 = du[1] * x[
+ k * x_dim1 + 2], dabs(r__3));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ tmp = (r__1 = b[i__ + k * b_dim1], dabs(r__1)) + (r__2 =
+ dl[i__ - 1] * x[i__ - 1 + k * x_dim1], dabs(r__2))
+ + (r__3 = d__[i__] * x[i__ + k * x_dim1], dabs(
+ r__3)) + (r__4 = du[i__] * x[i__ + 1 + k * x_dim1]
+ , dabs(r__4));
+ axbi = dmin(axbi,tmp);
+/* L40: */
+ }
+ tmp = (r__1 = b[*n + k * b_dim1], dabs(r__1)) + (r__2 = dl[*n
+ - 1] * x[*n - 1 + k * x_dim1], dabs(r__2)) + (r__3 =
+ d__[*n] * x[*n + k * x_dim1], dabs(r__3));
+ axbi = dmin(axbi,tmp);
+ }
+ } else {
+ if (*n == 1) {
+ axbi = (r__1 = b[k * b_dim1 + 1], dabs(r__1)) + (r__2 = d__[1]
+ * x[k * x_dim1 + 1], dabs(r__2));
+ } else {
+ axbi = (r__1 = b[k * b_dim1 + 1], dabs(r__1)) + (r__2 = d__[1]
+ * x[k * x_dim1 + 1], dabs(r__2)) + (r__3 = dl[1] * x[
+ k * x_dim1 + 2], dabs(r__3));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ tmp = (r__1 = b[i__ + k * b_dim1], dabs(r__1)) + (r__2 =
+ du[i__ - 1] * x[i__ - 1 + k * x_dim1], dabs(r__2))
+ + (r__3 = d__[i__] * x[i__ + k * x_dim1], dabs(
+ r__3)) + (r__4 = dl[i__] * x[i__ + 1 + k * x_dim1]
+ , dabs(r__4));
+ axbi = dmin(axbi,tmp);
+/* L50: */
+ }
+ tmp = (r__1 = b[*n + k * b_dim1], dabs(r__1)) + (r__2 = du[*n
+ - 1] * x[*n - 1 + k * x_dim1], dabs(r__2)) + (r__3 =
+ d__[*n] * x[*n + k * x_dim1], dabs(r__3));
+ axbi = dmin(axbi,tmp);
+ }
+ }
+/* Computing MAX */
+ r__1 = axbi, r__2 = nz * unfl;
+ tmp = berr[k] / (nz * eps + nz * unfl / dmax(r__1,r__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = dmax(reslts[2],tmp);
+ }
+/* L60: */
+ }
+
+ return 0;
+
+/* End of SGTT05 */
+
+} /* sgtt05_ */
diff --git a/TESTING/LIN/slahilb.c b/TESTING/LIN/slahilb.c
new file mode 100644
index 0000000..7a90c03
--- /dev/null
+++ b/TESTING/LIN/slahilb.c
@@ -0,0 +1,199 @@
+/* slahilb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b4 = 0.f;
+
+/* Subroutine */ int slahilb_(integer *n, integer *nrhs, real *a, integer *
+ lda, real *x, integer *ldx, real *b, integer *ldb, real *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, x_dim1, x_offset, b_dim1, b_offset, i__1, i__2;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j, m, r__, ti, tm;
+ extern /* Subroutine */ int xerbla_(char *, integer *), slaset_(
+ char *, integer *, integer *, real *, real *, real *, integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
+/* Courant Institute, Argonne National Lab, and Rice University */
+/* 28 August, 2006 */
+
+/* David Vu <dtv at cs.berkeley.edu> */
+/* Yozo Hida <yozo at cs.berkeley.edu> */
+/* Jason Riedy <ejr at cs.berkeley.edu> */
+/* D. Halligan <dhalligan at berkeley.edu> */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAHILB generates an N by N scaled Hilbert matrix in A along with */
+/* NRHS right-hand sides in B and solutions in X such that A*X=B. */
+
+/* The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all */
+/* entries are integers. The right-hand sides are the first NRHS */
+/* columns of M * the identity matrix, and the solutions are the */
+/* first NRHS columns of the inverse Hilbert matrix. */
+
+/* The condition number of the Hilbert matrix grows exponentially with */
+/* its size, roughly as O(e ** (3.5*N)). Additionally, the inverse */
+/* Hilbert matrices beyond a relatively small dimension cannot be */
+/* generated exactly without extra precision. Precision is exhausted */
+/* when the largest entry in the inverse Hilbert matrix is greater than */
+/* 2 to the power of the number of bits in the fraction of the data type */
+/* used plus one, which is 24 for single precision. */
+
+/* In single, the generated solution is exact for N <= 6 and has */
+/* small componentwise error for 7 <= N <= 11. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The dimension of the matrix A. */
+
+/* NRHS (input) NRHS */
+/* The requested number of right-hand sides. */
+
+/* A (output) REAL array, dimension (LDA, N) */
+/* The generated scaled Hilbert matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= N. */
+
+/* X (output) REAL array, dimension (LDX, NRHS) */
+/* The generated exact solutions. Currently, the first NRHS */
+/* columns of the inverse Hilbert matrix. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= N. */
+
+/* B (output) REAL array, dimension (LDB, NRHS) */
+/* The generated right-hand sides. Currently, the first NRHS */
+/* columns of LCM(1, 2, ..., 2*N-1) * the identity matrix. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= N. */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* = 1: N is too large; the data is still generated but may not */
+/* be not exact. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+/* .. Local Scalars .. */
+/* .. Parameters .. */
+/* NMAX_EXACT the largest dimension where the generated data is */
+/* exact. */
+/* NMAX_APPROX the largest dimension where the generated data has */
+/* a small componentwise relative error. */
+/* .. */
+/* .. External Functions */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --work;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0 || *n > 11) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*lda < *n) {
+ *info = -4;
+ } else if (*ldx < *n) {
+ *info = -6;
+ } else if (*ldb < *n) {
+ *info = -8;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("SLAHILB", &i__1);
+ return 0;
+ }
+ if (*n > 6) {
+ *info = 1;
+ }
+/* Compute M = the LCM of the integers [1, 2*N-1]. The largest */
+/* reasonable N is small enough that integers suffice (up to N = 11). */
+ m = 1;
+ i__1 = (*n << 1) - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ tm = m;
+ ti = i__;
+ r__ = tm % ti;
+ while(r__ != 0) {
+ tm = ti;
+ ti = r__;
+ r__ = tm % ti;
+ }
+ m = m / ti * i__;
+ }
+/* Generate the scaled Hilbert matrix in A */
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = (real) m / (i__ + j - 1);
+ }
+ }
+/* Generate matrix B as simply the first NRHS columns of M * the */
+/* identity. */
+ r__1 = (real) m;
+ slaset_("Full", n, nrhs, &c_b4, &r__1, &b[b_offset], ldb);
+/* Generate the true solutions in X. Because B = the first NRHS */
+/* columns of M*I, the true solutions are just the first NRHS columns */
+/* of the inverse Hilbert matrix. */
+ work[1] = (real) (*n);
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ work[j] = work[j - 1] / (j - 1) * (j - 1 - *n) / (j - 1) * (*n + j -
+ 1);
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__ + j * x_dim1] = work[i__] * work[j] / (i__ + j - 1);
+ }
+ }
+ return 0;
+} /* slahilb_ */
diff --git a/TESTING/LIN/slaord.c b/TESTING/LIN/slaord.c
new file mode 100644
index 0000000..23ff56d
--- /dev/null
+++ b/TESTING/LIN/slaord.c
@@ -0,0 +1,130 @@
+/* slaord.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slaord_(char *job, integer *n, real *x, integer *incx)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, ix, inc;
+ real temp;
+ extern logical lsame_(char *, char *);
+ integer ixnext;
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAORD sorts the elements of a vector x in increasing or decreasing */
+/* order. */
+
+/* Arguments */
+/* ========= */
+
+/* JOB (input) CHARACTER */
+/* = 'I': Sort in increasing order */
+/* = 'D': Sort in decreasing order */
+
+/* N (input) INTEGER */
+/* The length of the vector X. */
+
+/* X (input/output) REAL array, dimension */
+/* (1+(N-1)*INCX) */
+/* On entry, the vector of length n to be sorted. */
+/* On exit, the vector x is sorted in the prescribed order. */
+
+/* INCX (input) INTEGER */
+/* The spacing between successive elements of X. INCX >= 0. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --x;
+
+ /* Function Body */
+ inc = abs(*incx);
+ if (lsame_(job, "I")) {
+
+/* Sort in increasing order */
+
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ ix = (i__ - 1) * inc + 1;
+L10:
+ if (ix == 1) {
+ goto L20;
+ }
+ ixnext = ix - inc;
+ if (x[ix] > x[ixnext]) {
+ goto L20;
+ } else {
+ temp = x[ix];
+ x[ix] = x[ixnext];
+ x[ixnext] = temp;
+ }
+ ix = ixnext;
+ goto L10;
+L20:
+ ;
+ }
+
+ } else if (lsame_(job, "D")) {
+
+/* Sort in decreasing order */
+
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ ix = (i__ - 1) * inc + 1;
+L30:
+ if (ix == 1) {
+ goto L40;
+ }
+ ixnext = ix - inc;
+ if (x[ix] < x[ixnext]) {
+ goto L40;
+ } else {
+ temp = x[ix];
+ x[ix] = x[ixnext];
+ x[ixnext] = temp;
+ }
+ ix = ixnext;
+ goto L30;
+L40:
+ ;
+ }
+ }
+ return 0;
+
+/* End of SLAORD */
+
+} /* slaord_ */
diff --git a/TESTING/LIN/slaptm.c b/TESTING/LIN/slaptm.c
new file mode 100644
index 0000000..7f6915d
--- /dev/null
+++ b/TESTING/LIN/slaptm.c
@@ -0,0 +1,183 @@
+/* slaptm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slaptm_(integer *n, integer *nrhs, real *alpha, real *
+ d__, real *e, real *x, integer *ldx, real *beta, real *b, integer *
+ ldb)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAPTM multiplies an N by NRHS matrix X by a symmetric tridiagonal */
+/* matrix A and stores the result in a matrix B. The operation has the */
+/* form */
+
+/* B := alpha * A * X + beta * B */
+
+/* where alpha may be either 1. or -1. and beta may be 0., 1., or -1. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. */
+
+/* ALPHA (input) REAL */
+/* The scalar alpha. ALPHA must be 1. or -1.; otherwise, */
+/* it is assumed to be 0. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) REAL array, dimension (N-1) */
+/* The (n-1) subdiagonal or superdiagonal elements of A. */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The N by NRHS matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(N,1). */
+
+/* BETA (input) REAL */
+/* The scalar beta. BETA must be 0., 1., or -1.; otherwise, */
+/* it is assumed to be 1. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the N by NRHS matrix B. */
+/* On exit, B is overwritten by the matrix expression */
+/* B := alpha * A * X + beta * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(N,1). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Multiply B by BETA if BETA.NE.1. */
+
+ if (*beta == 0.f) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (*beta == -1.f) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = -b[i__ + j * b_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+ if (*alpha == 1.f) {
+
+/* Compute B := B + A*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ b[j * b_dim1 + 1] += d__[1] * x[j * x_dim1 + 1];
+ } else {
+ b[j * b_dim1 + 1] = b[j * b_dim1 + 1] + d__[1] * x[j * x_dim1
+ + 1] + e[1] * x[j * x_dim1 + 2];
+ b[*n + j * b_dim1] = b[*n + j * b_dim1] + e[*n - 1] * x[*n -
+ 1 + j * x_dim1] + d__[*n] * x[*n + j * x_dim1];
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = b[i__ + j * b_dim1] + e[i__ - 1] *
+ x[i__ - 1 + j * x_dim1] + d__[i__] * x[i__ + j *
+ x_dim1] + e[i__] * x[i__ + 1 + j * x_dim1];
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else if (*alpha == -1.f) {
+
+/* Compute B := B - A*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ b[j * b_dim1 + 1] -= d__[1] * x[j * x_dim1 + 1];
+ } else {
+ b[j * b_dim1 + 1] = b[j * b_dim1 + 1] - d__[1] * x[j * x_dim1
+ + 1] - e[1] * x[j * x_dim1 + 2];
+ b[*n + j * b_dim1] = b[*n + j * b_dim1] - e[*n - 1] * x[*n -
+ 1 + j * x_dim1] - d__[*n] * x[*n + j * x_dim1];
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ b[i__ + j * b_dim1] = b[i__ + j * b_dim1] - e[i__ - 1] *
+ x[i__ - 1 + j * x_dim1] - d__[i__] * x[i__ + j *
+ x_dim1] - e[i__] * x[i__ + 1 + j * x_dim1];
+/* L70: */
+ }
+ }
+/* L80: */
+ }
+ }
+ return 0;
+
+/* End of SLAPTM */
+
+} /* slaptm_ */
diff --git a/TESTING/LIN/slarhs.c b/TESTING/LIN/slarhs.c
new file mode 100644
index 0000000..7c3717e
--- /dev/null
+++ b/TESTING/LIN/slarhs.c
@@ -0,0 +1,394 @@
+/* slarhs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static real c_b32 = 1.f;
+static real c_b33 = 0.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int slarhs_(char *path, char *xtype, char *uplo, char *trans,
+ integer *m, integer *n, integer *kl, integer *ku, integer *nrhs,
+ real *a, integer *lda, real *x, integer *ldx, real *b, integer *ldb,
+ integer *iseed, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j;
+ char c1[1], c2[2];
+ integer mb, nx;
+ logical gen, tri, qrs, sym, band;
+ char diag[1];
+ logical tran;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *), sgbmv_(char *, integer *,
+ integer *, integer *, integer *, real *, real *, integer *, real *
+, integer *, real *, real *, integer *), ssbmv_(char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+, real *, real *, integer *), stbmv_(char *, char *, char
+ *, integer *, integer *, real *, integer *, real *, integer *), strmm_(char *, char *, char *, char *,
+ integer *, integer *, real *, real *, integer *, real *, integer *
+), sspmv_(char *, integer *, real
+ *, real *, real *, integer *, real *, real *, integer *),
+ ssymm_(char *, char *, integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, real *, integer *), stpmv_(char *, char *, char *, integer *, real *, real *,
+ integer *), xerbla_(char *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+ logical notran;
+ extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
+ *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARHS chooses a set of NRHS random solution vectors and sets */
+/* up the right hand sides for the linear system */
+/* op( A ) * X = B, */
+/* where op( A ) may be A or A' (transpose of A). */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The type of the real matrix A. PATH may be given in any */
+/* combination of upper and lower case. Valid types include */
+/* xGE: General m x n matrix */
+/* xGB: General banded matrix */
+/* xPO: Symmetric positive definite, 2-D storage */
+/* xPP: Symmetric positive definite packed */
+/* xPB: Symmetric positive definite banded */
+/* xSY: Symmetric indefinite, 2-D storage */
+/* xSP: Symmetric indefinite packed */
+/* xSB: Symmetric indefinite banded */
+/* xTR: Triangular */
+/* xTP: Triangular packed */
+/* xTB: Triangular banded */
+/* xQR: General m x n matrix */
+/* xLQ: General m x n matrix */
+/* xQL: General m x n matrix */
+/* xRQ: General m x n matrix */
+/* where the leading character indicates the precision. */
+
+/* XTYPE (input) CHARACTER*1 */
+/* Specifies how the exact solution X will be determined: */
+/* = 'N': New solution; generate a random X. */
+/* = 'C': Computed; use value of X on entry. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* matrix A is stored, if A is symmetric. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to the matrix A. */
+/* = 'N': System is A * x = b */
+/* = 'T': System is A'* x = b */
+/* = 'C': System is A'* x = b */
+
+/* M (input) INTEGER */
+/* The number or rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* Used only if A is a band matrix; specifies the number of */
+/* subdiagonals of A if A is a general band matrix or if A is */
+/* symmetric or triangular and UPLO = 'L'; specifies the number */
+/* of superdiagonals of A if A is symmetric or triangular and */
+/* UPLO = 'U'. 0 <= KL <= M-1. */
+
+/* KU (input) INTEGER */
+/* Used only if A is a general band matrix or if A is */
+/* triangular. */
+
+/* If PATH = xGB, specifies the number of superdiagonals of A, */
+/* and 0 <= KU <= N-1. */
+
+/* If PATH = xTR, xTP, or xTB, specifies whether or not the */
+/* matrix has unit diagonal: */
+/* = 1: matrix has non-unit diagonal (default) */
+/* = 2: matrix has unit diagonal */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors in the system A*X = B. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The test matrix whose type is given by PATH. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If PATH = xGB, LDA >= KL+KU+1. */
+/* If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1. */
+/* Otherwise, LDA >= max(1,M). */
+
+/* X (input or output) REAL array, dimension(LDX,NRHS) */
+/* On entry, if XTYPE = 'C' (for 'Computed'), then X contains */
+/* the exact solution to the system of linear equations. */
+/* On exit, if XTYPE = 'N' (for 'New'), then X is initialized */
+/* with random values. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M). */
+
+/* B (output) REAL array, dimension (LDB,NRHS) */
+/* The right hand side vector(s) for the system of equations, */
+/* computed from B = op(A) * X, where op(A) is determined by */
+/* TRANS. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. If TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N). */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* The seed vector for the random number generator (used in */
+/* SLATMS). Modified on exit. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --iseed;
+
+ /* Function Body */
+ *info = 0;
+ *(unsigned char *)c1 = *(unsigned char *)path;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ tran = lsame_(trans, "T") || lsame_(trans, "C");
+ notran = ! tran;
+ gen = lsame_(path + 1, "G");
+ qrs = lsame_(path + 1, "Q") || lsame_(path + 2,
+ "Q");
+ sym = lsame_(path + 1, "P") || lsame_(path + 1,
+ "S");
+ tri = lsame_(path + 1, "T");
+ band = lsame_(path + 2, "B");
+ if (! lsame_(c1, "Single precision")) {
+ *info = -1;
+ } else if (! (lsame_(xtype, "N") || lsame_(xtype,
+ "C"))) {
+ *info = -2;
+ } else if ((sym || tri) && ! (lsame_(uplo, "U") ||
+ lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if ((gen || qrs) && ! (tran || lsame_(trans, "N"))) {
+ *info = -4;
+ } else if (*m < 0) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (band && *kl < 0) {
+ *info = -7;
+ } else if (band && *ku < 0) {
+ *info = -8;
+ } else if (*nrhs < 0) {
+ *info = -9;
+ } else if (! band && *lda < max(1,*m) || band && (sym || tri) && *lda < *
+ kl + 1 || band && gen && *lda < *kl + *ku + 1) {
+ *info = -11;
+ } else if (notran && *ldx < max(1,*n) || tran && *ldx < max(1,*m)) {
+ *info = -13;
+ } else if (notran && *ldb < max(1,*m) || tran && *ldb < max(1,*n)) {
+ *info = -15;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLARHS", &i__1);
+ return 0;
+ }
+
+/* Initialize X to NRHS random vectors unless XTYPE = 'C'. */
+
+ if (tran) {
+ nx = *m;
+ mb = *n;
+ } else {
+ nx = *n;
+ mb = *m;
+ }
+ if (! lsame_(xtype, "C")) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ slarnv_(&c__2, &iseed[1], n, &x[j * x_dim1 + 1]);
+/* L10: */
+ }
+ }
+
+/* Multiply X by op( A ) using an appropriate */
+/* matrix multiply routine. */
+
+ if (lsamen_(&c__2, c2, "GE") || lsamen_(&c__2, c2,
+ "QR") || lsamen_(&c__2, c2, "LQ") || lsamen_(&c__2, c2, "QL") ||
+ lsamen_(&c__2, c2, "RQ")) {
+
+/* General matrix */
+
+ sgemm_(trans, "N", &mb, nrhs, &nx, &c_b32, &a[a_offset], lda, &x[
+ x_offset], ldx, &c_b33, &b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "PO") || lsamen_(&
+ c__2, c2, "SY")) {
+
+/* Symmetric matrix, 2-D storage */
+
+ ssymm_("Left", uplo, n, nrhs, &c_b32, &a[a_offset], lda, &x[x_offset],
+ ldx, &c_b33, &b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* General matrix, band storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ sgbmv_(trans, &mb, &nx, kl, ku, &c_b32, &a[a_offset], lda, &x[j *
+ x_dim1 + 1], &c__1, &c_b33, &b[j * b_dim1 + 1], &c__1);
+/* L20: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* Symmetric matrix, band storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ssbmv_(uplo, n, kl, &c_b32, &a[a_offset], lda, &x[j * x_dim1 + 1],
+ &c__1, &c_b33, &b[j * b_dim1 + 1], &c__1);
+/* L30: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "PP") || lsamen_(&
+ c__2, c2, "SP")) {
+
+/* Symmetric matrix, packed storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ sspmv_(uplo, n, &c_b32, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
+ c_b33, &b[j * b_dim1 + 1], &c__1);
+/* L40: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "TR")) {
+
+/* Triangular matrix. Note that for triangular matrices, */
+/* KU = 1 => non-unit triangular */
+/* KU = 2 => unit triangular */
+
+ slacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ strmm_("Left", uplo, trans, diag, n, nrhs, &c_b32, &a[a_offset], lda,
+ &b[b_offset], ldb)
+ ;
+
+ } else if (lsamen_(&c__2, c2, "TP")) {
+
+/* Triangular matrix, packed storage */
+
+ slacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ stpmv_(uplo, trans, diag, n, &a[a_offset], &b[j * b_dim1 + 1], &
+ c__1);
+/* L50: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "TB")) {
+
+/* Triangular matrix, banded storage */
+
+ slacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ stbmv_(uplo, trans, diag, n, kl, &a[a_offset], lda, &b[j * b_dim1
+ + 1], &c__1);
+/* L60: */
+ }
+
+ } else {
+
+/* If PATH is none of the above, return with an error code. */
+
+ *info = -1;
+ i__1 = -(*info);
+ xerbla_("SLARHS", &i__1);
+ }
+
+ return 0;
+
+/* End of SLARHS */
+
+} /* slarhs_ */
diff --git a/TESTING/LIN/slatb4.c b/TESTING/LIN/slatb4.c
new file mode 100644
index 0000000..1b8d4fa
--- /dev/null
+++ b/TESTING/LIN/slatb4.c
@@ -0,0 +1,483 @@
+/* slatb4.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+
+/* Subroutine */ int slatb4_(char *path, integer *imat, integer *m, integer *
+ n, char *type__, integer *kl, integer *ku, real *anorm, integer *mode,
+ real *cndnum, char *dist)
+{
+ /* Initialized data */
+
+ static logical first = TRUE_;
+
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ char c2[2];
+ integer mat;
+ static real eps, badc1, badc2, large, small;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ extern logical lsamen_(integer *, char *, char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLATB4 sets parameters for the matrix generator based on the type of */
+/* matrix to be generated. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name. */
+
+/* IMAT (input) INTEGER */
+/* An integer key describing which matrix to generate for this */
+/* path. */
+
+/* M (input) INTEGER */
+/* The number of rows in the matrix to be generated. */
+
+/* N (input) INTEGER */
+/* The number of columns in the matrix to be generated. */
+
+/* TYPE (output) CHARACTER*1 */
+/* The type of the matrix to be generated: */
+/* = 'S': symmetric matrix */
+/* = 'P': symmetric positive (semi)definite matrix */
+/* = 'N': nonsymmetric matrix */
+
+/* KL (output) INTEGER */
+/* The lower band width of the matrix to be generated. */
+
+/* KU (output) INTEGER */
+/* The upper band width of the matrix to be generated. */
+
+/* ANORM (output) REAL */
+/* The desired norm of the matrix to be generated. The diagonal */
+/* matrix of singular values or eigenvalues is scaled by this */
+/* value. */
+
+/* MODE (output) INTEGER */
+/* A key indicating how to choose the vector of eigenvalues. */
+
+/* CNDNUM (output) REAL */
+/* The desired condition number. */
+
+/* DIST (output) CHARACTER*1 */
+/* The type of distribution to be used by the random number */
+/* generator. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Set some constants for use in the subroutine. */
+
+ if (first) {
+ first = FALSE_;
+ eps = slamch_("Precision");
+ badc2 = .1f / eps;
+ badc1 = sqrt(badc2);
+ small = slamch_("Safe minimum");
+ large = 1.f / small;
+
+/* If it looks like we're on a Cray, take the square root of */
+/* SMALL and LARGE to avoid overflow and underflow problems. */
+
+ slabad_(&small, &large);
+ small = small / eps * .25f;
+ large = 1.f / small;
+ }
+
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set some parameters we don't plan to change. */
+
+ *(unsigned char *)dist = 'S';
+ *mode = 3;
+
+ if (lsamen_(&c__2, c2, "QR") || lsamen_(&c__2, c2,
+ "LQ") || lsamen_(&c__2, c2, "QL") || lsamen_(&c__2, c2, "RQ")) {
+
+/* xQR, xLQ, xQL, xRQ: Set parameters to generate a general */
+/* M x N matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the lower and upper bandwidths. */
+
+ if (*imat == 1) {
+ *kl = 0;
+ *ku = 0;
+ } else if (*imat == 2) {
+ *kl = 0;
+/* Computing MAX */
+ i__1 = *n - 1;
+ *ku = max(i__1,0);
+ } else if (*imat == 3) {
+/* Computing MAX */
+ i__1 = *m - 1;
+ *kl = max(i__1,0);
+ *ku = 0;
+ } else {
+/* Computing MAX */
+ i__1 = *m - 1;
+ *kl = max(i__1,0);
+/* Computing MAX */
+ i__1 = *n - 1;
+ *ku = max(i__1,0);
+ }
+
+/* Set the condition number and norm. */
+
+ if (*imat == 5) {
+ *cndnum = badc1;
+ } else if (*imat == 6) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.f;
+ }
+
+ if (*imat == 7) {
+ *anorm = small;
+ } else if (*imat == 8) {
+ *anorm = large;
+ } else {
+ *anorm = 1.f;
+ }
+
+ } else if (lsamen_(&c__2, c2, "GE")) {
+
+/* xGE: Set parameters to generate a general M x N matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the lower and upper bandwidths. */
+
+ if (*imat == 1) {
+ *kl = 0;
+ *ku = 0;
+ } else if (*imat == 2) {
+ *kl = 0;
+/* Computing MAX */
+ i__1 = *n - 1;
+ *ku = max(i__1,0);
+ } else if (*imat == 3) {
+/* Computing MAX */
+ i__1 = *m - 1;
+ *kl = max(i__1,0);
+ *ku = 0;
+ } else {
+/* Computing MAX */
+ i__1 = *m - 1;
+ *kl = max(i__1,0);
+/* Computing MAX */
+ i__1 = *n - 1;
+ *ku = max(i__1,0);
+ }
+
+/* Set the condition number and norm. */
+
+ if (*imat == 8) {
+ *cndnum = badc1;
+ } else if (*imat == 9) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.f;
+ }
+
+ if (*imat == 10) {
+ *anorm = small;
+ } else if (*imat == 11) {
+ *anorm = large;
+ } else {
+ *anorm = 1.f;
+ }
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* xGB: Set parameters to generate a general banded matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the condition number and norm. */
+
+ if (*imat == 5) {
+ *cndnum = badc1;
+ } else if (*imat == 6) {
+ *cndnum = badc2 * .1f;
+ } else {
+ *cndnum = 2.f;
+ }
+
+ if (*imat == 7) {
+ *anorm = small;
+ } else if (*imat == 8) {
+ *anorm = large;
+ } else {
+ *anorm = 1.f;
+ }
+
+ } else if (lsamen_(&c__2, c2, "GT")) {
+
+/* xGT: Set parameters to generate a general tridiagonal matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the lower and upper bandwidths. */
+
+ if (*imat == 1) {
+ *kl = 0;
+ } else {
+ *kl = 1;
+ }
+ *ku = *kl;
+
+/* Set the condition number and norm. */
+
+ if (*imat == 3) {
+ *cndnum = badc1;
+ } else if (*imat == 4) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.f;
+ }
+
+ if (*imat == 5 || *imat == 11) {
+ *anorm = small;
+ } else if (*imat == 6 || *imat == 12) {
+ *anorm = large;
+ } else {
+ *anorm = 1.f;
+ }
+
+ } else if (lsamen_(&c__2, c2, "PO") || lsamen_(&
+ c__2, c2, "PP") || lsamen_(&c__2, c2, "SY") || lsamen_(&c__2, c2, "SP")) {
+
+/* xPO, xPP, xSY, xSP: Set parameters to generate a */
+/* symmetric matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = *(unsigned char *)c2;
+
+/* Set the lower and upper bandwidths. */
+
+ if (*imat == 1) {
+ *kl = 0;
+ } else {
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kl = max(i__1,0);
+ }
+ *ku = *kl;
+
+/* Set the condition number and norm. */
+
+ if (*imat == 6) {
+ *cndnum = badc1;
+ } else if (*imat == 7) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.f;
+ }
+
+ if (*imat == 8) {
+ *anorm = small;
+ } else if (*imat == 9) {
+ *anorm = large;
+ } else {
+ *anorm = 1.f;
+ }
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* xPB: Set parameters to generate a symmetric band matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'P';
+
+/* Set the norm and condition number. */
+
+ if (*imat == 5) {
+ *cndnum = badc1;
+ } else if (*imat == 6) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.f;
+ }
+
+ if (*imat == 7) {
+ *anorm = small;
+ } else if (*imat == 8) {
+ *anorm = large;
+ } else {
+ *anorm = 1.f;
+ }
+
+ } else if (lsamen_(&c__2, c2, "PT")) {
+
+/* xPT: Set parameters to generate a symmetric positive definite */
+/* tridiagonal matrix. */
+
+ *(unsigned char *)type__ = 'P';
+ if (*imat == 1) {
+ *kl = 0;
+ } else {
+ *kl = 1;
+ }
+ *ku = *kl;
+
+/* Set the condition number and norm. */
+
+ if (*imat == 3) {
+ *cndnum = badc1;
+ } else if (*imat == 4) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.f;
+ }
+
+ if (*imat == 5 || *imat == 11) {
+ *anorm = small;
+ } else if (*imat == 6 || *imat == 12) {
+ *anorm = large;
+ } else {
+ *anorm = 1.f;
+ }
+
+ } else if (lsamen_(&c__2, c2, "TR") || lsamen_(&
+ c__2, c2, "TP")) {
+
+/* xTR, xTP: Set parameters to generate a triangular matrix */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the lower and upper bandwidths. */
+
+ mat = abs(*imat);
+ if (mat == 1 || mat == 7) {
+ *kl = 0;
+ *ku = 0;
+ } else if (*imat < 0) {
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kl = max(i__1,0);
+ *ku = 0;
+ } else {
+ *kl = 0;
+/* Computing MAX */
+ i__1 = *n - 1;
+ *ku = max(i__1,0);
+ }
+
+/* Set the condition number and norm. */
+
+ if (mat == 3 || mat == 9) {
+ *cndnum = badc1;
+ } else if (mat == 4) {
+ *cndnum = badc2;
+ } else if (mat == 10) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.f;
+ }
+
+ if (mat == 5) {
+ *anorm = small;
+ } else if (mat == 6) {
+ *anorm = large;
+ } else {
+ *anorm = 1.f;
+ }
+
+ } else if (lsamen_(&c__2, c2, "TB")) {
+
+/* xTB: Set parameters to generate a triangular band matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the norm and condition number. */
+
+ if (*imat == 2 || *imat == 8) {
+ *cndnum = badc1;
+ } else if (*imat == 3 || *imat == 9) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.f;
+ }
+
+ if (*imat == 4) {
+ *anorm = small;
+ } else if (*imat == 5) {
+ *anorm = large;
+ } else {
+ *anorm = 1.f;
+ }
+ }
+ if (*n <= 1) {
+ *cndnum = 1.f;
+ }
+
+ return 0;
+
+/* End of SLATB4 */
+
+} /* slatb4_ */
diff --git a/TESTING/LIN/slatb5.c b/TESTING/LIN/slatb5.c
new file mode 100644
index 0000000..34d7506
--- /dev/null
+++ b/TESTING/LIN/slatb5.c
@@ -0,0 +1,184 @@
+/* slatb5.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slatb5_(char *path, integer *imat, integer *n, char *
+ type__, integer *kl, integer *ku, real *anorm, integer *mode, real *
+ cndnum, char *dist)
+{
+ /* Initialized data */
+
+ static logical first = TRUE_;
+
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ char c2[2];
+ static real eps, badc1, badc2, large, small;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLATB5 sets parameters for the matrix generator based on the type */
+/* of matrix to be generated. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name. */
+
+/* IMAT (input) INTEGER */
+/* An integer key describing which matrix to generate for this */
+/* path. */
+
+/* N (input) INTEGER */
+/* The number of rows and columns in the matrix to be generated. */
+
+/* TYPE (output) CHARACTER*1 */
+/* The type of the matrix to be generated: */
+/* = 'S': symmetric matrix */
+/* = 'P': symmetric positive (semi)definite matrix */
+/* = 'N': nonsymmetric matrix */
+
+/* KL (output) INTEGER */
+/* The lower band width of the matrix to be generated. */
+
+/* KU (output) INTEGER */
+/* The upper band width of the matrix to be generated. */
+
+/* ANORM (output) REAL */
+/* The desired norm of the matrix to be generated. The diagonal */
+/* matrix of singular values or eigenvalues is scaled by this */
+/* value. */
+
+/* MODE (output) INTEGER */
+/* A key indicating how to choose the vector of eigenvalues. */
+
+/* CNDNUM (output) REAL */
+/* The desired condition number. */
+
+/* DIST (output) CHARACTER*1 */
+/* The type of distribution to be used by the random number */
+/* generator. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Set some constants for use in the subroutine. */
+
+ if (first) {
+ first = FALSE_;
+ eps = slamch_("Precision");
+ badc2 = .1f / eps;
+ badc1 = sqrt(badc2);
+ small = slamch_("Safe minimum");
+ large = 1.f / small;
+
+/* If it looks like we're on a Cray, take the square root of */
+/* SMALL and LARGE to avoid overflow and underflow problems. */
+
+ slabad_(&small, &large);
+ small = small / eps * .25f;
+ large = 1.f / small;
+ }
+
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set some parameters */
+
+ *(unsigned char *)dist = 'S';
+ *mode = 3;
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = *(unsigned char *)c2;
+
+/* Set the lower and upper bandwidths. */
+
+ if (*imat == 1) {
+ *kl = 0;
+ } else {
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kl = max(i__1,0);
+ }
+ *ku = *kl;
+
+/* Set the condition number and norm.etc */
+
+ if (*imat == 3) {
+ *cndnum = 1e4f;
+ *mode = 2;
+ } else if (*imat == 4) {
+ *cndnum = 1e4f;
+ *mode = 1;
+ } else if (*imat == 5) {
+ *cndnum = 1e4f;
+ *mode = 3;
+ } else if (*imat == 6) {
+ *cndnum = badc1;
+ } else if (*imat == 7) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.f;
+ }
+
+ if (*imat == 8) {
+ *anorm = small;
+ } else if (*imat == 9) {
+ *anorm = large;
+ } else {
+ *anorm = 1.f;
+ }
+
+ if (*n <= 1) {
+ *cndnum = 1.f;
+ }
+
+ return 0;
+
+/* End of SLATB5 */
+
+} /* slatb5_ */
diff --git a/TESTING/LIN/slattb.c b/TESTING/LIN/slattb.c
new file mode 100644
index 0000000..3d828bd
--- /dev/null
+++ b/TESTING/LIN/slattb.c
@@ -0,0 +1,859 @@
+/* slattb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static real c_b36 = 2.f;
+static real c_b47 = 1.f;
+static integer c_n1 = -1;
+
+/* Subroutine */ int slattb_(integer *imat, char *uplo, char *trans, char *
+ diag, integer *iseed, integer *n, integer *kd, real *ab, integer *
+ ldab, real *b, real *work, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5;
+ real r__1, r__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal), r_sign(real *, real *), pow_dd(doublereal *,
+ doublereal *);
+
+ /* Local variables */
+ integer i__, j, kl, ku, iy;
+ real ulp, sfac;
+ integer ioff, mode, lenj;
+ char path[3], dist[1];
+ real unfl, rexp;
+ char type__[1];
+ real texp, star1, plus1, plus2, bscal;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real tscal, anorm, bnorm, tleft;
+ logical upper;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), sswap_(integer *, real *, integer *, real *, integer *
+);
+ real tnorm;
+ extern /* Subroutine */ int slatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, real *, integer *, real *, char *
+), slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ char packit[1];
+ real bignum;
+ extern integer isamax_(integer *, real *, integer *);
+ extern doublereal slarnd_(integer *, integer *);
+ real cndnum;
+ integer jcount;
+ extern /* Subroutine */ int slatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, real *, integer *, real *, integer *), slarnv_(integer *, integer *, integer *, real *);
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLATTB generates a triangular test matrix in 2-dimensional storage. */
+/* IMAT and UPLO uniquely specify the properties of the test matrix, */
+/* which is returned in the array A. */
+
+/* Arguments */
+/* ========= */
+
+/* IMAT (input) INTEGER */
+/* An integer key describing which matrix to generate for this */
+/* path. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A will be upper or lower */
+/* triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies whether the matrix or its transpose will be used. */
+/* = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose (= transpose) */
+
+/* DIAG (output) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* The seed vector for the random number generator (used in */
+/* SLATMS). Modified on exit. */
+
+/* N (input) INTEGER */
+/* The order of the matrix to be generated. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the banded */
+/* triangular matrix A. KD >= 0. */
+
+/* AB (output) REAL array, dimension (LDAB,N) */
+/* The upper or lower triangular banded matrix A, stored in the */
+/* first KD+1 rows of AB. Let j be a column of A, 1<=j<=n. */
+/* If UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j. */
+/* If UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (workspace) REAL array, dimension (N) */
+
+/* WORK (workspace) REAL array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iseed;
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --b;
+ --work;
+
+ /* Function Body */
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "TB", (ftnlen)2, (ftnlen)2);
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ smlnum = unfl;
+ bignum = (1.f - ulp) / smlnum;
+ slabad_(&smlnum, &bignum);
+ if (*imat >= 6 && *imat <= 9 || *imat == 17) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ *info = 0;
+
+/* Quick return if N.LE.0. */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Call SLATB4 to set parameters for SLATMS. */
+
+ upper = lsame_(uplo, "U");
+ if (upper) {
+ slatb4_(path, imat, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ ku = *kd;
+/* Computing MAX */
+ i__1 = 0, i__2 = *kd - *n + 1;
+ ioff = max(i__1,i__2) + 1;
+ kl = 0;
+ *(unsigned char *)packit = 'Q';
+ } else {
+ i__1 = -(*imat);
+ slatb4_(path, &i__1, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ kl = *kd;
+ ioff = 1;
+ ku = 0;
+ *(unsigned char *)packit = 'B';
+ }
+
+/* IMAT <= 5: Non-unit triangular matrix */
+
+ if (*imat <= 5) {
+ slatms_(n, n, dist, &iseed[1], type__, &b[1], &mode, &cndnum, &anorm,
+ &kl, &ku, packit, &ab[ioff + ab_dim1], ldab, &work[1], info);
+
+/* IMAT > 5: Unit triangular matrix */
+/* The diagonal is deliberately set to something other than 1. */
+
+/* IMAT = 6: Matrix is the identity */
+
+ } else if (*imat == 6) {
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = 1, i__3 = *kd + 2 - j;
+ i__4 = *kd;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ ab[i__ + j * ab_dim1] = 0.f;
+/* L10: */
+ }
+ ab[*kd + 1 + j * ab_dim1] = (real) j;
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ab[j * ab_dim1 + 1] = (real) j;
+/* Computing MIN */
+ i__2 = *kd + 1, i__3 = *n - j + 1;
+ i__4 = min(i__2,i__3);
+ for (i__ = 2; i__ <= i__4; ++i__) {
+ ab[i__ + j * ab_dim1] = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+/* IMAT > 6: Non-trivial unit triangular matrix */
+
+/* A unit triangular matrix T with condition CNDNUM is formed. */
+/* In this version, T only has bandwidth 2, the rest of it is zero. */
+
+ } else if (*imat <= 9) {
+ tnorm = sqrt(cndnum);
+
+/* Initialize AB to zero. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__2 = *kd + 2 - j;
+ i__3 = *kd;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ ab[i__ + j * ab_dim1] = 0.f;
+/* L50: */
+ }
+ ab[*kd + 1 + j * ab_dim1] = (real) j;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = *kd + 1, i__2 = *n - j + 1;
+ i__3 = min(i__4,i__2);
+ for (i__ = 2; i__ <= i__3; ++i__) {
+ ab[i__ + j * ab_dim1] = 0.f;
+/* L70: */
+ }
+ ab[j * ab_dim1 + 1] = (real) j;
+/* L80: */
+ }
+ }
+
+/* Special case: T is tridiagonal. Set every other offdiagonal */
+/* so that the matrix has norm TNORM+1. */
+
+ if (*kd == 1) {
+ if (upper) {
+ r__1 = slarnd_(&c__2, &iseed[1]);
+ ab[(ab_dim1 << 1) + 1] = r_sign(&tnorm, &r__1);
+ lenj = (*n - 3) / 2;
+ slarnv_(&c__2, &iseed[1], &lenj, &work[1]);
+ i__1 = lenj;
+ for (j = 1; j <= i__1; ++j) {
+ ab[(j + 1 << 1) * ab_dim1 + 1] = tnorm * work[j];
+/* L90: */
+ }
+ } else {
+ r__1 = slarnd_(&c__2, &iseed[1]);
+ ab[ab_dim1 + 2] = r_sign(&tnorm, &r__1);
+ lenj = (*n - 3) / 2;
+ slarnv_(&c__2, &iseed[1], &lenj, &work[1]);
+ i__1 = lenj;
+ for (j = 1; j <= i__1; ++j) {
+ ab[((j << 1) + 1) * ab_dim1 + 2] = tnorm * work[j];
+/* L100: */
+ }
+ }
+ } else if (*kd > 1) {
+
+/* Form a unit triangular matrix T with condition CNDNUM. T is */
+/* given by */
+/* | 1 + * | */
+/* | 1 + | */
+/* T = | 1 + * | */
+/* | 1 + | */
+/* | 1 + * | */
+/* | 1 + | */
+/* | . . . | */
+/* Each element marked with a '*' is formed by taking the product */
+/* of the adjacent elements marked with '+'. The '*'s can be */
+/* chosen freely, and the '+'s are chosen so that the inverse of */
+/* T will have elements of the same magnitude as T. */
+
+/* The two offdiagonals of T are stored in WORK. */
+
+ r__1 = slarnd_(&c__2, &iseed[1]);
+ star1 = r_sign(&tnorm, &r__1);
+ sfac = sqrt(tnorm);
+ r__1 = slarnd_(&c__2, &iseed[1]);
+ plus1 = r_sign(&sfac, &r__1);
+ i__1 = *n;
+ for (j = 1; j <= i__1; j += 2) {
+ plus2 = star1 / plus1;
+ work[j] = plus1;
+ work[*n + j] = star1;
+ if (j + 1 <= *n) {
+ work[j + 1] = plus2;
+ work[*n + j + 1] = 0.f;
+ plus1 = star1 / plus2;
+
+/* Generate a new *-value with norm between sqrt(TNORM) */
+/* and TNORM. */
+
+ rexp = slarnd_(&c__2, &iseed[1]);
+ if (rexp < 0.f) {
+ d__1 = (doublereal) sfac;
+ d__2 = (doublereal) (1.f - rexp);
+ star1 = -pow_dd(&d__1, &d__2);
+ } else {
+ d__1 = (doublereal) sfac;
+ d__2 = (doublereal) (rexp + 1.f);
+ star1 = pow_dd(&d__1, &d__2);
+ }
+ }
+/* L110: */
+ }
+
+/* Copy the tridiagonal T to AB. */
+
+ if (upper) {
+ i__1 = *n - 1;
+ scopy_(&i__1, &work[1], &c__1, &ab[*kd + (ab_dim1 << 1)],
+ ldab);
+ i__1 = *n - 2;
+ scopy_(&i__1, &work[*n + 1], &c__1, &ab[*kd - 1 + ab_dim1 * 3]
+, ldab);
+ } else {
+ i__1 = *n - 1;
+ scopy_(&i__1, &work[1], &c__1, &ab[ab_dim1 + 2], ldab);
+ i__1 = *n - 2;
+ scopy_(&i__1, &work[*n + 1], &c__1, &ab[ab_dim1 + 3], ldab);
+ }
+ }
+
+/* IMAT > 9: Pathological test cases. These triangular matrices */
+/* are badly scaled or badly conditioned, so when used in solving a */
+/* triangular system they may cause overflow in the solution vector. */
+
+ } else if (*imat == 10) {
+
+/* Type 10: Generate a triangular matrix with elements between */
+/* -1 and 1. Give the diagonal norm 2 to make it well-conditioned. */
+/* Make the right hand side large so that it requires scaling. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j, i__4 = *kd + 1;
+ lenj = min(i__3,i__4);
+ slarnv_(&c__2, &iseed[1], &lenj, &ab[*kd + 2 - lenj + j *
+ ab_dim1]);
+ ab[*kd + 1 + j * ab_dim1] = r_sign(&c_b36, &ab[*kd + 1 + j *
+ ab_dim1]);
+/* L120: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n - j + 1, i__4 = *kd + 1;
+ lenj = min(i__3,i__4);
+ if (lenj > 0) {
+ slarnv_(&c__2, &iseed[1], &lenj, &ab[j * ab_dim1 + 1]);
+ }
+ ab[j * ab_dim1 + 1] = r_sign(&c_b36, &ab[j * ab_dim1 + 1]);
+/* L130: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ slarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = isamax_(n, &b[1], &c__1);
+ bnorm = (r__1 = b[iy], dabs(r__1));
+ bscal = bignum / dmax(1.f,bnorm);
+ sscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 11) {
+
+/* Type 11: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 11, the offdiagonal elements are small (CNORM(j) < 1). */
+
+ slarnv_(&c__2, &iseed[1], n, &b[1]);
+ tscal = 1.f / (real) (*kd + 1);
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j, i__4 = *kd + 1;
+ lenj = min(i__3,i__4);
+ slarnv_(&c__2, &iseed[1], &lenj, &ab[*kd + 2 - lenj + j *
+ ab_dim1]);
+ i__3 = lenj - 1;
+ sscal_(&i__3, &tscal, &ab[*kd + 2 - lenj + j * ab_dim1], &
+ c__1);
+ ab[*kd + 1 + j * ab_dim1] = r_sign(&c_b47, &ab[*kd + 1 + j *
+ ab_dim1]);
+/* L140: */
+ }
+ ab[*kd + 1 + *n * ab_dim1] = smlnum * ab[*kd + 1 + *n * ab_dim1];
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n - j + 1, i__4 = *kd + 1;
+ lenj = min(i__3,i__4);
+ slarnv_(&c__2, &iseed[1], &lenj, &ab[j * ab_dim1 + 1]);
+ if (lenj > 1) {
+ i__3 = lenj - 1;
+ sscal_(&i__3, &tscal, &ab[j * ab_dim1 + 2], &c__1);
+ }
+ ab[j * ab_dim1 + 1] = r_sign(&c_b47, &ab[j * ab_dim1 + 1]);
+/* L150: */
+ }
+ ab[ab_dim1 + 1] = smlnum * ab[ab_dim1 + 1];
+ }
+
+ } else if (*imat == 12) {
+
+/* Type 12: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 12, the offdiagonal elements are O(1) (CNORM(j) > 1). */
+
+ slarnv_(&c__2, &iseed[1], n, &b[1]);
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j, i__4 = *kd + 1;
+ lenj = min(i__3,i__4);
+ slarnv_(&c__2, &iseed[1], &lenj, &ab[*kd + 2 - lenj + j *
+ ab_dim1]);
+ ab[*kd + 1 + j * ab_dim1] = r_sign(&c_b47, &ab[*kd + 1 + j *
+ ab_dim1]);
+/* L160: */
+ }
+ ab[*kd + 1 + *n * ab_dim1] = smlnum * ab[*kd + 1 + *n * ab_dim1];
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n - j + 1, i__4 = *kd + 1;
+ lenj = min(i__3,i__4);
+ slarnv_(&c__2, &iseed[1], &lenj, &ab[j * ab_dim1 + 1]);
+ ab[j * ab_dim1 + 1] = r_sign(&c_b47, &ab[j * ab_dim1 + 1]);
+/* L170: */
+ }
+ ab[ab_dim1 + 1] = smlnum * ab[ab_dim1 + 1];
+ }
+
+ } else if (*imat == 13) {
+
+/* Type 13: T is diagonal with small numbers on the diagonal to */
+/* make the growth factor underflow, but a small right hand side */
+/* chosen so that the solution does not overflow. */
+
+ if (upper) {
+ jcount = 1;
+ for (j = *n; j >= 1; --j) {
+/* Computing MAX */
+ i__1 = 1, i__3 = *kd + 1 - (j - 1);
+ i__4 = *kd;
+ for (i__ = max(i__1,i__3); i__ <= i__4; ++i__) {
+ ab[i__ + j * ab_dim1] = 0.f;
+/* L180: */
+ }
+ if (jcount <= 2) {
+ ab[*kd + 1 + j * ab_dim1] = smlnum;
+ } else {
+ ab[*kd + 1 + j * ab_dim1] = 1.f;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+/* L190: */
+ }
+ } else {
+ jcount = 1;
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MIN */
+ i__3 = *n - j + 1, i__2 = *kd + 1;
+ i__1 = min(i__3,i__2);
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ ab[i__ + j * ab_dim1] = 0.f;
+/* L200: */
+ }
+ if (jcount <= 2) {
+ ab[j * ab_dim1 + 1] = smlnum;
+ } else {
+ ab[j * ab_dim1 + 1] = 1.f;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+/* L210: */
+ }
+ }
+
+/* Set the right hand side alternately zero and small. */
+
+ if (upper) {
+ b[1] = 0.f;
+ for (i__ = *n; i__ >= 2; i__ += -2) {
+ b[i__] = 0.f;
+ b[i__ - 1] = smlnum;
+/* L220: */
+ }
+ } else {
+ b[*n] = 0.f;
+ i__4 = *n - 1;
+ for (i__ = 1; i__ <= i__4; i__ += 2) {
+ b[i__] = 0.f;
+ b[i__ + 1] = smlnum;
+/* L230: */
+ }
+ }
+
+ } else if (*imat == 14) {
+
+/* Type 14: Make the diagonal elements small to cause gradual */
+/* overflow when dividing by T(j,j). To control the amount of */
+/* scaling needed, the matrix is bidiagonal. */
+
+ texp = 1.f / (real) (*kd + 1);
+ d__1 = (doublereal) smlnum;
+ d__2 = (doublereal) texp;
+ tscal = pow_dd(&d__1, &d__2);
+ slarnv_(&c__2, &iseed[1], n, &b[1]);
+ if (upper) {
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MAX */
+ i__1 = 1, i__3 = *kd + 2 - j;
+ i__2 = *kd;
+ for (i__ = max(i__1,i__3); i__ <= i__2; ++i__) {
+ ab[i__ + j * ab_dim1] = 0.f;
+/* L240: */
+ }
+ if (j > 1 && *kd > 0) {
+ ab[*kd + j * ab_dim1] = -1.f;
+ }
+ ab[*kd + 1 + j * ab_dim1] = tscal;
+/* L250: */
+ }
+ b[*n] = 1.f;
+ } else {
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MIN */
+ i__1 = *n - j + 1, i__3 = *kd + 1;
+ i__2 = min(i__1,i__3);
+ for (i__ = 3; i__ <= i__2; ++i__) {
+ ab[i__ + j * ab_dim1] = 0.f;
+/* L260: */
+ }
+ if (j < *n && *kd > 0) {
+ ab[j * ab_dim1 + 2] = -1.f;
+ }
+ ab[j * ab_dim1 + 1] = tscal;
+/* L270: */
+ }
+ b[1] = 1.f;
+ }
+
+ } else if (*imat == 15) {
+
+/* Type 15: One zero diagonal element. */
+
+ iy = *n / 2 + 1;
+ if (upper) {
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MIN */
+ i__2 = j, i__1 = *kd + 1;
+ lenj = min(i__2,i__1);
+ slarnv_(&c__2, &iseed[1], &lenj, &ab[*kd + 2 - lenj + j *
+ ab_dim1]);
+ if (j != iy) {
+ ab[*kd + 1 + j * ab_dim1] = r_sign(&c_b36, &ab[*kd + 1 +
+ j * ab_dim1]);
+ } else {
+ ab[*kd + 1 + j * ab_dim1] = 0.f;
+ }
+/* L280: */
+ }
+ } else {
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MIN */
+ i__2 = *n - j + 1, i__1 = *kd + 1;
+ lenj = min(i__2,i__1);
+ slarnv_(&c__2, &iseed[1], &lenj, &ab[j * ab_dim1 + 1]);
+ if (j != iy) {
+ ab[j * ab_dim1 + 1] = r_sign(&c_b36, &ab[j * ab_dim1 + 1])
+ ;
+ } else {
+ ab[j * ab_dim1 + 1] = 0.f;
+ }
+/* L290: */
+ }
+ }
+ slarnv_(&c__2, &iseed[1], n, &b[1]);
+ sscal_(n, &c_b36, &b[1], &c__1);
+
+ } else if (*imat == 16) {
+
+/* Type 16: Make the offdiagonal elements large to cause overflow */
+/* when adding a column of T. In the non-transposed case, the */
+/* matrix is constructed to cause overflow when adding a column in */
+/* every other step. */
+
+ tscal = unfl / ulp;
+ tscal = (1.f - ulp) / tscal;
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+ i__2 = *kd + 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ab[i__ + j * ab_dim1] = 0.f;
+/* L300: */
+ }
+/* L310: */
+ }
+ texp = 1.f;
+ if (*kd > 0) {
+ if (upper) {
+ i__4 = -(*kd);
+ for (j = *n; i__4 < 0 ? j >= 1 : j <= 1; j += i__4) {
+/* Computing MAX */
+ i__1 = 1, i__3 = j - *kd + 1;
+ i__2 = max(i__1,i__3);
+ for (i__ = j; i__ >= i__2; i__ += -2) {
+ ab[j - i__ + 1 + i__ * ab_dim1] = -tscal / (real) (*
+ kd + 2);
+ ab[*kd + 1 + i__ * ab_dim1] = 1.f;
+ b[i__] = texp * (1.f - ulp);
+/* Computing MAX */
+ i__1 = 1, i__3 = j - *kd + 1;
+ if (i__ > max(i__1,i__3)) {
+ ab[j - i__ + 2 + (i__ - 1) * ab_dim1] = -(tscal /
+ (real) (*kd + 2)) / (real) (*kd + 3);
+ ab[*kd + 1 + (i__ - 1) * ab_dim1] = 1.f;
+ b[i__ - 1] = texp * (real) ((*kd + 1) * (*kd + 1)
+ + *kd);
+ }
+ texp *= 2.f;
+/* L320: */
+ }
+/* Computing MAX */
+ i__2 = 1, i__1 = j - *kd + 1;
+ b[max(i__2,i__1)] = (real) (*kd + 2) / (real) (*kd + 3) *
+ tscal;
+/* L330: */
+ }
+ } else {
+ i__4 = *n;
+ i__2 = *kd;
+ for (j = 1; i__2 < 0 ? j >= i__4 : j <= i__4; j += i__2) {
+ texp = 1.f;
+/* Computing MIN */
+ i__1 = *kd + 1, i__3 = *n - j + 1;
+ lenj = min(i__1,i__3);
+/* Computing MIN */
+ i__3 = *n, i__5 = j + *kd - 1;
+ i__1 = min(i__3,i__5);
+ for (i__ = j; i__ <= i__1; i__ += 2) {
+ ab[lenj - (i__ - j) + j * ab_dim1] = -tscal / (real) (
+ *kd + 2);
+ ab[j * ab_dim1 + 1] = 1.f;
+ b[j] = texp * (1.f - ulp);
+/* Computing MIN */
+ i__3 = *n, i__5 = j + *kd - 1;
+ if (i__ < min(i__3,i__5)) {
+ ab[lenj - (i__ - j + 1) + (i__ + 1) * ab_dim1] =
+ -(tscal / (real) (*kd + 2)) / (real) (*kd
+ + 3);
+ ab[(i__ + 1) * ab_dim1 + 1] = 1.f;
+ b[i__ + 1] = texp * (real) ((*kd + 1) * (*kd + 1)
+ + *kd);
+ }
+ texp *= 2.f;
+/* L340: */
+ }
+/* Computing MIN */
+ i__1 = *n, i__3 = j + *kd - 1;
+ b[min(i__1,i__3)] = (real) (*kd + 2) / (real) (*kd + 3) *
+ tscal;
+/* L350: */
+ }
+ }
+ } else {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ ab[j * ab_dim1 + 1] = 1.f;
+ b[j] = (real) j;
+/* L360: */
+ }
+ }
+
+ } else if (*imat == 17) {
+
+/* Type 17: Generate a unit triangular matrix with elements */
+/* between -1 and 1, and make the right hand side large so that it */
+/* requires scaling. */
+
+ if (upper) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = j - 1;
+ lenj = min(i__4,*kd);
+ slarnv_(&c__2, &iseed[1], &lenj, &ab[*kd + 1 - lenj + j *
+ ab_dim1]);
+ ab[*kd + 1 + j * ab_dim1] = (real) j;
+/* L370: */
+ }
+ } else {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = *n - j;
+ lenj = min(i__4,*kd);
+ if (lenj > 0) {
+ slarnv_(&c__2, &iseed[1], &lenj, &ab[j * ab_dim1 + 2]);
+ }
+ ab[j * ab_dim1 + 1] = (real) j;
+/* L380: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ slarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = isamax_(n, &b[1], &c__1);
+ bnorm = (r__1 = b[iy], dabs(r__1));
+ bscal = bignum / dmax(1.f,bnorm);
+ sscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 18) {
+
+/* Type 18: Generate a triangular matrix with elements between */
+/* BIGNUM/KD and BIGNUM so that at least one of the column */
+/* norms will exceed BIGNUM. */
+
+/* Computing MAX */
+ r__1 = 1.f, r__2 = (real) (*kd);
+ tleft = bignum / dmax(r__1,r__2);
+ tscal = bignum * ((real) (*kd) / (real) (*kd + 1));
+ if (upper) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = j, i__1 = *kd + 1;
+ lenj = min(i__4,i__1);
+ slarnv_(&c__2, &iseed[1], &lenj, &ab[*kd + 2 - lenj + j *
+ ab_dim1]);
+ i__4 = *kd + 1;
+ for (i__ = *kd + 2 - lenj; i__ <= i__4; ++i__) {
+ ab[i__ + j * ab_dim1] = r_sign(&tleft, &ab[i__ + j *
+ ab_dim1]) + tscal * ab[i__ + j * ab_dim1];
+/* L390: */
+ }
+/* L400: */
+ }
+ } else {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = *n - j + 1, i__1 = *kd + 1;
+ lenj = min(i__4,i__1);
+ slarnv_(&c__2, &iseed[1], &lenj, &ab[j * ab_dim1 + 1]);
+ i__4 = lenj;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ ab[i__ + j * ab_dim1] = r_sign(&tleft, &ab[i__ + j *
+ ab_dim1]) + tscal * ab[i__ + j * ab_dim1];
+/* L410: */
+ }
+/* L420: */
+ }
+ }
+ slarnv_(&c__2, &iseed[1], n, &b[1]);
+ sscal_(n, &c_b36, &b[1], &c__1);
+ }
+
+/* Flip the matrix if the transpose will be used. */
+
+ if (! lsame_(trans, "N")) {
+ if (upper) {
+ i__2 = *n / 2;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = *n - (j << 1) + 1, i__1 = *kd + 1;
+ lenj = min(i__4,i__1);
+ i__4 = *ldab - 1;
+ sswap_(&lenj, &ab[*kd + 1 + j * ab_dim1], &i__4, &ab[*kd + 2
+ - lenj + (*n - j + 1) * ab_dim1], &c_n1);
+/* L430: */
+ }
+ } else {
+ i__2 = *n / 2;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = *n - (j << 1) + 1, i__1 = *kd + 1;
+ lenj = min(i__4,i__1);
+ i__4 = -(*ldab) + 1;
+ sswap_(&lenj, &ab[j * ab_dim1 + 1], &c__1, &ab[lenj + (*n - j
+ + 2 - lenj) * ab_dim1], &i__4);
+/* L440: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SLATTB */
+
+} /* slattb_ */
diff --git a/TESTING/LIN/slattp.c b/TESTING/LIN/slattp.c
new file mode 100644
index 0000000..1c16ed7
--- /dev/null
+++ b/TESTING/LIN/slattp.c
@@ -0,0 +1,943 @@
+/* slattp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static real c_b36 = 2.f;
+static real c_b48 = 1.f;
+
+/* Subroutine */ int slattp_(integer *imat, char *uplo, char *trans, char *
+ diag, integer *iseed, integer *n, real *a, real *b, real *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ real r__1, r__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double pow_dd(doublereal *, doublereal *), sqrt(doublereal), r_sign(real *
+ , real *);
+
+ /* Local variables */
+ real c__;
+ integer i__, j;
+ real s, t, x, y, z__;
+ integer jc;
+ real ra;
+ integer jj;
+ real rb;
+ integer jl, kl, jr, ku, iy, jx;
+ real ulp, sfac;
+ integer mode;
+ char path[3], dist[1];
+ real unfl, rexp;
+ char type__[1];
+ real texp;
+ extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
+ integer *, real *, real *);
+ real star1, plus1, plus2, bscal;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real tscal, anorm, bnorm, tleft, stemp;
+ logical upper;
+ extern /* Subroutine */ int srotg_(real *, real *, real *, real *),
+ slatb4_(char *, integer *, integer *, integer *, char *, integer *
+, integer *, real *, integer *, real *, char *), slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ char packit[1];
+ real bignum;
+ extern integer isamax_(integer *, real *, integer *);
+ extern doublereal slarnd_(integer *, integer *);
+ real cndnum;
+ integer jcnext, jcount;
+ extern /* Subroutine */ int slatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, real *, integer *, real *, integer *), slarnv_(integer *, integer *, integer *, real *);
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLATTP generates a triangular test matrix in packed storage. */
+/* IMAT and UPLO uniquely specify the properties of the test */
+/* matrix, which is returned in the array AP. */
+
+/* Arguments */
+/* ========= */
+
+/* IMAT (input) INTEGER */
+/* An integer key describing which matrix to generate for this */
+/* path. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A will be upper or lower */
+/* triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies whether the matrix or its transpose will be used. */
+/* = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose (= Transpose) */
+
+/* DIAG (output) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* The seed vector for the random number generator (used in */
+/* SLATMS). Modified on exit. */
+
+/* N (input) INTEGER */
+/* The order of the matrix to be generated. */
+
+/* A (output) REAL array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
+
+/* B (output) REAL array, dimension (N) */
+/* The right hand side vector, if IMAT > 10. */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --b;
+ --a;
+ --iseed;
+
+ /* Function Body */
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "TP", (ftnlen)2, (ftnlen)2);
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ smlnum = unfl;
+ bignum = (1.f - ulp) / smlnum;
+ slabad_(&smlnum, &bignum);
+ if (*imat >= 7 && *imat <= 10 || *imat == 18) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ *info = 0;
+
+/* Quick return if N.LE.0. */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Call SLATB4 to set parameters for SLATMS. */
+
+ upper = lsame_(uplo, "U");
+ if (upper) {
+ slatb4_(path, imat, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ *(unsigned char *)packit = 'C';
+ } else {
+ i__1 = -(*imat);
+ slatb4_(path, &i__1, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ *(unsigned char *)packit = 'R';
+ }
+
+/* IMAT <= 6: Non-unit triangular matrix */
+
+ if (*imat <= 6) {
+ slatms_(n, n, dist, &iseed[1], type__, &b[1], &mode, &cndnum, &anorm,
+ &kl, &ku, packit, &a[1], n, &work[1], info);
+
+/* IMAT > 6: Unit triangular matrix */
+/* The diagonal is deliberately set to something other than 1. */
+
+/* IMAT = 7: Matrix is the identity */
+
+ } else if (*imat == 7) {
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[jc + i__ - 1] = 0.f;
+/* L10: */
+ }
+ a[jc + j - 1] = (real) j;
+ jc += j;
+/* L20: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ a[jc] = (real) j;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[jc + i__ - j] = 0.f;
+/* L30: */
+ }
+ jc = jc + *n - j + 1;
+/* L40: */
+ }
+ }
+
+/* IMAT > 7: Non-trivial unit triangular matrix */
+
+/* Generate a unit triangular matrix T with condition CNDNUM by */
+/* forming a triangular matrix with known singular values and */
+/* filling in the zero entries with Givens rotations. */
+
+ } else if (*imat <= 10) {
+ if (upper) {
+ jc = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[jc + i__] = 0.f;
+/* L50: */
+ }
+ a[jc + j] = (real) j;
+ jc += j;
+/* L60: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ a[jc] = (real) j;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[jc + i__ - j] = 0.f;
+/* L70: */
+ }
+ jc = jc + *n - j + 1;
+/* L80: */
+ }
+ }
+
+/* Since the trace of a unit triangular matrix is 1, the product */
+/* of its singular values must be 1. Let s = sqrt(CNDNUM), */
+/* x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2. */
+/* The following triangular matrix has singular values s, 1, 1, */
+/* ..., 1, 1/s: */
+
+/* 1 y y y ... y y z */
+/* 1 0 0 ... 0 0 y */
+/* 1 0 ... 0 0 y */
+/* . ... . . . */
+/* . . . . */
+/* 1 0 y */
+/* 1 y */
+/* 1 */
+
+/* To fill in the zeros, we first multiply by a matrix with small */
+/* condition number of the form */
+
+/* 1 0 0 0 0 ... */
+/* 1 + * 0 0 ... */
+/* 1 + 0 0 0 */
+/* 1 + * 0 0 */
+/* 1 + 0 0 */
+/* ... */
+/* 1 + 0 */
+/* 1 0 */
+/* 1 */
+
+/* Each element marked with a '*' is formed by taking the product */
+/* of the adjacent elements marked with '+'. The '*'s can be */
+/* chosen freely, and the '+'s are chosen so that the inverse of */
+/* T will have elements of the same magnitude as T. If the *'s in */
+/* both T and inv(T) have small magnitude, T is well conditioned. */
+/* The two offdiagonals of T are stored in WORK. */
+
+/* The product of these two matrices has the form */
+
+/* 1 y y y y y . y y z */
+/* 1 + * 0 0 . 0 0 y */
+/* 1 + 0 0 . 0 0 y */
+/* 1 + * . . . . */
+/* 1 + . . . . */
+/* . . . . . */
+/* . . . . */
+/* 1 + y */
+/* 1 y */
+/* 1 */
+
+/* Now we multiply by Givens rotations, using the fact that */
+
+/* [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ] */
+/* [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ] */
+/* and */
+/* [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ] */
+/* [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ] */
+
+/* where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4). */
+
+ star1 = .25f;
+ sfac = .5f;
+ plus1 = sfac;
+ i__1 = *n;
+ for (j = 1; j <= i__1; j += 2) {
+ plus2 = star1 / plus1;
+ work[j] = plus1;
+ work[*n + j] = star1;
+ if (j + 1 <= *n) {
+ work[j + 1] = plus2;
+ work[*n + j + 1] = 0.f;
+ plus1 = star1 / plus2;
+ rexp = slarnd_(&c__2, &iseed[1]);
+ d__1 = (doublereal) sfac;
+ d__2 = (doublereal) rexp;
+ star1 *= pow_dd(&d__1, &d__2);
+ if (rexp < 0.f) {
+ d__1 = (doublereal) sfac;
+ d__2 = (doublereal) (1.f - rexp);
+ star1 = -pow_dd(&d__1, &d__2);
+ } else {
+ d__1 = (doublereal) sfac;
+ d__2 = (doublereal) (rexp + 1.f);
+ star1 = pow_dd(&d__1, &d__2);
+ }
+ }
+/* L90: */
+ }
+
+ x = sqrt(cndnum) - 1.f / sqrt(cndnum);
+ if (*n > 2) {
+ y = sqrt(2.f / (real) (*n - 2)) * x;
+ } else {
+ y = 0.f;
+ }
+ z__ = x * x;
+
+ if (upper) {
+
+/* Set the upper triangle of A with a unit triangular matrix */
+/* of known condition number. */
+
+ jc = 1;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ a[jc + 1] = y;
+ if (j > 2) {
+ a[jc + j - 1] = work[j - 2];
+ }
+ if (j > 3) {
+ a[jc + j - 2] = work[*n + j - 3];
+ }
+ jc += j;
+/* L100: */
+ }
+ jc -= *n;
+ a[jc + 1] = z__;
+ i__1 = *n - 1;
+ for (j = 2; j <= i__1; ++j) {
+ a[jc + j] = y;
+/* L110: */
+ }
+ } else {
+
+/* Set the lower triangle of A with a unit triangular matrix */
+/* of known condition number. */
+
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ a[i__] = y;
+/* L120: */
+ }
+ a[*n] = z__;
+ jc = *n + 1;
+ i__1 = *n - 1;
+ for (j = 2; j <= i__1; ++j) {
+ a[jc + 1] = work[j - 1];
+ if (j < *n - 1) {
+ a[jc + 2] = work[*n + j - 1];
+ }
+ a[jc + *n - j] = y;
+ jc = jc + *n - j + 1;
+/* L130: */
+ }
+ }
+
+/* Fill in the zeros using Givens rotations */
+
+ if (upper) {
+ jc = 1;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ jcnext = jc + j;
+ ra = a[jcnext + j - 1];
+ rb = 2.f;
+ srotg_(&ra, &rb, &c__, &s);
+
+/* Multiply by [ c s; -s c] on the left. */
+
+ if (*n > j + 1) {
+ jx = jcnext + j;
+ i__2 = *n;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+ stemp = c__ * a[jx + j] + s * a[jx + j + 1];
+ a[jx + j + 1] = -s * a[jx + j] + c__ * a[jx + j + 1];
+ a[jx + j] = stemp;
+ jx += i__;
+/* L140: */
+ }
+ }
+
+/* Multiply by [-c -s; s -c] on the right. */
+
+ if (j > 1) {
+ i__2 = j - 1;
+ r__1 = -c__;
+ r__2 = -s;
+ srot_(&i__2, &a[jcnext], &c__1, &a[jc], &c__1, &r__1, &
+ r__2);
+ }
+
+/* Negate A(J,J+1). */
+
+ a[jcnext + j - 1] = -a[jcnext + j - 1];
+ jc = jcnext;
+/* L150: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ jcnext = jc + *n - j + 1;
+ ra = a[jc + 1];
+ rb = 2.f;
+ srotg_(&ra, &rb, &c__, &s);
+
+/* Multiply by [ c -s; s c] on the right. */
+
+ if (*n > j + 1) {
+ i__2 = *n - j - 1;
+ r__1 = -s;
+ srot_(&i__2, &a[jcnext + 1], &c__1, &a[jc + 2], &c__1, &
+ c__, &r__1);
+ }
+
+/* Multiply by [-c s; -s -c] on the left. */
+
+ if (j > 1) {
+ jx = 1;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ stemp = -c__ * a[jx + j - i__] + s * a[jx + j - i__ +
+ 1];
+ a[jx + j - i__ + 1] = -s * a[jx + j - i__] - c__ * a[
+ jx + j - i__ + 1];
+ a[jx + j - i__] = stemp;
+ jx = jx + *n - i__ + 1;
+/* L160: */
+ }
+ }
+
+/* Negate A(J+1,J). */
+
+ a[jc + 1] = -a[jc + 1];
+ jc = jcnext;
+/* L170: */
+ }
+ }
+
+/* IMAT > 10: Pathological test cases. These triangular matrices */
+/* are badly scaled or badly conditioned, so when used in solving a */
+/* triangular system they may cause overflow in the solution vector. */
+
+ } else if (*imat == 11) {
+
+/* Type 11: Generate a triangular matrix with elements between */
+/* -1 and 1. Give the diagonal norm 2 to make it well-conditioned. */
+/* Make the right hand side large so that it requires scaling. */
+
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ slarnv_(&c__2, &iseed[1], &j, &a[jc]);
+ a[jc + j - 1] = r_sign(&c_b36, &a[jc + j - 1]);
+ jc += j;
+/* L180: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ slarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
+ a[jc] = r_sign(&c_b36, &a[jc]);
+ jc = jc + *n - j + 1;
+/* L190: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ slarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = isamax_(n, &b[1], &c__1);
+ bnorm = (r__1 = b[iy], dabs(r__1));
+ bscal = bignum / dmax(1.f,bnorm);
+ sscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 12) {
+
+/* Type 12: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 12, the offdiagonal elements are small (CNORM(j) < 1). */
+
+ slarnv_(&c__2, &iseed[1], n, &b[1]);
+/* Computing MAX */
+ r__1 = 1.f, r__2 = (real) (*n - 1);
+ tscal = 1.f / dmax(r__1,r__2);
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ slarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
+ i__2 = j - 1;
+ sscal_(&i__2, &tscal, &a[jc], &c__1);
+ r__1 = slarnd_(&c__2, &iseed[1]);
+ a[jc + j - 1] = r_sign(&c_b48, &r__1);
+ jc += j;
+/* L200: */
+ }
+ a[*n * (*n + 1) / 2] = smlnum;
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ slarnv_(&c__2, &iseed[1], &i__2, &a[jc + 1]);
+ i__2 = *n - j;
+ sscal_(&i__2, &tscal, &a[jc + 1], &c__1);
+ r__1 = slarnd_(&c__2, &iseed[1]);
+ a[jc] = r_sign(&c_b48, &r__1);
+ jc = jc + *n - j + 1;
+/* L210: */
+ }
+ a[1] = smlnum;
+ }
+
+ } else if (*imat == 13) {
+
+/* Type 13: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1). */
+
+ slarnv_(&c__2, &iseed[1], n, &b[1]);
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ slarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
+ r__1 = slarnd_(&c__2, &iseed[1]);
+ a[jc + j - 1] = r_sign(&c_b48, &r__1);
+ jc += j;
+/* L220: */
+ }
+ a[*n * (*n + 1) / 2] = smlnum;
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ slarnv_(&c__2, &iseed[1], &i__2, &a[jc + 1]);
+ r__1 = slarnd_(&c__2, &iseed[1]);
+ a[jc] = r_sign(&c_b48, &r__1);
+ jc = jc + *n - j + 1;
+/* L230: */
+ }
+ a[1] = smlnum;
+ }
+
+ } else if (*imat == 14) {
+
+/* Type 14: T is diagonal with small numbers on the diagonal to */
+/* make the growth factor underflow, but a small right hand side */
+/* chosen so that the solution does not overflow. */
+
+ if (upper) {
+ jcount = 1;
+ jc = (*n - 1) * *n / 2 + 1;
+ for (j = *n; j >= 1; --j) {
+ i__1 = j - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ a[jc + i__ - 1] = 0.f;
+/* L240: */
+ }
+ if (jcount <= 2) {
+ a[jc + j - 1] = smlnum;
+ } else {
+ a[jc + j - 1] = 1.f;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+ jc = jc - j + 1;
+/* L250: */
+ }
+ } else {
+ jcount = 1;
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[jc + i__ - j] = 0.f;
+/* L260: */
+ }
+ if (jcount <= 2) {
+ a[jc] = smlnum;
+ } else {
+ a[jc] = 1.f;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+ jc = jc + *n - j + 1;
+/* L270: */
+ }
+ }
+
+/* Set the right hand side alternately zero and small. */
+
+ if (upper) {
+ b[1] = 0.f;
+ for (i__ = *n; i__ >= 2; i__ += -2) {
+ b[i__] = 0.f;
+ b[i__ - 1] = smlnum;
+/* L280: */
+ }
+ } else {
+ b[*n] = 0.f;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; i__ += 2) {
+ b[i__] = 0.f;
+ b[i__ + 1] = smlnum;
+/* L290: */
+ }
+ }
+
+ } else if (*imat == 15) {
+
+/* Type 15: Make the diagonal elements small to cause gradual */
+/* overflow when dividing by T(j,j). To control the amount of */
+/* scaling needed, the matrix is bidiagonal. */
+
+/* Computing MAX */
+ r__1 = 1.f, r__2 = (real) (*n - 1);
+ texp = 1.f / dmax(r__1,r__2);
+ d__1 = (doublereal) smlnum;
+ d__2 = (doublereal) texp;
+ tscal = pow_dd(&d__1, &d__2);
+ slarnv_(&c__2, &iseed[1], n, &b[1]);
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 2;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[jc + i__ - 1] = 0.f;
+/* L300: */
+ }
+ if (j > 1) {
+ a[jc + j - 2] = -1.f;
+ }
+ a[jc + j - 1] = tscal;
+ jc += j;
+/* L310: */
+ }
+ b[*n] = 1.f;
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+ a[jc + i__ - j] = 0.f;
+/* L320: */
+ }
+ if (j < *n) {
+ a[jc + 1] = -1.f;
+ }
+ a[jc] = tscal;
+ jc = jc + *n - j + 1;
+/* L330: */
+ }
+ b[1] = 1.f;
+ }
+
+ } else if (*imat == 16) {
+
+/* Type 16: One zero diagonal element. */
+
+ iy = *n / 2 + 1;
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ slarnv_(&c__2, &iseed[1], &j, &a[jc]);
+ if (j != iy) {
+ a[jc + j - 1] = r_sign(&c_b36, &a[jc + j - 1]);
+ } else {
+ a[jc + j - 1] = 0.f;
+ }
+ jc += j;
+/* L340: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ slarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
+ if (j != iy) {
+ a[jc] = r_sign(&c_b36, &a[jc]);
+ } else {
+ a[jc] = 0.f;
+ }
+ jc = jc + *n - j + 1;
+/* L350: */
+ }
+ }
+ slarnv_(&c__2, &iseed[1], n, &b[1]);
+ sscal_(n, &c_b36, &b[1], &c__1);
+
+ } else if (*imat == 17) {
+
+/* Type 17: Make the offdiagonal elements large to cause overflow */
+/* when adding a column of T. In the non-transposed case, the */
+/* matrix is constructed to cause overflow when adding a column in */
+/* every other step. */
+
+ tscal = unfl / ulp;
+ tscal = (1.f - ulp) / tscal;
+ i__1 = *n * (*n + 1) / 2;
+ for (j = 1; j <= i__1; ++j) {
+ a[j] = 0.f;
+/* L360: */
+ }
+ texp = 1.f;
+ if (upper) {
+ jc = (*n - 1) * *n / 2 + 1;
+ for (j = *n; j >= 2; j += -2) {
+ a[jc] = -tscal / (real) (*n + 1);
+ a[jc + j - 1] = 1.f;
+ b[j] = texp * (1.f - ulp);
+ jc = jc - j + 1;
+ a[jc] = -(tscal / (real) (*n + 1)) / (real) (*n + 2);
+ a[jc + j - 2] = 1.f;
+ b[j - 1] = texp * (real) (*n * *n + *n - 1);
+ texp *= 2.f;
+ jc = jc - j + 2;
+/* L370: */
+ }
+ b[1] = (real) (*n + 1) / (real) (*n + 2) * tscal;
+ } else {
+ jc = 1;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; j += 2) {
+ a[jc + *n - j] = -tscal / (real) (*n + 1);
+ a[jc] = 1.f;
+ b[j] = texp * (1.f - ulp);
+ jc = jc + *n - j + 1;
+ a[jc + *n - j - 1] = -(tscal / (real) (*n + 1)) / (real) (*n
+ + 2);
+ a[jc] = 1.f;
+ b[j + 1] = texp * (real) (*n * *n + *n - 1);
+ texp *= 2.f;
+ jc = jc + *n - j;
+/* L380: */
+ }
+ b[*n] = (real) (*n + 1) / (real) (*n + 2) * tscal;
+ }
+
+ } else if (*imat == 18) {
+
+/* Type 18: Generate a unit triangular matrix with elements */
+/* between -1 and 1, and make the right hand side large so that it */
+/* requires scaling. */
+
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ slarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
+ a[jc + j - 1] = 0.f;
+ jc += j;
+/* L390: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (j < *n) {
+ i__2 = *n - j;
+ slarnv_(&c__2, &iseed[1], &i__2, &a[jc + 1]);
+ }
+ a[jc] = 0.f;
+ jc = jc + *n - j + 1;
+/* L400: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ slarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = isamax_(n, &b[1], &c__1);
+ bnorm = (r__1 = b[iy], dabs(r__1));
+ bscal = bignum / dmax(1.f,bnorm);
+ sscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 19) {
+
+/* Type 19: Generate a triangular matrix with elements between */
+/* BIGNUM/(n-1) and BIGNUM so that at least one of the column */
+/* norms will exceed BIGNUM. */
+
+/* Computing MAX */
+ r__1 = 1.f, r__2 = (real) (*n - 1);
+ tleft = bignum / dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = 1.f, r__2 = (real) (*n);
+ tscal = bignum * ((real) (*n - 1) / dmax(r__1,r__2));
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ slarnv_(&c__2, &iseed[1], &j, &a[jc]);
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[jc + i__ - 1] = r_sign(&tleft, &a[jc + i__ - 1]) +
+ tscal * a[jc + i__ - 1];
+/* L410: */
+ }
+ jc += j;
+/* L420: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ slarnv_(&c__2, &iseed[1], &i__2, &a[jc]);
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ a[jc + i__ - j] = r_sign(&tleft, &a[jc + i__ - j]) +
+ tscal * a[jc + i__ - j];
+/* L430: */
+ }
+ jc = jc + *n - j + 1;
+/* L440: */
+ }
+ }
+ slarnv_(&c__2, &iseed[1], n, &b[1]);
+ sscal_(n, &c_b36, &b[1], &c__1);
+ }
+
+/* Flip the matrix across its counter-diagonal if the transpose will */
+/* be used. */
+
+ if (! lsame_(trans, "N")) {
+ if (upper) {
+ jj = 1;
+ jr = *n * (*n + 1) / 2;
+ i__1 = *n / 2;
+ for (j = 1; j <= i__1; ++j) {
+ jl = jj;
+ i__2 = *n - j;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ t = a[jr - i__ + j];
+ a[jr - i__ + j] = a[jl];
+ a[jl] = t;
+ jl += i__;
+/* L450: */
+ }
+ jj = jj + j + 1;
+ jr -= *n - j + 1;
+/* L460: */
+ }
+ } else {
+ jl = 1;
+ jj = *n * (*n + 1) / 2;
+ i__1 = *n / 2;
+ for (j = 1; j <= i__1; ++j) {
+ jr = jj;
+ i__2 = *n - j;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ t = a[jl + i__ - j];
+ a[jl + i__ - j] = a[jr];
+ a[jr] = t;
+ jr -= i__;
+/* L470: */
+ }
+ jl = jl + *n - j + 1;
+ jj = jj - j - 1;
+/* L480: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SLATTP */
+
+} /* slattp_ */
diff --git a/TESTING/LIN/slattr.c b/TESTING/LIN/slattr.c
new file mode 100644
index 0000000..c879c5e
--- /dev/null
+++ b/TESTING/LIN/slattr.c
@@ -0,0 +1,855 @@
+/* slattr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static real c_b35 = 2.f;
+static real c_b46 = 1.f;
+static integer c_n1 = -1;
+
+/* Subroutine */ int slattr_(integer *imat, char *uplo, char *trans, char *
+ diag, integer *iseed, integer *n, real *a, integer *lda, real *b,
+ real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1, r__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double pow_dd(doublereal *, doublereal *), sqrt(doublereal), r_sign(real *
+ , real *);
+
+ /* Local variables */
+ real c__;
+ integer i__, j;
+ real s, x, y, z__, ra, rb;
+ integer kl, ku, iy;
+ real ulp, sfac;
+ integer mode;
+ char path[3], dist[1];
+ real unfl, rexp;
+ char type__[1];
+ real texp;
+ extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
+ integer *, real *, real *);
+ real star1, plus1, plus2, bscal;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real tscal, anorm, bnorm, tleft;
+ logical upper;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), srotg_(real *, real *, real *, real *), sswap_(
+ integer *, real *, integer *, real *, integer *), slatb4_(char *,
+ integer *, integer *, integer *, char *, integer *, integer *,
+ real *, integer *, real *, char *),
+ slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ real bignum;
+ extern integer isamax_(integer *, real *, integer *);
+ extern doublereal slarnd_(integer *, integer *);
+ real cndnum;
+ integer jcount;
+ extern /* Subroutine */ int slatms_(integer *, integer *, char *, integer
+ *, char *, real *, integer *, real *, real *, integer *, integer *
+, char *, real *, integer *, real *, integer *), slarnv_(integer *, integer *, integer *, real *);
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLATTR generates a triangular test matrix. */
+/* IMAT and UPLO uniquely specify the properties of the test */
+/* matrix, which is returned in the array A. */
+
+/* Arguments */
+/* ========= */
+
+/* IMAT (input) INTEGER */
+/* An integer key describing which matrix to generate for this */
+/* path. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A will be upper or lower */
+/* triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies whether the matrix or its transpose will be used. */
+/* = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose (= Transpose) */
+
+/* DIAG (output) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* The seed vector for the random number generator (used in */
+/* SLATMS). Modified on exit. */
+
+/* N (input) INTEGER */
+/* The order of the matrix to be generated. */
+
+/* A (output) REAL array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* set so that A(k,k) = k for 1 <= k <= n. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (output) REAL array, dimension (N) */
+/* The right hand side vector, if IMAT > 10. */
+
+/* WORK (workspace) REAL array, dimension (3*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --b;
+ --work;
+
+ /* Function Body */
+ s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
+ s_copy(path + 1, "TR", (ftnlen)2, (ftnlen)2);
+ unfl = slamch_("Safe minimum");
+ ulp = slamch_("Epsilon") * slamch_("Base");
+ smlnum = unfl;
+ bignum = (1.f - ulp) / smlnum;
+ slabad_(&smlnum, &bignum);
+ if (*imat >= 7 && *imat <= 10 || *imat == 18) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ *info = 0;
+
+/* Quick return if N.LE.0. */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Call SLATB4 to set parameters for SLATMS. */
+
+ upper = lsame_(uplo, "U");
+ if (upper) {
+ slatb4_(path, imat, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ } else {
+ i__1 = -(*imat);
+ slatb4_(path, &i__1, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ }
+
+/* IMAT <= 6: Non-unit triangular matrix */
+
+ if (*imat <= 6) {
+ slatms_(n, n, dist, &iseed[1], type__, &b[1], &mode, &cndnum, &anorm,
+ &kl, &ku, "No packing", &a[a_offset], lda, &work[1], info);
+
+/* IMAT > 6: Unit triangular matrix */
+/* The diagonal is deliberately set to something other than 1. */
+
+/* IMAT = 7: Matrix is the identity */
+
+ } else if (*imat == 7) {
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L10: */
+ }
+ a[j + j * a_dim1] = (real) j;
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ a[j + j * a_dim1] = (real) j;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+/* IMAT > 7: Non-trivial unit triangular matrix */
+
+/* Generate a unit triangular matrix T with condition CNDNUM by */
+/* forming a triangular matrix with known singular values and */
+/* filling in the zero entries with Givens rotations. */
+
+ } else if (*imat <= 10) {
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L50: */
+ }
+ a[j + j * a_dim1] = (real) j;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ a[j + j * a_dim1] = (real) j;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+
+/* Since the trace of a unit triangular matrix is 1, the product */
+/* of its singular values must be 1. Let s = sqrt(CNDNUM), */
+/* x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2. */
+/* The following triangular matrix has singular values s, 1, 1, */
+/* ..., 1, 1/s: */
+
+/* 1 y y y ... y y z */
+/* 1 0 0 ... 0 0 y */
+/* 1 0 ... 0 0 y */
+/* . ... . . . */
+/* . . . . */
+/* 1 0 y */
+/* 1 y */
+/* 1 */
+
+/* To fill in the zeros, we first multiply by a matrix with small */
+/* condition number of the form */
+
+/* 1 0 0 0 0 ... */
+/* 1 + * 0 0 ... */
+/* 1 + 0 0 0 */
+/* 1 + * 0 0 */
+/* 1 + 0 0 */
+/* ... */
+/* 1 + 0 */
+/* 1 0 */
+/* 1 */
+
+/* Each element marked with a '*' is formed by taking the product */
+/* of the adjacent elements marked with '+'. The '*'s can be */
+/* chosen freely, and the '+'s are chosen so that the inverse of */
+/* T will have elements of the same magnitude as T. If the *'s in */
+/* both T and inv(T) have small magnitude, T is well conditioned. */
+/* The two offdiagonals of T are stored in WORK. */
+
+/* The product of these two matrices has the form */
+
+/* 1 y y y y y . y y z */
+/* 1 + * 0 0 . 0 0 y */
+/* 1 + 0 0 . 0 0 y */
+/* 1 + * . . . . */
+/* 1 + . . . . */
+/* . . . . . */
+/* . . . . */
+/* 1 + y */
+/* 1 y */
+/* 1 */
+
+/* Now we multiply by Givens rotations, using the fact that */
+
+/* [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ] */
+/* [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ] */
+/* and */
+/* [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ] */
+/* [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ] */
+
+/* where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4). */
+
+ star1 = .25f;
+ sfac = .5f;
+ plus1 = sfac;
+ i__1 = *n;
+ for (j = 1; j <= i__1; j += 2) {
+ plus2 = star1 / plus1;
+ work[j] = plus1;
+ work[*n + j] = star1;
+ if (j + 1 <= *n) {
+ work[j + 1] = plus2;
+ work[*n + j + 1] = 0.f;
+ plus1 = star1 / plus2;
+ rexp = slarnd_(&c__2, &iseed[1]);
+ d__1 = (doublereal) sfac;
+ d__2 = (doublereal) rexp;
+ star1 *= pow_dd(&d__1, &d__2);
+ if (rexp < 0.f) {
+ d__1 = (doublereal) sfac;
+ d__2 = (doublereal) (1.f - rexp);
+ star1 = -pow_dd(&d__1, &d__2);
+ } else {
+ d__1 = (doublereal) sfac;
+ d__2 = (doublereal) (rexp + 1.f);
+ star1 = pow_dd(&d__1, &d__2);
+ }
+ }
+/* L90: */
+ }
+
+ x = sqrt(cndnum) - 1 / sqrt(cndnum);
+ if (*n > 2) {
+ y = sqrt(2.f / (*n - 2)) * x;
+ } else {
+ y = 0.f;
+ }
+ z__ = x * x;
+
+ if (upper) {
+ if (*n > 3) {
+ i__1 = *n - 3;
+ i__2 = *lda + 1;
+ scopy_(&i__1, &work[1], &c__1, &a[a_dim1 * 3 + 2], &i__2);
+ if (*n > 4) {
+ i__1 = *n - 4;
+ i__2 = *lda + 1;
+ scopy_(&i__1, &work[*n + 1], &c__1, &a[(a_dim1 << 2) + 2],
+ &i__2);
+ }
+ }
+ i__1 = *n - 1;
+ for (j = 2; j <= i__1; ++j) {
+ a[j * a_dim1 + 1] = y;
+ a[j + *n * a_dim1] = y;
+/* L100: */
+ }
+ a[*n * a_dim1 + 1] = z__;
+ } else {
+ if (*n > 3) {
+ i__1 = *n - 3;
+ i__2 = *lda + 1;
+ scopy_(&i__1, &work[1], &c__1, &a[(a_dim1 << 1) + 3], &i__2);
+ if (*n > 4) {
+ i__1 = *n - 4;
+ i__2 = *lda + 1;
+ scopy_(&i__1, &work[*n + 1], &c__1, &a[(a_dim1 << 1) + 4],
+ &i__2);
+ }
+ }
+ i__1 = *n - 1;
+ for (j = 2; j <= i__1; ++j) {
+ a[j + a_dim1] = y;
+ a[*n + j * a_dim1] = y;
+/* L110: */
+ }
+ a[*n + a_dim1] = z__;
+ }
+
+/* Fill in the zeros using Givens rotations. */
+
+ if (upper) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ ra = a[j + (j + 1) * a_dim1];
+ rb = 2.f;
+ srotg_(&ra, &rb, &c__, &s);
+
+/* Multiply by [ c s; -s c] on the left. */
+
+ if (*n > j + 1) {
+ i__2 = *n - j - 1;
+ srot_(&i__2, &a[j + (j + 2) * a_dim1], lda, &a[j + 1 + (j
+ + 2) * a_dim1], lda, &c__, &s);
+ }
+
+/* Multiply by [-c -s; s -c] on the right. */
+
+ if (j > 1) {
+ i__2 = j - 1;
+ r__1 = -c__;
+ r__2 = -s;
+ srot_(&i__2, &a[(j + 1) * a_dim1 + 1], &c__1, &a[j *
+ a_dim1 + 1], &c__1, &r__1, &r__2);
+ }
+
+/* Negate A(J,J+1). */
+
+ a[j + (j + 1) * a_dim1] = -a[j + (j + 1) * a_dim1];
+/* L120: */
+ }
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ ra = a[j + 1 + j * a_dim1];
+ rb = 2.f;
+ srotg_(&ra, &rb, &c__, &s);
+
+/* Multiply by [ c -s; s c] on the right. */
+
+ if (*n > j + 1) {
+ i__2 = *n - j - 1;
+ r__1 = -s;
+ srot_(&i__2, &a[j + 2 + (j + 1) * a_dim1], &c__1, &a[j +
+ 2 + j * a_dim1], &c__1, &c__, &r__1);
+ }
+
+/* Multiply by [-c s; -s -c] on the left. */
+
+ if (j > 1) {
+ i__2 = j - 1;
+ r__1 = -c__;
+ srot_(&i__2, &a[j + a_dim1], lda, &a[j + 1 + a_dim1], lda,
+ &r__1, &s);
+ }
+
+/* Negate A(J+1,J). */
+
+ a[j + 1 + j * a_dim1] = -a[j + 1 + j * a_dim1];
+/* L130: */
+ }
+ }
+
+/* IMAT > 10: Pathological test cases. These triangular matrices */
+/* are badly scaled or badly conditioned, so when used in solving a */
+/* triangular system they may cause overflow in the solution vector. */
+
+ } else if (*imat == 11) {
+
+/* Type 11: Generate a triangular matrix with elements between */
+/* -1 and 1. Give the diagonal norm 2 to make it well-conditioned. */
+/* Make the right hand side large so that it requires scaling. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ slarnv_(&c__2, &iseed[1], &j, &a[j * a_dim1 + 1]);
+ a[j + j * a_dim1] = r_sign(&c_b35, &a[j + j * a_dim1]);
+/* L140: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ slarnv_(&c__2, &iseed[1], &i__2, &a[j + j * a_dim1]);
+ a[j + j * a_dim1] = r_sign(&c_b35, &a[j + j * a_dim1]);
+/* L150: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ slarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = isamax_(n, &b[1], &c__1);
+ bnorm = (r__1 = b[iy], dabs(r__1));
+ bscal = bignum / dmax(1.f,bnorm);
+ sscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 12) {
+
+/* Type 12: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 12, the offdiagonal elements are small (CNORM(j) < 1). */
+
+ slarnv_(&c__2, &iseed[1], n, &b[1]);
+/* Computing MAX */
+ r__1 = 1.f, r__2 = (real) (*n - 1);
+ tscal = 1.f / dmax(r__1,r__2);
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ slarnv_(&c__2, &iseed[1], &j, &a[j * a_dim1 + 1]);
+ i__2 = j - 1;
+ sscal_(&i__2, &tscal, &a[j * a_dim1 + 1], &c__1);
+ a[j + j * a_dim1] = r_sign(&c_b46, &a[j + j * a_dim1]);
+/* L160: */
+ }
+ a[*n + *n * a_dim1] = smlnum * a[*n + *n * a_dim1];
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ slarnv_(&c__2, &iseed[1], &i__2, &a[j + j * a_dim1]);
+ if (*n > j) {
+ i__2 = *n - j;
+ sscal_(&i__2, &tscal, &a[j + 1 + j * a_dim1], &c__1);
+ }
+ a[j + j * a_dim1] = r_sign(&c_b46, &a[j + j * a_dim1]);
+/* L170: */
+ }
+ a[a_dim1 + 1] = smlnum * a[a_dim1 + 1];
+ }
+
+ } else if (*imat == 13) {
+
+/* Type 13: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1). */
+
+ slarnv_(&c__2, &iseed[1], n, &b[1]);
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ slarnv_(&c__2, &iseed[1], &j, &a[j * a_dim1 + 1]);
+ a[j + j * a_dim1] = r_sign(&c_b46, &a[j + j * a_dim1]);
+/* L180: */
+ }
+ a[*n + *n * a_dim1] = smlnum * a[*n + *n * a_dim1];
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ slarnv_(&c__2, &iseed[1], &i__2, &a[j + j * a_dim1]);
+ a[j + j * a_dim1] = r_sign(&c_b46, &a[j + j * a_dim1]);
+/* L190: */
+ }
+ a[a_dim1 + 1] = smlnum * a[a_dim1 + 1];
+ }
+
+ } else if (*imat == 14) {
+
+/* Type 14: T is diagonal with small numbers on the diagonal to */
+/* make the growth factor underflow, but a small right hand side */
+/* chosen so that the solution does not overflow. */
+
+ if (upper) {
+ jcount = 1;
+ for (j = *n; j >= 1; --j) {
+ i__1 = j - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L200: */
+ }
+ if (jcount <= 2) {
+ a[j + j * a_dim1] = smlnum;
+ } else {
+ a[j + j * a_dim1] = 1.f;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+/* L210: */
+ }
+ } else {
+ jcount = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L220: */
+ }
+ if (jcount <= 2) {
+ a[j + j * a_dim1] = smlnum;
+ } else {
+ a[j + j * a_dim1] = 1.f;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+/* L230: */
+ }
+ }
+
+/* Set the right hand side alternately zero and small. */
+
+ if (upper) {
+ b[1] = 0.f;
+ for (i__ = *n; i__ >= 2; i__ += -2) {
+ b[i__] = 0.f;
+ b[i__ - 1] = smlnum;
+/* L240: */
+ }
+ } else {
+ b[*n] = 0.f;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; i__ += 2) {
+ b[i__] = 0.f;
+ b[i__ + 1] = smlnum;
+/* L250: */
+ }
+ }
+
+ } else if (*imat == 15) {
+
+/* Type 15: Make the diagonal elements small to cause gradual */
+/* overflow when dividing by T(j,j). To control the amount of */
+/* scaling needed, the matrix is bidiagonal. */
+
+/* Computing MAX */
+ r__1 = 1.f, r__2 = (real) (*n - 1);
+ texp = 1.f / dmax(r__1,r__2);
+ d__1 = (doublereal) smlnum;
+ d__2 = (doublereal) texp;
+ tscal = pow_dd(&d__1, &d__2);
+ slarnv_(&c__2, &iseed[1], n, &b[1]);
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 2;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L260: */
+ }
+ if (j > 1) {
+ a[j - 1 + j * a_dim1] = -1.f;
+ }
+ a[j + j * a_dim1] = tscal;
+/* L270: */
+ }
+ b[*n] = 1.f;
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L280: */
+ }
+ if (j < *n) {
+ a[j + 1 + j * a_dim1] = -1.f;
+ }
+ a[j + j * a_dim1] = tscal;
+/* L290: */
+ }
+ b[1] = 1.f;
+ }
+
+ } else if (*imat == 16) {
+
+/* Type 16: One zero diagonal element. */
+
+ iy = *n / 2 + 1;
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ slarnv_(&c__2, &iseed[1], &j, &a[j * a_dim1 + 1]);
+ if (j != iy) {
+ a[j + j * a_dim1] = r_sign(&c_b35, &a[j + j * a_dim1]);
+ } else {
+ a[j + j * a_dim1] = 0.f;
+ }
+/* L300: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ slarnv_(&c__2, &iseed[1], &i__2, &a[j + j * a_dim1]);
+ if (j != iy) {
+ a[j + j * a_dim1] = r_sign(&c_b35, &a[j + j * a_dim1]);
+ } else {
+ a[j + j * a_dim1] = 0.f;
+ }
+/* L310: */
+ }
+ }
+ slarnv_(&c__2, &iseed[1], n, &b[1]);
+ sscal_(n, &c_b35, &b[1], &c__1);
+
+ } else if (*imat == 17) {
+
+/* Type 17: Make the offdiagonal elements large to cause overflow */
+/* when adding a column of T. In the non-transposed case, the */
+/* matrix is constructed to cause overflow when adding a column in */
+/* every other step. */
+
+ tscal = unfl / ulp;
+ tscal = (1.f - ulp) / tscal;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L320: */
+ }
+/* L330: */
+ }
+ texp = 1.f;
+ if (upper) {
+ for (j = *n; j >= 2; j += -2) {
+ a[j * a_dim1 + 1] = -tscal / (real) (*n + 1);
+ a[j + j * a_dim1] = 1.f;
+ b[j] = texp * (1.f - ulp);
+ a[(j - 1) * a_dim1 + 1] = -(tscal / (real) (*n + 1)) / (real)
+ (*n + 2);
+ a[j - 1 + (j - 1) * a_dim1] = 1.f;
+ b[j - 1] = texp * (real) (*n * *n + *n - 1);
+ texp *= 2.f;
+/* L340: */
+ }
+ b[1] = (real) (*n + 1) / (real) (*n + 2) * tscal;
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; j += 2) {
+ a[*n + j * a_dim1] = -tscal / (real) (*n + 1);
+ a[j + j * a_dim1] = 1.f;
+ b[j] = texp * (1.f - ulp);
+ a[*n + (j + 1) * a_dim1] = -(tscal / (real) (*n + 1)) / (real)
+ (*n + 2);
+ a[j + 1 + (j + 1) * a_dim1] = 1.f;
+ b[j + 1] = texp * (real) (*n * *n + *n - 1);
+ texp *= 2.f;
+/* L350: */
+ }
+ b[*n] = (real) (*n + 1) / (real) (*n + 2) * tscal;
+ }
+
+ } else if (*imat == 18) {
+
+/* Type 18: Generate a unit triangular matrix with elements */
+/* between -1 and 1, and make the right hand side large so that it */
+/* requires scaling. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ slarnv_(&c__2, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
+ a[j + j * a_dim1] = 0.f;
+/* L360: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (j < *n) {
+ i__2 = *n - j;
+ slarnv_(&c__2, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
+ }
+ a[j + j * a_dim1] = 0.f;
+/* L370: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ slarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = isamax_(n, &b[1], &c__1);
+ bnorm = (r__1 = b[iy], dabs(r__1));
+ bscal = bignum / dmax(1.f,bnorm);
+ sscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 19) {
+
+/* Type 19: Generate a triangular matrix with elements between */
+/* BIGNUM/(n-1) and BIGNUM so that at least one of the column */
+/* norms will exceed BIGNUM. */
+/* 1/3/91: SLATRS no longer can handle this case */
+
+/* Computing MAX */
+ r__1 = 1.f, r__2 = (real) (*n - 1);
+ tleft = bignum / dmax(r__1,r__2);
+/* Computing MAX */
+ r__1 = 1.f, r__2 = (real) (*n);
+ tscal = bignum * ((real) (*n - 1) / dmax(r__1,r__2));
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ slarnv_(&c__2, &iseed[1], &j, &a[j * a_dim1 + 1]);
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = r_sign(&tleft, &a[i__ + j * a_dim1])
+ + tscal * a[i__ + j * a_dim1];
+/* L380: */
+ }
+/* L390: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ slarnv_(&c__2, &iseed[1], &i__2, &a[j + j * a_dim1]);
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = r_sign(&tleft, &a[i__ + j * a_dim1])
+ + tscal * a[i__ + j * a_dim1];
+/* L400: */
+ }
+/* L410: */
+ }
+ }
+ slarnv_(&c__2, &iseed[1], n, &b[1]);
+ sscal_(n, &c_b35, &b[1], &c__1);
+ }
+
+/* Flip the matrix if the transpose will be used. */
+
+ if (! lsame_(trans, "N")) {
+ if (upper) {
+ i__1 = *n / 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - (j << 1) + 1;
+ sswap_(&i__2, &a[j + j * a_dim1], lda, &a[j + 1 + (*n - j + 1)
+ * a_dim1], &c_n1);
+/* L420: */
+ }
+ } else {
+ i__1 = *n / 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - (j << 1) + 1;
+ i__3 = -(*lda);
+ sswap_(&i__2, &a[j + j * a_dim1], &c__1, &a[*n - j + 1 + (j +
+ 1) * a_dim1], &i__3);
+/* L430: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SLATTR */
+
+} /* slattr_ */
diff --git a/TESTING/LIN/slavsp.c b/TESTING/LIN/slavsp.c
new file mode 100644
index 0000000..d407f34
--- /dev/null
+++ b/TESTING/LIN/slavsp.c
@@ -0,0 +1,558 @@
+/* slavsp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b15 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int slavsp_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, real *a, integer *ipiv, real *b, integer *ldb, integer
+ *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ integer j, k;
+ real t1, t2, d11, d12, d21, d22;
+ integer kc, kp;
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ sgemv_(char *, integer *, integer *, real *, real *, integer *,
+ real *, integer *, real *, real *, integer *), sswap_(
+ integer *, real *, integer *, real *, integer *), xerbla_(char *,
+ integer *);
+ integer kcnext;
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAVSP performs one of the matrix-vector operations */
+/* x := A*x or x := A'*x, */
+/* where x is an N element vector and A is one of the factors */
+/* from the block U*D*U' or L*D*L' factorization computed by SSPTRF. */
+
+/* If TRANS = 'N', multiplies by U or U * D (or L or L * D) */
+/* If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L' ) */
+/* If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L' ) */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the factor stored in A is upper or lower */
+/* triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation to be performed: */
+/* = 'N': x := A*x */
+/* = 'T': x := A'*x */
+/* = 'C': x := A'*x */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the diagonal blocks are unit */
+/* matrices. If the diagonal blocks are assumed to be unit, */
+/* then A = U or A = L, otherwise A = U*D or A = L*D. */
+/* = 'U': Diagonal blocks are assumed to be unit matrices. */
+/* = 'N': Diagonal blocks are assumed to be non-unit matrices. */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of vectors */
+/* x to be multiplied by A. NRHS >= 0. */
+
+/* A (input) REAL array, dimension (N*(N+1)/2) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L, stored as a packed triangular */
+/* matrix as computed by SSPTRF. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from SSPTRF. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, B contains NRHS vectors of length N. */
+/* On exit, B is overwritten with the product A * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --a;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLAVSP ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+/* ------------------------------------------ */
+
+/* Compute B := A * B (No transpose) */
+
+/* ------------------------------------------ */
+ if (lsame_(trans, "N")) {
+
+/* Compute B := U*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop forward applying the transformations. */
+
+ k = 1;
+ kc = 1;
+L10:
+ if (k > *n) {
+ goto L30;
+ }
+
+/* 1 x 1 pivot block */
+
+ if (ipiv[k] > 0) {
+
+/* Multiply by the diagonal element if forming U * D. */
+
+ if (nounit) {
+ sscal_(nrhs, &a[kc + k - 1], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformation. */
+
+ i__1 = k - 1;
+ sger_(&i__1, nrhs, &c_b15, &a[kc], &c__1, &b[k + b_dim1],
+ ldb, &b[b_dim1 + 1], ldb);
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ kc += k;
+ ++k;
+ } else {
+
+/* 2 x 2 pivot block */
+
+ kcnext = kc + k;
+
+/* Multiply by the diagonal block if forming U * D. */
+
+ if (nounit) {
+ d11 = a[kcnext - 1];
+ d22 = a[kcnext + k];
+ d12 = a[kcnext + k - 1];
+ d21 = d12;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ t1 = b[k + j * b_dim1];
+ t2 = b[k + 1 + j * b_dim1];
+ b[k + j * b_dim1] = d11 * t1 + d12 * t2;
+ b[k + 1 + j * b_dim1] = d21 * t1 + d22 * t2;
+/* L20: */
+ }
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformations. */
+
+ i__1 = k - 1;
+ sger_(&i__1, nrhs, &c_b15, &a[kc], &c__1, &b[k + b_dim1],
+ ldb, &b[b_dim1 + 1], ldb);
+ i__1 = k - 1;
+ sger_(&i__1, nrhs, &c_b15, &a[kcnext], &c__1, &b[k + 1 +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ kc = kcnext + k + 1;
+ k += 2;
+ }
+ goto L10;
+L30:
+
+/* Compute B := L*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . */
+
+ ;
+ } else {
+
+/* Loop backward applying the transformations to B. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L40:
+ if (k < 1) {
+ goto L60;
+ }
+ kc -= *n - k + 1;
+
+/* Test the pivot index. If greater than zero, a 1 x 1 */
+/* pivot was used, otherwise a 2 x 2 pivot was used. */
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 pivot block: */
+
+/* Multiply by the diagonal element if forming L * D. */
+
+ if (nounit) {
+ sscal_(nrhs, &a[kc], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+ kp = ipiv[k];
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ sger_(&i__1, nrhs, &c_b15, &a[kc + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ --k;
+
+ } else {
+
+/* 2 x 2 pivot block: */
+
+ kcnext = kc - (*n - k + 2);
+
+/* Multiply by the diagonal block if forming L * D. */
+
+ if (nounit) {
+ d11 = a[kcnext];
+ d22 = a[kc];
+ d21 = a[kcnext + 1];
+ d12 = d21;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ t1 = b[k - 1 + j * b_dim1];
+ t2 = b[k + j * b_dim1];
+ b[k - 1 + j * b_dim1] = d11 * t1 + d12 * t2;
+ b[k + j * b_dim1] = d21 * t1 + d22 * t2;
+/* L50: */
+ }
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ sger_(&i__1, nrhs, &c_b15, &a[kc + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+ i__1 = *n - k;
+ sger_(&i__1, nrhs, &c_b15, &a[kcnext + 2], &c__1, &b[k -
+ 1 + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ kc = kcnext;
+ k += -2;
+ }
+ goto L40;
+L60:
+ ;
+ }
+/* ---------------------------------------- */
+
+/* Compute B := A' * B (transpose) */
+
+/* ---------------------------------------- */
+ } else {
+
+/* Form B := U'*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+/* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop backward applying the transformations. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L70:
+ if (k < 1) {
+ goto L90;
+ }
+ kc -= k;
+
+/* 1 x 1 pivot block. */
+
+ if (ipiv[k] > 0) {
+ if (k > 1) {
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ i__1 = k - 1;
+ sgemv_("Transpose", &i__1, nrhs, &c_b15, &b[b_offset],
+ ldb, &a[kc], &c__1, &c_b15, &b[k + b_dim1], ldb);
+ }
+ if (nounit) {
+ sscal_(nrhs, &a[kc + k - 1], &b[k + b_dim1], ldb);
+ }
+ --k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ kcnext = kc - (k - 1);
+ if (k > 2) {
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k - 1) {
+ sswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformations */
+
+ i__1 = k - 2;
+ sgemv_("Transpose", &i__1, nrhs, &c_b15, &b[b_offset],
+ ldb, &a[kc], &c__1, &c_b15, &b[k + b_dim1], ldb);
+ i__1 = k - 2;
+ sgemv_("Transpose", &i__1, nrhs, &c_b15, &b[b_offset],
+ ldb, &a[kcnext], &c__1, &c_b15, &b[k - 1 + b_dim1]
+, ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ d11 = a[kc - 1];
+ d22 = a[kc + k - 1];
+ d12 = a[kc + k - 2];
+ d21 = d12;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ t1 = b[k - 1 + j * b_dim1];
+ t2 = b[k + j * b_dim1];
+ b[k - 1 + j * b_dim1] = d11 * t1 + d12 * t2;
+ b[k + j * b_dim1] = d21 * t1 + d22 * t2;
+/* L80: */
+ }
+ }
+ kc = kcnext;
+ k += -2;
+ }
+ goto L70;
+L90:
+
+/* Form B := L'*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) */
+/* and L' = inv(L(m))*P(m)* ... *inv(L(1))*P(1) */
+
+ ;
+ } else {
+
+/* Loop forward applying the L-transformations. */
+
+ k = 1;
+ kc = 1;
+L100:
+ if (k > *n) {
+ goto L120;
+ }
+
+/* 1 x 1 pivot block */
+
+ if (ipiv[k] > 0) {
+ if (k < *n) {
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ i__1 = *n - k;
+ sgemv_("Transpose", &i__1, nrhs, &c_b15, &b[k + 1 +
+ b_dim1], ldb, &a[kc + 1], &c__1, &c_b15, &b[k +
+ b_dim1], ldb);
+ }
+ if (nounit) {
+ sscal_(nrhs, &a[kc], &b[k + b_dim1], ldb);
+ }
+ kc = kc + *n - k + 1;
+ ++k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ kcnext = kc + *n - k + 1;
+ if (k < *n - 1) {
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k + 1) {
+ sswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ i__1 = *n - k - 1;
+ sgemv_("Transpose", &i__1, nrhs, &c_b15, &b[k + 2 +
+ b_dim1], ldb, &a[kcnext + 1], &c__1, &c_b15, &b[k
+ + 1 + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ sgemv_("Transpose", &i__1, nrhs, &c_b15, &b[k + 2 +
+ b_dim1], ldb, &a[kc + 2], &c__1, &c_b15, &b[k +
+ b_dim1], ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ d11 = a[kc];
+ d22 = a[kcnext];
+ d21 = a[kc + 1];
+ d12 = d21;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ t1 = b[k + j * b_dim1];
+ t2 = b[k + 1 + j * b_dim1];
+ b[k + j * b_dim1] = d11 * t1 + d12 * t2;
+ b[k + 1 + j * b_dim1] = d21 * t1 + d22 * t2;
+/* L110: */
+ }
+ }
+ kc = kcnext + (*n - k);
+ k += 2;
+ }
+ goto L100;
+L120:
+ ;
+ }
+
+ }
+ return 0;
+
+/* End of SLAVSP */
+
+} /* slavsp_ */
diff --git a/TESTING/LIN/slavsy.c b/TESTING/LIN/slavsy.c
new file mode 100644
index 0000000..b4bde82
--- /dev/null
+++ b/TESTING/LIN/slavsy.c
@@ -0,0 +1,548 @@
+/* slavsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b15 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int slavsy_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, real *a, integer *lda, integer *ipiv, real *b, integer
+ *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ integer j, k;
+ real t1, t2, d11, d12, d21, d22;
+ integer kp;
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ sgemv_(char *, integer *, integer *, real *, real *, integer *,
+ real *, integer *, real *, real *, integer *), sswap_(
+ integer *, real *, integer *, real *, integer *), xerbla_(char *,
+ integer *);
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAVSY performs one of the matrix-vector operations */
+/* x := A*x or x := A'*x, */
+/* where x is an N element vector and A is one of the factors */
+/* from the block U*D*U' or L*D*L' factorization computed by SSYTRF. */
+
+/* If TRANS = 'N', multiplies by U or U * D (or L or L * D) */
+/* If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L') */
+/* If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L') */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the factor stored in A is upper or lower */
+/* triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation to be performed: */
+/* = 'N': x := A*x */
+/* = 'T': x := A'*x */
+/* = 'C': x := A'*x */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the diagonal blocks are unit */
+/* matrices. If the diagonal blocks are assumed to be unit, */
+/* then A = U or A = L, otherwise A = U*D or A = L*D. */
+/* = 'U': Diagonal blocks are assumed to be unit matrices. */
+/* = 'N': Diagonal blocks are assumed to be non-unit matrices. */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of vectors */
+/* x to be multiplied by A. NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The block diagonal matrix D and the multipliers used to */
+/* obtain the factor U or L as computed by SSYTRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from SSYTRF. */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, B contains NRHS vectors of length N. */
+/* On exit, B is overwritten with the product A * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T") && ! lsame_(trans, "C")) {
+ *info = -2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLAVSY ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+/* ------------------------------------------ */
+
+/* Compute B := A * B (No transpose) */
+
+/* ------------------------------------------ */
+ if (lsame_(trans, "N")) {
+
+/* Compute B := U*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop forward applying the transformations. */
+
+ k = 1;
+L10:
+ if (k > *n) {
+ goto L30;
+ }
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 pivot block */
+
+/* Multiply by the diagonal element if forming U * D. */
+
+ if (nounit) {
+ sscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformation. */
+
+ i__1 = k - 1;
+ sger_(&i__1, nrhs, &c_b15, &a[k * a_dim1 + 1], &c__1, &b[
+ k + b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Interchange if P(K) .ne. I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ ++k;
+ } else {
+
+/* 2 x 2 pivot block */
+
+/* Multiply by the diagonal block if forming U * D. */
+
+ if (nounit) {
+ d11 = a[k + k * a_dim1];
+ d22 = a[k + 1 + (k + 1) * a_dim1];
+ d12 = a[k + (k + 1) * a_dim1];
+ d21 = d12;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ t1 = b[k + j * b_dim1];
+ t2 = b[k + 1 + j * b_dim1];
+ b[k + j * b_dim1] = d11 * t1 + d12 * t2;
+ b[k + 1 + j * b_dim1] = d21 * t1 + d22 * t2;
+/* L20: */
+ }
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformations. */
+
+ i__1 = k - 1;
+ sger_(&i__1, nrhs, &c_b15, &a[k * a_dim1 + 1], &c__1, &b[
+ k + b_dim1], ldb, &b[b_dim1 + 1], ldb);
+ i__1 = k - 1;
+ sger_(&i__1, nrhs, &c_b15, &a[(k + 1) * a_dim1 + 1], &
+ c__1, &b[k + 1 + b_dim1], ldb, &b[b_dim1 + 1],
+ ldb);
+
+/* Interchange if P(K) .ne. I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ k += 2;
+ }
+ goto L10;
+L30:
+
+/* Compute B := L*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . */
+
+ ;
+ } else {
+
+/* Loop backward applying the transformations to B. */
+
+ k = *n;
+L40:
+ if (k < 1) {
+ goto L60;
+ }
+
+/* Test the pivot index. If greater than zero, a 1 x 1 */
+/* pivot was used, otherwise a 2 x 2 pivot was used. */
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 pivot block: */
+
+/* Multiply by the diagonal element if forming L * D. */
+
+ if (nounit) {
+ sscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+ kp = ipiv[k];
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ sger_(&i__1, nrhs, &c_b15, &a[k + 1 + k * a_dim1], &c__1,
+ &b[k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ --k;
+
+ } else {
+
+/* 2 x 2 pivot block: */
+
+/* Multiply by the diagonal block if forming L * D. */
+
+ if (nounit) {
+ d11 = a[k - 1 + (k - 1) * a_dim1];
+ d22 = a[k + k * a_dim1];
+ d21 = a[k + (k - 1) * a_dim1];
+ d12 = d21;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ t1 = b[k - 1 + j * b_dim1];
+ t2 = b[k + j * b_dim1];
+ b[k - 1 + j * b_dim1] = d11 * t1 + d12 * t2;
+ b[k + j * b_dim1] = d21 * t1 + d22 * t2;
+/* L50: */
+ }
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ sger_(&i__1, nrhs, &c_b15, &a[k + 1 + k * a_dim1], &c__1,
+ &b[k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+ i__1 = *n - k;
+ sger_(&i__1, nrhs, &c_b15, &a[k + 1 + (k - 1) * a_dim1], &
+ c__1, &b[k - 1 + b_dim1], ldb, &b[k + 1 + b_dim1],
+ ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ k += -2;
+ }
+ goto L40;
+L60:
+ ;
+ }
+/* ---------------------------------------- */
+
+/* Compute B := A' * B (transpose) */
+
+/* ---------------------------------------- */
+ } else {
+
+/* Form B := U'*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+/* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop backward applying the transformations. */
+
+ k = *n;
+L70:
+ if (k < 1) {
+ goto L90;
+ }
+
+/* 1 x 1 pivot block. */
+
+ if (ipiv[k] > 0) {
+ if (k > 1) {
+
+/* Interchange if P(K) .ne. I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ i__1 = k - 1;
+ sgemv_("Transpose", &i__1, nrhs, &c_b15, &b[b_offset],
+ ldb, &a[k * a_dim1 + 1], &c__1, &c_b15, &b[k +
+ b_dim1], ldb);
+ }
+ if (nounit) {
+ sscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+ --k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ if (k > 2) {
+
+/* Interchange if P(K) .ne. I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k - 1) {
+ sswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformations */
+
+ i__1 = k - 2;
+ sgemv_("Transpose", &i__1, nrhs, &c_b15, &b[b_offset],
+ ldb, &a[k * a_dim1 + 1], &c__1, &c_b15, &b[k +
+ b_dim1], ldb);
+ i__1 = k - 2;
+ sgemv_("Transpose", &i__1, nrhs, &c_b15, &b[b_offset],
+ ldb, &a[(k - 1) * a_dim1 + 1], &c__1, &c_b15, &b[
+ k - 1 + b_dim1], ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ d11 = a[k - 1 + (k - 1) * a_dim1];
+ d22 = a[k + k * a_dim1];
+ d12 = a[k - 1 + k * a_dim1];
+ d21 = d12;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ t1 = b[k - 1 + j * b_dim1];
+ t2 = b[k + j * b_dim1];
+ b[k - 1 + j * b_dim1] = d11 * t1 + d12 * t2;
+ b[k + j * b_dim1] = d21 * t1 + d22 * t2;
+/* L80: */
+ }
+ }
+ k += -2;
+ }
+ goto L70;
+L90:
+
+/* Form B := L'*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) */
+/* and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1) */
+
+ ;
+ } else {
+
+/* Loop forward applying the L-transformations. */
+
+ k = 1;
+L100:
+ if (k > *n) {
+ goto L120;
+ }
+
+/* 1 x 1 pivot block */
+
+ if (ipiv[k] > 0) {
+ if (k < *n) {
+
+/* Interchange if P(K) .ne. I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ i__1 = *n - k;
+ sgemv_("Transpose", &i__1, nrhs, &c_b15, &b[k + 1 +
+ b_dim1], ldb, &a[k + 1 + k * a_dim1], &c__1, &
+ c_b15, &b[k + b_dim1], ldb);
+ }
+ if (nounit) {
+ sscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+ ++k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ if (k < *n - 1) {
+
+/* Interchange if P(K) .ne. I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k + 1) {
+ sswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ i__1 = *n - k - 1;
+ sgemv_("Transpose", &i__1, nrhs, &c_b15, &b[k + 2 +
+ b_dim1], ldb, &a[k + 2 + (k + 1) * a_dim1], &c__1,
+ &c_b15, &b[k + 1 + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ sgemv_("Transpose", &i__1, nrhs, &c_b15, &b[k + 2 +
+ b_dim1], ldb, &a[k + 2 + k * a_dim1], &c__1, &
+ c_b15, &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ d11 = a[k + k * a_dim1];
+ d22 = a[k + 1 + (k + 1) * a_dim1];
+ d21 = a[k + 1 + k * a_dim1];
+ d12 = d21;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ t1 = b[k + j * b_dim1];
+ t2 = b[k + 1 + j * b_dim1];
+ b[k + j * b_dim1] = d11 * t1 + d12 * t2;
+ b[k + 1 + j * b_dim1] = d21 * t1 + d22 * t2;
+/* L110: */
+ }
+ }
+ k += 2;
+ }
+ goto L100;
+L120:
+ ;
+ }
+
+ }
+ return 0;
+
+/* End of SLAVSY */
+
+} /* slavsy_ */
diff --git a/TESTING/LIN/slqt01.c b/TESTING/LIN/slqt01.c
new file mode 100644
index 0000000..345518f
--- /dev/null
+++ b/TESTING/LIN/slqt01.c
@@ -0,0 +1,223 @@
+/* slqt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static real c_b6 = -1e10f;
+static real c_b11 = 0.f;
+static real c_b16 = -1.f;
+static real c_b17 = 1.f;
+
+/* Subroutine */ int slqt01_(integer *m, integer *n, real *a, real *af, real *
+ q, real *l, integer *lda, real *tau, real *work, integer *lwork, real
+ *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
+ q_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real eps;
+ integer info;
+ real resid;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm;
+ integer minmn;
+ extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *,
+ real *, real *, integer *, real *, real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int sgelqf_(integer *, integer *, real *, integer
+ *, real *, real *, integer *, integer *), slacpy_(char *, integer
+ *, integer *, real *, integer *, real *, integer *),
+ slaset_(char *, integer *, integer *, real *, real *, real *,
+ integer *), sorglq_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLQT01 tests SGELQF, which computes the LQ factorization of an m-by-n */
+/* matrix A, and partially tests SORGLQ which forms the n-by-n */
+/* orthogonal matrix Q. */
+
+/* SLQT01 compares L with A*Q', and checks that Q is orthogonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The m-by-n matrix A. */
+
+/* AF (output) REAL array, dimension (LDA,N) */
+/* Details of the LQ factorization of A, as returned by SGELQF. */
+/* See SGELQF for further details. */
+
+/* Q (output) REAL array, dimension (LDA,N) */
+/* The n-by-n orthogonal matrix Q. */
+
+/* L (workspace) REAL array, dimension (LDA,max(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and L. */
+/* LDA >= max(M,N). */
+
+/* TAU (output) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by SGELQF. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) REAL array, dimension (max(M,N)) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ l_dim1 = *lda;
+ l_offset = 1 + l_dim1;
+ l -= l_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ minmn = min(*m,*n);
+ eps = slamch_("Epsilon");
+
+/* Copy the matrix A to the array AF. */
+
+ slacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+
+/* Factorize the matrix A in the array AF. */
+
+ s_copy(srnamc_1.srnamt, "SGELQF", (ftnlen)32, (ftnlen)6);
+ sgelqf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy details of Q */
+
+ slaset_("Full", n, n, &c_b6, &c_b6, &q[q_offset], lda);
+ if (*n > 1) {
+ i__1 = *n - 1;
+ slacpy_("Upper", m, &i__1, &af[(af_dim1 << 1) + 1], lda, &q[(q_dim1 <<
+ 1) + 1], lda);
+ }
+
+/* Generate the n-by-n matrix Q */
+
+ s_copy(srnamc_1.srnamt, "SORGLQ", (ftnlen)32, (ftnlen)6);
+ sorglq_(n, n, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy L */
+
+ slaset_("Full", m, n, &c_b11, &c_b11, &l[l_offset], lda);
+ slacpy_("Lower", m, n, &af[af_offset], lda, &l[l_offset], lda);
+
+/* Compute L - A*Q' */
+
+ sgemm_("No transpose", "Transpose", m, n, n, &c_b16, &a[a_offset], lda, &
+ q[q_offset], lda, &c_b17, &l[l_offset], lda);
+
+/* Compute norm( L - Q'*A ) / ( N * norm(A) * EPS ) . */
+
+ anorm = slange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ resid = slange_("1", m, n, &l[l_offset], lda, &rwork[1]);
+ if (anorm > 0.f) {
+ result[1] = resid / (real) max(1,*n) / anorm / eps;
+ } else {
+ result[1] = 0.f;
+ }
+
+/* Compute I - Q*Q' */
+
+ slaset_("Full", n, n, &c_b11, &c_b17, &l[l_offset], lda);
+ ssyrk_("Upper", "No transpose", n, n, &c_b16, &q[q_offset], lda, &c_b17, &
+ l[l_offset], lda);
+
+/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
+
+ resid = slansy_("1", "Upper", n, &l[l_offset], lda, &rwork[1]);
+
+ result[2] = resid / (real) max(1,*n) / eps;
+
+ return 0;
+
+/* End of SLQT01 */
+
+} /* slqt01_ */
diff --git a/TESTING/LIN/slqt02.c b/TESTING/LIN/slqt02.c
new file mode 100644
index 0000000..3939ce2
--- /dev/null
+++ b/TESTING/LIN/slqt02.c
@@ -0,0 +1,215 @@
+/* slqt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static real c_b4 = -1e10f;
+static real c_b9 = 0.f;
+static real c_b14 = -1.f;
+static real c_b15 = 1.f;
+
+/* Subroutine */ int slqt02_(integer *m, integer *n, integer *k, real *a,
+ real *af, real *q, real *l, integer *lda, real *tau, real *work,
+ integer *lwork, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
+ q_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real eps;
+ integer info;
+ real resid;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm;
+ extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *,
+ real *, real *, integer *, real *, real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *), sorglq_(
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, integer *, integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLQT02 tests SORGLQ, which generates an m-by-n matrix Q with */
+/* orthonornmal rows that is defined as the product of k elementary */
+/* reflectors. */
+
+/* Given the LQ factorization of an m-by-n matrix A, SLQT02 generates */
+/* the orthogonal matrix Q defined by the factorization of the first k */
+/* rows of A; it compares L(1:k,1:m) with A(1:k,1:n)*Q(1:m,1:n)', and */
+/* checks that the rows of Q are orthonormal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q to be generated. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q to be generated. */
+/* N >= M >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The m-by-n matrix A which was factorized by SLQT01. */
+
+/* AF (input) REAL array, dimension (LDA,N) */
+/* Details of the LQ factorization of A, as returned by SGELQF. */
+/* See SGELQF for further details. */
+
+/* Q (workspace) REAL array, dimension (LDA,N) */
+
+/* L (workspace) REAL array, dimension (LDA,M) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and L. LDA >= N. */
+
+/* TAU (input) REAL array, dimension (M) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the LQ factorization in AF. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ l_dim1 = *lda;
+ l_offset = 1 + l_dim1;
+ l -= l_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ eps = slamch_("Epsilon");
+
+/* Copy the first k rows of the factorization to the array Q */
+
+ slaset_("Full", m, n, &c_b4, &c_b4, &q[q_offset], lda);
+ i__1 = *n - 1;
+ slacpy_("Upper", k, &i__1, &af[(af_dim1 << 1) + 1], lda, &q[(q_dim1 << 1)
+ + 1], lda);
+
+/* Generate the first n columns of the matrix Q */
+
+ s_copy(srnamc_1.srnamt, "SORGLQ", (ftnlen)32, (ftnlen)6);
+ sorglq_(m, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy L(1:k,1:m) */
+
+ slaset_("Full", k, m, &c_b9, &c_b9, &l[l_offset], lda);
+ slacpy_("Lower", k, m, &af[af_offset], lda, &l[l_offset], lda);
+
+/* Compute L(1:k,1:m) - A(1:k,1:n) * Q(1:m,1:n)' */
+
+ sgemm_("No transpose", "Transpose", k, m, n, &c_b14, &a[a_offset], lda, &
+ q[q_offset], lda, &c_b15, &l[l_offset], lda);
+
+/* Compute norm( L - A*Q' ) / ( N * norm(A) * EPS ) . */
+
+ anorm = slange_("1", k, n, &a[a_offset], lda, &rwork[1]);
+ resid = slange_("1", k, m, &l[l_offset], lda, &rwork[1]);
+ if (anorm > 0.f) {
+ result[1] = resid / (real) max(1,*n) / anorm / eps;
+ } else {
+ result[1] = 0.f;
+ }
+
+/* Compute I - Q*Q' */
+
+ slaset_("Full", m, m, &c_b9, &c_b15, &l[l_offset], lda);
+ ssyrk_("Upper", "No transpose", m, n, &c_b14, &q[q_offset], lda, &c_b15, &
+ l[l_offset], lda);
+
+/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
+
+ resid = slansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
+
+ result[2] = resid / (real) max(1,*n) / eps;
+
+ return 0;
+
+/* End of SLQT02 */
+
+} /* slqt02_ */
diff --git a/TESTING/LIN/slqt03.c b/TESTING/LIN/slqt03.c
new file mode 100644
index 0000000..b6f50d5
--- /dev/null
+++ b/TESTING/LIN/slqt03.c
@@ -0,0 +1,260 @@
+/* slqt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static real c_b4 = -1e10f;
+static integer c__2 = 2;
+static real c_b21 = -1.f;
+static real c_b22 = 1.f;
+
+/* Subroutine */ int slqt03_(integer *m, integer *n, integer *k, real *af,
+ real *c__, real *cc, real *q, integer *lda, real *tau, real *work,
+ integer *lwork, real *rwork, real *result)
+{
+ /* Initialized data */
+
+ static integer iseed[4] = { 1988,1989,1990,1991 };
+
+ /* System generated locals */
+ integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1,
+ q_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j, mc, nc;
+ real eps;
+ char side[1];
+ integer info, iside;
+ extern logical lsame_(char *, char *);
+ real resid;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real cnorm;
+ char trans[1];
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *);
+ integer itrans;
+ extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
+ *), sorglq_(integer *, integer *, integer *, real *, integer *,
+ real *, real *, integer *, integer *), sormlq_(char *, char *,
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLQT03 tests SORMLQ, which computes Q*C, Q'*C, C*Q or C*Q'. */
+
+/* SLQT03 compares the results of a call to SORMLQ with the results of */
+/* forming Q explicitly by a call to SORGLQ and then performing matrix */
+/* multiplication by a call to SGEMM. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows or columns of the matrix C; C is n-by-m if */
+/* Q is applied from the left, or m-by-n if Q is applied from */
+/* the right. M >= 0. */
+
+/* N (input) INTEGER */
+/* The order of the orthogonal matrix Q. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* orthogonal matrix Q. N >= K >= 0. */
+
+/* AF (input) REAL array, dimension (LDA,N) */
+/* Details of the LQ factorization of an m-by-n matrix, as */
+/* returned by SGELQF. See SGELQF for further details. */
+
+/* C (workspace) REAL array, dimension (LDA,N) */
+
+/* CC (workspace) REAL array, dimension (LDA,N) */
+
+/* Q (workspace) REAL array, dimension (LDA,N) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays AF, C, CC, and Q. */
+
+/* TAU (input) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the LQ factorization in AF. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK must be at least M, and should be */
+/* M*NB, where NB is the blocksize for this environment. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (4) */
+/* The test ratios compare two techniques for multiplying a */
+/* random matrix C by an n-by-n orthogonal matrix Q. */
+/* RESULT(1) = norm( Q*C - Q*C ) / ( N * norm(C) * EPS ) */
+/* RESULT(2) = norm( C*Q - C*Q ) / ( N * norm(C) * EPS ) */
+/* RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS ) */
+/* RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ cc_dim1 = *lda;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+ c_dim1 = *lda;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = slamch_("Epsilon");
+
+/* Copy the first k rows of the factorization to the array Q */
+
+ slaset_("Full", n, n, &c_b4, &c_b4, &q[q_offset], lda);
+ i__1 = *n - 1;
+ slacpy_("Upper", k, &i__1, &af[(af_dim1 << 1) + 1], lda, &q[(q_dim1 << 1)
+ + 1], lda);
+
+/* Generate the n-by-n matrix Q */
+
+ s_copy(srnamc_1.srnamt, "SORGLQ", (ftnlen)32, (ftnlen)6);
+ sorglq_(n, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+ for (iside = 1; iside <= 2; ++iside) {
+ if (iside == 1) {
+ *(unsigned char *)side = 'L';
+ mc = *n;
+ nc = *m;
+ } else {
+ *(unsigned char *)side = 'R';
+ mc = *m;
+ nc = *n;
+ }
+
+/* Generate MC by NC matrix C */
+
+ i__1 = nc;
+ for (j = 1; j <= i__1; ++j) {
+ slarnv_(&c__2, iseed, &mc, &c__[j * c_dim1 + 1]);
+/* L10: */
+ }
+ cnorm = slange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]);
+ if (cnorm == 0.f) {
+ cnorm = 1.f;
+ }
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+ if (itrans == 1) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'T';
+ }
+
+/* Copy C */
+
+ slacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
+ lda);
+
+/* Apply Q or Q' to C */
+
+ s_copy(srnamc_1.srnamt, "SORMLQ", (ftnlen)32, (ftnlen)6);
+ sormlq_(side, trans, &mc, &nc, k, &af[af_offset], lda, &tau[1], &
+ cc[cc_offset], lda, &work[1], lwork, &info);
+
+/* Form explicit product and subtract */
+
+ if (lsame_(side, "L")) {
+ sgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b21, &q[
+ q_offset], lda, &c__[c_offset], lda, &c_b22, &cc[
+ cc_offset], lda);
+ } else {
+ sgemm_("No transpose", trans, &mc, &nc, &nc, &c_b21, &c__[
+ c_offset], lda, &q[q_offset], lda, &c_b22, &cc[
+ cc_offset], lda);
+ }
+
+/* Compute error in the difference */
+
+ resid = slange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
+ result[(iside - 1 << 1) + itrans] = resid / ((real) max(1,*n) *
+ cnorm * eps);
+
+/* L20: */
+ }
+/* L30: */
+ }
+
+ return 0;
+
+/* End of SLQT03 */
+
+} /* slqt03_ */
diff --git a/TESTING/LIN/spbt01.c b/TESTING/LIN/spbt01.c
new file mode 100644
index 0000000..4c8a3b2
--- /dev/null
+++ b/TESTING/LIN/spbt01.c
@@ -0,0 +1,242 @@
+/* spbt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b14 = 1.f;
+
+/* Subroutine */ int spbt01_(char *uplo, integer *n, integer *kd, real *a,
+ integer *lda, real *afac, integer *ldafac, real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ real t;
+ integer kc, ml, mu;
+ real eps;
+ integer klen;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ extern /* Subroutine */ int ssyr_(char *, integer *, real *, real *,
+ integer *, real *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real anorm;
+ extern /* Subroutine */ int strmv_(char *, char *, char *, integer *,
+ real *, integer *, real *, integer *);
+ extern doublereal slamch_(char *), slansb_(char *, char *,
+ integer *, integer *, real *, integer *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPBT01 reconstructs a symmetric positive definite band matrix A from */
+/* its L*L' or U'*U factorization and computes the residual */
+/* norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
+/* norm( U'*U - A ) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon, L' is the conjugate transpose of */
+/* L, and U' is the conjugate transpose of U. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The original symmetric band matrix A. If UPLO = 'U', the */
+/* upper triangular part of A is stored as a band matrix; if */
+/* UPLO = 'L', the lower triangular part of A is stored. The */
+/* columns of the appropriate triangle are stored in the columns */
+/* of A and the diagonals of the triangle are stored in the rows */
+/* of A. See SPBTRF for further details. */
+
+/* LDA (input) INTEGER. */
+/* The leading dimension of the array A. LDA >= max(1,KD+1). */
+
+/* AFAC (input) REAL array, dimension (LDAFAC,N) */
+/* The factored form of the matrix A. AFAC contains the factor */
+/* L or U from the L*L' or U'*U factorization in band storage */
+/* format, as computed by SPBTRF. */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. */
+/* LDAFAC >= max(1,KD+1). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
+/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = slansb_("1", uplo, n, kd, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute the product U'*U, overwriting U. */
+
+ if (lsame_(uplo, "U")) {
+ for (k = *n; k >= 1; --k) {
+/* Computing MAX */
+ i__1 = 1, i__2 = *kd + 2 - k;
+ kc = max(i__1,i__2);
+ klen = *kd + 1 - kc;
+
+/* Compute the (K,K) element of the result. */
+
+ i__1 = klen + 1;
+ t = sdot_(&i__1, &afac[kc + k * afac_dim1], &c__1, &afac[kc + k *
+ afac_dim1], &c__1);
+ afac[*kd + 1 + k * afac_dim1] = t;
+
+/* Compute the rest of column K. */
+
+ if (klen > 0) {
+ i__1 = *ldafac - 1;
+ strmv_("Upper", "Transpose", "Non-unit", &klen, &afac[*kd + 1
+ + (k - klen) * afac_dim1], &i__1, &afac[kc + k *
+ afac_dim1], &c__1);
+ }
+
+/* L10: */
+ }
+
+/* UPLO = 'L': Compute the product L*L', overwriting L. */
+
+ } else {
+ for (k = *n; k >= 1; --k) {
+/* Computing MIN */
+ i__1 = *kd, i__2 = *n - k;
+ klen = min(i__1,i__2);
+
+/* Add a multiple of column K of the factor L to each of */
+/* columns K+1 through N. */
+
+ if (klen > 0) {
+ i__1 = *ldafac - 1;
+ ssyr_("Lower", &klen, &c_b14, &afac[k * afac_dim1 + 2], &c__1,
+ &afac[(k + 1) * afac_dim1 + 1], &i__1);
+ }
+
+/* Scale column K by the diagonal element. */
+
+ t = afac[k * afac_dim1 + 1];
+ i__1 = klen + 1;
+ sscal_(&i__1, &t, &afac[k * afac_dim1 + 1], &c__1);
+
+/* L20: */
+ }
+ }
+
+/* Compute the difference L*L' - A or U'*U - A. */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = 1, i__3 = *kd + 2 - j;
+ mu = max(i__2,i__3);
+ i__2 = *kd + 1;
+ for (i__ = mu; i__ <= i__2; ++i__) {
+ afac[i__ + j * afac_dim1] -= a[i__ + j * a_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *kd + 1, i__3 = *n - j + 1;
+ ml = min(i__2,i__3);
+ i__2 = ml;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ afac[i__ + j * afac_dim1] -= a[i__ + j * a_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+
+/* Compute norm( L*L' - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = slansb_("I", uplo, n, kd, &afac[afac_offset], ldafac, &rwork[1]);
+
+ *resid = *resid / (real) (*n) / anorm / eps;
+
+ return 0;
+
+/* End of SPBT01 */
+
+} /* spbt01_ */
diff --git a/TESTING/LIN/spbt02.c b/TESTING/LIN/spbt02.c
new file mode 100644
index 0000000..7427146
--- /dev/null
+++ b/TESTING/LIN/spbt02.c
@@ -0,0 +1,180 @@
+/* spbt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b5 = -1.f;
+static integer c__1 = 1;
+static real c_b7 = 1.f;
+
+/* Subroutine */ int spbt02_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, real *a, integer *lda, real *x, integer *ldx, real *b, integer *
+ ldb, real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j;
+ real eps, anorm, bnorm;
+ extern doublereal sasum_(integer *, real *, integer *);
+ extern /* Subroutine */ int ssbmv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *);
+ real xnorm;
+ extern doublereal slamch_(char *), slansb_(char *, char *,
+ integer *, integer *, real *, integer *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPBT02 computes the residual for a solution of a symmetric banded */
+/* system of equations A*x = b: */
+/* RESID = norm( B - A*X ) / ( norm(A) * norm(X) * EPS) */
+/* where EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The original symmetric band matrix A. If UPLO = 'U', the */
+/* upper triangular part of A is stored as a band matrix; if */
+/* UPLO = 'L', the lower triangular part of A is stored. The */
+/* columns of the appropriate triangle are stored in the columns */
+/* of A and the diagonals of the triangle are stored in the rows */
+/* of A. See SPBTRF for further details. */
+
+/* LDA (input) INTEGER. */
+/* The leading dimension of the array A. LDA >= max(1,KD+1). */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = slansb_("1", uplo, n, kd, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute B - A*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ssbmv_(uplo, n, kd, &c_b5, &a[a_offset], lda, &x[j * x_dim1 + 1], &
+ c__1, &c_b7, &b[j * b_dim1 + 1], &c__1);
+/* L10: */
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = sasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = sasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L20: */
+ }
+
+ return 0;
+
+/* End of SPBT02 */
+
+} /* spbt02_ */
diff --git a/TESTING/LIN/spbt05.c b/TESTING/LIN/spbt05.c
new file mode 100644
index 0000000..07a9deb
--- /dev/null
+++ b/TESTING/LIN/spbt05.c
@@ -0,0 +1,292 @@
+/* spbt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int spbt05_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, real *ab, integer *ldab, real *b, integer *ldb, real *x,
+ integer *ldx, real *xact, integer *ldxact, real *ferr, real *berr,
+ real *reslts)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, k, nz;
+ real eps, tmp, diff, axbi;
+ integer imax;
+ real unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ real xnorm;
+ extern doublereal slamch_(char *);
+ real errbnd;
+ extern integer isamax_(integer *, real *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPBT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* symmetric band matrix. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+/* and NZ = max. number of nonzeros in any row of A, plus 1 */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* AB (input) REAL array, dimension (LDAB,N) */
+/* The upper or lower triangle of the symmetric band matrix A, */
+/* stored in the first KD+1 rows of the array. The j-th column */
+/* of A is stored in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) REAL array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) REAL array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) REAL array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.f;
+ reslts[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ upper = lsame_(uplo, "U");
+/* Computing MAX */
+ i__1 = *kd, i__2 = *n - 1;
+ nz = (max(i__1,i__2) << 1) + 1;
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = isamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ r__2 = (r__1 = x[imax + j * x_dim1], dabs(r__1));
+ xnorm = dmax(r__2,unfl);
+ diff = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = diff, r__3 = (r__1 = x[i__ + j * x_dim1] - xact[i__ + j *
+ xact_dim1], dabs(r__1));
+ diff = dmax(r__2,r__3);
+/* L10: */
+ }
+
+ if (xnorm > 1.f) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1.f / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
+ errbnd = dmax(r__1,r__2);
+ } else {
+ errbnd = 1.f / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ tmp = (r__1 = b[i__ + k * b_dim1], dabs(r__1));
+ if (upper) {
+/* Computing MAX */
+ i__3 = i__ - *kd;
+ i__4 = i__;
+ for (j = max(i__3,1); j <= i__4; ++j) {
+ tmp += (r__1 = ab[*kd + 1 - i__ + j + i__ * ab_dim1],
+ dabs(r__1)) * (r__2 = x[j + k * x_dim1], dabs(
+ r__2));
+/* L40: */
+ }
+/* Computing MIN */
+ i__3 = i__ + *kd;
+ i__4 = min(i__3,*n);
+ for (j = i__ + 1; j <= i__4; ++j) {
+ tmp += (r__1 = ab[*kd + 1 + i__ - j + j * ab_dim1], dabs(
+ r__1)) * (r__2 = x[j + k * x_dim1], dabs(r__2));
+/* L50: */
+ }
+ } else {
+/* Computing MAX */
+ i__4 = i__ - *kd;
+ i__3 = i__ - 1;
+ for (j = max(i__4,1); j <= i__3; ++j) {
+ tmp += (r__1 = ab[i__ + 1 - j + j * ab_dim1], dabs(r__1))
+ * (r__2 = x[j + k * x_dim1], dabs(r__2));
+/* L60: */
+ }
+/* Computing MIN */
+ i__4 = i__ + *kd;
+ i__3 = min(i__4,*n);
+ for (j = i__; j <= i__3; ++j) {
+ tmp += (r__1 = ab[j + 1 - i__ + i__ * ab_dim1], dabs(r__1)
+ ) * (r__2 = x[j + k * x_dim1], dabs(r__2));
+/* L70: */
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = dmin(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ r__1 = axbi, r__2 = nz * unfl;
+ tmp = berr[k] / (nz * eps + nz * unfl / dmax(r__1,r__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = dmax(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of SPBT05 */
+
+} /* spbt05_ */
diff --git a/TESTING/LIN/spot01.c b/TESTING/LIN/spot01.c
new file mode 100644
index 0000000..5c7c5e7
--- /dev/null
+++ b/TESTING/LIN/spot01.c
@@ -0,0 +1,211 @@
+/* spot01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b14 = 1.f;
+
+/* Subroutine */ int spot01_(char *uplo, integer *n, real *a, integer *lda,
+ real *afac, integer *ldafac, real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k;
+ real t, eps;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ extern /* Subroutine */ int ssyr_(char *, integer *, real *, real *,
+ integer *, real *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real anorm;
+ extern /* Subroutine */ int strmv_(char *, char *, char *, integer *,
+ real *, integer *, real *, integer *);
+ extern doublereal slamch_(char *), slansy_(char *, char *,
+ integer *, real *, integer *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPOT01 reconstructs a symmetric positive definite matrix A from */
+/* its L*L' or U'*U factorization and computes the residual */
+/* norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
+/* norm( U'*U - A ) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The original symmetric matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* AFAC (input/output) REAL array, dimension (LDAFAC,N) */
+/* On entry, the factor L or U from the L*L' or U'*U */
+/* factorization of A. */
+/* Overwritten with the reconstructed matrix, and then with the */
+/* difference L*L' - A (or U'*U - A). */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
+/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = slansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute the product U'*U, overwriting U. */
+
+ if (lsame_(uplo, "U")) {
+ for (k = *n; k >= 1; --k) {
+
+/* Compute the (K,K) element of the result. */
+
+ t = sdot_(&k, &afac[k * afac_dim1 + 1], &c__1, &afac[k *
+ afac_dim1 + 1], &c__1);
+ afac[k + k * afac_dim1] = t;
+
+/* Compute the rest of column K. */
+
+ i__1 = k - 1;
+ strmv_("Upper", "Transpose", "Non-unit", &i__1, &afac[afac_offset]
+, ldafac, &afac[k * afac_dim1 + 1], &c__1);
+
+/* L10: */
+ }
+
+/* Compute the product L*L', overwriting L. */
+
+ } else {
+ for (k = *n; k >= 1; --k) {
+
+/* Add a multiple of column K of the factor L to each of */
+/* columns K+1 through N. */
+
+ if (k + 1 <= *n) {
+ i__1 = *n - k;
+ ssyr_("Lower", &i__1, &c_b14, &afac[k + 1 + k * afac_dim1], &
+ c__1, &afac[k + 1 + (k + 1) * afac_dim1], ldafac);
+ }
+
+/* Scale column K by the diagonal element. */
+
+ t = afac[k + k * afac_dim1];
+ i__1 = *n - k + 1;
+ sscal_(&i__1, &t, &afac[k + k * afac_dim1], &c__1);
+
+/* L20: */
+ }
+ }
+
+/* Compute the difference L*L' - A (or U'*U - A). */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ afac[i__ + j * afac_dim1] -= a[i__ + j * a_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ afac[i__ + j * afac_dim1] -= a[i__ + j * a_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+ }
+
+/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = slansy_("1", uplo, n, &afac[afac_offset], ldafac, &rwork[1]);
+
+ *resid = *resid / (real) (*n) / anorm / eps;
+
+ return 0;
+
+/* End of SPOT01 */
+
+} /* spot01_ */
diff --git a/TESTING/LIN/spot02.c b/TESTING/LIN/spot02.c
new file mode 100644
index 0000000..dbbbc6e
--- /dev/null
+++ b/TESTING/LIN/spot02.c
@@ -0,0 +1,174 @@
+/* spot02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b5 = -1.f;
+static real c_b6 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int spot02_(char *uplo, integer *n, integer *nrhs, real *a,
+ integer *lda, real *x, integer *ldx, real *b, integer *ldb, real *
+ rwork, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j;
+ real eps, anorm, bnorm;
+ extern doublereal sasum_(integer *, real *, integer *);
+ real xnorm;
+ extern /* Subroutine */ int ssymm_(char *, char *, integer *, integer *,
+ real *, real *, integer *, real *, integer *, real *, real *,
+ integer *);
+ extern doublereal slamch_(char *), slansy_(char *, char *,
+ integer *, real *, integer *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPOT02 computes the residual for the solution of a symmetric system */
+/* of linear equations A*x = b: */
+
+/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ), */
+
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The original symmetric matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = slansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute B - A*X */
+
+ ssymm_("Left", uplo, n, nrhs, &c_b5, &a[a_offset], lda, &x[x_offset], ldx,
+ &c_b6, &b[b_offset], ldb);
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = sasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = sasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of SPOT02 */
+
+} /* spot02_ */
diff --git a/TESTING/LIN/spot03.c b/TESTING/LIN/spot03.c
new file mode 100644
index 0000000..4d10d37
--- /dev/null
+++ b/TESTING/LIN/spot03.c
@@ -0,0 +1,196 @@
+/* spot03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b11 = -1.f;
+static real c_b12 = 0.f;
+
+/* Subroutine */ int spot03_(char *uplo, integer *n, real *a, integer *lda,
+ real *ainv, integer *ldainv, real *work, integer *ldwork, real *rwork,
+ real *rcond, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, ainv_dim1, ainv_offset, work_dim1, work_offset,
+ i__1, i__2;
+
+ /* Local variables */
+ integer i__, j;
+ real eps;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern /* Subroutine */ int ssymm_(char *, char *, integer *, integer *,
+ real *, real *, integer *, real *, integer *, real *, real *,
+ integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ real ainvnm;
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPOT03 computes the residual for a symmetric matrix times its */
+/* inverse: */
+/* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The original symmetric matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* AINV (input/output) REAL array, dimension (LDAINV,N) */
+/* On entry, the inverse of the matrix A, stored as a symmetric */
+/* matrix in the same format as A. */
+/* In this version, AINV is expanded into a full matrix and */
+/* multiplied by A, so the opposing triangle of AINV will be */
+/* changed; i.e., if the upper triangular part of AINV is */
+/* stored, the lower triangular part will be used as work space. */
+
+/* LDAINV (input) INTEGER */
+/* The leading dimension of the array AINV. LDAINV >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (LDWORK,N) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RCOND (output) REAL */
+/* The reciprocal of the condition number of A, computed as */
+/* ( 1/norm(A) ) / norm(AINV). */
+
+/* RESID (output) REAL */
+/* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ ainv_dim1 = *ldainv;
+ ainv_offset = 1 + ainv_dim1;
+ ainv -= ainv_offset;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.f;
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = slansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+ ainvnm = slansy_("1", uplo, n, &ainv[ainv_offset], ldainv, &rwork[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ *rcond = 0.f;
+ *resid = 1.f / eps;
+ return 0;
+ }
+ *rcond = 1.f / anorm / ainvnm;
+
+/* Expand AINV into a full matrix and call SSYMM to multiply */
+/* AINV on the left by A. */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ainv[j + i__ * ainv_dim1] = ainv[i__ + j * ainv_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ ainv[j + i__ * ainv_dim1] = ainv[i__ + j * ainv_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ ssymm_("Left", uplo, n, n, &c_b11, &a[a_offset], lda, &ainv[ainv_offset],
+ ldainv, &c_b12, &work[work_offset], ldwork);
+
+/* Add the identity matrix to WORK . */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__ + i__ * work_dim1] += 1.f;
+/* L50: */
+ }
+
+/* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = slange_("1", n, n, &work[work_offset], ldwork, &rwork[1]);
+
+ *resid = *resid * *rcond / eps / (real) (*n);
+
+ return 0;
+
+/* End of SPOT03 */
+
+} /* spot03_ */
diff --git a/TESTING/LIN/spot05.c b/TESTING/LIN/spot05.c
new file mode 100644
index 0000000..b794655
--- /dev/null
+++ b/TESTING/LIN/spot05.c
@@ -0,0 +1,276 @@
+/* spot05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int spot05_(char *uplo, integer *n, integer *nrhs, real *a,
+ integer *lda, real *b, integer *ldb, real *x, integer *ldx, real *
+ xact, integer *ldxact, real *ferr, real *berr, real *reslts)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, k;
+ real eps, tmp, diff, axbi;
+ integer imax;
+ real unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ real xnorm;
+ extern doublereal slamch_(char *);
+ real errbnd;
+ extern integer isamax_(integer *, real *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPOT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* symmetric n by n matrix. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The symmetric matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of A contains the upper triangular part */
+/* of the matrix A, and the strictly lower triangular part of A */
+/* is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of A contains the lower triangular part of */
+/* the matrix A, and the strictly upper triangular part of A is */
+/* not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) REAL array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) REAL array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) REAL array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.f;
+ reslts[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ upper = lsame_(uplo, "U");
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = isamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ r__2 = (r__1 = x[imax + j * x_dim1], dabs(r__1));
+ xnorm = dmax(r__2,unfl);
+ diff = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = diff, r__3 = (r__1 = x[i__ + j * x_dim1] - xact[i__ + j *
+ xact_dim1], dabs(r__1));
+ diff = dmax(r__2,r__3);
+/* L10: */
+ }
+
+ if (xnorm > 1.f) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1.f / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
+ errbnd = dmax(r__1,r__2);
+ } else {
+ errbnd = 1.f / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ tmp = (r__1 = b[i__ + k * b_dim1], dabs(r__1));
+ if (upper) {
+ i__3 = i__;
+ for (j = 1; j <= i__3; ++j) {
+ tmp += (r__1 = a[j + i__ * a_dim1], dabs(r__1)) * (r__2 =
+ x[j + k * x_dim1], dabs(r__2));
+/* L40: */
+ }
+ i__3 = *n;
+ for (j = i__ + 1; j <= i__3; ++j) {
+ tmp += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * (r__2 =
+ x[j + k * x_dim1], dabs(r__2));
+/* L50: */
+ }
+ } else {
+ i__3 = i__ - 1;
+ for (j = 1; j <= i__3; ++j) {
+ tmp += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * (r__2 =
+ x[j + k * x_dim1], dabs(r__2));
+/* L60: */
+ }
+ i__3 = *n;
+ for (j = i__; j <= i__3; ++j) {
+ tmp += (r__1 = a[j + i__ * a_dim1], dabs(r__1)) * (r__2 =
+ x[j + k * x_dim1], dabs(r__2));
+/* L70: */
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = dmin(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ r__1 = axbi, r__2 = (*n + 1) * unfl;
+ tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / dmax(r__1,r__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = dmax(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of SPOT05 */
+
+} /* spot05_ */
diff --git a/TESTING/LIN/sppt01.c b/TESTING/LIN/sppt01.c
new file mode 100644
index 0000000..3d357fa
--- /dev/null
+++ b/TESTING/LIN/sppt01.c
@@ -0,0 +1,194 @@
+/* sppt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b14 = 1.f;
+
+/* Subroutine */ int sppt01_(char *uplo, integer *n, real *a, real *afac,
+ real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer i__, k;
+ real t;
+ integer kc;
+ real eps;
+ integer npp;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ extern /* Subroutine */ int sspr_(char *, integer *, real *, real *,
+ integer *, real *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real anorm;
+ extern /* Subroutine */ int stpmv_(char *, char *, char *, integer *,
+ real *, real *, integer *);
+ extern doublereal slamch_(char *), slansp_(char *, char *,
+ integer *, real *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPPT01 reconstructs a symmetric positive definite packed matrix A */
+/* from its L*L' or U'*U factorization and computes the residual */
+/* norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
+/* norm( U'*U - A ) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (N*(N+1)/2) */
+/* The original symmetric matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* AFAC (input/output) REAL array, dimension (N*(N+1)/2) */
+/* On entry, the factor L or U from the L*L' or U'*U */
+/* factorization of A, stored as a packed triangular matrix. */
+/* Overwritten with the reconstructed matrix, and then with the */
+/* difference L*L' - A (or U'*U - A). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
+/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 */
+
+ /* Parameter adjustments */
+ --rwork;
+ --afac;
+ --a;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = slansp_("1", uplo, n, &a[1], &rwork[1]);
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute the product U'*U, overwriting U. */
+
+ if (lsame_(uplo, "U")) {
+ kc = *n * (*n - 1) / 2 + 1;
+ for (k = *n; k >= 1; --k) {
+
+/* Compute the (K,K) element of the result. */
+
+ t = sdot_(&k, &afac[kc], &c__1, &afac[kc], &c__1);
+ afac[kc + k - 1] = t;
+
+/* Compute the rest of column K. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ stpmv_("Upper", "Transpose", "Non-unit", &i__1, &afac[1], &
+ afac[kc], &c__1);
+ kc -= k - 1;
+ }
+/* L10: */
+ }
+
+/* Compute the product L*L', overwriting L. */
+
+ } else {
+ kc = *n * (*n + 1) / 2;
+ for (k = *n; k >= 1; --k) {
+
+/* Add a multiple of column K of the factor L to each of */
+/* columns K+1 through N. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ sspr_("Lower", &i__1, &c_b14, &afac[kc + 1], &c__1, &afac[kc
+ + *n - k + 1]);
+ }
+
+/* Scale column K by the diagonal element. */
+
+ t = afac[kc];
+ i__1 = *n - k + 1;
+ sscal_(&i__1, &t, &afac[kc], &c__1);
+
+ kc -= *n - k + 2;
+/* L20: */
+ }
+ }
+
+/* Compute the difference L*L' - A (or U'*U - A). */
+
+ npp = *n * (*n + 1) / 2;
+ i__1 = npp;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ afac[i__] -= a[i__];
+/* L30: */
+ }
+
+/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = slansp_("1", uplo, n, &afac[1], &rwork[1]);
+
+ *resid = *resid / (real) (*n) / anorm / eps;
+
+ return 0;
+
+/* End of SPPT01 */
+
+} /* sppt01_ */
diff --git a/TESTING/LIN/sppt02.c b/TESTING/LIN/sppt02.c
new file mode 100644
index 0000000..22d9e4c
--- /dev/null
+++ b/TESTING/LIN/sppt02.c
@@ -0,0 +1,174 @@
+/* sppt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b5 = -1.f;
+static integer c__1 = 1;
+static real c_b7 = 1.f;
+
+/* Subroutine */ int sppt02_(char *uplo, integer *n, integer *nrhs, real *a,
+ real *x, integer *ldx, real *b, integer *ldb, real *rwork, real *
+ resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j;
+ real eps, anorm, bnorm;
+ extern doublereal sasum_(integer *, real *, integer *);
+ real xnorm;
+ extern /* Subroutine */ int sspmv_(char *, integer *, real *, real *,
+ real *, integer *, real *, real *, integer *);
+ extern doublereal slamch_(char *), slansp_(char *, char *,
+ integer *, real *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPPT02 computes the residual in the solution of a symmetric system */
+/* of linear equations A*x = b when packed storage is used for the */
+/* coefficient matrix. The ratio computed is */
+
+/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS), */
+
+/* where EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) REAL array, dimension (N*(N+1)/2) */
+/* The original symmetric matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ --a;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = slansp_("1", uplo, n, &a[1], &rwork[1]);
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute B - A*X for the matrix of right hand sides B. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ sspmv_(uplo, n, &c_b5, &a[1], &x[j * x_dim1 + 1], &c__1, &c_b7, &b[j *
+ b_dim1 + 1], &c__1);
+/* L10: */
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = sasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = sasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L20: */
+ }
+
+ return 0;
+
+/* End of SPPT02 */
+
+} /* sppt02_ */
diff --git a/TESTING/LIN/sppt03.c b/TESTING/LIN/sppt03.c
new file mode 100644
index 0000000..46570d6
--- /dev/null
+++ b/TESTING/LIN/sppt03.c
@@ -0,0 +1,226 @@
+/* sppt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b13 = -1.f;
+static real c_b15 = 0.f;
+
+/* Subroutine */ int sppt03_(char *uplo, integer *n, real *a, real *ainv,
+ real *work, integer *ldwork, real *rwork, real *rcond, real *resid)
+{
+ /* System generated locals */
+ integer work_dim1, work_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, jj;
+ real eps;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), sspmv_(char *, integer *, real *, real *, real *,
+ integer *, real *, real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ real ainvnm;
+ extern doublereal slansp_(char *, char *, integer *, real *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPPT03 computes the residual for a symmetric packed matrix times its */
+/* inverse: */
+/* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (N*(N+1)/2) */
+/* The original symmetric matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* AINV (input) REAL array, dimension (N*(N+1)/2) */
+/* The (symmetric) inverse of the matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* WORK (workspace) REAL array, dimension (LDWORK,N) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RCOND (output) REAL */
+/* The reciprocal of the condition number of A, computed as */
+/* ( 1/norm(A) ) / norm(AINV). */
+
+/* RESID (output) REAL */
+/* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ --a;
+ --ainv;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.f;
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = slansp_("1", uplo, n, &a[1], &rwork[1]);
+ ainvnm = slansp_("1", uplo, n, &ainv[1], &rwork[1]);
+ if (anorm <= 0.f || ainvnm == 0.f) {
+ *rcond = 0.f;
+ *resid = 1.f / eps;
+ return 0;
+ }
+ *rcond = 1.f / anorm / ainvnm;
+
+/* UPLO = 'U': */
+/* Copy the leading N-1 x N-1 submatrix of AINV to WORK(1:N,2:N) and */
+/* expand it to a full matrix, then multiply by A one column at a */
+/* time, moving the result one column to the left. */
+
+ if (lsame_(uplo, "U")) {
+
+/* Copy AINV */
+
+ jj = 1;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(&j, &ainv[jj], &c__1, &work[(j + 1) * work_dim1 + 1], &
+ c__1);
+ i__2 = j - 1;
+ scopy_(&i__2, &ainv[jj], &c__1, &work[j + (work_dim1 << 1)],
+ ldwork);
+ jj += j;
+/* L10: */
+ }
+ jj = (*n - 1) * *n / 2 + 1;
+ i__1 = *n - 1;
+ scopy_(&i__1, &ainv[jj], &c__1, &work[*n + (work_dim1 << 1)], ldwork);
+
+/* Multiply by A */
+
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ sspmv_("Upper", n, &c_b13, &a[1], &work[(j + 1) * work_dim1 + 1],
+ &c__1, &c_b15, &work[j * work_dim1 + 1], &c__1)
+ ;
+/* L20: */
+ }
+ sspmv_("Upper", n, &c_b13, &a[1], &ainv[jj], &c__1, &c_b15, &work[*n *
+ work_dim1 + 1], &c__1);
+
+/* UPLO = 'L': */
+/* Copy the trailing N-1 x N-1 submatrix of AINV to WORK(1:N,1:N-1) */
+/* and multiply by A, moving each column to the right. */
+
+ } else {
+
+/* Copy AINV */
+
+ i__1 = *n - 1;
+ scopy_(&i__1, &ainv[2], &c__1, &work[work_dim1 + 1], ldwork);
+ jj = *n + 1;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ scopy_(&i__2, &ainv[jj], &c__1, &work[j + (j - 1) * work_dim1], &
+ c__1);
+ i__2 = *n - j;
+ scopy_(&i__2, &ainv[jj + 1], &c__1, &work[j + j * work_dim1],
+ ldwork);
+ jj = jj + *n - j + 1;
+/* L30: */
+ }
+
+/* Multiply by A */
+
+ for (j = *n; j >= 2; --j) {
+ sspmv_("Lower", n, &c_b13, &a[1], &work[(j - 1) * work_dim1 + 1],
+ &c__1, &c_b15, &work[j * work_dim1 + 1], &c__1)
+ ;
+/* L40: */
+ }
+ sspmv_("Lower", n, &c_b13, &a[1], &ainv[1], &c__1, &c_b15, &work[
+ work_dim1 + 1], &c__1);
+
+ }
+
+/* Add the identity matrix to WORK . */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[i__ + i__ * work_dim1] += 1.f;
+/* L50: */
+ }
+
+/* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = slange_("1", n, n, &work[work_offset], ldwork, &rwork[1]);
+
+ *resid = *resid * *rcond / eps / (real) (*n);
+
+ return 0;
+
+/* End of SPPT03 */
+
+} /* sppt03_ */
diff --git a/TESTING/LIN/sppt05.c b/TESTING/LIN/sppt05.c
new file mode 100644
index 0000000..aa15030
--- /dev/null
+++ b/TESTING/LIN/sppt05.c
@@ -0,0 +1,274 @@
+/* sppt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sppt05_(char *uplo, integer *n, integer *nrhs, real *ap,
+ real *b, integer *ldb, real *x, integer *ldx, real *xact, integer *
+ ldxact, real *ferr, real *berr, real *reslts)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1,
+ i__2, i__3;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, k, jc;
+ real eps, tmp, diff, axbi;
+ integer imax;
+ real unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ real xnorm;
+ extern doublereal slamch_(char *);
+ real errbnd;
+ extern integer isamax_(integer *, real *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPPT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* symmetric matrix in packed storage format. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* AP (input) REAL array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the symmetric matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) REAL array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) REAL array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) REAL array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.f;
+ reslts[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ upper = lsame_(uplo, "U");
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = isamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ r__2 = (r__1 = x[imax + j * x_dim1], dabs(r__1));
+ xnorm = dmax(r__2,unfl);
+ diff = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = diff, r__3 = (r__1 = x[i__ + j * x_dim1] - xact[i__ + j *
+ xact_dim1], dabs(r__1));
+ diff = dmax(r__2,r__3);
+/* L10: */
+ }
+
+ if (xnorm > 1.f) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1.f / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
+ errbnd = dmax(r__1,r__2);
+ } else {
+ errbnd = 1.f / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ tmp = (r__1 = b[i__ + k * b_dim1], dabs(r__1));
+ if (upper) {
+ jc = (i__ - 1) * i__ / 2;
+ i__3 = i__;
+ for (j = 1; j <= i__3; ++j) {
+ tmp += (r__1 = ap[jc + j], dabs(r__1)) * (r__2 = x[j + k *
+ x_dim1], dabs(r__2));
+/* L40: */
+ }
+ jc += i__;
+ i__3 = *n;
+ for (j = i__ + 1; j <= i__3; ++j) {
+ tmp += (r__1 = ap[jc], dabs(r__1)) * (r__2 = x[j + k *
+ x_dim1], dabs(r__2));
+ jc += j;
+/* L50: */
+ }
+ } else {
+ jc = i__;
+ i__3 = i__ - 1;
+ for (j = 1; j <= i__3; ++j) {
+ tmp += (r__1 = ap[jc], dabs(r__1)) * (r__2 = x[j + k *
+ x_dim1], dabs(r__2));
+ jc = jc + *n - j;
+/* L60: */
+ }
+ i__3 = *n;
+ for (j = i__; j <= i__3; ++j) {
+ tmp += (r__1 = ap[jc + j - i__], dabs(r__1)) * (r__2 = x[
+ j + k * x_dim1], dabs(r__2));
+/* L70: */
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = dmin(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ r__1 = axbi, r__2 = (*n + 1) * unfl;
+ tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / dmax(r__1,r__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = dmax(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of SPPT05 */
+
+} /* sppt05_ */
diff --git a/TESTING/LIN/spst01.c b/TESTING/LIN/spst01.c
new file mode 100644
index 0000000..c043908
--- /dev/null
+++ b/TESTING/LIN/spst01.c
@@ -0,0 +1,299 @@
+/* spst01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b18 = 1.f;
+
+/* Subroutine */ int spst01_(char *uplo, integer *n, real *a, integer *lda,
+ real *afac, integer *ldafac, real *perm, integer *ldperm, integer *
+ piv, real *rwork, real *resid, integer *rank)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, perm_dim1, perm_offset,
+ i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, k;
+ real t, eps;
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
+ extern /* Subroutine */ int ssyr_(char *, integer *, real *, real *,
+ integer *, real *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real anorm;
+ extern /* Subroutine */ int strmv_(char *, char *, char *, integer *,
+ real *, integer *, real *, integer *);
+ extern doublereal slamch_(char *), slansy_(char *, char *,
+ integer *, real *, integer *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPST01 reconstructs a symmetric positive semidefinite matrix A */
+/* from its L or U factors and the permutation matrix P and computes */
+/* the residual */
+/* norm( P*L*L'*P' - A ) / ( N * norm(A) * EPS ) or */
+/* norm( P*U'*U*P' - A ) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The original symmetric matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* AFAC (input) REAL array, dimension (LDAFAC,N) */
+/* The factor L or U from the L*L' or U'*U */
+/* factorization of A. */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
+
+/* PERM (output) REAL array, dimension (LDPERM,N) */
+/* Overwritten with the reconstructed matrix, and then with the */
+/* difference P*L*L'*P' - A (or P*U'*U*P' - A) */
+
+/* LDPERM (input) INTEGER */
+/* The leading dimension of the array PERM. */
+/* LDAPERM >= max(1,N). */
+
+/* PIV (input) INTEGER array, dimension (N) */
+/* PIV is such that the nonzero entries are */
+/* P( PIV( K ), K ) = 1. */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
+/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ perm_dim1 = *ldperm;
+ perm_offset = 1 + perm_dim1;
+ perm -= perm_offset;
+ --piv;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = slansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute the product U'*U, overwriting U. */
+
+ if (lsame_(uplo, "U")) {
+
+ if (*rank < *n) {
+ i__1 = *n;
+ for (j = *rank + 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = *rank + 1; i__ <= i__2; ++i__) {
+ afac[i__ + j * afac_dim1] = 0.f;
+/* L100: */
+ }
+/* L110: */
+ }
+ }
+
+ for (k = *n; k >= 1; --k) {
+
+/* Compute the (K,K) element of the result. */
+
+ t = sdot_(&k, &afac[k * afac_dim1 + 1], &c__1, &afac[k *
+ afac_dim1 + 1], &c__1);
+ afac[k + k * afac_dim1] = t;
+
+/* Compute the rest of column K. */
+
+ i__1 = k - 1;
+ strmv_("Upper", "Transpose", "Non-unit", &i__1, &afac[afac_offset]
+, ldafac, &afac[k * afac_dim1 + 1], &c__1);
+
+/* L120: */
+ }
+
+/* Compute the product L*L', overwriting L. */
+
+ } else {
+
+ if (*rank < *n) {
+ i__1 = *n;
+ for (j = *rank + 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ afac[i__ + j * afac_dim1] = 0.f;
+/* L130: */
+ }
+/* L140: */
+ }
+ }
+
+ for (k = *n; k >= 1; --k) {
+/* Add a multiple of column K of the factor L to each of */
+/* columns K+1 through N. */
+
+ if (k + 1 <= *n) {
+ i__1 = *n - k;
+ ssyr_("Lower", &i__1, &c_b18, &afac[k + 1 + k * afac_dim1], &
+ c__1, &afac[k + 1 + (k + 1) * afac_dim1], ldafac);
+ }
+
+/* Scale column K by the diagonal element. */
+
+ t = afac[k + k * afac_dim1];
+ i__1 = *n - k + 1;
+ sscal_(&i__1, &t, &afac[k + k * afac_dim1], &c__1);
+/* L150: */
+ }
+
+ }
+
+/* Form P*L*L'*P' or P*U'*U*P' */
+
+ if (lsame_(uplo, "U")) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (piv[i__] <= piv[j]) {
+ if (i__ <= j) {
+ perm[piv[i__] + piv[j] * perm_dim1] = afac[i__ + j *
+ afac_dim1];
+ } else {
+ perm[piv[i__] + piv[j] * perm_dim1] = afac[j + i__ *
+ afac_dim1];
+ }
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+
+
+ } else {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (piv[i__] >= piv[j]) {
+ if (i__ >= j) {
+ perm[piv[i__] + piv[j] * perm_dim1] = afac[i__ + j *
+ afac_dim1];
+ } else {
+ perm[piv[i__] + piv[j] * perm_dim1] = afac[j + i__ *
+ afac_dim1];
+ }
+ }
+/* L180: */
+ }
+/* L190: */
+ }
+
+ }
+
+/* Compute the difference P*L*L'*P' - A (or P*U'*U*P' - A). */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ perm[i__ + j * perm_dim1] -= a[i__ + j * a_dim1];
+/* L200: */
+ }
+/* L210: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ perm[i__ + j * perm_dim1] -= a[i__ + j * a_dim1];
+/* L220: */
+ }
+/* L230: */
+ }
+ }
+
+/* Compute norm( P*L*L'P - A ) / ( N * norm(A) * EPS ), or */
+/* ( P*U'*U*P' - A )/ ( N * norm(A) * EPS ). */
+
+ *resid = slansy_("1", uplo, n, &perm[perm_offset], ldafac, &rwork[1]);
+
+ *resid = *resid / (real) (*n) / anorm / eps;
+
+ return 0;
+
+/* End of SPST01 */
+
+} /* spst01_ */
diff --git a/TESTING/LIN/sptt01.c b/TESTING/LIN/sptt01.c
new file mode 100644
index 0000000..f04a8f4
--- /dev/null
+++ b/TESTING/LIN/sptt01.c
@@ -0,0 +1,155 @@
+/* sptt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int sptt01_(integer *n, real *d__, real *e, real *df, real *
+ ef, real *work, real *resid)
+{
+ /* System generated locals */
+ integer i__1;
+ real r__1, r__2, r__3, r__4, r__5;
+
+ /* Local variables */
+ integer i__;
+ real de, eps, anorm;
+ extern doublereal slamch_(char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPTT01 reconstructs a tridiagonal matrix A from its L*D*L' */
+/* factorization and computes the residual */
+/* norm(L*D*L' - A) / ( n * norm(A) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGTER */
+/* The order of the matrix A. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) REAL array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
+
+/* DF (input) REAL array, dimension (N) */
+/* The n diagonal elements of the factor L from the L*D*L' */
+/* factorization of A. */
+
+/* EF (input) REAL array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the factor L from the */
+/* L*D*L' factorization of A. */
+
+/* WORK (workspace) REAL array, dimension (2*N) */
+
+/* RESID (output) REAL */
+/* norm(L*D*L' - A) / (n * norm(A) * EPS) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --work;
+ --ef;
+ --df;
+ --e;
+ --d__;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+
+/* Construct the difference L*D*L' - A. */
+
+ work[1] = df[1] - d__[1];
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ de = df[i__] * ef[i__];
+ work[*n + i__] = de - e[i__];
+ work[i__ + 1] = de * ef[i__] + df[i__ + 1] - d__[i__ + 1];
+/* L10: */
+ }
+
+/* Compute the 1-norms of the tridiagonal matrices A and WORK. */
+
+ if (*n == 1) {
+ anorm = d__[1];
+ *resid = dabs(work[1]);
+ } else {
+/* Computing MAX */
+ r__2 = d__[1] + dabs(e[1]), r__3 = d__[*n] + (r__1 = e[*n - 1], dabs(
+ r__1));
+ anorm = dmax(r__2,r__3);
+/* Computing MAX */
+ r__4 = dabs(work[1]) + (r__1 = work[*n + 1], dabs(r__1)), r__5 = (
+ r__2 = work[*n], dabs(r__2)) + (r__3 = work[(*n << 1) - 1],
+ dabs(r__3));
+ *resid = dmax(r__4,r__5);
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__3 = anorm, r__4 = d__[i__] + (r__1 = e[i__], dabs(r__1)) + (
+ r__2 = e[i__ - 1], dabs(r__2));
+ anorm = dmax(r__3,r__4);
+/* Computing MAX */
+ r__4 = *resid, r__5 = (r__1 = work[i__], dabs(r__1)) + (r__2 =
+ work[*n + i__ - 1], dabs(r__2)) + (r__3 = work[*n + i__],
+ dabs(r__3));
+ *resid = dmax(r__4,r__5);
+/* L20: */
+ }
+ }
+
+/* Compute norm(L*D*L' - A) / (n * norm(A) * EPS) */
+
+ if (anorm <= 0.f) {
+ if (*resid != 0.f) {
+ *resid = 1.f / eps;
+ }
+ } else {
+ *resid = *resid / (real) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of SPTT01 */
+
+} /* sptt01_ */
diff --git a/TESTING/LIN/sptt02.c b/TESTING/LIN/sptt02.c
new file mode 100644
index 0000000..985f12e
--- /dev/null
+++ b/TESTING/LIN/sptt02.c
@@ -0,0 +1,160 @@
+/* sptt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b4 = -1.f;
+static real c_b5 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int sptt02_(integer *n, integer *nrhs, real *d__, real *e,
+ real *x, integer *ldx, real *b, integer *ldb, real *resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j;
+ real eps, anorm, bnorm;
+ extern doublereal sasum_(integer *, real *, integer *);
+ real xnorm;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int slaptm_(integer *, integer *, real *, real *,
+ real *, real *, integer *, real *, real *, integer *);
+ extern doublereal slanst_(char *, integer *, real *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPTT02 computes the residual for the solution to a symmetric */
+/* tridiagonal system of equations: */
+/* RESID = norm(B - A*X) / (norm(A) * norm(X) * EPS), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGTER */
+/* The order of the matrix A. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) REAL array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The n by nrhs matrix of solution vectors X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the n by nrhs matrix of right hand side vectors B. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RESID (output) REAL */
+/* norm(B - A*X) / (norm(A) * norm(X) * EPS) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Compute the 1-norm of the tridiagonal matrix A. */
+
+ anorm = slanst_("1", n, &d__[1], &e[1]);
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute B - A*X. */
+
+ slaptm_(n, nrhs, &c_b4, &d__[1], &e[1], &x[x_offset], ldx, &c_b5, &b[
+ b_offset], ldb);
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = sasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = sasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of SPTT02 */
+
+} /* sptt02_ */
diff --git a/TESTING/LIN/sptt05.c b/TESTING/LIN/sptt05.c
new file mode 100644
index 0000000..6bf7895
--- /dev/null
+++ b/TESTING/LIN/sptt05.c
@@ -0,0 +1,245 @@
+/* sptt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int sptt05_(integer *n, integer *nrhs, real *d__, real *e,
+ real *b, integer *ldb, real *x, integer *ldx, real *xact, integer *
+ ldxact, real *ferr, real *berr, real *reslts)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1,
+ i__2;
+ real r__1, r__2, r__3, r__4;
+
+ /* Local variables */
+ integer i__, j, k, nz;
+ real eps, tmp, diff, axbi;
+ integer imax;
+ real unfl, ovfl, xnorm;
+ extern doublereal slamch_(char *);
+ real errbnd;
+ extern integer isamax_(integer *, real *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SPTT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* symmetric tridiagonal matrix of order n. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+/* and NZ = max. number of nonzeros in any row of A, plus 1 */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* D (input) REAL array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) REAL array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) REAL array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) REAL array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) REAL array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.f;
+ reslts[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ nz = 4;
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = isamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ r__2 = (r__1 = x[imax + j * x_dim1], dabs(r__1));
+ xnorm = dmax(r__2,unfl);
+ diff = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = diff, r__3 = (r__1 = x[i__ + j * x_dim1] - xact[i__ + j *
+ xact_dim1], dabs(r__1));
+ diff = dmax(r__2,r__3);
+/* L10: */
+ }
+
+ if (xnorm > 1.f) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1.f / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
+ errbnd = dmax(r__1,r__2);
+ } else {
+ errbnd = 1.f / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ if (*n == 1) {
+ axbi = (r__1 = b[k * b_dim1 + 1], dabs(r__1)) + (r__2 = d__[1] *
+ x[k * x_dim1 + 1], dabs(r__2));
+ } else {
+ axbi = (r__1 = b[k * b_dim1 + 1], dabs(r__1)) + (r__2 = d__[1] *
+ x[k * x_dim1 + 1], dabs(r__2)) + (r__3 = e[1] * x[k *
+ x_dim1 + 2], dabs(r__3));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ tmp = (r__1 = b[i__ + k * b_dim1], dabs(r__1)) + (r__2 = e[
+ i__ - 1] * x[i__ - 1 + k * x_dim1], dabs(r__2)) + (
+ r__3 = d__[i__] * x[i__ + k * x_dim1], dabs(r__3)) + (
+ r__4 = e[i__] * x[i__ + 1 + k * x_dim1], dabs(r__4));
+ axbi = dmin(axbi,tmp);
+/* L40: */
+ }
+ tmp = (r__1 = b[*n + k * b_dim1], dabs(r__1)) + (r__2 = e[*n - 1]
+ * x[*n - 1 + k * x_dim1], dabs(r__2)) + (r__3 = d__[*n] *
+ x[*n + k * x_dim1], dabs(r__3));
+ axbi = dmin(axbi,tmp);
+ }
+/* Computing MAX */
+ r__1 = axbi, r__2 = nz * unfl;
+ tmp = berr[k] / (nz * eps + nz * unfl / dmax(r__1,r__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = dmax(reslts[2],tmp);
+ }
+/* L50: */
+ }
+
+ return 0;
+
+/* End of SPTT05 */
+
+} /* sptt05_ */
diff --git a/TESTING/LIN/sqlt01.c b/TESTING/LIN/sqlt01.c
new file mode 100644
index 0000000..124e325
--- /dev/null
+++ b/TESTING/LIN/sqlt01.c
@@ -0,0 +1,252 @@
+/* sqlt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static real c_b6 = -1e10f;
+static real c_b13 = 0.f;
+static real c_b20 = -1.f;
+static real c_b21 = 1.f;
+
+/* Subroutine */ int sqlt01_(integer *m, integer *n, real *a, real *af, real *
+ q, real *l, integer *lda, real *tau, real *work, integer *lwork, real
+ *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
+ q_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real eps;
+ integer info;
+ real resid;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm;
+ integer minmn;
+ extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *,
+ real *, real *, integer *, real *, real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int sgeqlf_(integer *, integer *, real *, integer
+ *, real *, real *, integer *, integer *), slacpy_(char *, integer
+ *, integer *, real *, integer *, real *, integer *),
+ slaset_(char *, integer *, integer *, real *, real *, real *,
+ integer *), sorgql_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SQLT01 tests SGEQLF, which computes the QL factorization of an m-by-n */
+/* matrix A, and partially tests SORGQL which forms the m-by-m */
+/* orthogonal matrix Q. */
+
+/* SQLT01 compares L with Q'*A, and checks that Q is orthogonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The m-by-n matrix A. */
+
+/* AF (output) REAL array, dimension (LDA,N) */
+/* Details of the QL factorization of A, as returned by SGEQLF. */
+/* See SGEQLF for further details. */
+
+/* Q (output) REAL array, dimension (LDA,M) */
+/* The m-by-m orthogonal matrix Q. */
+
+/* L (workspace) REAL array, dimension (LDA,max(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and R. */
+/* LDA >= max(M,N). */
+
+/* TAU (output) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by SGEQLF. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ l_dim1 = *lda;
+ l_offset = 1 + l_dim1;
+ l -= l_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ minmn = min(*m,*n);
+ eps = slamch_("Epsilon");
+
+/* Copy the matrix A to the array AF. */
+
+ slacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+
+/* Factorize the matrix A in the array AF. */
+
+ s_copy(srnamc_1.srnamt, "SGEQLF", (ftnlen)32, (ftnlen)6);
+ sgeqlf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy details of Q */
+
+ slaset_("Full", m, m, &c_b6, &c_b6, &q[q_offset], lda);
+ if (*m >= *n) {
+ if (*n < *m && *n > 0) {
+ i__1 = *m - *n;
+ slacpy_("Full", &i__1, n, &af[af_offset], lda, &q[(*m - *n + 1) *
+ q_dim1 + 1], lda);
+ }
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ slacpy_("Upper", &i__1, &i__2, &af[*m - *n + 1 + (af_dim1 << 1)],
+ lda, &q[*m - *n + 1 + (*m - *n + 2) * q_dim1], lda);
+ }
+ } else {
+ if (*m > 1) {
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ slacpy_("Upper", &i__1, &i__2, &af[(*n - *m + 2) * af_dim1 + 1],
+ lda, &q[(q_dim1 << 1) + 1], lda);
+ }
+ }
+
+/* Generate the m-by-m matrix Q */
+
+ s_copy(srnamc_1.srnamt, "SORGQL", (ftnlen)32, (ftnlen)6);
+ sorgql_(m, m, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy L */
+
+ slaset_("Full", m, n, &c_b13, &c_b13, &l[l_offset], lda);
+ if (*m >= *n) {
+ if (*n > 0) {
+ slacpy_("Lower", n, n, &af[*m - *n + 1 + af_dim1], lda, &l[*m - *
+ n + 1 + l_dim1], lda);
+ }
+ } else {
+ if (*n > *m && *m > 0) {
+ i__1 = *n - *m;
+ slacpy_("Full", m, &i__1, &af[af_offset], lda, &l[l_offset], lda);
+ }
+ if (*m > 0) {
+ slacpy_("Lower", m, m, &af[(*n - *m + 1) * af_dim1 + 1], lda, &l[(
+ *n - *m + 1) * l_dim1 + 1], lda);
+ }
+ }
+
+/* Compute L - Q'*A */
+
+ sgemm_("Transpose", "No transpose", m, n, m, &c_b20, &q[q_offset], lda, &
+ a[a_offset], lda, &c_b21, &l[l_offset], lda);
+
+/* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */
+
+ anorm = slange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ resid = slange_("1", m, n, &l[l_offset], lda, &rwork[1]);
+ if (anorm > 0.f) {
+ result[1] = resid / (real) max(1,*m) / anorm / eps;
+ } else {
+ result[1] = 0.f;
+ }
+
+/* Compute I - Q'*Q */
+
+ slaset_("Full", m, m, &c_b13, &c_b21, &l[l_offset], lda);
+ ssyrk_("Upper", "Transpose", m, m, &c_b20, &q[q_offset], lda, &c_b21, &l[
+ l_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
+
+ resid = slansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
+
+ result[2] = resid / (real) max(1,*m) / eps;
+
+ return 0;
+
+/* End of SQLT01 */
+
+} /* sqlt01_ */
diff --git a/TESTING/LIN/sqlt02.c b/TESTING/LIN/sqlt02.c
new file mode 100644
index 0000000..4831a25
--- /dev/null
+++ b/TESTING/LIN/sqlt02.c
@@ -0,0 +1,237 @@
+/* sqlt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static real c_b4 = -1e10f;
+static real c_b10 = 0.f;
+static real c_b15 = -1.f;
+static real c_b16 = 1.f;
+
+/* Subroutine */ int sqlt02_(integer *m, integer *n, integer *k, real *a,
+ real *af, real *q, real *l, integer *lda, real *tau, real *work,
+ integer *lwork, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
+ q_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real eps;
+ integer info;
+ real resid;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm;
+ extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *,
+ real *, real *, integer *, real *, real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *), sorgql_(
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, integer *, integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SQLT02 tests SORGQL, which generates an m-by-n matrix Q with */
+/* orthonornmal columns that is defined as the product of k elementary */
+/* reflectors. */
+
+/* Given the QL factorization of an m-by-n matrix A, SQLT02 generates */
+/* the orthogonal matrix Q defined by the factorization of the last k */
+/* columns of A; it compares L(m-n+1:m,n-k+1:n) with */
+/* Q(1:m,m-n+1:m)'*A(1:m,n-k+1:n), and checks that the columns of Q are */
+/* orthonormal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q to be generated. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q to be generated. */
+/* M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The m-by-n matrix A which was factorized by SQLT01. */
+
+/* AF (input) REAL array, dimension (LDA,N) */
+/* Details of the QL factorization of A, as returned by SGEQLF. */
+/* See SGEQLF for further details. */
+
+/* Q (workspace) REAL array, dimension (LDA,N) */
+
+/* L (workspace) REAL array, dimension (LDA,N) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and L. LDA >= M. */
+
+/* TAU (input) REAL array, dimension (N) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the QL factorization in AF. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ l_dim1 = *lda;
+ l_offset = 1 + l_dim1;
+ l -= l_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ if (*m == 0 || *n == 0 || *k == 0) {
+ result[1] = 0.f;
+ result[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+
+/* Copy the last k columns of the factorization to the array Q */
+
+ slaset_("Full", m, n, &c_b4, &c_b4, &q[q_offset], lda);
+ if (*k < *m) {
+ i__1 = *m - *k;
+ slacpy_("Full", &i__1, k, &af[(*n - *k + 1) * af_dim1 + 1], lda, &q[(*
+ n - *k + 1) * q_dim1 + 1], lda);
+ }
+ if (*k > 1) {
+ i__1 = *k - 1;
+ i__2 = *k - 1;
+ slacpy_("Upper", &i__1, &i__2, &af[*m - *k + 1 + (*n - *k + 2) *
+ af_dim1], lda, &q[*m - *k + 1 + (*n - *k + 2) * q_dim1], lda);
+ }
+
+/* Generate the last n columns of the matrix Q */
+
+ s_copy(srnamc_1.srnamt, "SORGQL", (ftnlen)32, (ftnlen)6);
+ sorgql_(m, n, k, &q[q_offset], lda, &tau[*n - *k + 1], &work[1], lwork, &
+ info);
+
+/* Copy L(m-n+1:m,n-k+1:n) */
+
+ slaset_("Full", n, k, &c_b10, &c_b10, &l[*m - *n + 1 + (*n - *k + 1) *
+ l_dim1], lda);
+ slacpy_("Lower", k, k, &af[*m - *k + 1 + (*n - *k + 1) * af_dim1], lda, &
+ l[*m - *k + 1 + (*n - *k + 1) * l_dim1], lda);
+
+/* Compute L(m-n+1:m,n-k+1:n) - Q(1:m,m-n+1:m)' * A(1:m,n-k+1:n) */
+
+ sgemm_("Transpose", "No transpose", n, k, m, &c_b15, &q[q_offset], lda, &
+ a[(*n - *k + 1) * a_dim1 + 1], lda, &c_b16, &l[*m - *n + 1 + (*n
+ - *k + 1) * l_dim1], lda);
+
+/* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */
+
+ anorm = slange_("1", m, k, &a[(*n - *k + 1) * a_dim1 + 1], lda, &rwork[1]);
+ resid = slange_("1", n, k, &l[*m - *n + 1 + (*n - *k + 1) * l_dim1], lda,
+ &rwork[1]);
+ if (anorm > 0.f) {
+ result[1] = resid / (real) max(1,*m) / anorm / eps;
+ } else {
+ result[1] = 0.f;
+ }
+
+/* Compute I - Q'*Q */
+
+ slaset_("Full", n, n, &c_b10, &c_b16, &l[l_offset], lda);
+ ssyrk_("Upper", "Transpose", n, m, &c_b15, &q[q_offset], lda, &c_b16, &l[
+ l_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
+
+ resid = slansy_("1", "Upper", n, &l[l_offset], lda, &rwork[1]);
+
+ result[2] = resid / (real) max(1,*m) / eps;
+
+ return 0;
+
+/* End of SQLT02 */
+
+} /* sqlt02_ */
diff --git a/TESTING/LIN/sqlt03.c b/TESTING/LIN/sqlt03.c
new file mode 100644
index 0000000..351b00e
--- /dev/null
+++ b/TESTING/LIN/sqlt03.c
@@ -0,0 +1,284 @@
+/* sqlt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static real c_b4 = -1e10f;
+static integer c__2 = 2;
+static real c_b22 = -1.f;
+static real c_b23 = 1.f;
+
+/* Subroutine */ int sqlt03_(integer *m, integer *n, integer *k, real *af,
+ real *c__, real *cc, real *q, integer *lda, real *tau, real *work,
+ integer *lwork, real *rwork, real *result)
+{
+ /* Initialized data */
+
+ static integer iseed[4] = { 1988,1989,1990,1991 };
+
+ /* System generated locals */
+ integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1,
+ q_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j, mc, nc;
+ real eps;
+ char side[1];
+ integer info, iside;
+ extern logical lsame_(char *, char *);
+ real resid;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ integer minmn;
+ real cnorm;
+ char trans[1];
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *);
+ integer itrans;
+ extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
+ *), sorgql_(integer *, integer *, integer *, real *, integer *,
+ real *, real *, integer *, integer *), sormql_(char *, char *,
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SQLT03 tests SORMQL, which computes Q*C, Q'*C, C*Q or C*Q'. */
+
+/* SQLT03 compares the results of a call to SORMQL with the results of */
+/* forming Q explicitly by a call to SORGQL and then performing matrix */
+/* multiplication by a call to SGEMM. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The order of the orthogonal matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of rows or columns of the matrix C; C is m-by-n if */
+/* Q is applied from the left, or n-by-m if Q is applied from */
+/* the right. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* orthogonal matrix Q. M >= K >= 0. */
+
+/* AF (input) REAL array, dimension (LDA,N) */
+/* Details of the QL factorization of an m-by-n matrix, as */
+/* returned by SGEQLF. See SGEQLF for further details. */
+
+/* C (workspace) REAL array, dimension (LDA,N) */
+
+/* CC (workspace) REAL array, dimension (LDA,N) */
+
+/* Q (workspace) REAL array, dimension (LDA,M) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays AF, C, CC, and Q. */
+
+/* TAU (input) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the QL factorization in AF. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK must be at least M, and should be */
+/* M*NB, where NB is the blocksize for this environment. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (4) */
+/* The test ratios compare two techniques for multiplying a */
+/* random matrix C by an m-by-m orthogonal matrix Q. */
+/* RESULT(1) = norm( Q*C - Q*C ) / ( M * norm(C) * EPS ) */
+/* RESULT(2) = norm( C*Q - C*Q ) / ( M * norm(C) * EPS ) */
+/* RESULT(3) = norm( Q'*C - Q'*C )/ ( M * norm(C) * EPS ) */
+/* RESULT(4) = norm( C*Q' - C*Q' )/ ( M * norm(C) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ cc_dim1 = *lda;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+ c_dim1 = *lda;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = slamch_("Epsilon");
+ minmn = min(*m,*n);
+
+/* Quick return if possible */
+
+ if (minmn == 0) {
+ result[1] = 0.f;
+ result[2] = 0.f;
+ result[3] = 0.f;
+ result[4] = 0.f;
+ return 0;
+ }
+
+/* Copy the last k columns of the factorization to the array Q */
+
+ slaset_("Full", m, m, &c_b4, &c_b4, &q[q_offset], lda);
+ if (*k > 0 && *m > *k) {
+ i__1 = *m - *k;
+ slacpy_("Full", &i__1, k, &af[(*n - *k + 1) * af_dim1 + 1], lda, &q[(*
+ m - *k + 1) * q_dim1 + 1], lda);
+ }
+ if (*k > 1) {
+ i__1 = *k - 1;
+ i__2 = *k - 1;
+ slacpy_("Upper", &i__1, &i__2, &af[*m - *k + 1 + (*n - *k + 2) *
+ af_dim1], lda, &q[*m - *k + 1 + (*m - *k + 2) * q_dim1], lda);
+ }
+
+/* Generate the m-by-m matrix Q */
+
+ s_copy(srnamc_1.srnamt, "SORGQL", (ftnlen)32, (ftnlen)6);
+ sorgql_(m, m, k, &q[q_offset], lda, &tau[minmn - *k + 1], &work[1], lwork,
+ &info);
+
+ for (iside = 1; iside <= 2; ++iside) {
+ if (iside == 1) {
+ *(unsigned char *)side = 'L';
+ mc = *m;
+ nc = *n;
+ } else {
+ *(unsigned char *)side = 'R';
+ mc = *n;
+ nc = *m;
+ }
+
+/* Generate MC by NC matrix C */
+
+ i__1 = nc;
+ for (j = 1; j <= i__1; ++j) {
+ slarnv_(&c__2, iseed, &mc, &c__[j * c_dim1 + 1]);
+/* L10: */
+ }
+ cnorm = slange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]);
+ if (cnorm == 0.f) {
+ cnorm = 1.f;
+ }
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+ if (itrans == 1) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'T';
+ }
+
+/* Copy C */
+
+ slacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
+ lda);
+
+/* Apply Q or Q' to C */
+
+ s_copy(srnamc_1.srnamt, "SORMQL", (ftnlen)32, (ftnlen)6);
+ if (*k > 0) {
+ sormql_(side, trans, &mc, &nc, k, &af[(*n - *k + 1) * af_dim1
+ + 1], lda, &tau[minmn - *k + 1], &cc[cc_offset], lda,
+ &work[1], lwork, &info);
+ }
+
+/* Form explicit product and subtract */
+
+ if (lsame_(side, "L")) {
+ sgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b22, &q[
+ q_offset], lda, &c__[c_offset], lda, &c_b23, &cc[
+ cc_offset], lda);
+ } else {
+ sgemm_("No transpose", trans, &mc, &nc, &nc, &c_b22, &c__[
+ c_offset], lda, &q[q_offset], lda, &c_b23, &cc[
+ cc_offset], lda);
+ }
+
+/* Compute error in the difference */
+
+ resid = slange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
+ result[(iside - 1 << 1) + itrans] = resid / ((real) max(1,*m) *
+ cnorm * eps);
+
+/* L20: */
+ }
+/* L30: */
+ }
+
+ return 0;
+
+/* End of SQLT03 */
+
+} /* sqlt03_ */
diff --git a/TESTING/LIN/sqpt01.c b/TESTING/LIN/sqpt01.c
new file mode 100644
index 0000000..56e27ef
--- /dev/null
+++ b/TESTING/LIN/sqpt01.c
@@ -0,0 +1,193 @@
+/* sqpt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__10 = 10;
+static integer c__1 = 1;
+static real c_b14 = -1.f;
+
+doublereal sqpt01_(integer *m, integer *n, integer *k, real *a, real *af,
+ integer *lda, real *tau, integer *jpvt, real *work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2;
+ real ret_val;
+
+ /* Local variables */
+ integer i__, j, info;
+ real norma;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ real rwork[1];
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), sormqr_(
+ char *, char *, integer *, integer *, integer *, real *, integer *
+, real *, real *, integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SQPT01 tests the QR-factorization with pivoting of a matrix A. The */
+/* array AF contains the (possibly partial) QR-factorization of A, where */
+/* the upper triangle of AF(1:k,1:k) is a partial triangular factor, */
+/* the entries below the diagonal in the first k columns are the */
+/* Householder vectors, and the rest of AF contains a partially updated */
+/* matrix. */
+
+/* This function returns ||A*P - Q*R||/(||norm(A)||*eps*M) */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices A and AF. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and AF. */
+
+/* K (input) INTEGER */
+/* The number of columns of AF that have been reduced */
+/* to upper triangular form. */
+
+/* A (input) REAL array, dimension (LDA, N) */
+/* The original matrix A. */
+
+/* AF (input) REAL array, dimension (LDA,N) */
+/* The (possibly partial) output of SGEQPF. The upper triangle */
+/* of AF(1:k,1:k) is a partial triangular factor, the entries */
+/* below the diagonal in the first k columns are the Householder */
+/* vectors, and the rest of AF contains a partially updated */
+/* matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A and AF. */
+
+/* TAU (input) REAL array, dimension (K) */
+/* Details of the Householder transformations as returned by */
+/* SGEQPF. */
+
+/* JPVT (input) INTEGER array, dimension (N) */
+/* Pivot information as returned by SGEQPF. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= M*N+N. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --jpvt;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+/* Test if there is enough workspace */
+
+ if (*lwork < *m * *n + *n) {
+ xerbla_("SQPT01", &c__10);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return ret_val;
+ }
+
+ norma = slange_("One-norm", m, n, &a[a_offset], lda, rwork);
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(j,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[(j - 1) * *m + i__] = af[i__ + j * af_dim1];
+/* L10: */
+ }
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ work[(j - 1) * *m + i__] = 0.f;
+/* L20: */
+ }
+/* L30: */
+ }
+ i__1 = *n;
+ for (j = *k + 1; j <= i__1; ++j) {
+ scopy_(m, &af[j * af_dim1 + 1], &c__1, &work[(j - 1) * *m + 1], &c__1)
+ ;
+/* L40: */
+ }
+
+ i__1 = *lwork - *m * *n;
+ sormqr_("Left", "No transpose", m, n, k, &af[af_offset], lda, &tau[1], &
+ work[1], m, &work[*m * *n + 1], &i__1, &info);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compare i-th column of QR and jpvt(i)-th column of A */
+
+ saxpy_(m, &c_b14, &a[jpvt[j] * a_dim1 + 1], &c__1, &work[(j - 1) * *m
+ + 1], &c__1);
+/* L50: */
+ }
+
+ ret_val = slange_("One-norm", m, n, &work[1], m, rwork) / ((
+ real) max(*m,*n) * slamch_("Epsilon"));
+ if (norma != 0.f) {
+ ret_val /= norma;
+ }
+
+ return ret_val;
+
+/* End of SQPT01 */
+
+} /* sqpt01_ */
diff --git a/TESTING/LIN/sqrt01.c b/TESTING/LIN/sqrt01.c
new file mode 100644
index 0000000..4e18e79
--- /dev/null
+++ b/TESTING/LIN/sqrt01.c
@@ -0,0 +1,221 @@
+/* sqrt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static real c_b6 = -1e10f;
+static real c_b11 = 0.f;
+static real c_b16 = -1.f;
+static real c_b17 = 1.f;
+
+/* Subroutine */ int sqrt01_(integer *m, integer *n, real *a, real *af, real *
+ q, real *r__, integer *lda, real *tau, real *work, integer *lwork,
+ real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
+ r_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real eps;
+ integer info;
+ real resid;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm;
+ integer minmn;
+ extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *,
+ real *, real *, integer *, real *, real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int sgeqrf_(integer *, integer *, real *, integer
+ *, real *, real *, integer *, integer *), slacpy_(char *, integer
+ *, integer *, real *, integer *, real *, integer *),
+ slaset_(char *, integer *, integer *, real *, real *, real *,
+ integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+ extern /* Subroutine */ int sorgqr_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SQRT01 tests SGEQRF, which computes the QR factorization of an m-by-n */
+/* matrix A, and partially tests SORGQR which forms the m-by-m */
+/* orthogonal matrix Q. */
+
+/* SQRT01 compares R with Q'*A, and checks that Q is orthogonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The m-by-n matrix A. */
+
+/* AF (output) REAL array, dimension (LDA,N) */
+/* Details of the QR factorization of A, as returned by SGEQRF. */
+/* See SGEQRF for further details. */
+
+/* Q (output) REAL array, dimension (LDA,M) */
+/* The m-by-m orthogonal matrix Q. */
+
+/* R (workspace) REAL array, dimension (LDA,max(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and R. */
+/* LDA >= max(M,N). */
+
+/* TAU (output) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by SGEQRF. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - Q'*A ) / ( M * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ minmn = min(*m,*n);
+ eps = slamch_("Epsilon");
+
+/* Copy the matrix A to the array AF. */
+
+ slacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+
+/* Factorize the matrix A in the array AF. */
+
+ s_copy(srnamc_1.srnamt, "SGEQRF", (ftnlen)32, (ftnlen)6);
+ sgeqrf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy details of Q */
+
+ slaset_("Full", m, m, &c_b6, &c_b6, &q[q_offset], lda);
+ i__1 = *m - 1;
+ slacpy_("Lower", &i__1, n, &af[af_dim1 + 2], lda, &q[q_dim1 + 2], lda);
+
+/* Generate the m-by-m matrix Q */
+
+ s_copy(srnamc_1.srnamt, "SORGQR", (ftnlen)32, (ftnlen)6);
+ sorgqr_(m, m, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy R */
+
+ slaset_("Full", m, n, &c_b11, &c_b11, &r__[r_offset], lda);
+ slacpy_("Upper", m, n, &af[af_offset], lda, &r__[r_offset], lda);
+
+/* Compute R - Q'*A */
+
+ sgemm_("Transpose", "No transpose", m, n, m, &c_b16, &q[q_offset], lda, &
+ a[a_offset], lda, &c_b17, &r__[r_offset], lda);
+
+/* Compute norm( R - Q'*A ) / ( M * norm(A) * EPS ) . */
+
+ anorm = slange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ resid = slange_("1", m, n, &r__[r_offset], lda, &rwork[1]);
+ if (anorm > 0.f) {
+ result[1] = resid / (real) max(1,*m) / anorm / eps;
+ } else {
+ result[1] = 0.f;
+ }
+
+/* Compute I - Q'*Q */
+
+ slaset_("Full", m, m, &c_b11, &c_b17, &r__[r_offset], lda);
+ ssyrk_("Upper", "Transpose", m, m, &c_b16, &q[q_offset], lda, &c_b17, &
+ r__[r_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
+
+ resid = slansy_("1", "Upper", m, &r__[r_offset], lda, &rwork[1]);
+
+ result[2] = resid / (real) max(1,*m) / eps;
+
+ return 0;
+
+/* End of SQRT01 */
+
+} /* sqrt01_ */
diff --git a/TESTING/LIN/sqrt02.c b/TESTING/LIN/sqrt02.c
new file mode 100644
index 0000000..02c0074
--- /dev/null
+++ b/TESTING/LIN/sqrt02.c
@@ -0,0 +1,214 @@
+/* sqrt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static real c_b4 = -1e10f;
+static real c_b9 = 0.f;
+static real c_b14 = -1.f;
+static real c_b15 = 1.f;
+
+/* Subroutine */ int sqrt02_(integer *m, integer *n, integer *k, real *a,
+ real *af, real *q, real *r__, integer *lda, real *tau, real *work,
+ integer *lwork, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
+ r_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real eps;
+ integer info;
+ real resid;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm;
+ extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *,
+ real *, real *, integer *, real *, real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+ extern /* Subroutine */ int sorgqr_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SQRT02 tests SORGQR, which generates an m-by-n matrix Q with */
+/* orthonornmal columns that is defined as the product of k elementary */
+/* reflectors. */
+
+/* Given the QR factorization of an m-by-n matrix A, SQRT02 generates */
+/* the orthogonal matrix Q defined by the factorization of the first k */
+/* columns of A; it compares R(1:n,1:k) with Q(1:m,1:n)'*A(1:m,1:k), */
+/* and checks that the columns of Q are orthonormal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q to be generated. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q to be generated. */
+/* M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The m-by-n matrix A which was factorized by SQRT01. */
+
+/* AF (input) REAL array, dimension (LDA,N) */
+/* Details of the QR factorization of A, as returned by SGEQRF. */
+/* See SGEQRF for further details. */
+
+/* Q (workspace) REAL array, dimension (LDA,N) */
+
+/* R (workspace) REAL array, dimension (LDA,N) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and R. LDA >= M. */
+
+/* TAU (input) REAL array, dimension (N) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the QR factorization in AF. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - Q'*A ) / ( M * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ eps = slamch_("Epsilon");
+
+/* Copy the first k columns of the factorization to the array Q */
+
+ slaset_("Full", m, n, &c_b4, &c_b4, &q[q_offset], lda);
+ i__1 = *m - 1;
+ slacpy_("Lower", &i__1, k, &af[af_dim1 + 2], lda, &q[q_dim1 + 2], lda);
+
+/* Generate the first n columns of the matrix Q */
+
+ s_copy(srnamc_1.srnamt, "SORGQR", (ftnlen)32, (ftnlen)6);
+ sorgqr_(m, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy R(1:n,1:k) */
+
+ slaset_("Full", n, k, &c_b9, &c_b9, &r__[r_offset], lda);
+ slacpy_("Upper", n, k, &af[af_offset], lda, &r__[r_offset], lda);
+
+/* Compute R(1:n,1:k) - Q(1:m,1:n)' * A(1:m,1:k) */
+
+ sgemm_("Transpose", "No transpose", n, k, m, &c_b14, &q[q_offset], lda, &
+ a[a_offset], lda, &c_b15, &r__[r_offset], lda);
+
+/* Compute norm( R - Q'*A ) / ( M * norm(A) * EPS ) . */
+
+ anorm = slange_("1", m, k, &a[a_offset], lda, &rwork[1]);
+ resid = slange_("1", n, k, &r__[r_offset], lda, &rwork[1]);
+ if (anorm > 0.f) {
+ result[1] = resid / (real) max(1,*m) / anorm / eps;
+ } else {
+ result[1] = 0.f;
+ }
+
+/* Compute I - Q'*Q */
+
+ slaset_("Full", n, n, &c_b9, &c_b15, &r__[r_offset], lda);
+ ssyrk_("Upper", "Transpose", n, m, &c_b14, &q[q_offset], lda, &c_b15, &
+ r__[r_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
+
+ resid = slansy_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
+
+ result[2] = resid / (real) max(1,*m) / eps;
+
+ return 0;
+
+/* End of SQRT02 */
+
+} /* sqrt02_ */
diff --git a/TESTING/LIN/sqrt03.c b/TESTING/LIN/sqrt03.c
new file mode 100644
index 0000000..14b9aa7
--- /dev/null
+++ b/TESTING/LIN/sqrt03.c
@@ -0,0 +1,259 @@
+/* sqrt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static real c_b4 = -1e10f;
+static integer c__2 = 2;
+static real c_b21 = -1.f;
+static real c_b22 = 1.f;
+
+/* Subroutine */ int sqrt03_(integer *m, integer *n, integer *k, real *af,
+ real *c__, real *cc, real *q, integer *lda, real *tau, real *work,
+ integer *lwork, real *rwork, real *result)
+{
+ /* Initialized data */
+
+ static integer iseed[4] = { 1988,1989,1990,1991 };
+
+ /* System generated locals */
+ integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1,
+ q_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j, mc, nc;
+ real eps;
+ char side[1];
+ integer info, iside;
+ extern logical lsame_(char *, char *);
+ real resid;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real cnorm;
+ char trans[1];
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *);
+ integer itrans;
+ extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
+ *), sorgqr_(integer *, integer *, integer *, real *, integer *,
+ real *, real *, integer *, integer *), sormqr_(char *, char *,
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SQRT03 tests SORMQR, which computes Q*C, Q'*C, C*Q or C*Q'. */
+
+/* SQRT03 compares the results of a call to SORMQR with the results of */
+/* forming Q explicitly by a call to SORGQR and then performing matrix */
+/* multiplication by a call to SGEMM. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The order of the orthogonal matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of rows or columns of the matrix C; C is m-by-n if */
+/* Q is applied from the left, or n-by-m if Q is applied from */
+/* the right. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* orthogonal matrix Q. M >= K >= 0. */
+
+/* AF (input) REAL array, dimension (LDA,N) */
+/* Details of the QR factorization of an m-by-n matrix, as */
+/* returnedby SGEQRF. See SGEQRF for further details. */
+
+/* C (workspace) REAL array, dimension (LDA,N) */
+
+/* CC (workspace) REAL array, dimension (LDA,N) */
+
+/* Q (workspace) REAL array, dimension (LDA,M) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays AF, C, CC, and Q. */
+
+/* TAU (input) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the QR factorization in AF. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK must be at least M, and should be */
+/* M*NB, where NB is the blocksize for this environment. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (4) */
+/* The test ratios compare two techniques for multiplying a */
+/* random matrix C by an m-by-m orthogonal matrix Q. */
+/* RESULT(1) = norm( Q*C - Q*C ) / ( M * norm(C) * EPS ) */
+/* RESULT(2) = norm( C*Q - C*Q ) / ( M * norm(C) * EPS ) */
+/* RESULT(3) = norm( Q'*C - Q'*C )/ ( M * norm(C) * EPS ) */
+/* RESULT(4) = norm( C*Q' - C*Q' )/ ( M * norm(C) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ cc_dim1 = *lda;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+ c_dim1 = *lda;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = slamch_("Epsilon");
+
+/* Copy the first k columns of the factorization to the array Q */
+
+ slaset_("Full", m, m, &c_b4, &c_b4, &q[q_offset], lda);
+ i__1 = *m - 1;
+ slacpy_("Lower", &i__1, k, &af[af_dim1 + 2], lda, &q[q_dim1 + 2], lda);
+
+/* Generate the m-by-m matrix Q */
+
+ s_copy(srnamc_1.srnamt, "SORGQR", (ftnlen)32, (ftnlen)6);
+ sorgqr_(m, m, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+ for (iside = 1; iside <= 2; ++iside) {
+ if (iside == 1) {
+ *(unsigned char *)side = 'L';
+ mc = *m;
+ nc = *n;
+ } else {
+ *(unsigned char *)side = 'R';
+ mc = *n;
+ nc = *m;
+ }
+
+/* Generate MC by NC matrix C */
+
+ i__1 = nc;
+ for (j = 1; j <= i__1; ++j) {
+ slarnv_(&c__2, iseed, &mc, &c__[j * c_dim1 + 1]);
+/* L10: */
+ }
+ cnorm = slange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]);
+ if (cnorm == 0.f) {
+ cnorm = 1.f;
+ }
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+ if (itrans == 1) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'T';
+ }
+
+/* Copy C */
+
+ slacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
+ lda);
+
+/* Apply Q or Q' to C */
+
+ s_copy(srnamc_1.srnamt, "SORMQR", (ftnlen)32, (ftnlen)6);
+ sormqr_(side, trans, &mc, &nc, k, &af[af_offset], lda, &tau[1], &
+ cc[cc_offset], lda, &work[1], lwork, &info);
+
+/* Form explicit product and subtract */
+
+ if (lsame_(side, "L")) {
+ sgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b21, &q[
+ q_offset], lda, &c__[c_offset], lda, &c_b22, &cc[
+ cc_offset], lda);
+ } else {
+ sgemm_("No transpose", trans, &mc, &nc, &nc, &c_b21, &c__[
+ c_offset], lda, &q[q_offset], lda, &c_b22, &cc[
+ cc_offset], lda);
+ }
+
+/* Compute error in the difference */
+
+ resid = slange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
+ result[(iside - 1 << 1) + itrans] = resid / ((real) max(1,*m) *
+ cnorm * eps);
+
+/* L20: */
+ }
+/* L30: */
+ }
+
+ return 0;
+
+/* End of SQRT03 */
+
+} /* sqrt03_ */
diff --git a/TESTING/LIN/sqrt11.c b/TESTING/LIN/sqrt11.c
new file mode 100644
index 0000000..6c56c0a
--- /dev/null
+++ b/TESTING/LIN/sqrt11.c
@@ -0,0 +1,155 @@
+/* sqrt11.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__7 = 7;
+static real c_b5 = 0.f;
+static real c_b6 = 1.f;
+
+doublereal sqrt11_(integer *m, integer *k, real *a, integer *lda, real *tau,
+ real *work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ real ret_val;
+
+ /* Local variables */
+ integer j, info;
+ extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), slaset_(
+ char *, integer *, integer *, real *, real *, real *, integer *);
+ real rdummy[1];
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SQRT11 computes the test ratio */
+
+/* || Q'*Q - I || / (eps * m) */
+
+/* where the orthogonal matrix Q is represented as a product of */
+/* elementary transformations. Each transformation has the form */
+
+/* H(k) = I - tau(k) v(k) v(k)' */
+
+/* where tau(k) is stored in TAU(k) and v(k) is an m-vector of the form */
+/* [ 0 ... 0 1 x(k) ]', where x(k) is a vector of length m-k stored */
+/* in A(k+1:m,k). */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* K (input) INTEGER */
+/* The number of columns of A whose subdiagonal entries */
+/* contain information about orthogonal transformations. */
+
+/* A (input) REAL array, dimension (LDA,K) */
+/* The (possibly partial) output of a QR reduction routine. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* TAU (input) REAL array, dimension (K) */
+/* The scaling factors tau for the elementary transformations as */
+/* computed by the QR factorization routine. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= M*M + M. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+/* Test for sufficient workspace */
+
+ if (*lwork < *m * *m + *m) {
+ xerbla_("SQRT11", &c__7);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0) {
+ return ret_val;
+ }
+
+ slaset_("Full", m, m, &c_b5, &c_b6, &work[1], m);
+
+/* Form Q */
+
+ sorm2r_("Left", "No transpose", m, m, k, &a[a_offset], lda, &tau[1], &
+ work[1], m, &work[*m * *m + 1], &info);
+
+/* Form Q'*Q */
+
+ sorm2r_("Left", "Transpose", m, m, k, &a[a_offset], lda, &tau[1], &work[1]
+, m, &work[*m * *m + 1], &info);
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ work[(j - 1) * *m + j] += -1.f;
+/* L10: */
+ }
+
+ ret_val = slange_("One-norm", m, m, &work[1], m, rdummy) / ((
+ real) (*m) * slamch_("Epsilon"));
+
+ return ret_val;
+
+/* End of SQRT11 */
+
+} /* sqrt11_ */
diff --git a/TESTING/LIN/sqrt12.c b/TESTING/LIN/sqrt12.c
new file mode 100644
index 0000000..4e8b756
--- /dev/null
+++ b/TESTING/LIN/sqrt12.c
@@ -0,0 +1,219 @@
+/* sqrt12.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__7 = 7;
+static integer c__1 = 1;
+static real c_b6 = 0.f;
+static integer c__0 = 0;
+static real c_b33 = -1.f;
+
+doublereal sqrt12_(integer *m, integer *n, real *a, integer *lda, real *s,
+ real *work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real ret_val;
+
+ /* Local variables */
+ integer i__, j, mn, iscl, info;
+ real anrm;
+ extern doublereal snrm2_(integer *, real *, integer *), sasum_(integer *,
+ real *, integer *);
+ real dummy[1];
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *), sgebd2_(integer *, integer *, real *, integer
+ *, real *, real *, real *, real *, real *, integer *), slabad_(
+ real *, real *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *), slaset_(char *, integer *, integer *, real *, real *,
+ real *, integer *), sbdsqr_(char *, integer *, integer *,
+ integer *, integer *, real *, real *, real *, integer *, real *,
+ integer *, real *, integer *, real *, integer *);
+ real smlnum, nrmsvl;
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SQRT12 computes the singular values `svlues' of the upper trapezoid */
+/* of A(1:M,1:N) and returns the ratio */
+
+/* || s - svlues||/(||svlues||*eps*max(M,N)) */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The M-by-N matrix A. Only the upper trapezoid is referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* S (input) REAL array, dimension (min(M,N)) */
+/* The singular values of the matrix A. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= max(M*N + 4*min(M,N) + */
+/* max(M,N), M*N+2*MIN( M, N )+4*N). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+/* Test that enough workspace is supplied */
+
+/* Computing MAX */
+ i__1 = *m * *n + (min(*m,*n) << 2) + max(*m,*n), i__2 = *m * *n + (min(*m,
+ *n) << 1) + (*n << 2);
+ if (*lwork < max(i__1,i__2)) {
+ xerbla_("SQRT12", &c__7);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ mn = min(*m,*n);
+ if ((real) mn <= 0.f) {
+ return ret_val;
+ }
+
+ nrmsvl = snrm2_(&mn, &s[1], &c__1);
+
+/* Copy upper triangle of A into work */
+
+ slaset_("Full", m, n, &c_b6, &c_b6, &work[1], m);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(j,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[(j - 1) * *m + i__] = a[i__ + j * a_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Get machine parameters */
+
+ smlnum = slamch_("S") / slamch_("P");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Scale work if max entry outside range [SMLNUM,BIGNUM] */
+
+ anrm = slange_("M", m, n, &work[1], m, dummy);
+ iscl = 0;
+ if (anrm > 0.f && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ slascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &work[1], m, &info);
+ iscl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ slascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &work[1], m, &info);
+ iscl = 1;
+ }
+
+ if (anrm != 0.f) {
+
+/* Compute SVD of work */
+
+ sgebd2_(m, n, &work[1], m, &work[*m * *n + 1], &work[*m * *n + mn + 1]
+, &work[*m * *n + (mn << 1) + 1], &work[*m * *n + mn * 3 + 1],
+ &work[*m * *n + (mn << 2) + 1], &info);
+ sbdsqr_("Upper", &mn, &c__0, &c__0, &c__0, &work[*m * *n + 1], &work[*
+ m * *n + mn + 1], dummy, &mn, dummy, &c__1, dummy, &mn, &work[
+ *m * *n + (mn << 1) + 1], &info);
+
+ if (iscl == 1) {
+ if (anrm > bignum) {
+ slascl_("G", &c__0, &c__0, &bignum, &anrm, &mn, &c__1, &work[*
+ m * *n + 1], &mn, &info);
+ }
+ if (anrm < smlnum) {
+ slascl_("G", &c__0, &c__0, &smlnum, &anrm, &mn, &c__1, &work[*
+ m * *n + 1], &mn, &info);
+ }
+ }
+
+ } else {
+
+ i__1 = mn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[*m * *n + i__] = 0.f;
+/* L30: */
+ }
+ }
+
+/* Compare s and singular values of work */
+
+ saxpy_(&mn, &c_b33, &s[1], &c__1, &work[*m * *n + 1], &c__1);
+ ret_val = sasum_(&mn, &work[*m * *n + 1], &c__1) / (slamch_("Epsilon") * (real) max(*m,*n));
+ if (nrmsvl != 0.f) {
+ ret_val /= nrmsvl;
+ }
+
+ return ret_val;
+
+/* End of SQRT12 */
+
+} /* sqrt12_ */
diff --git a/TESTING/LIN/sqrt13.c b/TESTING/LIN/sqrt13.c
new file mode 100644
index 0000000..cab25c9
--- /dev/null
+++ b/TESTING/LIN/sqrt13.c
@@ -0,0 +1,155 @@
+/* sqrt13.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c__0 = 0;
+
+/* Subroutine */ int sqrt13_(integer *scale, integer *m, integer *n, real *a,
+ integer *lda, real *norma, integer *iseed)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ real r__1;
+
+ /* Builtin functions */
+ double r_sign(real *, real *);
+
+ /* Local variables */
+ integer j, info;
+ extern doublereal sasum_(integer *, real *, integer *);
+ real dummy[1];
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ real bignum;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *), slarnv_(integer *, integer *, integer *, real *);
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SQRT13 generates a full-rank matrix that may be scaled to have large */
+/* or small norm. */
+
+/* Arguments */
+/* ========= */
+
+/* SCALE (input) INTEGER */
+/* SCALE = 1: normally scaled matrix */
+/* SCALE = 2: matrix scaled up */
+/* SCALE = 3: matrix scaled down */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of A. */
+
+/* A (output) REAL array, dimension (LDA,N) */
+/* The M-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* NORMA (output) REAL */
+/* The one-norm of A. */
+
+/* ISEED (input/output) integer array, dimension (4) */
+/* Seed for random number generator */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iseed;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+/* benign matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ slarnv_(&c__2, &iseed[1], m, &a[j * a_dim1 + 1]);
+ if (j <= *m) {
+ r__1 = sasum_(m, &a[j * a_dim1 + 1], &c__1);
+ a[j + j * a_dim1] += r_sign(&r__1, &a[j + j * a_dim1]);
+ }
+/* L10: */
+ }
+
+/* scaled versions */
+
+ if (*scale != 1) {
+ *norma = slange_("Max", m, n, &a[a_offset], lda, dummy);
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ smlnum /= slamch_("Epsilon");
+ bignum = 1.f / smlnum;
+
+ if (*scale == 2) {
+
+/* matrix scaled up */
+
+ slascl_("General", &c__0, &c__0, norma, &bignum, m, n, &a[
+ a_offset], lda, &info);
+ } else if (*scale == 3) {
+
+/* matrix scaled down */
+
+ slascl_("General", &c__0, &c__0, norma, &smlnum, m, n, &a[
+ a_offset], lda, &info);
+ }
+ }
+
+ *norma = slange_("One-norm", m, n, &a[a_offset], lda, dummy);
+ return 0;
+
+/* End of SQRT13 */
+
+} /* sqrt13_ */
diff --git a/TESTING/LIN/sqrt14.c b/TESTING/LIN/sqrt14.c
new file mode 100644
index 0000000..5cc1d2d
--- /dev/null
+++ b/TESTING/LIN/sqrt14.c
@@ -0,0 +1,260 @@
+/* sqrt14.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__10 = 10;
+static integer c__1 = 1;
+static integer c__0 = 0;
+static real c_b15 = 1.f;
+
+doublereal sqrt14_(char *trans, integer *m, integer *n, integer *nrhs, real *
+ a, integer *lda, real *x, integer *ldx, real *work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, x_dim1, x_offset, i__1, i__2, i__3;
+ real ret_val, r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j;
+ real err;
+ integer info;
+ real anrm;
+ logical tpsd;
+ real xnrm;
+ extern logical lsame_(char *, char *);
+ real rwork[1];
+ extern /* Subroutine */ int sgelq2_(integer *, integer *, real *, integer
+ *, real *, real *, integer *), sgeqr2_(integer *, integer *, real
+ *, integer *, real *, real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), slascl_(
+ char *, integer *, integer *, real *, real *, integer *, integer *
+, real *, integer *, integer *), slacpy_(char *, integer *
+, integer *, real *, integer *, real *, integer *);
+ integer ldwork;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SQRT14 checks whether X is in the row space of A or A'. It does so */
+/* by scaling both X and A such that their norms are in the range */
+/* [sqrt(eps), 1/sqrt(eps)], then computing a QR factorization of [A,X] */
+/* (if TRANS = 'T') or an LQ factorization of [A',X]' (if TRANS = 'N'), */
+/* and returning the norm of the trailing triangle, scaled by */
+/* MAX(M,N,NRHS)*eps. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, check for X in the row space of A */
+/* = 'T': Transpose, check for X in the row space of A'. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of X. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The M-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* If TRANS = 'N', the N-by-NRHS matrix X. */
+/* IF TRANS = 'T', the M-by-NRHS matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. */
+
+/* WORK (workspace) REAL array dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* length of workspace array required */
+/* If TRANS = 'N', LWORK >= (M+NRHS)*(N+2); */
+/* if TRANS = 'T', LWORK >= (N+NRHS)*(M+2). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.f;
+ if (lsame_(trans, "N")) {
+ ldwork = *m + *nrhs;
+ tpsd = FALSE_;
+ if (*lwork < (*m + *nrhs) * (*n + 2)) {
+ xerbla_("SQRT14", &c__10);
+ return ret_val;
+ } else if (*n <= 0 || *nrhs <= 0) {
+ return ret_val;
+ }
+ } else if (lsame_(trans, "T")) {
+ ldwork = *m;
+ tpsd = TRUE_;
+ if (*lwork < (*n + *nrhs) * (*m + 2)) {
+ xerbla_("SQRT14", &c__10);
+ return ret_val;
+ } else if (*m <= 0 || *nrhs <= 0) {
+ return ret_val;
+ }
+ } else {
+ xerbla_("SQRT14", &c__1);
+ return ret_val;
+ }
+
+/* Copy and scale A */
+
+ slacpy_("All", m, n, &a[a_offset], lda, &work[1], &ldwork);
+ anrm = slange_("M", m, n, &work[1], &ldwork, rwork);
+ if (anrm != 0.f) {
+ slascl_("G", &c__0, &c__0, &anrm, &c_b15, m, n, &work[1], &ldwork, &
+ info);
+ }
+
+/* Copy X or X' into the right place and scale it */
+
+ if (tpsd) {
+
+/* Copy X into columns n+1:n+nrhs of work */
+
+ slacpy_("All", m, nrhs, &x[x_offset], ldx, &work[*n * ldwork + 1], &
+ ldwork);
+ xnrm = slange_("M", m, nrhs, &work[*n * ldwork + 1], &ldwork, rwork);
+ if (xnrm != 0.f) {
+ slascl_("G", &c__0, &c__0, &xnrm, &c_b15, m, nrhs, &work[*n *
+ ldwork + 1], &ldwork, &info);
+ }
+ i__1 = *n + *nrhs;
+ anrm = slange_("One-norm", m, &i__1, &work[1], &ldwork, rwork);
+
+/* Compute QR factorization of X */
+
+ i__1 = *n + *nrhs;
+/* Computing MIN */
+ i__2 = *m, i__3 = *n + *nrhs;
+ sgeqr2_(m, &i__1, &work[1], &ldwork, &work[ldwork * (*n + *nrhs) + 1],
+ &work[ldwork * (*n + *nrhs) + min(i__2, i__3)+ 1], &info);
+
+/* Compute largest entry in upper triangle of */
+/* work(n+1:m,n+1:n+nrhs) */
+
+ err = 0.f;
+ i__1 = *n + *nrhs;
+ for (j = *n + 1; j <= i__1; ++j) {
+ i__2 = min(*m,j);
+ for (i__ = *n + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = err, r__3 = (r__1 = work[i__ + (j - 1) * *m], dabs(
+ r__1));
+ err = dmax(r__2,r__3);
+/* L10: */
+ }
+/* L20: */
+ }
+
+ } else {
+
+/* Copy X' into rows m+1:m+nrhs of work */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *nrhs;
+ for (j = 1; j <= i__2; ++j) {
+ work[*m + j + (i__ - 1) * ldwork] = x[i__ + j * x_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+
+ xnrm = slange_("M", nrhs, n, &work[*m + 1], &ldwork, rwork)
+ ;
+ if (xnrm != 0.f) {
+ slascl_("G", &c__0, &c__0, &xnrm, &c_b15, nrhs, n, &work[*m + 1],
+ &ldwork, &info);
+ }
+
+/* Compute LQ factorization of work */
+
+ sgelq2_(&ldwork, n, &work[1], &ldwork, &work[ldwork * *n + 1], &work[
+ ldwork * (*n + 1) + 1], &info);
+
+/* Compute largest entry in lower triangle in */
+/* work(m+1:m+nrhs,m+1:n) */
+
+ err = 0.f;
+ i__1 = *n;
+ for (j = *m + 1; j <= i__1; ++j) {
+ i__2 = ldwork;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = err, r__3 = (r__1 = work[i__ + (j - 1) * ldwork], dabs(
+ r__1));
+ err = dmax(r__2,r__3);
+/* L50: */
+ }
+/* L60: */
+ }
+
+ }
+
+/* Computing MAX */
+ i__1 = max(*m,*n);
+ ret_val = err / ((real) max(i__1,*nrhs) * slamch_("Epsilon"));
+
+ return ret_val;
+
+/* End of SQRT14 */
+
+} /* sqrt14_ */
diff --git a/TESTING/LIN/sqrt15.c b/TESTING/LIN/sqrt15.c
new file mode 100644
index 0000000..a521798
--- /dev/null
+++ b/TESTING/LIN/sqrt15.c
@@ -0,0 +1,299 @@
+/* sqrt15.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__16 = 16;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static real c_b18 = 0.f;
+static real c_b19 = 1.f;
+static real c_b22 = 2.f;
+static integer c__0 = 0;
+
+/* Subroutine */ int sqrt15_(integer *scale, integer *rksel, integer *m,
+ integer *n, integer *nrhs, real *a, integer *lda, real *b, integer *
+ ldb, real *s, integer *rank, real *norma, real *normb, integer *iseed,
+ real *work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+ real r__1;
+
+ /* Local variables */
+ integer j, mn;
+ real eps;
+ integer info;
+ real temp;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ slarf_(char *, integer *, integer *, real *, integer *, real *,
+ real *, integer *, real *), sgemm_(char *, char *,
+ integer *, integer *, integer *, real *, real *, integer *, real *
+, integer *, real *, real *, integer *);
+ extern doublereal sasum_(integer *, real *, integer *);
+ real dummy[1];
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *);
+ extern doublereal slarnd_(integer *, integer *);
+ extern /* Subroutine */ int slaord_(char *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *,
+ real *, integer *), slaror_(char *, char *, integer *,
+ integer *, real *, integer *, integer *, real *, integer *), slarnv_(integer *, integer *, integer *, real *);
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SQRT15 generates a matrix with full or deficient rank and of various */
+/* norms. */
+
+/* Arguments */
+/* ========= */
+
+/* SCALE (input) INTEGER */
+/* SCALE = 1: normally scaled matrix */
+/* SCALE = 2: matrix scaled up */
+/* SCALE = 3: matrix scaled down */
+
+/* RKSEL (input) INTEGER */
+/* RKSEL = 1: full rank matrix */
+/* RKSEL = 2: rank-deficient matrix */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of A. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. */
+
+/* A (output) REAL array, dimension (LDA,N) */
+/* The M-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* B (output) REAL array, dimension (LDB, NRHS) */
+/* A matrix that is in the range space of matrix A. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. */
+
+/* S (output) REAL array, dimension MIN(M,N) */
+/* Singular values of A. */
+
+/* RANK (output) INTEGER */
+/* number of nonzero singular values of A. */
+
+/* NORMA (output) REAL */
+/* one-norm of A. */
+
+/* NORMB (output) REAL */
+/* one-norm of B. */
+
+/* ISEED (input/output) integer array, dimension (4) */
+/* seed for random number generator. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* length of work space required. */
+/* LWORK >= MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --s;
+ --iseed;
+ --work;
+
+ /* Function Body */
+ mn = min(*m,*n);
+/* Computing MAX */
+ i__1 = *m + mn, i__2 = mn * *nrhs, i__1 = max(i__1,i__2), i__2 = (*n << 1)
+ + *m;
+ if (*lwork < max(i__1,i__2)) {
+ xerbla_("SQRT15", &c__16);
+ return 0;
+ }
+
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ eps = slamch_("Epsilon");
+ smlnum = smlnum / eps / eps;
+ bignum = 1.f / smlnum;
+
+/* Determine rank and (unscaled) singular values */
+
+ if (*rksel == 1) {
+ *rank = mn;
+ } else if (*rksel == 2) {
+ *rank = mn * 3 / 4;
+ i__1 = mn;
+ for (j = *rank + 1; j <= i__1; ++j) {
+ s[j] = 0.f;
+/* L10: */
+ }
+ } else {
+ xerbla_("SQRT15", &c__2);
+ }
+
+ if (*rank > 0) {
+
+/* Nontrivial case */
+
+ s[1] = 1.f;
+ i__1 = *rank;
+ for (j = 2; j <= i__1; ++j) {
+L20:
+ temp = slarnd_(&c__1, &iseed[1]);
+ if (temp > .1f) {
+ s[j] = dabs(temp);
+ } else {
+ goto L20;
+ }
+/* L30: */
+ }
+ slaord_("Decreasing", rank, &s[1], &c__1);
+
+/* Generate 'rank' columns of a random orthogonal matrix in A */
+
+ slarnv_(&c__2, &iseed[1], m, &work[1]);
+ r__1 = 1.f / snrm2_(m, &work[1], &c__1);
+ sscal_(m, &r__1, &work[1], &c__1);
+ slaset_("Full", m, rank, &c_b18, &c_b19, &a[a_offset], lda)
+ ;
+ slarf_("Left", m, rank, &work[1], &c__1, &c_b22, &a[a_offset], lda, &
+ work[*m + 1]);
+
+/* workspace used: m+mn */
+
+/* Generate consistent rhs in the range space of A */
+
+ i__1 = *rank * *nrhs;
+ slarnv_(&c__2, &iseed[1], &i__1, &work[1]);
+ sgemm_("No transpose", "No transpose", m, nrhs, rank, &c_b19, &a[
+ a_offset], lda, &work[1], rank, &c_b18, &b[b_offset], ldb);
+
+/* work space used: <= mn *nrhs */
+
+/* generate (unscaled) matrix A */
+
+ i__1 = *rank;
+ for (j = 1; j <= i__1; ++j) {
+ sscal_(m, &s[j], &a[j * a_dim1 + 1], &c__1);
+/* L40: */
+ }
+ if (*rank < *n) {
+ i__1 = *n - *rank;
+ slaset_("Full", m, &i__1, &c_b18, &c_b18, &a[(*rank + 1) * a_dim1
+ + 1], lda);
+ }
+ slaror_("Right", "No initialization", m, n, &a[a_offset], lda, &iseed[
+ 1], &work[1], &info);
+
+ } else {
+
+/* work space used 2*n+m */
+
+/* Generate null matrix and rhs */
+
+ i__1 = mn;
+ for (j = 1; j <= i__1; ++j) {
+ s[j] = 0.f;
+/* L50: */
+ }
+ slaset_("Full", m, n, &c_b18, &c_b18, &a[a_offset], lda);
+ slaset_("Full", m, nrhs, &c_b18, &c_b18, &b[b_offset], ldb)
+ ;
+
+ }
+
+/* Scale the matrix */
+
+ if (*scale != 1) {
+ *norma = slange_("Max", m, n, &a[a_offset], lda, dummy);
+ if (*norma != 0.f) {
+ if (*scale == 2) {
+
+/* matrix scaled up */
+
+ slascl_("General", &c__0, &c__0, norma, &bignum, m, n, &a[
+ a_offset], lda, &info);
+ slascl_("General", &c__0, &c__0, norma, &bignum, &mn, &c__1, &
+ s[1], &mn, &info);
+ slascl_("General", &c__0, &c__0, norma, &bignum, m, nrhs, &b[
+ b_offset], ldb, &info);
+ } else if (*scale == 3) {
+
+/* matrix scaled down */
+
+ slascl_("General", &c__0, &c__0, norma, &smlnum, m, n, &a[
+ a_offset], lda, &info);
+ slascl_("General", &c__0, &c__0, norma, &smlnum, &mn, &c__1, &
+ s[1], &mn, &info);
+ slascl_("General", &c__0, &c__0, norma, &smlnum, m, nrhs, &b[
+ b_offset], ldb, &info);
+ } else {
+ xerbla_("SQRT15", &c__1);
+ return 0;
+ }
+ }
+ }
+
+ *norma = sasum_(&mn, &s[1], &c__1);
+ *normb = slange_("One-norm", m, nrhs, &b[b_offset], ldb, dummy)
+ ;
+
+ return 0;
+
+/* End of SQRT15 */
+
+} /* sqrt15_ */
diff --git a/TESTING/LIN/sqrt16.c b/TESTING/LIN/sqrt16.c
new file mode 100644
index 0000000..cb6c987
--- /dev/null
+++ b/TESTING/LIN/sqrt16.c
@@ -0,0 +1,185 @@
+/* sqrt16.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b8 = -1.f;
+static real c_b9 = 1.f;
+static integer c__1 = 1;
+
+/* Subroutine */ int sqrt16_(char *trans, integer *m, integer *n, integer *
+ nrhs, real *a, integer *lda, real *x, integer *ldx, real *b, integer *
+ ldb, real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j, n1, n2;
+ real eps;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm, bnorm;
+ extern doublereal sasum_(integer *, real *, integer *);
+ real xnorm;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SQRT16 computes the residual for a solution of a system of linear */
+/* equations A*x = b or A'*x = b: */
+/* RESID = norm(B - A*X) / ( max(m,n) * norm(A) * norm(X) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A *x = b */
+/* = 'T': A'*x = b, where A' is the transpose of A */
+/* = 'C': A'*x = b, where A' is the transpose of A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The original M x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M). */
+
+/* B (input/output) REAL array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. IF TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( max(m,n) * norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if M = 0 or N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0 || *nrhs == 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+ if (lsame_(trans, "T") || lsame_(trans, "C")) {
+ anorm = slange_("I", m, n, &a[a_offset], lda, &rwork[1]);
+ n1 = *n;
+ n2 = *m;
+ } else {
+ anorm = slange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ n1 = *m;
+ n2 = *n;
+ }
+
+ eps = slamch_("Epsilon");
+
+/* Compute B - A*X (or B - A'*X ) and store in B. */
+
+ sgemm_(trans, "No transpose", &n1, nrhs, &n2, &c_b8, &a[a_offset], lda, &
+ x[x_offset], ldx, &c_b9, &b[b_offset], ldb)
+ ;
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( max(m,n) * norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = sasum_(&n1, &b[j * b_dim1 + 1], &c__1);
+ xnorm = sasum_(&n2, &x[j * x_dim1 + 1], &c__1);
+ if (anorm == 0.f && bnorm == 0.f) {
+ *resid = 0.f;
+ } else if (anorm <= 0.f || xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / (max(*m,*n) * eps);
+ *resid = dmax(r__1,r__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of SQRT16 */
+
+} /* sqrt16_ */
diff --git a/TESTING/LIN/sqrt17.c b/TESTING/LIN/sqrt17.c
new file mode 100644
index 0000000..99b82fa
--- /dev/null
+++ b/TESTING/LIN/sqrt17.c
@@ -0,0 +1,238 @@
+/* sqrt17.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__13 = 13;
+static real c_b13 = -1.f;
+static real c_b14 = 1.f;
+static integer c__0 = 0;
+static real c_b22 = 0.f;
+
+doublereal sqrt17_(char *trans, integer *iresid, integer *m, integer *n,
+ integer *nrhs, real *a, integer *lda, real *x, integer *ldx, real *b,
+ integer *ldb, real *c__, real *work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, x_dim1,
+ x_offset, i__1;
+ real ret_val;
+
+ /* Local variables */
+ real err;
+ integer iscl, info;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real norma, normb;
+ integer ncols;
+ real normx, rwork[1];
+ integer nrows;
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real bignum;
+ extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
+ real *, integer *, integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *,
+ real *, integer *);
+ real smlnum, normrs;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SQRT17 computes the ratio */
+
+/* || R'*op(A) ||/(||A||*alpha*max(M,N,NRHS)*eps) */
+
+/* where R = op(A)*X - B, op(A) is A or A', and */
+
+/* alpha = ||B|| if IRESID = 1 (zero-residual problem) */
+/* alpha = ||R|| if IRESID = 2 (otherwise). */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies whether or not the transpose of A is used. */
+/* = 'N': No transpose, op(A) = A. */
+/* = 'T': Transpose, op(A) = A'. */
+
+/* IRESID (input) INTEGER */
+/* IRESID = 1 indicates zero-residual problem. */
+/* IRESID = 2 indicates non-zero residual. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+/* If TRANS = 'N', the number of rows of the matrix B. */
+/* If TRANS = 'T', the number of rows of the matrix X. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+/* If TRANS = 'N', the number of rows of the matrix X. */
+/* If TRANS = 'T', the number of rows of the matrix B. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X and B. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The m-by-n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* If TRANS = 'N', the n-by-nrhs matrix X. */
+/* If TRANS = 'T', the m-by-nrhs matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. */
+/* If TRANS = 'N', LDX >= N. */
+/* If TRANS = 'T', LDX >= M. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* If TRANS = 'N', the m-by-nrhs matrix B. */
+/* If TRANS = 'T', the n-by-nrhs matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. */
+/* If TRANS = 'N', LDB >= M. */
+/* If TRANS = 'T', LDB >= N. */
+
+/* C (workspace) REAL array, dimension (LDB,NRHS) */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= NRHS*(M+N). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ c_dim1 = *ldb;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ if (lsame_(trans, "N")) {
+ nrows = *m;
+ ncols = *n;
+ } else if (lsame_(trans, "T")) {
+ nrows = *n;
+ ncols = *m;
+ } else {
+ xerbla_("SQRT17", &c__1);
+ return ret_val;
+ }
+
+ if (*lwork < ncols * *nrhs) {
+ xerbla_("SQRT17", &c__13);
+ return ret_val;
+ }
+
+ if (*m <= 0 || *n <= 0 || *nrhs <= 0) {
+ return ret_val;
+ }
+
+ norma = slange_("One-norm", m, n, &a[a_offset], lda, rwork);
+ smlnum = slamch_("Safe minimum") / slamch_("Precision");
+ bignum = 1.f / smlnum;
+ iscl = 0;
+
+/* compute residual and scale it */
+
+ slacpy_("All", &nrows, nrhs, &b[b_offset], ldb, &c__[c_offset], ldb);
+ sgemm_(trans, "No transpose", &nrows, nrhs, &ncols, &c_b13, &a[a_offset],
+ lda, &x[x_offset], ldx, &c_b14, &c__[c_offset], ldb);
+ normrs = slange_("Max", &nrows, nrhs, &c__[c_offset], ldb, rwork);
+ if (normrs > smlnum) {
+ iscl = 1;
+ slascl_("General", &c__0, &c__0, &normrs, &c_b14, &nrows, nrhs, &c__[
+ c_offset], ldb, &info);
+ }
+
+/* compute R'*A */
+
+ sgemm_("Transpose", trans, nrhs, &ncols, &nrows, &c_b14, &c__[c_offset],
+ ldb, &a[a_offset], lda, &c_b22, &work[1], nrhs);
+
+/* compute and properly scale error */
+
+ err = slange_("One-norm", nrhs, &ncols, &work[1], nrhs, rwork);
+ if (norma != 0.f) {
+ err /= norma;
+ }
+
+ if (iscl == 1) {
+ err *= normrs;
+ }
+
+ if (*iresid == 1) {
+ normb = slange_("One-norm", &nrows, nrhs, &b[b_offset], ldb, rwork);
+ if (normb != 0.f) {
+ err /= normb;
+ }
+ } else {
+ normx = slange_("One-norm", &ncols, nrhs, &x[x_offset], ldx, rwork);
+ if (normx != 0.f) {
+ err /= normx;
+ }
+ }
+
+/* Computing MAX */
+ i__1 = max(*m,*n);
+ ret_val = err / (slamch_("Epsilon") * (real) max(i__1,*nrhs));
+ return ret_val;
+
+/* End of SQRT17 */
+
+} /* sqrt17_ */
diff --git a/TESTING/LIN/srqt01.c b/TESTING/LIN/srqt01.c
new file mode 100644
index 0000000..8acd804
--- /dev/null
+++ b/TESTING/LIN/srqt01.c
@@ -0,0 +1,254 @@
+/* srqt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static real c_b6 = -1e10f;
+static real c_b13 = 0.f;
+static real c_b20 = -1.f;
+static real c_b21 = 1.f;
+
+/* Subroutine */ int srqt01_(integer *m, integer *n, real *a, real *af, real *
+ q, real *r__, integer *lda, real *tau, real *work, integer *lwork,
+ real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
+ r_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real eps;
+ integer info;
+ real resid;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm;
+ integer minmn;
+ extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *,
+ real *, real *, integer *, real *, real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int sgerqf_(integer *, integer *, real *, integer
+ *, real *, real *, integer *, integer *), slacpy_(char *, integer
+ *, integer *, real *, integer *, real *, integer *),
+ slaset_(char *, integer *, integer *, real *, real *, real *,
+ integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+ extern /* Subroutine */ int sorgrq_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SRQT01 tests SGERQF, which computes the RQ factorization of an m-by-n */
+/* matrix A, and partially tests SORGRQ which forms the n-by-n */
+/* orthogonal matrix Q. */
+
+/* SRQT01 compares R with A*Q', and checks that Q is orthogonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The m-by-n matrix A. */
+
+/* AF (output) REAL array, dimension (LDA,N) */
+/* Details of the RQ factorization of A, as returned by SGERQF. */
+/* See SGERQF for further details. */
+
+/* Q (output) REAL array, dimension (LDA,N) */
+/* The n-by-n orthogonal matrix Q. */
+
+/* R (workspace) REAL array, dimension (LDA,max(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and L. */
+/* LDA >= max(M,N). */
+
+/* TAU (output) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by SGERQF. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) REAL array, dimension (max(M,N)) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ minmn = min(*m,*n);
+ eps = slamch_("Epsilon");
+
+/* Copy the matrix A to the array AF. */
+
+ slacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+
+/* Factorize the matrix A in the array AF. */
+
+ s_copy(srnamc_1.srnamt, "SGERQF", (ftnlen)32, (ftnlen)6);
+ sgerqf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy details of Q */
+
+ slaset_("Full", n, n, &c_b6, &c_b6, &q[q_offset], lda);
+ if (*m <= *n) {
+ if (*m > 0 && *m < *n) {
+ i__1 = *n - *m;
+ slacpy_("Full", m, &i__1, &af[af_offset], lda, &q[*n - *m + 1 +
+ q_dim1], lda);
+ }
+ if (*m > 1) {
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ slacpy_("Lower", &i__1, &i__2, &af[(*n - *m + 1) * af_dim1 + 2],
+ lda, &q[*n - *m + 2 + (*n - *m + 1) * q_dim1], lda);
+ }
+ } else {
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ slacpy_("Lower", &i__1, &i__2, &af[*m - *n + 2 + af_dim1], lda, &
+ q[q_dim1 + 2], lda);
+ }
+ }
+
+/* Generate the n-by-n matrix Q */
+
+ s_copy(srnamc_1.srnamt, "SORGRQ", (ftnlen)32, (ftnlen)6);
+ sorgrq_(n, n, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy R */
+
+ slaset_("Full", m, n, &c_b13, &c_b13, &r__[r_offset], lda);
+ if (*m <= *n) {
+ if (*m > 0) {
+ slacpy_("Upper", m, m, &af[(*n - *m + 1) * af_dim1 + 1], lda, &
+ r__[(*n - *m + 1) * r_dim1 + 1], lda);
+ }
+ } else {
+ if (*m > *n && *n > 0) {
+ i__1 = *m - *n;
+ slacpy_("Full", &i__1, n, &af[af_offset], lda, &r__[r_offset],
+ lda);
+ }
+ if (*n > 0) {
+ slacpy_("Upper", n, n, &af[*m - *n + 1 + af_dim1], lda, &r__[*m -
+ *n + 1 + r_dim1], lda);
+ }
+ }
+
+/* Compute R - A*Q' */
+
+ sgemm_("No transpose", "Transpose", m, n, n, &c_b20, &a[a_offset], lda, &
+ q[q_offset], lda, &c_b21, &r__[r_offset], lda);
+
+/* Compute norm( R - Q'*A ) / ( N * norm(A) * EPS ) . */
+
+ anorm = slange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ resid = slange_("1", m, n, &r__[r_offset], lda, &rwork[1]);
+ if (anorm > 0.f) {
+ result[1] = resid / (real) max(1,*n) / anorm / eps;
+ } else {
+ result[1] = 0.f;
+ }
+
+/* Compute I - Q*Q' */
+
+ slaset_("Full", n, n, &c_b13, &c_b21, &r__[r_offset], lda);
+ ssyrk_("Upper", "No transpose", n, n, &c_b20, &q[q_offset], lda, &c_b21, &
+ r__[r_offset], lda);
+
+/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
+
+ resid = slansy_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
+
+ result[2] = resid / (real) max(1,*n) / eps;
+
+ return 0;
+
+/* End of SRQT01 */
+
+} /* srqt01_ */
diff --git a/TESTING/LIN/srqt02.c b/TESTING/LIN/srqt02.c
new file mode 100644
index 0000000..27680c1
--- /dev/null
+++ b/TESTING/LIN/srqt02.c
@@ -0,0 +1,237 @@
+/* srqt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static real c_b4 = -1e10f;
+static real c_b10 = 0.f;
+static real c_b15 = -1.f;
+static real c_b16 = 1.f;
+
+/* Subroutine */ int srqt02_(integer *m, integer *n, integer *k, real *a,
+ real *af, real *q, real *r__, integer *lda, real *tau, real *work,
+ integer *lwork, real *rwork, real *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
+ r_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ real eps;
+ integer info;
+ real resid;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real anorm;
+ extern /* Subroutine */ int ssyrk_(char *, char *, integer *, integer *,
+ real *, real *, integer *, real *, real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+ extern /* Subroutine */ int sorgrq_(integer *, integer *, integer *, real
+ *, integer *, real *, real *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SRQT02 tests SORGRQ, which generates an m-by-n matrix Q with */
+/* orthonornmal rows that is defined as the product of k elementary */
+/* reflectors. */
+
+/* Given the RQ factorization of an m-by-n matrix A, SRQT02 generates */
+/* the orthogonal matrix Q defined by the factorization of the last k */
+/* rows of A; it compares R(m-k+1:m,n-m+1:n) with */
+/* A(m-k+1:m,1:n)*Q(n-m+1:n,1:n)', and checks that the rows of Q are */
+/* orthonormal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q to be generated. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q to be generated. */
+/* N >= M >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The m-by-n matrix A which was factorized by SRQT01. */
+
+/* AF (input) REAL array, dimension (LDA,N) */
+/* Details of the RQ factorization of A, as returned by SGERQF. */
+/* See SGERQF for further details. */
+
+/* Q (workspace) REAL array, dimension (LDA,N) */
+
+/* R (workspace) REAL array, dimension (LDA,M) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and L. LDA >= N. */
+
+/* TAU (input) REAL array, dimension (M) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the RQ factorization in AF. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ if (*m == 0 || *n == 0 || *k == 0) {
+ result[1] = 0.f;
+ result[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+
+/* Copy the last k rows of the factorization to the array Q */
+
+ slaset_("Full", m, n, &c_b4, &c_b4, &q[q_offset], lda);
+ if (*k < *n) {
+ i__1 = *n - *k;
+ slacpy_("Full", k, &i__1, &af[*m - *k + 1 + af_dim1], lda, &q[*m - *k
+ + 1 + q_dim1], lda);
+ }
+ if (*k > 1) {
+ i__1 = *k - 1;
+ i__2 = *k - 1;
+ slacpy_("Lower", &i__1, &i__2, &af[*m - *k + 2 + (*n - *k + 1) *
+ af_dim1], lda, &q[*m - *k + 2 + (*n - *k + 1) * q_dim1], lda);
+ }
+
+/* Generate the last n rows of the matrix Q */
+
+ s_copy(srnamc_1.srnamt, "SORGRQ", (ftnlen)32, (ftnlen)6);
+ sorgrq_(m, n, k, &q[q_offset], lda, &tau[*m - *k + 1], &work[1], lwork, &
+ info);
+
+/* Copy R(m-k+1:m,n-m+1:n) */
+
+ slaset_("Full", k, m, &c_b10, &c_b10, &r__[*m - *k + 1 + (*n - *m + 1) *
+ r_dim1], lda);
+ slacpy_("Upper", k, k, &af[*m - *k + 1 + (*n - *k + 1) * af_dim1], lda, &
+ r__[*m - *k + 1 + (*n - *k + 1) * r_dim1], lda);
+
+/* Compute R(m-k+1:m,n-m+1:n) - A(m-k+1:m,1:n) * Q(n-m+1:n,1:n)' */
+
+ sgemm_("No transpose", "Transpose", k, m, n, &c_b15, &a[*m - *k + 1 +
+ a_dim1], lda, &q[q_offset], lda, &c_b16, &r__[*m - *k + 1 + (*n -
+ *m + 1) * r_dim1], lda);
+
+/* Compute norm( R - A*Q' ) / ( N * norm(A) * EPS ) . */
+
+ anorm = slange_("1", k, n, &a[*m - *k + 1 + a_dim1], lda, &rwork[1]);
+ resid = slange_("1", k, m, &r__[*m - *k + 1 + (*n - *m + 1) * r_dim1],
+ lda, &rwork[1]);
+ if (anorm > 0.f) {
+ result[1] = resid / (real) max(1,*n) / anorm / eps;
+ } else {
+ result[1] = 0.f;
+ }
+
+/* Compute I - Q*Q' */
+
+ slaset_("Full", m, m, &c_b10, &c_b16, &r__[r_offset], lda);
+ ssyrk_("Upper", "No transpose", m, n, &c_b15, &q[q_offset], lda, &c_b16, &
+ r__[r_offset], lda);
+
+/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
+
+ resid = slansy_("1", "Upper", m, &r__[r_offset], lda, &rwork[1]);
+
+ result[2] = resid / (real) max(1,*n) / eps;
+
+ return 0;
+
+/* End of SRQT02 */
+
+} /* srqt02_ */
diff --git a/TESTING/LIN/srqt03.c b/TESTING/LIN/srqt03.c
new file mode 100644
index 0000000..c298b5d
--- /dev/null
+++ b/TESTING/LIN/srqt03.c
@@ -0,0 +1,284 @@
+/* srqt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static real c_b4 = -1e10f;
+static integer c__2 = 2;
+static real c_b22 = -1.f;
+static real c_b23 = 1.f;
+
+/* Subroutine */ int srqt03_(integer *m, integer *n, integer *k, real *af,
+ real *c__, real *cc, real *q, integer *lda, real *tau, real *work,
+ integer *lwork, real *rwork, real *result)
+{
+ /* Initialized data */
+
+ static integer iseed[4] = { 1988,1989,1990,1991 };
+
+ /* System generated locals */
+ integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1,
+ q_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j, mc, nc;
+ real eps;
+ char side[1];
+ integer info, iside;
+ extern logical lsame_(char *, char *);
+ real resid;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ integer minmn;
+ real cnorm;
+ char trans[1];
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *), slaset_(char *, integer *,
+ integer *, real *, real *, real *, integer *);
+ integer itrans;
+ extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
+ *), sorgrq_(integer *, integer *, integer *, real *, integer *,
+ real *, real *, integer *, integer *), sormrq_(char *, char *,
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, integer *, real *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SRQT03 tests SORMRQ, which computes Q*C, Q'*C, C*Q or C*Q'. */
+
+/* SRQT03 compares the results of a call to SORMRQ with the results of */
+/* forming Q explicitly by a call to SORGRQ and then performing matrix */
+/* multiplication by a call to SGEMM. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows or columns of the matrix C; C is n-by-m if */
+/* Q is applied from the left, or m-by-n if Q is applied from */
+/* the right. M >= 0. */
+
+/* N (input) INTEGER */
+/* The order of the orthogonal matrix Q. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* orthogonal matrix Q. N >= K >= 0. */
+
+/* AF (input) REAL array, dimension (LDA,N) */
+/* Details of the RQ factorization of an m-by-n matrix, as */
+/* returned by SGERQF. See SGERQF for further details. */
+
+/* C (workspace) REAL array, dimension (LDA,N) */
+
+/* CC (workspace) REAL array, dimension (LDA,N) */
+
+/* Q (workspace) REAL array, dimension (LDA,N) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays AF, C, CC, and Q. */
+
+/* TAU (input) REAL array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the RQ factorization in AF. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK must be at least M, and should be */
+/* M*NB, where NB is the blocksize for this environment. */
+
+/* RWORK (workspace) REAL array, dimension (M) */
+
+/* RESULT (output) REAL array, dimension (4) */
+/* The test ratios compare two techniques for multiplying a */
+/* random matrix C by an n-by-n orthogonal matrix Q. */
+/* RESULT(1) = norm( Q*C - Q*C ) / ( N * norm(C) * EPS ) */
+/* RESULT(2) = norm( C*Q - C*Q ) / ( N * norm(C) * EPS ) */
+/* RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS ) */
+/* RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ cc_dim1 = *lda;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+ c_dim1 = *lda;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = slamch_("Epsilon");
+ minmn = min(*m,*n);
+
+/* Quick return if possible */
+
+ if (minmn == 0) {
+ result[1] = 0.f;
+ result[2] = 0.f;
+ result[3] = 0.f;
+ result[4] = 0.f;
+ return 0;
+ }
+
+/* Copy the last k rows of the factorization to the array Q */
+
+ slaset_("Full", n, n, &c_b4, &c_b4, &q[q_offset], lda);
+ if (*k > 0 && *n > *k) {
+ i__1 = *n - *k;
+ slacpy_("Full", k, &i__1, &af[*m - *k + 1 + af_dim1], lda, &q[*n - *k
+ + 1 + q_dim1], lda);
+ }
+ if (*k > 1) {
+ i__1 = *k - 1;
+ i__2 = *k - 1;
+ slacpy_("Lower", &i__1, &i__2, &af[*m - *k + 2 + (*n - *k + 1) *
+ af_dim1], lda, &q[*n - *k + 2 + (*n - *k + 1) * q_dim1], lda);
+ }
+
+/* Generate the n-by-n matrix Q */
+
+ s_copy(srnamc_1.srnamt, "SORGRQ", (ftnlen)32, (ftnlen)6);
+ sorgrq_(n, n, k, &q[q_offset], lda, &tau[minmn - *k + 1], &work[1], lwork,
+ &info);
+
+ for (iside = 1; iside <= 2; ++iside) {
+ if (iside == 1) {
+ *(unsigned char *)side = 'L';
+ mc = *n;
+ nc = *m;
+ } else {
+ *(unsigned char *)side = 'R';
+ mc = *m;
+ nc = *n;
+ }
+
+/* Generate MC by NC matrix C */
+
+ i__1 = nc;
+ for (j = 1; j <= i__1; ++j) {
+ slarnv_(&c__2, iseed, &mc, &c__[j * c_dim1 + 1]);
+/* L10: */
+ }
+ cnorm = slange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]);
+ if (cnorm == 0.f) {
+ cnorm = 1.f;
+ }
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+ if (itrans == 1) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'T';
+ }
+
+/* Copy C */
+
+ slacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
+ lda);
+
+/* Apply Q or Q' to C */
+
+ s_copy(srnamc_1.srnamt, "SORMRQ", (ftnlen)32, (ftnlen)6);
+ if (*k > 0) {
+ sormrq_(side, trans, &mc, &nc, k, &af[*m - *k + 1 + af_dim1],
+ lda, &tau[minmn - *k + 1], &cc[cc_offset], lda, &work[
+ 1], lwork, &info);
+ }
+
+/* Form explicit product and subtract */
+
+ if (lsame_(side, "L")) {
+ sgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b22, &q[
+ q_offset], lda, &c__[c_offset], lda, &c_b23, &cc[
+ cc_offset], lda);
+ } else {
+ sgemm_("No transpose", trans, &mc, &nc, &nc, &c_b22, &c__[
+ c_offset], lda, &q[q_offset], lda, &c_b23, &cc[
+ cc_offset], lda);
+ }
+
+/* Compute error in the difference */
+
+ resid = slange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
+ result[(iside - 1 << 1) + itrans] = resid / ((real) max(1,*n) *
+ cnorm * eps);
+
+/* L20: */
+ }
+/* L30: */
+ }
+
+ return 0;
+
+/* End of SRQT03 */
+
+} /* srqt03_ */
diff --git a/TESTING/LIN/srzt01.c b/TESTING/LIN/srzt01.c
new file mode 100644
index 0000000..3b4fc73
--- /dev/null
+++ b/TESTING/LIN/srzt01.c
@@ -0,0 +1,169 @@
+/* srzt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static real c_b6 = 0.f;
+static real c_b13 = -1.f;
+static integer c__1 = 1;
+
+doublereal srzt01_(integer *m, integer *n, real *a, real *af, integer *lda,
+ real *tau, real *work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2;
+ real ret_val;
+
+ /* Local variables */
+ integer i__, j, info;
+ real norma, rwork[1];
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), slaset_(
+ char *, integer *, integer *, real *, real *, real *, integer *), sormrz_(char *, char *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SRZT01 returns */
+/* || A - R*Q || / ( M * eps * ||A|| ) */
+/* for an upper trapezoidal A that was factored with STZRZF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices A and AF. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and AF. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The original upper trapezoidal M by N matrix A. */
+
+/* AF (input) REAL array, dimension (LDA,N) */
+/* The output of STZRZF for input matrix A. */
+/* The lower triangle is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A and AF. */
+
+/* TAU (input) REAL array, dimension (M) */
+/* Details of the Householder transformations as returned by */
+/* STZRZF. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= m*n + m*nb. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ if (*lwork < *m * *n + *m) {
+ xerbla_("SRZT01", &c__8);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return ret_val;
+ }
+
+ norma = slange_("One-norm", m, n, &a[a_offset], lda, rwork);
+
+/* Copy upper triangle R */
+
+ slaset_("Full", m, n, &c_b6, &c_b6, &work[1], m);
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[(j - 1) * *m + i__] = af[i__ + j * af_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* R = R * P(1) * ... *P(m) */
+
+ i__1 = *n - *m;
+ i__2 = *lwork - *m * *n;
+ sormrz_("Right", "No tranpose", m, n, m, &i__1, &af[af_offset], lda, &tau[
+ 1], &work[1], m, &work[*m * *n + 1], &i__2, &info);
+
+/* R = R - A */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ saxpy_(m, &c_b13, &a[i__ * a_dim1 + 1], &c__1, &work[(i__ - 1) * *m +
+ 1], &c__1);
+/* L30: */
+ }
+
+ ret_val = slange_("One-norm", m, n, &work[1], m, rwork);
+
+ ret_val /= slamch_("Epsilon") * (real) max(*m,*n);
+ if (norma != 0.f) {
+ ret_val /= norma;
+ }
+
+ return ret_val;
+
+/* End of SRZT01 */
+
+} /* srzt01_ */
diff --git a/TESTING/LIN/srzt02.c b/TESTING/LIN/srzt02.c
new file mode 100644
index 0000000..9f006eb
--- /dev/null
+++ b/TESTING/LIN/srzt02.c
@@ -0,0 +1,150 @@
+/* srzt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__7 = 7;
+static real c_b5 = 0.f;
+static real c_b6 = 1.f;
+
+doublereal srzt02_(integer *m, integer *n, real *af, integer *lda, real *tau,
+ real *work, integer *lwork)
+{
+ /* System generated locals */
+ integer af_dim1, af_offset, i__1, i__2;
+ real ret_val;
+
+ /* Local variables */
+ integer i__, info;
+ real rwork[1];
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), slaset_(
+ char *, integer *, integer *, real *, real *, real *, integer *), sormrz_(char *, char *, integer *, integer *, integer *,
+ integer *, real *, integer *, real *, real *, integer *, real *,
+ integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SRZT02 returns */
+/* || I - Q'*Q || / ( M * eps) */
+/* where the matrix Q is defined by the Householder transformations */
+/* generated by STZRZF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix AF. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix AF. */
+
+/* AF (input) REAL array, dimension (LDA,N) */
+/* The output of STZRZF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array AF. */
+
+/* TAU (input) REAL array, dimension (M) */
+/* Details of the Householder transformations as returned by */
+/* STZRZF. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* length of WORK array. LWORK >= N*N+N*NB. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ if (*lwork < *n * *n + *n) {
+ xerbla_("SRZT02", &c__7);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return ret_val;
+ }
+
+/* Q := I */
+
+ slaset_("Full", n, n, &c_b5, &c_b6, &work[1], n);
+
+/* Q := P(1) * ... * P(m) * Q */
+
+ i__1 = *n - *m;
+ i__2 = *lwork - *n * *n;
+ sormrz_("Left", "No transpose", n, n, m, &i__1, &af[af_offset], lda, &tau[
+ 1], &work[1], n, &work[*n * *n + 1], &i__2, &info);
+
+/* Q := P(m) * ... * P(1) * Q */
+
+ i__1 = *n - *m;
+ i__2 = *lwork - *n * *n;
+ sormrz_("Left", "Transpose", n, n, m, &i__1, &af[af_offset], lda, &tau[1],
+ &work[1], n, &work[*n * *n + 1], &i__2, &info);
+
+/* Q := Q - I */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[(i__ - 1) * *n + i__] += -1.f;
+/* L10: */
+ }
+
+ ret_val = slange_("One-norm", n, n, &work[1], n, rwork) / (
+ slamch_("Epsilon") * (real) max(*m,*n));
+ return ret_val;
+
+/* End of SRZT02 */
+
+} /* srzt02_ */
diff --git a/TESTING/LIN/sspt01.c b/TESTING/LIN/sspt01.c
new file mode 100644
index 0000000..e230581
--- /dev/null
+++ b/TESTING/LIN/sspt01.c
@@ -0,0 +1,190 @@
+/* sspt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b5 = 0.f;
+static real c_b6 = 1.f;
+
+/* Subroutine */ int sspt01_(char *uplo, integer *n, real *a, real *afac,
+ integer *ipiv, real *c__, integer *ldc, real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1, i__2;
+
+ /* Local variables */
+ integer i__, j, jc;
+ real eps;
+ integer info;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *);
+ extern doublereal slansp_(char *, char *, integer *, real *, real *);
+ extern /* Subroutine */ int slavsp_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *, integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSPT01 reconstructs a symmetric indefinite packed matrix A from its */
+/* block L*D*L' or U*D*U' factorization and computes the residual */
+/* norm( C - A ) / ( N * norm(A) * EPS ), */
+/* where C is the reconstructed matrix and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (N*(N+1)/2) */
+/* The original symmetric matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* AFAC (input) REAL array, dimension (N*(N+1)/2) */
+/* The factored form of the matrix A, stored as a packed */
+/* triangular matrix. AFAC contains the block diagonal matrix D */
+/* and the multipliers used to obtain the factor L or U from the */
+/* block L*D*L' or U*D*U' factorization as computed by SSPTRF. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from SSPTRF. */
+
+/* C (workspace) REAL array, dimension (LDC,N) */
+
+/* LDC (integer) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) 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 ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ --a;
+ --afac;
+ --ipiv;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Determine EPS and the norm of A. */
+
+ eps = slamch_("Epsilon");
+ anorm = slansp_("1", uplo, n, &a[1], &rwork[1]);
+
+/* Initialize C to the identity matrix. */
+
+ slaset_("Full", n, n, &c_b5, &c_b6, &c__[c_offset], ldc);
+
+/* Call SLAVSP to form the product D * U' (or D * L' ). */
+
+ slavsp_(uplo, "Transpose", "Non-unit", n, n, &afac[1], &ipiv[1], &c__[
+ c_offset], ldc, &info);
+
+/* Call SLAVSP again to multiply by U ( or L ). */
+
+ slavsp_(uplo, "No transpose", "Unit", n, n, &afac[1], &ipiv[1], &c__[
+ c_offset], ldc, &info);
+
+/* Compute the difference C - A . */
+
+ if (lsame_(uplo, "U")) {
+ jc = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] -= a[jc + i__];
+/* L10: */
+ }
+ jc += j;
+/* L20: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] -= a[jc + i__ - j];
+/* L30: */
+ }
+ jc = jc + *n - j + 1;
+/* L40: */
+ }
+ }
+
+/* Compute norm( C - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = slansy_("1", uplo, n, &c__[c_offset], ldc, &rwork[1]);
+
+ if (anorm <= 0.f) {
+ if (*resid != 0.f) {
+ *resid = 1.f / eps;
+ }
+ } else {
+ *resid = *resid / (real) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of SSPT01 */
+
+} /* sspt01_ */
diff --git a/TESTING/LIN/ssyt01.c b/TESTING/LIN/ssyt01.c
new file mode 100644
index 0000000..150d981
--- /dev/null
+++ b/TESTING/LIN/ssyt01.c
@@ -0,0 +1,197 @@
+/* ssyt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b5 = 0.f;
+static real c_b6 = 1.f;
+
+/* Subroutine */ int ssyt01_(char *uplo, integer *n, real *a, integer *lda,
+ real *afac, integer *ldafac, integer *ipiv, real *c__, integer *ldc,
+ real *rwork, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, c_dim1, c_offset, i__1,
+ i__2;
+
+ /* Local variables */
+ integer i__, j;
+ real eps;
+ integer info;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern doublereal slamch_(char *);
+ extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *);
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+ extern /* Subroutine */ int slavsy_(char *, char *, char *, integer *,
+ integer *, real *, integer *, integer *, real *, integer *,
+ integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SSYT01 reconstructs a symmetric indefinite matrix A from its */
+/* block L*D*L' or U*D*U' factorization and computes the residual */
+/* norm( C - A ) / ( N * norm(A) * EPS ), */
+/* where C is the reconstructed matrix and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The original symmetric matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* AFAC (input) REAL array, dimension (LDAFAC,N) */
+/* The factored form of the matrix A. AFAC contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor L or U from the block L*D*L' or U*D*U' factorization */
+/* as computed by SSYTRF. */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from SSYTRF. */
+
+/* C (workspace) REAL array, dimension (LDC,N) */
+
+/* LDC (integer) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,N). */
+
+/* RWORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) 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 ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ --ipiv;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Determine EPS and the norm of A. */
+
+ eps = slamch_("Epsilon");
+ anorm = slansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+
+/* Initialize C to the identity matrix. */
+
+ slaset_("Full", n, n, &c_b5, &c_b6, &c__[c_offset], ldc);
+
+/* Call SLAVSY to form the product D * U' (or D * L' ). */
+
+ slavsy_(uplo, "Transpose", "Non-unit", n, n, &afac[afac_offset], ldafac, &
+ ipiv[1], &c__[c_offset], ldc, &info);
+
+/* Call SLAVSY again to multiply by U (or L ). */
+
+ slavsy_(uplo, "No transpose", "Unit", n, n, &afac[afac_offset], ldafac, &
+ ipiv[1], &c__[c_offset], ldc, &info);
+
+/* Compute the difference C - A . */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] -= a[i__ + j * a_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ c__[i__ + j * c_dim1] -= a[i__ + j * a_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+/* Compute norm( C - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = slansy_("1", uplo, n, &c__[c_offset], ldc, &rwork[1]);
+
+ if (anorm <= 0.f) {
+ if (*resid != 0.f) {
+ *resid = 1.f / eps;
+ }
+ } else {
+ *resid = *resid / (real) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of SSYT01 */
+
+} /* ssyt01_ */
diff --git a/TESTING/LIN/stbt02.c b/TESTING/LIN/stbt02.c
new file mode 100644
index 0000000..0f2eb5a
--- /dev/null
+++ b/TESTING/LIN/stbt02.c
@@ -0,0 +1,202 @@
+/* stbt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b10 = -1.f;
+
+/* Subroutine */ int stbt02_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, real *ab, integer *ldab, real *x, integer
+ *ldx, real *b, integer *ldb, real *work, real *resid)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j;
+ real eps;
+ extern logical lsame_(char *, char *);
+ real anorm, bnorm;
+ extern doublereal sasum_(integer *, real *, integer *);
+ extern /* Subroutine */ int stbmv_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *);
+ real xnorm;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *);
+ extern doublereal slamch_(char *), slantb_(char *, char *, char *,
+ integer *, integer *, real *, integer *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STBT02 computes the residual for the computed solution to a */
+/* triangular system of linear equations A*x = b or A' *x = b when */
+/* A is a triangular band matrix. Here A' is the transpose of A and */
+/* x and b are N by NRHS matrices. The test ratio is the maximum over */
+/* the number of right hand sides of */
+/* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A or A' and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = b (No transpose) */
+/* = 'T': A'*x = b (Transpose) */
+/* = 'C': A'*x = b (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* AB (input) REAL array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Compute the 1-norm of A or A'. */
+
+ if (lsame_(trans, "N")) {
+ anorm = slantb_("1", uplo, diag, n, kd, &ab[ab_offset], ldab, &work[1]
+);
+ } else {
+ anorm = slantb_("I", uplo, diag, n, kd, &ab[ab_offset], ldab, &work[1]
+);
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ stbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[1], &
+ c__1);
+ saxpy_(n, &c_b10, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ bnorm = sasum_(n, &work[1], &c__1);
+ xnorm = sasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of STBT02 */
+
+} /* stbt02_ */
diff --git a/TESTING/LIN/stbt03.c b/TESTING/LIN/stbt03.c
new file mode 100644
index 0000000..521f88f
--- /dev/null
+++ b/TESTING/LIN/stbt03.c
@@ -0,0 +1,256 @@
+/* stbt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int stbt03_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, real *ab, integer *ldab, real *scale,
+ real *cnorm, real *tscal, real *x, integer *ldx, real *b, integer *
+ ldb, real *work, real *resid)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer j, ix;
+ real eps, err;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real xscal;
+ extern /* Subroutine */ int stbmv_(char *, char *, char *, integer *,
+ integer *, real *, integer *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *);
+ real tnorm, xnorm;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *), slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ real bignum;
+ extern integer isamax_(integer *, real *, integer *);
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STBT03 computes the residual for the solution to a scaled triangular */
+/* system of equations A*x = s*b or A'*x = s*b when A is a */
+/* triangular band matrix. Here A' is the transpose of A, s is a scalar, */
+/* and x and b are N by NRHS matrices. The test ratio is the maximum */
+/* over the number of right hand sides of */
+/* norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A or A' and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = b (No transpose) */
+/* = 'T': A'*x = b (Transpose) */
+/* = 'C': A'*x = b (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* AB (input) REAL array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* SCALE (input) REAL */
+/* The scaling factor s used in solving the triangular system. */
+
+/* CNORM (input) REAL array, dimension (N) */
+/* The 1-norms of the columns of A, not counting the diagonal. */
+
+/* TSCAL (input) REAL */
+/* The scaling factor used in computing the 1-norms in CNORM. */
+/* CNORM actually contains the column norms of TSCAL*A. */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --cnorm;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+ eps = slamch_("Epsilon");
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Compute the norm of the triangular matrix A using the column */
+/* norms already computed by SLATBS. */
+
+ tnorm = 0.f;
+ if (lsame_(diag, "N")) {
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ r__2 = tnorm, r__3 = *tscal * (r__1 = ab[*kd + 1 + j *
+ ab_dim1], dabs(r__1)) + cnorm[j];
+ tnorm = dmax(r__2,r__3);
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ r__2 = tnorm, r__3 = *tscal * (r__1 = ab[j * ab_dim1 + 1],
+ dabs(r__1)) + cnorm[j];
+ tnorm = dmax(r__2,r__3);
+/* L20: */
+ }
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ r__1 = tnorm, r__2 = *tscal + cnorm[j];
+ tnorm = dmax(r__1,r__2);
+/* L30: */
+ }
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = isamax_(n, &work[1], &c__1);
+/* Computing MAX */
+ r__2 = 1.f, r__3 = (r__1 = x[ix + j * x_dim1], dabs(r__1));
+ xnorm = dmax(r__2,r__3);
+ xscal = 1.f / xnorm / (real) (*kd + 1);
+ sscal_(n, &xscal, &work[1], &c__1);
+ stbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[1], &
+ c__1);
+ r__1 = -(*scale) * xscal;
+ saxpy_(n, &r__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = isamax_(n, &work[1], &c__1);
+ err = *tscal * (r__1 = work[ix], dabs(r__1));
+ ix = isamax_(n, &x[j * x_dim1 + 1], &c__1);
+ xnorm = (r__1 = x[ix + j * x_dim1], dabs(r__1));
+ if (err * smlnum <= xnorm) {
+ if (xnorm > 0.f) {
+ err /= xnorm;
+ }
+ } else {
+ if (err > 0.f) {
+ err = 1.f / eps;
+ }
+ }
+ if (err * smlnum <= tnorm) {
+ if (tnorm > 0.f) {
+ err /= tnorm;
+ }
+ } else {
+ if (err > 0.f) {
+ err = 1.f / eps;
+ }
+ }
+ *resid = dmax(*resid,err);
+/* L40: */
+ }
+
+ return 0;
+
+/* End of STBT03 */
+
+} /* stbt03_ */
diff --git a/TESTING/LIN/stbt05.c b/TESTING/LIN/stbt05.c
new file mode 100644
index 0000000..79dcaef
--- /dev/null
+++ b/TESTING/LIN/stbt05.c
@@ -0,0 +1,333 @@
+/* stbt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int stbt05_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, real *ab, integer *ldab, real *b, integer
+ *ldb, real *x, integer *ldx, real *xact, integer *ldxact, real *ferr,
+ real *berr, real *reslts)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, k, nz, ifu;
+ real eps, tmp, diff, axbi;
+ integer imax;
+ real unfl, ovfl;
+ logical unit;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ real xnorm;
+ extern doublereal slamch_(char *);
+ real errbnd;
+ extern integer isamax_(integer *, real *, integer *);
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STBT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* triangular band matrix. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+/* and NZ = max. number of nonzeros in any row of A, plus 1 */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A'* X = B (Transpose) */
+/* = 'C': A'* X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* AB (input) REAL array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) REAL array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) REAL array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) REAL array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.f;
+ reslts[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ unit = lsame_(diag, "U");
+/* Computing MIN */
+ i__1 = *kd, i__2 = *n - 1;
+ nz = min(i__1,i__2) + 1;
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = isamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ r__2 = (r__1 = x[imax + j * x_dim1], dabs(r__1));
+ xnorm = dmax(r__2,unfl);
+ diff = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = diff, r__3 = (r__1 = x[i__ + j * x_dim1] - xact[i__ + j *
+ xact_dim1], dabs(r__1));
+ diff = dmax(r__2,r__3);
+/* L10: */
+ }
+
+ if (xnorm > 1.f) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1.f / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
+ errbnd = dmax(r__1,r__2);
+ } else {
+ errbnd = 1.f / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ ifu = 0;
+ if (unit) {
+ ifu = 1;
+ }
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ tmp = (r__1 = b[i__ + k * b_dim1], dabs(r__1));
+ if (upper) {
+ if (! notran) {
+/* Computing MAX */
+ i__3 = i__ - *kd;
+ i__4 = i__ - ifu;
+ for (j = max(i__3,1); j <= i__4; ++j) {
+ tmp += (r__1 = ab[*kd + 1 - i__ + j + i__ * ab_dim1],
+ dabs(r__1)) * (r__2 = x[j + k * x_dim1], dabs(
+ r__2));
+/* L40: */
+ }
+ if (unit) {
+ tmp += (r__1 = x[i__ + k * x_dim1], dabs(r__1));
+ }
+ } else {
+ if (unit) {
+ tmp += (r__1 = x[i__ + k * x_dim1], dabs(r__1));
+ }
+/* Computing MIN */
+ i__3 = i__ + *kd;
+ i__4 = min(i__3,*n);
+ for (j = i__ + ifu; j <= i__4; ++j) {
+ tmp += (r__1 = ab[*kd + 1 + i__ - j + j * ab_dim1],
+ dabs(r__1)) * (r__2 = x[j + k * x_dim1], dabs(
+ r__2));
+/* L50: */
+ }
+ }
+ } else {
+ if (notran) {
+/* Computing MAX */
+ i__4 = i__ - *kd;
+ i__3 = i__ - ifu;
+ for (j = max(i__4,1); j <= i__3; ++j) {
+ tmp += (r__1 = ab[i__ + 1 - j + j * ab_dim1], dabs(
+ r__1)) * (r__2 = x[j + k * x_dim1], dabs(r__2)
+ );
+/* L60: */
+ }
+ if (unit) {
+ tmp += (r__1 = x[i__ + k * x_dim1], dabs(r__1));
+ }
+ } else {
+ if (unit) {
+ tmp += (r__1 = x[i__ + k * x_dim1], dabs(r__1));
+ }
+/* Computing MIN */
+ i__4 = i__ + *kd;
+ i__3 = min(i__4,*n);
+ for (j = i__ + ifu; j <= i__3; ++j) {
+ tmp += (r__1 = ab[j + 1 - i__ + i__ * ab_dim1], dabs(
+ r__1)) * (r__2 = x[j + k * x_dim1], dabs(r__2)
+ );
+/* L70: */
+ }
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = dmin(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ r__1 = axbi, r__2 = nz * unfl;
+ tmp = berr[k] / (nz * eps + nz * unfl / dmax(r__1,r__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = dmax(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of STBT05 */
+
+} /* stbt05_ */
diff --git a/TESTING/LIN/stbt06.c b/TESTING/LIN/stbt06.c
new file mode 100644
index 0000000..a8caa9d
--- /dev/null
+++ b/TESTING/LIN/stbt06.c
@@ -0,0 +1,166 @@
+/* stbt06.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int stbt06_(real *rcond, real *rcondc, char *uplo, char *
+ diag, integer *n, integer *kd, real *ab, integer *ldab, real *work,
+ real *rat)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset;
+ real r__1, r__2;
+
+ /* Local variables */
+ real eps, rmin, rmax, anorm;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ real bignum;
+ extern doublereal slantb_(char *, char *, char *, integer *, integer *,
+ real *, integer *, real *);
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STBT06 computes a test ratio comparing RCOND (the reciprocal */
+/* condition number of a triangular matrix A) and RCONDC, the estimate */
+/* computed by STBCON. Information about the triangular matrix A is */
+/* used if one estimate is zero and the other is non-zero to decide if */
+/* underflow in the estimate is justified. */
+
+/* Arguments */
+/* ========= */
+
+/* RCOND (input) REAL */
+/* The estimate of the reciprocal condition number obtained by */
+/* forming the explicit inverse of the matrix A and computing */
+/* RCOND = 1/( norm(A) * norm(inv(A)) ). */
+
+/* RCONDC (input) REAL */
+/* The estimate of the reciprocal condition number computed by */
+/* STBCON. */
+
+/* UPLO (input) CHARACTER */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* AB (input) REAL array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* RAT (output) REAL */
+/* The test ratio. If both RCOND and RCONDC are nonzero, */
+/* RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1. */
+/* If RAT = 0, the two estimates are exactly the same. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --work;
+
+ /* Function Body */
+ eps = slamch_("Epsilon");
+ rmax = dmax(*rcond,*rcondc);
+ rmin = dmin(*rcond,*rcondc);
+
+/* Do the easy cases first. */
+
+ if (rmin < 0.f) {
+
+/* Invalid value for RCOND or RCONDC, return 1/EPS. */
+
+ *rat = 1.f / eps;
+
+ } else if (rmin > 0.f) {
+
+/* Both estimates are positive, return RMAX/RMIN - 1. */
+
+ *rat = rmax / rmin - 1.f;
+
+ } else if (rmax == 0.f) {
+
+/* Both estimates zero. */
+
+ *rat = 0.f;
+
+ } else {
+
+/* One estimate is zero, the other is non-zero. If the matrix is */
+/* ill-conditioned, return the nonzero estimate multiplied by */
+/* 1/EPS; if the matrix is badly scaled, return the nonzero */
+/* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum */
+/* element in absolute value in A. */
+
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ anorm = slantb_("M", uplo, diag, n, kd, &ab[ab_offset], ldab, &work[1]
+);
+
+/* Computing MIN */
+ r__1 = bignum / dmax(1.f,anorm), r__2 = 1.f / eps;
+ *rat = rmax * dmin(r__1,r__2);
+ }
+
+ return 0;
+
+/* End of STBT06 */
+
+} /* stbt06_ */
diff --git a/TESTING/LIN/stpt01.c b/TESTING/LIN/stpt01.c
new file mode 100644
index 0000000..4b3e0e2
--- /dev/null
+++ b/TESTING/LIN/stpt01.c
@@ -0,0 +1,189 @@
+/* stpt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int stpt01_(char *uplo, char *diag, integer *n, real *ap,
+ real *ainvp, real *rcond, real *work, real *resid)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+
+ /* Local variables */
+ integer j, jc;
+ real eps;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ logical unitd;
+ extern /* Subroutine */ int stpmv_(char *, char *, char *, integer *,
+ real *, real *, integer *);
+ extern doublereal slamch_(char *);
+ real ainvnm;
+ extern doublereal slantp_(char *, char *, char *, integer *, real *, real
+ *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STPT01 computes the residual for a triangular matrix A times its */
+/* inverse when A is stored in packed format: */
+/* RESID = norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) REAL array, dimension (N*(N+1)/2) */
+/* The original upper or lower triangular matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
+
+/* AINVP (input/output) REAL array, dimension (N*(N+1)/2) */
+/* On entry, the (triangular) inverse of the matrix A, packed */
+/* columnwise in a linear array as in AP. */
+/* On exit, the contents of AINVP are destroyed. */
+
+/* RCOND (output) REAL */
+/* The reciprocal condition number of A, computed as */
+/* 1/(norm(A) * norm(AINV)). */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ --work;
+ --ainvp;
+ --ap;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.f;
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = slantp_("1", uplo, diag, n, &ap[1], &work[1]);
+ ainvnm = slantp_("1", uplo, diag, n, &ainvp[1], &work[1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ *rcond = 0.f;
+ *resid = 1.f / eps;
+ return 0;
+ }
+ *rcond = 1.f / anorm / ainvnm;
+
+/* Compute A * AINV, overwriting AINV. */
+
+ unitd = lsame_(diag, "U");
+ if (lsame_(uplo, "U")) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (unitd) {
+ ainvp[jc + j - 1] = 1.f;
+ }
+
+/* Form the j-th column of A*AINV */
+
+ stpmv_("Upper", "No transpose", diag, &j, &ap[1], &ainvp[jc], &
+ c__1);
+
+/* Subtract 1 from the diagonal */
+
+ ainvp[jc + j - 1] += -1.f;
+ jc += j;
+/* L10: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (unitd) {
+ ainvp[jc] = 1.f;
+ }
+
+/* Form the j-th column of A*AINV */
+
+ i__2 = *n - j + 1;
+ stpmv_("Lower", "No transpose", diag, &i__2, &ap[jc], &ainvp[jc],
+ &c__1);
+
+/* Subtract 1 from the diagonal */
+
+ ainvp[jc] += -1.f;
+ jc = jc + *n - j + 1;
+/* L20: */
+ }
+ }
+
+/* Compute norm(A*AINV - I) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = slantp_("1", uplo, "Non-unit", n, &ainvp[1], &work[1]);
+
+ *resid = *resid * *rcond / (real) (*n) / eps;
+
+ return 0;
+
+/* End of STPT01 */
+
+} /* stpt01_ */
diff --git a/TESTING/LIN/stpt02.c b/TESTING/LIN/stpt02.c
new file mode 100644
index 0000000..86374a3
--- /dev/null
+++ b/TESTING/LIN/stpt02.c
@@ -0,0 +1,192 @@
+/* stpt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b10 = -1.f;
+
+/* Subroutine */ int stpt02_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, real *ap, real *x, integer *ldx, real *b, integer *ldb,
+ real *work, real *resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j;
+ real eps;
+ extern logical lsame_(char *, char *);
+ real anorm, bnorm;
+ extern doublereal sasum_(integer *, real *, integer *);
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ real xnorm;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *), stpmv_(char *, char *, char *, integer *,
+ real *, real *, integer *);
+ extern doublereal slamch_(char *), slantp_(char *, char *, char *,
+ integer *, real *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STPT02 computes the residual for the computed solution to a */
+/* triangular system of linear equations A*x = b or A'*x = b when */
+/* the triangular matrix A is stored in packed format. Here A' is the */
+/* transpose of A and x and b are N by NRHS matrices. The test ratio is */
+/* the maximum over the number of right hand sides of */
+/* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A or A' and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = b (No transpose) */
+/* = 'T': A'*x = b (Transpose) */
+/* = 'C': A'*x = b (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* AP (input) REAL array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ --ap;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Compute the 1-norm of A or A'. */
+
+ if (lsame_(trans, "N")) {
+ anorm = slantp_("1", uplo, diag, n, &ap[1], &work[1]);
+ } else {
+ anorm = slantp_("I", uplo, diag, n, &ap[1], &work[1]);
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ stpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1);
+ saxpy_(n, &c_b10, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ bnorm = sasum_(n, &work[1], &c__1);
+ xnorm = sasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of STPT02 */
+
+} /* stpt02_ */
diff --git a/TESTING/LIN/stpt03.c b/TESTING/LIN/stpt03.c
new file mode 100644
index 0000000..c9b10f6
--- /dev/null
+++ b/TESTING/LIN/stpt03.c
@@ -0,0 +1,252 @@
+/* stpt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int stpt03_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, real *ap, real *scale, real *cnorm, real *tscal, real *
+ x, integer *ldx, real *b, integer *ldb, real *work, real *resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer j, jj, ix;
+ real eps, err;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real xscal;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ real tnorm, xnorm;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *), stpmv_(char *, char *, char *, integer *,
+ real *, real *, integer *), slabad_(real *
+, real *);
+ extern doublereal slamch_(char *);
+ real bignum;
+ extern integer isamax_(integer *, real *, integer *);
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STPT03 computes the residual for the solution to a scaled triangular */
+/* system of equations A*x = s*b or A'*x = s*b when the triangular */
+/* matrix A is stored in packed format. Here A' is the transpose of A, */
+/* s is a scalar, and x and b are N by NRHS matrices. The test ratio is */
+/* the maximum over the number of right hand sides of */
+/* norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A or A' and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = s*b (No transpose) */
+/* = 'T': A'*x = s*b (Transpose) */
+/* = 'C': A'*x = s*b (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* AP (input) REAL array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
+
+/* SCALE (input) REAL */
+/* The scaling factor s used in solving the triangular system. */
+
+/* CNORM (input) REAL array, dimension (N) */
+/* The 1-norms of the columns of A, not counting the diagonal. */
+
+/* TSCAL (input) REAL */
+/* The scaling factor used in computing the 1-norms in CNORM. */
+/* CNORM actually contains the column norms of TSCAL*A. */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ --ap;
+ --cnorm;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+ eps = slamch_("Epsilon");
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Compute the norm of the triangular matrix A using the column */
+/* norms already computed by SLATPS. */
+
+ tnorm = 0.f;
+ if (lsame_(diag, "N")) {
+ if (lsame_(uplo, "U")) {
+ jj = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ r__2 = tnorm, r__3 = *tscal * (r__1 = ap[jj], dabs(r__1)) +
+ cnorm[j];
+ tnorm = dmax(r__2,r__3);
+ jj = jj + j + 1;
+/* L10: */
+ }
+ } else {
+ jj = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ r__2 = tnorm, r__3 = *tscal * (r__1 = ap[jj], dabs(r__1)) +
+ cnorm[j];
+ tnorm = dmax(r__2,r__3);
+ jj = jj + *n - j + 1;
+/* L20: */
+ }
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ r__1 = tnorm, r__2 = *tscal + cnorm[j];
+ tnorm = dmax(r__1,r__2);
+/* L30: */
+ }
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = isamax_(n, &work[1], &c__1);
+/* Computing MAX */
+ r__2 = 1.f, r__3 = (r__1 = x[ix + j * x_dim1], dabs(r__1));
+ xnorm = dmax(r__2,r__3);
+ xscal = 1.f / xnorm / (real) (*n);
+ sscal_(n, &xscal, &work[1], &c__1);
+ stpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1);
+ r__1 = -(*scale) * xscal;
+ saxpy_(n, &r__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = isamax_(n, &work[1], &c__1);
+ err = *tscal * (r__1 = work[ix], dabs(r__1));
+ ix = isamax_(n, &x[j * x_dim1 + 1], &c__1);
+ xnorm = (r__1 = x[ix + j * x_dim1], dabs(r__1));
+ if (err * smlnum <= xnorm) {
+ if (xnorm > 0.f) {
+ err /= xnorm;
+ }
+ } else {
+ if (err > 0.f) {
+ err = 1.f / eps;
+ }
+ }
+ if (err * smlnum <= tnorm) {
+ if (tnorm > 0.f) {
+ err /= tnorm;
+ }
+ } else {
+ if (err > 0.f) {
+ err = 1.f / eps;
+ }
+ }
+ *resid = dmax(*resid,err);
+/* L40: */
+ }
+
+ return 0;
+
+/* End of STPT03 */
+
+} /* stpt03_ */
diff --git a/TESTING/LIN/stpt05.c b/TESTING/LIN/stpt05.c
new file mode 100644
index 0000000..b9848d8
--- /dev/null
+++ b/TESTING/LIN/stpt05.c
@@ -0,0 +1,314 @@
+/* stpt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int stpt05_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, real *ap, real *b, integer *ldb, real *x, integer *ldx,
+ real *xact, integer *ldxact, real *ferr, real *berr, real *reslts)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1,
+ i__2, i__3;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, k, jc, ifu;
+ real eps, tmp, diff, axbi;
+ integer imax;
+ real unfl, ovfl;
+ logical unit;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ real xnorm;
+ extern doublereal slamch_(char *);
+ real errbnd;
+ extern integer isamax_(integer *, real *, integer *);
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STPT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* triangular matrix in packed storage format. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A'* X = B (Transpose) */
+/* = 'C': A'* X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* AP (input) REAL array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) REAL array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) REAL array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) REAL array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.f;
+ reslts[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ unit = lsame_(diag, "U");
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = isamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ r__2 = (r__1 = x[imax + j * x_dim1], dabs(r__1));
+ xnorm = dmax(r__2,unfl);
+ diff = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = diff, r__3 = (r__1 = x[i__ + j * x_dim1] - xact[i__ + j *
+ xact_dim1], dabs(r__1));
+ diff = dmax(r__2,r__3);
+/* L10: */
+ }
+
+ if (xnorm > 1.f) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1.f / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
+ errbnd = dmax(r__1,r__2);
+ } else {
+ errbnd = 1.f / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ ifu = 0;
+ if (unit) {
+ ifu = 1;
+ }
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ tmp = (r__1 = b[i__ + k * b_dim1], dabs(r__1));
+ if (upper) {
+ jc = (i__ - 1) * i__ / 2;
+ if (! notran) {
+ i__3 = i__ - ifu;
+ for (j = 1; j <= i__3; ++j) {
+ tmp += (r__1 = ap[jc + j], dabs(r__1)) * (r__2 = x[j
+ + k * x_dim1], dabs(r__2));
+/* L40: */
+ }
+ if (unit) {
+ tmp += (r__1 = x[i__ + k * x_dim1], dabs(r__1));
+ }
+ } else {
+ jc += i__;
+ if (unit) {
+ tmp += (r__1 = x[i__ + k * x_dim1], dabs(r__1));
+ jc += i__;
+ }
+ i__3 = *n;
+ for (j = i__ + ifu; j <= i__3; ++j) {
+ tmp += (r__1 = ap[jc], dabs(r__1)) * (r__2 = x[j + k *
+ x_dim1], dabs(r__2));
+ jc += j;
+/* L50: */
+ }
+ }
+ } else {
+ if (notran) {
+ jc = i__;
+ i__3 = i__ - ifu;
+ for (j = 1; j <= i__3; ++j) {
+ tmp += (r__1 = ap[jc], dabs(r__1)) * (r__2 = x[j + k *
+ x_dim1], dabs(r__2));
+ jc = jc + *n - j;
+/* L60: */
+ }
+ if (unit) {
+ tmp += (r__1 = x[i__ + k * x_dim1], dabs(r__1));
+ }
+ } else {
+ jc = (i__ - 1) * (*n - i__) + i__ * (i__ + 1) / 2;
+ if (unit) {
+ tmp += (r__1 = x[i__ + k * x_dim1], dabs(r__1));
+ }
+ i__3 = *n;
+ for (j = i__ + ifu; j <= i__3; ++j) {
+ tmp += (r__1 = ap[jc + j - i__], dabs(r__1)) * (r__2 =
+ x[j + k * x_dim1], dabs(r__2));
+/* L70: */
+ }
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = dmin(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ r__1 = axbi, r__2 = (*n + 1) * unfl;
+ tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / dmax(r__1,r__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = dmax(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of STPT05 */
+
+} /* stpt05_ */
diff --git a/TESTING/LIN/stpt06.c b/TESTING/LIN/stpt06.c
new file mode 100644
index 0000000..293ebb0
--- /dev/null
+++ b/TESTING/LIN/stpt06.c
@@ -0,0 +1,155 @@
+/* stpt06.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int stpt06_(real *rcond, real *rcondc, char *uplo, char *
+ diag, integer *n, real *ap, real *work, real *rat)
+{
+ /* System generated locals */
+ real r__1, r__2;
+
+ /* Local variables */
+ real eps, rmin, rmax, anorm;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ real bignum;
+ extern doublereal slantp_(char *, char *, char *, integer *, real *, real
+ *);
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STPT06 computes a test ratio comparing RCOND (the reciprocal */
+/* condition number of a triangular matrix A) and RCONDC, the estimate */
+/* computed by STPCON. Information about the triangular matrix A is */
+/* used if one estimate is zero and the other is non-zero to decide if */
+/* underflow in the estimate is justified. */
+
+/* Arguments */
+/* ========= */
+
+/* RCOND (input) REAL */
+/* The estimate of the reciprocal condition number obtained by */
+/* forming the explicit inverse of the matrix A and computing */
+/* RCOND = 1/( norm(A) * norm(inv(A)) ). */
+
+/* RCONDC (input) REAL */
+/* The estimate of the reciprocal condition number computed by */
+/* STPCON. */
+
+/* UPLO (input) CHARACTER */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) REAL array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* RAT (output) REAL */
+/* The test ratio. If both RCOND and RCONDC are nonzero, */
+/* RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1. */
+/* If RAT = 0, the two estimates are exactly the same. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --work;
+ --ap;
+
+ /* Function Body */
+ eps = slamch_("Epsilon");
+ rmax = dmax(*rcond,*rcondc);
+ rmin = dmin(*rcond,*rcondc);
+
+/* Do the easy cases first. */
+
+ if (rmin < 0.f) {
+
+/* Invalid value for RCOND or RCONDC, return 1/EPS. */
+
+ *rat = 1.f / eps;
+
+ } else if (rmin > 0.f) {
+
+/* Both estimates are positive, return RMAX/RMIN - 1. */
+
+ *rat = rmax / rmin - 1.f;
+
+ } else if (rmax == 0.f) {
+
+/* Both estimates zero. */
+
+ *rat = 0.f;
+
+ } else {
+
+/* One estimate is zero, the other is non-zero. If the matrix is */
+/* ill-conditioned, return the nonzero estimate multiplied by */
+/* 1/EPS; if the matrix is badly scaled, return the nonzero */
+/* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum */
+/* element in absolute value in A. */
+
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ anorm = slantp_("M", uplo, diag, n, &ap[1], &work[1]);
+
+/* Computing MIN */
+ r__1 = bignum / dmax(1.f,anorm), r__2 = 1.f / eps;
+ *rat = rmax * dmin(r__1,r__2);
+ }
+
+ return 0;
+
+/* End of STPT06 */
+
+} /* stpt06_ */
diff --git a/TESTING/LIN/strt01.c b/TESTING/LIN/strt01.c
new file mode 100644
index 0000000..92f3ca2
--- /dev/null
+++ b/TESTING/LIN/strt01.c
@@ -0,0 +1,196 @@
+/* strt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int strt01_(char *uplo, char *diag, integer *n, real *a,
+ integer *lda, real *ainv, integer *ldainv, real *rcond, real *work,
+ real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, ainv_dim1, ainv_offset, i__1, i__2;
+
+ /* Local variables */
+ integer j;
+ real eps;
+ extern logical lsame_(char *, char *);
+ real anorm;
+ extern /* Subroutine */ int strmv_(char *, char *, char *, integer *,
+ real *, integer *, real *, integer *);
+ extern doublereal slamch_(char *);
+ real ainvnm;
+ extern doublereal slantr_(char *, char *, char *, integer *, integer *,
+ real *, integer *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STRT01 computes the residual for a triangular matrix A times its */
+/* inverse: */
+/* RESID = norm( A*AINV - I ) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AINV (input/output) REAL array, dimension (LDAINV,N) */
+/* On entry, the (triangular) inverse of the matrix A, in the */
+/* same storage format as A. */
+/* On exit, the contents of AINV are destroyed. */
+
+/* LDAINV (input) INTEGER */
+/* The leading dimension of the array AINV. LDAINV >= max(1,N). */
+
+/* RCOND (output) REAL */
+/* The reciprocal condition number of A, computed as */
+/* 1/(norm(A) * norm(AINV)). */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ ainv_dim1 = *ldainv;
+ ainv_offset = 1 + ainv_dim1;
+ ainv -= ainv_offset;
+ --work;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.f;
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = slamch_("Epsilon");
+ anorm = slantr_("1", uplo, diag, n, n, &a[a_offset], lda, &work[1]);
+ ainvnm = slantr_("1", uplo, diag, n, n, &ainv[ainv_offset], ldainv, &work[
+ 1]);
+ if (anorm <= 0.f || ainvnm <= 0.f) {
+ *rcond = 0.f;
+ *resid = 1.f / eps;
+ return 0;
+ }
+ *rcond = 1.f / anorm / ainvnm;
+
+/* Set the diagonal of AINV to 1 if AINV has unit diagonal. */
+
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ainv[j + j * ainv_dim1] = 1.f;
+/* L10: */
+ }
+ }
+
+/* Compute A * AINV, overwriting AINV. */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ strmv_("Upper", "No transpose", diag, &j, &a[a_offset], lda, &
+ ainv[j * ainv_dim1 + 1], &c__1);
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ strmv_("Lower", "No transpose", diag, &i__2, &a[j + j * a_dim1],
+ lda, &ainv[j + j * ainv_dim1], &c__1);
+/* L30: */
+ }
+ }
+
+/* Subtract 1 from each diagonal element to form A*AINV - I. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ainv[j + j * ainv_dim1] += -1.f;
+/* L40: */
+ }
+
+/* Compute norm(A*AINV - I) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = slantr_("1", uplo, "Non-unit", n, n, &ainv[ainv_offset], ldainv,
+ &work[1]);
+
+ *resid = *resid * *rcond / (real) (*n) / eps;
+
+ return 0;
+
+/* End of STRT01 */
+
+} /* strt01_ */
diff --git a/TESTING/LIN/strt02.c b/TESTING/LIN/strt02.c
new file mode 100644
index 0000000..c4c1c13
--- /dev/null
+++ b/TESTING/LIN/strt02.c
@@ -0,0 +1,199 @@
+/* strt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b10 = -1.f;
+
+/* Subroutine */ int strt02_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, real *a, integer *lda, real *x, integer *ldx, real *b,
+ integer *ldb, real *work, real *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2;
+
+ /* Local variables */
+ integer j;
+ real eps;
+ extern logical lsame_(char *, char *);
+ real anorm, bnorm;
+ extern doublereal sasum_(integer *, real *, integer *);
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ real xnorm;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *), strmv_(char *, char *, char *, integer *,
+ real *, integer *, real *, integer *);
+ extern doublereal slamch_(char *), slantr_(char *, char *, char *,
+ integer *, integer *, real *, integer *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STRT02 computes the residual for the computed solution to a */
+/* triangular system of linear equations A*x = b or A'*x = b. */
+/* Here A is a triangular matrix, A' is the transpose of A, and x and b */
+/* are N by NRHS matrices. The test ratio is the maximum over the */
+/* number of right hand sides of */
+/* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A or A' and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = b (No transpose) */
+/* = 'T': A'*x = b (Transpose) */
+/* = 'C': A'*x = b (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+
+/* Compute the 1-norm of A or A'. */
+
+ if (lsame_(trans, "N")) {
+ anorm = slantr_("1", uplo, diag, n, n, &a[a_offset], lda, &work[1]);
+ } else {
+ anorm = slantr_("I", uplo, diag, n, n, &a[a_offset], lda, &work[1]);
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = slamch_("Epsilon");
+ if (anorm <= 0.f) {
+ *resid = 1.f / eps;
+ return 0;
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ) */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ strmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
+ saxpy_(n, &c_b10, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ bnorm = sasum_(n, &work[1], &c__1);
+ xnorm = sasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.f) {
+ *resid = 1.f / eps;
+ } else {
+/* Computing MAX */
+ r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
+ *resid = dmax(r__1,r__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of STRT02 */
+
+} /* strt02_ */
diff --git a/TESTING/LIN/strt03.c b/TESTING/LIN/strt03.c
new file mode 100644
index 0000000..527c91f
--- /dev/null
+++ b/TESTING/LIN/strt03.c
@@ -0,0 +1,245 @@
+/* strt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int strt03_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, real *a, integer *lda, real *scale, real *cnorm, real *
+ tscal, real *x, integer *ldx, real *b, integer *ldb, real *work, real
+ *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer j, ix;
+ real eps, err;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real xscal;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *);
+ real tnorm, xnorm;
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *), strmv_(char *, char *, char *, integer *,
+ real *, integer *, real *, integer *),
+ slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ real bignum;
+ extern integer isamax_(integer *, real *, integer *);
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STRT03 computes the residual for the solution to a scaled triangular */
+/* system of equations A*x = s*b or A'*x = s*b. */
+/* Here A is a triangular matrix, A' is the transpose of A, s is a */
+/* scalar, and x and b are N by NRHS matrices. The test ratio is the */
+/* maximum over the number of right hand sides of */
+/* norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A or A' and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = s*b (No transpose) */
+/* = 'T': A'*x = s*b (Transpose) */
+/* = 'C': A'*x = s*b (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* SCALE (input) REAL */
+/* The scaling factor s used in solving the triangular system. */
+
+/* CNORM (input) REAL array, dimension (N) */
+/* The 1-norms of the columns of A, not counting the diagonal. */
+
+/* TSCAL (input) REAL */
+/* The scaling factor used in computing the 1-norms in CNORM. */
+/* CNORM actually contains the column norms of TSCAL*A. */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* RESID (output) REAL */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --cnorm;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.f;
+ return 0;
+ }
+ eps = slamch_("Epsilon");
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+
+/* Compute the norm of the triangular matrix A using the column */
+/* norms already computed by SLATRS. */
+
+ tnorm = 0.f;
+ if (lsame_(diag, "N")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ r__2 = tnorm, r__3 = *tscal * (r__1 = a[j + j * a_dim1], dabs(
+ r__1)) + cnorm[j];
+ tnorm = dmax(r__2,r__3);
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ r__1 = tnorm, r__2 = *tscal + cnorm[j];
+ tnorm = dmax(r__1,r__2);
+/* L20: */
+ }
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+ *resid = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ scopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = isamax_(n, &work[1], &c__1);
+/* Computing MAX */
+ r__2 = 1.f, r__3 = (r__1 = x[ix + j * x_dim1], dabs(r__1));
+ xnorm = dmax(r__2,r__3);
+ xscal = 1.f / xnorm / (real) (*n);
+ sscal_(n, &xscal, &work[1], &c__1);
+ strmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
+ r__1 = -(*scale) * xscal;
+ saxpy_(n, &r__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = isamax_(n, &work[1], &c__1);
+ err = *tscal * (r__1 = work[ix], dabs(r__1));
+ ix = isamax_(n, &x[j * x_dim1 + 1], &c__1);
+ xnorm = (r__1 = x[ix + j * x_dim1], dabs(r__1));
+ if (err * smlnum <= xnorm) {
+ if (xnorm > 0.f) {
+ err /= xnorm;
+ }
+ } else {
+ if (err > 0.f) {
+ err = 1.f / eps;
+ }
+ }
+ if (err * smlnum <= tnorm) {
+ if (tnorm > 0.f) {
+ err /= tnorm;
+ }
+ } else {
+ if (err > 0.f) {
+ err = 1.f / eps;
+ }
+ }
+ *resid = dmax(*resid,err);
+/* L30: */
+ }
+
+ return 0;
+
+/* End of STRT03 */
+
+} /* strt03_ */
diff --git a/TESTING/LIN/strt05.c b/TESTING/LIN/strt05.c
new file mode 100644
index 0000000..90f0553
--- /dev/null
+++ b/TESTING/LIN/strt05.c
@@ -0,0 +1,314 @@
+/* strt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int strt05_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, real *a, integer *lda, real *b, integer *ldb, real *x,
+ integer *ldx, real *xact, integer *ldxact, real *ferr, real *berr,
+ real *reslts)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, k, ifu;
+ real eps, tmp, diff, axbi;
+ integer imax;
+ real unfl, ovfl;
+ logical unit;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ real xnorm;
+ extern doublereal slamch_(char *);
+ real errbnd;
+ extern integer isamax_(integer *, real *, integer *);
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STRT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* triangular n by n matrix. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A'* X = B (Transpose) */
+/* = 'C': A'* X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) REAL array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) REAL array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) REAL array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) REAL array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) REAL array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) REAL array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.f;
+ reslts[2] = 0.f;
+ return 0;
+ }
+
+ eps = slamch_("Epsilon");
+ unfl = slamch_("Safe minimum");
+ ovfl = 1.f / unfl;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ unit = lsame_(diag, "U");
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.f;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = isamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ r__2 = (r__1 = x[imax + j * x_dim1], dabs(r__1));
+ xnorm = dmax(r__2,unfl);
+ diff = 0.f;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ r__2 = diff, r__3 = (r__1 = x[i__ + j * x_dim1] - xact[i__ + j *
+ xact_dim1], dabs(r__1));
+ diff = dmax(r__2,r__3);
+/* L10: */
+ }
+
+ if (xnorm > 1.f) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1.f / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
+ errbnd = dmax(r__1,r__2);
+ } else {
+ errbnd = 1.f / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ ifu = 0;
+ if (unit) {
+ ifu = 1;
+ }
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ tmp = (r__1 = b[i__ + k * b_dim1], dabs(r__1));
+ if (upper) {
+ if (! notran) {
+ i__3 = i__ - ifu;
+ for (j = 1; j <= i__3; ++j) {
+ tmp += (r__1 = a[j + i__ * a_dim1], dabs(r__1)) * (
+ r__2 = x[j + k * x_dim1], dabs(r__2));
+/* L40: */
+ }
+ if (unit) {
+ tmp += (r__1 = x[i__ + k * x_dim1], dabs(r__1));
+ }
+ } else {
+ if (unit) {
+ tmp += (r__1 = x[i__ + k * x_dim1], dabs(r__1));
+ }
+ i__3 = *n;
+ for (j = i__ + ifu; j <= i__3; ++j) {
+ tmp += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * (
+ r__2 = x[j + k * x_dim1], dabs(r__2));
+/* L50: */
+ }
+ }
+ } else {
+ if (notran) {
+ i__3 = i__ - ifu;
+ for (j = 1; j <= i__3; ++j) {
+ tmp += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * (
+ r__2 = x[j + k * x_dim1], dabs(r__2));
+/* L60: */
+ }
+ if (unit) {
+ tmp += (r__1 = x[i__ + k * x_dim1], dabs(r__1));
+ }
+ } else {
+ if (unit) {
+ tmp += (r__1 = x[i__ + k * x_dim1], dabs(r__1));
+ }
+ i__3 = *n;
+ for (j = i__ + ifu; j <= i__3; ++j) {
+ tmp += (r__1 = a[j + i__ * a_dim1], dabs(r__1)) * (
+ r__2 = x[j + k * x_dim1], dabs(r__2));
+/* L70: */
+ }
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = dmin(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ r__1 = axbi, r__2 = (*n + 1) * unfl;
+ tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / dmax(r__1,r__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = dmax(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of STRT05 */
+
+} /* strt05_ */
diff --git a/TESTING/LIN/strt06.c b/TESTING/LIN/strt06.c
new file mode 100644
index 0000000..7b7cda6
--- /dev/null
+++ b/TESTING/LIN/strt06.c
@@ -0,0 +1,163 @@
+/* strt06.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int strt06_(real *rcond, real *rcondc, char *uplo, char *
+ diag, integer *n, real *a, integer *lda, real *work, real *rat)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset;
+ real r__1, r__2;
+
+ /* Local variables */
+ real eps, rmin, rmax, anorm;
+ extern /* Subroutine */ int slabad_(real *, real *);
+ extern doublereal slamch_(char *);
+ real bignum;
+ extern doublereal slantr_(char *, char *, char *, integer *, integer *,
+ real *, integer *, real *);
+ real smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STRT06 computes a test ratio comparing RCOND (the reciprocal */
+/* condition number of a triangular matrix A) and RCONDC, the estimate */
+/* computed by STRCON. Information about the triangular matrix A is */
+/* used if one estimate is zero and the other is non-zero to decide if */
+/* underflow in the estimate is justified. */
+
+/* Arguments */
+/* ========= */
+
+/* RCOND (input) REAL */
+/* The estimate of the reciprocal condition number obtained by */
+/* forming the explicit inverse of the matrix A and computing */
+/* RCOND = 1/( norm(A) * norm(inv(A)) ). */
+
+/* RCONDC (input) REAL */
+/* The estimate of the reciprocal condition number computed by */
+/* STRCON. */
+
+/* UPLO (input) CHARACTER */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+/* RAT (output) REAL */
+/* The test ratio. If both RCOND and RCONDC are nonzero, */
+/* RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1. */
+/* If RAT = 0, the two estimates are exactly the same. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ eps = slamch_("Epsilon");
+ rmax = dmax(*rcond,*rcondc);
+ rmin = dmin(*rcond,*rcondc);
+
+/* Do the easy cases first. */
+
+ if (rmin < 0.f) {
+
+/* Invalid value for RCOND or RCONDC, return 1/EPS. */
+
+ *rat = 1.f / eps;
+
+ } else if (rmin > 0.f) {
+
+/* Both estimates are positive, return RMAX/RMIN - 1. */
+
+ *rat = rmax / rmin - 1.f;
+
+ } else if (rmax == 0.f) {
+
+/* Both estimates zero. */
+
+ *rat = 0.f;
+
+ } else {
+
+/* One estimate is zero, the other is non-zero. If the matrix is */
+/* ill-conditioned, return the nonzero estimate multiplied by */
+/* 1/EPS; if the matrix is badly scaled, return the nonzero */
+/* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum */
+/* element in absolute value in A. */
+
+ smlnum = slamch_("Safe minimum");
+ bignum = 1.f / smlnum;
+ slabad_(&smlnum, &bignum);
+ anorm = slantr_("M", uplo, diag, n, n, &a[a_offset], lda, &work[1]);
+
+/* Computing MIN */
+ r__1 = bignum / dmax(1.f,anorm), r__2 = 1.f / eps;
+ *rat = rmax * dmin(r__1,r__2);
+ }
+
+ return 0;
+
+/* End of STRT06 */
+
+} /* strt06_ */
diff --git a/TESTING/LIN/stzt01.c b/TESTING/LIN/stzt01.c
new file mode 100644
index 0000000..0b478e7
--- /dev/null
+++ b/TESTING/LIN/stzt01.c
@@ -0,0 +1,172 @@
+/* stzt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static real c_b6 = 0.f;
+static real c_b13 = -1.f;
+static integer c__1 = 1;
+
+doublereal stzt01_(integer *m, integer *n, real *a, real *af, integer *lda,
+ real *tau, real *work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2;
+ real ret_val;
+
+ /* Local variables */
+ integer i__, j;
+ real norma, rwork[1];
+ extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
+ real *, integer *);
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), slaset_(
+ char *, integer *, integer *, real *, real *, real *, integer *), slatzm_(char *, integer *, integer *, real *, integer *,
+ real *, real *, real *, integer *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STZT01 returns */
+/* || A - R*Q || / ( M * eps * ||A|| ) */
+/* for an upper trapezoidal A that was factored with STZRQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices A and AF. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and AF. */
+
+/* A (input) REAL array, dimension (LDA,N) */
+/* The original upper trapezoidal M by N matrix A. */
+
+/* AF (input) REAL array, dimension (LDA,N) */
+/* The output of STZRQF for input matrix A. */
+/* The lower triangle is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A and AF. */
+
+/* TAU (input) REAL array, dimension (M) */
+/* Details of the Householder transformations as returned by */
+/* STZRQF. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= m*n + m. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ if (*lwork < *m * *n + *m) {
+ xerbla_("STZT01", &c__8);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return ret_val;
+ }
+
+ norma = slange_("One-norm", m, n, &a[a_offset], lda, rwork);
+
+/* Copy upper triangle R */
+
+ slaset_("Full", m, n, &c_b6, &c_b6, &work[1], m);
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ work[(j - 1) * *m + i__] = af[i__ + j * af_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* R = R * P(1) * ... *P(m) */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n - *m + 1;
+ slatzm_("Right", &i__, &i__2, &af[i__ + (*m + 1) * af_dim1], lda, &
+ tau[i__], &work[(i__ - 1) * *m + 1], &work[*m * *m + 1], m, &
+ work[*m * *n + 1]);
+/* L30: */
+ }
+
+/* R = R - A */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ saxpy_(m, &c_b13, &a[i__ * a_dim1 + 1], &c__1, &work[(i__ - 1) * *m +
+ 1], &c__1);
+/* L40: */
+ }
+
+ ret_val = slange_("One-norm", m, n, &work[1], m, rwork);
+
+ ret_val /= slamch_("Epsilon") * (real) max(*m,*n);
+ if (norma != 0.f) {
+ ret_val /= norma;
+ }
+
+ return ret_val;
+
+/* End of STZT01 */
+
+} /* stzt01_ */
diff --git a/TESTING/LIN/stzt02.c b/TESTING/LIN/stzt02.c
new file mode 100644
index 0000000..f48de62
--- /dev/null
+++ b/TESTING/LIN/stzt02.c
@@ -0,0 +1,154 @@
+/* stzt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__7 = 7;
+static real c_b5 = 0.f;
+static real c_b6 = 1.f;
+
+doublereal stzt02_(integer *m, integer *n, real *af, integer *lda, real *tau,
+ real *work, integer *lwork)
+{
+ /* System generated locals */
+ integer af_dim1, af_offset, i__1, i__2;
+ real ret_val;
+
+ /* Local variables */
+ integer i__;
+ real rwork[1];
+ extern doublereal slamch_(char *), slange_(char *, integer *,
+ integer *, real *, integer *, real *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), slaset_(
+ char *, integer *, integer *, real *, real *, real *, integer *), slatzm_(char *, integer *, integer *, real *, integer *,
+ real *, real *, real *, integer *, real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* STZT02 returns */
+/* || I - Q'*Q || / ( M * eps) */
+/* where the matrix Q is defined by the Householder transformations */
+/* generated by STZRQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix AF. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix AF. */
+
+/* AF (input) REAL array, dimension (LDA,N) */
+/* The output of STZRQF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array AF. */
+
+/* TAU (input) REAL array, dimension (M) */
+/* Details of the Householder transformations as returned by */
+/* STZRQF. */
+
+/* WORK (workspace) REAL array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* length of WORK array. Must be >= N*N+N */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.f;
+
+ if (*lwork < *n * *n + *n) {
+ xerbla_("STZT02", &c__7);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return ret_val;
+ }
+
+/* Q := I */
+
+ slaset_("Full", n, n, &c_b5, &c_b6, &work[1], n);
+
+/* Q := P(1) * ... * P(m) * Q */
+
+ for (i__ = *m; i__ >= 1; --i__) {
+ i__1 = *n - *m + 1;
+ slatzm_("Left", &i__1, n, &af[i__ + (*m + 1) * af_dim1], lda, &tau[
+ i__], &work[i__], &work[*m + 1], n, &work[*n * *n + 1]);
+/* L10: */
+ }
+
+/* Q := P(m) * ... * P(1) * Q */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n - *m + 1;
+ slatzm_("Left", &i__2, n, &af[i__ + (*m + 1) * af_dim1], lda, &tau[
+ i__], &work[i__], &work[*m + 1], n, &work[*n * *n + 1]);
+/* L20: */
+ }
+
+/* Q := Q - I */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ work[(i__ - 1) * *n + i__] += -1.f;
+/* L30: */
+ }
+
+ ret_val = slange_("One-norm", n, n, &work[1], n, rwork) / (
+ slamch_("Epsilon") * (real) max(*m,*n));
+ return ret_val;
+
+/* End of STZT02 */
+
+} /* stzt02_ */
diff --git a/TESTING/LIN/tags b/TESTING/LIN/tags
new file mode 100644
index 0000000..dcc57e5
--- /dev/null
+++ b/TESTING/LIN/tags
@@ -0,0 +1,460 @@
+!_TAG_FILE_FORMAT 2 /extended format; --format=1 will not append ;" to lines/
+!_TAG_FILE_SORTED 1 /0=unsorted, 1=sorted, 2=foldcase/
+!_TAG_PROGRAM_AUTHOR Darren Hiebert /dhiebert at users.sourceforge.net/
+!_TAG_PROGRAM_NAME Exuberant Ctags //
+!_TAG_PROGRAM_URL http://ctags.sourceforge.net /official site/
+!_TAG_PROGRAM_VERSION 5.7 //
+10 cdrvgbx.f /^ 10 CONTINUE$/;" l subroutine:CDRVGB file:
+10 cdrvgex.f /^ 10 CONTINUE$/;" l subroutine:CDRVGE file:
+10 cdrvpox.f /^ 10 CONTINUE$/;" l subroutine:CDRVPO file:
+10 ddrvgbx.f /^ 10 CONTINUE$/;" l subroutine:DDRVGB file:
+10 ddrvgex.f /^ 10 CONTINUE$/;" l subroutine:DDRVGE file:
+10 ddrvpox.f /^ 10 CONTINUE$/;" l subroutine:DDRVPO file:
+10 sdrvgbx.f /^ 10 CONTINUE$/;" l subroutine:SDRVGB file:
+10 sdrvgex.f /^ 10 CONTINUE$/;" l subroutine:SDRVGE file:
+10 sdrvpox.f /^ 10 CONTINUE$/;" l subroutine:SDRVPO file:
+10 zdrvgbx.f /^ 10 CONTINUE$/;" l subroutine:ZDRVGB file:
+10 zdrvgex.f /^ 10 CONTINUE$/;" l subroutine:ZDRVGE file:
+10 zdrvpox.f /^ 10 CONTINUE$/;" l subroutine:ZDRVPO file:
+100 cdrvgbx.f /^ 100 CONTINUE$/;" l subroutine:CDRVGB file:
+100 cdrvpox.f /^ 100 CONTINUE$/;" l subroutine:CDRVPO file:
+100 ddrvgbx.f /^ 100 CONTINUE$/;" l subroutine:DDRVGB file:
+100 ddrvpox.f /^ 100 CONTINUE$/;" l subroutine:DDRVPO file:
+100 sdrvgbx.f /^ 100 CONTINUE$/;" l subroutine:SDRVGB file:
+100 sdrvpox.f /^ 100 CONTINUE$/;" l subroutine:SDRVPO file:
+100 zdrvgbx.f /^ 100 CONTINUE$/;" l subroutine:ZDRVGB file:
+100 zdrvpox.f /^ 100 CONTINUE$/;" l subroutine:ZDRVPO file:
+110 cdrvgbx.f /^ 110 CONTINUE$/;" l subroutine:CDRVGB file:
+110 cdrvpox.f /^ 110 CONTINUE$/;" l subroutine:CDRVPO file:
+110 ddrvgbx.f /^ 110 CONTINUE$/;" l subroutine:DDRVGB file:
+110 ddrvpox.f /^ 110 CONTINUE$/;" l subroutine:DDRVPO file:
+110 sdrvgbx.f /^ 110 CONTINUE$/;" l subroutine:SDRVGB file:
+110 sdrvpox.f /^ 110 CONTINUE$/;" l subroutine:SDRVPO file:
+110 zdrvgbx.f /^ 110 CONTINUE$/;" l subroutine:ZDRVGB file:
+110 zdrvpox.f /^ 110 CONTINUE$/;" l subroutine:ZDRVPO file:
+120 cdrvgbx.f /^ 120 CONTINUE$/;" l subroutine:CDRVGB file:
+120 cdrvpox.f /^ 120 CONTINUE$/;" l subroutine:CDRVPO file:
+120 ddrvgbx.f /^ 120 CONTINUE$/;" l subroutine:DDRVGB file:
+120 ddrvpox.f /^ 120 CONTINUE$/;" l subroutine:DDRVPO file:
+120 sdrvgbx.f /^ 120 CONTINUE$/;" l subroutine:SDRVGB file:
+120 sdrvpox.f /^ 120 CONTINUE$/;" l subroutine:SDRVPO file:
+120 zdrvgbx.f /^ 120 CONTINUE$/;" l subroutine:ZDRVGB file:
+120 zdrvpox.f /^ 120 CONTINUE$/;" l subroutine:ZDRVPO file:
+130 cdrvgbx.f /^ 130 CONTINUE$/;" l subroutine:CDRVGB file:
+130 cdrvpox.f /^ 130 CONTINUE$/;" l subroutine:CDRVPO file:
+130 ddrvgbx.f /^ 130 CONTINUE$/;" l subroutine:DDRVGB file:
+130 ddrvpox.f /^ 130 CONTINUE$/;" l subroutine:DDRVPO file:
+130 sdrvgbx.f /^ 130 CONTINUE$/;" l subroutine:SDRVGB file:
+130 sdrvpox.f /^ 130 CONTINUE$/;" l subroutine:SDRVPO file:
+130 zdrvgbx.f /^ 130 CONTINUE$/;" l subroutine:ZDRVGB file:
+130 zdrvpox.f /^ 130 CONTINUE$/;" l subroutine:ZDRVPO file:
+140 cdrvgbx.f /^ 140 CONTINUE$/;" l subroutine:CDRVGB file:
+140 ddrvgbx.f /^ 140 CONTINUE$/;" l subroutine:DDRVGB file:
+140 sdrvgbx.f /^ 140 CONTINUE$/;" l subroutine:SDRVGB file:
+140 zdrvgbx.f /^ 140 CONTINUE$/;" l subroutine:ZDRVGB file:
+150 cdrvgbx.f /^ 150 CONTINUE$/;" l subroutine:CDRVGB file:
+150 ddrvgbx.f /^ 150 CONTINUE$/;" l subroutine:DDRVGB file:
+150 sdrvgbx.f /^ 150 CONTINUE$/;" l subroutine:SDRVGB file:
+150 zdrvgbx.f /^ 150 CONTINUE$/;" l subroutine:ZDRVGB file:
+20 cdrvgbx.f /^ 20 CONTINUE$/;" l subroutine:CDRVGB file:
+20 cdrvgex.f /^ 20 CONTINUE$/;" l subroutine:CDRVGE file:
+20 cdrvpox.f /^ 20 CONTINUE$/;" l subroutine:CDRVPO file:
+20 ddrvgbx.f /^ 20 CONTINUE$/;" l subroutine:DDRVGB file:
+20 ddrvgex.f /^ 20 CONTINUE$/;" l subroutine:DDRVGE file:
+20 ddrvpox.f /^ 20 CONTINUE$/;" l subroutine:DDRVPO file:
+20 sdrvgbx.f /^ 20 CONTINUE$/;" l subroutine:SDRVGB file:
+20 sdrvgex.f /^ 20 CONTINUE$/;" l subroutine:SDRVGE file:
+20 sdrvpox.f /^ 20 CONTINUE$/;" l subroutine:SDRVPO file:
+20 zdrvgbx.f /^ 20 CONTINUE$/;" l subroutine:ZDRVGB file:
+20 zdrvgex.f /^ 20 CONTINUE$/;" l subroutine:ZDRVGE file:
+20 zdrvpox.f /^ 20 CONTINUE$/;" l subroutine:ZDRVPO file:
+30 cdrvgbx.f /^ 30 CONTINUE$/;" l subroutine:CDRVGB file:
+30 cdrvgex.f /^ 30 CONTINUE$/;" l subroutine:CDRVGE file:
+30 cdrvpox.f /^ 30 CONTINUE$/;" l subroutine:CDRVPO file:
+30 ddrvgbx.f /^ 30 CONTINUE$/;" l subroutine:DDRVGB file:
+30 ddrvgex.f /^ 30 CONTINUE$/;" l subroutine:DDRVGE file:
+30 ddrvpox.f /^ 30 CONTINUE$/;" l subroutine:DDRVPO file:
+30 sdrvgbx.f /^ 30 CONTINUE$/;" l subroutine:SDRVGB file:
+30 sdrvgex.f /^ 30 CONTINUE$/;" l subroutine:SDRVGE file:
+30 sdrvpox.f /^ 30 CONTINUE$/;" l subroutine:SDRVPO file:
+30 zdrvgbx.f /^ 30 CONTINUE$/;" l subroutine:ZDRVGB file:
+30 zdrvgex.f /^ 30 CONTINUE$/;" l subroutine:ZDRVGE file:
+30 zdrvpox.f /^ 30 CONTINUE$/;" l subroutine:ZDRVPO file:
+40 cdrvgbx.f /^ 40 CONTINUE$/;" l subroutine:CDRVGB file:
+40 cdrvgex.f /^ 40 CONTINUE$/;" l subroutine:CDRVGE file:
+40 cdrvpox.f /^ 40 CONTINUE$/;" l subroutine:CDRVPO file:
+40 ddrvgbx.f /^ 40 CONTINUE$/;" l subroutine:DDRVGB file:
+40 ddrvgex.f /^ 40 CONTINUE$/;" l subroutine:DDRVGE file:
+40 ddrvpox.f /^ 40 CONTINUE$/;" l subroutine:DDRVPO file:
+40 sdrvgbx.f /^ 40 CONTINUE$/;" l subroutine:SDRVGB file:
+40 sdrvgex.f /^ 40 CONTINUE$/;" l subroutine:SDRVGE file:
+40 sdrvpox.f /^ 40 CONTINUE$/;" l subroutine:SDRVPO file:
+40 zdrvgbx.f /^ 40 CONTINUE$/;" l subroutine:ZDRVGB file:
+40 zdrvgex.f /^ 40 CONTINUE$/;" l subroutine:ZDRVGE file:
+40 zdrvpox.f /^ 40 CONTINUE$/;" l subroutine:ZDRVPO file:
+45 cdrvgbx.f /^ 45 CONTINUE$/;" l subroutine:CDRVGB file:
+45 cdrvgex.f /^ 45 CONTINUE$/;" l subroutine:CDRVGE file:
+45 ddrvgbx.f /^ 45 CONTINUE$/;" l subroutine:DDRVGB file:
+45 ddrvgex.f /^ 45 CONTINUE$/;" l subroutine:DDRVGE file:
+45 sdrvgbx.f /^ 45 CONTINUE$/;" l subroutine:SDRVGB file:
+45 sdrvgex.f /^ 45 CONTINUE$/;" l subroutine:SDRVGE file:
+45 zdrvgbx.f /^ 45 CONTINUE$/;" l subroutine:ZDRVGB file:
+45 zdrvgex.f /^ 45 CONTINUE$/;" l subroutine:ZDRVGE file:
+50 cdrvgbx.f /^ 50 CONTINUE$/;" l subroutine:CDRVGB file:
+50 cdrvgex.f /^ 50 CONTINUE$/;" l subroutine:CDRVGE file:
+50 cdrvpox.f /^ 50 CONTINUE$/;" l subroutine:CDRVPO file:
+50 ddrvgbx.f /^ 50 CONTINUE$/;" l subroutine:DDRVGB file:
+50 ddrvgex.f /^ 50 CONTINUE$/;" l subroutine:DDRVGE file:
+50 ddrvpox.f /^ 50 CONTINUE$/;" l subroutine:DDRVPO file:
+50 sdrvgbx.f /^ 50 CONTINUE$/;" l subroutine:SDRVGB file:
+50 sdrvgex.f /^ 50 CONTINUE$/;" l subroutine:SDRVGE file:
+50 sdrvpox.f /^ 50 CONTINUE$/;" l subroutine:SDRVPO file:
+50 zdrvgbx.f /^ 50 CONTINUE$/;" l subroutine:ZDRVGB file:
+50 zdrvgex.f /^ 50 CONTINUE$/;" l subroutine:ZDRVGE file:
+50 zdrvpox.f /^ 50 CONTINUE$/;" l subroutine:ZDRVPO file:
+60 cdrvgbx.f /^ 60 CONTINUE$/;" l subroutine:CDRVGB file:
+60 cdrvgex.f /^ 60 CONTINUE$/;" l subroutine:CDRVGE file:
+60 cdrvpox.f /^ 60 CONTINUE$/;" l subroutine:CDRVPO file:
+60 ddrvgbx.f /^ 60 CONTINUE$/;" l subroutine:DDRVGB file:
+60 ddrvgex.f /^ 60 CONTINUE$/;" l subroutine:DDRVGE file:
+60 ddrvpox.f /^ 60 CONTINUE$/;" l subroutine:DDRVPO file:
+60 sdrvgbx.f /^ 60 CONTINUE$/;" l subroutine:SDRVGB file:
+60 sdrvgex.f /^ 60 CONTINUE$/;" l subroutine:SDRVGE file:
+60 sdrvpox.f /^ 60 CONTINUE$/;" l subroutine:SDRVPO file:
+60 zdrvgbx.f /^ 60 CONTINUE$/;" l subroutine:ZDRVGB file:
+60 zdrvgex.f /^ 60 CONTINUE$/;" l subroutine:ZDRVGE file:
+60 zdrvpox.f /^ 60 CONTINUE$/;" l subroutine:ZDRVPO file:
+70 cdrvgbx.f /^ 70 CONTINUE$/;" l subroutine:CDRVGB file:
+70 cdrvgex.f /^ 70 CONTINUE$/;" l subroutine:CDRVGE file:
+70 cdrvpox.f /^ 70 CONTINUE$/;" l subroutine:CDRVPO file:
+70 ddrvgbx.f /^ 70 CONTINUE$/;" l subroutine:DDRVGB file:
+70 ddrvgex.f /^ 70 CONTINUE$/;" l subroutine:DDRVGE file:
+70 ddrvpox.f /^ 70 CONTINUE$/;" l subroutine:DDRVPO file:
+70 sdrvgbx.f /^ 70 CONTINUE$/;" l subroutine:SDRVGB file:
+70 sdrvgex.f /^ 70 CONTINUE$/;" l subroutine:SDRVGE file:
+70 sdrvpox.f /^ 70 CONTINUE$/;" l subroutine:SDRVPO file:
+70 zdrvgbx.f /^ 70 CONTINUE$/;" l subroutine:ZDRVGB file:
+70 zdrvgex.f /^ 70 CONTINUE$/;" l subroutine:ZDRVGE file:
+70 zdrvpox.f /^ 70 CONTINUE$/;" l subroutine:ZDRVPO file:
+80 cdrvgbx.f /^ 80 CONTINUE$/;" l subroutine:CDRVGB file:
+80 cdrvgex.f /^ 80 CONTINUE$/;" l subroutine:CDRVGE file:
+80 cdrvpox.f /^ 80 CONTINUE$/;" l subroutine:CDRVPO file:
+80 ddrvgbx.f /^ 80 CONTINUE$/;" l subroutine:DDRVGB file:
+80 ddrvgex.f /^ 80 CONTINUE$/;" l subroutine:DDRVGE file:
+80 ddrvpox.f /^ 80 CONTINUE$/;" l subroutine:DDRVPO file:
+80 sdrvgbx.f /^ 80 CONTINUE$/;" l subroutine:SDRVGB file:
+80 sdrvgex.f /^ 80 CONTINUE$/;" l subroutine:SDRVGE file:
+80 sdrvpox.f /^ 80 CONTINUE$/;" l subroutine:SDRVPO file:
+80 zdrvgbx.f /^ 80 CONTINUE$/;" l subroutine:ZDRVGB file:
+80 zdrvgex.f /^ 80 CONTINUE$/;" l subroutine:ZDRVGE file:
+80 zdrvpox.f /^ 80 CONTINUE$/;" l subroutine:ZDRVPO file:
+85 cdrvpox.f /^ 85 CONTINUE$/;" l subroutine:CDRVPO file:
+85 ddrvpox.f /^ 85 CONTINUE$/;" l subroutine:DDRVPO file:
+85 sdrvpox.f /^ 85 CONTINUE$/;" l subroutine:SDRVPO file:
+85 zdrvpox.f /^ 85 CONTINUE$/;" l subroutine:ZDRVPO file:
+90 cdrvgbx.f /^ 90 CONTINUE$/;" l subroutine:CDRVGB file:
+90 cdrvgex.f /^ 90 CONTINUE$/;" l subroutine:CDRVGE file:
+90 cdrvpox.f /^ 90 CONTINUE$/;" l subroutine:CDRVPO file:
+90 ddrvgbx.f /^ 90 CONTINUE$/;" l subroutine:DDRVGB file:
+90 ddrvgex.f /^ 90 CONTINUE$/;" l subroutine:DDRVGE file:
+90 ddrvpox.f /^ 90 CONTINUE$/;" l subroutine:DDRVPO file:
+90 sdrvgbx.f /^ 90 CONTINUE$/;" l subroutine:SDRVGB file:
+90 sdrvgex.f /^ 90 CONTINUE$/;" l subroutine:SDRVGE file:
+90 sdrvpox.f /^ 90 CONTINUE$/;" l subroutine:SDRVPO file:
+90 zdrvgbx.f /^ 90 CONTINUE$/;" l subroutine:ZDRVGB file:
+90 zdrvgex.f /^ 90 CONTINUE$/;" l subroutine:ZDRVGE file:
+90 zdrvpox.f /^ 90 CONTINUE$/;" l subroutine:ZDRVPO file:
+9995 cdrvgbx.f /^ 9995 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',',$/;" l subroutine:CDRVGB file:
+9995 ddrvgbx.f /^ 9995 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',',$/;" l subroutine:DDRVGB file:
+9995 sdrvgbx.f /^ 9995 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',',$/;" l subroutine:SDRVGB file:
+9995 zdrvgbx.f /^ 9995 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',',$/;" l subroutine:ZDRVGB file:
+9996 cdrvgbx.f /^ 9996 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',',$/;" l subroutine:CDRVGB file:
+9996 ddrvgbx.f /^ 9996 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',',$/;" l subroutine:DDRVGB file:
+9996 sdrvgbx.f /^ 9996 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',',$/;" l subroutine:SDRVGB file:
+9996 zdrvgbx.f /^ 9996 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',',$/;" l subroutine:ZDRVGB file:
+9997 cdrvgbx.f /^ 9997 FORMAT( 1X, A, ', N=', I5, ', KL=', I5, ', KU=', I5, ', type ',$/;" l subroutine:CDRVGB file:
+9997 cdrvgex.f /^ 9997 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5,$/;" l subroutine:CDRVGE file:
+9997 cdrvpox.f /^ 9997 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5,$/;" l subroutine:CDRVPO file:
+9997 ddrvgbx.f /^ 9997 FORMAT( 1X, A, ', N=', I5, ', KL=', I5, ', KU=', I5, ', type ',$/;" l subroutine:DDRVGB file:
+9997 ddrvgex.f /^ 9997 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5,$/;" l subroutine:DDRVGE file:
+9997 ddrvpox.f /^ 9997 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5,$/;" l subroutine:DDRVPO file:
+9997 sdrvgbx.f /^ 9997 FORMAT( 1X, A, ', N=', I5, ', KL=', I5, ', KU=', I5, ', type ',$/;" l subroutine:SDRVGB file:
+9997 sdrvgex.f /^ 9997 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5,$/;" l subroutine:SDRVGE file:
+9997 sdrvpox.f /^ 9997 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5,$/;" l subroutine:SDRVPO file:
+9997 zdrvgbx.f /^ 9997 FORMAT( 1X, A, ', N=', I5, ', KL=', I5, ', KU=', I5, ', type ',$/;" l subroutine:ZDRVGB file:
+9997 zdrvgex.f /^ 9997 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5,$/;" l subroutine:ZDRVGE file:
+9997 zdrvpox.f /^ 9997 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5,$/;" l subroutine:ZDRVPO file:
+9998 cdrvgbx.f /^ 9998 FORMAT( ' *** In CDRVGB, LAFB=', I5, ' is too small for N=', I5,$/;" l subroutine:CDRVGB file:
+9998 cdrvgex.f /^ 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5,$/;" l subroutine:CDRVGE file:
+9998 cdrvpox.f /^ 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5,$/;" l subroutine:CDRVPO file:
+9998 ddrvgbx.f /^ 9998 FORMAT( ' *** In DDRVGB, LAFB=', I5, ' is too small for N=', I5,$/;" l subroutine:DDRVGB file:
+9998 ddrvgex.f /^ 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5,$/;" l subroutine:DDRVGE file:
+9998 ddrvpox.f /^ 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5,$/;" l subroutine:DDRVPO file:
+9998 sdrvgbx.f /^ 9998 FORMAT( ' *** In SDRVGB, LAFB=', I5, ' is too small for N=', I5,$/;" l subroutine:SDRVGB file:
+9998 sdrvgex.f /^ 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5,$/;" l subroutine:SDRVGE file:
+9998 sdrvpox.f /^ 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5,$/;" l subroutine:SDRVPO file:
+9998 zdrvgbx.f /^ 9998 FORMAT( ' *** In ZDRVGB, LAFB=', I5, ' is too small for N=', I5,$/;" l subroutine:ZDRVGB file:
+9998 zdrvgex.f /^ 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5,$/;" l subroutine:ZDRVGE file:
+9998 zdrvpox.f /^ 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5,$/;" l subroutine:ZDRVPO file:
+9999 cdrvgbx.f /^ 9999 FORMAT( ' *** In CDRVGB, LA=', I5, ' is too small for N=', I5,$/;" l subroutine:CDRVGB file:
+9999 cdrvgex.f /^ 9999 FORMAT( 1X, A, ', N =', I5, ', type ', I2, ', test(', I2, ') =',$/;" l subroutine:CDRVGE file:
+9999 cdrvpox.f /^ 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I1,$/;" l subroutine:CDRVPO file:
+9999 ddrvgbx.f /^ 9999 FORMAT( ' *** In DDRVGB, LA=', I5, ' is too small for N=', I5,$/;" l subroutine:DDRVGB file:
+9999 ddrvgex.f /^ 9999 FORMAT( 1X, A, ', N =', I5, ', type ', I2, ', test(', I2, ') =',$/;" l subroutine:DDRVGE file:
+9999 ddrvpox.f /^ 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I1,$/;" l subroutine:DDRVPO file:
+9999 sdrvgbx.f /^ 9999 FORMAT( ' *** In SDRVGB, LA=', I5, ' is too small for N=', I5,$/;" l subroutine:SDRVGB file:
+9999 sdrvgex.f /^ 9999 FORMAT( 1X, A, ', N =', I5, ', type ', I2, ', test(', I2, ') =',$/;" l subroutine:SDRVGE file:
+9999 sdrvpox.f /^ 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I1,$/;" l subroutine:SDRVPO file:
+9999 zdrvgbx.f /^ 9999 FORMAT( ' *** In ZDRVGB, LA=', I5, ' is too small for N=', I5,$/;" l subroutine:ZDRVGB file:
+9999 zdrvgex.f /^ 9999 FORMAT( 1X, A, ', N =', I5, ', type ', I2, ', test(', I2, ') =',$/;" l subroutine:ZDRVGE file:
+9999 zdrvpox.f /^ 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I1,$/;" l subroutine:ZDRVPO file:
+CDRVGB cdrvgbx.f /^ SUBROUTINE CDRVGB(/;" s
+CDRVGE cdrvgex.f /^ SUBROUTINE CDRVGE(/;" s
+CDRVPO cdrvpox.f /^ SUBROUTINE CDRVPO(/;" s
+DDRVGB ddrvgbx.f /^ SUBROUTINE DDRVGB(/;" s
+DDRVGE ddrvgex.f /^ SUBROUTINE DDRVGE(/;" s
+DDRVPO ddrvpox.f /^ SUBROUTINE DDRVPO(/;" s
+INFOC cdrvgbx.f 144;" c subroutine:CDRVGB
+INFOC cdrvgex.f 137;" c subroutine:CDRVGE
+INFOC cdrvpox.f 125;" c subroutine:CDRVPO
+INFOC ddrvgbx.f 142;" c subroutine:DDRVGB
+INFOC ddrvgex.f 137;" c subroutine:DDRVGE
+INFOC ddrvpox.f 130;" c subroutine:DDRVPO
+INFOC sdrvgbx.f 142;" c subroutine:SDRVGB
+INFOC sdrvgex.f 137;" c subroutine:SDRVGE
+INFOC sdrvpox.f 130;" c subroutine:SDRVPO
+INFOC zdrvgbx.f 142;" c subroutine:ZDRVGB
+INFOC zdrvgex.f 137;" c subroutine:ZDRVGE
+INFOC zdrvpox.f 125;" c subroutine:ZDRVPO
+SDRVGB sdrvgbx.f /^ SUBROUTINE SDRVGB(/;" s
+SDRVGE sdrvgex.f /^ SUBROUTINE SDRVGE(/;" s
+SDRVPO sdrvpox.f /^ SUBROUTINE SDRVPO(/;" s
+SRNAMC cdrvgbx.f 145;" c subroutine:CDRVGB
+SRNAMC cdrvgex.f 138;" c subroutine:CDRVGE
+SRNAMC cdrvpox.f 126;" c subroutine:CDRVPO
+SRNAMC ddrvgbx.f 143;" c subroutine:DDRVGB
+SRNAMC ddrvgex.f 138;" c subroutine:DDRVGE
+SRNAMC ddrvpox.f 131;" c subroutine:DDRVPO
+SRNAMC sdrvgbx.f 143;" c subroutine:SDRVGB
+SRNAMC sdrvgex.f 138;" c subroutine:SDRVGE
+SRNAMC sdrvpox.f 131;" c subroutine:SDRVPO
+SRNAMC zdrvgbx.f 143;" c subroutine:ZDRVGB
+SRNAMC zdrvgex.f 138;" c subroutine:ZDRVGE
+SRNAMC zdrvpox.f 126;" c subroutine:ZDRVPO
+ZDRVGB zdrvgbx.f /^ SUBROUTINE ZDRVGB(/;" s
+ZDRVGE zdrvgex.f /^ SUBROUTINE ZDRVGE(/;" s
+ZDRVPO zdrvpox.f /^ SUBROUTINE ZDRVPO(/;" s
+c__0 cdrvgbx.c /^static integer c__0 = 0;$/;" v file:
+c__0 cdrvgex.c /^static integer c__0 = 0;$/;" v file:
+c__0 cdrvpox.c /^static integer c__0 = 0;$/;" v file:
+c__0 ddrvgbx.c /^static integer c__0 = 0;$/;" v file:
+c__0 ddrvgex.c /^static integer c__0 = 0;$/;" v file:
+c__0 ddrvpox.c /^static integer c__0 = 0;$/;" v file:
+c__0 sdrvgbx.c /^static integer c__0 = 0;$/;" v file:
+c__0 sdrvgex.c /^static integer c__0 = 0;$/;" v file:
+c__0 sdrvpox.c /^static integer c__0 = 0;$/;" v file:
+c__0 zdrvgbx.c /^static integer c__0 = 0;$/;" v file:
+c__0 zdrvgex.c /^static integer c__0 = 0;$/;" v file:
+c__0 zdrvpox.c /^static integer c__0 = 0;$/;" v file:
+c__1 cdrvgbx.c /^static integer c__1 = 1;$/;" v file:
+c__1 cdrvgex.c /^static integer c__1 = 1;$/;" v file:
+c__1 cdrvpox.c /^static integer c__1 = 1;$/;" v file:
+c__1 ddrvgbx.c /^static integer c__1 = 1;$/;" v file:
+c__1 ddrvgex.c /^static integer c__1 = 1;$/;" v file:
+c__1 ddrvpox.c /^static integer c__1 = 1;$/;" v file:
+c__1 sdrvgbx.c /^static integer c__1 = 1;$/;" v file:
+c__1 sdrvgex.c /^static integer c__1 = 1;$/;" v file:
+c__1 sdrvpox.c /^static integer c__1 = 1;$/;" v file:
+c__1 zdrvgbx.c /^static integer c__1 = 1;$/;" v file:
+c__1 zdrvgex.c /^static integer c__1 = 1;$/;" v file:
+c__1 zdrvpox.c /^static integer c__1 = 1;$/;" v file:
+c__2 cdrvgbx.c /^static integer c__2 = 2;$/;" v file:
+c__2 cdrvgex.c /^static integer c__2 = 2;$/;" v file:
+c__2 cdrvpox.c /^static integer c__2 = 2;$/;" v file:
+c__2 ddrvgbx.c /^static integer c__2 = 2;$/;" v file:
+c__2 ddrvgex.c /^static integer c__2 = 2;$/;" v file:
+c__2 ddrvpox.c /^static integer c__2 = 2;$/;" v file:
+c__2 sdrvgbx.c /^static integer c__2 = 2;$/;" v file:
+c__2 sdrvgex.c /^static integer c__2 = 2;$/;" v file:
+c__2 sdrvpox.c /^static integer c__2 = 2;$/;" v file:
+c__2 zdrvgbx.c /^static integer c__2 = 2;$/;" v file:
+c__2 zdrvgex.c /^static integer c__2 = 2;$/;" v file:
+c__2 zdrvpox.c /^static integer c__2 = 2;$/;" v file:
+c__6 cdrvgbx.c /^static integer c__6 = 6;$/;" v file:
+c__6 cdrvgex.c /^static integer c__6 = 6;$/;" v file:
+c__6 ddrvgbx.c /^static integer c__6 = 6;$/;" v file:
+c__6 ddrvgex.c /^static integer c__6 = 6;$/;" v file:
+c__6 sdrvgbx.c /^static integer c__6 = 6;$/;" v file:
+c__6 sdrvgex.c /^static integer c__6 = 6;$/;" v file:
+c__6 zdrvgbx.c /^static integer c__6 = 6;$/;" v file:
+c__6 zdrvgex.c /^static integer c__6 = 6;$/;" v file:
+c__7 cdrvgbx.c /^static integer c__7 = 7;$/;" v file:
+c__7 cdrvgex.c /^static integer c__7 = 7;$/;" v file:
+c__7 ddrvgbx.c /^static integer c__7 = 7;$/;" v file:
+c__7 ddrvgex.c /^static integer c__7 = 7;$/;" v file:
+c__7 sdrvgbx.c /^static integer c__7 = 7;$/;" v file:
+c__7 sdrvgex.c /^static integer c__7 = 7;$/;" v file:
+c__7 zdrvgbx.c /^static integer c__7 = 7;$/;" v file:
+c__7 zdrvgex.c /^static integer c__7 = 7;$/;" v file:
+c_b166 cdrvgex.c /^static real c_b166 = 0.f;$/;" v file:
+c_b166 zdrvgex.c /^static doublereal c_b166 = 0.;$/;" v file:
+c_b197 cdrvgbx.c /^static real c_b197 = 0.f;$/;" v file:
+c_b197 zdrvgbx.c /^static doublereal c_b197 = 0.;$/;" v file:
+c_b20 cdrvgex.c /^static complex c_b20 = {0.f,0.f};$/;" v file:
+c_b20 ddrvgex.c /^static doublereal c_b20 = 0.;$/;" v file:
+c_b20 sdrvgex.c /^static real c_b20 = 0.f;$/;" v file:
+c_b20 zdrvgex.c /^static doublecomplex c_b20 = {0.,0.};$/;" v file:
+c_b48 cdrvgbx.c /^static complex c_b48 = {0.f,0.f};$/;" v file:
+c_b48 ddrvgbx.c /^static doublereal c_b48 = 0.;$/;" v file:
+c_b48 sdrvgbx.c /^static real c_b48 = 0.f;$/;" v file:
+c_b48 zdrvgbx.c /^static doublecomplex c_b48 = {0.,0.};$/;" v file:
+c_b49 cdrvgbx.c /^static complex c_b49 = {1.f,0.f};$/;" v file:
+c_b49 ddrvgbx.c /^static doublereal c_b49 = 1.;$/;" v file:
+c_b49 sdrvgbx.c /^static real c_b49 = 1.f;$/;" v file:
+c_b49 zdrvgbx.c /^static doublecomplex c_b49 = {1.,0.};$/;" v file:
+c_b50 ddrvpox.c /^static doublereal c_b50 = 0.;$/;" v file:
+c_b50 sdrvpox.c /^static real c_b50 = 0.f;$/;" v file:
+c_b51 cdrvpox.c /^static complex c_b51 = {0.f,0.f};$/;" v file:
+c_b51 zdrvpox.c /^static doublecomplex c_b51 = {0.,0.};$/;" v file:
+c_b87 zdrvpox.c /^static complex c_b87 = {0.f,0.f};$/;" v file:
+c_b94 cdrvpox.c /^static real c_b94 = 0.f;$/;" v file:
+c_b94 zdrvpox.c /^static doublereal c_b94 = 0.;$/;" v file:
+c_n1 cdrvgbx.c /^static integer c_n1 = -1;$/;" v file:
+c_n1 cdrvgex.c /^static integer c_n1 = -1;$/;" v file:
+c_n1 cdrvpox.c /^static integer c_n1 = -1;$/;" v file:
+c_n1 ddrvgbx.c /^static integer c_n1 = -1;$/;" v file:
+c_n1 ddrvgex.c /^static integer c_n1 = -1;$/;" v file:
+c_n1 ddrvpox.c /^static integer c_n1 = -1;$/;" v file:
+c_n1 sdrvgbx.c /^static integer c_n1 = -1;$/;" v file:
+c_n1 sdrvgex.c /^static integer c_n1 = -1;$/;" v file:
+c_n1 sdrvpox.c /^static integer c_n1 = -1;$/;" v file:
+c_n1 zdrvgbx.c /^static integer c_n1 = -1;$/;" v file:
+c_n1 zdrvgex.c /^static integer c_n1 = -1;$/;" v file:
+c_n1 zdrvpox.c /^static integer c_n1 = -1;$/;" v file:
+c_true cdrvgex.c /^static logical c_true = TRUE_;$/;" v file:
+c_true ddrvgex.c /^static logical c_true = TRUE_;$/;" v file:
+c_true sdrvgex.c /^static logical c_true = TRUE_;$/;" v file:
+c_true zdrvgex.c /^static logical c_true = TRUE_;$/;" v file:
+cdrvgb_ cdrvgbx.c /^\/* Subroutine *\/ int cdrvgb_(logical *dotype, integer *nn, integer *nval, $/;" f
+cdrvge_ cdrvgex.c /^\/* Subroutine *\/ int cdrvge_(logical *dotype, integer *nn, integer *nval, $/;" f
+cdrvpo_ cdrvpox.c /^\/* Subroutine *\/ int cdrvpo_(logical *dotype, integer *nn, integer *nval, $/;" f
+dalloc3 memory_alloc.h 5;" d
+ddrvgb_ ddrvgbx.c /^\/* Subroutine *\/ int ddrvgb_(logical *dotype, integer *nn, integer *nval, $/;" f
+ddrvge_ ddrvgex.c /^\/* Subroutine *\/ int ddrvge_(logical *dotype, integer *nn, integer *nval, $/;" f
+ddrvpo_ ddrvpox.c /^\/* Subroutine *\/ int ddrvpo_(logical *dotype, integer *nn, integer *nval, $/;" f
+free3 memory_alloc.h 9;" d
+infoc_ cdrvgbx.c /^} infoc_;$/;" v typeref:struct:__anon1
+infoc_ cdrvgex.c /^} infoc_;$/;" v typeref:struct:__anon3
+infoc_ cdrvpox.c /^} infoc_;$/;" v typeref:struct:__anon5
+infoc_ ddrvgbx.c /^} infoc_;$/;" v typeref:struct:__anon7
+infoc_ ddrvgex.c /^} infoc_;$/;" v typeref:struct:__anon9
+infoc_ ddrvpox.c /^} infoc_;$/;" v typeref:struct:__anon11
+infoc_ sdrvgbx.c /^} infoc_;$/;" v typeref:struct:__anon13
+infoc_ sdrvgex.c /^} infoc_;$/;" v typeref:struct:__anon15
+infoc_ sdrvpox.c /^} infoc_;$/;" v typeref:struct:__anon17
+infoc_ zdrvgbx.c /^} infoc_;$/;" v typeref:struct:__anon19
+infoc_ zdrvgex.c /^} infoc_;$/;" v typeref:struct:__anon21
+infoc_ zdrvpox.c /^} infoc_;$/;" v typeref:struct:__anon23
+infoc_1 cdrvgbx.c 23;" d file:
+infoc_1 cdrvgex.c 23;" d file:
+infoc_1 cdrvpox.c 23;" d file:
+infoc_1 ddrvgbx.c 23;" d file:
+infoc_1 ddrvgex.c 23;" d file:
+infoc_1 ddrvpox.c 23;" d file:
+infoc_1 sdrvgbx.c 23;" d file:
+infoc_1 sdrvgex.c 23;" d file:
+infoc_1 sdrvpox.c 23;" d file:
+infoc_1 zdrvgbx.c 23;" d file:
+infoc_1 zdrvgex.c 23;" d file:
+infoc_1 zdrvpox.c 23;" d file:
+infot cdrvgbx.c /^ integer infot, nunit;$/;" m struct:__anon1 file:
+infot cdrvgex.c /^ integer infot, nunit;$/;" m struct:__anon3 file:
+infot cdrvpox.c /^ integer infot, nunit;$/;" m struct:__anon5 file:
+infot ddrvgbx.c /^ integer infot, nunit;$/;" m struct:__anon7 file:
+infot ddrvgex.c /^ integer infot, nunit;$/;" m struct:__anon9 file:
+infot ddrvpox.c /^ integer infot, nunit;$/;" m struct:__anon11 file:
+infot sdrvgbx.c /^ integer infot, nunit;$/;" m struct:__anon13 file:
+infot sdrvgex.c /^ integer infot, nunit;$/;" m struct:__anon15 file:
+infot sdrvpox.c /^ integer infot, nunit;$/;" m struct:__anon17 file:
+infot zdrvgbx.c /^ integer infot, nunit;$/;" m struct:__anon19 file:
+infot zdrvgex.c /^ integer infot, nunit;$/;" m struct:__anon21 file:
+infot zdrvpox.c /^ integer infot, nunit;$/;" m struct:__anon23 file:
+lerr cdrvgbx.c /^ logical ok, lerr;$/;" m struct:__anon1 file:
+lerr cdrvgex.c /^ logical ok, lerr;$/;" m struct:__anon3 file:
+lerr cdrvpox.c /^ logical ok, lerr;$/;" m struct:__anon5 file:
+lerr ddrvgbx.c /^ logical ok, lerr;$/;" m struct:__anon7 file:
+lerr ddrvgex.c /^ logical ok, lerr;$/;" m struct:__anon9 file:
+lerr ddrvpox.c /^ logical ok, lerr;$/;" m struct:__anon11 file:
+lerr sdrvgbx.c /^ logical ok, lerr;$/;" m struct:__anon13 file:
+lerr sdrvgex.c /^ logical ok, lerr;$/;" m struct:__anon15 file:
+lerr sdrvpox.c /^ logical ok, lerr;$/;" m struct:__anon17 file:
+lerr zdrvgbx.c /^ logical ok, lerr;$/;" m struct:__anon19 file:
+lerr zdrvgex.c /^ logical ok, lerr;$/;" m struct:__anon21 file:
+lerr zdrvpox.c /^ logical ok, lerr;$/;" m struct:__anon23 file:
+nunit cdrvgbx.c /^ integer infot, nunit;$/;" m struct:__anon1 file:
+nunit cdrvgex.c /^ integer infot, nunit;$/;" m struct:__anon3 file:
+nunit cdrvpox.c /^ integer infot, nunit;$/;" m struct:__anon5 file:
+nunit ddrvgbx.c /^ integer infot, nunit;$/;" m struct:__anon7 file:
+nunit ddrvgex.c /^ integer infot, nunit;$/;" m struct:__anon9 file:
+nunit ddrvpox.c /^ integer infot, nunit;$/;" m struct:__anon11 file:
+nunit sdrvgbx.c /^ integer infot, nunit;$/;" m struct:__anon13 file:
+nunit sdrvgex.c /^ integer infot, nunit;$/;" m struct:__anon15 file:
+nunit sdrvpox.c /^ integer infot, nunit;$/;" m struct:__anon17 file:
+nunit zdrvgbx.c /^ integer infot, nunit;$/;" m struct:__anon19 file:
+nunit zdrvgex.c /^ integer infot, nunit;$/;" m struct:__anon21 file:
+nunit zdrvpox.c /^ integer infot, nunit;$/;" m struct:__anon23 file:
+ok cdrvgbx.c /^ logical ok, lerr;$/;" m struct:__anon1 file:
+ok cdrvgex.c /^ logical ok, lerr;$/;" m struct:__anon3 file:
+ok cdrvpox.c /^ logical ok, lerr;$/;" m struct:__anon5 file:
+ok ddrvgbx.c /^ logical ok, lerr;$/;" m struct:__anon7 file:
+ok ddrvgex.c /^ logical ok, lerr;$/;" m struct:__anon9 file:
+ok ddrvpox.c /^ logical ok, lerr;$/;" m struct:__anon11 file:
+ok sdrvgbx.c /^ logical ok, lerr;$/;" m struct:__anon13 file:
+ok sdrvgex.c /^ logical ok, lerr;$/;" m struct:__anon15 file:
+ok sdrvpox.c /^ logical ok, lerr;$/;" m struct:__anon17 file:
+ok zdrvgbx.c /^ logical ok, lerr;$/;" m struct:__anon19 file:
+ok zdrvgex.c /^ logical ok, lerr;$/;" m struct:__anon21 file:
+ok zdrvpox.c /^ logical ok, lerr;$/;" m struct:__anon23 file:
+salloc3 memory_alloc.h 1;" d
+sdrvgb_ sdrvgbx.c /^\/* Subroutine *\/ int sdrvgb_(logical *dotype, integer *nn, integer *nval, $/;" f
+sdrvge_ sdrvgex.c /^\/* Subroutine *\/ int sdrvge_(logical *dotype, integer *nn, integer *nval, $/;" f
+sdrvpo_ sdrvpox.c /^\/* Subroutine *\/ int sdrvpo_(logical *dotype, integer *nn, integer *nval, $/;" f
+srnamc_ cdrvgbx.c /^} srnamc_;$/;" v typeref:struct:__anon2
+srnamc_ cdrvgex.c /^} srnamc_;$/;" v typeref:struct:__anon4
+srnamc_ cdrvpox.c /^} srnamc_;$/;" v typeref:struct:__anon6
+srnamc_ ddrvgbx.c /^} srnamc_;$/;" v typeref:struct:__anon8
+srnamc_ ddrvgex.c /^} srnamc_;$/;" v typeref:struct:__anon10
+srnamc_ ddrvpox.c /^} srnamc_;$/;" v typeref:struct:__anon12
+srnamc_ sdrvgbx.c /^} srnamc_;$/;" v typeref:struct:__anon14
+srnamc_ sdrvgex.c /^} srnamc_;$/;" v typeref:struct:__anon16
+srnamc_ sdrvpox.c /^} srnamc_;$/;" v typeref:struct:__anon18
+srnamc_ zdrvgbx.c /^} srnamc_;$/;" v typeref:struct:__anon20
+srnamc_ zdrvgex.c /^} srnamc_;$/;" v typeref:struct:__anon22
+srnamc_ zdrvpox.c /^} srnamc_;$/;" v typeref:struct:__anon24
+srnamc_1 cdrvgbx.c 29;" d file:
+srnamc_1 cdrvgex.c 29;" d file:
+srnamc_1 cdrvpox.c 29;" d file:
+srnamc_1 ddrvgbx.c 29;" d file:
+srnamc_1 ddrvgex.c 29;" d file:
+srnamc_1 ddrvpox.c 29;" d file:
+srnamc_1 sdrvgbx.c 29;" d file:
+srnamc_1 sdrvgex.c 29;" d file:
+srnamc_1 sdrvpox.c 29;" d file:
+srnamc_1 zdrvgbx.c 29;" d file:
+srnamc_1 zdrvgex.c 29;" d file:
+srnamc_1 zdrvpox.c 29;" d file:
+srnamt cdrvgbx.c /^ char srnamt[32];$/;" m struct:__anon2 file:
+srnamt cdrvgex.c /^ char srnamt[32];$/;" m struct:__anon4 file:
+srnamt cdrvpox.c /^ char srnamt[32];$/;" m struct:__anon6 file:
+srnamt ddrvgbx.c /^ char srnamt[32];$/;" m struct:__anon8 file:
+srnamt ddrvgex.c /^ char srnamt[32];$/;" m struct:__anon10 file:
+srnamt ddrvpox.c /^ char srnamt[32];$/;" m struct:__anon12 file:
+srnamt sdrvgbx.c /^ char srnamt[32];$/;" m struct:__anon14 file:
+srnamt sdrvgex.c /^ char srnamt[32];$/;" m struct:__anon16 file:
+srnamt sdrvpox.c /^ char srnamt[32];$/;" m struct:__anon18 file:
+srnamt zdrvgbx.c /^ char srnamt[32];$/;" m struct:__anon20 file:
+srnamt zdrvgex.c /^ char srnamt[32];$/;" m struct:__anon22 file:
+srnamt zdrvpox.c /^ char srnamt[32];$/;" m struct:__anon24 file:
+zdrvgb_ zdrvgbx.c /^\/* Subroutine *\/ int zdrvgb_(logical *dotype, integer *nn, integer *nval, $/;" f
+zdrvge_ zdrvgex.c /^\/* Subroutine *\/ int zdrvge_(logical *dotype, integer *nn, integer *nval, $/;" f
+zdrvpo_ zdrvpox.c /^\/* Subroutine *\/ int zdrvpo_(logical *dotype, integer *nn, integer *nval, $/;" f
diff --git a/TESTING/LIN/xerbla.c b/TESTING/LIN/xerbla.c
new file mode 100644
index 0000000..fc8aefe
--- /dev/null
+++ b/TESTING/LIN/xerbla.c
@@ -0,0 +1,142 @@
+/* xerbla.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+#include "string.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int xerbla_(char *srname, integer *info)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(\002 *** XERBLA was called from \002,a,\002 w"
+ "ith INFO = \002,i6,\002 instead of \002,i2,\002 ***\002)";
+ static char fmt_9997[] = "(\002 *** On entry to \002,a,\002 parameter nu"
+ "mber \002,i6,\002 had an illegal value ***\002)";
+ static char fmt_9998[] = "(\002 *** XERBLA was called with SRNAME = \002"
+ ",a,\002 instead of \002,a6,\002 ***\002)";
+
+ /* Builtin functions */
+ integer s_wsfe(cilist *), i_len_trim(char *, ftnlen), do_fio(integer *,
+ char *, ftnlen), e_wsfe(void), s_cmp(char *, char *, ftnlen,
+ ftnlen);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___2 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___3 = { 0, 0, 0, fmt_9998, 0 };
+
+ int srname_len;
+
+ srname_len = strlen (srname);
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* This is a special version of XERBLA to be used only as part of */
+/* the test program for testing error exits from the LAPACK routines. */
+/* Error messages are printed if INFO.NE.INFOT or if SRNAME.NE.SRMANT, */
+/* where INFOT and SRNAMT are values stored in COMMON. */
+
+/* Arguments */
+/* ========= */
+
+/* SRNAME (input) CHARACTER*(*) */
+/* The name of the subroutine calling XERBLA. This name should */
+/* match the COMMON variable SRNAMT. */
+
+/* INFO (input) INTEGER */
+/* The error return code from the calling subroutine. INFO */
+/* should equal the COMMON variable INFOT. */
+
+/* Further Details */
+/* ======= ======= */
+
+/* The following variables are passed via the common blocks INFOC and */
+/* SRNAMC: */
+
+/* INFOT INTEGER Expected integer return code */
+/* NOUT INTEGER Unit number for printing error messages */
+/* OK LOGICAL Set to .TRUE. if INFO = INFOT and */
+/* SRNAME = SRNAMT, otherwise set to .FALSE. */
+/* LERR LOGICAL Set to .TRUE., indicating that XERBLA was called */
+/* SRNAMT CHARACTER*(*) Expected name of calling subroutine */
+
+
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.lerr = TRUE_;
+ if (*info != infoc_1.infot) {
+ if (infoc_1.infot != 0) {
+ io___1.ciunit = infoc_1.nout;
+ s_wsfe(&io___1);
+ do_fio(&c__1, srnamc_1.srnamt, i_len_trim(srnamc_1.srnamt, (
+ ftnlen)32));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&infoc_1.infot, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___2.ciunit = infoc_1.nout;
+ s_wsfe(&io___2);
+ do_fio(&c__1, srname, i_len_trim(srname, srname_len));
+ do_fio(&c__1, (char *)&(*info), (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ infoc_1.ok = FALSE_;
+ }
+ if (s_cmp(srname, srnamc_1.srnamt, srname_len, (ftnlen)32) != 0) {
+ io___3.ciunit = infoc_1.nout;
+ s_wsfe(&io___3);
+ do_fio(&c__1, srname, i_len_trim(srname, srname_len));
+ do_fio(&c__1, srnamc_1.srnamt, i_len_trim(srnamc_1.srnamt, (ftnlen)32)
+ );
+ e_wsfe();
+ infoc_1.ok = FALSE_;
+ }
+ return 0;
+
+
+/* End of XERBLA */
+
+} /* xerbla_ */
diff --git a/TESTING/LIN/xlaenv.c b/TESTING/LIN/xlaenv.c
new file mode 100644
index 0000000..d87dba5
--- /dev/null
+++ b/TESTING/LIN/xlaenv.c
@@ -0,0 +1,91 @@
+/* xlaenv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer iparms[100];
+} claenv_;
+
+#define claenv_1 claenv_
+
+/* Subroutine */ int xlaenv_(integer *ispec, integer *nvalue)
+{
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* XLAENV sets certain machine- and problem-dependent quantities */
+/* which will later be retrieved by ILAENV. */
+
+/* Arguments */
+/* ========= */
+
+/* ISPEC (input) INTEGER */
+/* Specifies the parameter to be set in the COMMON array IPARMS. */
+/* = 1: the optimal blocksize; if this value is 1, an unblocked */
+/* algorithm will give the best performance. */
+/* = 2: the minimum block size for which the block routine */
+/* should be used; if the usable block size is less than */
+/* this value, an unblocked routine should be used. */
+/* = 3: the crossover point (in a block routine, for N less */
+/* than this value, an unblocked routine should be used) */
+/* = 4: the number of shifts, used in the nonsymmetric */
+/* eigenvalue routines */
+/* = 5: the minimum column dimension for blocking to be used; */
+/* rectangular blocks must have dimension at least k by m, */
+/* where k is given by ILAENV(2,...) and m by ILAENV(5,...) */
+/* = 6: the crossover point for the SVD (when reducing an m by n */
+/* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds */
+/* this value, a QR factorization is used first to reduce */
+/* the matrix to a triangular form) */
+/* = 7: the number of processors */
+/* = 8: another crossover point, for the multishift QR and QZ */
+/* methods for nonsymmetric eigenvalue problems. */
+/* = 9: maximum size of the subproblems at the bottom of the */
+/* computation tree in the divide-and-conquer algorithm */
+/* (used by xGELSD and xGESDD) */
+/* =10: ieee NaN arithmetic can be trusted not to trap */
+/* =11: infinity arithmetic can be trusted not to trap */
+
+/* NVALUE (input) INTEGER */
+/* The value of the parameter specified by ISPEC. */
+
+/* ===================================================================== */
+
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ if (*ispec >= 1 && *ispec <= 9) {
+ claenv_1.iparms[*ispec - 1] = *nvalue;
+ }
+
+ return 0;
+
+/* End of XLAENV */
+
+} /* xlaenv_ */
diff --git a/TESTING/LIN/zchkaa.c b/TESTING/LIN/zchkaa.c
new file mode 100644
index 0000000..e04e14b
--- /dev/null
+++ b/TESTING/LIN/zchkaa.c
@@ -0,0 +1,1467 @@
+/* zchkaa.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+struct {
+ integer iparms[100];
+} claenv_;
+
+#define claenv_1 claenv_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__12 = 12;
+static integer c__0 = 0;
+static integer c__132 = 132;
+static integer c__16 = 16;
+static integer c__100 = 100;
+static integer c__5 = 5;
+static integer c__8 = 8;
+static integer c__2 = 2;
+static integer c__6 = 6;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Initialized data */
+
+ static doublereal threq = 2.;
+ static char intstr[10] = "0123456789";
+
+ /* Format strings */
+ static char fmt_9994[] = "(\002 Tests of the COMPLEX*16 LAPACK routines"
+ " \002,/\002 LAPACK VERSION \002,i1,\002.\002,i1,\002.\002,i1,/"
+ "/\002 The following parameter values will be used:\002)";
+ static char fmt_9996[] = "(\002 Invalid input value: \002,a4,\002=\002,i"
+ "6,\002; must be >=\002,i6)";
+ static char fmt_9995[] = "(\002 Invalid input value: \002,a4,\002=\002,i"
+ "6,\002; must be <=\002,i6)";
+ static char fmt_9993[] = "(4x,a4,\002: \002,10i6,/11x,10i6)";
+ static char fmt_9992[] = "(/\002 Routines pass computational tests if te"
+ "st ratio is \002,\002less than\002,f8.2,/)";
+ static char fmt_9999[] = "(/\002 Execution not attempted due to input er"
+ "rors\002)";
+ static char fmt_9991[] = "(\002 Relative machine \002,a,\002 is taken to"
+ " be\002,d16.6)";
+ static char fmt_9990[] = "(/1x,a3,\002: Unrecognized path name\002)";
+ static char fmt_9989[] = "(/1x,a3,\002 routines were not tested\002)";
+ static char fmt_9988[] = "(/1x,a3,\002 driver routines were not teste"
+ "d\002)";
+ static char fmt_9998[] = "(/\002 End of tests\002)";
+ static char fmt_9997[] = "(\002 Total time used = \002,f12.2,\002 seco"
+ "nds\002,/)";
+
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1;
+ cilist ci__1;
+ cllist cl__1;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), e_rsle(void), s_wsfe(cilist *), do_fio(integer *
+ , char *, ftnlen), e_wsfe(void), do_lio(integer *, integer *,
+ char *, ftnlen);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_rsfe(cilist *), e_rsfe(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer f_clos(cllist *);
+
+ /* Local variables */
+ doublecomplex a[153384] /* was [21912][7] */, b[8448] /* was [2112][
+ 4] */;
+ integer i__, j, k;
+ doublereal s[264];
+ char c1[1], c2[2];
+ doublereal s1, s2;
+ integer ic, la, nb, nm, nn, vers_patch__, vers_major__, vers_minor__, lda,
+ nnb;
+ doublereal eps;
+ integer nns, piv[132], nnb2;
+ char path[3];
+ integer mval[12], nval[12], nrhs;
+ doublecomplex work[20856] /* was [132][158] */;
+ integer lafac;
+ logical fatal;
+ char aline[72];
+ extern logical lsame_(char *, char *);
+ integer nbval[12], nrank, nmats, nsval[12], nxval[12], iwork[3300];
+ doublereal rwork[19832];
+ integer nbval2[12];
+ extern /* Subroutine */ int zchkq3_(logical *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, doublereal
+ *, doublecomplex *, doublecomplex *, doublereal *, doublereal *,
+ doublecomplex *, doublecomplex *, doublereal *, integer *,
+ integer *);
+ extern doublereal dlamch_(char *), dsecnd_(void);
+ extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
+ *, integer *, integer *), zchkgb_(logical *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, doublereal *, logical *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublereal *, integer *,
+ integer *), zchkge_(logical *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, doublereal
+ *, logical *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublereal *, integer *, integer *), zchkhe_(
+ logical *, integer *, integer *, integer *, integer *, integer *,
+ integer *, doublereal *, logical *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, doublereal *, integer *,
+ integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int zchkpb_(logical *, integer *, integer *,
+ integer *, integer *, integer *, integer *, doublereal *, logical
+ *, integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublereal *, integer *), ilaver_(integer *, integer *, integer
+ *), zchkeq_(doublereal *, integer *), zchktb_(logical *, integer *
+, integer *, integer *, integer *, doublereal *, logical *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
+ integer *), zchkhp_(logical *, integer *, integer *, integer *,
+ integer *, doublereal *, logical *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, doublereal *, integer *,
+ integer *), zchkgt_(logical *, integer *, integer *, integer *,
+ integer *, doublereal *, logical *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublereal *, integer *, integer *), zchklq_(
+ logical *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, logical *, integer
+ *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
+ integer *, integer *);
+ doublereal thresh;
+ extern /* Subroutine */ int zchkpo_(logical *, integer *, integer *,
+ integer *, integer *, integer *, integer *, doublereal *, logical
+ *, integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublereal *, integer *), zchkpp_(logical *, integer *, integer
+ *, integer *, integer *, doublereal *, logical *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
+ integer *);
+ logical tstchk;
+ extern /* Subroutine */ int zchkql_(logical *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ doublereal *, logical *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublereal *, integer *,
+ integer *), zchkps_(logical *, integer *, integer *, integer *,
+ integer *, integer *, integer *, doublereal *, logical *, integer
+ *, doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublereal *, integer *);
+ logical dotype[30];
+ extern /* Subroutine */ int zchkpt_(logical *, integer *, integer *,
+ integer *, integer *, doublereal *, logical *, doublecomplex *,
+ doublereal *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublereal *, integer *),
+ zchkqp_(logical *, integer *, integer *, integer *, integer *,
+ doublereal *, logical *, doublecomplex *, doublecomplex *,
+ doublereal *, doublereal *, doublecomplex *, doublecomplex *,
+ doublereal *, integer *, integer *), zchkqr_(logical *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, doublereal *, logical *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublereal *, integer *,
+ integer *), zchkrq_(logical *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, doublereal
+ *, logical *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *, integer *), zchksp_(
+ logical *, integer *, integer *, integer *, integer *, doublereal
+ *, logical *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublereal *, integer *, integer *), zchktp_(
+ logical *, integer *, integer *, integer *, integer *, doublereal
+ *, logical *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublereal *, integer *), zchksy_(logical *, integer *, integer
+ *, integer *, integer *, integer *, integer *, doublereal *,
+ logical *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublereal *, integer *, integer *), zchktr_(
+ logical *, integer *, integer *, integer *, integer *, integer *,
+ integer *, doublereal *, logical *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublereal *, integer *), zchktz_(logical *,
+ integer *, integer *, integer *, integer *, doublereal *, logical
+ *, doublecomplex *, doublecomplex *, doublereal *, doublereal *,
+ doublecomplex *, doublecomplex *, doublereal *, integer *),
+ zdrvgb_(logical *, integer *, integer *, integer *, doublereal *,
+ logical *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex
+ *, doublecomplex *, doublereal *, doublecomplex *, doublereal *,
+ integer *, integer *), zdrvge_(logical *, integer *, integer *,
+ integer *, doublereal *, logical *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, doublereal *, doublecomplex *,
+ doublereal *, integer *, integer *), zdrvgt_(logical *, integer *
+, integer *, integer *, doublereal *, logical *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublereal *, integer *, integer *), zdrvhe_(
+ logical *, integer *, integer *, integer *, doublereal *, logical
+ *, integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublereal *, integer *, integer *);
+ integer ntypes;
+ logical tsterr;
+ extern /* Subroutine */ int zdrvhp_(logical *, integer *, integer *,
+ integer *, doublereal *, logical *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, doublereal *, integer *,
+ integer *);
+ logical tstdrv;
+ extern /* Subroutine */ int zdrvls_(logical *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, doublereal *, logical *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *, integer *), zdrvpb_(logical *, integer *, integer *,
+ integer *, doublereal *, logical *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, doublereal *, doublecomplex *,
+ doublereal *, integer *), zdrvpo_(logical *, integer *, integer *
+, integer *, doublereal *, logical *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, doublereal *, doublecomplex *,
+ doublereal *, integer *), zdrvpp_(logical *, integer *, integer *
+, integer *, doublereal *, logical *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, doublereal *, doublecomplex *,
+ doublereal *, integer *), zdrvpt_(logical *, integer *, integer *
+, integer *, doublereal *, logical *, doublecomplex *, doublereal
+ *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublereal *, integer *),
+ zdrvsp_(logical *, integer *, integer *, integer *, doublereal *,
+ logical *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublereal *, integer *, integer *), zdrvsy_(
+ logical *, integer *, integer *, integer *, doublereal *, logical
+ *, integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublereal *, integer *, integer *);
+ integer rankval[12];
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 5, 0, 0, 0 };
+ static cilist io___10 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___11 = { 0, 5, 0, 0, 0 };
+ static cilist io___13 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___14 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___15 = { 0, 5, 0, 0, 0 };
+ static cilist io___18 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___19 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___20 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___21 = { 0, 5, 0, 0, 0 };
+ static cilist io___23 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___24 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___25 = { 0, 5, 0, 0, 0 };
+ static cilist io___27 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___28 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___29 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___30 = { 0, 5, 0, 0, 0 };
+ static cilist io___32 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___33 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___34 = { 0, 5, 0, 0, 0 };
+ static cilist io___36 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___37 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___38 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___39 = { 0, 5, 0, 0, 0 };
+ static cilist io___41 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___42 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___43 = { 0, 5, 0, 0, 0 };
+ static cilist io___45 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___46 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___51 = { 0, 5, 0, 0, 0 };
+ static cilist io___53 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___54 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___55 = { 0, 5, 0, 0, 0 };
+ static cilist io___57 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___58 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___59 = { 0, 5, 0, 0, 0 };
+ static cilist io___61 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___62 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___63 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___64 = { 0, 5, 0, 0, 0 };
+ static cilist io___66 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___67 = { 0, 5, 0, 0, 0 };
+ static cilist io___69 = { 0, 5, 0, 0, 0 };
+ static cilist io___71 = { 0, 5, 0, 0, 0 };
+ static cilist io___73 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___75 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___76 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___77 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___78 = { 0, 6, 0, 0, 0 };
+ static cilist io___87 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___88 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___96 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___98 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___101 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___102 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___103 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___104 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___105 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___106 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___108 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___109 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___110 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___111 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___112 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___113 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___114 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___115 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___116 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___117 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___118 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___119 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___120 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___121 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___122 = { 0, 6, 0, fmt_9988, 0 };
+ static cilist io___123 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___124 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___125 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___126 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___127 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___128 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___129 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___130 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___131 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___132 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___133 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___134 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___136 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___137 = { 0, 6, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKAA is the main test program for the COMPLEX*16 linear equation */
+/* routines. */
+
+/* The program must be driven by a short data file. The first 14 records */
+/* specify problem dimensions and program options using list-directed */
+/* input. The remaining lines specify the LAPACK test paths and the */
+/* number of matrix types to use in testing. An annotated example of a */
+/* data file can be obtained by deleting the first 3 characters from the */
+/* following 38 lines: */
+/* Data file for testing COMPLEX*16 LAPACK linear equation routines */
+/* 7 Number of values of M */
+/* 0 1 2 3 5 10 16 Values of M (row dimension) */
+/* 7 Number of values of N */
+/* 0 1 2 3 5 10 16 Values of N (column dimension) */
+/* 1 Number of values of NRHS */
+/* 2 Values of NRHS (number of right hand sides) */
+/* 5 Number of values of NB */
+/* 1 3 3 3 20 Values of NB (the blocksize) */
+/* 1 0 5 9 1 Values of NX (crossover point) */
+/* 3 Number of values of RANK */
+/* 30 50 90 Values of rank (as a % of N) */
+/* 30.0 Threshold value of test ratio */
+/* T Put T to test the LAPACK routines */
+/* T Put T to test the driver routines */
+/* T Put T to test the error exits */
+/* ZGE 11 List types on next line if 0 < NTYPES < 11 */
+/* ZGB 8 List types on next line if 0 < NTYPES < 8 */
+/* ZGT 12 List types on next line if 0 < NTYPES < 12 */
+/* ZPO 9 List types on next line if 0 < NTYPES < 9 */
+/* ZPS 9 List types on next line if 0 < NTYPES < 9 */
+/* 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 */
+/* ZHE 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 */
+/* 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 */
+/* ZTB 17 List types on next line if 0 < NTYPES < 17 */
+/* ZQR 8 List types on next line if 0 < NTYPES < 8 */
+/* ZRQ 8 List types on next line if 0 < NTYPES < 8 */
+/* ZLQ 8 List types on next line if 0 < NTYPES < 8 */
+/* ZQL 8 List types on next line if 0 < NTYPES < 8 */
+/* ZQP 6 List types on next line if 0 < NTYPES < 6 */
+/* ZTZ 3 List types on next line if 0 < NTYPES < 3 */
+/* ZLS 6 List types on next line if 0 < NTYPES < 6 */
+/* ZEQ */
+
+/* Internal Parameters */
+/* =================== */
+
+/* NMAX INTEGER */
+/* The maximum allowable value for N. */
+
+/* MAXIN INTEGER */
+/* The number of different values that can be used for each of */
+/* M, N, or NB */
+
+/* MAXRHS INTEGER */
+/* The maximum number of right hand sides */
+
+/* NIN INTEGER */
+/* The unit number for input */
+
+/* NOUT INTEGER */
+/* The unit number for output */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Arrays in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ s1 = dsecnd_();
+ lda = 132;
+ fatal = FALSE_;
+
+/* Read a dummy line. */
+
+ s_rsle(&io___6);
+ e_rsle();
+
+/* Report values of parameters. */
+
+ ilaver_(&vers_major__, &vers_minor__, &vers_patch__);
+ s_wsfe(&io___10);
+ do_fio(&c__1, (char *)&vers_major__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_minor__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_patch__, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+/* Read the values of M */
+
+ s_rsle(&io___11);
+ do_lio(&c__3, &c__1, (char *)&nm, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nm < 1) {
+ s_wsfe(&io___13);
+ do_fio(&c__1, " NM ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nm, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nm = 0;
+ fatal = TRUE_;
+ } else if (nm > 12) {
+ s_wsfe(&io___14);
+ do_fio(&c__1, " NM ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nm, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nm = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___15);
+ i__1 = nm;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nm;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (mval[i__ - 1] < 0) {
+ s_wsfe(&io___18);
+ do_fio(&c__1, " M ", (ftnlen)4);
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (mval[i__ - 1] > 132) {
+ s_wsfe(&io___19);
+ do_fio(&c__1, " M ", (ftnlen)4);
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L10: */
+ }
+ if (nm > 0) {
+ s_wsfe(&io___20);
+ do_fio(&c__1, "M ", (ftnlen)4);
+ i__1 = nm;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of N */
+
+ s_rsle(&io___21);
+ do_lio(&c__3, &c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nn < 1) {
+ s_wsfe(&io___23);
+ do_fio(&c__1, " NN ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ } else if (nn > 12) {
+ s_wsfe(&io___24);
+ do_fio(&c__1, " NN ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___25);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nval[i__ - 1] < 0) {
+ s_wsfe(&io___27);
+ do_fio(&c__1, " N ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nval[i__ - 1] > 132) {
+ s_wsfe(&io___28);
+ do_fio(&c__1, " N ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L20: */
+ }
+ if (nn > 0) {
+ s_wsfe(&io___29);
+ do_fio(&c__1, "N ", (ftnlen)4);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of NRHS */
+
+ s_rsle(&io___30);
+ do_lio(&c__3, &c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nns < 1) {
+ s_wsfe(&io___32);
+ do_fio(&c__1, " NNS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nns = 0;
+ fatal = TRUE_;
+ } else if (nns > 12) {
+ s_wsfe(&io___33);
+ do_fio(&c__1, " NNS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nns = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___34);
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nsval[i__ - 1] < 0) {
+ s_wsfe(&io___36);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nsval[i__ - 1] > 16) {
+ s_wsfe(&io___37);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__16, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L30: */
+ }
+ if (nns > 0) {
+ s_wsfe(&io___38);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of NB */
+
+ s_rsle(&io___39);
+ do_lio(&c__3, &c__1, (char *)&nnb, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nnb < 1) {
+ s_wsfe(&io___41);
+ do_fio(&c__1, "NNB ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nnb, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nnb = 0;
+ fatal = TRUE_;
+ } else if (nnb > 12) {
+ s_wsfe(&io___42);
+ do_fio(&c__1, "NNB ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nnb, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nnb = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___43);
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nbval[i__ - 1] < 0) {
+ s_wsfe(&io___45);
+ do_fio(&c__1, " NB ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L40: */
+ }
+ if (nnb > 0) {
+ s_wsfe(&io___46);
+ do_fio(&c__1, "NB ", (ftnlen)4);
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Set NBVAL2 to be the set of unique values of NB */
+
+ nnb2 = 0;
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ nb = nbval[i__ - 1];
+ i__2 = nnb2;
+ for (j = 1; j <= i__2; ++j) {
+ if (nb == nbval2[j - 1]) {
+ goto L60;
+ }
+/* L50: */
+ }
+ ++nnb2;
+ nbval2[nnb2 - 1] = nb;
+L60:
+ ;
+ }
+
+/* Read the values of NX */
+
+ s_rsle(&io___51);
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nxval[i__ - 1] < 0) {
+ s_wsfe(&io___53);
+ do_fio(&c__1, " NX ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L70: */
+ }
+ if (nnb > 0) {
+ s_wsfe(&io___54);
+ do_fio(&c__1, "NX ", (ftnlen)4);
+ i__1 = nnb;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of RANKVAL */
+
+ s_rsle(&io___55);
+ do_lio(&c__3, &c__1, (char *)&nrank, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nn < 1) {
+ s_wsfe(&io___57);
+ do_fio(&c__1, " NRANK ", (ftnlen)7);
+ do_fio(&c__1, (char *)&nrank, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nrank = 0;
+ fatal = TRUE_;
+ } else if (nn > 12) {
+ s_wsfe(&io___58);
+ do_fio(&c__1, " NRANK ", (ftnlen)7);
+ do_fio(&c__1, (char *)&nrank, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nrank = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___59);
+ i__1 = nrank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&rankval[i__ - 1], (ftnlen)sizeof(
+ integer));
+ }
+ e_rsle();
+ i__1 = nrank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (rankval[i__ - 1] < 0) {
+ s_wsfe(&io___61);
+ do_fio(&c__1, " RANK ", (ftnlen)7);
+ do_fio(&c__1, (char *)&rankval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (rankval[i__ - 1] > 100) {
+ s_wsfe(&io___62);
+ do_fio(&c__1, " RANK ", (ftnlen)7);
+ do_fio(&c__1, (char *)&rankval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__100, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+ }
+ if (nrank > 0) {
+ s_wsfe(&io___63);
+ do_fio(&c__1, "RANK % OF N", (ftnlen)11);
+ i__1 = nrank;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&rankval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the threshold value for the test ratios. */
+
+ s_rsle(&io___64);
+ do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_rsle();
+ s_wsfe(&io___66);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+/* Read the flag that indicates whether to test the LAPACK routines. */
+
+ s_rsle(&io___67);
+ do_lio(&c__8, &c__1, (char *)&tstchk, (ftnlen)sizeof(logical));
+ e_rsle();
+
+/* Read the flag that indicates whether to test the driver routines. */
+
+ s_rsle(&io___69);
+ do_lio(&c__8, &c__1, (char *)&tstdrv, (ftnlen)sizeof(logical));
+ e_rsle();
+
+/* Read the flag that indicates whether to test the error exits. */
+
+ s_rsle(&io___71);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+
+ if (fatal) {
+ s_wsfe(&io___73);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Calculate and print the machine dependent constants. */
+
+ eps = dlamch_("Underflow threshold");
+ s_wsfe(&io___75);
+ do_fio(&c__1, "underflow", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ eps = dlamch_("Overflow threshold");
+ s_wsfe(&io___76);
+ do_fio(&c__1, "overflow ", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ eps = dlamch_("Epsilon");
+ s_wsfe(&io___77);
+ do_fio(&c__1, "precision", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_wsle(&io___78);
+ e_wsle();
+ nrhs = nsval[0];
+
+L80:
+
+/* Read a test path and the number of matrix types to use. */
+
+ ci__1.cierr = 0;
+ ci__1.ciend = 1;
+ ci__1.ciunit = 5;
+ ci__1.cifmt = "(A72)";
+ i__1 = s_rsfe(&ci__1);
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = do_fio(&c__1, aline, (ftnlen)72);
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L140;
+ }
+ s_copy(path, aline, (ftnlen)3, (ftnlen)3);
+ nmats = 30;
+ i__ = 3;
+L90:
+ ++i__;
+ if (i__ > 72) {
+ goto L130;
+ }
+ if (*(unsigned char *)&aline[i__ - 1] == ' ') {
+ goto L90;
+ }
+ nmats = 0;
+L100:
+ *(unsigned char *)c1 = *(unsigned char *)&aline[i__ - 1];
+ for (k = 1; k <= 10; ++k) {
+ if (*(unsigned char *)c1 == *(unsigned char *)&intstr[k - 1]) {
+ ic = k - 1;
+ goto L120;
+ }
+/* L110: */
+ }
+ goto L130;
+L120:
+ nmats = nmats * 10 + ic;
+ ++i__;
+ if (i__ > 72) {
+ goto L130;
+ }
+ goto L100;
+L130:
+ *(unsigned char *)c1 = *(unsigned char *)path;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Check first character for correct precision. */
+
+ if (! lsame_(c1, "Zomplex precision")) {
+ s_wsfe(&io___87);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+ } else if (nmats <= 0) {
+
+/* Check for a positive number of tests requested. */
+
+ s_wsfe(&io___88);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+ } else if (lsamen_(&c__2, c2, "GE")) {
+
+/* GE: general matrices */
+
+ ntypes = 11;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ zchkge_(dotype, &nm, mval, &nn, nval, &nnb2, nbval2, &nns, nsval,
+ &thresh, &tsterr, &lda, a, &a[21912], &a[43824], b, &b[
+ 2112], &b[4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___96);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ zdrvge_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
+ work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___98);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* GB: general banded matrices */
+
+ la = 43692;
+ lafac = 65472;
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ zchkgb_(dotype, &nm, mval, &nn, nval, &nnb2, nbval2, &nns, nsval,
+ &thresh, &tsterr, a, &la, &a[43824], &lafac, b, &b[2112],
+ &b[4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___101);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ zdrvgb_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, a, &la, &a[
+ 43824], &lafac, &a[109560], b, &b[2112], &b[4224], &b[
+ 6336], s, work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___102);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "GT")) {
+
+/* GT: general tridiagonal matrices */
+
+ ntypes = 12;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ zchkgt_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, a, &a[
+ 21912], b, &b[2112], &b[4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___103);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ zdrvgt_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, a, &a[21912],
+ b, &b[2112], &b[4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___104);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "PO")) {
+
+/* PO: positive definite matrices */
+
+ ntypes = 9;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ zchkpo_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
+ tsterr, &lda, a, &a[21912], &a[43824], b, &b[2112], &b[
+ 4224], work, rwork, &c__6);
+ } else {
+ s_wsfe(&io___105);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ zdrvpo_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
+ work, rwork, &c__6);
+ } else {
+ s_wsfe(&io___106);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "PS")) {
+
+/* PS: positive semi-definite matrices */
+
+ ntypes = 9;
+
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ zchkps_(dotype, &nn, nval, &nnb2, nbval2, &nrank, rankval, &
+ thresh, &tsterr, &lda, a, &a[21912], &a[43824], piv, work,
+ rwork, &c__6);
+ } else {
+ s_wsfe(&io___108);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "PP")) {
+
+/* PP: positive definite packed matrices */
+
+ ntypes = 9;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ zchkpp_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
+ &a[21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
+ &c__6);
+ } else {
+ s_wsfe(&io___109);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ zdrvpp_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
+ work, rwork, &c__6);
+ } else {
+ s_wsfe(&io___110);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* PB: positive definite banded matrices */
+
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ zchkpb_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
+ tsterr, &lda, a, &a[21912], &a[43824], b, &b[2112], &b[
+ 4224], work, rwork, &c__6);
+ } else {
+ s_wsfe(&io___111);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ zdrvpb_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
+ work, rwork, &c__6);
+ } else {
+ s_wsfe(&io___112);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "PT")) {
+
+/* PT: positive definite tridiagonal matrices */
+
+ ntypes = 12;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ zchkpt_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, a, s, &
+ a[21912], b, &b[2112], &b[4224], work, rwork, &c__6);
+ } else {
+ s_wsfe(&io___113);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ zdrvpt_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, a, s, &a[
+ 21912], b, &b[2112], &b[4224], work, rwork, &c__6);
+ } else {
+ s_wsfe(&io___114);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "HE")) {
+
+/* HE: Hermitian indefinite matrices */
+
+ ntypes = 10;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ zchkhe_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
+ tsterr, &lda, a, &a[21912], &a[43824], b, &b[2112], &b[
+ 4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___115);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ zdrvhe_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
+ iwork, &c__6);
+ } else {
+ s_wsfe(&io___116);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "HP")) {
+
+/* HP: Hermitian indefinite packed matrices */
+
+ ntypes = 10;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ zchkhp_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
+ &a[21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
+ iwork, &c__6);
+ } else {
+ s_wsfe(&io___117);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ zdrvhp_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
+ iwork, &c__6);
+ } else {
+ s_wsfe(&io___118);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "SY")) {
+
+/* SY: symmetric indefinite matrices */
+
+ ntypes = 11;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ zchksy_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
+ tsterr, &lda, a, &a[21912], &a[43824], b, &b[2112], &b[
+ 4224], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___119);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ zdrvsy_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
+ iwork, &c__6);
+ } else {
+ s_wsfe(&io___120);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "SP")) {
+
+/* SP: symmetric indefinite packed matrices */
+
+ ntypes = 11;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ zchksp_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
+ &a[21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
+ iwork, &c__6);
+ } else {
+ s_wsfe(&io___121);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ if (tstdrv) {
+ zdrvsp_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
+ 21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
+ iwork, &c__6);
+ } else {
+ s_wsfe(&io___122);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "TR")) {
+
+/* TR: triangular matrices */
+
+ ntypes = 18;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ zchktr_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
+ tsterr, &lda, a, &a[21912], b, &b[2112], &b[4224], work,
+ rwork, &c__6);
+ } else {
+ s_wsfe(&io___123);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "TP")) {
+
+/* TP: triangular packed matrices */
+
+ ntypes = 18;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ zchktp_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
+ &a[21912], b, &b[2112], &b[4224], work, rwork, &c__6);
+ } else {
+ s_wsfe(&io___124);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "TB")) {
+
+/* TB: triangular banded matrices */
+
+ ntypes = 17;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ zchktb_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
+ &a[21912], b, &b[2112], &b[4224], work, rwork, &c__6);
+ } else {
+ s_wsfe(&io___125);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "QR")) {
+
+/* QR: QR factorization */
+
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ zchkqr_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
+ thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
+ 65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
+ rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___126);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "LQ")) {
+
+/* LQ: LQ factorization */
+
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ zchklq_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
+ thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
+ 65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
+ rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___127);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "QL")) {
+
+/* QL: QL factorization */
+
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ zchkql_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
+ thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
+ 65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
+ rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___128);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "RQ")) {
+
+/* RQ: RQ factorization */
+
+ ntypes = 8;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ zchkrq_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
+ thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
+ 65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
+ rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___129);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "EQ")) {
+
+/* EQ: Equilibration routines for general and positive definite */
+/* matrices (THREQ should be between 2 and 10) */
+
+ if (tstchk) {
+ zchkeq_(&threq, &c__6);
+ } else {
+ s_wsfe(&io___130);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "TZ")) {
+
+/* TZ: Trapezoidal matrix */
+
+ ntypes = 3;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ zchktz_(dotype, &nm, mval, &nn, nval, &thresh, &tsterr, a, &a[
+ 21912], s, &s[132], b, work, rwork, &c__6);
+ } else {
+ s_wsfe(&io___131);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "QP")) {
+
+/* QP: QR factorization with pivoting */
+
+ ntypes = 6;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstchk) {
+ zchkqp_(dotype, &nm, mval, &nn, nval, &thresh, &tsterr, a, &a[
+ 21912], s, &s[132], b, work, rwork, iwork, &c__6);
+ zchkq3_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &thresh,
+ a, &a[21912], s, &s[132], b, work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___132);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "LS")) {
+
+/* LS: Least squares drivers */
+
+ ntypes = 6;
+ alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tstdrv) {
+ zdrvls_(dotype, &nm, mval, &nn, nval, &nns, nsval, &nnb, nbval,
+ nxval, &thresh, &tsterr, a, &a[21912], &a[43824], &a[
+ 65736], &a[87648], s, &s[132], work, rwork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___133);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+ } else {
+
+ s_wsfe(&io___134);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+/* Go back to get another input line. */
+
+ goto L80;
+
+/* Branch to this line when the last record is read. */
+
+L140:
+ cl__1.cerr = 0;
+ cl__1.cunit = 5;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ s2 = dsecnd_();
+ s_wsfe(&io___136);
+ e_wsfe();
+ s_wsfe(&io___137);
+ d__1 = s2 - s1;
+ do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+
+/* End of ZCHKAA */
+
+ return 0;
+} /* MAIN__ */
+
+/* Main program alias */ int zchkaa_ () { MAIN__ (); return 0; }
diff --git a/TESTING/LIN/zchkab.c b/TESTING/LIN/zchkab.c
new file mode 100644
index 0000000..76a68d3
--- /dev/null
+++ b/TESTING/LIN/zchkab.c
@@ -0,0 +1,574 @@
+/* zchkab.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__12 = 12;
+static integer c__0 = 0;
+static integer c__132 = 132;
+static integer c__16 = 16;
+static integer c__5 = 5;
+static integer c__8 = 8;
+static integer c__2 = 2;
+static integer c__6 = 6;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Initialized data */
+
+ static char intstr[10] = "0123456789";
+
+ /* Format strings */
+ static char fmt_9994[] = "(\002 Tests of the COMPLEX*16 LAPACK ZCGESV/ZC"
+ "POSV routines \002,/\002 LAPACK VERSION \002,i1,\002.\002,i1,"
+ "\002.\002,i1,//\002 The following parameter values will be used"
+ ":\002)";
+ static char fmt_9996[] = "(\002 Invalid input value: \002,a4,\002=\002,i"
+ "6,\002; must be >=\002,i6)";
+ static char fmt_9995[] = "(\002 Invalid input value: \002,a4,\002=\002,i"
+ "6,\002; must be <=\002,i6)";
+ static char fmt_9993[] = "(4x,a4,\002: \002,10i6,/11x,10i6)";
+ static char fmt_9992[] = "(/\002 Routines pass computational tests if te"
+ "st ratio is \002,\002less than\002,f8.2,/)";
+ static char fmt_9999[] = "(/\002 Execution not attempted due to input er"
+ "rors\002)";
+ static char fmt_9991[] = "(\002 Relative machine \002,a,\002 is taken to"
+ " be\002,d16.6)";
+ static char fmt_9990[] = "(/1x,a6,\002 routines were not tested\002)";
+ static char fmt_9989[] = "(/1x,a6,\002 driver routines were not teste"
+ "d\002)";
+ static char fmt_9998[] = "(/\002 End of tests\002)";
+ static char fmt_9997[] = "(\002 Total time used = \002,f12.2,\002 seco"
+ "nds\002,/)";
+
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+ cilist ci__1;
+ cllist cl__1;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), e_rsle(void), s_wsfe(cilist *), do_fio(integer *
+ , char *, ftnlen), e_wsfe(void), do_lio(integer *, integer *,
+ char *, ftnlen);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_rsfe(cilist *), e_rsfe(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer f_clos(cllist *);
+
+ /* Local variables */
+ doublecomplex a[34848] /* was [17424][2] */, b[4224] /* was [2112][
+ 2] */;
+ integer i__, k;
+ char c1[1], c2[2];
+ doublereal s1, s2;
+ integer ic, nm, vers_patch__, vers_major__, vers_minor__, lda;
+ doublereal eps;
+ integer nns;
+ char path[3];
+ integer mval[12], nrhs;
+ real seps;
+ doublecomplex work[4224];
+ logical fatal;
+ char aline[72];
+ extern logical lsame_(char *, char *);
+ integer nmats, nsval[12], iwork[132];
+ doublereal rwork[132];
+ complex swork[19536];
+ extern doublereal dlamch_(char *), dsecnd_(void);
+ extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
+ *, integer *, integer *);
+ extern doublereal slamch_(char *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int ilaver_(integer *, integer *, integer *),
+ zerrab_(integer *), zerrac_(integer *), zdrvab_(logical *,
+ integer *, integer *, integer *, integer *, doublereal *, integer
+ *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublereal *, complex *,
+ integer *, integer *), zdrvac_(logical *, integer *, integer *,
+ integer *, integer *, doublereal *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublereal *, complex *, integer *);
+ doublereal thresh;
+ logical dotype[30];
+ integer ntypes;
+ logical tsterr, tstdrv;
+
+ /* Fortran I/O blocks */
+ static cilist io___5 = { 0, 5, 0, 0, 0 };
+ static cilist io___9 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___10 = { 0, 5, 0, 0, 0 };
+ static cilist io___12 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___13 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___14 = { 0, 5, 0, 0, 0 };
+ static cilist io___17 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___18 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___19 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___20 = { 0, 5, 0, 0, 0 };
+ static cilist io___22 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___23 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___24 = { 0, 5, 0, 0, 0 };
+ static cilist io___26 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___27 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___28 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___29 = { 0, 5, 0, 0, 0 };
+ static cilist io___31 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___32 = { 0, 5, 0, 0, 0 };
+ static cilist io___34 = { 0, 5, 0, 0, 0 };
+ static cilist io___36 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___38 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___39 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___40 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___41 = { 0, 6, 0, 0, 0 };
+ static cilist io___43 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___44 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___45 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___46 = { 0, 6, 0, 0, 0 };
+ static cilist io___55 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___56 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___65 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___66 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___68 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___69 = { 0, 6, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKAB is the test program for the COMPLEX*16 LAPACK */
+/* ZCGESV/ZCPOSV routine */
+
+/* The program must be driven by a short data file. The first 5 records */
+/* specify problem dimensions and program options using list-directed */
+/* input. The remaining lines specify the LAPACK test paths and the */
+/* number of matrix types to use in testing. An annotated example of a */
+/* data file can be obtained by deleting the first 3 characters from the */
+/* following 9 lines: */
+/* Data file for testing COMPLEX*16 LAPACK ZCGESV */
+/* 7 Number of values of M */
+/* 0 1 2 3 5 10 16 Values of M (row dimension) */
+/* 1 Number of values of NRHS */
+/* 2 Values of NRHS (number of right hand sides) */
+/* 20.0 Threshold value of test ratio */
+/* T Put T to test the LAPACK routine */
+/* T Put T to test the error exits */
+/* DGE 11 List types on next line if 0 < NTYPES < 11 */
+/* DPO 9 List types on next line if 0 < NTYPES < 9 */
+
+/* Internal Parameters */
+/* =================== */
+
+/* NMAX INTEGER */
+/* The maximum allowable value for N */
+
+/* MAXIN INTEGER */
+/* The number of different values that can be used for each of */
+/* M, N, NRHS, NB, and NX */
+
+/* MAXRHS INTEGER */
+/* The maximum number of right hand sides */
+
+/* NIN INTEGER */
+/* The unit number for input */
+
+/* NOUT INTEGER */
+/* The unit number for output */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ s1 = dsecnd_();
+ lda = 132;
+ fatal = FALSE_;
+
+/* Read a dummy line. */
+
+ s_rsle(&io___5);
+ e_rsle();
+
+/* Report values of parameters. */
+
+ ilaver_(&vers_major__, &vers_minor__, &vers_patch__);
+ s_wsfe(&io___9);
+ do_fio(&c__1, (char *)&vers_major__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_minor__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_patch__, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+/* Read the values of M */
+
+ s_rsle(&io___10);
+ do_lio(&c__3, &c__1, (char *)&nm, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nm < 1) {
+ s_wsfe(&io___12);
+ do_fio(&c__1, " NM ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nm, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nm = 0;
+ fatal = TRUE_;
+ } else if (nm > 12) {
+ s_wsfe(&io___13);
+ do_fio(&c__1, " NM ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nm, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nm = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___14);
+ i__1 = nm;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nm;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (mval[i__ - 1] < 0) {
+ s_wsfe(&io___17);
+ do_fio(&c__1, " M ", (ftnlen)4);
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (mval[i__ - 1] > 132) {
+ s_wsfe(&io___18);
+ do_fio(&c__1, " M ", (ftnlen)4);
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L10: */
+ }
+ if (nm > 0) {
+ s_wsfe(&io___19);
+ do_fio(&c__1, "M ", (ftnlen)4);
+ i__1 = nm;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of NRHS */
+
+ s_rsle(&io___20);
+ do_lio(&c__3, &c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nns < 1) {
+ s_wsfe(&io___22);
+ do_fio(&c__1, " NNS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nns = 0;
+ fatal = TRUE_;
+ } else if (nns > 12) {
+ s_wsfe(&io___23);
+ do_fio(&c__1, " NNS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nns = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___24);
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nsval[i__ - 1] < 0) {
+ s_wsfe(&io___26);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nsval[i__ - 1] > 16) {
+ s_wsfe(&io___27);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__16, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L30: */
+ }
+ if (nns > 0) {
+ s_wsfe(&io___28);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the threshold value for the test ratios. */
+
+ s_rsle(&io___29);
+ do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_rsle();
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+/* Read the flag that indicates whether to test the driver routine. */
+
+ s_rsle(&io___32);
+ do_lio(&c__8, &c__1, (char *)&tstdrv, (ftnlen)sizeof(logical));
+ e_rsle();
+
+/* Read the flag that indicates whether to test the error exits. */
+
+ s_rsle(&io___34);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+
+ if (fatal) {
+ s_wsfe(&io___36);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Calculate and print the machine dependent constants. */
+
+ seps = slamch_("Underflow threshold");
+ s_wsfe(&io___38);
+ do_fio(&c__1, "(single precision) underflow", (ftnlen)28);
+ do_fio(&c__1, (char *)&seps, (ftnlen)sizeof(real));
+ e_wsfe();
+ seps = slamch_("Overflow threshold");
+ s_wsfe(&io___39);
+ do_fio(&c__1, "(single precision) overflow ", (ftnlen)28);
+ do_fio(&c__1, (char *)&seps, (ftnlen)sizeof(real));
+ e_wsfe();
+ seps = slamch_("Epsilon");
+ s_wsfe(&io___40);
+ do_fio(&c__1, "(single precision) precision", (ftnlen)28);
+ do_fio(&c__1, (char *)&seps, (ftnlen)sizeof(real));
+ e_wsfe();
+ s_wsle(&io___41);
+ e_wsle();
+
+ eps = dlamch_("Underflow threshold");
+ s_wsfe(&io___43);
+ do_fio(&c__1, "(double precision) underflow", (ftnlen)28);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ eps = dlamch_("Overflow threshold");
+ s_wsfe(&io___44);
+ do_fio(&c__1, "(double precision) overflow ", (ftnlen)28);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ eps = dlamch_("Epsilon");
+ s_wsfe(&io___45);
+ do_fio(&c__1, "(double precision) precision", (ftnlen)28);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_wsle(&io___46);
+ e_wsle();
+
+L80:
+
+/* Read a test path and the number of matrix types to use. */
+
+ ci__1.cierr = 0;
+ ci__1.ciend = 1;
+ ci__1.ciunit = 5;
+ ci__1.cifmt = "(A72)";
+ i__1 = s_rsfe(&ci__1);
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = do_fio(&c__1, aline, (ftnlen)72);
+ if (i__1 != 0) {
+ goto L140;
+ }
+ i__1 = e_rsfe();
+ if (i__1 != 0) {
+ goto L140;
+ }
+ s_copy(path, aline, (ftnlen)3, (ftnlen)3);
+ nmats = 30;
+ i__ = 3;
+L90:
+ ++i__;
+ if (i__ > 72) {
+ nmats = 30;
+ goto L130;
+ }
+ if (*(unsigned char *)&aline[i__ - 1] == ' ') {
+ goto L90;
+ }
+ nmats = 0;
+L100:
+ *(unsigned char *)c1 = *(unsigned char *)&aline[i__ - 1];
+ for (k = 1; k <= 10; ++k) {
+ if (*(unsigned char *)c1 == *(unsigned char *)&intstr[k - 1]) {
+ ic = k - 1;
+ goto L120;
+ }
+/* L110: */
+ }
+ goto L130;
+L120:
+ nmats = nmats * 10 + ic;
+ ++i__;
+ if (i__ > 72) {
+ goto L130;
+ }
+ goto L100;
+L130:
+ *(unsigned char *)c1 = *(unsigned char *)path;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ nrhs = nsval[0];
+ nrhs = nsval[0];
+
+/* Check first character for correct precision. */
+
+ if (! lsame_(c1, "Zomplex precision")) {
+ s_wsfe(&io___55);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+
+ } else if (nmats <= 0) {
+
+/* Check for a positive number of tests requested. */
+
+ s_wsfe(&io___56);
+ do_fio(&c__1, "ZCGESV", (ftnlen)6);
+ e_wsfe();
+ goto L140;
+
+ } else if (lsamen_(&c__2, c2, "GE")) {
+
+/* GE: general matrices */
+
+ ntypes = 11;
+ alareq_("ZGE", &nmats, dotype, &ntypes, &c__5, &c__6);
+
+/* Test the error exits */
+
+ if (tsterr) {
+ zerrab_(&c__6);
+ }
+
+ if (tstdrv) {
+ zdrvab_(dotype, &nm, mval, &nns, nsval, &thresh, &lda, a, &a[
+ 17424], b, &b[2112], work, rwork, swork, iwork, &c__6);
+ } else {
+ s_wsfe(&io___65);
+ do_fio(&c__1, "ZCGESV", (ftnlen)6);
+ e_wsfe();
+ }
+
+ } else if (lsamen_(&c__2, c2, "PO")) {
+
+/* PO: positive definite matrices */
+
+ ntypes = 9;
+ alareq_("DPO", &nmats, dotype, &ntypes, &c__5, &c__6);
+
+ if (tsterr) {
+ zerrac_(&c__6);
+ }
+
+
+ if (tstdrv) {
+ zdrvac_(dotype, &nm, mval, &nns, nsval, &thresh, &lda, a, &a[
+ 17424], b, &b[2112], work, rwork, swork, &c__6);
+ } else {
+ s_wsfe(&io___66);
+ do_fio(&c__1, "ZCPOSV", (ftnlen)6);
+ e_wsfe();
+ }
+
+ } else {
+
+ }
+
+/* Go back to get another input line. */
+
+ goto L80;
+
+/* Branch to this line when the last record is read. */
+
+L140:
+ cl__1.cerr = 0;
+ cl__1.cunit = 5;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ s2 = dsecnd_();
+ s_wsfe(&io___68);
+ e_wsfe();
+ s_wsfe(&io___69);
+ d__1 = s2 - s1;
+ do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+/* L9988: */
+
+/* End of ZCHKAB */
+
+ return 0;
+} /* MAIN__ */
+
+/* Main program alias */ int zchkab_ () { MAIN__ (); return 0; }
diff --git a/TESTING/LIN/zchkeq.c b/TESTING/LIN/zchkeq.c
new file mode 100644
index 0000000..fc5a30e
--- /dev/null
+++ b/TESTING/LIN/zchkeq.c
@@ -0,0 +1,705 @@
+/* zchkeq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b9 = 10.;
+static integer c_n1 = -1;
+static integer c__5 = 5;
+static integer c__13 = 13;
+static integer c__1 = 1;
+
+/* Subroutine */ int zchkeq_(doublereal *thresh, integer *nout)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002All tests for \002,a3,\002 routines pa"
+ "ssed the threshold\002)";
+ static char fmt_9998[] = "(\002 ZGEEQU failed test with value \002,d10"
+ ".3,\002 exceeding\002,\002 threshold \002,d10.3)";
+ static char fmt_9997[] = "(\002 ZGBEQU failed test with value \002,d10"
+ ".3,\002 exceeding\002,\002 threshold \002,d10.3)";
+ static char fmt_9996[] = "(\002 ZPOEQU failed test with value \002,d10"
+ ".3,\002 exceeding\002,\002 threshold \002,d10.3)";
+ static char fmt_9995[] = "(\002 ZPPEQU failed test with value \002,d10"
+ ".3,\002 exceeding\002,\002 threshold \002,d10.3)";
+ static char fmt_9994[] = "(\002 ZPBEQU failed test with value \002,d10"
+ ".3,\002 exceeding\002,\002 threshold \002,d10.3)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
+ doublereal d__1, d__2, d__3;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double pow_di(doublereal *, integer *);
+ integer pow_ii(integer *, integer *), s_wsle(cilist *), e_wsle(void),
+ s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublecomplex a[25] /* was [5][5] */;
+ doublereal c__[5];
+ integer i__, j, m, n;
+ doublereal r__[5];
+ doublecomplex ab[65] /* was [13][5] */, ap[15];
+ integer kl;
+ logical ok;
+ integer ku;
+ doublereal eps, pow[11];
+ integer info;
+ char path[3];
+ doublereal norm, rpow[11], ccond, rcond, rcmin, rcmax, ratio;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zgbequ_(integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *), zgeequ_(
+ integer *, integer *, doublecomplex *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *)
+ , zpbequ_(char *, integer *, integer *, doublecomplex *, integer *
+, doublereal *, doublereal *, doublereal *, integer *);
+ doublereal reslts[5];
+ extern /* Subroutine */ int zpoequ_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *), zppequ_(
+ char *, integer *, doublecomplex *, doublereal *, doublereal *,
+ doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___25 = { 0, 0, 0, 0, 0 };
+ static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKEQ tests ZGEEQU, ZGBEQU, ZPOEQU, ZPPEQU and ZPBEQU */
+
+/* Arguments */
+/* ========= */
+
+/* THRESH (input) DOUBLE PRECISION */
+/* Threshold for testing routines. Should be between 2 and 10. */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "EQ", (ftnlen)2, (ftnlen)2);
+
+ eps = dlamch_("P");
+ for (i__ = 1; i__ <= 5; ++i__) {
+ reslts[i__ - 1] = 0.;
+/* L10: */
+ }
+ for (i__ = 1; i__ <= 11; ++i__) {
+ i__1 = i__ - 1;
+ pow[i__ - 1] = pow_di(&c_b9, &i__1);
+ rpow[i__ - 1] = 1. / pow[i__ - 1];
+/* L20: */
+ }
+
+/* Test ZGEEQU */
+
+ for (n = 0; n <= 5; ++n) {
+ for (m = 0; m <= 5; ++m) {
+
+ for (j = 1; j <= 5; ++j) {
+ for (i__ = 1; i__ <= 5; ++i__) {
+ if (i__ <= m && j <= n) {
+ i__1 = i__ + j * 5 - 6;
+ i__2 = i__ + j;
+ d__1 = pow[i__ + j] * pow_ii(&c_n1, &i__2);
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ } else {
+ i__1 = i__ + j * 5 - 6;
+ a[i__1].r = 0., a[i__1].i = 0.;
+ }
+/* L30: */
+ }
+/* L40: */
+ }
+
+ zgeequ_(&m, &n, a, &c__5, r__, c__, &rcond, &ccond, &norm, &info);
+
+ if (info != 0) {
+ reslts[0] = 1.;
+ } else {
+ if (n != 0 && m != 0) {
+/* Computing MAX */
+ d__2 = reslts[0], d__3 = (d__1 = (rcond - rpow[m - 1]) /
+ rpow[m - 1], abs(d__1));
+ reslts[0] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = reslts[0], d__3 = (d__1 = (ccond - rpow[n - 1]) /
+ rpow[n - 1], abs(d__1));
+ reslts[0] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = reslts[0], d__3 = (d__1 = (norm - pow[n + m]) /
+ pow[n + m], abs(d__1));
+ reslts[0] = max(d__2,d__3);
+ i__1 = m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = reslts[0], d__3 = (d__1 = (r__[i__ - 1] - rpow[
+ i__ + n]) / rpow[i__ + n], abs(d__1));
+ reslts[0] = max(d__2,d__3);
+/* L50: */
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ d__2 = reslts[0], d__3 = (d__1 = (c__[j - 1] - pow[n
+ - j]) / pow[n - j], abs(d__1));
+ reslts[0] = max(d__2,d__3);
+/* L60: */
+ }
+ }
+ }
+
+/* L70: */
+ }
+/* L80: */
+ }
+
+/* Test with zero rows and columns */
+
+ for (j = 1; j <= 5; ++j) {
+ i__1 = j * 5 - 2;
+ a[i__1].r = 0., a[i__1].i = 0.;
+/* L90: */
+ }
+ zgeequ_(&c__5, &c__5, a, &c__5, r__, c__, &rcond, &ccond, &norm, &info);
+ if (info != 4) {
+ reslts[0] = 1.;
+ }
+
+ for (j = 1; j <= 5; ++j) {
+ i__1 = j * 5 - 2;
+ a[i__1].r = 1., a[i__1].i = 0.;
+/* L100: */
+ }
+ for (i__ = 1; i__ <= 5; ++i__) {
+ i__1 = i__ + 14;
+ a[i__1].r = 0., a[i__1].i = 0.;
+/* L110: */
+ }
+ zgeequ_(&c__5, &c__5, a, &c__5, r__, c__, &rcond, &ccond, &norm, &info);
+ if (info != 9) {
+ reslts[0] = 1.;
+ }
+ reslts[0] /= eps;
+
+/* Test ZGBEQU */
+
+ for (n = 0; n <= 5; ++n) {
+ for (m = 0; m <= 5; ++m) {
+/* Computing MAX */
+ i__2 = m - 1;
+ i__1 = max(i__2,0);
+ for (kl = 0; kl <= i__1; ++kl) {
+/* Computing MAX */
+ i__3 = n - 1;
+ i__2 = max(i__3,0);
+ for (ku = 0; ku <= i__2; ++ku) {
+
+ for (j = 1; j <= 5; ++j) {
+ for (i__ = 1; i__ <= 13; ++i__) {
+ i__3 = i__ + j * 13 - 14;
+ ab[i__3].r = 0., ab[i__3].i = 0.;
+/* L120: */
+ }
+/* L130: */
+ }
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = m;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+/* Computing MIN */
+ i__5 = m, i__6 = j + kl;
+/* Computing MAX */
+ i__7 = 1, i__8 = j - ku;
+ if (i__ <= min(i__5,i__6) && i__ >= max(i__7,i__8)
+ && j <= n) {
+ i__5 = ku + 1 + i__ - j + j * 13 - 14;
+ i__6 = i__ + j;
+ d__1 = pow[i__ + j] * pow_ii(&c_n1, &i__6);
+ ab[i__5].r = d__1, ab[i__5].i = 0.;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+ zgbequ_(&m, &n, &kl, &ku, ab, &c__13, r__, c__, &rcond, &
+ ccond, &norm, &info);
+
+ if (info != 0) {
+ if (! (n + kl < m && info == n + kl + 1 || m + ku < n
+ && info == (m << 1) + ku + 1)) {
+ reslts[1] = 1.;
+ }
+ } else {
+ if (n != 0 && m != 0) {
+
+ rcmin = r__[0];
+ rcmax = r__[0];
+ i__3 = m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = r__[i__ - 1];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = r__[i__ - 1];
+ rcmax = max(d__1,d__2);
+/* L160: */
+ }
+ ratio = rcmin / rcmax;
+/* Computing MAX */
+ d__2 = reslts[1], d__3 = (d__1 = (rcond - ratio) /
+ ratio, abs(d__1));
+ reslts[1] = max(d__2,d__3);
+
+ rcmin = c__[0];
+ rcmax = c__[0];
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+/* Computing MIN */
+ d__1 = rcmin, d__2 = c__[j - 1];
+ rcmin = min(d__1,d__2);
+/* Computing MAX */
+ d__1 = rcmax, d__2 = c__[j - 1];
+ rcmax = max(d__1,d__2);
+/* L170: */
+ }
+ ratio = rcmin / rcmax;
+/* Computing MAX */
+ d__2 = reslts[1], d__3 = (d__1 = (ccond - ratio) /
+ ratio, abs(d__1));
+ reslts[1] = max(d__2,d__3);
+
+/* Computing MAX */
+ d__2 = reslts[1], d__3 = (d__1 = (norm - pow[n +
+ m]) / pow[n + m], abs(d__1));
+ reslts[1] = max(d__2,d__3);
+ i__3 = m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ rcmax = 0.;
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ if (i__ <= j + kl && i__ >= j - ku) {
+ ratio = (d__1 = r__[i__ - 1] * pow[
+ i__ + j] * c__[j - 1], abs(
+ d__1));
+ rcmax = max(rcmax,ratio);
+ }
+/* L180: */
+ }
+/* Computing MAX */
+ d__2 = reslts[1], d__3 = (d__1 = 1. - rcmax,
+ abs(d__1));
+ reslts[1] = max(d__2,d__3);
+/* L190: */
+ }
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ rcmax = 0.;
+ i__4 = m;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ if (i__ <= j + kl && i__ >= j - ku) {
+ ratio = (d__1 = r__[i__ - 1] * pow[
+ i__ + j] * c__[j - 1], abs(
+ d__1));
+ rcmax = max(rcmax,ratio);
+ }
+/* L200: */
+ }
+/* Computing MAX */
+ d__2 = reslts[1], d__3 = (d__1 = 1. - rcmax,
+ abs(d__1));
+ reslts[1] = max(d__2,d__3);
+/* L210: */
+ }
+ }
+ }
+
+/* L220: */
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+/* L250: */
+ }
+ reslts[1] /= eps;
+
+/* Test ZPOEQU */
+
+ for (n = 0; n <= 5; ++n) {
+
+ for (i__ = 1; i__ <= 5; ++i__) {
+ for (j = 1; j <= 5; ++j) {
+ if (i__ <= n && j == i__) {
+ i__1 = i__ + j * 5 - 6;
+ i__2 = i__ + j;
+ d__1 = pow[i__ + j] * pow_ii(&c_n1, &i__2);
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ } else {
+ i__1 = i__ + j * 5 - 6;
+ a[i__1].r = 0., a[i__1].i = 0.;
+ }
+/* L260: */
+ }
+/* L270: */
+ }
+
+ zpoequ_(&n, a, &c__5, r__, &rcond, &norm, &info);
+
+ if (info != 0) {
+ reslts[2] = 1.;
+ } else {
+ if (n != 0) {
+/* Computing MAX */
+ d__2 = reslts[2], d__3 = (d__1 = (rcond - rpow[n - 1]) / rpow[
+ n - 1], abs(d__1));
+ reslts[2] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = reslts[2], d__3 = (d__1 = (norm - pow[n * 2]) / pow[n *
+ 2], abs(d__1));
+ reslts[2] = max(d__2,d__3);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = reslts[2], d__3 = (d__1 = (r__[i__ - 1] - rpow[i__]
+ ) / rpow[i__], abs(d__1));
+ reslts[2] = max(d__2,d__3);
+/* L280: */
+ }
+ }
+ }
+/* L290: */
+ }
+ z__1.r = -1., z__1.i = -0.;
+ a[18].r = z__1.r, a[18].i = z__1.i;
+ zpoequ_(&c__5, a, &c__5, r__, &rcond, &norm, &info);
+ if (info != 4) {
+ reslts[2] = 1.;
+ }
+ reslts[2] /= eps;
+
+/* Test ZPPEQU */
+
+ for (n = 0; n <= 5; ++n) {
+
+/* Upper triangular packed storage */
+
+ i__1 = n * (n + 1) / 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ - 1;
+ ap[i__2].r = 0., ap[i__2].i = 0.;
+/* L300: */
+ }
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ * (i__ + 1) / 2 - 1;
+ i__3 = i__ << 1;
+ ap[i__2].r = pow[i__3], ap[i__2].i = 0.;
+/* L310: */
+ }
+
+ zppequ_("U", &n, ap, r__, &rcond, &norm, &info);
+
+ if (info != 0) {
+ reslts[3] = 1.;
+ } else {
+ if (n != 0) {
+/* Computing MAX */
+ d__2 = reslts[3], d__3 = (d__1 = (rcond - rpow[n - 1]) / rpow[
+ n - 1], abs(d__1));
+ reslts[3] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = reslts[3], d__3 = (d__1 = (norm - pow[n * 2]) / pow[n *
+ 2], abs(d__1));
+ reslts[3] = max(d__2,d__3);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = reslts[3], d__3 = (d__1 = (r__[i__ - 1] - rpow[i__]
+ ) / rpow[i__], abs(d__1));
+ reslts[3] = max(d__2,d__3);
+/* L320: */
+ }
+ }
+ }
+
+/* Lower triangular packed storage */
+
+ i__1 = n * (n + 1) / 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ - 1;
+ ap[i__2].r = 0., ap[i__2].i = 0.;
+/* L330: */
+ }
+ j = 1;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = j - 1;
+ i__3 = i__ << 1;
+ ap[i__2].r = pow[i__3], ap[i__2].i = 0.;
+ j += n - i__ + 1;
+/* L340: */
+ }
+
+ zppequ_("L", &n, ap, r__, &rcond, &norm, &info);
+
+ if (info != 0) {
+ reslts[3] = 1.;
+ } else {
+ if (n != 0) {
+/* Computing MAX */
+ d__2 = reslts[3], d__3 = (d__1 = (rcond - rpow[n - 1]) / rpow[
+ n - 1], abs(d__1));
+ reslts[3] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = reslts[3], d__3 = (d__1 = (norm - pow[n * 2]) / pow[n *
+ 2], abs(d__1));
+ reslts[3] = max(d__2,d__3);
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = reslts[3], d__3 = (d__1 = (r__[i__ - 1] - rpow[i__]
+ ) / rpow[i__], abs(d__1));
+ reslts[3] = max(d__2,d__3);
+/* L350: */
+ }
+ }
+ }
+
+/* L360: */
+ }
+ i__ = 13;
+ i__1 = i__ - 1;
+ z__1.r = -1., z__1.i = -0.;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ zppequ_("L", &c__5, ap, r__, &rcond, &norm, &info);
+ if (info != 4) {
+ reslts[3] = 1.;
+ }
+ reslts[3] /= eps;
+
+/* Test ZPBEQU */
+
+ for (n = 0; n <= 5; ++n) {
+/* Computing MAX */
+ i__2 = n - 1;
+ i__1 = max(i__2,0);
+ for (kl = 0; kl <= i__1; ++kl) {
+
+/* Test upper triangular storage */
+
+ for (j = 1; j <= 5; ++j) {
+ for (i__ = 1; i__ <= 13; ++i__) {
+ i__2 = i__ + j * 13 - 14;
+ ab[i__2].r = 0., ab[i__2].i = 0.;
+/* L370: */
+ }
+/* L380: */
+ }
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = kl + 1 + j * 13 - 14;
+ i__4 = j << 1;
+ ab[i__3].r = pow[i__4], ab[i__3].i = 0.;
+/* L390: */
+ }
+
+ zpbequ_("U", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
+
+ if (info != 0) {
+ reslts[4] = 1.;
+ } else {
+ if (n != 0) {
+/* Computing MAX */
+ d__2 = reslts[4], d__3 = (d__1 = (rcond - rpow[n - 1]) /
+ rpow[n - 1], abs(d__1));
+ reslts[4] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = reslts[4], d__3 = (d__1 = (norm - pow[n * 2]) /
+ pow[n * 2], abs(d__1));
+ reslts[4] = max(d__2,d__3);
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = reslts[4], d__3 = (d__1 = (r__[i__ - 1] - rpow[
+ i__]) / rpow[i__], abs(d__1));
+ reslts[4] = max(d__2,d__3);
+/* L400: */
+ }
+ }
+ }
+ if (n != 0) {
+/* Computing MAX */
+ i__3 = n - 1;
+ i__2 = kl + 1 + max(i__3,1) * 13 - 14;
+ z__1.r = -1., z__1.i = -0.;
+ ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
+ zpbequ_("U", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
+/* Computing MAX */
+ i__2 = n - 1;
+ if (info != max(i__2,1)) {
+ reslts[4] = 1.;
+ }
+ }
+
+/* Test lower triangular storage */
+
+ for (j = 1; j <= 5; ++j) {
+ for (i__ = 1; i__ <= 13; ++i__) {
+ i__2 = i__ + j * 13 - 14;
+ ab[i__2].r = 0., ab[i__2].i = 0.;
+/* L410: */
+ }
+/* L420: */
+ }
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j * 13 - 13;
+ i__4 = j << 1;
+ ab[i__3].r = pow[i__4], ab[i__3].i = 0.;
+/* L430: */
+ }
+
+ zpbequ_("L", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
+
+ if (info != 0) {
+ reslts[4] = 1.;
+ } else {
+ if (n != 0) {
+/* Computing MAX */
+ d__2 = reslts[4], d__3 = (d__1 = (rcond - rpow[n - 1]) /
+ rpow[n - 1], abs(d__1));
+ reslts[4] = max(d__2,d__3);
+/* Computing MAX */
+ d__2 = reslts[4], d__3 = (d__1 = (norm - pow[n * 2]) /
+ pow[n * 2], abs(d__1));
+ reslts[4] = max(d__2,d__3);
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__2 = reslts[4], d__3 = (d__1 = (r__[i__ - 1] - rpow[
+ i__]) / rpow[i__], abs(d__1));
+ reslts[4] = max(d__2,d__3);
+/* L440: */
+ }
+ }
+ }
+ if (n != 0) {
+/* Computing MAX */
+ i__3 = n - 1;
+ i__2 = max(i__3,1) * 13 - 13;
+ z__1.r = -1., z__1.i = -0.;
+ ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
+ zpbequ_("L", &n, &kl, ab, &c__13, r__, &rcond, &norm, &info);
+/* Computing MAX */
+ i__2 = n - 1;
+ if (info != max(i__2,1)) {
+ reslts[4] = 1.;
+ }
+ }
+/* L450: */
+ }
+/* L460: */
+ }
+ reslts[4] /= eps;
+ ok = reslts[0] <= *thresh && reslts[1] <= *thresh && reslts[2] <= *thresh
+ && reslts[3] <= *thresh && reslts[4] <= *thresh;
+ io___25.ciunit = *nout;
+ s_wsle(&io___25);
+ e_wsle();
+ if (ok) {
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ } else {
+ if (reslts[0] > *thresh) {
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__1, (char *)&reslts[0], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ if (reslts[1] > *thresh) {
+ io___28.ciunit = *nout;
+ s_wsfe(&io___28);
+ do_fio(&c__1, (char *)&reslts[1], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ if (reslts[2] > *thresh) {
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ do_fio(&c__1, (char *)&reslts[2], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ if (reslts[3] > *thresh) {
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&reslts[3], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ if (reslts[4] > *thresh) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, (char *)&reslts[4], (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ }
+ return 0;
+
+/* End of ZCHKEQ */
+
+} /* zchkeq_ */
diff --git a/TESTING/LIN/zchkgb.c b/TESTING/LIN/zchkgb.c
new file mode 100644
index 0000000..93e0955
--- /dev/null
+++ b/TESTING/LIN/zchkgb.c
@@ -0,0 +1,879 @@
+/* zchkgb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublecomplex c_b61 = {0.,0.};
+static doublecomplex c_b62 = {1.,0.};
+static integer c__7 = 7;
+
+/* Subroutine */ int zchkgb_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nns, integer *nsval, doublereal *thresh, logical *tsterr,
+ doublecomplex *a, integer *la, doublecomplex *afac, integer *lafac,
+ doublecomplex *b, doublecomplex *x, doublecomplex *xact,
+ doublecomplex *work, doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 *** In ZCHKGB, LA=\002,i5,\002 is too sm"
+ "all for M=\002,i5,\002, N=\002,i5,\002, KL=\002,i4,\002, KU=\002"
+ ",i4,/\002 ==> Increase LA to at least \002,i5)";
+ static char fmt_9998[] = "(\002 *** In ZCHKGB, LAFAC=\002,i5,\002 is too"
+ " small for M=\002,i5,\002, N=\002,i5,\002, KL=\002,i4,\002, KU"
+ "=\002,i4,/\002 ==> Increase LAFAC to at least \002,i5)";
+ static char fmt_9997[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, KL="
+ "\002,i5,\002, KU=\002,i5,\002, NB =\002,i4,\002, type \002,i1"
+ ",\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9996[] = "(\002 TRANS='\002,a1,\002', N=\002,i5,\002, "
+ "KL=\002,i5,\002, KU=\002,i5,\002, NRHS=\002,i3,\002, type \002,i"
+ "1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9995[] = "(\002 NORM ='\002,a1,\002', N=\002,i5,\002, "
+ "KL=\002,i5,\002, KU=\002,i5,\002,\002,10x,\002 type \002,i1,\002"
+ ", test(\002,i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10,
+ i__11;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, m, n, i1, i2, nb, im, in, kl, ku, lda, ldb, inb, ikl,
+ nkl, iku, nku, ioff, mode, koff, imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char norm[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ doublereal rcond;
+ extern /* Subroutine */ int zgbt01_(integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *, doublecomplex *, doublereal *);
+ integer nimat, klval[4];
+ extern /* Subroutine */ int zgbt02_(char *, integer *, integer *, integer
+ *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *), zgbt05_(char *, integer *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *
+, doublereal *, doublereal *, doublereal *);
+ doublereal anorm;
+ integer itran;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+);
+ integer kuval[4];
+ char trans[1];
+ integer izero, nerrs;
+ logical zerot;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ char xtype[1];
+ extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *);
+ integer ldafac;
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ doublereal rcondc;
+ extern doublereal zlangb_(char *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+ doublereal rcondi;
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum, anormi, rcondo;
+ extern /* Subroutine */ int zgbcon_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, integer *, doublereal *,
+ doublereal *, doublecomplex *, doublereal *, integer *);
+ doublereal ainvnm;
+ logical trfcon;
+ doublereal anormo;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), zerrge_(char *,
+ integer *), zgbrfs_(char *, integer *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *, doublereal *, doublereal *, doublecomplex *,
+ doublereal *, integer *), zgbtrf_(integer *, integer *,
+ integer *, integer *, doublecomplex *, integer *, integer *,
+ integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), zlarhs_(char *,
+ char *, char *, char *, integer *, integer *, integer *, integer *
+, integer *, doublecomplex *, integer *, doublecomplex *, integer
+ *, doublecomplex *, integer *, integer *, integer *), zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zgbtrs_(char *, integer *, integer *, integer *, integer
+ *, doublecomplex *, integer *, integer *, doublecomplex *,
+ integer *, integer *), zlatms_(integer *, integer *, char
+ *, integer *, char *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *, char *, doublecomplex *,
+ integer *, doublecomplex *, integer *);
+ doublereal result[7];
+
+ /* Fortran I/O blocks */
+ static cilist io___25 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___26 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKGB tests ZGBTRF, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) COMPLEX*16 array, dimension (LA) */
+
+/* LA (input) INTEGER */
+/* The length of the array A. LA >= (KLMAX+KUMAX+1)*NMAX */
+/* where KLMAX is the largest entry in the local array KLVAL, */
+/* KUMAX is the largest entry in the local array KUVAL and */
+/* NMAX is the largest entry in the input array NVAL. */
+
+/* AFAC (workspace) COMPLEX*16 array, dimension (LAFAC) */
+
+/* LAFAC (input) INTEGER */
+/* The length of the array AFAC. LAFAC >= (2*KLMAX+KUMAX+1)*NMAX */
+/* where KLMAX is the largest entry in the local array KLVAL, */
+/* KUMAX is the largest entry in the local array KUVAL and */
+/* NMAX is the largest entry in the input array NVAL. */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(3,NSMAX,NMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --afac;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "GB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrge_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Initialize the first value for the lower and upper bandwidths. */
+
+ klval[0] = 0;
+ kuval[0] = 0;
+
+/* Do for each value of M in MVAL */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Set values to use for the lower bandwidth. */
+
+ klval[1] = m + (m + 1) / 4;
+
+/* KLVAL( 2 ) = MAX( M-1, 0 ) */
+
+ klval[2] = (m * 3 - 1) / 4;
+ klval[3] = (m + 1) / 4;
+
+/* Do for each value of N in NVAL */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ *(unsigned char *)xtype = 'N';
+
+/* Set values to use for the upper bandwidth. */
+
+ kuval[1] = n + (n + 1) / 4;
+
+/* KUVAL( 2 ) = MAX( N-1, 0 ) */
+
+ kuval[2] = (n * 3 - 1) / 4;
+ kuval[3] = (n + 1) / 4;
+
+/* Set limits on the number of loop iterations. */
+
+/* Computing MIN */
+ i__3 = m + 1;
+ nkl = min(i__3,4);
+ if (n == 0) {
+ nkl = 2;
+ }
+/* Computing MIN */
+ i__3 = n + 1;
+ nku = min(i__3,4);
+ if (m == 0) {
+ nku = 2;
+ }
+ nimat = 8;
+ if (m <= 0 || n <= 0) {
+ nimat = 1;
+ }
+
+ i__3 = nkl;
+ for (ikl = 1; ikl <= i__3; ++ikl) {
+
+/* Do for KL = 0, (5*M+1)/4, (3M-1)/4, and (M+1)/4. This */
+/* order makes it easier to skip redundant values for small */
+/* values of M. */
+
+ kl = klval[ikl - 1];
+ i__4 = nku;
+ for (iku = 1; iku <= i__4; ++iku) {
+
+/* Do for KU = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This */
+/* order makes it easier to skip redundant values for */
+/* small values of N. */
+
+ ku = kuval[iku - 1];
+
+/* Check that A and AFAC are big enough to generate this */
+/* matrix. */
+
+ lda = kl + ku + 1;
+ ldafac = (kl << 1) + ku + 1;
+ if (lda * n > *la || ldafac * n > *lafac) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ if (n * (kl + ku + 1) > *la) {
+ io___25.ciunit = *nout;
+ s_wsfe(&io___25);
+ do_fio(&c__1, (char *)&(*la), (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)
+ );
+ i__5 = n * (kl + ku + 1);
+ do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ if (n * ((kl << 1) + ku + 1) > *lafac) {
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, (char *)&(*lafac), (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer)
+ );
+ i__5 = n * ((kl << 1) + ku + 1);
+ do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ goto L130;
+ }
+
+ i__5 = nimat;
+ for (imat = 1; imat <= i__5; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+/* Skip types 2, 3, or 4 if the matrix size is too */
+/* small. */
+
+ zerot = imat >= 2 && imat <= 4;
+ if (zerot && n < imat - 1) {
+ goto L120;
+ }
+
+ if (! zerot || ! dotype[1]) {
+
+/* Set up parameters with ZLATB4 and generate a */
+/* test matrix with ZLATMS. */
+
+ zlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &
+ anorm, &mode, &cndnum, dist);
+
+/* Computing MAX */
+ i__6 = 1, i__7 = ku + 2 - n;
+ koff = max(i__6,i__7);
+ i__6 = koff - 1;
+ for (i__ = 1; i__ <= i__6; ++i__) {
+ i__7 = i__;
+ a[i__7].r = 0., a[i__7].i = 0.;
+/* L20: */
+ }
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (
+ ftnlen)6);
+ zlatms_(&m, &n, dist, iseed, type__, &rwork[1], &
+ mode, &cndnum, &anorm, &kl, &ku, "Z", &a[
+ koff], &lda, &work[1], &info);
+
+/* Check the error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, " ", &m,
+ &n, &kl, &ku, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ goto L120;
+ }
+ } else if (izero > 0) {
+
+/* Use the same matrix for types 3 and 4 as for */
+/* type 2 by copying back the zeroed out column. */
+
+ i__6 = i2 - i1 + 1;
+ zcopy_(&i__6, &b[1], &c__1, &a[ioff + i1], &c__1);
+ }
+
+/* For types 2, 3, and 4, zero one or more columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ izero = 0;
+ if (zerot) {
+ if (imat == 2) {
+ izero = 1;
+ } else if (imat == 3) {
+ izero = min(m,n);
+ } else {
+ izero = min(m,n) / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 4) {
+
+/* Store the column to be zeroed out in B. */
+
+/* Computing MAX */
+ i__6 = 1, i__7 = ku + 2 - izero;
+ i1 = max(i__6,i__7);
+/* Computing MIN */
+ i__6 = kl + ku + 1, i__7 = ku + 1 + (m -
+ izero);
+ i2 = min(i__6,i__7);
+ i__6 = i2 - i1 + 1;
+ zcopy_(&i__6, &a[ioff + i1], &c__1, &b[1], &
+ c__1);
+
+ i__6 = i2;
+ for (i__ = i1; i__ <= i__6; ++i__) {
+ i__7 = ioff + i__;
+ a[i__7].r = 0., a[i__7].i = 0.;
+/* L30: */
+ }
+ } else {
+ i__6 = n;
+ for (j = izero; j <= i__6; ++j) {
+/* Computing MAX */
+ i__7 = 1, i__8 = ku + 2 - j;
+/* Computing MIN */
+ i__10 = kl + ku + 1, i__11 = ku + 1 + (m
+ - j);
+ i__9 = min(i__10,i__11);
+ for (i__ = max(i__7,i__8); i__ <= i__9;
+ ++i__) {
+ i__7 = ioff + i__;
+ a[i__7].r = 0., a[i__7].i = 0.;
+/* L40: */
+ }
+ ioff += lda;
+/* L50: */
+ }
+ }
+ }
+
+/* These lines, if used in place of the calls in the */
+/* loop over INB, cause the code to bomb on a Sun */
+/* SPARCstation. */
+
+/* ANORMO = ZLANGB( 'O', N, KL, KU, A, LDA, RWORK ) */
+/* ANORMI = ZLANGB( 'I', N, KL, KU, A, LDA, RWORK ) */
+
+/* Do for each blocksize in NBVAL */
+
+ i__6 = *nnb;
+ for (inb = 1; inb <= i__6; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the LU factorization of the band matrix. */
+
+ if (m > 0 && n > 0) {
+ i__9 = kl + ku + 1;
+ zlacpy_("Full", &i__9, &n, &a[1], &lda, &afac[
+ kl + 1], &ldafac);
+ }
+ s_copy(srnamc_1.srnamt, "ZGBTRF", (ftnlen)32, (
+ ftnlen)6);
+ zgbtrf_(&m, &n, &kl, &ku, &afac[1], &ldafac, &
+ iwork[1], &info);
+
+/* Check error code from ZGBTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "ZGBTRF", &info, &izero, " ", &
+ m, &n, &kl, &ku, &nb, &imat, &nfail, &
+ nerrs, nout);
+ }
+ trfcon = FALSE_;
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zgbt01_(&m, &n, &kl, &ku, &a[1], &lda, &afac[1], &
+ ldafac, &iwork[1], &work[1], result);
+
+/* Print information about the tests so far that */
+/* did not pass the threshold. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+/* Skip the remaining tests if this is not the */
+/* first block size or if M .ne. N. */
+
+ if (inb > 1 || m != n) {
+ goto L110;
+ }
+
+ anormo = zlangb_("O", &n, &kl, &ku, &a[1], &lda, &
+ rwork[1]);
+ anormi = zlangb_("I", &n, &kl, &ku, &a[1], &lda, &
+ rwork[1]);
+
+ if (info == 0) {
+
+/* Form the inverse of A so we can get a good */
+/* estimate of CNDNUM = norm(A) * norm(inv(A)). */
+
+ ldb = max(1,n);
+ zlaset_("Full", &n, &n, &c_b61, &c_b62, &work[
+ 1], &ldb);
+ s_copy(srnamc_1.srnamt, "ZGBTRS", (ftnlen)32,
+ (ftnlen)6);
+ zgbtrs_("No transpose", &n, &kl, &ku, &n, &
+ afac[1], &ldafac, &iwork[1], &work[1],
+ &ldb, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = zlange_("O", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormo <= 0. || ainvnm <= 0.) {
+ rcondo = 1.;
+ } else {
+ rcondo = 1. / anormo / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number of */
+/* A. */
+
+ ainvnm = zlange_("I", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormi <= 0. || ainvnm <= 0.) {
+ rcondi = 1.;
+ } else {
+ rcondi = 1. / anormi / ainvnm;
+ }
+ } else {
+
+/* Do only the condition estimate if INFO.NE.0. */
+
+ trfcon = TRUE_;
+ rcondo = 0.;
+ rcondi = 0.;
+ }
+
+/* Skip the solve tests if the matrix is singular. */
+
+ if (trfcon) {
+ goto L90;
+ }
+
+ i__9 = *nns;
+ for (irhs = 1; irhs <= i__9; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+
+ for (itran = 1; itran <= 3; ++itran) {
+ *(unsigned char *)trans = *(unsigned char
+ *)&transs[itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ *(unsigned char *)norm = 'O';
+ } else {
+ rcondc = rcondi;
+ *(unsigned char *)norm = 'I';
+ }
+
+/* + TEST 2: */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)
+ 32, (ftnlen)6);
+ zlarhs_(path, xtype, " ", trans, &n, &n, &
+ kl, &ku, &nrhs, &a[1], &lda, &
+ xact[1], &ldb, &b[1], &ldb, iseed,
+ &info);
+ *(unsigned char *)xtype = 'C';
+ zlacpy_("Full", &n, &nrhs, &b[1], &ldb, &
+ x[1], &ldb);
+
+ s_copy(srnamc_1.srnamt, "ZGBTRS", (ftnlen)
+ 32, (ftnlen)6);
+ zgbtrs_(trans, &n, &kl, &ku, &nrhs, &afac[
+ 1], &ldafac, &iwork[1], &x[1], &
+ ldb, &info);
+
+/* Check error code from ZGBTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZGBTRS", &info, &c__0,
+ trans, &n, &n, &kl, &ku, &
+ c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ zlacpy_("Full", &n, &nrhs, &b[1], &ldb, &
+ work[1], &ldb);
+ zgbt02_(trans, &m, &n, &kl, &ku, &nrhs, &
+ a[1], &lda, &x[1], &ldb, &work[1],
+ &ldb, &result[1]);
+
+/* + TEST 3: */
+/* Check solution from generated exact */
+/* solution. */
+
+ zget04_(&n, &nrhs, &x[1], &ldb, &xact[1],
+ &ldb, &rcondc, &result[2]);
+
+/* + TESTS 4, 5, 6: */
+/* Use iterative refinement to improve the */
+/* solution. */
+
+ s_copy(srnamc_1.srnamt, "ZGBRFS", (ftnlen)
+ 32, (ftnlen)6);
+ zgbrfs_(trans, &n, &kl, &ku, &nrhs, &a[1],
+ &lda, &afac[1], &ldafac, &iwork[
+ 1], &b[1], &ldb, &x[1], &ldb, &
+ rwork[1], &rwork[nrhs + 1], &work[
+ 1], &rwork[(nrhs << 1) + 1], &
+ info);
+
+/* Check error code from ZGBRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZGBRFS", &info, &c__0,
+ trans, &n, &n, &kl, &ku, &
+ nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ zget04_(&n, &nrhs, &x[1], &ldb, &xact[1],
+ &ldb, &rcondc, &result[3]);
+ zgbt05_(trans, &n, &kl, &ku, &nrhs, &a[1],
+ &lda, &b[1], &ldb, &x[1], &ldb, &
+ xact[1], &ldb, &rwork[1], &rwork[
+ nrhs + 1], &result[4]);
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___59.ciunit = *nout;
+ s_wsfe(&io___59);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrhs, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k -
+ 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += 5;
+/* L70: */
+ }
+/* L80: */
+ }
+
+/* + TEST 7: */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+L90:
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ anorm = anormo;
+ rcondc = rcondo;
+ *(unsigned char *)norm = 'O';
+ } else {
+ anorm = anormi;
+ rcondc = rcondi;
+ *(unsigned char *)norm = 'I';
+ }
+ s_copy(srnamc_1.srnamt, "ZGBCON", (ftnlen)32,
+ (ftnlen)6);
+ zgbcon_(norm, &n, &kl, &ku, &afac[1], &ldafac,
+ &iwork[1], &anorm, &rcond, &work[1],
+ &rwork[1], &info);
+
+/* Check error code from ZGBCON. */
+
+ if (info != 0) {
+ alaerh_(path, "ZGBCON", &info, &c__0,
+ norm, &n, &n, &kl, &ku, &c_n1, &
+ imat, &nfail, &nerrs, nout);
+ }
+
+ result[6] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___61.ciunit = *nout;
+ s_wsfe(&io___61);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L100: */
+ }
+L110:
+ ;
+ }
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+
+ return 0;
+
+/* End of ZCHKGB */
+
+} /* zchkgb_ */
diff --git a/TESTING/LIN/zchkge.c b/TESTING/LIN/zchkge.c
new file mode 100644
index 0000000..db84315
--- /dev/null
+++ b/TESTING/LIN/zchkge.c
@@ -0,0 +1,691 @@
+/* zchkge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublecomplex c_b23 = {0.,0.};
+static logical c_true = TRUE_;
+static integer c__8 = 8;
+
+/* Subroutine */ int zchkge_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nns, integer *nsval, doublereal *thresh, logical *tsterr, integer *
+ nmax, doublecomplex *a, doublecomplex *afac, doublecomplex *ainv,
+ doublecomplex *b, doublecomplex *x, doublecomplex *xact,
+ doublecomplex *work, doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M = \002,i5,\002, N =\002,i5,\002, NB "
+ "=\002,i4,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
+ ;
+ static char fmt_9998[] = "(\002 TRANS='\002,a1,\002', N =\002,i5,\002, N"
+ "RHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g1"
+ "2.5)";
+ static char fmt_9997[] = "(\002 NORM ='\002,a1,\002', N =\002,i5,\002"
+ ",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
+ ;
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, im, in, kl, ku, nt, lda, inb, ioff, mode, imat,
+ info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char norm[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ doublereal rcond;
+ integer nimat;
+ extern /* Subroutine */ int zget01_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, doublereal *,
+ doublereal *), zget02_(char *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *);
+ doublereal anorm;
+ integer itran;
+ extern /* Subroutine */ int zget03_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *), zget04_(integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *), zget07_(char *, integer *, integer *
+, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, logical *, doublereal *, doublereal *);
+ char trans[1];
+ integer izero, nerrs;
+ doublereal dummy;
+ integer lwork;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *);
+ doublereal rcondc, rcondi;
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum, anormi, rcondo;
+ extern /* Subroutine */ int zgecon_(char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublecomplex *,
+ doublereal *, integer *);
+ doublereal ainvnm;
+ logical trfcon;
+ doublereal anormo;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), zerrge_(char *,
+ integer *), zgerfs_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zgetrf_(integer *, integer *, doublecomplex *,
+ integer *, integer *, integer *), zlacpy_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlarhs_(char *, char *, char *, char *, integer *,
+ integer *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *, integer *), zgetri_(
+ integer *, doublecomplex *, integer *, integer *, doublecomplex *,
+ integer *, integer *), zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatms_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublecomplex *, integer *, doublecomplex *,
+ integer *);
+ doublereal result[8];
+ extern /* Subroutine */ int zgetrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___50 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKGE tests ZGETRF, -TRI, -TRS, -RFS, and -CON. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(2*NMAX,2*NSMAX+NWORK)) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "GE", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ xlaenv_(&c__1, &c__1);
+ if (*tsterr) {
+ zerrge_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+/* Do for each value of M in MVAL */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+ lda = max(1,m);
+
+/* Do for each value of N in NVAL */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ *(unsigned char *)xtype = 'N';
+ nimat = 11;
+ if (m <= 0 || n <= 0) {
+ nimat = 1;
+ }
+
+ i__3 = nimat;
+ for (imat = 1; imat <= i__3; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L100;
+ }
+
+/* Skip types 5, 6, or 7 if the matrix size is too small. */
+
+ zerot = imat >= 5 && imat <= 7;
+ if (zerot && n < imat - 4) {
+ goto L100;
+ }
+
+/* Set up parameters with ZLATB4 and generate a test matrix */
+/* with ZLATMS. */
+
+ zlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, " ", &m, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L100;
+ }
+
+/* For types 5-7, zero one or more columns of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 5) {
+ izero = 1;
+ } else if (imat == 6) {
+ izero = min(m,n);
+ } else {
+ izero = min(m,n) / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 7) {
+ i__4 = m;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0., a[i__5].i = 0.;
+/* L20: */
+ }
+ } else {
+ i__4 = n - izero + 1;
+ zlaset_("Full", &m, &i__4, &c_b23, &c_b23, &a[ioff +
+ 1], &lda);
+ }
+ } else {
+ izero = 0;
+ }
+
+/* These lines, if used in place of the calls in the DO 60 */
+/* loop, cause the code to bomb on a Sun SPARCstation. */
+
+/* ANORMO = ZLANGE( 'O', M, N, A, LDA, RWORK ) */
+/* ANORMI = ZLANGE( 'I', M, N, A, LDA, RWORK ) */
+
+/* Do for each blocksize in NBVAL */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the LU factorization of the matrix. */
+
+ zlacpy_("Full", &m, &n, &a[1], &lda, &afac[1], &lda);
+ s_copy(srnamc_1.srnamt, "ZGETRF", (ftnlen)32, (ftnlen)6);
+ zgetrf_(&m, &n, &afac[1], &lda, &iwork[1], &info);
+
+/* Check error code from ZGETRF. */
+
+ if (info != izero) {
+ alaerh_(path, "ZGETRF", &info, &izero, " ", &m, &n, &
+ c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
+ }
+ trfcon = FALSE_;
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ zlacpy_("Full", &m, &n, &afac[1], &lda, &ainv[1], &lda);
+ zget01_(&m, &n, &a[1], &lda, &ainv[1], &lda, &iwork[1], &
+ rwork[1], result);
+ nt = 1;
+
+/* + TEST 2 */
+/* Form the inverse if the factorization was successful */
+/* and compute the residual. */
+
+ if (m == n && info == 0) {
+ zlacpy_("Full", &n, &n, &afac[1], &lda, &ainv[1], &
+ lda);
+ s_copy(srnamc_1.srnamt, "ZGETRI", (ftnlen)32, (ftnlen)
+ 6);
+ nrhs = nsval[1];
+ lwork = *nmax * max(3,nrhs);
+ zgetri_(&n, &ainv[1], &lda, &iwork[1], &work[1], &
+ lwork, &info);
+
+/* Check error code from ZGETRI. */
+
+ if (info != 0) {
+ alaerh_(path, "ZGETRI", &info, &c__0, " ", &n, &n,
+ &c_n1, &c_n1, &nb, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+/* Compute the residual for the matrix times its */
+/* inverse. Also compute the 1-norm condition number */
+/* of A. */
+
+ zget03_(&n, &a[1], &lda, &ainv[1], &lda, &work[1], &
+ lda, &rwork[1], &rcondo, &result[1]);
+ anormo = zlange_("O", &m, &n, &a[1], &lda, &rwork[1]);
+
+/* Compute the infinity-norm condition number of A. */
+
+ anormi = zlange_("I", &m, &n, &a[1], &lda, &rwork[1]);
+ ainvnm = zlange_("I", &n, &n, &ainv[1], &lda, &rwork[
+ 1]);
+ if (anormi <= 0. || ainvnm <= 0.) {
+ rcondi = 1.;
+ } else {
+ rcondi = 1. / anormi / ainvnm;
+ }
+ nt = 2;
+ } else {
+
+/* Do only the condition estimate if INFO > 0. */
+
+ trfcon = TRUE_;
+ anormo = zlange_("O", &m, &n, &a[1], &lda, &rwork[1]);
+ anormi = zlange_("I", &m, &n, &a[1], &lda, &rwork[1]);
+ rcondo = 0.;
+ rcondi = 0.;
+ }
+
+/* Print information about the tests so far that did not */
+/* pass the threshold. */
+
+ i__5 = nt;
+ for (k = 1; k <= i__5; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L30: */
+ }
+ nrun += nt;
+
+/* Skip the remaining tests if this is not the first */
+/* block size or if M .ne. N. Skip the solve tests if */
+/* the matrix is singular. */
+
+ if (inb > 1 || m != n) {
+ goto L90;
+ }
+ if (trfcon) {
+ goto L70;
+ }
+
+ i__5 = *nns;
+ for (irhs = 1; irhs <= i__5; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+
+ for (itran = 1; itran <= 3; ++itran) {
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (
+ ftnlen)6);
+ zlarhs_(path, xtype, " ", trans, &n, &n, &kl, &ku,
+ &nrhs, &a[1], &lda, &xact[1], &lda, &b[1]
+, &lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
+ lda);
+ s_copy(srnamc_1.srnamt, "ZGETRS", (ftnlen)32, (
+ ftnlen)6);
+ zgetrs_(trans, &n, &nrhs, &afac[1], &lda, &iwork[
+ 1], &x[1], &lda, &info);
+
+/* Check error code from ZGETRS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZGETRS", &info, &c__0, trans, &
+ n, &n, &c_n1, &c_n1, &nrhs, &imat, &
+ nfail, &nerrs, nout);
+ }
+
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1],
+ &lda);
+ zget02_(trans, &n, &n, &nrhs, &a[1], &lda, &x[1],
+ &lda, &work[1], &lda, &rwork[1], &result[
+ 2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the */
+/* solution. */
+
+ s_copy(srnamc_1.srnamt, "ZGERFS", (ftnlen)32, (
+ ftnlen)6);
+ zgerfs_(trans, &n, &nrhs, &a[1], &lda, &afac[1], &
+ lda, &iwork[1], &b[1], &lda, &x[1], &lda,
+ &rwork[1], &rwork[nrhs + 1], &work[1], &
+ rwork[(nrhs << 1) + 1], &info);
+
+/* Check error code from ZGERFS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZGERFS", &info, &c__0, trans, &
+ n, &n, &c_n1, &c_n1, &nrhs, &imat, &
+ nfail, &nerrs, nout);
+ }
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[4]);
+ zget07_(trans, &n, &nrhs, &a[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &c_true, &rwork[nrhs + 1], &result[5]);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___46.ciunit = *nout;
+ s_wsfe(&io___46);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L40: */
+ }
+ nrun += 5;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+L70:
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ anorm = anormo;
+ rcondc = rcondo;
+ *(unsigned char *)norm = 'O';
+ } else {
+ anorm = anormi;
+ rcondc = rcondi;
+ *(unsigned char *)norm = 'I';
+ }
+ s_copy(srnamc_1.srnamt, "ZGECON", (ftnlen)32, (ftnlen)
+ 6);
+ zgecon_(norm, &n, &afac[1], &lda, &anorm, &rcond, &
+ work[1], &rwork[1], &info);
+
+/* Check error code from ZGECON. */
+
+ if (info != 0) {
+ alaerh_(path, "ZGECON", &info, &c__0, norm, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+/* This line is needed on a Sun SPARCstation. */
+
+ dummy = rcond;
+
+ result[7] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___50.ciunit = *nout;
+ s_wsfe(&io___50);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L80: */
+ }
+L90:
+ ;
+ }
+L100:
+ ;
+ }
+
+/* L110: */
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZCHKGE */
+
+} /* zchkge_ */
diff --git a/TESTING/LIN/zchkgt.c b/TESTING/LIN/zchkgt.c
new file mode 100644
index 0000000..7e70ca7
--- /dev/null
+++ b/TESTING/LIN/zchkgt.c
@@ -0,0 +1,674 @@
+/* zchkgt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__7 = 7;
+static doublereal c_b63 = 1.;
+static doublereal c_b64 = 0.;
+
+/* Subroutine */ int zchkgt_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, doublereal *thresh, logical *tsterr,
+ doublecomplex *a, doublecomplex *af, doublecomplex *b, doublecomplex *
+ x, doublecomplex *xact, doublecomplex *work, doublereal *rwork,
+ integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 0,0,0,1 };
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(12x,\002N =\002,i5,\002,\002,10x,\002 type"
+ " \002,i2,\002, test(\002,i2,\002) = \002,g12.5)";
+ static char fmt_9997[] = "(\002 NORM ='\002,a1,\002', N =\002,i5,\002"
+ ",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) = \002,g12."
+ "5)";
+ static char fmt_9998[] = "(\002 TRANS='\002,a1,\002', N =\002,i5,\002, N"
+ "RHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) = \002,g"
+ "12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, m, n;
+ doublecomplex z__[3];
+ integer in, kl, ku, ix, lda;
+ doublereal cond;
+ integer mode, koff, imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char norm[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ doublereal rcond;
+ integer nimat;
+ doublereal anorm;
+ integer itran;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+);
+ char trans[1];
+ integer izero, nerrs;
+ extern /* Subroutine */ int zgtt01_(integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *), zgtt02_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *), zgtt05_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *);
+ logical zerot;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zlatb4_(char *, integer *, integer *,
+ integer *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *);
+ doublereal rcondc, rcondi;
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *), alasum_(char *, integer *, integer *,
+ integer *, integer *);
+ doublereal rcondo, ainvnm;
+ logical trfcon;
+ extern /* Subroutine */ int zerrge_(char *, integer *);
+ extern doublereal zlangt_(char *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *);
+ extern /* Subroutine */ int zlagtm_(char *, integer *, integer *,
+ doublereal *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ integer *), zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dzasum_(integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zgtcon_(char *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, integer *),
+ zlatms_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zlarnv_(integer *, integer *,
+ integer *, doublecomplex *);
+ doublereal result[7];
+ extern /* Subroutine */ int zgtrfs_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zgttrf_(integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ integer *), zgttrs_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKGT tests ZGTTRF, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*4) */
+
+/* AF (workspace) COMPLEX*16 array, dimension (NMAX*4) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX)+2*NSMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --af;
+ --a;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "GT", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrge_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+/* Computing MAX */
+ i__2 = n - 1;
+ m = max(i__2,0);
+ lda = max(1,n);
+ nimat = 12;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L100;
+ }
+
+/* Set up parameters with ZLATB4. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cond, dist);
+
+ zerot = imat >= 8 && imat <= 10;
+ if (imat <= 6) {
+
+/* Types 1-6: generate matrices of known condition number. */
+
+/* Computing MAX */
+ i__3 = 2 - ku, i__4 = 3 - max(1,n);
+ koff = max(i__3,i__4);
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
+ &anorm, &kl, &ku, "Z", &af[koff], &c__3, &work[1], &
+ info);
+
+/* Check the error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, " ", &n, &n, &kl, &
+ ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L100;
+ }
+ izero = 0;
+
+ if (n > 1) {
+ i__3 = n - 1;
+ zcopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
+ i__3 = n - 1;
+ zcopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
+ }
+ zcopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
+ } else {
+
+/* Types 7-12: generate tridiagonal matrices with */
+/* unknown condition numbers. */
+
+ if (! zerot || ! dotype[7]) {
+
+/* Generate a matrix with elements whose real and */
+/* imaginary parts are from [-1,1]. */
+
+ i__3 = n + (m << 1);
+ zlarnv_(&c__2, iseed, &i__3, &a[1]);
+ if (anorm != 1.) {
+ i__3 = n + (m << 1);
+ zdscal_(&i__3, &anorm, &a[1], &c__1);
+ }
+ } else if (izero > 0) {
+
+/* Reuse the last matrix by copying back the zeroed out */
+/* elements. */
+
+ if (izero == 1) {
+ i__3 = n;
+ a[i__3].r = z__[1].r, a[i__3].i = z__[1].i;
+ if (n > 1) {
+ a[1].r = z__[2].r, a[1].i = z__[2].i;
+ }
+ } else if (izero == n) {
+ i__3 = n * 3 - 2;
+ a[i__3].r = z__[0].r, a[i__3].i = z__[0].i;
+ i__3 = (n << 1) - 1;
+ a[i__3].r = z__[1].r, a[i__3].i = z__[1].i;
+ } else {
+ i__3 = (n << 1) - 2 + izero;
+ a[i__3].r = z__[0].r, a[i__3].i = z__[0].i;
+ i__3 = n - 1 + izero;
+ a[i__3].r = z__[1].r, a[i__3].i = z__[1].i;
+ i__3 = izero;
+ a[i__3].r = z__[2].r, a[i__3].i = z__[2].i;
+ }
+ }
+
+/* If IMAT > 7, set one column of the matrix to 0. */
+
+ if (! zerot) {
+ izero = 0;
+ } else if (imat == 8) {
+ izero = 1;
+ i__3 = n;
+ z__[1].r = a[i__3].r, z__[1].i = a[i__3].i;
+ i__3 = n;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ if (n > 1) {
+ z__[2].r = a[1].r, z__[2].i = a[1].i;
+ a[1].r = 0., a[1].i = 0.;
+ }
+ } else if (imat == 9) {
+ izero = n;
+ i__3 = n * 3 - 2;
+ z__[0].r = a[i__3].r, z__[0].i = a[i__3].i;
+ i__3 = (n << 1) - 1;
+ z__[1].r = a[i__3].r, z__[1].i = a[i__3].i;
+ i__3 = n * 3 - 2;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ i__3 = (n << 1) - 1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ } else {
+ izero = (n + 1) / 2;
+ i__3 = n - 1;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = (n << 1) - 2 + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ i__4 = n - 1 + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ i__4 = i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L20: */
+ }
+ i__3 = n * 3 - 2;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ i__3 = (n << 1) - 1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ }
+ }
+
+/* + TEST 1 */
+/* Factor A as L*U and compute the ratio */
+/* norm(L*U - A) / (n * norm(A) * EPS ) */
+
+ i__3 = n + (m << 1);
+ zcopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
+ s_copy(srnamc_1.srnamt, "ZGTTRF", (ftnlen)32, (ftnlen)6);
+ zgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (m << 1)
+ + 1], &iwork[1], &info);
+
+/* Check error code from ZGTTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "ZGTTRF", &info, &izero, " ", &n, &n, &c__1, &
+ c__1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+ trfcon = info != 0;
+
+ zgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &af[m + 1], &
+ af[n + m + 1], &af[n + (m << 1) + 1], &iwork[1], &work[1],
+ &lda, &rwork[1], result);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+ for (itran = 1; itran <= 2; ++itran) {
+ *(unsigned char *)trans = *(unsigned char *)&transs[itran - 1]
+ ;
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ } else {
+ *(unsigned char *)norm = 'I';
+ }
+ anorm = zlangt_(norm, &n, &a[1], &a[m + 1], &a[n + m + 1]);
+
+ if (! trfcon) {
+
+/* Use ZGTTRS to solve for one column at a time of */
+/* inv(A), computing the maximum column sum as we go. */
+
+ ainvnm = 0.;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__5 = j;
+ x[i__5].r = 0., x[i__5].i = 0.;
+/* L30: */
+ }
+ i__4 = i__;
+ x[i__4].r = 1., x[i__4].i = 0.;
+ zgttrs_(trans, &n, &c__1, &af[1], &af[m + 1], &af[n +
+ m + 1], &af[n + (m << 1) + 1], &iwork[1], &x[
+ 1], &lda, &info);
+/* Computing MAX */
+ d__1 = ainvnm, d__2 = dzasum_(&n, &x[1], &c__1);
+ ainvnm = max(d__1,d__2);
+/* L40: */
+ }
+
+/* Compute RCONDC = 1 / (norm(A) * norm(inv(A)) */
+
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondc = 1.;
+ } else {
+ rcondc = 1. / anorm / ainvnm;
+ }
+ if (itran == 1) {
+ rcondo = rcondc;
+ } else {
+ rcondi = rcondc;
+ }
+ } else {
+ rcondc = 0.;
+ }
+
+/* + TEST 7 */
+/* Estimate the reciprocal of the condition number of the */
+/* matrix. */
+
+ s_copy(srnamc_1.srnamt, "ZGTCON", (ftnlen)32, (ftnlen)6);
+ zgtcon_(norm, &n, &af[1], &af[m + 1], &af[n + m + 1], &af[n +
+ (m << 1) + 1], &iwork[1], &anorm, &rcond, &work[1], &
+ info);
+
+/* Check error code from ZGTCON. */
+
+ if (info != 0) {
+ alaerh_(path, "ZGTCON", &info, &c__0, norm, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+ result[6] = dget06_(&rcond, &rcondc);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L50: */
+ }
+
+/* Skip the remaining tests if the matrix is singular. */
+
+ if (trfcon) {
+ goto L100;
+ }
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* Generate NRHS random solution vectors. */
+
+ ix = 1;
+ i__4 = nrhs;
+ for (j = 1; j <= i__4; ++j) {
+ zlarnv_(&c__2, iseed, &n, &xact[ix]);
+ ix += lda;
+/* L60: */
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+ *(unsigned char *)trans = *(unsigned char *)&transs[itran
+ - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Set the right hand side. */
+
+ zlagtm_(trans, &n, &nrhs, &c_b63, &a[1], &a[m + 1], &a[n
+ + m + 1], &xact[1], &lda, &c_b64, &b[1], &lda);
+
+/* + TEST 2 */
+/* Solve op(A) * X = B and compute the residual. */
+
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+ s_copy(srnamc_1.srnamt, "ZGTTRS", (ftnlen)32, (ftnlen)6);
+ zgttrs_(trans, &n, &nrhs, &af[1], &af[m + 1], &af[n + m +
+ 1], &af[n + (m << 1) + 1], &iwork[1], &x[1], &lda,
+ &info);
+
+/* Check error code from ZGTTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZGTTRS", &info, &c__0, trans, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
+ zgtt02_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
+ &x[1], &lda, &work[1], &lda, &rwork[1], &result[
+ 1]);
+
+/* + TEST 3 */
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[2]);
+
+/* + TESTS 4, 5, and 6 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "ZGTRFS", (ftnlen)32, (ftnlen)6);
+ zgtrfs_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
+ &af[1], &af[m + 1], &af[n + m + 1], &af[n + (m <<
+ 1) + 1], &iwork[1], &b[1], &lda, &x[1], &lda, &
+ rwork[1], &rwork[nrhs + 1], &work[1], &rwork[(
+ nrhs << 1) + 1], &info);
+
+/* Check error code from ZGTRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZGTRFS", &info, &c__0, trans, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[3]);
+ zgtt05_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
+ &b[1], &lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &rwork[nrhs + 1], &result[4]);
+
+/* Print information about the tests that did not pass the */
+/* threshold. */
+
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L70: */
+ }
+ nrun += 5;
+/* L80: */
+ }
+/* L90: */
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZCHKGT */
+
+} /* zchkgt_ */
diff --git a/TESTING/LIN/zchkhe.c b/TESTING/LIN/zchkhe.c
new file mode 100644
index 0000000..403a2a3
--- /dev/null
+++ b/TESTING/LIN/zchkhe.c
@@ -0,0 +1,692 @@
+/* zchkhe.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__8 = 8;
+
+/* Subroutine */ int zchkhe_(logical *dotype, integer *nn, integer *nval,
+ integer *nnb, integer *nbval, integer *nns, integer *nsval,
+ doublereal *thresh, logical *tsterr, integer *nmax, doublecomplex *a,
+ doublecomplex *afac, doublecomplex *ainv, doublecomplex *b,
+ doublecomplex *x, doublecomplex *xact, doublecomplex *work,
+ doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
+ "=\002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
+ "12.5)";
+ static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002"
+ ",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
+ ;
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, nb, in, kl, ku, nt, lda, inb, ioff, mode,
+ imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ doublereal rcond;
+ integer nimat;
+ extern /* Subroutine */ int zhet01_(char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *);
+ doublereal anorm;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+);
+ integer iuplo, izero, nerrs, lwork;
+ extern /* Subroutine */ int zpot02_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *),
+ zpot03_(char *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *), zpot05_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *, doublecomplex *, integer *, doublecomplex *, integer
+ *, doublereal *, doublereal *, doublereal *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *);
+ doublereal rcondc;
+ extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int zlaipd_(integer *, doublecomplex *, integer *,
+ integer *), zhecon_(char *, integer *, doublecomplex *, integer *
+, integer *, doublereal *, doublereal *, doublecomplex *, integer
+ *);
+ logical trfcon;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), zerrhe_(char *,
+ integer *), zherfs_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zhetrf_(char *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), zhetri_(char *,
+ integer *, doublecomplex *, integer *, integer *, doublecomplex *,
+ integer *), zlarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *), zlatms_(integer *, integer *, char *, integer *,
+ char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ doublereal result[8];
+ extern /* Subroutine */ int zhetrs_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKHE tests ZHETRF, -TRI, -TRS, -RFS, and -CON. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "HE", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrhe_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 10;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ izero = 0;
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L170;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L170;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Set up parameters with ZLATB4 and generate a test matrix */
+/* with ZLATMS. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
+ &info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L160;
+ }
+
+/* For types 3-6, zero one or more rows and columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * lda;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ ioff = 0;
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0., a[i__5].i = 0.;
+/* L60: */
+ }
+ ioff += lda;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0., a[i__5].i = 0.;
+/* L80: */
+ }
+ ioff += lda;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ i__3 = lda + 1;
+ zlaipd_(&n, &a[1], &i__3, &c__0);
+
+/* Do for each value of NB in NBVAL */
+
+ i__3 = *nnb;
+ for (inb = 1; inb <= i__3; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the L*D*L' or U*D*U' factorization of the */
+/* matrix. */
+
+ zlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ lwork = max(2,nb) * lda;
+ s_copy(srnamc_1.srnamt, "ZHETRF", (ftnlen)32, (ftnlen)6);
+ zhetrf_(uplo, &n, &afac[1], &lda, &iwork[1], &ainv[1], &
+ lwork, &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from ZHETRF. */
+
+ if (info != k) {
+ alaerh_(path, "ZHETRF", &info, &k, uplo, &n, &n, &
+ c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
+ }
+ if (info != 0) {
+ trfcon = TRUE_;
+ } else {
+ trfcon = FALSE_;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ zhet01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &iwork[1],
+ &ainv[1], &lda, &rwork[1], result);
+ nt = 1;
+
+/* + TEST 2 */
+/* Form the inverse and compute the residual. */
+
+ if (inb == 1 && ! trfcon) {
+ zlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
+ s_copy(srnamc_1.srnamt, "ZHETRI", (ftnlen)32, (ftnlen)
+ 6);
+ zhetri_(uplo, &n, &ainv[1], &lda, &iwork[1], &work[1],
+ &info);
+
+/* Check error code from ZHETRI. */
+
+ if (info != 0) {
+ alaerh_(path, "ZHETRI", &info, &c_n1, uplo, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ zpot03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &work[
+ 1], &lda, &rwork[1], &rcondc, &result[1]);
+ nt = 2;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+
+/* Skip the other tests if this is not the first block */
+/* size. */
+
+ if (inb > 1) {
+ goto L150;
+ }
+
+/* Do only the condition estimate if INFO is not 0. */
+
+ if (trfcon) {
+ rcondc = 0.;
+ goto L140;
+ }
+
+ i__4 = *nns;
+ for (irhs = 1; irhs <= i__4; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "ZHETRS", (ftnlen)32, (ftnlen)
+ 6);
+ zhetrs_(uplo, &n, &nrhs, &afac[1], &lda, &iwork[1], &
+ x[1], &lda, &info);
+
+/* Check error code from ZHETRS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZHETRS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &
+ lda);
+ zpot02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
+ work[1], &lda, &rwork[1], &result[2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "ZHERFS", (ftnlen)32, (ftnlen)
+ 6);
+ zherfs_(uplo, &n, &nrhs, &a[1], &lda, &afac[1], &lda,
+ &iwork[1], &b[1], &lda, &x[1], &lda, &rwork[1]
+, &rwork[nrhs + 1], &work[1], &rwork[(nrhs <<
+ 1) + 1], &info);
+
+/* Check error code from ZHERFS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZHERFS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[4]);
+ zpot05_(uplo, &n, &nrhs, &a[1], &lda, &b[1], &lda, &x[
+ 1], &lda, &xact[1], &lda, &rwork[1], &rwork[
+ nrhs + 1], &result[5]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L120: */
+ }
+ nrun += 5;
+/* L130: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+L140:
+ anorm = zlanhe_("1", uplo, &n, &a[1], &lda, &rwork[1]);
+ s_copy(srnamc_1.srnamt, "ZHECON", (ftnlen)32, (ftnlen)6);
+ zhecon_(uplo, &n, &afac[1], &lda, &iwork[1], &anorm, &
+ rcond, &work[1], &info);
+
+/* Check error code from ZHECON. */
+
+ if (info != 0) {
+ alaerh_(path, "ZHECON", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ result[7] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L150:
+ ;
+ }
+L160:
+ ;
+ }
+L170:
+ ;
+ }
+/* L180: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZCHKHE */
+
+} /* zchkhe_ */
diff --git a/TESTING/LIN/zchkhp.c b/TESTING/LIN/zchkhp.c
new file mode 100644
index 0000000..895d99b
--- /dev/null
+++ b/TESTING/LIN/zchkhp.c
@@ -0,0 +1,659 @@
+/* zchkhp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c__8 = 8;
+
+/* Subroutine */ int zchkhp_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, doublereal *thresh, logical *tsterr,
+ integer *nmax, doublecomplex *a, doublecomplex *afac, doublecomplex *
+ ainv, doublecomplex *b, doublecomplex *x, doublecomplex *xact,
+ doublecomplex *work, doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
+ "12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, in, kl, ku, nt, lda, npp, ioff, mode, imat,
+ info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ extern logical lsame_(char *, char *);
+ doublereal rcond;
+ integer nimat;
+ doublereal anorm;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+), zhpt01_(char *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *);
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int zppt02_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *), zppt03_(char *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *);
+ logical zerot;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zppt05_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *);
+ char xtype[1];
+ extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *);
+ doublereal rcondc;
+ char packit[1];
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int zlaipd_(integer *, doublecomplex *, integer *,
+ integer *);
+ logical trfcon;
+ extern doublereal zlanhp_(char *, char *, integer *, doublecomplex *,
+ doublereal *);
+ extern /* Subroutine */ int zhpcon_(char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublecomplex *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), zlarhs_(char *,
+ char *, char *, char *, integer *, integer *, integer *, integer *
+, integer *, doublecomplex *, integer *, doublecomplex *, integer
+ *, doublecomplex *, integer *, integer *, integer *), zlatms_(integer *, integer *, char *,
+ integer *, char *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *, char *, doublecomplex *,
+ integer *, doublecomplex *, integer *),
+ zhprfs_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *), zhptrf_(char *,
+ integer *, doublecomplex *, integer *, integer *);
+ doublereal result[8];
+ extern /* Subroutine */ int zhptri_(char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), zhptrs_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *), zerrsy_(char *, integer *)
+ ;
+
+ /* Fortran I/O blocks */
+ static cilist io___38 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKHP tests ZHPTRF, -TRI, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AFAC (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AINV (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(2,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, */
+/* dimension (NMAX+2*NSMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "HP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrsy_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 10;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ izero = 0;
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L160;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L160;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ if (lsame_(uplo, "U")) {
+ *(unsigned char *)packit = 'C';
+ } else {
+ *(unsigned char *)packit = 'R';
+ }
+
+/* Set up parameters with ZLATB4 and generate a test matrix */
+/* with ZLATMS. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
+ 1], &info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L150;
+ }
+
+/* For types 3-6, zero one or more rows and columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * izero / 2;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff += i__;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff = ioff + n - i__;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ ioff = 0;
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0., a[i__5].i = 0.;
+/* L60: */
+ }
+ ioff += j;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0., a[i__5].i = 0.;
+/* L80: */
+ }
+ ioff = ioff + n - j;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ if (iuplo == 1) {
+ zlaipd_(&n, &a[1], &c__2, &c__1);
+ } else {
+ zlaipd_(&n, &a[1], &n, &c_n1);
+ }
+
+/* Compute the L*D*L' or U*D*U' factorization of the matrix. */
+
+ npp = n * (n + 1) / 2;
+ zcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ s_copy(srnamc_1.srnamt, "ZHPTRF", (ftnlen)32, (ftnlen)6);
+ zhptrf_(uplo, &n, &afac[1], &iwork[1], &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from ZHPTRF. */
+
+ if (info != k) {
+ alaerh_(path, "ZHPTRF", &info, &k, uplo, &n, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+ if (info != 0) {
+ trfcon = TRUE_;
+ } else {
+ trfcon = FALSE_;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ zhpt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &ainv[1], &lda,
+ &rwork[1], result);
+ nt = 1;
+
+/* + TEST 2 */
+/* Form the inverse and compute the residual. */
+
+ if (! trfcon) {
+ zcopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
+ s_copy(srnamc_1.srnamt, "ZHPTRI", (ftnlen)32, (ftnlen)6);
+ zhptri_(uplo, &n, &ainv[1], &iwork[1], &work[1], &info);
+
+/* Check error code from ZHPTRI. */
+
+ if (info != 0) {
+ alaerh_(path, "ZHPTRI", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ zppt03_(uplo, &n, &a[1], &ainv[1], &work[1], &lda, &rwork[
+ 1], &rcondc, &result[1]);
+ nt = 2;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+
+/* Do only the condition estimate if INFO is not 0. */
+
+ if (trfcon) {
+ rcondc = 0.;
+ goto L140;
+ }
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (ftnlen)6);
+ zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &nrhs, &
+ a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
+ info);
+ *(unsigned char *)xtype = 'C';
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "ZHPTRS", (ftnlen)32, (ftnlen)6);
+ zhptrs_(uplo, &n, &nrhs, &afac[1], &iwork[1], &x[1], &lda,
+ &info);
+
+/* Check error code from ZHPTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZHPTRS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
+ zppt02_(uplo, &n, &nrhs, &a[1], &x[1], &lda, &work[1], &
+ lda, &rwork[1], &result[2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "ZHPRFS", (ftnlen)32, (ftnlen)6);
+ zhprfs_(uplo, &n, &nrhs, &a[1], &afac[1], &iwork[1], &b[1]
+, &lda, &x[1], &lda, &rwork[1], &rwork[nrhs + 1],
+ &work[1], &rwork[(nrhs << 1) + 1], &info);
+
+/* Check error code from ZHPRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZHPRFS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[4]);
+ zppt05_(uplo, &n, &nrhs, &a[1], &b[1], &lda, &x[1], &lda,
+ &xact[1], &lda, &rwork[1], &rwork[nrhs + 1], &
+ result[5]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L120: */
+ }
+ nrun += 5;
+/* L130: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+L140:
+ anorm = zlanhp_("1", uplo, &n, &a[1], &rwork[1]);
+ s_copy(srnamc_1.srnamt, "ZHPCON", (ftnlen)32, (ftnlen)6);
+ zhpcon_(uplo, &n, &afac[1], &iwork[1], &anorm, &rcond, &work[
+ 1], &info);
+
+/* Check error code from ZHPCON. */
+
+ if (info != 0) {
+ alaerh_(path, "ZHPCON", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+ result[7] = dget06_(&rcond, &rcondc);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___43.ciunit = *nout;
+ s_wsfe(&io___43);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L150:
+ ;
+ }
+L160:
+ ;
+ }
+/* L170: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZCHKHP */
+
+} /* zchkhp_ */
diff --git a/TESTING/LIN/zchklq.c b/TESTING/LIN/zchklq.c
new file mode 100644
index 0000000..50e4809
--- /dev/null
+++ b/TESTING/LIN/zchklq.c
@@ -0,0 +1,475 @@
+/* zchklq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int zchklq_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nxval, integer *nrhs, doublereal *thresh, logical *tsterr, integer *
+ nmax, doublecomplex *a, doublecomplex *af, doublecomplex *aq,
+ doublecomplex *al, doublecomplex *ac, doublecomplex *b, doublecomplex
+ *x, doublecomplex *xact, doublecomplex *tau, doublecomplex *work,
+ doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
+ "5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
+ "t(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, ik, im, in, kl, nk, ku, nt, nx, lda, inb, mode,
+ imat, info;
+ char path[3];
+ integer kval[4];
+ char dist[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int zget02_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *);
+ doublereal anorm;
+ integer minmn, nerrs;
+ extern /* Subroutine */ int zlqt01_(integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublereal *,
+ doublereal *), zlqt02_(integer *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+ integer lwork;
+ extern /* Subroutine */ int zlqt03_(integer *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublereal *, doublereal *), zlatb4_(char *, integer *, integer *,
+ integer *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *), alasum_(char *, integer *,
+ integer *, integer *, integer *);
+ doublereal cndnum;
+ extern logical zgennd_(integer *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *), zlarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *), zgelqs_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *), zlatms_(
+ integer *, integer *, char *, integer *, char *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *, char
+ *, doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal result[8];
+ extern /* Subroutine */ int zerrlq_(char *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKLQ tests ZGELQF, ZUNGLQ and CUNMLQ. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AQ (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AL (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* TAU (workspace) COMPLEX*16 array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --tau;
+ --xact;
+ --x;
+ --b;
+ --ac;
+ --al;
+ --aq;
+ --af;
+ --a;
+ --nxval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "LQ", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrlq_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+ lda = *nmax;
+ lwork = *nmax * max(*nmax,*nrhs);
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Do for each value of N in NVAL. */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ minmn = min(m,n);
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L50;
+ }
+
+/* Set up parameters with ZLATB4 and generate a test matrix */
+/* with ZLATMS. */
+
+ zlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, " ", &m, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L50;
+ }
+
+/* Set some values for K: the first value must be MINMN, */
+/* corresponding to the call of ZLQT01; other values are */
+/* used in the calls of ZLQT02, and must not exceed MINMN. */
+
+ kval[0] = minmn;
+ kval[1] = 0;
+ kval[2] = 1;
+ kval[3] = minmn / 2;
+ if (minmn == 0) {
+ nk = 1;
+ } else if (minmn == 1) {
+ nk = 2;
+ } else if (minmn <= 3) {
+ nk = 3;
+ } else {
+ nk = 4;
+ }
+
+/* Do for each value of K in KVAL */
+
+ i__3 = nk;
+ for (ik = 1; ik <= i__3; ++ik) {
+ k = kval[ik - 1];
+
+/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ nx = nxval[inb];
+ xlaenv_(&c__3, &nx);
+ for (i__ = 1; i__ <= 8; ++i__) {
+ result[i__ - 1] = 0.;
+ }
+ nt = 2;
+ if (ik == 1) {
+
+/* Test ZGELQF */
+
+ zlqt01_(&m, &n, &a[1], &af[1], &aq[1], &al[1], &
+ lda, &tau[1], &work[1], &lwork, &rwork[1],
+ result);
+ if (! zgennd_(&m, &n, &af[1], &lda)) {
+ result[7] = *thresh * 2;
+ }
+ ++nt;
+ } else if (m <= n) {
+
+/* Test ZUNGLQ, using factorization */
+/* returned by ZLQT01 */
+
+ zlqt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &al[1],
+ &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], result);
+ } else {
+ result[0] = 0.;
+ result[1] = 0.;
+ }
+ if (m >= k) {
+
+/* Test ZUNMLQ, using factorization returned */
+/* by ZLQT01 */
+
+ zlqt03_(&m, &n, &k, &af[1], &ac[1], &al[1], &aq[1]
+, &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], &result[2]);
+ nt += 4;
+
+/* If M>=N and K=N, call ZGELQS to solve a system */
+/* with NRHS right hand sides and compute the */
+/* residual. */
+
+ if (k == m && inb == 1) {
+
+/* Generate a solution and set the right */
+/* hand side. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32,
+ (ftnlen)6);
+ zlarhs_(path, "New", "Full", "No transpose", &
+ m, &n, &c__0, &c__0, nrhs, &a[1], &
+ lda, &xact[1], &lda, &b[1], &lda,
+ iseed, &info);
+
+ zlacpy_("Full", &m, nrhs, &b[1], &lda, &x[1],
+ &lda);
+ s_copy(srnamc_1.srnamt, "ZGELQS", (ftnlen)32,
+ (ftnlen)6);
+ zgelqs_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
+ x[1], &lda, &work[1], &lwork, &info);
+
+/* Check error code from ZGELQS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZGELQS", &info, &c__0,
+ " ", &m, &n, nrhs, &c_n1, &nb, &
+ imat, &nfail, &nerrs, nout);
+ }
+
+ zget02_("No transpose", &m, &n, nrhs, &a[1], &
+ lda, &x[1], &lda, &b[1], &lda, &rwork[
+ 1], &result[6]);
+ ++nt;
+ } else {
+ result[6] = 0.;
+ }
+ } else {
+ result[2] = 0.;
+ result[3] = 0.;
+ result[4] = 0.;
+ result[5] = 0.;
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__5 = nt;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+/* L30: */
+ }
+/* L40: */
+ }
+L50:
+ ;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZCHKLQ */
+
+} /* zchklq_ */
diff --git a/TESTING/LIN/zchkpb.c b/TESTING/LIN/zchkpb.c
new file mode 100644
index 0000000..7aedd18
--- /dev/null
+++ b/TESTING/LIN/zchkpb.c
@@ -0,0 +1,716 @@
+/* zchkpb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static doublecomplex c_b50 = {0.,0.};
+static doublecomplex c_b51 = {1.,0.};
+static integer c__7 = 7;
+
+/* Subroutine */ int zchkpb_(logical *dotype, integer *nn, integer *nval,
+ integer *nnb, integer *nbval, integer *nns, integer *nsval,
+ doublereal *thresh, logical *tsterr, integer *nmax, doublecomplex *a,
+ doublecomplex *afac, doublecomplex *ainv, doublecomplex *b,
+ doublecomplex *x, doublecomplex *xact, doublecomplex *work,
+ doublereal *rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
+ "=\002,i5,\002, NB=\002,i4,\002, type \002,i2,\002, test \002,i2"
+ ",\002, ratio= \002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
+ "=\002,i5,\002, NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i"
+ "2,\002) = \002,g12.5)";
+ static char fmt_9997[] = "(\002 UPLO='\002,a1,\002', N=\002,i5,\002, KD"
+ "=\002,i5,\002,\002,10x,\002 type \002,i2,\002, test(\002,i2,\002"
+ ") = \002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, i1, i2, kd, nb, in, kl, iw, ku, lda, ikd, inb, nkd,
+ ldab, ioff, mode, koff, imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ integer kdval[4];
+ doublereal rcond;
+ integer nimat;
+ doublereal anorm;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+), zpbt01_(char *, integer *, integer *, doublecomplex *, integer
+ *, doublecomplex *, integer *, doublereal *, doublereal *)
+ , zpbt02_(char *, integer *, integer *, integer *, doublecomplex *
+, integer *, doublecomplex *, integer *, doublecomplex *, integer
+ *, doublereal *, doublereal *), zpbt05_(char *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *, doublecomplex *, integer *, doublecomplex *, integer
+ *, doublereal *, doublereal *, doublereal *);
+ integer iuplo, izero, nerrs;
+ logical zerot;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *);
+ char xtype[1];
+ extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *);
+ doublereal rcondc;
+ char packit[1];
+ extern doublereal zlanhb_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *),
+ zlange_(char *, integer *, integer *, doublecomplex *, integer *,
+ doublereal *);
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int zlaipd_(integer *, doublecomplex *, integer *,
+ integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int zpbcon_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *), xlaenv_(
+ integer *, integer *), zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ integer *), zlaset_(char *,
+ integer *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *), zpbrfs_(char *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *
+, doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zpbtrf_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *), zlatms_(integer *,
+ integer *, char *, integer *, char *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *, char *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal result[7];
+ extern /* Subroutine */ int zerrpo_(char *, integer *), zpbtrs_(
+ char *, integer *, integer *, integer *, doublecomplex *, integer
+ *, doublecomplex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___48 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKPB tests ZPBTRF, -TRS, -RFS, and -CON. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
+
+/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "PB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrpo_(path, nout);
+ }
+ infoc_1.infot = 0;
+ kdval[0] = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+
+/* Set limits on the number of loop iterations. */
+
+/* Computing MAX */
+ i__2 = 1, i__3 = min(n,4);
+ nkd = max(i__2,i__3);
+ nimat = 8;
+ if (n == 0) {
+ nimat = 1;
+ }
+
+ kdval[1] = n + (n + 1) / 4;
+ kdval[2] = (n * 3 - 1) / 4;
+ kdval[3] = (n + 1) / 4;
+
+ i__2 = nkd;
+ for (ikd = 1; ikd <= i__2; ++ikd) {
+
+/* Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order */
+/* makes it easier to skip redundant values for small values */
+/* of N. */
+
+ kd = kdval[ikd - 1];
+ ldab = kd + 1;
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ koff = 1;
+ if (iuplo == 1) {
+ *(unsigned char *)uplo = 'U';
+/* Computing MAX */
+ i__3 = 1, i__4 = kd + 2 - n;
+ koff = max(i__3,i__4);
+ *(unsigned char *)packit = 'Q';
+ } else {
+ *(unsigned char *)uplo = 'L';
+ *(unsigned char *)packit = 'B';
+ }
+
+ i__3 = nimat;
+ for (imat = 1; imat <= i__3; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L60;
+ }
+
+/* Skip types 2, 3, or 4 if the matrix size is too small. */
+
+ zerot = imat >= 2 && imat <= 4;
+ if (zerot && n < imat - 1) {
+ goto L60;
+ }
+
+ if (! zerot || ! dotype[1]) {
+
+/* Set up parameters with ZLATB4 and generate a test */
+/* matrix with ZLATMS. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm,
+ &mode, &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)
+ 6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode,
+ &cndnum, &anorm, &kd, &kd, packit, &a[koff],
+ &ldab, &work[1], &info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, uplo, &n, &
+ n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ goto L60;
+ }
+ } else if (izero > 0) {
+
+/* Use the same matrix for types 3 and 4 as for type */
+/* 2 by copying back the zeroed out column, */
+
+ iw = (lda << 1) + 1;
+ if (iuplo == 1) {
+ ioff = (izero - 1) * ldab + kd + 1;
+ i__4 = izero - i1;
+ zcopy_(&i__4, &work[iw], &c__1, &a[ioff - izero +
+ i1], &c__1);
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ zcopy_(&i__4, &work[iw], &c__1, &a[ioff], &i__5);
+ } else {
+ ioff = (i1 - 1) * ldab + 1;
+ i__4 = izero - i1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ zcopy_(&i__4, &work[iw], &c__1, &a[ioff + izero -
+ i1], &i__5);
+ ioff = (izero - 1) * ldab + 1;
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+ zcopy_(&i__4, &work[iw], &c__1, &a[ioff], &c__1);
+ }
+ }
+
+/* For types 2-4, zero one row and column of the matrix */
+/* to test that INFO is returned correctly. */
+
+ izero = 0;
+ if (zerot) {
+ if (imat == 2) {
+ izero = 1;
+ } else if (imat == 3) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+/* Save the zeroed out row and column in WORK(*,3) */
+
+ iw = lda << 1;
+/* Computing MIN */
+ i__5 = (kd << 1) + 1;
+ i__4 = min(i__5,n);
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = iw + i__;
+ work[i__5].r = 0., work[i__5].i = 0.;
+/* L20: */
+ }
+ ++iw;
+/* Computing MAX */
+ i__4 = izero - kd;
+ i1 = max(i__4,1);
+/* Computing MIN */
+ i__4 = izero + kd;
+ i2 = min(i__4,n);
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * ldab + kd + 1;
+ i__4 = izero - i1;
+ zswap_(&i__4, &a[ioff - izero + i1], &c__1, &work[
+ iw], &c__1);
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ zswap_(&i__4, &a[ioff], &i__5, &work[iw], &c__1);
+ } else {
+ ioff = (i1 - 1) * ldab + 1;
+ i__4 = izero - i1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ zswap_(&i__4, &a[ioff + izero - i1], &i__5, &work[
+ iw], &c__1);
+ ioff = (izero - 1) * ldab + 1;
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+ zswap_(&i__4, &a[ioff], &c__1, &work[iw], &c__1);
+ }
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ if (iuplo == 1) {
+ zlaipd_(&n, &a[kd + 1], &ldab, &c__0);
+ } else {
+ zlaipd_(&n, &a[1], &ldab, &c__0);
+ }
+
+/* Do for each value of NB in NBVAL */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the L*L' or U'*U factorization of the band */
+/* matrix. */
+
+ i__5 = kd + 1;
+ zlacpy_("Full", &i__5, &n, &a[1], &ldab, &afac[1], &
+ ldab);
+ s_copy(srnamc_1.srnamt, "ZPBTRF", (ftnlen)32, (ftnlen)
+ 6);
+ zpbtrf_(uplo, &n, &kd, &afac[1], &ldab, &info);
+
+/* Check error code from ZPBTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "ZPBTRF", &info, &izero, uplo, &n, &
+ n, &kd, &kd, &nb, &imat, &nfail, &nerrs,
+ nout);
+ goto L50;
+ }
+
+/* Skip the tests if INFO is not 0. */
+
+ if (info != 0) {
+ goto L50;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ i__5 = kd + 1;
+ zlacpy_("Full", &i__5, &n, &afac[1], &ldab, &ainv[1],
+ &ldab);
+ zpbt01_(uplo, &n, &kd, &a[1], &ldab, &ainv[1], &ldab,
+ &rwork[1], result);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+/* Only do other tests if this is the first blocksize. */
+
+ if (inb > 1) {
+ goto L50;
+ }
+
+/* Form the inverse of A so we can get a good estimate */
+/* of RCONDC = 1/(norm(A) * norm(inv(A))). */
+
+ zlaset_("Full", &n, &n, &c_b50, &c_b51, &ainv[1], &
+ lda);
+ s_copy(srnamc_1.srnamt, "ZPBTRS", (ftnlen)32, (ftnlen)
+ 6);
+ zpbtrs_(uplo, &n, &kd, &n, &afac[1], &ldab, &ainv[1],
+ &lda, &info);
+
+/* Compute RCONDC = 1/(norm(A) * norm(inv(A))). */
+
+ anorm = zlanhb_("1", uplo, &n, &kd, &a[1], &ldab, &
+ rwork[1]);
+ ainvnm = zlange_("1", &n, &n, &ainv[1], &lda, &rwork[
+ 1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondc = 1.;
+ } else {
+ rcondc = 1. / anorm / ainvnm;
+ }
+
+ i__5 = *nns;
+ for (irhs = 1; irhs <= i__5; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 2 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (
+ ftnlen)6);
+ zlarhs_(path, xtype, uplo, " ", &n, &n, &kd, &kd,
+ &nrhs, &a[1], &ldab, &xact[1], &lda, &b[1]
+, &lda, iseed, &info);
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "ZPBTRS", (ftnlen)32, (
+ ftnlen)6);
+ zpbtrs_(uplo, &n, &kd, &nrhs, &afac[1], &ldab, &x[
+ 1], &lda, &info);
+
+/* Check error code from ZPBTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZPBTRS", &info, &c__0, uplo, &
+ n, &n, &kd, &kd, &nrhs, &imat, &nfail,
+ &nerrs, nout);
+ }
+
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1],
+ &lda);
+ zpbt02_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &x[1],
+ &lda, &work[1], &lda, &rwork[1], &result[
+ 1]);
+
+/* + TEST 3 */
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* + TESTS 4, 5, and 6 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "ZPBRFS", (ftnlen)32, (
+ ftnlen)6);
+ zpbrfs_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &afac[
+ 1], &ldab, &b[1], &lda, &x[1], &lda, &
+ rwork[1], &rwork[nrhs + 1], &work[1], &
+ rwork[(nrhs << 1) + 1], &info);
+
+/* Check error code from ZPBRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZPBRFS", &info, &c__0, uplo, &
+ n, &n, &kd, &kd, &nrhs, &imat, &nfail,
+ &nerrs, nout);
+ }
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+ zpbt05_(uplo, &n, &kd, &nrhs, &a[1], &ldab, &b[1],
+ &lda, &x[1], &lda, &xact[1], &lda, &
+ rwork[1], &rwork[nrhs + 1], &result[4]);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___46.ciunit = *nout;
+ s_wsfe(&io___46);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L30: */
+ }
+ nrun += 5;
+/* L40: */
+ }
+
+/* + TEST 7 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ s_copy(srnamc_1.srnamt, "ZPBCON", (ftnlen)32, (ftnlen)
+ 6);
+ zpbcon_(uplo, &n, &kd, &afac[1], &ldab, &anorm, &
+ rcond, &work[1], &rwork[1], &info);
+
+/* Check error code from ZPBCON. */
+
+ if (info != 0) {
+ alaerh_(path, "ZPBCON", &info, &c__0, uplo, &n, &
+ n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ result[6] = dget06_(&rcond, &rcondc);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___48.ciunit = *nout;
+ s_wsfe(&io___48);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L50:
+ ;
+ }
+L60:
+ ;
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZCHKPB */
+
+} /* zchkpb_ */
diff --git a/TESTING/LIN/zchkpo.c b/TESTING/LIN/zchkpo.c
new file mode 100644
index 0000000..5bc8123
--- /dev/null
+++ b/TESTING/LIN/zchkpo.c
@@ -0,0 +1,611 @@
+/* zchkpo.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__8 = 8;
+
+/* Subroutine */ int zchkpo_(logical *dotype, integer *nn, integer *nval,
+ integer *nnb, integer *nbval, integer *nns, integer *nsval,
+ doublereal *thresh, logical *tsterr, integer *nmax, doublecomplex *a,
+ doublecomplex *afac, doublecomplex *ainv, doublecomplex *b,
+ doublecomplex *x, doublecomplex *xact, doublecomplex *work,
+ doublereal *rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
+ "=\002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
+ "12.5)";
+ static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002"
+ ",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
+ ;
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, nb, in, kl, ku, lda, inb, ioff, mode, imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ doublereal rcond;
+ integer nimat;
+ doublereal anorm;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+);
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int zpot01_(char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *), zpot02_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *), zpot03_(char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *), zpot05_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *);
+ doublereal rcondc;
+ extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int zlaipd_(integer *, doublecomplex *, integer *,
+ integer *), xlaenv_(integer *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zlarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *), zpocon_(char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublecomplex *,
+ doublereal *, integer *), zlatms_(integer *, integer *,
+ char *, integer *, char *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *, char *, doublecomplex *,
+ integer *, doublecomplex *, integer *);
+ doublereal result[8];
+ extern /* Subroutine */ int zerrpo_(char *, integer *), zporfs_(
+ char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *), zpotrf_(char *,
+ integer *, doublecomplex *, integer *, integer *),
+ zpotri_(char *, integer *, doublecomplex *, integer *, integer *), zpotrs_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKPO tests ZPOTRF, -TRI, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (NMAX+2*NSMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "PO", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrpo_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ izero = 0;
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L110;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot && n < imat - 2) {
+ goto L110;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Set up parameters with ZLATB4 and generate a test matrix */
+/* with ZLATMS. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
+ &info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L100;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ i__3 = lda + 1;
+ zlaipd_(&n, &a[1], &i__3, &c__0);
+
+/* Do for each value of NB in NBVAL */
+
+ i__3 = *nnb;
+ for (inb = 1; inb <= i__3; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the L*L' or U'*U factorization of the matrix. */
+
+ zlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ s_copy(srnamc_1.srnamt, "ZPOTRF", (ftnlen)32, (ftnlen)6);
+ zpotrf_(uplo, &n, &afac[1], &lda, &info);
+
+/* Check error code from ZPOTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "ZPOTRF", &info, &izero, uplo, &n, &n, &
+ c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+
+/* Skip the tests if INFO is not 0. */
+
+ if (info != 0) {
+ goto L90;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ zlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
+ zpot01_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &rwork[1],
+ result);
+
+/* + TEST 2 */
+/* Form the inverse and compute the residual. */
+
+ zlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
+ s_copy(srnamc_1.srnamt, "ZPOTRI", (ftnlen)32, (ftnlen)6);
+ zpotri_(uplo, &n, &ainv[1], &lda, &info);
+
+/* Check error code from ZPOTRI. */
+
+ if (info != 0) {
+ alaerh_(path, "ZPOTRI", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ zpot03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &work[1], &
+ lda, &rwork[1], &rcondc, &result[1]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 1; k <= 2; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += 2;
+
+/* Skip the rest of the tests unless this is the first */
+/* blocksize. */
+
+ if (inb != 1) {
+ goto L90;
+ }
+
+ i__4 = *nns;
+ for (irhs = 1; irhs <= i__4; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B . */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "ZPOTRS", (ftnlen)32, (ftnlen)
+ 6);
+ zpotrs_(uplo, &n, &nrhs, &afac[1], &lda, &x[1], &lda,
+ &info);
+
+/* Check error code from ZPOTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZPOTRS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &
+ lda);
+ zpot02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
+ work[1], &lda, &rwork[1], &result[2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "ZPORFS", (ftnlen)32, (ftnlen)
+ 6);
+ zporfs_(uplo, &n, &nrhs, &a[1], &lda, &afac[1], &lda,
+ &b[1], &lda, &x[1], &lda, &rwork[1], &rwork[
+ nrhs + 1], &work[1], &rwork[(nrhs << 1) + 1],
+ &info);
+
+/* Check error code from ZPORFS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZPORFS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[4]);
+ zpot05_(uplo, &n, &nrhs, &a[1], &lda, &b[1], &lda, &x[
+ 1], &lda, &xact[1], &lda, &rwork[1], &rwork[
+ nrhs + 1], &result[5]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L70: */
+ }
+ nrun += 5;
+/* L80: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ anorm = zlanhe_("1", uplo, &n, &a[1], &lda, &rwork[1]);
+ s_copy(srnamc_1.srnamt, "ZPOCON", (ftnlen)32, (ftnlen)6);
+ zpocon_(uplo, &n, &afac[1], &lda, &anorm, &rcond, &work[1]
+, &rwork[1], &info);
+
+/* Check error code from ZPOCON. */
+
+ if (info != 0) {
+ alaerh_(path, "ZPOCON", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ result[7] = dget06_(&rcond, &rcondc);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L90:
+ ;
+ }
+L100:
+ ;
+ }
+L110:
+ ;
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZCHKPO */
+
+} /* zchkpo_ */
diff --git a/TESTING/LIN/zchkpp.c b/TESTING/LIN/zchkpp.c
new file mode 100644
index 0000000..a31ab9d
--- /dev/null
+++ b/TESTING/LIN/zchkpp.c
@@ -0,0 +1,582 @@
+/* zchkpp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c__8 = 8;
+
+/* Subroutine */ int zchkpp_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, doublereal *thresh, logical *tsterr,
+ integer *nmax, doublecomplex *a, doublecomplex *afac, doublecomplex *
+ ainv, doublecomplex *b, doublecomplex *x, doublecomplex *xact,
+ doublecomplex *work, doublereal *rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char packs[1*2] = "C" "R";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
+ "12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, in, kl, ku, lda, npp, ioff, mode, imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ doublereal rcond;
+ integer nimat;
+ doublereal anorm;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+);
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int zppt01_(char *, integer *, doublecomplex *,
+ doublecomplex *, doublereal *, doublereal *), zppt02_(
+ char *, integer *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *), zppt03_(char *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *, doublereal *,
+ doublereal *, doublereal *);
+ logical zerot;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zppt05_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *);
+ char xtype[1];
+ extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *);
+ doublereal rcondc;
+ char packit[1];
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int zlaipd_(integer *, doublecomplex *, integer *,
+ integer *);
+ extern doublereal zlanhp_(char *, char *, integer *, doublecomplex *,
+ doublereal *);
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ integer *), zppcon_(char *,
+ integer *, doublecomplex *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *), zlatms_(
+ integer *, integer *, char *, integer *, char *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *, char
+ *, doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal result[8];
+ extern /* Subroutine */ int zerrpo_(char *, integer *), zpprfs_(
+ char *, integer *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zpptrf_(char *, integer *, doublecomplex *,
+ integer *), zpptri_(char *, integer *, doublecomplex *,
+ integer *), zpptrs_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKPP tests ZPPTRF, -TRI, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AFAC (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AINV (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "PP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrpo_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L100;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot && n < imat - 2) {
+ goto L100;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ *(unsigned char *)packit = *(unsigned char *)&packs[iuplo - 1]
+ ;
+
+/* Set up parameters with ZLATB4 and generate a test matrix */
+/* with ZLATMS. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
+ 1], &info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * izero / 2;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff += i__;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff = ioff + n - i__;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ if (iuplo == 1) {
+ zlaipd_(&n, &a[1], &c__2, &c__1);
+ } else {
+ zlaipd_(&n, &a[1], &n, &c_n1);
+ }
+
+/* Compute the L*L' or U'*U factorization of the matrix. */
+
+ npp = n * (n + 1) / 2;
+ zcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ s_copy(srnamc_1.srnamt, "ZPPTRF", (ftnlen)32, (ftnlen)6);
+ zpptrf_(uplo, &n, &afac[1], &info);
+
+/* Check error code from ZPPTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "ZPPTRF", &info, &izero, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+
+/* Skip the tests if INFO is not 0. */
+
+ if (info != 0) {
+ goto L90;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ zcopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
+ zppt01_(uplo, &n, &a[1], &ainv[1], &rwork[1], result);
+
+/* + TEST 2 */
+/* Form the inverse and compute the residual. */
+
+ zcopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
+ s_copy(srnamc_1.srnamt, "ZPPTRI", (ftnlen)32, (ftnlen)6);
+ zpptri_(uplo, &n, &ainv[1], &info);
+
+/* Check error code from ZPPTRI. */
+
+ if (info != 0) {
+ alaerh_(path, "ZPPTRI", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+ zppt03_(uplo, &n, &a[1], &ainv[1], &work[1], &lda, &rwork[1],
+ &rcondc, &result[1]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 1; k <= 2; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += 2;
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (ftnlen)6);
+ zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &nrhs, &
+ a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
+ info);
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "ZPPTRS", (ftnlen)32, (ftnlen)6);
+ zpptrs_(uplo, &n, &nrhs, &afac[1], &x[1], &lda, &info);
+
+/* Check error code from ZPPTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZPPTRS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
+ zppt02_(uplo, &n, &nrhs, &a[1], &x[1], &lda, &work[1], &
+ lda, &rwork[1], &result[2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "ZPPRFS", (ftnlen)32, (ftnlen)6);
+ zpprfs_(uplo, &n, &nrhs, &a[1], &afac[1], &b[1], &lda, &x[
+ 1], &lda, &rwork[1], &rwork[nrhs + 1], &work[1], &
+ rwork[(nrhs << 1) + 1], &info);
+
+/* Check error code from ZPPRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZPPRFS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[4]);
+ zppt05_(uplo, &n, &nrhs, &a[1], &b[1], &lda, &x[1], &lda,
+ &xact[1], &lda, &rwork[1], &rwork[nrhs + 1], &
+ result[5]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L70: */
+ }
+ nrun += 5;
+/* L80: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ anorm = zlanhp_("1", uplo, &n, &a[1], &rwork[1]);
+ s_copy(srnamc_1.srnamt, "ZPPCON", (ftnlen)32, (ftnlen)6);
+ zppcon_(uplo, &n, &afac[1], &anorm, &rcond, &work[1], &rwork[
+ 1], &info);
+
+/* Check error code from ZPPCON. */
+
+ if (info != 0) {
+ alaerh_(path, "ZPPCON", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+ result[7] = dget06_(&rcond, &rcondc);
+
+/* Print the test ratio if greater than or equal to THRESH. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+L90:
+ ;
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZCHKPP */
+
+} /* zchkpp_ */
diff --git a/TESTING/LIN/zchkps.c b/TESTING/LIN/zchkps.c
new file mode 100644
index 0000000..3a6c0fd
--- /dev/null
+++ b/TESTING/LIN/zchkps.c
@@ -0,0 +1,377 @@
+/* zchkps.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+
+/* Subroutine */ int zchkps_(logical *dotype, integer *nn, integer *nval,
+ integer *nnb, integer *nbval, integer *nrank, integer *rankval,
+ doublereal *thresh, logical *tsterr, integer *nmax, doublecomplex *a,
+ doublecomplex *afac, doublecomplex *perm, integer *piv, doublecomplex
+ *work, doublereal *rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "RANK =\002,i3,\002, Diff =\002,i5,\002, NB =\002,i4,\002, type"
+ " \002,i2,\002, Ratio =\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublereal d__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer i_dceiling(doublereal *), s_wsfe(cilist *), do_fio(integer *,
+ char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer rankdiff, comprank, i__, n, nb, in, kl, ku, lda, inb;
+ doublereal tol;
+ integer mode, imat, info, rank;
+ char path[3], dist[1], uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4], irank, nimat;
+ doublereal anorm;
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int zpst01_(char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *, doublereal *, doublereal *, integer *),
+ zlatb5_(char *, integer *, integer *, char *, integer *, integer *
+, doublereal *, integer *, doublereal *, char *), alaerh_(char *, char *, integer *, integer *, char *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *), alasum_(
+ char *, integer *, integer *, integer *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *), zlatmt_(integer *, integer *, char *,
+ integer *, char *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *, integer *, char *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal result;
+ extern /* Subroutine */ int zerrps_(char *, integer *), zpstrf_(
+ char *, integer *, doublecomplex *, integer *, integer *, integer
+ *, doublereal *, doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKPS tests ZPSTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the block size NB. */
+
+/* NRANK (input) INTEGER */
+/* The number of values of RANK contained in the vector RANKVAL. */
+
+/* RANKVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the block size NB. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* PERM (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* PIV (workspace) INTEGER array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (NMAX*3) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --piv;
+ --perm;
+ --afac;
+ --a;
+ --rankval;
+ --nbval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex Precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "PS", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L100: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrps_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ izero = 0;
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L140;
+ }
+
+/* Do for each value of RANK in RANKVAL */
+
+ i__3 = *nrank;
+ for (irank = 1; irank <= i__3; ++irank) {
+
+/* Only repeat test 3 to 5 for different ranks */
+/* Other tests use full rank */
+
+ if ((imat < 3 || imat > 5) && irank > 1) {
+ goto L130;
+ }
+
+ d__1 = n * (doublereal) rankval[irank] / 100.f;
+ rank = i_dceiling(&d__1);
+
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+
+/* Set up parameters with ZLATB5 and generate a test matrix */
+/* with ZLATMT. */
+
+ zlatb5_(path, &imat, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "ZLATMT", (ftnlen)32, (ftnlen)6);
+ zlatmt_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &rank, &kl, &ku, uplo, &a[1], &
+ lda, &work[1], &info);
+
+/* Check error code from ZLATMT. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMT", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ goto L120;
+ }
+
+/* Do for each value of NB in NBVAL */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the pivoted L*L' or U'*U factorization */
+/* of the matrix. */
+
+ zlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ s_copy(srnamc_1.srnamt, "ZPSTRF", (ftnlen)32, (ftnlen)
+ 6);
+
+/* Use default tolerance */
+
+ tol = -1.;
+ zpstrf_(uplo, &n, &afac[1], &lda, &piv[1], &comprank,
+ &tol, &rwork[1], &info);
+
+/* Check error code from ZPSTRF. */
+
+ if (info < izero || info != izero && rank == n ||
+ info <= izero && rank < n) {
+ alaerh_(path, "ZPSTRF", &info, &izero, uplo, &n, &
+ n, &c_n1, &c_n1, &nb, &imat, &nfail, &
+ nerrs, nout);
+ goto L110;
+ }
+
+/* Skip the test if INFO is not 0. */
+
+ if (info != 0) {
+ goto L110;
+ }
+
+/* Reconstruct matrix from factors and compute residual. */
+
+/* PERM holds permuted L*L^T or U^T*U */
+
+ zpst01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &perm[
+ 1], &lda, &piv[1], &rwork[1], &result, &
+ comprank);
+
+/* Print information about the tests that did not pass */
+/* the threshold or where computed rank was not RANK. */
+
+ if (n == 0) {
+ comprank = 0;
+ }
+ rankdiff = rank - comprank;
+ if (result >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&rank, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&rankdiff, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result, (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L110:
+ ;
+ }
+
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+L140:
+ ;
+ }
+/* L150: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZCHKPS */
+
+} /* zchkps_ */
diff --git a/TESTING/LIN/zchkpt.c b/TESTING/LIN/zchkpt.c
new file mode 100644
index 0000000..b087652
--- /dev/null
+++ b/TESTING/LIN/zchkpt.c
@@ -0,0 +1,659 @@
+/* zchkpt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static doublereal c_b48 = 1.;
+static doublereal c_b49 = 0.;
+static integer c__7 = 7;
+
+/* Subroutine */ int zchkpt_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, doublereal *thresh, logical *tsterr,
+ doublecomplex *a, doublereal *d__, doublecomplex *e, doublecomplex *b,
+ doublecomplex *x, doublecomplex *xact, doublecomplex *work,
+ doublereal *rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 0,0,0,1 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 N =\002,i5,\002, type \002,i2,\002, te"
+ "st \002,i2,\002, ratio = \002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NRHS =\002,i3,\002, type \002,i2,\002, test \002,i2,\002, ratio "
+ "= \002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double z_abs(doublecomplex *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n;
+ doublecomplex z__[3];
+ integer ia, in, kl, ku, ix, lda;
+ doublereal cond;
+ integer mode;
+ doublereal dmax__;
+ integer imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *), dscal_(
+ integer *, doublereal *, doublereal *, integer *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ doublereal rcond;
+ integer nimat;
+ doublereal anorm;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+), dcopy_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer iuplo, izero, nerrs;
+ logical zerot;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zptt01_(integer *, doublereal *,
+ doublecomplex *, doublereal *, doublecomplex *, doublecomplex *,
+ doublereal *), zptt02_(char *, integer *, integer *, doublereal *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *), zptt05_(integer *, integer *,
+ doublereal *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *), zlatb4_(char *,
+ integer *, integer *, integer *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, char *), alaerh_(char *, char *, integer *, integer *, char *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal rcondc;
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *), alasum_(char *, integer *, integer *,
+ integer *, integer *), dlarnv_(integer *, integer *,
+ integer *, doublereal *);
+ doublereal ainvnm;
+ extern doublereal zlanht_(char *, integer *, doublereal *, doublecomplex *
+);
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dzasum_(integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zlaptm_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublecomplex *,
+ integer *, doublereal *, doublecomplex *, integer *),
+ zlatms_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zlarnv_(integer *, integer *,
+ integer *, doublecomplex *), zerrgt_(char *, integer *);
+ doublereal result[7];
+ extern /* Subroutine */ int zptcon_(integer *, doublereal *,
+ doublecomplex *, doublereal *, doublereal *, doublereal *,
+ integer *), zptrfs_(char *, integer *, integer *, doublereal *,
+ doublecomplex *, doublereal *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *), zpttrf_(
+ integer *, doublereal *, doublecomplex *, integer *), zpttrs_(
+ char *, integer *, integer *, doublereal *, doublecomplex *,
+ doublecomplex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKPT tests ZPTTRF, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*2) */
+
+/* D (workspace) DOUBLE PRECISION array, dimension (NMAX*2) */
+
+/* E (workspace) COMPLEX*16 array, dimension (NMAX*2) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --e;
+ --d__;
+ --a;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "PT", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrgt_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+ lda = max(1,n);
+ nimat = 12;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (n > 0 && ! dotype[imat]) {
+ goto L110;
+ }
+
+/* Set up parameters with ZLATB4. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cond, dist);
+
+ zerot = imat >= 8 && imat <= 10;
+ if (imat <= 6) {
+
+/* Type 1-6: generate a Hermitian tridiagonal matrix of */
+/* known condition number in lower triangular band storage. */
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
+ &anorm, &kl, &ku, "B", &a[1], &c__2, &work[1], &info);
+
+/* Check the error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, " ", &n, &n, &kl, &
+ ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L110;
+ }
+ izero = 0;
+
+/* Copy the matrix to D and E. */
+
+ ia = 1;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ia;
+ d__[i__] = a[i__4].r;
+ i__4 = i__;
+ i__5 = ia + 1;
+ e[i__4].r = a[i__5].r, e[i__4].i = a[i__5].i;
+ ia += 2;
+/* L20: */
+ }
+ if (n > 0) {
+ i__3 = ia;
+ d__[n] = a[i__3].r;
+ }
+ } else {
+
+/* Type 7-12: generate a diagonally dominant matrix with */
+/* unknown condition number in the vectors D and E. */
+
+ if (! zerot || ! dotype[7]) {
+
+/* Let E be complex, D real, with values from [-1,1]. */
+
+ dlarnv_(&c__2, iseed, &n, &d__[1]);
+ i__3 = n - 1;
+ zlarnv_(&c__2, iseed, &i__3, &e[1]);
+
+/* Make the tridiagonal matrix diagonally dominant. */
+
+ if (n == 1) {
+ d__[1] = abs(d__[1]);
+ } else {
+ d__[1] = abs(d__[1]) + z_abs(&e[1]);
+ d__[n] = (d__1 = d__[n], abs(d__1)) + z_abs(&e[n - 1])
+ ;
+ i__3 = n - 1;
+ for (i__ = 2; i__ <= i__3; ++i__) {
+ d__[i__] = (d__1 = d__[i__], abs(d__1)) + z_abs(&
+ e[i__]) + z_abs(&e[i__ - 1]);
+/* L30: */
+ }
+ }
+
+/* Scale D and E so the maximum element is ANORM. */
+
+ ix = idamax_(&n, &d__[1], &c__1);
+ dmax__ = d__[ix];
+ d__1 = anorm / dmax__;
+ dscal_(&n, &d__1, &d__[1], &c__1);
+ i__3 = n - 1;
+ d__1 = anorm / dmax__;
+ zdscal_(&i__3, &d__1, &e[1], &c__1);
+
+ } else if (izero > 0) {
+
+/* Reuse the last matrix by copying back the zeroed out */
+/* elements. */
+
+ if (izero == 1) {
+ d__[1] = z__[1].r;
+ if (n > 1) {
+ e[1].r = z__[2].r, e[1].i = z__[2].i;
+ }
+ } else if (izero == n) {
+ i__3 = n - 1;
+ e[i__3].r = z__[0].r, e[i__3].i = z__[0].i;
+ i__3 = n;
+ d__[i__3] = z__[1].r;
+ } else {
+ i__3 = izero - 1;
+ e[i__3].r = z__[0].r, e[i__3].i = z__[0].i;
+ i__3 = izero;
+ d__[i__3] = z__[1].r;
+ i__3 = izero;
+ e[i__3].r = z__[2].r, e[i__3].i = z__[2].i;
+ }
+ }
+
+/* For types 8-10, set one row and column of the matrix to */
+/* zero. */
+
+ izero = 0;
+ if (imat == 8) {
+ izero = 1;
+ z__[1].r = d__[1], z__[1].i = 0.;
+ d__[1] = 0.;
+ if (n > 1) {
+ z__[2].r = e[1].r, z__[2].i = e[1].i;
+ e[1].r = 0., e[1].i = 0.;
+ }
+ } else if (imat == 9) {
+ izero = n;
+ if (n > 1) {
+ i__3 = n - 1;
+ z__[0].r = e[i__3].r, z__[0].i = e[i__3].i;
+ i__3 = n - 1;
+ e[i__3].r = 0., e[i__3].i = 0.;
+ }
+ i__3 = n;
+ z__[1].r = d__[i__3], z__[1].i = 0.;
+ d__[n] = 0.;
+ } else if (imat == 10) {
+ izero = (n + 1) / 2;
+ if (izero > 1) {
+ i__3 = izero - 1;
+ z__[0].r = e[i__3].r, z__[0].i = e[i__3].i;
+ i__3 = izero;
+ z__[2].r = e[i__3].r, z__[2].i = e[i__3].i;
+ i__3 = izero - 1;
+ e[i__3].r = 0., e[i__3].i = 0.;
+ i__3 = izero;
+ e[i__3].r = 0., e[i__3].i = 0.;
+ }
+ i__3 = izero;
+ z__[1].r = d__[i__3], z__[1].i = 0.;
+ d__[izero] = 0.;
+ }
+ }
+
+ dcopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
+ if (n > 1) {
+ i__3 = n - 1;
+ zcopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
+ }
+
+/* + TEST 1 */
+/* Factor A as L*D*L' and compute the ratio */
+/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
+
+ zpttrf_(&n, &d__[n + 1], &e[n + 1], &info);
+
+/* Check error code from ZPTTRF. */
+
+ if (info != izero) {
+ alaerh_(path, "ZPTTRF", &info, &izero, " ", &n, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L110;
+ }
+
+ if (info > 0) {
+ rcondc = 0.;
+ goto L100;
+ }
+
+ zptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &work[1],
+ result);
+
+/* Print the test ratio if greater than or equal to THRESH. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+/* Compute RCONDC = 1 / (norm(A) * norm(inv(A)) */
+
+/* Compute norm(A). */
+
+ anorm = zlanht_("1", &n, &d__[1], &e[1]);
+
+/* Use ZPTTRS to solve for one column at a time of inv(A), */
+/* computing the maximum column sum as we go. */
+
+ ainvnm = 0.;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__5 = j;
+ x[i__5].r = 0., x[i__5].i = 0.;
+/* L40: */
+ }
+ i__4 = i__;
+ x[i__4].r = 1., x[i__4].i = 0.;
+ zpttrs_("Lower", &n, &c__1, &d__[n + 1], &e[n + 1], &x[1], &
+ lda, &info);
+/* Computing MAX */
+ d__1 = ainvnm, d__2 = dzasum_(&n, &x[1], &c__1);
+ ainvnm = max(d__1,d__2);
+/* L50: */
+ }
+/* Computing MAX */
+ d__1 = 1., d__2 = anorm * ainvnm;
+ rcondc = 1. / max(d__1,d__2);
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* Generate NRHS random solution vectors. */
+
+ ix = 1;
+ i__4 = nrhs;
+ for (j = 1; j <= i__4; ++j) {
+ zlarnv_(&c__2, iseed, &n, &xact[ix]);
+ ix += lda;
+/* L60: */
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L'. */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+
+/* Set the right hand side. */
+
+ zlaptm_(uplo, &n, &nrhs, &c_b48, &d__[1], &e[1], &xact[1],
+ &lda, &c_b49, &b[1], &lda);
+
+/* + TEST 2 */
+/* Solve A*x = b and compute the residual. */
+
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+ zpttrs_(uplo, &n, &nrhs, &d__[n + 1], &e[n + 1], &x[1], &
+ lda, &info);
+
+/* Check error code from ZPTTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZPTTRS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
+ zptt02_(uplo, &n, &nrhs, &d__[1], &e[1], &x[1], &lda, &
+ work[1], &lda, &result[1]);
+
+/* + TEST 3 */
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[2]);
+
+/* + TESTS 4, 5, and 6 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "ZPTRFS", (ftnlen)32, (ftnlen)6);
+ zptrfs_(uplo, &n, &nrhs, &d__[1], &e[1], &d__[n + 1], &e[
+ n + 1], &b[1], &lda, &x[1], &lda, &rwork[1], &
+ rwork[nrhs + 1], &work[1], &rwork[(nrhs << 1) + 1]
+, &info);
+
+/* Check error code from ZPTRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZPTRFS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[3]);
+ zptt05_(&n, &nrhs, &d__[1], &e[1], &b[1], &lda, &x[1], &
+ lda, &xact[1], &lda, &rwork[1], &rwork[nrhs + 1],
+ &result[4]);
+
+/* Print information about the tests that did not pass the */
+/* threshold. */
+
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L70: */
+ }
+ nrun += 5;
+
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* + TEST 7 */
+/* Estimate the reciprocal of the condition number of the */
+/* matrix. */
+
+L100:
+ s_copy(srnamc_1.srnamt, "ZPTCON", (ftnlen)32, (ftnlen)6);
+ zptcon_(&n, &d__[n + 1], &e[n + 1], &anorm, &rcond, &rwork[1], &
+ info);
+
+/* Check error code from ZPTCON. */
+
+ if (info != 0) {
+ alaerh_(path, "ZPTCON", &info, &c__0, " ", &n, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+ result[6] = dget06_(&rcond, &rcondc);
+
+/* Print the test ratio if greater than or equal to THRESH. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L110:
+ ;
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZCHKPT */
+
+} /* zchkpt_ */
diff --git a/TESTING/LIN/zchkq3.c b/TESTING/LIN/zchkq3.c
new file mode 100644
index 0000000..7e522b7
--- /dev/null
+++ b/TESTING/LIN/zchkq3.c
@@ -0,0 +1,399 @@
+/* zchkq3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublereal c_b15 = 1.;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int zchkq3_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nxval, doublereal *thresh, doublecomplex *a, doublecomplex *copya,
+ doublereal *s, doublereal *copys, doublecomplex *tau, doublecomplex *
+ work, doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002 M =\002,i5,\002, N =\002,i5,\002, N"
+ "B =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublereal d__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, im, in, lw, nx, lda, inb;
+ doublereal eps;
+ integer mode, info;
+ char path[3];
+ integer ilow, nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer ihigh, nfail, iseed[4], imode, mnmin;
+ extern /* Subroutine */ int icopy_(integer *, integer *, integer *,
+ integer *, integer *);
+ integer istep, nerrs, lwork;
+ extern doublereal zqpt01_(integer *, integer *, integer *, doublecomplex *
+, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zqrt11_(integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zqrt12_(integer *, integer *, doublecomplex *,
+ integer *, doublereal *, doublecomplex *, integer *, doublereal *)
+ ;
+ extern /* Subroutine */ int zgeqp3_(integer *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *
+, doublereal *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *,
+ integer *), alasum_(char *, integer *, integer *, integer
+ *, integer *), xlaenv_(integer *, integer *), zlacpy_(
+ char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zlaset_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *), zlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ doublereal result[3];
+
+ /* Fortran I/O blocks */
+ static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKQ3 tests ZGEQP3. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* THRESH (input) 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. */
+
+/* A (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) */
+/* where MMAX is the maximum value of M in MVAL and NMAX is the */
+/* maximum value of N in NVAL. */
+
+/* COPYA (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* COPYS (workspace) DOUBLE PRECISION array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* TAU (workspace) COMPLEX*16 array, dimension (MMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (max(M*max(M,N) + 4*min(M,N) + max(M,N))) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (4*NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --tau;
+ --copys;
+ --s;
+ --copya;
+ --a;
+ --nxval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "Q3", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = dlamch_("Epsilon");
+ infoc_1.infot = 0;
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+
+/* Do for each value of M in MVAL. */
+
+ m = mval[im];
+ lda = max(1,m);
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__3 = 1, i__4 = m * max(m,n) + (mnmin << 2) + max(m,n);
+ lwork = max(i__3,i__4);
+
+ for (imode = 1; imode <= 6; ++imode) {
+ if (! dotype[imode]) {
+ goto L70;
+ }
+
+/* Do for each type of matrix */
+/* 1: zero matrix */
+/* 2: one small singular value */
+/* 3: geometric distribution of singular values */
+/* 4: first n/2 columns fixed */
+/* 5: last n/2 columns fixed */
+/* 6: every second column fixed */
+
+ mode = imode;
+ if (imode > 3) {
+ mode = 1;
+ }
+
+/* Generate test matrix of size m by n using */
+/* singular value distribution indicated by `mode'. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ iwork[i__] = 0;
+/* L20: */
+ }
+ if (imode == 1) {
+ zlaset_("Full", &m, &n, &c_b1, &c_b1, ©a[1], &lda);
+ i__3 = mnmin;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ copys[i__] = 0.;
+/* L30: */
+ }
+ } else {
+ d__1 = 1. / eps;
+ zlatms_(&m, &n, "Uniform", iseed, "Nonsymm", ©s[1], &
+ mode, &d__1, &c_b15, &m, &n, "No packing", ©a[
+ 1], &lda, &work[1], &info);
+ if (imode >= 4) {
+ if (imode == 4) {
+ ilow = 1;
+ istep = 1;
+/* Computing MAX */
+ i__3 = 1, i__4 = n / 2;
+ ihigh = max(i__3,i__4);
+ } else if (imode == 5) {
+/* Computing MAX */
+ i__3 = 1, i__4 = n / 2;
+ ilow = max(i__3,i__4);
+ istep = 1;
+ ihigh = n;
+ } else if (imode == 6) {
+ ilow = 1;
+ istep = 2;
+ ihigh = n;
+ }
+ i__3 = ihigh;
+ i__4 = istep;
+ for (i__ = ilow; i__4 < 0 ? i__ >= i__3 : i__ <= i__3;
+ i__ += i__4) {
+ iwork[i__] = 1;
+/* L40: */
+ }
+ }
+ dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
+ }
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+
+/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
+
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ nx = nxval[inb];
+ xlaenv_(&c__3, &nx);
+
+/* Save A and its singular values and a copy of */
+/* vector IWORK. */
+
+ zlacpy_("All", &m, &n, ©a[1], &lda, &a[1], &lda);
+ icopy_(&n, &iwork[1], &c__1, &iwork[n + 1], &c__1);
+
+/* Workspace needed. */
+
+ lw = nb * (n + 1);
+
+ s_copy(srnamc_1.srnamt, "ZGEQP3", (ftnlen)32, (ftnlen)6);
+ zgeqp3_(&m, &n, &a[1], &lda, &iwork[n + 1], &tau[1], &
+ work[1], &lw, &rwork[1], &info);
+
+/* Compute norm(svd(a) - svd(r)) */
+
+ result[0] = zqrt12_(&m, &n, &a[1], &lda, ©s[1], &work[
+ 1], &lwork, &rwork[1]);
+
+/* Compute norm( A*P - Q*R ) */
+
+ result[1] = zqpt01_(&m, &n, &mnmin, ©a[1], &a[1], &
+ lda, &tau[1], &iwork[n + 1], &work[1], &lwork);
+
+/* Compute Q'*Q */
+
+ result[2] = zqrt11_(&m, &mnmin, &a[1], &lda, &tau[1], &
+ work[1], &lwork);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 1; k <= 3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___28.ciunit = *nout;
+ s_wsfe(&io___28);
+ do_fio(&c__1, "ZGEQP3", (ftnlen)6);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L50: */
+ }
+ nrun += 3;
+
+/* L60: */
+ }
+L70:
+ ;
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+
+/* End of ZCHKQ3 */
+
+ return 0;
+} /* zchkq3_ */
diff --git a/TESTING/LIN/zchkql.c b/TESTING/LIN/zchkql.c
new file mode 100644
index 0000000..5d1abb7
--- /dev/null
+++ b/TESTING/LIN/zchkql.c
@@ -0,0 +1,483 @@
+/* zchkql.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int zchkql_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nxval, integer *nrhs, doublereal *thresh, logical *tsterr, integer *
+ nmax, doublecomplex *a, doublecomplex *af, doublecomplex *aq,
+ doublecomplex *al, doublecomplex *ac, doublecomplex *b, doublecomplex
+ *x, doublecomplex *xact, doublecomplex *tau, doublecomplex *work,
+ doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
+ "5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
+ "t(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, ik, im, in, kl, nk, ku, nt, nx, lda, inb, mode,
+ imat, info;
+ char path[3];
+ integer kval[4];
+ char dist[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int zget02_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *);
+ doublereal anorm;
+ integer minmn, nerrs;
+ extern /* Subroutine */ int zqlt01_(integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublereal *,
+ doublereal *), zqlt02_(integer *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+ integer lwork;
+ extern /* Subroutine */ int zqlt03_(integer *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublereal *, doublereal *), zlatb4_(char *, integer *, integer *,
+ integer *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *), alasum_(char *, integer *,
+ integer *, integer *, integer *);
+ doublereal cndnum;
+ extern logical zgennd_(integer *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *), zlarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *), zgeqls_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *), zlatms_(
+ integer *, integer *, char *, integer *, char *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *, char
+ *, doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal result[8];
+ extern /* Subroutine */ int zerrql_(char *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKQL tests ZGEQLF, ZUNGQL and CUNMQL. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AQ (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AL (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* TAU (workspace) COMPLEX*16 array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --tau;
+ --xact;
+ --x;
+ --b;
+ --ac;
+ --al;
+ --aq;
+ --af;
+ --a;
+ --nxval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "QL", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrql_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+ lda = *nmax;
+ lwork = *nmax * max(*nmax,*nrhs);
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Do for each value of N in NVAL. */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ minmn = min(m,n);
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L50;
+ }
+
+/* Set up parameters with ZLATB4 and generate a test matrix */
+/* with ZLATMS. */
+
+ zlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, " ", &m, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L50;
+ }
+
+/* Set some values for K: the first value must be MINMN, */
+/* corresponding to the call of ZQLT01; other values are */
+/* used in the calls of ZQLT02, and must not exceed MINMN. */
+
+ kval[0] = minmn;
+ kval[1] = 0;
+ kval[2] = 1;
+ kval[3] = minmn / 2;
+ if (minmn == 0) {
+ nk = 1;
+ } else if (minmn == 1) {
+ nk = 2;
+ } else if (minmn <= 3) {
+ nk = 3;
+ } else {
+ nk = 4;
+ }
+
+/* Do for each value of K in KVAL */
+
+ i__3 = nk;
+ for (ik = 1; ik <= i__3; ++ik) {
+ k = kval[ik - 1];
+
+/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ nx = nxval[inb];
+ xlaenv_(&c__3, &nx);
+ for (i__ = 1; i__ <= 8; ++i__) {
+ result[i__ - 1] = 0.;
+ }
+ nt = 2;
+ if (ik == 1) {
+
+/* Test ZGEQLF */
+
+ zqlt01_(&m, &n, &a[1], &af[1], &aq[1], &al[1], &
+ lda, &tau[1], &work[1], &lwork, &rwork[1],
+ result);
+ if (m >= n) {
+/* Check the lower-left n-by-n corner */
+ if (! zgennd_(&n, &n, &af[m - n + 1], &lda)) {
+ result[7] = *thresh * 2;
+ }
+ } else {
+/* Check the (n-m)th superdiagonal */
+ if (! zgennd_(&m, &m, &af[(n - m) * lda + 1],
+ &lda)) {
+ result[7] = *thresh * 2;
+ }
+ }
+ } else if (m >= n) {
+
+/* Test ZUNGQL, using factorization */
+/* returned by ZQLT01 */
+
+ zqlt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &al[1],
+ &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], result);
+ } else {
+ result[0] = 0.;
+ result[1] = 0.;
+ }
+ if (m >= k) {
+
+/* Test ZUNMQL, using factorization returned */
+/* by ZQLT01 */
+
+ zqlt03_(&m, &n, &k, &af[1], &ac[1], &al[1], &aq[1]
+, &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], &result[2]);
+ nt += 4;
+
+/* If M>=N and K=N, call ZGEQLS to solve a system */
+/* with NRHS right hand sides and compute the */
+/* residual. */
+
+ if (k == n && inb == 1) {
+
+/* Generate a solution and set the right */
+/* hand side. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32,
+ (ftnlen)6);
+ zlarhs_(path, "New", "Full", "No transpose", &
+ m, &n, &c__0, &c__0, nrhs, &a[1], &
+ lda, &xact[1], &lda, &b[1], &lda,
+ iseed, &info);
+
+ zlacpy_("Full", &m, nrhs, &b[1], &lda, &x[1],
+ &lda);
+ s_copy(srnamc_1.srnamt, "ZGEQLS", (ftnlen)32,
+ (ftnlen)6);
+ zgeqls_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
+ x[1], &lda, &work[1], &lwork, &info);
+
+/* Check error code from ZGEQLS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZGEQLS", &info, &c__0,
+ " ", &m, &n, nrhs, &c_n1, &nb, &
+ imat, &nfail, &nerrs, nout);
+ }
+
+ zget02_("No transpose", &m, &n, nrhs, &a[1], &
+ lda, &x[m - n + 1], &lda, &b[1], &lda,
+ &rwork[1], &result[6]);
+ ++nt;
+ } else {
+ result[6] = 0.;
+ }
+ } else {
+ result[2] = 0.;
+ result[3] = 0.;
+ result[4] = 0.;
+ result[5] = 0.;
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__5 = nt;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+/* L30: */
+ }
+/* L40: */
+ }
+L50:
+ ;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZCHKQL */
+
+} /* zchkql_ */
diff --git a/TESTING/LIN/zchkqp.c b/TESTING/LIN/zchkqp.c
new file mode 100644
index 0000000..ab26616
--- /dev/null
+++ b/TESTING/LIN/zchkqp.c
@@ -0,0 +1,365 @@
+/* zchkqp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublecomplex c_b11 = {0.,0.};
+static doublereal c_b16 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int zchkqp_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, doublereal *thresh, logical *tsterr,
+ doublecomplex *a, doublecomplex *copya, doublereal *s, doublereal *
+ copys, doublecomplex *tau, doublecomplex *work, doublereal *rwork,
+ integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, type"
+ " \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublereal d__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, im, in, lda;
+ doublereal eps;
+ integer mode, info;
+ char path[3];
+ integer ilow, nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer ihigh, nfail, iseed[4], imode, mnmin, istep, nerrs, lwork;
+ extern doublereal zqpt01_(integer *, integer *, integer *, doublecomplex *
+, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zqrt11_(integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zqrt12_(integer *, integer *, doublecomplex *,
+ integer *, doublereal *, doublecomplex *, integer *, doublereal *)
+ , dlamch_(char *);
+ extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *,
+ integer *), alasum_(char *, integer *, integer *, integer
+ *, integer *), zgeqpf_(integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatms_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublecomplex *, integer *, doublecomplex *,
+ integer *);
+ doublereal result[3];
+ extern /* Subroutine */ int zerrqp_(char *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___24 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKQP tests ZGEQPF. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) */
+/* where MMAX is the maximum value of M in MVAL and NMAX is the */
+/* maximum value of N in NVAL. */
+
+/* COPYA (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* COPYS (workspace) DOUBLE PRECISION array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* TAU (workspace) COMPLEX*16 array, dimension (MMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (max(M*max(M,N) + 4*min(M,N) + max(M,N))) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (4*NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --tau;
+ --copys;
+ --s;
+ --copya;
+ --a;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "QP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = dlamch_("Epsilon");
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrqp_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+
+/* Do for each value of M in MVAL. */
+
+ m = mval[im];
+ lda = max(1,m);
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__3 = 1, i__4 = m * max(m,n) + (mnmin << 2) + max(m,n);
+ lwork = max(i__3,i__4);
+
+ for (imode = 1; imode <= 6; ++imode) {
+ if (! dotype[imode]) {
+ goto L60;
+ }
+
+/* Do for each type of matrix */
+/* 1: zero matrix */
+/* 2: one small singular value */
+/* 3: geometric distribution of singular values */
+/* 4: first n/2 columns fixed */
+/* 5: last n/2 columns fixed */
+/* 6: every second column fixed */
+
+ mode = imode;
+ if (imode > 3) {
+ mode = 1;
+ }
+
+/* Generate test matrix of size m by n using */
+/* singular value distribution indicated by `mode'. */
+
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ iwork[i__] = 0;
+/* L20: */
+ }
+ if (imode == 1) {
+ zlaset_("Full", &m, &n, &c_b11, &c_b11, ©a[1], &lda);
+ i__3 = mnmin;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ copys[i__] = 0.;
+/* L30: */
+ }
+ } else {
+ d__1 = 1. / eps;
+ zlatms_(&m, &n, "Uniform", iseed, "Nonsymm", ©s[1], &
+ mode, &d__1, &c_b16, &m, &n, "No packing", ©a[
+ 1], &lda, &work[1], &info);
+ if (imode >= 4) {
+ if (imode == 4) {
+ ilow = 1;
+ istep = 1;
+/* Computing MAX */
+ i__3 = 1, i__4 = n / 2;
+ ihigh = max(i__3,i__4);
+ } else if (imode == 5) {
+/* Computing MAX */
+ i__3 = 1, i__4 = n / 2;
+ ilow = max(i__3,i__4);
+ istep = 1;
+ ihigh = n;
+ } else if (imode == 6) {
+ ilow = 1;
+ istep = 2;
+ ihigh = n;
+ }
+ i__3 = ihigh;
+ i__4 = istep;
+ for (i__ = ilow; i__4 < 0 ? i__ >= i__3 : i__ <= i__3;
+ i__ += i__4) {
+ iwork[i__] = 1;
+/* L40: */
+ }
+ }
+ dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
+ }
+
+/* Save A and its singular values */
+
+ zlacpy_("All", &m, &n, ©a[1], &lda, &a[1], &lda);
+
+/* Compute the QR factorization with pivoting of A */
+
+ s_copy(srnamc_1.srnamt, "ZGEQPF", (ftnlen)32, (ftnlen)6);
+ zgeqpf_(&m, &n, &a[1], &lda, &iwork[1], &tau[1], &work[1], &
+ rwork[1], &info);
+
+/* Compute norm(svd(a) - svd(r)) */
+
+ result[0] = zqrt12_(&m, &n, &a[1], &lda, ©s[1], &work[1],
+ &lwork, &rwork[1]);
+
+/* Compute norm( A*P - Q*R ) */
+
+ result[1] = zqpt01_(&m, &n, &mnmin, ©a[1], &a[1], &lda, &
+ tau[1], &iwork[1], &work[1], &lwork);
+
+/* Compute Q'*Q */
+
+ result[2] = zqrt11_(&m, &mnmin, &a[1], &lda, &tau[1], &work[1]
+, &lwork);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 1; k <= 3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___24.ciunit = *nout;
+ s_wsfe(&io___24);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L50: */
+ }
+ nrun += 3;
+L60:
+ ;
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+
+/* End of ZCHKQP */
+
+ return 0;
+} /* zchkqp_ */
diff --git a/TESTING/LIN/zchkqr.c b/TESTING/LIN/zchkqr.c
new file mode 100644
index 0000000..b2c02d5
--- /dev/null
+++ b/TESTING/LIN/zchkqr.c
@@ -0,0 +1,463 @@
+/* zchkqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int zchkqr_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nxval, integer *nrhs, doublereal *thresh, logical *tsterr, integer *
+ nmax, doublecomplex *a, doublecomplex *af, doublecomplex *aq,
+ doublecomplex *ar, doublecomplex *ac, doublecomplex *b, doublecomplex
+ *x, doublecomplex *xact, doublecomplex *tau, doublecomplex *work,
+ doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
+ "5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
+ "t(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, ik, im, in, kl, nk, ku, nt, nx, lda, inb, mode,
+ imat, info;
+ char path[3];
+ integer kval[4];
+ char dist[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int zget02_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *);
+ doublereal anorm;
+ integer minmn, nerrs, lwork;
+ extern /* Subroutine */ int zqrt01_(integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublereal *,
+ doublereal *), zqrt02_(integer *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublereal *, doublereal *), zqrt03_(integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublereal *, doublereal *), zlatb4_(char *, integer *,
+ integer *, integer *, char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, char *),
+ alaerh_(char *, char *, integer *, integer *, char *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *), alasum_(char *,
+ integer *, integer *, integer *, integer *);
+ doublereal cndnum;
+ extern logical zgennd_(integer *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *), zlarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *), zlatms_(integer *, integer *, char *, integer *,
+ char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zgeqrs_(
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *);
+ doublereal result[8];
+ extern /* Subroutine */ int zerrqr_(char *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKQR tests ZGEQRF, ZUNGQR and CUNMQR. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AQ (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AR (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* TAU (workspace) COMPLEX*16 array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --tau;
+ --xact;
+ --x;
+ --b;
+ --ac;
+ --ar;
+ --aq;
+ --af;
+ --a;
+ --nxval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "QR", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrqr_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+ lda = *nmax;
+ lwork = *nmax * max(*nmax,*nrhs);
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Do for each value of N in NVAL. */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ minmn = min(m,n);
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L50;
+ }
+
+/* Set up parameters with ZLATB4 and generate a test matrix */
+/* with ZLATMS. */
+
+ zlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, " ", &m, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L50;
+ }
+
+/* Set some values for K: the first value must be MINMN, */
+/* corresponding to the call of ZQRT01; other values are */
+/* used in the calls of ZQRT02, and must not exceed MINMN. */
+
+ kval[0] = minmn;
+ kval[1] = 0;
+ kval[2] = 1;
+ kval[3] = minmn / 2;
+ if (minmn == 0) {
+ nk = 1;
+ } else if (minmn == 1) {
+ nk = 2;
+ } else if (minmn <= 3) {
+ nk = 3;
+ } else {
+ nk = 4;
+ }
+
+/* Do for each value of K in KVAL */
+
+ i__3 = nk;
+ for (ik = 1; ik <= i__3; ++ik) {
+ k = kval[ik - 1];
+
+/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ nx = nxval[inb];
+ xlaenv_(&c__3, &nx);
+ for (i__ = 1; i__ <= 8; ++i__) {
+ result[i__ - 1] = 0.;
+ }
+ nt = 2;
+ if (ik == 1) {
+
+/* Test ZGEQRF */
+
+ zqrt01_(&m, &n, &a[1], &af[1], &aq[1], &ar[1], &
+ lda, &tau[1], &work[1], &lwork, &rwork[1],
+ result);
+ if (! zgennd_(&m, &n, &af[1], &lda)) {
+ result[7] = *thresh * 2;
+ }
+ ++nt;
+ } else if (m >= n) {
+
+/* Test ZUNGQR, using factorization */
+/* returned by ZQRT01 */
+
+ zqrt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &ar[1],
+ &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], result);
+ }
+ if (m >= k) {
+
+/* Test ZUNMQR, using factorization returned */
+/* by ZQRT01 */
+
+ zqrt03_(&m, &n, &k, &af[1], &ac[1], &ar[1], &aq[1]
+, &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], &result[2]);
+ nt += 4;
+
+/* If M>=N and K=N, call ZGEQRS to solve a system */
+/* with NRHS right hand sides and compute the */
+/* residual. */
+
+ if (k == n && inb == 1) {
+
+/* Generate a solution and set the right */
+/* hand side. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32,
+ (ftnlen)6);
+ zlarhs_(path, "New", "Full", "No transpose", &
+ m, &n, &c__0, &c__0, nrhs, &a[1], &
+ lda, &xact[1], &lda, &b[1], &lda,
+ iseed, &info);
+
+ zlacpy_("Full", &m, nrhs, &b[1], &lda, &x[1],
+ &lda);
+ s_copy(srnamc_1.srnamt, "ZGEQRS", (ftnlen)32,
+ (ftnlen)6);
+ zgeqrs_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
+ x[1], &lda, &work[1], &lwork, &info);
+
+/* Check error code from ZGEQRS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZGEQRS", &info, &c__0,
+ " ", &m, &n, nrhs, &c_n1, &nb, &
+ imat, &nfail, &nerrs, nout);
+ }
+
+ zget02_("No transpose", &m, &n, nrhs, &a[1], &
+ lda, &x[1], &lda, &b[1], &lda, &rwork[
+ 1], &result[6]);
+ ++nt;
+ }
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (i__ = 1; i__ <= 8; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+/* L30: */
+ }
+/* L40: */
+ }
+L50:
+ ;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZCHKQR */
+
+} /* zchkqr_ */
diff --git a/TESTING/LIN/zchkrfp.c b/TESTING/LIN/zchkrfp.c
new file mode 100644
index 0000000..2388ca6
--- /dev/null
+++ b/TESTING/LIN/zchkrfp.c
@@ -0,0 +1,481 @@
+/* zchkrfp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__12 = 12;
+static integer c__0 = 0;
+static integer c__50 = 50;
+static integer c__16 = 16;
+static integer c__9 = 9;
+static integer c__5 = 5;
+static integer c__8 = 8;
+static integer c__6 = 6;
+
+/* Main program */ int MAIN__(void)
+{
+ /* Format strings */
+ static char fmt_9994[] = "(/\002 Tests of the COMPLEX*16 LAPACK RFP rout"
+ "ines \002,/\002 LAPACK VERSION \002,i1,\002.\002,i1,\002.\002,i1"
+ ",//\002 The following parameter values will be used:\002)";
+ static char fmt_9996[] = "(\002 !! Invalid input value: \002,a4,\002="
+ "\002,i6,\002; must be >=\002,i6)";
+ static char fmt_9995[] = "(\002 !! Invalid input value: \002,a4,\002="
+ "\002,i6,\002; must be <=\002,i6)";
+ static char fmt_9993[] = "(4x,a4,\002: \002,10i6,/11x,10i6)";
+ static char fmt_9992[] = "(/\002 Routines pass computational tests if te"
+ "st ratio is \002,\002less than\002,f8.2,/)";
+ static char fmt_9999[] = "(/\002 Execution not attempted due to input er"
+ "rors\002)";
+ static char fmt_9991[] = "(\002 Relative machine \002,a,\002 is taken to"
+ " be\002,d16.6)";
+ static char fmt_9998[] = "(/\002 End of tests\002)";
+ static char fmt_9997[] = "(\002 Total time used = \002,f12.2,\002 seco"
+ "nds\002,/)";
+
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+ cllist cl__1;
+
+ /* Builtin functions */
+ integer s_rsle(cilist *), e_rsle(void), s_wsfe(cilist *), do_fio(integer *
+ , char *, ftnlen), e_wsfe(void), do_lio(integer *, integer *,
+ char *, ftnlen);
+ /* Subroutine */ int s_stop(char *, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), f_clos(cllist *);
+
+ /* Local variables */
+ doublecomplex workafac[2500] /* was [50][50] */, workasav[2500]
+ /* was [50][50] */, workbsav[800] /* was [50][16] */, workainv[
+ 2500] /* was [50][50] */, workxact[800] /* was [50][
+ 16] */;
+ integer i__;
+ doublereal s1, s2;
+ integer nn, vers_patch__, vers_major__, vers_minor__;
+ doublecomplex workarfinv[1275];
+ doublereal eps;
+ integer nns, nnt, nval[12];
+ doublereal d_work_zpot02__[50], d_work_zpot03__[50];
+ doublecomplex z_work_zpot01__[50];
+ logical fatal;
+ doublecomplex z_work_zpot02__[800] /* was [50][16] */, z_work_zpot03__[
+ 2500] /* was [50][50] */;
+ integer nsval[12], ntval[9];
+ doublecomplex worka[2500] /* was [50][50] */, workb[800] /* was [50][
+ 16] */, workx[800] /* was [50][16] */;
+ doublereal d_work_zlanhe__[50], d_work_zlatms__[50];
+ extern doublereal dlamch_(char *), dsecnd_(void);
+ doublecomplex z_work_zlatms__[150];
+ extern /* Subroutine */ int ilaver_(integer *, integer *, integer *);
+ doublereal thresh;
+ doublecomplex workap[1275];
+ logical tsterr;
+ extern /* Subroutine */ int zdrvrf1_(integer *, integer *, integer *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *), zdrvrf2_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *), zdrvrf3_(integer *, integer *, integer *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublereal *, doublecomplex *,
+ doublecomplex *), zdrvrf4_(integer *, integer *, integer *,
+ doublereal *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublereal *);
+ doublecomplex workarf[1275];
+ extern /* Subroutine */ int zerrrfp_(integer *), zdrvrfp_(integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ doublereal *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublereal *, doublereal *, doublereal *, doublereal *);
+
+ /* Fortran I/O blocks */
+ static cilist io___3 = { 0, 5, 0, 0, 0 };
+ static cilist io___7 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___8 = { 0, 5, 0, 0, 0 };
+ static cilist io___10 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___11 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___12 = { 0, 5, 0, 0, 0 };
+ static cilist io___15 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___16 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___17 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___18 = { 0, 5, 0, 0, 0 };
+ static cilist io___20 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___21 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___22 = { 0, 5, 0, 0, 0 };
+ static cilist io___24 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___25 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___26 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___27 = { 0, 5, 0, 0, 0 };
+ static cilist io___29 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___30 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___31 = { 0, 5, 0, 0, 0 };
+ static cilist io___33 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___34 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___35 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___36 = { 0, 5, 0, 0, 0 };
+ static cilist io___38 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___39 = { 0, 5, 0, 0, 0 };
+ static cilist io___41 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___44 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___45 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___46 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___47 = { 0, 6, 0, 0, 0 };
+ static cilist io___68 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___69 = { 0, 6, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKRFP is the main test program for the COMPLEX*16 linear equation */
+/* routines with RFP storage format */
+
+
+/* Internal Parameters */
+/* =================== */
+
+/* MAXIN INTEGER */
+/* The number of different values that can be used for each of */
+/* M, N, or NB */
+
+/* MAXRHS INTEGER */
+/* The maximum number of right hand sides */
+
+/* NTYPES INTEGER */
+
+/* NMAX INTEGER */
+/* The maximum allowable value for N. */
+
+/* NIN INTEGER */
+/* The unit number for input */
+
+/* NOUT INTEGER */
+/* The unit number for output */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ s1 = dsecnd_();
+ fatal = FALSE_;
+
+/* Read a dummy line. */
+
+ s_rsle(&io___3);
+ e_rsle();
+
+/* Report LAPACK version tag (e.g. LAPACK-3.2.0) */
+
+ ilaver_(&vers_major__, &vers_minor__, &vers_patch__);
+ s_wsfe(&io___7);
+ do_fio(&c__1, (char *)&vers_major__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_minor__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&vers_patch__, (ftnlen)sizeof(integer));
+ e_wsfe();
+
+/* Read the values of N */
+
+ s_rsle(&io___8);
+ do_lio(&c__3, &c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nn < 1) {
+ s_wsfe(&io___10);
+ do_fio(&c__1, " NN ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ } else if (nn > 12) {
+ s_wsfe(&io___11);
+ do_fio(&c__1, " NN ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nn = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___12);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_rsle();
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nval[i__ - 1] < 0) {
+ s_wsfe(&io___15);
+ do_fio(&c__1, " M ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nval[i__ - 1] > 50) {
+ s_wsfe(&io___16);
+ do_fio(&c__1, " M ", (ftnlen)4);
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__50, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L10: */
+ }
+ if (nn > 0) {
+ s_wsfe(&io___17);
+ do_fio(&c__1, "N ", (ftnlen)4);
+ i__1 = nn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the values of NRHS */
+
+ s_rsle(&io___18);
+ do_lio(&c__3, &c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nns < 1) {
+ s_wsfe(&io___20);
+ do_fio(&c__1, " NNS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nns = 0;
+ fatal = TRUE_;
+ } else if (nns > 12) {
+ s_wsfe(&io___21);
+ do_fio(&c__1, " NNS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nns = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___22);
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (nsval[i__ - 1] < 0) {
+ s_wsfe(&io___24);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (nsval[i__ - 1] > 16) {
+ s_wsfe(&io___25);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__16, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L30: */
+ }
+ if (nns > 0) {
+ s_wsfe(&io___26);
+ do_fio(&c__1, "NRHS", (ftnlen)4);
+ i__1 = nns;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the matrix types */
+
+ s_rsle(&io___27);
+ do_lio(&c__3, &c__1, (char *)&nnt, (ftnlen)sizeof(integer));
+ e_rsle();
+ if (nnt < 1) {
+ s_wsfe(&io___29);
+ do_fio(&c__1, " NMA", (ftnlen)4);
+ do_fio(&c__1, (char *)&nnt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nnt = 0;
+ fatal = TRUE_;
+ } else if (nnt > 9) {
+ s_wsfe(&io___30);
+ do_fio(&c__1, " NMA", (ftnlen)4);
+ do_fio(&c__1, (char *)&nnt, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ e_wsfe();
+ nnt = 0;
+ fatal = TRUE_;
+ }
+ s_rsle(&io___31);
+ i__1 = nnt;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_lio(&c__3, &c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer))
+ ;
+ }
+ e_rsle();
+ i__1 = nnt;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (ntval[i__ - 1] < 0) {
+ s_wsfe(&io___33);
+ do_fio(&c__1, "TYPE", (ftnlen)4);
+ do_fio(&c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ } else if (ntval[i__ - 1] > 9) {
+ s_wsfe(&io___34);
+ do_fio(&c__1, "TYPE", (ftnlen)4);
+ do_fio(&c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ e_wsfe();
+ fatal = TRUE_;
+ }
+/* L320: */
+ }
+ if (nnt > 0) {
+ s_wsfe(&io___35);
+ do_fio(&c__1, "TYPE", (ftnlen)4);
+ i__1 = nnt;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ do_fio(&c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer));
+ }
+ e_wsfe();
+ }
+
+/* Read the threshold value for the test ratios. */
+
+ s_rsle(&io___36);
+ do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_rsle();
+ s_wsfe(&io___38);
+ do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+/* Read the flag that indicates whether to test the error exits. */
+
+ s_rsle(&io___39);
+ do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
+ e_rsle();
+
+ if (fatal) {
+ s_wsfe(&io___41);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+ if (fatal) {
+ s_wsfe(&io___42);
+ e_wsfe();
+ s_stop("", (ftnlen)0);
+ }
+
+/* Calculate and print the machine dependent constants. */
+
+ eps = dlamch_("Underflow threshold");
+ s_wsfe(&io___44);
+ do_fio(&c__1, "underflow", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ eps = dlamch_("Overflow threshold");
+ s_wsfe(&io___45);
+ do_fio(&c__1, "overflow ", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ eps = dlamch_("Epsilon");
+ s_wsfe(&io___46);
+ do_fio(&c__1, "precision", (ftnlen)9);
+ do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ s_wsle(&io___47);
+ e_wsle();
+
+/* Test the error exit of: */
+
+ if (tsterr) {
+ zerrrfp_(&c__6);
+ }
+
+/* Test the routines: zpftrf, zpftri, zpftrs (as in ZDRVPO). */
+/* This also tests the routines: ztfsm, ztftri, ztfttr, ztrttf. */
+
+ zdrvrfp_(&c__6, &nn, nval, &nns, nsval, &nnt, ntval, &thresh, worka,
+ workasav, workafac, workainv, workb, workbsav, workxact, workx,
+ workarf, workarfinv, z_work_zlatms__, z_work_zpot01__,
+ z_work_zpot02__, z_work_zpot03__, d_work_zlatms__,
+ d_work_zlanhe__, d_work_zpot02__, d_work_zpot03__);
+
+/* Test the routine: zlanhf */
+
+ zdrvrf1_(&c__6, &nn, nval, &thresh, worka, &c__50, workarf,
+ d_work_zlanhe__);
+
+/* Test the convertion routines: */
+/* zhfttp, ztpthf, ztfttr, ztrttf, ztrttp and ztpttr. */
+
+ zdrvrf2_(&c__6, &nn, nval, worka, &c__50, workarf, workap, workasav);
+
+/* Test the routine: ztfsm */
+
+ zdrvrf3_(&c__6, &nn, nval, &thresh, worka, &c__50, workarf, workainv,
+ workafac, d_work_zlanhe__, z_work_zpot03__, z_work_zpot01__);
+
+/* Test the routine: zhfrk */
+
+ zdrvrf4_(&c__6, &nn, nval, &thresh, worka, workafac, &c__50, workarf,
+ workainv, &c__50, d_work_zlanhe__);
+
+ cl__1.cerr = 0;
+ cl__1.cunit = 5;
+ cl__1.csta = 0;
+ f_clos(&cl__1);
+ s2 = dsecnd_();
+ s_wsfe(&io___68);
+ e_wsfe();
+ s_wsfe(&io___69);
+ d__1 = s2 - s1;
+ do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+
+
+/* End of ZCHKRFP */
+
+ return 0;
+} /* MAIN__ */
+
+/* Main program alias */ int zchkrfp_ () { MAIN__ (); return 0; }
diff --git a/TESTING/LIN/zchkrq.c b/TESTING/LIN/zchkrq.c
new file mode 100644
index 0000000..5b219eb
--- /dev/null
+++ b/TESTING/LIN/zchkrq.c
@@ -0,0 +1,483 @@
+/* zchkrq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int zchkrq_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
+ nxval, integer *nrhs, doublereal *thresh, logical *tsterr, integer *
+ nmax, doublecomplex *a, doublecomplex *af, doublecomplex *aq,
+ doublecomplex *ar, doublecomplex *ac, doublecomplex *b, doublecomplex
+ *x, doublecomplex *xact, doublecomplex *tau, doublecomplex *work,
+ doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
+ "5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
+ "t(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, nb, ik, im, in, kl, nk, ku, nt, nx, lda, inb, mode,
+ imat, info;
+ char path[3];
+ integer kval[4];
+ char dist[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ extern /* Subroutine */ int zget02_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *);
+ doublereal anorm;
+ integer minmn, nerrs, lwork;
+ extern /* Subroutine */ int zrqt01_(integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublereal *,
+ doublereal *), zrqt02_(integer *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublereal *, doublereal *), zrqt03_(integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublereal *, doublereal *), zlatb4_(char *, integer *,
+ integer *, integer *, char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, char *),
+ alaerh_(char *, char *, integer *, integer *, char *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *), alasum_(char *,
+ integer *, integer *, integer *, integer *);
+ doublereal cndnum;
+ extern logical zgennd_(integer *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *), zlarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *), zlatms_(integer *, integer *, char *, integer *,
+ char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zgerqs_(
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *);
+ doublereal result[8];
+ extern /* Subroutine */ int zerrrq_(char *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKRQ tests ZGERQF, ZUNGRQ and CUNMRQ. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AF (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AQ (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AR (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* TAU (workspace) COMPLEX*16 array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --tau;
+ --xact;
+ --x;
+ --b;
+ --ac;
+ --ar;
+ --aq;
+ --af;
+ --a;
+ --nxval;
+ --nbval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "RQ", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrrq_(path, nout);
+ }
+ infoc_1.infot = 0;
+ xlaenv_(&c__2, &c__2);
+
+ lda = *nmax;
+ lwork = *nmax * max(*nmax,*nrhs);
+
+/* Do for each value of M in MVAL. */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+
+/* Do for each value of N in NVAL. */
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ minmn = min(m,n);
+ for (imat = 1; imat <= 8; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L50;
+ }
+
+/* Set up parameters with ZLATB4 and generate a test matrix */
+/* with ZLATMS. */
+
+ zlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, " ", &m, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L50;
+ }
+
+/* Set some values for K: the first value must be MINMN, */
+/* corresponding to the call of ZRQT01; other values are */
+/* used in the calls of ZRQT02, and must not exceed MINMN. */
+
+ kval[0] = minmn;
+ kval[1] = 0;
+ kval[2] = 1;
+ kval[3] = minmn / 2;
+ if (minmn == 0) {
+ nk = 1;
+ } else if (minmn == 1) {
+ nk = 2;
+ } else if (minmn <= 3) {
+ nk = 3;
+ } else {
+ nk = 4;
+ }
+
+/* Do for each value of K in KVAL */
+
+ i__3 = nk;
+ for (ik = 1; ik <= i__3; ++ik) {
+ k = kval[ik - 1];
+
+/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ nx = nxval[inb];
+ xlaenv_(&c__3, &nx);
+ for (i__ = 1; i__ <= 8; ++i__) {
+ result[i__ - 1] = 0.;
+ }
+ nt = 2;
+ if (ik == 1) {
+
+/* Test ZGERQF */
+
+ zrqt01_(&m, &n, &a[1], &af[1], &aq[1], &ar[1], &
+ lda, &tau[1], &work[1], &lwork, &rwork[1],
+ result);
+ if (m <= n) {
+/* Check the upper-right m-by-m corner */
+ if (! zgennd_(&m, &m, &af[lda * (n - m) + 1],
+ &lda)) {
+ result[7] = *thresh * 2;
+ }
+ } else {
+/* Check the (m-n)th subdiagonal */
+ i__ = m - n;
+ if (! zgennd_(&n, &n, &af[i__ + 1], &lda)) {
+ result[7] = *thresh * 2;
+ }
+ }
+ } else if (m <= n) {
+
+/* Test ZUNGRQ, using factorization */
+/* returned by ZRQT01 */
+
+ zrqt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &ar[1],
+ &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], result);
+ } else {
+ result[0] = 0.;
+ result[1] = 0.;
+ }
+ if (m >= k) {
+
+/* Test ZUNMRQ, using factorization returned */
+/* by ZRQT01 */
+
+ zrqt03_(&m, &n, &k, &af[1], &ac[1], &ar[1], &aq[1]
+, &lda, &tau[1], &work[1], &lwork, &rwork[
+ 1], &result[2]);
+ nt += 4;
+
+/* If M>=N and K=N, call ZGERQS to solve a system */
+/* with NRHS right hand sides and compute the */
+/* residual. */
+
+ if (k == m && inb == 1) {
+
+/* Generate a solution and set the right */
+/* hand side. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32,
+ (ftnlen)6);
+ zlarhs_(path, "New", "Full", "No transpose", &
+ m, &n, &c__0, &c__0, nrhs, &a[1], &
+ lda, &xact[1], &lda, &b[1], &lda,
+ iseed, &info);
+
+ zlacpy_("Full", &m, nrhs, &b[1], &lda, &x[n -
+ m + 1], &lda);
+ s_copy(srnamc_1.srnamt, "ZGERQS", (ftnlen)32,
+ (ftnlen)6);
+ zgerqs_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
+ x[1], &lda, &work[1], &lwork, &info);
+
+/* Check error code from ZGERQS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZGERQS", &info, &c__0,
+ " ", &m, &n, nrhs, &c_n1, &nb, &
+ imat, &nfail, &nerrs, nout);
+ }
+
+ zget02_("No transpose", &m, &n, nrhs, &a[1], &
+ lda, &x[1], &lda, &b[1], &lda, &rwork[
+ 1], &result[6]);
+ ++nt;
+ } else {
+ result[6] = 0.;
+ }
+ } else {
+ result[2] = 0.;
+ result[3] = 0.;
+ result[4] = 0.;
+ result[5] = 0.;
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__5 = nt;
+ for (i__ = 1; i__ <= i__5; ++i__) {
+ if (result[i__ - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[i__ - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += nt;
+/* L30: */
+ }
+/* L40: */
+ }
+L50:
+ ;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZCHKRQ */
+
+} /* zchkrq_ */
diff --git a/TESTING/LIN/zchksp.c b/TESTING/LIN/zchksp.c
new file mode 100644
index 0000000..33af735
--- /dev/null
+++ b/TESTING/LIN/zchksp.c
@@ -0,0 +1,660 @@
+/* zchksp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__8 = 8;
+
+/* Subroutine */ int zchksp_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, doublereal *thresh, logical *tsterr,
+ integer *nmax, doublecomplex *a, doublecomplex *afac, doublecomplex *
+ ainv, doublecomplex *b, doublecomplex *x, doublecomplex *xact,
+ doublecomplex *work, doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
+ "12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, in, kl, ku, nt, lda, npp, ioff, mode, imat,
+ info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ extern logical lsame_(char *, char *);
+ doublereal rcond;
+ integer nimat;
+ doublereal anorm;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+);
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int zspt01_(char *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *);
+ logical zerot;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zppt05_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *), zspt02_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *), zspt03_(char *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *);
+ char xtype[1];
+ extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *);
+ doublereal rcondc;
+ char packit[1];
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum;
+ logical trfcon;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ integer *);
+ extern doublereal zlansp_(char *, char *, integer *, doublecomplex *,
+ doublereal *);
+ extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zspcon_(char
+ *, integer *, doublecomplex *, integer *, doublereal *,
+ doublereal *, doublecomplex *, integer *), zlatsp_(char *,
+ integer *, doublecomplex *, integer *);
+ doublereal result[8];
+ extern /* Subroutine */ int zsprfs_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *), zsptrf_(char *
+, integer *, doublecomplex *, integer *, integer *),
+ zsptri_(char *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zerrsy_(char *, integer *), zsptrs_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___38 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKSP tests ZSPTRF, -TRI, -TRS, -RFS, and -CON */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AFAC (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AINV (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(2,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, */
+/* dimension (NMAX+2*NSMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "SP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrsy_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 11;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L160;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L160;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ if (lsame_(uplo, "U")) {
+ *(unsigned char *)packit = 'C';
+ } else {
+ *(unsigned char *)packit = 'R';
+ }
+
+ if (imat != 11) {
+
+/* Set up parameters with ZLATB4 and generate a test */
+/* matrix with ZLATMS. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
+ mode, &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ goto L150;
+ }
+
+/* For types 3-6, zero one or more rows and columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * izero / 2;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff += i__;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff = ioff + n - i__;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows and columns to zero. */
+
+ ioff = 0;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0., a[i__5].i = 0.;
+/* L60: */
+ }
+ ioff += j;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows and columns to zero. */
+
+ ioff = 0;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0., a[i__5].i = 0.;
+/* L80: */
+ }
+ ioff = ioff + n - j;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+ } else {
+
+/* Use a special block diagonal matrix to test alternate */
+/* code for the 2 x 2 blocks. */
+
+ zlatsp_(uplo, &n, &a[1], iseed);
+ }
+
+/* Compute the L*D*L' or U*D*U' factorization of the matrix. */
+
+ npp = n * (n + 1) / 2;
+ zcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ s_copy(srnamc_1.srnamt, "ZSPTRF", (ftnlen)32, (ftnlen)6);
+ zsptrf_(uplo, &n, &afac[1], &iwork[1], &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from ZSPTRF. */
+
+ if (info != k) {
+ alaerh_(path, "ZSPTRF", &info, &k, uplo, &n, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+ if (info != 0) {
+ trfcon = TRUE_;
+ } else {
+ trfcon = FALSE_;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ zspt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &ainv[1], &lda,
+ &rwork[1], result);
+ nt = 1;
+
+/* + TEST 2 */
+/* Form the inverse and compute the residual. */
+
+ if (! trfcon) {
+ zcopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
+ s_copy(srnamc_1.srnamt, "ZSPTRI", (ftnlen)32, (ftnlen)6);
+ zsptri_(uplo, &n, &ainv[1], &iwork[1], &work[1], &info);
+
+/* Check error code from ZSPTRI. */
+
+ if (info != 0) {
+ alaerh_(path, "ZSPTRI", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ zspt03_(uplo, &n, &a[1], &ainv[1], &work[1], &lda, &rwork[
+ 1], &rcondc, &result[1]);
+ nt = 2;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+
+/* Do only the condition estimate if INFO is not 0. */
+
+ if (trfcon) {
+ rcondc = 0.;
+ goto L140;
+ }
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (ftnlen)6);
+ zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &nrhs, &
+ a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
+ info);
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "ZSPTRS", (ftnlen)32, (ftnlen)6);
+ zsptrs_(uplo, &n, &nrhs, &afac[1], &iwork[1], &x[1], &lda,
+ &info);
+
+/* Check error code from ZSPTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZSPTRS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
+ zspt02_(uplo, &n, &nrhs, &a[1], &x[1], &lda, &work[1], &
+ lda, &rwork[1], &result[2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "ZSPRFS", (ftnlen)32, (ftnlen)6);
+ zsprfs_(uplo, &n, &nrhs, &a[1], &afac[1], &iwork[1], &b[1]
+, &lda, &x[1], &lda, &rwork[1], &rwork[nrhs + 1],
+ &work[1], &rwork[(nrhs << 1) + 1], &info);
+
+/* Check error code from ZSPRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZSPRFS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[4]);
+ zppt05_(uplo, &n, &nrhs, &a[1], &b[1], &lda, &x[1], &lda,
+ &xact[1], &lda, &rwork[1], &rwork[nrhs + 1], &
+ result[5]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L120: */
+ }
+ nrun += 5;
+/* L130: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+L140:
+ anorm = zlansp_("1", uplo, &n, &a[1], &rwork[1]);
+ s_copy(srnamc_1.srnamt, "ZSPCON", (ftnlen)32, (ftnlen)6);
+ zspcon_(uplo, &n, &afac[1], &iwork[1], &anorm, &rcond, &work[
+ 1], &info);
+
+/* Check error code from ZSPCON. */
+
+ if (info != 0) {
+ alaerh_(path, "ZSPCON", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+ result[7] = dget06_(&rcond, &rcondc);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___43.ciunit = *nout;
+ s_wsfe(&io___43);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L150:
+ ;
+ }
+L160:
+ ;
+ }
+/* L170: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZCHKSP */
+
+} /* zchksp_ */
diff --git a/TESTING/LIN/zchksy.c b/TESTING/LIN/zchksy.c
new file mode 100644
index 0000000..4f97dd6
--- /dev/null
+++ b/TESTING/LIN/zchksy.c
@@ -0,0 +1,694 @@
+/* zchksy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__8 = 8;
+
+/* Subroutine */ int zchksy_(logical *dotype, integer *nn, integer *nval,
+ integer *nnb, integer *nbval, integer *nns, integer *nsval,
+ doublereal *thresh, logical *tsterr, integer *nmax, doublecomplex *a,
+ doublecomplex *afac, doublecomplex *ainv, doublecomplex *b,
+ doublecomplex *x, doublecomplex *xact, doublecomplex *work,
+ doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
+ "=\002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
+ "NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
+ "12.5)";
+ static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002"
+ ",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
+ ;
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, nb, in, kl, ku, nt, lda, inb, ioff, mode,
+ imat, info;
+ char path[3], dist[1];
+ integer irhs, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ doublereal rcond;
+ integer nimat;
+ doublereal anorm;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+);
+ integer iuplo, izero, nerrs, lwork;
+ extern /* Subroutine */ int zpot05_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int zsyt01_(char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *), zsyt02_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+), zsyt03_(char *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *), zlatb4_(char *,
+ integer *, integer *, integer *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, char *), alaerh_(char *, char *, integer *, integer *, char *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *);
+ doublereal rcondc;
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum;
+ logical trfcon;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *), zlarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *), zlatms_(integer *, integer *, char *, integer *,
+ char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ doublereal result[8];
+ extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zsycon_(char *, integer *, doublecomplex *,
+ integer *, integer *, doublereal *, doublereal *, doublecomplex *,
+ integer *), zlatsy_(char *, integer *, doublecomplex *,
+ integer *, integer *), zerrsy_(char *, integer *),
+ zsyrfs_(char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *
+, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *), zsytrf_(char *,
+ integer *, doublecomplex *, integer *, integer *, doublecomplex *
+, integer *, integer *), zsytri_(char *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *), zsytrs_(char *, integer *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKSY tests ZSYTRF, -TRI, -TRS, -RFS, and -CON. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NBVAL) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(2,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, */
+/* dimension (NMAX+2*NSMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "SY", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrsy_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 11;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ izero = 0;
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L170;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L170;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+ if (imat != 11) {
+
+/* Set up parameters with ZLATB4 and generate a test */
+/* matrix with ZLATMS. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
+ mode, &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "N", &a[1], &lda, &work[
+ 1], &info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ goto L160;
+ }
+
+/* For types 3-6, zero one or more rows and columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * lda;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows to zero. */
+
+ ioff = 0;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0., a[i__5].i = 0.;
+/* L60: */
+ }
+ ioff += lda;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows to zero. */
+
+ ioff = 0;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0., a[i__5].i = 0.;
+/* L80: */
+ }
+ ioff += lda;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+ } else {
+
+/* Use a special block diagonal matrix to test alternate */
+/* code for the 2 x 2 blocks. */
+
+ zlatsy_(uplo, &n, &a[1], &lda, iseed);
+ }
+
+/* Do for each value of NB in NBVAL */
+
+ i__3 = *nnb;
+ for (inb = 1; inb <= i__3; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* Compute the L*D*L' or U*D*U' factorization of the */
+/* matrix. */
+
+ zlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ lwork = max(2,nb) * lda;
+ s_copy(srnamc_1.srnamt, "ZSYTRF", (ftnlen)32, (ftnlen)6);
+ zsytrf_(uplo, &n, &afac[1], &lda, &iwork[1], &ainv[1], &
+ lwork, &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from ZSYTRF. */
+
+ if (info != k) {
+ alaerh_(path, "ZSYTRF", &info, &k, uplo, &n, &n, &
+ c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
+ }
+ if (info != 0) {
+ trfcon = TRUE_;
+ } else {
+ trfcon = FALSE_;
+ }
+
+/* + TEST 1 */
+/* Reconstruct matrix from factors and compute residual. */
+
+ zsyt01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &iwork[1],
+ &ainv[1], &lda, &rwork[1], result);
+ nt = 1;
+
+/* + TEST 2 */
+/* Form the inverse and compute the residual. */
+
+ if (inb == 1 && ! trfcon) {
+ zlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
+ s_copy(srnamc_1.srnamt, "ZSYTRI", (ftnlen)32, (ftnlen)
+ 6);
+ zsytri_(uplo, &n, &ainv[1], &lda, &iwork[1], &work[1],
+ &info);
+
+/* Check error code from ZSYTRI. */
+
+ if (info != 0) {
+ alaerh_(path, "ZSYTRI", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ zsyt03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &work[
+ 1], &lda, &rwork[1], &rcondc, &result[1]);
+ nt = 2;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+
+/* Skip the other tests if this is not the first block */
+/* size. */
+
+ if (inb > 1) {
+ goto L150;
+ }
+
+/* Do only the condition estimate if INFO is not 0. */
+
+ if (trfcon) {
+ rcondc = 0.;
+ goto L140;
+ }
+
+ i__4 = *nns;
+ for (irhs = 1; irhs <= i__4; ++irhs) {
+ nrhs = nsval[irhs];
+
+/* + TEST 3 */
+/* Solve and compute residual for A * X = B. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "ZSYTRS", (ftnlen)32, (ftnlen)
+ 6);
+ zsytrs_(uplo, &n, &nrhs, &afac[1], &lda, &iwork[1], &
+ x[1], &lda, &info);
+
+/* Check error code from ZSYTRS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZSYTRS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &
+ lda);
+ zsyt02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
+ work[1], &lda, &rwork[1], &result[2]);
+
+/* + TEST 4 */
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+
+/* + TESTS 5, 6, and 7 */
+/* Use iterative refinement to improve the solution. */
+
+ s_copy(srnamc_1.srnamt, "ZSYRFS", (ftnlen)32, (ftnlen)
+ 6);
+ zsyrfs_(uplo, &n, &nrhs, &a[1], &lda, &afac[1], &lda,
+ &iwork[1], &b[1], &lda, &x[1], &lda, &rwork[1]
+, &rwork[nrhs + 1], &work[1], &rwork[(nrhs <<
+ 1) + 1], &info);
+
+/* Check error code from ZSYRFS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZSYRFS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[4]);
+ zpot05_(uplo, &n, &nrhs, &a[1], &lda, &b[1], &lda, &x[
+ 1], &lda, &xact[1], &lda, &rwork[1], &rwork[
+ nrhs + 1], &result[5]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 3; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L120: */
+ }
+ nrun += 5;
+/* L130: */
+ }
+
+/* + TEST 8 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+L140:
+ anorm = zlansy_("1", uplo, &n, &a[1], &lda, &rwork[1]);
+ s_copy(srnamc_1.srnamt, "ZSYCON", (ftnlen)32, (ftnlen)6);
+ zsycon_(uplo, &n, &afac[1], &lda, &iwork[1], &anorm, &
+ rcond, &work[1], &info);
+
+/* Check error code from ZSYCON. */
+
+ if (info != 0) {
+ alaerh_(path, "ZSYCON", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ result[7] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+L150:
+ ;
+ }
+L160:
+ ;
+ }
+L170:
+ ;
+ }
+/* L180: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZCHKSY */
+
+} /* zchksy_ */
diff --git a/TESTING/LIN/zchktb.c b/TESTING/LIN/zchktb.c
new file mode 100644
index 0000000..35edc36
--- /dev/null
+++ b/TESTING/LIN/zchktb.c
@@ -0,0 +1,739 @@
+/* zchktb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublecomplex c_b14 = {0.,0.};
+static doublecomplex c_b15 = {1.,0.};
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c__3 = 3;
+static integer c_n1 = -1;
+static integer c__6 = 6;
+static integer c__4 = 4;
+static doublereal c_b90 = 1.;
+static integer c__7 = 7;
+static integer c__8 = 8;
+
+/* Subroutine */ int zchktb_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, doublereal *thresh, logical *tsterr,
+ integer *nmax, doublecomplex *ab, doublecomplex *ainv, doublecomplex *
+ b, doublecomplex *x, doublecomplex *xact, doublecomplex *work,
+ doublereal *rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', TRANS='\002,a1,\002"
+ "', DIAG='\002,a1,\002', N=\002,i5,\002, K"
+ "D=\002,i5,\002, NRHS=\002,i5,\002, type \002,i2,\002, test(\002,"
+ "i2,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
+ "'\002,a1,\002',\002,i5,\002,\002,i5,\002, ... ), type \002,i2"
+ ",\002, test(\002,i2,\002)=\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
+ "'\002,a1,\002', '\002,a1,\002',\002,i5,\002,\002,i5,\002, ... )"
+ ", type \002,i2,\002, test(\002,i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[3], a__2[4];
+ integer i__1, i__2, i__3, i__4, i__5, i__6[3], i__7[4];
+ char ch__1[3], ch__2[4];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
+ char **, integer *, integer *, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n, kd, ik, in, nk, lda, ldab;
+ char diag[1];
+ integer imat, info;
+ char path[3];
+ integer irhs, nrhs;
+ char norm[1], uplo[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer idiag;
+ doublereal scale;
+ integer nfail, iseed[4];
+ extern logical lsame_(char *, char *);
+ doublereal rcond;
+ integer nimat;
+ doublereal anorm;
+ integer itran;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+), ztbt02_(char *, char *, char *, integer *, integer *, integer *
+, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublereal *,
+ doublereal *), ztbt03_(char *, char *,
+ char *, integer *, integer *, integer *, doublecomplex *, integer
+ *, doublereal *, doublereal *, doublereal *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *);
+ char trans[1];
+ integer iuplo, nerrs;
+ extern /* Subroutine */ int ztbt05_(char *, char *, char *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *
+, doublereal *, doublereal *, doublereal *), ztbt06_(doublereal *, doublereal *, char *, char *,
+ integer *, integer *, doublecomplex *, integer *, doublereal *,
+ doublereal *), zcopy_(integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), ztbsv_(char *, char *,
+ char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ char xtype[1];
+ integer nimat2;
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ doublereal rcondc, rcondi;
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal rcondo, ainvnm;
+ extern doublereal zlantb_(char *, char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int zlatbs_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *, doublereal *, integer *), zlattb_(integer *, char *, char *, char *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *)
+ , ztbcon_(char *, char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ doublereal *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zlarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *), zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+ extern doublereal zlantr_(char *, char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int ztbrfs_(char *, char *, char *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+, doublecomplex *, doublereal *, integer *);
+ doublereal result[8];
+ extern /* Subroutine */ int zerrtr_(char *, integer *), ztbtrs_(
+ char *, char *, char *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___44 = { 0, 0, 0, fmt_9997, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKTB tests ZTBTRS, -RFS, and -CON, and ZLATBS. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The leading dimension of the work arrays. */
+/* NMAX >= the maximum value of N in NVAL. */
+
+/* AB (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --ab;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "TB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrtr_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL */
+
+ n = nval[in];
+ lda = max(1,n);
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ nimat2 = 17;
+ if (n <= 0) {
+ nimat = 1;
+ nimat2 = 10;
+ }
+
+/* Computing MIN */
+ i__2 = n + 1;
+ nk = min(i__2,4);
+ i__2 = nk;
+ for (ik = 1; ik <= i__2; ++ik) {
+
+/* Do for KD = 0, N, (3N-1)/4, and (N+1)/4. This order makes */
+/* it easier to skip redundant values for small values of N. */
+
+ if (ik == 1) {
+ kd = 0;
+ } else if (ik == 2) {
+ kd = max(n,0);
+ } else if (ik == 3) {
+ kd = (n * 3 - 1) / 4;
+ } else if (ik == 4) {
+ kd = (n + 1) / 4;
+ }
+ ldab = kd + 1;
+
+ i__3 = nimat;
+ for (imat = 1; imat <= i__3; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L90;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+
+/* Call ZLATTB to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "ZLATTB", (ftnlen)32, (ftnlen)6);
+ zlattb_(&imat, uplo, "No transpose", diag, iseed, &n, &kd,
+ &ab[1], &ldab, &x[1], &work[1], &rwork[1], &info);
+
+/* Set IDIAG = 1 for non-unit matrices, 2 for unit. */
+
+ if (lsame_(diag, "N")) {
+ idiag = 1;
+ } else {
+ idiag = 2;
+ }
+
+/* Form the inverse of A so we can get a good estimate */
+/* of RCONDC = 1/(norm(A) * norm(inv(A))). */
+
+ zlaset_("Full", &n, &n, &c_b14, &c_b15, &ainv[1], &lda);
+ if (lsame_(uplo, "U")) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ ztbsv_(uplo, "No transpose", diag, &j, &kd, &ab[1]
+, &ldab, &ainv[(j - 1) * lda + 1], &c__1);
+/* L20: */
+ }
+ } else {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__5 = n - j + 1;
+ ztbsv_(uplo, "No transpose", diag, &i__5, &kd, &
+ ab[(j - 1) * ldab + 1], &ldab, &ainv[(j -
+ 1) * lda + j], &c__1);
+/* L30: */
+ }
+ }
+
+/* Compute the 1-norm condition number of A. */
+
+ anorm = zlantb_("1", uplo, diag, &n, &kd, &ab[1], &ldab, &
+ rwork[1]);
+ ainvnm = zlantr_("1", uplo, diag, &n, &n, &ainv[1], &lda,
+ &rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondo = 1.;
+ } else {
+ rcondo = 1. / anorm / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ anorm = zlantb_("I", uplo, diag, &n, &kd, &ab[1], &ldab, &
+ rwork[1]);
+ ainvnm = zlantr_("I", uplo, diag, &n, &n, &ainv[1], &lda,
+ &rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondi = 1.;
+ } else {
+ rcondi = 1. / anorm / ainvnm;
+ }
+
+ i__4 = *nns;
+ for (irhs = 1; irhs <= i__4; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, or A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itran - 1];
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+
+/* + TEST 1 */
+/* Solve and compute residual for op(A)*x = b. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (
+ ftnlen)6);
+ zlarhs_(path, xtype, uplo, trans, &n, &n, &kd, &
+ idiag, &nrhs, &ab[1], &ldab, &xact[1], &
+ lda, &b[1], &lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "ZTBTRS", (ftnlen)32, (
+ ftnlen)6);
+ ztbtrs_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1],
+ &ldab, &x[1], &lda, &info);
+
+/* Check error code from ZTBTRS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__6[0] = 1, a__1[0] = uplo;
+ i__6[1] = 1, a__1[1] = trans;
+ i__6[2] = 1, a__1[2] = diag;
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)3);
+ alaerh_(path, "ZTBTRS", &info, &c__0, ch__1, &
+ n, &n, &kd, &kd, &nrhs, &imat, &nfail,
+ &nerrs, nout);
+ }
+
+ ztbt02_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1],
+ &ldab, &x[1], &lda, &b[1], &lda, &work[1]
+, &rwork[1], result);
+
+/* + TEST 2 */
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[1]);
+
+/* + TESTS 3, 4, and 5 */
+/* Use iterative refinement to improve the solution */
+/* and compute error bounds. */
+
+ s_copy(srnamc_1.srnamt, "ZTBRFS", (ftnlen)32, (
+ ftnlen)6);
+ ztbrfs_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1],
+ &ldab, &b[1], &lda, &x[1], &lda, &rwork[
+ 1], &rwork[nrhs + 1], &work[1], &rwork[(
+ nrhs << 1) + 1], &info);
+
+/* Check error code from ZTBRFS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__6[0] = 1, a__1[0] = uplo;
+ i__6[1] = 1, a__1[1] = trans;
+ i__6[2] = 1, a__1[2] = diag;
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)3);
+ alaerh_(path, "ZTBRFS", &info, &c__0, ch__1, &
+ n, &n, &kd, &kd, &nrhs, &imat, &nfail,
+ &nerrs, nout);
+ }
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ ztbt05_(uplo, trans, diag, &n, &kd, &nrhs, &ab[1],
+ &ldab, &b[1], &lda, &x[1], &lda, &xact[1]
+, &lda, &rwork[1], &rwork[nrhs + 1], &
+ result[3]);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 1; k <= 5; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L40: */
+ }
+ nrun += 5;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* + TEST 6 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+ s_copy(srnamc_1.srnamt, "ZTBCON", (ftnlen)32, (ftnlen)
+ 6);
+ ztbcon_(norm, uplo, diag, &n, &kd, &ab[1], &ldab, &
+ rcond, &work[1], &rwork[1], &info);
+
+/* Check error code from ZTBCON. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__6[0] = 1, a__1[0] = norm;
+ i__6[1] = 1, a__1[1] = uplo;
+ i__6[2] = 1, a__1[2] = diag;
+ s_cat(ch__1, a__1, i__6, &c__3, (ftnlen)3);
+ alaerh_(path, "ZTBCON", &info, &c__0, ch__1, &n, &
+ n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ ztbt06_(&rcond, &rcondc, uplo, diag, &n, &kd, &ab[1],
+ &ldab, &rwork[1], &result[5]);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "ZTBCON", (ftnlen)6);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L70: */
+ }
+/* L80: */
+ }
+L90:
+ ;
+ }
+
+/* Use pathological test matrices to test ZLATBS. */
+
+ i__3 = nimat2;
+ for (imat = 10; imat <= i__3; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, and A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[
+ itran - 1];
+
+/* Call ZLATTB to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "ZLATTB", (ftnlen)32, (ftnlen)
+ 6);
+ zlattb_(&imat, uplo, trans, diag, iseed, &n, &kd, &ab[
+ 1], &ldab, &x[1], &work[1], &rwork[1], &info);
+
+/* + TEST 7 */
+/* Solve the system op(A)*x = b */
+
+ s_copy(srnamc_1.srnamt, "ZLATBS", (ftnlen)32, (ftnlen)
+ 6);
+ zcopy_(&n, &x[1], &c__1, &b[1], &c__1);
+ zlatbs_(uplo, trans, diag, "N", &n, &kd, &ab[1], &
+ ldab, &b[1], &scale, &rwork[1], &info);
+
+/* Check error code from ZLATBS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__7[0] = 1, a__2[0] = uplo;
+ i__7[1] = 1, a__2[1] = trans;
+ i__7[2] = 1, a__2[2] = diag;
+ i__7[3] = 1, a__2[3] = "N";
+ s_cat(ch__2, a__2, i__7, &c__4, (ftnlen)4);
+ alaerh_(path, "ZLATBS", &info, &c__0, ch__2, &n, &
+ n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ ztbt03_(uplo, trans, diag, &n, &kd, &c__1, &ab[1], &
+ ldab, &scale, &rwork[1], &c_b90, &b[1], &lda,
+ &x[1], &lda, &work[1], &result[6]);
+
+/* + TEST 8 */
+/* Solve op(A)*x = b again with NORMIN = 'Y'. */
+
+ zcopy_(&n, &x[1], &c__1, &b[1], &c__1);
+ zlatbs_(uplo, trans, diag, "Y", &n, &kd, &ab[1], &
+ ldab, &b[1], &scale, &rwork[1], &info);
+
+/* Check error code from ZLATBS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__7[0] = 1, a__2[0] = uplo;
+ i__7[1] = 1, a__2[1] = trans;
+ i__7[2] = 1, a__2[2] = diag;
+ i__7[3] = 1, a__2[3] = "Y";
+ s_cat(ch__2, a__2, i__7, &c__4, (ftnlen)4);
+ alaerh_(path, "ZLATBS", &info, &c__0, ch__2, &n, &
+ n, &kd, &kd, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ ztbt03_(uplo, trans, diag, &n, &kd, &c__1, &ab[1], &
+ ldab, &scale, &rwork[1], &c_b90, &b[1], &lda,
+ &x[1], &lda, &work[1], &result[7]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___43.ciunit = *nout;
+ s_wsfe(&io___43);
+ do_fio(&c__1, "ZLATBS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___44.ciunit = *nout;
+ s_wsfe(&io___44);
+ do_fio(&c__1, "ZLATBS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "Y", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&kd, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ nrun += 2;
+/* L100: */
+ }
+/* L110: */
+ }
+L120:
+ ;
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZCHKTB */
+
+} /* zchktb_ */
diff --git a/TESTING/LIN/zchktp.c b/TESTING/LIN/zchktp.c
new file mode 100644
index 0000000..a9dca2c
--- /dev/null
+++ b/TESTING/LIN/zchktp.c
@@ -0,0 +1,692 @@
+/* zchktp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__7 = 7;
+static integer c__4 = 4;
+static doublereal c_b103 = 1.;
+static integer c__8 = 8;
+static integer c__9 = 9;
+
+/* Subroutine */ int zchktp_(logical *dotype, integer *nn, integer *nval,
+ integer *nns, integer *nsval, doublereal *thresh, logical *tsterr,
+ integer *nmax, doublecomplex *ap, doublecomplex *ainvp, doublecomplex
+ *b, doublecomplex *x, doublecomplex *xact, doublecomplex *work,
+ doublereal *rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', DIAG='\002,a1,\002'"
+ ", N=\002,i5,\002, type \002,i2,\002, test(\002,i2,\002)= \002,g1"
+ "2.5)";
+ static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', TRANS='\002,a1,\002"
+ "', DIAG='\002,a1,\002', N=\002,i5,\002', NRHS=\002,i5,\002, type "
+ "\002,i2,\002, test(\002,i2,\002)= \002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
+ "'\002,a1,\002',\002,i5,\002, ... ), type \002,i2,\002, test(\002"
+ ",i2,\002)=\002,g12.5)";
+ static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
+ "'\002,a1,\002', '\002,a1,\002',\002,i5,\002, ... ), type \002,i2,"
+ "\002, test(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2], a__2[3], a__3[4];
+ integer i__1, i__2[2], i__3, i__4[3], i__5[4];
+ char ch__1[2], ch__2[3], ch__3[4];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
+ char **, integer *, integer *, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, in, lda, lap;
+ char diag[1];
+ integer imat, info;
+ char path[3];
+ integer irhs, nrhs;
+ char norm[1], uplo[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer idiag;
+ doublereal scale;
+ integer nfail, iseed[4];
+ extern logical lsame_(char *, char *);
+ doublereal rcond, anorm;
+ integer itran;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+);
+ char trans[1];
+ integer iuplo, nerrs;
+ extern /* Subroutine */ int ztpt01_(char *, char *, integer *,
+ doublecomplex *, doublecomplex *, doublereal *, doublereal *,
+ doublereal *), zcopy_(integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), ztpt02_(char *, char *,
+ char *, integer *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *, doublereal *), ztpt03_(char
+ *, char *, char *, integer *, integer *, doublecomplex *,
+ doublereal *, doublereal *, doublereal *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *), ztpt05_(char *, char *,
+ char *, integer *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *)
+ ;
+ char xtype[1];
+ extern /* Subroutine */ int ztpt06_(doublereal *, doublereal *, char *,
+ char *, integer *, doublecomplex *, doublereal *, doublereal *), alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ doublereal rcondc, rcondi;
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal rcondo, ainvnm;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ integer *);
+ extern doublereal zlantp_(char *, char *, char *, integer *,
+ doublecomplex *, doublereal *);
+ extern /* Subroutine */ int zlatps_(char *, char *, char *, char *,
+ integer *, doublecomplex *, doublecomplex *, doublereal *,
+ doublereal *, integer *);
+ doublereal result[9];
+ extern /* Subroutine */ int zlattp_(integer *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *),
+ ztpcon_(char *, char *, char *, integer *, doublecomplex *,
+ doublereal *, doublecomplex *, doublereal *, integer *), zerrtr_(char *, integer *), ztprfs_(char
+ *, char *, char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), ztptri_(char *, char *,
+ integer *, doublecomplex *, integer *), ztptrs_(
+ char *, char *, char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKTP tests ZTPTRI, -TRS, -RFS, and -CON, and ZLATPS */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The leading dimension of the work arrays. NMAX >= the */
+/* maximumm value of N in NVAL. */
+
+/* AP (workspace) COMPLEX*16 array, dimension (NMAX*(NMAX+1)/2) */
+
+/* AINVP (workspace) COMPLEX*16 array, dimension (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainvp;
+ --ap;
+ --nsval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "TP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrtr_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL */
+
+ n = nval[in];
+ lda = max(1,n);
+ lap = lda * (lda + 1) / 2;
+ *(unsigned char *)xtype = 'N';
+
+ for (imat = 1; imat <= 10; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L70;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Call ZLATTP to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "ZLATTP", (ftnlen)32, (ftnlen)6);
+ zlattp_(&imat, uplo, "No transpose", diag, iseed, &n, &ap[1],
+ &x[1], &work[1], &rwork[1], &info);
+
+/* Set IDIAG = 1 for non-unit matrices, 2 for unit. */
+
+ if (lsame_(diag, "N")) {
+ idiag = 1;
+ } else {
+ idiag = 2;
+ }
+
+/* + TEST 1 */
+/* Form the inverse of A. */
+
+ if (n > 0) {
+ zcopy_(&lap, &ap[1], &c__1, &ainvp[1], &c__1);
+ }
+ s_copy(srnamc_1.srnamt, "ZTPTRI", (ftnlen)32, (ftnlen)6);
+ ztptri_(uplo, diag, &n, &ainvp[1], &info);
+
+/* Check error code from ZTPTRI. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__2[0] = 1, a__1[0] = uplo;
+ i__2[1] = 1, a__1[1] = diag;
+ s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2);
+ alaerh_(path, "ZTPTRI", &info, &c__0, ch__1, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ anorm = zlantp_("I", uplo, diag, &n, &ap[1], &rwork[1]);
+ ainvnm = zlantp_("I", uplo, diag, &n, &ainvp[1], &rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondi = 1.;
+ } else {
+ rcondi = 1. / anorm / ainvnm;
+ }
+
+/* Compute the residual for the triangular matrix times its */
+/* inverse. Also compute the 1-norm condition number of A. */
+
+ ztpt01_(uplo, diag, &n, &ap[1], &ainvp[1], &rcondo, &rwork[1],
+ result);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, or A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[
+ itran - 1];
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+
+/* + TEST 2 */
+/* Solve and compute residual for op(A)*x = b. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ zlarhs_(path, xtype, uplo, trans, &n, &n, &c__0, &
+ idiag, &nrhs, &ap[1], &lap, &xact[1], &lda, &
+ b[1], &lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "ZTPTRS", (ftnlen)32, (ftnlen)
+ 6);
+ ztptrs_(uplo, trans, diag, &n, &nrhs, &ap[1], &x[1], &
+ lda, &info);
+
+/* Check error code from ZTPTRS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__4[0] = 1, a__2[0] = uplo;
+ i__4[1] = 1, a__2[1] = trans;
+ i__4[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)3);
+ alaerh_(path, "ZTPTRS", &info, &c__0, ch__2, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ ztpt02_(uplo, trans, diag, &n, &nrhs, &ap[1], &x[1], &
+ lda, &b[1], &lda, &work[1], &rwork[1], &
+ result[1]);
+
+/* + TEST 3 */
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* + TESTS 4, 5, and 6 */
+/* Use iterative refinement to improve the solution and */
+/* compute error bounds. */
+
+ s_copy(srnamc_1.srnamt, "ZTPRFS", (ftnlen)32, (ftnlen)
+ 6);
+ ztprfs_(uplo, trans, diag, &n, &nrhs, &ap[1], &b[1], &
+ lda, &x[1], &lda, &rwork[1], &rwork[nrhs + 1],
+ &work[1], &rwork[(nrhs << 1) + 1], &info);
+
+/* Check error code from ZTPRFS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__4[0] = 1, a__2[0] = uplo;
+ i__4[1] = 1, a__2[1] = trans;
+ i__4[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)3);
+ alaerh_(path, "ZTPRFS", &info, &c__0, ch__2, &n, &
+ n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+ ztpt05_(uplo, trans, diag, &n, &nrhs, &ap[1], &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[1], &
+ rwork[nrhs + 1], &result[4]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += 5;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* + TEST 7 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+ s_copy(srnamc_1.srnamt, "ZTPCON", (ftnlen)32, (ftnlen)6);
+ ztpcon_(norm, uplo, diag, &n, &ap[1], &rcond, &work[1], &
+ rwork[1], &info);
+
+/* Check error code from ZTPCON. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__4[0] = 1, a__2[0] = norm;
+ i__4[1] = 1, a__2[1] = uplo;
+ i__4[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__4, &c__3, (ftnlen)3);
+ alaerh_(path, "ZTPCON", &info, &c__0, ch__2, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ ztpt06_(&rcond, &rcondc, uplo, diag, &n, &ap[1], &rwork[1]
+, &result[6]);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, "ZTPCON", (ftnlen)6);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L50: */
+ }
+/* L60: */
+ }
+L70:
+ ;
+ }
+
+/* Use pathological test matrices to test ZLATPS. */
+
+ for (imat = 11; imat <= 18; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L100;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, or A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[itran
+ - 1];
+
+/* Call ZLATTP to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "ZLATTP", (ftnlen)32, (ftnlen)6);
+ zlattp_(&imat, uplo, trans, diag, iseed, &n, &ap[1], &x[1]
+, &work[1], &rwork[1], &info);
+
+/* + TEST 8 */
+/* Solve the system op(A)*x = b. */
+
+ s_copy(srnamc_1.srnamt, "ZLATPS", (ftnlen)32, (ftnlen)6);
+ zcopy_(&n, &x[1], &c__1, &b[1], &c__1);
+ zlatps_(uplo, trans, diag, "N", &n, &ap[1], &b[1], &scale,
+ &rwork[1], &info);
+
+/* Check error code from ZLATPS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__5[0] = 1, a__3[0] = uplo;
+ i__5[1] = 1, a__3[1] = trans;
+ i__5[2] = 1, a__3[2] = diag;
+ i__5[3] = 1, a__3[3] = "N";
+ s_cat(ch__3, a__3, i__5, &c__4, (ftnlen)4);
+ alaerh_(path, "ZLATPS", &info, &c__0, ch__3, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ ztpt03_(uplo, trans, diag, &n, &c__1, &ap[1], &scale, &
+ rwork[1], &c_b103, &b[1], &lda, &x[1], &lda, &
+ work[1], &result[7]);
+
+/* + TEST 9 */
+/* Solve op(A)*x = b again with NORMIN = 'Y'. */
+
+ zcopy_(&n, &x[1], &c__1, &b[n + 1], &c__1);
+ zlatps_(uplo, trans, diag, "Y", &n, &ap[1], &b[n + 1], &
+ scale, &rwork[1], &info);
+
+/* Check error code from ZLATPS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__5[0] = 1, a__3[0] = uplo;
+ i__5[1] = 1, a__3[1] = trans;
+ i__5[2] = 1, a__3[2] = diag;
+ i__5[3] = 1, a__3[3] = "Y";
+ s_cat(ch__3, a__3, i__5, &c__4, (ftnlen)4);
+ alaerh_(path, "ZLATPS", &info, &c__0, ch__3, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ ztpt03_(uplo, trans, diag, &n, &c__1, &ap[1], &scale, &
+ rwork[1], &c_b103, &b[n + 1], &lda, &x[1], &lda, &
+ work[1], &result[8]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, "ZLATPS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ if (result[8] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, "ZLATPS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "Y", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[8], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ nrun += 2;
+/* L80: */
+ }
+/* L90: */
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZCHKTP */
+
+} /* zchktp_ */
diff --git a/TESTING/LIN/zchktr.c b/TESTING/LIN/zchktr.c
new file mode 100644
index 0000000..a6d786c
--- /dev/null
+++ b/TESTING/LIN/zchktr.c
@@ -0,0 +1,730 @@
+/* zchktr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__7 = 7;
+static integer c__4 = 4;
+static doublereal c_b99 = 1.;
+static integer c__8 = 8;
+static integer c__9 = 9;
+
+/* Subroutine */ int zchktr_(logical *dotype, integer *nn, integer *nval,
+ integer *nnb, integer *nbval, integer *nns, integer *nsval,
+ doublereal *thresh, logical *tsterr, integer *nmax, doublecomplex *a,
+ doublecomplex *ainv, doublecomplex *b, doublecomplex *x,
+ doublecomplex *xact, doublecomplex *work, doublereal *rwork, integer *
+ nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 UPLO='\002,a1,\002', DIAG='\002,a1,\002'"
+ ", N=\002,i5,\002, NB=\002,i4,\002, type \002,i2,\002, test(\002,"
+ "i2,\002)= \002,g12.5)";
+ static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', TRANS='\002,a1,\002"
+ "', DIAG='\002,a1,\002', N=\002,i5,\002, NB=\002,i4,\002, type"
+ " \002,i2,\002, test(\002,i2,\002)= \002,g12"
+ ".5)";
+ static char fmt_9997[] = "(\002 NORM='\002,a1,\002', UPLO ='\002,a1,\002"
+ "', N=\002,i5,\002,\002,11x,\002 type \002,i2,\002, test(\002,i2"
+ ",\002)=\002,g12.5)";
+ static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002', "
+ "'\002,a1,\002', '\002,a1,\002',\002,i5,\002, ... ), type \002,i2,"
+ "\002, test(\002,i2,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2], a__2[3], a__3[4];
+ integer i__1, i__2, i__3[2], i__4, i__5[3], i__6[4];
+ char ch__1[2], ch__2[3], ch__3[4];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
+ char **, integer *, integer *, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, nb, in, lda, inb;
+ char diag[1];
+ integer imat, info;
+ char path[3];
+ integer irhs, nrhs;
+ char norm[1], uplo[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer idiag;
+ doublereal scale;
+ integer nfail, iseed[4];
+ extern logical lsame_(char *, char *);
+ doublereal rcond, anorm;
+ integer itran;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+);
+ char trans[1];
+ integer iuplo, nerrs;
+ doublereal dummy;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), ztrt01_(char *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *),
+ ztrt02_(char *, char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublereal *,
+ doublereal *), ztrt03_(char *, char *,
+ char *, integer *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *);
+ char xtype[1];
+ extern /* Subroutine */ int ztrt05_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *),
+ ztrt06_(doublereal *, doublereal *, char *, char *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *), alaerh_(char *, char *, integer *, integer *, char *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *);
+ doublereal rcondc, rcondi;
+ extern /* Subroutine */ int alasum_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal rcondo, ainvnm;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *), zlarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *);
+ extern doublereal zlantr_(char *, char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+ doublereal result[9];
+ extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *, doublereal *, integer *), zlattr_(integer *, char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *),
+ ztrcon_(char *, char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublecomplex *, doublereal *, integer *), zerrtr_(char *, integer *),
+ ztrrfs_(char *, char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *),
+ ztrtri_(char *, char *, integer *, doublecomplex *, integer *,
+ integer *), ztrtrs_(char *, char *, char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___27 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKTR tests ZTRTRI, -TRS, -RFS, and -CON, and ZLATRS */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB contained in the vector NBVAL. */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The leading dimension of the work arrays. */
+/* NMAX >= the maximum value of N in NVAL. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NSMAX)) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --a;
+ --nsval;
+ --nbval;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "TR", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrtr_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL */
+
+ n = nval[in];
+ lda = max(1,n);
+ *(unsigned char *)xtype = 'N';
+
+ for (imat = 1; imat <= 10; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L80;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Call ZLATTR to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "ZLATTR", (ftnlen)32, (ftnlen)6);
+ zlattr_(&imat, uplo, "No transpose", diag, iseed, &n, &a[1], &
+ lda, &x[1], &work[1], &rwork[1], &info);
+
+/* Set IDIAG = 1 for non-unit matrices, 2 for unit. */
+
+ if (lsame_(diag, "N")) {
+ idiag = 1;
+ } else {
+ idiag = 2;
+ }
+
+ i__2 = *nnb;
+ for (inb = 1; inb <= i__2; ++inb) {
+
+/* Do for each blocksize in NBVAL */
+
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+
+/* + TEST 1 */
+/* Form the inverse of A. */
+
+ zlacpy_(uplo, &n, &n, &a[1], &lda, &ainv[1], &lda);
+ s_copy(srnamc_1.srnamt, "ZTRTRI", (ftnlen)32, (ftnlen)6);
+ ztrtri_(uplo, diag, &n, &ainv[1], &lda, &info);
+
+/* Check error code from ZTRTRI. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__3[0] = 1, a__1[0] = uplo;
+ i__3[1] = 1, a__1[1] = diag;
+ s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+ alaerh_(path, "ZTRTRI", &info, &c__0, ch__1, &n, &n, &
+ c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ anorm = zlantr_("I", uplo, diag, &n, &n, &a[1], &lda, &
+ rwork[1]);
+ ainvnm = zlantr_("I", uplo, diag, &n, &n, &ainv[1], &lda,
+ &rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondi = 1.;
+ } else {
+ rcondi = 1. / anorm / ainvnm;
+ }
+
+/* Compute the residual for the triangular matrix times */
+/* its inverse. Also compute the 1-norm condition number */
+/* of A. */
+
+ ztrt01_(uplo, diag, &n, &a[1], &lda, &ainv[1], &lda, &
+ rcondo, &rwork[1], result);
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+
+/* Skip remaining tests if not the first block size. */
+
+ if (inb != 1) {
+ goto L60;
+ }
+
+ i__4 = *nns;
+ for (irhs = 1; irhs <= i__4; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, or A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itran - 1];
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+
+/* + TEST 2 */
+/* Solve and compute residual for op(A)*x = b. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (
+ ftnlen)6);
+ zlarhs_(path, xtype, uplo, trans, &n, &n, &c__0, &
+ idiag, &nrhs, &a[1], &lda, &xact[1], &lda,
+ &b[1], &lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "ZTRTRS", (ftnlen)32, (
+ ftnlen)6);
+ ztrtrs_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
+ &x[1], &lda, &info);
+
+/* Check error code from ZTRTRS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__5[0] = 1, a__2[0] = uplo;
+ i__5[1] = 1, a__2[1] = trans;
+ i__5[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3);
+ alaerh_(path, "ZTRTRS", &info, &c__0, ch__2, &
+ n, &n, &c_n1, &c_n1, &nrhs, &imat, &
+ nfail, &nerrs, nout);
+ }
+
+/* This line is needed on a Sun SPARCstation. */
+
+ if (n > 0) {
+ dummy = a[1].r;
+ }
+
+ ztrt02_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
+ &x[1], &lda, &b[1], &lda, &work[1], &
+ rwork[1], &result[1]);
+
+/* + TEST 3 */
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* + TESTS 4, 5, and 6 */
+/* Use iterative refinement to improve the solution */
+/* and compute error bounds. */
+
+ s_copy(srnamc_1.srnamt, "ZTRRFS", (ftnlen)32, (
+ ftnlen)6);
+ ztrrfs_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
+ &b[1], &lda, &x[1], &lda, &rwork[1], &
+ rwork[nrhs + 1], &work[1], &rwork[(nrhs <<
+ 1) + 1], &info);
+
+/* Check error code from ZTRRFS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__5[0] = 1, a__2[0] = uplo;
+ i__5[1] = 1, a__2[1] = trans;
+ i__5[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3);
+ alaerh_(path, "ZTRRFS", &info, &c__0, ch__2, &
+ n, &n, &c_n1, &c_n1, &nrhs, &imat, &
+ nfail, &nerrs, nout);
+ }
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+ ztrt05_(uplo, trans, diag, &n, &nrhs, &a[1], &lda,
+ &b[1], &lda, &x[1], &lda, &xact[1], &lda,
+ &rwork[1], &rwork[nrhs + 1], &result[4]);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 2; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += 5;
+/* L30: */
+ }
+/* L40: */
+ }
+
+/* + TEST 7 */
+/* Get an estimate of RCOND = 1/CNDNUM. */
+
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ *(unsigned char *)norm = 'O';
+ rcondc = rcondo;
+ } else {
+ *(unsigned char *)norm = 'I';
+ rcondc = rcondi;
+ }
+ s_copy(srnamc_1.srnamt, "ZTRCON", (ftnlen)32, (ftnlen)
+ 6);
+ ztrcon_(norm, uplo, diag, &n, &a[1], &lda, &rcond, &
+ work[1], &rwork[1], &info);
+
+/* Check error code from ZTRCON. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__5[0] = 1, a__2[0] = norm;
+ i__5[1] = 1, a__2[1] = uplo;
+ i__5[2] = 1, a__2[2] = diag;
+ s_cat(ch__2, a__2, i__5, &c__3, (ftnlen)3);
+ alaerh_(path, "ZTRCON", &info, &c__0, ch__2, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ ztrt06_(&rcond, &rcondc, uplo, diag, &n, &a[1], &lda,
+ &rwork[1], &result[6]);
+
+/* Print the test ratio if it is .GE. THRESH. */
+
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L50: */
+ }
+L60:
+ ;
+ }
+/* L70: */
+ }
+L80:
+ ;
+ }
+
+/* Use pathological test matrices to test ZLATRS. */
+
+ for (imat = 11; imat <= 18; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L110;
+ }
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for op(A) = A, A**T, and A**H. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[itran
+ - 1];
+
+/* Call ZLATTR to generate a triangular test matrix. */
+
+ s_copy(srnamc_1.srnamt, "ZLATTR", (ftnlen)32, (ftnlen)6);
+ zlattr_(&imat, uplo, trans, diag, iseed, &n, &a[1], &lda,
+ &x[1], &work[1], &rwork[1], &info);
+
+/* + TEST 8 */
+/* Solve the system op(A)*x = b. */
+
+ s_copy(srnamc_1.srnamt, "ZLATRS", (ftnlen)32, (ftnlen)6);
+ zcopy_(&n, &x[1], &c__1, &b[1], &c__1);
+ zlatrs_(uplo, trans, diag, "N", &n, &a[1], &lda, &b[1], &
+ scale, &rwork[1], &info);
+
+/* Check error code from ZLATRS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__6[0] = 1, a__3[0] = uplo;
+ i__6[1] = 1, a__3[1] = trans;
+ i__6[2] = 1, a__3[2] = diag;
+ i__6[3] = 1, a__3[3] = "N";
+ s_cat(ch__3, a__3, i__6, &c__4, (ftnlen)4);
+ alaerh_(path, "ZLATRS", &info, &c__0, ch__3, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ ztrt03_(uplo, trans, diag, &n, &c__1, &a[1], &lda, &scale,
+ &rwork[1], &c_b99, &b[1], &lda, &x[1], &lda, &
+ work[1], &result[7]);
+
+/* + TEST 9 */
+/* Solve op(A)*X = b again with NORMIN = 'Y'. */
+
+ zcopy_(&n, &x[1], &c__1, &b[n + 1], &c__1);
+ zlatrs_(uplo, trans, diag, "Y", &n, &a[1], &lda, &b[n + 1]
+, &scale, &rwork[1], &info);
+
+/* Check error code from ZLATRS. */
+
+ if (info != 0) {
+/* Writing concatenation */
+ i__6[0] = 1, a__3[0] = uplo;
+ i__6[1] = 1, a__3[1] = trans;
+ i__6[2] = 1, a__3[2] = diag;
+ i__6[3] = 1, a__3[3] = "Y";
+ s_cat(ch__3, a__3, i__6, &c__4, (ftnlen)4);
+ alaerh_(path, "ZLATRS", &info, &c__0, ch__3, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ ztrt03_(uplo, trans, diag, &n, &c__1, &a[1], &lda, &scale,
+ &rwork[1], &c_b99, &b[n + 1], &lda, &x[1], &lda,
+ &work[1], &result[8]);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (result[7] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "ZLATRS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "N", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ if (result[8] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, "ZLATRS", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, "Y", (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[8], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ nrun += 2;
+/* L90: */
+ }
+/* L100: */
+ }
+L110:
+ ;
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZCHKTR */
+
+} /* zchktr_ */
diff --git a/TESTING/LIN/zchktz.c b/TESTING/LIN/zchktz.c
new file mode 100644
index 0000000..5f8a3f8
--- /dev/null
+++ b/TESTING/LIN/zchktz.c
@@ -0,0 +1,392 @@
+/* zchktz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublecomplex c_b10 = {0.,0.};
+static doublereal c_b15 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int zchktz_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, doublereal *thresh, logical *tsterr,
+ doublecomplex *a, doublecomplex *copya, doublereal *s, doublereal *
+ copys, doublecomplex *tau, doublecomplex *work, doublereal *rwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, type"
+ " \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublereal d__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, m, n, im, in, lda;
+ doublereal eps;
+ integer mode, info;
+ char path[3];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4], imode, mnmin, nerrs, lwork;
+ extern doublereal zqrt12_(integer *, integer *, doublecomplex *, integer *
+, doublereal *, doublecomplex *, integer *, doublereal *),
+ zrzt01_(integer *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *), zrzt02_(
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *), ztzt01_(integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *), ztzt02_(integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *,
+ integer *), alasum_(char *, integer *, integer *, integer
+ *, integer *), zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *), zlatms_(
+ integer *, integer *, char *, integer *, char *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *, char
+ *, doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal result[6];
+ extern /* Subroutine */ int zerrtz_(char *, integer *), ztzrqf_(
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), ztzrzf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *)
+ ;
+
+ /* Fortran I/O blocks */
+ static cilist io___21 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZCHKTZ tests ZTZRQF and ZTZRZF. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) */
+/* where MMAX is the maximum value of M in MVAL and NMAX is the */
+/* maximum value of N in NVAL. */
+
+/* COPYA (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* COPYS (workspace) DOUBLE PRECISION array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* TAU (workspace) COMPLEX*16 array, dimension (MMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (MMAX*NMAX + 4*NMAX + MMAX) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --tau;
+ --copys;
+ --s;
+ --copya;
+ --a;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "TZ", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = dlamch_("Epsilon");
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrtz_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+
+/* Do for each value of M in MVAL. */
+
+ m = mval[im];
+ lda = max(1,m);
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+
+/* Do for each value of N in NVAL for which M .LE. N. */
+
+ n = nval[in];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__3 = 1, i__4 = n * n + (m << 2) + n;
+ lwork = max(i__3,i__4);
+
+ if (m <= n) {
+ for (imode = 1; imode <= 3; ++imode) {
+
+/* Do for each type of singular value distribution. */
+/* 0: zero matrix */
+/* 1: one small singular value */
+/* 2: exponential distribution */
+
+ mode = imode - 1;
+
+/* Test ZTZRQF */
+
+/* Generate test matrix of size m by n using */
+/* singular value distribution indicated by `mode'. */
+
+ if (mode == 0) {
+ zlaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
+ i__3 = mnmin;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ copys[i__] = 0.;
+/* L20: */
+ }
+ } else {
+ d__1 = 1. / eps;
+ zlatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
+ copys[1], &imode, &d__1, &c_b15, &m, &n,
+ "No packing", &a[1], &lda, &work[1], &info);
+ zgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
+ 1], &info);
+ i__3 = m - 1;
+ zlaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
+ lda);
+ dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
+ }
+
+/* Save A and its singular values */
+
+ zlacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
+
+/* Call ZTZRQF to reduce the upper trapezoidal matrix to */
+/* upper triangular form. */
+
+ s_copy(srnamc_1.srnamt, "ZTZRQF", (ftnlen)32, (ftnlen)6);
+ ztzrqf_(&m, &n, &a[1], &lda, &tau[1], &info);
+
+/* Compute norm(svd(a) - svd(r)) */
+
+ result[0] = zqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
+ 1], &lwork, &rwork[1]);
+
+/* Compute norm( A - R*Q ) */
+
+ result[1] = ztzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
+ 1], &work[1], &lwork);
+
+/* Compute norm(Q'*Q - I). */
+
+ result[2] = ztzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
+, &lwork);
+
+/* Test ZTZRZF */
+
+/* Generate test matrix of size m by n using */
+/* singular value distribution indicated by `mode'. */
+
+ if (mode == 0) {
+ zlaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda);
+ i__3 = mnmin;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ copys[i__] = 0.;
+/* L30: */
+ }
+ } else {
+ d__1 = 1. / eps;
+ zlatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", &
+ copys[1], &imode, &d__1, &c_b15, &m, &n,
+ "No packing", &a[1], &lda, &work[1], &info);
+ zgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin +
+ 1], &info);
+ i__3 = m - 1;
+ zlaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], &
+ lda);
+ dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
+ }
+
+/* Save A and its singular values */
+
+ zlacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda);
+
+/* Call ZTZRZF to reduce the upper trapezoidal matrix to */
+/* upper triangular form. */
+
+ s_copy(srnamc_1.srnamt, "ZTZRZF", (ftnlen)32, (ftnlen)6);
+ ztzrzf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lwork, &
+ info);
+
+/* Compute norm(svd(a) - svd(r)) */
+
+ result[3] = zqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[
+ 1], &lwork, &rwork[1]);
+
+/* Compute norm( A - R*Q ) */
+
+ result[4] = zrzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[
+ 1], &work[1], &lwork);
+
+/* Compute norm(Q'*Q - I). */
+
+ result[5] = zrzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1]
+, &lwork);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = 1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___21.ciunit = *nout;
+ s_wsfe(&io___21);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L40: */
+ }
+ nrun += 6;
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+/* Print a summary of the results. */
+
+ alasum_(path, nout, &nfail, &nrun, &nerrs);
+
+
+/* End if ZCHKTZ */
+
+ return 0;
+} /* zchktz_ */
diff --git a/TESTING/LIN/zdrvab.c b/TESTING/LIN/zdrvab.c
new file mode 100644
index 0000000..57bd2c0
--- /dev/null
+++ b/TESTING/LIN/zdrvab.c
@@ -0,0 +1,493 @@
+/* zdrvab.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublecomplex c_b17 = {0.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zdrvab_(logical *dotype, integer *nm, integer *mval,
+ integer *nns, integer *nsval, doublereal *thresh, integer *nmax,
+ doublecomplex *a, doublecomplex *afac, doublecomplex *b,
+ doublecomplex *x, doublecomplex *work, doublereal *rwork, complex *
+ swork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 2006,2007,2008,2009 };
+
+ /* Format strings */
+ static char fmt_9988[] = "(\002 *** \002,a6,\002 returned with INFO ="
+ "\002,i5,\002 instead of \002,i5,/\002 ==> M =\002,i5,\002, type"
+ " \002,i2)";
+ static char fmt_9975[] = "(\002 *** Error code from \002,a6,\002=\002,"
+ "i5,\002 for M=\002,i5,\002, type \002,i2)";
+ static char fmt_8999[] = "(/1x,a3,\002: General dense matrices\002)";
+ static char fmt_8979[] = "(4x,\0021. Diagonal\002,24x,\0027. Last n/2 co"
+ "lumns zero\002,/4x,\0022. Upper triangular\002,16x,\0028. Random"
+ ", CNDNUM = sqrt(0.1/EPS)\002,/4x,\0023. Lower triangular\002,16x,"
+ "\0029. Random, CNDNUM = 0.1/EPS\002,/4x,\0024. Random, CNDNUM = 2"
+ "\002,13x,\00210. Scaled near underflow\002,/4x,\0025. First colu"
+ "mn zero\002,14x,\00211. Scaled near overflow\002,/4x,\0026. Last"
+ " column zero\002)";
+ static char fmt_8960[] = "(3x,i2,\002: norm_1( B - A * X ) / \002,\002("
+ " norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF\002,/4x"
+ ",\002or norm_1( B - A * X ) / \002,\002( norm_1(A) * norm_1(X) "
+ "* EPS ) > THRES if DGETRF\002)";
+ static char fmt_9998[] = "(\002 TRANS='\002,a1,\002', N =\002,i5,\002, N"
+ "RHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g1"
+ "2.5)";
+ static char fmt_9996[] = "(1x,a6,\002: \002,i6,\002 out of \002,i6,\002 "
+ "tests failed to pass the threshold\002)";
+ static char fmt_9995[] = "(/1x,\002All tests for \002,a6,\002 routines p"
+ "assed the threshold (\002,i6,\002 tests run)\002)";
+ static char fmt_9994[] = "(6x,i6,\002 error messages recorded\002)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ cilist ci__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, m, n, im, kl, ku, lda, ioff, mode, kase, imat, info;
+ char path[3], dist[1];
+ integer irhs, iter, nrhs;
+ char type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4], nimat;
+ doublereal anorm;
+ extern /* Subroutine */ int zget08_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *);
+ char trans[1];
+ integer izero, nerrs;
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int zcgesv_(integer *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *, doublecomplex *, complex *, doublereal *, integer *,
+ integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), zlarhs_(char *,
+ char *, char *, char *, integer *, integer *, integer *, integer *
+, integer *, doublecomplex *, integer *, doublecomplex *, integer
+ *, doublecomplex *, integer *, integer *, integer *), zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatms_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublecomplex *, integer *, doublecomplex *,
+ integer *);
+ doublereal result[1];
+
+ /* Fortran I/O blocks */
+ static cilist io___31 = { 0, 0, 0, fmt_9988, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9975, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_8999, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_8979, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_8960, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVAB tests ZCGESV */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for M or N, used in dimensioning */
+/* the work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+/* where NSMAX is the largest entry in NSVAL. */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(3,NSMAX*2)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* NMAX */
+
+/* SWORK (workspace) COMPLEX array, dimension */
+/* (NMAX*(NSMAX+NMAX)) */
+
+/* IWORK (workspace) INTEGER array, dimension */
+/* NMAX */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Local Variables .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --swork;
+ --rwork;
+ --work;
+ --x;
+ --b;
+ --afac;
+ --a;
+ --nsval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ kase = 0;
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "GE", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+ infoc_1.infot = 0;
+
+/* Do for each value of M in MVAL */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+ lda = max(1,m);
+
+ n = m;
+ nimat = 11;
+ if (m <= 0 || n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L100;
+ }
+
+/* Skip types 5, 6, or 7 if the matrix size is too small. */
+
+ zerot = imat >= 5 && imat <= 7;
+ if (zerot && n < imat - 4) {
+ goto L100;
+ }
+
+/* Set up parameters with ZLATB4 and generate a test matrix */
+/* with ZLATMS. */
+
+ zlatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode, &
+ cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &cndnum, &
+ anorm, &kl, &ku, "No packing", &a[1], &lda, &work[1], &
+ info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, " ", &m, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L100;
+ }
+
+/* For types 5-7, zero one or more columns of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 5) {
+ izero = 1;
+ } else if (imat == 6) {
+ izero = min(m,n);
+ } else {
+ izero = min(m,n) / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 7) {
+ i__3 = m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L20: */
+ }
+ } else {
+ i__3 = n - izero + 1;
+ zlaset_("Full", &m, &i__3, &c_b17, &c_b17, &a[ioff + 1], &
+ lda);
+ }
+ } else {
+ izero = 0;
+ }
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+ *(unsigned char *)trans = 'N';
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (ftnlen)6);
+ zlarhs_(path, xtype, " ", trans, &n, &n, &kl, &ku, &nrhs, &a[
+ 1], &lda, &x[1], &lda, &b[1], &lda, iseed, &info);
+
+ s_copy(srnamc_1.srnamt, "ZCGESV", (ftnlen)32, (ftnlen)6);
+
+ ++kase;
+
+ zlacpy_("Full", &m, &n, &a[1], &lda, &afac[1], &lda);
+
+ zcgesv_(&n, &nrhs, &a[1], &lda, &iwork[1], &b[1], &lda, &x[1],
+ &lda, &work[1], &swork[1], &rwork[1], &iter, &info);
+
+ if (iter < 0) {
+ zlacpy_("Full", &m, &n, &afac[1], &lda, &a[1], &lda);
+ }
+
+/* Check error code from ZCGESV. This should be the same as */
+/* the one of DGETRF. */
+
+ if (info != izero) {
+
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ ++nerrs;
+
+ if (info != izero && izero != 0) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, "ZCGESV", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&izero, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "ZCGESV", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ }
+
+/* Skip the remaining test if the matrix is singular. */
+
+ if (info != 0) {
+ goto L100;
+ }
+
+/* Check the quality of the solution */
+
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
+
+ zget08_(trans, &n, &n, &nrhs, &a[1], &lda, &x[1], &lda, &work[
+ 1], &lda, &rwork[1], result);
+
+/* Check if the test passes the tesing. */
+/* Print information about the tests that did not */
+/* pass the testing. */
+
+/* If iterative refinement has been used and claimed to */
+/* be successful (ITER>0), we want */
+/* NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS*SRQT(N)) < 1 */
+
+/* If double precision has been used (ITER<0), we want */
+/* NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS) < THRES */
+/* (Cf. the linear solver testing routines) */
+
+ if (*thresh <= 0.f || iter >= 0 && n > 0 && result[0] >= sqrt(
+ (doublereal) n) || iter < 0 && result[0] >= *thresh) {
+
+ if (nfail == 0 && nerrs == 0) {
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "DGE", (ftnlen)3);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *nout;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *nout;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *nout;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ }
+
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ ++nrun;
+/* L60: */
+ }
+L100:
+ ;
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ if (nfail > 0) {
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, "ZCGESV", (ftnlen)6);
+ do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, "ZCGESV", (ftnlen)6);
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (nerrs > 0) {
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, (char *)&nerrs, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+
+/* SUBNAM, INFO, INFOE, M, IMAT */
+
+
+/* SUBNAM, INFO, M, IMAT */
+
+ return 0;
+
+/* End of ZDRVAB */
+
+} /* zdrvab_ */
diff --git a/TESTING/LIN/zdrvac.c b/TESTING/LIN/zdrvac.c
new file mode 100644
index 0000000..6653978
--- /dev/null
+++ b/TESTING/LIN/zdrvac.c
@@ -0,0 +1,544 @@
+/* zdrvac.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+
+/* Subroutine */ int zdrvac_(logical *dotype, integer *nm, integer *mval,
+ integer *nns, integer *nsval, doublereal *thresh, integer *nmax,
+ doublecomplex *a, doublecomplex *afac, doublecomplex *b,
+ doublecomplex *x, doublecomplex *work, doublereal *rwork, complex *
+ swork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+
+ /* Format strings */
+ static char fmt_9988[] = "(\002 *** \002,a6,\002 returned with INFO ="
+ "\002,i5,\002 instead of \002,i5,/\002 ==> N =\002,i5,\002, type"
+ " \002,i2)";
+ static char fmt_9975[] = "(\002 *** Error code from \002,a6,\002=\002,"
+ "i5,\002 for M=\002,i5,\002, type \002,i2)";
+ static char fmt_8999[] = "(/1x,a3,\002: positive definite dense matri"
+ "ces\002)";
+ static char fmt_8979[] = "(4x,\0021. Diagonal\002,24x,\0027. Last n/2 co"
+ "lumns zero\002,/4x,\0022. Upper triangular\002,16x,\0028. Random"
+ ", CNDNUM = sqrt(0.1/EPS)\002,/4x,\0023. Lower triangular\002,16x,"
+ "\0029. Random, CNDNUM = 0.1/EPS\002,/4x,\0024. Random, CNDNUM = 2"
+ "\002,13x,\00210. Scaled near underflow\002,/4x,\0025. First colu"
+ "mn zero\002,14x,\00211. Scaled near overflow\002,/4x,\0026. Last"
+ " column zero\002)";
+ static char fmt_8960[] = "(3x,i2,\002: norm_1( B - A * X ) / \002,\002("
+ " norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF\002,/4x"
+ ",\002or norm_1( B - A * X ) / \002,\002( norm_1(A) * norm_1(X) "
+ "* EPS ) > THRES if ZPOTRF\002)";
+ static char fmt_9998[] = "(\002 UPLO='\002,a1,\002', N =\002,i5,\002, NR"
+ "HS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g12"
+ ".5)";
+ static char fmt_9996[] = "(1x,a6,\002: \002,i6,\002 out of \002,i6,\002 "
+ "tests failed to pass the threshold\002)";
+ static char fmt_9995[] = "(/1x,\002All tests for \002,a6,\002 routines p"
+ "assed the threshold (\002,i6,\002 tests run)\002)";
+ static char fmt_9994[] = "(6x,i6,\002 error messages recorded\002)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ cilist ci__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, n, im, kl, ku, lda, ioff, mode, kase, imat, info;
+ char path[3], dist[1];
+ integer irhs, iter, nrhs;
+ char uplo[1], type__[1];
+ integer nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4], nimat;
+ doublereal anorm;
+ integer iuplo, izero, nerrs;
+ logical zerot;
+ extern /* Subroutine */ int zpot06_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *);
+ char xtype[1];
+ extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), alaerh_(char *,
+ char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *), zlaipd_(integer *,
+ doublecomplex *, integer *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ integer *), zlatms_(integer *,
+ integer *, char *, integer *, char *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *, char *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal result[1];
+ extern /* Subroutine */ int zcposv_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, complex *,
+ doublereal *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___32 = { 0, 0, 0, fmt_9988, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9975, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_8999, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_8979, 0 };
+ static cilist io___37 = { 0, 0, 0, fmt_8960, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___40 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* May 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVAC tests ZCPOSV. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NM (input) INTEGER */
+/* The number of values of N contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(3,NSMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(2*NMAX,2*NSMAX+NWORK)) */
+
+/* SWORK (workspace) COMPLEX array, dimension */
+/* (NMAX*(NSMAX+NMAX)) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Local Variables .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --swork;
+ --rwork;
+ --work;
+ --x;
+ --b;
+ --afac;
+ --a;
+ --nsval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ kase = 0;
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "PO", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+ infoc_1.infot = 0;
+
+/* Do for each value of N in MVAL */
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ n = mval[im];
+ lda = max(n,1);
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L110;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot && n < imat - 2) {
+ goto L110;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Set up parameters with ZLATB4 and generate a test matrix */
+/* with ZLATMS. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
+ &info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L100;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ i__3 = lda + 1;
+ zlaipd_(&n, &a[1], &i__3, &c__0);
+
+ i__3 = *nns;
+ for (irhs = 1; irhs <= i__3; ++irhs) {
+ nrhs = nsval[irhs];
+ *(unsigned char *)xtype = 'N';
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (ftnlen)6);
+ zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &nrhs, &
+ a[1], &lda, &x[1], &lda, &b[1], &lda, iseed, &
+ info);
+
+/* Compute the L*L' or U'*U factorization of the */
+/* matrix and solve the system. */
+
+ s_copy(srnamc_1.srnamt, "ZCPOSV ", (ftnlen)32, (ftnlen)7);
+ ++kase;
+
+ zlacpy_("All", &n, &n, &a[1], &lda, &afac[1], &lda);
+
+ zcposv_(uplo, &n, &nrhs, &afac[1], &lda, &b[1], &lda, &x[
+ 1], &lda, &work[1], &swork[1], &rwork[1], &iter, &
+ info);
+
+ if (iter < 0) {
+ zlacpy_("All", &n, &n, &a[1], &lda, &afac[1], &lda);
+ }
+
+/* Check error code from ZCPOSV . */
+
+ if (info != izero) {
+
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ ++nerrs;
+
+ if (info != izero && izero != 0) {
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "ZCPOSV", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&izero, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ } else {
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, "ZCPOSV", (ftnlen)6);
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ }
+ }
+
+/* Skip the remaining test if the matrix is singular. */
+
+ if (info != 0) {
+ goto L110;
+ }
+
+/* Check the quality of the solution */
+
+ zlacpy_("All", &n, &nrhs, &b[1], &lda, &work[1], &lda);
+
+ zpot06_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &work[
+ 1], &lda, &rwork[1], result);
+
+/* Check if the test passes the tesing. */
+/* Print information about the tests that did not */
+/* pass the testing. */
+
+/* If iterative refinement has been used and claimed to */
+/* be successful (ITER>0), we want */
+/* NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS*SRQT(N)) < 1 */
+
+/* If double precision has been used (ITER<0), we want */
+/* NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS) < THRES */
+/* (Cf. the linear solver testing routines) */
+
+ if (*thresh <= 0.f || iter >= 0 && n > 0 && result[0] >=
+ sqrt((doublereal) n) || iter < 0 && result[0] >= *
+ thresh) {
+
+ if (nfail == 0 && nerrs == 0) {
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, "ZPO", (ftnlen)3);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *nout;
+ ci__1.cifmt = "( ' Matrix types:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *nout;
+ ci__1.cifmt = "( ' Test ratios:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(
+ integer));
+ e_wsfe();
+ ci__1.cierr = 0;
+ ci__1.ciunit = *nout;
+ ci__1.cifmt = "( ' Messages:' )";
+ s_wsfe(&ci__1);
+ e_wsfe();
+ }
+
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+
+ ++nfail;
+
+ }
+
+ ++nrun;
+
+/* L60: */
+ }
+L100:
+ ;
+ }
+L110:
+ ;
+ }
+/* L120: */
+ }
+
+/* L130: */
+
+/* Print a summary of the results. */
+
+ if (nfail > 0) {
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, "ZCPOSV", (ftnlen)6);
+ do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___40.ciunit = *nout;
+ s_wsfe(&io___40);
+ do_fio(&c__1, "ZCPOSV", (ftnlen)6);
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (nerrs > 0) {
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, (char *)&nerrs, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+
+/* SUBNAM, INFO, INFOE, N, IMAT */
+
+
+/* SUBNAM, INFO, N, IMAT */
+
+ return 0;
+
+/* End of ZDRVAC */
+
+} /* zdrvac_ */
diff --git a/TESTING/LIN/zdrvgb.c b/TESTING/LIN/zdrvgb.c
new file mode 100644
index 0000000..d230c38
--- /dev/null
+++ b/TESTING/LIN/zdrvgb.c
@@ -0,0 +1,1138 @@
+/* zdrvgb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublecomplex c_b48 = {0.,0.};
+static doublecomplex c_b49 = {1.,0.};
+static integer c__6 = 6;
+static integer c__7 = 7;
+
+/* Subroutine */ int zdrvgb_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, doublecomplex *a,
+ integer *la, doublecomplex *afb, integer *lafb, doublecomplex *asav,
+ doublecomplex *b, doublecomplex *bsav, doublecomplex *x,
+ doublecomplex *xact, doublereal *s, doublecomplex *work, doublereal *
+ rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*4] = "N" "R" "C" "B";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 *** In ZDRVGB, LA=\002,i5,\002 is too sm"
+ "all for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> In"
+ "crease LA to at least \002,i5)";
+ static char fmt_9998[] = "(\002 *** In ZDRVGB, LAFB=\002,i5,\002 is too "
+ "small for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> "
+ "Increase LAFB to at least \002,i5)";
+ static char fmt_9997[] = "(1x,a,\002, N=\002,i5,\002, KL=\002,i5,\002, K"
+ "U=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)"
+ ;
+ static char fmt_9995[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002"
+ ",i5,\002,\002,i5,\002,\002,i5,\002,...), EQUED='\002,a1,\002', t"
+ "ype \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002"
+ ",i5,\002,\002,i5,\002,\002,i5,\002,...), type \002,i1,\002, test("
+ "\002,i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10,
+ i__11[2];
+ doublereal d__1, d__2;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+ double z_abs(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, k1, nb, in, kl, ku, nt, lda, ldb, ikl, nkl,
+ iku, nku;
+ char fact[1];
+ integer ioff, mode;
+ doublereal amax;
+ char path[3];
+ integer imat, info;
+ char dist[1];
+ doublereal rdum[1];
+ char type__[1];
+ integer nrun, ldafb, ifact, nfail, iseed[4], nfact;
+ extern doublereal dget06_(doublereal *, doublereal *);
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ doublereal rcond, roldc;
+ extern /* Subroutine */ int zgbt01_(integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *, doublecomplex *, doublereal *);
+ integer nimat;
+ doublereal roldi;
+ extern /* Subroutine */ int zgbt02_(char *, integer *, integer *, integer
+ *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *), zgbt05_(char *, integer *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *
+, doublereal *, doublereal *, doublereal *);
+ doublereal anorm;
+ integer itran;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+);
+ logical equil;
+ doublereal roldo;
+ char trans[1];
+ integer izero, nerrs;
+ extern /* Subroutine */ int zgbsv_(integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, integer *, doublecomplex *,
+ integer *, integer *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), aladhd_(integer *,
+ char *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ logical prefac;
+ doublereal colcnd, rcondc;
+ logical nofact;
+ integer iequed;
+ extern doublereal zlangb_(char *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+ doublereal rcondi;
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zlaqgb_(integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, char *),
+ alasvm_(char *, integer *, integer *, integer *, integer *);
+ doublereal cndnum, anormi, rcondo, ainvnm;
+ extern doublereal zlantb_(char *, char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+ logical trfcon;
+ doublereal anormo, rowcnd;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), zgbequ_(
+ integer *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *), zgbtrf_(integer *, integer *, integer *
+, integer *, doublecomplex *, integer *, integer *, integer *);
+ doublereal anrmpv;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ integer *), zlaset_(char *,
+ integer *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *), zgbtrs_(char *, integer *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ integer *, doublecomplex *, integer *, integer *),
+ zlatms_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublecomplex *, integer *, doublecomplex *,
+ integer *);
+ doublereal result[7];
+ extern /* Subroutine */ int zgbsvx_(char *, char *, integer *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *, char *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, doublecomplex *,
+ doublereal *, integer *);
+ doublereal rpvgrw;
+ extern /* Subroutine */ int zerrvx_(char *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___73 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___74 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___75 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___76 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___77 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___80 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVGB tests the driver routines ZGBSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) COMPLEX*16 array, dimension (LA) */
+
+/* LA (input) INTEGER */
+/* The length of the array A. LA >= (2*NMAX-1)*NMAX */
+/* where NMAX is the largest entry in NVAL. */
+
+/* AFB (workspace) COMPLEX*16 array, dimension (LAFB) */
+
+/* LAFB (input) INTEGER */
+/* The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX */
+/* where NMAX is the largest entry in NVAL. */
+
+/* ASAV (workspace) COMPLEX*16 array, dimension (LA) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension (2*NMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(3,NRHS,NMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NRHS)) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afb;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "GB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ ldb = max(n,1);
+ *(unsigned char *)xtype = 'N';
+
+/* Set limits on the number of loop iterations. */
+
+/* Computing MAX */
+ i__2 = 1, i__3 = min(n,4);
+ nkl = max(i__2,i__3);
+ if (n == 0) {
+ nkl = 1;
+ }
+ nku = nkl;
+ nimat = 8;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nkl;
+ for (ikl = 1; ikl <= i__2; ++ikl) {
+
+/* Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes */
+/* it easier to skip redundant values for small values of N. */
+
+ if (ikl == 1) {
+ kl = 0;
+ } else if (ikl == 2) {
+/* Computing MAX */
+ i__3 = n - 1;
+ kl = max(i__3,0);
+ } else if (ikl == 3) {
+ kl = (n * 3 - 1) / 4;
+ } else if (ikl == 4) {
+ kl = (n + 1) / 4;
+ }
+ i__3 = nku;
+ for (iku = 1; iku <= i__3; ++iku) {
+
+/* Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order */
+/* makes it easier to skip redundant values for small */
+/* values of N. */
+
+ if (iku == 1) {
+ ku = 0;
+ } else if (iku == 2) {
+/* Computing MAX */
+ i__4 = n - 1;
+ ku = max(i__4,0);
+ } else if (iku == 3) {
+ ku = (n * 3 - 1) / 4;
+ } else if (iku == 4) {
+ ku = (n + 1) / 4;
+ }
+
+/* Check that A and AFB are big enough to generate this */
+/* matrix. */
+
+ lda = kl + ku + 1;
+ ldafb = (kl << 1) + ku + 1;
+ if (lda * n > *la || ldafb * n > *lafb) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (lda * n > *la) {
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, (char *)&(*la), (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ i__4 = n * (kl + ku + 1);
+ do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ if (ldafb * n > *lafb) {
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__1, (char *)&(*lafb), (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ i__4 = n * ((kl << 1) + ku + 1);
+ do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ goto L130;
+ }
+
+ i__4 = nimat;
+ for (imat = 1; imat <= i__4; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+/* Skip types 2, 3, or 4 if the matrix is too small. */
+
+ zerot = imat >= 2 && imat <= 4;
+ if (zerot && n < imat - 1) {
+ goto L120;
+ }
+
+/* Set up parameters with ZLATB4 and generate a */
+/* test matrix with ZLATMS. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
+ mode, &cndnum, dist);
+ rcondc = 1. / cndnum;
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "Z", &a[1], &lda, &work[
+ 1], &info);
+
+/* Check the error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, " ", &n, &n, &
+ kl, &ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L120;
+ }
+
+/* For types 2, 3, and 4, zero one or more columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ izero = 0;
+ if (zerot) {
+ if (imat == 2) {
+ izero = 1;
+ } else if (imat == 3) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 4) {
+/* Computing MAX */
+ i__5 = 1, i__6 = ku + 2 - izero;
+ i1 = max(i__5,i__6);
+/* Computing MIN */
+ i__5 = kl + ku + 1, i__6 = ku + 1 + (n - izero);
+ i2 = min(i__5,i__6);
+ i__5 = i2;
+ for (i__ = i1; i__ <= i__5; ++i__) {
+ i__6 = ioff + i__;
+ a[i__6].r = 0., a[i__6].i = 0.;
+/* L20: */
+ }
+ } else {
+ i__5 = n;
+ for (j = izero; j <= i__5; ++j) {
+/* Computing MAX */
+ i__6 = 1, i__7 = ku + 2 - j;
+/* Computing MIN */
+ i__9 = kl + ku + 1, i__10 = ku + 1 + (n - j);
+ i__8 = min(i__9,i__10);
+ for (i__ = max(i__6,i__7); i__ <= i__8; ++i__)
+ {
+ i__6 = ioff + i__;
+ a[i__6].r = 0., a[i__6].i = 0.;
+/* L30: */
+ }
+ ioff += lda;
+/* L40: */
+ }
+ }
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ i__5 = kl + ku + 1;
+ zlacpy_("Full", &i__5, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 4; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__5 = nfact;
+ for (ifact = 1; ifact <= i__5; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L100;
+ }
+ rcondo = 0.;
+ rcondi = 0.;
+
+ } else if (! nofact) {
+
+/* Compute the condition number for comparison */
+/* with the value returned by DGESVX (FACT = */
+/* 'N' reuses the condition number from the */
+/* previous iteration with FACT = 'F'). */
+
+ i__8 = kl + ku + 1;
+ zlacpy_("Full", &i__8, &n, &asav[1], &lda, &
+ afb[kl + 1], &ldafb);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ zgbequ_(&n, &n, &kl, &ku, &afb[kl + 1], &
+ ldafb, &s[1], &s[n + 1], &rowcnd,
+ &colcnd, &amax, &info);
+ if (info == 0 && n > 0) {
+ if (lsame_(equed, "R")) {
+ rowcnd = 0.;
+ colcnd = 1.;
+ } else if (lsame_(equed, "C")) {
+ rowcnd = 1.;
+ colcnd = 0.;
+ } else if (lsame_(equed, "B")) {
+ rowcnd = 0.;
+ colcnd = 0.;
+ }
+
+/* Equilibrate the matrix. */
+
+ zlaqgb_(&n, &n, &kl, &ku, &afb[kl + 1]
+, &ldafb, &s[1], &s[n + 1], &
+ rowcnd, &colcnd, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in ZGET04. */
+
+ if (equil) {
+ roldo = rcondo;
+ roldi = rcondi;
+ }
+
+/* Compute the 1-norm and infinity-norm of A. */
+
+ anormo = zlangb_("1", &n, &kl, &ku, &afb[kl +
+ 1], &ldafb, &rwork[1]);
+ anormi = zlangb_("I", &n, &kl, &ku, &afb[kl +
+ 1], &ldafb, &rwork[1]);
+
+/* Factor the matrix A. */
+
+ zgbtrf_(&n, &n, &kl, &ku, &afb[1], &ldafb, &
+ iwork[1], &info);
+
+/* Form the inverse of A. */
+
+ zlaset_("Full", &n, &n, &c_b48, &c_b49, &work[
+ 1], &ldb);
+ s_copy(srnamc_1.srnamt, "ZGBTRS", (ftnlen)32,
+ (ftnlen)6);
+ zgbtrs_("No transpose", &n, &kl, &ku, &n, &
+ afb[1], &ldafb, &iwork[1], &work[1], &
+ ldb, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = zlange_("1", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormo <= 0. || ainvnm <= 0.) {
+ rcondo = 1.;
+ } else {
+ rcondo = 1. / anormo / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number */
+/* of A. */
+
+ ainvnm = zlange_("I", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormi <= 0. || ainvnm <= 0.) {
+ rcondi = 1.;
+ } else {
+ rcondi = 1. / anormi / ainvnm;
+ }
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for each value of TRANS. */
+
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Restore the matrix A. */
+
+ i__8 = kl + ku + 1;
+ zlacpy_("Full", &i__8, &n, &asav[1], &lda, &a[
+ 1], &lda);
+
+/* Form an exact solution and set the right hand */
+/* side. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32,
+ (ftnlen)6);
+ zlarhs_(path, xtype, "Full", trans, &n, &n, &
+ kl, &ku, nrhs, &a[1], &lda, &xact[1],
+ &ldb, &b[1], &ldb, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ zlacpy_("Full", &n, nrhs, &b[1], &ldb, &bsav[
+ 1], &ldb);
+
+ if (nofact && itran == 1) {
+
+/* --- Test ZGBSV --- */
+
+/* Compute the LU factorization of the matrix */
+/* and solve the system. */
+
+ i__8 = kl + ku + 1;
+ zlacpy_("Full", &i__8, &n, &a[1], &lda, &
+ afb[kl + 1], &ldafb);
+ zlacpy_("Full", &n, nrhs, &b[1], &ldb, &x[
+ 1], &ldb);
+
+ s_copy(srnamc_1.srnamt, "ZGBSV ", (ftnlen)
+ 32, (ftnlen)6);
+ zgbsv_(&n, &kl, &ku, nrhs, &afb[1], &
+ ldafb, &iwork[1], &x[1], &ldb, &
+ info);
+
+/* Check error code from ZGBSV . */
+
+ if (info != izero) {
+ alaerh_(path, "ZGBSV ", &info, &izero,
+ " ", &n, &n, &kl, &ku, nrhs,
+ &imat, &nfail, &nerrs, nout);
+ }
+
+/* Reconstruct matrix from factors and */
+/* compute residual. */
+
+ zgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
+ afb[1], &ldafb, &iwork[1], &work[
+ 1], result);
+ nt = 1;
+ if (izero == 0) {
+
+/* Compute residual of the computed */
+/* solution. */
+
+ zlacpy_("Full", &n, nrhs, &b[1], &ldb,
+ &work[1], &ldb);
+ zgbt02_("No transpose", &n, &n, &kl, &
+ ku, nrhs, &a[1], &lda, &x[1],
+ &ldb, &work[1], &ldb, &result[
+ 1]);
+
+/* Check solution from generated exact */
+/* solution. */
+
+ zget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &rcondc, &result[2])
+ ;
+ nt = 3;
+ }
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ i__8 = nt;
+ for (k = 1; k <= i__8; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___65.ciunit = *nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, "ZGBSV ", (ftnlen)6)
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k -
+ 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L50: */
+ }
+ nrun += nt;
+ }
+
+/* --- Test ZGBSVX --- */
+
+ if (! prefac) {
+ i__8 = (kl << 1) + ku + 1;
+ zlaset_("Full", &i__8, &n, &c_b48, &c_b48,
+ &afb[1], &ldafb);
+ }
+ zlaset_("Full", &n, nrhs, &c_b48, &c_b48, &x[
+ 1], &ldb);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ zlaqgb_(&n, &n, &kl, &ku, &a[1], &lda, &s[
+ 1], &s[n + 1], &rowcnd, &colcnd, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition */
+/* number and error bounds using ZGBSVX. */
+
+ s_copy(srnamc_1.srnamt, "ZGBSVX", (ftnlen)32,
+ (ftnlen)6);
+ zgbsvx_(fact, trans, &n, &kl, &ku, nrhs, &a[1]
+, &lda, &afb[1], &ldafb, &iwork[1],
+ equed, &s[1], &s[ldb + 1], &b[1], &
+ ldb, &x[1], &ldb, &rcond, &rwork[1], &
+ rwork[*nrhs + 1], &work[1], &rwork[(*
+ nrhs << 1) + 1], &info);
+
+/* Check the error code from ZGBSVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__11[0] = 1, a__1[0] = fact;
+ i__11[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__11, &c__2, (ftnlen)
+ 2);
+ alaerh_(path, "ZGBSVX", &info, &izero,
+ ch__1, &n, &n, &kl, &ku, nrhs, &
+ imat, &nfail, &nerrs, nout);
+ }
+/* Compare RWORK(2*NRHS+1) from ZGBSVX with the */
+/* computed reciprocal pivot growth RPVGRW */
+
+ if (info != 0) {
+ anrmpv = 0.;
+ i__8 = info;
+ for (j = 1; j <= i__8; ++j) {
+/* Computing MAX */
+ i__6 = ku + 2 - j;
+/* Computing MIN */
+ i__9 = n + ku + 1 - j, i__10 = kl +
+ ku + 1;
+ i__7 = min(i__9,i__10);
+ for (i__ = max(i__6,1); i__ <= i__7;
+ ++i__) {
+/* Computing MAX */
+ d__1 = anrmpv, d__2 = z_abs(&a[
+ i__ + (j - 1) * lda]);
+ anrmpv = max(d__1,d__2);
+/* L60: */
+ }
+/* L70: */
+ }
+/* Computing MIN */
+ i__7 = info - 1, i__6 = kl + ku;
+ i__8 = min(i__7,i__6);
+/* Computing MAX */
+ i__9 = 1, i__10 = kl + ku + 2 - info;
+ rpvgrw = zlantb_("M", "U", "N", &info, &
+ i__8, &afb[max(i__9, i__10)], &
+ ldafb, rdum);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = anrmpv / rpvgrw;
+ }
+ } else {
+ i__8 = kl + ku;
+ rpvgrw = zlantb_("M", "U", "N", &n, &i__8,
+ &afb[1], &ldafb, rdum);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = zlangb_("M", &n, &kl, &ku, &
+ a[1], &lda, rdum) /
+ rpvgrw;
+ }
+ }
+/* Computing MAX */
+ d__2 = rwork[(*nrhs << 1) + 1];
+ result[6] = (d__1 = rpvgrw - rwork[(*nrhs <<
+ 1) + 1], abs(d__1)) / max(d__2,rpvgrw)
+ / dlamch_("E");
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and */
+/* compute residual. */
+
+ zgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
+ afb[1], &ldafb, &iwork[1], &work[
+ 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &bsav[1], &ldb,
+ &work[1], &ldb);
+ zgbt02_(trans, &n, &n, &kl, &ku, nrhs, &
+ asav[1], &lda, &x[1], &ldb, &work[
+ 1], &ldb, &result[1]);
+
+/* Check solution from generated exact */
+/* solution. */
+
+ if (nofact || prefac && lsame_(equed,
+ "N")) {
+ zget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &rcondc, &result[2])
+ ;
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ zget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ zgbt05_(trans, &n, &kl, &ku, nrhs, &asav[
+ 1], &lda, &bsav[1], &ldb, &x[1], &
+ ldb, &xact[1], &ldb, &rwork[1], &
+ rwork[*nrhs + 1], &result[3]);
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from ZGBSVX with the computed */
+/* value in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___73.ciunit = *nout;
+ s_wsfe(&io___73);
+ do_fio(&c__1, "ZGBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___74.ciunit = *nout;
+ s_wsfe(&io___74);
+ do_fio(&c__1, "ZGBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___75.ciunit = *nout;
+ s_wsfe(&io___75);
+ do_fio(&c__1, "ZGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ } else {
+ io___76.ciunit = *nout;
+ s_wsfe(&io___76);
+ do_fio(&c__1, "ZGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___77.ciunit = *nout;
+ s_wsfe(&io___77);
+ do_fio(&c__1, "ZGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ } else {
+ io___78.ciunit = *nout;
+ s_wsfe(&io___78);
+ do_fio(&c__1, "ZGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___79.ciunit = *nout;
+ s_wsfe(&io___79);
+ do_fio(&c__1, "ZGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ } else {
+ io___80.ciunit = *nout;
+ s_wsfe(&io___80);
+ do_fio(&c__1, "ZGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ }
+/* L90: */
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+
+ return 0;
+
+/* End of ZDRVGB */
+
+} /* zdrvgb_ */
diff --git a/TESTING/LIN/zdrvgbx.c b/TESTING/LIN/zdrvgbx.c
new file mode 100644
index 0000000..e7cea53
--- /dev/null
+++ b/TESTING/LIN/zdrvgbx.c
@@ -0,0 +1,1494 @@
+/* zdrvgbx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "memory_alloc.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublecomplex c_b48 = {0.,0.};
+static doublecomplex c_b49 = {1.,0.};
+static integer c__6 = 6;
+static integer c__7 = 7;
+static doublereal c_b197 = 0.;
+
+/* Subroutine */ int zdrvgb_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, doublecomplex *a,
+ integer *la, doublecomplex *afb, integer *lafb, doublecomplex *asav,
+ doublecomplex *b, doublecomplex *bsav, doublecomplex *x,
+ doublecomplex *xact, doublereal *s, doublecomplex *work, doublereal *
+ rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*4] = "N" "R" "C" "B";
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 *** In ZDRVGB, LA=\002,i5,\002 is too sm"
+ "all for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> In"
+ "crease LA to at least \002,i5)";
+ static char fmt_9998[] = "(\002 *** In ZDRVGB, LAFB=\002,i5,\002 is too "
+ "small for N=\002,i5,\002, KU=\002,i5,\002, KL=\002,i5,/\002 ==> "
+ "Increase LAFB to at least \002,i5)";
+ static char fmt_9997[] = "(1x,a,\002, N=\002,i5,\002, KL=\002,i5,\002, K"
+ "U=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)"
+ ;
+ static char fmt_9995[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002"
+ ",i5,\002,\002,i5,\002,\002,i5,\002,...), EQUED='\002,a1,\002', t"
+ "ype \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9996[] = "(1x,a,\002( '\002,a1,\002','\002,a1,\002',\002"
+ ",i5,\002,\002,i5,\002,\002,i5,\002,...), type \002,i1,\002, test("
+ "\002,i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9, i__10,
+ i__11[2];
+ doublereal d__1, d__2;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+ double z_abs(doublecomplex *);
+
+ /* Local variables */
+ extern /* Subroutine */ int zebchvxx_(doublereal *, char *);
+ integer i__, j, k, n;
+ doublereal *errbnds_c__;
+ integer i1, i2, k1;
+ doublereal *errbnds_n__;
+ integer nb, in, kl, ku, nt, n_err_bnds__, lda, ldb, ikl, nkl, iku, nku;
+ char fact[1];
+ integer ioff, mode;
+ doublereal amax;
+ char path[3];
+ integer imat, info;
+ doublereal *berr;
+ char dist[1];
+ doublereal rdum[1], rpvgrw_svxx__;
+ char type__[1];
+ integer nrun;
+ extern doublereal zla_gbrpvgrw__(integer *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *);
+ integer ldafb, ifact, nfail, iseed[4], nfact;
+ extern doublereal dget06_(doublereal *, doublereal *);
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ doublereal rcond, roldc;
+ extern /* Subroutine */ int zgbt01_();
+ integer nimat;
+ doublereal roldi;
+ extern /* Subroutine */ int zgbt02_(), zgbt05_(char *, integer *, integer
+ *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *);
+ doublereal anorm;
+ integer itran;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+);
+ logical equil;
+ doublereal roldo;
+ char trans[1];
+ integer izero, nerrs;
+ extern /* Subroutine */ int zgbsv_(integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, integer *, doublecomplex *,
+ integer *, integer *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), aladhd_(integer *,
+ char *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ logical prefac;
+ doublereal colcnd, rcondc;
+ logical nofact;
+ integer iequed;
+ extern doublereal zlangb_(char *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+ doublereal rcondi;
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zlaqgb_(integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, char *),
+ alasvm_(char *, integer *, integer *, integer *, integer *);
+ doublereal cndnum, anormi, rcondo, ainvnm;
+ extern doublereal zlantb_(char *, char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+ logical trfcon;
+ doublereal anormo, rowcnd;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), zgbequ_(
+ integer *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *), zgbtrf_(integer *, integer *, integer *
+, integer *, doublecomplex *, integer *, integer *, integer *);
+ doublereal anrmpv;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ integer *), zlaset_(), zgbtrs_(
+ char *, integer *, integer *, integer *, integer *, doublecomplex
+ *, integer *, integer *, doublecomplex *, integer *, integer *), zlatms_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublecomplex *, integer *, doublecomplex *,
+ integer *);
+ doublereal result[7];
+ extern /* Subroutine */ int zgbsvx_(char *, char *, integer *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *, char *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, doublecomplex *,
+ doublereal *, integer *);
+ doublereal rpvgrw;
+ extern /* Subroutine */ int zerrvx_(char *, integer *), zgbsvxx_(
+ char *, char *, integer *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ char *, doublereal *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, doublecomplex *, doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___73 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___74 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___75 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___76 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___77 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___80 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___86 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___87 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___88 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___89 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___90 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___91 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___92 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___93 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVGB tests the driver routines ZGBSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) COMPLEX*16 array, dimension (LA) */
+
+/* LA (input) INTEGER */
+/* The length of the array A. LA >= (2*NMAX-1)*NMAX */
+/* where NMAX is the largest entry in NVAL. */
+
+/* AFB (workspace) COMPLEX*16 array, dimension (LAFB) */
+
+/* LAFB (input) INTEGER */
+/* The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX */
+/* where NMAX is the largest entry in NVAL. */
+
+/* ASAV (workspace) COMPLEX*16 array, dimension (LA) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension (2*NMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(3,NRHS,NMAX)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension */
+/* (max(NMAX,2*NRHS)) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afb;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "GB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ ldb = max(n,1);
+ *(unsigned char *)xtype = 'N';
+
+/* Set limits on the number of loop iterations. */
+
+/* Computing MAX */
+ i__2 = 1, i__3 = min(n,4);
+ nkl = max(i__2,i__3);
+ if (n == 0) {
+ nkl = 1;
+ }
+ nku = nkl;
+ nimat = 8;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nkl;
+ for (ikl = 1; ikl <= i__2; ++ikl) {
+
+/* Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes */
+/* it easier to skip redundant values for small values of N. */
+
+ if (ikl == 1) {
+ kl = 0;
+ } else if (ikl == 2) {
+/* Computing MAX */
+ i__3 = n - 1;
+ kl = max(i__3,0);
+ } else if (ikl == 3) {
+ kl = (n * 3 - 1) / 4;
+ } else if (ikl == 4) {
+ kl = (n + 1) / 4;
+ }
+ i__3 = nku;
+ for (iku = 1; iku <= i__3; ++iku) {
+
+/* Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order */
+/* makes it easier to skip redundant values for small */
+/* values of N. */
+
+ if (iku == 1) {
+ ku = 0;
+ } else if (iku == 2) {
+/* Computing MAX */
+ i__4 = n - 1;
+ ku = max(i__4,0);
+ } else if (iku == 3) {
+ ku = (n * 3 - 1) / 4;
+ } else if (iku == 4) {
+ ku = (n + 1) / 4;
+ }
+
+/* Check that A and AFB are big enough to generate this */
+/* matrix. */
+
+ lda = kl + ku + 1;
+ ldafb = (kl << 1) + ku + 1;
+ if (lda * n > *la || ldafb * n > *lafb) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (lda * n > *la) {
+ io___26.ciunit = *nout;
+ s_wsfe(&io___26);
+ do_fio(&c__1, (char *)&(*la), (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ i__4 = n * (kl + ku + 1);
+ do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ if (ldafb * n > *lafb) {
+ io___27.ciunit = *nout;
+ s_wsfe(&io___27);
+ do_fio(&c__1, (char *)&(*lafb), (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ i__4 = n * ((kl << 1) + ku + 1);
+ do_fio(&c__1, (char *)&i__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ++nerrs;
+ }
+ goto L130;
+ }
+
+ i__4 = nimat;
+ for (imat = 1; imat <= i__4; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+/* Skip types 2, 3, or 4 if the matrix is too small. */
+
+ zerot = imat >= 2 && imat <= 4;
+ if (zerot && n < imat - 1) {
+ goto L120;
+ }
+
+/* Set up parameters with ZLATB4 and generate a */
+/* test matrix with ZLATMS. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
+ mode, &cndnum, dist);
+ rcondc = 1. / cndnum;
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, "Z", &a[1], &lda, &work[
+ 1], &info);
+
+/* Check the error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, " ", &n, &n, &
+ kl, &ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L120;
+ }
+
+/* For types 2, 3, and 4, zero one or more columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ izero = 0;
+ if (zerot) {
+ if (imat == 2) {
+ izero = 1;
+ } else if (imat == 3) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 4) {
+/* Computing MAX */
+ i__5 = 1, i__6 = ku + 2 - izero;
+ i1 = max(i__5,i__6);
+/* Computing MIN */
+ i__5 = kl + ku + 1, i__6 = ku + 1 + (n - izero);
+ i2 = min(i__5,i__6);
+ i__5 = i2;
+ for (i__ = i1; i__ <= i__5; ++i__) {
+ i__6 = ioff + i__;
+ a[i__6].r = 0., a[i__6].i = 0.;
+/* L20: */
+ }
+ } else {
+ i__5 = n;
+ for (j = izero; j <= i__5; ++j) {
+/* Computing MAX */
+ i__6 = 1, i__7 = ku + 2 - j;
+/* Computing MIN */
+ i__9 = kl + ku + 1, i__10 = ku + 1 + (n - j);
+ i__8 = min(i__9,i__10);
+ for (i__ = max(i__6,i__7); i__ <= i__8; ++i__)
+ {
+ i__6 = ioff + i__;
+ a[i__6].r = 0., a[i__6].i = 0.;
+/* L30: */
+ }
+ ioff += lda;
+/* L40: */
+ }
+ }
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ i__5 = kl + ku + 1;
+ zlacpy_("Full", &i__5, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 4; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__5 = nfact;
+ for (ifact = 1; ifact <= i__5; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L100;
+ }
+ rcondo = 0.;
+ rcondi = 0.;
+
+ } else if (! nofact) {
+
+/* Compute the condition number for comparison */
+/* with the value returned by DGESVX (FACT = */
+/* 'N' reuses the condition number from the */
+/* previous iteration with FACT = 'F'). */
+
+ i__8 = kl + ku + 1;
+ zlacpy_("Full", &i__8, &n, &asav[1], &lda, &
+ afb[kl + 1], &ldafb);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ zgbequ_(&n, &n, &kl, &ku, &afb[kl + 1], &
+ ldafb, &s[1], &s[n + 1], &rowcnd,
+ &colcnd, &amax, &info);
+ if (info == 0 && n > 0) {
+ if (lsame_(equed, "R")) {
+ rowcnd = 0.;
+ colcnd = 1.;
+ } else if (lsame_(equed, "C")) {
+ rowcnd = 1.;
+ colcnd = 0.;
+ } else if (lsame_(equed, "B")) {
+ rowcnd = 0.;
+ colcnd = 0.;
+ }
+
+/* Equilibrate the matrix. */
+
+ zlaqgb_(&n, &n, &kl, &ku, &afb[kl + 1]
+, &ldafb, &s[1], &s[n + 1], &
+ rowcnd, &colcnd, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in ZGET04. */
+
+ if (equil) {
+ roldo = rcondo;
+ roldi = rcondi;
+ }
+
+/* Compute the 1-norm and infinity-norm of A. */
+
+ anormo = zlangb_("1", &n, &kl, &ku, &afb[kl +
+ 1], &ldafb, &rwork[1]);
+ anormi = zlangb_("I", &n, &kl, &ku, &afb[kl +
+ 1], &ldafb, &rwork[1]);
+
+/* Factor the matrix A. */
+
+ zgbtrf_(&n, &n, &kl, &ku, &afb[1], &ldafb, &
+ iwork[1], &info);
+
+/* Form the inverse of A. */
+
+ zlaset_("Full", &n, &n, &c_b48, &c_b49, &work[
+ 1], &ldb);
+ s_copy(srnamc_1.srnamt, "ZGBTRS", (ftnlen)32,
+ (ftnlen)6);
+ zgbtrs_("No transpose", &n, &kl, &ku, &n, &
+ afb[1], &ldafb, &iwork[1], &work[1], &
+ ldb, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = zlange_("1", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormo <= 0. || ainvnm <= 0.) {
+ rcondo = 1.;
+ } else {
+ rcondo = 1. / anormo / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number */
+/* of A. */
+
+ ainvnm = zlange_("I", &n, &n, &work[1], &ldb,
+ &rwork[1]);
+ if (anormi <= 0. || ainvnm <= 0.) {
+ rcondi = 1.;
+ } else {
+ rcondi = 1. / anormi / ainvnm;
+ }
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for each value of TRANS. */
+
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Restore the matrix A. */
+
+ i__8 = kl + ku + 1;
+ zlacpy_("Full", &i__8, &n, &asav[1], &lda, &a[
+ 1], &lda);
+
+/* Form an exact solution and set the right hand */
+/* side. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32,
+ (ftnlen)6);
+ zlarhs_(path, xtype, "Full", trans, &n, &n, &
+ kl, &ku, nrhs, &a[1], &lda, &xact[1],
+ &ldb, &b[1], &ldb, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ zlacpy_("Full", &n, nrhs, &b[1], &ldb, &bsav[
+ 1], &ldb);
+
+ if (nofact && itran == 1) {
+
+/* --- Test ZGBSV --- */
+
+/* Compute the LU factorization of the matrix */
+/* and solve the system. */
+
+ i__8 = kl + ku + 1;
+ zlacpy_("Full", &i__8, &n, &a[1], &lda, &
+ afb[kl + 1], &ldafb);
+ zlacpy_("Full", &n, nrhs, &b[1], &ldb, &x[
+ 1], &ldb);
+
+ s_copy(srnamc_1.srnamt, "ZGBSV ", (ftnlen)
+ 32, (ftnlen)6);
+ zgbsv_(&n, &kl, &ku, nrhs, &afb[1], &
+ ldafb, &iwork[1], &x[1], &ldb, &
+ info);
+
+/* Check error code from ZGBSV . */
+
+ if (info == n + 1) {
+ goto L90;
+ }
+ if (info != izero) {
+ alaerh_(path, "ZGBSV ", &info, &izero,
+ " ", &n, &n, &kl, &ku, nrhs,
+ &imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+
+/* Reconstruct matrix from factors and */
+/* compute residual. */
+
+ zgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
+ afb[1], &ldafb, &iwork[1], &work[
+ 1], result);
+ nt = 1;
+ if (izero == 0) {
+
+/* Compute residual of the computed */
+/* solution. */
+
+ zlacpy_("Full", &n, nrhs, &b[1], &ldb,
+ &work[1], &ldb);
+ zgbt02_("No transpose", &n, &n, &kl, &
+ ku, nrhs, &a[1], &lda, &x[1],
+ &ldb, &work[1], &ldb, &result[
+ 1]);
+
+/* Check solution from generated exact */
+/* solution. */
+
+ zget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &rcondc, &result[2])
+ ;
+ nt = 3;
+ }
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ i__8 = nt;
+ for (k = 1; k <= i__8; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___65.ciunit = *nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, "ZGBSV ", (ftnlen)6)
+ ;
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k -
+ 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L50: */
+ }
+ nrun += nt;
+ }
+
+/* --- Test ZGBSVX --- */
+
+ if (! prefac) {
+ i__8 = (kl << 1) + ku + 1;
+ zlaset_("Full", &i__8, &n, &c_b48, &c_b48,
+ &afb[1], &ldafb);
+ }
+ zlaset_("Full", &n, nrhs, &c_b48, &c_b48, &x[
+ 1], &ldb);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ zlaqgb_(&n, &n, &kl, &ku, &a[1], &lda, &s[
+ 1], &s[n + 1], &rowcnd, &colcnd, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition */
+/* number and error bounds using ZGBSVX. */
+
+ s_copy(srnamc_1.srnamt, "ZGBSVX", (ftnlen)32,
+ (ftnlen)6);
+ zgbsvx_(fact, trans, &n, &kl, &ku, nrhs, &a[1]
+, &lda, &afb[1], &ldafb, &iwork[1],
+ equed, &s[1], &s[ldb + 1], &b[1], &
+ ldb, &x[1], &ldb, &rcond, &rwork[1], &
+ rwork[*nrhs + 1], &work[1], &rwork[(*
+ nrhs << 1) + 1], &info);
+
+/* Check the error code from ZGBSVX. */
+
+ if (info == n + 1) {
+ goto L90;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__11[0] = 1, a__1[0] = fact;
+ i__11[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__11, &c__2, (ftnlen)
+ 2);
+ alaerh_(path, "ZGBSVX", &info, &izero,
+ ch__1, &n, &n, &kl, &ku, nrhs, &
+ imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+/* Compare RWORK(2*NRHS+1) from ZGBSVX with the */
+/* computed reciprocal pivot growth RPVGRW */
+
+ if (info != 0) {
+ anrmpv = 0.;
+ i__8 = info;
+ for (j = 1; j <= i__8; ++j) {
+/* Computing MAX */
+ i__6 = ku + 2 - j;
+/* Computing MIN */
+ i__9 = n + ku + 1 - j, i__10 = kl +
+ ku + 1;
+ i__7 = min(i__9,i__10);
+ for (i__ = max(i__6,1); i__ <= i__7;
+ ++i__) {
+/* Computing MAX */
+ d__1 = anrmpv, d__2 = z_abs(&a[
+ i__ + (j - 1) * lda]);
+ anrmpv = max(d__1,d__2);
+/* L60: */
+ }
+/* L70: */
+ }
+/* Computing MIN */
+ i__7 = info - 1, i__6 = kl + ku;
+ i__8 = min(i__7,i__6);
+/* Computing MAX */
+ i__9 = 1, i__10 = kl + ku + 2 - info;
+ rpvgrw = zlantb_("M", "U", "N", &info, &
+ i__8, &afb[max(i__9, i__10)], &
+ ldafb, rdum);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = anrmpv / rpvgrw;
+ }
+ } else {
+ i__8 = kl + ku;
+ rpvgrw = zlantb_("M", "U", "N", &n, &i__8,
+ &afb[1], &ldafb, rdum);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = zlangb_("M", &n, &kl, &ku, &
+ a[1], &lda, rdum) /
+ rpvgrw;
+ }
+ }
+/* Computing MAX */
+ d__2 = rwork[(*nrhs << 1) + 1];
+ result[6] = (d__1 = rpvgrw - rwork[(*nrhs <<
+ 1) + 1], abs(d__1)) / max(d__2,rpvgrw)
+ / dlamch_("E");
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and */
+/* compute residual. */
+
+ zgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
+ afb[1], &ldafb, &iwork[1], &work[
+ 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &bsav[1], &ldb,
+ &work[1], &ldb);
+ zgbt02_(trans, &n, &n, &kl, &ku, nrhs, &
+ asav[1], &lda, &x[1], &ldb, &work[
+ 1], &ldb, &result[1]);
+
+/* Check solution from generated exact */
+/* solution. */
+
+ if (nofact || prefac && lsame_(equed,
+ "N")) {
+ zget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &rcondc, &result[2])
+ ;
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ zget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ zgbt05_(trans, &n, &kl, &ku, nrhs, &asav[
+ 1], &lda, &bsav[1], &ldb, &x[1], &
+ ldb, &xact[1], &ldb, &rwork[1], &
+ rwork[*nrhs + 1], &result[3]);
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from ZGBSVX with the computed */
+/* value in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___73.ciunit = *nout;
+ s_wsfe(&io___73);
+ do_fio(&c__1, "ZGBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___74.ciunit = *nout;
+ s_wsfe(&io___74);
+ do_fio(&c__1, "ZGBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___75.ciunit = *nout;
+ s_wsfe(&io___75);
+ do_fio(&c__1, "ZGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ } else {
+ io___76.ciunit = *nout;
+ s_wsfe(&io___76);
+ do_fio(&c__1, "ZGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___77.ciunit = *nout;
+ s_wsfe(&io___77);
+ do_fio(&c__1, "ZGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ } else {
+ io___78.ciunit = *nout;
+ s_wsfe(&io___78);
+ do_fio(&c__1, "ZGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___79.ciunit = *nout;
+ s_wsfe(&io___79);
+ do_fio(&c__1, "ZGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ } else {
+ io___80.ciunit = *nout;
+ s_wsfe(&io___80);
+ do_fio(&c__1, "ZGBSVX", (ftnlen)6)
+ ;
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ }
+/* --- Test ZGBSVXX --- */
+/* Restore the matrices A and B. */
+/* write(*,*) 'begin zgbsvxx testing' */
+ i__8 = kl + ku + 1;
+ zlacpy_("Full", &i__8, &n, &asav[1], &lda, &a[
+ 1], &lda);
+ zlacpy_("Full", &n, nrhs, &bsav[1], &ldb, &b[
+ 1], &ldb);
+ if (! prefac) {
+ i__8 = (kl << 1) + ku + 1;
+ zlaset_("Full", &i__8, &n, &c_b197, &
+ c_b197, &afb[1], &ldafb);
+ }
+ zlaset_("Full", &n, nrhs, &c_b197, &c_b197, &
+ x[1], &ldb);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ zlaqgb_(&n, &n, &kl, &ku, &a[1], &lda, &s[
+ 1], &s[n + 1], &rowcnd, &colcnd, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using ZGBSVXX. */
+
+ s_copy(srnamc_1.srnamt, "ZGBSVXX", (ftnlen)32,
+ (ftnlen)7);
+ n_err_bnds__ = 3;
+
+ dalloc3();
+
+ zgbsvxx_(fact, trans, &n, &kl, &ku, nrhs, &a[
+ 1], &lda, &afb[1], &ldafb, &iwork[1],
+ equed, &s[1], &s[n + 1], &b[1], &ldb,
+ &x[1], &ldb, &rcond, &rpvgrw_svxx__,
+ berr, &n_err_bnds__, errbnds_n__,
+ errbnds_c__, &c__0, &c_b197, &work[1],
+ &rwork[1], &info);
+
+ free3();
+
+/* Check the error code from ZGBSVXX. */
+
+ if (info == n + 1) {
+ goto L90;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__11[0] = 1, a__1[0] = fact;
+ i__11[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__11, &c__2, (ftnlen)
+ 2);
+ alaerh_(path, "ZGBSVXX", &info, &izero,
+ ch__1, &n, &n, &c_n1, &c_n1, nrhs,
+ &imat, &nfail, &nerrs, nout);
+ goto L90;
+ }
+
+/* Compare rpvgrw_svxx from ZGESVXX with the computed */
+/* reciprocal pivot growth factor RPVGRW */
+
+ if (info > 0 && info < n + 1) {
+ rpvgrw = zla_gbrpvgrw__(&n, &kl, &ku, &
+ info, &a[1], &lda, &afb[1], &
+ ldafb);
+ } else {
+ rpvgrw = zla_gbrpvgrw__(&n, &kl, &ku, &n,
+ &a[1], &lda, &afb[1], &ldafb);
+ }
+ result[6] = (d__1 = rpvgrw - rpvgrw_svxx__,
+ abs(d__1)) / max(rpvgrw_svxx__,rpvgrw)
+ / dlamch_("E");
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zgbt01_(&n, &n, &kl, &ku, &a[1], &lda, &
+ afb[1], &ldafb, &iwork[1], &rwork[
+ (*nrhs << 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &bsav[1], &ldb,
+ &work[1], &ldb);
+ zgbt02_(trans, &n, &n, &kl, &ku, nrhs, &
+ asav[1], &lda, &x[1], &ldb, &work[
+ 1], &ldb, &rwork[(*nrhs << 1) + 1]
+, &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed,
+ "N")) {
+ zget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &rcondc, &result[2])
+ ;
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ zget04_(&n, nrhs, &x[1], &ldb, &xact[
+ 1], &ldb, &roldc, &result[2]);
+ }
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from ZGBSVXX with the computed value */
+/* in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___86.ciunit = *nout;
+ s_wsfe(&io___86);
+ do_fio(&c__1, "ZGBSVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___87.ciunit = *nout;
+ s_wsfe(&io___87);
+ do_fio(&c__1, "ZGBSVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer)
+ );
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L45: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___88.ciunit = *nout;
+ s_wsfe(&io___88);
+ do_fio(&c__1, "ZGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ } else {
+ io___89.ciunit = *nout;
+ s_wsfe(&io___89);
+ do_fio(&c__1, "ZGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[0],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___90.ciunit = *nout;
+ s_wsfe(&io___90);
+ do_fio(&c__1, "ZGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ } else {
+ io___91.ciunit = *nout;
+ s_wsfe(&io___91);
+ do_fio(&c__1, "ZGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[5],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___92.ciunit = *nout;
+ s_wsfe(&io___92);
+ do_fio(&c__1, "ZGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ } else {
+ io___93.ciunit = *nout;
+ s_wsfe(&io___93);
+ do_fio(&c__1, "ZGBSVXX", (ftnlen)
+ 7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kl, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&ku, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[6],
+ (ftnlen)sizeof(doublereal)
+ );
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+
+ }
+
+L90:
+ ;
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+/* Test Error Bounds from ZGBSVXX */
+ zebchvxx_(thresh, path);
+
+ return 0;
+
+/* End of ZDRVGB */
+
+} /* zdrvgb_ */
diff --git a/TESTING/LIN/zdrvge.c b/TESTING/LIN/zdrvge.c
new file mode 100644
index 0000000..b73ec83
--- /dev/null
+++ b/TESTING/LIN/zdrvge.c
@@ -0,0 +1,910 @@
+/* zdrvge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublecomplex c_b20 = {0.,0.};
+static logical c_true = TRUE_;
+static integer c__6 = 6;
+static integer c__7 = 7;
+
+/* Subroutine */ int zdrvge_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
+ doublecomplex *a, doublecomplex *afac, doublecomplex *asav,
+ doublecomplex *b, doublecomplex *bsav, doublecomplex *x,
+ doublecomplex *xact, doublereal *s, doublecomplex *work, doublereal *
+ rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*4] = "N" "R" "C" "B";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
+ ", test(\002,i2,\002) =\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
+ "1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i2,\002"
+ ", test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
+ "1,\002', N=\002,i5,\002, type \002,i2,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ doublereal d__1, d__2;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, k, n, k1, nb, in, kl, ku, nt, lda;
+ char fact[1];
+ integer ioff, mode;
+ doublereal amax;
+ char path[3];
+ integer imat, info;
+ char dist[1];
+ doublereal rdum[1];
+ char type__[1];
+ integer nrun, ifact, nfail, iseed[4], nfact;
+ extern doublereal dget06_(doublereal *, doublereal *);
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ doublereal rcond, roldc;
+ integer nimat;
+ doublereal roldi;
+ extern /* Subroutine */ int zget01_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, doublereal *,
+ doublereal *), zget02_(char *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *);
+ doublereal anorm;
+ integer itran;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+);
+ logical equil;
+ doublereal roldo;
+ extern /* Subroutine */ int zget07_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, logical *, doublereal *, doublereal *);
+ char trans[1];
+ integer izero, nerrs, lwork;
+ extern /* Subroutine */ int zgesv_(integer *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *, integer *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), aladhd_(integer *,
+ char *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ logical prefac;
+ doublereal colcnd, rcondc;
+ logical nofact;
+ integer iequed;
+ doublereal rcondi;
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum, anormi, rcondo, ainvnm;
+ extern /* Subroutine */ int zlaqge_(integer *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *
+, doublereal *, char *);
+ logical trfcon;
+ doublereal anormo, rowcnd;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), zgeequ_(
+ integer *, integer *, doublecomplex *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *)
+ , zgetrf_(integer *, integer *, doublecomplex *, integer *,
+ integer *, integer *), zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zgetri_(integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, integer *), zlarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *), zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+ extern doublereal zlantr_(char *, char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ doublereal result[7];
+ extern /* Subroutine */ int zgesvx_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ char *, doublereal *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *, doublecomplex *, doublereal *, integer *);
+ doublereal rpvgrw;
+ extern /* Subroutine */ int zerrvx_(char *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___68 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___69 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVGE tests the driver routines ZGESV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension (2*NMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*NRHS+NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "GE", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 11;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L80;
+ }
+
+/* Skip types 5, 6, or 7 if the matrix size is too small. */
+
+ zerot = imat >= 5 && imat <= 7;
+ if (zerot && n < imat - 4) {
+ goto L80;
+ }
+
+/* Set up parameters with ZLATB4 and generate a test matrix */
+/* with ZLATMS. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cndnum, dist);
+ rcondc = 1. / cndnum;
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cndnum, &
+ anorm, &kl, &ku, "No packing", &a[1], &lda, &work[1], &
+ info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, " ", &n, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L80;
+ }
+
+/* For types 5-7, zero one or more columns of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 5) {
+ izero = 1;
+ } else if (imat == 6) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 7) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L20: */
+ }
+ } else {
+ i__3 = n - izero + 1;
+ zlaset_("Full", &n, &i__3, &c_b20, &c_b20, &a[ioff + 1], &
+ lda);
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ zlacpy_("Full", &n, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 4; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[iequed -
+ 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__3 = nfact;
+ for (ifact = 1; ifact <= i__3; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[ifact -
+ 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L60;
+ }
+ rcondo = 0.;
+ rcondi = 0.;
+
+ } else if (! nofact) {
+
+/* Compute the condition number for comparison with */
+/* the value returned by ZGESVX (FACT = 'N' reuses */
+/* the condition number from the previous iteration */
+/* with FACT = 'F'). */
+
+ zlacpy_("Full", &n, &n, &asav[1], &lda, &afac[1], &
+ lda);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ zgeequ_(&n, &n, &afac[1], &lda, &s[1], &s[n + 1],
+ &rowcnd, &colcnd, &amax, &info);
+ if (info == 0 && n > 0) {
+ if (lsame_(equed, "R"))
+ {
+ rowcnd = 0.;
+ colcnd = 1.;
+ } else if (lsame_(equed, "C")) {
+ rowcnd = 1.;
+ colcnd = 0.;
+ } else if (lsame_(equed, "B")) {
+ rowcnd = 0.;
+ colcnd = 0.;
+ }
+
+/* Equilibrate the matrix. */
+
+ zlaqge_(&n, &n, &afac[1], &lda, &s[1], &s[n +
+ 1], &rowcnd, &colcnd, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the non-equilibrated */
+/* system for use in ZGET04. */
+
+ if (equil) {
+ roldo = rcondo;
+ roldi = rcondi;
+ }
+
+/* Compute the 1-norm and infinity-norm of A. */
+
+ anormo = zlange_("1", &n, &n, &afac[1], &lda, &rwork[
+ 1]);
+ anormi = zlange_("I", &n, &n, &afac[1], &lda, &rwork[
+ 1]);
+
+/* Factor the matrix A. */
+
+ zgetrf_(&n, &n, &afac[1], &lda, &iwork[1], &info);
+
+/* Form the inverse of A. */
+
+ zlacpy_("Full", &n, &n, &afac[1], &lda, &a[1], &lda);
+ lwork = *nmax * max(3,*nrhs);
+ zgetri_(&n, &a[1], &lda, &iwork[1], &work[1], &lwork,
+ &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = zlange_("1", &n, &n, &a[1], &lda, &rwork[1]);
+ if (anormo <= 0. || ainvnm <= 0.) {
+ rcondo = 1.;
+ } else {
+ rcondo = 1. / anormo / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ ainvnm = zlange_("I", &n, &n, &a[1], &lda, &rwork[1]);
+ if (anormi <= 0. || ainvnm <= 0.) {
+ rcondi = 1.;
+ } else {
+ rcondi = 1. / anormi / ainvnm;
+ }
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+
+/* Do for each value of TRANS. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[
+ itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Restore the matrix A. */
+
+ zlacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ zlarhs_(path, xtype, "Full", trans, &n, &n, &kl, &ku,
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
+
+ if (nofact && itran == 1) {
+
+/* --- Test ZGESV --- */
+
+/* Compute the LU factorization of the matrix and */
+/* solve the system. */
+
+ zlacpy_("Full", &n, &n, &a[1], &lda, &afac[1], &
+ lda);
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "ZGESV ", (ftnlen)32, (
+ ftnlen)6);
+ zgesv_(&n, nrhs, &afac[1], &lda, &iwork[1], &x[1],
+ &lda, &info);
+
+/* Check error code from ZGESV . */
+
+ if (info != izero) {
+ alaerh_(path, "ZGESV ", &info, &izero, " ", &
+ n, &n, &c_n1, &c_n1, nrhs, &imat, &
+ nfail, &nerrs, nout);
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &rwork[1], result);
+ nt = 1;
+ if (izero == 0) {
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[
+ 1], &lda);
+ zget02_("No transpose", &n, &n, nrhs, &a[1], &
+ lda, &x[1], &lda, &work[1], &lda, &
+ rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ nt = 3;
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___55.ciunit = *nout;
+ s_wsfe(&io___55);
+ do_fio(&c__1, "ZGESV ", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L30: */
+ }
+ nrun += nt;
+ }
+
+/* --- Test ZGESVX --- */
+
+ if (! prefac) {
+ zlaset_("Full", &n, &n, &c_b20, &c_b20, &afac[1],
+ &lda);
+ }
+ zlaset_("Full", &n, nrhs, &c_b20, &c_b20, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ zlaqge_(&n, &n, &a[1], &lda, &s[1], &s[n + 1], &
+ rowcnd, &colcnd, &amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using ZGESVX. */
+
+ s_copy(srnamc_1.srnamt, "ZGESVX", (ftnlen)32, (ftnlen)
+ 6);
+ zgesvx_(fact, trans, &n, nrhs, &a[1], &lda, &afac[1],
+ &lda, &iwork[1], equed, &s[1], &s[n + 1], &b[
+ 1], &lda, &x[1], &lda, &rcond, &rwork[1], &
+ rwork[*nrhs + 1], &work[1], &rwork[(*nrhs <<
+ 1) + 1], &info);
+
+/* Check the error code from ZGESVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "ZGESVX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+/* Compare RWORK(2*NRHS+1) from ZGESVX with the */
+/* computed reciprocal pivot growth factor RPVGRW */
+
+ if (info != 0) {
+ rpvgrw = zlantr_("M", "U", "N", &info, &info, &
+ afac[1], &lda, rdum);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = zlange_("M", &n, &info, &a[1], &lda,
+ rdum) / rpvgrw;
+ }
+ } else {
+ rpvgrw = zlantr_("M", "U", "N", &n, &n, &afac[1],
+ &lda, rdum);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = zlange_("M", &n, &n, &a[1], &lda,
+ rdum) / rpvgrw;
+ }
+ }
+/* Computing MAX */
+ d__2 = rwork[(*nrhs << 1) + 1];
+ result[6] = (d__1 = rpvgrw - rwork[(*nrhs << 1) + 1],
+ abs(d__1)) / max(d__2,rpvgrw) / dlamch_("E");
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &rwork[(*nrhs << 1) + 1],
+ result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ zget02_(trans, &n, &n, nrhs, &asav[1], &lda, &x[1]
+, &lda, &work[1], &lda, &rwork[(*nrhs <<
+ 1) + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ zget07_(trans, &n, nrhs, &asav[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &c_true, &rwork[*nrhs + 1], &result[3]
+);
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from ZGESVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___62.ciunit = *nout;
+ s_wsfe(&io___62);
+ do_fio(&c__1, "ZGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___63.ciunit = *nout;
+ s_wsfe(&io___63);
+ do_fio(&c__1, "ZGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L40: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___64.ciunit = *nout;
+ s_wsfe(&io___64);
+ do_fio(&c__1, "ZGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___65.ciunit = *nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, "ZGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___66.ciunit = *nout;
+ s_wsfe(&io___66);
+ do_fio(&c__1, "ZGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___67.ciunit = *nout;
+ s_wsfe(&io___67);
+ do_fio(&c__1, "ZGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___68.ciunit = *nout;
+ s_wsfe(&io___68);
+ do_fio(&c__1, "ZGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___69.ciunit = *nout;
+ s_wsfe(&io___69);
+ do_fio(&c__1, "ZGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+
+ }
+
+/* L50: */
+ }
+L60:
+ ;
+ }
+/* L70: */
+ }
+L80:
+ ;
+ }
+/* L90: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZDRVGE */
+
+} /* zdrvge_ */
diff --git a/TESTING/LIN/zdrvgex.c b/TESTING/LIN/zdrvgex.c
new file mode 100644
index 0000000..b06835a
--- /dev/null
+++ b/TESTING/LIN/zdrvgex.c
@@ -0,0 +1,1227 @@
+/* zdrvgex.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "memory_alloc.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublecomplex c_b20 = {0.,0.};
+static logical c_true = TRUE_;
+static integer c__6 = 6;
+static integer c__7 = 7;
+static doublereal c_b166 = 0.;
+
+/* Subroutine */ int zdrvge_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
+ doublecomplex *a, doublecomplex *afac, doublecomplex *asav,
+ doublecomplex *b, doublecomplex *bsav, doublecomplex *x,
+ doublecomplex *xact, doublereal *s, doublecomplex *work, doublereal *
+ rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char transs[1*3] = "N" "T" "C";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*4] = "N" "R" "C" "B";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
+ ", test(\002,i2,\002) =\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
+ "1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i2,\002"
+ ", test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
+ "1,\002', N=\002,i5,\002, type \002,i2,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ doublereal d__1, d__2;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ extern /* Subroutine */ int zebchvxx_(doublereal *, char *);
+ integer i__, k, n;
+ doublereal *errbnds_c__, *errbnds_n__;
+ integer k1, nb, in, kl, ku, nt, n_err_bnds__;
+ extern doublereal zla_rpvgrw__(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *);
+ integer lda;
+ char fact[1];
+ integer ioff, mode;
+ doublereal amax;
+ char path[3];
+ integer imat, info;
+ doublereal *berr;
+ char dist[1];
+ doublereal rdum[1], rpvgrw_svxx__;
+ char type__[1];
+ integer nrun, ifact, nfail, iseed[4], nfact;
+ extern doublereal dget06_(doublereal *, doublereal *);
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ doublereal rcond, roldc;
+ integer nimat;
+ doublereal roldi;
+ extern /* Subroutine */ int zget01_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, doublereal *,
+ doublereal *), zget02_(char *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *);
+ doublereal anorm;
+ integer itran;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+);
+ logical equil;
+ doublereal roldo;
+ extern /* Subroutine */ int zget07_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, logical *, doublereal *, doublereal *);
+ char trans[1];
+ integer izero, nerrs, lwork;
+ extern /* Subroutine */ int zgesv_(integer *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *, integer *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), aladhd_(integer *,
+ char *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ logical prefac;
+ doublereal colcnd, rcondc;
+ logical nofact;
+ integer iequed;
+ doublereal rcondi;
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum, anormi, rcondo, ainvnm;
+ extern /* Subroutine */ int zlaqge_(integer *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *
+, doublereal *, char *);
+ logical trfcon;
+ doublereal anormo, rowcnd;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), zgeequ_(
+ integer *, integer *, doublecomplex *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *)
+ , zgetrf_(integer *, integer *, doublecomplex *, integer *,
+ integer *, integer *), zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zgetri_(integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, integer *), zlarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *), zlaset_();
+ extern doublereal zlantr_(char *, char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ doublereal result[7];
+ extern /* Subroutine */ int zgesvx_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ char *, doublereal *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *, doublecomplex *, doublereal *, integer *);
+ doublereal rpvgrw;
+ extern /* Subroutine */ int zerrvx_(char *, integer *), zgesvxx_(
+ char *, char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, char *, doublereal *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *,
+ doublecomplex *, doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___55 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___62 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___63 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___64 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___65 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___66 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___67 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___68 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___69 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___75 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___76 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___77 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___78 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___79 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___80 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___81 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___82 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVGE tests the driver routines ZGESV, -SVX, and -SVXX. */
+
+/* Note that this file is used only when the XBLAS are available, */
+/* otherwise zdrvge.f defines this subroutine. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension (2*NMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*NRHS+NMAX) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "GE", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 11;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L80;
+ }
+
+/* Skip types 5, 6, or 7 if the matrix size is too small. */
+
+ zerot = imat >= 5 && imat <= 7;
+ if (zerot && n < imat - 4) {
+ goto L80;
+ }
+
+/* Set up parameters with ZLATB4 and generate a test matrix */
+/* with ZLATMS. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cndnum, dist);
+ rcondc = 1. / cndnum;
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cndnum, &
+ anorm, &kl, &ku, "No packing", &a[1], &lda, &work[1], &
+ info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, " ", &n, &n, &c_n1, &
+ c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L80;
+ }
+
+/* For types 5-7, zero one or more columns of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 5) {
+ izero = 1;
+ } else if (imat == 6) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+ if (imat < 7) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L20: */
+ }
+ } else {
+ i__3 = n - izero + 1;
+ zlaset_("Full", &n, &i__3, &c_b20, &c_b20, &a[ioff + 1], &
+ lda);
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ zlacpy_("Full", &n, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 4; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[iequed -
+ 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__3 = nfact;
+ for (ifact = 1; ifact <= i__3; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[ifact -
+ 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L60;
+ }
+ rcondo = 0.;
+ rcondi = 0.;
+
+ } else if (! nofact) {
+
+/* Compute the condition number for comparison with */
+/* the value returned by ZGESVX (FACT = 'N' reuses */
+/* the condition number from the previous iteration */
+/* with FACT = 'F'). */
+
+ zlacpy_("Full", &n, &n, &asav[1], &lda, &afac[1], &
+ lda);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ zgeequ_(&n, &n, &afac[1], &lda, &s[1], &s[n + 1],
+ &rowcnd, &colcnd, &amax, &info);
+ if (info == 0 && n > 0) {
+ if (lsame_(equed, "R"))
+ {
+ rowcnd = 0.;
+ colcnd = 1.;
+ } else if (lsame_(equed, "C")) {
+ rowcnd = 1.;
+ colcnd = 0.;
+ } else if (lsame_(equed, "B")) {
+ rowcnd = 0.;
+ colcnd = 0.;
+ }
+
+/* Equilibrate the matrix. */
+
+ zlaqge_(&n, &n, &afac[1], &lda, &s[1], &s[n +
+ 1], &rowcnd, &colcnd, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the non-equilibrated */
+/* system for use in ZGET04. */
+
+ if (equil) {
+ roldo = rcondo;
+ roldi = rcondi;
+ }
+
+/* Compute the 1-norm and infinity-norm of A. */
+
+ anormo = zlange_("1", &n, &n, &afac[1], &lda, &rwork[
+ 1]);
+ anormi = zlange_("I", &n, &n, &afac[1], &lda, &rwork[
+ 1]);
+
+/* Factor the matrix A. */
+
+ zgetrf_(&n, &n, &afac[1], &lda, &iwork[1], &info);
+
+/* Form the inverse of A. */
+
+ zlacpy_("Full", &n, &n, &afac[1], &lda, &a[1], &lda);
+ lwork = *nmax * max(3,*nrhs);
+ zgetri_(&n, &a[1], &lda, &iwork[1], &work[1], &lwork,
+ &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = zlange_("1", &n, &n, &a[1], &lda, &rwork[1]);
+ if (anormo <= 0. || ainvnm <= 0.) {
+ rcondo = 1.;
+ } else {
+ rcondo = 1. / anormo / ainvnm;
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ ainvnm = zlange_("I", &n, &n, &a[1], &lda, &rwork[1]);
+ if (anormi <= 0. || ainvnm <= 0.) {
+ rcondi = 1.;
+ } else {
+ rcondi = 1. / anormi / ainvnm;
+ }
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+ for (i__ = 1; i__ <= 7; ++i__) {
+ result[i__ - 1] = 0.;
+ }
+
+/* Do for each value of TRANS. */
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[
+ itran - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Restore the matrix A. */
+
+ zlacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ zlarhs_(path, xtype, "Full", trans, &n, &n, &kl, &ku,
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
+
+ if (nofact && itran == 1) {
+
+/* --- Test ZGESV --- */
+
+/* Compute the LU factorization of the matrix and */
+/* solve the system. */
+
+ zlacpy_("Full", &n, &n, &a[1], &lda, &afac[1], &
+ lda);
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "ZGESV ", (ftnlen)32, (
+ ftnlen)6);
+ zgesv_(&n, nrhs, &afac[1], &lda, &iwork[1], &x[1],
+ &lda, &info);
+
+/* Check error code from ZGESV . */
+
+ if (info != izero) {
+ alaerh_(path, "ZGESV ", &info, &izero, " ", &
+ n, &n, &c_n1, &c_n1, nrhs, &imat, &
+ nfail, &nerrs, nout);
+ goto L50;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &rwork[1], result);
+ nt = 1;
+ if (izero == 0) {
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[
+ 1], &lda);
+ zget02_("No transpose", &n, &n, nrhs, &a[1], &
+ lda, &x[1], &lda, &work[1], &lda, &
+ rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ nt = 3;
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___55.ciunit = *nout;
+ s_wsfe(&io___55);
+ do_fio(&c__1, "ZGESV ", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L30: */
+ }
+ nrun += nt;
+ }
+
+/* --- Test ZGESVX --- */
+
+ if (! prefac) {
+ zlaset_("Full", &n, &n, &c_b20, &c_b20, &afac[1],
+ &lda);
+ }
+ zlaset_("Full", &n, nrhs, &c_b20, &c_b20, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ zlaqge_(&n, &n, &a[1], &lda, &s[1], &s[n + 1], &
+ rowcnd, &colcnd, &amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using ZGESVX. */
+
+ s_copy(srnamc_1.srnamt, "ZGESVX", (ftnlen)32, (ftnlen)
+ 6);
+ zgesvx_(fact, trans, &n, nrhs, &a[1], &lda, &afac[1],
+ &lda, &iwork[1], equed, &s[1], &s[n + 1], &b[
+ 1], &lda, &x[1], &lda, &rcond, &rwork[1], &
+ rwork[*nrhs + 1], &work[1], &rwork[(*nrhs <<
+ 1) + 1], &info);
+
+/* Check the error code from ZGESVX. */
+
+ if (info == n + 1) {
+ goto L50;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "ZGESVX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L50;
+ }
+
+/* Compare RWORK(2*NRHS+1) from ZGESVX with the */
+/* computed reciprocal pivot growth factor RPVGRW */
+
+ if (info != 0) {
+ rpvgrw = zlantr_("M", "U", "N", &info, &info, &
+ afac[1], &lda, rdum);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = zlange_("M", &n, &info, &a[1], &lda,
+ rdum) / rpvgrw;
+ }
+ } else {
+ rpvgrw = zlantr_("M", "U", "N", &n, &n, &afac[1],
+ &lda, rdum);
+ if (rpvgrw == 0.) {
+ rpvgrw = 1.;
+ } else {
+ rpvgrw = zlange_("M", &n, &n, &a[1], &lda,
+ rdum) / rpvgrw;
+ }
+ }
+/* Computing MAX */
+ d__2 = rwork[(*nrhs << 1) + 1];
+ result[6] = (d__1 = rpvgrw - rwork[(*nrhs << 1) + 1],
+ abs(d__1)) / max(d__2,rpvgrw) / dlamch_("E");
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &rwork[(*nrhs << 1) + 1],
+ result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ zget02_(trans, &n, &n, nrhs, &asav[1], &lda, &x[1]
+, &lda, &work[1], &lda, &rwork[(*nrhs <<
+ 1) + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ zget07_(trans, &n, nrhs, &asav[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &c_true, &rwork[*nrhs + 1], &result[3]
+);
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from ZGESVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___62.ciunit = *nout;
+ s_wsfe(&io___62);
+ do_fio(&c__1, "ZGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___63.ciunit = *nout;
+ s_wsfe(&io___63);
+ do_fio(&c__1, "ZGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L40: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___64.ciunit = *nout;
+ s_wsfe(&io___64);
+ do_fio(&c__1, "ZGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___65.ciunit = *nout;
+ s_wsfe(&io___65);
+ do_fio(&c__1, "ZGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___66.ciunit = *nout;
+ s_wsfe(&io___66);
+ do_fio(&c__1, "ZGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___67.ciunit = *nout;
+ s_wsfe(&io___67);
+ do_fio(&c__1, "ZGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___68.ciunit = *nout;
+ s_wsfe(&io___68);
+ do_fio(&c__1, "ZGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___69.ciunit = *nout;
+ s_wsfe(&io___69);
+ do_fio(&c__1, "ZGESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+
+ }
+
+/* --- Test ZGESVXX --- */
+
+/* Restore the matrices A and B. */
+
+ zlacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
+ zlacpy_("Full", &n, nrhs, &bsav[1], &lda, &b[1], &lda);
+ if (! prefac) {
+ zlaset_("Full", &n, &n, &c_b166, &c_b166, &afac[1]
+, &lda);
+ }
+ zlaset_("Full", &n, nrhs, &c_b166, &c_b166, &x[1], &
+ lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT = 'F' and */
+/* EQUED = 'R', 'C', or 'B'. */
+
+ zlaqge_(&n, &n, &a[1], &lda, &s[1], &s[n + 1], &
+ rowcnd, &colcnd, &amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using ZGESVXX. */
+
+ s_copy(srnamc_1.srnamt, "ZGESVXX", (ftnlen)32, (
+ ftnlen)7);
+ n_err_bnds__ = 3;
+
+ dalloc3();
+
+ zgesvxx_(fact, trans, &n, nrhs, &a[1], &lda, &afac[1],
+ &lda, &iwork[1], equed, &s[1], &s[n + 1], &b[
+ 1], &lda, &x[1], &lda, &rcond, &rpvgrw_svxx__,
+ berr, &n_err_bnds__, errbnds_n__,
+ errbnds_c__, &c__0, &c_b166, &work[1], &rwork[
+ 1], &info);
+
+ free3();
+
+/* Check the error code from ZGESVXX. */
+
+ if (info == n + 1) {
+ goto L50;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "ZGESVXX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L50;
+ }
+
+/* Compare rpvgrw_svxx from ZGESVXX with the computed */
+/* reciprocal pivot growth factor RPVGRW */
+
+ if (info > 0 && info < n + 1) {
+ rpvgrw = zla_rpvgrw__(&n, &info, &a[1], &lda, &
+ afac[1], &lda);
+ } else {
+ rpvgrw = zla_rpvgrw__(&n, &n, &a[1], &lda, &afac[
+ 1], &lda);
+ }
+ result[6] = (d__1 = rpvgrw - rpvgrw_svxx__, abs(d__1))
+ / max(rpvgrw_svxx__,rpvgrw) / dlamch_("E");
+
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zget01_(&n, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &rwork[(*nrhs << 1) + 1],
+ result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ zget02_(trans, &n, &n, nrhs, &asav[1], &lda, &x[1]
+, &lda, &work[1], &lda, &rwork[(*nrhs <<
+ 1) + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ if (itran == 1) {
+ roldc = roldo;
+ } else {
+ roldc = roldi;
+ }
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+ } else {
+ trfcon = TRUE_;
+ }
+
+/* Compare RCOND from ZGESVXX with the computed value */
+/* in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ if (! trfcon) {
+ for (k = k1; k <= 7; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___75.ciunit = *nout;
+ s_wsfe(&io___75);
+ do_fio(&c__1, "ZGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___76.ciunit = *nout;
+ s_wsfe(&io___76);
+ do_fio(&c__1, "ZGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L45: */
+ }
+ nrun = nrun + 7 - k1;
+ } else {
+ if (result[0] >= *thresh && ! prefac) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___77.ciunit = *nout;
+ s_wsfe(&io___77);
+ do_fio(&c__1, "ZGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___78.ciunit = *nout;
+ s_wsfe(&io___78);
+ do_fio(&c__1, "ZGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__1, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___79.ciunit = *nout;
+ s_wsfe(&io___79);
+ do_fio(&c__1, "ZGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___80.ciunit = *nout;
+ s_wsfe(&io___80);
+ do_fio(&c__1, "ZGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__6, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[5], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+ if (result[6] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___81.ciunit = *nout;
+ s_wsfe(&io___81);
+ do_fio(&c__1, "ZGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___82.ciunit = *nout;
+ s_wsfe(&io___82);
+ do_fio(&c__1, "ZGESVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&c__7, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[6], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ ++nrun;
+ }
+
+ }
+
+L50:
+ ;
+ }
+L60:
+ ;
+ }
+/* L70: */
+ }
+L80:
+ ;
+ }
+/* L90: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+/* Test Error Bounds for ZGESVXX */
+ zebchvxx_(thresh, path);
+ return 0;
+
+/* End of ZDRVGE */
+
+} /* zdrvge_ */
diff --git a/TESTING/LIN/zdrvgt.c b/TESTING/LIN/zdrvgt.c
new file mode 100644
index 0000000..4fb6359
--- /dev/null
+++ b/TESTING/LIN/zdrvgt.c
@@ -0,0 +1,733 @@
+/* zdrvgt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static integer c__2 = 2;
+static doublereal c_b43 = 1.;
+static doublereal c_b44 = 0.;
+static doublecomplex c_b65 = {0.,0.};
+
+/* Subroutine */ int zdrvgt_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, doublecomplex *a,
+ doublecomplex *af, doublecomplex *b, doublecomplex *x, doublecomplex *
+ xact, doublecomplex *work, doublereal *rwork, integer *iwork, integer
+ *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 0,0,0,1 };
+ static char transs[1*3] = "N" "T" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
+ ", test \002,i2,\002, ratio = \002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', TRANS='\002,a"
+ "1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002, "
+ "ratio = \002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5, i__6[2];
+ doublereal d__1, d__2;
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k, m, n;
+ doublereal z__[3];
+ integer k1, in, kl, ku, ix, nt, lda;
+ char fact[1];
+ doublereal cond;
+ integer mode, koff, imat, info;
+ char path[3], dist[1], type__[1];
+ integer nrun, ifact, nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ doublereal rcond;
+ integer nimat;
+ doublereal anorm;
+ integer itran;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+);
+ char trans[1];
+ integer izero, nerrs;
+ extern /* Subroutine */ int zgtt01_(integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *), zgtt02_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *), zgtt05_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *);
+ logical zerot;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zgtsv_(integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, integer *), zlatb4_(char *, integer *, integer *,
+ integer *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), aladhd_(integer *,
+ char *), alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ doublereal rcondc, rcondi;
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *), alasvm_(char *, integer *, integer *,
+ integer *, integer *);
+ doublereal rcondo, anormi, ainvnm;
+ logical trfcon;
+ doublereal anormo;
+ extern /* Subroutine */ int zlagtm_(char *, integer *, integer *,
+ doublereal *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ integer *);
+ extern doublereal zlangt_(char *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *);
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dzasum_(integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatms_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublecomplex *, integer *, doublecomplex *,
+ integer *), zlarnv_(integer *, integer *,
+ integer *, doublecomplex *);
+ doublereal result[6];
+ extern /* Subroutine */ int zgttrf_(integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ integer *), zgttrs_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *), zerrvx_(char *,
+ integer *), zgtsvx_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, doublecomplex *,
+ doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___46 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___47 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVGT tests ZGTSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*4) */
+
+/* AF (workspace) COMPLEX*16 array, dimension (NMAX*4) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
+
+/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --af;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "GT", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+/* Computing MAX */
+ i__2 = n - 1;
+ m = max(i__2,0);
+ lda = max(1,n);
+ nimat = 12;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L130;
+ }
+
+/* Set up parameters with ZLATB4. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cond, dist);
+
+ zerot = imat >= 8 && imat <= 10;
+ if (imat <= 6) {
+
+/* Types 1-6: generate matrices of known condition number. */
+
+/* Computing MAX */
+ i__3 = 2 - ku, i__4 = 3 - max(1,n);
+ koff = max(i__3,i__4);
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
+ &anorm, &kl, &ku, "Z", &af[koff], &c__3, &work[1], &
+ info);
+
+/* Check the error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, " ", &n, &n, &kl, &
+ ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L130;
+ }
+ izero = 0;
+
+ if (n > 1) {
+ i__3 = n - 1;
+ zcopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
+ i__3 = n - 1;
+ zcopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
+ }
+ zcopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
+ } else {
+
+/* Types 7-12: generate tridiagonal matrices with */
+/* unknown condition numbers. */
+
+ if (! zerot || ! dotype[7]) {
+
+/* Generate a matrix with elements from [-1,1]. */
+
+ i__3 = n + (m << 1);
+ zlarnv_(&c__2, iseed, &i__3, &a[1]);
+ if (anorm != 1.) {
+ i__3 = n + (m << 1);
+ zdscal_(&i__3, &anorm, &a[1], &c__1);
+ }
+ } else if (izero > 0) {
+
+/* Reuse the last matrix by copying back the zeroed out */
+/* elements. */
+
+ if (izero == 1) {
+ i__3 = n;
+ a[i__3].r = z__[1], a[i__3].i = 0.;
+ if (n > 1) {
+ a[1].r = z__[2], a[1].i = 0.;
+ }
+ } else if (izero == n) {
+ i__3 = n * 3 - 2;
+ a[i__3].r = z__[0], a[i__3].i = 0.;
+ i__3 = (n << 1) - 1;
+ a[i__3].r = z__[1], a[i__3].i = 0.;
+ } else {
+ i__3 = (n << 1) - 2 + izero;
+ a[i__3].r = z__[0], a[i__3].i = 0.;
+ i__3 = n - 1 + izero;
+ a[i__3].r = z__[1], a[i__3].i = 0.;
+ i__3 = izero;
+ a[i__3].r = z__[2], a[i__3].i = 0.;
+ }
+ }
+
+/* If IMAT > 7, set one column of the matrix to 0. */
+
+ if (! zerot) {
+ izero = 0;
+ } else if (imat == 8) {
+ izero = 1;
+ i__3 = n;
+ z__[1] = a[i__3].r;
+ i__3 = n;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ if (n > 1) {
+ z__[2] = a[1].r;
+ a[1].r = 0., a[1].i = 0.;
+ }
+ } else if (imat == 9) {
+ izero = n;
+ i__3 = n * 3 - 2;
+ z__[0] = a[i__3].r;
+ i__3 = (n << 1) - 1;
+ z__[1] = a[i__3].r;
+ i__3 = n * 3 - 2;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ i__3 = (n << 1) - 1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ } else {
+ izero = (n + 1) / 2;
+ i__3 = n - 1;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = (n << 1) - 2 + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ i__4 = n - 1 + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ i__4 = i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L20: */
+ }
+ i__3 = n * 3 - 2;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ i__3 = (n << 1) - 1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ }
+ }
+
+ for (ifact = 1; ifact <= 2; ++ifact) {
+ if (ifact == 1) {
+ *(unsigned char *)fact = 'F';
+ } else {
+ *(unsigned char *)fact = 'N';
+ }
+
+/* Compute the condition number for comparison with */
+/* the value returned by ZGTSVX. */
+
+ if (zerot) {
+ if (ifact == 1) {
+ goto L120;
+ }
+ rcondo = 0.;
+ rcondi = 0.;
+
+ } else if (ifact == 1) {
+ i__3 = n + (m << 1);
+ zcopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
+
+/* Compute the 1-norm and infinity-norm of A. */
+
+ anormo = zlangt_("1", &n, &a[1], &a[m + 1], &a[n + m + 1]);
+ anormi = zlangt_("I", &n, &a[1], &a[m + 1], &a[n + m + 1]);
+
+/* Factor the matrix A. */
+
+ zgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (
+ m << 1) + 1], &iwork[1], &info);
+
+/* Use ZGTTRS to solve for one column at a time of */
+/* inv(A), computing the maximum column sum as we go. */
+
+ ainvnm = 0.;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__5 = j;
+ x[i__5].r = 0., x[i__5].i = 0.;
+/* L30: */
+ }
+ i__4 = i__;
+ x[i__4].r = 1., x[i__4].i = 0.;
+ zgttrs_("No transpose", &n, &c__1, &af[1], &af[m + 1],
+ &af[n + m + 1], &af[n + (m << 1) + 1], &
+ iwork[1], &x[1], &lda, &info);
+/* Computing MAX */
+ d__1 = ainvnm, d__2 = dzasum_(&n, &x[1], &c__1);
+ ainvnm = max(d__1,d__2);
+/* L40: */
+ }
+
+/* Compute the 1-norm condition number of A. */
+
+ if (anormo <= 0. || ainvnm <= 0.) {
+ rcondo = 1.;
+ } else {
+ rcondo = 1. / anormo / ainvnm;
+ }
+
+/* Use ZGTTRS to solve for one column at a time of */
+/* inv(A'), computing the maximum column sum as we go. */
+
+ ainvnm = 0.;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__5 = j;
+ x[i__5].r = 0., x[i__5].i = 0.;
+/* L50: */
+ }
+ i__4 = i__;
+ x[i__4].r = 1., x[i__4].i = 0.;
+ zgttrs_("Conjugate transpose", &n, &c__1, &af[1], &af[
+ m + 1], &af[n + m + 1], &af[n + (m << 1) + 1],
+ &iwork[1], &x[1], &lda, &info);
+/* Computing MAX */
+ d__1 = ainvnm, d__2 = dzasum_(&n, &x[1], &c__1);
+ ainvnm = max(d__1,d__2);
+/* L60: */
+ }
+
+/* Compute the infinity-norm condition number of A. */
+
+ if (anormi <= 0. || ainvnm <= 0.) {
+ rcondi = 1.;
+ } else {
+ rcondi = 1. / anormi / ainvnm;
+ }
+ }
+
+ for (itran = 1; itran <= 3; ++itran) {
+ *(unsigned char *)trans = *(unsigned char *)&transs[itran
+ - 1];
+ if (itran == 1) {
+ rcondc = rcondo;
+ } else {
+ rcondc = rcondi;
+ }
+
+/* Generate NRHS random solution vectors. */
+
+ ix = 1;
+ i__3 = *nrhs;
+ for (j = 1; j <= i__3; ++j) {
+ zlarnv_(&c__2, iseed, &n, &xact[ix]);
+ ix += lda;
+/* L70: */
+ }
+
+/* Set the right hand side. */
+
+ zlagtm_(trans, &n, nrhs, &c_b43, &a[1], &a[m + 1], &a[n +
+ m + 1], &xact[1], &lda, &c_b44, &b[1], &lda);
+
+ if (ifact == 2 && itran == 1) {
+
+/* --- Test ZGTSV --- */
+
+/* Solve the system using Gaussian elimination with */
+/* partial pivoting. */
+
+ i__3 = n + (m << 1);
+ zcopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
+
+ s_copy(srnamc_1.srnamt, "ZGTSV ", (ftnlen)32, (ftnlen)
+ 6);
+ zgtsv_(&n, nrhs, &af[1], &af[m + 1], &af[n + m + 1], &
+ x[1], &lda, &info);
+
+/* Check error code from ZGTSV . */
+
+ if (info != izero) {
+ alaerh_(path, "ZGTSV ", &info, &izero, " ", &n, &
+ n, &c__1, &c__1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ }
+ nt = 1;
+ if (izero == 0) {
+
+/* Check residual of computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
+ lda);
+ zgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n +
+ m + 1], &x[1], &lda, &work[1], &lda, &
+ rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 2; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "ZGTSV ", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + nt - 1;
+ }
+
+/* --- Test ZGTSVX --- */
+
+ if (ifact > 1) {
+
+/* Initialize AF to zero. */
+
+ i__3 = n * 3 - 2;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ af[i__4].r = 0., af[i__4].i = 0.;
+/* L90: */
+ }
+ }
+ zlaset_("Full", &n, nrhs, &c_b65, &c_b65, &x[1], &lda);
+
+/* Solve the system and compute the condition number and */
+/* error bounds using ZGTSVX. */
+
+ s_copy(srnamc_1.srnamt, "ZGTSVX", (ftnlen)32, (ftnlen)6);
+ zgtsvx_(fact, trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m
+ + 1], &af[1], &af[m + 1], &af[n + m + 1], &af[n +
+ (m << 1) + 1], &iwork[1], &b[1], &lda, &x[1], &
+ lda, &rcond, &rwork[1], &rwork[*nrhs + 1], &work[
+ 1], &rwork[(*nrhs << 1) + 1], &info);
+
+/* Check the error code from ZGTSVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__6[0] = 1, a__1[0] = fact;
+ i__6[1] = 1, a__1[1] = trans;
+ s_cat(ch__1, a__1, i__6, &c__2, (ftnlen)2);
+ alaerh_(path, "ZGTSVX", &info, &izero, ch__1, &n, &n,
+ &c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+
+ if (ifact >= 2) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &
+ af[m + 1], &af[n + m + 1], &af[n + (m << 1) +
+ 1], &iwork[1], &work[1], &lda, &rwork[1],
+ result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+ if (info == 0) {
+ trfcon = FALSE_;
+
+/* Check residual of computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ zgtt02_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
+ 1], &x[1], &lda, &work[1], &lda, &rwork[1], &
+ result[1]);
+
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* Check the error bounds from iterative refinement. */
+
+ zgtt05_(trans, &n, nrhs, &a[1], &a[m + 1], &a[n + m +
+ 1], &b[1], &lda, &x[1], &lda, &xact[1], &lda,
+ &rwork[1], &rwork[*nrhs + 1], &result[3]);
+ nt = 5;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = k1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___46.ciunit = *nout;
+ s_wsfe(&io___46);
+ do_fio(&c__1, "ZGTSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L100: */
+ }
+
+/* Check the reciprocal of the condition number. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+ if (result[5] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___47.ciunit = *nout;
+ s_wsfe(&io___47);
+ do_fio(&c__1, "ZGTSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ nrun = nrun + nt - k1 + 2;
+
+/* L110: */
+ }
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZDRVGT */
+
+} /* zdrvgt_ */
diff --git a/TESTING/LIN/zdrvhe.c b/TESTING/LIN/zdrvhe.c
new file mode 100644
index 0000000..88dea8d
--- /dev/null
+++ b/TESTING/LIN/zdrvhe.c
@@ -0,0 +1,693 @@
+/* zdrvhe.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublecomplex c_b50 = {0.,0.};
+
+/* Subroutine */ int zdrvhe_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
+ doublecomplex *a, doublecomplex *afac, doublecomplex *ainv,
+ doublecomplex *b, doublecomplex *x, doublecomplex *xact,
+ doublecomplex *work, doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char facts[1*2] = "F" "N";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002,"
+ " ratio =\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5, i__6[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, k1, nb, in, kl, ku, nt, lda;
+ char fact[1];
+ integer ioff, mode, imat, info;
+ char path[3], dist[1], uplo[1], type__[1];
+ integer nrun, ifact, nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ integer nbmin;
+ doublereal rcond;
+ integer nimat;
+ extern /* Subroutine */ int zhet01_(char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *);
+ doublereal anorm;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+);
+ integer iuplo, izero, nerrs, lwork;
+ extern /* Subroutine */ int zhesv_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *), zpot02_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+), zpot05_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), aladhd_(integer *,
+ char *), alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ doublereal rcondc;
+ extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int zlaipd_(integer *, doublecomplex *, integer *,
+ integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), zhetrf_(char *,
+ integer *, doublecomplex *, integer *, integer *, doublecomplex *
+, integer *, integer *), zhetri_(char *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), zlarhs_(char *,
+ char *, char *, char *, integer *, integer *, integer *, integer *
+, integer *, doublecomplex *, integer *, doublecomplex *, integer
+ *, doublecomplex *, integer *, integer *, integer *), zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatms_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublecomplex *, integer *, doublecomplex *,
+ integer *);
+ doublereal result[6];
+ extern /* Subroutine */ int zhesvx_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, doublecomplex *,
+ integer *, doublereal *, integer *), zerrvx_(char
+ *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVHE tests the driver routines ZHESV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(2,NRHS)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ *(unsigned char *)path = 'Z';
+ s_copy(path + 1, "HE", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+/* Computing MAX */
+ i__1 = *nmax << 1, i__2 = *nmax * *nrhs;
+ lwork = max(i__1,i__2);
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 10;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L170;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L170;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Set up parameters with ZLATB4 and generate a test matrix */
+/* with ZLATMS. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
+ &info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L160;
+ }
+
+/* For types 3-6, zero one or more rows and columns of the */
+/* matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * lda;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ ioff = 0;
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0., a[i__5].i = 0.;
+/* L60: */
+ }
+ ioff += lda;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0., a[i__5].i = 0.;
+/* L80: */
+ }
+ ioff += lda;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ i__3 = lda + 1;
+ zlaipd_(&n, &a[1], &i__3, &c__0);
+
+ for (ifact = 1; ifact <= 2; ++ifact) {
+
+/* Do first for FACT = 'F', then for other values. */
+
+ *(unsigned char *)fact = *(unsigned char *)&facts[ifact -
+ 1];
+
+/* Compute the condition number for comparison with */
+/* the value returned by ZHESVX. */
+
+ if (zerot) {
+ if (ifact == 1) {
+ goto L150;
+ }
+ rcondc = 0.;
+
+ } else if (ifact == 1) {
+
+/* Compute the 1-norm of A. */
+
+ anorm = zlanhe_("1", uplo, &n, &a[1], &lda, &rwork[1]);
+
+/* Factor the matrix A. */
+
+ zlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ zhetrf_(uplo, &n, &afac[1], &lda, &iwork[1], &work[1],
+ &lwork, &info);
+
+/* Compute inv(A) and take its norm. */
+
+ zlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
+ zhetri_(uplo, &n, &ainv[1], &lda, &iwork[1], &work[1],
+ &info);
+ ainvnm = zlanhe_("1", uplo, &n, &ainv[1], &lda, &
+ rwork[1]);
+
+/* Compute the 1-norm condition number of A. */
+
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondc = 1.;
+ } else {
+ rcondc = 1. / anorm / ainvnm;
+ }
+ }
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (ftnlen)6);
+ zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, nrhs, &
+ a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
+ info);
+ *(unsigned char *)xtype = 'C';
+
+/* --- Test ZHESV --- */
+
+ if (ifact == 2) {
+ zlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
+
+/* Factor the matrix and solve the system using ZHESV. */
+
+ s_copy(srnamc_1.srnamt, "ZHESV ", (ftnlen)32, (ftnlen)
+ 6);
+ zhesv_(uplo, &n, nrhs, &afac[1], &lda, &iwork[1], &x[
+ 1], &lda, &work[1], &lwork, &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from ZHESV . */
+
+ if (info != k) {
+ alaerh_(path, "ZHESV ", &info, &k, uplo, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L120;
+ } else if (info != 0) {
+ goto L120;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zhet01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &iwork[
+ 1], &ainv[1], &lda, &rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ zpot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda, &
+ work[1], &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "ZHESV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+L120:
+ ;
+ }
+
+/* --- Test ZHESVX --- */
+
+ if (ifact == 2) {
+ zlaset_(uplo, &n, &n, &c_b50, &c_b50, &afac[1], &lda);
+ }
+ zlaset_("Full", &n, nrhs, &c_b50, &c_b50, &x[1], &lda);
+
+/* Solve the system and compute the condition number and */
+/* error bounds using ZHESVX. */
+
+ s_copy(srnamc_1.srnamt, "ZHESVX", (ftnlen)32, (ftnlen)6);
+ zhesvx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1], &lda,
+ &iwork[1], &b[1], &lda, &x[1], &lda, &rcond, &
+ rwork[1], &rwork[*nrhs + 1], &work[1], &lwork, &
+ rwork[(*nrhs << 1) + 1], &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L130:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L130;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L130;
+ }
+ }
+
+/* Check the error code from ZHESVX. */
+
+ if (info != k) {
+/* Writing concatenation */
+ i__6[0] = 1, a__1[0] = fact;
+ i__6[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__6, &c__2, (ftnlen)2);
+ alaerh_(path, "ZHESVX", &info, &k, ch__1, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L150;
+ }
+
+ if (info == 0) {
+ if (ifact >= 2) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zhet01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &ainv[1], &lda, &rwork[(*nrhs <<
+ 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ zpot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda, &
+ work[1], &lda, &rwork[(*nrhs << 1) + 1], &
+ result[1]);
+
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* Check the error bounds from iterative refinement. */
+
+ zpot05_(uplo, &n, nrhs, &a[1], &lda, &b[1], &lda, &x[
+ 1], &lda, &xact[1], &lda, &rwork[1], &rwork[*
+ nrhs + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from ZHESVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "ZHESVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L140: */
+ }
+ nrun = nrun + 7 - k1;
+
+L150:
+ ;
+ }
+
+L160:
+ ;
+ }
+L170:
+ ;
+ }
+/* L180: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZDRVHE */
+
+} /* zdrvhe_ */
diff --git a/TESTING/LIN/zdrvhp.c b/TESTING/LIN/zdrvhp.c
new file mode 100644
index 0000000..0998a81
--- /dev/null
+++ b/TESTING/LIN/zdrvhp.c
@@ -0,0 +1,698 @@
+/* zdrvhp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublecomplex c_b64 = {0.,0.};
+
+/* Subroutine */ int zdrvhp_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
+ doublecomplex *a, doublecomplex *afac, doublecomplex *ainv,
+ doublecomplex *b, doublecomplex *x, doublecomplex *xact,
+ doublecomplex *work, doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char facts[1*2] = "F" "N";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002,"
+ " ratio =\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5, i__6[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, k1, nb, in, kl, ku, nt, lda, npp;
+ char fact[1];
+ integer ioff, mode, imat, info;
+ char path[3], dist[1], uplo[1], type__[1];
+ integer nrun, ifact, nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ integer nbmin;
+ doublereal rcond;
+ integer nimat;
+ doublereal anorm;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+), zhpt01_(char *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *);
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int zppt02_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *), zppt05_(char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *);
+ logical zerot;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ char xtype[1];
+ extern /* Subroutine */ int zhpsv_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *), zlatb4_(char *, integer *, integer *, integer *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ char *), aladhd_(integer *, char *), alaerh_(char *, char *, integer *, integer *, char *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *);
+ doublereal rcondc;
+ char packit[1];
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int zlaipd_(integer *, doublecomplex *, integer *,
+ integer *);
+ doublereal ainvnm;
+ extern doublereal zlanhp_(char *, char *, integer *, doublecomplex *,
+ doublereal *);
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *), zlarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *), zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatms_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublecomplex *, integer *, doublecomplex *,
+ integer *);
+ doublereal result[6];
+ extern /* Subroutine */ int zhptrf_(char *, integer *, doublecomplex *,
+ integer *, integer *), zhptri_(char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zerrvx_(char *, integer *), zhpsvx_(char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, doublecomplex *,
+ doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVHP tests the driver routines ZHPSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AFAC (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AINV (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(2,NRHS)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ *(unsigned char *)path = 'Z';
+ s_copy(path + 1, "HP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ npp = n * (n + 1) / 2;
+ *(unsigned char *)xtype = 'N';
+ nimat = 10;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L170;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L170;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ if (iuplo == 1) {
+ *(unsigned char *)uplo = 'U';
+ *(unsigned char *)packit = 'C';
+ } else {
+ *(unsigned char *)uplo = 'L';
+ *(unsigned char *)packit = 'R';
+ }
+
+/* Set up parameters with ZLATB4 and generate a test matrix */
+/* with ZLATMS. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
+ 1], &info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L160;
+ }
+
+/* For types 3-6, zero one or more rows and columns of the */
+/* matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * izero / 2;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff += i__;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff = ioff + n - i__;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ ioff = 0;
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0., a[i__5].i = 0.;
+/* L60: */
+ }
+ ioff += j;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows and columns to zero. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0., a[i__5].i = 0.;
+/* L80: */
+ }
+ ioff = ioff + n - j;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ if (iuplo == 1) {
+ zlaipd_(&n, &a[1], &c__2, &c__1);
+ } else {
+ zlaipd_(&n, &a[1], &n, &c_n1);
+ }
+
+ for (ifact = 1; ifact <= 2; ++ifact) {
+
+/* Do first for FACT = 'F', then for other values. */
+
+ *(unsigned char *)fact = *(unsigned char *)&facts[ifact -
+ 1];
+
+/* Compute the condition number for comparison with */
+/* the value returned by ZHPSVX. */
+
+ if (zerot) {
+ if (ifact == 1) {
+ goto L150;
+ }
+ rcondc = 0.;
+
+ } else if (ifact == 1) {
+
+/* Compute the 1-norm of A. */
+
+ anorm = zlanhp_("1", uplo, &n, &a[1], &rwork[1]);
+
+/* Factor the matrix A. */
+
+ zcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ zhptrf_(uplo, &n, &afac[1], &iwork[1], &info);
+
+/* Compute inv(A) and take its norm. */
+
+ zcopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
+ zhptri_(uplo, &n, &ainv[1], &iwork[1], &work[1], &
+ info);
+ ainvnm = zlanhp_("1", uplo, &n, &ainv[1], &rwork[1]);
+
+/* Compute the 1-norm condition number of A. */
+
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondc = 1.;
+ } else {
+ rcondc = 1. / anorm / ainvnm;
+ }
+ }
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (ftnlen)6);
+ zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, nrhs, &
+ a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
+ info);
+ *(unsigned char *)xtype = 'C';
+
+/* --- Test ZHPSV --- */
+
+ if (ifact == 2) {
+ zcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
+
+/* Factor the matrix and solve the system using ZHPSV. */
+
+ s_copy(srnamc_1.srnamt, "ZHPSV ", (ftnlen)32, (ftnlen)
+ 6);
+ zhpsv_(uplo, &n, nrhs, &afac[1], &iwork[1], &x[1], &
+ lda, &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from ZHPSV . */
+
+ if (info != k) {
+ alaerh_(path, "ZHPSV ", &info, &k, uplo, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L120;
+ } else if (info != 0) {
+ goto L120;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zhpt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &ainv[1]
+, &lda, &rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ zppt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[1],
+ &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "ZHPSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+L120:
+ ;
+ }
+
+/* --- Test ZHPSVX --- */
+
+ if (ifact == 2 && npp > 0) {
+ zlaset_("Full", &npp, &c__1, &c_b64, &c_b64, &afac[1],
+ &npp);
+ }
+ zlaset_("Full", &n, nrhs, &c_b64, &c_b64, &x[1], &lda);
+
+/* Solve the system and compute the condition number and */
+/* error bounds using ZHPSVX. */
+
+ s_copy(srnamc_1.srnamt, "ZHPSVX", (ftnlen)32, (ftnlen)6);
+ zhpsvx_(fact, uplo, &n, nrhs, &a[1], &afac[1], &iwork[1],
+ &b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &
+ rwork[*nrhs + 1], &work[1], &rwork[(*nrhs << 1) +
+ 1], &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L130:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L130;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L130;
+ }
+ }
+
+/* Check the error code from ZHPSVX. */
+
+ if (info != k) {
+/* Writing concatenation */
+ i__6[0] = 1, a__1[0] = fact;
+ i__6[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__6, &c__2, (ftnlen)2);
+ alaerh_(path, "ZHPSVX", &info, &k, ch__1, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L150;
+ }
+
+ if (info == 0) {
+ if (ifact >= 2) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zhpt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &
+ ainv[1], &lda, &rwork[(*nrhs << 1) + 1],
+ result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ zppt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[1],
+ &lda, &rwork[(*nrhs << 1) + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* Check the error bounds from iterative refinement. */
+
+ zppt05_(uplo, &n, nrhs, &a[1], &b[1], &lda, &x[1], &
+ lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs
+ + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from ZHPSVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "ZHPSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L140: */
+ }
+ nrun = nrun + 7 - k1;
+
+L150:
+ ;
+ }
+
+L160:
+ ;
+ }
+L170:
+ ;
+ }
+/* L180: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZDRVHP */
+
+} /* zdrvhp_ */
diff --git a/TESTING/LIN/zdrvls.c b/TESTING/LIN/zdrvls.c
new file mode 100644
index 0000000..b713b31
--- /dev/null
+++ b/TESTING/LIN/zdrvls.c
@@ -0,0 +1,857 @@
+/* zdrvls.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, iounit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static doublecomplex c_b2 = {0.,0.};
+static integer c__9 = 9;
+static integer c__25 = 25;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublereal c_b91 = -1.;
+
+/* Subroutine */ int zdrvls_(logical *dotype, integer *nm, integer *mval,
+ integer *nn, integer *nval, integer *nns, integer *nsval, integer *
+ nnb, integer *nbval, integer *nxval, doublereal *thresh, logical *
+ tsterr, doublecomplex *a, doublecomplex *copya, doublecomplex *b,
+ doublecomplex *copyb, doublecomplex *c__, doublereal *s, doublereal *
+ copys, doublecomplex *work, doublereal *rwork, integer *iwork,
+ integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(\002 TRANS='\002,a1,\002', M=\002,i5,\002, N"
+ "=\002,i5,\002, NRHS=\002,i4,\002, NB=\002,i4,\002, type\002,i2"
+ ",\002, test(\002,i2,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, NRHS="
+ "\002,i4,\002, NB=\002,i4,\002, type\002,i2,\002, test(\002,i2"
+ ",\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, m, n, nb, im, in, lda, ldb, inb;
+ doublereal eps;
+ integer ins, info;
+ char path[3];
+ integer rank, nrhs, nrun;
+ extern /* Subroutine */ int alahd_(integer *, char *);
+ integer nfail, iseed[4], crank, irank;
+ doublereal rcond;
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ integer itran, mnmin, ncols;
+ doublereal norma, normb;
+ extern /* Subroutine */ int zgels_(char *, integer *, integer *, integer *
+, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *), daxpy_(integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *),
+ zgemm_(char *, char *, integer *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ char trans[1];
+ integer nerrs, itype, lwork;
+ extern doublereal zqrt12_(integer *, integer *, doublecomplex *, integer *
+, doublereal *, doublecomplex *, integer *, doublereal *),
+ zqrt14_(char *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zqrt13_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *, integer *), zqrt15_(
+ integer *, integer *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublecomplex *, integer *);
+ integer nrows;
+ extern doublereal zqrt17_(char *, integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ integer lwlsy;
+ extern /* Subroutine */ int zqrt16_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ integer iscale;
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *), alasvm_(char *, integer *, integer *,
+ integer *, integer *), zgelsd_(integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, integer *, doublecomplex *, integer *
+, doublereal *, integer *, integer *), xlaenv_(integer *, integer
+ *);
+ integer ldwork;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zgelss_(integer *, integer *, integer *, doublecomplex *, integer
+ *, doublecomplex *, integer *, doublereal *, doublereal *,
+ integer *, doublecomplex *, integer *, doublereal *, integer *),
+ zgelsx_(integer *, integer *, integer *, doublecomplex *, integer
+ *, doublecomplex *, integer *, integer *, doublereal *, integer *,
+ doublecomplex *, doublereal *, integer *), zgelsy_(integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *, doublereal *, integer *, doublecomplex *,
+ integer *, doublereal *, integer *);
+ doublereal result[18];
+ extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *,
+ doublecomplex *), zerrls_(char *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___39 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVLS tests the least squares driver routines ZGELS, CGELSX, CGELSS, */
+/* ZGELSY and CGELSD. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+/* The matrix of type j is generated as follows: */
+/* j=1: A = U*D*V where U and V are random unitary matrices */
+/* and D has random entries (> 0.1) taken from a uniform */
+/* distribution (0,1). A is full rank. */
+/* j=2: The same of 1, but A is scaled up. */
+/* j=3: The same of 1, but A is scaled down. */
+/* j=4: A = U*D*V where U and V are random unitary matrices */
+/* and D has 3*min(M,N)/4 random entries (> 0.1) taken */
+/* from a uniform distribution (0,1) and the remaining */
+/* entries set to 0. A is rank-deficient. */
+/* j=5: The same of 4, but A is scaled up. */
+/* j=6: The same of 5, but A is scaled down. */
+
+/* NM (input) INTEGER */
+/* The number of values of M contained in the vector MVAL. */
+
+/* MVAL (input) INTEGER array, dimension (NM) */
+/* The values of the matrix row dimension M. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix column dimension N. */
+
+/* NNB (input) INTEGER */
+/* The number of values of NB and NX contained in the */
+/* vectors NBVAL and NXVAL. The blocking parameters are used */
+/* in pairs (NB,NX). */
+
+/* NBVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the blocksize NB. */
+
+/* NXVAL (input) INTEGER array, dimension (NNB) */
+/* The values of the crossover point NX. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right hand sides NRHS. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) */
+/* where MMAX is the maximum value of M in MVAL and NMAX is the */
+/* maximum value of N in NVAL. */
+
+/* COPYA (workspace) COMPLEX*16 array, dimension (MMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (MMAX*NSMAX) */
+/* where MMAX is the maximum value of M in MVAL and NSMAX is the */
+/* maximum value of NRHS in NSVAL. */
+
+/* COPYB (workspace) COMPLEX*16 array, dimension (MMAX*NSMAX) */
+
+/* C (workspace) COMPLEX*16 array, dimension (MMAX*NSMAX) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* COPYS (workspace) DOUBLE PRECISION array, dimension */
+/* (min(MMAX,NMAX)) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (MMAX*NMAX + 4*NMAX + MMAX). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (5*NMAX-1) */
+
+/* IWORK (workspace) INTEGER array, dimension (15*NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --copys;
+ --s;
+ --c__;
+ --copyb;
+ --b;
+ --copya;
+ --a;
+ --nxval;
+ --nbval;
+ --nsval;
+ --nval;
+ --mval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "LS", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = dlamch_("Epsilon");
+
+/* Threshold for rank estimation */
+
+ rcond = sqrt(eps) - (sqrt(eps) - eps) / 2;
+
+/* Test the error exits */
+
+ xlaenv_(&c__9, &c__25);
+ if (*tsterr) {
+ zerrls_(path, nout);
+ }
+
+/* Print the header if NM = 0 or NN = 0 and THRESH = 0. */
+
+ if ((*nm == 0 || *nn == 0) && *thresh == 0.) {
+ alahd_(nout, path);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nm;
+ for (im = 1; im <= i__1; ++im) {
+ m = mval[im];
+ lda = max(1,m);
+
+ i__2 = *nn;
+ for (in = 1; in <= i__2; ++in) {
+ n = nval[in];
+ mnmin = min(m,n);
+/* Computing MAX */
+ i__3 = max(1,m);
+ ldb = max(i__3,n);
+
+ i__3 = *nns;
+ for (ins = 1; ins <= i__3; ++ins) {
+ nrhs = nsval[ins];
+/* Computing MAX */
+ i__4 = 1, i__5 = (m + nrhs) * (n + 2), i__4 = max(i__4,i__5),
+ i__5 = (n + nrhs) * (m + 2), i__4 = max(i__4,i__5),
+ i__5 = m * n + (mnmin << 2) + max(m,n), i__4 = max(
+ i__4,i__5), i__5 = (n << 1) + m;
+ lwork = max(i__4,i__5);
+
+ for (irank = 1; irank <= 2; ++irank) {
+ for (iscale = 1; iscale <= 3; ++iscale) {
+ itype = (irank - 1) * 3 + iscale;
+ if (! dotype[itype]) {
+ goto L100;
+ }
+
+ if (irank == 1) {
+
+/* Test ZGELS */
+
+/* Generate a matrix of scaling type ISCALE */
+
+ zqrt13_(&iscale, &m, &n, ©a[1], &lda, &norma,
+ iseed);
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__3, &nxval[inb]);
+
+ for (itran = 1; itran <= 2; ++itran) {
+ if (itran == 1) {
+ *(unsigned char *)trans = 'N';
+ nrows = m;
+ ncols = n;
+ } else {
+ *(unsigned char *)trans = 'C';
+ nrows = n;
+ ncols = m;
+ }
+ ldwork = max(1,ncols);
+
+/* Set up a consistent rhs */
+
+ if (ncols > 0) {
+ i__5 = ncols * nrhs;
+ zlarnv_(&c__2, iseed, &i__5, &work[1])
+ ;
+ i__5 = ncols * nrhs;
+ d__1 = 1. / (doublereal) ncols;
+ zdscal_(&i__5, &d__1, &work[1], &c__1)
+ ;
+ }
+ zgemm_(trans, "No transpose", &nrows, &
+ nrhs, &ncols, &c_b1, ©a[1], &
+ lda, &work[1], &ldwork, &c_b2, &b[
+ 1], &ldb);
+ zlacpy_("Full", &nrows, &nrhs, &b[1], &
+ ldb, ©b[1], &ldb);
+
+/* Solve LS or overdetermined system */
+
+ if (m > 0 && n > 0) {
+ zlacpy_("Full", &m, &n, ©a[1], &
+ lda, &a[1], &lda);
+ zlacpy_("Full", &nrows, &nrhs, ©b[
+ 1], &ldb, &b[1], &ldb);
+ }
+ s_copy(srnamc_1.srnamt, "ZGELS ", (ftnlen)
+ 32, (ftnlen)6);
+ zgels_(trans, &m, &n, &nrhs, &a[1], &lda,
+ &b[1], &ldb, &work[1], &lwork, &
+ info);
+
+ if (info != 0) {
+ alaerh_(path, "ZGELS ", &info, &c__0,
+ trans, &m, &n, &nrhs, &c_n1, &
+ nb, &itype, &nfail, &nerrs,
+ nout);
+ }
+
+/* Check correctness of results */
+
+ ldwork = max(1,nrows);
+ if (nrows > 0 && nrhs > 0) {
+ zlacpy_("Full", &nrows, &nrhs, ©b[
+ 1], &ldb, &c__[1], &ldb);
+ }
+ zqrt16_(trans, &m, &n, &nrhs, ©a[1], &
+ lda, &b[1], &ldb, &c__[1], &ldb, &
+ rwork[1], result);
+
+ if (itran == 1 && m >= n || itran == 2 &&
+ m < n) {
+
+/* Solving LS system */
+
+ result[1] = zqrt17_(trans, &c__1, &m,
+ &n, &nrhs, ©a[1], &lda, &
+ b[1], &ldb, ©b[1], &ldb, &
+ c__[1], &work[1], &lwork);
+ } else {
+
+/* Solving overdetermined system */
+
+ result[1] = zqrt14_(trans, &m, &n, &
+ nrhs, ©a[1], &lda, &b[1],
+ &ldb, &work[1], &lwork);
+ }
+
+/* Print information about the tests that */
+/* did not pass the threshold. */
+
+ for (k = 1; k <= 2; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&nrhs, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nb, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&itype, (
+ ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k -
+ 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L20: */
+ }
+ nrun += 2;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+/* Generate a matrix of scaling type ISCALE and rank */
+/* type IRANK. */
+
+ zqrt15_(&iscale, &irank, &m, &n, &nrhs, ©a[1], &
+ lda, ©b[1], &ldb, ©s[1], &rank, &
+ norma, &normb, iseed, &work[1], &lwork);
+
+/* workspace used: MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M) */
+
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ iwork[j] = 0;
+/* L50: */
+ }
+ ldwork = max(1,m);
+
+/* Test ZGELSX */
+
+/* ZGELSX: Compute the minimum-norm solution X */
+/* to min( norm( A * X - B ) ) */
+/* using a complete orthogonal factorization. */
+
+ zlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &lda);
+ zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1], &
+ ldb);
+
+ s_copy(srnamc_1.srnamt, "ZGELSX", (ftnlen)32, (ftnlen)
+ 6);
+ zgelsx_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
+ iwork[1], &rcond, &crank, &work[1], &rwork[1],
+ &info);
+
+ if (info != 0) {
+ alaerh_(path, "ZGELSX", &info, &c__0, " ", &m, &n,
+ &nrhs, &c_n1, &nb, &itype, &nfail, &
+ nerrs, nout);
+ }
+
+/* workspace used: MAX( MNMIN+3*N, 2*MNMIN+NRHS ) */
+
+/* Test 3: Compute relative error in svd */
+/* workspace: M*N + 4*MIN(M,N) + MAX(M,N) */
+
+ result[2] = zqrt12_(&crank, &crank, &a[1], &lda, &
+ copys[1], &work[1], &lwork, &rwork[1]);
+
+/* Test 4: Compute error in solution */
+/* workspace: M*NRHS + M */
+
+ zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[1],
+ &ldwork);
+ zqrt16_("No transpose", &m, &n, &nrhs, ©a[1], &
+ lda, &b[1], &ldb, &work[1], &ldwork, &rwork[1]
+, &result[3]);
+
+/* Test 5: Check norm of r'*A */
+/* workspace: NRHS*(M+N) */
+
+ result[4] = 0.;
+ if (m > crank) {
+ result[4] = zqrt17_("No transpose", &c__1, &m, &n,
+ &nrhs, ©a[1], &lda, &b[1], &ldb, &
+ copyb[1], &ldb, &c__[1], &work[1], &lwork);
+ }
+
+/* Test 6: Check if x is in the rowspace of A */
+/* workspace: (M+NRHS)*(N+2) */
+
+ result[5] = 0.;
+
+ if (n > crank) {
+ result[5] = zqrt14_("No transpose", &m, &n, &nrhs,
+ ©a[1], &lda, &b[1], &ldb, &work[1], &
+ lwork);
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 3; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___39.ciunit = *nout;
+ s_wsfe(&io___39);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&itype, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += 4;
+
+/* Loop for testing different block sizes. */
+
+ i__4 = *nnb;
+ for (inb = 1; inb <= i__4; ++inb) {
+ nb = nbval[inb];
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__3, &nxval[inb]);
+
+/* Test ZGELSY */
+
+/* ZGELSY: Compute the minimum-norm solution */
+/* X to min( norm( A * X - B ) ) */
+/* using the rank-revealing orthogonal */
+/* factorization. */
+
+ zlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
+ lda);
+ zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
+ &ldb);
+
+/* Initialize vector IWORK. */
+
+ i__5 = n;
+ for (j = 1; j <= i__5; ++j) {
+ iwork[j] = 0;
+/* L70: */
+ }
+
+/* Set LWLSY to the adequate value. */
+
+/* Computing MAX */
+ i__5 = mnmin << 1, i__6 = nb * (n + 1), i__5 =
+ max(i__5,i__6), i__6 = mnmin + nb * nrhs;
+ lwlsy = mnmin + max(i__5,i__6);
+ lwlsy = max(1,lwlsy);
+
+ s_copy(srnamc_1.srnamt, "ZGELSY", (ftnlen)32, (
+ ftnlen)6);
+ zgelsy_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
+ iwork[1], &rcond, &crank, &work[1], &
+ lwlsy, &rwork[1], &info);
+ if (info != 0) {
+ alaerh_(path, "ZGELSY", &info, &c__0, " ", &m,
+ &n, &nrhs, &c_n1, &nb, &itype, &
+ nfail, &nerrs, nout);
+ }
+
+/* workspace used: 2*MNMIN+NB*NB+NB*MAX(N,NRHS) */
+
+/* Test 7: Compute relative error in svd */
+/* workspace: M*N + 4*MIN(M,N) + MAX(M,N) */
+
+ result[6] = zqrt12_(&crank, &crank, &a[1], &lda, &
+ copys[1], &work[1], &lwork, &rwork[1]);
+
+/* Test 8: Compute error in solution */
+/* workspace: M*NRHS + M */
+
+ zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
+ 1], &ldwork);
+ zqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
+ &lda, &b[1], &ldb, &work[1], &ldwork, &
+ rwork[1], &result[7]);
+
+/* Test 9: Check norm of r'*A */
+/* workspace: NRHS*(M+N) */
+
+ result[8] = 0.;
+ if (m > crank) {
+ result[8] = zqrt17_("No transpose", &c__1, &m,
+ &n, &nrhs, ©a[1], &lda, &b[1], &
+ ldb, ©b[1], &ldb, &c__[1], &work[
+ 1], &lwork);
+ }
+
+/* Test 10: Check if x is in the rowspace of A */
+/* workspace: (M+NRHS)*(N+2) */
+
+ result[9] = 0.;
+
+ if (n > crank) {
+ result[9] = zqrt14_("No transpose", &m, &n, &
+ nrhs, ©a[1], &lda, &b[1], &ldb, &
+ work[1], &lwork);
+ }
+
+/* Test ZGELSS */
+
+/* ZGELSS: Compute the minimum-norm solution */
+/* X to min( norm( A * X - B ) ) */
+/* using the SVD. */
+
+ zlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
+ lda);
+ zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
+ &ldb);
+ s_copy(srnamc_1.srnamt, "ZGELSS", (ftnlen)32, (
+ ftnlen)6);
+ zgelss_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
+ s[1], &rcond, &crank, &work[1], &lwork, &
+ rwork[1], &info);
+
+ if (info != 0) {
+ alaerh_(path, "ZGELSS", &info, &c__0, " ", &m,
+ &n, &nrhs, &c_n1, &nb, &itype, &
+ nfail, &nerrs, nout);
+ }
+
+/* workspace used: 3*min(m,n) + */
+/* max(2*min(m,n),nrhs,max(m,n)) */
+
+/* Test 11: Compute relative error in svd */
+
+ if (rank > 0) {
+ daxpy_(&mnmin, &c_b91, ©s[1], &c__1, &s[1]
+, &c__1);
+ result[10] = dasum_(&mnmin, &s[1], &c__1) /
+ dasum_(&mnmin, ©s[1], &c__1) / (
+ eps * (doublereal) mnmin);
+ } else {
+ result[10] = 0.;
+ }
+
+/* Test 12: Compute error in solution */
+
+ zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
+ 1], &ldwork);
+ zqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
+ &lda, &b[1], &ldb, &work[1], &ldwork, &
+ rwork[1], &result[11]);
+
+/* Test 13: Check norm of r'*A */
+
+ result[12] = 0.;
+ if (m > crank) {
+ result[12] = zqrt17_("No transpose", &c__1, &
+ m, &n, &nrhs, ©a[1], &lda, &b[1],
+ &ldb, ©b[1], &ldb, &c__[1], &work[
+ 1], &lwork);
+ }
+
+/* Test 14: Check if x is in the rowspace of A */
+
+ result[13] = 0.;
+ if (n > crank) {
+ result[13] = zqrt14_("No transpose", &m, &n, &
+ nrhs, ©a[1], &lda, &b[1], &ldb, &
+ work[1], &lwork);
+ }
+
+/* Test ZGELSD */
+
+/* ZGELSD: Compute the minimum-norm solution X */
+/* to min( norm( A * X - B ) ) using a */
+/* divide and conquer SVD. */
+
+ xlaenv_(&c__9, &c__25);
+
+ zlacpy_("Full", &m, &n, ©a[1], &lda, &a[1], &
+ lda);
+ zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &b[1],
+ &ldb);
+
+ s_copy(srnamc_1.srnamt, "ZGELSD", (ftnlen)32, (
+ ftnlen)6);
+ zgelsd_(&m, &n, &nrhs, &a[1], &lda, &b[1], &ldb, &
+ s[1], &rcond, &crank, &work[1], &lwork, &
+ rwork[1], &iwork[1], &info);
+ if (info != 0) {
+ alaerh_(path, "ZGELSD", &info, &c__0, " ", &m,
+ &n, &nrhs, &c_n1, &nb, &itype, &
+ nfail, &nerrs, nout);
+ }
+
+/* Test 15: Compute relative error in svd */
+
+ if (rank > 0) {
+ daxpy_(&mnmin, &c_b91, ©s[1], &c__1, &s[1]
+, &c__1);
+ result[14] = dasum_(&mnmin, &s[1], &c__1) /
+ dasum_(&mnmin, ©s[1], &c__1) / (
+ eps * (doublereal) mnmin);
+ } else {
+ result[14] = 0.;
+ }
+
+/* Test 16: Compute error in solution */
+
+ zlacpy_("Full", &m, &nrhs, ©b[1], &ldb, &work[
+ 1], &ldwork);
+ zqrt16_("No transpose", &m, &n, &nrhs, ©a[1],
+ &lda, &b[1], &ldb, &work[1], &ldwork, &
+ rwork[1], &result[15]);
+
+/* Test 17: Check norm of r'*A */
+
+ result[16] = 0.;
+ if (m > crank) {
+ result[16] = zqrt17_("No transpose", &c__1, &
+ m, &n, &nrhs, ©a[1], &lda, &b[1],
+ &ldb, ©b[1], &ldb, &c__[1], &work[
+ 1], &lwork);
+ }
+
+/* Test 18: Check if x is in the rowspace of A */
+
+ result[17] = 0.;
+ if (n > crank) {
+ result[17] = zqrt14_("No transpose", &m, &n, &
+ nrhs, ©a[1], &lda, &b[1], &ldb, &
+ work[1], &lwork);
+ }
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = 7; k <= 18; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ alahd_(nout, path);
+ }
+ io___41.ciunit = *nout;
+ s_wsfe(&io___41);
+ do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&nrhs, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&itype, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun += 12;
+
+/* L90: */
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZDRVLS */
+
+} /* zdrvls_ */
diff --git a/TESTING/LIN/zdrvpb.c b/TESTING/LIN/zdrvpb.c
new file mode 100644
index 0000000..1f15675
--- /dev/null
+++ b/TESTING/LIN/zdrvpb.c
@@ -0,0 +1,836 @@
+/* zdrvpb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublecomplex c_b47 = {0.,0.};
+static doublecomplex c_b48 = {1.,0.};
+
+/* Subroutine */ int zdrvpb_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
+ doublecomplex *a, doublecomplex *afac, doublecomplex *asav,
+ doublecomplex *b, doublecomplex *bsav, doublecomplex *x,
+ doublecomplex *xact, doublereal *s, doublecomplex *work, doublereal *
+ rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*2] = "N" "Y";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, KD =\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002',"
+ " \002,i5,\002, \002,i5,\002, ... ), EQUED='\002,a1,\002', type"
+ " \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002( '\002,a1,\002', '\002,a1,\002',"
+ " \002,i5,\002, \002,i5,\002, ... ), type \002,i1,\002, test(\002"
+ ",i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, k, n, i1, i2, k1, kd, nb, in, kl, iw, ku, nt, lda, ikd, nkd,
+ ldab;
+ char fact[1];
+ integer ioff, mode, koff;
+ doublereal amax;
+ char path[3];
+ integer imat, info;
+ char dist[1], uplo[1], type__[1];
+ integer nrun, ifact, nfail, iseed[4], nfact;
+ extern doublereal dget06_(doublereal *, doublereal *);
+ integer kdval[4];
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ doublereal rcond, roldc, scond;
+ integer nimat;
+ doublereal anorm;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+);
+ logical equil;
+ extern /* Subroutine */ int zpbt01_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *), zpbt02_(char *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+), zpbt05_(char *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *);
+ integer iuplo, izero, nerrs;
+ logical zerot;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zpbsv_(char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *), zswap_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ char xtype[1];
+ extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), aladhd_(integer *,
+ char *), alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ logical prefac;
+ doublereal rcondc;
+ logical nofact;
+ char packit[1];
+ integer iequed;
+ extern doublereal zlanhb_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *),
+ zlange_(char *, integer *, integer *, doublecomplex *, integer *,
+ doublereal *);
+ extern /* Subroutine */ int zlaqhb_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *, char *), alasvm_(char *, integer *,
+ integer *, integer *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int zlaipd_(integer *, doublecomplex *, integer *,
+ integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *), zlarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *), zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zpbequ_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *), zpbtrf_(char *, integer *, integer *, doublecomplex *,
+ integer *, integer *), zlatms_(integer *, integer *, char
+ *, integer *, char *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *, char *, doublecomplex *,
+ integer *, doublecomplex *, integer *);
+ doublereal result[6];
+ extern /* Subroutine */ int zpbtrs_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *), zpbsvx_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ char *, doublereal *, doublecomplex *, integer *, doublecomplex *
+, integer *, doublereal *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *),
+ zerrvx_(char *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___57 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___60 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___61 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVPB tests the driver routines ZPBSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "PB", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+ kdval[0] = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+
+/* Set limits on the number of loop iterations. */
+
+/* Computing MAX */
+ i__2 = 1, i__3 = min(n,4);
+ nkd = max(i__2,i__3);
+ nimat = 8;
+ if (n == 0) {
+ nimat = 1;
+ }
+
+ kdval[1] = n + (n + 1) / 4;
+ kdval[2] = (n * 3 - 1) / 4;
+ kdval[3] = (n + 1) / 4;
+
+ i__2 = nkd;
+ for (ikd = 1; ikd <= i__2; ++ikd) {
+
+/* Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order */
+/* makes it easier to skip redundant values for small values */
+/* of N. */
+
+ kd = kdval[ikd - 1];
+ ldab = kd + 1;
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ koff = 1;
+ if (iuplo == 1) {
+ *(unsigned char *)uplo = 'U';
+ *(unsigned char *)packit = 'Q';
+/* Computing MAX */
+ i__3 = 1, i__4 = kd + 2 - n;
+ koff = max(i__3,i__4);
+ } else {
+ *(unsigned char *)uplo = 'L';
+ *(unsigned char *)packit = 'B';
+ }
+
+ i__3 = nimat;
+ for (imat = 1; imat <= i__3; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L80;
+ }
+
+/* Skip types 2, 3, or 4 if the matrix size is too small. */
+
+ zerot = imat >= 2 && imat <= 4;
+ if (zerot && n < imat - 1) {
+ goto L80;
+ }
+
+ if (! zerot || ! dotype[1]) {
+
+/* Set up parameters with ZLATB4 and generate a test */
+/* matrix with ZLATMS. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm,
+ &mode, &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)
+ 6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode,
+ &cndnum, &anorm, &kd, &kd, packit, &a[koff],
+ &ldab, &work[1], &info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ goto L80;
+ }
+ } else if (izero > 0) {
+
+/* Use the same matrix for types 3 and 4 as for type */
+/* 2 by copying back the zeroed out column, */
+
+ iw = (lda << 1) + 1;
+ if (iuplo == 1) {
+ ioff = (izero - 1) * ldab + kd + 1;
+ i__4 = izero - i1;
+ zcopy_(&i__4, &work[iw], &c__1, &a[ioff - izero +
+ i1], &c__1);
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ zcopy_(&i__4, &work[iw], &c__1, &a[ioff], &i__5);
+ } else {
+ ioff = (i1 - 1) * ldab + 1;
+ i__4 = izero - i1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ zcopy_(&i__4, &work[iw], &c__1, &a[ioff + izero -
+ i1], &i__5);
+ ioff = (izero - 1) * ldab + 1;
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+ zcopy_(&i__4, &work[iw], &c__1, &a[ioff], &c__1);
+ }
+ }
+
+/* For types 2-4, zero one row and column of the matrix */
+/* to test that INFO is returned correctly. */
+
+ izero = 0;
+ if (zerot) {
+ if (imat == 2) {
+ izero = 1;
+ } else if (imat == 3) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+/* Save the zeroed out row and column in WORK(*,3) */
+
+ iw = lda << 1;
+/* Computing MIN */
+ i__5 = (kd << 1) + 1;
+ i__4 = min(i__5,n);
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = iw + i__;
+ work[i__5].r = 0., work[i__5].i = 0.;
+/* L20: */
+ }
+ ++iw;
+/* Computing MAX */
+ i__4 = izero - kd;
+ i1 = max(i__4,1);
+/* Computing MIN */
+ i__4 = izero + kd;
+ i2 = min(i__4,n);
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * ldab + kd + 1;
+ i__4 = izero - i1;
+ zswap_(&i__4, &a[ioff - izero + i1], &c__1, &work[
+ iw], &c__1);
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ zswap_(&i__4, &a[ioff], &i__5, &work[iw], &c__1);
+ } else {
+ ioff = (i1 - 1) * ldab + 1;
+ i__4 = izero - i1;
+/* Computing MAX */
+ i__6 = ldab - 1;
+ i__5 = max(i__6,1);
+ zswap_(&i__4, &a[ioff + izero - i1], &i__5, &work[
+ iw], &c__1);
+ ioff = (izero - 1) * ldab + 1;
+ iw = iw + izero - i1;
+ i__4 = i2 - izero + 1;
+ zswap_(&i__4, &a[ioff], &c__1, &work[iw], &c__1);
+ }
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ if (iuplo == 1) {
+ zlaipd_(&n, &a[kd + 1], &ldab, &c__0);
+ } else {
+ zlaipd_(&n, &a[1], &ldab, &c__0);
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ i__4 = kd + 1;
+ zlacpy_("Full", &i__4, &n, &a[1], &ldab, &asav[1], &ldab);
+
+ for (iequed = 1; iequed <= 2; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__4 = nfact;
+ for (ifact = 1; ifact <= i__4; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L60;
+ }
+ rcondc = 0.;
+
+ } else if (! lsame_(fact, "N")) {
+
+/* Compute the condition number for comparison */
+/* with the value returned by ZPBSVX (FACT = */
+/* 'N' reuses the condition number from the */
+/* previous iteration with FACT = 'F'). */
+
+ i__5 = kd + 1;
+ zlacpy_("Full", &i__5, &n, &asav[1], &ldab, &
+ afac[1], &ldab);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ zpbequ_(uplo, &n, &kd, &afac[1], &ldab, &
+ s[1], &scond, &amax, &info);
+ if (info == 0 && n > 0) {
+ if (iequed > 1) {
+ scond = 0.;
+ }
+
+/* Equilibrate the matrix. */
+
+ zlaqhb_(uplo, &n, &kd, &afac[1], &
+ ldab, &s[1], &scond, &amax,
+ equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in ZGET04. */
+
+ if (equil) {
+ roldc = rcondc;
+ }
+
+/* Compute the 1-norm of A. */
+
+ anorm = zlanhb_("1", uplo, &n, &kd, &afac[1],
+ &ldab, &rwork[1]);
+
+/* Factor the matrix A. */
+
+ zpbtrf_(uplo, &n, &kd, &afac[1], &ldab, &info);
+
+/* Form the inverse of A. */
+
+ zlaset_("Full", &n, &n, &c_b47, &c_b48, &a[1],
+ &lda);
+ s_copy(srnamc_1.srnamt, "ZPBTRS", (ftnlen)32,
+ (ftnlen)6);
+ zpbtrs_(uplo, &n, &kd, &n, &afac[1], &ldab, &
+ a[1], &lda, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = zlange_("1", &n, &n, &a[1], &lda, &
+ rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondc = 1.;
+ } else {
+ rcondc = 1. / anorm / ainvnm;
+ }
+ }
+
+/* Restore the matrix A. */
+
+ i__5 = kd + 1;
+ zlacpy_("Full", &i__5, &n, &asav[1], &ldab, &a[1],
+ &ldab);
+
+/* Form an exact solution and set the right hand */
+/* side. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (
+ ftnlen)6);
+ zlarhs_(path, xtype, uplo, " ", &n, &n, &kd, &kd,
+ nrhs, &a[1], &ldab, &xact[1], &lda, &b[1],
+ &lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &
+ lda);
+
+ if (nofact) {
+
+/* --- Test ZPBSV --- */
+
+/* Compute the L*L' or U'*U factorization of the */
+/* matrix and solve the system. */
+
+ i__5 = kd + 1;
+ zlacpy_("Full", &i__5, &n, &a[1], &ldab, &
+ afac[1], &ldab);
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1],
+ &lda);
+
+ s_copy(srnamc_1.srnamt, "ZPBSV ", (ftnlen)32,
+ (ftnlen)6);
+ zpbsv_(uplo, &n, &kd, nrhs, &afac[1], &ldab, &
+ x[1], &lda, &info);
+
+/* Check error code from ZPBSV . */
+
+ if (info != izero) {
+ alaerh_(path, "ZPBSV ", &info, &izero,
+ uplo, &n, &n, &kd, &kd, nrhs, &
+ imat, &nfail, &nerrs, nout);
+ goto L40;
+ } else if (info != 0) {
+ goto L40;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zpbt01_(uplo, &n, &kd, &a[1], &ldab, &afac[1],
+ &ldab, &rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[
+ 1], &lda);
+ zpbt02_(uplo, &n, &kd, nrhs, &a[1], &ldab, &x[
+ 1], &lda, &work[1], &lda, &rwork[1], &
+ result[1]);
+
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did */
+/* not pass the threshold. */
+
+ i__5 = nt;
+ for (k = 1; k <= i__5; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___57.ciunit = *nout;
+ s_wsfe(&io___57);
+ do_fio(&c__1, "ZPBSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L30: */
+ }
+ nrun += nt;
+L40:
+ ;
+ }
+
+/* --- Test ZPBSVX --- */
+
+ if (! prefac) {
+ i__5 = kd + 1;
+ zlaset_("Full", &i__5, &n, &c_b47, &c_b47, &
+ afac[1], &ldab);
+ }
+ zlaset_("Full", &n, nrhs, &c_b47, &c_b47, &x[1], &
+ lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT='F' and */
+/* EQUED='Y' */
+
+ zlaqhb_(uplo, &n, &kd, &a[1], &ldab, &s[1], &
+ scond, &amax, equed);
+ }
+
+/* Solve the system and compute the condition */
+/* number and error bounds using ZPBSVX. */
+
+ s_copy(srnamc_1.srnamt, "ZPBSVX", (ftnlen)32, (
+ ftnlen)6);
+ zpbsvx_(fact, uplo, &n, &kd, nrhs, &a[1], &ldab, &
+ afac[1], &ldab, equed, &s[1], &b[1], &lda,
+ &x[1], &lda, &rcond, &rwork[1], &rwork[*
+ nrhs + 1], &work[1], &rwork[(*nrhs << 1)
+ + 1], &info);
+
+/* Check the error code from ZPBSVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__7[0] = 1, a__1[0] = fact;
+ i__7[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__7, &c__2, (ftnlen)2);
+ alaerh_(path, "ZPBSVX", &info, &izero, ch__1,
+ &n, &n, &kd, &kd, nrhs, &imat, &nfail,
+ &nerrs, nout);
+ goto L60;
+ }
+
+ if (info == 0) {
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and */
+/* compute residual. */
+
+ zpbt01_(uplo, &n, &kd, &a[1], &ldab, &
+ afac[1], &ldab, &rwork[(*nrhs <<
+ 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &bsav[1], &lda, &
+ work[1], &lda);
+ zpbt02_(uplo, &n, &kd, nrhs, &asav[1], &ldab,
+ &x[1], &lda, &work[1], &lda, &rwork[(*
+ nrhs << 1) + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &
+ lda, &rcondc, &result[2]);
+ } else {
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &
+ lda, &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ zpbt05_(uplo, &n, &kd, nrhs, &asav[1], &ldab,
+ &b[1], &lda, &x[1], &lda, &xact[1], &
+ lda, &rwork[1], &rwork[*nrhs + 1], &
+ result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from ZPBSVX with the computed */
+/* value in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___60.ciunit = *nout;
+ s_wsfe(&io___60);
+ do_fio(&c__1, "ZPBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___61.ciunit = *nout;
+ s_wsfe(&io___61);
+ do_fio(&c__1, "ZPBSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&kd, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1],
+ (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L50: */
+ }
+ nrun = nrun + 7 - k1;
+L60:
+ ;
+ }
+/* L70: */
+ }
+L80:
+ ;
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZDRVPB */
+
+} /* zdrvpb_ */
diff --git a/TESTING/LIN/zdrvpo.c b/TESTING/LIN/zdrvpo.c
new file mode 100644
index 0000000..6689596
--- /dev/null
+++ b/TESTING/LIN/zdrvpo.c
@@ -0,0 +1,719 @@
+/* zdrvpo.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublecomplex c_b51 = {0.,0.};
+
+/* Subroutine */ int zdrvpo_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
+ doublecomplex *a, doublecomplex *afac, doublecomplex *asav,
+ doublecomplex *b, doublecomplex *bsav, doublecomplex *x,
+ doublecomplex *xact, doublereal *s, doublecomplex *work, doublereal *
+ rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*2] = "N" "Y";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,"
+ "\002, test(\002,i1,\002) =\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, k, n, k1, nb, in, kl, ku, nt, lda;
+ char fact[1];
+ integer ioff, mode;
+ doublereal amax;
+ char path[3];
+ integer imat, info;
+ char dist[1], uplo[1], type__[1];
+ integer nrun, ifact, nfail, iseed[4], nfact;
+ extern doublereal dget06_(doublereal *, doublereal *);
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ doublereal rcond, roldc, scond;
+ integer nimat;
+ doublereal anorm;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+);
+ logical equil;
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int zpot01_(char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *), zpot02_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *), zpot05_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int zposv_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *), zlatb4_(char *, integer *, integer *, integer *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ char *), aladhd_(integer *, char *), alaerh_(char *, char *, integer *, integer *, char *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *);
+ logical prefac;
+ doublereal rcondc;
+ logical nofact;
+ integer iequed;
+ extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int zlaipd_(integer *, doublecomplex *, integer *,
+ integer *), zlaqhe_(char *, integer *, doublecomplex *, integer *
+, doublereal *, doublereal *, doublereal *, char *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *), zlarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *), zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatms_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublecomplex *, integer *, doublecomplex *,
+ integer *);
+ doublereal result[6];
+ extern /* Subroutine */ int zpoequ_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *), zpotrf_(
+ char *, integer *, doublecomplex *, integer *, integer *),
+ zpotri_(char *, integer *, doublecomplex *, integer *, integer *), zerrvx_(char *, integer *), zposvx_(char *,
+ char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, char *, doublereal *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+, doublereal *, doublecomplex *, doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVPO tests the driver routines ZPOSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "PO", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot && n < imat - 2) {
+ goto L120;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Set up parameters with ZLATB4 and generate a test matrix */
+/* with ZLATMS. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
+ &info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L110;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ i__3 = lda + 1;
+ zlaipd_(&n, &a[1], &i__3, &c__0);
+
+/* Save a copy of the matrix A in ASAV. */
+
+ zlacpy_(uplo, &n, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 2; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__3 = nfact;
+ for (ifact = 1; ifact <= i__3; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L90;
+ }
+ rcondc = 0.;
+
+ } else if (! lsame_(fact, "N"))
+ {
+
+/* Compute the condition number for comparison with */
+/* the value returned by ZPOSVX (FACT = 'N' reuses */
+/* the condition number from the previous iteration */
+/* with FACT = 'F'). */
+
+ zlacpy_(uplo, &n, &n, &asav[1], &lda, &afac[1], &
+ lda);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ zpoequ_(&n, &afac[1], &lda, &s[1], &scond, &
+ amax, &info);
+ if (info == 0 && n > 0) {
+ if (iequed > 1) {
+ scond = 0.;
+ }
+
+/* Equilibrate the matrix. */
+
+ zlaqhe_(uplo, &n, &afac[1], &lda, &s[1], &
+ scond, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in ZGET04. */
+
+ if (equil) {
+ roldc = rcondc;
+ }
+
+/* Compute the 1-norm of A. */
+
+ anorm = zlanhe_("1", uplo, &n, &afac[1], &lda, &
+ rwork[1]);
+
+/* Factor the matrix A. */
+
+ zpotrf_(uplo, &n, &afac[1], &lda, &info);
+
+/* Form the inverse of A. */
+
+ zlacpy_(uplo, &n, &n, &afac[1], &lda, &a[1], &lda);
+ zpotri_(uplo, &n, &a[1], &lda, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = zlanhe_("1", uplo, &n, &a[1], &lda, &
+ rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondc = 1.;
+ } else {
+ rcondc = 1. / anorm / ainvnm;
+ }
+ }
+
+/* Restore the matrix A. */
+
+ zlacpy_(uplo, &n, &n, &asav[1], &lda, &a[1], &lda);
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku,
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
+
+ if (nofact) {
+
+/* --- Test ZPOSV --- */
+
+/* Compute the L*L' or U'*U factorization of the */
+/* matrix and solve the system. */
+
+ zlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "ZPOSV ", (ftnlen)32, (
+ ftnlen)6);
+ zposv_(uplo, &n, nrhs, &afac[1], &lda, &x[1], &
+ lda, &info);
+
+/* Check error code from ZPOSV . */
+
+ if (info != izero) {
+ alaerh_(path, "ZPOSV ", &info, &izero, uplo, &
+ n, &n, &c_n1, &c_n1, nrhs, &imat, &
+ nfail, &nerrs, nout);
+ goto L70;
+ } else if (info != 0) {
+ goto L70;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
+ rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
+ lda);
+ zpot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda,
+ &work[1], &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___48.ciunit = *nout;
+ s_wsfe(&io___48);
+ do_fio(&c__1, "ZPOSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += nt;
+L70:
+ ;
+ }
+
+/* --- Test ZPOSVX --- */
+
+ if (! prefac) {
+ zlaset_(uplo, &n, &n, &c_b51, &c_b51, &afac[1], &
+ lda);
+ }
+ zlaset_("Full", &n, nrhs, &c_b51, &c_b51, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT='F' and */
+/* EQUED='Y'. */
+
+ zlaqhe_(uplo, &n, &a[1], &lda, &s[1], &scond, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using ZPOSVX. */
+
+ s_copy(srnamc_1.srnamt, "ZPOSVX", (ftnlen)32, (ftnlen)
+ 6);
+ zposvx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1], &
+ lda, equed, &s[1], &b[1], &lda, &x[1], &lda, &
+ rcond, &rwork[1], &rwork[*nrhs + 1], &work[1],
+ &rwork[(*nrhs << 1) + 1], &info);
+
+/* Check the error code from ZPOSVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "ZPOSVX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L90;
+ }
+
+ if (info == 0) {
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda,
+ &rwork[(*nrhs << 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ zpot02_(uplo, &n, nrhs, &asav[1], &lda, &x[1], &
+ lda, &work[1], &lda, &rwork[(*nrhs << 1)
+ + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ zpot05_(uplo, &n, nrhs, &asav[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &rwork[*nrhs + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from ZPOSVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___51.ciunit = *nout;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "ZPOSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___52.ciunit = *nout;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "ZPOSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + 7 - k1;
+L90:
+ ;
+ }
+/* L100: */
+ }
+L110:
+ ;
+ }
+L120:
+ ;
+ }
+/* L130: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZDRVPO */
+
+} /* zdrvpo_ */
diff --git a/TESTING/LIN/zdrvpox.c b/TESTING/LIN/zdrvpox.c
new file mode 100644
index 0000000..9cfacc3
--- /dev/null
+++ b/TESTING/LIN/zdrvpox.c
@@ -0,0 +1,886 @@
+/* zdrvpox.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "memory_alloc.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublecomplex c_b51 = {0.,0.};
+static complex c_b87 = {0.f,0.f};
+static doublereal c_b94 = 0.;
+
+/* Subroutine */ int zdrvpo_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
+ doublecomplex *a, doublecomplex *afac, doublecomplex *asav,
+ doublecomplex *b, doublecomplex *bsav, doublecomplex *x,
+ doublecomplex *xact, doublereal *s, doublecomplex *work, doublereal *
+ rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char facts[1*3] = "F" "N" "E";
+ static char equeds[1*2] = "N" "Y";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,"
+ "\002, test(\002,i1,\002) =\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ extern /* Subroutine */ int zposvxx_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, char *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *,
+ doublecomplex *, doublereal *, integer *),
+ zebchvxx_(doublereal *, char *);
+ integer i__, k, n;
+ doublereal *errbnds_c__, *errbnds_n__;
+ integer k1, nb, in, kl, ku, nt, n_err_bnds__, lda;
+ char fact[1];
+ integer ioff, mode;
+ doublereal amax;
+ char path[3];
+ integer imat, info;
+ doublereal *berr;
+ char dist[1];
+ doublereal rpvgrw_svxx__;
+ char uplo[1], type__[1];
+ integer nrun, ifact, nfail, iseed[4], nfact;
+ extern doublereal dget06_(doublereal *, doublereal *);
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ integer nbmin;
+ doublereal rcond, roldc, scond;
+ integer nimat;
+ doublereal anorm;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+);
+ logical equil;
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int zpot01_(char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *), zpot02_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *), zpot05_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int zposv_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *), zlatb4_(char *, integer *, integer *, integer *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ char *), aladhd_(integer *, char *), alaerh_(char *, char *, integer *, integer *, char *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *);
+ logical prefac;
+ doublereal rcondc;
+ logical nofact;
+ integer iequed;
+ extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int zlaipd_(integer *, doublecomplex *, integer *,
+ integer *), zlaqhe_(char *, integer *, doublecomplex *, integer *
+, doublereal *, doublereal *, doublereal *, char *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *), zlarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *), zlaset_(), zlatms_(integer *, integer *, char *,
+ integer *, char *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, integer *, char *, doublecomplex *,
+ integer *, doublecomplex *, integer *);
+ doublereal result[6];
+ extern /* Subroutine */ int zpoequ_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *), zpotrf_(
+ char *, integer *, doublecomplex *, integer *, integer *),
+ zpotri_(char *, integer *, doublecomplex *, integer *, integer *), zerrvx_(char *, integer *), zposvx_(char *,
+ char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, char *, doublereal *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+, doublereal *, doublecomplex *, doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___51 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___58 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___59 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVPO tests the driver routines ZPOSV, -SVX, and -SVXX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "PO", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L120;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot && n < imat - 2) {
+ goto L120;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Set up parameters with ZLATB4 and generate a test matrix */
+/* with ZLATMS. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
+ &info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L110;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ i__3 = lda + 1;
+ zlaipd_(&n, &a[1], &i__3, &c__0);
+
+/* Save a copy of the matrix A in ASAV. */
+
+ zlacpy_(uplo, &n, &n, &a[1], &lda, &asav[1], &lda);
+
+ for (iequed = 1; iequed <= 2; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__3 = nfact;
+ for (ifact = 1; ifact <= i__3; ++ifact) {
+ for (i__ = 1; i__ <= 6; ++i__) {
+ result[i__ - 1] = 0.;
+ }
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L90;
+ }
+ rcondc = 0.;
+
+ } else if (! lsame_(fact, "N"))
+ {
+
+/* Compute the condition number for comparison with */
+/* the value returned by ZPOSVX (FACT = 'N' reuses */
+/* the condition number from the previous iteration */
+/* with FACT = 'F'). */
+
+ zlacpy_(uplo, &n, &n, &asav[1], &lda, &afac[1], &
+ lda);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ zpoequ_(&n, &afac[1], &lda, &s[1], &scond, &
+ amax, &info);
+ if (info == 0 && n > 0) {
+ if (iequed > 1) {
+ scond = 0.;
+ }
+
+/* Equilibrate the matrix. */
+
+ zlaqhe_(uplo, &n, &afac[1], &lda, &s[1], &
+ scond, &amax, equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in ZGET04. */
+
+ if (equil) {
+ roldc = rcondc;
+ }
+
+/* Compute the 1-norm of A. */
+
+ anorm = zlanhe_("1", uplo, &n, &afac[1], &lda, &
+ rwork[1]);
+
+/* Factor the matrix A. */
+
+ zpotrf_(uplo, &n, &afac[1], &lda, &info);
+
+/* Form the inverse of A. */
+
+ zlacpy_(uplo, &n, &n, &afac[1], &lda, &a[1], &lda);
+ zpotri_(uplo, &n, &a[1], &lda, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = zlanhe_("1", uplo, &n, &a[1], &lda, &
+ rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondc = 1.;
+ } else {
+ rcondc = 1. / anorm / ainvnm;
+ }
+ }
+
+/* Restore the matrix A. */
+
+ zlacpy_(uplo, &n, &n, &asav[1], &lda, &a[1], &lda);
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku,
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
+
+ if (nofact) {
+
+/* --- Test ZPOSV --- */
+
+/* Compute the L*L' or U'*U factorization of the */
+/* matrix and solve the system. */
+
+ zlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "ZPOSV ", (ftnlen)32, (
+ ftnlen)6);
+ zposv_(uplo, &n, nrhs, &afac[1], &lda, &x[1], &
+ lda, &info);
+
+/* Check error code from ZPOSV . */
+
+ if (info != izero) {
+ alaerh_(path, "ZPOSV ", &info, &izero, uplo, &
+ n, &n, &c_n1, &c_n1, nrhs, &imat, &
+ nfail, &nerrs, nout);
+ goto L70;
+ } else if (info != 0) {
+ goto L70;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
+ rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
+ lda);
+ zpot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda,
+ &work[1], &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___48.ciunit = *nout;
+ s_wsfe(&io___48);
+ do_fio(&c__1, "ZPOSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += nt;
+L70:
+ ;
+ }
+
+/* --- Test ZPOSVX --- */
+
+ if (! prefac) {
+ zlaset_(uplo, &n, &n, &c_b51, &c_b51, &afac[1], &
+ lda);
+ }
+ zlaset_("Full", &n, nrhs, &c_b51, &c_b51, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT='F' and */
+/* EQUED='Y'. */
+
+ zlaqhe_(uplo, &n, &a[1], &lda, &s[1], &scond, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using ZPOSVX. */
+
+ s_copy(srnamc_1.srnamt, "ZPOSVX", (ftnlen)32, (ftnlen)
+ 6);
+ zposvx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1], &
+ lda, equed, &s[1], &b[1], &lda, &x[1], &lda, &
+ rcond, &rwork[1], &rwork[*nrhs + 1], &work[1],
+ &rwork[(*nrhs << 1) + 1], &info);
+
+/* Check the error code from ZPOSVX. */
+
+ if (info == n + 1) {
+ goto L90;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "ZPOSVX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L90;
+ }
+
+ if (info == 0) {
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda,
+ &rwork[(*nrhs << 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ zpot02_(uplo, &n, nrhs, &asav[1], &lda, &x[1], &
+ lda, &work[1], &lda, &rwork[(*nrhs << 1)
+ + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ zpot05_(uplo, &n, nrhs, &asav[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &rwork[*nrhs + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from ZPOSVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___51.ciunit = *nout;
+ s_wsfe(&io___51);
+ do_fio(&c__1, "ZPOSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___52.ciunit = *nout;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "ZPOSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + 7 - k1;
+
+/* --- Test ZPOSVXX --- */
+
+/* Restore the matrices A and B. */
+
+ zlacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
+ zlacpy_("Full", &n, nrhs, &bsav[1], &lda, &b[1], &lda);
+ if (! prefac) {
+ zlaset_(uplo, &n, &n, &c_b87, &c_b87, &afac[1], &
+ lda);
+ }
+ zlaset_("Full", &n, nrhs, &c_b87, &c_b87, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT='F' and */
+/* EQUED='Y'. */
+
+ zlaqhe_(uplo, &n, &a[1], &lda, &s[1], &scond, &
+ amax, equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using ZPOSVXX. */
+
+ s_copy(srnamc_1.srnamt, "ZPOSVXX", (ftnlen)32, (
+ ftnlen)7);
+
+ dalloc3();
+
+ zposvxx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1],
+ &lda, equed, &s[1], &b[1], &lda, &x[1], &lda,
+ &rcond, &rpvgrw_svxx__, berr, &n_err_bnds__,
+ errbnds_n__, errbnds_c__, &c__0, &c_b94, &
+ work[1], &rwork[(*nrhs << 1) + 1], &info);
+
+ free3();
+
+/* Check the error code from ZPOSVXX. */
+
+ if (info == n + 1) {
+ goto L90;
+ }
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "ZPOSVXX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L90;
+ }
+
+ if (info == 0) {
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda,
+ &rwork[(*nrhs << 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ zpot02_(uplo, &n, nrhs, &asav[1], &lda, &x[1], &
+ lda, &work[1], &lda, &rwork[(*nrhs << 1)
+ + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ zpot05_(uplo, &n, nrhs, &asav[1], &lda, &b[1], &
+ lda, &x[1], &lda, &xact[1], &lda, &rwork[
+ 1], &rwork[*nrhs + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from ZPOSVXX with the computed value */
+/* in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___58.ciunit = *nout;
+ s_wsfe(&io___58);
+ do_fio(&c__1, "ZPOSVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___59.ciunit = *nout;
+ s_wsfe(&io___59);
+ do_fio(&c__1, "ZPOSVXX", (ftnlen)7);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L85: */
+ }
+ nrun = nrun + 7 - k1;
+L90:
+ ;
+ }
+/* L100: */
+ }
+L110:
+ ;
+ }
+L120:
+ ;
+ }
+/* L130: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+/* Test Error Bounds for ZGESVXX */
+ zebchvxx_(thresh, path);
+ return 0;
+
+/* End of ZDRVPO */
+
+} /* zdrvpo_ */
diff --git a/TESTING/LIN/zdrvpp.c b/TESTING/LIN/zdrvpp.c
new file mode 100644
index 0000000..7a2284b
--- /dev/null
+++ b/TESTING/LIN/zdrvpp.c
@@ -0,0 +1,723 @@
+/* zdrvpp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static doublecomplex c_b63 = {0.,0.};
+
+/* Subroutine */ int zdrvpp_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
+ doublecomplex *a, doublecomplex *afac, doublecomplex *asav,
+ doublecomplex *b, doublecomplex *bsav, doublecomplex *x,
+ doublecomplex *xact, doublereal *s, doublecomplex *work, doublereal *
+ rwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char facts[1*3] = "F" "N" "E";
+ static char packs[1*2] = "C" "R";
+ static char equeds[1*2] = "N" "Y";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,"
+ "\002, test(\002,i1,\002)=\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
+ "=\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, k, n, k1, in, kl, ku, nt, lda, npp;
+ char fact[1];
+ integer ioff, mode;
+ doublereal amax;
+ char path[3];
+ integer imat, info;
+ char dist[1], uplo[1], type__[1];
+ integer nrun, ifact, nfail, iseed[4], nfact;
+ extern doublereal dget06_(doublereal *, doublereal *);
+ extern logical lsame_(char *, char *);
+ char equed[1];
+ doublereal roldc, rcond, scond;
+ integer nimat;
+ doublereal anorm;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+);
+ logical equil;
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int zppt01_(char *, integer *, doublecomplex *,
+ doublecomplex *, doublereal *, doublereal *), zppt02_(
+ char *, integer *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *);
+ logical zerot;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zppt05_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *);
+ char xtype[1];
+ extern /* Subroutine */ int zppsv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *),
+ zlatb4_(char *, integer *, integer *, integer *, char *, integer *
+, integer *, doublereal *, integer *, doublereal *, char *), aladhd_(integer *, char *),
+ alaerh_(char *, char *, integer *, integer *, char *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *);
+ logical prefac;
+ doublereal rcondc;
+ logical nofact;
+ char packit[1];
+ integer iequed;
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int zlaipd_(integer *, doublecomplex *, integer *,
+ integer *);
+ doublereal ainvnm;
+ extern doublereal zlanhp_(char *, char *, integer *, doublecomplex *,
+ doublereal *);
+ extern /* Subroutine */ int zlaqhp_(char *, integer *, doublecomplex *,
+ doublereal *, doublereal *, doublereal *, char *),
+ zlacpy_(char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zlarhs_(char *, char *,
+ char *, char *, integer *, integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *), zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatms_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublecomplex *, integer *, doublecomplex *,
+ integer *);
+ doublereal result[6];
+ extern /* Subroutine */ int zppequ_(char *, integer *, doublecomplex *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ zpptrf_(char *, integer *, doublecomplex *, integer *),
+ zpptri_(char *, integer *, doublecomplex *, integer *),
+ zerrvx_(char *, integer *), zppsvx_(char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, char *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___52 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___53 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVPP tests the driver routines ZPPSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*(NMAX+1)/2) */
+
+/* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*(NMAX+1)/2) */
+
+/* ASAV (workspace) COMPLEX*16 array, dimension (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* BSAV (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* S (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --s;
+ --xact;
+ --x;
+ --bsav;
+ --b;
+ --asav;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "PP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ npp = n * (n + 1) / 2;
+ *(unsigned char *)xtype = 'N';
+ nimat = 9;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L130;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot && n < imat - 2) {
+ goto L130;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ *(unsigned char *)packit = *(unsigned char *)&packs[iuplo - 1]
+ ;
+
+/* Set up parameters with ZLATB4 and generate a test matrix */
+/* with ZLATMS. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
+ &cndnum, dist);
+ rcondc = 1. / cndnum;
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &work[
+ 1], &info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
+ &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L120;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * izero / 2;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff += i__;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff = ioff + n - i__;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ if (iuplo == 1) {
+ zlaipd_(&n, &a[1], &c__2, &c__1);
+ } else {
+ zlaipd_(&n, &a[1], &n, &c_n1);
+ }
+
+/* Save a copy of the matrix A in ASAV. */
+
+ zcopy_(&npp, &a[1], &c__1, &asav[1], &c__1);
+
+ for (iequed = 1; iequed <= 2; ++iequed) {
+ *(unsigned char *)equed = *(unsigned char *)&equeds[
+ iequed - 1];
+ if (iequed == 1) {
+ nfact = 3;
+ } else {
+ nfact = 1;
+ }
+
+ i__3 = nfact;
+ for (ifact = 1; ifact <= i__3; ++ifact) {
+ *(unsigned char *)fact = *(unsigned char *)&facts[
+ ifact - 1];
+ prefac = lsame_(fact, "F");
+ nofact = lsame_(fact, "N");
+ equil = lsame_(fact, "E");
+
+ if (zerot) {
+ if (prefac) {
+ goto L100;
+ }
+ rcondc = 0.;
+
+ } else if (! lsame_(fact, "N"))
+ {
+
+/* Compute the condition number for comparison with */
+/* the value returned by ZPPSVX (FACT = 'N' reuses */
+/* the condition number from the previous iteration */
+/* with FACT = 'F'). */
+
+ zcopy_(&npp, &asav[1], &c__1, &afac[1], &c__1);
+ if (equil || iequed > 1) {
+
+/* Compute row and column scale factors to */
+/* equilibrate the matrix A. */
+
+ zppequ_(uplo, &n, &afac[1], &s[1], &scond, &
+ amax, &info);
+ if (info == 0 && n > 0) {
+ if (iequed > 1) {
+ scond = 0.;
+ }
+
+/* Equilibrate the matrix. */
+
+ zlaqhp_(uplo, &n, &afac[1], &s[1], &scond,
+ &amax, equed);
+ }
+ }
+
+/* Save the condition number of the */
+/* non-equilibrated system for use in ZGET04. */
+
+ if (equil) {
+ roldc = rcondc;
+ }
+
+/* Compute the 1-norm of A. */
+
+ anorm = zlanhp_("1", uplo, &n, &afac[1], &rwork[1]
+);
+
+/* Factor the matrix A. */
+
+ zpptrf_(uplo, &n, &afac[1], &info);
+
+/* Form the inverse of A. */
+
+ zcopy_(&npp, &afac[1], &c__1, &a[1], &c__1);
+ zpptri_(uplo, &n, &a[1], &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = zlanhp_("1", uplo, &n, &a[1], &rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondc = 1.;
+ } else {
+ rcondc = 1. / anorm / ainvnm;
+ }
+ }
+
+/* Restore the matrix A. */
+
+ zcopy_(&npp, &asav[1], &c__1, &a[1], &c__1);
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku,
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ *(unsigned char *)xtype = 'C';
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
+
+ if (nofact) {
+
+/* --- Test ZPPSV --- */
+
+/* Compute the L*L' or U'*U factorization of the */
+/* matrix and solve the system. */
+
+ zcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
+ lda);
+
+ s_copy(srnamc_1.srnamt, "ZPPSV ", (ftnlen)32, (
+ ftnlen)6);
+ zppsv_(uplo, &n, nrhs, &afac[1], &x[1], &lda, &
+ info);
+
+/* Check error code from ZPPSV . */
+
+ if (info != izero) {
+ alaerh_(path, "ZPPSV ", &info, &izero, uplo, &
+ n, &n, &c_n1, &c_n1, nrhs, &imat, &
+ nfail, &nerrs, nout);
+ goto L70;
+ } else if (info != 0) {
+ goto L70;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zppt01_(uplo, &n, &a[1], &afac[1], &rwork[1],
+ result);
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
+ lda);
+ zppt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[
+ 1], &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___49.ciunit = *nout;
+ s_wsfe(&io___49);
+ do_fio(&c__1, "ZPPSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += nt;
+L70:
+ ;
+ }
+
+/* --- Test ZPPSVX --- */
+
+ if (! prefac && npp > 0) {
+ zlaset_("Full", &npp, &c__1, &c_b63, &c_b63, &
+ afac[1], &npp);
+ }
+ zlaset_("Full", &n, nrhs, &c_b63, &c_b63, &x[1], &lda);
+ if (iequed > 1 && n > 0) {
+
+/* Equilibrate the matrix if FACT='F' and */
+/* EQUED='Y'. */
+
+ zlaqhp_(uplo, &n, &a[1], &s[1], &scond, &amax,
+ equed);
+ }
+
+/* Solve the system and compute the condition number */
+/* and error bounds using ZPPSVX. */
+
+ s_copy(srnamc_1.srnamt, "ZPPSVX", (ftnlen)32, (ftnlen)
+ 6);
+ zppsvx_(fact, uplo, &n, nrhs, &a[1], &afac[1], equed,
+ &s[1], &b[1], &lda, &x[1], &lda, &rcond, &
+ rwork[1], &rwork[*nrhs + 1], &work[1], &rwork[
+ (*nrhs << 1) + 1], &info);
+
+/* Check the error code from ZPPSVX. */
+
+ if (info != izero) {
+/* Writing concatenation */
+ i__5[0] = 1, a__1[0] = fact;
+ i__5[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
+ alaerh_(path, "ZPPSVX", &info, &izero, ch__1, &n,
+ &n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
+ nerrs, nout);
+ goto L90;
+ }
+
+ if (info == 0) {
+ if (! prefac) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zppt01_(uplo, &n, &a[1], &afac[1], &rwork[(*
+ nrhs << 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
+, &lda);
+ zppt02_(uplo, &n, nrhs, &asav[1], &x[1], &lda, &
+ work[1], &lda, &rwork[(*nrhs << 1) + 1], &
+ result[1]);
+
+/* Check solution from generated exact solution. */
+
+ if (nofact || prefac && lsame_(equed, "N")) {
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &rcondc, &result[2]);
+ } else {
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
+ &roldc, &result[2]);
+ }
+
+/* Check the error bounds from iterative */
+/* refinement. */
+
+ zppt05_(uplo, &n, nrhs, &asav[1], &b[1], &lda, &x[
+ 1], &lda, &xact[1], &lda, &rwork[1], &
+ rwork[*nrhs + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from ZPPSVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ if (prefac) {
+ io___52.ciunit = *nout;
+ s_wsfe(&io___52);
+ do_fio(&c__1, "ZPPSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, equed, (ftnlen)1);
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ } else {
+ io___53.ciunit = *nout;
+ s_wsfe(&io___53);
+ do_fio(&c__1, "ZPPSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ ++nfail;
+ }
+/* L80: */
+ }
+ nrun = nrun + 7 - k1;
+L90:
+L100:
+ ;
+ }
+/* L110: */
+ }
+L120:
+ ;
+ }
+L130:
+ ;
+ }
+/* L140: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZDRVPP */
+
+} /* zdrvpp_ */
diff --git a/TESTING/LIN/zdrvpt.c b/TESTING/LIN/zdrvpt.c
new file mode 100644
index 0000000..5743cd9
--- /dev/null
+++ b/TESTING/LIN/zdrvpt.c
@@ -0,0 +1,685 @@
+/* zdrvpt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+static doublereal c_b24 = 1.;
+static doublereal c_b25 = 0.;
+static doublecomplex c_b62 = {0.,0.};
+
+/* Subroutine */ int zdrvpt_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, doublecomplex *a,
+ doublereal *d__, doublecomplex *e, doublecomplex *b, doublecomplex *x,
+ doublecomplex *xact, doublecomplex *work, doublereal *rwork, integer
+ *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 0,0,0,1 };
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
+ ", test \002,i2,\002, ratio = \002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i2,\002, test \002,i2,\002, ratio = \002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double z_abs(doublecomplex *);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, j, k, n;
+ doublereal z__[3];
+ integer k1, ia, in, kl, ku, ix, nt, lda;
+ char fact[1];
+ doublereal cond;
+ integer mode;
+ doublereal dmax__;
+ integer imat, info;
+ char path[3], dist[1], type__[1];
+ integer nrun, ifact;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ integer nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ doublereal rcond;
+ integer nimat;
+ doublereal anorm;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+), dcopy_(integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer izero, nerrs;
+ extern /* Subroutine */ int zptt01_(integer *, doublereal *,
+ doublecomplex *, doublereal *, doublecomplex *, doublecomplex *,
+ doublereal *);
+ logical zerot;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zptt02_(char *, integer *, integer *,
+ doublereal *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *), zptt05_(
+ integer *, integer *, doublereal *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *), zptsv_(integer *, integer *, doublereal *,
+ doublecomplex *, doublecomplex *, integer *, integer *), zlatb4_(
+ char *, integer *, integer *, integer *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, char *), aladhd_(integer *, char *), alaerh_(char
+ *, char *, integer *, integer *, char *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *);
+ extern integer idamax_(integer *, doublereal *, integer *);
+ doublereal rcondc;
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *), alasvm_(char *, integer *, integer *,
+ integer *, integer *), dlarnv_(integer *, integer *,
+ integer *, doublereal *);
+ doublereal ainvnm;
+ extern doublereal zlanht_(char *, integer *, doublereal *, doublecomplex *
+);
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dzasum_(integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlaptm_(char *, integer *, integer *, doublereal *,
+ doublereal *, doublecomplex *, doublecomplex *, integer *,
+ doublereal *, doublecomplex *, integer *), zlatms_(
+ integer *, integer *, char *, integer *, char *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, integer *, char
+ *, doublecomplex *, integer *, doublecomplex *, integer *), zlarnv_(integer *, integer *, integer *,
+ doublecomplex *);
+ doublereal result[6];
+ extern /* Subroutine */ int zpttrf_(integer *, doublereal *,
+ doublecomplex *, integer *), zerrvx_(char *, integer *),
+ zpttrs_(char *, integer *, integer *, doublereal *, doublecomplex
+ *, doublecomplex *, integer *, integer *), zptsvx_(char *,
+ integer *, integer *, doublereal *, doublecomplex *, doublereal *
+, doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___38 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVPT tests ZPTSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*2) */
+
+/* D (workspace) DOUBLE PRECISION array, dimension (NMAX*2) */
+
+/* E (workspace) COMPLEX*16 array, dimension (NMAX*2) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(3,NRHS)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --e;
+ --d__;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "PT", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+
+/* Do for each value of N in NVAL. */
+
+ n = nval[in];
+ lda = max(1,n);
+ nimat = 12;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (n > 0 && ! dotype[imat]) {
+ goto L110;
+ }
+
+/* Set up parameters with ZLATB4. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
+ cond, dist);
+
+ zerot = imat >= 8 && imat <= 10;
+ if (imat <= 6) {
+
+/* Type 1-6: generate a symmetric tridiagonal matrix of */
+/* known condition number in lower triangular band storage. */
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
+ &anorm, &kl, &ku, "B", &a[1], &c__2, &work[1], &info);
+
+/* Check the error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, " ", &n, &n, &kl, &
+ ku, &c_n1, &imat, &nfail, &nerrs, nout);
+ goto L110;
+ }
+ izero = 0;
+
+/* Copy the matrix to D and E. */
+
+ ia = 1;
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__5 = ia;
+ d__[i__4] = a[i__5].r;
+ i__4 = i__;
+ i__5 = ia + 1;
+ e[i__4].r = a[i__5].r, e[i__4].i = a[i__5].i;
+ ia += 2;
+/* L20: */
+ }
+ if (n > 0) {
+ i__3 = n;
+ i__4 = ia;
+ d__[i__3] = a[i__4].r;
+ }
+ } else {
+
+/* Type 7-12: generate a diagonally dominant matrix with */
+/* unknown condition number in the vectors D and E. */
+
+ if (! zerot || ! dotype[7]) {
+
+/* Let D and E have values from [-1,1]. */
+
+ dlarnv_(&c__2, iseed, &n, &d__[1]);
+ i__3 = n - 1;
+ zlarnv_(&c__2, iseed, &i__3, &e[1]);
+
+/* Make the tridiagonal matrix diagonally dominant. */
+
+ if (n == 1) {
+ d__[1] = abs(d__[1]);
+ } else {
+ d__[1] = abs(d__[1]) + z_abs(&e[1]);
+ d__[n] = (d__1 = d__[n], abs(d__1)) + z_abs(&e[n - 1])
+ ;
+ i__3 = n - 1;
+ for (i__ = 2; i__ <= i__3; ++i__) {
+ d__[i__] = (d__1 = d__[i__], abs(d__1)) + z_abs(&
+ e[i__]) + z_abs(&e[i__ - 1]);
+/* L30: */
+ }
+ }
+
+/* Scale D and E so the maximum element is ANORM. */
+
+ ix = idamax_(&n, &d__[1], &c__1);
+ dmax__ = d__[ix];
+ d__1 = anorm / dmax__;
+ dscal_(&n, &d__1, &d__[1], &c__1);
+ if (n > 1) {
+ i__3 = n - 1;
+ d__1 = anorm / dmax__;
+ zdscal_(&i__3, &d__1, &e[1], &c__1);
+ }
+
+ } else if (izero > 0) {
+
+/* Reuse the last matrix by copying back the zeroed out */
+/* elements. */
+
+ if (izero == 1) {
+ d__[1] = z__[1];
+ if (n > 1) {
+ e[1].r = z__[2], e[1].i = 0.;
+ }
+ } else if (izero == n) {
+ i__3 = n - 1;
+ e[i__3].r = z__[0], e[i__3].i = 0.;
+ d__[n] = z__[1];
+ } else {
+ i__3 = izero - 1;
+ e[i__3].r = z__[0], e[i__3].i = 0.;
+ d__[izero] = z__[1];
+ i__3 = izero;
+ e[i__3].r = z__[2], e[i__3].i = 0.;
+ }
+ }
+
+/* For types 8-10, set one row and column of the matrix to */
+/* zero. */
+
+ izero = 0;
+ if (imat == 8) {
+ izero = 1;
+ z__[1] = d__[1];
+ d__[1] = 0.;
+ if (n > 1) {
+ z__[2] = e[1].r;
+ e[1].r = 0., e[1].i = 0.;
+ }
+ } else if (imat == 9) {
+ izero = n;
+ if (n > 1) {
+ i__3 = n - 1;
+ z__[0] = e[i__3].r;
+ i__3 = n - 1;
+ e[i__3].r = 0., e[i__3].i = 0.;
+ }
+ z__[1] = d__[n];
+ d__[n] = 0.;
+ } else if (imat == 10) {
+ izero = (n + 1) / 2;
+ if (izero > 1) {
+ i__3 = izero - 1;
+ z__[0] = e[i__3].r;
+ i__3 = izero - 1;
+ e[i__3].r = 0., e[i__3].i = 0.;
+ i__3 = izero;
+ z__[2] = e[i__3].r;
+ i__3 = izero;
+ e[i__3].r = 0., e[i__3].i = 0.;
+ }
+ z__[1] = d__[izero];
+ d__[izero] = 0.;
+ }
+ }
+
+/* Generate NRHS random solution vectors. */
+
+ ix = 1;
+ i__3 = *nrhs;
+ for (j = 1; j <= i__3; ++j) {
+ zlarnv_(&c__2, iseed, &n, &xact[ix]);
+ ix += lda;
+/* L40: */
+ }
+
+/* Set the right hand side. */
+
+ zlaptm_("Lower", &n, nrhs, &c_b24, &d__[1], &e[1], &xact[1], &lda,
+ &c_b25, &b[1], &lda);
+
+ for (ifact = 1; ifact <= 2; ++ifact) {
+ if (ifact == 1) {
+ *(unsigned char *)fact = 'F';
+ } else {
+ *(unsigned char *)fact = 'N';
+ }
+
+/* Compute the condition number for comparison with */
+/* the value returned by ZPTSVX. */
+
+ if (zerot) {
+ if (ifact == 1) {
+ goto L100;
+ }
+ rcondc = 0.;
+
+ } else if (ifact == 1) {
+
+/* Compute the 1-norm of A. */
+
+ anorm = zlanht_("1", &n, &d__[1], &e[1]);
+
+ dcopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
+ if (n > 1) {
+ i__3 = n - 1;
+ zcopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
+ }
+
+/* Factor the matrix A. */
+
+ zpttrf_(&n, &d__[n + 1], &e[n + 1], &info);
+
+/* Use ZPTTRS to solve for one column at a time of */
+/* inv(A), computing the maximum column sum as we go. */
+
+ ainvnm = 0.;
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__5 = j;
+ x[i__5].r = 0., x[i__5].i = 0.;
+/* L50: */
+ }
+ i__4 = i__;
+ x[i__4].r = 1., x[i__4].i = 0.;
+ zpttrs_("Lower", &n, &c__1, &d__[n + 1], &e[n + 1], &
+ x[1], &lda, &info);
+/* Computing MAX */
+ d__1 = ainvnm, d__2 = dzasum_(&n, &x[1], &c__1);
+ ainvnm = max(d__1,d__2);
+/* L60: */
+ }
+
+/* Compute the 1-norm condition number of A. */
+
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondc = 1.;
+ } else {
+ rcondc = 1. / anorm / ainvnm;
+ }
+ }
+
+ if (ifact == 2) {
+
+/* --- Test ZPTSV -- */
+
+ dcopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
+ if (n > 1) {
+ i__3 = n - 1;
+ zcopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
+ }
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
+
+/* Factor A as L*D*L' and solve the system A*X = B. */
+
+ s_copy(srnamc_1.srnamt, "ZPTSV ", (ftnlen)32, (ftnlen)6);
+ zptsv_(&n, nrhs, &d__[n + 1], &e[n + 1], &x[1], &lda, &
+ info);
+
+/* Check error code from ZPTSV . */
+
+ if (info != izero) {
+ alaerh_(path, "ZPTSV ", &info, &izero, " ", &n, &n, &
+ c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ }
+ nt = 0;
+ if (izero == 0) {
+
+/* Check the factorization by computing the ratio */
+/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
+
+ zptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
+ work[1], result);
+
+/* Compute the residual in the solution. */
+
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ zptt02_("Lower", &n, nrhs, &d__[1], &e[1], &x[1], &
+ lda, &work[1], &lda, &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+ }
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, "ZPTSV ", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L70: */
+ }
+ nrun += nt;
+ }
+
+/* --- Test ZPTSVX --- */
+
+ if (ifact > 1) {
+
+/* Initialize D( N+1:2*N ) and E( N+1:2*N ) to zero. */
+
+ i__3 = n - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ d__[n + i__] = 0.;
+ i__4 = n + i__;
+ e[i__4].r = 0., e[i__4].i = 0.;
+/* L80: */
+ }
+ if (n > 0) {
+ d__[n + n] = 0.;
+ }
+ }
+
+ zlaset_("Full", &n, nrhs, &c_b62, &c_b62, &x[1], &lda);
+
+/* Solve the system and compute the condition number and */
+/* error bounds using ZPTSVX. */
+
+ s_copy(srnamc_1.srnamt, "ZPTSVX", (ftnlen)32, (ftnlen)6);
+ zptsvx_(fact, &n, nrhs, &d__[1], &e[1], &d__[n + 1], &e[n + 1]
+, &b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &rwork[
+ *nrhs + 1], &work[1], &rwork[(*nrhs << 1) + 1], &info);
+
+/* Check the error code from ZPTSVX. */
+
+ if (info != izero) {
+ alaerh_(path, "ZPTSVX", &info, &izero, fact, &n, &n, &
+ c__1, &c__1, nrhs, &imat, &nfail, &nerrs, nout);
+ }
+ if (izero == 0) {
+ if (ifact == 2) {
+
+/* Check the factorization by computing the ratio */
+/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
+
+ k1 = 1;
+ zptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
+ work[1], result);
+ } else {
+ k1 = 2;
+ }
+
+/* Compute the residual in the solution. */
+
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ zptt02_("Lower", &n, nrhs, &d__[1], &e[1], &x[1], &lda, &
+ work[1], &lda, &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
+ result[2]);
+
+/* Check error bounds from iterative refinement. */
+
+ zptt05_(&n, nrhs, &d__[1], &e[1], &b[1], &lda, &x[1], &
+ lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs + 1],
+ &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Check the reciprocal of the condition number. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___38.ciunit = *nout;
+ s_wsfe(&io___38);
+ do_fio(&c__1, "ZPTSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L90: */
+ }
+ nrun = nrun + 7 - k1;
+L100:
+ ;
+ }
+L110:
+ ;
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZDRVPT */
+
+} /* zdrvpt_ */
diff --git a/TESTING/LIN/zdrvrf1.c b/TESTING/LIN/zdrvrf1.c
new file mode 100644
index 0000000..8fdbb9c
--- /dev/null
+++ b/TESTING/LIN/zdrvrf1.c
@@ -0,0 +1,356 @@
+/* zdrvrf1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__4 = 4;
+static integer c__1 = 1;
+
+/* Subroutine */ int zdrvrf1_(integer *nout, integer *nn, integer *nval,
+ doublereal *thresh, doublecomplex *a, integer *lda, doublecomplex *
+ arf, doublereal *work)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char forms[1*2] = "N" "C";
+ static char norms[1*4] = "M" "1" "I" "F";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002 *** Error(s) or Failure(s) while test"
+ "ing ZLANHF ***\002)";
+ static char fmt_9998[] = "(1x,\002 Error in \002,a6,\002 with UPLO="
+ "'\002,a1,\002', FORM='\002,a1,\002', N=\002,i5)";
+ static char fmt_9997[] = "(1x,\002 Failure in \002,a6,\002 N=\002,"
+ "i5,\002 TYPE=\002,i5,\002 UPLO='\002,a1,\002', FORM ='\002,a1"
+ ",\002', NORM='\002,a1,\002', test=\002,g12.5)";
+ static char fmt_9996[] = "(1x,\002All tests for \002,a6,\002 auxiliary r"
+ "outine passed the \002,\002threshold (\002,i5,\002 tests run)"
+ "\002)";
+ static char fmt_9995[] = "(1x,a6,\002 auxiliary routine:\002,i5,\002 out"
+ " of \002,i5,\002 tests failed to pass the threshold\002)";
+ static char fmt_9994[] = "(26x,i5,\002 error message recorded (\002,a6"
+ ",\002)\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void),
+ do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, n, iin, iit;
+ doublereal eps;
+ integer info;
+ char norm[1], uplo[1];
+ integer nrun, nfail;
+ doublereal large;
+ integer iseed[4];
+ char cform[1];
+ doublereal small;
+ integer iform;
+ doublereal norma;
+ integer inorm, iuplo, nerrs;
+ extern doublereal dlamch_(char *), zlanhe_(char *, char *,
+ integer *, doublecomplex *, integer *, doublereal *), zlanhf_(char *, char *, char *, integer *, doublecomplex
+ *, doublereal *);
+ extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
+ integer *);
+ doublereal result[1];
+ extern /* Subroutine */ int ztrttf_(char *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal normarf;
+
+ /* Fortran I/O blocks */
+ static cilist io___22 = { 0, 0, 0, 0, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___24 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___30 = { 0, 0, 0, 0, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9995, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9994, 0 };
+
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVRF1 tests the LAPACK RFP routines: */
+/* ZLANHF.F */
+
+/* Arguments */
+/* ========= */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* THRESH (input) 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. */
+
+/* A (workspace) COMPLEX*16 array, dimension (LDA,NMAX) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,NMAX). */
+
+/* ARF (workspace) COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2). */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension ( NMAX ) */
+
+/* ===================================================================== */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nval;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --arf;
+ --work;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ info = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+ eps = dlamch_("Precision");
+ small = dlamch_("Safe minimum");
+ large = 1. / small;
+ small = small * *lda * *lda;
+ large = large / *lda / *lda;
+
+ i__1 = *nn;
+ for (iin = 1; iin <= i__1; ++iin) {
+
+ n = nval[iin];
+
+ for (iit = 1; iit <= 3; ++iit) {
+
+/* IIT = 1 : random matrix */
+/* IIT = 2 : random matrix scaled near underflow */
+/* IIT = 3 : random matrix scaled near overflow */
+
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ zlarnd_(&z__1, &c__4, iseed);
+ a[i__4].r = z__1.r, a[i__4].i = z__1.i;
+ }
+ }
+
+ if (iit == 2) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__ + j * a_dim1;
+ z__1.r = large * a[i__5].r, z__1.i = large * a[i__5]
+ .i;
+ a[i__4].r = z__1.r, a[i__4].i = z__1.i;
+ }
+ }
+ }
+
+ if (iit == 3) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__ + j * a_dim1;
+ z__1.r = small * a[i__5].r, z__1.i = small * a[i__5]
+ .i;
+ a[i__4].r = z__1.r, a[i__4].i = z__1.i;
+ }
+ }
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+/* Do first for CFORM = 'N', then for CFORM = 'C' */
+
+ for (iform = 1; iform <= 2; ++iform) {
+
+ *(unsigned char *)cform = *(unsigned char *)&forms[iform
+ - 1];
+
+ s_copy(srnamc_1.srnamt, "ZTRTTF", (ftnlen)32, (ftnlen)6);
+ ztrttf_(cform, uplo, &n, &a[a_offset], lda, &arf[1], &
+ info);
+
+/* Check error code from ZTRTTF */
+
+ if (info != 0) {
+ if (nfail == 0 && nerrs == 0) {
+ io___22.ciunit = *nout;
+ s_wsle(&io___22);
+ e_wsle();
+ io___23.ciunit = *nout;
+ s_wsfe(&io___23);
+ e_wsfe();
+ }
+ io___24.ciunit = *nout;
+ s_wsfe(&io___24);
+ do_fio(&c__1, srnamc_1.srnamt, (ftnlen)32);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, cform, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ e_wsfe();
+ ++nerrs;
+ goto L100;
+ }
+
+ for (inorm = 1; inorm <= 4; ++inorm) {
+
+/* Check all four norms: 'M', '1', 'I', 'F' */
+
+ *(unsigned char *)norm = *(unsigned char *)&norms[
+ inorm - 1];
+ normarf = zlanhf_(norm, cform, uplo, &n, &arf[1], &
+ work[1]);
+ norma = zlanhe_(norm, uplo, &n, &a[a_offset], lda, &
+ work[1]);
+
+ result[0] = (norma - normarf) / norma / eps;
+ ++nrun;
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ io___30.ciunit = *nout;
+ s_wsle(&io___30);
+ e_wsle();
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ e_wsfe();
+ }
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "ZLANHF", (ftnlen)6);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&iit, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, cform, (ftnlen)1);
+ do_fio(&c__1, norm, (ftnlen)1);
+ do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L90: */
+ }
+L100:
+ ;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+
+/* Print a summary of the results. */
+
+ if (nfail == 0) {
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ do_fio(&c__1, "ZLANHF", (ftnlen)6);
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "ZLANHF", (ftnlen)6);
+ do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+ if (nerrs != 0) {
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, (char *)&nerrs, (ftnlen)sizeof(integer));
+ do_fio(&c__1, "ZLANHF", (ftnlen)6);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of ZDRVRF1 */
+
+} /* zdrvrf1_ */
diff --git a/TESTING/LIN/zdrvrf2.c b/TESTING/LIN/zdrvrf2.c
new file mode 100644
index 0000000..899e3ba
--- /dev/null
+++ b/TESTING/LIN/zdrvrf2.c
@@ -0,0 +1,326 @@
+/* zdrvrf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__4 = 4;
+static integer c__1 = 1;
+
+/* Subroutine */ int zdrvrf2_(integer *nout, integer *nn, integer *nval,
+ doublecomplex *a, integer *lda, doublecomplex *arf, doublecomplex *ap,
+ doublecomplex *asav)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char forms[1*2] = "N" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002 *** Error(s) while testing the RFP co"
+ "nvertion\002,\002 routines ***\002)";
+ static char fmt_9998[] = "(1x,\002 Error in RFP,convertion routines "
+ "N=\002,i5,\002 UPLO='\002,a1,\002', FORM ='\002,a1,\002'\002)";
+ static char fmt_9997[] = "(1x,\002All tests for the RFP convertion routi"
+ "nes passed (\002,i5,\002 tests run)\002)";
+ static char fmt_9996[] = "(1x,\002RFP convertion routines:\002,i5,\002 o"
+ "ut of \002,i5,\002 error message recorded\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, asav_dim1, asav_offset, i__1, i__2, i__3, i__4,
+ i__5;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void),
+ do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, n;
+ logical ok1, ok2;
+ integer iin, info;
+ char uplo[1];
+ integer nrun, iseed[4];
+ char cform[1];
+ integer iform;
+ logical lower;
+ integer iuplo, nerrs;
+ extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
+ integer *);
+ extern /* Subroutine */ int ztfttp_(char *, char *, integer *,
+ doublecomplex *, doublecomplex *, integer *),
+ ztpttf_(char *, char *, integer *, doublecomplex *, doublecomplex
+ *, integer *), ztfttr_(char *, char *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *), ztrttf_(char *, char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), ztrttp_(
+ char *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), ztpttr_(char *, integer *, doublecomplex *,
+ doublecomplex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___19 = { 0, 0, 0, 0, 0 };
+ static cilist io___20 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___21 = { 0, 0, 0, fmt_9998, 0 };
+ static cilist io___22 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___23 = { 0, 0, 0, fmt_9996, 0 };
+
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVRF2 tests the LAPACK RFP convertion routines. */
+
+/* Arguments */
+/* ========= */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* A (workspace) COMPLEX*16 array, dimension (LDA,NMAX) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,NMAX). */
+
+/* ARF (workspace) COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2). */
+
+/* AP (workspace) COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2). */
+
+/* A2 (workspace) COMPLEX*16 array, dimension (LDA,NMAX) */
+
+/* ===================================================================== */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nval;
+ asav_dim1 = *lda;
+ asav_offset = 1 + asav_dim1;
+ asav -= asav_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --arf;
+ --ap;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ nrun = 0;
+ nerrs = 0;
+ info = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+ i__1 = *nn;
+ for (iin = 1; iin <= i__1; ++iin) {
+
+ n = nval[iin];
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+ lower = TRUE_;
+ if (iuplo == 1) {
+ lower = FALSE_;
+ }
+
+/* Do first for CFORM = 'N', then for CFORM = 'C' */
+
+ for (iform = 1; iform <= 2; ++iform) {
+
+ *(unsigned char *)cform = *(unsigned char *)&forms[iform - 1];
+
+ ++nrun;
+
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ zlarnd_(&z__1, &c__4, iseed);
+ a[i__4].r = z__1.r, a[i__4].i = z__1.i;
+ }
+ }
+
+ s_copy(srnamc_1.srnamt, "ZTRTTF", (ftnlen)32, (ftnlen)6);
+ ztrttf_(cform, uplo, &n, &a[a_offset], lda, &arf[1], &info);
+
+ s_copy(srnamc_1.srnamt, "ZTFTTP", (ftnlen)32, (ftnlen)6);
+ ztfttp_(cform, uplo, &n, &arf[1], &ap[1], &info);
+
+ s_copy(srnamc_1.srnamt, "ZTPTTR", (ftnlen)32, (ftnlen)6);
+ ztpttr_(uplo, &n, &ap[1], &asav[asav_offset], lda, &info);
+
+ ok1 = TRUE_;
+ if (lower) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__ + j * asav_dim1;
+ if (a[i__4].r != asav[i__5].r || a[i__4].i !=
+ asav[i__5].i) {
+ ok1 = FALSE_;
+ }
+ }
+ }
+ } else {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__ + j * asav_dim1;
+ if (a[i__4].r != asav[i__5].r || a[i__4].i !=
+ asav[i__5].i) {
+ ok1 = FALSE_;
+ }
+ }
+ }
+ }
+
+ ++nrun;
+
+ s_copy(srnamc_1.srnamt, "ZTRTTP", (ftnlen)32, (ftnlen)6);
+ ztrttp_(uplo, &n, &a[a_offset], lda, &ap[1], &info)
+ ;
+
+ s_copy(srnamc_1.srnamt, "ZTPTTF", (ftnlen)32, (ftnlen)6);
+ ztpttf_(cform, uplo, &n, &ap[1], &arf[1], &info);
+
+ s_copy(srnamc_1.srnamt, "ZTFTTR", (ftnlen)32, (ftnlen)6);
+ ztfttr_(cform, uplo, &n, &arf[1], &asav[asav_offset], lda, &
+ info);
+
+ ok2 = TRUE_;
+ if (lower) {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = n;
+ for (i__ = j; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__ + j * asav_dim1;
+ if (a[i__4].r != asav[i__5].r || a[i__4].i !=
+ asav[i__5].i) {
+ ok2 = FALSE_;
+ }
+ }
+ }
+ } else {
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = j;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ i__5 = i__ + j * asav_dim1;
+ if (a[i__4].r != asav[i__5].r || a[i__4].i !=
+ asav[i__5].i) {
+ ok2 = FALSE_;
+ }
+ }
+ }
+ }
+
+ if (! ok1 || ! ok2) {
+ if (nerrs == 0) {
+ io___19.ciunit = *nout;
+ s_wsle(&io___19);
+ e_wsle();
+ io___20.ciunit = *nout;
+ s_wsfe(&io___20);
+ e_wsfe();
+ }
+ io___21.ciunit = *nout;
+ s_wsfe(&io___21);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, cform, (ftnlen)1);
+ e_wsfe();
+ ++nerrs;
+ }
+
+/* L100: */
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+
+/* Print a summary of the results. */
+
+ if (nerrs == 0) {
+ io___22.ciunit = *nout;
+ s_wsfe(&io___22);
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___23.ciunit = *nout;
+ s_wsfe(&io___23);
+ do_fio(&c__1, (char *)&nerrs, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of ZDRVRF2 */
+
+} /* zdrvrf2_ */
diff --git a/TESTING/LIN/zdrvrf3.c b/TESTING/LIN/zdrvrf3.c
new file mode 100644
index 0000000..c18735b
--- /dev/null
+++ b/TESTING/LIN/zdrvrf3.c
@@ -0,0 +1,474 @@
+/* zdrvrf3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__4 = 4;
+static integer c__5 = 5;
+static integer c__1 = 1;
+
+/* Subroutine */ int zdrvrf3_(integer *nout, integer *nn, integer *nval,
+ doublereal *thresh, doublecomplex *a, integer *lda, doublecomplex *
+ arf, doublecomplex *b1, doublecomplex *b2, doublereal *
+ d_work_zlange__, doublecomplex *z_work_zgeqrf__, doublecomplex *tau)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char forms[1*2] = "N" "C";
+ static char sides[1*2] = "L" "R";
+ static char transs[1*2] = "N" "C";
+ static char diags[1*2] = "N" "U";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002 *** Error(s) or Failure(s) while test"
+ "ing ZTFSM ***\002)";
+ static char fmt_9997[] = "(1x,\002 Failure in \002,a5,\002, CFORM="
+ "'\002,a1,\002',\002,\002 SIDE='\002,a1,\002',\002,\002 UPLO='"
+ "\002,a1,\002',\002,\002 TRANS='\002,a1,\002',\002,\002 DIAG='"
+ "\002,a1,\002',\002,\002 M=\002,i3,\002, N =\002,i3,\002, test"
+ "=\002,g12.5)";
+ static char fmt_9996[] = "(1x,\002All tests for \002,a5,\002 auxiliary r"
+ "outine passed the \002,\002threshold (\002,i5,\002 tests run)"
+ "\002)";
+ static char fmt_9995[] = "(1x,a6,\002 auxiliary routine:\002,i5,\002 out"
+ " of \002,i5,\002 tests failed to pass the threshold\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, b1_dim1, b1_offset, b2_dim1, b2_offset, i__1,
+ i__2, i__3, i__4, i__5, i__6, i__7;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void),
+ do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, m, n, na, iim, iin;
+ doublereal eps;
+ char diag[1], side[1];
+ integer info;
+ char uplo[1];
+ integer nrun, idiag;
+ doublecomplex alpha;
+ integer nfail, iseed[4], iside;
+ char cform[1];
+ integer iform;
+ char trans[1];
+ integer iuplo;
+ extern /* Subroutine */ int ztfsm_(char *, char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *), ztrsm_(char *, char *, char *, char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ integer ialpha;
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zgelqf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *
+);
+ extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
+ integer *);
+ extern /* Subroutine */ int zgeqrf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *
+);
+ integer itrans;
+ doublereal result[1];
+ extern /* Subroutine */ int ztrttf_(char *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___32 = { 0, 0, 0, 0, 0 };
+ static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___34 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___35 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___36 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVRF3 tests the LAPACK RFP routines: */
+/* ZTFSM */
+
+/* Arguments */
+/* ========= */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* THRESH (input) 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. */
+
+/* A (workspace) COMPLEX*16 array, dimension (LDA,NMAX) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,NMAX). */
+
+/* ARF (workspace) COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2). */
+
+/* B1 (workspace) COMPLEX*16 array, dimension (LDA,NMAX) */
+
+/* B2 (workspace) COMPLEX*16 array, dimension (LDA,NMAX) */
+
+/* D_WORK_ZLANGE (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* Z_WORK_ZGEQRF (workspace) COMPLEX*16 array, dimension (NMAX) */
+
+/* TAU (workspace) COMPLEX*16 array, dimension (NMAX) */
+
+/* ===================================================================== */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nval;
+ b2_dim1 = *lda;
+ b2_offset = 1 + b2_dim1;
+ b2 -= b2_offset;
+ b1_dim1 = *lda;
+ b1_offset = 1 + b1_dim1;
+ b1 -= b1_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --arf;
+ --d_work_zlange__;
+ --z_work_zgeqrf__;
+ --tau;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ nrun = 0;
+ nfail = 0;
+ info = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = dlamch_("Precision");
+
+ i__1 = *nn;
+ for (iim = 1; iim <= i__1; ++iim) {
+
+ m = nval[iim];
+
+ i__2 = *nn;
+ for (iin = 1; iin <= i__2; ++iin) {
+
+ n = nval[iin];
+
+ for (iform = 1; iform <= 2; ++iform) {
+
+ *(unsigned char *)cform = *(unsigned char *)&forms[iform - 1];
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+
+ for (iside = 1; iside <= 2; ++iside) {
+
+ *(unsigned char *)side = *(unsigned char *)&sides[
+ iside - 1];
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+
+ *(unsigned char *)trans = *(unsigned char *)&
+ transs[itrans - 1];
+
+ for (idiag = 1; idiag <= 2; ++idiag) {
+
+ *(unsigned char *)diag = *(unsigned char *)&
+ diags[idiag - 1];
+
+ for (ialpha = 1; ialpha <= 3; ++ialpha) {
+
+ if (ialpha == 1) {
+ alpha.r = 0., alpha.i = 0.;
+ } else if (ialpha == 1) {
+ alpha.r = 1., alpha.i = 0.;
+ } else {
+ zlarnd_(&z__1, &c__4, iseed);
+ alpha.r = z__1.r, alpha.i = z__1.i;
+ }
+
+/* All the parameters are set: */
+/* CFORM, SIDE, UPLO, TRANS, DIAG, M, N, */
+/* and ALPHA */
+/* READY TO TEST! */
+
+ ++nrun;
+
+ if (iside == 1) {
+
+/* The case ISIDE.EQ.1 is when SIDE.EQ.'L' */
+/* -> A is M-by-M ( B is M-by-N ) */
+
+ na = m;
+
+ } else {
+
+/* The case ISIDE.EQ.2 is when SIDE.EQ.'R' */
+/* -> A is N-by-N ( B is M-by-N ) */
+
+ na = n;
+
+ }
+
+/* Generate A our NA--by--NA triangular */
+/* matrix. */
+/* Our test is based on forward error so we */
+/* do want A to be well conditionned! To get */
+/* a well-conditionned triangular matrix, we */
+/* take the R factor of the QR/LQ factorization */
+/* of a random matrix. */
+
+ i__3 = na;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = na;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__ + j * a_dim1;
+ zlarnd_(&z__1, &c__4, iseed);
+ a[i__5].r = z__1.r, a[i__5].i =
+ z__1.i;
+ }
+ }
+
+ if (iuplo == 1) {
+
+/* The case IUPLO.EQ.1 is when SIDE.EQ.'U' */
+/* -> QR factorization. */
+
+ s_copy(srnamc_1.srnamt, "ZGEQRF", (
+ ftnlen)32, (ftnlen)6);
+ zgeqrf_(&na, &na, &a[a_offset], lda, &
+ tau[1], &z_work_zgeqrf__[1],
+ lda, &info);
+ } else {
+
+/* The case IUPLO.EQ.2 is when SIDE.EQ.'L' */
+/* -> QL factorization. */
+
+ s_copy(srnamc_1.srnamt, "ZGELQF", (
+ ftnlen)32, (ftnlen)6);
+ zgelqf_(&na, &na, &a[a_offset], lda, &
+ tau[1], &z_work_zgeqrf__[1],
+ lda, &info);
+ }
+
+/* After the QR factorization, the diagonal */
+/* of A is made of real numbers, we multiply */
+/* by a random complex number of absolute */
+/* value 1.0E+00. */
+
+ i__3 = na;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j + j * a_dim1;
+ i__5 = j + j * a_dim1;
+ zlarnd_(&z__2, &c__5, iseed);
+ z__1.r = a[i__5].r * z__2.r - a[i__5]
+ .i * z__2.i, z__1.i = a[i__5]
+ .r * z__2.i + a[i__5].i *
+ z__2.r;
+ a[i__4].r = z__1.r, a[i__4].i =
+ z__1.i;
+ }
+
+/* Store a copy of A in RFP format (in ARF). */
+
+ s_copy(srnamc_1.srnamt, "ZTRTTF", (ftnlen)
+ 32, (ftnlen)6);
+ ztrttf_(cform, uplo, &na, &a[a_offset],
+ lda, &arf[1], &info);
+
+/* Generate B1 our M--by--N right-hand side */
+/* and store a copy in B2. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = m;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__ + j * b1_dim1;
+ zlarnd_(&z__1, &c__4, iseed);
+ b1[i__5].r = z__1.r, b1[i__5].i =
+ z__1.i;
+ i__5 = i__ + j * b2_dim1;
+ i__6 = i__ + j * b1_dim1;
+ b2[i__5].r = b1[i__6].r, b2[i__5]
+ .i = b1[i__6].i;
+ }
+ }
+
+/* Solve op( A ) X = B or X op( A ) = B */
+/* with ZTRSM */
+
+ s_copy(srnamc_1.srnamt, "ZTRSM", (ftnlen)
+ 32, (ftnlen)5);
+ ztrsm_(side, uplo, trans, diag, &m, &n, &
+ alpha, &a[a_offset], lda, &b1[
+ b1_offset], lda);
+
+/* Solve op( A ) X = B or X op( A ) = B */
+/* with ZTFSM */
+
+ s_copy(srnamc_1.srnamt, "ZTFSM", (ftnlen)
+ 32, (ftnlen)5);
+ ztfsm_(cform, side, uplo, trans, diag, &m,
+ &n, &alpha, &arf[1], &b2[
+ b2_offset], lda);
+
+/* Check that the result agrees. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = m;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__ + j * b1_dim1;
+ i__6 = i__ + j * b2_dim1;
+ i__7 = i__ + j * b1_dim1;
+ z__1.r = b2[i__6].r - b1[i__7].r,
+ z__1.i = b2[i__6].i - b1[
+ i__7].i;
+ b1[i__5].r = z__1.r, b1[i__5].i =
+ z__1.i;
+ }
+ }
+
+ result[0] = zlange_("I", &m, &n, &b1[
+ b1_offset], lda, &d_work_zlange__[
+ 1]);
+
+/* Computing MAX */
+ i__3 = max(m,n);
+ result[0] = result[0] / sqrt(eps) / max(
+ i__3,1);
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0) {
+ io___32.ciunit = *nout;
+ s_wsle(&io___32);
+ e_wsle();
+ io___33.ciunit = *nout;
+ s_wsfe(&io___33);
+ e_wsfe();
+ }
+ io___34.ciunit = *nout;
+ s_wsfe(&io___34);
+ do_fio(&c__1, "ZTFSM", (ftnlen)5);
+ do_fio(&c__1, cform, (ftnlen)1);
+ do_fio(&c__1, side, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, diag, (ftnlen)1);
+ do_fio(&c__1, (char *)&m, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&n, (ftnlen)
+ sizeof(integer));
+ do_fio(&c__1, (char *)&result[0], (
+ ftnlen)sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+
+/* L100: */
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+
+/* Print a summary of the results. */
+
+ if (nfail == 0) {
+ io___35.ciunit = *nout;
+ s_wsfe(&io___35);
+ do_fio(&c__1, "ZTFSM", (ftnlen)5);
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___36.ciunit = *nout;
+ s_wsfe(&io___36);
+ do_fio(&c__1, "ZTFSM", (ftnlen)5);
+ do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of ZDRVRF3 */
+
+} /* zdrvrf3_ */
diff --git a/TESTING/LIN/zdrvrf4.c b/TESTING/LIN/zdrvrf4.c
new file mode 100644
index 0000000..5b9949f
--- /dev/null
+++ b/TESTING/LIN/zdrvrf4.c
@@ -0,0 +1,426 @@
+/* zdrvrf4.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__4 = 4;
+static integer c__1 = 1;
+
+/* Subroutine */ int zdrvrf4_(integer *nout, integer *nn, integer *nval,
+ doublereal *thresh, doublecomplex *c1, doublecomplex *c2, integer *
+ ldc, doublecomplex *crf, doublecomplex *a, integer *lda, doublereal *
+ d_work_zlange__)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char forms[1*2] = "N" "C";
+ static char transs[1*2] = "N" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002 *** Error(s) or Failure(s) while test"
+ "ing ZHFRK ***\002)";
+ static char fmt_9997[] = "(1x,\002 Failure in \002,a5,\002, CFORM="
+ "'\002,a1,\002',\002,\002 UPLO='\002,a1,\002',\002,\002 TRANS="
+ "'\002,a1,\002',\002,\002 N=\002,i3,\002, K =\002,i3,\002, test"
+ "=\002,g12.5)";
+ static char fmt_9996[] = "(1x,\002All tests for \002,a5,\002 auxiliary r"
+ "outine passed the \002,\002threshold (\002,i5,\002 tests run)"
+ "\002)";
+ static char fmt_9995[] = "(1x,a6,\002 auxiliary routine:\002,i5,\002 out"
+ " of \002,i5,\002 tests failed to pass the threshold\002)";
+
+ /* System generated locals */
+ integer a_dim1, a_offset, c1_dim1, c1_offset, c2_dim1, c2_offset, i__1,
+ i__2, i__3, i__4, i__5, i__6, i__7;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void),
+ do_fio(integer *, char *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k, n, iik, iin;
+ doublereal eps, beta;
+ integer info;
+ char uplo[1];
+ integer nrun;
+ doublereal alpha;
+ integer nfail, iseed[4];
+ char cform[1];
+ integer iform;
+ doublereal norma, normc;
+ extern /* Subroutine */ int zherk_(char *, char *, integer *, integer *,
+ doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *), zhfrk_(char *, char *
+, char *, integer *, integer *, doublereal *, doublecomplex *,
+ integer *, doublereal *, doublecomplex *);
+ char trans[1];
+ integer iuplo;
+ extern doublereal dlamch_(char *);
+ integer ialpha;
+ extern doublereal dlarnd_(integer *, integer *), zlange_(char *, integer *
+, integer *, doublecomplex *, integer *, doublereal *);
+ extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
+ integer *);
+ integer itrans;
+ doublereal result[1];
+ extern /* Subroutine */ int ztfttr_(char *, char *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *), ztrttf_(char *, char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___28 = { 0, 0, 0, 0, 0 };
+ static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___30 = { 0, 0, 0, fmt_9997, 0 };
+ static cilist io___31 = { 0, 0, 0, fmt_9996, 0 };
+ static cilist io___32 = { 0, 0, 0, fmt_9995, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVRF4 tests the LAPACK RFP routines: */
+/* ZHFRK */
+
+/* Arguments */
+/* ========= */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* THRESH (input) 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. */
+
+/* C1 (workspace) COMPLEX*16 array, dimension (LDC,NMAX) */
+
+/* C2 (workspace) COMPLEX*16 array, dimension (LDC,NMAX) */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,NMAX). */
+
+/* CRF (workspace) COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2). */
+
+/* A (workspace) COMPLEX*16 array, dimension (LDA,NMAX) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,NMAX). */
+
+/* D_WORK_ZLANGE (workspace) DOUBLE PRECISION array, dimension (NMAX) */
+
+/* ===================================================================== */
+/* .. */
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nval;
+ c2_dim1 = *ldc;
+ c2_offset = 1 + c2_dim1;
+ c2 -= c2_offset;
+ c1_dim1 = *ldc;
+ c1_offset = 1 + c1_dim1;
+ c1 -= c1_offset;
+ --crf;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --d_work_zlange__;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ nrun = 0;
+ nfail = 0;
+ info = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+ eps = dlamch_("Precision");
+
+ i__1 = *nn;
+ for (iin = 1; iin <= i__1; ++iin) {
+
+ n = nval[iin];
+
+ i__2 = *nn;
+ for (iik = 1; iik <= i__2; ++iik) {
+
+ k = nval[iin];
+
+ for (iform = 1; iform <= 2; ++iform) {
+
+ *(unsigned char *)cform = *(unsigned char *)&forms[iform - 1];
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+
+ *(unsigned char *)trans = *(unsigned char *)&transs[
+ itrans - 1];
+
+ for (ialpha = 1; ialpha <= 4; ++ialpha) {
+
+ if (ialpha == 1) {
+ alpha = 0.;
+ beta = 0.;
+ } else if (ialpha == 1) {
+ alpha = 1.;
+ beta = 0.;
+ } else if (ialpha == 1) {
+ alpha = 0.;
+ beta = 1.;
+ } else {
+ alpha = dlarnd_(&c__2, iseed);
+ beta = dlarnd_(&c__2, iseed);
+ }
+
+/* All the parameters are set: */
+/* CFORM, UPLO, TRANS, M, N, */
+/* ALPHA, and BETA */
+/* READY TO TEST! */
+
+ ++nrun;
+
+ if (itrans == 1) {
+
+/* In this case we are NOTRANS, so A is N-by-K */
+
+ i__3 = k;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__ + j * a_dim1;
+ zlarnd_(&z__1, &c__4, iseed);
+ a[i__5].r = z__1.r, a[i__5].i =
+ z__1.i;
+ }
+ }
+
+ norma = zlange_("I", &n, &k, &a[a_offset],
+ lda, &d_work_zlange__[1]);
+
+ } else {
+
+/* In this case we are TRANS, so A is K-by-N */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = k;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__ + j * a_dim1;
+ zlarnd_(&z__1, &c__4, iseed);
+ a[i__5].r = z__1.r, a[i__5].i =
+ z__1.i;
+ }
+ }
+
+ norma = zlange_("I", &k, &n, &a[a_offset],
+ lda, &d_work_zlange__[1]);
+
+ }
+
+
+/* Generate C1 our N--by--N Hermitian matrix. */
+/* Make sure C2 has the same upper/lower part, */
+/* (the one that we do not touch), so */
+/* copy the initial C1 in C2 in it. */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__ + j * c1_dim1;
+ zlarnd_(&z__1, &c__4, iseed);
+ c1[i__5].r = z__1.r, c1[i__5].i = z__1.i;
+ i__5 = i__ + j * c2_dim1;
+ i__6 = i__ + j * c1_dim1;
+ c2[i__5].r = c1[i__6].r, c2[i__5].i = c1[
+ i__6].i;
+ }
+ }
+
+/* (See comment later on for why we use ZLANGE and */
+/* not ZLANHE for C1.) */
+
+ normc = zlange_("I", &n, &n, &c1[c1_offset], ldc,
+ &d_work_zlange__[1]);
+
+ s_copy(srnamc_1.srnamt, "ZTRTTF", (ftnlen)32, (
+ ftnlen)6);
+ ztrttf_(cform, uplo, &n, &c1[c1_offset], ldc, &
+ crf[1], &info);
+
+/* call zherk the BLAS routine -> gives C1 */
+
+ s_copy(srnamc_1.srnamt, "ZHERK ", (ftnlen)32, (
+ ftnlen)6);
+ zherk_(uplo, trans, &n, &k, &alpha, &a[a_offset],
+ lda, &beta, &c1[c1_offset], ldc);
+
+/* call zhfrk the RFP routine -> gives CRF */
+
+ s_copy(srnamc_1.srnamt, "ZHFRK ", (ftnlen)32, (
+ ftnlen)6);
+ zhfrk_(cform, uplo, trans, &n, &k, &alpha, &a[
+ a_offset], lda, &beta, &crf[1]);
+
+/* convert CRF in full format -> gives C2 */
+
+ s_copy(srnamc_1.srnamt, "ZTFTTR", (ftnlen)32, (
+ ftnlen)6);
+ ztfttr_(cform, uplo, &n, &crf[1], &c2[c2_offset],
+ ldc, &info);
+
+/* compare C1 and C2 */
+
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = i__ + j * c1_dim1;
+ i__6 = i__ + j * c1_dim1;
+ i__7 = i__ + j * c2_dim1;
+ z__1.r = c1[i__6].r - c2[i__7].r, z__1.i =
+ c1[i__6].i - c2[i__7].i;
+ c1[i__5].r = z__1.r, c1[i__5].i = z__1.i;
+ }
+ }
+
+/* Yes, C1 is Hermitian so we could call ZLANHE, */
+/* but we want to check the upper part that is */
+/* supposed to be unchanged and the diagonal that */
+/* is supposed to be real -> ZLANGE */
+
+ result[0] = zlange_("I", &n, &n, &c1[c1_offset],
+ ldc, &d_work_zlange__[1]);
+/* Computing MAX */
+ d__1 = abs(alpha) * norma * norma + abs(beta) *
+ normc;
+ result[0] = result[0] / max(d__1,1.) / max(n,1) /
+ eps;
+
+ if (result[0] >= *thresh) {
+ if (nfail == 0) {
+ io___28.ciunit = *nout;
+ s_wsle(&io___28);
+ e_wsle();
+ io___29.ciunit = *nout;
+ s_wsfe(&io___29);
+ e_wsfe();
+ }
+ io___30.ciunit = *nout;
+ s_wsfe(&io___30);
+ do_fio(&c__1, "ZHFRK", (ftnlen)5);
+ do_fio(&c__1, cform, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, trans, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[0], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+
+/* L100: */
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+
+/* Print a summary of the results. */
+
+ if (nfail == 0) {
+ io___31.ciunit = *nout;
+ s_wsfe(&io___31);
+ do_fio(&c__1, "ZHFRK", (ftnlen)5);
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ io___32.ciunit = *nout;
+ s_wsfe(&io___32);
+ do_fio(&c__1, "ZHFRK", (ftnlen)5);
+ do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of ZDRVRF4 */
+
+} /* zdrvrf4_ */
diff --git a/TESTING/LIN/zdrvrfp.c b/TESTING/LIN/zdrvrfp.c
new file mode 100644
index 0000000..4023441
--- /dev/null
+++ b/TESTING/LIN/zdrvrfp.c
@@ -0,0 +1,605 @@
+/* zdrvrfp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+
+/* Subroutine */ int zdrvrfp_(integer *nout, integer *nn, integer *nval,
+ integer *nns, integer *nsval, integer *nnt, integer *ntval,
+ doublereal *thresh, doublecomplex *a, doublecomplex *asav,
+ doublecomplex *afac, doublecomplex *ainv, doublecomplex *b,
+ doublecomplex *bsav, doublecomplex *xact, doublecomplex *x,
+ doublecomplex *arf, doublecomplex *arfinv, doublecomplex *
+ z_work_zlatms__, doublecomplex *z_work_zpot01__, doublecomplex *
+ z_work_zpot02__, doublecomplex *z_work_zpot03__, doublereal *
+ d_work_zlatms__, doublereal *d_work_zlanhe__, doublereal *
+ d_work_zpot02__, doublereal *d_work_zpot03__)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char forms[1*2] = "N" "C";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a6,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6, i__7;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ integer i__, k, n, kl, ku, nt, lda, ldb, iin, iis, iit, ioff, mode, info,
+ imat;
+ char dist[1];
+ integer nrhs;
+ char uplo[1];
+ integer nrun, nfail, iseed[4];
+ char cform[1];
+ integer iform;
+ doublereal anorm;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+);
+ char ctype[1];
+ integer iuplo, nerrs, izero;
+ extern /* Subroutine */ int zpot01_(char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *), zpot02_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *),
+ zpot03_(char *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *);
+ logical zerot;
+ extern /* Subroutine */ int zlatb4_(char *, integer *, integer *, integer
+ *, char *, integer *, integer *, doublereal *, integer *,
+ doublereal *, char *), aladhd_(integer *,
+ char *), alaerh_(char *, char *, integer *, integer *,
+ char *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *);
+ doublereal rcondc;
+ extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum;
+ extern /* Subroutine */ int zlaipd_(integer *, doublecomplex *, integer *,
+ integer *);
+ doublereal ainvnm;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlarhs_(char *, char *, char *, char *, integer *, integer *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ integer *), zlatms_(integer *,
+ integer *, char *, integer *, char *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, integer *, char *,
+ doublecomplex *, integer *, doublecomplex *, integer *), zpftrf_(char *, char *, integer *, doublecomplex
+ *, integer *);
+ doublereal result[4];
+ extern /* Subroutine */ int zpftri_(char *, char *, integer *,
+ doublecomplex *, integer *), zpotrf_(char *,
+ integer *, doublecomplex *, integer *, integer *),
+ zpotri_(char *, integer *, doublecomplex *, integer *, integer *), zpftrs_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *), ztfttr_(char *, char *, integer *, doublecomplex *,
+ doublecomplex *, integer *, integer *), ztrttf_(
+ char *, char *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___37 = { 0, 0, 0, fmt_9999, 0 };
+
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVRFP tests the LAPACK RFP routines: */
+/* ZPFTRF, ZPFTRS, and ZPFTRI. */
+
+/* This testing routine follow the same tests as ZDRVPO (test for the full */
+/* format Symmetric Positive Definite solver). */
+
+/* The tests are performed in Full Format, convertion back and forth from */
+/* full format to RFP format are performed using the routines ZTRTTF and */
+/* ZTFTTR. */
+
+/* First, a specific matrix A of size N is created. There is nine types of */
+/* different matrixes possible. */
+/* 1. Diagonal 6. Random, CNDNUM = sqrt(0.1/EPS) */
+/* 2. Random, CNDNUM = 2 7. Random, CNDNUM = 0.1/EPS */
+/* *3. First row and column zero 8. Scaled near underflow */
+/* *4. Last row and column zero 9. Scaled near overflow */
+/* *5. Middle row and column zero */
+/* (* - tests error exits from ZPFTRF, no test ratios are computed) */
+/* A solution XACT of size N-by-NRHS is created and the associated right */
+/* hand side B as well. Then ZPFTRF is called to compute L (or U), the */
+/* Cholesky factor of A. Then L (or U) is used to solve the linear system */
+/* of equations AX = B. This gives X. Then L (or U) is used to compute the */
+/* inverse of A, AINV. The following four tests are then performed: */
+/* (1) norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
+/* norm( U'*U - A ) / ( N * norm(A) * EPS ), */
+/* (2) norm(B - A*X) / ( norm(A) * norm(X) * EPS ), */
+/* (3) norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* (4) ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ), */
+/* where EPS is the machine precision, RCOND the condition number of A, and */
+/* norm( . ) the 1-norm for (1,2,3) and the inf-norm for (4). */
+/* Errors occur when INFO parameter is not as expected. Failures occur when */
+/* a test ratios is greater than THRES. */
+
+/* Arguments */
+/* ========= */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NNS (input) INTEGER */
+/* The number of values of NRHS contained in the vector NSVAL. */
+
+/* NSVAL (input) INTEGER array, dimension (NNS) */
+/* The values of the number of right-hand sides NRHS. */
+
+/* NNT (input) INTEGER */
+/* The number of values of MATRIX TYPE contained in the vector NTVAL. */
+
+/* NTVAL (input) INTEGER array, dimension (NNT) */
+/* The values of matrix type (between 0 and 9 for PO/PP/PF matrices). */
+
+/* THRESH (input) 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. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* ASAV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*MAXRHS) */
+
+/* BSAV (workspace) COMPLEX*16 array, dimension (NMAX*MAXRHS) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*MAXRHS) */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*MAXRHS) */
+
+/* ARF (workspace) COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2) */
+
+/* ARFINV (workspace) COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2) */
+
+/* Z_WORK_ZLATMS (workspace) COMPLEX*16 array, dimension ( 3*NMAX ) */
+
+/* Z_WORK_ZPOT01 (workspace) COMPLEX*16 array, dimension ( NMAX ) */
+
+/* Z_WORK_ZPOT02 (workspace) COMPLEX*16 array, dimension ( NMAX*MAXRHS ) */
+
+/* Z_WORK_ZPOT03 (workspace) COMPLEX*16 array, dimension ( NMAX*NMAX ) */
+
+/* D_WORK_ZLATMS (workspace) DOUBLE PRECISION array, dimension ( NMAX ) */
+
+/* D_WORK_ZLANHE (workspace) DOUBLE PRECISION array, dimension ( NMAX ) */
+
+/* D_WORK_ZPOT02 (workspace) DOUBLE PRECISION array, dimension ( NMAX ) */
+
+/* D_WORK_ZPOT03 (workspace) DOUBLE PRECISION array, dimension ( NMAX ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --nval;
+ --nsval;
+ --ntval;
+ --a;
+ --asav;
+ --afac;
+ --ainv;
+ --b;
+ --bsav;
+ --xact;
+ --x;
+ --arf;
+ --arfinv;
+ --z_work_zlatms__;
+ --z_work_zpot01__;
+ --z_work_zpot02__;
+ --z_work_zpot03__;
+ --d_work_zlatms__;
+ --d_work_zlanhe__;
+ --d_work_zpot02__;
+ --d_work_zpot03__;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+ i__1 = *nn;
+ for (iin = 1; iin <= i__1; ++iin) {
+
+ n = nval[iin];
+ lda = max(n,1);
+ ldb = max(n,1);
+
+ i__2 = *nns;
+ for (iis = 1; iis <= i__2; ++iis) {
+
+ nrhs = nsval[iis];
+
+ i__3 = *nnt;
+ for (iit = 1; iit <= i__3; ++iit) {
+
+ imat = ntval[iit];
+
+/* If N.EQ.0, only consider the first type */
+
+ if (n == 0 && iit > 1) {
+ goto L120;
+ }
+
+/* Skip types 3, 4, or 5 if the matrix size is too small. */
+
+ if (imat == 4 && n <= 1) {
+ goto L120;
+ }
+ if (imat == 5 && n <= 2) {
+ goto L120;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
+ 1];
+
+/* Do first for CFORM = 'N', then for CFORM = 'C' */
+
+ for (iform = 1; iform <= 2; ++iform) {
+ *(unsigned char *)cform = *(unsigned char *)&forms[
+ iform - 1];
+
+/* Set up parameters with ZLATB4 and generate a test */
+/* matrix with ZLATMS. */
+
+ zlatb4_("ZPO", &imat, &n, &n, ctype, &kl, &ku, &anorm,
+ &mode, &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)
+ 6);
+ zlatms_(&n, &n, dist, iseed, ctype, &d_work_zlatms__[
+ 1], &mode, &cndnum, &anorm, &kl, &ku, uplo, &
+ a[1], &lda, &z_work_zlatms__[1], &info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_("ZPF", "ZLATMS", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &c_n1, &iit, &nfail, &
+ nerrs, nout);
+ goto L100;
+ }
+
+/* For types 3-5, zero one row and column of the matrix to */
+/* test that INFO is returned correctly. */
+
+ zerot = imat >= 3 && imat <= 5;
+ if (zerot) {
+ if (iit == 3) {
+ izero = 1;
+ } else if (iit == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+ ioff = (izero - 1) * lda;
+
+/* Set row and column IZERO of A to 0. */
+
+ if (iuplo == 1) {
+ i__4 = izero - 1;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0., a[i__5].i = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__4 = n;
+ for (i__ = izero; i__ <= i__4; ++i__) {
+ i__5 = ioff;
+ a[i__5].r = 0., a[i__5].i = 0.;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__4 = izero - 1;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ioff;
+ a[i__5].r = 0., a[i__5].i = 0.;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__4 = n;
+ for (i__ = izero; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0., a[i__5].i = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ izero = 0;
+ }
+
+/* Set the imaginary part of the diagonals. */
+
+ i__4 = lda + 1;
+ zlaipd_(&n, &a[1], &i__4, &c__0);
+
+/* Save a copy of the matrix A in ASAV. */
+
+ zlacpy_(uplo, &n, &n, &a[1], &lda, &asav[1], &lda);
+
+/* Compute the condition number of A (RCONDC). */
+
+ if (zerot) {
+ rcondc = 0.;
+ } else {
+
+/* Compute the 1-norm of A. */
+
+ anorm = zlanhe_("1", uplo, &n, &a[1], &lda, &
+ d_work_zlanhe__[1]);
+
+/* Factor the matrix A. */
+
+ zpotrf_(uplo, &n, &a[1], &lda, &info);
+
+/* Form the inverse of A. */
+
+ zpotri_(uplo, &n, &a[1], &lda, &info);
+
+/* Compute the 1-norm condition number of A. */
+
+ ainvnm = zlanhe_("1", uplo, &n, &a[1], &lda, &
+ d_work_zlanhe__[1]);
+ rcondc = 1. / anorm / ainvnm;
+
+/* Restore the matrix A. */
+
+ zlacpy_(uplo, &n, &n, &asav[1], &lda, &a[1], &lda);
+
+ }
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (ftnlen)
+ 6);
+ zlarhs_("ZPO", "N", uplo, " ", &n, &n, &kl, &ku, &
+ nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
+ lda, iseed, &info);
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &bsav[1], &
+ lda);
+
+/* Compute the L*L' or U'*U factorization of the */
+/* matrix and solve the system. */
+
+ zlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ zlacpy_("Full", &n, &nrhs, &b[1], &ldb, &x[1], &ldb);
+
+ s_copy(srnamc_1.srnamt, "ZTRTTF", (ftnlen)32, (ftnlen)
+ 6);
+ ztrttf_(cform, uplo, &n, &afac[1], &lda, &arf[1], &
+ info);
+ s_copy(srnamc_1.srnamt, "ZPFTRF", (ftnlen)32, (ftnlen)
+ 6);
+ zpftrf_(cform, uplo, &n, &arf[1], &info);
+
+/* Check error code from ZPFTRF. */
+
+ if (info != izero) {
+
+/* LANGOU: there is a small hick here: IZERO should */
+/* always be INFO however if INFO is ZERO, ALAERH does not */
+/* complain. */
+
+ alaerh_("ZPF", "ZPFSV ", &info, &izero, uplo, &n,
+ &n, &c_n1, &c_n1, &nrhs, &iit, &nfail, &
+ nerrs, nout);
+ goto L100;
+ }
+
+/* Skip the tests if INFO is not 0. */
+
+ if (info != 0) {
+ goto L100;
+ }
+
+ s_copy(srnamc_1.srnamt, "ZPFTRS", (ftnlen)32, (ftnlen)
+ 6);
+ zpftrs_(cform, uplo, &n, &nrhs, &arf[1], &x[1], &ldb,
+ &info);
+
+ s_copy(srnamc_1.srnamt, "ZTFTTR", (ftnlen)32, (ftnlen)
+ 6);
+ ztfttr_(cform, uplo, &n, &arf[1], &afac[1], &lda, &
+ info);
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zlacpy_(uplo, &n, &n, &afac[1], &lda, &asav[1], &lda);
+ zpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
+ z_work_zpot01__[1], result);
+ zlacpy_(uplo, &n, &n, &asav[1], &lda, &afac[1], &lda);
+
+/* Form the inverse and compute the residual. */
+
+ if (n % 2 == 0) {
+ i__4 = n + 1;
+ i__5 = n / 2;
+ i__6 = n + 1;
+ i__7 = n + 1;
+ zlacpy_("A", &i__4, &i__5, &arf[1], &i__6, &
+ arfinv[1], &i__7);
+ } else {
+ i__4 = (n + 1) / 2;
+ zlacpy_("A", &n, &i__4, &arf[1], &n, &arfinv[1], &
+ n);
+ }
+
+ s_copy(srnamc_1.srnamt, "ZPFTRI", (ftnlen)32, (ftnlen)
+ 6);
+ zpftri_(cform, uplo, &n, &arfinv[1], &info);
+
+ s_copy(srnamc_1.srnamt, "ZTFTTR", (ftnlen)32, (ftnlen)
+ 6);
+ ztfttr_(cform, uplo, &n, &arfinv[1], &ainv[1], &lda, &
+ info);
+
+/* Check error code from ZPFTRI. */
+
+ if (info != 0) {
+ alaerh_("ZPO", "ZPFTRI", &info, &c__0, uplo, &n, &
+ n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
+ nerrs, nout);
+ }
+
+ zpot03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &
+ z_work_zpot03__[1], &lda, &d_work_zpot03__[1],
+ &rcondc, &result[1]);
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, &nrhs, &b[1], &lda, &
+ z_work_zpot02__[1], &lda);
+ zpot02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
+ z_work_zpot02__[1], &lda, &d_work_zpot02__[1],
+ &result[2]);
+
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[3]);
+ nt = 4;
+
+/* Print information about the tests that did not */
+/* pass the threshold. */
+
+ i__4 = nt;
+ for (k = 1; k <= i__4; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, "ZPF");
+ }
+ io___37.ciunit = *nout;
+ s_wsfe(&io___37);
+ do_fio(&c__1, "ZPFSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&iit, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L60: */
+ }
+ nrun += nt;
+L100:
+ ;
+ }
+/* L110: */
+ }
+L120:
+ ;
+ }
+/* L980: */
+ }
+/* L130: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_("ZPF", nout, &nfail, &nrun, &nerrs);
+
+
+ return 0;
+
+/* End of ZDRVRFP */
+
+} /* zdrvrfp_ */
diff --git a/TESTING/LIN/zdrvsp.c b/TESTING/LIN/zdrvsp.c
new file mode 100644
index 0000000..775f1fd
--- /dev/null
+++ b/TESTING/LIN/zdrvsp.c
@@ -0,0 +1,701 @@
+/* zdrvsp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublecomplex c_b61 = {0.,0.};
+
+/* Subroutine */ int zdrvsp_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
+ doublecomplex *a, doublecomplex *afac, doublecomplex *ainv,
+ doublecomplex *b, doublecomplex *x, doublecomplex *xact,
+ doublecomplex *work, doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char facts[1*2] = "F" "N";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002,"
+ " ratio =\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5, i__6[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, k1, nb, in, kl, ku, nt, lda, npp;
+ char fact[1];
+ integer ioff, mode, imat, info;
+ char path[3], dist[1], uplo[1], type__[1];
+ integer nrun, ifact, nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ integer nbmin;
+ doublereal rcond;
+ integer nimat;
+ doublereal anorm;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+);
+ integer iuplo, izero, nerrs;
+ extern /* Subroutine */ int zspt01_(char *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *), zppt05_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *);
+ logical zerot;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zspt02_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *);
+ char xtype[1];
+ extern /* Subroutine */ int zspsv_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *), zlatb4_(char *, integer *, integer *, integer *, char *,
+ integer *, integer *, doublereal *, integer *, doublereal *,
+ char *), aladhd_(integer *, char *), alaerh_(char *, char *, integer *, integer *, char *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *);
+ doublereal rcondc;
+ char packit[1];
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum, ainvnm;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *), zlarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *), zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+ extern doublereal zlansp_(char *, char *, integer *, doublecomplex *,
+ doublereal *);
+ extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zlatsp_(char
+ *, integer *, doublecomplex *, integer *);
+ doublereal result[6];
+ extern /* Subroutine */ int zsptrf_(char *, integer *, doublecomplex *,
+ integer *, integer *), zsptri_(char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zerrvx_(char *, integer *), zspsvx_(char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, doublecomplex *,
+ doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVSP tests the driver routines ZSPSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AFAC (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* AINV (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*(NMAX+1)/2) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(2,NRHS)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "SP", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ npp = n * (n + 1) / 2;
+ *(unsigned char *)xtype = 'N';
+ nimat = 11;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L170;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L170;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ if (iuplo == 1) {
+ *(unsigned char *)uplo = 'U';
+ *(unsigned char *)packit = 'C';
+ } else {
+ *(unsigned char *)uplo = 'L';
+ *(unsigned char *)packit = 'R';
+ }
+
+ if (imat != 11) {
+
+/* Set up parameters with ZLATB4 and generate a test */
+/* matrix with ZLATMS. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
+ mode, &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, packit, &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ goto L160;
+ }
+
+/* For types 3-6, zero one or more rows and columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * izero / 2;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff += i__;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff = ioff + n - i__;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows and columns to zero. */
+
+ ioff = 0;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0., a[i__5].i = 0.;
+/* L60: */
+ }
+ ioff += j;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows and columns to zero. */
+
+ ioff = 0;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0., a[i__5].i = 0.;
+/* L80: */
+ }
+ ioff = ioff + n - j;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+ } else {
+
+/* Use a special block diagonal matrix to test alternate */
+/* code for the 2-by-2 blocks. */
+
+ zlatsp_(uplo, &n, &a[1], iseed);
+ }
+
+ for (ifact = 1; ifact <= 2; ++ifact) {
+
+/* Do first for FACT = 'F', then for other values. */
+
+ *(unsigned char *)fact = *(unsigned char *)&facts[ifact -
+ 1];
+
+/* Compute the condition number for comparison with */
+/* the value returned by ZSPSVX. */
+
+ if (zerot) {
+ if (ifact == 1) {
+ goto L150;
+ }
+ rcondc = 0.;
+
+ } else if (ifact == 1) {
+
+/* Compute the 1-norm of A. */
+
+ anorm = zlansp_("1", uplo, &n, &a[1], &rwork[1]);
+
+/* Factor the matrix A. */
+
+ zcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ zsptrf_(uplo, &n, &afac[1], &iwork[1], &info);
+
+/* Compute inv(A) and take its norm. */
+
+ zcopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
+ zsptri_(uplo, &n, &ainv[1], &iwork[1], &work[1], &
+ info);
+ ainvnm = zlansp_("1", uplo, &n, &ainv[1], &rwork[1]);
+
+/* Compute the 1-norm condition number of A. */
+
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondc = 1.;
+ } else {
+ rcondc = 1. / anorm / ainvnm;
+ }
+ }
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (ftnlen)6);
+ zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, nrhs, &
+ a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
+ info);
+ *(unsigned char *)xtype = 'C';
+
+/* --- Test ZSPSV --- */
+
+ if (ifact == 2) {
+ zcopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
+
+/* Factor the matrix and solve the system using ZSPSV. */
+
+ s_copy(srnamc_1.srnamt, "ZSPSV ", (ftnlen)32, (ftnlen)
+ 6);
+ zspsv_(uplo, &n, nrhs, &afac[1], &iwork[1], &x[1], &
+ lda, &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from ZSPSV . */
+
+ if (info != k) {
+ alaerh_(path, "ZSPSV ", &info, &k, uplo, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L120;
+ } else if (info != 0) {
+ goto L120;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zspt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &ainv[1]
+, &lda, &rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ zspt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[1],
+ &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "ZSPSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+L120:
+ ;
+ }
+
+/* --- Test ZSPSVX --- */
+
+ if (ifact == 2 && npp > 0) {
+ zlaset_("Full", &npp, &c__1, &c_b61, &c_b61, &afac[1],
+ &npp);
+ }
+ zlaset_("Full", &n, nrhs, &c_b61, &c_b61, &x[1], &lda);
+
+/* Solve the system and compute the condition number and */
+/* error bounds using ZSPSVX. */
+
+ s_copy(srnamc_1.srnamt, "ZSPSVX", (ftnlen)32, (ftnlen)6);
+ zspsvx_(fact, uplo, &n, nrhs, &a[1], &afac[1], &iwork[1],
+ &b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &
+ rwork[*nrhs + 1], &work[1], &rwork[(*nrhs << 1) +
+ 1], &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L130:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L130;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L130;
+ }
+ }
+
+/* Check the error code from ZSPSVX. */
+
+ if (info != k) {
+/* Writing concatenation */
+ i__6[0] = 1, a__1[0] = fact;
+ i__6[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__6, &c__2, (ftnlen)2);
+ alaerh_(path, "ZSPSVX", &info, &k, ch__1, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L150;
+ }
+
+ if (info == 0) {
+ if (ifact >= 2) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zspt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &
+ ainv[1], &lda, &rwork[(*nrhs << 1) + 1],
+ result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ zspt02_(uplo, &n, nrhs, &a[1], &x[1], &lda, &work[1],
+ &lda, &rwork[(*nrhs << 1) + 1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* Check the error bounds from iterative refinement. */
+
+ zppt05_(uplo, &n, nrhs, &a[1], &b[1], &lda, &x[1], &
+ lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs
+ + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from ZSPSVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "ZSPSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L140: */
+ }
+ nrun = nrun + 7 - k1;
+
+L150:
+ ;
+ }
+
+L160:
+ ;
+ }
+L170:
+ ;
+ }
+/* L180: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZDRVSP */
+
+} /* zdrvsp_ */
diff --git a/TESTING/LIN/zdrvsy.c b/TESTING/LIN/zdrvsy.c
new file mode 100644
index 0000000..58c1556
--- /dev/null
+++ b/TESTING/LIN/zdrvsy.c
@@ -0,0 +1,697 @@
+/* zdrvsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nunit;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static doublecomplex c_b49 = {0.,0.};
+
+/* Subroutine */ int zdrvsy_(logical *dotype, integer *nn, integer *nval,
+ integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
+ doublecomplex *a, doublecomplex *afac, doublecomplex *ainv,
+ doublecomplex *b, doublecomplex *x, doublecomplex *xact,
+ doublecomplex *work, doublereal *rwork, integer *iwork, integer *nout)
+{
+ /* Initialized data */
+
+ static integer iseedy[4] = { 1988,1989,1990,1991 };
+ static char uplos[1*2] = "U" "L";
+ static char facts[1*2] = "F" "N";
+
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
+ ",\002, type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
+ static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
+ "a1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002,"
+ " ratio =\002,g12.5)";
+
+ /* System generated locals */
+ address a__1[2];
+ integer i__1, i__2, i__3, i__4, i__5, i__6[2];
+ char ch__1[2];
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+ /* Local variables */
+ integer i__, j, k, n, i1, i2, k1, nb, in, kl, ku, nt, lda;
+ char fact[1];
+ integer ioff, mode, imat, info;
+ char path[3], dist[1], uplo[1], type__[1];
+ integer nrun, ifact, nfail, iseed[4];
+ extern doublereal dget06_(doublereal *, doublereal *);
+ integer nbmin;
+ doublereal rcond;
+ integer nimat;
+ doublereal anorm;
+ extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+);
+ integer iuplo, izero, nerrs, lwork;
+ extern /* Subroutine */ int zpot05_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *);
+ logical zerot;
+ char xtype[1];
+ extern /* Subroutine */ int zsyt01_(char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *), zsyt02_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+), zsysv_(char *, integer *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *), zlatb4_(char *, integer *,
+ integer *, integer *, char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, char *), aladhd_(
+ integer *, char *), alaerh_(char *, char *, integer *,
+ integer *, char *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *);
+ doublereal rcondc;
+ extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
+ *, integer *);
+ doublereal cndnum, ainvnm;
+ extern /* Subroutine */ int xlaenv_(integer *, integer *), zlacpy_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *), zlarhs_(char *, char *, char *, char *,
+ integer *, integer *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, integer *), zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatms_(integer *, integer *, char *, integer *, char *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ integer *, char *, doublecomplex *, integer *, doublecomplex *,
+ integer *);
+ doublereal result[6];
+ extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zlatsy_(char *, integer *, doublecomplex *,
+ integer *, integer *), zerrvx_(char *, integer *),
+ zsytrf_(char *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, integer *), zsytri_(char *,
+ integer *, doublecomplex *, integer *, integer *, doublecomplex *,
+ integer *), zsysvx_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, doublecomplex *,
+ integer *, doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZDRVSY tests the driver routines ZSYSV and -SVX. */
+
+/* Arguments */
+/* ========= */
+
+/* DOTYPE (input) 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. */
+
+/* NN (input) INTEGER */
+/* The number of values of N contained in the vector NVAL. */
+
+/* NVAL (input) INTEGER array, dimension (NN) */
+/* The values of the matrix dimension N. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors to be generated for */
+/* each linear system. */
+
+/* THRESH (input) 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. */
+
+/* TSTERR (input) LOGICAL */
+/* Flag that indicates whether error exits are to be tested. */
+
+/* NMAX (input) INTEGER */
+/* The maximum value permitted for N, used in dimensioning the */
+/* work arrays. */
+
+/* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* AINV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
+
+/* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension */
+/* (NMAX*max(2,NRHS)) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
+
+/* IWORK (workspace) INTEGER array, dimension (NMAX) */
+
+/* NOUT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ --iwork;
+ --rwork;
+ --work;
+ --xact;
+ --x;
+ --b;
+ --ainv;
+ --afac;
+ --a;
+ --nval;
+ --dotype;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants and the random number seed. */
+
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "SY", (ftnlen)2, (ftnlen)2);
+ nrun = 0;
+ nfail = 0;
+ nerrs = 0;
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__ - 1] = iseedy[i__ - 1];
+/* L10: */
+ }
+/* Computing MAX */
+ i__1 = *nmax << 1, i__2 = *nmax * *nrhs;
+ lwork = max(i__1,i__2);
+
+/* Test the error exits */
+
+ if (*tsterr) {
+ zerrvx_(path, nout);
+ }
+ infoc_1.infot = 0;
+
+/* Set the block size and minimum block size for testing. */
+
+ nb = 1;
+ nbmin = 2;
+ xlaenv_(&c__1, &nb);
+ xlaenv_(&c__2, &nbmin);
+
+/* Do for each value of N in NVAL */
+
+ i__1 = *nn;
+ for (in = 1; in <= i__1; ++in) {
+ n = nval[in];
+ lda = max(n,1);
+ *(unsigned char *)xtype = 'N';
+ nimat = 11;
+ if (n <= 0) {
+ nimat = 1;
+ }
+
+ i__2 = nimat;
+ for (imat = 1; imat <= i__2; ++imat) {
+
+/* Do the tests only if DOTYPE( IMAT ) is true. */
+
+ if (! dotype[imat]) {
+ goto L170;
+ }
+
+/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
+
+ zerot = imat >= 3 && imat <= 6;
+ if (zerot && n < imat - 2) {
+ goto L170;
+ }
+
+/* Do first for UPLO = 'U', then for UPLO = 'L' */
+
+ for (iuplo = 1; iuplo <= 2; ++iuplo) {
+ *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
+
+ if (imat != 11) {
+
+/* Set up parameters with ZLATB4 and generate a test */
+/* matrix with ZLATMS. */
+
+ zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
+ mode, &cndnum, dist);
+
+ s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
+ zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
+ cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &
+ work[1], &info);
+
+/* Check error code from ZLATMS. */
+
+ if (info != 0) {
+ alaerh_(path, "ZLATMS", &info, &c__0, uplo, &n, &n, &
+ c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
+ nout);
+ goto L160;
+ }
+
+/* For types 3-6, zero one or more rows and columns of */
+/* the matrix to test that INFO is returned correctly. */
+
+ if (zerot) {
+ if (imat == 3) {
+ izero = 1;
+ } else if (imat == 4) {
+ izero = n;
+ } else {
+ izero = n / 2 + 1;
+ }
+
+ if (imat < 6) {
+
+/* Set row and column IZERO to zero. */
+
+ if (iuplo == 1) {
+ ioff = (izero - 1) * lda;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L20: */
+ }
+ ioff += izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff += lda;
+/* L30: */
+ }
+ } else {
+ ioff = izero;
+ i__3 = izero - 1;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ioff;
+ a[i__4].r = 0., a[i__4].i = 0.;
+ ioff += lda;
+/* L40: */
+ }
+ ioff -= izero;
+ i__3 = n;
+ for (i__ = izero; i__ <= i__3; ++i__) {
+ i__4 = ioff + i__;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L50: */
+ }
+ }
+ } else {
+ if (iuplo == 1) {
+
+/* Set the first IZERO rows to zero. */
+
+ ioff = 0;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i2 = min(j,izero);
+ i__4 = i2;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0., a[i__5].i = 0.;
+/* L60: */
+ }
+ ioff += lda;
+/* L70: */
+ }
+ } else {
+
+/* Set the last IZERO rows to zero. */
+
+ ioff = 0;
+ i__3 = n;
+ for (j = 1; j <= i__3; ++j) {
+ i1 = max(j,izero);
+ i__4 = n;
+ for (i__ = i1; i__ <= i__4; ++i__) {
+ i__5 = ioff + i__;
+ a[i__5].r = 0., a[i__5].i = 0.;
+/* L80: */
+ }
+ ioff += lda;
+/* L90: */
+ }
+ }
+ }
+ } else {
+ izero = 0;
+ }
+ } else {
+
+/* IMAT = NTYPES: Use a special block diagonal matrix to */
+/* test alternate code for the 2-by-2 blocks. */
+
+ zlatsy_(uplo, &n, &a[1], &lda, iseed);
+ }
+
+ for (ifact = 1; ifact <= 2; ++ifact) {
+
+/* Do first for FACT = 'F', then for other values. */
+
+ *(unsigned char *)fact = *(unsigned char *)&facts[ifact -
+ 1];
+
+/* Compute the condition number for comparison with */
+/* the value returned by ZSYSVX. */
+
+ if (zerot) {
+ if (ifact == 1) {
+ goto L150;
+ }
+ rcondc = 0.;
+
+ } else if (ifact == 1) {
+
+/* Compute the 1-norm of A. */
+
+ anorm = zlansy_("1", uplo, &n, &a[1], &lda, &rwork[1]);
+
+/* Factor the matrix A. */
+
+ zlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ zsytrf_(uplo, &n, &afac[1], &lda, &iwork[1], &work[1],
+ &lwork, &info);
+
+/* Compute inv(A) and take its norm. */
+
+ zlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
+ zsytri_(uplo, &n, &ainv[1], &lda, &iwork[1], &work[1],
+ &info);
+ ainvnm = zlansy_("1", uplo, &n, &ainv[1], &lda, &
+ rwork[1]);
+
+/* Compute the 1-norm condition number of A. */
+
+ if (anorm <= 0. || ainvnm <= 0.) {
+ rcondc = 1.;
+ } else {
+ rcondc = 1. / anorm / ainvnm;
+ }
+ }
+
+/* Form an exact solution and set the right hand side. */
+
+ s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)32, (ftnlen)6);
+ zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, nrhs, &
+ a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
+ info);
+ *(unsigned char *)xtype = 'C';
+
+/* --- Test ZSYSV --- */
+
+ if (ifact == 2) {
+ zlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
+
+/* Factor the matrix and solve the system using ZSYSV. */
+
+ s_copy(srnamc_1.srnamt, "ZSYSV ", (ftnlen)32, (ftnlen)
+ 6);
+ zsysv_(uplo, &n, nrhs, &afac[1], &lda, &iwork[1], &x[
+ 1], &lda, &work[1], &lwork, &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L100:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L100;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L100;
+ }
+ }
+
+/* Check error code from ZSYSV . */
+
+ if (info != k) {
+ alaerh_(path, "ZSYSV ", &info, &k, uplo, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L120;
+ } else if (info != 0) {
+ goto L120;
+ }
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zsyt01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &iwork[
+ 1], &ainv[1], &lda, &rwork[1], result);
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ zsyt02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda, &
+ work[1], &lda, &rwork[1], &result[1]);
+
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+ nt = 3;
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ i__3 = nt;
+ for (k = 1; k <= i__3; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___42.ciunit = *nout;
+ s_wsfe(&io___42);
+ do_fio(&c__1, "ZSYSV ", (ftnlen)6);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L110: */
+ }
+ nrun += nt;
+L120:
+ ;
+ }
+
+/* --- Test ZSYSVX --- */
+
+ if (ifact == 2) {
+ zlaset_(uplo, &n, &n, &c_b49, &c_b49, &afac[1], &lda);
+ }
+ zlaset_("Full", &n, nrhs, &c_b49, &c_b49, &x[1], &lda);
+
+/* Solve the system and compute the condition number and */
+/* error bounds using ZSYSVX. */
+
+ s_copy(srnamc_1.srnamt, "ZSYSVX", (ftnlen)32, (ftnlen)6);
+ zsysvx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1], &lda,
+ &iwork[1], &b[1], &lda, &x[1], &lda, &rcond, &
+ rwork[1], &rwork[*nrhs + 1], &work[1], &lwork, &
+ rwork[(*nrhs << 1) + 1], &info);
+
+/* Adjust the expected value of INFO to account for */
+/* pivoting. */
+
+ k = izero;
+ if (k > 0) {
+L130:
+ if (iwork[k] < 0) {
+ if (iwork[k] != -k) {
+ k = -iwork[k];
+ goto L130;
+ }
+ } else if (iwork[k] != k) {
+ k = iwork[k];
+ goto L130;
+ }
+ }
+
+/* Check the error code from ZSYSVX. */
+
+ if (info != k) {
+/* Writing concatenation */
+ i__6[0] = 1, a__1[0] = fact;
+ i__6[1] = 1, a__1[1] = uplo;
+ s_cat(ch__1, a__1, i__6, &c__2, (ftnlen)2);
+ alaerh_(path, "ZSYSVX", &info, &k, ch__1, &n, &n, &
+ c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
+ nout);
+ goto L150;
+ }
+
+ if (info == 0) {
+ if (ifact >= 2) {
+
+/* Reconstruct matrix from factors and compute */
+/* residual. */
+
+ zsyt01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
+ iwork[1], &ainv[1], &lda, &rwork[(*nrhs <<
+ 1) + 1], result);
+ k1 = 1;
+ } else {
+ k1 = 2;
+ }
+
+/* Compute residual of the computed solution. */
+
+ zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
+ zsyt02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda, &
+ work[1], &lda, &rwork[(*nrhs << 1) + 1], &
+ result[1]);
+
+/* Check solution from generated exact solution. */
+
+ zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
+ rcondc, &result[2]);
+
+/* Check the error bounds from iterative refinement. */
+
+ zpot05_(uplo, &n, nrhs, &a[1], &lda, &b[1], &lda, &x[
+ 1], &lda, &xact[1], &lda, &rwork[1], &rwork[*
+ nrhs + 1], &result[3]);
+ } else {
+ k1 = 6;
+ }
+
+/* Compare RCOND from ZSYSVX with the computed value */
+/* in RCONDC. */
+
+ result[5] = dget06_(&rcond, &rcondc);
+
+/* Print information about the tests that did not pass */
+/* the threshold. */
+
+ for (k = k1; k <= 6; ++k) {
+ if (result[k - 1] >= *thresh) {
+ if (nfail == 0 && nerrs == 0) {
+ aladhd_(nout, path);
+ }
+ io___45.ciunit = *nout;
+ s_wsfe(&io___45);
+ do_fio(&c__1, "ZSYSVX", (ftnlen)6);
+ do_fio(&c__1, fact, (ftnlen)1);
+ do_fio(&c__1, uplo, (ftnlen)1);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
+ integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
+ ;
+ do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
+ sizeof(doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+/* L140: */
+ }
+ nrun = nrun + 7 - k1;
+
+L150:
+ ;
+ }
+
+L160:
+ ;
+ }
+L170:
+ ;
+ }
+/* L180: */
+ }
+
+/* Print a summary of the results. */
+
+ alasvm_(path, nout, &nfail, &nrun, &nerrs);
+
+ return 0;
+
+/* End of ZDRVSY */
+
+} /* zdrvsy_ */
diff --git a/TESTING/LIN/zebchvxx.c b/TESTING/LIN/zebchvxx.c
new file mode 100644
index 0000000..861f6f3
--- /dev/null
+++ b/TESTING/LIN/zebchvxx.c
@@ -0,0 +1,688 @@
+/* zebchvxx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__10 = 10;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c__5 = 5;
+static integer c__6 = 6;
+static integer c__7 = 7;
+static integer c__8 = 8;
+
+/* Subroutine */ int zebchvxx_(doublereal *thresh, char *path)
+{
+ /* Format strings */
+ static char fmt_8000[] = "(\002 Z\002,a2,\002SVXX: N =\002,i2,\002, INFO"
+ " = \002,i3,\002, ORCOND = \002,g12.5,\002, real RCOND = \002,g12"
+ ".5)";
+ static char fmt_9996[] = "(3x,i2,\002: Normwise guaranteed forward erro"
+ "r\002,/5x,\002Guaranteed case: if norm ( abs( Xc - Xt )\002,\002"
+ " / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ), then\002,/5x"
+ ",\002ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS\002)"
+ ;
+ static char fmt_9995[] = "(3x,i2,\002: Componentwise guaranteed forward "
+ "error\002)";
+ static char fmt_9994[] = "(3x,i2,\002: Backwards error\002)";
+ static char fmt_9993[] = "(3x,i2,\002: Reciprocal condition number\002)";
+ static char fmt_9992[] = "(3x,i2,\002: Reciprocal normwise condition num"
+ "ber\002)";
+ static char fmt_9991[] = "(3x,i2,\002: Raw normwise error estimate\002)";
+ static char fmt_9990[] = "(3x,i2,\002: Reciprocal componentwise conditio"
+ "n number\002)";
+ static char fmt_9989[] = "(3x,i2,\002: Raw componentwise error estimat"
+ "e\002)";
+ static char fmt_9999[] = "(\002 Z\002,a2,\002SVXX: N =\002,i2,\002, RHS "
+ "= \002,i2,\002, NWISE GUAR. = \002,a,\002, CWISE GUAR. = \002,a"
+ ",\002 test(\002,i1,\002) =\002,g12.5)";
+ static char fmt_9998[] = "(\002 Z\002,a2,\002SVXX: \002,i6,\002 out of"
+ " \002,i6,\002 tests failed to pass the threshold\002)";
+ static char fmt_9997[] = "(\002 Z\002,a2,\002SVXX passed the tests of er"
+ "ror bounds\002)";
+
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1, d__2, d__3, d__4, d__5;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+ double d_imag(doublecomplex *);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+ integer s_wsle(cilist *), e_wsle(void);
+
+ /* Local variables */
+ extern /* Subroutine */ int zposvxx_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, char *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *,
+ doublecomplex *, doublereal *, integer *);
+ doublereal errbnd_c__[30];
+ extern /* Subroutine */ int zsysvxx_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *
+, char *, doublereal *, doublecomplex *, integer *, doublecomplex
+ *, integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *,
+ doublecomplex *, doublereal *, integer *);
+ doublereal errbnd_n__[30];
+ doublecomplex a[100] /* was [10][10] */, b[100] /* was [10][
+ 10] */;
+ doublereal c__[10];
+ integer i__, j, k;
+ doublereal m;
+ integer n;
+ doublereal r__[10], s[10];
+ doublecomplex x[100] /* was [10][10] */;
+ doublereal cwise_bnd__;
+ char c2[2];
+ doublereal nwise_bnd__, cwise_err__, nwise_err__, errthresh;
+ doublecomplex ab[190] /* was [19][10] */, af[100] /* was [10][
+ 10] */;
+ integer kl, ku;
+ doublereal condthresh;
+ doublecomplex afb[280] /* was [28][10] */;
+ integer lda;
+ doublereal eps, cwise_rcond__, nwise_rcond__;
+ integer n_aux_tests__, ldab;
+ doublereal diff[100] /* was [10][10] */;
+ char fact[1];
+ doublereal berr[10];
+ integer info, ipiv[10], nrhs;
+ doublereal rinv[10];
+ char uplo[1];
+ doublecomplex work[150];
+ doublereal sumr;
+ integer ldafb;
+ doublereal ccond;
+ integer nfail;
+ char cguar[3];
+ doublereal ncond;
+ char equed[1];
+ doublereal rcond;
+ doublecomplex acopy[100] /* was [10][10] */;
+ char nguar[3], trans[1];
+ doublereal rnorm, normt, sumri, rwork[30];
+ logical printed_guide__;
+ extern doublereal dlamch_(char *);
+ doublecomplex abcopy[190] /* was [19][10] */;
+ extern logical lsamen_(integer *, char *, char *);
+ doublereal params[2], orcond;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal rinorm, tstrat[6], rpvgrw;
+ extern /* Subroutine */ int zlahilb_(integer *, integer *, doublecomplex *
+, integer *, doublecomplex *, integer *, doublecomplex *, integer
+ *, doublecomplex *, integer *, char *);
+ doublecomplex invhilb[100] /* was [10][10] */;
+ doublereal normdif;
+ extern /* Subroutine */ int zgbsvxx_(char *, char *, integer *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *, integer *, char *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, doublecomplex *,
+ doublereal *, integer *), zgesvxx_(char *,
+ char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, char *, doublereal *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *,
+ doublecomplex *, doublereal *, integer *),
+ zhesvxx_(char *, char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, char *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *,
+ doublecomplex *, doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___42 = { 0, 6, 0, fmt_8000, 0 };
+ static cilist io___66 = { 0, 6, 0, 0, 0 };
+ static cilist io___67 = { 0, 6, 0, fmt_9996, 0 };
+ static cilist io___68 = { 0, 6, 0, fmt_9995, 0 };
+ static cilist io___69 = { 0, 6, 0, fmt_9994, 0 };
+ static cilist io___70 = { 0, 6, 0, fmt_9993, 0 };
+ static cilist io___71 = { 0, 6, 0, fmt_9992, 0 };
+ static cilist io___72 = { 0, 6, 0, fmt_9991, 0 };
+ static cilist io___73 = { 0, 6, 0, fmt_9990, 0 };
+ static cilist io___74 = { 0, 6, 0, fmt_9989, 0 };
+ static cilist io___75 = { 0, 6, 0, 0, 0 };
+ static cilist io___76 = { 0, 6, 0, fmt_9999, 0 };
+ static cilist io___77 = { 0, 6, 0, 0, 0 };
+ static cilist io___78 = { 0, 6, 0, fmt_9998, 0 };
+ static cilist io___79 = { 0, 6, 0, fmt_9997, 0 };
+
+
+/* .. Scalar Arguments .. */
+
+/* Purpose */
+/* ====== */
+
+/* ZEBCHVXX will run Z**SVXX on a series of Hilbert matrices and then */
+/* compare the error bounds returned by Z**SVXX to see if the returned */
+/* answer indeed falls within those bounds. */
+
+/* Eight test ratios will be computed. The tests will pass if they are .LT. */
+/* THRESH. There are two cases that are determined by 1 / (SQRT( N ) * EPS). */
+/* If that value is .LE. to the component wise reciprocal condition number, */
+/* it uses the guaranteed case, other wise it uses the unguaranteed case. */
+
+/* Test ratios: */
+/* Let Xc be X_computed and Xt be X_truth. */
+/* The norm used is the infinity norm. */
+/* Let A be the guaranteed case and B be the unguaranteed case. */
+
+/* 1. Normwise guaranteed forward error bound. */
+/* A: norm ( abs( Xc - Xt ) / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ) and */
+/* ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N),10) * EPS. */
+/* If these conditions are met, the test ratio is set to be */
+/* ERRBND( *, nwise_i, bnd_i ) / MAX(SQRT(N), 10). Otherwise it is 1/EPS. */
+/* B: For this case, CGESVXX should just return 1. If it is less than */
+/* one, treat it the same as in 1A. Otherwise it fails. (Set test */
+/* ratio to ERRBND( *, nwise_i, bnd_i ) * THRESH?) */
+
+/* 2. Componentwise guaranteed forward error bound. */
+/* A: norm ( abs( Xc(j) - Xt(j) ) ) / norm (Xt(j)) .LE. ERRBND( *, cwise_i, bnd_i ) */
+/* for all j .AND. ERRBND( *, cwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS. */
+/* If these conditions are met, the test ratio is set to be */
+/* ERRBND( *, cwise_i, bnd_i ) / MAX(SQRT(N), 10). Otherwise it is 1/EPS. */
+/* B: Same as normwise test ratio. */
+
+/* 3. Backwards error. */
+/* A: The test ratio is set to BERR/EPS. */
+/* B: Same test ratio. */
+
+/* 4. Reciprocal condition number. */
+/* A: A condition number is computed with Xt and compared with the one */
+/* returned from CGESVXX. Let RCONDc be the RCOND returned by CGESVXX */
+/* and RCONDt be the RCOND from the truth value. Test ratio is set to */
+/* MAX(RCONDc/RCONDt, RCONDt/RCONDc). */
+/* B: Test ratio is set to 1 / (EPS * RCONDc). */
+
+/* 5. Reciprocal normwise condition number. */
+/* A: The test ratio is set to */
+/* MAX(ERRBND( *, nwise_i, cond_i ) / NCOND, NCOND / ERRBND( *, nwise_i, cond_i )). */
+/* B: Test ratio is set to 1 / (EPS * ERRBND( *, nwise_i, cond_i )). */
+
+/* 6. Reciprocal componentwise condition number. */
+/* A: Test ratio is set to */
+/* MAX(ERRBND( *, cwise_i, cond_i ) / CCOND, CCOND / ERRBND( *, cwise_i, cond_i )). */
+/* B: Test ratio is set to 1 / (EPS * ERRBND( *, cwise_i, cond_i )). */
+
+/* .. Parameters .. */
+/* NMAX is determined by the largest number in the inverse of the hilbert */
+/* matrix. Precision is exhausted when the largest entry in it is greater */
+/* than 2 to the power of the number of bits in the fraction of the data */
+/* type used plus one, which is 24 for single precision. */
+/* NMAX should be 6 for single and 11 for double. */
+/* .. Local Scalars .. */
+/* .. Local Arrays .. */
+/* .. External Functions .. */
+/* .. External Subroutines .. */
+/* .. Intrinsic Functions .. */
+/* .. Statement Functions .. */
+/* .. Statement Function Definitions .. */
+/* .. Parameters .. */
+/* Create the loop to test out the Hilbert matrices */
+ *(unsigned char *)fact = 'E';
+ *(unsigned char *)uplo = 'U';
+ *(unsigned char *)trans = 'N';
+ *(unsigned char *)equed = 'N';
+ eps = dlamch_("Epsilon");
+ nfail = 0;
+ n_aux_tests__ = 0;
+ lda = 10;
+ ldab = 19;
+ ldafb = 28;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+/* Main loop to test the different Hilbert Matrices. */
+ printed_guide__ = FALSE_;
+ for (n = 1; n <= 10; ++n) {
+ params[0] = -1.;
+ params[1] = -1.;
+ kl = n - 1;
+ ku = n - 1;
+ nrhs = n;
+/* Computing MAX */
+ d__1 = sqrt((doublereal) n);
+ m = max(d__1,10.);
+/* Generate the Hilbert matrix, its inverse, and the */
+/* right hand side, all scaled by the LCM(1,..,2N-1). */
+ zlahilb_(&n, &n, a, &lda, invhilb, &lda, b, &lda, work, &info, path);
+/* Copy A into ACOPY. */
+ zlacpy_("ALL", &n, &n, a, &c__10, acopy, &c__10);
+/* Store A in band format for GB tests */
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = kl + ku + 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 19 - 20;
+ ab[i__3].r = 0., ab[i__3].i = 0.;
+ }
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = 1, i__3 = j - ku;
+/* Computing MIN */
+ i__5 = n, i__6 = j + kl;
+ i__4 = min(i__5,i__6);
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ i__2 = ku + 1 + i__ - j + j * 19 - 20;
+ i__3 = i__ + j * 10 - 11;
+ ab[i__2].r = a[i__3].r, ab[i__2].i = a[i__3].i;
+ }
+ }
+/* Copy AB into ABCOPY. */
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = kl + ku + 1;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__2 = i__ + j * 19 - 20;
+ abcopy[i__2].r = 0., abcopy[i__2].i = 0.;
+ }
+ }
+ i__1 = kl + ku + 1;
+ zlacpy_("ALL", &i__1, &n, ab, &ldab, abcopy, &ldab);
+/* Call Z**SVXX with default PARAMS and N_ERR_BND = 3. */
+ if (lsamen_(&c__2, c2, "SY")) {
+ zsysvxx_(fact, uplo, &n, &nrhs, acopy, &lda, af, &lda, ipiv,
+ equed, s, b, &lda, x, &lda, &orcond, &rpvgrw, berr, &c__3,
+ errbnd_n__, errbnd_c__, &c__2, params, work, rwork, &
+ info);
+ } else if (lsamen_(&c__2, c2, "PO")) {
+ zposvxx_(fact, uplo, &n, &nrhs, acopy, &lda, af, &lda, equed, s,
+ b, &lda, x, &lda, &orcond, &rpvgrw, berr, &c__3,
+ errbnd_n__, errbnd_c__, &c__2, params, work, rwork, &info);
+ } else if (lsamen_(&c__2, c2, "HE")) {
+ zhesvxx_(fact, uplo, &n, &nrhs, acopy, &lda, af, &lda, ipiv,
+ equed, s, b, &lda, x, &lda, &orcond, &rpvgrw, berr, &c__3,
+ errbnd_n__, errbnd_c__, &c__2, params, work, rwork, &
+ info);
+ } else if (lsamen_(&c__2, c2, "GB")) {
+ zgbsvxx_(fact, trans, &n, &kl, &ku, &nrhs, abcopy, &ldab, afb, &
+ ldafb, ipiv, equed, r__, c__, b, &lda, x, &lda, &orcond, &
+ rpvgrw, berr, &c__3, errbnd_n__, errbnd_c__, &c__2,
+ params, work, rwork, &info);
+ } else {
+ zgesvxx_(fact, trans, &n, &nrhs, acopy, &lda, af, &lda, ipiv,
+ equed, r__, c__, b, &lda, x, &lda, &orcond, &rpvgrw, berr,
+ &c__3, errbnd_n__, errbnd_c__, &c__2, params, work,
+ rwork, &info);
+ }
+ ++n_aux_tests__;
+ if (orcond < eps) {
+/* Either factorization failed or the matrix is flagged, and 1 <= */
+/* INFO <= N+1. We don't decide based on rcond anymore. */
+/* IF (INFO .EQ. 0 .OR. INFO .GT. N+1) THEN */
+/* NFAIL = NFAIL + 1 */
+/* WRITE (*, FMT=8000) N, INFO, ORCOND, RCOND */
+/* END IF */
+ } else {
+/* Either everything succeeded (INFO == 0) or some solution failed */
+/* to converge (INFO > N+1). */
+ if (info > 0 && info <= n + 1) {
+ ++nfail;
+ s_wsfe(&io___42);
+ do_fio(&c__1, c2, (ftnlen)2);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&orcond, (ftnlen)sizeof(doublereal));
+ do_fio(&c__1, (char *)&rcond, (ftnlen)sizeof(doublereal));
+ e_wsfe();
+ }
+ }
+/* Calculating the difference between Z**SVXX's X and the true X. */
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__4 = nrhs;
+ for (j = 1; j <= i__4; ++j) {
+ i__2 = i__ + j * 10 - 11;
+ i__3 = i__ + j * 10 - 11;
+ i__5 = i__ + j * 10 - 11;
+ z__1.r = x[i__3].r - invhilb[i__5].r, z__1.i = x[i__3].i -
+ invhilb[i__5].i;
+ diff[i__2] = z__1.r;
+ }
+ }
+/* Calculating the RCOND */
+ rnorm = 0.;
+ rinorm = 0.;
+ if (lsamen_(&c__2, c2, "PO") || lsamen_(&c__2,
+ c2, "SY") || lsamen_(&c__2, c2, "HE")) {
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sumr = 0.;
+ sumri = 0.;
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__2 = i__ + j * 10 - 11;
+ sumr += s[i__ - 1] * ((d__1 = a[i__2].r, abs(d__1)) + (
+ d__2 = d_imag(&a[i__ + j * 10 - 11]), abs(d__2)))
+ * s[j - 1];
+ i__2 = i__ + j * 10 - 11;
+ sumri += ((d__1 = invhilb[i__2].r, abs(d__1)) + (d__2 =
+ d_imag(&invhilb[i__ + j * 10 - 11]), abs(d__2))) /
+ (s[j - 1] * s[i__ - 1]);
+ }
+ rnorm = max(rnorm,sumr);
+ rinorm = max(rinorm,sumri);
+ }
+ } else if (lsamen_(&c__2, c2, "GE") || lsamen_(&
+ c__2, c2, "GB")) {
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sumr = 0.;
+ sumri = 0.;
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__2 = i__ + j * 10 - 11;
+ sumr += r__[i__ - 1] * ((d__1 = a[i__2].r, abs(d__1)) + (
+ d__2 = d_imag(&a[i__ + j * 10 - 11]), abs(d__2)))
+ * c__[j - 1];
+ i__2 = i__ + j * 10 - 11;
+ sumri += ((d__1 = invhilb[i__2].r, abs(d__1)) + (d__2 =
+ d_imag(&invhilb[i__ + j * 10 - 11]), abs(d__2))) /
+ (r__[j - 1] * c__[i__ - 1]);
+ }
+ rnorm = max(rnorm,sumr);
+ rinorm = max(rinorm,sumri);
+ }
+ }
+ rnorm /= (d__1 = a[0].r, abs(d__1)) + (d__2 = d_imag(a), abs(d__2));
+ rcond = 1. / (rnorm * rinorm);
+/* Calculating the R for normwise rcond. */
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ rinv[i__ - 1] = 0.;
+ }
+ i__1 = n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__2 = i__ + j * 10 - 11;
+ rinv[i__ - 1] += (d__1 = a[i__2].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * 10 - 11]), abs(d__2));
+ }
+ }
+/* Calculating the Normwise rcond. */
+ rinorm = 0.;
+ i__1 = n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sumri = 0.;
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__2 = i__ + j * 10 - 11;
+ i__3 = j - 1;
+ z__2.r = rinv[i__3] * invhilb[i__2].r, z__2.i = rinv[i__3] *
+ invhilb[i__2].i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ sumri += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
+ abs(d__2));
+ }
+ rinorm = max(rinorm,sumri);
+ }
+/* invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm */
+/* by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix) */
+ ncond = ((d__1 = a[0].r, abs(d__1)) + (d__2 = d_imag(a), abs(d__2))) /
+ rinorm;
+ condthresh = m * eps;
+ errthresh = m * eps;
+ i__1 = nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ normt = 0.;
+ normdif = 0.;
+ cwise_err__ = 0.;
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+/* Computing MAX */
+ i__2 = i__ + k * 10 - 11;
+ d__3 = (d__1 = invhilb[i__2].r, abs(d__1)) + (d__2 = d_imag(&
+ invhilb[i__ + k * 10 - 11]), abs(d__2));
+ normt = max(d__3,normt);
+ i__2 = i__ + k * 10 - 11;
+ i__3 = i__ + k * 10 - 11;
+ z__2.r = x[i__2].r - invhilb[i__3].r, z__2.i = x[i__2].i -
+ invhilb[i__3].i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+/* Computing MAX */
+ d__3 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1),
+ abs(d__2));
+ normdif = max(d__3,normdif);
+ i__2 = i__ + k * 10 - 11;
+ if (invhilb[i__2].r != 0. || invhilb[i__2].i != 0.) {
+ i__2 = i__ + k * 10 - 11;
+ i__3 = i__ + k * 10 - 11;
+ z__2.r = x[i__2].r - invhilb[i__3].r, z__2.i = x[i__2].i
+ - invhilb[i__3].i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+/* Computing MAX */
+ i__5 = i__ + k * 10 - 11;
+ d__5 = ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1)
+ , abs(d__2))) / ((d__3 = invhilb[i__5].r, abs(
+ d__3)) + (d__4 = d_imag(&invhilb[i__ + k * 10 -
+ 11]), abs(d__4)));
+ cwise_err__ = max(d__5,cwise_err__);
+ } else /* if(complicated condition) */ {
+ i__2 = i__ + k * 10 - 11;
+ if (x[i__2].r != 0. || x[i__2].i != 0.) {
+ cwise_err__ = dlamch_("OVERFLOW");
+ }
+ }
+ }
+ if (normt != 0.) {
+ nwise_err__ = normdif / normt;
+ } else if (normdif != 0.) {
+ nwise_err__ = dlamch_("OVERFLOW");
+ } else {
+ nwise_err__ = 0.;
+ }
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ rinv[i__ - 1] = 0.;
+ }
+ i__4 = n;
+ for (j = 1; j <= i__4; ++j) {
+ i__2 = n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * 10 - 11;
+ i__5 = j + k * 10 - 11;
+ z__2.r = a[i__3].r * invhilb[i__5].r - a[i__3].i *
+ invhilb[i__5].i, z__2.i = a[i__3].r * invhilb[
+ i__5].i + a[i__3].i * invhilb[i__5].r;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ rinv[i__ - 1] += (d__1 = z__1.r, abs(d__1)) + (d__2 =
+ d_imag(&z__1), abs(d__2));
+ }
+ }
+ rinorm = 0.;
+ i__4 = n;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ sumri = 0.;
+ i__2 = n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * 10 - 11;
+ i__5 = j - 1;
+ z__3.r = rinv[i__5] * invhilb[i__3].r, z__3.i = rinv[i__5]
+ * invhilb[i__3].i;
+ z_div(&z__2, &z__3, &invhilb[i__ + k * 10 - 11]);
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ sumri += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
+ z__1), abs(d__2));
+ }
+ rinorm = max(rinorm,sumri);
+ }
+/* invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm */
+/* by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix) */
+ ccond = ((d__1 = a[0].r, abs(d__1)) + (d__2 = d_imag(a), abs(d__2)
+ )) / rinorm;
+/* Forward error bound tests */
+ nwise_bnd__ = errbnd_n__[k + nrhs - 1];
+ cwise_bnd__ = errbnd_c__[k + nrhs - 1];
+ nwise_rcond__ = errbnd_n__[k + (nrhs << 1) - 1];
+ cwise_rcond__ = errbnd_c__[k + (nrhs << 1) - 1];
+/* write (*,*) 'nwise : ', n, k, ncond, nwise_rcond, */
+/* $ condthresh, ncond.ge.condthresh */
+/* write (*,*) 'nwise2: ', k, nwise_bnd, nwise_err, errthresh */
+ if (ncond >= condthresh) {
+ s_copy(nguar, "YES", (ftnlen)3, (ftnlen)3);
+ if (nwise_bnd__ > errthresh) {
+ tstrat[0] = 1 / (eps * 2.);
+ } else {
+ if (nwise_bnd__ != 0.) {
+ tstrat[0] = nwise_err__ / nwise_bnd__;
+ } else if (nwise_err__ != 0.) {
+ tstrat[0] = 1 / (eps * 16.f);
+ } else {
+ tstrat[0] = 0.;
+ }
+ if (tstrat[0] > 1.) {
+ tstrat[0] = 1 / (eps * 4.);
+ }
+ }
+ } else {
+ s_copy(nguar, "NO", (ftnlen)3, (ftnlen)2);
+ if (nwise_bnd__ < 1.) {
+ tstrat[0] = 1 / (eps * 8.);
+ } else {
+ tstrat[0] = 1.;
+ }
+ }
+/* write (*,*) 'cwise : ', n, k, ccond, cwise_rcond, */
+/* $ condthresh, ccond.ge.condthresh */
+/* write (*,*) 'cwise2: ', k, cwise_bnd, cwise_err, errthresh */
+ if (ccond >= condthresh) {
+ s_copy(cguar, "YES", (ftnlen)3, (ftnlen)3);
+ if (cwise_bnd__ > errthresh) {
+ tstrat[1] = 1 / (eps * 2.);
+ } else {
+ if (cwise_bnd__ != 0.) {
+ tstrat[1] = cwise_err__ / cwise_bnd__;
+ } else if (cwise_err__ != 0.) {
+ tstrat[1] = 1 / (eps * 16.);
+ } else {
+ tstrat[1] = 0.;
+ }
+ if (tstrat[1] > 1.) {
+ tstrat[1] = 1 / (eps * 4.);
+ }
+ }
+ } else {
+ s_copy(cguar, "NO", (ftnlen)3, (ftnlen)2);
+ if (cwise_bnd__ < 1.) {
+ tstrat[1] = 1 / (eps * 8.);
+ } else {
+ tstrat[1] = 1.;
+ }
+ }
+/* Backwards error test */
+ tstrat[2] = berr[k - 1] / eps;
+/* Condition number tests */
+ tstrat[3] = rcond / orcond;
+ if (rcond >= condthresh && tstrat[3] < 1.) {
+ tstrat[3] = 1. / tstrat[3];
+ }
+ tstrat[4] = ncond / nwise_rcond__;
+ if (ncond >= condthresh && tstrat[4] < 1.) {
+ tstrat[4] = 1. / tstrat[4];
+ }
+ tstrat[5] = ccond / nwise_rcond__;
+ if (ccond >= condthresh && tstrat[5] < 1.) {
+ tstrat[5] = 1. / tstrat[5];
+ }
+ for (i__ = 1; i__ <= 6; ++i__) {
+ if (tstrat[i__ - 1] > *thresh) {
+ if (! printed_guide__) {
+ s_wsle(&io___66);
+ e_wsle();
+ s_wsfe(&io___67);
+ do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___68);
+ do_fio(&c__1, (char *)&c__2, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___69);
+ do_fio(&c__1, (char *)&c__3, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___70);
+ do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___71);
+ do_fio(&c__1, (char *)&c__5, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___72);
+ do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___73);
+ do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsfe(&io___74);
+ do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
+ e_wsfe();
+ s_wsle(&io___75);
+ e_wsle();
+ printed_guide__ = TRUE_;
+ }
+ s_wsfe(&io___76);
+ do_fio(&c__1, c2, (ftnlen)2);
+ do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
+ do_fio(&c__1, nguar, (ftnlen)3);
+ do_fio(&c__1, cguar, (ftnlen)3);
+ do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
+ do_fio(&c__1, (char *)&tstrat[i__ - 1], (ftnlen)sizeof(
+ doublereal));
+ e_wsfe();
+ ++nfail;
+ }
+ }
+ }
+/* $$$ WRITE(*,*) */
+/* $$$ WRITE(*,*) 'Normwise Error Bounds' */
+/* $$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,nwise_i,bnd_i) */
+/* $$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,nwise_i,cond_i) */
+/* $$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,nwise_i,rawbnd_i) */
+/* $$$ WRITE(*,*) */
+/* $$$ WRITE(*,*) 'Componentwise Error Bounds' */
+/* $$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,cwise_i,bnd_i) */
+/* $$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,cwise_i,cond_i) */
+/* $$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,cwise_i,rawbnd_i) */
+/* $$$ print *, 'Info: ', info */
+/* $$$ WRITE(*,*) */
+/* WRITE(*,*) 'TSTRAT: ',TSTRAT */
+ }
+ s_wsle(&io___77);
+ e_wsle();
+ if (nfail > 0) {
+ s_wsfe(&io___78);
+ do_fio(&c__1, c2, (ftnlen)2);
+ do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
+ i__1 = n * 6 + n_aux_tests__;
+ do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer));
+ e_wsfe();
+ } else {
+ s_wsfe(&io___79);
+ do_fio(&c__1, c2, (ftnlen)2);
+ e_wsfe();
+ }
+/* Test ratios. */
+ return 0;
+} /* zebchvxx_ */
diff --git a/TESTING/LIN/zerrab.c b/TESTING/LIN/zerrab.c
new file mode 100644
index 0000000..f15e515
--- /dev/null
+++ b/TESTING/LIN/zerrab.c
@@ -0,0 +1,197 @@
+/* zerrab.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int zerrab_(integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a6,\002 drivers passed the tests of the er"
+ "ror exits\002)";
+ static char fmt_9998[] = "(\002 *** \002,a6,\002 drivers failed the test"
+ "s of the error \002,\002exits ***\002)";
+
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublecomplex a[16] /* was [4][4] */, b[4], c__[4];
+ integer i__, j;
+ doublecomplex r__[4], w[8], x[4], r1[4], r2[4], af[16] /* was [4][4]
+ */;
+ integer ip[4], info, iter;
+ doublecomplex work[1];
+ doublereal rwork[1];
+ complex swork[1];
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), zcgesv_(integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, complex *,
+ doublereal *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___19 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___20 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DERRAB tests the error exits for ZCGESV. */
+
+/* Arguments */
+/* ========= */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ d__1 = 1. / (doublereal) (i__ + j);
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ i__1 = i__ + (j << 2) - 5;
+ d__1 = 1. / (doublereal) (i__ + j);
+ af[i__1].r = d__1, af[i__1].i = 0.;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0., b[i__1].i = 0.;
+ i__1 = j - 1;
+ r1[i__1].r = 0., r1[i__1].i = 0.;
+ i__1 = j - 1;
+ r2[i__1].r = 0., r2[i__1].i = 0.;
+ i__1 = j - 1;
+ w[i__1].r = 0., w[i__1].i = 0.;
+ i__1 = j - 1;
+ x[i__1].r = 0., x[i__1].i = 0.;
+ i__1 = j - 1;
+ c__[i__1].r = 0., c__[i__1].i = 0.;
+ i__1 = j - 1;
+ r__[i__1].r = 0., r__[i__1].i = 0.;
+ ip[j - 1] = j;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+ s_copy(srnamc_1.srnamt, "ZCGESV", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zcgesv_(&c_n1, &c__0, a, &c__1, ip, b, &c__1, x, &c__1, work, swork,
+ rwork, &iter, &info);
+ chkxer_("ZCGESV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zcgesv_(&c__0, &c_n1, a, &c__1, ip, b, &c__1, x, &c__1, work, swork,
+ rwork, &iter, &info);
+ chkxer_("ZCGESV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zcgesv_(&c__2, &c__1, a, &c__1, ip, b, &c__2, x, &c__2, work, swork,
+ rwork, &iter, &info);
+ chkxer_("ZCGESV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zcgesv_(&c__2, &c__1, a, &c__2, ip, b, &c__1, x, &c__2, work, swork,
+ rwork, &iter, &info);
+ chkxer_("ZCGESV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zcgesv_(&c__2, &c__1, a, &c__2, ip, b, &c__2, x, &c__1, work, swork,
+ rwork, &iter, &info);
+ chkxer_("ZCGESV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___19.ciunit = infoc_1.nout;
+ s_wsfe(&io___19);
+ do_fio(&c__1, "ZCGESV", (ftnlen)6);
+ e_wsfe();
+ } else {
+ io___20.ciunit = infoc_1.nout;
+ s_wsfe(&io___20);
+ do_fio(&c__1, "ZCGESV", (ftnlen)6);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of ZERRAB */
+
+} /* zerrab_ */
diff --git a/TESTING/LIN/zerrac.c b/TESTING/LIN/zerrac.c
new file mode 100644
index 0000000..843d1e4
--- /dev/null
+++ b/TESTING/LIN/zerrac.c
@@ -0,0 +1,199 @@
+/* zerrac.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int zerrac_(integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a6,\002 drivers passed the tests of the er"
+ "ror exits\002)";
+ static char fmt_9998[] = "(\002 *** \002,a6,\002 drivers failed the test"
+ "s of the error \002,\002exits ***\002)";
+
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublecomplex a[16] /* was [4][4] */, b[4], c__[4];
+ integer i__, j;
+ doublecomplex r__[4], w[8], x[4], r1[4], r2[4], af[16] /* was [4][4]
+ */;
+ integer info, iter;
+ doublecomplex work[16];
+ doublereal rwork[4];
+ complex swork[16];
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), zcposv_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, complex *,
+ doublereal *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___18 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___19 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* May 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRPX tests the error exits for ZCPOSV. */
+
+/* Arguments */
+/* ========= */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ d__1 = 1. / (doublereal) (i__ + j);
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ i__1 = i__ + (j << 2) - 5;
+ d__1 = 1. / (doublereal) (i__ + j);
+ af[i__1].r = d__1, af[i__1].i = 0.;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0., b[i__1].i = 0.;
+ i__1 = j - 1;
+ r1[i__1].r = 0., r1[i__1].i = 0.;
+ i__1 = j - 1;
+ r2[i__1].r = 0., r2[i__1].i = 0.;
+ i__1 = j - 1;
+ w[i__1].r = 0., w[i__1].i = 0.;
+ i__1 = j - 1;
+ x[i__1].r = 0., x[i__1].i = 0.;
+ i__1 = j - 1;
+ c__[i__1].r = 0., c__[i__1].i = 0.;
+ i__1 = j - 1;
+ r__[i__1].r = 0., r__[i__1].i = 0.;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+ s_copy(srnamc_1.srnamt, "ZCPOSV", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zcposv_("/", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, work, swork,
+ rwork, &iter, &info);
+ chkxer_("ZCPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zcposv_("U", &c_n1, &c__0, a, &c__1, b, &c__1, x, &c__1, work, swork,
+ rwork, &iter, &info);
+ chkxer_("ZCPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zcposv_("U", &c__0, &c_n1, a, &c__1, b, &c__1, x, &c__1, work, swork,
+ rwork, &iter, &info);
+ chkxer_("ZCPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zcposv_("U", &c__2, &c__1, a, &c__1, b, &c__2, x, &c__2, work, swork,
+ rwork, &iter, &info);
+ chkxer_("ZCPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zcposv_("U", &c__2, &c__1, a, &c__2, b, &c__1, x, &c__2, work, swork,
+ rwork, &iter, &info);
+ chkxer_("ZCPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zcposv_("U", &c__2, &c__1, a, &c__2, b, &c__2, x, &c__1, work, swork,
+ rwork, &iter, &info);
+ chkxer_("ZCPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___18.ciunit = infoc_1.nout;
+ s_wsfe(&io___18);
+ do_fio(&c__1, "ZCPOSV", (ftnlen)6);
+ e_wsfe();
+ } else {
+ io___19.ciunit = infoc_1.nout;
+ s_wsfe(&io___19);
+ do_fio(&c__1, "ZCPOSV", (ftnlen)6);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of ZERRAC */
+
+} /* zerrac_ */
diff --git a/TESTING/LIN/zerrge.c b/TESTING/LIN/zerrge.c
new file mode 100644
index 0000000..3204d2a
--- /dev/null
+++ b/TESTING/LIN/zerrge.c
@@ -0,0 +1,536 @@
+/* zerrge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__4 = 4;
+
+/* Subroutine */ int zerrge_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublecomplex a[16] /* was [4][4] */, b[4];
+ integer i__, j;
+ doublereal r__[4];
+ doublecomplex w[8], x[4];
+ char c2[2];
+ doublereal r1[4], r2[4];
+ doublecomplex af[16] /* was [4][4] */;
+ integer ip[4], info;
+ doublereal anrm, ccond, rcond;
+ extern /* Subroutine */ int zgbtf2_(integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, integer *, integer *),
+ zgetf2_(integer *, integer *, doublecomplex *, integer *, integer
+ *, integer *), alaesm_(char *, logical *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int zgbcon_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, integer *, doublereal *,
+ doublereal *, doublecomplex *, doublereal *, integer *),
+ chkxer_(char *, integer *, integer *, logical *, logical *), zgecon_(char *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zgbequ_(integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *), zgbrfs_(
+ char *, integer *, integer *, integer *, integer *, doublecomplex
+ *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zgbtrf_(integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, integer *, integer *),
+ zgeequ_(integer *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *), zgerfs_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zgetrf_(integer *, integer *, doublecomplex *,
+ integer *, integer *, integer *), zgetri_(integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *), zgbtrs_(char *, integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, integer *, doublecomplex *,
+ integer *, integer *), zgetrs_(char *, integer *,
+ integer *, doublecomplex *, integer *, integer *, doublecomplex *,
+ integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRGE tests the error exits for the COMPLEX*16 routines */
+/* for general matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ d__1 = 1. / (doublereal) (i__ + j);
+ d__2 = -1. / (doublereal) (i__ + j);
+ z__1.r = d__1, z__1.i = d__2;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = i__ + (j << 2) - 5;
+ d__1 = 1. / (doublereal) (i__ + j);
+ d__2 = -1. / (doublereal) (i__ + j);
+ z__1.r = d__1, z__1.i = d__2;
+ af[i__1].r = z__1.r, af[i__1].i = z__1.i;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0., b[i__1].i = 0.;
+ r1[j - 1] = 0.;
+ r2[j - 1] = 0.;
+ i__1 = j - 1;
+ w[i__1].r = 0., w[i__1].i = 0.;
+ i__1 = j - 1;
+ x[i__1].r = 0., x[i__1].i = 0.;
+ ip[j - 1] = j;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+/* Test error exits of the routines that use the LU decomposition */
+/* of a general matrix. */
+
+ if (lsamen_(&c__2, c2, "GE")) {
+
+/* ZGETRF */
+
+ s_copy(srnamc_1.srnamt, "ZGETRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgetrf_(&c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("ZGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgetrf_(&c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("ZGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgetrf_(&c__2, &c__1, a, &c__1, ip, &info);
+ chkxer_("ZGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGETF2 */
+
+ s_copy(srnamc_1.srnamt, "ZGETF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgetf2_(&c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("ZGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgetf2_(&c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("ZGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgetf2_(&c__2, &c__1, a, &c__1, ip, &info);
+ chkxer_("ZGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGETRI */
+
+ s_copy(srnamc_1.srnamt, "ZGETRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgetri_(&c_n1, a, &c__1, ip, w, &c__1, &info);
+ chkxer_("ZGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgetri_(&c__2, a, &c__1, ip, w, &c__2, &info);
+ chkxer_("ZGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zgetri_(&c__2, a, &c__2, ip, w, &c__1, &info);
+ chkxer_("ZGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGETRS */
+
+ s_copy(srnamc_1.srnamt, "ZGETRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgetrs_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("ZGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgetrs_("N", &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("ZGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgetrs_("N", &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("ZGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgetrs_("N", &c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
+ chkxer_("ZGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zgetrs_("N", &c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
+ chkxer_("ZGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGERFS */
+
+ s_copy(srnamc_1.srnamt, "ZGERFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgerfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgerfs_("N", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgerfs_("N", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgerfs_("N", &c__2, &c__1, a, &c__1, af, &c__2, ip, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__1, ip, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__1, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__2, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGECON */
+
+ s_copy(srnamc_1.srnamt, "ZGECON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgecon_("/", &c__0, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("ZGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgecon_("1", &c_n1, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("ZGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgecon_("1", &c__2, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("ZGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGEEQU */
+
+ s_copy(srnamc_1.srnamt, "ZGEEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgeequ_(&c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("ZGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgeequ_(&c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("ZGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgeequ_(&c__2, &c__2, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("ZGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Test error exits of the routines that use the LU decomposition */
+/* of a general band matrix. */
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* ZGBTRF */
+
+ s_copy(srnamc_1.srnamt, "ZGBTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgbtrf_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("ZGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgbtrf_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("ZGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgbtrf_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("ZGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgbtrf_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("ZGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zgbtrf_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
+ chkxer_("ZGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGBTF2 */
+
+ s_copy(srnamc_1.srnamt, "ZGBTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgbtf2_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("ZGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgbtf2_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("ZGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgbtf2_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("ZGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgbtf2_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("ZGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zgbtf2_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
+ chkxer_("ZGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGBTRS */
+
+ s_copy(srnamc_1.srnamt, "ZGBTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgbtrs_("/", &c__0, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgbtrs_("N", &c_n1, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgbtrs_("N", &c__1, &c_n1, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgbtrs_("N", &c__1, &c__0, &c_n1, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgbtrs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zgbtrs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, ip, b, &c__2, &
+ info);
+ chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zgbtrs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGBRFS */
+
+ s_copy(srnamc_1.srnamt, "ZGBRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgbrfs_("/", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgbrfs_("N", &c_n1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgbrfs_("N", &c__1, &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgbrfs_("N", &c__1, &c__0, &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgbrfs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__2, af, &c__4, ip, b, &
+ c__2, x, &c__2, r1, r2, w, r__, &info);
+ chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__3, ip, b, &
+ c__2, x, &c__2, r1, r2, w, r__, &info);
+ chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__2, r1, r2, w, r__, &info);
+ chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ zgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
+ c__2, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGBCON */
+
+ s_copy(srnamc_1.srnamt, "ZGBCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgbcon_("/", &c__0, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, r__,
+ &info);
+ chkxer_("ZGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgbcon_("1", &c_n1, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, r__,
+ &info);
+ chkxer_("ZGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgbcon_("1", &c__1, &c_n1, &c__0, a, &c__1, ip, &anrm, &rcond, w, r__,
+ &info);
+ chkxer_("ZGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgbcon_("1", &c__1, &c__0, &c_n1, a, &c__1, ip, &anrm, &rcond, w, r__,
+ &info);
+ chkxer_("ZGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zgbcon_("1", &c__2, &c__1, &c__1, a, &c__3, ip, &anrm, &rcond, w, r__,
+ &info);
+ chkxer_("ZGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGBEQU */
+
+ s_copy(srnamc_1.srnamt, "ZGBEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgbequ_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("ZGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgbequ_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("ZGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgbequ_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("ZGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgbequ_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("ZGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zgbequ_(&c__2, &c__2, &c__1, &c__1, a, &c__2, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("ZGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of ZERRGE */
+
+} /* zerrge_ */
diff --git a/TESTING/LIN/zerrgex.c b/TESTING/LIN/zerrgex.c
new file mode 100644
index 0000000..b26d3cb
--- /dev/null
+++ b/TESTING/LIN/zerrgex.c
@@ -0,0 +1,747 @@
+/* zerrgex.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static integer c__5 = 5;
+
+/* Subroutine */ int zerrge_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublecomplex a[16] /* was [4][4] */, b[4];
+ integer i__, j;
+ doublereal r__[4];
+ doublecomplex w[8], x[4];
+ char c2[2];
+ doublereal r1[4], r2[4];
+ doublecomplex af[16] /* was [4][4] */;
+ char eq[1];
+ doublereal cs[4];
+ integer ip[4];
+ doublereal rs[4];
+ doublecomplex err_bnds_c__[12] /* was [4][3] */;
+ integer n_err_bnds__;
+ doublecomplex err_bnds_n__[12] /* was [4][3] */;
+ doublereal berr;
+ integer info;
+ doublereal anrm, ccond, rcond;
+ extern /* Subroutine */ int zgbtf2_(integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, integer *, integer *),
+ zgetf2_(integer *, integer *, doublecomplex *, integer *, integer
+ *, integer *), alaesm_(char *, logical *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int zgbcon_(char *, integer *, integer *, integer
+ *, doublecomplex *, integer *, integer *, doublereal *,
+ doublereal *, doublecomplex *, doublereal *, integer *);
+ doublecomplex params;
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), zgecon_(char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublecomplex *,
+ doublereal *, integer *), zgbequ_(integer *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *)
+ , zgbrfs_(char *, integer *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zgbtrf_(integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, integer *, integer *),
+ zgeequ_(integer *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *), zgerfs_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zgetrf_(integer *, integer *, doublecomplex *,
+ integer *, integer *, integer *), zgetri_(integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *), zgbtrs_(char *, integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, integer *, doublecomplex *,
+ integer *, integer *), zgetrs_(char *, integer *,
+ integer *, doublecomplex *, integer *, integer *, doublecomplex *,
+ integer *, integer *), zgbequb_(integer *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *, integer *)
+ ;
+ integer nparams;
+ extern /* Subroutine */ int zgeequb_(integer *, integer *, doublecomplex *
+, integer *, doublereal *, doublereal *, doublereal *, doublereal
+ *, doublereal *, integer *), zgbrfsx_(char *, char *, integer *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, doublereal *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ doublereal *, integer *), zgerfsx_(char *, char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *, integer *, doublereal *, doublereal *, doublecomplex
+ *, integer *, doublecomplex *, integer *, doublereal *,
+ doublereal *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, doublereal *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRGE tests the error exits for the COMPLEX*16 routines */
+/* for general matrices. */
+
+/* Note that this file is used only when the XBLAS are available, */
+/* otherwise zerrge.f defines this subroutine. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ d__1 = 1. / (doublereal) (i__ + j);
+ d__2 = -1. / (doublereal) (i__ + j);
+ z__1.r = d__1, z__1.i = d__2;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = i__ + (j << 2) - 5;
+ d__1 = 1. / (doublereal) (i__ + j);
+ d__2 = -1. / (doublereal) (i__ + j);
+ z__1.r = d__1, z__1.i = d__2;
+ af[i__1].r = z__1.r, af[i__1].i = z__1.i;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0., b[i__1].i = 0.;
+ r1[j - 1] = 0.;
+ r2[j - 1] = 0.;
+ i__1 = j - 1;
+ w[i__1].r = 0., w[i__1].i = 0.;
+ i__1 = j - 1;
+ x[i__1].r = 0., x[i__1].i = 0.;
+ cs[j - 1] = 0.;
+ rs[j - 1] = 0.;
+ ip[j - 1] = j;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+/* Test error exits of the routines that use the LU decomposition */
+/* of a general matrix. */
+
+ if (lsamen_(&c__2, c2, "GE")) {
+
+/* ZGETRF */
+
+ s_copy(srnamc_1.srnamt, "ZGETRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgetrf_(&c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("ZGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgetrf_(&c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("ZGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgetrf_(&c__2, &c__1, a, &c__1, ip, &info);
+ chkxer_("ZGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGETF2 */
+
+ s_copy(srnamc_1.srnamt, "ZGETF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgetf2_(&c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("ZGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgetf2_(&c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("ZGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgetf2_(&c__2, &c__1, a, &c__1, ip, &info);
+ chkxer_("ZGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGETRI */
+
+ s_copy(srnamc_1.srnamt, "ZGETRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgetri_(&c_n1, a, &c__1, ip, w, &c__1, &info);
+ chkxer_("ZGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgetri_(&c__2, a, &c__1, ip, w, &c__2, &info);
+ chkxer_("ZGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zgetri_(&c__2, a, &c__2, ip, w, &c__1, &info);
+ chkxer_("ZGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGETRS */
+
+ s_copy(srnamc_1.srnamt, "ZGETRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgetrs_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("ZGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgetrs_("N", &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("ZGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgetrs_("N", &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("ZGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgetrs_("N", &c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
+ chkxer_("ZGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zgetrs_("N", &c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
+ chkxer_("ZGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGERFS */
+
+ s_copy(srnamc_1.srnamt, "ZGERFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgerfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgerfs_("N", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgerfs_("N", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgerfs_("N", &c__2, &c__1, a, &c__1, af, &c__2, ip, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__1, ip, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__1, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__2, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGERFSX */
+
+ n_err_bnds__ = 3;
+ nparams = 0;
+ s_copy(srnamc_1.srnamt, "ZGERFSX", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ zgerfsx_("/", eq, &c__0, &c__0, a, &c__1, af, &c__1, ip, rs, cs, b, &
+ c__1, x, &c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ *(unsigned char *)eq = '/';
+ zgerfsx_("N", eq, &c__2, &c__1, a, &c__1, af, &c__2, ip, rs, cs, b, &
+ c__2, x, &c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ *(unsigned char *)eq = 'R';
+ zgerfsx_("N", eq, &c_n1, &c__0, a, &c__1, af, &c__1, ip, rs, cs, b, &
+ c__1, x, &c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgerfsx_("N", eq, &c__0, &c_n1, a, &c__1, af, &c__1, ip, rs, cs, b, &
+ c__1, x, &c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zgerfsx_("N", eq, &c__2, &c__1, a, &c__1, af, &c__2, ip, rs, cs, b, &
+ c__2, x, &c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zgerfsx_("N", eq, &c__2, &c__1, a, &c__2, af, &c__1, ip, rs, cs, b, &
+ c__2, x, &c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ *(unsigned char *)eq = 'C';
+ zgerfsx_("N", eq, &c__2, &c__1, a, &c__2, af, &c__2, ip, rs, cs, b, &
+ c__1, x, &c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ zgerfsx_("N", eq, &c__2, &c__1, a, &c__2, af, &c__2, ip, rs, cs, b, &
+ c__2, x, &c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZGERFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGECON */
+
+ s_copy(srnamc_1.srnamt, "ZGECON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgecon_("/", &c__0, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("ZGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgecon_("1", &c_n1, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("ZGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgecon_("1", &c__2, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("ZGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGEEQU */
+
+ s_copy(srnamc_1.srnamt, "ZGEEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgeequ_(&c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("ZGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgeequ_(&c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("ZGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgeequ_(&c__2, &c__2, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
+ chkxer_("ZGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGEEQUB */
+
+ s_copy(srnamc_1.srnamt, "ZGEEQUB", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ zgeequb_(&c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info)
+ ;
+ chkxer_("ZGEEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgeequb_(&c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info)
+ ;
+ chkxer_("ZGEEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgeequb_(&c__2, &c__2, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info)
+ ;
+ chkxer_("ZGEEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Test error exits of the routines that use the LU decomposition */
+/* of a general band matrix. */
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* ZGBTRF */
+
+ s_copy(srnamc_1.srnamt, "ZGBTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgbtrf_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("ZGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgbtrf_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("ZGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgbtrf_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("ZGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgbtrf_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("ZGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zgbtrf_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
+ chkxer_("ZGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGBTF2 */
+
+ s_copy(srnamc_1.srnamt, "ZGBTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgbtf2_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("ZGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgbtf2_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
+ chkxer_("ZGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgbtf2_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
+ chkxer_("ZGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgbtf2_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
+ chkxer_("ZGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zgbtf2_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
+ chkxer_("ZGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGBTRS */
+
+ s_copy(srnamc_1.srnamt, "ZGBTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgbtrs_("/", &c__0, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgbtrs_("N", &c_n1, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgbtrs_("N", &c__1, &c_n1, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgbtrs_("N", &c__1, &c__0, &c_n1, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgbtrs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zgbtrs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, ip, b, &c__2, &
+ info);
+ chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zgbtrs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
+ info);
+ chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGBRFS */
+
+ s_copy(srnamc_1.srnamt, "ZGBRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgbrfs_("/", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgbrfs_("N", &c_n1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgbrfs_("N", &c__1, &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgbrfs_("N", &c__1, &c__0, &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgbrfs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__2, af, &c__4, ip, b, &
+ c__2, x, &c__2, r1, r2, w, r__, &info);
+ chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__3, ip, b, &
+ c__2, x, &c__2, r1, r2, w, r__, &info);
+ chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
+ c__1, x, &c__2, r1, r2, w, r__, &info);
+ chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ zgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
+ c__2, x, &c__1, r1, r2, w, r__, &info);
+ chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGBRFSX */
+
+ n_err_bnds__ = 3;
+ nparams = 0;
+ s_copy(srnamc_1.srnamt, "ZGBRFSX", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ zgbrfsx_("/", eq, &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ rs, cs, b, &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ *(unsigned char *)eq = '/';
+ zgbrfsx_("N", eq, &c__2, &c__1, &c__1, &c__1, a, &c__1, af, &c__2, ip,
+ rs, cs, b, &c__2, x, &c__2, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ *(unsigned char *)eq = 'R';
+ zgbrfsx_("N", eq, &c_n1, &c__1, &c__1, &c__0, a, &c__1, af, &c__1, ip,
+ rs, cs, b, &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ *(unsigned char *)eq = 'R';
+ zgbrfsx_("N", eq, &c__2, &c_n1, &c__1, &c__1, a, &c__3, af, &c__4, ip,
+ rs, cs, b, &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ *(unsigned char *)eq = 'R';
+ zgbrfsx_("N", eq, &c__2, &c__1, &c_n1, &c__1, a, &c__3, af, &c__4, ip,
+ rs, cs, b, &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zgbrfsx_("N", eq, &c__0, &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, ip,
+ rs, cs, b, &c__1, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zgbrfsx_("N", eq, &c__2, &c__1, &c__1, &c__1, a, &c__1, af, &c__2, ip,
+ rs, cs, b, &c__2, x, &c__2, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zgbrfsx_("N", eq, &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__3, ip,
+ rs, cs, b, &c__2, x, &c__2, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ *(unsigned char *)eq = 'C';
+ zgbrfsx_("N", eq, &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__5, ip,
+ rs, cs, b, &c__1, x, &c__2, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ zgbrfsx_("N", eq, &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__5, ip,
+ rs, cs, b, &c__2, x, &c__1, &rcond, &berr, &n_err_bnds__,
+ err_bnds_n__, err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZGBRFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGBCON */
+
+ s_copy(srnamc_1.srnamt, "ZGBCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgbcon_("/", &c__0, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, r__,
+ &info);
+ chkxer_("ZGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgbcon_("1", &c_n1, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, r__,
+ &info);
+ chkxer_("ZGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgbcon_("1", &c__1, &c_n1, &c__0, a, &c__1, ip, &anrm, &rcond, w, r__,
+ &info);
+ chkxer_("ZGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgbcon_("1", &c__1, &c__0, &c_n1, a, &c__1, ip, &anrm, &rcond, w, r__,
+ &info);
+ chkxer_("ZGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zgbcon_("1", &c__2, &c__1, &c__1, a, &c__3, ip, &anrm, &rcond, w, r__,
+ &info);
+ chkxer_("ZGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGBEQU */
+
+ s_copy(srnamc_1.srnamt, "ZGBEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgbequ_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("ZGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgbequ_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("ZGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgbequ_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("ZGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgbequ_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("ZGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zgbequ_(&c__2, &c__2, &c__1, &c__1, a, &c__2, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("ZGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGBEQUB */
+
+ s_copy(srnamc_1.srnamt, "ZGBEQUB", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ zgbequb_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("ZGBEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgbequb_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("ZGBEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgbequb_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("ZGBEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgbequb_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("ZGBEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zgbequb_(&c__2, &c__2, &c__1, &c__1, a, &c__2, r1, r2, &rcond, &ccond,
+ &anrm, &info);
+ chkxer_("ZGBEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of ZERRGE */
+
+} /* zerrge_ */
diff --git a/TESTING/LIN/zerrgt.c b/TESTING/LIN/zerrgt.c
new file mode 100644
index 0000000..0136348
--- /dev/null
+++ b/TESTING/LIN/zerrgt.c
@@ -0,0 +1,313 @@
+/* zerrgt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int zerrgt_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublecomplex b[2];
+ doublereal d__[2];
+ doublecomplex e[2];
+ integer i__;
+ doublecomplex w[2], x[2];
+ char c2[2];
+ doublereal r1[2], r2[2], df[2];
+ doublecomplex ef[2], dl[2];
+ integer ip[2];
+ doublecomplex du[2];
+ doublereal rw[2];
+ doublecomplex du2[2], dlf[2], duf[2];
+ integer info;
+ doublereal rcond, anorm;
+ extern /* Subroutine */ int alaesm_(char *, logical *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), zgtcon_(char *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, integer *),
+ zptcon_(integer *, doublereal *, doublecomplex *, doublereal *,
+ doublereal *, doublereal *, integer *), zgtrfs_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, integer *, doublecomplex *, integer *, doublecomplex *, integer
+ *, doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zgttrf_(integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ integer *), zptrfs_(char *, integer *, integer *, doublereal *,
+ doublecomplex *, doublereal *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *), zpttrf_(
+ integer *, doublereal *, doublecomplex *, integer *), zgttrs_(
+ char *, integer *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *), zpttrs_(char *, integer *, integer
+ *, doublereal *, doublecomplex *, doublecomplex *, integer *,
+ integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRGT tests the error exits for the COMPLEX*16 tridiagonal */
+/* routines. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ for (i__ = 1; i__ <= 2; ++i__) {
+ d__[i__ - 1] = 1.;
+ i__1 = i__ - 1;
+ e[i__1].r = 2., e[i__1].i = 0.;
+ i__1 = i__ - 1;
+ dl[i__1].r = 3., dl[i__1].i = 0.;
+ i__1 = i__ - 1;
+ du[i__1].r = 4., du[i__1].i = 0.;
+/* L10: */
+ }
+ anorm = 1.;
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "GT")) {
+
+/* Test error exits for the general tridiagonal routines. */
+
+/* ZGTTRF */
+
+ s_copy(srnamc_1.srnamt, "ZGTTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgttrf_(&c_n1, dl, e, du, du2, ip, &info);
+ chkxer_("ZGTTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGTTRS */
+
+ s_copy(srnamc_1.srnamt, "ZGTTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgttrs_("/", &c__0, &c__0, dl, e, du, du2, ip, x, &c__1, &info);
+ chkxer_("ZGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgttrs_("N", &c_n1, &c__0, dl, e, du, du2, ip, x, &c__1, &info);
+ chkxer_("ZGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgttrs_("N", &c__0, &c_n1, dl, e, du, du2, ip, x, &c__1, &info);
+ chkxer_("ZGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zgttrs_("N", &c__2, &c__1, dl, e, du, du2, ip, x, &c__1, &info);
+ chkxer_("ZGTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGTRFS */
+
+ s_copy(srnamc_1.srnamt, "ZGTRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgtrfs_("/", &c__0, &c__0, dl, e, du, dlf, ef, duf, du2, ip, b, &c__1,
+ x, &c__1, r1, r2, w, rw, &info);
+ chkxer_("ZGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgtrfs_("N", &c_n1, &c__0, dl, e, du, dlf, ef, duf, du2, ip, b, &c__1,
+ x, &c__1, r1, r2, w, rw, &info);
+ chkxer_("ZGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgtrfs_("N", &c__0, &c_n1, dl, e, du, dlf, ef, duf, du2, ip, b, &c__1,
+ x, &c__1, r1, r2, w, rw, &info);
+ chkxer_("ZGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ zgtrfs_("N", &c__2, &c__1, dl, e, du, dlf, ef, duf, du2, ip, b, &c__1,
+ x, &c__2, r1, r2, w, rw, &info);
+ chkxer_("ZGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ zgtrfs_("N", &c__2, &c__1, dl, e, du, dlf, ef, duf, du2, ip, b, &c__2,
+ x, &c__1, r1, r2, w, rw, &info);
+ chkxer_("ZGTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGTCON */
+
+ s_copy(srnamc_1.srnamt, "ZGTCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgtcon_("/", &c__0, dl, e, du, du2, ip, &anorm, &rcond, w, &info);
+ chkxer_("ZGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgtcon_("I", &c_n1, dl, e, du, du2, ip, &anorm, &rcond, w, &info);
+ chkxer_("ZGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ d__1 = -anorm;
+ zgtcon_("I", &c__0, dl, e, du, du2, ip, &d__1, &rcond, w, &info);
+ chkxer_("ZGTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PT")) {
+
+/* Test error exits for the positive definite tridiagonal */
+/* routines. */
+
+/* ZPTTRF */
+
+ s_copy(srnamc_1.srnamt, "ZPTTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpttrf_(&c_n1, d__, e, &info);
+ chkxer_("ZPTTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPTTRS */
+
+ s_copy(srnamc_1.srnamt, "ZPTTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpttrs_("/", &c__1, &c__0, d__, e, x, &c__1, &info);
+ chkxer_("ZPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpttrs_("U", &c_n1, &c__0, d__, e, x, &c__1, &info);
+ chkxer_("ZPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpttrs_("U", &c__0, &c_n1, d__, e, x, &c__1, &info);
+ chkxer_("ZPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zpttrs_("U", &c__2, &c__1, d__, e, x, &c__1, &info);
+ chkxer_("ZPTTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPTRFS */
+
+ s_copy(srnamc_1.srnamt, "ZPTRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zptrfs_("/", &c__1, &c__0, d__, e, df, ef, b, &c__1, x, &c__1, r1, r2,
+ w, rw, &info);
+ chkxer_("ZPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zptrfs_("U", &c_n1, &c__0, d__, e, df, ef, b, &c__1, x, &c__1, r1, r2,
+ w, rw, &info);
+ chkxer_("ZPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zptrfs_("U", &c__0, &c_n1, d__, e, df, ef, b, &c__1, x, &c__1, r1, r2,
+ w, rw, &info);
+ chkxer_("ZPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zptrfs_("U", &c__2, &c__1, d__, e, df, ef, b, &c__1, x, &c__2, r1, r2,
+ w, rw, &info);
+ chkxer_("ZPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zptrfs_("U", &c__2, &c__1, d__, e, df, ef, b, &c__2, x, &c__1, r1, r2,
+ w, rw, &info);
+ chkxer_("ZPTRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPTCON */
+
+ s_copy(srnamc_1.srnamt, "ZPTCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zptcon_(&c_n1, d__, e, &anorm, &rcond, rw, &info);
+ chkxer_("ZPTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ d__1 = -anorm;
+ zptcon_(&c__0, d__, e, &d__1, &rcond, rw, &info);
+ chkxer_("ZPTCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of ZERRGT */
+
+} /* zerrgt_ */
diff --git a/TESTING/LIN/zerrhe.c b/TESTING/LIN/zerrhe.c
new file mode 100644
index 0000000..a06300e
--- /dev/null
+++ b/TESTING/LIN/zerrhe.c
@@ -0,0 +1,412 @@
+/* zerrhe.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__4 = 4;
+
+/* Subroutine */ int zerrhe_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublecomplex a[16] /* was [4][4] */, b[4];
+ integer i__, j;
+ doublereal r__[4];
+ doublecomplex w[8], x[4];
+ char c2[2];
+ doublereal r1[4], r2[4];
+ doublecomplex af[16] /* was [4][4] */;
+ integer ip[4], info;
+ doublereal anrm, rcond;
+ extern /* Subroutine */ int zhetf2_(char *, integer *, doublecomplex *,
+ integer *, integer *, integer *), alaesm_(char *, logical
+ *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), zhecon_(char *, integer *, doublecomplex *,
+ integer *, integer *, doublereal *, doublereal *, doublecomplex *
+, integer *), zherfs_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zhetrf_(char *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *, integer *), zhpcon_(char *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, integer *),
+ zhetri_(char *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *), zhprfs_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zhptrf_(char *, integer *, doublecomplex *,
+ integer *, integer *), zhetrs_(char *, integer *, integer
+ *, doublecomplex *, integer *, integer *, doublecomplex *,
+ integer *, integer *), zhptri_(char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zhptrs_(char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRHE tests the error exits for the COMPLEX*16 routines */
+/* for Hermitian indefinite matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ d__1 = 1. / (doublereal) (i__ + j);
+ d__2 = -1. / (doublereal) (i__ + j);
+ z__1.r = d__1, z__1.i = d__2;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = i__ + (j << 2) - 5;
+ d__1 = 1. / (doublereal) (i__ + j);
+ d__2 = -1. / (doublereal) (i__ + j);
+ z__1.r = d__1, z__1.i = d__2;
+ af[i__1].r = z__1.r, af[i__1].i = z__1.i;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0., b[i__1].i = 0.;
+ r1[j - 1] = 0.;
+ r2[j - 1] = 0.;
+ i__1 = j - 1;
+ w[i__1].r = 0., w[i__1].i = 0.;
+ i__1 = j - 1;
+ x[i__1].r = 0., x[i__1].i = 0.;
+ ip[j - 1] = j;
+/* L20: */
+ }
+ anrm = 1.;
+ infoc_1.ok = TRUE_;
+
+/* Test error exits of the routines that use the diagonal pivoting */
+/* factorization of a Hermitian indefinite matrix. */
+
+ if (lsamen_(&c__2, c2, "HE")) {
+
+/* ZHETRF */
+
+ s_copy(srnamc_1.srnamt, "ZHETRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhetrf_("/", &c__0, a, &c__1, ip, w, &c__1, &info);
+ chkxer_("ZHETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhetrf_("U", &c_n1, a, &c__1, ip, w, &c__1, &info);
+ chkxer_("ZHETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zhetrf_("U", &c__2, a, &c__1, ip, w, &c__4, &info);
+ chkxer_("ZHETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZHETF2 */
+
+ s_copy(srnamc_1.srnamt, "ZHETF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhetf2_("/", &c__0, a, &c__1, ip, &info);
+ chkxer_("ZHETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhetf2_("U", &c_n1, a, &c__1, ip, &info);
+ chkxer_("ZHETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zhetf2_("U", &c__2, a, &c__1, ip, &info);
+ chkxer_("ZHETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZHETRI */
+
+ s_copy(srnamc_1.srnamt, "ZHETRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhetri_("/", &c__0, a, &c__1, ip, w, &info);
+ chkxer_("ZHETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhetri_("U", &c_n1, a, &c__1, ip, w, &info);
+ chkxer_("ZHETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zhetri_("U", &c__2, a, &c__1, ip, w, &info);
+ chkxer_("ZHETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZHETRS */
+
+ s_copy(srnamc_1.srnamt, "ZHETRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhetrs_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("ZHETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhetrs_("U", &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("ZHETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zhetrs_("U", &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("ZHETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zhetrs_("U", &c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
+ chkxer_("ZHETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zhetrs_("U", &c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
+ chkxer_("ZHETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZHERFS */
+
+ s_copy(srnamc_1.srnamt, "ZHERFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zherfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZHERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zherfs_("U", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZHERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zherfs_("U", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZHERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zherfs_("U", &c__2, &c__1, a, &c__1, af, &c__2, ip, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("ZHERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zherfs_("U", &c__2, &c__1, a, &c__2, af, &c__1, ip, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("ZHERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zherfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__1, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("ZHERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zherfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__2, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZHERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZHECON */
+
+ s_copy(srnamc_1.srnamt, "ZHECON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhecon_("/", &c__0, a, &c__1, ip, &anrm, &rcond, w, &info);
+ chkxer_("ZHECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhecon_("U", &c_n1, a, &c__1, ip, &anrm, &rcond, w, &info);
+ chkxer_("ZHECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zhecon_("U", &c__2, a, &c__1, ip, &anrm, &rcond, w, &info);
+ chkxer_("ZHECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ d__1 = -anrm;
+ zhecon_("U", &c__1, a, &c__1, ip, &d__1, &rcond, w, &info);
+ chkxer_("ZHECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Test error exits of the routines that use the diagonal pivoting */
+/* factorization of a Hermitian indefinite packed matrix. */
+
+ } else if (lsamen_(&c__2, c2, "HP")) {
+
+/* ZHPTRF */
+
+ s_copy(srnamc_1.srnamt, "ZHPTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhptrf_("/", &c__0, a, ip, &info);
+ chkxer_("ZHPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhptrf_("U", &c_n1, a, ip, &info);
+ chkxer_("ZHPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZHPTRI */
+
+ s_copy(srnamc_1.srnamt, "ZHPTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhptri_("/", &c__0, a, ip, w, &info);
+ chkxer_("ZHPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhptri_("U", &c_n1, a, ip, w, &info);
+ chkxer_("ZHPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZHPTRS */
+
+ s_copy(srnamc_1.srnamt, "ZHPTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhptrs_("/", &c__0, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("ZHPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhptrs_("U", &c_n1, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("ZHPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zhptrs_("U", &c__0, &c_n1, a, ip, b, &c__1, &info);
+ chkxer_("ZHPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zhptrs_("U", &c__2, &c__1, a, ip, b, &c__1, &info);
+ chkxer_("ZHPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZHPRFS */
+
+ s_copy(srnamc_1.srnamt, "ZHPRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhprfs_("/", &c__0, &c__0, a, af, ip, b, &c__1, x, &c__1, r1, r2, w,
+ r__, &info);
+ chkxer_("ZHPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhprfs_("U", &c_n1, &c__0, a, af, ip, b, &c__1, x, &c__1, r1, r2, w,
+ r__, &info);
+ chkxer_("ZHPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zhprfs_("U", &c__0, &c_n1, a, af, ip, b, &c__1, x, &c__1, r1, r2, w,
+ r__, &info);
+ chkxer_("ZHPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zhprfs_("U", &c__2, &c__1, a, af, ip, b, &c__1, x, &c__2, r1, r2, w,
+ r__, &info);
+ chkxer_("ZHPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zhprfs_("U", &c__2, &c__1, a, af, ip, b, &c__2, x, &c__1, r1, r2, w,
+ r__, &info);
+ chkxer_("ZHPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZHPCON */
+
+ s_copy(srnamc_1.srnamt, "ZHPCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhpcon_("/", &c__0, a, ip, &anrm, &rcond, w, &info);
+ chkxer_("ZHPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhpcon_("U", &c_n1, a, ip, &anrm, &rcond, w, &info);
+ chkxer_("ZHPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ d__1 = -anrm;
+ zhpcon_("U", &c__1, a, ip, &d__1, &rcond, w, &info);
+ chkxer_("ZHPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of ZERRHE */
+
+} /* zerrhe_ */
diff --git a/TESTING/LIN/zerrlq.c b/TESTING/LIN/zerrlq.c
new file mode 100644
index 0000000..99559db
--- /dev/null
+++ b/TESTING/LIN/zerrlq.c
@@ -0,0 +1,394 @@
+/* zerrlq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int zerrlq_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublecomplex a[4] /* was [2][2] */, b[2];
+ integer i__, j;
+ doublecomplex w[2], x[2], af[4] /* was [2][2] */;
+ integer info;
+ extern /* Subroutine */ int zgelq2_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *), zungl2_(
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *), zunml2_(char *,
+ char *, integer *, integer *, integer *, doublecomplex *, integer
+ *, doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *), alaesm_(char *, logical *, integer *), chkxer_(char *, integer *, integer *, logical *, logical
+ *), zgelqf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *)
+ , zgelqs_(integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *), zunglq_(integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, integer *), zunmlq_(char *, char *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRLQ tests the error exits for the COMPLEX*16 routines */
+/* that use the LQ decomposition of a general matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 2; ++j) {
+ for (i__ = 1; i__ <= 2; ++i__) {
+ i__1 = i__ + (j << 1) - 3;
+ d__1 = 1. / (doublereal) (i__ + j);
+ d__2 = -1. / (doublereal) (i__ + j);
+ z__1.r = d__1, z__1.i = d__2;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = i__ + (j << 1) - 3;
+ d__1 = 1. / (doublereal) (i__ + j);
+ d__2 = -1. / (doublereal) (i__ + j);
+ z__1.r = d__1, z__1.i = d__2;
+ af[i__1].r = z__1.r, af[i__1].i = z__1.i;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0., b[i__1].i = 0.;
+ i__1 = j - 1;
+ w[i__1].r = 0., w[i__1].i = 0.;
+ i__1 = j - 1;
+ x[i__1].r = 0., x[i__1].i = 0.;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+/* Error exits for LQ factorization */
+
+/* ZGELQF */
+
+ s_copy(srnamc_1.srnamt, "ZGELQF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgelqf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
+ chkxer_("ZGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgelqf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("ZGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgelqf_(&c__2, &c__1, a, &c__1, b, w, &c__2, &info);
+ chkxer_("ZGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zgelqf_(&c__2, &c__1, a, &c__2, b, w, &c__1, &info);
+ chkxer_("ZGELQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGELQ2 */
+
+ s_copy(srnamc_1.srnamt, "ZGELQ2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgelq2_(&c_n1, &c__0, a, &c__1, b, w, &info);
+ chkxer_("ZGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgelq2_(&c__0, &c_n1, a, &c__1, b, w, &info);
+ chkxer_("ZGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgelq2_(&c__2, &c__1, a, &c__1, b, w, &info);
+ chkxer_("ZGELQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGELQS */
+
+ s_copy(srnamc_1.srnamt, "ZGELQS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgelqs_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgelqs_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgelqs_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgelqs_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgelqs_(&c__2, &c__2, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
+ chkxer_("ZGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zgelqs_(&c__1, &c__2, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zgelqs_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGELQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZUNGLQ */
+
+ s_copy(srnamc_1.srnamt, "ZUNGLQ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zunglq_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("ZUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zunglq_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("ZUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zunglq_(&c__2, &c__1, &c__0, a, &c__2, x, w, &c__2, &info);
+ chkxer_("ZUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zunglq_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
+ chkxer_("ZUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zunglq_(&c__1, &c__1, &c__2, a, &c__1, x, w, &c__1, &info);
+ chkxer_("ZUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunglq_(&c__2, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
+ chkxer_("ZUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zunglq_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
+ chkxer_("ZUNGLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZUNGL2 */
+
+ s_copy(srnamc_1.srnamt, "ZUNGL2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zungl2_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
+ chkxer_("ZUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zungl2_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("ZUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zungl2_(&c__2, &c__1, &c__0, a, &c__2, x, w, &info);
+ chkxer_("ZUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zungl2_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
+ chkxer_("ZUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zungl2_(&c__1, &c__1, &c__2, a, &c__1, x, w, &info);
+ chkxer_("ZUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zungl2_(&c__2, &c__2, &c__0, a, &c__1, x, w, &info);
+ chkxer_("ZUNGL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZUNMLQ */
+
+ s_copy(srnamc_1.srnamt, "ZUNMLQ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zunmlq_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zunmlq_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zunmlq_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zunmlq_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunmlq_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunmlq_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunmlq_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zunmlq_("L", "N", &c__2, &c__0, &c__2, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zunmlq_("R", "N", &c__0, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zunmlq_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zunmlq_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zunmlq_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("ZUNMLQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZUNML2 */
+
+ s_copy(srnamc_1.srnamt, "ZUNML2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zunml2_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zunml2_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zunml2_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zunml2_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunml2_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunml2_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunml2_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zunml2_("L", "N", &c__2, &c__1, &c__2, a, &c__1, x, af, &c__2, w, &info);
+ chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zunml2_("R", "N", &c__1, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zunml2_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &info);
+ chkxer_("ZUNML2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of ZERRLQ */
+
+} /* zerrlq_ */
diff --git a/TESTING/LIN/zerrls.c b/TESTING/LIN/zerrls.c
new file mode 100644
index 0000000..4c0c110
--- /dev/null
+++ b/TESTING/LIN/zerrls.c
@@ -0,0 +1,302 @@
+/* zerrls.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__10 = 10;
+static integer c__3 = 3;
+
+/* Subroutine */ int zerrls_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void);
+
+ /* Local variables */
+ doublecomplex a[4] /* was [2][2] */, b[4] /* was [2][2] */;
+ doublereal s[2];
+ doublecomplex w[2];
+ char c2[2];
+ integer ip[2];
+ doublereal rw[2];
+ integer info, irnk;
+ doublereal rcond;
+ extern /* Subroutine */ int zgels_(char *, integer *, integer *, integer *
+, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *), alaesm_(char *,
+ logical *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), zgelsd_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, integer *, doublecomplex *, integer *,
+ doublereal *, integer *, integer *), zgelss_(integer *, integer *
+, integer *, doublecomplex *, integer *, doublecomplex *, integer
+ *, doublereal *, doublereal *, integer *, doublecomplex *,
+ integer *, doublereal *, integer *), zgelsx_(integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *
+, integer *, doublereal *, integer *, doublecomplex *, doublereal
+ *, integer *), zgelsy_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ doublereal *, integer *, doublecomplex *, integer *, doublereal *
+, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___3 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRLS tests the error exits for the COMPLEX*16 least squares */
+/* driver routines (ZGELS, CGELSS, CGELSX, CGELSY, CGELSD). */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ a[0].r = 1., a[0].i = 0.;
+ a[2].r = 2., a[2].i = 0.;
+ a[3].r = 3., a[3].i = 0.;
+ a[1].r = 4., a[1].i = 0.;
+ infoc_1.ok = TRUE_;
+ io___3.ciunit = infoc_1.nout;
+ s_wsle(&io___3);
+ e_wsle();
+
+/* Test error exits for the least squares driver routines. */
+
+ if (lsamen_(&c__2, c2, "LS")) {
+
+/* ZGELS */
+
+ s_copy(srnamc_1.srnamt, "ZGELS ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgels_("/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgels_("N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgels_("N", &c__0, &c_n1, &c__0, a, &c__1, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgels_("N", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zgels_("N", &c__2, &c__0, &c__0, a, &c__1, b, &c__2, w, &c__2, &info);
+ chkxer_("ZGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zgels_("N", &c__2, &c__0, &c__0, a, &c__2, b, &c__1, w, &c__2, &info);
+ chkxer_("ZGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zgels_("N", &c__1, &c__1, &c__0, a, &c__1, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGELS ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGELSS */
+
+ s_copy(srnamc_1.srnamt, "ZGELSS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgelss_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__1, rw, &info);
+ chkxer_("ZGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgelss_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__1, rw, &info);
+ chkxer_("ZGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgelss_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__1, rw, &info);
+ chkxer_("ZGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgelss_(&c__2, &c__0, &c__0, a, &c__1, b, &c__2, s, &rcond, &irnk, w,
+ &c__2, rw, &info);
+ chkxer_("ZGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zgelss_(&c__2, &c__0, &c__0, a, &c__2, b, &c__1, s, &rcond, &irnk, w,
+ &c__2, rw, &info);
+ chkxer_("ZGELSS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGELSX */
+
+ s_copy(srnamc_1.srnamt, "ZGELSX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgelsx_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ rw, &info);
+ chkxer_("ZGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgelsx_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ rw, &info);
+ chkxer_("ZGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgelsx_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ rw, &info);
+ chkxer_("ZGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgelsx_(&c__2, &c__0, &c__0, a, &c__1, b, &c__2, ip, &rcond, &irnk, w,
+ rw, &info);
+ chkxer_("ZGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zgelsx_(&c__2, &c__0, &c__0, a, &c__2, b, &c__1, ip, &rcond, &irnk, w,
+ rw, &info);
+ chkxer_("ZGELSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGELSY */
+
+ s_copy(srnamc_1.srnamt, "ZGELSY", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgelsy_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ &c__10, rw, &info);
+ chkxer_("ZGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgelsy_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ &c__10, rw, &info);
+ chkxer_("ZGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgelsy_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, ip, &rcond, &irnk, w,
+ &c__10, rw, &info);
+ chkxer_("ZGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgelsy_(&c__2, &c__0, &c__0, a, &c__1, b, &c__2, ip, &rcond, &irnk, w,
+ &c__10, rw, &info);
+ chkxer_("ZGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zgelsy_(&c__2, &c__0, &c__0, a, &c__2, b, &c__1, ip, &rcond, &irnk, w,
+ &c__10, rw, &info);
+ chkxer_("ZGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zgelsy_(&c__0, &c__3, &c__0, a, &c__1, b, &c__3, ip, &rcond, &irnk, w,
+ &c__1, rw, &info);
+ chkxer_("ZGELSY", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGELSD */
+
+ s_copy(srnamc_1.srnamt, "ZGELSD", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgelsd_(&c_n1, &c__0, &c__0, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__10, rw, ip, &info);
+ chkxer_("ZGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgelsd_(&c__0, &c_n1, &c__0, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__10, rw, ip, &info);
+ chkxer_("ZGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgelsd_(&c__0, &c__0, &c_n1, a, &c__1, b, &c__1, s, &rcond, &irnk, w,
+ &c__10, rw, ip, &info);
+ chkxer_("ZGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgelsd_(&c__2, &c__0, &c__0, a, &c__1, b, &c__2, s, &rcond, &irnk, w,
+ &c__10, rw, ip, &info);
+ chkxer_("ZGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zgelsd_(&c__2, &c__0, &c__0, a, &c__2, b, &c__1, s, &rcond, &irnk, w,
+ &c__10, rw, ip, &info);
+ chkxer_("ZGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zgelsd_(&c__2, &c__2, &c__1, a, &c__2, b, &c__2, s, &rcond, &irnk, w,
+ &c__1, rw, ip, &info);
+ chkxer_("ZGELSD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of ZERRLS */
+
+} /* zerrls_ */
diff --git a/TESTING/LIN/zerrpo.c b/TESTING/LIN/zerrpo.c
new file mode 100644
index 0000000..27e3091
--- /dev/null
+++ b/TESTING/LIN/zerrpo.c
@@ -0,0 +1,612 @@
+/* zerrpo.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zerrpo_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublecomplex a[16] /* was [4][4] */, b[4];
+ integer i__, j;
+ doublereal r__[4];
+ doublecomplex w[8], x[4];
+ char c2[2];
+ doublereal r1[4], r2[4];
+ doublecomplex af[16] /* was [4][4] */;
+ integer info;
+ doublereal anrm, rcond;
+ extern /* Subroutine */ int zpbtf2_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *), zpotf2_(char *,
+ integer *, doublecomplex *, integer *, integer *),
+ alaesm_(char *, logical *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), zpbcon_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *), zpbequ_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *), zpbrfs_(char *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *), zpbtrf_(char *,
+ integer *, integer *, doublecomplex *, integer *, integer *), zpocon_(char *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zppcon_(char *, integer *, doublecomplex *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zpoequ_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *), zpbtrs_(
+ char *, integer *, integer *, integer *, doublecomplex *, integer
+ *, doublecomplex *, integer *, integer *), zporfs_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *, doublecomplex *, integer *, doublecomplex *, integer
+ *, doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zpotrf_(char *, integer *, doublecomplex *,
+ integer *, integer *), zpotri_(char *, integer *,
+ doublecomplex *, integer *, integer *), zppequ_(char *,
+ integer *, doublecomplex *, doublereal *, doublereal *,
+ doublereal *, integer *), zpprfs_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *), zpptrf_(char *
+, integer *, doublecomplex *, integer *), zpptri_(char *,
+ integer *, doublecomplex *, integer *), zpotrs_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *), zpptrs_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRPO tests the error exits for the COMPLEX*16 routines */
+/* for Hermitian positive definite matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ d__1 = 1. / (doublereal) (i__ + j);
+ d__2 = -1. / (doublereal) (i__ + j);
+ z__1.r = d__1, z__1.i = d__2;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = i__ + (j << 2) - 5;
+ d__1 = 1. / (doublereal) (i__ + j);
+ d__2 = -1. / (doublereal) (i__ + j);
+ z__1.r = d__1, z__1.i = d__2;
+ af[i__1].r = z__1.r, af[i__1].i = z__1.i;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0., b[i__1].i = 0.;
+ r1[j - 1] = 0.;
+ r2[j - 1] = 0.;
+ i__1 = j - 1;
+ w[i__1].r = 0., w[i__1].i = 0.;
+ i__1 = j - 1;
+ x[i__1].r = 0., x[i__1].i = 0.;
+/* L20: */
+ }
+ anrm = 1.;
+ infoc_1.ok = TRUE_;
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a Hermitian positive definite matrix. */
+
+ if (lsamen_(&c__2, c2, "PO")) {
+
+/* ZPOTRF */
+
+ s_copy(srnamc_1.srnamt, "ZPOTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpotrf_("/", &c__0, a, &c__1, &info);
+ chkxer_("ZPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpotrf_("U", &c_n1, a, &c__1, &info);
+ chkxer_("ZPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zpotrf_("U", &c__2, a, &c__1, &info);
+ chkxer_("ZPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPOTF2 */
+
+ s_copy(srnamc_1.srnamt, "ZPOTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpotf2_("/", &c__0, a, &c__1, &info);
+ chkxer_("ZPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpotf2_("U", &c_n1, a, &c__1, &info);
+ chkxer_("ZPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zpotf2_("U", &c__2, a, &c__1, &info);
+ chkxer_("ZPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPOTRI */
+
+ s_copy(srnamc_1.srnamt, "ZPOTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpotri_("/", &c__0, a, &c__1, &info);
+ chkxer_("ZPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpotri_("U", &c_n1, a, &c__1, &info);
+ chkxer_("ZPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zpotri_("U", &c__2, a, &c__1, &info);
+ chkxer_("ZPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPOTRS */
+
+ s_copy(srnamc_1.srnamt, "ZPOTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpotrs_("/", &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("ZPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpotrs_("U", &c_n1, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("ZPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpotrs_("U", &c__0, &c_n1, a, &c__1, b, &c__1, &info);
+ chkxer_("ZPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zpotrs_("U", &c__2, &c__1, a, &c__1, b, &c__2, &info);
+ chkxer_("ZPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zpotrs_("U", &c__2, &c__1, a, &c__2, b, &c__1, &info);
+ chkxer_("ZPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPORFS */
+
+ s_copy(srnamc_1.srnamt, "ZPORFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zporfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, r__, &info);
+ chkxer_("ZPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zporfs_("U", &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, r__, &info);
+ chkxer_("ZPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zporfs_("U", &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, r__, &info);
+ chkxer_("ZPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zporfs_("U", &c__2, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &c__2,
+ r1, r2, w, r__, &info);
+ chkxer_("ZPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zporfs_("U", &c__2, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &c__2,
+ r1, r2, w, r__, &info);
+ chkxer_("ZPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__1, x, &c__2,
+ r1, r2, w, r__, &info);
+ chkxer_("ZPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__2, x, &c__1,
+ r1, r2, w, r__, &info);
+ chkxer_("ZPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPOCON */
+
+ s_copy(srnamc_1.srnamt, "ZPOCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpocon_("/", &c__0, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("ZPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpocon_("U", &c_n1, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("ZPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zpocon_("U", &c__2, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("ZPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ d__1 = -anrm;
+ zpocon_("U", &c__1, a, &c__1, &d__1, &rcond, w, r__, &info)
+ ;
+ chkxer_("ZPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPOEQU */
+
+ s_copy(srnamc_1.srnamt, "ZPOEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpoequ_(&c_n1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("ZPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpoequ_(&c__2, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("ZPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a Hermitian positive definite packed matrix. */
+
+ } else if (lsamen_(&c__2, c2, "PP")) {
+
+/* ZPPTRF */
+
+ s_copy(srnamc_1.srnamt, "ZPPTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpptrf_("/", &c__0, a, &info);
+ chkxer_("ZPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpptrf_("U", &c_n1, a, &info);
+ chkxer_("ZPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPPTRI */
+
+ s_copy(srnamc_1.srnamt, "ZPPTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpptri_("/", &c__0, a, &info);
+ chkxer_("ZPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpptri_("U", &c_n1, a, &info);
+ chkxer_("ZPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPPTRS */
+
+ s_copy(srnamc_1.srnamt, "ZPPTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpptrs_("/", &c__0, &c__0, a, b, &c__1, &info);
+ chkxer_("ZPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpptrs_("U", &c_n1, &c__0, a, b, &c__1, &info);
+ chkxer_("ZPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpptrs_("U", &c__0, &c_n1, a, b, &c__1, &info);
+ chkxer_("ZPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zpptrs_("U", &c__2, &c__1, a, b, &c__1, &info);
+ chkxer_("ZPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPPRFS */
+
+ s_copy(srnamc_1.srnamt, "ZPPRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpprfs_("/", &c__0, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, r__,
+ &info);
+ chkxer_("ZPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpprfs_("U", &c_n1, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, r__,
+ &info);
+ chkxer_("ZPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpprfs_("U", &c__0, &c_n1, a, af, b, &c__1, x, &c__1, r1, r2, w, r__,
+ &info);
+ chkxer_("ZPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zpprfs_("U", &c__2, &c__1, a, af, b, &c__1, x, &c__2, r1, r2, w, r__,
+ &info);
+ chkxer_("ZPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zpprfs_("U", &c__2, &c__1, a, af, b, &c__2, x, &c__1, r1, r2, w, r__,
+ &info);
+ chkxer_("ZPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPPCON */
+
+ s_copy(srnamc_1.srnamt, "ZPPCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zppcon_("/", &c__0, a, &anrm, &rcond, w, r__, &info);
+ chkxer_("ZPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zppcon_("U", &c_n1, a, &anrm, &rcond, w, r__, &info);
+ chkxer_("ZPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ d__1 = -anrm;
+ zppcon_("U", &c__1, a, &d__1, &rcond, w, r__, &info);
+ chkxer_("ZPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPPEQU */
+
+ s_copy(srnamc_1.srnamt, "ZPPEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zppequ_("/", &c__0, a, r1, &rcond, &anrm, &info);
+ chkxer_("ZPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zppequ_("U", &c_n1, a, r1, &rcond, &anrm, &info);
+ chkxer_("ZPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a Hermitian positive definite band matrix. */
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* ZPBTRF */
+
+ s_copy(srnamc_1.srnamt, "ZPBTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpbtrf_("/", &c__0, &c__0, a, &c__1, &info);
+ chkxer_("ZPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpbtrf_("U", &c_n1, &c__0, a, &c__1, &info);
+ chkxer_("ZPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpbtrf_("U", &c__1, &c_n1, a, &c__1, &info);
+ chkxer_("ZPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zpbtrf_("U", &c__2, &c__1, a, &c__1, &info);
+ chkxer_("ZPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPBTF2 */
+
+ s_copy(srnamc_1.srnamt, "ZPBTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpbtf2_("/", &c__0, &c__0, a, &c__1, &info);
+ chkxer_("ZPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpbtf2_("U", &c_n1, &c__0, a, &c__1, &info);
+ chkxer_("ZPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpbtf2_("U", &c__1, &c_n1, a, &c__1, &info);
+ chkxer_("ZPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zpbtf2_("U", &c__2, &c__1, a, &c__1, &info);
+ chkxer_("ZPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPBTRS */
+
+ s_copy(srnamc_1.srnamt, "ZPBTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpbtrs_("/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("ZPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpbtrs_("U", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("ZPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpbtrs_("U", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("ZPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zpbtrs_("U", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, &info);
+ chkxer_("ZPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zpbtrs_("U", &c__2, &c__1, &c__1, a, &c__1, b, &c__1, &info);
+ chkxer_("ZPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zpbtrs_("U", &c__2, &c__0, &c__1, a, &c__1, b, &c__1, &info);
+ chkxer_("ZPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPBRFS */
+
+ s_copy(srnamc_1.srnamt, "ZPBRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpbrfs_("/", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpbrfs_("U", &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpbrfs_("U", &c__1, &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zpbrfs_("U", &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zpbrfs_("U", &c__2, &c__1, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("ZPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zpbrfs_("U", &c__2, &c__1, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("ZPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zpbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("ZPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zpbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__2, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPBCON */
+
+ s_copy(srnamc_1.srnamt, "ZPBCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpbcon_("/", &c__0, &c__0, a, &c__1, &anrm, &rcond, w, r__, &info);
+ chkxer_("ZPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpbcon_("U", &c_n1, &c__0, a, &c__1, &anrm, &rcond, w, r__, &info);
+ chkxer_("ZPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpbcon_("U", &c__1, &c_n1, a, &c__1, &anrm, &rcond, w, r__, &info);
+ chkxer_("ZPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zpbcon_("U", &c__2, &c__1, a, &c__1, &anrm, &rcond, w, r__, &info);
+ chkxer_("ZPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ d__1 = -anrm;
+ zpbcon_("U", &c__1, &c__0, a, &c__1, &d__1, &rcond, w, r__, &info);
+ chkxer_("ZPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPBEQU */
+
+ s_copy(srnamc_1.srnamt, "ZPBEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpbequ_("/", &c__0, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("ZPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpbequ_("U", &c_n1, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("ZPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpbequ_("U", &c__1, &c_n1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("ZPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zpbequ_("U", &c__2, &c__1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("ZPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of ZERRPO */
+
+} /* zerrpo_ */
diff --git a/TESTING/LIN/zerrpox.c b/TESTING/LIN/zerrpox.c
new file mode 100644
index 0000000..37eb443
--- /dev/null
+++ b/TESTING/LIN/zerrpox.c
@@ -0,0 +1,693 @@
+/* zerrpox.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zerrpo_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublecomplex a[16] /* was [4][4] */, b[4];
+ integer i__, j;
+ doublereal r__[4], s[4];
+ doublecomplex w[8], x[4];
+ char c2[2];
+ doublereal r1[4], r2[4];
+ doublecomplex af[16] /* was [4][4] */;
+ char eq[1];
+ doublereal err_bnds_c__[12] /* was [4][3] */;
+ integer n_err_bnds__;
+ doublereal err_bnds_n__[12] /* was [4][3] */, berr;
+ integer info;
+ doublereal anrm, rcond;
+ extern /* Subroutine */ int zpbtf2_(char *, integer *, integer *,
+ doublecomplex *, integer *, integer *), zpotf2_(char *,
+ integer *, doublecomplex *, integer *, integer *),
+ alaesm_(char *, logical *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ doublereal params;
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), zpbcon_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *), zpbequ_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublereal *,
+ doublereal *, doublereal *, integer *), zpbrfs_(char *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *), zpbtrf_(char *,
+ integer *, integer *, doublecomplex *, integer *, integer *), zpocon_(char *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zppcon_(char *, integer *, doublecomplex *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zpoequ_(integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *), zpbtrs_(
+ char *, integer *, integer *, integer *, doublecomplex *, integer
+ *, doublecomplex *, integer *, integer *), zporfs_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *, doublecomplex *, integer *, doublecomplex *, integer
+ *, doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zpotrf_(char *, integer *, doublecomplex *,
+ integer *, integer *), zpotri_(char *, integer *,
+ doublecomplex *, integer *, integer *), zppequ_(char *,
+ integer *, doublecomplex *, doublereal *, doublereal *,
+ doublereal *, integer *), zpprfs_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *), zpptrf_(char *
+, integer *, doublecomplex *, integer *), zpptri_(char *,
+ integer *, doublecomplex *, integer *), zpotrs_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *), zpptrs_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *);
+ integer nparams;
+ extern /* Subroutine */ int zpoequb_(integer *, doublecomplex *, integer *
+, doublereal *, doublereal *, doublereal *, integer *), zporfsx_(
+ char *, char *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ doublecomplex *, doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRPO tests the error exits for the COMPLEX*16 routines */
+/* for Hermitian positive definite matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ d__1 = 1. / (doublereal) (i__ + j);
+ d__2 = -1. / (doublereal) (i__ + j);
+ z__1.r = d__1, z__1.i = d__2;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = i__ + (j << 2) - 5;
+ d__1 = 1. / (doublereal) (i__ + j);
+ d__2 = -1. / (doublereal) (i__ + j);
+ z__1.r = d__1, z__1.i = d__2;
+ af[i__1].r = z__1.r, af[i__1].i = z__1.i;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0., b[i__1].i = 0.;
+ r1[j - 1] = 0.;
+ r2[j - 1] = 0.;
+ i__1 = j - 1;
+ w[i__1].r = 0., w[i__1].i = 0.;
+ i__1 = j - 1;
+ x[i__1].r = 0., x[i__1].i = 0.;
+ s[j - 1] = 0.;
+/* L20: */
+ }
+ anrm = 1.;
+ infoc_1.ok = TRUE_;
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a Hermitian positive definite matrix. */
+
+ if (lsamen_(&c__2, c2, "PO")) {
+
+/* ZPOTRF */
+
+ s_copy(srnamc_1.srnamt, "ZPOTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpotrf_("/", &c__0, a, &c__1, &info);
+ chkxer_("ZPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpotrf_("U", &c_n1, a, &c__1, &info);
+ chkxer_("ZPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zpotrf_("U", &c__2, a, &c__1, &info);
+ chkxer_("ZPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPOTF2 */
+
+ s_copy(srnamc_1.srnamt, "ZPOTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpotf2_("/", &c__0, a, &c__1, &info);
+ chkxer_("ZPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpotf2_("U", &c_n1, a, &c__1, &info);
+ chkxer_("ZPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zpotf2_("U", &c__2, a, &c__1, &info);
+ chkxer_("ZPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPOTRI */
+
+ s_copy(srnamc_1.srnamt, "ZPOTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpotri_("/", &c__0, a, &c__1, &info);
+ chkxer_("ZPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpotri_("U", &c_n1, a, &c__1, &info);
+ chkxer_("ZPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zpotri_("U", &c__2, a, &c__1, &info);
+ chkxer_("ZPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPOTRS */
+
+ s_copy(srnamc_1.srnamt, "ZPOTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpotrs_("/", &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("ZPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpotrs_("U", &c_n1, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("ZPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpotrs_("U", &c__0, &c_n1, a, &c__1, b, &c__1, &info);
+ chkxer_("ZPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zpotrs_("U", &c__2, &c__1, a, &c__1, b, &c__2, &info);
+ chkxer_("ZPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zpotrs_("U", &c__2, &c__1, a, &c__2, b, &c__1, &info);
+ chkxer_("ZPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPORFS */
+
+ s_copy(srnamc_1.srnamt, "ZPORFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zporfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, r__, &info);
+ chkxer_("ZPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zporfs_("U", &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, r__, &info);
+ chkxer_("ZPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zporfs_("U", &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
+ r1, r2, w, r__, &info);
+ chkxer_("ZPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zporfs_("U", &c__2, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &c__2,
+ r1, r2, w, r__, &info);
+ chkxer_("ZPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zporfs_("U", &c__2, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &c__2,
+ r1, r2, w, r__, &info);
+ chkxer_("ZPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__1, x, &c__2,
+ r1, r2, w, r__, &info);
+ chkxer_("ZPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__2, x, &c__1,
+ r1, r2, w, r__, &info);
+ chkxer_("ZPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPORFSX */
+
+ n_err_bnds__ = 3;
+ nparams = 0;
+ s_copy(srnamc_1.srnamt, "ZPORFSX", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ zporfsx_("/", eq, &c__0, &c__0, a, &c__1, af, &c__1, s, b, &c__1, x, &
+ c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zporfsx_("U", eq, &c_n1, &c__0, a, &c__1, af, &c__1, s, b, &c__1, x, &
+ c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ *(unsigned char *)eq = 'N';
+ infoc_1.infot = 3;
+ zporfsx_("U", eq, &c_n1, &c__0, a, &c__1, af, &c__1, s, b, &c__1, x, &
+ c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zporfsx_("U", eq, &c__0, &c_n1, a, &c__1, af, &c__1, s, b, &c__1, x, &
+ c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zporfsx_("U", eq, &c__2, &c__1, a, &c__1, af, &c__2, s, b, &c__2, x, &
+ c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zporfsx_("U", eq, &c__2, &c__1, a, &c__2, af, &c__1, s, b, &c__2, x, &
+ c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zporfsx_("U", eq, &c__2, &c__1, a, &c__2, af, &c__2, s, b, &c__1, x, &
+ c__2, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ zporfsx_("U", eq, &c__2, &c__1, a, &c__2, af, &c__2, s, b, &c__2, x, &
+ c__1, &rcond, &berr, &n_err_bnds__, err_bnds_n__,
+ err_bnds_c__, &nparams, ¶ms, w, r__, &info);
+ chkxer_("ZPORFSX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPOCON */
+
+ s_copy(srnamc_1.srnamt, "ZPOCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpocon_("/", &c__0, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("ZPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpocon_("U", &c_n1, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("ZPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zpocon_("U", &c__2, a, &c__1, &anrm, &rcond, w, r__, &info)
+ ;
+ chkxer_("ZPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ d__1 = -anrm;
+ zpocon_("U", &c__1, a, &c__1, &d__1, &rcond, w, r__, &info)
+ ;
+ chkxer_("ZPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPOEQU */
+
+ s_copy(srnamc_1.srnamt, "ZPOEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpoequ_(&c_n1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("ZPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpoequ_(&c__2, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("ZPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPOEQUB */
+
+ s_copy(srnamc_1.srnamt, "ZPOEQUB", (ftnlen)32, (ftnlen)7);
+ infoc_1.infot = 1;
+ zpoequb_(&c_n1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("ZPOEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpoequb_(&c__2, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("ZPOEQUB", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a Hermitian positive definite packed matrix. */
+
+ } else if (lsamen_(&c__2, c2, "PP")) {
+
+/* ZPPTRF */
+
+ s_copy(srnamc_1.srnamt, "ZPPTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpptrf_("/", &c__0, a, &info);
+ chkxer_("ZPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpptrf_("U", &c_n1, a, &info);
+ chkxer_("ZPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPPTRI */
+
+ s_copy(srnamc_1.srnamt, "ZPPTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpptri_("/", &c__0, a, &info);
+ chkxer_("ZPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpptri_("U", &c_n1, a, &info);
+ chkxer_("ZPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPPTRS */
+
+ s_copy(srnamc_1.srnamt, "ZPPTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpptrs_("/", &c__0, &c__0, a, b, &c__1, &info);
+ chkxer_("ZPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpptrs_("U", &c_n1, &c__0, a, b, &c__1, &info);
+ chkxer_("ZPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpptrs_("U", &c__0, &c_n1, a, b, &c__1, &info);
+ chkxer_("ZPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zpptrs_("U", &c__2, &c__1, a, b, &c__1, &info);
+ chkxer_("ZPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPPRFS */
+
+ s_copy(srnamc_1.srnamt, "ZPPRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpprfs_("/", &c__0, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, r__,
+ &info);
+ chkxer_("ZPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpprfs_("U", &c_n1, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, r__,
+ &info);
+ chkxer_("ZPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpprfs_("U", &c__0, &c_n1, a, af, b, &c__1, x, &c__1, r1, r2, w, r__,
+ &info);
+ chkxer_("ZPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zpprfs_("U", &c__2, &c__1, a, af, b, &c__1, x, &c__2, r1, r2, w, r__,
+ &info);
+ chkxer_("ZPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zpprfs_("U", &c__2, &c__1, a, af, b, &c__2, x, &c__1, r1, r2, w, r__,
+ &info);
+ chkxer_("ZPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPPCON */
+
+ s_copy(srnamc_1.srnamt, "ZPPCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zppcon_("/", &c__0, a, &anrm, &rcond, w, r__, &info);
+ chkxer_("ZPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zppcon_("U", &c_n1, a, &anrm, &rcond, w, r__, &info);
+ chkxer_("ZPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ d__1 = -anrm;
+ zppcon_("U", &c__1, a, &d__1, &rcond, w, r__, &info);
+ chkxer_("ZPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPPEQU */
+
+ s_copy(srnamc_1.srnamt, "ZPPEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zppequ_("/", &c__0, a, r1, &rcond, &anrm, &info);
+ chkxer_("ZPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zppequ_("U", &c_n1, a, r1, &rcond, &anrm, &info);
+ chkxer_("ZPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of a Hermitian positive definite band matrix. */
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* ZPBTRF */
+
+ s_copy(srnamc_1.srnamt, "ZPBTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpbtrf_("/", &c__0, &c__0, a, &c__1, &info);
+ chkxer_("ZPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpbtrf_("U", &c_n1, &c__0, a, &c__1, &info);
+ chkxer_("ZPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpbtrf_("U", &c__1, &c_n1, a, &c__1, &info);
+ chkxer_("ZPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zpbtrf_("U", &c__2, &c__1, a, &c__1, &info);
+ chkxer_("ZPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPBTF2 */
+
+ s_copy(srnamc_1.srnamt, "ZPBTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpbtf2_("/", &c__0, &c__0, a, &c__1, &info);
+ chkxer_("ZPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpbtf2_("U", &c_n1, &c__0, a, &c__1, &info);
+ chkxer_("ZPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpbtf2_("U", &c__1, &c_n1, a, &c__1, &info);
+ chkxer_("ZPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zpbtf2_("U", &c__2, &c__1, a, &c__1, &info);
+ chkxer_("ZPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPBTRS */
+
+ s_copy(srnamc_1.srnamt, "ZPBTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpbtrs_("/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("ZPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpbtrs_("U", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("ZPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpbtrs_("U", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("ZPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zpbtrs_("U", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, &info);
+ chkxer_("ZPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zpbtrs_("U", &c__2, &c__1, &c__1, a, &c__1, b, &c__1, &info);
+ chkxer_("ZPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zpbtrs_("U", &c__2, &c__0, &c__1, a, &c__1, b, &c__1, &info);
+ chkxer_("ZPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPBRFS */
+
+ s_copy(srnamc_1.srnamt, "ZPBRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpbrfs_("/", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpbrfs_("U", &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpbrfs_("U", &c__1, &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zpbrfs_("U", &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zpbrfs_("U", &c__2, &c__1, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("ZPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zpbrfs_("U", &c__2, &c__1, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("ZPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zpbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__1, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("ZPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zpbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__2, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPBCON */
+
+ s_copy(srnamc_1.srnamt, "ZPBCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpbcon_("/", &c__0, &c__0, a, &c__1, &anrm, &rcond, w, r__, &info);
+ chkxer_("ZPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpbcon_("U", &c_n1, &c__0, a, &c__1, &anrm, &rcond, w, r__, &info);
+ chkxer_("ZPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpbcon_("U", &c__1, &c_n1, a, &c__1, &anrm, &rcond, w, r__, &info);
+ chkxer_("ZPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zpbcon_("U", &c__2, &c__1, a, &c__1, &anrm, &rcond, w, r__, &info);
+ chkxer_("ZPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ d__1 = -anrm;
+ zpbcon_("U", &c__1, &c__0, a, &c__1, &d__1, &rcond, w, r__, &info);
+ chkxer_("ZPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPBEQU */
+
+ s_copy(srnamc_1.srnamt, "ZPBEQU", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpbequ_("/", &c__0, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("ZPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpbequ_("U", &c_n1, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("ZPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpbequ_("U", &c__1, &c_n1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("ZPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zpbequ_("U", &c__2, &c__1, a, &c__1, r1, &rcond, &anrm, &info);
+ chkxer_("ZPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of ZERRPO */
+
+} /* zerrpo_ */
diff --git a/TESTING/LIN/zerrps.c b/TESTING/LIN/zerrps.c
new file mode 100644
index 0000000..db3da78
--- /dev/null
+++ b/TESTING/LIN/zerrps.c
@@ -0,0 +1,172 @@
+/* zerrps.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c__1 = 1;
+static doublereal c_b9 = -1.;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+
+/* Subroutine */ int zerrps_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublecomplex a[16] /* was [4][4] */;
+ integer i__, j, piv[4], info;
+ doublereal rwork[8];
+ extern /* Subroutine */ int zpstf2_(char *, integer *, doublecomplex *,
+ integer *, integer *, integer *, doublereal *, doublereal *,
+ integer *), alaesm_(char *, logical *, integer *),
+ chkxer_(char *, integer *, integer *, logical *, logical *), zpstrf_(char *, integer *, doublecomplex *, integer *,
+ integer *, integer *, doublereal *, doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRPS tests the error exits for the COMPLEX routines */
+/* for ZPSTRF. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ d__1 = 1. / (doublereal) (i__ + j);
+ a[i__1].r = d__1, a[i__1].i = 0.;
+
+/* L100: */
+ }
+ piv[j - 1] = j;
+ rwork[j - 1] = 0.;
+ rwork[j + 3] = 0.;
+
+/* L110: */
+ }
+ infoc_1.ok = TRUE_;
+
+
+/* Test error exits of the routines that use the Cholesky */
+/* decomposition of an Hermitian positive semidefinite matrix. */
+
+/* ZPSTRF */
+
+ s_copy(srnamc_1.srnamt, "ZPSTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpstrf_("/", &c__0, a, &c__1, piv, &c__1, &c_b9, rwork, &info);
+ chkxer_("ZPSTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpstrf_("U", &c_n1, a, &c__1, piv, &c__1, &c_b9, rwork, &info);
+ chkxer_("ZPSTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zpstrf_("U", &c__2, a, &c__1, piv, &c__1, &c_b9, rwork, &info);
+ chkxer_("ZPSTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPSTF2 */
+
+ s_copy(srnamc_1.srnamt, "ZPSTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpstf2_("/", &c__0, a, &c__1, piv, &c__1, &c_b9, rwork, &info);
+ chkxer_("ZPSTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpstf2_("U", &c_n1, a, &c__1, piv, &c__1, &c_b9, rwork, &info);
+ chkxer_("ZPSTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zpstf2_("U", &c__2, a, &c__1, piv, &c__1, &c_b9, rwork, &info);
+ chkxer_("ZPSTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of ZERRPS */
+
+} /* zerrps_ */
diff --git a/TESTING/LIN/zerrql.c b/TESTING/LIN/zerrql.c
new file mode 100644
index 0000000..13999a6
--- /dev/null
+++ b/TESTING/LIN/zerrql.c
@@ -0,0 +1,394 @@
+/* zerrql.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int zerrql_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublecomplex a[4] /* was [2][2] */, b[2];
+ integer i__, j;
+ doublecomplex w[2], x[2], af[4] /* was [2][2] */;
+ integer info;
+ extern /* Subroutine */ int zgeql2_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *), zung2l_(
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *), zunm2l_(char *,
+ char *, integer *, integer *, integer *, doublecomplex *, integer
+ *, doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *), alaesm_(char *, logical *, integer *), chkxer_(char *, integer *, integer *, logical *, logical
+ *), zgeqlf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *)
+ , zgeqls_(integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *), zungql_(integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, integer *), zunmql_(char *, char *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRQL tests the error exits for the COMPLEX*16 routines */
+/* that use the QL decomposition of a general matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 2; ++j) {
+ for (i__ = 1; i__ <= 2; ++i__) {
+ i__1 = i__ + (j << 1) - 3;
+ d__1 = 1. / (doublereal) (i__ + j);
+ d__2 = -1. / (doublereal) (i__ + j);
+ z__1.r = d__1, z__1.i = d__2;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = i__ + (j << 1) - 3;
+ d__1 = 1. / (doublereal) (i__ + j);
+ d__2 = -1. / (doublereal) (i__ + j);
+ z__1.r = d__1, z__1.i = d__2;
+ af[i__1].r = z__1.r, af[i__1].i = z__1.i;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0., b[i__1].i = 0.;
+ i__1 = j - 1;
+ w[i__1].r = 0., w[i__1].i = 0.;
+ i__1 = j - 1;
+ x[i__1].r = 0., x[i__1].i = 0.;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+/* Error exits for QL factorization */
+
+/* ZGEQLF */
+
+ s_copy(srnamc_1.srnamt, "ZGEQLF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgeqlf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
+ chkxer_("ZGEQLF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgeqlf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("ZGEQLF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgeqlf_(&c__2, &c__1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("ZGEQLF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zgeqlf_(&c__1, &c__2, a, &c__1, b, w, &c__1, &info);
+ chkxer_("ZGEQLF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGEQL2 */
+
+ s_copy(srnamc_1.srnamt, "ZGEQL2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgeql2_(&c_n1, &c__0, a, &c__1, b, w, &info);
+ chkxer_("ZGEQL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgeql2_(&c__0, &c_n1, a, &c__1, b, w, &info);
+ chkxer_("ZGEQL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgeql2_(&c__2, &c__1, a, &c__1, b, w, &info);
+ chkxer_("ZGEQL2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGEQLS */
+
+ s_copy(srnamc_1.srnamt, "ZGEQLS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgeqls_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgeqls_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgeqls_(&c__1, &c__2, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgeqls_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgeqls_(&c__2, &c__1, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
+ chkxer_("ZGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zgeqls_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zgeqls_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGEQLS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZUNGQL */
+
+ s_copy(srnamc_1.srnamt, "ZUNGQL", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zungql_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("ZUNGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zungql_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("ZUNGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zungql_(&c__1, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
+ chkxer_("ZUNGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zungql_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
+ chkxer_("ZUNGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zungql_(&c__1, &c__1, &c__2, a, &c__1, x, w, &c__1, &info);
+ chkxer_("ZUNGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zungql_(&c__2, &c__1, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("ZUNGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zungql_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
+ chkxer_("ZUNGQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZUNG2L */
+
+ s_copy(srnamc_1.srnamt, "ZUNG2L", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zung2l_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
+ chkxer_("ZUNG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zung2l_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("ZUNG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zung2l_(&c__1, &c__2, &c__0, a, &c__1, x, w, &info);
+ chkxer_("ZUNG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zung2l_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
+ chkxer_("ZUNG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zung2l_(&c__2, &c__1, &c__2, a, &c__2, x, w, &info);
+ chkxer_("ZUNG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zung2l_(&c__2, &c__1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("ZUNG2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZUNMQL */
+
+ s_copy(srnamc_1.srnamt, "ZUNMQL", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zunmql_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zunmql_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zunmql_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zunmql_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunmql_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunmql_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunmql_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zunmql_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("ZUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zunmql_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zunmql_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zunmql_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zunmql_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("ZUNMQL", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZUNM2L */
+
+ s_copy(srnamc_1.srnamt, "ZUNM2L", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zunm2l_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zunm2l_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zunm2l_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zunm2l_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunm2l_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunm2l_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunm2l_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zunm2l_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &info);
+ chkxer_("ZUNM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zunm2l_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zunm2l_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &info);
+ chkxer_("ZUNM2L", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of ZERRQL */
+
+} /* zerrql_ */
diff --git a/TESTING/LIN/zerrqp.c b/TESTING/LIN/zerrqp.c
new file mode 100644
index 0000000..e971b06
--- /dev/null
+++ b/TESTING/LIN/zerrqp.c
@@ -0,0 +1,172 @@
+/* zerrqp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__3 = 3;
+
+/* Subroutine */ int zerrqp_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void);
+
+ /* Local variables */
+ doublecomplex a[9] /* was [3][3] */, w[15];
+ char c2[2];
+ integer ip[3], lw;
+ doublereal rw[6];
+ doublecomplex tau[3];
+ integer info;
+ extern /* Subroutine */ int zgeqp3_(integer *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *
+, doublereal *, integer *), alaesm_(char *, logical *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), zgeqpf_(integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublereal *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___4 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRQP tests the error exits for ZGEQPF and CGEQP3. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ lw = 4;
+ a[0].r = 1., a[0].i = -1.;
+ a[3].r = 2., a[3].i = -2.;
+ a[4].r = 3., a[4].i = -3.;
+ a[1].r = 4., a[1].i = -4.;
+ infoc_1.ok = TRUE_;
+ io___4.ciunit = infoc_1.nout;
+ s_wsle(&io___4);
+ e_wsle();
+
+/* Test error exits for QR factorization with pivoting */
+
+ if (lsamen_(&c__2, c2, "QP")) {
+
+/* ZGEQPF */
+
+ s_copy(srnamc_1.srnamt, "ZGEQPF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgeqpf_(&c_n1, &c__0, a, &c__1, ip, tau, w, rw, &info);
+ chkxer_("ZGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgeqpf_(&c__0, &c_n1, a, &c__1, ip, tau, w, rw, &info);
+ chkxer_("ZGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgeqpf_(&c__2, &c__0, a, &c__1, ip, tau, w, rw, &info);
+ chkxer_("ZGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGEQP3 */
+
+ s_copy(srnamc_1.srnamt, "ZGEQP3", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgeqp3_(&c_n1, &c__0, a, &c__1, ip, tau, w, &lw, rw, &info);
+ chkxer_("ZGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgeqp3_(&c__1, &c_n1, a, &c__1, ip, tau, w, &lw, rw, &info);
+ chkxer_("ZGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgeqp3_(&c__2, &c__3, a, &c__1, ip, tau, w, &lw, rw, &info);
+ chkxer_("ZGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ i__1 = lw - 10;
+ zgeqp3_(&c__2, &c__2, a, &c__2, ip, tau, w, &i__1, rw, &info);
+ chkxer_("ZGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of ZERRQP */
+
+} /* zerrqp_ */
diff --git a/TESTING/LIN/zerrqr.c b/TESTING/LIN/zerrqr.c
new file mode 100644
index 0000000..ec6231e
--- /dev/null
+++ b/TESTING/LIN/zerrqr.c
@@ -0,0 +1,394 @@
+/* zerrqr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int zerrqr_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublecomplex a[4] /* was [2][2] */, b[2];
+ integer i__, j;
+ doublecomplex w[2], x[2], af[4] /* was [2][2] */;
+ integer info;
+ extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *), zung2r_(
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *), zunm2r_(char *,
+ char *, integer *, integer *, integer *, doublecomplex *, integer
+ *, doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *), alaesm_(char *, logical *, integer *), chkxer_(char *, integer *, integer *, logical *, logical
+ *), zgeqrf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *)
+ , zgeqrs_(integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *), zungqr_(integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, integer *), zunmqr_(char *, char *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRQR tests the error exits for the COMPLEX*16 routines */
+/* that use the QR decomposition of a general matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 2; ++j) {
+ for (i__ = 1; i__ <= 2; ++i__) {
+ i__1 = i__ + (j << 1) - 3;
+ d__1 = 1. / (doublereal) (i__ + j);
+ d__2 = -1. / (doublereal) (i__ + j);
+ z__1.r = d__1, z__1.i = d__2;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = i__ + (j << 1) - 3;
+ d__1 = 1. / (doublereal) (i__ + j);
+ d__2 = -1. / (doublereal) (i__ + j);
+ z__1.r = d__1, z__1.i = d__2;
+ af[i__1].r = z__1.r, af[i__1].i = z__1.i;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0., b[i__1].i = 0.;
+ i__1 = j - 1;
+ w[i__1].r = 0., w[i__1].i = 0.;
+ i__1 = j - 1;
+ x[i__1].r = 0., x[i__1].i = 0.;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+/* Error exits for QR factorization */
+
+/* ZGEQRF */
+
+ s_copy(srnamc_1.srnamt, "ZGEQRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgeqrf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
+ chkxer_("ZGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgeqrf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("ZGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgeqrf_(&c__2, &c__1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("ZGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zgeqrf_(&c__1, &c__2, a, &c__1, b, w, &c__1, &info);
+ chkxer_("ZGEQRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGEQR2 */
+
+ s_copy(srnamc_1.srnamt, "ZGEQR2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgeqr2_(&c_n1, &c__0, a, &c__1, b, w, &info);
+ chkxer_("ZGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgeqr2_(&c__0, &c_n1, a, &c__1, b, w, &info);
+ chkxer_("ZGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgeqr2_(&c__2, &c__1, a, &c__1, b, w, &info);
+ chkxer_("ZGEQR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGEQRS */
+
+ s_copy(srnamc_1.srnamt, "ZGEQRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgeqrs_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgeqrs_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgeqrs_(&c__1, &c__2, &c__0, a, &c__2, x, b, &c__2, w, &c__1, &info);
+ chkxer_("ZGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgeqrs_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgeqrs_(&c__2, &c__1, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
+ chkxer_("ZGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zgeqrs_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zgeqrs_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGEQRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZUNGQR */
+
+ s_copy(srnamc_1.srnamt, "ZUNGQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zungqr_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("ZUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zungqr_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("ZUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zungqr_(&c__1, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
+ chkxer_("ZUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zungqr_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
+ chkxer_("ZUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zungqr_(&c__1, &c__1, &c__2, a, &c__1, x, w, &c__1, &info);
+ chkxer_("ZUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zungqr_(&c__2, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
+ chkxer_("ZUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zungqr_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
+ chkxer_("ZUNGQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZUNG2R */
+
+ s_copy(srnamc_1.srnamt, "ZUNG2R", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zung2r_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
+ chkxer_("ZUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zung2r_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("ZUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zung2r_(&c__1, &c__2, &c__0, a, &c__1, x, w, &info);
+ chkxer_("ZUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zung2r_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
+ chkxer_("ZUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zung2r_(&c__2, &c__1, &c__2, a, &c__2, x, w, &info);
+ chkxer_("ZUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zung2r_(&c__2, &c__1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("ZUNG2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZUNMQR */
+
+ s_copy(srnamc_1.srnamt, "ZUNMQR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zunmqr_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zunmqr_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zunmqr_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zunmqr_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunmqr_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunmqr_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunmqr_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zunmqr_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zunmqr_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zunmqr_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zunmqr_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zunmqr_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("ZUNMQR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZUNM2R */
+
+ s_copy(srnamc_1.srnamt, "ZUNM2R", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zunm2r_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zunm2r_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zunm2r_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zunm2r_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunm2r_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunm2r_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunm2r_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zunm2r_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &info);
+ chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zunm2r_("R", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zunm2r_("L", "N", &c__2, &c__1, &c__0, a, &c__2, x, af, &c__1, w, &info);
+ chkxer_("ZUNM2R", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of ZERRQR */
+
+} /* zerrqr_ */
diff --git a/TESTING/LIN/zerrrfp.c b/TESTING/LIN/zerrrfp.c
new file mode 100644
index 0000000..ff39624
--- /dev/null
+++ b/TESTING/LIN/zerrrfp.c
@@ -0,0 +1,362 @@
+/* zerrrfp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c_n1 = -1;
+static integer c__1 = 1;
+
+/* Subroutine */ int zerrrfp_(integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,\002COMPLEX*16 RFP routines passed the tes"
+ "ts of the \002,\002error exits\002)";
+ static char fmt_9998[] = "(\002 *** RFP routines failed the tests of the"
+ " error \002,\002exits ***\002)";
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), e_wsfe(void);
+
+ /* Local variables */
+ doublecomplex a[1] /* was [1][1] */, b[1] /* was [1][1] */, beta;
+ integer info;
+ doublecomplex alpha;
+ extern /* Subroutine */ int zhfrk_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *), ztfsm_(
+ char *, char *, char *, char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), chkxer_(char *, integer *
+, integer *, logical *, logical *), zpftrf_(char *, char *
+, integer *, doublecomplex *, integer *), zpftri_(
+ char *, char *, integer *, doublecomplex *, integer *), ztftri_(char *, char *, char *, integer *, doublecomplex
+ *, integer *), zpftrs_(char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ integer *), ztfttp_(char *, char *, integer *,
+ doublecomplex *, doublecomplex *, integer *),
+ ztpttf_(char *, char *, integer *, doublecomplex *, doublecomplex
+ *, integer *), ztfttr_(char *, char *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *), ztrttf_(char *, char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), ztpttr_(
+ char *, integer *, doublecomplex *, doublecomplex *, integer *,
+ integer *), ztrttp_(char *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___6 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___7 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.2.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRRFP tests the error exits for the COMPLEX*16 driver routines */
+/* for solving linear systems of equations. */
+
+/* ZDRVRFP tests the COMPLEX*16 LAPACK RFP routines: */
+/* ZTFSM, ZTFTRI, ZHFRK, ZTFTTP, ZTFTTR, ZPFTRF, ZPFTRS, ZTPTTF, */
+/* ZTPTTR, ZTRTTF, and ZTRTTP */
+
+/* Arguments */
+/* ========= */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ infoc_1.ok = TRUE_;
+ a[0].r = 1., a[0].i = 1.;
+ b[0].r = 1., b[0].i = 1.;
+ alpha.r = 1., alpha.i = 1.;
+ beta.r = 1., beta.i = 1.;
+
+ s_copy(srnamc_1.srnamt, "ZPFTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpftrf_("/", "U", &c__0, a, &info);
+ chkxer_("ZPFTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpftrf_("N", "/", &c__0, a, &info);
+ chkxer_("ZPFTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpftrf_("N", "U", &c_n1, a, &info);
+ chkxer_("ZPFTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "ZPFTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpftrs_("/", "U", &c__0, &c__0, a, b, &c__1, &info);
+ chkxer_("ZPFTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpftrs_("N", "/", &c__0, &c__0, a, b, &c__1, &info);
+ chkxer_("ZPFTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpftrs_("N", "U", &c_n1, &c__0, a, b, &c__1, &info);
+ chkxer_("ZPFTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zpftrs_("N", "U", &c__0, &c_n1, a, b, &c__1, &info);
+ chkxer_("ZPFTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zpftrs_("N", "U", &c__0, &c__0, a, b, &c__0, &info);
+ chkxer_("ZPFTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "ZPFTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpftri_("/", "U", &c__0, a, &info);
+ chkxer_("ZPFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpftri_("N", "/", &c__0, a, &info);
+ chkxer_("ZPFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpftri_("N", "U", &c_n1, a, &info);
+ chkxer_("ZPFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "ZTFSM ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztfsm_("/", "L", "U", "C", "U", &c__0, &c__0, &alpha, a, b, &c__1);
+ chkxer_("ZTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztfsm_("N", "/", "U", "C", "U", &c__0, &c__0, &alpha, a, b, &c__1);
+ chkxer_("ZTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ztfsm_("N", "L", "/", "C", "U", &c__0, &c__0, &alpha, a, b, &c__1);
+ chkxer_("ZTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ztfsm_("N", "L", "U", "/", "U", &c__0, &c__0, &alpha, a, b, &c__1);
+ chkxer_("ZTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ztfsm_("N", "L", "U", "C", "/", &c__0, &c__0, &alpha, a, b, &c__1);
+ chkxer_("ZTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ztfsm_("N", "L", "U", "C", "U", &c_n1, &c__0, &alpha, a, b, &c__1);
+ chkxer_("ZTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ztfsm_("N", "L", "U", "C", "U", &c__0, &c_n1, &alpha, a, b, &c__1);
+ chkxer_("ZTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ ztfsm_("N", "L", "U", "C", "U", &c__0, &c__0, &alpha, a, b, &c__0);
+ chkxer_("ZTFSM ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "ZTFTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztftri_("/", "L", "N", &c__0, a, &info);
+ chkxer_("ZTFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztftri_("N", "/", "N", &c__0, a, &info);
+ chkxer_("ZTFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ztftri_("N", "L", "/", &c__0, a, &info);
+ chkxer_("ZTFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ztftri_("N", "L", "N", &c_n1, a, &info);
+ chkxer_("ZTFTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "ZTFTTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztfttr_("/", "U", &c__0, a, b, &c__1, &info);
+ chkxer_("ZTFTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztfttr_("N", "/", &c__0, a, b, &c__1, &info);
+ chkxer_("ZTFTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ztfttr_("N", "U", &c_n1, a, b, &c__1, &info);
+ chkxer_("ZTFTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ztfttr_("N", "U", &c__0, a, b, &c__0, &info);
+ chkxer_("ZTFTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "ZTRTTF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztrttf_("/", "U", &c__0, a, &c__1, b, &info);
+ chkxer_("ZTRTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztrttf_("N", "/", &c__0, a, &c__1, b, &info);
+ chkxer_("ZTRTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ztrttf_("N", "U", &c_n1, a, &c__1, b, &info);
+ chkxer_("ZTRTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrttf_("N", "U", &c__0, a, &c__0, b, &info);
+ chkxer_("ZTRTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "ZTFTTP", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztfttp_("/", "U", &c__0, a, b, &info);
+ chkxer_("ZTFTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztfttp_("N", "/", &c__0, a, b, &info);
+ chkxer_("ZTFTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ztfttp_("N", "U", &c_n1, a, b, &info);
+ chkxer_("ZTFTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "ZTPTTF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztpttf_("/", "U", &c__0, a, b, &info);
+ chkxer_("ZTPTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztpttf_("N", "/", &c__0, a, b, &info);
+ chkxer_("ZTPTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ztpttf_("N", "U", &c_n1, a, b, &info);
+ chkxer_("ZTPTTF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "ZTRTTP", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztrttp_("/", &c__0, a, &c__1, b, &info);
+ chkxer_("ZTRTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztrttp_("U", &c_n1, a, &c__1, b, &info);
+ chkxer_("ZTRTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ztrttp_("U", &c__0, a, &c__0, b, &info);
+ chkxer_("ZTRTTP", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "ZTPTTR", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztpttr_("/", &c__0, a, b, &c__1, &info);
+ chkxer_("ZTPTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztpttr_("U", &c_n1, a, b, &c__1, &info);
+ chkxer_("ZTPTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ztpttr_("U", &c__0, a, b, &c__0, &info);
+ chkxer_("ZTPTTR", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ s_copy(srnamc_1.srnamt, "ZHFRK ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhfrk_("/", "U", "N", &c__0, &c__0, &alpha, a, &c__1, &beta, b);
+ chkxer_("ZHFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhfrk_("N", "/", "N", &c__0, &c__0, &alpha, a, &c__1, &beta, b);
+ chkxer_("ZHFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zhfrk_("N", "U", "/", &c__0, &c__0, &alpha, a, &c__1, &beta, b);
+ chkxer_("ZHFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zhfrk_("N", "U", "N", &c_n1, &c__0, &alpha, a, &c__1, &beta, b);
+ chkxer_("ZHFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zhfrk_("N", "U", "N", &c__0, &c_n1, &alpha, a, &c__1, &beta, b);
+ chkxer_("ZHFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zhfrk_("N", "U", "N", &c__0, &c__0, &alpha, a, &c__0, &beta, b);
+ chkxer_("ZHFRK ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___6.ciunit = infoc_1.nout;
+ s_wsfe(&io___6);
+ e_wsfe();
+ } else {
+ io___7.ciunit = infoc_1.nout;
+ s_wsfe(&io___7);
+ e_wsfe();
+ }
+
+ return 0;
+
+/* End of ZERRRFP */
+
+} /* zerrrfp_ */
diff --git a/TESTING/LIN/zerrrq.c b/TESTING/LIN/zerrrq.c
new file mode 100644
index 0000000..f641d0e
--- /dev/null
+++ b/TESTING/LIN/zerrrq.c
@@ -0,0 +1,394 @@
+/* zerrrq.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__2 = 2;
+
+/* Subroutine */ int zerrrq_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublecomplex a[4] /* was [2][2] */, b[2];
+ integer i__, j;
+ doublecomplex w[2], x[2], af[4] /* was [2][2] */;
+ integer info;
+ extern /* Subroutine */ int zgerq2_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *), zungr2_(
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *), zunmr2_(char *,
+ char *, integer *, integer *, integer *, doublecomplex *, integer
+ *, doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *), alaesm_(char *, logical *, integer *), chkxer_(char *, integer *, integer *, logical *, logical
+ *), zgerqf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *)
+ , zgerqs_(integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *), zungrq_(integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, integer *), zunmrq_(char *, char *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRRQ tests the error exits for the COMPLEX*16 routines */
+/* that use the RQ decomposition of a general matrix. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 2; ++j) {
+ for (i__ = 1; i__ <= 2; ++i__) {
+ i__1 = i__ + (j << 1) - 3;
+ d__1 = 1. / (doublereal) (i__ + j);
+ d__2 = -1. / (doublereal) (i__ + j);
+ z__1.r = d__1, z__1.i = d__2;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = i__ + (j << 1) - 3;
+ d__1 = 1. / (doublereal) (i__ + j);
+ d__2 = -1. / (doublereal) (i__ + j);
+ z__1.r = d__1, z__1.i = d__2;
+ af[i__1].r = z__1.r, af[i__1].i = z__1.i;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0., b[i__1].i = 0.;
+ i__1 = j - 1;
+ w[i__1].r = 0., w[i__1].i = 0.;
+ i__1 = j - 1;
+ x[i__1].r = 0., x[i__1].i = 0.;
+/* L20: */
+ }
+ infoc_1.ok = TRUE_;
+
+/* Error exits for RQ factorization */
+
+/* ZGERQF */
+
+ s_copy(srnamc_1.srnamt, "ZGERQF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgerqf_(&c_n1, &c__0, a, &c__1, b, w, &c__1, &info);
+ chkxer_("ZGERQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgerqf_(&c__0, &c_n1, a, &c__1, b, w, &c__1, &info);
+ chkxer_("ZGERQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgerqf_(&c__2, &c__1, a, &c__1, b, w, &c__2, &info);
+ chkxer_("ZGERQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zgerqf_(&c__2, &c__1, a, &c__2, b, w, &c__1, &info);
+ chkxer_("ZGERQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGERQ2 */
+
+ s_copy(srnamc_1.srnamt, "ZGERQ2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgerq2_(&c_n1, &c__0, a, &c__1, b, w, &info);
+ chkxer_("ZGERQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgerq2_(&c__0, &c_n1, a, &c__1, b, w, &info);
+ chkxer_("ZGERQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgerq2_(&c__2, &c__1, a, &c__1, b, w, &info);
+ chkxer_("ZGERQ2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGERQS */
+
+ s_copy(srnamc_1.srnamt, "ZGERQS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgerqs_(&c_n1, &c__0, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgerqs_(&c__0, &c_n1, &c__0, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgerqs_(&c__2, &c__1, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgerqs_(&c__0, &c__0, &c_n1, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgerqs_(&c__2, &c__2, &c__0, a, &c__1, x, b, &c__2, w, &c__1, &info);
+ chkxer_("ZGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zgerqs_(&c__2, &c__2, &c__0, a, &c__2, x, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zgerqs_(&c__1, &c__1, &c__2, a, &c__1, x, b, &c__1, w, &c__1, &info);
+ chkxer_("ZGERQS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZUNGRQ */
+
+ s_copy(srnamc_1.srnamt, "ZUNGRQ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zungrq_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("ZUNGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zungrq_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &c__1, &info);
+ chkxer_("ZUNGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zungrq_(&c__2, &c__1, &c__0, a, &c__2, x, w, &c__2, &info);
+ chkxer_("ZUNGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zungrq_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &c__1, &info);
+ chkxer_("ZUNGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zungrq_(&c__1, &c__2, &c__2, a, &c__1, x, w, &c__1, &info);
+ chkxer_("ZUNGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zungrq_(&c__2, &c__2, &c__0, a, &c__1, x, w, &c__2, &info);
+ chkxer_("ZUNGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zungrq_(&c__2, &c__2, &c__0, a, &c__2, x, w, &c__1, &info);
+ chkxer_("ZUNGRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZUNGR2 */
+
+ s_copy(srnamc_1.srnamt, "ZUNGR2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zungr2_(&c_n1, &c__0, &c__0, a, &c__1, x, w, &info);
+ chkxer_("ZUNGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zungr2_(&c__0, &c_n1, &c__0, a, &c__1, x, w, &info);
+ chkxer_("ZUNGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zungr2_(&c__2, &c__1, &c__0, a, &c__2, x, w, &info);
+ chkxer_("ZUNGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zungr2_(&c__0, &c__0, &c_n1, a, &c__1, x, w, &info);
+ chkxer_("ZUNGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zungr2_(&c__1, &c__2, &c__2, a, &c__2, x, w, &info);
+ chkxer_("ZUNGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zungr2_(&c__2, &c__2, &c__0, a, &c__1, x, w, &info);
+ chkxer_("ZUNGR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZUNMRQ */
+
+ s_copy(srnamc_1.srnamt, "ZUNMRQ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zunmrq_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zunmrq_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zunmrq_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zunmrq_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunmrq_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunmrq_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunmrq_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zunmrq_("L", "N", &c__2, &c__1, &c__2, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("ZUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zunmrq_("R", "N", &c__1, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zunmrq_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zunmrq_("L", "N", &c__1, &c__2, &c__0, a, &c__1, x, af, &c__1, w, &c__1, &
+ info);
+ chkxer_("ZUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zunmrq_("R", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__2, w, &c__1, &
+ info);
+ chkxer_("ZUNMRQ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZUNMR2 */
+
+ s_copy(srnamc_1.srnamt, "ZUNMR2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zunmr2_("/", "N", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zunmr2_("L", "/", &c__0, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zunmr2_("L", "N", &c_n1, &c__0, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zunmr2_("L", "N", &c__0, &c_n1, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunmr2_("L", "N", &c__0, &c__0, &c_n1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunmr2_("L", "N", &c__0, &c__1, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zunmr2_("R", "N", &c__1, &c__0, &c__1, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zunmr2_("L", "N", &c__2, &c__1, &c__2, a, &c__1, x, af, &c__2, w, &info);
+ chkxer_("ZUNMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zunmr2_("R", "N", &c__1, &c__2, &c__2, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zunmr2_("L", "N", &c__2, &c__1, &c__0, a, &c__1, x, af, &c__1, w, &info);
+ chkxer_("ZUNMR2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of ZERRRQ */
+
+} /* zerrrq_ */
diff --git a/TESTING/LIN/zerrsy.c b/TESTING/LIN/zerrsy.c
new file mode 100644
index 0000000..146d711
--- /dev/null
+++ b/TESTING/LIN/zerrsy.c
@@ -0,0 +1,410 @@
+/* zerrsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__4 = 4;
+
+/* Subroutine */ int zerrsy_(char *path, integer *nunit)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublecomplex a[16] /* was [4][4] */, b[4];
+ integer i__, j;
+ doublereal r__[4];
+ doublecomplex w[8], x[4];
+ char c2[2];
+ doublereal r1[4], r2[4];
+ doublecomplex af[16] /* was [4][4] */;
+ integer ip[4], info;
+ doublereal anrm, rcond;
+ extern /* Subroutine */ int zsytf2_(char *, integer *, doublecomplex *,
+ integer *, integer *, integer *), alaesm_(char *, logical
+ *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), zspcon_(char *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublecomplex *, integer *
+), zsycon_(char *, integer *, doublecomplex *, integer *,
+ integer *, doublereal *, doublereal *, doublecomplex *, integer *), zsprfs_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *), zsptrf_(char *,
+ integer *, doublecomplex *, integer *, integer *),
+ zsptri_(char *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zsyrfs_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *
+, doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zsytrf_(char *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *, integer *), zsytri_(char *, integer *, doublecomplex *, integer *,
+ integer *, doublecomplex *, integer *), zsptrs_(char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *), zsytrs_(char *, integer *,
+ integer *, doublecomplex *, integer *, integer *, doublecomplex *,
+ integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRSY tests the error exits for the COMPLEX*16 routines */
+/* for symmetric indefinite matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ d__1 = 1. / (doublereal) (i__ + j);
+ d__2 = -1. / (doublereal) (i__ + j);
+ z__1.r = d__1, z__1.i = d__2;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = i__ + (j << 2) - 5;
+ d__1 = 1. / (doublereal) (i__ + j);
+ d__2 = -1. / (doublereal) (i__ + j);
+ z__1.r = d__1, z__1.i = d__2;
+ af[i__1].r = z__1.r, af[i__1].i = z__1.i;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0., b[i__1].i = 0.;
+ r1[j - 1] = 0.;
+ r2[j - 1] = 0.;
+ i__1 = j - 1;
+ w[i__1].r = 0., w[i__1].i = 0.;
+ i__1 = j - 1;
+ x[i__1].r = 0., x[i__1].i = 0.;
+ ip[j - 1] = j;
+/* L20: */
+ }
+ anrm = 1.;
+ infoc_1.ok = TRUE_;
+
+/* Test error exits of the routines that use the diagonal pivoting */
+/* factorization of a symmetric indefinite matrix. */
+
+ if (lsamen_(&c__2, c2, "SY")) {
+
+/* ZSYTRF */
+
+ s_copy(srnamc_1.srnamt, "ZSYTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zsytrf_("/", &c__0, a, &c__1, ip, w, &c__1, &info);
+ chkxer_("ZSYTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zsytrf_("U", &c_n1, a, &c__1, ip, w, &c__1, &info);
+ chkxer_("ZSYTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zsytrf_("U", &c__2, a, &c__1, ip, w, &c__4, &info);
+ chkxer_("ZSYTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZSYTF2 */
+
+ s_copy(srnamc_1.srnamt, "ZSYTF2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zsytf2_("/", &c__0, a, &c__1, ip, &info);
+ chkxer_("ZSYTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zsytf2_("U", &c_n1, a, &c__1, ip, &info);
+ chkxer_("ZSYTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zsytf2_("U", &c__2, a, &c__1, ip, &info);
+ chkxer_("ZSYTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZSYTRI */
+
+ s_copy(srnamc_1.srnamt, "ZSYTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zsytri_("/", &c__0, a, &c__1, ip, w, &info);
+ chkxer_("ZSYTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zsytri_("U", &c_n1, a, &c__1, ip, w, &info);
+ chkxer_("ZSYTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zsytri_("U", &c__2, a, &c__1, ip, w, &info);
+ chkxer_("ZSYTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZSYTRS */
+
+ s_copy(srnamc_1.srnamt, "ZSYTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zsytrs_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("ZSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zsytrs_("U", &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("ZSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zsytrs_("U", &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("ZSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zsytrs_("U", &c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
+ chkxer_("ZSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zsytrs_("U", &c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
+ chkxer_("ZSYTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZSYRFS */
+
+ s_copy(srnamc_1.srnamt, "ZSYRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zsyrfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zsyrfs_("U", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zsyrfs_("U", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zsyrfs_("U", &c__2, &c__1, a, &c__1, af, &c__2, ip, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("ZSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zsyrfs_("U", &c__2, &c__1, a, &c__2, af, &c__1, ip, b, &c__2, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("ZSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zsyrfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__1, x, &
+ c__2, r1, r2, w, r__, &info);
+ chkxer_("ZSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zsyrfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__2, x, &
+ c__1, r1, r2, w, r__, &info);
+ chkxer_("ZSYRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZSYCON */
+
+ s_copy(srnamc_1.srnamt, "ZSYCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zsycon_("/", &c__0, a, &c__1, ip, &anrm, &rcond, w, &info);
+ chkxer_("ZSYCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zsycon_("U", &c_n1, a, &c__1, ip, &anrm, &rcond, w, &info);
+ chkxer_("ZSYCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zsycon_("U", &c__2, a, &c__1, ip, &anrm, &rcond, w, &info);
+ chkxer_("ZSYCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ d__1 = -anrm;
+ zsycon_("U", &c__1, a, &c__1, ip, &d__1, &rcond, w, &info);
+ chkxer_("ZSYCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Test error exits of the routines that use the diagonal pivoting */
+/* factorization of a symmetric indefinite packed matrix. */
+
+ } else if (lsamen_(&c__2, c2, "SP")) {
+
+/* ZSPTRF */
+
+ s_copy(srnamc_1.srnamt, "ZSPTRF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zsptrf_("/", &c__0, a, ip, &info);
+ chkxer_("ZSPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zsptrf_("U", &c_n1, a, ip, &info);
+ chkxer_("ZSPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZSPTRI */
+
+ s_copy(srnamc_1.srnamt, "ZSPTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zsptri_("/", &c__0, a, ip, w, &info);
+ chkxer_("ZSPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zsptri_("U", &c_n1, a, ip, w, &info);
+ chkxer_("ZSPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZSPTRS */
+
+ s_copy(srnamc_1.srnamt, "ZSPTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zsptrs_("/", &c__0, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("ZSPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zsptrs_("U", &c_n1, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("ZSPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zsptrs_("U", &c__0, &c_n1, a, ip, b, &c__1, &info);
+ chkxer_("ZSPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zsptrs_("U", &c__2, &c__1, a, ip, b, &c__1, &info);
+ chkxer_("ZSPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZSPRFS */
+
+ s_copy(srnamc_1.srnamt, "ZSPRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zsprfs_("/", &c__0, &c__0, a, af, ip, b, &c__1, x, &c__1, r1, r2, w,
+ r__, &info);
+ chkxer_("ZSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zsprfs_("U", &c_n1, &c__0, a, af, ip, b, &c__1, x, &c__1, r1, r2, w,
+ r__, &info);
+ chkxer_("ZSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zsprfs_("U", &c__0, &c_n1, a, af, ip, b, &c__1, x, &c__1, r1, r2, w,
+ r__, &info);
+ chkxer_("ZSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zsprfs_("U", &c__2, &c__1, a, af, ip, b, &c__1, x, &c__2, r1, r2, w,
+ r__, &info);
+ chkxer_("ZSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zsprfs_("U", &c__2, &c__1, a, af, ip, b, &c__2, x, &c__1, r1, r2, w,
+ r__, &info);
+ chkxer_("ZSPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZSPCON */
+
+ s_copy(srnamc_1.srnamt, "ZSPCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zspcon_("/", &c__0, a, ip, &anrm, &rcond, w, &info);
+ chkxer_("ZSPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zspcon_("U", &c_n1, a, ip, &anrm, &rcond, w, &info);
+ chkxer_("ZSPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ d__1 = -anrm;
+ zspcon_("U", &c__1, a, ip, &d__1, &rcond, w, &info);
+ chkxer_("ZSPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of ZERRSY */
+
+} /* zerrsy_ */
diff --git a/TESTING/LIN/zerrtr.c b/TESTING/LIN/zerrtr.c
new file mode 100644
index 0000000..fad99db
--- /dev/null
+++ b/TESTING/LIN/zerrtr.c
@@ -0,0 +1,605 @@
+/* zerrtr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zerrtr_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublecomplex a[4] /* was [2][2] */, b[2], w[2], x[2];
+ char c2[2];
+ doublereal r1[2], r2[2], rw[2];
+ integer info;
+ doublereal scale, rcond;
+ extern /* Subroutine */ int ztrti2_(char *, char *, integer *,
+ doublecomplex *, integer *, integer *), alaesm_(
+ char *, logical *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), zlatbs_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublereal *, doublereal *, integer *), ztbcon_(char *, char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ doublereal *, integer *), ztbrfs_(char *,
+ char *, char *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), zlatps_(char *, char *, char *
+, char *, integer *, doublecomplex *, doublecomplex *, doublereal
+ *, doublereal *, integer *),
+ ztpcon_(char *, char *, char *, integer *, doublecomplex *,
+ doublereal *, doublecomplex *, doublereal *, integer *), zlatrs_(char *, char *, char *, char *, integer *
+, doublecomplex *, integer *, doublecomplex *, doublereal *,
+ doublereal *, integer *), ztrcon_(
+ char *, char *, char *, integer *, doublecomplex *, integer *,
+ doublereal *, doublecomplex *, doublereal *, integer *), ztbtrs_(char *, char *, char *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *), ztprfs_(char *,
+ char *, char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublereal *,
+ integer *), ztrrfs_(char *, char *, char *
+, integer *, integer *, doublecomplex *, integer *, doublecomplex
+ *, integer *, doublecomplex *, integer *, doublereal *,
+ doublereal *, doublecomplex *, doublereal *, integer *), ztptri_(char *, char *, integer *, doublecomplex
+ *, integer *), ztrtri_(char *, char *, integer *,
+ doublecomplex *, integer *, integer *), ztptrs_(
+ char *, char *, char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, integer *),
+ ztrtrs_(char *, char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRTR tests the error exits for the COMPLEX*16 triangular routines. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ a[0].r = 1., a[0].i = 0.;
+ a[2].r = 2., a[2].i = 0.;
+ a[3].r = 3., a[3].i = 0.;
+ a[1].r = 4., a[1].i = 0.;
+ infoc_1.ok = TRUE_;
+
+/* Test error exits for the general triangular routines. */
+
+ if (lsamen_(&c__2, c2, "TR")) {
+
+/* ZTRTRI */
+
+ s_copy(srnamc_1.srnamt, "ZTRTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztrtri_("/", "N", &c__0, a, &c__1, &info);
+ chkxer_("ZTRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztrtri_("U", "/", &c__0, a, &c__1, &info);
+ chkxer_("ZTRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ztrtri_("U", "N", &c_n1, a, &c__1, &info);
+ chkxer_("ZTRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrtri_("U", "N", &c__2, a, &c__1, &info);
+ chkxer_("ZTRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZTRTI2 */
+
+ s_copy(srnamc_1.srnamt, "ZTRTI2", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztrti2_("/", "N", &c__0, a, &c__1, &info);
+ chkxer_("ZTRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztrti2_("U", "/", &c__0, a, &c__1, &info);
+ chkxer_("ZTRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ztrti2_("U", "N", &c_n1, a, &c__1, &info);
+ chkxer_("ZTRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrti2_("U", "N", &c__2, a, &c__1, &info);
+ chkxer_("ZTRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+
+/* ZTRTRS */
+
+ s_copy(srnamc_1.srnamt, "ZTRTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztrtrs_("/", "N", "N", &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("ZTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztrtrs_("U", "/", "N", &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("ZTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ztrtrs_("U", "N", "/", &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("ZTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ztrtrs_("U", "N", "N", &c_n1, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("ZTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrtrs_("U", "N", "N", &c__0, &c_n1, a, &c__1, x, &c__1, &info);
+ chkxer_("ZTRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+
+/* ZTRRFS */
+
+ s_copy(srnamc_1.srnamt, "ZTRRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztrrfs_("/", "N", "N", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
+ r2, w, rw, &info);
+ chkxer_("ZTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztrrfs_("U", "/", "N", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
+ r2, w, rw, &info);
+ chkxer_("ZTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ztrrfs_("U", "N", "/", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
+ r2, w, rw, &info);
+ chkxer_("ZTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ztrrfs_("U", "N", "N", &c_n1, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
+ r2, w, rw, &info);
+ chkxer_("ZTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ztrrfs_("U", "N", "N", &c__0, &c_n1, a, &c__1, b, &c__1, x, &c__1, r1,
+ r2, w, rw, &info);
+ chkxer_("ZTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ztrrfs_("U", "N", "N", &c__2, &c__1, a, &c__1, b, &c__2, x, &c__2, r1,
+ r2, w, rw, &info);
+ chkxer_("ZTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ ztrrfs_("U", "N", "N", &c__2, &c__1, a, &c__2, b, &c__1, x, &c__2, r1,
+ r2, w, rw, &info);
+ chkxer_("ZTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ ztrrfs_("U", "N", "N", &c__2, &c__1, a, &c__2, b, &c__2, x, &c__1, r1,
+ r2, w, rw, &info);
+ chkxer_("ZTRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZTRCON */
+
+ s_copy(srnamc_1.srnamt, "ZTRCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztrcon_("/", "U", "N", &c__0, a, &c__1, &rcond, w, rw, &info);
+ chkxer_("ZTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztrcon_("1", "/", "N", &c__0, a, &c__1, &rcond, w, rw, &info);
+ chkxer_("ZTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ztrcon_("1", "U", "/", &c__0, a, &c__1, &rcond, w, rw, &info);
+ chkxer_("ZTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ztrcon_("1", "U", "N", &c_n1, a, &c__1, &rcond, w, rw, &info);
+ chkxer_("ZTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ztrcon_("1", "U", "N", &c__2, a, &c__1, &rcond, w, rw, &info);
+ chkxer_("ZTRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZLATRS */
+
+ s_copy(srnamc_1.srnamt, "ZLATRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zlatrs_("/", "N", "N", "N", &c__0, a, &c__1, x, &scale, rw, &info);
+ chkxer_("ZLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zlatrs_("U", "/", "N", "N", &c__0, a, &c__1, x, &scale, rw, &info);
+ chkxer_("ZLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zlatrs_("U", "N", "/", "N", &c__0, a, &c__1, x, &scale, rw, &info);
+ chkxer_("ZLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zlatrs_("U", "N", "N", "/", &c__0, a, &c__1, x, &scale, rw, &info);
+ chkxer_("ZLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zlatrs_("U", "N", "N", "N", &c_n1, a, &c__1, x, &scale, rw, &info);
+ chkxer_("ZLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zlatrs_("U", "N", "N", "N", &c__2, a, &c__1, x, &scale, rw, &info);
+ chkxer_("ZLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Test error exits for the packed triangular routines. */
+
+ } else if (lsamen_(&c__2, c2, "TP")) {
+
+/* ZTPTRI */
+
+ s_copy(srnamc_1.srnamt, "ZTPTRI", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztptri_("/", "N", &c__0, a, &info);
+ chkxer_("ZTPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztptri_("U", "/", &c__0, a, &info);
+ chkxer_("ZTPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ztptri_("U", "N", &c_n1, a, &info);
+ chkxer_("ZTPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZTPTRS */
+
+ s_copy(srnamc_1.srnamt, "ZTPTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztptrs_("/", "N", "N", &c__0, &c__0, a, x, &c__1, &info);
+ chkxer_("ZTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztptrs_("U", "/", "N", &c__0, &c__0, a, x, &c__1, &info);
+ chkxer_("ZTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ztptrs_("U", "N", "/", &c__0, &c__0, a, x, &c__1, &info);
+ chkxer_("ZTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ztptrs_("U", "N", "N", &c_n1, &c__0, a, x, &c__1, &info);
+ chkxer_("ZTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ztptrs_("U", "N", "N", &c__0, &c_n1, a, x, &c__1, &info);
+ chkxer_("ZTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ztptrs_("U", "N", "N", &c__2, &c__1, a, x, &c__1, &info);
+ chkxer_("ZTPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZTPRFS */
+
+ s_copy(srnamc_1.srnamt, "ZTPRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztprfs_("/", "N", "N", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
+ rw, &info);
+ chkxer_("ZTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztprfs_("U", "/", "N", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
+ rw, &info);
+ chkxer_("ZTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ztprfs_("U", "N", "/", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
+ rw, &info);
+ chkxer_("ZTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ztprfs_("U", "N", "N", &c_n1, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
+ rw, &info);
+ chkxer_("ZTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ztprfs_("U", "N", "N", &c__0, &c_n1, a, b, &c__1, x, &c__1, r1, r2, w,
+ rw, &info);
+ chkxer_("ZTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ztprfs_("U", "N", "N", &c__2, &c__1, a, b, &c__1, x, &c__2, r1, r2, w,
+ rw, &info);
+ chkxer_("ZTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ztprfs_("U", "N", "N", &c__2, &c__1, a, b, &c__2, x, &c__1, r1, r2, w,
+ rw, &info);
+ chkxer_("ZTPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZTPCON */
+
+ s_copy(srnamc_1.srnamt, "ZTPCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztpcon_("/", "U", "N", &c__0, a, &rcond, w, rw, &info);
+ chkxer_("ZTPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztpcon_("1", "/", "N", &c__0, a, &rcond, w, rw, &info);
+ chkxer_("ZTPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ztpcon_("1", "U", "/", &c__0, a, &rcond, w, rw, &info);
+ chkxer_("ZTPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ztpcon_("1", "U", "N", &c_n1, a, &rcond, w, rw, &info);
+ chkxer_("ZTPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZLATPS */
+
+ s_copy(srnamc_1.srnamt, "ZLATPS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zlatps_("/", "N", "N", "N", &c__0, a, x, &scale, rw, &info);
+ chkxer_("ZLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zlatps_("U", "/", "N", "N", &c__0, a, x, &scale, rw, &info);
+ chkxer_("ZLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zlatps_("U", "N", "/", "N", &c__0, a, x, &scale, rw, &info);
+ chkxer_("ZLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zlatps_("U", "N", "N", "/", &c__0, a, x, &scale, rw, &info);
+ chkxer_("ZLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zlatps_("U", "N", "N", "N", &c_n1, a, x, &scale, rw, &info);
+ chkxer_("ZLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* Test error exits for the banded triangular routines. */
+
+ } else if (lsamen_(&c__2, c2, "TB")) {
+
+/* ZTBTRS */
+
+ s_copy(srnamc_1.srnamt, "ZTBTRS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztbtrs_("/", "N", "N", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("ZTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztbtrs_("U", "/", "N", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("ZTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ztbtrs_("U", "N", "/", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("ZTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ztbtrs_("U", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("ZTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ztbtrs_("U", "N", "N", &c__0, &c_n1, &c__0, a, &c__1, x, &c__1, &info);
+ chkxer_("ZTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ztbtrs_("U", "N", "N", &c__0, &c__0, &c_n1, a, &c__1, x, &c__1, &info);
+ chkxer_("ZTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ztbtrs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__1, x, &c__2, &info);
+ chkxer_("ZTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ztbtrs_("U", "N", "N", &c__2, &c__0, &c__1, a, &c__1, x, &c__1, &info);
+ chkxer_("ZTBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZTBRFS */
+
+ s_copy(srnamc_1.srnamt, "ZTBRFS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztbrfs_("/", "N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, rw, &info);
+ chkxer_("ZTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztbrfs_("U", "/", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, rw, &info);
+ chkxer_("ZTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ztbrfs_("U", "N", "/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, rw, &info);
+ chkxer_("ZTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ztbrfs_("U", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, rw, &info);
+ chkxer_("ZTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ztbrfs_("U", "N", "N", &c__0, &c_n1, &c__0, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, rw, &info);
+ chkxer_("ZTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ ztbrfs_("U", "N", "N", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, x, &
+ c__1, r1, r2, w, rw, &info);
+ chkxer_("ZTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ ztbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__1, b, &c__2, x, &
+ c__2, r1, r2, w, rw, &info);
+ chkxer_("ZTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ ztbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__1, x, &
+ c__2, r1, r2, w, rw, &info);
+ chkxer_("ZTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ ztbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, x, &
+ c__1, r1, r2, w, rw, &info);
+ chkxer_("ZTBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZTBCON */
+
+ s_copy(srnamc_1.srnamt, "ZTBCON", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztbcon_("/", "U", "N", &c__0, &c__0, a, &c__1, &rcond, w, rw, &info);
+ chkxer_("ZTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztbcon_("1", "/", "N", &c__0, &c__0, a, &c__1, &rcond, w, rw, &info);
+ chkxer_("ZTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ ztbcon_("1", "U", "/", &c__0, &c__0, a, &c__1, &rcond, w, rw, &info);
+ chkxer_("ZTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ztbcon_("1", "U", "N", &c_n1, &c__0, a, &c__1, &rcond, w, rw, &info);
+ chkxer_("ZTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ ztbcon_("1", "U", "N", &c__0, &c_n1, a, &c__1, &rcond, w, rw, &info);
+ chkxer_("ZTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ztbcon_("1", "U", "N", &c__2, &c__1, a, &c__1, &rcond, w, rw, &info);
+ chkxer_("ZTBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZLATBS */
+
+ s_copy(srnamc_1.srnamt, "ZLATBS", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zlatbs_("/", "N", "N", "N", &c__0, &c__0, a, &c__1, x, &scale, rw, &
+ info);
+ chkxer_("ZLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zlatbs_("U", "/", "N", "N", &c__0, &c__0, a, &c__1, x, &scale, rw, &
+ info);
+ chkxer_("ZLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zlatbs_("U", "N", "/", "N", &c__0, &c__0, a, &c__1, x, &scale, rw, &
+ info);
+ chkxer_("ZLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zlatbs_("U", "N", "N", "/", &c__0, &c__0, a, &c__1, x, &scale, rw, &
+ info);
+ chkxer_("ZLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zlatbs_("U", "N", "N", "N", &c_n1, &c__0, a, &c__1, x, &scale, rw, &
+ info);
+ chkxer_("ZLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zlatbs_("U", "N", "N", "N", &c__1, &c_n1, a, &c__1, x, &scale, rw, &
+ info);
+ chkxer_("ZLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zlatbs_("U", "N", "N", "N", &c__2, &c__1, a, &c__1, x, &scale, rw, &
+ info);
+ chkxer_("ZLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of ZERRTR */
+
+} /* zerrtr_ */
diff --git a/TESTING/LIN/zerrtz.c b/TESTING/LIN/zerrtz.c
new file mode 100644
index 0000000..7616149
--- /dev/null
+++ b/TESTING/LIN/zerrtz.c
@@ -0,0 +1,165 @@
+/* zerrtz.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int zerrtz_(char *path, integer *nunit)
+{
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsle(cilist *), e_wsle(void);
+
+ /* Local variables */
+ doublecomplex a[4] /* was [2][2] */, w[2];
+ char c2[2];
+ doublecomplex tau[2];
+ integer info;
+ extern /* Subroutine */ int alaesm_(char *, logical *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), ztzrqf_(integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *), ztzrzf_(
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, integer *);
+
+ /* Fortran I/O blocks */
+ static cilist io___4 = { 0, 0, 0, 0, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRTZ tests the error exits for ZTZRQF and ZTZRZF. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ a[0].r = 1., a[0].i = -1.;
+ a[2].r = 2., a[2].i = -2.;
+ a[3].r = 3., a[3].i = -3.;
+ a[1].r = 4., a[1].i = -4.;
+ w[0].r = 0., w[0].i = 0.;
+ w[1].r = 0., w[1].i = 0.;
+ infoc_1.ok = TRUE_;
+
+/* Test error exits for the trapezoidal routines. */
+
+ io___4.ciunit = infoc_1.nout;
+ s_wsle(&io___4);
+ e_wsle();
+ if (lsamen_(&c__2, c2, "TZ")) {
+
+/* ZTZRQF */
+
+ s_copy(srnamc_1.srnamt, "ZTZRQF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztzrqf_(&c_n1, &c__0, a, &c__1, tau, &info);
+ chkxer_("ZTZRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztzrqf_(&c__1, &c__0, a, &c__1, tau, &info);
+ chkxer_("ZTZRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ztzrqf_(&c__2, &c__2, a, &c__1, tau, &info);
+ chkxer_("ZTZRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZTZRZF */
+
+ s_copy(srnamc_1.srnamt, "ZTZRZF", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ ztzrzf_(&c_n1, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("ZTZRZF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ ztzrzf_(&c__1, &c__0, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("ZTZRZF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ ztzrzf_(&c__2, &c__2, a, &c__1, tau, w, &c__1, &info);
+ chkxer_("ZTZRZF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ ztzrzf_(&c__2, &c__2, a, &c__2, tau, w, &c__1, &info);
+ chkxer_("ZTZRZF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ alaesm_(path, &infoc_1.ok, &infoc_1.nout);
+
+ return 0;
+
+/* End of ZERRTZ */
+
+} /* zerrtz_ */
diff --git a/TESTING/LIN/zerrvx.c b/TESTING/LIN/zerrvx.c
new file mode 100644
index 0000000..bd1a2ca
--- /dev/null
+++ b/TESTING/LIN/zerrvx.c
@@ -0,0 +1,1056 @@
+/* zerrvx.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ integer infot, nout;
+ logical ok, lerr;
+} infoc_;
+
+#define infoc_1 infoc_
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static integer c__1 = 1;
+static integer c__3 = 3;
+static integer c__4 = 4;
+
+/* Subroutine */ int zerrvx_(char *path, integer *nunit)
+{
+ /* Format strings */
+ static char fmt_9999[] = "(1x,a3,\002 drivers passed the tests of the er"
+ "ror exits\002)";
+ static char fmt_9998[] = "(\002 *** \002,a3,\002 drivers failed the test"
+ "s of the error \002,\002exits ***\002)";
+
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ integer s_wsle(cilist *), e_wsle(void);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
+
+ /* Local variables */
+ doublecomplex a[16] /* was [4][4] */, b[4];
+ doublereal c__[4];
+ integer i__, j;
+ doublereal r__[4];
+ doublecomplex w[8], x[4];
+ char c2[2];
+ doublereal r1[4], r2[4];
+ doublecomplex af[16] /* was [4][4] */;
+ char eq[1];
+ doublereal rf[4];
+ integer ip[4];
+ doublereal rw[4];
+ integer info;
+ doublereal rcond;
+ extern /* Subroutine */ int zgbsv_(integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, integer *, doublecomplex *,
+ integer *, integer *), zgesv_(integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *,
+ integer *), zhesv_(char *, integer *, integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *
+, integer *, integer *), zpbsv_(char *, integer *,
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *), zhpsv_(char *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *), zgtsv_(integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ integer *), zposv_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *), zppsv_(
+ char *, integer *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *), zspsv_(char *, integer *, integer *
+, doublecomplex *, integer *, doublecomplex *, integer *, integer
+ *), zptsv_(integer *, integer *, doublereal *,
+ doublecomplex *, doublecomplex *, integer *, integer *), zsysv_(
+ char *, integer *, integer *, doublecomplex *, integer *, integer
+ *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
+ *, logical *), zgbsvx_(char *, char *, integer *, integer
+ *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *, char *, doublereal *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *),
+ zgesvx_(char *, char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, char *,
+ doublereal *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *, doublecomplex *, doublereal *, integer *), zhesvx_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, doublecomplex *,
+ integer *, doublereal *, integer *), zpbsvx_(char
+ *, char *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, char *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, doublecomplex *,
+ doublereal *, integer *), zhpsvx_(char *,
+ char *, integer *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublereal *, doublereal *, doublereal *, doublecomplex *,
+ doublereal *, integer *), zgtsvx_(char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
+, doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *, doublecomplex *, doublereal *, integer *), zposvx_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, char *,
+ doublereal *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublereal *,
+ doublecomplex *, doublereal *, integer *),
+ zppsvx_(char *, char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, char *, doublereal *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *, doublecomplex *, doublereal *, integer *), zspsvx_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *, doublecomplex *, doublereal *, integer *), zptsvx_(char *, integer *, integer *, doublereal *,
+ doublecomplex *, doublereal *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *,
+ doublereal *, doublecomplex *, doublereal *, integer *),
+ zsysvx_(char *, char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublereal *, doublereal *
+, doublereal *, doublecomplex *, integer *, doublereal *, integer
+ *);
+
+ /* Fortran I/O blocks */
+ static cilist io___1 = { 0, 0, 0, 0, 0 };
+ static cilist io___20 = { 0, 0, 0, fmt_9999, 0 };
+ static cilist io___21 = { 0, 0, 0, fmt_9998, 0 };
+
+
+
+/* -- LAPACK test routine (version 3.1.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* January 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZERRVX tests the error exits for the COMPLEX*16 driver routines */
+/* for solving linear systems of equations. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name for the routines to be tested. */
+
+/* NUNIT (input) INTEGER */
+/* The unit number for output. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ infoc_1.nout = *nunit;
+ io___1.ciunit = infoc_1.nout;
+ s_wsle(&io___1);
+ e_wsle();
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set the variables to innocuous values. */
+
+ for (j = 1; j <= 4; ++j) {
+ for (i__ = 1; i__ <= 4; ++i__) {
+ i__1 = i__ + (j << 2) - 5;
+ d__1 = 1. / (doublereal) (i__ + j);
+ d__2 = -1. / (doublereal) (i__ + j);
+ z__1.r = d__1, z__1.i = d__2;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = i__ + (j << 2) - 5;
+ d__1 = 1. / (doublereal) (i__ + j);
+ d__2 = -1. / (doublereal) (i__ + j);
+ z__1.r = d__1, z__1.i = d__2;
+ af[i__1].r = z__1.r, af[i__1].i = z__1.i;
+/* L10: */
+ }
+ i__1 = j - 1;
+ b[i__1].r = 0., b[i__1].i = 0.;
+ r1[j - 1] = 0.;
+ r2[j - 1] = 0.;
+ i__1 = j - 1;
+ w[i__1].r = 0., w[i__1].i = 0.;
+ i__1 = j - 1;
+ x[i__1].r = 0., x[i__1].i = 0.;
+ c__[j - 1] = 0.;
+ r__[j - 1] = 0.;
+ ip[j - 1] = j;
+/* L20: */
+ }
+ *(unsigned char *)eq = ' ';
+ infoc_1.ok = TRUE_;
+
+ if (lsamen_(&c__2, c2, "GE")) {
+
+/* ZGESV */
+
+ s_copy(srnamc_1.srnamt, "ZGESV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgesv_(&c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("ZGESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgesv_(&c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("ZGESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgesv_(&c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
+ chkxer_("ZGESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zgesv_(&c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
+ chkxer_("ZGESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGESVX */
+
+ s_copy(srnamc_1.srnamt, "ZGESVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgesvx_("/", "N", &c__0, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgesvx_("N", "/", &c__0, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgesvx_("N", "N", &c_n1, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgesvx_("N", "N", &c__0, &c_n1, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zgesvx_("N", "N", &c__2, &c__1, a, &c__1, af, &c__2, ip, eq, r__, c__,
+ b, &c__2, x, &c__2, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zgesvx_("N", "N", &c__2, &c__1, a, &c__2, af, &c__1, ip, eq, r__, c__,
+ b, &c__2, x, &c__2, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ *(unsigned char *)eq = '/';
+ zgesvx_("F", "N", &c__0, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ *(unsigned char *)eq = 'R';
+ zgesvx_("F", "N", &c__1, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ *(unsigned char *)eq = 'C';
+ zgesvx_("F", "N", &c__1, &c__0, a, &c__1, af, &c__1, ip, eq, r__, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ zgesvx_("N", "N", &c__2, &c__1, a, &c__2, af, &c__2, ip, eq, r__, c__,
+ b, &c__1, x, &c__2, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ zgesvx_("N", "N", &c__2, &c__1, a, &c__2, af, &c__2, ip, eq, r__, c__,
+ b, &c__2, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZGESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* ZGBSV */
+
+ s_copy(srnamc_1.srnamt, "ZGBSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgbsv_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("ZGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgbsv_(&c__1, &c_n1, &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("ZGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgbsv_(&c__1, &c__0, &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("ZGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgbsv_(&c__0, &c__0, &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("ZGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zgbsv_(&c__1, &c__1, &c__1, &c__0, a, &c__3, ip, b, &c__1, &info);
+ chkxer_("ZGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zgbsv_(&c__2, &c__0, &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
+ chkxer_("ZGBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGBSVX */
+
+ s_copy(srnamc_1.srnamt, "ZGBSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgbsvx_("/", "N", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("ZGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgbsvx_("N", "/", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("ZGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgbsvx_("N", "N", &c_n1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("ZGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgbsvx_("N", "N", &c__1, &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("ZGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zgbsvx_("N", "N", &c__1, &c__0, &c_n1, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("ZGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zgbsvx_("N", "N", &c__0, &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("ZGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zgbsvx_("N", "N", &c__1, &c__1, &c__1, &c__0, a, &c__2, af, &c__4, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("ZGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zgbsvx_("N", "N", &c__1, &c__1, &c__1, &c__0, a, &c__3, af, &c__3, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("ZGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ *(unsigned char *)eq = '/';
+ zgbsvx_("F", "N", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("ZGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ *(unsigned char *)eq = 'R';
+ zgbsvx_("F", "N", &c__1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("ZGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ *(unsigned char *)eq = 'C';
+ zgbsvx_("F", "N", &c__1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("ZGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ zgbsvx_("N", "N", &c__2, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__1, x, &c__2, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("ZGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ zgbsvx_("N", "N", &c__2, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip,
+ eq, r__, c__, b, &c__2, x, &c__1, &rcond, r1, r2, w, rw, &
+ info);
+ chkxer_("ZGBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "GT")) {
+
+/* ZGTSV */
+
+ s_copy(srnamc_1.srnamt, "ZGTSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgtsv_(&c_n1, &c__0, a, &a[4], &a[8], b, &c__1, &info);
+ chkxer_("ZGTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgtsv_(&c__0, &c_n1, a, &a[4], &a[8], b, &c__1, &info);
+ chkxer_("ZGTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zgtsv_(&c__2, &c__0, a, &a[4], &a[8], b, &c__1, &info);
+ chkxer_("ZGTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZGTSVX */
+
+ s_copy(srnamc_1.srnamt, "ZGTSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zgtsvx_("/", "N", &c__0, &c__0, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zgtsvx_("N", "/", &c__0, &c__0, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zgtsvx_("N", "N", &c_n1, &c__0, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zgtsvx_("N", "N", &c__0, &c_n1, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ zgtsvx_("N", "N", &c__2, &c__0, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__1, x, &c__2, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 16;
+ zgtsvx_("N", "N", &c__2, &c__0, a, &a[4], &a[8], af, &af[4], &af[8], &
+ af[12], ip, b, &c__2, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZGTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PO")) {
+
+/* ZPOSV */
+
+ s_copy(srnamc_1.srnamt, "ZPOSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zposv_("/", &c__0, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("ZPOSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zposv_("U", &c_n1, &c__0, a, &c__1, b, &c__1, &info);
+ chkxer_("ZPOSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zposv_("U", &c__0, &c_n1, a, &c__1, b, &c__1, &info);
+ chkxer_("ZPOSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zposv_("U", &c__2, &c__0, a, &c__1, b, &c__2, &info);
+ chkxer_("ZPOSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zposv_("U", &c__2, &c__0, a, &c__2, b, &c__1, &info);
+ chkxer_("ZPOSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPOSVX */
+
+ s_copy(srnamc_1.srnamt, "ZPOSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zposvx_("/", "U", &c__0, &c__0, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zposvx_("N", "/", &c__0, &c__0, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zposvx_("N", "U", &c_n1, &c__0, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zposvx_("N", "U", &c__0, &c_n1, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zposvx_("N", "U", &c__2, &c__0, a, &c__1, af, &c__2, eq, c__, b, &
+ c__2, x, &c__2, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zposvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__1, eq, c__, b, &
+ c__2, x, &c__2, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ *(unsigned char *)eq = '/';
+ zposvx_("F", "U", &c__0, &c__0, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ *(unsigned char *)eq = 'Y';
+ zposvx_("F", "U", &c__1, &c__0, a, &c__1, af, &c__1, eq, c__, b, &
+ c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zposvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, eq, c__, b, &
+ c__1, x, &c__2, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 14;
+ zposvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, eq, c__, b, &
+ c__2, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPOSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PP")) {
+
+/* ZPPSV */
+
+ s_copy(srnamc_1.srnamt, "ZPPSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zppsv_("/", &c__0, &c__0, a, b, &c__1, &info);
+ chkxer_("ZPPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zppsv_("U", &c_n1, &c__0, a, b, &c__1, &info);
+ chkxer_("ZPPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zppsv_("U", &c__0, &c_n1, a, b, &c__1, &info);
+ chkxer_("ZPPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zppsv_("U", &c__2, &c__0, a, b, &c__1, &info);
+ chkxer_("ZPPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPPSVX */
+
+ s_copy(srnamc_1.srnamt, "ZPPSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zppsvx_("/", "U", &c__0, &c__0, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zppsvx_("N", "/", &c__0, &c__0, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zppsvx_("N", "U", &c_n1, &c__0, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zppsvx_("N", "U", &c__0, &c_n1, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ *(unsigned char *)eq = '/';
+ zppsvx_("F", "U", &c__0, &c__0, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ *(unsigned char *)eq = 'Y';
+ zppsvx_("F", "U", &c__1, &c__0, a, af, eq, c__, b, &c__1, x, &c__1, &
+ rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ zppsvx_("N", "U", &c__2, &c__0, a, af, eq, c__, b, &c__1, x, &c__2, &
+ rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 12;
+ zppsvx_("N", "U", &c__2, &c__0, a, af, eq, c__, b, &c__2, x, &c__1, &
+ rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* ZPBSV */
+
+ s_copy(srnamc_1.srnamt, "ZPBSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpbsv_("/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &info)
+ ;
+ chkxer_("ZPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpbsv_("U", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, &info)
+ ;
+ chkxer_("ZPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpbsv_("U", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, &info)
+ ;
+ chkxer_("ZPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zpbsv_("U", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, &info)
+ ;
+ chkxer_("ZPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zpbsv_("U", &c__1, &c__1, &c__0, a, &c__1, b, &c__2, &info)
+ ;
+ chkxer_("ZPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zpbsv_("U", &c__2, &c__0, &c__0, a, &c__1, b, &c__1, &info)
+ ;
+ chkxer_("ZPBSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPBSVX */
+
+ s_copy(srnamc_1.srnamt, "ZPBSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zpbsvx_("/", "U", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zpbsvx_("N", "/", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zpbsvx_("N", "U", &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zpbsvx_("N", "U", &c__1, &c_n1, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zpbsvx_("N", "U", &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zpbsvx_("N", "U", &c__1, &c__1, &c__0, a, &c__1, af, &c__2, eq, c__,
+ b, &c__2, x, &c__2, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zpbsvx_("N", "U", &c__1, &c__1, &c__0, a, &c__2, af, &c__1, eq, c__,
+ b, &c__2, x, &c__2, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 10;
+ *(unsigned char *)eq = '/';
+ zpbsvx_("F", "U", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ *(unsigned char *)eq = 'Y';
+ zpbsvx_("F", "U", &c__1, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ zpbsvx_("N", "U", &c__2, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__1, x, &c__2, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 15;
+ zpbsvx_("N", "U", &c__2, &c__0, &c__0, a, &c__1, af, &c__1, eq, c__,
+ b, &c__2, x, &c__1, &rcond, r1, r2, w, rw, &info);
+ chkxer_("ZPBSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "PT")) {
+
+/* ZPTSV */
+
+ s_copy(srnamc_1.srnamt, "ZPTSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zptsv_(&c_n1, &c__0, r__, a, b, &c__1, &info);
+ chkxer_("ZPTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zptsv_(&c__0, &c_n1, r__, a, b, &c__1, &info);
+ chkxer_("ZPTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zptsv_(&c__2, &c__0, r__, a, b, &c__1, &info);
+ chkxer_("ZPTSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZPTSVX */
+
+ s_copy(srnamc_1.srnamt, "ZPTSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zptsvx_("/", &c__0, &c__0, r__, a, rf, af, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("ZPTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zptsvx_("N", &c_n1, &c__0, r__, a, rf, af, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("ZPTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zptsvx_("N", &c__0, &c_n1, r__, a, rf, af, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("ZPTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zptsvx_("N", &c__2, &c__0, r__, a, rf, af, b, &c__1, x, &c__2, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("ZPTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zptsvx_("N", &c__2, &c__0, r__, a, rf, af, b, &c__2, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("ZPTSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "HE")) {
+
+/* ZHESV */
+
+ s_copy(srnamc_1.srnamt, "ZHESV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhesv_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("ZHESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhesv_("U", &c_n1, &c__0, a, &c__1, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("ZHESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zhesv_("U", &c__0, &c_n1, a, &c__1, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("ZHESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 5;
+ zhesv_("U", &c__2, &c__0, a, &c__1, ip, b, &c__2, w, &c__1, &info);
+ chkxer_("ZHESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zhesv_("U", &c__2, &c__0, a, &c__2, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("ZHESV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZHESVX */
+
+ s_copy(srnamc_1.srnamt, "ZHESVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhesvx_("/", "U", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, rw, &info);
+ chkxer_("ZHESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhesvx_("N", "/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, rw, &info);
+ chkxer_("ZHESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zhesvx_("N", "U", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, rw, &info);
+ chkxer_("ZHESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zhesvx_("N", "U", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, rw, &info);
+ chkxer_("ZHESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zhesvx_("N", "U", &c__2, &c__0, a, &c__1, af, &c__2, ip, b, &c__2, x,
+ &c__2, &rcond, r1, r2, w, &c__4, rw, &info);
+ chkxer_("ZHESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zhesvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__1, ip, b, &c__2, x,
+ &c__2, &rcond, r1, r2, w, &c__4, rw, &info);
+ chkxer_("ZHESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zhesvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, ip, b, &c__1, x,
+ &c__2, &rcond, r1, r2, w, &c__4, rw, &info);
+ chkxer_("ZHESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ zhesvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, ip, b, &c__2, x,
+ &c__1, &rcond, r1, r2, w, &c__4, rw, &info);
+ chkxer_("ZHESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ zhesvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, ip, b, &c__2, x,
+ &c__2, &rcond, r1, r2, w, &c__3, rw, &info);
+ chkxer_("ZHESVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "HP")) {
+
+/* ZHPSV */
+
+ s_copy(srnamc_1.srnamt, "ZHPSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhpsv_("/", &c__0, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("ZHPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhpsv_("U", &c_n1, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("ZHPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zhpsv_("U", &c__0, &c_n1, a, ip, b, &c__1, &info);
+ chkxer_("ZHPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zhpsv_("U", &c__2, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("ZHPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZHPSVX */
+
+ s_copy(srnamc_1.srnamt, "ZHPSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zhpsvx_("/", "U", &c__0, &c__0, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("ZHPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zhpsvx_("N", "/", &c__0, &c__0, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("ZHPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zhpsvx_("N", "U", &c_n1, &c__0, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("ZHPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zhpsvx_("N", "U", &c__0, &c_n1, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("ZHPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zhpsvx_("N", "U", &c__2, &c__0, a, af, ip, b, &c__1, x, &c__2, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("ZHPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zhpsvx_("N", "U", &c__2, &c__0, a, af, ip, b, &c__2, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("ZHPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "SY")) {
+
+/* ZSYSV */
+
+ s_copy(srnamc_1.srnamt, "ZSYSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zsysv_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("ZSYSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zsysv_("U", &c_n1, &c__0, a, &c__1, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("ZSYSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zsysv_("U", &c__0, &c_n1, a, &c__1, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("ZSYSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zsysv_("U", &c__2, &c__0, a, &c__2, ip, b, &c__1, w, &c__1, &info);
+ chkxer_("ZSYSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZSYSVX */
+
+ s_copy(srnamc_1.srnamt, "ZSYSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zsysvx_("/", "U", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, rw, &info);
+ chkxer_("ZSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zsysvx_("N", "/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, rw, &info);
+ chkxer_("ZSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zsysvx_("N", "U", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, rw, &info);
+ chkxer_("ZSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zsysvx_("N", "U", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x,
+ &c__1, &rcond, r1, r2, w, &c__1, rw, &info);
+ chkxer_("ZSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 6;
+ zsysvx_("N", "U", &c__2, &c__0, a, &c__1, af, &c__2, ip, b, &c__2, x,
+ &c__2, &rcond, r1, r2, w, &c__4, rw, &info);
+ chkxer_("ZSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 8;
+ zsysvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__1, ip, b, &c__2, x,
+ &c__2, &rcond, r1, r2, w, &c__4, rw, &info);
+ chkxer_("ZSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zsysvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, ip, b, &c__1, x,
+ &c__2, &rcond, r1, r2, w, &c__4, rw, &info);
+ chkxer_("ZSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 13;
+ zsysvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, ip, b, &c__2, x,
+ &c__1, &rcond, r1, r2, w, &c__4, rw, &info);
+ chkxer_("ZSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 18;
+ zsysvx_("N", "U", &c__2, &c__0, a, &c__2, af, &c__2, ip, b, &c__2, x,
+ &c__2, &rcond, r1, r2, w, &c__3, rw, &info);
+ chkxer_("ZSYSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+ } else if (lsamen_(&c__2, c2, "SP")) {
+
+/* ZSPSV */
+
+ s_copy(srnamc_1.srnamt, "ZSPSV ", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zspsv_("/", &c__0, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("ZSPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zspsv_("U", &c_n1, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("ZSPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zspsv_("U", &c__0, &c_n1, a, ip, b, &c__1, &info);
+ chkxer_("ZSPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 7;
+ zspsv_("U", &c__2, &c__0, a, ip, b, &c__1, &info);
+ chkxer_("ZSPSV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+
+/* ZSPSVX */
+
+ s_copy(srnamc_1.srnamt, "ZSPSVX", (ftnlen)32, (ftnlen)6);
+ infoc_1.infot = 1;
+ zspsvx_("/", "U", &c__0, &c__0, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("ZSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 2;
+ zspsvx_("N", "/", &c__0, &c__0, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("ZSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 3;
+ zspsvx_("N", "U", &c_n1, &c__0, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("ZSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 4;
+ zspsvx_("N", "U", &c__0, &c_n1, a, af, ip, b, &c__1, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("ZSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 9;
+ zspsvx_("N", "U", &c__2, &c__0, a, af, ip, b, &c__1, x, &c__2, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("ZSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ infoc_1.infot = 11;
+ zspsvx_("N", "U", &c__2, &c__0, a, af, ip, b, &c__2, x, &c__1, &rcond,
+ r1, r2, w, rw, &info);
+ chkxer_("ZSPSVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
+ infoc_1.ok);
+ }
+
+/* Print a summary line. */
+
+ if (infoc_1.ok) {
+ io___20.ciunit = infoc_1.nout;
+ s_wsfe(&io___20);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ } else {
+ io___21.ciunit = infoc_1.nout;
+ s_wsfe(&io___21);
+ do_fio(&c__1, path, (ftnlen)3);
+ e_wsfe();
+ }
+
+
+ return 0;
+
+/* End of ZERRVX */
+
+} /* zerrvx_ */
diff --git a/TESTING/LIN/zgbt01.c b/TESTING/LIN/zgbt01.c
new file mode 100644
index 0000000..50376f0
--- /dev/null
+++ b/TESTING/LIN/zgbt01.c
@@ -0,0 +1,247 @@
+/* zgbt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublecomplex c_b12 = {-1.,-0.};
+
+/* Subroutine */ int zgbt01_(integer *m, integer *n, integer *kl, integer *ku,
+ doublecomplex *a, integer *lda, doublecomplex *afac, integer *ldafac,
+ integer *ipiv, doublecomplex *work, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer i__, j;
+ doublecomplex t;
+ integer i1, i2, kd, il, jl, ip, ju, iw, jua;
+ doublereal eps;
+ integer lenj;
+ doublereal anorm;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), dzasum_(integer *,
+ doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGBT01 reconstructs a band matrix A from its L*U factorization and */
+/* computes the residual: */
+/* norm(L*U - A) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* The expression L*U - A is computed one column at a time, so A and */
+/* AFAC are not modified. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* The original matrix A in band storage, stored in rows 1 to */
+/* KL+KU+1. */
+
+/* LDA (input) INTEGER. */
+/* The leading dimension of the array A. LDA >= max(1,KL+KU+1). */
+
+/* AFAC (input) COMPLEX*16 array, dimension (LDAFAC,N) */
+/* The factored form of the matrix A. AFAC contains the banded */
+/* factors L and U from the L*U factorization, as computed by */
+/* ZGBTRF. U is stored as an upper triangular band matrix with */
+/* KL+KU superdiagonals in rows 1 to KL+KU+1, and the */
+/* multipliers used during the factorization are stored in rows */
+/* KL+KU+2 to 2*KL+KU+1. See ZGBTRF for further details. */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. */
+/* LDAFAC >= max(1,2*KL*KU+1). */
+
+/* IPIV (input) INTEGER array, dimension (min(M,N)) */
+/* The pivot indices from ZGBTRF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*KL+KU+1) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* norm(L*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if M = 0 or N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ --ipiv;
+ --work;
+
+ /* Function Body */
+ *resid = 0.;
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+/* Determine EPS and the norm of A. */
+
+ eps = dlamch_("Epsilon");
+ kd = *ku + 1;
+ anorm = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = kd + 1 - j;
+ i1 = max(i__2,1);
+/* Computing MIN */
+ i__2 = kd + *m - j, i__3 = *kl + kd;
+ i2 = min(i__2,i__3);
+ if (i2 >= i1) {
+/* Computing MAX */
+ i__2 = i2 - i1 + 1;
+ d__1 = anorm, d__2 = dzasum_(&i__2, &a[i1 + j * a_dim1], &c__1);
+ anorm = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+/* Compute one column at a time of L*U - A. */
+
+ kd = *kl + *ku + 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Copy the J-th column of U to WORK. */
+
+/* Computing MIN */
+ i__2 = *kl + *ku, i__3 = j - 1;
+ ju = min(i__2,i__3);
+/* Computing MIN */
+ i__2 = *kl, i__3 = *m - j;
+ jl = min(i__2,i__3);
+ lenj = min(*m,j) - j + ju + 1;
+ if (lenj > 0) {
+ zcopy_(&lenj, &afac[kd - ju + j * afac_dim1], &c__1, &work[1], &
+ c__1);
+ i__2 = ju + jl + 1;
+ for (i__ = lenj + 1; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ work[i__3].r = 0., work[i__3].i = 0.;
+/* L20: */
+ }
+
+/* Multiply by the unit lower triangular matrix L. Note that L */
+/* is stored as a product of transformations and permutations. */
+
+/* Computing MIN */
+ i__2 = *m - 1;
+ i__3 = j - ju;
+ for (i__ = min(i__2,j); i__ >= i__3; --i__) {
+/* Computing MIN */
+ i__2 = *kl, i__4 = *m - i__;
+ il = min(i__2,i__4);
+ if (il > 0) {
+ iw = i__ - j + ju + 1;
+ i__2 = iw;
+ t.r = work[i__2].r, t.i = work[i__2].i;
+ zaxpy_(&il, &t, &afac[kd + 1 + i__ * afac_dim1], &c__1, &
+ work[iw + 1], &c__1);
+ ip = ipiv[i__];
+ if (i__ != ip) {
+ ip = ip - j + ju + 1;
+ i__2 = iw;
+ i__4 = ip;
+ work[i__2].r = work[i__4].r, work[i__2].i = work[i__4]
+ .i;
+ i__2 = ip;
+ work[i__2].r = t.r, work[i__2].i = t.i;
+ }
+ }
+/* L30: */
+ }
+
+/* Subtract the corresponding column of A. */
+
+ jua = min(ju,*ku);
+ if (jua + jl + 1 > 0) {
+ i__3 = jua + jl + 1;
+ zaxpy_(&i__3, &c_b12, &a[*ku + 1 - jua + j * a_dim1], &c__1, &
+ work[ju + 1 - jua], &c__1);
+ }
+
+/* Compute the 1-norm of the column. */
+
+/* Computing MAX */
+ i__3 = ju + jl + 1;
+ d__1 = *resid, d__2 = dzasum_(&i__3, &work[1], &c__1);
+ *resid = max(d__1,d__2);
+ }
+/* L40: */
+ }
+
+/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
+
+ if (anorm <= 0.) {
+ if (*resid != 0.) {
+ *resid = 1. / eps;
+ }
+ } else {
+ *resid = *resid / (doublereal) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of ZGBT01 */
+
+} /* zgbt01_ */
diff --git a/TESTING/LIN/zgbt02.c b/TESTING/LIN/zgbt02.c
new file mode 100644
index 0000000..3ef82bc
--- /dev/null
+++ b/TESTING/LIN/zgbt02.c
@@ -0,0 +1,210 @@
+/* zgbt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zgbt02_(char *trans, integer *m, integer *n, integer *kl,
+ integer *ku, integer *nrhs, doublecomplex *a, integer *lda,
+ doublecomplex *x, integer *ldx, doublecomplex *b, integer *ldb,
+ doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2,
+ i__3;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer j, i1, i2, n1, kd;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ doublereal anorm, bnorm;
+ extern /* Subroutine */ int zgbmv_(char *, integer *, integer *, integer *
+, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ doublereal xnorm;
+ extern doublereal dlamch_(char *), dzasum_(integer *,
+ doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGBT02 computes the residual for a solution of a banded system of */
+/* equations A*x = b or A'*x = b: */
+/* RESID = norm( B - A*X ) / ( norm(A) * norm(X) * EPS). */
+/* where EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A *x = b */
+/* = 'T': A'*x = b, where A' is the transpose of A */
+/* = 'C': A'*x = b, where A' is the transpose of A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original matrix A in band storage, stored in rows 1 to */
+/* KL+KU+1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,KL+KU+1). */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. IF TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if N = 0 pr NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ kd = *ku + 1;
+ anorm = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = kd + 1 - j;
+ i1 = max(i__2,1);
+/* Computing MIN */
+ i__2 = kd + *m - j, i__3 = *kl + kd;
+ i2 = min(i__2,i__3);
+/* Computing MAX */
+ i__2 = i2 - i1 + 1;
+ d__1 = anorm, d__2 = dzasum_(&i__2, &a[i1 + j * a_dim1], &c__1);
+ anorm = max(d__1,d__2);
+/* L10: */
+ }
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+ if (lsame_(trans, "T") || lsame_(trans, "C")) {
+ n1 = *n;
+ } else {
+ n1 = *m;
+ }
+
+/* Compute B - A*X (or B - A'*X ) */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ z__1.r = -1., z__1.i = -0.;
+ zgbmv_(trans, m, n, kl, ku, &z__1, &a[a_offset], lda, &x[j * x_dim1 +
+ 1], &c__1, &c_b1, &b[j * b_dim1 + 1], &c__1);
+/* L20: */
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = dzasum_(&n1, &b[j * b_dim1 + 1], &c__1);
+ xnorm = dzasum_(&n1, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L30: */
+ }
+
+ return 0;
+
+/* End of ZGBT02 */
+
+} /* zgbt02_ */
diff --git a/TESTING/LIN/zgbt05.c b/TESTING/LIN/zgbt05.c
new file mode 100644
index 0000000..967e70e
--- /dev/null
+++ b/TESTING/LIN/zgbt05.c
@@ -0,0 +1,307 @@
+/* zgbt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zgbt05_(char *trans, integer *n, integer *kl, integer *
+ ku, integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *b,
+ integer *ldb, doublecomplex *x, integer *ldx, doublecomplex *xact,
+ integer *ldxact, doublereal *ferr, doublereal *berr, doublereal *
+ reslts)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, nz;
+ doublereal eps, tmp, diff, axbi;
+ integer imax;
+ doublereal unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ doublereal xnorm;
+ extern doublereal dlamch_(char *);
+ doublereal errbnd;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGBT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations op(A)*X = B, where A is a */
+/* general band matrix of order n with kl subdiagonals and ku */
+/* superdiagonals and op(A) = A or A**T, depending on TRANS. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+/* and NZ = max. number of nonzeros in any row of A, plus 1 */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of subdiagonals within the band of A. KL >= 0. */
+
+/* KU (input) INTEGER */
+/* The number of superdiagonals within the band of A. KU >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
+/* The original band matrix A, stored in rows 1 to KL+KU+1. */
+/* The j-th column of A is stored in the j-th column of the */
+/* array AB as follows: */
+/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KL+KU+1. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.;
+ reslts[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ notran = lsame_(trans, "N");
+/* Computing MIN */
+ i__1 = *kl + *ku + 2, i__2 = *n + 1;
+ nz = min(i__1,i__2);
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = izamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__2 = imax + j * x_dim1;
+ d__3 = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[imax + j *
+ x_dim1]), abs(d__2));
+ xnorm = max(d__3,unfl);
+ diff = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * xact_dim1;
+ z__2.r = x[i__3].r - xact[i__4].r, z__2.i = x[i__3].i - xact[i__4]
+ .i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+/* Computing MAX */
+ d__3 = diff, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
+ z__1), abs(d__2));
+ diff = max(d__3,d__4);
+/* L10: */
+ }
+
+ if (xnorm > 1.) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1. / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
+ errbnd = max(d__1,d__2);
+ } else {
+ errbnd = 1. / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ tmp = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__ + k *
+ b_dim1]), abs(d__2));
+ if (notran) {
+/* Computing MAX */
+ i__3 = i__ - *kl;
+/* Computing MIN */
+ i__5 = i__ + *ku;
+ i__4 = min(i__5,*n);
+ for (j = max(i__3,1); j <= i__4; ++j) {
+ i__3 = *ku + 1 + i__ - j + j * ab_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 = d_imag(&
+ ab[*ku + 1 + i__ - j + j * ab_dim1]), abs(d__2)))
+ * ((d__3 = x[i__5].r, abs(d__3)) + (d__4 = d_imag(
+ &x[j + k * x_dim1]), abs(d__4)));
+/* L40: */
+ }
+ } else {
+/* Computing MAX */
+ i__4 = i__ - *ku;
+/* Computing MIN */
+ i__5 = i__ + *kl;
+ i__3 = min(i__5,*n);
+ for (j = max(i__4,1); j <= i__3; ++j) {
+ i__4 = *ku + 1 + j - i__ + i__ * ab_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = ab[i__4].r, abs(d__1)) + (d__2 = d_imag(&
+ ab[*ku + 1 + j - i__ + i__ * ab_dim1]), abs(d__2))
+ ) * ((d__3 = x[i__5].r, abs(d__3)) + (d__4 =
+ d_imag(&x[j + k * x_dim1]), abs(d__4)));
+/* L50: */
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = min(axbi,tmp);
+ }
+/* L60: */
+ }
+/* Computing MAX */
+ d__1 = axbi, d__2 = nz * unfl;
+ tmp = berr[k] / (nz * eps + nz * unfl / max(d__1,d__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = max(reslts[2],tmp);
+ }
+/* L70: */
+ }
+
+ return 0;
+
+/* End of ZGBT05 */
+
+} /* zgbt05_ */
diff --git a/TESTING/LIN/zgelqs.c b/TESTING/LIN/zgelqs.c
new file mode 100644
index 0000000..6aef036
--- /dev/null
+++ b/TESTING/LIN/zgelqs.c
@@ -0,0 +1,167 @@
+/* zgelqs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+
+/* Subroutine */ int zgelqs_(integer *m, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *b,
+ integer *ldb, doublecomplex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ xerbla_(char *, integer *), zlaset_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *), zunmlq_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Compute a minimum-norm solution */
+/* min || A*X - B || */
+/* using the LQ factorization */
+/* A = L*Q */
+/* computed by ZGELQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= M >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* Details of the LQ factorization of the original matrix A as */
+/* returned by ZGELQF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* TAU (input) COMPLEX*16 array, dimension (M) */
+/* Details of the orthogonal matrix Q. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the m-by-nrhs right hand side matrix B. */
+/* On exit, the n-by-nrhs solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= N. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK must be at least NRHS, */
+/* and should be at least NRHS*NB, where NB is the block size */
+/* for this environment. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *m > *n) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*lwork < 1 || *lwork < *nrhs && *m > 0 && *n > 0) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGELQS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0 || *m == 0) {
+ return 0;
+ }
+
+/* Solve L*X = B(1:m,:) */
+
+ ztrsm_("Left", "Lower", "No transpose", "Non-unit", m, nrhs, &c_b2, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+/* Set B(m+1:n,:) to zero */
+
+ if (*m < *n) {
+ i__1 = *n - *m;
+ zlaset_("Full", &i__1, nrhs, &c_b1, &c_b1, &b[*m + 1 + b_dim1], ldb);
+ }
+
+/* B := Q' * B */
+
+ zunmlq_("Left", "Conjugate transpose", n, nrhs, m, &a[a_offset], lda, &
+ tau[1], &b[b_offset], ldb, &work[1], lwork, info);
+
+ return 0;
+
+/* End of ZGELQS */
+
+} /* zgelqs_ */
diff --git a/TESTING/LIN/zgennd.c b/TESTING/LIN/zgennd.c
new file mode 100644
index 0000000..8a0eee3
--- /dev/null
+++ b/TESTING/LIN/zgennd.c
@@ -0,0 +1,86 @@
+/* zgennd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+logical zgennd_(integer *m, integer *n, doublecomplex *a, integer *lda)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ logical ret_val;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, k;
+ doublecomplex aii;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* February 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGENND tests that its argument has a real, non-negative diagonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows in A. */
+
+/* N (input) INTEGER */
+/* The number of columns in A. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA, N) */
+/* The matrix. */
+
+/* LDA (input) INTEGER */
+/* Leading dimension of A. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsics .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+
+ /* Function Body */
+ k = min(*m,*n);
+ i__1 = k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ aii.r = a[i__2].r, aii.i = a[i__2].i;
+ if (aii.r < 0.f || d_imag(&aii) != 0.f) {
+ ret_val = FALSE_;
+ return ret_val;
+ }
+ }
+ ret_val = TRUE_;
+ return ret_val;
+} /* zgennd_ */
diff --git a/TESTING/LIN/zgeqls.c b/TESTING/LIN/zgeqls.c
new file mode 100644
index 0000000..2505d5c
--- /dev/null
+++ b/TESTING/LIN/zgeqls.c
@@ -0,0 +1,159 @@
+/* zgeqls.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+
+/* Subroutine */ int zgeqls_(integer *m, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *b,
+ integer *ldb, doublecomplex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ xerbla_(char *, integer *), zunmql_(char *, char *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Solve the least squares problem */
+/* min || A*X - B || */
+/* using the QL factorization */
+/* A = Q*L */
+/* computed by ZGEQLF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. M >= N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* Details of the QL factorization of the original matrix A as */
+/* returned by ZGEQLF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* TAU (input) COMPLEX*16 array, dimension (N) */
+/* Details of the orthogonal matrix Q. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the m-by-nrhs right hand side matrix B. */
+/* On exit, the n-by-nrhs solution matrix X, stored in rows */
+/* m-n+1:m. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= M. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK must be at least NRHS, */
+/* and should be at least NRHS*NB, where NB is the block size */
+/* for this environment. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*m)) {
+ *info = -8;
+ } else if (*lwork < 1 || *lwork < *nrhs && *m > 0 && *n > 0) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGEQLS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0 || *m == 0) {
+ return 0;
+ }
+
+/* B := Q' * B */
+
+ zunmql_("Left", "Conjugate transpose", m, nrhs, n, &a[a_offset], lda, &
+ tau[1], &b[b_offset], ldb, &work[1], lwork, info);
+
+/* Solve L*X = B(m-n+1:m,:) */
+
+ ztrsm_("Left", "Lower", "No transpose", "Non-unit", n, nrhs, &c_b1, &a[*m
+ - *n + 1 + a_dim1], lda, &b[*m - *n + 1 + b_dim1], ldb);
+
+ return 0;
+
+/* End of ZGEQLS */
+
+} /* zgeqls_ */
diff --git a/TESTING/LIN/zgeqrs.c b/TESTING/LIN/zgeqrs.c
new file mode 100644
index 0000000..f6d7521
--- /dev/null
+++ b/TESTING/LIN/zgeqrs.c
@@ -0,0 +1,158 @@
+/* zgeqrs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+
+/* Subroutine */ int zgeqrs_(integer *m, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *b,
+ integer *ldb, doublecomplex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ xerbla_(char *, integer *), zunmqr_(char *, char *,
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Solve the least squares problem */
+/* min || A*X - B || */
+/* using the QR factorization */
+/* A = Q*R */
+/* computed by ZGEQRF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. M >= N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* Details of the QR factorization of the original matrix A as */
+/* returned by ZGEQRF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* TAU (input) COMPLEX*16 array, dimension (N) */
+/* Details of the orthogonal matrix Q. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the m-by-nrhs right hand side matrix B. */
+/* On exit, the n-by-nrhs solution matrix X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= M. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK must be at least NRHS, */
+/* and should be at least NRHS*NB, where NB is the block size */
+/* for this environment. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *n > *m) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*m)) {
+ *info = -8;
+ } else if (*lwork < 1 || *lwork < *nrhs && *m > 0 && *n > 0) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGEQRS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0 || *m == 0) {
+ return 0;
+ }
+
+/* B := Q' * B */
+
+ zunmqr_("Left", "Conjugate transpose", m, nrhs, n, &a[a_offset], lda, &
+ tau[1], &b[b_offset], ldb, &work[1], lwork, info);
+
+/* Solve R*X = B(1:n,:) */
+
+ ztrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b1, &a[
+ a_offset], lda, &b[b_offset], ldb);
+
+ return 0;
+
+/* End of ZGEQRS */
+
+} /* zgeqrs_ */
diff --git a/TESTING/LIN/zgerqs.c b/TESTING/LIN/zgerqs.c
new file mode 100644
index 0000000..8e7ade7
--- /dev/null
+++ b/TESTING/LIN/zgerqs.c
@@ -0,0 +1,166 @@
+/* zgerqs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+
+/* Subroutine */ int zgerqs_(integer *m, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *b,
+ integer *ldb, doublecomplex *work, integer *lwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+ /* Local variables */
+ extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ xerbla_(char *, integer *), zlaset_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *), zunmrq_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Compute a minimum-norm solution */
+/* min || A*X - B || */
+/* using the RQ factorization */
+/* A = R*Q */
+/* computed by ZGERQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= M >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* Details of the RQ factorization of the original matrix A as */
+/* returned by ZGERQF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* TAU (input) COMPLEX*16 array, dimension (M) */
+/* Details of the orthogonal matrix Q. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the linear system. */
+/* On exit, the solution vectors X. Each solution vector */
+/* is contained in rows 1:N of a column of B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK must be at least NRHS, */
+/* and should be at least NRHS*NB, where NB is the block size */
+/* for this environment. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0 || *m > *n) {
+ *info = -2;
+ } else if (*nrhs < 0) {
+ *info = -3;
+ } else if (*lda < max(1,*m)) {
+ *info = -5;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ } else if (*lwork < 1 || *lwork < *nrhs && *m > 0 && *n > 0) {
+ *info = -10;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZGERQS", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible */
+
+ if (*n == 0 || *nrhs == 0 || *m == 0) {
+ return 0;
+ }
+
+/* Solve R*X = B(n-m+1:n,:) */
+
+ ztrsm_("Left", "Upper", "No transpose", "Non-unit", m, nrhs, &c_b2, &a[(*
+ n - *m + 1) * a_dim1 + 1], lda, &b[*n - *m + 1 + b_dim1], ldb);
+
+/* Set B(1:n-m,:) to zero */
+
+ i__1 = *n - *m;
+ zlaset_("Full", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+
+/* B := Q' * B */
+
+ zunmrq_("Left", "Conjugate transpose", n, nrhs, m, &a[a_offset], lda, &
+ tau[1], &b[b_offset], ldb, &work[1], lwork, info);
+
+ return 0;
+
+/* End of ZGERQS */
+
+} /* zgerqs_ */
diff --git a/TESTING/LIN/zget01.c b/TESTING/LIN/zget01.c
new file mode 100644
index 0000000..8119b4b
--- /dev/null
+++ b/TESTING/LIN/zget01.c
@@ -0,0 +1,213 @@
+/* zget01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zget01_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *afac, integer *ldafac, integer *ipiv,
+ doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3, i__4,
+ i__5;
+ doublecomplex z__1, z__2;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublecomplex t;
+ doublereal eps, anorm;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ extern /* Double Complex */ VOID zdotu_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int ztrmv_(char *, char *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int zlaswp_(integer *, doublecomplex *, integer *,
+ integer *, integer *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGET01 reconstructs a matrix A from its L*U factorization and */
+/* computes the residual */
+/* norm(L*U - A) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original M x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* AFAC (input/output) COMPLEX*16 array, dimension (LDAFAC,N) */
+/* The factored form of the matrix A. AFAC contains the factors */
+/* L and U from the L*U factorization as computed by ZGETRF. */
+/* Overwritten with the reconstructed matrix, and then with the */
+/* difference L*U - A. */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. LDAFAC >= max(1,M). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from ZGETRF. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* norm(L*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if M = 0 or N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ --ipiv;
+ --rwork;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Determine EPS and the norm of A. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+
+/* Compute the product L*U and overwrite AFAC with the result. */
+/* A column at a time of the product is obtained, starting with */
+/* column N. */
+
+ for (k = *n; k >= 1; --k) {
+ if (k > *m) {
+ ztrmv_("Lower", "No transpose", "Unit", m, &afac[afac_offset],
+ ldafac, &afac[k * afac_dim1 + 1], &c__1);
+ } else {
+
+/* Compute elements (K+1:M,K) */
+
+ i__1 = k + k * afac_dim1;
+ t.r = afac[i__1].r, t.i = afac[i__1].i;
+ if (k + 1 <= *m) {
+ i__1 = *m - k;
+ zscal_(&i__1, &t, &afac[k + 1 + k * afac_dim1], &c__1);
+ i__1 = *m - k;
+ i__2 = k - 1;
+ zgemv_("No transpose", &i__1, &i__2, &c_b1, &afac[k + 1 +
+ afac_dim1], ldafac, &afac[k * afac_dim1 + 1], &c__1, &
+ c_b1, &afac[k + 1 + k * afac_dim1], &c__1)
+ ;
+ }
+
+/* Compute the (K,K) element */
+
+ i__1 = k + k * afac_dim1;
+ i__2 = k - 1;
+ zdotu_(&z__2, &i__2, &afac[k + afac_dim1], ldafac, &afac[k *
+ afac_dim1 + 1], &c__1);
+ z__1.r = t.r + z__2.r, z__1.i = t.i + z__2.i;
+ afac[i__1].r = z__1.r, afac[i__1].i = z__1.i;
+
+/* Compute elements (1:K-1,K) */
+
+ i__1 = k - 1;
+ ztrmv_("Lower", "No transpose", "Unit", &i__1, &afac[afac_offset],
+ ldafac, &afac[k * afac_dim1 + 1], &c__1);
+ }
+/* L10: */
+ }
+ i__1 = min(*m,*n);
+ zlaswp_(n, &afac[afac_offset], ldafac, &c__1, &i__1, &ipiv[1], &c_n1);
+
+/* Compute the difference L*U - A and store in AFAC. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * afac_dim1;
+ i__4 = i__ + j * afac_dim1;
+ i__5 = i__ + j * a_dim1;
+ z__1.r = afac[i__4].r - a[i__5].r, z__1.i = afac[i__4].i - a[i__5]
+ .i;
+ afac[i__3].r = z__1.r, afac[i__3].i = z__1.i;
+/* L20: */
+ }
+/* L30: */
+ }
+
+/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = zlange_("1", m, n, &afac[afac_offset], ldafac, &rwork[1]);
+
+ if (anorm <= 0.) {
+ if (*resid != 0.) {
+ *resid = 1. / eps;
+ }
+ } else {
+ *resid = *resid / (doublereal) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of ZGET01 */
+
+} /* zget01_ */
diff --git a/TESTING/LIN/zget02.c b/TESTING/LIN/zget02.c
new file mode 100644
index 0000000..688affb
--- /dev/null
+++ b/TESTING/LIN/zget02.c
@@ -0,0 +1,190 @@
+/* zget02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zget02_(char *trans, integer *m, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *x, integer *ldx,
+ doublecomplex *b, integer *ldb, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer j, n1, n2;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ doublereal anorm, bnorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ doublereal xnorm;
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *),
+ dzasum_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGET02 computes the residual for a solution of a system of linear */
+/* equations A*x = b or A'*x = b: */
+/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A *x = b */
+/* = 'T': A^T*x = b, where A^T is the transpose of A */
+/* = 'C': A^H*x = b, where A^H is the conjugate transpose of A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original M x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. IF TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if M = 0 or N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0 || *nrhs == 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+ if (lsame_(trans, "T") || lsame_(trans, "C")) {
+ n1 = *n;
+ n2 = *m;
+ } else {
+ n1 = *m;
+ n2 = *n;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlange_("1", &n1, &n2, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute B - A*X (or B - A'*X ) and store in B. */
+
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_(trans, "No transpose", &n1, nrhs, &n2, &z__1, &a[a_offset], lda, &
+ x[x_offset], ldx, &c_b1, &b[b_offset], ldb)
+ ;
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = dzasum_(&n1, &b[j * b_dim1 + 1], &c__1);
+ xnorm = dzasum_(&n2, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of ZGET02 */
+
+} /* zget02_ */
diff --git a/TESTING/LIN/zget03.c b/TESTING/LIN/zget03.c
new file mode 100644
index 0000000..4bad003
--- /dev/null
+++ b/TESTING/LIN/zget03.c
@@ -0,0 +1,160 @@
+/* zget03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+
+/* Subroutine */ int zget03_(integer *n, doublecomplex *a, integer *lda,
+ doublecomplex *ainv, integer *ldainv, doublecomplex *work, integer *
+ ldwork, doublereal *rwork, doublereal *rcond, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, ainv_dim1, ainv_offset, work_dim1, work_offset,
+ i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__;
+ doublereal eps, anorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ doublereal ainvnm;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGET03 computes the residual for a general matrix times its inverse: */
+/* norm( I - AINV*A ) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original N x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AINV (input) COMPLEX*16 array, dimension (LDAINV,N) */
+/* The inverse of the matrix A. */
+
+/* LDAINV (input) INTEGER */
+/* The leading dimension of the array AINV. LDAINV >= max(1,N). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,N) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal of the condition number of A, computed as */
+/* ( 1/norm(A) ) / norm(AINV). */
+
+/* RESID (output) DOUBLE PRECISION */
+/* norm(I - AINV*A) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ ainv_dim1 = *ldainv;
+ ainv_offset = 1 + ainv_dim1;
+ ainv -= ainv_offset;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.;
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlange_("1", n, n, &a[a_offset], lda, &rwork[1]);
+ ainvnm = zlange_("1", n, n, &ainv[ainv_offset], ldainv, &rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ *rcond = 0.;
+ *resid = 1. / eps;
+ return 0;
+ }
+ *rcond = 1. / anorm / ainvnm;
+
+/* Compute I - A * AINV */
+
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("No transpose", "No transpose", n, n, n, &z__1, &ainv[ainv_offset],
+ ldainv, &a[a_offset], lda, &c_b1, &work[work_offset], ldwork);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * work_dim1;
+ i__3 = i__ + i__ * work_dim1;
+ z__1.r = work[i__3].r + 1., z__1.i = work[i__3].i + 0.;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L10: */
+ }
+
+/* Compute norm(I - AINV*A) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = zlange_("1", n, n, &work[work_offset], ldwork, &rwork[1]);
+
+ *resid = *resid * *rcond / eps / (doublereal) (*n);
+
+ return 0;
+
+/* End of ZGET03 */
+
+} /* zget03_ */
diff --git a/TESTING/LIN/zget04.c b/TESTING/LIN/zget04.c
new file mode 100644
index 0000000..e47d6d5
--- /dev/null
+++ b/TESTING/LIN/zget04.c
@@ -0,0 +1,174 @@
+/* zget04.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zget04_(integer *n, integer *nrhs, doublecomplex *x,
+ integer *ldx, doublecomplex *xact, integer *ldxact, doublereal *rcond,
+ doublereal *resid)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, xact_dim1, xact_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, ix;
+ doublereal eps, xnorm;
+ extern doublereal dlamch_(char *);
+ doublereal diffnm;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGET04 computes the difference between a computed solution and the */
+/* true solution to a system of linear equations. */
+
+/* RESID = ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ), */
+/* where RCOND is the reciprocal of the condition number and EPS is the */
+/* machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X and XACT. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X and XACT. NRHS >= 0. */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* The reciprocal of the condition number of the coefficient */
+/* matrix in the system of equations. */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the NRHS solution vectors of */
+/* ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if RCOND is invalid. */
+
+ eps = dlamch_("Epsilon");
+ if (*rcond < 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute the maximum of */
+/* norm(X - XACT) / ( norm(XACT) * EPS ) */
+/* over all the vectors X and XACT . */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ix = izamax_(n, &xact[j * xact_dim1 + 1], &c__1);
+ i__2 = ix + j * xact_dim1;
+ xnorm = (d__1 = xact[i__2].r, abs(d__1)) + (d__2 = d_imag(&xact[ix +
+ j * xact_dim1]), abs(d__2));
+ diffnm = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * xact_dim1;
+ z__2.r = x[i__3].r - xact[i__4].r, z__2.i = x[i__3].i - xact[i__4]
+ .i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+/* Computing MAX */
+ d__3 = diffnm, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(
+ &z__1), abs(d__2));
+ diffnm = max(d__3,d__4);
+/* L10: */
+ }
+ if (xnorm <= 0.) {
+ if (diffnm > 0.) {
+ *resid = 1. / eps;
+ }
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = diffnm / xnorm * *rcond;
+ *resid = max(d__1,d__2);
+ }
+/* L20: */
+ }
+ if (*resid * eps < 1.) {
+ *resid /= eps;
+ }
+
+ return 0;
+
+/* End of ZGET04 */
+
+} /* zget04_ */
diff --git a/TESTING/LIN/zget07.c b/TESTING/LIN/zget07.c
new file mode 100644
index 0000000..8b5e9ee
--- /dev/null
+++ b/TESTING/LIN/zget07.c
@@ -0,0 +1,290 @@
+/* zget07.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zget07_(char *trans, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublecomplex *xact, integer *ldxact,
+ doublereal *ferr, logical *chkferr, doublereal *berr, doublereal *
+ reslts)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal eps, tmp, diff, axbi;
+ integer imax;
+ doublereal unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ doublereal xnorm;
+ extern doublereal dlamch_(char *);
+ doublereal errbnd;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGET07 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations op(A)*X = B, where A is a */
+/* general n by n matrix and op(A) = A or A**T, depending on TRANS. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X and XACT. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X and XACT. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original n by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* CHKFERR (input) LOGICAL */
+/* Set to .TRUE. to check FERR, .FALSE. not to check FERR. */
+/* When the test system is ill-conditioned, the "true" */
+/* solution in XACT may be incorrect. */
+
+/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.;
+ reslts[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ notran = lsame_(trans, "N");
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.;
+ if (*chkferr) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = izamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__2 = imax + j * x_dim1;
+ d__3 = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[imax + j
+ * x_dim1]), abs(d__2));
+ xnorm = max(d__3,unfl);
+ diff = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * xact_dim1;
+ z__2.r = x[i__3].r - xact[i__4].r, z__2.i = x[i__3].i - xact[
+ i__4].i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+/* Computing MAX */
+ d__3 = diff, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 =
+ d_imag(&z__1), abs(d__2));
+ diff = max(d__3,d__4);
+/* L10: */
+ }
+
+ if (xnorm > 1.) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1. / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
+ errbnd = max(d__1,d__2);
+ } else {
+ errbnd = 1. / eps;
+ }
+L30:
+ ;
+ }
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ tmp = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__ + k *
+ b_dim1]), abs(d__2));
+ if (notran) {
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = i__ + j * a_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2))) * ((d__3 = x[i__5]
+ .r, abs(d__3)) + (d__4 = d_imag(&x[j + k * x_dim1]
+ ), abs(d__4)));
+/* L40: */
+ }
+ } else {
+ i__3 = *n;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j + i__ * a_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[
+ j + i__ * a_dim1]), abs(d__2))) * ((d__3 = x[i__5]
+ .r, abs(d__3)) + (d__4 = d_imag(&x[j + k * x_dim1]
+ ), abs(d__4)));
+/* L50: */
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = min(axbi,tmp);
+ }
+/* L60: */
+ }
+/* Computing MAX */
+ d__1 = axbi, d__2 = (*n + 1) * unfl;
+ tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / max(d__1,d__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = max(reslts[2],tmp);
+ }
+/* L70: */
+ }
+
+ return 0;
+
+/* End of ZGET07 */
+
+} /* zget07_ */
diff --git a/TESTING/LIN/zget08.c b/TESTING/LIN/zget08.c
new file mode 100644
index 0000000..b46b0d8
--- /dev/null
+++ b/TESTING/LIN/zget08.c
@@ -0,0 +1,201 @@
+/* zget08.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zget08_(char *trans, integer *m, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *x, integer *ldx,
+ doublecomplex *b, integer *ldb, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer j, n1, n2;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ doublereal anorm, bnorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ doublereal xnorm;
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGET02 computes the residual for a solution of a system of linear */
+/* equations A*x = b or A'*x = b: */
+/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A *x = b */
+/* = 'T': A^T*x = b, where A^T is the transpose of A */
+/* = 'C': A^H*x = b, where A^H is the conjugate transpose of A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original M x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. IF TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if M = 0 or N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0 || *nrhs == 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+ if (lsame_(trans, "T") || lsame_(trans, "C")) {
+ n1 = *n;
+ n2 = *m;
+ } else {
+ n1 = *m;
+ n2 = *n;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlange_("I", &n1, &n2, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute B - A*X (or B - A'*X ) and store in B. */
+
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_(trans, "No transpose", &n1, nrhs, &n2, &z__1, &a[a_offset], lda, &
+ x[x_offset], ldx, &c_b1, &b[b_offset], ldb)
+ ;
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = izamax_(&n1, &b[j * b_dim1 + 1], &c__1) + j * b_dim1;
+ bnorm = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[izamax_(&n1,
+ &b[j * b_dim1 + 1], &c__1) + j * b_dim1]), abs(d__2));
+ i__2 = izamax_(&n2, &x[j * x_dim1 + 1], &c__1) + j * x_dim1;
+ xnorm = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[izamax_(&n2,
+ &x[j * x_dim1 + 1], &c__1) + j * x_dim1]), abs(d__2));
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of ZGET02 */
+
+} /* zget08_ */
diff --git a/TESTING/LIN/zgtt01.c b/TESTING/LIN/zgtt01.c
new file mode 100644
index 0000000..2b4d6f7
--- /dev/null
+++ b/TESTING/LIN/zgtt01.c
@@ -0,0 +1,281 @@
+/* zgtt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zgtt01_(integer *n, doublecomplex *dl, doublecomplex *
+ d__, doublecomplex *du, doublecomplex *dlf, doublecomplex *df,
+ doublecomplex *duf, doublecomplex *du2, integer *ipiv, doublecomplex *
+ work, integer *ldwork, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer work_dim1, work_offset, i__1, i__2, i__3, i__4;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j;
+ doublecomplex li;
+ integer ip;
+ doublereal eps, anorm;
+ integer lastj;
+ extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlangt_(char *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *),
+ zlanhs_(char *, integer *, doublecomplex *, integer *, doublereal
+ *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGTT01 reconstructs a tridiagonal matrix A from its LU factorization */
+/* and computes the residual */
+/* norm(L*U - A) / ( norm(A) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGTER */
+/* The order of the matrix A. N >= 0. */
+
+/* DL (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) sub-diagonal elements of A. */
+
+/* D (input) COMPLEX*16 array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* DU (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) super-diagonal elements of A. */
+
+/* DLF (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) multipliers that define the matrix L from the */
+/* LU factorization of A. */
+
+/* DF (input) COMPLEX*16 array, dimension (N) */
+/* The n diagonal elements of the upper triangular matrix U from */
+/* the LU factorization of A. */
+
+/* DUF (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) elements of the first super-diagonal of U. */
+
+/* DU2 (input) COMPLEX*16 array, dimension (N-2) */
+/* The (n-2) elements of the second super-diagonal of U. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices; for 1 <= i <= n, row i of the matrix was */
+/* interchanged with row IPIV(i). IPIV(i) will always be either */
+/* i or i+1; IPIV(i) = i indicates a row interchange was not */
+/* required. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,N) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The scaled residual: norm(L*U - A) / (norm(A) * EPS) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ --dlf;
+ --df;
+ --duf;
+ --du2;
+ --ipiv;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+
+/* Copy the matrix U to WORK. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * work_dim1;
+ work[i__3].r = 0., work[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (i__ == 1) {
+ i__2 = i__ + i__ * work_dim1;
+ i__3 = i__;
+ work[i__2].r = df[i__3].r, work[i__2].i = df[i__3].i;
+ if (*n >= 2) {
+ i__2 = i__ + (i__ + 1) * work_dim1;
+ i__3 = i__;
+ work[i__2].r = duf[i__3].r, work[i__2].i = duf[i__3].i;
+ }
+ if (*n >= 3) {
+ i__2 = i__ + (i__ + 2) * work_dim1;
+ i__3 = i__;
+ work[i__2].r = du2[i__3].r, work[i__2].i = du2[i__3].i;
+ }
+ } else if (i__ == *n) {
+ i__2 = i__ + i__ * work_dim1;
+ i__3 = i__;
+ work[i__2].r = df[i__3].r, work[i__2].i = df[i__3].i;
+ } else {
+ i__2 = i__ + i__ * work_dim1;
+ i__3 = i__;
+ work[i__2].r = df[i__3].r, work[i__2].i = df[i__3].i;
+ i__2 = i__ + (i__ + 1) * work_dim1;
+ i__3 = i__;
+ work[i__2].r = duf[i__3].r, work[i__2].i = duf[i__3].i;
+ if (i__ < *n - 1) {
+ i__2 = i__ + (i__ + 2) * work_dim1;
+ i__3 = i__;
+ work[i__2].r = du2[i__3].r, work[i__2].i = du2[i__3].i;
+ }
+ }
+/* L30: */
+ }
+
+/* Multiply on the left by L. */
+
+ lastj = *n;
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+ i__1 = i__;
+ li.r = dlf[i__1].r, li.i = dlf[i__1].i;
+ i__1 = lastj - i__ + 1;
+ zaxpy_(&i__1, &li, &work[i__ + i__ * work_dim1], ldwork, &work[i__ +
+ 1 + i__ * work_dim1], ldwork);
+ ip = ipiv[i__];
+ if (ip == i__) {
+/* Computing MIN */
+ i__1 = i__ + 2;
+ lastj = min(i__1,*n);
+ } else {
+ i__1 = lastj - i__ + 1;
+ zswap_(&i__1, &work[i__ + i__ * work_dim1], ldwork, &work[i__ + 1
+ + i__ * work_dim1], ldwork);
+ }
+/* L40: */
+ }
+
+/* Subtract the matrix A. */
+
+ i__1 = work_dim1 + 1;
+ i__2 = work_dim1 + 1;
+ z__1.r = work[i__2].r - d__[1].r, z__1.i = work[i__2].i - d__[1].i;
+ work[i__1].r = z__1.r, work[i__1].i = z__1.i;
+ if (*n > 1) {
+ i__1 = (work_dim1 << 1) + 1;
+ i__2 = (work_dim1 << 1) + 1;
+ z__1.r = work[i__2].r - du[1].r, z__1.i = work[i__2].i - du[1].i;
+ work[i__1].r = z__1.r, work[i__1].i = z__1.i;
+ i__1 = *n + (*n - 1) * work_dim1;
+ i__2 = *n + (*n - 1) * work_dim1;
+ i__3 = *n - 1;
+ z__1.r = work[i__2].r - dl[i__3].r, z__1.i = work[i__2].i - dl[i__3]
+ .i;
+ work[i__1].r = z__1.r, work[i__1].i = z__1.i;
+ i__1 = *n + *n * work_dim1;
+ i__2 = *n + *n * work_dim1;
+ i__3 = *n;
+ z__1.r = work[i__2].r - d__[i__3].r, z__1.i = work[i__2].i - d__[i__3]
+ .i;
+ work[i__1].r = z__1.r, work[i__1].i = z__1.i;
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__ + (i__ - 1) * work_dim1;
+ i__3 = i__ + (i__ - 1) * work_dim1;
+ i__4 = i__ - 1;
+ z__1.r = work[i__3].r - dl[i__4].r, z__1.i = work[i__3].i - dl[
+ i__4].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ i__2 = i__ + i__ * work_dim1;
+ i__3 = i__ + i__ * work_dim1;
+ i__4 = i__;
+ z__1.r = work[i__3].r - d__[i__4].r, z__1.i = work[i__3].i - d__[
+ i__4].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ i__2 = i__ + (i__ + 1) * work_dim1;
+ i__3 = i__ + (i__ + 1) * work_dim1;
+ i__4 = i__;
+ z__1.r = work[i__3].r - du[i__4].r, z__1.i = work[i__3].i - du[
+ i__4].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L50: */
+ }
+ }
+
+/* Compute the 1-norm of the tridiagonal matrix A. */
+
+ anorm = zlangt_("1", n, &dl[1], &d__[1], &du[1]);
+
+/* Compute the 1-norm of WORK, which is only guaranteed to be */
+/* upper Hessenberg. */
+
+ *resid = zlanhs_("1", n, &work[work_offset], ldwork, &rwork[1])
+ ;
+
+/* Compute norm(L*U - A) / (norm(A) * EPS) */
+
+ if (anorm <= 0.) {
+ if (*resid != 0.) {
+ *resid = 1. / eps;
+ }
+ } else {
+ *resid = *resid / anorm / eps;
+ }
+
+ return 0;
+
+/* End of ZGTT01 */
+
+} /* zgtt01_ */
diff --git a/TESTING/LIN/zgtt02.c b/TESTING/LIN/zgtt02.c
new file mode 100644
index 0000000..87913da
--- /dev/null
+++ b/TESTING/LIN/zgtt02.c
@@ -0,0 +1,181 @@
+/* zgtt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b6 = -1.;
+static doublereal c_b7 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int zgtt02_(char *trans, integer *n, integer *nrhs,
+ doublecomplex *dl, doublecomplex *d__, doublecomplex *du,
+ doublecomplex *x, integer *ldx, doublecomplex *b, integer *ldb,
+ doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ doublereal anorm, bnorm, xnorm;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zlagtm_(char *, integer *, integer *,
+ doublereal *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *,
+ integer *);
+ extern doublereal zlangt_(char *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *), dzasum_(integer *,
+ doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGTT02 computes the residual for the solution to a tridiagonal */
+/* system of equations: */
+/* RESID = norm(B - op(A)*X) / (norm(A) * norm(X) * EPS), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER */
+/* Specifies the form of the residual. */
+/* = 'N': B - A * X (No transpose) */
+/* = 'T': B - A**T * X (Transpose) */
+/* = 'C': B - A**H * X (Conjugate transpose) */
+
+/* N (input) INTEGTER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* DL (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) sub-diagonal elements of A. */
+
+/* D (input) COMPLEX*16 array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* DU (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) super-diagonal elements of A. */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - op(A)*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* norm(B - op(A)*X) / (norm(A) * norm(X) * EPS) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ *resid = 0.;
+ if (*n <= 0 || *nrhs == 0) {
+ return 0;
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - op(A)*X) / ( norm(A) * norm(X) * EPS ). */
+
+ if (lsame_(trans, "N")) {
+ anorm = zlangt_("1", n, &dl[1], &d__[1], &du[1]);
+ } else {
+ anorm = zlangt_("I", n, &dl[1], &d__[1], &du[1]);
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute B - op(A)*X. */
+
+ zlagtm_(trans, n, nrhs, &c_b6, &dl[1], &d__[1], &du[1], &x[x_offset], ldx,
+ &c_b7, &b[b_offset], ldb);
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = dzasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = dzasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of ZGTT02 */
+
+} /* zgtt02_ */
diff --git a/TESTING/LIN/zgtt05.c b/TESTING/LIN/zgtt05.c
new file mode 100644
index 0000000..0ec39ae
--- /dev/null
+++ b/TESTING/LIN/zgtt05.c
@@ -0,0 +1,378 @@
+/* zgtt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zgtt05_(char *trans, integer *n, integer *nrhs,
+ doublecomplex *dl, doublecomplex *d__, doublecomplex *du,
+ doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
+ doublecomplex *xact, integer *ldxact, doublereal *ferr, doublereal *
+ berr, doublereal *reslts)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1,
+ i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
+ d__11, d__12, d__13, d__14;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, nz;
+ doublereal eps, tmp, diff, axbi;
+ integer imax;
+ doublereal unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ doublereal xnorm;
+ extern doublereal dlamch_(char *);
+ doublereal errbnd;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZGTT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* general tridiagonal matrix of order n and op(A) = A or A**T, */
+/* depending on TRANS. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+/* and NZ = max. number of nonzeros in any row of A, plus 1 */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A**T * X = B (Transpose) */
+/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X and XACT. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X and XACT. NRHS >= 0. */
+
+/* DL (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) sub-diagonal elements of A. */
+
+/* D (input) COMPLEX*16 array, dimension (N) */
+/* The diagonal elements of A. */
+
+/* DU (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) super-diagonal elements of A. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ --dl;
+ --d__;
+ --du;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.;
+ reslts[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ notran = lsame_(trans, "N");
+ nz = 4;
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = izamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__2 = imax + j * x_dim1;
+ d__3 = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[imax + j *
+ x_dim1]), abs(d__2));
+ xnorm = max(d__3,unfl);
+ diff = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * xact_dim1;
+ z__2.r = x[i__3].r - xact[i__4].r, z__2.i = x[i__3].i - xact[i__4]
+ .i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+/* Computing MAX */
+ d__3 = diff, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
+ z__1), abs(d__2));
+ diff = max(d__3,d__4);
+/* L10: */
+ }
+
+ if (xnorm > 1.) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1. / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
+ errbnd = max(d__1,d__2);
+ } else {
+ errbnd = 1. / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ if (notran) {
+ if (*n == 1) {
+ i__2 = k * b_dim1 + 1;
+ i__3 = k * x_dim1 + 1;
+ axbi = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[k *
+ b_dim1 + 1]), abs(d__2)) + ((d__3 = d__[1].r, abs(
+ d__3)) + (d__4 = d_imag(&d__[1]), abs(d__4))) * ((
+ d__5 = x[i__3].r, abs(d__5)) + (d__6 = d_imag(&x[k *
+ x_dim1 + 1]), abs(d__6)));
+ } else {
+ i__2 = k * b_dim1 + 1;
+ i__3 = k * x_dim1 + 1;
+ i__4 = k * x_dim1 + 2;
+ axbi = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[k *
+ b_dim1 + 1]), abs(d__2)) + ((d__3 = d__[1].r, abs(
+ d__3)) + (d__4 = d_imag(&d__[1]), abs(d__4))) * ((
+ d__5 = x[i__3].r, abs(d__5)) + (d__6 = d_imag(&x[k *
+ x_dim1 + 1]), abs(d__6))) + ((d__7 = du[1].r, abs(
+ d__7)) + (d__8 = d_imag(&du[1]), abs(d__8))) * ((d__9
+ = x[i__4].r, abs(d__9)) + (d__10 = d_imag(&x[k *
+ x_dim1 + 2]), abs(d__10)));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ i__4 = i__ - 1;
+ i__5 = i__ - 1 + k * x_dim1;
+ i__6 = i__;
+ i__7 = i__ + k * x_dim1;
+ i__8 = i__;
+ i__9 = i__ + 1 + k * x_dim1;
+ tmp = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
+ i__ + k * b_dim1]), abs(d__2)) + ((d__3 = dl[i__4]
+ .r, abs(d__3)) + (d__4 = d_imag(&dl[i__ - 1]),
+ abs(d__4))) * ((d__5 = x[i__5].r, abs(d__5)) + (
+ d__6 = d_imag(&x[i__ - 1 + k * x_dim1]), abs(d__6)
+ )) + ((d__7 = d__[i__6].r, abs(d__7)) + (d__8 =
+ d_imag(&d__[i__]), abs(d__8))) * ((d__9 = x[i__7]
+ .r, abs(d__9)) + (d__10 = d_imag(&x[i__ + k *
+ x_dim1]), abs(d__10))) + ((d__11 = du[i__8].r,
+ abs(d__11)) + (d__12 = d_imag(&du[i__]), abs(
+ d__12))) * ((d__13 = x[i__9].r, abs(d__13)) + (
+ d__14 = d_imag(&x[i__ + 1 + k * x_dim1]), abs(
+ d__14)));
+ axbi = min(axbi,tmp);
+/* L40: */
+ }
+ i__2 = *n + k * b_dim1;
+ i__3 = *n - 1;
+ i__4 = *n - 1 + k * x_dim1;
+ i__5 = *n;
+ i__6 = *n + k * x_dim1;
+ tmp = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[*n +
+ k * b_dim1]), abs(d__2)) + ((d__3 = dl[i__3].r, abs(
+ d__3)) + (d__4 = d_imag(&dl[*n - 1]), abs(d__4))) * ((
+ d__5 = x[i__4].r, abs(d__5)) + (d__6 = d_imag(&x[*n -
+ 1 + k * x_dim1]), abs(d__6))) + ((d__7 = d__[i__5].r,
+ abs(d__7)) + (d__8 = d_imag(&d__[*n]), abs(d__8))) * (
+ (d__9 = x[i__6].r, abs(d__9)) + (d__10 = d_imag(&x[*n
+ + k * x_dim1]), abs(d__10)));
+ axbi = min(axbi,tmp);
+ }
+ } else {
+ if (*n == 1) {
+ i__2 = k * b_dim1 + 1;
+ i__3 = k * x_dim1 + 1;
+ axbi = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[k *
+ b_dim1 + 1]), abs(d__2)) + ((d__3 = d__[1].r, abs(
+ d__3)) + (d__4 = d_imag(&d__[1]), abs(d__4))) * ((
+ d__5 = x[i__3].r, abs(d__5)) + (d__6 = d_imag(&x[k *
+ x_dim1 + 1]), abs(d__6)));
+ } else {
+ i__2 = k * b_dim1 + 1;
+ i__3 = k * x_dim1 + 1;
+ i__4 = k * x_dim1 + 2;
+ axbi = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[k *
+ b_dim1 + 1]), abs(d__2)) + ((d__3 = d__[1].r, abs(
+ d__3)) + (d__4 = d_imag(&d__[1]), abs(d__4))) * ((
+ d__5 = x[i__3].r, abs(d__5)) + (d__6 = d_imag(&x[k *
+ x_dim1 + 1]), abs(d__6))) + ((d__7 = dl[1].r, abs(
+ d__7)) + (d__8 = d_imag(&dl[1]), abs(d__8))) * ((d__9
+ = x[i__4].r, abs(d__9)) + (d__10 = d_imag(&x[k *
+ x_dim1 + 2]), abs(d__10)));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ i__4 = i__ - 1;
+ i__5 = i__ - 1 + k * x_dim1;
+ i__6 = i__;
+ i__7 = i__ + k * x_dim1;
+ i__8 = i__;
+ i__9 = i__ + 1 + k * x_dim1;
+ tmp = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[
+ i__ + k * b_dim1]), abs(d__2)) + ((d__3 = du[i__4]
+ .r, abs(d__3)) + (d__4 = d_imag(&du[i__ - 1]),
+ abs(d__4))) * ((d__5 = x[i__5].r, abs(d__5)) + (
+ d__6 = d_imag(&x[i__ - 1 + k * x_dim1]), abs(d__6)
+ )) + ((d__7 = d__[i__6].r, abs(d__7)) + (d__8 =
+ d_imag(&d__[i__]), abs(d__8))) * ((d__9 = x[i__7]
+ .r, abs(d__9)) + (d__10 = d_imag(&x[i__ + k *
+ x_dim1]), abs(d__10))) + ((d__11 = dl[i__8].r,
+ abs(d__11)) + (d__12 = d_imag(&dl[i__]), abs(
+ d__12))) * ((d__13 = x[i__9].r, abs(d__13)) + (
+ d__14 = d_imag(&x[i__ + 1 + k * x_dim1]), abs(
+ d__14)));
+ axbi = min(axbi,tmp);
+/* L50: */
+ }
+ i__2 = *n + k * b_dim1;
+ i__3 = *n - 1;
+ i__4 = *n - 1 + k * x_dim1;
+ i__5 = *n;
+ i__6 = *n + k * x_dim1;
+ tmp = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[*n +
+ k * b_dim1]), abs(d__2)) + ((d__3 = du[i__3].r, abs(
+ d__3)) + (d__4 = d_imag(&du[*n - 1]), abs(d__4))) * ((
+ d__5 = x[i__4].r, abs(d__5)) + (d__6 = d_imag(&x[*n -
+ 1 + k * x_dim1]), abs(d__6))) + ((d__7 = d__[i__5].r,
+ abs(d__7)) + (d__8 = d_imag(&d__[*n]), abs(d__8))) * (
+ (d__9 = x[i__6].r, abs(d__9)) + (d__10 = d_imag(&x[*n
+ + k * x_dim1]), abs(d__10)));
+ axbi = min(axbi,tmp);
+ }
+ }
+/* Computing MAX */
+ d__1 = axbi, d__2 = nz * unfl;
+ tmp = berr[k] / (nz * eps + nz * unfl / max(d__1,d__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = max(reslts[2],tmp);
+ }
+/* L60: */
+ }
+
+ return 0;
+
+/* End of ZGTT05 */
+
+} /* zgtt05_ */
diff --git a/TESTING/LIN/zhet01.c b/TESTING/LIN/zhet01.c
new file mode 100644
index 0000000..da21a13
--- /dev/null
+++ b/TESTING/LIN/zhet01.c
@@ -0,0 +1,238 @@
+/* zhet01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+
+/* Subroutine */ int zhet01_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *afac, integer *ldafac, integer *ipiv,
+ doublecomplex *c__, integer *ldc, doublereal *rwork, doublereal *
+ resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, c_dim1, c_offset, i__1,
+ i__2, i__3, i__4, i__5;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal eps;
+ integer info;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern doublereal dlamch_(char *), zlanhe_(char *, char *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int zlavhe_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, integer *, doublecomplex *,
+ integer *, integer *), zlaset_(char *,
+ integer *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHET01 reconstructs a Hermitian indefinite matrix A from its */
+/* block L*D*L' or U*D*U' factorization and computes the residual */
+/* norm( C - A ) / ( N * norm(A) * EPS ), */
+/* where C is the reconstructed matrix, EPS is the machine epsilon, */
+/* L' is the conjugate transpose of L, and U' is the conjugate transpose */
+/* of U. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original Hermitian matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* AFAC (input) COMPLEX*16 array, dimension (LDAFAC,N) */
+/* The factored form of the matrix A. AFAC contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor L or U from the block L*D*L' or U*D*U' factorization */
+/* as computed by ZHETRF. */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from ZHETRF. */
+
+/* C (workspace) COMPLEX*16 array, dimension (LDC,N) */
+
+/* LDC (integer) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) 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 ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ --ipiv;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Determine EPS and the norm of A. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+
+/* Check the imaginary parts of the diagonal elements and return with */
+/* an error code if any are nonzero. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (d_imag(&afac[j + j * afac_dim1]) != 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+/* L10: */
+ }
+
+/* Initialize C to the identity matrix. */
+
+ zlaset_("Full", n, n, &c_b1, &c_b2, &c__[c_offset], ldc);
+
+/* Call ZLAVHE to form the product D * U' (or D * L' ). */
+
+ zlavhe_(uplo, "Conjugate", "Non-unit", n, n, &afac[afac_offset], ldafac, &
+ ipiv[1], &c__[c_offset], ldc, &info);
+
+/* Call ZLAVHE again to multiply by U (or L ). */
+
+ zlavhe_(uplo, "No transpose", "Unit", n, n, &afac[afac_offset], ldafac, &
+ ipiv[1], &c__[c_offset], ldc, &info);
+
+/* Compute the difference C - A . */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * a_dim1;
+ z__1.r = c__[i__4].r - a[i__5].r, z__1.i = c__[i__4].i - a[
+ i__5].i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L20: */
+ }
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ i__4 = j + j * a_dim1;
+ d__1 = a[i__4].r;
+ z__1.r = c__[i__3].r - d__1, z__1.i = c__[i__3].i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+/* L30: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ i__4 = j + j * a_dim1;
+ d__1 = a[i__4].r;
+ z__1.r = c__[i__3].r - d__1, z__1.i = c__[i__3].i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * a_dim1;
+ z__1.r = c__[i__4].r - a[i__5].r, z__1.i = c__[i__4].i - a[
+ i__5].i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L40: */
+ }
+/* L50: */
+ }
+ }
+
+/* Compute norm( C - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = zlanhe_("1", uplo, n, &c__[c_offset], ldc, &rwork[1]);
+
+ if (anorm <= 0.) {
+ if (*resid != 0.) {
+ *resid = 1. / eps;
+ }
+ } else {
+ *resid = *resid / (doublereal) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of ZHET01 */
+
+} /* zhet01_ */
diff --git a/TESTING/LIN/zhpt01.c b/TESTING/LIN/zhpt01.c
new file mode 100644
index 0000000..82587c4
--- /dev/null
+++ b/TESTING/LIN/zhpt01.c
@@ -0,0 +1,244 @@
+/* zhpt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+
+/* Subroutine */ int zhpt01_(char *uplo, integer *n, doublecomplex *a,
+ doublecomplex *afac, integer *ipiv, doublecomplex *c__, integer *ldc,
+ doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, jc;
+ doublereal eps;
+ integer info;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern doublereal dlamch_(char *), zlanhe_(char *, char *,
+ integer *, doublecomplex *, integer *, doublereal *), zlanhp_(char *, char *, integer *, doublecomplex *,
+ doublereal *);
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlavhp_(char *, char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZHPT01 reconstructs a Hermitian indefinite packed matrix A from its */
+/* block L*D*L' or U*D*U' factorization and computes the residual */
+/* norm( C - A ) / ( N * norm(A) * EPS ), */
+/* where C is the reconstructed matrix, EPS is the machine epsilon, */
+/* L' is the conjugate transpose of L, and U' is the conjugate transpose */
+/* of U. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The original Hermitian matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* AFAC (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The factored form of the matrix A, stored as a packed */
+/* triangular matrix. AFAC contains the block diagonal matrix D */
+/* and the multipliers used to obtain the factor L or U from the */
+/* block L*D*L' or U*D*U' factorization as computed by ZHPTRF. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from ZHPTRF. */
+
+/* C (workspace) COMPLEX*16 array, dimension (LDC,N) */
+
+/* LDC (integer) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) 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 ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ --a;
+ --afac;
+ --ipiv;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Determine EPS and the norm of A. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlanhp_("1", uplo, n, &a[1], &rwork[1]);
+
+/* Check the imaginary parts of the diagonal elements and return with */
+/* an error code if any are nonzero. */
+
+ jc = 1;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (d_imag(&afac[jc]) != 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+ jc = jc + j + 1;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (d_imag(&afac[jc]) != 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+ jc = jc + *n - j + 1;
+/* L20: */
+ }
+ }
+
+/* Initialize C to the identity matrix. */
+
+ zlaset_("Full", n, n, &c_b1, &c_b2, &c__[c_offset], ldc);
+
+/* Call ZLAVHP to form the product D * U' (or D * L' ). */
+
+ zlavhp_(uplo, "Conjugate", "Non-unit", n, n, &afac[1], &ipiv[1], &c__[
+ c_offset], ldc, &info);
+
+/* Call ZLAVHP again to multiply by U ( or L ). */
+
+ zlavhp_(uplo, "No transpose", "Unit", n, n, &afac[1], &ipiv[1], &c__[
+ c_offset], ldc, &info);
+
+/* Compute the difference C - A . */
+
+ if (lsame_(uplo, "U")) {
+ jc = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = jc + i__;
+ z__1.r = c__[i__4].r - a[i__5].r, z__1.i = c__[i__4].i - a[
+ i__5].i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L30: */
+ }
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ i__4 = jc + j;
+ d__1 = a[i__4].r;
+ z__1.r = c__[i__3].r - d__1, z__1.i = c__[i__3].i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ jc += j;
+/* L40: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * c_dim1;
+ i__3 = j + j * c_dim1;
+ i__4 = jc;
+ d__1 = a[i__4].r;
+ z__1.r = c__[i__3].r - d__1, z__1.i = c__[i__3].i;
+ c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = jc + i__ - j;
+ z__1.r = c__[i__4].r - a[i__5].r, z__1.i = c__[i__4].i - a[
+ i__5].i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L50: */
+ }
+ jc = jc + *n - j + 1;
+/* L60: */
+ }
+ }
+
+/* Compute norm( C - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = zlanhe_("1", uplo, n, &c__[c_offset], ldc, &rwork[1]);
+
+ if (anorm <= 0.) {
+ if (*resid != 0.) {
+ *resid = 1. / eps;
+ }
+ } else {
+ *resid = *resid / (doublereal) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of ZHPT01 */
+
+} /* zhpt01_ */
diff --git a/TESTING/LIN/zlahilb.c b/TESTING/LIN/zlahilb.c
new file mode 100644
index 0000000..055590c
--- /dev/null
+++ b/TESTING/LIN/zlahilb.c
@@ -0,0 +1,277 @@
+/* zlahilb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static doublecomplex c_b6 = {0.,0.};
+
+/* Subroutine */ int zlahilb_(integer *n, integer *nrhs, doublecomplex *a,
+ integer *lda, doublecomplex *x, integer *ldx, doublecomplex *b,
+ integer *ldb, doublereal *work, integer *info, char *path)
+{
+ /* Initialized data */
+
+ static doublecomplex d1[8] = { {-1.,0.},{0.,1.},{-1.,-1.},{0.,-1.},{1.,0.}
+ ,{-1.,1.},{1.,1.},{1.,-1.} };
+ static doublecomplex d2[8] = { {-1.,0.},{0.,-1.},{-1.,1.},{0.,1.},{1.,0.},
+ {-1.,-1.},{1.,-1.},{1.,1.} };
+ static doublecomplex invd1[8] = { {-1.,0.},{0.,-1.},{-.5,.5},{0.,1.},{1.,
+ 0.},{-.5,-.5},{.5,-.5},{.5,.5} };
+ static doublecomplex invd2[8] = { {-1.,0.},{0.,1.},{-.5,-.5},{0.,-1.},{1.,
+ 0.},{-.5,.5},{.5,.5},{.5,-.5} };
+
+ /* System generated locals */
+ integer a_dim1, a_offset, x_dim1, x_offset, b_dim1, b_offset, i__1, i__2,
+ i__3, i__4, i__5;
+ doublereal d__1;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer i__, j, m, r__;
+ char c2[2];
+ integer ti, tm;
+ doublecomplex tmp;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
+/* Courant Institute, Argonne National Lab, and Rice University */
+/* 28 August, 2006 */
+
+/* David Vu <dtv at cs.berkeley.edu> */
+/* Yozo Hida <yozo at cs.berkeley.edu> */
+/* Jason Riedy <ejr at cs.berkeley.edu> */
+/* D. Halligan <dhalligan at berkeley.edu> */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAHILB generates an N by N scaled Hilbert matrix in A along with */
+/* NRHS right-hand sides in B and solutions in X such that A*X=B. */
+
+/* The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all */
+/* entries are integers. The right-hand sides are the first NRHS */
+/* columns of M * the identity matrix, and the solutions are the */
+/* first NRHS columns of the inverse Hilbert matrix. */
+
+/* The condition number of the Hilbert matrix grows exponentially with */
+/* its size, roughly as O(e ** (3.5*N)). Additionally, the inverse */
+/* Hilbert matrices beyond a relatively small dimension cannot be */
+/* generated exactly without extra precision. Precision is exhausted */
+/* when the largest entry in the inverse Hilbert matrix is greater than */
+/* 2 to the power of the number of bits in the fraction of the data type */
+/* used plus one, which is 24 for single precision. */
+
+/* In single, the generated solution is exact for N <= 6 and has */
+/* small componentwise error for 7 <= N <= 11. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The dimension of the matrix A. */
+
+/* NRHS (input) NRHS */
+/* The requested number of right-hand sides. */
+
+/* A (output) COMPLEX array, dimension (LDA, N) */
+/* The generated scaled Hilbert matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= N. */
+
+/* X (output) COMPLEX array, dimension (LDX, NRHS) */
+/* The generated exact solutions. Currently, the first NRHS */
+/* columns of the inverse Hilbert matrix. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= N. */
+
+/* B (output) REAL array, dimension (LDB, NRHS) */
+/* The generated right-hand sides. Currently, the first NRHS */
+/* columns of LCM(1, 2, ..., 2*N-1) * the identity matrix. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= N. */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* = 1: N is too large; the data is still generated but may not */
+/* be not exact. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+/* .. Local Scalars .. */
+/* .. Parameters .. */
+/* NMAX_EXACT the largest dimension where the generated data is */
+/* exact. */
+/* NMAX_APPROX the largest dimension where the generated data has */
+/* a small componentwise relative error. */
+/* ??? complex uses how many bits ??? */
+/* d's are generated from random permuation of those eight elements. */
+ /* Parameter adjustments */
+ --work;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+/* .. */
+/* .. External Functions */
+/* .. */
+/* .. Executable Statements .. */
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Test the input arguments */
+
+ *info = 0;
+ if (*n < 0 || *n > 11) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*lda < *n) {
+ *info = -4;
+ } else if (*ldx < *n) {
+ *info = -6;
+ } else if (*ldb < *n) {
+ *info = -8;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("ZLAHILB", &i__1);
+ return 0;
+ }
+ if (*n > 6) {
+ *info = 1;
+ }
+/* Compute M = the LCM of the integers [1, 2*N-1]. The largest */
+/* reasonable N is small enough that integers suffice (up to N = 11). */
+ m = 1;
+ i__1 = (*n << 1) - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ tm = m;
+ ti = i__;
+ r__ = tm % ti;
+ while(r__ != 0) {
+ tm = ti;
+ ti = r__;
+ r__ = tm % ti;
+ }
+ m = m / ti * i__;
+ }
+/* Generate the scaled Hilbert matrix in A */
+/* If we are testing SY routines, take D1_i = D2_i, else, D1_i = D2_i* */
+ if (lsamen_(&c__2, c2, "SY")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = j % 8;
+ d__1 = (doublereal) m / (i__ + j - 1);
+ z__2.r = d__1 * d1[i__4].r, z__2.i = d__1 * d1[i__4].i;
+ i__5 = i__ % 8;
+ z__1.r = z__2.r * d1[i__5].r - z__2.i * d1[i__5].i, z__1.i =
+ z__2.r * d1[i__5].i + z__2.i * d1[i__5].r;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ }
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = j % 8;
+ d__1 = (doublereal) m / (i__ + j - 1);
+ z__2.r = d__1 * d1[i__4].r, z__2.i = d__1 * d1[i__4].i;
+ i__5 = i__ % 8;
+ z__1.r = z__2.r * d2[i__5].r - z__2.i * d2[i__5].i, z__1.i =
+ z__2.r * d2[i__5].i + z__2.i * d2[i__5].r;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ }
+ }
+ }
+/* Generate matrix B as simply the first NRHS columns of M * the */
+/* identity. */
+ d__1 = (doublereal) m;
+ tmp.r = d__1, tmp.i = 0.;
+ zlaset_("Full", n, nrhs, &c_b6, &tmp, &b[b_offset], ldb);
+/* Generate the true solutions in X. Because B = the first NRHS */
+/* columns of M*I, the true solutions are just the first NRHS columns */
+/* of the inverse Hilbert matrix. */
+ work[1] = (doublereal) (*n);
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ work[j] = work[j - 1] / (j - 1) * (j - 1 - *n) / (j - 1) * (*n + j -
+ 1);
+ }
+/* If we are testing SY routines, take D1_i = D2_i, else, D1_i = D2_i* */
+ if (lsamen_(&c__2, c2, "SY")) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = j % 8;
+ d__1 = work[i__] * work[j] / (i__ + j - 1);
+ z__2.r = d__1 * invd1[i__4].r, z__2.i = d__1 * invd1[i__4].i;
+ i__5 = i__ % 8;
+ z__1.r = z__2.r * invd1[i__5].r - z__2.i * invd1[i__5].i,
+ z__1.i = z__2.r * invd1[i__5].i + z__2.i * invd1[i__5]
+ .r;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ }
+ }
+ } else {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = j % 8;
+ d__1 = work[i__] * work[j] / (i__ + j - 1);
+ z__2.r = d__1 * invd2[i__4].r, z__2.i = d__1 * invd2[i__4].i;
+ i__5 = i__ % 8;
+ z__1.r = z__2.r * invd1[i__5].r - z__2.i * invd1[i__5].i,
+ z__1.i = z__2.r * invd1[i__5].i + z__2.i * invd1[i__5]
+ .r;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ }
+ }
+ }
+ return 0;
+} /* zlahilb_ */
diff --git a/TESTING/LIN/zlaipd.c b/TESTING/LIN/zlaipd.c
new file mode 100644
index 0000000..9c264a2
--- /dev/null
+++ b/TESTING/LIN/zlaipd.c
@@ -0,0 +1,103 @@
+/* zlaipd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlaipd_(integer *n, doublecomplex *a, integer *inda,
+ integer *vinda)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, ia, ixa;
+ extern doublereal dlamch_(char *);
+ doublereal bignum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAIPD sets the imaginary part of the diagonal elements of a complex */
+/* matrix A to a large value. This is used to test LAPACK routines for */
+/* complex Hermitian matrices, which are not supposed to access or use */
+/* the imaginary parts of the diagonals. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of diagonal elements of A. */
+
+/* A (input/output) COMPLEX*16 array, dimension */
+/* (1+(N-1)*INDA+(N-2)*VINDA) */
+/* On entry, the complex (Hermitian) matrix A. */
+/* On exit, the imaginary parts of the diagonal elements are set */
+/* to BIGNUM = EPS / SAFMIN, where EPS is the machine epsilon and */
+/* SAFMIN is the safe minimum. */
+
+/* INDA (input) INTEGER */
+/* The increment between A(1) and the next diagonal element of A. */
+/* Typical values are */
+/* = LDA+1: square matrices with leading dimension LDA */
+/* = 2: packed upper triangular matrix, starting at A(1,1) */
+/* = N: packed lower triangular matrix, starting at A(1,1) */
+
+/* VINDA (input) INTEGER */
+/* The change in the diagonal increment between columns of A. */
+/* Typical values are */
+/* = 0: no change, the row and column increments in A are fixed */
+/* = 1: packed upper triangular matrix */
+/* = -1: packed lower triangular matrix */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --a;
+
+ /* Function Body */
+ bignum = dlamch_("Epsilon") / dlamch_("Safe minimum");
+ ia = 1;
+ ixa = *inda;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = ia;
+ i__3 = ia;
+ d__1 = a[i__3].r;
+ z__1.r = d__1, z__1.i = bignum;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ ia += ixa;
+ ixa += *vinda;
+/* L10: */
+ }
+ return 0;
+} /* zlaipd_ */
diff --git a/TESTING/LIN/zlaptm.c b/TESTING/LIN/zlaptm.c
new file mode 100644
index 0000000..9b5b9fa
--- /dev/null
+++ b/TESTING/LIN/zlaptm.c
@@ -0,0 +1,423 @@
+/* zlaptm.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlaptm_(char *uplo, integer *n, integer *nrhs,
+ doublereal *alpha, doublereal *d__, doublecomplex *e, doublecomplex *
+ x, integer *ldx, doublereal *beta, doublecomplex *b, integer *ldb)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5,
+ i__6, i__7, i__8, i__9;
+ doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ extern logical lsame_(char *, char *);
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAPTM multiplies an N by NRHS matrix X by a Hermitian tridiagonal */
+/* matrix A and stores the result in a matrix B. The operation has the */
+/* form */
+
+/* B := alpha * A * X + beta * B */
+
+/* where alpha may be either 1. or -1. and beta may be 0., 1., or -1. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER */
+/* Specifies whether the superdiagonal or the subdiagonal of the */
+/* tridiagonal matrix A is stored. */
+/* = 'U': Upper, E is the superdiagonal of A. */
+/* = 'L': Lower, E is the subdiagonal of A. */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. */
+
+/* ALPHA (input) DOUBLE PRECISION */
+/* The scalar alpha. ALPHA must be 1. or -1.; otherwise, */
+/* it is assumed to be 0. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) subdiagonal or superdiagonal elements of A. */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The N by NRHS matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(N,1). */
+
+/* BETA (input) DOUBLE PRECISION */
+/* The scalar beta. BETA must be 0., 1., or -1.; otherwise, */
+/* it is assumed to be 1. */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the N by NRHS matrix B. */
+/* On exit, B is overwritten by the matrix expression */
+/* B := alpha * A * X + beta * B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(N,1). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*n == 0) {
+ return 0;
+ }
+
+ if (*beta == 0.) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0., b[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else if (*beta == -1.) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ z__1.r = -b[i__4].r, z__1.i = -b[i__4].i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+ if (*alpha == 1.) {
+ if (lsame_(uplo, "U")) {
+
+/* Compute B := B + A*X, where E is the superdiagonal of A. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ z__2.r = d__[1] * x[i__4].r, z__2.i = d__[1] * x[i__4].i;
+ z__1.r = b[i__3].r + z__2.r, z__1.i = b[i__3].i + z__2.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ z__3.r = d__[1] * x[i__4].r, z__3.i = d__[1] * x[i__4].i;
+ z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i;
+ i__5 = j * x_dim1 + 2;
+ z__4.r = e[1].r * x[i__5].r - e[1].i * x[i__5].i, z__4.i =
+ e[1].r * x[i__5].i + e[1].i * x[i__5].r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ d_cnjg(&z__4, &e[*n - 1]);
+ i__4 = *n - 1 + j * x_dim1;
+ z__3.r = z__4.r * x[i__4].r - z__4.i * x[i__4].i, z__3.i =
+ z__4.r * x[i__4].i + z__4.i * x[i__4].r;
+ z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i;
+ i__5 = *n;
+ i__6 = *n + j * x_dim1;
+ z__5.r = d__[i__5] * x[i__6].r, z__5.i = d__[i__5] * x[
+ i__6].i;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ d_cnjg(&z__5, &e[i__ - 1]);
+ i__5 = i__ - 1 + j * x_dim1;
+ z__4.r = z__5.r * x[i__5].r - z__5.i * x[i__5].i,
+ z__4.i = z__5.r * x[i__5].i + z__5.i * x[i__5]
+ .r;
+ z__3.r = b[i__4].r + z__4.r, z__3.i = b[i__4].i +
+ z__4.i;
+ i__6 = i__;
+ i__7 = i__ + j * x_dim1;
+ z__6.r = d__[i__6] * x[i__7].r, z__6.i = d__[i__6] *
+ x[i__7].i;
+ z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
+ i__8 = i__;
+ i__9 = i__ + 1 + j * x_dim1;
+ z__7.r = e[i__8].r * x[i__9].r - e[i__8].i * x[i__9]
+ .i, z__7.i = e[i__8].r * x[i__9].i + e[i__8]
+ .i * x[i__9].r;
+ z__1.r = z__2.r + z__7.r, z__1.i = z__2.i + z__7.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L50: */
+ }
+ }
+/* L60: */
+ }
+ } else {
+
+/* Compute B := B + A*X, where E is the subdiagonal of A. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ z__2.r = d__[1] * x[i__4].r, z__2.i = d__[1] * x[i__4].i;
+ z__1.r = b[i__3].r + z__2.r, z__1.i = b[i__3].i + z__2.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ z__3.r = d__[1] * x[i__4].r, z__3.i = d__[1] * x[i__4].i;
+ z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i;
+ d_cnjg(&z__5, &e[1]);
+ i__5 = j * x_dim1 + 2;
+ z__4.r = z__5.r * x[i__5].r - z__5.i * x[i__5].i, z__4.i =
+ z__5.r * x[i__5].i + z__5.i * x[i__5].r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ i__4 = *n - 1;
+ i__5 = *n - 1 + j * x_dim1;
+ z__3.r = e[i__4].r * x[i__5].r - e[i__4].i * x[i__5].i,
+ z__3.i = e[i__4].r * x[i__5].i + e[i__4].i * x[
+ i__5].r;
+ z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i;
+ i__6 = *n;
+ i__7 = *n + j * x_dim1;
+ z__4.r = d__[i__6] * x[i__7].r, z__4.i = d__[i__6] * x[
+ i__7].i;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ - 1;
+ i__6 = i__ - 1 + j * x_dim1;
+ z__4.r = e[i__5].r * x[i__6].r - e[i__5].i * x[i__6]
+ .i, z__4.i = e[i__5].r * x[i__6].i + e[i__5]
+ .i * x[i__6].r;
+ z__3.r = b[i__4].r + z__4.r, z__3.i = b[i__4].i +
+ z__4.i;
+ i__7 = i__;
+ i__8 = i__ + j * x_dim1;
+ z__5.r = d__[i__7] * x[i__8].r, z__5.i = d__[i__7] *
+ x[i__8].i;
+ z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
+ d_cnjg(&z__7, &e[i__]);
+ i__9 = i__ + 1 + j * x_dim1;
+ z__6.r = z__7.r * x[i__9].r - z__7.i * x[i__9].i,
+ z__6.i = z__7.r * x[i__9].i + z__7.i * x[i__9]
+ .r;
+ z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L70: */
+ }
+ }
+/* L80: */
+ }
+ }
+ } else if (*alpha == -1.) {
+ if (lsame_(uplo, "U")) {
+
+/* Compute B := B - A*X, where E is the superdiagonal of A. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ z__2.r = d__[1] * x[i__4].r, z__2.i = d__[1] * x[i__4].i;
+ z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i - z__2.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ z__3.r = d__[1] * x[i__4].r, z__3.i = d__[1] * x[i__4].i;
+ z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i;
+ i__5 = j * x_dim1 + 2;
+ z__4.r = e[1].r * x[i__5].r - e[1].i * x[i__5].i, z__4.i =
+ e[1].r * x[i__5].i + e[1].i * x[i__5].r;
+ z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ d_cnjg(&z__4, &e[*n - 1]);
+ i__4 = *n - 1 + j * x_dim1;
+ z__3.r = z__4.r * x[i__4].r - z__4.i * x[i__4].i, z__3.i =
+ z__4.r * x[i__4].i + z__4.i * x[i__4].r;
+ z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i;
+ i__5 = *n;
+ i__6 = *n + j * x_dim1;
+ z__5.r = d__[i__5] * x[i__6].r, z__5.i = d__[i__5] * x[
+ i__6].i;
+ z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - z__5.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ d_cnjg(&z__5, &e[i__ - 1]);
+ i__5 = i__ - 1 + j * x_dim1;
+ z__4.r = z__5.r * x[i__5].r - z__5.i * x[i__5].i,
+ z__4.i = z__5.r * x[i__5].i + z__5.i * x[i__5]
+ .r;
+ z__3.r = b[i__4].r - z__4.r, z__3.i = b[i__4].i -
+ z__4.i;
+ i__6 = i__;
+ i__7 = i__ + j * x_dim1;
+ z__6.r = d__[i__6] * x[i__7].r, z__6.i = d__[i__6] *
+ x[i__7].i;
+ z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
+ i__8 = i__;
+ i__9 = i__ + 1 + j * x_dim1;
+ z__7.r = e[i__8].r * x[i__9].r - e[i__8].i * x[i__9]
+ .i, z__7.i = e[i__8].r * x[i__9].i + e[i__8]
+ .i * x[i__9].r;
+ z__1.r = z__2.r - z__7.r, z__1.i = z__2.i - z__7.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L90: */
+ }
+ }
+/* L100: */
+ }
+ } else {
+
+/* Compute B := B - A*X, where E is the subdiagonal of A. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ if (*n == 1) {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ z__2.r = d__[1] * x[i__4].r, z__2.i = d__[1] * x[i__4].i;
+ z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i - z__2.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ } else {
+ i__2 = j * b_dim1 + 1;
+ i__3 = j * b_dim1 + 1;
+ i__4 = j * x_dim1 + 1;
+ z__3.r = d__[1] * x[i__4].r, z__3.i = d__[1] * x[i__4].i;
+ z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i;
+ d_cnjg(&z__5, &e[1]);
+ i__5 = j * x_dim1 + 2;
+ z__4.r = z__5.r * x[i__5].r - z__5.i * x[i__5].i, z__4.i =
+ z__5.r * x[i__5].i + z__5.i * x[i__5].r;
+ z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = *n + j * b_dim1;
+ i__3 = *n + j * b_dim1;
+ i__4 = *n - 1;
+ i__5 = *n - 1 + j * x_dim1;
+ z__3.r = e[i__4].r * x[i__5].r - e[i__4].i * x[i__5].i,
+ z__3.i = e[i__4].r * x[i__5].i + e[i__4].i * x[
+ i__5].r;
+ z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i;
+ i__6 = *n;
+ i__7 = *n + j * x_dim1;
+ z__4.r = d__[i__6] * x[i__7].r, z__4.i = d__[i__6] * x[
+ i__7].i;
+ z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j * b_dim1;
+ i__5 = i__ - 1;
+ i__6 = i__ - 1 + j * x_dim1;
+ z__4.r = e[i__5].r * x[i__6].r - e[i__5].i * x[i__6]
+ .i, z__4.i = e[i__5].r * x[i__6].i + e[i__5]
+ .i * x[i__6].r;
+ z__3.r = b[i__4].r - z__4.r, z__3.i = b[i__4].i -
+ z__4.i;
+ i__7 = i__;
+ i__8 = i__ + j * x_dim1;
+ z__5.r = d__[i__7] * x[i__8].r, z__5.i = d__[i__7] *
+ x[i__8].i;
+ z__2.r = z__3.r - z__5.r, z__2.i = z__3.i - z__5.i;
+ d_cnjg(&z__7, &e[i__]);
+ i__9 = i__ + 1 + j * x_dim1;
+ z__6.r = z__7.r * x[i__9].r - z__7.i * x[i__9].i,
+ z__6.i = z__7.r * x[i__9].i + z__7.i * x[i__9]
+ .r;
+ z__1.r = z__2.r - z__6.r, z__1.i = z__2.i - z__6.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L110: */
+ }
+ }
+/* L120: */
+ }
+ }
+ }
+ return 0;
+
+/* End of ZLAPTM */
+
+} /* zlaptm_ */
diff --git a/TESTING/LIN/zlarhs.c b/TESTING/LIN/zlarhs.c
new file mode 100644
index 0000000..f301ffe
--- /dev/null
+++ b/TESTING/LIN/zlarhs.c
@@ -0,0 +1,442 @@
+/* zlarhs.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static doublecomplex c_b2 = {0.,0.};
+static integer c__2 = 2;
+static integer c__1 = 1;
+
+/* Subroutine */ int zlarhs_(char *path, char *xtype, char *uplo, char *trans,
+ integer *m, integer *n, integer *kl, integer *ku, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *x, integer *ldx,
+ doublecomplex *b, integer *ldb, integer *iseed, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j;
+ char c1[1], c2[2];
+ integer mb, nx;
+ logical gen, tri, qrs, sym, band;
+ char diag[1];
+ logical tran;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zhemm_(char *, char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zgbmv_(char *, integer *, integer *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zhbmv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zsbmv_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *), ztbmv_(char
+ *, char *, char *, integer *, integer *, doublecomplex *, integer
+ *, doublecomplex *, integer *), zhpmv_(
+ char *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), ztrmm_(char *, char *, char *, char *,
+ integer *, integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *),
+ zspmv_(char *, integer *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zsymm_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *), ztpmv_(char *, char *, char *, integer *, doublecomplex *
+, doublecomplex *, integer *), xerbla_(
+ char *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ logical notran;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlarnv_(integer *, integer *, integer *, doublecomplex *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLARHS chooses a set of NRHS random solution vectors and sets */
+/* up the right hand sides for the linear system */
+/* op( A ) * X = B, */
+/* where op( A ) may be A, A**T (transpose of A), or A**H (conjugate */
+/* transpose of A). */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The type of the complex matrix A. PATH may be given in any */
+/* combination of upper and lower case. Valid paths include */
+/* xGE: General m x n matrix */
+/* xGB: General banded matrix */
+/* xPO: Hermitian positive definite, 2-D storage */
+/* xPP: Hermitian positive definite packed */
+/* xPB: Hermitian positive definite banded */
+/* xHE: Hermitian indefinite, 2-D storage */
+/* xHP: Hermitian indefinite packed */
+/* xHB: Hermitian indefinite banded */
+/* xSY: Symmetric indefinite, 2-D storage */
+/* xSP: Symmetric indefinite packed */
+/* xSB: Symmetric indefinite banded */
+/* xTR: Triangular */
+/* xTP: Triangular packed */
+/* xTB: Triangular banded */
+/* xQR: General m x n matrix */
+/* xLQ: General m x n matrix */
+/* xQL: General m x n matrix */
+/* xRQ: General m x n matrix */
+/* where the leading character indicates the precision. */
+
+/* XTYPE (input) CHARACTER*1 */
+/* Specifies how the exact solution X will be determined: */
+/* = 'N': New solution; generate a random X. */
+/* = 'C': Computed; use value of X on entry. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Used only if A is symmetric or triangular; specifies whether */
+/* the upper or lower triangular part of the matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Used only if A is nonsymmetric; specifies the operation */
+/* applied to the matrix A. */
+/* = 'N': B := A * X */
+/* = 'T': B := A**T * X */
+/* = 'C': B := A**H * X */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* Used only if A is a band matrix; specifies the number of */
+/* subdiagonals of A if A is a general band matrix or if A is */
+/* symmetric or triangular and UPLO = 'L'; specifies the number */
+/* of superdiagonals of A if A is symmetric or triangular and */
+/* UPLO = 'U'. 0 <= KL <= M-1. */
+
+/* KU (input) INTEGER */
+/* Used only if A is a general band matrix or if A is */
+/* triangular. */
+
+/* If PATH = xGB, specifies the number of superdiagonals of A, */
+/* and 0 <= KU <= N-1. */
+
+/* If PATH = xTR, xTP, or xTB, specifies whether or not the */
+/* matrix has unit diagonal: */
+/* = 1: matrix has non-unit diagonal (default) */
+/* = 2: matrix has unit diagonal */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand side vectors in the system A*X = B. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The test matrix whose type is given by PATH. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+/* If PATH = xGB, LDA >= KL+KU+1. */
+/* If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1. */
+/* Otherwise, LDA >= max(1,M). */
+
+/* X (input or output) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* On entry, if XTYPE = 'C' (for 'Computed'), then X contains */
+/* the exact solution to the system of linear equations. */
+/* On exit, if XTYPE = 'N' (for 'New'), then X is initialized */
+/* with random values. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M). */
+
+/* B (output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side vector(s) for the system of equations, */
+/* computed from B = op(A) * X, where op(A) is determined by */
+/* TRANS. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. If TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N). */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* The seed vector for the random number generator (used in */
+/* ZLATMS). Modified on exit. */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --iseed;
+
+ /* Function Body */
+ *info = 0;
+ *(unsigned char *)c1 = *(unsigned char *)path;
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+ tran = lsame_(trans, "T") || lsame_(trans, "C");
+ notran = ! tran;
+ gen = lsame_(path + 1, "G");
+ qrs = lsame_(path + 1, "Q") || lsame_(path + 2,
+ "Q");
+ sym = lsame_(path + 1, "P") || lsame_(path + 1,
+ "S") || lsame_(path + 1, "H");
+ tri = lsame_(path + 1, "T");
+ band = lsame_(path + 2, "B");
+ if (! lsame_(c1, "Zomplex precision")) {
+ *info = -1;
+ } else if (! (lsame_(xtype, "N") || lsame_(xtype,
+ "C"))) {
+ *info = -2;
+ } else if ((sym || tri) && ! (lsame_(uplo, "U") ||
+ lsame_(uplo, "L"))) {
+ *info = -3;
+ } else if ((gen || qrs) && ! (tran || lsame_(trans, "N"))) {
+ *info = -4;
+ } else if (*m < 0) {
+ *info = -5;
+ } else if (*n < 0) {
+ *info = -6;
+ } else if (band && *kl < 0) {
+ *info = -7;
+ } else if (band && *ku < 0) {
+ *info = -8;
+ } else if (*nrhs < 0) {
+ *info = -9;
+ } else if (! band && *lda < max(1,*m) || band && (sym || tri) && *lda < *
+ kl + 1 || band && gen && *lda < *kl + *ku + 1) {
+ *info = -11;
+ } else if (notran && *ldx < max(1,*n) || tran && *ldx < max(1,*m)) {
+ *info = -13;
+ } else if (notran && *ldb < max(1,*m) || tran && *ldb < max(1,*n)) {
+ *info = -15;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLARHS", &i__1);
+ return 0;
+ }
+
+/* Initialize X to NRHS random vectors unless XTYPE = 'C'. */
+
+ if (tran) {
+ nx = *m;
+ mb = *n;
+ } else {
+ nx = *n;
+ mb = *m;
+ }
+ if (! lsame_(xtype, "C")) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ zlarnv_(&c__2, &iseed[1], n, &x[j * x_dim1 + 1]);
+/* L10: */
+ }
+ }
+
+/* Multiply X by op( A ) using an appropriate */
+/* matrix multiply routine. */
+
+ if (lsamen_(&c__2, c2, "GE") || lsamen_(&c__2, c2,
+ "QR") || lsamen_(&c__2, c2, "LQ") || lsamen_(&c__2, c2, "QL") ||
+ lsamen_(&c__2, c2, "RQ")) {
+
+/* General matrix */
+
+ zgemm_(trans, "N", &mb, nrhs, &nx, &c_b1, &a[a_offset], lda, &x[
+ x_offset], ldx, &c_b2, &b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "PO") || lsamen_(&
+ c__2, c2, "HE")) {
+
+/* Hermitian matrix, 2-D storage */
+
+ zhemm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset],
+ ldx, &c_b2, &b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "SY")) {
+
+/* Symmetric matrix, 2-D storage */
+
+ zsymm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset],
+ ldx, &c_b2, &b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* General matrix, band storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ zgbmv_(trans, m, n, kl, ku, &c_b1, &a[a_offset], lda, &x[j *
+ x_dim1 + 1], &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
+/* L20: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "PB") || lsamen_(&
+ c__2, c2, "HB")) {
+
+/* Hermitian matrix, band storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ zhbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1],
+ &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
+/* L30: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "SB")) {
+
+/* Symmetric matrix, band storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ zsbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1],
+ &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
+/* L40: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "PP") || lsamen_(&
+ c__2, c2, "HP")) {
+
+/* Hermitian matrix, packed storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ zhpmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
+ c_b2, &b[j * b_dim1 + 1], &c__1);
+/* L50: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "SP")) {
+
+/* Symmetric matrix, packed storage */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ zspmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
+ c_b2, &b[j * b_dim1 + 1], &c__1);
+/* L60: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "TR")) {
+
+/* Triangular matrix. Note that for triangular matrices, */
+/* KU = 1 => non-unit triangular */
+/* KU = 2 => unit triangular */
+
+ zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ ztrmm_("Left", uplo, trans, diag, n, nrhs, &c_b1, &a[a_offset], lda, &
+ b[b_offset], ldb);
+
+ } else if (lsamen_(&c__2, c2, "TP")) {
+
+/* Triangular matrix, packed storage */
+
+ zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ztpmv_(uplo, trans, diag, n, &a[a_offset], &b[j * b_dim1 + 1], &
+ c__1);
+/* L70: */
+ }
+
+ } else if (lsamen_(&c__2, c2, "TB")) {
+
+/* Triangular matrix, banded storage */
+
+ zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
+ if (*ku == 2) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ ztbmv_(uplo, trans, diag, n, kl, &a[a_offset], lda, &b[j * b_dim1
+ + 1], &c__1);
+/* L80: */
+ }
+
+ } else {
+
+/* If none of the above, set INFO = -1 and return */
+
+ *info = -1;
+ i__1 = -(*info);
+ xerbla_("ZLARHS", &i__1);
+ }
+
+ return 0;
+
+/* End of ZLARHS */
+
+} /* zlarhs_ */
diff --git a/TESTING/LIN/zlatb4.c b/TESTING/LIN/zlatb4.c
new file mode 100644
index 0000000..22d212d
--- /dev/null
+++ b/TESTING/LIN/zlatb4.c
@@ -0,0 +1,482 @@
+/* zlatb4.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+
+/* Subroutine */ int zlatb4_(char *path, integer *imat, integer *m, integer *
+ n, char *type__, integer *kl, integer *ku, doublereal *anorm, integer
+ *mode, doublereal *cndnum, char *dist)
+{
+ /* Initialized data */
+
+ static logical first = TRUE_;
+
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ char c2[2];
+ integer mat;
+ static doublereal eps, badc1, badc2, large, small;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern logical lsamen_(integer *, char *, char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLATB4 sets parameters for the matrix generator based on the type of */
+/* matrix to be generated. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name. */
+
+/* IMAT (input) INTEGER */
+/* An integer key describing which matrix to generate for this */
+/* path. */
+
+/* M (input) INTEGER */
+/* The number of rows in the matrix to be generated. */
+
+/* N (input) INTEGER */
+/* The number of columns in the matrix to be generated. */
+
+/* TYPE (output) CHARACTER*1 */
+/* The type of the matrix to be generated: */
+/* = 'S': symmetric matrix */
+/* = 'P': symmetric positive (semi)definite matrix */
+/* = 'N': nonsymmetric matrix */
+
+/* KL (output) INTEGER */
+/* The lower band width of the matrix to be generated. */
+
+/* KU (output) INTEGER */
+/* The upper band width of the matrix to be generated. */
+
+/* ANORM (output) DOUBLE PRECISION */
+/* The desired norm of the matrix to be generated. The diagonal */
+/* matrix of singular values or eigenvalues is scaled by this */
+/* value. */
+
+/* MODE (output) INTEGER */
+/* A key indicating how to choose the vector of eigenvalues. */
+
+/* CNDNUM (output) DOUBLE PRECISION */
+/* The desired condition number. */
+
+/* DIST (output) CHARACTER*1 */
+/* The type of distribution to be used by the random number */
+/* generator. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Set some constants for use in the subroutine. */
+
+ if (first) {
+ first = FALSE_;
+ eps = dlamch_("Precision");
+ badc2 = .1 / eps;
+ badc1 = sqrt(badc2);
+ small = dlamch_("Safe minimum");
+ large = 1. / small;
+
+/* If it looks like we're on a Cray, take the square root of */
+/* SMALL and LARGE to avoid overflow and underflow problems. */
+
+ dlabad_(&small, &large);
+ small = small / eps * .25;
+ large = 1. / small;
+ }
+
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set some parameters we don't plan to change. */
+
+ *(unsigned char *)dist = 'S';
+ *mode = 3;
+
+/* xQR, xLQ, xQL, xRQ: Set parameters to generate a general */
+/* M x N matrix. */
+
+ if (lsamen_(&c__2, c2, "QR") || lsamen_(&c__2, c2,
+ "LQ") || lsamen_(&c__2, c2, "QL") || lsamen_(&c__2, c2, "RQ")) {
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the lower and upper bandwidths. */
+
+ if (*imat == 1) {
+ *kl = 0;
+ *ku = 0;
+ } else if (*imat == 2) {
+ *kl = 0;
+/* Computing MAX */
+ i__1 = *n - 1;
+ *ku = max(i__1,0);
+ } else if (*imat == 3) {
+/* Computing MAX */
+ i__1 = *m - 1;
+ *kl = max(i__1,0);
+ *ku = 0;
+ } else {
+/* Computing MAX */
+ i__1 = *m - 1;
+ *kl = max(i__1,0);
+/* Computing MAX */
+ i__1 = *n - 1;
+ *ku = max(i__1,0);
+ }
+
+/* Set the condition number and norm. */
+
+ if (*imat == 5) {
+ *cndnum = badc1;
+ } else if (*imat == 6) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.;
+ }
+
+ if (*imat == 7) {
+ *anorm = small;
+ } else if (*imat == 8) {
+ *anorm = large;
+ } else {
+ *anorm = 1.;
+ }
+
+ } else if (lsamen_(&c__2, c2, "GE")) {
+
+/* xGE: Set parameters to generate a general M x N matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the lower and upper bandwidths. */
+
+ if (*imat == 1) {
+ *kl = 0;
+ *ku = 0;
+ } else if (*imat == 2) {
+ *kl = 0;
+/* Computing MAX */
+ i__1 = *n - 1;
+ *ku = max(i__1,0);
+ } else if (*imat == 3) {
+/* Computing MAX */
+ i__1 = *m - 1;
+ *kl = max(i__1,0);
+ *ku = 0;
+ } else {
+/* Computing MAX */
+ i__1 = *m - 1;
+ *kl = max(i__1,0);
+/* Computing MAX */
+ i__1 = *n - 1;
+ *ku = max(i__1,0);
+ }
+
+/* Set the condition number and norm. */
+
+ if (*imat == 8) {
+ *cndnum = badc1;
+ } else if (*imat == 9) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.;
+ }
+
+ if (*imat == 10) {
+ *anorm = small;
+ } else if (*imat == 11) {
+ *anorm = large;
+ } else {
+ *anorm = 1.;
+ }
+
+ } else if (lsamen_(&c__2, c2, "GB")) {
+
+/* xGB: Set parameters to generate a general banded matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the condition number and norm. */
+
+ if (*imat == 5) {
+ *cndnum = badc1;
+ } else if (*imat == 6) {
+ *cndnum = badc2 * .1;
+ } else {
+ *cndnum = 2.;
+ }
+
+ if (*imat == 7) {
+ *anorm = small;
+ } else if (*imat == 8) {
+ *anorm = large;
+ } else {
+ *anorm = 1.;
+ }
+
+ } else if (lsamen_(&c__2, c2, "GT")) {
+
+/* xGT: Set parameters to generate a general tridiagonal matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the lower and upper bandwidths. */
+
+ if (*imat == 1) {
+ *kl = 0;
+ } else {
+ *kl = 1;
+ }
+ *ku = *kl;
+
+/* Set the condition number and norm. */
+
+ if (*imat == 3) {
+ *cndnum = badc1;
+ } else if (*imat == 4) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.;
+ }
+
+ if (*imat == 5 || *imat == 11) {
+ *anorm = small;
+ } else if (*imat == 6 || *imat == 12) {
+ *anorm = large;
+ } else {
+ *anorm = 1.;
+ }
+
+ } else if (lsamen_(&c__2, c2, "PO") || lsamen_(&
+ c__2, c2, "PP") || lsamen_(&c__2, c2, "HE") || lsamen_(&c__2, c2, "HP") || lsamen_(&c__2, c2, "SY") ||
+ lsamen_(&c__2, c2, "SP")) {
+
+/* xPO, xPP, xHE, xHP, xSY, xSP: Set parameters to generate a */
+/* symmetric or Hermitian matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = *(unsigned char *)c2;
+
+/* Set the lower and upper bandwidths. */
+
+ if (*imat == 1) {
+ *kl = 0;
+ } else {
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kl = max(i__1,0);
+ }
+ *ku = *kl;
+
+/* Set the condition number and norm. */
+
+ if (*imat == 6) {
+ *cndnum = badc1;
+ } else if (*imat == 7) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.;
+ }
+
+ if (*imat == 8) {
+ *anorm = small;
+ } else if (*imat == 9) {
+ *anorm = large;
+ } else {
+ *anorm = 1.;
+ }
+
+ } else if (lsamen_(&c__2, c2, "PB")) {
+
+/* xPB: Set parameters to generate a symmetric band matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'P';
+
+/* Set the norm and condition number. */
+
+ if (*imat == 5) {
+ *cndnum = badc1;
+ } else if (*imat == 6) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.;
+ }
+
+ if (*imat == 7) {
+ *anorm = small;
+ } else if (*imat == 8) {
+ *anorm = large;
+ } else {
+ *anorm = 1.;
+ }
+
+ } else if (lsamen_(&c__2, c2, "PT")) {
+
+/* xPT: Set parameters to generate a symmetric positive definite */
+/* tridiagonal matrix. */
+
+ *(unsigned char *)type__ = 'P';
+ if (*imat == 1) {
+ *kl = 0;
+ } else {
+ *kl = 1;
+ }
+ *ku = *kl;
+
+/* Set the condition number and norm. */
+
+ if (*imat == 3) {
+ *cndnum = badc1;
+ } else if (*imat == 4) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.;
+ }
+
+ if (*imat == 5 || *imat == 11) {
+ *anorm = small;
+ } else if (*imat == 6 || *imat == 12) {
+ *anorm = large;
+ } else {
+ *anorm = 1.;
+ }
+
+ } else if (lsamen_(&c__2, c2, "TR") || lsamen_(&
+ c__2, c2, "TP")) {
+
+/* xTR, xTP: Set parameters to generate a triangular matrix */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the lower and upper bandwidths. */
+
+ mat = abs(*imat);
+ if (mat == 1 || mat == 7) {
+ *kl = 0;
+ *ku = 0;
+ } else if (*imat < 0) {
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kl = max(i__1,0);
+ *ku = 0;
+ } else {
+ *kl = 0;
+/* Computing MAX */
+ i__1 = *n - 1;
+ *ku = max(i__1,0);
+ }
+
+/* Set the condition number and norm. */
+
+ if (mat == 3 || mat == 9) {
+ *cndnum = badc1;
+ } else if (mat == 4 || mat == 10) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.;
+ }
+
+ if (mat == 5) {
+ *anorm = small;
+ } else if (mat == 6) {
+ *anorm = large;
+ } else {
+ *anorm = 1.;
+ }
+
+ } else if (lsamen_(&c__2, c2, "TB")) {
+
+/* xTB: Set parameters to generate a triangular band matrix. */
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = 'N';
+
+/* Set the norm and condition number. */
+
+ if (*imat == 2 || *imat == 8) {
+ *cndnum = badc1;
+ } else if (*imat == 3 || *imat == 9) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.;
+ }
+
+ if (*imat == 4) {
+ *anorm = small;
+ } else if (*imat == 5) {
+ *anorm = large;
+ } else {
+ *anorm = 1.;
+ }
+ }
+ if (*n <= 1) {
+ *cndnum = 1.;
+ }
+
+ return 0;
+
+/* End of ZLATB4 */
+
+} /* zlatb4_ */
diff --git a/TESTING/LIN/zlatb5.c b/TESTING/LIN/zlatb5.c
new file mode 100644
index 0000000..6890659
--- /dev/null
+++ b/TESTING/LIN/zlatb5.c
@@ -0,0 +1,184 @@
+/* zlatb5.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zlatb5_(char *path, integer *imat, integer *n, char *
+ type__, integer *kl, integer *ku, doublereal *anorm, integer *mode,
+ doublereal *cndnum, char *dist)
+{
+ /* Initialized data */
+
+ static logical first = TRUE_;
+
+ /* System generated locals */
+ integer i__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ char c2[2];
+ static doublereal eps, badc1, badc2, large, small;
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLATB5 sets parameters for the matrix generator based on the type */
+/* of matrix to be generated. */
+
+/* Arguments */
+/* ========= */
+
+/* PATH (input) CHARACTER*3 */
+/* The LAPACK path name. */
+
+/* IMAT (input) INTEGER */
+/* An integer key describing which matrix to generate for this */
+/* path. */
+
+/* N (input) INTEGER */
+/* The number of rows and columns in the matrix to be generated. */
+
+/* TYPE (output) CHARACTER*1 */
+/* The type of the matrix to be generated: */
+/* = 'S': symmetric matrix */
+/* = 'P': symmetric positive (semi)definite matrix */
+/* = 'N': nonsymmetric matrix */
+
+/* KL (output) INTEGER */
+/* The lower band width of the matrix to be generated. */
+
+/* KU (output) INTEGER */
+/* The upper band width of the matrix to be generated. */
+
+/* ANORM (output) DOUBLE PRECISION */
+/* The desired norm of the matrix to be generated. The diagonal */
+/* matrix of singular values or eigenvalues is scaled by this */
+/* value. */
+
+/* MODE (output) INTEGER */
+/* A key indicating how to choose the vector of eigenvalues. */
+
+/* CNDNUM (output) DOUBLE PRECISION */
+/* The desired condition number. */
+
+/* DIST (output) CHARACTER*1 */
+/* The type of distribution to be used by the random number */
+/* generator. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Save statement .. */
+/* .. */
+/* .. Data statements .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Set some constants for use in the subroutine. */
+
+ if (first) {
+ first = FALSE_;
+ eps = dlamch_("Precision");
+ badc2 = .1 / eps;
+ badc1 = sqrt(badc2);
+ small = dlamch_("Safe minimum");
+ large = 1. / small;
+
+/* If it looks like we're on a Cray, take the square root of */
+/* SMALL and LARGE to avoid overflow and underflow problems. */
+
+ dlabad_(&small, &large);
+ small = small / eps * .25;
+ large = 1. / small;
+ }
+
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Set some parameters */
+
+ *(unsigned char *)dist = 'S';
+ *mode = 3;
+
+/* Set TYPE, the type of matrix to be generated. */
+
+ *(unsigned char *)type__ = *(unsigned char *)c2;
+
+/* Set the lower and upper bandwidths. */
+
+ if (*imat == 1) {
+ *kl = 0;
+ } else {
+/* Computing MAX */
+ i__1 = *n - 1;
+ *kl = max(i__1,0);
+ }
+ *ku = *kl;
+
+/* Set the condition number and norm.etc */
+
+ if (*imat == 3) {
+ *cndnum = 1e12;
+ *mode = 2;
+ } else if (*imat == 4) {
+ *cndnum = 1e12;
+ *mode = 1;
+ } else if (*imat == 5) {
+ *cndnum = 1e12;
+ *mode = 3;
+ } else if (*imat == 6) {
+ *cndnum = badc1;
+ } else if (*imat == 7) {
+ *cndnum = badc2;
+ } else {
+ *cndnum = 2.;
+ }
+
+ if (*imat == 8) {
+ *anorm = small;
+ } else if (*imat == 9) {
+ *anorm = large;
+ } else {
+ *anorm = 1.;
+ }
+
+ if (*n <= 1) {
+ *cndnum = 1.;
+ }
+
+ return 0;
+
+/* End of ZLATB5 */
+
+} /* zlatb5_ */
diff --git a/TESTING/LIN/zlatsp.c b/TESTING/LIN/zlatsp.c
new file mode 100644
index 0000000..d48eebf
--- /dev/null
+++ b/TESTING/LIN/zlatsp.c
@@ -0,0 +1,358 @@
+/* zlatsp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__5 = 5;
+static integer c__2 = 2;
+
+/* Subroutine */ int zlatsp_(char *uplo, integer *n, doublecomplex *x,
+ integer *iseed)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal), z_abs(doublecomplex *);
+
+ /* Local variables */
+ doublecomplex a, b, c__;
+ integer j;
+ doublecomplex r__;
+ integer n5, jj;
+ doublereal beta, alpha, alpha3;
+ extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
+ integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLATSP generates a special test matrix for the complex symmetric */
+/* (indefinite) factorization for packed matrices. The pivot blocks of */
+/* the generated matrix will be in the following order: */
+/* 2x2 pivot block, non diagonalizable */
+/* 1x1 pivot block */
+/* 2x2 pivot block, diagonalizable */
+/* (cycle repeats) */
+/* A row interchange is required for each non-diagonalizable 2x2 block. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER */
+/* Specifies whether the generated matrix is to be upper or */
+/* lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The dimension of the matrix to be generated. */
+
+/* X (output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The generated matrix in packed storage format. The matrix */
+/* consists of 3x3 and 2x2 diagonal blocks which result in the */
+/* pivot sequence given above. The matrix outside these */
+/* diagonal blocks is zero. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed for the random number generator. The last */
+/* of the four integers must be odd. (modified on exit) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants */
+
+ /* Parameter adjustments */
+ --iseed;
+ --x;
+
+ /* Function Body */
+ alpha = (sqrt(17.) + 1.) / 8.;
+ beta = alpha - .001;
+ alpha3 = alpha * alpha * alpha;
+
+/* Fill the matrix with zeros. */
+
+ i__1 = *n * (*n + 1) / 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ x[i__2].r = 0., x[i__2].i = 0.;
+/* L10: */
+ }
+
+/* UPLO = 'U': Upper triangular storage */
+
+ if (*(unsigned char *)uplo == 'U') {
+ n5 = *n / 5;
+ n5 = *n - n5 * 5 + 1;
+
+ jj = *n * (*n + 1) / 2;
+ i__1 = n5;
+ for (j = *n; j >= i__1; j += -5) {
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = alpha3 * z__2.r, z__1.i = alpha3 * z__2.i;
+ a.r = z__1.r, a.i = z__1.i;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = z__2.r / alpha, z__1.i = z__2.i / alpha;
+ b.r = z__1.r, b.i = z__1.i;
+ z__3.r = b.r * 2., z__3.i = b.i * 2.;
+ z__2.r = z__3.r * 0. - z__3.i * 1., z__2.i = z__3.r * 1. + z__3.i
+ * 0.;
+ z__1.r = a.r - z__2.r, z__1.i = a.i - z__2.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__1.r = c__.r / beta, z__1.i = c__.i / beta;
+ r__.r = z__1.r, r__.i = z__1.i;
+ i__2 = jj;
+ x[i__2].r = a.r, x[i__2].i = a.i;
+ i__2 = jj - 2;
+ x[i__2].r = b.r, x[i__2].i = b.i;
+ jj -= j;
+ i__2 = jj;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ i__2 = jj - 1;
+ x[i__2].r = r__.r, x[i__2].i = r__.i;
+ jj -= j - 1;
+ i__2 = jj;
+ x[i__2].r = c__.r, x[i__2].i = c__.i;
+ jj -= j - 2;
+ i__2 = jj;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ jj -= j - 3;
+ i__2 = jj;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ if (z_abs(&x[jj + (j - 3)]) > z_abs(&x[jj])) {
+ i__2 = jj + (j - 4);
+ i__3 = jj + (j - 3);
+ z__1.r = x[i__3].r * 2., z__1.i = x[i__3].i * 2.;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ } else {
+ i__2 = jj + (j - 4);
+ i__3 = jj;
+ z__1.r = x[i__3].r * 2., z__1.i = x[i__3].i * 2.;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ }
+ jj -= j - 4;
+/* L20: */
+ }
+
+/* Clean-up for N not a multiple of 5. */
+
+ j = n5 - 1;
+ if (j > 2) {
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = alpha3 * z__2.r, z__1.i = alpha3 * z__2.i;
+ a.r = z__1.r, a.i = z__1.i;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = z__2.r / alpha, z__1.i = z__2.i / alpha;
+ b.r = z__1.r, b.i = z__1.i;
+ z__3.r = b.r * 2., z__3.i = b.i * 2.;
+ z__2.r = z__3.r * 0. - z__3.i * 1., z__2.i = z__3.r * 1. + z__3.i
+ * 0.;
+ z__1.r = a.r - z__2.r, z__1.i = a.i - z__2.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__1.r = c__.r / beta, z__1.i = c__.i / beta;
+ r__.r = z__1.r, r__.i = z__1.i;
+ i__1 = jj;
+ x[i__1].r = a.r, x[i__1].i = a.i;
+ i__1 = jj - 2;
+ x[i__1].r = b.r, x[i__1].i = b.i;
+ jj -= j;
+ i__1 = jj;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ i__1 = jj - 1;
+ x[i__1].r = r__.r, x[i__1].i = r__.i;
+ jj -= j - 1;
+ i__1 = jj;
+ x[i__1].r = c__.r, x[i__1].i = c__.i;
+ jj -= j - 2;
+ j += -3;
+ }
+ if (j > 1) {
+ i__1 = jj;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ i__1 = jj - j;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ if (z_abs(&x[jj]) > z_abs(&x[jj - j])) {
+ i__1 = jj - 1;
+ i__2 = jj;
+ z__1.r = x[i__2].r * 2., z__1.i = x[i__2].i * 2.;
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ } else {
+ i__1 = jj - 1;
+ i__2 = jj - j;
+ z__1.r = x[i__2].r * 2., z__1.i = x[i__2].i * 2.;
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ }
+ jj = jj - j - (j - 1);
+ j += -2;
+ } else if (j == 1) {
+ i__1 = jj;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ --j;
+ }
+
+/* UPLO = 'L': Lower triangular storage */
+
+ } else {
+ n5 = *n / 5;
+ n5 *= 5;
+
+ jj = 1;
+ i__1 = n5;
+ for (j = 1; j <= i__1; j += 5) {
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = alpha3 * z__2.r, z__1.i = alpha3 * z__2.i;
+ a.r = z__1.r, a.i = z__1.i;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = z__2.r / alpha, z__1.i = z__2.i / alpha;
+ b.r = z__1.r, b.i = z__1.i;
+ z__3.r = b.r * 2., z__3.i = b.i * 2.;
+ z__2.r = z__3.r * 0. - z__3.i * 1., z__2.i = z__3.r * 1. + z__3.i
+ * 0.;
+ z__1.r = a.r - z__2.r, z__1.i = a.i - z__2.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__1.r = c__.r / beta, z__1.i = c__.i / beta;
+ r__.r = z__1.r, r__.i = z__1.i;
+ i__2 = jj;
+ x[i__2].r = a.r, x[i__2].i = a.i;
+ i__2 = jj + 2;
+ x[i__2].r = b.r, x[i__2].i = b.i;
+ jj += *n - j + 1;
+ i__2 = jj;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ i__2 = jj + 1;
+ x[i__2].r = r__.r, x[i__2].i = r__.i;
+ jj += *n - j;
+ i__2 = jj;
+ x[i__2].r = c__.r, x[i__2].i = c__.i;
+ jj += *n - j - 1;
+ i__2 = jj;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ jj += *n - j - 2;
+ i__2 = jj;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ if (z_abs(&x[jj - (*n - j - 2)]) > z_abs(&x[jj])) {
+ i__2 = jj - (*n - j - 2) + 1;
+ i__3 = jj - (*n - j - 2);
+ z__1.r = x[i__3].r * 2., z__1.i = x[i__3].i * 2.;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ } else {
+ i__2 = jj - (*n - j - 2) + 1;
+ i__3 = jj;
+ z__1.r = x[i__3].r * 2., z__1.i = x[i__3].i * 2.;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ }
+ jj += *n - j - 3;
+/* L30: */
+ }
+
+/* Clean-up for N not a multiple of 5. */
+
+ j = n5 + 1;
+ if (j < *n - 1) {
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = alpha3 * z__2.r, z__1.i = alpha3 * z__2.i;
+ a.r = z__1.r, a.i = z__1.i;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = z__2.r / alpha, z__1.i = z__2.i / alpha;
+ b.r = z__1.r, b.i = z__1.i;
+ z__3.r = b.r * 2., z__3.i = b.i * 2.;
+ z__2.r = z__3.r * 0. - z__3.i * 1., z__2.i = z__3.r * 1. + z__3.i
+ * 0.;
+ z__1.r = a.r - z__2.r, z__1.i = a.i - z__2.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__1.r = c__.r / beta, z__1.i = c__.i / beta;
+ r__.r = z__1.r, r__.i = z__1.i;
+ i__1 = jj;
+ x[i__1].r = a.r, x[i__1].i = a.i;
+ i__1 = jj + 2;
+ x[i__1].r = b.r, x[i__1].i = b.i;
+ jj += *n - j + 1;
+ i__1 = jj;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ i__1 = jj + 1;
+ x[i__1].r = r__.r, x[i__1].i = r__.i;
+ jj += *n - j;
+ i__1 = jj;
+ x[i__1].r = c__.r, x[i__1].i = c__.i;
+ jj += *n - j - 1;
+ j += 3;
+ }
+ if (j < *n) {
+ i__1 = jj;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ i__1 = jj + (*n - j + 1);
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ if (z_abs(&x[jj]) > z_abs(&x[jj + (*n - j + 1)])) {
+ i__1 = jj + 1;
+ i__2 = jj;
+ z__1.r = x[i__2].r * 2., z__1.i = x[i__2].i * 2.;
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ } else {
+ i__1 = jj + 1;
+ i__2 = jj + (*n - j + 1);
+ z__1.r = x[i__2].r * 2., z__1.i = x[i__2].i * 2.;
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ }
+ jj = jj + (*n - j + 1) + (*n - j);
+ j += 2;
+ } else if (j == *n) {
+ i__1 = jj;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ jj += *n - j + 1;
+ ++j;
+ }
+ }
+
+ return 0;
+
+/* End of ZLATSP */
+
+} /* zlatsp_ */
diff --git a/TESTING/LIN/zlatsy.c b/TESTING/LIN/zlatsy.c
new file mode 100644
index 0000000..871ce19
--- /dev/null
+++ b/TESTING/LIN/zlatsy.c
@@ -0,0 +1,362 @@
+/* zlatsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__5 = 5;
+static integer c__2 = 2;
+
+/* Subroutine */ int zlatsy_(char *uplo, integer *n, doublecomplex *x,
+ integer *ldx, integer *iseed)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, i__1, i__2, i__3;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ double sqrt(doublereal), z_abs(doublecomplex *);
+
+ /* Local variables */
+ doublecomplex a, b, c__;
+ integer i__, j;
+ doublecomplex r__;
+ integer n5;
+ doublereal beta, alpha, alpha3;
+ extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
+ integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLATSY generates a special test matrix for the complex symmetric */
+/* (indefinite) factorization. The pivot blocks of the generated matrix */
+/* will be in the following order: */
+/* 2x2 pivot block, non diagonalizable */
+/* 1x1 pivot block */
+/* 2x2 pivot block, diagonalizable */
+/* (cycle repeats) */
+/* A row interchange is required for each non-diagonalizable 2x2 block. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER */
+/* Specifies whether the generated matrix is to be upper or */
+/* lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The dimension of the matrix to be generated. */
+
+/* X (output) COMPLEX*16 array, dimension (LDX,N) */
+/* The generated matrix, consisting of 3x3 and 2x2 diagonal */
+/* blocks which result in the pivot sequence given above. */
+/* The matrix outside of these diagonal blocks is zero. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed for the random number generator. The last */
+/* of the four integers must be odd. (modified on exit) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize constants */
+
+ /* Parameter adjustments */
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --iseed;
+
+ /* Function Body */
+ alpha = (sqrt(17.) + 1.) / 8.;
+ beta = alpha - .001;
+ alpha3 = alpha * alpha * alpha;
+
+/* UPLO = 'U': Upper triangular storage */
+
+ if (*(unsigned char *)uplo == 'U') {
+
+/* Fill the upper triangle of the matrix with zeros. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ x[i__3].r = 0., x[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ n5 = *n / 5;
+ n5 = *n - n5 * 5 + 1;
+
+ i__1 = n5;
+ for (i__ = *n; i__ >= i__1; i__ += -5) {
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = alpha3 * z__2.r, z__1.i = alpha3 * z__2.i;
+ a.r = z__1.r, a.i = z__1.i;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = z__2.r / alpha, z__1.i = z__2.i / alpha;
+ b.r = z__1.r, b.i = z__1.i;
+ z__3.r = b.r * 2., z__3.i = b.i * 2.;
+ z__2.r = z__3.r * 0. - z__3.i * 1., z__2.i = z__3.r * 1. + z__3.i
+ * 0.;
+ z__1.r = a.r - z__2.r, z__1.i = a.i - z__2.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__1.r = c__.r / beta, z__1.i = c__.i / beta;
+ r__.r = z__1.r, r__.i = z__1.i;
+ i__2 = i__ + i__ * x_dim1;
+ x[i__2].r = a.r, x[i__2].i = a.i;
+ i__2 = i__ - 2 + i__ * x_dim1;
+ x[i__2].r = b.r, x[i__2].i = b.i;
+ i__2 = i__ - 2 + (i__ - 1) * x_dim1;
+ x[i__2].r = r__.r, x[i__2].i = r__.i;
+ i__2 = i__ - 2 + (i__ - 2) * x_dim1;
+ x[i__2].r = c__.r, x[i__2].i = c__.i;
+ i__2 = i__ - 1 + (i__ - 1) * x_dim1;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ i__2 = i__ - 3 + (i__ - 3) * x_dim1;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ i__2 = i__ - 4 + (i__ - 4) * x_dim1;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ if (z_abs(&x[i__ - 3 + (i__ - 3) * x_dim1]) > z_abs(&x[i__ - 4 + (
+ i__ - 4) * x_dim1])) {
+ i__2 = i__ - 4 + (i__ - 3) * x_dim1;
+ i__3 = i__ - 3 + (i__ - 3) * x_dim1;
+ z__1.r = x[i__3].r * 2., z__1.i = x[i__3].i * 2.;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ } else {
+ i__2 = i__ - 4 + (i__ - 3) * x_dim1;
+ i__3 = i__ - 4 + (i__ - 4) * x_dim1;
+ z__1.r = x[i__3].r * 2., z__1.i = x[i__3].i * 2.;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ }
+/* L30: */
+ }
+
+/* Clean-up for N not a multiple of 5. */
+
+ i__ = n5 - 1;
+ if (i__ > 2) {
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = alpha3 * z__2.r, z__1.i = alpha3 * z__2.i;
+ a.r = z__1.r, a.i = z__1.i;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = z__2.r / alpha, z__1.i = z__2.i / alpha;
+ b.r = z__1.r, b.i = z__1.i;
+ z__3.r = b.r * 2., z__3.i = b.i * 2.;
+ z__2.r = z__3.r * 0. - z__3.i * 1., z__2.i = z__3.r * 1. + z__3.i
+ * 0.;
+ z__1.r = a.r - z__2.r, z__1.i = a.i - z__2.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__1.r = c__.r / beta, z__1.i = c__.i / beta;
+ r__.r = z__1.r, r__.i = z__1.i;
+ i__1 = i__ + i__ * x_dim1;
+ x[i__1].r = a.r, x[i__1].i = a.i;
+ i__1 = i__ - 2 + i__ * x_dim1;
+ x[i__1].r = b.r, x[i__1].i = b.i;
+ i__1 = i__ - 2 + (i__ - 1) * x_dim1;
+ x[i__1].r = r__.r, x[i__1].i = r__.i;
+ i__1 = i__ - 2 + (i__ - 2) * x_dim1;
+ x[i__1].r = c__.r, x[i__1].i = c__.i;
+ i__1 = i__ - 1 + (i__ - 1) * x_dim1;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ i__ += -3;
+ }
+ if (i__ > 1) {
+ i__1 = i__ + i__ * x_dim1;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ i__1 = i__ - 1 + (i__ - 1) * x_dim1;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ if (z_abs(&x[i__ + i__ * x_dim1]) > z_abs(&x[i__ - 1 + (i__ - 1) *
+ x_dim1])) {
+ i__1 = i__ - 1 + i__ * x_dim1;
+ i__2 = i__ + i__ * x_dim1;
+ z__1.r = x[i__2].r * 2., z__1.i = x[i__2].i * 2.;
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ } else {
+ i__1 = i__ - 1 + i__ * x_dim1;
+ i__2 = i__ - 1 + (i__ - 1) * x_dim1;
+ z__1.r = x[i__2].r * 2., z__1.i = x[i__2].i * 2.;
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ }
+ i__ += -2;
+ } else if (i__ == 1) {
+ i__1 = i__ + i__ * x_dim1;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ --i__;
+ }
+
+/* UPLO = 'L': Lower triangular storage */
+
+ } else {
+
+/* Fill the lower triangle of the matrix with zeros. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ x[i__3].r = 0., x[i__3].i = 0.;
+/* L40: */
+ }
+/* L50: */
+ }
+ n5 = *n / 5;
+ n5 *= 5;
+
+ i__1 = n5;
+ for (i__ = 1; i__ <= i__1; i__ += 5) {
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = alpha3 * z__2.r, z__1.i = alpha3 * z__2.i;
+ a.r = z__1.r, a.i = z__1.i;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = z__2.r / alpha, z__1.i = z__2.i / alpha;
+ b.r = z__1.r, b.i = z__1.i;
+ z__3.r = b.r * 2., z__3.i = b.i * 2.;
+ z__2.r = z__3.r * 0. - z__3.i * 1., z__2.i = z__3.r * 1. + z__3.i
+ * 0.;
+ z__1.r = a.r - z__2.r, z__1.i = a.i - z__2.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__1.r = c__.r / beta, z__1.i = c__.i / beta;
+ r__.r = z__1.r, r__.i = z__1.i;
+ i__2 = i__ + i__ * x_dim1;
+ x[i__2].r = a.r, x[i__2].i = a.i;
+ i__2 = i__ + 2 + i__ * x_dim1;
+ x[i__2].r = b.r, x[i__2].i = b.i;
+ i__2 = i__ + 2 + (i__ + 1) * x_dim1;
+ x[i__2].r = r__.r, x[i__2].i = r__.i;
+ i__2 = i__ + 2 + (i__ + 2) * x_dim1;
+ x[i__2].r = c__.r, x[i__2].i = c__.i;
+ i__2 = i__ + 1 + (i__ + 1) * x_dim1;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ i__2 = i__ + 3 + (i__ + 3) * x_dim1;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ i__2 = i__ + 4 + (i__ + 4) * x_dim1;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ if (z_abs(&x[i__ + 3 + (i__ + 3) * x_dim1]) > z_abs(&x[i__ + 4 + (
+ i__ + 4) * x_dim1])) {
+ i__2 = i__ + 4 + (i__ + 3) * x_dim1;
+ i__3 = i__ + 3 + (i__ + 3) * x_dim1;
+ z__1.r = x[i__3].r * 2., z__1.i = x[i__3].i * 2.;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ } else {
+ i__2 = i__ + 4 + (i__ + 3) * x_dim1;
+ i__3 = i__ + 4 + (i__ + 4) * x_dim1;
+ z__1.r = x[i__3].r * 2., z__1.i = x[i__3].i * 2.;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ }
+/* L60: */
+ }
+
+/* Clean-up for N not a multiple of 5. */
+
+ i__ = n5 + 1;
+ if (i__ < *n - 1) {
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = alpha3 * z__2.r, z__1.i = alpha3 * z__2.i;
+ a.r = z__1.r, a.i = z__1.i;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = z__2.r / alpha, z__1.i = z__2.i / alpha;
+ b.r = z__1.r, b.i = z__1.i;
+ z__3.r = b.r * 2., z__3.i = b.i * 2.;
+ z__2.r = z__3.r * 0. - z__3.i * 1., z__2.i = z__3.r * 1. + z__3.i
+ * 0.;
+ z__1.r = a.r - z__2.r, z__1.i = a.i - z__2.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__1.r = c__.r / beta, z__1.i = c__.i / beta;
+ r__.r = z__1.r, r__.i = z__1.i;
+ i__1 = i__ + i__ * x_dim1;
+ x[i__1].r = a.r, x[i__1].i = a.i;
+ i__1 = i__ + 2 + i__ * x_dim1;
+ x[i__1].r = b.r, x[i__1].i = b.i;
+ i__1 = i__ + 2 + (i__ + 1) * x_dim1;
+ x[i__1].r = r__.r, x[i__1].i = r__.i;
+ i__1 = i__ + 2 + (i__ + 2) * x_dim1;
+ x[i__1].r = c__.r, x[i__1].i = c__.i;
+ i__1 = i__ + 1 + (i__ + 1) * x_dim1;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ i__ += 3;
+ }
+ if (i__ < *n) {
+ i__1 = i__ + i__ * x_dim1;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ i__1 = i__ + 1 + (i__ + 1) * x_dim1;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ if (z_abs(&x[i__ + i__ * x_dim1]) > z_abs(&x[i__ + 1 + (i__ + 1) *
+ x_dim1])) {
+ i__1 = i__ + 1 + i__ * x_dim1;
+ i__2 = i__ + i__ * x_dim1;
+ z__1.r = x[i__2].r * 2., z__1.i = x[i__2].i * 2.;
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ } else {
+ i__1 = i__ + 1 + i__ * x_dim1;
+ i__2 = i__ + 1 + (i__ + 1) * x_dim1;
+ z__1.r = x[i__2].r * 2., z__1.i = x[i__2].i * 2.;
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ }
+ i__ += 2;
+ } else if (i__ == *n) {
+ i__1 = i__ + i__ * x_dim1;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ ++i__;
+ }
+ }
+
+ return 0;
+
+/* End of ZLATSY */
+
+} /* zlatsy_ */
diff --git a/TESTING/LIN/zlattb.c b/TESTING/LIN/zlattb.c
new file mode 100644
index 0000000..b68c9d7
--- /dev/null
+++ b/TESTING/LIN/zlattb.c
@@ -0,0 +1,997 @@
+/* zlattb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__5 = 5;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static doublereal c_b91 = 2.;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zlattb_(integer *imat, char *uplo, char *trans, char *
+ diag, integer *iseed, integer *n, integer *kd, doublecomplex *ab,
+ integer *ldab, doublecomplex *b, doublecomplex *work, doublereal *
+ rwork, integer *info)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ double sqrt(doublereal);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+ double pow_dd(doublereal *, doublereal *), z_abs(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, kl, ku, iy;
+ doublereal ulp, sfac;
+ integer ioff, mode, lenj;
+ char path[3], dist[1];
+ doublereal unfl, rexp;
+ char type__[1];
+ doublereal texp;
+ doublecomplex star1, plus1, plus2;
+ doublereal bscal;
+ extern logical lsame_(char *, char *);
+ doublereal tscal, anorm, bnorm, tleft;
+ logical upper;
+ doublereal tnorm;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *), zlatb4_(char *, integer *,
+ integer *, integer *, char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, char *),
+ dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *), dlarnd_(integer *, integer *);
+ char packit[1];
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ doublereal bignum, cndnum;
+ extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *,
+ doublereal *);
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
+ integer *);
+ integer jcount;
+ extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ doublereal smlnum;
+ extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *,
+ doublecomplex *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLATTB generates a triangular test matrix in 2-dimensional storage. */
+/* IMAT and UPLO uniquely specify the properties of the test matrix, */
+/* which is returned in the array A. */
+
+/* Arguments */
+/* ========= */
+
+/* IMAT (input) INTEGER */
+/* An integer key describing which matrix to generate for this */
+/* path. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A will be upper or lower */
+/* triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies whether the matrix or its transpose will be used. */
+/* = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose (= transpose) */
+
+/* DIAG (output) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* The seed vector for the random number generator (used in */
+/* ZLATMS). Modified on exit. */
+
+/* N (input) INTEGER */
+/* The order of the matrix to be generated. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the banded */
+/* triangular matrix A. KD >= 0. */
+
+/* AB (output) COMPLEX*16 array, dimension (LDAB,N) */
+/* The upper or lower triangular banded matrix A, stored in the */
+/* first KD+1 rows of AB. Let j be a column of A, 1<=j<=n. */
+/* If UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j. */
+/* If UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (workspace) COMPLEX*16 array, dimension (N) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iseed;
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --b;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "TB", (ftnlen)2, (ftnlen)2);
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ smlnum = unfl;
+ bignum = (1. - ulp) / smlnum;
+ dlabad_(&smlnum, &bignum);
+ if (*imat >= 6 && *imat <= 9 || *imat == 17) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ *info = 0;
+
+/* Quick return if N.LE.0. */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Call ZLATB4 to set parameters for CLATMS. */
+
+ upper = lsame_(uplo, "U");
+ if (upper) {
+ zlatb4_(path, imat, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ ku = *kd;
+/* Computing MAX */
+ i__1 = 0, i__2 = *kd - *n + 1;
+ ioff = max(i__1,i__2) + 1;
+ kl = 0;
+ *(unsigned char *)packit = 'Q';
+ } else {
+ i__1 = -(*imat);
+ zlatb4_(path, &i__1, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ kl = *kd;
+ ioff = 1;
+ ku = 0;
+ *(unsigned char *)packit = 'B';
+ }
+
+/* IMAT <= 5: Non-unit triangular matrix */
+
+ if (*imat <= 5) {
+ zlatms_(n, n, dist, &iseed[1], type__, &rwork[1], &mode, &cndnum, &
+ anorm, &kl, &ku, packit, &ab[ioff + ab_dim1], ldab, &work[1],
+ info);
+
+/* IMAT > 5: Unit triangular matrix */
+/* The diagonal is deliberately set to something other than 1. */
+
+/* IMAT = 6: Matrix is the identity */
+
+ } else if (*imat == 6) {
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = 1, i__3 = *kd + 2 - j;
+ i__4 = *kd;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ i__2 = i__ + j * ab_dim1;
+ ab[i__2].r = 0., ab[i__2].i = 0.;
+/* L10: */
+ }
+ i__4 = *kd + 1 + j * ab_dim1;
+ ab[i__4].r = (doublereal) j, ab[i__4].i = 0.;
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = j * ab_dim1 + 1;
+ ab[i__4].r = (doublereal) j, ab[i__4].i = 0.;
+/* Computing MIN */
+ i__2 = *kd + 1, i__3 = *n - j + 1;
+ i__4 = min(i__2,i__3);
+ for (i__ = 2; i__ <= i__4; ++i__) {
+ i__2 = i__ + j * ab_dim1;
+ ab[i__2].r = 0., ab[i__2].i = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+/* IMAT > 6: Non-trivial unit triangular matrix */
+
+/* A unit triangular matrix T with condition CNDNUM is formed. */
+/* In this version, T only has bandwidth 2, the rest of it is zero. */
+
+ } else if (*imat <= 9) {
+ tnorm = sqrt(cndnum);
+
+/* Initialize AB to zero. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__4 = 1, i__2 = *kd + 2 - j;
+ i__3 = *kd;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ i__4 = i__ + j * ab_dim1;
+ ab[i__4].r = 0., ab[i__4].i = 0.;
+/* L50: */
+ }
+ i__3 = *kd + 1 + j * ab_dim1;
+ d__1 = (doublereal) j;
+ ab[i__3].r = d__1, ab[i__3].i = 0.;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = *kd + 1, i__2 = *n - j + 1;
+ i__3 = min(i__4,i__2);
+ for (i__ = 2; i__ <= i__3; ++i__) {
+ i__4 = i__ + j * ab_dim1;
+ ab[i__4].r = 0., ab[i__4].i = 0.;
+/* L70: */
+ }
+ i__3 = j * ab_dim1 + 1;
+ d__1 = (doublereal) j;
+ ab[i__3].r = d__1, ab[i__3].i = 0.;
+/* L80: */
+ }
+ }
+
+/* Special case: T is tridiagonal. Set every other offdiagonal */
+/* so that the matrix has norm TNORM+1. */
+
+ if (*kd == 1) {
+ if (upper) {
+ i__1 = (ab_dim1 << 1) + 1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = tnorm * z__2.r, z__1.i = tnorm * z__2.i;
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+ lenj = (*n - 3) / 2;
+ zlarnv_(&c__2, &iseed[1], &lenj, &work[1]);
+ i__1 = lenj;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = (j + 1 << 1) * ab_dim1 + 1;
+ i__4 = j;
+ z__1.r = tnorm * work[i__4].r, z__1.i = tnorm * work[i__4]
+ .i;
+ ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
+/* L90: */
+ }
+ } else {
+ i__1 = ab_dim1 + 2;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = tnorm * z__2.r, z__1.i = tnorm * z__2.i;
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+ lenj = (*n - 3) / 2;
+ zlarnv_(&c__2, &iseed[1], &lenj, &work[1]);
+ i__1 = lenj;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = ((j << 1) + 1) * ab_dim1 + 2;
+ i__4 = j;
+ z__1.r = tnorm * work[i__4].r, z__1.i = tnorm * work[i__4]
+ .i;
+ ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
+/* L100: */
+ }
+ }
+ } else if (*kd > 1) {
+
+/* Form a unit triangular matrix T with condition CNDNUM. T is */
+/* given by */
+/* | 1 + * | */
+/* | 1 + | */
+/* T = | 1 + * | */
+/* | 1 + | */
+/* | 1 + * | */
+/* | 1 + | */
+/* | . . . | */
+/* Each element marked with a '*' is formed by taking the product */
+/* of the adjacent elements marked with '+'. The '*'s can be */
+/* chosen freely, and the '+'s are chosen so that the inverse of */
+/* T will have elements of the same magnitude as T. */
+
+/* The two offdiagonals of T are stored in WORK. */
+
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = tnorm * z__2.r, z__1.i = tnorm * z__2.i;
+ star1.r = z__1.r, star1.i = z__1.i;
+ sfac = sqrt(tnorm);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = sfac * z__2.r, z__1.i = sfac * z__2.i;
+ plus1.r = z__1.r, plus1.i = z__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; j += 2) {
+ z_div(&z__1, &star1, &plus1);
+ plus2.r = z__1.r, plus2.i = z__1.i;
+ i__3 = j;
+ work[i__3].r = plus1.r, work[i__3].i = plus1.i;
+ i__3 = *n + j;
+ work[i__3].r = star1.r, work[i__3].i = star1.i;
+ if (j + 1 <= *n) {
+ i__3 = j + 1;
+ work[i__3].r = plus2.r, work[i__3].i = plus2.i;
+ i__3 = *n + j + 1;
+ work[i__3].r = 0., work[i__3].i = 0.;
+ z_div(&z__1, &star1, &plus2);
+ plus1.r = z__1.r, plus1.i = z__1.i;
+
+/* Generate a new *-value with norm between sqrt(TNORM) */
+/* and TNORM. */
+
+ rexp = dlarnd_(&c__2, &iseed[1]);
+ if (rexp < 0.) {
+ d__2 = 1. - rexp;
+ d__1 = -pow_dd(&sfac, &d__2);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ star1.r = z__1.r, star1.i = z__1.i;
+ } else {
+ d__2 = rexp + 1.;
+ d__1 = pow_dd(&sfac, &d__2);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ star1.r = z__1.r, star1.i = z__1.i;
+ }
+ }
+/* L110: */
+ }
+
+/* Copy the tridiagonal T to AB. */
+
+ if (upper) {
+ i__1 = *n - 1;
+ zcopy_(&i__1, &work[1], &c__1, &ab[*kd + (ab_dim1 << 1)],
+ ldab);
+ i__1 = *n - 2;
+ zcopy_(&i__1, &work[*n + 1], &c__1, &ab[*kd - 1 + ab_dim1 * 3]
+, ldab);
+ } else {
+ i__1 = *n - 1;
+ zcopy_(&i__1, &work[1], &c__1, &ab[ab_dim1 + 2], ldab);
+ i__1 = *n - 2;
+ zcopy_(&i__1, &work[*n + 1], &c__1, &ab[ab_dim1 + 3], ldab);
+ }
+ }
+
+/* IMAT > 9: Pathological test cases. These triangular matrices */
+/* are badly scaled or badly conditioned, so when used in solving a */
+/* triangular system they may cause overflow in the solution vector. */
+
+ } else if (*imat == 10) {
+
+/* Type 10: Generate a triangular matrix with elements between */
+/* -1 and 1. Give the diagonal norm 2 to make it well-conditioned. */
+/* Make the right hand side large so that it requires scaling. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j - 1;
+ lenj = min(i__3,*kd);
+ zlarnv_(&c__4, &iseed[1], &lenj, &ab[*kd + 1 - lenj + j *
+ ab_dim1]);
+ i__3 = *kd + 1 + j * ab_dim1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
+ ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
+/* L120: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n - j;
+ lenj = min(i__3,*kd);
+ if (lenj > 0) {
+ zlarnv_(&c__4, &iseed[1], &lenj, &ab[j * ab_dim1 + 2]);
+ }
+ i__3 = j * ab_dim1 + 1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
+ ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
+/* L130: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ zlarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = izamax_(n, &b[1], &c__1);
+ bnorm = z_abs(&b[iy]);
+ bscal = bignum / max(1.,bnorm);
+ zdscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 11) {
+
+/* Type 11: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 11, the offdiagonal elements are small (CNORM(j) < 1). */
+
+ zlarnv_(&c__2, &iseed[1], n, &b[1]);
+ tscal = 1. / (doublereal) (*kd + 1);
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j - 1;
+ lenj = min(i__3,*kd);
+ if (lenj > 0) {
+ zlarnv_(&c__4, &iseed[1], &lenj, &ab[*kd + 2 - lenj + j *
+ ab_dim1]);
+ zdscal_(&lenj, &tscal, &ab[*kd + 2 - lenj + j * ab_dim1],
+ &c__1);
+ }
+ i__3 = *kd + 1 + j * ab_dim1;
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
+/* L140: */
+ }
+ i__1 = *kd + 1 + *n * ab_dim1;
+ i__3 = *kd + 1 + *n * ab_dim1;
+ z__1.r = smlnum * ab[i__3].r, z__1.i = smlnum * ab[i__3].i;
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n - j;
+ lenj = min(i__3,*kd);
+ if (lenj > 0) {
+ zlarnv_(&c__4, &iseed[1], &lenj, &ab[j * ab_dim1 + 2]);
+ zdscal_(&lenj, &tscal, &ab[j * ab_dim1 + 2], &c__1);
+ }
+ i__3 = j * ab_dim1 + 1;
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
+/* L150: */
+ }
+ i__1 = ab_dim1 + 1;
+ i__3 = ab_dim1 + 1;
+ z__1.r = smlnum * ab[i__3].r, z__1.i = smlnum * ab[i__3].i;
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+ }
+
+ } else if (*imat == 12) {
+
+/* Type 12: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 12, the offdiagonal elements are O(1) (CNORM(j) > 1). */
+
+ zlarnv_(&c__2, &iseed[1], n, &b[1]);
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = j - 1;
+ lenj = min(i__3,*kd);
+ if (lenj > 0) {
+ zlarnv_(&c__4, &iseed[1], &lenj, &ab[*kd + 2 - lenj + j *
+ ab_dim1]);
+ }
+ i__3 = *kd + 1 + j * ab_dim1;
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
+/* L160: */
+ }
+ i__1 = *kd + 1 + *n * ab_dim1;
+ i__3 = *kd + 1 + *n * ab_dim1;
+ z__1.r = smlnum * ab[i__3].r, z__1.i = smlnum * ab[i__3].i;
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__3 = *n - j;
+ lenj = min(i__3,*kd);
+ if (lenj > 0) {
+ zlarnv_(&c__4, &iseed[1], &lenj, &ab[j * ab_dim1 + 2]);
+ }
+ i__3 = j * ab_dim1 + 1;
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ ab[i__3].r = z__1.r, ab[i__3].i = z__1.i;
+/* L170: */
+ }
+ i__1 = ab_dim1 + 1;
+ i__3 = ab_dim1 + 1;
+ z__1.r = smlnum * ab[i__3].r, z__1.i = smlnum * ab[i__3].i;
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+ }
+
+ } else if (*imat == 13) {
+
+/* Type 13: T is diagonal with small numbers on the diagonal to */
+/* make the growth factor underflow, but a small right hand side */
+/* chosen so that the solution does not overflow. */
+
+ if (upper) {
+ jcount = 1;
+ for (j = *n; j >= 1; --j) {
+/* Computing MAX */
+ i__1 = 1, i__3 = *kd + 1 - (j - 1);
+ i__4 = *kd;
+ for (i__ = max(i__1,i__3); i__ <= i__4; ++i__) {
+ i__1 = i__ + j * ab_dim1;
+ ab[i__1].r = 0., ab[i__1].i = 0.;
+/* L180: */
+ }
+ if (jcount <= 2) {
+ i__4 = *kd + 1 + j * ab_dim1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
+ ab[i__4].r = z__1.r, ab[i__4].i = z__1.i;
+ } else {
+ i__4 = *kd + 1 + j * ab_dim1;
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ ab[i__4].r = z__1.r, ab[i__4].i = z__1.i;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+/* L190: */
+ }
+ } else {
+ jcount = 1;
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MIN */
+ i__3 = *n - j + 1, i__2 = *kd + 1;
+ i__1 = min(i__3,i__2);
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__3 = i__ + j * ab_dim1;
+ ab[i__3].r = 0., ab[i__3].i = 0.;
+/* L200: */
+ }
+ if (jcount <= 2) {
+ i__1 = j * ab_dim1 + 1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+ } else {
+ i__1 = j * ab_dim1 + 1;
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+/* L210: */
+ }
+ }
+
+/* Set the right hand side alternately zero and small. */
+
+ if (upper) {
+ b[1].r = 0., b[1].i = 0.;
+ for (i__ = *n; i__ >= 2; i__ += -2) {
+ i__4 = i__;
+ b[i__4].r = 0., b[i__4].i = 0.;
+ i__4 = i__ - 1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
+ b[i__4].r = z__1.r, b[i__4].i = z__1.i;
+/* L220: */
+ }
+ } else {
+ i__4 = *n;
+ b[i__4].r = 0., b[i__4].i = 0.;
+ i__4 = *n - 1;
+ for (i__ = 1; i__ <= i__4; i__ += 2) {
+ i__1 = i__;
+ b[i__1].r = 0., b[i__1].i = 0.;
+ i__1 = i__ + 1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
+ b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+/* L230: */
+ }
+ }
+
+ } else if (*imat == 14) {
+
+/* Type 14: Make the diagonal elements small to cause gradual */
+/* overflow when dividing by T(j,j). To control the amount of */
+/* scaling needed, the matrix is bidiagonal. */
+
+ texp = 1. / (doublereal) (*kd + 1);
+ tscal = pow_dd(&smlnum, &texp);
+ zlarnv_(&c__4, &iseed[1], n, &b[1]);
+ if (upper) {
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MAX */
+ i__1 = 1, i__3 = *kd + 2 - j;
+ i__2 = *kd;
+ for (i__ = max(i__1,i__3); i__ <= i__2; ++i__) {
+ i__1 = i__ + j * ab_dim1;
+ ab[i__1].r = 0., ab[i__1].i = 0.;
+/* L240: */
+ }
+ if (j > 1 && *kd > 0) {
+ i__2 = *kd + j * ab_dim1;
+ ab[i__2].r = -1., ab[i__2].i = -1.;
+ }
+ i__2 = *kd + 1 + j * ab_dim1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
+ ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
+/* L250: */
+ }
+ i__4 = *n;
+ b[i__4].r = 1., b[i__4].i = 1.;
+ } else {
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MIN */
+ i__1 = *n - j + 1, i__3 = *kd + 1;
+ i__2 = min(i__1,i__3);
+ for (i__ = 3; i__ <= i__2; ++i__) {
+ i__1 = i__ + j * ab_dim1;
+ ab[i__1].r = 0., ab[i__1].i = 0.;
+/* L260: */
+ }
+ if (j < *n && *kd > 0) {
+ i__2 = j * ab_dim1 + 2;
+ ab[i__2].r = -1., ab[i__2].i = -1.;
+ }
+ i__2 = j * ab_dim1 + 1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
+ ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
+/* L270: */
+ }
+ b[1].r = 1., b[1].i = 1.;
+ }
+
+ } else if (*imat == 15) {
+
+/* Type 15: One zero diagonal element. */
+
+ iy = *n / 2 + 1;
+ if (upper) {
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MIN */
+ i__2 = j, i__1 = *kd + 1;
+ lenj = min(i__2,i__1);
+ zlarnv_(&c__4, &iseed[1], &lenj, &ab[*kd + 2 - lenj + j *
+ ab_dim1]);
+ if (j != iy) {
+ i__2 = *kd + 1 + j * ab_dim1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
+ ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
+ } else {
+ i__2 = *kd + 1 + j * ab_dim1;
+ ab[i__2].r = 0., ab[i__2].i = 0.;
+ }
+/* L280: */
+ }
+ } else {
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+/* Computing MIN */
+ i__2 = *n - j + 1, i__1 = *kd + 1;
+ lenj = min(i__2,i__1);
+ zlarnv_(&c__4, &iseed[1], &lenj, &ab[j * ab_dim1 + 1]);
+ if (j != iy) {
+ i__2 = j * ab_dim1 + 1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
+ ab[i__2].r = z__1.r, ab[i__2].i = z__1.i;
+ } else {
+ i__2 = j * ab_dim1 + 1;
+ ab[i__2].r = 0., ab[i__2].i = 0.;
+ }
+/* L290: */
+ }
+ }
+ zlarnv_(&c__2, &iseed[1], n, &b[1]);
+ zdscal_(n, &c_b91, &b[1], &c__1);
+
+ } else if (*imat == 16) {
+
+/* Type 16: Make the offdiagonal elements large to cause overflow */
+/* when adding a column of T. In the non-transposed case, the */
+/* matrix is constructed to cause overflow when adding a column in */
+/* every other step. */
+
+ tscal = unfl / ulp;
+ tscal = (1. - ulp) / tscal;
+ i__4 = *n;
+ for (j = 1; j <= i__4; ++j) {
+ i__2 = *kd + 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__1 = i__ + j * ab_dim1;
+ ab[i__1].r = 0., ab[i__1].i = 0.;
+/* L300: */
+ }
+/* L310: */
+ }
+ texp = 1.;
+ if (*kd > 0) {
+ if (upper) {
+ i__4 = -(*kd);
+ for (j = *n; i__4 < 0 ? j >= 1 : j <= 1; j += i__4) {
+/* Computing MAX */
+ i__1 = 1, i__3 = j - *kd + 1;
+ i__2 = max(i__1,i__3);
+ for (i__ = j; i__ >= i__2; i__ += -2) {
+ i__1 = j - i__ + 1 + i__ * ab_dim1;
+ d__1 = -tscal / (doublereal) (*kd + 2);
+ ab[i__1].r = d__1, ab[i__1].i = 0.;
+ i__1 = *kd + 1 + i__ * ab_dim1;
+ ab[i__1].r = 1., ab[i__1].i = 0.;
+ i__1 = i__;
+ d__1 = texp * (1. - ulp);
+ b[i__1].r = d__1, b[i__1].i = 0.;
+/* Computing MAX */
+ i__1 = 1, i__3 = j - *kd + 1;
+ if (i__ > max(i__1,i__3)) {
+ i__1 = j - i__ + 2 + (i__ - 1) * ab_dim1;
+ d__1 = -(tscal / (doublereal) (*kd + 2)) / (
+ doublereal) (*kd + 3);
+ ab[i__1].r = d__1, ab[i__1].i = 0.;
+ i__1 = *kd + 1 + (i__ - 1) * ab_dim1;
+ ab[i__1].r = 1., ab[i__1].i = 0.;
+ i__1 = i__ - 1;
+ d__1 = texp * (doublereal) ((*kd + 1) * (*kd + 1)
+ + *kd);
+ b[i__1].r = d__1, b[i__1].i = 0.;
+ }
+ texp *= 2.;
+/* L320: */
+ }
+/* Computing MAX */
+ i__1 = 1, i__3 = j - *kd + 1;
+ i__2 = max(i__1,i__3);
+ d__1 = (doublereal) (*kd + 2) / (doublereal) (*kd + 3) *
+ tscal;
+ b[i__2].r = d__1, b[i__2].i = 0.;
+/* L330: */
+ }
+ } else {
+ i__4 = *n;
+ i__2 = *kd;
+ for (j = 1; i__2 < 0 ? j >= i__4 : j <= i__4; j += i__2) {
+ texp = 1.;
+/* Computing MIN */
+ i__1 = *kd + 1, i__3 = *n - j + 1;
+ lenj = min(i__1,i__3);
+/* Computing MIN */
+ i__3 = *n, i__5 = j + *kd - 1;
+ i__1 = min(i__3,i__5);
+ for (i__ = j; i__ <= i__1; i__ += 2) {
+ i__3 = lenj - (i__ - j) + j * ab_dim1;
+ d__1 = -tscal / (doublereal) (*kd + 2);
+ ab[i__3].r = d__1, ab[i__3].i = 0.;
+ i__3 = j * ab_dim1 + 1;
+ ab[i__3].r = 1., ab[i__3].i = 0.;
+ i__3 = j;
+ d__1 = texp * (1. - ulp);
+ b[i__3].r = d__1, b[i__3].i = 0.;
+/* Computing MIN */
+ i__3 = *n, i__5 = j + *kd - 1;
+ if (i__ < min(i__3,i__5)) {
+ i__3 = lenj - (i__ - j + 1) + (i__ + 1) * ab_dim1;
+ d__1 = -(tscal / (doublereal) (*kd + 2)) / (
+ doublereal) (*kd + 3);
+ ab[i__3].r = d__1, ab[i__3].i = 0.;
+ i__3 = (i__ + 1) * ab_dim1 + 1;
+ ab[i__3].r = 1., ab[i__3].i = 0.;
+ i__3 = i__ + 1;
+ d__1 = texp * (doublereal) ((*kd + 1) * (*kd + 1)
+ + *kd);
+ b[i__3].r = d__1, b[i__3].i = 0.;
+ }
+ texp *= 2.;
+/* L340: */
+ }
+/* Computing MIN */
+ i__3 = *n, i__5 = j + *kd - 1;
+ i__1 = min(i__3,i__5);
+ d__1 = (doublereal) (*kd + 2) / (doublereal) (*kd + 3) *
+ tscal;
+ b[i__1].r = d__1, b[i__1].i = 0.;
+/* L350: */
+ }
+ }
+ }
+
+ } else if (*imat == 17) {
+
+/* Type 17: Generate a unit triangular matrix with elements */
+/* between -1 and 1, and make the right hand side large so that it */
+/* requires scaling. */
+
+ if (upper) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = j - 1;
+ lenj = min(i__4,*kd);
+ zlarnv_(&c__4, &iseed[1], &lenj, &ab[*kd + 1 - lenj + j *
+ ab_dim1]);
+ i__4 = *kd + 1 + j * ab_dim1;
+ d__1 = (doublereal) j;
+ ab[i__4].r = d__1, ab[i__4].i = 0.;
+/* L360: */
+ }
+ } else {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = *n - j;
+ lenj = min(i__4,*kd);
+ if (lenj > 0) {
+ zlarnv_(&c__4, &iseed[1], &lenj, &ab[j * ab_dim1 + 2]);
+ }
+ i__4 = j * ab_dim1 + 1;
+ d__1 = (doublereal) j;
+ ab[i__4].r = d__1, ab[i__4].i = 0.;
+/* L370: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ zlarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = izamax_(n, &b[1], &c__1);
+ bnorm = z_abs(&b[iy]);
+ bscal = bignum / max(1.,bnorm);
+ zdscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 18) {
+
+/* Type 18: Generate a triangular matrix with elements between */
+/* BIGNUM/(KD+1) and BIGNUM so that at least one of the column */
+/* norms will exceed BIGNUM. */
+/* 1/3/91: ZLATBS no longer can handle this case */
+
+ tleft = bignum / (doublereal) (*kd + 1);
+ tscal = bignum * ((doublereal) (*kd + 1) / (doublereal) (*kd + 2));
+ if (upper) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = j, i__1 = *kd + 1;
+ lenj = min(i__4,i__1);
+ zlarnv_(&c__5, &iseed[1], &lenj, &ab[*kd + 2 - lenj + j *
+ ab_dim1]);
+ dlarnv_(&c__1, &iseed[1], &lenj, &rwork[*kd + 2 - lenj]);
+ i__4 = *kd + 1;
+ for (i__ = *kd + 2 - lenj; i__ <= i__4; ++i__) {
+ i__1 = i__ + j * ab_dim1;
+ i__3 = i__ + j * ab_dim1;
+ d__1 = tleft + rwork[i__] * tscal;
+ z__1.r = d__1 * ab[i__3].r, z__1.i = d__1 * ab[i__3].i;
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+/* L380: */
+ }
+/* L390: */
+ }
+ } else {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = *n - j + 1, i__1 = *kd + 1;
+ lenj = min(i__4,i__1);
+ zlarnv_(&c__5, &iseed[1], &lenj, &ab[j * ab_dim1 + 1]);
+ dlarnv_(&c__1, &iseed[1], &lenj, &rwork[1]);
+ i__4 = lenj;
+ for (i__ = 1; i__ <= i__4; ++i__) {
+ i__1 = i__ + j * ab_dim1;
+ i__3 = i__ + j * ab_dim1;
+ d__1 = tleft + rwork[i__] * tscal;
+ z__1.r = d__1 * ab[i__3].r, z__1.i = d__1 * ab[i__3].i;
+ ab[i__1].r = z__1.r, ab[i__1].i = z__1.i;
+/* L400: */
+ }
+/* L410: */
+ }
+ }
+ zlarnv_(&c__2, &iseed[1], n, &b[1]);
+ zdscal_(n, &c_b91, &b[1], &c__1);
+ }
+
+/* Flip the matrix if the transpose will be used. */
+
+ if (! lsame_(trans, "N")) {
+ if (upper) {
+ i__2 = *n / 2;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = *n - (j << 1) + 1, i__1 = *kd + 1;
+ lenj = min(i__4,i__1);
+ i__4 = *ldab - 1;
+ zswap_(&lenj, &ab[*kd + 1 + j * ab_dim1], &i__4, &ab[*kd + 2
+ - lenj + (*n - j + 1) * ab_dim1], &c_n1);
+/* L420: */
+ }
+ } else {
+ i__2 = *n / 2;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing MIN */
+ i__4 = *n - (j << 1) + 1, i__1 = *kd + 1;
+ lenj = min(i__4,i__1);
+ i__4 = -(*ldab) + 1;
+ zswap_(&lenj, &ab[j * ab_dim1 + 1], &c__1, &ab[lenj + (*n - j
+ + 2 - lenj) * ab_dim1], &i__4);
+/* L430: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZLATTB */
+
+} /* zlattb_ */
diff --git a/TESTING/LIN/zlattp.c b/TESTING/LIN/zlattp.c
new file mode 100644
index 0000000..f808b30
--- /dev/null
+++ b/TESTING/LIN/zlattp.c
@@ -0,0 +1,1143 @@
+/* zlattp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__5 = 5;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static doublereal c_b93 = 2.;
+
+/* Subroutine */ int zlattp_(integer *imat, char *uplo, char *trans, char *
+ diag, integer *iseed, integer *n, doublecomplex *ap, doublecomplex *b,
+ doublecomplex *work, doublereal *rwork, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2, z__3, z__4, z__5;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+ double pow_dd(doublereal *, doublereal *), sqrt(doublereal);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ double z_abs(doublecomplex *);
+
+ /* Local variables */
+ doublereal c__;
+ integer i__, j;
+ doublecomplex s;
+ doublereal t, x, y, z__;
+ integer jc;
+ doublecomplex ra;
+ integer jj;
+ doublecomplex rb;
+ integer jl, kl, jr, ku, iy, jx;
+ doublereal ulp, sfac;
+ integer mode;
+ char path[3], dist[1];
+ doublereal unfl, rexp;
+ char type__[1];
+ doublereal texp;
+ extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *);
+ doublecomplex star1, plus1, plus2;
+ doublereal bscal;
+ extern logical lsame_(char *, char *);
+ doublereal tscal;
+ doublecomplex ctemp;
+ doublereal anorm, bnorm, tleft;
+ logical upper;
+ extern /* Subroutine */ int zrotg_(doublecomplex *, doublecomplex *,
+ doublereal *, doublecomplex *), zlatb4_(char *, integer *,
+ integer *, integer *, char *, integer *, integer *, doublereal *,
+ integer *, doublereal *, char *), dlabad_(
+ doublereal *, doublereal *);
+ extern doublereal dlamch_(char *);
+ char packit[1];
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ doublereal bignum, cndnum;
+ extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *,
+ doublereal *);
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
+ integer *);
+ integer jcnext, jcount;
+ extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ doublereal smlnum;
+ extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *,
+ doublecomplex *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLATTP generates a triangular test matrix in packed storage. */
+/* IMAT and UPLO uniquely specify the properties of the test matrix, */
+/* which is returned in the array AP. */
+
+/* Arguments */
+/* ========= */
+
+/* IMAT (input) INTEGER */
+/* An integer key describing which matrix to generate for this */
+/* path. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A will be upper or lower */
+/* triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies whether the matrix or its transpose will be used. */
+/* = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose */
+
+/* DIAG (output) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* The seed vector for the random number generator (used in */
+/* ZLATMS). Modified on exit. */
+
+/* N (input) INTEGER */
+/* The order of the matrix to be generated. */
+
+/* AP (output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
+
+/* B (output) COMPLEX*16 array, dimension (N) */
+/* The right hand side vector, if IMAT > 10. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --work;
+ --b;
+ --ap;
+ --iseed;
+
+ /* Function Body */
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "TP", (ftnlen)2, (ftnlen)2);
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ smlnum = unfl;
+ bignum = (1. - ulp) / smlnum;
+ dlabad_(&smlnum, &bignum);
+ if (*imat >= 7 && *imat <= 10 || *imat == 18) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ *info = 0;
+
+/* Quick return if N.LE.0. */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Call ZLATB4 to set parameters for CLATMS. */
+
+ upper = lsame_(uplo, "U");
+ if (upper) {
+ zlatb4_(path, imat, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ *(unsigned char *)packit = 'C';
+ } else {
+ i__1 = -(*imat);
+ zlatb4_(path, &i__1, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ *(unsigned char *)packit = 'R';
+ }
+
+/* IMAT <= 6: Non-unit triangular matrix */
+
+ if (*imat <= 6) {
+ zlatms_(n, n, dist, &iseed[1], type__, &rwork[1], &mode, &cndnum, &
+ anorm, &kl, &ku, packit, &ap[1], n, &work[1], info);
+
+/* IMAT > 6: Unit triangular matrix */
+/* The diagonal is deliberately set to something other than 1. */
+
+/* IMAT = 7: Matrix is the identity */
+
+ } else if (*imat == 7) {
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - 1;
+ ap[i__3].r = 0., ap[i__3].i = 0.;
+/* L10: */
+ }
+ i__2 = jc + j - 1;
+ ap[i__2].r = (doublereal) j, ap[i__2].i = 0.;
+ jc += j;
+/* L20: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jc;
+ ap[i__2].r = (doublereal) j, ap[i__2].i = 0.;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - j;
+ ap[i__3].r = 0., ap[i__3].i = 0.;
+/* L30: */
+ }
+ jc = jc + *n - j + 1;
+/* L40: */
+ }
+ }
+
+/* IMAT > 7: Non-trivial unit triangular matrix */
+
+/* Generate a unit triangular matrix T with condition CNDNUM by */
+/* forming a triangular matrix with known singular values and */
+/* filling in the zero entries with Givens rotations. */
+
+ } else if (*imat <= 10) {
+ if (upper) {
+ jc = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = jc + i__;
+ ap[i__3].r = 0., ap[i__3].i = 0.;
+/* L50: */
+ }
+ i__2 = jc + j;
+ ap[i__2].r = (doublereal) j, ap[i__2].i = 0.;
+ jc += j;
+/* L60: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = jc;
+ ap[i__2].r = (doublereal) j, ap[i__2].i = 0.;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - j;
+ ap[i__3].r = 0., ap[i__3].i = 0.;
+/* L70: */
+ }
+ jc = jc + *n - j + 1;
+/* L80: */
+ }
+ }
+
+/* Since the trace of a unit triangular matrix is 1, the product */
+/* of its singular values must be 1. Let s = sqrt(CNDNUM), */
+/* x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2. */
+/* The following triangular matrix has singular values s, 1, 1, */
+/* ..., 1, 1/s: */
+
+/* 1 y y y ... y y z */
+/* 1 0 0 ... 0 0 y */
+/* 1 0 ... 0 0 y */
+/* . ... . . . */
+/* . . . . */
+/* 1 0 y */
+/* 1 y */
+/* 1 */
+
+/* To fill in the zeros, we first multiply by a matrix with small */
+/* condition number of the form */
+
+/* 1 0 0 0 0 ... */
+/* 1 + * 0 0 ... */
+/* 1 + 0 0 0 */
+/* 1 + * 0 0 */
+/* 1 + 0 0 */
+/* ... */
+/* 1 + 0 */
+/* 1 0 */
+/* 1 */
+
+/* Each element marked with a '*' is formed by taking the product */
+/* of the adjacent elements marked with '+'. The '*'s can be */
+/* chosen freely, and the '+'s are chosen so that the inverse of */
+/* T will have elements of the same magnitude as T. If the *'s in */
+/* both T and inv(T) have small magnitude, T is well conditioned. */
+/* The two offdiagonals of T are stored in WORK. */
+
+/* The product of these two matrices has the form */
+
+/* 1 y y y y y . y y z */
+/* 1 + * 0 0 . 0 0 y */
+/* 1 + 0 0 . 0 0 y */
+/* 1 + * . . . . */
+/* 1 + . . . . */
+/* . . . . . */
+/* . . . . */
+/* 1 + y */
+/* 1 y */
+/* 1 */
+
+/* Now we multiply by Givens rotations, using the fact that */
+
+/* [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ] */
+/* [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ] */
+/* and */
+/* [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ] */
+/* [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ] */
+
+/* where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4). */
+
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = z__2.r * .25, z__1.i = z__2.i * .25;
+ star1.r = z__1.r, star1.i = z__1.i;
+ sfac = .5;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = sfac * z__2.r, z__1.i = sfac * z__2.i;
+ plus1.r = z__1.r, plus1.i = z__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; j += 2) {
+ z_div(&z__1, &star1, &plus1);
+ plus2.r = z__1.r, plus2.i = z__1.i;
+ i__2 = j;
+ work[i__2].r = plus1.r, work[i__2].i = plus1.i;
+ i__2 = *n + j;
+ work[i__2].r = star1.r, work[i__2].i = star1.i;
+ if (j + 1 <= *n) {
+ i__2 = j + 1;
+ work[i__2].r = plus2.r, work[i__2].i = plus2.i;
+ i__2 = *n + j + 1;
+ work[i__2].r = 0., work[i__2].i = 0.;
+ z_div(&z__1, &star1, &plus2);
+ plus1.r = z__1.r, plus1.i = z__1.i;
+ zlarnd_(&z__1, &c__2, &iseed[1]);
+ rexp = z__1.r;
+ if (rexp < 0.) {
+ d__2 = 1. - rexp;
+ d__1 = -pow_dd(&sfac, &d__2);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ star1.r = z__1.r, star1.i = z__1.i;
+ } else {
+ d__2 = rexp + 1.;
+ d__1 = pow_dd(&sfac, &d__2);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ star1.r = z__1.r, star1.i = z__1.i;
+ }
+ }
+/* L90: */
+ }
+
+ x = sqrt(cndnum) - 1. / sqrt(cndnum);
+ if (*n > 2) {
+ y = sqrt(2. / (doublereal) (*n - 2)) * x;
+ } else {
+ y = 0.;
+ }
+ z__ = x * x;
+
+ if (upper) {
+
+/* Set the upper triangle of A with a unit triangular matrix */
+/* of known condition number. */
+
+ jc = 1;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = jc + 1;
+ ap[i__2].r = y, ap[i__2].i = 0.;
+ if (j > 2) {
+ i__2 = jc + j - 1;
+ i__3 = j - 2;
+ ap[i__2].r = work[i__3].r, ap[i__2].i = work[i__3].i;
+ }
+ if (j > 3) {
+ i__2 = jc + j - 2;
+ i__3 = *n + j - 3;
+ ap[i__2].r = work[i__3].r, ap[i__2].i = work[i__3].i;
+ }
+ jc += j;
+/* L100: */
+ }
+ jc -= *n;
+ i__1 = jc + 1;
+ ap[i__1].r = z__, ap[i__1].i = 0.;
+ i__1 = *n - 1;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = jc + j;
+ ap[i__2].r = y, ap[i__2].i = 0.;
+/* L110: */
+ }
+ } else {
+
+/* Set the lower triangle of A with a unit triangular matrix */
+/* of known condition number. */
+
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ ap[i__2].r = y, ap[i__2].i = 0.;
+/* L120: */
+ }
+ i__1 = *n;
+ ap[i__1].r = z__, ap[i__1].i = 0.;
+ jc = *n + 1;
+ i__1 = *n - 1;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = jc + 1;
+ i__3 = j - 1;
+ ap[i__2].r = work[i__3].r, ap[i__2].i = work[i__3].i;
+ if (j < *n - 1) {
+ i__2 = jc + 2;
+ i__3 = *n + j - 1;
+ ap[i__2].r = work[i__3].r, ap[i__2].i = work[i__3].i;
+ }
+ i__2 = jc + *n - j;
+ ap[i__2].r = y, ap[i__2].i = 0.;
+ jc = jc + *n - j + 1;
+/* L130: */
+ }
+ }
+
+/* Fill in the zeros using Givens rotations */
+
+ if (upper) {
+ jc = 1;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ jcnext = jc + j;
+ i__2 = jcnext + j - 1;
+ ra.r = ap[i__2].r, ra.i = ap[i__2].i;
+ rb.r = 2., rb.i = 0.;
+ zrotg_(&ra, &rb, &c__, &s);
+
+/* Multiply by [ c s; -conjg(s) c] on the left. */
+
+ if (*n > j + 1) {
+ jx = jcnext + j;
+ i__2 = *n;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+ i__3 = jx + j;
+ z__2.r = c__ * ap[i__3].r, z__2.i = c__ * ap[i__3].i;
+ i__4 = jx + j + 1;
+ z__3.r = s.r * ap[i__4].r - s.i * ap[i__4].i, z__3.i =
+ s.r * ap[i__4].i + s.i * ap[i__4].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__3 = jx + j + 1;
+ d_cnjg(&z__4, &s);
+ z__3.r = -z__4.r, z__3.i = -z__4.i;
+ i__4 = jx + j;
+ z__2.r = z__3.r * ap[i__4].r - z__3.i * ap[i__4].i,
+ z__2.i = z__3.r * ap[i__4].i + z__3.i * ap[
+ i__4].r;
+ i__5 = jx + j + 1;
+ z__5.r = c__ * ap[i__5].r, z__5.i = c__ * ap[i__5].i;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+ i__3 = jx + j;
+ ap[i__3].r = ctemp.r, ap[i__3].i = ctemp.i;
+ jx += i__;
+/* L140: */
+ }
+ }
+
+/* Multiply by [-c -s; conjg(s) -c] on the right. */
+
+ if (j > 1) {
+ i__2 = j - 1;
+ d__1 = -c__;
+ z__1.r = -s.r, z__1.i = -s.i;
+ zrot_(&i__2, &ap[jcnext], &c__1, &ap[jc], &c__1, &d__1, &
+ z__1);
+ }
+
+/* Negate A(J,J+1). */
+
+ i__2 = jcnext + j - 1;
+ i__3 = jcnext + j - 1;
+ z__1.r = -ap[i__3].r, z__1.i = -ap[i__3].i;
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ jc = jcnext;
+/* L150: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ jcnext = jc + *n - j + 1;
+ i__2 = jc + 1;
+ ra.r = ap[i__2].r, ra.i = ap[i__2].i;
+ rb.r = 2., rb.i = 0.;
+ zrotg_(&ra, &rb, &c__, &s);
+ d_cnjg(&z__1, &s);
+ s.r = z__1.r, s.i = z__1.i;
+
+/* Multiply by [ c -s; conjg(s) c] on the right. */
+
+ if (*n > j + 1) {
+ i__2 = *n - j - 1;
+ z__1.r = -s.r, z__1.i = -s.i;
+ zrot_(&i__2, &ap[jcnext + 1], &c__1, &ap[jc + 2], &c__1, &
+ c__, &z__1);
+ }
+
+/* Multiply by [-c s; -conjg(s) -c] on the left. */
+
+ if (j > 1) {
+ jx = 1;
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ d__1 = -c__;
+ i__3 = jx + j - i__;
+ z__2.r = d__1 * ap[i__3].r, z__2.i = d__1 * ap[i__3]
+ .i;
+ i__4 = jx + j - i__ + 1;
+ z__3.r = s.r * ap[i__4].r - s.i * ap[i__4].i, z__3.i =
+ s.r * ap[i__4].i + s.i * ap[i__4].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__3 = jx + j - i__ + 1;
+ d_cnjg(&z__4, &s);
+ z__3.r = -z__4.r, z__3.i = -z__4.i;
+ i__4 = jx + j - i__;
+ z__2.r = z__3.r * ap[i__4].r - z__3.i * ap[i__4].i,
+ z__2.i = z__3.r * ap[i__4].i + z__3.i * ap[
+ i__4].r;
+ i__5 = jx + j - i__ + 1;
+ z__5.r = c__ * ap[i__5].r, z__5.i = c__ * ap[i__5].i;
+ z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - z__5.i;
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+ i__3 = jx + j - i__;
+ ap[i__3].r = ctemp.r, ap[i__3].i = ctemp.i;
+ jx = jx + *n - i__ + 1;
+/* L160: */
+ }
+ }
+
+/* Negate A(J+1,J). */
+
+ i__2 = jc + 1;
+ i__3 = jc + 1;
+ z__1.r = -ap[i__3].r, z__1.i = -ap[i__3].i;
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ jc = jcnext;
+/* L170: */
+ }
+ }
+
+/* IMAT > 10: Pathological test cases. These triangular matrices */
+/* are badly scaled or badly conditioned, so when used in solving a */
+/* triangular system they may cause overflow in the solution vector. */
+
+ } else if (*imat == 11) {
+
+/* Type 11: Generate a triangular matrix with elements between */
+/* -1 and 1. Give the diagonal norm 2 to make it well-conditioned. */
+/* Make the right hand side large so that it requires scaling. */
+
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ zlarnv_(&c__4, &iseed[1], &i__2, &ap[jc]);
+ i__2 = jc + j - 1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ jc += j;
+/* L180: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (j < *n) {
+ i__2 = *n - j;
+ zlarnv_(&c__4, &iseed[1], &i__2, &ap[jc + 1]);
+ }
+ i__2 = jc;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ jc = jc + *n - j + 1;
+/* L190: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ zlarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = izamax_(n, &b[1], &c__1);
+ bnorm = z_abs(&b[iy]);
+ bscal = bignum / max(1.,bnorm);
+ zdscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 12) {
+
+/* Type 12: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 12, the offdiagonal elements are small (CNORM(j) < 1). */
+
+ zlarnv_(&c__2, &iseed[1], n, &b[1]);
+/* Computing MAX */
+ d__1 = 1., d__2 = (doublereal) (*n - 1);
+ tscal = 1. / max(d__1,d__2);
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ zlarnv_(&c__4, &iseed[1], &i__2, &ap[jc]);
+ i__2 = j - 1;
+ zdscal_(&i__2, &tscal, &ap[jc], &c__1);
+ i__2 = jc + j - 1;
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ jc += j;
+/* L200: */
+ }
+ i__1 = *n * (*n + 1) / 2;
+ i__2 = *n * (*n + 1) / 2;
+ z__1.r = smlnum * ap[i__2].r, z__1.i = smlnum * ap[i__2].i;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ zlarnv_(&c__2, &iseed[1], &i__2, &ap[jc + 1]);
+ i__2 = *n - j;
+ zdscal_(&i__2, &tscal, &ap[jc + 1], &c__1);
+ i__2 = jc;
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ jc = jc + *n - j + 1;
+/* L210: */
+ }
+ z__1.r = smlnum * ap[1].r, z__1.i = smlnum * ap[1].i;
+ ap[1].r = z__1.r, ap[1].i = z__1.i;
+ }
+
+ } else if (*imat == 13) {
+
+/* Type 13: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1). */
+
+ zlarnv_(&c__2, &iseed[1], n, &b[1]);
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ zlarnv_(&c__4, &iseed[1], &i__2, &ap[jc]);
+ i__2 = jc + j - 1;
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ jc += j;
+/* L220: */
+ }
+ i__1 = *n * (*n + 1) / 2;
+ i__2 = *n * (*n + 1) / 2;
+ z__1.r = smlnum * ap[i__2].r, z__1.i = smlnum * ap[i__2].i;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j;
+ zlarnv_(&c__4, &iseed[1], &i__2, &ap[jc + 1]);
+ i__2 = jc;
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ jc = jc + *n - j + 1;
+/* L230: */
+ }
+ z__1.r = smlnum * ap[1].r, z__1.i = smlnum * ap[1].i;
+ ap[1].r = z__1.r, ap[1].i = z__1.i;
+ }
+
+ } else if (*imat == 14) {
+
+/* Type 14: T is diagonal with small numbers on the diagonal to */
+/* make the growth factor underflow, but a small right hand side */
+/* chosen so that the solution does not overflow. */
+
+ if (upper) {
+ jcount = 1;
+ jc = (*n - 1) * *n / 2 + 1;
+ for (j = *n; j >= 1; --j) {
+ i__1 = j - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = jc + i__ - 1;
+ ap[i__2].r = 0., ap[i__2].i = 0.;
+/* L240: */
+ }
+ if (jcount <= 2) {
+ i__1 = jc + j - 1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ } else {
+ i__1 = jc + j - 1;
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ ap[i__1].r = z__1.r, ap[i__1].i = z__1.i;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+ jc = jc - j + 1;
+/* L250: */
+ }
+ } else {
+ jcount = 1;
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - j;
+ ap[i__3].r = 0., ap[i__3].i = 0.;
+/* L260: */
+ }
+ if (jcount <= 2) {
+ i__2 = jc;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ } else {
+ i__2 = jc;
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+ jc = jc + *n - j + 1;
+/* L270: */
+ }
+ }
+
+/* Set the right hand side alternately zero and small. */
+
+ if (upper) {
+ b[1].r = 0., b[1].i = 0.;
+ for (i__ = *n; i__ >= 2; i__ += -2) {
+ i__1 = i__;
+ b[i__1].r = 0., b[i__1].i = 0.;
+ i__1 = i__ - 1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
+ b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+/* L280: */
+ }
+ } else {
+ i__1 = *n;
+ b[i__1].r = 0., b[i__1].i = 0.;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; i__ += 2) {
+ i__2 = i__;
+ b[i__2].r = 0., b[i__2].i = 0.;
+ i__2 = i__ + 1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L290: */
+ }
+ }
+
+ } else if (*imat == 15) {
+
+/* Type 15: Make the diagonal elements small to cause gradual */
+/* overflow when dividing by T(j,j). To control the amount of */
+/* scaling needed, the matrix is bidiagonal. */
+
+/* Computing MAX */
+ d__1 = 1., d__2 = (doublereal) (*n - 1);
+ texp = 1. / max(d__1,d__2);
+ tscal = pow_dd(&smlnum, &texp);
+ zlarnv_(&c__4, &iseed[1], n, &b[1]);
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 2;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - 1;
+ ap[i__3].r = 0., ap[i__3].i = 0.;
+/* L300: */
+ }
+ if (j > 1) {
+ i__2 = jc + j - 2;
+ ap[i__2].r = -1., ap[i__2].i = -1.;
+ }
+ i__2 = jc + j - 1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ jc += j;
+/* L310: */
+ }
+ i__1 = *n;
+ b[i__1].r = 1., b[i__1].i = 1.;
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - j;
+ ap[i__3].r = 0., ap[i__3].i = 0.;
+/* L320: */
+ }
+ if (j < *n) {
+ i__2 = jc + 1;
+ ap[i__2].r = -1., ap[i__2].i = -1.;
+ }
+ i__2 = jc;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ jc = jc + *n - j + 1;
+/* L330: */
+ }
+ b[1].r = 1., b[1].i = 1.;
+ }
+
+ } else if (*imat == 16) {
+
+/* Type 16: One zero diagonal element. */
+
+ iy = *n / 2 + 1;
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ zlarnv_(&c__4, &iseed[1], &j, &ap[jc]);
+ if (j != iy) {
+ i__2 = jc + j - 1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ } else {
+ i__2 = jc + j - 1;
+ ap[i__2].r = 0., ap[i__2].i = 0.;
+ }
+ jc += j;
+/* L340: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ zlarnv_(&c__4, &iseed[1], &i__2, &ap[jc]);
+ if (j != iy) {
+ i__2 = jc;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
+ ap[i__2].r = z__1.r, ap[i__2].i = z__1.i;
+ } else {
+ i__2 = jc;
+ ap[i__2].r = 0., ap[i__2].i = 0.;
+ }
+ jc = jc + *n - j + 1;
+/* L350: */
+ }
+ }
+ zlarnv_(&c__2, &iseed[1], n, &b[1]);
+ zdscal_(n, &c_b93, &b[1], &c__1);
+
+ } else if (*imat == 17) {
+
+/* Type 17: Make the offdiagonal elements large to cause overflow */
+/* when adding a column of T. In the non-transposed case, the */
+/* matrix is constructed to cause overflow when adding a column in */
+/* every other step. */
+
+ tscal = unfl / ulp;
+ tscal = (1. - ulp) / tscal;
+ i__1 = *n * (*n + 1) / 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ ap[i__2].r = 0., ap[i__2].i = 0.;
+/* L360: */
+ }
+ texp = 1.;
+ if (upper) {
+ jc = (*n - 1) * *n / 2 + 1;
+ for (j = *n; j >= 2; j += -2) {
+ i__1 = jc;
+ d__1 = -tscal / (doublereal) (*n + 1);
+ ap[i__1].r = d__1, ap[i__1].i = 0.;
+ i__1 = jc + j - 1;
+ ap[i__1].r = 1., ap[i__1].i = 0.;
+ i__1 = j;
+ d__1 = texp * (1. - ulp);
+ b[i__1].r = d__1, b[i__1].i = 0.;
+ jc = jc - j + 1;
+ i__1 = jc;
+ d__1 = -(tscal / (doublereal) (*n + 1)) / (doublereal) (*n +
+ 2);
+ ap[i__1].r = d__1, ap[i__1].i = 0.;
+ i__1 = jc + j - 2;
+ ap[i__1].r = 1., ap[i__1].i = 0.;
+ i__1 = j - 1;
+ d__1 = texp * (doublereal) (*n * *n + *n - 1);
+ b[i__1].r = d__1, b[i__1].i = 0.;
+ texp *= 2.;
+ jc = jc - j + 2;
+/* L370: */
+ }
+ d__1 = (doublereal) (*n + 1) / (doublereal) (*n + 2) * tscal;
+ b[1].r = d__1, b[1].i = 0.;
+ } else {
+ jc = 1;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; j += 2) {
+ i__2 = jc + *n - j;
+ d__1 = -tscal / (doublereal) (*n + 1);
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+ i__2 = jc;
+ ap[i__2].r = 1., ap[i__2].i = 0.;
+ i__2 = j;
+ d__1 = texp * (1. - ulp);
+ b[i__2].r = d__1, b[i__2].i = 0.;
+ jc = jc + *n - j + 1;
+ i__2 = jc + *n - j - 1;
+ d__1 = -(tscal / (doublereal) (*n + 1)) / (doublereal) (*n +
+ 2);
+ ap[i__2].r = d__1, ap[i__2].i = 0.;
+ i__2 = jc;
+ ap[i__2].r = 1., ap[i__2].i = 0.;
+ i__2 = j + 1;
+ d__1 = texp * (doublereal) (*n * *n + *n - 1);
+ b[i__2].r = d__1, b[i__2].i = 0.;
+ texp *= 2.;
+ jc = jc + *n - j;
+/* L380: */
+ }
+ i__1 = *n;
+ d__1 = (doublereal) (*n + 1) / (doublereal) (*n + 2) * tscal;
+ b[i__1].r = d__1, b[i__1].i = 0.;
+ }
+
+ } else if (*imat == 18) {
+
+/* Type 18: Generate a unit triangular matrix with elements */
+/* between -1 and 1, and make the right hand side large so that it */
+/* requires scaling. */
+
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ zlarnv_(&c__4, &iseed[1], &i__2, &ap[jc]);
+ i__2 = jc + j - 1;
+ ap[i__2].r = 0., ap[i__2].i = 0.;
+ jc += j;
+/* L390: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (j < *n) {
+ i__2 = *n - j;
+ zlarnv_(&c__4, &iseed[1], &i__2, &ap[jc + 1]);
+ }
+ i__2 = jc;
+ ap[i__2].r = 0., ap[i__2].i = 0.;
+ jc = jc + *n - j + 1;
+/* L400: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ zlarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = izamax_(n, &b[1], &c__1);
+ bnorm = z_abs(&b[iy]);
+ bscal = bignum / max(1.,bnorm);
+ zdscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 19) {
+
+/* Type 19: Generate a triangular matrix with elements between */
+/* BIGNUM/(n-1) and BIGNUM so that at least one of the column */
+/* norms will exceed BIGNUM. */
+/* 1/3/91: ZLATPS no longer can handle this case */
+
+/* Computing MAX */
+ d__1 = 1., d__2 = (doublereal) (*n - 1);
+ tleft = bignum / max(d__1,d__2);
+/* Computing MAX */
+ d__1 = 1., d__2 = (doublereal) (*n);
+ tscal = bignum * ((doublereal) (*n - 1) / max(d__1,d__2));
+ if (upper) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ zlarnv_(&c__5, &iseed[1], &j, &ap[jc]);
+ dlarnv_(&c__1, &iseed[1], &j, &rwork[1]);
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - 1;
+ i__4 = jc + i__ - 1;
+ d__1 = tleft + rwork[i__] * tscal;
+ z__1.r = d__1 * ap[i__4].r, z__1.i = d__1 * ap[i__4].i;
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+/* L410: */
+ }
+ jc += j;
+/* L420: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ zlarnv_(&c__5, &iseed[1], &i__2, &ap[jc]);
+ i__2 = *n - j + 1;
+ dlarnv_(&c__1, &iseed[1], &i__2, &rwork[1]);
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = jc + i__ - j;
+ i__4 = jc + i__ - j;
+ d__1 = tleft + rwork[i__ - j + 1] * tscal;
+ z__1.r = d__1 * ap[i__4].r, z__1.i = d__1 * ap[i__4].i;
+ ap[i__3].r = z__1.r, ap[i__3].i = z__1.i;
+/* L430: */
+ }
+ jc = jc + *n - j + 1;
+/* L440: */
+ }
+ }
+ zlarnv_(&c__2, &iseed[1], n, &b[1]);
+ zdscal_(n, &c_b93, &b[1], &c__1);
+ }
+
+/* Flip the matrix across its counter-diagonal if the transpose will */
+/* be used. */
+
+ if (! lsame_(trans, "N")) {
+ if (upper) {
+ jj = 1;
+ jr = *n * (*n + 1) / 2;
+ i__1 = *n / 2;
+ for (j = 1; j <= i__1; ++j) {
+ jl = jj;
+ i__2 = *n - j;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = jr - i__ + j;
+ t = ap[i__3].r;
+ i__3 = jr - i__ + j;
+ i__4 = jl;
+ ap[i__3].r = ap[i__4].r, ap[i__3].i = ap[i__4].i;
+ i__3 = jl;
+ ap[i__3].r = t, ap[i__3].i = 0.;
+ jl += i__;
+/* L450: */
+ }
+ jj = jj + j + 1;
+ jr -= *n - j + 1;
+/* L460: */
+ }
+ } else {
+ jl = 1;
+ jj = *n * (*n + 1) / 2;
+ i__1 = *n / 2;
+ for (j = 1; j <= i__1; ++j) {
+ jr = jj;
+ i__2 = *n - j;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = jl + i__ - j;
+ t = ap[i__3].r;
+ i__3 = jl + i__ - j;
+ i__4 = jr;
+ ap[i__3].r = ap[i__4].r, ap[i__3].i = ap[i__4].i;
+ i__3 = jr;
+ ap[i__3].r = t, ap[i__3].i = 0.;
+ jr -= i__;
+/* L470: */
+ }
+ jl = jl + *n - j + 1;
+ jj = jj - j - 1;
+/* L480: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZLATTP */
+
+} /* zlattp_ */
diff --git a/TESTING/LIN/zlattr.c b/TESTING/LIN/zlattr.c
new file mode 100644
index 0000000..7704595
--- /dev/null
+++ b/TESTING/LIN/zlattr.c
@@ -0,0 +1,1015 @@
+/* zlattr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__5 = 5;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c__4 = 4;
+static doublereal c_b92 = 2.;
+static integer c_n1 = -1;
+
+/* Subroutine */ int zlattr_(integer *imat, char *uplo, char *trans, char *
+ diag, integer *iseed, integer *n, doublecomplex *a, integer *lda,
+ doublecomplex *b, doublecomplex *work, doublereal *rwork, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+ double pow_dd(doublereal *, doublereal *), sqrt(doublereal);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ double z_abs(doublecomplex *);
+
+ /* Local variables */
+ doublereal c__;
+ integer i__, j;
+ doublecomplex s;
+ doublereal x, y, z__;
+ doublecomplex ra, rb;
+ integer kl, ku, iy;
+ doublereal ulp, sfac;
+ integer mode;
+ char path[3], dist[1];
+ doublereal unfl, rexp;
+ char type__[1];
+ doublereal texp;
+ extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, doublecomplex *);
+ doublecomplex star1, plus1, plus2;
+ doublereal bscal;
+ extern logical lsame_(char *, char *);
+ doublereal tscal, anorm, bnorm, tleft;
+ logical upper;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zrotg_(doublecomplex *,
+ doublecomplex *, doublereal *, doublecomplex *), zswap_(integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *), zlatb4_(
+ char *, integer *, integer *, integer *, char *, integer *,
+ integer *, doublereal *, integer *, doublereal *, char *), dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *), dlarnd_(integer *, integer *);
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ doublereal bignum, cndnum;
+ extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *,
+ doublereal *);
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
+ integer *);
+ integer jcount;
+ extern /* Subroutine */ int zlatms_(integer *, integer *, char *, integer
+ *, char *, doublereal *, integer *, doublereal *, doublereal *,
+ integer *, integer *, char *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ doublereal smlnum;
+ extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *,
+ doublecomplex *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLATTR generates a triangular test matrix in 2-dimensional storage. */
+/* IMAT and UPLO uniquely specify the properties of the test matrix, */
+/* which is returned in the array A. */
+
+/* Arguments */
+/* ========= */
+
+/* IMAT (input) INTEGER */
+/* An integer key describing which matrix to generate for this */
+/* path. */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A will be upper or lower */
+/* triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies whether the matrix or its transpose will be used. */
+/* = 'N': No transpose */
+/* = 'T': Transpose */
+/* = 'C': Conjugate transpose */
+
+/* DIAG (output) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* The seed vector for the random number generator (used in */
+/* ZLATMS). Modified on exit. */
+
+/* N (input) INTEGER */
+/* The order of the matrix to be generated. */
+
+/* A (output) COMPLEX*16 array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading N x N */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading N x N lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix and the strictly upper triangular part of A is not */
+/* referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (output) COMPLEX*16 array, dimension (N) */
+/* The right hand side vector, if IMAT > 10. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --iseed;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --b;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17);
+ s_copy(path + 1, "TR", (ftnlen)2, (ftnlen)2);
+ unfl = dlamch_("Safe minimum");
+ ulp = dlamch_("Epsilon") * dlamch_("Base");
+ smlnum = unfl;
+ bignum = (1. - ulp) / smlnum;
+ dlabad_(&smlnum, &bignum);
+ if (*imat >= 7 && *imat <= 10 || *imat == 18) {
+ *(unsigned char *)diag = 'U';
+ } else {
+ *(unsigned char *)diag = 'N';
+ }
+ *info = 0;
+
+/* Quick return if N.LE.0. */
+
+ if (*n <= 0) {
+ return 0;
+ }
+
+/* Call ZLATB4 to set parameters for CLATMS. */
+
+ upper = lsame_(uplo, "U");
+ if (upper) {
+ zlatb4_(path, imat, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ } else {
+ i__1 = -(*imat);
+ zlatb4_(path, &i__1, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum,
+ dist);
+ }
+
+/* IMAT <= 6: Non-unit triangular matrix */
+
+ if (*imat <= 6) {
+ zlatms_(n, n, dist, &iseed[1], type__, &rwork[1], &mode, &cndnum, &
+ anorm, &kl, &ku, "No packing", &a[a_offset], lda, &work[1],
+ info);
+
+/* IMAT > 6: Unit triangular matrix */
+/* The diagonal is deliberately set to something other than 1. */
+
+/* IMAT = 7: Matrix is the identity */
+
+ } else if (*imat == 7) {
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L10: */
+ }
+ i__2 = j + j * a_dim1;
+ a[i__2].r = (doublereal) j, a[i__2].i = 0.;
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * a_dim1;
+ a[i__2].r = (doublereal) j, a[i__2].i = 0.;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+/* IMAT > 7: Non-trivial unit triangular matrix */
+
+/* Generate a unit triangular matrix T with condition CNDNUM by */
+/* forming a triangular matrix with known singular values and */
+/* filling in the zero entries with Givens rotations. */
+
+ } else if (*imat <= 10) {
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L50: */
+ }
+ i__2 = j + j * a_dim1;
+ a[i__2].r = (doublereal) j, a[i__2].i = 0.;
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * a_dim1;
+ a[i__2].r = (doublereal) j, a[i__2].i = 0.;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+
+/* Since the trace of a unit triangular matrix is 1, the product */
+/* of its singular values must be 1. Let s = sqrt(CNDNUM), */
+/* x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2. */
+/* The following triangular matrix has singular values s, 1, 1, */
+/* ..., 1, 1/s: */
+
+/* 1 y y y ... y y z */
+/* 1 0 0 ... 0 0 y */
+/* 1 0 ... 0 0 y */
+/* . ... . . . */
+/* . . . . */
+/* 1 0 y */
+/* 1 y */
+/* 1 */
+
+/* To fill in the zeros, we first multiply by a matrix with small */
+/* condition number of the form */
+
+/* 1 0 0 0 0 ... */
+/* 1 + * 0 0 ... */
+/* 1 + 0 0 0 */
+/* 1 + * 0 0 */
+/* 1 + 0 0 */
+/* ... */
+/* 1 + 0 */
+/* 1 0 */
+/* 1 */
+
+/* Each element marked with a '*' is formed by taking the product */
+/* of the adjacent elements marked with '+'. The '*'s can be */
+/* chosen freely, and the '+'s are chosen so that the inverse of */
+/* T will have elements of the same magnitude as T. If the *'s in */
+/* both T and inv(T) have small magnitude, T is well conditioned. */
+/* The two offdiagonals of T are stored in WORK. */
+
+/* The product of these two matrices has the form */
+
+/* 1 y y y y y . y y z */
+/* 1 + * 0 0 . 0 0 y */
+/* 1 + 0 0 . 0 0 y */
+/* 1 + * . . . . */
+/* 1 + . . . . */
+/* . . . . . */
+/* . . . . */
+/* 1 + y */
+/* 1 y */
+/* 1 */
+
+/* Now we multiply by Givens rotations, using the fact that */
+
+/* [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ] */
+/* [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ] */
+/* and */
+/* [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ] */
+/* [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ] */
+
+/* where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4). */
+
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = z__2.r * .25, z__1.i = z__2.i * .25;
+ star1.r = z__1.r, star1.i = z__1.i;
+ sfac = .5;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = sfac * z__2.r, z__1.i = sfac * z__2.i;
+ plus1.r = z__1.r, plus1.i = z__1.i;
+ i__1 = *n;
+ for (j = 1; j <= i__1; j += 2) {
+ z_div(&z__1, &star1, &plus1);
+ plus2.r = z__1.r, plus2.i = z__1.i;
+ i__2 = j;
+ work[i__2].r = plus1.r, work[i__2].i = plus1.i;
+ i__2 = *n + j;
+ work[i__2].r = star1.r, work[i__2].i = star1.i;
+ if (j + 1 <= *n) {
+ i__2 = j + 1;
+ work[i__2].r = plus2.r, work[i__2].i = plus2.i;
+ i__2 = *n + j + 1;
+ work[i__2].r = 0., work[i__2].i = 0.;
+ z_div(&z__1, &star1, &plus2);
+ plus1.r = z__1.r, plus1.i = z__1.i;
+ rexp = dlarnd_(&c__2, &iseed[1]);
+ if (rexp < 0.) {
+ d__2 = 1. - rexp;
+ d__1 = -pow_dd(&sfac, &d__2);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ star1.r = z__1.r, star1.i = z__1.i;
+ } else {
+ d__2 = rexp + 1.;
+ d__1 = pow_dd(&sfac, &d__2);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ star1.r = z__1.r, star1.i = z__1.i;
+ }
+ }
+/* L90: */
+ }
+
+ x = sqrt(cndnum) - 1 / sqrt(cndnum);
+ if (*n > 2) {
+ y = sqrt(2. / (*n - 2)) * x;
+ } else {
+ y = 0.;
+ }
+ z__ = x * x;
+
+ if (upper) {
+ if (*n > 3) {
+ i__1 = *n - 3;
+ i__2 = *lda + 1;
+ zcopy_(&i__1, &work[1], &c__1, &a[a_dim1 * 3 + 2], &i__2);
+ if (*n > 4) {
+ i__1 = *n - 4;
+ i__2 = *lda + 1;
+ zcopy_(&i__1, &work[*n + 1], &c__1, &a[(a_dim1 << 2) + 2],
+ &i__2);
+ }
+ }
+ i__1 = *n - 1;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j * a_dim1 + 1;
+ a[i__2].r = y, a[i__2].i = 0.;
+ i__2 = j + *n * a_dim1;
+ a[i__2].r = y, a[i__2].i = 0.;
+/* L100: */
+ }
+ i__1 = *n * a_dim1 + 1;
+ a[i__1].r = z__, a[i__1].i = 0.;
+ } else {
+ if (*n > 3) {
+ i__1 = *n - 3;
+ i__2 = *lda + 1;
+ zcopy_(&i__1, &work[1], &c__1, &a[(a_dim1 << 1) + 3], &i__2);
+ if (*n > 4) {
+ i__1 = *n - 4;
+ i__2 = *lda + 1;
+ zcopy_(&i__1, &work[*n + 1], &c__1, &a[(a_dim1 << 1) + 4],
+ &i__2);
+ }
+ }
+ i__1 = *n - 1;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j + a_dim1;
+ a[i__2].r = y, a[i__2].i = 0.;
+ i__2 = *n + j * a_dim1;
+ a[i__2].r = y, a[i__2].i = 0.;
+/* L110: */
+ }
+ i__1 = *n + a_dim1;
+ a[i__1].r = z__, a[i__1].i = 0.;
+ }
+
+/* Fill in the zeros using Givens rotations. */
+
+ if (upper) {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + (j + 1) * a_dim1;
+ ra.r = a[i__2].r, ra.i = a[i__2].i;
+ rb.r = 2., rb.i = 0.;
+ zrotg_(&ra, &rb, &c__, &s);
+
+/* Multiply by [ c s; -conjg(s) c] on the left. */
+
+ if (*n > j + 1) {
+ i__2 = *n - j - 1;
+ zrot_(&i__2, &a[j + (j + 2) * a_dim1], lda, &a[j + 1 + (j
+ + 2) * a_dim1], lda, &c__, &s);
+ }
+
+/* Multiply by [-c -s; conjg(s) -c] on the right. */
+
+ if (j > 1) {
+ i__2 = j - 1;
+ d__1 = -c__;
+ z__1.r = -s.r, z__1.i = -s.i;
+ zrot_(&i__2, &a[(j + 1) * a_dim1 + 1], &c__1, &a[j *
+ a_dim1 + 1], &c__1, &d__1, &z__1);
+ }
+
+/* Negate A(J,J+1). */
+
+ i__2 = j + (j + 1) * a_dim1;
+ i__3 = j + (j + 1) * a_dim1;
+ z__1.r = -a[i__3].r, z__1.i = -a[i__3].i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L120: */
+ }
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + 1 + j * a_dim1;
+ ra.r = a[i__2].r, ra.i = a[i__2].i;
+ rb.r = 2., rb.i = 0.;
+ zrotg_(&ra, &rb, &c__, &s);
+ d_cnjg(&z__1, &s);
+ s.r = z__1.r, s.i = z__1.i;
+
+/* Multiply by [ c -s; conjg(s) c] on the right. */
+
+ if (*n > j + 1) {
+ i__2 = *n - j - 1;
+ z__1.r = -s.r, z__1.i = -s.i;
+ zrot_(&i__2, &a[j + 2 + (j + 1) * a_dim1], &c__1, &a[j +
+ 2 + j * a_dim1], &c__1, &c__, &z__1);
+ }
+
+/* Multiply by [-c s; -conjg(s) -c] on the left. */
+
+ if (j > 1) {
+ i__2 = j - 1;
+ d__1 = -c__;
+ zrot_(&i__2, &a[j + a_dim1], lda, &a[j + 1 + a_dim1], lda,
+ &d__1, &s);
+ }
+
+/* Negate A(J+1,J). */
+
+ i__2 = j + 1 + j * a_dim1;
+ i__3 = j + 1 + j * a_dim1;
+ z__1.r = -a[i__3].r, z__1.i = -a[i__3].i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L130: */
+ }
+ }
+
+/* IMAT > 10: Pathological test cases. These triangular matrices */
+/* are badly scaled or badly conditioned, so when used in solving a */
+/* triangular system they may cause overflow in the solution vector. */
+
+ } else if (*imat == 11) {
+
+/* Type 11: Generate a triangular matrix with elements between */
+/* -1 and 1. Give the diagonal norm 2 to make it well-conditioned. */
+/* Make the right hand side large so that it requires scaling. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ zlarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
+ i__2 = j + j * a_dim1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L140: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (j < *n) {
+ i__2 = *n - j;
+ zlarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
+ }
+ i__2 = j + j * a_dim1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L150: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ zlarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = izamax_(n, &b[1], &c__1);
+ bnorm = z_abs(&b[iy]);
+ bscal = bignum / max(1.,bnorm);
+ zdscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 12) {
+
+/* Type 12: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 12, the offdiagonal elements are small (CNORM(j) < 1). */
+
+ zlarnv_(&c__2, &iseed[1], n, &b[1]);
+/* Computing MAX */
+ d__1 = 1., d__2 = (doublereal) (*n - 1);
+ tscal = 1. / max(d__1,d__2);
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ zlarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
+ i__2 = j - 1;
+ zdscal_(&i__2, &tscal, &a[j * a_dim1 + 1], &c__1);
+ i__2 = j + j * a_dim1;
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L160: */
+ }
+ i__1 = *n + *n * a_dim1;
+ i__2 = *n + *n * a_dim1;
+ z__1.r = smlnum * a[i__2].r, z__1.i = smlnum * a[i__2].i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (j < *n) {
+ i__2 = *n - j;
+ zlarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
+ i__2 = *n - j;
+ zdscal_(&i__2, &tscal, &a[j + 1 + j * a_dim1], &c__1);
+ }
+ i__2 = j + j * a_dim1;
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L170: */
+ }
+ i__1 = a_dim1 + 1;
+ i__2 = a_dim1 + 1;
+ z__1.r = smlnum * a[i__2].r, z__1.i = smlnum * a[i__2].i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ }
+
+ } else if (*imat == 13) {
+
+/* Type 13: Make the first diagonal element in the solve small to */
+/* cause immediate overflow when dividing by T(j,j). */
+/* In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1). */
+
+ zlarnv_(&c__2, &iseed[1], n, &b[1]);
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ zlarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
+ i__2 = j + j * a_dim1;
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L180: */
+ }
+ i__1 = *n + *n * a_dim1;
+ i__2 = *n + *n * a_dim1;
+ z__1.r = smlnum * a[i__2].r, z__1.i = smlnum * a[i__2].i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (j < *n) {
+ i__2 = *n - j;
+ zlarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
+ }
+ i__2 = j + j * a_dim1;
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L190: */
+ }
+ i__1 = a_dim1 + 1;
+ i__2 = a_dim1 + 1;
+ z__1.r = smlnum * a[i__2].r, z__1.i = smlnum * a[i__2].i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ }
+
+ } else if (*imat == 14) {
+
+/* Type 14: T is diagonal with small numbers on the diagonal to */
+/* make the growth factor underflow, but a small right hand side */
+/* chosen so that the solution does not overflow. */
+
+ if (upper) {
+ jcount = 1;
+ for (j = *n; j >= 1; --j) {
+ i__1 = j - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + j * a_dim1;
+ a[i__2].r = 0., a[i__2].i = 0.;
+/* L200: */
+ }
+ if (jcount <= 2) {
+ i__1 = j + j * a_dim1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ } else {
+ i__1 = j + j * a_dim1;
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+/* L210: */
+ }
+ } else {
+ jcount = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L220: */
+ }
+ if (jcount <= 2) {
+ i__2 = j + j * a_dim1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ } else {
+ i__2 = j + j * a_dim1;
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ }
+ ++jcount;
+ if (jcount > 4) {
+ jcount = 1;
+ }
+/* L230: */
+ }
+ }
+
+/* Set the right hand side alternately zero and small. */
+
+ if (upper) {
+ b[1].r = 0., b[1].i = 0.;
+ for (i__ = *n; i__ >= 2; i__ += -2) {
+ i__1 = i__;
+ b[i__1].r = 0., b[i__1].i = 0.;
+ i__1 = i__ - 1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
+ b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+/* L240: */
+ }
+ } else {
+ i__1 = *n;
+ b[i__1].r = 0., b[i__1].i = 0.;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; i__ += 2) {
+ i__2 = i__;
+ b[i__2].r = 0., b[i__2].i = 0.;
+ i__2 = i__ + 1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = smlnum * z__2.r, z__1.i = smlnum * z__2.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L250: */
+ }
+ }
+
+ } else if (*imat == 15) {
+
+/* Type 15: Make the diagonal elements small to cause gradual */
+/* overflow when dividing by T(j,j). To control the amount of */
+/* scaling needed, the matrix is bidiagonal. */
+
+/* Computing MAX */
+ d__1 = 1., d__2 = (doublereal) (*n - 1);
+ texp = 1. / max(d__1,d__2);
+ tscal = pow_dd(&smlnum, &texp);
+ zlarnv_(&c__4, &iseed[1], n, &b[1]);
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 2;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L260: */
+ }
+ if (j > 1) {
+ i__2 = j - 1 + j * a_dim1;
+ a[i__2].r = -1., a[i__2].i = -1.;
+ }
+ i__2 = j + j * a_dim1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L270: */
+ }
+ i__1 = *n;
+ b[i__1].r = 1., b[i__1].i = 1.;
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 2; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L280: */
+ }
+ if (j < *n) {
+ i__2 = j + 1 + j * a_dim1;
+ a[i__2].r = -1., a[i__2].i = -1.;
+ }
+ i__2 = j + j * a_dim1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L290: */
+ }
+ b[1].r = 1., b[1].i = 1.;
+ }
+
+ } else if (*imat == 16) {
+
+/* Type 16: One zero diagonal element. */
+
+ iy = *n / 2 + 1;
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ zlarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
+ if (j != iy) {
+ i__2 = j + j * a_dim1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ } else {
+ i__2 = j + j * a_dim1;
+ a[i__2].r = 0., a[i__2].i = 0.;
+ }
+/* L300: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (j < *n) {
+ i__2 = *n - j;
+ zlarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
+ }
+ if (j != iy) {
+ i__2 = j + j * a_dim1;
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = z__2.r * 2., z__1.i = z__2.i * 2.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ } else {
+ i__2 = j + j * a_dim1;
+ a[i__2].r = 0., a[i__2].i = 0.;
+ }
+/* L310: */
+ }
+ }
+ zlarnv_(&c__2, &iseed[1], n, &b[1]);
+ zdscal_(n, &c_b92, &b[1], &c__1);
+
+ } else if (*imat == 17) {
+
+/* Type 17: Make the offdiagonal elements large to cause overflow */
+/* when adding a column of T. In the non-transposed case, the */
+/* matrix is constructed to cause overflow when adding a column in */
+/* every other step. */
+
+ tscal = unfl / ulp;
+ tscal = (1. - ulp) / tscal;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L320: */
+ }
+/* L330: */
+ }
+ texp = 1.;
+ if (upper) {
+ for (j = *n; j >= 2; j += -2) {
+ i__1 = j * a_dim1 + 1;
+ d__1 = -tscal / (doublereal) (*n + 1);
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ i__1 = j + j * a_dim1;
+ a[i__1].r = 1., a[i__1].i = 0.;
+ i__1 = j;
+ d__1 = texp * (1. - ulp);
+ b[i__1].r = d__1, b[i__1].i = 0.;
+ i__1 = (j - 1) * a_dim1 + 1;
+ d__1 = -(tscal / (doublereal) (*n + 1)) / (doublereal) (*n +
+ 2);
+ a[i__1].r = d__1, a[i__1].i = 0.;
+ i__1 = j - 1 + (j - 1) * a_dim1;
+ a[i__1].r = 1., a[i__1].i = 0.;
+ i__1 = j - 1;
+ d__1 = texp * (doublereal) (*n * *n + *n - 1);
+ b[i__1].r = d__1, b[i__1].i = 0.;
+ texp *= 2.;
+/* L340: */
+ }
+ d__1 = (doublereal) (*n + 1) / (doublereal) (*n + 2) * tscal;
+ b[1].r = d__1, b[1].i = 0.;
+ } else {
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; j += 2) {
+ i__2 = *n + j * a_dim1;
+ d__1 = -tscal / (doublereal) (*n + 1);
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ i__2 = j + j * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+ i__2 = j;
+ d__1 = texp * (1. - ulp);
+ b[i__2].r = d__1, b[i__2].i = 0.;
+ i__2 = *n + (j + 1) * a_dim1;
+ d__1 = -(tscal / (doublereal) (*n + 1)) / (doublereal) (*n +
+ 2);
+ a[i__2].r = d__1, a[i__2].i = 0.;
+ i__2 = j + 1 + (j + 1) * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+ i__2 = j + 1;
+ d__1 = texp * (doublereal) (*n * *n + *n - 1);
+ b[i__2].r = d__1, b[i__2].i = 0.;
+ texp *= 2.;
+/* L350: */
+ }
+ i__1 = *n;
+ d__1 = (doublereal) (*n + 1) / (doublereal) (*n + 2) * tscal;
+ b[i__1].r = d__1, b[i__1].i = 0.;
+ }
+
+ } else if (*imat == 18) {
+
+/* Type 18: Generate a unit triangular matrix with elements */
+/* between -1 and 1, and make the right hand side large so that it */
+/* requires scaling. */
+
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ zlarnv_(&c__4, &iseed[1], &i__2, &a[j * a_dim1 + 1]);
+ i__2 = j + j * a_dim1;
+ a[i__2].r = 0., a[i__2].i = 0.;
+/* L360: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (j < *n) {
+ i__2 = *n - j;
+ zlarnv_(&c__4, &iseed[1], &i__2, &a[j + 1 + j * a_dim1]);
+ }
+ i__2 = j + j * a_dim1;
+ a[i__2].r = 0., a[i__2].i = 0.;
+/* L370: */
+ }
+ }
+
+/* Set the right hand side so that the largest value is BIGNUM. */
+
+ zlarnv_(&c__2, &iseed[1], n, &b[1]);
+ iy = izamax_(n, &b[1], &c__1);
+ bnorm = z_abs(&b[iy]);
+ bscal = bignum / max(1.,bnorm);
+ zdscal_(n, &bscal, &b[1], &c__1);
+
+ } else if (*imat == 19) {
+
+/* Type 19: Generate a triangular matrix with elements between */
+/* BIGNUM/(n-1) and BIGNUM so that at least one of the column */
+/* norms will exceed BIGNUM. */
+/* 1/3/91: ZLATRS no longer can handle this case */
+
+/* Computing MAX */
+ d__1 = 1., d__2 = (doublereal) (*n - 1);
+ tleft = bignum / max(d__1,d__2);
+/* Computing MAX */
+ d__1 = 1., d__2 = (doublereal) (*n);
+ tscal = bignum * ((doublereal) (*n - 1) / max(d__1,d__2));
+ if (upper) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ zlarnv_(&c__5, &iseed[1], &j, &a[j * a_dim1 + 1]);
+ dlarnv_(&c__1, &iseed[1], &j, &rwork[1]);
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ d__1 = tleft + rwork[i__] * tscal;
+ z__1.r = d__1 * a[i__4].r, z__1.i = d__1 * a[i__4].i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L380: */
+ }
+/* L390: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ zlarnv_(&c__5, &iseed[1], &i__2, &a[j + j * a_dim1]);
+ i__2 = *n - j + 1;
+ dlarnv_(&c__1, &iseed[1], &i__2, &rwork[1]);
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ d__1 = tleft + rwork[i__ - j + 1] * tscal;
+ z__1.r = d__1 * a[i__4].r, z__1.i = d__1 * a[i__4].i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L400: */
+ }
+/* L410: */
+ }
+ }
+ zlarnv_(&c__2, &iseed[1], n, &b[1]);
+ zdscal_(n, &c_b92, &b[1], &c__1);
+ }
+
+/* Flip the matrix if the transpose will be used. */
+
+ if (! lsame_(trans, "N")) {
+ if (upper) {
+ i__1 = *n / 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - (j << 1) + 1;
+ zswap_(&i__2, &a[j + j * a_dim1], lda, &a[j + 1 + (*n - j + 1)
+ * a_dim1], &c_n1);
+/* L420: */
+ }
+ } else {
+ i__1 = *n / 2;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - (j << 1) + 1;
+ i__3 = -(*lda);
+ zswap_(&i__2, &a[j + j * a_dim1], &c__1, &a[*n - j + 1 + (j +
+ 1) * a_dim1], &i__3);
+/* L430: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZLATTR */
+
+} /* zlattr_ */
diff --git a/TESTING/LIN/zlavhe.c b/TESTING/LIN/zlavhe.c
new file mode 100644
index 0000000..db7a500
--- /dev/null
+++ b/TESTING/LIN/zlavhe.c
@@ -0,0 +1,679 @@
+/* zlavhe.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zlavhe_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublecomplex *a, integer *lda, integer *ipiv,
+ doublecomplex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer j, k;
+ doublecomplex t1, t2, d11, d12, d21, d22;
+ integer kp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zgeru_(integer *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *)
+ , zswap_(integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), xerbla_(char *, integer *), zlacgv_(integer *,
+ doublecomplex *, integer *);
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAVHE performs one of the matrix-vector operations */
+/* x := A*x or x := A^H*x, */
+/* where x is an N element vector and A is one of the factors */
+/* from the symmetric factorization computed by ZHETRF. */
+/* ZHETRF produces a factorization of the form */
+/* U * D * U^H or L * D * L^H, */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, U^H (or L^H) is the conjugate transpose of */
+/* U (or L), and D is Hermitian and block diagonal with 1 x 1 and */
+/* 2 x 2 diagonal blocks. The multipliers for the transformations */
+/* and the upper or lower triangular parts of the diagonal blocks */
+/* are stored in the leading upper or lower triangle of the 2-D */
+/* array A. */
+
+/* If TRANS = 'N' or 'n', ZLAVHE multiplies either by U or U * D */
+/* (or L or L * D). */
+/* If TRANS = 'C' or 'c', ZLAVHE multiplies either by U^H or D * U^H */
+/* (or L^H or D * L^H ). */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1 */
+/* On entry, UPLO specifies whether the triangular matrix */
+/* stored in A is upper or lower triangular. */
+/* UPLO = 'U' or 'u' The matrix is upper triangular. */
+/* UPLO = 'L' or 'l' The matrix is lower triangular. */
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1 */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+/* TRANS = 'N' or 'n' x := A*x. */
+/* TRANS = 'C' or 'c' x := A^H*x. */
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1 */
+/* On entry, DIAG specifies whether the diagonal blocks are */
+/* assumed to be unit matrices: */
+/* DIAG = 'U' or 'u' Diagonal blocks are unit matrices. */
+/* DIAG = 'N' or 'n' Diagonal blocks are non-unit. */
+/* Unchanged on exit. */
+
+/* N - INTEGER */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* NRHS - INTEGER */
+/* On entry, NRHS specifies the number of right hand sides, */
+/* i.e., the number of vectors x to be multiplied by A. */
+/* NRHS must be at least zero. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array, dimension( LDA, N ) */
+/* On entry, A contains a block diagonal matrix and the */
+/* multipliers of the transformations used to obtain it, */
+/* stored as a 2-D triangular matrix. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling ( sub ) program. LDA must be at least */
+/* max( 1, N ). */
+/* Unchanged on exit. */
+
+/* IPIV - INTEGER array, dimension( N ) */
+/* On entry, IPIV contains the vector of pivot indices as */
+/* determined by ZSYTRF or ZHETRF. */
+/* If IPIV( K ) = K, no interchange was done. */
+/* If IPIV( K ) <> K but IPIV( K ) > 0, then row K was inter- */
+/* changed with row IPIV( K ) and a 1 x 1 pivot block was used. */
+/* If IPIV( K ) < 0 and UPLO = 'U', then row K-1 was exchanged */
+/* with row | IPIV( K ) | and a 2 x 2 pivot block was used. */
+/* If IPIV( K ) < 0 and UPLO = 'L', then row K+1 was exchanged */
+/* with row | IPIV( K ) | and a 2 x 2 pivot block was used. */
+
+/* B - COMPLEX*16 array, dimension( LDB, NRHS ) */
+/* On entry, B contains NRHS vectors of length N. */
+/* On exit, B is overwritten with the product A * B. */
+
+/* LDB - INTEGER */
+/* On entry, LDB contains the leading dimension of B as */
+/* declared in the calling program. LDB must be at least */
+/* max( 1, N ). */
+/* Unchanged on exit. */
+
+/* INFO - INTEGER */
+/* INFO is the error flag. */
+/* On exit, a value of 0 indicates a successful exit. */
+/* A negative value, say -K, indicates that the K-th argument */
+/* has an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "C")) {
+ *info = -2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLAVHE ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+/* ------------------------------------------ */
+
+/* Compute B := A * B (No transpose) */
+
+/* ------------------------------------------ */
+ if (lsame_(trans, "N")) {
+
+/* Compute B := U*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop forward applying the transformations. */
+
+ k = 1;
+L10:
+ if (k > *n) {
+ goto L30;
+ }
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 pivot block */
+
+/* Multiply by the diagonal element if forming U * D. */
+
+ if (nounit) {
+ zscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformation. */
+
+ i__1 = k - 1;
+ zgeru_(&i__1, nrhs, &c_b1, &a[k * a_dim1 + 1], &c__1, &b[
+ k + b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ ++k;
+ } else {
+
+/* 2 x 2 pivot block */
+
+/* Multiply by the diagonal block if forming U * D. */
+
+ if (nounit) {
+ i__1 = k + k * a_dim1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = k + (k + 1) * a_dim1;
+ d12.r = a[i__1].r, d12.i = a[i__1].i;
+ d_cnjg(&z__1, &d12);
+ d21.r = z__1.r, d21.i = z__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + 1 + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ z__2.r = d11.r * t1.r - d11.i * t1.i, z__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ z__3.r = d12.r * t2.r - d12.i * t2.i, z__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ z__2.r = d21.r * t1.r - d21.i * t1.i, z__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ z__3.r = d22.r * t2.r - d22.i * t2.i, z__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L20: */
+ }
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformations. */
+
+ i__1 = k - 1;
+ zgeru_(&i__1, nrhs, &c_b1, &a[k * a_dim1 + 1], &c__1, &b[
+ k + b_dim1], ldb, &b[b_dim1 + 1], ldb);
+ i__1 = k - 1;
+ zgeru_(&i__1, nrhs, &c_b1, &a[(k + 1) * a_dim1 + 1], &
+ c__1, &b[k + 1 + b_dim1], ldb, &b[b_dim1 + 1],
+ ldb);
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ k += 2;
+ }
+ goto L10;
+L30:
+
+/* Compute B := L*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . */
+
+ ;
+ } else {
+
+/* Loop backward applying the transformations to B. */
+
+ k = *n;
+L40:
+ if (k < 1) {
+ goto L60;
+ }
+
+/* Test the pivot index. If greater than zero, a 1 x 1 */
+/* pivot was used, otherwise a 2 x 2 pivot was used. */
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 pivot block: */
+
+/* Multiply by the diagonal element if forming L * D. */
+
+ if (nounit) {
+ zscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+ kp = ipiv[k];
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ zgeru_(&i__1, nrhs, &c_b1, &a[k + 1 + k * a_dim1], &c__1,
+ &b[k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ --k;
+
+ } else {
+
+/* 2 x 2 pivot block: */
+
+/* Multiply by the diagonal block if forming L * D. */
+
+ if (nounit) {
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = k + k * a_dim1;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = k + (k - 1) * a_dim1;
+ d21.r = a[i__1].r, d21.i = a[i__1].i;
+ d_cnjg(&z__1, &d21);
+ d12.r = z__1.r, d12.i = z__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k - 1 + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k - 1 + j * b_dim1;
+ z__2.r = d11.r * t1.r - d11.i * t1.i, z__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ z__3.r = d12.r * t2.r - d12.i * t2.i, z__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + j * b_dim1;
+ z__2.r = d21.r * t1.r - d21.i * t1.i, z__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ z__3.r = d22.r * t2.r - d22.i * t2.i, z__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L50: */
+ }
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ zgeru_(&i__1, nrhs, &c_b1, &a[k + 1 + k * a_dim1], &c__1,
+ &b[k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+ i__1 = *n - k;
+ zgeru_(&i__1, nrhs, &c_b1, &a[k + 1 + (k - 1) * a_dim1], &
+ c__1, &b[k - 1 + b_dim1], ldb, &b[k + 1 + b_dim1],
+ ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ k += -2;
+ }
+ goto L40;
+L60:
+ ;
+ }
+/* -------------------------------------------------- */
+
+/* Compute B := A^H * B (conjugate transpose) */
+
+/* -------------------------------------------------- */
+ } else {
+
+/* Form B := U^H*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+/* and U^H = inv(U^H(1))*P(1)* ... *inv(U^H(m))*P(m) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop backward applying the transformations. */
+
+ k = *n;
+L70:
+ if (k < 1) {
+ goto L90;
+ }
+
+/* 1 x 1 pivot block. */
+
+ if (ipiv[k] > 0) {
+ if (k > 1) {
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+/* y = y - B' conjg(x), */
+/* where x is a column of A and y is a row of B. */
+
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = k - 1;
+ zgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[k * a_dim1 + 1], &c__1, &c_b1, &b[k + b_dim1],
+ ldb);
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ }
+ if (nounit) {
+ zscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+ --k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ if (k > 2) {
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k - 1) {
+ zswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformations */
+/* y = y - B' conjg(x), */
+/* where x is a block column of A and y is a block */
+/* row of B. */
+
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = k - 2;
+ zgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[k * a_dim1 + 1], &c__1, &c_b1, &b[k + b_dim1],
+ ldb);
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+
+ zlacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
+ i__1 = k - 2;
+ zgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[(k - 1) * a_dim1 + 1], &c__1, &c_b1, &b[k - 1
+ + b_dim1], ldb);
+ zlacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = k + k * a_dim1;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = k - 1 + k * a_dim1;
+ d12.r = a[i__1].r, d12.i = a[i__1].i;
+ d_cnjg(&z__1, &d12);
+ d21.r = z__1.r, d21.i = z__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k - 1 + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k - 1 + j * b_dim1;
+ z__2.r = d11.r * t1.r - d11.i * t1.i, z__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ z__3.r = d12.r * t2.r - d12.i * t2.i, z__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + j * b_dim1;
+ z__2.r = d21.r * t1.r - d21.i * t1.i, z__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ z__3.r = d22.r * t2.r - d22.i * t2.i, z__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L80: */
+ }
+ }
+ k += -2;
+ }
+ goto L70;
+L90:
+
+/* Form B := L^H*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) */
+/* and L^H = inv(L^H(m))*P(m)* ... *inv(L^H(1))*P(1) */
+
+ ;
+ } else {
+
+/* Loop forward applying the L-transformations. */
+
+ k = 1;
+L100:
+ if (k > *n) {
+ goto L120;
+ }
+
+/* 1 x 1 pivot block */
+
+ if (ipiv[k] > 0) {
+ if (k < *n) {
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = *n - k;
+ zgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[k + 1 + b_dim1]
+, ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, &b[k
+ + b_dim1], ldb);
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ }
+ if (nounit) {
+ zscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+ ++k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ if (k < *n - 1) {
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k + 1) {
+ zswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ zlacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ zgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[k + 2 + b_dim1]
+, ldb, &a[k + 2 + (k + 1) * a_dim1], &c__1, &c_b1,
+ &b[k + 1 + b_dim1], ldb);
+ zlacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
+
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ zgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[k + 2 + b_dim1]
+, ldb, &a[k + 2 + k * a_dim1], &c__1, &c_b1, &b[k
+ + b_dim1], ldb);
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ i__1 = k + k * a_dim1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = k + 1 + k * a_dim1;
+ d21.r = a[i__1].r, d21.i = a[i__1].i;
+ d_cnjg(&z__1, &d21);
+ d12.r = z__1.r, d12.i = z__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + 1 + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ z__2.r = d11.r * t1.r - d11.i * t1.i, z__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ z__3.r = d12.r * t2.r - d12.i * t2.i, z__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ z__2.r = d21.r * t1.r - d21.i * t1.i, z__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ z__3.r = d22.r * t2.r - d22.i * t2.i, z__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L110: */
+ }
+ }
+ k += 2;
+ }
+ goto L100;
+L120:
+ ;
+ }
+
+ }
+ return 0;
+
+/* End of ZLAVHE */
+
+} /* zlavhe_ */
diff --git a/TESTING/LIN/zlavhp.c b/TESTING/LIN/zlavhp.c
new file mode 100644
index 0000000..aaf364f
--- /dev/null
+++ b/TESTING/LIN/zlavhp.c
@@ -0,0 +1,681 @@
+/* zlavhp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zlavhp_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublecomplex *a, integer *ipiv, doublecomplex *b,
+ integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer j, k;
+ doublecomplex t1, t2, d11, d12, d21, d22;
+ integer kc, kp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zgeru_(integer *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *)
+ , zswap_(integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), xerbla_(char *, integer *), zlacgv_(integer *,
+ doublecomplex *, integer *);
+ integer kcnext;
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAVHP performs one of the matrix-vector operations */
+/* x := A*x or x := A^H*x, */
+/* where x is an N element vector and A is one of the factors */
+/* from the symmetric factorization computed by ZHPTRF. */
+/* ZHPTRF produces a factorization of the form */
+/* U * D * U^H or L * D * L^H, */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, U^H (or L^H) is the conjugate transpose of */
+/* U (or L), and D is Hermitian and block diagonal with 1 x 1 and */
+/* 2 x 2 diagonal blocks. The multipliers for the transformations */
+/* and the upper or lower triangular parts of the diagonal blocks */
+/* are stored columnwise in packed format in the linear array A. */
+
+/* If TRANS = 'N' or 'n', ZLAVHP multiplies either by U or U * D */
+/* (or L or L * D). */
+/* If TRANS = 'C' or 'c', ZLAVHP multiplies either by U^H or D * U^H */
+/* (or L^H or D * L^H ). */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1 */
+/* On entry, UPLO specifies whether the triangular matrix */
+/* stored in A is upper or lower triangular. */
+/* UPLO = 'U' or 'u' The matrix is upper triangular. */
+/* UPLO = 'L' or 'l' The matrix is lower triangular. */
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1 */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+/* TRANS = 'N' or 'n' x := A*x. */
+/* TRANS = 'C' or 'c' x := A^H*x. */
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1 */
+/* On entry, DIAG specifies whether the diagonal blocks are */
+/* assumed to be unit matrices, as follows: */
+/* DIAG = 'U' or 'u' Diagonal blocks are unit matrices. */
+/* DIAG = 'N' or 'n' Diagonal blocks are non-unit. */
+/* Unchanged on exit. */
+
+/* N - INTEGER */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* NRHS - INTEGER */
+/* On entry, NRHS specifies the number of right hand sides, */
+/* i.e., the number of vectors x to be multiplied by A. */
+/* NRHS must be at least zero. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array, dimension( N*(N+1)/2 ) */
+/* On entry, A contains a block diagonal matrix and the */
+/* multipliers of the transformations used to obtain it, */
+/* stored as a packed triangular matrix. */
+/* Unchanged on exit. */
+
+/* IPIV - INTEGER array, dimension( N ) */
+/* On entry, IPIV contains the vector of pivot indices as */
+/* determined by ZSPTRF or ZHPTRF. */
+/* If IPIV( K ) = K, no interchange was done. */
+/* If IPIV( K ) <> K but IPIV( K ) > 0, then row K was inter- */
+/* changed with row IPIV( K ) and a 1 x 1 pivot block was used. */
+/* If IPIV( K ) < 0 and UPLO = 'U', then row K-1 was exchanged */
+/* with row | IPIV( K ) | and a 2 x 2 pivot block was used. */
+/* If IPIV( K ) < 0 and UPLO = 'L', then row K+1 was exchanged */
+/* with row | IPIV( K ) | and a 2 x 2 pivot block was used. */
+
+/* B - COMPLEX*16 array, dimension( LDB, NRHS ) */
+/* On entry, B contains NRHS vectors of length N. */
+/* On exit, B is overwritten with the product A * B. */
+
+/* LDB - INTEGER */
+/* On entry, LDB contains the leading dimension of B as */
+/* declared in the calling program. LDB must be at least */
+/* max( 1, N ). */
+/* Unchanged on exit. */
+
+/* INFO - INTEGER */
+/* INFO is the error flag. */
+/* On exit, a value of 0 indicates a successful exit. */
+/* A negative value, say -K, indicates that the K-th argument */
+/* has an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --a;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "C")) {
+ *info = -2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLAVHP ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+/* ------------------------------------------ */
+
+/* Compute B := A * B (No transpose) */
+
+/* ------------------------------------------ */
+ if (lsame_(trans, "N")) {
+
+/* Compute B := U*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop forward applying the transformations. */
+
+ k = 1;
+ kc = 1;
+L10:
+ if (k > *n) {
+ goto L30;
+ }
+
+/* 1 x 1 pivot block */
+
+ if (ipiv[k] > 0) {
+
+/* Multiply by the diagonal element if forming U * D. */
+
+ if (nounit) {
+ zscal_(nrhs, &a[kc + k - 1], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformation. */
+
+ i__1 = k - 1;
+ zgeru_(&i__1, nrhs, &c_b1, &a[kc], &c__1, &b[k + b_dim1],
+ ldb, &b[b_dim1 + 1], ldb);
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ kc += k;
+ ++k;
+ } else {
+
+/* 2 x 2 pivot block */
+
+ kcnext = kc + k;
+
+/* Multiply by the diagonal block if forming U * D. */
+
+ if (nounit) {
+ i__1 = kcnext - 1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = kcnext + k;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = kcnext + k - 1;
+ d12.r = a[i__1].r, d12.i = a[i__1].i;
+ d_cnjg(&z__1, &d12);
+ d21.r = z__1.r, d21.i = z__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + 1 + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ z__2.r = d11.r * t1.r - d11.i * t1.i, z__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ z__3.r = d12.r * t2.r - d12.i * t2.i, z__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ z__2.r = d21.r * t1.r - d21.i * t1.i, z__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ z__3.r = d22.r * t2.r - d22.i * t2.i, z__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L20: */
+ }
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformations. */
+
+ i__1 = k - 1;
+ zgeru_(&i__1, nrhs, &c_b1, &a[kc], &c__1, &b[k + b_dim1],
+ ldb, &b[b_dim1 + 1], ldb);
+ i__1 = k - 1;
+ zgeru_(&i__1, nrhs, &c_b1, &a[kcnext], &c__1, &b[k + 1 +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ kc = kcnext + k + 1;
+ k += 2;
+ }
+ goto L10;
+L30:
+
+/* Compute B := L*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . */
+
+ ;
+ } else {
+
+/* Loop backward applying the transformations to B. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L40:
+ if (k < 1) {
+ goto L60;
+ }
+ kc -= *n - k + 1;
+
+/* Test the pivot index. If greater than zero, a 1 x 1 */
+/* pivot was used, otherwise a 2 x 2 pivot was used. */
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 pivot block: */
+
+/* Multiply by the diagonal element if forming L * D. */
+
+ if (nounit) {
+ zscal_(nrhs, &a[kc], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+ kp = ipiv[k];
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ zgeru_(&i__1, nrhs, &c_b1, &a[kc + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ --k;
+
+ } else {
+
+/* 2 x 2 pivot block: */
+
+ kcnext = kc - (*n - k + 2);
+
+/* Multiply by the diagonal block if forming L * D. */
+
+ if (nounit) {
+ i__1 = kcnext;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = kc;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = kcnext + 1;
+ d21.r = a[i__1].r, d21.i = a[i__1].i;
+ d_cnjg(&z__1, &d21);
+ d12.r = z__1.r, d12.i = z__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k - 1 + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k - 1 + j * b_dim1;
+ z__2.r = d11.r * t1.r - d11.i * t1.i, z__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ z__3.r = d12.r * t2.r - d12.i * t2.i, z__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + j * b_dim1;
+ z__2.r = d21.r * t1.r - d21.i * t1.i, z__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ z__3.r = d22.r * t2.r - d22.i * t2.i, z__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L50: */
+ }
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ zgeru_(&i__1, nrhs, &c_b1, &a[kc + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+ i__1 = *n - k;
+ zgeru_(&i__1, nrhs, &c_b1, &a[kcnext + 2], &c__1, &b[k -
+ 1 + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ kc = kcnext;
+ k += -2;
+ }
+ goto L40;
+L60:
+ ;
+ }
+/* ------------------------------------------------- */
+
+/* Compute B := A^H * B (conjugate transpose) */
+
+/* ------------------------------------------------- */
+ } else {
+
+/* Form B := U^H*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+/* and U^H = inv(U^H(1))*P(1)* ... *inv(U^H(m))*P(m) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop backward applying the transformations. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L70:
+ if (k < 1) {
+ goto L90;
+ }
+ kc -= k;
+
+/* 1 x 1 pivot block. */
+
+ if (ipiv[k] > 0) {
+ if (k > 1) {
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation: */
+/* y := y - B' * conjg(x) */
+/* where x is a column of A and y is a row of B. */
+
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = k - 1;
+ zgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[kc], &c__1, &c_b1, &b[k + b_dim1], ldb);
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ }
+ if (nounit) {
+ zscal_(nrhs, &a[kc + k - 1], &b[k + b_dim1], ldb);
+ }
+ --k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ kcnext = kc - (k - 1);
+ if (k > 2) {
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k - 1) {
+ zswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformations. */
+
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = k - 2;
+ zgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[kc], &c__1, &c_b1, &b[k + b_dim1], ldb);
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+
+ zlacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
+ i__1 = k - 2;
+ zgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[kcnext], &c__1, &c_b1, &b[k - 1 + b_dim1],
+ ldb);
+ zlacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ i__1 = kc - 1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = kc + k - 1;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = kc + k - 2;
+ d12.r = a[i__1].r, d12.i = a[i__1].i;
+ d_cnjg(&z__1, &d12);
+ d21.r = z__1.r, d21.i = z__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k - 1 + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k - 1 + j * b_dim1;
+ z__2.r = d11.r * t1.r - d11.i * t1.i, z__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ z__3.r = d12.r * t2.r - d12.i * t2.i, z__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + j * b_dim1;
+ z__2.r = d21.r * t1.r - d21.i * t1.i, z__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ z__3.r = d22.r * t2.r - d22.i * t2.i, z__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L80: */
+ }
+ }
+ kc = kcnext;
+ k += -2;
+ }
+ goto L70;
+L90:
+
+/* Form B := L^H*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) */
+/* and L^H = inv(L(m))*P(m)* ... *inv(L(1))*P(1) */
+
+ ;
+ } else {
+
+/* Loop forward applying the L-transformations. */
+
+ k = 1;
+ kc = 1;
+L100:
+ if (k > *n) {
+ goto L120;
+ }
+
+/* 1 x 1 pivot block */
+
+ if (ipiv[k] > 0) {
+ if (k < *n) {
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = *n - k;
+ zgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[k + 1 + b_dim1]
+, ldb, &a[kc + 1], &c__1, &c_b1, &b[k + b_dim1],
+ ldb);
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ }
+ if (nounit) {
+ zscal_(nrhs, &a[kc], &b[k + b_dim1], ldb);
+ }
+ kc = kc + *n - k + 1;
+ ++k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ kcnext = kc + *n - k + 1;
+ if (k < *n - 1) {
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k + 1) {
+ zswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ zlacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ zgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[k + 2 + b_dim1]
+, ldb, &a[kcnext + 1], &c__1, &c_b1, &b[k + 1 +
+ b_dim1], ldb);
+ zlacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
+
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ zgemv_("Conjugate", &i__1, nrhs, &c_b1, &b[k + 2 + b_dim1]
+, ldb, &a[kc + 2], &c__1, &c_b1, &b[k + b_dim1],
+ ldb);
+ zlacgv_(nrhs, &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ i__1 = kc;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = kcnext;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = kc + 1;
+ d21.r = a[i__1].r, d21.i = a[i__1].i;
+ d_cnjg(&z__1, &d21);
+ d12.r = z__1.r, d12.i = z__1.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + 1 + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ z__2.r = d11.r * t1.r - d11.i * t1.i, z__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ z__3.r = d12.r * t2.r - d12.i * t2.i, z__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ z__2.r = d21.r * t1.r - d21.i * t1.i, z__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ z__3.r = d22.r * t2.r - d22.i * t2.i, z__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L110: */
+ }
+ }
+ kc = kcnext + (*n - k);
+ k += 2;
+ }
+ goto L100;
+L120:
+ ;
+ }
+
+ }
+ return 0;
+
+/* End of ZLAVHP */
+
+} /* zlavhp_ */
diff --git a/TESTING/LIN/zlavsp.c b/TESTING/LIN/zlavsp.c
new file mode 100644
index 0000000..a1069de
--- /dev/null
+++ b/TESTING/LIN/zlavsp.c
@@ -0,0 +1,661 @@
+/* zlavsp.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zlavsp_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublecomplex *a, integer *ipiv, doublecomplex *b,
+ integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Local variables */
+ integer j, k;
+ doublecomplex t1, t2, d11, d12, d21, d22;
+ integer kc, kp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zgeru_(integer *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *)
+ , zswap_(integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), xerbla_(char *, integer *);
+ integer kcnext;
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAVSP performs one of the matrix-vector operations */
+/* x := A*x or x := A^T*x, */
+/* where x is an N element vector and A is one of the factors */
+/* from the symmetric factorization computed by ZSPTRF. */
+/* ZSPTRF produces a factorization of the form */
+/* U * D * U^T or L * D * L^T, */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, U^T (or L^T) is the transpose of */
+/* U (or L), and D is symmetric and block diagonal with 1 x 1 and */
+/* 2 x 2 diagonal blocks. The multipliers for the transformations */
+/* and the upper or lower triangular parts of the diagonal blocks */
+/* are stored columnwise in packed format in the linear array A. */
+
+/* If TRANS = 'N' or 'n', ZLAVSP multiplies either by U or U * D */
+/* (or L or L * D). */
+/* If TRANS = 'C' or 'c', ZLAVSP multiplies either by U^T or D * U^T */
+/* (or L^T or D * L^T ). */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1 */
+/* On entry, UPLO specifies whether the triangular matrix */
+/* stored in A is upper or lower triangular. */
+/* UPLO = 'U' or 'u' The matrix is upper triangular. */
+/* UPLO = 'L' or 'l' The matrix is lower triangular. */
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1 */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+/* TRANS = 'N' or 'n' x := A*x. */
+/* TRANS = 'T' or 't' x := A^T*x. */
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1 */
+/* On entry, DIAG specifies whether the diagonal blocks are */
+/* assumed to be unit matrices, as follows: */
+/* DIAG = 'U' or 'u' Diagonal blocks are unit matrices. */
+/* DIAG = 'N' or 'n' Diagonal blocks are non-unit. */
+/* Unchanged on exit. */
+
+/* N - INTEGER */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* NRHS - INTEGER */
+/* On entry, NRHS specifies the number of right hand sides, */
+/* i.e., the number of vectors x to be multiplied by A. */
+/* NRHS must be at least zero. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array, dimension( N*(N+1)/2 ) */
+/* On entry, A contains a block diagonal matrix and the */
+/* multipliers of the transformations used to obtain it, */
+/* stored as a packed triangular matrix. */
+/* Unchanged on exit. */
+
+/* IPIV - INTEGER array, dimension( N ) */
+/* On entry, IPIV contains the vector of pivot indices as */
+/* determined by ZSPTRF. */
+/* If IPIV( K ) = K, no interchange was done. */
+/* If IPIV( K ) <> K but IPIV( K ) > 0, then row K was inter- */
+/* changed with row IPIV( K ) and a 1 x 1 pivot block was used. */
+/* If IPIV( K ) < 0 and UPLO = 'U', then row K-1 was exchanged */
+/* with row | IPIV( K ) | and a 2 x 2 pivot block was used. */
+/* If IPIV( K ) < 0 and UPLO = 'L', then row K+1 was exchanged */
+/* with row | IPIV( K ) | and a 2 x 2 pivot block was used. */
+
+/* B - COMPLEX*16 array, dimension( LDB, NRHS ) */
+/* On entry, B contains NRHS vectors of length N. */
+/* On exit, B is overwritten with the product A * B. */
+
+/* LDB - INTEGER */
+/* On entry, LDB contains the leading dimension of B as */
+/* declared in the calling program. LDB must be at least */
+/* max( 1, N ). */
+/* Unchanged on exit. */
+
+/* INFO - INTEGER */
+/* INFO is the error flag. */
+/* On exit, a value of 0 indicates a successful exit. */
+/* A negative value, say -K, indicates that the K-th argument */
+/* has an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ --a;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T")) {
+ *info = -2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*ldb < max(1,*n)) {
+ *info = -8;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLAVSP ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+/* ------------------------------------------ */
+
+/* Compute B := A * B (No transpose) */
+
+/* ------------------------------------------ */
+ if (lsame_(trans, "N")) {
+
+/* Compute B := U*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop forward applying the transformations. */
+
+ k = 1;
+ kc = 1;
+L10:
+ if (k > *n) {
+ goto L30;
+ }
+
+/* 1 x 1 pivot block */
+
+ if (ipiv[k] > 0) {
+
+/* Multiply by the diagonal element if forming U * D. */
+
+ if (nounit) {
+ zscal_(nrhs, &a[kc + k - 1], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformation. */
+
+ i__1 = k - 1;
+ zgeru_(&i__1, nrhs, &c_b1, &a[kc], &c__1, &b[k + b_dim1],
+ ldb, &b[b_dim1 + 1], ldb);
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ kc += k;
+ ++k;
+ } else {
+
+/* 2 x 2 pivot block */
+
+ kcnext = kc + k;
+
+/* Multiply by the diagonal block if forming U * D. */
+
+ if (nounit) {
+ i__1 = kcnext - 1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = kcnext + k;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = kcnext + k - 1;
+ d12.r = a[i__1].r, d12.i = a[i__1].i;
+ d21.r = d12.r, d21.i = d12.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + 1 + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ z__2.r = d11.r * t1.r - d11.i * t1.i, z__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ z__3.r = d12.r * t2.r - d12.i * t2.i, z__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ z__2.r = d21.r * t1.r - d21.i * t1.i, z__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ z__3.r = d22.r * t2.r - d22.i * t2.i, z__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L20: */
+ }
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformations. */
+
+ i__1 = k - 1;
+ zgeru_(&i__1, nrhs, &c_b1, &a[kc], &c__1, &b[k + b_dim1],
+ ldb, &b[b_dim1 + 1], ldb);
+ i__1 = k - 1;
+ zgeru_(&i__1, nrhs, &c_b1, &a[kcnext], &c__1, &b[k + 1 +
+ b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ kc = kcnext + k + 1;
+ k += 2;
+ }
+ goto L10;
+L30:
+
+/* Compute B := L*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . */
+
+ ;
+ } else {
+
+/* Loop backward applying the transformations to B. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L40:
+ if (k < 1) {
+ goto L60;
+ }
+ kc -= *n - k + 1;
+
+/* Test the pivot index. If greater than zero, a 1 x 1 */
+/* pivot was used, otherwise a 2 x 2 pivot was used. */
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 pivot block: */
+
+/* Multiply by the diagonal element if forming L * D. */
+
+ if (nounit) {
+ zscal_(nrhs, &a[kc], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+ kp = ipiv[k];
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ zgeru_(&i__1, nrhs, &c_b1, &a[kc + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ --k;
+
+ } else {
+
+/* 2 x 2 pivot block: */
+
+ kcnext = kc - (*n - k + 2);
+
+/* Multiply by the diagonal block if forming L * D. */
+
+ if (nounit) {
+ i__1 = kcnext;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = kc;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = kcnext + 1;
+ d21.r = a[i__1].r, d21.i = a[i__1].i;
+ d12.r = d21.r, d12.i = d21.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k - 1 + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k - 1 + j * b_dim1;
+ z__2.r = d11.r * t1.r - d11.i * t1.i, z__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ z__3.r = d12.r * t2.r - d12.i * t2.i, z__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + j * b_dim1;
+ z__2.r = d21.r * t1.r - d21.i * t1.i, z__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ z__3.r = d22.r * t2.r - d22.i * t2.i, z__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L50: */
+ }
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ zgeru_(&i__1, nrhs, &c_b1, &a[kc + 1], &c__1, &b[k +
+ b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+ i__1 = *n - k;
+ zgeru_(&i__1, nrhs, &c_b1, &a[kcnext + 2], &c__1, &b[k -
+ 1 + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ kc = kcnext;
+ k += -2;
+ }
+ goto L40;
+L60:
+ ;
+ }
+/* ------------------------------------------------- */
+
+/* Compute B := A^T * B (transpose) */
+
+/* ------------------------------------------------- */
+ } else {
+
+/* Form B := U^T*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+/* and U^T = inv(U^T(1))*P(1)* ... *inv(U^T(m))*P(m) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop backward applying the transformations. */
+
+ k = *n;
+ kc = *n * (*n + 1) / 2 + 1;
+L70:
+ if (k < 1) {
+ goto L90;
+ }
+ kc -= k;
+
+/* 1 x 1 pivot block. */
+
+ if (ipiv[k] > 0) {
+ if (k > 1) {
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation: */
+/* y := y - B' * conjg(x) */
+/* where x is a column of A and y is a row of B. */
+
+ i__1 = k - 1;
+ zgemv_("Transpose", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[kc], &c__1, &c_b1, &b[k + b_dim1], ldb);
+ }
+ if (nounit) {
+ zscal_(nrhs, &a[kc + k - 1], &b[k + b_dim1], ldb);
+ }
+ --k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ kcnext = kc - (k - 1);
+ if (k > 2) {
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k - 1) {
+ zswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformations. */
+
+ i__1 = k - 2;
+ zgemv_("Transpose", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[kc], &c__1, &c_b1, &b[k + b_dim1], ldb);
+
+ i__1 = k - 2;
+ zgemv_("Transpose", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[kcnext], &c__1, &c_b1, &b[k - 1 + b_dim1],
+ ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ i__1 = kc - 1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = kc + k - 1;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = kc + k - 2;
+ d12.r = a[i__1].r, d12.i = a[i__1].i;
+ d21.r = d12.r, d21.i = d12.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k - 1 + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k - 1 + j * b_dim1;
+ z__2.r = d11.r * t1.r - d11.i * t1.i, z__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ z__3.r = d12.r * t2.r - d12.i * t2.i, z__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + j * b_dim1;
+ z__2.r = d21.r * t1.r - d21.i * t1.i, z__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ z__3.r = d22.r * t2.r - d22.i * t2.i, z__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L80: */
+ }
+ }
+ kc = kcnext;
+ k += -2;
+ }
+ goto L70;
+L90:
+
+/* Form B := L^T*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) */
+/* and L^T = inv(L(m))*P(m)* ... *inv(L(1))*P(1) */
+
+ ;
+ } else {
+
+/* Loop forward applying the L-transformations. */
+
+ k = 1;
+ kc = 1;
+L100:
+ if (k > *n) {
+ goto L120;
+ }
+
+/* 1 x 1 pivot block */
+
+ if (ipiv[k] > 0) {
+ if (k < *n) {
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ i__1 = *n - k;
+ zgemv_("Transpose", &i__1, nrhs, &c_b1, &b[k + 1 + b_dim1]
+, ldb, &a[kc + 1], &c__1, &c_b1, &b[k + b_dim1],
+ ldb);
+ }
+ if (nounit) {
+ zscal_(nrhs, &a[kc], &b[k + b_dim1], ldb);
+ }
+ kc = kc + *n - k + 1;
+ ++k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ kcnext = kc + *n - k + 1;
+ if (k < *n - 1) {
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k + 1) {
+ zswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ i__1 = *n - k - 1;
+ zgemv_("Transpose", &i__1, nrhs, &c_b1, &b[k + 2 + b_dim1]
+, ldb, &a[kcnext + 1], &c__1, &c_b1, &b[k + 1 +
+ b_dim1], ldb);
+
+ i__1 = *n - k - 1;
+ zgemv_("Transpose", &i__1, nrhs, &c_b1, &b[k + 2 + b_dim1]
+, ldb, &a[kc + 2], &c__1, &c_b1, &b[k + b_dim1],
+ ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ i__1 = kc;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = kcnext;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = kc + 1;
+ d21.r = a[i__1].r, d21.i = a[i__1].i;
+ d12.r = d21.r, d12.i = d21.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + 1 + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ z__2.r = d11.r * t1.r - d11.i * t1.i, z__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ z__3.r = d12.r * t2.r - d12.i * t2.i, z__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ z__2.r = d21.r * t1.r - d21.i * t1.i, z__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ z__3.r = d22.r * t2.r - d22.i * t2.i, z__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L110: */
+ }
+ }
+ kc = kcnext + (*n - k);
+ k += 2;
+ }
+ goto L100;
+L120:
+ ;
+ }
+
+ }
+ return 0;
+
+/* End of ZLAVSP */
+
+} /* zlavsp_ */
diff --git a/TESTING/LIN/zlavsy.c b/TESTING/LIN/zlavsy.c
new file mode 100644
index 0000000..da68ff7
--- /dev/null
+++ b/TESTING/LIN/zlavsy.c
@@ -0,0 +1,651 @@
+/* zlavsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zlavsy_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublecomplex *a, integer *lda, integer *ipiv,
+ doublecomplex *b, integer *ldb, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Local variables */
+ integer j, k;
+ doublecomplex t1, t2, d11, d12, d21, d22;
+ integer kp;
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zgeru_(integer *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *)
+ , zswap_(integer *, doublecomplex *, integer *, doublecomplex *,
+ integer *), xerbla_(char *, integer *);
+ logical nounit;
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAVSY performs one of the matrix-vector operations */
+/* x := A*x or x := A'*x, */
+/* where x is an N element vector and A is one of the factors */
+/* from the symmetric factorization computed by ZSYTRF. */
+/* ZSYTRF produces a factorization of the form */
+/* U * D * U' or L * D * L' , */
+/* where U (or L) is a product of permutation and unit upper (lower) */
+/* triangular matrices, U' (or L') is the transpose of */
+/* U (or L), and D is symmetric and block diagonal with 1 x 1 and */
+/* 2 x 2 diagonal blocks. The multipliers for the transformations */
+/* and the upper or lower triangular parts of the diagonal blocks */
+/* are stored in the leading upper or lower triangle of the 2-D */
+/* array A. */
+
+/* If TRANS = 'N' or 'n', ZLAVSY multiplies either by U or U * D */
+/* (or L or L * D). */
+/* If TRANS = 'T' or 't', ZLAVSY multiplies either by U' or D * U' */
+/* (or L' or D * L' ). */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1 */
+/* On entry, UPLO specifies whether the triangular matrix */
+/* stored in A is upper or lower triangular. */
+/* UPLO = 'U' or 'u' The matrix is upper triangular. */
+/* UPLO = 'L' or 'l' The matrix is lower triangular. */
+/* Unchanged on exit. */
+
+/* TRANS - CHARACTER*1 */
+/* On entry, TRANS specifies the operation to be performed as */
+/* follows: */
+/* TRANS = 'N' or 'n' x := A*x. */
+/* TRANS = 'T' or 't' x := A'*x. */
+/* Unchanged on exit. */
+
+/* DIAG - CHARACTER*1 */
+/* On entry, DIAG specifies whether the diagonal blocks are */
+/* assumed to be unit matrices: */
+/* DIAG = 'U' or 'u' Diagonal blocks are unit matrices. */
+/* DIAG = 'N' or 'n' Diagonal blocks are non-unit. */
+/* Unchanged on exit. */
+
+/* N - INTEGER */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* NRHS - INTEGER */
+/* On entry, NRHS specifies the number of right hand sides, */
+/* i.e., the number of vectors x to be multiplied by A. */
+/* NRHS must be at least zero. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array, dimension( LDA, N ) */
+/* On entry, A contains a block diagonal matrix and the */
+/* multipliers of the transformations used to obtain it, */
+/* stored as a 2-D triangular matrix. */
+/* Unchanged on exit. */
+
+/* LDA - INTEGER */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling ( sub ) program. LDA must be at least */
+/* max( 1, N ). */
+/* Unchanged on exit. */
+
+/* IPIV - INTEGER array, dimension( N ) */
+/* On entry, IPIV contains the vector of pivot indices as */
+/* determined by ZSYTRF or ZHETRF. */
+/* If IPIV( K ) = K, no interchange was done. */
+/* If IPIV( K ) <> K but IPIV( K ) > 0, then row K was inter- */
+/* changed with row IPIV( K ) and a 1 x 1 pivot block was used. */
+/* If IPIV( K ) < 0 and UPLO = 'U', then row K-1 was exchanged */
+/* with row | IPIV( K ) | and a 2 x 2 pivot block was used. */
+/* If IPIV( K ) < 0 and UPLO = 'L', then row K+1 was exchanged */
+/* with row | IPIV( K ) | and a 2 x 2 pivot block was used. */
+
+/* B - COMPLEX*16 array, dimension( LDB, NRHS ) */
+/* On entry, B contains NRHS vectors of length N. */
+/* On exit, B is overwritten with the product A * B. */
+
+/* LDB - INTEGER */
+/* On entry, LDB contains the leading dimension of B as */
+/* declared in the calling program. LDB must be at least */
+/* max( 1, N ). */
+/* Unchanged on exit. */
+
+/* INFO - INTEGER */
+/* INFO is the error flag. */
+/* On exit, a value of 0 indicates a successful exit. */
+/* A negative value, say -K, indicates that the K-th argument */
+/* has an illegal value. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --ipiv;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ *info = -1;
+ } else if (! lsame_(trans, "N") && ! lsame_(trans,
+ "T")) {
+ *info = -2;
+ } else if (! lsame_(diag, "U") && ! lsame_(diag,
+ "N")) {
+ *info = -3;
+ } else if (*n < 0) {
+ *info = -4;
+ } else if (*lda < max(1,*n)) {
+ *info = -6;
+ } else if (*ldb < max(1,*n)) {
+ *info = -9;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLAVSY ", &i__1);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+ nounit = lsame_(diag, "N");
+/* ------------------------------------------ */
+
+/* Compute B := A * B (No transpose) */
+
+/* ------------------------------------------ */
+ if (lsame_(trans, "N")) {
+
+/* Compute B := U*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop forward applying the transformations. */
+
+ k = 1;
+L10:
+ if (k > *n) {
+ goto L30;
+ }
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 pivot block */
+
+/* Multiply by the diagonal element if forming U * D. */
+
+ if (nounit) {
+ zscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformation. */
+
+ i__1 = k - 1;
+ zgeru_(&i__1, nrhs, &c_b1, &a[k * a_dim1 + 1], &c__1, &b[
+ k + b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ ++k;
+ } else {
+
+/* 2 x 2 pivot block */
+
+/* Multiply by the diagonal block if forming U * D. */
+
+ if (nounit) {
+ i__1 = k + k * a_dim1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = k + (k + 1) * a_dim1;
+ d12.r = a[i__1].r, d12.i = a[i__1].i;
+ d21.r = d12.r, d21.i = d12.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + 1 + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ z__2.r = d11.r * t1.r - d11.i * t1.i, z__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ z__3.r = d12.r * t2.r - d12.i * t2.i, z__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ z__2.r = d21.r * t1.r - d21.i * t1.i, z__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ z__3.r = d22.r * t2.r - d22.i * t2.i, z__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L20: */
+ }
+ }
+
+/* Multiply by P(K) * inv(U(K)) if K > 1. */
+
+ if (k > 1) {
+
+/* Apply the transformations. */
+
+ i__1 = k - 1;
+ zgeru_(&i__1, nrhs, &c_b1, &a[k * a_dim1 + 1], &c__1, &b[
+ k + b_dim1], ldb, &b[b_dim1 + 1], ldb);
+ i__1 = k - 1;
+ zgeru_(&i__1, nrhs, &c_b1, &a[(k + 1) * a_dim1 + 1], &
+ c__1, &b[k + 1 + b_dim1], ldb, &b[b_dim1 + 1],
+ ldb);
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ k += 2;
+ }
+ goto L10;
+L30:
+
+/* Compute B := L*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . */
+
+ ;
+ } else {
+
+/* Loop backward applying the transformations to B. */
+
+ k = *n;
+L40:
+ if (k < 1) {
+ goto L60;
+ }
+
+/* Test the pivot index. If greater than zero, a 1 x 1 */
+/* pivot was used, otherwise a 2 x 2 pivot was used. */
+
+ if (ipiv[k] > 0) {
+
+/* 1 x 1 pivot block: */
+
+/* Multiply by the diagonal element if forming L * D. */
+
+ if (nounit) {
+ zscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+ kp = ipiv[k];
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ zgeru_(&i__1, nrhs, &c_b1, &a[k + 1 + k * a_dim1], &c__1,
+ &b[k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ --k;
+
+ } else {
+
+/* 2 x 2 pivot block: */
+
+/* Multiply by the diagonal block if forming L * D. */
+
+ if (nounit) {
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = k + k * a_dim1;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = k + (k - 1) * a_dim1;
+ d21.r = a[i__1].r, d21.i = a[i__1].i;
+ d12.r = d21.r, d12.i = d21.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k - 1 + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k - 1 + j * b_dim1;
+ z__2.r = d11.r * t1.r - d11.i * t1.i, z__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ z__3.r = d12.r * t2.r - d12.i * t2.i, z__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + j * b_dim1;
+ z__2.r = d21.r * t1.r - d21.i * t1.i, z__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ z__3.r = d22.r * t2.r - d22.i * t2.i, z__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L50: */
+ }
+ }
+
+/* Multiply by P(K) * inv(L(K)) if K < N. */
+
+ if (k != *n) {
+
+/* Apply the transformation. */
+
+ i__1 = *n - k;
+ zgeru_(&i__1, nrhs, &c_b1, &a[k + 1 + k * a_dim1], &c__1,
+ &b[k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+ i__1 = *n - k;
+ zgeru_(&i__1, nrhs, &c_b1, &a[k + 1 + (k - 1) * a_dim1], &
+ c__1, &b[k - 1 + b_dim1], ldb, &b[k + 1 + b_dim1],
+ ldb);
+
+/* Interchange if a permutation was applied at the */
+/* K-th step of the factorization. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+ }
+ k += -2;
+ }
+ goto L40;
+L60:
+ ;
+ }
+/* ---------------------------------------- */
+
+/* Compute B := A' * B (transpose) */
+
+/* ---------------------------------------- */
+ } else if (lsame_(trans, "T")) {
+
+/* Form B := U'*B */
+/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
+/* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m) */
+
+ if (lsame_(uplo, "U")) {
+
+/* Loop backward applying the transformations. */
+
+ k = *n;
+L70:
+ if (k < 1) {
+ goto L90;
+ }
+
+/* 1 x 1 pivot block. */
+
+ if (ipiv[k] > 0) {
+ if (k > 1) {
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ i__1 = k - 1;
+ zgemv_("Transpose", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[k * a_dim1 + 1], &c__1, &c_b1, &b[k + b_dim1],
+ ldb);
+ }
+ if (nounit) {
+ zscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+ --k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ if (k > 2) {
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k - 1) {
+ zswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformations */
+
+ i__1 = k - 2;
+ zgemv_("Transpose", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[k * a_dim1 + 1], &c__1, &c_b1, &b[k + b_dim1],
+ ldb);
+ i__1 = k - 2;
+ zgemv_("Transpose", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
+ &a[(k - 1) * a_dim1 + 1], &c__1, &c_b1, &b[k - 1
+ + b_dim1], ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ i__1 = k - 1 + (k - 1) * a_dim1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = k + k * a_dim1;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = k - 1 + k * a_dim1;
+ d12.r = a[i__1].r, d12.i = a[i__1].i;
+ d21.r = d12.r, d21.i = d12.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k - 1 + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k - 1 + j * b_dim1;
+ z__2.r = d11.r * t1.r - d11.i * t1.i, z__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ z__3.r = d12.r * t2.r - d12.i * t2.i, z__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + j * b_dim1;
+ z__2.r = d21.r * t1.r - d21.i * t1.i, z__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ z__3.r = d22.r * t2.r - d22.i * t2.i, z__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L80: */
+ }
+ }
+ k += -2;
+ }
+ goto L70;
+L90:
+
+/* Form B := L'*B */
+/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) */
+/* and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1) */
+
+ ;
+ } else {
+
+/* Loop forward applying the L-transformations. */
+
+ k = 1;
+L100:
+ if (k > *n) {
+ goto L120;
+ }
+
+/* 1 x 1 pivot block */
+
+ if (ipiv[k] > 0) {
+ if (k < *n) {
+
+/* Interchange if P(K) != I. */
+
+ kp = ipiv[k];
+ if (kp != k) {
+ zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ i__1 = *n - k;
+ zgemv_("Transpose", &i__1, nrhs, &c_b1, &b[k + 1 + b_dim1]
+, ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, &b[k
+ + b_dim1], ldb);
+ }
+ if (nounit) {
+ zscal_(nrhs, &a[k + k * a_dim1], &b[k + b_dim1], ldb);
+ }
+ ++k;
+
+/* 2 x 2 pivot block. */
+
+ } else {
+ if (k < *n - 1) {
+
+/* Interchange if P(K) != I. */
+
+ kp = (i__1 = ipiv[k], abs(i__1));
+ if (kp != k + 1) {
+ zswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1],
+ ldb);
+ }
+
+/* Apply the transformation */
+
+ i__1 = *n - k - 1;
+ zgemv_("Transpose", &i__1, nrhs, &c_b1, &b[k + 2 + b_dim1]
+, ldb, &a[k + 2 + (k + 1) * a_dim1], &c__1, &c_b1,
+ &b[k + 1 + b_dim1], ldb);
+ i__1 = *n - k - 1;
+ zgemv_("Transpose", &i__1, nrhs, &c_b1, &b[k + 2 + b_dim1]
+, ldb, &a[k + 2 + k * a_dim1], &c__1, &c_b1, &b[k
+ + b_dim1], ldb);
+ }
+
+/* Multiply by the diagonal block if non-unit. */
+
+ if (nounit) {
+ i__1 = k + k * a_dim1;
+ d11.r = a[i__1].r, d11.i = a[i__1].i;
+ i__1 = k + 1 + (k + 1) * a_dim1;
+ d22.r = a[i__1].r, d22.i = a[i__1].i;
+ i__1 = k + 1 + k * a_dim1;
+ d21.r = a[i__1].r, d21.i = a[i__1].i;
+ d12.r = d21.r, d12.i = d21.i;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = k + j * b_dim1;
+ t1.r = b[i__2].r, t1.i = b[i__2].i;
+ i__2 = k + 1 + j * b_dim1;
+ t2.r = b[i__2].r, t2.i = b[i__2].i;
+ i__2 = k + j * b_dim1;
+ z__2.r = d11.r * t1.r - d11.i * t1.i, z__2.i = d11.r *
+ t1.i + d11.i * t1.r;
+ z__3.r = d12.r * t2.r - d12.i * t2.i, z__3.i = d12.r *
+ t2.i + d12.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ i__2 = k + 1 + j * b_dim1;
+ z__2.r = d21.r * t1.r - d21.i * t1.i, z__2.i = d21.r *
+ t1.i + d21.i * t1.r;
+ z__3.r = d22.r * t2.r - d22.i * t2.i, z__3.i = d22.r *
+ t2.i + d22.i * t2.r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+/* L110: */
+ }
+ }
+ k += 2;
+ }
+ goto L100;
+L120:
+ ;
+ }
+ }
+ return 0;
+
+/* End of ZLAVSY */
+
+} /* zlavsy_ */
diff --git a/TESTING/LIN/zlqt01.c b/TESTING/LIN/zlqt01.c
new file mode 100644
index 0000000..b374c02
--- /dev/null
+++ b/TESTING/LIN/zlqt01.c
@@ -0,0 +1,229 @@
+/* zlqt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {-1e10,-1e10};
+static doublecomplex c_b10 = {0.,0.};
+static doublecomplex c_b15 = {-1.,0.};
+static doublecomplex c_b16 = {1.,0.};
+static doublereal c_b24 = -1.;
+static doublereal c_b25 = 1.;
+
+/* Subroutine */ int zlqt01_(integer *m, integer *n, doublecomplex *a,
+ doublecomplex *af, doublecomplex *q, doublecomplex *l, integer *lda,
+ doublecomplex *tau, doublecomplex *work, integer *lwork, doublereal *
+ rwork, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
+ q_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal eps;
+ integer info;
+ doublereal resid, anorm;
+ integer minmn;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zherk_(char *, char *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int zgelqf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *
+), zlacpy_(char *, integer *, integer *, doublecomplex *, integer
+ *, doublecomplex *, integer *), zlaset_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *);
+ extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zunglq_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLQT01 tests ZGELQF, which computes the LQ factorization of an m-by-n */
+/* matrix A, and partially tests ZUNGLQ which forms the n-by-n */
+/* orthogonal matrix Q. */
+
+/* ZLQT01 compares L with A*Q', and checks that Q is orthogonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The m-by-n matrix A. */
+
+/* AF (output) COMPLEX*16 array, dimension (LDA,N) */
+/* Details of the LQ factorization of A, as returned by ZGELQF. */
+/* See ZGELQF for further details. */
+
+/* Q (output) COMPLEX*16 array, dimension (LDA,N) */
+/* The n-by-n orthogonal matrix Q. */
+
+/* L (workspace) COMPLEX*16 array, dimension (LDA,max(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and L. */
+/* LDA >= max(M,N). */
+
+/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by ZGELQF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(M,N)) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ l_dim1 = *lda;
+ l_offset = 1 + l_dim1;
+ l -= l_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ minmn = min(*m,*n);
+ eps = dlamch_("Epsilon");
+
+/* Copy the matrix A to the array AF. */
+
+ zlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+
+/* Factorize the matrix A in the array AF. */
+
+ s_copy(srnamc_1.srnamt, "ZGELQF", (ftnlen)32, (ftnlen)6);
+ zgelqf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy details of Q */
+
+ zlaset_("Full", n, n, &c_b1, &c_b1, &q[q_offset], lda);
+ if (*n > 1) {
+ i__1 = *n - 1;
+ zlacpy_("Upper", m, &i__1, &af[(af_dim1 << 1) + 1], lda, &q[(q_dim1 <<
+ 1) + 1], lda);
+ }
+
+/* Generate the n-by-n matrix Q */
+
+ s_copy(srnamc_1.srnamt, "ZUNGLQ", (ftnlen)32, (ftnlen)6);
+ zunglq_(n, n, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy L */
+
+ zlaset_("Full", m, n, &c_b10, &c_b10, &l[l_offset], lda);
+ zlacpy_("Lower", m, n, &af[af_offset], lda, &l[l_offset], lda);
+
+/* Compute L - A*Q' */
+
+ zgemm_("No transpose", "Conjugate transpose", m, n, n, &c_b15, &a[
+ a_offset], lda, &q[q_offset], lda, &c_b16, &l[l_offset], lda);
+
+/* Compute norm( L - Q'*A ) / ( N * norm(A) * EPS ) . */
+
+ anorm = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ resid = zlange_("1", m, n, &l[l_offset], lda, &rwork[1]);
+ if (anorm > 0.) {
+ result[1] = resid / (doublereal) max(1,*n) / anorm / eps;
+ } else {
+ result[1] = 0.;
+ }
+
+/* Compute I - Q*Q' */
+
+ zlaset_("Full", n, n, &c_b10, &c_b16, &l[l_offset], lda);
+ zherk_("Upper", "No transpose", n, n, &c_b24, &q[q_offset], lda, &c_b25, &
+ l[l_offset], lda);
+
+/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
+
+ resid = zlansy_("1", "Upper", n, &l[l_offset], lda, &rwork[1]);
+
+ result[2] = resid / (doublereal) max(1,*n) / eps;
+
+ return 0;
+
+/* End of ZLQT01 */
+
+} /* zlqt01_ */
diff --git a/TESTING/LIN/zlqt02.c b/TESTING/LIN/zlqt02.c
new file mode 100644
index 0000000..c1ccb46
--- /dev/null
+++ b/TESTING/LIN/zlqt02.c
@@ -0,0 +1,220 @@
+/* zlqt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {-1e10,-1e10};
+static doublecomplex c_b8 = {0.,0.};
+static doublecomplex c_b13 = {-1.,0.};
+static doublecomplex c_b14 = {1.,0.};
+static doublereal c_b22 = -1.;
+static doublereal c_b23 = 1.;
+
+/* Subroutine */ int zlqt02_(integer *m, integer *n, integer *k,
+ doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex *
+ l, integer *lda, doublecomplex *tau, doublecomplex *work, integer *
+ lwork, doublereal *rwork, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
+ q_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal eps;
+ integer info;
+ doublereal resid, anorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zherk_(char *, char *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *);
+ extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zunglq_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLQT02 tests ZUNGLQ, which generates an m-by-n matrix Q with */
+/* orthonornmal rows that is defined as the product of k elementary */
+/* reflectors. */
+
+/* Given the LQ factorization of an m-by-n matrix A, ZLQT02 generates */
+/* the orthogonal matrix Q defined by the factorization of the first k */
+/* rows of A; it compares L(1:k,1:m) with A(1:k,1:n)*Q(1:m,1:n)', and */
+/* checks that the rows of Q are orthonormal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q to be generated. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q to be generated. */
+/* N >= M >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The m-by-n matrix A which was factorized by ZLQT01. */
+
+/* AF (input) COMPLEX*16 array, dimension (LDA,N) */
+/* Details of the LQ factorization of A, as returned by ZGELQF. */
+/* See ZGELQF for further details. */
+
+/* Q (workspace) COMPLEX*16 array, dimension (LDA,N) */
+
+/* L (workspace) COMPLEX*16 array, dimension (LDA,M) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and L. LDA >= N. */
+
+/* TAU (input) COMPLEX*16 array, dimension (M) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the LQ factorization in AF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ l_dim1 = *lda;
+ l_offset = 1 + l_dim1;
+ l -= l_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ eps = dlamch_("Epsilon");
+
+/* Copy the first k rows of the factorization to the array Q */
+
+ zlaset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
+ i__1 = *n - 1;
+ zlacpy_("Upper", k, &i__1, &af[(af_dim1 << 1) + 1], lda, &q[(q_dim1 << 1)
+ + 1], lda);
+
+/* Generate the first n columns of the matrix Q */
+
+ s_copy(srnamc_1.srnamt, "ZUNGLQ", (ftnlen)32, (ftnlen)6);
+ zunglq_(m, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy L(1:k,1:m) */
+
+ zlaset_("Full", k, m, &c_b8, &c_b8, &l[l_offset], lda);
+ zlacpy_("Lower", k, m, &af[af_offset], lda, &l[l_offset], lda);
+
+/* Compute L(1:k,1:m) - A(1:k,1:n) * Q(1:m,1:n)' */
+
+ zgemm_("No transpose", "Conjugate transpose", k, m, n, &c_b13, &a[
+ a_offset], lda, &q[q_offset], lda, &c_b14, &l[l_offset], lda);
+
+/* Compute norm( L - A*Q' ) / ( N * norm(A) * EPS ) . */
+
+ anorm = zlange_("1", k, n, &a[a_offset], lda, &rwork[1]);
+ resid = zlange_("1", k, m, &l[l_offset], lda, &rwork[1]);
+ if (anorm > 0.) {
+ result[1] = resid / (doublereal) max(1,*n) / anorm / eps;
+ } else {
+ result[1] = 0.;
+ }
+
+/* Compute I - Q*Q' */
+
+ zlaset_("Full", m, m, &c_b8, &c_b14, &l[l_offset], lda);
+ zherk_("Upper", "No transpose", m, n, &c_b22, &q[q_offset], lda, &c_b23, &
+ l[l_offset], lda);
+
+/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
+
+ resid = zlansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
+
+ result[2] = resid / (doublereal) max(1,*n) / eps;
+
+ return 0;
+
+/* End of ZLQT02 */
+
+} /* zlqt02_ */
diff --git a/TESTING/LIN/zlqt03.c b/TESTING/LIN/zlqt03.c
new file mode 100644
index 0000000..7c1d29e
--- /dev/null
+++ b/TESTING/LIN/zlqt03.c
@@ -0,0 +1,263 @@
+/* zlqt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {-1e10,-1e10};
+static integer c__2 = 2;
+static doublecomplex c_b20 = {-1.,0.};
+static doublecomplex c_b21 = {1.,0.};
+
+/* Subroutine */ int zlqt03_(integer *m, integer *n, integer *k,
+ doublecomplex *af, doublecomplex *c__, doublecomplex *cc,
+ doublecomplex *q, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *lwork, doublereal *rwork, doublereal *result)
+{
+ /* Initialized data */
+
+ static integer iseed[4] = { 1988,1989,1990,1991 };
+
+ /* System generated locals */
+ integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1,
+ q_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j, mc, nc;
+ doublereal eps;
+ char side[1];
+ integer info, iside;
+ extern logical lsame_(char *, char *);
+ doublereal resid, cnorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ char trans[1];
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ integer itrans;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *), zlarnv_(
+ integer *, integer *, integer *, doublecomplex *), zunglq_(
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *), zunmlq_(
+ char *, char *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLQT03 tests ZUNMLQ, which computes Q*C, Q'*C, C*Q or C*Q'. */
+
+/* ZLQT03 compares the results of a call to ZUNMLQ with the results of */
+/* forming Q explicitly by a call to ZUNGLQ and then performing matrix */
+/* multiplication by a call to ZGEMM. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows or columns of the matrix C; C is n-by-m if */
+/* Q is applied from the left, or m-by-n if Q is applied from */
+/* the right. M >= 0. */
+
+/* N (input) INTEGER */
+/* The order of the orthogonal matrix Q. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* orthogonal matrix Q. N >= K >= 0. */
+
+/* AF (input) COMPLEX*16 array, dimension (LDA,N) */
+/* Details of the LQ factorization of an m-by-n matrix, as */
+/* returned by ZGELQF. See CGELQF for further details. */
+
+/* C (workspace) COMPLEX*16 array, dimension (LDA,N) */
+
+/* CC (workspace) COMPLEX*16 array, dimension (LDA,N) */
+
+/* Q (workspace) COMPLEX*16 array, dimension (LDA,N) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays AF, C, CC, and Q. */
+
+/* TAU (input) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the LQ factorization in AF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK must be at least M, and should be */
+/* M*NB, where NB is the blocksize for this environment. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
+/* The test ratios compare two techniques for multiplying a */
+/* random matrix C by an n-by-n orthogonal matrix Q. */
+/* RESULT(1) = norm( Q*C - Q*C ) / ( N * norm(C) * EPS ) */
+/* RESULT(2) = norm( C*Q - C*Q ) / ( N * norm(C) * EPS ) */
+/* RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS ) */
+/* RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ cc_dim1 = *lda;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+ c_dim1 = *lda;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = dlamch_("Epsilon");
+
+/* Copy the first k rows of the factorization to the array Q */
+
+ zlaset_("Full", n, n, &c_b1, &c_b1, &q[q_offset], lda);
+ i__1 = *n - 1;
+ zlacpy_("Upper", k, &i__1, &af[(af_dim1 << 1) + 1], lda, &q[(q_dim1 << 1)
+ + 1], lda);
+
+/* Generate the n-by-n matrix Q */
+
+ s_copy(srnamc_1.srnamt, "ZUNGLQ", (ftnlen)32, (ftnlen)6);
+ zunglq_(n, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+ for (iside = 1; iside <= 2; ++iside) {
+ if (iside == 1) {
+ *(unsigned char *)side = 'L';
+ mc = *n;
+ nc = *m;
+ } else {
+ *(unsigned char *)side = 'R';
+ mc = *m;
+ nc = *n;
+ }
+
+/* Generate MC by NC matrix C */
+
+ i__1 = nc;
+ for (j = 1; j <= i__1; ++j) {
+ zlarnv_(&c__2, iseed, &mc, &c__[j * c_dim1 + 1]);
+/* L10: */
+ }
+ cnorm = zlange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]);
+ if (cnorm == 0.) {
+ cnorm = 1.;
+ }
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+ if (itrans == 1) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'C';
+ }
+
+/* Copy C */
+
+ zlacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
+ lda);
+
+/* Apply Q or Q' to C */
+
+ s_copy(srnamc_1.srnamt, "ZUNMLQ", (ftnlen)32, (ftnlen)6);
+ zunmlq_(side, trans, &mc, &nc, k, &af[af_offset], lda, &tau[1], &
+ cc[cc_offset], lda, &work[1], lwork, &info);
+
+/* Form explicit product and subtract */
+
+ if (lsame_(side, "L")) {
+ zgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b20, &q[
+ q_offset], lda, &c__[c_offset], lda, &c_b21, &cc[
+ cc_offset], lda);
+ } else {
+ zgemm_("No transpose", trans, &mc, &nc, &nc, &c_b20, &c__[
+ c_offset], lda, &q[q_offset], lda, &c_b21, &cc[
+ cc_offset], lda);
+ }
+
+/* Compute error in the difference */
+
+ resid = zlange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
+ result[(iside - 1 << 1) + itrans] = resid / ((doublereal) max(1,*
+ n) * cnorm * eps);
+
+/* L20: */
+ }
+/* L30: */
+ }
+
+ return 0;
+
+/* End of ZLQT03 */
+
+} /* zlqt03_ */
diff --git a/TESTING/LIN/zpbt01.c b/TESTING/LIN/zpbt01.c
new file mode 100644
index 0000000..89f9c50
--- /dev/null
+++ b/TESTING/LIN/zpbt01.c
@@ -0,0 +1,284 @@
+/* zpbt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b17 = 1.;
+
+/* Subroutine */ int zpbt01_(char *uplo, integer *n, integer *kd,
+ doublecomplex *a, integer *lda, doublecomplex *afac, integer *ldafac,
+ doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3, i__4,
+ i__5;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, kc, ml, mu;
+ doublereal akk, eps;
+ integer klen;
+ extern /* Subroutine */ int zher_(char *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int ztrmv_(char *, char *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlanhb_(char *, char *,
+ integer *, integer *, doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPBT01 reconstructs a Hermitian positive definite band matrix A from */
+/* its L*L' or U'*U factorization and computes the residual */
+/* norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
+/* norm( U'*U - A ) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon, L' is the conjugate transpose of */
+/* L, and U' is the conjugate transpose of U. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original Hermitian band matrix A. If UPLO = 'U', the */
+/* upper triangular part of A is stored as a band matrix; if */
+/* UPLO = 'L', the lower triangular part of A is stored. The */
+/* columns of the appropriate triangle are stored in the columns */
+/* of A and the diagonals of the triangle are stored in the rows */
+/* of A. See ZPBTRF for further details. */
+
+/* LDA (input) INTEGER. */
+/* The leading dimension of the array A. LDA >= max(1,KD+1). */
+
+/* AFAC (input) COMPLEX*16 array, dimension (LDAFAC,N) */
+/* The factored form of the matrix A. AFAC contains the factor */
+/* L or U from the L*L' or U'*U factorization in band storage */
+/* format, as computed by ZPBTRF. */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. */
+/* LDAFAC >= max(1,KD+1). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
+/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlanhb_("1", uplo, n, kd, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Check the imaginary parts of the diagonal elements and return with */
+/* an error code if any are nonzero. */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (d_imag(&afac[*kd + 1 + j * afac_dim1]) != 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (d_imag(&afac[j * afac_dim1 + 1]) != 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+/* L20: */
+ }
+ }
+
+/* Compute the product U'*U, overwriting U. */
+
+ if (lsame_(uplo, "U")) {
+ for (k = *n; k >= 1; --k) {
+/* Computing MAX */
+ i__1 = 1, i__2 = *kd + 2 - k;
+ kc = max(i__1,i__2);
+ klen = *kd + 1 - kc;
+
+/* Compute the (K,K) element of the result. */
+
+ i__1 = klen + 1;
+ zdotc_(&z__1, &i__1, &afac[kc + k * afac_dim1], &c__1, &afac[kc +
+ k * afac_dim1], &c__1);
+ akk = z__1.r;
+ i__1 = *kd + 1 + k * afac_dim1;
+ afac[i__1].r = akk, afac[i__1].i = 0.;
+
+/* Compute the rest of column K. */
+
+ if (klen > 0) {
+ i__1 = *ldafac - 1;
+ ztrmv_("Upper", "Conjugate", "Non-unit", &klen, &afac[*kd + 1
+ + (k - klen) * afac_dim1], &i__1, &afac[kc + k *
+ afac_dim1], &c__1);
+ }
+
+/* L30: */
+ }
+
+/* UPLO = 'L': Compute the product L*L', overwriting L. */
+
+ } else {
+ for (k = *n; k >= 1; --k) {
+/* Computing MIN */
+ i__1 = *kd, i__2 = *n - k;
+ klen = min(i__1,i__2);
+
+/* Add a multiple of column K of the factor L to each of */
+/* columns K+1 through N. */
+
+ if (klen > 0) {
+ i__1 = *ldafac - 1;
+ zher_("Lower", &klen, &c_b17, &afac[k * afac_dim1 + 2], &c__1,
+ &afac[(k + 1) * afac_dim1 + 1], &i__1);
+ }
+
+/* Scale column K by the diagonal element. */
+
+ i__1 = k * afac_dim1 + 1;
+ akk = afac[i__1].r;
+ i__1 = klen + 1;
+ zdscal_(&i__1, &akk, &afac[k * afac_dim1 + 1], &c__1);
+
+/* L40: */
+ }
+ }
+
+/* Compute the difference L*L' - A or U'*U - A. */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ i__2 = 1, i__3 = *kd + 2 - j;
+ mu = max(i__2,i__3);
+ i__2 = *kd + 1;
+ for (i__ = mu; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * afac_dim1;
+ i__4 = i__ + j * afac_dim1;
+ i__5 = i__ + j * a_dim1;
+ z__1.r = afac[i__4].r - a[i__5].r, z__1.i = afac[i__4].i - a[
+ i__5].i;
+ afac[i__3].r = z__1.r, afac[i__3].i = z__1.i;
+/* L50: */
+ }
+/* L60: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = *kd + 1, i__3 = *n - j + 1;
+ ml = min(i__2,i__3);
+ i__2 = ml;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * afac_dim1;
+ i__4 = i__ + j * afac_dim1;
+ i__5 = i__ + j * a_dim1;
+ z__1.r = afac[i__4].r - a[i__5].r, z__1.i = afac[i__4].i - a[
+ i__5].i;
+ afac[i__3].r = z__1.r, afac[i__3].i = z__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+ }
+
+/* Compute norm( L*L' - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = zlanhb_("1", uplo, n, kd, &afac[afac_offset], ldafac, &rwork[1]);
+
+ *resid = *resid / (doublereal) (*n) / anorm / eps;
+
+ return 0;
+
+/* End of ZPBT01 */
+
+} /* zpbt01_ */
diff --git a/TESTING/LIN/zpbt02.c b/TESTING/LIN/zpbt02.c
new file mode 100644
index 0000000..256e46a
--- /dev/null
+++ b/TESTING/LIN/zpbt02.c
@@ -0,0 +1,181 @@
+/* zpbt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zpbt02_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *x, integer *ldx,
+ doublecomplex *b, integer *ldb, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer j;
+ doublereal eps, anorm, bnorm;
+ extern /* Subroutine */ int zhbmv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ doublereal xnorm;
+ extern doublereal dlamch_(char *), zlanhb_(char *, char *,
+ integer *, integer *, doublecomplex *, integer *, doublereal *), dzasum_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPBT02 computes the residual for a solution of a Hermitian banded */
+/* system of equations A*x = b: */
+/* RESID = norm( B - A*X ) / ( norm(A) * norm(X) * EPS) */
+/* where EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original Hermitian band matrix A. If UPLO = 'U', the */
+/* upper triangular part of A is stored as a band matrix; if */
+/* UPLO = 'L', the lower triangular part of A is stored. The */
+/* columns of the appropriate triangle are stored in the columns */
+/* of A and the diagonals of the triangle are stored in the rows */
+/* of A. See ZPBTRF for further details. */
+
+/* LDA (input) INTEGER. */
+/* The leading dimension of the array A. LDA >= max(1,KD+1). */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlanhb_("1", uplo, n, kd, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute B - A*X */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ z__1.r = -1., z__1.i = -0.;
+ zhbmv_(uplo, n, kd, &z__1, &a[a_offset], lda, &x[j * x_dim1 + 1], &
+ c__1, &c_b1, &b[j * b_dim1 + 1], &c__1);
+/* L10: */
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = dzasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = dzasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L20: */
+ }
+
+ return 0;
+
+/* End of ZPBT02 */
+
+} /* zpbt02_ */
diff --git a/TESTING/LIN/zpbt05.c b/TESTING/LIN/zpbt05.c
new file mode 100644
index 0000000..d12ac43
--- /dev/null
+++ b/TESTING/LIN/zpbt05.c
@@ -0,0 +1,334 @@
+/* zpbt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zpbt05_(char *uplo, integer *n, integer *kd, integer *
+ nrhs, doublecomplex *ab, integer *ldab, doublecomplex *b, integer *
+ ldb, doublecomplex *x, integer *ldx, doublecomplex *xact, integer *
+ ldxact, doublereal *ferr, doublereal *berr, doublereal *reslts)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, nz;
+ doublereal eps, tmp, diff, axbi;
+ integer imax;
+ doublereal unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ doublereal xnorm;
+ extern doublereal dlamch_(char *);
+ doublereal errbnd;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPBT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* Hermitian band matrix. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+/* and NZ = max. number of nonzeros in any row of A, plus 1 */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
+/* The upper or lower triangle of the Hermitian band matrix A, */
+/* stored in the first KD+1 rows of the array. The j-th column */
+/* of A is stored in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.;
+ reslts[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ upper = lsame_(uplo, "U");
+/* Computing MAX */
+ i__1 = *kd, i__2 = *n - 1;
+ nz = (max(i__1,i__2) << 1) + 1;
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = izamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__2 = imax + j * x_dim1;
+ d__3 = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[imax + j *
+ x_dim1]), abs(d__2));
+ xnorm = max(d__3,unfl);
+ diff = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * xact_dim1;
+ z__2.r = x[i__3].r - xact[i__4].r, z__2.i = x[i__3].i - xact[i__4]
+ .i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+/* Computing MAX */
+ d__3 = diff, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
+ z__1), abs(d__2));
+ diff = max(d__3,d__4);
+/* L10: */
+ }
+
+ if (xnorm > 1.) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1. / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
+ errbnd = max(d__1,d__2);
+ } else {
+ errbnd = 1. / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ tmp = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__ + k *
+ b_dim1]), abs(d__2));
+ if (upper) {
+/* Computing MAX */
+ i__3 = i__ - *kd;
+ i__4 = i__ - 1;
+ for (j = max(i__3,1); j <= i__4; ++j) {
+ i__3 = *kd + 1 - i__ + j + i__ * ab_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 = d_imag(&
+ ab[*kd + 1 - i__ + j + i__ * ab_dim1]), abs(d__2))
+ ) * ((d__3 = x[i__5].r, abs(d__3)) + (d__4 =
+ d_imag(&x[j + k * x_dim1]), abs(d__4)));
+/* L40: */
+ }
+ i__4 = *kd + 1 + i__ * ab_dim1;
+ i__3 = i__ + k * x_dim1;
+ tmp += (d__1 = ab[i__4].r, abs(d__1)) * ((d__2 = x[i__3].r,
+ abs(d__2)) + (d__3 = d_imag(&x[i__ + k * x_dim1]),
+ abs(d__3)));
+/* Computing MIN */
+ i__3 = i__ + *kd;
+ i__4 = min(i__3,*n);
+ for (j = i__ + 1; j <= i__4; ++j) {
+ i__3 = *kd + 1 + i__ - j + j * ab_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 = d_imag(&
+ ab[*kd + 1 + i__ - j + j * ab_dim1]), abs(d__2)))
+ * ((d__3 = x[i__5].r, abs(d__3)) + (d__4 = d_imag(
+ &x[j + k * x_dim1]), abs(d__4)));
+/* L50: */
+ }
+ } else {
+/* Computing MAX */
+ i__4 = i__ - *kd;
+ i__3 = i__ - 1;
+ for (j = max(i__4,1); j <= i__3; ++j) {
+ i__4 = i__ + 1 - j + j * ab_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = ab[i__4].r, abs(d__1)) + (d__2 = d_imag(&
+ ab[i__ + 1 - j + j * ab_dim1]), abs(d__2))) * ((
+ d__3 = x[i__5].r, abs(d__3)) + (d__4 = d_imag(&x[
+ j + k * x_dim1]), abs(d__4)));
+/* L60: */
+ }
+ i__3 = i__ * ab_dim1 + 1;
+ i__4 = i__ + k * x_dim1;
+ tmp += (d__1 = ab[i__3].r, abs(d__1)) * ((d__2 = x[i__4].r,
+ abs(d__2)) + (d__3 = d_imag(&x[i__ + k * x_dim1]),
+ abs(d__3)));
+/* Computing MIN */
+ i__4 = i__ + *kd;
+ i__3 = min(i__4,*n);
+ for (j = i__ + 1; j <= i__3; ++j) {
+ i__4 = j + 1 - i__ + i__ * ab_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = ab[i__4].r, abs(d__1)) + (d__2 = d_imag(&
+ ab[j + 1 - i__ + i__ * ab_dim1]), abs(d__2))) * ((
+ d__3 = x[i__5].r, abs(d__3)) + (d__4 = d_imag(&x[
+ j + k * x_dim1]), abs(d__4)));
+/* L70: */
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = min(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ d__1 = axbi, d__2 = nz * unfl;
+ tmp = berr[k] / (nz * eps + nz * unfl / max(d__1,d__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = max(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of ZPBT05 */
+
+} /* zpbt05_ */
diff --git a/TESTING/LIN/zpot01.c b/TESTING/LIN/zpot01.c
new file mode 100644
index 0000000..133bfd5
--- /dev/null
+++ b/TESTING/LIN/zpot01.c
@@ -0,0 +1,259 @@
+/* zpot01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b15 = 1.;
+
+/* Subroutine */ int zpot01_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *afac, integer *ldafac, doublereal *rwork,
+ doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3, i__4,
+ i__5;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublecomplex tc;
+ doublereal tr, eps;
+ extern /* Subroutine */ int zher_(char *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int ztrmv_(char *, char *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlanhe_(char *, char *,
+ integer *, doublecomplex *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPOT01 reconstructs a Hermitian positive definite matrix A from */
+/* its L*L' or U'*U factorization and computes the residual */
+/* norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
+/* norm( U'*U - A ) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon, L' is the conjugate transpose of L, */
+/* and U' is the conjugate transpose of U. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original Hermitian matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* AFAC (input/output) COMPLEX*16 array, dimension (LDAFAC,N) */
+/* On entry, the factor L or U from the L*L' or U'*U */
+/* factorization of A. */
+/* Overwritten with the reconstructed matrix, and then with the */
+/* difference L*L' - A (or U'*U - A). */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
+/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Check the imaginary parts of the diagonal elements and return with */
+/* an error code if any are nonzero. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (d_imag(&afac[j + j * afac_dim1]) != 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+/* L10: */
+ }
+
+/* Compute the product U'*U, overwriting U. */
+
+ if (lsame_(uplo, "U")) {
+ for (k = *n; k >= 1; --k) {
+
+/* Compute the (K,K) element of the result. */
+
+ zdotc_(&z__1, &k, &afac[k * afac_dim1 + 1], &c__1, &afac[k *
+ afac_dim1 + 1], &c__1);
+ tr = z__1.r;
+ i__1 = k + k * afac_dim1;
+ afac[i__1].r = tr, afac[i__1].i = 0.;
+
+/* Compute the rest of column K. */
+
+ i__1 = k - 1;
+ ztrmv_("Upper", "Conjugate", "Non-unit", &i__1, &afac[afac_offset]
+, ldafac, &afac[k * afac_dim1 + 1], &c__1);
+
+/* L20: */
+ }
+
+/* Compute the product L*L', overwriting L. */
+
+ } else {
+ for (k = *n; k >= 1; --k) {
+
+/* Add a multiple of column K of the factor L to each of */
+/* columns K+1 through N. */
+
+ if (k + 1 <= *n) {
+ i__1 = *n - k;
+ zher_("Lower", &i__1, &c_b15, &afac[k + 1 + k * afac_dim1], &
+ c__1, &afac[k + 1 + (k + 1) * afac_dim1], ldafac);
+ }
+
+/* Scale column K by the diagonal element. */
+
+ i__1 = k + k * afac_dim1;
+ tc.r = afac[i__1].r, tc.i = afac[i__1].i;
+ i__1 = *n - k + 1;
+ zscal_(&i__1, &tc, &afac[k + k * afac_dim1], &c__1);
+
+/* L30: */
+ }
+ }
+
+/* Compute the difference L*L' - A (or U'*U - A). */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * afac_dim1;
+ i__4 = i__ + j * afac_dim1;
+ i__5 = i__ + j * a_dim1;
+ z__1.r = afac[i__4].r - a[i__5].r, z__1.i = afac[i__4].i - a[
+ i__5].i;
+ afac[i__3].r = z__1.r, afac[i__3].i = z__1.i;
+/* L40: */
+ }
+ i__2 = j + j * afac_dim1;
+ i__3 = j + j * afac_dim1;
+ i__4 = j + j * a_dim1;
+ d__1 = a[i__4].r;
+ z__1.r = afac[i__3].r - d__1, z__1.i = afac[i__3].i;
+ afac[i__2].r = z__1.r, afac[i__2].i = z__1.i;
+/* L50: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * afac_dim1;
+ i__3 = j + j * afac_dim1;
+ i__4 = j + j * a_dim1;
+ d__1 = a[i__4].r;
+ z__1.r = afac[i__3].r - d__1, z__1.i = afac[i__3].i;
+ afac[i__2].r = z__1.r, afac[i__2].i = z__1.i;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * afac_dim1;
+ i__4 = i__ + j * afac_dim1;
+ i__5 = i__ + j * a_dim1;
+ z__1.r = afac[i__4].r - a[i__5].r, z__1.i = afac[i__4].i - a[
+ i__5].i;
+ afac[i__3].r = z__1.r, afac[i__3].i = z__1.i;
+/* L60: */
+ }
+/* L70: */
+ }
+ }
+
+/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = zlanhe_("1", uplo, n, &afac[afac_offset], ldafac, &rwork[1]);
+
+ *resid = *resid / (doublereal) (*n) / anorm / eps;
+
+ return 0;
+
+/* End of ZPOT01 */
+
+} /* zpot01_ */
diff --git a/TESTING/LIN/zpot02.c b/TESTING/LIN/zpot02.c
new file mode 100644
index 0000000..eadd759
--- /dev/null
+++ b/TESTING/LIN/zpot02.c
@@ -0,0 +1,174 @@
+/* zpot02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zpot02_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *x, integer *ldx,
+ doublecomplex *b, integer *ldb, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer j;
+ doublereal eps, anorm, bnorm;
+ extern /* Subroutine */ int zhemm_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ doublereal xnorm;
+ extern doublereal dlamch_(char *), zlanhe_(char *, char *,
+ integer *, doublecomplex *, integer *, doublereal *), dzasum_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPOT02 computes the residual for the solution of a Hermitian system */
+/* of linear equations A*x = b: */
+
+/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ), */
+
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original Hermitian matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute B - A*X */
+
+ z__1.r = -1., z__1.i = -0.;
+ zhemm_("Left", uplo, n, nrhs, &z__1, &a[a_offset], lda, &x[x_offset], ldx,
+ &c_b1, &b[b_offset], ldb);
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = dzasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = dzasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of ZPOT02 */
+
+} /* zpot02_ */
diff --git a/TESTING/LIN/zpot03.c b/TESTING/LIN/zpot03.c
new file mode 100644
index 0000000..acd47fd
--- /dev/null
+++ b/TESTING/LIN/zpot03.c
@@ -0,0 +1,208 @@
+/* zpot03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+
+/* Subroutine */ int zpot03_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *ainv, integer *ldainv, doublecomplex *
+ work, integer *ldwork, doublereal *rwork, doublereal *rcond,
+ doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, ainv_dim1, ainv_offset, work_dim1, work_offset,
+ i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int zhemm_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *),
+ zlanhe_(char *, char *, integer *, doublecomplex *, integer *,
+ doublereal *);
+ doublereal ainvnm;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPOT03 computes the residual for a Hermitian matrix times its */
+/* inverse: */
+/* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original Hermitian matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* AINV (input/output) COMPLEX*16 array, dimension (LDAINV,N) */
+/* On entry, the inverse of the matrix A, stored as a Hermitian */
+/* matrix in the same format as A. */
+/* In this version, AINV is expanded into a full matrix and */
+/* multiplied by A, so the opposing triangle of AINV will be */
+/* changed; i.e., if the upper triangular part of AINV is */
+/* stored, the lower triangular part will be used as work space. */
+
+/* LDAINV (input) INTEGER */
+/* The leading dimension of the array AINV. LDAINV >= max(1,N). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,N) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal of the condition number of A, computed as */
+/* ( 1/norm(A) ) / norm(AINV). */
+
+/* RESID (output) DOUBLE PRECISION */
+/* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ ainv_dim1 = *ldainv;
+ ainv_offset = 1 + ainv_dim1;
+ ainv -= ainv_offset;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.;
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+ ainvnm = zlanhe_("1", uplo, n, &ainv[ainv_offset], ldainv, &rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ *rcond = 0.;
+ *resid = 1. / eps;
+ return 0;
+ }
+ *rcond = 1. / anorm / ainvnm;
+
+/* Expand AINV into a full matrix and call ZHEMM to multiply */
+/* AINV on the left by A. */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * ainv_dim1;
+ d_cnjg(&z__1, &ainv[i__ + j * ainv_dim1]);
+ ainv[i__3].r = z__1.r, ainv[i__3].i = z__1.i;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * ainv_dim1;
+ d_cnjg(&z__1, &ainv[i__ + j * ainv_dim1]);
+ ainv[i__3].r = z__1.r, ainv[i__3].i = z__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ z__1.r = -1., z__1.i = -0.;
+ zhemm_("Left", uplo, n, n, &z__1, &a[a_offset], lda, &ainv[ainv_offset],
+ ldainv, &c_b1, &work[work_offset], ldwork);
+
+/* Add the identity matrix to WORK . */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * work_dim1;
+ i__3 = i__ + i__ * work_dim1;
+ z__1.r = work[i__3].r + 1., z__1.i = work[i__3].i + 0.;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L50: */
+ }
+
+/* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = zlange_("1", n, n, &work[work_offset], ldwork, &rwork[1]);
+
+ *resid = *resid * *rcond / eps / (doublereal) (*n);
+
+ return 0;
+
+/* End of ZPOT03 */
+
+} /* zpot03_ */
diff --git a/TESTING/LIN/zpot05.c b/TESTING/LIN/zpot05.c
new file mode 100644
index 0000000..28c9daf
--- /dev/null
+++ b/TESTING/LIN/zpot05.c
@@ -0,0 +1,320 @@
+/* zpot05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zpot05_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublecomplex *xact, integer *ldxact,
+ doublereal *ferr, doublereal *berr, doublereal *reslts)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublereal eps, tmp, diff, axbi;
+ integer imax;
+ doublereal unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ doublereal xnorm;
+ extern doublereal dlamch_(char *);
+ doublereal errbnd;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPOT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* Hermitian n by n matrix. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* 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. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.;
+ reslts[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ upper = lsame_(uplo, "U");
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = izamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__2 = imax + j * x_dim1;
+ d__3 = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[imax + j *
+ x_dim1]), abs(d__2));
+ xnorm = max(d__3,unfl);
+ diff = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * xact_dim1;
+ z__2.r = x[i__3].r - xact[i__4].r, z__2.i = x[i__3].i - xact[i__4]
+ .i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+/* Computing MAX */
+ d__3 = diff, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
+ z__1), abs(d__2));
+ diff = max(d__3,d__4);
+/* L10: */
+ }
+
+ if (xnorm > 1.) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1. / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
+ errbnd = max(d__1,d__2);
+ } else {
+ errbnd = 1. / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ tmp = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__ + k *
+ b_dim1]), abs(d__2));
+ if (upper) {
+ i__3 = i__ - 1;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j + i__ * a_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[
+ j + i__ * a_dim1]), abs(d__2))) * ((d__3 = x[i__5]
+ .r, abs(d__3)) + (d__4 = d_imag(&x[j + k * x_dim1]
+ ), abs(d__4)));
+/* L40: */
+ }
+ i__3 = i__ + i__ * a_dim1;
+ i__4 = i__ + k * x_dim1;
+ tmp += (d__1 = a[i__3].r, abs(d__1)) * ((d__2 = x[i__4].r,
+ abs(d__2)) + (d__3 = d_imag(&x[i__ + k * x_dim1]),
+ abs(d__3)));
+ i__3 = *n;
+ for (j = i__ + 1; j <= i__3; ++j) {
+ i__4 = i__ + j * a_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2))) * ((d__3 = x[i__5]
+ .r, abs(d__3)) + (d__4 = d_imag(&x[j + k * x_dim1]
+ ), abs(d__4)));
+/* L50: */
+ }
+ } else {
+ i__3 = i__ - 1;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = i__ + j * a_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[
+ i__ + j * a_dim1]), abs(d__2))) * ((d__3 = x[i__5]
+ .r, abs(d__3)) + (d__4 = d_imag(&x[j + k * x_dim1]
+ ), abs(d__4)));
+/* L60: */
+ }
+ i__3 = i__ + i__ * a_dim1;
+ i__4 = i__ + k * x_dim1;
+ tmp += (d__1 = a[i__3].r, abs(d__1)) * ((d__2 = x[i__4].r,
+ abs(d__2)) + (d__3 = d_imag(&x[i__ + k * x_dim1]),
+ abs(d__3)));
+ i__3 = *n;
+ for (j = i__ + 1; j <= i__3; ++j) {
+ i__4 = j + i__ * a_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 = d_imag(&a[
+ j + i__ * a_dim1]), abs(d__2))) * ((d__3 = x[i__5]
+ .r, abs(d__3)) + (d__4 = d_imag(&x[j + k * x_dim1]
+ ), abs(d__4)));
+/* L70: */
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = min(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ d__1 = axbi, d__2 = (*n + 1) * unfl;
+ tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / max(d__1,d__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = max(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of ZPOT05 */
+
+} /* zpot05_ */
diff --git a/TESTING/LIN/zpot06.c b/TESTING/LIN/zpot06.c
new file mode 100644
index 0000000..4ebd775
--- /dev/null
+++ b/TESTING/LIN/zpot06.c
@@ -0,0 +1,190 @@
+/* zpot06.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static doublecomplex c_b2 = {-1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zpot06_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *x, integer *ldx,
+ doublecomplex *b, integer *ldb, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer j;
+ doublereal eps;
+ integer ifail;
+ doublereal anorm, bnorm;
+ extern /* Subroutine */ int zhemm_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ doublereal xnorm;
+ extern doublereal dlamch_(char *);
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1.2) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* May 2007 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPOT06 computes the residual for a solution of a system of linear */
+/* equations A*x = b : */
+/* RESID = norm(B - A*X,inf) / ( norm(A,inf) * norm(X,inf) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original M x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. IF TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs == 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlansy_("I", uplo, n, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute B - A*X and store in B. */
+ ifail = 0;
+
+ zhemm_("Left", uplo, n, nrhs, &c_b2, &a[a_offset], lda, &x[x_offset], ldx,
+ &c_b1, &b[b_offset], ldb);
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = izamax_(n, &b[j * b_dim1 + 1], &c__1) + j * b_dim1;
+ bnorm = (d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[izamax_(n, &
+ b[j * b_dim1 + 1], &c__1) + j * b_dim1]), abs(d__2));
+ i__2 = izamax_(n, &x[j * x_dim1 + 1], &c__1) + j * x_dim1;
+ xnorm = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[izamax_(n, &
+ x[j * x_dim1 + 1], &c__1) + j * x_dim1]), abs(d__2));
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of ZPOT06 */
+
+} /* zpot06_ */
diff --git a/TESTING/LIN/zppt01.c b/TESTING/LIN/zppt01.c
new file mode 100644
index 0000000..b5c1020
--- /dev/null
+++ b/TESTING/LIN/zppt01.c
@@ -0,0 +1,270 @@
+/* zppt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b19 = 1.;
+
+/* Subroutine */ int zppt01_(char *uplo, integer *n, doublecomplex *a,
+ doublecomplex *afac, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, k, kc;
+ doublecomplex tc;
+ doublereal tr, eps;
+ extern /* Subroutine */ int zhpr_(char *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *);
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int ztpmv_(char *, char *, char *, integer *,
+ doublecomplex *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlanhp_(char *, char *,
+ integer *, doublecomplex *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPPT01 reconstructs a Hermitian positive definite packed matrix A */
+/* from its L*L' or U'*U factorization and computes the residual */
+/* norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
+/* norm( U'*U - A ) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon, L' is the conjugate transpose of */
+/* L, and U' is the conjugate transpose of U. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The original Hermitian matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* AFAC (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the factor L or U from the L*L' or U'*U */
+/* factorization of A, stored as a packed triangular matrix. */
+/* Overwritten with the reconstructed matrix, and then with the */
+/* difference L*L' - A (or U'*U - A). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
+/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 */
+
+ /* Parameter adjustments */
+ --rwork;
+ --afac;
+ --a;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlanhp_("1", uplo, n, &a[1], &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Check the imaginary parts of the diagonal elements and return with */
+/* an error code if any are nonzero. */
+
+ kc = 1;
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (d_imag(&afac[kc]) != 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+ kc = kc + k + 1;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ if (d_imag(&afac[kc]) != 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+ kc = kc + *n - k + 1;
+/* L20: */
+ }
+ }
+
+/* Compute the product U'*U, overwriting U. */
+
+ if (lsame_(uplo, "U")) {
+ kc = *n * (*n - 1) / 2 + 1;
+ for (k = *n; k >= 1; --k) {
+
+/* Compute the (K,K) element of the result. */
+
+ zdotc_(&z__1, &k, &afac[kc], &c__1, &afac[kc], &c__1);
+ tr = z__1.r;
+ i__1 = kc + k - 1;
+ afac[i__1].r = tr, afac[i__1].i = 0.;
+
+/* Compute the rest of column K. */
+
+ if (k > 1) {
+ i__1 = k - 1;
+ ztpmv_("Upper", "Conjugate", "Non-unit", &i__1, &afac[1], &
+ afac[kc], &c__1);
+ kc -= k - 1;
+ }
+/* L30: */
+ }
+
+/* Compute the difference L*L' - A */
+
+ kc = 1;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = k - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = kc + i__ - 1;
+ i__4 = kc + i__ - 1;
+ i__5 = kc + i__ - 1;
+ z__1.r = afac[i__4].r - a[i__5].r, z__1.i = afac[i__4].i - a[
+ i__5].i;
+ afac[i__3].r = z__1.r, afac[i__3].i = z__1.i;
+/* L40: */
+ }
+ i__2 = kc + k - 1;
+ i__3 = kc + k - 1;
+ i__4 = kc + k - 1;
+ d__1 = a[i__4].r;
+ z__1.r = afac[i__3].r - d__1, z__1.i = afac[i__3].i;
+ afac[i__2].r = z__1.r, afac[i__2].i = z__1.i;
+ kc += k;
+/* L50: */
+ }
+
+/* Compute the product L*L', overwriting L. */
+
+ } else {
+ kc = *n * (*n + 1) / 2;
+ for (k = *n; k >= 1; --k) {
+
+/* Add a multiple of column K of the factor L to each of */
+/* columns K+1 through N. */
+
+ if (k < *n) {
+ i__1 = *n - k;
+ zhpr_("Lower", &i__1, &c_b19, &afac[kc + 1], &c__1, &afac[kc
+ + *n - k + 1]);
+ }
+
+/* Scale column K by the diagonal element. */
+
+ i__1 = kc;
+ tc.r = afac[i__1].r, tc.i = afac[i__1].i;
+ i__1 = *n - k + 1;
+ zscal_(&i__1, &tc, &afac[kc], &c__1);
+
+ kc -= *n - k + 2;
+/* L60: */
+ }
+
+/* Compute the difference U'*U - A */
+
+ kc = 1;
+ i__1 = *n;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = kc;
+ i__3 = kc;
+ i__4 = kc;
+ d__1 = a[i__4].r;
+ z__1.r = afac[i__3].r - d__1, z__1.i = afac[i__3].i;
+ afac[i__2].r = z__1.r, afac[i__2].i = z__1.i;
+ i__2 = *n;
+ for (i__ = k + 1; i__ <= i__2; ++i__) {
+ i__3 = kc + i__ - k;
+ i__4 = kc + i__ - k;
+ i__5 = kc + i__ - k;
+ z__1.r = afac[i__4].r - a[i__5].r, z__1.i = afac[i__4].i - a[
+ i__5].i;
+ afac[i__3].r = z__1.r, afac[i__3].i = z__1.i;
+/* L70: */
+ }
+ kc = kc + *n - k + 1;
+/* L80: */
+ }
+ }
+
+/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = zlanhp_("1", uplo, n, &afac[1], &rwork[1]);
+
+ *resid = *resid / (doublereal) (*n) / anorm / eps;
+
+ return 0;
+
+/* End of ZPPT01 */
+
+} /* zppt01_ */
diff --git a/TESTING/LIN/zppt02.c b/TESTING/LIN/zppt02.c
new file mode 100644
index 0000000..61e006c
--- /dev/null
+++ b/TESTING/LIN/zppt02.c
@@ -0,0 +1,175 @@
+/* zppt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zppt02_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, doublecomplex *x, integer *ldx, doublecomplex *b,
+ integer *ldb, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer j;
+ doublereal eps, anorm, bnorm, xnorm;
+ extern /* Subroutine */ int zhpmv_(char *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlanhp_(char *, char *,
+ integer *, doublecomplex *, doublereal *),
+ dzasum_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPPT02 computes the residual in the solution of a Hermitian system */
+/* of linear equations A*x = b when packed storage is used for the */
+/* coefficient matrix. The ratio computed is */
+
+/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS), */
+
+/* where EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The original Hermitian matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ --a;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlanhp_("1", uplo, n, &a[1], &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute B - A*X for the matrix of right hand sides B. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ z__1.r = -1., z__1.i = -0.;
+ zhpmv_(uplo, n, &z__1, &a[1], &x[j * x_dim1 + 1], &c__1, &c_b1, &b[j *
+ b_dim1 + 1], &c__1);
+/* L10: */
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = dzasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = dzasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L20: */
+ }
+
+ return 0;
+
+/* End of ZPPT02 */
+
+} /* zppt02_ */
diff --git a/TESTING/LIN/zppt03.c b/TESTING/LIN/zppt03.c
new file mode 100644
index 0000000..f7bb80a
--- /dev/null
+++ b/TESTING/LIN/zppt03.c
@@ -0,0 +1,255 @@
+/* zppt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zppt03_(char *uplo, integer *n, doublecomplex *a,
+ doublecomplex *ainv, doublecomplex *work, integer *ldwork, doublereal
+ *rwork, doublereal *rcond, doublereal *resid)
+{
+ /* System generated locals */
+ integer work_dim1, work_offset, i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, jj;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zhpmv_(char *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ doublereal ainvnm;
+ extern doublereal zlanhp_(char *, char *, integer *, doublecomplex *,
+ doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPPT03 computes the residual for a Hermitian packed matrix times its */
+/* inverse: */
+/* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The original Hermitian matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* AINV (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The (Hermitian) inverse of the matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,N) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal of the condition number of A, computed as */
+/* ( 1/norm(A) ) / norm(AINV). */
+
+/* RESID (output) DOUBLE PRECISION */
+/* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ --a;
+ --ainv;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.;
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlanhp_("1", uplo, n, &a[1], &rwork[1]);
+ ainvnm = zlanhp_("1", uplo, n, &ainv[1], &rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ *rcond = 0.;
+ *resid = 1. / eps;
+ return 0;
+ }
+ *rcond = 1. / anorm / ainvnm;
+
+/* UPLO = 'U': */
+/* Copy the leading N-1 x N-1 submatrix of AINV to WORK(1:N,2:N) and */
+/* expand it to a full matrix, then multiply by A one column at a */
+/* time, moving the result one column to the left. */
+
+ if (lsame_(uplo, "U")) {
+
+/* Copy AINV */
+
+ jj = 1;
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(&j, &ainv[jj], &c__1, &work[(j + 1) * work_dim1 + 1], &
+ c__1);
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = j + (i__ + 1) * work_dim1;
+ d_cnjg(&z__1, &ainv[jj + i__ - 1]);
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L10: */
+ }
+ jj += j;
+/* L20: */
+ }
+ jj = (*n - 1) * *n / 2 + 1;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n + (i__ + 1) * work_dim1;
+ d_cnjg(&z__1, &ainv[jj + i__ - 1]);
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L30: */
+ }
+
+/* Multiply by A */
+
+ i__1 = *n - 1;
+ for (j = 1; j <= i__1; ++j) {
+ z__1.r = -1., z__1.i = -0.;
+ zhpmv_("Upper", n, &z__1, &a[1], &work[(j + 1) * work_dim1 + 1], &
+ c__1, &c_b1, &work[j * work_dim1 + 1], &c__1);
+/* L40: */
+ }
+ z__1.r = -1., z__1.i = -0.;
+ zhpmv_("Upper", n, &z__1, &a[1], &ainv[jj], &c__1, &c_b1, &work[*n *
+ work_dim1 + 1], &c__1);
+
+/* UPLO = 'L': */
+/* Copy the trailing N-1 x N-1 submatrix of AINV to WORK(1:N,1:N-1) */
+/* and multiply by A, moving each column to the right. */
+
+ } else {
+
+/* Copy AINV */
+
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ * work_dim1 + 1;
+ d_cnjg(&z__1, &ainv[i__ + 1]);
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L50: */
+ }
+ jj = *n + 1;
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ zcopy_(&i__2, &ainv[jj], &c__1, &work[j + (j - 1) * work_dim1], &
+ c__1);
+ i__2 = *n - j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = j + (j + i__ - 1) * work_dim1;
+ d_cnjg(&z__1, &ainv[jj + i__]);
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L60: */
+ }
+ jj = jj + *n - j + 1;
+/* L70: */
+ }
+
+/* Multiply by A */
+
+ for (j = *n; j >= 2; --j) {
+ z__1.r = -1., z__1.i = -0.;
+ zhpmv_("Lower", n, &z__1, &a[1], &work[(j - 1) * work_dim1 + 1], &
+ c__1, &c_b1, &work[j * work_dim1 + 1], &c__1);
+/* L80: */
+ }
+ z__1.r = -1., z__1.i = -0.;
+ zhpmv_("Lower", n, &z__1, &a[1], &ainv[1], &c__1, &c_b1, &work[
+ work_dim1 + 1], &c__1);
+
+ }
+
+/* Add the identity matrix to WORK . */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * work_dim1;
+ i__3 = i__ + i__ * work_dim1;
+ z__1.r = work[i__3].r + 1., z__1.i = work[i__3].i + 0.;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L90: */
+ }
+
+/* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = zlange_("1", n, n, &work[work_offset], ldwork, &rwork[1]);
+
+ *resid = *resid * *rcond / eps / (doublereal) (*n);
+
+ return 0;
+
+/* End of ZPPT03 */
+
+} /* zppt03_ */
diff --git a/TESTING/LIN/zppt05.c b/TESTING/LIN/zppt05.c
new file mode 100644
index 0000000..a839e2b
--- /dev/null
+++ b/TESTING/LIN/zppt05.c
@@ -0,0 +1,318 @@
+/* zppt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zppt05_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *ap, doublecomplex *b, integer *ldb, doublecomplex *x,
+ integer *ldx, doublecomplex *xact, integer *ldxact, doublereal *ferr,
+ doublereal *berr, doublereal *reslts)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1,
+ i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, jc;
+ doublereal eps, tmp, diff, axbi;
+ integer imax;
+ doublereal unfl, ovfl;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ doublereal xnorm;
+ extern doublereal dlamch_(char *);
+ doublereal errbnd;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPPT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* Hermitian matrix in packed storage format. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The upper or lower triangle of the Hermitian matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.;
+ reslts[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ upper = lsame_(uplo, "U");
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = izamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__2 = imax + j * x_dim1;
+ d__3 = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[imax + j *
+ x_dim1]), abs(d__2));
+ xnorm = max(d__3,unfl);
+ diff = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * xact_dim1;
+ z__2.r = x[i__3].r - xact[i__4].r, z__2.i = x[i__3].i - xact[i__4]
+ .i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+/* Computing MAX */
+ d__3 = diff, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
+ z__1), abs(d__2));
+ diff = max(d__3,d__4);
+/* L10: */
+ }
+
+ if (xnorm > 1.) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1. / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
+ errbnd = max(d__1,d__2);
+ } else {
+ errbnd = 1. / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ tmp = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__ + k *
+ b_dim1]), abs(d__2));
+ if (upper) {
+ jc = (i__ - 1) * i__ / 2;
+ i__3 = i__ - 1;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = jc + j;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 = d_imag(&
+ ap[jc + j]), abs(d__2))) * ((d__3 = x[i__5].r,
+ abs(d__3)) + (d__4 = d_imag(&x[j + k * x_dim1]),
+ abs(d__4)));
+/* L40: */
+ }
+ i__3 = jc + i__;
+ i__4 = i__ + k * x_dim1;
+ tmp += (d__1 = ap[i__3].r, abs(d__1)) * ((d__2 = x[i__4].r,
+ abs(d__2)) + (d__3 = d_imag(&x[i__ + k * x_dim1]),
+ abs(d__3)));
+ jc = jc + i__ + i__;
+ i__3 = *n;
+ for (j = i__ + 1; j <= i__3; ++j) {
+ i__4 = jc;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 = d_imag(&
+ ap[jc]), abs(d__2))) * ((d__3 = x[i__5].r, abs(
+ d__3)) + (d__4 = d_imag(&x[j + k * x_dim1]), abs(
+ d__4)));
+ jc += j;
+/* L50: */
+ }
+ } else {
+ jc = i__;
+ i__3 = i__ - 1;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = jc;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 = d_imag(&
+ ap[jc]), abs(d__2))) * ((d__3 = x[i__5].r, abs(
+ d__3)) + (d__4 = d_imag(&x[j + k * x_dim1]), abs(
+ d__4)));
+ jc = jc + *n - j;
+/* L60: */
+ }
+ i__3 = jc;
+ i__4 = i__ + k * x_dim1;
+ tmp += (d__1 = ap[i__3].r, abs(d__1)) * ((d__2 = x[i__4].r,
+ abs(d__2)) + (d__3 = d_imag(&x[i__ + k * x_dim1]),
+ abs(d__3)));
+ i__3 = *n;
+ for (j = i__ + 1; j <= i__3; ++j) {
+ i__4 = jc + j - i__;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 = d_imag(&
+ ap[jc + j - i__]), abs(d__2))) * ((d__3 = x[i__5]
+ .r, abs(d__3)) + (d__4 = d_imag(&x[j + k * x_dim1]
+ ), abs(d__4)));
+/* L70: */
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = min(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ d__1 = axbi, d__2 = (*n + 1) * unfl;
+ tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / max(d__1,d__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = max(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of ZPPT05 */
+
+} /* zppt05_ */
diff --git a/TESTING/LIN/zpst01.c b/TESTING/LIN/zpst01.c
new file mode 100644
index 0000000..634ed13
--- /dev/null
+++ b/TESTING/LIN/zpst01.c
@@ -0,0 +1,355 @@
+/* zpst01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b20 = 1.;
+
+/* Subroutine */ int zpst01_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *afac, integer *ldafac, doublecomplex *
+ perm, integer *ldperm, integer *piv, doublereal *rwork, doublereal *
+ resid, integer *rank)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, perm_dim1, perm_offset,
+ i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublecomplex tc;
+ doublereal tr, eps;
+ extern /* Subroutine */ int zher_(char *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int ztrmv_(char *, char *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlanhe_(char *, char *,
+ integer *, doublecomplex *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPST01 reconstructs an Hermitian positive semidefinite matrix A */
+/* from its L or U factors and the permutation matrix P and computes */
+/* the residual */
+/* norm( P*L*L'*P' - A ) / ( N * norm(A) * EPS ) or */
+/* norm( P*U'*U*P' - A ) / ( N * norm(A) * EPS ), */
+/* where EPS is the machine epsilon, L' is the conjugate transpose of L, */
+/* and U' is the conjugate transpose of U. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original Hermitian matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* AFAC (input) COMPLEX*16 array, dimension (LDAFAC,N) */
+/* The factor L or U from the L*L' or U'*U */
+/* factorization of A. */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
+
+/* PERM (output) COMPLEX*16 array, dimension (LDPERM,N) */
+/* Overwritten with the reconstructed matrix, and then with the */
+/* difference P*L*L'*P' - A (or P*U'*U*P' - A) */
+
+/* LDPERM (input) INTEGER */
+/* The leading dimension of the array PERM. */
+/* LDAPERM >= max(1,N). */
+
+/* PIV (input) INTEGER array, dimension (N) */
+/* PIV is such that the nonzero entries are */
+/* P( PIV( K ), K ) = 1. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
+/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ perm_dim1 = *ldperm;
+ perm_offset = 1 + perm_dim1;
+ perm -= perm_offset;
+ --piv;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Check the imaginary parts of the diagonal elements and return with */
+/* an error code if any are nonzero. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (d_imag(&afac[j + j * afac_dim1]) != 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+/* L100: */
+ }
+
+/* Compute the product U'*U, overwriting U. */
+
+ if (lsame_(uplo, "U")) {
+
+ if (*rank < *n) {
+ i__1 = *n;
+ for (j = *rank + 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = *rank + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * afac_dim1;
+ afac[i__3].r = 0., afac[i__3].i = 0.;
+/* L110: */
+ }
+/* L120: */
+ }
+ }
+
+ for (k = *n; k >= 1; --k) {
+
+/* Compute the (K,K) element of the result. */
+
+ zdotc_(&z__1, &k, &afac[k * afac_dim1 + 1], &c__1, &afac[k *
+ afac_dim1 + 1], &c__1);
+ tr = z__1.r;
+ i__1 = k + k * afac_dim1;
+ afac[i__1].r = tr, afac[i__1].i = 0.;
+
+/* Compute the rest of column K. */
+
+ i__1 = k - 1;
+ ztrmv_("Upper", "Conjugate", "Non-unit", &i__1, &afac[afac_offset]
+, ldafac, &afac[k * afac_dim1 + 1], &c__1);
+
+/* L130: */
+ }
+
+/* Compute the product L*L', overwriting L. */
+
+ } else {
+
+ if (*rank < *n) {
+ i__1 = *n;
+ for (j = *rank + 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * afac_dim1;
+ afac[i__3].r = 0., afac[i__3].i = 0.;
+/* L140: */
+ }
+/* L150: */
+ }
+ }
+
+ for (k = *n; k >= 1; --k) {
+/* Add a multiple of column K of the factor L to each of */
+/* columns K+1 through N. */
+
+ if (k + 1 <= *n) {
+ i__1 = *n - k;
+ zher_("Lower", &i__1, &c_b20, &afac[k + 1 + k * afac_dim1], &
+ c__1, &afac[k + 1 + (k + 1) * afac_dim1], ldafac);
+ }
+
+/* Scale column K by the diagonal element. */
+
+ i__1 = k + k * afac_dim1;
+ tc.r = afac[i__1].r, tc.i = afac[i__1].i;
+ i__1 = *n - k + 1;
+ zscal_(&i__1, &tc, &afac[k + k * afac_dim1], &c__1);
+/* L160: */
+ }
+
+ }
+
+/* Form P*L*L'*P' or P*U'*U*P' */
+
+ if (lsame_(uplo, "U")) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (piv[i__] <= piv[j]) {
+ if (i__ <= j) {
+ i__3 = piv[i__] + piv[j] * perm_dim1;
+ i__4 = i__ + j * afac_dim1;
+ perm[i__3].r = afac[i__4].r, perm[i__3].i = afac[i__4]
+ .i;
+ } else {
+ i__3 = piv[i__] + piv[j] * perm_dim1;
+ d_cnjg(&z__1, &afac[j + i__ * afac_dim1]);
+ perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
+ }
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+
+
+ } else {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (piv[i__] >= piv[j]) {
+ if (i__ >= j) {
+ i__3 = piv[i__] + piv[j] * perm_dim1;
+ i__4 = i__ + j * afac_dim1;
+ perm[i__3].r = afac[i__4].r, perm[i__3].i = afac[i__4]
+ .i;
+ } else {
+ i__3 = piv[i__] + piv[j] * perm_dim1;
+ d_cnjg(&z__1, &afac[j + i__ * afac_dim1]);
+ perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
+ }
+ }
+/* L190: */
+ }
+/* L200: */
+ }
+
+ }
+
+/* Compute the difference P*L*L'*P' - A (or P*U'*U*P' - A). */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * perm_dim1;
+ i__4 = i__ + j * perm_dim1;
+ i__5 = i__ + j * a_dim1;
+ z__1.r = perm[i__4].r - a[i__5].r, z__1.i = perm[i__4].i - a[
+ i__5].i;
+ perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
+/* L210: */
+ }
+ i__2 = j + j * perm_dim1;
+ i__3 = j + j * perm_dim1;
+ i__4 = j + j * a_dim1;
+ d__1 = a[i__4].r;
+ z__1.r = perm[i__3].r - d__1, z__1.i = perm[i__3].i;
+ perm[i__2].r = z__1.r, perm[i__2].i = z__1.i;
+/* L220: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * perm_dim1;
+ i__3 = j + j * perm_dim1;
+ i__4 = j + j * a_dim1;
+ d__1 = a[i__4].r;
+ z__1.r = perm[i__3].r - d__1, z__1.i = perm[i__3].i;
+ perm[i__2].r = z__1.r, perm[i__2].i = z__1.i;
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * perm_dim1;
+ i__4 = i__ + j * perm_dim1;
+ i__5 = i__ + j * a_dim1;
+ z__1.r = perm[i__4].r - a[i__5].r, z__1.i = perm[i__4].i - a[
+ i__5].i;
+ perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
+/* L230: */
+ }
+/* L240: */
+ }
+ }
+
+/* Compute norm( P*L*L'P - A ) / ( N * norm(A) * EPS ), or */
+/* ( P*U'*U*P' - A )/ ( N * norm(A) * EPS ). */
+
+ *resid = zlanhe_("1", uplo, n, &perm[perm_offset], ldafac, &rwork[1]);
+
+ *resid = *resid / (doublereal) (*n) / anorm / eps;
+
+ return 0;
+
+/* End of ZPST01 */
+
+} /* zpst01_ */
diff --git a/TESTING/LIN/zptt01.c b/TESTING/LIN/zptt01.c
new file mode 100644
index 0000000..5db5072
--- /dev/null
+++ b/TESTING/LIN/zptt01.c
@@ -0,0 +1,174 @@
+/* zptt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zptt01_(integer *n, doublereal *d__, doublecomplex *e,
+ doublereal *df, doublecomplex *ef, doublecomplex *work, doublereal *
+ resid)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ double z_abs(doublecomplex *);
+
+ /* Local variables */
+ integer i__;
+ doublecomplex de;
+ doublereal eps, anorm;
+ extern doublereal dlamch_(char *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPTT01 reconstructs a tridiagonal matrix A from its L*D*L' */
+/* factorization and computes the residual */
+/* norm(L*D*L' - A) / ( n * norm(A) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGTER */
+/* The order of the matrix A. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
+
+/* DF (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the factor L from the L*D*L' */
+/* factorization of A. */
+
+/* EF (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the factor L from the */
+/* L*D*L' factorization of A. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* norm(L*D*L' - A) / (n * norm(A) * EPS) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --work;
+ --ef;
+ --df;
+ --e;
+ --d__;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+
+/* Construct the difference L*D*L' - A. */
+
+ d__1 = df[1] - d__[1];
+ work[1].r = d__1, work[1].i = 0.;
+ i__1 = *n - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ z__1.r = df[i__2] * ef[i__3].r, z__1.i = df[i__2] * ef[i__3].i;
+ de.r = z__1.r, de.i = z__1.i;
+ i__2 = *n + i__;
+ i__3 = i__;
+ z__1.r = de.r - e[i__3].r, z__1.i = de.i - e[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+ i__2 = i__ + 1;
+ d_cnjg(&z__4, &ef[i__]);
+ z__3.r = de.r * z__4.r - de.i * z__4.i, z__3.i = de.r * z__4.i + de.i
+ * z__4.r;
+ i__3 = i__ + 1;
+ z__2.r = z__3.r + df[i__3], z__2.i = z__3.i;
+ i__4 = i__ + 1;
+ z__1.r = z__2.r - d__[i__4], z__1.i = z__2.i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L10: */
+ }
+
+/* Compute the 1-norms of the tridiagonal matrices A and WORK. */
+
+ if (*n == 1) {
+ anorm = d__[1];
+ *resid = z_abs(&work[1]);
+ } else {
+/* Computing MAX */
+ d__1 = d__[1] + z_abs(&e[1]), d__2 = d__[*n] + z_abs(&e[*n - 1]);
+ anorm = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = z_abs(&work[1]) + z_abs(&work[*n + 1]), d__2 = z_abs(&work[*n])
+ + z_abs(&work[(*n << 1) - 1]);
+ *resid = max(d__1,d__2);
+ i__1 = *n - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = anorm, d__2 = d__[i__] + z_abs(&e[i__]) + z_abs(&e[i__ - 1]
+ );
+ anorm = max(d__1,d__2);
+/* Computing MAX */
+ d__1 = *resid, d__2 = z_abs(&work[i__]) + z_abs(&work[*n + i__ -
+ 1]) + z_abs(&work[*n + i__]);
+ *resid = max(d__1,d__2);
+/* L20: */
+ }
+ }
+
+/* Compute norm(L*D*L' - A) / (n * norm(A) * EPS) */
+
+ if (anorm <= 0.) {
+ if (*resid != 0.) {
+ *resid = 1. / eps;
+ }
+ } else {
+ *resid = *resid / (doublereal) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of ZPTT01 */
+
+} /* zptt01_ */
diff --git a/TESTING/LIN/zptt02.c b/TESTING/LIN/zptt02.c
new file mode 100644
index 0000000..55338bc
--- /dev/null
+++ b/TESTING/LIN/zptt02.c
@@ -0,0 +1,167 @@
+/* zptt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b4 = -1.;
+static doublereal c_b5 = 1.;
+static integer c__1 = 1;
+
+/* Subroutine */ int zptt02_(char *uplo, integer *n, integer *nrhs,
+ doublereal *d__, doublecomplex *e, doublecomplex *x, integer *ldx,
+ doublecomplex *b, integer *ldb, doublereal *resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ doublereal eps, anorm, bnorm, xnorm;
+ extern doublereal dlamch_(char *), zlanht_(char *, integer *,
+ doublereal *, doublecomplex *), dzasum_(integer *,
+ doublecomplex *, integer *);
+ extern /* Subroutine */ int zlaptm_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublecomplex *, doublecomplex *,
+ integer *, doublereal *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPTT02 computes the residual for the solution to a symmetric */
+/* tridiagonal system of equations: */
+/* RESID = norm(B - A*X) / (norm(A) * norm(X) * EPS), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the superdiagonal or the subdiagonal of the */
+/* tridiagonal matrix A is stored. */
+/* = 'U': E is the superdiagonal of A */
+/* = 'L': E is the subdiagonal of A */
+
+/* N (input) INTEGTER */
+/* The order of the matrix A. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices B and X. NRHS >= 0. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The n by nrhs matrix of solution vectors X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the n by nrhs matrix of right hand side vectors B. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RESID (output) DOUBLE PRECISION */
+/* norm(B - A*X) / (norm(A) * norm(X) * EPS) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Compute the 1-norm of the tridiagonal matrix A. */
+
+ anorm = zlanht_("1", n, &d__[1], &e[1]);
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute B - A*X. */
+
+ zlaptm_(uplo, n, nrhs, &c_b4, &d__[1], &e[1], &x[x_offset], ldx, &c_b5, &
+ b[b_offset], ldb);
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = dzasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = dzasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of ZPTT02 */
+
+} /* zptt02_ */
diff --git a/TESTING/LIN/zptt05.c b/TESTING/LIN/zptt05.c
new file mode 100644
index 0000000..92fe107
--- /dev/null
+++ b/TESTING/LIN/zptt05.c
@@ -0,0 +1,301 @@
+/* zptt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zptt05_(integer *n, integer *nrhs, doublereal *d__,
+ doublecomplex *e, doublecomplex *b, integer *ldb, doublecomplex *x,
+ integer *ldx, doublecomplex *xact, integer *ldxact, doublereal *ferr,
+ doublereal *berr, doublereal *reslts)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1,
+ i__2, i__3, i__4, i__5, i__6, i__7, i__8, i__9;
+ doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10,
+ d__11, d__12;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, nz;
+ doublereal eps, tmp, diff, axbi;
+ integer imax;
+ doublereal unfl, ovfl, xnorm;
+ extern doublereal dlamch_(char *);
+ doublereal errbnd;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZPTT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* Hermitian tridiagonal matrix of order n. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+/* and NZ = max. number of nonzeros in any row of A, plus 1 */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The n diagonal elements of the tridiagonal matrix A. */
+
+/* E (input) COMPLEX*16 array, dimension (N-1) */
+/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ --d__;
+ --e;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.;
+ reslts[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ nz = 4;
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = izamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__2 = imax + j * x_dim1;
+ d__3 = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[imax + j *
+ x_dim1]), abs(d__2));
+ xnorm = max(d__3,unfl);
+ diff = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * xact_dim1;
+ z__2.r = x[i__3].r - xact[i__4].r, z__2.i = x[i__3].i - xact[i__4]
+ .i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+/* Computing MAX */
+ d__3 = diff, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
+ z__1), abs(d__2));
+ diff = max(d__3,d__4);
+/* L10: */
+ }
+
+ if (xnorm > 1.) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1. / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
+ errbnd = max(d__1,d__2);
+ } else {
+ errbnd = 1. / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ if (*n == 1) {
+ i__2 = k * x_dim1 + 1;
+ z__2.r = d__[1] * x[i__2].r, z__2.i = d__[1] * x[i__2].i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ i__3 = k * b_dim1 + 1;
+ axbi = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[k *
+ b_dim1 + 1]), abs(d__2)) + ((d__3 = z__1.r, abs(d__3)) + (
+ d__4 = d_imag(&z__1), abs(d__4)));
+ } else {
+ i__2 = k * x_dim1 + 1;
+ z__2.r = d__[1] * x[i__2].r, z__2.i = d__[1] * x[i__2].i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ i__3 = k * b_dim1 + 1;
+ i__4 = k * x_dim1 + 2;
+ axbi = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[k *
+ b_dim1 + 1]), abs(d__2)) + ((d__3 = z__1.r, abs(d__3)) + (
+ d__4 = d_imag(&z__1), abs(d__4))) + ((d__5 = e[1].r, abs(
+ d__5)) + (d__6 = d_imag(&e[1]), abs(d__6))) * ((d__7 = x[
+ i__4].r, abs(d__7)) + (d__8 = d_imag(&x[k * x_dim1 + 2]),
+ abs(d__8)));
+ i__2 = *n - 1;
+ for (i__ = 2; i__ <= i__2; ++i__) {
+ i__3 = i__;
+ i__4 = i__ + k * x_dim1;
+ z__2.r = d__[i__3] * x[i__4].r, z__2.i = d__[i__3] * x[i__4]
+ .i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ i__5 = i__ + k * b_dim1;
+ i__6 = i__ - 1;
+ i__7 = i__ - 1 + k * x_dim1;
+ i__8 = i__;
+ i__9 = i__ + 1 + k * x_dim1;
+ tmp = (d__1 = b[i__5].r, abs(d__1)) + (d__2 = d_imag(&b[i__ +
+ k * b_dim1]), abs(d__2)) + ((d__3 = e[i__6].r, abs(
+ d__3)) + (d__4 = d_imag(&e[i__ - 1]), abs(d__4))) * ((
+ d__5 = x[i__7].r, abs(d__5)) + (d__6 = d_imag(&x[i__
+ - 1 + k * x_dim1]), abs(d__6))) + ((d__7 = z__1.r,
+ abs(d__7)) + (d__8 = d_imag(&z__1), abs(d__8))) + ((
+ d__9 = e[i__8].r, abs(d__9)) + (d__10 = d_imag(&e[i__]
+ ), abs(d__10))) * ((d__11 = x[i__9].r, abs(d__11)) + (
+ d__12 = d_imag(&x[i__ + 1 + k * x_dim1]), abs(d__12)))
+ ;
+ axbi = min(axbi,tmp);
+/* L40: */
+ }
+ i__2 = *n;
+ i__3 = *n + k * x_dim1;
+ z__2.r = d__[i__2] * x[i__3].r, z__2.i = d__[i__2] * x[i__3].i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+ i__4 = *n + k * b_dim1;
+ i__5 = *n - 1;
+ i__6 = *n - 1 + k * x_dim1;
+ tmp = (d__1 = b[i__4].r, abs(d__1)) + (d__2 = d_imag(&b[*n + k *
+ b_dim1]), abs(d__2)) + ((d__3 = e[i__5].r, abs(d__3)) + (
+ d__4 = d_imag(&e[*n - 1]), abs(d__4))) * ((d__5 = x[i__6]
+ .r, abs(d__5)) + (d__6 = d_imag(&x[*n - 1 + k * x_dim1]),
+ abs(d__6))) + ((d__7 = z__1.r, abs(d__7)) + (d__8 =
+ d_imag(&z__1), abs(d__8)));
+ axbi = min(axbi,tmp);
+ }
+/* Computing MAX */
+ d__1 = axbi, d__2 = nz * unfl;
+ tmp = berr[k] / (nz * eps + nz * unfl / max(d__1,d__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = max(reslts[2],tmp);
+ }
+/* L50: */
+ }
+
+ return 0;
+
+/* End of ZPTT05 */
+
+} /* zptt05_ */
diff --git a/TESTING/LIN/zqlt01.c b/TESTING/LIN/zqlt01.c
new file mode 100644
index 0000000..05368e8
--- /dev/null
+++ b/TESTING/LIN/zqlt01.c
@@ -0,0 +1,258 @@
+/* zqlt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {-1e10,-1e10};
+static doublecomplex c_b12 = {0.,0.};
+static doublecomplex c_b19 = {-1.,0.};
+static doublecomplex c_b20 = {1.,0.};
+static doublereal c_b28 = -1.;
+static doublereal c_b29 = 1.;
+
+/* Subroutine */ int zqlt01_(integer *m, integer *n, doublecomplex *a,
+ doublecomplex *af, doublecomplex *q, doublecomplex *l, integer *lda,
+ doublecomplex *tau, doublecomplex *work, integer *lwork, doublereal *
+ rwork, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
+ q_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal eps;
+ integer info;
+ doublereal resid, anorm;
+ integer minmn;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zherk_(char *, char *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int zgeqlf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *
+), zlacpy_(char *, integer *, integer *, doublecomplex *, integer
+ *, doublecomplex *, integer *), zlaset_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *);
+ extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zungql_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZQLT01 tests ZGEQLF, which computes the QL factorization of an m-by-n */
+/* matrix A, and partially tests ZUNGQL which forms the m-by-m */
+/* orthogonal matrix Q. */
+
+/* ZQLT01 compares L with Q'*A, and checks that Q is orthogonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The m-by-n matrix A. */
+
+/* AF (output) COMPLEX*16 array, dimension (LDA,N) */
+/* Details of the QL factorization of A, as returned by ZGEQLF. */
+/* See ZGEQLF for further details. */
+
+/* Q (output) COMPLEX*16 array, dimension (LDA,M) */
+/* The m-by-m orthogonal matrix Q. */
+
+/* L (workspace) COMPLEX*16 array, dimension (LDA,max(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and R. */
+/* LDA >= max(M,N). */
+
+/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by ZGEQLF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ l_dim1 = *lda;
+ l_offset = 1 + l_dim1;
+ l -= l_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ minmn = min(*m,*n);
+ eps = dlamch_("Epsilon");
+
+/* Copy the matrix A to the array AF. */
+
+ zlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+
+/* Factorize the matrix A in the array AF. */
+
+ s_copy(srnamc_1.srnamt, "ZGEQLF", (ftnlen)32, (ftnlen)6);
+ zgeqlf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy details of Q */
+
+ zlaset_("Full", m, m, &c_b1, &c_b1, &q[q_offset], lda);
+ if (*m >= *n) {
+ if (*n < *m && *n > 0) {
+ i__1 = *m - *n;
+ zlacpy_("Full", &i__1, n, &af[af_offset], lda, &q[(*m - *n + 1) *
+ q_dim1 + 1], lda);
+ }
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ zlacpy_("Upper", &i__1, &i__2, &af[*m - *n + 1 + (af_dim1 << 1)],
+ lda, &q[*m - *n + 1 + (*m - *n + 2) * q_dim1], lda);
+ }
+ } else {
+ if (*m > 1) {
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ zlacpy_("Upper", &i__1, &i__2, &af[(*n - *m + 2) * af_dim1 + 1],
+ lda, &q[(q_dim1 << 1) + 1], lda);
+ }
+ }
+
+/* Generate the m-by-m matrix Q */
+
+ s_copy(srnamc_1.srnamt, "ZUNGQL", (ftnlen)32, (ftnlen)6);
+ zungql_(m, m, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy L */
+
+ zlaset_("Full", m, n, &c_b12, &c_b12, &l[l_offset], lda);
+ if (*m >= *n) {
+ if (*n > 0) {
+ zlacpy_("Lower", n, n, &af[*m - *n + 1 + af_dim1], lda, &l[*m - *
+ n + 1 + l_dim1], lda);
+ }
+ } else {
+ if (*n > *m && *m > 0) {
+ i__1 = *n - *m;
+ zlacpy_("Full", m, &i__1, &af[af_offset], lda, &l[l_offset], lda);
+ }
+ if (*m > 0) {
+ zlacpy_("Lower", m, m, &af[(*n - *m + 1) * af_dim1 + 1], lda, &l[(
+ *n - *m + 1) * l_dim1 + 1], lda);
+ }
+ }
+
+/* Compute L - Q'*A */
+
+ zgemm_("Conjugate transpose", "No transpose", m, n, m, &c_b19, &q[
+ q_offset], lda, &a[a_offset], lda, &c_b20, &l[l_offset], lda);
+
+/* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */
+
+ anorm = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ resid = zlange_("1", m, n, &l[l_offset], lda, &rwork[1]);
+ if (anorm > 0.) {
+ result[1] = resid / (doublereal) max(1,*m) / anorm / eps;
+ } else {
+ result[1] = 0.;
+ }
+
+/* Compute I - Q'*Q */
+
+ zlaset_("Full", m, m, &c_b12, &c_b20, &l[l_offset], lda);
+ zherk_("Upper", "Conjugate transpose", m, m, &c_b28, &q[q_offset], lda, &
+ c_b29, &l[l_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
+
+ resid = zlansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
+
+ result[2] = resid / (doublereal) max(1,*m) / eps;
+
+ return 0;
+
+/* End of ZQLT01 */
+
+} /* zqlt01_ */
diff --git a/TESTING/LIN/zqlt02.c b/TESTING/LIN/zqlt02.c
new file mode 100644
index 0000000..0f1555e
--- /dev/null
+++ b/TESTING/LIN/zqlt02.c
@@ -0,0 +1,243 @@
+/* zqlt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {-1e10,-1e10};
+static doublecomplex c_b9 = {0.,0.};
+static doublecomplex c_b14 = {-1.,0.};
+static doublecomplex c_b15 = {1.,0.};
+static doublereal c_b23 = -1.;
+static doublereal c_b24 = 1.;
+
+/* Subroutine */ int zqlt02_(integer *m, integer *n, integer *k,
+ doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex *
+ l, integer *lda, doublecomplex *tau, doublecomplex *work, integer *
+ lwork, doublereal *rwork, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
+ q_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal eps;
+ integer info;
+ doublereal resid, anorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zherk_(char *, char *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *);
+ extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zungql_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZQLT02 tests ZUNGQL, which generates an m-by-n matrix Q with */
+/* orthonornmal columns that is defined as the product of k elementary */
+/* reflectors. */
+
+/* Given the QL factorization of an m-by-n matrix A, ZQLT02 generates */
+/* the orthogonal matrix Q defined by the factorization of the last k */
+/* columns of A; it compares L(m-n+1:m,n-k+1:n) with */
+/* Q(1:m,m-n+1:m)'*A(1:m,n-k+1:n), and checks that the columns of Q are */
+/* orthonormal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q to be generated. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q to be generated. */
+/* M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The m-by-n matrix A which was factorized by ZQLT01. */
+
+/* AF (input) COMPLEX*16 array, dimension (LDA,N) */
+/* Details of the QL factorization of A, as returned by ZGEQLF. */
+/* See ZGEQLF for further details. */
+
+/* Q (workspace) COMPLEX*16 array, dimension (LDA,N) */
+
+/* L (workspace) COMPLEX*16 array, dimension (LDA,N) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and L. LDA >= M. */
+
+/* TAU (input) COMPLEX*16 array, dimension (N) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the QL factorization in AF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ l_dim1 = *lda;
+ l_offset = 1 + l_dim1;
+ l -= l_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ if (*m == 0 || *n == 0 || *k == 0) {
+ result[1] = 0.;
+ result[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+
+/* Copy the last k columns of the factorization to the array Q */
+
+ zlaset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
+ if (*k < *m) {
+ i__1 = *m - *k;
+ zlacpy_("Full", &i__1, k, &af[(*n - *k + 1) * af_dim1 + 1], lda, &q[(*
+ n - *k + 1) * q_dim1 + 1], lda);
+ }
+ if (*k > 1) {
+ i__1 = *k - 1;
+ i__2 = *k - 1;
+ zlacpy_("Upper", &i__1, &i__2, &af[*m - *k + 1 + (*n - *k + 2) *
+ af_dim1], lda, &q[*m - *k + 1 + (*n - *k + 2) * q_dim1], lda);
+ }
+
+/* Generate the last n columns of the matrix Q */
+
+ s_copy(srnamc_1.srnamt, "ZUNGQL", (ftnlen)32, (ftnlen)6);
+ zungql_(m, n, k, &q[q_offset], lda, &tau[*n - *k + 1], &work[1], lwork, &
+ info);
+
+/* Copy L(m-n+1:m,n-k+1:n) */
+
+ zlaset_("Full", n, k, &c_b9, &c_b9, &l[*m - *n + 1 + (*n - *k + 1) *
+ l_dim1], lda);
+ zlacpy_("Lower", k, k, &af[*m - *k + 1 + (*n - *k + 1) * af_dim1], lda, &
+ l[*m - *k + 1 + (*n - *k + 1) * l_dim1], lda);
+
+/* Compute L(m-n+1:m,n-k+1:n) - Q(1:m,m-n+1:m)' * A(1:m,n-k+1:n) */
+
+ zgemm_("Conjugate transpose", "No transpose", n, k, m, &c_b14, &q[
+ q_offset], lda, &a[(*n - *k + 1) * a_dim1 + 1], lda, &c_b15, &l[*
+ m - *n + 1 + (*n - *k + 1) * l_dim1], lda)
+ ;
+
+/* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */
+
+ anorm = zlange_("1", m, k, &a[(*n - *k + 1) * a_dim1 + 1], lda, &rwork[1]);
+ resid = zlange_("1", n, k, &l[*m - *n + 1 + (*n - *k + 1) * l_dim1], lda,
+ &rwork[1]);
+ if (anorm > 0.) {
+ result[1] = resid / (doublereal) max(1,*m) / anorm / eps;
+ } else {
+ result[1] = 0.;
+ }
+
+/* Compute I - Q'*Q */
+
+ zlaset_("Full", n, n, &c_b9, &c_b15, &l[l_offset], lda);
+ zherk_("Upper", "Conjugate transpose", n, m, &c_b23, &q[q_offset], lda, &
+ c_b24, &l[l_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
+
+ resid = zlansy_("1", "Upper", n, &l[l_offset], lda, &rwork[1]);
+
+ result[2] = resid / (doublereal) max(1,*m) / eps;
+
+ return 0;
+
+/* End of ZQLT02 */
+
+} /* zqlt02_ */
diff --git a/TESTING/LIN/zqlt03.c b/TESTING/LIN/zqlt03.c
new file mode 100644
index 0000000..0a6b0e6
--- /dev/null
+++ b/TESTING/LIN/zqlt03.c
@@ -0,0 +1,288 @@
+/* zqlt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {-1e10,-1e10};
+static integer c__2 = 2;
+static doublecomplex c_b21 = {-1.,0.};
+static doublecomplex c_b22 = {1.,0.};
+
+/* Subroutine */ int zqlt03_(integer *m, integer *n, integer *k,
+ doublecomplex *af, doublecomplex *c__, doublecomplex *cc,
+ doublecomplex *q, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *lwork, doublereal *rwork, doublereal *result)
+{
+ /* Initialized data */
+
+ static integer iseed[4] = { 1988,1989,1990,1991 };
+
+ /* System generated locals */
+ integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1,
+ q_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j, mc, nc;
+ doublereal eps;
+ char side[1];
+ integer info, iside;
+ extern logical lsame_(char *, char *);
+ doublereal resid;
+ integer minmn;
+ doublereal cnorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ char trans[1];
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ integer itrans;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *), zlarnv_(
+ integer *, integer *, integer *, doublecomplex *), zungql_(
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *), zunmql_(
+ char *, char *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZQLT03 tests ZUNMQL, which computes Q*C, Q'*C, C*Q or C*Q'. */
+
+/* ZQLT03 compares the results of a call to ZUNMQL with the results of */
+/* forming Q explicitly by a call to ZUNGQL and then performing matrix */
+/* multiplication by a call to ZGEMM. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The order of the orthogonal matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of rows or columns of the matrix C; C is m-by-n if */
+/* Q is applied from the left, or n-by-m if Q is applied from */
+/* the right. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* orthogonal matrix Q. M >= K >= 0. */
+
+/* AF (input) COMPLEX*16 array, dimension (LDA,N) */
+/* Details of the QL factorization of an m-by-n matrix, as */
+/* returned by ZGEQLF. See CGEQLF for further details. */
+
+/* C (workspace) COMPLEX*16 array, dimension (LDA,N) */
+
+/* CC (workspace) COMPLEX*16 array, dimension (LDA,N) */
+
+/* Q (workspace) COMPLEX*16 array, dimension (LDA,M) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays AF, C, CC, and Q. */
+
+/* TAU (input) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the QL factorization in AF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK must be at least M, and should be */
+/* M*NB, where NB is the blocksize for this environment. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
+/* The test ratios compare two techniques for multiplying a */
+/* random matrix C by an m-by-m orthogonal matrix Q. */
+/* RESULT(1) = norm( Q*C - Q*C ) / ( M * norm(C) * EPS ) */
+/* RESULT(2) = norm( C*Q - C*Q ) / ( M * norm(C) * EPS ) */
+/* RESULT(3) = norm( Q'*C - Q'*C )/ ( M * norm(C) * EPS ) */
+/* RESULT(4) = norm( C*Q' - C*Q' )/ ( M * norm(C) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ cc_dim1 = *lda;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+ c_dim1 = *lda;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = dlamch_("Epsilon");
+ minmn = min(*m,*n);
+
+/* Quick return if possible */
+
+ if (minmn == 0) {
+ result[1] = 0.;
+ result[2] = 0.;
+ result[3] = 0.;
+ result[4] = 0.;
+ return 0;
+ }
+
+/* Copy the last k columns of the factorization to the array Q */
+
+ zlaset_("Full", m, m, &c_b1, &c_b1, &q[q_offset], lda);
+ if (*k > 0 && *m > *k) {
+ i__1 = *m - *k;
+ zlacpy_("Full", &i__1, k, &af[(*n - *k + 1) * af_dim1 + 1], lda, &q[(*
+ m - *k + 1) * q_dim1 + 1], lda);
+ }
+ if (*k > 1) {
+ i__1 = *k - 1;
+ i__2 = *k - 1;
+ zlacpy_("Upper", &i__1, &i__2, &af[*m - *k + 1 + (*n - *k + 2) *
+ af_dim1], lda, &q[*m - *k + 1 + (*m - *k + 2) * q_dim1], lda);
+ }
+
+/* Generate the m-by-m matrix Q */
+
+ s_copy(srnamc_1.srnamt, "ZUNGQL", (ftnlen)32, (ftnlen)6);
+ zungql_(m, m, k, &q[q_offset], lda, &tau[minmn - *k + 1], &work[1], lwork,
+ &info);
+
+ for (iside = 1; iside <= 2; ++iside) {
+ if (iside == 1) {
+ *(unsigned char *)side = 'L';
+ mc = *m;
+ nc = *n;
+ } else {
+ *(unsigned char *)side = 'R';
+ mc = *n;
+ nc = *m;
+ }
+
+/* Generate MC by NC matrix C */
+
+ i__1 = nc;
+ for (j = 1; j <= i__1; ++j) {
+ zlarnv_(&c__2, iseed, &mc, &c__[j * c_dim1 + 1]);
+/* L10: */
+ }
+ cnorm = zlange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]);
+ if (cnorm == 0.) {
+ cnorm = 1.;
+ }
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+ if (itrans == 1) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'C';
+ }
+
+/* Copy C */
+
+ zlacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
+ lda);
+
+/* Apply Q or Q' to C */
+
+ s_copy(srnamc_1.srnamt, "ZUNMQL", (ftnlen)32, (ftnlen)6);
+ if (*k > 0) {
+ zunmql_(side, trans, &mc, &nc, k, &af[(*n - *k + 1) * af_dim1
+ + 1], lda, &tau[minmn - *k + 1], &cc[cc_offset], lda,
+ &work[1], lwork, &info);
+ }
+
+/* Form explicit product and subtract */
+
+ if (lsame_(side, "L")) {
+ zgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b21, &q[
+ q_offset], lda, &c__[c_offset], lda, &c_b22, &cc[
+ cc_offset], lda);
+ } else {
+ zgemm_("No transpose", trans, &mc, &nc, &nc, &c_b21, &c__[
+ c_offset], lda, &q[q_offset], lda, &c_b22, &cc[
+ cc_offset], lda);
+ }
+
+/* Compute error in the difference */
+
+ resid = zlange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
+ result[(iside - 1 << 1) + itrans] = resid / ((doublereal) max(1,*
+ m) * cnorm * eps);
+
+/* L20: */
+ }
+/* L30: */
+ }
+
+ return 0;
+
+/* End of ZQLT03 */
+
+} /* zqlt03_ */
diff --git a/TESTING/LIN/zqpt01.c b/TESTING/LIN/zqpt01.c
new file mode 100644
index 0000000..1851961
--- /dev/null
+++ b/TESTING/LIN/zqpt01.c
@@ -0,0 +1,197 @@
+/* zqpt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__10 = 10;
+static integer c__1 = 1;
+static doublecomplex c_b16 = {-1.,0.};
+
+doublereal zqpt01_(integer *m, integer *n, integer *k, doublecomplex *a,
+ doublecomplex *af, integer *lda, doublecomplex *tau, integer *jpvt,
+ doublecomplex *work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val;
+
+ /* Local variables */
+ integer i__, j, info;
+ doublereal norma, rwork[1];
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zunmqr_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZQPT01 tests the QR-factorization with pivoting of a matrix A. The */
+/* array AF contains the (possibly partial) QR-factorization of A, where */
+/* the upper triangle of AF(1:k,1:k) is a partial triangular factor, */
+/* the entries below the diagonal in the first k columns are the */
+/* Householder vectors, and the rest of AF contains a partially updated */
+/* matrix. */
+
+/* This function returns ||A*P - Q*R||/(||norm(A)||*eps*M) */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices A and AF. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and AF. */
+
+/* K (input) INTEGER */
+/* The number of columns of AF that have been reduced */
+/* to upper triangular form. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA, N) */
+/* The original matrix A. */
+
+/* AF (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The (possibly partial) output of ZGEQPF. The upper triangle */
+/* of AF(1:k,1:k) is a partial triangular factor, the entries */
+/* below the diagonal in the first k columns are the Householder */
+/* vectors, and the rest of AF contains a partially updated */
+/* matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A and AF. */
+
+/* TAU (input) COMPLEX*16 array, dimension (K) */
+/* Details of the Householder transformations as returned by */
+/* ZGEQPF. */
+
+/* JPVT (input) INTEGER array, dimension (N) */
+/* Pivot information as returned by ZGEQPF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= M*N+N. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --jpvt;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.;
+
+/* Test if there is enough workspace */
+
+ if (*lwork < *m * *n + *n) {
+ xerbla_("ZQPT01", &c__10);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return ret_val;
+ }
+
+ norma = zlange_("One-norm", m, n, &a[a_offset], lda, rwork);
+
+ i__1 = *k;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(j,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = (j - 1) * *m + i__;
+ i__4 = i__ + j * af_dim1;
+ work[i__3].r = af[i__4].r, work[i__3].i = af[i__4].i;
+/* L10: */
+ }
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = (j - 1) * *m + i__;
+ work[i__3].r = 0., work[i__3].i = 0.;
+/* L20: */
+ }
+/* L30: */
+ }
+ i__1 = *n;
+ for (j = *k + 1; j <= i__1; ++j) {
+ zcopy_(m, &af[j * af_dim1 + 1], &c__1, &work[(j - 1) * *m + 1], &c__1)
+ ;
+/* L40: */
+ }
+
+ i__1 = *lwork - *m * *n;
+ zunmqr_("Left", "No transpose", m, n, k, &af[af_offset], lda, &tau[1], &
+ work[1], m, &work[*m * *n + 1], &i__1, &info);
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+
+/* Compare i-th column of QR and jpvt(i)-th column of A */
+
+ zaxpy_(m, &c_b16, &a[jpvt[j] * a_dim1 + 1], &c__1, &work[(j - 1) * *m
+ + 1], &c__1);
+/* L50: */
+ }
+
+ ret_val = zlange_("One-norm", m, n, &work[1], m, rwork) / ((
+ doublereal) max(*m,*n) * dlamch_("Epsilon"));
+ if (norma != 0.) {
+ ret_val /= norma;
+ }
+
+ return ret_val;
+
+/* End of ZQPT01 */
+
+} /* zqpt01_ */
diff --git a/TESTING/LIN/zqrt01.c b/TESTING/LIN/zqrt01.c
new file mode 100644
index 0000000..0cb032c
--- /dev/null
+++ b/TESTING/LIN/zqrt01.c
@@ -0,0 +1,226 @@
+/* zqrt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {-1e10,-1e10};
+static doublecomplex c_b10 = {0.,0.};
+static doublecomplex c_b15 = {-1.,0.};
+static doublecomplex c_b16 = {1.,0.};
+static doublereal c_b24 = -1.;
+static doublereal c_b25 = 1.;
+
+/* Subroutine */ int zqrt01_(integer *m, integer *n, doublecomplex *a,
+ doublecomplex *af, doublecomplex *q, doublecomplex *r__, integer *lda,
+ doublecomplex *tau, doublecomplex *work, integer *lwork, doublereal *
+ rwork, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
+ r_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal eps;
+ integer info;
+ doublereal resid, anorm;
+ integer minmn;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zherk_(char *, char *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int zgeqrf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *
+), zlacpy_(char *, integer *, integer *, doublecomplex *, integer
+ *, doublecomplex *, integer *), zlaset_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *);
+ extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zungqr_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZQRT01 tests ZGEQRF, which computes the QR factorization of an m-by-n */
+/* matrix A, and partially tests ZUNGQR which forms the m-by-m */
+/* orthogonal matrix Q. */
+
+/* ZQRT01 compares R with Q'*A, and checks that Q is orthogonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The m-by-n matrix A. */
+
+/* AF (output) COMPLEX*16 array, dimension (LDA,N) */
+/* Details of the QR factorization of A, as returned by ZGEQRF. */
+/* See ZGEQRF for further details. */
+
+/* Q (output) COMPLEX*16 array, dimension (LDA,M) */
+/* The m-by-m orthogonal matrix Q. */
+
+/* R (workspace) COMPLEX*16 array, dimension (LDA,max(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and R. */
+/* LDA >= max(M,N). */
+
+/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by ZGEQRF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - Q'*A ) / ( M * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ minmn = min(*m,*n);
+ eps = dlamch_("Epsilon");
+
+/* Copy the matrix A to the array AF. */
+
+ zlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+
+/* Factorize the matrix A in the array AF. */
+
+ s_copy(srnamc_1.srnamt, "ZGEQRF", (ftnlen)32, (ftnlen)6);
+ zgeqrf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy details of Q */
+
+ zlaset_("Full", m, m, &c_b1, &c_b1, &q[q_offset], lda);
+ i__1 = *m - 1;
+ zlacpy_("Lower", &i__1, n, &af[af_dim1 + 2], lda, &q[q_dim1 + 2], lda);
+
+/* Generate the m-by-m matrix Q */
+
+ s_copy(srnamc_1.srnamt, "ZUNGQR", (ftnlen)32, (ftnlen)6);
+ zungqr_(m, m, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy R */
+
+ zlaset_("Full", m, n, &c_b10, &c_b10, &r__[r_offset], lda);
+ zlacpy_("Upper", m, n, &af[af_offset], lda, &r__[r_offset], lda);
+
+/* Compute R - Q'*A */
+
+ zgemm_("Conjugate transpose", "No transpose", m, n, m, &c_b15, &q[
+ q_offset], lda, &a[a_offset], lda, &c_b16, &r__[r_offset], lda);
+
+/* Compute norm( R - Q'*A ) / ( M * norm(A) * EPS ) . */
+
+ anorm = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ resid = zlange_("1", m, n, &r__[r_offset], lda, &rwork[1]);
+ if (anorm > 0.) {
+ result[1] = resid / (doublereal) max(1,*m) / anorm / eps;
+ } else {
+ result[1] = 0.;
+ }
+
+/* Compute I - Q'*Q */
+
+ zlaset_("Full", m, m, &c_b10, &c_b16, &r__[r_offset], lda);
+ zherk_("Upper", "Conjugate transpose", m, m, &c_b24, &q[q_offset], lda, &
+ c_b25, &r__[r_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
+
+ resid = zlansy_("1", "Upper", m, &r__[r_offset], lda, &rwork[1]);
+
+ result[2] = resid / (doublereal) max(1,*m) / eps;
+
+ return 0;
+
+/* End of ZQRT01 */
+
+} /* zqrt01_ */
diff --git a/TESTING/LIN/zqrt02.c b/TESTING/LIN/zqrt02.c
new file mode 100644
index 0000000..600a11b
--- /dev/null
+++ b/TESTING/LIN/zqrt02.c
@@ -0,0 +1,219 @@
+/* zqrt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {-1e10,-1e10};
+static doublecomplex c_b8 = {0.,0.};
+static doublecomplex c_b13 = {-1.,0.};
+static doublecomplex c_b14 = {1.,0.};
+static doublereal c_b22 = -1.;
+static doublereal c_b23 = 1.;
+
+/* Subroutine */ int zqrt02_(integer *m, integer *n, integer *k,
+ doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex *
+ r__, integer *lda, doublecomplex *tau, doublecomplex *work, integer *
+ lwork, doublereal *rwork, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
+ r_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal eps;
+ integer info;
+ doublereal resid, anorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zherk_(char *, char *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *);
+ extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zungqr_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZQRT02 tests ZUNGQR, which generates an m-by-n matrix Q with */
+/* orthonornmal columns that is defined as the product of k elementary */
+/* reflectors. */
+
+/* Given the QR factorization of an m-by-n matrix A, ZQRT02 generates */
+/* the orthogonal matrix Q defined by the factorization of the first k */
+/* columns of A; it compares R(1:n,1:k) with Q(1:m,1:n)'*A(1:m,1:k), */
+/* and checks that the columns of Q are orthonormal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q to be generated. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q to be generated. */
+/* M >= N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. N >= K >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The m-by-n matrix A which was factorized by ZQRT01. */
+
+/* AF (input) COMPLEX*16 array, dimension (LDA,N) */
+/* Details of the QR factorization of A, as returned by ZGEQRF. */
+/* See ZGEQRF for further details. */
+
+/* Q (workspace) COMPLEX*16 array, dimension (LDA,N) */
+
+/* R (workspace) COMPLEX*16 array, dimension (LDA,N) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and R. LDA >= M. */
+
+/* TAU (input) COMPLEX*16 array, dimension (N) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the QR factorization in AF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - Q'*A ) / ( M * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ eps = dlamch_("Epsilon");
+
+/* Copy the first k columns of the factorization to the array Q */
+
+ zlaset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
+ i__1 = *m - 1;
+ zlacpy_("Lower", &i__1, k, &af[af_dim1 + 2], lda, &q[q_dim1 + 2], lda);
+
+/* Generate the first n columns of the matrix Q */
+
+ s_copy(srnamc_1.srnamt, "ZUNGQR", (ftnlen)32, (ftnlen)6);
+ zungqr_(m, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy R(1:n,1:k) */
+
+ zlaset_("Full", n, k, &c_b8, &c_b8, &r__[r_offset], lda);
+ zlacpy_("Upper", n, k, &af[af_offset], lda, &r__[r_offset], lda);
+
+/* Compute R(1:n,1:k) - Q(1:m,1:n)' * A(1:m,1:k) */
+
+ zgemm_("Conjugate transpose", "No transpose", n, k, m, &c_b13, &q[
+ q_offset], lda, &a[a_offset], lda, &c_b14, &r__[r_offset], lda);
+
+/* Compute norm( R - Q'*A ) / ( M * norm(A) * EPS ) . */
+
+ anorm = zlange_("1", m, k, &a[a_offset], lda, &rwork[1]);
+ resid = zlange_("1", n, k, &r__[r_offset], lda, &rwork[1]);
+ if (anorm > 0.) {
+ result[1] = resid / (doublereal) max(1,*m) / anorm / eps;
+ } else {
+ result[1] = 0.;
+ }
+
+/* Compute I - Q'*Q */
+
+ zlaset_("Full", n, n, &c_b8, &c_b14, &r__[r_offset], lda);
+ zherk_("Upper", "Conjugate transpose", n, m, &c_b22, &q[q_offset], lda, &
+ c_b23, &r__[r_offset], lda);
+
+/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
+
+ resid = zlansy_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
+
+ result[2] = resid / (doublereal) max(1,*m) / eps;
+
+ return 0;
+
+/* End of ZQRT02 */
+
+} /* zqrt02_ */
diff --git a/TESTING/LIN/zqrt03.c b/TESTING/LIN/zqrt03.c
new file mode 100644
index 0000000..770acbb
--- /dev/null
+++ b/TESTING/LIN/zqrt03.c
@@ -0,0 +1,262 @@
+/* zqrt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {-1e10,-1e10};
+static integer c__2 = 2;
+static doublecomplex c_b20 = {-1.,0.};
+static doublecomplex c_b21 = {1.,0.};
+
+/* Subroutine */ int zqrt03_(integer *m, integer *n, integer *k,
+ doublecomplex *af, doublecomplex *c__, doublecomplex *cc,
+ doublecomplex *q, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *lwork, doublereal *rwork, doublereal *result)
+{
+ /* Initialized data */
+
+ static integer iseed[4] = { 1988,1989,1990,1991 };
+
+ /* System generated locals */
+ integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1,
+ q_offset, i__1;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j, mc, nc;
+ doublereal eps;
+ char side[1];
+ integer info, iside;
+ extern logical lsame_(char *, char *);
+ doublereal resid, cnorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ char trans[1];
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ integer itrans;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *), zlarnv_(
+ integer *, integer *, integer *, doublecomplex *), zungqr_(
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *), zunmqr_(
+ char *, char *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZQRT03 tests ZUNMQR, which computes Q*C, Q'*C, C*Q or C*Q'. */
+
+/* ZQRT03 compares the results of a call to ZUNMQR with the results of */
+/* forming Q explicitly by a call to ZUNGQR and then performing matrix */
+/* multiplication by a call to ZGEMM. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The order of the orthogonal matrix Q. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of rows or columns of the matrix C; C is m-by-n if */
+/* Q is applied from the left, or n-by-m if Q is applied from */
+/* the right. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* orthogonal matrix Q. M >= K >= 0. */
+
+/* AF (input) COMPLEX*16 array, dimension (LDA,N) */
+/* Details of the QR factorization of an m-by-n matrix, as */
+/* returnedby ZGEQRF. See CGEQRF for further details. */
+
+/* C (workspace) COMPLEX*16 array, dimension (LDA,N) */
+
+/* CC (workspace) COMPLEX*16 array, dimension (LDA,N) */
+
+/* Q (workspace) COMPLEX*16 array, dimension (LDA,M) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays AF, C, CC, and Q. */
+
+/* TAU (input) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the QR factorization in AF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK must be at least M, and should be */
+/* M*NB, where NB is the blocksize for this environment. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
+/* The test ratios compare two techniques for multiplying a */
+/* random matrix C by an m-by-m orthogonal matrix Q. */
+/* RESULT(1) = norm( Q*C - Q*C ) / ( M * norm(C) * EPS ) */
+/* RESULT(2) = norm( C*Q - C*Q ) / ( M * norm(C) * EPS ) */
+/* RESULT(3) = norm( Q'*C - Q'*C )/ ( M * norm(C) * EPS ) */
+/* RESULT(4) = norm( C*Q' - C*Q' )/ ( M * norm(C) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ cc_dim1 = *lda;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+ c_dim1 = *lda;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = dlamch_("Epsilon");
+
+/* Copy the first k columns of the factorization to the array Q */
+
+ zlaset_("Full", m, m, &c_b1, &c_b1, &q[q_offset], lda);
+ i__1 = *m - 1;
+ zlacpy_("Lower", &i__1, k, &af[af_dim1 + 2], lda, &q[q_dim1 + 2], lda);
+
+/* Generate the m-by-m matrix Q */
+
+ s_copy(srnamc_1.srnamt, "ZUNGQR", (ftnlen)32, (ftnlen)6);
+ zungqr_(m, m, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+ for (iside = 1; iside <= 2; ++iside) {
+ if (iside == 1) {
+ *(unsigned char *)side = 'L';
+ mc = *m;
+ nc = *n;
+ } else {
+ *(unsigned char *)side = 'R';
+ mc = *n;
+ nc = *m;
+ }
+
+/* Generate MC by NC matrix C */
+
+ i__1 = nc;
+ for (j = 1; j <= i__1; ++j) {
+ zlarnv_(&c__2, iseed, &mc, &c__[j * c_dim1 + 1]);
+/* L10: */
+ }
+ cnorm = zlange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]);
+ if (cnorm == 0.) {
+ cnorm = 1.;
+ }
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+ if (itrans == 1) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'C';
+ }
+
+/* Copy C */
+
+ zlacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
+ lda);
+
+/* Apply Q or Q' to C */
+
+ s_copy(srnamc_1.srnamt, "ZUNMQR", (ftnlen)32, (ftnlen)6);
+ zunmqr_(side, trans, &mc, &nc, k, &af[af_offset], lda, &tau[1], &
+ cc[cc_offset], lda, &work[1], lwork, &info);
+
+/* Form explicit product and subtract */
+
+ if (lsame_(side, "L")) {
+ zgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b20, &q[
+ q_offset], lda, &c__[c_offset], lda, &c_b21, &cc[
+ cc_offset], lda);
+ } else {
+ zgemm_("No transpose", trans, &mc, &nc, &nc, &c_b20, &c__[
+ c_offset], lda, &q[q_offset], lda, &c_b21, &cc[
+ cc_offset], lda);
+ }
+
+/* Compute error in the difference */
+
+ resid = zlange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
+ result[(iside - 1 << 1) + itrans] = resid / ((doublereal) max(1,*
+ m) * cnorm * eps);
+
+/* L20: */
+ }
+/* L30: */
+ }
+
+ return 0;
+
+/* End of ZQRT03 */
+
+} /* zqrt03_ */
diff --git a/TESTING/LIN/zqrt11.c b/TESTING/LIN/zqrt11.c
new file mode 100644
index 0000000..0f7f085
--- /dev/null
+++ b/TESTING/LIN/zqrt11.c
@@ -0,0 +1,160 @@
+/* zqrt11.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__7 = 7;
+static doublecomplex c_b5 = {0.,0.};
+static doublecomplex c_b6 = {1.,0.};
+
+doublereal zqrt11_(integer *m, integer *k, doublecomplex *a, integer *lda,
+ doublecomplex *tau, doublecomplex *work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal ret_val;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer j, info;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+ doublereal rdummy[1];
+
+
+/* -- LAPACK routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZQRT11 computes the test ratio */
+
+/* || Q'*Q - I || / (eps * m) */
+
+/* where the orthogonal matrix Q is represented as a product of */
+/* elementary transformations. Each transformation has the form */
+
+/* H(k) = I - tau(k) v(k) v(k)' */
+
+/* where tau(k) is stored in TAU(k) and v(k) is an m-vector of the form */
+/* [ 0 ... 0 1 x(k) ]', where x(k) is a vector of length m-k stored */
+/* in A(k+1:m,k). */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* K (input) INTEGER */
+/* The number of columns of A whose subdiagonal entries */
+/* contain information about orthogonal transformations. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,K) */
+/* The (possibly partial) output of a QR reduction routine. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* TAU (input) COMPLEX*16 array, dimension (K) */
+/* The scaling factors tau for the elementary transformations as */
+/* computed by the QR factorization routine. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= M*M + M. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.;
+
+/* Test for sufficient workspace */
+
+ if (*lwork < *m * *m + *m) {
+ xerbla_("ZQRT11", &c__7);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0) {
+ return ret_val;
+ }
+
+ zlaset_("Full", m, m, &c_b5, &c_b6, &work[1], m);
+
+/* Form Q */
+
+ zunm2r_("Left", "No transpose", m, m, k, &a[a_offset], lda, &tau[1], &
+ work[1], m, &work[*m * *m + 1], &info);
+
+/* Form Q'*Q */
+
+ zunm2r_("Left", "Conjugate transpose", m, m, k, &a[a_offset], lda, &tau[1]
+, &work[1], m, &work[*m * *m + 1], &info);
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (j - 1) * *m + j;
+ i__3 = (j - 1) * *m + j;
+ z__1.r = work[i__3].r - 1., z__1.i = work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L10: */
+ }
+
+ ret_val = zlange_("One-norm", m, m, &work[1], m, rdummy) / ((
+ doublereal) (*m) * dlamch_("Epsilon"));
+
+ return ret_val;
+
+/* End of ZQRT11 */
+
+} /* zqrt11_ */
diff --git a/TESTING/LIN/zqrt12.c b/TESTING/LIN/zqrt12.c
new file mode 100644
index 0000000..bf98826
--- /dev/null
+++ b/TESTING/LIN/zqrt12.c
@@ -0,0 +1,230 @@
+/* zqrt12.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__7 = 7;
+static integer c__1 = 1;
+static doublecomplex c_b6 = {0.,0.};
+static integer c__0 = 0;
+static doublereal c_b33 = -1.;
+
+doublereal zqrt12_(integer *m, integer *n, doublecomplex *a, integer *lda,
+ doublereal *s, doublecomplex *work, integer *lwork, doublereal *rwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val;
+
+ /* Local variables */
+ integer i__, j, mn, iscl, info;
+ doublereal anrm;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *), dasum_(
+ integer *, doublereal *, integer *);
+ extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
+ integer *, doublereal *, integer *);
+ doublereal dummy[1];
+ extern /* Subroutine */ int zgebd2_(integer *, integer *, doublecomplex *,
+ integer *, doublereal *, doublereal *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *), dlabad_(doublereal *
+, doublereal *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *), xerbla_(char *, integer *),
+ dbdsqr_(char *, integer *, integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, integer *, doublereal *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ doublereal bignum;
+ extern /* Subroutine */ int zlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublecomplex *,
+ integer *, integer *), zlaset_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *);
+ doublereal smlnum, nrmsvl;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZQRT12 computes the singular values `svlues' of the upper trapezoid */
+/* of A(1:M,1:N) and returns the ratio */
+
+/* || s - svlues||/(||svlues||*eps*max(M,N)) */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The M-by-N matrix A. Only the upper trapezoid is referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* S (input) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The singular values of the matrix A. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= M*N + 2*min(M,N) + */
+/* max(M,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (2*min(M,N)) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --s;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ ret_val = 0.;
+
+/* Test that enough workspace is supplied */
+
+ if (*lwork < *m * *n + (min(*m,*n) << 1) + max(*m,*n)) {
+ xerbla_("ZQRT12", &c__7);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ mn = min(*m,*n);
+ if ((doublereal) mn <= 0.) {
+ return ret_val;
+ }
+
+ nrmsvl = dnrm2_(&mn, &s[1], &c__1);
+
+/* Copy upper triangle of A into work */
+
+ zlaset_("Full", m, n, &c_b6, &c_b6, &work[1], m);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = min(j,*m);
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = (j - 1) * *m + i__;
+ i__4 = i__ + j * a_dim1;
+ work[i__3].r = a[i__4].r, work[i__3].i = a[i__4].i;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Get machine parameters */
+
+ smlnum = dlamch_("S") / dlamch_("P");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+
+/* Scale work if max entry outside range [SMLNUM,BIGNUM] */
+
+ anrm = zlange_("M", m, n, &work[1], m, dummy);
+ iscl = 0;
+ if (anrm > 0. && anrm < smlnum) {
+
+/* Scale matrix norm up to SMLNUM */
+
+ zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &work[1], m, &info);
+ iscl = 1;
+ } else if (anrm > bignum) {
+
+/* Scale matrix norm down to BIGNUM */
+
+ zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &work[1], m, &info);
+ iscl = 1;
+ }
+
+ if (anrm != 0.) {
+
+/* Compute SVD of work */
+
+ zgebd2_(m, n, &work[1], m, &rwork[1], &rwork[mn + 1], &work[*m * *n +
+ 1], &work[*m * *n + mn + 1], &work[*m * *n + (mn << 1) + 1], &
+ info);
+ dbdsqr_("Upper", &mn, &c__0, &c__0, &c__0, &rwork[1], &rwork[mn + 1],
+ dummy, &mn, dummy, &c__1, dummy, &mn, &rwork[(mn << 1) + 1], &
+ info);
+
+ if (iscl == 1) {
+ if (anrm > bignum) {
+ dlascl_("G", &c__0, &c__0, &bignum, &anrm, &mn, &c__1, &rwork[
+ 1], &mn, &info);
+ }
+ if (anrm < smlnum) {
+ dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &mn, &c__1, &rwork[
+ 1], &mn, &info);
+ }
+ }
+
+ } else {
+
+ i__1 = mn;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ rwork[i__] = 0.;
+/* L30: */
+ }
+ }
+
+/* Compare s and singular values of work */
+
+ daxpy_(&mn, &c_b33, &s[1], &c__1, &rwork[1], &c__1);
+ ret_val = dasum_(&mn, &rwork[1], &c__1) / (dlamch_("Epsilon") *
+ (doublereal) max(*m,*n));
+ if (nrmsvl != 0.) {
+ ret_val /= nrmsvl;
+ }
+
+ return ret_val;
+
+/* End of ZQRT12 */
+
+} /* zqrt12_ */
diff --git a/TESTING/LIN/zqrt13.c b/TESTING/LIN/zqrt13.c
new file mode 100644
index 0000000..7116587
--- /dev/null
+++ b/TESTING/LIN/zqrt13.c
@@ -0,0 +1,166 @@
+/* zqrt13.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static integer c__1 = 1;
+static integer c__0 = 0;
+
+/* Subroutine */ int zqrt13_(integer *scale, integer *m, integer *n,
+ doublecomplex *a, integer *lda, doublereal *norma, integer *iseed)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2, d__3;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer j, info;
+ doublereal dummy[1];
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ doublereal bignum;
+ extern /* Subroutine */ int zlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublecomplex *,
+ integer *, integer *);
+ extern doublereal dzasum_(integer *, doublecomplex *, integer *);
+ doublereal smlnum;
+ extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *,
+ doublecomplex *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZQRT13 generates a full-rank matrix that may be scaled to have large */
+/* or small norm. */
+
+/* Arguments */
+/* ========= */
+
+/* SCALE (input) INTEGER */
+/* SCALE = 1: normally scaled matrix */
+/* SCALE = 2: matrix scaled up */
+/* SCALE = 3: matrix scaled down */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of A. */
+
+/* A (output) COMPLEX*16 array, dimension (LDA,N) */
+/* The M-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* NORMA (output) DOUBLE PRECISION */
+/* The one-norm of A. */
+
+/* ISEED (input/output) integer array, dimension (4) */
+/* Seed for random number generator */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iseed;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0) {
+ return 0;
+ }
+
+/* benign matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ zlarnv_(&c__2, &iseed[1], m, &a[j * a_dim1 + 1]);
+ if (j <= *m) {
+ i__2 = j + j * a_dim1;
+ i__3 = j + j * a_dim1;
+ d__2 = dzasum_(m, &a[j * a_dim1 + 1], &c__1);
+ i__4 = j + j * a_dim1;
+ d__3 = a[i__4].r;
+ d__1 = d_sign(&d__2, &d__3);
+ z__2.r = d__1, z__2.i = 0.;
+ z__1.r = a[i__3].r + z__2.r, z__1.i = a[i__3].i + z__2.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ }
+/* L10: */
+ }
+
+/* scaled versions */
+
+ if (*scale != 1) {
+ *norma = zlange_("Max", m, n, &a[a_offset], lda, dummy);
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ smlnum /= dlamch_("Epsilon");
+ bignum = 1. / smlnum;
+
+ if (*scale == 2) {
+
+/* matrix scaled up */
+
+ zlascl_("General", &c__0, &c__0, norma, &bignum, m, n, &a[
+ a_offset], lda, &info);
+ } else if (*scale == 3) {
+
+/* matrix scaled down */
+
+ zlascl_("General", &c__0, &c__0, norma, &smlnum, m, n, &a[
+ a_offset], lda, &info);
+ }
+ }
+
+ *norma = zlange_("One-norm", m, n, &a[a_offset], lda, dummy);
+ return 0;
+
+/* End of ZQRT13 */
+
+} /* zqrt13_ */
diff --git a/TESTING/LIN/zqrt14.c b/TESTING/LIN/zqrt14.c
new file mode 100644
index 0000000..e99f090
--- /dev/null
+++ b/TESTING/LIN/zqrt14.c
@@ -0,0 +1,270 @@
+/* zqrt14.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__10 = 10;
+static integer c__1 = 1;
+static integer c__0 = 0;
+static doublereal c_b15 = 1.;
+
+doublereal zqrt14_(char *trans, integer *m, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *x, integer *ldx,
+ doublecomplex *work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, x_dim1, x_offset, i__1, i__2, i__3;
+ doublereal ret_val, d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal err;
+ integer info;
+ doublereal anrm;
+ logical tpsd;
+ doublereal xnrm;
+ extern logical lsame_(char *, char *);
+ doublereal rwork[1];
+ extern /* Subroutine */ int zgelq2_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *), zgeqr2_(
+ integer *, integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublecomplex *,
+ integer *, integer *);
+ integer ldwork;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZQRT14 checks whether X is in the row space of A or A'. It does so */
+/* by scaling both X and A such that their norms are in the range */
+/* [sqrt(eps), 1/sqrt(eps)], then computing a QR factorization of [A,X] */
+/* (if TRANS = 'C') or an LQ factorization of [A',X]' (if TRANS = 'N'), */
+/* and returning the norm of the trailing triangle, scaled by */
+/* MAX(M,N,NRHS)*eps. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* = 'N': No transpose, check for X in the row space of A */
+/* = 'C': Conjugate transpose, check for X in row space of A'. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of X. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The M-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* If TRANS = 'N', the N-by-NRHS matrix X. */
+/* IF TRANS = 'C', the M-by-NRHS matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. */
+
+/* WORK (workspace) COMPLEX*16 array dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* length of workspace array required */
+/* If TRANS = 'N', LWORK >= (M+NRHS)*(N+2); */
+/* if TRANS = 'C', LWORK >= (N+NRHS)*(M+2). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.;
+ if (lsame_(trans, "N")) {
+ ldwork = *m + *nrhs;
+ tpsd = FALSE_;
+ if (*lwork < (*m + *nrhs) * (*n + 2)) {
+ xerbla_("ZQRT14", &c__10);
+ return ret_val;
+ } else if (*n <= 0 || *nrhs <= 0) {
+ return ret_val;
+ }
+ } else if (lsame_(trans, "C")) {
+ ldwork = *m;
+ tpsd = TRUE_;
+ if (*lwork < (*n + *nrhs) * (*m + 2)) {
+ xerbla_("ZQRT14", &c__10);
+ return ret_val;
+ } else if (*m <= 0 || *nrhs <= 0) {
+ return ret_val;
+ }
+ } else {
+ xerbla_("ZQRT14", &c__1);
+ return ret_val;
+ }
+
+/* Copy and scale A */
+
+ zlacpy_("All", m, n, &a[a_offset], lda, &work[1], &ldwork);
+ anrm = zlange_("M", m, n, &work[1], &ldwork, rwork);
+ if (anrm != 0.) {
+ zlascl_("G", &c__0, &c__0, &anrm, &c_b15, m, n, &work[1], &ldwork, &
+ info);
+ }
+
+/* Copy X or X' into the right place and scale it */
+
+ if (tpsd) {
+
+/* Copy X into columns n+1:n+nrhs of work */
+
+ zlacpy_("All", m, nrhs, &x[x_offset], ldx, &work[*n * ldwork + 1], &
+ ldwork);
+ xnrm = zlange_("M", m, nrhs, &work[*n * ldwork + 1], &ldwork, rwork);
+ if (xnrm != 0.) {
+ zlascl_("G", &c__0, &c__0, &xnrm, &c_b15, m, nrhs, &work[*n *
+ ldwork + 1], &ldwork, &info);
+ }
+ i__1 = *n + *nrhs;
+ anrm = zlange_("One-norm", m, &i__1, &work[1], &ldwork, rwork);
+
+/* Compute QR factorization of X */
+
+ i__1 = *n + *nrhs;
+/* Computing MIN */
+ i__2 = *m, i__3 = *n + *nrhs;
+ zgeqr2_(m, &i__1, &work[1], &ldwork, &work[ldwork * (*n + *nrhs) + 1],
+ &work[ldwork * (*n + *nrhs) + min(i__2, i__3)+ 1], &info);
+
+/* Compute largest entry in upper triangle of */
+/* work(n+1:m,n+1:n+nrhs) */
+
+ err = 0.;
+ i__1 = *n + *nrhs;
+ for (j = *n + 1; j <= i__1; ++j) {
+ i__2 = min(*m,j);
+ for (i__ = *n + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = err, d__2 = z_abs(&work[i__ + (j - 1) * *m]);
+ err = max(d__1,d__2);
+/* L10: */
+ }
+/* L20: */
+ }
+
+ } else {
+
+/* Copy X' into rows m+1:m+nrhs of work */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *nrhs;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = *m + j + (i__ - 1) * ldwork;
+ d_cnjg(&z__1, &x[i__ + j * x_dim1]);
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+
+ xnrm = zlange_("M", nrhs, n, &work[*m + 1], &ldwork, rwork)
+ ;
+ if (xnrm != 0.) {
+ zlascl_("G", &c__0, &c__0, &xnrm, &c_b15, nrhs, n, &work[*m + 1],
+ &ldwork, &info);
+ }
+
+/* Compute LQ factorization of work */
+
+ zgelq2_(&ldwork, n, &work[1], &ldwork, &work[ldwork * *n + 1], &work[
+ ldwork * (*n + 1) + 1], &info);
+
+/* Compute largest entry in lower triangle in */
+/* work(m+1:m+nrhs,m+1:n) */
+
+ err = 0.;
+ i__1 = *n;
+ for (j = *m + 1; j <= i__1; ++j) {
+ i__2 = ldwork;
+ for (i__ = j; i__ <= i__2; ++i__) {
+/* Computing MAX */
+ d__1 = err, d__2 = z_abs(&work[i__ + (j - 1) * ldwork]);
+ err = max(d__1,d__2);
+/* L50: */
+ }
+/* L60: */
+ }
+
+ }
+
+/* Computing MAX */
+ i__1 = max(*m,*n);
+ ret_val = err / ((doublereal) max(i__1,*nrhs) * dlamch_("Epsilon"));
+
+ return ret_val;
+
+/* End of ZQRT14 */
+
+} /* zqrt14_ */
diff --git a/TESTING/LIN/zqrt15.c b/TESTING/LIN/zqrt15.c
new file mode 100644
index 0000000..b7f0821
--- /dev/null
+++ b/TESTING/LIN/zqrt15.c
@@ -0,0 +1,310 @@
+/* zqrt15.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__16 = 16;
+static integer c__2 = 2;
+static integer c__1 = 1;
+static doublecomplex c_b22 = {2.,0.};
+static integer c__0 = 0;
+
+/* Subroutine */ int zqrt15_(integer *scale, integer *rksel, integer *m,
+ integer *n, integer *nrhs, doublecomplex *a, integer *lda,
+ doublecomplex *b, integer *ldb, doublereal *s, integer *rank,
+ doublereal *norma, doublereal *normb, integer *iseed, doublecomplex *
+ work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Local variables */
+ integer j, mn;
+ doublereal eps;
+ integer info;
+ doublereal temp;
+ extern doublereal dasum_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int zlarf_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *), zgemm_(char *, char *,
+ integer *, integer *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ doublereal dummy[1];
+ extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+ extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
+ char *);
+ extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *, integer *);
+ extern doublereal dlarnd_(integer *, integer *);
+ extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *,
+ integer *), xerbla_(char *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ doublereal bignum;
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *), zlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublecomplex *
+, integer *, integer *), zlaset_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *), zlaror_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *);
+ doublereal smlnum;
+ extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *,
+ doublecomplex *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZQRT15 generates a matrix with full or deficient rank and of various */
+/* norms. */
+
+/* Arguments */
+/* ========= */
+
+/* SCALE (input) INTEGER */
+/* SCALE = 1: normally scaled matrix */
+/* SCALE = 2: matrix scaled up */
+/* SCALE = 3: matrix scaled down */
+
+/* RKSEL (input) INTEGER */
+/* RKSEL = 1: full rank matrix */
+/* RKSEL = 2: rank-deficient matrix */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+
+/* N (input) INTEGER */
+/* The number of columns of A. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B. */
+
+/* A (output) COMPLEX*16 array, dimension (LDA,N) */
+/* The M-by-N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. */
+
+/* B (output) COMPLEX*16 array, dimension (LDB, NRHS) */
+/* A matrix that is in the range space of matrix A. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. */
+
+/* S (output) DOUBLE PRECISION array, dimension MIN(M,N) */
+/* Singular values of A. */
+
+/* RANK (output) INTEGER */
+/* number of nonzero singular values of A. */
+
+/* NORMA (output) DOUBLE PRECISION */
+/* one-norm norm of A. */
+
+/* NORMB (output) DOUBLE PRECISION */
+/* one-norm norm of B. */
+
+/* ISEED (input/output) integer array, dimension (4) */
+/* seed for random number generator. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* length of work space required. */
+/* LWORK >= MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --s;
+ --iseed;
+ --work;
+
+ /* Function Body */
+ mn = min(*m,*n);
+/* Computing MAX */
+ i__1 = *m + mn, i__2 = mn * *nrhs, i__1 = max(i__1,i__2), i__2 = (*n << 1)
+ + *m;
+ if (*lwork < max(i__1,i__2)) {
+ xerbla_("ZQRT15", &c__16);
+ return 0;
+ }
+
+ smlnum = dlamch_("Safe minimum");
+ bignum = 1. / smlnum;
+ dlabad_(&smlnum, &bignum);
+ eps = dlamch_("Epsilon");
+ smlnum = smlnum / eps / eps;
+ bignum = 1. / smlnum;
+
+/* Determine rank and (unscaled) singular values */
+
+ if (*rksel == 1) {
+ *rank = mn;
+ } else if (*rksel == 2) {
+ *rank = mn * 3 / 4;
+ i__1 = mn;
+ for (j = *rank + 1; j <= i__1; ++j) {
+ s[j] = 0.;
+/* L10: */
+ }
+ } else {
+ xerbla_("ZQRT15", &c__2);
+ }
+
+ if (*rank > 0) {
+
+/* Nontrivial case */
+
+ s[1] = 1.;
+ i__1 = *rank;
+ for (j = 2; j <= i__1; ++j) {
+L20:
+ temp = dlarnd_(&c__1, &iseed[1]);
+ if (temp > .1) {
+ s[j] = abs(temp);
+ } else {
+ goto L20;
+ }
+/* L30: */
+ }
+ dlaord_("Decreasing", rank, &s[1], &c__1);
+
+/* Generate 'rank' columns of a random orthogonal matrix in A */
+
+ zlarnv_(&c__2, &iseed[1], m, &work[1]);
+ d__1 = 1. / dznrm2_(m, &work[1], &c__1);
+ zdscal_(m, &d__1, &work[1], &c__1);
+ zlaset_("Full", m, rank, &c_b1, &c_b2, &a[a_offset], lda);
+ zlarf_("Left", m, rank, &work[1], &c__1, &c_b22, &a[a_offset], lda, &
+ work[*m + 1]);
+
+/* workspace used: m+mn */
+
+/* Generate consistent rhs in the range space of A */
+
+ i__1 = *rank * *nrhs;
+ zlarnv_(&c__2, &iseed[1], &i__1, &work[1]);
+ zgemm_("No transpose", "No transpose", m, nrhs, rank, &c_b2, &a[
+ a_offset], lda, &work[1], rank, &c_b1, &b[b_offset], ldb);
+
+/* work space used: <= mn *nrhs */
+
+/* generate (unscaled) matrix A */
+
+ i__1 = *rank;
+ for (j = 1; j <= i__1; ++j) {
+ zdscal_(m, &s[j], &a[j * a_dim1 + 1], &c__1);
+/* L40: */
+ }
+ if (*rank < *n) {
+ i__1 = *n - *rank;
+ zlaset_("Full", m, &i__1, &c_b1, &c_b1, &a[(*rank + 1) * a_dim1 +
+ 1], lda);
+ }
+ zlaror_("Right", "No initialization", m, n, &a[a_offset], lda, &iseed[
+ 1], &work[1], &info);
+
+ } else {
+
+/* work space used 2*n+m */
+
+/* Generate null matrix and rhs */
+
+ i__1 = mn;
+ for (j = 1; j <= i__1; ++j) {
+ s[j] = 0.;
+/* L50: */
+ }
+ zlaset_("Full", m, n, &c_b1, &c_b1, &a[a_offset], lda);
+ zlaset_("Full", m, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
+
+ }
+
+/* Scale the matrix */
+
+ if (*scale != 1) {
+ *norma = zlange_("Max", m, n, &a[a_offset], lda, dummy);
+ if (*norma != 0.) {
+ if (*scale == 2) {
+
+/* matrix scaled up */
+
+ zlascl_("General", &c__0, &c__0, norma, &bignum, m, n, &a[
+ a_offset], lda, &info);
+ dlascl_("General", &c__0, &c__0, norma, &bignum, &mn, &c__1, &
+ s[1], &mn, &info);
+ zlascl_("General", &c__0, &c__0, norma, &bignum, m, nrhs, &b[
+ b_offset], ldb, &info);
+ } else if (*scale == 3) {
+
+/* matrix scaled down */
+
+ zlascl_("General", &c__0, &c__0, norma, &smlnum, m, n, &a[
+ a_offset], lda, &info);
+ dlascl_("General", &c__0, &c__0, norma, &smlnum, &mn, &c__1, &
+ s[1], &mn, &info);
+ zlascl_("General", &c__0, &c__0, norma, &smlnum, m, nrhs, &b[
+ b_offset], ldb, &info);
+ } else {
+ xerbla_("ZQRT15", &c__1);
+ return 0;
+ }
+ }
+ }
+
+ *norma = dasum_(&mn, &s[1], &c__1);
+ *normb = zlange_("One-norm", m, nrhs, &b[b_offset], ldb, dummy)
+ ;
+
+ return 0;
+
+/* End of ZQRT15 */
+
+} /* zqrt15_ */
diff --git a/TESTING/LIN/zqrt16.c b/TESTING/LIN/zqrt16.c
new file mode 100644
index 0000000..0bafebf
--- /dev/null
+++ b/TESTING/LIN/zqrt16.c
@@ -0,0 +1,187 @@
+/* zqrt16.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zqrt16_(char *trans, integer *m, integer *n, integer *
+ nrhs, doublecomplex *a, integer *lda, doublecomplex *x, integer *ldx,
+ doublecomplex *b, integer *ldb, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer j, n1, n2;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ doublereal anorm, bnorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ doublereal xnorm;
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *),
+ dzasum_(integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZQRT16 computes the residual for a solution of a system of linear */
+/* equations A*x = b or A'*x = b: */
+/* RESID = norm(B - A*X) / ( max(m,n) * norm(A) * norm(X) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations: */
+/* = 'N': A *x = b */
+/* = 'T': A^T*x = b, where A^T is the transpose of A */
+/* = 'C': A^H*x = b, where A^H is the conjugate transpose of A */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original M x N matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. If TRANS = 'N', */
+/* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. IF TRANS = 'N', */
+/* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( max(m,n) * norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if M = 0 or N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*m <= 0 || *n <= 0 || *nrhs == 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+ if (lsame_(trans, "T") || lsame_(trans, "C")) {
+ anorm = zlange_("I", m, n, &a[a_offset], lda, &rwork[1]);
+ n1 = *n;
+ n2 = *m;
+ } else {
+ anorm = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ n1 = *m;
+ n2 = *n;
+ }
+
+ eps = dlamch_("Epsilon");
+
+/* Compute B - A*X (or B - A'*X ) and store in B. */
+
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_(trans, "No transpose", &n1, nrhs, &n2, &z__1, &a[a_offset], lda, &
+ x[x_offset], ldx, &c_b1, &b[b_offset], ldb)
+ ;
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( max(m,n) * norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = dzasum_(&n1, &b[j * b_dim1 + 1], &c__1);
+ xnorm = dzasum_(&n2, &x[j * x_dim1 + 1], &c__1);
+ if (anorm == 0. && bnorm == 0.) {
+ *resid = 0.;
+ } else if (anorm <= 0. || xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / (max(*m,*n) * eps);
+ *resid = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of ZQRT16 */
+
+} /* zqrt16_ */
diff --git a/TESTING/LIN/zqrt17.c b/TESTING/LIN/zqrt17.c
new file mode 100644
index 0000000..ba0a526
--- /dev/null
+++ b/TESTING/LIN/zqrt17.c
@@ -0,0 +1,244 @@
+/* zqrt17.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__13 = 13;
+static doublecomplex c_b13 = {-1.,0.};
+static doublecomplex c_b14 = {1.,0.};
+static integer c__0 = 0;
+static doublereal c_b19 = 1.;
+static doublecomplex c_b22 = {0.,0.};
+
+doublereal zqrt17_(char *trans, integer *iresid, integer *m, integer *n,
+ integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *x,
+ integer *ldx, doublecomplex *b, integer *ldb, doublecomplex *c__,
+ doublecomplex *work, integer *lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, x_dim1,
+ x_offset, i__1;
+ doublereal ret_val;
+
+ /* Local variables */
+ doublereal err;
+ integer iscl, info;
+ extern logical lsame_(char *, char *);
+ doublereal norma, normb;
+ integer ncols;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ doublereal normx, rwork[1];
+ integer nrows;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ doublereal bignum;
+ extern /* Subroutine */ int zlascl_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublecomplex *,
+ integer *, integer *), zlacpy_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal smlnum, normrs;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZQRT17 computes the ratio */
+
+/* || R'*op(A) ||/(||A||*alpha*max(M,N,NRHS)*eps) */
+
+/* where R = op(A)*X - B, op(A) is A or A', and */
+
+/* alpha = ||B|| if IRESID = 1 (zero-residual problem) */
+/* alpha = ||R|| if IRESID = 2 (otherwise). */
+
+/* Arguments */
+/* ========= */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies whether or not the transpose of A is used. */
+/* = 'N': No transpose, op(A) = A. */
+/* = 'C': Conjugate transpose, op(A) = A'. */
+
+/* IRESID (input) INTEGER */
+/* IRESID = 1 indicates zero-residual problem. */
+/* IRESID = 2 indicates non-zero residual. */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. */
+/* If TRANS = 'N', the number of rows of the matrix B. */
+/* If TRANS = 'C', the number of rows of the matrix X. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. */
+/* If TRANS = 'N', the number of rows of the matrix X. */
+/* If TRANS = 'C', the number of rows of the matrix B. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X and B. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The m-by-n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* If TRANS = 'N', the n-by-nrhs matrix X. */
+/* If TRANS = 'C', the m-by-nrhs matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. */
+/* If TRANS = 'N', LDX >= N. */
+/* If TRANS = 'C', LDX >= M. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* If TRANS = 'N', the m-by-nrhs matrix B. */
+/* If TRANS = 'C', the n-by-nrhs matrix B. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. */
+/* If TRANS = 'N', LDB >= M. */
+/* If TRANS = 'C', LDB >= N. */
+
+/* C (workspace) COMPLEX*16 array, dimension (LDB,NRHS) */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= NRHS*(M+N). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ c_dim1 = *ldb;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ if (lsame_(trans, "N")) {
+ nrows = *m;
+ ncols = *n;
+ } else if (lsame_(trans, "C")) {
+ nrows = *n;
+ ncols = *m;
+ } else {
+ xerbla_("ZQRT17", &c__1);
+ return ret_val;
+ }
+
+ if (*lwork < ncols * *nrhs) {
+ xerbla_("ZQRT17", &c__13);
+ return ret_val;
+ }
+
+ if (*m <= 0 || *n <= 0 || *nrhs <= 0) {
+ return ret_val;
+ }
+
+ norma = zlange_("One-norm", m, n, &a[a_offset], lda, rwork);
+ smlnum = dlamch_("Safe minimum") / dlamch_("Precision");
+ bignum = 1. / smlnum;
+ iscl = 0;
+
+/* compute residual and scale it */
+
+ zlacpy_("All", &nrows, nrhs, &b[b_offset], ldb, &c__[c_offset], ldb);
+ zgemm_(trans, "No transpose", &nrows, nrhs, &ncols, &c_b13, &a[a_offset],
+ lda, &x[x_offset], ldx, &c_b14, &c__[c_offset], ldb);
+ normrs = zlange_("Max", &nrows, nrhs, &c__[c_offset], ldb, rwork);
+ if (normrs > smlnum) {
+ iscl = 1;
+ zlascl_("General", &c__0, &c__0, &normrs, &c_b19, &nrows, nrhs, &c__[
+ c_offset], ldb, &info);
+ }
+
+/* compute R'*A */
+
+ zgemm_("Conjugate transpose", trans, nrhs, &ncols, &nrows, &c_b14, &c__[
+ c_offset], ldb, &a[a_offset], lda, &c_b22, &work[1], nrhs);
+
+/* compute and properly scale error */
+
+ err = zlange_("One-norm", nrhs, &ncols, &work[1], nrhs, rwork);
+ if (norma != 0.) {
+ err /= norma;
+ }
+
+ if (iscl == 1) {
+ err *= normrs;
+ }
+
+ if (*iresid == 1) {
+ normb = zlange_("One-norm", &nrows, nrhs, &b[b_offset], ldb, rwork);
+ if (normb != 0.) {
+ err /= normb;
+ }
+ } else {
+ normx = zlange_("One-norm", &ncols, nrhs, &x[x_offset], ldx, rwork);
+ if (normx != 0.) {
+ err /= normx;
+ }
+ }
+
+/* Computing MAX */
+ i__1 = max(*m,*n);
+ ret_val = err / (dlamch_("Epsilon") * (doublereal) max(i__1,*
+ nrhs));
+ return ret_val;
+
+/* End of ZQRT17 */
+
+} /* zqrt17_ */
diff --git a/TESTING/LIN/zrqt01.c b/TESTING/LIN/zrqt01.c
new file mode 100644
index 0000000..0489e37
--- /dev/null
+++ b/TESTING/LIN/zrqt01.c
@@ -0,0 +1,259 @@
+/* zrqt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {-1e10,-1e10};
+static doublecomplex c_b12 = {0.,0.};
+static doublecomplex c_b19 = {-1.,0.};
+static doublecomplex c_b20 = {1.,0.};
+static doublereal c_b28 = -1.;
+static doublereal c_b29 = 1.;
+
+/* Subroutine */ int zrqt01_(integer *m, integer *n, doublecomplex *a,
+ doublecomplex *af, doublecomplex *q, doublecomplex *r__, integer *lda,
+ doublecomplex *tau, doublecomplex *work, integer *lwork, doublereal *
+ rwork, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
+ r_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal eps;
+ integer info;
+ doublereal resid, anorm;
+ integer minmn;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zherk_(char *, char *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int zgerqf_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *, integer *
+), zlacpy_(char *, integer *, integer *, doublecomplex *, integer
+ *, doublecomplex *, integer *), zlaset_(char *, integer *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *);
+ extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zungrq_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZRQT01 tests ZGERQF, which computes the RQ factorization of an m-by-n */
+/* matrix A, and partially tests ZUNGRQ which forms the n-by-n */
+/* orthogonal matrix Q. */
+
+/* ZRQT01 compares R with A*Q', and checks that Q is orthogonal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The m-by-n matrix A. */
+
+/* AF (output) COMPLEX*16 array, dimension (LDA,N) */
+/* Details of the RQ factorization of A, as returned by ZGERQF. */
+/* See ZGERQF for further details. */
+
+/* Q (output) COMPLEX*16 array, dimension (LDA,N) */
+/* The n-by-n orthogonal matrix Q. */
+
+/* R (workspace) COMPLEX*16 array, dimension (LDA,max(M,N)) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and L. */
+/* LDA >= max(M,N). */
+
+/* TAU (output) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors, as returned */
+/* by ZGERQF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(M,N)) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ minmn = min(*m,*n);
+ eps = dlamch_("Epsilon");
+
+/* Copy the matrix A to the array AF. */
+
+ zlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
+
+/* Factorize the matrix A in the array AF. */
+
+ s_copy(srnamc_1.srnamt, "ZGERQF", (ftnlen)32, (ftnlen)6);
+ zgerqf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy details of Q */
+
+ zlaset_("Full", n, n, &c_b1, &c_b1, &q[q_offset], lda);
+ if (*m <= *n) {
+ if (*m > 0 && *m < *n) {
+ i__1 = *n - *m;
+ zlacpy_("Full", m, &i__1, &af[af_offset], lda, &q[*n - *m + 1 +
+ q_dim1], lda);
+ }
+ if (*m > 1) {
+ i__1 = *m - 1;
+ i__2 = *m - 1;
+ zlacpy_("Lower", &i__1, &i__2, &af[(*n - *m + 1) * af_dim1 + 2],
+ lda, &q[*n - *m + 2 + (*n - *m + 1) * q_dim1], lda);
+ }
+ } else {
+ if (*n > 1) {
+ i__1 = *n - 1;
+ i__2 = *n - 1;
+ zlacpy_("Lower", &i__1, &i__2, &af[*m - *n + 2 + af_dim1], lda, &
+ q[q_dim1 + 2], lda);
+ }
+ }
+
+/* Generate the n-by-n matrix Q */
+
+ s_copy(srnamc_1.srnamt, "ZUNGRQ", (ftnlen)32, (ftnlen)6);
+ zungrq_(n, n, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
+
+/* Copy R */
+
+ zlaset_("Full", m, n, &c_b12, &c_b12, &r__[r_offset], lda);
+ if (*m <= *n) {
+ if (*m > 0) {
+ zlacpy_("Upper", m, m, &af[(*n - *m + 1) * af_dim1 + 1], lda, &
+ r__[(*n - *m + 1) * r_dim1 + 1], lda);
+ }
+ } else {
+ if (*m > *n && *n > 0) {
+ i__1 = *m - *n;
+ zlacpy_("Full", &i__1, n, &af[af_offset], lda, &r__[r_offset],
+ lda);
+ }
+ if (*n > 0) {
+ zlacpy_("Upper", n, n, &af[*m - *n + 1 + af_dim1], lda, &r__[*m -
+ *n + 1 + r_dim1], lda);
+ }
+ }
+
+/* Compute R - A*Q' */
+
+ zgemm_("No transpose", "Conjugate transpose", m, n, n, &c_b19, &a[
+ a_offset], lda, &q[q_offset], lda, &c_b20, &r__[r_offset], lda);
+
+/* Compute norm( R - Q'*A ) / ( N * norm(A) * EPS ) . */
+
+ anorm = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
+ resid = zlange_("1", m, n, &r__[r_offset], lda, &rwork[1]);
+ if (anorm > 0.) {
+ result[1] = resid / (doublereal) max(1,*n) / anorm / eps;
+ } else {
+ result[1] = 0.;
+ }
+
+/* Compute I - Q*Q' */
+
+ zlaset_("Full", n, n, &c_b12, &c_b20, &r__[r_offset], lda);
+ zherk_("Upper", "No transpose", n, n, &c_b28, &q[q_offset], lda, &c_b29, &
+ r__[r_offset], lda);
+
+/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
+
+ resid = zlansy_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
+
+ result[2] = resid / (doublereal) max(1,*n) / eps;
+
+ return 0;
+
+/* End of ZRQT01 */
+
+} /* zrqt01_ */
diff --git a/TESTING/LIN/zrqt02.c b/TESTING/LIN/zrqt02.c
new file mode 100644
index 0000000..7c94b2d
--- /dev/null
+++ b/TESTING/LIN/zrqt02.c
@@ -0,0 +1,242 @@
+/* zrqt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {-1e10,-1e10};
+static doublecomplex c_b9 = {0.,0.};
+static doublecomplex c_b14 = {-1.,0.};
+static doublecomplex c_b15 = {1.,0.};
+static doublereal c_b23 = -1.;
+static doublereal c_b24 = 1.;
+
+/* Subroutine */ int zrqt02_(integer *m, integer *n, integer *k,
+ doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex *
+ r__, integer *lda, doublecomplex *tau, doublecomplex *work, integer *
+ lwork, doublereal *rwork, doublereal *result)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
+ r_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ doublereal eps;
+ integer info;
+ doublereal resid, anorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *), zherk_(char *, char *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *);
+ extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zungrq_(integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZRQT02 tests ZUNGRQ, which generates an m-by-n matrix Q with */
+/* orthonornmal rows that is defined as the product of k elementary */
+/* reflectors. */
+
+/* Given the RQ factorization of an m-by-n matrix A, ZRQT02 generates */
+/* the orthogonal matrix Q defined by the factorization of the last k */
+/* rows of A; it compares R(m-k+1:m,n-m+1:n) with */
+/* A(m-k+1:m,1:n)*Q(n-m+1:n,1:n)', and checks that the rows of Q are */
+/* orthonormal. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix Q to be generated. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix Q to be generated. */
+/* N >= M >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* matrix Q. M >= K >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The m-by-n matrix A which was factorized by ZRQT01. */
+
+/* AF (input) COMPLEX*16 array, dimension (LDA,N) */
+/* Details of the RQ factorization of A, as returned by ZGERQF. */
+/* See ZGERQF for further details. */
+
+/* Q (workspace) COMPLEX*16 array, dimension (LDA,N) */
+
+/* R (workspace) COMPLEX*16 array, dimension (LDA,M) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A, AF, Q and L. LDA >= N. */
+
+/* TAU (input) COMPLEX*16 array, dimension (M) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the RQ factorization in AF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The dimension of the array WORK. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
+/* The test ratios: */
+/* RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS ) */
+/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick return if possible */
+
+ /* Parameter adjustments */
+ r_dim1 = *lda;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+ if (*m == 0 || *n == 0 || *k == 0) {
+ result[1] = 0.;
+ result[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+
+/* Copy the last k rows of the factorization to the array Q */
+
+ zlaset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
+ if (*k < *n) {
+ i__1 = *n - *k;
+ zlacpy_("Full", k, &i__1, &af[*m - *k + 1 + af_dim1], lda, &q[*m - *k
+ + 1 + q_dim1], lda);
+ }
+ if (*k > 1) {
+ i__1 = *k - 1;
+ i__2 = *k - 1;
+ zlacpy_("Lower", &i__1, &i__2, &af[*m - *k + 2 + (*n - *k + 1) *
+ af_dim1], lda, &q[*m - *k + 2 + (*n - *k + 1) * q_dim1], lda);
+ }
+
+/* Generate the last n rows of the matrix Q */
+
+ s_copy(srnamc_1.srnamt, "ZUNGRQ", (ftnlen)32, (ftnlen)6);
+ zungrq_(m, n, k, &q[q_offset], lda, &tau[*m - *k + 1], &work[1], lwork, &
+ info);
+
+/* Copy R(m-k+1:m,n-m+1:n) */
+
+ zlaset_("Full", k, m, &c_b9, &c_b9, &r__[*m - *k + 1 + (*n - *m + 1) *
+ r_dim1], lda);
+ zlacpy_("Upper", k, k, &af[*m - *k + 1 + (*n - *k + 1) * af_dim1], lda, &
+ r__[*m - *k + 1 + (*n - *k + 1) * r_dim1], lda);
+
+/* Compute R(m-k+1:m,n-m+1:n) - A(m-k+1:m,1:n) * Q(n-m+1:n,1:n)' */
+
+ zgemm_("No transpose", "Conjugate transpose", k, m, n, &c_b14, &a[*m - *k
+ + 1 + a_dim1], lda, &q[q_offset], lda, &c_b15, &r__[*m - *k + 1 +
+ (*n - *m + 1) * r_dim1], lda);
+
+/* Compute norm( R - A*Q' ) / ( N * norm(A) * EPS ) . */
+
+ anorm = zlange_("1", k, n, &a[*m - *k + 1 + a_dim1], lda, &rwork[1]);
+ resid = zlange_("1", k, m, &r__[*m - *k + 1 + (*n - *m + 1) * r_dim1],
+ lda, &rwork[1]);
+ if (anorm > 0.) {
+ result[1] = resid / (doublereal) max(1,*n) / anorm / eps;
+ } else {
+ result[1] = 0.;
+ }
+
+/* Compute I - Q*Q' */
+
+ zlaset_("Full", m, m, &c_b9, &c_b15, &r__[r_offset], lda);
+ zherk_("Upper", "No transpose", m, n, &c_b23, &q[q_offset], lda, &c_b24, &
+ r__[r_offset], lda);
+
+/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
+
+ resid = zlansy_("1", "Upper", m, &r__[r_offset], lda, &rwork[1]);
+
+ result[2] = resid / (doublereal) max(1,*n) / eps;
+
+ return 0;
+
+/* End of ZRQT02 */
+
+} /* zrqt02_ */
diff --git a/TESTING/LIN/zrqt03.c b/TESTING/LIN/zrqt03.c
new file mode 100644
index 0000000..f54356c
--- /dev/null
+++ b/TESTING/LIN/zrqt03.c
@@ -0,0 +1,288 @@
+/* zrqt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Common Block Declarations */
+
+struct {
+ char srnamt[32];
+} srnamc_;
+
+#define srnamc_1 srnamc_
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {-1e10,-1e10};
+static integer c__2 = 2;
+static doublecomplex c_b21 = {-1.,0.};
+static doublecomplex c_b22 = {1.,0.};
+
+/* Subroutine */ int zrqt03_(integer *m, integer *n, integer *k,
+ doublecomplex *af, doublecomplex *c__, doublecomplex *cc,
+ doublecomplex *q, integer *lda, doublecomplex *tau, doublecomplex *
+ work, integer *lwork, doublereal *rwork, doublereal *result)
+{
+ /* Initialized data */
+
+ static integer iseed[4] = { 1988,1989,1990,1991 };
+
+ /* System generated locals */
+ integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1,
+ q_offset, i__1, i__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer j, mc, nc;
+ doublereal eps;
+ char side[1];
+ integer info, iside;
+ extern logical lsame_(char *, char *);
+ doublereal resid;
+ integer minmn;
+ doublereal cnorm;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+ char trans[1];
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ integer itrans;
+ extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *),
+ zlaset_(char *, integer *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *), zlarnv_(
+ integer *, integer *, integer *, doublecomplex *), zungrq_(
+ integer *, integer *, integer *, doublecomplex *, integer *,
+ doublecomplex *, doublecomplex *, integer *, integer *), zunmrq_(
+ char *, char *, integer *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZRQT03 tests ZUNMRQ, which computes Q*C, Q'*C, C*Q or C*Q'. */
+
+/* ZRQT03 compares the results of a call to ZUNMRQ with the results of */
+/* forming Q explicitly by a call to ZUNGRQ and then performing matrix */
+/* multiplication by a call to ZGEMM. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows or columns of the matrix C; C is n-by-m if */
+/* Q is applied from the left, or m-by-n if Q is applied from */
+/* the right. M >= 0. */
+
+/* N (input) INTEGER */
+/* The order of the orthogonal matrix Q. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of elementary reflectors whose product defines the */
+/* orthogonal matrix Q. N >= K >= 0. */
+
+/* AF (input) COMPLEX*16 array, dimension (LDA,N) */
+/* Details of the RQ factorization of an m-by-n matrix, as */
+/* returned by ZGERQF. See CGERQF for further details. */
+
+/* C (workspace) COMPLEX*16 array, dimension (LDA,N) */
+
+/* CC (workspace) COMPLEX*16 array, dimension (LDA,N) */
+
+/* Q (workspace) COMPLEX*16 array, dimension (LDA,N) */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays AF, C, CC, and Q. */
+
+/* TAU (input) COMPLEX*16 array, dimension (min(M,N)) */
+/* The scalar factors of the elementary reflectors corresponding */
+/* to the RQ factorization in AF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of WORK. LWORK must be at least M, and should be */
+/* M*NB, where NB is the blocksize for this environment. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
+/* The test ratios compare two techniques for multiplying a */
+/* random matrix C by an n-by-n orthogonal matrix Q. */
+/* RESULT(1) = norm( Q*C - Q*C ) / ( N * norm(C) * EPS ) */
+/* RESULT(2) = norm( C*Q - C*Q ) / ( N * norm(C) * EPS ) */
+/* RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS ) */
+/* RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Scalars in Common .. */
+/* .. */
+/* .. Common blocks .. */
+/* .. */
+/* .. Data statements .. */
+ /* Parameter adjustments */
+ q_dim1 = *lda;
+ q_offset = 1 + q_dim1;
+ q -= q_offset;
+ cc_dim1 = *lda;
+ cc_offset = 1 + cc_dim1;
+ cc -= cc_offset;
+ c_dim1 = *lda;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+ --rwork;
+ --result;
+
+ /* Function Body */
+/* .. */
+/* .. Executable Statements .. */
+
+ eps = dlamch_("Epsilon");
+ minmn = min(*m,*n);
+
+/* Quick return if possible */
+
+ if (minmn == 0) {
+ result[1] = 0.;
+ result[2] = 0.;
+ result[3] = 0.;
+ result[4] = 0.;
+ return 0;
+ }
+
+/* Copy the last k rows of the factorization to the array Q */
+
+ zlaset_("Full", n, n, &c_b1, &c_b1, &q[q_offset], lda);
+ if (*k > 0 && *n > *k) {
+ i__1 = *n - *k;
+ zlacpy_("Full", k, &i__1, &af[*m - *k + 1 + af_dim1], lda, &q[*n - *k
+ + 1 + q_dim1], lda);
+ }
+ if (*k > 1) {
+ i__1 = *k - 1;
+ i__2 = *k - 1;
+ zlacpy_("Lower", &i__1, &i__2, &af[*m - *k + 2 + (*n - *k + 1) *
+ af_dim1], lda, &q[*n - *k + 2 + (*n - *k + 1) * q_dim1], lda);
+ }
+
+/* Generate the n-by-n matrix Q */
+
+ s_copy(srnamc_1.srnamt, "ZUNGRQ", (ftnlen)32, (ftnlen)6);
+ zungrq_(n, n, k, &q[q_offset], lda, &tau[minmn - *k + 1], &work[1], lwork,
+ &info);
+
+ for (iside = 1; iside <= 2; ++iside) {
+ if (iside == 1) {
+ *(unsigned char *)side = 'L';
+ mc = *n;
+ nc = *m;
+ } else {
+ *(unsigned char *)side = 'R';
+ mc = *m;
+ nc = *n;
+ }
+
+/* Generate MC by NC matrix C */
+
+ i__1 = nc;
+ for (j = 1; j <= i__1; ++j) {
+ zlarnv_(&c__2, iseed, &mc, &c__[j * c_dim1 + 1]);
+/* L10: */
+ }
+ cnorm = zlange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]);
+ if (cnorm == 0.) {
+ cnorm = 1.;
+ }
+
+ for (itrans = 1; itrans <= 2; ++itrans) {
+ if (itrans == 1) {
+ *(unsigned char *)trans = 'N';
+ } else {
+ *(unsigned char *)trans = 'C';
+ }
+
+/* Copy C */
+
+ zlacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
+ lda);
+
+/* Apply Q or Q' to C */
+
+ s_copy(srnamc_1.srnamt, "ZUNMRQ", (ftnlen)32, (ftnlen)6);
+ if (*k > 0) {
+ zunmrq_(side, trans, &mc, &nc, k, &af[*m - *k + 1 + af_dim1],
+ lda, &tau[minmn - *k + 1], &cc[cc_offset], lda, &work[
+ 1], lwork, &info);
+ }
+
+/* Form explicit product and subtract */
+
+ if (lsame_(side, "L")) {
+ zgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b21, &q[
+ q_offset], lda, &c__[c_offset], lda, &c_b22, &cc[
+ cc_offset], lda);
+ } else {
+ zgemm_("No transpose", trans, &mc, &nc, &nc, &c_b21, &c__[
+ c_offset], lda, &q[q_offset], lda, &c_b22, &cc[
+ cc_offset], lda);
+ }
+
+/* Compute error in the difference */
+
+ resid = zlange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
+ result[(iside - 1 << 1) + itrans] = resid / ((doublereal) max(1,*
+ n) * cnorm * eps);
+
+/* L20: */
+ }
+/* L30: */
+ }
+
+ return 0;
+
+/* End of ZRQT03 */
+
+} /* zrqt03_ */
diff --git a/TESTING/LIN/zrzt01.c b/TESTING/LIN/zrzt01.c
new file mode 100644
index 0000000..a4dca5e
--- /dev/null
+++ b/TESTING/LIN/zrzt01.c
@@ -0,0 +1,174 @@
+/* zrzt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static doublecomplex c_b6 = {0.,0.};
+static integer c__1 = 1;
+static doublecomplex c_b15 = {-1.,0.};
+
+doublereal zrzt01_(integer *m, integer *n, doublecomplex *a, doublecomplex *
+ af, integer *lda, doublecomplex *tau, doublecomplex *work, integer *
+ lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val;
+
+ /* Local variables */
+ integer i__, j, info;
+ doublereal norma, rwork[1];
+ extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zunmrz_(char *, char *, integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZRZT01 returns */
+/* || A - R*Q || / ( M * eps * ||A|| ) */
+/* for an upper trapezoidal A that was factored with ZTZRZF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices A and AF. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and AF. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original upper trapezoidal M by N matrix A. */
+
+/* AF (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The output of ZTZRZF for input matrix A. */
+/* The lower triangle is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A and AF. */
+
+/* TAU (input) COMPLEX*16 array, dimension (M) */
+/* Details of the Householder transformations as returned by */
+/* ZTZRZF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= m*n + m. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ if (*lwork < *m * *n + *m) {
+ xerbla_("ZRZT01", &c__8);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return ret_val;
+ }
+
+ norma = zlange_("One-norm", m, n, &a[a_offset], lda, rwork);
+
+/* Copy upper triangle R */
+
+ zlaset_("Full", m, n, &c_b6, &c_b6, &work[1], m);
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = (j - 1) * *m + i__;
+ i__4 = i__ + j * af_dim1;
+ work[i__3].r = af[i__4].r, work[i__3].i = af[i__4].i;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* R = R * P(1) * ... *P(m) */
+
+ i__1 = *n - *m;
+ i__2 = *lwork - *m * *n;
+ zunmrz_("Right", "No tranpose", m, n, m, &i__1, &af[af_offset], lda, &tau[
+ 1], &work[1], m, &work[*m * *n + 1], &i__2, &info);
+
+/* R = R - A */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ zaxpy_(m, &c_b15, &a[i__ * a_dim1 + 1], &c__1, &work[(i__ - 1) * *m +
+ 1], &c__1);
+/* L30: */
+ }
+
+ ret_val = zlange_("One-norm", m, n, &work[1], m, rwork);
+
+ ret_val /= dlamch_("Epsilon") * (doublereal) max(*m,*n);
+ if (norma != 0.) {
+ ret_val /= norma;
+ }
+
+ return ret_val;
+
+/* End of ZRZT01 */
+
+} /* zrzt01_ */
diff --git a/TESTING/LIN/zrzt02.c b/TESTING/LIN/zrzt02.c
new file mode 100644
index 0000000..5101757
--- /dev/null
+++ b/TESTING/LIN/zrzt02.c
@@ -0,0 +1,156 @@
+/* zrzt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__7 = 7;
+static doublecomplex c_b5 = {0.,0.};
+static doublecomplex c_b6 = {1.,0.};
+
+doublereal zrzt02_(integer *m, integer *n, doublecomplex *af, integer *lda,
+ doublecomplex *tau, doublecomplex *work, integer *lwork)
+{
+ /* System generated locals */
+ integer af_dim1, af_offset, i__1, i__2, i__3;
+ doublereal ret_val;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, info;
+ doublereal rwork[1];
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zunmrz_(char *, char *, integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZRZT02 returns */
+/* || I - Q'*Q || / ( M * eps) */
+/* where the matrix Q is defined by the Householder transformations */
+/* generated by ZTZRZF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix AF. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix AF. */
+
+/* AF (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The output of ZTZRZF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array AF. */
+
+/* TAU (input) COMPLEX*16 array, dimension (M) */
+/* Details of the Householder transformations as returned by */
+/* ZTZRZF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* Length of WORK array. LWORK >= N*N+N. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ if (*lwork < *n * *n + *n) {
+ xerbla_("ZRZT02", &c__7);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return ret_val;
+ }
+
+/* Q := I */
+
+ zlaset_("Full", n, n, &c_b5, &c_b6, &work[1], n);
+
+/* Q := P(1) * ... * P(m) * Q */
+
+ i__1 = *n - *m;
+ i__2 = *lwork - *n * *n;
+ zunmrz_("Left", "No transpose", n, n, m, &i__1, &af[af_offset], lda, &tau[
+ 1], &work[1], n, &work[*n * *n + 1], &i__2, &info);
+
+/* Q := P(m)' * ... * P(1)' * Q */
+
+ i__1 = *n - *m;
+ i__2 = *lwork - *n * *n;
+ zunmrz_("Left", "Conjugate transpose", n, n, m, &i__1, &af[af_offset],
+ lda, &tau[1], &work[1], n, &work[*n * *n + 1], &i__2, &info);
+
+/* Q := Q - I */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = (i__ - 1) * *n + i__;
+ i__3 = (i__ - 1) * *n + i__;
+ z__1.r = work[i__3].r - 1., z__1.i = work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L10: */
+ }
+
+ ret_val = zlange_("One-norm", n, n, &work[1], n, rwork) / (
+ dlamch_("Epsilon") * (doublereal) max(*m,*n));
+ return ret_val;
+
+/* End of ZRZT02 */
+
+} /* zrzt02_ */
diff --git a/TESTING/LIN/zsbmv.c b/TESTING/LIN/zsbmv.c
new file mode 100644
index 0000000..bf09f15
--- /dev/null
+++ b/TESTING/LIN/zsbmv.c
@@ -0,0 +1,479 @@
+/* zsbmv.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int zsbmv_(char *uplo, integer *n, integer *k, doublecomplex
+ *alpha, doublecomplex *a, integer *lda, doublecomplex *x, integer *
+ incx, doublecomplex *beta, doublecomplex *y, integer *incy)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Local variables */
+ integer i__, j, l, ix, iy, jx, jy, kx, ky, info;
+ doublecomplex temp1, temp2;
+ extern logical lsame_(char *, char *);
+ integer kplus1;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSBMV performs the matrix-vector operation */
+
+/* y := alpha*A*x + beta*y, */
+
+/* where alpha and beta are scalars, x and y are n element vectors and */
+/* A is an n by n symmetric band matrix, with k super-diagonals. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO - CHARACTER*1 */
+/* On entry, UPLO specifies whether the upper or lower */
+/* triangular part of the band matrix A is being supplied as */
+/* follows: */
+
+/* UPLO = 'U' or 'u' The upper triangular part of A is */
+/* being supplied. */
+
+/* UPLO = 'L' or 'l' The lower triangular part of A is */
+/* being supplied. */
+
+/* Unchanged on exit. */
+
+/* N - INTEGER */
+/* On entry, N specifies the order of the matrix A. */
+/* N must be at least zero. */
+/* Unchanged on exit. */
+
+/* K - INTEGER */
+/* On entry, K specifies the number of super-diagonals of the */
+/* matrix A. K must satisfy 0 .le. K. */
+/* Unchanged on exit. */
+
+/* ALPHA - COMPLEX*16 */
+/* On entry, ALPHA specifies the scalar alpha. */
+/* Unchanged on exit. */
+
+/* A - COMPLEX*16 array, dimension( LDA, N ) */
+/* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
+/* by n part of the array A must contain the upper triangular */
+/* band part of the symmetric matrix, supplied column by */
+/* column, with the leading diagonal of the matrix in row */
+/* ( k + 1 ) of the array, the first super-diagonal starting at */
+/* position 2 in row k, and so on. The top left k by k triangle */
+/* of the array A is not referenced. */
+/* The following program segment will transfer the upper */
+/* triangular part of a symmetric band matrix from conventional */
+/* full matrix storage to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = K + 1 - J */
+/* DO 10, I = MAX( 1, J - K ), J */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
+/* by n part of the array A must contain the lower triangular */
+/* band part of the symmetric matrix, supplied column by */
+/* column, with the leading diagonal of the matrix in row 1 of */
+/* the array, the first sub-diagonal starting at position 1 in */
+/* row 2, and so on. The bottom right k by k triangle of the */
+/* array A is not referenced. */
+/* The following program segment will transfer the lower */
+/* triangular part of a symmetric band matrix from conventional */
+/* full matrix storage to band storage: */
+
+/* DO 20, J = 1, N */
+/* M = 1 - J */
+/* DO 10, I = J, MIN( N, J + K ) */
+/* A( M + I, J ) = matrix( I, J ) */
+/* 10 CONTINUE */
+/* 20 CONTINUE */
+
+/* Unchanged on exit. */
+
+/* LDA - INTEGER */
+/* On entry, LDA specifies the first dimension of A as declared */
+/* in the calling (sub) program. LDA must be at least */
+/* ( k + 1 ). */
+/* Unchanged on exit. */
+
+/* X - COMPLEX*16 array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCX ) ). */
+/* Before entry, the incremented array X must contain the */
+/* vector x. */
+/* Unchanged on exit. */
+
+/* INCX - INTEGER */
+/* On entry, INCX specifies the increment for the elements of */
+/* X. INCX must not be zero. */
+/* Unchanged on exit. */
+
+/* BETA - COMPLEX*16 */
+/* On entry, BETA specifies the scalar beta. */
+/* Unchanged on exit. */
+
+/* Y - COMPLEX*16 array, dimension at least */
+/* ( 1 + ( N - 1 )*abs( INCY ) ). */
+/* Before entry, the incremented array Y must contain the */
+/* vector y. On exit, Y is overwritten by the updated vector y. */
+
+/* INCY - INTEGER */
+/* On entry, INCY specifies the increment for the elements of */
+/* Y. INCY must not be zero. */
+/* Unchanged on exit. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input parameters. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --x;
+ --y;
+
+ /* Function Body */
+ info = 0;
+ if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+ info = 1;
+ } else if (*n < 0) {
+ info = 2;
+ } else if (*k < 0) {
+ info = 3;
+ } else if (*lda < *k + 1) {
+ info = 6;
+ } else if (*incx == 0) {
+ info = 8;
+ } else if (*incy == 0) {
+ info = 11;
+ }
+ if (info != 0) {
+ xerbla_("ZSBMV ", &info);
+ return 0;
+ }
+
+/* Quick return if possible. */
+
+ if (*n == 0 || alpha->r == 0. && alpha->i == 0. && (beta->r == 1. &&
+ beta->i == 0.)) {
+ return 0;
+ }
+
+/* Set up the start points in X and Y. */
+
+ if (*incx > 0) {
+ kx = 1;
+ } else {
+ kx = 1 - (*n - 1) * *incx;
+ }
+ if (*incy > 0) {
+ ky = 1;
+ } else {
+ ky = 1 - (*n - 1) * *incy;
+ }
+
+/* Start the operations. In this version the elements of the array A */
+/* are accessed sequentially with one pass through A. */
+
+/* First form y := beta*y. */
+
+ if (beta->r != 1. || beta->i != 0.) {
+ if (*incy == 1) {
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ y[i__2].r = 0., y[i__2].i = 0.;
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+/* L20: */
+ }
+ }
+ } else {
+ iy = ky;
+ if (beta->r == 0. && beta->i == 0.) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ y[i__2].r = 0., y[i__2].i = 0.;
+ iy += *incy;
+/* L30: */
+ }
+ } else {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = iy;
+ i__3 = iy;
+ z__1.r = beta->r * y[i__3].r - beta->i * y[i__3].i,
+ z__1.i = beta->r * y[i__3].i + beta->i * y[i__3]
+ .r;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ iy += *incy;
+/* L40: */
+ }
+ }
+ }
+ }
+ if (alpha->r == 0. && alpha->i == 0.) {
+ return 0;
+ }
+ if (lsame_(uplo, "U")) {
+
+/* Form y when upper triangle of A is stored. */
+
+ kplus1 = *k + 1;
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ z__1.r = alpha->r * x[i__2].r - alpha->i * x[i__2].i, z__1.i =
+ alpha->r * x[i__2].i + alpha->i * x[i__2].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__2 = 1, i__3 = j - *k;
+ i__4 = j - 1;
+ for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ i__5 = l + i__ + j * a_dim1;
+ z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ z__1.r = y[i__3].r + z__2.r, z__1.i = y[i__3].i + z__2.i;
+ y[i__2].r = z__1.r, y[i__2].i = z__1.i;
+ i__2 = l + i__ + j * a_dim1;
+ i__3 = i__;
+ z__2.r = a[i__2].r * x[i__3].r - a[i__2].i * x[i__3].i,
+ z__2.i = a[i__2].r * x[i__3].i + a[i__2].i * x[
+ i__3].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L50: */
+ }
+ i__4 = j;
+ i__2 = j;
+ i__3 = kplus1 + j * a_dim1;
+ z__3.r = temp1.r * a[i__3].r - temp1.i * a[i__3].i, z__3.i =
+ temp1.r * a[i__3].i + temp1.i * a[i__3].r;
+ z__2.r = y[i__2].r + z__3.r, z__2.i = y[i__2].i + z__3.i;
+ z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ y[i__4].r = z__1.r, y[i__4].i = z__1.i;
+/* L60: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = jx;
+ z__1.r = alpha->r * x[i__4].r - alpha->i * x[i__4].i, z__1.i =
+ alpha->r * x[i__4].i + alpha->i * x[i__4].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ ix = kx;
+ iy = ky;
+ l = kplus1 - j;
+/* Computing MAX */
+ i__4 = 1, i__2 = j - *k;
+ i__3 = j - 1;
+ for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+ i__4 = iy;
+ i__2 = iy;
+ i__5 = l + i__ + j * a_dim1;
+ z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i;
+ y[i__4].r = z__1.r, y[i__4].i = z__1.i;
+ i__4 = l + i__ + j * a_dim1;
+ i__2 = ix;
+ z__2.r = a[i__4].r * x[i__2].r - a[i__4].i * x[i__2].i,
+ z__2.i = a[i__4].r * x[i__2].i + a[i__4].i * x[
+ i__2].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+ ix += *incx;
+ iy += *incy;
+/* L70: */
+ }
+ i__3 = jy;
+ i__4 = jy;
+ i__2 = kplus1 + j * a_dim1;
+ z__3.r = temp1.r * a[i__2].r - temp1.i * a[i__2].i, z__3.i =
+ temp1.r * a[i__2].i + temp1.i * a[i__2].r;
+ z__2.r = y[i__4].r + z__3.r, z__2.i = y[i__4].i + z__3.i;
+ z__4.r = alpha->r * temp2.r - alpha->i * temp2.i, z__4.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ jx += *incx;
+ jy += *incy;
+ if (j > *k) {
+ kx += *incx;
+ ky += *incy;
+ }
+/* L80: */
+ }
+ }
+ } else {
+
+/* Form y when lower triangle of A is stored. */
+
+ if (*incx == 1 && *incy == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = j;
+ z__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, z__1.i =
+ alpha->r * x[i__3].i + alpha->i * x[i__3].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ i__3 = j;
+ i__4 = j;
+ i__2 = j * a_dim1 + 1;
+ z__2.r = temp1.r * a[i__2].r - temp1.i * a[i__2].i, z__2.i =
+ temp1.r * a[i__2].i + temp1.i * a[i__2].r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ l = 1 - j;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ i__4 = i__;
+ i__2 = i__;
+ i__5 = l + i__ + j * a_dim1;
+ z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i;
+ y[i__4].r = z__1.r, y[i__4].i = z__1.i;
+ i__4 = l + i__ + j * a_dim1;
+ i__2 = i__;
+ z__2.r = a[i__4].r * x[i__2].r - a[i__4].i * x[i__2].i,
+ z__2.i = a[i__4].r * x[i__2].i + a[i__4].i * x[
+ i__2].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L90: */
+ }
+ i__3 = j;
+ i__4 = j;
+ z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+/* L100: */
+ }
+ } else {
+ jx = kx;
+ jy = ky;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__3 = jx;
+ z__1.r = alpha->r * x[i__3].r - alpha->i * x[i__3].i, z__1.i =
+ alpha->r * x[i__3].i + alpha->i * x[i__3].r;
+ temp1.r = z__1.r, temp1.i = z__1.i;
+ temp2.r = 0., temp2.i = 0.;
+ i__3 = jy;
+ i__4 = jy;
+ i__2 = j * a_dim1 + 1;
+ z__2.r = temp1.r * a[i__2].r - temp1.i * a[i__2].i, z__2.i =
+ temp1.r * a[i__2].i + temp1.i * a[i__2].r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ l = 1 - j;
+ ix = jx;
+ iy = jy;
+/* Computing MIN */
+ i__4 = *n, i__2 = j + *k;
+ i__3 = min(i__4,i__2);
+ for (i__ = j + 1; i__ <= i__3; ++i__) {
+ ix += *incx;
+ iy += *incy;
+ i__4 = iy;
+ i__2 = iy;
+ i__5 = l + i__ + j * a_dim1;
+ z__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
+ z__2.i = temp1.r * a[i__5].i + temp1.i * a[i__5]
+ .r;
+ z__1.r = y[i__2].r + z__2.r, z__1.i = y[i__2].i + z__2.i;
+ y[i__4].r = z__1.r, y[i__4].i = z__1.i;
+ i__4 = l + i__ + j * a_dim1;
+ i__2 = ix;
+ z__2.r = a[i__4].r * x[i__2].r - a[i__4].i * x[i__2].i,
+ z__2.i = a[i__4].r * x[i__2].i + a[i__4].i * x[
+ i__2].r;
+ z__1.r = temp2.r + z__2.r, z__1.i = temp2.i + z__2.i;
+ temp2.r = z__1.r, temp2.i = z__1.i;
+/* L110: */
+ }
+ i__3 = jy;
+ i__4 = jy;
+ z__2.r = alpha->r * temp2.r - alpha->i * temp2.i, z__2.i =
+ alpha->r * temp2.i + alpha->i * temp2.r;
+ z__1.r = y[i__4].r + z__2.r, z__1.i = y[i__4].i + z__2.i;
+ y[i__3].r = z__1.r, y[i__3].i = z__1.i;
+ jx += *incx;
+ jy += *incy;
+/* L120: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZSBMV */
+
+} /* zsbmv_ */
diff --git a/TESTING/LIN/zspt01.c b/TESTING/LIN/zspt01.c
new file mode 100644
index 0000000..9a48a95
--- /dev/null
+++ b/TESTING/LIN/zspt01.c
@@ -0,0 +1,205 @@
+/* zspt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+
+/* Subroutine */ int zspt01_(char *uplo, integer *n, doublecomplex *a,
+ doublecomplex *afac, integer *ipiv, doublecomplex *c__, integer *ldc,
+ doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j, jc;
+ doublereal eps;
+ integer info;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+ extern doublereal zlansp_(char *, char *, integer *, doublecomplex *,
+ doublereal *);
+ extern /* Subroutine */ int zlavsp_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *,
+ integer *);
+ extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSPT01 reconstructs a symmetric indefinite packed matrix A from its */
+/* diagonal pivoting factorization A = U*D*U' or A = L*D*L' and computes */
+/* the residual */
+/* norm( C - A ) / ( N * norm(A) * EPS ), */
+/* where C is the reconstructed matrix and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* Hermitian matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The original symmetric matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* AFAC (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The factored form of the matrix A, stored as a packed */
+/* triangular matrix. AFAC contains the block diagonal matrix D */
+/* and the multipliers used to obtain the factor L or U from the */
+/* L*D*L' or U*D*U' factorization as computed by ZSPTRF. */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from ZSPTRF. */
+
+/* C (workspace) COMPLEX*16 array, dimension (LDC,N) */
+
+/* LDC (integer) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) 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 ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ --a;
+ --afac;
+ --ipiv;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Determine EPS and the norm of A. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlansp_("1", uplo, n, &a[1], &rwork[1]);
+
+/* Initialize C to the identity matrix. */
+
+ zlaset_("Full", n, n, &c_b1, &c_b2, &c__[c_offset], ldc);
+
+/* Call ZLAVSP to form the product D * U' (or D * L' ). */
+
+ zlavsp_(uplo, "Transpose", "Non-unit", n, n, &afac[1], &ipiv[1], &c__[
+ c_offset], ldc, &info);
+
+/* Call ZLAVSP again to multiply by U ( or L ). */
+
+ zlavsp_(uplo, "No transpose", "Unit", n, n, &afac[1], &ipiv[1], &c__[
+ c_offset], ldc, &info);
+
+/* Compute the difference C - A . */
+
+ if (lsame_(uplo, "U")) {
+ jc = 0;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = jc + i__;
+ z__1.r = c__[i__4].r - a[i__5].r, z__1.i = c__[i__4].i - a[
+ i__5].i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L10: */
+ }
+ jc += j;
+/* L20: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = jc + i__ - j;
+ z__1.r = c__[i__4].r - a[i__5].r, z__1.i = c__[i__4].i - a[
+ i__5].i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L30: */
+ }
+ jc = jc + *n - j + 1;
+/* L40: */
+ }
+ }
+
+/* Compute norm( C - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = zlansy_("1", uplo, n, &c__[c_offset], ldc, &rwork[1]);
+
+ if (anorm <= 0.) {
+ if (*resid != 0.) {
+ *resid = 1. / eps;
+ }
+ } else {
+ *resid = *resid / (doublereal) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of ZSPT01 */
+
+} /* zspt01_ */
diff --git a/TESTING/LIN/zspt02.c b/TESTING/LIN/zspt02.c
new file mode 100644
index 0000000..3644c37
--- /dev/null
+++ b/TESTING/LIN/zspt02.c
@@ -0,0 +1,175 @@
+/* zspt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zspt02_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, doublecomplex *x, integer *ldx, doublecomplex *b,
+ integer *ldb, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer j;
+ doublereal eps, anorm, bnorm, xnorm;
+ extern /* Subroutine */ int zspmv_(char *, integer *, doublecomplex *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), dzasum_(integer *,
+ doublecomplex *, integer *), zlansp_(char *, char *, integer *,
+ doublecomplex *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSPT02 computes the residual in the solution of a complex symmetric */
+/* system of linear equations A*x = b when packed storage is used for */
+/* the coefficient matrix. The ratio computed is */
+
+/* RESID = norm( B - A*X ) / ( norm(A) * norm(X) * EPS). */
+
+/* where EPS is the machine precision. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* complex symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The original complex symmetric matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ --a;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlansp_("1", uplo, n, &a[1], &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute B - A*X for the matrix of right hand sides B. */
+
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ z__1.r = -1., z__1.i = -0.;
+ zspmv_(uplo, n, &z__1, &a[1], &x[j * x_dim1 + 1], &c__1, &c_b1, &b[j *
+ b_dim1 + 1], &c__1);
+/* L10: */
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = dzasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = dzasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L20: */
+ }
+
+ return 0;
+
+/* End of ZSPT02 */
+
+} /* zspt02_ */
diff --git a/TESTING/LIN/zspt03.c b/TESTING/LIN/zspt03.c
new file mode 100644
index 0000000..f83c615
--- /dev/null
+++ b/TESTING/LIN/zspt03.c
@@ -0,0 +1,348 @@
+/* zspt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int zspt03_(char *uplo, integer *n, doublecomplex *a,
+ doublecomplex *ainv, doublecomplex *work, integer *ldw, doublereal *
+ rwork, doublereal *rcond, doublereal *resid)
+{
+ /* System generated locals */
+ integer work_dim1, work_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1, z__2;
+
+ /* Local variables */
+ integer i__, j, k;
+ doublecomplex t;
+ doublereal eps;
+ integer icol, jcol, kcol, nall;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Double Complex */ VOID zdotu_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ doublereal ainvnm;
+ extern doublereal zlansp_(char *, char *, integer *, doublecomplex *,
+ doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSPT03 computes the residual for a complex symmetric packed matrix */
+/* times its inverse: */
+/* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* complex symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The original complex symmetric matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* AINV (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The (symmetric) inverse of the matrix A, stored as a packed */
+/* triangular matrix. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,N) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal of the condition number of A, computed as */
+/* ( 1/norm(A) ) / norm(AINV). */
+
+/* RESID (output) DOUBLE PRECISION */
+/* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ --a;
+ --ainv;
+ work_dim1 = *ldw;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.;
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlansp_("1", uplo, n, &a[1], &rwork[1]);
+ ainvnm = zlansp_("1", uplo, n, &ainv[1], &rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ *rcond = 0.;
+ *resid = 1. / eps;
+ return 0;
+ }
+ *rcond = 1. / anorm / ainvnm;
+
+/* Case where both A and AINV are upper triangular: */
+/* Each element of - A * AINV is computed by taking the dot product */
+/* of a row of A with a column of AINV. */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ icol = (i__ - 1) * i__ / 2 + 1;
+
+/* Code when J <= I */
+
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ jcol = (j - 1) * j / 2 + 1;
+ zdotu_(&z__1, &j, &a[icol], &c__1, &ainv[jcol], &c__1);
+ t.r = z__1.r, t.i = z__1.i;
+ jcol = jcol + (j << 1) - 1;
+ kcol = icol - 1;
+ i__3 = i__;
+ for (k = j + 1; k <= i__3; ++k) {
+ i__4 = kcol + k;
+ i__5 = jcol;
+ z__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
+ .i, z__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
+ * ainv[i__5].r;
+ z__1.r = t.r + z__2.r, z__1.i = t.i + z__2.i;
+ t.r = z__1.r, t.i = z__1.i;
+ jcol += k;
+/* L10: */
+ }
+ kcol += i__ << 1;
+ i__3 = *n;
+ for (k = i__ + 1; k <= i__3; ++k) {
+ i__4 = kcol;
+ i__5 = jcol;
+ z__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
+ .i, z__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
+ * ainv[i__5].r;
+ z__1.r = t.r + z__2.r, z__1.i = t.i + z__2.i;
+ t.r = z__1.r, t.i = z__1.i;
+ kcol += k;
+ jcol += k;
+/* L20: */
+ }
+ i__3 = i__ + j * work_dim1;
+ z__1.r = -t.r, z__1.i = -t.i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L30: */
+ }
+
+/* Code when J > I */
+
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ jcol = (j - 1) * j / 2 + 1;
+ zdotu_(&z__1, &i__, &a[icol], &c__1, &ainv[jcol], &c__1);
+ t.r = z__1.r, t.i = z__1.i;
+ --jcol;
+ kcol = icol + (i__ << 1) - 1;
+ i__3 = j;
+ for (k = i__ + 1; k <= i__3; ++k) {
+ i__4 = kcol;
+ i__5 = jcol + k;
+ z__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
+ .i, z__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
+ * ainv[i__5].r;
+ z__1.r = t.r + z__2.r, z__1.i = t.i + z__2.i;
+ t.r = z__1.r, t.i = z__1.i;
+ kcol += k;
+/* L40: */
+ }
+ jcol += j << 1;
+ i__3 = *n;
+ for (k = j + 1; k <= i__3; ++k) {
+ i__4 = kcol;
+ i__5 = jcol;
+ z__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
+ .i, z__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
+ * ainv[i__5].r;
+ z__1.r = t.r + z__2.r, z__1.i = t.i + z__2.i;
+ t.r = z__1.r, t.i = z__1.i;
+ kcol += k;
+ jcol += k;
+/* L50: */
+ }
+ i__3 = i__ + j * work_dim1;
+ z__1.r = -t.r, z__1.i = -t.i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L60: */
+ }
+/* L70: */
+ }
+ } else {
+
+/* Case where both A and AINV are lower triangular */
+
+ nall = *n * (*n + 1) / 2;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* Code when J <= I */
+
+ icol = nall - (*n - i__ + 1) * (*n - i__ + 2) / 2 + 1;
+ i__2 = i__;
+ for (j = 1; j <= i__2; ++j) {
+ jcol = nall - (*n - j) * (*n - j + 1) / 2 - (*n - i__);
+ i__3 = *n - i__ + 1;
+ zdotu_(&z__1, &i__3, &a[icol], &c__1, &ainv[jcol], &c__1);
+ t.r = z__1.r, t.i = z__1.i;
+ kcol = i__;
+ jcol = j;
+ i__3 = j - 1;
+ for (k = 1; k <= i__3; ++k) {
+ i__4 = kcol;
+ i__5 = jcol;
+ z__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
+ .i, z__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
+ * ainv[i__5].r;
+ z__1.r = t.r + z__2.r, z__1.i = t.i + z__2.i;
+ t.r = z__1.r, t.i = z__1.i;
+ jcol = jcol + *n - k;
+ kcol = kcol + *n - k;
+/* L80: */
+ }
+ jcol -= j;
+ i__3 = i__ - 1;
+ for (k = j; k <= i__3; ++k) {
+ i__4 = kcol;
+ i__5 = jcol + k;
+ z__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
+ .i, z__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
+ * ainv[i__5].r;
+ z__1.r = t.r + z__2.r, z__1.i = t.i + z__2.i;
+ t.r = z__1.r, t.i = z__1.i;
+ kcol = kcol + *n - k;
+/* L90: */
+ }
+ i__3 = i__ + j * work_dim1;
+ z__1.r = -t.r, z__1.i = -t.i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L100: */
+ }
+
+/* Code when J > I */
+
+ icol = nall - (*n - i__) * (*n - i__ + 1) / 2;
+ i__2 = *n;
+ for (j = i__ + 1; j <= i__2; ++j) {
+ jcol = nall - (*n - j + 1) * (*n - j + 2) / 2 + 1;
+ i__3 = *n - j + 1;
+ zdotu_(&z__1, &i__3, &a[icol - *n + j], &c__1, &ainv[jcol], &
+ c__1);
+ t.r = z__1.r, t.i = z__1.i;
+ kcol = i__;
+ jcol = j;
+ i__3 = i__ - 1;
+ for (k = 1; k <= i__3; ++k) {
+ i__4 = kcol;
+ i__5 = jcol;
+ z__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
+ .i, z__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
+ * ainv[i__5].r;
+ z__1.r = t.r + z__2.r, z__1.i = t.i + z__2.i;
+ t.r = z__1.r, t.i = z__1.i;
+ jcol = jcol + *n - k;
+ kcol = kcol + *n - k;
+/* L110: */
+ }
+ kcol -= i__;
+ i__3 = j - 1;
+ for (k = i__; k <= i__3; ++k) {
+ i__4 = kcol + k;
+ i__5 = jcol;
+ z__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
+ .i, z__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
+ * ainv[i__5].r;
+ z__1.r = t.r + z__2.r, z__1.i = t.i + z__2.i;
+ t.r = z__1.r, t.i = z__1.i;
+ jcol = jcol + *n - k;
+/* L120: */
+ }
+ i__3 = i__ + j * work_dim1;
+ z__1.r = -t.r, z__1.i = -t.i;
+ work[i__3].r = z__1.r, work[i__3].i = z__1.i;
+/* L130: */
+ }
+/* L140: */
+ }
+ }
+
+/* Add the identity matrix to WORK . */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * work_dim1;
+ i__3 = i__ + i__ * work_dim1;
+ z__1.r = work[i__3].r + 1., z__1.i = work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L150: */
+ }
+
+/* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = zlange_("1", n, n, &work[work_offset], ldw, &rwork[1])
+ ;
+
+ *resid = *resid * *rcond / eps / (doublereal) (*n);
+
+ return 0;
+
+/* End of ZSPT03 */
+
+} /* zspt03_ */
diff --git a/TESTING/LIN/zsyt01.c b/TESTING/LIN/zsyt01.c
new file mode 100644
index 0000000..d17ef82
--- /dev/null
+++ b/TESTING/LIN/zsyt01.c
@@ -0,0 +1,210 @@
+/* zsyt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+
+/* Subroutine */ int zsyt01_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *afac, integer *ldafac, integer *ipiv,
+ doublecomplex *c__, integer *ldc, doublereal *rwork, doublereal *
+ resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, afac_dim1, afac_offset, c_dim1, c_offset, i__1,
+ i__2, i__3, i__4, i__5;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal eps;
+ integer info;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+ extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zlavsy_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, integer *, doublecomplex *,
+ integer *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSYT01 reconstructs a complex symmetric indefinite matrix A from its */
+/* block L*D*L' or U*D*U' factorization and computes the residual */
+/* norm( C - A ) / ( N * norm(A) * EPS ), */
+/* where C is the reconstructed matrix, EPS is the machine epsilon, */
+/* L' is the transpose of L, and U' is the transpose of U. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* complex symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original complex symmetric matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* AFAC (input) COMPLEX*16 array, dimension (LDAFAC,N) */
+/* The factored form of the matrix A. AFAC contains the block */
+/* diagonal matrix D and the multipliers used to obtain the */
+/* factor L or U from the block L*D*L' or U*D*U' factorization */
+/* as computed by ZSYTRF. */
+
+/* LDAFAC (input) INTEGER */
+/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
+
+/* IPIV (input) INTEGER array, dimension (N) */
+/* The pivot indices from ZSYTRF. */
+
+/* C (workspace) COMPLEX*16 array, dimension (LDC,N) */
+
+/* LDC (integer) INTEGER */
+/* The leading dimension of the array C. LDC >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) 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 ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ afac_dim1 = *ldafac;
+ afac_offset = 1 + afac_dim1;
+ afac -= afac_offset;
+ --ipiv;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Determine EPS and the norm of A. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+
+/* Initialize C to the identity matrix. */
+
+ zlaset_("Full", n, n, &c_b1, &c_b2, &c__[c_offset], ldc);
+
+/* Call ZLAVSY to form the product D * U' (or D * L' ). */
+
+ zlavsy_(uplo, "Transpose", "Non-unit", n, n, &afac[afac_offset], ldafac, &
+ ipiv[1], &c__[c_offset], ldc, &info);
+
+/* Call ZLAVSY again to multiply by U (or L ). */
+
+ zlavsy_(uplo, "No transpose", "Unit", n, n, &afac[afac_offset], ldafac, &
+ ipiv[1], &c__[c_offset], ldc, &info);
+
+/* Compute the difference C - A . */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * a_dim1;
+ z__1.r = c__[i__4].r - a[i__5].r, z__1.i = c__[i__4].i - a[
+ i__5].i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * c_dim1;
+ i__4 = i__ + j * c_dim1;
+ i__5 = i__ + j * a_dim1;
+ z__1.r = c__[i__4].r - a[i__5].r, z__1.i = c__[i__4].i - a[
+ i__5].i;
+ c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+
+/* Compute norm( C - A ) / ( N * norm(A) * EPS ) */
+
+ *resid = zlansy_("1", uplo, n, &c__[c_offset], ldc, &rwork[1]);
+
+ if (anorm <= 0.) {
+ if (*resid != 0.) {
+ *resid = 1. / eps;
+ }
+ } else {
+ *resid = *resid / (doublereal) (*n) / anorm / eps;
+ }
+
+ return 0;
+
+/* End of ZSYT01 */
+
+} /* zsyt01_ */
diff --git a/TESTING/LIN/zsyt02.c b/TESTING/LIN/zsyt02.c
new file mode 100644
index 0000000..e46652a
--- /dev/null
+++ b/TESTING/LIN/zsyt02.c
@@ -0,0 +1,174 @@
+/* zsyt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static integer c__1 = 1;
+
+/* Subroutine */ int zsyt02_(char *uplo, integer *n, integer *nrhs,
+ doublecomplex *a, integer *lda, doublecomplex *x, integer *ldx,
+ doublecomplex *b, integer *ldb, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer j;
+ doublereal eps, anorm, bnorm, xnorm;
+ extern /* Subroutine */ int zsymm_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), dzasum_(integer *,
+ doublecomplex *, integer *), zlansy_(char *, char *, integer *,
+ doublecomplex *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSYT02 computes the residual for a solution to a complex symmetric */
+/* system of linear equations A*x = b: */
+
+/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ), */
+
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of B, the matrix of right hand sides. */
+/* NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original complex symmetric matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* On entry, the right hand side vectors for the system of */
+/* linear equations. */
+/* On exit, B is overwritten with the difference B - A*X. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute B - A*X (or B - A'*X ) and store in B . */
+
+ z__1.r = -1., z__1.i = -0.;
+ zsymm_("Left", uplo, n, nrhs, &z__1, &a[a_offset], lda, &x[x_offset], ldx,
+ &c_b1, &b[b_offset], ldb);
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) . */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ bnorm = dzasum_(n, &b[j * b_dim1 + 1], &c__1);
+ xnorm = dzasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of ZSYT02 */
+
+} /* zsyt02_ */
diff --git a/TESTING/LIN/zsyt03.c b/TESTING/LIN/zsyt03.c
new file mode 100644
index 0000000..81be77b
--- /dev/null
+++ b/TESTING/LIN/zsyt03.c
@@ -0,0 +1,206 @@
+/* zsyt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+
+/* Subroutine */ int zsyt03_(char *uplo, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *ainv, integer *ldainv, doublecomplex *
+ work, integer *ldwork, doublereal *rwork, doublereal *rcond,
+ doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, ainv_dim1, ainv_offset, work_dim1, work_offset,
+ i__1, i__2, i__3, i__4;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int zsymm_(char *, char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlange_(char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *);
+ doublereal ainvnm;
+ extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
+ integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZSYT03 computes the residual for a complex symmetric matrix times */
+/* its inverse: */
+/* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ) */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the upper or lower triangular part of the */
+/* complex symmetric matrix A is stored: */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* N (input) INTEGER */
+/* The number of rows and columns of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original complex symmetric matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N) */
+
+/* AINV (input/output) COMPLEX*16 array, dimension (LDAINV,N) */
+/* On entry, the inverse of the matrix A, stored as a symmetric */
+/* matrix in the same format as A. */
+/* In this version, AINV is expanded into a full matrix and */
+/* multiplied by A, so the opposing triangle of AINV will be */
+/* changed; i.e., if the upper triangular part of AINV is */
+/* stored, the lower triangular part will be used as work space. */
+
+/* LDAINV (input) INTEGER */
+/* The leading dimension of the array AINV. LDAINV >= max(1,N). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,N) */
+
+/* LDWORK (input) INTEGER */
+/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal of the condition number of A, computed as */
+/* RCOND = 1/ (norm(A) * norm(AINV)). */
+
+/* RESID (output) DOUBLE PRECISION */
+/* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ ainv_dim1 = *ldainv;
+ ainv_offset = 1 + ainv_dim1;
+ ainv -= ainv_offset;
+ work_dim1 = *ldwork;
+ work_offset = 1 + work_dim1;
+ work -= work_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.;
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
+ ainvnm = zlansy_("1", uplo, n, &ainv[ainv_offset], ldainv, &rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ *rcond = 0.;
+ *resid = 1. / eps;
+ return 0;
+ }
+ *rcond = 1. / anorm / ainvnm;
+
+/* Expand AINV into a full matrix and call ZSYMM to multiply */
+/* AINV on the left by A (store the result in WORK). */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * ainv_dim1;
+ i__4 = i__ + j * ainv_dim1;
+ ainv[i__3].r = ainv[i__4].r, ainv[i__3].i = ainv[i__4].i;
+/* L10: */
+ }
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * ainv_dim1;
+ i__4 = i__ + j * ainv_dim1;
+ ainv[i__3].r = ainv[i__4].r, ainv[i__3].i = ainv[i__4].i;
+/* L30: */
+ }
+/* L40: */
+ }
+ }
+ z__1.r = -1., z__1.i = -0.;
+ zsymm_("Left", uplo, n, n, &z__1, &a[a_offset], lda, &ainv[ainv_offset],
+ ldainv, &c_b1, &work[work_offset], ldwork);
+
+/* Add the identity matrix to WORK . */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * work_dim1;
+ i__3 = i__ + i__ * work_dim1;
+ z__1.r = work[i__3].r + 1., z__1.i = work[i__3].i + 0.;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L50: */
+ }
+
+/* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = zlange_("1", n, n, &work[work_offset], ldwork, &rwork[1]);
+
+ *resid = *resid * *rcond / eps / (doublereal) (*n);
+
+ return 0;
+
+/* End of ZSYT03 */
+
+} /* zsyt03_ */
diff --git a/TESTING/LIN/ztbt02.c b/TESTING/LIN/ztbt02.c
new file mode 100644
index 0000000..7054931
--- /dev/null
+++ b/TESTING/LIN/ztbt02.c
@@ -0,0 +1,208 @@
+/* ztbt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublecomplex c_b12 = {-1.,0.};
+
+/* Subroutine */ int ztbt02_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, doublecomplex *ab, integer *ldab,
+ doublecomplex *x, integer *ldx, doublecomplex *b, integer *ldb,
+ doublecomplex *work, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ doublereal anorm, bnorm;
+ extern /* Subroutine */ int ztbmv_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal xnorm;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), zlantb_(char *, char *, char *,
+ integer *, integer *, doublecomplex *, integer *, doublereal *), dzasum_(integer *, doublecomplex *,
+ integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTBT02 computes the residual for the computed solution to a */
+/* triangular system of linear equations A*x = b, A**T *x = b, or */
+/* A**H *x = b when A is a triangular band matrix. Here A**T denotes */
+/* the transpose of A, A**H denotes the conjugate transpose of A, and */
+/* x and b are N by NRHS matrices. The test ratio is the maximum over */
+/* the number of right hand sides of */
+/* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A, A**T, or A**H, and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = b (No transpose) */
+/* = 'T': A**T *x = b (Transpose) */
+/* = 'C': A**H *x = b (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= max(1,KD+1). */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Compute the 1-norm of A or A'. */
+
+ if (lsame_(trans, "N")) {
+ anorm = zlantb_("1", uplo, diag, n, kd, &ab[ab_offset], ldab, &rwork[
+ 1]);
+ } else {
+ anorm = zlantb_("I", uplo, diag, n, kd, &ab[ab_offset], ldab, &rwork[
+ 1]);
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ztbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[1], &
+ c__1);
+ zaxpy_(n, &c_b12, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ bnorm = dzasum_(n, &work[1], &c__1);
+ xnorm = dzasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of ZTBT02 */
+
+} /* ztbt02_ */
diff --git a/TESTING/LIN/ztbt03.c b/TESTING/LIN/ztbt03.c
new file mode 100644
index 0000000..859c7dc
--- /dev/null
+++ b/TESTING/LIN/ztbt03.c
@@ -0,0 +1,263 @@
+/* ztbt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ztbt03_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, doublecomplex *ab, integer *ldab,
+ doublereal *scale, doublereal *cnorm, doublereal *tscal,
+ doublecomplex *x, integer *ldx, doublecomplex *b, integer *ldb,
+ doublecomplex *work, doublereal *resid)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+
+ /* Local variables */
+ integer j, ix;
+ doublereal eps, err;
+ extern logical lsame_(char *, char *);
+ doublereal xscal, tnorm;
+ extern /* Subroutine */ int ztbmv_(char *, char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *, integer *);
+ doublereal xnorm;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ doublereal smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTBT03 computes the residual for the solution to a scaled triangular */
+/* system of equations A*x = s*b, A**T *x = s*b, or A**H *x = s*b */
+/* when A is a triangular band matrix. Here A**T denotes the transpose */
+/* of A, A**H denotes the conjugate transpose of A, s is a scalar, and */
+/* x and b are N by NRHS matrices. The test ratio is the maximum over */
+/* the number of right hand sides of */
+/* norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A, A**T, or A**H, and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = s*b (No transpose) */
+/* = 'T': A**T *x = s*b (Transpose) */
+/* = 'C': A**H *x = s*b (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* SCALE (input) DOUBLE PRECISION */
+/* The scaling factor s used in solving the triangular system. */
+
+/* CNORM (input) DOUBLE PRECISION array, dimension (N) */
+/* The 1-norms of the columns of A, not counting the diagonal. */
+
+/* TSCAL (input) DOUBLE PRECISION */
+/* The scaling factor used in computing the 1-norms in CNORM. */
+/* CNORM actually contains the column norms of TSCAL*A. */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --cnorm;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+ eps = dlamch_("Epsilon");
+ smlnum = dlamch_("Safe minimum");
+
+/* Compute the norm of the triangular matrix A using the column */
+/* norms already computed by ZLATBS. */
+
+ tnorm = 0.;
+ if (lsame_(diag, "N")) {
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ d__1 = tnorm, d__2 = *tscal * z_abs(&ab[*kd + 1 + j * ab_dim1]
+ ) + cnorm[j];
+ tnorm = max(d__1,d__2);
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ d__1 = tnorm, d__2 = *tscal * z_abs(&ab[j * ab_dim1 + 1]) +
+ cnorm[j];
+ tnorm = max(d__1,d__2);
+/* L20: */
+ }
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ d__1 = tnorm, d__2 = *tscal + cnorm[j];
+ tnorm = max(d__1,d__2);
+/* L30: */
+ }
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = izamax_(n, &work[1], &c__1);
+/* Computing MAX */
+ d__1 = 1., d__2 = z_abs(&x[ix + j * x_dim1]);
+ xnorm = max(d__1,d__2);
+ xscal = 1. / xnorm / (doublereal) (*kd + 1);
+ zdscal_(n, &xscal, &work[1], &c__1);
+ ztbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[1], &
+ c__1);
+ d__1 = -(*scale) * xscal;
+ z__1.r = d__1, z__1.i = 0.;
+ zaxpy_(n, &z__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = izamax_(n, &work[1], &c__1);
+ err = *tscal * z_abs(&work[ix]);
+ ix = izamax_(n, &x[j * x_dim1 + 1], &c__1);
+ xnorm = z_abs(&x[ix + j * x_dim1]);
+ if (err * smlnum <= xnorm) {
+ if (xnorm > 0.) {
+ err /= xnorm;
+ }
+ } else {
+ if (err > 0.) {
+ err = 1. / eps;
+ }
+ }
+ if (err * smlnum <= tnorm) {
+ if (tnorm > 0.) {
+ err /= tnorm;
+ }
+ } else {
+ if (err > 0.) {
+ err = 1. / eps;
+ }
+ }
+ *resid = max(*resid,err);
+/* L40: */
+ }
+
+ return 0;
+
+/* End of ZTBT03 */
+
+} /* ztbt03_ */
diff --git a/TESTING/LIN/ztbt05.c b/TESTING/LIN/ztbt05.c
new file mode 100644
index 0000000..81d9c9f
--- /dev/null
+++ b/TESTING/LIN/ztbt05.c
@@ -0,0 +1,375 @@
+/* ztbt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ztbt05_(char *uplo, char *trans, char *diag, integer *n,
+ integer *kd, integer *nrhs, doublecomplex *ab, integer *ldab,
+ doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx,
+ doublecomplex *xact, integer *ldxact, doublereal *ferr, doublereal *
+ berr, doublereal *reslts)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, nz, ifu;
+ doublereal eps, tmp, diff, axbi;
+ integer imax;
+ doublereal unfl, ovfl;
+ logical unit;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ doublereal xnorm;
+ extern doublereal dlamch_(char *);
+ doublereal errbnd;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTBT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* triangular band matrix. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+/* and NZ = max. number of nonzeros in any row of A, plus 1 */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A'* X = B (Transpose) */
+/* = 'C': A'* X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of super-diagonals of the matrix A if UPLO = 'U', */
+/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( NZ*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.;
+ reslts[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ unit = lsame_(diag, "U");
+/* Computing MIN */
+ i__1 = *kd, i__2 = *n - 1;
+ nz = min(i__1,i__2) + 1;
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = izamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__2 = imax + j * x_dim1;
+ d__3 = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[imax + j *
+ x_dim1]), abs(d__2));
+ xnorm = max(d__3,unfl);
+ diff = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * xact_dim1;
+ z__2.r = x[i__3].r - xact[i__4].r, z__2.i = x[i__3].i - xact[i__4]
+ .i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+/* Computing MAX */
+ d__3 = diff, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
+ z__1), abs(d__2));
+ diff = max(d__3,d__4);
+/* L10: */
+ }
+
+ if (xnorm > 1.) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1. / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
+ errbnd = max(d__1,d__2);
+ } else {
+ errbnd = 1. / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where */
+/* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ ifu = 0;
+ if (unit) {
+ ifu = 1;
+ }
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ tmp = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__ + k *
+ b_dim1]), abs(d__2));
+ if (upper) {
+ if (! notran) {
+/* Computing MAX */
+ i__3 = i__ - *kd;
+ i__4 = i__ - ifu;
+ for (j = max(i__3,1); j <= i__4; ++j) {
+ i__3 = *kd + 1 - i__ + j + i__ * ab_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&ab[*kd + 1 - i__ + j + i__ * ab_dim1])
+ , abs(d__2))) * ((d__3 = x[i__5].r, abs(d__3))
+ + (d__4 = d_imag(&x[j + k * x_dim1]), abs(
+ d__4)));
+/* L40: */
+ }
+ if (unit) {
+ i__4 = i__ + k * x_dim1;
+ tmp += (d__1 = x[i__4].r, abs(d__1)) + (d__2 = d_imag(
+ &x[i__ + k * x_dim1]), abs(d__2));
+ }
+ } else {
+ if (unit) {
+ i__4 = i__ + k * x_dim1;
+ tmp += (d__1 = x[i__4].r, abs(d__1)) + (d__2 = d_imag(
+ &x[i__ + k * x_dim1]), abs(d__2));
+ }
+/* Computing MIN */
+ i__3 = i__ + *kd;
+ i__4 = min(i__3,*n);
+ for (j = i__ + ifu; j <= i__4; ++j) {
+ i__3 = *kd + 1 + i__ - j + j * ab_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 =
+ d_imag(&ab[*kd + 1 + i__ - j + j * ab_dim1]),
+ abs(d__2))) * ((d__3 = x[i__5].r, abs(d__3))
+ + (d__4 = d_imag(&x[j + k * x_dim1]), abs(
+ d__4)));
+/* L50: */
+ }
+ }
+ } else {
+ if (notran) {
+/* Computing MAX */
+ i__4 = i__ - *kd;
+ i__3 = i__ - ifu;
+ for (j = max(i__4,1); j <= i__3; ++j) {
+ i__4 = i__ + 1 - j + j * ab_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = ab[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&ab[i__ + 1 - j + j * ab_dim1]), abs(
+ d__2))) * ((d__3 = x[i__5].r, abs(d__3)) + (
+ d__4 = d_imag(&x[j + k * x_dim1]), abs(d__4)))
+ ;
+/* L60: */
+ }
+ if (unit) {
+ i__3 = i__ + k * x_dim1;
+ tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
+ &x[i__ + k * x_dim1]), abs(d__2));
+ }
+ } else {
+ if (unit) {
+ i__3 = i__ + k * x_dim1;
+ tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
+ &x[i__ + k * x_dim1]), abs(d__2));
+ }
+/* Computing MIN */
+ i__4 = i__ + *kd;
+ i__3 = min(i__4,*n);
+ for (j = i__ + ifu; j <= i__3; ++j) {
+ i__4 = j + 1 - i__ + i__ * ab_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = ab[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&ab[j + 1 - i__ + i__ * ab_dim1]), abs(
+ d__2))) * ((d__3 = x[i__5].r, abs(d__3)) + (
+ d__4 = d_imag(&x[j + k * x_dim1]), abs(d__4)))
+ ;
+/* L70: */
+ }
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = min(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ d__1 = axbi, d__2 = nz * unfl;
+ tmp = berr[k] / (nz * eps + nz * unfl / max(d__1,d__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = max(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of ZTBT05 */
+
+} /* ztbt05_ */
diff --git a/TESTING/LIN/ztbt06.c b/TESTING/LIN/ztbt06.c
new file mode 100644
index 0000000..8df4e4a
--- /dev/null
+++ b/TESTING/LIN/ztbt06.c
@@ -0,0 +1,160 @@
+/* ztbt06.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ztbt06_(doublereal *rcond, doublereal *rcondc, char *
+ uplo, char *diag, integer *n, integer *kd, doublecomplex *ab, integer
+ *ldab, doublereal *rwork, doublereal *rat)
+{
+ /* System generated locals */
+ integer ab_dim1, ab_offset;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ doublereal eps, rmin, rmax, anorm;
+ extern doublereal dlamch_(char *);
+ doublereal bignum;
+ extern doublereal zlantb_(char *, char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTBT06 computes a test ratio comparing RCOND (the reciprocal */
+/* condition number of a triangular matrix A) and RCONDC, the estimate */
+/* computed by ZTBCON. Information about the triangular matrix A is */
+/* used if one estimate is zero and the other is non-zero to decide if */
+/* underflow in the estimate is justified. */
+
+/* Arguments */
+/* ========= */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number obtained by */
+/* forming the explicit inverse of the matrix A and computing */
+/* RCOND = 1/( norm(A) * norm(inv(A)) ). */
+
+/* RCONDC (input) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number computed by */
+/* ZTBCON. */
+
+/* UPLO (input) CHARACTER */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* KD (input) INTEGER */
+/* The number of superdiagonals or subdiagonals of the */
+/* triangular band matrix A. KD >= 0. */
+
+/* AB (input) COMPLEX*16 array, dimension (LDAB,N) */
+/* The upper or lower triangular band matrix A, stored in the */
+/* first kd+1 rows of the array. The j-th column of A is stored */
+/* in the j-th column of the array AB as follows: */
+/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
+/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
+
+/* LDAB (input) INTEGER */
+/* The leading dimension of the array AB. LDAB >= KD+1. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RAT (output) DOUBLE PRECISION */
+/* The test ratio. If both RCOND and RCONDC are nonzero, */
+/* RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1. */
+/* If RAT = 0, the two estimates are exactly the same. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ ab_dim1 = *ldab;
+ ab_offset = 1 + ab_dim1;
+ ab -= ab_offset;
+ --rwork;
+
+ /* Function Body */
+ eps = dlamch_("Epsilon");
+ rmax = max(*rcond,*rcondc);
+ rmin = min(*rcond,*rcondc);
+
+/* Do the easy cases first. */
+
+ if (rmin < 0.) {
+
+/* Invalid value for RCOND or RCONDC, return 1/EPS. */
+
+ *rat = 1. / eps;
+
+ } else if (rmin > 0.) {
+
+/* Both estimates are positive, return RMAX/RMIN - 1. */
+
+ *rat = rmax / rmin - 1.;
+
+ } else if (rmax == 0.) {
+
+/* Both estimates zero. */
+
+ *rat = 0.;
+
+ } else {
+
+/* One estimate is zero, the other is non-zero. If the matrix is */
+/* ill-conditioned, return the nonzero estimate multiplied by */
+/* 1/EPS; if the matrix is badly scaled, return the nonzero */
+/* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum */
+/* element in absolute value in A. */
+
+ bignum = 1. / dlamch_("Safe minimum");
+ anorm = zlantb_("M", uplo, diag, n, kd, &ab[ab_offset], ldab, &rwork[
+ 1]);
+
+/* Computing MIN */
+ d__1 = bignum / max(1.,anorm), d__2 = 1. / eps;
+ *rat = rmax * min(d__1,d__2);
+ }
+
+ return 0;
+
+/* End of ZTBT06 */
+
+} /* ztbt06_ */
diff --git a/TESTING/LIN/ztpt01.c b/TESTING/LIN/ztpt01.c
new file mode 100644
index 0000000..28191ab
--- /dev/null
+++ b/TESTING/LIN/ztpt01.c
@@ -0,0 +1,199 @@
+/* ztpt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ztpt01_(char *uplo, char *diag, integer *n,
+ doublecomplex *ap, doublecomplex *ainvp, doublereal *rcond,
+ doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer j, jc;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ logical unitd;
+ extern /* Subroutine */ int ztpmv_(char *, char *, char *, integer *,
+ doublecomplex *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal ainvnm;
+ extern doublereal zlantp_(char *, char *, char *, integer *,
+ doublecomplex *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTPT01 computes the residual for a triangular matrix A times its */
+/* inverse when A is stored in packed format: */
+/* RESID = norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The original upper or lower triangular matrix A, packed */
+/* columnwise in a linear array. The j-th column of A is stored */
+/* in the array AP as follows: */
+/* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
+
+/* AINVP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* On entry, the (triangular) inverse of the matrix A, packed */
+/* columnwise in a linear array as in AP. */
+/* On exit, the contents of AINVP are destroyed. */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal condition number of A, computed as */
+/* 1/(norm(A) * norm(AINV)). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --ainvp;
+ --ap;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.;
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlantp_("1", uplo, diag, n, &ap[1], &rwork[1]);
+ ainvnm = zlantp_("1", uplo, diag, n, &ainvp[1], &rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ *rcond = 0.;
+ *resid = 1. / eps;
+ return 0;
+ }
+ *rcond = 1. / anorm / ainvnm;
+
+/* Compute A * AINV, overwriting AINV. */
+
+ unitd = lsame_(diag, "U");
+ if (lsame_(uplo, "U")) {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (unitd) {
+ i__2 = jc + j - 1;
+ ainvp[i__2].r = 1., ainvp[i__2].i = 0.;
+ }
+
+/* Form the j-th column of A*AINV. */
+
+ ztpmv_("Upper", "No transpose", diag, &j, &ap[1], &ainvp[jc], &
+ c__1);
+
+/* Subtract 1 from the diagonal to form A*AINV - I. */
+
+ i__2 = jc + j - 1;
+ i__3 = jc + j - 1;
+ z__1.r = ainvp[i__3].r - 1., z__1.i = ainvp[i__3].i;
+ ainvp[i__2].r = z__1.r, ainvp[i__2].i = z__1.i;
+ jc += j;
+/* L10: */
+ }
+ } else {
+ jc = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (unitd) {
+ i__2 = jc;
+ ainvp[i__2].r = 1., ainvp[i__2].i = 0.;
+ }
+
+/* Form the j-th column of A*AINV. */
+
+ i__2 = *n - j + 1;
+ ztpmv_("Lower", "No transpose", diag, &i__2, &ap[jc], &ainvp[jc],
+ &c__1);
+
+/* Subtract 1 from the diagonal to form A*AINV - I. */
+
+ i__2 = jc;
+ i__3 = jc;
+ z__1.r = ainvp[i__3].r - 1., z__1.i = ainvp[i__3].i;
+ ainvp[i__2].r = z__1.r, ainvp[i__2].i = z__1.i;
+ jc = jc + *n - j + 1;
+/* L20: */
+ }
+ }
+
+/* Compute norm(A*AINV - I) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = zlantp_("1", uplo, "Non-unit", n, &ainvp[1], &rwork[1]);
+
+ *resid = *resid * *rcond / (doublereal) (*n) / eps;
+
+ return 0;
+
+/* End of ZTPT01 */
+
+} /* ztpt01_ */
diff --git a/TESTING/LIN/ztpt02.c b/TESTING/LIN/ztpt02.c
new file mode 100644
index 0000000..63a237c
--- /dev/null
+++ b/TESTING/LIN/ztpt02.c
@@ -0,0 +1,197 @@
+/* ztpt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublecomplex c_b12 = {-1.,0.};
+
+/* Subroutine */ int ztpt02_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublecomplex *ap, doublecomplex *x, integer *ldx,
+ doublecomplex *b, integer *ldb, doublecomplex *work, doublereal *
+ rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ doublereal anorm, bnorm, xnorm;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), ztpmv_(
+ char *, char *, char *, integer *, doublecomplex *, doublecomplex
+ *, integer *);
+ extern doublereal dlamch_(char *), dzasum_(integer *,
+ doublecomplex *, integer *), zlantp_(char *, char *, char *,
+ integer *, doublecomplex *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTPT02 computes the residual for the computed solution to a */
+/* triangular system of linear equations A*x = b, A**T *x = b, or */
+/* A**H *x = b, when the triangular matrix A is stored in packed format. */
+/* Here A**T denotes the transpose of A, A**H denotes the conjugate */
+/* transpose of A, and x and b are N by NRHS matrices. The test ratio */
+/* is the maximum over the number of right hand sides of */
+/* the maximum over the number of right hand sides of */
+/* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A, A**T, or A**H, and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = b (No transpose) */
+/* = 'T': A**T *x = b (Transpose) */
+/* = 'C': A**H *x = b (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ --ap;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Compute the 1-norm of A or A**H. */
+
+ if (lsame_(trans, "N")) {
+ anorm = zlantp_("1", uplo, diag, n, &ap[1], &rwork[1]);
+ } else {
+ anorm = zlantp_("I", uplo, diag, n, &ap[1], &rwork[1]);
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ztpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1);
+ zaxpy_(n, &c_b12, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ bnorm = dzasum_(n, &work[1], &c__1);
+ xnorm = dzasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of ZTPT02 */
+
+} /* ztpt02_ */
diff --git a/TESTING/LIN/ztpt03.c b/TESTING/LIN/ztpt03.c
new file mode 100644
index 0000000..3c39273
--- /dev/null
+++ b/TESTING/LIN/ztpt03.c
@@ -0,0 +1,254 @@
+/* ztpt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ztpt03_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublecomplex *ap, doublereal *scale, doublereal *
+ cnorm, doublereal *tscal, doublecomplex *x, integer *ldx,
+ doublecomplex *b, integer *ldb, doublecomplex *work, doublereal *
+ resid)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+
+ /* Local variables */
+ integer j, jj, ix;
+ doublereal eps, err;
+ extern logical lsame_(char *, char *);
+ doublereal xscal, tnorm, xnorm;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), ztpmv_(
+ char *, char *, char *, integer *, doublecomplex *, doublecomplex
+ *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ doublereal smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTPT03 computes the residual for the solution to a scaled triangular */
+/* system of equations A*x = s*b, A**T *x = s*b, or A**H *x = s*b, */
+/* when the triangular matrix A is stored in packed format. Here A**T */
+/* denotes the transpose of A, A**H denotes the conjugate transpose of */
+/* A, s is a scalar, and x and b are N by NRHS matrices. The test ratio */
+/* is the maximum over the number of right hand sides of */
+/* norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A, A**T, or A**H, and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = s*b (No transpose) */
+/* = 'T': A**T *x = s*b (Transpose) */
+/* = 'C': A**H *x = s*b (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
+
+/* SCALE (input) DOUBLE PRECISION */
+/* The scaling factor s used in solving the triangular system. */
+
+/* CNORM (input) DOUBLE PRECISION array, dimension (N) */
+/* The 1-norms of the columns of A, not counting the diagonal. */
+
+/* TSCAL (input) DOUBLE PRECISION */
+/* The scaling factor used in computing the 1-norms in CNORM. */
+/* CNORM actually contains the column norms of TSCAL*A. */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0. */
+
+ /* Parameter adjustments */
+ --ap;
+ --cnorm;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+ eps = dlamch_("Epsilon");
+ smlnum = dlamch_("Safe minimum");
+
+/* Compute the norm of the triangular matrix A using the column */
+/* norms already computed by ZLATPS. */
+
+ tnorm = 0.;
+ if (lsame_(diag, "N")) {
+ if (lsame_(uplo, "U")) {
+ jj = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ d__1 = tnorm, d__2 = *tscal * z_abs(&ap[jj]) + cnorm[j];
+ tnorm = max(d__1,d__2);
+ jj += j;
+/* L10: */
+ }
+ } else {
+ jj = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ d__1 = tnorm, d__2 = *tscal * z_abs(&ap[jj]) + cnorm[j];
+ tnorm = max(d__1,d__2);
+ jj = jj + *n - j + 1;
+/* L20: */
+ }
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ d__1 = tnorm, d__2 = *tscal + cnorm[j];
+ tnorm = max(d__1,d__2);
+/* L30: */
+ }
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(A) * norm(x) * EPS ). */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = izamax_(n, &work[1], &c__1);
+/* Computing MAX */
+ d__1 = 1., d__2 = z_abs(&x[ix + j * x_dim1]);
+ xnorm = max(d__1,d__2);
+ xscal = 1. / xnorm / (doublereal) (*n);
+ zdscal_(n, &xscal, &work[1], &c__1);
+ ztpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1);
+ d__1 = -(*scale) * xscal;
+ z__1.r = d__1, z__1.i = 0.;
+ zaxpy_(n, &z__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = izamax_(n, &work[1], &c__1);
+ err = *tscal * z_abs(&work[ix]);
+ ix = izamax_(n, &x[j * x_dim1 + 1], &c__1);
+ xnorm = z_abs(&x[ix + j * x_dim1]);
+ if (err * smlnum <= xnorm) {
+ if (xnorm > 0.) {
+ err /= xnorm;
+ }
+ } else {
+ if (err > 0.) {
+ err = 1. / eps;
+ }
+ }
+ if (err * smlnum <= tnorm) {
+ if (tnorm > 0.) {
+ err /= tnorm;
+ }
+ } else {
+ if (err > 0.) {
+ err = 1. / eps;
+ }
+ }
+ *resid = max(*resid,err);
+/* L40: */
+ }
+
+ return 0;
+
+/* End of ZTPT03 */
+
+} /* ztpt03_ */
diff --git a/TESTING/LIN/ztpt05.c b/TESTING/LIN/ztpt05.c
new file mode 100644
index 0000000..3a739ca
--- /dev/null
+++ b/TESTING/LIN/ztpt05.c
@@ -0,0 +1,356 @@
+/* ztpt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ztpt05_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublecomplex *ap, doublecomplex *b, integer *ldb,
+ doublecomplex *x, integer *ldx, doublecomplex *xact, integer *ldxact,
+ doublereal *ferr, doublereal *berr, doublereal *reslts)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1,
+ i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, jc, ifu;
+ doublereal eps, tmp, diff, axbi;
+ integer imax;
+ doublereal unfl, ovfl;
+ logical unit;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ doublereal xnorm;
+ extern doublereal dlamch_(char *);
+ doublereal errbnd;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTPT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* triangular matrix in packed storage format. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A'* X = B (Transpose) */
+/* = 'C': A'* X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* If DIAG = 'U', the diagonal elements of A are not referenced */
+/* and are assumed to be 1. */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ --ap;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.;
+ reslts[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ unit = lsame_(diag, "U");
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = izamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__2 = imax + j * x_dim1;
+ d__3 = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[imax + j *
+ x_dim1]), abs(d__2));
+ xnorm = max(d__3,unfl);
+ diff = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * xact_dim1;
+ z__2.r = x[i__3].r - xact[i__4].r, z__2.i = x[i__3].i - xact[i__4]
+ .i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+/* Computing MAX */
+ d__3 = diff, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
+ z__1), abs(d__2));
+ diff = max(d__3,d__4);
+/* L10: */
+ }
+
+ if (xnorm > 1.) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1. / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
+ errbnd = max(d__1,d__2);
+ } else {
+ errbnd = 1. / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ ifu = 0;
+ if (unit) {
+ ifu = 1;
+ }
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ tmp = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__ + k *
+ b_dim1]), abs(d__2));
+ if (upper) {
+ jc = (i__ - 1) * i__ / 2;
+ if (! notran) {
+ i__3 = i__ - ifu;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = jc + j;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&ap[jc + j]), abs(d__2))) * ((d__3 = x[
+ i__5].r, abs(d__3)) + (d__4 = d_imag(&x[j + k
+ * x_dim1]), abs(d__4)));
+/* L40: */
+ }
+ if (unit) {
+ i__3 = i__ + k * x_dim1;
+ tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
+ &x[i__ + k * x_dim1]), abs(d__2));
+ }
+ } else {
+ jc += i__;
+ if (unit) {
+ i__3 = i__ + k * x_dim1;
+ tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
+ &x[i__ + k * x_dim1]), abs(d__2));
+ jc += i__;
+ }
+ i__3 = *n;
+ for (j = i__ + ifu; j <= i__3; ++j) {
+ i__4 = jc;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&ap[jc]), abs(d__2))) * ((d__3 = x[
+ i__5].r, abs(d__3)) + (d__4 = d_imag(&x[j + k
+ * x_dim1]), abs(d__4)));
+ jc += j;
+/* L50: */
+ }
+ }
+ } else {
+ if (notran) {
+ jc = i__;
+ i__3 = i__ - ifu;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = jc;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&ap[jc]), abs(d__2))) * ((d__3 = x[
+ i__5].r, abs(d__3)) + (d__4 = d_imag(&x[j + k
+ * x_dim1]), abs(d__4)));
+ jc = jc + *n - j;
+/* L60: */
+ }
+ if (unit) {
+ i__3 = i__ + k * x_dim1;
+ tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
+ &x[i__ + k * x_dim1]), abs(d__2));
+ }
+ } else {
+ jc = (i__ - 1) * (*n - i__) + i__ * (i__ + 1) / 2;
+ if (unit) {
+ i__3 = i__ + k * x_dim1;
+ tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
+ &x[i__ + k * x_dim1]), abs(d__2));
+ }
+ i__3 = *n;
+ for (j = i__ + ifu; j <= i__3; ++j) {
+ i__4 = jc + j - i__;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&ap[jc + j - i__]), abs(d__2))) * ((
+ d__3 = x[i__5].r, abs(d__3)) + (d__4 = d_imag(
+ &x[j + k * x_dim1]), abs(d__4)));
+/* L70: */
+ }
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = min(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ d__1 = axbi, d__2 = (*n + 1) * unfl;
+ tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / max(d__1,d__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = max(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of ZTPT05 */
+
+} /* ztpt05_ */
diff --git a/TESTING/LIN/ztpt06.c b/TESTING/LIN/ztpt06.c
new file mode 100644
index 0000000..8aa0af1
--- /dev/null
+++ b/TESTING/LIN/ztpt06.c
@@ -0,0 +1,150 @@
+/* ztpt06.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ztpt06_(doublereal *rcond, doublereal *rcondc, char *
+ uplo, char *diag, integer *n, doublecomplex *ap, doublereal *rwork,
+ doublereal *rat)
+{
+ /* System generated locals */
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ doublereal eps, rmin, rmax, anorm;
+ extern doublereal dlamch_(char *);
+ doublereal bignum;
+ extern doublereal zlantp_(char *, char *, char *, integer *,
+ doublecomplex *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTPT06 computes a test ratio comparing RCOND (the reciprocal */
+/* condition number of the triangular matrix A) and RCONDC, the estimate */
+/* computed by ZTPCON. Information about the triangular matrix is used */
+/* if one estimate is zero and the other is non-zero to decide if */
+/* underflow in the estimate is justified. */
+
+/* Arguments */
+/* ========= */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number obtained by */
+/* forming the explicit inverse of the matrix A and computing */
+/* RCOND = 1/( norm(A) * norm(inv(A)) ). */
+
+/* RCONDC (input) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number computed by */
+/* ZTPCON. */
+
+/* UPLO (input) CHARACTER */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
+/* The upper or lower triangular matrix A, packed columnwise in */
+/* a linear array. The j-th column of A is stored in the array */
+/* AP as follows: */
+/* if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
+/* if UPLO = 'L', */
+/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RAT (output) DOUBLE PRECISION */
+/* The test ratio. If both RCOND and RCONDC are nonzero, */
+/* RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1. */
+/* If RAT = 0, the two estimates are exactly the same. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ --rwork;
+ --ap;
+
+ /* Function Body */
+ eps = dlamch_("Epsilon");
+ rmax = max(*rcond,*rcondc);
+ rmin = min(*rcond,*rcondc);
+
+/* Do the easy cases first. */
+
+ if (rmin < 0.) {
+
+/* Invalid value for RCOND or RCONDC, return 1/EPS. */
+
+ *rat = 1. / eps;
+
+ } else if (rmin > 0.) {
+
+/* Both estimates are positive, return RMAX/RMIN - 1. */
+
+ *rat = rmax / rmin - 1.;
+
+ } else if (rmax == 0.) {
+
+/* Both estimates zero. */
+
+ *rat = 0.;
+
+ } else {
+
+/* One estimate is zero, the other is non-zero. If the matrix is */
+/* ill-conditioned, return the nonzero estimate multiplied by */
+/* 1/EPS; if the matrix is badly scaled, return the nonzero */
+/* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum */
+/* element in absolute value in A. */
+
+ bignum = 1. / dlamch_("Safe minimum");
+ anorm = zlantp_("M", uplo, diag, n, &ap[1], &rwork[1]);
+
+/* Computing MIN */
+ d__1 = bignum / max(1.,anorm), d__2 = 1. / eps;
+ *rat = rmax * min(d__1,d__2);
+ }
+
+ return 0;
+
+/* End of ZTPT06 */
+
+} /* ztpt06_ */
diff --git a/TESTING/LIN/ztrt01.c b/TESTING/LIN/ztrt01.c
new file mode 100644
index 0000000..4dff88a
--- /dev/null
+++ b/TESTING/LIN/ztrt01.c
@@ -0,0 +1,201 @@
+/* ztrt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ztrt01_(char *uplo, char *diag, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *ainv, integer *ldainv,
+ doublereal *rcond, doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, ainv_dim1, ainv_offset, i__1, i__2, i__3;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer j;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ doublereal anorm;
+ extern /* Subroutine */ int ztrmv_(char *, char *, char *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ doublereal ainvnm;
+ extern doublereal zlantr_(char *, char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTRT01 computes the residual for a triangular matrix A times its */
+/* inverse: */
+/* RESID = norm( A*AINV - I ) / ( N * norm(A) * norm(AINV) * EPS ), */
+/* where EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========== */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* AINV (input) COMPLEX*16 array, dimension (LDAINV,N) */
+/* On entry, the (triangular) inverse of the matrix A, in the */
+/* same storage format as A. */
+/* On exit, the contents of AINV are destroyed. */
+
+/* LDAINV (input) INTEGER */
+/* The leading dimension of the array AINV. LDAINV >= max(1,N). */
+
+/* RCOND (output) DOUBLE PRECISION */
+/* The reciprocal condition number of A, computed as */
+/* 1/(norm(A) * norm(AINV)). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ ainv_dim1 = *ldainv;
+ ainv_offset = 1 + ainv_dim1;
+ ainv -= ainv_offset;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0) {
+ *rcond = 1.;
+ *resid = 0.;
+ return 0;
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
+
+ eps = dlamch_("Epsilon");
+ anorm = zlantr_("1", uplo, diag, n, n, &a[a_offset], lda, &rwork[1]);
+ ainvnm = zlantr_("1", uplo, diag, n, n, &ainv[ainv_offset], ldainv, &
+ rwork[1]);
+ if (anorm <= 0. || ainvnm <= 0.) {
+ *rcond = 0.;
+ *resid = 1. / eps;
+ return 0;
+ }
+ *rcond = 1. / anorm / ainvnm;
+
+/* Set the diagonal of AINV to 1 if AINV has unit diagonal. */
+
+ if (lsame_(diag, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * ainv_dim1;
+ ainv[i__2].r = 1., ainv[i__2].i = 0.;
+/* L10: */
+ }
+ }
+
+/* Compute A * AINV, overwriting AINV. */
+
+ if (lsame_(uplo, "U")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ ztrmv_("Upper", "No transpose", diag, &j, &a[a_offset], lda, &
+ ainv[j * ainv_dim1 + 1], &c__1);
+/* L20: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n - j + 1;
+ ztrmv_("Lower", "No transpose", diag, &i__2, &a[j + j * a_dim1],
+ lda, &ainv[j + j * ainv_dim1], &c__1);
+/* L30: */
+ }
+ }
+
+/* Subtract 1 from each diagonal element to form A*AINV - I. */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + j * ainv_dim1;
+ i__3 = j + j * ainv_dim1;
+ z__1.r = ainv[i__3].r - 1., z__1.i = ainv[i__3].i;
+ ainv[i__2].r = z__1.r, ainv[i__2].i = z__1.i;
+/* L40: */
+ }
+
+/* Compute norm(A*AINV - I) / (N * norm(A) * norm(AINV) * EPS) */
+
+ *resid = zlantr_("1", uplo, "Non-unit", n, n, &ainv[ainv_offset], ldainv,
+ &rwork[1]);
+
+ *resid = *resid * *rcond / (doublereal) (*n) / eps;
+
+ return 0;
+
+/* End of ZTRT01 */
+
+} /* ztrt01_ */
diff --git a/TESTING/LIN/ztrt02.c b/TESTING/LIN/ztrt02.c
new file mode 100644
index 0000000..1484491
--- /dev/null
+++ b/TESTING/LIN/ztrt02.c
@@ -0,0 +1,203 @@
+/* ztrt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublecomplex c_b12 = {-1.,0.};
+
+/* Subroutine */ int ztrt02_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *x,
+ integer *ldx, doublecomplex *b, integer *ldb, doublecomplex *work,
+ doublereal *rwork, doublereal *resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ integer j;
+ doublereal eps;
+ extern logical lsame_(char *, char *);
+ doublereal anorm, bnorm, xnorm;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), ztrmv_(
+ char *, char *, char *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *), dzasum_(integer *,
+ doublecomplex *, integer *), zlantr_(char *, char *, char *,
+ integer *, integer *, doublecomplex *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTRT02 computes the residual for the computed solution to a */
+/* triangular system of linear equations A*x = b, A**T *x = b, */
+/* or A**H *x = b. Here A is a triangular matrix, A**T is the transpose */
+/* of A, A**H is the conjugate transpose of A, and x and b are N by NRHS */
+/* matrices. The test ratio is the maximum over the number of right */
+/* hand sides of */
+/* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A, A**T, or A**H, and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = b (No transpose) */
+/* = 'T': A**T *x = b (Transpose) */
+/* = 'C': A**H *x = b (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+ --rwork;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+
+/* Compute the 1-norm of A or A**H. */
+
+ if (lsame_(trans, "N")) {
+ anorm = zlantr_("1", uplo, diag, n, n, &a[a_offset], lda, &rwork[1]);
+ } else {
+ anorm = zlantr_("I", uplo, diag, n, n, &a[a_offset], lda, &rwork[1]);
+ }
+
+/* Exit with RESID = 1/EPS if ANORM = 0. */
+
+ eps = dlamch_("Epsilon");
+ if (anorm <= 0.) {
+ *resid = 1. / eps;
+ return 0;
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ) */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ztrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
+ zaxpy_(n, &c_b12, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ bnorm = dzasum_(n, &work[1], &c__1);
+ xnorm = dzasum_(n, &x[j * x_dim1 + 1], &c__1);
+ if (xnorm <= 0.) {
+ *resid = 1. / eps;
+ } else {
+/* Computing MAX */
+ d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
+ *resid = max(d__1,d__2);
+ }
+/* L10: */
+ }
+
+ return 0;
+
+/* End of ZTRT02 */
+
+} /* ztrt02_ */
diff --git a/TESTING/LIN/ztrt03.c b/TESTING/LIN/ztrt03.c
new file mode 100644
index 0000000..72261c6
--- /dev/null
+++ b/TESTING/LIN/ztrt03.c
@@ -0,0 +1,248 @@
+/* ztrt03.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ztrt03_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublecomplex *a, integer *lda, doublereal *scale,
+ doublereal *cnorm, doublereal *tscal, doublecomplex *x, integer *ldx,
+ doublecomplex *b, integer *ldb, doublecomplex *work, doublereal *
+ resid)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
+ doublereal d__1, d__2;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+
+ /* Local variables */
+ integer j, ix;
+ doublereal eps, err;
+ extern logical lsame_(char *, char *);
+ doublereal xscal, tnorm, xnorm;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *), ztrmv_(
+ char *, char *, char *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ doublereal smlnum;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTRT03 computes the residual for the solution to a scaled triangular */
+/* system of equations A*x = s*b, A**T *x = s*b, or A**H *x = s*b. */
+/* Here A is a triangular matrix, A**T denotes the transpose of A, A**H */
+/* denotes the conjugate transpose of A, s is a scalar, and x and b are */
+/* N by NRHS matrices. The test ratio is the maximum over the number of */
+/* right hand sides of */
+/* norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
+/* where op(A) denotes A, A**T, or A**H, and EPS is the machine epsilon. */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the operation applied to A. */
+/* = 'N': A *x = s*b (No transpose) */
+/* = 'T': A**T *x = s*b (Transpose) */
+/* = 'C': A**H *x = s*b (Conjugate transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of right hand sides, i.e., the number of columns */
+/* of the matrices X and B. NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* SCALE (input) DOUBLE PRECISION */
+/* The scaling factor s used in solving the triangular system. */
+
+/* CNORM (input) DOUBLE PRECISION array, dimension (N) */
+/* The 1-norms of the columns of A, not counting the diagonal. */
+
+/* TSCAL (input) DOUBLE PRECISION */
+/* The scaling factor used in computing the 1-norms in CNORM. */
+/* CNORM actually contains the column norms of TSCAL*A. */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors for the system of linear */
+/* equations. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (N) */
+
+/* RESID (output) DOUBLE PRECISION */
+/* The maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --cnorm;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --work;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ *resid = 0.;
+ return 0;
+ }
+ eps = dlamch_("Epsilon");
+ smlnum = dlamch_("Safe minimum");
+
+/* Compute the norm of the triangular matrix A using the column */
+/* norms already computed by ZLATRS. */
+
+ tnorm = 0.;
+ if (lsame_(diag, "N")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ d__1 = tnorm, d__2 = *tscal * z_abs(&a[j + j * a_dim1]) + cnorm[j]
+ ;
+ tnorm = max(d__1,d__2);
+/* L10: */
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+ d__1 = tnorm, d__2 = *tscal + cnorm[j];
+ tnorm = max(d__1,d__2);
+/* L20: */
+ }
+ }
+
+/* Compute the maximum over the number of right hand sides of */
+/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
+
+ *resid = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ zcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = izamax_(n, &work[1], &c__1);
+/* Computing MAX */
+ d__1 = 1., d__2 = z_abs(&x[ix + j * x_dim1]);
+ xnorm = max(d__1,d__2);
+ xscal = 1. / xnorm / (doublereal) (*n);
+ zdscal_(n, &xscal, &work[1], &c__1);
+ ztrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
+ d__1 = -(*scale) * xscal;
+ z__1.r = d__1, z__1.i = 0.;
+ zaxpy_(n, &z__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
+ ix = izamax_(n, &work[1], &c__1);
+ err = *tscal * z_abs(&work[ix]);
+ ix = izamax_(n, &x[j * x_dim1 + 1], &c__1);
+ xnorm = z_abs(&x[ix + j * x_dim1]);
+ if (err * smlnum <= xnorm) {
+ if (xnorm > 0.) {
+ err /= xnorm;
+ }
+ } else {
+ if (err > 0.) {
+ err = 1. / eps;
+ }
+ }
+ if (err * smlnum <= tnorm) {
+ if (tnorm > 0.) {
+ err /= tnorm;
+ }
+ } else {
+ if (err > 0.) {
+ err = 1. / eps;
+ }
+ }
+ *resid = max(*resid,err);
+/* L30: */
+ }
+
+ return 0;
+
+/* End of ZTRT03 */
+
+} /* ztrt03_ */
diff --git a/TESTING/LIN/ztrt05.c b/TESTING/LIN/ztrt05.c
new file mode 100644
index 0000000..b7f236b
--- /dev/null
+++ b/TESTING/LIN/ztrt05.c
@@ -0,0 +1,356 @@
+/* ztrt05.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int ztrt05_(char *uplo, char *trans, char *diag, integer *n,
+ integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b,
+ integer *ldb, doublecomplex *x, integer *ldx, doublecomplex *xact,
+ integer *ldxact, doublereal *ferr, doublereal *berr, doublereal *
+ reslts)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
+ xact_offset, i__1, i__2, i__3, i__4, i__5;
+ doublereal d__1, d__2, d__3, d__4;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double d_imag(doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, ifu;
+ doublereal eps, tmp, diff, axbi;
+ integer imax;
+ doublereal unfl, ovfl;
+ logical unit;
+ extern logical lsame_(char *, char *);
+ logical upper;
+ doublereal xnorm;
+ extern doublereal dlamch_(char *);
+ doublereal errbnd;
+ extern integer izamax_(integer *, doublecomplex *, integer *);
+ logical notran;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTRT05 tests the error bounds from iterative refinement for the */
+/* computed solution to a system of equations A*X = B, where A is a */
+/* triangular n by n matrix. */
+
+/* RESLTS(1) = test of the error bound */
+/* = norm(X - XACT) / ( norm(X) * FERR ) */
+
+/* A large value is returned if this ratio is not less than one. */
+
+/* RESLTS(2) = residual from the iterative refinement routine */
+/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+/* Arguments */
+/* ========= */
+
+/* UPLO (input) CHARACTER*1 */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* TRANS (input) CHARACTER*1 */
+/* Specifies the form of the system of equations. */
+/* = 'N': A * X = B (No transpose) */
+/* = 'T': A'* X = B (Transpose) */
+/* = 'C': A'* X = B (Conjugate transpose = Transpose) */
+
+/* DIAG (input) CHARACTER*1 */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The number of rows of the matrices X, B, and XACT, and the */
+/* order of the matrix A. N >= 0. */
+
+/* NRHS (input) INTEGER */
+/* The number of columns of the matrices X, B, and XACT. */
+/* NRHS >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
+/* The right hand side vectors for the system of linear */
+/* equations. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= max(1,N). */
+
+/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The computed solution vectors. Each vector is stored as a */
+/* column of the matrix X. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= max(1,N). */
+
+/* XACT (input) COMPLEX*16 array, dimension (LDX,NRHS) */
+/* The exact solution vectors. Each vector is stored as a */
+/* column of the matrix XACT. */
+
+/* LDXACT (input) INTEGER */
+/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
+
+/* FERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The estimated forward error bounds for each solution vector */
+/* X. If XTRUE is the true solution, FERR bounds the magnitude */
+/* of the largest entry in (X - XTRUE) divided by the magnitude */
+/* of the largest entry in X. */
+
+/* BERR (input) DOUBLE PRECISION array, dimension (NRHS) */
+/* The componentwise relative backward error of each solution */
+/* vector (i.e., the smallest relative change in any entry of A */
+/* or B that makes X an exact solution). */
+
+/* RESLTS (output) DOUBLE PRECISION array, dimension (2) */
+/* The maximum over the NRHS solution vectors of the ratios: */
+/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
+/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Statement Functions .. */
+/* .. */
+/* .. Statement Function definitions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Quick exit if N = 0 or NRHS = 0. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ xact_dim1 = *ldxact;
+ xact_offset = 1 + xact_dim1;
+ xact -= xact_offset;
+ --ferr;
+ --berr;
+ --reslts;
+
+ /* Function Body */
+ if (*n <= 0 || *nrhs <= 0) {
+ reslts[1] = 0.;
+ reslts[2] = 0.;
+ return 0;
+ }
+
+ eps = dlamch_("Epsilon");
+ unfl = dlamch_("Safe minimum");
+ ovfl = 1. / unfl;
+ upper = lsame_(uplo, "U");
+ notran = lsame_(trans, "N");
+ unit = lsame_(diag, "U");
+
+/* Test 1: Compute the maximum of */
+/* norm(X - XACT) / ( norm(X) * FERR ) */
+/* over all the vectors X and XACT using the infinity-norm. */
+
+ errbnd = 0.;
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ imax = izamax_(n, &x[j * x_dim1 + 1], &c__1);
+/* Computing MAX */
+ i__2 = imax + j * x_dim1;
+ d__3 = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[imax + j *
+ x_dim1]), abs(d__2));
+ xnorm = max(d__3,unfl);
+ diff = 0.;
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = i__ + j * xact_dim1;
+ z__2.r = x[i__3].r - xact[i__4].r, z__2.i = x[i__3].i - xact[i__4]
+ .i;
+ z__1.r = z__2.r, z__1.i = z__2.i;
+/* Computing MAX */
+ d__3 = diff, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
+ z__1), abs(d__2));
+ diff = max(d__3,d__4);
+/* L10: */
+ }
+
+ if (xnorm > 1.) {
+ goto L20;
+ } else if (diff <= ovfl * xnorm) {
+ goto L20;
+ } else {
+ errbnd = 1. / eps;
+ goto L30;
+ }
+
+L20:
+ if (diff / xnorm <= ferr[j]) {
+/* Computing MAX */
+ d__1 = errbnd, d__2 = diff / xnorm / ferr[j];
+ errbnd = max(d__1,d__2);
+ } else {
+ errbnd = 1. / eps;
+ }
+L30:
+ ;
+ }
+ reslts[1] = errbnd;
+
+/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
+/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
+
+ ifu = 0;
+ if (unit) {
+ ifu = 1;
+ }
+ i__1 = *nrhs;
+ for (k = 1; k <= i__1; ++k) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + k * b_dim1;
+ tmp = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__ + k *
+ b_dim1]), abs(d__2));
+ if (upper) {
+ if (! notran) {
+ i__3 = i__ - ifu;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = j + i__ * a_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&a[j + i__ * a_dim1]), abs(d__2))) * ((
+ d__3 = x[i__5].r, abs(d__3)) + (d__4 = d_imag(
+ &x[j + k * x_dim1]), abs(d__4)));
+/* L40: */
+ }
+ if (unit) {
+ i__3 = i__ + k * x_dim1;
+ tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
+ &x[i__ + k * x_dim1]), abs(d__2));
+ }
+ } else {
+ if (unit) {
+ i__3 = i__ + k * x_dim1;
+ tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
+ &x[i__ + k * x_dim1]), abs(d__2));
+ }
+ i__3 = *n;
+ for (j = i__ + ifu; j <= i__3; ++j) {
+ i__4 = i__ + j * a_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2))) * ((
+ d__3 = x[i__5].r, abs(d__3)) + (d__4 = d_imag(
+ &x[j + k * x_dim1]), abs(d__4)));
+/* L50: */
+ }
+ }
+ } else {
+ if (notran) {
+ i__3 = i__ - ifu;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = i__ + j * a_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&a[i__ + j * a_dim1]), abs(d__2))) * ((
+ d__3 = x[i__5].r, abs(d__3)) + (d__4 = d_imag(
+ &x[j + k * x_dim1]), abs(d__4)));
+/* L60: */
+ }
+ if (unit) {
+ i__3 = i__ + k * x_dim1;
+ tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
+ &x[i__ + k * x_dim1]), abs(d__2));
+ }
+ } else {
+ if (unit) {
+ i__3 = i__ + k * x_dim1;
+ tmp += (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(
+ &x[i__ + k * x_dim1]), abs(d__2));
+ }
+ i__3 = *n;
+ for (j = i__ + ifu; j <= i__3; ++j) {
+ i__4 = j + i__ * a_dim1;
+ i__5 = j + k * x_dim1;
+ tmp += ((d__1 = a[i__4].r, abs(d__1)) + (d__2 =
+ d_imag(&a[j + i__ * a_dim1]), abs(d__2))) * ((
+ d__3 = x[i__5].r, abs(d__3)) + (d__4 = d_imag(
+ &x[j + k * x_dim1]), abs(d__4)));
+/* L70: */
+ }
+ }
+ }
+ if (i__ == 1) {
+ axbi = tmp;
+ } else {
+ axbi = min(axbi,tmp);
+ }
+/* L80: */
+ }
+/* Computing MAX */
+ d__1 = axbi, d__2 = (*n + 1) * unfl;
+ tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / max(d__1,d__2));
+ if (k == 1) {
+ reslts[2] = tmp;
+ } else {
+ reslts[2] = max(reslts[2],tmp);
+ }
+/* L90: */
+ }
+
+ return 0;
+
+/* End of ZTRT05 */
+
+} /* ztrt05_ */
diff --git a/TESTING/LIN/ztrt06.c b/TESTING/LIN/ztrt06.c
new file mode 100644
index 0000000..f644161
--- /dev/null
+++ b/TESTING/LIN/ztrt06.c
@@ -0,0 +1,158 @@
+/* ztrt06.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int ztrt06_(doublereal *rcond, doublereal *rcondc, char *
+ uplo, char *diag, integer *n, doublecomplex *a, integer *lda,
+ doublereal *rwork, doublereal *rat)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset;
+ doublereal d__1, d__2;
+
+ /* Local variables */
+ doublereal eps, rmin, rmax, anorm;
+ extern doublereal dlamch_(char *);
+ doublereal bignum;
+ extern doublereal zlantr_(char *, char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTRT06 computes a test ratio comparing RCOND (the reciprocal */
+/* condition number of a triangular matrix A) and RCONDC, the estimate */
+/* computed by ZTRCON. Information about the triangular matrix A is */
+/* used if one estimate is zero and the other is non-zero to decide if */
+/* underflow in the estimate is justified. */
+
+/* Arguments */
+/* ========= */
+
+/* RCOND (input) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number obtained by */
+/* forming the explicit inverse of the matrix A and computing */
+/* RCOND = 1/( norm(A) * norm(inv(A)) ). */
+
+/* RCONDC (input) DOUBLE PRECISION */
+/* The estimate of the reciprocal condition number computed by */
+/* ZTRCON. */
+
+/* UPLO (input) CHARACTER */
+/* Specifies whether the matrix A is upper or lower triangular. */
+/* = 'U': Upper triangular */
+/* = 'L': Lower triangular */
+
+/* DIAG (input) CHARACTER */
+/* Specifies whether or not the matrix A is unit triangular. */
+/* = 'N': Non-unit triangular */
+/* = 'U': Unit triangular */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The triangular matrix A. If UPLO = 'U', the leading n by n */
+/* upper triangular part of the array A contains the upper */
+/* triangular matrix, and the strictly lower triangular part of */
+/* A is not referenced. If UPLO = 'L', the leading n by n lower */
+/* triangular part of the array A contains the lower triangular */
+/* matrix, and the strictly upper triangular part of A is not */
+/* referenced. If DIAG = 'U', the diagonal elements of A are */
+/* also not referenced and are assumed to be 1. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,N). */
+
+/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/* RAT (output) DOUBLE PRECISION */
+/* The test ratio. If both RCOND and RCONDC are nonzero, */
+/* RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1. */
+/* If RAT = 0, the two estimates are exactly the same. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --rwork;
+
+ /* Function Body */
+ eps = dlamch_("Epsilon");
+ rmax = max(*rcond,*rcondc);
+ rmin = min(*rcond,*rcondc);
+
+/* Do the easy cases first. */
+
+ if (rmin < 0.) {
+
+/* Invalid value for RCOND or RCONDC, return 1/EPS. */
+
+ *rat = 1. / eps;
+
+ } else if (rmin > 0.) {
+
+/* Both estimates are positive, return RMAX/RMIN - 1. */
+
+ *rat = rmax / rmin - 1.;
+
+ } else if (rmax == 0.) {
+
+/* Both estimates zero. */
+
+ *rat = 0.;
+
+ } else {
+
+/* One estimate is zero, the other is non-zero. If the matrix is */
+/* ill-conditioned, return the nonzero estimate multiplied by */
+/* 1/EPS; if the matrix is badly scaled, return the nonzero */
+/* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum */
+/* element in absolute value in A. */
+
+ bignum = 1. / dlamch_("Safe minimum");
+ anorm = zlantr_("M", uplo, diag, n, n, &a[a_offset], lda, &rwork[1]);
+
+/* Computing MIN */
+ d__1 = bignum / max(1.,anorm), d__2 = 1. / eps;
+ *rat = rmax * min(d__1,d__2);
+ }
+
+ return 0;
+
+/* End of ZTRT06 */
+
+} /* ztrt06_ */
diff --git a/TESTING/LIN/ztzt01.c b/TESTING/LIN/ztzt01.c
new file mode 100644
index 0000000..a501dc1
--- /dev/null
+++ b/TESTING/LIN/ztzt01.c
@@ -0,0 +1,178 @@
+/* ztzt01.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__8 = 8;
+static doublecomplex c_b6 = {0.,0.};
+static integer c__1 = 1;
+static doublecomplex c_b15 = {-1.,0.};
+
+doublereal ztzt01_(integer *m, integer *n, doublecomplex *a, doublecomplex *
+ af, integer *lda, doublecomplex *tau, doublecomplex *work, integer *
+ lwork)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4;
+ doublereal ret_val;
+
+ /* Local variables */
+ integer i__, j;
+ doublereal norma, rwork[1];
+ extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatzm_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTZT01 returns */
+/* || A - R*Q || / ( M * eps * ||A|| ) */
+/* for an upper trapezoidal A that was factored with ZTZRQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrices A and AF. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrices A and AF. */
+
+/* A (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The original upper trapezoidal M by N matrix A. */
+
+/* AF (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The output of ZTZRQF for input matrix A. */
+/* The lower triangle is not referenced. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the arrays A and AF. */
+
+/* TAU (input) COMPLEX*16 array, dimension (M) */
+/* Details of the Householder transformations as returned by */
+/* ZTZRQF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* The length of the array WORK. LWORK >= m*n + m. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ if (*lwork < *m * *n + *m) {
+ xerbla_("ZTZT01", &c__8);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return ret_val;
+ }
+
+ norma = zlange_("One-norm", m, n, &a[a_offset], lda, rwork);
+
+/* Copy upper triangle R */
+
+ zlaset_("Full", m, n, &c_b6, &c_b6, &work[1], m);
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = (j - 1) * *m + i__;
+ i__4 = i__ + j * af_dim1;
+ work[i__3].r = af[i__4].r, work[i__3].i = af[i__4].i;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* R = R * P(1) * ... *P(m) */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n - *m + 1;
+ zlatzm_("Right", &i__, &i__2, &af[i__ + (*m + 1) * af_dim1], lda, &
+ tau[i__], &work[(i__ - 1) * *m + 1], &work[*m * *m + 1], m, &
+ work[*m * *n + 1]);
+/* L30: */
+ }
+
+/* R = R - A */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ zaxpy_(m, &c_b15, &a[i__ * a_dim1 + 1], &c__1, &work[(i__ - 1) * *m +
+ 1], &c__1);
+/* L40: */
+ }
+
+ ret_val = zlange_("One-norm", m, n, &work[1], m, rwork);
+
+ ret_val /= dlamch_("Epsilon") * (doublereal) max(*m,*n);
+ if (norma != 0.) {
+ ret_val /= norma;
+ }
+
+ return ret_val;
+
+/* End of ZTZT01 */
+
+} /* ztzt01_ */
diff --git a/TESTING/LIN/ztzt02.c b/TESTING/LIN/ztzt02.c
new file mode 100644
index 0000000..75803e7
--- /dev/null
+++ b/TESTING/LIN/ztzt02.c
@@ -0,0 +1,165 @@
+/* ztzt02.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__7 = 7;
+static doublecomplex c_b5 = {0.,0.};
+static doublecomplex c_b6 = {1.,0.};
+
+doublereal ztzt02_(integer *m, integer *n, doublecomplex *af, integer *lda,
+ doublecomplex *tau, doublecomplex *work, integer *lwork)
+{
+ /* System generated locals */
+ integer af_dim1, af_offset, i__1, i__2, i__3;
+ doublereal ret_val;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__;
+ doublereal rwork[1];
+ extern doublereal dlamch_(char *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatzm_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZTZT02 returns */
+/* || I - Q'*Q || / ( M * eps) */
+/* where the matrix Q is defined by the Householder transformations */
+/* generated by ZTZRQF. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix AF. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix AF. */
+
+/* AF (input) COMPLEX*16 array, dimension (LDA,N) */
+/* The output of ZTZRQF. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array AF. */
+
+/* TAU (input) COMPLEX*16 array, dimension (M) */
+/* Details of the Householder transformations as returned by */
+/* ZTZRQF. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
+
+/* LWORK (input) INTEGER */
+/* length of WORK array. Must be >= N*N+N */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ af_dim1 = *lda;
+ af_offset = 1 + af_dim1;
+ af -= af_offset;
+ --tau;
+ --work;
+
+ /* Function Body */
+ ret_val = 0.;
+
+ if (*lwork < *n * *n + *n) {
+ xerbla_("ZTZT02", &c__7);
+ return ret_val;
+ }
+
+/* Quick return if possible */
+
+ if (*m <= 0 || *n <= 0) {
+ return ret_val;
+ }
+
+/* Q := I */
+
+ zlaset_("Full", n, n, &c_b5, &c_b6, &work[1], n);
+
+/* Q := P(1) * ... * P(m) * Q */
+
+ for (i__ = *m; i__ >= 1; --i__) {
+ i__1 = *n - *m + 1;
+ zlatzm_("Left", &i__1, n, &af[i__ + (*m + 1) * af_dim1], lda, &tau[
+ i__], &work[i__], &work[*m + 1], n, &work[*n * *n + 1]);
+/* L10: */
+ }
+
+/* Q := P(m)' * ... * P(1)' * Q */
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n - *m + 1;
+ d_cnjg(&z__1, &tau[i__]);
+ zlatzm_("Left", &i__2, n, &af[i__ + (*m + 1) * af_dim1], lda, &z__1, &
+ work[i__], &work[*m + 1], n, &work[*n * *n + 1]);
+/* L20: */
+ }
+
+/* Q := Q - I */
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = (i__ - 1) * *n + i__;
+ i__3 = (i__ - 1) * *n + i__;
+ z__1.r = work[i__3].r - 1., z__1.i = work[i__3].i;
+ work[i__2].r = z__1.r, work[i__2].i = z__1.i;
+/* L30: */
+ }
+
+ ret_val = zlange_("One-norm", n, n, &work[1], n, rwork) / (
+ dlamch_("Epsilon") * (doublereal) max(*m,*n));
+ return ret_val;
+
+/* End of ZTZT02 */
+
+} /* ztzt02_ */
diff --git a/TESTING/MATGEN/CMakeLists.txt b/TESTING/MATGEN/CMakeLists.txt
new file mode 100644
index 0000000..b2cb47a
--- /dev/null
+++ b/TESTING/MATGEN/CMakeLists.txt
@@ -0,0 +1,69 @@
+#######################################################################
+# This is the makefile to create a library of the test matrix
+# generators used in LAPACK. The files are organized as follows:
+#
+# SCATGEN -- Auxiliary routines called from both REAL and COMPLEX
+# DZATGEN -- Auxiliary routines called from both DOUBLE PRECISION
+# and COMPLEX*16
+# SMATGEN -- Single precision real matrix generation routines
+# CMATGEN -- Single precision complex matrix generation routines
+# DMATGEN -- Double precision real matrix generation routines
+# ZMATGEN -- Double precision complex matrix generation routines
+#
+# The library can be set up to include routines for any combination
+# of the four precisions. To create or add to the library, enter make
+# followed by one or more of the precisions desired. Some examples:
+# make single
+# make single complex
+# make single double complex complex16
+# Alternatively, the command
+# make
+# without any arguments creates a library of all four precisions.
+# The library is called
+# tmglib.a
+# and is created at the LAPACK directory level.
+#
+# To remove the object files after the library is created, enter
+# make clean
+# On some systems, you can force the source files to be recompiled by
+# entering (for example)
+# make single FRC=FRC
+#
+#######################################################################
+
+set(SCATGEN slatm1.c slaran.c slarnd.c)
+
+set(SMATGEN slatms.c slatme.c slatmr.c slatmt.c
+ slagge.c slagsy.c slakf2.c slarge.c slaror.c slarot.c slatm2.c
+ slatm3.c slatm5.c slatm6.c slatm7.c slahilb.c)
+
+set(CMATGEN clatms.c clatme.c clatmr.c clatmt.c
+ clagge.c claghe.c clagsy.c clakf2.c clarge.c claror.c clarot.c
+ clatm1.c clarnd.c clatm2.c clatm3.c clatm5.c clatm6.c clahilb.c)
+
+set(DZATGEN dlatm1.c dlaran.c dlarnd.c)
+
+set(DMATGEN dlatms.c dlatme.c dlatmr.c dlatmt.c
+ dlagge.c dlagsy.c dlakf2.c dlarge.c dlaror.c dlarot.c dlatm2.c
+ dlatm3.c dlatm5.c dlatm6.c dlatm7.c dlahilb.c)
+
+set(ZMATGEN zlatms.c zlatme.c zlatmr.c zlatmt.c
+ zlagge.c zlaghe.c zlagsy.c zlakf2.c zlarge.c zlaror.c zlarot.c
+ zlatm1.c zlarnd.c zlatm2.c zlatm3.c zlatm5.c zlatm6.c zlahilb.c)
+
+set(ALLOBJ ${SMATGEN} ${CMATGEN} ${SCATGEN} ${DMATGEN} ${ZMATGEN}
+ ${DZATGEN})
+if(BUILD_SINGLE)
+ set(ALLOBJ $(SMATGEN) $(SCATGEN))
+endif()
+if(BUILD_DOUBLE)
+ set(ALLOBJ $(DMATGEN) $(DZATGEN))
+endif()
+if(BUILD_COMPLEX)
+ set(ALLOBJ $(CMATGEN) $(SCATGEN))
+endif()
+if(BUILD_COMPLEX16)
+ set(ALLOBJ $(ZMATGEN) $(DZATGEN))
+endif()
+add_library(tmglib ${ALLOBJ} )
+
diff --git a/TESTING/MATGEN/Makefile b/TESTING/MATGEN/Makefile
new file mode 100644
index 0000000..8db01de
--- /dev/null
+++ b/TESTING/MATGEN/Makefile
@@ -0,0 +1,99 @@
+include ../../make.inc
+
+#######################################################################
+# This is the makefile to create a library of the test matrix
+# generators used in LAPACK. The files are organized as follows:
+#
+# SCATGEN -- Auxiliary routines called from both REAL and COMPLEX
+# DZATGEN -- Auxiliary routines called from both DOUBLE PRECISION
+# and COMPLEX*16
+# SMATGEN -- Single precision real matrix generation routines
+# CMATGEN -- Single precision complex matrix generation routines
+# DMATGEN -- Double precision real matrix generation routines
+# ZMATGEN -- Double precision complex matrix generation routines
+#
+# The library can be set up to include routines for any combination
+# of the four precisions. To create or add to the library, enter make
+# followed by one or more of the precisions desired. Some examples:
+# make single
+# make single complex
+# make single double complex complex16
+# Alternatively, the command
+# make
+# without any arguments creates a library of all four precisions.
+# The library is called
+# tmglib.a
+# and is created at the LAPACK directory level.
+#
+# To remove the object files after the library is created, enter
+# make clean
+# On some systems, you can force the source files to be recompiled by
+# entering (for example)
+# make single FRC=FRC
+#
+#######################################################################
+
+SCATGEN = slatm1.o slaran.o slarnd.o
+
+SMATGEN = slatms.o slatme.o slatmr.o slatmt.o \
+ slagge.o slagsy.o slakf2.o slarge.o slaror.o slarot.o slatm2.o \
+ slatm3.o slatm5.o slatm6.o slatm7.o slahilb.o
+
+CMATGEN = clatms.o clatme.o clatmr.o clatmt.o \
+ clagge.o claghe.o clagsy.o clakf2.o clarge.o claror.o clarot.o \
+ clatm1.o clarnd.o clatm2.o clatm3.o clatm5.o clatm6.o clahilb.o
+
+DZATGEN = dlatm1.o dlaran.o dlarnd.o
+
+DMATGEN = dlatms.o dlatme.o dlatmr.o dlatmt.o \
+ dlagge.o dlagsy.o dlakf2.o dlarge.o dlaror.o dlarot.o dlatm2.o \
+ dlatm3.o dlatm5.o dlatm6.o dlatm7.o dlahilb.o
+
+ZMATGEN = zlatms.o zlatme.o zlatmr.o zlatmt.o \
+ zlagge.o zlaghe.o zlagsy.o zlakf2.o zlarge.o zlaror.o zlarot.o \
+ zlatm1.o zlarnd.o zlatm2.o zlatm3.o zlatm5.o zlatm6.o zlahilb.o
+
+all: ../../$(TMGLIB)
+
+ALLOBJ=$(SMATGEN) $(CMATGEN) $(SCATGEN) $(DMATGEN) $(ZMATGEN) \
+ $(DZATGEN)
+
+../../$(TMGLIB): $(SMATGEN) $(CMATGEN) $(SCATGEN) $(DMATGEN) \
+ $(ZMATGEN) $(DZATGEN)
+ $(ARCH) $(ARCHFLAGS) $@ $(ALLOBJ)
+ $(RANLIB) $@
+
+single: $(SMATGEN) $(SCATGEN)
+ $(ARCH) $(ARCHFLAGS) ../../$(TMGLIB) $(SMATGEN) $(SCATGEN)
+ $(RANLIB) ../../$(TMGLIB)
+
+complex: $(CMATGEN) $(SCATGEN)
+ $(ARCH) $(ARCHFLAGS) ../../$(TMGLIB) $(CMATGEN) $(SCATGEN)
+ $(RANLIB) ../../$(TMGLIB)
+
+double: $(DMATGEN) $(DZATGEN)
+ $(ARCH) $(ARCHFLAGS) ../../$(TMGLIB) $(DMATGEN) $(DZATGEN)
+ $(RANLIB) ../../$(TMGLIB)
+
+complex16: $(ZMATGEN) $(DZATGEN)
+ $(ARCH) $(ARCHFLAGS) ../../$(TMGLIB) $(ZMATGEN) $(DZATGEN)
+ $(RANLIB) ../../$(TMGLIB)
+
+$(SCATGEN): $(FRC)
+$(SMATGEN): $(FRC)
+$(CMATGEN): $(FRC)
+$(DZATGEN): $(FRC)
+$(DMATGEN): $(FRC)
+$(ZMATGEN): $(FRC)
+
+FRC:
+ @FRC=$(FRC)
+
+clean: ; \
+ rm -f *.o
+
+.c.o: ; $(CC) $(CFLAGS) -I../../INCLUDE -c $< -o $@
+
+slaran.o: slaran.c ; $(CC) $(NOOPT) -I../../INCLUDE -c $< -o $@
+dlaran.o: dlaran.c ; $(CC) $(NOOPT) -I../../INCLUDE -c $< -o $@
+
diff --git a/TESTING/MATGEN/clagge.c b/TESTING/MATGEN/clagge.c
new file mode 100644
index 0000000..ea9a021
--- /dev/null
+++ b/TESTING/MATGEN/clagge.c
@@ -0,0 +1,478 @@
+/* clagge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__3 = 3;
+static integer c__1 = 1;
+
+/* Subroutine */ int clagge_(integer *m, integer *n, integer *kl, integer *ku,
+ real *d__, complex *a, integer *lda, integer *iseed, complex *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1;
+ complex q__1;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer i__, j;
+ complex wa, wb;
+ real wn;
+ complex tau;
+ extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *),
+ cscal_(integer *, complex *, complex *, integer *), cgemv_(char *
+, integer *, integer *, complex *, complex *, integer *, complex *
+, integer *, complex *, complex *, integer *);
+ extern doublereal scnrm2_(integer *, complex *, integer *);
+ extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
+ xerbla_(char *, integer *), clarnv_(integer *, integer *,
+ integer *, complex *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAGGE generates a complex general m by n matrix A, by pre- and post- */
+/* multiplying a real diagonal matrix D with random unitary matrices: */
+/* A = U*D*V. The lower and upper bandwidths may then be reduced to */
+/* kl and ku by additional unitary transformations. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of nonzero subdiagonals within the band of A. */
+/* 0 <= KL <= M-1. */
+
+/* KU (input) INTEGER */
+/* The number of nonzero superdiagonals within the band of A. */
+/* 0 <= KU <= N-1. */
+
+/* D (input) REAL array, dimension (min(M,N)) */
+/* The diagonal elements of the diagonal matrix D. */
+
+/* A (output) COMPLEX array, dimension (LDA,N) */
+/* The generated m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* WORK (workspace) COMPLEX array, dimension (M+N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --d__;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iseed;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0 || *kl > *m - 1) {
+ *info = -3;
+ } else if (*ku < 0 || *ku > *n - 1) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -7;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("CLAGGE", &i__1);
+ return 0;
+ }
+
+/* initialize A to diagonal matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ i__1 = min(*m,*n);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ i__3 = i__;
+ a[i__2].r = d__[i__3], a[i__2].i = 0.f;
+/* L30: */
+ }
+
+/* pre- and post-multiply A by random unitary matrices */
+
+ for (i__ = min(*m,*n); i__ >= 1; --i__) {
+ if (i__ < *m) {
+
+/* generate random reflection */
+
+ i__1 = *m - i__ + 1;
+ clarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+ i__1 = *m - i__ + 1;
+ wn = scnrm2_(&i__1, &work[1], &c__1);
+ r__1 = wn / c_abs(&work[1]);
+ q__1.r = r__1 * work[1].r, q__1.i = r__1 * work[1].i;
+ wa.r = q__1.r, wa.i = q__1.i;
+ if (wn == 0.f) {
+ tau.r = 0.f, tau.i = 0.f;
+ } else {
+ q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i;
+ wb.r = q__1.r, wb.i = q__1.i;
+ i__1 = *m - i__;
+ c_div(&q__1, &c_b2, &wb);
+ cscal_(&i__1, &q__1, &work[2], &c__1);
+ work[1].r = 1.f, work[1].i = 0.f;
+ c_div(&q__1, &wb, &wa);
+ r__1 = q__1.r;
+ tau.r = r__1, tau.i = 0.f;
+ }
+
+/* multiply A(i:m,i:n) by random reflection from the left */
+
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__ + 1;
+ cgemv_("Conjugate transpose", &i__1, &i__2, &c_b2, &a[i__ + i__ *
+ a_dim1], lda, &work[1], &c__1, &c_b1, &work[*m + 1], &
+ c__1);
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__ + 1;
+ q__1.r = -tau.r, q__1.i = -tau.i;
+ cgerc_(&i__1, &i__2, &q__1, &work[1], &c__1, &work[*m + 1], &c__1,
+ &a[i__ + i__ * a_dim1], lda);
+ }
+ if (i__ < *n) {
+
+/* generate random reflection */
+
+ i__1 = *n - i__ + 1;
+ clarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+ i__1 = *n - i__ + 1;
+ wn = scnrm2_(&i__1, &work[1], &c__1);
+ r__1 = wn / c_abs(&work[1]);
+ q__1.r = r__1 * work[1].r, q__1.i = r__1 * work[1].i;
+ wa.r = q__1.r, wa.i = q__1.i;
+ if (wn == 0.f) {
+ tau.r = 0.f, tau.i = 0.f;
+ } else {
+ q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i;
+ wb.r = q__1.r, wb.i = q__1.i;
+ i__1 = *n - i__;
+ c_div(&q__1, &c_b2, &wb);
+ cscal_(&i__1, &q__1, &work[2], &c__1);
+ work[1].r = 1.f, work[1].i = 0.f;
+ c_div(&q__1, &wb, &wa);
+ r__1 = q__1.r;
+ tau.r = r__1, tau.i = 0.f;
+ }
+
+/* multiply A(i:m,i:n) by random reflection from the right */
+
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__ + 1;
+ cgemv_("No transpose", &i__1, &i__2, &c_b2, &a[i__ + i__ * a_dim1]
+, lda, &work[1], &c__1, &c_b1, &work[*n + 1], &c__1);
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__ + 1;
+ q__1.r = -tau.r, q__1.i = -tau.i;
+ cgerc_(&i__1, &i__2, &q__1, &work[*n + 1], &c__1, &work[1], &c__1,
+ &a[i__ + i__ * a_dim1], lda);
+ }
+/* L40: */
+ }
+
+/* Reduce number of subdiagonals to KL and number of superdiagonals */
+/* to KU */
+
+/* Computing MAX */
+ i__2 = *m - 1 - *kl, i__3 = *n - 1 - *ku;
+ i__1 = max(i__2,i__3);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*kl <= *ku) {
+
+/* annihilate subdiagonal elements first (necessary if KL = 0) */
+
+/* Computing MIN */
+ i__2 = *m - 1 - *kl;
+ if (i__ <= min(i__2,*n)) {
+
+/* generate reflection to annihilate A(kl+i+1:m,i) */
+
+ i__2 = *m - *kl - i__ + 1;
+ wn = scnrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
+ r__1 = wn / c_abs(&a[*kl + i__ + i__ * a_dim1]);
+ i__2 = *kl + i__ + i__ * a_dim1;
+ q__1.r = r__1 * a[i__2].r, q__1.i = r__1 * a[i__2].i;
+ wa.r = q__1.r, wa.i = q__1.i;
+ if (wn == 0.f) {
+ tau.r = 0.f, tau.i = 0.f;
+ } else {
+ i__2 = *kl + i__ + i__ * a_dim1;
+ q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
+ wb.r = q__1.r, wb.i = q__1.i;
+ i__2 = *m - *kl - i__;
+ c_div(&q__1, &c_b2, &wb);
+ cscal_(&i__2, &q__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
+ c__1);
+ i__2 = *kl + i__ + i__ * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+ c_div(&q__1, &wb, &wa);
+ r__1 = q__1.r;
+ tau.r = r__1, tau.i = 0.f;
+ }
+
+/* apply reflection to A(kl+i:m,i+1:n) from the left */
+
+ i__2 = *m - *kl - i__ + 1;
+ i__3 = *n - i__;
+ cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*kl +
+ i__ + (i__ + 1) * a_dim1], lda, &a[*kl + i__ + i__ *
+ a_dim1], &c__1, &c_b1, &work[1], &c__1);
+ i__2 = *m - *kl - i__ + 1;
+ i__3 = *n - i__;
+ q__1.r = -tau.r, q__1.i = -tau.i;
+ cgerc_(&i__2, &i__3, &q__1, &a[*kl + i__ + i__ * a_dim1], &
+ c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) *
+ a_dim1], lda);
+ i__2 = *kl + i__ + i__ * a_dim1;
+ q__1.r = -wa.r, q__1.i = -wa.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ }
+
+/* Computing MIN */
+ i__2 = *n - 1 - *ku;
+ if (i__ <= min(i__2,*m)) {
+
+/* generate reflection to annihilate A(i,ku+i+1:n) */
+
+ i__2 = *n - *ku - i__ + 1;
+ wn = scnrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+ r__1 = wn / c_abs(&a[i__ + (*ku + i__) * a_dim1]);
+ i__2 = i__ + (*ku + i__) * a_dim1;
+ q__1.r = r__1 * a[i__2].r, q__1.i = r__1 * a[i__2].i;
+ wa.r = q__1.r, wa.i = q__1.i;
+ if (wn == 0.f) {
+ tau.r = 0.f, tau.i = 0.f;
+ } else {
+ i__2 = i__ + (*ku + i__) * a_dim1;
+ q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
+ wb.r = q__1.r, wb.i = q__1.i;
+ i__2 = *n - *ku - i__;
+ c_div(&q__1, &c_b2, &wb);
+ cscal_(&i__2, &q__1, &a[i__ + (*ku + i__ + 1) * a_dim1],
+ lda);
+ i__2 = i__ + (*ku + i__) * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+ c_div(&q__1, &wb, &wa);
+ r__1 = q__1.r;
+ tau.r = r__1, tau.i = 0.f;
+ }
+
+/* apply reflection to A(i+1:m,ku+i:n) from the right */
+
+ i__2 = *n - *ku - i__ + 1;
+ clacgv_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+ i__2 = *m - i__;
+ i__3 = *n - *ku - i__ + 1;
+ cgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (*ku
+ + i__) * a_dim1], lda, &a[i__ + (*ku + i__) * a_dim1],
+ lda, &c_b1, &work[1], &c__1);
+ i__2 = *m - i__;
+ i__3 = *n - *ku - i__ + 1;
+ q__1.r = -tau.r, q__1.i = -tau.i;
+ cgerc_(&i__2, &i__3, &q__1, &work[1], &c__1, &a[i__ + (*ku +
+ i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) *
+ a_dim1], lda);
+ i__2 = i__ + (*ku + i__) * a_dim1;
+ q__1.r = -wa.r, q__1.i = -wa.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ }
+ } else {
+
+/* annihilate superdiagonal elements first (necessary if */
+/* KU = 0) */
+
+/* Computing MIN */
+ i__2 = *n - 1 - *ku;
+ if (i__ <= min(i__2,*m)) {
+
+/* generate reflection to annihilate A(i,ku+i+1:n) */
+
+ i__2 = *n - *ku - i__ + 1;
+ wn = scnrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+ r__1 = wn / c_abs(&a[i__ + (*ku + i__) * a_dim1]);
+ i__2 = i__ + (*ku + i__) * a_dim1;
+ q__1.r = r__1 * a[i__2].r, q__1.i = r__1 * a[i__2].i;
+ wa.r = q__1.r, wa.i = q__1.i;
+ if (wn == 0.f) {
+ tau.r = 0.f, tau.i = 0.f;
+ } else {
+ i__2 = i__ + (*ku + i__) * a_dim1;
+ q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
+ wb.r = q__1.r, wb.i = q__1.i;
+ i__2 = *n - *ku - i__;
+ c_div(&q__1, &c_b2, &wb);
+ cscal_(&i__2, &q__1, &a[i__ + (*ku + i__ + 1) * a_dim1],
+ lda);
+ i__2 = i__ + (*ku + i__) * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+ c_div(&q__1, &wb, &wa);
+ r__1 = q__1.r;
+ tau.r = r__1, tau.i = 0.f;
+ }
+
+/* apply reflection to A(i+1:m,ku+i:n) from the right */
+
+ i__2 = *n - *ku - i__ + 1;
+ clacgv_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+ i__2 = *m - i__;
+ i__3 = *n - *ku - i__ + 1;
+ cgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (*ku
+ + i__) * a_dim1], lda, &a[i__ + (*ku + i__) * a_dim1],
+ lda, &c_b1, &work[1], &c__1);
+ i__2 = *m - i__;
+ i__3 = *n - *ku - i__ + 1;
+ q__1.r = -tau.r, q__1.i = -tau.i;
+ cgerc_(&i__2, &i__3, &q__1, &work[1], &c__1, &a[i__ + (*ku +
+ i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) *
+ a_dim1], lda);
+ i__2 = i__ + (*ku + i__) * a_dim1;
+ q__1.r = -wa.r, q__1.i = -wa.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ }
+
+/* Computing MIN */
+ i__2 = *m - 1 - *kl;
+ if (i__ <= min(i__2,*n)) {
+
+/* generate reflection to annihilate A(kl+i+1:m,i) */
+
+ i__2 = *m - *kl - i__ + 1;
+ wn = scnrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
+ r__1 = wn / c_abs(&a[*kl + i__ + i__ * a_dim1]);
+ i__2 = *kl + i__ + i__ * a_dim1;
+ q__1.r = r__1 * a[i__2].r, q__1.i = r__1 * a[i__2].i;
+ wa.r = q__1.r, wa.i = q__1.i;
+ if (wn == 0.f) {
+ tau.r = 0.f, tau.i = 0.f;
+ } else {
+ i__2 = *kl + i__ + i__ * a_dim1;
+ q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
+ wb.r = q__1.r, wb.i = q__1.i;
+ i__2 = *m - *kl - i__;
+ c_div(&q__1, &c_b2, &wb);
+ cscal_(&i__2, &q__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
+ c__1);
+ i__2 = *kl + i__ + i__ * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+ c_div(&q__1, &wb, &wa);
+ r__1 = q__1.r;
+ tau.r = r__1, tau.i = 0.f;
+ }
+
+/* apply reflection to A(kl+i:m,i+1:n) from the left */
+
+ i__2 = *m - *kl - i__ + 1;
+ i__3 = *n - i__;
+ cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*kl +
+ i__ + (i__ + 1) * a_dim1], lda, &a[*kl + i__ + i__ *
+ a_dim1], &c__1, &c_b1, &work[1], &c__1);
+ i__2 = *m - *kl - i__ + 1;
+ i__3 = *n - i__;
+ q__1.r = -tau.r, q__1.i = -tau.i;
+ cgerc_(&i__2, &i__3, &q__1, &a[*kl + i__ + i__ * a_dim1], &
+ c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) *
+ a_dim1], lda);
+ i__2 = *kl + i__ + i__ * a_dim1;
+ q__1.r = -wa.r, q__1.i = -wa.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ }
+ }
+
+ i__2 = *m;
+ for (j = *kl + i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L50: */
+ }
+
+ i__2 = *n;
+ for (j = *ku + i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L60: */
+ }
+/* L70: */
+ }
+ return 0;
+
+/* End of CLAGGE */
+
+} /* clagge_ */
diff --git a/TESTING/MATGEN/claghe.c b/TESTING/MATGEN/claghe.c
new file mode 100644
index 0000000..3c81fe6
--- /dev/null
+++ b/TESTING/MATGEN/claghe.c
@@ -0,0 +1,327 @@
+/* claghe.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__3 = 3;
+static integer c__1 = 1;
+
+/* Subroutine */ int claghe_(integer *n, integer *k, real *d__, complex *a,
+ integer *lda, integer *iseed, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+ void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j;
+ complex wa, wb;
+ real wn;
+ complex tau;
+ extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex *
+, integer *, complex *, integer *, complex *, integer *),
+ cgerc_(integer *, integer *, complex *, complex *, integer *,
+ complex *, integer *, complex *, integer *);
+ complex alpha;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *);
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *), chemv_(char *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, complex *,
+ integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *);
+ extern doublereal scnrm2_(integer *, complex *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), clarnv_(
+ integer *, integer *, integer *, complex *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAGHE generates a complex hermitian matrix A, by pre- and post- */
+/* multiplying a real diagonal matrix D with a random unitary matrix: */
+/* A = U*D*U'. The semi-bandwidth may then be reduced to k by additional */
+/* unitary transformations. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of nonzero subdiagonals within the band of A. */
+/* 0 <= K <= N-1. */
+
+/* D (input) REAL array, dimension (N) */
+/* The diagonal elements of the diagonal matrix D. */
+
+/* A (output) COMPLEX array, dimension (LDA,N) */
+/* The generated n by n hermitian matrix A (the full matrix is */
+/* stored). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= N. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --d__;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iseed;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*k < 0 || *k > *n - 1) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("CLAGHE", &i__1);
+ return 0;
+ }
+
+/* initialize lower triangle of A to diagonal matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ i__3 = i__;
+ a[i__2].r = d__[i__3], a[i__2].i = 0.f;
+/* L30: */
+ }
+
+/* Generate lower triangle of hermitian matrix */
+
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+
+/* generate random reflection */
+
+ i__1 = *n - i__ + 1;
+ clarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+ i__1 = *n - i__ + 1;
+ wn = scnrm2_(&i__1, &work[1], &c__1);
+ r__1 = wn / c_abs(&work[1]);
+ q__1.r = r__1 * work[1].r, q__1.i = r__1 * work[1].i;
+ wa.r = q__1.r, wa.i = q__1.i;
+ if (wn == 0.f) {
+ tau.r = 0.f, tau.i = 0.f;
+ } else {
+ q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i;
+ wb.r = q__1.r, wb.i = q__1.i;
+ i__1 = *n - i__;
+ c_div(&q__1, &c_b2, &wb);
+ cscal_(&i__1, &q__1, &work[2], &c__1);
+ work[1].r = 1.f, work[1].i = 0.f;
+ c_div(&q__1, &wb, &wa);
+ r__1 = q__1.r;
+ tau.r = r__1, tau.i = 0.f;
+ }
+
+/* apply random reflection to A(i:n,i:n) from the left */
+/* and the right */
+
+/* compute y := tau * A * u */
+
+ i__1 = *n - i__ + 1;
+ chemv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], &
+ c__1, &c_b1, &work[*n + 1], &c__1);
+
+/* compute v := y - 1/2 * tau * ( y, u ) * u */
+
+ q__3.r = -.5f, q__3.i = -0.f;
+ q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i +
+ q__3.i * tau.r;
+ i__1 = *n - i__ + 1;
+ cdotc_(&q__4, &i__1, &work[*n + 1], &c__1, &work[1], &c__1);
+ q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i
+ + q__2.i * q__4.r;
+ alpha.r = q__1.r, alpha.i = q__1.i;
+ i__1 = *n - i__ + 1;
+ caxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
+
+/* apply the transformation as a rank-2 update to A(i:n,i:n) */
+
+ i__1 = *n - i__ + 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cher2_("Lower", &i__1, &q__1, &work[1], &c__1, &work[*n + 1], &c__1, &
+ a[i__ + i__ * a_dim1], lda);
+/* L40: */
+ }
+
+/* Reduce number of subdiagonals to K */
+
+ i__1 = *n - 1 - *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* generate reflection to annihilate A(k+i+1:n,i) */
+
+ i__2 = *n - *k - i__ + 1;
+ wn = scnrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
+ r__1 = wn / c_abs(&a[*k + i__ + i__ * a_dim1]);
+ i__2 = *k + i__ + i__ * a_dim1;
+ q__1.r = r__1 * a[i__2].r, q__1.i = r__1 * a[i__2].i;
+ wa.r = q__1.r, wa.i = q__1.i;
+ if (wn == 0.f) {
+ tau.r = 0.f, tau.i = 0.f;
+ } else {
+ i__2 = *k + i__ + i__ * a_dim1;
+ q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
+ wb.r = q__1.r, wb.i = q__1.i;
+ i__2 = *n - *k - i__;
+ c_div(&q__1, &c_b2, &wb);
+ cscal_(&i__2, &q__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1);
+ i__2 = *k + i__ + i__ * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+ c_div(&q__1, &wb, &wa);
+ r__1 = q__1.r;
+ tau.r = r__1, tau.i = 0.f;
+ }
+
+/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */
+
+ i__2 = *n - *k - i__ + 1;
+ i__3 = *k - 1;
+ cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + (i__
+ + 1) * a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &
+ c_b1, &work[1], &c__1);
+ i__2 = *n - *k - i__ + 1;
+ i__3 = *k - 1;
+ q__1.r = -tau.r, q__1.i = -tau.i;
+ cgerc_(&i__2, &i__3, &q__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[
+ 1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda);
+
+/* apply reflection to A(k+i:n,k+i:n) from the left and the right */
+
+/* compute y := tau * A * u */
+
+ i__2 = *n - *k - i__ + 1;
+ chemv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda,
+ &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &work[1], &c__1);
+
+/* compute v := y - 1/2 * tau * ( y, u ) * u */
+
+ q__3.r = -.5f, q__3.i = -0.f;
+ q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i +
+ q__3.i * tau.r;
+ i__2 = *n - *k - i__ + 1;
+ cdotc_(&q__4, &i__2, &work[1], &c__1, &a[*k + i__ + i__ * a_dim1], &
+ c__1);
+ q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i
+ + q__2.i * q__4.r;
+ alpha.r = q__1.r, alpha.i = q__1.i;
+ i__2 = *n - *k - i__ + 1;
+ caxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], &
+ c__1);
+
+/* apply hermitian rank-2 update to A(k+i:n,k+i:n) */
+
+ i__2 = *n - *k - i__ + 1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ cher2_("Lower", &i__2, &q__1, &a[*k + i__ + i__ * a_dim1], &c__1, &
+ work[1], &c__1, &a[*k + i__ + (*k + i__) * a_dim1], lda);
+
+ i__2 = *k + i__ + i__ * a_dim1;
+ q__1.r = -wa.r, q__1.i = -wa.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ i__2 = *n;
+ for (j = *k + i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* Store full hermitian matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * a_dim1;
+ r_cnjg(&q__1, &a[i__ + j * a_dim1]);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+ return 0;
+
+/* End of CLAGHE */
+
+} /* claghe_ */
diff --git a/TESTING/MATGEN/clagsy.c b/TESTING/MATGEN/clagsy.c
new file mode 100644
index 0000000..2c5f16c
--- /dev/null
+++ b/TESTING/MATGEN/clagsy.c
@@ -0,0 +1,379 @@
+/* clagsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__3 = 3;
+static integer c__1 = 1;
+
+/* Subroutine */ int clagsy_(integer *n, integer *k, real *d__, complex *a,
+ integer *lda, integer *iseed, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
+ i__9;
+ real r__1;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, ii, jj;
+ complex wa, wb;
+ real wn;
+ complex tau;
+ extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *);
+ complex alpha;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *);
+ extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
+ *, complex *, integer *);
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *), caxpy_(integer *, complex *, complex *,
+ integer *, complex *, integer *), csymv_(char *, integer *,
+ complex *, complex *, integer *, complex *, integer *, complex *,
+ complex *, integer *);
+ extern doublereal scnrm2_(integer *, complex *, integer *);
+ extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
+ xerbla_(char *, integer *), clarnv_(integer *, integer *,
+ integer *, complex *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAGSY generates a complex symmetric matrix A, by pre- and post- */
+/* multiplying a real diagonal matrix D with a random unitary matrix: */
+/* A = U*D*U**T. The semi-bandwidth may then be reduced to k by */
+/* additional unitary transformations. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of nonzero subdiagonals within the band of A. */
+/* 0 <= K <= N-1. */
+
+/* D (input) REAL array, dimension (N) */
+/* The diagonal elements of the diagonal matrix D. */
+
+/* A (output) COMPLEX array, dimension (LDA,N) */
+/* The generated n by n symmetric matrix A (the full matrix is */
+/* stored). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= N. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --d__;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iseed;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*k < 0 || *k > *n - 1) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("CLAGSY", &i__1);
+ return 0;
+ }
+
+/* initialize lower triangle of A to diagonal matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ i__3 = i__;
+ a[i__2].r = d__[i__3], a[i__2].i = 0.f;
+/* L30: */
+ }
+
+/* Generate lower triangle of symmetric matrix */
+
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+
+/* generate random reflection */
+
+ i__1 = *n - i__ + 1;
+ clarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+ i__1 = *n - i__ + 1;
+ wn = scnrm2_(&i__1, &work[1], &c__1);
+ r__1 = wn / c_abs(&work[1]);
+ q__1.r = r__1 * work[1].r, q__1.i = r__1 * work[1].i;
+ wa.r = q__1.r, wa.i = q__1.i;
+ if (wn == 0.f) {
+ tau.r = 0.f, tau.i = 0.f;
+ } else {
+ q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i;
+ wb.r = q__1.r, wb.i = q__1.i;
+ i__1 = *n - i__;
+ c_div(&q__1, &c_b2, &wb);
+ cscal_(&i__1, &q__1, &work[2], &c__1);
+ work[1].r = 1.f, work[1].i = 0.f;
+ c_div(&q__1, &wb, &wa);
+ r__1 = q__1.r;
+ tau.r = r__1, tau.i = 0.f;
+ }
+
+/* apply random reflection to A(i:n,i:n) from the left */
+/* and the right */
+
+/* compute y := tau * A * conjg(u) */
+
+ i__1 = *n - i__ + 1;
+ clacgv_(&i__1, &work[1], &c__1);
+ i__1 = *n - i__ + 1;
+ csymv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], &
+ c__1, &c_b1, &work[*n + 1], &c__1);
+ i__1 = *n - i__ + 1;
+ clacgv_(&i__1, &work[1], &c__1);
+
+/* compute v := y - 1/2 * tau * ( u, y ) * u */
+
+ q__3.r = -.5f, q__3.i = -0.f;
+ q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i +
+ q__3.i * tau.r;
+ i__1 = *n - i__ + 1;
+ cdotc_(&q__4, &i__1, &work[1], &c__1, &work[*n + 1], &c__1);
+ q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i
+ + q__2.i * q__4.r;
+ alpha.r = q__1.r, alpha.i = q__1.i;
+ i__1 = *n - i__ + 1;
+ caxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
+
+/* apply the transformation as a rank-2 update to A(i:n,i:n) */
+
+/* CALL CSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1, */
+/* $ A( I, I ), LDA ) */
+
+ i__1 = *n;
+ for (jj = i__; jj <= i__1; ++jj) {
+ i__2 = *n;
+ for (ii = jj; ii <= i__2; ++ii) {
+ i__3 = ii + jj * a_dim1;
+ i__4 = ii + jj * a_dim1;
+ i__5 = ii - i__ + 1;
+ i__6 = *n + jj - i__ + 1;
+ q__3.r = work[i__5].r * work[i__6].r - work[i__5].i * work[
+ i__6].i, q__3.i = work[i__5].r * work[i__6].i + work[
+ i__5].i * work[i__6].r;
+ q__2.r = a[i__4].r - q__3.r, q__2.i = a[i__4].i - q__3.i;
+ i__7 = *n + ii - i__ + 1;
+ i__8 = jj - i__ + 1;
+ q__4.r = work[i__7].r * work[i__8].r - work[i__7].i * work[
+ i__8].i, q__4.i = work[i__7].r * work[i__8].i + work[
+ i__7].i * work[i__8].r;
+ q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L40: */
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* Reduce number of subdiagonals to K */
+
+ i__1 = *n - 1 - *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* generate reflection to annihilate A(k+i+1:n,i) */
+
+ i__2 = *n - *k - i__ + 1;
+ wn = scnrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
+ r__1 = wn / c_abs(&a[*k + i__ + i__ * a_dim1]);
+ i__2 = *k + i__ + i__ * a_dim1;
+ q__1.r = r__1 * a[i__2].r, q__1.i = r__1 * a[i__2].i;
+ wa.r = q__1.r, wa.i = q__1.i;
+ if (wn == 0.f) {
+ tau.r = 0.f, tau.i = 0.f;
+ } else {
+ i__2 = *k + i__ + i__ * a_dim1;
+ q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
+ wb.r = q__1.r, wb.i = q__1.i;
+ i__2 = *n - *k - i__;
+ c_div(&q__1, &c_b2, &wb);
+ cscal_(&i__2, &q__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1);
+ i__2 = *k + i__ + i__ * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+ c_div(&q__1, &wb, &wa);
+ r__1 = q__1.r;
+ tau.r = r__1, tau.i = 0.f;
+ }
+
+/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */
+
+ i__2 = *n - *k - i__ + 1;
+ i__3 = *k - 1;
+ cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + (i__
+ + 1) * a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &
+ c_b1, &work[1], &c__1);
+ i__2 = *n - *k - i__ + 1;
+ i__3 = *k - 1;
+ q__1.r = -tau.r, q__1.i = -tau.i;
+ cgerc_(&i__2, &i__3, &q__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[
+ 1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda);
+
+/* apply reflection to A(k+i:n,k+i:n) from the left and the right */
+
+/* compute y := tau * A * conjg(u) */
+
+ i__2 = *n - *k - i__ + 1;
+ clacgv_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
+ i__2 = *n - *k - i__ + 1;
+ csymv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda,
+ &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &work[1], &c__1);
+ i__2 = *n - *k - i__ + 1;
+ clacgv_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
+
+/* compute v := y - 1/2 * tau * ( u, y ) * u */
+
+ q__3.r = -.5f, q__3.i = -0.f;
+ q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i +
+ q__3.i * tau.r;
+ i__2 = *n - *k - i__ + 1;
+ cdotc_(&q__4, &i__2, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], &
+ c__1);
+ q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i
+ + q__2.i * q__4.r;
+ alpha.r = q__1.r, alpha.i = q__1.i;
+ i__2 = *n - *k - i__ + 1;
+ caxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], &
+ c__1);
+
+/* apply symmetric rank-2 update to A(k+i:n,k+i:n) */
+
+/* CALL CSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1, */
+/* $ A( K+I, K+I ), LDA ) */
+
+ i__2 = *n;
+ for (jj = *k + i__; jj <= i__2; ++jj) {
+ i__3 = *n;
+ for (ii = jj; ii <= i__3; ++ii) {
+ i__4 = ii + jj * a_dim1;
+ i__5 = ii + jj * a_dim1;
+ i__6 = ii + i__ * a_dim1;
+ i__7 = jj - *k - i__ + 1;
+ q__3.r = a[i__6].r * work[i__7].r - a[i__6].i * work[i__7].i,
+ q__3.i = a[i__6].r * work[i__7].i + a[i__6].i * work[
+ i__7].r;
+ q__2.r = a[i__5].r - q__3.r, q__2.i = a[i__5].i - q__3.i;
+ i__8 = ii - *k - i__ + 1;
+ i__9 = jj + i__ * a_dim1;
+ q__4.r = work[i__8].r * a[i__9].r - work[i__8].i * a[i__9].i,
+ q__4.i = work[i__8].r * a[i__9].i + work[i__8].i * a[
+ i__9].r;
+ q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
+ a[i__4].r = q__1.r, a[i__4].i = q__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+
+ i__2 = *k + i__ + i__ * a_dim1;
+ q__1.r = -wa.r, q__1.i = -wa.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ i__2 = *n;
+ for (j = *k + i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L90: */
+ }
+/* L100: */
+ }
+
+/* Store full symmetric matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
+/* L110: */
+ }
+/* L120: */
+ }
+ return 0;
+
+/* End of CLAGSY */
+
+} /* clagsy_ */
diff --git a/TESTING/MATGEN/clahilb.c b/TESTING/MATGEN/clahilb.c
new file mode 100644
index 0000000..3f2216e
--- /dev/null
+++ b/TESTING/MATGEN/clahilb.c
@@ -0,0 +1,277 @@
+/* clahilb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static complex c_b6 = {0.f,0.f};
+
+/* Subroutine */ int clahilb_(integer *n, integer *nrhs, complex *a, integer *
+ lda, complex *x, integer *ldx, complex *b, integer *ldb, real *work,
+ integer *info, char *path)
+{
+ /* Initialized data */
+
+ static complex d1[8] = { {-1.f,0.f},{0.f,1.f},{-1.f,-1.f},{0.f,-1.f},{1.f,
+ 0.f},{-1.f,1.f},{1.f,1.f},{1.f,-1.f} };
+ static complex d2[8] = { {-1.f,0.f},{0.f,-1.f},{-1.f,1.f},{0.f,1.f},{1.f,
+ 0.f},{-1.f,-1.f},{1.f,-1.f},{1.f,1.f} };
+ static complex invd1[8] = { {-1.f,0.f},{0.f,-1.f},{-.5f,.5f},{0.f,1.f},{
+ 1.f,0.f},{-.5f,-.5f},{.5f,-.5f},{.5f,.5f} };
+ static complex invd2[8] = { {-1.f,0.f},{0.f,1.f},{-.5f,-.5f},{0.f,-1.f},{
+ 1.f,0.f},{-.5f,.5f},{.5f,.5f},{.5f,-.5f} };
+
+ /* System generated locals */
+ integer a_dim1, a_offset, x_dim1, x_offset, b_dim1, b_offset, i__1, i__2,
+ i__3, i__4, i__5;
+ real r__1;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer i__, j, m, r__;
+ char c2[2];
+ integer ti, tm;
+ complex tmp;
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), xerbla_(char *,
+ integer *);
+ extern logical lsamen_(integer *, char *, char *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
+/* Courant Institute, Argonne National Lab, and Rice University */
+/* 28 August, 2006 */
+
+/* David Vu <dtv at cs.berkeley.edu> */
+/* Yozo Hida <yozo at cs.berkeley.edu> */
+/* Jason Riedy <ejr at cs.berkeley.edu> */
+/* D. Halligan <dhalligan at berkeley.edu> */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAHILB generates an N by N scaled Hilbert matrix in A along with */
+/* NRHS right-hand sides in B and solutions in X such that A*X=B. */
+
+/* The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all */
+/* entries are integers. The right-hand sides are the first NRHS */
+/* columns of M * the identity matrix, and the solutions are the */
+/* first NRHS columns of the inverse Hilbert matrix. */
+
+/* The condition number of the Hilbert matrix grows exponentially with */
+/* its size, roughly as O(e ** (3.5*N)). Additionally, the inverse */
+/* Hilbert matrices beyond a relatively small dimension cannot be */
+/* generated exactly without extra precision. Precision is exhausted */
+/* when the largest entry in the inverse Hilbert matrix is greater than */
+/* 2 to the power of the number of bits in the fraction of the data type */
+/* used plus one, which is 24 for single precision. */
+
+/* In single, the generated solution is exact for N <= 6 and has */
+/* small componentwise error for 7 <= N <= 11. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The dimension of the matrix A. */
+
+/* NRHS (input) NRHS */
+/* The requested number of right-hand sides. */
+
+/* A (output) COMPLEX array, dimension (LDA, N) */
+/* The generated scaled Hilbert matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= N. */
+
+/* X (output) COMPLEX array, dimension (LDX, NRHS) */
+/* The generated exact solutions. Currently, the first NRHS */
+/* columns of the inverse Hilbert matrix. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= N. */
+
+/* B (output) REAL array, dimension (LDB, NRHS) */
+/* The generated right-hand sides. Currently, the first NRHS */
+/* columns of LCM(1, 2, ..., 2*N-1) * the identity matrix. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= N. */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* = 1: N is too large; the data is still generated but may not */
+/* be not exact. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+/* .. Local Scalars .. */
+/* .. Parameters .. */
+/* NMAX_EXACT the largest dimension where the generated data is */
+/* exact. */
+/* NMAX_APPROX the largest dimension where the generated data has */
+/* a small componentwise relative error. */
+/* ??? complex uses how many bits ??? */
+/* d's are generated from random permuation of those eight elements. */
+ /* Parameter adjustments */
+ --work;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+/* .. */
+/* .. External Functions */
+/* .. */
+/* .. Executable Statements .. */
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Test the input arguments */
+
+ *info = 0;
+ if (*n < 0 || *n > 11) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*lda < *n) {
+ *info = -4;
+ } else if (*ldx < *n) {
+ *info = -6;
+ } else if (*ldb < *n) {
+ *info = -8;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("CLAHILB", &i__1);
+ return 0;
+ }
+ if (*n > 6) {
+ *info = 1;
+ }
+/* Compute M = the LCM of the integers [1, 2*N-1]. The largest */
+/* reasonable N is small enough that integers suffice (up to N = 11). */
+ m = 1;
+ i__1 = (*n << 1) - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ tm = m;
+ ti = i__;
+ r__ = tm % ti;
+ while(r__ != 0) {
+ tm = ti;
+ ti = r__;
+ r__ = tm % ti;
+ }
+ m = m / ti * i__;
+ }
+/* Generate the scaled Hilbert matrix in A */
+/* If we are testing SY routines, take D1_i = D2_i, else, D1_i = D2_i* */
+ if (lsamen_(&c__2, c2, "SY")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = j % 8;
+ r__1 = (real) m / (i__ + j - 1);
+ q__2.r = r__1 * d1[i__4].r, q__2.i = r__1 * d1[i__4].i;
+ i__5 = i__ % 8;
+ q__1.r = q__2.r * d1[i__5].r - q__2.i * d1[i__5].i, q__1.i =
+ q__2.r * d1[i__5].i + q__2.i * d1[i__5].r;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ }
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = j % 8;
+ r__1 = (real) m / (i__ + j - 1);
+ q__2.r = r__1 * d1[i__4].r, q__2.i = r__1 * d1[i__4].i;
+ i__5 = i__ % 8;
+ q__1.r = q__2.r * d2[i__5].r - q__2.i * d2[i__5].i, q__1.i =
+ q__2.r * d2[i__5].i + q__2.i * d2[i__5].r;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ }
+ }
+ }
+/* Generate matrix B as simply the first NRHS columns of M * the */
+/* identity. */
+ r__1 = (real) m;
+ tmp.r = r__1, tmp.i = 0.f;
+ claset_("Full", n, nrhs, &c_b6, &tmp, &b[b_offset], ldb);
+/* Generate the true solutions in X. Because B = the first NRHS */
+/* columns of M*I, the true solutions are just the first NRHS columns */
+/* of the inverse Hilbert matrix. */
+ work[1] = (real) (*n);
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ work[j] = work[j - 1] / (j - 1) * (j - 1 - *n) / (j - 1) * (*n + j -
+ 1);
+ }
+/* If we are testing SY routines, take D1_i = D2_i, else, D1_i = D2_i* */
+ if (lsamen_(&c__2, c2, "SY")) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = j % 8;
+ r__1 = work[i__] * work[j] / (i__ + j - 1);
+ q__2.r = r__1 * invd1[i__4].r, q__2.i = r__1 * invd1[i__4].i;
+ i__5 = i__ % 8;
+ q__1.r = q__2.r * invd1[i__5].r - q__2.i * invd1[i__5].i,
+ q__1.i = q__2.r * invd1[i__5].i + q__2.i * invd1[i__5]
+ .r;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ }
+ }
+ } else {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = j % 8;
+ r__1 = work[i__] * work[j] / (i__ + j - 1);
+ q__2.r = r__1 * invd2[i__4].r, q__2.i = r__1 * invd2[i__4].i;
+ i__5 = i__ % 8;
+ q__1.r = q__2.r * invd1[i__5].r - q__2.i * invd1[i__5].i,
+ q__1.i = q__2.r * invd1[i__5].i + q__2.i * invd1[i__5]
+ .r;
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+ }
+ }
+ }
+ return 0;
+} /* clahilb_ */
diff --git a/TESTING/MATGEN/clakf2.c b/TESTING/MATGEN/clakf2.c
new file mode 100644
index 0000000..4278257
--- /dev/null
+++ b/TESTING/MATGEN/clakf2.c
@@ -0,0 +1,193 @@
+/* clakf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+
+/* Subroutine */ int clakf2_(integer *m, integer *n, complex *a, integer *lda,
+ complex *b, complex *d__, complex *e, complex *z__, integer *ldz)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, d_dim1, d_offset, e_dim1,
+ e_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
+ complex q__1;
+
+ /* Local variables */
+ integer i__, j, l, ik, jk, mn, mn2;
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Form the 2*M*N by 2*M*N matrix */
+
+/* Z = [ kron(In, A) -kron(B', Im) ] */
+/* [ kron(In, D) -kron(E', Im) ], */
+
+/* where In is the identity matrix of size n and X' is the transpose */
+/* of X. kron(X, Y) is the Kronecker product between the matrices X */
+/* and Y. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* Size of matrix, must be >= 1. */
+
+/* N (input) INTEGER */
+/* Size of matrix, must be >= 1. */
+
+/* A (input) COMPLEX, dimension ( LDA, M ) */
+/* The matrix A in the output matrix Z. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, D, and E. ( LDA >= M+N ) */
+
+/* B (input) COMPLEX, dimension ( LDA, N ) */
+/* D (input) COMPLEX, dimension ( LDA, M ) */
+/* E (input) COMPLEX, dimension ( LDA, N ) */
+/* The matrices used in forming the output matrix Z. */
+
+/* Z (output) COMPLEX, dimension ( LDZ, 2*M*N ) */
+/* The resultant Kronecker M*N*2 by M*N*2 matrix (see above.) */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of Z. ( LDZ >= 2*M*N ) */
+
+/* ==================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize Z */
+
+ /* Parameter adjustments */
+ e_dim1 = *lda;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ d_dim1 = *lda;
+ d_offset = 1 + d_dim1;
+ d__ -= d_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+
+ /* Function Body */
+ mn = *m * *n;
+ mn2 = mn << 1;
+ claset_("Full", &mn2, &mn2, &c_b1, &c_b1, &z__[z_offset], ldz);
+
+ ik = 1;
+ i__1 = *n;
+ for (l = 1; l <= i__1; ++l) {
+
+/* form kron(In, A) */
+
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = *m;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = ik + i__ - 1 + (ik + j - 1) * z_dim1;
+ i__5 = i__ + j * a_dim1;
+ z__[i__4].r = a[i__5].r, z__[i__4].i = a[i__5].i;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* form kron(In, D) */
+
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = *m;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = ik + mn + i__ - 1 + (ik + j - 1) * z_dim1;
+ i__5 = i__ + j * d_dim1;
+ z__[i__4].r = d__[i__5].r, z__[i__4].i = d__[i__5].i;
+/* L30: */
+ }
+/* L40: */
+ }
+
+ ik += *m;
+/* L50: */
+ }
+
+ ik = 1;
+ i__1 = *n;
+ for (l = 1; l <= i__1; ++l) {
+ jk = mn + 1;
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+
+/* form -kron(B', Im) */
+
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ik + i__ - 1 + (jk + i__ - 1) * z_dim1;
+ i__5 = j + l * b_dim1;
+ q__1.r = -b[i__5].r, q__1.i = -b[i__5].i;
+ z__[i__4].r = q__1.r, z__[i__4].i = q__1.i;
+/* L60: */
+ }
+
+/* form -kron(E', Im) */
+
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ik + mn + i__ - 1 + (jk + i__ - 1) * z_dim1;
+ i__5 = j + l * e_dim1;
+ q__1.r = -e[i__5].r, q__1.i = -e[i__5].i;
+ z__[i__4].r = q__1.r, z__[i__4].i = q__1.i;
+/* L70: */
+ }
+
+ jk += *m;
+/* L80: */
+ }
+
+ ik += *m;
+/* L90: */
+ }
+
+ return 0;
+
+/* End of CLAKF2 */
+
+} /* clakf2_ */
diff --git a/TESTING/MATGEN/clarge.c b/TESTING/MATGEN/clarge.c
new file mode 100644
index 0000000..5eae17e
--- /dev/null
+++ b/TESTING/MATGEN/clarge.c
@@ -0,0 +1,179 @@
+/* clarge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__3 = 3;
+static integer c__1 = 1;
+
+/* Subroutine */ int clarge_(integer *n, complex *a, integer *lda, integer *
+ iseed, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ real r__1;
+ complex q__1;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+ void c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer i__;
+ complex wa, wb;
+ real wn;
+ complex tau;
+ extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *),
+ cscal_(integer *, complex *, complex *, integer *), cgemv_(char *
+, integer *, integer *, complex *, complex *, integer *, complex *
+, integer *, complex *, complex *, integer *);
+ extern doublereal scnrm2_(integer *, complex *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), clarnv_(
+ integer *, integer *, integer *, complex *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLARGE pre- and post-multiplies a complex general n by n matrix A */
+/* with a random unitary matrix: A = U*D*U'. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX array, dimension (LDA,N) */
+/* On entry, the original n by n matrix A. */
+/* On exit, A is overwritten by U*A*U' for some random */
+/* unitary matrix U. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= N. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* WORK (workspace) COMPLEX array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iseed;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*lda < max(1,*n)) {
+ *info = -3;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("CLARGE", &i__1);
+ return 0;
+ }
+
+/* pre- and post-multiply A by random unitary matrix */
+
+ for (i__ = *n; i__ >= 1; --i__) {
+
+/* generate random reflection */
+
+ i__1 = *n - i__ + 1;
+ clarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+ i__1 = *n - i__ + 1;
+ wn = scnrm2_(&i__1, &work[1], &c__1);
+ r__1 = wn / c_abs(&work[1]);
+ q__1.r = r__1 * work[1].r, q__1.i = r__1 * work[1].i;
+ wa.r = q__1.r, wa.i = q__1.i;
+ if (wn == 0.f) {
+ tau.r = 0.f, tau.i = 0.f;
+ } else {
+ q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i;
+ wb.r = q__1.r, wb.i = q__1.i;
+ i__1 = *n - i__;
+ c_div(&q__1, &c_b2, &wb);
+ cscal_(&i__1, &q__1, &work[2], &c__1);
+ work[1].r = 1.f, work[1].i = 0.f;
+ c_div(&q__1, &wb, &wa);
+ r__1 = q__1.r;
+ tau.r = r__1, tau.i = 0.f;
+ }
+
+/* multiply A(i:n,1:n) by random reflection from the left */
+
+ i__1 = *n - i__ + 1;
+ cgemv_("Conjugate transpose", &i__1, n, &c_b2, &a[i__ + a_dim1], lda,
+ &work[1], &c__1, &c_b1, &work[*n + 1], &c__1);
+ i__1 = *n - i__ + 1;
+ q__1.r = -tau.r, q__1.i = -tau.i;
+ cgerc_(&i__1, n, &q__1, &work[1], &c__1, &work[*n + 1], &c__1, &a[i__
+ + a_dim1], lda);
+
+/* multiply A(1:n,i:n) by random reflection from the right */
+
+ i__1 = *n - i__ + 1;
+ cgemv_("No transpose", n, &i__1, &c_b2, &a[i__ * a_dim1 + 1], lda, &
+ work[1], &c__1, &c_b1, &work[*n + 1], &c__1);
+ i__1 = *n - i__ + 1;
+ q__1.r = -tau.r, q__1.i = -tau.i;
+ cgerc_(n, &i__1, &q__1, &work[*n + 1], &c__1, &work[1], &c__1, &a[i__
+ * a_dim1 + 1], lda);
+/* L10: */
+ }
+ return 0;
+
+/* End of CLARGE */
+
+} /* clarge_ */
diff --git a/TESTING/MATGEN/clarnd.c b/TESTING/MATGEN/clarnd.c
new file mode 100644
index 0000000..6bc9356
--- /dev/null
+++ b/TESTING/MATGEN/clarnd.c
@@ -0,0 +1,139 @@
+/* clarnd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Complex */ VOID clarnd_(complex * ret_val, integer *idist, integer *iseed)
+{
+ /* System generated locals */
+ real r__1, r__2;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ double log(doublereal), sqrt(doublereal);
+ void c_exp(complex *, complex *);
+
+ /* Local variables */
+ real t1, t2;
+ extern doublereal slaran_(integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLARND returns a random complex number from a uniform or normal */
+/* distribution. */
+
+/* Arguments */
+/* ========= */
+
+/* IDIST (input) INTEGER */
+/* Specifies the distribution of the random numbers: */
+/* = 1: real and imaginary parts each uniform (0,1) */
+/* = 2: real and imaginary parts each uniform (-1,1) */
+/* = 3: real and imaginary parts each normal (0,1) */
+/* = 4: uniformly distributed on the disc abs(z) <= 1 */
+/* = 5: uniformly distributed on the circle abs(z) = 1 */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* Further Details */
+/* =============== */
+
+/* This routine calls the auxiliary routine SLARAN to generate a random */
+/* real number from a uniform (0,1) distribution. The Box-Muller method */
+/* is used to transform numbers from a uniform to a normal distribution. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Generate a pair of real random numbers from a uniform (0,1) */
+/* distribution */
+
+ /* Parameter adjustments */
+ --iseed;
+
+ /* Function Body */
+ t1 = slaran_(&iseed[1]);
+ t2 = slaran_(&iseed[1]);
+
+ if (*idist == 1) {
+
+/* real and imaginary parts each uniform (0,1) */
+
+ q__1.r = t1, q__1.i = t2;
+ ret_val->r = q__1.r, ret_val->i = q__1.i;
+ } else if (*idist == 2) {
+
+/* real and imaginary parts each uniform (-1,1) */
+
+ r__1 = t1 * 2.f - 1.f;
+ r__2 = t2 * 2.f - 1.f;
+ q__1.r = r__1, q__1.i = r__2;
+ ret_val->r = q__1.r, ret_val->i = q__1.i;
+ } else if (*idist == 3) {
+
+/* real and imaginary parts each normal (0,1) */
+
+ r__1 = sqrt(log(t1) * -2.f);
+ r__2 = t2 * 6.2831853071795864769252867663f;
+ q__3.r = 0.f, q__3.i = r__2;
+ c_exp(&q__2, &q__3);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ ret_val->r = q__1.r, ret_val->i = q__1.i;
+ } else if (*idist == 4) {
+
+/* uniform distribution on the unit disc abs(z) <= 1 */
+
+ r__1 = sqrt(t1);
+ r__2 = t2 * 6.2831853071795864769252867663f;
+ q__3.r = 0.f, q__3.i = r__2;
+ c_exp(&q__2, &q__3);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ ret_val->r = q__1.r, ret_val->i = q__1.i;
+ } else if (*idist == 5) {
+
+/* uniform distribution on the unit circle abs(z) = 1 */
+
+ r__1 = t2 * 6.2831853071795864769252867663f;
+ q__2.r = 0.f, q__2.i = r__1;
+ c_exp(&q__1, &q__2);
+ ret_val->r = q__1.r, ret_val->i = q__1.i;
+ }
+ return ;
+
+/* End of CLARND */
+
+} /* clarnd_ */
diff --git a/TESTING/MATGEN/claror.c b/TESTING/MATGEN/claror.c
new file mode 100644
index 0000000..c0699d9
--- /dev/null
+++ b/TESTING/MATGEN/claror.c
@@ -0,0 +1,364 @@
+/* claror.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__3 = 3;
+static integer c__1 = 1;
+
+/* Subroutine */ int claror_(char *side, char *init, integer *m, integer *n,
+ complex *a, integer *lda, integer *iseed, complex *x, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer j, kbeg, jcol;
+ real xabs;
+ integer irow;
+ extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *),
+ cscal_(integer *, complex *, complex *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *);
+ complex csign;
+ integer ixfrm, itype, nxfrm;
+ real xnorm;
+ extern doublereal scnrm2_(integer *, complex *, integer *);
+ extern /* Subroutine */ int clacgv_(integer *, complex *, integer *);
+ extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), xerbla_(char *,
+ integer *);
+ real factor;
+ complex xnorms;
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAROR pre- or post-multiplies an M by N matrix A by a random */
+/* unitary matrix U, overwriting A. A may optionally be */
+/* initialized to the identity matrix before multiplying by U. */
+/* U is generated using the method of G.W. Stewart */
+/* ( SIAM J. Numer. Anal. 17, 1980, pp. 403-409 ). */
+/* (BLAS-2 version) */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE - CHARACTER*1 */
+/* SIDE specifies whether A is multiplied on the left or right */
+/* by U. */
+/* SIDE = 'L' Multiply A on the left (premultiply) by U */
+/* SIDE = 'R' Multiply A on the right (postmultiply) by U* */
+/* SIDE = 'C' Multiply A on the left by U and the right by U* */
+/* SIDE = 'T' Multiply A on the left by U and the right by U' */
+/* Not modified. */
+
+/* INIT - CHARACTER*1 */
+/* INIT specifies whether or not A should be initialized to */
+/* the identity matrix. */
+/* INIT = 'I' Initialize A to (a section of) the */
+/* identity matrix before applying U. */
+/* INIT = 'N' No initialization. Apply U to the */
+/* input matrix A. */
+
+/* INIT = 'I' may be used to generate square (i.e., unitary) */
+/* or rectangular orthogonal matrices (orthogonality being */
+/* in the sense of CDOTC): */
+
+/* For square matrices, M=N, and SIDE many be either 'L' or */
+/* 'R'; the rows will be orthogonal to each other, as will the */
+/* columns. */
+/* For rectangular matrices where M < N, SIDE = 'R' will */
+/* produce a dense matrix whose rows will be orthogonal and */
+/* whose columns will not, while SIDE = 'L' will produce a */
+/* matrix whose rows will be orthogonal, and whose first M */
+/* columns will be orthogonal, the remaining columns being */
+/* zero. */
+/* For matrices where M > N, just use the previous */
+/* explaination, interchanging 'L' and 'R' and "rows" and */
+/* "columns". */
+
+/* Not modified. */
+
+/* M - INTEGER */
+/* Number of rows of A. Not modified. */
+
+/* N - INTEGER */
+/* Number of columns of A. Not modified. */
+
+/* A - COMPLEX array, dimension ( LDA, N ) */
+/* Input and output array. Overwritten by U A ( if SIDE = 'L' ) */
+/* or by A U ( if SIDE = 'R' ) */
+/* or by U A U* ( if SIDE = 'C') */
+/* or by U A U' ( if SIDE = 'T') on exit. */
+
+/* LDA - INTEGER */
+/* Leading dimension of A. Must be at least MAX ( 1, M ). */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension ( 4 ) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to CLAROR to continue the same random number */
+/* sequence. */
+/* Modified. */
+
+/* X - COMPLEX array, dimension ( 3*MAX( M, N ) ) */
+/* Workspace. Of length: */
+/* 2*M + N if SIDE = 'L', */
+/* 2*N + M if SIDE = 'R', */
+/* 3*N if SIDE = 'C' or 'T'. */
+/* Modified. */
+
+/* INFO - INTEGER */
+/* An error flag. It is set to: */
+/* 0 if no error. */
+/* 1 if CLARND returned a bad random number (installation */
+/* problem) */
+/* -1 if SIDE is not L, R, C, or T. */
+/* -3 if M is negative. */
+/* -4 if N is negative or if SIDE is C or T and N is not equal */
+/* to M. */
+/* -6 if LDA is less than M. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iseed;
+ --x;
+
+ /* Function Body */
+ if (*n == 0 || *m == 0) {
+ return 0;
+ }
+
+ itype = 0;
+ if (lsame_(side, "L")) {
+ itype = 1;
+ } else if (lsame_(side, "R")) {
+ itype = 2;
+ } else if (lsame_(side, "C")) {
+ itype = 3;
+ } else if (lsame_(side, "T")) {
+ itype = 4;
+ }
+
+/* Check for argument errors. */
+
+ *info = 0;
+ if (itype == 0) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0 || itype == 3 && *n != *m) {
+ *info = -4;
+ } else if (*lda < *m) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLAROR", &i__1);
+ return 0;
+ }
+
+ if (itype == 1) {
+ nxfrm = *m;
+ } else {
+ nxfrm = *n;
+ }
+
+/* Initialize A to the identity matrix if desired */
+
+ if (lsame_(init, "I")) {
+ claset_("Full", m, n, &c_b1, &c_b2, &a[a_offset], lda);
+ }
+
+/* If no rotation possible, still multiply by */
+/* a random complex number from the circle |x| = 1 */
+
+/* 2) Compute Rotation by computing Householder */
+/* Transformations H(2), H(3), ..., H(n). Note that the */
+/* order in which they are computed is irrelevant. */
+
+ i__1 = nxfrm;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ x[i__2].r = 0.f, x[i__2].i = 0.f;
+/* L40: */
+ }
+
+ i__1 = nxfrm;
+ for (ixfrm = 2; ixfrm <= i__1; ++ixfrm) {
+ kbeg = nxfrm - ixfrm + 1;
+
+/* Generate independent normal( 0, 1 ) random numbers */
+
+ i__2 = nxfrm;
+ for (j = kbeg; j <= i__2; ++j) {
+ i__3 = j;
+ clarnd_(&q__1, &c__3, &iseed[1]);
+ x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+/* L50: */
+ }
+
+/* Generate a Householder transformation from the random vector X */
+
+ xnorm = scnrm2_(&ixfrm, &x[kbeg], &c__1);
+ xabs = c_abs(&x[kbeg]);
+ if (xabs != 0.f) {
+ i__2 = kbeg;
+ q__1.r = x[i__2].r / xabs, q__1.i = x[i__2].i / xabs;
+ csign.r = q__1.r, csign.i = q__1.i;
+ } else {
+ csign.r = 1.f, csign.i = 0.f;
+ }
+ q__1.r = xnorm * csign.r, q__1.i = xnorm * csign.i;
+ xnorms.r = q__1.r, xnorms.i = q__1.i;
+ i__2 = nxfrm + kbeg;
+ q__1.r = -csign.r, q__1.i = -csign.i;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+ factor = xnorm * (xnorm + xabs);
+ if (dabs(factor) < 1e-20f) {
+ *info = 1;
+ i__2 = -(*info);
+ xerbla_("CLAROR", &i__2);
+ return 0;
+ } else {
+ factor = 1.f / factor;
+ }
+ i__2 = kbeg;
+ i__3 = kbeg;
+ q__1.r = x[i__3].r + xnorms.r, q__1.i = x[i__3].i + xnorms.i;
+ x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+
+/* Apply Householder transformation to A */
+
+ if (itype == 1 || itype == 3 || itype == 4) {
+
+/* Apply H(k) on the left of A */
+
+ cgemv_("C", &ixfrm, n, &c_b2, &a[kbeg + a_dim1], lda, &x[kbeg], &
+ c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1);
+ q__2.r = factor, q__2.i = 0.f;
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ cgerc_(&ixfrm, n, &q__1, &x[kbeg], &c__1, &x[(nxfrm << 1) + 1], &
+ c__1, &a[kbeg + a_dim1], lda);
+
+ }
+
+ if (itype >= 2 && itype <= 4) {
+
+/* Apply H(k)* (or H(k)') on the right of A */
+
+ if (itype == 4) {
+ clacgv_(&ixfrm, &x[kbeg], &c__1);
+ }
+
+ cgemv_("N", m, &ixfrm, &c_b2, &a[kbeg * a_dim1 + 1], lda, &x[kbeg]
+, &c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1);
+ q__2.r = factor, q__2.i = 0.f;
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ cgerc_(m, &ixfrm, &q__1, &x[(nxfrm << 1) + 1], &c__1, &x[kbeg], &
+ c__1, &a[kbeg * a_dim1 + 1], lda);
+
+ }
+/* L60: */
+ }
+
+ clarnd_(&q__1, &c__3, &iseed[1]);
+ x[1].r = q__1.r, x[1].i = q__1.i;
+ xabs = c_abs(&x[1]);
+ if (xabs != 0.f) {
+ q__1.r = x[1].r / xabs, q__1.i = x[1].i / xabs;
+ csign.r = q__1.r, csign.i = q__1.i;
+ } else {
+ csign.r = 1.f, csign.i = 0.f;
+ }
+ i__1 = nxfrm << 1;
+ x[i__1].r = csign.r, x[i__1].i = csign.i;
+
+/* Scale the matrix A by D. */
+
+ if (itype == 1 || itype == 3 || itype == 4) {
+ i__1 = *m;
+ for (irow = 1; irow <= i__1; ++irow) {
+ r_cnjg(&q__1, &x[nxfrm + irow]);
+ cscal_(n, &q__1, &a[irow + a_dim1], lda);
+/* L70: */
+ }
+ }
+
+ if (itype == 2 || itype == 3) {
+ i__1 = *n;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ cscal_(m, &x[nxfrm + jcol], &a[jcol * a_dim1 + 1], &c__1);
+/* L80: */
+ }
+ }
+
+ if (itype == 4) {
+ i__1 = *n;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ r_cnjg(&q__1, &x[nxfrm + jcol]);
+ cscal_(m, &q__1, &a[jcol * a_dim1 + 1], &c__1);
+/* L90: */
+ }
+ }
+ return 0;
+
+/* End of CLAROR */
+
+} /* claror_ */
diff --git a/TESTING/MATGEN/clarot.c b/TESTING/MATGEN/clarot.c
new file mode 100644
index 0000000..9e2d21e
--- /dev/null
+++ b/TESTING/MATGEN/clarot.c
@@ -0,0 +1,374 @@
+/* clarot.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__4 = 4;
+static integer c__8 = 8;
+
+/* Subroutine */ int clarot_(logical *lrows, logical *lleft, logical *lright,
+ integer *nl, complex *c__, complex *s, complex *a, integer *lda,
+ complex *xleft, complex *xright)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ complex q__1, q__2, q__3, q__4, q__5, q__6;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer j, ix, iy, nt;
+ complex xt[2], yt[2];
+ integer iyt, iinc, inext;
+ complex tempx;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLAROT applies a (Givens) rotation to two adjacent rows or */
+/* columns, where one element of the first and/or last column/row */
+/* for use on matrices stored in some format other than GE, so */
+/* that elements of the matrix may be used or modified for which */
+/* no array element is provided. */
+
+/* One example is a symmetric matrix in SB format (bandwidth=4), for */
+/* which UPLO='L': Two adjacent rows will have the format: */
+
+/* row j: * * * * * . . . . */
+/* row j+1: * * * * * . . . . */
+
+/* '*' indicates elements for which storage is provided, */
+/* '.' indicates elements for which no storage is provided, but */
+/* are not necessarily zero; their values are determined by */
+/* symmetry. ' ' indicates elements which are necessarily zero, */
+/* and have no storage provided. */
+
+/* Those columns which have two '*'s can be handled by SROT. */
+/* Those columns which have no '*'s can be ignored, since as long */
+/* as the Givens rotations are carefully applied to preserve */
+/* symmetry, their values are determined. */
+/* Those columns which have one '*' have to be handled separately, */
+/* by using separate variables "p" and "q": */
+
+/* row j: * * * * * p . . . */
+/* row j+1: q * * * * * . . . . */
+
+/* The element p would have to be set correctly, then that column */
+/* is rotated, setting p to its new value. The next call to */
+/* CLAROT would rotate columns j and j+1, using p, and restore */
+/* symmetry. The element q would start out being zero, and be */
+/* made non-zero by the rotation. Later, rotations would presumably */
+/* be chosen to zero q out. */
+
+/* Typical Calling Sequences: rotating the i-th and (i+1)-st rows. */
+/* ------- ------- --------- */
+
+/* General dense matrix: */
+
+/* CALL CLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S, */
+/* A(i,1),LDA, DUMMY, DUMMY) */
+
+/* General banded matrix in GB format: */
+
+/* j = MAX(1, i-KL ) */
+/* NL = MIN( N, i+KU+1 ) + 1-j */
+/* CALL CLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S, */
+/* A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT ) */
+
+/* [ note that i+1-j is just MIN(i,KL+1) ] */
+
+/* Symmetric banded matrix in SY format, bandwidth K, */
+/* lower triangle only: */
+
+/* j = MAX(1, i-K ) */
+/* NL = MIN( K+1, i ) + 1 */
+/* CALL CLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S, */
+/* A(i,j), LDA, XLEFT, XRIGHT ) */
+
+/* Same, but upper triangle only: */
+
+/* NL = MIN( K+1, N-i ) + 1 */
+/* CALL CLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S, */
+/* A(i,i), LDA, XLEFT, XRIGHT ) */
+
+/* Symmetric banded matrix in SB format, bandwidth K, */
+/* lower triangle only: */
+
+/* [ same as for SY, except:] */
+/* . . . . */
+/* A(i+1-j,j), LDA-1, XLEFT, XRIGHT ) */
+
+/* [ note that i+1-j is just MIN(i,K+1) ] */
+
+/* Same, but upper triangle only: */
+/* . . . */
+/* A(K+1,i), LDA-1, XLEFT, XRIGHT ) */
+
+/* Rotating columns is just the transpose of rotating rows, except */
+/* for GB and SB: (rotating columns i and i+1) */
+
+/* GB: */
+/* j = MAX(1, i-KU ) */
+/* NL = MIN( N, i+KL+1 ) + 1-j */
+/* CALL CLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S, */
+/* A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM ) */
+
+/* [note that KU+j+1-i is just MAX(1,KU+2-i)] */
+
+/* SB: (upper triangle) */
+
+/* . . . . . . */
+/* A(K+j+1-i,i),LDA-1, XTOP, XBOTTM ) */
+
+/* SB: (lower triangle) */
+
+/* . . . . . . */
+/* A(1,i),LDA-1, XTOP, XBOTTM ) */
+
+/* Arguments */
+/* ========= */
+
+/* LROWS - LOGICAL */
+/* If .TRUE., then CLAROT will rotate two rows. If .FALSE., */
+/* then it will rotate two columns. */
+/* Not modified. */
+
+/* LLEFT - LOGICAL */
+/* If .TRUE., then XLEFT will be used instead of the */
+/* corresponding element of A for the first element in the */
+/* second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) */
+/* If .FALSE., then the corresponding element of A will be */
+/* used. */
+/* Not modified. */
+
+/* LRIGHT - LOGICAL */
+/* If .TRUE., then XRIGHT will be used instead of the */
+/* corresponding element of A for the last element in the */
+/* first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If */
+/* .FALSE., then the corresponding element of A will be used. */
+/* Not modified. */
+
+/* NL - INTEGER */
+/* The length of the rows (if LROWS=.TRUE.) or columns (if */
+/* LROWS=.FALSE.) to be rotated. If XLEFT and/or XRIGHT are */
+/* used, the columns/rows they are in should be included in */
+/* NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at */
+/* least 2. The number of rows/columns to be rotated */
+/* exclusive of those involving XLEFT and/or XRIGHT may */
+/* not be negative, i.e., NL minus how many of LLEFT and */
+/* LRIGHT are .TRUE. must be at least zero; if not, XERBLA */
+/* will be called. */
+/* Not modified. */
+
+/* C, S - COMPLEX */
+/* Specify the Givens rotation to be applied. If LROWS is */
+/* true, then the matrix ( c s ) */
+/* ( _ _ ) */
+/* (-s c ) is applied from the left; */
+/* if false, then the transpose (not conjugated) thereof is */
+/* applied from the right. Note that in contrast to the */
+/* output of CROTG or to most versions of CROT, both C and S */
+/* are complex. For a Givens rotation, |C|**2 + |S|**2 should */
+/* be 1, but this is not checked. */
+/* Not modified. */
+
+/* A - COMPLEX array. */
+/* The array containing the rows/columns to be rotated. The */
+/* first element of A should be the upper left element to */
+/* be rotated. */
+/* Read and modified. */
+
+/* LDA - INTEGER */
+/* The "effective" leading dimension of A. If A contains */
+/* a matrix stored in GE, HE, or SY format, then this is just */
+/* the leading dimension of A as dimensioned in the calling */
+/* routine. If A contains a matrix stored in band (GB, HB, or */
+/* SB) format, then this should be *one less* than the leading */
+/* dimension used in the calling routine. Thus, if A were */
+/* dimensioned A(LDA,*) in CLAROT, then A(1,j) would be the */
+/* j-th element in the first of the two rows to be rotated, */
+/* and A(2,j) would be the j-th in the second, regardless of */
+/* how the array may be stored in the calling routine. [A */
+/* cannot, however, actually be dimensioned thus, since for */
+/* band format, the row number may exceed LDA, which is not */
+/* legal FORTRAN.] */
+/* If LROWS=.TRUE., then LDA must be at least 1, otherwise */
+/* it must be at least NL minus the number of .TRUE. values */
+/* in XLEFT and XRIGHT. */
+/* Not modified. */
+
+/* XLEFT - COMPLEX */
+/* If LLEFT is .TRUE., then XLEFT will be used and modified */
+/* instead of A(2,1) (if LROWS=.TRUE.) or A(1,2) */
+/* (if LROWS=.FALSE.). */
+/* Read and modified. */
+
+/* XRIGHT - COMPLEX */
+/* If LRIGHT is .TRUE., then XRIGHT will be used and modified */
+/* instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1) */
+/* (if LROWS=.FALSE.). */
+/* Read and modified. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Set up indices, arrays for ends */
+
+ /* Parameter adjustments */
+ --a;
+
+ /* Function Body */
+ if (*lrows) {
+ iinc = *lda;
+ inext = 1;
+ } else {
+ iinc = 1;
+ inext = *lda;
+ }
+
+ if (*lleft) {
+ nt = 1;
+ ix = iinc + 1;
+ iy = *lda + 2;
+ xt[0].r = a[1].r, xt[0].i = a[1].i;
+ yt[0].r = xleft->r, yt[0].i = xleft->i;
+ } else {
+ nt = 0;
+ ix = 1;
+ iy = inext + 1;
+ }
+
+ if (*lright) {
+ iyt = inext + 1 + (*nl - 1) * iinc;
+ ++nt;
+ i__1 = nt - 1;
+ xt[i__1].r = xright->r, xt[i__1].i = xright->i;
+ i__1 = nt - 1;
+ i__2 = iyt;
+ yt[i__1].r = a[i__2].r, yt[i__1].i = a[i__2].i;
+ }
+
+/* Check for errors */
+
+ if (*nl < nt) {
+ xerbla_("CLAROT", &c__4);
+ return 0;
+ }
+ if (*lda <= 0 || ! (*lrows) && *lda < *nl - nt) {
+ xerbla_("CLAROT", &c__8);
+ return 0;
+ }
+
+/* Rotate */
+
+/* CROT( NL-NT, A(IX),IINC, A(IY),IINC, C, S ) with complex C, S */
+
+ i__1 = *nl - nt - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = ix + j * iinc;
+ q__2.r = c__->r * a[i__2].r - c__->i * a[i__2].i, q__2.i = c__->r * a[
+ i__2].i + c__->i * a[i__2].r;
+ i__3 = iy + j * iinc;
+ q__3.r = s->r * a[i__3].r - s->i * a[i__3].i, q__3.i = s->r * a[i__3]
+ .i + s->i * a[i__3].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ tempx.r = q__1.r, tempx.i = q__1.i;
+ i__2 = iy + j * iinc;
+ r_cnjg(&q__4, s);
+ q__3.r = -q__4.r, q__3.i = -q__4.i;
+ i__3 = ix + j * iinc;
+ q__2.r = q__3.r * a[i__3].r - q__3.i * a[i__3].i, q__2.i = q__3.r * a[
+ i__3].i + q__3.i * a[i__3].r;
+ r_cnjg(&q__6, c__);
+ i__4 = iy + j * iinc;
+ q__5.r = q__6.r * a[i__4].r - q__6.i * a[i__4].i, q__5.i = q__6.r * a[
+ i__4].i + q__6.i * a[i__4].r;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ i__2 = ix + j * iinc;
+ a[i__2].r = tempx.r, a[i__2].i = tempx.i;
+/* L10: */
+ }
+
+/* CROT( NT, XT,1, YT,1, C, S ) with complex C, S */
+
+ i__1 = nt;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ q__2.r = c__->r * xt[i__2].r - c__->i * xt[i__2].i, q__2.i = c__->r *
+ xt[i__2].i + c__->i * xt[i__2].r;
+ i__3 = j - 1;
+ q__3.r = s->r * yt[i__3].r - s->i * yt[i__3].i, q__3.i = s->r * yt[
+ i__3].i + s->i * yt[i__3].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ tempx.r = q__1.r, tempx.i = q__1.i;
+ i__2 = j - 1;
+ r_cnjg(&q__4, s);
+ q__3.r = -q__4.r, q__3.i = -q__4.i;
+ i__3 = j - 1;
+ q__2.r = q__3.r * xt[i__3].r - q__3.i * xt[i__3].i, q__2.i = q__3.r *
+ xt[i__3].i + q__3.i * xt[i__3].r;
+ r_cnjg(&q__6, c__);
+ i__4 = j - 1;
+ q__5.r = q__6.r * yt[i__4].r - q__6.i * yt[i__4].i, q__5.i = q__6.r *
+ yt[i__4].i + q__6.i * yt[i__4].r;
+ q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+ yt[i__2].r = q__1.r, yt[i__2].i = q__1.i;
+ i__2 = j - 1;
+ xt[i__2].r = tempx.r, xt[i__2].i = tempx.i;
+/* L20: */
+ }
+
+/* Stuff values back into XLEFT, XRIGHT, etc. */
+
+ if (*lleft) {
+ a[1].r = xt[0].r, a[1].i = xt[0].i;
+ xleft->r = yt[0].r, xleft->i = yt[0].i;
+ }
+
+ if (*lright) {
+ i__1 = nt - 1;
+ xright->r = xt[i__1].r, xright->i = xt[i__1].i;
+ i__1 = iyt;
+ i__2 = nt - 1;
+ a[i__1].r = yt[i__2].r, a[i__1].i = yt[i__2].i;
+ }
+
+ return 0;
+
+/* End of CLAROT */
+
+} /* clarot_ */
diff --git a/TESTING/MATGEN/clatm1.c b/TESTING/MATGEN/clatm1.c
new file mode 100644
index 0000000..ac5bb1a
--- /dev/null
+++ b/TESTING/MATGEN/clatm1.c
@@ -0,0 +1,315 @@
+/* clatm1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+
+/* Subroutine */ int clatm1_(integer *mode, real *cond, integer *irsign,
+ integer *idist, integer *iseed, complex *d__, integer *n, integer *
+ info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ real r__1;
+ doublereal d__1, d__2;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double pow_dd(doublereal *, doublereal *), pow_ri(real *, integer *), log(
+ doublereal), exp(doublereal), c_abs(complex *);
+
+ /* Local variables */
+ integer i__;
+ real temp, alpha;
+ complex ctemp;
+ extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal slaran_(integer *);
+ extern /* Subroutine */ int clarnv_(integer *, integer *, integer *,
+ complex *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLATM1 computes the entries of D(1..N) as specified by */
+/* MODE, COND and IRSIGN. IDIST and ISEED determine the generation */
+/* of random numbers. CLATM1 is called by CLATMR to generate */
+/* random test matrices for LAPACK programs. */
+
+/* Arguments */
+/* ========= */
+
+/* MODE - INTEGER */
+/* On entry describes how D is to be computed: */
+/* MODE = 0 means do not change D. */
+/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
+/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
+/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
+/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* MODE = 5 sets D to random numbers in the range */
+/* ( 1/COND , 1 ) such that their logarithms */
+/* are uniformly distributed. */
+/* MODE = 6 set D to random numbers from same distribution */
+/* as the rest of the matrix. */
+/* MODE < 0 has the same meaning as ABS(MODE), except that */
+/* the order of the elements of D is reversed. */
+/* Thus if MODE is positive, D has entries ranging from */
+/* 1 to 1/COND, if negative, from 1/COND to 1, */
+/* Not modified. */
+
+/* COND - REAL */
+/* On entry, used as described under MODE above. */
+/* If used, it must be >= 1. Not modified. */
+
+/* IRSIGN - INTEGER */
+/* On entry, if MODE neither -6, 0 nor 6, determines sign of */
+/* entries of D */
+/* 0 => leave entries of D unchanged */
+/* 1 => multiply each entry of D by random complex number */
+/* uniformly distributed with absolute value 1 */
+
+/* IDIST - CHARACTER*1 */
+/* On entry, IDIST specifies the type of distribution to be */
+/* used to generate a random matrix . */
+/* 1 => real and imaginary parts each UNIFORM( 0, 1 ) */
+/* 2 => real and imaginary parts each UNIFORM( -1, 1 ) */
+/* 3 => real and imaginary parts each NORMAL( 0, 1 ) */
+/* 4 => complex number uniform in DISK( 0, 1 ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension ( 4 ) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The random number generator uses a */
+/* linear congruential sequence limited to small */
+/* integers, and so should produce machine independent */
+/* random numbers. The values of ISEED are changed on */
+/* exit, and can be used in the next call to CLATM1 */
+/* to continue the same random number sequence. */
+/* Changed on exit. */
+
+/* D - COMPLEX array, dimension ( MIN( M , N ) ) */
+/* Array to be computed according to MODE, COND and IRSIGN. */
+/* May be changed on exit if MODE is nonzero. */
+
+/* N - INTEGER */
+/* Number of entries of D. Not modified. */
+
+/* INFO - INTEGER */
+/* 0 => normal termination */
+/* -1 => if MODE not in range -6 to 6 */
+/* -2 => if MODE neither -6, 0 nor 6, and */
+/* IRSIGN neither 0 nor 1 */
+/* -3 => if MODE neither -6, 0 nor 6 and COND less than 1 */
+/* -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 4 */
+/* -7 => if N negative */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and Test the input parameters. Initialize flags & seed. */
+
+ /* Parameter adjustments */
+ --d__;
+ --iseed;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Set INFO if an error */
+
+ if (*mode < -6 || *mode > 6) {
+ *info = -1;
+ } else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && *
+ irsign != 1)) {
+ *info = -2;
+ } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.f) {
+ *info = -3;
+ } else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 4)) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -7;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLATM1", &i__1);
+ return 0;
+ }
+
+/* Compute D according to COND and MODE */
+
+ if (*mode != 0) {
+ switch (abs(*mode)) {
+ case 1: goto L10;
+ case 2: goto L30;
+ case 3: goto L50;
+ case 4: goto L70;
+ case 5: goto L90;
+ case 6: goto L110;
+ }
+
+/* One large D value: */
+
+L10:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ r__1 = 1.f / *cond;
+ d__[i__2].r = r__1, d__[i__2].i = 0.f;
+/* L20: */
+ }
+ d__[1].r = 1.f, d__[1].i = 0.f;
+ goto L120;
+
+/* One small D value: */
+
+L30:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ d__[i__2].r = 1.f, d__[i__2].i = 0.f;
+/* L40: */
+ }
+ i__1 = *n;
+ r__1 = 1.f / *cond;
+ d__[i__1].r = r__1, d__[i__1].i = 0.f;
+ goto L120;
+
+/* Exponentially distributed D values: */
+
+L50:
+ d__[1].r = 1.f, d__[1].i = 0.f;
+ if (*n > 1) {
+ d__1 = (doublereal) (*cond);
+ d__2 = (doublereal) (-1.f / (real) (*n - 1));
+ alpha = pow_dd(&d__1, &d__2);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__ - 1;
+ r__1 = pow_ri(&alpha, &i__3);
+ d__[i__2].r = r__1, d__[i__2].i = 0.f;
+/* L60: */
+ }
+ }
+ goto L120;
+
+/* Arithmetically distributed D values: */
+
+L70:
+ d__[1].r = 1.f, d__[1].i = 0.f;
+ if (*n > 1) {
+ temp = 1.f / *cond;
+ alpha = (1.f - temp) / (real) (*n - 1);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ r__1 = (real) (*n - i__) * alpha + temp;
+ d__[i__2].r = r__1, d__[i__2].i = 0.f;
+/* L80: */
+ }
+ }
+ goto L120;
+
+/* Randomly distributed D values on ( 1/COND , 1): */
+
+L90:
+ alpha = log(1.f / *cond);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ r__1 = exp(alpha * slaran_(&iseed[1]));
+ d__[i__2].r = r__1, d__[i__2].i = 0.f;
+/* L100: */
+ }
+ goto L120;
+
+/* Randomly distributed D values from IDIST */
+
+L110:
+ clarnv_(idist, &iseed[1], n, &d__[1]);
+
+L120:
+
+/* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */
+/* random signs to D */
+
+ if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ clarnd_(&q__1, &c__3, &iseed[1]);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__2 = i__;
+ i__3 = i__;
+ r__1 = c_abs(&ctemp);
+ q__2.r = ctemp.r / r__1, q__2.i = ctemp.i / r__1;
+ q__1.r = d__[i__3].r * q__2.r - d__[i__3].i * q__2.i, q__1.i =
+ d__[i__3].r * q__2.i + d__[i__3].i * q__2.r;
+ d__[i__2].r = q__1.r, d__[i__2].i = q__1.i;
+/* L130: */
+ }
+ }
+
+/* Reverse if MODE < 0 */
+
+ if (*mode < 0) {
+ i__1 = *n / 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ ctemp.r = d__[i__2].r, ctemp.i = d__[i__2].i;
+ i__2 = i__;
+ i__3 = *n + 1 - i__;
+ d__[i__2].r = d__[i__3].r, d__[i__2].i = d__[i__3].i;
+ i__2 = *n + 1 - i__;
+ d__[i__2].r = ctemp.r, d__[i__2].i = ctemp.i;
+/* L140: */
+ }
+ }
+
+ }
+
+ return 0;
+
+/* End of CLATM1 */
+
+} /* clatm1_ */
diff --git a/TESTING/MATGEN/clatm2.c b/TESTING/MATGEN/clatm2.c
new file mode 100644
index 0000000..0d072be
--- /dev/null
+++ b/TESTING/MATGEN/clatm2.c
@@ -0,0 +1,295 @@
+/* clatm2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Complex */ VOID clatm2_(complex * ret_val, integer *m, integer *n, integer
+ *i__, integer *j, integer *kl, integer *ku, integer *idist, integer *
+ iseed, complex *d__, integer *igrade, complex *dl, complex *dr,
+ integer *ipvtng, integer *iwork, real *sparse)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer isub, jsub;
+ complex ctemp;
+ extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+ extern doublereal slaran_(integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+
+/* .. */
+
+/* .. Array Arguments .. */
+
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLATM2 returns the (I,J) entry of a random matrix of dimension */
+/* (M, N) described by the other paramters. It is called by the */
+/* CLATMR routine in order to build random test matrices. No error */
+/* checking on parameters is done, because this routine is called in */
+/* a tight loop by CLATMR which has already checked the parameters. */
+
+/* Use of CLATM2 differs from CLATM3 in the order in which the random */
+/* number generator is called to fill in random matrix entries. */
+/* With CLATM2, the generator is called to fill in the pivoted matrix */
+/* columnwise. With CLATM3, the generator is called to fill in the */
+/* matrix columnwise, after which it is pivoted. Thus, CLATM3 can */
+/* be used to construct random matrices which differ only in their */
+/* order of rows and/or columns. CLATM2 is used to construct band */
+/* matrices while avoiding calling the random number generator for */
+/* entries outside the band (and therefore generating random numbers */
+
+/* The matrix whose (I,J) entry is returned is constructed as */
+/* follows (this routine only computes one entry): */
+
+/* If I is outside (1..M) or J is outside (1..N), return zero */
+/* (this is convenient for generating matrices in band format). */
+
+/* Generate a matrix A with random entries of distribution IDIST. */
+
+/* Set the diagonal to D. */
+
+/* Grade the matrix, if desired, from the left (by DL) and/or */
+/* from the right (by DR or DL) as specified by IGRADE. */
+
+/* Permute, if desired, the rows and/or columns as specified by */
+/* IPVTNG and IWORK. */
+
+/* Band the matrix to have lower bandwidth KL and upper */
+/* bandwidth KU. */
+
+/* Set random entries to zero as specified by SPARSE. */
+
+/* Arguments */
+/* ========= */
+
+/* M - INTEGER */
+/* Number of rows of matrix. Not modified. */
+
+/* N - INTEGER */
+/* Number of columns of matrix. Not modified. */
+
+/* I - INTEGER */
+/* Row of entry to be returned. Not modified. */
+
+/* J - INTEGER */
+/* Column of entry to be returned. Not modified. */
+
+/* KL - INTEGER */
+/* Lower bandwidth. Not modified. */
+
+/* KU - INTEGER */
+/* Upper bandwidth. Not modified. */
+
+/* IDIST - INTEGER */
+/* On entry, IDIST specifies the type of distribution to be */
+/* used to generate a random matrix . */
+/* 1 => real and imaginary parts each UNIFORM( 0, 1 ) */
+/* 2 => real and imaginary parts each UNIFORM( -1, 1 ) */
+/* 3 => real and imaginary parts each NORMAL( 0, 1 ) */
+/* 4 => complex number uniform in DISK( 0 , 1 ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array of dimension ( 4 ) */
+/* Seed for random number generator. */
+/* Changed on exit. */
+
+/* D - COMPLEX array of dimension ( MIN( I , J ) ) */
+/* Diagonal entries of matrix. Not modified. */
+
+/* IGRADE - INTEGER */
+/* Specifies grading of matrix as follows: */
+/* 0 => no grading */
+/* 1 => matrix premultiplied by diag( DL ) */
+/* 2 => matrix postmultiplied by diag( DR ) */
+/* 3 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DR ) */
+/* 4 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by inv( diag( DL ) ) */
+/* 5 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( CONJG(DL) ) */
+/* 6 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DL ) */
+/* Not modified. */
+
+/* DL - COMPLEX array ( I or J, as appropriate ) */
+/* Left scale factors for grading matrix. Not modified. */
+
+/* DR - COMPLEX array ( I or J, as appropriate ) */
+/* Right scale factors for grading matrix. Not modified. */
+
+/* IPVTNG - INTEGER */
+/* On entry specifies pivoting permutations as follows: */
+/* 0 => none. */
+/* 1 => row pivoting. */
+/* 2 => column pivoting. */
+/* 3 => full pivoting, i.e., on both sides. */
+/* Not modified. */
+
+/* IWORK - INTEGER array ( I or J, as appropriate ) */
+/* This array specifies the permutation used. The */
+/* row (or column) in position K was originally in */
+/* position IWORK( K ). */
+/* This differs from IWORK for CLATM3. Not modified. */
+
+/* SPARSE - REAL between 0. and 1. */
+/* On entry specifies the sparsity of the matrix */
+/* if sparse matix is to be generated. */
+/* SPARSE should lie between 0 and 1. */
+/* A uniform ( 0, 1 ) random number x is generated and */
+/* compared to SPARSE; if x is larger the matrix entry */
+/* is unchanged and if x is smaller the entry is set */
+/* to zero. Thus on the average a fraction SPARSE of the */
+/* entries will be set to zero. */
+/* Not modified. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+
+/* .. */
+
+/* .. Local Scalars .. */
+
+/* .. */
+
+/* .. External Functions .. */
+
+/* .. */
+
+/* .. Intrinsic Functions .. */
+
+/* .. */
+
+/* ----------------------------------------------------------------------- */
+
+/* .. Executable Statements .. */
+
+
+/* Check for I and J in range */
+
+ /* Parameter adjustments */
+ --iwork;
+ --dr;
+ --dl;
+ --d__;
+ --iseed;
+
+ /* Function Body */
+ if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) {
+ ret_val->r = 0.f, ret_val->i = 0.f;
+ return ;
+ }
+
+/* Check for banding */
+
+ if (*j > *i__ + *ku || *j < *i__ - *kl) {
+ ret_val->r = 0.f, ret_val->i = 0.f;
+ return ;
+ }
+
+/* Check for sparsity */
+
+ if (*sparse > 0.f) {
+ if (slaran_(&iseed[1]) < *sparse) {
+ ret_val->r = 0.f, ret_val->i = 0.f;
+ return ;
+ }
+ }
+
+/* Compute subscripts depending on IPVTNG */
+
+ if (*ipvtng == 0) {
+ isub = *i__;
+ jsub = *j;
+ } else if (*ipvtng == 1) {
+ isub = iwork[*i__];
+ jsub = *j;
+ } else if (*ipvtng == 2) {
+ isub = *i__;
+ jsub = iwork[*j];
+ } else if (*ipvtng == 3) {
+ isub = iwork[*i__];
+ jsub = iwork[*j];
+ }
+
+/* Compute entry and grade it according to IGRADE */
+
+ if (isub == jsub) {
+ i__1 = isub;
+ ctemp.r = d__[i__1].r, ctemp.i = d__[i__1].i;
+ } else {
+ clarnd_(&q__1, idist, &iseed[1]);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ }
+ if (*igrade == 1) {
+ i__1 = isub;
+ q__1.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__1.i =
+ ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ } else if (*igrade == 2) {
+ i__1 = jsub;
+ q__1.r = ctemp.r * dr[i__1].r - ctemp.i * dr[i__1].i, q__1.i =
+ ctemp.r * dr[i__1].i + ctemp.i * dr[i__1].r;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ } else if (*igrade == 3) {
+ i__1 = isub;
+ q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i =
+ ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+ i__2 = jsub;
+ q__1.r = q__2.r * dr[i__2].r - q__2.i * dr[i__2].i, q__1.i = q__2.r *
+ dr[i__2].i + q__2.i * dr[i__2].r;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ } else if (*igrade == 4 && isub != jsub) {
+ i__1 = isub;
+ q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i =
+ ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+ c_div(&q__1, &q__2, &dl[jsub]);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ } else if (*igrade == 5) {
+ i__1 = isub;
+ q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i =
+ ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+ r_cnjg(&q__3, &dl[jsub]);
+ q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * q__3.i
+ + q__2.i * q__3.r;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ } else if (*igrade == 6) {
+ i__1 = isub;
+ q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i =
+ ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+ i__2 = jsub;
+ q__1.r = q__2.r * dl[i__2].r - q__2.i * dl[i__2].i, q__1.i = q__2.r *
+ dl[i__2].i + q__2.i * dl[i__2].r;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ }
+ ret_val->r = ctemp.r, ret_val->i = ctemp.i;
+ return ;
+
+/* End of CLATM2 */
+
+} /* clatm2_ */
diff --git a/TESTING/MATGEN/clatm3.c b/TESTING/MATGEN/clatm3.c
new file mode 100644
index 0000000..7622707
--- /dev/null
+++ b/TESTING/MATGEN/clatm3.c
@@ -0,0 +1,306 @@
+/* clatm3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Complex */ VOID clatm3_(complex * ret_val, integer *m, integer *n, integer
+ *i__, integer *j, integer *isub, integer *jsub, integer *kl, integer *
+ ku, integer *idist, integer *iseed, complex *d__, integer *igrade,
+ complex *dl, complex *dr, integer *ipvtng, integer *iwork, real *
+ sparse)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ complex q__1, q__2, q__3;
+
+ /* Builtin functions */
+ void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ complex ctemp;
+ extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+ extern doublereal slaran_(integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+
+/* .. */
+
+/* .. Array Arguments .. */
+
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLATM3 returns the (ISUB,JSUB) entry of a random matrix of */
+/* dimension (M, N) described by the other paramters. (ISUB,JSUB) */
+/* is the final position of the (I,J) entry after pivoting */
+/* according to IPVTNG and IWORK. CLATM3 is called by the */
+/* CLATMR routine in order to build random test matrices. No error */
+/* checking on parameters is done, because this routine is called in */
+/* a tight loop by CLATMR which has already checked the parameters. */
+
+/* Use of CLATM3 differs from CLATM2 in the order in which the random */
+/* number generator is called to fill in random matrix entries. */
+/* With CLATM2, the generator is called to fill in the pivoted matrix */
+/* columnwise. With CLATM3, the generator is called to fill in the */
+/* matrix columnwise, after which it is pivoted. Thus, CLATM3 can */
+/* be used to construct random matrices which differ only in their */
+/* order of rows and/or columns. CLATM2 is used to construct band */
+/* matrices while avoiding calling the random number generator for */
+/* entries outside the band (and therefore generating random numbers */
+/* in different orders for different pivot orders). */
+
+/* The matrix whose (ISUB,JSUB) entry is returned is constructed as */
+/* follows (this routine only computes one entry): */
+
+/* If ISUB is outside (1..M) or JSUB is outside (1..N), return zero */
+/* (this is convenient for generating matrices in band format). */
+
+/* Generate a matrix A with random entries of distribution IDIST. */
+
+/* Set the diagonal to D. */
+
+/* Grade the matrix, if desired, from the left (by DL) and/or */
+/* from the right (by DR or DL) as specified by IGRADE. */
+
+/* Permute, if desired, the rows and/or columns as specified by */
+/* IPVTNG and IWORK. */
+
+/* Band the matrix to have lower bandwidth KL and upper */
+/* bandwidth KU. */
+
+/* Set random entries to zero as specified by SPARSE. */
+
+/* Arguments */
+/* ========= */
+
+/* M - INTEGER */
+/* Number of rows of matrix. Not modified. */
+
+/* N - INTEGER */
+/* Number of columns of matrix. Not modified. */
+
+/* I - INTEGER */
+/* Row of unpivoted entry to be returned. Not modified. */
+
+/* J - INTEGER */
+/* Column of unpivoted entry to be returned. Not modified. */
+
+/* ISUB - INTEGER */
+/* Row of pivoted entry to be returned. Changed on exit. */
+
+/* JSUB - INTEGER */
+/* Column of pivoted entry to be returned. Changed on exit. */
+
+/* KL - INTEGER */
+/* Lower bandwidth. Not modified. */
+
+/* KU - INTEGER */
+/* Upper bandwidth. Not modified. */
+
+/* IDIST - INTEGER */
+/* On entry, IDIST specifies the type of distribution to be */
+/* used to generate a random matrix . */
+/* 1 => real and imaginary parts each UNIFORM( 0, 1 ) */
+/* 2 => real and imaginary parts each UNIFORM( -1, 1 ) */
+/* 3 => real and imaginary parts each NORMAL( 0, 1 ) */
+/* 4 => complex number uniform in DISK( 0 , 1 ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array of dimension ( 4 ) */
+/* Seed for random number generator. */
+/* Changed on exit. */
+
+/* D - COMPLEX array of dimension ( MIN( I , J ) ) */
+/* Diagonal entries of matrix. Not modified. */
+
+/* IGRADE - INTEGER */
+/* Specifies grading of matrix as follows: */
+/* 0 => no grading */
+/* 1 => matrix premultiplied by diag( DL ) */
+/* 2 => matrix postmultiplied by diag( DR ) */
+/* 3 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DR ) */
+/* 4 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by inv( diag( DL ) ) */
+/* 5 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( CONJG(DL) ) */
+/* 6 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DL ) */
+/* Not modified. */
+
+/* DL - COMPLEX array ( I or J, as appropriate ) */
+/* Left scale factors for grading matrix. Not modified. */
+
+/* DR - COMPLEX array ( I or J, as appropriate ) */
+/* Right scale factors for grading matrix. Not modified. */
+
+/* IPVTNG - INTEGER */
+/* On entry specifies pivoting permutations as follows: */
+/* 0 => none. */
+/* 1 => row pivoting. */
+/* 2 => column pivoting. */
+/* 3 => full pivoting, i.e., on both sides. */
+/* Not modified. */
+
+/* IWORK - INTEGER array ( I or J, as appropriate ) */
+/* This array specifies the permutation used. The */
+/* row (or column) originally in position K is in */
+/* position IWORK( K ) after pivoting. */
+/* This differs from IWORK for CLATM2. Not modified. */
+
+/* SPARSE - REAL between 0. and 1. */
+/* On entry specifies the sparsity of the matrix */
+/* if sparse matix is to be generated. */
+/* SPARSE should lie between 0 and 1. */
+/* A uniform ( 0, 1 ) random number x is generated and */
+/* compared to SPARSE; if x is larger the matrix entry */
+/* is unchanged and if x is smaller the entry is set */
+/* to zero. Thus on the average a fraction SPARSE of the */
+/* entries will be set to zero. */
+/* Not modified. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+
+/* .. */
+
+/* .. Local Scalars .. */
+
+/* .. */
+
+/* .. External Functions .. */
+
+/* .. */
+
+/* .. Intrinsic Functions .. */
+
+/* .. */
+
+/* ----------------------------------------------------------------------- */
+
+/* .. Executable Statements .. */
+
+
+/* Check for I and J in range */
+
+ /* Parameter adjustments */
+ --iwork;
+ --dr;
+ --dl;
+ --d__;
+ --iseed;
+
+ /* Function Body */
+ if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) {
+ *isub = *i__;
+ *jsub = *j;
+ ret_val->r = 0.f, ret_val->i = 0.f;
+ return ;
+ }
+
+/* Compute subscripts depending on IPVTNG */
+
+ if (*ipvtng == 0) {
+ *isub = *i__;
+ *jsub = *j;
+ } else if (*ipvtng == 1) {
+ *isub = iwork[*i__];
+ *jsub = *j;
+ } else if (*ipvtng == 2) {
+ *isub = *i__;
+ *jsub = iwork[*j];
+ } else if (*ipvtng == 3) {
+ *isub = iwork[*i__];
+ *jsub = iwork[*j];
+ }
+
+/* Check for banding */
+
+ if (*jsub > *isub + *ku || *jsub < *isub - *kl) {
+ ret_val->r = 0.f, ret_val->i = 0.f;
+ return ;
+ }
+
+/* Check for sparsity */
+
+ if (*sparse > 0.f) {
+ if (slaran_(&iseed[1]) < *sparse) {
+ ret_val->r = 0.f, ret_val->i = 0.f;
+ return ;
+ }
+ }
+
+/* Compute entry and grade it according to IGRADE */
+
+ if (*i__ == *j) {
+ i__1 = *i__;
+ ctemp.r = d__[i__1].r, ctemp.i = d__[i__1].i;
+ } else {
+ clarnd_(&q__1, idist, &iseed[1]);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ }
+ if (*igrade == 1) {
+ i__1 = *i__;
+ q__1.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__1.i =
+ ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ } else if (*igrade == 2) {
+ i__1 = *j;
+ q__1.r = ctemp.r * dr[i__1].r - ctemp.i * dr[i__1].i, q__1.i =
+ ctemp.r * dr[i__1].i + ctemp.i * dr[i__1].r;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ } else if (*igrade == 3) {
+ i__1 = *i__;
+ q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i =
+ ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+ i__2 = *j;
+ q__1.r = q__2.r * dr[i__2].r - q__2.i * dr[i__2].i, q__1.i = q__2.r *
+ dr[i__2].i + q__2.i * dr[i__2].r;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ } else if (*igrade == 4 && *i__ != *j) {
+ i__1 = *i__;
+ q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i =
+ ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+ c_div(&q__1, &q__2, &dl[*j]);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ } else if (*igrade == 5) {
+ i__1 = *i__;
+ q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i =
+ ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+ r_cnjg(&q__3, &dl[*j]);
+ q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * q__3.i
+ + q__2.i * q__3.r;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ } else if (*igrade == 6) {
+ i__1 = *i__;
+ q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i =
+ ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+ i__2 = *j;
+ q__1.r = q__2.r * dl[i__2].r - q__2.i * dl[i__2].i, q__1.i = q__2.r *
+ dl[i__2].i + q__2.i * dl[i__2].r;
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ }
+ ret_val->r = ctemp.r, ret_val->i = ctemp.i;
+ return ;
+
+/* End of CLATM3 */
+
+} /* clatm3_ */
diff --git a/TESTING/MATGEN/clatm5.c b/TESTING/MATGEN/clatm5.c
new file mode 100644
index 0000000..61ba547
--- /dev/null
+++ b/TESTING/MATGEN/clatm5.c
@@ -0,0 +1,693 @@
+/* clatm5.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {1.f,0.f};
+static complex c_b3 = {0.f,0.f};
+static complex c_b5 = {20.f,0.f};
+
+/* Subroutine */ int clatm5_(integer *prtype, integer *m, integer *n, complex
+ *a, integer *lda, complex *b, integer *ldb, complex *c__, integer *
+ ldc, complex *d__, integer *ldd, complex *e, integer *lde, complex *f,
+ integer *ldf, complex *r__, integer *ldr, complex *l, integer *ldl,
+ real *alpha, integer *qblcka, integer *qblckb)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
+ d_offset, e_dim1, e_offset, f_dim1, f_offset, l_dim1, l_offset,
+ r_dim1, r_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1;
+ complex q__1, q__2, q__3, q__4, q__5;
+
+ /* Builtin functions */
+ void c_sin(complex *, complex *), c_div(complex *, complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
+ integer *, complex *, complex *, integer *, complex *, integer *,
+ complex *, complex *, integer *);
+ complex imeps, reeps;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLATM5 generates matrices involved in the Generalized Sylvester */
+/* equation: */
+
+/* A * R - L * B = C */
+/* D * R - L * E = F */
+
+/* They also satisfy (the diagonalization condition) */
+
+/* [ I -L ] ( [ A -C ], [ D -F ] ) [ I R ] = ( [ A ], [ D ] ) */
+/* [ I ] ( [ B ] [ E ] ) [ I ] ( [ B ] [ E ] ) */
+
+
+/* Arguments */
+/* ========= */
+
+/* PRTYPE (input) INTEGER */
+/* "Points" to a certian type of the matrices to generate */
+/* (see futher details). */
+
+/* M (input) INTEGER */
+/* Specifies the order of A and D and the number of rows in */
+/* C, F, R and L. */
+
+/* N (input) INTEGER */
+/* Specifies the order of B and E and the number of columns in */
+/* C, F, R and L. */
+
+/* A (output) COMPLEX array, dimension (LDA, M). */
+/* On exit A M-by-M is initialized according to PRTYPE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. */
+
+/* B (output) COMPLEX array, dimension (LDB, N). */
+/* On exit B N-by-N is initialized according to PRTYPE. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. */
+
+/* C (output) COMPLEX array, dimension (LDC, N). */
+/* On exit C M-by-N is initialized according to PRTYPE. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of C. */
+
+/* D (output) COMPLEX array, dimension (LDD, M). */
+/* On exit D M-by-M is initialized according to PRTYPE. */
+
+/* LDD (input) INTEGER */
+/* The leading dimension of D. */
+
+/* E (output) COMPLEX array, dimension (LDE, N). */
+/* On exit E N-by-N is initialized according to PRTYPE. */
+
+/* LDE (input) INTEGER */
+/* The leading dimension of E. */
+
+/* F (output) COMPLEX array, dimension (LDF, N). */
+/* On exit F M-by-N is initialized according to PRTYPE. */
+
+/* LDF (input) INTEGER */
+/* The leading dimension of F. */
+
+/* R (output) COMPLEX array, dimension (LDR, N). */
+/* On exit R M-by-N is initialized according to PRTYPE. */
+
+/* LDR (input) INTEGER */
+/* The leading dimension of R. */
+
+/* L (output) COMPLEX array, dimension (LDL, N). */
+/* On exit L M-by-N is initialized according to PRTYPE. */
+
+/* LDL (input) INTEGER */
+/* The leading dimension of L. */
+
+/* ALPHA (input) REAL */
+/* Parameter used in generating PRTYPE = 1 and 5 matrices. */
+
+/* QBLCKA (input) INTEGER */
+/* When PRTYPE = 3, specifies the distance between 2-by-2 */
+/* blocks on the diagonal in A. Otherwise, QBLCKA is not */
+/* referenced. QBLCKA > 1. */
+
+/* QBLCKB (input) INTEGER */
+/* When PRTYPE = 3, specifies the distance between 2-by-2 */
+/* blocks on the diagonal in B. Otherwise, QBLCKB is not */
+/* referenced. QBLCKB > 1. */
+
+
+/* Further Details */
+/* =============== */
+
+/* PRTYPE = 1: A and B are Jordan blocks, D and E are identity matrices */
+
+/* A : if (i == j) then A(i, j) = 1.0 */
+/* if (j == i + 1) then A(i, j) = -1.0 */
+/* else A(i, j) = 0.0, i, j = 1...M */
+
+/* B : if (i == j) then B(i, j) = 1.0 - ALPHA */
+/* if (j == i + 1) then B(i, j) = 1.0 */
+/* else B(i, j) = 0.0, i, j = 1...N */
+
+/* D : if (i == j) then D(i, j) = 1.0 */
+/* else D(i, j) = 0.0, i, j = 1...M */
+
+/* E : if (i == j) then E(i, j) = 1.0 */
+/* else E(i, j) = 0.0, i, j = 1...N */
+
+/* L = R are chosen from [-10...10], */
+/* which specifies the right hand sides (C, F). */
+
+/* PRTYPE = 2 or 3: Triangular and/or quasi- triangular. */
+
+/* A : if (i <= j) then A(i, j) = [-1...1] */
+/* else A(i, j) = 0.0, i, j = 1...M */
+
+/* if (PRTYPE = 3) then */
+/* A(k + 1, k + 1) = A(k, k) */
+/* A(k + 1, k) = [-1...1] */
+/* sign(A(k, k + 1) = -(sin(A(k + 1, k)) */
+/* k = 1, M - 1, QBLCKA */
+
+/* B : if (i <= j) then B(i, j) = [-1...1] */
+/* else B(i, j) = 0.0, i, j = 1...N */
+
+/* if (PRTYPE = 3) then */
+/* B(k + 1, k + 1) = B(k, k) */
+/* B(k + 1, k) = [-1...1] */
+/* sign(B(k, k + 1) = -(sign(B(k + 1, k)) */
+/* k = 1, N - 1, QBLCKB */
+
+/* D : if (i <= j) then D(i, j) = [-1...1]. */
+/* else D(i, j) = 0.0, i, j = 1...M */
+
+
+/* E : if (i <= j) then D(i, j) = [-1...1] */
+/* else E(i, j) = 0.0, i, j = 1...N */
+
+/* L, R are chosen from [-10...10], */
+/* which specifies the right hand sides (C, F). */
+
+/* PRTYPE = 4 Full */
+/* A(i, j) = [-10...10] */
+/* D(i, j) = [-1...1] i,j = 1...M */
+/* B(i, j) = [-10...10] */
+/* E(i, j) = [-1...1] i,j = 1...N */
+/* R(i, j) = [-10...10] */
+/* L(i, j) = [-1...1] i = 1..M ,j = 1...N */
+
+/* L, R specifies the right hand sides (C, F). */
+
+/* PRTYPE = 5 special case common and/or close eigs. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ d_dim1 = *ldd;
+ d_offset = 1 + d_dim1;
+ d__ -= d_offset;
+ e_dim1 = *lde;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ f_dim1 = *ldf;
+ f_offset = 1 + f_dim1;
+ f -= f_offset;
+ r_dim1 = *ldr;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ l_dim1 = *ldl;
+ l_offset = 1 + l_dim1;
+ l -= l_offset;
+
+ /* Function Body */
+ if (*prtype == 1) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *m;
+ for (j = 1; j <= i__2; ++j) {
+ if (i__ == j) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 1.f, a[i__3].i = 0.f;
+ i__3 = i__ + j * d_dim1;
+ d__[i__3].r = 1.f, d__[i__3].i = 0.f;
+ } else if (i__ == j - 1) {
+ i__3 = i__ + j * a_dim1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ i__3 = i__ + j * d_dim1;
+ d__[i__3].r = 0.f, d__[i__3].i = 0.f;
+ } else {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ i__3 = i__ + j * d_dim1;
+ d__[i__3].r = 0.f, d__[i__3].i = 0.f;
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (i__ == j) {
+ i__3 = i__ + j * b_dim1;
+ q__1.r = 1.f - *alpha, q__1.i = 0.f;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+ i__3 = i__ + j * e_dim1;
+ e[i__3].r = 1.f, e[i__3].i = 0.f;
+ } else if (i__ == j - 1) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 1.f, b[i__3].i = 0.f;
+ i__3 = i__ + j * e_dim1;
+ e[i__3].r = 0.f, e[i__3].i = 0.f;
+ } else {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0.f, b[i__3].i = 0.f;
+ i__3 = i__ + j * e_dim1;
+ e[i__3].r = 0.f, e[i__3].i = 0.f;
+ }
+/* L30: */
+ }
+/* L40: */
+ }
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * r_dim1;
+ i__4 = i__ / j;
+ q__4.r = (real) i__4, q__4.i = 0.f;
+ c_sin(&q__3, &q__4);
+ q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
+ q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f
+ + q__2.i * 20.f;
+ r__[i__3].r = q__1.r, r__[i__3].i = q__1.i;
+ i__3 = i__ + j * l_dim1;
+ i__4 = i__ + j * r_dim1;
+ l[i__3].r = r__[i__4].r, l[i__3].i = r__[i__4].i;
+/* L50: */
+ }
+/* L60: */
+ }
+
+ } else if (*prtype == 2 || *prtype == 3) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *m;
+ for (j = 1; j <= i__2; ++j) {
+ if (i__ <= j) {
+ i__3 = i__ + j * a_dim1;
+ q__4.r = (real) i__, q__4.i = 0.f;
+ c_sin(&q__3, &q__4);
+ q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
+ q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r *
+ 0.f + q__2.i * 2.f;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ i__3 = i__ + j * d_dim1;
+ i__4 = i__ * j;
+ q__4.r = (real) i__4, q__4.i = 0.f;
+ c_sin(&q__3, &q__4);
+ q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
+ q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r *
+ 0.f + q__2.i * 2.f;
+ d__[i__3].r = q__1.r, d__[i__3].i = q__1.i;
+ } else {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ i__3 = i__ + j * d_dim1;
+ d__[i__3].r = 0.f, d__[i__3].i = 0.f;
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (i__ <= j) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j;
+ q__4.r = (real) i__4, q__4.i = 0.f;
+ c_sin(&q__3, &q__4);
+ q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
+ q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r *
+ 0.f + q__2.i * 2.f;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+ i__3 = i__ + j * e_dim1;
+ q__4.r = (real) j, q__4.i = 0.f;
+ c_sin(&q__3, &q__4);
+ q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
+ q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r *
+ 0.f + q__2.i * 2.f;
+ e[i__3].r = q__1.r, e[i__3].i = q__1.i;
+ } else {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0.f, b[i__3].i = 0.f;
+ i__3 = i__ + j * e_dim1;
+ e[i__3].r = 0.f, e[i__3].i = 0.f;
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * r_dim1;
+ i__4 = i__ * j;
+ q__4.r = (real) i__4, q__4.i = 0.f;
+ c_sin(&q__3, &q__4);
+ q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
+ q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f
+ + q__2.i * 20.f;
+ r__[i__3].r = q__1.r, r__[i__3].i = q__1.i;
+ i__3 = i__ + j * l_dim1;
+ i__4 = i__ + j;
+ q__4.r = (real) i__4, q__4.i = 0.f;
+ c_sin(&q__3, &q__4);
+ q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
+ q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f
+ + q__2.i * 20.f;
+ l[i__3].r = q__1.r, l[i__3].i = q__1.i;
+/* L110: */
+ }
+/* L120: */
+ }
+
+ if (*prtype == 3) {
+ if (*qblcka <= 1) {
+ *qblcka = 2;
+ }
+ i__1 = *m - 1;
+ i__2 = *qblcka;
+ for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+ i__3 = k + 1 + (k + 1) * a_dim1;
+ i__4 = k + k * a_dim1;
+ a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
+ i__3 = k + 1 + k * a_dim1;
+ c_sin(&q__2, &a[k + (k + 1) * a_dim1]);
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L130: */
+ }
+
+ if (*qblckb <= 1) {
+ *qblckb = 2;
+ }
+ i__2 = *n - 1;
+ i__1 = *qblckb;
+ for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+ i__3 = k + 1 + (k + 1) * b_dim1;
+ i__4 = k + k * b_dim1;
+ b[i__3].r = b[i__4].r, b[i__3].i = b[i__4].i;
+ i__3 = k + 1 + k * b_dim1;
+ c_sin(&q__2, &b[k + (k + 1) * b_dim1]);
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+/* L140: */
+ }
+ }
+
+ } else if (*prtype == 4) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *m;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ * j;
+ q__4.r = (real) i__4, q__4.i = 0.f;
+ c_sin(&q__3, &q__4);
+ q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
+ q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f
+ + q__2.i * 20.f;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ i__3 = i__ + j * d_dim1;
+ i__4 = i__ + j;
+ q__4.r = (real) i__4, q__4.i = 0.f;
+ c_sin(&q__3, &q__4);
+ q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
+ q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f +
+ q__2.i * 2.f;
+ d__[i__3].r = q__1.r, d__[i__3].i = q__1.i;
+/* L150: */
+ }
+/* L160: */
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j;
+ q__4.r = (real) i__4, q__4.i = 0.f;
+ c_sin(&q__3, &q__4);
+ q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
+ q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f
+ + q__2.i * 20.f;
+ b[i__3].r = q__1.r, b[i__3].i = q__1.i;
+ i__3 = i__ + j * e_dim1;
+ i__4 = i__ * j;
+ q__4.r = (real) i__4, q__4.i = 0.f;
+ c_sin(&q__3, &q__4);
+ q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
+ q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f +
+ q__2.i * 2.f;
+ e[i__3].r = q__1.r, e[i__3].i = q__1.i;
+/* L170: */
+ }
+/* L180: */
+ }
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * r_dim1;
+ i__4 = j / i__;
+ q__4.r = (real) i__4, q__4.i = 0.f;
+ c_sin(&q__3, &q__4);
+ q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
+ q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f
+ + q__2.i * 20.f;
+ r__[i__3].r = q__1.r, r__[i__3].i = q__1.i;
+ i__3 = i__ + j * l_dim1;
+ i__4 = i__ * j;
+ q__4.r = (real) i__4, q__4.i = 0.f;
+ c_sin(&q__3, &q__4);
+ q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i;
+ q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f +
+ q__2.i * 2.f;
+ l[i__3].r = q__1.r, l[i__3].i = q__1.i;
+/* L190: */
+ }
+/* L200: */
+ }
+
+ } else if (*prtype >= 5) {
+ q__3.r = 1.f, q__3.i = 0.f;
+ q__2.r = q__3.r * 20.f - q__3.i * 0.f, q__2.i = q__3.r * 0.f + q__3.i
+ * 20.f;
+ q__1.r = q__2.r / *alpha, q__1.i = q__2.i / *alpha;
+ reeps.r = q__1.r, reeps.i = q__1.i;
+ q__2.r = -1.5f, q__2.i = 0.f;
+ q__1.r = q__2.r / *alpha, q__1.i = q__2.i / *alpha;
+ imeps.r = q__1.r, imeps.i = q__1.i;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * r_dim1;
+ i__4 = i__ * j;
+ q__5.r = (real) i__4, q__5.i = 0.f;
+ c_sin(&q__4, &q__5);
+ q__3.r = .5f - q__4.r, q__3.i = 0.f - q__4.i;
+ q__2.r = *alpha * q__3.r, q__2.i = *alpha * q__3.i;
+ c_div(&q__1, &q__2, &c_b5);
+ r__[i__3].r = q__1.r, r__[i__3].i = q__1.i;
+ i__3 = i__ + j * l_dim1;
+ i__4 = i__ + j;
+ q__5.r = (real) i__4, q__5.i = 0.f;
+ c_sin(&q__4, &q__5);
+ q__3.r = .5f - q__4.r, q__3.i = 0.f - q__4.i;
+ q__2.r = *alpha * q__3.r, q__2.i = *alpha * q__3.i;
+ c_div(&q__1, &q__2, &c_b5);
+ l[i__3].r = q__1.r, l[i__3].i = q__1.i;
+/* L210: */
+ }
+/* L220: */
+ }
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * d_dim1;
+ d__[i__2].r = 1.f, d__[i__2].i = 0.f;
+/* L230: */
+ }
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (i__ <= 4) {
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+ if (i__ > 2) {
+ i__2 = i__ + i__ * a_dim1;
+ q__1.r = reeps.r + 1.f, q__1.i = reeps.i + 0.f;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ }
+ if (i__ % 2 != 0 && i__ < *m) {
+ i__2 = i__ + (i__ + 1) * a_dim1;
+ a[i__2].r = imeps.r, a[i__2].i = imeps.i;
+ } else if (i__ > 1) {
+ i__2 = i__ + (i__ - 1) * a_dim1;
+ q__1.r = -imeps.r, q__1.i = -imeps.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ }
+ } else if (i__ <= 8) {
+ if (i__ <= 6) {
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = reeps.r, a[i__2].i = reeps.i;
+ } else {
+ i__2 = i__ + i__ * a_dim1;
+ q__1.r = -reeps.r, q__1.i = -reeps.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ }
+ if (i__ % 2 != 0 && i__ < *m) {
+ i__2 = i__ + (i__ + 1) * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+ } else if (i__ > 1) {
+ i__2 = i__ + (i__ - 1) * a_dim1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ }
+ } else {
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = 1.f, a[i__2].i = 0.f;
+ if (i__ % 2 != 0 && i__ < *m) {
+ i__2 = i__ + (i__ + 1) * a_dim1;
+ d__1 = 2.;
+ q__1.r = d__1 * imeps.r, q__1.i = d__1 * imeps.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ } else if (i__ > 1) {
+ i__2 = i__ + (i__ - 1) * a_dim1;
+ q__2.r = -imeps.r, q__2.i = -imeps.i;
+ d__1 = 2.;
+ q__1.r = d__1 * q__2.r, q__1.i = d__1 * q__2.i;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+ }
+ }
+/* L240: */
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * e_dim1;
+ e[i__2].r = 1.f, e[i__2].i = 0.f;
+ if (i__ <= 4) {
+ i__2 = i__ + i__ * b_dim1;
+ q__1.r = -1.f, q__1.i = -0.f;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ if (i__ > 2) {
+ i__2 = i__ + i__ * b_dim1;
+ q__1.r = 1.f - reeps.r, q__1.i = 0.f - reeps.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ }
+ if (i__ % 2 != 0 && i__ < *n) {
+ i__2 = i__ + (i__ + 1) * b_dim1;
+ b[i__2].r = imeps.r, b[i__2].i = imeps.i;
+ } else if (i__ > 1) {
+ i__2 = i__ + (i__ - 1) * b_dim1;
+ q__1.r = -imeps.r, q__1.i = -imeps.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ }
+ } else if (i__ <= 8) {
+ if (i__ <= 6) {
+ i__2 = i__ + i__ * b_dim1;
+ b[i__2].r = reeps.r, b[i__2].i = reeps.i;
+ } else {
+ i__2 = i__ + i__ * b_dim1;
+ q__1.r = -reeps.r, q__1.i = -reeps.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ }
+ if (i__ % 2 != 0 && i__ < *n) {
+ i__2 = i__ + (i__ + 1) * b_dim1;
+ q__1.r = imeps.r + 1.f, q__1.i = imeps.i + 0.f;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ } else if (i__ > 1) {
+ i__2 = i__ + (i__ - 1) * b_dim1;
+ q__2.r = -1.f, q__2.i = -0.f;
+ q__1.r = q__2.r - imeps.r, q__1.i = q__2.i - imeps.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ }
+ } else {
+ i__2 = i__ + i__ * b_dim1;
+ q__1.r = 1.f - reeps.r, q__1.i = 0.f - reeps.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ if (i__ % 2 != 0 && i__ < *n) {
+ i__2 = i__ + (i__ + 1) * b_dim1;
+ d__1 = 2.;
+ q__1.r = d__1 * imeps.r, q__1.i = d__1 * imeps.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ } else if (i__ > 1) {
+ i__2 = i__ + (i__ - 1) * b_dim1;
+ q__2.r = -imeps.r, q__2.i = -imeps.i;
+ d__1 = 2.;
+ q__1.r = d__1 * q__2.r, q__1.i = d__1 * q__2.i;
+ b[i__2].r = q__1.r, b[i__2].i = q__1.i;
+ }
+ }
+/* L250: */
+ }
+ }
+
+/* Compute rhs (C, F) */
+
+ cgemm_("N", "N", m, n, m, &c_b1, &a[a_offset], lda, &r__[r_offset], ldr, &
+ c_b3, &c__[c_offset], ldc);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("N", "N", m, n, n, &q__1, &l[l_offset], ldl, &b[b_offset], ldb, &
+ c_b1, &c__[c_offset], ldc);
+ cgemm_("N", "N", m, n, m, &c_b1, &d__[d_offset], ldd, &r__[r_offset], ldr,
+ &c_b3, &f[f_offset], ldf);
+ q__1.r = -1.f, q__1.i = -0.f;
+ cgemm_("N", "N", m, n, n, &q__1, &l[l_offset], ldl, &e[e_offset], lde, &
+ c_b1, &f[f_offset], ldf);
+
+/* End of CLATM5 */
+
+ return 0;
+} /* clatm5_ */
diff --git a/TESTING/MATGEN/clatm6.c b/TESTING/MATGEN/clatm6.c
new file mode 100644
index 0000000..c0c0a16
--- /dev/null
+++ b/TESTING/MATGEN/clatm6.c
@@ -0,0 +1,376 @@
+/* clatm6.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c__8 = 8;
+static integer c__24 = 24;
+
+/* Subroutine */ int clatm6_(integer *type__, integer *n, complex *a, integer
+ *lda, complex *b, complex *x, integer *ldx, complex *y, integer *ldy,
+ complex *alpha, complex *beta, complex *wx, complex *wy, real *s,
+ real *dif)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, y_dim1,
+ y_offset, i__1, i__2, i__3;
+ real r__1, r__2;
+ complex q__1, q__2, q__3, q__4;
+
+ /* Builtin functions */
+ void r_cnjg(complex *, complex *);
+ double c_abs(complex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ complex z__[64] /* was [8][8] */;
+ integer info;
+ complex work[26];
+ extern /* Subroutine */ int clakf2_(integer *, integer *, complex *,
+ integer *, complex *, complex *, complex *, complex *, integer *);
+ real rwork[50];
+ extern /* Subroutine */ int cgesvd_(char *, char *, integer *, integer *,
+ complex *, integer *, real *, complex *, integer *, complex *,
+ integer *, complex *, integer *, real *, integer *), clacpy_(char *, integer *, integer *, complex *, integer
+ *, complex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLATM6 generates test matrices for the generalized eigenvalue */
+/* problem, their corresponding right and left eigenvector matrices, */
+/* and also reciprocal condition numbers for all eigenvalues and */
+/* the reciprocal condition numbers of eigenvectors corresponding to */
+/* the 1th and 5th eigenvalues. */
+
+/* Test Matrices */
+/* ============= */
+
+/* Two kinds of test matrix pairs */
+/* (A, B) = inverse(YH) * (Da, Db) * inverse(X) */
+/* are used in the tests: */
+
+/* Type 1: */
+/* Da = 1+a 0 0 0 0 Db = 1 0 0 0 0 */
+/* 0 2+a 0 0 0 0 1 0 0 0 */
+/* 0 0 3+a 0 0 0 0 1 0 0 */
+/* 0 0 0 4+a 0 0 0 0 1 0 */
+/* 0 0 0 0 5+a , 0 0 0 0 1 */
+/* and Type 2: */
+/* Da = 1+i 0 0 0 0 Db = 1 0 0 0 0 */
+/* 0 1-i 0 0 0 0 1 0 0 0 */
+/* 0 0 1 0 0 0 0 1 0 0 */
+/* 0 0 0 (1+a)+(1+b)i 0 0 0 0 1 0 */
+/* 0 0 0 0 (1+a)-(1+b)i, 0 0 0 0 1 . */
+
+/* In both cases the same inverse(YH) and inverse(X) are used to compute */
+/* (A, B), giving the exact eigenvectors to (A,B) as (YH, X): */
+
+/* YH: = 1 0 -y y -y X = 1 0 -x -x x */
+/* 0 1 -y y -y 0 1 x -x -x */
+/* 0 0 1 0 0 0 0 1 0 0 */
+/* 0 0 0 1 0 0 0 0 1 0 */
+/* 0 0 0 0 1, 0 0 0 0 1 , where */
+
+/* a, b, x and y will have all values independently of each other. */
+
+/* Arguments */
+/* ========= */
+
+/* TYPE (input) INTEGER */
+/* Specifies the problem type (see futher details). */
+
+/* N (input) INTEGER */
+/* Size of the matrices A and B. */
+
+/* A (output) COMPLEX array, dimension (LDA, N). */
+/* On exit A N-by-N is initialized according to TYPE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A and of B. */
+
+/* B (output) COMPLEX array, dimension (LDA, N). */
+/* On exit B N-by-N is initialized according to TYPE. */
+
+/* X (output) COMPLEX array, dimension (LDX, N). */
+/* On exit X is the N-by-N matrix of right eigenvectors. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of X. */
+
+/* Y (output) COMPLEX array, dimension (LDY, N). */
+/* On exit Y is the N-by-N matrix of left eigenvectors. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of Y. */
+
+/* ALPHA (input) COMPLEX */
+/* BETA (input) COMPLEX */
+/* Weighting constants for matrix A. */
+
+/* WX (input) COMPLEX */
+/* Constant for right eigenvector matrix. */
+
+/* WY (input) COMPLEX */
+/* Constant for left eigenvector matrix. */
+
+/* S (output) REAL array, dimension (N) */
+/* S(i) is the reciprocal condition number for eigenvalue i. */
+
+/* DIF (output) REAL array, dimension (N) */
+/* DIF(i) is the reciprocal condition number for eigenvector i. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Generate test problem ... */
+/* (Da, Db) ... */
+
+ /* Parameter adjustments */
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ --s;
+ --dif;
+
+ /* Function Body */
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+
+ if (i__ == j) {
+ i__3 = i__ + i__ * a_dim1;
+ q__2.r = (real) i__, q__2.i = 0.f;
+ q__1.r = q__2.r + alpha->r, q__1.i = q__2.i + alpha->i;
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ i__3 = i__ + i__ * b_dim1;
+ b[i__3].r = 1.f, b[i__3].i = 0.f;
+ } else {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0.f, b[i__3].i = 0.f;
+ }
+
+/* L10: */
+ }
+/* L20: */
+ }
+ if (*type__ == 2) {
+ i__1 = a_dim1 + 1;
+ a[i__1].r = 1.f, a[i__1].i = 1.f;
+ i__1 = (a_dim1 << 1) + 2;
+ r_cnjg(&q__1, &a[a_dim1 + 1]);
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = a_dim1 * 3 + 3;
+ a[i__1].r = 1.f, a[i__1].i = 0.f;
+ i__1 = (a_dim1 << 2) + 4;
+ q__2.r = alpha->r + 1.f, q__2.i = alpha->i + 0.f;
+ r__1 = q__2.r;
+ q__3.r = beta->r + 1.f, q__3.i = beta->i + 0.f;
+ r__2 = q__3.r;
+ q__1.r = r__1, q__1.i = r__2;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = a_dim1 * 5 + 5;
+ r_cnjg(&q__1, &a[(a_dim1 << 2) + 4]);
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ }
+
+/* Form X and Y */
+
+ clacpy_("F", n, n, &b[b_offset], lda, &y[y_offset], ldy);
+ i__1 = y_dim1 + 3;
+ r_cnjg(&q__2, wy);
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ y[i__1].r = q__1.r, y[i__1].i = q__1.i;
+ i__1 = y_dim1 + 4;
+ r_cnjg(&q__1, wy);
+ y[i__1].r = q__1.r, y[i__1].i = q__1.i;
+ i__1 = y_dim1 + 5;
+ r_cnjg(&q__2, wy);
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ y[i__1].r = q__1.r, y[i__1].i = q__1.i;
+ i__1 = (y_dim1 << 1) + 3;
+ r_cnjg(&q__2, wy);
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ y[i__1].r = q__1.r, y[i__1].i = q__1.i;
+ i__1 = (y_dim1 << 1) + 4;
+ r_cnjg(&q__1, wy);
+ y[i__1].r = q__1.r, y[i__1].i = q__1.i;
+ i__1 = (y_dim1 << 1) + 5;
+ r_cnjg(&q__2, wy);
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ y[i__1].r = q__1.r, y[i__1].i = q__1.i;
+
+ clacpy_("F", n, n, &b[b_offset], lda, &x[x_offset], ldx);
+ i__1 = x_dim1 * 3 + 1;
+ q__1.r = -wx->r, q__1.i = -wx->i;
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ i__1 = (x_dim1 << 2) + 1;
+ q__1.r = -wx->r, q__1.i = -wx->i;
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ i__1 = x_dim1 * 5 + 1;
+ x[i__1].r = wx->r, x[i__1].i = wx->i;
+ i__1 = x_dim1 * 3 + 2;
+ x[i__1].r = wx->r, x[i__1].i = wx->i;
+ i__1 = (x_dim1 << 2) + 2;
+ q__1.r = -wx->r, q__1.i = -wx->i;
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+ i__1 = x_dim1 * 5 + 2;
+ q__1.r = -wx->r, q__1.i = -wx->i;
+ x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+
+/* Form (A, B) */
+
+ i__1 = b_dim1 * 3 + 1;
+ q__1.r = wx->r + wy->r, q__1.i = wx->i + wy->i;
+ b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+ i__1 = b_dim1 * 3 + 2;
+ q__2.r = -wx->r, q__2.i = -wx->i;
+ q__1.r = q__2.r + wy->r, q__1.i = q__2.i + wy->i;
+ b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+ i__1 = (b_dim1 << 2) + 1;
+ q__1.r = wx->r - wy->r, q__1.i = wx->i - wy->i;
+ b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+ i__1 = (b_dim1 << 2) + 2;
+ q__1.r = wx->r - wy->r, q__1.i = wx->i - wy->i;
+ b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+ i__1 = b_dim1 * 5 + 1;
+ q__2.r = -wx->r, q__2.i = -wx->i;
+ q__1.r = q__2.r + wy->r, q__1.i = q__2.i + wy->i;
+ b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+ i__1 = b_dim1 * 5 + 2;
+ q__1.r = wx->r + wy->r, q__1.i = wx->i + wy->i;
+ b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+ i__1 = a_dim1 * 3 + 1;
+ i__2 = a_dim1 + 1;
+ q__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, q__2.i = wx->r * a[i__2]
+ .i + wx->i * a[i__2].r;
+ i__3 = a_dim1 * 3 + 3;
+ q__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, q__3.i = wy->r * a[i__3]
+ .i + wy->i * a[i__3].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = a_dim1 * 3 + 2;
+ q__3.r = -wx->r, q__3.i = -wx->i;
+ i__2 = (a_dim1 << 1) + 2;
+ q__2.r = q__3.r * a[i__2].r - q__3.i * a[i__2].i, q__2.i = q__3.r * a[
+ i__2].i + q__3.i * a[i__2].r;
+ i__3 = a_dim1 * 3 + 3;
+ q__4.r = wy->r * a[i__3].r - wy->i * a[i__3].i, q__4.i = wy->r * a[i__3]
+ .i + wy->i * a[i__3].r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = (a_dim1 << 2) + 1;
+ i__2 = a_dim1 + 1;
+ q__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, q__2.i = wx->r * a[i__2]
+ .i + wx->i * a[i__2].r;
+ i__3 = (a_dim1 << 2) + 4;
+ q__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, q__3.i = wy->r * a[i__3]
+ .i + wy->i * a[i__3].r;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = (a_dim1 << 2) + 2;
+ i__2 = (a_dim1 << 1) + 2;
+ q__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, q__2.i = wx->r * a[i__2]
+ .i + wx->i * a[i__2].r;
+ i__3 = (a_dim1 << 2) + 4;
+ q__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, q__3.i = wy->r * a[i__3]
+ .i + wy->i * a[i__3].r;
+ q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = a_dim1 * 5 + 1;
+ q__3.r = -wx->r, q__3.i = -wx->i;
+ i__2 = a_dim1 + 1;
+ q__2.r = q__3.r * a[i__2].r - q__3.i * a[i__2].i, q__2.i = q__3.r * a[
+ i__2].i + q__3.i * a[i__2].r;
+ i__3 = a_dim1 * 5 + 5;
+ q__4.r = wy->r * a[i__3].r - wy->i * a[i__3].i, q__4.i = wy->r * a[i__3]
+ .i + wy->i * a[i__3].r;
+ q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+ i__1 = a_dim1 * 5 + 2;
+ i__2 = (a_dim1 << 1) + 2;
+ q__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, q__2.i = wx->r * a[i__2]
+ .i + wx->i * a[i__2].r;
+ i__3 = a_dim1 * 5 + 5;
+ q__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, q__3.i = wy->r * a[i__3]
+ .i + wy->i * a[i__3].r;
+ q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+ a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+
+/* Compute condition numbers */
+
+ s[1] = 1.f / sqrt((c_abs(wy) * 3.f * c_abs(wy) + 1.f) / (c_abs(&a[a_dim1
+ + 1]) * c_abs(&a[a_dim1 + 1]) + 1.f));
+ s[2] = 1.f / sqrt((c_abs(wy) * 3.f * c_abs(wy) + 1.f) / (c_abs(&a[(a_dim1
+ << 1) + 2]) * c_abs(&a[(a_dim1 << 1) + 2]) + 1.f));
+ s[3] = 1.f / sqrt((c_abs(wx) * 2.f * c_abs(wx) + 1.f) / (c_abs(&a[a_dim1 *
+ 3 + 3]) * c_abs(&a[a_dim1 * 3 + 3]) + 1.f));
+ s[4] = 1.f / sqrt((c_abs(wx) * 2.f * c_abs(wx) + 1.f) / (c_abs(&a[(a_dim1
+ << 2) + 4]) * c_abs(&a[(a_dim1 << 2) + 4]) + 1.f));
+ s[5] = 1.f / sqrt((c_abs(wx) * 2.f * c_abs(wx) + 1.f) / (c_abs(&a[a_dim1 *
+ 5 + 5]) * c_abs(&a[a_dim1 * 5 + 5]) + 1.f));
+
+ clakf2_(&c__1, &c__4, &a[a_offset], lda, &a[(a_dim1 << 1) + 2], &b[
+ b_offset], &b[(b_dim1 << 1) + 2], z__, &c__8);
+ cgesvd_("N", "N", &c__8, &c__8, z__, &c__8, rwork, work, &c__1, &work[1],
+ &c__1, &work[2], &c__24, &rwork[8], &info);
+ dif[1] = rwork[7];
+
+ clakf2_(&c__4, &c__1, &a[a_offset], lda, &a[a_dim1 * 5 + 5], &b[b_offset],
+ &b[b_dim1 * 5 + 5], z__, &c__8);
+ cgesvd_("N", "N", &c__8, &c__8, z__, &c__8, rwork, work, &c__1, &work[1],
+ &c__1, &work[2], &c__24, &rwork[8], &info);
+ dif[5] = rwork[7];
+
+ return 0;
+
+/* End of CLATM6 */
+
+} /* clatm6_ */
diff --git a/TESTING/MATGEN/clatme.c b/TESTING/MATGEN/clatme.c
new file mode 100644
index 0000000..7e386bf
--- /dev/null
+++ b/TESTING/MATGEN/clatme.c
@@ -0,0 +1,635 @@
+/* clatme.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static complex c_b2 = {1.f,0.f};
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c__5 = 5;
+
+/* Subroutine */ int clatme_(integer *n, char *dist, integer *iseed, complex *
+ d__, integer *mode, real *cond, complex *dmax__, char *ei, char *
+ rsign, char *upper, char *sim, real *ds, integer *modes, real *conds,
+ integer *kl, integer *ku, real *anorm, complex *a, integer *lda,
+ complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real r__1, r__2;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, ic, jc, ir, jcr;
+ complex tau;
+ logical bads;
+ integer isim;
+ real temp;
+ extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
+ complex *, integer *, complex *, integer *, complex *, integer *);
+ complex alpha;
+ extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+, complex *, integer *, complex *, integer *, complex *, complex *
+, integer *);
+ integer iinfo;
+ real tempa[1];
+ integer icols, idist;
+ extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
+ complex *, integer *);
+ integer irows;
+ extern /* Subroutine */ int clatm1_(integer *, real *, integer *, integer
+ *, integer *, complex *, integer *, integer *), slatm1_(integer *,
+ real *, integer *, integer *, integer *, real *, integer *,
+ integer *);
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int clarge_(integer *, complex *, integer *,
+ integer *, complex *, integer *), clarfg_(integer *, complex *,
+ complex *, integer *, complex *), clacgv_(integer *, complex *,
+ integer *);
+ extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+ real ralpha;
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *), claset_(char *, integer *, integer *, complex *, complex *,
+ complex *, integer *), xerbla_(char *, integer *),
+ clarnv_(integer *, integer *, integer *, complex *);
+ integer irsign, iupper;
+ complex xnorms;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLATME generates random non-symmetric square matrices with */
+/* specified eigenvalues for testing LAPACK programs. */
+
+/* CLATME operates by applying the following sequence of */
+/* operations: */
+
+/* 1. Set the diagonal to D, where D may be input or */
+/* computed according to MODE, COND, DMAX, and RSIGN */
+/* as described below. */
+
+/* 2. If UPPER='T', the upper triangle of A is set to random values */
+/* out of distribution DIST. */
+
+/* 3. If SIM='T', A is multiplied on the left by a random matrix */
+/* X, whose singular values are specified by DS, MODES, and */
+/* CONDS, and on the right by X inverse. */
+
+/* 4. If KL < N-1, the lower bandwidth is reduced to KL using */
+/* Householder transformations. If KU < N-1, the upper */
+/* bandwidth is reduced to KU. */
+
+/* 5. If ANORM is not negative, the matrix is scaled to have */
+/* maximum-element-norm ANORM. */
+
+/* (Note: since the matrix cannot be reduced beyond Hessenberg form, */
+/* no packing options are available.) */
+
+/* Arguments */
+/* ========= */
+
+/* N - INTEGER */
+/* The number of columns (or rows) of A. Not modified. */
+
+/* DIST - CHARACTER*1 */
+/* On entry, DIST specifies the type of distribution to be used */
+/* to generate the random eigen-/singular values, and on the */
+/* upper triangle (see UPPER). */
+/* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */
+/* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */
+/* 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */
+/* 'D' => uniform on the complex disc |z| < 1. */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension ( 4 ) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. They should lie between 0 and 4095 inclusive, */
+/* and ISEED(4) should be odd. The random number generator */
+/* uses a linear congruential sequence limited to small */
+/* integers, and so should produce machine independent */
+/* random numbers. The values of ISEED are changed on */
+/* exit, and can be used in the next call to CLATME */
+/* to continue the same random number sequence. */
+/* Changed on exit. */
+
+/* D - COMPLEX array, dimension ( N ) */
+/* This array is used to specify the eigenvalues of A. If */
+/* MODE=0, then D is assumed to contain the eigenvalues */
+/* otherwise they will be computed according to MODE, COND, */
+/* DMAX, and RSIGN and placed in D. */
+/* Modified if MODE is nonzero. */
+
+/* MODE - INTEGER */
+/* On entry this describes how the eigenvalues are to */
+/* be specified: */
+/* MODE = 0 means use D as input */
+/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
+/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
+/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
+/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* MODE = 5 sets D to random numbers in the range */
+/* ( 1/COND , 1 ) such that their logarithms */
+/* are uniformly distributed. */
+/* MODE = 6 set D to random numbers from same distribution */
+/* as the rest of the matrix. */
+/* MODE < 0 has the same meaning as ABS(MODE), except that */
+/* the order of the elements of D is reversed. */
+/* Thus if MODE is between 1 and 4, D has entries ranging */
+/* from 1 to 1/COND, if between -1 and -4, D has entries */
+/* ranging from 1/COND to 1, */
+/* Not modified. */
+
+/* COND - REAL */
+/* On entry, this is used as described under MODE above. */
+/* If used, it must be >= 1. Not modified. */
+
+/* DMAX - COMPLEX */
+/* If MODE is neither -6, 0 nor 6, the contents of D, as */
+/* computed according to MODE and COND, will be scaled by */
+/* DMAX / max(abs(D(i))). Note that DMAX need not be */
+/* positive or real: if DMAX is negative or complex (or zero), */
+/* D will be scaled by a negative or complex number (or zero). */
+/* If RSIGN='F' then the largest (absolute) eigenvalue will be */
+/* equal to DMAX. */
+/* Not modified. */
+
+/* EI - CHARACTER*1 (ignored) */
+/* Not modified. */
+
+/* RSIGN - CHARACTER*1 */
+/* If MODE is not 0, 6, or -6, and RSIGN='T', then the */
+/* elements of D, as computed according to MODE and COND, will */
+/* be multiplied by a random complex number from the unit */
+/* circle |z| = 1. If RSIGN='F', they will not be. RSIGN may */
+/* only have the values 'T' or 'F'. */
+/* Not modified. */
+
+/* UPPER - CHARACTER*1 */
+/* If UPPER='T', then the elements of A above the diagonal */
+/* will be set to random numbers out of DIST. If UPPER='F', */
+/* they will not. UPPER may only have the values 'T' or 'F'. */
+/* Not modified. */
+
+/* SIM - CHARACTER*1 */
+/* If SIM='T', then A will be operated on by a "similarity */
+/* transform", i.e., multiplied on the left by a matrix X and */
+/* on the right by X inverse. X = U S V, where U and V are */
+/* random unitary matrices and S is a (diagonal) matrix of */
+/* singular values specified by DS, MODES, and CONDS. If */
+/* SIM='F', then A will not be transformed. */
+/* Not modified. */
+
+/* DS - REAL array, dimension ( N ) */
+/* This array is used to specify the singular values of X, */
+/* in the same way that D specifies the eigenvalues of A. */
+/* If MODE=0, the DS contains the singular values, which */
+/* may not be zero. */
+/* Modified if MODE is nonzero. */
+
+/* MODES - INTEGER */
+/* CONDS - REAL */
+/* Similar to MODE and COND, but for specifying the diagonal */
+/* of S. MODES=-6 and +6 are not allowed (since they would */
+/* result in randomly ill-conditioned eigenvalues.) */
+
+/* KL - INTEGER */
+/* This specifies the lower bandwidth of the matrix. KL=1 */
+/* specifies upper Hessenberg form. If KL is at least N-1, */
+/* then A will have full lower bandwidth. */
+/* Not modified. */
+
+/* KU - INTEGER */
+/* This specifies the upper bandwidth of the matrix. KU=1 */
+/* specifies lower Hessenberg form. If KU is at least N-1, */
+/* then A will have full upper bandwidth; if KU and KL */
+/* are both at least N-1, then A will be dense. Only one of */
+/* KU and KL may be less than N-1. */
+/* Not modified. */
+
+/* ANORM - REAL */
+/* If ANORM is not negative, then A will be scaled by a non- */
+/* negative real number to make the maximum-element-norm of A */
+/* to be ANORM. */
+/* Not modified. */
+
+/* A - COMPLEX array, dimension ( LDA, N ) */
+/* On exit A is the desired test matrix. */
+/* Modified. */
+
+/* LDA - INTEGER */
+/* LDA specifies the first dimension of A as declared in the */
+/* calling program. LDA must be at least M. */
+/* Not modified. */
+
+/* WORK - COMPLEX array, dimension ( 3*N ) */
+/* Workspace. */
+/* Modified. */
+
+/* INFO - INTEGER */
+/* Error code. On exit, INFO will be set to one of the */
+/* following values: */
+/* 0 => normal return */
+/* -1 => N negative */
+/* -2 => DIST illegal string */
+/* -5 => MODE not in range -6 to 6 */
+/* -6 => COND less than 1.0, and MODE neither -6, 0 nor 6 */
+/* -9 => RSIGN is not 'T' or 'F' */
+/* -10 => UPPER is not 'T' or 'F' */
+/* -11 => SIM is not 'T' or 'F' */
+/* -12 => MODES=0 and DS has a zero singular value. */
+/* -13 => MODES is not in the range -5 to 5. */
+/* -14 => MODES is nonzero and CONDS is less than 1. */
+/* -15 => KL is less than 1. */
+/* -16 => KU is less than 1, or KL and KU are both less than */
+/* N-1. */
+/* -19 => LDA is less than M. */
+/* 1 => Error return from CLATM1 (computing D) */
+/* 2 => Cannot scale to DMAX (max. eigenvalue is 0) */
+/* 3 => Error return from SLATM1 (computing DS) */
+/* 4 => Error return from CLARGE */
+/* 5 => Zero singular value from SLATM1. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Decode and Test the input parameters. */
+/* Initialize flags & seed. */
+
+ /* Parameter adjustments */
+ --iseed;
+ --d__;
+ --ds;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Decode DIST */
+
+ if (lsame_(dist, "U")) {
+ idist = 1;
+ } else if (lsame_(dist, "S")) {
+ idist = 2;
+ } else if (lsame_(dist, "N")) {
+ idist = 3;
+ } else if (lsame_(dist, "D")) {
+ idist = 4;
+ } else {
+ idist = -1;
+ }
+
+/* Decode RSIGN */
+
+ if (lsame_(rsign, "T")) {
+ irsign = 1;
+ } else if (lsame_(rsign, "F")) {
+ irsign = 0;
+ } else {
+ irsign = -1;
+ }
+
+/* Decode UPPER */
+
+ if (lsame_(upper, "T")) {
+ iupper = 1;
+ } else if (lsame_(upper, "F")) {
+ iupper = 0;
+ } else {
+ iupper = -1;
+ }
+
+/* Decode SIM */
+
+ if (lsame_(sim, "T")) {
+ isim = 1;
+ } else if (lsame_(sim, "F")) {
+ isim = 0;
+ } else {
+ isim = -1;
+ }
+
+/* Check DS, if MODES=0 and ISIM=1 */
+
+ bads = FALSE_;
+ if (*modes == 0 && isim == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (ds[j] == 0.f) {
+ bads = TRUE_;
+ }
+/* L10: */
+ }
+ }
+
+/* Set INFO if an error */
+
+ if (*n < 0) {
+ *info = -1;
+ } else if (idist == -1) {
+ *info = -2;
+ } else if (abs(*mode) > 6) {
+ *info = -5;
+ } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.f) {
+ *info = -6;
+ } else if (irsign == -1) {
+ *info = -9;
+ } else if (iupper == -1) {
+ *info = -10;
+ } else if (isim == -1) {
+ *info = -11;
+ } else if (bads) {
+ *info = -12;
+ } else if (isim == 1 && abs(*modes) > 5) {
+ *info = -13;
+ } else if (isim == 1 && *modes != 0 && *conds < 1.f) {
+ *info = -14;
+ } else if (*kl < 1) {
+ *info = -15;
+ } else if (*ku < 1 || *ku < *n - 1 && *kl < *n - 1) {
+ *info = -16;
+ } else if (*lda < max(1,*n)) {
+ *info = -19;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLATME", &i__1);
+ return 0;
+ }
+
+/* Initialize random number generator */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
+/* L20: */
+ }
+
+ if (iseed[4] % 2 != 1) {
+ ++iseed[4];
+ }
+
+/* 2) Set up diagonal of A */
+
+/* Compute D according to COND and MODE */
+
+ clatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], n, &iinfo);
+ if (iinfo != 0) {
+ *info = 1;
+ return 0;
+ }
+ if (*mode != 0 && abs(*mode) != 6) {
+
+/* Scale by DMAX */
+
+ temp = c_abs(&d__[1]);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = temp, r__2 = c_abs(&d__[i__]);
+ temp = dmax(r__1,r__2);
+/* L30: */
+ }
+
+ if (temp > 0.f) {
+ q__1.r = dmax__->r / temp, q__1.i = dmax__->i / temp;
+ alpha.r = q__1.r, alpha.i = q__1.i;
+ } else {
+ *info = 2;
+ return 0;
+ }
+
+ cscal_(n, &alpha, &d__[1], &c__1);
+
+ }
+
+ claset_("Full", n, n, &c_b1, &c_b1, &a[a_offset], lda);
+ i__1 = *lda + 1;
+ ccopy_(n, &d__[1], &c__1, &a[a_offset], &i__1);
+
+/* 3) If UPPER='T', set upper triangle of A to random numbers. */
+
+ if (iupper != 0) {
+ i__1 = *n;
+ for (jc = 2; jc <= i__1; ++jc) {
+ i__2 = jc - 1;
+ clarnv_(&idist, &iseed[1], &i__2, &a[jc * a_dim1 + 1]);
+/* L40: */
+ }
+ }
+
+/* 4) If SIM='T', apply similarity transformation. */
+
+/* -1 */
+/* Transform is X A X , where X = U S V, thus */
+
+/* it is U S V A V' (1/S) U' */
+
+ if (isim != 0) {
+
+/* Compute S (singular values of the eigenvector matrix) */
+/* according to CONDS and MODES */
+
+ slatm1_(modes, conds, &c__0, &c__0, &iseed[1], &ds[1], n, &iinfo);
+ if (iinfo != 0) {
+ *info = 3;
+ return 0;
+ }
+
+/* Multiply by V and V' */
+
+ clarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
+ if (iinfo != 0) {
+ *info = 4;
+ return 0;
+ }
+
+/* Multiply by S and (1/S) */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ csscal_(n, &ds[j], &a[j + a_dim1], lda);
+ if (ds[j] != 0.f) {
+ r__1 = 1.f / ds[j];
+ csscal_(n, &r__1, &a[j * a_dim1 + 1], &c__1);
+ } else {
+ *info = 5;
+ return 0;
+ }
+/* L50: */
+ }
+
+/* Multiply by U and U' */
+
+ clarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
+ if (iinfo != 0) {
+ *info = 4;
+ return 0;
+ }
+ }
+
+/* 5) Reduce the bandwidth. */
+
+ if (*kl < *n - 1) {
+
+/* Reduce bandwidth -- kill column */
+
+ i__1 = *n - 1;
+ for (jcr = *kl + 1; jcr <= i__1; ++jcr) {
+ ic = jcr - *kl;
+ irows = *n + 1 - jcr;
+ icols = *n + *kl - jcr;
+
+ ccopy_(&irows, &a[jcr + ic * a_dim1], &c__1, &work[1], &c__1);
+ xnorms.r = work[1].r, xnorms.i = work[1].i;
+ clarfg_(&irows, &xnorms, &work[2], &c__1, &tau);
+ r_cnjg(&q__1, &tau);
+ tau.r = q__1.r, tau.i = q__1.i;
+ work[1].r = 1.f, work[1].i = 0.f;
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ alpha.r = q__1.r, alpha.i = q__1.i;
+
+ cgemv_("C", &irows, &icols, &c_b2, &a[jcr + (ic + 1) * a_dim1],
+ lda, &work[1], &c__1, &c_b1, &work[irows + 1], &c__1);
+ q__1.r = -tau.r, q__1.i = -tau.i;
+ cgerc_(&irows, &icols, &q__1, &work[1], &c__1, &work[irows + 1], &
+ c__1, &a[jcr + (ic + 1) * a_dim1], lda);
+
+ cgemv_("N", n, &irows, &c_b2, &a[jcr * a_dim1 + 1], lda, &work[1],
+ &c__1, &c_b1, &work[irows + 1], &c__1);
+ r_cnjg(&q__2, &tau);
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ cgerc_(n, &irows, &q__1, &work[irows + 1], &c__1, &work[1], &c__1,
+ &a[jcr * a_dim1 + 1], lda);
+
+ i__2 = jcr + ic * a_dim1;
+ a[i__2].r = xnorms.r, a[i__2].i = xnorms.i;
+ i__2 = irows - 1;
+ claset_("Full", &i__2, &c__1, &c_b1, &c_b1, &a[jcr + 1 + ic *
+ a_dim1], lda);
+
+ i__2 = icols + 1;
+ cscal_(&i__2, &alpha, &a[jcr + ic * a_dim1], lda);
+ r_cnjg(&q__1, &alpha);
+ cscal_(n, &q__1, &a[jcr * a_dim1 + 1], &c__1);
+/* L60: */
+ }
+ } else if (*ku < *n - 1) {
+
+/* Reduce upper bandwidth -- kill a row at a time. */
+
+ i__1 = *n - 1;
+ for (jcr = *ku + 1; jcr <= i__1; ++jcr) {
+ ir = jcr - *ku;
+ irows = *n + *ku - jcr;
+ icols = *n + 1 - jcr;
+
+ ccopy_(&icols, &a[ir + jcr * a_dim1], lda, &work[1], &c__1);
+ xnorms.r = work[1].r, xnorms.i = work[1].i;
+ clarfg_(&icols, &xnorms, &work[2], &c__1, &tau);
+ r_cnjg(&q__1, &tau);
+ tau.r = q__1.r, tau.i = q__1.i;
+ work[1].r = 1.f, work[1].i = 0.f;
+ i__2 = icols - 1;
+ clacgv_(&i__2, &work[2], &c__1);
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ alpha.r = q__1.r, alpha.i = q__1.i;
+
+ cgemv_("N", &irows, &icols, &c_b2, &a[ir + 1 + jcr * a_dim1], lda,
+ &work[1], &c__1, &c_b1, &work[icols + 1], &c__1);
+ q__1.r = -tau.r, q__1.i = -tau.i;
+ cgerc_(&irows, &icols, &q__1, &work[icols + 1], &c__1, &work[1], &
+ c__1, &a[ir + 1 + jcr * a_dim1], lda);
+
+ cgemv_("C", &icols, n, &c_b2, &a[jcr + a_dim1], lda, &work[1], &
+ c__1, &c_b1, &work[icols + 1], &c__1);
+ r_cnjg(&q__2, &tau);
+ q__1.r = -q__2.r, q__1.i = -q__2.i;
+ cgerc_(&icols, n, &q__1, &work[1], &c__1, &work[icols + 1], &c__1,
+ &a[jcr + a_dim1], lda);
+
+ i__2 = ir + jcr * a_dim1;
+ a[i__2].r = xnorms.r, a[i__2].i = xnorms.i;
+ i__2 = icols - 1;
+ claset_("Full", &c__1, &i__2, &c_b1, &c_b1, &a[ir + (jcr + 1) *
+ a_dim1], lda);
+
+ i__2 = irows + 1;
+ cscal_(&i__2, &alpha, &a[ir + jcr * a_dim1], &c__1);
+ r_cnjg(&q__1, &alpha);
+ cscal_(n, &q__1, &a[jcr + a_dim1], lda);
+/* L70: */
+ }
+ }
+
+/* Scale the matrix to have norm ANORM */
+
+ if (*anorm >= 0.f) {
+ temp = clange_("M", n, n, &a[a_offset], lda, tempa);
+ if (temp > 0.f) {
+ ralpha = *anorm / temp;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ csscal_(n, &ralpha, &a[j * a_dim1 + 1], &c__1);
+/* L80: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CLATME */
+
+} /* clatme_ */
diff --git a/TESTING/MATGEN/clatmr.c b/TESTING/MATGEN/clatmr.c
new file mode 100644
index 0000000..4e9866d
--- /dev/null
+++ b/TESTING/MATGEN/clatmr.c
@@ -0,0 +1,1504 @@
+/* clatmr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int clatmr_(integer *m, integer *n, char *dist, integer *
+ iseed, char *sym, complex *d__, integer *mode, real *cond, complex *
+ dmax__, char *rsign, char *grade, complex *dl, integer *model, real *
+ condl, complex *dr, integer *moder, real *condr, char *pivtng,
+ integer *ipivot, integer *kl, integer *ku, real *sparse, real *anorm,
+ char *pack, complex *a, integer *lda, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ real r__1, r__2;
+ complex q__1, q__2;
+
+ /* Builtin functions */
+ double c_abs(complex *);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ integer i__, j, k, kll, kuu, isub, jsub;
+ real temp;
+ integer isym, ipack;
+ extern logical lsame_(char *, char *);
+ real tempa[1];
+ complex ctemp;
+ integer iisub, idist, jjsub, mnmin;
+ logical dzero;
+ integer mnsub;
+ real onorm;
+ integer mxsub, npvts;
+ extern /* Subroutine */ int clatm1_(integer *, real *, integer *, integer
+ *, integer *, complex *, integer *, integer *);
+ extern /* Complex */ VOID clatm2_(complex *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ complex *, integer *, complex *, complex *, integer *, integer *,
+ real *), clatm3_(complex *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, complex *, integer *, complex *, complex *, integer *,
+ integer *, real *);
+ extern doublereal clangb_(char *, integer *, integer *, integer *,
+ complex *, integer *, real *);
+ complex calpha;
+ extern doublereal clange_(char *, integer *, integer *, complex *,
+ integer *, real *);
+ integer igrade;
+ extern doublereal clansb_(char *, char *, integer *, integer *, complex *,
+ integer *, real *);
+ extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
+ *);
+ logical fulbnd;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical badpvt;
+ extern doublereal clansp_(char *, char *, integer *, complex *, real *), clansy_(char *, char *, integer *, complex *,
+ integer *, real *);
+ integer irsign, ipvtng;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLATMR generates random matrices of various types for testing */
+/* LAPACK programs. */
+
+/* CLATMR operates by applying the following sequence of */
+/* operations: */
+
+/* Generate a matrix A with random entries of distribution DIST */
+/* which is symmetric if SYM='S', Hermitian if SYM='H', and */
+/* nonsymmetric if SYM='N'. */
+
+/* Set the diagonal to D, where D may be input or */
+/* computed according to MODE, COND, DMAX and RSIGN */
+/* as described below. */
+
+/* Grade the matrix, if desired, from the left and/or right */
+/* as specified by GRADE. The inputs DL, MODEL, CONDL, DR, */
+/* MODER and CONDR also determine the grading as described */
+/* below. */
+
+/* Permute, if desired, the rows and/or columns as specified by */
+/* PIVTNG and IPIVOT. */
+
+/* Set random entries to zero, if desired, to get a random sparse */
+/* matrix as specified by SPARSE. */
+
+/* Make A a band matrix, if desired, by zeroing out the matrix */
+/* outside a band of lower bandwidth KL and upper bandwidth KU. */
+
+/* Scale A, if desired, to have maximum entry ANORM. */
+
+/* Pack the matrix if desired. Options specified by PACK are: */
+/* no packing */
+/* zero out upper half (if symmetric or Hermitian) */
+/* zero out lower half (if symmetric or Hermitian) */
+/* store the upper half columnwise (if symmetric or Hermitian */
+/* or square upper triangular) */
+/* store the lower half columnwise (if symmetric or Hermitian */
+/* or square lower triangular) */
+/* same as upper half rowwise if symmetric */
+/* same as conjugate upper half rowwise if Hermitian */
+/* store the lower triangle in banded format */
+/* (if symmetric or Hermitian) */
+/* store the upper triangle in banded format */
+/* (if symmetric or Hermitian) */
+/* store the entire matrix in banded format */
+
+/* Note: If two calls to CLATMR differ only in the PACK parameter, */
+/* they will generate mathematically equivalent matrices. */
+
+/* If two calls to CLATMR both have full bandwidth (KL = M-1 */
+/* and KU = N-1), and differ only in the PIVTNG and PACK */
+/* parameters, then the matrices generated will differ only */
+/* in the order of the rows and/or columns, and otherwise */
+/* contain the same data. This consistency cannot be and */
+/* is not maintained with less than full bandwidth. */
+
+/* Arguments */
+/* ========= */
+
+/* M - INTEGER */
+/* Number of rows of A. Not modified. */
+
+/* N - INTEGER */
+/* Number of columns of A. Not modified. */
+
+/* DIST - CHARACTER*1 */
+/* On entry, DIST specifies the type of distribution to be used */
+/* to generate a random matrix . */
+/* 'U' => real and imaginary parts are independent */
+/* UNIFORM( 0, 1 ) ( 'U' for uniform ) */
+/* 'S' => real and imaginary parts are independent */
+/* UNIFORM( -1, 1 ) ( 'S' for symmetric ) */
+/* 'N' => real and imaginary parts are independent */
+/* NORMAL( 0, 1 ) ( 'N' for normal ) */
+/* 'D' => uniform on interior of unit disk ( 'D' for disk ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. They should lie between 0 and 4095 inclusive, */
+/* and ISEED(4) should be odd. The random number generator */
+/* uses a linear congruential sequence limited to small */
+/* integers, and so should produce machine independent */
+/* random numbers. The values of ISEED are changed on */
+/* exit, and can be used in the next call to CLATMR */
+/* to continue the same random number sequence. */
+/* Changed on exit. */
+
+/* SYM - CHARACTER*1 */
+/* If SYM='S', generated matrix is symmetric. */
+/* If SYM='H', generated matrix is Hermitian. */
+/* If SYM='N', generated matrix is nonsymmetric. */
+/* Not modified. */
+
+/* D - COMPLEX array, dimension (min(M,N)) */
+/* On entry this array specifies the diagonal entries */
+/* of the diagonal of A. D may either be specified */
+/* on entry, or set according to MODE and COND as described */
+/* below. If the matrix is Hermitian, the real part of D */
+/* will be taken. May be changed on exit if MODE is nonzero. */
+
+/* MODE - INTEGER */
+/* On entry describes how D is to be used: */
+/* MODE = 0 means use D as input */
+/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
+/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
+/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
+/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* MODE = 5 sets D to random numbers in the range */
+/* ( 1/COND , 1 ) such that their logarithms */
+/* are uniformly distributed. */
+/* MODE = 6 set D to random numbers from same distribution */
+/* as the rest of the matrix. */
+/* MODE < 0 has the same meaning as ABS(MODE), except that */
+/* the order of the elements of D is reversed. */
+/* Thus if MODE is positive, D has entries ranging from */
+/* 1 to 1/COND, if negative, from 1/COND to 1, */
+/* Not modified. */
+
+/* COND - REAL */
+/* On entry, used as described under MODE above. */
+/* If used, it must be >= 1. Not modified. */
+
+/* DMAX - COMPLEX */
+/* If MODE neither -6, 0 nor 6, the diagonal is scaled by */
+/* DMAX / max(abs(D(i))), so that maximum absolute entry */
+/* of diagonal is abs(DMAX). If DMAX is complex (or zero), */
+/* diagonal will be scaled by a complex number (or zero). */
+
+/* RSIGN - CHARACTER*1 */
+/* If MODE neither -6, 0 nor 6, specifies sign of diagonal */
+/* as follows: */
+/* 'T' => diagonal entries are multiplied by a random complex */
+/* number uniformly distributed with absolute value 1 */
+/* 'F' => diagonal unchanged */
+/* Not modified. */
+
+/* GRADE - CHARACTER*1 */
+/* Specifies grading of matrix as follows: */
+/* 'N' => no grading */
+/* 'L' => matrix premultiplied by diag( DL ) */
+/* (only if matrix nonsymmetric) */
+/* 'R' => matrix postmultiplied by diag( DR ) */
+/* (only if matrix nonsymmetric) */
+/* 'B' => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DR ) */
+/* (only if matrix nonsymmetric) */
+/* 'H' => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( CONJG(DL) ) */
+/* (only if matrix Hermitian or nonsymmetric) */
+/* 'S' => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DL ) */
+/* (only if matrix symmetric or nonsymmetric) */
+/* 'E' => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by inv( diag( DL ) ) */
+/* ( 'S' for similarity ) */
+/* (only if matrix nonsymmetric) */
+/* Note: if GRADE='S', then M must equal N. */
+/* Not modified. */
+
+/* DL - COMPLEX array, dimension (M) */
+/* If MODEL=0, then on entry this array specifies the diagonal */
+/* entries of a diagonal matrix used as described under GRADE */
+/* above. If MODEL is not zero, then DL will be set according */
+/* to MODEL and CONDL, analogous to the way D is set according */
+/* to MODE and COND (except there is no DMAX parameter for DL). */
+/* If GRADE='E', then DL cannot have zero entries. */
+/* Not referenced if GRADE = 'N' or 'R'. Changed on exit. */
+
+/* MODEL - INTEGER */
+/* This specifies how the diagonal array DL is to be computed, */
+/* just as MODE specifies how D is to be computed. */
+/* Not modified. */
+
+/* CONDL - REAL */
+/* When MODEL is not zero, this specifies the condition number */
+/* of the computed DL. Not modified. */
+
+/* DR - COMPLEX array, dimension (N) */
+/* If MODER=0, then on entry this array specifies the diagonal */
+/* entries of a diagonal matrix used as described under GRADE */
+/* above. If MODER is not zero, then DR will be set according */
+/* to MODER and CONDR, analogous to the way D is set according */
+/* to MODE and COND (except there is no DMAX parameter for DR). */
+/* Not referenced if GRADE = 'N', 'L', 'H' or 'S'. */
+/* Changed on exit. */
+
+/* MODER - INTEGER */
+/* This specifies how the diagonal array DR is to be computed, */
+/* just as MODE specifies how D is to be computed. */
+/* Not modified. */
+
+/* CONDR - REAL */
+/* When MODER is not zero, this specifies the condition number */
+/* of the computed DR. Not modified. */
+
+/* PIVTNG - CHARACTER*1 */
+/* On entry specifies pivoting permutations as follows: */
+/* 'N' or ' ' => none. */
+/* 'L' => left or row pivoting (matrix must be nonsymmetric). */
+/* 'R' => right or column pivoting (matrix must be */
+/* nonsymmetric). */
+/* 'B' or 'F' => both or full pivoting, i.e., on both sides. */
+/* In this case, M must equal N */
+
+/* If two calls to CLATMR both have full bandwidth (KL = M-1 */
+/* and KU = N-1), and differ only in the PIVTNG and PACK */
+/* parameters, then the matrices generated will differ only */
+/* in the order of the rows and/or columns, and otherwise */
+/* contain the same data. This consistency cannot be */
+/* maintained with less than full bandwidth. */
+
+/* IPIVOT - INTEGER array, dimension (N or M) */
+/* This array specifies the permutation used. After the */
+/* basic matrix is generated, the rows, columns, or both */
+/* are permuted. If, say, row pivoting is selected, CLATMR */
+/* starts with the *last* row and interchanges the M-th and */
+/* IPIVOT(M)-th rows, then moves to the next-to-last row, */
+/* interchanging the (M-1)-th and the IPIVOT(M-1)-th rows, */
+/* and so on. In terms of "2-cycles", the permutation is */
+/* (1 IPIVOT(1)) (2 IPIVOT(2)) ... (M IPIVOT(M)) */
+/* where the rightmost cycle is applied first. This is the */
+/* *inverse* of the effect of pivoting in LINPACK. The idea */
+/* is that factoring (with pivoting) an identity matrix */
+/* which has been inverse-pivoted in this way should */
+/* result in a pivot vector identical to IPIVOT. */
+/* Not referenced if PIVTNG = 'N'. Not modified. */
+
+/* SPARSE - REAL */
+/* On entry specifies the sparsity of the matrix if a sparse */
+/* matrix is to be generated. SPARSE should lie between */
+/* 0 and 1. To generate a sparse matrix, for each matrix entry */
+/* a uniform ( 0, 1 ) random number x is generated and */
+/* compared to SPARSE; if x is larger the matrix entry */
+/* is unchanged and if x is smaller the entry is set */
+/* to zero. Thus on the average a fraction SPARSE of the */
+/* entries will be set to zero. */
+/* Not modified. */
+
+/* KL - INTEGER */
+/* On entry specifies the lower bandwidth of the matrix. For */
+/* example, KL=0 implies upper triangular, KL=1 implies upper */
+/* Hessenberg, and KL at least M-1 implies the matrix is not */
+/* banded. Must equal KU if matrix is symmetric or Hermitian. */
+/* Not modified. */
+
+/* KU - INTEGER */
+/* On entry specifies the upper bandwidth of the matrix. For */
+/* example, KU=0 implies lower triangular, KU=1 implies lower */
+/* Hessenberg, and KU at least N-1 implies the matrix is not */
+/* banded. Must equal KL if matrix is symmetric or Hermitian. */
+/* Not modified. */
+
+/* ANORM - REAL */
+/* On entry specifies maximum entry of output matrix */
+/* (output matrix will by multiplied by a constant so that */
+/* its largest absolute entry equal ANORM) */
+/* if ANORM is nonnegative. If ANORM is negative no scaling */
+/* is done. Not modified. */
+
+/* PACK - CHARACTER*1 */
+/* On entry specifies packing of matrix as follows: */
+/* 'N' => no packing */
+/* 'U' => zero out all subdiagonal entries */
+/* (if symmetric or Hermitian) */
+/* 'L' => zero out all superdiagonal entries */
+/* (if symmetric or Hermitian) */
+/* 'C' => store the upper triangle columnwise */
+/* (only if matrix symmetric or Hermitian or */
+/* square upper triangular) */
+/* 'R' => store the lower triangle columnwise */
+/* (only if matrix symmetric or Hermitian or */
+/* square lower triangular) */
+/* (same as upper half rowwise if symmetric) */
+/* (same as conjugate upper half rowwise if Hermitian) */
+/* 'B' => store the lower triangle in band storage scheme */
+/* (only if matrix symmetric or Hermitian) */
+/* 'Q' => store the upper triangle in band storage scheme */
+/* (only if matrix symmetric or Hermitian) */
+/* 'Z' => store the entire matrix in band storage scheme */
+/* (pivoting can be provided for by using this */
+/* option to store A in the trailing rows of */
+/* the allocated storage) */
+
+/* Using these options, the various LAPACK packed and banded */
+/* storage schemes can be obtained: */
+/* GB - use 'Z' */
+/* PB, HB or TB - use 'B' or 'Q' */
+/* PP, HP or TP - use 'C' or 'R' */
+
+/* If two calls to CLATMR differ only in the PACK parameter, */
+/* they will generate mathematically equivalent matrices. */
+/* Not modified. */
+
+/* A - COMPLEX array, dimension (LDA,N) */
+/* On exit A is the desired test matrix. Only those */
+/* entries of A which are significant on output */
+/* will be referenced (even if A is in packed or band */
+/* storage format). The 'unoccupied corners' of A in */
+/* band format will be zeroed out. */
+
+/* LDA - INTEGER */
+/* on entry LDA specifies the first dimension of A as */
+/* declared in the calling program. */
+/* If PACK='N', 'U' or 'L', LDA must be at least max ( 1, M ). */
+/* If PACK='C' or 'R', LDA must be at least 1. */
+/* If PACK='B', or 'Q', LDA must be MIN ( KU+1, N ) */
+/* If PACK='Z', LDA must be at least KUU+KLL+1, where */
+/* KUU = MIN ( KU, N-1 ) and KLL = MIN ( KL, N-1 ) */
+/* Not modified. */
+
+/* IWORK - INTEGER array, dimension (N or M) */
+/* Workspace. Not referenced if PIVTNG = 'N'. Changed on exit. */
+
+/* INFO - INTEGER */
+/* Error parameter on exit: */
+/* 0 => normal return */
+/* -1 => M negative or unequal to N and SYM='S' or 'H' */
+/* -2 => N negative */
+/* -3 => DIST illegal string */
+/* -5 => SYM illegal string */
+/* -7 => MODE not in range -6 to 6 */
+/* -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */
+/* -10 => MODE neither -6, 0 nor 6 and RSIGN illegal string */
+/* -11 => GRADE illegal string, or GRADE='E' and */
+/* M not equal to N, or GRADE='L', 'R', 'B', 'S' or 'E' */
+/* and SYM = 'H', or GRADE='L', 'R', 'B', 'H' or 'E' */
+/* and SYM = 'S' */
+/* -12 => GRADE = 'E' and DL contains zero */
+/* -13 => MODEL not in range -6 to 6 and GRADE= 'L', 'B', 'H', */
+/* 'S' or 'E' */
+/* -14 => CONDL less than 1.0, GRADE='L', 'B', 'H', 'S' or 'E', */
+/* and MODEL neither -6, 0 nor 6 */
+/* -16 => MODER not in range -6 to 6 and GRADE= 'R' or 'B' */
+/* -17 => CONDR less than 1.0, GRADE='R' or 'B', and */
+/* MODER neither -6, 0 nor 6 */
+/* -18 => PIVTNG illegal string, or PIVTNG='B' or 'F' and */
+/* M not equal to N, or PIVTNG='L' or 'R' and SYM='S' */
+/* or 'H' */
+/* -19 => IPIVOT contains out of range number and */
+/* PIVTNG not equal to 'N' */
+/* -20 => KL negative */
+/* -21 => KU negative, or SYM='S' or 'H' and KU not equal to KL */
+/* -22 => SPARSE not in range 0. to 1. */
+/* -24 => PACK illegal string, or PACK='U', 'L', 'B' or 'Q' */
+/* and SYM='N', or PACK='C' and SYM='N' and either KL */
+/* not equal to 0 or N not equal to M, or PACK='R' and */
+/* SYM='N', and either KU not equal to 0 or N not equal */
+/* to M */
+/* -26 => LDA too small */
+/* 1 => Error return from CLATM1 (computing D) */
+/* 2 => Cannot scale diagonal to DMAX (max. entry is 0) */
+/* 3 => Error return from CLATM1 (computing DL) */
+/* 4 => Error return from CLATM1 (computing DR) */
+/* 5 => ANORM is positive, but matrix constructed prior to */
+/* attempting to scale it to have norm ANORM, is zero */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Decode and Test the input parameters. */
+/* Initialize flags & seed. */
+
+ /* Parameter adjustments */
+ --iseed;
+ --d__;
+ --dl;
+ --dr;
+ --ipivot;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Decode DIST */
+
+ if (lsame_(dist, "U")) {
+ idist = 1;
+ } else if (lsame_(dist, "S")) {
+ idist = 2;
+ } else if (lsame_(dist, "N")) {
+ idist = 3;
+ } else if (lsame_(dist, "D")) {
+ idist = 4;
+ } else {
+ idist = -1;
+ }
+
+/* Decode SYM */
+
+ if (lsame_(sym, "H")) {
+ isym = 0;
+ } else if (lsame_(sym, "N")) {
+ isym = 1;
+ } else if (lsame_(sym, "S")) {
+ isym = 2;
+ } else {
+ isym = -1;
+ }
+
+/* Decode RSIGN */
+
+ if (lsame_(rsign, "F")) {
+ irsign = 0;
+ } else if (lsame_(rsign, "T")) {
+ irsign = 1;
+ } else {
+ irsign = -1;
+ }
+
+/* Decode PIVTNG */
+
+ if (lsame_(pivtng, "N")) {
+ ipvtng = 0;
+ } else if (lsame_(pivtng, " ")) {
+ ipvtng = 0;
+ } else if (lsame_(pivtng, "L")) {
+ ipvtng = 1;
+ npvts = *m;
+ } else if (lsame_(pivtng, "R")) {
+ ipvtng = 2;
+ npvts = *n;
+ } else if (lsame_(pivtng, "B")) {
+ ipvtng = 3;
+ npvts = min(*n,*m);
+ } else if (lsame_(pivtng, "F")) {
+ ipvtng = 3;
+ npvts = min(*n,*m);
+ } else {
+ ipvtng = -1;
+ }
+
+/* Decode GRADE */
+
+ if (lsame_(grade, "N")) {
+ igrade = 0;
+ } else if (lsame_(grade, "L")) {
+ igrade = 1;
+ } else if (lsame_(grade, "R")) {
+ igrade = 2;
+ } else if (lsame_(grade, "B")) {
+ igrade = 3;
+ } else if (lsame_(grade, "E")) {
+ igrade = 4;
+ } else if (lsame_(grade, "H")) {
+ igrade = 5;
+ } else if (lsame_(grade, "S")) {
+ igrade = 6;
+ } else {
+ igrade = -1;
+ }
+
+/* Decode PACK */
+
+ if (lsame_(pack, "N")) {
+ ipack = 0;
+ } else if (lsame_(pack, "U")) {
+ ipack = 1;
+ } else if (lsame_(pack, "L")) {
+ ipack = 2;
+ } else if (lsame_(pack, "C")) {
+ ipack = 3;
+ } else if (lsame_(pack, "R")) {
+ ipack = 4;
+ } else if (lsame_(pack, "B")) {
+ ipack = 5;
+ } else if (lsame_(pack, "Q")) {
+ ipack = 6;
+ } else if (lsame_(pack, "Z")) {
+ ipack = 7;
+ } else {
+ ipack = -1;
+ }
+
+/* Set certain internal parameters */
+
+ mnmin = min(*m,*n);
+/* Computing MIN */
+ i__1 = *kl, i__2 = *m - 1;
+ kll = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *ku, i__2 = *n - 1;
+ kuu = min(i__1,i__2);
+
+/* If inv(DL) is used, check to see if DL has a zero entry. */
+
+ dzero = FALSE_;
+ if (igrade == 4 && *model == 0) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ if (dl[i__2].r == 0.f && dl[i__2].i == 0.f) {
+ dzero = TRUE_;
+ }
+/* L10: */
+ }
+ }
+
+/* Check values in IPIVOT */
+
+ badpvt = FALSE_;
+ if (ipvtng > 0) {
+ i__1 = npvts;
+ for (j = 1; j <= i__1; ++j) {
+ if (ipivot[j] <= 0 || ipivot[j] > npvts) {
+ badpvt = TRUE_;
+ }
+/* L20: */
+ }
+ }
+
+/* Set INFO if an error */
+
+ if (*m < 0) {
+ *info = -1;
+ } else if (*m != *n && (isym == 0 || isym == 2)) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (idist == -1) {
+ *info = -3;
+ } else if (isym == -1) {
+ *info = -5;
+ } else if (*mode < -6 || *mode > 6) {
+ *info = -7;
+ } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.f) {
+ *info = -8;
+ } else if (*mode != -6 && *mode != 0 && *mode != 6 && irsign == -1) {
+ *info = -10;
+ } else if (igrade == -1 || igrade == 4 && *m != *n || (igrade == 1 ||
+ igrade == 2 || igrade == 3 || igrade == 4 || igrade == 6) && isym
+ == 0 || (igrade == 1 || igrade == 2 || igrade == 3 || igrade == 4
+ || igrade == 5) && isym == 2) {
+ *info = -11;
+ } else if (igrade == 4 && dzero) {
+ *info = -12;
+ } else if ((igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5 ||
+ igrade == 6) && (*model < -6 || *model > 6)) {
+ *info = -13;
+ } else if ((igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5 ||
+ igrade == 6) && (*model != -6 && *model != 0 && *model != 6) && *
+ condl < 1.f) {
+ *info = -14;
+ } else if ((igrade == 2 || igrade == 3) && (*moder < -6 || *moder > 6)) {
+ *info = -16;
+ } else if ((igrade == 2 || igrade == 3) && (*moder != -6 && *moder != 0 &&
+ *moder != 6) && *condr < 1.f) {
+ *info = -17;
+ } else if (ipvtng == -1 || ipvtng == 3 && *m != *n || (ipvtng == 1 ||
+ ipvtng == 2) && (isym == 0 || isym == 2)) {
+ *info = -18;
+ } else if (ipvtng != 0 && badpvt) {
+ *info = -19;
+ } else if (*kl < 0) {
+ *info = -20;
+ } else if (*ku < 0 || (isym == 0 || isym == 2) && *kl != *ku) {
+ *info = -21;
+ } else if (*sparse < 0.f || *sparse > 1.f) {
+ *info = -22;
+ } else if (ipack == -1 || (ipack == 1 || ipack == 2 || ipack == 5 ||
+ ipack == 6) && isym == 1 || ipack == 3 && isym == 1 && (*kl != 0
+ || *m != *n) || ipack == 4 && isym == 1 && (*ku != 0 || *m != *n))
+ {
+ *info = -24;
+ } else if ((ipack == 0 || ipack == 1 || ipack == 2) && *lda < max(1,*m) ||
+ (ipack == 3 || ipack == 4) && *lda < 1 || (ipack == 5 || ipack ==
+ 6) && *lda < kuu + 1 || ipack == 7 && *lda < kll + kuu + 1) {
+ *info = -26;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLATMR", &i__1);
+ return 0;
+ }
+
+/* Decide if we can pivot consistently */
+
+ fulbnd = FALSE_;
+ if (kuu == *n - 1 && kll == *m - 1) {
+ fulbnd = TRUE_;
+ }
+
+/* Initialize random number generator */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
+/* L30: */
+ }
+
+ iseed[4] = (iseed[4] / 2 << 1) + 1;
+
+/* 2) Set up D, DL, and DR, if indicated. */
+
+/* Compute D according to COND and MODE */
+
+ clatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, info);
+ if (*info != 0) {
+ *info = 1;
+ return 0;
+ }
+ if (*mode != 0 && *mode != -6 && *mode != 6) {
+
+/* Scale by DMAX */
+
+ temp = c_abs(&d__[1]);
+ i__1 = mnmin;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__1 = temp, r__2 = c_abs(&d__[i__]);
+ temp = dmax(r__1,r__2);
+/* L40: */
+ }
+ if (temp == 0.f && (dmax__->r != 0.f || dmax__->i != 0.f)) {
+ *info = 2;
+ return 0;
+ }
+ if (temp != 0.f) {
+ q__1.r = dmax__->r / temp, q__1.i = dmax__->i / temp;
+ calpha.r = q__1.r, calpha.i = q__1.i;
+ } else {
+ calpha.r = 1.f, calpha.i = 0.f;
+ }
+ i__1 = mnmin;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ q__1.r = calpha.r * d__[i__3].r - calpha.i * d__[i__3].i, q__1.i =
+ calpha.r * d__[i__3].i + calpha.i * d__[i__3].r;
+ d__[i__2].r = q__1.r, d__[i__2].i = q__1.i;
+/* L50: */
+ }
+
+ }
+
+/* If matrix Hermitian, make D real */
+
+ if (isym == 0) {
+ i__1 = mnmin;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ r__1 = d__[i__3].r;
+ d__[i__2].r = r__1, d__[i__2].i = 0.f;
+/* L60: */
+ }
+ }
+
+/* Compute DL if grading set */
+
+ if (igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5 || igrade ==
+ 6) {
+ clatm1_(model, condl, &c__0, &idist, &iseed[1], &dl[1], m, info);
+ if (*info != 0) {
+ *info = 3;
+ return 0;
+ }
+ }
+
+/* Compute DR if grading set */
+
+ if (igrade == 2 || igrade == 3) {
+ clatm1_(moder, condr, &c__0, &idist, &iseed[1], &dr[1], n, info);
+ if (*info != 0) {
+ *info = 4;
+ return 0;
+ }
+ }
+
+/* 3) Generate IWORK if pivoting */
+
+ if (ipvtng > 0) {
+ i__1 = npvts;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ iwork[i__] = i__;
+/* L70: */
+ }
+ if (fulbnd) {
+ i__1 = npvts;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ k = ipivot[i__];
+ j = iwork[i__];
+ iwork[i__] = iwork[k];
+ iwork[k] = j;
+/* L80: */
+ }
+ } else {
+ for (i__ = npvts; i__ >= 1; --i__) {
+ k = ipivot[i__];
+ j = iwork[i__];
+ iwork[i__] = iwork[k];
+ iwork[k] = j;
+/* L90: */
+ }
+ }
+ }
+
+/* 4) Generate matrices for each kind of PACKing */
+/* Always sweep matrix columnwise (if symmetric, upper */
+/* half only) so that matrix generated does not depend */
+/* on PACK */
+
+ if (fulbnd) {
+
+/* Use CLATM3 so matrices generated with differing PIVOTing only */
+/* differ only in the order of their rows and/or columns. */
+
+ if (ipack == 0) {
+ if (isym == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ clatm3_(&q__1, m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__3 = isub + jsub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+ i__3 = jsub + isub * a_dim1;
+ r_cnjg(&q__1, &ctemp);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L100: */
+ }
+/* L110: */
+ }
+ } else if (isym == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ clatm3_(&q__1, m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__3 = isub + jsub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+/* L120: */
+ }
+/* L130: */
+ }
+ } else if (isym == 2) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ clatm3_(&q__1, m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__3 = isub + jsub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+ i__3 = jsub + isub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+/* L140: */
+ }
+/* L150: */
+ }
+ }
+
+ } else if (ipack == 1) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ clatm3_(&q__1, m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ if (mxsub == isub && isym == 0) {
+ i__3 = mnsub + mxsub * a_dim1;
+ r_cnjg(&q__1, &ctemp);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ } else {
+ i__3 = mnsub + mxsub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+ }
+ if (mnsub != mxsub) {
+ i__3 = mxsub + mnsub * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+
+ } else if (ipack == 2) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ clatm3_(&q__1, m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ if (mxsub == jsub && isym == 0) {
+ i__3 = mxsub + mnsub * a_dim1;
+ r_cnjg(&q__1, &ctemp);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ } else {
+ i__3 = mxsub + mnsub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+ }
+ if (mnsub != mxsub) {
+ i__3 = mnsub + mxsub * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ }
+/* L180: */
+ }
+/* L190: */
+ }
+
+ } else if (ipack == 3) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ clatm3_(&q__1, m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+
+/* Compute K = location of (ISUB,JSUB) entry in packed */
+/* array */
+
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ k = mxsub * (mxsub - 1) / 2 + mnsub;
+
+/* Convert K to (IISUB,JJSUB) location */
+
+ jjsub = (k - 1) / *lda + 1;
+ iisub = k - *lda * (jjsub - 1);
+
+ if (mxsub == isub && isym == 0) {
+ i__3 = iisub + jjsub * a_dim1;
+ r_cnjg(&q__1, &ctemp);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ } else {
+ i__3 = iisub + jjsub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+
+ } else if (ipack == 4) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ clatm3_(&q__1, m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+
+/* Compute K = location of (I,J) entry in packed array */
+
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ if (mnsub == 1) {
+ k = mxsub;
+ } else {
+ k = *n * (*n + 1) / 2 - (*n - mnsub + 1) * (*n -
+ mnsub + 2) / 2 + mxsub - mnsub + 1;
+ }
+
+/* Convert K to (IISUB,JJSUB) location */
+
+ jjsub = (k - 1) / *lda + 1;
+ iisub = k - *lda * (jjsub - 1);
+
+ if (mxsub == jsub && isym == 0) {
+ i__3 = iisub + jjsub * a_dim1;
+ r_cnjg(&q__1, &ctemp);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ } else {
+ i__3 = iisub + jjsub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+ }
+/* L220: */
+ }
+/* L230: */
+ }
+
+ } else if (ipack == 5) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ if (i__ < 1) {
+ i__3 = j - i__ + 1 + (i__ + *n) * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ } else {
+ clatm3_(&q__1, m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ if (mxsub == jsub && isym == 0) {
+ i__3 = mxsub - mnsub + 1 + mnsub * a_dim1;
+ r_cnjg(&q__1, &ctemp);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ } else {
+ i__3 = mxsub - mnsub + 1 + mnsub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+ }
+ }
+/* L240: */
+ }
+/* L250: */
+ }
+
+ } else if (ipack == 6) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ clatm3_(&q__1, m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ if (mxsub == isub && isym == 0) {
+ i__3 = mnsub - mxsub + kuu + 1 + mxsub * a_dim1;
+ r_cnjg(&q__1, &ctemp);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ } else {
+ i__3 = mnsub - mxsub + kuu + 1 + mxsub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+ }
+/* L260: */
+ }
+/* L270: */
+ }
+
+ } else if (ipack == 7) {
+
+ if (isym != 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ clatm3_(&q__1, m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ if (i__ < 1) {
+ i__3 = j - i__ + 1 + kuu + (i__ + *n) * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ }
+ if (mxsub == isub && isym == 0) {
+ i__3 = mnsub - mxsub + kuu + 1 + mxsub * a_dim1;
+ r_cnjg(&q__1, &ctemp);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ } else {
+ i__3 = mnsub - mxsub + kuu + 1 + mxsub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+ }
+ if (i__ >= 1 && mnsub != mxsub) {
+ if (mnsub == isub && isym == 0) {
+ i__3 = mxsub - mnsub + 1 + kuu + mnsub *
+ a_dim1;
+ r_cnjg(&q__1, &ctemp);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ } else {
+ i__3 = mxsub - mnsub + 1 + kuu + mnsub *
+ a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+ }
+ }
+/* L280: */
+ }
+/* L290: */
+ }
+ } else if (isym == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + kll;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ clatm3_(&q__1, m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ i__3 = isub - jsub + kuu + 1 + jsub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+/* L300: */
+ }
+/* L310: */
+ }
+ }
+
+ }
+
+ } else {
+
+/* Use CLATM2 */
+
+ if (ipack == 0) {
+ if (isym == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, &iseed[
+ 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng,
+ &iwork[1], sparse);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ i__3 = j + i__ * a_dim1;
+ r_cnjg(&q__1, &a[i__ + j * a_dim1]);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L320: */
+ }
+/* L330: */
+ }
+ } else if (isym == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, &iseed[
+ 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng,
+ &iwork[1], sparse);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L340: */
+ }
+/* L350: */
+ }
+ } else if (isym == 2) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, &iseed[
+ 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng,
+ &iwork[1], sparse);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ i__3 = j + i__ * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
+/* L360: */
+ }
+/* L370: */
+ }
+ }
+
+ } else if (ipack == 1) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, &iseed[1],
+ &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, &iwork[
+ 1], sparse);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ if (i__ != j) {
+ i__3 = j + i__ * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ }
+/* L380: */
+ }
+/* L390: */
+ }
+
+ } else if (ipack == 2) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (isym == 0) {
+ i__3 = j + i__ * a_dim1;
+ clatm2_(&q__2, m, n, &i__, &j, kl, ku, &idist, &iseed[
+ 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng,
+ &iwork[1], sparse);
+ r_cnjg(&q__1, &q__2);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ } else {
+ i__3 = j + i__ * a_dim1;
+ clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, &iseed[
+ 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng,
+ &iwork[1], sparse);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ }
+ if (i__ != j) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ }
+/* L400: */
+ }
+/* L410: */
+ }
+
+ } else if (ipack == 3) {
+
+ isub = 0;
+ jsub = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ++isub;
+ if (isub > *lda) {
+ isub = 1;
+ ++jsub;
+ }
+ i__3 = isub + jsub * a_dim1;
+ clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, &iseed[1],
+ &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, &iwork[
+ 1], sparse);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L420: */
+ }
+/* L430: */
+ }
+
+ } else if (ipack == 4) {
+
+ if (isym == 0 || isym == 2) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+
+/* Compute K = location of (I,J) entry in packed array */
+
+ if (i__ == 1) {
+ k = j;
+ } else {
+ k = *n * (*n + 1) / 2 - (*n - i__ + 1) * (*n -
+ i__ + 2) / 2 + j - i__ + 1;
+ }
+
+/* Convert K to (ISUB,JSUB) location */
+
+ jsub = (k - 1) / *lda + 1;
+ isub = k - *lda * (jsub - 1);
+
+ i__3 = isub + jsub * a_dim1;
+ clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, &iseed[
+ 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng,
+ &iwork[1], sparse);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ if (isym == 0) {
+ i__3 = isub + jsub * a_dim1;
+ r_cnjg(&q__1, &a[isub + jsub * a_dim1]);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ }
+/* L440: */
+ }
+/* L450: */
+ }
+ } else {
+ isub = 0;
+ jsub = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ++isub;
+ if (isub > *lda) {
+ isub = 1;
+ ++jsub;
+ }
+ i__3 = isub + jsub * a_dim1;
+ clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, &iseed[
+ 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng,
+ &iwork[1], sparse);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L460: */
+ }
+/* L470: */
+ }
+ }
+
+ } else if (ipack == 5) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ if (i__ < 1) {
+ i__3 = j - i__ + 1 + (i__ + *n) * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ } else {
+ if (isym == 0) {
+ i__3 = j - i__ + 1 + i__ * a_dim1;
+ clatm2_(&q__2, m, n, &i__, &j, kl, ku, &idist, &
+ iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ r_cnjg(&q__1, &q__2);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ } else {
+ i__3 = j - i__ + 1 + i__ * a_dim1;
+ clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, &
+ iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ }
+ }
+/* L480: */
+ }
+/* L490: */
+ }
+
+ } else if (ipack == 6) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ i__3 = i__ - j + kuu + 1 + j * a_dim1;
+ clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, &iseed[1],
+ &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, &iwork[
+ 1], sparse);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L500: */
+ }
+/* L510: */
+ }
+
+ } else if (ipack == 7) {
+
+ if (isym != 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ i__3 = i__ - j + kuu + 1 + j * a_dim1;
+ clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, &iseed[
+ 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng,
+ &iwork[1], sparse);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ if (i__ < 1) {
+ i__3 = j - i__ + 1 + kuu + (i__ + *n) * a_dim1;
+ a[i__3].r = 0.f, a[i__3].i = 0.f;
+ }
+ if (i__ >= 1 && i__ != j) {
+ if (isym == 0) {
+ i__3 = j - i__ + 1 + kuu + i__ * a_dim1;
+ r_cnjg(&q__1, &a[i__ - j + kuu + 1 + j *
+ a_dim1]);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+ } else {
+ i__3 = j - i__ + 1 + kuu + i__ * a_dim1;
+ i__4 = i__ - j + kuu + 1 + j * a_dim1;
+ a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
+ }
+ }
+/* L520: */
+ }
+/* L530: */
+ }
+ } else if (isym == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + kll;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ i__3 = i__ - j + kuu + 1 + j * a_dim1;
+ clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, &iseed[
+ 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng,
+ &iwork[1], sparse);
+ a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L540: */
+ }
+/* L550: */
+ }
+ }
+
+ }
+
+ }
+
+/* 5) Scaling the norm */
+
+ if (ipack == 0) {
+ onorm = clange_("M", m, n, &a[a_offset], lda, tempa);
+ } else if (ipack == 1) {
+ onorm = clansy_("M", "U", n, &a[a_offset], lda, tempa);
+ } else if (ipack == 2) {
+ onorm = clansy_("M", "L", n, &a[a_offset], lda, tempa);
+ } else if (ipack == 3) {
+ onorm = clansp_("M", "U", n, &a[a_offset], tempa);
+ } else if (ipack == 4) {
+ onorm = clansp_("M", "L", n, &a[a_offset], tempa);
+ } else if (ipack == 5) {
+ onorm = clansb_("M", "L", n, &kll, &a[a_offset], lda, tempa);
+ } else if (ipack == 6) {
+ onorm = clansb_("M", "U", n, &kuu, &a[a_offset], lda, tempa);
+ } else if (ipack == 7) {
+ onorm = clangb_("M", n, &kll, &kuu, &a[a_offset], lda, tempa);
+ }
+
+ if (*anorm >= 0.f) {
+
+ if (*anorm > 0.f && onorm == 0.f) {
+
+/* Desired scaling impossible */
+
+ *info = 5;
+ return 0;
+
+ } else if (*anorm > 1.f && onorm < 1.f || *anorm < 1.f && onorm > 1.f)
+ {
+
+/* Scale carefully to avoid over / underflow */
+
+ if (ipack <= 2) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ r__1 = 1.f / onorm;
+ csscal_(m, &r__1, &a[j * a_dim1 + 1], &c__1);
+ csscal_(m, anorm, &a[j * a_dim1 + 1], &c__1);
+/* L560: */
+ }
+
+ } else if (ipack == 3 || ipack == 4) {
+
+ i__1 = *n * (*n + 1) / 2;
+ r__1 = 1.f / onorm;
+ csscal_(&i__1, &r__1, &a[a_offset], &c__1);
+ i__1 = *n * (*n + 1) / 2;
+ csscal_(&i__1, anorm, &a[a_offset], &c__1);
+
+ } else if (ipack >= 5) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = kll + kuu + 1;
+ r__1 = 1.f / onorm;
+ csscal_(&i__2, &r__1, &a[j * a_dim1 + 1], &c__1);
+ i__2 = kll + kuu + 1;
+ csscal_(&i__2, anorm, &a[j * a_dim1 + 1], &c__1);
+/* L570: */
+ }
+
+ }
+
+ } else {
+
+/* Scale straightforwardly */
+
+ if (ipack <= 2) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ r__1 = *anorm / onorm;
+ csscal_(m, &r__1, &a[j * a_dim1 + 1], &c__1);
+/* L580: */
+ }
+
+ } else if (ipack == 3 || ipack == 4) {
+
+ i__1 = *n * (*n + 1) / 2;
+ r__1 = *anorm / onorm;
+ csscal_(&i__1, &r__1, &a[a_offset], &c__1);
+
+ } else if (ipack >= 5) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = kll + kuu + 1;
+ r__1 = *anorm / onorm;
+ csscal_(&i__2, &r__1, &a[j * a_dim1 + 1], &c__1);
+/* L590: */
+ }
+ }
+
+ }
+
+ }
+
+/* End of CLATMR */
+
+ return 0;
+} /* clatmr_ */
diff --git a/TESTING/MATGEN/clatms.c b/TESTING/MATGEN/clatms.c
new file mode 100644
index 0000000..207f2d5
--- /dev/null
+++ b/TESTING/MATGEN/clatms.c
@@ -0,0 +1,1627 @@
+/* clatms.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static integer c__1 = 1;
+static integer c__5 = 5;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int clatms_(integer *m, integer *n, char *dist, integer *
+ iseed, char *sym, real *d__, integer *mode, real *cond, real *dmax__,
+ integer *kl, integer *ku, char *pack, complex *a, integer *lda,
+ complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1, r__2, r__3;
+ complex q__1, q__2, q__3;
+ logical L__1;
+
+ /* Builtin functions */
+ double cos(doublereal), sin(doublereal);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ complex c__;
+ integer i__, j, k;
+ complex s;
+ integer ic, jc, nc, il;
+ complex ct;
+ integer ir, jr, mr;
+ complex st;
+ integer ir1, ir2, jch, llb, jkl, jku, uub, ilda, icol;
+ real temp;
+ logical csym;
+ integer irow, isym;
+ real alpha, angle;
+ integer ipack;
+ real realc;
+ integer ioffg;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ complex ctemp;
+ integer idist, mnmin, iskew;
+ complex extra, dummy;
+ extern /* Subroutine */ int slatm1_(integer *, real *, integer *, integer
+ *, integer *, real *, integer *, integer *), clagge_(integer *,
+ integer *, integer *, integer *, real *, complex *, integer *,
+ integer *, complex *, integer *), claghe_(integer *, integer *,
+ real *, complex *, integer *, integer *, complex *, integer *);
+ integer iendch, ipackg;
+ extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+ integer minlda;
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), clartg_(complex *,
+ complex *, real *, complex *, complex *), xerbla_(char *, integer
+ *), clagsy_(integer *, integer *, real *, complex *,
+ integer *, integer *, complex *, integer *);
+ extern doublereal slarnd_(integer *, integer *);
+ extern /* Subroutine */ int clarot_(logical *, logical *, logical *,
+ integer *, complex *, complex *, complex *, integer *, complex *,
+ complex *);
+ logical iltemp, givens;
+ integer ioffst, irsign;
+ logical ilextr, topdwn;
+ integer isympk;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLATMS generates random matrices with specified singular values */
+/* (or hermitian with specified eigenvalues) */
+/* for testing LAPACK programs. */
+
+/* CLATMS operates by applying the following sequence of */
+/* operations: */
+
+/* Set the diagonal to D, where D may be input or */
+/* computed according to MODE, COND, DMAX, and SYM */
+/* as described below. */
+
+/* Generate a matrix with the appropriate band structure, by one */
+/* of two methods: */
+
+/* Method A: */
+/* Generate a dense M x N matrix by multiplying D on the left */
+/* and the right by random unitary matrices, then: */
+
+/* Reduce the bandwidth according to KL and KU, using */
+/* Householder transformations. */
+
+/* Method B: */
+/* Convert the bandwidth-0 (i.e., diagonal) matrix to a */
+/* bandwidth-1 matrix using Givens rotations, "chasing" */
+/* out-of-band elements back, much as in QR; then convert */
+/* the bandwidth-1 to a bandwidth-2 matrix, etc. Note */
+/* that for reasonably small bandwidths (relative to M and */
+/* N) this requires less storage, as a dense matrix is not */
+/* generated. Also, for hermitian or symmetric matrices, */
+/* only one triangle is generated. */
+
+/* Method A is chosen if the bandwidth is a large fraction of the */
+/* order of the matrix, and LDA is at least M (so a dense */
+/* matrix can be stored.) Method B is chosen if the bandwidth */
+/* is small (< 1/2 N for hermitian or symmetric, < .3 N+M for */
+/* non-symmetric), or LDA is less than M and not less than the */
+/* bandwidth. */
+
+/* Pack the matrix if desired. Options specified by PACK are: */
+/* no packing */
+/* zero out upper half (if hermitian) */
+/* zero out lower half (if hermitian) */
+/* store the upper half columnwise (if hermitian or upper */
+/* triangular) */
+/* store the lower half columnwise (if hermitian or lower */
+/* triangular) */
+/* store the lower triangle in banded format (if hermitian or */
+/* lower triangular) */
+/* store the upper triangle in banded format (if hermitian or */
+/* upper triangular) */
+/* store the entire matrix in banded format */
+/* If Method B is chosen, and band format is specified, then the */
+/* matrix will be generated in the band format, so no repacking */
+/* will be necessary. */
+
+/* Arguments */
+/* ========= */
+
+/* M - INTEGER */
+/* The number of rows of A. Not modified. */
+
+/* N - INTEGER */
+/* The number of columns of A. N must equal M if the matrix */
+/* is symmetric or hermitian (i.e., if SYM is not 'N') */
+/* Not modified. */
+
+/* DIST - CHARACTER*1 */
+/* On entry, DIST specifies the type of distribution to be used */
+/* to generate the random eigen-/singular values. */
+/* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */
+/* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */
+/* 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension ( 4 ) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. They should lie between 0 and 4095 inclusive, */
+/* and ISEED(4) should be odd. The random number generator */
+/* uses a linear congruential sequence limited to small */
+/* integers, and so should produce machine independent */
+/* random numbers. The values of ISEED are changed on */
+/* exit, and can be used in the next call to CLATMS */
+/* to continue the same random number sequence. */
+/* Changed on exit. */
+
+/* SYM - CHARACTER*1 */
+/* If SYM='H', the generated matrix is hermitian, with */
+/* eigenvalues specified by D, COND, MODE, and DMAX; they */
+/* may be positive, negative, or zero. */
+/* If SYM='P', the generated matrix is hermitian, with */
+/* eigenvalues (= singular values) specified by D, COND, */
+/* MODE, and DMAX; they will not be negative. */
+/* If SYM='N', the generated matrix is nonsymmetric, with */
+/* singular values specified by D, COND, MODE, and DMAX; */
+/* they will not be negative. */
+/* If SYM='S', the generated matrix is (complex) symmetric, */
+/* with singular values specified by D, COND, MODE, and */
+/* DMAX; they will not be negative. */
+/* Not modified. */
+
+/* D - REAL array, dimension ( MIN( M, N ) ) */
+/* This array is used to specify the singular values or */
+/* eigenvalues of A (see SYM, above.) If MODE=0, then D is */
+/* assumed to contain the singular/eigenvalues, otherwise */
+/* they will be computed according to MODE, COND, and DMAX, */
+/* and placed in D. */
+/* Modified if MODE is nonzero. */
+
+/* MODE - INTEGER */
+/* On entry this describes how the singular/eigenvalues are to */
+/* be specified: */
+/* MODE = 0 means use D as input */
+/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
+/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
+/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
+/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* MODE = 5 sets D to random numbers in the range */
+/* ( 1/COND , 1 ) such that their logarithms */
+/* are uniformly distributed. */
+/* MODE = 6 set D to random numbers from same distribution */
+/* as the rest of the matrix. */
+/* MODE < 0 has the same meaning as ABS(MODE), except that */
+/* the order of the elements of D is reversed. */
+/* Thus if MODE is positive, D has entries ranging from */
+/* 1 to 1/COND, if negative, from 1/COND to 1, */
+/* If SYM='H', and MODE is neither 0, 6, nor -6, then */
+/* the elements of D will also be multiplied by a random */
+/* sign (i.e., +1 or -1.) */
+/* Not modified. */
+
+/* COND - REAL */
+/* On entry, this is used as described under MODE above. */
+/* If used, it must be >= 1. Not modified. */
+
+/* DMAX - REAL */
+/* If MODE is neither -6, 0 nor 6, the contents of D, as */
+/* computed according to MODE and COND, will be scaled by */
+/* DMAX / max(abs(D(i))); thus, the maximum absolute eigen- or */
+/* singular value (which is to say the norm) will be abs(DMAX). */
+/* Note that DMAX need not be positive: if DMAX is negative */
+/* (or zero), D will be scaled by a negative number (or zero). */
+/* Not modified. */
+
+/* KL - INTEGER */
+/* This specifies the lower bandwidth of the matrix. For */
+/* example, KL=0 implies upper triangular, KL=1 implies upper */
+/* Hessenberg, and KL being at least M-1 means that the matrix */
+/* has full lower bandwidth. KL must equal KU if the matrix */
+/* is symmetric or hermitian. */
+/* Not modified. */
+
+/* KU - INTEGER */
+/* This specifies the upper bandwidth of the matrix. For */
+/* example, KU=0 implies lower triangular, KU=1 implies lower */
+/* Hessenberg, and KU being at least N-1 means that the matrix */
+/* has full upper bandwidth. KL must equal KU if the matrix */
+/* is symmetric or hermitian. */
+/* Not modified. */
+
+/* PACK - CHARACTER*1 */
+/* This specifies packing of matrix as follows: */
+/* 'N' => no packing */
+/* 'U' => zero out all subdiagonal entries (if symmetric */
+/* or hermitian) */
+/* 'L' => zero out all superdiagonal entries (if symmetric */
+/* or hermitian) */
+/* 'C' => store the upper triangle columnwise (only if the */
+/* matrix is symmetric, hermitian, or upper triangular) */
+/* 'R' => store the lower triangle columnwise (only if the */
+/* matrix is symmetric, hermitian, or lower triangular) */
+/* 'B' => store the lower triangle in band storage scheme */
+/* (only if the matrix is symmetric, hermitian, or */
+/* lower triangular) */
+/* 'Q' => store the upper triangle in band storage scheme */
+/* (only if the matrix is symmetric, hermitian, or */
+/* upper triangular) */
+/* 'Z' => store the entire matrix in band storage scheme */
+/* (pivoting can be provided for by using this */
+/* option to store A in the trailing rows of */
+/* the allocated storage) */
+
+/* Using these options, the various LAPACK packed and banded */
+/* storage schemes can be obtained: */
+/* GB - use 'Z' */
+/* PB, SB, HB, or TB - use 'B' or 'Q' */
+/* PP, SP, HB, or TP - use 'C' or 'R' */
+
+/* If two calls to CLATMS differ only in the PACK parameter, */
+/* they will generate mathematically equivalent matrices. */
+/* Not modified. */
+
+/* A - COMPLEX array, dimension ( LDA, N ) */
+/* On exit A is the desired test matrix. A is first generated */
+/* in full (unpacked) form, and then packed, if so specified */
+/* by PACK. Thus, the first M elements of the first N */
+/* columns will always be modified. If PACK specifies a */
+/* packed or banded storage scheme, all LDA elements of the */
+/* first N columns will be modified; the elements of the */
+/* array which do not correspond to elements of the generated */
+/* matrix are set to zero. */
+/* Modified. */
+
+/* LDA - INTEGER */
+/* LDA specifies the first dimension of A as declared in the */
+/* calling program. If PACK='N', 'U', 'L', 'C', or 'R', then */
+/* LDA must be at least M. If PACK='B' or 'Q', then LDA must */
+/* be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)). */
+/* If PACK='Z', LDA must be large enough to hold the packed */
+/* array: MIN( KU, N-1) + MIN( KL, M-1) + 1. */
+/* Not modified. */
+
+/* WORK - COMPLEX array, dimension ( 3*MAX( N, M ) ) */
+/* Workspace. */
+/* Modified. */
+
+/* INFO - INTEGER */
+/* Error code. On exit, INFO will be set to one of the */
+/* following values: */
+/* 0 => normal return */
+/* -1 => M negative or unequal to N and SYM='S', 'H', or 'P' */
+/* -2 => N negative */
+/* -3 => DIST illegal string */
+/* -5 => SYM illegal string */
+/* -7 => MODE not in range -6 to 6 */
+/* -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */
+/* -10 => KL negative */
+/* -11 => KU negative, or SYM is not 'N' and KU is not equal to */
+/* KL */
+/* -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N'; */
+/* or PACK='C' or 'Q' and SYM='N' and KL is not zero; */
+/* or PACK='R' or 'B' and SYM='N' and KU is not zero; */
+/* or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not */
+/* N. */
+/* -14 => LDA is less than M, or PACK='Z' and LDA is less than */
+/* MIN(KU,N-1) + MIN(KL,M-1) + 1. */
+/* 1 => Error return from SLATM1 */
+/* 2 => Cannot scale to DMAX (max. sing. value is 0) */
+/* 3 => Error return from CLAGGE, CLAGHE or CLAGSY */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Decode and Test the input parameters. */
+/* Initialize flags & seed. */
+
+ /* Parameter adjustments */
+ --iseed;
+ --d__;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Decode DIST */
+
+ if (lsame_(dist, "U")) {
+ idist = 1;
+ } else if (lsame_(dist, "S")) {
+ idist = 2;
+ } else if (lsame_(dist, "N")) {
+ idist = 3;
+ } else {
+ idist = -1;
+ }
+
+/* Decode SYM */
+
+ if (lsame_(sym, "N")) {
+ isym = 1;
+ irsign = 0;
+ csym = FALSE_;
+ } else if (lsame_(sym, "P")) {
+ isym = 2;
+ irsign = 0;
+ csym = FALSE_;
+ } else if (lsame_(sym, "S")) {
+ isym = 2;
+ irsign = 0;
+ csym = TRUE_;
+ } else if (lsame_(sym, "H")) {
+ isym = 2;
+ irsign = 1;
+ csym = FALSE_;
+ } else {
+ isym = -1;
+ }
+
+/* Decode PACK */
+
+ isympk = 0;
+ if (lsame_(pack, "N")) {
+ ipack = 0;
+ } else if (lsame_(pack, "U")) {
+ ipack = 1;
+ isympk = 1;
+ } else if (lsame_(pack, "L")) {
+ ipack = 2;
+ isympk = 1;
+ } else if (lsame_(pack, "C")) {
+ ipack = 3;
+ isympk = 2;
+ } else if (lsame_(pack, "R")) {
+ ipack = 4;
+ isympk = 3;
+ } else if (lsame_(pack, "B")) {
+ ipack = 5;
+ isympk = 3;
+ } else if (lsame_(pack, "Q")) {
+ ipack = 6;
+ isympk = 2;
+ } else if (lsame_(pack, "Z")) {
+ ipack = 7;
+ } else {
+ ipack = -1;
+ }
+
+/* Set certain internal parameters */
+
+ mnmin = min(*m,*n);
+/* Computing MIN */
+ i__1 = *kl, i__2 = *m - 1;
+ llb = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *ku, i__2 = *n - 1;
+ uub = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *m, i__2 = *n + llb;
+ mr = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *n, i__2 = *m + uub;
+ nc = min(i__1,i__2);
+
+ if (ipack == 5 || ipack == 6) {
+ minlda = uub + 1;
+ } else if (ipack == 7) {
+ minlda = llb + uub + 1;
+ } else {
+ minlda = *m;
+ }
+
+/* Use Givens rotation method if bandwidth small enough, */
+/* or if LDA is too small to store the matrix unpacked. */
+
+ givens = FALSE_;
+ if (isym == 1) {
+/* Computing MAX */
+ i__1 = 1, i__2 = mr + nc;
+ if ((real) (llb + uub) < (real) max(i__1,i__2) * .3f) {
+ givens = TRUE_;
+ }
+ } else {
+ if (llb << 1 < *m) {
+ givens = TRUE_;
+ }
+ }
+ if (*lda < *m && *lda >= minlda) {
+ givens = TRUE_;
+ }
+
+/* Set INFO if an error */
+
+ if (*m < 0) {
+ *info = -1;
+ } else if (*m != *n && isym != 1) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (idist == -1) {
+ *info = -3;
+ } else if (isym == -1) {
+ *info = -5;
+ } else if (abs(*mode) > 6) {
+ *info = -7;
+ } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.f) {
+ *info = -8;
+ } else if (*kl < 0) {
+ *info = -10;
+ } else if (*ku < 0 || isym != 1 && *kl != *ku) {
+ *info = -11;
+ } else if (ipack == -1 || isympk == 1 && isym == 1 || isympk == 2 && isym
+ == 1 && *kl > 0 || isympk == 3 && isym == 1 && *ku > 0 || isympk
+ != 0 && *m != *n) {
+ *info = -12;
+ } else if (*lda < max(1,minlda)) {
+ *info = -14;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLATMS", &i__1);
+ return 0;
+ }
+
+/* Initialize random number generator */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
+/* L10: */
+ }
+
+ if (iseed[4] % 2 != 1) {
+ ++iseed[4];
+ }
+
+/* 2) Set up D if indicated. */
+
+/* Compute D according to COND and MODE */
+
+ slatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, &iinfo);
+ if (iinfo != 0) {
+ *info = 1;
+ return 0;
+ }
+
+/* Choose Top-Down if D is (apparently) increasing, */
+/* Bottom-Up if D is (apparently) decreasing. */
+
+ if (dabs(d__[1]) <= (r__1 = d__[mnmin], dabs(r__1))) {
+ topdwn = TRUE_;
+ } else {
+ topdwn = FALSE_;
+ }
+
+ if (*mode != 0 && abs(*mode) != 6) {
+
+/* Scale by DMAX */
+
+ temp = dabs(d__[1]);
+ i__1 = mnmin;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = temp, r__3 = (r__1 = d__[i__], dabs(r__1));
+ temp = dmax(r__2,r__3);
+/* L20: */
+ }
+
+ if (temp > 0.f) {
+ alpha = *dmax__ / temp;
+ } else {
+ *info = 2;
+ return 0;
+ }
+
+ sscal_(&mnmin, &alpha, &d__[1], &c__1);
+
+ }
+
+ claset_("Full", lda, n, &c_b1, &c_b1, &a[a_offset], lda);
+
+/* 3) Generate Banded Matrix using Givens rotations. */
+/* Also the special case of UUB=LLB=0 */
+
+/* Compute Addressing constants to cover all */
+/* storage formats. Whether GE, HE, SY, GB, HB, or SB, */
+/* upper or lower triangle or both, */
+/* the (i,j)-th element is in */
+/* A( i - ISKEW*j + IOFFST, j ) */
+
+ if (ipack > 4) {
+ ilda = *lda - 1;
+ iskew = 1;
+ if (ipack > 5) {
+ ioffst = uub + 1;
+ } else {
+ ioffst = 1;
+ }
+ } else {
+ ilda = *lda;
+ iskew = 0;
+ ioffst = 0;
+ }
+
+/* IPACKG is the format that the matrix is generated in. If this is */
+/* different from IPACK, then the matrix must be repacked at the */
+/* end. It also signals how to compute the norm, for scaling. */
+
+ ipackg = 0;
+
+/* Diagonal Matrix -- We are done, unless it */
+/* is to be stored HP/SP/PP/TP (PACK='R' or 'C') */
+
+ if (llb == 0 && uub == 0) {
+ i__1 = mnmin;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (1 - iskew) * j + ioffst + j * a_dim1;
+ i__3 = j;
+ q__1.r = d__[i__3], q__1.i = 0.f;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L30: */
+ }
+
+ if (ipack <= 2 || ipack >= 5) {
+ ipackg = ipack;
+ }
+
+ } else if (givens) {
+
+/* Check whether to use Givens rotations, */
+/* Householder transformations, or nothing. */
+
+ if (isym == 1) {
+
+/* Non-symmetric -- A = U D V */
+
+ if (ipack > 4) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+
+ i__1 = mnmin;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (1 - iskew) * j + ioffst + j * a_dim1;
+ i__3 = j;
+ q__1.r = d__[i__3], q__1.i = 0.f;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L40: */
+ }
+
+ if (topdwn) {
+ jkl = 0;
+ i__1 = uub;
+ for (jku = 1; jku <= i__1; ++jku) {
+
+/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */
+
+/* Last row actually rotated is M */
+/* Last column actually rotated is MIN( M+JKU, N ) */
+
+/* Computing MIN */
+ i__3 = *m + jku;
+ i__2 = min(i__3,*n) + jkl - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ extra.r = 0.f, extra.i = 0.f;
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ r__1 = cos(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ r__1 = sin(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ s.r = q__1.r, s.i = q__1.i;
+/* Computing MAX */
+ i__3 = 1, i__4 = jr - jkl;
+ icol = max(i__3,i__4);
+ if (jr < *m) {
+/* Computing MIN */
+ i__3 = *n, i__4 = jr + jku;
+ il = min(i__3,i__4) + 1 - icol;
+ L__1 = jr > jkl;
+ clarot_(&c_true, &L__1, &c_false, &il, &c__, &s, &
+ a[jr - iskew * icol + ioffst + icol *
+ a_dim1], &ilda, &extra, &dummy);
+ }
+
+/* Chase "EXTRA" back up */
+
+ ir = jr;
+ ic = icol;
+ i__3 = -jkl - jku;
+ for (jch = jr - jkl; i__3 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__3) {
+ if (ir < *m) {
+ clartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst
+ + (ic + 1) * a_dim1], &extra, &realc,
+ &s, &dummy);
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ dummy.r = q__1.r, dummy.i = q__1.i;
+ q__2.r = realc * dummy.r, q__2.i = realc *
+ dummy.i;
+ r_cnjg(&q__1, &q__2);
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__3.r = -s.r, q__3.i = -s.i;
+ q__2.r = q__3.r * dummy.r - q__3.i * dummy.i,
+ q__2.i = q__3.r * dummy.i + q__3.i *
+ dummy.r;
+ r_cnjg(&q__1, &q__2);
+ s.r = q__1.r, s.i = q__1.i;
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jku;
+ irow = max(i__4,i__5);
+ il = ir + 2 - irow;
+ ctemp.r = 0.f, ctemp.i = 0.f;
+ iltemp = jch > jku;
+ clarot_(&c_false, &iltemp, &c_true, &il, &c__, &s,
+ &a[irow - iskew * ic + ioffst + ic *
+ a_dim1], &ilda, &ctemp, &extra);
+ if (iltemp) {
+ clartg_(&a[irow + 1 - iskew * (ic + 1) +
+ ioffst + (ic + 1) * a_dim1], &ctemp, &
+ realc, &s, &dummy);
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ dummy.r = q__1.r, dummy.i = q__1.i;
+ q__2.r = realc * dummy.r, q__2.i = realc *
+ dummy.i;
+ r_cnjg(&q__1, &q__2);
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__3.r = -s.r, q__3.i = -s.i;
+ q__2.r = q__3.r * dummy.r - q__3.i * dummy.i,
+ q__2.i = q__3.r * dummy.i + q__3.i *
+ dummy.r;
+ r_cnjg(&q__1, &q__2);
+ s.r = q__1.r, s.i = q__1.i;
+
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jku - jkl;
+ icol = max(i__4,i__5);
+ il = ic + 2 - icol;
+ extra.r = 0.f, extra.i = 0.f;
+ L__1 = jch > jku + jkl;
+ clarot_(&c_true, &L__1, &c_true, &il, &c__, &
+ s, &a[irow - iskew * icol + ioffst +
+ icol * a_dim1], &ilda, &extra, &ctemp)
+ ;
+ ic = icol;
+ ir = irow;
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+ jku = uub;
+ i__1 = llb;
+ for (jkl = 1; jkl <= i__1; ++jkl) {
+
+/* Transform from bandwidth JKL-1, JKU to JKL, JKU */
+
+/* Computing MIN */
+ i__3 = *n + jkl;
+ i__2 = min(i__3,*m) + jku - 1;
+ for (jc = 1; jc <= i__2; ++jc) {
+ extra.r = 0.f, extra.i = 0.f;
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ r__1 = cos(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ r__1 = sin(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ s.r = q__1.r, s.i = q__1.i;
+/* Computing MAX */
+ i__3 = 1, i__4 = jc - jku;
+ irow = max(i__3,i__4);
+ if (jc < *n) {
+/* Computing MIN */
+ i__3 = *m, i__4 = jc + jkl;
+ il = min(i__3,i__4) + 1 - irow;
+ L__1 = jc > jku;
+ clarot_(&c_false, &L__1, &c_false, &il, &c__, &s,
+ &a[irow - iskew * jc + ioffst + jc *
+ a_dim1], &ilda, &extra, &dummy);
+ }
+
+/* Chase "EXTRA" back up */
+
+ ic = jc;
+ ir = irow;
+ i__3 = -jkl - jku;
+ for (jch = jc - jku; i__3 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__3) {
+ if (ic < *n) {
+ clartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst
+ + (ic + 1) * a_dim1], &extra, &realc,
+ &s, &dummy);
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ dummy.r = q__1.r, dummy.i = q__1.i;
+ q__2.r = realc * dummy.r, q__2.i = realc *
+ dummy.i;
+ r_cnjg(&q__1, &q__2);
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__3.r = -s.r, q__3.i = -s.i;
+ q__2.r = q__3.r * dummy.r - q__3.i * dummy.i,
+ q__2.i = q__3.r * dummy.i + q__3.i *
+ dummy.r;
+ r_cnjg(&q__1, &q__2);
+ s.r = q__1.r, s.i = q__1.i;
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jkl;
+ icol = max(i__4,i__5);
+ il = ic + 2 - icol;
+ ctemp.r = 0.f, ctemp.i = 0.f;
+ iltemp = jch > jkl;
+ clarot_(&c_true, &iltemp, &c_true, &il, &c__, &s,
+ &a[ir - iskew * icol + ioffst + icol *
+ a_dim1], &ilda, &ctemp, &extra);
+ if (iltemp) {
+ clartg_(&a[ir + 1 - iskew * (icol + 1) +
+ ioffst + (icol + 1) * a_dim1], &ctemp,
+ &realc, &s, &dummy);
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ dummy.r = q__1.r, dummy.i = q__1.i;
+ q__2.r = realc * dummy.r, q__2.i = realc *
+ dummy.i;
+ r_cnjg(&q__1, &q__2);
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__3.r = -s.r, q__3.i = -s.i;
+ q__2.r = q__3.r * dummy.r - q__3.i * dummy.i,
+ q__2.i = q__3.r * dummy.i + q__3.i *
+ dummy.r;
+ r_cnjg(&q__1, &q__2);
+ s.r = q__1.r, s.i = q__1.i;
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jkl - jku;
+ irow = max(i__4,i__5);
+ il = ir + 2 - irow;
+ extra.r = 0.f, extra.i = 0.f;
+ L__1 = jch > jkl + jku;
+ clarot_(&c_false, &L__1, &c_true, &il, &c__, &
+ s, &a[irow - iskew * icol + ioffst +
+ icol * a_dim1], &ilda, &extra, &ctemp)
+ ;
+ ic = icol;
+ ir = irow;
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+
+ } else {
+
+/* Bottom-Up -- Start at the bottom right. */
+
+ jkl = 0;
+ i__1 = uub;
+ for (jku = 1; jku <= i__1; ++jku) {
+
+/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */
+
+/* First row actually rotated is M */
+/* First column actually rotated is MIN( M+JKU, N ) */
+
+/* Computing MIN */
+ i__2 = *m, i__3 = *n + jkl;
+ iendch = min(i__2,i__3) - 1;
+/* Computing MIN */
+ i__2 = *m + jku;
+ i__3 = 1 - jkl;
+ for (jc = min(i__2,*n) - 1; jc >= i__3; --jc) {
+ extra.r = 0.f, extra.i = 0.f;
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ r__1 = cos(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ r__1 = sin(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ s.r = q__1.r, s.i = q__1.i;
+/* Computing MAX */
+ i__2 = 1, i__4 = jc - jku + 1;
+ irow = max(i__2,i__4);
+ if (jc > 0) {
+/* Computing MIN */
+ i__2 = *m, i__4 = jc + jkl + 1;
+ il = min(i__2,i__4) + 1 - irow;
+ L__1 = jc + jkl < *m;
+ clarot_(&c_false, &c_false, &L__1, &il, &c__, &s,
+ &a[irow - iskew * jc + ioffst + jc *
+ a_dim1], &ilda, &dummy, &extra);
+ }
+
+/* Chase "EXTRA" back down */
+
+ ic = jc;
+ i__2 = iendch;
+ i__4 = jkl + jku;
+ for (jch = jc + jkl; i__4 < 0 ? jch >= i__2 : jch <=
+ i__2; jch += i__4) {
+ ilextr = ic > 0;
+ if (ilextr) {
+ clartg_(&a[jch - iskew * ic + ioffst + ic *
+ a_dim1], &extra, &realc, &s, &dummy);
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ dummy.r = q__1.r, dummy.i = q__1.i;
+ q__1.r = realc * dummy.r, q__1.i = realc *
+ dummy.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__1.r = s.r * dummy.r - s.i * dummy.i,
+ q__1.i = s.r * dummy.i + s.i *
+ dummy.r;
+ s.r = q__1.r, s.i = q__1.i;
+ }
+ ic = max(1,ic);
+/* Computing MIN */
+ i__5 = *n - 1, i__6 = jch + jku;
+ icol = min(i__5,i__6);
+ iltemp = jch + jku < *n;
+ ctemp.r = 0.f, ctemp.i = 0.f;
+ i__5 = icol + 2 - ic;
+ clarot_(&c_true, &ilextr, &iltemp, &i__5, &c__, &
+ s, &a[jch - iskew * ic + ioffst + ic *
+ a_dim1], &ilda, &extra, &ctemp);
+ if (iltemp) {
+ clartg_(&a[jch - iskew * icol + ioffst + icol
+ * a_dim1], &ctemp, &realc, &s, &dummy)
+ ;
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ dummy.r = q__1.r, dummy.i = q__1.i;
+ q__1.r = realc * dummy.r, q__1.i = realc *
+ dummy.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__1.r = s.r * dummy.r - s.i * dummy.i,
+ q__1.i = s.r * dummy.i + s.i *
+ dummy.r;
+ s.r = q__1.r, s.i = q__1.i;
+/* Computing MIN */
+ i__5 = iendch, i__6 = jch + jkl + jku;
+ il = min(i__5,i__6) + 2 - jch;
+ extra.r = 0.f, extra.i = 0.f;
+ L__1 = jch + jkl + jku <= iendch;
+ clarot_(&c_false, &c_true, &L__1, &il, &c__, &
+ s, &a[jch - iskew * icol + ioffst +
+ icol * a_dim1], &ilda, &ctemp, &extra)
+ ;
+ ic = icol;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+
+ jku = uub;
+ i__1 = llb;
+ for (jkl = 1; jkl <= i__1; ++jkl) {
+
+/* Transform from bandwidth JKL-1, JKU to JKL, JKU */
+
+/* First row actually rotated is MIN( N+JKL, M ) */
+/* First column actually rotated is N */
+
+/* Computing MIN */
+ i__3 = *n, i__4 = *m + jku;
+ iendch = min(i__3,i__4) - 1;
+/* Computing MIN */
+ i__3 = *n + jkl;
+ i__4 = 1 - jku;
+ for (jr = min(i__3,*m) - 1; jr >= i__4; --jr) {
+ extra.r = 0.f, extra.i = 0.f;
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ r__1 = cos(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ r__1 = sin(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ s.r = q__1.r, s.i = q__1.i;
+/* Computing MAX */
+ i__3 = 1, i__2 = jr - jkl + 1;
+ icol = max(i__3,i__2);
+ if (jr > 0) {
+/* Computing MIN */
+ i__3 = *n, i__2 = jr + jku + 1;
+ il = min(i__3,i__2) + 1 - icol;
+ L__1 = jr + jku < *n;
+ clarot_(&c_true, &c_false, &L__1, &il, &c__, &s, &
+ a[jr - iskew * icol + ioffst + icol *
+ a_dim1], &ilda, &dummy, &extra);
+ }
+
+/* Chase "EXTRA" back down */
+
+ ir = jr;
+ i__3 = iendch;
+ i__2 = jkl + jku;
+ for (jch = jr + jku; i__2 < 0 ? jch >= i__3 : jch <=
+ i__3; jch += i__2) {
+ ilextr = ir > 0;
+ if (ilextr) {
+ clartg_(&a[ir - iskew * jch + ioffst + jch *
+ a_dim1], &extra, &realc, &s, &dummy);
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ dummy.r = q__1.r, dummy.i = q__1.i;
+ q__1.r = realc * dummy.r, q__1.i = realc *
+ dummy.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__1.r = s.r * dummy.r - s.i * dummy.i,
+ q__1.i = s.r * dummy.i + s.i *
+ dummy.r;
+ s.r = q__1.r, s.i = q__1.i;
+ }
+ ir = max(1,ir);
+/* Computing MIN */
+ i__5 = *m - 1, i__6 = jch + jkl;
+ irow = min(i__5,i__6);
+ iltemp = jch + jkl < *m;
+ ctemp.r = 0.f, ctemp.i = 0.f;
+ i__5 = irow + 2 - ir;
+ clarot_(&c_false, &ilextr, &iltemp, &i__5, &c__, &
+ s, &a[ir - iskew * jch + ioffst + jch *
+ a_dim1], &ilda, &extra, &ctemp);
+ if (iltemp) {
+ clartg_(&a[irow - iskew * jch + ioffst + jch *
+ a_dim1], &ctemp, &realc, &s, &dummy);
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ dummy.r = q__1.r, dummy.i = q__1.i;
+ q__1.r = realc * dummy.r, q__1.i = realc *
+ dummy.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__1.r = s.r * dummy.r - s.i * dummy.i,
+ q__1.i = s.r * dummy.i + s.i *
+ dummy.r;
+ s.r = q__1.r, s.i = q__1.i;
+/* Computing MIN */
+ i__5 = iendch, i__6 = jch + jkl + jku;
+ il = min(i__5,i__6) + 2 - jch;
+ extra.r = 0.f, extra.i = 0.f;
+ L__1 = jch + jkl + jku <= iendch;
+ clarot_(&c_true, &c_true, &L__1, &il, &c__, &
+ s, &a[irow - iskew * jch + ioffst +
+ jch * a_dim1], &ilda, &ctemp, &extra);
+ ir = irow;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+
+ }
+
+ } else {
+
+/* Symmetric -- A = U D U' */
+/* Hermitian -- A = U D U* */
+
+ ipackg = ipack;
+ ioffg = ioffst;
+
+ if (topdwn) {
+
+/* Top-Down -- Generate Upper triangle only */
+
+ if (ipack >= 5) {
+ ipackg = 6;
+ ioffg = uub + 1;
+ } else {
+ ipackg = 1;
+ }
+
+ i__1 = mnmin;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = (1 - iskew) * j + ioffg + j * a_dim1;
+ i__2 = j;
+ q__1.r = d__[i__2], q__1.i = 0.f;
+ a[i__4].r = q__1.r, a[i__4].i = q__1.i;
+/* L170: */
+ }
+
+ i__1 = uub;
+ for (k = 1; k <= i__1; ++k) {
+ i__4 = *n - 1;
+ for (jc = 1; jc <= i__4; ++jc) {
+/* Computing MAX */
+ i__2 = 1, i__3 = jc - k;
+ irow = max(i__2,i__3);
+/* Computing MIN */
+ i__2 = jc + 1, i__3 = k + 2;
+ il = min(i__2,i__3);
+ extra.r = 0.f, extra.i = 0.f;
+ i__2 = jc - iskew * (jc + 1) + ioffg + (jc + 1) *
+ a_dim1;
+ ctemp.r = a[i__2].r, ctemp.i = a[i__2].i;
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ r__1 = cos(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ r__1 = sin(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ s.r = q__1.r, s.i = q__1.i;
+ if (csym) {
+ ct.r = c__.r, ct.i = c__.i;
+ st.r = s.r, st.i = s.i;
+ } else {
+ r_cnjg(&q__1, &ctemp);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ r_cnjg(&q__1, &c__);
+ ct.r = q__1.r, ct.i = q__1.i;
+ r_cnjg(&q__1, &s);
+ st.r = q__1.r, st.i = q__1.i;
+ }
+ L__1 = jc > k;
+ clarot_(&c_false, &L__1, &c_true, &il, &c__, &s, &a[
+ irow - iskew * jc + ioffg + jc * a_dim1], &
+ ilda, &extra, &ctemp);
+/* Computing MIN */
+ i__3 = k, i__5 = *n - jc;
+ i__2 = min(i__3,i__5) + 1;
+ clarot_(&c_true, &c_true, &c_false, &i__2, &ct, &st, &
+ a[(1 - iskew) * jc + ioffg + jc * a_dim1], &
+ ilda, &ctemp, &dummy);
+
+/* Chase EXTRA back up the matrix */
+
+ icol = jc;
+ i__2 = -k;
+ for (jch = jc - k; i__2 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__2) {
+ clartg_(&a[jch + 1 - iskew * (icol + 1) + ioffg +
+ (icol + 1) * a_dim1], &extra, &realc, &s,
+ &dummy);
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ dummy.r = q__1.r, dummy.i = q__1.i;
+ q__2.r = realc * dummy.r, q__2.i = realc *
+ dummy.i;
+ r_cnjg(&q__1, &q__2);
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__3.r = -s.r, q__3.i = -s.i;
+ q__2.r = q__3.r * dummy.r - q__3.i * dummy.i,
+ q__2.i = q__3.r * dummy.i + q__3.i *
+ dummy.r;
+ r_cnjg(&q__1, &q__2);
+ s.r = q__1.r, s.i = q__1.i;
+ i__3 = jch - iskew * (jch + 1) + ioffg + (jch + 1)
+ * a_dim1;
+ ctemp.r = a[i__3].r, ctemp.i = a[i__3].i;
+ if (csym) {
+ ct.r = c__.r, ct.i = c__.i;
+ st.r = s.r, st.i = s.i;
+ } else {
+ r_cnjg(&q__1, &ctemp);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ r_cnjg(&q__1, &c__);
+ ct.r = q__1.r, ct.i = q__1.i;
+ r_cnjg(&q__1, &s);
+ st.r = q__1.r, st.i = q__1.i;
+ }
+ i__3 = k + 2;
+ clarot_(&c_true, &c_true, &c_true, &i__3, &c__, &
+ s, &a[(1 - iskew) * jch + ioffg + jch *
+ a_dim1], &ilda, &ctemp, &extra);
+/* Computing MAX */
+ i__3 = 1, i__5 = jch - k;
+ irow = max(i__3,i__5);
+/* Computing MIN */
+ i__3 = jch + 1, i__5 = k + 2;
+ il = min(i__3,i__5);
+ extra.r = 0.f, extra.i = 0.f;
+ L__1 = jch > k;
+ clarot_(&c_false, &L__1, &c_true, &il, &ct, &st, &
+ a[irow - iskew * jch + ioffg + jch *
+ a_dim1], &ilda, &extra, &ctemp);
+ icol = jch;
+/* L180: */
+ }
+/* L190: */
+ }
+/* L200: */
+ }
+
+/* If we need lower triangle, copy from upper. Note that */
+/* the order of copying is chosen to work for 'q' -> 'b' */
+
+ if (ipack != ipackg && ipack != 3) {
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ irow = ioffst - iskew * jc;
+ if (csym) {
+/* Computing MIN */
+ i__2 = *n, i__3 = jc + uub;
+ i__4 = min(i__2,i__3);
+ for (jr = jc; jr <= i__4; ++jr) {
+ i__2 = jr + irow + jc * a_dim1;
+ i__3 = jc - iskew * jr + ioffg + jr * a_dim1;
+ a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
+/* L210: */
+ }
+ } else {
+/* Computing MIN */
+ i__2 = *n, i__3 = jc + uub;
+ i__4 = min(i__2,i__3);
+ for (jr = jc; jr <= i__4; ++jr) {
+ i__2 = jr + irow + jc * a_dim1;
+ r_cnjg(&q__1, &a[jc - iskew * jr + ioffg + jr
+ * a_dim1]);
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L220: */
+ }
+ }
+/* L230: */
+ }
+ if (ipack == 5) {
+ i__1 = *n;
+ for (jc = *n - uub + 1; jc <= i__1; ++jc) {
+ i__4 = uub + 1;
+ for (jr = *n + 2 - jc; jr <= i__4; ++jr) {
+ i__2 = jr + jc * a_dim1;
+ a[i__2].r = 0.f, a[i__2].i = 0.f;
+/* L240: */
+ }
+/* L250: */
+ }
+ }
+ if (ipackg == 6) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+ }
+ } else {
+
+/* Bottom-Up -- Generate Lower triangle only */
+
+ if (ipack >= 5) {
+ ipackg = 5;
+ if (ipack == 6) {
+ ioffg = 1;
+ }
+ } else {
+ ipackg = 2;
+ }
+
+ i__1 = mnmin;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = (1 - iskew) * j + ioffg + j * a_dim1;
+ i__2 = j;
+ q__1.r = d__[i__2], q__1.i = 0.f;
+ a[i__4].r = q__1.r, a[i__4].i = q__1.i;
+/* L260: */
+ }
+
+ i__1 = uub;
+ for (k = 1; k <= i__1; ++k) {
+ for (jc = *n - 1; jc >= 1; --jc) {
+/* Computing MIN */
+ i__4 = *n + 1 - jc, i__2 = k + 2;
+ il = min(i__4,i__2);
+ extra.r = 0.f, extra.i = 0.f;
+ i__4 = (1 - iskew) * jc + 1 + ioffg + jc * a_dim1;
+ ctemp.r = a[i__4].r, ctemp.i = a[i__4].i;
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ r__1 = cos(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ r__1 = sin(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ s.r = q__1.r, s.i = q__1.i;
+ if (csym) {
+ ct.r = c__.r, ct.i = c__.i;
+ st.r = s.r, st.i = s.i;
+ } else {
+ r_cnjg(&q__1, &ctemp);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ r_cnjg(&q__1, &c__);
+ ct.r = q__1.r, ct.i = q__1.i;
+ r_cnjg(&q__1, &s);
+ st.r = q__1.r, st.i = q__1.i;
+ }
+ L__1 = *n - jc > k;
+ clarot_(&c_false, &c_true, &L__1, &il, &c__, &s, &a[(
+ 1 - iskew) * jc + ioffg + jc * a_dim1], &ilda,
+ &ctemp, &extra);
+/* Computing MAX */
+ i__4 = 1, i__2 = jc - k + 1;
+ icol = max(i__4,i__2);
+ i__4 = jc + 2 - icol;
+ clarot_(&c_true, &c_false, &c_true, &i__4, &ct, &st, &
+ a[jc - iskew * icol + ioffg + icol * a_dim1],
+ &ilda, &dummy, &ctemp);
+
+/* Chase EXTRA back down the matrix */
+
+ icol = jc;
+ i__4 = *n - 1;
+ i__2 = k;
+ for (jch = jc + k; i__2 < 0 ? jch >= i__4 : jch <=
+ i__4; jch += i__2) {
+ clartg_(&a[jch - iskew * icol + ioffg + icol *
+ a_dim1], &extra, &realc, &s, &dummy);
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ dummy.r = q__1.r, dummy.i = q__1.i;
+ q__1.r = realc * dummy.r, q__1.i = realc *
+ dummy.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__1.r = s.r * dummy.r - s.i * dummy.i, q__1.i =
+ s.r * dummy.i + s.i * dummy.r;
+ s.r = q__1.r, s.i = q__1.i;
+ i__3 = (1 - iskew) * jch + 1 + ioffg + jch *
+ a_dim1;
+ ctemp.r = a[i__3].r, ctemp.i = a[i__3].i;
+ if (csym) {
+ ct.r = c__.r, ct.i = c__.i;
+ st.r = s.r, st.i = s.i;
+ } else {
+ r_cnjg(&q__1, &ctemp);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ r_cnjg(&q__1, &c__);
+ ct.r = q__1.r, ct.i = q__1.i;
+ r_cnjg(&q__1, &s);
+ st.r = q__1.r, st.i = q__1.i;
+ }
+ i__3 = k + 2;
+ clarot_(&c_true, &c_true, &c_true, &i__3, &c__, &
+ s, &a[jch - iskew * icol + ioffg + icol *
+ a_dim1], &ilda, &extra, &ctemp);
+/* Computing MIN */
+ i__3 = *n + 1 - jch, i__5 = k + 2;
+ il = min(i__3,i__5);
+ extra.r = 0.f, extra.i = 0.f;
+ L__1 = *n - jch > k;
+ clarot_(&c_false, &c_true, &L__1, &il, &ct, &st, &
+ a[(1 - iskew) * jch + ioffg + jch *
+ a_dim1], &ilda, &ctemp, &extra);
+ icol = jch;
+/* L270: */
+ }
+/* L280: */
+ }
+/* L290: */
+ }
+
+/* If we need upper triangle, copy from lower. Note that */
+/* the order of copying is chosen to work for 'b' -> 'q' */
+
+ if (ipack != ipackg && ipack != 4) {
+ for (jc = *n; jc >= 1; --jc) {
+ irow = ioffst - iskew * jc;
+ if (csym) {
+/* Computing MAX */
+ i__2 = 1, i__4 = jc - uub;
+ i__1 = max(i__2,i__4);
+ for (jr = jc; jr >= i__1; --jr) {
+ i__2 = jr + irow + jc * a_dim1;
+ i__4 = jc - iskew * jr + ioffg + jr * a_dim1;
+ a[i__2].r = a[i__4].r, a[i__2].i = a[i__4].i;
+/* L300: */
+ }
+ } else {
+/* Computing MAX */
+ i__2 = 1, i__4 = jc - uub;
+ i__1 = max(i__2,i__4);
+ for (jr = jc; jr >= i__1; --jr) {
+ i__2 = jr + irow + jc * a_dim1;
+ r_cnjg(&q__1, &a[jc - iskew * jr + ioffg + jr
+ * a_dim1]);
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L310: */
+ }
+ }
+/* L320: */
+ }
+ if (ipack == 6) {
+ i__1 = uub;
+ for (jc = 1; jc <= i__1; ++jc) {
+ i__2 = uub + 1 - jc;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__4 = jr + jc * a_dim1;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L330: */
+ }
+/* L340: */
+ }
+ }
+ if (ipackg == 5) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+ }
+ }
+
+/* Ensure that the diagonal is real if Hermitian */
+
+ if (! csym) {
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ irow = ioffst + (1 - iskew) * jc;
+ i__2 = irow + jc * a_dim1;
+ i__4 = irow + jc * a_dim1;
+ r__1 = a[i__4].r;
+ q__1.r = r__1, q__1.i = 0.f;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L350: */
+ }
+ }
+
+ }
+
+ } else {
+
+/* 4) Generate Banded Matrix by first */
+/* Rotating by random Unitary matrices, */
+/* then reducing the bandwidth using Householder */
+/* transformations. */
+
+/* Note: we should get here only if LDA .ge. N */
+
+ if (isym == 1) {
+
+/* Non-symmetric -- A = U D V */
+
+ clagge_(&mr, &nc, &llb, &uub, &d__[1], &a[a_offset], lda, &iseed[
+ 1], &work[1], &iinfo);
+ } else {
+
+/* Symmetric -- A = U D U' or */
+/* Hermitian -- A = U D U* */
+
+ if (csym) {
+ clagsy_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[
+ 1], &iinfo);
+ } else {
+ claghe_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[
+ 1], &iinfo);
+ }
+ }
+
+ if (iinfo != 0) {
+ *info = 3;
+ return 0;
+ }
+ }
+
+/* 5) Pack the matrix */
+
+ if (ipack != ipackg) {
+ if (ipack == 1) {
+
+/* 'U' -- Upper triangular, not packed */
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L360: */
+ }
+/* L370: */
+ }
+
+ } else if (ipack == 2) {
+
+/* 'L' -- Lower triangular, not packed */
+
+ i__1 = *m;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L380: */
+ }
+/* L390: */
+ }
+
+ } else if (ipack == 3) {
+
+/* 'C' -- Upper triangle packed Columnwise. */
+
+ icol = 1;
+ irow = 0;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ++irow;
+ if (irow > *lda) {
+ irow = 1;
+ ++icol;
+ }
+ i__4 = irow + icol * a_dim1;
+ i__3 = i__ + j * a_dim1;
+ a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i;
+/* L400: */
+ }
+/* L410: */
+ }
+
+ } else if (ipack == 4) {
+
+/* 'R' -- Lower triangle packed Columnwise. */
+
+ icol = 1;
+ irow = 0;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ++irow;
+ if (irow > *lda) {
+ irow = 1;
+ ++icol;
+ }
+ i__4 = irow + icol * a_dim1;
+ i__3 = i__ + j * a_dim1;
+ a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i;
+/* L420: */
+ }
+/* L430: */
+ }
+
+ } else if (ipack >= 5) {
+
+/* 'B' -- The lower triangle is packed as a band matrix. */
+/* 'Q' -- The upper triangle is packed as a band matrix. */
+/* 'Z' -- The whole matrix is packed as a band matrix. */
+
+ if (ipack == 5) {
+ uub = 0;
+ }
+ if (ipack == 6) {
+ llb = 0;
+ }
+
+ i__1 = uub;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = j + llb;
+ for (i__ = min(i__2,*m); i__ >= 1; --i__) {
+ i__2 = i__ - j + uub + 1 + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ a[i__2].r = a[i__4].r, a[i__2].i = a[i__4].i;
+/* L440: */
+ }
+/* L450: */
+ }
+
+ i__1 = *n;
+ for (j = uub + 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = j + llb;
+ i__2 = min(i__4,*m);
+ for (i__ = j - uub; i__ <= i__2; ++i__) {
+ i__4 = i__ - j + uub + 1 + j * a_dim1;
+ i__3 = i__ + j * a_dim1;
+ a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i;
+/* L460: */
+ }
+/* L470: */
+ }
+ }
+
+/* If packed, zero out extraneous elements. */
+
+/* Symmetric/Triangular Packed -- */
+/* zero out everything after A(IROW,ICOL) */
+
+ if (ipack == 3 || ipack == 4) {
+ i__1 = *m;
+ for (jc = icol; jc <= i__1; ++jc) {
+ i__2 = *lda;
+ for (jr = irow + 1; jr <= i__2; ++jr) {
+ i__4 = jr + jc * a_dim1;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L480: */
+ }
+ irow = 0;
+/* L490: */
+ }
+
+ } else if (ipack >= 5) {
+
+/* Packed Band -- */
+/* 1st row is now in A( UUB+2-j, j), zero above it */
+/* m-th row is now in A( M+UUB-j,j), zero below it */
+/* last non-zero diagonal is now in A( UUB+LLB+1,j ), */
+/* zero below it, too. */
+
+ ir1 = uub + llb + 2;
+ ir2 = uub + *m + 2;
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ i__2 = uub + 1 - jc;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__4 = jr + jc * a_dim1;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L500: */
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__3 = ir1, i__5 = ir2 - jc;
+ i__2 = 1, i__4 = min(i__3,i__5);
+ i__6 = *lda;
+ for (jr = max(i__2,i__4); jr <= i__6; ++jr) {
+ i__2 = jr + jc * a_dim1;
+ a[i__2].r = 0.f, a[i__2].i = 0.f;
+/* L510: */
+ }
+/* L520: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CLATMS */
+
+} /* clatms_ */
diff --git a/TESTING/MATGEN/clatmt.c b/TESTING/MATGEN/clatmt.c
new file mode 100644
index 0000000..59ea80e
--- /dev/null
+++ b/TESTING/MATGEN/clatmt.c
@@ -0,0 +1,1633 @@
+/* clatmt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static complex c_b1 = {0.f,0.f};
+static integer c__1 = 1;
+static integer c__5 = 5;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int clatmt_(integer *m, integer *n, char *dist, integer *
+ iseed, char *sym, real *d__, integer *mode, real *cond, real *dmax__,
+ integer *rank, integer *kl, integer *ku, char *pack, complex *a,
+ integer *lda, complex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1, r__2, r__3;
+ complex q__1, q__2, q__3;
+ logical L__1;
+
+ /* Builtin functions */
+ double cos(doublereal), sin(doublereal);
+ void r_cnjg(complex *, complex *);
+
+ /* Local variables */
+ complex c__;
+ integer i__, j, k;
+ complex s;
+ integer ic, jc, nc, il;
+ complex ct;
+ integer ir, jr, mr;
+ complex st;
+ integer ir1, ir2, jch, llb, jkl, jku, uub, ilda, icol;
+ real temp;
+ logical csym;
+ integer irow, isym;
+ real alpha, angle, realc;
+ integer ipack, ioffg;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ complex ctemp;
+ integer idist, mnmin;
+ complex extra;
+ integer iskew;
+ complex dummy;
+ extern /* Subroutine */ int slatm7_(integer *, real *, integer *, integer
+ *, integer *, real *, integer *, integer *, integer *), clagge_(
+ integer *, integer *, integer *, integer *, real *, complex *,
+ integer *, integer *, complex *, integer *), claghe_(integer *,
+ integer *, real *, complex *, integer *, integer *, complex *,
+ integer *);
+ integer iendch, ipackg;
+ extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+ integer minlda;
+ extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
+ *, complex *, complex *, integer *), clartg_(complex *,
+ complex *, real *, complex *, complex *), xerbla_(char *, integer
+ *), clagsy_(integer *, integer *, real *, complex *,
+ integer *, integer *, complex *, integer *);
+ extern doublereal slarnd_(integer *, integer *);
+ extern /* Subroutine */ int clarot_(logical *, logical *, logical *,
+ integer *, complex *, complex *, complex *, integer *, complex *,
+ complex *);
+ integer ioffst, irsign;
+ logical givens, iltemp, ilextr, topdwn;
+ integer isympk;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* CLATMT generates random matrices with specified singular values */
+/* (or hermitian with specified eigenvalues) */
+/* for testing LAPACK programs. */
+
+/* CLATMT operates by applying the following sequence of */
+/* operations: */
+
+/* Set the diagonal to D, where D may be input or */
+/* computed according to MODE, COND, DMAX, and SYM */
+/* as described below. */
+
+/* Generate a matrix with the appropriate band structure, by one */
+/* of two methods: */
+
+/* Method A: */
+/* Generate a dense M x N matrix by multiplying D on the left */
+/* and the right by random unitary matrices, then: */
+
+/* Reduce the bandwidth according to KL and KU, using */
+/* Householder transformations. */
+
+/* Method B: */
+/* Convert the bandwidth-0 (i.e., diagonal) matrix to a */
+/* bandwidth-1 matrix using Givens rotations, "chasing" */
+/* out-of-band elements back, much as in QR; then convert */
+/* the bandwidth-1 to a bandwidth-2 matrix, etc. Note */
+/* that for reasonably small bandwidths (relative to M and */
+/* N) this requires less storage, as a dense matrix is not */
+/* generated. Also, for hermitian or symmetric matrices, */
+/* only one triangle is generated. */
+
+/* Method A is chosen if the bandwidth is a large fraction of the */
+/* order of the matrix, and LDA is at least M (so a dense */
+/* matrix can be stored.) Method B is chosen if the bandwidth */
+/* is small (< 1/2 N for hermitian or symmetric, < .3 N+M for */
+/* non-symmetric), or LDA is less than M and not less than the */
+/* bandwidth. */
+
+/* Pack the matrix if desired. Options specified by PACK are: */
+/* no packing */
+/* zero out upper half (if hermitian) */
+/* zero out lower half (if hermitian) */
+/* store the upper half columnwise (if hermitian or upper */
+/* triangular) */
+/* store the lower half columnwise (if hermitian or lower */
+/* triangular) */
+/* store the lower triangle in banded format (if hermitian or */
+/* lower triangular) */
+/* store the upper triangle in banded format (if hermitian or */
+/* upper triangular) */
+/* store the entire matrix in banded format */
+/* If Method B is chosen, and band format is specified, then the */
+/* matrix will be generated in the band format, so no repacking */
+/* will be necessary. */
+
+/* Arguments */
+/* ========= */
+
+/* M - INTEGER */
+/* The number of rows of A. Not modified. */
+
+/* N - INTEGER */
+/* The number of columns of A. N must equal M if the matrix */
+/* is symmetric or hermitian (i.e., if SYM is not 'N') */
+/* Not modified. */
+
+/* DIST - CHARACTER*1 */
+/* On entry, DIST specifies the type of distribution to be used */
+/* to generate the random eigen-/singular values. */
+/* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */
+/* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */
+/* 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension ( 4 ) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. They should lie between 0 and 4095 inclusive, */
+/* and ISEED(4) should be odd. The random number generator */
+/* uses a linear congruential sequence limited to small */
+/* integers, and so should produce machine independent */
+/* random numbers. The values of ISEED are changed on */
+/* exit, and can be used in the next call to CLATMT */
+/* to continue the same random number sequence. */
+/* Changed on exit. */
+
+/* SYM - CHARACTER*1 */
+/* If SYM='H', the generated matrix is hermitian, with */
+/* eigenvalues specified by D, COND, MODE, and DMAX; they */
+/* may be positive, negative, or zero. */
+/* If SYM='P', the generated matrix is hermitian, with */
+/* eigenvalues (= singular values) specified by D, COND, */
+/* MODE, and DMAX; they will not be negative. */
+/* If SYM='N', the generated matrix is nonsymmetric, with */
+/* singular values specified by D, COND, MODE, and DMAX; */
+/* they will not be negative. */
+/* If SYM='S', the generated matrix is (complex) symmetric, */
+/* with singular values specified by D, COND, MODE, and */
+/* DMAX; they will not be negative. */
+/* Not modified. */
+
+/* D - REAL array, dimension ( MIN( M, N ) ) */
+/* This array is used to specify the singular values or */
+/* eigenvalues of A (see SYM, above.) If MODE=0, then D is */
+/* assumed to contain the singular/eigenvalues, otherwise */
+/* they will be computed according to MODE, COND, and DMAX, */
+/* and placed in D. */
+/* Modified if MODE is nonzero. */
+
+/* MODE - INTEGER */
+/* On entry this describes how the singular/eigenvalues are to */
+/* be specified: */
+/* MODE = 0 means use D as input */
+/* MODE = 1 sets D(1)=1 and D(2:RANK)=1.0/COND */
+/* MODE = 2 sets D(1:RANK-1)=1 and D(RANK)=1.0/COND */
+/* MODE = 3 sets D(I)=COND**(-(I-1)/(RANK-1)) */
+/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* MODE = 5 sets D to random numbers in the range */
+/* ( 1/COND , 1 ) such that their logarithms */
+/* are uniformly distributed. */
+/* MODE = 6 set D to random numbers from same distribution */
+/* as the rest of the matrix. */
+/* MODE < 0 has the same meaning as ABS(MODE), except that */
+/* the order of the elements of D is reversed. */
+/* Thus if MODE is positive, D has entries ranging from */
+/* 1 to 1/COND, if negative, from 1/COND to 1, */
+/* If SYM='H', and MODE is neither 0, 6, nor -6, then */
+/* the elements of D will also be multiplied by a random */
+/* sign (i.e., +1 or -1.) */
+/* Not modified. */
+
+/* COND - REAL */
+/* On entry, this is used as described under MODE above. */
+/* If used, it must be >= 1. Not modified. */
+
+/* DMAX - REAL */
+/* If MODE is neither -6, 0 nor 6, the contents of D, as */
+/* computed according to MODE and COND, will be scaled by */
+/* DMAX / max(abs(D(i))); thus, the maximum absolute eigen- or */
+/* singular value (which is to say the norm) will be abs(DMAX). */
+/* Note that DMAX need not be positive: if DMAX is negative */
+/* (or zero), D will be scaled by a negative number (or zero). */
+/* Not modified. */
+
+/* RANK - INTEGER */
+/* The rank of matrix to be generated for modes 1,2,3 only. */
+/* D( RANK+1:N ) = 0. */
+/* Not modified. */
+
+/* KL - INTEGER */
+/* This specifies the lower bandwidth of the matrix. For */
+/* example, KL=0 implies upper triangular, KL=1 implies upper */
+/* Hessenberg, and KL being at least M-1 means that the matrix */
+/* has full lower bandwidth. KL must equal KU if the matrix */
+/* is symmetric or hermitian. */
+/* Not modified. */
+
+/* KU - INTEGER */
+/* This specifies the upper bandwidth of the matrix. For */
+/* example, KU=0 implies lower triangular, KU=1 implies lower */
+/* Hessenberg, and KU being at least N-1 means that the matrix */
+/* has full upper bandwidth. KL must equal KU if the matrix */
+/* is symmetric or hermitian. */
+/* Not modified. */
+
+/* PACK - CHARACTER*1 */
+/* This specifies packing of matrix as follows: */
+/* 'N' => no packing */
+/* 'U' => zero out all subdiagonal entries (if symmetric */
+/* or hermitian) */
+/* 'L' => zero out all superdiagonal entries (if symmetric */
+/* or hermitian) */
+/* 'C' => store the upper triangle columnwise (only if the */
+/* matrix is symmetric, hermitian, or upper triangular) */
+/* 'R' => store the lower triangle columnwise (only if the */
+/* matrix is symmetric, hermitian, or lower triangular) */
+/* 'B' => store the lower triangle in band storage scheme */
+/* (only if the matrix is symmetric, hermitian, or */
+/* lower triangular) */
+/* 'Q' => store the upper triangle in band storage scheme */
+/* (only if the matrix is symmetric, hermitian, or */
+/* upper triangular) */
+/* 'Z' => store the entire matrix in band storage scheme */
+/* (pivoting can be provided for by using this */
+/* option to store A in the trailing rows of */
+/* the allocated storage) */
+
+/* Using these options, the various LAPACK packed and banded */
+/* storage schemes can be obtained: */
+/* GB - use 'Z' */
+/* PB, SB, HB, or TB - use 'B' or 'Q' */
+/* PP, SP, HB, or TP - use 'C' or 'R' */
+
+/* If two calls to CLATMT differ only in the PACK parameter, */
+/* they will generate mathematically equivalent matrices. */
+/* Not modified. */
+
+/* A - COMPLEX array, dimension ( LDA, N ) */
+/* On exit A is the desired test matrix. A is first generated */
+/* in full (unpacked) form, and then packed, if so specified */
+/* by PACK. Thus, the first M elements of the first N */
+/* columns will always be modified. If PACK specifies a */
+/* packed or banded storage scheme, all LDA elements of the */
+/* first N columns will be modified; the elements of the */
+/* array which do not correspond to elements of the generated */
+/* matrix are set to zero. */
+/* Modified. */
+
+/* LDA - INTEGER */
+/* LDA specifies the first dimension of A as declared in the */
+/* calling program. If PACK='N', 'U', 'L', 'C', or 'R', then */
+/* LDA must be at least M. If PACK='B' or 'Q', then LDA must */
+/* be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)). */
+/* If PACK='Z', LDA must be large enough to hold the packed */
+/* array: MIN( KU, N-1) + MIN( KL, M-1) + 1. */
+/* Not modified. */
+
+/* WORK - COMPLEX array, dimension ( 3*MAX( N, M ) ) */
+/* Workspace. */
+/* Modified. */
+
+/* INFO - INTEGER */
+/* Error code. On exit, INFO will be set to one of the */
+/* following values: */
+/* 0 => normal return */
+/* -1 => M negative or unequal to N and SYM='S', 'H', or 'P' */
+/* -2 => N negative */
+/* -3 => DIST illegal string */
+/* -5 => SYM illegal string */
+/* -7 => MODE not in range -6 to 6 */
+/* -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */
+/* -10 => KL negative */
+/* -11 => KU negative, or SYM is not 'N' and KU is not equal to */
+/* KL */
+/* -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N'; */
+/* or PACK='C' or 'Q' and SYM='N' and KL is not zero; */
+/* or PACK='R' or 'B' and SYM='N' and KU is not zero; */
+/* or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not */
+/* N. */
+/* -14 => LDA is less than M, or PACK='Z' and LDA is less than */
+/* MIN(KU,N-1) + MIN(KL,M-1) + 1. */
+/* 1 => Error return from SLATM7 */
+/* 2 => Cannot scale to DMAX (max. sing. value is 0) */
+/* 3 => Error return from CLAGGE, CLAGHE or CLAGSY */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Decode and Test the input parameters. */
+/* Initialize flags & seed. */
+
+ /* Parameter adjustments */
+ --iseed;
+ --d__;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Decode DIST */
+
+ if (lsame_(dist, "U")) {
+ idist = 1;
+ } else if (lsame_(dist, "S")) {
+ idist = 2;
+ } else if (lsame_(dist, "N")) {
+ idist = 3;
+ } else {
+ idist = -1;
+ }
+
+/* Decode SYM */
+
+ if (lsame_(sym, "N")) {
+ isym = 1;
+ irsign = 0;
+ csym = FALSE_;
+ } else if (lsame_(sym, "P")) {
+ isym = 2;
+ irsign = 0;
+ csym = FALSE_;
+ } else if (lsame_(sym, "S")) {
+ isym = 2;
+ irsign = 0;
+ csym = TRUE_;
+ } else if (lsame_(sym, "H")) {
+ isym = 2;
+ irsign = 1;
+ csym = FALSE_;
+ } else {
+ isym = -1;
+ }
+
+/* Decode PACK */
+
+ isympk = 0;
+ if (lsame_(pack, "N")) {
+ ipack = 0;
+ } else if (lsame_(pack, "U")) {
+ ipack = 1;
+ isympk = 1;
+ } else if (lsame_(pack, "L")) {
+ ipack = 2;
+ isympk = 1;
+ } else if (lsame_(pack, "C")) {
+ ipack = 3;
+ isympk = 2;
+ } else if (lsame_(pack, "R")) {
+ ipack = 4;
+ isympk = 3;
+ } else if (lsame_(pack, "B")) {
+ ipack = 5;
+ isympk = 3;
+ } else if (lsame_(pack, "Q")) {
+ ipack = 6;
+ isympk = 2;
+ } else if (lsame_(pack, "Z")) {
+ ipack = 7;
+ } else {
+ ipack = -1;
+ }
+
+/* Set certain internal parameters */
+
+ mnmin = min(*m,*n);
+/* Computing MIN */
+ i__1 = *kl, i__2 = *m - 1;
+ llb = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *ku, i__2 = *n - 1;
+ uub = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *m, i__2 = *n + llb;
+ mr = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *n, i__2 = *m + uub;
+ nc = min(i__1,i__2);
+
+ if (ipack == 5 || ipack == 6) {
+ minlda = uub + 1;
+ } else if (ipack == 7) {
+ minlda = llb + uub + 1;
+ } else {
+ minlda = *m;
+ }
+
+/* Use Givens rotation method if bandwidth small enough, */
+/* or if LDA is too small to store the matrix unpacked. */
+
+ givens = FALSE_;
+ if (isym == 1) {
+/* Computing MAX */
+ i__1 = 1, i__2 = mr + nc;
+ if ((real) (llb + uub) < (real) max(i__1,i__2) * .3f) {
+ givens = TRUE_;
+ }
+ } else {
+ if (llb << 1 < *m) {
+ givens = TRUE_;
+ }
+ }
+ if (*lda < *m && *lda >= minlda) {
+ givens = TRUE_;
+ }
+
+/* Set INFO if an error */
+
+ if (*m < 0) {
+ *info = -1;
+ } else if (*m != *n && isym != 1) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (idist == -1) {
+ *info = -3;
+ } else if (isym == -1) {
+ *info = -5;
+ } else if (abs(*mode) > 6) {
+ *info = -7;
+ } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.f) {
+ *info = -8;
+ } else if (*kl < 0) {
+ *info = -10;
+ } else if (*ku < 0 || isym != 1 && *kl != *ku) {
+ *info = -11;
+ } else if (ipack == -1 || isympk == 1 && isym == 1 || isympk == 2 && isym
+ == 1 && *kl > 0 || isympk == 3 && isym == 1 && *ku > 0 || isympk
+ != 0 && *m != *n) {
+ *info = -12;
+ } else if (*lda < max(1,minlda)) {
+ *info = -14;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("CLATMT", &i__1);
+ return 0;
+ }
+
+/* Initialize random number generator */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
+/* L100: */
+ }
+
+ if (iseed[4] % 2 != 1) {
+ ++iseed[4];
+ }
+
+/* 2) Set up D if indicated. */
+
+/* Compute D according to COND and MODE */
+
+ slatm7_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, rank, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = 1;
+ return 0;
+ }
+
+/* Choose Top-Down if D is (apparently) increasing, */
+/* Bottom-Up if D is (apparently) decreasing. */
+
+ if (dabs(d__[1]) <= (r__1 = d__[*rank], dabs(r__1))) {
+ topdwn = TRUE_;
+ } else {
+ topdwn = FALSE_;
+ }
+
+ if (*mode != 0 && abs(*mode) != 6) {
+
+/* Scale by DMAX */
+
+ temp = dabs(d__[1]);
+ i__1 = *rank;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = temp, r__3 = (r__1 = d__[i__], dabs(r__1));
+ temp = dmax(r__2,r__3);
+/* L110: */
+ }
+
+ if (temp > 0.f) {
+ alpha = *dmax__ / temp;
+ } else {
+ *info = 2;
+ return 0;
+ }
+
+ sscal_(rank, &alpha, &d__[1], &c__1);
+
+ }
+
+ claset_("Full", lda, n, &c_b1, &c_b1, &a[a_offset], lda);
+
+/* 3) Generate Banded Matrix using Givens rotations. */
+/* Also the special case of UUB=LLB=0 */
+
+/* Compute Addressing constants to cover all */
+/* storage formats. Whether GE, HE, SY, GB, HB, or SB, */
+/* upper or lower triangle or both, */
+/* the (i,j)-th element is in */
+/* A( i - ISKEW*j + IOFFST, j ) */
+
+ if (ipack > 4) {
+ ilda = *lda - 1;
+ iskew = 1;
+ if (ipack > 5) {
+ ioffst = uub + 1;
+ } else {
+ ioffst = 1;
+ }
+ } else {
+ ilda = *lda;
+ iskew = 0;
+ ioffst = 0;
+ }
+
+/* IPACKG is the format that the matrix is generated in. If this is */
+/* different from IPACK, then the matrix must be repacked at the */
+/* end. It also signals how to compute the norm, for scaling. */
+
+ ipackg = 0;
+
+/* Diagonal Matrix -- We are done, unless it */
+/* is to be stored HP/SP/PP/TP (PACK='R' or 'C') */
+
+ if (llb == 0 && uub == 0) {
+ i__1 = mnmin;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (1 - iskew) * j + ioffst + j * a_dim1;
+ i__3 = j;
+ q__1.r = d__[i__3], q__1.i = 0.f;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L120: */
+ }
+
+ if (ipack <= 2 || ipack >= 5) {
+ ipackg = ipack;
+ }
+
+ } else if (givens) {
+
+/* Check whether to use Givens rotations, */
+/* Householder transformations, or nothing. */
+
+ if (isym == 1) {
+
+/* Non-symmetric -- A = U D V */
+
+ if (ipack > 4) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+
+ i__1 = mnmin;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (1 - iskew) * j + ioffst + j * a_dim1;
+ i__3 = j;
+ q__1.r = d__[i__3], q__1.i = 0.f;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L130: */
+ }
+
+ if (topdwn) {
+ jkl = 0;
+ i__1 = uub;
+ for (jku = 1; jku <= i__1; ++jku) {
+
+/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */
+
+/* Last row actually rotated is M */
+/* Last column actually rotated is MIN( M+JKU, N ) */
+
+/* Computing MIN */
+ i__3 = *m + jku;
+ i__2 = min(i__3,*n) + jkl - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ extra.r = 0.f, extra.i = 0.f;
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ r__1 = cos(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ r__1 = sin(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ s.r = q__1.r, s.i = q__1.i;
+/* Computing MAX */
+ i__3 = 1, i__4 = jr - jkl;
+ icol = max(i__3,i__4);
+ if (jr < *m) {
+/* Computing MIN */
+ i__3 = *n, i__4 = jr + jku;
+ il = min(i__3,i__4) + 1 - icol;
+ L__1 = jr > jkl;
+ clarot_(&c_true, &L__1, &c_false, &il, &c__, &s, &
+ a[jr - iskew * icol + ioffst + icol *
+ a_dim1], &ilda, &extra, &dummy);
+ }
+
+/* Chase "EXTRA" back up */
+
+ ir = jr;
+ ic = icol;
+ i__3 = -jkl - jku;
+ for (jch = jr - jkl; i__3 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__3) {
+ if (ir < *m) {
+ clartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst
+ + (ic + 1) * a_dim1], &extra, &realc,
+ &s, &dummy);
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ dummy.r = q__1.r, dummy.i = q__1.i;
+ q__2.r = realc * dummy.r, q__2.i = realc *
+ dummy.i;
+ r_cnjg(&q__1, &q__2);
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__3.r = -s.r, q__3.i = -s.i;
+ q__2.r = q__3.r * dummy.r - q__3.i * dummy.i,
+ q__2.i = q__3.r * dummy.i + q__3.i *
+ dummy.r;
+ r_cnjg(&q__1, &q__2);
+ s.r = q__1.r, s.i = q__1.i;
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jku;
+ irow = max(i__4,i__5);
+ il = ir + 2 - irow;
+ ctemp.r = 0.f, ctemp.i = 0.f;
+ iltemp = jch > jku;
+ clarot_(&c_false, &iltemp, &c_true, &il, &c__, &s,
+ &a[irow - iskew * ic + ioffst + ic *
+ a_dim1], &ilda, &ctemp, &extra);
+ if (iltemp) {
+ clartg_(&a[irow + 1 - iskew * (ic + 1) +
+ ioffst + (ic + 1) * a_dim1], &ctemp, &
+ realc, &s, &dummy);
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ dummy.r = q__1.r, dummy.i = q__1.i;
+ q__2.r = realc * dummy.r, q__2.i = realc *
+ dummy.i;
+ r_cnjg(&q__1, &q__2);
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__3.r = -s.r, q__3.i = -s.i;
+ q__2.r = q__3.r * dummy.r - q__3.i * dummy.i,
+ q__2.i = q__3.r * dummy.i + q__3.i *
+ dummy.r;
+ r_cnjg(&q__1, &q__2);
+ s.r = q__1.r, s.i = q__1.i;
+
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jku - jkl;
+ icol = max(i__4,i__5);
+ il = ic + 2 - icol;
+ extra.r = 0.f, extra.i = 0.f;
+ L__1 = jch > jku + jkl;
+ clarot_(&c_true, &L__1, &c_true, &il, &c__, &
+ s, &a[irow - iskew * icol + ioffst +
+ icol * a_dim1], &ilda, &extra, &ctemp)
+ ;
+ ic = icol;
+ ir = irow;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+
+ jku = uub;
+ i__1 = llb;
+ for (jkl = 1; jkl <= i__1; ++jkl) {
+
+/* Transform from bandwidth JKL-1, JKU to JKL, JKU */
+
+/* Computing MIN */
+ i__3 = *n + jkl;
+ i__2 = min(i__3,*m) + jku - 1;
+ for (jc = 1; jc <= i__2; ++jc) {
+ extra.r = 0.f, extra.i = 0.f;
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ r__1 = cos(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ r__1 = sin(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ s.r = q__1.r, s.i = q__1.i;
+/* Computing MAX */
+ i__3 = 1, i__4 = jc - jku;
+ irow = max(i__3,i__4);
+ if (jc < *n) {
+/* Computing MIN */
+ i__3 = *m, i__4 = jc + jkl;
+ il = min(i__3,i__4) + 1 - irow;
+ L__1 = jc > jku;
+ clarot_(&c_false, &L__1, &c_false, &il, &c__, &s,
+ &a[irow - iskew * jc + ioffst + jc *
+ a_dim1], &ilda, &extra, &dummy);
+ }
+
+/* Chase "EXTRA" back up */
+
+ ic = jc;
+ ir = irow;
+ i__3 = -jkl - jku;
+ for (jch = jc - jku; i__3 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__3) {
+ if (ic < *n) {
+ clartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst
+ + (ic + 1) * a_dim1], &extra, &realc,
+ &s, &dummy);
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ dummy.r = q__1.r, dummy.i = q__1.i;
+ q__2.r = realc * dummy.r, q__2.i = realc *
+ dummy.i;
+ r_cnjg(&q__1, &q__2);
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__3.r = -s.r, q__3.i = -s.i;
+ q__2.r = q__3.r * dummy.r - q__3.i * dummy.i,
+ q__2.i = q__3.r * dummy.i + q__3.i *
+ dummy.r;
+ r_cnjg(&q__1, &q__2);
+ s.r = q__1.r, s.i = q__1.i;
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jkl;
+ icol = max(i__4,i__5);
+ il = ic + 2 - icol;
+ ctemp.r = 0.f, ctemp.i = 0.f;
+ iltemp = jch > jkl;
+ clarot_(&c_true, &iltemp, &c_true, &il, &c__, &s,
+ &a[ir - iskew * icol + ioffst + icol *
+ a_dim1], &ilda, &ctemp, &extra);
+ if (iltemp) {
+ clartg_(&a[ir + 1 - iskew * (icol + 1) +
+ ioffst + (icol + 1) * a_dim1], &ctemp,
+ &realc, &s, &dummy);
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ dummy.r = q__1.r, dummy.i = q__1.i;
+ q__2.r = realc * dummy.r, q__2.i = realc *
+ dummy.i;
+ r_cnjg(&q__1, &q__2);
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__3.r = -s.r, q__3.i = -s.i;
+ q__2.r = q__3.r * dummy.r - q__3.i * dummy.i,
+ q__2.i = q__3.r * dummy.i + q__3.i *
+ dummy.r;
+ r_cnjg(&q__1, &q__2);
+ s.r = q__1.r, s.i = q__1.i;
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jkl - jku;
+ irow = max(i__4,i__5);
+ il = ir + 2 - irow;
+ extra.r = 0.f, extra.i = 0.f;
+ L__1 = jch > jkl + jku;
+ clarot_(&c_false, &L__1, &c_true, &il, &c__, &
+ s, &a[irow - iskew * icol + ioffst +
+ icol * a_dim1], &ilda, &extra, &ctemp)
+ ;
+ ic = icol;
+ ir = irow;
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+/* L190: */
+ }
+
+ } else {
+
+/* Bottom-Up -- Start at the bottom right. */
+
+ jkl = 0;
+ i__1 = uub;
+ for (jku = 1; jku <= i__1; ++jku) {
+
+/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */
+
+/* First row actually rotated is M */
+/* First column actually rotated is MIN( M+JKU, N ) */
+
+/* Computing MIN */
+ i__2 = *m, i__3 = *n + jkl;
+ iendch = min(i__2,i__3) - 1;
+/* Computing MIN */
+ i__2 = *m + jku;
+ i__3 = 1 - jkl;
+ for (jc = min(i__2,*n) - 1; jc >= i__3; --jc) {
+ extra.r = 0.f, extra.i = 0.f;
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ r__1 = cos(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ r__1 = sin(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ s.r = q__1.r, s.i = q__1.i;
+/* Computing MAX */
+ i__2 = 1, i__4 = jc - jku + 1;
+ irow = max(i__2,i__4);
+ if (jc > 0) {
+/* Computing MIN */
+ i__2 = *m, i__4 = jc + jkl + 1;
+ il = min(i__2,i__4) + 1 - irow;
+ L__1 = jc + jkl < *m;
+ clarot_(&c_false, &c_false, &L__1, &il, &c__, &s,
+ &a[irow - iskew * jc + ioffst + jc *
+ a_dim1], &ilda, &dummy, &extra);
+ }
+
+/* Chase "EXTRA" back down */
+
+ ic = jc;
+ i__2 = iendch;
+ i__4 = jkl + jku;
+ for (jch = jc + jkl; i__4 < 0 ? jch >= i__2 : jch <=
+ i__2; jch += i__4) {
+ ilextr = ic > 0;
+ if (ilextr) {
+ clartg_(&a[jch - iskew * ic + ioffst + ic *
+ a_dim1], &extra, &realc, &s, &dummy);
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ dummy.r = q__1.r, dummy.i = q__1.i;
+ q__1.r = realc * dummy.r, q__1.i = realc *
+ dummy.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__1.r = s.r * dummy.r - s.i * dummy.i,
+ q__1.i = s.r * dummy.i + s.i *
+ dummy.r;
+ s.r = q__1.r, s.i = q__1.i;
+ }
+ ic = max(1,ic);
+/* Computing MIN */
+ i__5 = *n - 1, i__6 = jch + jku;
+ icol = min(i__5,i__6);
+ iltemp = jch + jku < *n;
+ ctemp.r = 0.f, ctemp.i = 0.f;
+ i__5 = icol + 2 - ic;
+ clarot_(&c_true, &ilextr, &iltemp, &i__5, &c__, &
+ s, &a[jch - iskew * ic + ioffst + ic *
+ a_dim1], &ilda, &extra, &ctemp);
+ if (iltemp) {
+ clartg_(&a[jch - iskew * icol + ioffst + icol
+ * a_dim1], &ctemp, &realc, &s, &dummy)
+ ;
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ dummy.r = q__1.r, dummy.i = q__1.i;
+ q__1.r = realc * dummy.r, q__1.i = realc *
+ dummy.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__1.r = s.r * dummy.r - s.i * dummy.i,
+ q__1.i = s.r * dummy.i + s.i *
+ dummy.r;
+ s.r = q__1.r, s.i = q__1.i;
+/* Computing MIN */
+ i__5 = iendch, i__6 = jch + jkl + jku;
+ il = min(i__5,i__6) + 2 - jch;
+ extra.r = 0.f, extra.i = 0.f;
+ L__1 = jch + jkl + jku <= iendch;
+ clarot_(&c_false, &c_true, &L__1, &il, &c__, &
+ s, &a[jch - iskew * icol + ioffst +
+ icol * a_dim1], &ilda, &ctemp, &extra)
+ ;
+ ic = icol;
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+/* L220: */
+ }
+
+ jku = uub;
+ i__1 = llb;
+ for (jkl = 1; jkl <= i__1; ++jkl) {
+
+/* Transform from bandwidth JKL-1, JKU to JKL, JKU */
+
+/* First row actually rotated is MIN( N+JKL, M ) */
+/* First column actually rotated is N */
+
+/* Computing MIN */
+ i__3 = *n, i__4 = *m + jku;
+ iendch = min(i__3,i__4) - 1;
+/* Computing MIN */
+ i__3 = *n + jkl;
+ i__4 = 1 - jku;
+ for (jr = min(i__3,*m) - 1; jr >= i__4; --jr) {
+ extra.r = 0.f, extra.i = 0.f;
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ r__1 = cos(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ r__1 = sin(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ s.r = q__1.r, s.i = q__1.i;
+/* Computing MAX */
+ i__3 = 1, i__2 = jr - jkl + 1;
+ icol = max(i__3,i__2);
+ if (jr > 0) {
+/* Computing MIN */
+ i__3 = *n, i__2 = jr + jku + 1;
+ il = min(i__3,i__2) + 1 - icol;
+ L__1 = jr + jku < *n;
+ clarot_(&c_true, &c_false, &L__1, &il, &c__, &s, &
+ a[jr - iskew * icol + ioffst + icol *
+ a_dim1], &ilda, &dummy, &extra);
+ }
+
+/* Chase "EXTRA" back down */
+
+ ir = jr;
+ i__3 = iendch;
+ i__2 = jkl + jku;
+ for (jch = jr + jku; i__2 < 0 ? jch >= i__3 : jch <=
+ i__3; jch += i__2) {
+ ilextr = ir > 0;
+ if (ilextr) {
+ clartg_(&a[ir - iskew * jch + ioffst + jch *
+ a_dim1], &extra, &realc, &s, &dummy);
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ dummy.r = q__1.r, dummy.i = q__1.i;
+ q__1.r = realc * dummy.r, q__1.i = realc *
+ dummy.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__1.r = s.r * dummy.r - s.i * dummy.i,
+ q__1.i = s.r * dummy.i + s.i *
+ dummy.r;
+ s.r = q__1.r, s.i = q__1.i;
+ }
+ ir = max(1,ir);
+/* Computing MIN */
+ i__5 = *m - 1, i__6 = jch + jkl;
+ irow = min(i__5,i__6);
+ iltemp = jch + jkl < *m;
+ ctemp.r = 0.f, ctemp.i = 0.f;
+ i__5 = irow + 2 - ir;
+ clarot_(&c_false, &ilextr, &iltemp, &i__5, &c__, &
+ s, &a[ir - iskew * jch + ioffst + jch *
+ a_dim1], &ilda, &extra, &ctemp);
+ if (iltemp) {
+ clartg_(&a[irow - iskew * jch + ioffst + jch *
+ a_dim1], &ctemp, &realc, &s, &dummy);
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ dummy.r = q__1.r, dummy.i = q__1.i;
+ q__1.r = realc * dummy.r, q__1.i = realc *
+ dummy.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__1.r = s.r * dummy.r - s.i * dummy.i,
+ q__1.i = s.r * dummy.i + s.i *
+ dummy.r;
+ s.r = q__1.r, s.i = q__1.i;
+/* Computing MIN */
+ i__5 = iendch, i__6 = jch + jkl + jku;
+ il = min(i__5,i__6) + 2 - jch;
+ extra.r = 0.f, extra.i = 0.f;
+ L__1 = jch + jkl + jku <= iendch;
+ clarot_(&c_true, &c_true, &L__1, &il, &c__, &
+ s, &a[irow - iskew * jch + ioffst +
+ jch * a_dim1], &ilda, &ctemp, &extra);
+ ir = irow;
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+/* L250: */
+ }
+
+ }
+
+ } else {
+
+/* Symmetric -- A = U D U' */
+/* Hermitian -- A = U D U* */
+
+ ipackg = ipack;
+ ioffg = ioffst;
+
+ if (topdwn) {
+
+/* Top-Down -- Generate Upper triangle only */
+
+ if (ipack >= 5) {
+ ipackg = 6;
+ ioffg = uub + 1;
+ } else {
+ ipackg = 1;
+ }
+
+ i__1 = mnmin;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = (1 - iskew) * j + ioffg + j * a_dim1;
+ i__2 = j;
+ q__1.r = d__[i__2], q__1.i = 0.f;
+ a[i__4].r = q__1.r, a[i__4].i = q__1.i;
+/* L260: */
+ }
+
+ i__1 = uub;
+ for (k = 1; k <= i__1; ++k) {
+ i__4 = *n - 1;
+ for (jc = 1; jc <= i__4; ++jc) {
+/* Computing MAX */
+ i__2 = 1, i__3 = jc - k;
+ irow = max(i__2,i__3);
+/* Computing MIN */
+ i__2 = jc + 1, i__3 = k + 2;
+ il = min(i__2,i__3);
+ extra.r = 0.f, extra.i = 0.f;
+ i__2 = jc - iskew * (jc + 1) + ioffg + (jc + 1) *
+ a_dim1;
+ ctemp.r = a[i__2].r, ctemp.i = a[i__2].i;
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ r__1 = cos(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ r__1 = sin(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ s.r = q__1.r, s.i = q__1.i;
+ if (csym) {
+ ct.r = c__.r, ct.i = c__.i;
+ st.r = s.r, st.i = s.i;
+ } else {
+ r_cnjg(&q__1, &ctemp);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ r_cnjg(&q__1, &c__);
+ ct.r = q__1.r, ct.i = q__1.i;
+ r_cnjg(&q__1, &s);
+ st.r = q__1.r, st.i = q__1.i;
+ }
+ L__1 = jc > k;
+ clarot_(&c_false, &L__1, &c_true, &il, &c__, &s, &a[
+ irow - iskew * jc + ioffg + jc * a_dim1], &
+ ilda, &extra, &ctemp);
+/* Computing MIN */
+ i__3 = k, i__5 = *n - jc;
+ i__2 = min(i__3,i__5) + 1;
+ clarot_(&c_true, &c_true, &c_false, &i__2, &ct, &st, &
+ a[(1 - iskew) * jc + ioffg + jc * a_dim1], &
+ ilda, &ctemp, &dummy);
+
+/* Chase EXTRA back up the matrix */
+
+ icol = jc;
+ i__2 = -k;
+ for (jch = jc - k; i__2 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__2) {
+ clartg_(&a[jch + 1 - iskew * (icol + 1) + ioffg +
+ (icol + 1) * a_dim1], &extra, &realc, &s,
+ &dummy);
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ dummy.r = q__1.r, dummy.i = q__1.i;
+ q__2.r = realc * dummy.r, q__2.i = realc *
+ dummy.i;
+ r_cnjg(&q__1, &q__2);
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__3.r = -s.r, q__3.i = -s.i;
+ q__2.r = q__3.r * dummy.r - q__3.i * dummy.i,
+ q__2.i = q__3.r * dummy.i + q__3.i *
+ dummy.r;
+ r_cnjg(&q__1, &q__2);
+ s.r = q__1.r, s.i = q__1.i;
+ i__3 = jch - iskew * (jch + 1) + ioffg + (jch + 1)
+ * a_dim1;
+ ctemp.r = a[i__3].r, ctemp.i = a[i__3].i;
+ if (csym) {
+ ct.r = c__.r, ct.i = c__.i;
+ st.r = s.r, st.i = s.i;
+ } else {
+ r_cnjg(&q__1, &ctemp);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ r_cnjg(&q__1, &c__);
+ ct.r = q__1.r, ct.i = q__1.i;
+ r_cnjg(&q__1, &s);
+ st.r = q__1.r, st.i = q__1.i;
+ }
+ i__3 = k + 2;
+ clarot_(&c_true, &c_true, &c_true, &i__3, &c__, &
+ s, &a[(1 - iskew) * jch + ioffg + jch *
+ a_dim1], &ilda, &ctemp, &extra);
+/* Computing MAX */
+ i__3 = 1, i__5 = jch - k;
+ irow = max(i__3,i__5);
+/* Computing MIN */
+ i__3 = jch + 1, i__5 = k + 2;
+ il = min(i__3,i__5);
+ extra.r = 0.f, extra.i = 0.f;
+ L__1 = jch > k;
+ clarot_(&c_false, &L__1, &c_true, &il, &ct, &st, &
+ a[irow - iskew * jch + ioffg + jch *
+ a_dim1], &ilda, &extra, &ctemp);
+ icol = jch;
+/* L270: */
+ }
+/* L280: */
+ }
+/* L290: */
+ }
+
+/* If we need lower triangle, copy from upper. Note that */
+/* the order of copying is chosen to work for 'q' -> 'b' */
+
+ if (ipack != ipackg && ipack != 3) {
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ irow = ioffst - iskew * jc;
+ if (csym) {
+/* Computing MIN */
+ i__2 = *n, i__3 = jc + uub;
+ i__4 = min(i__2,i__3);
+ for (jr = jc; jr <= i__4; ++jr) {
+ i__2 = jr + irow + jc * a_dim1;
+ i__3 = jc - iskew * jr + ioffg + jr * a_dim1;
+ a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
+/* L300: */
+ }
+ } else {
+/* Computing MIN */
+ i__2 = *n, i__3 = jc + uub;
+ i__4 = min(i__2,i__3);
+ for (jr = jc; jr <= i__4; ++jr) {
+ i__2 = jr + irow + jc * a_dim1;
+ r_cnjg(&q__1, &a[jc - iskew * jr + ioffg + jr
+ * a_dim1]);
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L310: */
+ }
+ }
+/* L320: */
+ }
+ if (ipack == 5) {
+ i__1 = *n;
+ for (jc = *n - uub + 1; jc <= i__1; ++jc) {
+ i__4 = uub + 1;
+ for (jr = *n + 2 - jc; jr <= i__4; ++jr) {
+ i__2 = jr + jc * a_dim1;
+ a[i__2].r = 0.f, a[i__2].i = 0.f;
+/* L330: */
+ }
+/* L340: */
+ }
+ }
+ if (ipackg == 6) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+ }
+ } else {
+
+/* Bottom-Up -- Generate Lower triangle only */
+
+ if (ipack >= 5) {
+ ipackg = 5;
+ if (ipack == 6) {
+ ioffg = 1;
+ }
+ } else {
+ ipackg = 2;
+ }
+
+ i__1 = mnmin;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = (1 - iskew) * j + ioffg + j * a_dim1;
+ i__2 = j;
+ q__1.r = d__[i__2], q__1.i = 0.f;
+ a[i__4].r = q__1.r, a[i__4].i = q__1.i;
+/* L350: */
+ }
+
+ i__1 = uub;
+ for (k = 1; k <= i__1; ++k) {
+ for (jc = *n - 1; jc >= 1; --jc) {
+/* Computing MIN */
+ i__4 = *n + 1 - jc, i__2 = k + 2;
+ il = min(i__4,i__2);
+ extra.r = 0.f, extra.i = 0.f;
+ i__4 = (1 - iskew) * jc + 1 + ioffg + jc * a_dim1;
+ ctemp.r = a[i__4].r, ctemp.i = a[i__4].i;
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ r__1 = cos(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ r__1 = sin(angle);
+ clarnd_(&q__2, &c__5, &iseed[1]);
+ q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+ s.r = q__1.r, s.i = q__1.i;
+ if (csym) {
+ ct.r = c__.r, ct.i = c__.i;
+ st.r = s.r, st.i = s.i;
+ } else {
+ r_cnjg(&q__1, &ctemp);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ r_cnjg(&q__1, &c__);
+ ct.r = q__1.r, ct.i = q__1.i;
+ r_cnjg(&q__1, &s);
+ st.r = q__1.r, st.i = q__1.i;
+ }
+ L__1 = *n - jc > k;
+ clarot_(&c_false, &c_true, &L__1, &il, &c__, &s, &a[(
+ 1 - iskew) * jc + ioffg + jc * a_dim1], &ilda,
+ &ctemp, &extra);
+/* Computing MAX */
+ i__4 = 1, i__2 = jc - k + 1;
+ icol = max(i__4,i__2);
+ i__4 = jc + 2 - icol;
+ clarot_(&c_true, &c_false, &c_true, &i__4, &ct, &st, &
+ a[jc - iskew * icol + ioffg + icol * a_dim1],
+ &ilda, &dummy, &ctemp);
+
+/* Chase EXTRA back down the matrix */
+
+ icol = jc;
+ i__4 = *n - 1;
+ i__2 = k;
+ for (jch = jc + k; i__2 < 0 ? jch >= i__4 : jch <=
+ i__4; jch += i__2) {
+ clartg_(&a[jch - iskew * icol + ioffg + icol *
+ a_dim1], &extra, &realc, &s, &dummy);
+ clarnd_(&q__1, &c__5, &iseed[1]);
+ dummy.r = q__1.r, dummy.i = q__1.i;
+ q__1.r = realc * dummy.r, q__1.i = realc *
+ dummy.i;
+ c__.r = q__1.r, c__.i = q__1.i;
+ q__1.r = s.r * dummy.r - s.i * dummy.i, q__1.i =
+ s.r * dummy.i + s.i * dummy.r;
+ s.r = q__1.r, s.i = q__1.i;
+ i__3 = (1 - iskew) * jch + 1 + ioffg + jch *
+ a_dim1;
+ ctemp.r = a[i__3].r, ctemp.i = a[i__3].i;
+ if (csym) {
+ ct.r = c__.r, ct.i = c__.i;
+ st.r = s.r, st.i = s.i;
+ } else {
+ r_cnjg(&q__1, &ctemp);
+ ctemp.r = q__1.r, ctemp.i = q__1.i;
+ r_cnjg(&q__1, &c__);
+ ct.r = q__1.r, ct.i = q__1.i;
+ r_cnjg(&q__1, &s);
+ st.r = q__1.r, st.i = q__1.i;
+ }
+ i__3 = k + 2;
+ clarot_(&c_true, &c_true, &c_true, &i__3, &c__, &
+ s, &a[jch - iskew * icol + ioffg + icol *
+ a_dim1], &ilda, &extra, &ctemp);
+/* Computing MIN */
+ i__3 = *n + 1 - jch, i__5 = k + 2;
+ il = min(i__3,i__5);
+ extra.r = 0.f, extra.i = 0.f;
+ L__1 = *n - jch > k;
+ clarot_(&c_false, &c_true, &L__1, &il, &ct, &st, &
+ a[(1 - iskew) * jch + ioffg + jch *
+ a_dim1], &ilda, &ctemp, &extra);
+ icol = jch;
+/* L360: */
+ }
+/* L370: */
+ }
+/* L380: */
+ }
+
+/* If we need upper triangle, copy from lower. Note that */
+/* the order of copying is chosen to work for 'b' -> 'q' */
+
+ if (ipack != ipackg && ipack != 4) {
+ for (jc = *n; jc >= 1; --jc) {
+ irow = ioffst - iskew * jc;
+ if (csym) {
+/* Computing MAX */
+ i__2 = 1, i__4 = jc - uub;
+ i__1 = max(i__2,i__4);
+ for (jr = jc; jr >= i__1; --jr) {
+ i__2 = jr + irow + jc * a_dim1;
+ i__4 = jc - iskew * jr + ioffg + jr * a_dim1;
+ a[i__2].r = a[i__4].r, a[i__2].i = a[i__4].i;
+/* L390: */
+ }
+ } else {
+/* Computing MAX */
+ i__2 = 1, i__4 = jc - uub;
+ i__1 = max(i__2,i__4);
+ for (jr = jc; jr >= i__1; --jr) {
+ i__2 = jr + irow + jc * a_dim1;
+ r_cnjg(&q__1, &a[jc - iskew * jr + ioffg + jr
+ * a_dim1]);
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L400: */
+ }
+ }
+/* L410: */
+ }
+ if (ipack == 6) {
+ i__1 = uub;
+ for (jc = 1; jc <= i__1; ++jc) {
+ i__2 = uub + 1 - jc;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__4 = jr + jc * a_dim1;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L420: */
+ }
+/* L430: */
+ }
+ }
+ if (ipackg == 5) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+ }
+ }
+
+/* Ensure that the diagonal is real if Hermitian */
+
+ if (! csym) {
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ irow = ioffst + (1 - iskew) * jc;
+ i__2 = irow + jc * a_dim1;
+ i__4 = irow + jc * a_dim1;
+ r__1 = a[i__4].r;
+ q__1.r = r__1, q__1.i = 0.f;
+ a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+/* L440: */
+ }
+ }
+
+ }
+
+ } else {
+
+/* 4) Generate Banded Matrix by first */
+/* Rotating by random Unitary matrices, */
+/* then reducing the bandwidth using Householder */
+/* transformations. */
+
+/* Note: we should get here only if LDA .ge. N */
+
+ if (isym == 1) {
+
+/* Non-symmetric -- A = U D V */
+
+ clagge_(&mr, &nc, &llb, &uub, &d__[1], &a[a_offset], lda, &iseed[
+ 1], &work[1], &iinfo);
+ } else {
+
+/* Symmetric -- A = U D U' or */
+/* Hermitian -- A = U D U* */
+
+ if (csym) {
+ clagsy_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[
+ 1], &iinfo);
+ } else {
+ claghe_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[
+ 1], &iinfo);
+ }
+ }
+
+ if (iinfo != 0) {
+ *info = 3;
+ return 0;
+ }
+ }
+
+/* 5) Pack the matrix */
+
+ if (ipack != ipackg) {
+ if (ipack == 1) {
+
+/* 'U' -- Upper triangular, not packed */
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L450: */
+ }
+/* L460: */
+ }
+
+ } else if (ipack == 2) {
+
+/* 'L' -- Lower triangular, not packed */
+
+ i__1 = *m;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L470: */
+ }
+/* L480: */
+ }
+
+ } else if (ipack == 3) {
+
+/* 'C' -- Upper triangle packed Columnwise. */
+
+ icol = 1;
+ irow = 0;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ++irow;
+ if (irow > *lda) {
+ irow = 1;
+ ++icol;
+ }
+ i__4 = irow + icol * a_dim1;
+ i__3 = i__ + j * a_dim1;
+ a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i;
+/* L490: */
+ }
+/* L500: */
+ }
+
+ } else if (ipack == 4) {
+
+/* 'R' -- Lower triangle packed Columnwise. */
+
+ icol = 1;
+ irow = 0;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ++irow;
+ if (irow > *lda) {
+ irow = 1;
+ ++icol;
+ }
+ i__4 = irow + icol * a_dim1;
+ i__3 = i__ + j * a_dim1;
+ a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i;
+/* L510: */
+ }
+/* L520: */
+ }
+
+ } else if (ipack >= 5) {
+
+/* 'B' -- The lower triangle is packed as a band matrix. */
+/* 'Q' -- The upper triangle is packed as a band matrix. */
+/* 'Z' -- The whole matrix is packed as a band matrix. */
+
+ if (ipack == 5) {
+ uub = 0;
+ }
+ if (ipack == 6) {
+ llb = 0;
+ }
+
+ i__1 = uub;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = j + llb;
+ for (i__ = min(i__2,*m); i__ >= 1; --i__) {
+ i__2 = i__ - j + uub + 1 + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ a[i__2].r = a[i__4].r, a[i__2].i = a[i__4].i;
+/* L530: */
+ }
+/* L540: */
+ }
+
+ i__1 = *n;
+ for (j = uub + 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = j + llb;
+ i__2 = min(i__4,*m);
+ for (i__ = j - uub; i__ <= i__2; ++i__) {
+ i__4 = i__ - j + uub + 1 + j * a_dim1;
+ i__3 = i__ + j * a_dim1;
+ a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i;
+/* L550: */
+ }
+/* L560: */
+ }
+ }
+
+/* If packed, zero out extraneous elements. */
+
+/* Symmetric/Triangular Packed -- */
+/* zero out everything after A(IROW,ICOL) */
+
+ if (ipack == 3 || ipack == 4) {
+ i__1 = *m;
+ for (jc = icol; jc <= i__1; ++jc) {
+ i__2 = *lda;
+ for (jr = irow + 1; jr <= i__2; ++jr) {
+ i__4 = jr + jc * a_dim1;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L570: */
+ }
+ irow = 0;
+/* L580: */
+ }
+
+ } else if (ipack >= 5) {
+
+/* Packed Band -- */
+/* 1st row is now in A( UUB+2-j, j), zero above it */
+/* m-th row is now in A( M+UUB-j,j), zero below it */
+/* last non-zero diagonal is now in A( UUB+LLB+1,j ), */
+/* zero below it, too. */
+
+ ir1 = uub + llb + 2;
+ ir2 = uub + *m + 2;
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ i__2 = uub + 1 - jc;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__4 = jr + jc * a_dim1;
+ a[i__4].r = 0.f, a[i__4].i = 0.f;
+/* L590: */
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__3 = ir1, i__5 = ir2 - jc;
+ i__2 = 1, i__4 = min(i__3,i__5);
+ i__6 = *lda;
+ for (jr = max(i__2,i__4); jr <= i__6; ++jr) {
+ i__2 = jr + jc * a_dim1;
+ a[i__2].r = 0.f, a[i__2].i = 0.f;
+/* L600: */
+ }
+/* L610: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of CLATMT */
+
+} /* clatmt_ */
diff --git a/TESTING/MATGEN/dlagge.c b/TESTING/MATGEN/dlagge.c
new file mode 100644
index 0000000..fd72629
--- /dev/null
+++ b/TESTING/MATGEN/dlagge.c
@@ -0,0 +1,414 @@
+/* dlagge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static doublereal c_b11 = 1.;
+static doublereal c_b13 = 0.;
+
+/* Subroutine */ int dlagge_(integer *m, integer *n, integer *kl, integer *ku,
+ doublereal *d__, doublereal *a, integer *lda, integer *iseed,
+ doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal wa, wb, wn, tau;
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *), dgemv_(char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *), xerbla_(char *, integer *), dlarnv_(integer *, integer *, integer *, doublereal *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAGGE generates a real general m by n matrix A, by pre- and post- */
+/* multiplying a real diagonal matrix D with random orthogonal matrices: */
+/* A = U*D*V. The lower and upper bandwidths may then be reduced to */
+/* kl and ku by additional orthogonal transformations. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of nonzero subdiagonals within the band of A. */
+/* 0 <= KL <= M-1. */
+
+/* KU (input) INTEGER */
+/* The number of nonzero superdiagonals within the band of A. */
+/* 0 <= KU <= N-1. */
+
+/* D (input) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The diagonal elements of the diagonal matrix D. */
+
+/* A (output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The generated m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (M+N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --d__;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iseed;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0 || *kl > *m - 1) {
+ *info = -3;
+ } else if (*ku < 0 || *ku > *n - 1) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -7;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("DLAGGE", &i__1);
+ return 0;
+ }
+
+/* initialize A to diagonal matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ i__1 = min(*m,*n);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ a[i__ + i__ * a_dim1] = d__[i__];
+/* L30: */
+ }
+
+/* pre- and post-multiply A by random orthogonal matrices */
+
+ for (i__ = min(*m,*n); i__ >= 1; --i__) {
+ if (i__ < *m) {
+
+/* generate random reflection */
+
+ i__1 = *m - i__ + 1;
+ dlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+ i__1 = *m - i__ + 1;
+ wn = dnrm2_(&i__1, &work[1], &c__1);
+ wa = d_sign(&wn, &work[1]);
+ if (wn == 0.) {
+ tau = 0.;
+ } else {
+ wb = work[1] + wa;
+ i__1 = *m - i__;
+ d__1 = 1. / wb;
+ dscal_(&i__1, &d__1, &work[2], &c__1);
+ work[1] = 1.;
+ tau = wb / wa;
+ }
+
+/* multiply A(i:m,i:n) by random reflection from the left */
+
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__ + 1;
+ dgemv_("Transpose", &i__1, &i__2, &c_b11, &a[i__ + i__ * a_dim1],
+ lda, &work[1], &c__1, &c_b13, &work[*m + 1], &c__1);
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__ + 1;
+ d__1 = -tau;
+ dger_(&i__1, &i__2, &d__1, &work[1], &c__1, &work[*m + 1], &c__1,
+ &a[i__ + i__ * a_dim1], lda);
+ }
+ if (i__ < *n) {
+
+/* generate random reflection */
+
+ i__1 = *n - i__ + 1;
+ dlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+ i__1 = *n - i__ + 1;
+ wn = dnrm2_(&i__1, &work[1], &c__1);
+ wa = d_sign(&wn, &work[1]);
+ if (wn == 0.) {
+ tau = 0.;
+ } else {
+ wb = work[1] + wa;
+ i__1 = *n - i__;
+ d__1 = 1. / wb;
+ dscal_(&i__1, &d__1, &work[2], &c__1);
+ work[1] = 1.;
+ tau = wb / wa;
+ }
+
+/* multiply A(i:m,i:n) by random reflection from the right */
+
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__ + 1;
+ dgemv_("No transpose", &i__1, &i__2, &c_b11, &a[i__ + i__ *
+ a_dim1], lda, &work[1], &c__1, &c_b13, &work[*n + 1], &
+ c__1);
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__ + 1;
+ d__1 = -tau;
+ dger_(&i__1, &i__2, &d__1, &work[*n + 1], &c__1, &work[1], &c__1,
+ &a[i__ + i__ * a_dim1], lda);
+ }
+/* L40: */
+ }
+
+/* Reduce number of subdiagonals to KL and number of superdiagonals */
+/* to KU */
+
+/* Computing MAX */
+ i__2 = *m - 1 - *kl, i__3 = *n - 1 - *ku;
+ i__1 = max(i__2,i__3);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*kl <= *ku) {
+
+/* annihilate subdiagonal elements first (necessary if KL = 0) */
+
+/* Computing MIN */
+ i__2 = *m - 1 - *kl;
+ if (i__ <= min(i__2,*n)) {
+
+/* generate reflection to annihilate A(kl+i+1:m,i) */
+
+ i__2 = *m - *kl - i__ + 1;
+ wn = dnrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
+ wa = d_sign(&wn, &a[*kl + i__ + i__ * a_dim1]);
+ if (wn == 0.) {
+ tau = 0.;
+ } else {
+ wb = a[*kl + i__ + i__ * a_dim1] + wa;
+ i__2 = *m - *kl - i__;
+ d__1 = 1. / wb;
+ dscal_(&i__2, &d__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
+ c__1);
+ a[*kl + i__ + i__ * a_dim1] = 1.;
+ tau = wb / wa;
+ }
+
+/* apply reflection to A(kl+i:m,i+1:n) from the left */
+
+ i__2 = *m - *kl - i__ + 1;
+ i__3 = *n - i__;
+ dgemv_("Transpose", &i__2, &i__3, &c_b11, &a[*kl + i__ + (i__
+ + 1) * a_dim1], lda, &a[*kl + i__ + i__ * a_dim1], &
+ c__1, &c_b13, &work[1], &c__1);
+ i__2 = *m - *kl - i__ + 1;
+ i__3 = *n - i__;
+ d__1 = -tau;
+ dger_(&i__2, &i__3, &d__1, &a[*kl + i__ + i__ * a_dim1], &
+ c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) *
+ a_dim1], lda);
+ a[*kl + i__ + i__ * a_dim1] = -wa;
+ }
+
+/* Computing MIN */
+ i__2 = *n - 1 - *ku;
+ if (i__ <= min(i__2,*m)) {
+
+/* generate reflection to annihilate A(i,ku+i+1:n) */
+
+ i__2 = *n - *ku - i__ + 1;
+ wn = dnrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+ wa = d_sign(&wn, &a[i__ + (*ku + i__) * a_dim1]);
+ if (wn == 0.) {
+ tau = 0.;
+ } else {
+ wb = a[i__ + (*ku + i__) * a_dim1] + wa;
+ i__2 = *n - *ku - i__;
+ d__1 = 1. / wb;
+ dscal_(&i__2, &d__1, &a[i__ + (*ku + i__ + 1) * a_dim1],
+ lda);
+ a[i__ + (*ku + i__) * a_dim1] = 1.;
+ tau = wb / wa;
+ }
+
+/* apply reflection to A(i+1:m,ku+i:n) from the right */
+
+ i__2 = *m - i__;
+ i__3 = *n - *ku - i__ + 1;
+ dgemv_("No transpose", &i__2, &i__3, &c_b11, &a[i__ + 1 + (*
+ ku + i__) * a_dim1], lda, &a[i__ + (*ku + i__) *
+ a_dim1], lda, &c_b13, &work[1], &c__1);
+ i__2 = *m - i__;
+ i__3 = *n - *ku - i__ + 1;
+ d__1 = -tau;
+ dger_(&i__2, &i__3, &d__1, &work[1], &c__1, &a[i__ + (*ku +
+ i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) *
+ a_dim1], lda);
+ a[i__ + (*ku + i__) * a_dim1] = -wa;
+ }
+ } else {
+
+/* annihilate superdiagonal elements first (necessary if */
+/* KU = 0) */
+
+/* Computing MIN */
+ i__2 = *n - 1 - *ku;
+ if (i__ <= min(i__2,*m)) {
+
+/* generate reflection to annihilate A(i,ku+i+1:n) */
+
+ i__2 = *n - *ku - i__ + 1;
+ wn = dnrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+ wa = d_sign(&wn, &a[i__ + (*ku + i__) * a_dim1]);
+ if (wn == 0.) {
+ tau = 0.;
+ } else {
+ wb = a[i__ + (*ku + i__) * a_dim1] + wa;
+ i__2 = *n - *ku - i__;
+ d__1 = 1. / wb;
+ dscal_(&i__2, &d__1, &a[i__ + (*ku + i__ + 1) * a_dim1],
+ lda);
+ a[i__ + (*ku + i__) * a_dim1] = 1.;
+ tau = wb / wa;
+ }
+
+/* apply reflection to A(i+1:m,ku+i:n) from the right */
+
+ i__2 = *m - i__;
+ i__3 = *n - *ku - i__ + 1;
+ dgemv_("No transpose", &i__2, &i__3, &c_b11, &a[i__ + 1 + (*
+ ku + i__) * a_dim1], lda, &a[i__ + (*ku + i__) *
+ a_dim1], lda, &c_b13, &work[1], &c__1);
+ i__2 = *m - i__;
+ i__3 = *n - *ku - i__ + 1;
+ d__1 = -tau;
+ dger_(&i__2, &i__3, &d__1, &work[1], &c__1, &a[i__ + (*ku +
+ i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) *
+ a_dim1], lda);
+ a[i__ + (*ku + i__) * a_dim1] = -wa;
+ }
+
+/* Computing MIN */
+ i__2 = *m - 1 - *kl;
+ if (i__ <= min(i__2,*n)) {
+
+/* generate reflection to annihilate A(kl+i+1:m,i) */
+
+ i__2 = *m - *kl - i__ + 1;
+ wn = dnrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
+ wa = d_sign(&wn, &a[*kl + i__ + i__ * a_dim1]);
+ if (wn == 0.) {
+ tau = 0.;
+ } else {
+ wb = a[*kl + i__ + i__ * a_dim1] + wa;
+ i__2 = *m - *kl - i__;
+ d__1 = 1. / wb;
+ dscal_(&i__2, &d__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
+ c__1);
+ a[*kl + i__ + i__ * a_dim1] = 1.;
+ tau = wb / wa;
+ }
+
+/* apply reflection to A(kl+i:m,i+1:n) from the left */
+
+ i__2 = *m - *kl - i__ + 1;
+ i__3 = *n - i__;
+ dgemv_("Transpose", &i__2, &i__3, &c_b11, &a[*kl + i__ + (i__
+ + 1) * a_dim1], lda, &a[*kl + i__ + i__ * a_dim1], &
+ c__1, &c_b13, &work[1], &c__1);
+ i__2 = *m - *kl - i__ + 1;
+ i__3 = *n - i__;
+ d__1 = -tau;
+ dger_(&i__2, &i__3, &d__1, &a[*kl + i__ + i__ * a_dim1], &
+ c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) *
+ a_dim1], lda);
+ a[*kl + i__ + i__ * a_dim1] = -wa;
+ }
+ }
+
+ i__2 = *m;
+ for (j = *kl + i__ + 1; j <= i__2; ++j) {
+ a[j + i__ * a_dim1] = 0.;
+/* L50: */
+ }
+
+ i__2 = *n;
+ for (j = *ku + i__ + 1; j <= i__2; ++j) {
+ a[i__ + j * a_dim1] = 0.;
+/* L60: */
+ }
+/* L70: */
+ }
+ return 0;
+
+/* End of DLAGGE */
+
+} /* dlagge_ */
diff --git a/TESTING/MATGEN/dlagsy.c b/TESTING/MATGEN/dlagsy.c
new file mode 100644
index 0000000..599e415
--- /dev/null
+++ b/TESTING/MATGEN/dlagsy.c
@@ -0,0 +1,291 @@
+/* dlagsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static doublereal c_b12 = 0.;
+static doublereal c_b19 = -1.;
+static doublereal c_b26 = 1.;
+
+/* Subroutine */ int dlagsy_(integer *n, integer *k, doublereal *d__,
+ doublereal *a, integer *lda, integer *iseed, doublereal *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal wa, wb, wn, tau;
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
+ integer *), dnrm2_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ doublereal alpha;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *), dgemv_(char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *), daxpy_(integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *), dsymv_(char *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *), dlarnv_(integer *, integer *,
+ integer *, doublereal *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAGSY generates a real symmetric matrix A, by pre- and post- */
+/* multiplying a real diagonal matrix D with a random orthogonal matrix: */
+/* A = U*D*U'. The semi-bandwidth may then be reduced to k by additional */
+/* orthogonal transformations. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of nonzero subdiagonals within the band of A. */
+/* 0 <= K <= N-1. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal elements of the diagonal matrix D. */
+
+/* A (output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* The generated n by n symmetric matrix A (the full matrix is */
+/* stored). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= N. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --d__;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iseed;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*k < 0 || *k > *n - 1) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("DLAGSY", &i__1);
+ return 0;
+ }
+
+/* initialize lower triangle of A to diagonal matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ a[i__ + i__ * a_dim1] = d__[i__];
+/* L30: */
+ }
+
+/* Generate lower triangle of symmetric matrix */
+
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+
+/* generate random reflection */
+
+ i__1 = *n - i__ + 1;
+ dlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+ i__1 = *n - i__ + 1;
+ wn = dnrm2_(&i__1, &work[1], &c__1);
+ wa = d_sign(&wn, &work[1]);
+ if (wn == 0.) {
+ tau = 0.;
+ } else {
+ wb = work[1] + wa;
+ i__1 = *n - i__;
+ d__1 = 1. / wb;
+ dscal_(&i__1, &d__1, &work[2], &c__1);
+ work[1] = 1.;
+ tau = wb / wa;
+ }
+
+/* apply random reflection to A(i:n,i:n) from the left */
+/* and the right */
+
+/* compute y := tau * A * u */
+
+ i__1 = *n - i__ + 1;
+ dsymv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], &
+ c__1, &c_b12, &work[*n + 1], &c__1);
+
+/* compute v := y - 1/2 * tau * ( y, u ) * u */
+
+ i__1 = *n - i__ + 1;
+ alpha = tau * -.5 * ddot_(&i__1, &work[*n + 1], &c__1, &work[1], &
+ c__1);
+ i__1 = *n - i__ + 1;
+ daxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
+
+/* apply the transformation as a rank-2 update to A(i:n,i:n) */
+
+ i__1 = *n - i__ + 1;
+ dsyr2_("Lower", &i__1, &c_b19, &work[1], &c__1, &work[*n + 1], &c__1,
+ &a[i__ + i__ * a_dim1], lda);
+/* L40: */
+ }
+
+/* Reduce number of subdiagonals to K */
+
+ i__1 = *n - 1 - *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* generate reflection to annihilate A(k+i+1:n,i) */
+
+ i__2 = *n - *k - i__ + 1;
+ wn = dnrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
+ wa = d_sign(&wn, &a[*k + i__ + i__ * a_dim1]);
+ if (wn == 0.) {
+ tau = 0.;
+ } else {
+ wb = a[*k + i__ + i__ * a_dim1] + wa;
+ i__2 = *n - *k - i__;
+ d__1 = 1. / wb;
+ dscal_(&i__2, &d__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1);
+ a[*k + i__ + i__ * a_dim1] = 1.;
+ tau = wb / wa;
+ }
+
+/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */
+
+ i__2 = *n - *k - i__ + 1;
+ i__3 = *k - 1;
+ dgemv_("Transpose", &i__2, &i__3, &c_b26, &a[*k + i__ + (i__ + 1) *
+ a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b12, &
+ work[1], &c__1);
+ i__2 = *n - *k - i__ + 1;
+ i__3 = *k - 1;
+ d__1 = -tau;
+ dger_(&i__2, &i__3, &d__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[
+ 1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda);
+
+/* apply reflection to A(k+i:n,k+i:n) from the left and the right */
+
+/* compute y := tau * A * u */
+
+ i__2 = *n - *k - i__ + 1;
+ dsymv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda,
+ &a[*k + i__ + i__ * a_dim1], &c__1, &c_b12, &work[1], &c__1);
+
+/* compute v := y - 1/2 * tau * ( y, u ) * u */
+
+ i__2 = *n - *k - i__ + 1;
+ alpha = tau * -.5 * ddot_(&i__2, &work[1], &c__1, &a[*k + i__ + i__ *
+ a_dim1], &c__1);
+ i__2 = *n - *k - i__ + 1;
+ daxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], &
+ c__1);
+
+/* apply symmetric rank-2 update to A(k+i:n,k+i:n) */
+
+ i__2 = *n - *k - i__ + 1;
+ dsyr2_("Lower", &i__2, &c_b19, &a[*k + i__ + i__ * a_dim1], &c__1, &
+ work[1], &c__1, &a[*k + i__ + (*k + i__) * a_dim1], lda);
+
+ a[*k + i__ + i__ * a_dim1] = -wa;
+ i__2 = *n;
+ for (j = *k + i__ + 1; j <= i__2; ++j) {
+ a[j + i__ * a_dim1] = 0.;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* Store full symmetric matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[j + i__ * a_dim1] = a[i__ + j * a_dim1];
+/* L70: */
+ }
+/* L80: */
+ }
+ return 0;
+
+/* End of DLAGSY */
+
+} /* dlagsy_ */
diff --git a/TESTING/MATGEN/dlahilb.c b/TESTING/MATGEN/dlahilb.c
new file mode 100644
index 0000000..57902cd
--- /dev/null
+++ b/TESTING/MATGEN/dlahilb.c
@@ -0,0 +1,202 @@
+/* dlahilb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b4 = 0.;
+
+/* Subroutine */ int dlahilb_(integer *n, integer *nrhs, doublereal *a,
+ integer *lda, doublereal *x, integer *ldx, doublereal *b, integer *
+ ldb, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, x_dim1, x_offset, b_dim1, b_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Local variables */
+ integer i__, j, m, r__, ti, tm;
+ doublecomplex tmp;
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublecomplex *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
+/* Courant Institute, Argonne National Lab, and Rice University */
+/* 28 August, 2006 */
+
+/* David Vu <dtv at cs.berkeley.edu> */
+/* Yozo Hida <yozo at cs.berkeley.edu> */
+/* Jason Riedy <ejr at cs.berkeley.edu> */
+/* D. Halligan <dhalligan at berkeley.edu> */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAHILB generates an N by N scaled Hilbert matrix in A along with */
+/* NRHS right-hand sides in B and solutions in X such that A*X=B. */
+
+/* The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all */
+/* entries are integers. The right-hand sides are the first NRHS */
+/* columns of M * the identity matrix, and the solutions are the */
+/* first NRHS columns of the inverse Hilbert matrix. */
+
+/* The condition number of the Hilbert matrix grows exponentially with */
+/* its size, roughly as O(e ** (3.5*N)). Additionally, the inverse */
+/* Hilbert matrices beyond a relatively small dimension cannot be */
+/* generated exactly without extra precision. Precision is exhausted */
+/* when the largest entry in the inverse Hilbert matrix is greater than */
+/* 2 to the power of the number of bits in the fraction of the data type */
+/* used plus one, which is 24 for single precision. */
+
+/* In single, the generated solution is exact for N <= 6 and has */
+/* small componentwise error for 7 <= N <= 11. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The dimension of the matrix A. */
+
+/* NRHS (input) NRHS */
+/* The requested number of right-hand sides. */
+
+/* A (output) DOUBLE PRECISION array, dimension (LDA, N) */
+/* The generated scaled Hilbert matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= N. */
+
+/* X (output) DOUBLE PRECISION array, dimension (LDX, NRHS) */
+/* The generated exact solutions. Currently, the first NRHS */
+/* columns of the inverse Hilbert matrix. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= N. */
+
+/* B (output) DOUBLE PRECISION array, dimension (LDB, NRHS) */
+/* The generated right-hand sides. Currently, the first NRHS */
+/* columns of LCM(1, 2, ..., 2*N-1) * the identity matrix. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= N. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
+
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* = 1: N is too large; the data is still generated but may not */
+/* be not exact. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+/* .. Local Scalars .. */
+/* .. Parameters .. */
+/* NMAX_EXACT the largest dimension where the generated data is */
+/* exact. */
+/* NMAX_APPROX the largest dimension where the generated data has */
+/* a small componentwise relative error. */
+/* .. */
+/* .. External Functions */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --work;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0 || *n > 11) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*lda < *n) {
+ *info = -4;
+ } else if (*ldx < *n) {
+ *info = -6;
+ } else if (*ldb < *n) {
+ *info = -8;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("DLAHILB", &i__1);
+ return 0;
+ }
+ if (*n > 6) {
+ *info = 1;
+ }
+/* Compute M = the LCM of the integers [1, 2*N-1]. The largest */
+/* reasonable N is small enough that integers suffice (up to N = 11). */
+ m = 1;
+ i__1 = (*n << 1) - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ tm = m;
+ ti = i__;
+ r__ = tm % ti;
+ while(r__ != 0) {
+ tm = ti;
+ ti = r__;
+ r__ = tm % ti;
+ }
+ m = m / ti * i__;
+ }
+/* Generate the scaled Hilbert matrix in A */
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = (doublereal) m / (i__ + j - 1);
+ }
+ }
+/* Generate matrix B as simply the first NRHS columns of M * the */
+/* identity. */
+ d__1 = (doublereal) m;
+ tmp.r = d__1, tmp.i = 0.;
+ dlaset_("Full", n, nrhs, &c_b4, &tmp, &b[b_offset], ldb);
+/* Generate the true solutions in X. Because B = the first NRHS */
+/* columns of M*I, the true solutions are just the first NRHS columns */
+/* of the inverse Hilbert matrix. */
+ work[1] = (doublereal) (*n);
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ work[j] = work[j - 1] / (j - 1) * (j - 1 - *n) / (j - 1) * (*n + j -
+ 1);
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__ + j * x_dim1] = work[i__] * work[j] / (i__ + j - 1);
+ }
+ }
+ return 0;
+} /* dlahilb_ */
diff --git a/TESTING/MATGEN/dlakf2.c b/TESTING/MATGEN/dlakf2.c
new file mode 100644
index 0000000..7bb214c
--- /dev/null
+++ b/TESTING/MATGEN/dlakf2.c
@@ -0,0 +1,187 @@
+/* dlakf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b3 = 0.;
+
+/* Subroutine */ int dlakf2_(integer *m, integer *n, doublereal *a, integer *
+ lda, doublereal *b, doublereal *d__, doublereal *e, doublereal *z__,
+ integer *ldz)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, d_dim1, d_offset, e_dim1,
+ e_offset, z_dim1, z_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, l, ik, jk, mn, mn2;
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Form the 2*M*N by 2*M*N matrix */
+
+/* Z = [ kron(In, A) -kron(B', Im) ] */
+/* [ kron(In, D) -kron(E', Im) ], */
+
+/* where In is the identity matrix of size n and X' is the transpose */
+/* of X. kron(X, Y) is the Kronecker product between the matrices X */
+/* and Y. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* Size of matrix, must be >= 1. */
+
+/* N (input) INTEGER */
+/* Size of matrix, must be >= 1. */
+
+/* A (input) DOUBLE PRECISION, dimension ( LDA, M ) */
+/* The matrix A in the output matrix Z. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, D, and E. ( LDA >= M+N ) */
+
+/* B (input) DOUBLE PRECISION, dimension ( LDA, N ) */
+/* D (input) DOUBLE PRECISION, dimension ( LDA, M ) */
+/* E (input) DOUBLE PRECISION, dimension ( LDA, N ) */
+/* The matrices used in forming the output matrix Z. */
+
+/* Z (output) DOUBLE PRECISION, dimension ( LDZ, 2*M*N ) */
+/* The resultant Kronecker M*N*2 by M*N*2 matrix (see above.) */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of Z. ( LDZ >= 2*M*N ) */
+
+/* ==================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize Z */
+
+ /* Parameter adjustments */
+ e_dim1 = *lda;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ d_dim1 = *lda;
+ d_offset = 1 + d_dim1;
+ d__ -= d_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+
+ /* Function Body */
+ mn = *m * *n;
+ mn2 = mn << 1;
+ dlaset_("Full", &mn2, &mn2, &c_b3, &c_b3, &z__[z_offset], ldz);
+
+ ik = 1;
+ i__1 = *n;
+ for (l = 1; l <= i__1; ++l) {
+
+/* form kron(In, A) */
+
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = *m;
+ for (j = 1; j <= i__3; ++j) {
+ z__[ik + i__ - 1 + (ik + j - 1) * z_dim1] = a[i__ + j *
+ a_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* form kron(In, D) */
+
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = *m;
+ for (j = 1; j <= i__3; ++j) {
+ z__[ik + mn + i__ - 1 + (ik + j - 1) * z_dim1] = d__[i__ + j *
+ d_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+
+ ik += *m;
+/* L50: */
+ }
+
+ ik = 1;
+ i__1 = *n;
+ for (l = 1; l <= i__1; ++l) {
+ jk = mn + 1;
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+
+/* form -kron(B', Im) */
+
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ z__[ik + i__ - 1 + (jk + i__ - 1) * z_dim1] = -b[j + l *
+ b_dim1];
+/* L60: */
+ }
+
+/* form -kron(E', Im) */
+
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ z__[ik + mn + i__ - 1 + (jk + i__ - 1) * z_dim1] = -e[j + l *
+ e_dim1];
+/* L70: */
+ }
+
+ jk += *m;
+/* L80: */
+ }
+
+ ik += *m;
+/* L90: */
+ }
+
+ return 0;
+
+/* End of DLAKF2 */
+
+} /* dlakf2_ */
diff --git a/TESTING/MATGEN/dlaran.c b/TESTING/MATGEN/dlaran.c
new file mode 100644
index 0000000..fd0969d
--- /dev/null
+++ b/TESTING/MATGEN/dlaran.c
@@ -0,0 +1,123 @@
+/* dlaran.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dlaran_(integer *iseed)
+{
+ /* System generated locals */
+ doublereal ret_val;
+
+ /* Local variables */
+ integer it1, it2, it3, it4;
+ doublereal rndout;
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARAN returns a random real number from a uniform (0,1) */
+/* distribution. */
+
+/* Arguments */
+/* ========= */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* Further Details */
+/* =============== */
+
+/* This routine uses a multiplicative congruential method with modulus */
+/* 2**48 and multiplier 33952834046453 (see G.S.Fishman, */
+/* 'Multiplicative congruential random number generators with modulus */
+/* 2**b: an exhaustive analysis for b = 32 and a partial analysis for */
+/* b = 48', Math. Comp. 189, pp 331-344, 1990). */
+
+/* 48-bit integers are stored in 4 integer array elements with 12 bits */
+/* per element. Hence the routine is portable across machines with */
+/* integers of 32 bits or more. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ --iseed;
+
+ /* Function Body */
+L10:
+
+/* multiply the seed by the multiplier modulo 2**48 */
+
+ it4 = iseed[4] * 2549;
+ it3 = it4 / 4096;
+ it4 -= it3 << 12;
+ it3 = it3 + iseed[3] * 2549 + iseed[4] * 2508;
+ it2 = it3 / 4096;
+ it3 -= it2 << 12;
+ it2 = it2 + iseed[2] * 2549 + iseed[3] * 2508 + iseed[4] * 322;
+ it1 = it2 / 4096;
+ it2 -= it1 << 12;
+ it1 = it1 + iseed[1] * 2549 + iseed[2] * 2508 + iseed[3] * 322 + iseed[4]
+ * 494;
+ it1 %= 4096;
+
+/* return updated seed */
+
+ iseed[1] = it1;
+ iseed[2] = it2;
+ iseed[3] = it3;
+ iseed[4] = it4;
+
+/* convert 48-bit integer to a real number in the interval (0,1) */
+
+ rndout = ((doublereal) it1 + ((doublereal) it2 + ((doublereal) it3 + (
+ doublereal) it4 * 2.44140625e-4) * 2.44140625e-4) * 2.44140625e-4)
+ * 2.44140625e-4;
+
+ if (rndout == 1.) {
+/* If a real number has n bits of precision, and the first */
+/* n bits of the 48-bit integer above happen to be all 1 (which */
+/* will occur about once every 2**n calls), then DLARAN will */
+/* be rounded to exactly 1.0. */
+/* Since DLARAN is not supposed to return exactly 0.0 or 1.0 */
+/* (and some callers of DLARAN, such as CLARND, depend on that), */
+/* the statistically correct thing to do in this situation is */
+/* simply to iterate again. */
+/* N.B. the case DLARAN = 0.0 should not be possible. */
+
+ goto L10;
+ }
+
+ ret_val = rndout;
+ return ret_val;
+
+/* End of DLARAN */
+
+} /* dlaran_ */
diff --git a/TESTING/MATGEN/dlarge.c b/TESTING/MATGEN/dlarge.c
new file mode 100644
index 0000000..f01d009
--- /dev/null
+++ b/TESTING/MATGEN/dlarge.c
@@ -0,0 +1,170 @@
+/* dlarge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static doublereal c_b8 = 1.;
+static doublereal c_b10 = 0.;
+
+/* Subroutine */ int dlarge_(integer *n, doublereal *a, integer *lda, integer
+ *iseed, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer i__;
+ doublereal wa, wb, wn, tau;
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *), dgemv_(char *, integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ doublereal *, integer *), xerbla_(char *, integer *), dlarnv_(integer *, integer *, integer *, doublereal *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARGE pre- and post-multiplies a real general n by n matrix A */
+/* with a random orthogonal matrix: A = U*D*U'. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/* On entry, the original n by n matrix A. */
+/* On exit, A is overwritten by U*A*U' for some random */
+/* orthogonal matrix U. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= N. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iseed;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*lda < max(1,*n)) {
+ *info = -3;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("DLARGE", &i__1);
+ return 0;
+ }
+
+/* pre- and post-multiply A by random orthogonal matrix */
+
+ for (i__ = *n; i__ >= 1; --i__) {
+
+/* generate random reflection */
+
+ i__1 = *n - i__ + 1;
+ dlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+ i__1 = *n - i__ + 1;
+ wn = dnrm2_(&i__1, &work[1], &c__1);
+ wa = d_sign(&wn, &work[1]);
+ if (wn == 0.) {
+ tau = 0.;
+ } else {
+ wb = work[1] + wa;
+ i__1 = *n - i__;
+ d__1 = 1. / wb;
+ dscal_(&i__1, &d__1, &work[2], &c__1);
+ work[1] = 1.;
+ tau = wb / wa;
+ }
+
+/* multiply A(i:n,1:n) by random reflection from the left */
+
+ i__1 = *n - i__ + 1;
+ dgemv_("Transpose", &i__1, n, &c_b8, &a[i__ + a_dim1], lda, &work[1],
+ &c__1, &c_b10, &work[*n + 1], &c__1);
+ i__1 = *n - i__ + 1;
+ d__1 = -tau;
+ dger_(&i__1, n, &d__1, &work[1], &c__1, &work[*n + 1], &c__1, &a[i__
+ + a_dim1], lda);
+
+/* multiply A(1:n,i:n) by random reflection from the right */
+
+ i__1 = *n - i__ + 1;
+ dgemv_("No transpose", n, &i__1, &c_b8, &a[i__ * a_dim1 + 1], lda, &
+ work[1], &c__1, &c_b10, &work[*n + 1], &c__1);
+ i__1 = *n - i__ + 1;
+ d__1 = -tau;
+ dger_(n, &i__1, &d__1, &work[*n + 1], &c__1, &work[1], &c__1, &a[i__ *
+ a_dim1 + 1], lda);
+/* L10: */
+ }
+ return 0;
+
+/* End of DLARGE */
+
+} /* dlarge_ */
diff --git a/TESTING/MATGEN/dlarnd.c b/TESTING/MATGEN/dlarnd.c
new file mode 100644
index 0000000..df629ab
--- /dev/null
+++ b/TESTING/MATGEN/dlarnd.c
@@ -0,0 +1,108 @@
+/* dlarnd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dlarnd_(integer *idist, integer *iseed)
+{
+ /* System generated locals */
+ doublereal ret_val;
+
+ /* Builtin functions */
+ double log(doublereal), sqrt(doublereal), cos(doublereal);
+
+ /* Local variables */
+ doublereal t1, t2;
+ extern doublereal dlaran_(integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLARND returns a random real number from a uniform or normal */
+/* distribution. */
+
+/* Arguments */
+/* ========= */
+
+/* IDIST (input) INTEGER */
+/* Specifies the distribution of the random numbers: */
+/* = 1: uniform (0,1) */
+/* = 2: uniform (-1,1) */
+/* = 3: normal (0,1) */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* Further Details */
+/* =============== */
+
+/* This routine calls the auxiliary routine DLARAN to generate a random */
+/* real number from a uniform (0,1) distribution. The Box-Muller method */
+/* is used to transform numbers from a uniform to a normal distribution. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Generate a real random number from a uniform (0,1) distribution */
+
+ /* Parameter adjustments */
+ --iseed;
+
+ /* Function Body */
+ t1 = dlaran_(&iseed[1]);
+
+ if (*idist == 1) {
+
+/* uniform (0,1) */
+
+ ret_val = t1;
+ } else if (*idist == 2) {
+
+/* uniform (-1,1) */
+
+ ret_val = t1 * 2. - 1.;
+ } else if (*idist == 3) {
+
+/* normal (0,1) */
+
+ t2 = dlaran_(&iseed[1]);
+ ret_val = sqrt(log(t1) * -2.) * cos(t2 *
+ 6.2831853071795864769252867663);
+ }
+ return ret_val;
+
+/* End of DLARND */
+
+} /* dlarnd_ */
diff --git a/TESTING/MATGEN/dlaror.c b/TESTING/MATGEN/dlaror.c
new file mode 100644
index 0000000..680ec3d
--- /dev/null
+++ b/TESTING/MATGEN/dlaror.c
@@ -0,0 +1,302 @@
+/* dlaror.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b9 = 0.;
+static doublereal c_b10 = 1.;
+static integer c__3 = 3;
+static integer c__1 = 1;
+
+/* Subroutine */ int dlaror_(char *side, char *init, integer *m, integer *n,
+ doublereal *a, integer *lda, integer *iseed, doublereal *x, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double d_sign(doublereal *, doublereal *);
+
+ /* Local variables */
+ integer j, kbeg;
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer jcol, irow;
+ extern doublereal dnrm2_(integer *, doublereal *, integer *);
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ integer ixfrm, itype, nxfrm;
+ doublereal xnorm;
+ extern doublereal dlarnd_(integer *, integer *);
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *);
+ doublereal factor, xnorms;
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAROR pre- or post-multiplies an M by N matrix A by a random */
+/* orthogonal matrix U, overwriting A. A may optionally be initialized */
+/* to the identity matrix before multiplying by U. U is generated using */
+/* the method of G.W. Stewart (SIAM J. Numer. Anal. 17, 1980, 403-409). */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* Specifies whether A is multiplied on the left or right by U. */
+/* = 'L': Multiply A on the left (premultiply) by U */
+/* = 'R': Multiply A on the right (postmultiply) by U' */
+/* = 'C' or 'T': Multiply A on the left by U and the right */
+/* by U' (Here, U' means U-transpose.) */
+
+/* INIT (input) CHARACTER*1 */
+/* Specifies whether or not A should be initialized to the */
+/* identity matrix. */
+/* = 'I': Initialize A to (a section of) the identity matrix */
+/* before applying U. */
+/* = 'N': No initialization. Apply U to the input matrix A. */
+
+/* INIT = 'I' may be used to generate square or rectangular */
+/* orthogonal matrices: */
+
+/* For M = N and SIDE = 'L' or 'R', the rows will be orthogonal */
+/* to each other, as will the columns. */
+
+/* If M < N, SIDE = 'R' produces a dense matrix whose rows are */
+/* orthogonal and whose columns are not, while SIDE = 'L' */
+/* produces a matrix whose rows are orthogonal, and whose first */
+/* M columns are orthogonal, and whose remaining columns are */
+/* zero. */
+
+/* If M > N, SIDE = 'L' produces a dense matrix whose columns */
+/* are orthogonal and whose rows are not, while SIDE = 'R' */
+/* produces a matrix whose columns are orthogonal, and whose */
+/* first M rows are orthogonal, and whose remaining rows are */
+/* zero. */
+
+/* M (input) INTEGER */
+/* The number of rows of A. */
+
+/* N (input) INTEGER */
+/* The number of columns of A. */
+
+/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
+/* On entry, the array A. */
+/* On exit, overwritten by U A ( if SIDE = 'L' ), */
+/* or by A U ( if SIDE = 'R' ), */
+/* or by U A U' ( if SIDE = 'C' or 'T'). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to DLAROR to continue the same random number */
+/* sequence. */
+
+/* X (workspace) DOUBLE PRECISION array, dimension (3*MAX( M, N )) */
+/* Workspace of length */
+/* 2*M + N if SIDE = 'L', */
+/* 2*N + M if SIDE = 'R', */
+/* 3*N if SIDE = 'C' or 'T'. */
+
+/* INFO (output) INTEGER */
+/* An error flag. It is set to: */
+/* = 0: normal return */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* = 1: if the random numbers generated by DLARND are bad. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iseed;
+ --x;
+
+ /* Function Body */
+ if (*n == 0 || *m == 0) {
+ return 0;
+ }
+
+ itype = 0;
+ if (lsame_(side, "L")) {
+ itype = 1;
+ } else if (lsame_(side, "R")) {
+ itype = 2;
+ } else if (lsame_(side, "C") || lsame_(side, "T")) {
+ itype = 3;
+ }
+
+/* Check for argument errors. */
+
+ *info = 0;
+ if (itype == 0) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0 || itype == 3 && *n != *m) {
+ *info = -4;
+ } else if (*lda < *m) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLAROR", &i__1);
+ return 0;
+ }
+
+ if (itype == 1) {
+ nxfrm = *m;
+ } else {
+ nxfrm = *n;
+ }
+
+/* Initialize A to the identity matrix if desired */
+
+ if (lsame_(init, "I")) {
+ dlaset_("Full", m, n, &c_b9, &c_b10, &a[a_offset], lda);
+ }
+
+/* If no rotation possible, multiply by random +/-1 */
+
+/* Compute rotation by computing Householder transformations */
+/* H(2), H(3), ..., H(nhouse) */
+
+ i__1 = nxfrm;
+ for (j = 1; j <= i__1; ++j) {
+ x[j] = 0.;
+/* L10: */
+ }
+
+ i__1 = nxfrm;
+ for (ixfrm = 2; ixfrm <= i__1; ++ixfrm) {
+ kbeg = nxfrm - ixfrm + 1;
+
+/* Generate independent normal( 0, 1 ) random numbers */
+
+ i__2 = nxfrm;
+ for (j = kbeg; j <= i__2; ++j) {
+ x[j] = dlarnd_(&c__3, &iseed[1]);
+/* L20: */
+ }
+
+/* Generate a Householder transformation from the random vector X */
+
+ xnorm = dnrm2_(&ixfrm, &x[kbeg], &c__1);
+ xnorms = d_sign(&xnorm, &x[kbeg]);
+ d__1 = -x[kbeg];
+ x[kbeg + nxfrm] = d_sign(&c_b10, &d__1);
+ factor = xnorms * (xnorms + x[kbeg]);
+ if (abs(factor) < 1e-20) {
+ *info = 1;
+ xerbla_("DLAROR", info);
+ return 0;
+ } else {
+ factor = 1. / factor;
+ }
+ x[kbeg] += xnorms;
+
+/* Apply Householder transformation to A */
+
+ if (itype == 1 || itype == 3) {
+
+/* Apply H(k) from the left. */
+
+ dgemv_("T", &ixfrm, n, &c_b10, &a[kbeg + a_dim1], lda, &x[kbeg], &
+ c__1, &c_b9, &x[(nxfrm << 1) + 1], &c__1);
+ d__1 = -factor;
+ dger_(&ixfrm, n, &d__1, &x[kbeg], &c__1, &x[(nxfrm << 1) + 1], &
+ c__1, &a[kbeg + a_dim1], lda);
+
+ }
+
+ if (itype == 2 || itype == 3) {
+
+/* Apply H(k) from the right. */
+
+ dgemv_("N", m, &ixfrm, &c_b10, &a[kbeg * a_dim1 + 1], lda, &x[
+ kbeg], &c__1, &c_b9, &x[(nxfrm << 1) + 1], &c__1);
+ d__1 = -factor;
+ dger_(m, &ixfrm, &d__1, &x[(nxfrm << 1) + 1], &c__1, &x[kbeg], &
+ c__1, &a[kbeg * a_dim1 + 1], lda);
+
+ }
+/* L30: */
+ }
+
+ d__1 = dlarnd_(&c__3, &iseed[1]);
+ x[nxfrm * 2] = d_sign(&c_b10, &d__1);
+
+/* Scale the matrix A by D. */
+
+ if (itype == 1 || itype == 3) {
+ i__1 = *m;
+ for (irow = 1; irow <= i__1; ++irow) {
+ dscal_(n, &x[nxfrm + irow], &a[irow + a_dim1], lda);
+/* L40: */
+ }
+ }
+
+ if (itype == 2 || itype == 3) {
+ i__1 = *n;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ dscal_(m, &x[nxfrm + jcol], &a[jcol * a_dim1 + 1], &c__1);
+/* L50: */
+ }
+ }
+ return 0;
+
+/* End of DLAROR */
+
+} /* dlaror_ */
diff --git a/TESTING/MATGEN/dlarot.c b/TESTING/MATGEN/dlarot.c
new file mode 100644
index 0000000..153624c
--- /dev/null
+++ b/TESTING/MATGEN/dlarot.c
@@ -0,0 +1,308 @@
+/* dlarot.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__4 = 4;
+static integer c__8 = 8;
+static integer c__1 = 1;
+
+/* Subroutine */ int dlarot_(logical *lrows, logical *lleft, logical *lright,
+ integer *nl, doublereal *c__, doublereal *s, doublereal *a, integer *
+ lda, doublereal *xleft, doublereal *xright)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer ix, iy, nt;
+ doublereal xt[2], yt[2];
+ integer iyt, iinc;
+ extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *);
+ integer inext;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLAROT applies a (Givens) rotation to two adjacent rows or */
+/* columns, where one element of the first and/or last column/row */
+/* for use on matrices stored in some format other than GE, so */
+/* that elements of the matrix may be used or modified for which */
+/* no array element is provided. */
+
+/* One example is a symmetric matrix in SB format (bandwidth=4), for */
+/* which UPLO='L': Two adjacent rows will have the format: */
+
+/* row j: * * * * * . . . . */
+/* row j+1: * * * * * . . . . */
+
+/* '*' indicates elements for which storage is provided, */
+/* '.' indicates elements for which no storage is provided, but */
+/* are not necessarily zero; their values are determined by */
+/* symmetry. ' ' indicates elements which are necessarily zero, */
+/* and have no storage provided. */
+
+/* Those columns which have two '*'s can be handled by DROT. */
+/* Those columns which have no '*'s can be ignored, since as long */
+/* as the Givens rotations are carefully applied to preserve */
+/* symmetry, their values are determined. */
+/* Those columns which have one '*' have to be handled separately, */
+/* by using separate variables "p" and "q": */
+
+/* row j: * * * * * p . . . */
+/* row j+1: q * * * * * . . . . */
+
+/* The element p would have to be set correctly, then that column */
+/* is rotated, setting p to its new value. The next call to */
+/* DLAROT would rotate columns j and j+1, using p, and restore */
+/* symmetry. The element q would start out being zero, and be */
+/* made non-zero by the rotation. Later, rotations would presumably */
+/* be chosen to zero q out. */
+
+/* Typical Calling Sequences: rotating the i-th and (i+1)-st rows. */
+/* ------- ------- --------- */
+
+/* General dense matrix: */
+
+/* CALL DLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S, */
+/* A(i,1),LDA, DUMMY, DUMMY) */
+
+/* General banded matrix in GB format: */
+
+/* j = MAX(1, i-KL ) */
+/* NL = MIN( N, i+KU+1 ) + 1-j */
+/* CALL DLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S, */
+/* A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT ) */
+
+/* [ note that i+1-j is just MIN(i,KL+1) ] */
+
+/* Symmetric banded matrix in SY format, bandwidth K, */
+/* lower triangle only: */
+
+/* j = MAX(1, i-K ) */
+/* NL = MIN( K+1, i ) + 1 */
+/* CALL DLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S, */
+/* A(i,j), LDA, XLEFT, XRIGHT ) */
+
+/* Same, but upper triangle only: */
+
+/* NL = MIN( K+1, N-i ) + 1 */
+/* CALL DLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S, */
+/* A(i,i), LDA, XLEFT, XRIGHT ) */
+
+/* Symmetric banded matrix in SB format, bandwidth K, */
+/* lower triangle only: */
+
+/* [ same as for SY, except:] */
+/* . . . . */
+/* A(i+1-j,j), LDA-1, XLEFT, XRIGHT ) */
+
+/* [ note that i+1-j is just MIN(i,K+1) ] */
+
+/* Same, but upper triangle only: */
+/* . . . */
+/* A(K+1,i), LDA-1, XLEFT, XRIGHT ) */
+
+/* Rotating columns is just the transpose of rotating rows, except */
+/* for GB and SB: (rotating columns i and i+1) */
+
+/* GB: */
+/* j = MAX(1, i-KU ) */
+/* NL = MIN( N, i+KL+1 ) + 1-j */
+/* CALL DLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S, */
+/* A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM ) */
+
+/* [note that KU+j+1-i is just MAX(1,KU+2-i)] */
+
+/* SB: (upper triangle) */
+
+/* . . . . . . */
+/* A(K+j+1-i,i),LDA-1, XTOP, XBOTTM ) */
+
+/* SB: (lower triangle) */
+
+/* . . . . . . */
+/* A(1,i),LDA-1, XTOP, XBOTTM ) */
+
+/* Arguments */
+/* ========= */
+
+/* LROWS - LOGICAL */
+/* If .TRUE., then DLAROT will rotate two rows. If .FALSE., */
+/* then it will rotate two columns. */
+/* Not modified. */
+
+/* LLEFT - LOGICAL */
+/* If .TRUE., then XLEFT will be used instead of the */
+/* corresponding element of A for the first element in the */
+/* second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) */
+/* If .FALSE., then the corresponding element of A will be */
+/* used. */
+/* Not modified. */
+
+/* LRIGHT - LOGICAL */
+/* If .TRUE., then XRIGHT will be used instead of the */
+/* corresponding element of A for the last element in the */
+/* first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If */
+/* .FALSE., then the corresponding element of A will be used. */
+/* Not modified. */
+
+/* NL - INTEGER */
+/* The length of the rows (if LROWS=.TRUE.) or columns (if */
+/* LROWS=.FALSE.) to be rotated. If XLEFT and/or XRIGHT are */
+/* used, the columns/rows they are in should be included in */
+/* NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at */
+/* least 2. The number of rows/columns to be rotated */
+/* exclusive of those involving XLEFT and/or XRIGHT may */
+/* not be negative, i.e., NL minus how many of LLEFT and */
+/* LRIGHT are .TRUE. must be at least zero; if not, XERBLA */
+/* will be called. */
+/* Not modified. */
+
+/* C, S - DOUBLE PRECISION */
+/* Specify the Givens rotation to be applied. If LROWS is */
+/* true, then the matrix ( c s ) */
+/* (-s c ) is applied from the left; */
+/* if false, then the transpose thereof is applied from the */
+/* right. For a Givens rotation, C**2 + S**2 should be 1, */
+/* but this is not checked. */
+/* Not modified. */
+
+/* A - DOUBLE PRECISION array. */
+/* The array containing the rows/columns to be rotated. The */
+/* first element of A should be the upper left element to */
+/* be rotated. */
+/* Read and modified. */
+
+/* LDA - INTEGER */
+/* The "effective" leading dimension of A. If A contains */
+/* a matrix stored in GE or SY format, then this is just */
+/* the leading dimension of A as dimensioned in the calling */
+/* routine. If A contains a matrix stored in band (GB or SB) */
+/* format, then this should be *one less* than the leading */
+/* dimension used in the calling routine. Thus, if */
+/* A were dimensioned A(LDA,*) in DLAROT, then A(1,j) would */
+/* be the j-th element in the first of the two rows */
+/* to be rotated, and A(2,j) would be the j-th in the second, */
+/* regardless of how the array may be stored in the calling */
+/* routine. [A cannot, however, actually be dimensioned thus, */
+/* since for band format, the row number may exceed LDA, which */
+/* is not legal FORTRAN.] */
+/* If LROWS=.TRUE., then LDA must be at least 1, otherwise */
+/* it must be at least NL minus the number of .TRUE. values */
+/* in XLEFT and XRIGHT. */
+/* Not modified. */
+
+/* XLEFT - DOUBLE PRECISION */
+/* If LLEFT is .TRUE., then XLEFT will be used and modified */
+/* instead of A(2,1) (if LROWS=.TRUE.) or A(1,2) */
+/* (if LROWS=.FALSE.). */
+/* Read and modified. */
+
+/* XRIGHT - DOUBLE PRECISION */
+/* If LRIGHT is .TRUE., then XRIGHT will be used and modified */
+/* instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1) */
+/* (if LROWS=.FALSE.). */
+/* Read and modified. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Set up indices, arrays for ends */
+
+ /* Parameter adjustments */
+ --a;
+
+ /* Function Body */
+ if (*lrows) {
+ iinc = *lda;
+ inext = 1;
+ } else {
+ iinc = 1;
+ inext = *lda;
+ }
+
+ if (*lleft) {
+ nt = 1;
+ ix = iinc + 1;
+ iy = *lda + 2;
+ xt[0] = a[1];
+ yt[0] = *xleft;
+ } else {
+ nt = 0;
+ ix = 1;
+ iy = inext + 1;
+ }
+
+ if (*lright) {
+ iyt = inext + 1 + (*nl - 1) * iinc;
+ ++nt;
+ xt[nt - 1] = *xright;
+ yt[nt - 1] = a[iyt];
+ }
+
+/* Check for errors */
+
+ if (*nl < nt) {
+ xerbla_("DLAROT", &c__4);
+ return 0;
+ }
+ if (*lda <= 0 || ! (*lrows) && *lda < *nl - nt) {
+ xerbla_("DLAROT", &c__8);
+ return 0;
+ }
+
+/* Rotate */
+
+ i__1 = *nl - nt;
+ drot_(&i__1, &a[ix], &iinc, &a[iy], &iinc, c__, s);
+ drot_(&nt, xt, &c__1, yt, &c__1, c__, s);
+
+/* Stuff values back into XLEFT, XRIGHT, etc. */
+
+ if (*lleft) {
+ a[1] = xt[0];
+ *xleft = yt[0];
+ }
+
+ if (*lright) {
+ *xright = xt[nt - 1];
+ a[iyt] = yt[nt - 1];
+ }
+
+ return 0;
+
+/* End of DLAROT */
+
+} /* dlarot_ */
diff --git a/TESTING/MATGEN/dlatm1.c b/TESTING/MATGEN/dlatm1.c
new file mode 100644
index 0000000..f36f314
--- /dev/null
+++ b/TESTING/MATGEN/dlatm1.c
@@ -0,0 +1,283 @@
+/* dlatm1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlatm1_(integer *mode, doublereal *cond, integer *irsign,
+ integer *idist, integer *iseed, doublereal *d__, integer *n, integer
+ *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double pow_dd(doublereal *, doublereal *), pow_di(doublereal *, integer *)
+ , log(doublereal), exp(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal temp, alpha;
+ extern doublereal dlaran_(integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), dlarnv_(
+ integer *, integer *, integer *, doublereal *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLATM1 computes the entries of D(1..N) as specified by */
+/* MODE, COND and IRSIGN. IDIST and ISEED determine the generation */
+/* of random numbers. DLATM1 is called by SLATMR to generate */
+/* random test matrices for LAPACK programs. */
+
+/* Arguments */
+/* ========= */
+
+/* MODE - INTEGER */
+/* On entry describes how D is to be computed: */
+/* MODE = 0 means do not change D. */
+/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
+/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
+/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
+/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* MODE = 5 sets D to random numbers in the range */
+/* ( 1/COND , 1 ) such that their logarithms */
+/* are uniformly distributed. */
+/* MODE = 6 set D to random numbers from same distribution */
+/* as the rest of the matrix. */
+/* MODE < 0 has the same meaning as ABS(MODE), except that */
+/* the order of the elements of D is reversed. */
+/* Thus if MODE is positive, D has entries ranging from */
+/* 1 to 1/COND, if negative, from 1/COND to 1, */
+/* Not modified. */
+
+/* COND - DOUBLE PRECISION */
+/* On entry, used as described under MODE above. */
+/* If used, it must be >= 1. Not modified. */
+
+/* IRSIGN - INTEGER */
+/* On entry, if MODE neither -6, 0 nor 6, determines sign of */
+/* entries of D */
+/* 0 => leave entries of D unchanged */
+/* 1 => multiply each entry of D by 1 or -1 with probability .5 */
+
+/* IDIST - CHARACTER*1 */
+/* On entry, IDIST specifies the type of distribution to be */
+/* used to generate a random matrix . */
+/* 1 => UNIFORM( 0, 1 ) */
+/* 2 => UNIFORM( -1, 1 ) */
+/* 3 => NORMAL( 0, 1 ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension ( 4 ) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The random number generator uses a */
+/* linear congruential sequence limited to small */
+/* integers, and so should produce machine independent */
+/* random numbers. The values of ISEED are changed on */
+/* exit, and can be used in the next call to DLATM1 */
+/* to continue the same random number sequence. */
+/* Changed on exit. */
+
+/* D - DOUBLE PRECISION array, dimension ( MIN( M , N ) ) */
+/* Array to be computed according to MODE, COND and IRSIGN. */
+/* May be changed on exit if MODE is nonzero. */
+
+/* N - INTEGER */
+/* Number of entries of D. Not modified. */
+
+/* INFO - INTEGER */
+/* 0 => normal termination */
+/* -1 => if MODE not in range -6 to 6 */
+/* -2 => if MODE neither -6, 0 nor 6, and */
+/* IRSIGN neither 0 nor 1 */
+/* -3 => if MODE neither -6, 0 nor 6 and COND less than 1 */
+/* -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 3 */
+/* -7 => if N negative */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and Test the input parameters. Initialize flags & seed. */
+
+ /* Parameter adjustments */
+ --d__;
+ --iseed;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Set INFO if an error */
+
+ if (*mode < -6 || *mode > 6) {
+ *info = -1;
+ } else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && *
+ irsign != 1)) {
+ *info = -2;
+ } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.) {
+ *info = -3;
+ } else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 3)) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -7;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLATM1", &i__1);
+ return 0;
+ }
+
+/* Compute D according to COND and MODE */
+
+ if (*mode != 0) {
+ switch (abs(*mode)) {
+ case 1: goto L10;
+ case 2: goto L30;
+ case 3: goto L50;
+ case 4: goto L70;
+ case 5: goto L90;
+ case 6: goto L110;
+ }
+
+/* One large D value: */
+
+L10:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = 1. / *cond;
+/* L20: */
+ }
+ d__[1] = 1.;
+ goto L120;
+
+/* One small D value: */
+
+L30:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = 1.;
+/* L40: */
+ }
+ d__[*n] = 1. / *cond;
+ goto L120;
+
+/* Exponentially distributed D values: */
+
+L50:
+ d__[1] = 1.;
+ if (*n > 1) {
+ d__1 = -1. / (doublereal) (*n - 1);
+ alpha = pow_dd(cond, &d__1);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__ - 1;
+ d__[i__] = pow_di(&alpha, &i__2);
+/* L60: */
+ }
+ }
+ goto L120;
+
+/* Arithmetically distributed D values: */
+
+L70:
+ d__[1] = 1.;
+ if (*n > 1) {
+ temp = 1. / *cond;
+ alpha = (1. - temp) / (doublereal) (*n - 1);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ d__[i__] = (doublereal) (*n - i__) * alpha + temp;
+/* L80: */
+ }
+ }
+ goto L120;
+
+/* Randomly distributed D values on ( 1/COND , 1): */
+
+L90:
+ alpha = log(1. / *cond);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = exp(alpha * dlaran_(&iseed[1]));
+/* L100: */
+ }
+ goto L120;
+
+/* Randomly distributed D values from IDIST */
+
+L110:
+ dlarnv_(idist, &iseed[1], n, &d__[1]);
+
+L120:
+
+/* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */
+/* random signs to D */
+
+ if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = dlaran_(&iseed[1]);
+ if (temp > .5) {
+ d__[i__] = -d__[i__];
+ }
+/* L130: */
+ }
+ }
+
+/* Reverse if MODE < 0 */
+
+ if (*mode < 0) {
+ i__1 = *n / 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = d__[i__];
+ d__[i__] = d__[*n + 1 - i__];
+ d__[*n + 1 - i__] = temp;
+/* L140: */
+ }
+ }
+
+ }
+
+ return 0;
+
+/* End of DLATM1 */
+
+} /* dlatm1_ */
diff --git a/TESTING/MATGEN/dlatm2.c b/TESTING/MATGEN/dlatm2.c
new file mode 100644
index 0000000..502a529
--- /dev/null
+++ b/TESTING/MATGEN/dlatm2.c
@@ -0,0 +1,251 @@
+/* dlatm2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dlatm2_(integer *m, integer *n, integer *i__, integer *j, integer *
+ kl, integer *ku, integer *idist, integer *iseed, doublereal *d__,
+ integer *igrade, doublereal *dl, doublereal *dr, integer *ipvtng,
+ integer *iwork, doublereal *sparse)
+{
+ /* System generated locals */
+ doublereal ret_val;
+
+ /* Local variables */
+ integer isub, jsub;
+ doublereal temp;
+ extern doublereal dlaran_(integer *), dlarnd_(integer *, integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+
+/* .. */
+
+/* .. Array Arguments .. */
+
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLATM2 returns the (I,J) entry of a random matrix of dimension */
+/* (M, N) described by the other paramters. It is called by the */
+/* DLATMR routine in order to build random test matrices. No error */
+/* checking on parameters is done, because this routine is called in */
+/* a tight loop by DLATMR which has already checked the parameters. */
+
+/* Use of DLATM2 differs from SLATM3 in the order in which the random */
+/* number generator is called to fill in random matrix entries. */
+/* With DLATM2, the generator is called to fill in the pivoted matrix */
+/* columnwise. With DLATM3, the generator is called to fill in the */
+/* matrix columnwise, after which it is pivoted. Thus, DLATM3 can */
+/* be used to construct random matrices which differ only in their */
+/* order of rows and/or columns. DLATM2 is used to construct band */
+/* matrices while avoiding calling the random number generator for */
+/* entries outside the band (and therefore generating random numbers */
+
+/* The matrix whose (I,J) entry is returned is constructed as */
+/* follows (this routine only computes one entry): */
+
+/* If I is outside (1..M) or J is outside (1..N), return zero */
+/* (this is convenient for generating matrices in band format). */
+
+/* Generate a matrix A with random entries of distribution IDIST. */
+
+/* Set the diagonal to D. */
+
+/* Grade the matrix, if desired, from the left (by DL) and/or */
+/* from the right (by DR or DL) as specified by IGRADE. */
+
+/* Permute, if desired, the rows and/or columns as specified by */
+/* IPVTNG and IWORK. */
+
+/* Band the matrix to have lower bandwidth KL and upper */
+/* bandwidth KU. */
+
+/* Set random entries to zero as specified by SPARSE. */
+
+/* Arguments */
+/* ========= */
+
+/* M - INTEGER */
+/* Number of rows of matrix. Not modified. */
+
+/* N - INTEGER */
+/* Number of columns of matrix. Not modified. */
+
+/* I - INTEGER */
+/* Row of entry to be returned. Not modified. */
+
+/* J - INTEGER */
+/* Column of entry to be returned. Not modified. */
+
+/* KL - INTEGER */
+/* Lower bandwidth. Not modified. */
+
+/* KU - INTEGER */
+/* Upper bandwidth. Not modified. */
+
+/* IDIST - INTEGER */
+/* On entry, IDIST specifies the type of distribution to be */
+/* used to generate a random matrix . */
+/* 1 => UNIFORM( 0, 1 ) */
+/* 2 => UNIFORM( -1, 1 ) */
+/* 3 => NORMAL( 0, 1 ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array of dimension ( 4 ) */
+/* Seed for random number generator. */
+/* Changed on exit. */
+
+/* D - DOUBLE PRECISION array of dimension ( MIN( I , J ) ) */
+/* Diagonal entries of matrix. Not modified. */
+
+/* IGRADE - INTEGER */
+/* Specifies grading of matrix as follows: */
+/* 0 => no grading */
+/* 1 => matrix premultiplied by diag( DL ) */
+/* 2 => matrix postmultiplied by diag( DR ) */
+/* 3 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DR ) */
+/* 4 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by inv( diag( DL ) ) */
+/* 5 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DL ) */
+/* Not modified. */
+
+/* DL - DOUBLE PRECISION array ( I or J, as appropriate ) */
+/* Left scale factors for grading matrix. Not modified. */
+
+/* DR - DOUBLE PRECISION array ( I or J, as appropriate ) */
+/* Right scale factors for grading matrix. Not modified. */
+
+/* IPVTNG - INTEGER */
+/* On entry specifies pivoting permutations as follows: */
+/* 0 => none. */
+/* 1 => row pivoting. */
+/* 2 => column pivoting. */
+/* 3 => full pivoting, i.e., on both sides. */
+/* Not modified. */
+
+/* IWORK - INTEGER array ( I or J, as appropriate ) */
+/* This array specifies the permutation used. The */
+/* row (or column) in position K was originally in */
+/* position IWORK( K ). */
+/* This differs from IWORK for DLATM3. Not modified. */
+
+/* SPARSE - DOUBLE PRECISION between 0. and 1. */
+/* On entry specifies the sparsity of the matrix */
+/* if sparse matix is to be generated. */
+/* SPARSE should lie between 0 and 1. */
+/* A uniform ( 0, 1 ) random number x is generated and */
+/* compared to SPARSE; if x is larger the matrix entry */
+/* is unchanged and if x is smaller the entry is set */
+/* to zero. Thus on the average a fraction SPARSE of the */
+/* entries will be set to zero. */
+/* Not modified. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+
+/* .. */
+
+/* .. Local Scalars .. */
+
+/* .. */
+
+/* .. External Functions .. */
+
+/* .. */
+
+/* ----------------------------------------------------------------------- */
+
+/* .. Executable Statements .. */
+
+
+/* Check for I and J in range */
+
+ /* Parameter adjustments */
+ --iwork;
+ --dr;
+ --dl;
+ --d__;
+ --iseed;
+
+ /* Function Body */
+ if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) {
+ ret_val = 0.;
+ return ret_val;
+ }
+
+/* Check for banding */
+
+ if (*j > *i__ + *ku || *j < *i__ - *kl) {
+ ret_val = 0.;
+ return ret_val;
+ }
+
+/* Check for sparsity */
+
+ if (*sparse > 0.) {
+ if (dlaran_(&iseed[1]) < *sparse) {
+ ret_val = 0.;
+ return ret_val;
+ }
+ }
+
+/* Compute subscripts depending on IPVTNG */
+
+ if (*ipvtng == 0) {
+ isub = *i__;
+ jsub = *j;
+ } else if (*ipvtng == 1) {
+ isub = iwork[*i__];
+ jsub = *j;
+ } else if (*ipvtng == 2) {
+ isub = *i__;
+ jsub = iwork[*j];
+ } else if (*ipvtng == 3) {
+ isub = iwork[*i__];
+ jsub = iwork[*j];
+ }
+
+/* Compute entry and grade it according to IGRADE */
+
+ if (isub == jsub) {
+ temp = d__[isub];
+ } else {
+ temp = dlarnd_(idist, &iseed[1]);
+ }
+ if (*igrade == 1) {
+ temp *= dl[isub];
+ } else if (*igrade == 2) {
+ temp *= dr[jsub];
+ } else if (*igrade == 3) {
+ temp = temp * dl[isub] * dr[jsub];
+ } else if (*igrade == 4 && isub != jsub) {
+ temp = temp * dl[isub] / dl[jsub];
+ } else if (*igrade == 5) {
+ temp = temp * dl[isub] * dl[jsub];
+ }
+ ret_val = temp;
+ return ret_val;
+
+/* End of DLATM2 */
+
+} /* dlatm2_ */
diff --git a/TESTING/MATGEN/dlatm3.c b/TESTING/MATGEN/dlatm3.c
new file mode 100644
index 0000000..2ddef32
--- /dev/null
+++ b/TESTING/MATGEN/dlatm3.c
@@ -0,0 +1,261 @@
+/* dlatm3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dlatm3_(integer *m, integer *n, integer *i__, integer *j, integer *
+ isub, integer *jsub, integer *kl, integer *ku, integer *idist,
+ integer *iseed, doublereal *d__, integer *igrade, doublereal *dl,
+ doublereal *dr, integer *ipvtng, integer *iwork, doublereal *sparse)
+{
+ /* System generated locals */
+ doublereal ret_val;
+
+ /* Local variables */
+ doublereal temp;
+ extern doublereal dlaran_(integer *), dlarnd_(integer *, integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+
+/* .. */
+
+/* .. Array Arguments .. */
+
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLATM3 returns the (ISUB,JSUB) entry of a random matrix of */
+/* dimension (M, N) described by the other paramters. (ISUB,JSUB) */
+/* is the final position of the (I,J) entry after pivoting */
+/* according to IPVTNG and IWORK. DLATM3 is called by the */
+/* DLATMR routine in order to build random test matrices. No error */
+/* checking on parameters is done, because this routine is called in */
+/* a tight loop by DLATMR which has already checked the parameters. */
+
+/* Use of DLATM3 differs from SLATM2 in the order in which the random */
+/* number generator is called to fill in random matrix entries. */
+/* With DLATM2, the generator is called to fill in the pivoted matrix */
+/* columnwise. With DLATM3, the generator is called to fill in the */
+/* matrix columnwise, after which it is pivoted. Thus, DLATM3 can */
+/* be used to construct random matrices which differ only in their */
+/* order of rows and/or columns. DLATM2 is used to construct band */
+/* matrices while avoiding calling the random number generator for */
+/* entries outside the band (and therefore generating random numbers */
+/* in different orders for different pivot orders). */
+
+/* The matrix whose (ISUB,JSUB) entry is returned is constructed as */
+/* follows (this routine only computes one entry): */
+
+/* If ISUB is outside (1..M) or JSUB is outside (1..N), return zero */
+/* (this is convenient for generating matrices in band format). */
+
+/* Generate a matrix A with random entries of distribution IDIST. */
+
+/* Set the diagonal to D. */
+
+/* Grade the matrix, if desired, from the left (by DL) and/or */
+/* from the right (by DR or DL) as specified by IGRADE. */
+
+/* Permute, if desired, the rows and/or columns as specified by */
+/* IPVTNG and IWORK. */
+
+/* Band the matrix to have lower bandwidth KL and upper */
+/* bandwidth KU. */
+
+/* Set random entries to zero as specified by SPARSE. */
+
+/* Arguments */
+/* ========= */
+
+/* M - INTEGER */
+/* Number of rows of matrix. Not modified. */
+
+/* N - INTEGER */
+/* Number of columns of matrix. Not modified. */
+
+/* I - INTEGER */
+/* Row of unpivoted entry to be returned. Not modified. */
+
+/* J - INTEGER */
+/* Column of unpivoted entry to be returned. Not modified. */
+
+/* ISUB - INTEGER */
+/* Row of pivoted entry to be returned. Changed on exit. */
+
+/* JSUB - INTEGER */
+/* Column of pivoted entry to be returned. Changed on exit. */
+
+/* KL - INTEGER */
+/* Lower bandwidth. Not modified. */
+
+/* KU - INTEGER */
+/* Upper bandwidth. Not modified. */
+
+/* IDIST - INTEGER */
+/* On entry, IDIST specifies the type of distribution to be */
+/* used to generate a random matrix . */
+/* 1 => UNIFORM( 0, 1 ) */
+/* 2 => UNIFORM( -1, 1 ) */
+/* 3 => NORMAL( 0, 1 ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array of dimension ( 4 ) */
+/* Seed for random number generator. */
+/* Changed on exit. */
+
+/* D - DOUBLE PRECISION array of dimension ( MIN( I , J ) ) */
+/* Diagonal entries of matrix. Not modified. */
+
+/* IGRADE - INTEGER */
+/* Specifies grading of matrix as follows: */
+/* 0 => no grading */
+/* 1 => matrix premultiplied by diag( DL ) */
+/* 2 => matrix postmultiplied by diag( DR ) */
+/* 3 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DR ) */
+/* 4 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by inv( diag( DL ) ) */
+/* 5 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DL ) */
+/* Not modified. */
+
+/* DL - DOUBLE PRECISION array ( I or J, as appropriate ) */
+/* Left scale factors for grading matrix. Not modified. */
+
+/* DR - DOUBLE PRECISION array ( I or J, as appropriate ) */
+/* Right scale factors for grading matrix. Not modified. */
+
+/* IPVTNG - INTEGER */
+/* On entry specifies pivoting permutations as follows: */
+/* 0 => none. */
+/* 1 => row pivoting. */
+/* 2 => column pivoting. */
+/* 3 => full pivoting, i.e., on both sides. */
+/* Not modified. */
+
+/* IWORK - INTEGER array ( I or J, as appropriate ) */
+/* This array specifies the permutation used. The */
+/* row (or column) originally in position K is in */
+/* position IWORK( K ) after pivoting. */
+/* This differs from IWORK for DLATM2. Not modified. */
+
+/* SPARSE - DOUBLE PRECISION between 0. and 1. */
+/* On entry specifies the sparsity of the matrix */
+/* if sparse matix is to be generated. */
+/* SPARSE should lie between 0 and 1. */
+/* A uniform ( 0, 1 ) random number x is generated and */
+/* compared to SPARSE; if x is larger the matrix entry */
+/* is unchanged and if x is smaller the entry is set */
+/* to zero. Thus on the average a fraction SPARSE of the */
+/* entries will be set to zero. */
+/* Not modified. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+
+/* .. */
+
+/* .. Local Scalars .. */
+
+/* .. */
+
+/* .. External Functions .. */
+
+/* .. */
+
+/* ----------------------------------------------------------------------- */
+
+/* .. Executable Statements .. */
+
+
+/* Check for I and J in range */
+
+ /* Parameter adjustments */
+ --iwork;
+ --dr;
+ --dl;
+ --d__;
+ --iseed;
+
+ /* Function Body */
+ if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) {
+ *isub = *i__;
+ *jsub = *j;
+ ret_val = 0.;
+ return ret_val;
+ }
+
+/* Compute subscripts depending on IPVTNG */
+
+ if (*ipvtng == 0) {
+ *isub = *i__;
+ *jsub = *j;
+ } else if (*ipvtng == 1) {
+ *isub = iwork[*i__];
+ *jsub = *j;
+ } else if (*ipvtng == 2) {
+ *isub = *i__;
+ *jsub = iwork[*j];
+ } else if (*ipvtng == 3) {
+ *isub = iwork[*i__];
+ *jsub = iwork[*j];
+ }
+
+/* Check for banding */
+
+ if (*jsub > *isub + *ku || *jsub < *isub - *kl) {
+ ret_val = 0.;
+ return ret_val;
+ }
+
+/* Check for sparsity */
+
+ if (*sparse > 0.) {
+ if (dlaran_(&iseed[1]) < *sparse) {
+ ret_val = 0.;
+ return ret_val;
+ }
+ }
+
+/* Compute entry and grade it according to IGRADE */
+
+ if (*i__ == *j) {
+ temp = d__[*i__];
+ } else {
+ temp = dlarnd_(idist, &iseed[1]);
+ }
+ if (*igrade == 1) {
+ temp *= dl[*i__];
+ } else if (*igrade == 2) {
+ temp *= dr[*j];
+ } else if (*igrade == 3) {
+ temp = temp * dl[*i__] * dr[*j];
+ } else if (*igrade == 4 && *i__ != *j) {
+ temp = temp * dl[*i__] / dl[*j];
+ } else if (*igrade == 5) {
+ temp = temp * dl[*i__] * dl[*j];
+ }
+ ret_val = temp;
+ return ret_val;
+
+/* End of DLATM3 */
+
+} /* dlatm3_ */
diff --git a/TESTING/MATGEN/dlatm5.c b/TESTING/MATGEN/dlatm5.c
new file mode 100644
index 0000000..890d9bb
--- /dev/null
+++ b/TESTING/MATGEN/dlatm5.c
@@ -0,0 +1,516 @@
+/* dlatm5.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b29 = 1.;
+static doublereal c_b30 = 0.;
+static doublereal c_b33 = -1.;
+
+/* Subroutine */ int dlatm5_(integer *prtype, integer *m, integer *n,
+ doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
+ c__, integer *ldc, doublereal *d__, integer *ldd, doublereal *e,
+ integer *lde, doublereal *f, integer *ldf, doublereal *r__, integer *
+ ldr, doublereal *l, integer *ldl, doublereal *alpha, integer *qblcka,
+ integer *qblckb)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
+ d_offset, e_dim1, e_offset, f_dim1, f_offset, l_dim1, l_offset,
+ r_dim1, r_offset, i__1, i__2;
+
+ /* Builtin functions */
+ double sin(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
+ integer *, doublereal *, doublereal *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, integer *);
+ doublereal imeps, reeps;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLATM5 generates matrices involved in the Generalized Sylvester */
+/* equation: */
+
+/* A * R - L * B = C */
+/* D * R - L * E = F */
+
+/* They also satisfy (the diagonalization condition) */
+
+/* [ I -L ] ( [ A -C ], [ D -F ] ) [ I R ] = ( [ A ], [ D ] ) */
+/* [ I ] ( [ B ] [ E ] ) [ I ] ( [ B ] [ E ] ) */
+
+
+/* Arguments */
+/* ========= */
+
+/* PRTYPE (input) INTEGER */
+/* "Points" to a certian type of the matrices to generate */
+/* (see futher details). */
+
+/* M (input) INTEGER */
+/* Specifies the order of A and D and the number of rows in */
+/* C, F, R and L. */
+
+/* N (input) INTEGER */
+/* Specifies the order of B and E and the number of columns in */
+/* C, F, R and L. */
+
+/* A (output) DOUBLE PRECISION array, dimension (LDA, M). */
+/* On exit A M-by-M is initialized according to PRTYPE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. */
+
+/* B (output) DOUBLE PRECISION array, dimension (LDB, N). */
+/* On exit B N-by-N is initialized according to PRTYPE. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. */
+
+/* C (output) DOUBLE PRECISION array, dimension (LDC, N). */
+/* On exit C M-by-N is initialized according to PRTYPE. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of C. */
+
+/* D (output) DOUBLE PRECISION array, dimension (LDD, M). */
+/* On exit D M-by-M is initialized according to PRTYPE. */
+
+/* LDD (input) INTEGER */
+/* The leading dimension of D. */
+
+/* E (output) DOUBLE PRECISION array, dimension (LDE, N). */
+/* On exit E N-by-N is initialized according to PRTYPE. */
+
+/* LDE (input) INTEGER */
+/* The leading dimension of E. */
+
+/* F (output) DOUBLE PRECISION array, dimension (LDF, N). */
+/* On exit F M-by-N is initialized according to PRTYPE. */
+
+/* LDF (input) INTEGER */
+/* The leading dimension of F. */
+
+/* R (output) DOUBLE PRECISION array, dimension (LDR, N). */
+/* On exit R M-by-N is initialized according to PRTYPE. */
+
+/* LDR (input) INTEGER */
+/* The leading dimension of R. */
+
+/* L (output) DOUBLE PRECISION array, dimension (LDL, N). */
+/* On exit L M-by-N is initialized according to PRTYPE. */
+
+/* LDL (input) INTEGER */
+/* The leading dimension of L. */
+
+/* ALPHA (input) DOUBLE PRECISION */
+/* Parameter used in generating PRTYPE = 1 and 5 matrices. */
+
+/* QBLCKA (input) INTEGER */
+/* When PRTYPE = 3, specifies the distance between 2-by-2 */
+/* blocks on the diagonal in A. Otherwise, QBLCKA is not */
+/* referenced. QBLCKA > 1. */
+
+/* QBLCKB (input) INTEGER */
+/* When PRTYPE = 3, specifies the distance between 2-by-2 */
+/* blocks on the diagonal in B. Otherwise, QBLCKB is not */
+/* referenced. QBLCKB > 1. */
+
+
+/* Further Details */
+/* =============== */
+
+/* PRTYPE = 1: A and B are Jordan blocks, D and E are identity matrices */
+
+/* A : if (i == j) then A(i, j) = 1.0 */
+/* if (j == i + 1) then A(i, j) = -1.0 */
+/* else A(i, j) = 0.0, i, j = 1...M */
+
+/* B : if (i == j) then B(i, j) = 1.0 - ALPHA */
+/* if (j == i + 1) then B(i, j) = 1.0 */
+/* else B(i, j) = 0.0, i, j = 1...N */
+
+/* D : if (i == j) then D(i, j) = 1.0 */
+/* else D(i, j) = 0.0, i, j = 1...M */
+
+/* E : if (i == j) then E(i, j) = 1.0 */
+/* else E(i, j) = 0.0, i, j = 1...N */
+
+/* L = R are chosen from [-10...10], */
+/* which specifies the right hand sides (C, F). */
+
+/* PRTYPE = 2 or 3: Triangular and/or quasi- triangular. */
+
+/* A : if (i <= j) then A(i, j) = [-1...1] */
+/* else A(i, j) = 0.0, i, j = 1...M */
+
+/* if (PRTYPE = 3) then */
+/* A(k + 1, k + 1) = A(k, k) */
+/* A(k + 1, k) = [-1...1] */
+/* sign(A(k, k + 1) = -(sin(A(k + 1, k)) */
+/* k = 1, M - 1, QBLCKA */
+
+/* B : if (i <= j) then B(i, j) = [-1...1] */
+/* else B(i, j) = 0.0, i, j = 1...N */
+
+/* if (PRTYPE = 3) then */
+/* B(k + 1, k + 1) = B(k, k) */
+/* B(k + 1, k) = [-1...1] */
+/* sign(B(k, k + 1) = -(sign(B(k + 1, k)) */
+/* k = 1, N - 1, QBLCKB */
+
+/* D : if (i <= j) then D(i, j) = [-1...1]. */
+/* else D(i, j) = 0.0, i, j = 1...M */
+
+
+/* E : if (i <= j) then D(i, j) = [-1...1] */
+/* else E(i, j) = 0.0, i, j = 1...N */
+
+/* L, R are chosen from [-10...10], */
+/* which specifies the right hand sides (C, F). */
+
+/* PRTYPE = 4 Full */
+/* A(i, j) = [-10...10] */
+/* D(i, j) = [-1...1] i,j = 1...M */
+/* B(i, j) = [-10...10] */
+/* E(i, j) = [-1...1] i,j = 1...N */
+/* R(i, j) = [-10...10] */
+/* L(i, j) = [-1...1] i = 1..M ,j = 1...N */
+
+/* L, R specifies the right hand sides (C, F). */
+
+/* PRTYPE = 5 special case common and/or close eigs. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ d_dim1 = *ldd;
+ d_offset = 1 + d_dim1;
+ d__ -= d_offset;
+ e_dim1 = *lde;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ f_dim1 = *ldf;
+ f_offset = 1 + f_dim1;
+ f -= f_offset;
+ r_dim1 = *ldr;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ l_dim1 = *ldl;
+ l_offset = 1 + l_dim1;
+ l -= l_offset;
+
+ /* Function Body */
+ if (*prtype == 1) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *m;
+ for (j = 1; j <= i__2; ++j) {
+ if (i__ == j) {
+ a[i__ + j * a_dim1] = 1.;
+ d__[i__ + j * d_dim1] = 1.;
+ } else if (i__ == j - 1) {
+ a[i__ + j * a_dim1] = -1.;
+ d__[i__ + j * d_dim1] = 0.;
+ } else {
+ a[i__ + j * a_dim1] = 0.;
+ d__[i__ + j * d_dim1] = 0.;
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (i__ == j) {
+ b[i__ + j * b_dim1] = 1. - *alpha;
+ e[i__ + j * e_dim1] = 1.;
+ } else if (i__ == j - 1) {
+ b[i__ + j * b_dim1] = 1.;
+ e[i__ + j * e_dim1] = 0.;
+ } else {
+ b[i__ + j * b_dim1] = 0.;
+ e[i__ + j * e_dim1] = 0.;
+ }
+/* L30: */
+ }
+/* L40: */
+ }
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ r__[i__ + j * r_dim1] = (.5 - sin((doublereal) (i__ / j))) *
+ 20.;
+ l[i__ + j * l_dim1] = r__[i__ + j * r_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+
+ } else if (*prtype == 2 || *prtype == 3) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *m;
+ for (j = 1; j <= i__2; ++j) {
+ if (i__ <= j) {
+ a[i__ + j * a_dim1] = (.5 - sin((doublereal) i__)) * 2.;
+ d__[i__ + j * d_dim1] = (.5 - sin((doublereal) (i__ * j)))
+ * 2.;
+ } else {
+ a[i__ + j * a_dim1] = 0.;
+ d__[i__ + j * d_dim1] = 0.;
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (i__ <= j) {
+ b[i__ + j * b_dim1] = (.5 - sin((doublereal) (i__ + j))) *
+ 2.;
+ e[i__ + j * e_dim1] = (.5 - sin((doublereal) j)) * 2.;
+ } else {
+ b[i__ + j * b_dim1] = 0.;
+ e[i__ + j * e_dim1] = 0.;
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ r__[i__ + j * r_dim1] = (.5 - sin((doublereal) (i__ * j))) *
+ 20.;
+ l[i__ + j * l_dim1] = (.5 - sin((doublereal) (i__ + j))) *
+ 20.;
+/* L110: */
+ }
+/* L120: */
+ }
+
+ if (*prtype == 3) {
+ if (*qblcka <= 1) {
+ *qblcka = 2;
+ }
+ i__1 = *m - 1;
+ i__2 = *qblcka;
+ for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+ a[k + 1 + (k + 1) * a_dim1] = a[k + k * a_dim1];
+ a[k + 1 + k * a_dim1] = -sin(a[k + (k + 1) * a_dim1]);
+/* L130: */
+ }
+
+ if (*qblckb <= 1) {
+ *qblckb = 2;
+ }
+ i__2 = *n - 1;
+ i__1 = *qblckb;
+ for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+ b[k + 1 + (k + 1) * b_dim1] = b[k + k * b_dim1];
+ b[k + 1 + k * b_dim1] = -sin(b[k + (k + 1) * b_dim1]);
+/* L140: */
+ }
+ }
+
+ } else if (*prtype == 4) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *m;
+ for (j = 1; j <= i__2; ++j) {
+ a[i__ + j * a_dim1] = (.5 - sin((doublereal) (i__ * j))) *
+ 20.;
+ d__[i__ + j * d_dim1] = (.5 - sin((doublereal) (i__ + j))) *
+ 2.;
+/* L150: */
+ }
+/* L160: */
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ b[i__ + j * b_dim1] = (.5 - sin((doublereal) (i__ + j))) *
+ 20.;
+ e[i__ + j * e_dim1] = (.5 - sin((doublereal) (i__ * j))) * 2.;
+/* L170: */
+ }
+/* L180: */
+ }
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ r__[i__ + j * r_dim1] = (.5 - sin((doublereal) (j / i__))) *
+ 20.;
+ l[i__ + j * l_dim1] = (.5 - sin((doublereal) (i__ * j))) * 2.;
+/* L190: */
+ }
+/* L200: */
+ }
+
+ } else if (*prtype >= 5) {
+ reeps = 20. / *alpha;
+ imeps = -1.5 / *alpha;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ r__[i__ + j * r_dim1] = (.5 - sin((doublereal) (i__ * j))) * *
+ alpha / 20.;
+ l[i__ + j * l_dim1] = (.5 - sin((doublereal) (i__ + j))) * *
+ alpha / 20.;
+/* L210: */
+ }
+/* L220: */
+ }
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__ + i__ * d_dim1] = 1.;
+/* L230: */
+ }
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (i__ <= 4) {
+ a[i__ + i__ * a_dim1] = 1.;
+ if (i__ > 2) {
+ a[i__ + i__ * a_dim1] = reeps + 1.;
+ }
+ if (i__ % 2 != 0 && i__ < *m) {
+ a[i__ + (i__ + 1) * a_dim1] = imeps;
+ } else if (i__ > 1) {
+ a[i__ + (i__ - 1) * a_dim1] = -imeps;
+ }
+ } else if (i__ <= 8) {
+ if (i__ <= 6) {
+ a[i__ + i__ * a_dim1] = reeps;
+ } else {
+ a[i__ + i__ * a_dim1] = -reeps;
+ }
+ if (i__ % 2 != 0 && i__ < *m) {
+ a[i__ + (i__ + 1) * a_dim1] = 1.;
+ } else if (i__ > 1) {
+ a[i__ + (i__ - 1) * a_dim1] = -1.;
+ }
+ } else {
+ a[i__ + i__ * a_dim1] = 1.;
+ if (i__ % 2 != 0 && i__ < *m) {
+ a[i__ + (i__ + 1) * a_dim1] = imeps * 2;
+ } else if (i__ > 1) {
+ a[i__ + (i__ - 1) * a_dim1] = -imeps * 2;
+ }
+ }
+/* L240: */
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ e[i__ + i__ * e_dim1] = 1.;
+ if (i__ <= 4) {
+ b[i__ + i__ * b_dim1] = -1.;
+ if (i__ > 2) {
+ b[i__ + i__ * b_dim1] = 1. - reeps;
+ }
+ if (i__ % 2 != 0 && i__ < *n) {
+ b[i__ + (i__ + 1) * b_dim1] = imeps;
+ } else if (i__ > 1) {
+ b[i__ + (i__ - 1) * b_dim1] = -imeps;
+ }
+ } else if (i__ <= 8) {
+ if (i__ <= 6) {
+ b[i__ + i__ * b_dim1] = reeps;
+ } else {
+ b[i__ + i__ * b_dim1] = -reeps;
+ }
+ if (i__ % 2 != 0 && i__ < *n) {
+ b[i__ + (i__ + 1) * b_dim1] = imeps + 1.;
+ } else if (i__ > 1) {
+ b[i__ + (i__ - 1) * b_dim1] = -1. - imeps;
+ }
+ } else {
+ b[i__ + i__ * b_dim1] = 1. - reeps;
+ if (i__ % 2 != 0 && i__ < *n) {
+ b[i__ + (i__ + 1) * b_dim1] = imeps * 2;
+ } else if (i__ > 1) {
+ b[i__ + (i__ - 1) * b_dim1] = -imeps * 2;
+ }
+ }
+/* L250: */
+ }
+ }
+
+/* Compute rhs (C, F) */
+
+ dgemm_("N", "N", m, n, m, &c_b29, &a[a_offset], lda, &r__[r_offset], ldr,
+ &c_b30, &c__[c_offset], ldc);
+ dgemm_("N", "N", m, n, n, &c_b33, &l[l_offset], ldl, &b[b_offset], ldb, &
+ c_b29, &c__[c_offset], ldc);
+ dgemm_("N", "N", m, n, m, &c_b29, &d__[d_offset], ldd, &r__[r_offset],
+ ldr, &c_b30, &f[f_offset], ldf);
+ dgemm_("N", "N", m, n, n, &c_b33, &l[l_offset], ldl, &e[e_offset], lde, &
+ c_b29, &f[f_offset], ldf);
+
+/* End of DLATM5 */
+
+ return 0;
+} /* dlatm5_ */
diff --git a/TESTING/MATGEN/dlatm6.c b/TESTING/MATGEN/dlatm6.c
new file mode 100644
index 0000000..14e3855
--- /dev/null
+++ b/TESTING/MATGEN/dlatm6.c
@@ -0,0 +1,311 @@
+/* dlatm6.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c__12 = 12;
+static integer c__8 = 8;
+static integer c__40 = 40;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__60 = 60;
+
+/* Subroutine */ int dlatm6_(integer *type__, integer *n, doublereal *a,
+ integer *lda, doublereal *b, doublereal *x, integer *ldx, doublereal *
+ y, integer *ldy, doublereal *alpha, doublereal *beta, doublereal *wx,
+ doublereal *wy, doublereal *s, doublereal *dif)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, y_dim1,
+ y_offset, i__1, i__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ doublereal z__[144] /* was [12][12] */;
+ integer info;
+ doublereal work[100];
+ extern /* Subroutine */ int dlakf2_(integer *, integer *, doublereal *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ integer *), dgesvd_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, integer *, integer *), dlacpy_(char *, integer *, integer *, doublereal
+ *, integer *, doublereal *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLATM6 generates test matrices for the generalized eigenvalue */
+/* problem, their corresponding right and left eigenvector matrices, */
+/* and also reciprocal condition numbers for all eigenvalues and */
+/* the reciprocal condition numbers of eigenvectors corresponding to */
+/* the 1th and 5th eigenvalues. */
+
+/* Test Matrices */
+/* ============= */
+
+/* Two kinds of test matrix pairs */
+
+/* (A, B) = inverse(YH) * (Da, Db) * inverse(X) */
+
+/* are used in the tests: */
+
+/* Type 1: */
+/* Da = 1+a 0 0 0 0 Db = 1 0 0 0 0 */
+/* 0 2+a 0 0 0 0 1 0 0 0 */
+/* 0 0 3+a 0 0 0 0 1 0 0 */
+/* 0 0 0 4+a 0 0 0 0 1 0 */
+/* 0 0 0 0 5+a , 0 0 0 0 1 , and */
+
+/* Type 2: */
+/* Da = 1 -1 0 0 0 Db = 1 0 0 0 0 */
+/* 1 1 0 0 0 0 1 0 0 0 */
+/* 0 0 1 0 0 0 0 1 0 0 */
+/* 0 0 0 1+a 1+b 0 0 0 1 0 */
+/* 0 0 0 -1-b 1+a , 0 0 0 0 1 . */
+
+/* In both cases the same inverse(YH) and inverse(X) are used to compute */
+/* (A, B), giving the exact eigenvectors to (A,B) as (YH, X): */
+
+/* YH: = 1 0 -y y -y X = 1 0 -x -x x */
+/* 0 1 -y y -y 0 1 x -x -x */
+/* 0 0 1 0 0 0 0 1 0 0 */
+/* 0 0 0 1 0 0 0 0 1 0 */
+/* 0 0 0 0 1, 0 0 0 0 1 , */
+
+/* where a, b, x and y will have all values independently of each other. */
+
+/* Arguments */
+/* ========= */
+
+/* TYPE (input) INTEGER */
+/* Specifies the problem type (see futher details). */
+
+/* N (input) INTEGER */
+/* Size of the matrices A and B. */
+
+/* A (output) DOUBLE PRECISION array, dimension (LDA, N). */
+/* On exit A N-by-N is initialized according to TYPE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A and of B. */
+
+/* B (output) DOUBLE PRECISION array, dimension (LDA, N). */
+/* On exit B N-by-N is initialized according to TYPE. */
+
+/* X (output) DOUBLE PRECISION array, dimension (LDX, N). */
+/* On exit X is the N-by-N matrix of right eigenvectors. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of X. */
+
+/* Y (output) DOUBLE PRECISION array, dimension (LDY, N). */
+/* On exit Y is the N-by-N matrix of left eigenvectors. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of Y. */
+
+/* ALPHA (input) DOUBLE PRECISION */
+/* BETA (input) DOUBLE PRECISION */
+/* Weighting constants for matrix A. */
+
+/* WX (input) DOUBLE PRECISION */
+/* Constant for right eigenvector matrix. */
+
+/* WY (input) DOUBLE PRECISION */
+/* Constant for left eigenvector matrix. */
+
+/* S (output) DOUBLE PRECISION array, dimension (N) */
+/* S(i) is the reciprocal condition number for eigenvalue i. */
+
+/* DIF (output) DOUBLE PRECISION array, dimension (N) */
+/* DIF(i) is the reciprocal condition number for eigenvector i. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Generate test problem ... */
+/* (Da, Db) ... */
+
+ /* Parameter adjustments */
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ --s;
+ --dif;
+
+ /* Function Body */
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+
+ if (i__ == j) {
+ a[i__ + i__ * a_dim1] = (doublereal) i__ + *alpha;
+ b[i__ + i__ * b_dim1] = 1.;
+ } else {
+ a[i__ + j * a_dim1] = 0.;
+ b[i__ + j * b_dim1] = 0.;
+ }
+
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Form X and Y */
+
+ dlacpy_("F", n, n, &b[b_offset], lda, &y[y_offset], ldy);
+ y[y_dim1 + 3] = -(*wy);
+ y[y_dim1 + 4] = *wy;
+ y[y_dim1 + 5] = -(*wy);
+ y[(y_dim1 << 1) + 3] = -(*wy);
+ y[(y_dim1 << 1) + 4] = *wy;
+ y[(y_dim1 << 1) + 5] = -(*wy);
+
+ dlacpy_("F", n, n, &b[b_offset], lda, &x[x_offset], ldx);
+ x[x_dim1 * 3 + 1] = -(*wx);
+ x[(x_dim1 << 2) + 1] = -(*wx);
+ x[x_dim1 * 5 + 1] = *wx;
+ x[x_dim1 * 3 + 2] = *wx;
+ x[(x_dim1 << 2) + 2] = -(*wx);
+ x[x_dim1 * 5 + 2] = -(*wx);
+
+/* Form (A, B) */
+
+ b[b_dim1 * 3 + 1] = *wx + *wy;
+ b[b_dim1 * 3 + 2] = -(*wx) + *wy;
+ b[(b_dim1 << 2) + 1] = *wx - *wy;
+ b[(b_dim1 << 2) + 2] = *wx - *wy;
+ b[b_dim1 * 5 + 1] = -(*wx) + *wy;
+ b[b_dim1 * 5 + 2] = *wx + *wy;
+ if (*type__ == 1) {
+ a[a_dim1 * 3 + 1] = *wx * a[a_dim1 + 1] + *wy * a[a_dim1 * 3 + 3];
+ a[a_dim1 * 3 + 2] = -(*wx) * a[(a_dim1 << 1) + 2] + *wy * a[a_dim1 *
+ 3 + 3];
+ a[(a_dim1 << 2) + 1] = *wx * a[a_dim1 + 1] - *wy * a[(a_dim1 << 2) +
+ 4];
+ a[(a_dim1 << 2) + 2] = *wx * a[(a_dim1 << 1) + 2] - *wy * a[(a_dim1 <<
+ 2) + 4];
+ a[a_dim1 * 5 + 1] = -(*wx) * a[a_dim1 + 1] + *wy * a[a_dim1 * 5 + 5];
+ a[a_dim1 * 5 + 2] = *wx * a[(a_dim1 << 1) + 2] + *wy * a[a_dim1 * 5 +
+ 5];
+ } else if (*type__ == 2) {
+ a[a_dim1 * 3 + 1] = *wx * 2. + *wy;
+ a[a_dim1 * 3 + 2] = *wy;
+ a[(a_dim1 << 2) + 1] = -(*wy) * (*alpha + 2. + *beta);
+ a[(a_dim1 << 2) + 2] = *wx * 2. - *wy * (*alpha + 2. + *beta);
+ a[a_dim1 * 5 + 1] = *wx * -2. + *wy * (*alpha - *beta);
+ a[a_dim1 * 5 + 2] = *wy * (*alpha - *beta);
+ a[a_dim1 + 1] = 1.;
+ a[(a_dim1 << 1) + 1] = -1.;
+ a[a_dim1 + 2] = 1.;
+ a[(a_dim1 << 1) + 2] = a[a_dim1 + 1];
+ a[a_dim1 * 3 + 3] = 1.;
+ a[(a_dim1 << 2) + 4] = *alpha + 1.;
+ a[a_dim1 * 5 + 4] = *beta + 1.;
+ a[(a_dim1 << 2) + 5] = -a[a_dim1 * 5 + 4];
+ a[a_dim1 * 5 + 5] = a[(a_dim1 << 2) + 4];
+ }
+
+/* Compute condition numbers */
+
+ if (*type__ == 1) {
+
+ s[1] = 1. / sqrt((*wy * 3. * *wy + 1.) / (a[a_dim1 + 1] * a[a_dim1 +
+ 1] + 1.));
+ s[2] = 1. / sqrt((*wy * 3. * *wy + 1.) / (a[(a_dim1 << 1) + 2] * a[(
+ a_dim1 << 1) + 2] + 1.));
+ s[3] = 1. / sqrt((*wx * 2. * *wx + 1.) / (a[a_dim1 * 3 + 3] * a[
+ a_dim1 * 3 + 3] + 1.));
+ s[4] = 1. / sqrt((*wx * 2. * *wx + 1.) / (a[(a_dim1 << 2) + 4] * a[(
+ a_dim1 << 2) + 4] + 1.));
+ s[5] = 1. / sqrt((*wx * 2. * *wx + 1.) / (a[a_dim1 * 5 + 5] * a[
+ a_dim1 * 5 + 5] + 1.));
+
+ dlakf2_(&c__1, &c__4, &a[a_offset], lda, &a[(a_dim1 << 1) + 2], &b[
+ b_offset], &b[(b_dim1 << 1) + 2], z__, &c__12);
+ dgesvd_("N", "N", &c__8, &c__8, z__, &c__12, work, &work[8], &c__1, &
+ work[9], &c__1, &work[10], &c__40, &info);
+ dif[1] = work[7];
+
+ dlakf2_(&c__4, &c__1, &a[a_offset], lda, &a[a_dim1 * 5 + 5], &b[
+ b_offset], &b[b_dim1 * 5 + 5], z__, &c__12);
+ dgesvd_("N", "N", &c__8, &c__8, z__, &c__12, work, &work[8], &c__1, &
+ work[9], &c__1, &work[10], &c__40, &info);
+ dif[5] = work[7];
+
+ } else if (*type__ == 2) {
+
+ s[1] = 1. / sqrt(*wy * *wy + .33333333333333331);
+ s[2] = s[1];
+ s[3] = 1. / sqrt(*wx * *wx + .5);
+ s[4] = 1. / sqrt((*wx * 2. * *wx + 1.) / ((*alpha + 1.) * (*alpha +
+ 1.) + 1. + (*beta + 1.) * (*beta + 1.)));
+ s[5] = s[4];
+
+ dlakf2_(&c__2, &c__3, &a[a_offset], lda, &a[a_dim1 * 3 + 3], &b[
+ b_offset], &b[b_dim1 * 3 + 3], z__, &c__12);
+ dgesvd_("N", "N", &c__12, &c__12, z__, &c__12, work, &work[12], &c__1,
+ &work[13], &c__1, &work[14], &c__60, &info);
+ dif[1] = work[11];
+
+ dlakf2_(&c__3, &c__2, &a[a_offset], lda, &a[(a_dim1 << 2) + 4], &b[
+ b_offset], &b[(b_dim1 << 2) + 4], z__, &c__12);
+ dgesvd_("N", "N", &c__12, &c__12, z__, &c__12, work, &work[12], &c__1,
+ &work[13], &c__1, &work[14], &c__60, &info);
+ dif[5] = work[11];
+
+ }
+
+ return 0;
+
+/* End of DLATM6 */
+
+} /* dlatm6_ */
diff --git a/TESTING/MATGEN/dlatm7.c b/TESTING/MATGEN/dlatm7.c
new file mode 100644
index 0000000..3b8d5ec
--- /dev/null
+++ b/TESTING/MATGEN/dlatm7.c
@@ -0,0 +1,305 @@
+/* dlatm7.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlatm7_(integer *mode, doublereal *cond, integer *irsign,
+ integer *idist, integer *iseed, doublereal *d__, integer *n, integer
+ *rank, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double pow_dd(doublereal *, doublereal *), pow_di(doublereal *, integer *)
+ , log(doublereal), exp(doublereal);
+
+ /* Local variables */
+ integer i__;
+ doublereal temp, alpha;
+ extern doublereal dlaran_(integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), dlarnv_(
+ integer *, integer *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLATM7 computes the entries of D as specified by MODE */
+/* COND and IRSIGN. IDIST and ISEED determine the generation */
+/* of random numbers. DLATM7 is called by DLATMT to generate */
+/* random test matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* MODE - INTEGER */
+/* On entry describes how D is to be computed: */
+/* MODE = 0 means do not change D. */
+
+/* MODE = 1 sets D(1)=1 and D(2:RANK)=1.0/COND */
+/* MODE = 2 sets D(1:RANK-1)=1 and D(RANK)=1.0/COND */
+/* MODE = 3 sets D(I)=COND**(-(I-1)/(RANK-1)) I=1:RANK */
+
+/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* MODE = 5 sets D to random numbers in the range */
+/* ( 1/COND , 1 ) such that their logarithms */
+/* are uniformly distributed. */
+/* MODE = 6 set D to random numbers from same distribution */
+/* as the rest of the matrix. */
+/* MODE < 0 has the same meaning as ABS(MODE), except that */
+/* the order of the elements of D is reversed. */
+/* Thus if MODE is positive, D has entries ranging from */
+/* 1 to 1/COND, if negative, from 1/COND to 1, */
+/* Not modified. */
+
+/* COND - DOUBLE PRECISION */
+/* On entry, used as described under MODE above. */
+/* If used, it must be >= 1. Not modified. */
+
+/* IRSIGN - INTEGER */
+/* On entry, if MODE neither -6, 0 nor 6, determines sign of */
+/* entries of D */
+/* 0 => leave entries of D unchanged */
+/* 1 => multiply each entry of D by 1 or -1 with probability .5 */
+
+/* IDIST - CHARACTER*1 */
+/* On entry, IDIST specifies the type of distribution to be */
+/* used to generate a random matrix . */
+/* 1 => UNIFORM( 0, 1 ) */
+/* 2 => UNIFORM( -1, 1 ) */
+/* 3 => NORMAL( 0, 1 ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension ( 4 ) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The random number generator uses a */
+/* linear congruential sequence limited to small */
+/* integers, and so should produce machine independent */
+/* random numbers. The values of ISEED are changed on */
+/* exit, and can be used in the next call to DLATM7 */
+/* to continue the same random number sequence. */
+/* Changed on exit. */
+
+/* D - DOUBLE PRECISION array, dimension ( MIN( M , N ) ) */
+/* Array to be computed according to MODE, COND and IRSIGN. */
+/* May be changed on exit if MODE is nonzero. */
+
+/* N - INTEGER */
+/* Number of entries of D. Not modified. */
+
+/* RANK - INTEGER */
+/* The rank of matrix to be generated for modes 1,2,3 only. */
+/* D( RANK+1:N ) = 0. */
+/* Not modified. */
+
+/* INFO - INTEGER */
+/* 0 => normal termination */
+/* -1 => if MODE not in range -6 to 6 */
+/* -2 => if MODE neither -6, 0 nor 6, and */
+/* IRSIGN neither 0 nor 1 */
+/* -3 => if MODE neither -6, 0 nor 6 and COND less than 1 */
+/* -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 3 */
+/* -7 => if N negative */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and Test the input parameters. Initialize flags & seed. */
+
+ /* Parameter adjustments */
+ --d__;
+ --iseed;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Set INFO if an error */
+
+ if (*mode < -6 || *mode > 6) {
+ *info = -1;
+ } else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && *
+ irsign != 1)) {
+ *info = -2;
+ } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.) {
+ *info = -3;
+ } else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 3)) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -7;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLATM7", &i__1);
+ return 0;
+ }
+
+/* Compute D according to COND and MODE */
+
+ if (*mode != 0) {
+ switch (abs(*mode)) {
+ case 1: goto L100;
+ case 2: goto L130;
+ case 3: goto L160;
+ case 4: goto L190;
+ case 5: goto L210;
+ case 6: goto L230;
+ }
+
+/* One large D value: */
+
+L100:
+ i__1 = *rank;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ d__[i__] = 1. / *cond;
+/* L110: */
+ }
+ i__1 = *n;
+ for (i__ = *rank + 1; i__ <= i__1; ++i__) {
+ d__[i__] = 0.;
+/* L120: */
+ }
+ d__[1] = 1.;
+ goto L240;
+
+/* One small D value: */
+
+L130:
+ i__1 = *rank - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = 1.;
+/* L140: */
+ }
+ i__1 = *n;
+ for (i__ = *rank + 1; i__ <= i__1; ++i__) {
+ d__[i__] = 0.;
+/* L150: */
+ }
+ d__[*rank] = 1. / *cond;
+ goto L240;
+
+/* Exponentially distributed D values: */
+
+L160:
+ d__[1] = 1.;
+ if (*n > 1) {
+ d__1 = -1. / (doublereal) (*rank - 1);
+ alpha = pow_dd(cond, &d__1);
+ i__1 = *rank;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__ - 1;
+ d__[i__] = pow_di(&alpha, &i__2);
+/* L170: */
+ }
+ i__1 = *n;
+ for (i__ = *rank + 1; i__ <= i__1; ++i__) {
+ d__[i__] = 0.;
+/* L180: */
+ }
+ }
+ goto L240;
+
+/* Arithmetically distributed D values: */
+
+L190:
+ d__[1] = 1.;
+ if (*n > 1) {
+ temp = 1. / *cond;
+ alpha = (1. - temp) / (doublereal) (*n - 1);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ d__[i__] = (doublereal) (*n - i__) * alpha + temp;
+/* L200: */
+ }
+ }
+ goto L240;
+
+/* Randomly distributed D values on ( 1/COND , 1): */
+
+L210:
+ alpha = log(1. / *cond);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = exp(alpha * dlaran_(&iseed[1]));
+/* L220: */
+ }
+ goto L240;
+
+/* Randomly distributed D values from IDIST */
+
+L230:
+ dlarnv_(idist, &iseed[1], n, &d__[1]);
+
+L240:
+
+/* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */
+/* random signs to D */
+
+ if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = dlaran_(&iseed[1]);
+ if (temp > .5) {
+ d__[i__] = -d__[i__];
+ }
+/* L250: */
+ }
+ }
+
+/* Reverse if MODE < 0 */
+
+ if (*mode < 0) {
+ i__1 = *n / 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = d__[i__];
+ d__[i__] = d__[*n + 1 - i__];
+ d__[*n + 1 - i__] = temp;
+/* L260: */
+ }
+ }
+
+ }
+
+ return 0;
+
+/* End of DLATM7 */
+
+} /* dlatm7_ */
diff --git a/TESTING/MATGEN/dlatme.c b/TESTING/MATGEN/dlatme.c
new file mode 100644
index 0000000..bfb73cd
--- /dev/null
+++ b/TESTING/MATGEN/dlatme.c
@@ -0,0 +1,693 @@
+/* dlatme.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b23 = 0.;
+static integer c__0 = 0;
+static doublereal c_b39 = 1.;
+
+/* Subroutine */ int dlatme_(integer *n, char *dist, integer *iseed,
+ doublereal *d__, integer *mode, doublereal *cond, doublereal *dmax__,
+ char *ei, char *rsign, char *upper, char *sim, doublereal *ds,
+ integer *modes, doublereal *conds, integer *kl, integer *ku,
+ doublereal *anorm, doublereal *a, integer *lda, doublereal *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, ic, jc, ir, jr, jcr;
+ doublereal tau;
+ logical bads;
+ extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
+ doublereal *, integer *, doublereal *, integer *, doublereal *,
+ integer *);
+ integer isim;
+ doublereal temp;
+ logical badei;
+ doublereal alpha;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
+ doublereal *, doublereal *, integer *, doublereal *, integer *,
+ doublereal *, doublereal *, integer *);
+ integer iinfo;
+ doublereal tempa[1];
+ integer icols;
+ logical useei;
+ integer idist;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer irows;
+ extern /* Subroutine */ int dlatm1_(integer *, doublereal *, integer *,
+ integer *, integer *, doublereal *, integer *, integer *);
+ extern doublereal dlange_(char *, integer *, integer *, doublereal *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int dlarge_(integer *, doublereal *, integer *,
+ integer *, doublereal *, integer *), dlarfg_(integer *,
+ doublereal *, doublereal *, integer *, doublereal *);
+ extern doublereal dlaran_(integer *);
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ xerbla_(char *, integer *), dlarnv_(integer *, integer *,
+ integer *, doublereal *);
+ integer irsign, iupper;
+ doublereal xnorms;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLATME generates random non-symmetric square matrices with */
+/* specified eigenvalues for testing LAPACK programs. */
+
+/* DLATME operates by applying the following sequence of */
+/* operations: */
+
+/* 1. Set the diagonal to D, where D may be input or */
+/* computed according to MODE, COND, DMAX, and RSIGN */
+/* as described below. */
+
+/* 2. If complex conjugate pairs are desired (MODE=0 and EI(1)='R', */
+/* or MODE=5), certain pairs of adjacent elements of D are */
+/* interpreted as the real and complex parts of a complex */
+/* conjugate pair; A thus becomes block diagonal, with 1x1 */
+/* and 2x2 blocks. */
+
+/* 3. If UPPER='T', the upper triangle of A is set to random values */
+/* out of distribution DIST. */
+
+/* 4. If SIM='T', A is multiplied on the left by a random matrix */
+/* X, whose singular values are specified by DS, MODES, and */
+/* CONDS, and on the right by X inverse. */
+
+/* 5. If KL < N-1, the lower bandwidth is reduced to KL using */
+/* Householder transformations. If KU < N-1, the upper */
+/* bandwidth is reduced to KU. */
+
+/* 6. If ANORM is not negative, the matrix is scaled to have */
+/* maximum-element-norm ANORM. */
+
+/* (Note: since the matrix cannot be reduced beyond Hessenberg form, */
+/* no packing options are available.) */
+
+/* Arguments */
+/* ========= */
+
+/* N - INTEGER */
+/* The number of columns (or rows) of A. Not modified. */
+
+/* DIST - CHARACTER*1 */
+/* On entry, DIST specifies the type of distribution to be used */
+/* to generate the random eigen-/singular values, and for the */
+/* upper triangle (see UPPER). */
+/* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */
+/* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */
+/* 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension ( 4 ) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. They should lie between 0 and 4095 inclusive, */
+/* and ISEED(4) should be odd. The random number generator */
+/* uses a linear congruential sequence limited to small */
+/* integers, and so should produce machine independent */
+/* random numbers. The values of ISEED are changed on */
+/* exit, and can be used in the next call to DLATME */
+/* to continue the same random number sequence. */
+/* Changed on exit. */
+
+/* D - DOUBLE PRECISION array, dimension ( N ) */
+/* This array is used to specify the eigenvalues of A. If */
+/* MODE=0, then D is assumed to contain the eigenvalues (but */
+/* see the description of EI), otherwise they will be */
+/* computed according to MODE, COND, DMAX, and RSIGN and */
+/* placed in D. */
+/* Modified if MODE is nonzero. */
+
+/* MODE - INTEGER */
+/* On entry this describes how the eigenvalues are to */
+/* be specified: */
+/* MODE = 0 means use D (with EI) as input */
+/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
+/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
+/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
+/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* MODE = 5 sets D to random numbers in the range */
+/* ( 1/COND , 1 ) such that their logarithms */
+/* are uniformly distributed. Each odd-even pair */
+/* of elements will be either used as two real */
+/* eigenvalues or as the real and imaginary part */
+/* of a complex conjugate pair of eigenvalues; */
+/* the choice of which is done is random, with */
+/* 50-50 probability, for each pair. */
+/* MODE = 6 set D to random numbers from same distribution */
+/* as the rest of the matrix. */
+/* MODE < 0 has the same meaning as ABS(MODE), except that */
+/* the order of the elements of D is reversed. */
+/* Thus if MODE is between 1 and 4, D has entries ranging */
+/* from 1 to 1/COND, if between -1 and -4, D has entries */
+/* ranging from 1/COND to 1, */
+/* Not modified. */
+
+/* COND - DOUBLE PRECISION */
+/* On entry, this is used as described under MODE above. */
+/* If used, it must be >= 1. Not modified. */
+
+/* DMAX - DOUBLE PRECISION */
+/* If MODE is neither -6, 0 nor 6, the contents of D, as */
+/* computed according to MODE and COND, will be scaled by */
+/* DMAX / max(abs(D(i))). Note that DMAX need not be */
+/* positive: if DMAX is negative (or zero), D will be */
+/* scaled by a negative number (or zero). */
+/* Not modified. */
+
+/* EI - CHARACTER*1 array, dimension ( N ) */
+/* If MODE is 0, and EI(1) is not ' ' (space character), */
+/* this array specifies which elements of D (on input) are */
+/* real eigenvalues and which are the real and imaginary parts */
+/* of a complex conjugate pair of eigenvalues. The elements */
+/* of EI may then only have the values 'R' and 'I'. If */
+/* EI(j)='R' and EI(j+1)='I', then the j-th eigenvalue is */
+/* CMPLX( D(j) , D(j+1) ), and the (j+1)-th is the complex */
+/* conjugate thereof. If EI(j)=EI(j+1)='R', then the j-th */
+/* eigenvalue is D(j) (i.e., real). EI(1) may not be 'I', */
+/* nor may two adjacent elements of EI both have the value 'I'. */
+/* If MODE is not 0, then EI is ignored. If MODE is 0 and */
+/* EI(1)=' ', then the eigenvalues will all be real. */
+/* Not modified. */
+
+/* RSIGN - CHARACTER*1 */
+/* If MODE is not 0, 6, or -6, and RSIGN='T', then the */
+/* elements of D, as computed according to MODE and COND, will */
+/* be multiplied by a random sign (+1 or -1). If RSIGN='F', */
+/* they will not be. RSIGN may only have the values 'T' or */
+/* 'F'. */
+/* Not modified. */
+
+/* UPPER - CHARACTER*1 */
+/* If UPPER='T', then the elements of A above the diagonal */
+/* (and above the 2x2 diagonal blocks, if A has complex */
+/* eigenvalues) will be set to random numbers out of DIST. */
+/* If UPPER='F', they will not. UPPER may only have the */
+/* values 'T' or 'F'. */
+/* Not modified. */
+
+/* SIM - CHARACTER*1 */
+/* If SIM='T', then A will be operated on by a "similarity */
+/* transform", i.e., multiplied on the left by a matrix X and */
+/* on the right by X inverse. X = U S V, where U and V are */
+/* random unitary matrices and S is a (diagonal) matrix of */
+/* singular values specified by DS, MODES, and CONDS. If */
+/* SIM='F', then A will not be transformed. */
+/* Not modified. */
+
+/* DS - DOUBLE PRECISION array, dimension ( N ) */
+/* This array is used to specify the singular values of X, */
+/* in the same way that D specifies the eigenvalues of A. */
+/* If MODE=0, the DS contains the singular values, which */
+/* may not be zero. */
+/* Modified if MODE is nonzero. */
+
+/* MODES - INTEGER */
+/* CONDS - DOUBLE PRECISION */
+/* Same as MODE and COND, but for specifying the diagonal */
+/* of S. MODES=-6 and +6 are not allowed (since they would */
+/* result in randomly ill-conditioned eigenvalues.) */
+
+/* KL - INTEGER */
+/* This specifies the lower bandwidth of the matrix. KL=1 */
+/* specifies upper Hessenberg form. If KL is at least N-1, */
+/* then A will have full lower bandwidth. KL must be at */
+/* least 1. */
+/* Not modified. */
+
+/* KU - INTEGER */
+/* This specifies the upper bandwidth of the matrix. KU=1 */
+/* specifies lower Hessenberg form. If KU is at least N-1, */
+/* then A will have full upper bandwidth; if KU and KL */
+/* are both at least N-1, then A will be dense. Only one of */
+/* KU and KL may be less than N-1. KU must be at least 1. */
+/* Not modified. */
+
+/* ANORM - DOUBLE PRECISION */
+/* If ANORM is not negative, then A will be scaled by a non- */
+/* negative real number to make the maximum-element-norm of A */
+/* to be ANORM. */
+/* Not modified. */
+
+/* A - DOUBLE PRECISION array, dimension ( LDA, N ) */
+/* On exit A is the desired test matrix. */
+/* Modified. */
+
+/* LDA - INTEGER */
+/* LDA specifies the first dimension of A as declared in the */
+/* calling program. LDA must be at least N. */
+/* Not modified. */
+
+/* WORK - DOUBLE PRECISION array, dimension ( 3*N ) */
+/* Workspace. */
+/* Modified. */
+
+/* INFO - INTEGER */
+/* Error code. On exit, INFO will be set to one of the */
+/* following values: */
+/* 0 => normal return */
+/* -1 => N negative */
+/* -2 => DIST illegal string */
+/* -5 => MODE not in range -6 to 6 */
+/* -6 => COND less than 1.0, and MODE neither -6, 0 nor 6 */
+/* -8 => EI(1) is not ' ' or 'R', EI(j) is not 'R' or 'I', or */
+/* two adjacent elements of EI are 'I'. */
+/* -9 => RSIGN is not 'T' or 'F' */
+/* -10 => UPPER is not 'T' or 'F' */
+/* -11 => SIM is not 'T' or 'F' */
+/* -12 => MODES=0 and DS has a zero singular value. */
+/* -13 => MODES is not in the range -5 to 5. */
+/* -14 => MODES is nonzero and CONDS is less than 1. */
+/* -15 => KL is less than 1. */
+/* -16 => KU is less than 1, or KL and KU are both less than */
+/* N-1. */
+/* -19 => LDA is less than N. */
+/* 1 => Error return from DLATM1 (computing D) */
+/* 2 => Cannot scale to DMAX (max. eigenvalue is 0) */
+/* 3 => Error return from DLATM1 (computing DS) */
+/* 4 => Error return from DLARGE */
+/* 5 => Zero singular value from DLATM1. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Decode and Test the input parameters. */
+/* Initialize flags & seed. */
+
+ /* Parameter adjustments */
+ --iseed;
+ --d__;
+ --ei;
+ --ds;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Decode DIST */
+
+ if (lsame_(dist, "U")) {
+ idist = 1;
+ } else if (lsame_(dist, "S")) {
+ idist = 2;
+ } else if (lsame_(dist, "N")) {
+ idist = 3;
+ } else {
+ idist = -1;
+ }
+
+/* Check EI */
+
+ useei = TRUE_;
+ badei = FALSE_;
+ if (lsame_(ei + 1, " ") || *mode != 0) {
+ useei = FALSE_;
+ } else {
+ if (lsame_(ei + 1, "R")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ if (lsame_(ei + j, "I")) {
+ if (lsame_(ei + (j - 1), "I")) {
+ badei = TRUE_;
+ }
+ } else {
+ if (! lsame_(ei + j, "R")) {
+ badei = TRUE_;
+ }
+ }
+/* L10: */
+ }
+ } else {
+ badei = TRUE_;
+ }
+ }
+
+/* Decode RSIGN */
+
+ if (lsame_(rsign, "T")) {
+ irsign = 1;
+ } else if (lsame_(rsign, "F")) {
+ irsign = 0;
+ } else {
+ irsign = -1;
+ }
+
+/* Decode UPPER */
+
+ if (lsame_(upper, "T")) {
+ iupper = 1;
+ } else if (lsame_(upper, "F")) {
+ iupper = 0;
+ } else {
+ iupper = -1;
+ }
+
+/* Decode SIM */
+
+ if (lsame_(sim, "T")) {
+ isim = 1;
+ } else if (lsame_(sim, "F")) {
+ isim = 0;
+ } else {
+ isim = -1;
+ }
+
+/* Check DS, if MODES=0 and ISIM=1 */
+
+ bads = FALSE_;
+ if (*modes == 0 && isim == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (ds[j] == 0.) {
+ bads = TRUE_;
+ }
+/* L20: */
+ }
+ }
+
+/* Set INFO if an error */
+
+ if (*n < 0) {
+ *info = -1;
+ } else if (idist == -1) {
+ *info = -2;
+ } else if (abs(*mode) > 6) {
+ *info = -5;
+ } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.) {
+ *info = -6;
+ } else if (badei) {
+ *info = -8;
+ } else if (irsign == -1) {
+ *info = -9;
+ } else if (iupper == -1) {
+ *info = -10;
+ } else if (isim == -1) {
+ *info = -11;
+ } else if (bads) {
+ *info = -12;
+ } else if (isim == 1 && abs(*modes) > 5) {
+ *info = -13;
+ } else if (isim == 1 && *modes != 0 && *conds < 1.) {
+ *info = -14;
+ } else if (*kl < 1) {
+ *info = -15;
+ } else if (*ku < 1 || *ku < *n - 1 && *kl < *n - 1) {
+ *info = -16;
+ } else if (*lda < max(1,*n)) {
+ *info = -19;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLATME", &i__1);
+ return 0;
+ }
+
+/* Initialize random number generator */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
+/* L30: */
+ }
+
+ if (iseed[4] % 2 != 1) {
+ ++iseed[4];
+ }
+
+/* 2) Set up diagonal of A */
+
+/* Compute D according to COND and MODE */
+
+ dlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], n, &iinfo);
+ if (iinfo != 0) {
+ *info = 1;
+ return 0;
+ }
+ if (*mode != 0 && abs(*mode) != 6) {
+
+/* Scale by DMAX */
+
+ temp = abs(d__[1]);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = temp, d__3 = (d__1 = d__[i__], abs(d__1));
+ temp = max(d__2,d__3);
+/* L40: */
+ }
+
+ if (temp > 0.) {
+ alpha = *dmax__ / temp;
+ } else if (*dmax__ != 0.) {
+ *info = 2;
+ return 0;
+ } else {
+ alpha = 0.;
+ }
+
+ dscal_(n, &alpha, &d__[1], &c__1);
+
+ }
+
+ dlaset_("Full", n, n, &c_b23, &c_b23, &a[a_offset], lda);
+ i__1 = *lda + 1;
+ dcopy_(n, &d__[1], &c__1, &a[a_offset], &i__1);
+
+/* Set up complex conjugate pairs */
+
+ if (*mode == 0) {
+ if (useei) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ if (lsame_(ei + j, "I")) {
+ a[j - 1 + j * a_dim1] = a[j + j * a_dim1];
+ a[j + (j - 1) * a_dim1] = -a[j + j * a_dim1];
+ a[j + j * a_dim1] = a[j - 1 + (j - 1) * a_dim1];
+ }
+/* L50: */
+ }
+ }
+
+ } else if (abs(*mode) == 5) {
+
+ i__1 = *n;
+ for (j = 2; j <= i__1; j += 2) {
+ if (dlaran_(&iseed[1]) > .5) {
+ a[j - 1 + j * a_dim1] = a[j + j * a_dim1];
+ a[j + (j - 1) * a_dim1] = -a[j + j * a_dim1];
+ a[j + j * a_dim1] = a[j - 1 + (j - 1) * a_dim1];
+ }
+/* L60: */
+ }
+ }
+
+/* 3) If UPPER='T', set upper triangle of A to random numbers. */
+/* (but don't modify the corners of 2x2 blocks.) */
+
+ if (iupper != 0) {
+ i__1 = *n;
+ for (jc = 2; jc <= i__1; ++jc) {
+ if (a[jc - 1 + jc * a_dim1] != 0.) {
+ jr = jc - 2;
+ } else {
+ jr = jc - 1;
+ }
+ dlarnv_(&idist, &iseed[1], &jr, &a[jc * a_dim1 + 1]);
+/* L70: */
+ }
+ }
+
+/* 4) If SIM='T', apply similarity transformation. */
+
+/* -1 */
+/* Transform is X A X , where X = U S V, thus */
+
+/* it is U S V A V' (1/S) U' */
+
+ if (isim != 0) {
+
+/* Compute S (singular values of the eigenvector matrix) */
+/* according to CONDS and MODES */
+
+ dlatm1_(modes, conds, &c__0, &c__0, &iseed[1], &ds[1], n, &iinfo);
+ if (iinfo != 0) {
+ *info = 3;
+ return 0;
+ }
+
+/* Multiply by V and V' */
+
+ dlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
+ if (iinfo != 0) {
+ *info = 4;
+ return 0;
+ }
+
+/* Multiply by S and (1/S) */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dscal_(n, &ds[j], &a[j + a_dim1], lda);
+ if (ds[j] != 0.) {
+ d__1 = 1. / ds[j];
+ dscal_(n, &d__1, &a[j * a_dim1 + 1], &c__1);
+ } else {
+ *info = 5;
+ return 0;
+ }
+/* L80: */
+ }
+
+/* Multiply by U and U' */
+
+ dlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
+ if (iinfo != 0) {
+ *info = 4;
+ return 0;
+ }
+ }
+
+/* 5) Reduce the bandwidth. */
+
+ if (*kl < *n - 1) {
+
+/* Reduce bandwidth -- kill column */
+
+ i__1 = *n - 1;
+ for (jcr = *kl + 1; jcr <= i__1; ++jcr) {
+ ic = jcr - *kl;
+ irows = *n + 1 - jcr;
+ icols = *n + *kl - jcr;
+
+ dcopy_(&irows, &a[jcr + ic * a_dim1], &c__1, &work[1], &c__1);
+ xnorms = work[1];
+ dlarfg_(&irows, &xnorms, &work[2], &c__1, &tau);
+ work[1] = 1.;
+
+ dgemv_("T", &irows, &icols, &c_b39, &a[jcr + (ic + 1) * a_dim1],
+ lda, &work[1], &c__1, &c_b23, &work[irows + 1], &c__1);
+ d__1 = -tau;
+ dger_(&irows, &icols, &d__1, &work[1], &c__1, &work[irows + 1], &
+ c__1, &a[jcr + (ic + 1) * a_dim1], lda);
+
+ dgemv_("N", n, &irows, &c_b39, &a[jcr * a_dim1 + 1], lda, &work[1]
+, &c__1, &c_b23, &work[irows + 1], &c__1);
+ d__1 = -tau;
+ dger_(n, &irows, &d__1, &work[irows + 1], &c__1, &work[1], &c__1,
+ &a[jcr * a_dim1 + 1], lda);
+
+ a[jcr + ic * a_dim1] = xnorms;
+ i__2 = irows - 1;
+ dlaset_("Full", &i__2, &c__1, &c_b23, &c_b23, &a[jcr + 1 + ic *
+ a_dim1], lda);
+/* L90: */
+ }
+ } else if (*ku < *n - 1) {
+
+/* Reduce upper bandwidth -- kill a row at a time. */
+
+ i__1 = *n - 1;
+ for (jcr = *ku + 1; jcr <= i__1; ++jcr) {
+ ir = jcr - *ku;
+ irows = *n + *ku - jcr;
+ icols = *n + 1 - jcr;
+
+ dcopy_(&icols, &a[ir + jcr * a_dim1], lda, &work[1], &c__1);
+ xnorms = work[1];
+ dlarfg_(&icols, &xnorms, &work[2], &c__1, &tau);
+ work[1] = 1.;
+
+ dgemv_("N", &irows, &icols, &c_b39, &a[ir + 1 + jcr * a_dim1],
+ lda, &work[1], &c__1, &c_b23, &work[icols + 1], &c__1);
+ d__1 = -tau;
+ dger_(&irows, &icols, &d__1, &work[icols + 1], &c__1, &work[1], &
+ c__1, &a[ir + 1 + jcr * a_dim1], lda);
+
+ dgemv_("C", &icols, n, &c_b39, &a[jcr + a_dim1], lda, &work[1], &
+ c__1, &c_b23, &work[icols + 1], &c__1);
+ d__1 = -tau;
+ dger_(&icols, n, &d__1, &work[1], &c__1, &work[icols + 1], &c__1,
+ &a[jcr + a_dim1], lda);
+
+ a[ir + jcr * a_dim1] = xnorms;
+ i__2 = icols - 1;
+ dlaset_("Full", &c__1, &i__2, &c_b23, &c_b23, &a[ir + (jcr + 1) *
+ a_dim1], lda);
+/* L100: */
+ }
+ }
+
+/* Scale the matrix to have norm ANORM */
+
+ if (*anorm >= 0.) {
+ temp = dlange_("M", n, n, &a[a_offset], lda, tempa);
+ if (temp > 0.) {
+ alpha = *anorm / temp;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ dscal_(n, &alpha, &a[j * a_dim1 + 1], &c__1);
+/* L110: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DLATME */
+
+} /* dlatme_ */
diff --git a/TESTING/MATGEN/dlatmr.c b/TESTING/MATGEN/dlatmr.c
new file mode 100644
index 0000000..0b74688
--- /dev/null
+++ b/TESTING/MATGEN/dlatmr.c
@@ -0,0 +1,1288 @@
+/* dlatmr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int dlatmr_(integer *m, integer *n, char *dist, integer *
+ iseed, char *sym, doublereal *d__, integer *mode, doublereal *cond,
+ doublereal *dmax__, char *rsign, char *grade, doublereal *dl, integer
+ *model, doublereal *condl, doublereal *dr, integer *moder, doublereal
+ *condr, char *pivtng, integer *ipivot, integer *kl, integer *ku,
+ doublereal *sparse, doublereal *anorm, char *pack, doublereal *a,
+ integer *lda, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ integer i__, j, k, kll, kuu, isub, jsub;
+ doublereal temp;
+ integer isym;
+ doublereal alpha;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ integer ipack;
+ extern logical lsame_(char *, char *);
+ doublereal tempa[1];
+ integer iisub, idist, jjsub, mnmin;
+ logical dzero;
+ integer mnsub;
+ doublereal onorm;
+ integer mxsub, npvts;
+ extern /* Subroutine */ int dlatm1_(integer *, doublereal *, integer *,
+ integer *, integer *, doublereal *, integer *, integer *);
+ extern doublereal dlatm2_(integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, doublereal *, integer
+ *, doublereal *, doublereal *, integer *, integer *, doublereal *)
+ , dlatm3_(integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, doublereal
+ *, integer *, doublereal *, doublereal *, integer *, integer *,
+ doublereal *), dlangb_(char *, integer *, integer *, integer *,
+ doublereal *, integer *, doublereal *), dlange_(char *,
+ integer *, integer *, doublereal *, integer *, doublereal *);
+ integer igrade;
+ extern doublereal dlansb_(char *, char *, integer *, integer *,
+ doublereal *, integer *, doublereal *);
+ logical fulbnd;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical badpvt;
+ extern doublereal dlansp_(char *, char *, integer *, doublereal *,
+ doublereal *), dlansy_(char *, char *, integer *,
+ doublereal *, integer *, doublereal *);
+ integer irsign, ipvtng;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLATMR generates random matrices of various types for testing */
+/* LAPACK programs. */
+
+/* DLATMR operates by applying the following sequence of */
+/* operations: */
+
+/* Generate a matrix A with random entries of distribution DIST */
+/* which is symmetric if SYM='S', and nonsymmetric */
+/* if SYM='N'. */
+
+/* Set the diagonal to D, where D may be input or */
+/* computed according to MODE, COND, DMAX and RSIGN */
+/* as described below. */
+
+/* Grade the matrix, if desired, from the left and/or right */
+/* as specified by GRADE. The inputs DL, MODEL, CONDL, DR, */
+/* MODER and CONDR also determine the grading as described */
+/* below. */
+
+/* Permute, if desired, the rows and/or columns as specified by */
+/* PIVTNG and IPIVOT. */
+
+/* Set random entries to zero, if desired, to get a random sparse */
+/* matrix as specified by SPARSE. */
+
+/* Make A a band matrix, if desired, by zeroing out the matrix */
+/* outside a band of lower bandwidth KL and upper bandwidth KU. */
+
+/* Scale A, if desired, to have maximum entry ANORM. */
+
+/* Pack the matrix if desired. Options specified by PACK are: */
+/* no packing */
+/* zero out upper half (if symmetric) */
+/* zero out lower half (if symmetric) */
+/* store the upper half columnwise (if symmetric or */
+/* square upper triangular) */
+/* store the lower half columnwise (if symmetric or */
+/* square lower triangular) */
+/* same as upper half rowwise if symmetric */
+/* store the lower triangle in banded format (if symmetric) */
+/* store the upper triangle in banded format (if symmetric) */
+/* store the entire matrix in banded format */
+
+/* Note: If two calls to DLATMR differ only in the PACK parameter, */
+/* they will generate mathematically equivalent matrices. */
+
+/* If two calls to DLATMR both have full bandwidth (KL = M-1 */
+/* and KU = N-1), and differ only in the PIVTNG and PACK */
+/* parameters, then the matrices generated will differ only */
+/* in the order of the rows and/or columns, and otherwise */
+/* contain the same data. This consistency cannot be and */
+/* is not maintained with less than full bandwidth. */
+
+/* Arguments */
+/* ========= */
+
+/* M - INTEGER */
+/* Number of rows of A. Not modified. */
+
+/* N - INTEGER */
+/* Number of columns of A. Not modified. */
+
+/* DIST - CHARACTER*1 */
+/* On entry, DIST specifies the type of distribution to be used */
+/* to generate a random matrix . */
+/* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */
+/* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */
+/* 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. They should lie between 0 and 4095 inclusive, */
+/* and ISEED(4) should be odd. The random number generator */
+/* uses a linear congruential sequence limited to small */
+/* integers, and so should produce machine independent */
+/* random numbers. The values of ISEED are changed on */
+/* exit, and can be used in the next call to DLATMR */
+/* to continue the same random number sequence. */
+/* Changed on exit. */
+
+/* SYM - CHARACTER*1 */
+/* If SYM='S' or 'H', generated matrix is symmetric. */
+/* If SYM='N', generated matrix is nonsymmetric. */
+/* Not modified. */
+
+/* D - DOUBLE PRECISION array, dimension (min(M,N)) */
+/* On entry this array specifies the diagonal entries */
+/* of the diagonal of A. D may either be specified */
+/* on entry, or set according to MODE and COND as described */
+/* below. May be changed on exit if MODE is nonzero. */
+
+/* MODE - INTEGER */
+/* On entry describes how D is to be used: */
+/* MODE = 0 means use D as input */
+/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
+/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
+/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
+/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* MODE = 5 sets D to random numbers in the range */
+/* ( 1/COND , 1 ) such that their logarithms */
+/* are uniformly distributed. */
+/* MODE = 6 set D to random numbers from same distribution */
+/* as the rest of the matrix. */
+/* MODE < 0 has the same meaning as ABS(MODE), except that */
+/* the order of the elements of D is reversed. */
+/* Thus if MODE is positive, D has entries ranging from */
+/* 1 to 1/COND, if negative, from 1/COND to 1, */
+/* Not modified. */
+
+/* COND - DOUBLE PRECISION */
+/* On entry, used as described under MODE above. */
+/* If used, it must be >= 1. Not modified. */
+
+/* DMAX - DOUBLE PRECISION */
+/* If MODE neither -6, 0 nor 6, the diagonal is scaled by */
+/* DMAX / max(abs(D(i))), so that maximum absolute entry */
+/* of diagonal is abs(DMAX). If DMAX is negative (or zero), */
+/* diagonal will be scaled by a negative number (or zero). */
+
+/* RSIGN - CHARACTER*1 */
+/* If MODE neither -6, 0 nor 6, specifies sign of diagonal */
+/* as follows: */
+/* 'T' => diagonal entries are multiplied by 1 or -1 */
+/* with probability .5 */
+/* 'F' => diagonal unchanged */
+/* Not modified. */
+
+/* GRADE - CHARACTER*1 */
+/* Specifies grading of matrix as follows: */
+/* 'N' => no grading */
+/* 'L' => matrix premultiplied by diag( DL ) */
+/* (only if matrix nonsymmetric) */
+/* 'R' => matrix postmultiplied by diag( DR ) */
+/* (only if matrix nonsymmetric) */
+/* 'B' => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DR ) */
+/* (only if matrix nonsymmetric) */
+/* 'S' or 'H' => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DL ) */
+/* ('S' for symmetric, or 'H' for Hermitian) */
+/* 'E' => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by inv( diag( DL ) ) */
+/* ( 'E' for eigenvalue invariance) */
+/* (only if matrix nonsymmetric) */
+/* Note: if GRADE='E', then M must equal N. */
+/* Not modified. */
+
+/* DL - DOUBLE PRECISION array, dimension (M) */
+/* If MODEL=0, then on entry this array specifies the diagonal */
+/* entries of a diagonal matrix used as described under GRADE */
+/* above. If MODEL is not zero, then DL will be set according */
+/* to MODEL and CONDL, analogous to the way D is set according */
+/* to MODE and COND (except there is no DMAX parameter for DL). */
+/* If GRADE='E', then DL cannot have zero entries. */
+/* Not referenced if GRADE = 'N' or 'R'. Changed on exit. */
+
+/* MODEL - INTEGER */
+/* This specifies how the diagonal array DL is to be computed, */
+/* just as MODE specifies how D is to be computed. */
+/* Not modified. */
+
+/* CONDL - DOUBLE PRECISION */
+/* When MODEL is not zero, this specifies the condition number */
+/* of the computed DL. Not modified. */
+
+/* DR - DOUBLE PRECISION array, dimension (N) */
+/* If MODER=0, then on entry this array specifies the diagonal */
+/* entries of a diagonal matrix used as described under GRADE */
+/* above. If MODER is not zero, then DR will be set according */
+/* to MODER and CONDR, analogous to the way D is set according */
+/* to MODE and COND (except there is no DMAX parameter for DR). */
+/* Not referenced if GRADE = 'N', 'L', 'H', 'S' or 'E'. */
+/* Changed on exit. */
+
+/* MODER - INTEGER */
+/* This specifies how the diagonal array DR is to be computed, */
+/* just as MODE specifies how D is to be computed. */
+/* Not modified. */
+
+/* CONDR - DOUBLE PRECISION */
+/* When MODER is not zero, this specifies the condition number */
+/* of the computed DR. Not modified. */
+
+/* PIVTNG - CHARACTER*1 */
+/* On entry specifies pivoting permutations as follows: */
+/* 'N' or ' ' => none. */
+/* 'L' => left or row pivoting (matrix must be nonsymmetric). */
+/* 'R' => right or column pivoting (matrix must be */
+/* nonsymmetric). */
+/* 'B' or 'F' => both or full pivoting, i.e., on both sides. */
+/* In this case, M must equal N */
+
+/* If two calls to DLATMR both have full bandwidth (KL = M-1 */
+/* and KU = N-1), and differ only in the PIVTNG and PACK */
+/* parameters, then the matrices generated will differ only */
+/* in the order of the rows and/or columns, and otherwise */
+/* contain the same data. This consistency cannot be */
+/* maintained with less than full bandwidth. */
+
+/* IPIVOT - INTEGER array, dimension (N or M) */
+/* This array specifies the permutation used. After the */
+/* basic matrix is generated, the rows, columns, or both */
+/* are permuted. If, say, row pivoting is selected, DLATMR */
+/* starts with the *last* row and interchanges the M-th and */
+/* IPIVOT(M)-th rows, then moves to the next-to-last row, */
+/* interchanging the (M-1)-th and the IPIVOT(M-1)-th rows, */
+/* and so on. In terms of "2-cycles", the permutation is */
+/* (1 IPIVOT(1)) (2 IPIVOT(2)) ... (M IPIVOT(M)) */
+/* where the rightmost cycle is applied first. This is the */
+/* *inverse* of the effect of pivoting in LINPACK. The idea */
+/* is that factoring (with pivoting) an identity matrix */
+/* which has been inverse-pivoted in this way should */
+/* result in a pivot vector identical to IPIVOT. */
+/* Not referenced if PIVTNG = 'N'. Not modified. */
+
+/* SPARSE - DOUBLE PRECISION */
+/* On entry specifies the sparsity of the matrix if a sparse */
+/* matrix is to be generated. SPARSE should lie between */
+/* 0 and 1. To generate a sparse matrix, for each matrix entry */
+/* a uniform ( 0, 1 ) random number x is generated and */
+/* compared to SPARSE; if x is larger the matrix entry */
+/* is unchanged and if x is smaller the entry is set */
+/* to zero. Thus on the average a fraction SPARSE of the */
+/* entries will be set to zero. */
+/* Not modified. */
+
+/* KL - INTEGER */
+/* On entry specifies the lower bandwidth of the matrix. For */
+/* example, KL=0 implies upper triangular, KL=1 implies upper */
+/* Hessenberg, and KL at least M-1 implies the matrix is not */
+/* banded. Must equal KU if matrix is symmetric. */
+/* Not modified. */
+
+/* KU - INTEGER */
+/* On entry specifies the upper bandwidth of the matrix. For */
+/* example, KU=0 implies lower triangular, KU=1 implies lower */
+/* Hessenberg, and KU at least N-1 implies the matrix is not */
+/* banded. Must equal KL if matrix is symmetric. */
+/* Not modified. */
+
+/* ANORM - DOUBLE PRECISION */
+/* On entry specifies maximum entry of output matrix */
+/* (output matrix will by multiplied by a constant so that */
+/* its largest absolute entry equal ANORM) */
+/* if ANORM is nonnegative. If ANORM is negative no scaling */
+/* is done. Not modified. */
+
+/* PACK - CHARACTER*1 */
+/* On entry specifies packing of matrix as follows: */
+/* 'N' => no packing */
+/* 'U' => zero out all subdiagonal entries (if symmetric) */
+/* 'L' => zero out all superdiagonal entries (if symmetric) */
+/* 'C' => store the upper triangle columnwise */
+/* (only if matrix symmetric or square upper triangular) */
+/* 'R' => store the lower triangle columnwise */
+/* (only if matrix symmetric or square lower triangular) */
+/* (same as upper half rowwise if symmetric) */
+/* 'B' => store the lower triangle in band storage scheme */
+/* (only if matrix symmetric) */
+/* 'Q' => store the upper triangle in band storage scheme */
+/* (only if matrix symmetric) */
+/* 'Z' => store the entire matrix in band storage scheme */
+/* (pivoting can be provided for by using this */
+/* option to store A in the trailing rows of */
+/* the allocated storage) */
+
+/* Using these options, the various LAPACK packed and banded */
+/* storage schemes can be obtained: */
+/* GB - use 'Z' */
+/* PB, SB or TB - use 'B' or 'Q' */
+/* PP, SP or TP - use 'C' or 'R' */
+
+/* If two calls to DLATMR differ only in the PACK parameter, */
+/* they will generate mathematically equivalent matrices. */
+/* Not modified. */
+
+/* A - DOUBLE PRECISION array, dimension (LDA,N) */
+/* On exit A is the desired test matrix. Only those */
+/* entries of A which are significant on output */
+/* will be referenced (even if A is in packed or band */
+/* storage format). The 'unoccupied corners' of A in */
+/* band format will be zeroed out. */
+
+/* LDA - INTEGER */
+/* on entry LDA specifies the first dimension of A as */
+/* declared in the calling program. */
+/* If PACK='N', 'U' or 'L', LDA must be at least max ( 1, M ). */
+/* If PACK='C' or 'R', LDA must be at least 1. */
+/* If PACK='B', or 'Q', LDA must be MIN ( KU+1, N ) */
+/* If PACK='Z', LDA must be at least KUU+KLL+1, where */
+/* KUU = MIN ( KU, N-1 ) and KLL = MIN ( KL, N-1 ) */
+/* Not modified. */
+
+/* IWORK - INTEGER array, dimension ( N or M) */
+/* Workspace. Not referenced if PIVTNG = 'N'. Changed on exit. */
+
+/* INFO - INTEGER */
+/* Error parameter on exit: */
+/* 0 => normal return */
+/* -1 => M negative or unequal to N and SYM='S' or 'H' */
+/* -2 => N negative */
+/* -3 => DIST illegal string */
+/* -5 => SYM illegal string */
+/* -7 => MODE not in range -6 to 6 */
+/* -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */
+/* -10 => MODE neither -6, 0 nor 6 and RSIGN illegal string */
+/* -11 => GRADE illegal string, or GRADE='E' and */
+/* M not equal to N, or GRADE='L', 'R', 'B' or 'E' and */
+/* SYM = 'S' or 'H' */
+/* -12 => GRADE = 'E' and DL contains zero */
+/* -13 => MODEL not in range -6 to 6 and GRADE= 'L', 'B', 'H', */
+/* 'S' or 'E' */
+/* -14 => CONDL less than 1.0, GRADE='L', 'B', 'H', 'S' or 'E', */
+/* and MODEL neither -6, 0 nor 6 */
+/* -16 => MODER not in range -6 to 6 and GRADE= 'R' or 'B' */
+/* -17 => CONDR less than 1.0, GRADE='R' or 'B', and */
+/* MODER neither -6, 0 nor 6 */
+/* -18 => PIVTNG illegal string, or PIVTNG='B' or 'F' and */
+/* M not equal to N, or PIVTNG='L' or 'R' and SYM='S' */
+/* or 'H' */
+/* -19 => IPIVOT contains out of range number and */
+/* PIVTNG not equal to 'N' */
+/* -20 => KL negative */
+/* -21 => KU negative, or SYM='S' or 'H' and KU not equal to KL */
+/* -22 => SPARSE not in range 0. to 1. */
+/* -24 => PACK illegal string, or PACK='U', 'L', 'B' or 'Q' */
+/* and SYM='N', or PACK='C' and SYM='N' and either KL */
+/* not equal to 0 or N not equal to M, or PACK='R' and */
+/* SYM='N', and either KU not equal to 0 or N not equal */
+/* to M */
+/* -26 => LDA too small */
+/* 1 => Error return from DLATM1 (computing D) */
+/* 2 => Cannot scale diagonal to DMAX (max. entry is 0) */
+/* 3 => Error return from DLATM1 (computing DL) */
+/* 4 => Error return from DLATM1 (computing DR) */
+/* 5 => ANORM is positive, but matrix constructed prior to */
+/* attempting to scale it to have norm ANORM, is zero */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Decode and Test the input parameters. */
+/* Initialize flags & seed. */
+
+ /* Parameter adjustments */
+ --iseed;
+ --d__;
+ --dl;
+ --dr;
+ --ipivot;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Decode DIST */
+
+ if (lsame_(dist, "U")) {
+ idist = 1;
+ } else if (lsame_(dist, "S")) {
+ idist = 2;
+ } else if (lsame_(dist, "N")) {
+ idist = 3;
+ } else {
+ idist = -1;
+ }
+
+/* Decode SYM */
+
+ if (lsame_(sym, "S")) {
+ isym = 0;
+ } else if (lsame_(sym, "N")) {
+ isym = 1;
+ } else if (lsame_(sym, "H")) {
+ isym = 0;
+ } else {
+ isym = -1;
+ }
+
+/* Decode RSIGN */
+
+ if (lsame_(rsign, "F")) {
+ irsign = 0;
+ } else if (lsame_(rsign, "T")) {
+ irsign = 1;
+ } else {
+ irsign = -1;
+ }
+
+/* Decode PIVTNG */
+
+ if (lsame_(pivtng, "N")) {
+ ipvtng = 0;
+ } else if (lsame_(pivtng, " ")) {
+ ipvtng = 0;
+ } else if (lsame_(pivtng, "L")) {
+ ipvtng = 1;
+ npvts = *m;
+ } else if (lsame_(pivtng, "R")) {
+ ipvtng = 2;
+ npvts = *n;
+ } else if (lsame_(pivtng, "B")) {
+ ipvtng = 3;
+ npvts = min(*n,*m);
+ } else if (lsame_(pivtng, "F")) {
+ ipvtng = 3;
+ npvts = min(*n,*m);
+ } else {
+ ipvtng = -1;
+ }
+
+/* Decode GRADE */
+
+ if (lsame_(grade, "N")) {
+ igrade = 0;
+ } else if (lsame_(grade, "L")) {
+ igrade = 1;
+ } else if (lsame_(grade, "R")) {
+ igrade = 2;
+ } else if (lsame_(grade, "B")) {
+ igrade = 3;
+ } else if (lsame_(grade, "E")) {
+ igrade = 4;
+ } else if (lsame_(grade, "H") || lsame_(grade,
+ "S")) {
+ igrade = 5;
+ } else {
+ igrade = -1;
+ }
+
+/* Decode PACK */
+
+ if (lsame_(pack, "N")) {
+ ipack = 0;
+ } else if (lsame_(pack, "U")) {
+ ipack = 1;
+ } else if (lsame_(pack, "L")) {
+ ipack = 2;
+ } else if (lsame_(pack, "C")) {
+ ipack = 3;
+ } else if (lsame_(pack, "R")) {
+ ipack = 4;
+ } else if (lsame_(pack, "B")) {
+ ipack = 5;
+ } else if (lsame_(pack, "Q")) {
+ ipack = 6;
+ } else if (lsame_(pack, "Z")) {
+ ipack = 7;
+ } else {
+ ipack = -1;
+ }
+
+/* Set certain internal parameters */
+
+ mnmin = min(*m,*n);
+/* Computing MIN */
+ i__1 = *kl, i__2 = *m - 1;
+ kll = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *ku, i__2 = *n - 1;
+ kuu = min(i__1,i__2);
+
+/* If inv(DL) is used, check to see if DL has a zero entry. */
+
+ dzero = FALSE_;
+ if (igrade == 4 && *model == 0) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (dl[i__] == 0.) {
+ dzero = TRUE_;
+ }
+/* L10: */
+ }
+ }
+
+/* Check values in IPIVOT */
+
+ badpvt = FALSE_;
+ if (ipvtng > 0) {
+ i__1 = npvts;
+ for (j = 1; j <= i__1; ++j) {
+ if (ipivot[j] <= 0 || ipivot[j] > npvts) {
+ badpvt = TRUE_;
+ }
+/* L20: */
+ }
+ }
+
+/* Set INFO if an error */
+
+ if (*m < 0) {
+ *info = -1;
+ } else if (*m != *n && isym == 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (idist == -1) {
+ *info = -3;
+ } else if (isym == -1) {
+ *info = -5;
+ } else if (*mode < -6 || *mode > 6) {
+ *info = -7;
+ } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.) {
+ *info = -8;
+ } else if (*mode != -6 && *mode != 0 && *mode != 6 && irsign == -1) {
+ *info = -10;
+ } else if (igrade == -1 || igrade == 4 && *m != *n || igrade >= 1 &&
+ igrade <= 4 && isym == 0) {
+ *info = -11;
+ } else if (igrade == 4 && dzero) {
+ *info = -12;
+ } else if ((igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5) && (
+ *model < -6 || *model > 6)) {
+ *info = -13;
+ } else if ((igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5) && (
+ *model != -6 && *model != 0 && *model != 6) && *condl < 1.) {
+ *info = -14;
+ } else if ((igrade == 2 || igrade == 3) && (*moder < -6 || *moder > 6)) {
+ *info = -16;
+ } else if ((igrade == 2 || igrade == 3) && (*moder != -6 && *moder != 0 &&
+ *moder != 6) && *condr < 1.) {
+ *info = -17;
+ } else if (ipvtng == -1 || ipvtng == 3 && *m != *n || (ipvtng == 1 ||
+ ipvtng == 2) && isym == 0) {
+ *info = -18;
+ } else if (ipvtng != 0 && badpvt) {
+ *info = -19;
+ } else if (*kl < 0) {
+ *info = -20;
+ } else if (*ku < 0 || isym == 0 && *kl != *ku) {
+ *info = -21;
+ } else if (*sparse < 0. || *sparse > 1.) {
+ *info = -22;
+ } else if (ipack == -1 || (ipack == 1 || ipack == 2 || ipack == 5 ||
+ ipack == 6) && isym == 1 || ipack == 3 && isym == 1 && (*kl != 0
+ || *m != *n) || ipack == 4 && isym == 1 && (*ku != 0 || *m != *n))
+ {
+ *info = -24;
+ } else if ((ipack == 0 || ipack == 1 || ipack == 2) && *lda < max(1,*m) ||
+ (ipack == 3 || ipack == 4) && *lda < 1 || (ipack == 5 || ipack ==
+ 6) && *lda < kuu + 1 || ipack == 7 && *lda < kll + kuu + 1) {
+ *info = -26;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLATMR", &i__1);
+ return 0;
+ }
+
+/* Decide if we can pivot consistently */
+
+ fulbnd = FALSE_;
+ if (kuu == *n - 1 && kll == *m - 1) {
+ fulbnd = TRUE_;
+ }
+
+/* Initialize random number generator */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
+/* L30: */
+ }
+
+ iseed[4] = (iseed[4] / 2 << 1) + 1;
+
+/* 2) Set up D, DL, and DR, if indicated. */
+
+/* Compute D according to COND and MODE */
+
+ dlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, info);
+ if (*info != 0) {
+ *info = 1;
+ return 0;
+ }
+ if (*mode != 0 && *mode != -6 && *mode != 6) {
+
+/* Scale by DMAX */
+
+ temp = abs(d__[1]);
+ i__1 = mnmin;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = temp, d__3 = (d__1 = d__[i__], abs(d__1));
+ temp = max(d__2,d__3);
+/* L40: */
+ }
+ if (temp == 0. && *dmax__ != 0.) {
+ *info = 2;
+ return 0;
+ }
+ if (temp != 0.) {
+ alpha = *dmax__ / temp;
+ } else {
+ alpha = 1.;
+ }
+ i__1 = mnmin;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = alpha * d__[i__];
+/* L50: */
+ }
+
+ }
+
+/* Compute DL if grading set */
+
+ if (igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5) {
+ dlatm1_(model, condl, &c__0, &idist, &iseed[1], &dl[1], m, info);
+ if (*info != 0) {
+ *info = 3;
+ return 0;
+ }
+ }
+
+/* Compute DR if grading set */
+
+ if (igrade == 2 || igrade == 3) {
+ dlatm1_(moder, condr, &c__0, &idist, &iseed[1], &dr[1], n, info);
+ if (*info != 0) {
+ *info = 4;
+ return 0;
+ }
+ }
+
+/* 3) Generate IWORK if pivoting */
+
+ if (ipvtng > 0) {
+ i__1 = npvts;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ iwork[i__] = i__;
+/* L60: */
+ }
+ if (fulbnd) {
+ i__1 = npvts;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ k = ipivot[i__];
+ j = iwork[i__];
+ iwork[i__] = iwork[k];
+ iwork[k] = j;
+/* L70: */
+ }
+ } else {
+ for (i__ = npvts; i__ >= 1; --i__) {
+ k = ipivot[i__];
+ j = iwork[i__];
+ iwork[i__] = iwork[k];
+ iwork[k] = j;
+/* L80: */
+ }
+ }
+ }
+
+/* 4) Generate matrices for each kind of PACKing */
+/* Always sweep matrix columnwise (if symmetric, upper */
+/* half only) so that matrix generated does not depend */
+/* on PACK */
+
+ if (fulbnd) {
+
+/* Use DLATM3 so matrices generated with differing PIVOTing only */
+/* differ only in the order of their rows and/or columns. */
+
+ if (ipack == 0) {
+ if (isym == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ a[isub + jsub * a_dim1] = temp;
+ a[jsub + isub * a_dim1] = temp;
+/* L90: */
+ }
+/* L100: */
+ }
+ } else if (isym == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ a[isub + jsub * a_dim1] = temp;
+/* L110: */
+ }
+/* L120: */
+ }
+ }
+
+ } else if (ipack == 1) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ a[mnsub + mxsub * a_dim1] = temp;
+ if (mnsub != mxsub) {
+ a[mxsub + mnsub * a_dim1] = 0.;
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+
+ } else if (ipack == 2) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ a[mxsub + mnsub * a_dim1] = temp;
+ if (mnsub != mxsub) {
+ a[mnsub + mxsub * a_dim1] = 0.;
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+
+ } else if (ipack == 3) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+
+/* Compute K = location of (ISUB,JSUB) entry in packed */
+/* array */
+
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ k = mxsub * (mxsub - 1) / 2 + mnsub;
+
+/* Convert K to (IISUB,JJSUB) location */
+
+ jjsub = (k - 1) / *lda + 1;
+ iisub = k - *lda * (jjsub - 1);
+
+ a[iisub + jjsub * a_dim1] = temp;
+/* L170: */
+ }
+/* L180: */
+ }
+
+ } else if (ipack == 4) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+
+/* Compute K = location of (I,J) entry in packed array */
+
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ if (mnsub == 1) {
+ k = mxsub;
+ } else {
+ k = *n * (*n + 1) / 2 - (*n - mnsub + 1) * (*n -
+ mnsub + 2) / 2 + mxsub - mnsub + 1;
+ }
+
+/* Convert K to (IISUB,JJSUB) location */
+
+ jjsub = (k - 1) / *lda + 1;
+ iisub = k - *lda * (jjsub - 1);
+
+ a[iisub + jjsub * a_dim1] = temp;
+/* L190: */
+ }
+/* L200: */
+ }
+
+ } else if (ipack == 5) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ if (i__ < 1) {
+ a[j - i__ + 1 + (i__ + *n) * a_dim1] = 0.;
+ } else {
+ temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ a[mxsub - mnsub + 1 + mnsub * a_dim1] = temp;
+ }
+/* L210: */
+ }
+/* L220: */
+ }
+
+ } else if (ipack == 6) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ a[mnsub - mxsub + kuu + 1 + mxsub * a_dim1] = temp;
+/* L230: */
+ }
+/* L240: */
+ }
+
+ } else if (ipack == 7) {
+
+ if (isym == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ a[mnsub - mxsub + kuu + 1 + mxsub * a_dim1] = temp;
+ if (i__ < 1) {
+ a[j - i__ + 1 + kuu + (i__ + *n) * a_dim1] = 0.;
+ }
+ if (i__ >= 1 && mnsub != mxsub) {
+ a[mxsub - mnsub + 1 + kuu + mnsub * a_dim1] =
+ temp;
+ }
+/* L250: */
+ }
+/* L260: */
+ }
+ } else if (isym == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + kll;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ a[isub - jsub + kuu + 1 + jsub * a_dim1] = temp;
+/* L270: */
+ }
+/* L280: */
+ }
+ }
+
+ }
+
+ } else {
+
+/* Use DLATM2 */
+
+ if (ipack == 0) {
+ if (isym == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = dlatm2_(m, n, &i__, &j, kl, ku,
+ &idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ a[j + i__ * a_dim1] = a[i__ + j * a_dim1];
+/* L290: */
+ }
+/* L300: */
+ }
+ } else if (isym == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = dlatm2_(m, n, &i__, &j, kl, ku,
+ &idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+/* L310: */
+ }
+/* L320: */
+ }
+ }
+
+ } else if (ipack == 1) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = dlatm2_(m, n, &i__, &j, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ if (i__ != j) {
+ a[j + i__ * a_dim1] = 0.;
+ }
+/* L330: */
+ }
+/* L340: */
+ }
+
+ } else if (ipack == 2) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[j + i__ * a_dim1] = dlatm2_(m, n, &i__, &j, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ if (i__ != j) {
+ a[i__ + j * a_dim1] = 0.;
+ }
+/* L350: */
+ }
+/* L360: */
+ }
+
+ } else if (ipack == 3) {
+
+ isub = 0;
+ jsub = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ++isub;
+ if (isub > *lda) {
+ isub = 1;
+ ++jsub;
+ }
+ a[isub + jsub * a_dim1] = dlatm2_(m, n, &i__, &j, kl, ku,
+ &idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[
+ 1], &ipvtng, &iwork[1], sparse);
+/* L370: */
+ }
+/* L380: */
+ }
+
+ } else if (ipack == 4) {
+
+ if (isym == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+
+/* Compute K = location of (I,J) entry in packed array */
+
+ if (i__ == 1) {
+ k = j;
+ } else {
+ k = *n * (*n + 1) / 2 - (*n - i__ + 1) * (*n -
+ i__ + 2) / 2 + j - i__ + 1;
+ }
+
+/* Convert K to (ISUB,JSUB) location */
+
+ jsub = (k - 1) / *lda + 1;
+ isub = k - *lda * (jsub - 1);
+
+ a[isub + jsub * a_dim1] = dlatm2_(m, n, &i__, &j, kl,
+ ku, &idist, &iseed[1], &d__[1], &igrade, &dl[
+ 1], &dr[1], &ipvtng, &iwork[1], sparse);
+/* L390: */
+ }
+/* L400: */
+ }
+ } else {
+ isub = 0;
+ jsub = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ++isub;
+ if (isub > *lda) {
+ isub = 1;
+ ++jsub;
+ }
+ a[isub + jsub * a_dim1] = dlatm2_(m, n, &i__, &j, kl,
+ ku, &idist, &iseed[1], &d__[1], &igrade, &dl[
+ 1], &dr[1], &ipvtng, &iwork[1], sparse);
+/* L410: */
+ }
+/* L420: */
+ }
+ }
+
+ } else if (ipack == 5) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ if (i__ < 1) {
+ a[j - i__ + 1 + (i__ + *n) * a_dim1] = 0.;
+ } else {
+ a[j - i__ + 1 + i__ * a_dim1] = dlatm2_(m, n, &i__, &
+ j, kl, ku, &idist, &iseed[1], &d__[1], &
+ igrade, &dl[1], &dr[1], &ipvtng, &iwork[1],
+ sparse);
+ }
+/* L430: */
+ }
+/* L440: */
+ }
+
+ } else if (ipack == 6) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ a[i__ - j + kuu + 1 + j * a_dim1] = dlatm2_(m, n, &i__, &
+ j, kl, ku, &idist, &iseed[1], &d__[1], &igrade, &
+ dl[1], &dr[1], &ipvtng, &iwork[1], sparse);
+/* L450: */
+ }
+/* L460: */
+ }
+
+ } else if (ipack == 7) {
+
+ if (isym == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ a[i__ - j + kuu + 1 + j * a_dim1] = dlatm2_(m, n, &
+ i__, &j, kl, ku, &idist, &iseed[1], &d__[1], &
+ igrade, &dl[1], &dr[1], &ipvtng, &iwork[1],
+ sparse);
+ if (i__ < 1) {
+ a[j - i__ + 1 + kuu + (i__ + *n) * a_dim1] = 0.;
+ }
+ if (i__ >= 1 && i__ != j) {
+ a[j - i__ + 1 + kuu + i__ * a_dim1] = a[i__ - j +
+ kuu + 1 + j * a_dim1];
+ }
+/* L470: */
+ }
+/* L480: */
+ }
+ } else if (isym == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + kll;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ a[i__ - j + kuu + 1 + j * a_dim1] = dlatm2_(m, n, &
+ i__, &j, kl, ku, &idist, &iseed[1], &d__[1], &
+ igrade, &dl[1], &dr[1], &ipvtng, &iwork[1],
+ sparse);
+/* L490: */
+ }
+/* L500: */
+ }
+ }
+
+ }
+
+ }
+
+/* 5) Scaling the norm */
+
+ if (ipack == 0) {
+ onorm = dlange_("M", m, n, &a[a_offset], lda, tempa);
+ } else if (ipack == 1) {
+ onorm = dlansy_("M", "U", n, &a[a_offset], lda, tempa);
+ } else if (ipack == 2) {
+ onorm = dlansy_("M", "L", n, &a[a_offset], lda, tempa);
+ } else if (ipack == 3) {
+ onorm = dlansp_("M", "U", n, &a[a_offset], tempa);
+ } else if (ipack == 4) {
+ onorm = dlansp_("M", "L", n, &a[a_offset], tempa);
+ } else if (ipack == 5) {
+ onorm = dlansb_("M", "L", n, &kll, &a[a_offset], lda, tempa);
+ } else if (ipack == 6) {
+ onorm = dlansb_("M", "U", n, &kuu, &a[a_offset], lda, tempa);
+ } else if (ipack == 7) {
+ onorm = dlangb_("M", n, &kll, &kuu, &a[a_offset], lda, tempa);
+ }
+
+ if (*anorm >= 0.) {
+
+ if (*anorm > 0. && onorm == 0.) {
+
+/* Desired scaling impossible */
+
+ *info = 5;
+ return 0;
+
+ } else if (*anorm > 1. && onorm < 1. || *anorm < 1. && onorm > 1.) {
+
+/* Scale carefully to avoid over / underflow */
+
+ if (ipack <= 2) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ d__1 = 1. / onorm;
+ dscal_(m, &d__1, &a[j * a_dim1 + 1], &c__1);
+ dscal_(m, anorm, &a[j * a_dim1 + 1], &c__1);
+/* L510: */
+ }
+
+ } else if (ipack == 3 || ipack == 4) {
+
+ i__1 = *n * (*n + 1) / 2;
+ d__1 = 1. / onorm;
+ dscal_(&i__1, &d__1, &a[a_offset], &c__1);
+ i__1 = *n * (*n + 1) / 2;
+ dscal_(&i__1, anorm, &a[a_offset], &c__1);
+
+ } else if (ipack >= 5) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = kll + kuu + 1;
+ d__1 = 1. / onorm;
+ dscal_(&i__2, &d__1, &a[j * a_dim1 + 1], &c__1);
+ i__2 = kll + kuu + 1;
+ dscal_(&i__2, anorm, &a[j * a_dim1 + 1], &c__1);
+/* L520: */
+ }
+
+ }
+
+ } else {
+
+/* Scale straightforwardly */
+
+ if (ipack <= 2) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ d__1 = *anorm / onorm;
+ dscal_(m, &d__1, &a[j * a_dim1 + 1], &c__1);
+/* L530: */
+ }
+
+ } else if (ipack == 3 || ipack == 4) {
+
+ i__1 = *n * (*n + 1) / 2;
+ d__1 = *anorm / onorm;
+ dscal_(&i__1, &d__1, &a[a_offset], &c__1);
+
+ } else if (ipack >= 5) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = kll + kuu + 1;
+ d__1 = *anorm / onorm;
+ dscal_(&i__2, &d__1, &a[j * a_dim1 + 1], &c__1);
+/* L540: */
+ }
+ }
+
+ }
+
+ }
+
+/* End of DLATMR */
+
+ return 0;
+} /* dlatmr_ */
diff --git a/TESTING/MATGEN/dlatms.c b/TESTING/MATGEN/dlatms.c
new file mode 100644
index 0000000..7a37f7f
--- /dev/null
+++ b/TESTING/MATGEN/dlatms.c
@@ -0,0 +1,1328 @@
+/* dlatms.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b22 = 0.;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int dlatms_(integer *m, integer *n, char *dist, integer *
+ iseed, char *sym, doublereal *d__, integer *mode, doublereal *cond,
+ doublereal *dmax__, integer *kl, integer *ku, char *pack, doublereal *
+ a, integer *lda, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1, d__2, d__3;
+ logical L__1;
+
+ /* Builtin functions */
+ double cos(doublereal), sin(doublereal);
+
+ /* Local variables */
+ doublereal c__;
+ integer i__, j, k;
+ doublereal s;
+ integer ic, jc, nc, il, ir, jr, mr, ir1, ir2, jch, llb, jkl, jku, uub,
+ ilda, icol;
+ doublereal temp;
+ integer irow, isym;
+ doublereal alpha, angle;
+ integer ipack;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ integer ioffg;
+ extern logical lsame_(char *, char *);
+ integer iinfo, idist, mnmin;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer iskew;
+ doublereal extra, dummy;
+ extern /* Subroutine */ int dlatm1_(integer *, doublereal *, integer *,
+ integer *, integer *, doublereal *, integer *, integer *),
+ dlagge_(integer *, integer *, integer *, integer *, doublereal *,
+ doublereal *, integer *, integer *, doublereal *, integer *);
+ integer iendch, ipackg, minlda;
+ extern doublereal dlarnd_(integer *, integer *);
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ dlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *), xerbla_(char *, integer *), dlagsy_(
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ integer *, doublereal *, integer *), dlarot_(logical *, logical *,
+ logical *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, doublereal *);
+ logical iltemp, givens;
+ integer ioffst, irsign;
+ logical ilextr, topdwn;
+ integer isympk;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLATMS generates random matrices with specified singular values */
+/* (or symmetric/hermitian with specified eigenvalues) */
+/* for testing LAPACK programs. */
+
+/* DLATMS operates by applying the following sequence of */
+/* operations: */
+
+/* Set the diagonal to D, where D may be input or */
+/* computed according to MODE, COND, DMAX, and SYM */
+/* as described below. */
+
+/* Generate a matrix with the appropriate band structure, by one */
+/* of two methods: */
+
+/* Method A: */
+/* Generate a dense M x N matrix by multiplying D on the left */
+/* and the right by random unitary matrices, then: */
+
+/* Reduce the bandwidth according to KL and KU, using */
+/* Householder transformations. */
+
+/* Method B: */
+/* Convert the bandwidth-0 (i.e., diagonal) matrix to a */
+/* bandwidth-1 matrix using Givens rotations, "chasing" */
+/* out-of-band elements back, much as in QR; then */
+/* convert the bandwidth-1 to a bandwidth-2 matrix, etc. */
+/* Note that for reasonably small bandwidths (relative to */
+/* M and N) this requires less storage, as a dense matrix */
+/* is not generated. Also, for symmetric matrices, only */
+/* one triangle is generated. */
+
+/* Method A is chosen if the bandwidth is a large fraction of the */
+/* order of the matrix, and LDA is at least M (so a dense */
+/* matrix can be stored.) Method B is chosen if the bandwidth */
+/* is small (< 1/2 N for symmetric, < .3 N+M for */
+/* non-symmetric), or LDA is less than M and not less than the */
+/* bandwidth. */
+
+/* Pack the matrix if desired. Options specified by PACK are: */
+/* no packing */
+/* zero out upper half (if symmetric) */
+/* zero out lower half (if symmetric) */
+/* store the upper half columnwise (if symmetric or upper */
+/* triangular) */
+/* store the lower half columnwise (if symmetric or lower */
+/* triangular) */
+/* store the lower triangle in banded format (if symmetric */
+/* or lower triangular) */
+/* store the upper triangle in banded format (if symmetric */
+/* or upper triangular) */
+/* store the entire matrix in banded format */
+/* If Method B is chosen, and band format is specified, then the */
+/* matrix will be generated in the band format, so no repacking */
+/* will be necessary. */
+
+/* Arguments */
+/* ========= */
+
+/* M - INTEGER */
+/* The number of rows of A. Not modified. */
+
+/* N - INTEGER */
+/* The number of columns of A. Not modified. */
+
+/* DIST - CHARACTER*1 */
+/* On entry, DIST specifies the type of distribution to be used */
+/* to generate the random eigen-/singular values. */
+/* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */
+/* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */
+/* 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension ( 4 ) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. They should lie between 0 and 4095 inclusive, */
+/* and ISEED(4) should be odd. The random number generator */
+/* uses a linear congruential sequence limited to small */
+/* integers, and so should produce machine independent */
+/* random numbers. The values of ISEED are changed on */
+/* exit, and can be used in the next call to DLATMS */
+/* to continue the same random number sequence. */
+/* Changed on exit. */
+
+/* SYM - CHARACTER*1 */
+/* If SYM='S' or 'H', the generated matrix is symmetric, with */
+/* eigenvalues specified by D, COND, MODE, and DMAX; they */
+/* may be positive, negative, or zero. */
+/* If SYM='P', the generated matrix is symmetric, with */
+/* eigenvalues (= singular values) specified by D, COND, */
+/* MODE, and DMAX; they will not be negative. */
+/* If SYM='N', the generated matrix is nonsymmetric, with */
+/* singular values specified by D, COND, MODE, and DMAX; */
+/* they will not be negative. */
+/* Not modified. */
+
+/* D - DOUBLE PRECISION array, dimension ( MIN( M , N ) ) */
+/* This array is used to specify the singular values or */
+/* eigenvalues of A (see SYM, above.) If MODE=0, then D is */
+/* assumed to contain the singular/eigenvalues, otherwise */
+/* they will be computed according to MODE, COND, and DMAX, */
+/* and placed in D. */
+/* Modified if MODE is nonzero. */
+
+/* MODE - INTEGER */
+/* On entry this describes how the singular/eigenvalues are to */
+/* be specified: */
+/* MODE = 0 means use D as input */
+/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
+/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
+/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
+/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* MODE = 5 sets D to random numbers in the range */
+/* ( 1/COND , 1 ) such that their logarithms */
+/* are uniformly distributed. */
+/* MODE = 6 set D to random numbers from same distribution */
+/* as the rest of the matrix. */
+/* MODE < 0 has the same meaning as ABS(MODE), except that */
+/* the order of the elements of D is reversed. */
+/* Thus if MODE is positive, D has entries ranging from */
+/* 1 to 1/COND, if negative, from 1/COND to 1, */
+/* If SYM='S' or 'H', and MODE is neither 0, 6, nor -6, then */
+/* the elements of D will also be multiplied by a random */
+/* sign (i.e., +1 or -1.) */
+/* Not modified. */
+
+/* COND - DOUBLE PRECISION */
+/* On entry, this is used as described under MODE above. */
+/* If used, it must be >= 1. Not modified. */
+
+/* DMAX - DOUBLE PRECISION */
+/* If MODE is neither -6, 0 nor 6, the contents of D, as */
+/* computed according to MODE and COND, will be scaled by */
+/* DMAX / max(abs(D(i))); thus, the maximum absolute eigen- or */
+/* singular value (which is to say the norm) will be abs(DMAX). */
+/* Note that DMAX need not be positive: if DMAX is negative */
+/* (or zero), D will be scaled by a negative number (or zero). */
+/* Not modified. */
+
+/* KL - INTEGER */
+/* This specifies the lower bandwidth of the matrix. For */
+/* example, KL=0 implies upper triangular, KL=1 implies upper */
+/* Hessenberg, and KL being at least M-1 means that the matrix */
+/* has full lower bandwidth. KL must equal KU if the matrix */
+/* is symmetric. */
+/* Not modified. */
+
+/* KU - INTEGER */
+/* This specifies the upper bandwidth of the matrix. For */
+/* example, KU=0 implies lower triangular, KU=1 implies lower */
+/* Hessenberg, and KU being at least N-1 means that the matrix */
+/* has full upper bandwidth. KL must equal KU if the matrix */
+/* is symmetric. */
+/* Not modified. */
+
+/* PACK - CHARACTER*1 */
+/* This specifies packing of matrix as follows: */
+/* 'N' => no packing */
+/* 'U' => zero out all subdiagonal entries (if symmetric) */
+/* 'L' => zero out all superdiagonal entries (if symmetric) */
+/* 'C' => store the upper triangle columnwise */
+/* (only if the matrix is symmetric or upper triangular) */
+/* 'R' => store the lower triangle columnwise */
+/* (only if the matrix is symmetric or lower triangular) */
+/* 'B' => store the lower triangle in band storage scheme */
+/* (only if matrix symmetric or lower triangular) */
+/* 'Q' => store the upper triangle in band storage scheme */
+/* (only if matrix symmetric or upper triangular) */
+/* 'Z' => store the entire matrix in band storage scheme */
+/* (pivoting can be provided for by using this */
+/* option to store A in the trailing rows of */
+/* the allocated storage) */
+
+/* Using these options, the various LAPACK packed and banded */
+/* storage schemes can be obtained: */
+/* GB - use 'Z' */
+/* PB, SB or TB - use 'B' or 'Q' */
+/* PP, SP or TP - use 'C' or 'R' */
+
+/* If two calls to DLATMS differ only in the PACK parameter, */
+/* they will generate mathematically equivalent matrices. */
+/* Not modified. */
+
+/* A - DOUBLE PRECISION array, dimension ( LDA, N ) */
+/* On exit A is the desired test matrix. A is first generated */
+/* in full (unpacked) form, and then packed, if so specified */
+/* by PACK. Thus, the first M elements of the first N */
+/* columns will always be modified. If PACK specifies a */
+/* packed or banded storage scheme, all LDA elements of the */
+/* first N columns will be modified; the elements of the */
+/* array which do not correspond to elements of the generated */
+/* matrix are set to zero. */
+/* Modified. */
+
+/* LDA - INTEGER */
+/* LDA specifies the first dimension of A as declared in the */
+/* calling program. If PACK='N', 'U', 'L', 'C', or 'R', then */
+/* LDA must be at least M. If PACK='B' or 'Q', then LDA must */
+/* be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)). */
+/* If PACK='Z', LDA must be large enough to hold the packed */
+/* array: MIN( KU, N-1) + MIN( KL, M-1) + 1. */
+/* Not modified. */
+
+/* WORK - DOUBLE PRECISION array, dimension ( 3*MAX( N , M ) ) */
+/* Workspace. */
+/* Modified. */
+
+/* INFO - INTEGER */
+/* Error code. On exit, INFO will be set to one of the */
+/* following values: */
+/* 0 => normal return */
+/* -1 => M negative or unequal to N and SYM='S', 'H', or 'P' */
+/* -2 => N negative */
+/* -3 => DIST illegal string */
+/* -5 => SYM illegal string */
+/* -7 => MODE not in range -6 to 6 */
+/* -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */
+/* -10 => KL negative */
+/* -11 => KU negative, or SYM='S' or 'H' and KU not equal to KL */
+/* -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N'; */
+/* or PACK='C' or 'Q' and SYM='N' and KL is not zero; */
+/* or PACK='R' or 'B' and SYM='N' and KU is not zero; */
+/* or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not */
+/* N. */
+/* -14 => LDA is less than M, or PACK='Z' and LDA is less than */
+/* MIN(KU,N-1) + MIN(KL,M-1) + 1. */
+/* 1 => Error return from DLATM1 */
+/* 2 => Cannot scale to DMAX (max. sing. value is 0) */
+/* 3 => Error return from DLAGGE or SLAGSY */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Decode and Test the input parameters. */
+/* Initialize flags & seed. */
+
+ /* Parameter adjustments */
+ --iseed;
+ --d__;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Decode DIST */
+
+ if (lsame_(dist, "U")) {
+ idist = 1;
+ } else if (lsame_(dist, "S")) {
+ idist = 2;
+ } else if (lsame_(dist, "N")) {
+ idist = 3;
+ } else {
+ idist = -1;
+ }
+
+/* Decode SYM */
+
+ if (lsame_(sym, "N")) {
+ isym = 1;
+ irsign = 0;
+ } else if (lsame_(sym, "P")) {
+ isym = 2;
+ irsign = 0;
+ } else if (lsame_(sym, "S")) {
+ isym = 2;
+ irsign = 1;
+ } else if (lsame_(sym, "H")) {
+ isym = 2;
+ irsign = 1;
+ } else {
+ isym = -1;
+ }
+
+/* Decode PACK */
+
+ isympk = 0;
+ if (lsame_(pack, "N")) {
+ ipack = 0;
+ } else if (lsame_(pack, "U")) {
+ ipack = 1;
+ isympk = 1;
+ } else if (lsame_(pack, "L")) {
+ ipack = 2;
+ isympk = 1;
+ } else if (lsame_(pack, "C")) {
+ ipack = 3;
+ isympk = 2;
+ } else if (lsame_(pack, "R")) {
+ ipack = 4;
+ isympk = 3;
+ } else if (lsame_(pack, "B")) {
+ ipack = 5;
+ isympk = 3;
+ } else if (lsame_(pack, "Q")) {
+ ipack = 6;
+ isympk = 2;
+ } else if (lsame_(pack, "Z")) {
+ ipack = 7;
+ } else {
+ ipack = -1;
+ }
+
+/* Set certain internal parameters */
+
+ mnmin = min(*m,*n);
+/* Computing MIN */
+ i__1 = *kl, i__2 = *m - 1;
+ llb = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *ku, i__2 = *n - 1;
+ uub = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *m, i__2 = *n + llb;
+ mr = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *n, i__2 = *m + uub;
+ nc = min(i__1,i__2);
+
+ if (ipack == 5 || ipack == 6) {
+ minlda = uub + 1;
+ } else if (ipack == 7) {
+ minlda = llb + uub + 1;
+ } else {
+ minlda = *m;
+ }
+
+/* Use Givens rotation method if bandwidth small enough, */
+/* or if LDA is too small to store the matrix unpacked. */
+
+ givens = FALSE_;
+ if (isym == 1) {
+/* Computing MAX */
+ i__1 = 1, i__2 = mr + nc;
+ if ((doublereal) (llb + uub) < (doublereal) max(i__1,i__2) * .3) {
+ givens = TRUE_;
+ }
+ } else {
+ if (llb << 1 < *m) {
+ givens = TRUE_;
+ }
+ }
+ if (*lda < *m && *lda >= minlda) {
+ givens = TRUE_;
+ }
+
+/* Set INFO if an error */
+
+ if (*m < 0) {
+ *info = -1;
+ } else if (*m != *n && isym != 1) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (idist == -1) {
+ *info = -3;
+ } else if (isym == -1) {
+ *info = -5;
+ } else if (abs(*mode) > 6) {
+ *info = -7;
+ } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.) {
+ *info = -8;
+ } else if (*kl < 0) {
+ *info = -10;
+ } else if (*ku < 0 || isym != 1 && *kl != *ku) {
+ *info = -11;
+ } else if (ipack == -1 || isympk == 1 && isym == 1 || isympk == 2 && isym
+ == 1 && *kl > 0 || isympk == 3 && isym == 1 && *ku > 0 || isympk
+ != 0 && *m != *n) {
+ *info = -12;
+ } else if (*lda < max(1,minlda)) {
+ *info = -14;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLATMS", &i__1);
+ return 0;
+ }
+
+/* Initialize random number generator */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
+/* L10: */
+ }
+
+ if (iseed[4] % 2 != 1) {
+ ++iseed[4];
+ }
+
+/* 2) Set up D if indicated. */
+
+/* Compute D according to COND and MODE */
+
+ dlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, &iinfo);
+ if (iinfo != 0) {
+ *info = 1;
+ return 0;
+ }
+
+/* Choose Top-Down if D is (apparently) increasing, */
+/* Bottom-Up if D is (apparently) decreasing. */
+
+ if (abs(d__[1]) <= (d__1 = d__[mnmin], abs(d__1))) {
+ topdwn = TRUE_;
+ } else {
+ topdwn = FALSE_;
+ }
+
+ if (*mode != 0 && abs(*mode) != 6) {
+
+/* Scale by DMAX */
+
+ temp = abs(d__[1]);
+ i__1 = mnmin;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = temp, d__3 = (d__1 = d__[i__], abs(d__1));
+ temp = max(d__2,d__3);
+/* L20: */
+ }
+
+ if (temp > 0.) {
+ alpha = *dmax__ / temp;
+ } else {
+ *info = 2;
+ return 0;
+ }
+
+ dscal_(&mnmin, &alpha, &d__[1], &c__1);
+
+ }
+
+/* 3) Generate Banded Matrix using Givens rotations. */
+/* Also the special case of UUB=LLB=0 */
+
+/* Compute Addressing constants to cover all */
+/* storage formats. Whether GE, SY, GB, or SB, */
+/* upper or lower triangle or both, */
+/* the (i,j)-th element is in */
+/* A( i - ISKEW*j + IOFFST, j ) */
+
+ if (ipack > 4) {
+ ilda = *lda - 1;
+ iskew = 1;
+ if (ipack > 5) {
+ ioffst = uub + 1;
+ } else {
+ ioffst = 1;
+ }
+ } else {
+ ilda = *lda;
+ iskew = 0;
+ ioffst = 0;
+ }
+
+/* IPACKG is the format that the matrix is generated in. If this is */
+/* different from IPACK, then the matrix must be repacked at the */
+/* end. It also signals how to compute the norm, for scaling. */
+
+ ipackg = 0;
+ dlaset_("Full", lda, n, &c_b22, &c_b22, &a[a_offset], lda);
+
+/* Diagonal Matrix -- We are done, unless it */
+/* is to be stored SP/PP/TP (PACK='R' or 'C') */
+
+ if (llb == 0 && uub == 0) {
+ i__1 = ilda + 1;
+ dcopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffst + a_dim1], &i__1)
+ ;
+ if (ipack <= 2 || ipack >= 5) {
+ ipackg = ipack;
+ }
+
+ } else if (givens) {
+
+/* Check whether to use Givens rotations, */
+/* Householder transformations, or nothing. */
+
+ if (isym == 1) {
+
+/* Non-symmetric -- A = U D V */
+
+ if (ipack > 4) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+
+ i__1 = ilda + 1;
+ dcopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffst + a_dim1], &
+ i__1);
+
+ if (topdwn) {
+ jkl = 0;
+ i__1 = uub;
+ for (jku = 1; jku <= i__1; ++jku) {
+
+/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */
+
+/* Last row actually rotated is M */
+/* Last column actually rotated is MIN( M+JKU, N ) */
+
+/* Computing MIN */
+ i__3 = *m + jku;
+ i__2 = min(i__3,*n) + jkl - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ extra = 0.;
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ c__ = cos(angle);
+ s = sin(angle);
+/* Computing MAX */
+ i__3 = 1, i__4 = jr - jkl;
+ icol = max(i__3,i__4);
+ if (jr < *m) {
+/* Computing MIN */
+ i__3 = *n, i__4 = jr + jku;
+ il = min(i__3,i__4) + 1 - icol;
+ L__1 = jr > jkl;
+ dlarot_(&c_true, &L__1, &c_false, &il, &c__, &s, &
+ a[jr - iskew * icol + ioffst + icol *
+ a_dim1], &ilda, &extra, &dummy);
+ }
+
+/* Chase "EXTRA" back up */
+
+ ir = jr;
+ ic = icol;
+ i__3 = -jkl - jku;
+ for (jch = jr - jkl; i__3 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__3) {
+ if (ir < *m) {
+ dlartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst
+ + (ic + 1) * a_dim1], &extra, &c__, &
+ s, &dummy);
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jku;
+ irow = max(i__4,i__5);
+ il = ir + 2 - irow;
+ temp = 0.;
+ iltemp = jch > jku;
+ d__1 = -s;
+ dlarot_(&c_false, &iltemp, &c_true, &il, &c__, &
+ d__1, &a[irow - iskew * ic + ioffst + ic *
+ a_dim1], &ilda, &temp, &extra);
+ if (iltemp) {
+ dlartg_(&a[irow + 1 - iskew * (ic + 1) +
+ ioffst + (ic + 1) * a_dim1], &temp, &
+ c__, &s, &dummy);
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jku - jkl;
+ icol = max(i__4,i__5);
+ il = ic + 2 - icol;
+ extra = 0.;
+ L__1 = jch > jku + jkl;
+ d__1 = -s;
+ dlarot_(&c_true, &L__1, &c_true, &il, &c__, &
+ d__1, &a[irow - iskew * icol + ioffst
+ + icol * a_dim1], &ilda, &extra, &
+ temp);
+ ic = icol;
+ ir = irow;
+ }
+/* L30: */
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+
+ jku = uub;
+ i__1 = llb;
+ for (jkl = 1; jkl <= i__1; ++jkl) {
+
+/* Transform from bandwidth JKL-1, JKU to JKL, JKU */
+
+/* Computing MIN */
+ i__3 = *n + jkl;
+ i__2 = min(i__3,*m) + jku - 1;
+ for (jc = 1; jc <= i__2; ++jc) {
+ extra = 0.;
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ c__ = cos(angle);
+ s = sin(angle);
+/* Computing MAX */
+ i__3 = 1, i__4 = jc - jku;
+ irow = max(i__3,i__4);
+ if (jc < *n) {
+/* Computing MIN */
+ i__3 = *m, i__4 = jc + jkl;
+ il = min(i__3,i__4) + 1 - irow;
+ L__1 = jc > jku;
+ dlarot_(&c_false, &L__1, &c_false, &il, &c__, &s,
+ &a[irow - iskew * jc + ioffst + jc *
+ a_dim1], &ilda, &extra, &dummy);
+ }
+
+/* Chase "EXTRA" back up */
+
+ ic = jc;
+ ir = irow;
+ i__3 = -jkl - jku;
+ for (jch = jc - jku; i__3 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__3) {
+ if (ic < *n) {
+ dlartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst
+ + (ic + 1) * a_dim1], &extra, &c__, &
+ s, &dummy);
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jkl;
+ icol = max(i__4,i__5);
+ il = ic + 2 - icol;
+ temp = 0.;
+ iltemp = jch > jkl;
+ d__1 = -s;
+ dlarot_(&c_true, &iltemp, &c_true, &il, &c__, &
+ d__1, &a[ir - iskew * icol + ioffst +
+ icol * a_dim1], &ilda, &temp, &extra);
+ if (iltemp) {
+ dlartg_(&a[ir + 1 - iskew * (icol + 1) +
+ ioffst + (icol + 1) * a_dim1], &temp,
+ &c__, &s, &dummy);
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jkl - jku;
+ irow = max(i__4,i__5);
+ il = ir + 2 - irow;
+ extra = 0.;
+ L__1 = jch > jkl + jku;
+ d__1 = -s;
+ dlarot_(&c_false, &L__1, &c_true, &il, &c__, &
+ d__1, &a[irow - iskew * icol + ioffst
+ + icol * a_dim1], &ilda, &extra, &
+ temp);
+ ic = icol;
+ ir = irow;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+
+ } else {
+
+/* Bottom-Up -- Start at the bottom right. */
+
+ jkl = 0;
+ i__1 = uub;
+ for (jku = 1; jku <= i__1; ++jku) {
+
+/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */
+
+/* First row actually rotated is M */
+/* First column actually rotated is MIN( M+JKU, N ) */
+
+/* Computing MIN */
+ i__2 = *m, i__3 = *n + jkl;
+ iendch = min(i__2,i__3) - 1;
+/* Computing MIN */
+ i__2 = *m + jku;
+ i__3 = 1 - jkl;
+ for (jc = min(i__2,*n) - 1; jc >= i__3; --jc) {
+ extra = 0.;
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ c__ = cos(angle);
+ s = sin(angle);
+/* Computing MAX */
+ i__2 = 1, i__4 = jc - jku + 1;
+ irow = max(i__2,i__4);
+ if (jc > 0) {
+/* Computing MIN */
+ i__2 = *m, i__4 = jc + jkl + 1;
+ il = min(i__2,i__4) + 1 - irow;
+ L__1 = jc + jkl < *m;
+ dlarot_(&c_false, &c_false, &L__1, &il, &c__, &s,
+ &a[irow - iskew * jc + ioffst + jc *
+ a_dim1], &ilda, &dummy, &extra);
+ }
+
+/* Chase "EXTRA" back down */
+
+ ic = jc;
+ i__2 = iendch;
+ i__4 = jkl + jku;
+ for (jch = jc + jkl; i__4 < 0 ? jch >= i__2 : jch <=
+ i__2; jch += i__4) {
+ ilextr = ic > 0;
+ if (ilextr) {
+ dlartg_(&a[jch - iskew * ic + ioffst + ic *
+ a_dim1], &extra, &c__, &s, &dummy);
+ }
+ ic = max(1,ic);
+/* Computing MIN */
+ i__5 = *n - 1, i__6 = jch + jku;
+ icol = min(i__5,i__6);
+ iltemp = jch + jku < *n;
+ temp = 0.;
+ i__5 = icol + 2 - ic;
+ dlarot_(&c_true, &ilextr, &iltemp, &i__5, &c__, &
+ s, &a[jch - iskew * ic + ioffst + ic *
+ a_dim1], &ilda, &extra, &temp);
+ if (iltemp) {
+ dlartg_(&a[jch - iskew * icol + ioffst + icol
+ * a_dim1], &temp, &c__, &s, &dummy);
+/* Computing MIN */
+ i__5 = iendch, i__6 = jch + jkl + jku;
+ il = min(i__5,i__6) + 2 - jch;
+ extra = 0.;
+ L__1 = jch + jkl + jku <= iendch;
+ dlarot_(&c_false, &c_true, &L__1, &il, &c__, &
+ s, &a[jch - iskew * icol + ioffst +
+ icol * a_dim1], &ilda, &temp, &extra);
+ ic = icol;
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+
+ jku = uub;
+ i__1 = llb;
+ for (jkl = 1; jkl <= i__1; ++jkl) {
+
+/* Transform from bandwidth JKL-1, JKU to JKL, JKU */
+
+/* First row actually rotated is MIN( N+JKL, M ) */
+/* First column actually rotated is N */
+
+/* Computing MIN */
+ i__3 = *n, i__4 = *m + jku;
+ iendch = min(i__3,i__4) - 1;
+/* Computing MIN */
+ i__3 = *n + jkl;
+ i__4 = 1 - jku;
+ for (jr = min(i__3,*m) - 1; jr >= i__4; --jr) {
+ extra = 0.;
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ c__ = cos(angle);
+ s = sin(angle);
+/* Computing MAX */
+ i__3 = 1, i__2 = jr - jkl + 1;
+ icol = max(i__3,i__2);
+ if (jr > 0) {
+/* Computing MIN */
+ i__3 = *n, i__2 = jr + jku + 1;
+ il = min(i__3,i__2) + 1 - icol;
+ L__1 = jr + jku < *n;
+ dlarot_(&c_true, &c_false, &L__1, &il, &c__, &s, &
+ a[jr - iskew * icol + ioffst + icol *
+ a_dim1], &ilda, &dummy, &extra);
+ }
+
+/* Chase "EXTRA" back down */
+
+ ir = jr;
+ i__3 = iendch;
+ i__2 = jkl + jku;
+ for (jch = jr + jku; i__2 < 0 ? jch >= i__3 : jch <=
+ i__3; jch += i__2) {
+ ilextr = ir > 0;
+ if (ilextr) {
+ dlartg_(&a[ir - iskew * jch + ioffst + jch *
+ a_dim1], &extra, &c__, &s, &dummy);
+ }
+ ir = max(1,ir);
+/* Computing MIN */
+ i__5 = *m - 1, i__6 = jch + jkl;
+ irow = min(i__5,i__6);
+ iltemp = jch + jkl < *m;
+ temp = 0.;
+ i__5 = irow + 2 - ir;
+ dlarot_(&c_false, &ilextr, &iltemp, &i__5, &c__, &
+ s, &a[ir - iskew * jch + ioffst + jch *
+ a_dim1], &ilda, &extra, &temp);
+ if (iltemp) {
+ dlartg_(&a[irow - iskew * jch + ioffst + jch *
+ a_dim1], &temp, &c__, &s, &dummy);
+/* Computing MIN */
+ i__5 = iendch, i__6 = jch + jkl + jku;
+ il = min(i__5,i__6) + 2 - jch;
+ extra = 0.;
+ L__1 = jch + jkl + jku <= iendch;
+ dlarot_(&c_true, &c_true, &L__1, &il, &c__, &
+ s, &a[irow - iskew * jch + ioffst +
+ jch * a_dim1], &ilda, &temp, &extra);
+ ir = irow;
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+ }
+
+ } else {
+
+/* Symmetric -- A = U D U' */
+
+ ipackg = ipack;
+ ioffg = ioffst;
+
+ if (topdwn) {
+
+/* Top-Down -- Generate Upper triangle only */
+
+ if (ipack >= 5) {
+ ipackg = 6;
+ ioffg = uub + 1;
+ } else {
+ ipackg = 1;
+ }
+ i__1 = ilda + 1;
+ dcopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffg + a_dim1],
+ &i__1);
+
+ i__1 = uub;
+ for (k = 1; k <= i__1; ++k) {
+ i__4 = *n - 1;
+ for (jc = 1; jc <= i__4; ++jc) {
+/* Computing MAX */
+ i__2 = 1, i__3 = jc - k;
+ irow = max(i__2,i__3);
+/* Computing MIN */
+ i__2 = jc + 1, i__3 = k + 2;
+ il = min(i__2,i__3);
+ extra = 0.;
+ temp = a[jc - iskew * (jc + 1) + ioffg + (jc + 1) *
+ a_dim1];
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ c__ = cos(angle);
+ s = sin(angle);
+ L__1 = jc > k;
+ dlarot_(&c_false, &L__1, &c_true, &il, &c__, &s, &a[
+ irow - iskew * jc + ioffg + jc * a_dim1], &
+ ilda, &extra, &temp);
+/* Computing MIN */
+ i__3 = k, i__5 = *n - jc;
+ i__2 = min(i__3,i__5) + 1;
+ dlarot_(&c_true, &c_true, &c_false, &i__2, &c__, &s, &
+ a[(1 - iskew) * jc + ioffg + jc * a_dim1], &
+ ilda, &temp, &dummy);
+
+/* Chase EXTRA back up the matrix */
+
+ icol = jc;
+ i__2 = -k;
+ for (jch = jc - k; i__2 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__2) {
+ dlartg_(&a[jch + 1 - iskew * (icol + 1) + ioffg +
+ (icol + 1) * a_dim1], &extra, &c__, &s, &
+ dummy);
+ temp = a[jch - iskew * (jch + 1) + ioffg + (jch +
+ 1) * a_dim1];
+ i__3 = k + 2;
+ d__1 = -s;
+ dlarot_(&c_true, &c_true, &c_true, &i__3, &c__, &
+ d__1, &a[(1 - iskew) * jch + ioffg + jch *
+ a_dim1], &ilda, &temp, &extra);
+/* Computing MAX */
+ i__3 = 1, i__5 = jch - k;
+ irow = max(i__3,i__5);
+/* Computing MIN */
+ i__3 = jch + 1, i__5 = k + 2;
+ il = min(i__3,i__5);
+ extra = 0.;
+ L__1 = jch > k;
+ d__1 = -s;
+ dlarot_(&c_false, &L__1, &c_true, &il, &c__, &
+ d__1, &a[irow - iskew * jch + ioffg + jch
+ * a_dim1], &ilda, &extra, &temp);
+ icol = jch;
+/* L150: */
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+
+/* If we need lower triangle, copy from upper. Note that */
+/* the order of copying is chosen to work for 'q' -> 'b' */
+
+ if (ipack != ipackg && ipack != 3) {
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ irow = ioffst - iskew * jc;
+/* Computing MIN */
+ i__2 = *n, i__3 = jc + uub;
+ i__4 = min(i__2,i__3);
+ for (jr = jc; jr <= i__4; ++jr) {
+ a[jr + irow + jc * a_dim1] = a[jc - iskew * jr +
+ ioffg + jr * a_dim1];
+/* L180: */
+ }
+/* L190: */
+ }
+ if (ipack == 5) {
+ i__1 = *n;
+ for (jc = *n - uub + 1; jc <= i__1; ++jc) {
+ i__4 = uub + 1;
+ for (jr = *n + 2 - jc; jr <= i__4; ++jr) {
+ a[jr + jc * a_dim1] = 0.;
+/* L200: */
+ }
+/* L210: */
+ }
+ }
+ if (ipackg == 6) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+ }
+ } else {
+
+/* Bottom-Up -- Generate Lower triangle only */
+
+ if (ipack >= 5) {
+ ipackg = 5;
+ if (ipack == 6) {
+ ioffg = 1;
+ }
+ } else {
+ ipackg = 2;
+ }
+ i__1 = ilda + 1;
+ dcopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffg + a_dim1],
+ &i__1);
+
+ i__1 = uub;
+ for (k = 1; k <= i__1; ++k) {
+ for (jc = *n - 1; jc >= 1; --jc) {
+/* Computing MIN */
+ i__4 = *n + 1 - jc, i__2 = k + 2;
+ il = min(i__4,i__2);
+ extra = 0.;
+ temp = a[(1 - iskew) * jc + 1 + ioffg + jc * a_dim1];
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ c__ = cos(angle);
+ s = -sin(angle);
+ L__1 = *n - jc > k;
+ dlarot_(&c_false, &c_true, &L__1, &il, &c__, &s, &a[(
+ 1 - iskew) * jc + ioffg + jc * a_dim1], &ilda,
+ &temp, &extra);
+/* Computing MAX */
+ i__4 = 1, i__2 = jc - k + 1;
+ icol = max(i__4,i__2);
+ i__4 = jc + 2 - icol;
+ dlarot_(&c_true, &c_false, &c_true, &i__4, &c__, &s, &
+ a[jc - iskew * icol + ioffg + icol * a_dim1],
+ &ilda, &dummy, &temp);
+
+/* Chase EXTRA back down the matrix */
+
+ icol = jc;
+ i__4 = *n - 1;
+ i__2 = k;
+ for (jch = jc + k; i__2 < 0 ? jch >= i__4 : jch <=
+ i__4; jch += i__2) {
+ dlartg_(&a[jch - iskew * icol + ioffg + icol *
+ a_dim1], &extra, &c__, &s, &dummy);
+ temp = a[(1 - iskew) * jch + 1 + ioffg + jch *
+ a_dim1];
+ i__3 = k + 2;
+ dlarot_(&c_true, &c_true, &c_true, &i__3, &c__, &
+ s, &a[jch - iskew * icol + ioffg + icol *
+ a_dim1], &ilda, &extra, &temp);
+/* Computing MIN */
+ i__3 = *n + 1 - jch, i__5 = k + 2;
+ il = min(i__3,i__5);
+ extra = 0.;
+ L__1 = *n - jch > k;
+ dlarot_(&c_false, &c_true, &L__1, &il, &c__, &s, &
+ a[(1 - iskew) * jch + ioffg + jch *
+ a_dim1], &ilda, &temp, &extra);
+ icol = jch;
+/* L220: */
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+
+/* If we need upper triangle, copy from lower. Note that */
+/* the order of copying is chosen to work for 'b' -> 'q' */
+
+ if (ipack != ipackg && ipack != 4) {
+ for (jc = *n; jc >= 1; --jc) {
+ irow = ioffst - iskew * jc;
+/* Computing MAX */
+ i__2 = 1, i__4 = jc - uub;
+ i__1 = max(i__2,i__4);
+ for (jr = jc; jr >= i__1; --jr) {
+ a[jr + irow + jc * a_dim1] = a[jc - iskew * jr +
+ ioffg + jr * a_dim1];
+/* L250: */
+ }
+/* L260: */
+ }
+ if (ipack == 6) {
+ i__1 = uub;
+ for (jc = 1; jc <= i__1; ++jc) {
+ i__2 = uub + 1 - jc;
+ for (jr = 1; jr <= i__2; ++jr) {
+ a[jr + jc * a_dim1] = 0.;
+/* L270: */
+ }
+/* L280: */
+ }
+ }
+ if (ipackg == 5) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+ }
+ }
+ }
+
+ } else {
+
+/* 4) Generate Banded Matrix by first */
+/* Rotating by random Unitary matrices, */
+/* then reducing the bandwidth using Householder */
+/* transformations. */
+
+/* Note: we should get here only if LDA .ge. N */
+
+ if (isym == 1) {
+
+/* Non-symmetric -- A = U D V */
+
+ dlagge_(&mr, &nc, &llb, &uub, &d__[1], &a[a_offset], lda, &iseed[
+ 1], &work[1], &iinfo);
+ } else {
+
+/* Symmetric -- A = U D U' */
+
+ dlagsy_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[1],
+ &iinfo);
+
+ }
+ if (iinfo != 0) {
+ *info = 3;
+ return 0;
+ }
+ }
+
+/* 5) Pack the matrix */
+
+ if (ipack != ipackg) {
+ if (ipack == 1) {
+
+/* 'U' -- Upper triangular, not packed */
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L290: */
+ }
+/* L300: */
+ }
+
+ } else if (ipack == 2) {
+
+/* 'L' -- Lower triangular, not packed */
+
+ i__1 = *m;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L310: */
+ }
+/* L320: */
+ }
+
+ } else if (ipack == 3) {
+
+/* 'C' -- Upper triangle packed Columnwise. */
+
+ icol = 1;
+ irow = 0;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ++irow;
+ if (irow > *lda) {
+ irow = 1;
+ ++icol;
+ }
+ a[irow + icol * a_dim1] = a[i__ + j * a_dim1];
+/* L330: */
+ }
+/* L340: */
+ }
+
+ } else if (ipack == 4) {
+
+/* 'R' -- Lower triangle packed Columnwise. */
+
+ icol = 1;
+ irow = 0;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ++irow;
+ if (irow > *lda) {
+ irow = 1;
+ ++icol;
+ }
+ a[irow + icol * a_dim1] = a[i__ + j * a_dim1];
+/* L350: */
+ }
+/* L360: */
+ }
+
+ } else if (ipack >= 5) {
+
+/* 'B' -- The lower triangle is packed as a band matrix. */
+/* 'Q' -- The upper triangle is packed as a band matrix. */
+/* 'Z' -- The whole matrix is packed as a band matrix. */
+
+ if (ipack == 5) {
+ uub = 0;
+ }
+ if (ipack == 6) {
+ llb = 0;
+ }
+
+ i__1 = uub;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = j + llb;
+ for (i__ = min(i__2,*m); i__ >= 1; --i__) {
+ a[i__ - j + uub + 1 + j * a_dim1] = a[i__ + j * a_dim1];
+/* L370: */
+ }
+/* L380: */
+ }
+
+ i__1 = *n;
+ for (j = uub + 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = j + llb;
+ i__2 = min(i__4,*m);
+ for (i__ = j - uub; i__ <= i__2; ++i__) {
+ a[i__ - j + uub + 1 + j * a_dim1] = a[i__ + j * a_dim1];
+/* L390: */
+ }
+/* L400: */
+ }
+ }
+
+/* If packed, zero out extraneous elements. */
+
+/* Symmetric/Triangular Packed -- */
+/* zero out everything after A(IROW,ICOL) */
+
+ if (ipack == 3 || ipack == 4) {
+ i__1 = *m;
+ for (jc = icol; jc <= i__1; ++jc) {
+ i__2 = *lda;
+ for (jr = irow + 1; jr <= i__2; ++jr) {
+ a[jr + jc * a_dim1] = 0.;
+/* L410: */
+ }
+ irow = 0;
+/* L420: */
+ }
+
+ } else if (ipack >= 5) {
+
+/* Packed Band -- */
+/* 1st row is now in A( UUB+2-j, j), zero above it */
+/* m-th row is now in A( M+UUB-j,j), zero below it */
+/* last non-zero diagonal is now in A( UUB+LLB+1,j ), */
+/* zero below it, too. */
+
+ ir1 = uub + llb + 2;
+ ir2 = uub + *m + 2;
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ i__2 = uub + 1 - jc;
+ for (jr = 1; jr <= i__2; ++jr) {
+ a[jr + jc * a_dim1] = 0.;
+/* L430: */
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__3 = ir1, i__5 = ir2 - jc;
+ i__2 = 1, i__4 = min(i__3,i__5);
+ i__6 = *lda;
+ for (jr = max(i__2,i__4); jr <= i__6; ++jr) {
+ a[jr + jc * a_dim1] = 0.;
+/* L440: */
+ }
+/* L450: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DLATMS */
+
+} /* dlatms_ */
diff --git a/TESTING/MATGEN/dlatmt.c b/TESTING/MATGEN/dlatmt.c
new file mode 100644
index 0000000..182383d
--- /dev/null
+++ b/TESTING/MATGEN/dlatmt.c
@@ -0,0 +1,1336 @@
+/* dlatmt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b22 = 0.;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int dlatmt_(integer *m, integer *n, char *dist, integer *
+ iseed, char *sym, doublereal *d__, integer *mode, doublereal *cond,
+ doublereal *dmax__, integer *rank, integer *kl, integer *ku, char *
+ pack, doublereal *a, integer *lda, doublereal *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1, d__2, d__3;
+ logical L__1;
+
+ /* Builtin functions */
+ double cos(doublereal), sin(doublereal);
+
+ /* Local variables */
+ doublereal c__;
+ integer i__, j, k;
+ doublereal s;
+ integer ic, jc, nc, il, ir, jr, mr, ir1, ir2, jch, llb, jkl, jku, uub,
+ ilda, icol;
+ doublereal temp;
+ integer irow, isym;
+ doublereal alpha, angle;
+ integer ipack;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ integer ioffg;
+ extern logical lsame_(char *, char *);
+ integer iinfo, idist, mnmin;
+ extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
+ doublereal *, integer *);
+ integer iskew;
+ doublereal extra, dummy;
+ extern /* Subroutine */ int dlatm7_(integer *, doublereal *, integer *,
+ integer *, integer *, doublereal *, integer *, integer *, integer
+ *), dlagge_(integer *, integer *, integer *, integer *,
+ doublereal *, doublereal *, integer *, integer *, doublereal *,
+ integer *);
+ integer iendch, ipackg, minlda;
+ extern doublereal dlarnd_(integer *, integer *);
+ extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, integer *),
+ dlartg_(doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *), xerbla_(char *, integer *), dlagsy_(
+ integer *, integer *, doublereal *, doublereal *, integer *,
+ integer *, doublereal *, integer *), dlarot_(logical *, logical *,
+ logical *, integer *, doublereal *, doublereal *, doublereal *,
+ integer *, doublereal *, doublereal *);
+ integer ioffst, irsign;
+ logical givens, iltemp, ilextr, topdwn;
+ integer isympk;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* DLATMT generates random matrices with specified singular values */
+/* (or symmetric/hermitian with specified eigenvalues) */
+/* for testing LAPACK programs. */
+
+/* DLATMT operates by applying the following sequence of */
+/* operations: */
+
+/* Set the diagonal to D, where D may be input or */
+/* computed according to MODE, COND, DMAX, and SYM */
+/* as described below. */
+
+/* Generate a matrix with the appropriate band structure, by one */
+/* of two methods: */
+
+/* Method A: */
+/* Generate a dense M x N matrix by multiplying D on the left */
+/* and the right by random unitary matrices, then: */
+
+/* Reduce the bandwidth according to KL and KU, using */
+/* Householder transformations. */
+
+/* Method B: */
+/* Convert the bandwidth-0 (i.e., diagonal) matrix to a */
+/* bandwidth-1 matrix using Givens rotations, "chasing" */
+/* out-of-band elements back, much as in QR; then */
+/* convert the bandwidth-1 to a bandwidth-2 matrix, etc. */
+/* Note that for reasonably small bandwidths (relative to */
+/* M and N) this requires less storage, as a dense matrix */
+/* is not generated. Also, for symmetric matrices, only */
+/* one triangle is generated. */
+
+/* Method A is chosen if the bandwidth is a large fraction of the */
+/* order of the matrix, and LDA is at least M (so a dense */
+/* matrix can be stored.) Method B is chosen if the bandwidth */
+/* is small (< 1/2 N for symmetric, < .3 N+M for */
+/* non-symmetric), or LDA is less than M and not less than the */
+/* bandwidth. */
+
+/* Pack the matrix if desired. Options specified by PACK are: */
+/* no packing */
+/* zero out upper half (if symmetric) */
+/* zero out lower half (if symmetric) */
+/* store the upper half columnwise (if symmetric or upper */
+/* triangular) */
+/* store the lower half columnwise (if symmetric or lower */
+/* triangular) */
+/* store the lower triangle in banded format (if symmetric */
+/* or lower triangular) */
+/* store the upper triangle in banded format (if symmetric */
+/* or upper triangular) */
+/* store the entire matrix in banded format */
+/* If Method B is chosen, and band format is specified, then the */
+/* matrix will be generated in the band format, so no repacking */
+/* will be necessary. */
+
+/* Arguments */
+/* ========= */
+
+/* M - INTEGER */
+/* The number of rows of A. Not modified. */
+
+/* N - INTEGER */
+/* The number of columns of A. Not modified. */
+
+/* DIST - CHARACTER*1 */
+/* On entry, DIST specifies the type of distribution to be used */
+/* to generate the random eigen-/singular values. */
+/* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */
+/* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */
+/* 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension ( 4 ) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. They should lie between 0 and 4095 inclusive, */
+/* and ISEED(4) should be odd. The random number generator */
+/* uses a linear congruential sequence limited to small */
+/* integers, and so should produce machine independent */
+/* random numbers. The values of ISEED are changed on */
+/* exit, and can be used in the next call to DLATMT */
+/* to continue the same random number sequence. */
+/* Changed on exit. */
+
+/* SYM - CHARACTER*1 */
+/* If SYM='S' or 'H', the generated matrix is symmetric, with */
+/* eigenvalues specified by D, COND, MODE, and DMAX; they */
+/* may be positive, negative, or zero. */
+/* If SYM='P', the generated matrix is symmetric, with */
+/* eigenvalues (= singular values) specified by D, COND, */
+/* MODE, and DMAX; they will not be negative. */
+/* If SYM='N', the generated matrix is nonsymmetric, with */
+/* singular values specified by D, COND, MODE, and DMAX; */
+/* they will not be negative. */
+/* Not modified. */
+
+/* D - DOUBLE PRECISION array, dimension ( MIN( M , N ) ) */
+/* This array is used to specify the singular values or */
+/* eigenvalues of A (see SYM, above.) If MODE=0, then D is */
+/* assumed to contain the singular/eigenvalues, otherwise */
+/* they will be computed according to MODE, COND, and DMAX, */
+/* and placed in D. */
+/* Modified if MODE is nonzero. */
+
+/* MODE - INTEGER */
+/* On entry this describes how the singular/eigenvalues are to */
+/* be specified: */
+/* MODE = 0 means use D as input */
+
+/* MODE = 1 sets D(1)=1 and D(2:RANK)=1.0/COND */
+/* MODE = 2 sets D(1:RANK-1)=1 and D(RANK)=1.0/COND */
+/* MODE = 3 sets D(I)=COND**(-(I-1)/(RANK-1)) */
+
+/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* MODE = 5 sets D to random numbers in the range */
+/* ( 1/COND , 1 ) such that their logarithms */
+/* are uniformly distributed. */
+/* MODE = 6 set D to random numbers from same distribution */
+/* as the rest of the matrix. */
+/* MODE < 0 has the same meaning as ABS(MODE), except that */
+/* the order of the elements of D is reversed. */
+/* Thus if MODE is positive, D has entries ranging from */
+/* 1 to 1/COND, if negative, from 1/COND to 1, */
+/* If SYM='S' or 'H', and MODE is neither 0, 6, nor -6, then */
+/* the elements of D will also be multiplied by a random */
+/* sign (i.e., +1 or -1.) */
+/* Not modified. */
+
+/* COND - DOUBLE PRECISION */
+/* On entry, this is used as described under MODE above. */
+/* If used, it must be >= 1. Not modified. */
+
+/* DMAX - DOUBLE PRECISION */
+/* If MODE is neither -6, 0 nor 6, the contents of D, as */
+/* computed according to MODE and COND, will be scaled by */
+/* DMAX / max(abs(D(i))); thus, the maximum absolute eigen- or */
+/* singular value (which is to say the norm) will be abs(DMAX). */
+/* Note that DMAX need not be positive: if DMAX is negative */
+/* (or zero), D will be scaled by a negative number (or zero). */
+/* Not modified. */
+
+/* RANK - INTEGER */
+/* The rank of matrix to be generated for modes 1,2,3 only. */
+/* D( RANK+1:N ) = 0. */
+/* Not modified. */
+
+/* KL - INTEGER */
+/* This specifies the lower bandwidth of the matrix. For */
+/* example, KL=0 implies upper triangular, KL=1 implies upper */
+/* Hessenberg, and KL being at least M-1 means that the matrix */
+/* has full lower bandwidth. KL must equal KU if the matrix */
+/* is symmetric. */
+/* Not modified. */
+
+/* KU - INTEGER */
+/* This specifies the upper bandwidth of the matrix. For */
+/* example, KU=0 implies lower triangular, KU=1 implies lower */
+/* Hessenberg, and KU being at least N-1 means that the matrix */
+/* has full upper bandwidth. KL must equal KU if the matrix */
+/* is symmetric. */
+/* Not modified. */
+
+/* PACK - CHARACTER*1 */
+/* This specifies packing of matrix as follows: */
+/* 'N' => no packing */
+/* 'U' => zero out all subdiagonal entries (if symmetric) */
+/* 'L' => zero out all superdiagonal entries (if symmetric) */
+/* 'C' => store the upper triangle columnwise */
+/* (only if the matrix is symmetric or upper triangular) */
+/* 'R' => store the lower triangle columnwise */
+/* (only if the matrix is symmetric or lower triangular) */
+/* 'B' => store the lower triangle in band storage scheme */
+/* (only if matrix symmetric or lower triangular) */
+/* 'Q' => store the upper triangle in band storage scheme */
+/* (only if matrix symmetric or upper triangular) */
+/* 'Z' => store the entire matrix in band storage scheme */
+/* (pivoting can be provided for by using this */
+/* option to store A in the trailing rows of */
+/* the allocated storage) */
+
+/* Using these options, the various LAPACK packed and banded */
+/* storage schemes can be obtained: */
+/* GB - use 'Z' */
+/* PB, SB or TB - use 'B' or 'Q' */
+/* PP, SP or TP - use 'C' or 'R' */
+
+/* If two calls to DLATMT differ only in the PACK parameter, */
+/* they will generate mathematically equivalent matrices. */
+/* Not modified. */
+
+/* A - DOUBLE PRECISION array, dimension ( LDA, N ) */
+/* On exit A is the desired test matrix. A is first generated */
+/* in full (unpacked) form, and then packed, if so specified */
+/* by PACK. Thus, the first M elements of the first N */
+/* columns will always be modified. If PACK specifies a */
+/* packed or banded storage scheme, all LDA elements of the */
+/* first N columns will be modified; the elements of the */
+/* array which do not correspond to elements of the generated */
+/* matrix are set to zero. */
+/* Modified. */
+
+/* LDA - INTEGER */
+/* LDA specifies the first dimension of A as declared in the */
+/* calling program. If PACK='N', 'U', 'L', 'C', or 'R', then */
+/* LDA must be at least M. If PACK='B' or 'Q', then LDA must */
+/* be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)). */
+/* If PACK='Z', LDA must be large enough to hold the packed */
+/* array: MIN( KU, N-1) + MIN( KL, M-1) + 1. */
+/* Not modified. */
+
+/* WORK - DOUBLE PRECISION array, dimension ( 3*MAX( N , M ) ) */
+/* Workspace. */
+/* Modified. */
+
+/* INFO - INTEGER */
+/* Error code. On exit, INFO will be set to one of the */
+/* following values: */
+/* 0 => normal return */
+/* -1 => M negative or unequal to N and SYM='S', 'H', or 'P' */
+/* -2 => N negative */
+/* -3 => DIST illegal string */
+/* -5 => SYM illegal string */
+/* -7 => MODE not in range -6 to 6 */
+/* -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */
+/* -10 => KL negative */
+/* -11 => KU negative, or SYM='S' or 'H' and KU not equal to KL */
+/* -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N'; */
+/* or PACK='C' or 'Q' and SYM='N' and KL is not zero; */
+/* or PACK='R' or 'B' and SYM='N' and KU is not zero; */
+/* or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not */
+/* N. */
+/* -14 => LDA is less than M, or PACK='Z' and LDA is less than */
+/* MIN(KU,N-1) + MIN(KL,M-1) + 1. */
+/* 1 => Error return from DLATM7 */
+/* 2 => Cannot scale to DMAX (max. sing. value is 0) */
+/* 3 => Error return from DLAGGE or DLAGSY */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Decode and Test the input parameters. */
+/* Initialize flags & seed. */
+
+ /* Parameter adjustments */
+ --iseed;
+ --d__;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Decode DIST */
+
+ if (lsame_(dist, "U")) {
+ idist = 1;
+ } else if (lsame_(dist, "S")) {
+ idist = 2;
+ } else if (lsame_(dist, "N")) {
+ idist = 3;
+ } else {
+ idist = -1;
+ }
+
+/* Decode SYM */
+
+ if (lsame_(sym, "N")) {
+ isym = 1;
+ irsign = 0;
+ } else if (lsame_(sym, "P")) {
+ isym = 2;
+ irsign = 0;
+ } else if (lsame_(sym, "S")) {
+ isym = 2;
+ irsign = 1;
+ } else if (lsame_(sym, "H")) {
+ isym = 2;
+ irsign = 1;
+ } else {
+ isym = -1;
+ }
+
+/* Decode PACK */
+
+ isympk = 0;
+ if (lsame_(pack, "N")) {
+ ipack = 0;
+ } else if (lsame_(pack, "U")) {
+ ipack = 1;
+ isympk = 1;
+ } else if (lsame_(pack, "L")) {
+ ipack = 2;
+ isympk = 1;
+ } else if (lsame_(pack, "C")) {
+ ipack = 3;
+ isympk = 2;
+ } else if (lsame_(pack, "R")) {
+ ipack = 4;
+ isympk = 3;
+ } else if (lsame_(pack, "B")) {
+ ipack = 5;
+ isympk = 3;
+ } else if (lsame_(pack, "Q")) {
+ ipack = 6;
+ isympk = 2;
+ } else if (lsame_(pack, "Z")) {
+ ipack = 7;
+ } else {
+ ipack = -1;
+ }
+
+/* Set certain internal parameters */
+
+ mnmin = min(*m,*n);
+/* Computing MIN */
+ i__1 = *kl, i__2 = *m - 1;
+ llb = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *ku, i__2 = *n - 1;
+ uub = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *m, i__2 = *n + llb;
+ mr = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *n, i__2 = *m + uub;
+ nc = min(i__1,i__2);
+
+ if (ipack == 5 || ipack == 6) {
+ minlda = uub + 1;
+ } else if (ipack == 7) {
+ minlda = llb + uub + 1;
+ } else {
+ minlda = *m;
+ }
+
+/* Use Givens rotation method if bandwidth small enough, */
+/* or if LDA is too small to store the matrix unpacked. */
+
+ givens = FALSE_;
+ if (isym == 1) {
+/* Computing MAX */
+ i__1 = 1, i__2 = mr + nc;
+ if ((doublereal) (llb + uub) < (doublereal) max(i__1,i__2) * .3) {
+ givens = TRUE_;
+ }
+ } else {
+ if (llb << 1 < *m) {
+ givens = TRUE_;
+ }
+ }
+ if (*lda < *m && *lda >= minlda) {
+ givens = TRUE_;
+ }
+
+/* Set INFO if an error */
+
+ if (*m < 0) {
+ *info = -1;
+ } else if (*m != *n && isym != 1) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (idist == -1) {
+ *info = -3;
+ } else if (isym == -1) {
+ *info = -5;
+ } else if (abs(*mode) > 6) {
+ *info = -7;
+ } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.) {
+ *info = -8;
+ } else if (*kl < 0) {
+ *info = -10;
+ } else if (*ku < 0 || isym != 1 && *kl != *ku) {
+ *info = -11;
+ } else if (ipack == -1 || isympk == 1 && isym == 1 || isympk == 2 && isym
+ == 1 && *kl > 0 || isympk == 3 && isym == 1 && *ku > 0 || isympk
+ != 0 && *m != *n) {
+ *info = -12;
+ } else if (*lda < max(1,minlda)) {
+ *info = -14;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("DLATMT", &i__1);
+ return 0;
+ }
+
+/* Initialize random number generator */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
+/* L100: */
+ }
+
+ if (iseed[4] % 2 != 1) {
+ ++iseed[4];
+ }
+
+/* 2) Set up D if indicated. */
+
+/* Compute D according to COND and MODE */
+
+ dlatm7_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, rank, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = 1;
+ return 0;
+ }
+
+/* Choose Top-Down if D is (apparently) increasing, */
+/* Bottom-Up if D is (apparently) decreasing. */
+
+ if (abs(d__[1]) <= (d__1 = d__[*rank], abs(d__1))) {
+ topdwn = TRUE_;
+ } else {
+ topdwn = FALSE_;
+ }
+
+ if (*mode != 0 && abs(*mode) != 6) {
+
+/* Scale by DMAX */
+
+ temp = abs(d__[1]);
+ i__1 = *rank;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = temp, d__3 = (d__1 = d__[i__], abs(d__1));
+ temp = max(d__2,d__3);
+/* L110: */
+ }
+
+ if (temp > 0.) {
+ alpha = *dmax__ / temp;
+ } else {
+ *info = 2;
+ return 0;
+ }
+
+ dscal_(rank, &alpha, &d__[1], &c__1);
+
+ }
+
+/* 3) Generate Banded Matrix using Givens rotations. */
+/* Also the special case of UUB=LLB=0 */
+
+/* Compute Addressing constants to cover all */
+/* storage formats. Whether GE, SY, GB, or SB, */
+/* upper or lower triangle or both, */
+/* the (i,j)-th element is in */
+/* A( i - ISKEW*j + IOFFST, j ) */
+
+ if (ipack > 4) {
+ ilda = *lda - 1;
+ iskew = 1;
+ if (ipack > 5) {
+ ioffst = uub + 1;
+ } else {
+ ioffst = 1;
+ }
+ } else {
+ ilda = *lda;
+ iskew = 0;
+ ioffst = 0;
+ }
+
+/* IPACKG is the format that the matrix is generated in. If this is */
+/* different from IPACK, then the matrix must be repacked at the */
+/* end. It also signals how to compute the norm, for scaling. */
+
+ ipackg = 0;
+ dlaset_("Full", lda, n, &c_b22, &c_b22, &a[a_offset], lda);
+
+/* Diagonal Matrix -- We are done, unless it */
+/* is to be stored SP/PP/TP (PACK='R' or 'C') */
+
+ if (llb == 0 && uub == 0) {
+ i__1 = ilda + 1;
+ dcopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffst + a_dim1], &i__1)
+ ;
+ if (ipack <= 2 || ipack >= 5) {
+ ipackg = ipack;
+ }
+
+ } else if (givens) {
+
+/* Check whether to use Givens rotations, */
+/* Householder transformations, or nothing. */
+
+ if (isym == 1) {
+
+/* Non-symmetric -- A = U D V */
+
+ if (ipack > 4) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+
+ i__1 = ilda + 1;
+ dcopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffst + a_dim1], &
+ i__1);
+
+ if (topdwn) {
+ jkl = 0;
+ i__1 = uub;
+ for (jku = 1; jku <= i__1; ++jku) {
+
+/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */
+
+/* Last row actually rotated is M */
+/* Last column actually rotated is MIN( M+JKU, N ) */
+
+/* Computing MIN */
+ i__3 = *m + jku;
+ i__2 = min(i__3,*n) + jkl - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ extra = 0.;
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ c__ = cos(angle);
+ s = sin(angle);
+/* Computing MAX */
+ i__3 = 1, i__4 = jr - jkl;
+ icol = max(i__3,i__4);
+ if (jr < *m) {
+/* Computing MIN */
+ i__3 = *n, i__4 = jr + jku;
+ il = min(i__3,i__4) + 1 - icol;
+ L__1 = jr > jkl;
+ dlarot_(&c_true, &L__1, &c_false, &il, &c__, &s, &
+ a[jr - iskew * icol + ioffst + icol *
+ a_dim1], &ilda, &extra, &dummy);
+ }
+
+/* Chase "EXTRA" back up */
+
+ ir = jr;
+ ic = icol;
+ i__3 = -jkl - jku;
+ for (jch = jr - jkl; i__3 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__3) {
+ if (ir < *m) {
+ dlartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst
+ + (ic + 1) * a_dim1], &extra, &c__, &
+ s, &dummy);
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jku;
+ irow = max(i__4,i__5);
+ il = ir + 2 - irow;
+ temp = 0.;
+ iltemp = jch > jku;
+ d__1 = -s;
+ dlarot_(&c_false, &iltemp, &c_true, &il, &c__, &
+ d__1, &a[irow - iskew * ic + ioffst + ic *
+ a_dim1], &ilda, &temp, &extra);
+ if (iltemp) {
+ dlartg_(&a[irow + 1 - iskew * (ic + 1) +
+ ioffst + (ic + 1) * a_dim1], &temp, &
+ c__, &s, &dummy);
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jku - jkl;
+ icol = max(i__4,i__5);
+ il = ic + 2 - icol;
+ extra = 0.;
+ L__1 = jch > jku + jkl;
+ d__1 = -s;
+ dlarot_(&c_true, &L__1, &c_true, &il, &c__, &
+ d__1, &a[irow - iskew * icol + ioffst
+ + icol * a_dim1], &ilda, &extra, &
+ temp);
+ ic = icol;
+ ir = irow;
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+
+ jku = uub;
+ i__1 = llb;
+ for (jkl = 1; jkl <= i__1; ++jkl) {
+
+/* Transform from bandwidth JKL-1, JKU to JKL, JKU */
+
+/* Computing MIN */
+ i__3 = *n + jkl;
+ i__2 = min(i__3,*m) + jku - 1;
+ for (jc = 1; jc <= i__2; ++jc) {
+ extra = 0.;
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ c__ = cos(angle);
+ s = sin(angle);
+/* Computing MAX */
+ i__3 = 1, i__4 = jc - jku;
+ irow = max(i__3,i__4);
+ if (jc < *n) {
+/* Computing MIN */
+ i__3 = *m, i__4 = jc + jkl;
+ il = min(i__3,i__4) + 1 - irow;
+ L__1 = jc > jku;
+ dlarot_(&c_false, &L__1, &c_false, &il, &c__, &s,
+ &a[irow - iskew * jc + ioffst + jc *
+ a_dim1], &ilda, &extra, &dummy);
+ }
+
+/* Chase "EXTRA" back up */
+
+ ic = jc;
+ ir = irow;
+ i__3 = -jkl - jku;
+ for (jch = jc - jku; i__3 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__3) {
+ if (ic < *n) {
+ dlartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst
+ + (ic + 1) * a_dim1], &extra, &c__, &
+ s, &dummy);
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jkl;
+ icol = max(i__4,i__5);
+ il = ic + 2 - icol;
+ temp = 0.;
+ iltemp = jch > jkl;
+ d__1 = -s;
+ dlarot_(&c_true, &iltemp, &c_true, &il, &c__, &
+ d__1, &a[ir - iskew * icol + ioffst +
+ icol * a_dim1], &ilda, &temp, &extra);
+ if (iltemp) {
+ dlartg_(&a[ir + 1 - iskew * (icol + 1) +
+ ioffst + (icol + 1) * a_dim1], &temp,
+ &c__, &s, &dummy);
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jkl - jku;
+ irow = max(i__4,i__5);
+ il = ir + 2 - irow;
+ extra = 0.;
+ L__1 = jch > jkl + jku;
+ d__1 = -s;
+ dlarot_(&c_false, &L__1, &c_true, &il, &c__, &
+ d__1, &a[irow - iskew * icol + ioffst
+ + icol * a_dim1], &ilda, &extra, &
+ temp);
+ ic = icol;
+ ir = irow;
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+
+ } else {
+
+/* Bottom-Up -- Start at the bottom right. */
+
+ jkl = 0;
+ i__1 = uub;
+ for (jku = 1; jku <= i__1; ++jku) {
+
+/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */
+
+/* First row actually rotated is M */
+/* First column actually rotated is MIN( M+JKU, N ) */
+
+/* Computing MIN */
+ i__2 = *m, i__3 = *n + jkl;
+ iendch = min(i__2,i__3) - 1;
+/* Computing MIN */
+ i__2 = *m + jku;
+ i__3 = 1 - jkl;
+ for (jc = min(i__2,*n) - 1; jc >= i__3; --jc) {
+ extra = 0.;
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ c__ = cos(angle);
+ s = sin(angle);
+/* Computing MAX */
+ i__2 = 1, i__4 = jc - jku + 1;
+ irow = max(i__2,i__4);
+ if (jc > 0) {
+/* Computing MIN */
+ i__2 = *m, i__4 = jc + jkl + 1;
+ il = min(i__2,i__4) + 1 - irow;
+ L__1 = jc + jkl < *m;
+ dlarot_(&c_false, &c_false, &L__1, &il, &c__, &s,
+ &a[irow - iskew * jc + ioffst + jc *
+ a_dim1], &ilda, &dummy, &extra);
+ }
+
+/* Chase "EXTRA" back down */
+
+ ic = jc;
+ i__2 = iendch;
+ i__4 = jkl + jku;
+ for (jch = jc + jkl; i__4 < 0 ? jch >= i__2 : jch <=
+ i__2; jch += i__4) {
+ ilextr = ic > 0;
+ if (ilextr) {
+ dlartg_(&a[jch - iskew * ic + ioffst + ic *
+ a_dim1], &extra, &c__, &s, &dummy);
+ }
+ ic = max(1,ic);
+/* Computing MIN */
+ i__5 = *n - 1, i__6 = jch + jku;
+ icol = min(i__5,i__6);
+ iltemp = jch + jku < *n;
+ temp = 0.;
+ i__5 = icol + 2 - ic;
+ dlarot_(&c_true, &ilextr, &iltemp, &i__5, &c__, &
+ s, &a[jch - iskew * ic + ioffst + ic *
+ a_dim1], &ilda, &extra, &temp);
+ if (iltemp) {
+ dlartg_(&a[jch - iskew * icol + ioffst + icol
+ * a_dim1], &temp, &c__, &s, &dummy);
+/* Computing MIN */
+ i__5 = iendch, i__6 = jch + jkl + jku;
+ il = min(i__5,i__6) + 2 - jch;
+ extra = 0.;
+ L__1 = jch + jkl + jku <= iendch;
+ dlarot_(&c_false, &c_true, &L__1, &il, &c__, &
+ s, &a[jch - iskew * icol + ioffst +
+ icol * a_dim1], &ilda, &temp, &extra);
+ ic = icol;
+ }
+/* L180: */
+ }
+/* L190: */
+ }
+/* L200: */
+ }
+
+ jku = uub;
+ i__1 = llb;
+ for (jkl = 1; jkl <= i__1; ++jkl) {
+
+/* Transform from bandwidth JKL-1, JKU to JKL, JKU */
+
+/* First row actually rotated is MIN( N+JKL, M ) */
+/* First column actually rotated is N */
+
+/* Computing MIN */
+ i__3 = *n, i__4 = *m + jku;
+ iendch = min(i__3,i__4) - 1;
+/* Computing MIN */
+ i__3 = *n + jkl;
+ i__4 = 1 - jku;
+ for (jr = min(i__3,*m) - 1; jr >= i__4; --jr) {
+ extra = 0.;
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ c__ = cos(angle);
+ s = sin(angle);
+/* Computing MAX */
+ i__3 = 1, i__2 = jr - jkl + 1;
+ icol = max(i__3,i__2);
+ if (jr > 0) {
+/* Computing MIN */
+ i__3 = *n, i__2 = jr + jku + 1;
+ il = min(i__3,i__2) + 1 - icol;
+ L__1 = jr + jku < *n;
+ dlarot_(&c_true, &c_false, &L__1, &il, &c__, &s, &
+ a[jr - iskew * icol + ioffst + icol *
+ a_dim1], &ilda, &dummy, &extra);
+ }
+
+/* Chase "EXTRA" back down */
+
+ ir = jr;
+ i__3 = iendch;
+ i__2 = jkl + jku;
+ for (jch = jr + jku; i__2 < 0 ? jch >= i__3 : jch <=
+ i__3; jch += i__2) {
+ ilextr = ir > 0;
+ if (ilextr) {
+ dlartg_(&a[ir - iskew * jch + ioffst + jch *
+ a_dim1], &extra, &c__, &s, &dummy);
+ }
+ ir = max(1,ir);
+/* Computing MIN */
+ i__5 = *m - 1, i__6 = jch + jkl;
+ irow = min(i__5,i__6);
+ iltemp = jch + jkl < *m;
+ temp = 0.;
+ i__5 = irow + 2 - ir;
+ dlarot_(&c_false, &ilextr, &iltemp, &i__5, &c__, &
+ s, &a[ir - iskew * jch + ioffst + jch *
+ a_dim1], &ilda, &extra, &temp);
+ if (iltemp) {
+ dlartg_(&a[irow - iskew * jch + ioffst + jch *
+ a_dim1], &temp, &c__, &s, &dummy);
+/* Computing MIN */
+ i__5 = iendch, i__6 = jch + jkl + jku;
+ il = min(i__5,i__6) + 2 - jch;
+ extra = 0.;
+ L__1 = jch + jkl + jku <= iendch;
+ dlarot_(&c_true, &c_true, &L__1, &il, &c__, &
+ s, &a[irow - iskew * jch + ioffst +
+ jch * a_dim1], &ilda, &temp, &extra);
+ ir = irow;
+ }
+/* L210: */
+ }
+/* L220: */
+ }
+/* L230: */
+ }
+ }
+
+ } else {
+
+/* Symmetric -- A = U D U' */
+
+ ipackg = ipack;
+ ioffg = ioffst;
+
+ if (topdwn) {
+
+/* Top-Down -- Generate Upper triangle only */
+
+ if (ipack >= 5) {
+ ipackg = 6;
+ ioffg = uub + 1;
+ } else {
+ ipackg = 1;
+ }
+ i__1 = ilda + 1;
+ dcopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffg + a_dim1],
+ &i__1);
+
+ i__1 = uub;
+ for (k = 1; k <= i__1; ++k) {
+ i__4 = *n - 1;
+ for (jc = 1; jc <= i__4; ++jc) {
+/* Computing MAX */
+ i__2 = 1, i__3 = jc - k;
+ irow = max(i__2,i__3);
+/* Computing MIN */
+ i__2 = jc + 1, i__3 = k + 2;
+ il = min(i__2,i__3);
+ extra = 0.;
+ temp = a[jc - iskew * (jc + 1) + ioffg + (jc + 1) *
+ a_dim1];
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ c__ = cos(angle);
+ s = sin(angle);
+ L__1 = jc > k;
+ dlarot_(&c_false, &L__1, &c_true, &il, &c__, &s, &a[
+ irow - iskew * jc + ioffg + jc * a_dim1], &
+ ilda, &extra, &temp);
+/* Computing MIN */
+ i__3 = k, i__5 = *n - jc;
+ i__2 = min(i__3,i__5) + 1;
+ dlarot_(&c_true, &c_true, &c_false, &i__2, &c__, &s, &
+ a[(1 - iskew) * jc + ioffg + jc * a_dim1], &
+ ilda, &temp, &dummy);
+
+/* Chase EXTRA back up the matrix */
+
+ icol = jc;
+ i__2 = -k;
+ for (jch = jc - k; i__2 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__2) {
+ dlartg_(&a[jch + 1 - iskew * (icol + 1) + ioffg +
+ (icol + 1) * a_dim1], &extra, &c__, &s, &
+ dummy);
+ temp = a[jch - iskew * (jch + 1) + ioffg + (jch +
+ 1) * a_dim1];
+ i__3 = k + 2;
+ d__1 = -s;
+ dlarot_(&c_true, &c_true, &c_true, &i__3, &c__, &
+ d__1, &a[(1 - iskew) * jch + ioffg + jch *
+ a_dim1], &ilda, &temp, &extra);
+/* Computing MAX */
+ i__3 = 1, i__5 = jch - k;
+ irow = max(i__3,i__5);
+/* Computing MIN */
+ i__3 = jch + 1, i__5 = k + 2;
+ il = min(i__3,i__5);
+ extra = 0.;
+ L__1 = jch > k;
+ d__1 = -s;
+ dlarot_(&c_false, &L__1, &c_true, &il, &c__, &
+ d__1, &a[irow - iskew * jch + ioffg + jch
+ * a_dim1], &ilda, &extra, &temp);
+ icol = jch;
+/* L240: */
+ }
+/* L250: */
+ }
+/* L260: */
+ }
+
+/* If we need lower triangle, copy from upper. Note that */
+/* the order of copying is chosen to work for 'q' -> 'b' */
+
+ if (ipack != ipackg && ipack != 3) {
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ irow = ioffst - iskew * jc;
+/* Computing MIN */
+ i__2 = *n, i__3 = jc + uub;
+ i__4 = min(i__2,i__3);
+ for (jr = jc; jr <= i__4; ++jr) {
+ a[jr + irow + jc * a_dim1] = a[jc - iskew * jr +
+ ioffg + jr * a_dim1];
+/* L270: */
+ }
+/* L280: */
+ }
+ if (ipack == 5) {
+ i__1 = *n;
+ for (jc = *n - uub + 1; jc <= i__1; ++jc) {
+ i__4 = uub + 1;
+ for (jr = *n + 2 - jc; jr <= i__4; ++jr) {
+ a[jr + jc * a_dim1] = 0.;
+/* L290: */
+ }
+/* L300: */
+ }
+ }
+ if (ipackg == 6) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+ }
+ } else {
+
+/* Bottom-Up -- Generate Lower triangle only */
+
+ if (ipack >= 5) {
+ ipackg = 5;
+ if (ipack == 6) {
+ ioffg = 1;
+ }
+ } else {
+ ipackg = 2;
+ }
+ i__1 = ilda + 1;
+ dcopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffg + a_dim1],
+ &i__1);
+
+ i__1 = uub;
+ for (k = 1; k <= i__1; ++k) {
+ for (jc = *n - 1; jc >= 1; --jc) {
+/* Computing MIN */
+ i__4 = *n + 1 - jc, i__2 = k + 2;
+ il = min(i__4,i__2);
+ extra = 0.;
+ temp = a[(1 - iskew) * jc + 1 + ioffg + jc * a_dim1];
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ c__ = cos(angle);
+ s = -sin(angle);
+ L__1 = *n - jc > k;
+ dlarot_(&c_false, &c_true, &L__1, &il, &c__, &s, &a[(
+ 1 - iskew) * jc + ioffg + jc * a_dim1], &ilda,
+ &temp, &extra);
+/* Computing MAX */
+ i__4 = 1, i__2 = jc - k + 1;
+ icol = max(i__4,i__2);
+ i__4 = jc + 2 - icol;
+ dlarot_(&c_true, &c_false, &c_true, &i__4, &c__, &s, &
+ a[jc - iskew * icol + ioffg + icol * a_dim1],
+ &ilda, &dummy, &temp);
+
+/* Chase EXTRA back down the matrix */
+
+ icol = jc;
+ i__4 = *n - 1;
+ i__2 = k;
+ for (jch = jc + k; i__2 < 0 ? jch >= i__4 : jch <=
+ i__4; jch += i__2) {
+ dlartg_(&a[jch - iskew * icol + ioffg + icol *
+ a_dim1], &extra, &c__, &s, &dummy);
+ temp = a[(1 - iskew) * jch + 1 + ioffg + jch *
+ a_dim1];
+ i__3 = k + 2;
+ dlarot_(&c_true, &c_true, &c_true, &i__3, &c__, &
+ s, &a[jch - iskew * icol + ioffg + icol *
+ a_dim1], &ilda, &extra, &temp);
+/* Computing MIN */
+ i__3 = *n + 1 - jch, i__5 = k + 2;
+ il = min(i__3,i__5);
+ extra = 0.;
+ L__1 = *n - jch > k;
+ dlarot_(&c_false, &c_true, &L__1, &il, &c__, &s, &
+ a[(1 - iskew) * jch + ioffg + jch *
+ a_dim1], &ilda, &temp, &extra);
+ icol = jch;
+/* L310: */
+ }
+/* L320: */
+ }
+/* L330: */
+ }
+
+/* If we need upper triangle, copy from lower. Note that */
+/* the order of copying is chosen to work for 'b' -> 'q' */
+
+ if (ipack != ipackg && ipack != 4) {
+ for (jc = *n; jc >= 1; --jc) {
+ irow = ioffst - iskew * jc;
+/* Computing MAX */
+ i__2 = 1, i__4 = jc - uub;
+ i__1 = max(i__2,i__4);
+ for (jr = jc; jr >= i__1; --jr) {
+ a[jr + irow + jc * a_dim1] = a[jc - iskew * jr +
+ ioffg + jr * a_dim1];
+/* L340: */
+ }
+/* L350: */
+ }
+ if (ipack == 6) {
+ i__1 = uub;
+ for (jc = 1; jc <= i__1; ++jc) {
+ i__2 = uub + 1 - jc;
+ for (jr = 1; jr <= i__2; ++jr) {
+ a[jr + jc * a_dim1] = 0.;
+/* L360: */
+ }
+/* L370: */
+ }
+ }
+ if (ipackg == 5) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+ }
+ }
+ }
+
+ } else {
+
+/* 4) Generate Banded Matrix by first */
+/* Rotating by random Unitary matrices, */
+/* then reducing the bandwidth using Householder */
+/* transformations. */
+
+/* Note: we should get here only if LDA .ge. N */
+
+ if (isym == 1) {
+
+/* Non-symmetric -- A = U D V */
+
+ dlagge_(&mr, &nc, &llb, &uub, &d__[1], &a[a_offset], lda, &iseed[
+ 1], &work[1], &iinfo);
+ } else {
+
+/* Symmetric -- A = U D U' */
+
+ dlagsy_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[1],
+ &iinfo);
+
+ }
+ if (iinfo != 0) {
+ *info = 3;
+ return 0;
+ }
+ }
+
+/* 5) Pack the matrix */
+
+ if (ipack != ipackg) {
+ if (ipack == 1) {
+
+/* 'U' -- Upper triangular, not packed */
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L380: */
+ }
+/* L390: */
+ }
+
+ } else if (ipack == 2) {
+
+/* 'L' -- Lower triangular, not packed */
+
+ i__1 = *m;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.;
+/* L400: */
+ }
+/* L410: */
+ }
+
+ } else if (ipack == 3) {
+
+/* 'C' -- Upper triangle packed Columnwise. */
+
+ icol = 1;
+ irow = 0;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ++irow;
+ if (irow > *lda) {
+ irow = 1;
+ ++icol;
+ }
+ a[irow + icol * a_dim1] = a[i__ + j * a_dim1];
+/* L420: */
+ }
+/* L430: */
+ }
+
+ } else if (ipack == 4) {
+
+/* 'R' -- Lower triangle packed Columnwise. */
+
+ icol = 1;
+ irow = 0;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ++irow;
+ if (irow > *lda) {
+ irow = 1;
+ ++icol;
+ }
+ a[irow + icol * a_dim1] = a[i__ + j * a_dim1];
+/* L440: */
+ }
+/* L450: */
+ }
+
+ } else if (ipack >= 5) {
+
+/* 'B' -- The lower triangle is packed as a band matrix. */
+/* 'Q' -- The upper triangle is packed as a band matrix. */
+/* 'Z' -- The whole matrix is packed as a band matrix. */
+
+ if (ipack == 5) {
+ uub = 0;
+ }
+ if (ipack == 6) {
+ llb = 0;
+ }
+
+ i__1 = uub;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = j + llb;
+ for (i__ = min(i__2,*m); i__ >= 1; --i__) {
+ a[i__ - j + uub + 1 + j * a_dim1] = a[i__ + j * a_dim1];
+/* L460: */
+ }
+/* L470: */
+ }
+
+ i__1 = *n;
+ for (j = uub + 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = j + llb;
+ i__2 = min(i__4,*m);
+ for (i__ = j - uub; i__ <= i__2; ++i__) {
+ a[i__ - j + uub + 1 + j * a_dim1] = a[i__ + j * a_dim1];
+/* L480: */
+ }
+/* L490: */
+ }
+ }
+
+/* If packed, zero out extraneous elements. */
+
+/* Symmetric/Triangular Packed -- */
+/* zero out everything after A(IROW,ICOL) */
+
+ if (ipack == 3 || ipack == 4) {
+ i__1 = *m;
+ for (jc = icol; jc <= i__1; ++jc) {
+ i__2 = *lda;
+ for (jr = irow + 1; jr <= i__2; ++jr) {
+ a[jr + jc * a_dim1] = 0.;
+/* L500: */
+ }
+ irow = 0;
+/* L510: */
+ }
+
+ } else if (ipack >= 5) {
+
+/* Packed Band -- */
+/* 1st row is now in A( UUB+2-j, j), zero above it */
+/* m-th row is now in A( M+UUB-j,j), zero below it */
+/* last non-zero diagonal is now in A( UUB+LLB+1,j ), */
+/* zero below it, too. */
+
+ ir1 = uub + llb + 2;
+ ir2 = uub + *m + 2;
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ i__2 = uub + 1 - jc;
+ for (jr = 1; jr <= i__2; ++jr) {
+ a[jr + jc * a_dim1] = 0.;
+/* L520: */
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__3 = ir1, i__5 = ir2 - jc;
+ i__2 = 1, i__4 = min(i__3,i__5);
+ i__6 = *lda;
+ for (jr = max(i__2,i__4); jr <= i__6; ++jr) {
+ a[jr + jc * a_dim1] = 0.;
+/* L530: */
+ }
+/* L540: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of DLATMT */
+
+} /* dlatmt_ */
diff --git a/TESTING/MATGEN/slagge.c b/TESTING/MATGEN/slagge.c
new file mode 100644
index 0000000..2c068c3
--- /dev/null
+++ b/TESTING/MATGEN/slagge.c
@@ -0,0 +1,414 @@
+/* slagge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static real c_b11 = 1.f;
+static real c_b13 = 0.f;
+
+/* Subroutine */ int slagge_(integer *m, integer *n, integer *kl, integer *ku,
+ real *d__, real *a, integer *lda, integer *iseed, real *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1;
+
+ /* Builtin functions */
+ double r_sign(real *, real *);
+
+ /* Local variables */
+ integer i__, j;
+ real wa, wb, wn, tau;
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ extern doublereal snrm2_(integer *, real *, integer *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ sgemv_(char *, integer *, integer *, real *, real *, integer *,
+ real *, integer *, real *, real *, integer *), xerbla_(
+ char *, integer *), slarnv_(integer *, integer *, integer
+ *, real *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAGGE generates a real general m by n matrix A, by pre- and post- */
+/* multiplying a real diagonal matrix D with random orthogonal matrices: */
+/* A = U*D*V. The lower and upper bandwidths may then be reduced to */
+/* kl and ku by additional orthogonal transformations. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of nonzero subdiagonals within the band of A. */
+/* 0 <= KL <= M-1. */
+
+/* KU (input) INTEGER */
+/* The number of nonzero superdiagonals within the band of A. */
+/* 0 <= KU <= N-1. */
+
+/* D (input) REAL array, dimension (min(M,N)) */
+/* The diagonal elements of the diagonal matrix D. */
+
+/* A (output) REAL array, dimension (LDA,N) */
+/* The generated m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* WORK (workspace) REAL array, dimension (M+N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --d__;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iseed;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0 || *kl > *m - 1) {
+ *info = -3;
+ } else if (*ku < 0 || *ku > *n - 1) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -7;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("SLAGGE", &i__1);
+ return 0;
+ }
+
+/* initialize A to diagonal matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ i__1 = min(*m,*n);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ a[i__ + i__ * a_dim1] = d__[i__];
+/* L30: */
+ }
+
+/* pre- and post-multiply A by random orthogonal matrices */
+
+ for (i__ = min(*m,*n); i__ >= 1; --i__) {
+ if (i__ < *m) {
+
+/* generate random reflection */
+
+ i__1 = *m - i__ + 1;
+ slarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+ i__1 = *m - i__ + 1;
+ wn = snrm2_(&i__1, &work[1], &c__1);
+ wa = r_sign(&wn, &work[1]);
+ if (wn == 0.f) {
+ tau = 0.f;
+ } else {
+ wb = work[1] + wa;
+ i__1 = *m - i__;
+ r__1 = 1.f / wb;
+ sscal_(&i__1, &r__1, &work[2], &c__1);
+ work[1] = 1.f;
+ tau = wb / wa;
+ }
+
+/* multiply A(i:m,i:n) by random reflection from the left */
+
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__ + 1;
+ sgemv_("Transpose", &i__1, &i__2, &c_b11, &a[i__ + i__ * a_dim1],
+ lda, &work[1], &c__1, &c_b13, &work[*m + 1], &c__1);
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__ + 1;
+ r__1 = -tau;
+ sger_(&i__1, &i__2, &r__1, &work[1], &c__1, &work[*m + 1], &c__1,
+ &a[i__ + i__ * a_dim1], lda);
+ }
+ if (i__ < *n) {
+
+/* generate random reflection */
+
+ i__1 = *n - i__ + 1;
+ slarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+ i__1 = *n - i__ + 1;
+ wn = snrm2_(&i__1, &work[1], &c__1);
+ wa = r_sign(&wn, &work[1]);
+ if (wn == 0.f) {
+ tau = 0.f;
+ } else {
+ wb = work[1] + wa;
+ i__1 = *n - i__;
+ r__1 = 1.f / wb;
+ sscal_(&i__1, &r__1, &work[2], &c__1);
+ work[1] = 1.f;
+ tau = wb / wa;
+ }
+
+/* multiply A(i:m,i:n) by random reflection from the right */
+
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__ + 1;
+ sgemv_("No transpose", &i__1, &i__2, &c_b11, &a[i__ + i__ *
+ a_dim1], lda, &work[1], &c__1, &c_b13, &work[*n + 1], &
+ c__1);
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__ + 1;
+ r__1 = -tau;
+ sger_(&i__1, &i__2, &r__1, &work[*n + 1], &c__1, &work[1], &c__1,
+ &a[i__ + i__ * a_dim1], lda);
+ }
+/* L40: */
+ }
+
+/* Reduce number of subdiagonals to KL and number of superdiagonals */
+/* to KU */
+
+/* Computing MAX */
+ i__2 = *m - 1 - *kl, i__3 = *n - 1 - *ku;
+ i__1 = max(i__2,i__3);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*kl <= *ku) {
+
+/* annihilate subdiagonal elements first (necessary if KL = 0) */
+
+/* Computing MIN */
+ i__2 = *m - 1 - *kl;
+ if (i__ <= min(i__2,*n)) {
+
+/* generate reflection to annihilate A(kl+i+1:m,i) */
+
+ i__2 = *m - *kl - i__ + 1;
+ wn = snrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
+ wa = r_sign(&wn, &a[*kl + i__ + i__ * a_dim1]);
+ if (wn == 0.f) {
+ tau = 0.f;
+ } else {
+ wb = a[*kl + i__ + i__ * a_dim1] + wa;
+ i__2 = *m - *kl - i__;
+ r__1 = 1.f / wb;
+ sscal_(&i__2, &r__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
+ c__1);
+ a[*kl + i__ + i__ * a_dim1] = 1.f;
+ tau = wb / wa;
+ }
+
+/* apply reflection to A(kl+i:m,i+1:n) from the left */
+
+ i__2 = *m - *kl - i__ + 1;
+ i__3 = *n - i__;
+ sgemv_("Transpose", &i__2, &i__3, &c_b11, &a[*kl + i__ + (i__
+ + 1) * a_dim1], lda, &a[*kl + i__ + i__ * a_dim1], &
+ c__1, &c_b13, &work[1], &c__1);
+ i__2 = *m - *kl - i__ + 1;
+ i__3 = *n - i__;
+ r__1 = -tau;
+ sger_(&i__2, &i__3, &r__1, &a[*kl + i__ + i__ * a_dim1], &
+ c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) *
+ a_dim1], lda);
+ a[*kl + i__ + i__ * a_dim1] = -wa;
+ }
+
+/* Computing MIN */
+ i__2 = *n - 1 - *ku;
+ if (i__ <= min(i__2,*m)) {
+
+/* generate reflection to annihilate A(i,ku+i+1:n) */
+
+ i__2 = *n - *ku - i__ + 1;
+ wn = snrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+ wa = r_sign(&wn, &a[i__ + (*ku + i__) * a_dim1]);
+ if (wn == 0.f) {
+ tau = 0.f;
+ } else {
+ wb = a[i__ + (*ku + i__) * a_dim1] + wa;
+ i__2 = *n - *ku - i__;
+ r__1 = 1.f / wb;
+ sscal_(&i__2, &r__1, &a[i__ + (*ku + i__ + 1) * a_dim1],
+ lda);
+ a[i__ + (*ku + i__) * a_dim1] = 1.f;
+ tau = wb / wa;
+ }
+
+/* apply reflection to A(i+1:m,ku+i:n) from the right */
+
+ i__2 = *m - i__;
+ i__3 = *n - *ku - i__ + 1;
+ sgemv_("No transpose", &i__2, &i__3, &c_b11, &a[i__ + 1 + (*
+ ku + i__) * a_dim1], lda, &a[i__ + (*ku + i__) *
+ a_dim1], lda, &c_b13, &work[1], &c__1);
+ i__2 = *m - i__;
+ i__3 = *n - *ku - i__ + 1;
+ r__1 = -tau;
+ sger_(&i__2, &i__3, &r__1, &work[1], &c__1, &a[i__ + (*ku +
+ i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) *
+ a_dim1], lda);
+ a[i__ + (*ku + i__) * a_dim1] = -wa;
+ }
+ } else {
+
+/* annihilate superdiagonal elements first (necessary if */
+/* KU = 0) */
+
+/* Computing MIN */
+ i__2 = *n - 1 - *ku;
+ if (i__ <= min(i__2,*m)) {
+
+/* generate reflection to annihilate A(i,ku+i+1:n) */
+
+ i__2 = *n - *ku - i__ + 1;
+ wn = snrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+ wa = r_sign(&wn, &a[i__ + (*ku + i__) * a_dim1]);
+ if (wn == 0.f) {
+ tau = 0.f;
+ } else {
+ wb = a[i__ + (*ku + i__) * a_dim1] + wa;
+ i__2 = *n - *ku - i__;
+ r__1 = 1.f / wb;
+ sscal_(&i__2, &r__1, &a[i__ + (*ku + i__ + 1) * a_dim1],
+ lda);
+ a[i__ + (*ku + i__) * a_dim1] = 1.f;
+ tau = wb / wa;
+ }
+
+/* apply reflection to A(i+1:m,ku+i:n) from the right */
+
+ i__2 = *m - i__;
+ i__3 = *n - *ku - i__ + 1;
+ sgemv_("No transpose", &i__2, &i__3, &c_b11, &a[i__ + 1 + (*
+ ku + i__) * a_dim1], lda, &a[i__ + (*ku + i__) *
+ a_dim1], lda, &c_b13, &work[1], &c__1);
+ i__2 = *m - i__;
+ i__3 = *n - *ku - i__ + 1;
+ r__1 = -tau;
+ sger_(&i__2, &i__3, &r__1, &work[1], &c__1, &a[i__ + (*ku +
+ i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) *
+ a_dim1], lda);
+ a[i__ + (*ku + i__) * a_dim1] = -wa;
+ }
+
+/* Computing MIN */
+ i__2 = *m - 1 - *kl;
+ if (i__ <= min(i__2,*n)) {
+
+/* generate reflection to annihilate A(kl+i+1:m,i) */
+
+ i__2 = *m - *kl - i__ + 1;
+ wn = snrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
+ wa = r_sign(&wn, &a[*kl + i__ + i__ * a_dim1]);
+ if (wn == 0.f) {
+ tau = 0.f;
+ } else {
+ wb = a[*kl + i__ + i__ * a_dim1] + wa;
+ i__2 = *m - *kl - i__;
+ r__1 = 1.f / wb;
+ sscal_(&i__2, &r__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
+ c__1);
+ a[*kl + i__ + i__ * a_dim1] = 1.f;
+ tau = wb / wa;
+ }
+
+/* apply reflection to A(kl+i:m,i+1:n) from the left */
+
+ i__2 = *m - *kl - i__ + 1;
+ i__3 = *n - i__;
+ sgemv_("Transpose", &i__2, &i__3, &c_b11, &a[*kl + i__ + (i__
+ + 1) * a_dim1], lda, &a[*kl + i__ + i__ * a_dim1], &
+ c__1, &c_b13, &work[1], &c__1);
+ i__2 = *m - *kl - i__ + 1;
+ i__3 = *n - i__;
+ r__1 = -tau;
+ sger_(&i__2, &i__3, &r__1, &a[*kl + i__ + i__ * a_dim1], &
+ c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) *
+ a_dim1], lda);
+ a[*kl + i__ + i__ * a_dim1] = -wa;
+ }
+ }
+
+ i__2 = *m;
+ for (j = *kl + i__ + 1; j <= i__2; ++j) {
+ a[j + i__ * a_dim1] = 0.f;
+/* L50: */
+ }
+
+ i__2 = *n;
+ for (j = *ku + i__ + 1; j <= i__2; ++j) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L60: */
+ }
+/* L70: */
+ }
+ return 0;
+
+/* End of SLAGGE */
+
+} /* slagge_ */
diff --git a/TESTING/MATGEN/slagsy.c b/TESTING/MATGEN/slagsy.c
new file mode 100644
index 0000000..063eddd
--- /dev/null
+++ b/TESTING/MATGEN/slagsy.c
@@ -0,0 +1,285 @@
+/* slagsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static real c_b12 = 0.f;
+static real c_b19 = -1.f;
+static real c_b26 = 1.f;
+
+/* Subroutine */ int slagsy_(integer *n, integer *k, real *d__, real *a,
+ integer *lda, integer *iseed, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ real r__1;
+
+ /* Builtin functions */
+ double r_sign(real *, real *);
+
+ /* Local variables */
+ integer i__, j;
+ real wa, wb, wn, tau;
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ extern doublereal sdot_(integer *, real *, integer *, real *, integer *),
+ snrm2_(integer *, real *, integer *);
+ extern /* Subroutine */ int ssyr2_(char *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ real alpha;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ sgemv_(char *, integer *, integer *, real *, real *, integer *,
+ real *, integer *, real *, real *, integer *), saxpy_(
+ integer *, real *, real *, integer *, real *, integer *), ssymv_(
+ char *, integer *, real *, real *, integer *, real *, integer *,
+ real *, real *, integer *), xerbla_(char *, integer *), slarnv_(integer *, integer *, integer *, real *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAGSY generates a real symmetric matrix A, by pre- and post- */
+/* multiplying a real diagonal matrix D with a random orthogonal matrix: */
+/* A = U*D*U'. The semi-bandwidth may then be reduced to k by additional */
+/* orthogonal transformations. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of nonzero subdiagonals within the band of A. */
+/* 0 <= K <= N-1. */
+
+/* D (input) REAL array, dimension (N) */
+/* The diagonal elements of the diagonal matrix D. */
+
+/* A (output) REAL array, dimension (LDA,N) */
+/* The generated n by n symmetric matrix A (the full matrix is */
+/* stored). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= N. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* WORK (workspace) REAL array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --d__;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iseed;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*k < 0 || *k > *n - 1) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("SLAGSY", &i__1);
+ return 0;
+ }
+
+/* initialize lower triangle of A to diagonal matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L10: */
+ }
+/* L20: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ a[i__ + i__ * a_dim1] = d__[i__];
+/* L30: */
+ }
+
+/* Generate lower triangle of symmetric matrix */
+
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+
+/* generate random reflection */
+
+ i__1 = *n - i__ + 1;
+ slarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+ i__1 = *n - i__ + 1;
+ wn = snrm2_(&i__1, &work[1], &c__1);
+ wa = r_sign(&wn, &work[1]);
+ if (wn == 0.f) {
+ tau = 0.f;
+ } else {
+ wb = work[1] + wa;
+ i__1 = *n - i__;
+ r__1 = 1.f / wb;
+ sscal_(&i__1, &r__1, &work[2], &c__1);
+ work[1] = 1.f;
+ tau = wb / wa;
+ }
+
+/* apply random reflection to A(i:n,i:n) from the left */
+/* and the right */
+
+/* compute y := tau * A * u */
+
+ i__1 = *n - i__ + 1;
+ ssymv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], &
+ c__1, &c_b12, &work[*n + 1], &c__1);
+
+/* compute v := y - 1/2 * tau * ( y, u ) * u */
+
+ i__1 = *n - i__ + 1;
+ alpha = tau * -.5f * sdot_(&i__1, &work[*n + 1], &c__1, &work[1], &
+ c__1);
+ i__1 = *n - i__ + 1;
+ saxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
+
+/* apply the transformation as a rank-2 update to A(i:n,i:n) */
+
+ i__1 = *n - i__ + 1;
+ ssyr2_("Lower", &i__1, &c_b19, &work[1], &c__1, &work[*n + 1], &c__1,
+ &a[i__ + i__ * a_dim1], lda);
+/* L40: */
+ }
+
+/* Reduce number of subdiagonals to K */
+
+ i__1 = *n - 1 - *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* generate reflection to annihilate A(k+i+1:n,i) */
+
+ i__2 = *n - *k - i__ + 1;
+ wn = snrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
+ wa = r_sign(&wn, &a[*k + i__ + i__ * a_dim1]);
+ if (wn == 0.f) {
+ tau = 0.f;
+ } else {
+ wb = a[*k + i__ + i__ * a_dim1] + wa;
+ i__2 = *n - *k - i__;
+ r__1 = 1.f / wb;
+ sscal_(&i__2, &r__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1);
+ a[*k + i__ + i__ * a_dim1] = 1.f;
+ tau = wb / wa;
+ }
+
+/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */
+
+ i__2 = *n - *k - i__ + 1;
+ i__3 = *k - 1;
+ sgemv_("Transpose", &i__2, &i__3, &c_b26, &a[*k + i__ + (i__ + 1) *
+ a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b12, &
+ work[1], &c__1);
+ i__2 = *n - *k - i__ + 1;
+ i__3 = *k - 1;
+ r__1 = -tau;
+ sger_(&i__2, &i__3, &r__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[
+ 1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda);
+
+/* apply reflection to A(k+i:n,k+i:n) from the left and the right */
+
+/* compute y := tau * A * u */
+
+ i__2 = *n - *k - i__ + 1;
+ ssymv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda,
+ &a[*k + i__ + i__ * a_dim1], &c__1, &c_b12, &work[1], &c__1);
+
+/* compute v := y - 1/2 * tau * ( y, u ) * u */
+
+ i__2 = *n - *k - i__ + 1;
+ alpha = tau * -.5f * sdot_(&i__2, &work[1], &c__1, &a[*k + i__ + i__ *
+ a_dim1], &c__1);
+ i__2 = *n - *k - i__ + 1;
+ saxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], &
+ c__1);
+
+/* apply symmetric rank-2 update to A(k+i:n,k+i:n) */
+
+ i__2 = *n - *k - i__ + 1;
+ ssyr2_("Lower", &i__2, &c_b19, &a[*k + i__ + i__ * a_dim1], &c__1, &
+ work[1], &c__1, &a[*k + i__ + (*k + i__) * a_dim1], lda);
+
+ a[*k + i__ + i__ * a_dim1] = -wa;
+ i__2 = *n;
+ for (j = *k + i__ + 1; j <= i__2; ++j) {
+ a[j + i__ * a_dim1] = 0.f;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* Store full symmetric matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[j + i__ * a_dim1] = a[i__ + j * a_dim1];
+/* L70: */
+ }
+/* L80: */
+ }
+ return 0;
+
+/* End of SLAGSY */
+
+} /* slagsy_ */
diff --git a/TESTING/MATGEN/slahilb.c b/TESTING/MATGEN/slahilb.c
new file mode 100644
index 0000000..7a90c03
--- /dev/null
+++ b/TESTING/MATGEN/slahilb.c
@@ -0,0 +1,199 @@
+/* slahilb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b4 = 0.f;
+
+/* Subroutine */ int slahilb_(integer *n, integer *nrhs, real *a, integer *
+ lda, real *x, integer *ldx, real *b, integer *ldb, real *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, x_dim1, x_offset, b_dim1, b_offset, i__1, i__2;
+ real r__1;
+
+ /* Local variables */
+ integer i__, j, m, r__, ti, tm;
+ extern /* Subroutine */ int xerbla_(char *, integer *), slaset_(
+ char *, integer *, integer *, real *, real *, real *, integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
+/* Courant Institute, Argonne National Lab, and Rice University */
+/* 28 August, 2006 */
+
+/* David Vu <dtv at cs.berkeley.edu> */
+/* Yozo Hida <yozo at cs.berkeley.edu> */
+/* Jason Riedy <ejr at cs.berkeley.edu> */
+/* D. Halligan <dhalligan at berkeley.edu> */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAHILB generates an N by N scaled Hilbert matrix in A along with */
+/* NRHS right-hand sides in B and solutions in X such that A*X=B. */
+
+/* The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all */
+/* entries are integers. The right-hand sides are the first NRHS */
+/* columns of M * the identity matrix, and the solutions are the */
+/* first NRHS columns of the inverse Hilbert matrix. */
+
+/* The condition number of the Hilbert matrix grows exponentially with */
+/* its size, roughly as O(e ** (3.5*N)). Additionally, the inverse */
+/* Hilbert matrices beyond a relatively small dimension cannot be */
+/* generated exactly without extra precision. Precision is exhausted */
+/* when the largest entry in the inverse Hilbert matrix is greater than */
+/* 2 to the power of the number of bits in the fraction of the data type */
+/* used plus one, which is 24 for single precision. */
+
+/* In single, the generated solution is exact for N <= 6 and has */
+/* small componentwise error for 7 <= N <= 11. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The dimension of the matrix A. */
+
+/* NRHS (input) NRHS */
+/* The requested number of right-hand sides. */
+
+/* A (output) REAL array, dimension (LDA, N) */
+/* The generated scaled Hilbert matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= N. */
+
+/* X (output) REAL array, dimension (LDX, NRHS) */
+/* The generated exact solutions. Currently, the first NRHS */
+/* columns of the inverse Hilbert matrix. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= N. */
+
+/* B (output) REAL array, dimension (LDB, NRHS) */
+/* The generated right-hand sides. Currently, the first NRHS */
+/* columns of LCM(1, 2, ..., 2*N-1) * the identity matrix. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= N. */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* = 1: N is too large; the data is still generated but may not */
+/* be not exact. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+/* .. Local Scalars .. */
+/* .. Parameters .. */
+/* NMAX_EXACT the largest dimension where the generated data is */
+/* exact. */
+/* NMAX_APPROX the largest dimension where the generated data has */
+/* a small componentwise relative error. */
+/* .. */
+/* .. External Functions */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --work;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0 || *n > 11) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*lda < *n) {
+ *info = -4;
+ } else if (*ldx < *n) {
+ *info = -6;
+ } else if (*ldb < *n) {
+ *info = -8;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("SLAHILB", &i__1);
+ return 0;
+ }
+ if (*n > 6) {
+ *info = 1;
+ }
+/* Compute M = the LCM of the integers [1, 2*N-1]. The largest */
+/* reasonable N is small enough that integers suffice (up to N = 11). */
+ m = 1;
+ i__1 = (*n << 1) - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ tm = m;
+ ti = i__;
+ r__ = tm % ti;
+ while(r__ != 0) {
+ tm = ti;
+ ti = r__;
+ r__ = tm % ti;
+ }
+ m = m / ti * i__;
+ }
+/* Generate the scaled Hilbert matrix in A */
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = (real) m / (i__ + j - 1);
+ }
+ }
+/* Generate matrix B as simply the first NRHS columns of M * the */
+/* identity. */
+ r__1 = (real) m;
+ slaset_("Full", n, nrhs, &c_b4, &r__1, &b[b_offset], ldb);
+/* Generate the true solutions in X. Because B = the first NRHS */
+/* columns of M*I, the true solutions are just the first NRHS columns */
+/* of the inverse Hilbert matrix. */
+ work[1] = (real) (*n);
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ work[j] = work[j - 1] / (j - 1) * (j - 1 - *n) / (j - 1) * (*n + j -
+ 1);
+ }
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__ + j * x_dim1] = work[i__] * work[j] / (i__ + j - 1);
+ }
+ }
+ return 0;
+} /* slahilb_ */
diff --git a/TESTING/MATGEN/slakf2.c b/TESTING/MATGEN/slakf2.c
new file mode 100644
index 0000000..e0f6ed7
--- /dev/null
+++ b/TESTING/MATGEN/slakf2.c
@@ -0,0 +1,186 @@
+/* slakf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b3 = 0.f;
+
+/* Subroutine */ int slakf2_(integer *m, integer *n, real *a, integer *lda,
+ real *b, real *d__, real *e, real *z__, integer *ldz)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, d_dim1, d_offset, e_dim1,
+ e_offset, z_dim1, z_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ integer i__, j, l, ik, jk, mn, mn2;
+ extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Form the 2*M*N by 2*M*N matrix */
+
+/* Z = [ kron(In, A) -kron(B', Im) ] */
+/* [ kron(In, D) -kron(E', Im) ], */
+
+/* where In is the identity matrix of size n and X' is the transpose */
+/* of X. kron(X, Y) is the Kronecker product between the matrices X */
+/* and Y. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* Size of matrix, must be >= 1. */
+
+/* N (input) INTEGER */
+/* Size of matrix, must be >= 1. */
+
+/* A (input) REAL, dimension ( LDA, M ) */
+/* The matrix A in the output matrix Z. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, D, and E. ( LDA >= M+N ) */
+
+/* B (input) REAL, dimension ( LDA, N ) */
+/* D (input) REAL, dimension ( LDA, M ) */
+/* E (input) REAL, dimension ( LDA, N ) */
+/* The matrices used in forming the output matrix Z. */
+
+/* Z (output) REAL, dimension ( LDZ, 2*M*N ) */
+/* The resultant Kronecker M*N*2 by M*N*2 matrix (see above.) */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of Z. ( LDZ >= 2*M*N ) */
+
+/* ==================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize Z */
+
+ /* Parameter adjustments */
+ e_dim1 = *lda;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ d_dim1 = *lda;
+ d_offset = 1 + d_dim1;
+ d__ -= d_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+
+ /* Function Body */
+ mn = *m * *n;
+ mn2 = mn << 1;
+ slaset_("Full", &mn2, &mn2, &c_b3, &c_b3, &z__[z_offset], ldz);
+
+ ik = 1;
+ i__1 = *n;
+ for (l = 1; l <= i__1; ++l) {
+
+/* form kron(In, A) */
+
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = *m;
+ for (j = 1; j <= i__3; ++j) {
+ z__[ik + i__ - 1 + (ik + j - 1) * z_dim1] = a[i__ + j *
+ a_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* form kron(In, D) */
+
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = *m;
+ for (j = 1; j <= i__3; ++j) {
+ z__[ik + mn + i__ - 1 + (ik + j - 1) * z_dim1] = d__[i__ + j *
+ d_dim1];
+/* L30: */
+ }
+/* L40: */
+ }
+
+ ik += *m;
+/* L50: */
+ }
+
+ ik = 1;
+ i__1 = *n;
+ for (l = 1; l <= i__1; ++l) {
+ jk = mn + 1;
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+
+/* form -kron(B', Im) */
+
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ z__[ik + i__ - 1 + (jk + i__ - 1) * z_dim1] = -b[j + l *
+ b_dim1];
+/* L60: */
+ }
+
+/* form -kron(E', Im) */
+
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ z__[ik + mn + i__ - 1 + (jk + i__ - 1) * z_dim1] = -e[j + l *
+ e_dim1];
+/* L70: */
+ }
+
+ jk += *m;
+/* L80: */
+ }
+
+ ik += *m;
+/* L90: */
+ }
+
+ return 0;
+
+/* End of SLAKF2 */
+
+} /* slakf2_ */
diff --git a/TESTING/MATGEN/slaran.c b/TESTING/MATGEN/slaran.c
new file mode 100644
index 0000000..d427cbf
--- /dev/null
+++ b/TESTING/MATGEN/slaran.c
@@ -0,0 +1,124 @@
+/* slaran.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal slaran_(integer *iseed)
+{
+ /* System generated locals */
+ real ret_val;
+
+ /* Local variables */
+ integer it1, it2, it3, it4;
+ real rndout;
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARAN returns a random real number from a uniform (0,1) */
+/* distribution. */
+
+/* Arguments */
+/* ========= */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* Further Details */
+/* =============== */
+
+/* This routine uses a multiplicative congruential method with modulus */
+/* 2**48 and multiplier 33952834046453 (see G.S.Fishman, */
+/* 'Multiplicative congruential random number generators with modulus */
+/* 2**b: an exhaustive analysis for b = 32 and a partial analysis for */
+/* b = 48', Math. Comp. 189, pp 331-344, 1990). */
+
+/* 48-bit integers are stored in 4 integer array elements with 12 bits */
+/* per element. Hence the routine is portable across machines with */
+/* integers of 32 bits or more. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+ /* Parameter adjustments */
+ --iseed;
+
+ /* Function Body */
+L10:
+
+/* multiply the seed by the multiplier modulo 2**48 */
+
+ it4 = iseed[4] * 2549;
+ it3 = it4 / 4096;
+ it4 -= it3 << 12;
+ it3 = it3 + iseed[3] * 2549 + iseed[4] * 2508;
+ it2 = it3 / 4096;
+ it3 -= it2 << 12;
+ it2 = it2 + iseed[2] * 2549 + iseed[3] * 2508 + iseed[4] * 322;
+ it1 = it2 / 4096;
+ it2 -= it1 << 12;
+ it1 = it1 + iseed[1] * 2549 + iseed[2] * 2508 + iseed[3] * 322 + iseed[4]
+ * 494;
+ it1 %= 4096;
+
+/* return updated seed */
+
+ iseed[1] = it1;
+ iseed[2] = it2;
+ iseed[3] = it3;
+ iseed[4] = it4;
+
+/* convert 48-bit integer to a real number in the interval (0,1) */
+
+ rndout = ((real) it1 + ((real) it2 + ((real) it3 + (real) it4 *
+ 2.44140625e-4f) * 2.44140625e-4f) * 2.44140625e-4f) *
+ 2.44140625e-4f;
+
+ if (rndout == 1.f) {
+/* If a real number has n bits of precision, and the first */
+/* n bits of the 48-bit integer above happen to be all 1 (which */
+/* will occur about once every 2**n calls), then SLARAN will */
+/* be rounded to exactly 1.0. In IEEE single precision arithmetic, */
+/* this will happen relatively often since n = 24. */
+/* Since SLARAN is not supposed to return exactly 0.0 or 1.0 */
+/* (and some callers of SLARAN, such as CLARND, depend on that), */
+/* the statistically correct thing to do in this situation is */
+/* simply to iterate again. */
+/* N.B. the case SLARAN = 0.0 should not be possible. */
+
+ goto L10;
+ }
+
+ ret_val = rndout;
+ return ret_val;
+
+/* End of SLARAN */
+
+} /* slaran_ */
diff --git a/TESTING/MATGEN/slarge.c b/TESTING/MATGEN/slarge.c
new file mode 100644
index 0000000..0ac2397
--- /dev/null
+++ b/TESTING/MATGEN/slarge.c
@@ -0,0 +1,170 @@
+/* slarge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+static integer c__1 = 1;
+static real c_b8 = 1.f;
+static real c_b10 = 0.f;
+
+/* Subroutine */ int slarge_(integer *n, real *a, integer *lda, integer *
+ iseed, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ real r__1;
+
+ /* Builtin functions */
+ double r_sign(real *, real *);
+
+ /* Local variables */
+ integer i__;
+ real wa, wb, wn, tau;
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ extern doublereal snrm2_(integer *, real *, integer *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ sgemv_(char *, integer *, integer *, real *, real *, integer *,
+ real *, integer *, real *, real *, integer *), xerbla_(
+ char *, integer *), slarnv_(integer *, integer *, integer
+ *, real *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARGE pre- and post-multiplies a real general n by n matrix A */
+/* with a random orthogonal matrix: A = U*D*U'. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) REAL array, dimension (LDA,N) */
+/* On entry, the original n by n matrix A. */
+/* On exit, A is overwritten by U*A*U' for some random */
+/* orthogonal matrix U. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= N. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* WORK (workspace) REAL array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iseed;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*lda < max(1,*n)) {
+ *info = -3;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("SLARGE", &i__1);
+ return 0;
+ }
+
+/* pre- and post-multiply A by random orthogonal matrix */
+
+ for (i__ = *n; i__ >= 1; --i__) {
+
+/* generate random reflection */
+
+ i__1 = *n - i__ + 1;
+ slarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+ i__1 = *n - i__ + 1;
+ wn = snrm2_(&i__1, &work[1], &c__1);
+ wa = r_sign(&wn, &work[1]);
+ if (wn == 0.f) {
+ tau = 0.f;
+ } else {
+ wb = work[1] + wa;
+ i__1 = *n - i__;
+ r__1 = 1.f / wb;
+ sscal_(&i__1, &r__1, &work[2], &c__1);
+ work[1] = 1.f;
+ tau = wb / wa;
+ }
+
+/* multiply A(i:n,1:n) by random reflection from the left */
+
+ i__1 = *n - i__ + 1;
+ sgemv_("Transpose", &i__1, n, &c_b8, &a[i__ + a_dim1], lda, &work[1],
+ &c__1, &c_b10, &work[*n + 1], &c__1);
+ i__1 = *n - i__ + 1;
+ r__1 = -tau;
+ sger_(&i__1, n, &r__1, &work[1], &c__1, &work[*n + 1], &c__1, &a[i__
+ + a_dim1], lda);
+
+/* multiply A(1:n,i:n) by random reflection from the right */
+
+ i__1 = *n - i__ + 1;
+ sgemv_("No transpose", n, &i__1, &c_b8, &a[i__ * a_dim1 + 1], lda, &
+ work[1], &c__1, &c_b10, &work[*n + 1], &c__1);
+ i__1 = *n - i__ + 1;
+ r__1 = -tau;
+ sger_(n, &i__1, &r__1, &work[*n + 1], &c__1, &work[1], &c__1, &a[i__ *
+ a_dim1 + 1], lda);
+/* L10: */
+ }
+ return 0;
+
+/* End of SLARGE */
+
+} /* slarge_ */
diff --git a/TESTING/MATGEN/slarnd.c b/TESTING/MATGEN/slarnd.c
new file mode 100644
index 0000000..5e35cc3
--- /dev/null
+++ b/TESTING/MATGEN/slarnd.c
@@ -0,0 +1,108 @@
+/* slarnd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal slarnd_(integer *idist, integer *iseed)
+{
+ /* System generated locals */
+ real ret_val;
+
+ /* Builtin functions */
+ double log(doublereal), sqrt(doublereal), cos(doublereal);
+
+ /* Local variables */
+ real t1, t2;
+ extern doublereal slaran_(integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLARND returns a random real number from a uniform or normal */
+/* distribution. */
+
+/* Arguments */
+/* ========= */
+
+/* IDIST (input) INTEGER */
+/* Specifies the distribution of the random numbers: */
+/* = 1: uniform (0,1) */
+/* = 2: uniform (-1,1) */
+/* = 3: normal (0,1) */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* Further Details */
+/* =============== */
+
+/* This routine calls the auxiliary routine SLARAN to generate a random */
+/* real number from a uniform (0,1) distribution. The Box-Muller method */
+/* is used to transform numbers from a uniform to a normal distribution. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Generate a real random number from a uniform (0,1) distribution */
+
+ /* Parameter adjustments */
+ --iseed;
+
+ /* Function Body */
+ t1 = slaran_(&iseed[1]);
+
+ if (*idist == 1) {
+
+/* uniform (0,1) */
+
+ ret_val = t1;
+ } else if (*idist == 2) {
+
+/* uniform (-1,1) */
+
+ ret_val = t1 * 2.f - 1.f;
+ } else if (*idist == 3) {
+
+/* normal (0,1) */
+
+ t2 = slaran_(&iseed[1]);
+ ret_val = sqrt(log(t1) * -2.f) * cos(t2 *
+ 6.2831853071795864769252867663f);
+ }
+ return ret_val;
+
+/* End of SLARND */
+
+} /* slarnd_ */
diff --git a/TESTING/MATGEN/slaror.c b/TESTING/MATGEN/slaror.c
new file mode 100644
index 0000000..ea1db7a
--- /dev/null
+++ b/TESTING/MATGEN/slaror.c
@@ -0,0 +1,299 @@
+/* slaror.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b9 = 0.f;
+static real c_b10 = 1.f;
+static integer c__3 = 3;
+static integer c__1 = 1;
+
+/* Subroutine */ int slaror_(char *side, char *init, integer *m, integer *n,
+ real *a, integer *lda, integer *iseed, real *x, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real r__1;
+
+ /* Builtin functions */
+ double r_sign(real *, real *);
+
+ /* Local variables */
+ integer j, kbeg, jcol;
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ integer irow;
+ extern doublereal snrm2_(integer *, real *, integer *);
+ extern logical lsame_(char *, char *);
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
+ sgemv_(char *, integer *, integer *, real *, real *, integer *,
+ real *, integer *, real *, real *, integer *);
+ integer ixfrm, itype, nxfrm;
+ real xnorm;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ real factor;
+ extern doublereal slarnd_(integer *, integer *);
+ extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *);
+ real xnorms;
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAROR pre- or post-multiplies an M by N matrix A by a random */
+/* orthogonal matrix U, overwriting A. A may optionally be initialized */
+/* to the identity matrix before multiplying by U. U is generated using */
+/* the method of G.W. Stewart (SIAM J. Numer. Anal. 17, 1980, 403-409). */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE (input) CHARACTER*1 */
+/* Specifies whether A is multiplied on the left or right by U. */
+/* = 'L': Multiply A on the left (premultiply) by U */
+/* = 'R': Multiply A on the right (postmultiply) by U' */
+/* = 'C' or 'T': Multiply A on the left by U and the right */
+/* by U' (Here, U' means U-transpose.) */
+
+/* INIT (input) CHARACTER*1 */
+/* Specifies whether or not A should be initialized to the */
+/* identity matrix. */
+/* = 'I': Initialize A to (a section of) the identity matrix */
+/* before applying U. */
+/* = 'N': No initialization. Apply U to the input matrix A. */
+
+/* INIT = 'I' may be used to generate square or rectangular */
+/* orthogonal matrices: */
+
+/* For M = N and SIDE = 'L' or 'R', the rows will be orthogonal */
+/* to each other, as will the columns. */
+
+/* If M < N, SIDE = 'R' produces a dense matrix whose rows are */
+/* orthogonal and whose columns are not, while SIDE = 'L' */
+/* produces a matrix whose rows are orthogonal, and whose first */
+/* M columns are orthogonal, and whose remaining columns are */
+/* zero. */
+
+/* If M > N, SIDE = 'L' produces a dense matrix whose columns */
+/* are orthogonal and whose rows are not, while SIDE = 'R' */
+/* produces a matrix whose columns are orthogonal, and whose */
+/* first M rows are orthogonal, and whose remaining rows are */
+/* zero. */
+
+/* M (input) INTEGER */
+/* The number of rows of A. */
+
+/* N (input) INTEGER */
+/* The number of columns of A. */
+
+/* A (input/output) REAL array, dimension (LDA, N) */
+/* On entry, the array A. */
+/* On exit, overwritten by U A ( if SIDE = 'L' ), */
+/* or by A U ( if SIDE = 'R' ), */
+/* or by U A U' ( if SIDE = 'C' or 'T'). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= max(1,M). */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to SLAROR to continue the same random number */
+/* sequence. */
+
+/* X (workspace) REAL array, dimension (3*MAX( M, N )) */
+/* Workspace of length */
+/* 2*M + N if SIDE = 'L', */
+/* 2*N + M if SIDE = 'R', */
+/* 3*N if SIDE = 'C' or 'T'. */
+
+/* INFO (output) INTEGER */
+/* An error flag. It is set to: */
+/* = 0: normal return */
+/* < 0: if INFO = -k, the k-th argument had an illegal value */
+/* = 1: if the random numbers generated by SLARND are bad. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iseed;
+ --x;
+
+ /* Function Body */
+ if (*n == 0 || *m == 0) {
+ return 0;
+ }
+
+ itype = 0;
+ if (lsame_(side, "L")) {
+ itype = 1;
+ } else if (lsame_(side, "R")) {
+ itype = 2;
+ } else if (lsame_(side, "C") || lsame_(side, "T")) {
+ itype = 3;
+ }
+
+/* Check for argument errors. */
+
+ *info = 0;
+ if (itype == 0) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0 || itype == 3 && *n != *m) {
+ *info = -4;
+ } else if (*lda < *m) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLAROR", &i__1);
+ return 0;
+ }
+
+ if (itype == 1) {
+ nxfrm = *m;
+ } else {
+ nxfrm = *n;
+ }
+
+/* Initialize A to the identity matrix if desired */
+
+ if (lsame_(init, "I")) {
+ slaset_("Full", m, n, &c_b9, &c_b10, &a[a_offset], lda);
+ }
+
+/* If no rotation possible, multiply by random +/-1 */
+
+/* Compute rotation by computing Householder transformations */
+/* H(2), H(3), ..., H(nhouse) */
+
+ i__1 = nxfrm;
+ for (j = 1; j <= i__1; ++j) {
+ x[j] = 0.f;
+/* L10: */
+ }
+
+ i__1 = nxfrm;
+ for (ixfrm = 2; ixfrm <= i__1; ++ixfrm) {
+ kbeg = nxfrm - ixfrm + 1;
+
+/* Generate independent normal( 0, 1 ) random numbers */
+
+ i__2 = nxfrm;
+ for (j = kbeg; j <= i__2; ++j) {
+ x[j] = slarnd_(&c__3, &iseed[1]);
+/* L20: */
+ }
+
+/* Generate a Householder transformation from the random vector X */
+
+ xnorm = snrm2_(&ixfrm, &x[kbeg], &c__1);
+ xnorms = r_sign(&xnorm, &x[kbeg]);
+ r__1 = -x[kbeg];
+ x[kbeg + nxfrm] = r_sign(&c_b10, &r__1);
+ factor = xnorms * (xnorms + x[kbeg]);
+ if (dabs(factor) < 1e-20f) {
+ *info = 1;
+ xerbla_("SLAROR", info);
+ return 0;
+ } else {
+ factor = 1.f / factor;
+ }
+ x[kbeg] += xnorms;
+
+/* Apply Householder transformation to A */
+
+ if (itype == 1 || itype == 3) {
+
+/* Apply H(k) from the left. */
+
+ sgemv_("T", &ixfrm, n, &c_b10, &a[kbeg + a_dim1], lda, &x[kbeg], &
+ c__1, &c_b9, &x[(nxfrm << 1) + 1], &c__1);
+ r__1 = -factor;
+ sger_(&ixfrm, n, &r__1, &x[kbeg], &c__1, &x[(nxfrm << 1) + 1], &
+ c__1, &a[kbeg + a_dim1], lda);
+
+ }
+
+ if (itype == 2 || itype == 3) {
+
+/* Apply H(k) from the right. */
+
+ sgemv_("N", m, &ixfrm, &c_b10, &a[kbeg * a_dim1 + 1], lda, &x[
+ kbeg], &c__1, &c_b9, &x[(nxfrm << 1) + 1], &c__1);
+ r__1 = -factor;
+ sger_(m, &ixfrm, &r__1, &x[(nxfrm << 1) + 1], &c__1, &x[kbeg], &
+ c__1, &a[kbeg * a_dim1 + 1], lda);
+
+ }
+/* L30: */
+ }
+
+ r__1 = slarnd_(&c__3, &iseed[1]);
+ x[nxfrm * 2] = r_sign(&c_b10, &r__1);
+
+/* Scale the matrix A by D. */
+
+ if (itype == 1 || itype == 3) {
+ i__1 = *m;
+ for (irow = 1; irow <= i__1; ++irow) {
+ sscal_(n, &x[nxfrm + irow], &a[irow + a_dim1], lda);
+/* L40: */
+ }
+ }
+
+ if (itype == 2 || itype == 3) {
+ i__1 = *n;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ sscal_(m, &x[nxfrm + jcol], &a[jcol * a_dim1 + 1], &c__1);
+/* L50: */
+ }
+ }
+ return 0;
+
+/* End of SLAROR */
+
+} /* slaror_ */
diff --git a/TESTING/MATGEN/slarot.c b/TESTING/MATGEN/slarot.c
new file mode 100644
index 0000000..771834d
--- /dev/null
+++ b/TESTING/MATGEN/slarot.c
@@ -0,0 +1,308 @@
+/* slarot.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__4 = 4;
+static integer c__8 = 8;
+static integer c__1 = 1;
+
+/* Subroutine */ int slarot_(logical *lrows, logical *lleft, logical *lright,
+ integer *nl, real *c__, real *s, real *a, integer *lda, real *xleft,
+ real *xright)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ integer ix, iy, nt;
+ real xt[2], yt[2];
+ integer iyt, iinc;
+ extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
+ integer *, real *, real *);
+ integer inext;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLAROT applies a (Givens) rotation to two adjacent rows or */
+/* columns, where one element of the first and/or last column/row */
+/* for use on matrices stored in some format other than GE, so */
+/* that elements of the matrix may be used or modified for which */
+/* no array element is provided. */
+
+/* One example is a symmetric matrix in SB format (bandwidth=4), for */
+/* which UPLO='L': Two adjacent rows will have the format: */
+
+/* row j: * * * * * . . . . */
+/* row j+1: * * * * * . . . . */
+
+/* '*' indicates elements for which storage is provided, */
+/* '.' indicates elements for which no storage is provided, but */
+/* are not necessarily zero; their values are determined by */
+/* symmetry. ' ' indicates elements which are necessarily zero, */
+/* and have no storage provided. */
+
+/* Those columns which have two '*'s can be handled by SROT. */
+/* Those columns which have no '*'s can be ignored, since as long */
+/* as the Givens rotations are carefully applied to preserve */
+/* symmetry, their values are determined. */
+/* Those columns which have one '*' have to be handled separately, */
+/* by using separate variables "p" and "q": */
+
+/* row j: * * * * * p . . . */
+/* row j+1: q * * * * * . . . . */
+
+/* The element p would have to be set correctly, then that column */
+/* is rotated, setting p to its new value. The next call to */
+/* SLAROT would rotate columns j and j+1, using p, and restore */
+/* symmetry. The element q would start out being zero, and be */
+/* made non-zero by the rotation. Later, rotations would presumably */
+/* be chosen to zero q out. */
+
+/* Typical Calling Sequences: rotating the i-th and (i+1)-st rows. */
+/* ------- ------- --------- */
+
+/* General dense matrix: */
+
+/* CALL SLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S, */
+/* A(i,1),LDA, DUMMY, DUMMY) */
+
+/* General banded matrix in GB format: */
+
+/* j = MAX(1, i-KL ) */
+/* NL = MIN( N, i+KU+1 ) + 1-j */
+/* CALL SLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S, */
+/* A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT ) */
+
+/* [ note that i+1-j is just MIN(i,KL+1) ] */
+
+/* Symmetric banded matrix in SY format, bandwidth K, */
+/* lower triangle only: */
+
+/* j = MAX(1, i-K ) */
+/* NL = MIN( K+1, i ) + 1 */
+/* CALL SLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S, */
+/* A(i,j), LDA, XLEFT, XRIGHT ) */
+
+/* Same, but upper triangle only: */
+
+/* NL = MIN( K+1, N-i ) + 1 */
+/* CALL SLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S, */
+/* A(i,i), LDA, XLEFT, XRIGHT ) */
+
+/* Symmetric banded matrix in SB format, bandwidth K, */
+/* lower triangle only: */
+
+/* [ same as for SY, except:] */
+/* . . . . */
+/* A(i+1-j,j), LDA-1, XLEFT, XRIGHT ) */
+
+/* [ note that i+1-j is just MIN(i,K+1) ] */
+
+/* Same, but upper triangle only: */
+/* . . . */
+/* A(K+1,i), LDA-1, XLEFT, XRIGHT ) */
+
+/* Rotating columns is just the transpose of rotating rows, except */
+/* for GB and SB: (rotating columns i and i+1) */
+
+/* GB: */
+/* j = MAX(1, i-KU ) */
+/* NL = MIN( N, i+KL+1 ) + 1-j */
+/* CALL SLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S, */
+/* A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM ) */
+
+/* [note that KU+j+1-i is just MAX(1,KU+2-i)] */
+
+/* SB: (upper triangle) */
+
+/* . . . . . . */
+/* A(K+j+1-i,i),LDA-1, XTOP, XBOTTM ) */
+
+/* SB: (lower triangle) */
+
+/* . . . . . . */
+/* A(1,i),LDA-1, XTOP, XBOTTM ) */
+
+/* Arguments */
+/* ========= */
+
+/* LROWS - LOGICAL */
+/* If .TRUE., then SLAROT will rotate two rows. If .FALSE., */
+/* then it will rotate two columns. */
+/* Not modified. */
+
+/* LLEFT - LOGICAL */
+/* If .TRUE., then XLEFT will be used instead of the */
+/* corresponding element of A for the first element in the */
+/* second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) */
+/* If .FALSE., then the corresponding element of A will be */
+/* used. */
+/* Not modified. */
+
+/* LRIGHT - LOGICAL */
+/* If .TRUE., then XRIGHT will be used instead of the */
+/* corresponding element of A for the last element in the */
+/* first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If */
+/* .FALSE., then the corresponding element of A will be used. */
+/* Not modified. */
+
+/* NL - INTEGER */
+/* The length of the rows (if LROWS=.TRUE.) or columns (if */
+/* LROWS=.FALSE.) to be rotated. If XLEFT and/or XRIGHT are */
+/* used, the columns/rows they are in should be included in */
+/* NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at */
+/* least 2. The number of rows/columns to be rotated */
+/* exclusive of those involving XLEFT and/or XRIGHT may */
+/* not be negative, i.e., NL minus how many of LLEFT and */
+/* LRIGHT are .TRUE. must be at least zero; if not, XERBLA */
+/* will be called. */
+/* Not modified. */
+
+/* C, S - REAL */
+/* Specify the Givens rotation to be applied. If LROWS is */
+/* true, then the matrix ( c s ) */
+/* (-s c ) is applied from the left; */
+/* if false, then the transpose thereof is applied from the */
+/* right. For a Givens rotation, C**2 + S**2 should be 1, */
+/* but this is not checked. */
+/* Not modified. */
+
+/* A - REAL array. */
+/* The array containing the rows/columns to be rotated. The */
+/* first element of A should be the upper left element to */
+/* be rotated. */
+/* Read and modified. */
+
+/* LDA - INTEGER */
+/* The "effective" leading dimension of A. If A contains */
+/* a matrix stored in GE or SY format, then this is just */
+/* the leading dimension of A as dimensioned in the calling */
+/* routine. If A contains a matrix stored in band (GB or SB) */
+/* format, then this should be *one less* than the leading */
+/* dimension used in the calling routine. Thus, if */
+/* A were dimensioned A(LDA,*) in SLAROT, then A(1,j) would */
+/* be the j-th element in the first of the two rows */
+/* to be rotated, and A(2,j) would be the j-th in the second, */
+/* regardless of how the array may be stored in the calling */
+/* routine. [A cannot, however, actually be dimensioned thus, */
+/* since for band format, the row number may exceed LDA, which */
+/* is not legal FORTRAN.] */
+/* If LROWS=.TRUE., then LDA must be at least 1, otherwise */
+/* it must be at least NL minus the number of .TRUE. values */
+/* in XLEFT and XRIGHT. */
+/* Not modified. */
+
+/* XLEFT - REAL */
+/* If LLEFT is .TRUE., then XLEFT will be used and modified */
+/* instead of A(2,1) (if LROWS=.TRUE.) or A(1,2) */
+/* (if LROWS=.FALSE.). */
+/* Read and modified. */
+
+/* XRIGHT - REAL */
+/* If LRIGHT is .TRUE., then XRIGHT will be used and modified */
+/* instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1) */
+/* (if LROWS=.FALSE.). */
+/* Read and modified. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Set up indices, arrays for ends */
+
+ /* Parameter adjustments */
+ --a;
+
+ /* Function Body */
+ if (*lrows) {
+ iinc = *lda;
+ inext = 1;
+ } else {
+ iinc = 1;
+ inext = *lda;
+ }
+
+ if (*lleft) {
+ nt = 1;
+ ix = iinc + 1;
+ iy = *lda + 2;
+ xt[0] = a[1];
+ yt[0] = *xleft;
+ } else {
+ nt = 0;
+ ix = 1;
+ iy = inext + 1;
+ }
+
+ if (*lright) {
+ iyt = inext + 1 + (*nl - 1) * iinc;
+ ++nt;
+ xt[nt - 1] = *xright;
+ yt[nt - 1] = a[iyt];
+ }
+
+/* Check for errors */
+
+ if (*nl < nt) {
+ xerbla_("SLAROT", &c__4);
+ return 0;
+ }
+ if (*lda <= 0 || ! (*lrows) && *lda < *nl - nt) {
+ xerbla_("SLAROT", &c__8);
+ return 0;
+ }
+
+/* Rotate */
+
+ i__1 = *nl - nt;
+ srot_(&i__1, &a[ix], &iinc, &a[iy], &iinc, c__, s);
+ srot_(&nt, xt, &c__1, yt, &c__1, c__, s);
+
+/* Stuff values back into XLEFT, XRIGHT, etc. */
+
+ if (*lleft) {
+ a[1] = xt[0];
+ *xleft = yt[0];
+ }
+
+ if (*lright) {
+ *xright = xt[nt - 1];
+ a[iyt] = yt[nt - 1];
+ }
+
+ return 0;
+
+/* End of SLAROT */
+
+} /* slarot_ */
diff --git a/TESTING/MATGEN/slatm1.c b/TESTING/MATGEN/slatm1.c
new file mode 100644
index 0000000..faaf564
--- /dev/null
+++ b/TESTING/MATGEN/slatm1.c
@@ -0,0 +1,284 @@
+/* slatm1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slatm1_(integer *mode, real *cond, integer *irsign,
+ integer *idist, integer *iseed, real *d__, integer *n, integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double pow_dd(doublereal *, doublereal *), pow_ri(real *, integer *), log(
+ doublereal), exp(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real temp, alpha;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal slaran_(integer *);
+ extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
+ *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLATM1 computes the entries of D(1..N) as specified by */
+/* MODE, COND and IRSIGN. IDIST and ISEED determine the generation */
+/* of random numbers. SLATM1 is called by SLATMR to generate */
+/* random test matrices for LAPACK programs. */
+
+/* Arguments */
+/* ========= */
+
+/* MODE - INTEGER */
+/* On entry describes how D is to be computed: */
+/* MODE = 0 means do not change D. */
+/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
+/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
+/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
+/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* MODE = 5 sets D to random numbers in the range */
+/* ( 1/COND , 1 ) such that their logarithms */
+/* are uniformly distributed. */
+/* MODE = 6 set D to random numbers from same distribution */
+/* as the rest of the matrix. */
+/* MODE < 0 has the same meaning as ABS(MODE), except that */
+/* the order of the elements of D is reversed. */
+/* Thus if MODE is positive, D has entries ranging from */
+/* 1 to 1/COND, if negative, from 1/COND to 1, */
+/* Not modified. */
+
+/* COND - REAL */
+/* On entry, used as described under MODE above. */
+/* If used, it must be >= 1. Not modified. */
+
+/* IRSIGN - INTEGER */
+/* On entry, if MODE neither -6, 0 nor 6, determines sign of */
+/* entries of D */
+/* 0 => leave entries of D unchanged */
+/* 1 => multiply each entry of D by 1 or -1 with probability .5 */
+
+/* IDIST - CHARACTER*1 */
+/* On entry, IDIST specifies the type of distribution to be */
+/* used to generate a random matrix . */
+/* 1 => UNIFORM( 0, 1 ) */
+/* 2 => UNIFORM( -1, 1 ) */
+/* 3 => NORMAL( 0, 1 ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension ( 4 ) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The random number generator uses a */
+/* linear congruential sequence limited to small */
+/* integers, and so should produce machine independent */
+/* random numbers. The values of ISEED are changed on */
+/* exit, and can be used in the next call to SLATM1 */
+/* to continue the same random number sequence. */
+/* Changed on exit. */
+
+/* D - REAL array, dimension ( MIN( M , N ) ) */
+/* Array to be computed according to MODE, COND and IRSIGN. */
+/* May be changed on exit if MODE is nonzero. */
+
+/* N - INTEGER */
+/* Number of entries of D. Not modified. */
+
+/* INFO - INTEGER */
+/* 0 => normal termination */
+/* -1 => if MODE not in range -6 to 6 */
+/* -2 => if MODE neither -6, 0 nor 6, and */
+/* IRSIGN neither 0 nor 1 */
+/* -3 => if MODE neither -6, 0 nor 6 and COND less than 1 */
+/* -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 3 */
+/* -7 => if N negative */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and Test the input parameters. Initialize flags & seed. */
+
+ /* Parameter adjustments */
+ --d__;
+ --iseed;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Set INFO if an error */
+
+ if (*mode < -6 || *mode > 6) {
+ *info = -1;
+ } else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && *
+ irsign != 1)) {
+ *info = -2;
+ } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.f) {
+ *info = -3;
+ } else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 3)) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -7;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLATM1", &i__1);
+ return 0;
+ }
+
+/* Compute D according to COND and MODE */
+
+ if (*mode != 0) {
+ switch (abs(*mode)) {
+ case 1: goto L10;
+ case 2: goto L30;
+ case 3: goto L50;
+ case 4: goto L70;
+ case 5: goto L90;
+ case 6: goto L110;
+ }
+
+/* One large D value: */
+
+L10:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = 1.f / *cond;
+/* L20: */
+ }
+ d__[1] = 1.f;
+ goto L120;
+
+/* One small D value: */
+
+L30:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = 1.f;
+/* L40: */
+ }
+ d__[*n] = 1.f / *cond;
+ goto L120;
+
+/* Exponentially distributed D values: */
+
+L50:
+ d__[1] = 1.f;
+ if (*n > 1) {
+ d__1 = (doublereal) (*cond);
+ d__2 = (doublereal) (-1.f / (real) (*n - 1));
+ alpha = pow_dd(&d__1, &d__2);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__ - 1;
+ d__[i__] = pow_ri(&alpha, &i__2);
+/* L60: */
+ }
+ }
+ goto L120;
+
+/* Arithmetically distributed D values: */
+
+L70:
+ d__[1] = 1.f;
+ if (*n > 1) {
+ temp = 1.f / *cond;
+ alpha = (1.f - temp) / (real) (*n - 1);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ d__[i__] = (real) (*n - i__) * alpha + temp;
+/* L80: */
+ }
+ }
+ goto L120;
+
+/* Randomly distributed D values on ( 1/COND , 1): */
+
+L90:
+ alpha = log(1.f / *cond);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = exp(alpha * slaran_(&iseed[1]));
+/* L100: */
+ }
+ goto L120;
+
+/* Randomly distributed D values from IDIST */
+
+L110:
+ slarnv_(idist, &iseed[1], n, &d__[1]);
+
+L120:
+
+/* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */
+/* random signs to D */
+
+ if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = slaran_(&iseed[1]);
+ if (temp > .5f) {
+ d__[i__] = -d__[i__];
+ }
+/* L130: */
+ }
+ }
+
+/* Reverse if MODE < 0 */
+
+ if (*mode < 0) {
+ i__1 = *n / 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = d__[i__];
+ d__[i__] = d__[*n + 1 - i__];
+ d__[*n + 1 - i__] = temp;
+/* L140: */
+ }
+ }
+
+ }
+
+ return 0;
+
+/* End of SLATM1 */
+
+} /* slatm1_ */
diff --git a/TESTING/MATGEN/slatm2.c b/TESTING/MATGEN/slatm2.c
new file mode 100644
index 0000000..6a9fc0d
--- /dev/null
+++ b/TESTING/MATGEN/slatm2.c
@@ -0,0 +1,251 @@
+/* slatm2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal slatm2_(integer *m, integer *n, integer *i__, integer *j, integer *
+ kl, integer *ku, integer *idist, integer *iseed, real *d__, integer *
+ igrade, real *dl, real *dr, integer *ipvtng, integer *iwork, real *
+ sparse)
+{
+ /* System generated locals */
+ real ret_val;
+
+ /* Local variables */
+ integer isub, jsub;
+ real temp;
+ extern doublereal slaran_(integer *), slarnd_(integer *, integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+
+/* .. */
+
+/* .. Array Arguments .. */
+
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLATM2 returns the (I,J) entry of a random matrix of dimension */
+/* (M, N) described by the other paramters. It is called by the */
+/* SLATMR routine in order to build random test matrices. No error */
+/* checking on parameters is done, because this routine is called in */
+/* a tight loop by SLATMR which has already checked the parameters. */
+
+/* Use of SLATM2 differs from SLATM3 in the order in which the random */
+/* number generator is called to fill in random matrix entries. */
+/* With SLATM2, the generator is called to fill in the pivoted matrix */
+/* columnwise. With SLATM3, the generator is called to fill in the */
+/* matrix columnwise, after which it is pivoted. Thus, SLATM3 can */
+/* be used to construct random matrices which differ only in their */
+/* order of rows and/or columns. SLATM2 is used to construct band */
+/* matrices while avoiding calling the random number generator for */
+/* entries outside the band (and therefore generating random numbers */
+
+/* The matrix whose (I,J) entry is returned is constructed as */
+/* follows (this routine only computes one entry): */
+
+/* If I is outside (1..M) or J is outside (1..N), return zero */
+/* (this is convenient for generating matrices in band format). */
+
+/* Generate a matrix A with random entries of distribution IDIST. */
+
+/* Set the diagonal to D. */
+
+/* Grade the matrix, if desired, from the left (by DL) and/or */
+/* from the right (by DR or DL) as specified by IGRADE. */
+
+/* Permute, if desired, the rows and/or columns as specified by */
+/* IPVTNG and IWORK. */
+
+/* Band the matrix to have lower bandwidth KL and upper */
+/* bandwidth KU. */
+
+/* Set random entries to zero as specified by SPARSE. */
+
+/* Arguments */
+/* ========= */
+
+/* M - INTEGER */
+/* Number of rows of matrix. Not modified. */
+
+/* N - INTEGER */
+/* Number of columns of matrix. Not modified. */
+
+/* I - INTEGER */
+/* Row of entry to be returned. Not modified. */
+
+/* J - INTEGER */
+/* Column of entry to be returned. Not modified. */
+
+/* KL - INTEGER */
+/* Lower bandwidth. Not modified. */
+
+/* KU - INTEGER */
+/* Upper bandwidth. Not modified. */
+
+/* IDIST - INTEGER */
+/* On entry, IDIST specifies the type of distribution to be */
+/* used to generate a random matrix . */
+/* 1 => UNIFORM( 0, 1 ) */
+/* 2 => UNIFORM( -1, 1 ) */
+/* 3 => NORMAL( 0, 1 ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array of dimension ( 4 ) */
+/* Seed for random number generator. */
+/* Changed on exit. */
+
+/* D - REAL array of dimension ( MIN( I , J ) ) */
+/* Diagonal entries of matrix. Not modified. */
+
+/* IGRADE - INTEGER */
+/* Specifies grading of matrix as follows: */
+/* 0 => no grading */
+/* 1 => matrix premultiplied by diag( DL ) */
+/* 2 => matrix postmultiplied by diag( DR ) */
+/* 3 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DR ) */
+/* 4 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by inv( diag( DL ) ) */
+/* 5 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DL ) */
+/* Not modified. */
+
+/* DL - REAL array ( I or J, as appropriate ) */
+/* Left scale factors for grading matrix. Not modified. */
+
+/* DR - REAL array ( I or J, as appropriate ) */
+/* Right scale factors for grading matrix. Not modified. */
+
+/* IPVTNG - INTEGER */
+/* On entry specifies pivoting permutations as follows: */
+/* 0 => none. */
+/* 1 => row pivoting. */
+/* 2 => column pivoting. */
+/* 3 => full pivoting, i.e., on both sides. */
+/* Not modified. */
+
+/* IWORK - INTEGER array ( I or J, as appropriate ) */
+/* This array specifies the permutation used. The */
+/* row (or column) in position K was originally in */
+/* position IWORK( K ). */
+/* This differs from IWORK for SLATM3. Not modified. */
+
+/* SPARSE - REAL between 0. and 1. */
+/* On entry specifies the sparsity of the matrix */
+/* if sparse matix is to be generated. */
+/* SPARSE should lie between 0 and 1. */
+/* A uniform ( 0, 1 ) random number x is generated and */
+/* compared to SPARSE; if x is larger the matrix entry */
+/* is unchanged and if x is smaller the entry is set */
+/* to zero. Thus on the average a fraction SPARSE of the */
+/* entries will be set to zero. */
+/* Not modified. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+
+/* .. */
+
+/* .. Local Scalars .. */
+
+/* .. */
+
+/* .. External Functions .. */
+
+/* .. */
+
+/* ----------------------------------------------------------------------- */
+
+/* .. Executable Statements .. */
+
+
+/* Check for I and J in range */
+
+ /* Parameter adjustments */
+ --iwork;
+ --dr;
+ --dl;
+ --d__;
+ --iseed;
+
+ /* Function Body */
+ if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) {
+ ret_val = 0.f;
+ return ret_val;
+ }
+
+/* Check for banding */
+
+ if (*j > *i__ + *ku || *j < *i__ - *kl) {
+ ret_val = 0.f;
+ return ret_val;
+ }
+
+/* Check for sparsity */
+
+ if (*sparse > 0.f) {
+ if (slaran_(&iseed[1]) < *sparse) {
+ ret_val = 0.f;
+ return ret_val;
+ }
+ }
+
+/* Compute subscripts depending on IPVTNG */
+
+ if (*ipvtng == 0) {
+ isub = *i__;
+ jsub = *j;
+ } else if (*ipvtng == 1) {
+ isub = iwork[*i__];
+ jsub = *j;
+ } else if (*ipvtng == 2) {
+ isub = *i__;
+ jsub = iwork[*j];
+ } else if (*ipvtng == 3) {
+ isub = iwork[*i__];
+ jsub = iwork[*j];
+ }
+
+/* Compute entry and grade it according to IGRADE */
+
+ if (isub == jsub) {
+ temp = d__[isub];
+ } else {
+ temp = slarnd_(idist, &iseed[1]);
+ }
+ if (*igrade == 1) {
+ temp *= dl[isub];
+ } else if (*igrade == 2) {
+ temp *= dr[jsub];
+ } else if (*igrade == 3) {
+ temp = temp * dl[isub] * dr[jsub];
+ } else if (*igrade == 4 && isub != jsub) {
+ temp = temp * dl[isub] / dl[jsub];
+ } else if (*igrade == 5) {
+ temp = temp * dl[isub] * dl[jsub];
+ }
+ ret_val = temp;
+ return ret_val;
+
+/* End of SLATM2 */
+
+} /* slatm2_ */
diff --git a/TESTING/MATGEN/slatm3.c b/TESTING/MATGEN/slatm3.c
new file mode 100644
index 0000000..27d8f5c
--- /dev/null
+++ b/TESTING/MATGEN/slatm3.c
@@ -0,0 +1,261 @@
+/* slatm3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal slatm3_(integer *m, integer *n, integer *i__, integer *j, integer *
+ isub, integer *jsub, integer *kl, integer *ku, integer *idist,
+ integer *iseed, real *d__, integer *igrade, real *dl, real *dr,
+ integer *ipvtng, integer *iwork, real *sparse)
+{
+ /* System generated locals */
+ real ret_val;
+
+ /* Local variables */
+ real temp;
+ extern doublereal slaran_(integer *), slarnd_(integer *, integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+
+/* .. */
+
+/* .. Array Arguments .. */
+
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLATM3 returns the (ISUB,JSUB) entry of a random matrix of */
+/* dimension (M, N) described by the other paramters. (ISUB,JSUB) */
+/* is the final position of the (I,J) entry after pivoting */
+/* according to IPVTNG and IWORK. SLATM3 is called by the */
+/* SLATMR routine in order to build random test matrices. No error */
+/* checking on parameters is done, because this routine is called in */
+/* a tight loop by SLATMR which has already checked the parameters. */
+
+/* Use of SLATM3 differs from SLATM2 in the order in which the random */
+/* number generator is called to fill in random matrix entries. */
+/* With SLATM2, the generator is called to fill in the pivoted matrix */
+/* columnwise. With SLATM3, the generator is called to fill in the */
+/* matrix columnwise, after which it is pivoted. Thus, SLATM3 can */
+/* be used to construct random matrices which differ only in their */
+/* order of rows and/or columns. SLATM2 is used to construct band */
+/* matrices while avoiding calling the random number generator for */
+/* entries outside the band (and therefore generating random numbers */
+/* in different orders for different pivot orders). */
+
+/* The matrix whose (ISUB,JSUB) entry is returned is constructed as */
+/* follows (this routine only computes one entry): */
+
+/* If ISUB is outside (1..M) or JSUB is outside (1..N), return zero */
+/* (this is convenient for generating matrices in band format). */
+
+/* Generate a matrix A with random entries of distribution IDIST. */
+
+/* Set the diagonal to D. */
+
+/* Grade the matrix, if desired, from the left (by DL) and/or */
+/* from the right (by DR or DL) as specified by IGRADE. */
+
+/* Permute, if desired, the rows and/or columns as specified by */
+/* IPVTNG and IWORK. */
+
+/* Band the matrix to have lower bandwidth KL and upper */
+/* bandwidth KU. */
+
+/* Set random entries to zero as specified by SPARSE. */
+
+/* Arguments */
+/* ========= */
+
+/* M - INTEGER */
+/* Number of rows of matrix. Not modified. */
+
+/* N - INTEGER */
+/* Number of columns of matrix. Not modified. */
+
+/* I - INTEGER */
+/* Row of unpivoted entry to be returned. Not modified. */
+
+/* J - INTEGER */
+/* Column of unpivoted entry to be returned. Not modified. */
+
+/* ISUB - INTEGER */
+/* Row of pivoted entry to be returned. Changed on exit. */
+
+/* JSUB - INTEGER */
+/* Column of pivoted entry to be returned. Changed on exit. */
+
+/* KL - INTEGER */
+/* Lower bandwidth. Not modified. */
+
+/* KU - INTEGER */
+/* Upper bandwidth. Not modified. */
+
+/* IDIST - INTEGER */
+/* On entry, IDIST specifies the type of distribution to be */
+/* used to generate a random matrix . */
+/* 1 => UNIFORM( 0, 1 ) */
+/* 2 => UNIFORM( -1, 1 ) */
+/* 3 => NORMAL( 0, 1 ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array of dimension ( 4 ) */
+/* Seed for random number generator. */
+/* Changed on exit. */
+
+/* D - REAL array of dimension ( MIN( I , J ) ) */
+/* Diagonal entries of matrix. Not modified. */
+
+/* IGRADE - INTEGER */
+/* Specifies grading of matrix as follows: */
+/* 0 => no grading */
+/* 1 => matrix premultiplied by diag( DL ) */
+/* 2 => matrix postmultiplied by diag( DR ) */
+/* 3 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DR ) */
+/* 4 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by inv( diag( DL ) ) */
+/* 5 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DL ) */
+/* Not modified. */
+
+/* DL - REAL array ( I or J, as appropriate ) */
+/* Left scale factors for grading matrix. Not modified. */
+
+/* DR - REAL array ( I or J, as appropriate ) */
+/* Right scale factors for grading matrix. Not modified. */
+
+/* IPVTNG - INTEGER */
+/* On entry specifies pivoting permutations as follows: */
+/* 0 => none. */
+/* 1 => row pivoting. */
+/* 2 => column pivoting. */
+/* 3 => full pivoting, i.e., on both sides. */
+/* Not modified. */
+
+/* IWORK - INTEGER array ( I or J, as appropriate ) */
+/* This array specifies the permutation used. The */
+/* row (or column) originally in position K is in */
+/* position IWORK( K ) after pivoting. */
+/* This differs from IWORK for SLATM2. Not modified. */
+
+/* SPARSE - REAL between 0. and 1. */
+/* On entry specifies the sparsity of the matrix */
+/* if sparse matix is to be generated. */
+/* SPARSE should lie between 0 and 1. */
+/* A uniform ( 0, 1 ) random number x is generated and */
+/* compared to SPARSE; if x is larger the matrix entry */
+/* is unchanged and if x is smaller the entry is set */
+/* to zero. Thus on the average a fraction SPARSE of the */
+/* entries will be set to zero. */
+/* Not modified. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+
+/* .. */
+
+/* .. Local Scalars .. */
+
+/* .. */
+
+/* .. External Functions .. */
+
+/* .. */
+
+/* ----------------------------------------------------------------------- */
+
+/* .. Executable Statements .. */
+
+
+/* Check for I and J in range */
+
+ /* Parameter adjustments */
+ --iwork;
+ --dr;
+ --dl;
+ --d__;
+ --iseed;
+
+ /* Function Body */
+ if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) {
+ *isub = *i__;
+ *jsub = *j;
+ ret_val = 0.f;
+ return ret_val;
+ }
+
+/* Compute subscripts depending on IPVTNG */
+
+ if (*ipvtng == 0) {
+ *isub = *i__;
+ *jsub = *j;
+ } else if (*ipvtng == 1) {
+ *isub = iwork[*i__];
+ *jsub = *j;
+ } else if (*ipvtng == 2) {
+ *isub = *i__;
+ *jsub = iwork[*j];
+ } else if (*ipvtng == 3) {
+ *isub = iwork[*i__];
+ *jsub = iwork[*j];
+ }
+
+/* Check for banding */
+
+ if (*jsub > *isub + *ku || *jsub < *isub - *kl) {
+ ret_val = 0.f;
+ return ret_val;
+ }
+
+/* Check for sparsity */
+
+ if (*sparse > 0.f) {
+ if (slaran_(&iseed[1]) < *sparse) {
+ ret_val = 0.f;
+ return ret_val;
+ }
+ }
+
+/* Compute entry and grade it according to IGRADE */
+
+ if (*i__ == *j) {
+ temp = d__[*i__];
+ } else {
+ temp = slarnd_(idist, &iseed[1]);
+ }
+ if (*igrade == 1) {
+ temp *= dl[*i__];
+ } else if (*igrade == 2) {
+ temp *= dr[*j];
+ } else if (*igrade == 3) {
+ temp = temp * dl[*i__] * dr[*j];
+ } else if (*igrade == 4 && *i__ != *j) {
+ temp = temp * dl[*i__] / dl[*j];
+ } else if (*igrade == 5) {
+ temp = temp * dl[*i__] * dl[*j];
+ }
+ ret_val = temp;
+ return ret_val;
+
+/* End of SLATM3 */
+
+} /* slatm3_ */
diff --git a/TESTING/MATGEN/slatm5.c b/TESTING/MATGEN/slatm5.c
new file mode 100644
index 0000000..1f4adfc
--- /dev/null
+++ b/TESTING/MATGEN/slatm5.c
@@ -0,0 +1,507 @@
+/* slatm5.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static real c_b29 = 1.f;
+static real c_b30 = 0.f;
+static real c_b33 = -1.f;
+
+/* Subroutine */ int slatm5_(integer *prtype, integer *m, integer *n, real *a,
+ integer *lda, real *b, integer *ldb, real *c__, integer *ldc, real *
+ d__, integer *ldd, real *e, integer *lde, real *f, integer *ldf, real
+ *r__, integer *ldr, real *l, integer *ldl, real *alpha, integer *
+ qblcka, integer *qblckb)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
+ d_offset, e_dim1, e_offset, f_dim1, f_offset, l_dim1, l_offset,
+ r_dim1, r_offset, i__1, i__2;
+
+ /* Builtin functions */
+ double sin(doublereal);
+
+ /* Local variables */
+ integer i__, j, k;
+ extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
+ integer *, real *, real *, integer *, real *, integer *, real *,
+ real *, integer *);
+ real imeps, reeps;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLATM5 generates matrices involved in the Generalized Sylvester */
+/* equation: */
+
+/* A * R - L * B = C */
+/* D * R - L * E = F */
+
+/* They also satisfy (the diagonalization condition) */
+
+/* [ I -L ] ( [ A -C ], [ D -F ] ) [ I R ] = ( [ A ], [ D ] ) */
+/* [ I ] ( [ B ] [ E ] ) [ I ] ( [ B ] [ E ] ) */
+
+
+/* Arguments */
+/* ========= */
+
+/* PRTYPE (input) INTEGER */
+/* "Points" to a certian type of the matrices to generate */
+/* (see futher details). */
+
+/* M (input) INTEGER */
+/* Specifies the order of A and D and the number of rows in */
+/* C, F, R and L. */
+
+/* N (input) INTEGER */
+/* Specifies the order of B and E and the number of columns in */
+/* C, F, R and L. */
+
+/* A (output) REAL array, dimension (LDA, M). */
+/* On exit A M-by-M is initialized according to PRTYPE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. */
+
+/* B (output) REAL array, dimension (LDB, N). */
+/* On exit B N-by-N is initialized according to PRTYPE. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. */
+
+/* C (output) REAL array, dimension (LDC, N). */
+/* On exit C M-by-N is initialized according to PRTYPE. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of C. */
+
+/* D (output) REAL array, dimension (LDD, M). */
+/* On exit D M-by-M is initialized according to PRTYPE. */
+
+/* LDD (input) INTEGER */
+/* The leading dimension of D. */
+
+/* E (output) REAL array, dimension (LDE, N). */
+/* On exit E N-by-N is initialized according to PRTYPE. */
+
+/* LDE (input) INTEGER */
+/* The leading dimension of E. */
+
+/* F (output) REAL array, dimension (LDF, N). */
+/* On exit F M-by-N is initialized according to PRTYPE. */
+
+/* LDF (input) INTEGER */
+/* The leading dimension of F. */
+
+/* R (output) REAL array, dimension (LDR, N). */
+/* On exit R M-by-N is initialized according to PRTYPE. */
+
+/* LDR (input) INTEGER */
+/* The leading dimension of R. */
+
+/* L (output) REAL array, dimension (LDL, N). */
+/* On exit L M-by-N is initialized according to PRTYPE. */
+
+/* LDL (input) INTEGER */
+/* The leading dimension of L. */
+
+/* ALPHA (input) REAL */
+/* Parameter used in generating PRTYPE = 1 and 5 matrices. */
+
+/* QBLCKA (input) INTEGER */
+/* When PRTYPE = 3, specifies the distance between 2-by-2 */
+/* blocks on the diagonal in A. Otherwise, QBLCKA is not */
+/* referenced. QBLCKA > 1. */
+
+/* QBLCKB (input) INTEGER */
+/* When PRTYPE = 3, specifies the distance between 2-by-2 */
+/* blocks on the diagonal in B. Otherwise, QBLCKB is not */
+/* referenced. QBLCKB > 1. */
+
+
+/* Further Details */
+/* =============== */
+
+/* PRTYPE = 1: A and B are Jordan blocks, D and E are identity matrices */
+
+/* A : if (i == j) then A(i, j) = 1.0 */
+/* if (j == i + 1) then A(i, j) = -1.0 */
+/* else A(i, j) = 0.0, i, j = 1...M */
+
+/* B : if (i == j) then B(i, j) = 1.0 - ALPHA */
+/* if (j == i + 1) then B(i, j) = 1.0 */
+/* else B(i, j) = 0.0, i, j = 1...N */
+
+/* D : if (i == j) then D(i, j) = 1.0 */
+/* else D(i, j) = 0.0, i, j = 1...M */
+
+/* E : if (i == j) then E(i, j) = 1.0 */
+/* else E(i, j) = 0.0, i, j = 1...N */
+
+/* L = R are chosen from [-10...10], */
+/* which specifies the right hand sides (C, F). */
+
+/* PRTYPE = 2 or 3: Triangular and/or quasi- triangular. */
+
+/* A : if (i <= j) then A(i, j) = [-1...1] */
+/* else A(i, j) = 0.0, i, j = 1...M */
+
+/* if (PRTYPE = 3) then */
+/* A(k + 1, k + 1) = A(k, k) */
+/* A(k + 1, k) = [-1...1] */
+/* sign(A(k, k + 1) = -(sin(A(k + 1, k)) */
+/* k = 1, M - 1, QBLCKA */
+
+/* B : if (i <= j) then B(i, j) = [-1...1] */
+/* else B(i, j) = 0.0, i, j = 1...N */
+
+/* if (PRTYPE = 3) then */
+/* B(k + 1, k + 1) = B(k, k) */
+/* B(k + 1, k) = [-1...1] */
+/* sign(B(k, k + 1) = -(sign(B(k + 1, k)) */
+/* k = 1, N - 1, QBLCKB */
+
+/* D : if (i <= j) then D(i, j) = [-1...1]. */
+/* else D(i, j) = 0.0, i, j = 1...M */
+
+
+/* E : if (i <= j) then D(i, j) = [-1...1] */
+/* else E(i, j) = 0.0, i, j = 1...N */
+
+/* L, R are chosen from [-10...10], */
+/* which specifies the right hand sides (C, F). */
+
+/* PRTYPE = 4 Full */
+/* A(i, j) = [-10...10] */
+/* D(i, j) = [-1...1] i,j = 1...M */
+/* B(i, j) = [-10...10] */
+/* E(i, j) = [-1...1] i,j = 1...N */
+/* R(i, j) = [-10...10] */
+/* L(i, j) = [-1...1] i = 1..M ,j = 1...N */
+
+/* L, R specifies the right hand sides (C, F). */
+
+/* PRTYPE = 5 special case common and/or close eigs. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ d_dim1 = *ldd;
+ d_offset = 1 + d_dim1;
+ d__ -= d_offset;
+ e_dim1 = *lde;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ f_dim1 = *ldf;
+ f_offset = 1 + f_dim1;
+ f -= f_offset;
+ r_dim1 = *ldr;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ l_dim1 = *ldl;
+ l_offset = 1 + l_dim1;
+ l -= l_offset;
+
+ /* Function Body */
+ if (*prtype == 1) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *m;
+ for (j = 1; j <= i__2; ++j) {
+ if (i__ == j) {
+ a[i__ + j * a_dim1] = 1.f;
+ d__[i__ + j * d_dim1] = 1.f;
+ } else if (i__ == j - 1) {
+ a[i__ + j * a_dim1] = -1.f;
+ d__[i__ + j * d_dim1] = 0.f;
+ } else {
+ a[i__ + j * a_dim1] = 0.f;
+ d__[i__ + j * d_dim1] = 0.f;
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (i__ == j) {
+ b[i__ + j * b_dim1] = 1.f - *alpha;
+ e[i__ + j * e_dim1] = 1.f;
+ } else if (i__ == j - 1) {
+ b[i__ + j * b_dim1] = 1.f;
+ e[i__ + j * e_dim1] = 0.f;
+ } else {
+ b[i__ + j * b_dim1] = 0.f;
+ e[i__ + j * e_dim1] = 0.f;
+ }
+/* L30: */
+ }
+/* L40: */
+ }
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ r__[i__ + j * r_dim1] = (.5f - sin((real) (i__ / j))) * 20.f;
+ l[i__ + j * l_dim1] = r__[i__ + j * r_dim1];
+/* L50: */
+ }
+/* L60: */
+ }
+
+ } else if (*prtype == 2 || *prtype == 3) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *m;
+ for (j = 1; j <= i__2; ++j) {
+ if (i__ <= j) {
+ a[i__ + j * a_dim1] = (.5f - sin((real) i__)) * 2.f;
+ d__[i__ + j * d_dim1] = (.5f - sin((real) (i__ * j))) *
+ 2.f;
+ } else {
+ a[i__ + j * a_dim1] = 0.f;
+ d__[i__ + j * d_dim1] = 0.f;
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (i__ <= j) {
+ b[i__ + j * b_dim1] = (.5f - sin((real) (i__ + j))) * 2.f;
+ e[i__ + j * e_dim1] = (.5f - sin((real) j)) * 2.f;
+ } else {
+ b[i__ + j * b_dim1] = 0.f;
+ e[i__ + j * e_dim1] = 0.f;
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ r__[i__ + j * r_dim1] = (.5f - sin((real) (i__ * j))) * 20.f;
+ l[i__ + j * l_dim1] = (.5f - sin((real) (i__ + j))) * 20.f;
+/* L110: */
+ }
+/* L120: */
+ }
+
+ if (*prtype == 3) {
+ if (*qblcka <= 1) {
+ *qblcka = 2;
+ }
+ i__1 = *m - 1;
+ i__2 = *qblcka;
+ for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+ a[k + 1 + (k + 1) * a_dim1] = a[k + k * a_dim1];
+ a[k + 1 + k * a_dim1] = -sin(a[k + (k + 1) * a_dim1]);
+/* L130: */
+ }
+
+ if (*qblckb <= 1) {
+ *qblckb = 2;
+ }
+ i__2 = *n - 1;
+ i__1 = *qblckb;
+ for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+ b[k + 1 + (k + 1) * b_dim1] = b[k + k * b_dim1];
+ b[k + 1 + k * b_dim1] = -sin(b[k + (k + 1) * b_dim1]);
+/* L140: */
+ }
+ }
+
+ } else if (*prtype == 4) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *m;
+ for (j = 1; j <= i__2; ++j) {
+ a[i__ + j * a_dim1] = (.5f - sin((real) (i__ * j))) * 20.f;
+ d__[i__ + j * d_dim1] = (.5f - sin((real) (i__ + j))) * 2.f;
+/* L150: */
+ }
+/* L160: */
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ b[i__ + j * b_dim1] = (.5f - sin((real) (i__ + j))) * 20.f;
+ e[i__ + j * e_dim1] = (.5f - sin((real) (i__ * j))) * 2.f;
+/* L170: */
+ }
+/* L180: */
+ }
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ r__[i__ + j * r_dim1] = (.5f - sin((real) (j / i__))) * 20.f;
+ l[i__ + j * l_dim1] = (.5f - sin((real) (i__ * j))) * 2.f;
+/* L190: */
+ }
+/* L200: */
+ }
+
+ } else if (*prtype >= 5) {
+ reeps = 20.f / *alpha;
+ imeps = -1.5f / *alpha;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ r__[i__ + j * r_dim1] = (.5f - sin((real) (i__ * j))) * *
+ alpha / 20.f;
+ l[i__ + j * l_dim1] = (.5f - sin((real) (i__ + j))) * *alpha /
+ 20.f;
+/* L210: */
+ }
+/* L220: */
+ }
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__ + i__ * d_dim1] = 1.f;
+/* L230: */
+ }
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (i__ <= 4) {
+ a[i__ + i__ * a_dim1] = 1.f;
+ if (i__ > 2) {
+ a[i__ + i__ * a_dim1] = reeps + 1.f;
+ }
+ if (i__ % 2 != 0 && i__ < *m) {
+ a[i__ + (i__ + 1) * a_dim1] = imeps;
+ } else if (i__ > 1) {
+ a[i__ + (i__ - 1) * a_dim1] = -imeps;
+ }
+ } else if (i__ <= 8) {
+ if (i__ <= 6) {
+ a[i__ + i__ * a_dim1] = reeps;
+ } else {
+ a[i__ + i__ * a_dim1] = -reeps;
+ }
+ if (i__ % 2 != 0 && i__ < *m) {
+ a[i__ + (i__ + 1) * a_dim1] = 1.f;
+ } else if (i__ > 1) {
+ a[i__ + (i__ - 1) * a_dim1] = -1.f;
+ }
+ } else {
+ a[i__ + i__ * a_dim1] = 1.f;
+ if (i__ % 2 != 0 && i__ < *m) {
+ a[i__ + (i__ + 1) * a_dim1] = imeps * 2;
+ } else if (i__ > 1) {
+ a[i__ + (i__ - 1) * a_dim1] = -imeps * 2;
+ }
+ }
+/* L240: */
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ e[i__ + i__ * e_dim1] = 1.f;
+ if (i__ <= 4) {
+ b[i__ + i__ * b_dim1] = -1.f;
+ if (i__ > 2) {
+ b[i__ + i__ * b_dim1] = 1.f - reeps;
+ }
+ if (i__ % 2 != 0 && i__ < *n) {
+ b[i__ + (i__ + 1) * b_dim1] = imeps;
+ } else if (i__ > 1) {
+ b[i__ + (i__ - 1) * b_dim1] = -imeps;
+ }
+ } else if (i__ <= 8) {
+ if (i__ <= 6) {
+ b[i__ + i__ * b_dim1] = reeps;
+ } else {
+ b[i__ + i__ * b_dim1] = -reeps;
+ }
+ if (i__ % 2 != 0 && i__ < *n) {
+ b[i__ + (i__ + 1) * b_dim1] = imeps + 1.f;
+ } else if (i__ > 1) {
+ b[i__ + (i__ - 1) * b_dim1] = -1.f - imeps;
+ }
+ } else {
+ b[i__ + i__ * b_dim1] = 1.f - reeps;
+ if (i__ % 2 != 0 && i__ < *n) {
+ b[i__ + (i__ + 1) * b_dim1] = imeps * 2;
+ } else if (i__ > 1) {
+ b[i__ + (i__ - 1) * b_dim1] = -imeps * 2;
+ }
+ }
+/* L250: */
+ }
+ }
+
+/* Compute rhs (C, F) */
+
+ sgemm_("N", "N", m, n, m, &c_b29, &a[a_offset], lda, &r__[r_offset], ldr,
+ &c_b30, &c__[c_offset], ldc);
+ sgemm_("N", "N", m, n, n, &c_b33, &l[l_offset], ldl, &b[b_offset], ldb, &
+ c_b29, &c__[c_offset], ldc);
+ sgemm_("N", "N", m, n, m, &c_b29, &d__[d_offset], ldd, &r__[r_offset],
+ ldr, &c_b30, &f[f_offset], ldf);
+ sgemm_("N", "N", m, n, n, &c_b33, &l[l_offset], ldl, &e[e_offset], lde, &
+ c_b29, &f[f_offset], ldf);
+
+/* End of SLATM5 */
+
+ return 0;
+} /* slatm5_ */
diff --git a/TESTING/MATGEN/slatm6.c b/TESTING/MATGEN/slatm6.c
new file mode 100644
index 0000000..9ee26fc
--- /dev/null
+++ b/TESTING/MATGEN/slatm6.c
@@ -0,0 +1,309 @@
+/* slatm6.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c__12 = 12;
+static integer c__8 = 8;
+static integer c__40 = 40;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__60 = 60;
+
+/* Subroutine */ int slatm6_(integer *type__, integer *n, real *a, integer *
+ lda, real *b, real *x, integer *ldx, real *y, integer *ldy, real *
+ alpha, real *beta, real *wx, real *wy, real *s, real *dif)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, y_dim1,
+ y_offset, i__1, i__2;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ real z__[144] /* was [12][12] */;
+ integer info;
+ real work[100];
+ extern /* Subroutine */ int slakf2_(integer *, integer *, real *, integer
+ *, real *, real *, real *, real *, integer *), sgesvd_(char *,
+ char *, integer *, integer *, real *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *,
+ integer *, real *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLATM6 generates test matrices for the generalized eigenvalue */
+/* problem, their corresponding right and left eigenvector matrices, */
+/* and also reciprocal condition numbers for all eigenvalues and */
+/* the reciprocal condition numbers of eigenvectors corresponding to */
+/* the 1th and 5th eigenvalues. */
+
+/* Test Matrices */
+/* ============= */
+
+/* Two kinds of test matrix pairs */
+
+/* (A, B) = inverse(YH) * (Da, Db) * inverse(X) */
+
+/* are used in the tests: */
+
+/* Type 1: */
+/* Da = 1+a 0 0 0 0 Db = 1 0 0 0 0 */
+/* 0 2+a 0 0 0 0 1 0 0 0 */
+/* 0 0 3+a 0 0 0 0 1 0 0 */
+/* 0 0 0 4+a 0 0 0 0 1 0 */
+/* 0 0 0 0 5+a , 0 0 0 0 1 , and */
+
+/* Type 2: */
+/* Da = 1 -1 0 0 0 Db = 1 0 0 0 0 */
+/* 1 1 0 0 0 0 1 0 0 0 */
+/* 0 0 1 0 0 0 0 1 0 0 */
+/* 0 0 0 1+a 1+b 0 0 0 1 0 */
+/* 0 0 0 -1-b 1+a , 0 0 0 0 1 . */
+
+/* In both cases the same inverse(YH) and inverse(X) are used to compute */
+/* (A, B), giving the exact eigenvectors to (A,B) as (YH, X): */
+
+/* YH: = 1 0 -y y -y X = 1 0 -x -x x */
+/* 0 1 -y y -y 0 1 x -x -x */
+/* 0 0 1 0 0 0 0 1 0 0 */
+/* 0 0 0 1 0 0 0 0 1 0 */
+/* 0 0 0 0 1, 0 0 0 0 1 , */
+
+/* where a, b, x and y will have all values independently of each other. */
+
+/* Arguments */
+/* ========= */
+
+/* TYPE (input) INTEGER */
+/* Specifies the problem type (see futher details). */
+
+/* N (input) INTEGER */
+/* Size of the matrices A and B. */
+
+/* A (output) REAL array, dimension (LDA, N). */
+/* On exit A N-by-N is initialized according to TYPE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A and of B. */
+
+/* B (output) REAL array, dimension (LDA, N). */
+/* On exit B N-by-N is initialized according to TYPE. */
+
+/* X (output) REAL array, dimension (LDX, N). */
+/* On exit X is the N-by-N matrix of right eigenvectors. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of X. */
+
+/* Y (output) REAL array, dimension (LDY, N). */
+/* On exit Y is the N-by-N matrix of left eigenvectors. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of Y. */
+
+/* ALPHA (input) REAL */
+/* BETA (input) REAL */
+/* Weighting constants for matrix A. */
+
+/* WX (input) REAL */
+/* Constant for right eigenvector matrix. */
+
+/* WY (input) REAL */
+/* Constant for left eigenvector matrix. */
+
+/* S (output) REAL array, dimension (N) */
+/* S(i) is the reciprocal condition number for eigenvalue i. */
+
+/* DIF (output) REAL array, dimension (N) */
+/* DIF(i) is the reciprocal condition number for eigenvector i. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Generate test problem ... */
+/* (Da, Db) ... */
+
+ /* Parameter adjustments */
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ --s;
+ --dif;
+
+ /* Function Body */
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+
+ if (i__ == j) {
+ a[i__ + i__ * a_dim1] = (real) i__ + *alpha;
+ b[i__ + i__ * b_dim1] = 1.f;
+ } else {
+ a[i__ + j * a_dim1] = 0.f;
+ b[i__ + j * b_dim1] = 0.f;
+ }
+
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* Form X and Y */
+
+ slacpy_("F", n, n, &b[b_offset], lda, &y[y_offset], ldy);
+ y[y_dim1 + 3] = -(*wy);
+ y[y_dim1 + 4] = *wy;
+ y[y_dim1 + 5] = -(*wy);
+ y[(y_dim1 << 1) + 3] = -(*wy);
+ y[(y_dim1 << 1) + 4] = *wy;
+ y[(y_dim1 << 1) + 5] = -(*wy);
+
+ slacpy_("F", n, n, &b[b_offset], lda, &x[x_offset], ldx);
+ x[x_dim1 * 3 + 1] = -(*wx);
+ x[(x_dim1 << 2) + 1] = -(*wx);
+ x[x_dim1 * 5 + 1] = *wx;
+ x[x_dim1 * 3 + 2] = *wx;
+ x[(x_dim1 << 2) + 2] = -(*wx);
+ x[x_dim1 * 5 + 2] = -(*wx);
+
+/* Form (A, B) */
+
+ b[b_dim1 * 3 + 1] = *wx + *wy;
+ b[b_dim1 * 3 + 2] = -(*wx) + *wy;
+ b[(b_dim1 << 2) + 1] = *wx - *wy;
+ b[(b_dim1 << 2) + 2] = *wx - *wy;
+ b[b_dim1 * 5 + 1] = -(*wx) + *wy;
+ b[b_dim1 * 5 + 2] = *wx + *wy;
+ if (*type__ == 1) {
+ a[a_dim1 * 3 + 1] = *wx * a[a_dim1 + 1] + *wy * a[a_dim1 * 3 + 3];
+ a[a_dim1 * 3 + 2] = -(*wx) * a[(a_dim1 << 1) + 2] + *wy * a[a_dim1 *
+ 3 + 3];
+ a[(a_dim1 << 2) + 1] = *wx * a[a_dim1 + 1] - *wy * a[(a_dim1 << 2) +
+ 4];
+ a[(a_dim1 << 2) + 2] = *wx * a[(a_dim1 << 1) + 2] - *wy * a[(a_dim1 <<
+ 2) + 4];
+ a[a_dim1 * 5 + 1] = -(*wx) * a[a_dim1 + 1] + *wy * a[a_dim1 * 5 + 5];
+ a[a_dim1 * 5 + 2] = *wx * a[(a_dim1 << 1) + 2] + *wy * a[a_dim1 * 5 +
+ 5];
+ } else if (*type__ == 2) {
+ a[a_dim1 * 3 + 1] = *wx * 2.f + *wy;
+ a[a_dim1 * 3 + 2] = *wy;
+ a[(a_dim1 << 2) + 1] = -(*wy) * (*alpha + 2.f + *beta);
+ a[(a_dim1 << 2) + 2] = *wx * 2.f - *wy * (*alpha + 2.f + *beta);
+ a[a_dim1 * 5 + 1] = *wx * -2.f + *wy * (*alpha - *beta);
+ a[a_dim1 * 5 + 2] = *wy * (*alpha - *beta);
+ a[a_dim1 + 1] = 1.f;
+ a[(a_dim1 << 1) + 1] = -1.f;
+ a[a_dim1 + 2] = 1.f;
+ a[(a_dim1 << 1) + 2] = a[a_dim1 + 1];
+ a[a_dim1 * 3 + 3] = 1.f;
+ a[(a_dim1 << 2) + 4] = *alpha + 1.f;
+ a[a_dim1 * 5 + 4] = *beta + 1.f;
+ a[(a_dim1 << 2) + 5] = -a[a_dim1 * 5 + 4];
+ a[a_dim1 * 5 + 5] = a[(a_dim1 << 2) + 4];
+ }
+
+/* Compute condition numbers */
+
+ if (*type__ == 1) {
+
+ s[1] = 1.f / sqrt((*wy * 3.f * *wy + 1.f) / (a[a_dim1 + 1] * a[a_dim1
+ + 1] + 1.f));
+ s[2] = 1.f / sqrt((*wy * 3.f * *wy + 1.f) / (a[(a_dim1 << 1) + 2] * a[
+ (a_dim1 << 1) + 2] + 1.f));
+ s[3] = 1.f / sqrt((*wx * 2.f * *wx + 1.f) / (a[a_dim1 * 3 + 3] * a[
+ a_dim1 * 3 + 3] + 1.f));
+ s[4] = 1.f / sqrt((*wx * 2.f * *wx + 1.f) / (a[(a_dim1 << 2) + 4] * a[
+ (a_dim1 << 2) + 4] + 1.f));
+ s[5] = 1.f / sqrt((*wx * 2.f * *wx + 1.f) / (a[a_dim1 * 5 + 5] * a[
+ a_dim1 * 5 + 5] + 1.f));
+
+ slakf2_(&c__1, &c__4, &a[a_offset], lda, &a[(a_dim1 << 1) + 2], &b[
+ b_offset], &b[(b_dim1 << 1) + 2], z__, &c__12);
+ sgesvd_("N", "N", &c__8, &c__8, z__, &c__12, work, &work[8], &c__1, &
+ work[9], &c__1, &work[10], &c__40, &info);
+ dif[1] = work[7];
+
+ slakf2_(&c__4, &c__1, &a[a_offset], lda, &a[a_dim1 * 5 + 5], &b[
+ b_offset], &b[b_dim1 * 5 + 5], z__, &c__12);
+ sgesvd_("N", "N", &c__8, &c__8, z__, &c__12, work, &work[8], &c__1, &
+ work[9], &c__1, &work[10], &c__40, &info);
+ dif[5] = work[7];
+
+ } else if (*type__ == 2) {
+
+ s[1] = 1.f / sqrt(*wy * *wy + .33333333333333331f);
+ s[2] = s[1];
+ s[3] = 1.f / sqrt(*wx * *wx + .5f);
+ s[4] = 1.f / sqrt((*wx * 2.f * *wx + 1.f) / ((*alpha + 1.f) * (*alpha
+ + 1.f) + 1.f + (*beta + 1.f) * (*beta + 1.f)));
+ s[5] = s[4];
+
+ slakf2_(&c__2, &c__3, &a[a_offset], lda, &a[a_dim1 * 3 + 3], &b[
+ b_offset], &b[b_dim1 * 3 + 3], z__, &c__12);
+ sgesvd_("N", "N", &c__12, &c__12, z__, &c__12, work, &work[12], &c__1,
+ &work[13], &c__1, &work[14], &c__60, &info);
+ dif[1] = work[11];
+
+ slakf2_(&c__3, &c__2, &a[a_offset], lda, &a[(a_dim1 << 2) + 4], &b[
+ b_offset], &b[(b_dim1 << 2) + 4], z__, &c__12);
+ sgesvd_("N", "N", &c__12, &c__12, z__, &c__12, work, &work[12], &c__1,
+ &work[13], &c__1, &work[14], &c__60, &info);
+ dif[5] = work[11];
+
+ }
+
+ return 0;
+
+/* End of SLATM6 */
+
+} /* slatm6_ */
diff --git a/TESTING/MATGEN/slatm7.c b/TESTING/MATGEN/slatm7.c
new file mode 100644
index 0000000..db503a6
--- /dev/null
+++ b/TESTING/MATGEN/slatm7.c
@@ -0,0 +1,307 @@
+/* slatm7.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int slatm7_(integer *mode, real *cond, integer *irsign,
+ integer *idist, integer *iseed, real *d__, integer *n, integer *rank,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublereal d__1, d__2;
+
+ /* Builtin functions */
+ double pow_dd(doublereal *, doublereal *), pow_ri(real *, integer *), log(
+ doublereal), exp(doublereal);
+
+ /* Local variables */
+ integer i__;
+ real temp, alpha;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal slaran_(integer *);
+ extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
+ *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLATM7 computes the entries of D as specified by MODE */
+/* COND and IRSIGN. IDIST and ISEED determine the generation */
+/* of random numbers. SLATM7 is called by SLATMT to generate */
+/* random test matrices. */
+
+/* Arguments */
+/* ========= */
+
+/* MODE - INTEGER */
+/* On entry describes how D is to be computed: */
+/* MODE = 0 means do not change D. */
+
+/* MODE = 1 sets D(1)=1 and D(2:RANK)=1.0/COND */
+/* MODE = 2 sets D(1:RANK-1)=1 and D(RANK)=1.0/COND */
+/* MODE = 3 sets D(I)=COND**(-(I-1)/(RANK-1)) I=1:RANK */
+
+/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* MODE = 5 sets D to random numbers in the range */
+/* ( 1/COND , 1 ) such that their logarithms */
+/* are uniformly distributed. */
+/* MODE = 6 set D to random numbers from same distribution */
+/* as the rest of the matrix. */
+/* MODE < 0 has the same meaning as ABS(MODE), except that */
+/* the order of the elements of D is reversed. */
+/* Thus if MODE is positive, D has entries ranging from */
+/* 1 to 1/COND, if negative, from 1/COND to 1, */
+/* Not modified. */
+
+/* COND - REAL */
+/* On entry, used as described under MODE above. */
+/* If used, it must be >= 1. Not modified. */
+
+/* IRSIGN - INTEGER */
+/* On entry, if MODE neither -6, 0 nor 6, determines sign of */
+/* entries of D */
+/* 0 => leave entries of D unchanged */
+/* 1 => multiply each entry of D by 1 or -1 with probability .5 */
+
+/* IDIST - CHARACTER*1 */
+/* On entry, IDIST specifies the type of distribution to be */
+/* used to generate a random matrix . */
+/* 1 => UNIFORM( 0, 1 ) */
+/* 2 => UNIFORM( -1, 1 ) */
+/* 3 => NORMAL( 0, 1 ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension ( 4 ) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The random number generator uses a */
+/* linear congruential sequence limited to small */
+/* integers, and so should produce machine independent */
+/* random numbers. The values of ISEED are changed on */
+/* exit, and can be used in the next call to SLATM7 */
+/* to continue the same random number sequence. */
+/* Changed on exit. */
+
+/* D - REAL array, dimension ( MIN( M , N ) ) */
+/* Array to be computed according to MODE, COND and IRSIGN. */
+/* May be changed on exit if MODE is nonzero. */
+
+/* N - INTEGER */
+/* Number of entries of D. Not modified. */
+
+/* RANK - INTEGER */
+/* The rank of matrix to be generated for modes 1,2,3 only. */
+/* D( RANK+1:N ) = 0. */
+/* Not modified. */
+
+/* INFO - INTEGER */
+/* 0 => normal termination */
+/* -1 => if MODE not in range -6 to 6 */
+/* -2 => if MODE neither -6, 0 nor 6, and */
+/* IRSIGN neither 0 nor 1 */
+/* -3 => if MODE neither -6, 0 nor 6 and COND less than 1 */
+/* -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 3 */
+/* -7 => if N negative */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and Test the input parameters. Initialize flags & seed. */
+
+ /* Parameter adjustments */
+ --d__;
+ --iseed;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Set INFO if an error */
+
+ if (*mode < -6 || *mode > 6) {
+ *info = -1;
+ } else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && *
+ irsign != 1)) {
+ *info = -2;
+ } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.f) {
+ *info = -3;
+ } else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 3)) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -7;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLATM7", &i__1);
+ return 0;
+ }
+
+/* Compute D according to COND and MODE */
+
+ if (*mode != 0) {
+ switch (abs(*mode)) {
+ case 1: goto L100;
+ case 2: goto L130;
+ case 3: goto L160;
+ case 4: goto L190;
+ case 5: goto L210;
+ case 6: goto L230;
+ }
+
+/* One large D value: */
+
+L100:
+ i__1 = *rank;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ d__[i__] = 1.f / *cond;
+/* L110: */
+ }
+ i__1 = *n;
+ for (i__ = *rank + 1; i__ <= i__1; ++i__) {
+ d__[i__] = 0.f;
+/* L120: */
+ }
+ d__[1] = 1.f;
+ goto L240;
+
+/* One small D value: */
+
+L130:
+ i__1 = *rank - 1;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = 1.f;
+/* L140: */
+ }
+ i__1 = *n;
+ for (i__ = *rank + 1; i__ <= i__1; ++i__) {
+ d__[i__] = 0.f;
+/* L150: */
+ }
+ d__[*rank] = 1.f / *cond;
+ goto L240;
+
+/* Exponentially distributed D values: */
+
+L160:
+ d__[1] = 1.f;
+ if (*n > 1) {
+ d__1 = (doublereal) (*cond);
+ d__2 = (doublereal) (-1.f / (real) (*rank - 1));
+ alpha = pow_dd(&d__1, &d__2);
+ i__1 = *rank;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__ - 1;
+ d__[i__] = pow_ri(&alpha, &i__2);
+/* L170: */
+ }
+ i__1 = *n;
+ for (i__ = *rank + 1; i__ <= i__1; ++i__) {
+ d__[i__] = 0.f;
+/* L180: */
+ }
+ }
+ goto L240;
+
+/* Arithmetically distributed D values: */
+
+L190:
+ d__[1] = 1.f;
+ if (*n > 1) {
+ temp = 1.f / *cond;
+ alpha = (1.f - temp) / (real) (*n - 1);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ d__[i__] = (real) (*n - i__) * alpha + temp;
+/* L200: */
+ }
+ }
+ goto L240;
+
+/* Randomly distributed D values on ( 1/COND , 1): */
+
+L210:
+ alpha = log(1.f / *cond);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = exp(alpha * slaran_(&iseed[1]));
+/* L220: */
+ }
+ goto L240;
+
+/* Randomly distributed D values from IDIST */
+
+L230:
+ slarnv_(idist, &iseed[1], n, &d__[1]);
+
+L240:
+
+/* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */
+/* random signs to D */
+
+ if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = slaran_(&iseed[1]);
+ if (temp > .5f) {
+ d__[i__] = -d__[i__];
+ }
+/* L250: */
+ }
+ }
+
+/* Reverse if MODE < 0 */
+
+ if (*mode < 0) {
+ i__1 = *n / 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ temp = d__[i__];
+ d__[i__] = d__[*n + 1 - i__];
+ d__[*n + 1 - i__] = temp;
+/* L260: */
+ }
+ }
+
+ }
+
+ return 0;
+
+/* End of SLATM7 */
+
+} /* slatm7_ */
diff --git a/TESTING/MATGEN/slatme.c b/TESTING/MATGEN/slatme.c
new file mode 100644
index 0000000..41e28af
--- /dev/null
+++ b/TESTING/MATGEN/slatme.c
@@ -0,0 +1,688 @@
+/* slatme.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b23 = 0.f;
+static integer c__0 = 0;
+static real c_b39 = 1.f;
+
+/* Subroutine */ int slatme_(integer *n, char *dist, integer *iseed, real *
+ d__, integer *mode, real *cond, real *dmax__, char *ei, char *rsign,
+ char *upper, char *sim, real *ds, integer *modes, real *conds,
+ integer *kl, integer *ku, real *anorm, real *a, integer *lda, real *
+ work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, ic, jc, ir, jr, jcr;
+ real tau;
+ logical bads;
+ extern /* Subroutine */ int sger_(integer *, integer *, real *, real *,
+ integer *, real *, integer *, real *, integer *);
+ integer isim;
+ real temp;
+ logical badei;
+ real alpha;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ real tempa[1];
+ integer icols;
+ logical useei;
+ integer idist;
+ extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
+ real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *);
+ integer irows;
+ extern /* Subroutine */ int slatm1_(integer *, real *, integer *, integer
+ *, integer *, real *, integer *, integer *);
+ extern doublereal slange_(char *, integer *, integer *, real *, integer *,
+ real *);
+ extern /* Subroutine */ int slarge_(integer *, real *, integer *, integer
+ *, real *, integer *), slarfg_(integer *, real *, real *, integer
+ *, real *), xerbla_(char *, integer *);
+ extern doublereal slaran_(integer *);
+ integer irsign;
+ extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
+ real *, real *, integer *);
+ integer iupper;
+ extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
+ *);
+ real xnorms;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLATME generates random non-symmetric square matrices with */
+/* specified eigenvalues for testing LAPACK programs. */
+
+/* SLATME operates by applying the following sequence of */
+/* operations: */
+
+/* 1. Set the diagonal to D, where D may be input or */
+/* computed according to MODE, COND, DMAX, and RSIGN */
+/* as described below. */
+
+/* 2. If complex conjugate pairs are desired (MODE=0 and EI(1)='R', */
+/* or MODE=5), certain pairs of adjacent elements of D are */
+/* interpreted as the real and complex parts of a complex */
+/* conjugate pair; A thus becomes block diagonal, with 1x1 */
+/* and 2x2 blocks. */
+
+/* 3. If UPPER='T', the upper triangle of A is set to random values */
+/* out of distribution DIST. */
+
+/* 4. If SIM='T', A is multiplied on the left by a random matrix */
+/* X, whose singular values are specified by DS, MODES, and */
+/* CONDS, and on the right by X inverse. */
+
+/* 5. If KL < N-1, the lower bandwidth is reduced to KL using */
+/* Householder transformations. If KU < N-1, the upper */
+/* bandwidth is reduced to KU. */
+
+/* 6. If ANORM is not negative, the matrix is scaled to have */
+/* maximum-element-norm ANORM. */
+
+/* (Note: since the matrix cannot be reduced beyond Hessenberg form, */
+/* no packing options are available.) */
+
+/* Arguments */
+/* ========= */
+
+/* N - INTEGER */
+/* The number of columns (or rows) of A. Not modified. */
+
+/* DIST - CHARACTER*1 */
+/* On entry, DIST specifies the type of distribution to be used */
+/* to generate the random eigen-/singular values, and for the */
+/* upper triangle (see UPPER). */
+/* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */
+/* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */
+/* 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension ( 4 ) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. They should lie between 0 and 4095 inclusive, */
+/* and ISEED(4) should be odd. The random number generator */
+/* uses a linear congruential sequence limited to small */
+/* integers, and so should produce machine independent */
+/* random numbers. The values of ISEED are changed on */
+/* exit, and can be used in the next call to SLATME */
+/* to continue the same random number sequence. */
+/* Changed on exit. */
+
+/* D - REAL array, dimension ( N ) */
+/* This array is used to specify the eigenvalues of A. If */
+/* MODE=0, then D is assumed to contain the eigenvalues (but */
+/* see the description of EI), otherwise they will be */
+/* computed according to MODE, COND, DMAX, and RSIGN and */
+/* placed in D. */
+/* Modified if MODE is nonzero. */
+
+/* MODE - INTEGER */
+/* On entry this describes how the eigenvalues are to */
+/* be specified: */
+/* MODE = 0 means use D (with EI) as input */
+/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
+/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
+/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
+/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* MODE = 5 sets D to random numbers in the range */
+/* ( 1/COND , 1 ) such that their logarithms */
+/* are uniformly distributed. Each odd-even pair */
+/* of elements will be either used as two real */
+/* eigenvalues or as the real and imaginary part */
+/* of a complex conjugate pair of eigenvalues; */
+/* the choice of which is done is random, with */
+/* 50-50 probability, for each pair. */
+/* MODE = 6 set D to random numbers from same distribution */
+/* as the rest of the matrix. */
+/* MODE < 0 has the same meaning as ABS(MODE), except that */
+/* the order of the elements of D is reversed. */
+/* Thus if MODE is between 1 and 4, D has entries ranging */
+/* from 1 to 1/COND, if between -1 and -4, D has entries */
+/* ranging from 1/COND to 1, */
+/* Not modified. */
+
+/* COND - REAL */
+/* On entry, this is used as described under MODE above. */
+/* If used, it must be >= 1. Not modified. */
+
+/* DMAX - REAL */
+/* If MODE is neither -6, 0 nor 6, the contents of D, as */
+/* computed according to MODE and COND, will be scaled by */
+/* DMAX / max(abs(D(i))). Note that DMAX need not be */
+/* positive: if DMAX is negative (or zero), D will be */
+/* scaled by a negative number (or zero). */
+/* Not modified. */
+
+/* EI - CHARACTER*1 array, dimension ( N ) */
+/* If MODE is 0, and EI(1) is not ' ' (space character), */
+/* this array specifies which elements of D (on input) are */
+/* real eigenvalues and which are the real and imaginary parts */
+/* of a complex conjugate pair of eigenvalues. The elements */
+/* of EI may then only have the values 'R' and 'I'. If */
+/* EI(j)='R' and EI(j+1)='I', then the j-th eigenvalue is */
+/* CMPLX( D(j) , D(j+1) ), and the (j+1)-th is the complex */
+/* conjugate thereof. If EI(j)=EI(j+1)='R', then the j-th */
+/* eigenvalue is D(j) (i.e., real). EI(1) may not be 'I', */
+/* nor may two adjacent elements of EI both have the value 'I'. */
+/* If MODE is not 0, then EI is ignored. If MODE is 0 and */
+/* EI(1)=' ', then the eigenvalues will all be real. */
+/* Not modified. */
+
+/* RSIGN - CHARACTER*1 */
+/* If MODE is not 0, 6, or -6, and RSIGN='T', then the */
+/* elements of D, as computed according to MODE and COND, will */
+/* be multiplied by a random sign (+1 or -1). If RSIGN='F', */
+/* they will not be. RSIGN may only have the values 'T' or */
+/* 'F'. */
+/* Not modified. */
+
+/* UPPER - CHARACTER*1 */
+/* If UPPER='T', then the elements of A above the diagonal */
+/* (and above the 2x2 diagonal blocks, if A has complex */
+/* eigenvalues) will be set to random numbers out of DIST. */
+/* If UPPER='F', they will not. UPPER may only have the */
+/* values 'T' or 'F'. */
+/* Not modified. */
+
+/* SIM - CHARACTER*1 */
+/* If SIM='T', then A will be operated on by a "similarity */
+/* transform", i.e., multiplied on the left by a matrix X and */
+/* on the right by X inverse. X = U S V, where U and V are */
+/* random unitary matrices and S is a (diagonal) matrix of */
+/* singular values specified by DS, MODES, and CONDS. If */
+/* SIM='F', then A will not be transformed. */
+/* Not modified. */
+
+/* DS - REAL array, dimension ( N ) */
+/* This array is used to specify the singular values of X, */
+/* in the same way that D specifies the eigenvalues of A. */
+/* If MODE=0, the DS contains the singular values, which */
+/* may not be zero. */
+/* Modified if MODE is nonzero. */
+
+/* MODES - INTEGER */
+/* CONDS - REAL */
+/* Same as MODE and COND, but for specifying the diagonal */
+/* of S. MODES=-6 and +6 are not allowed (since they would */
+/* result in randomly ill-conditioned eigenvalues.) */
+
+/* KL - INTEGER */
+/* This specifies the lower bandwidth of the matrix. KL=1 */
+/* specifies upper Hessenberg form. If KL is at least N-1, */
+/* then A will have full lower bandwidth. KL must be at */
+/* least 1. */
+/* Not modified. */
+
+/* KU - INTEGER */
+/* This specifies the upper bandwidth of the matrix. KU=1 */
+/* specifies lower Hessenberg form. If KU is at least N-1, */
+/* then A will have full upper bandwidth; if KU and KL */
+/* are both at least N-1, then A will be dense. Only one of */
+/* KU and KL may be less than N-1. KU must be at least 1. */
+/* Not modified. */
+
+/* ANORM - REAL */
+/* If ANORM is not negative, then A will be scaled by a non- */
+/* negative real number to make the maximum-element-norm of A */
+/* to be ANORM. */
+/* Not modified. */
+
+/* A - REAL array, dimension ( LDA, N ) */
+/* On exit A is the desired test matrix. */
+/* Modified. */
+
+/* LDA - INTEGER */
+/* LDA specifies the first dimension of A as declared in the */
+/* calling program. LDA must be at least N. */
+/* Not modified. */
+
+/* WORK - REAL array, dimension ( 3*N ) */
+/* Workspace. */
+/* Modified. */
+
+/* INFO - INTEGER */
+/* Error code. On exit, INFO will be set to one of the */
+/* following values: */
+/* 0 => normal return */
+/* -1 => N negative */
+/* -2 => DIST illegal string */
+/* -5 => MODE not in range -6 to 6 */
+/* -6 => COND less than 1.0, and MODE neither -6, 0 nor 6 */
+/* -8 => EI(1) is not ' ' or 'R', EI(j) is not 'R' or 'I', or */
+/* two adjacent elements of EI are 'I'. */
+/* -9 => RSIGN is not 'T' or 'F' */
+/* -10 => UPPER is not 'T' or 'F' */
+/* -11 => SIM is not 'T' or 'F' */
+/* -12 => MODES=0 and DS has a zero singular value. */
+/* -13 => MODES is not in the range -5 to 5. */
+/* -14 => MODES is nonzero and CONDS is less than 1. */
+/* -15 => KL is less than 1. */
+/* -16 => KU is less than 1, or KL and KU are both less than */
+/* N-1. */
+/* -19 => LDA is less than N. */
+/* 1 => Error return from SLATM1 (computing D) */
+/* 2 => Cannot scale to DMAX (max. eigenvalue is 0) */
+/* 3 => Error return from SLATM1 (computing DS) */
+/* 4 => Error return from SLARGE */
+/* 5 => Zero singular value from SLATM1. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Decode and Test the input parameters. */
+/* Initialize flags & seed. */
+
+ /* Parameter adjustments */
+ --iseed;
+ --d__;
+ --ei;
+ --ds;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Decode DIST */
+
+ if (lsame_(dist, "U")) {
+ idist = 1;
+ } else if (lsame_(dist, "S")) {
+ idist = 2;
+ } else if (lsame_(dist, "N")) {
+ idist = 3;
+ } else {
+ idist = -1;
+ }
+
+/* Check EI */
+
+ useei = TRUE_;
+ badei = FALSE_;
+ if (lsame_(ei + 1, " ") || *mode != 0) {
+ useei = FALSE_;
+ } else {
+ if (lsame_(ei + 1, "R")) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ if (lsame_(ei + j, "I")) {
+ if (lsame_(ei + (j - 1), "I")) {
+ badei = TRUE_;
+ }
+ } else {
+ if (! lsame_(ei + j, "R")) {
+ badei = TRUE_;
+ }
+ }
+/* L10: */
+ }
+ } else {
+ badei = TRUE_;
+ }
+ }
+
+/* Decode RSIGN */
+
+ if (lsame_(rsign, "T")) {
+ irsign = 1;
+ } else if (lsame_(rsign, "F")) {
+ irsign = 0;
+ } else {
+ irsign = -1;
+ }
+
+/* Decode UPPER */
+
+ if (lsame_(upper, "T")) {
+ iupper = 1;
+ } else if (lsame_(upper, "F")) {
+ iupper = 0;
+ } else {
+ iupper = -1;
+ }
+
+/* Decode SIM */
+
+ if (lsame_(sim, "T")) {
+ isim = 1;
+ } else if (lsame_(sim, "F")) {
+ isim = 0;
+ } else {
+ isim = -1;
+ }
+
+/* Check DS, if MODES=0 and ISIM=1 */
+
+ bads = FALSE_;
+ if (*modes == 0 && isim == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (ds[j] == 0.f) {
+ bads = TRUE_;
+ }
+/* L20: */
+ }
+ }
+
+/* Set INFO if an error */
+
+ if (*n < 0) {
+ *info = -1;
+ } else if (idist == -1) {
+ *info = -2;
+ } else if (abs(*mode) > 6) {
+ *info = -5;
+ } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.f) {
+ *info = -6;
+ } else if (badei) {
+ *info = -8;
+ } else if (irsign == -1) {
+ *info = -9;
+ } else if (iupper == -1) {
+ *info = -10;
+ } else if (isim == -1) {
+ *info = -11;
+ } else if (bads) {
+ *info = -12;
+ } else if (isim == 1 && abs(*modes) > 5) {
+ *info = -13;
+ } else if (isim == 1 && *modes != 0 && *conds < 1.f) {
+ *info = -14;
+ } else if (*kl < 1) {
+ *info = -15;
+ } else if (*ku < 1 || *ku < *n - 1 && *kl < *n - 1) {
+ *info = -16;
+ } else if (*lda < max(1,*n)) {
+ *info = -19;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLATME", &i__1);
+ return 0;
+ }
+
+/* Initialize random number generator */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
+/* L30: */
+ }
+
+ if (iseed[4] % 2 != 1) {
+ ++iseed[4];
+ }
+
+/* 2) Set up diagonal of A */
+
+/* Compute D according to COND and MODE */
+
+ slatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], n, &iinfo);
+ if (iinfo != 0) {
+ *info = 1;
+ return 0;
+ }
+ if (*mode != 0 && abs(*mode) != 6) {
+
+/* Scale by DMAX */
+
+ temp = dabs(d__[1]);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = temp, r__3 = (r__1 = d__[i__], dabs(r__1));
+ temp = dmax(r__2,r__3);
+/* L40: */
+ }
+
+ if (temp > 0.f) {
+ alpha = *dmax__ / temp;
+ } else if (*dmax__ != 0.f) {
+ *info = 2;
+ return 0;
+ } else {
+ alpha = 0.f;
+ }
+
+ sscal_(n, &alpha, &d__[1], &c__1);
+
+ }
+
+ slaset_("Full", n, n, &c_b23, &c_b23, &a[a_offset], lda);
+ i__1 = *lda + 1;
+ scopy_(n, &d__[1], &c__1, &a[a_offset], &i__1);
+
+/* Set up complex conjugate pairs */
+
+ if (*mode == 0) {
+ if (useei) {
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ if (lsame_(ei + j, "I")) {
+ a[j - 1 + j * a_dim1] = a[j + j * a_dim1];
+ a[j + (j - 1) * a_dim1] = -a[j + j * a_dim1];
+ a[j + j * a_dim1] = a[j - 1 + (j - 1) * a_dim1];
+ }
+/* L50: */
+ }
+ }
+
+ } else if (abs(*mode) == 5) {
+
+ i__1 = *n;
+ for (j = 2; j <= i__1; j += 2) {
+ if (slaran_(&iseed[1]) > .5f) {
+ a[j - 1 + j * a_dim1] = a[j + j * a_dim1];
+ a[j + (j - 1) * a_dim1] = -a[j + j * a_dim1];
+ a[j + j * a_dim1] = a[j - 1 + (j - 1) * a_dim1];
+ }
+/* L60: */
+ }
+ }
+
+/* 3) If UPPER='T', set upper triangle of A to random numbers. */
+/* (but don't modify the corners of 2x2 blocks.) */
+
+ if (iupper != 0) {
+ i__1 = *n;
+ for (jc = 2; jc <= i__1; ++jc) {
+ if (a[jc - 1 + jc * a_dim1] != 0.f) {
+ jr = jc - 2;
+ } else {
+ jr = jc - 1;
+ }
+ slarnv_(&idist, &iseed[1], &jr, &a[jc * a_dim1 + 1]);
+/* L70: */
+ }
+ }
+
+/* 4) If SIM='T', apply similarity transformation. */
+
+/* -1 */
+/* Transform is X A X , where X = U S V, thus */
+
+/* it is U S V A V' (1/S) U' */
+
+ if (isim != 0) {
+
+/* Compute S (singular values of the eigenvector matrix) */
+/* according to CONDS and MODES */
+
+ slatm1_(modes, conds, &c__0, &c__0, &iseed[1], &ds[1], n, &iinfo);
+ if (iinfo != 0) {
+ *info = 3;
+ return 0;
+ }
+
+/* Multiply by V and V' */
+
+ slarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
+ if (iinfo != 0) {
+ *info = 4;
+ return 0;
+ }
+
+/* Multiply by S and (1/S) */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sscal_(n, &ds[j], &a[j + a_dim1], lda);
+ if (ds[j] != 0.f) {
+ r__1 = 1.f / ds[j];
+ sscal_(n, &r__1, &a[j * a_dim1 + 1], &c__1);
+ } else {
+ *info = 5;
+ return 0;
+ }
+/* L80: */
+ }
+
+/* Multiply by U and U' */
+
+ slarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
+ if (iinfo != 0) {
+ *info = 4;
+ return 0;
+ }
+ }
+
+/* 5) Reduce the bandwidth. */
+
+ if (*kl < *n - 1) {
+
+/* Reduce bandwidth -- kill column */
+
+ i__1 = *n - 1;
+ for (jcr = *kl + 1; jcr <= i__1; ++jcr) {
+ ic = jcr - *kl;
+ irows = *n + 1 - jcr;
+ icols = *n + *kl - jcr;
+
+ scopy_(&irows, &a[jcr + ic * a_dim1], &c__1, &work[1], &c__1);
+ xnorms = work[1];
+ slarfg_(&irows, &xnorms, &work[2], &c__1, &tau);
+ work[1] = 1.f;
+
+ sgemv_("T", &irows, &icols, &c_b39, &a[jcr + (ic + 1) * a_dim1],
+ lda, &work[1], &c__1, &c_b23, &work[irows + 1], &c__1);
+ r__1 = -tau;
+ sger_(&irows, &icols, &r__1, &work[1], &c__1, &work[irows + 1], &
+ c__1, &a[jcr + (ic + 1) * a_dim1], lda);
+
+ sgemv_("N", n, &irows, &c_b39, &a[jcr * a_dim1 + 1], lda, &work[1]
+, &c__1, &c_b23, &work[irows + 1], &c__1);
+ r__1 = -tau;
+ sger_(n, &irows, &r__1, &work[irows + 1], &c__1, &work[1], &c__1,
+ &a[jcr * a_dim1 + 1], lda);
+
+ a[jcr + ic * a_dim1] = xnorms;
+ i__2 = irows - 1;
+ slaset_("Full", &i__2, &c__1, &c_b23, &c_b23, &a[jcr + 1 + ic *
+ a_dim1], lda);
+/* L90: */
+ }
+ } else if (*ku < *n - 1) {
+
+/* Reduce upper bandwidth -- kill a row at a time. */
+
+ i__1 = *n - 1;
+ for (jcr = *ku + 1; jcr <= i__1; ++jcr) {
+ ir = jcr - *ku;
+ irows = *n + *ku - jcr;
+ icols = *n + 1 - jcr;
+
+ scopy_(&icols, &a[ir + jcr * a_dim1], lda, &work[1], &c__1);
+ xnorms = work[1];
+ slarfg_(&icols, &xnorms, &work[2], &c__1, &tau);
+ work[1] = 1.f;
+
+ sgemv_("N", &irows, &icols, &c_b39, &a[ir + 1 + jcr * a_dim1],
+ lda, &work[1], &c__1, &c_b23, &work[icols + 1], &c__1);
+ r__1 = -tau;
+ sger_(&irows, &icols, &r__1, &work[icols + 1], &c__1, &work[1], &
+ c__1, &a[ir + 1 + jcr * a_dim1], lda);
+
+ sgemv_("C", &icols, n, &c_b39, &a[jcr + a_dim1], lda, &work[1], &
+ c__1, &c_b23, &work[icols + 1], &c__1);
+ r__1 = -tau;
+ sger_(&icols, n, &r__1, &work[1], &c__1, &work[icols + 1], &c__1,
+ &a[jcr + a_dim1], lda);
+
+ a[ir + jcr * a_dim1] = xnorms;
+ i__2 = icols - 1;
+ slaset_("Full", &c__1, &i__2, &c_b23, &c_b23, &a[ir + (jcr + 1) *
+ a_dim1], lda);
+/* L100: */
+ }
+ }
+
+/* Scale the matrix to have norm ANORM */
+
+ if (*anorm >= 0.f) {
+ temp = slange_("M", n, n, &a[a_offset], lda, tempa);
+ if (temp > 0.f) {
+ alpha = *anorm / temp;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sscal_(n, &alpha, &a[j * a_dim1 + 1], &c__1);
+/* L110: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SLATME */
+
+} /* slatme_ */
diff --git a/TESTING/MATGEN/slatmr.c b/TESTING/MATGEN/slatmr.c
new file mode 100644
index 0000000..f44fb15
--- /dev/null
+++ b/TESTING/MATGEN/slatmr.c
@@ -0,0 +1,1288 @@
+/* slatmr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int slatmr_(integer *m, integer *n, char *dist, integer *
+ iseed, char *sym, real *d__, integer *mode, real *cond, real *dmax__,
+ char *rsign, char *grade, real *dl, integer *model, real *condl, real
+ *dr, integer *moder, real *condr, char *pivtng, integer *ipivot,
+ integer *kl, integer *ku, real *sparse, real *anorm, char *pack, real
+ *a, integer *lda, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ real r__1, r__2, r__3;
+
+ /* Local variables */
+ integer i__, j, k, kll, kuu, isub, jsub;
+ real temp;
+ integer isym;
+ real alpha;
+ integer ipack;
+ extern logical lsame_(char *, char *);
+ real tempa[1];
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ integer iisub, idist, jjsub, mnmin;
+ logical dzero;
+ integer mnsub;
+ real onorm;
+ integer mxsub, npvts;
+ extern /* Subroutine */ int slatm1_(integer *, real *, integer *, integer
+ *, integer *, real *, integer *, integer *);
+ extern doublereal slatm2_(integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, real *, integer *,
+ real *, real *, integer *, integer *, real *), slatm3_(integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, real *, integer *, real *, real *
+, integer *, integer *, real *);
+ integer igrade;
+ extern doublereal slangb_(char *, integer *, integer *, integer *, real *,
+ integer *, real *), slange_(char *, integer *, integer *,
+ real *, integer *, real *);
+ logical fulbnd;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical badpvt;
+ extern doublereal slansb_(char *, char *, integer *, integer *, real *,
+ integer *, real *);
+ integer irsign;
+ extern doublereal slansp_(char *, char *, integer *, real *, real *);
+ integer ipvtng;
+ extern doublereal slansy_(char *, char *, integer *, real *, integer *,
+ real *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLATMR generates random matrices of various types for testing */
+/* LAPACK programs. */
+
+/* SLATMR operates by applying the following sequence of */
+/* operations: */
+
+/* Generate a matrix A with random entries of distribution DIST */
+/* which is symmetric if SYM='S', and nonsymmetric */
+/* if SYM='N'. */
+
+/* Set the diagonal to D, where D may be input or */
+/* computed according to MODE, COND, DMAX and RSIGN */
+/* as described below. */
+
+/* Grade the matrix, if desired, from the left and/or right */
+/* as specified by GRADE. The inputs DL, MODEL, CONDL, DR, */
+/* MODER and CONDR also determine the grading as described */
+/* below. */
+
+/* Permute, if desired, the rows and/or columns as specified by */
+/* PIVTNG and IPIVOT. */
+
+/* Set random entries to zero, if desired, to get a random sparse */
+/* matrix as specified by SPARSE. */
+
+/* Make A a band matrix, if desired, by zeroing out the matrix */
+/* outside a band of lower bandwidth KL and upper bandwidth KU. */
+
+/* Scale A, if desired, to have maximum entry ANORM. */
+
+/* Pack the matrix if desired. Options specified by PACK are: */
+/* no packing */
+/* zero out upper half (if symmetric) */
+/* zero out lower half (if symmetric) */
+/* store the upper half columnwise (if symmetric or */
+/* square upper triangular) */
+/* store the lower half columnwise (if symmetric or */
+/* square lower triangular) */
+/* same as upper half rowwise if symmetric */
+/* store the lower triangle in banded format (if symmetric) */
+/* store the upper triangle in banded format (if symmetric) */
+/* store the entire matrix in banded format */
+
+/* Note: If two calls to SLATMR differ only in the PACK parameter, */
+/* they will generate mathematically equivalent matrices. */
+
+/* If two calls to SLATMR both have full bandwidth (KL = M-1 */
+/* and KU = N-1), and differ only in the PIVTNG and PACK */
+/* parameters, then the matrices generated will differ only */
+/* in the order of the rows and/or columns, and otherwise */
+/* contain the same data. This consistency cannot be and */
+/* is not maintained with less than full bandwidth. */
+
+/* Arguments */
+/* ========= */
+
+/* M - INTEGER */
+/* Number of rows of A. Not modified. */
+
+/* N - INTEGER */
+/* Number of columns of A. Not modified. */
+
+/* DIST - CHARACTER*1 */
+/* On entry, DIST specifies the type of distribution to be used */
+/* to generate a random matrix . */
+/* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */
+/* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */
+/* 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. They should lie between 0 and 4095 inclusive, */
+/* and ISEED(4) should be odd. The random number generator */
+/* uses a linear congruential sequence limited to small */
+/* integers, and so should produce machine independent */
+/* random numbers. The values of ISEED are changed on */
+/* exit, and can be used in the next call to SLATMR */
+/* to continue the same random number sequence. */
+/* Changed on exit. */
+
+/* SYM - CHARACTER*1 */
+/* If SYM='S' or 'H', generated matrix is symmetric. */
+/* If SYM='N', generated matrix is nonsymmetric. */
+/* Not modified. */
+
+/* D - REAL array, dimension (min(M,N)) */
+/* On entry this array specifies the diagonal entries */
+/* of the diagonal of A. D may either be specified */
+/* on entry, or set according to MODE and COND as described */
+/* below. May be changed on exit if MODE is nonzero. */
+
+/* MODE - INTEGER */
+/* On entry describes how D is to be used: */
+/* MODE = 0 means use D as input */
+/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
+/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
+/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
+/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* MODE = 5 sets D to random numbers in the range */
+/* ( 1/COND , 1 ) such that their logarithms */
+/* are uniformly distributed. */
+/* MODE = 6 set D to random numbers from same distribution */
+/* as the rest of the matrix. */
+/* MODE < 0 has the same meaning as ABS(MODE), except that */
+/* the order of the elements of D is reversed. */
+/* Thus if MODE is positive, D has entries ranging from */
+/* 1 to 1/COND, if negative, from 1/COND to 1, */
+/* Not modified. */
+
+/* COND - REAL */
+/* On entry, used as described under MODE above. */
+/* If used, it must be >= 1. Not modified. */
+
+/* DMAX - REAL */
+/* If MODE neither -6, 0 nor 6, the diagonal is scaled by */
+/* DMAX / max(abs(D(i))), so that maximum absolute entry */
+/* of diagonal is abs(DMAX). If DMAX is negative (or zero), */
+/* diagonal will be scaled by a negative number (or zero). */
+
+/* RSIGN - CHARACTER*1 */
+/* If MODE neither -6, 0 nor 6, specifies sign of diagonal */
+/* as follows: */
+/* 'T' => diagonal entries are multiplied by 1 or -1 */
+/* with probability .5 */
+/* 'F' => diagonal unchanged */
+/* Not modified. */
+
+/* GRADE - CHARACTER*1 */
+/* Specifies grading of matrix as follows: */
+/* 'N' => no grading */
+/* 'L' => matrix premultiplied by diag( DL ) */
+/* (only if matrix nonsymmetric) */
+/* 'R' => matrix postmultiplied by diag( DR ) */
+/* (only if matrix nonsymmetric) */
+/* 'B' => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DR ) */
+/* (only if matrix nonsymmetric) */
+/* 'S' or 'H' => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DL ) */
+/* ('S' for symmetric, or 'H' for Hermitian) */
+/* 'E' => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by inv( diag( DL ) ) */
+/* ( 'E' for eigenvalue invariance) */
+/* (only if matrix nonsymmetric) */
+/* Note: if GRADE='E', then M must equal N. */
+/* Not modified. */
+
+/* DL - REAL array, dimension (M) */
+/* If MODEL=0, then on entry this array specifies the diagonal */
+/* entries of a diagonal matrix used as described under GRADE */
+/* above. If MODEL is not zero, then DL will be set according */
+/* to MODEL and CONDL, analogous to the way D is set according */
+/* to MODE and COND (except there is no DMAX parameter for DL). */
+/* If GRADE='E', then DL cannot have zero entries. */
+/* Not referenced if GRADE = 'N' or 'R'. Changed on exit. */
+
+/* MODEL - INTEGER */
+/* This specifies how the diagonal array DL is to be computed, */
+/* just as MODE specifies how D is to be computed. */
+/* Not modified. */
+
+/* CONDL - REAL */
+/* When MODEL is not zero, this specifies the condition number */
+/* of the computed DL. Not modified. */
+
+/* DR - REAL array, dimension (N) */
+/* If MODER=0, then on entry this array specifies the diagonal */
+/* entries of a diagonal matrix used as described under GRADE */
+/* above. If MODER is not zero, then DR will be set according */
+/* to MODER and CONDR, analogous to the way D is set according */
+/* to MODE and COND (except there is no DMAX parameter for DR). */
+/* Not referenced if GRADE = 'N', 'L', 'H', 'S' or 'E'. */
+/* Changed on exit. */
+
+/* MODER - INTEGER */
+/* This specifies how the diagonal array DR is to be computed, */
+/* just as MODE specifies how D is to be computed. */
+/* Not modified. */
+
+/* CONDR - REAL */
+/* When MODER is not zero, this specifies the condition number */
+/* of the computed DR. Not modified. */
+
+/* PIVTNG - CHARACTER*1 */
+/* On entry specifies pivoting permutations as follows: */
+/* 'N' or ' ' => none. */
+/* 'L' => left or row pivoting (matrix must be nonsymmetric). */
+/* 'R' => right or column pivoting (matrix must be */
+/* nonsymmetric). */
+/* 'B' or 'F' => both or full pivoting, i.e., on both sides. */
+/* In this case, M must equal N */
+
+/* If two calls to SLATMR both have full bandwidth (KL = M-1 */
+/* and KU = N-1), and differ only in the PIVTNG and PACK */
+/* parameters, then the matrices generated will differ only */
+/* in the order of the rows and/or columns, and otherwise */
+/* contain the same data. This consistency cannot be */
+/* maintained with less than full bandwidth. */
+
+/* IPIVOT - INTEGER array, dimension (N or M) */
+/* This array specifies the permutation used. After the */
+/* basic matrix is generated, the rows, columns, or both */
+/* are permuted. If, say, row pivoting is selected, SLATMR */
+/* starts with the *last* row and interchanges the M-th and */
+/* IPIVOT(M)-th rows, then moves to the next-to-last row, */
+/* interchanging the (M-1)-th and the IPIVOT(M-1)-th rows, */
+/* and so on. In terms of "2-cycles", the permutation is */
+/* (1 IPIVOT(1)) (2 IPIVOT(2)) ... (M IPIVOT(M)) */
+/* where the rightmost cycle is applied first. This is the */
+/* *inverse* of the effect of pivoting in LINPACK. The idea */
+/* is that factoring (with pivoting) an identity matrix */
+/* which has been inverse-pivoted in this way should */
+/* result in a pivot vector identical to IPIVOT. */
+/* Not referenced if PIVTNG = 'N'. Not modified. */
+
+/* SPARSE - REAL */
+/* On entry specifies the sparsity of the matrix if a sparse */
+/* matrix is to be generated. SPARSE should lie between */
+/* 0 and 1. To generate a sparse matrix, for each matrix entry */
+/* a uniform ( 0, 1 ) random number x is generated and */
+/* compared to SPARSE; if x is larger the matrix entry */
+/* is unchanged and if x is smaller the entry is set */
+/* to zero. Thus on the average a fraction SPARSE of the */
+/* entries will be set to zero. */
+/* Not modified. */
+
+/* KL - INTEGER */
+/* On entry specifies the lower bandwidth of the matrix. For */
+/* example, KL=0 implies upper triangular, KL=1 implies upper */
+/* Hessenberg, and KL at least M-1 implies the matrix is not */
+/* banded. Must equal KU if matrix is symmetric. */
+/* Not modified. */
+
+/* KU - INTEGER */
+/* On entry specifies the upper bandwidth of the matrix. For */
+/* example, KU=0 implies lower triangular, KU=1 implies lower */
+/* Hessenberg, and KU at least N-1 implies the matrix is not */
+/* banded. Must equal KL if matrix is symmetric. */
+/* Not modified. */
+
+/* ANORM - REAL */
+/* On entry specifies maximum entry of output matrix */
+/* (output matrix will by multiplied by a constant so that */
+/* its largest absolute entry equal ANORM) */
+/* if ANORM is nonnegative. If ANORM is negative no scaling */
+/* is done. Not modified. */
+
+/* PACK - CHARACTER*1 */
+/* On entry specifies packing of matrix as follows: */
+/* 'N' => no packing */
+/* 'U' => zero out all subdiagonal entries (if symmetric) */
+/* 'L' => zero out all superdiagonal entries (if symmetric) */
+/* 'C' => store the upper triangle columnwise */
+/* (only if matrix symmetric or square upper triangular) */
+/* 'R' => store the lower triangle columnwise */
+/* (only if matrix symmetric or square lower triangular) */
+/* (same as upper half rowwise if symmetric) */
+/* 'B' => store the lower triangle in band storage scheme */
+/* (only if matrix symmetric) */
+/* 'Q' => store the upper triangle in band storage scheme */
+/* (only if matrix symmetric) */
+/* 'Z' => store the entire matrix in band storage scheme */
+/* (pivoting can be provided for by using this */
+/* option to store A in the trailing rows of */
+/* the allocated storage) */
+
+/* Using these options, the various LAPACK packed and banded */
+/* storage schemes can be obtained: */
+/* GB - use 'Z' */
+/* PB, SB or TB - use 'B' or 'Q' */
+/* PP, SP or TP - use 'C' or 'R' */
+
+/* If two calls to SLATMR differ only in the PACK parameter, */
+/* they will generate mathematically equivalent matrices. */
+/* Not modified. */
+
+/* A - REAL array, dimension (LDA,N) */
+/* On exit A is the desired test matrix. Only those */
+/* entries of A which are significant on output */
+/* will be referenced (even if A is in packed or band */
+/* storage format). The 'unoccupied corners' of A in */
+/* band format will be zeroed out. */
+
+/* LDA - INTEGER */
+/* on entry LDA specifies the first dimension of A as */
+/* declared in the calling program. */
+/* If PACK='N', 'U' or 'L', LDA must be at least max ( 1, M ). */
+/* If PACK='C' or 'R', LDA must be at least 1. */
+/* If PACK='B', or 'Q', LDA must be MIN ( KU+1, N ) */
+/* If PACK='Z', LDA must be at least KUU+KLL+1, where */
+/* KUU = MIN ( KU, N-1 ) and KLL = MIN ( KL, N-1 ) */
+/* Not modified. */
+
+/* IWORK - INTEGER array, dimension ( N or M) */
+/* Workspace. Not referenced if PIVTNG = 'N'. Changed on exit. */
+
+/* INFO - INTEGER */
+/* Error parameter on exit: */
+/* 0 => normal return */
+/* -1 => M negative or unequal to N and SYM='S' or 'H' */
+/* -2 => N negative */
+/* -3 => DIST illegal string */
+/* -5 => SYM illegal string */
+/* -7 => MODE not in range -6 to 6 */
+/* -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */
+/* -10 => MODE neither -6, 0 nor 6 and RSIGN illegal string */
+/* -11 => GRADE illegal string, or GRADE='E' and */
+/* M not equal to N, or GRADE='L', 'R', 'B' or 'E' and */
+/* SYM = 'S' or 'H' */
+/* -12 => GRADE = 'E' and DL contains zero */
+/* -13 => MODEL not in range -6 to 6 and GRADE= 'L', 'B', 'H', */
+/* 'S' or 'E' */
+/* -14 => CONDL less than 1.0, GRADE='L', 'B', 'H', 'S' or 'E', */
+/* and MODEL neither -6, 0 nor 6 */
+/* -16 => MODER not in range -6 to 6 and GRADE= 'R' or 'B' */
+/* -17 => CONDR less than 1.0, GRADE='R' or 'B', and */
+/* MODER neither -6, 0 nor 6 */
+/* -18 => PIVTNG illegal string, or PIVTNG='B' or 'F' and */
+/* M not equal to N, or PIVTNG='L' or 'R' and SYM='S' */
+/* or 'H' */
+/* -19 => IPIVOT contains out of range number and */
+/* PIVTNG not equal to 'N' */
+/* -20 => KL negative */
+/* -21 => KU negative, or SYM='S' or 'H' and KU not equal to KL */
+/* -22 => SPARSE not in range 0. to 1. */
+/* -24 => PACK illegal string, or PACK='U', 'L', 'B' or 'Q' */
+/* and SYM='N', or PACK='C' and SYM='N' and either KL */
+/* not equal to 0 or N not equal to M, or PACK='R' and */
+/* SYM='N', and either KU not equal to 0 or N not equal */
+/* to M */
+/* -26 => LDA too small */
+/* 1 => Error return from SLATM1 (computing D) */
+/* 2 => Cannot scale diagonal to DMAX (max. entry is 0) */
+/* 3 => Error return from SLATM1 (computing DL) */
+/* 4 => Error return from SLATM1 (computing DR) */
+/* 5 => ANORM is positive, but matrix constructed prior to */
+/* attempting to scale it to have norm ANORM, is zero */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Decode and Test the input parameters. */
+/* Initialize flags & seed. */
+
+ /* Parameter adjustments */
+ --iseed;
+ --d__;
+ --dl;
+ --dr;
+ --ipivot;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Decode DIST */
+
+ if (lsame_(dist, "U")) {
+ idist = 1;
+ } else if (lsame_(dist, "S")) {
+ idist = 2;
+ } else if (lsame_(dist, "N")) {
+ idist = 3;
+ } else {
+ idist = -1;
+ }
+
+/* Decode SYM */
+
+ if (lsame_(sym, "S")) {
+ isym = 0;
+ } else if (lsame_(sym, "N")) {
+ isym = 1;
+ } else if (lsame_(sym, "H")) {
+ isym = 0;
+ } else {
+ isym = -1;
+ }
+
+/* Decode RSIGN */
+
+ if (lsame_(rsign, "F")) {
+ irsign = 0;
+ } else if (lsame_(rsign, "T")) {
+ irsign = 1;
+ } else {
+ irsign = -1;
+ }
+
+/* Decode PIVTNG */
+
+ if (lsame_(pivtng, "N")) {
+ ipvtng = 0;
+ } else if (lsame_(pivtng, " ")) {
+ ipvtng = 0;
+ } else if (lsame_(pivtng, "L")) {
+ ipvtng = 1;
+ npvts = *m;
+ } else if (lsame_(pivtng, "R")) {
+ ipvtng = 2;
+ npvts = *n;
+ } else if (lsame_(pivtng, "B")) {
+ ipvtng = 3;
+ npvts = min(*n,*m);
+ } else if (lsame_(pivtng, "F")) {
+ ipvtng = 3;
+ npvts = min(*n,*m);
+ } else {
+ ipvtng = -1;
+ }
+
+/* Decode GRADE */
+
+ if (lsame_(grade, "N")) {
+ igrade = 0;
+ } else if (lsame_(grade, "L")) {
+ igrade = 1;
+ } else if (lsame_(grade, "R")) {
+ igrade = 2;
+ } else if (lsame_(grade, "B")) {
+ igrade = 3;
+ } else if (lsame_(grade, "E")) {
+ igrade = 4;
+ } else if (lsame_(grade, "H") || lsame_(grade,
+ "S")) {
+ igrade = 5;
+ } else {
+ igrade = -1;
+ }
+
+/* Decode PACK */
+
+ if (lsame_(pack, "N")) {
+ ipack = 0;
+ } else if (lsame_(pack, "U")) {
+ ipack = 1;
+ } else if (lsame_(pack, "L")) {
+ ipack = 2;
+ } else if (lsame_(pack, "C")) {
+ ipack = 3;
+ } else if (lsame_(pack, "R")) {
+ ipack = 4;
+ } else if (lsame_(pack, "B")) {
+ ipack = 5;
+ } else if (lsame_(pack, "Q")) {
+ ipack = 6;
+ } else if (lsame_(pack, "Z")) {
+ ipack = 7;
+ } else {
+ ipack = -1;
+ }
+
+/* Set certain internal parameters */
+
+ mnmin = min(*m,*n);
+/* Computing MIN */
+ i__1 = *kl, i__2 = *m - 1;
+ kll = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *ku, i__2 = *n - 1;
+ kuu = min(i__1,i__2);
+
+/* If inv(DL) is used, check to see if DL has a zero entry. */
+
+ dzero = FALSE_;
+ if (igrade == 4 && *model == 0) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (dl[i__] == 0.f) {
+ dzero = TRUE_;
+ }
+/* L10: */
+ }
+ }
+
+/* Check values in IPIVOT */
+
+ badpvt = FALSE_;
+ if (ipvtng > 0) {
+ i__1 = npvts;
+ for (j = 1; j <= i__1; ++j) {
+ if (ipivot[j] <= 0 || ipivot[j] > npvts) {
+ badpvt = TRUE_;
+ }
+/* L20: */
+ }
+ }
+
+/* Set INFO if an error */
+
+ if (*m < 0) {
+ *info = -1;
+ } else if (*m != *n && isym == 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (idist == -1) {
+ *info = -3;
+ } else if (isym == -1) {
+ *info = -5;
+ } else if (*mode < -6 || *mode > 6) {
+ *info = -7;
+ } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.f) {
+ *info = -8;
+ } else if (*mode != -6 && *mode != 0 && *mode != 6 && irsign == -1) {
+ *info = -10;
+ } else if (igrade == -1 || igrade == 4 && *m != *n || igrade >= 1 &&
+ igrade <= 4 && isym == 0) {
+ *info = -11;
+ } else if (igrade == 4 && dzero) {
+ *info = -12;
+ } else if ((igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5) && (
+ *model < -6 || *model > 6)) {
+ *info = -13;
+ } else if ((igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5) && (
+ *model != -6 && *model != 0 && *model != 6) && *condl < 1.f) {
+ *info = -14;
+ } else if ((igrade == 2 || igrade == 3) && (*moder < -6 || *moder > 6)) {
+ *info = -16;
+ } else if ((igrade == 2 || igrade == 3) && (*moder != -6 && *moder != 0 &&
+ *moder != 6) && *condr < 1.f) {
+ *info = -17;
+ } else if (ipvtng == -1 || ipvtng == 3 && *m != *n || (ipvtng == 1 ||
+ ipvtng == 2) && isym == 0) {
+ *info = -18;
+ } else if (ipvtng != 0 && badpvt) {
+ *info = -19;
+ } else if (*kl < 0) {
+ *info = -20;
+ } else if (*ku < 0 || isym == 0 && *kl != *ku) {
+ *info = -21;
+ } else if (*sparse < 0.f || *sparse > 1.f) {
+ *info = -22;
+ } else if (ipack == -1 || (ipack == 1 || ipack == 2 || ipack == 5 ||
+ ipack == 6) && isym == 1 || ipack == 3 && isym == 1 && (*kl != 0
+ || *m != *n) || ipack == 4 && isym == 1 && (*ku != 0 || *m != *n))
+ {
+ *info = -24;
+ } else if ((ipack == 0 || ipack == 1 || ipack == 2) && *lda < max(1,*m) ||
+ (ipack == 3 || ipack == 4) && *lda < 1 || (ipack == 5 || ipack ==
+ 6) && *lda < kuu + 1 || ipack == 7 && *lda < kll + kuu + 1) {
+ *info = -26;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLATMR", &i__1);
+ return 0;
+ }
+
+/* Decide if we can pivot consistently */
+
+ fulbnd = FALSE_;
+ if (kuu == *n - 1 && kll == *m - 1) {
+ fulbnd = TRUE_;
+ }
+
+/* Initialize random number generator */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
+/* L30: */
+ }
+
+ iseed[4] = (iseed[4] / 2 << 1) + 1;
+
+/* 2) Set up D, DL, and DR, if indicated. */
+
+/* Compute D according to COND and MODE */
+
+ slatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, info);
+ if (*info != 0) {
+ *info = 1;
+ return 0;
+ }
+ if (*mode != 0 && *mode != -6 && *mode != 6) {
+
+/* Scale by DMAX */
+
+ temp = dabs(d__[1]);
+ i__1 = mnmin;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = temp, r__3 = (r__1 = d__[i__], dabs(r__1));
+ temp = dmax(r__2,r__3);
+/* L40: */
+ }
+ if (temp == 0.f && *dmax__ != 0.f) {
+ *info = 2;
+ return 0;
+ }
+ if (temp != 0.f) {
+ alpha = *dmax__ / temp;
+ } else {
+ alpha = 1.f;
+ }
+ i__1 = mnmin;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ d__[i__] = alpha * d__[i__];
+/* L50: */
+ }
+
+ }
+
+/* Compute DL if grading set */
+
+ if (igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5) {
+ slatm1_(model, condl, &c__0, &idist, &iseed[1], &dl[1], m, info);
+ if (*info != 0) {
+ *info = 3;
+ return 0;
+ }
+ }
+
+/* Compute DR if grading set */
+
+ if (igrade == 2 || igrade == 3) {
+ slatm1_(moder, condr, &c__0, &idist, &iseed[1], &dr[1], n, info);
+ if (*info != 0) {
+ *info = 4;
+ return 0;
+ }
+ }
+
+/* 3) Generate IWORK if pivoting */
+
+ if (ipvtng > 0) {
+ i__1 = npvts;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ iwork[i__] = i__;
+/* L60: */
+ }
+ if (fulbnd) {
+ i__1 = npvts;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ k = ipivot[i__];
+ j = iwork[i__];
+ iwork[i__] = iwork[k];
+ iwork[k] = j;
+/* L70: */
+ }
+ } else {
+ for (i__ = npvts; i__ >= 1; --i__) {
+ k = ipivot[i__];
+ j = iwork[i__];
+ iwork[i__] = iwork[k];
+ iwork[k] = j;
+/* L80: */
+ }
+ }
+ }
+
+/* 4) Generate matrices for each kind of PACKing */
+/* Always sweep matrix columnwise (if symmetric, upper */
+/* half only) so that matrix generated does not depend */
+/* on PACK */
+
+ if (fulbnd) {
+
+/* Use SLATM3 so matrices generated with differing PIVOTing only */
+/* differ only in the order of their rows and/or columns. */
+
+ if (ipack == 0) {
+ if (isym == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = slatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ a[isub + jsub * a_dim1] = temp;
+ a[jsub + isub * a_dim1] = temp;
+/* L90: */
+ }
+/* L100: */
+ }
+ } else if (isym == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = slatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ a[isub + jsub * a_dim1] = temp;
+/* L110: */
+ }
+/* L120: */
+ }
+ }
+
+ } else if (ipack == 1) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = slatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ a[mnsub + mxsub * a_dim1] = temp;
+ if (mnsub != mxsub) {
+ a[mxsub + mnsub * a_dim1] = 0.f;
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+
+ } else if (ipack == 2) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = slatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ a[mxsub + mnsub * a_dim1] = temp;
+ if (mnsub != mxsub) {
+ a[mnsub + mxsub * a_dim1] = 0.f;
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+
+ } else if (ipack == 3) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = slatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+
+/* Compute K = location of (ISUB,JSUB) entry in packed */
+/* array */
+
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ k = mxsub * (mxsub - 1) / 2 + mnsub;
+
+/* Convert K to (IISUB,JJSUB) location */
+
+ jjsub = (k - 1) / *lda + 1;
+ iisub = k - *lda * (jjsub - 1);
+
+ a[iisub + jjsub * a_dim1] = temp;
+/* L170: */
+ }
+/* L180: */
+ }
+
+ } else if (ipack == 4) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ temp = slatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+
+/* Compute K = location of (I,J) entry in packed array */
+
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ if (mnsub == 1) {
+ k = mxsub;
+ } else {
+ k = *n * (*n + 1) / 2 - (*n - mnsub + 1) * (*n -
+ mnsub + 2) / 2 + mxsub - mnsub + 1;
+ }
+
+/* Convert K to (IISUB,JJSUB) location */
+
+ jjsub = (k - 1) / *lda + 1;
+ iisub = k - *lda * (jjsub - 1);
+
+ a[iisub + jjsub * a_dim1] = temp;
+/* L190: */
+ }
+/* L200: */
+ }
+
+ } else if (ipack == 5) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ if (i__ < 1) {
+ a[j - i__ + 1 + (i__ + *n) * a_dim1] = 0.f;
+ } else {
+ temp = slatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ a[mxsub - mnsub + 1 + mnsub * a_dim1] = temp;
+ }
+/* L210: */
+ }
+/* L220: */
+ }
+
+ } else if (ipack == 6) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ temp = slatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ a[mnsub - mxsub + kuu + 1 + mxsub * a_dim1] = temp;
+/* L230: */
+ }
+/* L240: */
+ }
+
+ } else if (ipack == 7) {
+
+ if (isym == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ temp = slatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ a[mnsub - mxsub + kuu + 1 + mxsub * a_dim1] = temp;
+ if (i__ < 1) {
+ a[j - i__ + 1 + kuu + (i__ + *n) * a_dim1] = 0.f;
+ }
+ if (i__ >= 1 && mnsub != mxsub) {
+ a[mxsub - mnsub + 1 + kuu + mnsub * a_dim1] =
+ temp;
+ }
+/* L250: */
+ }
+/* L260: */
+ }
+ } else if (isym == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + kll;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ temp = slatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ a[isub - jsub + kuu + 1 + jsub * a_dim1] = temp;
+/* L270: */
+ }
+/* L280: */
+ }
+ }
+
+ }
+
+ } else {
+
+/* Use SLATM2 */
+
+ if (ipack == 0) {
+ if (isym == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = slatm2_(m, n, &i__, &j, kl, ku,
+ &idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ a[j + i__ * a_dim1] = a[i__ + j * a_dim1];
+/* L290: */
+ }
+/* L300: */
+ }
+ } else if (isym == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = slatm2_(m, n, &i__, &j, kl, ku,
+ &idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+/* L310: */
+ }
+/* L320: */
+ }
+ }
+
+ } else if (ipack == 1) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = slatm2_(m, n, &i__, &j, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ if (i__ != j) {
+ a[j + i__ * a_dim1] = 0.f;
+ }
+/* L330: */
+ }
+/* L340: */
+ }
+
+ } else if (ipack == 2) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[j + i__ * a_dim1] = slatm2_(m, n, &i__, &j, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ if (i__ != j) {
+ a[i__ + j * a_dim1] = 0.f;
+ }
+/* L350: */
+ }
+/* L360: */
+ }
+
+ } else if (ipack == 3) {
+
+ isub = 0;
+ jsub = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ++isub;
+ if (isub > *lda) {
+ isub = 1;
+ ++jsub;
+ }
+ a[isub + jsub * a_dim1] = slatm2_(m, n, &i__, &j, kl, ku,
+ &idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[
+ 1], &ipvtng, &iwork[1], sparse);
+/* L370: */
+ }
+/* L380: */
+ }
+
+ } else if (ipack == 4) {
+
+ if (isym == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+
+/* Compute K = location of (I,J) entry in packed array */
+
+ if (i__ == 1) {
+ k = j;
+ } else {
+ k = *n * (*n + 1) / 2 - (*n - i__ + 1) * (*n -
+ i__ + 2) / 2 + j - i__ + 1;
+ }
+
+/* Convert K to (ISUB,JSUB) location */
+
+ jsub = (k - 1) / *lda + 1;
+ isub = k - *lda * (jsub - 1);
+
+ a[isub + jsub * a_dim1] = slatm2_(m, n, &i__, &j, kl,
+ ku, &idist, &iseed[1], &d__[1], &igrade, &dl[
+ 1], &dr[1], &ipvtng, &iwork[1], sparse);
+/* L390: */
+ }
+/* L400: */
+ }
+ } else {
+ isub = 0;
+ jsub = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ++isub;
+ if (isub > *lda) {
+ isub = 1;
+ ++jsub;
+ }
+ a[isub + jsub * a_dim1] = slatm2_(m, n, &i__, &j, kl,
+ ku, &idist, &iseed[1], &d__[1], &igrade, &dl[
+ 1], &dr[1], &ipvtng, &iwork[1], sparse);
+/* L410: */
+ }
+/* L420: */
+ }
+ }
+
+ } else if (ipack == 5) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ if (i__ < 1) {
+ a[j - i__ + 1 + (i__ + *n) * a_dim1] = 0.f;
+ } else {
+ a[j - i__ + 1 + i__ * a_dim1] = slatm2_(m, n, &i__, &
+ j, kl, ku, &idist, &iseed[1], &d__[1], &
+ igrade, &dl[1], &dr[1], &ipvtng, &iwork[1],
+ sparse);
+ }
+/* L430: */
+ }
+/* L440: */
+ }
+
+ } else if (ipack == 6) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ a[i__ - j + kuu + 1 + j * a_dim1] = slatm2_(m, n, &i__, &
+ j, kl, ku, &idist, &iseed[1], &d__[1], &igrade, &
+ dl[1], &dr[1], &ipvtng, &iwork[1], sparse);
+/* L450: */
+ }
+/* L460: */
+ }
+
+ } else if (ipack == 7) {
+
+ if (isym == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ a[i__ - j + kuu + 1 + j * a_dim1] = slatm2_(m, n, &
+ i__, &j, kl, ku, &idist, &iseed[1], &d__[1], &
+ igrade, &dl[1], &dr[1], &ipvtng, &iwork[1],
+ sparse);
+ if (i__ < 1) {
+ a[j - i__ + 1 + kuu + (i__ + *n) * a_dim1] = 0.f;
+ }
+ if (i__ >= 1 && i__ != j) {
+ a[j - i__ + 1 + kuu + i__ * a_dim1] = a[i__ - j +
+ kuu + 1 + j * a_dim1];
+ }
+/* L470: */
+ }
+/* L480: */
+ }
+ } else if (isym == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + kll;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ a[i__ - j + kuu + 1 + j * a_dim1] = slatm2_(m, n, &
+ i__, &j, kl, ku, &idist, &iseed[1], &d__[1], &
+ igrade, &dl[1], &dr[1], &ipvtng, &iwork[1],
+ sparse);
+/* L490: */
+ }
+/* L500: */
+ }
+ }
+
+ }
+
+ }
+
+/* 5) Scaling the norm */
+
+ if (ipack == 0) {
+ onorm = slange_("M", m, n, &a[a_offset], lda, tempa);
+ } else if (ipack == 1) {
+ onorm = slansy_("M", "U", n, &a[a_offset], lda, tempa);
+ } else if (ipack == 2) {
+ onorm = slansy_("M", "L", n, &a[a_offset], lda, tempa);
+ } else if (ipack == 3) {
+ onorm = slansp_("M", "U", n, &a[a_offset], tempa);
+ } else if (ipack == 4) {
+ onorm = slansp_("M", "L", n, &a[a_offset], tempa);
+ } else if (ipack == 5) {
+ onorm = slansb_("M", "L", n, &kll, &a[a_offset], lda, tempa);
+ } else if (ipack == 6) {
+ onorm = slansb_("M", "U", n, &kuu, &a[a_offset], lda, tempa);
+ } else if (ipack == 7) {
+ onorm = slangb_("M", n, &kll, &kuu, &a[a_offset], lda, tempa);
+ }
+
+ if (*anorm >= 0.f) {
+
+ if (*anorm > 0.f && onorm == 0.f) {
+
+/* Desired scaling impossible */
+
+ *info = 5;
+ return 0;
+
+ } else if (*anorm > 1.f && onorm < 1.f || *anorm < 1.f && onorm > 1.f)
+ {
+
+/* Scale carefully to avoid over / underflow */
+
+ if (ipack <= 2) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ r__1 = 1.f / onorm;
+ sscal_(m, &r__1, &a[j * a_dim1 + 1], &c__1);
+ sscal_(m, anorm, &a[j * a_dim1 + 1], &c__1);
+/* L510: */
+ }
+
+ } else if (ipack == 3 || ipack == 4) {
+
+ i__1 = *n * (*n + 1) / 2;
+ r__1 = 1.f / onorm;
+ sscal_(&i__1, &r__1, &a[a_offset], &c__1);
+ i__1 = *n * (*n + 1) / 2;
+ sscal_(&i__1, anorm, &a[a_offset], &c__1);
+
+ } else if (ipack >= 5) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = kll + kuu + 1;
+ r__1 = 1.f / onorm;
+ sscal_(&i__2, &r__1, &a[j * a_dim1 + 1], &c__1);
+ i__2 = kll + kuu + 1;
+ sscal_(&i__2, anorm, &a[j * a_dim1 + 1], &c__1);
+/* L520: */
+ }
+
+ }
+
+ } else {
+
+/* Scale straightforwardly */
+
+ if (ipack <= 2) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ r__1 = *anorm / onorm;
+ sscal_(m, &r__1, &a[j * a_dim1 + 1], &c__1);
+/* L530: */
+ }
+
+ } else if (ipack == 3 || ipack == 4) {
+
+ i__1 = *n * (*n + 1) / 2;
+ r__1 = *anorm / onorm;
+ sscal_(&i__1, &r__1, &a[a_offset], &c__1);
+
+ } else if (ipack >= 5) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = kll + kuu + 1;
+ r__1 = *anorm / onorm;
+ sscal_(&i__2, &r__1, &a[j * a_dim1 + 1], &c__1);
+/* L540: */
+ }
+ }
+
+ }
+
+ }
+
+/* End of SLATMR */
+
+ return 0;
+} /* slatmr_ */
diff --git a/TESTING/MATGEN/slatms.c b/TESTING/MATGEN/slatms.c
new file mode 100644
index 0000000..e024aa7
--- /dev/null
+++ b/TESTING/MATGEN/slatms.c
@@ -0,0 +1,1326 @@
+/* slatms.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b22 = 0.f;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int slatms_(integer *m, integer *n, char *dist, integer *
+ iseed, char *sym, real *d__, integer *mode, real *cond, real *dmax__,
+ integer *kl, integer *ku, char *pack, real *a, integer *lda, real *
+ work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1, r__2, r__3;
+ logical L__1;
+
+ /* Builtin functions */
+ double cos(doublereal), sin(doublereal);
+
+ /* Local variables */
+ real c__;
+ integer i__, j, k;
+ real s;
+ integer ic, jc, nc, il, ir, jr, mr, ir1, ir2, jch, llb, jkl, jku, uub,
+ ilda, icol;
+ real temp;
+ integer irow, isym;
+ real alpha, angle;
+ integer ipack, ioffg;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ integer idist, mnmin, iskew;
+ real extra, dummy;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), slatm1_(integer *, real *, integer *, integer *,
+ integer *, real *, integer *, integer *);
+ integer iendch, ipackg;
+ extern /* Subroutine */ int slagge_(integer *, integer *, integer *,
+ integer *, real *, real *, integer *, integer *, real *, integer *
+);
+ integer minlda;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal slarnd_(integer *, integer *);
+ logical iltemp, givens;
+ integer ioffst, irsign;
+ extern /* Subroutine */ int slartg_(real *, real *, real *, real *, real *
+), slaset_(char *, integer *, integer *, real *, real *, real *,
+ integer *), slagsy_(integer *, integer *, real *, real *,
+ integer *, integer *, real *, integer *), slarot_(logical *,
+ logical *, logical *, integer *, real *, real *, real *, integer *
+, real *, real *);
+ logical ilextr, topdwn;
+ integer isympk;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLATMS generates random matrices with specified singular values */
+/* (or symmetric/hermitian with specified eigenvalues) */
+/* for testing LAPACK programs. */
+
+/* SLATMS operates by applying the following sequence of */
+/* operations: */
+
+/* Set the diagonal to D, where D may be input or */
+/* computed according to MODE, COND, DMAX, and SYM */
+/* as described below. */
+
+/* Generate a matrix with the appropriate band structure, by one */
+/* of two methods: */
+
+/* Method A: */
+/* Generate a dense M x N matrix by multiplying D on the left */
+/* and the right by random unitary matrices, then: */
+
+/* Reduce the bandwidth according to KL and KU, using */
+/* Householder transformations. */
+
+/* Method B: */
+/* Convert the bandwidth-0 (i.e., diagonal) matrix to a */
+/* bandwidth-1 matrix using Givens rotations, "chasing" */
+/* out-of-band elements back, much as in QR; then */
+/* convert the bandwidth-1 to a bandwidth-2 matrix, etc. */
+/* Note that for reasonably small bandwidths (relative to */
+/* M and N) this requires less storage, as a dense matrix */
+/* is not generated. Also, for symmetric matrices, only */
+/* one triangle is generated. */
+
+/* Method A is chosen if the bandwidth is a large fraction of the */
+/* order of the matrix, and LDA is at least M (so a dense */
+/* matrix can be stored.) Method B is chosen if the bandwidth */
+/* is small (< 1/2 N for symmetric, < .3 N+M for */
+/* non-symmetric), or LDA is less than M and not less than the */
+/* bandwidth. */
+
+/* Pack the matrix if desired. Options specified by PACK are: */
+/* no packing */
+/* zero out upper half (if symmetric) */
+/* zero out lower half (if symmetric) */
+/* store the upper half columnwise (if symmetric or upper */
+/* triangular) */
+/* store the lower half columnwise (if symmetric or lower */
+/* triangular) */
+/* store the lower triangle in banded format (if symmetric */
+/* or lower triangular) */
+/* store the upper triangle in banded format (if symmetric */
+/* or upper triangular) */
+/* store the entire matrix in banded format */
+/* If Method B is chosen, and band format is specified, then the */
+/* matrix will be generated in the band format, so no repacking */
+/* will be necessary. */
+
+/* Arguments */
+/* ========= */
+
+/* M - INTEGER */
+/* The number of rows of A. Not modified. */
+
+/* N - INTEGER */
+/* The number of columns of A. Not modified. */
+
+/* DIST - CHARACTER*1 */
+/* On entry, DIST specifies the type of distribution to be used */
+/* to generate the random eigen-/singular values. */
+/* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */
+/* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */
+/* 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension ( 4 ) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. They should lie between 0 and 4095 inclusive, */
+/* and ISEED(4) should be odd. The random number generator */
+/* uses a linear congruential sequence limited to small */
+/* integers, and so should produce machine independent */
+/* random numbers. The values of ISEED are changed on */
+/* exit, and can be used in the next call to SLATMS */
+/* to continue the same random number sequence. */
+/* Changed on exit. */
+
+/* SYM - CHARACTER*1 */
+/* If SYM='S' or 'H', the generated matrix is symmetric, with */
+/* eigenvalues specified by D, COND, MODE, and DMAX; they */
+/* may be positive, negative, or zero. */
+/* If SYM='P', the generated matrix is symmetric, with */
+/* eigenvalues (= singular values) specified by D, COND, */
+/* MODE, and DMAX; they will not be negative. */
+/* If SYM='N', the generated matrix is nonsymmetric, with */
+/* singular values specified by D, COND, MODE, and DMAX; */
+/* they will not be negative. */
+/* Not modified. */
+
+/* D - REAL array, dimension ( MIN( M , N ) ) */
+/* This array is used to specify the singular values or */
+/* eigenvalues of A (see SYM, above.) If MODE=0, then D is */
+/* assumed to contain the singular/eigenvalues, otherwise */
+/* they will be computed according to MODE, COND, and DMAX, */
+/* and placed in D. */
+/* Modified if MODE is nonzero. */
+
+/* MODE - INTEGER */
+/* On entry this describes how the singular/eigenvalues are to */
+/* be specified: */
+/* MODE = 0 means use D as input */
+/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
+/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
+/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
+/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* MODE = 5 sets D to random numbers in the range */
+/* ( 1/COND , 1 ) such that their logarithms */
+/* are uniformly distributed. */
+/* MODE = 6 set D to random numbers from same distribution */
+/* as the rest of the matrix. */
+/* MODE < 0 has the same meaning as ABS(MODE), except that */
+/* the order of the elements of D is reversed. */
+/* Thus if MODE is positive, D has entries ranging from */
+/* 1 to 1/COND, if negative, from 1/COND to 1, */
+/* If SYM='S' or 'H', and MODE is neither 0, 6, nor -6, then */
+/* the elements of D will also be multiplied by a random */
+/* sign (i.e., +1 or -1.) */
+/* Not modified. */
+
+/* COND - REAL */
+/* On entry, this is used as described under MODE above. */
+/* If used, it must be >= 1. Not modified. */
+
+/* DMAX - REAL */
+/* If MODE is neither -6, 0 nor 6, the contents of D, as */
+/* computed according to MODE and COND, will be scaled by */
+/* DMAX / max(abs(D(i))); thus, the maximum absolute eigen- or */
+/* singular value (which is to say the norm) will be abs(DMAX). */
+/* Note that DMAX need not be positive: if DMAX is negative */
+/* (or zero), D will be scaled by a negative number (or zero). */
+/* Not modified. */
+
+/* KL - INTEGER */
+/* This specifies the lower bandwidth of the matrix. For */
+/* example, KL=0 implies upper triangular, KL=1 implies upper */
+/* Hessenberg, and KL being at least M-1 means that the matrix */
+/* has full lower bandwidth. KL must equal KU if the matrix */
+/* is symmetric. */
+/* Not modified. */
+
+/* KU - INTEGER */
+/* This specifies the upper bandwidth of the matrix. For */
+/* example, KU=0 implies lower triangular, KU=1 implies lower */
+/* Hessenberg, and KU being at least N-1 means that the matrix */
+/* has full upper bandwidth. KL must equal KU if the matrix */
+/* is symmetric. */
+/* Not modified. */
+
+/* PACK - CHARACTER*1 */
+/* This specifies packing of matrix as follows: */
+/* 'N' => no packing */
+/* 'U' => zero out all subdiagonal entries (if symmetric) */
+/* 'L' => zero out all superdiagonal entries (if symmetric) */
+/* 'C' => store the upper triangle columnwise */
+/* (only if the matrix is symmetric or upper triangular) */
+/* 'R' => store the lower triangle columnwise */
+/* (only if the matrix is symmetric or lower triangular) */
+/* 'B' => store the lower triangle in band storage scheme */
+/* (only if matrix symmetric or lower triangular) */
+/* 'Q' => store the upper triangle in band storage scheme */
+/* (only if matrix symmetric or upper triangular) */
+/* 'Z' => store the entire matrix in band storage scheme */
+/* (pivoting can be provided for by using this */
+/* option to store A in the trailing rows of */
+/* the allocated storage) */
+
+/* Using these options, the various LAPACK packed and banded */
+/* storage schemes can be obtained: */
+/* GB - use 'Z' */
+/* PB, SB or TB - use 'B' or 'Q' */
+/* PP, SP or TP - use 'C' or 'R' */
+
+/* If two calls to SLATMS differ only in the PACK parameter, */
+/* they will generate mathematically equivalent matrices. */
+/* Not modified. */
+
+/* A - REAL array, dimension ( LDA, N ) */
+/* On exit A is the desired test matrix. A is first generated */
+/* in full (unpacked) form, and then packed, if so specified */
+/* by PACK. Thus, the first M elements of the first N */
+/* columns will always be modified. If PACK specifies a */
+/* packed or banded storage scheme, all LDA elements of the */
+/* first N columns will be modified; the elements of the */
+/* array which do not correspond to elements of the generated */
+/* matrix are set to zero. */
+/* Modified. */
+
+/* LDA - INTEGER */
+/* LDA specifies the first dimension of A as declared in the */
+/* calling program. If PACK='N', 'U', 'L', 'C', or 'R', then */
+/* LDA must be at least M. If PACK='B' or 'Q', then LDA must */
+/* be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)). */
+/* If PACK='Z', LDA must be large enough to hold the packed */
+/* array: MIN( KU, N-1) + MIN( KL, M-1) + 1. */
+/* Not modified. */
+
+/* WORK - REAL array, dimension ( 3*MAX( N , M ) ) */
+/* Workspace. */
+/* Modified. */
+
+/* INFO - INTEGER */
+/* Error code. On exit, INFO will be set to one of the */
+/* following values: */
+/* 0 => normal return */
+/* -1 => M negative or unequal to N and SYM='S', 'H', or 'P' */
+/* -2 => N negative */
+/* -3 => DIST illegal string */
+/* -5 => SYM illegal string */
+/* -7 => MODE not in range -6 to 6 */
+/* -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */
+/* -10 => KL negative */
+/* -11 => KU negative, or SYM='S' or 'H' and KU not equal to KL */
+/* -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N'; */
+/* or PACK='C' or 'Q' and SYM='N' and KL is not zero; */
+/* or PACK='R' or 'B' and SYM='N' and KU is not zero; */
+/* or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not */
+/* N. */
+/* -14 => LDA is less than M, or PACK='Z' and LDA is less than */
+/* MIN(KU,N-1) + MIN(KL,M-1) + 1. */
+/* 1 => Error return from SLATM1 */
+/* 2 => Cannot scale to DMAX (max. sing. value is 0) */
+/* 3 => Error return from SLAGGE or SLAGSY */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Decode and Test the input parameters. */
+/* Initialize flags & seed. */
+
+ /* Parameter adjustments */
+ --iseed;
+ --d__;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Decode DIST */
+
+ if (lsame_(dist, "U")) {
+ idist = 1;
+ } else if (lsame_(dist, "S")) {
+ idist = 2;
+ } else if (lsame_(dist, "N")) {
+ idist = 3;
+ } else {
+ idist = -1;
+ }
+
+/* Decode SYM */
+
+ if (lsame_(sym, "N")) {
+ isym = 1;
+ irsign = 0;
+ } else if (lsame_(sym, "P")) {
+ isym = 2;
+ irsign = 0;
+ } else if (lsame_(sym, "S")) {
+ isym = 2;
+ irsign = 1;
+ } else if (lsame_(sym, "H")) {
+ isym = 2;
+ irsign = 1;
+ } else {
+ isym = -1;
+ }
+
+/* Decode PACK */
+
+ isympk = 0;
+ if (lsame_(pack, "N")) {
+ ipack = 0;
+ } else if (lsame_(pack, "U")) {
+ ipack = 1;
+ isympk = 1;
+ } else if (lsame_(pack, "L")) {
+ ipack = 2;
+ isympk = 1;
+ } else if (lsame_(pack, "C")) {
+ ipack = 3;
+ isympk = 2;
+ } else if (lsame_(pack, "R")) {
+ ipack = 4;
+ isympk = 3;
+ } else if (lsame_(pack, "B")) {
+ ipack = 5;
+ isympk = 3;
+ } else if (lsame_(pack, "Q")) {
+ ipack = 6;
+ isympk = 2;
+ } else if (lsame_(pack, "Z")) {
+ ipack = 7;
+ } else {
+ ipack = -1;
+ }
+
+/* Set certain internal parameters */
+
+ mnmin = min(*m,*n);
+/* Computing MIN */
+ i__1 = *kl, i__2 = *m - 1;
+ llb = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *ku, i__2 = *n - 1;
+ uub = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *m, i__2 = *n + llb;
+ mr = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *n, i__2 = *m + uub;
+ nc = min(i__1,i__2);
+
+ if (ipack == 5 || ipack == 6) {
+ minlda = uub + 1;
+ } else if (ipack == 7) {
+ minlda = llb + uub + 1;
+ } else {
+ minlda = *m;
+ }
+
+/* Use Givens rotation method if bandwidth small enough, */
+/* or if LDA is too small to store the matrix unpacked. */
+
+ givens = FALSE_;
+ if (isym == 1) {
+/* Computing MAX */
+ i__1 = 1, i__2 = mr + nc;
+ if ((real) (llb + uub) < (real) max(i__1,i__2) * .3f) {
+ givens = TRUE_;
+ }
+ } else {
+ if (llb << 1 < *m) {
+ givens = TRUE_;
+ }
+ }
+ if (*lda < *m && *lda >= minlda) {
+ givens = TRUE_;
+ }
+
+/* Set INFO if an error */
+
+ if (*m < 0) {
+ *info = -1;
+ } else if (*m != *n && isym != 1) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (idist == -1) {
+ *info = -3;
+ } else if (isym == -1) {
+ *info = -5;
+ } else if (abs(*mode) > 6) {
+ *info = -7;
+ } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.f) {
+ *info = -8;
+ } else if (*kl < 0) {
+ *info = -10;
+ } else if (*ku < 0 || isym != 1 && *kl != *ku) {
+ *info = -11;
+ } else if (ipack == -1 || isympk == 1 && isym == 1 || isympk == 2 && isym
+ == 1 && *kl > 0 || isympk == 3 && isym == 1 && *ku > 0 || isympk
+ != 0 && *m != *n) {
+ *info = -12;
+ } else if (*lda < max(1,minlda)) {
+ *info = -14;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLATMS", &i__1);
+ return 0;
+ }
+
+/* Initialize random number generator */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
+/* L10: */
+ }
+
+ if (iseed[4] % 2 != 1) {
+ ++iseed[4];
+ }
+
+/* 2) Set up D if indicated. */
+
+/* Compute D according to COND and MODE */
+
+ slatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, &iinfo);
+ if (iinfo != 0) {
+ *info = 1;
+ return 0;
+ }
+
+/* Choose Top-Down if D is (apparently) increasing, */
+/* Bottom-Up if D is (apparently) decreasing. */
+
+ if (dabs(d__[1]) <= (r__1 = d__[mnmin], dabs(r__1))) {
+ topdwn = TRUE_;
+ } else {
+ topdwn = FALSE_;
+ }
+
+ if (*mode != 0 && abs(*mode) != 6) {
+
+/* Scale by DMAX */
+
+ temp = dabs(d__[1]);
+ i__1 = mnmin;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = temp, r__3 = (r__1 = d__[i__], dabs(r__1));
+ temp = dmax(r__2,r__3);
+/* L20: */
+ }
+
+ if (temp > 0.f) {
+ alpha = *dmax__ / temp;
+ } else {
+ *info = 2;
+ return 0;
+ }
+
+ sscal_(&mnmin, &alpha, &d__[1], &c__1);
+
+ }
+
+/* 3) Generate Banded Matrix using Givens rotations. */
+/* Also the special case of UUB=LLB=0 */
+
+/* Compute Addressing constants to cover all */
+/* storage formats. Whether GE, SY, GB, or SB, */
+/* upper or lower triangle or both, */
+/* the (i,j)-th element is in */
+/* A( i - ISKEW*j + IOFFST, j ) */
+
+ if (ipack > 4) {
+ ilda = *lda - 1;
+ iskew = 1;
+ if (ipack > 5) {
+ ioffst = uub + 1;
+ } else {
+ ioffst = 1;
+ }
+ } else {
+ ilda = *lda;
+ iskew = 0;
+ ioffst = 0;
+ }
+
+/* IPACKG is the format that the matrix is generated in. If this is */
+/* different from IPACK, then the matrix must be repacked at the */
+/* end. It also signals how to compute the norm, for scaling. */
+
+ ipackg = 0;
+ slaset_("Full", lda, n, &c_b22, &c_b22, &a[a_offset], lda);
+
+/* Diagonal Matrix -- We are done, unless it */
+/* is to be stored SP/PP/TP (PACK='R' or 'C') */
+
+ if (llb == 0 && uub == 0) {
+ i__1 = ilda + 1;
+ scopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffst + a_dim1], &i__1)
+ ;
+ if (ipack <= 2 || ipack >= 5) {
+ ipackg = ipack;
+ }
+
+ } else if (givens) {
+
+/* Check whether to use Givens rotations, */
+/* Householder transformations, or nothing. */
+
+ if (isym == 1) {
+
+/* Non-symmetric -- A = U D V */
+
+ if (ipack > 4) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+
+ i__1 = ilda + 1;
+ scopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffst + a_dim1], &
+ i__1);
+
+ if (topdwn) {
+ jkl = 0;
+ i__1 = uub;
+ for (jku = 1; jku <= i__1; ++jku) {
+
+/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */
+
+/* Last row actually rotated is M */
+/* Last column actually rotated is MIN( M+JKU, N ) */
+
+/* Computing MIN */
+ i__3 = *m + jku;
+ i__2 = min(i__3,*n) + jkl - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ extra = 0.f;
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ c__ = cos(angle);
+ s = sin(angle);
+/* Computing MAX */
+ i__3 = 1, i__4 = jr - jkl;
+ icol = max(i__3,i__4);
+ if (jr < *m) {
+/* Computing MIN */
+ i__3 = *n, i__4 = jr + jku;
+ il = min(i__3,i__4) + 1 - icol;
+ L__1 = jr > jkl;
+ slarot_(&c_true, &L__1, &c_false, &il, &c__, &s, &
+ a[jr - iskew * icol + ioffst + icol *
+ a_dim1], &ilda, &extra, &dummy);
+ }
+
+/* Chase "EXTRA" back up */
+
+ ir = jr;
+ ic = icol;
+ i__3 = -jkl - jku;
+ for (jch = jr - jkl; i__3 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__3) {
+ if (ir < *m) {
+ slartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst
+ + (ic + 1) * a_dim1], &extra, &c__, &
+ s, &dummy);
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jku;
+ irow = max(i__4,i__5);
+ il = ir + 2 - irow;
+ temp = 0.f;
+ iltemp = jch > jku;
+ r__1 = -s;
+ slarot_(&c_false, &iltemp, &c_true, &il, &c__, &
+ r__1, &a[irow - iskew * ic + ioffst + ic *
+ a_dim1], &ilda, &temp, &extra);
+ if (iltemp) {
+ slartg_(&a[irow + 1 - iskew * (ic + 1) +
+ ioffst + (ic + 1) * a_dim1], &temp, &
+ c__, &s, &dummy);
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jku - jkl;
+ icol = max(i__4,i__5);
+ il = ic + 2 - icol;
+ extra = 0.f;
+ L__1 = jch > jku + jkl;
+ r__1 = -s;
+ slarot_(&c_true, &L__1, &c_true, &il, &c__, &
+ r__1, &a[irow - iskew * icol + ioffst
+ + icol * a_dim1], &ilda, &extra, &
+ temp);
+ ic = icol;
+ ir = irow;
+ }
+/* L30: */
+ }
+/* L40: */
+ }
+/* L50: */
+ }
+
+ jku = uub;
+ i__1 = llb;
+ for (jkl = 1; jkl <= i__1; ++jkl) {
+
+/* Transform from bandwidth JKL-1, JKU to JKL, JKU */
+
+/* Computing MIN */
+ i__3 = *n + jkl;
+ i__2 = min(i__3,*m) + jku - 1;
+ for (jc = 1; jc <= i__2; ++jc) {
+ extra = 0.f;
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ c__ = cos(angle);
+ s = sin(angle);
+/* Computing MAX */
+ i__3 = 1, i__4 = jc - jku;
+ irow = max(i__3,i__4);
+ if (jc < *n) {
+/* Computing MIN */
+ i__3 = *m, i__4 = jc + jkl;
+ il = min(i__3,i__4) + 1 - irow;
+ L__1 = jc > jku;
+ slarot_(&c_false, &L__1, &c_false, &il, &c__, &s,
+ &a[irow - iskew * jc + ioffst + jc *
+ a_dim1], &ilda, &extra, &dummy);
+ }
+
+/* Chase "EXTRA" back up */
+
+ ic = jc;
+ ir = irow;
+ i__3 = -jkl - jku;
+ for (jch = jc - jku; i__3 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__3) {
+ if (ic < *n) {
+ slartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst
+ + (ic + 1) * a_dim1], &extra, &c__, &
+ s, &dummy);
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jkl;
+ icol = max(i__4,i__5);
+ il = ic + 2 - icol;
+ temp = 0.f;
+ iltemp = jch > jkl;
+ r__1 = -s;
+ slarot_(&c_true, &iltemp, &c_true, &il, &c__, &
+ r__1, &a[ir - iskew * icol + ioffst +
+ icol * a_dim1], &ilda, &temp, &extra);
+ if (iltemp) {
+ slartg_(&a[ir + 1 - iskew * (icol + 1) +
+ ioffst + (icol + 1) * a_dim1], &temp,
+ &c__, &s, &dummy);
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jkl - jku;
+ irow = max(i__4,i__5);
+ il = ir + 2 - irow;
+ extra = 0.f;
+ L__1 = jch > jkl + jku;
+ r__1 = -s;
+ slarot_(&c_false, &L__1, &c_true, &il, &c__, &
+ r__1, &a[irow - iskew * icol + ioffst
+ + icol * a_dim1], &ilda, &extra, &
+ temp);
+ ic = icol;
+ ir = irow;
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+
+ } else {
+
+/* Bottom-Up -- Start at the bottom right. */
+
+ jkl = 0;
+ i__1 = uub;
+ for (jku = 1; jku <= i__1; ++jku) {
+
+/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */
+
+/* First row actually rotated is M */
+/* First column actually rotated is MIN( M+JKU, N ) */
+
+/* Computing MIN */
+ i__2 = *m, i__3 = *n + jkl;
+ iendch = min(i__2,i__3) - 1;
+/* Computing MIN */
+ i__2 = *m + jku;
+ i__3 = 1 - jkl;
+ for (jc = min(i__2,*n) - 1; jc >= i__3; --jc) {
+ extra = 0.f;
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ c__ = cos(angle);
+ s = sin(angle);
+/* Computing MAX */
+ i__2 = 1, i__4 = jc - jku + 1;
+ irow = max(i__2,i__4);
+ if (jc > 0) {
+/* Computing MIN */
+ i__2 = *m, i__4 = jc + jkl + 1;
+ il = min(i__2,i__4) + 1 - irow;
+ L__1 = jc + jkl < *m;
+ slarot_(&c_false, &c_false, &L__1, &il, &c__, &s,
+ &a[irow - iskew * jc + ioffst + jc *
+ a_dim1], &ilda, &dummy, &extra);
+ }
+
+/* Chase "EXTRA" back down */
+
+ ic = jc;
+ i__2 = iendch;
+ i__4 = jkl + jku;
+ for (jch = jc + jkl; i__4 < 0 ? jch >= i__2 : jch <=
+ i__2; jch += i__4) {
+ ilextr = ic > 0;
+ if (ilextr) {
+ slartg_(&a[jch - iskew * ic + ioffst + ic *
+ a_dim1], &extra, &c__, &s, &dummy);
+ }
+ ic = max(1,ic);
+/* Computing MIN */
+ i__5 = *n - 1, i__6 = jch + jku;
+ icol = min(i__5,i__6);
+ iltemp = jch + jku < *n;
+ temp = 0.f;
+ i__5 = icol + 2 - ic;
+ slarot_(&c_true, &ilextr, &iltemp, &i__5, &c__, &
+ s, &a[jch - iskew * ic + ioffst + ic *
+ a_dim1], &ilda, &extra, &temp);
+ if (iltemp) {
+ slartg_(&a[jch - iskew * icol + ioffst + icol
+ * a_dim1], &temp, &c__, &s, &dummy);
+/* Computing MIN */
+ i__5 = iendch, i__6 = jch + jkl + jku;
+ il = min(i__5,i__6) + 2 - jch;
+ extra = 0.f;
+ L__1 = jch + jkl + jku <= iendch;
+ slarot_(&c_false, &c_true, &L__1, &il, &c__, &
+ s, &a[jch - iskew * icol + ioffst +
+ icol * a_dim1], &ilda, &temp, &extra);
+ ic = icol;
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+/* L110: */
+ }
+
+ jku = uub;
+ i__1 = llb;
+ for (jkl = 1; jkl <= i__1; ++jkl) {
+
+/* Transform from bandwidth JKL-1, JKU to JKL, JKU */
+
+/* First row actually rotated is MIN( N+JKL, M ) */
+/* First column actually rotated is N */
+
+/* Computing MIN */
+ i__3 = *n, i__4 = *m + jku;
+ iendch = min(i__3,i__4) - 1;
+/* Computing MIN */
+ i__3 = *n + jkl;
+ i__4 = 1 - jku;
+ for (jr = min(i__3,*m) - 1; jr >= i__4; --jr) {
+ extra = 0.f;
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ c__ = cos(angle);
+ s = sin(angle);
+/* Computing MAX */
+ i__3 = 1, i__2 = jr - jkl + 1;
+ icol = max(i__3,i__2);
+ if (jr > 0) {
+/* Computing MIN */
+ i__3 = *n, i__2 = jr + jku + 1;
+ il = min(i__3,i__2) + 1 - icol;
+ L__1 = jr + jku < *n;
+ slarot_(&c_true, &c_false, &L__1, &il, &c__, &s, &
+ a[jr - iskew * icol + ioffst + icol *
+ a_dim1], &ilda, &dummy, &extra);
+ }
+
+/* Chase "EXTRA" back down */
+
+ ir = jr;
+ i__3 = iendch;
+ i__2 = jkl + jku;
+ for (jch = jr + jku; i__2 < 0 ? jch >= i__3 : jch <=
+ i__3; jch += i__2) {
+ ilextr = ir > 0;
+ if (ilextr) {
+ slartg_(&a[ir - iskew * jch + ioffst + jch *
+ a_dim1], &extra, &c__, &s, &dummy);
+ }
+ ir = max(1,ir);
+/* Computing MIN */
+ i__5 = *m - 1, i__6 = jch + jkl;
+ irow = min(i__5,i__6);
+ iltemp = jch + jkl < *m;
+ temp = 0.f;
+ i__5 = irow + 2 - ir;
+ slarot_(&c_false, &ilextr, &iltemp, &i__5, &c__, &
+ s, &a[ir - iskew * jch + ioffst + jch *
+ a_dim1], &ilda, &extra, &temp);
+ if (iltemp) {
+ slartg_(&a[irow - iskew * jch + ioffst + jch *
+ a_dim1], &temp, &c__, &s, &dummy);
+/* Computing MIN */
+ i__5 = iendch, i__6 = jch + jkl + jku;
+ il = min(i__5,i__6) + 2 - jch;
+ extra = 0.f;
+ L__1 = jch + jkl + jku <= iendch;
+ slarot_(&c_true, &c_true, &L__1, &il, &c__, &
+ s, &a[irow - iskew * jch + ioffst +
+ jch * a_dim1], &ilda, &temp, &extra);
+ ir = irow;
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+ }
+
+ } else {
+
+/* Symmetric -- A = U D U' */
+
+ ipackg = ipack;
+ ioffg = ioffst;
+
+ if (topdwn) {
+
+/* Top-Down -- Generate Upper triangle only */
+
+ if (ipack >= 5) {
+ ipackg = 6;
+ ioffg = uub + 1;
+ } else {
+ ipackg = 1;
+ }
+ i__1 = ilda + 1;
+ scopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffg + a_dim1],
+ &i__1);
+
+ i__1 = uub;
+ for (k = 1; k <= i__1; ++k) {
+ i__4 = *n - 1;
+ for (jc = 1; jc <= i__4; ++jc) {
+/* Computing MAX */
+ i__2 = 1, i__3 = jc - k;
+ irow = max(i__2,i__3);
+/* Computing MIN */
+ i__2 = jc + 1, i__3 = k + 2;
+ il = min(i__2,i__3);
+ extra = 0.f;
+ temp = a[jc - iskew * (jc + 1) + ioffg + (jc + 1) *
+ a_dim1];
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ c__ = cos(angle);
+ s = sin(angle);
+ L__1 = jc > k;
+ slarot_(&c_false, &L__1, &c_true, &il, &c__, &s, &a[
+ irow - iskew * jc + ioffg + jc * a_dim1], &
+ ilda, &extra, &temp);
+/* Computing MIN */
+ i__3 = k, i__5 = *n - jc;
+ i__2 = min(i__3,i__5) + 1;
+ slarot_(&c_true, &c_true, &c_false, &i__2, &c__, &s, &
+ a[(1 - iskew) * jc + ioffg + jc * a_dim1], &
+ ilda, &temp, &dummy);
+
+/* Chase EXTRA back up the matrix */
+
+ icol = jc;
+ i__2 = -k;
+ for (jch = jc - k; i__2 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__2) {
+ slartg_(&a[jch + 1 - iskew * (icol + 1) + ioffg +
+ (icol + 1) * a_dim1], &extra, &c__, &s, &
+ dummy);
+ temp = a[jch - iskew * (jch + 1) + ioffg + (jch +
+ 1) * a_dim1];
+ i__3 = k + 2;
+ r__1 = -s;
+ slarot_(&c_true, &c_true, &c_true, &i__3, &c__, &
+ r__1, &a[(1 - iskew) * jch + ioffg + jch *
+ a_dim1], &ilda, &temp, &extra);
+/* Computing MAX */
+ i__3 = 1, i__5 = jch - k;
+ irow = max(i__3,i__5);
+/* Computing MIN */
+ i__3 = jch + 1, i__5 = k + 2;
+ il = min(i__3,i__5);
+ extra = 0.f;
+ L__1 = jch > k;
+ r__1 = -s;
+ slarot_(&c_false, &L__1, &c_true, &il, &c__, &
+ r__1, &a[irow - iskew * jch + ioffg + jch
+ * a_dim1], &ilda, &extra, &temp);
+ icol = jch;
+/* L150: */
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+
+/* If we need lower triangle, copy from upper. Note that */
+/* the order of copying is chosen to work for 'q' -> 'b' */
+
+ if (ipack != ipackg && ipack != 3) {
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ irow = ioffst - iskew * jc;
+/* Computing MIN */
+ i__2 = *n, i__3 = jc + uub;
+ i__4 = min(i__2,i__3);
+ for (jr = jc; jr <= i__4; ++jr) {
+ a[jr + irow + jc * a_dim1] = a[jc - iskew * jr +
+ ioffg + jr * a_dim1];
+/* L180: */
+ }
+/* L190: */
+ }
+ if (ipack == 5) {
+ i__1 = *n;
+ for (jc = *n - uub + 1; jc <= i__1; ++jc) {
+ i__4 = uub + 1;
+ for (jr = *n + 2 - jc; jr <= i__4; ++jr) {
+ a[jr + jc * a_dim1] = 0.f;
+/* L200: */
+ }
+/* L210: */
+ }
+ }
+ if (ipackg == 6) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+ }
+ } else {
+
+/* Bottom-Up -- Generate Lower triangle only */
+
+ if (ipack >= 5) {
+ ipackg = 5;
+ if (ipack == 6) {
+ ioffg = 1;
+ }
+ } else {
+ ipackg = 2;
+ }
+ i__1 = ilda + 1;
+ scopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffg + a_dim1],
+ &i__1);
+
+ i__1 = uub;
+ for (k = 1; k <= i__1; ++k) {
+ for (jc = *n - 1; jc >= 1; --jc) {
+/* Computing MIN */
+ i__4 = *n + 1 - jc, i__2 = k + 2;
+ il = min(i__4,i__2);
+ extra = 0.f;
+ temp = a[(1 - iskew) * jc + 1 + ioffg + jc * a_dim1];
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ c__ = cos(angle);
+ s = -sin(angle);
+ L__1 = *n - jc > k;
+ slarot_(&c_false, &c_true, &L__1, &il, &c__, &s, &a[(
+ 1 - iskew) * jc + ioffg + jc * a_dim1], &ilda,
+ &temp, &extra);
+/* Computing MAX */
+ i__4 = 1, i__2 = jc - k + 1;
+ icol = max(i__4,i__2);
+ i__4 = jc + 2 - icol;
+ slarot_(&c_true, &c_false, &c_true, &i__4, &c__, &s, &
+ a[jc - iskew * icol + ioffg + icol * a_dim1],
+ &ilda, &dummy, &temp);
+
+/* Chase EXTRA back down the matrix */
+
+ icol = jc;
+ i__4 = *n - 1;
+ i__2 = k;
+ for (jch = jc + k; i__2 < 0 ? jch >= i__4 : jch <=
+ i__4; jch += i__2) {
+ slartg_(&a[jch - iskew * icol + ioffg + icol *
+ a_dim1], &extra, &c__, &s, &dummy);
+ temp = a[(1 - iskew) * jch + 1 + ioffg + jch *
+ a_dim1];
+ i__3 = k + 2;
+ slarot_(&c_true, &c_true, &c_true, &i__3, &c__, &
+ s, &a[jch - iskew * icol + ioffg + icol *
+ a_dim1], &ilda, &extra, &temp);
+/* Computing MIN */
+ i__3 = *n + 1 - jch, i__5 = k + 2;
+ il = min(i__3,i__5);
+ extra = 0.f;
+ L__1 = *n - jch > k;
+ slarot_(&c_false, &c_true, &L__1, &il, &c__, &s, &
+ a[(1 - iskew) * jch + ioffg + jch *
+ a_dim1], &ilda, &temp, &extra);
+ icol = jch;
+/* L220: */
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+
+/* If we need upper triangle, copy from lower. Note that */
+/* the order of copying is chosen to work for 'b' -> 'q' */
+
+ if (ipack != ipackg && ipack != 4) {
+ for (jc = *n; jc >= 1; --jc) {
+ irow = ioffst - iskew * jc;
+/* Computing MAX */
+ i__2 = 1, i__4 = jc - uub;
+ i__1 = max(i__2,i__4);
+ for (jr = jc; jr >= i__1; --jr) {
+ a[jr + irow + jc * a_dim1] = a[jc - iskew * jr +
+ ioffg + jr * a_dim1];
+/* L250: */
+ }
+/* L260: */
+ }
+ if (ipack == 6) {
+ i__1 = uub;
+ for (jc = 1; jc <= i__1; ++jc) {
+ i__2 = uub + 1 - jc;
+ for (jr = 1; jr <= i__2; ++jr) {
+ a[jr + jc * a_dim1] = 0.f;
+/* L270: */
+ }
+/* L280: */
+ }
+ }
+ if (ipackg == 5) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+ }
+ }
+ }
+
+ } else {
+
+/* 4) Generate Banded Matrix by first */
+/* Rotating by random Unitary matrices, */
+/* then reducing the bandwidth using Householder */
+/* transformations. */
+
+/* Note: we should get here only if LDA .ge. N */
+
+ if (isym == 1) {
+
+/* Non-symmetric -- A = U D V */
+
+ slagge_(&mr, &nc, &llb, &uub, &d__[1], &a[a_offset], lda, &iseed[
+ 1], &work[1], &iinfo);
+ } else {
+
+/* Symmetric -- A = U D U' */
+
+ slagsy_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[1],
+ &iinfo);
+
+ }
+ if (iinfo != 0) {
+ *info = 3;
+ return 0;
+ }
+ }
+
+/* 5) Pack the matrix */
+
+ if (ipack != ipackg) {
+ if (ipack == 1) {
+
+/* 'U' -- Upper triangular, not packed */
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L290: */
+ }
+/* L300: */
+ }
+
+ } else if (ipack == 2) {
+
+/* 'L' -- Lower triangular, not packed */
+
+ i__1 = *m;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L310: */
+ }
+/* L320: */
+ }
+
+ } else if (ipack == 3) {
+
+/* 'C' -- Upper triangle packed Columnwise. */
+
+ icol = 1;
+ irow = 0;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ++irow;
+ if (irow > *lda) {
+ irow = 1;
+ ++icol;
+ }
+ a[irow + icol * a_dim1] = a[i__ + j * a_dim1];
+/* L330: */
+ }
+/* L340: */
+ }
+
+ } else if (ipack == 4) {
+
+/* 'R' -- Lower triangle packed Columnwise. */
+
+ icol = 1;
+ irow = 0;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ++irow;
+ if (irow > *lda) {
+ irow = 1;
+ ++icol;
+ }
+ a[irow + icol * a_dim1] = a[i__ + j * a_dim1];
+/* L350: */
+ }
+/* L360: */
+ }
+
+ } else if (ipack >= 5) {
+
+/* 'B' -- The lower triangle is packed as a band matrix. */
+/* 'Q' -- The upper triangle is packed as a band matrix. */
+/* 'Z' -- The whole matrix is packed as a band matrix. */
+
+ if (ipack == 5) {
+ uub = 0;
+ }
+ if (ipack == 6) {
+ llb = 0;
+ }
+
+ i__1 = uub;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = j + llb;
+ for (i__ = min(i__2,*m); i__ >= 1; --i__) {
+ a[i__ - j + uub + 1 + j * a_dim1] = a[i__ + j * a_dim1];
+/* L370: */
+ }
+/* L380: */
+ }
+
+ i__1 = *n;
+ for (j = uub + 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = j + llb;
+ i__2 = min(i__4,*m);
+ for (i__ = j - uub; i__ <= i__2; ++i__) {
+ a[i__ - j + uub + 1 + j * a_dim1] = a[i__ + j * a_dim1];
+/* L390: */
+ }
+/* L400: */
+ }
+ }
+
+/* If packed, zero out extraneous elements. */
+
+/* Symmetric/Triangular Packed -- */
+/* zero out everything after A(IROW,ICOL) */
+
+ if (ipack == 3 || ipack == 4) {
+ i__1 = *m;
+ for (jc = icol; jc <= i__1; ++jc) {
+ i__2 = *lda;
+ for (jr = irow + 1; jr <= i__2; ++jr) {
+ a[jr + jc * a_dim1] = 0.f;
+/* L410: */
+ }
+ irow = 0;
+/* L420: */
+ }
+
+ } else if (ipack >= 5) {
+
+/* Packed Band -- */
+/* 1st row is now in A( UUB+2-j, j), zero above it */
+/* m-th row is now in A( M+UUB-j,j), zero below it */
+/* last non-zero diagonal is now in A( UUB+LLB+1,j ), */
+/* zero below it, too. */
+
+ ir1 = uub + llb + 2;
+ ir2 = uub + *m + 2;
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ i__2 = uub + 1 - jc;
+ for (jr = 1; jr <= i__2; ++jr) {
+ a[jr + jc * a_dim1] = 0.f;
+/* L430: */
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__3 = ir1, i__5 = ir2 - jc;
+ i__2 = 1, i__4 = min(i__3,i__5);
+ i__6 = *lda;
+ for (jr = max(i__2,i__4); jr <= i__6; ++jr) {
+ a[jr + jc * a_dim1] = 0.f;
+/* L440: */
+ }
+/* L450: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SLATMS */
+
+} /* slatms_ */
diff --git a/TESTING/MATGEN/slatmt.c b/TESTING/MATGEN/slatmt.c
new file mode 100644
index 0000000..5874792
--- /dev/null
+++ b/TESTING/MATGEN/slatmt.c
@@ -0,0 +1,1334 @@
+/* slatmt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b22 = 0.f;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int slatmt_(integer *m, integer *n, char *dist, integer *
+ iseed, char *sym, real *d__, integer *mode, real *cond, real *dmax__,
+ integer *rank, integer *kl, integer *ku, char *pack, real *a, integer
+ *lda, real *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ real r__1, r__2, r__3;
+ logical L__1;
+
+ /* Builtin functions */
+ double cos(doublereal), sin(doublereal);
+
+ /* Local variables */
+ real c__;
+ integer i__, j, k;
+ real s;
+ integer ic, jc, nc, il, ir, jr, mr, ir1, ir2, jch, llb, jkl, jku, uub,
+ ilda, icol;
+ real temp;
+ integer irow, isym;
+ real alpha, angle;
+ integer ipack, ioffg;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+ integer idist, mnmin, iskew;
+ real extra, dummy;
+ extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
+ integer *), slatm7_(integer *, real *, integer *, integer *,
+ integer *, real *, integer *, integer *, integer *);
+ integer iendch, ipackg;
+ extern /* Subroutine */ int slagge_(integer *, integer *, integer *,
+ integer *, real *, real *, integer *, integer *, real *, integer *
+);
+ integer minlda;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal slarnd_(integer *, integer *);
+ integer ioffst, irsign;
+ logical givens, iltemp;
+ extern /* Subroutine */ int slartg_(real *, real *, real *, real *, real *
+), slaset_(char *, integer *, integer *, real *, real *, real *,
+ integer *), slagsy_(integer *, integer *, real *, real *,
+ integer *, integer *, real *, integer *), slarot_(logical *,
+ logical *, logical *, integer *, real *, real *, real *, integer *
+, real *, real *);
+ logical ilextr, topdwn;
+ integer isympk;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* SLATMT generates random matrices with specified singular values */
+/* (or symmetric/hermitian with specified eigenvalues) */
+/* for testing LAPACK programs. */
+
+/* SLATMT operates by applying the following sequence of */
+/* operations: */
+
+/* Set the diagonal to D, where D may be input or */
+/* computed according to MODE, COND, DMAX, and SYM */
+/* as described below. */
+
+/* Generate a matrix with the appropriate band structure, by one */
+/* of two methods: */
+
+/* Method A: */
+/* Generate a dense M x N matrix by multiplying D on the left */
+/* and the right by random unitary matrices, then: */
+
+/* Reduce the bandwidth according to KL and KU, using */
+/* Householder transformations. */
+
+/* Method B: */
+/* Convert the bandwidth-0 (i.e., diagonal) matrix to a */
+/* bandwidth-1 matrix using Givens rotations, "chasing" */
+/* out-of-band elements back, much as in QR; then */
+/* convert the bandwidth-1 to a bandwidth-2 matrix, etc. */
+/* Note that for reasonably small bandwidths (relative to */
+/* M and N) this requires less storage, as a dense matrix */
+/* is not generated. Also, for symmetric matrices, only */
+/* one triangle is generated. */
+
+/* Method A is chosen if the bandwidth is a large fraction of the */
+/* order of the matrix, and LDA is at least M (so a dense */
+/* matrix can be stored.) Method B is chosen if the bandwidth */
+/* is small (< 1/2 N for symmetric, < .3 N+M for */
+/* non-symmetric), or LDA is less than M and not less than the */
+/* bandwidth. */
+
+/* Pack the matrix if desired. Options specified by PACK are: */
+/* no packing */
+/* zero out upper half (if symmetric) */
+/* zero out lower half (if symmetric) */
+/* store the upper half columnwise (if symmetric or upper */
+/* triangular) */
+/* store the lower half columnwise (if symmetric or lower */
+/* triangular) */
+/* store the lower triangle in banded format (if symmetric */
+/* or lower triangular) */
+/* store the upper triangle in banded format (if symmetric */
+/* or upper triangular) */
+/* store the entire matrix in banded format */
+/* If Method B is chosen, and band format is specified, then the */
+/* matrix will be generated in the band format, so no repacking */
+/* will be necessary. */
+
+/* Arguments */
+/* ========= */
+
+/* M - INTEGER */
+/* The number of rows of A. Not modified. */
+
+/* N - INTEGER */
+/* The number of columns of A. Not modified. */
+
+/* DIST - CHARACTER*1 */
+/* On entry, DIST specifies the type of distribution to be used */
+/* to generate the random eigen-/singular values. */
+/* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */
+/* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */
+/* 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension ( 4 ) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. They should lie between 0 and 4095 inclusive, */
+/* and ISEED(4) should be odd. The random number generator */
+/* uses a linear congruential sequence limited to small */
+/* integers, and so should produce machine independent */
+/* random numbers. The values of ISEED are changed on */
+/* exit, and can be used in the next call to SLATMT */
+/* to continue the same random number sequence. */
+/* Changed on exit. */
+
+/* SYM - CHARACTER*1 */
+/* If SYM='S' or 'H', the generated matrix is symmetric, with */
+/* eigenvalues specified by D, COND, MODE, and DMAX; they */
+/* may be positive, negative, or zero. */
+/* If SYM='P', the generated matrix is symmetric, with */
+/* eigenvalues (= singular values) specified by D, COND, */
+/* MODE, and DMAX; they will not be negative. */
+/* If SYM='N', the generated matrix is nonsymmetric, with */
+/* singular values specified by D, COND, MODE, and DMAX; */
+/* they will not be negative. */
+/* Not modified. */
+
+/* D - REAL array, dimension ( MIN( M , N ) ) */
+/* This array is used to specify the singular values or */
+/* eigenvalues of A (see SYM, above.) If MODE=0, then D is */
+/* assumed to contain the singular/eigenvalues, otherwise */
+/* they will be computed according to MODE, COND, and DMAX, */
+/* and placed in D. */
+/* Modified if MODE is nonzero. */
+
+/* MODE - INTEGER */
+/* On entry this describes how the singular/eigenvalues are to */
+/* be specified: */
+/* MODE = 0 means use D as input */
+
+/* MODE = 1 sets D(1)=1 and D(2:RANK)=1.0/COND */
+/* MODE = 2 sets D(1:RANK-1)=1 and D(RANK)=1.0/COND */
+/* MODE = 3 sets D(I)=COND**(-(I-1)/(RANK-1)) */
+
+/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* MODE = 5 sets D to random numbers in the range */
+/* ( 1/COND , 1 ) such that their logarithms */
+/* are uniformly distributed. */
+/* MODE = 6 set D to random numbers from same distribution */
+/* as the rest of the matrix. */
+/* MODE < 0 has the same meaning as ABS(MODE), except that */
+/* the order of the elements of D is reversed. */
+/* Thus if MODE is positive, D has entries ranging from */
+/* 1 to 1/COND, if negative, from 1/COND to 1, */
+/* If SYM='S' or 'H', and MODE is neither 0, 6, nor -6, then */
+/* the elements of D will also be multiplied by a random */
+/* sign (i.e., +1 or -1.) */
+/* Not modified. */
+
+/* COND - REAL */
+/* On entry, this is used as described under MODE above. */
+/* If used, it must be >= 1. Not modified. */
+
+/* DMAX - REAL */
+/* If MODE is neither -6, 0 nor 6, the contents of D, as */
+/* computed according to MODE and COND, will be scaled by */
+/* DMAX / max(abs(D(i))); thus, the maximum absolute eigen- or */
+/* singular value (which is to say the norm) will be abs(DMAX). */
+/* Note that DMAX need not be positive: if DMAX is negative */
+/* (or zero), D will be scaled by a negative number (or zero). */
+/* Not modified. */
+
+/* RANK - INTEGER */
+/* The rank of matrix to be generated for modes 1,2,3 only. */
+/* D( RANK+1:N ) = 0. */
+/* Not modified. */
+
+/* KL - INTEGER */
+/* This specifies the lower bandwidth of the matrix. For */
+/* example, KL=0 implies upper triangular, KL=1 implies upper */
+/* Hessenberg, and KL being at least M-1 means that the matrix */
+/* has full lower bandwidth. KL must equal KU if the matrix */
+/* is symmetric. */
+/* Not modified. */
+
+/* KU - INTEGER */
+/* This specifies the upper bandwidth of the matrix. For */
+/* example, KU=0 implies lower triangular, KU=1 implies lower */
+/* Hessenberg, and KU being at least N-1 means that the matrix */
+/* has full upper bandwidth. KL must equal KU if the matrix */
+/* is symmetric. */
+/* Not modified. */
+
+/* PACK - CHARACTER*1 */
+/* This specifies packing of matrix as follows: */
+/* 'N' => no packing */
+/* 'U' => zero out all subdiagonal entries (if symmetric) */
+/* 'L' => zero out all superdiagonal entries (if symmetric) */
+/* 'C' => store the upper triangle columnwise */
+/* (only if the matrix is symmetric or upper triangular) */
+/* 'R' => store the lower triangle columnwise */
+/* (only if the matrix is symmetric or lower triangular) */
+/* 'B' => store the lower triangle in band storage scheme */
+/* (only if matrix symmetric or lower triangular) */
+/* 'Q' => store the upper triangle in band storage scheme */
+/* (only if matrix symmetric or upper triangular) */
+/* 'Z' => store the entire matrix in band storage scheme */
+/* (pivoting can be provided for by using this */
+/* option to store A in the trailing rows of */
+/* the allocated storage) */
+
+/* Using these options, the various LAPACK packed and banded */
+/* storage schemes can be obtained: */
+/* GB - use 'Z' */
+/* PB, SB or TB - use 'B' or 'Q' */
+/* PP, SP or TP - use 'C' or 'R' */
+
+/* If two calls to SLATMT differ only in the PACK parameter, */
+/* they will generate mathematically equivalent matrices. */
+/* Not modified. */
+
+/* A - REAL array, dimension ( LDA, N ) */
+/* On exit A is the desired test matrix. A is first generated */
+/* in full (unpacked) form, and then packed, if so specified */
+/* by PACK. Thus, the first M elements of the first N */
+/* columns will always be modified. If PACK specifies a */
+/* packed or banded storage scheme, all LDA elements of the */
+/* first N columns will be modified; the elements of the */
+/* array which do not correspond to elements of the generated */
+/* matrix are set to zero. */
+/* Modified. */
+
+/* LDA - INTEGER */
+/* LDA specifies the first dimension of A as declared in the */
+/* calling program. If PACK='N', 'U', 'L', 'C', or 'R', then */
+/* LDA must be at least M. If PACK='B' or 'Q', then LDA must */
+/* be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)). */
+/* If PACK='Z', LDA must be large enough to hold the packed */
+/* array: MIN( KU, N-1) + MIN( KL, M-1) + 1. */
+/* Not modified. */
+
+/* WORK - REAL array, dimension ( 3*MAX( N , M ) ) */
+/* Workspace. */
+/* Modified. */
+
+/* INFO - INTEGER */
+/* Error code. On exit, INFO will be set to one of the */
+/* following values: */
+/* 0 => normal return */
+/* -1 => M negative or unequal to N and SYM='S', 'H', or 'P' */
+/* -2 => N negative */
+/* -3 => DIST illegal string */
+/* -5 => SYM illegal string */
+/* -7 => MODE not in range -6 to 6 */
+/* -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */
+/* -10 => KL negative */
+/* -11 => KU negative, or SYM='S' or 'H' and KU not equal to KL */
+/* -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N'; */
+/* or PACK='C' or 'Q' and SYM='N' and KL is not zero; */
+/* or PACK='R' or 'B' and SYM='N' and KU is not zero; */
+/* or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not */
+/* N. */
+/* -14 => LDA is less than M, or PACK='Z' and LDA is less than */
+/* MIN(KU,N-1) + MIN(KL,M-1) + 1. */
+/* 1 => Error return from SLATM7 */
+/* 2 => Cannot scale to DMAX (max. sing. value is 0) */
+/* 3 => Error return from SLAGGE or SLAGSY */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Decode and Test the input parameters. */
+/* Initialize flags & seed. */
+
+ /* Parameter adjustments */
+ --iseed;
+ --d__;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Decode DIST */
+
+ if (lsame_(dist, "U")) {
+ idist = 1;
+ } else if (lsame_(dist, "S")) {
+ idist = 2;
+ } else if (lsame_(dist, "N")) {
+ idist = 3;
+ } else {
+ idist = -1;
+ }
+
+/* Decode SYM */
+
+ if (lsame_(sym, "N")) {
+ isym = 1;
+ irsign = 0;
+ } else if (lsame_(sym, "P")) {
+ isym = 2;
+ irsign = 0;
+ } else if (lsame_(sym, "S")) {
+ isym = 2;
+ irsign = 1;
+ } else if (lsame_(sym, "H")) {
+ isym = 2;
+ irsign = 1;
+ } else {
+ isym = -1;
+ }
+
+/* Decode PACK */
+
+ isympk = 0;
+ if (lsame_(pack, "N")) {
+ ipack = 0;
+ } else if (lsame_(pack, "U")) {
+ ipack = 1;
+ isympk = 1;
+ } else if (lsame_(pack, "L")) {
+ ipack = 2;
+ isympk = 1;
+ } else if (lsame_(pack, "C")) {
+ ipack = 3;
+ isympk = 2;
+ } else if (lsame_(pack, "R")) {
+ ipack = 4;
+ isympk = 3;
+ } else if (lsame_(pack, "B")) {
+ ipack = 5;
+ isympk = 3;
+ } else if (lsame_(pack, "Q")) {
+ ipack = 6;
+ isympk = 2;
+ } else if (lsame_(pack, "Z")) {
+ ipack = 7;
+ } else {
+ ipack = -1;
+ }
+
+/* Set certain internal parameters */
+
+ mnmin = min(*m,*n);
+/* Computing MIN */
+ i__1 = *kl, i__2 = *m - 1;
+ llb = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *ku, i__2 = *n - 1;
+ uub = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *m, i__2 = *n + llb;
+ mr = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *n, i__2 = *m + uub;
+ nc = min(i__1,i__2);
+
+ if (ipack == 5 || ipack == 6) {
+ minlda = uub + 1;
+ } else if (ipack == 7) {
+ minlda = llb + uub + 1;
+ } else {
+ minlda = *m;
+ }
+
+/* Use Givens rotation method if bandwidth small enough, */
+/* or if LDA is too small to store the matrix unpacked. */
+
+ givens = FALSE_;
+ if (isym == 1) {
+/* Computing MAX */
+ i__1 = 1, i__2 = mr + nc;
+ if ((real) (llb + uub) < (real) max(i__1,i__2) * .3f) {
+ givens = TRUE_;
+ }
+ } else {
+ if (llb << 1 < *m) {
+ givens = TRUE_;
+ }
+ }
+ if (*lda < *m && *lda >= minlda) {
+ givens = TRUE_;
+ }
+
+/* Set INFO if an error */
+
+ if (*m < 0) {
+ *info = -1;
+ } else if (*m != *n && isym != 1) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (idist == -1) {
+ *info = -3;
+ } else if (isym == -1) {
+ *info = -5;
+ } else if (abs(*mode) > 6) {
+ *info = -7;
+ } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.f) {
+ *info = -8;
+ } else if (*kl < 0) {
+ *info = -10;
+ } else if (*ku < 0 || isym != 1 && *kl != *ku) {
+ *info = -11;
+ } else if (ipack == -1 || isympk == 1 && isym == 1 || isympk == 2 && isym
+ == 1 && *kl > 0 || isympk == 3 && isym == 1 && *ku > 0 || isympk
+ != 0 && *m != *n) {
+ *info = -12;
+ } else if (*lda < max(1,minlda)) {
+ *info = -14;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("SLATMT", &i__1);
+ return 0;
+ }
+
+/* Initialize random number generator */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
+/* L100: */
+ }
+
+ if (iseed[4] % 2 != 1) {
+ ++iseed[4];
+ }
+
+/* 2) Set up D if indicated. */
+
+/* Compute D according to COND and MODE */
+
+ slatm7_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, rank, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = 1;
+ return 0;
+ }
+
+/* Choose Top-Down if D is (apparently) increasing, */
+/* Bottom-Up if D is (apparently) decreasing. */
+
+ if (dabs(d__[1]) <= (r__1 = d__[*rank], dabs(r__1))) {
+ topdwn = TRUE_;
+ } else {
+ topdwn = FALSE_;
+ }
+
+ if (*mode != 0 && abs(*mode) != 6) {
+
+/* Scale by DMAX */
+
+ temp = dabs(d__[1]);
+ i__1 = *rank;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ r__2 = temp, r__3 = (r__1 = d__[i__], dabs(r__1));
+ temp = dmax(r__2,r__3);
+/* L110: */
+ }
+
+ if (temp > 0.f) {
+ alpha = *dmax__ / temp;
+ } else {
+ *info = 2;
+ return 0;
+ }
+
+ sscal_(rank, &alpha, &d__[1], &c__1);
+
+ }
+
+/* 3) Generate Banded Matrix using Givens rotations. */
+/* Also the special case of UUB=LLB=0 */
+
+/* Compute Addressing constants to cover all */
+/* storage formats. Whether GE, SY, GB, or SB, */
+/* upper or lower triangle or both, */
+/* the (i,j)-th element is in */
+/* A( i - ISKEW*j + IOFFST, j ) */
+
+ if (ipack > 4) {
+ ilda = *lda - 1;
+ iskew = 1;
+ if (ipack > 5) {
+ ioffst = uub + 1;
+ } else {
+ ioffst = 1;
+ }
+ } else {
+ ilda = *lda;
+ iskew = 0;
+ ioffst = 0;
+ }
+
+/* IPACKG is the format that the matrix is generated in. If this is */
+/* different from IPACK, then the matrix must be repacked at the */
+/* end. It also signals how to compute the norm, for scaling. */
+
+ ipackg = 0;
+ slaset_("Full", lda, n, &c_b22, &c_b22, &a[a_offset], lda);
+
+/* Diagonal Matrix -- We are done, unless it */
+/* is to be stored SP/PP/TP (PACK='R' or 'C') */
+
+ if (llb == 0 && uub == 0) {
+ i__1 = ilda + 1;
+ scopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffst + a_dim1], &i__1)
+ ;
+ if (ipack <= 2 || ipack >= 5) {
+ ipackg = ipack;
+ }
+
+ } else if (givens) {
+
+/* Check whether to use Givens rotations, */
+/* Householder transformations, or nothing. */
+
+ if (isym == 1) {
+
+/* Non-symmetric -- A = U D V */
+
+ if (ipack > 4) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+
+ i__1 = ilda + 1;
+ scopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffst + a_dim1], &
+ i__1);
+
+ if (topdwn) {
+ jkl = 0;
+ i__1 = uub;
+ for (jku = 1; jku <= i__1; ++jku) {
+
+/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */
+
+/* Last row actually rotated is M */
+/* Last column actually rotated is MIN( M+JKU, N ) */
+
+/* Computing MIN */
+ i__3 = *m + jku;
+ i__2 = min(i__3,*n) + jkl - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ extra = 0.f;
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ c__ = cos(angle);
+ s = sin(angle);
+/* Computing MAX */
+ i__3 = 1, i__4 = jr - jkl;
+ icol = max(i__3,i__4);
+ if (jr < *m) {
+/* Computing MIN */
+ i__3 = *n, i__4 = jr + jku;
+ il = min(i__3,i__4) + 1 - icol;
+ L__1 = jr > jkl;
+ slarot_(&c_true, &L__1, &c_false, &il, &c__, &s, &
+ a[jr - iskew * icol + ioffst + icol *
+ a_dim1], &ilda, &extra, &dummy);
+ }
+
+/* Chase "EXTRA" back up */
+
+ ir = jr;
+ ic = icol;
+ i__3 = -jkl - jku;
+ for (jch = jr - jkl; i__3 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__3) {
+ if (ir < *m) {
+ slartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst
+ + (ic + 1) * a_dim1], &extra, &c__, &
+ s, &dummy);
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jku;
+ irow = max(i__4,i__5);
+ il = ir + 2 - irow;
+ temp = 0.f;
+ iltemp = jch > jku;
+ r__1 = -s;
+ slarot_(&c_false, &iltemp, &c_true, &il, &c__, &
+ r__1, &a[irow - iskew * ic + ioffst + ic *
+ a_dim1], &ilda, &temp, &extra);
+ if (iltemp) {
+ slartg_(&a[irow + 1 - iskew * (ic + 1) +
+ ioffst + (ic + 1) * a_dim1], &temp, &
+ c__, &s, &dummy);
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jku - jkl;
+ icol = max(i__4,i__5);
+ il = ic + 2 - icol;
+ extra = 0.f;
+ L__1 = jch > jku + jkl;
+ r__1 = -s;
+ slarot_(&c_true, &L__1, &c_true, &il, &c__, &
+ r__1, &a[irow - iskew * icol + ioffst
+ + icol * a_dim1], &ilda, &extra, &
+ temp);
+ ic = icol;
+ ir = irow;
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+/* L140: */
+ }
+
+ jku = uub;
+ i__1 = llb;
+ for (jkl = 1; jkl <= i__1; ++jkl) {
+
+/* Transform from bandwidth JKL-1, JKU to JKL, JKU */
+
+/* Computing MIN */
+ i__3 = *n + jkl;
+ i__2 = min(i__3,*m) + jku - 1;
+ for (jc = 1; jc <= i__2; ++jc) {
+ extra = 0.f;
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ c__ = cos(angle);
+ s = sin(angle);
+/* Computing MAX */
+ i__3 = 1, i__4 = jc - jku;
+ irow = max(i__3,i__4);
+ if (jc < *n) {
+/* Computing MIN */
+ i__3 = *m, i__4 = jc + jkl;
+ il = min(i__3,i__4) + 1 - irow;
+ L__1 = jc > jku;
+ slarot_(&c_false, &L__1, &c_false, &il, &c__, &s,
+ &a[irow - iskew * jc + ioffst + jc *
+ a_dim1], &ilda, &extra, &dummy);
+ }
+
+/* Chase "EXTRA" back up */
+
+ ic = jc;
+ ir = irow;
+ i__3 = -jkl - jku;
+ for (jch = jc - jku; i__3 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__3) {
+ if (ic < *n) {
+ slartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst
+ + (ic + 1) * a_dim1], &extra, &c__, &
+ s, &dummy);
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jkl;
+ icol = max(i__4,i__5);
+ il = ic + 2 - icol;
+ temp = 0.f;
+ iltemp = jch > jkl;
+ r__1 = -s;
+ slarot_(&c_true, &iltemp, &c_true, &il, &c__, &
+ r__1, &a[ir - iskew * icol + ioffst +
+ icol * a_dim1], &ilda, &temp, &extra);
+ if (iltemp) {
+ slartg_(&a[ir + 1 - iskew * (icol + 1) +
+ ioffst + (icol + 1) * a_dim1], &temp,
+ &c__, &s, &dummy);
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jkl - jku;
+ irow = max(i__4,i__5);
+ il = ir + 2 - irow;
+ extra = 0.f;
+ L__1 = jch > jkl + jku;
+ r__1 = -s;
+ slarot_(&c_false, &L__1, &c_true, &il, &c__, &
+ r__1, &a[irow - iskew * icol + ioffst
+ + icol * a_dim1], &ilda, &extra, &
+ temp);
+ ic = icol;
+ ir = irow;
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+
+ } else {
+
+/* Bottom-Up -- Start at the bottom right. */
+
+ jkl = 0;
+ i__1 = uub;
+ for (jku = 1; jku <= i__1; ++jku) {
+
+/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */
+
+/* First row actually rotated is M */
+/* First column actually rotated is MIN( M+JKU, N ) */
+
+/* Computing MIN */
+ i__2 = *m, i__3 = *n + jkl;
+ iendch = min(i__2,i__3) - 1;
+/* Computing MIN */
+ i__2 = *m + jku;
+ i__3 = 1 - jkl;
+ for (jc = min(i__2,*n) - 1; jc >= i__3; --jc) {
+ extra = 0.f;
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ c__ = cos(angle);
+ s = sin(angle);
+/* Computing MAX */
+ i__2 = 1, i__4 = jc - jku + 1;
+ irow = max(i__2,i__4);
+ if (jc > 0) {
+/* Computing MIN */
+ i__2 = *m, i__4 = jc + jkl + 1;
+ il = min(i__2,i__4) + 1 - irow;
+ L__1 = jc + jkl < *m;
+ slarot_(&c_false, &c_false, &L__1, &il, &c__, &s,
+ &a[irow - iskew * jc + ioffst + jc *
+ a_dim1], &ilda, &dummy, &extra);
+ }
+
+/* Chase "EXTRA" back down */
+
+ ic = jc;
+ i__2 = iendch;
+ i__4 = jkl + jku;
+ for (jch = jc + jkl; i__4 < 0 ? jch >= i__2 : jch <=
+ i__2; jch += i__4) {
+ ilextr = ic > 0;
+ if (ilextr) {
+ slartg_(&a[jch - iskew * ic + ioffst + ic *
+ a_dim1], &extra, &c__, &s, &dummy);
+ }
+ ic = max(1,ic);
+/* Computing MIN */
+ i__5 = *n - 1, i__6 = jch + jku;
+ icol = min(i__5,i__6);
+ iltemp = jch + jku < *n;
+ temp = 0.f;
+ i__5 = icol + 2 - ic;
+ slarot_(&c_true, &ilextr, &iltemp, &i__5, &c__, &
+ s, &a[jch - iskew * ic + ioffst + ic *
+ a_dim1], &ilda, &extra, &temp);
+ if (iltemp) {
+ slartg_(&a[jch - iskew * icol + ioffst + icol
+ * a_dim1], &temp, &c__, &s, &dummy);
+/* Computing MIN */
+ i__5 = iendch, i__6 = jch + jkl + jku;
+ il = min(i__5,i__6) + 2 - jch;
+ extra = 0.f;
+ L__1 = jch + jkl + jku <= iendch;
+ slarot_(&c_false, &c_true, &L__1, &il, &c__, &
+ s, &a[jch - iskew * icol + ioffst +
+ icol * a_dim1], &ilda, &temp, &extra);
+ ic = icol;
+ }
+/* L180: */
+ }
+/* L190: */
+ }
+/* L200: */
+ }
+
+ jku = uub;
+ i__1 = llb;
+ for (jkl = 1; jkl <= i__1; ++jkl) {
+
+/* Transform from bandwidth JKL-1, JKU to JKL, JKU */
+
+/* First row actually rotated is MIN( N+JKL, M ) */
+/* First column actually rotated is N */
+
+/* Computing MIN */
+ i__3 = *n, i__4 = *m + jku;
+ iendch = min(i__3,i__4) - 1;
+/* Computing MIN */
+ i__3 = *n + jkl;
+ i__4 = 1 - jku;
+ for (jr = min(i__3,*m) - 1; jr >= i__4; --jr) {
+ extra = 0.f;
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ c__ = cos(angle);
+ s = sin(angle);
+/* Computing MAX */
+ i__3 = 1, i__2 = jr - jkl + 1;
+ icol = max(i__3,i__2);
+ if (jr > 0) {
+/* Computing MIN */
+ i__3 = *n, i__2 = jr + jku + 1;
+ il = min(i__3,i__2) + 1 - icol;
+ L__1 = jr + jku < *n;
+ slarot_(&c_true, &c_false, &L__1, &il, &c__, &s, &
+ a[jr - iskew * icol + ioffst + icol *
+ a_dim1], &ilda, &dummy, &extra);
+ }
+
+/* Chase "EXTRA" back down */
+
+ ir = jr;
+ i__3 = iendch;
+ i__2 = jkl + jku;
+ for (jch = jr + jku; i__2 < 0 ? jch >= i__3 : jch <=
+ i__3; jch += i__2) {
+ ilextr = ir > 0;
+ if (ilextr) {
+ slartg_(&a[ir - iskew * jch + ioffst + jch *
+ a_dim1], &extra, &c__, &s, &dummy);
+ }
+ ir = max(1,ir);
+/* Computing MIN */
+ i__5 = *m - 1, i__6 = jch + jkl;
+ irow = min(i__5,i__6);
+ iltemp = jch + jkl < *m;
+ temp = 0.f;
+ i__5 = irow + 2 - ir;
+ slarot_(&c_false, &ilextr, &iltemp, &i__5, &c__, &
+ s, &a[ir - iskew * jch + ioffst + jch *
+ a_dim1], &ilda, &extra, &temp);
+ if (iltemp) {
+ slartg_(&a[irow - iskew * jch + ioffst + jch *
+ a_dim1], &temp, &c__, &s, &dummy);
+/* Computing MIN */
+ i__5 = iendch, i__6 = jch + jkl + jku;
+ il = min(i__5,i__6) + 2 - jch;
+ extra = 0.f;
+ L__1 = jch + jkl + jku <= iendch;
+ slarot_(&c_true, &c_true, &L__1, &il, &c__, &
+ s, &a[irow - iskew * jch + ioffst +
+ jch * a_dim1], &ilda, &temp, &extra);
+ ir = irow;
+ }
+/* L210: */
+ }
+/* L220: */
+ }
+/* L230: */
+ }
+ }
+
+ } else {
+
+/* Symmetric -- A = U D U' */
+
+ ipackg = ipack;
+ ioffg = ioffst;
+
+ if (topdwn) {
+
+/* Top-Down -- Generate Upper triangle only */
+
+ if (ipack >= 5) {
+ ipackg = 6;
+ ioffg = uub + 1;
+ } else {
+ ipackg = 1;
+ }
+ i__1 = ilda + 1;
+ scopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffg + a_dim1],
+ &i__1);
+
+ i__1 = uub;
+ for (k = 1; k <= i__1; ++k) {
+ i__4 = *n - 1;
+ for (jc = 1; jc <= i__4; ++jc) {
+/* Computing MAX */
+ i__2 = 1, i__3 = jc - k;
+ irow = max(i__2,i__3);
+/* Computing MIN */
+ i__2 = jc + 1, i__3 = k + 2;
+ il = min(i__2,i__3);
+ extra = 0.f;
+ temp = a[jc - iskew * (jc + 1) + ioffg + (jc + 1) *
+ a_dim1];
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ c__ = cos(angle);
+ s = sin(angle);
+ L__1 = jc > k;
+ slarot_(&c_false, &L__1, &c_true, &il, &c__, &s, &a[
+ irow - iskew * jc + ioffg + jc * a_dim1], &
+ ilda, &extra, &temp);
+/* Computing MIN */
+ i__3 = k, i__5 = *n - jc;
+ i__2 = min(i__3,i__5) + 1;
+ slarot_(&c_true, &c_true, &c_false, &i__2, &c__, &s, &
+ a[(1 - iskew) * jc + ioffg + jc * a_dim1], &
+ ilda, &temp, &dummy);
+
+/* Chase EXTRA back up the matrix */
+
+ icol = jc;
+ i__2 = -k;
+ for (jch = jc - k; i__2 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__2) {
+ slartg_(&a[jch + 1 - iskew * (icol + 1) + ioffg +
+ (icol + 1) * a_dim1], &extra, &c__, &s, &
+ dummy);
+ temp = a[jch - iskew * (jch + 1) + ioffg + (jch +
+ 1) * a_dim1];
+ i__3 = k + 2;
+ r__1 = -s;
+ slarot_(&c_true, &c_true, &c_true, &i__3, &c__, &
+ r__1, &a[(1 - iskew) * jch + ioffg + jch *
+ a_dim1], &ilda, &temp, &extra);
+/* Computing MAX */
+ i__3 = 1, i__5 = jch - k;
+ irow = max(i__3,i__5);
+/* Computing MIN */
+ i__3 = jch + 1, i__5 = k + 2;
+ il = min(i__3,i__5);
+ extra = 0.f;
+ L__1 = jch > k;
+ r__1 = -s;
+ slarot_(&c_false, &L__1, &c_true, &il, &c__, &
+ r__1, &a[irow - iskew * jch + ioffg + jch
+ * a_dim1], &ilda, &extra, &temp);
+ icol = jch;
+/* L240: */
+ }
+/* L250: */
+ }
+/* L260: */
+ }
+
+/* If we need lower triangle, copy from upper. Note that */
+/* the order of copying is chosen to work for 'q' -> 'b' */
+
+ if (ipack != ipackg && ipack != 3) {
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ irow = ioffst - iskew * jc;
+/* Computing MIN */
+ i__2 = *n, i__3 = jc + uub;
+ i__4 = min(i__2,i__3);
+ for (jr = jc; jr <= i__4; ++jr) {
+ a[jr + irow + jc * a_dim1] = a[jc - iskew * jr +
+ ioffg + jr * a_dim1];
+/* L270: */
+ }
+/* L280: */
+ }
+ if (ipack == 5) {
+ i__1 = *n;
+ for (jc = *n - uub + 1; jc <= i__1; ++jc) {
+ i__4 = uub + 1;
+ for (jr = *n + 2 - jc; jr <= i__4; ++jr) {
+ a[jr + jc * a_dim1] = 0.f;
+/* L290: */
+ }
+/* L300: */
+ }
+ }
+ if (ipackg == 6) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+ }
+ } else {
+
+/* Bottom-Up -- Generate Lower triangle only */
+
+ if (ipack >= 5) {
+ ipackg = 5;
+ if (ipack == 6) {
+ ioffg = 1;
+ }
+ } else {
+ ipackg = 2;
+ }
+ i__1 = ilda + 1;
+ scopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffg + a_dim1],
+ &i__1);
+
+ i__1 = uub;
+ for (k = 1; k <= i__1; ++k) {
+ for (jc = *n - 1; jc >= 1; --jc) {
+/* Computing MIN */
+ i__4 = *n + 1 - jc, i__2 = k + 2;
+ il = min(i__4,i__2);
+ extra = 0.f;
+ temp = a[(1 - iskew) * jc + 1 + ioffg + jc * a_dim1];
+ angle = slarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663f;
+ c__ = cos(angle);
+ s = -sin(angle);
+ L__1 = *n - jc > k;
+ slarot_(&c_false, &c_true, &L__1, &il, &c__, &s, &a[(
+ 1 - iskew) * jc + ioffg + jc * a_dim1], &ilda,
+ &temp, &extra);
+/* Computing MAX */
+ i__4 = 1, i__2 = jc - k + 1;
+ icol = max(i__4,i__2);
+ i__4 = jc + 2 - icol;
+ slarot_(&c_true, &c_false, &c_true, &i__4, &c__, &s, &
+ a[jc - iskew * icol + ioffg + icol * a_dim1],
+ &ilda, &dummy, &temp);
+
+/* Chase EXTRA back down the matrix */
+
+ icol = jc;
+ i__4 = *n - 1;
+ i__2 = k;
+ for (jch = jc + k; i__2 < 0 ? jch >= i__4 : jch <=
+ i__4; jch += i__2) {
+ slartg_(&a[jch - iskew * icol + ioffg + icol *
+ a_dim1], &extra, &c__, &s, &dummy);
+ temp = a[(1 - iskew) * jch + 1 + ioffg + jch *
+ a_dim1];
+ i__3 = k + 2;
+ slarot_(&c_true, &c_true, &c_true, &i__3, &c__, &
+ s, &a[jch - iskew * icol + ioffg + icol *
+ a_dim1], &ilda, &extra, &temp);
+/* Computing MIN */
+ i__3 = *n + 1 - jch, i__5 = k + 2;
+ il = min(i__3,i__5);
+ extra = 0.f;
+ L__1 = *n - jch > k;
+ slarot_(&c_false, &c_true, &L__1, &il, &c__, &s, &
+ a[(1 - iskew) * jch + ioffg + jch *
+ a_dim1], &ilda, &temp, &extra);
+ icol = jch;
+/* L310: */
+ }
+/* L320: */
+ }
+/* L330: */
+ }
+
+/* If we need upper triangle, copy from lower. Note that */
+/* the order of copying is chosen to work for 'b' -> 'q' */
+
+ if (ipack != ipackg && ipack != 4) {
+ for (jc = *n; jc >= 1; --jc) {
+ irow = ioffst - iskew * jc;
+/* Computing MAX */
+ i__2 = 1, i__4 = jc - uub;
+ i__1 = max(i__2,i__4);
+ for (jr = jc; jr >= i__1; --jr) {
+ a[jr + irow + jc * a_dim1] = a[jc - iskew * jr +
+ ioffg + jr * a_dim1];
+/* L340: */
+ }
+/* L350: */
+ }
+ if (ipack == 6) {
+ i__1 = uub;
+ for (jc = 1; jc <= i__1; ++jc) {
+ i__2 = uub + 1 - jc;
+ for (jr = 1; jr <= i__2; ++jr) {
+ a[jr + jc * a_dim1] = 0.f;
+/* L360: */
+ }
+/* L370: */
+ }
+ }
+ if (ipackg == 5) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+ }
+ }
+ }
+
+ } else {
+
+/* 4) Generate Banded Matrix by first */
+/* Rotating by random Unitary matrices, */
+/* then reducing the bandwidth using Householder */
+/* transformations. */
+
+/* Note: we should get here only if LDA .ge. N */
+
+ if (isym == 1) {
+
+/* Non-symmetric -- A = U D V */
+
+ slagge_(&mr, &nc, &llb, &uub, &d__[1], &a[a_offset], lda, &iseed[
+ 1], &work[1], &iinfo);
+ } else {
+
+/* Symmetric -- A = U D U' */
+
+ slagsy_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[1],
+ &iinfo);
+
+ }
+ if (iinfo != 0) {
+ *info = 3;
+ return 0;
+ }
+ }
+
+/* 5) Pack the matrix */
+
+ if (ipack != ipackg) {
+ if (ipack == 1) {
+
+/* 'U' -- Upper triangular, not packed */
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L380: */
+ }
+/* L390: */
+ }
+
+ } else if (ipack == 2) {
+
+/* 'L' -- Lower triangular, not packed */
+
+ i__1 = *m;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + j * a_dim1] = 0.f;
+/* L400: */
+ }
+/* L410: */
+ }
+
+ } else if (ipack == 3) {
+
+/* 'C' -- Upper triangle packed Columnwise. */
+
+ icol = 1;
+ irow = 0;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ++irow;
+ if (irow > *lda) {
+ irow = 1;
+ ++icol;
+ }
+ a[irow + icol * a_dim1] = a[i__ + j * a_dim1];
+/* L420: */
+ }
+/* L430: */
+ }
+
+ } else if (ipack == 4) {
+
+/* 'R' -- Lower triangle packed Columnwise. */
+
+ icol = 1;
+ irow = 0;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ++irow;
+ if (irow > *lda) {
+ irow = 1;
+ ++icol;
+ }
+ a[irow + icol * a_dim1] = a[i__ + j * a_dim1];
+/* L440: */
+ }
+/* L450: */
+ }
+
+ } else if (ipack >= 5) {
+
+/* 'B' -- The lower triangle is packed as a band matrix. */
+/* 'Q' -- The upper triangle is packed as a band matrix. */
+/* 'Z' -- The whole matrix is packed as a band matrix. */
+
+ if (ipack == 5) {
+ uub = 0;
+ }
+ if (ipack == 6) {
+ llb = 0;
+ }
+
+ i__1 = uub;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = j + llb;
+ for (i__ = min(i__2,*m); i__ >= 1; --i__) {
+ a[i__ - j + uub + 1 + j * a_dim1] = a[i__ + j * a_dim1];
+/* L460: */
+ }
+/* L470: */
+ }
+
+ i__1 = *n;
+ for (j = uub + 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = j + llb;
+ i__2 = min(i__4,*m);
+ for (i__ = j - uub; i__ <= i__2; ++i__) {
+ a[i__ - j + uub + 1 + j * a_dim1] = a[i__ + j * a_dim1];
+/* L480: */
+ }
+/* L490: */
+ }
+ }
+
+/* If packed, zero out extraneous elements. */
+
+/* Symmetric/Triangular Packed -- */
+/* zero out everything after A(IROW,ICOL) */
+
+ if (ipack == 3 || ipack == 4) {
+ i__1 = *m;
+ for (jc = icol; jc <= i__1; ++jc) {
+ i__2 = *lda;
+ for (jr = irow + 1; jr <= i__2; ++jr) {
+ a[jr + jc * a_dim1] = 0.f;
+/* L500: */
+ }
+ irow = 0;
+/* L510: */
+ }
+
+ } else if (ipack >= 5) {
+
+/* Packed Band -- */
+/* 1st row is now in A( UUB+2-j, j), zero above it */
+/* m-th row is now in A( M+UUB-j,j), zero below it */
+/* last non-zero diagonal is now in A( UUB+LLB+1,j ), */
+/* zero below it, too. */
+
+ ir1 = uub + llb + 2;
+ ir2 = uub + *m + 2;
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ i__2 = uub + 1 - jc;
+ for (jr = 1; jr <= i__2; ++jr) {
+ a[jr + jc * a_dim1] = 0.f;
+/* L520: */
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__3 = ir1, i__5 = ir2 - jc;
+ i__2 = 1, i__4 = min(i__3,i__5);
+ i__6 = *lda;
+ for (jr = max(i__2,i__4); jr <= i__6; ++jr) {
+ a[jr + jc * a_dim1] = 0.f;
+/* L530: */
+ }
+/* L540: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of SLATMT */
+
+} /* slatmt_ */
diff --git a/TESTING/MATGEN/zlagge.c b/TESTING/MATGEN/zlagge.c
new file mode 100644
index 0000000..306b994
--- /dev/null
+++ b/TESTING/MATGEN/zlagge.c
@@ -0,0 +1,479 @@
+/* zlagge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__3 = 3;
+static integer c__1 = 1;
+
+/* Subroutine */ int zlagge_(integer *m, integer *n, integer *kl, integer *ku,
+ doublereal *d__, doublecomplex *a, integer *lda, integer *iseed,
+ doublecomplex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublecomplex wa, wb;
+ doublereal wn;
+ doublecomplex tau;
+ extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), zlacgv_(
+ integer *, doublecomplex *, integer *), zlarnv_(integer *,
+ integer *, integer *, doublecomplex *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAGGE generates a complex general m by n matrix A, by pre- and post- */
+/* multiplying a real diagonal matrix D with random unitary matrices: */
+/* A = U*D*V. The lower and upper bandwidths may then be reduced to */
+/* kl and ku by additional unitary transformations. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* The number of rows of the matrix A. M >= 0. */
+
+/* N (input) INTEGER */
+/* The number of columns of the matrix A. N >= 0. */
+
+/* KL (input) INTEGER */
+/* The number of nonzero subdiagonals within the band of A. */
+/* 0 <= KL <= M-1. */
+
+/* KU (input) INTEGER */
+/* The number of nonzero superdiagonals within the band of A. */
+/* 0 <= KU <= N-1. */
+
+/* D (input) DOUBLE PRECISION array, dimension (min(M,N)) */
+/* The diagonal elements of the diagonal matrix D. */
+
+/* A (output) COMPLEX*16 array, dimension (LDA,N) */
+/* The generated m by n matrix A. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= M. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (M+N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --d__;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iseed;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*m < 0) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (*kl < 0 || *kl > *m - 1) {
+ *info = -3;
+ } else if (*ku < 0 || *ku > *n - 1) {
+ *info = -4;
+ } else if (*lda < max(1,*m)) {
+ *info = -7;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("ZLAGGE", &i__1);
+ return 0;
+ }
+
+/* initialize A to diagonal matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ i__1 = min(*m,*n);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ i__3 = i__;
+ a[i__2].r = d__[i__3], a[i__2].i = 0.;
+/* L30: */
+ }
+
+/* pre- and post-multiply A by random unitary matrices */
+
+ for (i__ = min(*m,*n); i__ >= 1; --i__) {
+ if (i__ < *m) {
+
+/* generate random reflection */
+
+ i__1 = *m - i__ + 1;
+ zlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+ i__1 = *m - i__ + 1;
+ wn = dznrm2_(&i__1, &work[1], &c__1);
+ d__1 = wn / z_abs(&work[1]);
+ z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i;
+ wa.r = z__1.r, wa.i = z__1.i;
+ if (wn == 0.) {
+ tau.r = 0., tau.i = 0.;
+ } else {
+ z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i;
+ wb.r = z__1.r, wb.i = z__1.i;
+ i__1 = *m - i__;
+ z_div(&z__1, &c_b2, &wb);
+ zscal_(&i__1, &z__1, &work[2], &c__1);
+ work[1].r = 1., work[1].i = 0.;
+ z_div(&z__1, &wb, &wa);
+ d__1 = z__1.r;
+ tau.r = d__1, tau.i = 0.;
+ }
+
+/* multiply A(i:m,i:n) by random reflection from the left */
+
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__ + 1;
+ zgemv_("Conjugate transpose", &i__1, &i__2, &c_b2, &a[i__ + i__ *
+ a_dim1], lda, &work[1], &c__1, &c_b1, &work[*m + 1], &
+ c__1);
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__ + 1;
+ z__1.r = -tau.r, z__1.i = -tau.i;
+ zgerc_(&i__1, &i__2, &z__1, &work[1], &c__1, &work[*m + 1], &c__1,
+ &a[i__ + i__ * a_dim1], lda);
+ }
+ if (i__ < *n) {
+
+/* generate random reflection */
+
+ i__1 = *n - i__ + 1;
+ zlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+ i__1 = *n - i__ + 1;
+ wn = dznrm2_(&i__1, &work[1], &c__1);
+ d__1 = wn / z_abs(&work[1]);
+ z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i;
+ wa.r = z__1.r, wa.i = z__1.i;
+ if (wn == 0.) {
+ tau.r = 0., tau.i = 0.;
+ } else {
+ z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i;
+ wb.r = z__1.r, wb.i = z__1.i;
+ i__1 = *n - i__;
+ z_div(&z__1, &c_b2, &wb);
+ zscal_(&i__1, &z__1, &work[2], &c__1);
+ work[1].r = 1., work[1].i = 0.;
+ z_div(&z__1, &wb, &wa);
+ d__1 = z__1.r;
+ tau.r = d__1, tau.i = 0.;
+ }
+
+/* multiply A(i:m,i:n) by random reflection from the right */
+
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__ + 1;
+ zgemv_("No transpose", &i__1, &i__2, &c_b2, &a[i__ + i__ * a_dim1]
+, lda, &work[1], &c__1, &c_b1, &work[*n + 1], &c__1);
+ i__1 = *m - i__ + 1;
+ i__2 = *n - i__ + 1;
+ z__1.r = -tau.r, z__1.i = -tau.i;
+ zgerc_(&i__1, &i__2, &z__1, &work[*n + 1], &c__1, &work[1], &c__1,
+ &a[i__ + i__ * a_dim1], lda);
+ }
+/* L40: */
+ }
+
+/* Reduce number of subdiagonals to KL and number of superdiagonals */
+/* to KU */
+
+/* Computing MAX */
+ i__2 = *m - 1 - *kl, i__3 = *n - 1 - *ku;
+ i__1 = max(i__2,i__3);
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (*kl <= *ku) {
+
+/* annihilate subdiagonal elements first (necessary if KL = 0) */
+
+/* Computing MIN */
+ i__2 = *m - 1 - *kl;
+ if (i__ <= min(i__2,*n)) {
+
+/* generate reflection to annihilate A(kl+i+1:m,i) */
+
+ i__2 = *m - *kl - i__ + 1;
+ wn = dznrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
+ d__1 = wn / z_abs(&a[*kl + i__ + i__ * a_dim1]);
+ i__2 = *kl + i__ + i__ * a_dim1;
+ z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
+ wa.r = z__1.r, wa.i = z__1.i;
+ if (wn == 0.) {
+ tau.r = 0., tau.i = 0.;
+ } else {
+ i__2 = *kl + i__ + i__ * a_dim1;
+ z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
+ wb.r = z__1.r, wb.i = z__1.i;
+ i__2 = *m - *kl - i__;
+ z_div(&z__1, &c_b2, &wb);
+ zscal_(&i__2, &z__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
+ c__1);
+ i__2 = *kl + i__ + i__ * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+ z_div(&z__1, &wb, &wa);
+ d__1 = z__1.r;
+ tau.r = d__1, tau.i = 0.;
+ }
+
+/* apply reflection to A(kl+i:m,i+1:n) from the left */
+
+ i__2 = *m - *kl - i__ + 1;
+ i__3 = *n - i__;
+ zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*kl +
+ i__ + (i__ + 1) * a_dim1], lda, &a[*kl + i__ + i__ *
+ a_dim1], &c__1, &c_b1, &work[1], &c__1);
+ i__2 = *m - *kl - i__ + 1;
+ i__3 = *n - i__;
+ z__1.r = -tau.r, z__1.i = -tau.i;
+ zgerc_(&i__2, &i__3, &z__1, &a[*kl + i__ + i__ * a_dim1], &
+ c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) *
+ a_dim1], lda);
+ i__2 = *kl + i__ + i__ * a_dim1;
+ z__1.r = -wa.r, z__1.i = -wa.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ }
+
+/* Computing MIN */
+ i__2 = *n - 1 - *ku;
+ if (i__ <= min(i__2,*m)) {
+
+/* generate reflection to annihilate A(i,ku+i+1:n) */
+
+ i__2 = *n - *ku - i__ + 1;
+ wn = dznrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+ d__1 = wn / z_abs(&a[i__ + (*ku + i__) * a_dim1]);
+ i__2 = i__ + (*ku + i__) * a_dim1;
+ z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
+ wa.r = z__1.r, wa.i = z__1.i;
+ if (wn == 0.) {
+ tau.r = 0., tau.i = 0.;
+ } else {
+ i__2 = i__ + (*ku + i__) * a_dim1;
+ z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
+ wb.r = z__1.r, wb.i = z__1.i;
+ i__2 = *n - *ku - i__;
+ z_div(&z__1, &c_b2, &wb);
+ zscal_(&i__2, &z__1, &a[i__ + (*ku + i__ + 1) * a_dim1],
+ lda);
+ i__2 = i__ + (*ku + i__) * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+ z_div(&z__1, &wb, &wa);
+ d__1 = z__1.r;
+ tau.r = d__1, tau.i = 0.;
+ }
+
+/* apply reflection to A(i+1:m,ku+i:n) from the right */
+
+ i__2 = *n - *ku - i__ + 1;
+ zlacgv_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+ i__2 = *m - i__;
+ i__3 = *n - *ku - i__ + 1;
+ zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (*ku
+ + i__) * a_dim1], lda, &a[i__ + (*ku + i__) * a_dim1],
+ lda, &c_b1, &work[1], &c__1);
+ i__2 = *m - i__;
+ i__3 = *n - *ku - i__ + 1;
+ z__1.r = -tau.r, z__1.i = -tau.i;
+ zgerc_(&i__2, &i__3, &z__1, &work[1], &c__1, &a[i__ + (*ku +
+ i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) *
+ a_dim1], lda);
+ i__2 = i__ + (*ku + i__) * a_dim1;
+ z__1.r = -wa.r, z__1.i = -wa.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ }
+ } else {
+
+/* annihilate superdiagonal elements first (necessary if */
+/* KU = 0) */
+
+/* Computing MIN */
+ i__2 = *n - 1 - *ku;
+ if (i__ <= min(i__2,*m)) {
+
+/* generate reflection to annihilate A(i,ku+i+1:n) */
+
+ i__2 = *n - *ku - i__ + 1;
+ wn = dznrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+ d__1 = wn / z_abs(&a[i__ + (*ku + i__) * a_dim1]);
+ i__2 = i__ + (*ku + i__) * a_dim1;
+ z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
+ wa.r = z__1.r, wa.i = z__1.i;
+ if (wn == 0.) {
+ tau.r = 0., tau.i = 0.;
+ } else {
+ i__2 = i__ + (*ku + i__) * a_dim1;
+ z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
+ wb.r = z__1.r, wb.i = z__1.i;
+ i__2 = *n - *ku - i__;
+ z_div(&z__1, &c_b2, &wb);
+ zscal_(&i__2, &z__1, &a[i__ + (*ku + i__ + 1) * a_dim1],
+ lda);
+ i__2 = i__ + (*ku + i__) * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+ z_div(&z__1, &wb, &wa);
+ d__1 = z__1.r;
+ tau.r = d__1, tau.i = 0.;
+ }
+
+/* apply reflection to A(i+1:m,ku+i:n) from the right */
+
+ i__2 = *n - *ku - i__ + 1;
+ zlacgv_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+ i__2 = *m - i__;
+ i__3 = *n - *ku - i__ + 1;
+ zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (*ku
+ + i__) * a_dim1], lda, &a[i__ + (*ku + i__) * a_dim1],
+ lda, &c_b1, &work[1], &c__1);
+ i__2 = *m - i__;
+ i__3 = *n - *ku - i__ + 1;
+ z__1.r = -tau.r, z__1.i = -tau.i;
+ zgerc_(&i__2, &i__3, &z__1, &work[1], &c__1, &a[i__ + (*ku +
+ i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) *
+ a_dim1], lda);
+ i__2 = i__ + (*ku + i__) * a_dim1;
+ z__1.r = -wa.r, z__1.i = -wa.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ }
+
+/* Computing MIN */
+ i__2 = *m - 1 - *kl;
+ if (i__ <= min(i__2,*n)) {
+
+/* generate reflection to annihilate A(kl+i+1:m,i) */
+
+ i__2 = *m - *kl - i__ + 1;
+ wn = dznrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
+ d__1 = wn / z_abs(&a[*kl + i__ + i__ * a_dim1]);
+ i__2 = *kl + i__ + i__ * a_dim1;
+ z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
+ wa.r = z__1.r, wa.i = z__1.i;
+ if (wn == 0.) {
+ tau.r = 0., tau.i = 0.;
+ } else {
+ i__2 = *kl + i__ + i__ * a_dim1;
+ z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
+ wb.r = z__1.r, wb.i = z__1.i;
+ i__2 = *m - *kl - i__;
+ z_div(&z__1, &c_b2, &wb);
+ zscal_(&i__2, &z__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
+ c__1);
+ i__2 = *kl + i__ + i__ * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+ z_div(&z__1, &wb, &wa);
+ d__1 = z__1.r;
+ tau.r = d__1, tau.i = 0.;
+ }
+
+/* apply reflection to A(kl+i:m,i+1:n) from the left */
+
+ i__2 = *m - *kl - i__ + 1;
+ i__3 = *n - i__;
+ zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*kl +
+ i__ + (i__ + 1) * a_dim1], lda, &a[*kl + i__ + i__ *
+ a_dim1], &c__1, &c_b1, &work[1], &c__1);
+ i__2 = *m - *kl - i__ + 1;
+ i__3 = *n - i__;
+ z__1.r = -tau.r, z__1.i = -tau.i;
+ zgerc_(&i__2, &i__3, &z__1, &a[*kl + i__ + i__ * a_dim1], &
+ c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) *
+ a_dim1], lda);
+ i__2 = *kl + i__ + i__ * a_dim1;
+ z__1.r = -wa.r, z__1.i = -wa.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ }
+ }
+
+ i__2 = *m;
+ for (j = *kl + i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L50: */
+ }
+
+ i__2 = *n;
+ for (j = *ku + i__ + 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L60: */
+ }
+/* L70: */
+ }
+ return 0;
+
+/* End of ZLAGGE */
+
+} /* zlagge_ */
diff --git a/TESTING/MATGEN/zlaghe.c b/TESTING/MATGEN/zlaghe.c
new file mode 100644
index 0000000..ea14801
--- /dev/null
+++ b/TESTING/MATGEN/zlaghe.c
@@ -0,0 +1,332 @@
+/* zlaghe.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__3 = 3;
+static integer c__1 = 1;
+
+/* Subroutine */ int zlaghe_(integer *n, integer *k, doublereal *d__,
+ doublecomplex *a, integer *lda, integer *iseed, doublecomplex *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublereal d__1;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
+ doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j;
+ doublecomplex wa, wb;
+ doublereal wn;
+ doublecomplex tau;
+ extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ doublecomplex alpha;
+ extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zhemv_(char *, integer *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *), zaxpy_(integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *);
+ extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), zlarnv_(
+ integer *, integer *, integer *, doublecomplex *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAGHE generates a complex hermitian matrix A, by pre- and post- */
+/* multiplying a real diagonal matrix D with a random unitary matrix: */
+/* A = U*D*U'. The semi-bandwidth may then be reduced to k by additional */
+/* unitary transformations. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of nonzero subdiagonals within the band of A. */
+/* 0 <= K <= N-1. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal elements of the diagonal matrix D. */
+
+/* A (output) COMPLEX*16 array, dimension (LDA,N) */
+/* The generated n by n hermitian matrix A (the full matrix is */
+/* stored). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= N. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --d__;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iseed;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*k < 0 || *k > *n - 1) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("ZLAGHE", &i__1);
+ return 0;
+ }
+
+/* initialize lower triangle of A to diagonal matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ i__3 = i__;
+ a[i__2].r = d__[i__3], a[i__2].i = 0.;
+/* L30: */
+ }
+
+/* Generate lower triangle of hermitian matrix */
+
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+
+/* generate random reflection */
+
+ i__1 = *n - i__ + 1;
+ zlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+ i__1 = *n - i__ + 1;
+ wn = dznrm2_(&i__1, &work[1], &c__1);
+ d__1 = wn / z_abs(&work[1]);
+ z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i;
+ wa.r = z__1.r, wa.i = z__1.i;
+ if (wn == 0.) {
+ tau.r = 0., tau.i = 0.;
+ } else {
+ z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i;
+ wb.r = z__1.r, wb.i = z__1.i;
+ i__1 = *n - i__;
+ z_div(&z__1, &c_b2, &wb);
+ zscal_(&i__1, &z__1, &work[2], &c__1);
+ work[1].r = 1., work[1].i = 0.;
+ z_div(&z__1, &wb, &wa);
+ d__1 = z__1.r;
+ tau.r = d__1, tau.i = 0.;
+ }
+
+/* apply random reflection to A(i:n,i:n) from the left */
+/* and the right */
+
+/* compute y := tau * A * u */
+
+ i__1 = *n - i__ + 1;
+ zhemv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], &
+ c__1, &c_b1, &work[*n + 1], &c__1);
+
+/* compute v := y - 1/2 * tau * ( y, u ) * u */
+
+ z__3.r = -.5, z__3.i = -0.;
+ z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i +
+ z__3.i * tau.r;
+ i__1 = *n - i__ + 1;
+ zdotc_(&z__4, &i__1, &work[*n + 1], &c__1, &work[1], &c__1);
+ z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i
+ + z__2.i * z__4.r;
+ alpha.r = z__1.r, alpha.i = z__1.i;
+ i__1 = *n - i__ + 1;
+ zaxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
+
+/* apply the transformation as a rank-2 update to A(i:n,i:n) */
+
+ i__1 = *n - i__ + 1;
+ z__1.r = -1., z__1.i = -0.;
+ zher2_("Lower", &i__1, &z__1, &work[1], &c__1, &work[*n + 1], &c__1, &
+ a[i__ + i__ * a_dim1], lda);
+/* L40: */
+ }
+
+/* Reduce number of subdiagonals to K */
+
+ i__1 = *n - 1 - *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* generate reflection to annihilate A(k+i+1:n,i) */
+
+ i__2 = *n - *k - i__ + 1;
+ wn = dznrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
+ d__1 = wn / z_abs(&a[*k + i__ + i__ * a_dim1]);
+ i__2 = *k + i__ + i__ * a_dim1;
+ z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
+ wa.r = z__1.r, wa.i = z__1.i;
+ if (wn == 0.) {
+ tau.r = 0., tau.i = 0.;
+ } else {
+ i__2 = *k + i__ + i__ * a_dim1;
+ z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
+ wb.r = z__1.r, wb.i = z__1.i;
+ i__2 = *n - *k - i__;
+ z_div(&z__1, &c_b2, &wb);
+ zscal_(&i__2, &z__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1);
+ i__2 = *k + i__ + i__ * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+ z_div(&z__1, &wb, &wa);
+ d__1 = z__1.r;
+ tau.r = d__1, tau.i = 0.;
+ }
+
+/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */
+
+ i__2 = *n - *k - i__ + 1;
+ i__3 = *k - 1;
+ zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + (i__
+ + 1) * a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &
+ c_b1, &work[1], &c__1);
+ i__2 = *n - *k - i__ + 1;
+ i__3 = *k - 1;
+ z__1.r = -tau.r, z__1.i = -tau.i;
+ zgerc_(&i__2, &i__3, &z__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[
+ 1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda);
+
+/* apply reflection to A(k+i:n,k+i:n) from the left and the right */
+
+/* compute y := tau * A * u */
+
+ i__2 = *n - *k - i__ + 1;
+ zhemv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda,
+ &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &work[1], &c__1);
+
+/* compute v := y - 1/2 * tau * ( y, u ) * u */
+
+ z__3.r = -.5, z__3.i = -0.;
+ z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i +
+ z__3.i * tau.r;
+ i__2 = *n - *k - i__ + 1;
+ zdotc_(&z__4, &i__2, &work[1], &c__1, &a[*k + i__ + i__ * a_dim1], &
+ c__1);
+ z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i
+ + z__2.i * z__4.r;
+ alpha.r = z__1.r, alpha.i = z__1.i;
+ i__2 = *n - *k - i__ + 1;
+ zaxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], &
+ c__1);
+
+/* apply hermitian rank-2 update to A(k+i:n,k+i:n) */
+
+ i__2 = *n - *k - i__ + 1;
+ z__1.r = -1., z__1.i = -0.;
+ zher2_("Lower", &i__2, &z__1, &a[*k + i__ + i__ * a_dim1], &c__1, &
+ work[1], &c__1, &a[*k + i__ + (*k + i__) * a_dim1], lda);
+
+ i__2 = *k + i__ + i__ * a_dim1;
+ z__1.r = -wa.r, z__1.i = -wa.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ i__2 = *n;
+ for (j = *k + i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* Store full hermitian matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * a_dim1;
+ d_cnjg(&z__1, &a[i__ + j * a_dim1]);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+ return 0;
+
+/* End of ZLAGHE */
+
+} /* zlaghe_ */
diff --git a/TESTING/MATGEN/zlagsy.c b/TESTING/MATGEN/zlagsy.c
new file mode 100644
index 0000000..b4c8ee9
--- /dev/null
+++ b/TESTING/MATGEN/zlagsy.c
@@ -0,0 +1,380 @@
+/* zlagsy.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__3 = 3;
+static integer c__1 = 1;
+
+/* Subroutine */ int zlagsy_(integer *n, integer *k, doublereal *d__,
+ doublecomplex *a, integer *lda, integer *iseed, doublecomplex *work,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8,
+ i__9;
+ doublereal d__1;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, ii, jj;
+ doublecomplex wa, wb;
+ doublereal wn;
+ doublecomplex tau, alpha;
+ extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *),
+ zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zsymv_(char *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), zlacgv_(
+ integer *, doublecomplex *, integer *), zlarnv_(integer *,
+ integer *, integer *, doublecomplex *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAGSY generates a complex symmetric matrix A, by pre- and post- */
+/* multiplying a real diagonal matrix D with a random unitary matrix: */
+/* A = U*D*U**T. The semi-bandwidth may then be reduced to k by */
+/* additional unitary transformations. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* K (input) INTEGER */
+/* The number of nonzero subdiagonals within the band of A. */
+/* 0 <= K <= N-1. */
+
+/* D (input) DOUBLE PRECISION array, dimension (N) */
+/* The diagonal elements of the diagonal matrix D. */
+
+/* A (output) COMPLEX*16 array, dimension (LDA,N) */
+/* The generated n by n symmetric matrix A (the full matrix is */
+/* stored). */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= N. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ --d__;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iseed;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*k < 0 || *k > *n - 1) {
+ *info = -2;
+ } else if (*lda < max(1,*n)) {
+ *info = -5;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("ZLAGSY", &i__1);
+ return 0;
+ }
+
+/* initialize lower triangle of A to diagonal matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L10: */
+ }
+/* L20: */
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * a_dim1;
+ i__3 = i__;
+ a[i__2].r = d__[i__3], a[i__2].i = 0.;
+/* L30: */
+ }
+
+/* Generate lower triangle of symmetric matrix */
+
+ for (i__ = *n - 1; i__ >= 1; --i__) {
+
+/* generate random reflection */
+
+ i__1 = *n - i__ + 1;
+ zlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+ i__1 = *n - i__ + 1;
+ wn = dznrm2_(&i__1, &work[1], &c__1);
+ d__1 = wn / z_abs(&work[1]);
+ z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i;
+ wa.r = z__1.r, wa.i = z__1.i;
+ if (wn == 0.) {
+ tau.r = 0., tau.i = 0.;
+ } else {
+ z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i;
+ wb.r = z__1.r, wb.i = z__1.i;
+ i__1 = *n - i__;
+ z_div(&z__1, &c_b2, &wb);
+ zscal_(&i__1, &z__1, &work[2], &c__1);
+ work[1].r = 1., work[1].i = 0.;
+ z_div(&z__1, &wb, &wa);
+ d__1 = z__1.r;
+ tau.r = d__1, tau.i = 0.;
+ }
+
+/* apply random reflection to A(i:n,i:n) from the left */
+/* and the right */
+
+/* compute y := tau * A * conjg(u) */
+
+ i__1 = *n - i__ + 1;
+ zlacgv_(&i__1, &work[1], &c__1);
+ i__1 = *n - i__ + 1;
+ zsymv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], &
+ c__1, &c_b1, &work[*n + 1], &c__1);
+ i__1 = *n - i__ + 1;
+ zlacgv_(&i__1, &work[1], &c__1);
+
+/* compute v := y - 1/2 * tau * ( u, y ) * u */
+
+ z__3.r = -.5, z__3.i = -0.;
+ z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i +
+ z__3.i * tau.r;
+ i__1 = *n - i__ + 1;
+ zdotc_(&z__4, &i__1, &work[1], &c__1, &work[*n + 1], &c__1);
+ z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i
+ + z__2.i * z__4.r;
+ alpha.r = z__1.r, alpha.i = z__1.i;
+ i__1 = *n - i__ + 1;
+ zaxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
+
+/* apply the transformation as a rank-2 update to A(i:n,i:n) */
+
+/* CALL ZSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1, */
+/* $ A( I, I ), LDA ) */
+
+ i__1 = *n;
+ for (jj = i__; jj <= i__1; ++jj) {
+ i__2 = *n;
+ for (ii = jj; ii <= i__2; ++ii) {
+ i__3 = ii + jj * a_dim1;
+ i__4 = ii + jj * a_dim1;
+ i__5 = ii - i__ + 1;
+ i__6 = *n + jj - i__ + 1;
+ z__3.r = work[i__5].r * work[i__6].r - work[i__5].i * work[
+ i__6].i, z__3.i = work[i__5].r * work[i__6].i + work[
+ i__5].i * work[i__6].r;
+ z__2.r = a[i__4].r - z__3.r, z__2.i = a[i__4].i - z__3.i;
+ i__7 = *n + ii - i__ + 1;
+ i__8 = jj - i__ + 1;
+ z__4.r = work[i__7].r * work[i__8].r - work[i__7].i * work[
+ i__8].i, z__4.i = work[i__7].r * work[i__8].i + work[
+ i__7].i * work[i__8].r;
+ z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L40: */
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+
+/* Reduce number of subdiagonals to K */
+
+ i__1 = *n - 1 - *k;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+
+/* generate reflection to annihilate A(k+i+1:n,i) */
+
+ i__2 = *n - *k - i__ + 1;
+ wn = dznrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
+ d__1 = wn / z_abs(&a[*k + i__ + i__ * a_dim1]);
+ i__2 = *k + i__ + i__ * a_dim1;
+ z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
+ wa.r = z__1.r, wa.i = z__1.i;
+ if (wn == 0.) {
+ tau.r = 0., tau.i = 0.;
+ } else {
+ i__2 = *k + i__ + i__ * a_dim1;
+ z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
+ wb.r = z__1.r, wb.i = z__1.i;
+ i__2 = *n - *k - i__;
+ z_div(&z__1, &c_b2, &wb);
+ zscal_(&i__2, &z__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1);
+ i__2 = *k + i__ + i__ * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+ z_div(&z__1, &wb, &wa);
+ d__1 = z__1.r;
+ tau.r = d__1, tau.i = 0.;
+ }
+
+/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */
+
+ i__2 = *n - *k - i__ + 1;
+ i__3 = *k - 1;
+ zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + (i__
+ + 1) * a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &
+ c_b1, &work[1], &c__1);
+ i__2 = *n - *k - i__ + 1;
+ i__3 = *k - 1;
+ z__1.r = -tau.r, z__1.i = -tau.i;
+ zgerc_(&i__2, &i__3, &z__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[
+ 1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda);
+
+/* apply reflection to A(k+i:n,k+i:n) from the left and the right */
+
+/* compute y := tau * A * conjg(u) */
+
+ i__2 = *n - *k - i__ + 1;
+ zlacgv_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
+ i__2 = *n - *k - i__ + 1;
+ zsymv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda,
+ &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &work[1], &c__1);
+ i__2 = *n - *k - i__ + 1;
+ zlacgv_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
+
+/* compute v := y - 1/2 * tau * ( u, y ) * u */
+
+ z__3.r = -.5, z__3.i = -0.;
+ z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i +
+ z__3.i * tau.r;
+ i__2 = *n - *k - i__ + 1;
+ zdotc_(&z__4, &i__2, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], &
+ c__1);
+ z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i
+ + z__2.i * z__4.r;
+ alpha.r = z__1.r, alpha.i = z__1.i;
+ i__2 = *n - *k - i__ + 1;
+ zaxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], &
+ c__1);
+
+/* apply symmetric rank-2 update to A(k+i:n,k+i:n) */
+
+/* CALL ZSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1, */
+/* $ A( K+I, K+I ), LDA ) */
+
+ i__2 = *n;
+ for (jj = *k + i__; jj <= i__2; ++jj) {
+ i__3 = *n;
+ for (ii = jj; ii <= i__3; ++ii) {
+ i__4 = ii + jj * a_dim1;
+ i__5 = ii + jj * a_dim1;
+ i__6 = ii + i__ * a_dim1;
+ i__7 = jj - *k - i__ + 1;
+ z__3.r = a[i__6].r * work[i__7].r - a[i__6].i * work[i__7].i,
+ z__3.i = a[i__6].r * work[i__7].i + a[i__6].i * work[
+ i__7].r;
+ z__2.r = a[i__5].r - z__3.r, z__2.i = a[i__5].i - z__3.i;
+ i__8 = ii - *k - i__ + 1;
+ i__9 = jj + i__ * a_dim1;
+ z__4.r = work[i__8].r * a[i__9].r - work[i__8].i * a[i__9].i,
+ z__4.i = work[i__8].r * a[i__9].i + work[i__8].i * a[
+ i__9].r;
+ z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i;
+ a[i__4].r = z__1.r, a[i__4].i = z__1.i;
+/* L70: */
+ }
+/* L80: */
+ }
+
+ i__2 = *k + i__ + i__ * a_dim1;
+ z__1.r = -wa.r, z__1.i = -wa.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ i__2 = *n;
+ for (j = *k + i__ + 1; j <= i__2; ++j) {
+ i__3 = j + i__ * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+/* L90: */
+ }
+/* L100: */
+ }
+
+/* Store full symmetric matrix */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__3 = j + i__ * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
+/* L110: */
+ }
+/* L120: */
+ }
+ return 0;
+
+/* End of ZLAGSY */
+
+} /* zlagsy_ */
diff --git a/TESTING/MATGEN/zlahilb.c b/TESTING/MATGEN/zlahilb.c
new file mode 100644
index 0000000..055590c
--- /dev/null
+++ b/TESTING/MATGEN/zlahilb.c
@@ -0,0 +1,277 @@
+/* zlahilb.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__2 = 2;
+static doublecomplex c_b6 = {0.,0.};
+
+/* Subroutine */ int zlahilb_(integer *n, integer *nrhs, doublecomplex *a,
+ integer *lda, doublecomplex *x, integer *ldx, doublecomplex *b,
+ integer *ldb, doublereal *work, integer *info, char *path)
+{
+ /* Initialized data */
+
+ static doublecomplex d1[8] = { {-1.,0.},{0.,1.},{-1.,-1.},{0.,-1.},{1.,0.}
+ ,{-1.,1.},{1.,1.},{1.,-1.} };
+ static doublecomplex d2[8] = { {-1.,0.},{0.,-1.},{-1.,1.},{0.,1.},{1.,0.},
+ {-1.,-1.},{1.,-1.},{1.,1.} };
+ static doublecomplex invd1[8] = { {-1.,0.},{0.,-1.},{-.5,.5},{0.,1.},{1.,
+ 0.},{-.5,-.5},{.5,-.5},{.5,.5} };
+ static doublecomplex invd2[8] = { {-1.,0.},{0.,1.},{-.5,-.5},{0.,-1.},{1.,
+ 0.},{-.5,.5},{.5,.5},{.5,-.5} };
+
+ /* System generated locals */
+ integer a_dim1, a_offset, x_dim1, x_offset, b_dim1, b_offset, i__1, i__2,
+ i__3, i__4, i__5;
+ doublereal d__1;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+
+ /* Local variables */
+ integer i__, j, m, r__;
+ char c2[2];
+ integer ti, tm;
+ doublecomplex tmp;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern logical lsamen_(integer *, char *, char *);
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.0) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
+/* Courant Institute, Argonne National Lab, and Rice University */
+/* 28 August, 2006 */
+
+/* David Vu <dtv at cs.berkeley.edu> */
+/* Yozo Hida <yozo at cs.berkeley.edu> */
+/* Jason Riedy <ejr at cs.berkeley.edu> */
+/* D. Halligan <dhalligan at berkeley.edu> */
+
+/* .. Scalar Arguments .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAHILB generates an N by N scaled Hilbert matrix in A along with */
+/* NRHS right-hand sides in B and solutions in X such that A*X=B. */
+
+/* The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all */
+/* entries are integers. The right-hand sides are the first NRHS */
+/* columns of M * the identity matrix, and the solutions are the */
+/* first NRHS columns of the inverse Hilbert matrix. */
+
+/* The condition number of the Hilbert matrix grows exponentially with */
+/* its size, roughly as O(e ** (3.5*N)). Additionally, the inverse */
+/* Hilbert matrices beyond a relatively small dimension cannot be */
+/* generated exactly without extra precision. Precision is exhausted */
+/* when the largest entry in the inverse Hilbert matrix is greater than */
+/* 2 to the power of the number of bits in the fraction of the data type */
+/* used plus one, which is 24 for single precision. */
+
+/* In single, the generated solution is exact for N <= 6 and has */
+/* small componentwise error for 7 <= N <= 11. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The dimension of the matrix A. */
+
+/* NRHS (input) NRHS */
+/* The requested number of right-hand sides. */
+
+/* A (output) COMPLEX array, dimension (LDA, N) */
+/* The generated scaled Hilbert matrix. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= N. */
+
+/* X (output) COMPLEX array, dimension (LDX, NRHS) */
+/* The generated exact solutions. Currently, the first NRHS */
+/* columns of the inverse Hilbert matrix. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of the array X. LDX >= N. */
+
+/* B (output) REAL array, dimension (LDB, NRHS) */
+/* The generated right-hand sides. Currently, the first NRHS */
+/* columns of LCM(1, 2, ..., 2*N-1) * the identity matrix. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of the array B. LDB >= N. */
+
+/* WORK (workspace) REAL array, dimension (N) */
+
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* = 1: N is too large; the data is still generated but may not */
+/* be not exact. */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+/* .. Local Scalars .. */
+/* .. Parameters .. */
+/* NMAX_EXACT the largest dimension where the generated data is */
+/* exact. */
+/* NMAX_APPROX the largest dimension where the generated data has */
+/* a small componentwise relative error. */
+/* ??? complex uses how many bits ??? */
+/* d's are generated from random permuation of those eight elements. */
+ /* Parameter adjustments */
+ --work;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+
+ /* Function Body */
+/* .. */
+/* .. External Functions */
+/* .. */
+/* .. Executable Statements .. */
+ s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/* Test the input arguments */
+
+ *info = 0;
+ if (*n < 0 || *n > 11) {
+ *info = -1;
+ } else if (*nrhs < 0) {
+ *info = -2;
+ } else if (*lda < *n) {
+ *info = -4;
+ } else if (*ldx < *n) {
+ *info = -6;
+ } else if (*ldb < *n) {
+ *info = -8;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("ZLAHILB", &i__1);
+ return 0;
+ }
+ if (*n > 6) {
+ *info = 1;
+ }
+/* Compute M = the LCM of the integers [1, 2*N-1]. The largest */
+/* reasonable N is small enough that integers suffice (up to N = 11). */
+ m = 1;
+ i__1 = (*n << 1) - 1;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ tm = m;
+ ti = i__;
+ r__ = tm % ti;
+ while(r__ != 0) {
+ tm = ti;
+ ti = r__;
+ r__ = tm % ti;
+ }
+ m = m / ti * i__;
+ }
+/* Generate the scaled Hilbert matrix in A */
+/* If we are testing SY routines, take D1_i = D2_i, else, D1_i = D2_i* */
+ if (lsamen_(&c__2, c2, "SY")) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = j % 8;
+ d__1 = (doublereal) m / (i__ + j - 1);
+ z__2.r = d__1 * d1[i__4].r, z__2.i = d__1 * d1[i__4].i;
+ i__5 = i__ % 8;
+ z__1.r = z__2.r * d1[i__5].r - z__2.i * d1[i__5].i, z__1.i =
+ z__2.r * d1[i__5].i + z__2.i * d1[i__5].r;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ }
+ }
+ } else {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = j % 8;
+ d__1 = (doublereal) m / (i__ + j - 1);
+ z__2.r = d__1 * d1[i__4].r, z__2.i = d__1 * d1[i__4].i;
+ i__5 = i__ % 8;
+ z__1.r = z__2.r * d2[i__5].r - z__2.i * d2[i__5].i, z__1.i =
+ z__2.r * d2[i__5].i + z__2.i * d2[i__5].r;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ }
+ }
+ }
+/* Generate matrix B as simply the first NRHS columns of M * the */
+/* identity. */
+ d__1 = (doublereal) m;
+ tmp.r = d__1, tmp.i = 0.;
+ zlaset_("Full", n, nrhs, &c_b6, &tmp, &b[b_offset], ldb);
+/* Generate the true solutions in X. Because B = the first NRHS */
+/* columns of M*I, the true solutions are just the first NRHS columns */
+/* of the inverse Hilbert matrix. */
+ work[1] = (doublereal) (*n);
+ i__1 = *n;
+ for (j = 2; j <= i__1; ++j) {
+ work[j] = work[j - 1] / (j - 1) * (j - 1 - *n) / (j - 1) * (*n + j -
+ 1);
+ }
+/* If we are testing SY routines, take D1_i = D2_i, else, D1_i = D2_i* */
+ if (lsamen_(&c__2, c2, "SY")) {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = j % 8;
+ d__1 = work[i__] * work[j] / (i__ + j - 1);
+ z__2.r = d__1 * invd1[i__4].r, z__2.i = d__1 * invd1[i__4].i;
+ i__5 = i__ % 8;
+ z__1.r = z__2.r * invd1[i__5].r - z__2.i * invd1[i__5].i,
+ z__1.i = z__2.r * invd1[i__5].i + z__2.i * invd1[i__5]
+ .r;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ }
+ }
+ } else {
+ i__1 = *nrhs;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *n;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * x_dim1;
+ i__4 = j % 8;
+ d__1 = work[i__] * work[j] / (i__ + j - 1);
+ z__2.r = d__1 * invd2[i__4].r, z__2.i = d__1 * invd2[i__4].i;
+ i__5 = i__ % 8;
+ z__1.r = z__2.r * invd1[i__5].r - z__2.i * invd1[i__5].i,
+ z__1.i = z__2.r * invd1[i__5].i + z__2.i * invd1[i__5]
+ .r;
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+ }
+ }
+ }
+ return 0;
+} /* zlahilb_ */
diff --git a/TESTING/MATGEN/zlakf2.c b/TESTING/MATGEN/zlakf2.c
new file mode 100644
index 0000000..c4f86b0
--- /dev/null
+++ b/TESTING/MATGEN/zlakf2.c
@@ -0,0 +1,194 @@
+/* zlakf2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+
+/* Subroutine */ int zlakf2_(integer *m, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *b, doublecomplex *d__, doublecomplex *e,
+ doublecomplex *z__, integer *ldz)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, d_dim1, d_offset, e_dim1,
+ e_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
+ doublecomplex z__1;
+
+ /* Local variables */
+ integer i__, j, l, ik, jk, mn, mn2;
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* Form the 2*M*N by 2*M*N matrix */
+
+/* Z = [ kron(In, A) -kron(B', Im) ] */
+/* [ kron(In, D) -kron(E', Im) ], */
+
+/* where In is the identity matrix of size n and X' is the transpose */
+/* of X. kron(X, Y) is the Kronecker product between the matrices X */
+/* and Y. */
+
+/* Arguments */
+/* ========= */
+
+/* M (input) INTEGER */
+/* Size of matrix, must be >= 1. */
+
+/* N (input) INTEGER */
+/* Size of matrix, must be >= 1. */
+
+/* A (input) COMPLEX*16, dimension ( LDA, M ) */
+/* The matrix A in the output matrix Z. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A, B, D, and E. ( LDA >= M+N ) */
+
+/* B (input) COMPLEX*16, dimension ( LDA, N ) */
+/* D (input) COMPLEX*16, dimension ( LDA, M ) */
+/* E (input) COMPLEX*16, dimension ( LDA, N ) */
+/* The matrices used in forming the output matrix Z. */
+
+/* Z (output) COMPLEX*16, dimension ( LDZ, 2*M*N ) */
+/* The resultant Kronecker M*N*2 by M*N*2 matrix (see above.) */
+
+/* LDZ (input) INTEGER */
+/* The leading dimension of Z. ( LDZ >= 2*M*N ) */
+
+/* ==================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Initialize Z */
+
+ /* Parameter adjustments */
+ e_dim1 = *lda;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ d_dim1 = *lda;
+ d_offset = 1 + d_dim1;
+ d__ -= d_offset;
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ z_dim1 = *ldz;
+ z_offset = 1 + z_dim1;
+ z__ -= z_offset;
+
+ /* Function Body */
+ mn = *m * *n;
+ mn2 = mn << 1;
+ zlaset_("Full", &mn2, &mn2, &c_b1, &c_b1, &z__[z_offset], ldz);
+
+ ik = 1;
+ i__1 = *n;
+ for (l = 1; l <= i__1; ++l) {
+
+/* form kron(In, A) */
+
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = *m;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = ik + i__ - 1 + (ik + j - 1) * z_dim1;
+ i__5 = i__ + j * a_dim1;
+ z__[i__4].r = a[i__5].r, z__[i__4].i = a[i__5].i;
+/* L10: */
+ }
+/* L20: */
+ }
+
+/* form kron(In, D) */
+
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = *m;
+ for (j = 1; j <= i__3; ++j) {
+ i__4 = ik + mn + i__ - 1 + (ik + j - 1) * z_dim1;
+ i__5 = i__ + j * d_dim1;
+ z__[i__4].r = d__[i__5].r, z__[i__4].i = d__[i__5].i;
+/* L30: */
+ }
+/* L40: */
+ }
+
+ ik += *m;
+/* L50: */
+ }
+
+ ik = 1;
+ i__1 = *n;
+ for (l = 1; l <= i__1; ++l) {
+ jk = mn + 1;
+
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+
+/* form -kron(B', Im) */
+
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ik + i__ - 1 + (jk + i__ - 1) * z_dim1;
+ i__5 = j + l * b_dim1;
+ z__1.r = -b[i__5].r, z__1.i = -b[i__5].i;
+ z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
+/* L60: */
+ }
+
+/* form -kron(E', Im) */
+
+ i__3 = *m;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ i__4 = ik + mn + i__ - 1 + (jk + i__ - 1) * z_dim1;
+ i__5 = j + l * e_dim1;
+ z__1.r = -e[i__5].r, z__1.i = -e[i__5].i;
+ z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
+/* L70: */
+ }
+
+ jk += *m;
+/* L80: */
+ }
+
+ ik += *m;
+/* L90: */
+ }
+
+ return 0;
+
+/* End of ZLAKF2 */
+
+} /* zlakf2_ */
diff --git a/TESTING/MATGEN/zlarge.c b/TESTING/MATGEN/zlarge.c
new file mode 100644
index 0000000..d66b182
--- /dev/null
+++ b/TESTING/MATGEN/zlarge.c
@@ -0,0 +1,180 @@
+/* zlarge.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__3 = 3;
+static integer c__1 = 1;
+
+/* Subroutine */ int zlarge_(integer *n, doublecomplex *a, integer *lda,
+ integer *iseed, doublecomplex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1;
+ doublereal d__1;
+ doublecomplex z__1;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__;
+ doublecomplex wa, wb;
+ doublereal wn;
+ doublecomplex tau;
+ extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *), zlarnv_(
+ integer *, integer *, integer *, doublecomplex *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLARGE pre- and post-multiplies a complex general n by n matrix A */
+/* with a random unitary matrix: A = U*D*U'. */
+
+/* Arguments */
+/* ========= */
+
+/* N (input) INTEGER */
+/* The order of the matrix A. N >= 0. */
+
+/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
+/* On entry, the original n by n matrix A. */
+/* On exit, A is overwritten by U*A*U' for some random */
+/* unitary matrix U. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of the array A. LDA >= N. */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
+
+/* INFO (output) INTEGER */
+/* = 0: successful exit */
+/* < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Test the input arguments */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iseed;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+ if (*n < 0) {
+ *info = -1;
+ } else if (*lda < max(1,*n)) {
+ *info = -3;
+ }
+ if (*info < 0) {
+ i__1 = -(*info);
+ xerbla_("ZLARGE", &i__1);
+ return 0;
+ }
+
+/* pre- and post-multiply A by random unitary matrix */
+
+ for (i__ = *n; i__ >= 1; --i__) {
+
+/* generate random reflection */
+
+ i__1 = *n - i__ + 1;
+ zlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+ i__1 = *n - i__ + 1;
+ wn = dznrm2_(&i__1, &work[1], &c__1);
+ d__1 = wn / z_abs(&work[1]);
+ z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i;
+ wa.r = z__1.r, wa.i = z__1.i;
+ if (wn == 0.) {
+ tau.r = 0., tau.i = 0.;
+ } else {
+ z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i;
+ wb.r = z__1.r, wb.i = z__1.i;
+ i__1 = *n - i__;
+ z_div(&z__1, &c_b2, &wb);
+ zscal_(&i__1, &z__1, &work[2], &c__1);
+ work[1].r = 1., work[1].i = 0.;
+ z_div(&z__1, &wb, &wa);
+ d__1 = z__1.r;
+ tau.r = d__1, tau.i = 0.;
+ }
+
+/* multiply A(i:n,1:n) by random reflection from the left */
+
+ i__1 = *n - i__ + 1;
+ zgemv_("Conjugate transpose", &i__1, n, &c_b2, &a[i__ + a_dim1], lda,
+ &work[1], &c__1, &c_b1, &work[*n + 1], &c__1);
+ i__1 = *n - i__ + 1;
+ z__1.r = -tau.r, z__1.i = -tau.i;
+ zgerc_(&i__1, n, &z__1, &work[1], &c__1, &work[*n + 1], &c__1, &a[i__
+ + a_dim1], lda);
+
+/* multiply A(1:n,i:n) by random reflection from the right */
+
+ i__1 = *n - i__ + 1;
+ zgemv_("No transpose", n, &i__1, &c_b2, &a[i__ * a_dim1 + 1], lda, &
+ work[1], &c__1, &c_b1, &work[*n + 1], &c__1);
+ i__1 = *n - i__ + 1;
+ z__1.r = -tau.r, z__1.i = -tau.i;
+ zgerc_(n, &i__1, &z__1, &work[*n + 1], &c__1, &work[1], &c__1, &a[i__
+ * a_dim1 + 1], lda);
+/* L10: */
+ }
+ return 0;
+
+/* End of ZLARGE */
+
+} /* zlarge_ */
diff --git a/TESTING/MATGEN/zlarnd.c b/TESTING/MATGEN/zlarnd.c
new file mode 100644
index 0000000..5749d10
--- /dev/null
+++ b/TESTING/MATGEN/zlarnd.c
@@ -0,0 +1,140 @@
+/* zlarnd.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Double Complex */ VOID zlarnd_(doublecomplex * ret_val, integer *idist,
+ integer *iseed)
+{
+ /* System generated locals */
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ double log(doublereal), sqrt(doublereal);
+ void z_exp(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ doublereal t1, t2;
+ extern doublereal dlaran_(integer *);
+
+
+/* -- LAPACK auxiliary routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLARND returns a random complex number from a uniform or normal */
+/* distribution. */
+
+/* Arguments */
+/* ========= */
+
+/* IDIST (input) INTEGER */
+/* Specifies the distribution of the random numbers: */
+/* = 1: real and imaginary parts each uniform (0,1) */
+/* = 2: real and imaginary parts each uniform (-1,1) */
+/* = 3: real and imaginary parts each normal (0,1) */
+/* = 4: uniformly distributed on the disc abs(z) <= 1 */
+/* = 5: uniformly distributed on the circle abs(z) = 1 */
+
+/* ISEED (input/output) INTEGER array, dimension (4) */
+/* On entry, the seed of the random number generator; the array */
+/* elements must be between 0 and 4095, and ISEED(4) must be */
+/* odd. */
+/* On exit, the seed is updated. */
+
+/* Further Details */
+/* =============== */
+
+/* This routine calls the auxiliary routine DLARAN to generate a random */
+/* real number from a uniform (0,1) distribution. The Box-Muller method */
+/* is used to transform numbers from a uniform to a normal distribution. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Generate a pair of real random numbers from a uniform (0,1) */
+/* distribution */
+
+ /* Parameter adjustments */
+ --iseed;
+
+ /* Function Body */
+ t1 = dlaran_(&iseed[1]);
+ t2 = dlaran_(&iseed[1]);
+
+ if (*idist == 1) {
+
+/* real and imaginary parts each uniform (0,1) */
+
+ z__1.r = t1, z__1.i = t2;
+ ret_val->r = z__1.r, ret_val->i = z__1.i;
+ } else if (*idist == 2) {
+
+/* real and imaginary parts each uniform (-1,1) */
+
+ d__1 = t1 * 2. - 1.;
+ d__2 = t2 * 2. - 1.;
+ z__1.r = d__1, z__1.i = d__2;
+ ret_val->r = z__1.r, ret_val->i = z__1.i;
+ } else if (*idist == 3) {
+
+/* real and imaginary parts each normal (0,1) */
+
+ d__1 = sqrt(log(t1) * -2.);
+ d__2 = t2 * 6.2831853071795864769252867663;
+ z__3.r = 0., z__3.i = d__2;
+ z_exp(&z__2, &z__3);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ ret_val->r = z__1.r, ret_val->i = z__1.i;
+ } else if (*idist == 4) {
+
+/* uniform distribution on the unit disc abs(z) <= 1 */
+
+ d__1 = sqrt(t1);
+ d__2 = t2 * 6.2831853071795864769252867663;
+ z__3.r = 0., z__3.i = d__2;
+ z_exp(&z__2, &z__3);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ ret_val->r = z__1.r, ret_val->i = z__1.i;
+ } else if (*idist == 5) {
+
+/* uniform distribution on the unit circle abs(z) = 1 */
+
+ d__1 = t2 * 6.2831853071795864769252867663;
+ z__2.r = 0., z__2.i = d__1;
+ z_exp(&z__1, &z__2);
+ ret_val->r = z__1.r, ret_val->i = z__1.i;
+ }
+ return ;
+
+/* End of ZLARND */
+
+} /* zlarnd_ */
diff --git a/TESTING/MATGEN/zlaror.c b/TESTING/MATGEN/zlaror.c
new file mode 100644
index 0000000..b581962
--- /dev/null
+++ b/TESTING/MATGEN/zlaror.c
@@ -0,0 +1,369 @@
+/* zlaror.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__3 = 3;
+static integer c__1 = 1;
+
+/* Subroutine */ int zlaror_(char *side, char *init, integer *m, integer *n,
+ doublecomplex *a, integer *lda, integer *iseed, doublecomplex *x,
+ integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer j, kbeg, jcol;
+ doublereal xabs;
+ integer irow;
+ extern logical lsame_(char *, char *);
+ doublecomplex csign;
+ extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *);
+ integer ixfrm;
+ extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ integer itype, nxfrm;
+ doublereal xnorm;
+ extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ doublereal factor;
+ extern /* Subroutine */ int zlacgv_(integer *, doublecomplex *, integer *)
+ ;
+ extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
+ integer *);
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+ doublecomplex xnorms;
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAROR pre- or post-multiplies an M by N matrix A by a random */
+/* unitary matrix U, overwriting A. A may optionally be */
+/* initialized to the identity matrix before multiplying by U. */
+/* U is generated using the method of G.W. Stewart */
+/* ( SIAM J. Numer. Anal. 17, 1980, pp. 403-409 ). */
+/* (BLAS-2 version) */
+
+/* Arguments */
+/* ========= */
+
+/* SIDE - CHARACTER*1 */
+/* SIDE specifies whether A is multiplied on the left or right */
+/* by U. */
+/* SIDE = 'L' Multiply A on the left (premultiply) by U */
+/* SIDE = 'R' Multiply A on the right (postmultiply) by U* */
+/* SIDE = 'C' Multiply A on the left by U and the right by U* */
+/* SIDE = 'T' Multiply A on the left by U and the right by U' */
+/* Not modified. */
+
+/* INIT - CHARACTER*1 */
+/* INIT specifies whether or not A should be initialized to */
+/* the identity matrix. */
+/* INIT = 'I' Initialize A to (a section of) the */
+/* identity matrix before applying U. */
+/* INIT = 'N' No initialization. Apply U to the */
+/* input matrix A. */
+
+/* INIT = 'I' may be used to generate square (i.e., unitary) */
+/* or rectangular orthogonal matrices (orthogonality being */
+/* in the sense of ZDOTC): */
+
+/* For square matrices, M=N, and SIDE many be either 'L' or */
+/* 'R'; the rows will be orthogonal to each other, as will the */
+/* columns. */
+/* For rectangular matrices where M < N, SIDE = 'R' will */
+/* produce a dense matrix whose rows will be orthogonal and */
+/* whose columns will not, while SIDE = 'L' will produce a */
+/* matrix whose rows will be orthogonal, and whose first M */
+/* columns will be orthogonal, the remaining columns being */
+/* zero. */
+/* For matrices where M > N, just use the previous */
+/* explaination, interchanging 'L' and 'R' and "rows" and */
+/* "columns". */
+
+/* Not modified. */
+
+/* M - INTEGER */
+/* Number of rows of A. Not modified. */
+
+/* N - INTEGER */
+/* Number of columns of A. Not modified. */
+
+/* A - COMPLEX*16 array, dimension ( LDA, N ) */
+/* Input and output array. Overwritten by U A ( if SIDE = 'L' ) */
+/* or by A U ( if SIDE = 'R' ) */
+/* or by U A U* ( if SIDE = 'C') */
+/* or by U A U' ( if SIDE = 'T') on exit. */
+
+/* LDA - INTEGER */
+/* Leading dimension of A. Must be at least MAX ( 1, M ). */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension ( 4 ) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The array elements should be between 0 and 4095; */
+/* if not they will be reduced mod 4096. Also, ISEED(4) must */
+/* be odd. The random number generator uses a linear */
+/* congruential sequence limited to small integers, and so */
+/* should produce machine independent random numbers. The */
+/* values of ISEED are changed on exit, and can be used in the */
+/* next call to ZLAROR to continue the same random number */
+/* sequence. */
+/* Modified. */
+
+/* X - COMPLEX*16 array, dimension ( 3*MAX( M, N ) ) */
+/* Workspace. Of length: */
+/* 2*M + N if SIDE = 'L', */
+/* 2*N + M if SIDE = 'R', */
+/* 3*N if SIDE = 'C' or 'T'. */
+/* Modified. */
+
+/* INFO - INTEGER */
+/* An error flag. It is set to: */
+/* 0 if no error. */
+/* 1 if ZLARND returned a bad random number (installation */
+/* problem) */
+/* -1 if SIDE is not L, R, C, or T. */
+/* -3 if M is negative. */
+/* -4 if N is negative or if SIDE is C or T and N is not equal */
+/* to M. */
+/* -6 if LDA is less than M. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iseed;
+ --x;
+
+ /* Function Body */
+ if (*n == 0 || *m == 0) {
+ return 0;
+ }
+
+ itype = 0;
+ if (lsame_(side, "L")) {
+ itype = 1;
+ } else if (lsame_(side, "R")) {
+ itype = 2;
+ } else if (lsame_(side, "C")) {
+ itype = 3;
+ } else if (lsame_(side, "T")) {
+ itype = 4;
+ }
+
+/* Check for argument errors. */
+
+ *info = 0;
+ if (itype == 0) {
+ *info = -1;
+ } else if (*m < 0) {
+ *info = -3;
+ } else if (*n < 0 || itype == 3 && *n != *m) {
+ *info = -4;
+ } else if (*lda < *m) {
+ *info = -6;
+ }
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLAROR", &i__1);
+ return 0;
+ }
+
+ if (itype == 1) {
+ nxfrm = *m;
+ } else {
+ nxfrm = *n;
+ }
+
+/* Initialize A to the identity matrix if desired */
+
+ if (lsame_(init, "I")) {
+ zlaset_("Full", m, n, &c_b1, &c_b2, &a[a_offset], lda);
+ }
+
+/* If no rotation possible, still multiply by */
+/* a random complex number from the circle |x| = 1 */
+
+/* 2) Compute Rotation by computing Householder */
+/* Transformations H(2), H(3), ..., H(n). Note that the */
+/* order in which they are computed is irrelevant. */
+
+ i__1 = nxfrm;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ x[i__2].r = 0., x[i__2].i = 0.;
+/* L10: */
+ }
+
+ i__1 = nxfrm;
+ for (ixfrm = 2; ixfrm <= i__1; ++ixfrm) {
+ kbeg = nxfrm - ixfrm + 1;
+
+/* Generate independent normal( 0, 1 ) random numbers */
+
+ i__2 = nxfrm;
+ for (j = kbeg; j <= i__2; ++j) {
+ i__3 = j;
+ zlarnd_(&z__1, &c__3, &iseed[1]);
+ x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+/* L20: */
+ }
+
+/* Generate a Householder transformation from the random vector X */
+
+ xnorm = dznrm2_(&ixfrm, &x[kbeg], &c__1);
+ xabs = z_abs(&x[kbeg]);
+ if (xabs != 0.) {
+ i__2 = kbeg;
+ z__1.r = x[i__2].r / xabs, z__1.i = x[i__2].i / xabs;
+ csign.r = z__1.r, csign.i = z__1.i;
+ } else {
+ csign.r = 1., csign.i = 0.;
+ }
+ z__1.r = xnorm * csign.r, z__1.i = xnorm * csign.i;
+ xnorms.r = z__1.r, xnorms.i = z__1.i;
+ i__2 = nxfrm + kbeg;
+ z__1.r = -csign.r, z__1.i = -csign.i;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+ factor = xnorm * (xnorm + xabs);
+ if (abs(factor) < 1e-20) {
+ *info = 1;
+ i__2 = -(*info);
+ xerbla_("ZLAROR", &i__2);
+ return 0;
+ } else {
+ factor = 1. / factor;
+ }
+ i__2 = kbeg;
+ i__3 = kbeg;
+ z__1.r = x[i__3].r + xnorms.r, z__1.i = x[i__3].i + xnorms.i;
+ x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+
+/* Apply Householder transformation to A */
+
+ if (itype == 1 || itype == 3 || itype == 4) {
+
+/* Apply H(k) on the left of A */
+
+ zgemv_("C", &ixfrm, n, &c_b2, &a[kbeg + a_dim1], lda, &x[kbeg], &
+ c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1);
+ z__2.r = factor, z__2.i = 0.;
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ zgerc_(&ixfrm, n, &z__1, &x[kbeg], &c__1, &x[(nxfrm << 1) + 1], &
+ c__1, &a[kbeg + a_dim1], lda);
+
+ }
+
+ if (itype >= 2 && itype <= 4) {
+
+/* Apply H(k)* (or H(k)') on the right of A */
+
+ if (itype == 4) {
+ zlacgv_(&ixfrm, &x[kbeg], &c__1);
+ }
+
+ zgemv_("N", m, &ixfrm, &c_b2, &a[kbeg * a_dim1 + 1], lda, &x[kbeg]
+, &c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1);
+ z__2.r = factor, z__2.i = 0.;
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ zgerc_(m, &ixfrm, &z__1, &x[(nxfrm << 1) + 1], &c__1, &x[kbeg], &
+ c__1, &a[kbeg * a_dim1 + 1], lda);
+
+ }
+/* L30: */
+ }
+
+ zlarnd_(&z__1, &c__3, &iseed[1]);
+ x[1].r = z__1.r, x[1].i = z__1.i;
+ xabs = z_abs(&x[1]);
+ if (xabs != 0.) {
+ z__1.r = x[1].r / xabs, z__1.i = x[1].i / xabs;
+ csign.r = z__1.r, csign.i = z__1.i;
+ } else {
+ csign.r = 1., csign.i = 0.;
+ }
+ i__1 = nxfrm << 1;
+ x[i__1].r = csign.r, x[i__1].i = csign.i;
+
+/* Scale the matrix A by D. */
+
+ if (itype == 1 || itype == 3 || itype == 4) {
+ i__1 = *m;
+ for (irow = 1; irow <= i__1; ++irow) {
+ d_cnjg(&z__1, &x[nxfrm + irow]);
+ zscal_(n, &z__1, &a[irow + a_dim1], lda);
+/* L40: */
+ }
+ }
+
+ if (itype == 2 || itype == 3) {
+ i__1 = *n;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ zscal_(m, &x[nxfrm + jcol], &a[jcol * a_dim1 + 1], &c__1);
+/* L50: */
+ }
+ }
+
+ if (itype == 4) {
+ i__1 = *n;
+ for (jcol = 1; jcol <= i__1; ++jcol) {
+ d_cnjg(&z__1, &x[nxfrm + jcol]);
+ zscal_(m, &z__1, &a[jcol * a_dim1 + 1], &c__1);
+/* L60: */
+ }
+ }
+ return 0;
+
+/* End of ZLAROR */
+
+} /* zlaror_ */
diff --git a/TESTING/MATGEN/zlarot.c b/TESTING/MATGEN/zlarot.c
new file mode 100644
index 0000000..8e29030
--- /dev/null
+++ b/TESTING/MATGEN/zlarot.c
@@ -0,0 +1,374 @@
+/* zlarot.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__4 = 4;
+static integer c__8 = 8;
+
+/* Subroutine */ int zlarot_(logical *lrows, logical *lleft, logical *lright,
+ integer *nl, doublecomplex *c__, doublecomplex *s, doublecomplex *a,
+ integer *lda, doublecomplex *xleft, doublecomplex *xright)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3, i__4;
+ doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer j, ix, iy, nt;
+ doublecomplex xt[2], yt[2];
+ integer iyt, iinc, inext;
+ doublecomplex tempx;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLAROT applies a (Givens) rotation to two adjacent rows or */
+/* columns, where one element of the first and/or last column/row */
+/* for use on matrices stored in some format other than GE, so */
+/* that elements of the matrix may be used or modified for which */
+/* no array element is provided. */
+
+/* One example is a symmetric matrix in SB format (bandwidth=4), for */
+/* which UPLO='L': Two adjacent rows will have the format: */
+
+/* row j: * * * * * . . . . */
+/* row j+1: * * * * * . . . . */
+
+/* '*' indicates elements for which storage is provided, */
+/* '.' indicates elements for which no storage is provided, but */
+/* are not necessarily zero; their values are determined by */
+/* symmetry. ' ' indicates elements which are necessarily zero, */
+/* and have no storage provided. */
+
+/* Those columns which have two '*'s can be handled by DROT. */
+/* Those columns which have no '*'s can be ignored, since as long */
+/* as the Givens rotations are carefully applied to preserve */
+/* symmetry, their values are determined. */
+/* Those columns which have one '*' have to be handled separately, */
+/* by using separate variables "p" and "q": */
+
+/* row j: * * * * * p . . . */
+/* row j+1: q * * * * * . . . . */
+
+/* The element p would have to be set correctly, then that column */
+/* is rotated, setting p to its new value. The next call to */
+/* ZLAROT would rotate columns j and j+1, using p, and restore */
+/* symmetry. The element q would start out being zero, and be */
+/* made non-zero by the rotation. Later, rotations would presumably */
+/* be chosen to zero q out. */
+
+/* Typical Calling Sequences: rotating the i-th and (i+1)-st rows. */
+/* ------- ------- --------- */
+
+/* General dense matrix: */
+
+/* CALL ZLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S, */
+/* A(i,1),LDA, DUMMY, DUMMY) */
+
+/* General banded matrix in GB format: */
+
+/* j = MAX(1, i-KL ) */
+/* NL = MIN( N, i+KU+1 ) + 1-j */
+/* CALL ZLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S, */
+/* A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT ) */
+
+/* [ note that i+1-j is just MIN(i,KL+1) ] */
+
+/* Symmetric banded matrix in SY format, bandwidth K, */
+/* lower triangle only: */
+
+/* j = MAX(1, i-K ) */
+/* NL = MIN( K+1, i ) + 1 */
+/* CALL ZLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S, */
+/* A(i,j), LDA, XLEFT, XRIGHT ) */
+
+/* Same, but upper triangle only: */
+
+/* NL = MIN( K+1, N-i ) + 1 */
+/* CALL ZLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S, */
+/* A(i,i), LDA, XLEFT, XRIGHT ) */
+
+/* Symmetric banded matrix in SB format, bandwidth K, */
+/* lower triangle only: */
+
+/* [ same as for SY, except:] */
+/* . . . . */
+/* A(i+1-j,j), LDA-1, XLEFT, XRIGHT ) */
+
+/* [ note that i+1-j is just MIN(i,K+1) ] */
+
+/* Same, but upper triangle only: */
+/* . . . */
+/* A(K+1,i), LDA-1, XLEFT, XRIGHT ) */
+
+/* Rotating columns is just the transpose of rotating rows, except */
+/* for GB and SB: (rotating columns i and i+1) */
+
+/* GB: */
+/* j = MAX(1, i-KU ) */
+/* NL = MIN( N, i+KL+1 ) + 1-j */
+/* CALL ZLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S, */
+/* A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM ) */
+
+/* [note that KU+j+1-i is just MAX(1,KU+2-i)] */
+
+/* SB: (upper triangle) */
+
+/* . . . . . . */
+/* A(K+j+1-i,i),LDA-1, XTOP, XBOTTM ) */
+
+/* SB: (lower triangle) */
+
+/* . . . . . . */
+/* A(1,i),LDA-1, XTOP, XBOTTM ) */
+
+/* Arguments */
+/* ========= */
+
+/* LROWS - LOGICAL */
+/* If .TRUE., then ZLAROT will rotate two rows. If .FALSE., */
+/* then it will rotate two columns. */
+/* Not modified. */
+
+/* LLEFT - LOGICAL */
+/* If .TRUE., then XLEFT will be used instead of the */
+/* corresponding element of A for the first element in the */
+/* second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) */
+/* If .FALSE., then the corresponding element of A will be */
+/* used. */
+/* Not modified. */
+
+/* LRIGHT - LOGICAL */
+/* If .TRUE., then XRIGHT will be used instead of the */
+/* corresponding element of A for the last element in the */
+/* first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If */
+/* .FALSE., then the corresponding element of A will be used. */
+/* Not modified. */
+
+/* NL - INTEGER */
+/* The length of the rows (if LROWS=.TRUE.) or columns (if */
+/* LROWS=.FALSE.) to be rotated. If XLEFT and/or XRIGHT are */
+/* used, the columns/rows they are in should be included in */
+/* NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at */
+/* least 2. The number of rows/columns to be rotated */
+/* exclusive of those involving XLEFT and/or XRIGHT may */
+/* not be negative, i.e., NL minus how many of LLEFT and */
+/* LRIGHT are .TRUE. must be at least zero; if not, XERBLA */
+/* will be called. */
+/* Not modified. */
+
+/* C, S - COMPLEX*16 */
+/* Specify the Givens rotation to be applied. If LROWS is */
+/* true, then the matrix ( c s ) */
+/* ( _ _ ) */
+/* (-s c ) is applied from the left; */
+/* if false, then the transpose (not conjugated) thereof is */
+/* applied from the right. Note that in contrast to the */
+/* output of ZROTG or to most versions of ZROT, both C and S */
+/* are complex. For a Givens rotation, |C|**2 + |S|**2 should */
+/* be 1, but this is not checked. */
+/* Not modified. */
+
+/* A - COMPLEX*16 array. */
+/* The array containing the rows/columns to be rotated. The */
+/* first element of A should be the upper left element to */
+/* be rotated. */
+/* Read and modified. */
+
+/* LDA - INTEGER */
+/* The "effective" leading dimension of A. If A contains */
+/* a matrix stored in GE, HE, or SY format, then this is just */
+/* the leading dimension of A as dimensioned in the calling */
+/* routine. If A contains a matrix stored in band (GB, HB, or */
+/* SB) format, then this should be *one less* than the leading */
+/* dimension used in the calling routine. Thus, if A were */
+/* dimensioned A(LDA,*) in ZLAROT, then A(1,j) would be the */
+/* j-th element in the first of the two rows to be rotated, */
+/* and A(2,j) would be the j-th in the second, regardless of */
+/* how the array may be stored in the calling routine. [A */
+/* cannot, however, actually be dimensioned thus, since for */
+/* band format, the row number may exceed LDA, which is not */
+/* legal FORTRAN.] */
+/* If LROWS=.TRUE., then LDA must be at least 1, otherwise */
+/* it must be at least NL minus the number of .TRUE. values */
+/* in XLEFT and XRIGHT. */
+/* Not modified. */
+
+/* XLEFT - COMPLEX*16 */
+/* If LLEFT is .TRUE., then XLEFT will be used and modified */
+/* instead of A(2,1) (if LROWS=.TRUE.) or A(1,2) */
+/* (if LROWS=.FALSE.). */
+/* Read and modified. */
+
+/* XRIGHT - COMPLEX*16 */
+/* If LRIGHT is .TRUE., then XRIGHT will be used and modified */
+/* instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1) */
+/* (if LROWS=.FALSE.). */
+/* Read and modified. */
+
+/* ===================================================================== */
+
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Set up indices, arrays for ends */
+
+ /* Parameter adjustments */
+ --a;
+
+ /* Function Body */
+ if (*lrows) {
+ iinc = *lda;
+ inext = 1;
+ } else {
+ iinc = 1;
+ inext = *lda;
+ }
+
+ if (*lleft) {
+ nt = 1;
+ ix = iinc + 1;
+ iy = *lda + 2;
+ xt[0].r = a[1].r, xt[0].i = a[1].i;
+ yt[0].r = xleft->r, yt[0].i = xleft->i;
+ } else {
+ nt = 0;
+ ix = 1;
+ iy = inext + 1;
+ }
+
+ if (*lright) {
+ iyt = inext + 1 + (*nl - 1) * iinc;
+ ++nt;
+ i__1 = nt - 1;
+ xt[i__1].r = xright->r, xt[i__1].i = xright->i;
+ i__1 = nt - 1;
+ i__2 = iyt;
+ yt[i__1].r = a[i__2].r, yt[i__1].i = a[i__2].i;
+ }
+
+/* Check for errors */
+
+ if (*nl < nt) {
+ xerbla_("ZLAROT", &c__4);
+ return 0;
+ }
+ if (*lda <= 0 || ! (*lrows) && *lda < *nl - nt) {
+ xerbla_("ZLAROT", &c__8);
+ return 0;
+ }
+
+/* Rotate */
+
+/* ZROT( NL-NT, A(IX),IINC, A(IY),IINC, C, S ) with complex C, S */
+
+ i__1 = *nl - nt - 1;
+ for (j = 0; j <= i__1; ++j) {
+ i__2 = ix + j * iinc;
+ z__2.r = c__->r * a[i__2].r - c__->i * a[i__2].i, z__2.i = c__->r * a[
+ i__2].i + c__->i * a[i__2].r;
+ i__3 = iy + j * iinc;
+ z__3.r = s->r * a[i__3].r - s->i * a[i__3].i, z__3.i = s->r * a[i__3]
+ .i + s->i * a[i__3].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ tempx.r = z__1.r, tempx.i = z__1.i;
+ i__2 = iy + j * iinc;
+ d_cnjg(&z__4, s);
+ z__3.r = -z__4.r, z__3.i = -z__4.i;
+ i__3 = ix + j * iinc;
+ z__2.r = z__3.r * a[i__3].r - z__3.i * a[i__3].i, z__2.i = z__3.r * a[
+ i__3].i + z__3.i * a[i__3].r;
+ d_cnjg(&z__6, c__);
+ i__4 = iy + j * iinc;
+ z__5.r = z__6.r * a[i__4].r - z__6.i * a[i__4].i, z__5.i = z__6.r * a[
+ i__4].i + z__6.i * a[i__4].r;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ i__2 = ix + j * iinc;
+ a[i__2].r = tempx.r, a[i__2].i = tempx.i;
+/* L10: */
+ }
+
+/* ZROT( NT, XT,1, YT,1, C, S ) with complex C, S */
+
+ i__1 = nt;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j - 1;
+ z__2.r = c__->r * xt[i__2].r - c__->i * xt[i__2].i, z__2.i = c__->r *
+ xt[i__2].i + c__->i * xt[i__2].r;
+ i__3 = j - 1;
+ z__3.r = s->r * yt[i__3].r - s->i * yt[i__3].i, z__3.i = s->r * yt[
+ i__3].i + s->i * yt[i__3].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ tempx.r = z__1.r, tempx.i = z__1.i;
+ i__2 = j - 1;
+ d_cnjg(&z__4, s);
+ z__3.r = -z__4.r, z__3.i = -z__4.i;
+ i__3 = j - 1;
+ z__2.r = z__3.r * xt[i__3].r - z__3.i * xt[i__3].i, z__2.i = z__3.r *
+ xt[i__3].i + z__3.i * xt[i__3].r;
+ d_cnjg(&z__6, c__);
+ i__4 = j - 1;
+ z__5.r = z__6.r * yt[i__4].r - z__6.i * yt[i__4].i, z__5.i = z__6.r *
+ yt[i__4].i + z__6.i * yt[i__4].r;
+ z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+ yt[i__2].r = z__1.r, yt[i__2].i = z__1.i;
+ i__2 = j - 1;
+ xt[i__2].r = tempx.r, xt[i__2].i = tempx.i;
+/* L20: */
+ }
+
+/* Stuff values back into XLEFT, XRIGHT, etc. */
+
+ if (*lleft) {
+ a[1].r = xt[0].r, a[1].i = xt[0].i;
+ xleft->r = yt[0].r, xleft->i = yt[0].i;
+ }
+
+ if (*lright) {
+ i__1 = nt - 1;
+ xright->r = xt[i__1].r, xright->i = xt[i__1].i;
+ i__1 = iyt;
+ i__2 = nt - 1;
+ a[i__1].r = yt[i__2].r, a[i__1].i = yt[i__2].i;
+ }
+
+ return 0;
+
+/* End of ZLAROT */
+
+} /* zlarot_ */
diff --git a/TESTING/MATGEN/zlatm1.c b/TESTING/MATGEN/zlatm1.c
new file mode 100644
index 0000000..04e9990
--- /dev/null
+++ b/TESTING/MATGEN/zlatm1.c
@@ -0,0 +1,314 @@
+/* zlatm1.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__3 = 3;
+
+/* Subroutine */ int zlatm1_(integer *mode, doublereal *cond, integer *irsign,
+ integer *idist, integer *iseed, doublecomplex *d__, integer *n,
+ integer *info)
+{
+ /* System generated locals */
+ integer i__1, i__2, i__3;
+ doublereal d__1;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double pow_dd(doublereal *, doublereal *), pow_di(doublereal *, integer *)
+ , log(doublereal), exp(doublereal), z_abs(doublecomplex *);
+
+ /* Local variables */
+ integer i__;
+ doublereal temp, alpha;
+ doublecomplex ctemp;
+ extern doublereal dlaran_(integer *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
+ integer *);
+ extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *,
+ doublecomplex *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLATM1 computes the entries of D(1..N) as specified by */
+/* MODE, COND and IRSIGN. IDIST and ISEED determine the generation */
+/* of random numbers. ZLATM1 is called by CLATMR to generate */
+/* random test matrices for LAPACK programs. */
+
+/* Arguments */
+/* ========= */
+
+/* MODE - INTEGER */
+/* On entry describes how D is to be computed: */
+/* MODE = 0 means do not change D. */
+/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
+/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
+/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
+/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* MODE = 5 sets D to random numbers in the range */
+/* ( 1/COND , 1 ) such that their logarithms */
+/* are uniformly distributed. */
+/* MODE = 6 set D to random numbers from same distribution */
+/* as the rest of the matrix. */
+/* MODE < 0 has the same meaning as ABS(MODE), except that */
+/* the order of the elements of D is reversed. */
+/* Thus if MODE is positive, D has entries ranging from */
+/* 1 to 1/COND, if negative, from 1/COND to 1, */
+/* Not modified. */
+
+/* COND - DOUBLE PRECISION */
+/* On entry, used as described under MODE above. */
+/* If used, it must be >= 1. Not modified. */
+
+/* IRSIGN - INTEGER */
+/* On entry, if MODE neither -6, 0 nor 6, determines sign of */
+/* entries of D */
+/* 0 => leave entries of D unchanged */
+/* 1 => multiply each entry of D by random complex number */
+/* uniformly distributed with absolute value 1 */
+
+/* IDIST - CHARACTER*1 */
+/* On entry, IDIST specifies the type of distribution to be */
+/* used to generate a random matrix . */
+/* 1 => real and imaginary parts each UNIFORM( 0, 1 ) */
+/* 2 => real and imaginary parts each UNIFORM( -1, 1 ) */
+/* 3 => real and imaginary parts each NORMAL( 0, 1 ) */
+/* 4 => complex number uniform in DISK( 0, 1 ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension ( 4 ) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. The random number generator uses a */
+/* linear congruential sequence limited to small */
+/* integers, and so should produce machine independent */
+/* random numbers. The values of ISEED are changed on */
+/* exit, and can be used in the next call to ZLATM1 */
+/* to continue the same random number sequence. */
+/* Changed on exit. */
+
+/* D - COMPLEX*16 array, dimension ( MIN( M , N ) ) */
+/* Array to be computed according to MODE, COND and IRSIGN. */
+/* May be changed on exit if MODE is nonzero. */
+
+/* N - INTEGER */
+/* Number of entries of D. Not modified. */
+
+/* INFO - INTEGER */
+/* 0 => normal termination */
+/* -1 => if MODE not in range -6 to 6 */
+/* -2 => if MODE neither -6, 0 nor 6, and */
+/* IRSIGN neither 0 nor 1 */
+/* -3 => if MODE neither -6, 0 nor 6 and COND less than 1 */
+/* -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 4 */
+/* -7 => if N negative */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Decode and Test the input parameters. Initialize flags & seed. */
+
+ /* Parameter adjustments */
+ --d__;
+ --iseed;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Set INFO if an error */
+
+ if (*mode < -6 || *mode > 6) {
+ *info = -1;
+ } else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && *
+ irsign != 1)) {
+ *info = -2;
+ } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.) {
+ *info = -3;
+ } else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 4)) {
+ *info = -4;
+ } else if (*n < 0) {
+ *info = -7;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLATM1", &i__1);
+ return 0;
+ }
+
+/* Compute D according to COND and MODE */
+
+ if (*mode != 0) {
+ switch (abs(*mode)) {
+ case 1: goto L10;
+ case 2: goto L30;
+ case 3: goto L50;
+ case 4: goto L70;
+ case 5: goto L90;
+ case 6: goto L110;
+ }
+
+/* One large D value: */
+
+L10:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ d__1 = 1. / *cond;
+ d__[i__2].r = d__1, d__[i__2].i = 0.;
+/* L20: */
+ }
+ d__[1].r = 1., d__[1].i = 0.;
+ goto L120;
+
+/* One small D value: */
+
+L30:
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ d__[i__2].r = 1., d__[i__2].i = 0.;
+/* L40: */
+ }
+ i__1 = *n;
+ d__1 = 1. / *cond;
+ d__[i__1].r = d__1, d__[i__1].i = 0.;
+ goto L120;
+
+/* Exponentially distributed D values: */
+
+L50:
+ d__[1].r = 1., d__[1].i = 0.;
+ if (*n > 1) {
+ d__1 = -1. / (doublereal) (*n - 1);
+ alpha = pow_dd(cond, &d__1);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__ - 1;
+ d__1 = pow_di(&alpha, &i__3);
+ d__[i__2].r = d__1, d__[i__2].i = 0.;
+/* L60: */
+ }
+ }
+ goto L120;
+
+/* Arithmetically distributed D values: */
+
+L70:
+ d__[1].r = 1., d__[1].i = 0.;
+ if (*n > 1) {
+ temp = 1. / *cond;
+ alpha = (1. - temp) / (doublereal) (*n - 1);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ d__1 = (doublereal) (*n - i__) * alpha + temp;
+ d__[i__2].r = d__1, d__[i__2].i = 0.;
+/* L80: */
+ }
+ }
+ goto L120;
+
+/* Randomly distributed D values on ( 1/COND , 1): */
+
+L90:
+ alpha = log(1. / *cond);
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ d__1 = exp(alpha * dlaran_(&iseed[1]));
+ d__[i__2].r = d__1, d__[i__2].i = 0.;
+/* L100: */
+ }
+ goto L120;
+
+/* Randomly distributed D values from IDIST */
+
+L110:
+ zlarnv_(idist, &iseed[1], n, &d__[1]);
+
+L120:
+
+/* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */
+/* random signs to D */
+
+ if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) {
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ zlarnd_(&z__1, &c__3, &iseed[1]);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__2 = i__;
+ i__3 = i__;
+ d__1 = z_abs(&ctemp);
+ z__2.r = ctemp.r / d__1, z__2.i = ctemp.i / d__1;
+ z__1.r = d__[i__3].r * z__2.r - d__[i__3].i * z__2.i, z__1.i =
+ d__[i__3].r * z__2.i + d__[i__3].i * z__2.r;
+ d__[i__2].r = z__1.r, d__[i__2].i = z__1.i;
+/* L130: */
+ }
+ }
+
+/* Reverse if MODE < 0 */
+
+ if (*mode < 0) {
+ i__1 = *n / 2;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ ctemp.r = d__[i__2].r, ctemp.i = d__[i__2].i;
+ i__2 = i__;
+ i__3 = *n + 1 - i__;
+ d__[i__2].r = d__[i__3].r, d__[i__2].i = d__[i__3].i;
+ i__2 = *n + 1 - i__;
+ d__[i__2].r = ctemp.r, d__[i__2].i = ctemp.i;
+/* L140: */
+ }
+ }
+
+ }
+
+ return 0;
+
+/* End of ZLATM1 */
+
+} /* zlatm1_ */
diff --git a/TESTING/MATGEN/zlatm2.c b/TESTING/MATGEN/zlatm2.c
new file mode 100644
index 0000000..229885a
--- /dev/null
+++ b/TESTING/MATGEN/zlatm2.c
@@ -0,0 +1,298 @@
+/* zlatm2.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Double Complex */ VOID zlatm2_(doublecomplex * ret_val, integer *m,
+ integer *n, integer *i__, integer *j, integer *kl, integer *ku,
+ integer *idist, integer *iseed, doublecomplex *d__, integer *igrade,
+ doublecomplex *dl, doublecomplex *dr, integer *ipvtng, integer *iwork,
+ doublereal *sparse)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
+ doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer isub, jsub;
+ doublecomplex ctemp;
+ extern doublereal dlaran_(integer *);
+ extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
+ integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+
+/* .. */
+
+/* .. Array Arguments .. */
+
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLATM2 returns the (I,J) entry of a random matrix of dimension */
+/* (M, N) described by the other paramters. It is called by the */
+/* ZLATMR routine in order to build random test matrices. No error */
+/* checking on parameters is done, because this routine is called in */
+/* a tight loop by ZLATMR which has already checked the parameters. */
+
+/* Use of ZLATM2 differs from CLATM3 in the order in which the random */
+/* number generator is called to fill in random matrix entries. */
+/* With ZLATM2, the generator is called to fill in the pivoted matrix */
+/* columnwise. With ZLATM3, the generator is called to fill in the */
+/* matrix columnwise, after which it is pivoted. Thus, ZLATM3 can */
+/* be used to construct random matrices which differ only in their */
+/* order of rows and/or columns. ZLATM2 is used to construct band */
+/* matrices while avoiding calling the random number generator for */
+/* entries outside the band (and therefore generating random numbers */
+
+/* The matrix whose (I,J) entry is returned is constructed as */
+/* follows (this routine only computes one entry): */
+
+/* If I is outside (1..M) or J is outside (1..N), return zero */
+/* (this is convenient for generating matrices in band format). */
+
+/* Generate a matrix A with random entries of distribution IDIST. */
+
+/* Set the diagonal to D. */
+
+/* Grade the matrix, if desired, from the left (by DL) and/or */
+/* from the right (by DR or DL) as specified by IGRADE. */
+
+/* Permute, if desired, the rows and/or columns as specified by */
+/* IPVTNG and IWORK. */
+
+/* Band the matrix to have lower bandwidth KL and upper */
+/* bandwidth KU. */
+
+/* Set random entries to zero as specified by SPARSE. */
+
+/* Arguments */
+/* ========= */
+
+/* M - INTEGER */
+/* Number of rows of matrix. Not modified. */
+
+/* N - INTEGER */
+/* Number of columns of matrix. Not modified. */
+
+/* I - INTEGER */
+/* Row of entry to be returned. Not modified. */
+
+/* J - INTEGER */
+/* Column of entry to be returned. Not modified. */
+
+/* KL - INTEGER */
+/* Lower bandwidth. Not modified. */
+
+/* KU - INTEGER */
+/* Upper bandwidth. Not modified. */
+
+/* IDIST - INTEGER */
+/* On entry, IDIST specifies the type of distribution to be */
+/* used to generate a random matrix . */
+/* 1 => real and imaginary parts each UNIFORM( 0, 1 ) */
+/* 2 => real and imaginary parts each UNIFORM( -1, 1 ) */
+/* 3 => real and imaginary parts each NORMAL( 0, 1 ) */
+/* 4 => complex number uniform in DISK( 0 , 1 ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array of dimension ( 4 ) */
+/* Seed for random number generator. */
+/* Changed on exit. */
+
+/* D - COMPLEX*16 array of dimension ( MIN( I , J ) ) */
+/* Diagonal entries of matrix. Not modified. */
+
+/* IGRADE - INTEGER */
+/* Specifies grading of matrix as follows: */
+/* 0 => no grading */
+/* 1 => matrix premultiplied by diag( DL ) */
+/* 2 => matrix postmultiplied by diag( DR ) */
+/* 3 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DR ) */
+/* 4 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by inv( diag( DL ) ) */
+/* 5 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( CONJG(DL) ) */
+/* 6 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DL ) */
+/* Not modified. */
+
+/* DL - COMPLEX*16 array ( I or J, as appropriate ) */
+/* Left scale factors for grading matrix. Not modified. */
+
+/* DR - COMPLEX*16 array ( I or J, as appropriate ) */
+/* Right scale factors for grading matrix. Not modified. */
+
+/* IPVTNG - INTEGER */
+/* On entry specifies pivoting permutations as follows: */
+/* 0 => none. */
+/* 1 => row pivoting. */
+/* 2 => column pivoting. */
+/* 3 => full pivoting, i.e., on both sides. */
+/* Not modified. */
+
+/* IWORK - INTEGER array ( I or J, as appropriate ) */
+/* This array specifies the permutation used. The */
+/* row (or column) in position K was originally in */
+/* position IWORK( K ). */
+/* This differs from IWORK for ZLATM3. Not modified. */
+
+/* SPARSE - DOUBLE PRECISION between 0. and 1. */
+/* On entry specifies the sparsity of the matrix */
+/* if sparse matix is to be generated. */
+/* SPARSE should lie between 0 and 1. */
+/* A uniform ( 0, 1 ) random number x is generated and */
+/* compared to SPARSE; if x is larger the matrix entry */
+/* is unchanged and if x is smaller the entry is set */
+/* to zero. Thus on the average a fraction SPARSE of the */
+/* entries will be set to zero. */
+/* Not modified. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+
+/* .. */
+
+/* .. Local Scalars .. */
+
+/* .. */
+
+/* .. External Functions .. */
+
+/* .. */
+
+/* .. Intrinsic Functions .. */
+
+/* .. */
+
+/* ----------------------------------------------------------------------- */
+
+/* .. Executable Statements .. */
+
+
+/* Check for I and J in range */
+
+ /* Parameter adjustments */
+ --iwork;
+ --dr;
+ --dl;
+ --d__;
+ --iseed;
+
+ /* Function Body */
+ if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) {
+ ret_val->r = 0., ret_val->i = 0.;
+ return ;
+ }
+
+/* Check for banding */
+
+ if (*j > *i__ + *ku || *j < *i__ - *kl) {
+ ret_val->r = 0., ret_val->i = 0.;
+ return ;
+ }
+
+/* Check for sparsity */
+
+ if (*sparse > 0.) {
+ if (dlaran_(&iseed[1]) < *sparse) {
+ ret_val->r = 0., ret_val->i = 0.;
+ return ;
+ }
+ }
+
+/* Compute subscripts depending on IPVTNG */
+
+ if (*ipvtng == 0) {
+ isub = *i__;
+ jsub = *j;
+ } else if (*ipvtng == 1) {
+ isub = iwork[*i__];
+ jsub = *j;
+ } else if (*ipvtng == 2) {
+ isub = *i__;
+ jsub = iwork[*j];
+ } else if (*ipvtng == 3) {
+ isub = iwork[*i__];
+ jsub = iwork[*j];
+ }
+
+/* Compute entry and grade it according to IGRADE */
+
+ if (isub == jsub) {
+ i__1 = isub;
+ ctemp.r = d__[i__1].r, ctemp.i = d__[i__1].i;
+ } else {
+ zlarnd_(&z__1, idist, &iseed[1]);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ }
+ if (*igrade == 1) {
+ i__1 = isub;
+ z__1.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__1.i =
+ ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ } else if (*igrade == 2) {
+ i__1 = jsub;
+ z__1.r = ctemp.r * dr[i__1].r - ctemp.i * dr[i__1].i, z__1.i =
+ ctemp.r * dr[i__1].i + ctemp.i * dr[i__1].r;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ } else if (*igrade == 3) {
+ i__1 = isub;
+ z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
+ ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+ i__2 = jsub;
+ z__1.r = z__2.r * dr[i__2].r - z__2.i * dr[i__2].i, z__1.i = z__2.r *
+ dr[i__2].i + z__2.i * dr[i__2].r;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ } else if (*igrade == 4 && isub != jsub) {
+ i__1 = isub;
+ z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
+ ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+ z_div(&z__1, &z__2, &dl[jsub]);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ } else if (*igrade == 5) {
+ i__1 = isub;
+ z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
+ ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+ d_cnjg(&z__3, &dl[jsub]);
+ z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i
+ + z__2.i * z__3.r;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ } else if (*igrade == 6) {
+ i__1 = isub;
+ z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
+ ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+ i__2 = jsub;
+ z__1.r = z__2.r * dl[i__2].r - z__2.i * dl[i__2].i, z__1.i = z__2.r *
+ dl[i__2].i + z__2.i * dl[i__2].r;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ }
+ ret_val->r = ctemp.r, ret_val->i = ctemp.i;
+ return ;
+
+/* End of ZLATM2 */
+
+} /* zlatm2_ */
diff --git a/TESTING/MATGEN/zlatm3.c b/TESTING/MATGEN/zlatm3.c
new file mode 100644
index 0000000..c68673a
--- /dev/null
+++ b/TESTING/MATGEN/zlatm3.c
@@ -0,0 +1,308 @@
+/* zlatm3.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Double Complex */ VOID zlatm3_(doublecomplex * ret_val, integer *m,
+ integer *n, integer *i__, integer *j, integer *isub, integer *jsub,
+ integer *kl, integer *ku, integer *idist, integer *iseed,
+ doublecomplex *d__, integer *igrade, doublecomplex *dl, doublecomplex
+ *dr, integer *ipvtng, integer *iwork, doublereal *sparse)
+{
+ /* System generated locals */
+ integer i__1, i__2;
+ doublecomplex z__1, z__2, z__3;
+
+ /* Builtin functions */
+ void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
+ doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ doublecomplex ctemp;
+ extern doublereal dlaran_(integer *);
+ extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
+ integer *);
+
+
+/* -- LAPACK auxiliary test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+
+/* .. */
+
+/* .. Array Arguments .. */
+
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLATM3 returns the (ISUB,JSUB) entry of a random matrix of */
+/* dimension (M, N) described by the other paramters. (ISUB,JSUB) */
+/* is the final position of the (I,J) entry after pivoting */
+/* according to IPVTNG and IWORK. ZLATM3 is called by the */
+/* ZLATMR routine in order to build random test matrices. No error */
+/* checking on parameters is done, because this routine is called in */
+/* a tight loop by ZLATMR which has already checked the parameters. */
+
+/* Use of ZLATM3 differs from CLATM2 in the order in which the random */
+/* number generator is called to fill in random matrix entries. */
+/* With ZLATM2, the generator is called to fill in the pivoted matrix */
+/* columnwise. With ZLATM3, the generator is called to fill in the */
+/* matrix columnwise, after which it is pivoted. Thus, ZLATM3 can */
+/* be used to construct random matrices which differ only in their */
+/* order of rows and/or columns. ZLATM2 is used to construct band */
+/* matrices while avoiding calling the random number generator for */
+/* entries outside the band (and therefore generating random numbers */
+/* in different orders for different pivot orders). */
+
+/* The matrix whose (ISUB,JSUB) entry is returned is constructed as */
+/* follows (this routine only computes one entry): */
+
+/* If ISUB is outside (1..M) or JSUB is outside (1..N), return zero */
+/* (this is convenient for generating matrices in band format). */
+
+/* Generate a matrix A with random entries of distribution IDIST. */
+
+/* Set the diagonal to D. */
+
+/* Grade the matrix, if desired, from the left (by DL) and/or */
+/* from the right (by DR or DL) as specified by IGRADE. */
+
+/* Permute, if desired, the rows and/or columns as specified by */
+/* IPVTNG and IWORK. */
+
+/* Band the matrix to have lower bandwidth KL and upper */
+/* bandwidth KU. */
+
+/* Set random entries to zero as specified by SPARSE. */
+
+/* Arguments */
+/* ========= */
+
+/* M - INTEGER */
+/* Number of rows of matrix. Not modified. */
+
+/* N - INTEGER */
+/* Number of columns of matrix. Not modified. */
+
+/* I - INTEGER */
+/* Row of unpivoted entry to be returned. Not modified. */
+
+/* J - INTEGER */
+/* Column of unpivoted entry to be returned. Not modified. */
+
+/* ISUB - INTEGER */
+/* Row of pivoted entry to be returned. Changed on exit. */
+
+/* JSUB - INTEGER */
+/* Column of pivoted entry to be returned. Changed on exit. */
+
+/* KL - INTEGER */
+/* Lower bandwidth. Not modified. */
+
+/* KU - INTEGER */
+/* Upper bandwidth. Not modified. */
+
+/* IDIST - INTEGER */
+/* On entry, IDIST specifies the type of distribution to be */
+/* used to generate a random matrix . */
+/* 1 => real and imaginary parts each UNIFORM( 0, 1 ) */
+/* 2 => real and imaginary parts each UNIFORM( -1, 1 ) */
+/* 3 => real and imaginary parts each NORMAL( 0, 1 ) */
+/* 4 => complex number uniform in DISK( 0 , 1 ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array of dimension ( 4 ) */
+/* Seed for random number generator. */
+/* Changed on exit. */
+
+/* D - COMPLEX*16 array of dimension ( MIN( I , J ) ) */
+/* Diagonal entries of matrix. Not modified. */
+
+/* IGRADE - INTEGER */
+/* Specifies grading of matrix as follows: */
+/* 0 => no grading */
+/* 1 => matrix premultiplied by diag( DL ) */
+/* 2 => matrix postmultiplied by diag( DR ) */
+/* 3 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DR ) */
+/* 4 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by inv( diag( DL ) ) */
+/* 5 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( CONJG(DL) ) */
+/* 6 => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DL ) */
+/* Not modified. */
+
+/* DL - COMPLEX*16 array ( I or J, as appropriate ) */
+/* Left scale factors for grading matrix. Not modified. */
+
+/* DR - COMPLEX*16 array ( I or J, as appropriate ) */
+/* Right scale factors for grading matrix. Not modified. */
+
+/* IPVTNG - INTEGER */
+/* On entry specifies pivoting permutations as follows: */
+/* 0 => none. */
+/* 1 => row pivoting. */
+/* 2 => column pivoting. */
+/* 3 => full pivoting, i.e., on both sides. */
+/* Not modified. */
+
+/* IWORK - INTEGER array ( I or J, as appropriate ) */
+/* This array specifies the permutation used. The */
+/* row (or column) originally in position K is in */
+/* position IWORK( K ) after pivoting. */
+/* This differs from IWORK for ZLATM2. Not modified. */
+
+/* SPARSE - DOUBLE PRECISION between 0. and 1. */
+/* On entry specifies the sparsity of the matrix */
+/* if sparse matix is to be generated. */
+/* SPARSE should lie between 0 and 1. */
+/* A uniform ( 0, 1 ) random number x is generated and */
+/* compared to SPARSE; if x is larger the matrix entry */
+/* is unchanged and if x is smaller the entry is set */
+/* to zero. Thus on the average a fraction SPARSE of the */
+/* entries will be set to zero. */
+/* Not modified. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+
+/* .. */
+
+/* .. Local Scalars .. */
+
+/* .. */
+
+/* .. External Functions .. */
+
+/* .. */
+
+/* .. Intrinsic Functions .. */
+
+/* .. */
+
+/* ----------------------------------------------------------------------- */
+
+/* .. Executable Statements .. */
+
+
+/* Check for I and J in range */
+
+ /* Parameter adjustments */
+ --iwork;
+ --dr;
+ --dl;
+ --d__;
+ --iseed;
+
+ /* Function Body */
+ if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) {
+ *isub = *i__;
+ *jsub = *j;
+ ret_val->r = 0., ret_val->i = 0.;
+ return ;
+ }
+
+/* Compute subscripts depending on IPVTNG */
+
+ if (*ipvtng == 0) {
+ *isub = *i__;
+ *jsub = *j;
+ } else if (*ipvtng == 1) {
+ *isub = iwork[*i__];
+ *jsub = *j;
+ } else if (*ipvtng == 2) {
+ *isub = *i__;
+ *jsub = iwork[*j];
+ } else if (*ipvtng == 3) {
+ *isub = iwork[*i__];
+ *jsub = iwork[*j];
+ }
+
+/* Check for banding */
+
+ if (*jsub > *isub + *ku || *jsub < *isub - *kl) {
+ ret_val->r = 0., ret_val->i = 0.;
+ return ;
+ }
+
+/* Check for sparsity */
+
+ if (*sparse > 0.) {
+ if (dlaran_(&iseed[1]) < *sparse) {
+ ret_val->r = 0., ret_val->i = 0.;
+ return ;
+ }
+ }
+
+/* Compute entry and grade it according to IGRADE */
+
+ if (*i__ == *j) {
+ i__1 = *i__;
+ ctemp.r = d__[i__1].r, ctemp.i = d__[i__1].i;
+ } else {
+ zlarnd_(&z__1, idist, &iseed[1]);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ }
+ if (*igrade == 1) {
+ i__1 = *i__;
+ z__1.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__1.i =
+ ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ } else if (*igrade == 2) {
+ i__1 = *j;
+ z__1.r = ctemp.r * dr[i__1].r - ctemp.i * dr[i__1].i, z__1.i =
+ ctemp.r * dr[i__1].i + ctemp.i * dr[i__1].r;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ } else if (*igrade == 3) {
+ i__1 = *i__;
+ z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
+ ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+ i__2 = *j;
+ z__1.r = z__2.r * dr[i__2].r - z__2.i * dr[i__2].i, z__1.i = z__2.r *
+ dr[i__2].i + z__2.i * dr[i__2].r;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ } else if (*igrade == 4 && *i__ != *j) {
+ i__1 = *i__;
+ z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
+ ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+ z_div(&z__1, &z__2, &dl[*j]);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ } else if (*igrade == 5) {
+ i__1 = *i__;
+ z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
+ ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+ d_cnjg(&z__3, &dl[*j]);
+ z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i
+ + z__2.i * z__3.r;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ } else if (*igrade == 6) {
+ i__1 = *i__;
+ z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
+ ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+ i__2 = *j;
+ z__1.r = z__2.r * dl[i__2].r - z__2.i * dl[i__2].i, z__1.i = z__2.r *
+ dl[i__2].i + z__2.i * dl[i__2].r;
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ }
+ ret_val->r = ctemp.r, ret_val->i = ctemp.i;
+ return ;
+
+/* End of ZLATM3 */
+
+} /* zlatm3_ */
diff --git a/TESTING/MATGEN/zlatm5.c b/TESTING/MATGEN/zlatm5.c
new file mode 100644
index 0000000..2b9854e
--- /dev/null
+++ b/TESTING/MATGEN/zlatm5.c
@@ -0,0 +1,696 @@
+/* zlatm5.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {1.,0.};
+static doublecomplex c_b3 = {0.,0.};
+static doublecomplex c_b5 = {20.,0.};
+
+/* Subroutine */ int zlatm5_(integer *prtype, integer *m, integer *n,
+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
+ doublecomplex *c__, integer *ldc, doublecomplex *d__, integer *ldd,
+ doublecomplex *e, integer *lde, doublecomplex *f, integer *ldf,
+ doublecomplex *r__, integer *ldr, doublecomplex *l, integer *ldl,
+ doublereal *alpha, integer *qblcka, integer *qblckb)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1,
+ d_offset, e_dim1, e_offset, f_dim1, f_offset, l_dim1, l_offset,
+ r_dim1, r_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1;
+ doublecomplex z__1, z__2, z__3, z__4, z__5;
+
+ /* Builtin functions */
+ void z_sin(doublecomplex *, doublecomplex *), z_div(doublecomplex *,
+ doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k;
+ doublecomplex imeps, reeps;
+ extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLATM5 generates matrices involved in the Generalized Sylvester */
+/* equation: */
+
+/* A * R - L * B = C */
+/* D * R - L * E = F */
+
+/* They also satisfy (the diagonalization condition) */
+
+/* [ I -L ] ( [ A -C ], [ D -F ] ) [ I R ] = ( [ A ], [ D ] ) */
+/* [ I ] ( [ B ] [ E ] ) [ I ] ( [ B ] [ E ] ) */
+
+
+/* Arguments */
+/* ========= */
+
+/* PRTYPE (input) INTEGER */
+/* "Points" to a certian type of the matrices to generate */
+/* (see futher details). */
+
+/* M (input) INTEGER */
+/* Specifies the order of A and D and the number of rows in */
+/* C, F, R and L. */
+
+/* N (input) INTEGER */
+/* Specifies the order of B and E and the number of columns in */
+/* C, F, R and L. */
+
+/* A (output) COMPLEX*16 array, dimension (LDA, M). */
+/* On exit A M-by-M is initialized according to PRTYPE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A. */
+
+/* B (output) COMPLEX*16 array, dimension (LDB, N). */
+/* On exit B N-by-N is initialized according to PRTYPE. */
+
+/* LDB (input) INTEGER */
+/* The leading dimension of B. */
+
+/* C (output) COMPLEX*16 array, dimension (LDC, N). */
+/* On exit C M-by-N is initialized according to PRTYPE. */
+
+/* LDC (input) INTEGER */
+/* The leading dimension of C. */
+
+/* D (output) COMPLEX*16 array, dimension (LDD, M). */
+/* On exit D M-by-M is initialized according to PRTYPE. */
+
+/* LDD (input) INTEGER */
+/* The leading dimension of D. */
+
+/* E (output) COMPLEX*16 array, dimension (LDE, N). */
+/* On exit E N-by-N is initialized according to PRTYPE. */
+
+/* LDE (input) INTEGER */
+/* The leading dimension of E. */
+
+/* F (output) COMPLEX*16 array, dimension (LDF, N). */
+/* On exit F M-by-N is initialized according to PRTYPE. */
+
+/* LDF (input) INTEGER */
+/* The leading dimension of F. */
+
+/* R (output) COMPLEX*16 array, dimension (LDR, N). */
+/* On exit R M-by-N is initialized according to PRTYPE. */
+
+/* LDR (input) INTEGER */
+/* The leading dimension of R. */
+
+/* L (output) COMPLEX*16 array, dimension (LDL, N). */
+/* On exit L M-by-N is initialized according to PRTYPE. */
+
+/* LDL (input) INTEGER */
+/* The leading dimension of L. */
+
+/* ALPHA (input) DOUBLE PRECISION */
+/* Parameter used in generating PRTYPE = 1 and 5 matrices. */
+
+/* QBLCKA (input) INTEGER */
+/* When PRTYPE = 3, specifies the distance between 2-by-2 */
+/* blocks on the diagonal in A. Otherwise, QBLCKA is not */
+/* referenced. QBLCKA > 1. */
+
+/* QBLCKB (input) INTEGER */
+/* When PRTYPE = 3, specifies the distance between 2-by-2 */
+/* blocks on the diagonal in B. Otherwise, QBLCKB is not */
+/* referenced. QBLCKB > 1. */
+
+
+/* Further Details */
+/* =============== */
+
+/* PRTYPE = 1: A and B are Jordan blocks, D and E are identity matrices */
+
+/* A : if (i == j) then A(i, j) = 1.0 */
+/* if (j == i + 1) then A(i, j) = -1.0 */
+/* else A(i, j) = 0.0, i, j = 1...M */
+
+/* B : if (i == j) then B(i, j) = 1.0 - ALPHA */
+/* if (j == i + 1) then B(i, j) = 1.0 */
+/* else B(i, j) = 0.0, i, j = 1...N */
+
+/* D : if (i == j) then D(i, j) = 1.0 */
+/* else D(i, j) = 0.0, i, j = 1...M */
+
+/* E : if (i == j) then E(i, j) = 1.0 */
+/* else E(i, j) = 0.0, i, j = 1...N */
+
+/* L = R are chosen from [-10...10], */
+/* which specifies the right hand sides (C, F). */
+
+/* PRTYPE = 2 or 3: Triangular and/or quasi- triangular. */
+
+/* A : if (i <= j) then A(i, j) = [-1...1] */
+/* else A(i, j) = 0.0, i, j = 1...M */
+
+/* if (PRTYPE = 3) then */
+/* A(k + 1, k + 1) = A(k, k) */
+/* A(k + 1, k) = [-1...1] */
+/* sign(A(k, k + 1) = -(sin(A(k + 1, k)) */
+/* k = 1, M - 1, QBLCKA */
+
+/* B : if (i <= j) then B(i, j) = [-1...1] */
+/* else B(i, j) = 0.0, i, j = 1...N */
+
+/* if (PRTYPE = 3) then */
+/* B(k + 1, k + 1) = B(k, k) */
+/* B(k + 1, k) = [-1...1] */
+/* sign(B(k, k + 1) = -(sign(B(k + 1, k)) */
+/* k = 1, N - 1, QBLCKB */
+
+/* D : if (i <= j) then D(i, j) = [-1...1]. */
+/* else D(i, j) = 0.0, i, j = 1...M */
+
+
+/* E : if (i <= j) then D(i, j) = [-1...1] */
+/* else E(i, j) = 0.0, i, j = 1...N */
+
+/* L, R are chosen from [-10...10], */
+/* which specifies the right hand sides (C, F). */
+
+/* PRTYPE = 4 Full */
+/* A(i, j) = [-10...10] */
+/* D(i, j) = [-1...1] i,j = 1...M */
+/* B(i, j) = [-10...10] */
+/* E(i, j) = [-1...1] i,j = 1...N */
+/* R(i, j) = [-10...10] */
+/* L(i, j) = [-1...1] i = 1..M ,j = 1...N */
+
+/* L, R specifies the right hand sides (C, F). */
+
+/* PRTYPE = 5 special case common and/or close eigs. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+ /* Parameter adjustments */
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ b_dim1 = *ldb;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ c_dim1 = *ldc;
+ c_offset = 1 + c_dim1;
+ c__ -= c_offset;
+ d_dim1 = *ldd;
+ d_offset = 1 + d_dim1;
+ d__ -= d_offset;
+ e_dim1 = *lde;
+ e_offset = 1 + e_dim1;
+ e -= e_offset;
+ f_dim1 = *ldf;
+ f_offset = 1 + f_dim1;
+ f -= f_offset;
+ r_dim1 = *ldr;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ l_dim1 = *ldl;
+ l_offset = 1 + l_dim1;
+ l -= l_offset;
+
+ /* Function Body */
+ if (*prtype == 1) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *m;
+ for (j = 1; j <= i__2; ++j) {
+ if (i__ == j) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 1., a[i__3].i = 0.;
+ i__3 = i__ + j * d_dim1;
+ d__[i__3].r = 1., d__[i__3].i = 0.;
+ } else if (i__ == j - 1) {
+ i__3 = i__ + j * a_dim1;
+ z__1.r = -1., z__1.i = -0.;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ i__3 = i__ + j * d_dim1;
+ d__[i__3].r = 0., d__[i__3].i = 0.;
+ } else {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ i__3 = i__ + j * d_dim1;
+ d__[i__3].r = 0., d__[i__3].i = 0.;
+ }
+/* L10: */
+ }
+/* L20: */
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (i__ == j) {
+ i__3 = i__ + j * b_dim1;
+ z__1.r = 1. - *alpha, z__1.i = 0.;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+ i__3 = i__ + j * e_dim1;
+ e[i__3].r = 1., e[i__3].i = 0.;
+ } else if (i__ == j - 1) {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 1., b[i__3].i = 0.;
+ i__3 = i__ + j * e_dim1;
+ e[i__3].r = 0., e[i__3].i = 0.;
+ } else {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0., b[i__3].i = 0.;
+ i__3 = i__ + j * e_dim1;
+ e[i__3].r = 0., e[i__3].i = 0.;
+ }
+/* L30: */
+ }
+/* L40: */
+ }
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * r_dim1;
+ i__4 = i__ / j;
+ z__4.r = (doublereal) i__4, z__4.i = 0.;
+ z_sin(&z__3, &z__4);
+ z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
+ z__1.r = z__2.r * 20. - z__2.i * 0., z__1.i = z__2.r * 0. +
+ z__2.i * 20.;
+ r__[i__3].r = z__1.r, r__[i__3].i = z__1.i;
+ i__3 = i__ + j * l_dim1;
+ i__4 = i__ + j * r_dim1;
+ l[i__3].r = r__[i__4].r, l[i__3].i = r__[i__4].i;
+/* L50: */
+ }
+/* L60: */
+ }
+
+ } else if (*prtype == 2 || *prtype == 3) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *m;
+ for (j = 1; j <= i__2; ++j) {
+ if (i__ <= j) {
+ i__3 = i__ + j * a_dim1;
+ z__4.r = (doublereal) i__, z__4.i = 0.;
+ z_sin(&z__3, &z__4);
+ z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
+ z__1.r = z__2.r * 2. - z__2.i * 0., z__1.i = z__2.r * 0.
+ + z__2.i * 2.;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ i__3 = i__ + j * d_dim1;
+ i__4 = i__ * j;
+ z__4.r = (doublereal) i__4, z__4.i = 0.;
+ z_sin(&z__3, &z__4);
+ z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
+ z__1.r = z__2.r * 2. - z__2.i * 0., z__1.i = z__2.r * 0.
+ + z__2.i * 2.;
+ d__[i__3].r = z__1.r, d__[i__3].i = z__1.i;
+ } else {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ i__3 = i__ + j * d_dim1;
+ d__[i__3].r = 0., d__[i__3].i = 0.;
+ }
+/* L70: */
+ }
+/* L80: */
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ if (i__ <= j) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j;
+ z__4.r = (doublereal) i__4, z__4.i = 0.;
+ z_sin(&z__3, &z__4);
+ z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
+ z__1.r = z__2.r * 2. - z__2.i * 0., z__1.i = z__2.r * 0.
+ + z__2.i * 2.;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+ i__3 = i__ + j * e_dim1;
+ z__4.r = (doublereal) j, z__4.i = 0.;
+ z_sin(&z__3, &z__4);
+ z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
+ z__1.r = z__2.r * 2. - z__2.i * 0., z__1.i = z__2.r * 0.
+ + z__2.i * 2.;
+ e[i__3].r = z__1.r, e[i__3].i = z__1.i;
+ } else {
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0., b[i__3].i = 0.;
+ i__3 = i__ + j * e_dim1;
+ e[i__3].r = 0., e[i__3].i = 0.;
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * r_dim1;
+ i__4 = i__ * j;
+ z__4.r = (doublereal) i__4, z__4.i = 0.;
+ z_sin(&z__3, &z__4);
+ z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
+ z__1.r = z__2.r * 20. - z__2.i * 0., z__1.i = z__2.r * 0. +
+ z__2.i * 20.;
+ r__[i__3].r = z__1.r, r__[i__3].i = z__1.i;
+ i__3 = i__ + j * l_dim1;
+ i__4 = i__ + j;
+ z__4.r = (doublereal) i__4, z__4.i = 0.;
+ z_sin(&z__3, &z__4);
+ z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
+ z__1.r = z__2.r * 20. - z__2.i * 0., z__1.i = z__2.r * 0. +
+ z__2.i * 20.;
+ l[i__3].r = z__1.r, l[i__3].i = z__1.i;
+/* L110: */
+ }
+/* L120: */
+ }
+
+ if (*prtype == 3) {
+ if (*qblcka <= 1) {
+ *qblcka = 2;
+ }
+ i__1 = *m - 1;
+ i__2 = *qblcka;
+ for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+ i__3 = k + 1 + (k + 1) * a_dim1;
+ i__4 = k + k * a_dim1;
+ a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
+ i__3 = k + 1 + k * a_dim1;
+ z_sin(&z__2, &a[k + (k + 1) * a_dim1]);
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L130: */
+ }
+
+ if (*qblckb <= 1) {
+ *qblckb = 2;
+ }
+ i__2 = *n - 1;
+ i__1 = *qblckb;
+ for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+ i__3 = k + 1 + (k + 1) * b_dim1;
+ i__4 = k + k * b_dim1;
+ b[i__3].r = b[i__4].r, b[i__3].i = b[i__4].i;
+ i__3 = k + 1 + k * b_dim1;
+ z_sin(&z__2, &b[k + (k + 1) * b_dim1]);
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+/* L140: */
+ }
+ }
+
+ } else if (*prtype == 4) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *m;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * a_dim1;
+ i__4 = i__ * j;
+ z__4.r = (doublereal) i__4, z__4.i = 0.;
+ z_sin(&z__3, &z__4);
+ z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
+ z__1.r = z__2.r * 20. - z__2.i * 0., z__1.i = z__2.r * 0. +
+ z__2.i * 20.;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ i__3 = i__ + j * d_dim1;
+ i__4 = i__ + j;
+ z__4.r = (doublereal) i__4, z__4.i = 0.;
+ z_sin(&z__3, &z__4);
+ z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
+ z__1.r = z__2.r * 2. - z__2.i * 0., z__1.i = z__2.r * 0. +
+ z__2.i * 2.;
+ d__[i__3].r = z__1.r, d__[i__3].i = z__1.i;
+/* L150: */
+ }
+/* L160: */
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * b_dim1;
+ i__4 = i__ + j;
+ z__4.r = (doublereal) i__4, z__4.i = 0.;
+ z_sin(&z__3, &z__4);
+ z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
+ z__1.r = z__2.r * 20. - z__2.i * 0., z__1.i = z__2.r * 0. +
+ z__2.i * 20.;
+ b[i__3].r = z__1.r, b[i__3].i = z__1.i;
+ i__3 = i__ + j * e_dim1;
+ i__4 = i__ * j;
+ z__4.r = (doublereal) i__4, z__4.i = 0.;
+ z_sin(&z__3, &z__4);
+ z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
+ z__1.r = z__2.r * 2. - z__2.i * 0., z__1.i = z__2.r * 0. +
+ z__2.i * 2.;
+ e[i__3].r = z__1.r, e[i__3].i = z__1.i;
+/* L170: */
+ }
+/* L180: */
+ }
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * r_dim1;
+ i__4 = j / i__;
+ z__4.r = (doublereal) i__4, z__4.i = 0.;
+ z_sin(&z__3, &z__4);
+ z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
+ z__1.r = z__2.r * 20. - z__2.i * 0., z__1.i = z__2.r * 0. +
+ z__2.i * 20.;
+ r__[i__3].r = z__1.r, r__[i__3].i = z__1.i;
+ i__3 = i__ + j * l_dim1;
+ i__4 = i__ * j;
+ z__4.r = (doublereal) i__4, z__4.i = 0.;
+ z_sin(&z__3, &z__4);
+ z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i;
+ z__1.r = z__2.r * 2. - z__2.i * 0., z__1.i = z__2.r * 0. +
+ z__2.i * 2.;
+ l[i__3].r = z__1.r, l[i__3].i = z__1.i;
+/* L190: */
+ }
+/* L200: */
+ }
+
+ } else if (*prtype >= 5) {
+ z__3.r = 1., z__3.i = 0.;
+ z__2.r = z__3.r * 20. - z__3.i * 0., z__2.i = z__3.r * 0. + z__3.i *
+ 20.;
+ z__1.r = z__2.r / *alpha, z__1.i = z__2.i / *alpha;
+ reeps.r = z__1.r, reeps.i = z__1.i;
+ z__2.r = -1.5, z__2.i = 0.;
+ z__1.r = z__2.r / *alpha, z__1.i = z__2.i / *alpha;
+ imeps.r = z__1.r, imeps.i = z__1.i;
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = i__ + j * r_dim1;
+ i__4 = i__ * j;
+ z__5.r = (doublereal) i__4, z__5.i = 0.;
+ z_sin(&z__4, &z__5);
+ z__3.r = .5 - z__4.r, z__3.i = 0. - z__4.i;
+ z__2.r = *alpha * z__3.r, z__2.i = *alpha * z__3.i;
+ z_div(&z__1, &z__2, &c_b5);
+ r__[i__3].r = z__1.r, r__[i__3].i = z__1.i;
+ i__3 = i__ + j * l_dim1;
+ i__4 = i__ + j;
+ z__5.r = (doublereal) i__4, z__5.i = 0.;
+ z_sin(&z__4, &z__5);
+ z__3.r = .5 - z__4.r, z__3.i = 0. - z__4.i;
+ z__2.r = *alpha * z__3.r, z__2.i = *alpha * z__3.i;
+ z_div(&z__1, &z__2, &c_b5);
+ l[i__3].r = z__1.r, l[i__3].i = z__1.i;
+/* L210: */
+ }
+/* L220: */
+ }
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * d_dim1;
+ d__[i__2].r = 1., d__[i__2].i = 0.;
+/* L230: */
+ }
+
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ if (i__ <= 4) {
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+ if (i__ > 2) {
+ i__2 = i__ + i__ * a_dim1;
+ z__1.r = reeps.r + 1., z__1.i = reeps.i + 0.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ }
+ if (i__ % 2 != 0 && i__ < *m) {
+ i__2 = i__ + (i__ + 1) * a_dim1;
+ a[i__2].r = imeps.r, a[i__2].i = imeps.i;
+ } else if (i__ > 1) {
+ i__2 = i__ + (i__ - 1) * a_dim1;
+ z__1.r = -imeps.r, z__1.i = -imeps.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ }
+ } else if (i__ <= 8) {
+ if (i__ <= 6) {
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = reeps.r, a[i__2].i = reeps.i;
+ } else {
+ i__2 = i__ + i__ * a_dim1;
+ z__1.r = -reeps.r, z__1.i = -reeps.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ }
+ if (i__ % 2 != 0 && i__ < *m) {
+ i__2 = i__ + (i__ + 1) * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+ } else if (i__ > 1) {
+ i__2 = i__ + (i__ - 1) * a_dim1;
+ z__1.r = -1., z__1.i = -0.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ }
+ } else {
+ i__2 = i__ + i__ * a_dim1;
+ a[i__2].r = 1., a[i__2].i = 0.;
+ if (i__ % 2 != 0 && i__ < *m) {
+ i__2 = i__ + (i__ + 1) * a_dim1;
+ d__1 = 2.;
+ z__1.r = d__1 * imeps.r, z__1.i = d__1 * imeps.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ } else if (i__ > 1) {
+ i__2 = i__ + (i__ - 1) * a_dim1;
+ z__2.r = -imeps.r, z__2.i = -imeps.i;
+ d__1 = 2.;
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+ }
+ }
+/* L240: */
+ }
+
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__ + i__ * e_dim1;
+ e[i__2].r = 1., e[i__2].i = 0.;
+ if (i__ <= 4) {
+ i__2 = i__ + i__ * b_dim1;
+ z__1.r = -1., z__1.i = -0.;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ if (i__ > 2) {
+ i__2 = i__ + i__ * b_dim1;
+ z__1.r = 1. - reeps.r, z__1.i = 0. - reeps.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ }
+ if (i__ % 2 != 0 && i__ < *n) {
+ i__2 = i__ + (i__ + 1) * b_dim1;
+ b[i__2].r = imeps.r, b[i__2].i = imeps.i;
+ } else if (i__ > 1) {
+ i__2 = i__ + (i__ - 1) * b_dim1;
+ z__1.r = -imeps.r, z__1.i = -imeps.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ }
+ } else if (i__ <= 8) {
+ if (i__ <= 6) {
+ i__2 = i__ + i__ * b_dim1;
+ b[i__2].r = reeps.r, b[i__2].i = reeps.i;
+ } else {
+ i__2 = i__ + i__ * b_dim1;
+ z__1.r = -reeps.r, z__1.i = -reeps.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ }
+ if (i__ % 2 != 0 && i__ < *n) {
+ i__2 = i__ + (i__ + 1) * b_dim1;
+ z__1.r = imeps.r + 1., z__1.i = imeps.i + 0.;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ } else if (i__ > 1) {
+ i__2 = i__ + (i__ - 1) * b_dim1;
+ z__2.r = -1., z__2.i = -0.;
+ z__1.r = z__2.r - imeps.r, z__1.i = z__2.i - imeps.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ }
+ } else {
+ i__2 = i__ + i__ * b_dim1;
+ z__1.r = 1. - reeps.r, z__1.i = 0. - reeps.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ if (i__ % 2 != 0 && i__ < *n) {
+ i__2 = i__ + (i__ + 1) * b_dim1;
+ d__1 = 2.;
+ z__1.r = d__1 * imeps.r, z__1.i = d__1 * imeps.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ } else if (i__ > 1) {
+ i__2 = i__ + (i__ - 1) * b_dim1;
+ z__2.r = -imeps.r, z__2.i = -imeps.i;
+ d__1 = 2.;
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ b[i__2].r = z__1.r, b[i__2].i = z__1.i;
+ }
+ }
+/* L250: */
+ }
+ }
+
+/* Compute rhs (C, F) */
+
+ zgemm_("N", "N", m, n, m, &c_b1, &a[a_offset], lda, &r__[r_offset], ldr, &
+ c_b3, &c__[c_offset], ldc);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("N", "N", m, n, n, &z__1, &l[l_offset], ldl, &b[b_offset], ldb, &
+ c_b1, &c__[c_offset], ldc);
+ zgemm_("N", "N", m, n, m, &c_b1, &d__[d_offset], ldd, &r__[r_offset], ldr,
+ &c_b3, &f[f_offset], ldf);
+ z__1.r = -1., z__1.i = -0.;
+ zgemm_("N", "N", m, n, n, &z__1, &l[l_offset], ldl, &e[e_offset], lde, &
+ c_b1, &f[f_offset], ldf);
+
+/* End of ZLATM5 */
+
+ return 0;
+} /* zlatm5_ */
diff --git a/TESTING/MATGEN/zlatm6.c b/TESTING/MATGEN/zlatm6.c
new file mode 100644
index 0000000..4ccbd4f
--- /dev/null
+++ b/TESTING/MATGEN/zlatm6.c
@@ -0,0 +1,378 @@
+/* zlatm6.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__4 = 4;
+static integer c__8 = 8;
+static integer c__24 = 24;
+
+/* Subroutine */ int zlatm6_(integer *type__, integer *n, doublecomplex *a,
+ integer *lda, doublecomplex *b, doublecomplex *x, integer *ldx,
+ doublecomplex *y, integer *ldy, doublecomplex *alpha, doublecomplex *
+ beta, doublecomplex *wx, doublecomplex *wy, doublereal *s, doublereal
+ *dif)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, y_dim1,
+ y_offset, i__1, i__2, i__3;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2, z__3, z__4;
+
+ /* Builtin functions */
+ void d_cnjg(doublecomplex *, doublecomplex *);
+ double z_abs(doublecomplex *), sqrt(doublereal);
+
+ /* Local variables */
+ integer i__, j;
+ doublecomplex z__[64] /* was [8][8] */;
+ integer info;
+ doublecomplex work[26];
+ doublereal rwork[50];
+ extern /* Subroutine */ int zlakf2_(integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ doublecomplex *, integer *), zgesvd_(char *, char *, integer *,
+ integer *, doublecomplex *, integer *, doublereal *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *, doublereal *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublecomplex *, integer *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLATM6 generates test matrices for the generalized eigenvalue */
+/* problem, their corresponding right and left eigenvector matrices, */
+/* and also reciprocal condition numbers for all eigenvalues and */
+/* the reciprocal condition numbers of eigenvectors corresponding to */
+/* the 1th and 5th eigenvalues. */
+
+/* Test Matrices */
+/* ============= */
+
+/* Two kinds of test matrix pairs */
+/* (A, B) = inverse(YH) * (Da, Db) * inverse(X) */
+/* are used in the tests: */
+
+/* Type 1: */
+/* Da = 1+a 0 0 0 0 Db = 1 0 0 0 0 */
+/* 0 2+a 0 0 0 0 1 0 0 0 */
+/* 0 0 3+a 0 0 0 0 1 0 0 */
+/* 0 0 0 4+a 0 0 0 0 1 0 */
+/* 0 0 0 0 5+a , 0 0 0 0 1 */
+/* and Type 2: */
+/* Da = 1+i 0 0 0 0 Db = 1 0 0 0 0 */
+/* 0 1-i 0 0 0 0 1 0 0 0 */
+/* 0 0 1 0 0 0 0 1 0 0 */
+/* 0 0 0 (1+a)+(1+b)i 0 0 0 0 1 0 */
+/* 0 0 0 0 (1+a)-(1+b)i, 0 0 0 0 1 . */
+
+/* In both cases the same inverse(YH) and inverse(X) are used to compute */
+/* (A, B), giving the exact eigenvectors to (A,B) as (YH, X): */
+
+/* YH: = 1 0 -y y -y X = 1 0 -x -x x */
+/* 0 1 -y y -y 0 1 x -x -x */
+/* 0 0 1 0 0 0 0 1 0 0 */
+/* 0 0 0 1 0 0 0 0 1 0 */
+/* 0 0 0 0 1, 0 0 0 0 1 , where */
+
+/* a, b, x and y will have all values independently of each other. */
+
+/* Arguments */
+/* ========= */
+
+/* TYPE (input) INTEGER */
+/* Specifies the problem type (see futher details). */
+
+/* N (input) INTEGER */
+/* Size of the matrices A and B. */
+
+/* A (output) COMPLEX*16 array, dimension (LDA, N). */
+/* On exit A N-by-N is initialized according to TYPE. */
+
+/* LDA (input) INTEGER */
+/* The leading dimension of A and of B. */
+
+/* B (output) COMPLEX*16 array, dimension (LDA, N). */
+/* On exit B N-by-N is initialized according to TYPE. */
+
+/* X (output) COMPLEX*16 array, dimension (LDX, N). */
+/* On exit X is the N-by-N matrix of right eigenvectors. */
+
+/* LDX (input) INTEGER */
+/* The leading dimension of X. */
+
+/* Y (output) COMPLEX*16 array, dimension (LDY, N). */
+/* On exit Y is the N-by-N matrix of left eigenvectors. */
+
+/* LDY (input) INTEGER */
+/* The leading dimension of Y. */
+
+/* ALPHA (input) COMPLEX*16 */
+/* BETA (input) COMPLEX*16 */
+/* Weighting constants for matrix A. */
+
+/* WX (input) COMPLEX*16 */
+/* Constant for right eigenvector matrix. */
+
+/* WY (input) COMPLEX*16 */
+/* Constant for left eigenvector matrix. */
+
+/* S (output) DOUBLE PRECISION array, dimension (N) */
+/* S(i) is the reciprocal condition number for eigenvalue i. */
+
+/* DIF (output) DOUBLE PRECISION array, dimension (N) */
+/* DIF(i) is the reciprocal condition number for eigenvector i. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* Generate test problem ... */
+/* (Da, Db) ... */
+
+ /* Parameter adjustments */
+ b_dim1 = *lda;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ x_dim1 = *ldx;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ y_dim1 = *ldy;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ --s;
+ --dif;
+
+ /* Function Body */
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+
+ if (i__ == j) {
+ i__3 = i__ + i__ * a_dim1;
+ z__2.r = (doublereal) i__, z__2.i = 0.;
+ z__1.r = z__2.r + alpha->r, z__1.i = z__2.i + alpha->i;
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ i__3 = i__ + i__ * b_dim1;
+ b[i__3].r = 1., b[i__3].i = 0.;
+ } else {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ i__3 = i__ + j * b_dim1;
+ b[i__3].r = 0., b[i__3].i = 0.;
+ }
+
+/* L10: */
+ }
+/* L20: */
+ }
+ if (*type__ == 2) {
+ i__1 = a_dim1 + 1;
+ a[i__1].r = 1., a[i__1].i = 1.;
+ i__1 = (a_dim1 << 1) + 2;
+ d_cnjg(&z__1, &a[a_dim1 + 1]);
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = a_dim1 * 3 + 3;
+ a[i__1].r = 1., a[i__1].i = 0.;
+ i__1 = (a_dim1 << 2) + 4;
+ z__2.r = alpha->r + 1., z__2.i = alpha->i + 0.;
+ d__1 = z__2.r;
+ z__3.r = beta->r + 1., z__3.i = beta->i + 0.;
+ d__2 = z__3.r;
+ z__1.r = d__1, z__1.i = d__2;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = a_dim1 * 5 + 5;
+ d_cnjg(&z__1, &a[(a_dim1 << 2) + 4]);
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ }
+
+/* Form X and Y */
+
+ zlacpy_("F", n, n, &b[b_offset], lda, &y[y_offset], ldy);
+ i__1 = y_dim1 + 3;
+ d_cnjg(&z__2, wy);
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ y[i__1].r = z__1.r, y[i__1].i = z__1.i;
+ i__1 = y_dim1 + 4;
+ d_cnjg(&z__1, wy);
+ y[i__1].r = z__1.r, y[i__1].i = z__1.i;
+ i__1 = y_dim1 + 5;
+ d_cnjg(&z__2, wy);
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ y[i__1].r = z__1.r, y[i__1].i = z__1.i;
+ i__1 = (y_dim1 << 1) + 3;
+ d_cnjg(&z__2, wy);
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ y[i__1].r = z__1.r, y[i__1].i = z__1.i;
+ i__1 = (y_dim1 << 1) + 4;
+ d_cnjg(&z__1, wy);
+ y[i__1].r = z__1.r, y[i__1].i = z__1.i;
+ i__1 = (y_dim1 << 1) + 5;
+ d_cnjg(&z__2, wy);
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ y[i__1].r = z__1.r, y[i__1].i = z__1.i;
+
+ zlacpy_("F", n, n, &b[b_offset], lda, &x[x_offset], ldx);
+ i__1 = x_dim1 * 3 + 1;
+ z__1.r = -wx->r, z__1.i = -wx->i;
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ i__1 = (x_dim1 << 2) + 1;
+ z__1.r = -wx->r, z__1.i = -wx->i;
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ i__1 = x_dim1 * 5 + 1;
+ x[i__1].r = wx->r, x[i__1].i = wx->i;
+ i__1 = x_dim1 * 3 + 2;
+ x[i__1].r = wx->r, x[i__1].i = wx->i;
+ i__1 = (x_dim1 << 2) + 2;
+ z__1.r = -wx->r, z__1.i = -wx->i;
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+ i__1 = x_dim1 * 5 + 2;
+ z__1.r = -wx->r, z__1.i = -wx->i;
+ x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+
+/* Form (A, B) */
+
+ i__1 = b_dim1 * 3 + 1;
+ z__1.r = wx->r + wy->r, z__1.i = wx->i + wy->i;
+ b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+ i__1 = b_dim1 * 3 + 2;
+ z__2.r = -wx->r, z__2.i = -wx->i;
+ z__1.r = z__2.r + wy->r, z__1.i = z__2.i + wy->i;
+ b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+ i__1 = (b_dim1 << 2) + 1;
+ z__1.r = wx->r - wy->r, z__1.i = wx->i - wy->i;
+ b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+ i__1 = (b_dim1 << 2) + 2;
+ z__1.r = wx->r - wy->r, z__1.i = wx->i - wy->i;
+ b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+ i__1 = b_dim1 * 5 + 1;
+ z__2.r = -wx->r, z__2.i = -wx->i;
+ z__1.r = z__2.r + wy->r, z__1.i = z__2.i + wy->i;
+ b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+ i__1 = b_dim1 * 5 + 2;
+ z__1.r = wx->r + wy->r, z__1.i = wx->i + wy->i;
+ b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+ i__1 = a_dim1 * 3 + 1;
+ i__2 = a_dim1 + 1;
+ z__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, z__2.i = wx->r * a[i__2]
+ .i + wx->i * a[i__2].r;
+ i__3 = a_dim1 * 3 + 3;
+ z__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__3.i = wy->r * a[i__3]
+ .i + wy->i * a[i__3].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = a_dim1 * 3 + 2;
+ z__3.r = -wx->r, z__3.i = -wx->i;
+ i__2 = (a_dim1 << 1) + 2;
+ z__2.r = z__3.r * a[i__2].r - z__3.i * a[i__2].i, z__2.i = z__3.r * a[
+ i__2].i + z__3.i * a[i__2].r;
+ i__3 = a_dim1 * 3 + 3;
+ z__4.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__4.i = wy->r * a[i__3]
+ .i + wy->i * a[i__3].r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = (a_dim1 << 2) + 1;
+ i__2 = a_dim1 + 1;
+ z__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, z__2.i = wx->r * a[i__2]
+ .i + wx->i * a[i__2].r;
+ i__3 = (a_dim1 << 2) + 4;
+ z__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__3.i = wy->r * a[i__3]
+ .i + wy->i * a[i__3].r;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = (a_dim1 << 2) + 2;
+ i__2 = (a_dim1 << 1) + 2;
+ z__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, z__2.i = wx->r * a[i__2]
+ .i + wx->i * a[i__2].r;
+ i__3 = (a_dim1 << 2) + 4;
+ z__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__3.i = wy->r * a[i__3]
+ .i + wy->i * a[i__3].r;
+ z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = a_dim1 * 5 + 1;
+ z__3.r = -wx->r, z__3.i = -wx->i;
+ i__2 = a_dim1 + 1;
+ z__2.r = z__3.r * a[i__2].r - z__3.i * a[i__2].i, z__2.i = z__3.r * a[
+ i__2].i + z__3.i * a[i__2].r;
+ i__3 = a_dim1 * 5 + 5;
+ z__4.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__4.i = wy->r * a[i__3]
+ .i + wy->i * a[i__3].r;
+ z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+ i__1 = a_dim1 * 5 + 2;
+ i__2 = (a_dim1 << 1) + 2;
+ z__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, z__2.i = wx->r * a[i__2]
+ .i + wx->i * a[i__2].r;
+ i__3 = a_dim1 * 5 + 5;
+ z__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__3.i = wy->r * a[i__3]
+ .i + wy->i * a[i__3].r;
+ z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+ a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+
+/* Compute condition numbers */
+
+ s[1] = 1. / sqrt((z_abs(wy) * 3. * z_abs(wy) + 1.) / (z_abs(&a[a_dim1 + 1]
+ ) * z_abs(&a[a_dim1 + 1]) + 1.));
+ s[2] = 1. / sqrt((z_abs(wy) * 3. * z_abs(wy) + 1.) / (z_abs(&a[(a_dim1 <<
+ 1) + 2]) * z_abs(&a[(a_dim1 << 1) + 2]) + 1.));
+ s[3] = 1. / sqrt((z_abs(wx) * 2. * z_abs(wx) + 1.) / (z_abs(&a[a_dim1 * 3
+ + 3]) * z_abs(&a[a_dim1 * 3 + 3]) + 1.));
+ s[4] = 1. / sqrt((z_abs(wx) * 2. * z_abs(wx) + 1.) / (z_abs(&a[(a_dim1 <<
+ 2) + 4]) * z_abs(&a[(a_dim1 << 2) + 4]) + 1.));
+ s[5] = 1. / sqrt((z_abs(wx) * 2. * z_abs(wx) + 1.) / (z_abs(&a[a_dim1 * 5
+ + 5]) * z_abs(&a[a_dim1 * 5 + 5]) + 1.));
+
+ zlakf2_(&c__1, &c__4, &a[a_offset], lda, &a[(a_dim1 << 1) + 2], &b[
+ b_offset], &b[(b_dim1 << 1) + 2], z__, &c__8);
+ zgesvd_("N", "N", &c__8, &c__8, z__, &c__8, rwork, work, &c__1, &work[1],
+ &c__1, &work[2], &c__24, &rwork[8], &info);
+ dif[1] = rwork[7];
+
+ zlakf2_(&c__4, &c__1, &a[a_offset], lda, &a[a_dim1 * 5 + 5], &b[b_offset],
+ &b[b_dim1 * 5 + 5], z__, &c__8);
+ zgesvd_("N", "N", &c__8, &c__8, z__, &c__8, rwork, work, &c__1, &work[1],
+ &c__1, &work[2], &c__24, &rwork[8], &info);
+ dif[5] = rwork[7];
+
+ return 0;
+
+/* End of ZLATM6 */
+
+} /* zlatm6_ */
diff --git a/TESTING/MATGEN/zlatme.c b/TESTING/MATGEN/zlatme.c
new file mode 100644
index 0000000..1c6fef7
--- /dev/null
+++ b/TESTING/MATGEN/zlatme.c
@@ -0,0 +1,640 @@
+/* zlatme.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static doublecomplex c_b2 = {1.,0.};
+static integer c__1 = 1;
+static integer c__0 = 0;
+static integer c__5 = 5;
+
+/* Subroutine */ int zlatme_(integer *n, char *dist, integer *iseed,
+ doublecomplex *d__, integer *mode, doublereal *cond, doublecomplex *
+ dmax__, char *ei, char *rsign, char *upper, char *sim, doublereal *ds,
+ integer *modes, doublereal *conds, integer *kl, integer *ku,
+ doublereal *anorm, doublecomplex *a, integer *lda, doublecomplex *
+ work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, ic, jc, ir, jcr;
+ doublecomplex tau;
+ logical bads;
+ integer isim;
+ doublereal temp;
+ doublecomplex alpha;
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ doublereal tempa[1];
+ integer icols;
+ extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
+ doublecomplex *, integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *);
+ integer idist;
+ extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
+ doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, integer *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *, integer *);
+ integer irows;
+ extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
+ doublecomplex *, integer *), dlatm1_(integer *, doublereal *,
+ integer *, integer *, integer *, doublereal *, integer *, integer
+ *), zlatm1_(integer *, doublereal *, integer *, integer *,
+ integer *, doublecomplex *, integer *, integer *);
+ doublereal ralpha;
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *), zlarge_(integer *, doublecomplex *,
+ integer *, integer *, doublecomplex *, integer *), zlarfg_(
+ integer *, doublecomplex *, doublecomplex *, integer *,
+ doublecomplex *), zlacgv_(integer *, doublecomplex *, integer *);
+ extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
+ integer *);
+ integer irsign;
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+ integer iupper;
+ extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *,
+ doublecomplex *);
+ doublecomplex xnorms;
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLATME generates random non-symmetric square matrices with */
+/* specified eigenvalues for testing LAPACK programs. */
+
+/* ZLATME operates by applying the following sequence of */
+/* operations: */
+
+/* 1. Set the diagonal to D, where D may be input or */
+/* computed according to MODE, COND, DMAX, and RSIGN */
+/* as described below. */
+
+/* 2. If UPPER='T', the upper triangle of A is set to random values */
+/* out of distribution DIST. */
+
+/* 3. If SIM='T', A is multiplied on the left by a random matrix */
+/* X, whose singular values are specified by DS, MODES, and */
+/* CONDS, and on the right by X inverse. */
+
+/* 4. If KL < N-1, the lower bandwidth is reduced to KL using */
+/* Householder transformations. If KU < N-1, the upper */
+/* bandwidth is reduced to KU. */
+
+/* 5. If ANORM is not negative, the matrix is scaled to have */
+/* maximum-element-norm ANORM. */
+
+/* (Note: since the matrix cannot be reduced beyond Hessenberg form, */
+/* no packing options are available.) */
+
+/* Arguments */
+/* ========= */
+
+/* N - INTEGER */
+/* The number of columns (or rows) of A. Not modified. */
+
+/* DIST - CHARACTER*1 */
+/* On entry, DIST specifies the type of distribution to be used */
+/* to generate the random eigen-/singular values, and on the */
+/* upper triangle (see UPPER). */
+/* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */
+/* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */
+/* 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */
+/* 'D' => uniform on the complex disc |z| < 1. */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension ( 4 ) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. They should lie between 0 and 4095 inclusive, */
+/* and ISEED(4) should be odd. The random number generator */
+/* uses a linear congruential sequence limited to small */
+/* integers, and so should produce machine independent */
+/* random numbers. The values of ISEED are changed on */
+/* exit, and can be used in the next call to ZLATME */
+/* to continue the same random number sequence. */
+/* Changed on exit. */
+
+/* D - COMPLEX*16 array, dimension ( N ) */
+/* This array is used to specify the eigenvalues of A. If */
+/* MODE=0, then D is assumed to contain the eigenvalues */
+/* otherwise they will be computed according to MODE, COND, */
+/* DMAX, and RSIGN and placed in D. */
+/* Modified if MODE is nonzero. */
+
+/* MODE - INTEGER */
+/* On entry this describes how the eigenvalues are to */
+/* be specified: */
+/* MODE = 0 means use D as input */
+/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
+/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
+/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
+/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* MODE = 5 sets D to random numbers in the range */
+/* ( 1/COND , 1 ) such that their logarithms */
+/* are uniformly distributed. */
+/* MODE = 6 set D to random numbers from same distribution */
+/* as the rest of the matrix. */
+/* MODE < 0 has the same meaning as ABS(MODE), except that */
+/* the order of the elements of D is reversed. */
+/* Thus if MODE is between 1 and 4, D has entries ranging */
+/* from 1 to 1/COND, if between -1 and -4, D has entries */
+/* ranging from 1/COND to 1, */
+/* Not modified. */
+
+/* COND - DOUBLE PRECISION */
+/* On entry, this is used as described under MODE above. */
+/* If used, it must be >= 1. Not modified. */
+
+/* DMAX - COMPLEX*16 */
+/* If MODE is neither -6, 0 nor 6, the contents of D, as */
+/* computed according to MODE and COND, will be scaled by */
+/* DMAX / max(abs(D(i))). Note that DMAX need not be */
+/* positive or real: if DMAX is negative or complex (or zero), */
+/* D will be scaled by a negative or complex number (or zero). */
+/* If RSIGN='F' then the largest (absolute) eigenvalue will be */
+/* equal to DMAX. */
+/* Not modified. */
+
+/* EI - CHARACTER*1 (ignored) */
+/* Not modified. */
+
+/* RSIGN - CHARACTER*1 */
+/* If MODE is not 0, 6, or -6, and RSIGN='T', then the */
+/* elements of D, as computed according to MODE and COND, will */
+/* be multiplied by a random complex number from the unit */
+/* circle |z| = 1. If RSIGN='F', they will not be. RSIGN may */
+/* only have the values 'T' or 'F'. */
+/* Not modified. */
+
+/* UPPER - CHARACTER*1 */
+/* If UPPER='T', then the elements of A above the diagonal */
+/* will be set to random numbers out of DIST. If UPPER='F', */
+/* they will not. UPPER may only have the values 'T' or 'F'. */
+/* Not modified. */
+
+/* SIM - CHARACTER*1 */
+/* If SIM='T', then A will be operated on by a "similarity */
+/* transform", i.e., multiplied on the left by a matrix X and */
+/* on the right by X inverse. X = U S V, where U and V are */
+/* random unitary matrices and S is a (diagonal) matrix of */
+/* singular values specified by DS, MODES, and CONDS. If */
+/* SIM='F', then A will not be transformed. */
+/* Not modified. */
+
+/* DS - DOUBLE PRECISION array, dimension ( N ) */
+/* This array is used to specify the singular values of X, */
+/* in the same way that D specifies the eigenvalues of A. */
+/* If MODE=0, the DS contains the singular values, which */
+/* may not be zero. */
+/* Modified if MODE is nonzero. */
+
+/* MODES - INTEGER */
+/* CONDS - DOUBLE PRECISION */
+/* Similar to MODE and COND, but for specifying the diagonal */
+/* of S. MODES=-6 and +6 are not allowed (since they would */
+/* result in randomly ill-conditioned eigenvalues.) */
+
+/* KL - INTEGER */
+/* This specifies the lower bandwidth of the matrix. KL=1 */
+/* specifies upper Hessenberg form. If KL is at least N-1, */
+/* then A will have full lower bandwidth. */
+/* Not modified. */
+
+/* KU - INTEGER */
+/* This specifies the upper bandwidth of the matrix. KU=1 */
+/* specifies lower Hessenberg form. If KU is at least N-1, */
+/* then A will have full upper bandwidth; if KU and KL */
+/* are both at least N-1, then A will be dense. Only one of */
+/* KU and KL may be less than N-1. */
+/* Not modified. */
+
+/* ANORM - DOUBLE PRECISION */
+/* If ANORM is not negative, then A will be scaled by a non- */
+/* negative real number to make the maximum-element-norm of A */
+/* to be ANORM. */
+/* Not modified. */
+
+/* A - COMPLEX*16 array, dimension ( LDA, N ) */
+/* On exit A is the desired test matrix. */
+/* Modified. */
+
+/* LDA - INTEGER */
+/* LDA specifies the first dimension of A as declared in the */
+/* calling program. LDA must be at least M. */
+/* Not modified. */
+
+/* WORK - COMPLEX*16 array, dimension ( 3*N ) */
+/* Workspace. */
+/* Modified. */
+
+/* INFO - INTEGER */
+/* Error code. On exit, INFO will be set to one of the */
+/* following values: */
+/* 0 => normal return */
+/* -1 => N negative */
+/* -2 => DIST illegal string */
+/* -5 => MODE not in range -6 to 6 */
+/* -6 => COND less than 1.0, and MODE neither -6, 0 nor 6 */
+/* -9 => RSIGN is not 'T' or 'F' */
+/* -10 => UPPER is not 'T' or 'F' */
+/* -11 => SIM is not 'T' or 'F' */
+/* -12 => MODES=0 and DS has a zero singular value. */
+/* -13 => MODES is not in the range -5 to 5. */
+/* -14 => MODES is nonzero and CONDS is less than 1. */
+/* -15 => KL is less than 1. */
+/* -16 => KU is less than 1, or KL and KU are both less than */
+/* N-1. */
+/* -19 => LDA is less than M. */
+/* 1 => Error return from ZLATM1 (computing D) */
+/* 2 => Cannot scale to DMAX (max. eigenvalue is 0) */
+/* 3 => Error return from DLATM1 (computing DS) */
+/* 4 => Error return from ZLARGE */
+/* 5 => Zero singular value from DLATM1. */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Decode and Test the input parameters. */
+/* Initialize flags & seed. */
+
+ /* Parameter adjustments */
+ --iseed;
+ --d__;
+ --ds;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*n == 0) {
+ return 0;
+ }
+
+/* Decode DIST */
+
+ if (lsame_(dist, "U")) {
+ idist = 1;
+ } else if (lsame_(dist, "S")) {
+ idist = 2;
+ } else if (lsame_(dist, "N")) {
+ idist = 3;
+ } else if (lsame_(dist, "D")) {
+ idist = 4;
+ } else {
+ idist = -1;
+ }
+
+/* Decode RSIGN */
+
+ if (lsame_(rsign, "T")) {
+ irsign = 1;
+ } else if (lsame_(rsign, "F")) {
+ irsign = 0;
+ } else {
+ irsign = -1;
+ }
+
+/* Decode UPPER */
+
+ if (lsame_(upper, "T")) {
+ iupper = 1;
+ } else if (lsame_(upper, "F")) {
+ iupper = 0;
+ } else {
+ iupper = -1;
+ }
+
+/* Decode SIM */
+
+ if (lsame_(sim, "T")) {
+ isim = 1;
+ } else if (lsame_(sim, "F")) {
+ isim = 0;
+ } else {
+ isim = -1;
+ }
+
+/* Check DS, if MODES=0 and ISIM=1 */
+
+ bads = FALSE_;
+ if (*modes == 0 && isim == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (ds[j] == 0.) {
+ bads = TRUE_;
+ }
+/* L10: */
+ }
+ }
+
+/* Set INFO if an error */
+
+ if (*n < 0) {
+ *info = -1;
+ } else if (idist == -1) {
+ *info = -2;
+ } else if (abs(*mode) > 6) {
+ *info = -5;
+ } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.) {
+ *info = -6;
+ } else if (irsign == -1) {
+ *info = -9;
+ } else if (iupper == -1) {
+ *info = -10;
+ } else if (isim == -1) {
+ *info = -11;
+ } else if (bads) {
+ *info = -12;
+ } else if (isim == 1 && abs(*modes) > 5) {
+ *info = -13;
+ } else if (isim == 1 && *modes != 0 && *conds < 1.) {
+ *info = -14;
+ } else if (*kl < 1) {
+ *info = -15;
+ } else if (*ku < 1 || *ku < *n - 1 && *kl < *n - 1) {
+ *info = -16;
+ } else if (*lda < max(1,*n)) {
+ *info = -19;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLATME", &i__1);
+ return 0;
+ }
+
+/* Initialize random number generator */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
+/* L20: */
+ }
+
+ if (iseed[4] % 2 != 1) {
+ ++iseed[4];
+ }
+
+/* 2) Set up diagonal of A */
+
+/* Compute D according to COND and MODE */
+
+ zlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], n, &iinfo);
+ if (iinfo != 0) {
+ *info = 1;
+ return 0;
+ }
+ if (*mode != 0 && abs(*mode) != 6) {
+
+/* Scale by DMAX */
+
+ temp = z_abs(&d__[1]);
+ i__1 = *n;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = temp, d__2 = z_abs(&d__[i__]);
+ temp = max(d__1,d__2);
+/* L30: */
+ }
+
+ if (temp > 0.) {
+ z__1.r = dmax__->r / temp, z__1.i = dmax__->i / temp;
+ alpha.r = z__1.r, alpha.i = z__1.i;
+ } else {
+ *info = 2;
+ return 0;
+ }
+
+ zscal_(n, &alpha, &d__[1], &c__1);
+
+ }
+
+ zlaset_("Full", n, n, &c_b1, &c_b1, &a[a_offset], lda);
+ i__1 = *lda + 1;
+ zcopy_(n, &d__[1], &c__1, &a[a_offset], &i__1);
+
+/* 3) If UPPER='T', set upper triangle of A to random numbers. */
+
+ if (iupper != 0) {
+ i__1 = *n;
+ for (jc = 2; jc <= i__1; ++jc) {
+ i__2 = jc - 1;
+ zlarnv_(&idist, &iseed[1], &i__2, &a[jc * a_dim1 + 1]);
+/* L40: */
+ }
+ }
+
+/* 4) If SIM='T', apply similarity transformation. */
+
+/* -1 */
+/* Transform is X A X , where X = U S V, thus */
+
+/* it is U S V A V' (1/S) U' */
+
+ if (isim != 0) {
+
+/* Compute S (singular values of the eigenvector matrix) */
+/* according to CONDS and MODES */
+
+ dlatm1_(modes, conds, &c__0, &c__0, &iseed[1], &ds[1], n, &iinfo);
+ if (iinfo != 0) {
+ *info = 3;
+ return 0;
+ }
+
+/* Multiply by V and V' */
+
+ zlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
+ if (iinfo != 0) {
+ *info = 4;
+ return 0;
+ }
+
+/* Multiply by S and (1/S) */
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ zdscal_(n, &ds[j], &a[j + a_dim1], lda);
+ if (ds[j] != 0.) {
+ d__1 = 1. / ds[j];
+ zdscal_(n, &d__1, &a[j * a_dim1 + 1], &c__1);
+ } else {
+ *info = 5;
+ return 0;
+ }
+/* L50: */
+ }
+
+/* Multiply by U and U' */
+
+ zlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
+ if (iinfo != 0) {
+ *info = 4;
+ return 0;
+ }
+ }
+
+/* 5) Reduce the bandwidth. */
+
+ if (*kl < *n - 1) {
+
+/* Reduce bandwidth -- kill column */
+
+ i__1 = *n - 1;
+ for (jcr = *kl + 1; jcr <= i__1; ++jcr) {
+ ic = jcr - *kl;
+ irows = *n + 1 - jcr;
+ icols = *n + *kl - jcr;
+
+ zcopy_(&irows, &a[jcr + ic * a_dim1], &c__1, &work[1], &c__1);
+ xnorms.r = work[1].r, xnorms.i = work[1].i;
+ zlarfg_(&irows, &xnorms, &work[2], &c__1, &tau);
+ d_cnjg(&z__1, &tau);
+ tau.r = z__1.r, tau.i = z__1.i;
+ work[1].r = 1., work[1].i = 0.;
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ alpha.r = z__1.r, alpha.i = z__1.i;
+
+ zgemv_("C", &irows, &icols, &c_b2, &a[jcr + (ic + 1) * a_dim1],
+ lda, &work[1], &c__1, &c_b1, &work[irows + 1], &c__1);
+ z__1.r = -tau.r, z__1.i = -tau.i;
+ zgerc_(&irows, &icols, &z__1, &work[1], &c__1, &work[irows + 1], &
+ c__1, &a[jcr + (ic + 1) * a_dim1], lda);
+
+ zgemv_("N", n, &irows, &c_b2, &a[jcr * a_dim1 + 1], lda, &work[1],
+ &c__1, &c_b1, &work[irows + 1], &c__1);
+ d_cnjg(&z__2, &tau);
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ zgerc_(n, &irows, &z__1, &work[irows + 1], &c__1, &work[1], &c__1,
+ &a[jcr * a_dim1 + 1], lda);
+
+ i__2 = jcr + ic * a_dim1;
+ a[i__2].r = xnorms.r, a[i__2].i = xnorms.i;
+ i__2 = irows - 1;
+ zlaset_("Full", &i__2, &c__1, &c_b1, &c_b1, &a[jcr + 1 + ic *
+ a_dim1], lda);
+
+ i__2 = icols + 1;
+ zscal_(&i__2, &alpha, &a[jcr + ic * a_dim1], lda);
+ d_cnjg(&z__1, &alpha);
+ zscal_(n, &z__1, &a[jcr * a_dim1 + 1], &c__1);
+/* L60: */
+ }
+ } else if (*ku < *n - 1) {
+
+/* Reduce upper bandwidth -- kill a row at a time. */
+
+ i__1 = *n - 1;
+ for (jcr = *ku + 1; jcr <= i__1; ++jcr) {
+ ir = jcr - *ku;
+ irows = *n + *ku - jcr;
+ icols = *n + 1 - jcr;
+
+ zcopy_(&icols, &a[ir + jcr * a_dim1], lda, &work[1], &c__1);
+ xnorms.r = work[1].r, xnorms.i = work[1].i;
+ zlarfg_(&icols, &xnorms, &work[2], &c__1, &tau);
+ d_cnjg(&z__1, &tau);
+ tau.r = z__1.r, tau.i = z__1.i;
+ work[1].r = 1., work[1].i = 0.;
+ i__2 = icols - 1;
+ zlacgv_(&i__2, &work[2], &c__1);
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ alpha.r = z__1.r, alpha.i = z__1.i;
+
+ zgemv_("N", &irows, &icols, &c_b2, &a[ir + 1 + jcr * a_dim1], lda,
+ &work[1], &c__1, &c_b1, &work[icols + 1], &c__1);
+ z__1.r = -tau.r, z__1.i = -tau.i;
+ zgerc_(&irows, &icols, &z__1, &work[icols + 1], &c__1, &work[1], &
+ c__1, &a[ir + 1 + jcr * a_dim1], lda);
+
+ zgemv_("C", &icols, n, &c_b2, &a[jcr + a_dim1], lda, &work[1], &
+ c__1, &c_b1, &work[icols + 1], &c__1);
+ d_cnjg(&z__2, &tau);
+ z__1.r = -z__2.r, z__1.i = -z__2.i;
+ zgerc_(&icols, n, &z__1, &work[1], &c__1, &work[icols + 1], &c__1,
+ &a[jcr + a_dim1], lda);
+
+ i__2 = ir + jcr * a_dim1;
+ a[i__2].r = xnorms.r, a[i__2].i = xnorms.i;
+ i__2 = icols - 1;
+ zlaset_("Full", &c__1, &i__2, &c_b1, &c_b1, &a[ir + (jcr + 1) *
+ a_dim1], lda);
+
+ i__2 = irows + 1;
+ zscal_(&i__2, &alpha, &a[ir + jcr * a_dim1], &c__1);
+ d_cnjg(&z__1, &alpha);
+ zscal_(n, &z__1, &a[jcr + a_dim1], lda);
+/* L70: */
+ }
+ }
+
+/* Scale the matrix to have norm ANORM */
+
+ if (*anorm >= 0.) {
+ temp = zlange_("M", n, n, &a[a_offset], lda, tempa);
+ if (temp > 0.) {
+ ralpha = *anorm / temp;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ zdscal_(n, &ralpha, &a[j * a_dim1 + 1], &c__1);
+/* L80: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZLATME */
+
+} /* zlatme_ */
diff --git a/TESTING/MATGEN/zlatmr.c b/TESTING/MATGEN/zlatmr.c
new file mode 100644
index 0000000..334e2f6
--- /dev/null
+++ b/TESTING/MATGEN/zlatmr.c
@@ -0,0 +1,1506 @@
+/* zlatmr.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__0 = 0;
+static integer c__1 = 1;
+
+/* Subroutine */ int zlatmr_(integer *m, integer *n, char *dist, integer *
+ iseed, char *sym, doublecomplex *d__, integer *mode, doublereal *cond,
+ doublecomplex *dmax__, char *rsign, char *grade, doublecomplex *dl,
+ integer *model, doublereal *condl, doublecomplex *dr, integer *moder,
+ doublereal *condr, char *pivtng, integer *ipivot, integer *kl,
+ integer *ku, doublereal *sparse, doublereal *anorm, char *pack,
+ doublecomplex *a, integer *lda, integer *iwork, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+ doublereal d__1, d__2;
+ doublecomplex z__1, z__2;
+
+ /* Builtin functions */
+ double z_abs(doublecomplex *);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ integer i__, j, k, kll, kuu, isub, jsub;
+ doublereal temp;
+ integer isym, ipack;
+ extern logical lsame_(char *, char *);
+ doublereal tempa[1];
+ doublecomplex ctemp;
+ integer iisub, idist, jjsub, mnmin;
+ logical dzero;
+ integer mnsub;
+ doublereal onorm;
+ integer mxsub, npvts;
+ extern /* Subroutine */ int zlatm1_(integer *, doublereal *, integer *,
+ integer *, integer *, doublecomplex *, integer *, integer *);
+ extern /* Double Complex */ VOID zlatm2_(doublecomplex *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ integer *, doublecomplex *, integer *, doublecomplex *,
+ doublecomplex *, integer *, integer *, doublereal *), zlatm3_(
+ doublecomplex *, integer *, integer *, integer *, integer *,
+ integer *, integer *, integer *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublecomplex *, doublecomplex *,
+ integer *, integer *, doublereal *);
+ doublecomplex calpha;
+ integer igrade;
+ logical fulbnd;
+ extern doublereal zlangb_(char *, integer *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+ extern /* Subroutine */ int xerbla_(char *, integer *);
+ logical badpvt;
+ extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
+ integer *, doublereal *);
+ extern /* Subroutine */ int zdscal_(integer *, doublereal *,
+ doublecomplex *, integer *);
+ extern doublereal zlansb_(char *, char *, integer *, integer *,
+ doublecomplex *, integer *, doublereal *);
+ integer irsign, ipvtng;
+ extern doublereal zlansp_(char *, char *, integer *, doublecomplex *,
+ doublereal *), zlansy_(char *, char *, integer *,
+ doublecomplex *, integer *, doublereal *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLATMR generates random matrices of various types for testing */
+/* LAPACK programs. */
+
+/* ZLATMR operates by applying the following sequence of */
+/* operations: */
+
+/* Generate a matrix A with random entries of distribution DIST */
+/* which is symmetric if SYM='S', Hermitian if SYM='H', and */
+/* nonsymmetric if SYM='N'. */
+
+/* Set the diagonal to D, where D may be input or */
+/* computed according to MODE, COND, DMAX and RSIGN */
+/* as described below. */
+
+/* Grade the matrix, if desired, from the left and/or right */
+/* as specified by GRADE. The inputs DL, MODEL, CONDL, DR, */
+/* MODER and CONDR also determine the grading as described */
+/* below. */
+
+/* Permute, if desired, the rows and/or columns as specified by */
+/* PIVTNG and IPIVOT. */
+
+/* Set random entries to zero, if desired, to get a random sparse */
+/* matrix as specified by SPARSE. */
+
+/* Make A a band matrix, if desired, by zeroing out the matrix */
+/* outside a band of lower bandwidth KL and upper bandwidth KU. */
+
+/* Scale A, if desired, to have maximum entry ANORM. */
+
+/* Pack the matrix if desired. Options specified by PACK are: */
+/* no packing */
+/* zero out upper half (if symmetric or Hermitian) */
+/* zero out lower half (if symmetric or Hermitian) */
+/* store the upper half columnwise (if symmetric or Hermitian */
+/* or square upper triangular) */
+/* store the lower half columnwise (if symmetric or Hermitian */
+/* or square lower triangular) */
+/* same as upper half rowwise if symmetric */
+/* same as conjugate upper half rowwise if Hermitian */
+/* store the lower triangle in banded format */
+/* (if symmetric or Hermitian) */
+/* store the upper triangle in banded format */
+/* (if symmetric or Hermitian) */
+/* store the entire matrix in banded format */
+
+/* Note: If two calls to ZLATMR differ only in the PACK parameter, */
+/* they will generate mathematically equivalent matrices. */
+
+/* If two calls to ZLATMR both have full bandwidth (KL = M-1 */
+/* and KU = N-1), and differ only in the PIVTNG and PACK */
+/* parameters, then the matrices generated will differ only */
+/* in the order of the rows and/or columns, and otherwise */
+/* contain the same data. This consistency cannot be and */
+/* is not maintained with less than full bandwidth. */
+
+/* Arguments */
+/* ========= */
+
+/* M - INTEGER */
+/* Number of rows of A. Not modified. */
+
+/* N - INTEGER */
+/* Number of columns of A. Not modified. */
+
+/* DIST - CHARACTER*1 */
+/* On entry, DIST specifies the type of distribution to be used */
+/* to generate a random matrix . */
+/* 'U' => real and imaginary parts are independent */
+/* UNIFORM( 0, 1 ) ( 'U' for uniform ) */
+/* 'S' => real and imaginary parts are independent */
+/* UNIFORM( -1, 1 ) ( 'S' for symmetric ) */
+/* 'N' => real and imaginary parts are independent */
+/* NORMAL( 0, 1 ) ( 'N' for normal ) */
+/* 'D' => uniform on interior of unit disk ( 'D' for disk ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension (4) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. They should lie between 0 and 4095 inclusive, */
+/* and ISEED(4) should be odd. The random number generator */
+/* uses a linear congruential sequence limited to small */
+/* integers, and so should produce machine independent */
+/* random numbers. The values of ISEED are changed on */
+/* exit, and can be used in the next call to ZLATMR */
+/* to continue the same random number sequence. */
+/* Changed on exit. */
+
+/* SYM - CHARACTER*1 */
+/* If SYM='S', generated matrix is symmetric. */
+/* If SYM='H', generated matrix is Hermitian. */
+/* If SYM='N', generated matrix is nonsymmetric. */
+/* Not modified. */
+
+/* D - COMPLEX*16 array, dimension (min(M,N)) */
+/* On entry this array specifies the diagonal entries */
+/* of the diagonal of A. D may either be specified */
+/* on entry, or set according to MODE and COND as described */
+/* below. If the matrix is Hermitian, the real part of D */
+/* will be taken. May be changed on exit if MODE is nonzero. */
+
+/* MODE - INTEGER */
+/* On entry describes how D is to be used: */
+/* MODE = 0 means use D as input */
+/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
+/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
+/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
+/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* MODE = 5 sets D to random numbers in the range */
+/* ( 1/COND , 1 ) such that their logarithms */
+/* are uniformly distributed. */
+/* MODE = 6 set D to random numbers from same distribution */
+/* as the rest of the matrix. */
+/* MODE < 0 has the same meaning as ABS(MODE), except that */
+/* the order of the elements of D is reversed. */
+/* Thus if MODE is positive, D has entries ranging from */
+/* 1 to 1/COND, if negative, from 1/COND to 1, */
+/* Not modified. */
+
+/* COND - DOUBLE PRECISION */
+/* On entry, used as described under MODE above. */
+/* If used, it must be >= 1. Not modified. */
+
+/* DMAX - COMPLEX*16 */
+/* If MODE neither -6, 0 nor 6, the diagonal is scaled by */
+/* DMAX / max(abs(D(i))), so that maximum absolute entry */
+/* of diagonal is abs(DMAX). If DMAX is complex (or zero), */
+/* diagonal will be scaled by a complex number (or zero). */
+
+/* RSIGN - CHARACTER*1 */
+/* If MODE neither -6, 0 nor 6, specifies sign of diagonal */
+/* as follows: */
+/* 'T' => diagonal entries are multiplied by a random complex */
+/* number uniformly distributed with absolute value 1 */
+/* 'F' => diagonal unchanged */
+/* Not modified. */
+
+/* GRADE - CHARACTER*1 */
+/* Specifies grading of matrix as follows: */
+/* 'N' => no grading */
+/* 'L' => matrix premultiplied by diag( DL ) */
+/* (only if matrix nonsymmetric) */
+/* 'R' => matrix postmultiplied by diag( DR ) */
+/* (only if matrix nonsymmetric) */
+/* 'B' => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DR ) */
+/* (only if matrix nonsymmetric) */
+/* 'H' => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( CONJG(DL) ) */
+/* (only if matrix Hermitian or nonsymmetric) */
+/* 'S' => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by diag( DL ) */
+/* (only if matrix symmetric or nonsymmetric) */
+/* 'E' => matrix premultiplied by diag( DL ) and */
+/* postmultiplied by inv( diag( DL ) ) */
+/* ( 'S' for similarity ) */
+/* (only if matrix nonsymmetric) */
+/* Note: if GRADE='S', then M must equal N. */
+/* Not modified. */
+
+/* DL - COMPLEX*16 array, dimension (M) */
+/* If MODEL=0, then on entry this array specifies the diagonal */
+/* entries of a diagonal matrix used as described under GRADE */
+/* above. If MODEL is not zero, then DL will be set according */
+/* to MODEL and CONDL, analogous to the way D is set according */
+/* to MODE and COND (except there is no DMAX parameter for DL). */
+/* If GRADE='E', then DL cannot have zero entries. */
+/* Not referenced if GRADE = 'N' or 'R'. Changed on exit. */
+
+/* MODEL - INTEGER */
+/* This specifies how the diagonal array DL is to be computed, */
+/* just as MODE specifies how D is to be computed. */
+/* Not modified. */
+
+/* CONDL - DOUBLE PRECISION */
+/* When MODEL is not zero, this specifies the condition number */
+/* of the computed DL. Not modified. */
+
+/* DR - COMPLEX*16 array, dimension (N) */
+/* If MODER=0, then on entry this array specifies the diagonal */
+/* entries of a diagonal matrix used as described under GRADE */
+/* above. If MODER is not zero, then DR will be set according */
+/* to MODER and CONDR, analogous to the way D is set according */
+/* to MODE and COND (except there is no DMAX parameter for DR). */
+/* Not referenced if GRADE = 'N', 'L', 'H' or 'S'. */
+/* Changed on exit. */
+
+/* MODER - INTEGER */
+/* This specifies how the diagonal array DR is to be computed, */
+/* just as MODE specifies how D is to be computed. */
+/* Not modified. */
+
+/* CONDR - DOUBLE PRECISION */
+/* When MODER is not zero, this specifies the condition number */
+/* of the computed DR. Not modified. */
+
+/* PIVTNG - CHARACTER*1 */
+/* On entry specifies pivoting permutations as follows: */
+/* 'N' or ' ' => none. */
+/* 'L' => left or row pivoting (matrix must be nonsymmetric). */
+/* 'R' => right or column pivoting (matrix must be */
+/* nonsymmetric). */
+/* 'B' or 'F' => both or full pivoting, i.e., on both sides. */
+/* In this case, M must equal N */
+
+/* If two calls to ZLATMR both have full bandwidth (KL = M-1 */
+/* and KU = N-1), and differ only in the PIVTNG and PACK */
+/* parameters, then the matrices generated will differ only */
+/* in the order of the rows and/or columns, and otherwise */
+/* contain the same data. This consistency cannot be */
+/* maintained with less than full bandwidth. */
+
+/* IPIVOT - INTEGER array, dimension (N or M) */
+/* This array specifies the permutation used. After the */
+/* basic matrix is generated, the rows, columns, or both */
+/* are permuted. If, say, row pivoting is selected, ZLATMR */
+/* starts with the *last* row and interchanges the M-th and */
+/* IPIVOT(M)-th rows, then moves to the next-to-last row, */
+/* interchanging the (M-1)-th and the IPIVOT(M-1)-th rows, */
+/* and so on. In terms of "2-cycles", the permutation is */
+/* (1 IPIVOT(1)) (2 IPIVOT(2)) ... (M IPIVOT(M)) */
+/* where the rightmost cycle is applied first. This is the */
+/* *inverse* of the effect of pivoting in LINPACK. The idea */
+/* is that factoring (with pivoting) an identity matrix */
+/* which has been inverse-pivoted in this way should */
+/* result in a pivot vector identical to IPIVOT. */
+/* Not referenced if PIVTNG = 'N'. Not modified. */
+
+/* SPARSE - DOUBLE PRECISION */
+/* On entry specifies the sparsity of the matrix if a sparse */
+/* matrix is to be generated. SPARSE should lie between */
+/* 0 and 1. To generate a sparse matrix, for each matrix entry */
+/* a uniform ( 0, 1 ) random number x is generated and */
+/* compared to SPARSE; if x is larger the matrix entry */
+/* is unchanged and if x is smaller the entry is set */
+/* to zero. Thus on the average a fraction SPARSE of the */
+/* entries will be set to zero. */
+/* Not modified. */
+
+/* KL - INTEGER */
+/* On entry specifies the lower bandwidth of the matrix. For */
+/* example, KL=0 implies upper triangular, KL=1 implies upper */
+/* Hessenberg, and KL at least M-1 implies the matrix is not */
+/* banded. Must equal KU if matrix is symmetric or Hermitian. */
+/* Not modified. */
+
+/* KU - INTEGER */
+/* On entry specifies the upper bandwidth of the matrix. For */
+/* example, KU=0 implies lower triangular, KU=1 implies lower */
+/* Hessenberg, and KU at least N-1 implies the matrix is not */
+/* banded. Must equal KL if matrix is symmetric or Hermitian. */
+/* Not modified. */
+
+/* ANORM - DOUBLE PRECISION */
+/* On entry specifies maximum entry of output matrix */
+/* (output matrix will by multiplied by a constant so that */
+/* its largest absolute entry equal ANORM) */
+/* if ANORM is nonnegative. If ANORM is negative no scaling */
+/* is done. Not modified. */
+
+/* PACK - CHARACTER*1 */
+/* On entry specifies packing of matrix as follows: */
+/* 'N' => no packing */
+/* 'U' => zero out all subdiagonal entries */
+/* (if symmetric or Hermitian) */
+/* 'L' => zero out all superdiagonal entries */
+/* (if symmetric or Hermitian) */
+/* 'C' => store the upper triangle columnwise */
+/* (only if matrix symmetric or Hermitian or */
+/* square upper triangular) */
+/* 'R' => store the lower triangle columnwise */
+/* (only if matrix symmetric or Hermitian or */
+/* square lower triangular) */
+/* (same as upper half rowwise if symmetric) */
+/* (same as conjugate upper half rowwise if Hermitian) */
+/* 'B' => store the lower triangle in band storage scheme */
+/* (only if matrix symmetric or Hermitian) */
+/* 'Q' => store the upper triangle in band storage scheme */
+/* (only if matrix symmetric or Hermitian) */
+/* 'Z' => store the entire matrix in band storage scheme */
+/* (pivoting can be provided for by using this */
+/* option to store A in the trailing rows of */
+/* the allocated storage) */
+
+/* Using these options, the various LAPACK packed and banded */
+/* storage schemes can be obtained: */
+/* GB - use 'Z' */
+/* PB, HB or TB - use 'B' or 'Q' */
+/* PP, HP or TP - use 'C' or 'R' */
+
+/* If two calls to ZLATMR differ only in the PACK parameter, */
+/* they will generate mathematically equivalent matrices. */
+/* Not modified. */
+
+/* A - COMPLEX*16 array, dimension (LDA,N) */
+/* On exit A is the desired test matrix. Only those */
+/* entries of A which are significant on output */
+/* will be referenced (even if A is in packed or band */
+/* storage format). The 'unoccupied corners' of A in */
+/* band format will be zeroed out. */
+
+/* LDA - INTEGER */
+/* on entry LDA specifies the first dimension of A as */
+/* declared in the calling program. */
+/* If PACK='N', 'U' or 'L', LDA must be at least max ( 1, M ). */
+/* If PACK='C' or 'R', LDA must be at least 1. */
+/* If PACK='B', or 'Q', LDA must be MIN ( KU+1, N ) */
+/* If PACK='Z', LDA must be at least KUU+KLL+1, where */
+/* KUU = MIN ( KU, N-1 ) and KLL = MIN ( KL, N-1 ) */
+/* Not modified. */
+
+/* IWORK - INTEGER array, dimension (N or M) */
+/* Workspace. Not referenced if PIVTNG = 'N'. Changed on exit. */
+
+/* INFO - INTEGER */
+/* Error parameter on exit: */
+/* 0 => normal return */
+/* -1 => M negative or unequal to N and SYM='S' or 'H' */
+/* -2 => N negative */
+/* -3 => DIST illegal string */
+/* -5 => SYM illegal string */
+/* -7 => MODE not in range -6 to 6 */
+/* -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */
+/* -10 => MODE neither -6, 0 nor 6 and RSIGN illegal string */
+/* -11 => GRADE illegal string, or GRADE='E' and */
+/* M not equal to N, or GRADE='L', 'R', 'B', 'S' or 'E' */
+/* and SYM = 'H', or GRADE='L', 'R', 'B', 'H' or 'E' */
+/* and SYM = 'S' */
+/* -12 => GRADE = 'E' and DL contains zero */
+/* -13 => MODEL not in range -6 to 6 and GRADE= 'L', 'B', 'H', */
+/* 'S' or 'E' */
+/* -14 => CONDL less than 1.0, GRADE='L', 'B', 'H', 'S' or 'E', */
+/* and MODEL neither -6, 0 nor 6 */
+/* -16 => MODER not in range -6 to 6 and GRADE= 'R' or 'B' */
+/* -17 => CONDR less than 1.0, GRADE='R' or 'B', and */
+/* MODER neither -6, 0 nor 6 */
+/* -18 => PIVTNG illegal string, or PIVTNG='B' or 'F' and */
+/* M not equal to N, or PIVTNG='L' or 'R' and SYM='S' */
+/* or 'H' */
+/* -19 => IPIVOT contains out of range number and */
+/* PIVTNG not equal to 'N' */
+/* -20 => KL negative */
+/* -21 => KU negative, or SYM='S' or 'H' and KU not equal to KL */
+/* -22 => SPARSE not in range 0. to 1. */
+/* -24 => PACK illegal string, or PACK='U', 'L', 'B' or 'Q' */
+/* and SYM='N', or PACK='C' and SYM='N' and either KL */
+/* not equal to 0 or N not equal to M, or PACK='R' and */
+/* SYM='N', and either KU not equal to 0 or N not equal */
+/* to M */
+/* -26 => LDA too small */
+/* 1 => Error return from ZLATM1 (computing D) */
+/* 2 => Cannot scale diagonal to DMAX (max. entry is 0) */
+/* 3 => Error return from ZLATM1 (computing DL) */
+/* 4 => Error return from ZLATM1 (computing DR) */
+/* 5 => ANORM is positive, but matrix constructed prior to */
+/* attempting to scale it to have norm ANORM, is zero */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. Local Arrays .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Decode and Test the input parameters. */
+/* Initialize flags & seed. */
+
+ /* Parameter adjustments */
+ --iseed;
+ --d__;
+ --dl;
+ --dr;
+ --ipivot;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --iwork;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Decode DIST */
+
+ if (lsame_(dist, "U")) {
+ idist = 1;
+ } else if (lsame_(dist, "S")) {
+ idist = 2;
+ } else if (lsame_(dist, "N")) {
+ idist = 3;
+ } else if (lsame_(dist, "D")) {
+ idist = 4;
+ } else {
+ idist = -1;
+ }
+
+/* Decode SYM */
+
+ if (lsame_(sym, "H")) {
+ isym = 0;
+ } else if (lsame_(sym, "N")) {
+ isym = 1;
+ } else if (lsame_(sym, "S")) {
+ isym = 2;
+ } else {
+ isym = -1;
+ }
+
+/* Decode RSIGN */
+
+ if (lsame_(rsign, "F")) {
+ irsign = 0;
+ } else if (lsame_(rsign, "T")) {
+ irsign = 1;
+ } else {
+ irsign = -1;
+ }
+
+/* Decode PIVTNG */
+
+ if (lsame_(pivtng, "N")) {
+ ipvtng = 0;
+ } else if (lsame_(pivtng, " ")) {
+ ipvtng = 0;
+ } else if (lsame_(pivtng, "L")) {
+ ipvtng = 1;
+ npvts = *m;
+ } else if (lsame_(pivtng, "R")) {
+ ipvtng = 2;
+ npvts = *n;
+ } else if (lsame_(pivtng, "B")) {
+ ipvtng = 3;
+ npvts = min(*n,*m);
+ } else if (lsame_(pivtng, "F")) {
+ ipvtng = 3;
+ npvts = min(*n,*m);
+ } else {
+ ipvtng = -1;
+ }
+
+/* Decode GRADE */
+
+ if (lsame_(grade, "N")) {
+ igrade = 0;
+ } else if (lsame_(grade, "L")) {
+ igrade = 1;
+ } else if (lsame_(grade, "R")) {
+ igrade = 2;
+ } else if (lsame_(grade, "B")) {
+ igrade = 3;
+ } else if (lsame_(grade, "E")) {
+ igrade = 4;
+ } else if (lsame_(grade, "H")) {
+ igrade = 5;
+ } else if (lsame_(grade, "S")) {
+ igrade = 6;
+ } else {
+ igrade = -1;
+ }
+
+/* Decode PACK */
+
+ if (lsame_(pack, "N")) {
+ ipack = 0;
+ } else if (lsame_(pack, "U")) {
+ ipack = 1;
+ } else if (lsame_(pack, "L")) {
+ ipack = 2;
+ } else if (lsame_(pack, "C")) {
+ ipack = 3;
+ } else if (lsame_(pack, "R")) {
+ ipack = 4;
+ } else if (lsame_(pack, "B")) {
+ ipack = 5;
+ } else if (lsame_(pack, "Q")) {
+ ipack = 6;
+ } else if (lsame_(pack, "Z")) {
+ ipack = 7;
+ } else {
+ ipack = -1;
+ }
+
+/* Set certain internal parameters */
+
+ mnmin = min(*m,*n);
+/* Computing MIN */
+ i__1 = *kl, i__2 = *m - 1;
+ kll = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *ku, i__2 = *n - 1;
+ kuu = min(i__1,i__2);
+
+/* If inv(DL) is used, check to see if DL has a zero entry. */
+
+ dzero = FALSE_;
+ if (igrade == 4 && *model == 0) {
+ i__1 = *m;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ if (dl[i__2].r == 0. && dl[i__2].i == 0.) {
+ dzero = TRUE_;
+ }
+/* L10: */
+ }
+ }
+
+/* Check values in IPIVOT */
+
+ badpvt = FALSE_;
+ if (ipvtng > 0) {
+ i__1 = npvts;
+ for (j = 1; j <= i__1; ++j) {
+ if (ipivot[j] <= 0 || ipivot[j] > npvts) {
+ badpvt = TRUE_;
+ }
+/* L20: */
+ }
+ }
+
+/* Set INFO if an error */
+
+ if (*m < 0) {
+ *info = -1;
+ } else if (*m != *n && (isym == 0 || isym == 2)) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (idist == -1) {
+ *info = -3;
+ } else if (isym == -1) {
+ *info = -5;
+ } else if (*mode < -6 || *mode > 6) {
+ *info = -7;
+ } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.) {
+ *info = -8;
+ } else if (*mode != -6 && *mode != 0 && *mode != 6 && irsign == -1) {
+ *info = -10;
+ } else if (igrade == -1 || igrade == 4 && *m != *n || (igrade == 1 ||
+ igrade == 2 || igrade == 3 || igrade == 4 || igrade == 6) && isym
+ == 0 || (igrade == 1 || igrade == 2 || igrade == 3 || igrade == 4
+ || igrade == 5) && isym == 2) {
+ *info = -11;
+ } else if (igrade == 4 && dzero) {
+ *info = -12;
+ } else if ((igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5 ||
+ igrade == 6) && (*model < -6 || *model > 6)) {
+ *info = -13;
+ } else if ((igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5 ||
+ igrade == 6) && (*model != -6 && *model != 0 && *model != 6) && *
+ condl < 1.) {
+ *info = -14;
+ } else if ((igrade == 2 || igrade == 3) && (*moder < -6 || *moder > 6)) {
+ *info = -16;
+ } else if ((igrade == 2 || igrade == 3) && (*moder != -6 && *moder != 0 &&
+ *moder != 6) && *condr < 1.) {
+ *info = -17;
+ } else if (ipvtng == -1 || ipvtng == 3 && *m != *n || (ipvtng == 1 ||
+ ipvtng == 2) && (isym == 0 || isym == 2)) {
+ *info = -18;
+ } else if (ipvtng != 0 && badpvt) {
+ *info = -19;
+ } else if (*kl < 0) {
+ *info = -20;
+ } else if (*ku < 0 || (isym == 0 || isym == 2) && *kl != *ku) {
+ *info = -21;
+ } else if (*sparse < 0. || *sparse > 1.) {
+ *info = -22;
+ } else if (ipack == -1 || (ipack == 1 || ipack == 2 || ipack == 5 ||
+ ipack == 6) && isym == 1 || ipack == 3 && isym == 1 && (*kl != 0
+ || *m != *n) || ipack == 4 && isym == 1 && (*ku != 0 || *m != *n))
+ {
+ *info = -24;
+ } else if ((ipack == 0 || ipack == 1 || ipack == 2) && *lda < max(1,*m) ||
+ (ipack == 3 || ipack == 4) && *lda < 1 || (ipack == 5 || ipack ==
+ 6) && *lda < kuu + 1 || ipack == 7 && *lda < kll + kuu + 1) {
+ *info = -26;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLATMR", &i__1);
+ return 0;
+ }
+
+/* Decide if we can pivot consistently */
+
+ fulbnd = FALSE_;
+ if (kuu == *n - 1 && kll == *m - 1) {
+ fulbnd = TRUE_;
+ }
+
+/* Initialize random number generator */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
+/* L30: */
+ }
+
+ iseed[4] = (iseed[4] / 2 << 1) + 1;
+
+/* 2) Set up D, DL, and DR, if indicated. */
+
+/* Compute D according to COND and MODE */
+
+ zlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, info);
+ if (*info != 0) {
+ *info = 1;
+ return 0;
+ }
+ if (*mode != 0 && *mode != -6 && *mode != 6) {
+
+/* Scale by DMAX */
+
+ temp = z_abs(&d__[1]);
+ i__1 = mnmin;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__1 = temp, d__2 = z_abs(&d__[i__]);
+ temp = max(d__1,d__2);
+/* L40: */
+ }
+ if (temp == 0. && (dmax__->r != 0. || dmax__->i != 0.)) {
+ *info = 2;
+ return 0;
+ }
+ if (temp != 0.) {
+ z__1.r = dmax__->r / temp, z__1.i = dmax__->i / temp;
+ calpha.r = z__1.r, calpha.i = z__1.i;
+ } else {
+ calpha.r = 1., calpha.i = 0.;
+ }
+ i__1 = mnmin;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ z__1.r = calpha.r * d__[i__3].r - calpha.i * d__[i__3].i, z__1.i =
+ calpha.r * d__[i__3].i + calpha.i * d__[i__3].r;
+ d__[i__2].r = z__1.r, d__[i__2].i = z__1.i;
+/* L50: */
+ }
+
+ }
+
+/* If matrix Hermitian, make D real */
+
+ if (isym == 0) {
+ i__1 = mnmin;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = i__;
+ i__3 = i__;
+ d__1 = d__[i__3].r;
+ d__[i__2].r = d__1, d__[i__2].i = 0.;
+/* L60: */
+ }
+ }
+
+/* Compute DL if grading set */
+
+ if (igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5 || igrade ==
+ 6) {
+ zlatm1_(model, condl, &c__0, &idist, &iseed[1], &dl[1], m, info);
+ if (*info != 0) {
+ *info = 3;
+ return 0;
+ }
+ }
+
+/* Compute DR if grading set */
+
+ if (igrade == 2 || igrade == 3) {
+ zlatm1_(moder, condr, &c__0, &idist, &iseed[1], &dr[1], n, info);
+ if (*info != 0) {
+ *info = 4;
+ return 0;
+ }
+ }
+
+/* 3) Generate IWORK if pivoting */
+
+ if (ipvtng > 0) {
+ i__1 = npvts;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ iwork[i__] = i__;
+/* L70: */
+ }
+ if (fulbnd) {
+ i__1 = npvts;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ k = ipivot[i__];
+ j = iwork[i__];
+ iwork[i__] = iwork[k];
+ iwork[k] = j;
+/* L80: */
+ }
+ } else {
+ for (i__ = npvts; i__ >= 1; --i__) {
+ k = ipivot[i__];
+ j = iwork[i__];
+ iwork[i__] = iwork[k];
+ iwork[k] = j;
+/* L90: */
+ }
+ }
+ }
+
+/* 4) Generate matrices for each kind of PACKing */
+/* Always sweep matrix columnwise (if symmetric, upper */
+/* half only) so that matrix generated does not depend */
+/* on PACK */
+
+ if (fulbnd) {
+
+/* Use ZLATM3 so matrices generated with differing PIVOTing only */
+/* differ only in the order of their rows and/or columns. */
+
+ if (ipack == 0) {
+ if (isym == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ zlatm3_(&z__1, m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__3 = isub + jsub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+ i__3 = jsub + isub * a_dim1;
+ d_cnjg(&z__1, &ctemp);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L100: */
+ }
+/* L110: */
+ }
+ } else if (isym == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ zlatm3_(&z__1, m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__3 = isub + jsub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+/* L120: */
+ }
+/* L130: */
+ }
+ } else if (isym == 2) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ zlatm3_(&z__1, m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__3 = isub + jsub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+ i__3 = jsub + isub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+/* L140: */
+ }
+/* L150: */
+ }
+ }
+
+ } else if (ipack == 1) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ zlatm3_(&z__1, m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ if (mxsub == isub && isym == 0) {
+ i__3 = mnsub + mxsub * a_dim1;
+ d_cnjg(&z__1, &ctemp);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ } else {
+ i__3 = mnsub + mxsub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+ }
+ if (mnsub != mxsub) {
+ i__3 = mxsub + mnsub * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ }
+/* L160: */
+ }
+/* L170: */
+ }
+
+ } else if (ipack == 2) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ zlatm3_(&z__1, m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ if (mxsub == jsub && isym == 0) {
+ i__3 = mxsub + mnsub * a_dim1;
+ d_cnjg(&z__1, &ctemp);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ } else {
+ i__3 = mxsub + mnsub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+ }
+ if (mnsub != mxsub) {
+ i__3 = mnsub + mxsub * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ }
+/* L180: */
+ }
+/* L190: */
+ }
+
+ } else if (ipack == 3) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ zlatm3_(&z__1, m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+
+/* Compute K = location of (ISUB,JSUB) entry in packed */
+/* array */
+
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ k = mxsub * (mxsub - 1) / 2 + mnsub;
+
+/* Convert K to (IISUB,JJSUB) location */
+
+ jjsub = (k - 1) / *lda + 1;
+ iisub = k - *lda * (jjsub - 1);
+
+ if (mxsub == isub && isym == 0) {
+ i__3 = iisub + jjsub * a_dim1;
+ d_cnjg(&z__1, &ctemp);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ } else {
+ i__3 = iisub + jjsub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+
+ } else if (ipack == 4) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ zlatm3_(&z__1, m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+
+/* Compute K = location of (I,J) entry in packed array */
+
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ if (mnsub == 1) {
+ k = mxsub;
+ } else {
+ k = *n * (*n + 1) / 2 - (*n - mnsub + 1) * (*n -
+ mnsub + 2) / 2 + mxsub - mnsub + 1;
+ }
+
+/* Convert K to (IISUB,JJSUB) location */
+
+ jjsub = (k - 1) / *lda + 1;
+ iisub = k - *lda * (jjsub - 1);
+
+ if (mxsub == jsub && isym == 0) {
+ i__3 = iisub + jjsub * a_dim1;
+ d_cnjg(&z__1, &ctemp);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ } else {
+ i__3 = iisub + jjsub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+ }
+/* L220: */
+ }
+/* L230: */
+ }
+
+ } else if (ipack == 5) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ if (i__ < 1) {
+ i__3 = j - i__ + 1 + (i__ + *n) * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ } else {
+ zlatm3_(&z__1, m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ if (mxsub == jsub && isym == 0) {
+ i__3 = mxsub - mnsub + 1 + mnsub * a_dim1;
+ d_cnjg(&z__1, &ctemp);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ } else {
+ i__3 = mxsub - mnsub + 1 + mnsub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+ }
+ }
+/* L240: */
+ }
+/* L250: */
+ }
+
+ } else if (ipack == 6) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ zlatm3_(&z__1, m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ if (mxsub == isub && isym == 0) {
+ i__3 = mnsub - mxsub + kuu + 1 + mxsub * a_dim1;
+ d_cnjg(&z__1, &ctemp);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ } else {
+ i__3 = mnsub - mxsub + kuu + 1 + mxsub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+ }
+/* L260: */
+ }
+/* L270: */
+ }
+
+ } else if (ipack == 7) {
+
+ if (isym != 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ zlatm3_(&z__1, m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ mnsub = min(isub,jsub);
+ mxsub = max(isub,jsub);
+ if (i__ < 1) {
+ i__3 = j - i__ + 1 + kuu + (i__ + *n) * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ }
+ if (mxsub == isub && isym == 0) {
+ i__3 = mnsub - mxsub + kuu + 1 + mxsub * a_dim1;
+ d_cnjg(&z__1, &ctemp);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ } else {
+ i__3 = mnsub - mxsub + kuu + 1 + mxsub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+ }
+ if (i__ >= 1 && mnsub != mxsub) {
+ if (mnsub == isub && isym == 0) {
+ i__3 = mxsub - mnsub + 1 + kuu + mnsub *
+ a_dim1;
+ d_cnjg(&z__1, &ctemp);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ } else {
+ i__3 = mxsub - mnsub + 1 + kuu + mnsub *
+ a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+ }
+ }
+/* L280: */
+ }
+/* L290: */
+ }
+ } else if (isym == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + kll;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ zlatm3_(&z__1, m, n, &i__, &j, &isub, &jsub, kl, ku, &
+ idist, &iseed[1], &d__[1], &igrade, &dl[1], &
+ dr[1], &ipvtng, &iwork[1], sparse);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ i__3 = isub - jsub + kuu + 1 + jsub * a_dim1;
+ a[i__3].r = ctemp.r, a[i__3].i = ctemp.i;
+/* L300: */
+ }
+/* L310: */
+ }
+ }
+
+ }
+
+ } else {
+
+/* Use ZLATM2 */
+
+ if (ipack == 0) {
+ if (isym == 0) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, &iseed[
+ 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng,
+ &iwork[1], sparse);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ i__3 = j + i__ * a_dim1;
+ d_cnjg(&z__1, &a[i__ + j * a_dim1]);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L320: */
+ }
+/* L330: */
+ }
+ } else if (isym == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, &iseed[
+ 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng,
+ &iwork[1], sparse);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L340: */
+ }
+/* L350: */
+ }
+ } else if (isym == 2) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, &iseed[
+ 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng,
+ &iwork[1], sparse);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ i__3 = j + i__ * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
+/* L360: */
+ }
+/* L370: */
+ }
+ }
+
+ } else if (ipack == 1) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__3 = i__ + j * a_dim1;
+ zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, &iseed[1],
+ &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, &iwork[
+ 1], sparse);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ if (i__ != j) {
+ i__3 = j + i__ * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ }
+/* L380: */
+ }
+/* L390: */
+ }
+
+ } else if (ipack == 2) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ if (isym == 0) {
+ i__3 = j + i__ * a_dim1;
+ zlatm2_(&z__2, m, n, &i__, &j, kl, ku, &idist, &iseed[
+ 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng,
+ &iwork[1], sparse);
+ d_cnjg(&z__1, &z__2);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ } else {
+ i__3 = j + i__ * a_dim1;
+ zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, &iseed[
+ 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng,
+ &iwork[1], sparse);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ }
+ if (i__ != j) {
+ i__3 = i__ + j * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ }
+/* L400: */
+ }
+/* L410: */
+ }
+
+ } else if (ipack == 3) {
+
+ isub = 0;
+ jsub = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ++isub;
+ if (isub > *lda) {
+ isub = 1;
+ ++jsub;
+ }
+ i__3 = isub + jsub * a_dim1;
+ zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, &iseed[1],
+ &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, &iwork[
+ 1], sparse);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L420: */
+ }
+/* L430: */
+ }
+
+ } else if (ipack == 4) {
+
+ if (isym == 0 || isym == 2) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+
+/* Compute K = location of (I,J) entry in packed array */
+
+ if (i__ == 1) {
+ k = j;
+ } else {
+ k = *n * (*n + 1) / 2 - (*n - i__ + 1) * (*n -
+ i__ + 2) / 2 + j - i__ + 1;
+ }
+
+/* Convert K to (ISUB,JSUB) location */
+
+ jsub = (k - 1) / *lda + 1;
+ isub = k - *lda * (jsub - 1);
+
+ i__3 = isub + jsub * a_dim1;
+ zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, &iseed[
+ 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng,
+ &iwork[1], sparse);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ if (isym == 0) {
+ i__3 = isub + jsub * a_dim1;
+ d_cnjg(&z__1, &a[isub + jsub * a_dim1]);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ }
+/* L440: */
+ }
+/* L450: */
+ }
+ } else {
+ isub = 0;
+ jsub = 1;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ++isub;
+ if (isub > *lda) {
+ isub = 1;
+ ++jsub;
+ }
+ i__3 = isub + jsub * a_dim1;
+ zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, &iseed[
+ 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng,
+ &iwork[1], sparse);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L460: */
+ }
+/* L470: */
+ }
+ }
+
+ } else if (ipack == 5) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ if (i__ < 1) {
+ i__3 = j - i__ + 1 + (i__ + *n) * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ } else {
+ if (isym == 0) {
+ i__3 = j - i__ + 1 + i__ * a_dim1;
+ zlatm2_(&z__2, m, n, &i__, &j, kl, ku, &idist, &
+ iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ d_cnjg(&z__1, &z__2);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ } else {
+ i__3 = j - i__ + 1 + i__ * a_dim1;
+ zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, &
+ iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
+, &ipvtng, &iwork[1], sparse);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ }
+ }
+/* L480: */
+ }
+/* L490: */
+ }
+
+ } else if (ipack == 6) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ i__3 = i__ - j + kuu + 1 + j * a_dim1;
+ zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, &iseed[1],
+ &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, &iwork[
+ 1], sparse);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L500: */
+ }
+/* L510: */
+ }
+
+ } else if (ipack == 7) {
+
+ if (isym != 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ i__3 = i__ - j + kuu + 1 + j * a_dim1;
+ zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, &iseed[
+ 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng,
+ &iwork[1], sparse);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ if (i__ < 1) {
+ i__3 = j - i__ + 1 + kuu + (i__ + *n) * a_dim1;
+ a[i__3].r = 0., a[i__3].i = 0.;
+ }
+ if (i__ >= 1 && i__ != j) {
+ if (isym == 0) {
+ i__3 = j - i__ + 1 + kuu + i__ * a_dim1;
+ d_cnjg(&z__1, &a[i__ - j + kuu + 1 + j *
+ a_dim1]);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+ } else {
+ i__3 = j - i__ + 1 + kuu + i__ * a_dim1;
+ i__4 = i__ - j + kuu + 1 + j * a_dim1;
+ a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
+ }
+ }
+/* L520: */
+ }
+/* L530: */
+ }
+ } else if (isym == 1) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j + kll;
+ for (i__ = j - kuu; i__ <= i__2; ++i__) {
+ i__3 = i__ - j + kuu + 1 + j * a_dim1;
+ zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, &iseed[
+ 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng,
+ &iwork[1], sparse);
+ a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L540: */
+ }
+/* L550: */
+ }
+ }
+
+ }
+
+ }
+
+/* 5) Scaling the norm */
+
+ if (ipack == 0) {
+ onorm = zlange_("M", m, n, &a[a_offset], lda, tempa);
+ } else if (ipack == 1) {
+ onorm = zlansy_("M", "U", n, &a[a_offset], lda, tempa);
+ } else if (ipack == 2) {
+ onorm = zlansy_("M", "L", n, &a[a_offset], lda, tempa);
+ } else if (ipack == 3) {
+ onorm = zlansp_("M", "U", n, &a[a_offset], tempa);
+ } else if (ipack == 4) {
+ onorm = zlansp_("M", "L", n, &a[a_offset], tempa);
+ } else if (ipack == 5) {
+ onorm = zlansb_("M", "L", n, &kll, &a[a_offset], lda, tempa);
+ } else if (ipack == 6) {
+ onorm = zlansb_("M", "U", n, &kuu, &a[a_offset], lda, tempa);
+ } else if (ipack == 7) {
+ onorm = zlangb_("M", n, &kll, &kuu, &a[a_offset], lda, tempa);
+ }
+
+ if (*anorm >= 0.) {
+
+ if (*anorm > 0. && onorm == 0.) {
+
+/* Desired scaling impossible */
+
+ *info = 5;
+ return 0;
+
+ } else if (*anorm > 1. && onorm < 1. || *anorm < 1. && onorm > 1.) {
+
+/* Scale carefully to avoid over / underflow */
+
+ if (ipack <= 2) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ d__1 = 1. / onorm;
+ zdscal_(m, &d__1, &a[j * a_dim1 + 1], &c__1);
+ zdscal_(m, anorm, &a[j * a_dim1 + 1], &c__1);
+/* L560: */
+ }
+
+ } else if (ipack == 3 || ipack == 4) {
+
+ i__1 = *n * (*n + 1) / 2;
+ d__1 = 1. / onorm;
+ zdscal_(&i__1, &d__1, &a[a_offset], &c__1);
+ i__1 = *n * (*n + 1) / 2;
+ zdscal_(&i__1, anorm, &a[a_offset], &c__1);
+
+ } else if (ipack >= 5) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = kll + kuu + 1;
+ d__1 = 1. / onorm;
+ zdscal_(&i__2, &d__1, &a[j * a_dim1 + 1], &c__1);
+ i__2 = kll + kuu + 1;
+ zdscal_(&i__2, anorm, &a[j * a_dim1 + 1], &c__1);
+/* L570: */
+ }
+
+ }
+
+ } else {
+
+/* Scale straightforwardly */
+
+ if (ipack <= 2) {
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ d__1 = *anorm / onorm;
+ zdscal_(m, &d__1, &a[j * a_dim1 + 1], &c__1);
+/* L580: */
+ }
+
+ } else if (ipack == 3 || ipack == 4) {
+
+ i__1 = *n * (*n + 1) / 2;
+ d__1 = *anorm / onorm;
+ zdscal_(&i__1, &d__1, &a[a_offset], &c__1);
+
+ } else if (ipack >= 5) {
+
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = kll + kuu + 1;
+ d__1 = *anorm / onorm;
+ zdscal_(&i__2, &d__1, &a[j * a_dim1 + 1], &c__1);
+/* L590: */
+ }
+ }
+
+ }
+
+ }
+
+/* End of ZLATMR */
+
+ return 0;
+} /* zlatmr_ */
diff --git a/TESTING/MATGEN/zlatms.c b/TESTING/MATGEN/zlatms.c
new file mode 100644
index 0000000..8db2f50
--- /dev/null
+++ b/TESTING/MATGEN/zlatms.c
@@ -0,0 +1,1632 @@
+/* zlatms.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static integer c__1 = 1;
+static integer c__5 = 5;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int zlatms_(integer *m, integer *n, char *dist, integer *
+ iseed, char *sym, doublereal *d__, integer *mode, doublereal *cond,
+ doublereal *dmax__, integer *kl, integer *ku, char *pack,
+ doublecomplex *a, integer *lda, doublecomplex *work, integer *info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1, d__2, d__3;
+ doublecomplex z__1, z__2, z__3;
+ logical L__1;
+
+ /* Builtin functions */
+ double cos(doublereal), sin(doublereal);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ doublecomplex c__;
+ integer i__, j, k;
+ doublecomplex s;
+ integer ic, jc, nc, il;
+ doublecomplex ct;
+ integer ir, jr, mr;
+ doublecomplex st;
+ integer ir1, ir2, jch, llb, jkl, jku, uub, ilda, icol;
+ doublereal temp;
+ integer irow, isym;
+ logical zsym;
+ doublereal alpha, angle;
+ integer ipack;
+ doublereal realc;
+ integer ioffg;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ integer iinfo;
+ doublecomplex ctemp;
+ integer idist, mnmin, iskew;
+ doublecomplex extra, dummy;
+ extern /* Subroutine */ int dlatm1_(integer *, doublereal *, integer *,
+ integer *, integer *, doublereal *, integer *, integer *);
+ integer iendch, ipackg, minlda;
+ extern doublereal dlarnd_(integer *, integer *);
+ extern /* Subroutine */ int zlagge_(integer *, integer *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *), zlaghe_(integer *, integer *,
+ doublereal *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *), xerbla_(char *, integer *);
+ logical iltemp, givens;
+ integer ioffst, irsign;
+ extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
+ integer *);
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlartg_(doublecomplex *, doublecomplex *, doublereal *,
+ doublecomplex *, doublecomplex *);
+ logical ilextr;
+ extern /* Subroutine */ int zlagsy_(integer *, integer *, doublereal *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *)
+ ;
+ logical topdwn;
+ integer isympk;
+ extern /* Subroutine */ int zlarot_(logical *, logical *, logical *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/* November 2006 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLATMS generates random matrices with specified singular values */
+/* (or hermitian with specified eigenvalues) */
+/* for testing LAPACK programs. */
+
+/* ZLATMS operates by applying the following sequence of */
+/* operations: */
+
+/* Set the diagonal to D, where D may be input or */
+/* computed according to MODE, COND, DMAX, and SYM */
+/* as described below. */
+
+/* Generate a matrix with the appropriate band structure, by one */
+/* of two methods: */
+
+/* Method A: */
+/* Generate a dense M x N matrix by multiplying D on the left */
+/* and the right by random unitary matrices, then: */
+
+/* Reduce the bandwidth according to KL and KU, using */
+/* Householder transformations. */
+
+/* Method B: */
+/* Convert the bandwidth-0 (i.e., diagonal) matrix to a */
+/* bandwidth-1 matrix using Givens rotations, "chasing" */
+/* out-of-band elements back, much as in QR; then convert */
+/* the bandwidth-1 to a bandwidth-2 matrix, etc. Note */
+/* that for reasonably small bandwidths (relative to M and */
+/* N) this requires less storage, as a dense matrix is not */
+/* generated. Also, for hermitian or symmetric matrices, */
+/* only one triangle is generated. */
+
+/* Method A is chosen if the bandwidth is a large fraction of the */
+/* order of the matrix, and LDA is at least M (so a dense */
+/* matrix can be stored.) Method B is chosen if the bandwidth */
+/* is small (< 1/2 N for hermitian or symmetric, < .3 N+M for */
+/* non-symmetric), or LDA is less than M and not less than the */
+/* bandwidth. */
+
+/* Pack the matrix if desired. Options specified by PACK are: */
+/* no packing */
+/* zero out upper half (if hermitian) */
+/* zero out lower half (if hermitian) */
+/* store the upper half columnwise (if hermitian or upper */
+/* triangular) */
+/* store the lower half columnwise (if hermitian or lower */
+/* triangular) */
+/* store the lower triangle in banded format (if hermitian or */
+/* lower triangular) */
+/* store the upper triangle in banded format (if hermitian or */
+/* upper triangular) */
+/* store the entire matrix in banded format */
+/* If Method B is chosen, and band format is specified, then the */
+/* matrix will be generated in the band format, so no repacking */
+/* will be necessary. */
+
+/* Arguments */
+/* ========= */
+
+/* M - INTEGER */
+/* The number of rows of A. Not modified. */
+
+/* N - INTEGER */
+/* The number of columns of A. N must equal M if the matrix */
+/* is symmetric or hermitian (i.e., if SYM is not 'N') */
+/* Not modified. */
+
+/* DIST - CHARACTER*1 */
+/* On entry, DIST specifies the type of distribution to be used */
+/* to generate the random eigen-/singular values. */
+/* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */
+/* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */
+/* 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension ( 4 ) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. They should lie between 0 and 4095 inclusive, */
+/* and ISEED(4) should be odd. The random number generator */
+/* uses a linear congruential sequence limited to small */
+/* integers, and so should produce machine independent */
+/* random numbers. The values of ISEED are changed on */
+/* exit, and can be used in the next call to ZLATMS */
+/* to continue the same random number sequence. */
+/* Changed on exit. */
+
+/* SYM - CHARACTER*1 */
+/* If SYM='H', the generated matrix is hermitian, with */
+/* eigenvalues specified by D, COND, MODE, and DMAX; they */
+/* may be positive, negative, or zero. */
+/* If SYM='P', the generated matrix is hermitian, with */
+/* eigenvalues (= singular values) specified by D, COND, */
+/* MODE, and DMAX; they will not be negative. */
+/* If SYM='N', the generated matrix is nonsymmetric, with */
+/* singular values specified by D, COND, MODE, and DMAX; */
+/* they will not be negative. */
+/* If SYM='S', the generated matrix is (complex) symmetric, */
+/* with singular values specified by D, COND, MODE, and */
+/* DMAX; they will not be negative. */
+/* Not modified. */
+
+/* D - DOUBLE PRECISION array, dimension ( MIN( M, N ) ) */
+/* This array is used to specify the singular values or */
+/* eigenvalues of A (see SYM, above.) If MODE=0, then D is */
+/* assumed to contain the singular/eigenvalues, otherwise */
+/* they will be computed according to MODE, COND, and DMAX, */
+/* and placed in D. */
+/* Modified if MODE is nonzero. */
+
+/* MODE - INTEGER */
+/* On entry this describes how the singular/eigenvalues are to */
+/* be specified: */
+/* MODE = 0 means use D as input */
+/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
+/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
+/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
+/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* MODE = 5 sets D to random numbers in the range */
+/* ( 1/COND , 1 ) such that their logarithms */
+/* are uniformly distributed. */
+/* MODE = 6 set D to random numbers from same distribution */
+/* as the rest of the matrix. */
+/* MODE < 0 has the same meaning as ABS(MODE), except that */
+/* the order of the elements of D is reversed. */
+/* Thus if MODE is positive, D has entries ranging from */
+/* 1 to 1/COND, if negative, from 1/COND to 1, */
+/* If SYM='H', and MODE is neither 0, 6, nor -6, then */
+/* the elements of D will also be multiplied by a random */
+/* sign (i.e., +1 or -1.) */
+/* Not modified. */
+
+/* COND - DOUBLE PRECISION */
+/* On entry, this is used as described under MODE above. */
+/* If used, it must be >= 1. Not modified. */
+
+/* DMAX - DOUBLE PRECISION */
+/* If MODE is neither -6, 0 nor 6, the contents of D, as */
+/* computed according to MODE and COND, will be scaled by */
+/* DMAX / max(abs(D(i))); thus, the maximum absolute eigen- or */
+/* singular value (which is to say the norm) will be abs(DMAX). */
+/* Note that DMAX need not be positive: if DMAX is negative */
+/* (or zero), D will be scaled by a negative number (or zero). */
+/* Not modified. */
+
+/* KL - INTEGER */
+/* This specifies the lower bandwidth of the matrix. For */
+/* example, KL=0 implies upper triangular, KL=1 implies upper */
+/* Hessenberg, and KL being at least M-1 means that the matrix */
+/* has full lower bandwidth. KL must equal KU if the matrix */
+/* is symmetric or hermitian. */
+/* Not modified. */
+
+/* KU - INTEGER */
+/* This specifies the upper bandwidth of the matrix. For */
+/* example, KU=0 implies lower triangular, KU=1 implies lower */
+/* Hessenberg, and KU being at least N-1 means that the matrix */
+/* has full upper bandwidth. KL must equal KU if the matrix */
+/* is symmetric or hermitian. */
+/* Not modified. */
+
+/* PACK - CHARACTER*1 */
+/* This specifies packing of matrix as follows: */
+/* 'N' => no packing */
+/* 'U' => zero out all subdiagonal entries (if symmetric */
+/* or hermitian) */
+/* 'L' => zero out all superdiagonal entries (if symmetric */
+/* or hermitian) */
+/* 'C' => store the upper triangle columnwise (only if the */
+/* matrix is symmetric, hermitian, or upper triangular) */
+/* 'R' => store the lower triangle columnwise (only if the */
+/* matrix is symmetric, hermitian, or lower triangular) */
+/* 'B' => store the lower triangle in band storage scheme */
+/* (only if the matrix is symmetric, hermitian, or */
+/* lower triangular) */
+/* 'Q' => store the upper triangle in band storage scheme */
+/* (only if the matrix is symmetric, hermitian, or */
+/* upper triangular) */
+/* 'Z' => store the entire matrix in band storage scheme */
+/* (pivoting can be provided for by using this */
+/* option to store A in the trailing rows of */
+/* the allocated storage) */
+
+/* Using these options, the various LAPACK packed and banded */
+/* storage schemes can be obtained: */
+/* GB - use 'Z' */
+/* PB, SB, HB, or TB - use 'B' or 'Q' */
+/* PP, SP, HB, or TP - use 'C' or 'R' */
+
+/* If two calls to ZLATMS differ only in the PACK parameter, */
+/* they will generate mathematically equivalent matrices. */
+/* Not modified. */
+
+/* A - COMPLEX*16 array, dimension ( LDA, N ) */
+/* On exit A is the desired test matrix. A is first generated */
+/* in full (unpacked) form, and then packed, if so specified */
+/* by PACK. Thus, the first M elements of the first N */
+/* columns will always be modified. If PACK specifies a */
+/* packed or banded storage scheme, all LDA elements of the */
+/* first N columns will be modified; the elements of the */
+/* array which do not correspond to elements of the generated */
+/* matrix are set to zero. */
+/* Modified. */
+
+/* LDA - INTEGER */
+/* LDA specifies the first dimension of A as declared in the */
+/* calling program. If PACK='N', 'U', 'L', 'C', or 'R', then */
+/* LDA must be at least M. If PACK='B' or 'Q', then LDA must */
+/* be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)). */
+/* If PACK='Z', LDA must be large enough to hold the packed */
+/* array: MIN( KU, N-1) + MIN( KL, M-1) + 1. */
+/* Not modified. */
+
+/* WORK - COMPLEX*16 array, dimension ( 3*MAX( N, M ) ) */
+/* Workspace. */
+/* Modified. */
+
+/* INFO - INTEGER */
+/* Error code. On exit, INFO will be set to one of the */
+/* following values: */
+/* 0 => normal return */
+/* -1 => M negative or unequal to N and SYM='S', 'H', or 'P' */
+/* -2 => N negative */
+/* -3 => DIST illegal string */
+/* -5 => SYM illegal string */
+/* -7 => MODE not in range -6 to 6 */
+/* -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */
+/* -10 => KL negative */
+/* -11 => KU negative, or SYM is not 'N' and KU is not equal to */
+/* KL */
+/* -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N'; */
+/* or PACK='C' or 'Q' and SYM='N' and KL is not zero; */
+/* or PACK='R' or 'B' and SYM='N' and KU is not zero; */
+/* or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not */
+/* N. */
+/* -14 => LDA is less than M, or PACK='Z' and LDA is less than */
+/* MIN(KU,N-1) + MIN(KL,M-1) + 1. */
+/* 1 => Error return from DLATM1 */
+/* 2 => Cannot scale to DMAX (max. sing. value is 0) */
+/* 3 => Error return from ZLAGGE, CLAGHE or CLAGSY */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Decode and Test the input parameters. */
+/* Initialize flags & seed. */
+
+ /* Parameter adjustments */
+ --iseed;
+ --d__;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Decode DIST */
+
+ if (lsame_(dist, "U")) {
+ idist = 1;
+ } else if (lsame_(dist, "S")) {
+ idist = 2;
+ } else if (lsame_(dist, "N")) {
+ idist = 3;
+ } else {
+ idist = -1;
+ }
+
+/* Decode SYM */
+
+ if (lsame_(sym, "N")) {
+ isym = 1;
+ irsign = 0;
+ zsym = FALSE_;
+ } else if (lsame_(sym, "P")) {
+ isym = 2;
+ irsign = 0;
+ zsym = FALSE_;
+ } else if (lsame_(sym, "S")) {
+ isym = 2;
+ irsign = 0;
+ zsym = TRUE_;
+ } else if (lsame_(sym, "H")) {
+ isym = 2;
+ irsign = 1;
+ zsym = FALSE_;
+ } else {
+ isym = -1;
+ }
+
+/* Decode PACK */
+
+ isympk = 0;
+ if (lsame_(pack, "N")) {
+ ipack = 0;
+ } else if (lsame_(pack, "U")) {
+ ipack = 1;
+ isympk = 1;
+ } else if (lsame_(pack, "L")) {
+ ipack = 2;
+ isympk = 1;
+ } else if (lsame_(pack, "C")) {
+ ipack = 3;
+ isympk = 2;
+ } else if (lsame_(pack, "R")) {
+ ipack = 4;
+ isympk = 3;
+ } else if (lsame_(pack, "B")) {
+ ipack = 5;
+ isympk = 3;
+ } else if (lsame_(pack, "Q")) {
+ ipack = 6;
+ isympk = 2;
+ } else if (lsame_(pack, "Z")) {
+ ipack = 7;
+ } else {
+ ipack = -1;
+ }
+
+/* Set certain internal parameters */
+
+ mnmin = min(*m,*n);
+/* Computing MIN */
+ i__1 = *kl, i__2 = *m - 1;
+ llb = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *ku, i__2 = *n - 1;
+ uub = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *m, i__2 = *n + llb;
+ mr = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *n, i__2 = *m + uub;
+ nc = min(i__1,i__2);
+
+ if (ipack == 5 || ipack == 6) {
+ minlda = uub + 1;
+ } else if (ipack == 7) {
+ minlda = llb + uub + 1;
+ } else {
+ minlda = *m;
+ }
+
+/* Use Givens rotation method if bandwidth small enough, */
+/* or if LDA is too small to store the matrix unpacked. */
+
+ givens = FALSE_;
+ if (isym == 1) {
+/* Computing MAX */
+ i__1 = 1, i__2 = mr + nc;
+ if ((doublereal) (llb + uub) < (doublereal) max(i__1,i__2) * .3) {
+ givens = TRUE_;
+ }
+ } else {
+ if (llb << 1 < *m) {
+ givens = TRUE_;
+ }
+ }
+ if (*lda < *m && *lda >= minlda) {
+ givens = TRUE_;
+ }
+
+/* Set INFO if an error */
+
+ if (*m < 0) {
+ *info = -1;
+ } else if (*m != *n && isym != 1) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (idist == -1) {
+ *info = -3;
+ } else if (isym == -1) {
+ *info = -5;
+ } else if (abs(*mode) > 6) {
+ *info = -7;
+ } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.) {
+ *info = -8;
+ } else if (*kl < 0) {
+ *info = -10;
+ } else if (*ku < 0 || isym != 1 && *kl != *ku) {
+ *info = -11;
+ } else if (ipack == -1 || isympk == 1 && isym == 1 || isympk == 2 && isym
+ == 1 && *kl > 0 || isympk == 3 && isym == 1 && *ku > 0 || isympk
+ != 0 && *m != *n) {
+ *info = -12;
+ } else if (*lda < max(1,minlda)) {
+ *info = -14;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLATMS", &i__1);
+ return 0;
+ }
+
+/* Initialize random number generator */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
+/* L10: */
+ }
+
+ if (iseed[4] % 2 != 1) {
+ ++iseed[4];
+ }
+
+/* 2) Set up D if indicated. */
+
+/* Compute D according to COND and MODE */
+
+ dlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, &iinfo);
+ if (iinfo != 0) {
+ *info = 1;
+ return 0;
+ }
+
+/* Choose Top-Down if D is (apparently) increasing, */
+/* Bottom-Up if D is (apparently) decreasing. */
+
+ if (abs(d__[1]) <= (d__1 = d__[mnmin], abs(d__1))) {
+ topdwn = TRUE_;
+ } else {
+ topdwn = FALSE_;
+ }
+
+ if (*mode != 0 && abs(*mode) != 6) {
+
+/* Scale by DMAX */
+
+ temp = abs(d__[1]);
+ i__1 = mnmin;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = temp, d__3 = (d__1 = d__[i__], abs(d__1));
+ temp = max(d__2,d__3);
+/* L20: */
+ }
+
+ if (temp > 0.) {
+ alpha = *dmax__ / temp;
+ } else {
+ *info = 2;
+ return 0;
+ }
+
+ dscal_(&mnmin, &alpha, &d__[1], &c__1);
+
+ }
+
+ zlaset_("Full", lda, n, &c_b1, &c_b1, &a[a_offset], lda);
+
+/* 3) Generate Banded Matrix using Givens rotations. */
+/* Also the special case of UUB=LLB=0 */
+
+/* Compute Addressing constants to cover all */
+/* storage formats. Whether GE, HE, SY, GB, HB, or SB, */
+/* upper or lower triangle or both, */
+/* the (i,j)-th element is in */
+/* A( i - ISKEW*j + IOFFST, j ) */
+
+ if (ipack > 4) {
+ ilda = *lda - 1;
+ iskew = 1;
+ if (ipack > 5) {
+ ioffst = uub + 1;
+ } else {
+ ioffst = 1;
+ }
+ } else {
+ ilda = *lda;
+ iskew = 0;
+ ioffst = 0;
+ }
+
+/* IPACKG is the format that the matrix is generated in. If this is */
+/* different from IPACK, then the matrix must be repacked at the */
+/* end. It also signals how to compute the norm, for scaling. */
+
+ ipackg = 0;
+
+/* Diagonal Matrix -- We are done, unless it */
+/* is to be stored HP/SP/PP/TP (PACK='R' or 'C') */
+
+ if (llb == 0 && uub == 0) {
+ i__1 = mnmin;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (1 - iskew) * j + ioffst + j * a_dim1;
+ i__3 = j;
+ z__1.r = d__[i__3], z__1.i = 0.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L30: */
+ }
+
+ if (ipack <= 2 || ipack >= 5) {
+ ipackg = ipack;
+ }
+
+ } else if (givens) {
+
+/* Check whether to use Givens rotations, */
+/* Householder transformations, or nothing. */
+
+ if (isym == 1) {
+
+/* Non-symmetric -- A = U D V */
+
+ if (ipack > 4) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+
+ i__1 = mnmin;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (1 - iskew) * j + ioffst + j * a_dim1;
+ i__3 = j;
+ z__1.r = d__[i__3], z__1.i = 0.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L40: */
+ }
+
+ if (topdwn) {
+ jkl = 0;
+ i__1 = uub;
+ for (jku = 1; jku <= i__1; ++jku) {
+
+/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */
+
+/* Last row actually rotated is M */
+/* Last column actually rotated is MIN( M+JKU, N ) */
+
+/* Computing MIN */
+ i__3 = *m + jku;
+ i__2 = min(i__3,*n) + jkl - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ extra.r = 0., extra.i = 0.;
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ d__1 = cos(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ d__1 = sin(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ s.r = z__1.r, s.i = z__1.i;
+/* Computing MAX */
+ i__3 = 1, i__4 = jr - jkl;
+ icol = max(i__3,i__4);
+ if (jr < *m) {
+/* Computing MIN */
+ i__3 = *n, i__4 = jr + jku;
+ il = min(i__3,i__4) + 1 - icol;
+ L__1 = jr > jkl;
+ zlarot_(&c_true, &L__1, &c_false, &il, &c__, &s, &
+ a[jr - iskew * icol + ioffst + icol *
+ a_dim1], &ilda, &extra, &dummy);
+ }
+
+/* Chase "EXTRA" back up */
+
+ ir = jr;
+ ic = icol;
+ i__3 = -jkl - jku;
+ for (jch = jr - jkl; i__3 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__3) {
+ if (ir < *m) {
+ zlartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst
+ + (ic + 1) * a_dim1], &extra, &realc,
+ &s, &dummy);
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ dummy.r = z__1.r, dummy.i = z__1.i;
+ z__2.r = realc * dummy.r, z__2.i = realc *
+ dummy.i;
+ d_cnjg(&z__1, &z__2);
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__3.r = -s.r, z__3.i = -s.i;
+ z__2.r = z__3.r * dummy.r - z__3.i * dummy.i,
+ z__2.i = z__3.r * dummy.i + z__3.i *
+ dummy.r;
+ d_cnjg(&z__1, &z__2);
+ s.r = z__1.r, s.i = z__1.i;
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jku;
+ irow = max(i__4,i__5);
+ il = ir + 2 - irow;
+ ctemp.r = 0., ctemp.i = 0.;
+ iltemp = jch > jku;
+ zlarot_(&c_false, &iltemp, &c_true, &il, &c__, &s,
+ &a[irow - iskew * ic + ioffst + ic *
+ a_dim1], &ilda, &ctemp, &extra);
+ if (iltemp) {
+ zlartg_(&a[irow + 1 - iskew * (ic + 1) +
+ ioffst + (ic + 1) * a_dim1], &ctemp, &
+ realc, &s, &dummy);
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ dummy.r = z__1.r, dummy.i = z__1.i;
+ z__2.r = realc * dummy.r, z__2.i = realc *
+ dummy.i;
+ d_cnjg(&z__1, &z__2);
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__3.r = -s.r, z__3.i = -s.i;
+ z__2.r = z__3.r * dummy.r - z__3.i * dummy.i,
+ z__2.i = z__3.r * dummy.i + z__3.i *
+ dummy.r;
+ d_cnjg(&z__1, &z__2);
+ s.r = z__1.r, s.i = z__1.i;
+
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jku - jkl;
+ icol = max(i__4,i__5);
+ il = ic + 2 - icol;
+ extra.r = 0., extra.i = 0.;
+ L__1 = jch > jku + jkl;
+ zlarot_(&c_true, &L__1, &c_true, &il, &c__, &
+ s, &a[irow - iskew * icol + ioffst +
+ icol * a_dim1], &ilda, &extra, &ctemp)
+ ;
+ ic = icol;
+ ir = irow;
+ }
+/* L50: */
+ }
+/* L60: */
+ }
+/* L70: */
+ }
+
+ jku = uub;
+ i__1 = llb;
+ for (jkl = 1; jkl <= i__1; ++jkl) {
+
+/* Transform from bandwidth JKL-1, JKU to JKL, JKU */
+
+/* Computing MIN */
+ i__3 = *n + jkl;
+ i__2 = min(i__3,*m) + jku - 1;
+ for (jc = 1; jc <= i__2; ++jc) {
+ extra.r = 0., extra.i = 0.;
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ d__1 = cos(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ d__1 = sin(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ s.r = z__1.r, s.i = z__1.i;
+/* Computing MAX */
+ i__3 = 1, i__4 = jc - jku;
+ irow = max(i__3,i__4);
+ if (jc < *n) {
+/* Computing MIN */
+ i__3 = *m, i__4 = jc + jkl;
+ il = min(i__3,i__4) + 1 - irow;
+ L__1 = jc > jku;
+ zlarot_(&c_false, &L__1, &c_false, &il, &c__, &s,
+ &a[irow - iskew * jc + ioffst + jc *
+ a_dim1], &ilda, &extra, &dummy);
+ }
+
+/* Chase "EXTRA" back up */
+
+ ic = jc;
+ ir = irow;
+ i__3 = -jkl - jku;
+ for (jch = jc - jku; i__3 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__3) {
+ if (ic < *n) {
+ zlartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst
+ + (ic + 1) * a_dim1], &extra, &realc,
+ &s, &dummy);
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ dummy.r = z__1.r, dummy.i = z__1.i;
+ z__2.r = realc * dummy.r, z__2.i = realc *
+ dummy.i;
+ d_cnjg(&z__1, &z__2);
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__3.r = -s.r, z__3.i = -s.i;
+ z__2.r = z__3.r * dummy.r - z__3.i * dummy.i,
+ z__2.i = z__3.r * dummy.i + z__3.i *
+ dummy.r;
+ d_cnjg(&z__1, &z__2);
+ s.r = z__1.r, s.i = z__1.i;
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jkl;
+ icol = max(i__4,i__5);
+ il = ic + 2 - icol;
+ ctemp.r = 0., ctemp.i = 0.;
+ iltemp = jch > jkl;
+ zlarot_(&c_true, &iltemp, &c_true, &il, &c__, &s,
+ &a[ir - iskew * icol + ioffst + icol *
+ a_dim1], &ilda, &ctemp, &extra);
+ if (iltemp) {
+ zlartg_(&a[ir + 1 - iskew * (icol + 1) +
+ ioffst + (icol + 1) * a_dim1], &ctemp,
+ &realc, &s, &dummy);
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ dummy.r = z__1.r, dummy.i = z__1.i;
+ z__2.r = realc * dummy.r, z__2.i = realc *
+ dummy.i;
+ d_cnjg(&z__1, &z__2);
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__3.r = -s.r, z__3.i = -s.i;
+ z__2.r = z__3.r * dummy.r - z__3.i * dummy.i,
+ z__2.i = z__3.r * dummy.i + z__3.i *
+ dummy.r;
+ d_cnjg(&z__1, &z__2);
+ s.r = z__1.r, s.i = z__1.i;
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jkl - jku;
+ irow = max(i__4,i__5);
+ il = ir + 2 - irow;
+ extra.r = 0., extra.i = 0.;
+ L__1 = jch > jkl + jku;
+ zlarot_(&c_false, &L__1, &c_true, &il, &c__, &
+ s, &a[irow - iskew * icol + ioffst +
+ icol * a_dim1], &ilda, &extra, &ctemp)
+ ;
+ ic = icol;
+ ir = irow;
+ }
+/* L80: */
+ }
+/* L90: */
+ }
+/* L100: */
+ }
+
+ } else {
+
+/* Bottom-Up -- Start at the bottom right. */
+
+ jkl = 0;
+ i__1 = uub;
+ for (jku = 1; jku <= i__1; ++jku) {
+
+/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */
+
+/* First row actually rotated is M */
+/* First column actually rotated is MIN( M+JKU, N ) */
+
+/* Computing MIN */
+ i__2 = *m, i__3 = *n + jkl;
+ iendch = min(i__2,i__3) - 1;
+/* Computing MIN */
+ i__2 = *m + jku;
+ i__3 = 1 - jkl;
+ for (jc = min(i__2,*n) - 1; jc >= i__3; --jc) {
+ extra.r = 0., extra.i = 0.;
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ d__1 = cos(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ d__1 = sin(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ s.r = z__1.r, s.i = z__1.i;
+/* Computing MAX */
+ i__2 = 1, i__4 = jc - jku + 1;
+ irow = max(i__2,i__4);
+ if (jc > 0) {
+/* Computing MIN */
+ i__2 = *m, i__4 = jc + jkl + 1;
+ il = min(i__2,i__4) + 1 - irow;
+ L__1 = jc + jkl < *m;
+ zlarot_(&c_false, &c_false, &L__1, &il, &c__, &s,
+ &a[irow - iskew * jc + ioffst + jc *
+ a_dim1], &ilda, &dummy, &extra);
+ }
+
+/* Chase "EXTRA" back down */
+
+ ic = jc;
+ i__2 = iendch;
+ i__4 = jkl + jku;
+ for (jch = jc + jkl; i__4 < 0 ? jch >= i__2 : jch <=
+ i__2; jch += i__4) {
+ ilextr = ic > 0;
+ if (ilextr) {
+ zlartg_(&a[jch - iskew * ic + ioffst + ic *
+ a_dim1], &extra, &realc, &s, &dummy);
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ dummy.r = z__1.r, dummy.i = z__1.i;
+ z__1.r = realc * dummy.r, z__1.i = realc *
+ dummy.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__1.r = s.r * dummy.r - s.i * dummy.i,
+ z__1.i = s.r * dummy.i + s.i *
+ dummy.r;
+ s.r = z__1.r, s.i = z__1.i;
+ }
+ ic = max(1,ic);
+/* Computing MIN */
+ i__5 = *n - 1, i__6 = jch + jku;
+ icol = min(i__5,i__6);
+ iltemp = jch + jku < *n;
+ ctemp.r = 0., ctemp.i = 0.;
+ i__5 = icol + 2 - ic;
+ zlarot_(&c_true, &ilextr, &iltemp, &i__5, &c__, &
+ s, &a[jch - iskew * ic + ioffst + ic *
+ a_dim1], &ilda, &extra, &ctemp);
+ if (iltemp) {
+ zlartg_(&a[jch - iskew * icol + ioffst + icol
+ * a_dim1], &ctemp, &realc, &s, &dummy)
+ ;
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ dummy.r = z__1.r, dummy.i = z__1.i;
+ z__1.r = realc * dummy.r, z__1.i = realc *
+ dummy.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__1.r = s.r * dummy.r - s.i * dummy.i,
+ z__1.i = s.r * dummy.i + s.i *
+ dummy.r;
+ s.r = z__1.r, s.i = z__1.i;
+/* Computing MIN */
+ i__5 = iendch, i__6 = jch + jkl + jku;
+ il = min(i__5,i__6) + 2 - jch;
+ extra.r = 0., extra.i = 0.;
+ L__1 = jch + jkl + jku <= iendch;
+ zlarot_(&c_false, &c_true, &L__1, &il, &c__, &
+ s, &a[jch - iskew * icol + ioffst +
+ icol * a_dim1], &ilda, &ctemp, &extra)
+ ;
+ ic = icol;
+ }
+/* L110: */
+ }
+/* L120: */
+ }
+/* L130: */
+ }
+
+ jku = uub;
+ i__1 = llb;
+ for (jkl = 1; jkl <= i__1; ++jkl) {
+
+/* Transform from bandwidth JKL-1, JKU to JKL, JKU */
+
+/* First row actually rotated is MIN( N+JKL, M ) */
+/* First column actually rotated is N */
+
+/* Computing MIN */
+ i__3 = *n, i__4 = *m + jku;
+ iendch = min(i__3,i__4) - 1;
+/* Computing MIN */
+ i__3 = *n + jkl;
+ i__4 = 1 - jku;
+ for (jr = min(i__3,*m) - 1; jr >= i__4; --jr) {
+ extra.r = 0., extra.i = 0.;
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ d__1 = cos(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ d__1 = sin(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ s.r = z__1.r, s.i = z__1.i;
+/* Computing MAX */
+ i__3 = 1, i__2 = jr - jkl + 1;
+ icol = max(i__3,i__2);
+ if (jr > 0) {
+/* Computing MIN */
+ i__3 = *n, i__2 = jr + jku + 1;
+ il = min(i__3,i__2) + 1 - icol;
+ L__1 = jr + jku < *n;
+ zlarot_(&c_true, &c_false, &L__1, &il, &c__, &s, &
+ a[jr - iskew * icol + ioffst + icol *
+ a_dim1], &ilda, &dummy, &extra);
+ }
+
+/* Chase "EXTRA" back down */
+
+ ir = jr;
+ i__3 = iendch;
+ i__2 = jkl + jku;
+ for (jch = jr + jku; i__2 < 0 ? jch >= i__3 : jch <=
+ i__3; jch += i__2) {
+ ilextr = ir > 0;
+ if (ilextr) {
+ zlartg_(&a[ir - iskew * jch + ioffst + jch *
+ a_dim1], &extra, &realc, &s, &dummy);
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ dummy.r = z__1.r, dummy.i = z__1.i;
+ z__1.r = realc * dummy.r, z__1.i = realc *
+ dummy.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__1.r = s.r * dummy.r - s.i * dummy.i,
+ z__1.i = s.r * dummy.i + s.i *
+ dummy.r;
+ s.r = z__1.r, s.i = z__1.i;
+ }
+ ir = max(1,ir);
+/* Computing MIN */
+ i__5 = *m - 1, i__6 = jch + jkl;
+ irow = min(i__5,i__6);
+ iltemp = jch + jkl < *m;
+ ctemp.r = 0., ctemp.i = 0.;
+ i__5 = irow + 2 - ir;
+ zlarot_(&c_false, &ilextr, &iltemp, &i__5, &c__, &
+ s, &a[ir - iskew * jch + ioffst + jch *
+ a_dim1], &ilda, &extra, &ctemp);
+ if (iltemp) {
+ zlartg_(&a[irow - iskew * jch + ioffst + jch *
+ a_dim1], &ctemp, &realc, &s, &dummy);
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ dummy.r = z__1.r, dummy.i = z__1.i;
+ z__1.r = realc * dummy.r, z__1.i = realc *
+ dummy.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__1.r = s.r * dummy.r - s.i * dummy.i,
+ z__1.i = s.r * dummy.i + s.i *
+ dummy.r;
+ s.r = z__1.r, s.i = z__1.i;
+/* Computing MIN */
+ i__5 = iendch, i__6 = jch + jkl + jku;
+ il = min(i__5,i__6) + 2 - jch;
+ extra.r = 0., extra.i = 0.;
+ L__1 = jch + jkl + jku <= iendch;
+ zlarot_(&c_true, &c_true, &L__1, &il, &c__, &
+ s, &a[irow - iskew * jch + ioffst +
+ jch * a_dim1], &ilda, &ctemp, &extra);
+ ir = irow;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+
+ }
+
+ } else {
+
+/* Symmetric -- A = U D U' */
+/* Hermitian -- A = U D U* */
+
+ ipackg = ipack;
+ ioffg = ioffst;
+
+ if (topdwn) {
+
+/* Top-Down -- Generate Upper triangle only */
+
+ if (ipack >= 5) {
+ ipackg = 6;
+ ioffg = uub + 1;
+ } else {
+ ipackg = 1;
+ }
+
+ i__1 = mnmin;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = (1 - iskew) * j + ioffg + j * a_dim1;
+ i__2 = j;
+ z__1.r = d__[i__2], z__1.i = 0.;
+ a[i__4].r = z__1.r, a[i__4].i = z__1.i;
+/* L170: */
+ }
+
+ i__1 = uub;
+ for (k = 1; k <= i__1; ++k) {
+ i__4 = *n - 1;
+ for (jc = 1; jc <= i__4; ++jc) {
+/* Computing MAX */
+ i__2 = 1, i__3 = jc - k;
+ irow = max(i__2,i__3);
+/* Computing MIN */
+ i__2 = jc + 1, i__3 = k + 2;
+ il = min(i__2,i__3);
+ extra.r = 0., extra.i = 0.;
+ i__2 = jc - iskew * (jc + 1) + ioffg + (jc + 1) *
+ a_dim1;
+ ctemp.r = a[i__2].r, ctemp.i = a[i__2].i;
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ d__1 = cos(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ d__1 = sin(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ s.r = z__1.r, s.i = z__1.i;
+ if (zsym) {
+ ct.r = c__.r, ct.i = c__.i;
+ st.r = s.r, st.i = s.i;
+ } else {
+ d_cnjg(&z__1, &ctemp);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ d_cnjg(&z__1, &c__);
+ ct.r = z__1.r, ct.i = z__1.i;
+ d_cnjg(&z__1, &s);
+ st.r = z__1.r, st.i = z__1.i;
+ }
+ L__1 = jc > k;
+ zlarot_(&c_false, &L__1, &c_true, &il, &c__, &s, &a[
+ irow - iskew * jc + ioffg + jc * a_dim1], &
+ ilda, &extra, &ctemp);
+/* Computing MIN */
+ i__3 = k, i__5 = *n - jc;
+ i__2 = min(i__3,i__5) + 1;
+ zlarot_(&c_true, &c_true, &c_false, &i__2, &ct, &st, &
+ a[(1 - iskew) * jc + ioffg + jc * a_dim1], &
+ ilda, &ctemp, &dummy);
+
+/* Chase EXTRA back up the matrix */
+
+ icol = jc;
+ i__2 = -k;
+ for (jch = jc - k; i__2 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__2) {
+ zlartg_(&a[jch + 1 - iskew * (icol + 1) + ioffg +
+ (icol + 1) * a_dim1], &extra, &realc, &s,
+ &dummy);
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ dummy.r = z__1.r, dummy.i = z__1.i;
+ z__2.r = realc * dummy.r, z__2.i = realc *
+ dummy.i;
+ d_cnjg(&z__1, &z__2);
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__3.r = -s.r, z__3.i = -s.i;
+ z__2.r = z__3.r * dummy.r - z__3.i * dummy.i,
+ z__2.i = z__3.r * dummy.i + z__3.i *
+ dummy.r;
+ d_cnjg(&z__1, &z__2);
+ s.r = z__1.r, s.i = z__1.i;
+ i__3 = jch - iskew * (jch + 1) + ioffg + (jch + 1)
+ * a_dim1;
+ ctemp.r = a[i__3].r, ctemp.i = a[i__3].i;
+ if (zsym) {
+ ct.r = c__.r, ct.i = c__.i;
+ st.r = s.r, st.i = s.i;
+ } else {
+ d_cnjg(&z__1, &ctemp);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ d_cnjg(&z__1, &c__);
+ ct.r = z__1.r, ct.i = z__1.i;
+ d_cnjg(&z__1, &s);
+ st.r = z__1.r, st.i = z__1.i;
+ }
+ i__3 = k + 2;
+ zlarot_(&c_true, &c_true, &c_true, &i__3, &c__, &
+ s, &a[(1 - iskew) * jch + ioffg + jch *
+ a_dim1], &ilda, &ctemp, &extra);
+/* Computing MAX */
+ i__3 = 1, i__5 = jch - k;
+ irow = max(i__3,i__5);
+/* Computing MIN */
+ i__3 = jch + 1, i__5 = k + 2;
+ il = min(i__3,i__5);
+ extra.r = 0., extra.i = 0.;
+ L__1 = jch > k;
+ zlarot_(&c_false, &L__1, &c_true, &il, &ct, &st, &
+ a[irow - iskew * jch + ioffg + jch *
+ a_dim1], &ilda, &extra, &ctemp);
+ icol = jch;
+/* L180: */
+ }
+/* L190: */
+ }
+/* L200: */
+ }
+
+/* If we need lower triangle, copy from upper. Note that */
+/* the order of copying is chosen to work for 'q' -> 'b' */
+
+ if (ipack != ipackg && ipack != 3) {
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ irow = ioffst - iskew * jc;
+ if (zsym) {
+/* Computing MIN */
+ i__2 = *n, i__3 = jc + uub;
+ i__4 = min(i__2,i__3);
+ for (jr = jc; jr <= i__4; ++jr) {
+ i__2 = jr + irow + jc * a_dim1;
+ i__3 = jc - iskew * jr + ioffg + jr * a_dim1;
+ a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
+/* L210: */
+ }
+ } else {
+/* Computing MIN */
+ i__2 = *n, i__3 = jc + uub;
+ i__4 = min(i__2,i__3);
+ for (jr = jc; jr <= i__4; ++jr) {
+ i__2 = jr + irow + jc * a_dim1;
+ d_cnjg(&z__1, &a[jc - iskew * jr + ioffg + jr
+ * a_dim1]);
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L220: */
+ }
+ }
+/* L230: */
+ }
+ if (ipack == 5) {
+ i__1 = *n;
+ for (jc = *n - uub + 1; jc <= i__1; ++jc) {
+ i__4 = uub + 1;
+ for (jr = *n + 2 - jc; jr <= i__4; ++jr) {
+ i__2 = jr + jc * a_dim1;
+ a[i__2].r = 0., a[i__2].i = 0.;
+/* L240: */
+ }
+/* L250: */
+ }
+ }
+ if (ipackg == 6) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+ }
+ } else {
+
+/* Bottom-Up -- Generate Lower triangle only */
+
+ if (ipack >= 5) {
+ ipackg = 5;
+ if (ipack == 6) {
+ ioffg = 1;
+ }
+ } else {
+ ipackg = 2;
+ }
+
+ i__1 = mnmin;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = (1 - iskew) * j + ioffg + j * a_dim1;
+ i__2 = j;
+ z__1.r = d__[i__2], z__1.i = 0.;
+ a[i__4].r = z__1.r, a[i__4].i = z__1.i;
+/* L260: */
+ }
+
+ i__1 = uub;
+ for (k = 1; k <= i__1; ++k) {
+ for (jc = *n - 1; jc >= 1; --jc) {
+/* Computing MIN */
+ i__4 = *n + 1 - jc, i__2 = k + 2;
+ il = min(i__4,i__2);
+ extra.r = 0., extra.i = 0.;
+ i__4 = (1 - iskew) * jc + 1 + ioffg + jc * a_dim1;
+ ctemp.r = a[i__4].r, ctemp.i = a[i__4].i;
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ d__1 = cos(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ d__1 = sin(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ s.r = z__1.r, s.i = z__1.i;
+ if (zsym) {
+ ct.r = c__.r, ct.i = c__.i;
+ st.r = s.r, st.i = s.i;
+ } else {
+ d_cnjg(&z__1, &ctemp);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ d_cnjg(&z__1, &c__);
+ ct.r = z__1.r, ct.i = z__1.i;
+ d_cnjg(&z__1, &s);
+ st.r = z__1.r, st.i = z__1.i;
+ }
+ L__1 = *n - jc > k;
+ zlarot_(&c_false, &c_true, &L__1, &il, &c__, &s, &a[(
+ 1 - iskew) * jc + ioffg + jc * a_dim1], &ilda,
+ &ctemp, &extra);
+/* Computing MAX */
+ i__4 = 1, i__2 = jc - k + 1;
+ icol = max(i__4,i__2);
+ i__4 = jc + 2 - icol;
+ zlarot_(&c_true, &c_false, &c_true, &i__4, &ct, &st, &
+ a[jc - iskew * icol + ioffg + icol * a_dim1],
+ &ilda, &dummy, &ctemp);
+
+/* Chase EXTRA back down the matrix */
+
+ icol = jc;
+ i__4 = *n - 1;
+ i__2 = k;
+ for (jch = jc + k; i__2 < 0 ? jch >= i__4 : jch <=
+ i__4; jch += i__2) {
+ zlartg_(&a[jch - iskew * icol + ioffg + icol *
+ a_dim1], &extra, &realc, &s, &dummy);
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ dummy.r = z__1.r, dummy.i = z__1.i;
+ z__1.r = realc * dummy.r, z__1.i = realc *
+ dummy.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__1.r = s.r * dummy.r - s.i * dummy.i, z__1.i =
+ s.r * dummy.i + s.i * dummy.r;
+ s.r = z__1.r, s.i = z__1.i;
+ i__3 = (1 - iskew) * jch + 1 + ioffg + jch *
+ a_dim1;
+ ctemp.r = a[i__3].r, ctemp.i = a[i__3].i;
+ if (zsym) {
+ ct.r = c__.r, ct.i = c__.i;
+ st.r = s.r, st.i = s.i;
+ } else {
+ d_cnjg(&z__1, &ctemp);
+ ctemp.r = z__1.r, ctemp.i = z__1.i;
+ d_cnjg(&z__1, &c__);
+ ct.r = z__1.r, ct.i = z__1.i;
+ d_cnjg(&z__1, &s);
+ st.r = z__1.r, st.i = z__1.i;
+ }
+ i__3 = k + 2;
+ zlarot_(&c_true, &c_true, &c_true, &i__3, &c__, &
+ s, &a[jch - iskew * icol + ioffg + icol *
+ a_dim1], &ilda, &extra, &ctemp);
+/* Computing MIN */
+ i__3 = *n + 1 - jch, i__5 = k + 2;
+ il = min(i__3,i__5);
+ extra.r = 0., extra.i = 0.;
+ L__1 = *n - jch > k;
+ zlarot_(&c_false, &c_true, &L__1, &il, &ct, &st, &
+ a[(1 - iskew) * jch + ioffg + jch *
+ a_dim1], &ilda, &ctemp, &extra);
+ icol = jch;
+/* L270: */
+ }
+/* L280: */
+ }
+/* L290: */
+ }
+
+/* If we need upper triangle, copy from lower. Note that */
+/* the order of copying is chosen to work for 'b' -> 'q' */
+
+ if (ipack != ipackg && ipack != 4) {
+ for (jc = *n; jc >= 1; --jc) {
+ irow = ioffst - iskew * jc;
+ if (zsym) {
+/* Computing MAX */
+ i__2 = 1, i__4 = jc - uub;
+ i__1 = max(i__2,i__4);
+ for (jr = jc; jr >= i__1; --jr) {
+ i__2 = jr + irow + jc * a_dim1;
+ i__4 = jc - iskew * jr + ioffg + jr * a_dim1;
+ a[i__2].r = a[i__4].r, a[i__2].i = a[i__4].i;
+/* L300: */
+ }
+ } else {
+/* Computing MAX */
+ i__2 = 1, i__4 = jc - uub;
+ i__1 = max(i__2,i__4);
+ for (jr = jc; jr >= i__1; --jr) {
+ i__2 = jr + irow + jc * a_dim1;
+ d_cnjg(&z__1, &a[jc - iskew * jr + ioffg + jr
+ * a_dim1]);
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L310: */
+ }
+ }
+/* L320: */
+ }
+ if (ipack == 6) {
+ i__1 = uub;
+ for (jc = 1; jc <= i__1; ++jc) {
+ i__2 = uub + 1 - jc;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__4 = jr + jc * a_dim1;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L330: */
+ }
+/* L340: */
+ }
+ }
+ if (ipackg == 5) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+ }
+ }
+
+/* Ensure that the diagonal is real if Hermitian */
+
+ if (! zsym) {
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ irow = ioffst + (1 - iskew) * jc;
+ i__2 = irow + jc * a_dim1;
+ i__4 = irow + jc * a_dim1;
+ d__1 = a[i__4].r;
+ z__1.r = d__1, z__1.i = 0.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L350: */
+ }
+ }
+
+ }
+
+ } else {
+
+/* 4) Generate Banded Matrix by first */
+/* Rotating by random Unitary matrices, */
+/* then reducing the bandwidth using Householder */
+/* transformations. */
+
+/* Note: we should get here only if LDA .ge. N */
+
+ if (isym == 1) {
+
+/* Non-symmetric -- A = U D V */
+
+ zlagge_(&mr, &nc, &llb, &uub, &d__[1], &a[a_offset], lda, &iseed[
+ 1], &work[1], &iinfo);
+ } else {
+
+/* Symmetric -- A = U D U' or */
+/* Hermitian -- A = U D U* */
+
+ if (zsym) {
+ zlagsy_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[
+ 1], &iinfo);
+ } else {
+ zlaghe_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[
+ 1], &iinfo);
+ }
+ }
+
+ if (iinfo != 0) {
+ *info = 3;
+ return 0;
+ }
+ }
+
+/* 5) Pack the matrix */
+
+ if (ipack != ipackg) {
+ if (ipack == 1) {
+
+/* 'U' -- Upper triangular, not packed */
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L360: */
+ }
+/* L370: */
+ }
+
+ } else if (ipack == 2) {
+
+/* 'L' -- Lower triangular, not packed */
+
+ i__1 = *m;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L380: */
+ }
+/* L390: */
+ }
+
+ } else if (ipack == 3) {
+
+/* 'C' -- Upper triangle packed Columnwise. */
+
+ icol = 1;
+ irow = 0;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ++irow;
+ if (irow > *lda) {
+ irow = 1;
+ ++icol;
+ }
+ i__4 = irow + icol * a_dim1;
+ i__3 = i__ + j * a_dim1;
+ a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i;
+/* L400: */
+ }
+/* L410: */
+ }
+
+ } else if (ipack == 4) {
+
+/* 'R' -- Lower triangle packed Columnwise. */
+
+ icol = 1;
+ irow = 0;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ++irow;
+ if (irow > *lda) {
+ irow = 1;
+ ++icol;
+ }
+ i__4 = irow + icol * a_dim1;
+ i__3 = i__ + j * a_dim1;
+ a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i;
+/* L420: */
+ }
+/* L430: */
+ }
+
+ } else if (ipack >= 5) {
+
+/* 'B' -- The lower triangle is packed as a band matrix. */
+/* 'Q' -- The upper triangle is packed as a band matrix. */
+/* 'Z' -- The whole matrix is packed as a band matrix. */
+
+ if (ipack == 5) {
+ uub = 0;
+ }
+ if (ipack == 6) {
+ llb = 0;
+ }
+
+ i__1 = uub;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = j + llb;
+ for (i__ = min(i__2,*m); i__ >= 1; --i__) {
+ i__2 = i__ - j + uub + 1 + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ a[i__2].r = a[i__4].r, a[i__2].i = a[i__4].i;
+/* L440: */
+ }
+/* L450: */
+ }
+
+ i__1 = *n;
+ for (j = uub + 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = j + llb;
+ i__2 = min(i__4,*m);
+ for (i__ = j - uub; i__ <= i__2; ++i__) {
+ i__4 = i__ - j + uub + 1 + j * a_dim1;
+ i__3 = i__ + j * a_dim1;
+ a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i;
+/* L460: */
+ }
+/* L470: */
+ }
+ }
+
+/* If packed, zero out extraneous elements. */
+
+/* Symmetric/Triangular Packed -- */
+/* zero out everything after A(IROW,ICOL) */
+
+ if (ipack == 3 || ipack == 4) {
+ i__1 = *m;
+ for (jc = icol; jc <= i__1; ++jc) {
+ i__2 = *lda;
+ for (jr = irow + 1; jr <= i__2; ++jr) {
+ i__4 = jr + jc * a_dim1;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L480: */
+ }
+ irow = 0;
+/* L490: */
+ }
+
+ } else if (ipack >= 5) {
+
+/* Packed Band -- */
+/* 1st row is now in A( UUB+2-j, j), zero above it */
+/* m-th row is now in A( M+UUB-j,j), zero below it */
+/* last non-zero diagonal is now in A( UUB+LLB+1,j ), */
+/* zero below it, too. */
+
+ ir1 = uub + llb + 2;
+ ir2 = uub + *m + 2;
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ i__2 = uub + 1 - jc;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__4 = jr + jc * a_dim1;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L500: */
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__3 = ir1, i__5 = ir2 - jc;
+ i__2 = 1, i__4 = min(i__3,i__5);
+ i__6 = *lda;
+ for (jr = max(i__2,i__4); jr <= i__6; ++jr) {
+ i__2 = jr + jc * a_dim1;
+ a[i__2].r = 0., a[i__2].i = 0.;
+/* L510: */
+ }
+/* L520: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZLATMS */
+
+} /* zlatms_ */
diff --git a/TESTING/MATGEN/zlatmt.c b/TESTING/MATGEN/zlatmt.c
new file mode 100644
index 0000000..983eb5b
--- /dev/null
+++ b/TESTING/MATGEN/zlatmt.c
@@ -0,0 +1,1638 @@
+/* zlatmt.f -- translated by f2c (version 20061008).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublecomplex c_b1 = {0.,0.};
+static integer c__1 = 1;
+static integer c__5 = 5;
+static logical c_true = TRUE_;
+static logical c_false = FALSE_;
+
+/* Subroutine */ int zlatmt_(integer *m, integer *n, char *dist, integer *
+ iseed, char *sym, doublereal *d__, integer *mode, doublereal *cond,
+ doublereal *dmax__, integer *rank, integer *kl, integer *ku, char *
+ pack, doublecomplex *a, integer *lda, doublecomplex *work, integer *
+ info)
+{
+ /* System generated locals */
+ integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+ doublereal d__1, d__2, d__3;
+ doublecomplex z__1, z__2, z__3;
+ logical L__1;
+
+ /* Builtin functions */
+ double cos(doublereal), sin(doublereal);
+ void d_cnjg(doublecomplex *, doublecomplex *);
+
+ /* Local variables */
+ doublecomplex c__;
+ integer i__, j, k;
+ doublecomplex s;
+ integer ic, jc, nc, il;
+ doublecomplex ct;
+ integer ir, jr, mr;
+ doublecomplex st;
+ integer ir1, ir2, jch, llb, jkl, jku, uub, ilda, icol;
+ doublereal temp;
+ logical csym;
+ integer irow, isym;
+ doublereal alpha, angle, realc;
+ integer ipack, ioffg;
+ extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
+ integer *);
+ extern logical lsame_(char *, char *);
+ integer iinfo, idist, mnmin;
+ doublecomplex extra;
+ integer iskew;
+ doublecomplex dummy, ztemp;
+ extern /* Subroutine */ int dlatm7_(integer *, doublereal *, integer *,
+ integer *, integer *, doublereal *, integer *, integer *, integer
+ *);
+ integer iendch, ipackg, minlda;
+ extern doublereal dlarnd_(integer *, integer *);
+ extern /* Subroutine */ int zlagge_(integer *, integer *, integer *,
+ integer *, doublereal *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *), zlaghe_(integer *, integer *,
+ doublereal *, doublecomplex *, integer *, integer *,
+ doublecomplex *, integer *), xerbla_(char *, integer *);
+ integer ioffst, irsign;
+ logical givens, iltemp;
+ extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
+ integer *);
+ extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
+ doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlartg_(doublecomplex *, doublecomplex *, doublereal *,
+ doublecomplex *, doublecomplex *);
+ logical ilextr;
+ extern /* Subroutine */ int zlagsy_(integer *, integer *, doublereal *,
+ doublecomplex *, integer *, integer *, doublecomplex *, integer *)
+ ;
+ integer isympk;
+ logical topdwn;
+ extern /* Subroutine */ int zlarot_(logical *, logical *, logical *,
+ integer *, doublecomplex *, doublecomplex *, doublecomplex *,
+ integer *, doublecomplex *, doublecomplex *);
+
+
+/* -- LAPACK test routine (version 3.1) -- */
+/* Craig Lucas, University of Manchester / NAG Ltd. */
+/* October, 2008 */
+
+/* .. Scalar Arguments .. */
+/* .. */
+/* .. Array Arguments .. */
+/* .. */
+
+/* Purpose */
+/* ======= */
+
+/* ZLATMT generates random matrices with specified singular values */
+/* (or hermitian with specified eigenvalues) */
+/* for testing LAPACK programs. */
+
+/* ZLATMT operates by applying the following sequence of */
+/* operations: */
+
+/* Set the diagonal to D, where D may be input or */
+/* computed according to MODE, COND, DMAX, and SYM */
+/* as described below. */
+
+/* Generate a matrix with the appropriate band structure, by one */
+/* of two methods: */
+
+/* Method A: */
+/* Generate a dense M x N matrix by multiplying D on the left */
+/* and the right by random unitary matrices, then: */
+
+/* Reduce the bandwidth according to KL and KU, using */
+/* Householder transformations. */
+
+/* Method B: */
+/* Convert the bandwidth-0 (i.e., diagonal) matrix to a */
+/* bandwidth-1 matrix using Givens rotations, "chasing" */
+/* out-of-band elements back, much as in QR; then convert */
+/* the bandwidth-1 to a bandwidth-2 matrix, etc. Note */
+/* that for reasonably small bandwidths (relative to M and */
+/* N) this requires less storage, as a dense matrix is not */
+/* generated. Also, for hermitian or symmetric matrices, */
+/* only one triangle is generated. */
+
+/* Method A is chosen if the bandwidth is a large fraction of the */
+/* order of the matrix, and LDA is at least M (so a dense */
+/* matrix can be stored.) Method B is chosen if the bandwidth */
+/* is small (< 1/2 N for hermitian or symmetric, < .3 N+M for */
+/* non-symmetric), or LDA is less than M and not less than the */
+/* bandwidth. */
+
+/* Pack the matrix if desired. Options specified by PACK are: */
+/* no packing */
+/* zero out upper half (if hermitian) */
+/* zero out lower half (if hermitian) */
+/* store the upper half columnwise (if hermitian or upper */
+/* triangular) */
+/* store the lower half columnwise (if hermitian or lower */
+/* triangular) */
+/* store the lower triangle in banded format (if hermitian or */
+/* lower triangular) */
+/* store the upper triangle in banded format (if hermitian or */
+/* upper triangular) */
+/* store the entire matrix in banded format */
+/* If Method B is chosen, and band format is specified, then the */
+/* matrix will be generated in the band format, so no repacking */
+/* will be necessary. */
+
+/* Arguments */
+/* ========= */
+
+/* M - INTEGER */
+/* The number of rows of A. Not modified. */
+
+/* N - INTEGER */
+/* The number of columns of A. N must equal M if the matrix */
+/* is symmetric or hermitian (i.e., if SYM is not 'N') */
+/* Not modified. */
+
+/* DIST - CHARACTER*1 */
+/* On entry, DIST specifies the type of distribution to be used */
+/* to generate the random eigen-/singular values. */
+/* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */
+/* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */
+/* 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */
+/* Not modified. */
+
+/* ISEED - INTEGER array, dimension ( 4 ) */
+/* On entry ISEED specifies the seed of the random number */
+/* generator. They should lie between 0 and 4095 inclusive, */
+/* and ISEED(4) should be odd. The random number generator */
+/* uses a linear congruential sequence limited to small */
+/* integers, and so should produce machine independent */
+/* random numbers. The values of ISEED are changed on */
+/* exit, and can be used in the next call to ZLATMT */
+/* to continue the same random number sequence. */
+/* Changed on exit. */
+
+/* SYM - CHARACTER*1 */
+/* If SYM='H', the generated matrix is hermitian, with */
+/* eigenvalues specified by D, COND, MODE, and DMAX; they */
+/* may be positive, negative, or zero. */
+/* If SYM='P', the generated matrix is hermitian, with */
+/* eigenvalues (= singular values) specified by D, COND, */
+/* MODE, and DMAX; they will not be negative. */
+/* If SYM='N', the generated matrix is nonsymmetric, with */
+/* singular values specified by D, COND, MODE, and DMAX; */
+/* they will not be negative. */
+/* If SYM='S', the generated matrix is (complex) symmetric, */
+/* with singular values specified by D, COND, MODE, and */
+/* DMAX; they will not be negative. */
+/* Not modified. */
+
+/* D - DOUBLE PRECISION array, dimension ( MIN( M, N ) ) */
+/* This array is used to specify the singular values or */
+/* eigenvalues of A (see SYM, above.) If MODE=0, then D is */
+/* assumed to contain the singular/eigenvalues, otherwise */
+/* they will be computed according to MODE, COND, and DMAX, */
+/* and placed in D. */
+/* Modified if MODE is nonzero. */
+
+/* MODE - INTEGER */
+/* On entry this describes how the singular/eigenvalues are to */
+/* be specified: */
+/* MODE = 0 means use D as input */
+/* MODE = 1 sets D(1)=1 and D(2:RANK)=1.0/COND */
+/* MODE = 2 sets D(1:RANK-1)=1 and D(RANK)=1.0/COND */
+/* MODE = 3 sets D(I)=COND**(-(I-1)/(RANK-1)) */
+/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* MODE = 5 sets D to random numbers in the range */
+/* ( 1/COND , 1 ) such that their logarithms */
+/* are uniformly distributed. */
+/* MODE = 6 set D to random numbers from same distribution */
+/* as the rest of the matrix. */
+/* MODE < 0 has the same meaning as ABS(MODE), except that */
+/* the order of the elements of D is reversed. */
+/* Thus if MODE is positive, D has entries ranging from */
+/* 1 to 1/COND, if negative, from 1/COND to 1, */
+/* If SYM='H', and MODE is neither 0, 6, nor -6, then */
+/* the elements of D will also be multiplied by a random */
+/* sign (i.e., +1 or -1.) */
+/* Not modified. */
+
+/* COND - DOUBLE PRECISION */
+/* On entry, this is used as described under MODE above. */
+/* If used, it must be >= 1. Not modified. */
+
+/* DMAX - DOUBLE PRECISION */
+/* If MODE is neither -6, 0 nor 6, the contents of D, as */
+/* computed according to MODE and COND, will be scaled by */
+/* DMAX / max(abs(D(i))); thus, the maximum absolute eigen- or */
+/* singular value (which is to say the norm) will be abs(DMAX). */
+/* Note that DMAX need not be positive: if DMAX is negative */
+/* (or zero), D will be scaled by a negative number (or zero). */
+/* Not modified. */
+
+/* RANK - INTEGER */
+/* The rank of matrix to be generated for modes 1,2,3 only. */
+/* D( RANK+1:N ) = 0. */
+/* Not modified. */
+
+/* KL - INTEGER */
+/* This specifies the lower bandwidth of the matrix. For */
+/* example, KL=0 implies upper triangular, KL=1 implies upper */
+/* Hessenberg, and KL being at least M-1 means that the matrix */
+/* has full lower bandwidth. KL must equal KU if the matrix */
+/* is symmetric or hermitian. */
+/* Not modified. */
+
+/* KU - INTEGER */
+/* This specifies the upper bandwidth of the matrix. For */
+/* example, KU=0 implies lower triangular, KU=1 implies lower */
+/* Hessenberg, and KU being at least N-1 means that the matrix */
+/* has full upper bandwidth. KL must equal KU if the matrix */
+/* is symmetric or hermitian. */
+/* Not modified. */
+
+/* PACK - CHARACTER*1 */
+/* This specifies packing of matrix as follows: */
+/* 'N' => no packing */
+/* 'U' => zero out all subdiagonal entries (if symmetric */
+/* or hermitian) */
+/* 'L' => zero out all superdiagonal entries (if symmetric */
+/* or hermitian) */
+/* 'C' => store the upper triangle columnwise (only if the */
+/* matrix is symmetric, hermitian, or upper triangular) */
+/* 'R' => store the lower triangle columnwise (only if the */
+/* matrix is symmetric, hermitian, or lower triangular) */
+/* 'B' => store the lower triangle in band storage scheme */
+/* (only if the matrix is symmetric, hermitian, or */
+/* lower triangular) */
+/* 'Q' => store the upper triangle in band storage scheme */
+/* (only if the matrix is symmetric, hermitian, or */
+/* upper triangular) */
+/* 'Z' => store the entire matrix in band storage scheme */
+/* (pivoting can be provided for by using this */
+/* option to store A in the trailing rows of */
+/* the allocated storage) */
+
+/* Using these options, the various LAPACK packed and banded */
+/* storage schemes can be obtained: */
+/* GB - use 'Z' */
+/* PB, SB, HB, or TB - use 'B' or 'Q' */
+/* PP, SP, HB, or TP - use 'C' or 'R' */
+
+/* If two calls to ZLATMT differ only in the PACK parameter, */
+/* they will generate mathematically equivalent matrices. */
+/* Not modified. */
+
+/* A - COMPLEX*16 array, dimension ( LDA, N ) */
+/* On exit A is the desired test matrix. A is first generated */
+/* in full (unpacked) form, and then packed, if so specified */
+/* by PACK. Thus, the first M elements of the first N */
+/* columns will always be modified. If PACK specifies a */
+/* packed or banded storage scheme, all LDA elements of the */
+/* first N columns will be modified; the elements of the */
+/* array which do not correspond to elements of the generated */
+/* matrix are set to zero. */
+/* Modified. */
+
+/* LDA - INTEGER */
+/* LDA specifies the first dimension of A as declared in the */
+/* calling program. If PACK='N', 'U', 'L', 'C', or 'R', then */
+/* LDA must be at least M. If PACK='B' or 'Q', then LDA must */
+/* be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)). */
+/* If PACK='Z', LDA must be large enough to hold the packed */
+/* array: MIN( KU, N-1) + MIN( KL, M-1) + 1. */
+/* Not modified. */
+
+/* WORK - COMPLEX*16 array, dimension ( 3*MAX( N, M ) ) */
+/* Workspace. */
+/* Modified. */
+
+/* INFO - INTEGER */
+/* Error code. On exit, INFO will be set to one of the */
+/* following values: */
+/* 0 => normal return */
+/* -1 => M negative or unequal to N and SYM='S', 'H', or 'P' */
+/* -2 => N negative */
+/* -3 => DIST illegal string */
+/* -5 => SYM illegal string */
+/* -7 => MODE not in range -6 to 6 */
+/* -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */
+/* -10 => KL negative */
+/* -11 => KU negative, or SYM is not 'N' and KU is not equal to */
+/* KL */
+/* -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N'; */
+/* or PACK='C' or 'Q' and SYM='N' and KL is not zero; */
+/* or PACK='R' or 'B' and SYM='N' and KU is not zero; */
+/* or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not */
+/* N. */
+/* -14 => LDA is less than M, or PACK='Z' and LDA is less than */
+/* MIN(KU,N-1) + MIN(KL,M-1) + 1. */
+/* 1 => Error return from DLATM7 */
+/* 2 => Cannot scale to DMAX (max. sing. value is 0) */
+/* 3 => Error return from ZLAGGE, ZLAGHE or ZLAGSY */
+
+/* ===================================================================== */
+
+/* .. Parameters .. */
+/* .. */
+/* .. Local Scalars .. */
+/* .. */
+/* .. External Functions .. */
+/* .. */
+/* .. External Subroutines .. */
+/* .. */
+/* .. Intrinsic Functions .. */
+/* .. */
+/* .. Executable Statements .. */
+
+/* 1) Decode and Test the input parameters. */
+/* Initialize flags & seed. */
+
+ /* Parameter adjustments */
+ --iseed;
+ --d__;
+ a_dim1 = *lda;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --work;
+
+ /* Function Body */
+ *info = 0;
+
+/* Quick return if possible */
+
+ if (*m == 0 || *n == 0) {
+ return 0;
+ }
+
+/* Decode DIST */
+
+ if (lsame_(dist, "U")) {
+ idist = 1;
+ } else if (lsame_(dist, "S")) {
+ idist = 2;
+ } else if (lsame_(dist, "N")) {
+ idist = 3;
+ } else {
+ idist = -1;
+ }
+
+/* Decode SYM */
+
+ if (lsame_(sym, "N")) {
+ isym = 1;
+ irsign = 0;
+ csym = FALSE_;
+ } else if (lsame_(sym, "P")) {
+ isym = 2;
+ irsign = 0;
+ csym = FALSE_;
+ } else if (lsame_(sym, "S")) {
+ isym = 2;
+ irsign = 0;
+ csym = TRUE_;
+ } else if (lsame_(sym, "H")) {
+ isym = 2;
+ irsign = 1;
+ csym = FALSE_;
+ } else {
+ isym = -1;
+ }
+
+/* Decode PACK */
+
+ isympk = 0;
+ if (lsame_(pack, "N")) {
+ ipack = 0;
+ } else if (lsame_(pack, "U")) {
+ ipack = 1;
+ isympk = 1;
+ } else if (lsame_(pack, "L")) {
+ ipack = 2;
+ isympk = 1;
+ } else if (lsame_(pack, "C")) {
+ ipack = 3;
+ isympk = 2;
+ } else if (lsame_(pack, "R")) {
+ ipack = 4;
+ isympk = 3;
+ } else if (lsame_(pack, "B")) {
+ ipack = 5;
+ isympk = 3;
+ } else if (lsame_(pack, "Q")) {
+ ipack = 6;
+ isympk = 2;
+ } else if (lsame_(pack, "Z")) {
+ ipack = 7;
+ } else {
+ ipack = -1;
+ }
+
+/* Set certain internal parameters */
+
+ mnmin = min(*m,*n);
+/* Computing MIN */
+ i__1 = *kl, i__2 = *m - 1;
+ llb = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *ku, i__2 = *n - 1;
+ uub = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *m, i__2 = *n + llb;
+ mr = min(i__1,i__2);
+/* Computing MIN */
+ i__1 = *n, i__2 = *m + uub;
+ nc = min(i__1,i__2);
+
+ if (ipack == 5 || ipack == 6) {
+ minlda = uub + 1;
+ } else if (ipack == 7) {
+ minlda = llb + uub + 1;
+ } else {
+ minlda = *m;
+ }
+
+/* Use Givens rotation method if bandwidth small enough, */
+/* or if LDA is too small to store the matrix unpacked. */
+
+ givens = FALSE_;
+ if (isym == 1) {
+/* Computing MAX */
+ i__1 = 1, i__2 = mr + nc;
+ if ((doublereal) (llb + uub) < (doublereal) max(i__1,i__2) * .3) {
+ givens = TRUE_;
+ }
+ } else {
+ if (llb << 1 < *m) {
+ givens = TRUE_;
+ }
+ }
+ if (*lda < *m && *lda >= minlda) {
+ givens = TRUE_;
+ }
+
+/* Set INFO if an error */
+
+ if (*m < 0) {
+ *info = -1;
+ } else if (*m != *n && isym != 1) {
+ *info = -1;
+ } else if (*n < 0) {
+ *info = -2;
+ } else if (idist == -1) {
+ *info = -3;
+ } else if (isym == -1) {
+ *info = -5;
+ } else if (abs(*mode) > 6) {
+ *info = -7;
+ } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.) {
+ *info = -8;
+ } else if (*kl < 0) {
+ *info = -10;
+ } else if (*ku < 0 || isym != 1 && *kl != *ku) {
+ *info = -11;
+ } else if (ipack == -1 || isympk == 1 && isym == 1 || isympk == 2 && isym
+ == 1 && *kl > 0 || isympk == 3 && isym == 1 && *ku > 0 || isympk
+ != 0 && *m != *n) {
+ *info = -12;
+ } else if (*lda < max(1,minlda)) {
+ *info = -14;
+ }
+
+ if (*info != 0) {
+ i__1 = -(*info);
+ xerbla_("ZLATMT", &i__1);
+ return 0;
+ }
+
+/* Initialize random number generator */
+
+ for (i__ = 1; i__ <= 4; ++i__) {
+ iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
+/* L100: */
+ }
+
+ if (iseed[4] % 2 != 1) {
+ ++iseed[4];
+ }
+
+/* 2) Set up D if indicated. */
+
+/* Compute D according to COND and MODE */
+
+ dlatm7_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, rank, &
+ iinfo);
+ if (iinfo != 0) {
+ *info = 1;
+ return 0;
+ }
+
+/* Choose Top-Down if D is (apparently) increasing, */
+/* Bottom-Up if D is (apparently) decreasing. */
+
+ if (abs(d__[1]) <= (d__1 = d__[*rank], abs(d__1))) {
+ topdwn = TRUE_;
+ } else {
+ topdwn = FALSE_;
+ }
+
+ if (*mode != 0 && abs(*mode) != 6) {
+
+/* Scale by DMAX */
+
+ temp = abs(d__[1]);
+ i__1 = *rank;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = temp, d__3 = (d__1 = d__[i__], abs(d__1));
+ temp = max(d__2,d__3);
+/* L110: */
+ }
+
+ if (temp > 0.) {
+ alpha = *dmax__ / temp;
+ } else {
+ *info = 2;
+ return 0;
+ }
+
+ dscal_(rank, &alpha, &d__[1], &c__1);
+
+ }
+
+ zlaset_("Full", lda, n, &c_b1, &c_b1, &a[a_offset], lda);
+
+/* 3) Generate Banded Matrix using Givens rotations. */
+/* Also the special case of UUB=LLB=0 */
+
+/* Compute Addressing constants to cover all */
+/* storage formats. Whether GE, HE, SY, GB, HB, or SB, */
+/* upper or lower triangle or both, */
+/* the (i,j)-th element is in */
+/* A( i - ISKEW*j + IOFFST, j ) */
+
+ if (ipack > 4) {
+ ilda = *lda - 1;
+ iskew = 1;
+ if (ipack > 5) {
+ ioffst = uub + 1;
+ } else {
+ ioffst = 1;
+ }
+ } else {
+ ilda = *lda;
+ iskew = 0;
+ ioffst = 0;
+ }
+
+/* IPACKG is the format that the matrix is generated in. If this is */
+/* different from IPACK, then the matrix must be repacked at the */
+/* end. It also signals how to compute the norm, for scaling. */
+
+ ipackg = 0;
+
+/* Diagonal Matrix -- We are done, unless it */
+/* is to be stored HP/SP/PP/TP (PACK='R' or 'C') */
+
+ if (llb == 0 && uub == 0) {
+ i__1 = mnmin;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (1 - iskew) * j + ioffst + j * a_dim1;
+ i__3 = j;
+ z__1.r = d__[i__3], z__1.i = 0.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L120: */
+ }
+
+ if (ipack <= 2 || ipack >= 5) {
+ ipackg = ipack;
+ }
+
+ } else if (givens) {
+
+/* Check whether to use Givens rotations, */
+/* Householder transformations, or nothing. */
+
+ if (isym == 1) {
+
+/* Non-symmetric -- A = U D V */
+
+ if (ipack > 4) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+
+ i__1 = mnmin;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = (1 - iskew) * j + ioffst + j * a_dim1;
+ i__3 = j;
+ z__1.r = d__[i__3], z__1.i = 0.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L130: */
+ }
+
+ if (topdwn) {
+ jkl = 0;
+ i__1 = uub;
+ for (jku = 1; jku <= i__1; ++jku) {
+
+/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */
+
+/* Last row actually rotated is M */
+/* Last column actually rotated is MIN( M+JKU, N ) */
+
+/* Computing MIN */
+ i__3 = *m + jku;
+ i__2 = min(i__3,*n) + jkl - 1;
+ for (jr = 1; jr <= i__2; ++jr) {
+ extra.r = 0., extra.i = 0.;
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ d__1 = cos(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ d__1 = sin(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ s.r = z__1.r, s.i = z__1.i;
+/* Computing MAX */
+ i__3 = 1, i__4 = jr - jkl;
+ icol = max(i__3,i__4);
+ if (jr < *m) {
+/* Computing MIN */
+ i__3 = *n, i__4 = jr + jku;
+ il = min(i__3,i__4) + 1 - icol;
+ L__1 = jr > jkl;
+ zlarot_(&c_true, &L__1, &c_false, &il, &c__, &s, &
+ a[jr - iskew * icol + ioffst + icol *
+ a_dim1], &ilda, &extra, &dummy);
+ }
+
+/* Chase "EXTRA" back up */
+
+ ir = jr;
+ ic = icol;
+ i__3 = -jkl - jku;
+ for (jch = jr - jkl; i__3 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__3) {
+ if (ir < *m) {
+ zlartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst
+ + (ic + 1) * a_dim1], &extra, &realc,
+ &s, &dummy);
+ d__1 = dlarnd_(&c__5, &iseed[1]);
+ dummy.r = d__1, dummy.i = 0.;
+ z__2.r = realc * dummy.r, z__2.i = realc *
+ dummy.i;
+ d_cnjg(&z__1, &z__2);
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__3.r = -s.r, z__3.i = -s.i;
+ z__2.r = z__3.r * dummy.r - z__3.i * dummy.i,
+ z__2.i = z__3.r * dummy.i + z__3.i *
+ dummy.r;
+ d_cnjg(&z__1, &z__2);
+ s.r = z__1.r, s.i = z__1.i;
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jku;
+ irow = max(i__4,i__5);
+ il = ir + 2 - irow;
+ ztemp.r = 0., ztemp.i = 0.;
+ iltemp = jch > jku;
+ zlarot_(&c_false, &iltemp, &c_true, &il, &c__, &s,
+ &a[irow - iskew * ic + ioffst + ic *
+ a_dim1], &ilda, &ztemp, &extra);
+ if (iltemp) {
+ zlartg_(&a[irow + 1 - iskew * (ic + 1) +
+ ioffst + (ic + 1) * a_dim1], &ztemp, &
+ realc, &s, &dummy);
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ dummy.r = z__1.r, dummy.i = z__1.i;
+ z__2.r = realc * dummy.r, z__2.i = realc *
+ dummy.i;
+ d_cnjg(&z__1, &z__2);
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__3.r = -s.r, z__3.i = -s.i;
+ z__2.r = z__3.r * dummy.r - z__3.i * dummy.i,
+ z__2.i = z__3.r * dummy.i + z__3.i *
+ dummy.r;
+ d_cnjg(&z__1, &z__2);
+ s.r = z__1.r, s.i = z__1.i;
+
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jku - jkl;
+ icol = max(i__4,i__5);
+ il = ic + 2 - icol;
+ extra.r = 0., extra.i = 0.;
+ L__1 = jch > jku + jkl;
+ zlarot_(&c_true, &L__1, &c_true, &il, &c__, &
+ s, &a[irow - iskew * icol + ioffst +
+ icol * a_dim1], &ilda, &extra, &ztemp)
+ ;
+ ic = icol;
+ ir = irow;
+ }
+/* L140: */
+ }
+/* L150: */
+ }
+/* L160: */
+ }
+
+ jku = uub;
+ i__1 = llb;
+ for (jkl = 1; jkl <= i__1; ++jkl) {
+
+/* Transform from bandwidth JKL-1, JKU to JKL, JKU */
+
+/* Computing MIN */
+ i__3 = *n + jkl;
+ i__2 = min(i__3,*m) + jku - 1;
+ for (jc = 1; jc <= i__2; ++jc) {
+ extra.r = 0., extra.i = 0.;
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ d__1 = cos(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ d__1 = sin(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ s.r = z__1.r, s.i = z__1.i;
+/* Computing MAX */
+ i__3 = 1, i__4 = jc - jku;
+ irow = max(i__3,i__4);
+ if (jc < *n) {
+/* Computing MIN */
+ i__3 = *m, i__4 = jc + jkl;
+ il = min(i__3,i__4) + 1 - irow;
+ L__1 = jc > jku;
+ zlarot_(&c_false, &L__1, &c_false, &il, &c__, &s,
+ &a[irow - iskew * jc + ioffst + jc *
+ a_dim1], &ilda, &extra, &dummy);
+ }
+
+/* Chase "EXTRA" back up */
+
+ ic = jc;
+ ir = irow;
+ i__3 = -jkl - jku;
+ for (jch = jc - jku; i__3 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__3) {
+ if (ic < *n) {
+ zlartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst
+ + (ic + 1) * a_dim1], &extra, &realc,
+ &s, &dummy);
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ dummy.r = z__1.r, dummy.i = z__1.i;
+ z__2.r = realc * dummy.r, z__2.i = realc *
+ dummy.i;
+ d_cnjg(&z__1, &z__2);
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__3.r = -s.r, z__3.i = -s.i;
+ z__2.r = z__3.r * dummy.r - z__3.i * dummy.i,
+ z__2.i = z__3.r * dummy.i + z__3.i *
+ dummy.r;
+ d_cnjg(&z__1, &z__2);
+ s.r = z__1.r, s.i = z__1.i;
+ }
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jkl;
+ icol = max(i__4,i__5);
+ il = ic + 2 - icol;
+ ztemp.r = 0., ztemp.i = 0.;
+ iltemp = jch > jkl;
+ zlarot_(&c_true, &iltemp, &c_true, &il, &c__, &s,
+ &a[ir - iskew * icol + ioffst + icol *
+ a_dim1], &ilda, &ztemp, &extra);
+ if (iltemp) {
+ zlartg_(&a[ir + 1 - iskew * (icol + 1) +
+ ioffst + (icol + 1) * a_dim1], &ztemp,
+ &realc, &s, &dummy);
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ dummy.r = z__1.r, dummy.i = z__1.i;
+ z__2.r = realc * dummy.r, z__2.i = realc *
+ dummy.i;
+ d_cnjg(&z__1, &z__2);
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__3.r = -s.r, z__3.i = -s.i;
+ z__2.r = z__3.r * dummy.r - z__3.i * dummy.i,
+ z__2.i = z__3.r * dummy.i + z__3.i *
+ dummy.r;
+ d_cnjg(&z__1, &z__2);
+ s.r = z__1.r, s.i = z__1.i;
+/* Computing MAX */
+ i__4 = 1, i__5 = jch - jkl - jku;
+ irow = max(i__4,i__5);
+ il = ir + 2 - irow;
+ extra.r = 0., extra.i = 0.;
+ L__1 = jch > jkl + jku;
+ zlarot_(&c_false, &L__1, &c_true, &il, &c__, &
+ s, &a[irow - iskew * icol + ioffst +
+ icol * a_dim1], &ilda, &extra, &ztemp)
+ ;
+ ic = icol;
+ ir = irow;
+ }
+/* L170: */
+ }
+/* L180: */
+ }
+/* L190: */
+ }
+
+ } else {
+
+/* Bottom-Up -- Start at the bottom right. */
+
+ jkl = 0;
+ i__1 = uub;
+ for (jku = 1; jku <= i__1; ++jku) {
+
+/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */
+
+/* First row actually rotated is M */
+/* First column actually rotated is MIN( M+JKU, N ) */
+
+/* Computing MIN */
+ i__2 = *m, i__3 = *n + jkl;
+ iendch = min(i__2,i__3) - 1;
+/* Computing MIN */
+ i__2 = *m + jku;
+ i__3 = 1 - jkl;
+ for (jc = min(i__2,*n) - 1; jc >= i__3; --jc) {
+ extra.r = 0., extra.i = 0.;
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ d__1 = cos(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ d__1 = sin(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ s.r = z__1.r, s.i = z__1.i;
+/* Computing MAX */
+ i__2 = 1, i__4 = jc - jku + 1;
+ irow = max(i__2,i__4);
+ if (jc > 0) {
+/* Computing MIN */
+ i__2 = *m, i__4 = jc + jkl + 1;
+ il = min(i__2,i__4) + 1 - irow;
+ L__1 = jc + jkl < *m;
+ zlarot_(&c_false, &c_false, &L__1, &il, &c__, &s,
+ &a[irow - iskew * jc + ioffst + jc *
+ a_dim1], &ilda, &dummy, &extra);
+ }
+
+/* Chase "EXTRA" back down */
+
+ ic = jc;
+ i__2 = iendch;
+ i__4 = jkl + jku;
+ for (jch = jc + jkl; i__4 < 0 ? jch >= i__2 : jch <=
+ i__2; jch += i__4) {
+ ilextr = ic > 0;
+ if (ilextr) {
+ zlartg_(&a[jch - iskew * ic + ioffst + ic *
+ a_dim1], &extra, &realc, &s, &dummy);
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ dummy.r = z__1.r, dummy.i = z__1.i;
+ z__1.r = realc * dummy.r, z__1.i = realc *
+ dummy.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__1.r = s.r * dummy.r - s.i * dummy.i,
+ z__1.i = s.r * dummy.i + s.i *
+ dummy.r;
+ s.r = z__1.r, s.i = z__1.i;
+ }
+ ic = max(1,ic);
+/* Computing MIN */
+ i__5 = *n - 1, i__6 = jch + jku;
+ icol = min(i__5,i__6);
+ iltemp = jch + jku < *n;
+ ztemp.r = 0., ztemp.i = 0.;
+ i__5 = icol + 2 - ic;
+ zlarot_(&c_true, &ilextr, &iltemp, &i__5, &c__, &
+ s, &a[jch - iskew * ic + ioffst + ic *
+ a_dim1], &ilda, &extra, &ztemp);
+ if (iltemp) {
+ zlartg_(&a[jch - iskew * icol + ioffst + icol
+ * a_dim1], &ztemp, &realc, &s, &dummy)
+ ;
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ dummy.r = z__1.r, dummy.i = z__1.i;
+ z__1.r = realc * dummy.r, z__1.i = realc *
+ dummy.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__1.r = s.r * dummy.r - s.i * dummy.i,
+ z__1.i = s.r * dummy.i + s.i *
+ dummy.r;
+ s.r = z__1.r, s.i = z__1.i;
+/* Computing MIN */
+ i__5 = iendch, i__6 = jch + jkl + jku;
+ il = min(i__5,i__6) + 2 - jch;
+ extra.r = 0., extra.i = 0.;
+ L__1 = jch + jkl + jku <= iendch;
+ zlarot_(&c_false, &c_true, &L__1, &il, &c__, &
+ s, &a[jch - iskew * icol + ioffst +
+ icol * a_dim1], &ilda, &ztemp, &extra)
+ ;
+ ic = icol;
+ }
+/* L200: */
+ }
+/* L210: */
+ }
+/* L220: */
+ }
+
+ jku = uub;
+ i__1 = llb;
+ for (jkl = 1; jkl <= i__1; ++jkl) {
+
+/* Transform from bandwidth JKL-1, JKU to JKL, JKU */
+
+/* First row actually rotated is MIN( N+JKL, M ) */
+/* First column actually rotated is N */
+
+/* Computing MIN */
+ i__3 = *n, i__4 = *m + jku;
+ iendch = min(i__3,i__4) - 1;
+/* Computing MIN */
+ i__3 = *n + jkl;
+ i__4 = 1 - jku;
+ for (jr = min(i__3,*m) - 1; jr >= i__4; --jr) {
+ extra.r = 0., extra.i = 0.;
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ d__1 = cos(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ d__1 = sin(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ s.r = z__1.r, s.i = z__1.i;
+/* Computing MAX */
+ i__3 = 1, i__2 = jr - jkl + 1;
+ icol = max(i__3,i__2);
+ if (jr > 0) {
+/* Computing MIN */
+ i__3 = *n, i__2 = jr + jku + 1;
+ il = min(i__3,i__2) + 1 - icol;
+ L__1 = jr + jku < *n;
+ zlarot_(&c_true, &c_false, &L__1, &il, &c__, &s, &
+ a[jr - iskew * icol + ioffst + icol *
+ a_dim1], &ilda, &dummy, &extra);
+ }
+
+/* Chase "EXTRA" back down */
+
+ ir = jr;
+ i__3 = iendch;
+ i__2 = jkl + jku;
+ for (jch = jr + jku; i__2 < 0 ? jch >= i__3 : jch <=
+ i__3; jch += i__2) {
+ ilextr = ir > 0;
+ if (ilextr) {
+ zlartg_(&a[ir - iskew * jch + ioffst + jch *
+ a_dim1], &extra, &realc, &s, &dummy);
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ dummy.r = z__1.r, dummy.i = z__1.i;
+ z__1.r = realc * dummy.r, z__1.i = realc *
+ dummy.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__1.r = s.r * dummy.r - s.i * dummy.i,
+ z__1.i = s.r * dummy.i + s.i *
+ dummy.r;
+ s.r = z__1.r, s.i = z__1.i;
+ }
+ ir = max(1,ir);
+/* Computing MIN */
+ i__5 = *m - 1, i__6 = jch + jkl;
+ irow = min(i__5,i__6);
+ iltemp = jch + jkl < *m;
+ ztemp.r = 0., ztemp.i = 0.;
+ i__5 = irow + 2 - ir;
+ zlarot_(&c_false, &ilextr, &iltemp, &i__5, &c__, &
+ s, &a[ir - iskew * jch + ioffst + jch *
+ a_dim1], &ilda, &extra, &ztemp);
+ if (iltemp) {
+ zlartg_(&a[irow - iskew * jch + ioffst + jch *
+ a_dim1], &ztemp, &realc, &s, &dummy);
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ dummy.r = z__1.r, dummy.i = z__1.i;
+ z__1.r = realc * dummy.r, z__1.i = realc *
+ dummy.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__1.r = s.r * dummy.r - s.i * dummy.i,
+ z__1.i = s.r * dummy.i + s.i *
+ dummy.r;
+ s.r = z__1.r, s.i = z__1.i;
+/* Computing MIN */
+ i__5 = iendch, i__6 = jch + jkl + jku;
+ il = min(i__5,i__6) + 2 - jch;
+ extra.r = 0., extra.i = 0.;
+ L__1 = jch + jkl + jku <= iendch;
+ zlarot_(&c_true, &c_true, &L__1, &il, &c__, &
+ s, &a[irow - iskew * jch + ioffst +
+ jch * a_dim1], &ilda, &ztemp, &extra);
+ ir = irow;
+ }
+/* L230: */
+ }
+/* L240: */
+ }
+/* L250: */
+ }
+
+ }
+
+ } else {
+
+/* Symmetric -- A = U D U' */
+/* Hermitian -- A = U D U* */
+
+ ipackg = ipack;
+ ioffg = ioffst;
+
+ if (topdwn) {
+
+/* Top-Down -- Generate Upper triangle only */
+
+ if (ipack >= 5) {
+ ipackg = 6;
+ ioffg = uub + 1;
+ } else {
+ ipackg = 1;
+ }
+
+ i__1 = mnmin;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = (1 - iskew) * j + ioffg + j * a_dim1;
+ i__2 = j;
+ z__1.r = d__[i__2], z__1.i = 0.;
+ a[i__4].r = z__1.r, a[i__4].i = z__1.i;
+/* L260: */
+ }
+
+ i__1 = uub;
+ for (k = 1; k <= i__1; ++k) {
+ i__4 = *n - 1;
+ for (jc = 1; jc <= i__4; ++jc) {
+/* Computing MAX */
+ i__2 = 1, i__3 = jc - k;
+ irow = max(i__2,i__3);
+/* Computing MIN */
+ i__2 = jc + 1, i__3 = k + 2;
+ il = min(i__2,i__3);
+ extra.r = 0., extra.i = 0.;
+ i__2 = jc - iskew * (jc + 1) + ioffg + (jc + 1) *
+ a_dim1;
+ ztemp.r = a[i__2].r, ztemp.i = a[i__2].i;
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ d__1 = cos(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ d__1 = sin(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ s.r = z__1.r, s.i = z__1.i;
+ if (csym) {
+ ct.r = c__.r, ct.i = c__.i;
+ st.r = s.r, st.i = s.i;
+ } else {
+ d_cnjg(&z__1, &ztemp);
+ ztemp.r = z__1.r, ztemp.i = z__1.i;
+ d_cnjg(&z__1, &c__);
+ ct.r = z__1.r, ct.i = z__1.i;
+ d_cnjg(&z__1, &s);
+ st.r = z__1.r, st.i = z__1.i;
+ }
+ L__1 = jc > k;
+ zlarot_(&c_false, &L__1, &c_true, &il, &c__, &s, &a[
+ irow - iskew * jc + ioffg + jc * a_dim1], &
+ ilda, &extra, &ztemp);
+/* Computing MIN */
+ i__3 = k, i__5 = *n - jc;
+ i__2 = min(i__3,i__5) + 1;
+ zlarot_(&c_true, &c_true, &c_false, &i__2, &ct, &st, &
+ a[(1 - iskew) * jc + ioffg + jc * a_dim1], &
+ ilda, &ztemp, &dummy);
+
+/* Chase EXTRA back up the matrix */
+
+ icol = jc;
+ i__2 = -k;
+ for (jch = jc - k; i__2 < 0 ? jch >= 1 : jch <= 1;
+ jch += i__2) {
+ zlartg_(&a[jch + 1 - iskew * (icol + 1) + ioffg +
+ (icol + 1) * a_dim1], &extra, &realc, &s,
+ &dummy);
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ dummy.r = z__1.r, dummy.i = z__1.i;
+ z__2.r = realc * dummy.r, z__2.i = realc *
+ dummy.i;
+ d_cnjg(&z__1, &z__2);
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__3.r = -s.r, z__3.i = -s.i;
+ z__2.r = z__3.r * dummy.r - z__3.i * dummy.i,
+ z__2.i = z__3.r * dummy.i + z__3.i *
+ dummy.r;
+ d_cnjg(&z__1, &z__2);
+ s.r = z__1.r, s.i = z__1.i;
+ i__3 = jch - iskew * (jch + 1) + ioffg + (jch + 1)
+ * a_dim1;
+ ztemp.r = a[i__3].r, ztemp.i = a[i__3].i;
+ if (csym) {
+ ct.r = c__.r, ct.i = c__.i;
+ st.r = s.r, st.i = s.i;
+ } else {
+ d_cnjg(&z__1, &ztemp);
+ ztemp.r = z__1.r, ztemp.i = z__1.i;
+ d_cnjg(&z__1, &c__);
+ ct.r = z__1.r, ct.i = z__1.i;
+ d_cnjg(&z__1, &s);
+ st.r = z__1.r, st.i = z__1.i;
+ }
+ i__3 = k + 2;
+ zlarot_(&c_true, &c_true, &c_true, &i__3, &c__, &
+ s, &a[(1 - iskew) * jch + ioffg + jch *
+ a_dim1], &ilda, &ztemp, &extra);
+/* Computing MAX */
+ i__3 = 1, i__5 = jch - k;
+ irow = max(i__3,i__5);
+/* Computing MIN */
+ i__3 = jch + 1, i__5 = k + 2;
+ il = min(i__3,i__5);
+ extra.r = 0., extra.i = 0.;
+ L__1 = jch > k;
+ zlarot_(&c_false, &L__1, &c_true, &il, &ct, &st, &
+ a[irow - iskew * jch + ioffg + jch *
+ a_dim1], &ilda, &extra, &ztemp);
+ icol = jch;
+/* L270: */
+ }
+/* L280: */
+ }
+/* L290: */
+ }
+
+/* If we need lower triangle, copy from upper. Note that */
+/* the order of copying is chosen to work for 'q' -> 'b' */
+
+ if (ipack != ipackg && ipack != 3) {
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ irow = ioffst - iskew * jc;
+ if (csym) {
+/* Computing MIN */
+ i__2 = *n, i__3 = jc + uub;
+ i__4 = min(i__2,i__3);
+ for (jr = jc; jr <= i__4; ++jr) {
+ i__2 = jr + irow + jc * a_dim1;
+ i__3 = jc - iskew * jr + ioffg + jr * a_dim1;
+ a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
+/* L300: */
+ }
+ } else {
+/* Computing MIN */
+ i__2 = *n, i__3 = jc + uub;
+ i__4 = min(i__2,i__3);
+ for (jr = jc; jr <= i__4; ++jr) {
+ i__2 = jr + irow + jc * a_dim1;
+ d_cnjg(&z__1, &a[jc - iskew * jr + ioffg + jr
+ * a_dim1]);
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L310: */
+ }
+ }
+/* L320: */
+ }
+ if (ipack == 5) {
+ i__1 = *n;
+ for (jc = *n - uub + 1; jc <= i__1; ++jc) {
+ i__4 = uub + 1;
+ for (jr = *n + 2 - jc; jr <= i__4; ++jr) {
+ i__2 = jr + jc * a_dim1;
+ a[i__2].r = 0., a[i__2].i = 0.;
+/* L330: */
+ }
+/* L340: */
+ }
+ }
+ if (ipackg == 6) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+ }
+ } else {
+
+/* Bottom-Up -- Generate Lower triangle only */
+
+ if (ipack >= 5) {
+ ipackg = 5;
+ if (ipack == 6) {
+ ioffg = 1;
+ }
+ } else {
+ ipackg = 2;
+ }
+
+ i__1 = mnmin;
+ for (j = 1; j <= i__1; ++j) {
+ i__4 = (1 - iskew) * j + ioffg + j * a_dim1;
+ i__2 = j;
+ z__1.r = d__[i__2], z__1.i = 0.;
+ a[i__4].r = z__1.r, a[i__4].i = z__1.i;
+/* L350: */
+ }
+
+ i__1 = uub;
+ for (k = 1; k <= i__1; ++k) {
+ for (jc = *n - 1; jc >= 1; --jc) {
+/* Computing MIN */
+ i__4 = *n + 1 - jc, i__2 = k + 2;
+ il = min(i__4,i__2);
+ extra.r = 0., extra.i = 0.;
+ i__4 = (1 - iskew) * jc + 1 + ioffg + jc * a_dim1;
+ ztemp.r = a[i__4].r, ztemp.i = a[i__4].i;
+ angle = dlarnd_(&c__1, &iseed[1]) *
+ 6.2831853071795864769252867663;
+ d__1 = cos(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ d__1 = sin(angle);
+ zlarnd_(&z__2, &c__5, &iseed[1]);
+ z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+ s.r = z__1.r, s.i = z__1.i;
+ if (csym) {
+ ct.r = c__.r, ct.i = c__.i;
+ st.r = s.r, st.i = s.i;
+ } else {
+ d_cnjg(&z__1, &ztemp);
+ ztemp.r = z__1.r, ztemp.i = z__1.i;
+ d_cnjg(&z__1, &c__);
+ ct.r = z__1.r, ct.i = z__1.i;
+ d_cnjg(&z__1, &s);
+ st.r = z__1.r, st.i = z__1.i;
+ }
+ L__1 = *n - jc > k;
+ zlarot_(&c_false, &c_true, &L__1, &il, &c__, &s, &a[(
+ 1 - iskew) * jc + ioffg + jc * a_dim1], &ilda,
+ &ztemp, &extra);
+/* Computing MAX */
+ i__4 = 1, i__2 = jc - k + 1;
+ icol = max(i__4,i__2);
+ i__4 = jc + 2 - icol;
+ zlarot_(&c_true, &c_false, &c_true, &i__4, &ct, &st, &
+ a[jc - iskew * icol + ioffg + icol * a_dim1],
+ &ilda, &dummy, &ztemp);
+
+/* Chase EXTRA back down the matrix */
+
+ icol = jc;
+ i__4 = *n - 1;
+ i__2 = k;
+ for (jch = jc + k; i__2 < 0 ? jch >= i__4 : jch <=
+ i__4; jch += i__2) {
+ zlartg_(&a[jch - iskew * icol + ioffg + icol *
+ a_dim1], &extra, &realc, &s, &dummy);
+ zlarnd_(&z__1, &c__5, &iseed[1]);
+ dummy.r = z__1.r, dummy.i = z__1.i;
+ z__1.r = realc * dummy.r, z__1.i = realc *
+ dummy.i;
+ c__.r = z__1.r, c__.i = z__1.i;
+ z__1.r = s.r * dummy.r - s.i * dummy.i, z__1.i =
+ s.r * dummy.i + s.i * dummy.r;
+ s.r = z__1.r, s.i = z__1.i;
+ i__3 = (1 - iskew) * jch + 1 + ioffg + jch *
+ a_dim1;
+ ztemp.r = a[i__3].r, ztemp.i = a[i__3].i;
+ if (csym) {
+ ct.r = c__.r, ct.i = c__.i;
+ st.r = s.r, st.i = s.i;
+ } else {
+ d_cnjg(&z__1, &ztemp);
+ ztemp.r = z__1.r, ztemp.i = z__1.i;
+ d_cnjg(&z__1, &c__);
+ ct.r = z__1.r, ct.i = z__1.i;
+ d_cnjg(&z__1, &s);
+ st.r = z__1.r, st.i = z__1.i;
+ }
+ i__3 = k + 2;
+ zlarot_(&c_true, &c_true, &c_true, &i__3, &c__, &
+ s, &a[jch - iskew * icol + ioffg + icol *
+ a_dim1], &ilda, &extra, &ztemp);
+/* Computing MIN */
+ i__3 = *n + 1 - jch, i__5 = k + 2;
+ il = min(i__3,i__5);
+ extra.r = 0., extra.i = 0.;
+ L__1 = *n - jch > k;
+ zlarot_(&c_false, &c_true, &L__1, &il, &ct, &st, &
+ a[(1 - iskew) * jch + ioffg + jch *
+ a_dim1], &ilda, &ztemp, &extra);
+ icol = jch;
+/* L360: */
+ }
+/* L370: */
+ }
+/* L380: */
+ }
+
+/* If we need upper triangle, copy from lower. Note that */
+/* the order of copying is chosen to work for 'b' -> 'q' */
+
+ if (ipack != ipackg && ipack != 4) {
+ for (jc = *n; jc >= 1; --jc) {
+ irow = ioffst - iskew * jc;
+ if (csym) {
+/* Computing MAX */
+ i__2 = 1, i__4 = jc - uub;
+ i__1 = max(i__2,i__4);
+ for (jr = jc; jr >= i__1; --jr) {
+ i__2 = jr + irow + jc * a_dim1;
+ i__4 = jc - iskew * jr + ioffg + jr * a_dim1;
+ a[i__2].r = a[i__4].r, a[i__2].i = a[i__4].i;
+/* L390: */
+ }
+ } else {
+/* Computing MAX */
+ i__2 = 1, i__4 = jc - uub;
+ i__1 = max(i__2,i__4);
+ for (jr = jc; jr >= i__1; --jr) {
+ i__2 = jr + irow + jc * a_dim1;
+ d_cnjg(&z__1, &a[jc - iskew * jr + ioffg + jr
+ * a_dim1]);
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L400: */
+ }
+ }
+/* L410: */
+ }
+ if (ipack == 6) {
+ i__1 = uub;
+ for (jc = 1; jc <= i__1; ++jc) {
+ i__2 = uub + 1 - jc;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__4 = jr + jc * a_dim1;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L420: */
+ }
+/* L430: */
+ }
+ }
+ if (ipackg == 5) {
+ ipackg = ipack;
+ } else {
+ ipackg = 0;
+ }
+ }
+ }
+
+/* Ensure that the diagonal is real if Hermitian */
+
+ if (! csym) {
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ irow = ioffst + (1 - iskew) * jc;
+ i__2 = irow + jc * a_dim1;
+ i__4 = irow + jc * a_dim1;
+ d__1 = a[i__4].r;
+ z__1.r = d__1, z__1.i = 0.;
+ a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+/* L440: */
+ }
+ }
+
+ }
+
+ } else {
+
+/* 4) Generate Banded Matrix by first */
+/* Rotating by random Unitary matrices, */
+/* then reducing the bandwidth using Householder */
+/* transformations. */
+
+/* Note: we should get here only if LDA .ge. N */
+
+ if (isym == 1) {
+
+/* Non-symmetric -- A = U D V */
+
+ zlagge_(&mr, &nc, &llb, &uub, &d__[1], &a[a_offset], lda, &iseed[
+ 1], &work[1], &iinfo);
+ } else {
+
+/* Symmetric -- A = U D U' or */
+/* Hermitian -- A = U D U* */
+
+ if (csym) {
+ zlagsy_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[
+ 1], &iinfo);
+ } else {
+ zlaghe_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[
+ 1], &iinfo);
+ }
+ }
+
+ if (iinfo != 0) {
+ *info = 3;
+ return 0;
+ }
+ }
+
+/* 5) Pack the matrix */
+
+ if (ipack != ipackg) {
+ if (ipack == 1) {
+
+/* 'U' -- Upper triangular, not packed */
+
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j + 1; i__ <= i__2; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L450: */
+ }
+/* L460: */
+ }
+
+ } else if (ipack == 2) {
+
+/* 'L' -- Lower triangular, not packed */
+
+ i__1 = *m;
+ for (j = 2; j <= i__1; ++j) {
+ i__2 = j - 1;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ i__4 = i__ + j * a_dim1;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L470: */
+ }
+/* L480: */
+ }
+
+ } else if (ipack == 3) {
+
+/* 'C' -- Upper triangle packed Columnwise. */
+
+ icol = 1;
+ irow = 0;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ ++irow;
+ if (irow > *lda) {
+ irow = 1;
+ ++icol;
+ }
+ i__4 = irow + icol * a_dim1;
+ i__3 = i__ + j * a_dim1;
+ a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i;
+/* L490: */
+ }
+/* L500: */
+ }
+
+ } else if (ipack == 4) {
+
+/* 'R' -- Lower triangle packed Columnwise. */
+
+ icol = 1;
+ irow = 0;
+ i__1 = *m;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *m;
+ for (i__ = j; i__ <= i__2; ++i__) {
+ ++irow;
+ if (irow > *lda) {
+ irow = 1;
+ ++icol;
+ }
+ i__4 = irow + icol * a_dim1;
+ i__3 = i__ + j * a_dim1;
+ a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i;
+/* L510: */
+ }
+/* L520: */
+ }
+
+ } else if (ipack >= 5) {
+
+/* 'B' -- The lower triangle is packed as a band matrix. */
+/* 'Q' -- The upper triangle is packed as a band matrix. */
+/* 'Z' -- The whole matrix is packed as a band matrix. */
+
+ if (ipack == 5) {
+ uub = 0;
+ }
+ if (ipack == 6) {
+ llb = 0;
+ }
+
+ i__1 = uub;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+ i__2 = j + llb;
+ for (i__ = min(i__2,*m); i__ >= 1; --i__) {
+ i__2 = i__ - j + uub + 1 + j * a_dim1;
+ i__4 = i__ + j * a_dim1;
+ a[i__2].r = a[i__4].r, a[i__2].i = a[i__4].i;
+/* L530: */
+ }
+/* L540: */
+ }
+
+ i__1 = *n;
+ for (j = uub + 2; j <= i__1; ++j) {
+/* Computing MIN */
+ i__4 = j + llb;
+ i__2 = min(i__4,*m);
+ for (i__ = j - uub; i__ <= i__2; ++i__) {
+ i__4 = i__ - j + uub + 1 + j * a_dim1;
+ i__3 = i__ + j * a_dim1;
+ a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i;
+/* L550: */
+ }
+/* L560: */
+ }
+ }
+
+/* If packed, zero out extraneous elements. */
+
+/* Symmetric/Triangular Packed -- */
+/* zero out everything after A(IROW,ICOL) */
+
+ if (ipack == 3 || ipack == 4) {
+ i__1 = *m;
+ for (jc = icol; jc <= i__1; ++jc) {
+ i__2 = *lda;
+ for (jr = irow + 1; jr <= i__2; ++jr) {
+ i__4 = jr + jc * a_dim1;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L570: */
+ }
+ irow = 0;
+/* L580: */
+ }
+
+ } else if (ipack >= 5) {
+
+/* Packed Band -- */
+/* 1st row is now in A( UUB+2-j, j), zero above it */
+/* m-th row is now in A( M+UUB-j,j), zero below it */
+/* last non-zero diagonal is now in A( UUB+LLB+1,j ), */
+/* zero below it, too. */
+
+ ir1 = uub + llb + 2;
+ ir2 = uub + *m + 2;
+ i__1 = *n;
+ for (jc = 1; jc <= i__1; ++jc) {
+ i__2 = uub + 1 - jc;
+ for (jr = 1; jr <= i__2; ++jr) {
+ i__4 = jr + jc * a_dim1;
+ a[i__4].r = 0., a[i__4].i = 0.;
+/* L590: */
+ }
+/* Computing MAX */
+/* Computing MIN */
+ i__3 = ir1, i__5 = ir2 - jc;
+ i__2 = 1, i__4 = min(i__3,i__5);
+ i__6 = *lda;
+ for (jr = max(i__2,i__4); jr <= i__6; ++jr) {
+ i__2 = jr + jc * a_dim1;
+ a[i__2].r = 0., a[i__2].i = 0.;
+/* L600: */
+ }
+/* L610: */
+ }
+ }
+ }
+
+ return 0;
+
+/* End of ZLATMT */
+
+} /* zlatmt_ */
diff --git a/TESTING/Makefile b/TESTING/Makefile
new file mode 100644
index 0000000..81bd9ad
--- /dev/null
+++ b/TESTING/Makefile
@@ -0,0 +1,564 @@
+#######################################################################
+# This makefile runs the test programs for the linear equation routines
+# and the eigenvalue routines in LAPACK. The test output files
+# are grouped as follows:
+#
+# SLINTST,SEIGTST -- Single precision real test routines
+# CLINTST,CEIGTST -- Single precision complex test routines
+# DLINTST,DEIGTST -- Double precision real test routines
+# ZLINTST,ZEIGTST -- Double precision complex test routines
+#
+# Test programs can be executed for all or some of the four different
+# precisions. Enter 'make' followed by one or more of the data types
+# desired.
+# Some examples:
+# make single
+# make single complex
+# make single double complex complex16
+# Alternatively, the command
+# make
+# without any arguments runs all eight test programs.
+# The executable files are called:
+# xlintsts, xlintstd, xlintstc, and xlintstz for LIN
+# xeigtsts, xeigtstd, xeigtstc, and xeigtstz for EIG
+# and exist in the current directory level.
+#
+# To remove the output files after the tests have been run, enter
+# make clean
+#
+# To re-run specific tests after a make, enter (for example):
+# 'rm ssvd.out; make' or:
+# 'make ssvd.out' or:
+# 'touch svd.in; make' (to re-run the single precision SVD tests.)
+#
+# 'rm *svd.out; make' (to re-run all the SVD tests.)
+#
+#######################################################################
+
+include ../make.inc
+
+ifneq ($(strip $(VARLIB)),)
+ LAPACKLIB := $(VARLIB) ../$(LAPACKLIB)
+endif
+
+
+all: single complex double complex16 singleproto doubleproto complexproto complex16proto
+
+SEIGTST= snep.out \
+ ssep.out \
+ ssvd.out \
+ sec.out \
+ sed.out \
+ sgg.out \
+ sgd.out \
+ ssb.out \
+ ssg.out \
+ sbal.out \
+ sbak.out \
+ sgbal.out \
+ sgbak.out \
+ sbb.out \
+ sglm.out \
+ sgqr.out \
+ sgsv.out \
+ slse.out
+
+CEIGTST= cnep.out \
+ csep.out \
+ csvd.out \
+ cec.out \
+ ced.out \
+ cgg.out \
+ cgd.out \
+ csb.out \
+ csg.out \
+ cbal.out \
+ cbak.out \
+ cgbal.out \
+ cgbak.out \
+ cbb.out \
+ cglm.out \
+ cgqr.out \
+ cgsv.out \
+ clse.out
+
+DEIGTST= dnep.out \
+ dsep.out \
+ dsvd.out \
+ dec.out \
+ ded.out \
+ dgg.out \
+ dgd.out \
+ dsb.out \
+ dsg.out \
+ dbal.out \
+ dbak.out \
+ dgbal.out \
+ dgbak.out \
+ dbb.out \
+ dglm.out \
+ dgqr.out \
+ dgsv.out \
+ dlse.out
+
+ZEIGTST= znep.out \
+ zsep.out \
+ zsvd.out \
+ zec.out \
+ zed.out \
+ zgg.out \
+ zgd.out \
+ zsb.out \
+ zsg.out \
+ zbal.out \
+ zbak.out \
+ zgbal.out \
+ zgbak.out \
+ zbb.out \
+ zglm.out \
+ zgqr.out \
+ zgsv.out \
+ zlse.out
+
+
+SLINTST= stest.out
+
+SLINTSTPROTO= stest_rfp.out
+
+CLINTST= ctest.out
+
+CLINTSTPROTO= ctest_rfp.out
+
+DLINTST= dtest.out
+
+DLINTSTPROTO= dstest.out dtest_rfp.out
+
+ZLINTST= ztest.out
+
+ZLINTSTPROTO= zctest.out ztest_rfp.out
+
+single: $(SLINTST) $(SEIGTST)
+complex: $(CLINTST) $(CEIGTST)
+double: $(DLINTST) $(DEIGTST)
+complex16: $(ZLINTST) $(ZEIGTST)
+singleproto: $(SLINTSTPROTO)
+complexproto: $(CLINTSTPROTO)
+doubleproto: $(DLINTSTPROTO)
+complex16proto: $(ZLINTSTPROTO)
+
+#
+# ======== SINGLE LIN TESTS ===========================
+
+stest.out: stest.in xlintsts
+ @echo Testing REAL LAPACK linear equation routines
+ ./xlintsts < stest.in > $@ 2>&1
+#
+# ======== COMPLEX LIN TESTS ==========================
+
+ctest.out: ctest.in xlintstc
+ @echo Testing COMPLEX LAPACK linear equation routines
+ ./xlintstc < ctest.in > $@ 2>&1
+#
+# ======== DOUBLE LIN TESTS ===========================
+
+dtest.out: dtest.in xlintstd
+ @echo Testing DOUBLE PRECISION LAPACK linear equation routines
+ ./xlintstd < dtest.in > $@ 2>&1
+#
+# ======== COMPLEX16 LIN TESTS ========================
+
+ztest.out: ztest.in xlintstz
+ @echo Testing COMPLEX16 LAPACK linear equation routines
+ ./xlintstz < ztest.in > $@ 2>&1
+#
+# ======== SINGLE-DOUBLE PROTO LIN TESTS ==============
+
+dstest.out: dstest.in xlintstds
+ @echo Testing SINGLE-DOUBLE PRECISION LAPACK prototype linear equation routines
+ ./xlintstds < dstest.in > $@ 2>&1
+#
+# ======== COMPLEX-COMPLEX16 LIN TESTS ========================
+
+zctest.out: zctest.in xlintstzc
+ @echo Testing COMPLEX-COMPLEX16 LAPACK protoype linear equation routines
+ ./xlintstzc < zctest.in > $@ 2>&1
+#
+# ======== SINGLE RFP LIN TESTS ========================
+
+stest_rfp.out: stest_rfp.in xlintstrfs
+ @echo Testing REAL LAPACK RFP protoype linear equation routines
+ ./xlintstrfs < stest_rfp.in > $@ 2>&1
+#
+# ======== COMPLEX16 RFP LIN TESTS ========================
+
+dtest_rfp.out: dtest_rfp.in xlintstrfd
+ @echo Testing DOUBLE PRECISION LAPACK RFP protoype linear equation routines
+ ./xlintstrfd < dtest_rfp.in > $@ 2>&1
+#
+# ======== COMPLEX16 RFP LIN TESTS ========================
+
+ctest_rfp.out: ctest_rfp.in xlintstrfc
+ @echo Testing COMPLEX LAPACK RFP protoype linear equation routines
+ ./xlintstrfc < ctest_rfp.in > $@ 2>&1
+#
+# ======== COMPLEX16 RFP LIN TESTS ========================
+
+ztest_rfp.out: ztest_rfp.in xlintstrfz
+ @echo Testing COMPLEX16 LAPACK RFP protoype linear equation routines
+ ./xlintstrfz < ztest_rfp.in > $@ 2>&1
+#
+#
+# ======== SINGLE EIG TESTS ===========================
+#
+
+snep.out: nep.in xeigtsts
+ @echo NEP: Testing Nonsymmetric Eigenvalue Problem routines
+ ./xeigtsts < nep.in > $@ 2>&1
+
+ssep.out: sep.in xeigtsts
+ @echo SEP: Testing Symmetric Eigenvalue Problem routines
+ ./xeigtsts < sep.in > $@ 2>&1
+
+ssvd.out: svd.in xeigtsts
+ @echo SVD: Testing Singular Value Decomposition routines
+ ./xeigtsts < svd.in > $@ 2>&1
+
+sec.out: sec.in xeigtsts
+ @echo SEC: Testing REAL Eigen Condition Routines
+ ./xeigtsts < sec.in > $@ 2>&1
+
+sed.out: sed.in xeigtsts
+ @echo SEV: Testing REAL Nonsymmetric Eigenvalue Driver
+ ./xeigtsts < sed.in > $@ 2>&1
+
+sgg.out: sgg.in xeigtsts
+ @echo SGG: Testing REAL Nonsymmetric Generalized Eigenvalue Problem routines
+ ./xeigtsts < sgg.in > $@ 2>&1
+
+sgd.out: sgd.in xeigtsts
+ @echo SGD: Testing REAL Nonsymmetric Generalized Eigenvalue Problem driver routines
+ ./xeigtsts < sgd.in > $@ 2>&1
+
+ssb.out: ssb.in xeigtsts
+ @echo SSB: Testing REAL Symmetric Eigenvalue Problem routines
+ ./xeigtsts < ssb.in > $@ 2>&1
+
+ssg.out: ssg.in xeigtsts
+ @echo SSG: Testing REAL Symmetric Generalized Eigenvalue Problem routines
+ ./xeigtsts < ssg.in > $@ 2>&1
+
+sbal.out: sbal.in xeigtsts
+ @echo SGEBAL: Testing the balancing of a REAL general matrix
+ ./xeigtsts < sbal.in > $@ 2>&1
+
+sbak.out: sbak.in xeigtsts
+ @echo SGEBAK: Testing the back transformation of a REAL balanced matrix
+ ./xeigtsts < sbak.in > $@ 2>&1
+
+sgbal.out: sgbal.in xeigtsts
+ @echo SGGBAL: Testing the balancing of a pair of REAL general matrices
+ ./xeigtsts < sgbal.in > $@ 2>&1
+
+sgbak.out: sgbak.in xeigtsts
+ @echo SGGBAK: Testing the back transformation of a pair of REAL balanced matrices
+ ./xeigtsts < sgbak.in > $@ 2>&1
+
+sbb.out: sbb.in xeigtsts
+ @echo SBB: Testing banded Singular Value Decomposition routines
+ ./xeigtsts < sbb.in > $@ 2>&1
+
+sglm.out: glm.in xeigtsts
+ @echo GLM: Testing Generalized Linear Regression Model routines
+ ./xeigtsts < glm.in > $@ 2>&1
+
+sgqr.out: gqr.in xeigtsts
+ @echo GQR: Testing Generalized QR and RQ factorization routines
+ ./xeigtsts < gqr.in > $@ 2>&1
+
+sgsv.out: gsv.in xeigtsts
+ @echo GSV: Testing Generalized Singular Value Decomposition routines
+ ./xeigtsts < gsv.in > $@ 2>&1
+
+slse.out: lse.in xeigtsts
+ @echo LSE: Testing Constrained Linear Least Squares routines
+ ./xeigtsts < lse.in > $@ 2>&1
+#
+# ======== COMPLEX EIG TESTS ===========================
+
+cnep.out: nep.in xeigtstc
+ @echo NEP: Testing Nonsymmetric Eigenvalue Problem routines
+ ./xeigtstc < nep.in > $@ 2>&1
+
+csep.out: sep.in xeigtstc
+ @echo SEP: Testing Symmetric Eigenvalue Problem routines
+ ./xeigtstc < sep.in > $@ 2>&1
+
+csvd.out: svd.in xeigtstc
+ @echo SVD: Testing Singular Value Decomposition routines
+ ./xeigtstc < svd.in > $@ 2>&1
+
+cec.out: cec.in xeigtstc
+ @echo CEC: Testing COMPLEX Eigen Condition Routines
+ ./xeigtstc < cec.in > $@ 2>&1
+
+ced.out: ced.in xeigtstc
+ @echo CES: Testing COMPLEX Nonsymmetric Schur Form Driver
+ ./xeigtstc < ced.in > $@ 2>&1
+
+cgg.out: cgg.in xeigtstc
+ @echo CGG: Testing COMPLEX Nonsymmetric Generalized Eigenvalue Problem routines
+ ./xeigtstc < cgg.in > $@ 2>&1
+
+cgd.out: cgd.in xeigtstc
+ @echo CGD: Testing COMPLEX Nonsymmetric Generalized Eigenvalue Problem driver routines
+ ./xeigtstc < cgd.in > $@ 2>&1
+
+csb.out: csb.in xeigtstc
+ @echo CHB: Testing Hermitian Eigenvalue Problem routines
+ ./xeigtstc < csb.in > $@ 2>&1
+
+csg.out: csg.in xeigtstc
+ @echo CSG: Testing Symmetric Generalized Eigenvalue Problem routines
+ ./xeigtstc < csg.in > $@ 2>&1
+
+cbal.out: cbal.in xeigtstc
+ @echo CGEBAL: Testing the balancing of a COMPLEX general matrix
+ ./xeigtstc < cbal.in > $@ 2>&1
+
+cbak.out: cbak.in xeigtstc
+ @echo CGEBAK: Testing the back transformation of a COMPLEX balanced matrix
+ ./xeigtstc < cbak.in > $@ 2>&1
+
+cgbal.out: cgbal.in xeigtstc
+ @echo CGGBAL: Testing the balancing of a pair of COMPLEX general matrices
+ ./xeigtstc < cgbal.in > $@ 2>&1
+
+cgbak.out: cgbak.in xeigtstc
+ @echo CGGBAK: Testing the back transformation of a pair of COMPLEX balanced matrices
+ ./xeigtstc < cgbak.in > $@ 2>&1
+
+cbb.out: cbb.in xeigtstc
+ @echo CBB: Testing banded Singular Value Decomposition routines
+ ./xeigtstc < cbb.in > $@ 2>&1
+
+cglm.out: glm.in xeigtstc
+ @echo GLM: Testing Generalized Linear Regression Model routines
+ ./xeigtstc < glm.in > $@ 2>&1
+
+cgqr.out: gqr.in xeigtstc
+ @echo GQR: Testing Generalized QR and RQ factorization routines
+ ./xeigtstc < gqr.in > $@ 2>&1
+
+cgsv.out: gsv.in xeigtstc
+ @echo GSV: Testing Generalized Singular Value Decomposition routines
+ ./xeigtstc < gsv.in > $@ 2>&1
+
+clse.out: lse.in xeigtstc
+ @echo LSE: Testing Constrained Linear Least Squares routines
+ ./xeigtstc < lse.in > $@ 2>&1
+#
+# ======== DOUBLE EIG TESTS ===========================
+
+dnep.out: nep.in xeigtstd
+ @echo NEP: Testing Nonsymmetric Eigenvalue Problem routines
+ ./xeigtstd < nep.in > $@ 2>&1
+
+dsep.out: sep.in xeigtstd
+ @echo SEP: Testing Symmetric Eigenvalue Problem routines
+ ./xeigtstd < sep.in > $@ 2>&1
+
+dsvd.out: svd.in xeigtstd
+ @echo SVD: Testing Singular Value Decomposition routines
+ ./xeigtstd < svd.in > $@ 2>&1
+
+dec.out: dec.in xeigtstd
+ @echo DEC: Testing DOUBLE PRECISION Eigen Condition Routines
+ ./xeigtstd < dec.in > $@ 2>&1
+
+ded.out: ded.in xeigtstd
+ @echo DEV: Testing DOUBLE PRECISION Nonsymmetric Eigenvalue Driver
+ ./xeigtstd < ded.in > $@ 2>&1
+
+dgg.out: dgg.in xeigtstd
+ @echo DGG: Testing DOUBLE PRECISION Nonsymmetric Generalized Eigenvalue Problem routines
+ ./xeigtstd < dgg.in > $@ 2>&1
+
+dgd.out: dgd.in xeigtstd
+ @echo DGD: Testing DOUBLE PRECISION Nonsymmetric Generalized Eigenvalue Problem driver routines
+ ./xeigtstd < dgd.in > $@ 2>&1
+
+dsb.out: dsb.in xeigtstd
+ @echo DSB: Testing DOUBLE PRECISION Symmetric Eigenvalue Problem routines
+ ./xeigtstd < dsb.in > $@ 2>&1
+
+dsg.out: dsg.in xeigtstd
+ @echo DSG: Testing DOUBLE PRECISION Symmetric Generalized Eigenvalue Problem routines
+ ./xeigtstd < dsg.in > $@ 2>&1
+
+dbal.out: dbal.in xeigtstd
+ @echo DGEBAL: Testing the balancing of a DOUBLE PRECISION general matrix
+ ./xeigtstd < dbal.in > $@ 2>&1
+
+dbak.out: dbak.in xeigtstd
+ @echo DGEBAK: Testing the back transformation of a DOUBLE PRECISION balanced matrix
+ ./xeigtstd < dbak.in > $@ 2>&1
+
+dgbal.out: dgbal.in xeigtstd
+ @echo DGGBAL: Testing the balancing of a pair of DOUBLE PRECISION general matrices
+ ./xeigtstd < dgbal.in > $@ 2>&1
+
+dgbak.out: dgbak.in xeigtstd
+ @echo DGGBAK: Testing the back transformation of a pair of DOUBLE PRECISION balanced matrices
+ ./xeigtstd < dgbak.in > $@ 2>&1
+
+dbb.out: dbb.in xeigtstd
+ @echo DBB: Testing banded Singular Value Decomposition routines
+ ./xeigtstd < dbb.in > $@ 2>&1
+
+dglm.out: glm.in xeigtstd
+ @echo GLM: Testing Generalized Linear Regression Model routines
+ ./xeigtstd < glm.in > $@ 2>&1
+
+dgqr.out: gqr.in xeigtstd
+ @echo GQR: Testing Generalized QR and RQ factorization routines
+ ./xeigtstd < gqr.in > $@ 2>&1
+
+dgsv.out: gsv.in xeigtstd
+ @echo GSV: Testing Generalized Singular Value Decomposition routines
+ ./xeigtstd < gsv.in > $@ 2>&1
+
+dlse.out: lse.in xeigtstd
+ @echo LSE: Testing Constrained Linear Least Squares routines
+ ./xeigtstd < lse.in > $@ 2>&1
+#
+# ======== COMPLEX16 EIG TESTS ===========================
+
+znep.out: nep.in xeigtstz
+ @echo NEP: Testing Nonsymmetric Eigenvalue Problem routines
+ ./xeigtstz < nep.in > $@ 2>&1
+
+zsep.out: sep.in xeigtstz
+ @echo SEP: Testing Symmetric Eigenvalue Problem routines
+ ./xeigtstz < sep.in > $@ 2>&1
+
+zsvd.out: svd.in xeigtstz
+ @echo SVD: Testing Singular Value Decomposition routines
+ ./xeigtstz < svd.in > $@ 2>&1
+
+zec.out: zec.in xeigtstz
+ @echo ZEC: Testing COMPLEX16 Eigen Condition Routines
+ ./xeigtstz < zec.in > $@ 2>&1
+
+zed.out: zed.in xeigtstz
+ @echo ZES: Testing COMPLEX16 Nonsymmetric Schur Form Driver
+ ./xeigtstz < zed.in > $@ 2>&1
+
+zgg.out: zgg.in xeigtstz
+ @echo ZGG: Testing COMPLEX16 Nonsymmetric Generalized Eigenvalue Problem routines
+ ./xeigtstz < zgg.in > $@ 2>&1
+
+zgd.out: zgd.in xeigtstz
+ @echo ZGD: Testing COMPLEX16 Nonsymmetric Generalized Eigenvalue Problem driver routines
+ ./xeigtstz < zgd.in > $@ 2>&1
+
+zsb.out: zsb.in xeigtstz
+ @echo ZHB: Testing Hermitian Eigenvalue Problem routines
+ ./xeigtstz < zsb.in > $@ 2>&1
+
+zsg.out: zsg.in xeigtstz
+ @echo ZSG: Testing Symmetric Generalized Eigenvalue Problem routines
+ ./xeigtstz < zsg.in > $@ 2>&1
+
+zbal.out: zbal.in xeigtstz
+ @echo ZGEBAL: Testing the balancing of a COMPLEX16 general matrix
+ ./xeigtstz < zbal.in > $@ 2>&1
+
+zbak.out: zbak.in xeigtstz
+ @echo ZGEBAK: Testing the back transformation of a COMPLEX16 balanced matrix
+ ./xeigtstz < zbak.in > $@ 2>&1
+
+zgbal.out: zgbal.in xeigtstz
+ @echo ZGGBAL: Testing the balancing of a pair of COMPLEX general matrices
+ ./xeigtstz < zgbal.in > $@ 2>&1
+
+zgbak.out: zgbak.in xeigtstz
+ @echo ZGGBAK: Testing the back transformation of a pair of COMPLEX16 balanced matrices
+ ./xeigtstz < zgbak.in > $@ 2>&1
+
+zbb.out: zbb.in xeigtstz
+ @echo ZBB: Testing banded Singular Value Decomposition routines
+ ./xeigtstz < zbb.in > $@ 2>&1
+
+zglm.out: glm.in xeigtstz
+ @echo GLM: Testing Generalized Linear Regression Model routines
+ ./xeigtstz < glm.in > $@ 2>&1
+
+zgqr.out: gqr.in xeigtstz
+ @echo GQR: Testing Generalized QR and RQ factorization routines
+ ./xeigtstz < gqr.in > $@ 2>&1
+
+zgsv.out: gsv.in xeigtstz
+ @echo GSV: Testing Generalized Singular Value Decomposition routines
+ ./xeigtstz < gsv.in > $@ 2>&1
+
+zlse.out: lse.in xeigtstz
+ @echo LSE: Testing Constrained Linear Least Squares routines
+ ./xeigtstz < lse.in > $@ 2>&1
+# ==============================================================================
+
+xlintsts: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC)
+ cd LIN ; $(MAKE) single
+
+xlintstc: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC)
+ cd LIN ; $(MAKE) complex
+
+xlintstd: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC)
+ cd LIN ; $(MAKE) double
+
+xlintstz: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC)
+ cd LIN ; $(MAKE) complex16
+
+xlintstrfs: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC)
+ cd LIN ; $(MAKE) proto-single
+
+xlintstrfc: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC)
+ cd LIN ; $(MAKE) proto-complex
+
+xlintstrfd: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC)
+ cd LIN ; $(MAKE) proto-double
+
+xlintstrfz: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC)
+ cd LIN ; $(MAKE) proto-complex16
+
+xlintstds: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC)
+ cd LIN ; $(MAKE) proto-double
+
+xlintstzc: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCLIN) $(FRC)
+ cd LIN ; $(MAKE) proto-complex16
+
+xeigtsts: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCEIG) $(FRC)
+ cd EIG ; $(MAKE) single
+
+xeigtstc: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCEIG) $(FRC)
+ cd EIG ; $(MAKE) complex
+
+xeigtstd: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCEIG) $(FRC)
+ cd EIG ; $(MAKE) double
+
+xeigtstz: ../$(LAPACKLIB) ../$(TMGLIB) $(FRCEIG) $(FRC)
+ cd EIG ; $(MAKE) complex16
+
+clean:
+ rm -f *.out core
+
+cleanup:
+ rm -f x* *.out core
+
+FRCLIN:
+ @FRCLIN=$(FRCLIN)
+
+FRCEIG:
+ @FRCEIG=$(FRCEIG)
+
+FRC:
+ @FRC=$(FRC)
diff --git a/TESTING/cbak.in b/TESTING/cbak.in
new file mode 100644
index 0000000..c6073bd
--- /dev/null
+++ b/TESTING/cbak.in
@@ -0,0 +1,208 @@
+CBK: Tests CGEBAK
+ 5 1 1
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01
+
+(0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00)
+
+(0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00)
+
+ 5 1 1
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+
+(0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00)
+(-.66667E+00,0.00000E+00) (-.41667E-01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (-.25000E+00,0.00000E+00) (-.66667E+00,0.00000E+00)
+(0.10000E+01,0.00000E+00) (0.16667E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.22222E+00,0.00000E+00)
+(-.10000E+01,0.00000E+00) (-.50000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.50000E+00,0.00000E+00) (0.10000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (-.10000E+01,0.00000E+00)
+
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (-.10000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.50000E+00,0.00000E+00) (0.10000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.22222E+00,0.00000E+00)
+(-.10000E+01,0.00000E+00) (-.50000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (-.25000E+00,0.00000E+00) (-.66667E+00,0.00000E+00)
+(0.10000E+01,0.00000E+00) (0.16667E+00,0.00000E+00)
+(0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00)
+(-.66667E+00,0.00000E+00) (-.41667E-01,0.00000E+00)
+
+ 5 1 1
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+
+(0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00)
+(0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (-.60000E-17,0.00000E+00) (-.60000E-17,0.00000E+00)
+(-.60000E-17,0.00000E+00) (-.60000E-17,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.36000E-34,0.00000E+00)
+(0.36000E-34,0.00000E+00) (0.36000E-34,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.36000E-34,0.00000E+00)
+(0.36000E-34,0.00000E+00) (0.36000E-34,0.00000E+00)
+(0.00000E+00,0.00000E+00) (-.60000E-17,0.00000E+00) (-.60000E-17,0.00000E+00)
+(-.60000E-17,0.00000E+00) (-.60000E-17,0.00000E+00)
+(0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00)
+(0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00)
+
+ 6 4 6
+ 0.4000E+01 0.3000E+01 0.5000E+01 0.1000E+03 0.1000E+00 0.1000E+01
+
+(0.10000E+01,0.00000E+00) (0.13356E-05,0.00000E+00) (0.10000E+01,0.00000E+00)
+(0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00)
+(-.30007E-10,0.00000E+00) (-.32523E-04,0.00000E+00) (0.13050E-01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (-.83300E-02,0.00000E+00)
+(0.89289E-09,0.00000E+00) (-.67123E-04,0.00000E+00) (0.66874E-04,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(-.44554E-05,0.00000E+00) (-.33550E-02,0.00000E+00) (0.33448E-02,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.44554E-06,0.00000E+00) (-.33561E-01,0.00000E+00) (0.33437E-01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.44113E-09,0.00000E+00) (0.10115E+00,0.00000E+00) (0.10084E+00,0.00000E+00)
+
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(-.44554E-03,0.00000E+00) (-.33550E+00,0.00000E+00) (0.33448E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.44554E-07,0.00000E+00) (-.33561E-02,0.00000E+00) (0.33437E-02,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00)
+(-.30007E-10,0.00000E+00) (-.32523E-04,0.00000E+00) (0.13050E-01,0.00000E+00)
+(0.10000E+01,0.00000E+00) (0.13356E-05,0.00000E+00) (0.10000E+01,0.00000E+00)
+(0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (-.83300E-02,0.00000E+00)
+(0.89289E-09,0.00000E+00) (-.67123E-04,0.00000E+00) (0.66874E-04,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.44113E-09,0.00000E+00) (0.10115E+00,0.00000E+00) (0.10084E+00,0.00000E+00)
+
+ 5 1 5
+ 0.1000E+03 0.1000E+00 0.1000E-01 0.1000E+01 0.1000E+02
+
+(0.13663E-03,0.00000E+00) (-.68290E-04,0.00000E+00) (0.12516E-03,0.00000E+00)
+(0.10000E+01,0.00000E+00) (0.19503E-14,0.00000E+00)
+(0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) (-.27756E-16,0.00000E+00)
+(0.36012E-05,0.00000E+00) (-.60728E-17,0.00000E+00)
+(0.27355E+00,0.00000E+00) (-.13627E+00,0.00000E+00) (0.25030E+00,0.00000E+00)
+(-.33221E-05,0.00000E+00) (-.20000E-02,0.00000E+00)
+(0.69088E-02,0.00000E+00) (-.34434E-02,0.00000E+00) (0.61959E-02,0.00000E+00)
+(0.16661E-01,0.00000E+00) (0.10000E+01,0.00000E+00)
+(0.38988E+00,0.00000E+00) (-.20327E+00,0.00000E+00) (-.34200E+00,0.00000E+00)
+(-.10000E-02,0.00000E+00) (0.60004E-14,0.00000E+00)
+
+(0.13663E-01,0.00000E+00) (-.68290E-02,0.00000E+00) (0.12516E-01,0.00000E+00)
+(0.10000E+03,0.00000E+00) (0.19503E-12,0.00000E+00)
+(0.10000E+00,0.00000E+00) (0.10000E+00,0.00000E+00) (-.27756E-17,0.00000E+00)
+(0.36012E-06,0.00000E+00) (-.60728E-18,0.00000E+00)
+(0.27355E-02,0.00000E+00) (-.13627E-02,0.00000E+00) (0.25030E-02,0.00000E+00)
+(-.33221E-07,0.00000E+00) (-.20000E-04,0.00000E+00)
+(0.69088E-02,0.00000E+00) (-.34434E-02,0.00000E+00) (0.61959E-02,0.00000E+00)
+(0.16661E-01,0.00000E+00) (0.10000E+01,0.00000E+00)
+(0.38988E+01,0.00000E+00) (-.20327E+01,0.00000E+00) (-.34200E+01,0.00000E+00)
+(-.10000E-01,0.00000E+00) (0.60004E-13,0.00000E+00)
+
+ 6 2 5
+ 0.3000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.4000E+01
+
+(0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) (0.27764E-15,0.00000E+00)
+(-.24046E-16,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.75000E+00,0.00000E+00) (0.10000E+01,0.00000E+00)
+(0.85197E-01,0.00000E+00) (0.00000E+00,0.00000E+00) (-.15196E-16,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.75000E+00,0.00000E+00) (-.80934E+00,0.00000E+00)
+(0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (-.15196E-16,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.75000E+00,0.00000E+00) (-.95328E-01,0.00000E+00)
+(-.54260E+00,0.00000E+00) (0.10000E+01,0.00000E+00) (-.15196E-16,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.75000E+00,0.00000E+00) (-.95328E-01,0.00000E+00)
+(-.54260E+00,0.00000E+00) (-.10000E+01,0.00000E+00) (-.15196E-16,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.45588E-16,0.00000E+00)
+
+(0.00000E+00,0.00000E+00) (0.75000E+00,0.00000E+00) (-.80934E+00,0.00000E+00)
+(0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (-.15196E-16,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.75000E+00,0.00000E+00) (0.10000E+01,0.00000E+00)
+(0.85197E-01,0.00000E+00) (0.00000E+00,0.00000E+00) (-.15196E-16,0.00000E+00)
+(0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00) (0.27764E-15,0.00000E+00)
+(-.24046E-16,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.45588E-16,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.75000E+00,0.00000E+00) (-.95328E-01,0.00000E+00)
+(-.54260E+00,0.00000E+00) (-.10000E+01,0.00000E+00) (-.15196E-16,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.75000E+00,0.00000E+00) (-.95328E-01,0.00000E+00)
+(-.54260E+00,0.00000E+00) (0.10000E+01,0.00000E+00) (-.15196E-16,0.00000E+00)
+
+ 7 2 5
+ 0.3000E+01 0.1000E-02 0.1000E-01 0.1000E+02 0.1000E+00 0.1000E+01
+ 0.6000E+01
+
+(0.10000E+01,0.00000E+00) (-.11048E-01,0.00000E+00) (0.37942E-01,0.00000E+00)
+(-.93781E-01,0.00000E+00) (-.34815E-01,0.00000E+00) (0.44651E+00,0.00000E+00)
+(-.36016E-01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (-.45564E+00,0.00000E+00) (-.45447E+00,0.00000E+00)
+(0.10000E+01,0.00000E+00) (0.46394E+00,0.00000E+00) (-.65116E+00,0.00000E+00)
+(0.47808E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (-.27336E+00,0.00000E+00) (-.79459E+00,0.00000E+00)
+(0.63028E+00,0.00000E+00) (0.10000E+01,0.00000E+00) (-.62791E+00,0.00000E+00)
+(0.10000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) (-.69389E-17,0.00000E+00)
+(0.42585E-01,0.00000E+00) (-.64954E+00,0.00000E+00) (-.55814E+00,0.00000E+00)
+(-.64516E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (-.39041E+00,0.00000E+00) (-.40294E+00,0.00000E+00)
+(-.16849E+00,0.00000E+00) (-.94294E+00,0.00000E+00) (0.10000E+01,0.00000E+00)
+(-.93714E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (-.25581E+00,0.00000E+00)
+(0.33085E-03,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(-.19851E-02,0.00000E+00)
+
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (-.25581E+00,0.00000E+00)
+(0.33085E-03,0.00000E+00)
+(0.00000E+00,0.00000E+00) (-.45564E-03,0.00000E+00) (-.45447E-03,0.00000E+00)
+(0.10000E-02,0.00000E+00) (0.46394E-03,0.00000E+00) (-.65116E-03,0.00000E+00)
+(0.47808E-03,0.00000E+00)
+(0.10000E+01,0.00000E+00) (-.11048E-01,0.00000E+00) (0.37942E-01,0.00000E+00)
+(-.93781E-01,0.00000E+00) (-.34815E-01,0.00000E+00) (0.44651E+00,0.00000E+00)
+(-.36016E-01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.10000E+02,0.00000E+00) (-.69389E-16,0.00000E+00)
+(0.42585E+00,0.00000E+00) (-.64954E+01,0.00000E+00) (-.55814E+01,0.00000E+00)
+(-.64516E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (-.39041E-01,0.00000E+00) (-.40294E-01,0.00000E+00)
+(-.16849E-01,0.00000E+00) (-.94294E-01,0.00000E+00) (0.10000E+00,0.00000E+00)
+(-.93714E-01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(-.19851E-02,0.00000E+00)
+(0.00000E+00,0.00000E+00) (-.27336E-02,0.00000E+00) (-.79459E-02,0.00000E+00)
+(0.63028E-02,0.00000E+00) (0.10000E-01,0.00000E+00) (-.62791E-02,0.00000E+00)
+(0.10000E-01,0.00000E+00)
+
+0 0 0
diff --git a/TESTING/cbal.in b/TESTING/cbal.in
new file mode 100644
index 0000000..29b1459
--- /dev/null
+++ b/TESTING/cbal.in
@@ -0,0 +1,350 @@
+CBL: Tests CGEBAL
+ 5
+(0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.20000E+01,0.10000E+01) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.30000E+01,0.30000E+01)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.40000E+01,0.10000E+01) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.50000E+01,0.50000E+01)
+
+ 1 1
+(0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.20000E+01,0.10000E+01) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.30000E+01,0.30000E+01)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.40000E+01,0.10000E+01) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.50000E+01,0.50000E+01)
+
+ 0.10000E+01 0.20000E+01 0.30000E+01 0.40000E+01 0.50000E+01
+
+ 5
+(0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.10000E+01,0.10000E+01) (0.20000E+01,0.20000E+01) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.10000E+01,0.10000E+01) (0.20000E+01,0.20000E+01) (0.30000E+01,0.30000E+01)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.10000E+01,0.10000E+01) (0.20000E+01,0.20000E+01) (0.30000E+01,0.30000E+01)
+(0.40000E+01,0.40000E+01) (0.00000E+00,0.00000E+00)
+(0.10000E+01,0.10000E+01) (0.20000E+01,0.20000E+01) (0.30000E+01,0.30000E+01)
+(0.40000E+01,0.40000E+01) (0.50000E+01,0.50000E+01)
+
+ 1 1
+(0.50000E+01,0.50000E+01) (0.40000E+01,0.40000E+01) (0.30000E+01,0.30000E+01)
+(0.20000E+01,0.20000E+01) (0.10000E+01,0.10000E+01)
+(0.00000E+00,0.00000E+00) (0.40000E+01,0.40000E+01) (0.30000E+01,0.30000E+01)
+(0.20000E+01,0.20000E+01) (0.10000E+01,0.10000E+01)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.30000E+01,0.30000E+01)
+(0.20000E+01,0.20000E+01) (0.10000E+01,0.10000E+01)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.20000E+01,0.20000E+01) (0.10000E+01,0.10000E+01)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.10000E+01,0.10000E+01)
+
+ 0.10000E+01 0.20000E+01 0.30000E+01 0.20000E+01 0.10000E+01
+
+ 5
+(0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.10000E+01,0.00000E+00) (0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00) (0.10000E+01,0.10000E+01)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00)
+(0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.10000E+01,0.00000E+00) (0.10000E+01,0.10000E+01)
+
+ 1 1
+(0.10000E+01,0.10000E+01) (0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.10000E+01,0.10000E+01) (0.10000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+01,0.10000E+01)
+(0.10000E+01,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.10000E+01,0.10000E+01) (0.10000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.10000E+01,0.10000E+01)
+
+ 0.10000E+01 0.20000E+01 0.30000E+01 0.20000E+01 0.10000E+01
+
+ 4
+(0.00000E+00,0.00000E+00) (0.20000E+01,0.00000E+00) (0.10000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00)
+(0.20000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.10000E+00,0.00000E+00)
+(0.10000E+03,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.20000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.10000E+03,0.00000E+00) (0.20000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00)
+
+ 1 4
+(0.0000E+00,0.00000E+00) (0.2000E+01,0.00000E+00) (0.3200E+01,0.00000E+00)
+(0.000E+00,0.00000E+00)
+(0.2000E+01,0.00000E+00) (0.0000E+00,0.00000E+00) (0.0000E+00,0.00000E+00)
+(0.3200E+01,0.00000E+00)
+(0.3125E+01,0.00000E+00) (0.0000E+00,0.00000E+00) (0.0000E+00,0.00000E+00)
+(0.2000E+01,0.00000E+00)
+(0.0000E+00,0.00000E+00) (0.3125E+01,0.00000E+00) (0.2000E+01,0.00000E+00)
+(0.0000E+00,0.00000E+00)
+
+6.25000E-02 6.25000E-02 2.00000E+00 2.00000E+00
+
+ 6
+(0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10240E+04,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.12800E+03,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.20000E+01,0.10000E+01) (0.30000E+04,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.20000E+01,0.00000E+00)
+(0.00000E+00,0.12800E+03) (0.40000E+01,0.00000E+00) (0.40000E-02,0.00000E+00)
+(0.50000E+01,0.00000E+00) (0.60000E+03,0.00000E+00) (0.80000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.20000E-02) (0.20000E+01,0.00000E+00)
+(0.80000E+01,0.00000E+00) (0.00000E+00,0.81920E+04) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.20000E+01,0.00000E+00)
+
+ 4 6
+(0.50000E+01,0.00000E+00) (0.40000E-02,0.00000E+00) (0.60000E+03,0.00000E+00)
+(0.00000E+00,0.10240E+04) (0.50000E+00,0.00000E+00) (0.80000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.30000E+04,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.25000E+00,0.12500E+00) (0.20000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.20000E-02)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.20000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) (0.12800E+03,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10240E+04,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.64000E+02,0.00000E+00) (0.00000E+00,0.10240E+04) (0.20000E+01,0.00000E+00)
+
+ 0.40000E+01 0.30000E+01 0.50000E+01 0.80000E+01 0.12500E+00 0.10000E+01
+
+5
+(0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.80000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.20000E+01,0.10000E+01) (0.81920E+04,0.00000E+00)
+(0.20000E+01,0.00000E+00) (0.40000E+01,0.00000E+00)
+(0.25000E-03,0.00000E+00) (0.12500E-03,0.00000E+00) (0.40000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.64000E+02,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.20000E+01,0.00000E+00) (0.10240E+04,0.10240E+01)
+(0.40000E+01,0.00000E+00) (0.80000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.81920E+04) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.80000E+01,0.00000E+00)
+
+ 1 5
+ ( 1.0000e+000, 1.0000e+000) ( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00)
+( 0.0000e-003,0.00000E+00) (250.0000e-003,0.00000E+00)
+ ( 0.0000e-003,0.00000E+00) ( 2.0000e+000, 1.0000e+000) ( 1.0240e+003,0.00000E+00)
+ ( 16.0000e+000,0.00000E+00) ( 16.0000e+000,0.00000E+00)
+ (256.0000e-003,0.00000E+00) ( 1.0000e-003,0.00000E+00) ( 4.0000e+000,0.00000E+00)
+ ( 0.0000e-003,0.00000E+00) ( 2.0480e+003,0.00000E+00)
+ ( 0.0000e-003,0.00000E+00) (250.0000e-003,0.00000E+00) ( 16.0000e+000,16.0000e-003)
+ ( 4.0000e+000,0.00000E+00) ( 4.0000e+000,0.00000E+00)
+ ( 0.0000e-003,0.00000E+00) ( 0.0000e-003, 2.0480e+003) ( 0.0000e-003,0.00000E+00)
+ ( 0.0000e-003,0.00000E+00) ( 8.0000e+000,0.00000E+00)
+
+ 64.0000e+000 500.0000e-003 62.5000e-003 4.0000e+000 2.0000e+000
+
+ 4
+(0.10000E+01,0.10000E+01) (0.10000E+07,0.00000E+00) (0.10000E+07,0.00000E+00)
+(0.10000E+07,0.00000E+00)
+(-.20000E+07,0.00000E+00) (0.30000E+01,0.10000E+01) (0.20000E-05,0.00000E+00)
+(0.30000E-05,0.00000E+00)
+(-.30000E+07,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E-05,0.10000E+01)
+(0.20000E+01,0.00000E+00)
+(0.10000E+07,0.00000E+00) (0.00000E+00,0.00000E+00) (0.30000E-05,0.00000E+00)
+(0.40000E+07,0.10000E+01)
+
+ 1 4
+
+ ( 1.0000e+000, 1.0000e+000) ( 1.0000e+006,0.00000E+00) ( 2.0000e+006,0.00000E+00) ( 1.0000e+006,0.00000E+00) (250.0000e-003,0.00000E+00)
+ ( -2.0000e+006,0.00000E+00) ( 3.0000e+000, 1.0000e+000) ( 4.0000e-006,0.00000E+00) ( 3.0000e-006,0.00000E+00) ( 16.0000e+000,0.00000E+00)
+ ( -1.5000e+006,0.00000E+00) ( 0.0000e-003,0.00000E+00) ( 1.0000e-006, 1.0000e+000) ( 1.0000e+000,0.00000E+00) ( 2.0480e+003,0.00000E+00)
+ ( 1.0000e+006,0.00000E+00) ( 0.0000e-003,0.00000E+00) ( 6.0000e-006,0.00000E+00) ( 4.0000e+006, 1.0000e+000) ( 4.0000e+000,0.00000E+00)
+
+ 1.0000e+000 1.0000e+000 2.0000e+000 1.0000e+000
+ 4
+(0.10000E+01,0.00000E+00) (0.00000E+00,0.10000E+05) (0.00000E+00,0.10000E+05)
+(0.00000E+00,0.10000E+05)
+(-.20000E+05,0.00000E+00) (0.30000E+01,0.00000E+00) (0.20000E-02,0.00000E+00)
+(0.30000E-02,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.20000E+01,0.10000E+01) (0.00000E+00,0.00000E+00)
+(-.30000E+05,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+05,0.00000E+00)
+(0.00000E+00,0.00000E+00)
+ 1 4
+ ( 1.0000e+000,0.00000E+00) ( 0.0000e-003,10.0000e+003) (0.0000e-003,10.0000e+003) (0.0000e-003,5.0000e+003) (250.0000e-003,0.00000E+00)
+ (-20.0000e+003,0.00000E+00) ( 3.0000e+000,0.00000E+00) ( 2.0000e-003,0.00000E+00) ( 1.5000e-003,0.00000E+00) ( 16.0000e+000,0.00000E+00)
+ ( 0.0000e-003,0.00000E+00) ( 2.0000e+000, 1.0000e+000) ( 0.0000e-003,0.00000E+00) (-15.0000e+003,0.00000E+00) ( 2.0480e+003,0.00000E+00)
+ ( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00) ( 20.0000e+003,0.00000E+00) ( 0.0000e-003,0.00000E+00) ( 4.0000e+000,0.00000E+00)
+
+ 1.0000e+000 1.0000e+000 1.0000e+000 500.0000e-003
+
+ 5
+(0.10000E+01,0.00000E+00) (0.51200E+03,0.00000E+00) (0.40960E+04,0.00000E+00)
+(0.32768E+05,0.00000E+00) (2.62144E+05,0.00000E+00)
+(0.80000E+01,0.80000E+01) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.80000E+01,0.80000E+01) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.80000E+01,0.80000E+01)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.80000E+01,0.80000E+01) (0.00000E+00,0.00000E+00)
+
+ 1 5
+ ( 1.0000e+000,0.00000E+00) ( 64.0000e+000,0.00000E+00) ( 64.0000e+000,0.00000E+00)
+( 64.0000e+000,0.00000E+00) ( 64.0000e+000,0.00000E+00)
+ ( 64.0000e+000,64.0000e+000) ( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00)
+( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00)
+ ( 0.0000e-003,0.00000E+00) ( 64.0000e+000,64.0000e+000) ( 0.0000e-003,0.00000E+00)
+( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00)
+ ( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00) ( 64.0000e+000,64.0000e+000)
+( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00)
+ ( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00) ( 0.0000e-003,0.00000E+00)
+( 64.0000e+000,64.0000e+000) ( 0.0000e-003,0.00000E+00)
+
+ 128.0000e+000 16.0000e+000 2.0000e+000 250.0000e-003 31.2500e-003
+
+ 6
+(0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00)
+(0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01)
+(0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00)
+(0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01)
+(0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01)
+(0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00)
+(0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01)
+(0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01) (0.00000E+00,0.00000E+00)
+(0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01)
+
+ 2 5
+(0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01)
+(0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01)
+(0.00000E+00,0.00000E+00) (0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01)
+(0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01)
+(0.00000E+00,0.00000E+00) (0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01)
+(0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01)
+(0.00000E+00,0.00000E+00) (0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01)
+(0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01)
+(0.00000E+00,0.00000E+00) (0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01)
+(0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01) (0.10000E+01,0.10000E+01)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+01,0.10000E+01)
+
+ 0.30000E+01 0.10000E+01 0.10000E+01 0.10000E+01 0.10000E+01 0.40000E+01
+
+ 7
+(0.60000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.10000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.40000E+01,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.25000E-03,0.00000E+00) (0.12500E-01,0.00000E+00) (0.20000E-01,0.00000E+00)
+(0.12500E+00,0.00000E+00)
+(0.10000E+01,0.00000E+00) (0.12800E+03,0.00000E+00) (0.64000E+02,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (-.20000E+01,0.00000E+00)
+(0.16000E+02,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.16384E+05,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.10000E+01,0.00000E+00) (-.40000E+03,0.00000E+00) (0.25600E+03,0.00000E+00)
+(-.40000E+04,0.00000E+00)
+(-.20000E+01,0.00000E+00) (-.25600E+03,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.12500E-01,0.00000E+00) (0.20000E+01,0.00000E+00) (0.20000E+01,0.00000E+00)
+(0.32000E+02,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00)
+(0.00000E+00,0.00000E+00) (0.80000E+01,0.00000E+00) (0.00000E+00,0.00000E+00)
+(0.40000E-02,0.00000E+00) (0.12500E+00,0.00000E+00) (-.20000E+00,0.00000E+00)
+(0.30000E+01,0.00000E+00)
+
+ 2 5
+ (6.4000E+01,0.00000E+00) (2.5000E-01,0.00000E+00) (5.00000E-01,0.00000E+00)
+ (0.0000E+00,0.00000E+00) (0.0000E+00,0.00000E+00) (1.0000E+00,0.00000E+00)
+ (-2.0000E+00,0.00000E+00)
+ (0.0000E+00,0.00000E+00) (4.0000E+00,0.00000E+00) (2.00000E+00,0.00000E+00)
+ (4.0960E+00,0.00000E+00) (1.6000E+00,0.00000E+00) (0.0000E+00,0.00000E+00)
+ (1.0240E+01,0.00000E+00)
+ (0.0000E+00,0.00000E+00) (5.0000E-01,0.00000E+00) (3.00000E+00,0.00000E+00)
+ (4.0960E+00,0.00000E+00) (1.0000E+00,0.00000E+00) (0.0000E+00,0.00000E+00)
+ (-6.4000E+00,0.00000E+00)
+ (0.0000E+00,0.00000E+00) (1.0000E+00,0.00000E+00) (-3.90625E+00,0.00000E+00)
+ (1.0000E+00,0.00000E+00) (-3.1250E+00,0.00000E+00) (0.0000E+00,0.00000E+00)
+ (8.0000E+00,0.00000E+00)
+ (0.0000E+00,0.00000E+00) (-2.0000E+00,0.00000E+00) (4.00000E+00,0.00000E+00)
+ (1.6000E+00,0.00000E+00) (2.0000E+00,0.00000E+00) (-8.0000E+00,0.00000E+00)
+ (8.0000E+00,0.00000E+00)
+ (0.0000E+00,0.00000E+00) (0.0000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+ (0.0000E+00,0.00000E+00) (0.0000E+00,0.00000E+00) (6.0000E+00,0.00000E+00)
+ (1.0000E+00,0.00000E+00)
+ (0.0000E+00,0.00000E+00) (0.0000E+00,0.00000E+00) (0.00000E+00,0.00000E+00)
+ (0.0000E+00,0.00000E+00) (0.0000E+00,0.00000E+00) (0.0000E+00,0.00000E+00)
+ (0.0000E+00,0.00000E+00)
+
+ 3.0000E+00 1.953125E-03 3.1250E-02 3.2000E+01 2.5000E-01 1.0000E+00 6.0000E+00
+
+ 5
+(0.10000E+04,0.00000E+00) (0.20000E+01,0.00000E+00) (0.30000E+01,0.00000E+00)
+(0.40000E+01,0.00000E+00) (0.50000E+06,0.00000E+00)
+(0.90000E+01,0.00000E+00) (0.00000E+00,0.00000E+00) (0.20000E-03,0.00000E+00)
+(0.10000E+01,0.00000E+00) (0.30000E+01,0.00000E+00)
+(0.00000E+00,0.00000E+00) (-.30000E+03,0.00000E+00) (0.20000E+01,0.00000E+00)
+(0.10000E+01,0.00000E+00) (0.10000E+01,0.00000E+00)
+(0.90000E+01,0.00000E+00) (0.20000E-02,0.00000E+00) (0.10000E+01,0.00000E+00)
+(0.10000E+01,0.00000E+00) (-.10000E+04,0.00000E+00)
+(0.60000E+01,0.00000E+00) (0.20000E+03,0.00000E+00) (0.10000E+01,0.00000E+00)
+(0.60000E+03,0.00000E+00) (0.30000E+01,0.00000E+00)
+
+ 1 5
+ (1.0000E+03,0.00000E+00) (3.1250E-02,0.00000E+00) (3.7500E-01,0.00000E+00)
+(6.2500E-02,0.00000E+00) (3.90625E+03,0.00000E+00)
+ (5.7600E+02,0.00000E+00) (0.0000E+00,0.00000E+00) (1.6000E-03,0.00000E+00)
+(1.0000E+00,0.00000E+00) (1.5000E+00,0.00000E+00)
+ (0.0000E+00,0.00000E+00) (-3.7500E+01,0.00000E+00) (2.0000E+00,0.00000E+00)
+(1.2500E-01,0.00000E+00) (6.2500E-02,0.00000E+00)
+ (5.7600E+02,0.00000E+00) (2.0000E-03,0.00000E+00) (8.0000E+00,0.00000E+00)
+(1.0000E+00,0.00000E+00) (-5.0000E+02,0.00000E+00)
+ (7.6800E+02,0.00000E+00) (4.0000E+02,0.00000E+00) (1.6000E+01,0.00000E+00)
+(1.2000E+03,0.00000E+00) (3.0000E+00,0.00000E+00)
+
+ 1.2800E+02 2.0000E+00 1.6000E+01 2.0000E+00 1.0000E+00
+
+ 5
+(1.0000E+00,0.0000E+00) (1.0000E+15,0.0000E+00) (0.0000E+00,0.0000E+00)
+(0.0000E+00,0.0000E+00) (0.0000E+00,0.0000E+00)
+(1.0000E-15,0.0000E+00) (1.0000E+00,0.0000E+00) (1.0000E+15,0.0000E+00)
+(0.0000E+00,0.0000E+00) (0.0000E+00,0.0000E+00)
+(0.0000E+00,0.0000E+00) (1.0000E-15,0.0000E+00) (1.0000E+00,0.0000E+00)
+(1.0000E+15,0.0000E+00) (0.0000E+00,0.0000E+00)
+(0.0000E+00,0.0000E+00) (0.0000E+00,0.0000E+00) (1.0000E-15,0.0000E+00)
+(1.0000E+00,0.0000E+00) (1.0000E+15,0.0000E+00)
+(0.0000E+00,0.0000E+00) (0.0000E+00,0.0000E+00) (0.0000E+00,0.0000E+00)
+(1.0000E-15,0.0000E+00) (1.0000E+00,0.0000E+00)
+
+ 1 5
+
+(1.0000000e+00,0.0000000e+00) (7.1054273e+00,0.0000000e+00) (0.0000000e+00,0.0000000e+00)
+(0.0000000e+00,0.0000000e+00) (0.0000000e+00,0.0000000e+00)
+(1.4073749e-01,0.0000000e+00) (1.0000000e+00,0.0000000e+00) (3.5527136e+00,0.0000000e+00)
+(0.0000000e+00,0.0000000e+00) (0.0000000e+00,0.0000000e+00)
+(0.0000000e+00,0.0000000e+00) (2.8147498e-01,0.0000000e+00) (1.0000000e+00,0.0000000e+00)
+(1.7763568e+00,0.0000000e+00) (0.0000000e+00,0.0000000e+00)
+(0.0000000e+00,0.0000000e+00) (0.0000000e+00,0.0000000e+00) (5.6294996e-01,0.0000000e+00)
+(1.0000000e+00,0.0000000e+00) (8.8817841e-01,0.0000000e+00)
+(0.0000000e+00,0.0000000e+00) (0.0000000e+00,0.0000000e+00) (0.0000000e+00,0.0000000e+00)
+(1.1258999e+00,0.0000000e+00) (1.0000000e+00,0.0000000e+00)
+
+5.0706024e+30 3.6028797e+16 1.2800000e+02 2.2737368e-13 2.0194839e-28
+
+0
diff --git a/TESTING/cbb.in b/TESTING/cbb.in
new file mode 100644
index 0000000..2aad1aa
--- /dev/null
+++ b/TESTING/cbb.in
@@ -0,0 +1,12 @@
+CBB: Data file for testing banded Singular Value Decomposition routines
+20 Number of values of M
+0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 10 10 16 16 Values of M
+0 1 2 3 0 1 2 3 0 1 2 3 0 1 2 3 10 16 10 16 Values of N
+5 Number of values of K
+0 1 2 3 16 Values of K (band width)
+2 Number of values of NRHS
+1 2 Values of NRHS
+20.0 Threshold value
+F Put T to test the error exits
+1 Code to interpret the seed
+CBB 15
diff --git a/TESTING/cec.in b/TESTING/cec.in
new file mode 100644
index 0000000..622f05f
--- /dev/null
+++ b/TESTING/cec.in
@@ -0,0 +1,517 @@
+CEC Key indicating type of input
+20.0E0 Threshold value for test ratios
+ 1 1
+( 2.0E0, 0.0E0)
+( 2.0E0, 0.0E0)
+( 1.0E0, 1.0E0)
+ 1 3
+( 1.0E0, 1.0E0)
+( 1.0E0, 1.0E0) ( 1.0E0, 1.0E0) ( 1.0E0, 1.0E0)
+( 0.0E0, 0.0E0) ( 1.5E0, 1.5E0) ( 2.0E0, 1.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 2.0E0, 2.0E0)
+( 2.0E0, 1.0E0) ( 2.0E0, 1.0E0) ( 9.0E0, 0.0E0)
+ 4 4
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 2.0E0, 0.0E0) ( 1.0E0, 3.0E0)
+( 2.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 8.0E0, 9.0E0) ( 2.0E0, 2.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 7.0E0) ( 0.0E0, 0.0E0) ( 2.0E0, 0.0E0) ( 1.0E0, 0.0E0)
+ 4 4
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+ 4 4
+( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0)
+( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0)
+( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0)
+ 4 4
+( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0)
+(-1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) (-1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) (-1.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) (-1.0E0, 0.0E0)
+( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0)
+ 4 4
+( 1.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 0.0E0, 1.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 1.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0)
+(-1.0E0, 1.0E0) ( 0.0E0, 1.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 1.0E0)
+( 0.0E0, 0.0E0) (-1.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) (-1.0E0, 0.0E0) ( 0.0E0, 1.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) (-1.0E0, 0.0E0)
+( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0)
+ 4 3
+( 0.0621E0, 0.7054E0) ( 0.1062E0, 0.0503E0) ( 0.6553E0, 0.5876E0) ( 0.2560E0, 0.8642E0)
+( 0.0E0, 0.0E0) ( 0.2640E0, 0.5782E0) ( 0.9700E0, 0.7256E0) ( 0.5598E0, 0.1943E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0380E0, 0.2849E0) ( 0.9166E0, 0.0580E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.1402E0, 0.6908E0)
+( 0.6769E0, 0.6219E0) ( 0.5965E0, 0.0505E0) ( 0.7361E0, 0.5069E0)
+( 0.0E0, 0.0E0) ( 0.0726E0, 0.7195E0) ( 0.2531E0, 0.9764E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.3481E0, 0.5602E0)
+( 0.9110E0, 0.7001E0) ( 0.1821E0, 0.5406E0) ( 0.8879E0, 0.5813E0)
+( 0.0728E0, 0.5887E0) ( 0.3271E0, 0.5647E0) ( 0.3793E0, 0.1667E0)
+( 0.1729E0, 0.6041E0) ( 0.9368E0, 0.3514E0) ( 0.8149E0, 0.3535E0)
+( 0.3785E0, 0.7924E0) ( 0.6588E0, 0.8646E0) ( 0.1353E0, 0.8362E0)
+ 6 5
+( 3.0E0, 5.0E0) ( 3.0E0, 22.0E0) ( 2.0E0, 3.0E0) ( 2.0E0, 3.0E0)
+( 3.0E0, 3.0E0) (311.E0, 2.0E0)
+( 0.0E0, 0.0E0) (-3.0E0, 5.0E0) ( 3.0E0, 2.0E0) ( 2.0E0, 3.0E0)
+( 2.0E0, 3.0E0) (11.0E0, 2.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 3.0E0, 2.0E0) ( 2.0E0, 3.0E0)
+( 2.0E0, 3.0E0) ( 1.0E0, -2.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) (-33.E0, 2.0E0)
+( 2.0E0, 3.0E0) ( 1.0E0, 2.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+(-22.E0, 3.0E0) ( 1.0E0, 2.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 2.0E0, -3.0E0)
+( 9.0E0, 0.0E0) ( 2.0E0, 0.0E0) (-12.E0, 0.0E0) ( 1.0E0, 0.0E0)
+( 3.0E0, 0.0E0)
+( 0.0E0, 0.0E0) (-19.E0, 0.0E0) ( 12.E0, 0.0E0) ( 1.0E0, 0.0E0)
+( 3.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 98.E0, 0.0E0) (11.0E0, 0.0E0)
+( 3.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) (13.0E0, 0.0E0)
+(11.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+(13.0E0, 0.0E0)
+( 3.0E0, -5.0E0) ( 3.0E0, 22.0E0) ( 2.0E0, 31.0E0) ( 2.0E0, 3.0E0)
+( 3.0E0, 3.0E0)
+( 0.0E0, 0.0E0) (-3.0E0, 5.0E0) ( 33.E0, 22.0E0) ( 2.0E0, 3.0E0)
+(-2.0E0, 3.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) (-3.0E0, 2.0E0) ( 2.0E0, 3.0E0)
+( 2.0E0, -3.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) (-33.E0, 2.0E0)
+( 2.0E0, 3.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+(-22.E0, 3.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, -2.0E0)
+ 0 0
+ 1 1 1
+( 0.0E0, 0.0E0)
+ 3 1 3
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+ 4 4 1
+( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0)
+ 4 4 1
+( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 2.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 3.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 4.0E0, 0.0E0)
+ 4 1 4
+(12.0E0, 0.0E0) ( 0.0E0, 20.0E0) (-2.0E0, 0.0E0) (10.0E0, 0.0E0)
+( 0.0E0, 0.0E0) (20.0E0, 0.0E0) ( 2.0E0, -1.0E0) ( 0.0E0, 0.9E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 3.0E0, 0.0E0) ( 0.8E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 8.0E0, 0.0E0)
+ 5 5 1
+( 1.0E0, 1.0E0) ( 2.0E0, -1.0E0) ( 2.0E0, -3.0E0) (12.0E0, 3.0E0)
+( 2.0E0, 39.0E0)
+( 0.0E0, 0.0E0) ( 2.0E0, 3.0E0) ( 2.0E0, 3.0E0) ( 2.0E0, 13.0E0)
+( 2.0E0, 31.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) (-2.0E0, 3.0E0) ( 2.0E0, 3.0E0)
+(12.0E0, 3.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 2.0E0, -3.0E0)
+(-2.0E0, 3.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 2.0E0, 3.0E0)
+ 4 4 1
+( 0.0621E0, 0.7054E0) ( 0.1062E0, 0.0503E0) ( 0.6553E0, 0.5876E0) ( 0.2560E0, 0.8642E0)
+( 0.0E0, 0.0E0) ( 0.2640E0, 0.5782E0) ( 0.9700E0, 0.7256E0) ( 0.5598E0, 0.1943E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0380E0, 0.2849E0) ( 0.9166E0, 0.0580E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.1402E0, 0.6908E0)
+ 6 5 3
+( 10.0E0, 1.0E0) ( 10.0E0, 0.0E0) ( 30.0E0, 0.0E0) ( 0.0E0, 1.0E0)
+( 10.0E0, 1.0E0) ( 10.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 20.0E0, 1.0E0) ( 30.0E0, 0.0E0) ( 20.0E0, 1.0E0)
+( 0.0E0,-1.0E0) ( 0.0E0,-10.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 30.0E0, 1.0E0) ( 0.0E0, 0.0E0)
+( 2.0E0, 0.0E0) ( 0.0E0, 20.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 40.0E0, 1.0E0)
+( 0.0E0,-10.0E0) ( -30.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 50.0E0, 1.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 60.0E0, 1.0E0)
+ 0 0 0
+ 1 0
+( 0.0E0, 0.0E0)
+ 0.0E0 0.0E0 1.0E0 0.0E0
+ 1 0
+( 0.0E0, 1.0E0)
+ 0.0E0 1.0E0 1.0E0 1.0E0
+ 2 0
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+ 0.0E0 0.0E0 1.0E0 0.0E0
+ 0.0E0 0.0E0 1.0E0 0.0E0
+ 2 0
+( 3.0E0, 0.0E0) ( 2.0E0, 0.0E0)
+( 2.0E0, 0.0E0) ( 3.0E0, 0.0E0)
+ 1.0E0 0.0E0 1.0E0 4.0E0
+ 5.0E0 0.0E0 1.0E0 4.0E0
+ 2 0
+( 3.0E0, 0.0E0) ( 0.0E0, 2.0E0)
+( 0.0E0, 2.0E0) ( 3.0E0, 0.0E0)
+ 3.0E0 2.0E0 1.0E0 4.0E0
+ 3.0E0 -2.0E0 1.0E0 4.0E0
+ 5 0
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+ 0.0E0 0.0E0 1.0E0 0.0E0
+ 0.0E0 0.0E0 1.0E0 0.0E0
+ 0.0E0 0.0E0 1.0E0 0.0E0
+ 0.0E0 0.0E0 1.0E0 0.0E0
+ 0.0E0 0.0E0 1.0E0 0.0E0
+ 5 0
+( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0)
+ 1.0E0 0.0E0 1.0E0 0.0E0
+ 1.0E0 0.0E0 1.0E0 0.0E0
+ 1.0E0 0.0E0 1.0E0 0.0E0
+ 1.0E0 0.0E0 1.0E0 0.0E0
+ 1.0E0 0.0E0 1.0E0 0.0E0
+ 5 0
+( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 2.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 3.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 4.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 5.0E0, 0.0E0)
+ 1.0E0 0.0E0 1.0E0 1.0E0
+ 2.0E0 0.0E0 1.0E0 1.0E0
+ 3.0E0 0.0E0 1.0E0 1.0E0
+ 4.0E0 0.0E0 1.0E0 1.0E0
+ 5.0E0 0.0E0 1.0E0 1.0E0
+ 6 0
+( 0.0E0, 1.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 1.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 1.0E0)
+ 0.0E0 1.0E0 1.1921E-07 0.0E0
+ 0.0E0 1.0E0 2.4074E-35 0.0E0
+ 0.0E0 1.0E0 2.4074E-35 0.0E0
+ 0.0E0 1.0E0 2.4074E-35 0.0E0
+ 0.0E0 1.0E0 2.4074E-35 0.0E0
+ 0.0E0 1.0E0 1.1921E-07 0.0E0
+ 6 0
+( 0.0E0, 1.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 1.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 1.0E0)
+ 0.0E0 1.0E0 1.1921E-07 0.0E0
+ 0.0E0 1.0E0 2.4074E-35 0.0E0
+ 0.0E0 1.0E0 2.4074E-35 0.0E0
+ 0.0E0 1.0E0 2.4074E-35 0.0E0
+ 0.0E0 1.0E0 2.4074E-35 0.0E0
+ 0.0E0 1.0E0 1.1921E-07 0.0E0
+ 4 0
+( 9.4480E-01, 1.0E0) ( 6.7670E-01, 1.0E0) ( 6.9080E-01, 1.0E0) ( 5.9650E-01, 1.0E0)
+( 5.8760E-01, 1.0E0) ( 8.6420E-01, 1.0E0) ( 6.7690E-01, 1.0E0) ( 7.2600E-02, 1.0E0)
+( 7.2560E-01, 1.0E0) ( 1.9430E-01, 1.0E0) ( 9.6870E-01, 1.0E0) ( 2.8310E-01, 1.0E0)
+( 2.8490E-01, 1.0E0) ( 5.8000E-02, 1.0E0) ( 4.8450E-01, 1.0E0) ( 7.3610E-01, 1.0E0)
+ 2.6014E-01 -1.7813E-01 8.5279E-01 3.2881E-01
+ 2.8961E-01 2.0772E-01 8.4871E-01 3.2358E-01
+ 7.3990E-01 -4.6522E-04 9.7398E-01 3.4994E-01
+ 2.2242E+00 3.9709E+00 9.8325E-01 4.1429E+00
+ 4 0
+( 2.1130E-01, 9.9330E-01) ( 8.0960E-01, 4.2370E-01) ( 4.8320E-01, 1.1670E-01) ( 6.5380E-01, 4.9430E-01)
+( 8.2400E-02, 8.3600E-01) ( 8.4740E-01, 2.6130E-01) ( 6.1350E-01, 6.2500E-01) ( 4.8990E-01, 3.6500E-02)
+( 7.5990E-01, 7.4690E-01) ( 4.5240E-01, 2.4030E-01) ( 2.7490E-01, 5.5100E-01) ( 7.7410E-01, 2.2600E-01)
+( 8.7000E-03, 3.7800E-02) ( 8.0750E-01, 3.4050E-01) ( 8.8070E-01, 3.5500E-01) ( 9.6260E-01, 8.1590E-01)
+ -6.2157E-01 6.0607E-01 8.7533E-01 8.1980E-01
+ 2.8890E-01 -2.6354E-01 8.2538E-01 8.1086E-01
+ 3.8017E-01 5.4217E-01 7.4771E-01 7.0323E-01
+ 2.2487E+00 1.7368E+00 9.2372E-01 2.2178E+00
+ 3 0
+( 1.0E0, 2.0E0) ( 3.0E0, 4.0E0) ( 2.1E1, 2.2E1)
+( 4.3E1, 4.4E1) ( 1.3E1, 1.4E1) ( 1.5E1, 1.6E1)
+( 5.0E0, 6.0E0) ( 7.0E0, 8.0E0) ( 2.5E1, 2.6E1)
+ -7.4775E+00 6.8803E+00 3.9550E-01 1.6583E+01
+ 6.7009E+00 -7.8760E+00 3.9828E-01 1.6312E+01
+ 3.9777E+01 4.2996E+01 7.9686E-01 3.7399E+01
+ 4 0
+( 5.0E0, 9.0E0) ( 5.0E0, 5.0E0) (-6.0E0,-6.0E0) (-7.0E0,-7.0E0)
+( 3.0E0, 3.0E0) ( 6.0E0, 1.0E1) (-5.0E0,-5.0E0) (-6.0E0,-6.0E0)
+( 2.0E0, 2.0E0) ( 3.0E0, 3.0E0) (-1.0E0, 3.0E0) (-5.0E0,-5.0E0)
+( 1.0E0, 1.0E0) ( 2.0E0, 2.0E0) (-3.0E0,-3.0E0) ( 0.0E0, 4.0E0)
+ 1.0E0 5.0E0 2.1822E-01 7.4651E-01
+ 2.0E0 6.0E0 2.1822E-01 3.0893E-01
+ 3.0E0 7.0E0 2.1822E-01 1.8315E-01
+ 4.0E0 8.0E0 2.1822E-01 6.6350E-01
+ 4 0
+( 3.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 2.0E0)
+( 1.0E0, 0.0E0) ( 3.0E0, 0.0E0) ( 0.0E0,-2.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 2.0E0) ( 1.0E0, 0.0E0) ( 1.0E0, 0.0E0)
+( 0.0E0,-2.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 1.0E0, 0.0E0)
+ -8.2843E-01 1.6979E-07 1.0E0 8.2843E-01
+ 4.1744E-07 7.1526E-08 1.0E0 8.2843E-01
+ 4.0E0 1.6690E-07 1.0E0 8.2843E-01
+ 4.8284E+00 6.8633E-08 1.0E0 8.2843E-01
+ 4 0
+( 7.0E0, 0.0E0) ( 3.0E0, 0.0E0) ( 1.0E0, 2.0E0) (-1.0E0, 2.0E0)
+( 3.0E0, 0.0E0) ( 7.0E0, 0.0E0) ( 1.0E0,-2.0E0) (-1.0E0,-2.0E0)
+( 1.0E0,-2.0E0) ( 1.0E0, 2.0E0) ( 7.0E0, 0.0E0) (-3.0E0, 0.0E0)
+(-1.0E0,-2.0E0) (-2.0E0, 2.0E0) (-3.0E0, 0.0E0) ( 7.0E0, 0.0E0)
+ -8.0767E-03 -2.5211E-01 9.9864E-01 7.7961E+00
+ 7.7723E+00 2.4349E-01 7.0272E-01 3.3337E-01
+ 8.0E0 -3.4273E-07 7.0711E-01 3.3337E-01
+ 1.2236E+01 8.6188E-03 9.9021E-01 3.9429E+00
+ 5 0
+( 1.0E0, 2.0E0) ( 3.0E0, 4.0E0) ( 2.1E1, 2.2E1) ( 2.3E1, 2.4E1) ( 4.1E1, 4.2E1)
+( 4.3E1, 4.4E1) ( 1.3E1, 1.4E1) ( 1.5E1, 1.6E1) ( 3.3E1, 3.4E1) ( 3.5E1, 3.6E1)
+( 5.0E0, 6.0E0) ( 7.0E0, 8.0E0) ( 2.5E1, 2.6E1) ( 2.7E1, 2.8E1) ( 4.5E1, 4.6E1)
+( 4.7E1, 4.8E1) ( 1.7E1, 1.8E1) ( 1.9E1, 2.0E1) ( 3.7E1, 3.8E1) ( 3.9E1, 4.0E1)
+( 9.0E0, 1.0E1) ( 1.1E1, 1.2E1) ( 2.9E1, 3.0E1) ( 3.1E1, 3.2E1) ( 4.9E1, 5.0E1)
+ -9.4600E+00 7.2802E+00 3.1053E-01 1.1937E+01
+ -7.7912E-06 -1.2743E-05 2.9408E-01 1.6030E-05
+ -7.3042E-06 3.2789E-06 7.2259E-01 6.7794E-06
+ 7.0733E+00 -9.5584E+00 3.0911E-01 1.1891E+01
+ 1.2739E+02 1.3228E+02 9.2770E-01 1.2111E+02
+ 3 0
+( 1.0E0, 1.0E0) (-1.0E0,-1.0E0) ( 2.0E0, 2.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 2.0E0, 0.0E0)
+( 0.0E0, 0.0E0) (-1.0E0, 0.0E0) ( 3.0E0, 1.0E0)
+ 1.0E0 1.0E0 3.0151E-01 0.0E0
+ 1.0E0 1.0E0 3.1623E-01 0.0E0
+ 2.0E0 1.0E0 2.2361E-01 1.0E0
+ 4 1
+(-4.0E0,-2.0E0) (-5.0E0,-6.0E0) (-2.0E0,-6.0E0) ( 0.0E0,-2.0E0)
+( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+-9.9883E-01 -1.0006E+00 1.3180E-04 2.4106E-04
+-1.0012E+00 -9.9945E-01 1.3140E-04 2.4041E-04
+ -9.9947E-01 -6.8325E-04 1.3989E-04 8.7487E-05
+-1.0005E+00 6.8556E-04 1.4010E-04 8.7750E-05
+ 7 0
+( 2.0E0, 4.0E0) ( 1.0E0, 1.0E0) ( 6.0E0, 2.0E0) ( 3.0E0, 3.0E0) ( 5.0E0, 5.0E0) ( 2.0E0, 6.0E0) ( 1.0E0, 1.0E0)
+( 1.0E0, 2.0E0) ( 1.0E0, 3.0E0) ( 3.0E0, 1.0E0) ( 5.0E0,-4.0E0) ( 1.0E0, 1.0E0) ( 7.0E0, 2.0E0) ( 2.0E0, 3.0E0)
+( 0.0E0, 0.0E0) ( 3.0E0,-2.0E0) ( 1.0E0, 1.0E0) ( 6.0E0, 3.0E0) ( 2.0E0, 1.0E0) ( 1.0E0, 4.0E0) ( 2.0E0, 1.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 2.0E0, 3.0E0) ( 3.0E0, 1.0E0) ( 1.0E0, 2.0E0) ( 2.0E0, 2.0E0) ( 3.0E0, 1.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 2.0E0,-1.0E0) ( 2.0E0, 2.0E0) ( 3.0E0, 1.0E0) ( 1.0E0, 3.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0,-1.0E0) ( 2.0E0, 1.0E0) ( 2.0E0, 2.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 2.0E0,-2.0E0) ( 1.0E0, 1.0E0)
+ -2.7081E+00 -2.8029E+00 6.9734E-01 3.9279E+00
+-1.1478E+00 8.0176E-01 6.5772E-01 9.4243E-01
+ -8.0109E-01 4.9694E+00 4.6751E-01 1.3779E+00
+ 9.9492E-01 3.1688E+00 3.5095E-01 5.9845E-01
+ 2.0809E+00 1.9341E+00 4.9042E-01 3.9035E-01
+ 5.3138E+00 1.2242E+00 3.0213E-01 7.1268E-01
+ 8.2674E+00 3.7047E+00 2.8270E-01 3.2849E+00
+ 5 1
+( 0.0E0, 5.0E0) ( 1.0E0, 2.0E0) ( 2.0E0, 3.0E0) (-3.0E0, 6.0E0) ( 6.0E0, 0.0E0)
+(-1.0E0, 2.0E0) ( 0.0E0, 6.0E0) ( 4.0E0, 5.0E0) (-3.0E0,-2.0E0) ( 5.0E0, 0.0E0)
+(-2.0E0, 3.0E0) (-4.0E0, 5.0E0) ( 0.0E0, 7.0E0) ( 3.0E0, 0.0E0) ( 2.0E0, 0.0E0)
+( 3.0E0, 6.0E0) ( 3.0E0,-2.0E0) (-3.0E0, 0.0E0) ( 0.0E0,-5.0E0) ( 2.0E0, 1.0E0)
+(-6.0E0, 0.0E0) (-5.0E0, 0.0E0) (-2.0E0, 0.0E0) (-2.0E0, 1.0E0) ( 0.0E0, 2.0E0)
+ -4.1735E-08 -1.0734E+01 1.0E0 7.7345E+00
+ -2.6397E-07 -2.9991E+00 1.0E0 4.5989E+00
+ 1.4565E-07 1.5998E+00 1.0E0 4.5989E+00
+ -4.4369E-07 9.3159E+00 1.0E0 7.7161E+00
+ 4.0937E-09 1.7817E+01 1.0E0 8.5013E+00
+ 3 0
+( 2.0E0, 0.0E0) ( 0.0E0,-1.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 1.0E0) ( 2.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 3.0E0, 0.0E0)
+ 1.0E0 0.0E0 1.0E0 2.0E0
+ 3.0E0 0.0E0 1.0E0 0.0E0
+ 3.0E0 0.0E0 1.0E0 0.0E0
+ 0 0
+ 1 1 0
+ 1
+( 0.0E0, 0.0E0)
+ 1.0E0 0.0E0
+ 1 1 0
+ 1
+( 1.0E0, 0.0E0)
+ 1.0E0 1.0E0
+ 5 3 0
+ 2 3 4
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+ 1.0E0 2.9582E-31
+ 5 3 0
+ 1 3 5
+( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0)
+ 1.0E0 1.1921E-07
+ 5 2 0
+ 2 4
+( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 2.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 3.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 4.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 5.0E0, 0.0E0)
+ 1.0E0 1.0E0
+ 6 3 1
+ 3 4 6
+( 0.0E0, 1.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 1.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 1.0E0)
+ 4.0124E-36 3.2099E-36
+ 6 3 0
+ 1 3 5
+( 0.0E0, 1.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 1.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 1.0E0)
+ 4.0124E-36 3.2099E-36
+ 4 2 0
+ 3 4
+( 9.4480E-01, 1.0E0) ( 6.7670E-01, 1.0E0) ( 6.9080E-01, 1.0E0) ( 5.9650E-01, 1.0E0)
+( 5.8760E-01, 1.0E0) ( 8.6420E-01, 1.0E0) ( 6.7690E-01, 1.0E0) ( 7.2600E-02, 1.0E0)
+( 7.2560E-01, 1.0E0) ( 1.9430E-01, 1.0E0) ( 9.6870E-01, 1.0E0) ( 2.8310E-01, 1.0E0)
+( 2.8490E-01, 1.0E0) ( 5.8000E-02, 1.0E0) ( 4.8450E-01, 1.0E0) ( 7.3610E-01, 1.0E0)
+ 9.6350E-01 3.3122E-01
+ 4 2 0
+ 2 3
+( 2.1130E-01, 9.9330E-01) ( 8.0960E-01, 4.2370E-01) ( 4.8320E-01, 1.1670E-01) ( 6.5380E-01, 4.9430E-01)
+( 8.2400E-02, 8.3600E-01) ( 8.4740E-01, 2.6130E-01) ( 6.1350E-01, 6.2500E-01) ( 4.8990E-01, 3.6500E-02)
+( 7.5990E-01, 7.4690E-01) ( 4.5240E-01, 2.4030E-01) ( 2.7490E-01, 5.5100E-01) ( 7.7410E-01, 2.2600E-01)
+( 8.7000E-03, 3.7800E-02) ( 8.0750E-01, 3.4050E-01) ( 8.8070E-01, 3.5500E-01) ( 9.6260E-01, 8.1590E-01)
+ 8.4053E-01 7.4754E-01
+ 3 2 0
+ 2 3
+( 1.0E0, 2.0E0) ( 3.0E0, 4.0E0) ( 2.1E1, 2.2E1)
+( 4.3E1, 4.4E1) ( 1.3E1, 1.4E1) ( 1.5E1, 1.6E1)
+( 5.0E0, 6.0E0) ( 7.0E0, 8.0E0) ( 2.5E1, 2.6E1)
+ 3.9550E-01 2.0464E+01
+ 4 2 0
+ 1 3
+( 5.0E0, 9.0E0) ( 5.0E0, 5.0E0) (-6.0E0,-6.0E0) (-7.0E0,-7.0E0)
+( 3.0E0, 3.0E0) ( 6.0E0, 1.0E1) (-5.0E0,-5.0E0) (-6.0E0,-6.0E0)
+( 2.0E0, 2.0E0) ( 3.0E0, 3.0E0) (-1.0E0, 3.0E0) (-5.0E0,-5.0E0)
+( 1.0E0, 1.0E0) ( 2.0E0, 2.0E0) (-3.0E0,-3.0E0) ( 0.0E0, 4.0E0)
+ 3.3333E-01 1.2569E-01
+ 4 3 0
+ 1 3 4
+( 3.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 2.0E0)
+( 1.0E0, 0.0E0) ( 3.0E0, 0.0E0) ( 0.0E0,-2.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 2.0E0) ( 1.0E0, 0.0E0) ( 1.0E0, 0.0E0)
+( 0.0E0,-2.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 1.0E0, 0.0E0)
+ 1.0E0 8.2843E-01
+ 4 2 0
+ 2 3
+( 7.0E0, 0.0E0) ( 3.0E0, 0.0E0) ( 1.0E0, 2.0E0) (-1.0E0, 2.0E0)
+( 3.0E0, 0.0E0) ( 7.0E0, 0.0E0) ( 1.0E0,-2.0E0) (-1.0E0,-2.0E0)
+( 1.0E0,-2.0E0) ( 1.0E0, 2.0E0) ( 7.0E0, 0.0E0) (-3.0E0, 0.0E0)
+(-1.0E0,-2.0E0) (-2.0E0, 2.0E0) (-3.0E0, 0.0E0) ( 7.0E0, 0.0E0)
+ 9.8985E-01 4.1447E+00
+ 5 2 1
+ 2 3
+( 1.0E0, 2.0E0) ( 3.0E0, 4.0E0) ( 2.1E1, 2.2E1) ( 2.3E1, 2.4E1) ( 4.1E1, 4.2E1)
+( 4.3E1, 4.4E1) ( 1.3E1, 1.4E1) ( 1.5E1, 1.6E1) ( 3.3E1, 3.4E1) ( 3.5E1, 3.6E1)
+( 5.0E0, 6.0E0) ( 7.0E0, 8.0E0) ( 2.5E1, 2.6E1) ( 2.7E1, 2.8E1) ( 4.5E1, 4.6E1)
+( 4.7E1, 4.8E1) ( 1.7E1, 1.8E1) ( 1.9E1, 2.0E1) ( 3.7E1, 3.8E1) ( 3.9E1, 4.0E1)
+( 9.0E0, 1.0E1) ( 1.1E1, 1.2E1) ( 2.9E1, 3.0E1) ( 3.1E1, 3.2E1) ( 4.9E1, 5.0E1)
+ 3.1088E-01 4.6912E+00
+ 3 2 0
+ 1 2
+( 1.0E0, 1.0E0) (-1.0E0,-1.0E0) ( 2.0E0, 2.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 2.0E0, 0.0E0)
+( 0.0E0, 0.0E0) (-1.0E0, 0.0E0) ( 3.0E0, 1.0E0)
+ 2.2361E-01 1.0E0
+ 4 2 1
+ 1 3
+(-4.0E0,-2.0E0) (-5.0E0,-6.0E0) (-2.0E0,-6.0E0) ( 0.0E0,-2.0E0)
+( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+ 7.2803E-05 1.1947E-04
+ 7 4 0
+ 1 4 6 7
+( 2.0E0, 4.0E0) ( 1.0E0, 1.0E0) ( 6.0E0, 2.0E0) ( 3.0E0, 3.0E0) ( 5.0E0, 5.0E0) ( 2.0E0, 6.0E0) ( 1.0E0, 1.0E0)
+( 1.0E0, 2.0E0) ( 1.0E0, 3.0E0) ( 3.0E0, 1.0E0) ( 5.0E0,-4.0E0) ( 1.0E0, 1.0E0) ( 7.0E0, 2.0E0) ( 2.0E0, 3.0E0)
+( 0.0E0, 0.0E0) ( 3.0E0,-2.0E0) ( 1.0E0, 1.0E0) ( 6.0E0, 3.0E0) ( 2.0E0, 1.0E0) ( 1.0E0, 4.0E0) ( 2.0E0, 1.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 2.0E0, 3.0E0) ( 3.0E0, 1.0E0) ( 1.0E0, 2.0E0) ( 2.0E0, 2.0E0) ( 3.0E0, 1.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 2.0E0,-1.0E0) ( 2.0E0, 2.0E0) ( 3.0E0, 1.0E0) ( 1.0E0, 3.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 1.0E0,-1.0E0) ( 2.0E0, 1.0E0) ( 2.0E0, 2.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 2.0E0,-2.0E0) ( 1.0E0, 1.0E0)
+ 3.7241E-01 5.2080E-01
+ 5 3 1
+ 1 3 5
+( 0.0E0, 5.0E0) ( 1.0E0, 2.0E0) ( 2.0E0, 3.0E0) (-3.0E0, 6.0E0) ( 6.0E0, 0.0E0)
+(-1.0E0, 2.0E0) ( 0.0E0, 6.0E0) ( 4.0E0, 5.0E0) (-3.0E0,-2.0E0) ( 5.0E0, 0.0E0)
+(-2.0E0, 3.0E0) (-4.0E0, 5.0E0) ( 0.0E0, 7.0E0) ( 3.0E0, 0.0E0) ( 2.0E0, 0.0E0)
+( 3.0E0, 6.0E0) ( 3.0E0,-2.0E0) (-3.0E0, 0.0E0) ( 0.0E0,-5.0E0) ( 2.0E0, 1.0E0)
+(-6.0E0, 0.0E0) (-5.0E0, 0.0E0) (-2.0E0, 0.0E0) (-2.0E0, 1.0E0) ( 0.0E0, 2.0E0)
+ 1.0E0 4.5989E+00
+ 8 4 1
+ 1 2 3 4
+( 0.0E0, 1.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 1.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 2.0E0) ( 2.0E0, 0.0E0) ( 0.0E0, 2.0E0) ( 2.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 1.0E0, 0.0E0) ( 0.0E0, 3.0E0) ( 3.0E0, 0.0E0) ( 0.0E0, 3.0E0) ( 3.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 1.0E0) ( 0.0E0, 4.0E0) ( 4.0E0, 0.0E0) ( 0.0E0, 4.0E0) ( 4.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 9.5E-1) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 9.5E-1) ( 1.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 9.5E-1) ( 1.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 0.0E0, 9.5E-1)
+ 9.5269E-12 2.9360E-11
+ 3 2 0
+ 2 3
+( 2.0E0, 0.0E0) ( 0.0E0,-1.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 1.0E0) ( 2.0E0, 0.0E0) ( 0.0E0, 0.0E0)
+( 0.0E0, 0.0E0) ( 0.0E0, 0.0E0) ( 3.0E0, 0.0E0)
+ 1.0E0 2.0E0
+ 0 0 0
diff --git a/TESTING/ced.in b/TESTING/ced.in
new file mode 100644
index 0000000..dde30fa
--- /dev/null
+++ b/TESTING/ced.in
@@ -0,0 +1,1023 @@
+CES Data for the Complex Nonsymmetric Schur Form Driver
+6 Number of matrix dimensions
+0 1 2 3 5 10 20 Matrix dimensions
+3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
+20.0 Threshold for test ratios
+T
+2 Read another line with random number generate seed
+2518 3899 995 397 Seed for random number generator
+CES 21 Use all matrix types
+CEV Data for the Complex Nonsymmetric Eigenvalue Driver
+6 Number of matrix dimensions
+0 1 2 3 5 10 20 Matrix dimensions
+3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
+20.0 Threshold for test ratios
+T
+2 Read another line with random number generate seed
+2518 3899 995 397 Seed for random number generator
+CEV 21 Use all matrix types
+CSX Data for the Complex Nonsymmetric Schur Form Expert Driver
+6 Number of matrix dimensions
+0 1 2 3 5 10 20 Matrix dimensions
+3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
+20.0 Threshold for test ratios
+T
+2 Read another line with random number generate seed
+2518 3899 995 397 Seed for random number generator
+CSX 21 Use all matrix types
+ 1 1 0
+ 1
+( 0.0000E+00, 0.0000E+00)
+ 1.0000E+00 0.0000E+00
+ 1 1 0
+ 1
+( 1.0000E+00, 0.0000E+00)
+ 1.0000E+00 1.0000E+00
+ 5 3 0
+ 2 3 4
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+ 1.0000E+00 2.9582E-31
+ 5 3 0
+ 1 3 5
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+ 1.0000E+00 1.0000E+00
+ 5 2 0
+ 2 4
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 2.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 3.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 4.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 5.0000E+00, 0.0000E+00)
+ 1.0000E+00 1.0000E+00
+ 6 3 1
+ 3 4 6
+( 0.0000E+00, 1.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+ 1.0000E+00 2.0000E+00
+ 6 3 0
+ 1 3 5
+( 0.0000E+00, 1.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+ 1.0000E+00 2.0000E+00
+ 4 2 0
+ 3 4
+( 9.4480E-01, 1.0000E+00)
+( 6.7670E-01, 1.0000E+00)
+( 6.9080E-01, 1.0000E+00)
+( 5.9650E-01, 1.0000E+00)
+( 5.8760E-01, 1.0000E+00)
+( 8.6420E-01, 1.0000E+00)
+( 6.7690E-01, 1.0000E+00)
+( 7.2600E-02, 1.0000E+00)
+( 7.2560E-01, 1.0000E+00)
+( 1.9430E-01, 1.0000E+00)
+( 9.6870E-01, 1.0000E+00)
+( 2.8310E-01, 1.0000E+00)
+( 2.8490E-01, 1.0000E+00)
+( 5.8000E-02, 1.0000E+00)
+( 4.8450E-01, 1.0000E+00)
+( 7.3610E-01, 1.0000E+00)
+ 9.6350E-01 3.3122E-01
+ 4 2 0
+ 2 3
+( 2.1130E-01, 9.9330E-01)
+( 8.0960E-01, 4.2370E-01)
+( 4.8320E-01, 1.1670E-01)
+( 6.5380E-01, 4.9430E-01)
+( 8.2400E-02, 8.3600E-01)
+( 8.4740E-01, 2.6130E-01)
+( 6.1350E-01, 6.2500E-01)
+( 4.8990E-01, 3.6500E-02)
+( 7.5990E-01, 7.4690E-01)
+( 4.5240E-01, 2.4030E-01)
+( 2.7490E-01, 5.5100E-01)
+( 7.7410E-01, 2.2600E-01)
+( 8.7000E-03, 3.7800E-02)
+( 8.0750E-01, 3.4050E-01)
+( 8.8070E-01, 3.5500E-01)
+( 9.6260E-01, 8.1590E-01)
+ 8.4053E-01 7.4754E-01
+ 3 2 0
+ 2 3
+( 1.0000E+00, 2.0000E+00)
+( 3.0000E+00, 4.0000E+00)
+( 2.1000E+01, 2.2000E+01)
+( 4.3000E+01, 4.4000E+01)
+( 1.3000E+01, 1.4000E+01)
+( 1.5000E+01, 1.6000E+01)
+( 5.0000E+00, 6.0000E+00)
+( 7.0000E+00, 8.0000E+00)
+( 2.5000E+01, 2.6000E+01)
+ 3.9550E-01 2.0464E+01
+ 4 2 0
+ 1 3
+( 5.0000E+00, 9.0000E+00)
+( 5.0000E+00, 5.0000E+00)
+(-6.0000E+00,-6.0000E+00)
+(-7.0000E+00,-7.0000E+00)
+( 3.0000E+00, 3.0000E+00)
+( 6.0000E+00, 1.0000E+01)
+(-5.0000E+00,-5.0000E+00)
+(-6.0000E+00,-6.0000E+00)
+( 2.0000E+00, 2.0000E+00)
+( 3.0000E+00, 3.0000E+00)
+(-1.0000E+00, 3.0000E+00)
+(-5.0000E+00,-5.0000E+00)
+( 1.0000E+00, 1.0000E+00)
+( 2.0000E+00, 2.0000E+00)
+(-3.0000E+00,-3.0000E+00)
+( 0.0000E+00, 4.0000E+00)
+ 3.3333E-01 1.2569E-01
+ 4 3 0
+ 1 3 4
+( 3.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 2.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 3.0000E+00, 0.0000E+00)
+( 0.0000E+00,-2.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 2.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00,-2.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+ 1.0000E+00 8.2843E-01
+ 4 2 0
+ 2 3
+( 7.0000E+00, 0.0000E+00)
+( 3.0000E+00, 0.0000E+00)
+( 1.0000E+00, 2.0000E+00)
+(-1.0000E+00, 2.0000E+00)
+( 3.0000E+00, 0.0000E+00)
+( 7.0000E+00, 0.0000E+00)
+( 1.0000E+00,-2.0000E+00)
+(-1.0000E+00,-2.0000E+00)
+( 1.0000E+00,-2.0000E+00)
+( 1.0000E+00, 2.0000E+00)
+( 7.0000E+00, 0.0000E+00)
+(-3.0000E+00, 0.0000E+00)
+(-1.0000E+00,-2.0000E+00)
+(-2.0000E+00, 2.0000E+00)
+(-3.0000E+00, 0.0000E+00)
+( 7.0000E+00, 0.0000E+00)
+ 9.8985E-01 4.1447E+00
+ 5 2 1
+ 2 3
+( 1.0000E+00, 2.0000E+00)
+( 3.0000E+00, 4.0000E+00)
+( 2.1000E+01, 2.2000E+01)
+( 2.3000E+01, 2.4000E+01)
+( 4.1000E+01, 4.2000E+01)
+( 4.3000E+01, 4.4000E+01)
+( 1.3000E+01, 1.4000E+01)
+( 1.5000E+01, 1.6000E+01)
+( 3.3000E+01, 3.4000E+01)
+( 3.5000E+01, 3.6000E+01)
+( 5.0000E+00, 6.0000E+00)
+( 7.0000E+00, 8.0000E+00)
+( 2.5000E+01, 2.6000E+01)
+( 2.7000E+01, 2.8000E+01)
+( 4.5000E+01, 4.6000E+01)
+( 4.7000E+01, 4.8000E+01)
+( 1.7000E+01, 1.8000E+01)
+( 1.9000E+01, 2.0000E+01)
+( 3.7000E+01, 3.8000E+01)
+( 3.9000E+01, 4.0000E+01)
+( 9.0000E+00, 1.0000E+01)
+( 1.1000E+01, 1.2000E+01)
+( 2.9000E+01, 3.0000E+01)
+( 3.1000E+01, 3.2000E+01)
+( 4.9000E+01, 5.0000E+01)
+ 3.1088E-01 4.6912E+00
+ 3 2 0
+ 1 2
+( 1.0000E+00, 1.0000E+00)
+(-1.0000E+00,-1.0000E+00)
+( 2.0000E+00, 2.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 2.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+(-1.0000E+00, 0.0000E+00)
+( 3.0000E+00, 1.0000E+00)
+ 2.2361E-01 1.0000E+00
+ 4 2 1
+ 1 3
+(-4.0000E+00,-2.0000E+00)
+(-5.0000E+00,-6.0000E+00)
+(-2.0000E+00,-6.0000E+00)
+( 0.0000E+00,-2.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+ 7.2803E-05 1.1947E-04
+ 7 4 0
+ 1 4 6 7
+( 2.0000E+00, 4.0000E+00)
+( 1.0000E+00, 1.0000E+00)
+( 6.0000E+00, 2.0000E+00)
+( 3.0000E+00, 3.0000E+00)
+( 5.0000E+00, 5.0000E+00)
+( 2.0000E+00, 6.0000E+00)
+( 1.0000E+00, 1.0000E+00)
+( 1.0000E+00, 2.0000E+00)
+( 1.0000E+00, 3.0000E+00)
+( 3.0000E+00, 1.0000E+00)
+( 5.0000E+00,-4.0000E+00)
+( 1.0000E+00, 1.0000E+00)
+( 7.0000E+00, 2.0000E+00)
+( 2.0000E+00, 3.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 3.0000E+00,-2.0000E+00)
+( 1.0000E+00, 1.0000E+00)
+( 6.0000E+00, 3.0000E+00)
+( 2.0000E+00, 1.0000E+00)
+( 1.0000E+00, 4.0000E+00)
+( 2.0000E+00, 1.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 2.0000E+00, 3.0000E+00)
+( 3.0000E+00, 1.0000E+00)
+( 1.0000E+00, 2.0000E+00)
+( 2.0000E+00, 2.0000E+00)
+( 3.0000E+00, 1.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 2.0000E+00,-1.0000E+00)
+( 2.0000E+00, 2.0000E+00)
+( 3.0000E+00, 1.0000E+00)
+( 1.0000E+00, 3.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00,-1.0000E+00)
+( 2.0000E+00, 1.0000E+00)
+( 2.0000E+00, 2.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 2.0000E+00,-2.0000E+00)
+( 1.0000E+00, 1.0000E+00)
+ 3.7241E-01 5.2080E-01
+ 5 3 1
+ 1 3 5
+( 0.0000E+00, 5.0000E+00)
+( 1.0000E+00, 2.0000E+00)
+( 2.0000E+00, 3.0000E+00)
+(-3.0000E+00, 6.0000E+00)
+( 6.0000E+00, 0.0000E+00)
+(-1.0000E+00, 2.0000E+00)
+( 0.0000E+00, 6.0000E+00)
+( 4.0000E+00, 5.0000E+00)
+(-3.0000E+00,-2.0000E+00)
+( 5.0000E+00, 0.0000E+00)
+(-2.0000E+00, 3.0000E+00)
+(-4.0000E+00, 5.0000E+00)
+( 0.0000E+00, 7.0000E+00)
+( 3.0000E+00, 0.0000E+00)
+( 2.0000E+00, 0.0000E+00)
+( 3.0000E+00, 6.0000E+00)
+( 3.0000E+00,-2.0000E+00)
+(-3.0000E+00, 0.0000E+00)
+( 0.0000E+00,-5.0000E+00)
+( 2.0000E+00, 1.0000E+00)
+(-6.0000E+00, 0.0000E+00)
+(-5.0000E+00, 0.0000E+00)
+(-2.0000E+00, 0.0000E+00)
+(-2.0000E+00, 1.0000E+00)
+( 0.0000E+00, 2.0000E+00)
+ 1.0000E+00 4.5989E+00
+ 8 4 1
+ 1 2 3 4
+( 0.0000E+00, 1.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 2.0000E+00)
+( 2.0000E+00, 0.0000E+00)
+( 0.0000E+00, 2.0000E+00)
+( 2.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 3.0000E+00)
+( 3.0000E+00, 0.0000E+00)
+( 0.0000E+00, 3.0000E+00)
+( 3.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 0.0000E+00, 4.0000E+00)
+( 4.0000E+00, 0.0000E+00)
+( 0.0000E+00, 4.0000E+00)
+( 4.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 9.5000E-01)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 9.5000E-01)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 9.5000E-01)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 9.5000E-01)
+ 9.5269E-12 2.9360E-11
+ 3 2 0
+ 2 3
+( 2.0000E+00, 0.0000E+00)
+( 0.0000E+00,-1.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 2.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 3.0000E+00, 0.0000E+00)
+ 1.0000E+00 2.0000E+00
+ 0 0 0
+CVX Data for the Complex Nonsymmetric Eigenvalue Expert Driver
+6 Number of matrix dimensions
+0 1 2 3 5 10 20 Matrix dimensions
+3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
+20.0 Threshold for test ratios
+T
+2 Read another line with random number generate seed
+2518 3899 995 397 Seed for random number generator
+CVX 21 Use all matrix types
+ 1 0
+( 0.0000E+00, 0.0000E+00)
+ 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 1 0
+( 0.0000E+00, 1.0000E+00)
+ 0.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00
+ 2 0
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+ 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 2 0
+( 3.0000E+00, 0.0000E+00)
+( 2.0000E+00, 0.0000E+00)
+( 2.0000E+00, 0.0000E+00)
+( 3.0000E+00, 0.0000E+00)
+ 1.0000E+00 0.0000E+00 1.0000E+00 4.0000E+00
+ 5.0000E+00 0.0000E+00 1.0000E+00 4.0000E+00
+ 2 0
+( 3.0000E+00, 0.0000E+00)
+( 0.0000E+00, 2.0000E+00)
+( 0.0000E+00, 2.0000E+00)
+( 3.0000E+00, 0.0000E+00)
+ 3.0000E+00 2.0000E+00 1.0000E+00 4.0000E+00
+ 3.0000E+00 -2.0000E+00 1.0000E+00 4.0000E+00
+ 5 0
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+ 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 5 0
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+ 1.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 1.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 1.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 1.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 1.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 5 0
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 2.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 3.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 4.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 5.0000E+00, 0.0000E+00)
+ 1.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 2.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 3.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 4.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 5.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 6 0
+( 0.0000E+00, 1.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+ 0.0000E+00 1.0000E+00 1.1921E-07 0.0000E+00
+ 0.0000E+00 1.0000E+00 2.4074E-35 0.0000E+00
+ 0.0000E+00 1.0000E+00 2.4074E-35 0.0000E+00
+ 0.0000E+00 1.0000E+00 2.4074E-35 0.0000E+00
+ 0.0000E+00 1.0000E+00 2.4074E-35 0.0000E+00
+ 0.0000E+00 1.0000E+00 1.1921E-07 0.0000E+00
+ 6 0
+( 0.0000E+00, 1.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+ 0.0000E+00 1.0000E+00 1.1921E-07 0.0000E+00
+ 0.0000E+00 1.0000E+00 2.4074E-35 0.0000E+00
+ 0.0000E+00 1.0000E+00 2.4074E-35 0.0000E+00
+ 0.0000E+00 1.0000E+00 2.4074E-35 0.0000E+00
+ 0.0000E+00 1.0000E+00 2.4074E-35 0.0000E+00
+ 0.0000E+00 1.0000E+00 1.1921E-07 0.0000E+00
+ 4 0
+( 9.4480E-01, 1.0000E+00)
+( 6.7670E-01, 1.0000E+00)
+( 6.9080E-01, 1.0000E+00)
+( 5.9650E-01, 1.0000E+00)
+( 5.8760E-01, 1.0000E+00)
+( 8.6420E-01, 1.0000E+00)
+( 6.7690E-01, 1.0000E+00)
+( 7.2600E-02, 1.0000E+00)
+( 7.2560E-01, 1.0000E+00)
+( 1.9430E-01, 1.0000E+00)
+( 9.6870E-01, 1.0000E+00)
+( 2.8310E-01, 1.0000E+00)
+( 2.8490E-01, 1.0000E+00)
+( 5.8000E-02, 1.0000E+00)
+( 4.8450E-01, 1.0000E+00)
+( 7.3610E-01, 1.0000E+00)
+ 2.6014E-01 -1.7813E-01 8.5279E-01 3.2881E-01
+ 2.8961E-01 2.0772E-01 8.4871E-01 3.2358E-01
+ 7.3990E-01 -4.6522E-04 9.7398E-01 3.4994E-01
+ 2.2242E+00 3.9709E+00 9.8325E-01 4.1429E+00
+ 4 0
+( 2.1130E-01, 9.9330E-01)
+( 8.0960E-01, 4.2370E-01)
+( 4.8320E-01, 1.1670E-01)
+( 6.5380E-01, 4.9430E-01)
+( 8.2400E-02, 8.3600E-01)
+( 8.4740E-01, 2.6130E-01)
+( 6.1350E-01, 6.2500E-01)
+( 4.8990E-01, 3.6500E-02)
+( 7.5990E-01, 7.4690E-01)
+( 4.5240E-01, 2.4030E-01)
+( 2.7490E-01, 5.5100E-01)
+( 7.7410E-01, 2.2600E-01)
+( 8.7000E-03, 3.7800E-02)
+( 8.0750E-01, 3.4050E-01)
+( 8.8070E-01, 3.5500E-01)
+( 9.6260E-01, 8.1590E-01)
+ -6.2157E-01 6.0607E-01 8.7533E-01 8.1980E-01
+ 2.8890E-01 -2.6354E-01 8.2538E-01 8.1086E-01
+ 3.8017E-01 5.4217E-01 7.4771E-01 7.0323E-01
+ 2.2487E+00 1.7368E+00 9.2372E-01 2.2178E+00
+ 3 0
+( 1.0000E+00, 2.0000E+00)
+( 3.0000E+00, 4.0000E+00)
+( 2.1000E+01, 2.2000E+01)
+( 4.3000E+01, 4.4000E+01)
+( 1.3000E+01, 1.4000E+01)
+( 1.5000E+01, 1.6000E+01)
+( 5.0000E+00, 6.0000E+00)
+( 7.0000E+00, 8.0000E+00)
+( 2.5000E+01, 2.6000E+01)
+ -7.4775E+00 6.8803E+00 3.9550E-01 1.6583E+01
+ 6.7009E+00 -7.8760E+00 3.9828E-01 1.6312E+01
+ 3.9777E+01 4.2996E+01 7.9686E-01 3.7399E+01
+ 4 0
+( 5.0000E+00, 9.0000E+00)
+( 5.0000E+00, 5.0000E+00)
+(-6.0000E+00,-6.0000E+00)
+(-7.0000E+00,-7.0000E+00)
+( 3.0000E+00, 3.0000E+00)
+( 6.0000E+00, 1.0000E+01)
+(-5.0000E+00,-5.0000E+00)
+(-6.0000E+00,-6.0000E+00)
+( 2.0000E+00, 2.0000E+00)
+( 3.0000E+00, 3.0000E+00)
+(-1.0000E+00, 3.0000E+00)
+(-5.0000E+00,-5.0000E+00)
+( 1.0000E+00, 1.0000E+00)
+( 2.0000E+00, 2.0000E+00)
+(-3.0000E+00,-3.0000E+00)
+( 0.0000E+00, 4.0000E+00)
+ 1.0000E+00 5.0000E+00 2.1822E-01 7.4651E-01
+ 2.0000E+00 6.0000E+00 2.1822E-01 3.0893E-01
+ 3.0000E+00 7.0000E+00 2.1822E-01 1.8315E-01
+ 4.0000E+00 8.0000E+00 2.1822E-01 6.6350E-01
+ 4 0
+( 3.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 2.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 3.0000E+00, 0.0000E+00)
+( 0.0000E+00,-2.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 2.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00,-2.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+ -8.2843E-01 1.6979E-07 1.0000E+00 8.2843E-01
+ 4.1744E-07 7.1526E-08 1.0000E+00 8.2843E-01
+ 4.0000E+00 1.6690E-07 1.0000E+00 8.2843E-01
+ 4.8284E+00 6.8633E-08 1.0000E+00 8.2843E-01
+ 4 0
+( 7.0000E+00, 0.0000E+00)
+( 3.0000E+00, 0.0000E+00)
+( 1.0000E+00, 2.0000E+00)
+(-1.0000E+00, 2.0000E+00)
+( 3.0000E+00, 0.0000E+00)
+( 7.0000E+00, 0.0000E+00)
+( 1.0000E+00,-2.0000E+00)
+(-1.0000E+00,-2.0000E+00)
+( 1.0000E+00,-2.0000E+00)
+( 1.0000E+00, 2.0000E+00)
+( 7.0000E+00, 0.0000E+00)
+(-3.0000E+00, 0.0000E+00)
+(-1.0000E+00,-2.0000E+00)
+(-2.0000E+00, 2.0000E+00)
+(-3.0000E+00, 0.0000E+00)
+( 7.0000E+00, 0.0000E+00)
+ -8.0767E-03 -2.5211E-01 9.9864E-01 7.7961E+00
+ 7.7723E+00 2.4349E-01 7.0272E-01 3.3337E-01
+ 8.0000E+00 -3.4273E-07 7.0711E-01 3.3337E-01
+ 1.2236E+01 8.6188E-03 9.9021E-01 3.9429E+00
+ 5 0
+( 1.0000E+00, 2.0000E+00)
+( 3.0000E+00, 4.0000E+00)
+( 2.1000E+01, 2.2000E+01)
+( 2.3000E+01, 2.4000E+01)
+( 4.1000E+01, 4.2000E+01)
+( 4.3000E+01, 4.4000E+01)
+( 1.3000E+01, 1.4000E+01)
+( 1.5000E+01, 1.6000E+01)
+( 3.3000E+01, 3.4000E+01)
+( 3.5000E+01, 3.6000E+01)
+( 5.0000E+00, 6.0000E+00)
+( 7.0000E+00, 8.0000E+00)
+( 2.5000E+01, 2.6000E+01)
+( 2.7000E+01, 2.8000E+01)
+( 4.5000E+01, 4.6000E+01)
+( 4.7000E+01, 4.8000E+01)
+( 1.7000E+01, 1.8000E+01)
+( 1.9000E+01, 2.0000E+01)
+( 3.7000E+01, 3.8000E+01)
+( 3.9000E+01, 4.0000E+01)
+( 9.0000E+00, 1.0000E+01)
+( 1.1000E+01, 1.2000E+01)
+( 2.9000E+01, 3.0000E+01)
+( 3.1000E+01, 3.2000E+01)
+( 4.9000E+01, 5.0000E+01)
+ -9.4600E+00 7.2802E+00 3.1053E-01 1.1937E+01
+ -7.7912E-06 -1.2743E-05 2.9408E-01 1.6030E-05
+ -7.3042E-06 3.2789E-06 7.2259E-01 6.7794E-06
+ 7.0733E+00 -9.5584E+00 3.0911E-01 1.1891E+01
+ 1.2739E+02 1.3228E+02 9.2770E-01 1.2111E+02
+ 3 0
+( 1.0000E+00, 1.0000E+00)
+(-1.0000E+00,-1.0000E+00)
+( 2.0000E+00, 2.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 2.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+(-1.0000E+00, 0.0000E+00)
+( 3.0000E+00, 1.0000E+00)
+ 1.0000E+00 1.0000E+00 3.0151E-01 0.0000E+00
+ 1.0000E+00 1.0000E+00 3.1623E-01 0.0000E+00
+ 2.0000E+00 1.0000E+00 2.2361E-01 1.0000E+00
+ 4 1
+(-4.0000E+00,-2.0000E+00)
+(-5.0000E+00,-6.0000E+00)
+(-2.0000E+00,-6.0000E+00)
+( 0.0000E+00,-2.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+ -9.9883E-01 -1.0006E+00 1.3180E-04 2.4106E-04
+ -1.0012E+00 -9.9945E-01 1.3140E-04 2.4041E-04
+ -9.9947E-01 -6.8325E-04 1.3989E-04 8.7487E-05
+ -1.0005E+00 6.8556E-04 1.4010E-04 8.7750E-05
+ 7 0
+( 2.0000E+00, 4.0000E+00)
+( 1.0000E+00, 1.0000E+00)
+( 6.0000E+00, 2.0000E+00)
+( 3.0000E+00, 3.0000E+00)
+( 5.0000E+00, 5.0000E+00)
+( 2.0000E+00, 6.0000E+00)
+( 1.0000E+00, 1.0000E+00)
+( 1.0000E+00, 2.0000E+00)
+( 1.0000E+00, 3.0000E+00)
+( 3.0000E+00, 1.0000E+00)
+( 5.0000E+00,-4.0000E+00)
+( 1.0000E+00, 1.0000E+00)
+( 7.0000E+00, 2.0000E+00)
+( 2.0000E+00, 3.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 3.0000E+00,-2.0000E+00)
+( 1.0000E+00, 1.0000E+00)
+( 6.0000E+00, 3.0000E+00)
+( 2.0000E+00, 1.0000E+00)
+( 1.0000E+00, 4.0000E+00)
+( 2.0000E+00, 1.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 2.0000E+00, 3.0000E+00)
+( 3.0000E+00, 1.0000E+00)
+( 1.0000E+00, 2.0000E+00)
+( 2.0000E+00, 2.0000E+00)
+( 3.0000E+00, 1.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 2.0000E+00,-1.0000E+00)
+( 2.0000E+00, 2.0000E+00)
+( 3.0000E+00, 1.0000E+00)
+( 1.0000E+00, 3.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00,-1.0000E+00)
+( 2.0000E+00, 1.0000E+00)
+( 2.0000E+00, 2.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 2.0000E+00,-2.0000E+00)
+( 1.0000E+00, 1.0000E+00)
+ -2.7081E+00 -2.8029E+00 6.9734E-01 3.9279E+00
+ -1.1478E+00 8.0176E-01 6.5772E-01 9.4243E-01
+ -8.0109E-01 4.9694E+00 4.6751E-01 1.3779E+00
+ 9.9492E-01 3.1688E+00 3.5095E-01 5.9845E-01
+ 2.0809E+00 1.9341E+00 4.9042E-01 3.9035E-01
+ 5.3138E+00 1.2242E+00 3.0213E-01 7.1268E-01
+ 8.2674E+00 3.7047E+00 2.8270E-01 3.2849E+00
+ 5 1
+( 0.0000E+00, 5.0000E+00)
+( 1.0000E+00, 2.0000E+00)
+( 2.0000E+00, 3.0000E+00)
+(-3.0000E+00, 6.0000E+00)
+( 6.0000E+00, 0.0000E+00)
+(-1.0000E+00, 2.0000E+00)
+( 0.0000E+00, 6.0000E+00)
+( 4.0000E+00, 5.0000E+00)
+(-3.0000E+00,-2.0000E+00)
+( 5.0000E+00, 0.0000E+00)
+(-2.0000E+00, 3.0000E+00)
+(-4.0000E+00, 5.0000E+00)
+( 0.0000E+00, 7.0000E+00)
+( 3.0000E+00, 0.0000E+00)
+( 2.0000E+00, 0.0000E+00)
+( 3.0000E+00, 6.0000E+00)
+( 3.0000E+00,-2.0000E+00)
+(-3.0000E+00, 0.0000E+00)
+( 0.0000E+00,-5.0000E+00)
+( 2.0000E+00, 1.0000E+00)
+(-6.0000E+00, 0.0000E+00)
+(-5.0000E+00, 0.0000E+00)
+(-2.0000E+00, 0.0000E+00)
+(-2.0000E+00, 1.0000E+00)
+( 0.0000E+00, 2.0000E+00)
+ -4.1735E-08 -1.0734E+01 1.0000E+00 7.7345E+00
+ -2.6397E-07 -2.9991E+00 1.0000E+00 4.5989E+00
+ 1.4565E-07 1.5998E+00 1.0000E+00 4.5989E+00
+ -4.4369E-07 9.3159E+00 1.0000E+00 7.7161E+00
+ 4.0937E-09 1.7817E+01 1.0000E+00 8.5013E+00
+ 3 0
+( 2.0000E+00, 0.0000E+00)
+( 0.0000E+00,-1.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 1.0000E+00)
+( 2.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 3.0000E+00, 0.0000E+00)
+ 1.0000E+00 0.0000E+00 1.0000E+00 2.0000E+00
+ 3.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 3.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 0 0
diff --git a/TESTING/cgbak.in b/TESTING/cgbak.in
new file mode 100644
index 0000000..970fb26
--- /dev/null
+++ b/TESTING/cgbak.in
@@ -0,0 +1,446 @@
+CGK: Tests CGGBAK
+ 6 3
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.2000E+01, 0.2000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.3000E+01, 0.3000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.4000E+01, 0.4000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.5000E+01, 0.5000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.6000E+01, 0.6000E+01)
+
+( 0.6000E+01, 0.6000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.5000E+01, 0.5000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.4000E+01, 0.4000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.3000E+01, 0.3000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.2000E+01, 0.2000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.2000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.3000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.4000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.5000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.6000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+
+(-0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+(-0.2000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+(-0.3000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+(-0.4000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+(-0.5000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+(-0.6000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+
+ 6 2
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) (
+( 0.2000E+01, 0.2000E+01) ( 0.2000E+01, 0.2000E+01) (
+( 0.3000E+01, 0.3000E+01) ( 0.3000E+01, 0.3000E+01) (
+( 0.4000E+01, 0.4000E+01) ( 0.4000E+01, 0.4000E+01) (
+( 0.5000E+01, 0.5000E+01) ( 0.5000E+01, 0.5000E+01) (
+( 0.6000E+01, 0.6000E+01) ( 0.6000E+01, 0.6000E+01) (
+
+(-0.1000E+01,-0.1000E+01) (-0.1000E+01,-0.1000E+01) (
+(-0.2000E+01,-0.2000E+01) (-0.2000E+01,-0.2000E+01) (
+(-0.3000E+01,-0.3000E+01) (-0.3000E+01,-0.3000E+01) (
+(-0.4000E+01,-0.4000E+01) (-0.4000E+01,-0.4000E+01) (
+(-0.5000E+01,-0.5000E+01) (-0.5000E+01,-0.5000E+01) (
+(-0.6000E+01,-0.6000E+01) (-0.6000E+01,-0.6000E+01) (
+
+ 6 3
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.4000E+01, 0.4000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.4000E+01, 0.4000E+01) ( 0.5000E+01, 0.5000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.4000E+01, 0.4000E+01) ( 0.5000E+01, 0.5000E+01) ( 0.6000E+01, 0.6000E+01)
+
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.4000E+01, 0.4000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.4000E+01, 0.4000E+01) ( 0.5000E+01, 0.5000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.4000E+01, 0.4000E+01) ( 0.5000E+01, 0.5000E+01) ( 0.6000E+01, 0.6000E+01)
+
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.2000E+01, 0.2000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.2000E+01, 0.2000E+01)
+( 0.3000E+01, 0.3000E+01) ( 0.3000E+01, 0.3000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.4000E+01, 0.4000E+01) ( 0.4000E+01, 0.4000E+01) ( 0.4000E+01, 0.4000E+01)
+( 0.5000E+01, 0.5000E+01) ( 0.5000E+01, 0.5000E+01) ( 0.5000E+01, 0.5000E+01)
+( 0.6000E+01, 0.6000E+01) ( 0.6000E+01, 0.6000E+01) ( 0.6000E+01, 0.6000E+01)
+
+(-0.1000E+01,-0.1000E+01) (-0.1000E+01,-0.1000E+01) (-0.1000E+01,-0.1000E+01)
+(-0.2000E+01,-0.2000E+01) (-0.2000E+01,-0.2000E+01) (-0.2000E+01,-0.2000E+01)
+(-0.3000E+01,-0.3000E+01) (-0.3000E+01,-0.3000E+01) (-0.3000E+01,-0.3000E+01)
+(-0.4000E+01,-0.4000E+01) (-0.4000E+01,-0.4000E+01) (-0.4000E+01,-0.4000E+01)
+(-0.5000E+01,-0.5000E+01) (-0.5000E+01,-0.5000E+01) (-0.5000E+01,-0.5000E+01)
+(-0.6000E+01,-0.6000E+01) (-0.6000E+01,-0.6000E+01) (-0.6000E+01,-0.6000E+01)
+
+ 5 3
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) (
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) (
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) (
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.4000E+01, 0.4000E+01) ( 0.0000E+00, 0.0000E+00) (
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.4000E+01, 0.4000E+01) ( 0.5000E+01, 0.5000E+01) (
+
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) (
+
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.2000E+01, 0.2000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.2000E+01, 0.2000E+01)
+( 0.3000E+01, 0.3000E+01) ( 0.3000E+01, 0.3000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.4000E+01, 0.4000E+01) ( 0.4000E+01, 0.4000E+01) ( 0.4000E+01, 0.4000E+01)
+( 0.5000E+01, 0.5000E+01) ( 0.5000E+01, 0.5000E+01) ( 0.5000E+01, 0.5000E+01)
+
+(-0.1000E+01,-0.1000E+01) (-0.1000E+01,-0.1000E+01) (-0.1000E+01,-0.1000E+01)
+(-0.2000E+01,-0.2000E+01) (-0.2000E+01,-0.2000E+01) (-0.2000E+01,-0.2000E+01)
+(-0.3000E+01,-0.3000E+01) (-0.3000E+01,-0.3000E+01) (-0.3000E+01,-0.3000E+01)
+(-0.4000E+01,-0.4000E+01) (-0.4000E+01,-0.4000E+01) (-0.4000E+01,-0.4000E+01)
+(-0.5000E+01,-0.5000E+01) (-0.5000E+01,-0.5000E+01) (-0.5000E+01,-0.5000E+01)
+
+ 6 3
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+
+( 0.1000E+05, 0.1000E+05) ( 0.1000E+05, 0.1000E+05) ( 0.1000E+05, 0.1000E+05)
+( 0.2000E+05, 0.2000E+05) ( 0.2000E+05, 0.2000E+05) ( 0.2000E+05, 0.2000E+05)
+( 0.3000E+05, 0.3000E+05) ( 0.3000E+05, 0.3000E+05) ( 0.3000E+05, 0.3000E+05)
+( 0.4000E+05, 0.4000E+05) ( 0.4000E+05, 0.4000E+05) ( 0.4000E+05, 0.4000E+05)
+( 0.5000E+05, 0.5000E+05) ( 0.5000E+05, 0.5000E+05) ( 0.5000E+05, 0.5000E+05)
+( 0.6000E+05, 0.6000E+05) ( 0.6000E+05, 0.6000E+05) ( 0.6000E+05, 0.6000E+05)
+
+(-0.1000E+05,-0.1000E+05) (-0.1000E+05,-0.1000E+05) (-0.1000E+05,-0.1000E+05)
+(-0.2000E+05,-0.2000E+05) (-0.2000E+05,-0.2000E+05) (-0.2000E+05,-0.2000E+05)
+(-0.3000E+05,-0.3000E+05) (-0.3000E+05,-0.3000E+05) (-0.3000E+05,-0.3000E+05)
+(-0.4000E+05,-0.4000E+05) (-0.4000E+05,-0.4000E+05) (-0.4000E+05,-0.4000E+05)
+(-0.5000E+05,-0.5000E+05) (-0.5000E+05,-0.5000E+05) (-0.5000E+05,-0.5000E+05)
+(-0.6000E+05,-0.6000E+05) (-0.6000E+05,-0.6000E+05) (-0.6000E+05,-0.6000E+05)
+
+ 6 3
+( 0.1000E+01, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+07, 0.1000E+07) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E-05, 0.1000E-05) ( 0.1000E+07, 0.1000E+07)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+07, 0.1000E+07) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E-05, 0.1000E-05) ( 0.1000E-05, 0.1000E-05)
+( 0.1000E+07, 0.1000E+07) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+07, 0.1000E+07) ( 0.1000E+07, 0.1000E+07)
+
+( 0.1000E+01, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+07, 0.1000E+07) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E-05, 0.1000E-05) ( 0.1000E+07, 0.1000E+07)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+07, 0.1000E+07) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E-05, 0.1000E-05) ( 0.1000E-05, 0.1000E-05)
+( 0.1000E+07, 0.1000E+07) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+07, 0.1000E+07) ( 0.1000E+07, 0.1000E+07)
+
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.2000E+01, 0.2000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.2000E+01, 0.2000E+01)
+( 0.3000E+01, 0.3000E+01) ( 0.3000E+01, 0.3000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.4000E+01, 0.4000E+01) ( 0.4000E+01, 0.4000E+01) ( 0.4000E+01, 0.4000E+01)
+( 0.5000E+01, 0.5000E+01) ( 0.5000E+01, 0.5000E+01) ( 0.5000E+01, 0.5000E+01)
+( 0.6000E+01, 0.6000E+01) ( 0.6000E+01, 0.6000E+01) ( 0.6000E+01, 0.6000E+01)
+
+(-0.1000E+01,-0.1000E+01) (-0.1000E+01,-0.1000E+01) (-0.1000E+01,-0.1000E+01)
+(-0.2000E+01,-0.2000E+01) (-0.2000E+01,-0.2000E+01) (-0.2000E+01,-0.2000E+01)
+(-0.3000E+01,-0.3000E+01) (-0.3000E+01,-0.3000E+01) (-0.3000E+01,-0.3000E+01)
+(-0.4000E+01,-0.4000E+01) (-0.4000E+01,-0.4000E+01) (-0.4000E+01,-0.4000E+01)
+(-0.5000E+01,-0.5000E+01) (-0.5000E+01,-0.5000E+01) (-0.5000E+01,-0.5000E+01)
+(-0.6000E+01,-0.6000E+01) (-0.6000E+01,-0.6000E+01) (-0.6000E+01,-0.6000E+01)
+
+ 7 2
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) (
+( 0.2000E+01, 0.2000E+01) ( 0.2000E+01, 0.2000E+01) (
+( 0.3000E+01, 0.3000E+01) ( 0.3000E+01, 0.3000E+01) (
+( 0.4000E+01, 0.4000E+01) ( 0.4000E+01, 0.4000E+01) (
+( 0.5000E+01, 0.5000E+01) ( 0.5000E+01, 0.5000E+01) (
+( 0.6000E+01, 0.6000E+01) ( 0.6000E+01, 0.6000E+01) (
+( 0.7000E+01, 0.7000E+01) ( 0.7000E+01, 0.7000E+01) (
+
+(-0.1000E+01,-0.1000E+01) (-0.1000E+01,-0.1000E+01) (
+(-0.2000E+01,-0.2000E+01) (-0.2000E+01,-0.2000E+01) (
+(-0.3000E+01,-0.3000E+01) (-0.3000E+01,-0.3000E+01) (
+(-0.4000E+01,-0.4000E+01) (-0.4000E+01,-0.4000E+01) (
+(-0.5000E+01,-0.5000E+01) (-0.5000E+01,-0.5000E+01) (
+(-0.6000E+01,-0.6000E+01) (-0.6000E+01,-0.6000E+01) (
+(-0.7000E+01,-0.7000E+01) (-0.7000E+01,-0.7000E+01) (
+
+ 7 3
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+06, 0.1000E+06) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+06, 0.1000E+06) ( 0.1000E+06, 0.1000E+06) ( 0.1000E+06, 0.1000E+06)
+( 0.1000E-04, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E-04, 0.1000E-04) ( 0.1000E+06, 0.1000E+06)
+( 0.1000E-03, 0.1000E-03) ( 0.1000E-04, 0.0000E+00) ( 0.1000E+06, 0.1000E+06)
+( 0.1000E+06, 0.1000E+06) (
+( 0.1000E+06, 0.1000E+06) ( 0.1000E+06, 0.1000E+06) ( 0.1000E-04, 0.1000E-04)
+( 0.1000E+06, 0.1000E+01) ( 0.1000E+06, 0.1000E+01) ( 0.1000E+06, 0.1000E+06)
+( 0.1000E+04, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E-03, 0.1000E-04) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+00, 0.1000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.1000E-03, 0.1000E-03)
+( 0.1000E+06, 0.1000E+06) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+06, 0.1000E+06) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E-04, 0.1000E-04) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E-04, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+02, 0.1000E+02) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+06, 0.1000E+06) ( 0.1000E+06, 0.1000E+06) ( 0.1000E-04, 0.1000E-04)
+( 0.1000E+03, 0.0000E+00) (
+
+( 0.0000E+00, 0.0000E+00) ( 0.1000E-01, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+06, 0.1000E+06) ( 0.1000E-04, 0.0000E+00) ( 0.1000E+06, 0.1000E+06)
+( 0.1000E+06, 0.1000E+06) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+06, 0.1000E+06) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+06, 0.1000E+06) ( 0.1000E+06, 0.1000E+06) ( 0.1000E+00, 0.0000E+00)
+( 0.1000E+03, 0.0000E+00) (
+( 0.1000E+06, 0.1000E+06) ( 0.1000E+03, 0.0000E+00) ( 0.1000E+04, 0.0000E+00)
+( 0.1000E+04, 0.0000E+00) ( 0.1000E-03, 0.1000E-04) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E-04, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+06, 0.1000E+06) ( 0.1000E+06, 0.1000E+06) ( 0.1000E+06, 0.1000E+06)
+( 0.1000E+06, 0.1000E+06) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+06, 0.1000E+06) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+06, 0.1000E+06) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+06, 0.1000E+06) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E-03, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+06, 0.1000E+06) ( 0.1000E+06, 0.1000E+06) ( 0.1000E+06, 0.1000E+06)
+( 0.1000E-03, 0.1000E-04) (
+
+( 0.1000E-04, 0.1000E-04) ( 0.1000E-04, 0.1000E-04) ( 0.1000E-04, 0.1000E-04)
+( 0.2000E-04, 0.2000E-04) ( 0.2000E-04, 0.2000E-04) ( 0.2000E-04, 0.2000E-04)
+( 0.3000E-04, 0.3000E-04) ( 0.3000E-04, 0.3000E-04) ( 0.3000E-04, 0.3000E-04)
+( 0.4000E-04, 0.4000E-04) ( 0.4000E-04, 0.4000E-04) ( 0.4000E-04, 0.4000E-04)
+( 0.5000E-04, 0.5000E-04) ( 0.5000E-04, 0.5000E-04) ( 0.5000E-04, 0.5000E-04)
+( 0.6000E-04, 0.6000E-04) ( 0.6000E-04, 0.6000E-04) ( 0.6000E-04, 0.6000E-04)
+( 0.7000E-04, 0.7000E-04) ( 0.7000E-04, 0.7000E-04) ( 0.7000E-04, 0.7000E-04)
+
+(-0.1000E-04,-0.1000E-04) (-0.1000E-04,-0.1000E-04) (-0.1000E-04,-0.1000E-04)
+(-0.2000E-04,-0.2000E-04) (-0.2000E-04,-0.2000E-04) (-0.2000E-04,-0.2000E-04)
+(-0.3000E-04,-0.3000E-04) (-0.3000E-04,-0.3000E-04) (-0.3000E-04,-0.3000E-04)
+(-0.4000E-04,-0.4000E-04) (-0.4000E-04,-0.4000E-04) (-0.4000E-04,-0.4000E-04)
+(-0.5000E-04,-0.5000E-04) (-0.5000E-04,-0.5000E-04) (-0.5000E-04,-0.5000E-04)
+(-0.6000E-04,-0.6000E-04) (-0.6000E-04,-0.6000E-04) (-0.6000E-04,-0.6000E-04)
+(-0.7000E-04,-0.7000E-04) (-0.7000E-04,-0.7000E-04) (-0.7000E-04,-0.7000E-04)
+
+ 6 3
+(-0.2000E+02, 0.1000E+01) (-0.1000E+04, 0.1000E+04) (-0.2000E+01, 0.0000E+00)
+(-0.1000E+04, 0.0000E+00) (-0.1000E+02, 0.0000E+00) (-0.2000E+04, 0.1000E+04)
+( 0.6000E-04, 0.0000E+00) ( 0.4000E+01, 0.0000E+00) ( 0.6000E-02, 0.0000E+00)
+( 0.2000E+03, 0.0000E+00) ( 0.3000E-04, 0.0000E+00) ( 0.3000E+02, 0.0000E+00)
+(-0.2000E+00, 0.0000E+00) (-0.3000E+03, 0.0000E+00) (-0.4000E-01, 0.0000E+00)
+(-0.1000E+04, 0.1000E+04) ( 0.0000E+00, 0.0000E+00) ( 0.3000E+04, 0.1000E+04)
+( 0.6000E-04, 0.0000E+00) ( 0.4000E-01, 0.0000E+00) ( 0.9000E-02, 0.0000E+00)
+( 0.9000E+01, 0.0000E+00) ( 0.3000E-04, 0.0000E+00) ( 0.5000E+00, 0.0000E+00)
+( 0.6000E-01, 0.0000E+00) ( 0.5000E+02, 0.0000E+00) ( 0.8000E-04, 0.0000E+00)
+(-0.4000E+04, 0.0000E+00) ( 0.8000E-01, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+04, 0.1000E+04) ( 0.7000E+00, 0.0000E+00)
+(-0.2000E+04, 0.1000E+04) ( 0.1300E+02, 0.0000E+00) (-0.6000E+04, 0.1000E+04)
+
+(-0.2000E+02, 0.0000E+00) (-0.1000E+04, 0.1000E+04) ( 0.2000E+01, 0.0000E+00)
+(-0.2000E+04, 0.0000E+00) ( 0.1000E+02, 0.0000E+00) (-0.1000E+04, 0.1000E+04)
+( 0.5000E-04, 0.0000E+00) ( 0.3000E+01, 0.0000E+00) (-0.2000E-02, 0.0000E+00)
+( 0.4000E+03, 0.0000E+00) (-0.1000E-04, 0.0000E+00) ( 0.3000E+02, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) (-0.1000E+03, 0.0000E+00) (-0.8000E-01, 0.0000E+00)
+( 0.2000E+04, 0.0000E+00) (-0.4000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.5000E-04, 0.0000E+00) ( 0.3000E-01, 0.0000E+00) ( 0.2000E-02, 0.0000E+00)
+( 0.4000E+01, 0.0000E+00) ( 0.2000E-04, 0.0000E+00) ( 0.1000E+00, 0.0000E+00)
+( 0.4000E-01, 0.0000E+00) ( 0.3000E+02, 0.0000E+00) (-0.1000E-04, 0.0000E+00)
+( 0.3000E+04, 0.0000E+00) (-0.1000E-01, 0.0000E+00) ( 0.6000E+03, 0.0000E+00)
+(-0.1000E+01, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.4000E+00, 0.0000E+00)
+(-0.1000E+04, 0.1000E+04) ( 0.4000E+01, 0.0000E+00) ( 0.2000E+04, 0.0000E+00)
+
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+
+(-0.1000E+01,-0.1000E+01) (-0.1000E+01,-0.1000E+01) (-0.1000E+01,-0.1000E+01)
+(-0.1000E+01,-0.1000E+01) (-0.1000E+01,-0.1000E+01) (-0.1000E+01,-0.1000E+01)
+(-0.1000E+01,-0.1000E+01) (-0.1000E+01,-0.1000E+01) (-0.1000E+01,-0.1000E+01)
+(-0.1000E+01,-0.1000E+01) (-0.1000E+01,-0.1000E+01) (-0.1000E+01,-0.1000E+01)
+(-0.1000E+01,-0.1000E+01) (-0.1000E+01,-0.1000E+01) (-0.1000E+01,-0.1000E+01)
+(-0.1000E+01,-0.1000E+01) (-0.1000E+01,-0.1000E+01) (-0.1000E+01,-0.1000E+01)
+
+ 6 3
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.2000E+01, 0.2000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.2000E+01, 0.2000E+01)
+( 0.3000E+01, 0.3000E+01) ( 0.3000E+01, 0.3000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.4000E+01, 0.4000E+01) ( 0.4000E+01, 0.4000E+01) ( 0.4000E+01, 0.4000E+01)
+( 0.5000E+01, 0.5000E+01) ( 0.5000E+01, 0.5000E+01) ( 0.5000E+01, 0.5000E+01)
+( 0.6000E+01, 0.6000E+01) ( 0.6000E+01, 0.6000E+01) ( 0.6000E+01, 0.6000E+01)
+
+(-0.1000E+01,-0.1000E+01) (-0.1000E+01,-0.1000E+01) (-0.1000E+01,-0.1000E+01)
+(-0.2000E+01,-0.2000E+01) (-0.2000E+01,-0.2000E+01) (-0.2000E+01,-0.2000E+01)
+(-0.3000E+01,-0.3000E+01) (-0.3000E+01,-0.3000E+01) (-0.3000E+01,-0.3000E+01)
+(-0.4000E+01,-0.4000E+01) (-0.4000E+01,-0.4000E+01) (-0.4000E+01,-0.4000E+01)
+(-0.5000E+01,-0.5000E+01) (-0.5000E+01,-0.5000E+01) (-0.5000E+01,-0.5000E+01)
+(-0.6000E+01,-0.6000E+01) (-0.6000E+01,-0.6000E+01) (-0.6000E+01,-0.6000E+01)
+
+0 0
diff --git a/TESTING/cgbal.in b/TESTING/cgbal.in
new file mode 100644
index 0000000..6fa3155
--- /dev/null
+++ b/TESTING/cgbal.in
@@ -0,0 +1,660 @@
+CGL: Tests CGGBAL
+ 6
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.2000E+01, 0.2000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.3000E+01, 0.3000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.4000E+01, 0.4000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.5000E+01, 0.5000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.6000E+01, 0.6000E+01)
+
+( 0.6000E+01, 0.6000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.5000E+01, 0.5000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.4000E+01, 0.4000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.3000E+01, 0.3000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.2000E+01, 0.2000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+
+ 1 1
+
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.2000E+01, 0.2000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.3000E+01, 0.3000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.4000E+01, 0.4000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.5000E+01, 0.5000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.6000E+01, 0.6000E+01)
+
+( 0.6000E+01, 0.6000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.5000E+01, 0.5000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.4000E+01, 0.4000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.3000E+01, 0.3000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.2000E+01, 0.2000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01 0.6000E+01
+
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01 0.6000E+01
+
+ 6
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+
+ 1 1
+
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+
+ 6
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.4000E+01, 0.4000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.4000E+01, 0.4000E+01) ( 0.5000E+01, 0.5000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.4000E+01, 0.4000E+01) ( 0.5000E+01, 0.5000E+01) ( 0.6000E+01, 0.6000E+01)
+
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.4000E+01, 0.4000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.4000E+01, 0.4000E+01) ( 0.5000E+01, 0.5000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.4000E+01, 0.4000E+01) ( 0.5000E+01, 0.5000E+01) ( 0.6000E+01, 0.6000E+01)
+
+ 1 1
+
+( 0.6000E+01, 0.6000E+01) ( 0.5000E+01, 0.5000E+01) ( 0.4000E+01, 0.4000E+01)
+( 0.3000E+01, 0.3000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.5000E+01, 0.5000E+01) ( 0.4000E+01, 0.4000E+01)
+( 0.3000E+01, 0.3000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.4000E+01, 0.4000E+01)
+( 0.3000E+01, 0.3000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.3000E+01, 0.3000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.2000E+01, 0.2000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+
+( 0.6000E+01, 0.6000E+01) ( 0.5000E+01, 0.5000E+01) ( 0.4000E+01, 0.4000E+01)
+( 0.3000E+01, 0.3000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.5000E+01, 0.5000E+01) ( 0.4000E+01, 0.4000E+01)
+( 0.3000E+01, 0.3000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.4000E+01, 0.4000E+01)
+( 0.3000E+01, 0.3000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.3000E+01, 0.3000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.2000E+01, 0.2000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+
+ 5
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) (
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) (
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) (
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.4000E+01, 0.4000E+01) ( 0.0000E+00, 0.0000E+00) (
+( 0.1000E+01, 0.1000E+01) ( 0.2000E+01, 0.2000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.4000E+01, 0.4000E+01) ( 0.5000E+01, 0.5000E+01) (
+
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) (
+
+ 1 1
+
+( 0.5000E+01, 0.5000E+01) ( 0.4000E+01, 0.4000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.2000E+01, 0.2000E+01) ( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.4000E+01, 0.4000E+01) ( 0.3000E+01, 0.3000E+01)
+( 0.2000E+01, 0.2000E+01) ( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.3000E+01, 0.3000E+01)
+( 0.2000E+01, 0.2000E+01) ( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.2000E+01, 0.2000E+01) ( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) (
+
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) (
+
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+
+ 6
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+12, 0.1000E+12) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+12, 0.1000E+12)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+
+ 1 6
+
+( 0.1000E-04, 0.0000E+00) ( 0.1000E+05, 0.1000E+05) ( 0.1000E+04, 0.1000E+04)
+( 0.1000E+02, 0.1000E+02) ( 0.1000E+00, 0.1000E+00) ( 0.1000E-02, 0.1000E-02)
+( 0.1000E-02, 0.0000E+00) ( 0.1000E-04, 0.0000E+00) ( 0.1000E+06, 0.1000E+06)
+( 0.1000E+04, 0.1000E+04) ( 0.1000E+02, 0.1000E+02) ( 0.1000E+00, 0.1000E+00)
+( 0.1000E+00, 0.0000E+00) ( 0.1000E-02, 0.0000E+00) ( 0.1000E-03, 0.0000E+00)
+( 0.1000E+06, 0.1000E+06) ( 0.1000E+04, 0.1000E+04) ( 0.1000E+02, 0.1000E+02)
+( 0.1000E+02, 0.0000E+00) ( 0.1000E+00, 0.0000E+00) ( 0.1000E-01, 0.0000E+00)
+( 0.1000E-03, 0.0000E+00) ( 0.1000E+06, 0.1000E+06) ( 0.1000E+04, 0.1000E+04)
+( 0.1000E+03, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+00, 0.0000E+00)
+( 0.1000E-02, 0.0000E+00) ( 0.1000E-04, 0.0000E+00) ( 0.1000E+05, 0.1000E+05)
+( 0.1000E+05, 0.0000E+00) ( 0.1000E+03, 0.0000E+00) ( 0.1000E+02, 0.0000E+00)
+( 0.1000E+00, 0.0000E+00) ( 0.1000E-02, 0.0000E+00) ( 0.1000E-04, 0.0000E+00)
+
+( 0.1000E-04, 0.0000E+00) ( 0.1000E+05, 0.1000E+05) ( 0.1000E+04, 0.1000E+04)
+( 0.1000E+02, 0.1000E+02) ( 0.1000E+00, 0.1000E+00) ( 0.1000E-02, 0.1000E-02)
+( 0.1000E-02, 0.0000E+00) ( 0.1000E-04, 0.0000E+00) ( 0.1000E+06, 0.1000E+06)
+( 0.1000E+04, 0.1000E+04) ( 0.1000E+02, 0.1000E+02) ( 0.1000E+00, 0.1000E+00)
+( 0.1000E+00, 0.0000E+00) ( 0.1000E-02, 0.0000E+00) ( 0.1000E-03, 0.0000E+00)
+( 0.1000E+06, 0.1000E+06) ( 0.1000E+04, 0.1000E+04) ( 0.1000E+02, 0.1000E+02)
+( 0.1000E+02, 0.0000E+00) ( 0.1000E+00, 0.0000E+00) ( 0.1000E-01, 0.0000E+00)
+( 0.1000E-03, 0.0000E+00) ( 0.1000E+06, 0.1000E+06) ( 0.1000E+04, 0.1000E+04)
+( 0.1000E+03, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+00, 0.0000E+00)
+( 0.1000E-02, 0.0000E+00) ( 0.1000E-04, 0.0000E+00) ( 0.1000E+05, 0.1000E+05)
+( 0.1000E+05, 0.0000E+00) ( 0.1000E+03, 0.0000E+00) ( 0.1000E+02, 0.0000E+00)
+( 0.1000E+00, 0.0000E+00) ( 0.1000E-02, 0.0000E+00) ( 0.1000E-04, 0.0000E+00)
+
+ 0.1000E-06 0.1000E-04 0.1000E-02 0.1000E+00 0.1000E+01 0.1000E+03
+
+ 0.1000E+03 0.1000E+01 0.1000E+00 0.1000E-02 0.1000E-04 0.1000E-06
+
+ 6
+( 0.1000E+01, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+07, 0.1000E+07) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E-05, 0.1000E-05) ( 0.1000E+07, 0.1000E+07)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+07, 0.1000E+07) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E-05, 0.1000E-05) ( 0.1000E-05, 0.1000E-05)
+( 0.1000E+07, 0.1000E+07) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+07, 0.1000E+07) ( 0.1000E+07, 0.1000E+07)
+
+( 0.1000E+01, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+07, 0.1000E+07) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E-05, 0.1000E-05) ( 0.1000E+07, 0.1000E+07)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+07, 0.1000E+07) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E-05, 0.1000E-05) ( 0.1000E-05, 0.1000E-05)
+( 0.1000E+07, 0.1000E+07) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+07, 0.1000E+07) ( 0.1000E+07, 0.1000E+07)
+
+ 4 6
+
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E-04, 0.0000E+00) ( 0.1000E+04, 0.0000E+00) ( 0.1000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E-04, 0.0000E+00) ( 0.1000E+04, 0.0000E+00) ( 0.1000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E-04, 0.0000E+00) ( 0.1000E+04, 0.0000E+00) ( 0.1000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E-03, 0.1000E-03) ( 0.1000E+05, 0.1000E+05)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+05, 0.1000E+05) ( 0.1000E+01, 0.1000E+01) ( 0.1000E-03, 0.1000E-03)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E-03, 0.1000E-03) ( 0.1000E+05, 0.1000E+05) ( 0.1000E+01, 0.1000E+01)
+
+( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E-04, 0.0000E+00) ( 0.1000E+04, 0.0000E+00) ( 0.1000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E-04, 0.0000E+00) ( 0.1000E+04, 0.0000E+00) ( 0.1000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E-04, 0.0000E+00) ( 0.1000E+04, 0.0000E+00) ( 0.1000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E-03, 0.1000E-03) ( 0.1000E+05, 0.1000E+05)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+05, 0.1000E+05) ( 0.1000E+01, 0.1000E+01) ( 0.1000E-03, 0.1000E-03)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E-03, 0.1000E-03) ( 0.1000E+05, 0.1000E+05) ( 0.1000E+01, 0.1000E+01)
+
+ 0.4000E+01 0.4000E+01 0.4000E+01 0.1000E+00 0.1000E+04 0.1000E-04
+
+ 0.2000E+01 0.3000E+01 0.4000E+01 0.1000E-04 0.1000E+04 0.1000E+00
+
+ 7
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+
+ 3 5
+
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) (
+
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+01, 0.1000E+01) (
+
+ 0.3000E+01 0.2000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.6000E+01
+ 0.5000E+01
+
+ 0.1000E+01 0.3000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.2000E+01
+ 0.2000E+01
+
+ 7
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+06, 0.1000E+06) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+06, 0.1000E+06) ( 0.1000E+06, 0.1000E+06) ( 0.1000E+06, 0.1000E+06)
+( 0.1000E-02, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E-04, 0.1000E-04) ( 0.1000E+06, 0.1000E+06)
+( 0.1000E-03, 0.1000E-03) ( 0.1000E-02, 0.0000E+00) ( 0.1000E+06, 0.1000E+06)
+( 0.1000E+06, 0.1000E+06) (
+( 0.1000E+06, 0.1000E+06) ( 0.1000E+06, 0.1000E+06) ( 0.1000E-02, 0.1000E-02)
+( 0.1000E+06, 0.1000E+01) ( 0.1000E+06, 0.1000E+01) ( 0.1000E+06, 0.1000E+06)
+( 0.1000E+04, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E-03, 0.1000E-04) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+00, 0.1000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.1000E-03, 0.1000E-03)
+( 0.1000E+06, 0.1000E+06) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+06, 0.1000E+06) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E-02, 0.1000E-02) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E-04, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+02, 0.1000E+02) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+06, 0.1000E+06) ( 0.1000E+06, 0.1000E+06) ( 0.1000E-02, 0.1000E-02)
+( 0.1000E+03, 0.0000E+00) (
+
+( 0.0000E+00, 0.0000E+00) ( 0.1000E-01, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+06, 0.1000E+06) ( 0.1000E-02, 0.0000E+00) ( 0.1000E+06, 0.1000E+06)
+( 0.1000E+06, 0.1000E+06) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+06, 0.1000E+06) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+06, 0.1000E+06) ( 0.1000E+06, 0.1000E+06) ( 0.1000E+00, 0.0000E+00)
+( 0.1000E+03, 0.0000E+00) (
+( 0.1000E+06, 0.1000E+06) ( 0.1000E+03, 0.0000E+00) ( 0.1000E+04, 0.0000E+00)
+( 0.1000E+04, 0.0000E+00) ( 0.1000E-03, 0.1000E-02) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E-04, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+06, 0.1000E+06) ( 0.1000E+06, 0.1000E+06) ( 0.1000E+06, 0.1000E+06)
+( 0.1000E+06, 0.1000E+06) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+06, 0.1000E+06) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+06, 0.1000E+06) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+06, 0.1000E+06) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E-03, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+06, 0.1000E+06) ( 0.1000E+06, 0.1000E+06) ( 0.1000E+06, 0.1000E+06)
+( 0.1000E-03, 0.1000E-02) (
+
+ 3 5
+
+( 0.1000E+06, 0.1000E+06) ( 0.1000E-02, 0.1000E-02) ( 0.1000E+05, 0.1000E+05)
+( 0.1000E+03, 0.1000E-02) ( 0.1000E+05, 0.1000E+00) ( 0.1000E+04, 0.0000E+00)
+( 0.1000E+06, 0.1000E+06) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+06, 0.1000E+06) ( 0.1000E+05, 0.1000E+05)
+( 0.1000E-06, 0.1000E-06) ( 0.1000E-03, 0.0000E+00) ( 0.1000E+06, 0.1000E+06)
+( 0.1000E-04, 0.1000E-04) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+03, 0.1000E+03)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+03, 0.1000E+03) ( 0.1000E-04, 0.0000E+00)
+( 0.1000E+04, 0.1000E+04) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E-04, 0.1000E-04)
+( 0.1000E-03, 0.1000E-03) ( 0.1000E+00, 0.1000E+00) ( 0.1000E+06, 0.1000E+06)
+( 0.1000E-03, 0.1000E-04) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E-05, 0.1000E-05)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+03, 0.1000E+03) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+00, 0.1000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E-04, 0.0000E+00)
+( 0.1000E-02, 0.1000E-02) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+06, 0.1000E+06) (
+
+( 0.1000E+06, 0.1000E+06) ( 0.1000E+04, 0.0000E+00) ( 0.1000E+00, 0.0000E+00)
+( 0.1000E+01, 0.0000E+00) ( 0.1000E-04, 0.1000E-03) ( 0.1000E+01, 0.0000E+00)
+( 0.1000E+03, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) ( 0.1000E-01, 0.0000E+00)
+( 0.1000E+03, 0.1000E+03) ( 0.1000E+05, 0.1000E+05) ( 0.1000E+03, 0.0000E+00)
+( 0.1000E+06, 0.1000E+06) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+03, 0.1000E+03)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E-05, 0.0000E+00) ( 0.1000E+04, 0.1000E+04)
+( 0.1000E-03, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+05, 0.1000E+05)
+( 0.1000E+03, 0.1000E+03) ( 0.1000E+05, 0.1000E+05) ( 0.1000E+06, 0.1000E+06)
+( 0.1000E-04, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+03, 0.1000E+03)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+03, 0.1000E+03) ( 0.1000E-05, 0.1000E-04)
+( 0.1000E-05, 0.0000E+00) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+06, 0.1000E+06)
+( 0.1000E+06, 0.1000E+06) (
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.1000E+06, 0.1000E+06) (
+
+ 0.3000E+01 0.2000E+01 0.1000E-01 0.1000E+01 0.1000E-01 0.6000E+01
+ 0.5000E+01
+
+ 0.1000E+01 0.3000E+01 0.1000E+00 0.1000E-02 0.1000E+00 0.2000E+01
+ 0.2000E+01
+
+ 6
+(-0.2000E+02, 0.1000E+01) (-0.1000E+05, 0.1000E+05) (-0.2000E+01, 0.0000E+00)
+(-0.1000E+07, 0.0000E+00) (-0.1000E+02, 0.0000E+00) (-0.2000E+06, 0.1000E+06)
+( 0.6000E-02, 0.0000E+00) ( 0.4000E+01, 0.0000E+00) ( 0.6000E-03, 0.0000E+00)
+( 0.2000E+03, 0.0000E+00) ( 0.3000E-02, 0.0000E+00) ( 0.3000E+02, 0.0000E+00)
+(-0.2000E+00, 0.0000E+00) (-0.3000E+03, 0.0000E+00) (-0.4000E-01, 0.0000E+00)
+(-0.1000E+05, 0.1000E+05) ( 0.0000E+00, 0.0000E+00) ( 0.3000E+04, 0.1000E+04)
+( 0.6000E-04, 0.0000E+00) ( 0.4000E-01, 0.0000E+00) ( 0.9000E-05, 0.0000E+00)
+( 0.9000E+01, 0.0000E+00) ( 0.3000E-04, 0.0000E+00) ( 0.5000E+00, 0.0000E+00)
+( 0.6000E-01, 0.0000E+00) ( 0.5000E+02, 0.0000E+00) ( 0.8000E-02, 0.0000E+00)
+(-0.4000E+04, 0.0000E+00) ( 0.8000E-01, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+04, 0.1000E+04) ( 0.7000E+00, 0.0000E+00)
+(-0.2000E+06, 0.1000E+06) ( 0.1300E+02, 0.0000E+00) (-0.6000E+05, 0.1000E+05)
+
+(-0.2000E+02, 0.0000E+00) (-0.1000E+05, 0.1000E+05) ( 0.2000E+01, 0.0000E+00)
+(-0.2000E+07, 0.0000E+00) ( 0.1000E+02, 0.0000E+00) (-0.1000E+06, 0.1000E+06)
+( 0.5000E-02, 0.0000E+00) ( 0.3000E+01, 0.0000E+00) (-0.2000E-03, 0.0000E+00)
+( 0.4000E+03, 0.0000E+00) (-0.1000E-02, 0.0000E+00) ( 0.3000E+02, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) (-0.1000E+03, 0.0000E+00) (-0.8000E-01, 0.0000E+00)
+( 0.2000E+05, 0.0000E+00) (-0.4000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.5000E-04, 0.0000E+00) ( 0.3000E-01, 0.0000E+00) ( 0.2000E-05, 0.0000E+00)
+( 0.4000E+01, 0.0000E+00) ( 0.2000E-04, 0.0000E+00) ( 0.1000E+00, 0.0000E+00)
+( 0.4000E-01, 0.0000E+00) ( 0.3000E+02, 0.0000E+00) (-0.1000E-02, 0.0000E+00)
+( 0.3000E+04, 0.0000E+00) (-0.1000E-01, 0.0000E+00) ( 0.6000E+03, 0.0000E+00)
+(-0.1000E+01, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.4000E+00, 0.0000E+00)
+(-0.1000E+06, 0.1000E+06) ( 0.4000E+01, 0.0000E+00) ( 0.2000E+05, 0.0000E+00)
+
+ 1 6
+
+(-0.2000E+00, 0.1000E-01) (-0.1000E+01, 0.1000E+01) (-0.2000E+00, 0.0000E+00)
+(-0.1000E+01, 0.0000E+00) (-0.1000E+01, 0.0000E+00) (-0.2000E+00, 0.1000E+00)
+( 0.6000E+00, 0.0000E+00) ( 0.4000E+01, 0.0000E+00) ( 0.6000E+00, 0.0000E+00)
+( 0.2000E+01, 0.0000E+00) ( 0.3000E+01, 0.0000E+00) ( 0.3000E+00, 0.0000E+00)
+(-0.2000E+00, 0.0000E+00) (-0.3000E+01, 0.0000E+00) (-0.4000E+00, 0.0000E+00)
+(-0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.3000E+00, 0.1000E+00)
+( 0.6000E+00, 0.0000E+00) ( 0.4000E+01, 0.0000E+00) ( 0.9000E+00, 0.0000E+00)
+( 0.9000E+01, 0.0000E+00) ( 0.3000E+01, 0.0000E+00) ( 0.5000E+00, 0.0000E+00)
+( 0.6000E+00, 0.0000E+00) ( 0.5000E+01, 0.0000E+00) ( 0.8000E+00, 0.0000E+00)
+(-0.4000E+01, 0.0000E+00) ( 0.8000E+01, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.7000E+00, 0.0000E+00)
+(-0.2000E+01, 0.1000E+01) ( 0.1300E+02, 0.0000E+00) (-0.6000E+00, 0.1000E+00)
+
+(-0.2000E+00, 0.0000E+00) (-0.1000E+01, 0.1000E+01) ( 0.2000E+00, 0.0000E+00)
+(-0.2000E+01, 0.0000E+00) ( 0.1000E+01, 0.0000E+00) (-0.1000E+00, 0.1000E+00)
+( 0.5000E+00, 0.0000E+00) ( 0.3000E+01, 0.0000E+00) (-0.2000E+00, 0.0000E+00)
+( 0.4000E+01, 0.0000E+00) (-0.1000E+01, 0.0000E+00) ( 0.3000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) (-0.1000E+01, 0.0000E+00) (-0.8000E+00, 0.0000E+00)
+( 0.2000E+01, 0.0000E+00) (-0.4000E+01, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.5000E+00, 0.0000E+00) ( 0.3000E+01, 0.0000E+00) ( 0.2000E+00, 0.0000E+00)
+( 0.4000E+01, 0.0000E+00) ( 0.2000E+01, 0.0000E+00) ( 0.1000E+00, 0.0000E+00)
+( 0.4000E+00, 0.0000E+00) ( 0.3000E+01, 0.0000E+00) (-0.1000E+00, 0.0000E+00)
+( 0.3000E+01, 0.0000E+00) (-0.1000E+01, 0.0000E+00) ( 0.6000E+00, 0.0000E+00)
+(-0.1000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.4000E+00, 0.0000E+00)
+(-0.1000E+01, 0.1000E+01) ( 0.4000E+01, 0.0000E+00) ( 0.2000E+00, 0.0000E+00)
+
+ 0.1000E-02 0.1000E+02 0.1000E+00 0.1000E+04 0.1000E+01 0.1000E-01
+
+ 0.1000E+02 0.1000E+00 0.1000E+03 0.1000E-02 0.1000E+03 0.1000E-02
+
+ 6
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.0000E+00, 0.0000E+00)
+
+ 3 4
+
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01) ( 0.1000E+01, 0.1000E+01)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00) ( 0.0000E+00, 0.0000E+00) ( 0.1000E+01, 0.1000E+01)
+
+ 0.1000E+01 0.2000E+01 0.1000E+01 0.1000E+01 0.5000E+01 0.6000E+01
+
+ 0.2000E+01 0.2000E+01 0.1000E+01 0.1000E+01 0.5000E+01 0.5000E+01
+
+0
diff --git a/TESTING/cgd.in b/TESTING/cgd.in
new file mode 100644
index 0000000..da7d4a4
--- /dev/null
+++ b/TESTING/cgd.in
@@ -0,0 +1,182 @@
+CGV Data for the Complex Nonsymmetric Eigenvalue Driver
+6 Number of matrix dimensions
+2 6 8 10 12 20 Matrix dimensions
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+CGV 26 Test all 26 matrix types
+CGS Data for the Complex Nonsymmetric Schur Form Driver
+5 Number of matrix dimensions
+2 6 10 12 20 30 Matrix dimensions
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+CGS 26 Test all 26 matrix types
+CGX Data for the Complex Nonsymmetric Schur Form Expert Driver
+2 Largest matrix dimension (0 <= NSIZE <= 5)
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+CXV Data for the Complex Nonsymmetric Eigenvalue Expert Driver
+6 Number of matrix dimensions
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+CGX Data for the Complex Nonsymmetric Schur Form Expert Driver
+0 Number of matrix dimensions
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+ 4
+ 2
+( 2.0000E+00, 6.0000E+00)
+( 2.0000E+00, 5.0000E+00)
+( 3.0000E+00,-1.0000E+01)
+( 4.0000E+00, 7.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 9.0000E+00, 2.0000E+00)
+( 1.6000E+01,-2.4000E+01)
+( 7.0000E+00,-7.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 8.0000E+00,-3.0000E+00)
+( 9.0000E+00,-8.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+01,-1.6000E+01)
+(-9.0000E+00, 1.0000E+00)
+(-1.0000E+00,-8.0000E+00)
+(-1.0000E+00, 1.0000E+01)
+( 2.0000E+00,-6.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+(-1.0000E+00, 4.0000E+00)
+( 1.0000E+00, 1.6000E+01)
+(-6.0000E+00, 4.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00,-1.4000E+01)
+(-1.0000E+00, 6.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 8.0000E+00, 4.0000E+00)
+ 7.6883E-02 2.1007E-01 Condition #'s for cluster selected from lower 2x2
+ 4
+ 2
+( 1.0000E+00, 8.0000E+00)
+( 2.0000E+00, 4.0000E+00)
+( 3.0000E+00,-1.3000E+01)
+( 4.0000E+00, 4.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 5.0000E+00, 7.0000E+00)
+( 6.0000E+00,-2.4000E+01)
+( 7.0000E+00,-3.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 8.0000E+00, 3.0000E+00)
+( 9.0000E+00,-5.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+01, 1.6000E+01)
+(-1.0000E+00, 9.0000E+00)
+(-1.0000E+00,-1.0000E+00)
+(-1.0000E+00, 1.0000E+00)
+(-1.0000E+00,-6.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+(-1.0000E+00, 4.0000E+00)
+(-1.0000E+00, 1.6000E+01)
+(-1.0000E+00,-2.4000E+01)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00,-1.1000E+01)
+(-1.0000E+00, 6.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 4.0000E+00)
+ 4.2067E-01 4.9338E+00 Condition #'s for cluster selected from lower 2x2
+0
+CXV Data for the Complex Nonsymmetric Eigenvalue Expert Driver
+0 Number of matrix dimensions
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+ 4
+( 2.0000E+00, 6.0000E+00)
+( 2.0000E+00, 5.0000E+00)
+( 3.0000E+00,-1.0000E+01)
+( 4.0000E+00, 7.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 9.0000E+00, 2.0000E+00)
+( 1.6000E+01,-2.4000E+01)
+( 7.0000E+00,-7.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 8.0000E+00,-3.0000E+00)
+( 9.0000E+00,-8.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+01,-1.6000E+01)
+(-9.0000E+00, 1.0000E+00)
+(-1.0000E+00,-8.0000E+00)
+(-1.0000E+00, 1.0000E+01)
+( 2.0000E+00,-6.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+(-1.0000E+00, 4.0000E+00)
+( 1.0000E+00, 1.6000E+01)
+(-6.0000E+00, 4.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00,-1.4000E+01)
+(-1.0000E+00, 6.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 8.0000E+00, 4.0000E+00)
+ 5.2612E+00 8.0058E-01 1.4032E+00 4.0073E+00 condition #'s for eigenvalues
+ 1.1787E+00 3.3139E+00 1.1835E+00 2.0777E+00 condition #'s for eigenvectors
+ 4
+( 1.0000E+00, 8.0000E+00)
+( 2.0000E+00, 4.0000E+00)
+( 3.0000E+00,-1.3000E+01)
+( 4.0000E+00, 4.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 5.0000E+00, 7.0000E+00)
+( 6.0000E+00,-2.4000E+01)
+( 7.0000E+00,-3.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 8.0000E+00, 3.0000E+00)
+( 9.0000E+00,-5.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+01, 1.6000E+01)
+(-1.0000E+00, 9.0000E+00)
+(-1.0000E+00,-1.0000E+00)
+(-1.0000E+00, 1.0000E+00)
+(-1.0000E+00,-6.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+(-1.0000E+00, 4.0000E+00)
+(-1.0000E+00, 1.6000E+01)
+(-1.0000E+00,-2.4000E+01)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00,-1.1000E+01)
+(-1.0000E+00, 6.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 0.0000E+00, 0.0000E+00)
+( 1.0000E+00, 4.0000E+00)
+ 4.9068E+00 1.6813E+00 3.4636E+00 5.2436E+00 condition #'s for eigenvalues
+ 1.0386E+00 1.4728E+00 2.0029E+00 9.8365E-01 condition #'s for eigenvectors
+0
diff --git a/TESTING/cgg.in b/TESTING/cgg.in
new file mode 100644
index 0000000..8e44e45
--- /dev/null
+++ b/TESTING/cgg.in
@@ -0,0 +1,15 @@
+CGG: Data file for testing Nonsymmetric Eigenvalue Problem routines
+7 Number of values of N
+0 1 2 3 5 10 16 Values of N (dimension)
+4 Number of parameter values
+1 1 2 2 Values of NB (blocksize)
+40 40 2 2 Values of NBMIN (minimum blocksize)
+2 4 2 4 Values of NSHIFT (no. of shifts)
+40 40 2 2 Values of MAXB (multishift crossover pt)
+40 40 2 2 Values of NBCOL (minimum col. dimension)
+20.0 Threshold value
+T Put T to test the LAPACK routines
+T Put T to test the driver routines
+T Put T to test the error exits
+1 Code to interpret the seed
+CGG 26
diff --git a/TESTING/csb.in b/TESTING/csb.in
new file mode 100644
index 0000000..741f166
--- /dev/null
+++ b/TESTING/csb.in
@@ -0,0 +1,9 @@
+CHB: Data file for testing Hermitian Eigenvalue Problem routines
+2 Number of values of N
+5 20 Values of N (dimension)
+5 Number of values of K
+0 1 2 5 16 Values of K (band width)
+20.0 Threshold value
+T Put T to test the error exits
+1 Code to interpret the seed
+CHB 15
diff --git a/TESTING/csg.in b/TESTING/csg.in
new file mode 100644
index 0000000..aefe0ec
--- /dev/null
+++ b/TESTING/csg.in
@@ -0,0 +1,13 @@
+CSG: Data file for testing Generalized Hermitian Eigenvalue Problem routines
+7 Number of values of N
+0 1 2 3 5 10 16 Values of N (dimension)
+3 Number of values of NB
+1 3 20 Values of NB (blocksize)
+2 2 2 Values of NBMIN (minimum blocksize)
+1 1 1 Values of NX (crossover point)
+20.0 Threshold value
+T Put T to test the LAPACK routines
+T Put T to test the driver routines
+T Put T to test the error exits
+1 Code to interpret the seed
+CSG 21
diff --git a/TESTING/ctest.in b/TESTING/ctest.in
new file mode 100644
index 0000000..b0b2290
--- /dev/null
+++ b/TESTING/ctest.in
@@ -0,0 +1,39 @@
+Data file for testing COMPLEX LAPACK linear equation routines
+7 Number of values of M
+0 1 2 3 5 10 50 Values of M (row dimension)
+7 Number of values of N
+0 1 2 3 5 10 50 Values of N (column dimension)
+3 Number of values of NRHS
+1 2 15 Values of NRHS (number of right hand sides)
+5 Number of values of NB
+1 3 3 3 20 Values of NB (the blocksize)
+1 0 5 9 1 Values of NX (crossover point)
+3 Number of values of RANK
+30 50 90 Values of rank (as a % of N)
+30.0 Threshold value of test ratio
+T Put T to test the LAPACK routines
+T Put T to test the driver routines
+T Put T to test the error exits
+CGE 11 List types on next line if 0 < NTYPES < 11
+CGB 8 List types on next line if 0 < NTYPES < 8
+CGT 12 List types on next line if 0 < NTYPES < 12
+CPO 9 List types on next line if 0 < NTYPES < 9
+CPS 9 List types on next line if 0 < NTYPES < 9
+CPP 9 List types on next line if 0 < NTYPES < 9
+CPB 8 List types on next line if 0 < NTYPES < 8
+CPT 12 List types on next line if 0 < NTYPES < 12
+CHE 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
+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
+CTB 17 List types on next line if 0 < NTYPES < 17
+CQR 8 List types on next line if 0 < NTYPES < 8
+CRQ 8 List types on next line if 0 < NTYPES < 8
+CLQ 8 List types on next line if 0 < NTYPES < 8
+CQL 8 List types on next line if 0 < NTYPES < 8
+CQP 6 List types on next line if 0 < NTYPES < 6
+CTZ 3 List types on next line if 0 < NTYPES < 3
+CLS 6 List types on next line if 0 < NTYPES < 6
+CEQ
diff --git a/TESTING/ctest_rfp.in b/TESTING/ctest_rfp.in
new file mode 100644
index 0000000..d6988f2
--- /dev/null
+++ b/TESTING/ctest_rfp.in
@@ -0,0 +1,9 @@
+Data file for testing COMPLEX LAPACK linear equation routines RFP format
+9 Number of values of N (at most 9)
+0 1 2 3 5 6 10 11 50 Values of N
+3 Number of values of NRHS (at most 9)
+1 2 15 Values of NRHS (number of right hand sides)
+9 Number of matrix types (list types on next line if 0 < NTYPES < 9)
+1 2 3 4 5 6 7 8 9 Matrix Types
+30.0 Threshold value of test ratio
+T Put T to test the error exits
diff --git a/TESTING/dbak.in b/TESTING/dbak.in
new file mode 100644
index 0000000..cb69cb3
--- /dev/null
+++ b/TESTING/dbak.in
@@ -0,0 +1,130 @@
+DBK: Tests DGEBAK
+ 5 1 1
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01
+
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 5 1 1
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 0.1000D+01 0.1000D+01 0.1000D+01 -0.6667D+00 -0.4167D-01
+ 0.0000D+00 -0.2500D+00 -0.6667D+00 0.1000D+01 0.1667D+00
+ 0.0000D+00 0.0000D+00 0.2222D+00 -0.1000D+01 -0.5000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+00 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -0.1000D+01
+
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+00 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.2222D+00 -0.1000D+01 -0.5000D+00
+ 0.0000D+00 -0.2500D+00 -0.6667D+00 0.1000D+01 0.1667D+00
+ 0.1000D+01 0.1000D+01 0.1000D+01 -0.6667D+00 -0.4167D-01
+
+ 5 1 1
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.0000D+00 -0.6000D-17 -0.6000D-17 -0.6000D-17 -0.6000D-17
+ 0.0000D+00 0.0000D+00 0.3600D-34 0.3600D-34 0.3600D-34
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.3600D-34 0.3600D-34 0.3600D-34
+ 0.0000D+00 -0.6000D-17 -0.6000D-17 -0.6000D-17 -0.6000D-17
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+
+ 6 4 6
+ 0.4000D+01 0.3000D+01 0.5000D+01 0.1000D+03 0.1000D+00 0.1000D+01
+
+ 0.1000D+01 0.1336D-05 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 -0.3001D-10 -0.3252D-04 0.1305D-01
+ 0.0000D+00 0.0000D+00 -0.8330D-02 0.8929D-09 -0.6712D-04 0.6687D-04
+ 0.0000D+00 0.0000D+00 0.0000D+00 -0.4455D-05 -0.3355D-02 0.3345D-02
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.4455D-06 -0.3356D-01 0.3344D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.4411D-09 0.1011D+00 0.1008D+00
+
+ 0.0000D+00 0.0000D+00 0.0000D+00 -0.4455D-03 -0.3355D+00 0.3345D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.4455D-07 -0.3356D-02 0.3344D-02
+ 0.0000D+00 0.1000D+01 0.0000D+00 -0.3001D-10 -0.3252D-04 0.1305D-01
+ 0.1000D+01 0.1336D-05 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 -0.8330D-02 0.8929D-09 -0.6712D-04 0.6687D-04
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.4411D-09 0.1011D+00 0.1008D+00
+
+ 5 1 5
+ 0.1000D+03 0.1000D+00 0.1000D-01 0.1000D+01 0.1000D+02
+
+ 0.1366D-03 -0.6829D-04 0.1252D-03 0.1000D+01 0.1950D-14
+ 0.1000D+01 0.1000D+01 -0.2776D-16 0.3601D-05 -0.6073D-17
+ 0.2736D+00 -0.1363D+00 0.2503D+00 -0.3322D-05 -0.2000D-02
+ 0.6909D-02 -0.3443D-02 0.6196D-02 0.1666D-01 0.1000D+01
+ 0.3899D+00 -0.2033D+00 -0.3420D+00 -0.1000D-02 0.6000D-14
+
+ 0.1366D-01 -0.6829D-02 0.1252D-01 0.1000D+03 0.1950D-12
+ 0.1000D+00 0.1000D+00 -0.2776D-17 0.3601D-06 -0.6073D-18
+ 0.2736D-02 -0.1363D-02 0.2503D-02 -0.3322D-07 -0.2000D-04
+ 0.6909D-02 -0.3443D-02 0.6196D-02 0.1666D-01 0.1000D+01
+ 0.3899D+01 -0.2033D+01 -0.3420D+01 -0.1000D-01 0.6000D-13
+
+ 6 2 5
+ 0.3000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.4000D+01
+
+ 0.1000D+01 0.1000D+01 0.2776D-15 -0.2405D-16 0.0000D+00 0.1000D+01
+ 0.0000D+00 0.7500D+00 0.1000D+01 0.8520D-01 0.0000D+00 -0.1520D-16
+ 0.0000D+00 0.7500D+00 -0.8093D+00 0.1000D+01 0.0000D+00 -0.1520D-16
+ 0.0000D+00 0.7500D+00 -0.9533D-01 -0.5426D+00 0.1000D+01 -0.1520D-16
+ 0.0000D+00 0.7500D+00 -0.9533D-01 -0.5426D+00 -0.1000D+01 -0.1520D-16
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.4559D-16
+
+ 0.0000D+00 0.7500D+00 -0.8093D+00 0.1000D+01 0.0000D+00 -0.1520D-16
+ 0.0000D+00 0.7500D+00 0.1000D+01 0.8520D-01 0.0000D+00 -0.1520D-16
+ 0.1000D+01 0.1000D+01 0.2776D-15 -0.2405D-16 0.0000D+00 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.4559D-16
+ 0.0000D+00 0.7500D+00 -0.9533D-01 -0.5426D+00 -0.1000D+01 -0.1520D-16
+ 0.0000D+00 0.7500D+00 -0.9533D-01 -0.5426D+00 0.1000D+01 -0.1520D-16
+
+ 7 2 5
+ 0.3000D+01 0.1000D-02 0.1000D-01 0.1000D+02 0.1000D+00 0.1000D+01
+ 0.6000D+01
+
+ 0.1000D+01 -0.1105D-01 0.3794D-01 -0.9378D-01 -0.3481D-01 0.4465D+00
+ -0.3602D-01
+ 0.0000D+00 -0.4556D+00 -0.4545D+00 0.1000D+01 0.4639D+00 -0.6512D+00
+ 0.4781D+00
+ 0.0000D+00 -0.2734D+00 -0.7946D+00 0.6303D+00 0.1000D+01 -0.6279D+00
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 -0.6939D-17 0.4259D-01 -0.6495D+00 -0.5581D+00
+ -0.6452D+00
+ 0.0000D+00 -0.3904D+00 -0.4029D+00 -0.1685D+00 -0.9429D+00 0.1000D+01
+ -0.9371D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -0.2558D+00
+ 0.3308D-03
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ -0.1985D-02
+
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -0.2558D+00
+ 0.3308D-03
+ 0.0000D+00 -0.4556D-03 -0.4545D-03 0.1000D-02 0.4639D-03 -0.6512D-03
+ 0.4781D-03
+ 0.1000D+01 -0.1105D-01 0.3794D-01 -0.9378D-01 -0.3481D-01 0.4465D+00
+ -0.3602D-01
+ 0.0000D+00 0.1000D+02 -0.6939D-16 0.4259D+00 -0.6495D+01 -0.5581D+01
+ -0.6452D+01
+ 0.0000D+00 -0.3904D-01 -0.4029D-01 -0.1685D-01 -0.9429D-01 0.1000D+00
+ -0.9371D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ -0.1985D-02
+ 0.0000D+00 -0.2734D-02 -0.7946D-02 0.6303D-02 0.1000D-01 -0.6279D-02
+ 0.1000D-01
+
+ 0 0 0
diff --git a/TESTING/dbal.in b/TESTING/dbal.in
new file mode 100644
index 0000000..103d090
--- /dev/null
+++ b/TESTING/dbal.in
@@ -0,0 +1,215 @@
+DBL: Tests DGEBAL
+ 5
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+01
+
+ 1 1
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01
+
+ 5
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01
+
+ 1 1
+ 0.5000D+01 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 5
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01
+
+ 1 1
+ 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 4
+ 0.0000D+00 0.2000D+01 0.1000D+00 0.0000D+00
+ 0.2000D+01 0.0000D+00 0.0000D+00 0.1000D+00
+ 0.1000D+03 0.0000D+00 0.0000D+00 0.2000D+01
+ 0.0000D+00 0.1000D+03 0.2000D+01 0.0000D+00
+
+ 1 4
+ 0.0000D-03 2.0000D+00 3.2000D+00 0.0000D-03
+ 2.0000D+00 0.0000D-03 0.0000D-03 3.2000D+00
+ 3.1250D+00 0.0000D-03 0.0000D-03 2.0000D+00
+ 0.0000D-03 3.1250D+00 2.0000D+00 0.0000D-03
+
+ 62.5000D-03 62.5000D-03 2.0000D+00 2.0000D+00
+
+ 6
+ 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1024D+04
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1280D+03
+ 0.0000D+00 0.2000D+01 0.3000D+04 0.0000D+00 0.0000D+00 0.2000D+01
+ 0.1280D+03 0.4000D+01 0.4000D-02 0.5000D+01 0.6000D+03 0.8000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D-02 0.2000D+01
+ 0.8000D+01 0.8192D+04 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01
+
+ 4 6
+ 0.5000D+01 0.4000D-02 0.6000D+03 0.1024D+04 0.5000D+00 0.8000D+01
+ 0.0000D+00 0.3000D+04 0.0000D+00 0.0000D+00 0.2500D+00 0.2000D+01
+ 0.0000D+00 0.0000D+00 0.2000D-02 0.0000D+00 0.0000D+00 0.2000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.0000D+00 0.1280D+03
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1024D+04
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.6400D+02 0.1024D+04 0.2000D+01
+
+ 0.4000D+01 0.3000D+01 0.5000D+01 0.8000D+01 0.1250D+00 0.1000D+01
+
+ 5
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.8000D+01
+ 0.0000D+00 0.2000D+01 0.8192D+04 0.2000D+01 0.4000D+01
+ 0.2500D-03 0.1250D-03 0.4000D+01 0.0000D+00 0.6400D+02
+ 0.0000D+00 0.2000D+01 0.1024D+04 0.4000D+01 0.8000D+01
+ 0.0000D+00 0.8192D+04 0.0000D+00 0.0000D+00 0.8000D+01
+
+ 1 5
+ 1.0000D+00 0.0000D-03 0.0000D-03 0.0000D-03 250.0000D-03
+ 0.0000D-03 2.0000D+00 1.0240D+03 16.0000D+00 16.0000D+00
+ 256.0000D-03 1.0000D-03 4.0000D+00 0.0000D-03 2.0480D+03
+ 0.0000D-03 250.0000D-03 16.0000D+00 4.0000D+00 4.0000D+00
+ 0.0000D-03 2.0480D+03 0.0000D-03 0.0000D-03 8.0000D+00
+
+ 64.0000D+00 500.0000D-03 62.5000D-03 4.0000D+00 2.0000D+00
+
+ 4
+ 0.1000D+01 0.1000D+07 0.1000D+07 0.1000D+07
+ -0.2000D+07 0.3000D+01 0.2000D-05 0.3000D-05
+ -0.3000D+07 0.0000D+00 0.1000D-05 0.2000D+01
+ 0.1000D+07 0.0000D+00 0.3000D-05 0.4000D+07
+
+ 1 4
+ 1.0000D+00 1.0000D+06 2.0000D+06 1.0000D+06
+ -2.0000D+06 3.0000D+00 4.0000D-06 3.0000D-06
+ -1.5000D+06 0.0000D-03 1.0000D-06 1.0000D+00
+ 1.0000D+06 0.0000D-03 6.0000D-06 4.0000D+06
+
+ 1.0000D+00 1.0000D+00 2.0000D+00 1.0000D+00
+
+ 4
+ 0.1000D+01 0.1000D+05 0.1000D+05 0.1000D+05
+ -0.2000D+05 0.3000D+01 0.2000D-02 0.3000D-02
+ 0.0000D+00 0.2000D+01 0.0000D+00 -0.3000D+05
+ 0.0000D+00 0.0000D+00 0.1000D+05 0.0000D+00
+
+ 1 4
+ 1.0000D+00 10.0000D+03 10.0000D+03 5.0000D+03
+ -20.0000D+03 3.0000D+00 2.0000D-03 1.5000D-03
+ 0.0000D-03 2.0000D+00 0.0000D-03 -15.0000D+03
+ 0.0000D-03 0.0000D-03 20.0000D+03 0.0000D-03
+
+ 1.0000D+00 1.0000D+00 1.0000D+00 500.0000D-03
+
+ 5
+ 0.1000D+01 0.5120D+03 0.4096D+04 3.2768D+04 2.62144D+05
+ 0.8000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.8000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.8000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.8000D+01 0.0000D+00
+
+ 1 5
+ 1.0000D+00 32.0000D+00 32.0000D+00 32.0000D+000 32.0000D+00
+ 128.0000D+00 0.0000D-03 0.0000D-03 0.0000D-003 0.0000D-03
+ 0.0000D-03 64.0000D+00 0.0000D-03 0.0000D-003 0.0000D-03
+ 0.0000D-03 0.0000D-03 64.0000D+00 0.0000D-003 0.0000D-03
+ 0.0000D-03 0.0000D-03 0.0000D-03 64.0000D+000 0.0000D-03
+
+ 256.0000D+00 16.0000D+00 2.0000D+00 250.0000D-03 31.2500D-03
+
+ 6
+ 0.1000D+01 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+
+ 2 5
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.3000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.4000D+01
+
+ 7
+ 0.6000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.4000D+01 0.0000D+00 0.2500D-03 0.1250D-01 0.2000D-01 0.1250D+00
+ 0.1000D+01 0.1280D+03 0.6400D+02 0.0000D+00 0.0000D+00 -0.2000D+01 0.1600D+02
+ 0.0000D+00 1.6384D+04 0.0000D+00 0.1000D+01 -0.4000D+03 0.2560D+03 -0.4000D+04
+ -0.2000D+01 -0.2560D+03 0.0000D+00 0.1250D-01 0.2000D+01 0.2000D+01 0.3200D+02
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.8000D+01 0.0000D+00 0.4000D-02 0.1250D+00 -0.2000D+00 0.3000D+01
+
+ 2 5
+ 6.4000D+01 2.5000D-01 5.00000D-01 0.0000D+00 0.0000D+00 1.0000D+00 -2.0000D+00
+ 0.0000D+00 4.0000D+00 2.00000D+00 4.0960D+00 1.6000D+00 0.0000D+00 1.0240D+01
+ 0.0000D+00 5.0000D-01 3.00000D+00 4.0960D+00 1.0000D+00 0.0000D+00 -6.4000D+00
+ 0.0000D+00 1.0000D+00 -3.90625D+00 1.0000D+00 -3.1250D+00 0.0000D+00 8.0000D+00
+ 0.0000D+00 -2.0000D+00 4.00000D+00 1.6000D+00 2.0000D+00 -8.0000D+00 8.0000D+00
+ 0.0000D+00 0.0000D+00 0.00000D+00 0.0000D+00 0.0000D+00 6.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.00000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+
+ 3.0000D+00 1.953125D-03 3.1250D-02 3.2000D+01 2.5000D-01 1.0000D+00 6.0000D+00
+
+ 5
+ 0.1000D+04 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+06
+ 0.9000D+01 0.0000D+00 0.2000D-03 0.1000D+01 0.3000D+01
+ 0.0000D+00 -0.3000D+03 0.2000D+01 0.1000D+01 0.1000D+01
+ 0.9000D+01 0.2000D-02 0.1000D+01 0.1000D+01 -0.1000D+04
+ 0.6000D+01 0.2000D+03 0.1000D+01 0.6000D+03 0.3000D+01
+
+ 1 5
+ 1.0000D+03 3.1250D-02 3.7500D-01 6.2500D-02 3.90625D+03
+ 5.7600D+02 0.0000D+00 1.6000D-03 1.0000D+00 1.5000D+00
+ 0.0000D+00 -3.7500D+01 2.0000D+00 1.2500D-01 6.2500D-02
+ 5.7600D+02 2.0000D-03 8.0000D+00 1.0000D+00 -5.0000D+02
+ 7.6800D+02 4.0000D+02 1.6000D+01 1.2000D+03 3.0000D+00
+
+ 1.2800D+02 2.0000D+00 1.6000D+01 2.0000D+00 1.0000D+00
+
+ 6
+ 1.0000D+00 1.0000D+120 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 1.0000D-120 1.0000D+00 1.0000D+120 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D-120 1.0000D+00 1.0000D+120 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D-120 1.0000D+00 1.0000D+120 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D-120 1.0000D+00 1.0000D+120
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D-120 1.0000D+00
+
+ 1 6
+ 1.000000000000000000D+00 6.344854593289122931D+03 0.000000000000000000D+00 0.000000000000000000D+00 0.000000000000000000D+00 0.000000000000000000D+00
+ 1.576080247855779135D-04 1.000000000000000000D+00 6.344854593289122931D+03 0.000000000000000000D+00 0.000000000000000000D+00 0.000000000000000000D+00
+ 0.000000000000000000D+00 1.576080247855779135D-04 1.000000000000000000D+00 3.172427296644561466D+03 0.000000000000000000D+00 0.000000000000000000D+00
+ 0.000000000000000000D+00 0.000000000000000000D+00 3.152160495711558270D-04 1.000000000000000000D+00 1.586213648322280733D+03 0.000000000000000000D+00
+ 0.000000000000000000D+00 0.000000000000000000D+00 0.000000000000000000D+00 6.304320991423116539D-04 1.000000000000000000D+00 1.586213648322280733D+03
+ 0.000000000000000000D+00 0.000000000000000000D+00 0.000000000000000000D+00 0.000000000000000000D+00 6.304320991423116539D-04 1.000000000000000000D+00
+
+ 2.494800386918399765D+291 1.582914569427869018D+175 1.004336277661868922D+59 3.186183822264904554D-58 5.053968264940243633D-175 8.016673440035891112D-292
+
+
+0
diff --git a/TESTING/dbb.in b/TESTING/dbb.in
new file mode 100644
index 0000000..3303274
--- /dev/null
+++ b/TESTING/dbb.in
@@ -0,0 +1,12 @@
+DBB: Data file for testing banded Singular Value Decomposition routines
+20 Number of values of M
+0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 10 10 16 16 Values of M
+0 1 2 3 0 1 2 3 0 1 2 3 0 1 2 3 10 16 10 16 Values of N
+5 Number of values of K
+0 1 2 3 16 Values of K (band width)
+2 Number of values of NRHS
+1 2 Values of NRHS
+20.0 Threshold value
+F Put T to test the error exits
+1 Code to interpret the seed
+DBB 15
diff --git a/TESTING/dec.in b/TESTING/dec.in
new file mode 100644
index 0000000..50837a1
--- /dev/null
+++ b/TESTING/dec.in
@@ -0,0 +1,950 @@
+DEC Key indicating type of input
+20.0 Threshold value for test ratios
+ 8 2 7
+ 1.0D+00 1.0D+00 1.1D+00 1.3D+00 2.0D+00 3.0D+00 -4.7D+00 3.3D+00
+ -1.0D+00 1.0D+00 3.7D+00 7.9D+00 4.0D+00 5.3D+00 3.3D+00 -9.0D-01
+ 0.0D+00 0.0D+00 2.0D+00 -3.0D+00 3.4D+00 6.5D+00 5.2D+00 1.8D+00
+ 0.0D+00 0.0D+00 4.0D+00 2.0D+00 -5.3D+00 -8.9D+00 -2.0D-01 -5.0D-01
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 4.2D+00 2.0D+00 3.3D+00 2.3D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -3.7D+00 4.2D+00 9.9D+00 8.8D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 9.9D+00 8.8D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.9D+00 9.9D+00
+ 8 7 2
+ 1.0D+00 1.0D+00 1.1D+00 1.3D+00 2.0D+00 3.0D+00 -4.7D+00 3.3D+00
+ -1.0D+00 1.0D+00 3.7D+00 7.9D+00 4.0D+00 5.3D+00 3.3D+00 -9.0D-01
+ 0.0D+00 0.0D+00 2.0D+00 -3.0D+00 3.4D+00 6.5D+00 5.2D+00 1.8D+00
+ 0.0D+00 0.0D+00 4.0D+00 2.0D+00 -5.3D+00 -8.9D+00 -2.0D-01 -5.0D-01
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 4.2D+00 2.0D+00 3.3D+00 2.3D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -3.7D+00 4.2D+00 9.9D+00 8.8D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 9.9D+00 8.8D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.9D+00 9.9D+00
+ 8 1 7
+ 1.0D+00 1.0D+00 1.1D+00 1.3D+00 2.0D+00 3.0D+00 -4.7D+00 3.3D+00
+ 0.0D+00 1.0D+00 3.7D+00 7.9D+00 4.0D+00 5.3D+00 3.3D+00 -9.0D-01
+ 0.0D+00 0.0D+00 2.0D+00 -3.0D+00 3.4D+00 6.5D+00 5.2D+00 1.8D+00
+ 0.0D+00 0.0D+00 4.0D+00 2.0D+00 -5.3D+00 -8.9D+00 -2.0D-01 -5.0D-01
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 4.2D+00 2.0D+00 3.3D+00 2.3D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 4.2D+00 9.9D+00 8.8D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 9.9D+00 8.8D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.9D+00 9.9D+00
+ 8 8 2
+ 1.0D+00 1.0D+00 1.1D+00 1.3D+00 2.0D+00 3.0D+00 -4.7D+00 3.3D+00
+ -1.1D+00 1.0D+00 3.7D+00 7.9D+00 4.0D+00 5.3D+00 3.3D+00 -9.0D-01
+ 0.0D+00 0.0D+00 2.0D+00 -3.0D+00 3.4D+00 6.5D+00 5.2D+00 1.8D+00
+ 0.0D+00 0.0D+00 0.0D+00 2.0D+00 -5.3D+00 -8.9D+00 -2.0D-01 -5.0D-01
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 4.2D+00 2.0D+00 3.3D+00 2.3D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -3.7D+00 4.2D+00 9.9D+00 8.8D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 9.9D+00 8.8D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 9.9D+00
+ 7 2 7
+ 1.1D+00 1.0D-16 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
+ -1.0D-16 1.1D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
+ 0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
+ 0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D+00 6.5D+00 3.2D+00
+ 0.0D+00 0.0D+00 0.0D+00 -9.0D-01 3.9D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-01 6.3D+00
+ 7 2 7
+ 1.1D+00 1.0D-16 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
+ -1.0D-16 1.1D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
+ 0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
+ 0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D-15 6.5D+00 3.2D+00
+ 0.0D+00 0.0D+00 0.0D+00 -9.0D-16 3.9D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.4D+00
+ 7 2 7
+ 1.1D+00 1.0D-16 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
+ -1.0D-16 1.1D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
+ 0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
+ 0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D-15 6.5D+00 3.2D+00
+ 0.0D+00 0.0D+00 0.0D+00 -9.0D-16 3.9D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-21 6.3D+00
+ 7 1 7
+ 1.1D+00 1.0D-16 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
+ 0.0D+00 1.1D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
+ 0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
+ 0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D-15 6.5D+00 3.2D+00
+ 0.0D+00 0.0D+00 0.0D+00 -9.0D-16 3.9D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-21 6.3D+00
+ 7 1 7
+ 1.1D+00 -1.1D+00 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
+ 2.3D+00 1.1D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
+ 0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
+ 0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D+00 6.5D+00 3.2D+00
+ 0.0D+00 0.0D+00 0.0D+00 -9.0D-21 3.9D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D-20
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-21 6.3D+00
+ 7 7 2
+ 6.3D+00 3.0D+00 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
+ -9.0D-01 6.3D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
+ 0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
+ 0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D+00 6.5D+00 3.2D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 3.8D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 1.1D+00 1.4D-20
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -1.6D-20 1.1D+00
+ 7 7 2
+ 6.3D+00 3.0D+00 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
+ -9.0D-01 6.3D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
+ 0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
+ 0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D+00 6.5D+00 3.2D+00
+ 0.0D+00 0.0D+00 0.0D+00 -9.0D-01 3.9D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 1.1D+00 1.4D-20
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -1.6D-20 1.1D+00
+ 7 7 2
+ 1.1D+00 1.0D-16 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
+ -1.0D-16 1.1D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
+ 0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
+ 0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D-15 6.5D+00 3.2D+00
+ 0.0D+00 0.0D+00 0.0D+00 -9.0D-16 3.9D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-21 6.3D+00
+ 7 7 1
+ 1.1D+00 1.0D-16 2.7D+06 3.3D+00 2.3D+00 3.4D+00 5.6D+00
+ 0.0D+00 1.1D+00 4.2D+06 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
+ 0.0D+00 0.0D+00 2.3D+00 1.0D+07 1.0D+08 1.0D+03 1.0D+02
+ 0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D-15 6.5D+04 3.2D+00
+ 0.0D+00 0.0D+00 0.0D+00 -9.0D-16 3.9D+00 6.3D+03 3.0D+05
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-21 6.3D+00
+ 8 8 1
+ 1.1D+00 -1.0D-16 2.7D+06 2.3D+04 3.3D+00 2.3D+00 3.4D+00 5.6D+00
+ 1.0D-16 1.1D+00 4.2D+06 -1.0D-01 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
+ 0.0D+00 0.0D+00 2.3D+00 1.1D-16 1.0D+07 1.0D+08 1.0D+03 1.0D+02
+ 0.0D+00 0.0D+00 -1.1D-13 2.3D+00 1.0D+07 1.0D+08 1.0D+03 1.0D+02
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D-15 6.5D+04 3.2D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-16 3.9D+00 6.3D+03 3.0D+05
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D-20
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-21 6.3D+00
+ 0 0 0
+ 1
+ 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 1
+ 1.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 2
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 2
+ 3.0000D+00 2.0000D+00
+ 2.0000D+00 3.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 4.0000D+00
+ 5.0000D+00 0.0000D+00 1.0000D+00 4.0000D+00
+ 2
+ 3.0000D+00 -2.0000D+00
+ 2.0000D+00 3.0000D+00
+ 3.0000D+00 2.0000D+00 1.0000D+00 4.0000D+00
+ 3.0000D+00 -2.0000D+00 1.0000D+00 4.0000D+00
+ 6
+ 1.0000D-07 -1.0000D-07 1.0000D+00 1.1000D+00 2.3000D+00 3.7000D+00
+ 3.0000D-07 1.0000D-07 1.0000D+00 1.0000D+00 -1.3000D+00 -7.7000D+00
+ 0.0000D+00 0.0000D+00 3.0000D-07 1.0000D-07 2.2000D+00 3.3000D+00
+ 0.0000D+00 0.0000D+00 -1.0000D-07 3.0000D-07 1.8000D+00 1.6000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 4.0000D-06 5.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 3.0000D+00 4.0000D-06
+ -3.8730D+00 0.0000D+00 6.9855D-01 2.2823D+00
+ 1.0000D-07 1.7321D-07 9.7611D-08 5.0060D-14
+ 1.0000D-07 -1.7321D-07 9.7611D-08 5.0060D-14
+ 3.0000D-07 1.0000D-07 1.0000D-07 9.4094D-14
+ 3.0000D-07 -1.0000D-07 1.0000D-07 9.4094D-14
+ 3.8730D+00 0.0000D+00 4.0659D-01 1.5283D+00
+ 4
+ 7.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
+ -1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
+ -1.0000D+00 1.0000D+00 5.0000D+00 -3.0000D+00
+ 1.0000D+00 -1.0000D+00 3.0000D+00 3.0000D+00
+ 3.9603D+00 4.0425D-02 1.1244D-05 3.1179D-05
+ 3.9603D+00 -4.0425D-02 1.1244D-05 3.1179D-05
+ 4.0397D+00 3.8854D-02 1.0807D-05 2.9981D-05
+ 4.0397D+00 -3.8854D-02 1.0807D-05 2.9981D-05
+ 5
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 5
+ 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 6
+ 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 6
+ 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 6
+ 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 2.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 3.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 5.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 6.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 2.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 3.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 4.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 5.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 6.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 4
+ 9.4480D-01 6.7670D-01 6.9080D-01 5.9650D-01
+ 5.8760D-01 8.6420D-01 6.7690D-01 7.2600D-02
+ 7.2560D-01 1.9430D-01 9.6870D-01 2.8310D-01
+ 2.8490D-01 5.8000D-02 4.8450D-01 7.3610D-01
+ 2.4326D-01 2.1409D-01 8.7105D-01 3.5073D-01
+ 2.4326D-01 -2.1409D-01 8.7105D-01 3.5073D-01
+ 7.4091D-01 0.0000D+00 9.8194D-01 4.6989D-01
+ 2.2864D+00 0.0000D+00 9.7723D-01 1.5455D+00
+ 6
+ 5.0410D-01 6.6520D-01 7.7190D-01 6.3870D-01 5.9550D-01 6.1310D-01
+ 1.5740D-01 3.7340D-01 5.9840D-01 1.5470D-01 9.4270D-01 6.5900D-02
+ 4.4170D-01 7.2300D-02 1.5440D-01 5.4920D-01 8.7000D-03 3.0040D-01
+ 2.0080D-01 6.0800D-01 3.0340D-01 8.4390D-01 2.3900D-01 5.7680D-01
+ 9.3610D-01 7.4130D-01 1.4440D-01 1.7860D-01 1.4280D-01 7.2630D-01
+ 5.5990D-01 9.3360D-01 7.8000D-02 4.0930D-01 6.7140D-01 5.6170D-01
+ -5.2278D-01 0.0000D+00 2.7888D-01 1.1793D-01
+ -3.5380D-01 0.0000D+00 3.5427D-01 6.8911D-02
+ -8.0876D-03 0.0000D+00 3.4558D-01 1.3489D-01
+ 3.4760D-01 3.0525D-01 5.4661D-01 1.7729D-01
+ 3.4760D-01 -3.0525D-01 5.4661D-01 1.7729D-01
+ 2.7698D+00 0.0000D+00 9.6635D-01 1.8270D+00
+ 5
+ 2.0000D-03 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D-03 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 -1.0000D-03 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 -2.0000D-03 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ -2.0000D-03 0.0000D+00 2.4000D-11 2.3952D-11
+ -1.0000D-03 0.0000D+00 6.0000D-12 5.9940D-12
+ 0.0000D+00 0.0000D+00 4.0000D-12 3.9920D-12
+ 1.0000D-03 0.0000D+00 6.0000D-12 5.9940D-12
+ 2.0000D-03 0.0000D+00 2.4000D-11 2.3952D-11
+ 10
+ 4.8630D-01 9.1260D-01 2.1900D-02 6.0110D-01 1.4050D-01 2.0840D-01
+ 8.2640D-01 8.4410D-01 3.1420D-01 8.6750D-01
+ 7.1500D-01 2.6480D-01 8.8510D-01 2.6150D-01 5.9520D-01 4.7800D-01
+ 7.6730D-01 4.6110D-01 5.7320D-01 7.7000D-03
+ 2.1210D-01 5.5080D-01 5.2350D-01 3.0810D-01 6.6020D-01 2.8900D-01
+ 2.3140D-01 2.2790D-01 9.6600D-02 1.0910D-01
+ 7.1510D-01 8.5790D-01 5.7710D-01 5.1140D-01 1.9010D-01 9.0810D-01
+ 6.0090D-01 7.1980D-01 1.0640D-01 8.6840D-01
+ 5.6800D-01 2.8100D-02 4.0140D-01 6.3150D-01 1.1480D-01 7.5800D-02
+ 9.4230D-01 7.2030D-01 3.6850D-01 1.7430D-01
+ 7.7210D-01 3.0280D-01 5.5640D-01 9.9980D-01 3.6520D-01 5.2580D-01
+ 3.7030D-01 6.7790D-01 9.9350D-01 5.0270D-01
+ 7.3960D-01 4.5600D-02 7.4740D-01 9.2880D-01 2.2000D-03 8.2600D-02
+ 3.6340D-01 4.9120D-01 9.4050D-01 3.8910D-01
+ 5.6370D-01 8.5540D-01 3.2100D-02 2.6380D-01 3.6090D-01 6.4970D-01
+ 8.4690D-01 9.3500D-01 3.7000D-02 2.9170D-01
+ 8.6560D-01 6.3270D-01 3.5620D-01 6.3560D-01 2.7360D-01 6.5120D-01
+ 1.0220D-01 2.8880D-01 5.7620D-01 4.0790D-01
+ 5.3320D-01 4.1210D-01 7.2870D-01 2.3110D-01 6.8300D-01 7.3860D-01
+ 8.1800D-01 9.8150D-01 8.0550D-01 2.5660D-01
+ -4.6121D-01 7.2657D-01 4.7781D-01 1.5842D-01
+ -4.6121D-01 -7.2657D-01 4.7781D-01 1.5842D-01
+ -4.5164D-01 0.0000D+00 4.6034D-01 1.9931D-01
+ -1.4922D-01 4.8255D-01 4.7500D-01 9.1686D-02
+ -1.4922D-01 -4.8255D-01 4.7500D-01 9.1686D-02
+ 3.3062D-02 0.0000D+00 2.9729D-01 8.2469D-02
+ 3.0849D-01 1.1953D-01 4.2947D-01 3.9688D-02
+ 3.0849D-01 -1.1953D-01 4.2947D-01 3.9688D-02
+ 5.4509D-01 0.0000D+00 7.0777D-01 1.5033D-01
+ 5.0352D+00 0.0000D+00 9.7257D-01 3.5548D+00
+ 4
+ -3.8730D-01 3.6560D-01 3.1200D-02 -5.8340D-01
+ 5.5230D-01 -1.1854D+00 9.8330D-01 7.6670D-01
+ 1.6746D+00 -1.9900D-02 -1.8293D+00 5.7180D-01
+ -5.2500D-01 3.5340D-01 -2.7210D-01 -8.8300D-02
+ -1.8952D+00 7.5059D-01 8.1913D-01 7.7090D-01
+ -1.8952D+00 -7.5059D-01 8.1913D-01 7.7090D-01
+ -9.5162D-02 0.0000D+00 8.0499D-01 4.9037D-01
+ 3.9520D-01 0.0000D+00 9.8222D-01 4.9037D-01
+ 6
+ -1.0777D+00 1.7027D+00 2.6510D-01 8.5160D-01 1.0121D+00 2.5710D-01
+ -1.3400D-02 3.9030D-01 -1.2680D+00 2.7530D-01 -3.2350D-01 -1.3844D+00
+ 1.5230D-01 3.0680D-01 8.7330D-01 -3.3410D-01 -4.8310D-01 -1.5416D+00
+ 1.4470D-01 -6.0570D-01 3.1900D-02 -1.0905D+00 -8.3700D-02 6.2410D-01
+ -7.6510D-01 -1.7889D+00 -1.5069D+00 -6.0210D-01 5.2170D-01 6.4700D-01
+ 8.1940D-01 2.1100D-01 5.4320D-01 7.5610D-01 1.7130D-01 5.5400D-01
+ -1.7029D+00 0.0000D+00 6.7909D-01 6.7220D-01
+ -1.0307D+00 0.0000D+00 7.2671D-01 2.0436D-01
+ 2.8487D-01 1.2101D+00 3.9757D-01 4.9797D-01
+ 2.8487D-01 -1.2101D+00 3.9757D-01 4.9797D-01
+ 1.1675D+00 4.6631D-01 4.2334D-01 1.9048D-01
+ 1.1675D+00 -4.6631D-01 4.2334D-01 1.9048D-01
+ 10
+ -1.0639D+00 1.6120D-01 1.5620D-01 3.4360D-01 -6.7480D-01 1.6598D+00
+ 6.4650D-01 -7.8630D-01 -2.6100D-01 7.0190D-01
+ -8.4400D-01 -2.2439D+00 1.8800D+00 -1.0005D+00 7.4500D-02 -1.6156D+00
+ 2.8220D-01 8.5600D-01 1.3497D+00 -1.5883D+00
+ 1.5988D+00 1.1758D+00 1.2398D+00 1.1173D+00 2.1500D-01 4.3140D-01
+ 1.8500D-01 7.9470D-01 6.6260D-01 8.6460D-01
+ -2.2960D-01 1.2442D+00 2.3242D+00 -5.0690D-01 -7.5160D-01 -5.4370D-01
+ -2.5990D-01 1.2830D+00 -1.1067D+00 -1.1150D-01
+ -3.6040D-01 4.0420D-01 6.1240D-01 -1.2164D+00 -9.4650D-01 -3.1460D-01
+ 1.8310D-01 7.3710D-01 1.4278D+00 2.9220D-01
+ 4.6150D-01 3.8740D-01 -4.2900D-02 -9.3600D-01 7.1160D-01 -8.2590D-01
+ -1.7640D+00 -9.4660D-01 1.8202D+00 -2.5480D-01
+ 1.2934D+00 -9.7550D-01 6.7480D-01 -1.0481D+00 -1.8442D+00 -5.4600D-02
+ 7.4050D-01 6.1000D-03 1.2430D+00 -1.8490D-01
+ -3.4710D-01 -9.5800D-01 1.6530D-01 9.1300D-02 -5.2010D-01 -1.1832D+00
+ 8.5410D-01 -2.3200D-01 -1.6155D+00 5.5180D-01
+ 1.0190D+00 -6.8240D-01 8.0850D-01 2.5950D-01 -3.7580D-01 -1.8825D+00
+ 1.6473D+00 -6.5920D-01 8.0250D-01 -4.9000D-03
+ 1.2670D+00 -4.2400D-02 8.9570D-01 -1.6770D-01 1.4620D-01 9.8800D-01
+ -2.3170D-01 -1.4483D+00 -5.8200D-02 1.9700D-02
+ -2.6992D+00 9.0387D-01 6.4005D-01 4.1615D-01
+ -2.6992D+00 -9.0387D-01 6.4005D-01 4.1615D-01
+ -2.4366D+00 0.0000D+00 6.9083D-01 2.5476D-01
+ -1.2882D+00 8.8930D-01 5.3435D-01 6.0878D-01
+ -1.2882D+00 -8.8930D-01 5.3435D-01 6.0878D-01
+ 9.0275D-01 0.0000D+00 2.9802D-01 4.7530D-01
+ 9.0442D-01 2.5661D+00 7.3193D-01 6.2016D-01
+ 9.0442D-01 -2.5661D+00 7.3193D-01 6.2016D-01
+ 1.6774D+00 0.0000D+00 3.0743D-01 4.1726D-01
+ 3.0060D+00 0.0000D+00 8.5623D-01 4.3175D-01
+ 4
+ -1.2298D+00 -2.3142D+00 -6.9800D-02 1.0523D+00
+ 2.0390D-01 -1.2298D+00 8.0500D-02 9.7860D-01
+ 0.0000D+00 0.0000D+00 2.5600D-01 -8.9100D-01
+ 0.0000D+00 0.0000D+00 2.7480D-01 2.5600D-01
+ -1.2298D+00 6.8692D-01 4.7136D-01 7.1772D-01
+ -1.2298D+00 -6.8692D-01 4.7136D-01 7.1772D-01
+ 2.5600D-01 4.9482D-01 8.0960D-01 5.1408D-01
+ 2.5600D-01 -4.9482D-01 8.0960D-01 5.1408D-01
+ 6
+ 5.9930D-01 1.9372D+00 -1.6160D-01 -1.4602D+00 6.0180D-01 2.7120D+00
+ -2.2049D+00 5.9930D-01 -1.0679D+00 1.9405D+00 -1.4400D+00 -2.2110D-01
+ 0.0000D+00 0.0000D+00 -2.4567D+00 -6.8650D-01 -1.9101D+00 6.4960D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 7.3620D-01 3.9700D-01 -1.5190D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -1.0034D+00 1.1954D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -1.3400D-01 -1.0034D+00
+ -2.4567D+00 0.0000D+00 4.7091D-01 8.5788D-01
+ -1.0034D+00 4.0023D-01 3.6889D-01 1.8909D-01
+ -1.0034D+00 -4.0023D-01 3.6889D-01 1.8909D-01
+ 5.9930D-01 2.0667D+00 5.8849D-01 1.3299D+00
+ 5.9930D-01 -2.0667D+00 5.8849D-01 1.3299D+00
+ 7.3620D-01 0.0000D+00 6.0845D-01 9.6725D-01
+ 4
+ 1.0000D-04 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 -1.0000D-04 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D-02 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 -5.0000D-03
+ -5.0000D-03 0.0000D+00 3.7485D-07 3.6932D-07
+ -1.0000D-04 0.0000D+00 9.8979D-09 9.8493D-09
+ 1.0000D-04 0.0000D+00 1.0098D-08 1.0046D-08
+ 1.0000D-02 0.0000D+00 1.4996D-06 1.4773D-06
+ 3
+ 2.0000D-06 1.0000D+00 -2.0000D+00
+ 1.0000D-06 -2.0000D+00 4.0000D+00
+ 0.0000D+00 1.0000D+00 -2.0000D+00
+ -4.0000D+00 0.0000D+00 7.3030D-01 4.0000D+00
+ 0.0000D+00 0.0000D+00 7.2801D-01 1.3726D-06
+ 2.2096D-06 0.0000D+00 8.2763D-01 2.2096D-06
+ 6
+ 2.4080D-01 6.5530D-01 9.1660D-01 5.0300D-02 2.8490D-01 2.4080D-01
+ 6.9070D-01 9.7000D-01 1.4020D-01 5.7820D-01 6.7670D-01 6.9070D-01
+ 1.0620D-01 3.8000D-02 7.0540D-01 2.4320D-01 8.6420D-01 1.0620D-01
+ 2.6400D-01 9.8800D-02 1.7800D-02 9.4480D-01 1.9430D-01 2.6400D-01
+ 7.0340D-01 2.5600D-01 2.6110D-01 5.8760D-01 5.8000D-02 7.0340D-01
+ 4.0210D-01 5.5980D-01 1.3580D-01 7.2560D-01 6.9080D-01 4.0210D-01
+ -3.4008D-01 3.2133D-01 5.7839D-01 2.0310D-01
+ -3.4008D-01 -3.2133D-01 5.7839D-01 2.0310D-01
+ -1.6998D-07 0.0000D+00 4.9641D-01 2.1574D-01
+ 7.2311D-01 5.9389D-02 7.0039D-01 4.1945D-02
+ 7.2311D-01 -5.9389D-02 7.0039D-01 4.1945D-02
+ 2.5551D+00 0.0000D+00 9.2518D-01 1.7390D+00
+ 6
+ 3.4800D+00 -2.9900D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ -4.9000D-01 2.4800D+00 -1.9900D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 -4.9000D-01 1.4800D+00 -9.9000D-01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 -9.9000D-01 1.4800D+00 -4.9000D-01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 -1.9900D+00 2.4800D+00 -4.9000D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -2.9900D+00 3.4800D+00
+ 1.3034D-02 0.0000D+00 7.5301D-01 6.0533D-01
+ 1.1294D+00 0.0000D+00 6.0479D-01 2.8613D-01
+ 2.0644D+00 0.0000D+00 5.4665D-01 1.7376D-01
+ 2.8388D+00 0.0000D+00 4.2771D-01 3.0915D-01
+ 4.3726D+00 0.0000D+00 6.6370D-01 7.6443D-02
+ 4.4618D+00 0.0000D+00 5.7388D-01 8.9227D-02
+ 6
+ 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00
+ -1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ -1.7321D+00 0.0000D+00 8.6603D-01 7.2597D-01
+ -1.0000D+00 0.0000D+00 5.0000D-01 2.6417D-01
+ 0.0000D+00 0.0000D+00 2.9582D-31 1.4600D-07
+ 0.0000D+00 0.0000D+00 2.9582D-31 6.2446D-08
+ 1.0000D+00 0.0000D+00 5.0000D-01 2.6417D-01
+ 1.7321D+00 0.0000D+00 8.6603D-01 3.7896D-01
+ 6
+ 3.5345D-01 9.3023D-01 7.4679D-02 -1.0059D-02 4.6698D-02 -4.3480D-02
+ 9.3545D-01 -3.5147D-01 -2.8216D-02 3.8008D-03 -1.7644D-02 1.6428D-02
+ 0.0000D+00 -1.0555D-01 7.5211D-01 -1.0131D-01 4.7030D-01 -4.3789D-01
+ 0.0000D+00 0.0000D+00 6.5419D-01 1.1779D-01 -5.4678D-01 5.0911D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 -9.8780D-01 -1.1398D-01 1.0612D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 6.8144D-01 7.3187D-01
+ -9.9980D-01 1.9645D-02 1.0000D+00 3.9290D-02
+ -9.9980D-01 -1.9645D-02 1.0000D+00 3.9290D-02
+ 7.4539D-01 6.6663D-01 1.0000D+00 5.2120D-01
+ 7.4539D-01 -6.6663D-01 1.0000D+00 5.2120D-01
+ 9.9929D-01 3.7545D-02 1.0000D+00 7.5089D-02
+ 9.9929D-01 -3.7545D-02 1.0000D+00 7.5089D-02
+ 6
+ 1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
+ 5.0000D-01 3.3330D-01 2.5000D-01 2.0000D-01 1.6670D-01 1.4290D-01
+ 3.3330D-01 2.5000D-01 2.0000D-01 1.6670D-01 1.4290D-01 1.2500D-01
+ 2.5000D-01 2.0000D-01 1.6670D-01 1.4290D-01 1.2500D-01 1.1110D-01
+ 2.0000D-01 1.6670D-01 1.4290D-01 1.2500D-01 1.1110D-01 1.0000D-01
+ 1.6670D-01 1.4290D-01 1.2500D-01 1.1110D-01 1.0000D-01 9.0900D-02
+ -2.2135D-01 0.0000D+00 4.0841D-01 1.6605D-01
+ -3.1956D-02 0.0000D+00 3.7927D-01 3.0531D-02
+ -8.5031D-04 0.0000D+00 6.2793D-01 7.8195D-04
+ -5.8584D-05 0.0000D+00 8.1156D-01 7.2478D-05
+ 1.3895D-05 0.0000D+00 9.7087D-01 7.2478D-05
+ 2.1324D+00 0.0000D+00 8.4325D-01 1.8048D+00
+ 12
+ 1.2000D+01 1.1000D+01 1.0000D+01 9.0000D+00 8.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 1.1000D+01 1.1000D+01 1.0000D+01 9.0000D+00 8.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 1.0000D+01 1.0000D+01 9.0000D+00 8.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 9.0000D+00 9.0000D+00 8.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 8.0000D+00 8.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 7.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 6.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 5.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 4.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 3.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 2.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ -2.8234D-02 0.0000D+00 2.8690D-06 3.2094D-06
+ 7.2587D-02 9.0746D-02 1.5885D-06 9.9934D-07
+ 7.2587D-02 -9.0746D-02 1.5885D-06 9.9934D-07
+ 1.8533D-01 0.0000D+00 6.5757D-07 7.8673D-07
+ 2.8828D-01 0.0000D+00 1.8324D-06 2.0796D-06
+ 6.4315D-01 0.0000D+00 6.8640D-05 6.1058D-05
+ 1.5539D+00 0.0000D+00 4.6255D-03 6.4028D-03
+ 3.5119D+00 0.0000D+00 1.4447D-01 1.9470D-01
+ 6.9615D+00 0.0000D+00 5.8447D-01 1.2016D+00
+ 1.2311D+01 0.0000D+00 3.1823D-01 1.4273D+00
+ 2.0199D+01 0.0000D+00 2.0079D-01 2.4358D+00
+ 3.2229D+01 0.0000D+00 3.0424D-01 5.6865D+00
+ 6
+ 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 5.0000D+00 0.0000D+00 2.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 4.0000D+00 0.0000D+00 3.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 3.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 2.0000D+00 0.0000D+00 5.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ -5.0000D+00 0.0000D+00 8.2295D-01 1.2318D+00
+ -3.0000D+00 0.0000D+00 7.2281D-01 7.5970D-01
+ -1.0000D+00 0.0000D+00 6.2854D-01 6.9666D-01
+ 1.0000D+00 0.0000D+00 6.2854D-01 6.9666D-01
+ 3.0000D+00 0.0000D+00 7.2281D-01 7.5970D-01
+ 5.0000D+00 0.0000D+00 8.2295D-01 1.2318D+00
+ 6
+ 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ -1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ -1.0000D+00 -1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ -1.0000D+00 -1.0000D+00 -1.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00
+ -1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 1.0000D+00 1.0000D+00
+ -1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 1.0000D+00
+ 8.0298D-02 2.4187D+00 8.9968D-01 1.5236D+00
+ 8.0298D-02 -2.4187D+00 8.9968D-01 1.5236D+00
+ 1.4415D+00 6.2850D-01 9.6734D-01 4.2793D-01
+ 1.4415D+00 -6.2850D-01 9.6734D-01 4.2793D-01
+ 1.4782D+00 1.5638D-01 9.7605D-01 2.2005D-01
+ 1.4782D+00 -1.5638D-01 9.7605D-01 2.2005D-01
+ 6
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
+ -3.5343D-02 7.4812D-01 3.9345D-01 1.8415D-01
+ -3.5343D-02 -7.4812D-01 3.9345D-01 1.8415D-01
+ 5.8440D-07 0.0000D+00 2.8868D-01 1.7003D-01
+ 6.4087D-01 7.2822D-01 4.5013D-01 2.9425D-01
+ 6.4087D-01 -7.2822D-01 4.5013D-01 2.9425D-01
+ 3.7889D+00 0.0000D+00 9.6305D-01 2.2469D+00
+ 6
+ 1.0000D+00 4.0112D+00 1.2750D+01 4.0213D+01 1.2656D+02 3.9788D+02
+ 1.0000D+00 3.2616D+00 1.0629D+01 3.3342D+01 1.0479D+02 3.2936D+02
+ 1.0000D+00 3.1500D+00 9.8006D+00 3.0630D+01 9.6164D+01 3.0215D+02
+ 1.0000D+00 3.2755D+00 1.0420D+01 3.2957D+01 1.0374D+02 3.2616D+02
+ 1.0000D+00 2.8214D+00 8.4558D+00 2.6296D+01 8.2443D+01 2.5893D+02
+ 1.0000D+00 2.6406D+00 8.3565D+00 2.6558D+01 8.3558D+01 2.6268D+02
+ -5.3220D-01 0.0000D+00 5.3287D-01 3.8557D-01
+ -1.0118D-01 0.0000D+00 7.2342D-01 9.1303D-02
+ -9.8749D-03 0.0000D+00 7.3708D-01 1.1032D-02
+ 2.9861D-03 0.0000D+00 4.4610D-01 1.2861D-02
+ 1.8075D-01 0.0000D+00 4.2881D-01 1.7378D-01
+ 3.9260D+02 0.0000D+00 4.8057D-01 3.9201D+02
+ 8
+ 0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00
+ 1.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 4.0000D+00
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 4.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 0.0000D+00 4.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 1.0000D+00 0.0000D+00
+ -3.7588D+00 0.0000D+00 1.2253D-01 1.2978D-01
+ -3.0642D+00 0.0000D+00 4.9811D-02 8.0162D-02
+ -2.0000D+00 0.0000D+00 3.6914D-02 8.2942D-02
+ -6.9459D-01 0.0000D+00 3.3328D-02 1.3738D-01
+ 6.9459D-01 0.0000D+00 3.3328D-02 1.1171D-01
+ 2.0000D+00 0.0000D+00 3.6914D-02 7.2156D-02
+ 3.0642D+00 0.0000D+00 4.9811D-02 6.8352D-02
+ 3.7588D+00 0.0000D+00 1.2253D-01 1.1527D-01
+ 6
+ 8.5000D+00 -1.0472D+01 2.8944D+00 -1.5279D+00 1.1056D+00 -5.0000D-01
+ 2.6180D+00 -1.1708D+00 -2.0000D+00 8.9440D-01 -6.1800D-01 2.7640D-01
+ -7.2360D-01 2.0000D+00 -1.7080D-01 -1.6180D+00 8.9440D-01 -3.8200D-01
+ 3.8200D-01 -8.9440D-01 1.6180D+00 1.7080D-01 -2.0000D+00 7.2360D-01
+ -2.7640D-01 6.1800D-01 -8.9440D-01 2.0000D+00 1.1708D+00 -2.6180D+00
+ 5.0000D-01 -1.1056D+00 1.5279D+00 -2.8944D+00 1.0472D+01 -8.5000D+00
+ -5.8930D-01 0.0000D+00 1.7357D-04 2.8157D-04
+ -2.7627D-01 4.9852D-01 1.7486D-04 1.6704D-04
+ -2.7627D-01 -4.9852D-01 1.7486D-04 1.6704D-04
+ 2.7509D-01 5.0059D-01 1.7635D-04 1.6828D-04
+ 2.7509D-01 -5.0059D-01 1.7635D-04 1.6828D-04
+ 5.9167D-01 0.0000D+00 1.7623D-04 3.0778D-04
+ 4
+ 4.0000D+00 -5.0000D+00 0.0000D+00 3.0000D+00
+ 0.0000D+00 4.0000D+00 -3.0000D+00 -5.0000D+00
+ 5.0000D+00 -3.0000D+00 4.0000D+00 0.0000D+00
+ 3.0000D+00 0.0000D+00 5.0000D+00 4.0000D+00
+ 1.0000D+00 5.0000D+00 1.0000D+00 4.3333D+00
+ 1.0000D+00 -5.0000D+00 1.0000D+00 4.3333D+00
+ 2.0000D+00 0.0000D+00 1.0000D+00 4.3333D+00
+ 1.2000D+01 0.0000D+00 1.0000D+00 9.1250D+00
+ 5
+ 1.5000D+01 1.1000D+01 6.0000D+00 -9.0000D+00 -1.5000D+01
+ 1.0000D+00 3.0000D+00 9.0000D+00 -3.0000D+00 -8.0000D+00
+ 7.0000D+00 6.0000D+00 6.0000D+00 -3.0000D+00 -1.1000D+01
+ 7.0000D+00 7.0000D+00 5.0000D+00 -3.0000D+00 -1.1000D+01
+ 1.7000D+01 1.2000D+01 5.0000D+00 -1.0000D+01 -1.6000D+01
+ -9.9999D-01 0.0000D+00 2.1768D-01 5.2263D-01
+ 1.4980D+00 3.5752D+00 3.9966D-04 6.0947D-03
+ 1.4980D+00 -3.5752D+00 3.9966D-04 6.0947D-03
+ 1.5020D+00 3.5662D+00 3.9976D-04 6.0960D-03
+ 1.5020D+00 -3.5662D+00 3.9976D-04 6.0960D-03
+ 6
+ -9.0000D+00 2.1000D+01 -1.5000D+01 4.0000D+00 2.0000D+00 0.0000D+00
+ -1.0000D+01 2.1000D+01 -1.4000D+01 4.0000D+00 2.0000D+00 0.0000D+00
+ -8.0000D+00 1.6000D+01 -1.1000D+01 4.0000D+00 2.0000D+00 0.0000D+00
+ -6.0000D+00 1.2000D+01 -9.0000D+00 3.0000D+00 3.0000D+00 0.0000D+00
+ -4.0000D+00 8.0000D+00 -6.0000D+00 0.0000D+00 5.0000D+00 0.0000D+00
+ -2.0000D+00 4.0000D+00 -3.0000D+00 0.0000D+00 1.0000D+00 3.0000D+00
+ 1.0000D+00 6.2559D-04 6.4875D-05 5.0367D-04
+ 1.0000D+00 -6.2559D-04 6.4875D-05 5.0367D-04
+ 2.0000D+00 1.0001D+00 5.4076D-02 2.3507D-01
+ 2.0000D+00 -1.0001D+00 5.4076D-02 2.3507D-01
+ 3.0000D+00 0.0000D+00 8.6149D-01 5.4838D-07
+ 3.0000D+00 0.0000D+00 1.2425D-01 1.2770D-06
+ 10
+ 1.0000D+00 1.0000D+00 1.0000D+00 -2.0000D+00 1.0000D+00 -1.0000D+00
+ 2.0000D+00 -2.0000D+00 4.0000D+00 -3.0000D+00
+ -1.0000D+00 2.0000D+00 3.0000D+00 -4.0000D+00 2.0000D+00 -2.0000D+00
+ 4.0000D+00 -4.0000D+00 8.0000D+00 -6.0000D+00
+ -1.0000D+00 0.0000D+00 5.0000D+00 -5.0000D+00 3.0000D+00 -3.0000D+00
+ 6.0000D+00 -6.0000D+00 1.2000D+01 -9.0000D+00
+ -1.0000D+00 0.0000D+00 3.0000D+00 -4.0000D+00 4.0000D+00 -4.0000D+00
+ 8.0000D+00 -8.0000D+00 1.6000D+01 -1.2000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 5.0000D+00 -4.0000D+00
+ 1.0000D+01 -1.0000D+01 2.0000D+01 -1.5000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -2.0000D+00
+ 1.2000D+01 -1.2000D+01 2.4000D+01 -1.8000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
+ 1.5000D+01 -1.3000D+01 2.8000D+01 -2.1000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
+ 1.2000D+01 -1.1000D+01 3.2000D+01 -2.4000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
+ 1.2000D+01 -1.4000D+01 3.7000D+01 -2.6000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
+ 1.2000D+01 -1.4000D+01 3.6000D+01 -2.5000D+01
+ 1.0000D+00 0.0000D+00 3.6037D-02 7.9613D-02
+ 1.9867D+00 0.0000D+00 7.4283D-05 7.4025D-06
+ 2.0000D+00 2.5052D-03 1.4346D-04 6.7839D-07
+ 2.0000D+00 -2.5052D-03 1.4346D-04 6.7839D-07
+ 2.0067D+00 1.1763D-02 6.7873D-05 5.7496D-06
+ 2.0067D+00 -1.1763D-02 6.7873D-05 5.7496D-06
+ 2.9970D+00 0.0000D+00 9.2779D-05 2.6519D-06
+ 3.0000D+00 8.7028D-04 2.7358D-04 1.9407D-07
+ 3.0000D+00 -8.7028D-04 2.7358D-04 1.9407D-07
+ 3.0030D+00 0.0000D+00 9.2696D-05 2.6477D-06
+ 0
+ 1 1
+ 1
+ 0.00000D+00
+ 1.00000D+00 0.00000D+00
+ 1 1
+ 1
+ 1.00000D+00
+ 1.00000D+00 1.00000D+00
+ 6 3
+ 4 5 6
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+00 4.43734D-31
+ 6 3
+ 4 5 6
+ 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 1.00000D+00 1.19209D-07
+ 6 3
+ 4 5 6
+ 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 4.01235D-36 3.20988D-36
+ 6 3
+ 4 5 6
+ 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00
+ 4.01235D-36 3.20988D-36
+ 6 3
+ 4 5 6
+ 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 2.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 3.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 4.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 6.00000D+00
+ 1.00000D+00 1.00000D+00
+ 2 1
+ 1
+ 1.00000D+00 2.00000D+00
+ 0.00000D+00 3.00000D+00
+ 7.07107D-01 2.00000D+00
+ 4 2
+ 1 2
+ 8.52400D-01 5.61100D-01 7.04300D-01 9.54000D-01
+ 2.79800D-01 7.21600D-01 9.61300D-01 3.58200D-01
+ 7.08100D-01 4.09400D-01 2.25000D-01 9.51800D-01
+ 5.54300D-01 5.22000D-01 6.86000D-01 3.07000D-02
+ 7.22196D-01 4.63943D-01
+ 7 6
+ 1 2 3 4 5 6
+ 7.81800D-01 5.65700D-01 7.62100D-01 7.43600D-01 2.55300D-01 4.10000D-01
+ 1.34000D-02
+ 6.45800D-01 2.66600D-01 5.51000D-01 8.31800D-01 9.27100D-01 6.20900D-01
+ 7.83900D-01
+ 1.31600D-01 4.91400D-01 1.77100D-01 1.96400D-01 1.08500D-01 9.27000D-01
+ 2.24700D-01
+ 6.41000D-01 4.68900D-01 9.65900D-01 8.88400D-01 3.76900D-01 9.67300D-01
+ 6.18300D-01
+ 8.38200D-01 8.74300D-01 4.50700D-01 9.44200D-01 7.75500D-01 9.67600D-01
+ 7.83100D-01
+ 3.25900D-01 7.38900D-01 8.30200D-01 4.52100D-01 3.01500D-01 2.13300D-01
+ 8.43400D-01
+ 5.24400D-01 5.01600D-01 7.52900D-01 3.83800D-01 8.47900D-01 9.12800D-01
+ 5.77000D-01
+ 9.43220D-01 3.20530D+00
+ 4 2
+ 2 3
+ -9.85900D-01 1.47840D+00 -1.33600D-01 -2.95970D+00
+ -4.33700D-01 -6.54000D-01 -7.15500D-01 1.23760D+00
+ -7.36300D-01 -1.97680D+00 -1.95100D-01 3.43200D-01
+ 6.41400D-01 -1.40880D+00 6.39400D-01 8.58000D-02
+ 5.22869D-01 5.45530D-01
+ 7 5
+ 1 2 3 4 5
+ 2.72840D+00 2.15200D-01 -1.05200D+00 -2.44600D-01 -6.53000D-02 3.90500D-01
+ 1.40980D+00
+ 9.75300D-01 6.51500D-01 -4.76200D-01 5.42100D-01 6.20900D-01 4.75900D-01
+ -1.44930D+00
+ -9.05200D-01 1.79000D-01 -7.08600D-01 4.62100D-01 1.05800D+00 2.24260D+00
+ 1.58260D+00
+ -7.17900D-01 -2.53400D-01 -4.73900D-01 -1.08100D+00 4.13800D-01 -9.50000D-02
+ 1.45300D-01
+ -1.37990D+00 -1.06490D+00 1.25580D+00 7.80100D-01 -6.40500D-01 -8.61000D-02
+ 8.30000D-02
+ 2.84900D-01 -1.29900D-01 4.80000D-02 -2.58600D-01 4.18900D-01 1.37680D+00
+ 8.20800D-01
+ -5.44200D-01 9.74900D-01 9.55800D-01 1.23700D-01 1.09020D+00 -1.40600D-01
+ 1.90960D+00
+ 6.04729D-01 9.00391D-01
+ 6 4
+ 3 4 5 6
+ 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
+ 1.00000D-06 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D-01
+ 4.89525D-05 4.56492D-05
+ 8 4
+ 1 2 3 4
+ 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00
+ 1.00000D+01 0.00000D+00
+ 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01
+ 1.00000D+01 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 1.00000D+01
+ 1.00000D+01 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+01
+ 0.00000D+00 1.00000D+01
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D-01 1.00000D+00
+ 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D-01
+ 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 5.00000D-01 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 5.00000D-01
+ 9.56158D-05 4.14317D-05
+ 9 3
+ 1 2 3
+ 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 7.50000D-01 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 7.50000D-01 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 7.50000D-01
+ 1.00000D+00 5.55801D-07
+ 10 4
+ 1 2 3 4
+ 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 8.75000D-01 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 8.75000D-01 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 8.75000D-01 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 8.75000D-01
+ 1.00000D+00 1.16972D-10
+ 12 6
+ 1 2 3 4 5 6
+ 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+01 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+01 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 9.37500D-01 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 9.37500D-01 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 9.37500D-01 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 9.37500D-01 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 9.37500D-01 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 9.37500D-01
+ 1.85655D-10 2.20147D-16
+ 12 7
+ 6 7 8 9 10 11 12
+ 1.20000D+01 1.10000D+01 1.00000D+01 9.00000D+00 8.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 1.10000D+01 1.10000D+01 1.00000D+01 9.00000D+00 8.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 1.00000D+01 1.00000D+01 9.00000D+00 8.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 9.00000D+00 9.00000D+00 8.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 8.00000D+00 8.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 7.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 6.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 5.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 4.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 3.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 2.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00
+ 6.92558D-05 5.52606D-05
+ 3 1
+ 1
+ 2.00000D-06 1.00000D+00 -2.00000D+00
+ 1.00000D-06 -2.00000D+00 4.00000D+00
+ 0.00000D+00 1.00000D+00 -2.00000D+00
+ 7.30297D-01 4.00000D+00
+ 5 1
+ 3
+ 2.00000D-03 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D-03 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 -1.00000D-03 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 -2.00000D-03 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 3.99999D-12 3.99201D-12
+ 6 4
+ 1 2 3 5
+ 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00
+ 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00
+ 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00
+ 2.93294D-01 1.63448D-01
+ 6 2
+ 3 4
+ 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 1.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+00
+ -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
+ 3.97360D-01 3.58295D-01
+ 6 3
+ 3 4 5
+ 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00
+ 5.00000D-01 3.33300D-01 2.50000D-01 2.00000D-01 1.66700D-01 1.42900D-01
+ 3.33300D-01 2.50000D-01 2.00000D-01 1.66700D-01 1.42900D-01 1.25000D-01
+ 2.50000D-01 2.00000D-01 1.66700D-01 1.42900D-01 1.25000D-01 1.11100D-01
+ 2.00000D-01 1.66700D-01 1.42900D-01 1.25000D-01 1.11100D-01 1.00000D-01
+ 1.66700D-01 1.42900D-01 1.25000D-01 1.11100D-01 1.00000D-01 9.09000D-02
+ 7.28934D-01 1.24624D-02
+ 5 1
+ 1
+ 1.50000D+01 1.10000D+01 6.00000D+00 -9.00000D+00 -1.50000D+01
+ 1.00000D+00 3.00000D+00 9.00000D+00 -3.00000D+00 -8.00000D+00
+ 7.00000D+00 6.00000D+00 6.00000D+00 -3.00000D+00 -1.10000D+01
+ 7.00000D+00 7.00000D+00 5.00000D+00 -3.00000D+00 -1.10000D+01
+ 1.70000D+01 1.20000D+01 5.00000D+00 -1.00000D+01 -1.60000D+01
+ 2.17680D-01 5.22626D-01
+ 6 2
+ 1 2
+ -9.00000D+00 2.10000D+01 -1.50000D+01 4.00000D+00 2.00000D+00 0.00000D+00
+ -1.00000D+01 2.10000D+01 -1.40000D+01 4.00000D+00 2.00000D+00 0.00000D+00
+ -8.00000D+00 1.60000D+01 -1.10000D+01 4.00000D+00 2.00000D+00 0.00000D+00
+ -6.00000D+00 1.20000D+01 -9.00000D+00 3.00000D+00 3.00000D+00 0.00000D+00
+ -4.00000D+00 8.00000D+00 -6.00000D+00 0.00000D+00 5.00000D+00 0.00000D+00
+ -2.00000D+00 4.00000D+00 -3.00000D+00 0.00000D+00 1.00000D+00 3.00000D+00
+ 6.78904D-02 4.22005D-02
+ 10 1
+ 1
+ 1.00000D+00 1.00000D+00 1.00000D+00 -2.00000D+00 1.00000D+00 -1.00000D+00
+ 2.00000D+00 -2.00000D+00 4.00000D+00 -3.00000D+00
+ -1.00000D+00 2.00000D+00 3.00000D+00 -4.00000D+00 2.00000D+00 -2.00000D+00
+ 4.00000D+00 -4.00000D+00 8.00000D+00 -6.00000D+00
+ -1.00000D+00 0.00000D+00 5.00000D+00 -5.00000D+00 3.00000D+00 -3.00000D+00
+ 6.00000D+00 -6.00000D+00 1.20000D+01 -9.00000D+00
+ -1.00000D+00 0.00000D+00 3.00000D+00 -4.00000D+00 4.00000D+00 -4.00000D+00
+ 8.00000D+00 -8.00000D+00 1.60000D+01 -1.20000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 5.00000D+00 -4.00000D+00
+ 1.00000D+01 -1.00000D+01 2.00000D+01 -1.50000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -2.00000D+00
+ 1.20000D+01 -1.20000D+01 2.40000D+01 -1.80000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
+ 1.50000D+01 -1.30000D+01 2.80000D+01 -2.10000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
+ 1.20000D+01 -1.10000D+01 3.20000D+01 -2.40000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
+ 1.20000D+01 -1.40000D+01 3.70000D+01 -2.60000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
+ 1.20000D+01 -1.40000D+01 3.60000D+01 -2.50000D+01
+ 3.60372D-02 7.96134D-02
+ 0 0
diff --git a/TESTING/ded.in b/TESTING/ded.in
new file mode 100644
index 0000000..09f698e
--- /dev/null
+++ b/TESTING/ded.in
@@ -0,0 +1,865 @@
+DEV Data file for Real Nonsymmetric Eigenvalue Driver
+6 Number of matrix dimensions
+0 1 2 3 5 10 20 Matrix dimensions
+3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
+20.0 Threshold for test ratios
+T
+2 Read another line with random number generator seed
+2518 3899 995 397 Seed for random number generator
+DEV 21 Use all matrix types
+DES Data file for Real Nonsymmetric Schur Form Driver
+6 Number of matrix dimensions
+0 1 2 3 5 10 20 Matrix dimensions
+3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
+20.0 Threshold for test ratios
+T
+2 Read another line with random number generator seed
+2518 3899 995 397 Seed for random number generator
+DES 21 Use all matrix types
+DVX Data file for Real Nonsymmetric Eigenvalue Expert Driver
+6 Number of matrix dimensions
+0 1 2 3 5 10 20 Matrix dimensions
+3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
+20.0 Threshold for test ratios
+T
+2 Read another line with random number generator seed
+2518 3899 995 397 Seed for random number generator
+DVX 21 Use all matrix types
+ 1
+ 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 1
+ 1.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 2
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 2
+ 3.0000D+00 2.0000D+00
+ 2.0000D+00 3.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 4.0000D+00
+ 5.0000D+00 0.0000D+00 1.0000D+00 4.0000D+00
+ 2
+ 3.0000D+00 -2.0000D+00
+ 2.0000D+00 3.0000D+00
+ 3.0000D+00 2.0000D+00 1.0000D+00 4.0000D+00
+ 3.0000D+00 -2.0000D+00 1.0000D+00 4.0000D+00
+ 6
+ 1.0000D-07 -1.0000D-07 1.0000D+00 1.1000D+00 2.3000D+00 3.7000D+00
+ 3.0000D-07 1.0000D-07 1.0000D+00 1.0000D+00 -1.3000D+00 -7.7000D+00
+ 0.0000D+00 0.0000D+00 3.0000D-07 1.0000D-07 2.2000D+00 3.3000D+00
+ 0.0000D+00 0.0000D+00 -1.0000D-07 3.0000D-07 1.8000D+00 1.6000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 4.0000D-06 5.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 3.0000D+00 4.0000D-06
+ -3.8730D+00 0.0000D+00 6.9855D-01 2.2823D+00
+ 1.0000D-07 1.7321D-07 9.7611D-08 5.0060D-14
+ 1.0000D-07 -1.7321D-07 9.7611D-08 5.0060D-14
+ 3.0000D-07 1.0000D-07 1.0000D-07 9.4094D-14
+ 3.0000D-07 -1.0000D-07 1.0000D-07 9.4094D-14
+ 3.8730D+00 0.0000D+00 4.0659D-01 1.5283D+00
+ 4
+ 7.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
+ -1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
+ -1.0000D+00 1.0000D+00 5.0000D+00 -3.0000D+00
+ 1.0000D+00 -1.0000D+00 3.0000D+00 3.0000D+00
+ 3.9603D+00 4.0425D-02 1.1244D-05 3.1179D-05
+ 3.9603D+00 -4.0425D-02 1.1244D-05 3.1179D-05
+ 4.0397D+00 3.8854D-02 1.0807D-05 2.9981D-05
+ 4.0397D+00 -3.8854D-02 1.0807D-05 2.9981D-05
+ 5
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 5
+ 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 6
+ 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 6
+ 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 6
+ 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 2.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 3.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 5.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 6.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 2.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 3.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 4.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 5.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 6.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 4
+ 9.4480D-01 6.7670D-01 6.9080D-01 5.9650D-01
+ 5.8760D-01 8.6420D-01 6.7690D-01 7.2600D-02
+ 7.2560D-01 1.9430D-01 9.6870D-01 2.8310D-01
+ 2.8490D-01 5.8000D-02 4.8450D-01 7.3610D-01
+ 2.4326D-01 2.1409D-01 8.7105D-01 3.5073D-01
+ 2.4326D-01 -2.1409D-01 8.7105D-01 3.5073D-01
+ 7.4091D-01 0.0000D+00 9.8194D-01 4.6989D-01
+ 2.2864D+00 0.0000D+00 9.7723D-01 1.5455D+00
+ 6
+ 5.0410D-01 6.6520D-01 7.7190D-01 6.3870D-01 5.9550D-01 6.1310D-01
+ 1.5740D-01 3.7340D-01 5.9840D-01 1.5470D-01 9.4270D-01 6.5900D-02
+ 4.4170D-01 7.2300D-02 1.5440D-01 5.4920D-01 8.7000D-03 3.0040D-01
+ 2.0080D-01 6.0800D-01 3.0340D-01 8.4390D-01 2.3900D-01 5.7680D-01
+ 9.3610D-01 7.4130D-01 1.4440D-01 1.7860D-01 1.4280D-01 7.2630D-01
+ 5.5990D-01 9.3360D-01 7.8000D-02 4.0930D-01 6.7140D-01 5.6170D-01
+ -5.2278D-01 0.0000D+00 2.7888D-01 1.1793D-01
+ -3.5380D-01 0.0000D+00 3.5427D-01 6.8911D-02
+ -8.0876D-03 0.0000D+00 3.4558D-01 1.3489D-01
+ 3.4760D-01 3.0525D-01 5.4661D-01 1.7729D-01
+ 3.4760D-01 -3.0525D-01 5.4661D-01 1.7729D-01
+ 2.7698D+00 0.0000D+00 9.6635D-01 1.8270D+00
+ 5
+ 2.0000D-03 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D-03 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 -1.0000D-03 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 -2.0000D-03 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ -2.0000D-03 0.0000D+00 2.4000D-11 2.3952D-11
+ -1.0000D-03 0.0000D+00 6.0000D-12 5.9940D-12
+ 0.0000D+00 0.0000D+00 4.0000D-12 3.9920D-12
+ 1.0000D-03 0.0000D+00 6.0000D-12 5.9940D-12
+ 2.0000D-03 0.0000D+00 2.4000D-11 2.3952D-11
+ 10
+ 4.8630D-01 9.1260D-01 2.1900D-02 6.0110D-01 1.4050D-01 2.0840D-01
+ 8.2640D-01 8.4410D-01 3.1420D-01 8.6750D-01
+ 7.1500D-01 2.6480D-01 8.8510D-01 2.6150D-01 5.9520D-01 4.7800D-01
+ 7.6730D-01 4.6110D-01 5.7320D-01 7.7000D-03
+ 2.1210D-01 5.5080D-01 5.2350D-01 3.0810D-01 6.6020D-01 2.8900D-01
+ 2.3140D-01 2.2790D-01 9.6600D-02 1.0910D-01
+ 7.1510D-01 8.5790D-01 5.7710D-01 5.1140D-01 1.9010D-01 9.0810D-01
+ 6.0090D-01 7.1980D-01 1.0640D-01 8.6840D-01
+ 5.6800D-01 2.8100D-02 4.0140D-01 6.3150D-01 1.1480D-01 7.5800D-02
+ 9.4230D-01 7.2030D-01 3.6850D-01 1.7430D-01
+ 7.7210D-01 3.0280D-01 5.5640D-01 9.9980D-01 3.6520D-01 5.2580D-01
+ 3.7030D-01 6.7790D-01 9.9350D-01 5.0270D-01
+ 7.3960D-01 4.5600D-02 7.4740D-01 9.2880D-01 2.2000D-03 8.2600D-02
+ 3.6340D-01 4.9120D-01 9.4050D-01 3.8910D-01
+ 5.6370D-01 8.5540D-01 3.2100D-02 2.6380D-01 3.6090D-01 6.4970D-01
+ 8.4690D-01 9.3500D-01 3.7000D-02 2.9170D-01
+ 8.6560D-01 6.3270D-01 3.5620D-01 6.3560D-01 2.7360D-01 6.5120D-01
+ 1.0220D-01 2.8880D-01 5.7620D-01 4.0790D-01
+ 5.3320D-01 4.1210D-01 7.2870D-01 2.3110D-01 6.8300D-01 7.3860D-01
+ 8.1800D-01 9.8150D-01 8.0550D-01 2.5660D-01
+ -4.6121D-01 7.2657D-01 4.7781D-01 1.5842D-01
+ -4.6121D-01 -7.2657D-01 4.7781D-01 1.5842D-01
+ -4.5164D-01 0.0000D+00 4.6034D-01 1.9931D-01
+ -1.4922D-01 4.8255D-01 4.7500D-01 9.1686D-02
+ -1.4922D-01 -4.8255D-01 4.7500D-01 9.1686D-02
+ 3.3062D-02 0.0000D+00 2.9729D-01 8.2469D-02
+ 3.0849D-01 1.1953D-01 4.2947D-01 3.9688D-02
+ 3.0849D-01 -1.1953D-01 4.2947D-01 3.9688D-02
+ 5.4509D-01 0.0000D+00 7.0777D-01 1.5033D-01
+ 5.0352D+00 0.0000D+00 9.7257D-01 3.5548D+00
+ 4
+ -3.8730D-01 3.6560D-01 3.1200D-02 -5.8340D-01
+ 5.5230D-01 -1.1854D+00 9.8330D-01 7.6670D-01
+ 1.6746D+00 -1.9900D-02 -1.8293D+00 5.7180D-01
+ -5.2500D-01 3.5340D-01 -2.7210D-01 -8.8300D-02
+ -1.8952D+00 7.5059D-01 8.1913D-01 7.7090D-01
+ -1.8952D+00 -7.5059D-01 8.1913D-01 7.7090D-01
+ -9.5162D-02 0.0000D+00 8.0499D-01 4.9037D-01
+ 3.9520D-01 0.0000D+00 9.8222D-01 4.9037D-01
+ 6
+ -1.0777D+00 1.7027D+00 2.6510D-01 8.5160D-01 1.0121D+00 2.5710D-01
+ -1.3400D-02 3.9030D-01 -1.2680D+00 2.7530D-01 -3.2350D-01 -1.3844D+00
+ 1.5230D-01 3.0680D-01 8.7330D-01 -3.3410D-01 -4.8310D-01 -1.5416D+00
+ 1.4470D-01 -6.0570D-01 3.1900D-02 -1.0905D+00 -8.3700D-02 6.2410D-01
+ -7.6510D-01 -1.7889D+00 -1.5069D+00 -6.0210D-01 5.2170D-01 6.4700D-01
+ 8.1940D-01 2.1100D-01 5.4320D-01 7.5610D-01 1.7130D-01 5.5400D-01
+ -1.7029D+00 0.0000D+00 6.7909D-01 6.7220D-01
+ -1.0307D+00 0.0000D+00 7.2671D-01 2.0436D-01
+ 2.8487D-01 1.2101D+00 3.9757D-01 4.9797D-01
+ 2.8487D-01 -1.2101D+00 3.9757D-01 4.9797D-01
+ 1.1675D+00 4.6631D-01 4.2334D-01 1.9048D-01
+ 1.1675D+00 -4.6631D-01 4.2334D-01 1.9048D-01
+ 10
+ -1.0639D+00 1.6120D-01 1.5620D-01 3.4360D-01 -6.7480D-01 1.6598D+00
+ 6.4650D-01 -7.8630D-01 -2.6100D-01 7.0190D-01
+ -8.4400D-01 -2.2439D+00 1.8800D+00 -1.0005D+00 7.4500D-02 -1.6156D+00
+ 2.8220D-01 8.5600D-01 1.3497D+00 -1.5883D+00
+ 1.5988D+00 1.1758D+00 1.2398D+00 1.1173D+00 2.1500D-01 4.3140D-01
+ 1.8500D-01 7.9470D-01 6.6260D-01 8.6460D-01
+ -2.2960D-01 1.2442D+00 2.3242D+00 -5.0690D-01 -7.5160D-01 -5.4370D-01
+ -2.5990D-01 1.2830D+00 -1.1067D+00 -1.1150D-01
+ -3.6040D-01 4.0420D-01 6.1240D-01 -1.2164D+00 -9.4650D-01 -3.1460D-01
+ 1.8310D-01 7.3710D-01 1.4278D+00 2.9220D-01
+ 4.6150D-01 3.8740D-01 -4.2900D-02 -9.3600D-01 7.1160D-01 -8.2590D-01
+ -1.7640D+00 -9.4660D-01 1.8202D+00 -2.5480D-01
+ 1.2934D+00 -9.7550D-01 6.7480D-01 -1.0481D+00 -1.8442D+00 -5.4600D-02
+ 7.4050D-01 6.1000D-03 1.2430D+00 -1.8490D-01
+ -3.4710D-01 -9.5800D-01 1.6530D-01 9.1300D-02 -5.2010D-01 -1.1832D+00
+ 8.5410D-01 -2.3200D-01 -1.6155D+00 5.5180D-01
+ 1.0190D+00 -6.8240D-01 8.0850D-01 2.5950D-01 -3.7580D-01 -1.8825D+00
+ 1.6473D+00 -6.5920D-01 8.0250D-01 -4.9000D-03
+ 1.2670D+00 -4.2400D-02 8.9570D-01 -1.6770D-01 1.4620D-01 9.8800D-01
+ -2.3170D-01 -1.4483D+00 -5.8200D-02 1.9700D-02
+ -2.6992D+00 9.0387D-01 6.4005D-01 4.1615D-01
+ -2.6992D+00 -9.0387D-01 6.4005D-01 4.1615D-01
+ -2.4366D+00 0.0000D+00 6.9083D-01 2.5476D-01
+ -1.2882D+00 8.8930D-01 5.3435D-01 6.0878D-01
+ -1.2882D+00 -8.8930D-01 5.3435D-01 6.0878D-01
+ 9.0275D-01 0.0000D+00 2.9802D-01 4.7530D-01
+ 9.0442D-01 2.5661D+00 7.3193D-01 6.2016D-01
+ 9.0442D-01 -2.5661D+00 7.3193D-01 6.2016D-01
+ 1.6774D+00 0.0000D+00 3.0743D-01 4.1726D-01
+ 3.0060D+00 0.0000D+00 8.5623D-01 4.3175D-01
+ 4
+ -1.2298D+00 -2.3142D+00 -6.9800D-02 1.0523D+00
+ 2.0390D-01 -1.2298D+00 8.0500D-02 9.7860D-01
+ 0.0000D+00 0.0000D+00 2.5600D-01 -8.9100D-01
+ 0.0000D+00 0.0000D+00 2.7480D-01 2.5600D-01
+ -1.2298D+00 6.8692D-01 4.7136D-01 7.1772D-01
+ -1.2298D+00 -6.8692D-01 4.7136D-01 7.1772D-01
+ 2.5600D-01 4.9482D-01 8.0960D-01 5.1408D-01
+ 2.5600D-01 -4.9482D-01 8.0960D-01 5.1408D-01
+ 6
+ 5.9930D-01 1.9372D+00 -1.6160D-01 -1.4602D+00 6.0180D-01 2.7120D+00
+ -2.2049D+00 5.9930D-01 -1.0679D+00 1.9405D+00 -1.4400D+00 -2.2110D-01
+ 0.0000D+00 0.0000D+00 -2.4567D+00 -6.8650D-01 -1.9101D+00 6.4960D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 7.3620D-01 3.9700D-01 -1.5190D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -1.0034D+00 1.1954D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -1.3400D-01 -1.0034D+00
+ -2.4567D+00 0.0000D+00 4.7091D-01 8.5788D-01
+ -1.0034D+00 4.0023D-01 3.6889D-01 1.8909D-01
+ -1.0034D+00 -4.0023D-01 3.6889D-01 1.8909D-01
+ 5.9930D-01 2.0667D+00 5.8849D-01 1.3299D+00
+ 5.9930D-01 -2.0667D+00 5.8849D-01 1.3299D+00
+ 7.3620D-01 0.0000D+00 6.0845D-01 9.6725D-01
+ 4
+ 1.0000D-04 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 -1.0000D-04 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D-02 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 -5.0000D-03
+ -5.0000D-03 0.0000D+00 3.7485D-07 3.6932D-07
+ -1.0000D-04 0.0000D+00 9.8979D-09 9.8493D-09
+ 1.0000D-04 0.0000D+00 1.0098D-08 1.0046D-08
+ 1.0000D-02 0.0000D+00 1.4996D-06 1.4773D-06
+ 3
+ 2.0000D-06 1.0000D+00 -2.0000D+00
+ 1.0000D-06 -2.0000D+00 4.0000D+00
+ 0.0000D+00 1.0000D+00 -2.0000D+00
+ -4.0000D+00 0.0000D+00 7.3030D-01 4.0000D+00
+ 0.0000D+00 0.0000D+00 7.2801D-01 1.3726D-06
+ 2.2096D-06 0.0000D+00 8.2763D-01 2.2096D-06
+ 6
+ 2.4080D-01 6.5530D-01 9.1660D-01 5.0300D-02 2.8490D-01 2.4080D-01
+ 6.9070D-01 9.7000D-01 1.4020D-01 5.7820D-01 6.7670D-01 6.9070D-01
+ 1.0620D-01 3.8000D-02 7.0540D-01 2.4320D-01 8.6420D-01 1.0620D-01
+ 2.6400D-01 9.8800D-02 1.7800D-02 9.4480D-01 1.9430D-01 2.6400D-01
+ 7.0340D-01 2.5600D-01 2.6110D-01 5.8760D-01 5.8000D-02 7.0340D-01
+ 4.0210D-01 5.5980D-01 1.3580D-01 7.2560D-01 6.9080D-01 4.0210D-01
+ -3.4008D-01 3.2133D-01 5.7839D-01 2.0310D-01
+ -3.4008D-01 -3.2133D-01 5.7839D-01 2.0310D-01
+ -1.6998D-07 0.0000D+00 4.9641D-01 2.1574D-01
+ 7.2311D-01 5.9389D-02 7.0039D-01 4.1945D-02
+ 7.2311D-01 -5.9389D-02 7.0039D-01 4.1945D-02
+ 2.5551D+00 0.0000D+00 9.2518D-01 1.7390D+00
+ 6
+ 3.4800D+00 -2.9900D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ -4.9000D-01 2.4800D+00 -1.9900D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 -4.9000D-01 1.4800D+00 -9.9000D-01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 -9.9000D-01 1.4800D+00 -4.9000D-01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 -1.9900D+00 2.4800D+00 -4.9000D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -2.9900D+00 3.4800D+00
+ 1.3034D-02 0.0000D+00 7.5301D-01 6.0533D-01
+ 1.1294D+00 0.0000D+00 6.0479D-01 2.8613D-01
+ 2.0644D+00 0.0000D+00 5.4665D-01 1.7376D-01
+ 2.8388D+00 0.0000D+00 4.2771D-01 3.0915D-01
+ 4.3726D+00 0.0000D+00 6.6370D-01 7.6443D-02
+ 4.4618D+00 0.0000D+00 5.7388D-01 8.9227D-02
+ 6
+ 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00
+ -1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ -1.7321D+00 0.0000D+00 8.6603D-01 7.2597D-01
+ -1.0000D+00 0.0000D+00 5.0000D-01 2.6417D-01
+ 0.0000D+00 0.0000D+00 2.9582D-31 1.4600D-07
+ 0.0000D+00 0.0000D+00 2.9582D-31 6.2446D-08
+ 1.0000D+00 0.0000D+00 5.0000D-01 2.6417D-01
+ 1.7321D+00 0.0000D+00 8.6603D-01 3.7896D-01
+ 6
+ 3.5345D-01 9.3023D-01 7.4679D-02 -1.0059D-02 4.6698D-02 -4.3480D-02
+ 9.3545D-01 -3.5147D-01 -2.8216D-02 3.8008D-03 -1.7644D-02 1.6428D-02
+ 0.0000D+00 -1.0555D-01 7.5211D-01 -1.0131D-01 4.7030D-01 -4.3789D-01
+ 0.0000D+00 0.0000D+00 6.5419D-01 1.1779D-01 -5.4678D-01 5.0911D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 -9.8780D-01 -1.1398D-01 1.0612D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 6.8144D-01 7.3187D-01
+ -9.9980D-01 1.9645D-02 1.0000D+00 3.9290D-02
+ -9.9980D-01 -1.9645D-02 1.0000D+00 3.9290D-02
+ 7.4539D-01 6.6663D-01 1.0000D+00 5.2120D-01
+ 7.4539D-01 -6.6663D-01 1.0000D+00 5.2120D-01
+ 9.9929D-01 3.7545D-02 1.0000D+00 7.5089D-02
+ 9.9929D-01 -3.7545D-02 1.0000D+00 7.5089D-02
+ 6
+ 1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
+ 5.0000D-01 3.3330D-01 2.5000D-01 2.0000D-01 1.6670D-01 1.4290D-01
+ 3.3330D-01 2.5000D-01 2.0000D-01 1.6670D-01 1.4290D-01 1.2500D-01
+ 2.5000D-01 2.0000D-01 1.6670D-01 1.4290D-01 1.2500D-01 1.1110D-01
+ 2.0000D-01 1.6670D-01 1.4290D-01 1.2500D-01 1.1110D-01 1.0000D-01
+ 1.6670D-01 1.4290D-01 1.2500D-01 1.1110D-01 1.0000D-01 9.0900D-02
+ -2.2135D-01 0.0000D+00 4.0841D-01 1.6605D-01
+ -3.1956D-02 0.0000D+00 3.7927D-01 3.0531D-02
+ -8.5031D-04 0.0000D+00 6.2793D-01 7.8195D-04
+ -5.8584D-05 0.0000D+00 8.1156D-01 7.2478D-05
+ 1.3895D-05 0.0000D+00 9.7087D-01 7.2478D-05
+ 2.1324D+00 0.0000D+00 8.4325D-01 1.8048D+00
+ 12
+ 1.2000D+01 1.1000D+01 1.0000D+01 9.0000D+00 8.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 1.1000D+01 1.1000D+01 1.0000D+01 9.0000D+00 8.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 1.0000D+01 1.0000D+01 9.0000D+00 8.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 9.0000D+00 9.0000D+00 8.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 8.0000D+00 8.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 7.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 6.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 5.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 4.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 3.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 2.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ -2.8234D-02 0.0000D+00 2.8690D-06 3.2094D-06
+ 7.2587D-02 9.0746D-02 1.5885D-06 9.9934D-07
+ 7.2587D-02 -9.0746D-02 1.5885D-06 9.9934D-07
+ 1.8533D-01 0.0000D+00 6.5757D-07 7.8673D-07
+ 2.8828D-01 0.0000D+00 1.8324D-06 2.0796D-06
+ 6.4315D-01 0.0000D+00 6.8640D-05 6.1058D-05
+ 1.5539D+00 0.0000D+00 4.6255D-03 6.4028D-03
+ 3.5119D+00 0.0000D+00 1.4447D-01 1.9470D-01
+ 6.9615D+00 0.0000D+00 5.8447D-01 1.2016D+00
+ 1.2311D+01 0.0000D+00 3.1823D-01 1.4273D+00
+ 2.0199D+01 0.0000D+00 2.0079D-01 2.4358D+00
+ 3.2229D+01 0.0000D+00 3.0424D-01 5.6865D+00
+ 6
+ 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 5.0000D+00 0.0000D+00 2.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 4.0000D+00 0.0000D+00 3.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 3.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 2.0000D+00 0.0000D+00 5.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ -5.0000D+00 0.0000D+00 8.2295D-01 1.2318D+00
+ -3.0000D+00 0.0000D+00 7.2281D-01 7.5970D-01
+ -1.0000D+00 0.0000D+00 6.2854D-01 6.9666D-01
+ 1.0000D+00 0.0000D+00 6.2854D-01 6.9666D-01
+ 3.0000D+00 0.0000D+00 7.2281D-01 7.5970D-01
+ 5.0000D+00 0.0000D+00 8.2295D-01 1.2318D+00
+ 6
+ 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ -1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ -1.0000D+00 -1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ -1.0000D+00 -1.0000D+00 -1.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00
+ -1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 1.0000D+00 1.0000D+00
+ -1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 1.0000D+00
+ 8.0298D-02 2.4187D+00 8.9968D-01 1.5236D+00
+ 8.0298D-02 -2.4187D+00 8.9968D-01 1.5236D+00
+ 1.4415D+00 6.2850D-01 9.6734D-01 4.2793D-01
+ 1.4415D+00 -6.2850D-01 9.6734D-01 4.2793D-01
+ 1.4782D+00 1.5638D-01 9.7605D-01 2.2005D-01
+ 1.4782D+00 -1.5638D-01 9.7605D-01 2.2005D-01
+ 6
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
+ -3.5343D-02 7.4812D-01 3.9345D-01 1.8415D-01
+ -3.5343D-02 -7.4812D-01 3.9345D-01 1.8415D-01
+ 5.8440D-07 0.0000D+00 2.8868D-01 1.7003D-01
+ 6.4087D-01 7.2822D-01 4.5013D-01 2.9425D-01
+ 6.4087D-01 -7.2822D-01 4.5013D-01 2.9425D-01
+ 3.7889D+00 0.0000D+00 9.6305D-01 2.2469D+00
+ 6
+ 1.0000D+00 4.0112D+00 1.2750D+01 4.0213D+01 1.2656D+02 3.9788D+02
+ 1.0000D+00 3.2616D+00 1.0629D+01 3.3342D+01 1.0479D+02 3.2936D+02
+ 1.0000D+00 3.1500D+00 9.8006D+00 3.0630D+01 9.6164D+01 3.0215D+02
+ 1.0000D+00 3.2755D+00 1.0420D+01 3.2957D+01 1.0374D+02 3.2616D+02
+ 1.0000D+00 2.8214D+00 8.4558D+00 2.6296D+01 8.2443D+01 2.5893D+02
+ 1.0000D+00 2.6406D+00 8.3565D+00 2.6558D+01 8.3558D+01 2.6268D+02
+ -5.3220D-01 0.0000D+00 5.3287D-01 3.8557D-01
+ -1.0118D-01 0.0000D+00 7.2342D-01 9.1303D-02
+ -9.8749D-03 0.0000D+00 7.3708D-01 1.1032D-02
+ 2.9861D-03 0.0000D+00 4.4610D-01 1.2861D-02
+ 1.8075D-01 0.0000D+00 4.2881D-01 1.7378D-01
+ 3.9260D+02 0.0000D+00 4.8057D-01 3.9201D+02
+ 8
+ 0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00
+ 1.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 4.0000D+00
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 4.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 0.0000D+00 4.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 1.0000D+00 0.0000D+00
+ -3.7588D+00 0.0000D+00 1.2253D-01 1.2978D-01
+ -3.0642D+00 0.0000D+00 4.9811D-02 8.0162D-02
+ -2.0000D+00 0.0000D+00 3.6914D-02 8.2942D-02
+ -6.9459D-01 0.0000D+00 3.3328D-02 1.3738D-01
+ 6.9459D-01 0.0000D+00 3.3328D-02 1.1171D-01
+ 2.0000D+00 0.0000D+00 3.6914D-02 7.2156D-02
+ 3.0642D+00 0.0000D+00 4.9811D-02 6.8352D-02
+ 3.7588D+00 0.0000D+00 1.2253D-01 1.1527D-01
+ 6
+ 8.5000D+00 -1.0472D+01 2.8944D+00 -1.5279D+00 1.1056D+00 -5.0000D-01
+ 2.6180D+00 -1.1708D+00 -2.0000D+00 8.9440D-01 -6.1800D-01 2.7640D-01
+ -7.2360D-01 2.0000D+00 -1.7080D-01 -1.6180D+00 8.9440D-01 -3.8200D-01
+ 3.8200D-01 -8.9440D-01 1.6180D+00 1.7080D-01 -2.0000D+00 7.2360D-01
+ -2.7640D-01 6.1800D-01 -8.9440D-01 2.0000D+00 1.1708D+00 -2.6180D+00
+ 5.0000D-01 -1.1056D+00 1.5279D+00 -2.8944D+00 1.0472D+01 -8.5000D+00
+ -5.8930D-01 0.0000D+00 1.7357D-04 2.8157D-04
+ -2.7627D-01 4.9852D-01 1.7486D-04 1.6704D-04
+ -2.7627D-01 -4.9852D-01 1.7486D-04 1.6704D-04
+ 2.7509D-01 5.0059D-01 1.7635D-04 1.6828D-04
+ 2.7509D-01 -5.0059D-01 1.7635D-04 1.6828D-04
+ 5.9167D-01 0.0000D+00 1.7623D-04 3.0778D-04
+ 4
+ 4.0000D+00 -5.0000D+00 0.0000D+00 3.0000D+00
+ 0.0000D+00 4.0000D+00 -3.0000D+00 -5.0000D+00
+ 5.0000D+00 -3.0000D+00 4.0000D+00 0.0000D+00
+ 3.0000D+00 0.0000D+00 5.0000D+00 4.0000D+00
+ 1.0000D+00 5.0000D+00 1.0000D+00 4.3333D+00
+ 1.0000D+00 -5.0000D+00 1.0000D+00 4.3333D+00
+ 2.0000D+00 0.0000D+00 1.0000D+00 4.3333D+00
+ 1.2000D+01 0.0000D+00 1.0000D+00 9.1250D+00
+ 5
+ 1.5000D+01 1.1000D+01 6.0000D+00 -9.0000D+00 -1.5000D+01
+ 1.0000D+00 3.0000D+00 9.0000D+00 -3.0000D+00 -8.0000D+00
+ 7.0000D+00 6.0000D+00 6.0000D+00 -3.0000D+00 -1.1000D+01
+ 7.0000D+00 7.0000D+00 5.0000D+00 -3.0000D+00 -1.1000D+01
+ 1.7000D+01 1.2000D+01 5.0000D+00 -1.0000D+01 -1.6000D+01
+ -9.9999D-01 0.0000D+00 2.1768D-01 5.2263D-01
+ 1.4980D+00 3.5752D+00 3.9966D-04 6.0947D-03
+ 1.4980D+00 -3.5752D+00 3.9966D-04 6.0947D-03
+ 1.5020D+00 3.5662D+00 3.9976D-04 6.0960D-03
+ 1.5020D+00 -3.5662D+00 3.9976D-04 6.0960D-03
+ 6
+ -9.0000D+00 2.1000D+01 -1.5000D+01 4.0000D+00 2.0000D+00 0.0000D+00
+ -1.0000D+01 2.1000D+01 -1.4000D+01 4.0000D+00 2.0000D+00 0.0000D+00
+ -8.0000D+00 1.6000D+01 -1.1000D+01 4.0000D+00 2.0000D+00 0.0000D+00
+ -6.0000D+00 1.2000D+01 -9.0000D+00 3.0000D+00 3.0000D+00 0.0000D+00
+ -4.0000D+00 8.0000D+00 -6.0000D+00 0.0000D+00 5.0000D+00 0.0000D+00
+ -2.0000D+00 4.0000D+00 -3.0000D+00 0.0000D+00 1.0000D+00 3.0000D+00
+ 1.0000D+00 6.2559D-04 6.4875D-05 5.0367D-04
+ 1.0000D+00 -6.2559D-04 6.4875D-05 5.0367D-04
+ 2.0000D+00 1.0001D+00 5.4076D-02 2.3507D-01
+ 2.0000D+00 -1.0001D+00 5.4076D-02 2.3507D-01
+ 3.0000D+00 0.0000D+00 8.6149D-01 5.4838D-07
+ 3.0000D+00 0.0000D+00 1.2425D-01 1.2770D-06
+ 10
+ 1.0000D+00 1.0000D+00 1.0000D+00 -2.0000D+00 1.0000D+00 -1.0000D+00
+ 2.0000D+00 -2.0000D+00 4.0000D+00 -3.0000D+00
+ -1.0000D+00 2.0000D+00 3.0000D+00 -4.0000D+00 2.0000D+00 -2.0000D+00
+ 4.0000D+00 -4.0000D+00 8.0000D+00 -6.0000D+00
+ -1.0000D+00 0.0000D+00 5.0000D+00 -5.0000D+00 3.0000D+00 -3.0000D+00
+ 6.0000D+00 -6.0000D+00 1.2000D+01 -9.0000D+00
+ -1.0000D+00 0.0000D+00 3.0000D+00 -4.0000D+00 4.0000D+00 -4.0000D+00
+ 8.0000D+00 -8.0000D+00 1.6000D+01 -1.2000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 5.0000D+00 -4.0000D+00
+ 1.0000D+01 -1.0000D+01 2.0000D+01 -1.5000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -2.0000D+00
+ 1.2000D+01 -1.2000D+01 2.4000D+01 -1.8000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
+ 1.5000D+01 -1.3000D+01 2.8000D+01 -2.1000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
+ 1.2000D+01 -1.1000D+01 3.2000D+01 -2.4000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
+ 1.2000D+01 -1.4000D+01 3.7000D+01 -2.6000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
+ 1.2000D+01 -1.4000D+01 3.6000D+01 -2.5000D+01
+ 1.0000D+00 0.0000D+00 3.6037D-02 7.9613D-02
+ 1.9867D+00 0.0000D+00 7.4283D-05 7.4025D-06
+ 2.0000D+00 2.5052D-03 1.4346D-04 6.7839D-07
+ 2.0000D+00 -2.5052D-03 1.4346D-04 6.7839D-07
+ 2.0067D+00 1.1763D-02 6.7873D-05 5.7496D-06
+ 2.0067D+00 -1.1763D-02 6.7873D-05 5.7496D-06
+ 2.9970D+00 0.0000D+00 9.2779D-05 2.6519D-06
+ 3.0000D+00 8.7028D-04 2.7358D-04 1.9407D-07
+ 3.0000D+00 -8.7028D-04 2.7358D-04 1.9407D-07
+ 3.0030D+00 0.0000D+00 9.2696D-05 2.6477D-06
+ 0
+DSX Data file for Real Nonsymmetric Schur Form Expert Driver
+6 Number of matrix dimensions
+0 1 2 3 5 10 20 Matrix dimensions
+3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
+20.0 Threshold for test ratios
+T
+2 Read another line with random number generator seed
+2518 3899 995 397 Seed for random number generator
+DSX 21 Use all matrix types
+ 1 1
+ 1
+ 0.00000D+00
+ 1.00000D+00 0.00000D+00
+ 1 1
+ 1
+ 1.00000D+00
+ 1.00000D+00 1.00000D+00
+ 6 6
+ 1 2 3 4 5 6
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+00 4.43734D-31
+ 6 0
+ 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 1.00000D+00 1.00000D+00
+ 6 6
+ 1 2 3 4 5 6
+ 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 1.00000D+00 2.00000D+00
+ 6 1
+ 1
+ 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00
+ 1.00000D+00 2.00000D+00
+ 6 3
+ 4 5 6
+ 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 2.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 3.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 4.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 6.00000D+00
+ 1.00000D+00 1.00000D+00
+ 2 1
+ 1
+ 1.00000D+00 2.00000D+00
+ 0.00000D+00 3.00000D+00
+ 7.07107D-01 2.00000D+00
+ 4 2
+ 1 2
+ 8.52400D-01 5.61100D-01 7.04300D-01 9.54000D-01
+ 2.79800D-01 7.21600D-01 9.61300D-01 3.58200D-01
+ 7.08100D-01 4.09400D-01 2.25000D-01 9.51800D-01
+ 5.54300D-01 5.22000D-01 6.86000D-01 3.07000D-02
+ 7.22196D-01 4.63943D-01
+ 7 6
+ 1 2 3 4 5 6
+ 7.81800D-01 5.65700D-01 7.62100D-01 7.43600D-01 2.55300D-01 4.10000D-01
+ 1.34000D-02
+ 6.45800D-01 2.66600D-01 5.51000D-01 8.31800D-01 9.27100D-01 6.20900D-01
+ 7.83900D-01
+ 1.31600D-01 4.91400D-01 1.77100D-01 1.96400D-01 1.08500D-01 9.27000D-01
+ 2.24700D-01
+ 6.41000D-01 4.68900D-01 9.65900D-01 8.88400D-01 3.76900D-01 9.67300D-01
+ 6.18300D-01
+ 8.38200D-01 8.74300D-01 4.50700D-01 9.44200D-01 7.75500D-01 9.67600D-01
+ 7.83100D-01
+ 3.25900D-01 7.38900D-01 8.30200D-01 4.52100D-01 3.01500D-01 2.13300D-01
+ 8.43400D-01
+ 5.24400D-01 5.01600D-01 7.52900D-01 3.83800D-01 8.47900D-01 9.12800D-01
+ 5.77000D-01
+ 9.43220D-01 3.20530D+00
+ 4 2
+ 2 3
+ -9.85900D-01 1.47840D+00 -1.33600D-01 -2.95970D+00
+ -4.33700D-01 -6.54000D-01 -7.15500D-01 1.23760D+00
+ -7.36300D-01 -1.97680D+00 -1.95100D-01 3.43200D-01
+ 6.41400D-01 -1.40880D+00 6.39400D-01 8.58000D-02
+ 5.22869D-01 5.45530D-01
+ 7 5
+ 1 2 3 4 5
+ 2.72840D+00 2.15200D-01 -1.05200D+00 -2.44600D-01 -6.53000D-02 3.90500D-01
+ 1.40980D+00
+ 9.75300D-01 6.51500D-01 -4.76200D-01 5.42100D-01 6.20900D-01 4.75900D-01
+ -1.44930D+00
+ -9.05200D-01 1.79000D-01 -7.08600D-01 4.62100D-01 1.05800D+00 2.24260D+00
+ 1.58260D+00
+ -7.17900D-01 -2.53400D-01 -4.73900D-01 -1.08100D+00 4.13800D-01 -9.50000D-02
+ 1.45300D-01
+ -1.37990D+00 -1.06490D+00 1.25580D+00 7.80100D-01 -6.40500D-01 -8.61000D-02
+ 8.30000D-02
+ 2.84900D-01 -1.29900D-01 4.80000D-02 -2.58600D-01 4.18900D-01 1.37680D+00
+ 8.20800D-01
+ -5.44200D-01 9.74900D-01 9.55800D-01 1.23700D-01 1.09020D+00 -1.40600D-01
+ 1.90960D+00
+ 6.04729D-01 9.00391D-01
+ 6 4
+ 3 4 5 6
+ 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
+ 1.00000D-06 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D-01
+ 4.89525D-05 4.56492D-05
+ 8 4
+ 1 2 3 4
+ 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00
+ 1.00000D+01 0.00000D+00
+ 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01
+ 1.00000D+01 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 1.00000D+01
+ 1.00000D+01 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+01
+ 0.00000D+00 1.00000D+01
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D-01 1.00000D+00
+ 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D-01
+ 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 5.00000D-01 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 5.00000D-01
+ 9.56158D-05 4.14317D-05
+ 9 3
+ 1 2 3
+ 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 7.50000D-01 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 7.50000D-01 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 7.50000D-01
+ 1.00000D+00 5.55801D-07
+ 10 4
+ 1 2 3 4
+ 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 8.75000D-01 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 8.75000D-01 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 8.75000D-01 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 8.75000D-01
+ 1.00000D+00 1.16972D-10
+ 12 6
+ 1 2 3 4 5 6
+ 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+01 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+01 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 9.37500D-01 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 9.37500D-01 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 9.37500D-01 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 9.37500D-01 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 9.37500D-01 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 9.37500D-01
+ 1.85655D-10 2.20147D-16
+ 12 7
+ 6 7 8 9 10 11 12
+ 1.20000D+01 1.10000D+01 1.00000D+01 9.00000D+00 8.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 1.10000D+01 1.10000D+01 1.00000D+01 9.00000D+00 8.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 1.00000D+01 1.00000D+01 9.00000D+00 8.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 9.00000D+00 9.00000D+00 8.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 8.00000D+00 8.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 7.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 6.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 5.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 4.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 3.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 2.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00
+ 6.92558D-05 5.52606D-05
+ 3 1
+ 1
+ 2.00000D-06 1.00000D+00 -2.00000D+00
+ 1.00000D-06 -2.00000D+00 4.00000D+00
+ 0.00000D+00 1.00000D+00 -2.00000D+00
+ 7.30297D-01 4.00000D+00
+ 5 1
+ 3
+ 2.00000D-03 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D-03 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 -1.00000D-03 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 -2.00000D-03 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 3.99999D-12 3.99201D-12
+ 6 4
+ 1 2 3 5
+ 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00
+ 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00
+ 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00
+ 2.93294D-01 1.63448D-01
+ 6 2
+ 3 4
+ 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 1.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+00
+ -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
+ 3.97360D-01 3.58295D-01
+ 6 3
+ 3 4 5
+ 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00
+ 5.00000D-01 3.33300D-01 2.50000D-01 2.00000D-01 1.66700D-01 1.42900D-01
+ 3.33300D-01 2.50000D-01 2.00000D-01 1.66700D-01 1.42900D-01 1.25000D-01
+ 2.50000D-01 2.00000D-01 1.66700D-01 1.42900D-01 1.25000D-01 1.11100D-01
+ 2.00000D-01 1.66700D-01 1.42900D-01 1.25000D-01 1.11100D-01 1.00000D-01
+ 1.66700D-01 1.42900D-01 1.25000D-01 1.11100D-01 1.00000D-01 9.09000D-02
+ 7.28934D-01 1.24624D-02
+ 5 1
+ 1
+ 1.50000D+01 1.10000D+01 6.00000D+00 -9.00000D+00 -1.50000D+01
+ 1.00000D+00 3.00000D+00 9.00000D+00 -3.00000D+00 -8.00000D+00
+ 7.00000D+00 6.00000D+00 6.00000D+00 -3.00000D+00 -1.10000D+01
+ 7.00000D+00 7.00000D+00 5.00000D+00 -3.00000D+00 -1.10000D+01
+ 1.70000D+01 1.20000D+01 5.00000D+00 -1.00000D+01 -1.60000D+01
+ 2.17680D-01 5.22626D-01
+ 6 2
+ 1 2
+ -9.00000D+00 2.10000D+01 -1.50000D+01 4.00000D+00 2.00000D+00 0.00000D+00
+ -1.00000D+01 2.10000D+01 -1.40000D+01 4.00000D+00 2.00000D+00 0.00000D+00
+ -8.00000D+00 1.60000D+01 -1.10000D+01 4.00000D+00 2.00000D+00 0.00000D+00
+ -6.00000D+00 1.20000D+01 -9.00000D+00 3.00000D+00 3.00000D+00 0.00000D+00
+ -4.00000D+00 8.00000D+00 -6.00000D+00 0.00000D+00 5.00000D+00 0.00000D+00
+ -2.00000D+00 4.00000D+00 -3.00000D+00 0.00000D+00 1.00000D+00 3.00000D+00
+ 6.78904D-02 4.22005D-02
+ 10 1
+ 1
+ 1.00000D+00 1.00000D+00 1.00000D+00 -2.00000D+00 1.00000D+00 -1.00000D+00
+ 2.00000D+00 -2.00000D+00 4.00000D+00 -3.00000D+00
+ -1.00000D+00 2.00000D+00 3.00000D+00 -4.00000D+00 2.00000D+00 -2.00000D+00
+ 4.00000D+00 -4.00000D+00 8.00000D+00 -6.00000D+00
+ -1.00000D+00 0.00000D+00 5.00000D+00 -5.00000D+00 3.00000D+00 -3.00000D+00
+ 6.00000D+00 -6.00000D+00 1.20000D+01 -9.00000D+00
+ -1.00000D+00 0.00000D+00 3.00000D+00 -4.00000D+00 4.00000D+00 -4.00000D+00
+ 8.00000D+00 -8.00000D+00 1.60000D+01 -1.20000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 5.00000D+00 -4.00000D+00
+ 1.00000D+01 -1.00000D+01 2.00000D+01 -1.50000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -2.00000D+00
+ 1.20000D+01 -1.20000D+01 2.40000D+01 -1.80000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
+ 1.50000D+01 -1.30000D+01 2.80000D+01 -2.10000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
+ 1.20000D+01 -1.10000D+01 3.20000D+01 -2.40000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
+ 1.20000D+01 -1.40000D+01 3.70000D+01 -2.60000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
+ 1.20000D+01 -1.40000D+01 3.60000D+01 -2.50000D+01
+ 3.60372D-02 7.96134D-02
+ 0 0
diff --git a/TESTING/dgbak.in b/TESTING/dgbak.in
new file mode 100644
index 0000000..633ec77
--- /dev/null
+++ b/TESTING/dgbak.in
@@ -0,0 +1,266 @@
+DGK: Tests DGGBAK
+ 6 3
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.6000D+01
+
+ 0.6000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.5000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.2000D+01 0.2000D+01 0.2000D+01
+ 0.3000D+01 0.3000D+01 0.3000D+01
+ 0.4000D+01 0.4000D+01 0.4000D+01
+ 0.5000D+01 0.5000D+01 0.5000D+01
+ 0.6000D+01 0.6000D+01 0.6000D+01
+
+ -0.1000D+01 -0.1000D+01 -0.1000D+01
+ -0.2000D+01 -0.2000D+01 -0.2000D+01
+ -0.3000D+01 -0.3000D+01 -0.3000D+01
+ -0.4000D+01 -0.4000D+01 -0.4000D+01
+ -0.5000D+01 -0.5000D+01 -0.5000D+01
+ -0.6000D+01 -0.6000D+01 -0.6000D+01
+
+ 6 3
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.2000D+01 0.2100D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.3000D+01 0.3100D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.4000D+01 0.4100D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+01 0.5100D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.6000D+01 0.6100D+01
+
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.6000D+01
+
+ 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.2000D+01 0.2000D+01 0.2000D+01
+ 0.3000D+01 0.3000D+01 0.3000D+01
+ 0.4000D+01 0.4000D+01 0.4000D+01
+ 0.5000D+01 0.5000D+01 0.5000D+01
+ 0.6000D+01 0.6000D+01 0.6000D+01
+
+ -0.1000D+01 -0.1000D+01 -0.1000D+01
+ -0.2000D+01 -0.2000D+01 -0.2000D+01
+ -0.3000D+01 -0.3000D+01 -0.3000D+01
+ -0.4000D+01 -0.4000D+01 -0.4000D+01
+ -0.5000D+01 -0.5000D+01 -0.5000D+01
+ -0.6000D+01 -0.6000D+01 -0.6000D+01
+
+ 5 5
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01
+
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.2000D+01 0.2000D+01 0.2000D+01 0.2000D+01 0.2000D+01
+ 0.3000D+01 0.3000D+01 0.3000D+01 0.3000D+01 0.3000D+01
+ 0.4000D+01 0.4000D+01 0.4000D+01 0.4000D+01 0.4000D+01
+ 0.5000D+01 0.5000D+01 0.5000D+01 0.5000D+01 0.5000D+01
+
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.2000D+01 0.2000D+01 0.2000D+01 0.2000D+01 0.2000D+01
+ 0.3000D+01 0.3000D+01 0.3000D+01 0.3000D+01 0.3000D+01
+ 0.4000D+01 0.4000D+01 0.4000D+01 0.4000D+01 0.4000D+01
+ 0.5000D+01 0.5000D+01 0.5000D+01 0.5000D+01 0.5000D+01
+
+ 6 5
+ 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+
+ 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+
+ 0.1000D+01 0.2000D+01 -0.3000D+01 0.4000D+01 0.5000D+01
+ 0.8000D+01 0.9000D+01 0.0000D+00 0.9000D+01 0.2000D+01
+ 0.0000D+00 -0.9000D+01 0.2000D+01 0.1000D+01 0.1000D+01
+ 0.8000D+01 0.2000D+01 0.1000D+01 0.0000D+00 0.2000D+01
+ 0.0000D+00 0.3000D+01 0.2000D+01 0.1000D+01 0.1000D+01
+ 0.2000D+01 0.1000D+01 0.9000D+01 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 -0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01
+ -0.8000D+01 0.9000D+01 0.0000D+00 0.9000D+01 0.2000D+01
+ 0.0000D+00 0.9000D+01 0.2000D+01 0.1000D+01 0.1000D+01
+ 0.8000D+01 0.2000D+01 0.1000D+01 0.0000D+00 0.2000D+01
+ 0.0000D+00 0.3000D+01 0.2000D+01 0.1000D+01 0.1000D+01
+ 0.2000D+01 0.8000D+01 0.9000D+01 0.0000D+00 0.1000D+01
+
+ 6 2
+ 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D+07
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D-05
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+07 0.1000D+07
+
+ 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D+07
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D-05
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+07 0.1000D+07
+
+ 0.1000D+01 0.1000D+01
+ 0.2000D+01 0.2000D+01
+ 0.3000D+01 0.3000D+01
+ 0.4000D+01 0.4000D+01
+ 0.5000D+01 0.5000D+01
+ 0.6000D+01 0.6000D+01
+
+ 0.1100D+01 0.1100D+01
+ 0.2200D+01 0.2200D+01
+ 0.3300D+01 0.3300D+01
+ 0.4400D+01 0.4400D+01
+ 0.5500D+01 0.5500D+01
+ 0.6600D+01 0.6600D+01
+
+ 7 3
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+
+ 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.2000D+01 0.2000D+01 0.2000D+01
+ 0.3000D+01 0.3000D+01 0.3000D+01
+ 0.4000D+01 0.4000D+01 0.4000D+01
+ 0.5000D+01 0.5000D+01 0.5000D+01
+ 0.6000D+01 0.6000D+01 0.6000D+01
+ 0.7000D+01 0.7000D+01 0.7000D+01
+
+ -0.1000D+01 -0.1000D+01 -0.1000D+01
+ -0.2000D+01 -0.2000D+01 -0.2000D+01
+ -0.3000D+01 -0.3000D+01 -0.3000D+01
+ -0.4000D+01 -0.4000D+01 -0.4000D+01
+ -0.5000D+01 -0.5000D+01 -0.5000D+01
+ -0.6000D+01 -0.6000D+01 -0.6000D+01
+ -0.7000D+01 -0.7000D+01 -0.7000D+01
+
+ 7 3
+ 0.0000D+00 0.1000D+04 0.0000D+00 0.1000D+04 0.1000D+04 0.1000D+04
+ 0.1000D-04
+ 0.0000D+00 0.1000D-04 0.1000D+04 0.1000D-04 0.1000D-04 0.1000D+04
+ 0.1000D+04
+ 0.1000D+04 0.1000D+04 0.1000D-04 0.1000D+04 0.1000D+04 0.1000D+04
+ 0.1000D+04
+ 0.0000D+00 0.1000D-04 0.0000D+00 0.1000D+00 0.1000D+04 0.1000D-04
+ 0.1000D+04
+ 0.0000D+00 0.1000D+04 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00
+ 0.0000D+00 0.4000D-04 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D-04
+ 0.0000D+00 0.1000D+04 0.0000D+00 0.1000D+04 0.1000D+04 0.1000D-04
+ 0.1000D+04
+
+ 0.0000D+00 0.1000D-01 0.0000D+00 0.1000D+04 0.1000D-04 0.1000D+04
+ 0.1000D+04
+ 0.0000D+00 0.1000D+04 0.1000D+04 0.1000D+04 0.1000D+04 0.1000D+00
+ 0.1000D+04
+ 0.1000D+04 0.1000D+04 0.1000D+04 0.1000D+04 0.1000D-04 0.1000D+04
+ 0.1000D+04
+ 0.0000D+00 0.4000D-01 0.0000D+00 0.1000D+04 0.1000D+01 0.1000D+04
+ 0.1000D+04
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01
+ 0.0000D+00 0.1000D-04 0.0000D+00 0.1000D+04 0.1000D+01 0.1000D+01
+ 0.1000D-04
+
+ 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.2000D+01 0.2000D+01 0.2000D+01
+ 0.3000D+01 0.3000D+01 0.3000D+01
+ 0.4000D+01 0.4000D+01 0.4000D+01
+ 0.5000D+01 0.5000D+01 0.5000D+01
+ 0.6000D+01 0.6000D+01 0.6000D+01
+ 0.7000D+01 0.7000D+01 0.7000D+01
+
+ 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.2000D+01 0.2000D+01 0.2000D+01
+ 0.3000D+01 0.3000D+01 0.3000D+01
+ 0.4000D+01 0.4000D+01 0.4000D+01
+ 0.5000D+01 0.5000D+01 0.5000D+01
+ 0.6000D+01 0.6000D+01 0.6000D+01
+ 0.7000D+01 0.7000D+01 0.7000D+01
+
+ 6 2
+ -0.2000D+02 -0.1000D+05 -0.2000D+01 -0.1000D+07 -0.1000D+02 -0.2000D+06
+ 0.6000D-02 0.4000D+01 0.6000D-03 0.2000D+03 0.3000D-02 0.3000D+02
+ -0.2000D+00 -0.3000D+03 -0.4000D-01 -0.1000D+05 0.0000D+00 0.3000D+04
+ 0.6000D-04 0.4000D-01 0.9000D-05 0.9000D+01 0.3000D-04 0.5000D+00
+ 0.6000D-01 0.5000D+02 0.8000D-02 -0.4000D+04 0.8000D-01 0.0000D+00
+ 0.0000D+00 0.1000D+04 0.7000D+00 -0.2000D+06 0.1300D+02 -0.6000D+05
+
+ -0.2000D+02 -0.1000D+05 0.2000D+01 -0.2000D+07 0.1000D+02 -0.1000D+06
+ 0.5000D-02 0.3000D+01 -0.2000D-03 0.4000D+03 -0.1000D-02 0.3000D+02
+ 0.0000D+00 -0.1000D+03 -0.8000D-01 0.2000D+05 -0.4000D+00 0.0000D+00
+ 0.5000D-04 0.3000D-01 0.2000D-05 0.4000D+01 0.2000D-04 0.1000D+00
+ 0.4000D-01 0.3000D+02 -0.1000D-02 0.3000D+04 -0.1000D-01 0.6000D+03
+ -0.1000D+01 0.0000D+00 0.4000D+00 -0.1000D+06 0.4000D+01 0.2000D+05
+
+ 0.1000D+01 0.1000D+01
+ 0.2000D+01 0.2000D+01
+ 0.3000D+01 0.3000D+01
+ 0.4000D+01 0.4000D+01
+ 0.5000D+01 0.5000D+01
+ 0.6000D+01 0.6000D+01
+
+ 0.1000D+02 0.1000D+02
+ 0.2000D+02 0.2000D+02
+ 0.3000D+02 0.3000D+02
+ 0.4000D+02 0.4000D+02
+ 0.5000D+02 0.5000D+02
+ 0.6000D+02 0.6000D+02
+
+0 0
diff --git a/TESTING/dgbal.in b/TESTING/dgbal.in
new file mode 100644
index 0000000..f2f7cc5
--- /dev/null
+++ b/TESTING/dgbal.in
@@ -0,0 +1,304 @@
+DGL: Tests DGGBAL
+ 6
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.6000D+01
+
+ 0.6000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.5000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 1 1
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.6000D+01
+
+ 0.6000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.5000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01 0.6000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01 0.6000D+01
+
+ 6
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01
+
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 1 1
+ 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 6
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01 0.6000D+01
+
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01 0.6000D+01
+
+ 1 1
+ 0.6000D+01 0.5000D+01 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.5000D+01 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.6000D+01 0.5000D+01 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.5000D+01 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 5
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01
+
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 1 1
+ 0.5000D+01 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 6
+ 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+
+ 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+
+ 1 6
+ 0.1000D-03 0.1000D+05 0.1000D+04 0.1000D+02 0.1000D+00 0.1000D-01
+ 0.1000D-02 0.1000D-04 0.1000D+05 0.1000D+03 0.1000D+01 0.1000D+00
+ 0.1000D+00 0.1000D-02 0.1000D-03 0.1000D+05 0.1000D+03 0.1000D+02
+ 0.1000D+02 0.1000D+00 0.1000D-01 0.1000D-03 0.1000D+05 0.1000D+04
+ 0.1000D+03 0.1000D+01 0.1000D+00 0.1000D-02 0.1000D-04 0.1000D+05
+ 0.1000D+05 0.1000D+03 0.1000D+02 0.1000D+00 0.1000D-02 0.1000D-03
+
+ 0.1000D-03 0.1000D+05 0.1000D+04 0.1000D+02 0.1000D+00 0.1000D-01
+ 0.1000D-02 0.1000D-04 0.1000D+05 0.1000D+03 0.1000D+01 0.1000D+00
+ 0.1000D+00 0.1000D-02 0.1000D-03 0.1000D+05 0.1000D+03 0.1000D+02
+ 0.1000D+02 0.1000D+00 0.1000D-01 0.1000D-03 0.1000D+05 0.1000D+04
+ 0.1000D+03 0.1000D+01 0.1000D+00 0.1000D-02 0.1000D-04 0.1000D+05
+ 0.1000D+05 0.1000D+03 0.1000D+02 0.1000D+00 0.1000D-02 0.1000D-03
+
+ 0.1000D-05 0.1000D-04 0.1000D-02 0.1000D+00 0.1000D+01 0.1000D+03
+
+ 0.1000D+03 0.1000D+01 0.1000D+00 0.1000D-02 0.1000D-04 0.1000D-05
+
+ 6
+ 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D+07
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D-05
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+07 0.1000D+07
+
+ 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D+07
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D-05
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+07 0.1000D+07
+
+ 4 6
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D-04 0.1000D+04 0.1000D+00
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D-04 0.1000D+04 0.1000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D-04 0.1000D+04 0.1000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D-03 0.1000D+05
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+05 0.1000D+01 0.1000D-03
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-03 0.1000D+05 0.1000D+01
+
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D-04 0.1000D+04 0.1000D+00
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D-04 0.1000D+04 0.1000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D-04 0.1000D+04 0.1000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D-03 0.1000D+05
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+05 0.1000D+01 0.1000D-03
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-03 0.1000D+05 0.1000D+01
+
+ 0.4000D+01 0.4000D+01 0.4000D+01 0.1000D+00 0.1000D+04 0.1000D-04
+
+ 0.2000D+01 0.3000D+01 0.4000D+01 0.1000D-04 0.1000D+04 0.1000D+00
+
+ 7
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+
+ 3 5
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01
+
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01
+
+ 0.3000D+01 0.2000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.6000D+01
+ 0.5000D+01
+
+ 0.1000D+01 0.3000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.2000D+01
+ 0.2000D+01
+
+ 6
+ -0.2000D+02 -0.1000D+05 -0.2000D+01 -0.1000D+07 -0.1000D+02 -0.2000D+06
+ 0.6000D-02 0.4000D+01 0.6000D-03 0.2000D+03 0.3000D-02 0.3000D+02
+ -0.2000D+00 -0.3000D+03 -0.4000D-01 -0.1000D+05 0.0000D+00 0.3000D+04
+ 0.6000D-04 0.4000D-01 0.9000D-05 0.9000D+01 0.3000D-04 0.5000D+00
+ 0.6000D-01 0.5000D+02 0.8000D-02 -0.4000D+04 0.8000D-01 0.0000D+00
+ 0.0000D+00 0.1000D+04 0.7000D+00 -0.2000D+06 0.1300D+02 -0.6000D+05
+
+ -0.2000D+02 -0.1000D+05 0.2000D+01 -0.2000D+07 0.1000D+02 -0.1000D+06
+ 0.5000D-02 0.3000D+01 -0.2000D-03 0.4000D+03 -0.1000D-02 0.3000D+02
+ 0.0000D+00 -0.1000D+03 -0.8000D-01 0.2000D+05 -0.4000D+00 0.0000D+00
+ 0.5000D-04 0.3000D-01 0.2000D-05 0.4000D+01 0.2000D-04 0.1000D+00
+ 0.4000D-01 0.3000D+02 -0.1000D-02 0.3000D+04 -0.1000D-01 0.6000D+03
+ -0.1000D+01 0.0000D+00 0.4000D+00 -0.1000D+06 0.4000D+01 0.2000D+05
+
+ 1 6
+ -0.2000D+00 -0.1000D+01 -0.2000D+00 -0.1000D+01 -0.1000D+01 -0.2000D+01
+ 0.6000D+00 0.4000D+01 0.6000D+00 0.2000D+01 0.3000D+01 0.3000D+01
+ -0.2000D+00 -0.3000D+01 -0.4000D+00 -0.1000D+01 0.0000D+00 0.3000D+01
+ 0.6000D+00 0.4000D+01 0.9000D+00 0.9000D+01 0.3000D+01 0.5000D+01
+ 0.6000D+00 0.5000D+01 0.8000D+00 -0.4000D+01 0.8000D+01 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.7000D+00 -0.2000D+01 0.1300D+02 -0.6000D+01
+
+ -0.2000D+00 -0.1000D+01 0.2000D+00 -0.2000D+01 0.1000D+01 -0.1000D+01
+ 0.5000D+00 0.3000D+01 -0.2000D+00 0.4000D+01 -0.1000D+01 0.3000D+01
+ 0.0000D+00 -0.1000D+01 -0.8000D+00 0.2000D+01 -0.4000D+01 0.0000D+00
+ 0.5000D+00 0.3000D+01 0.2000D+00 0.4000D+01 0.2000D+01 0.1000D+01
+ 0.4000D+00 0.3000D+01 -0.1000D+00 0.3000D+01 -0.1000D+01 0.6000D+01
+ -0.1000D+00 0.0000D+00 0.4000D+00 -0.1000D+01 0.4000D+01 0.2000D+01
+
+ 0.1000D-02 0.1000D+02 0.1000D+00 0.1000D+04 0.1000D+01 0.1000D-01
+
+ 0.1000D+02 0.1000D+00 0.1000D+03 0.1000D-02 0.1000D+03 0.1000D-01
+
+0
diff --git a/TESTING/dgd.in b/TESTING/dgd.in
new file mode 100644
index 0000000..42ff716
--- /dev/null
+++ b/TESTING/dgd.in
@@ -0,0 +1,86 @@
+DGS Data for the Real Nonsymmetric Schur Form Driver
+5 Number of matrix dimensions
+2 6 10 12 20 30 Matrix dimensions
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+DGS 26 Test all 26 matrix types
+DGV Data for the Real Nonsymmetric Eigenvalue Problem Driver
+6 Number of matrix dimensions
+2 6 8 10 15 20 Matrix dimensions
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold value
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+DGV 26 Test all 26 matrix types
+DGX Data for the Real Nonsymmetric Schur Form Expert Driver
+2 Largest matrix dimension (0 <= NSIZE <= 5)
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+DGX Data for the Real Nonsymmetric Schur Form Expert Driver
+0 Largest matrix dimension
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+ 4
+ 2
+ 8.0000D+00 4.0000D+00 -1.3000D+01 4.0000D+00 Input matrix A
+ 0.0000D+00 7.0000D+00 -2.4000D+01 -3.0000D+00
+ 0.0000D+00 0.0000D+00 3.0000D+00 -5.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.6000D+01
+ 9.0000D+00 -1.0000D+00 1.0000D+00 -6.0000D+00 Input matrix B
+ 0.0000D+00 4.0000D+00 1.6000D+01 -2.4000D+01
+ 0.0000D+00 0.0000D+00 -1.1000D+01 6.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 4.0000D+00
+ 2.5901D-01 1.7592D+00 Condition #'s for cluster selected from lower 2x2
+ 4
+ 2
+ 1.0000D+00 2.0000D+00 3.0000D+00 4.0000D+00 Input matrix A
+ 0.0000D+00 5.0000D+00 6.0000D+00 7.0000D+00
+ 0.0000D+00 0.0000D+00 8.0000D+00 9.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+01
+ -1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 Input matrix B
+ 0.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 -1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 9.8173D-01 6.3649D-01 Condition #'s for cluster selected from lower 2x2
+0
+DXV Data for the Real Nonsymmetric Eigenvalue Expert Driver
+5 Largest matrix dimension
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+DXV Data for the Real Nonsymmetric Eigenvalue Expert Driver
+0 Largest matrix dimension
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+ 4
+ 8.0000D+00 4.0000D+00 -1.3000D+01 4.0000D+00 Input matrix A
+ 0.0000D+00 7.0000D+00 -2.4000D+01 -3.0000D+00
+ 0.0000D+00 0.0000D+00 3.0000D+00 -5.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.6000D+01
+ 9.0000D+00 -1.0000D+00 1.0000D+00 -6.0000D+00 Input matrix B
+ 0.0000D+00 4.0000D+00 1.6000D+01 -2.4000D+01
+ 0.0000D+00 0.0000D+00 -1.1000D+01 6.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 4.0000D+00
+ 3.1476D+00 2.5286D+00 4.2241D+00 3.4160D+00 eigenvalue condition #'s
+ 6.7340D-01 1.1380D+00 3.5424D+00 9.5917D-01 eigenvector condition #'s
+ 4
+ 1.0000D+00 2.0000D+00 3.0000D+00 4.0000D+00 Input matrix A
+ 0.0000D+00 5.0000D+00 6.0000D+00 7.0000D+00
+ 0.0000D+00 0.0000D+00 8.0000D+00 9.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+01
+ -1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 Input matrix B
+ 0.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 -1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 1.3639D+00 4.0417D+00 6.4089D-01 6.8030D-01 eigenvalue condition #'s
+ 7.6064D-01 8.4964D-01 1.1222D-01 1.1499D-01 eigenvector condition #'s
+0
diff --git a/TESTING/dgg.in b/TESTING/dgg.in
new file mode 100644
index 0000000..fb83aac
--- /dev/null
+++ b/TESTING/dgg.in
@@ -0,0 +1,15 @@
+DGG: Data file for testing Nonsymmetric Eigenvalue Problem routines
+7 Number of values of N
+0 1 2 3 5 10 16 Values of N (dimension)
+4 Number of parameter values
+1 1 2 2 Values of NB (blocksize)
+40 40 2 2 Values of NBMIN (minimum blocksize)
+2 4 2 4 Values of NSHIFT (no. of shifts)
+40 40 2 2 Values of MAXB (multishift crossover pt)
+40 40 2 2 Values of NBCOL (minimum col. dimension)
+20.0 Threshold value
+T Put T to test the LAPACK routines
+T Put T to test the driver routines
+T Put T to test the error exits
+1 Code to interpret the seed
+DGG 26
diff --git a/TESTING/dsb.in b/TESTING/dsb.in
new file mode 100644
index 0000000..76fe2de
--- /dev/null
+++ b/TESTING/dsb.in
@@ -0,0 +1,9 @@
+DSB: Data file for testing Symmetric Eigenvalue Problem routines
+2 Number of values of N
+5 20 Values of N (dimension)
+5 Number of values of K
+0 1 2 5 16 Values of K (band width)
+20.0 Threshold value
+T Put T to test the error exits
+1 Code to interpret the seed
+DSB 15
diff --git a/TESTING/dsg.in b/TESTING/dsg.in
new file mode 100644
index 0000000..7819a83
--- /dev/null
+++ b/TESTING/dsg.in
@@ -0,0 +1,13 @@
+DSG: Data file for testing Generalized Symmetric Eigenvalue Problem routines
+7 Number of values of N
+0 1 2 3 5 10 16 Values of N (dimension)
+3 Number of values of NB
+1 3 20 Values of NB (blocksize)
+2 2 2 Values of NBMIN (minimum blocksize)
+1 1 1 Values of NX (crossover point)
+20.0 Threshold value
+T Put T to test the LAPACK routines
+T Put T to test the driver routines
+T Put T to test the error exits
+1 Code to interpret the seed
+DSG 21
diff --git a/TESTING/dstest.in b/TESTING/dstest.in
new file mode 100644
index 0000000..3d337f6
--- /dev/null
+++ b/TESTING/dstest.in
@@ -0,0 +1,10 @@
+Data file for testing DSGESV/DSPOSV LAPACK routines
+11 Number of values of M
+0 1 2 13 17 45 78 91 101 120 132 Values of M (row dimension)
+4 Number of values of NRHS
+1 2 15 16 Values of NRHS (number of right hand sides)
+30.0 Threshold value of test ratio
+T Put T to test the driver routine
+T Put T to test the error exits
+DGE 11 Number of matrix types to be tested, list types on next line if 0 < NTYPES < 11
+DPO 9 Number of matrix types to be tested, list types on next line if 0 < NTYPES < 11
diff --git a/TESTING/dtest.in b/TESTING/dtest.in
new file mode 100644
index 0000000..f9192f2
--- /dev/null
+++ b/TESTING/dtest.in
@@ -0,0 +1,37 @@
+Data file for testing DOUBLE PRECISION LAPACK linear eqn. routines
+7 Number of values of M
+0 1 2 3 5 10 50 Values of M (row dimension)
+7 Number of values of N
+0 1 2 3 5 10 50 Values of N (column dimension)
+3 Number of values of NRHS
+1 2 15 Values of NRHS (number of right hand sides)
+5 Number of values of NB
+1 3 3 3 20 Values of NB (the blocksize)
+1 0 5 9 1 Values of NX (crossover point)
+3 Number of values of RANK
+30 50 90 Values of rank (as a % of N)
+30.0 Threshold value of test ratio
+T Put T to test the LAPACK routines
+T Put T to test the driver routines
+T Put T to test the error exits
+DGE 11 List types on next line if 0 < NTYPES < 11
+DGB 8 List types on next line if 0 < NTYPES < 8
+DGT 12 List types on next line if 0 < NTYPES < 12
+DPO 9 List types on next line if 0 < NTYPES < 9
+DPS 9 List types on next line if 0 < NTYPES < 9
+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
+DSY 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
+DTB 17 List types on next line if 0 < NTYPES < 17
+DQR 8 List types on next line if 0 < NTYPES < 8
+DRQ 8 List types on next line if 0 < NTYPES < 8
+DLQ 8 List types on next line if 0 < NTYPES < 8
+DQL 8 List types on next line if 0 < NTYPES < 8
+DQP 6 List types on next line if 0 < NTYPES < 6
+DTZ 3 List types on next line if 0 < NTYPES < 3
+DLS 6 List types on next line if 0 < NTYPES < 6
+DEQ
diff --git a/TESTING/dtest_rfp.in b/TESTING/dtest_rfp.in
new file mode 100644
index 0000000..96aa52f
--- /dev/null
+++ b/TESTING/dtest_rfp.in
@@ -0,0 +1,9 @@
+Data file for testing DOUBLE PRECISION LAPACK linear equation routines RFP format
+9 Number of values of N (at most 9)
+0 1 2 3 5 6 10 11 50 Values of N
+3 Number of values of NRHS (at most 9)
+1 2 15 Values of NRHS (number of right hand sides)
+9 Number of matrix types (list types on next line if 0 < NTYPES < 9)
+1 2 3 4 5 6 7 8 9 Matrix Types
+30.0 Threshold value of test ratio
+T Put T to test the error exits
diff --git a/TESTING/glm.in b/TESTING/glm.in
new file mode 100644
index 0000000..4fddc61
--- /dev/null
+++ b/TESTING/glm.in
@@ -0,0 +1,9 @@
+GLM: Data file for testing Generalized Linear Regression Model routines
+6 Number of values of M, P, and N
+0 5 8 15 20 40 Values of M (row dimension)
+9 0 15 12 15 30 Values of P (row dimension)
+5 5 10 25 30 40 Values of N (col dimension), M <= N <= M+P
+20.0 Threshold value of test ratio
+T Put T to test the error exits
+1 Code to interpret the seed
+GLM 8 List types on next line if 0 < NTYPES < 8
diff --git a/TESTING/gqr.in b/TESTING/gqr.in
new file mode 100644
index 0000000..ccd861c
--- /dev/null
+++ b/TESTING/gqr.in
@@ -0,0 +1,9 @@
+GQR: Data file for testing Generalized QR and RQ routines
+3 Number of values of M, P and N
+0 3 10 Values of M
+0 5 20 Values of P
+0 3 30 Values of N
+20.0 Threshold value of test ratio
+T Put T to test the error exits
+1 Code to interpret the seed
+GQR 8 List types on next line if 0 < NTYPES < 8
diff --git a/TESTING/gsv.in b/TESTING/gsv.in
new file mode 100644
index 0000000..e97211d
--- /dev/null
+++ b/TESTING/gsv.in
@@ -0,0 +1,9 @@
+GSV: Data file for testing Generalized SVD routines
+8 Number of values of M, P, N
+0 5 9 10 20 12 12 40 Values of M (row dimension)
+4 0 12 14 10 10 20 15 Values of P (row dimension)
+3 10 15 12 8 20 8 20 Values of N (column dimension)
+20.0 Threshold value of test ratio
+T Put T to test the error exits
+1 Code to interpret the seed
+GSV 8 List types on next line if 0 < NTYPES < 8
diff --git a/TESTING/lse.in b/TESTING/lse.in
new file mode 100644
index 0000000..5959854
--- /dev/null
+++ b/TESTING/lse.in
@@ -0,0 +1,9 @@
+LSE: Data file for testing Constrained Linear Least Squares routines
+6 Number of values of M, P, and N
+6 0 5 8 10 30 Values of M
+0 5 5 5 8 20 Values of P
+5 5 6 8 12 40 Values of N, note P<= N <= P+M
+20.0 Threshold value of test ratio
+T Put T to test the error exits
+1 Code to interpret the seed
+LSE 8 List types on next line if 0 < NTYPES < 8
diff --git a/TESTING/nep.in b/TESTING/nep.in
new file mode 100644
index 0000000..c4a4149
--- /dev/null
+++ b/TESTING/nep.in
@@ -0,0 +1,16 @@
+NEP: Data file for testing Nonsymmetric Eigenvalue Problem routines
+7 Number of values of N
+0 1 2 3 5 10 16 Values of N (dimension)
+5 Number of values of NB, NBMIN, NX, INMIN, IN WIN, INIBL, ISHFTS, and IACC22
+ 1 3 3 3 20 Values of NB (blocksize)
+ 2 2 2 2 2 Values of NBMIN (minimum blocksize)
+ 1 0 5 9 1 Values of NX (crossover point)
+ 11 12 11 15 11 Values of INMIN (LAHQR vs TTQRE crossover point, >= 11)
+ 2 3 5 3 2 Values of INWIN (recommended deflation window size)
+ 0 5 7 3 200 Values of INIBL (nibble crossover point)
+ 1 2 4 2 1 Values of ISHFTS (number of simultaneous shifts)
+ 0 1 2 0 1 Values of IACC22 (select structured matrix multiply: 0, 1 or 2)
+20.0 Threshold value
+T Put T to test the error exits
+1 Code to interpret the seed
+NEP 21
diff --git a/TESTING/out b/TESTING/out
new file mode 100644
index 0000000..c48bcac
--- /dev/null
+++ b/TESTING/out
@@ -0,0 +1,4332 @@
+ .. test output of CGEBAK ..
+ value of largest test error = .189E+01
+ example number where info is not zero = 0
+ example number having largest error = 5
+ number of examples where info is not 0 = 0
+ total number of examples tested = 7
+
+
+ End of tests
+ Total time used = .00 seconds
+
+ .. test output of CGEBAL ..
+ value of largest test error = .000E+00
+ example number where info is not zero = 0
+ example number where ILO or IHI wrong = 0
+ example number having largest error = 0
+ number of examples where info is not 0 = 0
+ total number of examples tested = 13
+
+
+ End of tests
+ Total time used = .00 seconds
+
+ Tests of CGBBRD
+ (reduction of a general band matrix to real bidiagonal form)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 0 0 0 1 1 1 1 2 2
+ 2 2 3 3 3 3 10 10 16 16
+ N: 0 1 2 3 0 1 2 3 0 1
+ 2 3 0 1 2 3 10 16 10 16
+ K: 0 1 2 3 16
+ NS: 1 2
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+
+ CBB: NRHS = 1
+
+ All tests for CBB passed the threshold ( 3000 tests run)
+
+
+ CBB: NRHS = 2
+
+ All tests for CBB passed the threshold ( 3000 tests run)
+
+
+ End of tests
+ Total time used = .20 seconds
+
+ Tests of the Nonsymmetric eigenproblem condition estimation routines
+ CTRSYL, CTREXC, CTRSNA, CTRSEN
+
+ Relative machine precision (EPS) = .119209E-06
+ Safe minimum (SFMIN) = .117549E-37
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ CEC routines passed the tests of the error exits ( 33 tests done)
+
+ All tests for CEC routines passed the threshold ( 5966 tests run)
+
+
+ End of tests
+ Total time used = .10 seconds
+
+
+ Tests of the Nonsymmetric Eigenvalue Problem Driver
+ CGEES (Schur form)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10
+ N: 0 1 2 3 5 10
+ NB: 3
+ NBMIN: 3
+ NX: 1
+ INMIN: 11
+ INWIN: 4
+ INIBL: 8
+ ISHFTS: 2
+ IACC22: 0
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ CGEES passed the tests of the error exits ( 6 tests done)
+
+ All tests for CES passed the threshold ( 3276 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Nonsymmetric Eigenvalue Problem Driver
+ CGEEV (eigenvalues and eigevectors)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10
+ N: 0 1 2 3 5 10
+ NB: 3
+ NBMIN: 3
+ NX: 1
+ INMIN: 11
+ INWIN: 4
+ INIBL: 8
+ ISHFTS: 2
+ IACC22: 0
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ CGEEV passed the tests of the error exits ( 7 tests done)
+
+ All tests for CEV passed the threshold ( 924 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Nonsymmetric Eigenvalue Problem Expert Driver
+ CGEESX (Schur form and condition numbers)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10
+ N: 0 1 2 3 5 10
+ NB: 3
+ NBMIN: 3
+ NX: 1
+ INMIN: 11
+ INWIN: 4
+ INIBL: 8
+ ISHFTS: 2
+ IACC22: 0
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ CGEESX passed the tests of the error exits ( 7 tests done)
+
+ All tests for CSX passed the threshold ( 3406 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Nonsymmetric Eigenvalue Problem Expert Driver
+ CGEEVX (eigenvalues, eigenvectors and condition numbers)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10
+ N: 0 1 2 3 5 10
+ NB: 3
+ NBMIN: 3
+ NX: 1
+ INMIN: 11
+ INWIN: 4
+ INIBL: 8
+ ISHFTS: 2
+ IACC22: 0
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ CGEEVX passed the tests of the error exits ( 10 tests done)
+
+ All tests for CVX passed the threshold ( 5172 tests run)
+
+ -----------------------------------------------------------------------
+
+
+ End of tests
+ Total time used = 1.20 seconds
+
+ .. test output of CGGBAK ..
+ value of largest test error = .138E-07
+ example number where CGGBAL info is not 0 = 0
+ example number where CGGBAK(L) info is not 0 = 0
+ example number where CGGBAK(R) info is not 0 = 0
+ example number having largest error = 8
+ number of examples where info is not 0 = 0
+ total number of examples tested = 10
+
+
+ End of tests
+ Total time used = .00 seconds
+
+ .. test output of CGGBAL ..
+ ratio of largest test error = .640E-03
+ example number where info is not zero = 0
+ example number where ILO or IHI is wrong = 0
+ example number having largest error = 8
+ number of examples where info is not 0 = 0
+ total number of examples tested = 10
+
+
+ End of tests
+ Total time used = .00 seconds
+
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Driver CGGEV
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 2 6 8 10 12 20
+ N: 2 6 8 10 12 20
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ CGV routines passed the tests of the error exits ( 85 tests done)
+
+ All tests for CGV drivers passed the threshold ( 1092 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Driver CGGES
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 2 6 10 12 20
+ N: 2 6 10 12 20
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ CGS routines passed the tests of the error exits ( 85 tests done)
+
+ All tests for CGS drivers passed the threshold ( 1560 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Expert Driver CGGESX
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ N: 2
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ CGX routines passed the tests of the error exits ( 85 tests done)
+
+ All tests for CGX drivers passed the threshold ( 150 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Expert Driver CGGEVX
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ N: 6
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ CXV routines passed the tests of the error exits ( 85 tests done)
+
+ All tests for CXV drivers passed the threshold ( 5000 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Expert Driver CGGESX
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ N: 0
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ CGX routines passed the tests of the error exits ( 85 tests done)
+
+ All tests for CGX drivers passed the threshold ( 20 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Expert Driver CGGEVX
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ N: 0
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ CXV routines passed the tests of the error exits ( 85 tests done)
+
+ All tests for CXV drivers passed the threshold ( 8 tests run)
+
+ -----------------------------------------------------------------------
+
+
+ End of tests
+ Total time used = .98 seconds
+
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10 16
+ N: 0 1 2 3 5 10 16
+ NB: 1 1 2 2
+ NBMIN: 40 40 2 2
+ NS: 2 4 2 4
+ MAXB: 40 40 2 2
+ NBCOL: 40 40 2 2
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ CGG routines passed the tests of the error exits ( 27 tests done)
+
+
+ CGG: NB = 1, NBMIN = 40, NS = 2, MAXB = 40, NBCOL = 40
+
+ All tests for CGG passed the threshold ( 2184 tests run)
+
+ All tests for CGG drivers passed the threshold ( 1274 tests run)
+
+
+ CGG: NB = 1, NBMIN = 40, NS = 4, MAXB = 40, NBCOL = 40
+
+ All tests for CGG passed the threshold ( 2184 tests run)
+
+ All tests for CGG drivers passed the threshold ( 1274 tests run)
+
+
+ CGG: NB = 2, NBMIN = 2, NS = 2, MAXB = 2, NBCOL = 2
+
+ All tests for CGG passed the threshold ( 2184 tests run)
+
+ All tests for CGG drivers passed the threshold ( 1274 tests run)
+
+
+ CGG: NB = 2, NBMIN = 2, NS = 4, MAXB = 2, NBCOL = 2
+
+ All tests for CGG passed the threshold ( 2184 tests run)
+
+ All tests for CGG drivers passed the threshold ( 1274 tests run)
+
+
+ End of tests
+ Total time used = 1.12 seconds
+
+
+ Tests of the Generalized Linear Regression Model routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 5 8 15 20 40
+ P: 9 0 15 12 15 30
+ N: 5 5 10 25 30 40
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ GLM routines passed the tests of the error exits ( 8 tests done)
+
+ All tests for GLM routines passed the threshold ( 48 tests run)
+
+
+ End of tests
+ Total time used = .07 seconds
+
+
+ Tests of the Generalized QR and RQ routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 3 10
+ P: 0 5 20
+ N: 0 3 30
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ GQR routines passed the tests of the error exits ( 12 tests done)
+
+ All tests for GQR routines passed the threshold ( 1728 tests run)
+
+
+ End of tests
+ Total time used = .23 seconds
+
+
+ Tests of the Generalized Singular Value Decomposition routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 5 9 10 20 12 12 40
+ P: 4 0 12 14 10 10 20 15
+ N: 3 10 15 12 8 20 8 20
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ GSV routines passed the tests of the error exits ( 33 tests done)
+
+ All tests for GSV routines passed the threshold ( 384 tests run)
+
+
+ End of tests
+ Total time used = .15 seconds
+
+
+ Tests of the Linear Least Squares routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 6 0 5 8 10 30
+ P: 0 5 5 5 8 20
+ N: 5 5 6 8 12 40
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ LSE routines passed the tests of the error exits ( 8 tests done)
+
+ All tests for LSE routines passed the threshold ( 96 tests run)
+
+
+ End of tests
+ Total time used = .03 seconds
+
+ Tests of the Nonsymmetric Eigenvalue Problem routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10 16
+ N: 0 1 2 3 5 10 16
+ NB: 1 3 3 3 20
+ NBMIN: 2 2 2 2 2
+ NX: 1 0 5 9 1
+ INMIN: 11 12 11 15 11
+ INWIN: 2 3 5 3 2
+ INIBL: 0 5 7 3 200
+ ISHFTS: 1 2 4 2 1
+ IACC22: 0 1 2 0 1
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ CHS routines passed the tests of the error exits ( 66 tests done)
+
+
+ NEP: NB = 1, NBMIN = 2, NX = 1, INMIN= 11, INWIN = 2, INIBL = 0, ISHFTS = 1, IACC22 = 0
+
+ All tests for CHS passed the threshold ( 2058 tests run)
+
+
+ NEP: NB = 3, NBMIN = 2, NX = 0, INMIN= 12, INWIN = 3, INIBL = 5, ISHFTS = 2, IACC22 = 1
+
+ All tests for CHS passed the threshold ( 2058 tests run)
+
+
+ NEP: NB = 3, NBMIN = 2, NX = 5, INMIN= 11, INWIN = 5, INIBL = 7, ISHFTS = 4, IACC22 = 2
+
+ All tests for CHS passed the threshold ( 2058 tests run)
+
+
+ NEP: NB = 3, NBMIN = 2, NX = 9, INMIN= 15, INWIN = 3, INIBL = 3, ISHFTS = 2, IACC22 = 0
+
+ All tests for CHS passed the threshold ( 2058 tests run)
+
+
+ NEP: NB = 20, NBMIN = 2, NX = 1, INMIN= 11, INWIN = 2, INIBL = 200, ISHFTS = 1, IACC22 = 1
+
+ All tests for CHS passed the threshold ( 2058 tests run)
+
+
+ End of tests
+ Total time used = .88 seconds
+
+ Tests of CHBTRD
+ (reduction of a Hermitian band matrix to real tridiagonal form)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 5 20
+ N: 5 20
+ K: 0 1 2 5 16
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ CHB routines passed the tests of the error exits ( 38 tests done)
+
+ All tests for CHB passed the threshold ( 540 tests run)
+
+
+ End of tests
+ Total time used = .05 seconds
+
+ Tests of the Hermitian Eigenvalue Problem routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 20
+ N: 0 1 2 3 5 20
+ NB: 1 3 3 3 10
+ NBMIN: 2 2 2 2 2
+ NX: 1 0 5 9 1
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 50.00
+
+
+ CST routines passed the tests of the error exits (114 tests done)
+
+
+ SEP: NB = 1, NBMIN = 2, NX = 1
+
+ All tests for CST passed the threshold ( 4662 tests run)
+
+ CST -- Complex Hermitian eigenvalue problem
+ Matrix types (see xDRVST for details):
+
+ Special Matrices:
+ 1=Zero matrix. 5=Diagonal: clustered entries.
+ 2=Identity matrix. 6=Diagonal: large, evenly spaced.
+ 3=Diagonal: evenly spaced entries. 7=Diagonal: small, evenly spaced.
+ 4=Diagonal: geometr. spaced entries.
+ Dense Hermitian Matrices:
+ 8=Evenly spaced eigenvals. 12=Small, evenly spaced eigenvals.
+ 9=Geometrically spaced eigenvals. 13=Matrix with random O(1) entries.
+ 10=Clustered eigenvalues. 14=Matrix with large random entries.
+ 11=Large, evenly spaced eigenvals. 15=Matrix with small random entries.
+
+ Tests performed: See cdrvst.f
+ Matrix order= 20, type= 9, seed= 363,3293,2012,2937, result 47 is 636.79
+ CST drivers: 1 out of 11664 tests failed to pass the threshold
+
+
+ SEP: NB = 3, NBMIN = 2, NX = 0
+
+ CST -- Complex Hermitian eigenvalue problem
+ Matrix types (see CCHKST for details):
+
+ Special Matrices:
+ 1=Zero matrix. 5=Diagonal: clustered entries.
+ 2=Identity matrix. 6=Diagonal: large, evenly spaced.
+ 3=Diagonal: evenly spaced entries. 7=Diagonal: small, evenly spaced.
+ 4=Diagonal: geometr. spaced entries.
+ Dense Hermitian Matrices:
+ 8=Evenly spaced eigenvals. 12=Small, evenly spaced eigenvals.
+ 9=Geometrically spaced eigenvals. 13=Matrix with random O(1) entries.
+ 10=Clustered eigenvalues. 14=Matrix with large random entries.
+ 11=Large, evenly spaced eigenvals. 15=Matrix with small random entries.
+ 16=Positive definite, evenly spaced eigenvalues
+ 17=Positive definite, geometrically spaced eigenvlaues
+ 18=Positive definite, clustered eigenvalues
+ 19=Positive definite, small evenly spaced eigenvalues
+ 20=Positive definite, large evenly spaced eigenvalues
+ 21=Diagonally dominant tridiagonal, geometrically spaced eigenvalues
+
+Test performed: see CCHKST for details.
+
+ Matrix order= 20, type= 9, seed=1509, 822,1315,3593, result 36 is 59.89
+ CST: 1 out of 4662 tests failed to pass the threshold
+
+ All tests for CST drivers passed the threshold ( 11664 tests run)
+
+
+ SEP: NB = 3, NBMIN = 2, NX = 5
+
+ All tests for CST passed the threshold ( 4662 tests run)
+
+ All tests for CST drivers passed the threshold ( 11664 tests run)
+
+
+ SEP: NB = 3, NBMIN = 2, NX = 9
+
+ CST -- Complex Hermitian eigenvalue problem
+ Matrix types (see CCHKST for details):
+
+ Special Matrices:
+ 1=Zero matrix. 5=Diagonal: clustered entries.
+ 2=Identity matrix. 6=Diagonal: large, evenly spaced.
+ 3=Diagonal: evenly spaced entries. 7=Diagonal: small, evenly spaced.
+ 4=Diagonal: geometr. spaced entries.
+ Dense Hermitian Matrices:
+ 8=Evenly spaced eigenvals. 12=Small, evenly spaced eigenvals.
+ 9=Geometrically spaced eigenvals. 13=Matrix with random O(1) entries.
+ 10=Clustered eigenvalues. 14=Matrix with large random entries.
+ 11=Large, evenly spaced eigenvals. 15=Matrix with small random entries.
+ 16=Positive definite, evenly spaced eigenvalues
+ 17=Positive definite, geometrically spaced eigenvlaues
+ 18=Positive definite, clustered eigenvalues
+ 19=Positive definite, small evenly spaced eigenvalues
+ 20=Positive definite, large evenly spaced eigenvalues
+ 21=Diagonally dominant tridiagonal, geometrically spaced eigenvalues
+
+Test performed: see CCHKST for details.
+
+ Matrix order= 20, type= 9, seed=1052,3651,3662,3633, result 36 is 271.55
+ CST: 1 out of 4662 tests failed to pass the threshold
+
+ All tests for CST drivers passed the threshold ( 11664 tests run)
+
+
+ SEP: NB = 10, NBMIN = 2, NX = 1
+
+ All tests for CST passed the threshold ( 4662 tests run)
+
+ All tests for CST drivers passed the threshold ( 11664 tests run)
+
+
+ End of tests
+ Total time used = 3.83 seconds
+
+ Tests of the Hermitian Eigenvalue Problem routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10 16
+ N: 0 1 2 3 5 10 16
+ NB: 1 3 20
+ NBMIN: 2 2 2
+ NX: 1 1 1
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+
+ CSG: NB = 1, NBMIN = 2, NX = 1
+
+ All tests for CSG passed the threshold (10290 tests run)
+
+
+ CSG: NB = 3, NBMIN = 2, NX = 1
+
+ All tests for CSG passed the threshold (10290 tests run)
+
+
+ CSG: NB = 20, NBMIN = 2, NX = 1
+
+ All tests for CSG passed the threshold (10290 tests run)
+
+
+ End of tests
+ Total time used = 4.22 seconds
+
+ Tests of the Singular Value Decomposition routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 0 0 1 1 1 2 2 3 3
+ 3 10 10 16 16 30 30 40 40
+ N: 0 1 3 0 1 2 0 1 0 1
+ 3 10 16 10 16 30 40 30 40
+ NB: 1 3 3 3 20
+ NBMIN: 2 2 2 2 2
+ NX: 1 0 5 9 1
+ NS: 2 0 2 2 2
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 35.00
+
+
+ CBD routines passed the tests of the error exits ( 35 tests done)
+
+ CGESVD passed the tests of the error exits ( 8 tests done)
+ CGESDD passed the tests of the error exits ( 6 tests done)
+
+
+ SVD: NB = 1, NBMIN = 2, NX = 1, NRHS = 2
+
+ All tests for CBD routines passed the threshold ( 4085 tests run)
+
+ All tests for CBD drivers passed the threshold ( 4840 tests run)
+
+
+ SVD: NB = 3, NBMIN = 2, NX = 0, NRHS = 0
+
+ All tests for CBD routines passed the threshold ( 4085 tests run)
+
+ All tests for CBD drivers passed the threshold ( 4840 tests run)
+
+
+ SVD: NB = 3, NBMIN = 2, NX = 5, NRHS = 2
+
+ All tests for CBD routines passed the threshold ( 4085 tests run)
+
+ All tests for CBD drivers passed the threshold ( 4840 tests run)
+
+
+ SVD: NB = 3, NBMIN = 2, NX = 9, NRHS = 2
+
+ All tests for CBD routines passed the threshold ( 4085 tests run)
+
+ All tests for CBD drivers passed the threshold ( 4840 tests run)
+
+
+ SVD: NB = 20, NBMIN = 2, NX = 1, NRHS = 2
+
+ All tests for CBD routines passed the threshold ( 4085 tests run)
+
+ All tests for CBD drivers passed the threshold ( 4840 tests run)
+
+
+ End of tests
+ Total time used = 32.40 seconds
+
+ Tests of the COMPLEX LAPACK routines
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M : 0 1 2 3 5 10 50
+ N : 0 1 2 3 5 10 50
+ NRHS: 1 2 15
+ NB : 1 3 3 3 20
+ NX : 1 0 5 9 1
+ RANK: 30 50 90
+
+ Routines pass computational tests if test ratio is less than 30.00
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+
+ CGE routines passed the tests of the error exits
+
+ All tests for CGE routines passed the threshold ( 3653 tests run)
+
+ CGE drivers passed the tests of the error exits
+
+ All tests for CGE drivers passed the threshold ( 4866 tests run)
+
+ CGB routines passed the tests of the error exits
+
+ All tests for CGB routines passed the threshold ( 28938 tests run)
+
+ CGB drivers passed the tests of the error exits
+
+ All tests for CGB drivers passed the threshold ( 30969 tests run)
+
+ CGT routines passed the tests of the error exits
+
+ All tests for CGT routines passed the threshold ( 2694 tests run)
+
+ CGT drivers passed the tests of the error exits
+
+ All tests for CGT drivers passed the threshold ( 2033 tests run)
+
+ CPO routines passed the tests of the error exits
+
+ All tests for CPO routines passed the threshold ( 1628 tests run)
+
+ CPO drivers passed the tests of the error exits
+
+ All tests for CPO drivers passed the threshold ( 1910 tests run)
+
+ CPS routines passed the tests of the error exits
+
+ All tests for CPS routines passed the threshold ( 150 tests run)
+
+ CPP routines passed the tests of the error exits
+
+ All tests for CPP routines passed the threshold ( 1332 tests run)
+
+ CPP drivers passed the tests of the error exits
+
+ All tests for CPP drivers passed the threshold ( 1910 tests run)
+
+ CPB routines passed the tests of the error exits
+
+ All tests for CPB routines passed the threshold ( 3458 tests run)
+
+ CPB drivers passed the tests of the error exits
+
+ All tests for CPB drivers passed the threshold ( 4750 tests run)
+
+ CPT routines passed the tests of the error exits
+
+ All tests for CPT routines passed the threshold ( 1778 tests run)
+
+ CPT drivers passed the tests of the error exits
+
+ All tests for CPT drivers passed the threshold ( 788 tests run)
+
+ CHE routines passed the tests of the error exits
+
+ All tests for CHE routines passed the threshold ( 1624 tests run)
+
+ CHE drivers passed the tests of the error exits
+
+ All tests for CHE drivers passed the threshold ( 1072 tests run)
+
+ CHP routines passed the tests of the error exits
+
+ All tests for CHP routines passed the threshold ( 1404 tests run)
+
+ CHP drivers passed the tests of the error exits
+
+ All tests for CHP drivers passed the threshold ( 1072 tests run)
+
+ CSY routines passed the tests of the error exits
+
+ All tests for CSY routines passed the threshold ( 1864 tests run)
+
+ CSY drivers passed the tests of the error exits
+
+ All tests for CSY drivers passed the threshold ( 1240 tests run)
+
+ CSP routines passed the tests of the error exits
+
+ All tests for CSP routines passed the threshold ( 1620 tests run)
+
+ CSP drivers passed the tests of the error exits
+
+ All tests for CSP drivers passed the threshold ( 1240 tests run)
+
+ CTR routines passed the tests of the error exits
+
+ All tests for CTR routines passed the threshold ( 7672 tests run)
+
+ CTP routines passed the tests of the error exits
+
+ All tests for CTP routines passed the threshold ( 7392 tests run)
+
+ CTB routines passed the tests of the error exits
+
+ All tests for CTB routines passed the threshold ( 19888 tests run)
+
+ CQR routines passed the tests of the error exits
+
+ All tests for CQR routines passed the threshold ( 30744 tests run)
+
+ CRQ routines passed the tests of the error exits
+
+ All tests for CRQ routines passed the threshold ( 28784 tests run)
+
+ CLQ routines passed the tests of the error exits
+
+ All tests for CLQ routines passed the threshold ( 30744 tests run)
+
+ CQL routines passed the tests of the error exits
+
+ All tests for CQL routines passed the threshold ( 28784 tests run)
+
+ CQP routines passed the tests of the error exits
+
+ All tests for CQP routines passed the threshold ( 882 tests run)
+
+ All tests for CQ3 routines passed the threshold ( 4410 tests run)
+
+ CTZ routines passed the tests of the error exits
+
+ All tests for CTZ routines passed the threshold ( 504 tests run)
+
+ CLS routines passed the tests of the error exits
+
+ All tests for CLS drivers passed the threshold ( 65268 tests run)
+
+ All tests for CEQ routines passed the threshold
+
+ End of tests
+ Total time used = 51.08 seconds
+
+
+ Tests of the COMPLEX LAPACK RFP routines
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ N : 0 1 2 3 5 6 10 11 50
+ NRHS: 1 2 15
+ TYPE: 1 2 3 4 5 6 7 8 9
+
+ Routines pass computational tests if test ratio is less than 30.00
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ COMPLEX RFP routines passed the tests of the error exits
+
+ All tests for CPF drivers passed the threshold ( 2352 tests run)
+ All tests for CLANHF auxiliary routine passed the threshold ( 432 tests run)
+ All tests for the RFP convertion routines passed ( 72 tests run)
+ All tests for CTFSM auxiliary routine passed the threshold ( 7776 tests run)
+ All tests for CHFRK auxiliary routine passed the threshold ( 2592 tests run)
+
+ End of tests
+ Total time used = 6.45 seconds
+
+ .. test output of DGEBAK ..
+ value of largest test error = .160E+01
+ example number where info is not zero = 0
+ example number having largest error = 7
+ number of examples where info is not 0 = 0
+ total number of examples tested = 7
+
+
+ End of tests
+ Total time used = .00 seconds
+
+ .. test output of DGEBAL ..
+ value of largest test error = .000E+00
+ example number where info is not zero = 0
+ example number where ILO or IHI wrong = 0
+ example number having largest error = 0
+ number of examples where info is not 0 = 0
+ total number of examples tested = 13
+
+
+ End of tests
+ Total time used = .00 seconds
+
+ Tests of DGBBRD
+ (reduction of a general band matrix to real bidiagonal form)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 0 0 0 1 1 1 1 2 2
+ 2 2 3 3 3 3 10 10 16 16
+ N: 0 1 2 3 0 1 2 3 0 1
+ 2 3 0 1 2 3 10 16 10 16
+ K: 0 1 2 3 16
+ NS: 1 2
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+
+ DBB: NRHS = 1
+
+ All tests for DBB passed the threshold ( 3000 tests run)
+
+
+ DBB: NRHS = 2
+
+ All tests for DBB passed the threshold ( 3000 tests run)
+
+
+ End of tests
+ Total time used = .08 seconds
+
+ Tests of the Nonsymmetric eigenproblem condition estimation routines
+ DLALN2, DLASY2, DLANV2, DLAEXC, DTRSYL, DTREXC, DTRSNA, DTRSEN, DLAQTR
+
+ Relative machine precision (EPS) = .222045E-15
+ Safe minimum (SFMIN) = .222507-307
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ DEC routines passed the tests of the error exits ( 35 tests done)
+
+ All tests for DEC routines passed the threshold (501251 tests run)
+
+
+ End of tests
+ Total time used = 1.35 seconds
+
+
+ Tests of the Nonsymmetric Eigenvalue Problem Driver
+ DGEEV (eigenvalues and eigevectors)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10
+ N: 0 1 2 3 5 10
+ NB: 3
+ NBMIN: 3
+ NX: 1
+ INMIN: 11
+ INWIN: 4
+ INIBL: 8
+ ISHFTS: 2
+ IACC22: 0
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ DGEEV passed the tests of the error exits ( 7 tests done)
+
+ All tests for DEV passed the threshold ( 924 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Nonsymmetric Eigenvalue Problem Driver
+ DGEES (Schur form)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10
+ N: 0 1 2 3 5 10
+ NB: 3
+ NBMIN: 3
+ NX: 1
+ INMIN: 11
+ INWIN: 4
+ INIBL: 8
+ ISHFTS: 2
+ IACC22: 0
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ DGEES passed the tests of the error exits ( 6 tests done)
+
+ All tests for DES passed the threshold ( 3276 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Nonsymmetric Eigenvalue Problem Expert Driver
+ DGEEVX (eigenvalues, eigenvectors and condition numbers)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10
+ N: 0 1 2 3 5 10
+ NB: 3
+ NBMIN: 3
+ NX: 1
+ INMIN: 11
+ INWIN: 4
+ INIBL: 8
+ ISHFTS: 2
+ IACC22: 0
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ DGEEVX passed the tests of the error exits ( 11 tests done)
+
+ All tests for DVX passed the threshold ( 5274 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Nonsymmetric Eigenvalue Problem Expert Driver
+ DGEESX (Schur form and condition numbers)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10
+ N: 0 1 2 3 5 10
+ NB: 3
+ NBMIN: 3
+ NX: 1
+ INMIN: 11
+ INWIN: 4
+ INIBL: 8
+ ISHFTS: 2
+ IACC22: 0
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ DGEESX passed the tests of the error exits ( 7 tests done)
+
+ All tests for DSX passed the threshold ( 3508 tests run)
+
+ -----------------------------------------------------------------------
+
+
+ End of tests
+ Total time used = .67 seconds
+
+ .. test output of DGGBAK ..
+ value of largest test error = .205E-02
+ example number where DGGBAL info is not 0 = 0
+ example number where DGGBAK(L) info is not 0 = 0
+ example number where DGGBAK(R) info is not 0 = 0
+ example number having largest error = 8
+ number of examples where info is not 0 = 0
+ total number of examples tested = 8
+
+
+ End of tests
+ Total time used = .00 seconds
+
+ .. test output of DGGBAL ..
+ value of largest test error = .246E-01
+ example number where info is not zero = 0
+ example number where ILO or IHI wrong = 0
+ example number having largest error = 6
+ number of examples where info is not 0 = 0
+ total number of examples tested = 8
+
+
+ End of tests
+ Total time used = .00 seconds
+
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Driver DGGES
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 2 6 10 12 20
+ N: 2 6 10 12 20
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ DGS routines passed the tests of the error exits ( 87 tests done)
+
+ All tests for DGS drivers passed the threshold ( 1560 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Driver DGGEV
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 2 6 8 10 15 20
+ N: 2 6 8 10 15 20
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ DGV routines passed the tests of the error exits ( 87 tests done)
+
+ All tests for DGV drivers passed the threshold ( 1092 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Expert Driver DGGESX
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ N: 2
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ DGX routines passed the tests of the error exits ( 87 tests done)
+
+ All tests for SGX drivers passed the threshold ( 150 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Expert Driver DGGESX
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ N: 0
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ DGX routines passed the tests of the error exits ( 87 tests done)
+
+ All tests for SGX drivers passed the threshold ( 20 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Expert Driver DGGEVX
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ N: 5
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ DXV routines passed the tests of the error exits ( 87 tests done)
+
+ DXV -- Real Expert Eigenvalue/vector problem driver
+ Matrix types:
+
+ TYPE 1: Da is diagonal, Db is identity,
+ A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1)
+ YH and X are left and right eigenvectors.
+
+ TYPE 2: Da is quasi-diagonal, Db is identity,
+ A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1)
+ YH and X are left and right eigenvectors.
+
+
+ Tests performed:
+ a is alpha, b is beta, l is a left eigenvector,
+ r is a right eigenvector and ' means transpose.
+ 1 = max | ( b A - a B )' l | / const.
+ 2 = max | ( b A - a B ) r | / const.
+ 3 = max ( Sest/Stru, Stru/Sest ) over all eigenvalues
+ 4 = max( DIFest/DIFtru, DIFtru/DIFest ) over the 1st and 5th eigenvectors
+
+ Type= 2, IWA= 1, IWB= 1, IWX= 5, IWY= 1, result 4 is 3766.18
+ Type= 2, IWA= 1, IWB= 1, IWX= 5, IWY= 2, result 4 is 3930.80
+ Type= 2, IWA= 1, IWB= 1, IWX= 5, IWY= 3, result 4 is 3540.26
+ Type= 2, IWA= 1, IWB= 1, IWX= 5, IWY= 4, result 4 is 3527.71
+ Type= 2, IWA= 1, IWB= 1, IWX= 5, IWY= 5, result 4 is 1648.31
+ Type= 2, IWA= 1, IWB= 2, IWX= 5, IWY= 5, result 4 is 2269.35
+ Type= 2, IWA= 1, IWB= 3, IWX= 5, IWY= 5, result 4 is 1325.15
+ Type= 2, IWA= 1, IWB= 4, IWX= 5, IWY= 5, result 4 is 476.04
+ Type= 2, IWA= 1, IWB= 5, IWX= 1, IWY= 1, result 4 is 4096.29
+ Type= 2, IWA= 1, IWB= 5, IWX= 1, IWY= 2, result 4 is 3817.53
+ Type= 2, IWA= 1, IWB= 5, IWX= 1, IWY= 3, result 4 is 2120.76
+ Type= 2, IWA= 1, IWB= 5, IWX= 1, IWY= 4, result 4 is 288.27
+ Type= 2, IWA= 1, IWB= 5, IWX= 2, IWY= 1, result 4 is 3817.53
+ Type= 2, IWA= 1, IWB= 5, IWX= 2, IWY= 2, result 4 is 3707.73
+ Type= 2, IWA= 1, IWB= 5, IWX= 2, IWY= 3, result 4 is 2114.67
+ Type= 2, IWA= 1, IWB= 5, IWX= 2, IWY= 4, result 4 is 288.25
+ Type= 2, IWA= 1, IWB= 5, IWX= 3, IWY= 1, result 4 is 2120.76
+ Type= 2, IWA= 1, IWB= 5, IWX= 3, IWY= 2, result 4 is 2114.67
+ Type= 2, IWA= 1, IWB= 5, IWX= 3, IWY= 3, result 4 is 1697.03
+ Type= 2, IWA= 1, IWB= 5, IWX= 3, IWY= 4, result 4 is 286.85
+ Type= 2, IWA= 1, IWB= 5, IWX= 4, IWY= 1, result 4 is 288.27
+ Type= 2, IWA= 1, IWB= 5, IWX= 4, IWY= 2, result 4 is 288.25
+ Type= 2, IWA= 1, IWB= 5, IWX= 4, IWY= 3, result 4 is 286.85
+ Type= 2, IWA= 1, IWB= 5, IWX= 4, IWY= 4, result 4 is 204.34
+ Type= 2, IWA= 2, IWB= 1, IWX= 5, IWY= 5, result 4 is 4540.57
+ Type= 2, IWA= 2, IWB= 2, IWX= 5, IWY= 5, result 4 is 3644.86
+ Type= 2, IWA= 2, IWB= 3, IWX= 5, IWY= 5, result 4 is 1633.45
+ Type= 2, IWA= 2, IWB= 4, IWX= 5, IWY= 5, result 4 is 481.28
+ Type= 2, IWA= 2, IWB= 5, IWX= 1, IWY= 1, result 4 is 4096.34
+ Type= 2, IWA= 2, IWB= 5, IWX= 1, IWY= 2, result 4 is 3817.57
+ Type= 2, IWA= 2, IWB= 5, IWX= 1, IWY= 3, result 4 is 2120.79
+ Type= 2, IWA= 2, IWB= 5, IWX= 1, IWY= 4, result 4 is 288.27
+ Type= 2, IWA= 2, IWB= 5, IWX= 2, IWY= 1, result 4 is 3817.57
+ Type= 2, IWA= 2, IWB= 5, IWX= 2, IWY= 2, result 4 is 3707.78
+ Type= 2, IWA= 2, IWB= 5, IWX= 2, IWY= 3, result 4 is 2114.70
+ Type= 2, IWA= 2, IWB= 5, IWX= 2, IWY= 4, result 4 is 288.26
+ Type= 2, IWA= 2, IWB= 5, IWX= 3, IWY= 1, result 4 is 2120.79
+ Type= 2, IWA= 2, IWB= 5, IWX= 3, IWY= 2, result 4 is 2114.70
+ Type= 2, IWA= 2, IWB= 5, IWX= 3, IWY= 3, result 4 is 1697.05
+ Type= 2, IWA= 2, IWB= 5, IWX= 3, IWY= 4, result 4 is 286.85
+ Type= 2, IWA= 2, IWB= 5, IWX= 4, IWY= 1, result 4 is 288.27
+ Type= 2, IWA= 2, IWB= 5, IWX= 4, IWY= 2, result 4 is 288.26
+ Type= 2, IWA= 2, IWB= 5, IWX= 4, IWY= 3, result 4 is 286.85
+ Type= 2, IWA= 2, IWB= 5, IWX= 4, IWY= 4, result 4 is 204.34
+ Type= 2, IWA= 3, IWB= 1, IWX= 5, IWY= 5, result 4 is 4780.11
+ Type= 2, IWA= 3, IWB= 2, IWX= 4, IWY= 2, result 4 is 4.504E+15
+ Type= 2, IWA= 3, IWB= 2, IWX= 5, IWY= 5, result 4 is 4729.81
+ Type= 2, IWA= 3, IWB= 3, IWX= 5, IWY= 5, result 4 is 3176.46
+ Type= 2, IWA= 3, IWB= 4, IWX= 5, IWY= 5, result 4 is 524.84
+ Type= 2, IWA= 3, IWB= 5, IWX= 1, IWY= 1, result 4 is 4096.79
+ Type= 2, IWA= 3, IWB= 5, IWX= 1, IWY= 2, result 4 is 3817.99
+ Type= 2, IWA= 3, IWB= 5, IWX= 1, IWY= 3, result 4 is 2121.02
+ Type= 2, IWA= 3, IWB= 5, IWX= 1, IWY= 4, result 4 is 288.30
+ Type= 2, IWA= 3, IWB= 5, IWX= 2, IWY= 1, result 4 is 3817.99
+ Type= 2, IWA= 3, IWB= 5, IWX= 2, IWY= 2, result 4 is 3708.19
+ Type= 2, IWA= 3, IWB= 5, IWX= 2, IWY= 3, result 4 is 2114.93
+ Type= 2, IWA= 3, IWB= 5, IWX= 2, IWY= 4, result 4 is 288.29
+ Type= 2, IWA= 3, IWB= 5, IWX= 3, IWY= 1, result 4 is 2121.02
+ Type= 2, IWA= 3, IWB= 5, IWX= 3, IWY= 2, result 4 is 2114.93
+ Type= 2, IWA= 3, IWB= 5, IWX= 3, IWY= 3, result 4 is 1697.24
+ Type= 2, IWA= 3, IWB= 5, IWX= 3, IWY= 4, result 4 is 286.89
+ Type= 2, IWA= 3, IWB= 5, IWX= 4, IWY= 1, result 4 is 288.30
+ Type= 2, IWA= 3, IWB= 5, IWX= 4, IWY= 2, result 4 is 288.29
+ Type= 2, IWA= 3, IWB= 5, IWX= 4, IWY= 3, result 4 is 286.89
+ Type= 2, IWA= 3, IWB= 5, IWX= 4, IWY= 4, result 4 is 204.37
+ Type= 2, IWA= 4, IWB= 1, IWX= 5, IWY= 5, result 4 is 638.67
+ Type= 2, IWA= 4, IWB= 2, IWX= 5, IWY= 5, result 4 is 643.37
+ Type= 2, IWA= 4, IWB= 3, IWX= 5, IWY= 5, result 4 is 678.17
+ Type= 2, IWA= 4, IWB= 4, IWX= 5, IWY= 5, result 4 is 547.42
+ Type= 2, IWA= 4, IWB= 5, IWX= 1, IWY= 1, result 4 is 4101.29
+ Type= 2, IWA= 4, IWB= 5, IWX= 1, IWY= 2, result 4 is 3822.19
+ Type= 2, IWA= 4, IWB= 5, IWX= 1, IWY= 3, result 4 is 2123.35
+ Type= 2, IWA= 4, IWB= 5, IWX= 1, IWY= 4, result 4 is 288.62
+ Type= 2, IWA= 4, IWB= 5, IWX= 2, IWY= 1, result 4 is 3822.19
+ Type= 2, IWA= 4, IWB= 5, IWX= 2, IWY= 2, result 4 is 3712.26
+ Type= 2, IWA= 4, IWB= 5, IWX= 2, IWY= 3, result 4 is 2117.25
+ Type= 2, IWA= 4, IWB= 5, IWX= 2, IWY= 4, result 4 is 288.61
+ Type= 2, IWA= 4, IWB= 5, IWX= 3, IWY= 1, result 4 is 2123.35
+ Type= 2, IWA= 4, IWB= 5, IWX= 3, IWY= 2, result 4 is 2117.25
+ Type= 2, IWA= 4, IWB= 5, IWX= 3, IWY= 3, result 4 is 1699.11
+ Type= 2, IWA= 4, IWB= 5, IWX= 3, IWY= 4, result 4 is 287.20
+ Type= 2, IWA= 4, IWB= 5, IWX= 4, IWY= 1, result 4 is 288.62
+ Type= 2, IWA= 4, IWB= 5, IWX= 4, IWY= 2, result 4 is 288.61
+ Type= 2, IWA= 4, IWB= 5, IWX= 4, IWY= 3, result 4 is 287.20
+ Type= 2, IWA= 4, IWB= 5, IWX= 4, IWY= 4, result 4 is 204.59
+ Type= 2, IWA= 5, IWB= 1, IWX= 1, IWY= 1, result 4 is 3.355E+07
+ Type= 2, IWA= 5, IWB= 1, IWX= 1, IWY= 2, result 4 is 3.127E+07
+ Type= 2, IWA= 5, IWB= 1, IWX= 1, IWY= 3, result 4 is 1.737E+07
+ Type= 2, IWA= 5, IWB= 1, IWX= 1, IWY= 4, result 4 is 2.361E+06
+ Type= 2, IWA= 5, IWB= 1, IWX= 1, IWY= 5, result 4 is 2896.66
+ Type= 2, IWA= 5, IWB= 1, IWX= 2, IWY= 1, result 4 is 3.127E+07
+ Type= 2, IWA= 5, IWB= 1, IWX= 2, IWY= 2, result 4 is 3.037E+07
+ Type= 2, IWA= 5, IWB= 1, IWX= 2, IWY= 3, result 4 is 1.732E+07
+ Type= 2, IWA= 5, IWB= 1, IWX= 2, IWY= 4, result 4 is 2.361E+06
+ Type= 2, IWA= 5, IWB= 1, IWX= 2, IWY= 5, result 4 is 2896.66
+ Type= 2, IWA= 5, IWB= 1, IWX= 3, IWY= 1, result 4 is 1.737E+07
+ Type= 2, IWA= 5, IWB= 1, IWX= 3, IWY= 2, result 4 is 1.732E+07
+ Type= 2, IWA= 5, IWB= 1, IWX= 3, IWY= 3, result 4 is 1.390E+07
+ Type= 2, IWA= 5, IWB= 1, IWX= 3, IWY= 4, result 4 is 2.350E+06
+ Type= 2, IWA= 5, IWB= 1, IWX= 3, IWY= 5, result 4 is 2896.66
+ Type= 2, IWA= 5, IWB= 1, IWX= 4, IWY= 1, result 4 is 2.361E+06
+ Type= 2, IWA= 5, IWB= 1, IWX= 4, IWY= 2, result 4 is 2.361E+06
+ Type= 2, IWA= 5, IWB= 1, IWX= 4, IWY= 3, result 4 is 2.350E+06
+ Type= 2, IWA= 5, IWB= 1, IWX= 4, IWY= 4, result 4 is 1.674E+06
+ Type= 2, IWA= 5, IWB= 1, IWX= 4, IWY= 5, result 4 is 2896.66
+ Type= 2, IWA= 5, IWB= 1, IWX= 5, IWY= 1, result 4 is 2896.66
+ Type= 2, IWA= 5, IWB= 1, IWX= 5, IWY= 2, result 4 is 2896.66
+ Type= 2, IWA= 5, IWB= 1, IWX= 5, IWY= 3, result 4 is 2896.66
+ Type= 2, IWA= 5, IWB= 1, IWX= 5, IWY= 4, result 4 is 2896.66
+ Type= 2, IWA= 5, IWB= 1, IWX= 5, IWY= 5, result 4 is 2048.38
+ Type= 2, IWA= 5, IWB= 2, IWX= 1, IWY= 1, result 4 is 3.051E+07
+ Type= 2, IWA= 5, IWB= 2, IWX= 1, IWY= 2, result 4 is 2.843E+07
+ Type= 2, IWA= 5, IWB= 2, IWX= 1, IWY= 3, result 4 is 1.579E+07
+ Type= 2, IWA= 5, IWB= 2, IWX= 1, IWY= 4, result 4 is 2.147E+06
+ Type= 2, IWA= 5, IWB= 2, IWX= 1, IWY= 5, result 4 is 2633.68
+ Type= 2, IWA= 5, IWB= 2, IWX= 2, IWY= 1, result 4 is 2.843E+07
+ Type= 2, IWA= 5, IWB= 2, IWX= 2, IWY= 2, result 4 is 2.761E+07
+ Type= 2, IWA= 5, IWB= 2, IWX= 2, IWY= 3, result 4 is 1.575E+07
+ Type= 2, IWA= 5, IWB= 2, IWX= 2, IWY= 4, result 4 is 2.147E+06
+ Type= 2, IWA= 5, IWB= 2, IWX= 2, IWY= 5, result 4 is 2633.68
+ Type= 2, IWA= 5, IWB= 2, IWX= 3, IWY= 1, result 4 is 1.579E+07
+ Type= 2, IWA= 5, IWB= 2, IWX= 3, IWY= 2, result 4 is 1.575E+07
+ Type= 2, IWA= 5, IWB= 2, IWX= 3, IWY= 3, result 4 is 1.264E+07
+ Type= 2, IWA= 5, IWB= 2, IWX= 3, IWY= 4, result 4 is 2.136E+06
+ Type= 2, IWA= 5, IWB= 2, IWX= 3, IWY= 5, result 4 is 2633.68
+ Type= 2, IWA= 5, IWB= 2, IWX= 4, IWY= 1, result 4 is 2.147E+06
+ Type= 2, IWA= 5, IWB= 2, IWX= 4, IWY= 2, result 4 is 2.147E+06
+ Type= 2, IWA= 5, IWB= 2, IWX= 4, IWY= 3, result 4 is 2.136E+06
+ Type= 2, IWA= 5, IWB= 2, IWX= 4, IWY= 4, result 4 is 1.522E+06
+ Type= 2, IWA= 5, IWB= 2, IWX= 4, IWY= 5, result 4 is 2633.68
+ Type= 2, IWA= 5, IWB= 2, IWX= 5, IWY= 1, result 4 is 2633.68
+ Type= 2, IWA= 5, IWB= 2, IWX= 5, IWY= 2, result 4 is 2633.68
+ Type= 2, IWA= 5, IWB= 2, IWX= 5, IWY= 3, result 4 is 2633.68
+ Type= 2, IWA= 5, IWB= 2, IWX= 5, IWY= 4, result 4 is 2633.68
+ Type= 2, IWA= 5, IWB= 2, IWX= 5, IWY= 5, result 4 is 1862.41
+ Type= 2, IWA= 5, IWB= 3, IWX= 1, IWY= 1, result 4 is 1.678E+07
+ Type= 2, IWA= 5, IWB= 3, IWX= 1, IWY= 2, result 4 is 1.564E+07
+ Type= 2, IWA= 5, IWB= 3, IWX= 1, IWY= 3, result 4 is 8.688E+06
+ Type= 2, IWA= 5, IWB= 3, IWX= 1, IWY= 4, result 4 is 1.181E+06
+ Type= 2, IWA= 5, IWB= 3, IWX= 1, IWY= 5, result 4 is 1448.69
+ Type= 2, IWA= 5, IWB= 3, IWX= 2, IWY= 1, result 4 is 1.564E+07
+ Type= 2, IWA= 5, IWB= 3, IWX= 2, IWY= 2, result 4 is 1.519E+07
+ Type= 2, IWA= 5, IWB= 3, IWX= 2, IWY= 3, result 4 is 8.663E+06
+ Type= 2, IWA= 5, IWB= 3, IWX= 2, IWY= 4, result 4 is 1.181E+06
+ Type= 2, IWA= 5, IWB= 3, IWX= 2, IWY= 5, result 4 is 1448.69
+ Type= 2, IWA= 5, IWB= 3, IWX= 3, IWY= 1, result 4 is 8.688E+06
+ Type= 2, IWA= 5, IWB= 3, IWX= 3, IWY= 2, result 4 is 8.663E+06
+ Type= 2, IWA= 5, IWB= 3, IWX= 3, IWY= 3, result 4 is 6.952E+06
+ Type= 2, IWA= 5, IWB= 3, IWX= 3, IWY= 4, result 4 is 1.175E+06
+ Type= 2, IWA= 5, IWB= 3, IWX= 3, IWY= 5, result 4 is 1448.69
+ Type= 2, IWA= 5, IWB= 3, IWX= 4, IWY= 1, result 4 is 1.181E+06
+ Type= 2, IWA= 5, IWB= 3, IWX= 4, IWY= 2, result 4 is 1.181E+06
+ Type= 2, IWA= 5, IWB= 3, IWX= 4, IWY= 3, result 4 is 1.175E+06
+ Type= 2, IWA= 5, IWB= 3, IWX= 4, IWY= 4, result 4 is 8.371E+05
+ Type= 2, IWA= 5, IWB= 3, IWX= 4, IWY= 5, result 4 is 1448.68
+ Type= 2, IWA= 5, IWB= 3, IWX= 5, IWY= 1, result 4 is 1448.69
+ Type= 2, IWA= 5, IWB= 3, IWX= 5, IWY= 2, result 4 is 1448.69
+ Type= 2, IWA= 5, IWB= 3, IWX= 5, IWY= 3, result 4 is 1448.69
+ Type= 2, IWA= 5, IWB= 3, IWX= 5, IWY= 4, result 4 is 1448.68
+ Type= 2, IWA= 5, IWB= 3, IWX= 5, IWY= 5, result 4 is 1024.44
+ Type= 2, IWA= 5, IWB= 4, IWX= 1, IWY= 1, result 4 is 3.055E+06
+ Type= 2, IWA= 5, IWB= 4, IWX= 1, IWY= 2, result 4 is 2.846E+06
+ Type= 2, IWA= 5, IWB= 4, IWX= 1, IWY= 3, result 4 is 1.581E+06
+ Type= 2, IWA= 5, IWB= 4, IWX= 1, IWY= 4, result 4 is 2.149E+05
+ Type= 2, IWA= 5, IWB= 4, IWX= 1, IWY= 5, result 4 is 263.69
+ Type= 2, IWA= 5, IWB= 4, IWX= 2, IWY= 1, result 4 is 2.846E+06
+ Type= 2, IWA= 5, IWB= 4, IWX= 2, IWY= 2, result 4 is 2.765E+06
+ Type= 2, IWA= 5, IWB= 4, IWX= 2, IWY= 3, result 4 is 1.577E+06
+ Type= 2, IWA= 5, IWB= 4, IWX= 2, IWY= 4, result 4 is 2.149E+05
+ Type= 2, IWA= 5, IWB= 4, IWX= 2, IWY= 5, result 4 is 263.69
+ Type= 2, IWA= 5, IWB= 4, IWX= 3, IWY= 1, result 4 is 1.581E+06
+ Type= 2, IWA= 5, IWB= 4, IWX= 3, IWY= 2, result 4 is 1.577E+06
+ Type= 2, IWA= 5, IWB= 4, IWX= 3, IWY= 3, result 4 is 1.265E+06
+ Type= 2, IWA= 5, IWB= 4, IWX= 3, IWY= 4, result 4 is 2.139E+05
+ Type= 2, IWA= 5, IWB= 4, IWX= 3, IWY= 5, result 4 is 263.69
+ Type= 2, IWA= 5, IWB= 4, IWX= 4, IWY= 1, result 4 is 2.149E+05
+ Type= 2, IWA= 5, IWB= 4, IWX= 4, IWY= 2, result 4 is 2.149E+05
+ Type= 2, IWA= 5, IWB= 4, IWX= 4, IWY= 3, result 4 is 2.139E+05
+ Type= 2, IWA= 5, IWB= 4, IWX= 4, IWY= 4, result 4 is 1.524E+05
+ Type= 2, IWA= 5, IWB= 4, IWX= 4, IWY= 5, result 4 is 263.69
+ Type= 2, IWA= 5, IWB= 4, IWX= 5, IWY= 1, result 4 is 263.69
+ Type= 2, IWA= 5, IWB= 4, IWX= 5, IWY= 2, result 4 is 263.69
+ Type= 2, IWA= 5, IWB= 4, IWX= 5, IWY= 3, result 4 is 263.69
+ Type= 2, IWA= 5, IWB= 4, IWX= 5, IWY= 4, result 4 is 263.69
+ Type= 2, IWA= 5, IWB= 4, IWX= 5, IWY= 5, result 4 is 186.47
+ Type= 2, IWA= 5, IWB= 5, IWX= 1, IWY= 1, result 4 is 1.158E+04
+ Type= 2, IWA= 5, IWB= 5, IWX= 1, IWY= 2, result 4 is 1.080E+04
+ Type= 2, IWA= 5, IWB= 5, IWX= 1, IWY= 3, result 4 is 5997.33
+ Type= 2, IWA= 5, IWB= 5, IWX= 1, IWY= 4, result 4 is 815.19
+ Type= 2, IWA= 5, IWB= 5, IWX= 2, IWY= 1, result 4 is 1.080E+04
+ Type= 2, IWA= 5, IWB= 5, IWX= 2, IWY= 2, result 4 is 1.049E+04
+ Type= 2, IWA= 5, IWB= 5, IWX= 2, IWY= 3, result 4 is 5980.12
+ Type= 2, IWA= 5, IWB= 5, IWX= 2, IWY= 4, result 4 is 815.15
+ Type= 2, IWA= 5, IWB= 5, IWX= 3, IWY= 1, result 4 is 5997.33
+ Type= 2, IWA= 5, IWB= 5, IWX= 3, IWY= 2, result 4 is 5980.12
+ Type= 2, IWA= 5, IWB= 5, IWX= 3, IWY= 3, result 4 is 4799.16
+ Type= 2, IWA= 5, IWB= 5, IWX= 3, IWY= 4, result 4 is 811.19
+ Type= 2, IWA= 5, IWB= 5, IWX= 4, IWY= 1, result 4 is 815.19
+ Type= 2, IWA= 5, IWB= 5, IWX= 4, IWY= 2, result 4 is 815.15
+ Type= 2, IWA= 5, IWB= 5, IWX= 4, IWY= 3, result 4 is 811.19
+ Type= 2, IWA= 5, IWB= 5, IWX= 4, IWY= 4, result 4 is 577.87
+ DXV drivers: 201 out of 5000 tests failed to pass the threshold
+
+ -----------------------------------------------------------------------
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Expert Driver DGGEVX
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ N: 0
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ DXV routines passed the tests of the error exits ( 87 tests done)
+
+ All tests for DXV drivers passed the threshold ( 8 tests run)
+
+ -----------------------------------------------------------------------
+
+
+ End of tests
+ Total time used = .67 seconds
+
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10 16
+ N: 0 1 2 3 5 10 16
+ NB: 1 1 2 2
+ NBMIN: 40 40 2 2
+ NS: 2 4 2 4
+ MAXB: 40 40 2 2
+ NBCOL: 40 40 2 2
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ DGG routines passed the tests of the error exits ( 27 tests done)
+
+
+ DGG: NB = 1, NBMIN = 40, NS = 2, MAXB = 40, NBCOL = 40
+
+ All tests for DGG passed the threshold ( 2184 tests run)
+
+ All tests for DGG drivers passed the threshold ( 1274 tests run)
+
+
+ DGG: NB = 1, NBMIN = 40, NS = 4, MAXB = 40, NBCOL = 40
+
+ All tests for DGG passed the threshold ( 2184 tests run)
+
+ All tests for DGG drivers passed the threshold ( 1274 tests run)
+
+
+ DGG: NB = 2, NBMIN = 2, NS = 2, MAXB = 2, NBCOL = 2
+
+ All tests for DGG passed the threshold ( 2184 tests run)
+
+ All tests for DGG drivers passed the threshold ( 1274 tests run)
+
+
+ DGG: NB = 2, NBMIN = 2, NS = 4, MAXB = 2, NBCOL = 2
+
+ All tests for DGG passed the threshold ( 2184 tests run)
+
+ All tests for DGG drivers passed the threshold ( 1274 tests run)
+
+
+ End of tests
+ Total time used = .52 seconds
+
+
+ Tests of the Generalized Linear Regression Model routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 5 8 15 20 40
+ P: 9 0 15 12 15 30
+ N: 5 5 10 25 30 40
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ GLM routines passed the tests of the error exits ( 8 tests done)
+
+ All tests for GLM routines passed the threshold ( 48 tests run)
+
+
+ End of tests
+ Total time used = .03 seconds
+
+
+ Tests of the Generalized QR and RQ routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 3 10
+ P: 0 5 20
+ N: 0 3 30
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ GQR routines passed the tests of the error exits ( 12 tests done)
+
+ All tests for GQR routines passed the threshold ( 1728 tests run)
+
+
+ End of tests
+ Total time used = .08 seconds
+
+
+ Tests of the Generalized Singular Value Decomposition routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 5 9 10 20 12 12 40
+ P: 4 0 12 14 10 10 20 15
+ N: 3 10 15 12 8 20 8 20
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ GSV routines passed the tests of the error exits ( 33 tests done)
+
+ All tests for GSV routines passed the threshold ( 384 tests run)
+
+
+ End of tests
+ Total time used = .05 seconds
+
+
+ Tests of the Linear Least Squares routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 6 0 5 8 10 30
+ P: 0 5 5 5 8 20
+ N: 5 5 6 8 12 40
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ LSE routines passed the tests of the error exits ( 8 tests done)
+
+ All tests for LSE routines passed the threshold ( 96 tests run)
+
+
+ End of tests
+ Total time used = .02 seconds
+
+ Tests of the Nonsymmetric Eigenvalue Problem routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10 16
+ N: 0 1 2 3 5 10 16
+ NB: 1 3 3 3 20
+ NBMIN: 2 2 2 2 2
+ NX: 1 0 5 9 1
+ INMIN: 11 12 11 15 11
+ INWIN: 2 3 5 3 2
+ INIBL: 0 5 7 3 200
+ ISHFTS: 1 2 4 2 1
+ IACC22: 0 1 2 0 1
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ DHS routines passed the tests of the error exits ( 66 tests done)
+
+
+ NEP: NB = 1, NBMIN = 2, NX = 1, INMIN= 11, INWIN = 2, INIBL = 0, ISHFTS = 1, IACC22 = 0
+
+ All tests for DHS passed the threshold ( 1764 tests run)
+
+
+ NEP: NB = 3, NBMIN = 2, NX = 0, INMIN= 12, INWIN = 3, INIBL = 5, ISHFTS = 2, IACC22 = 1
+
+ All tests for DHS passed the threshold ( 1764 tests run)
+
+
+ NEP: NB = 3, NBMIN = 2, NX = 5, INMIN= 11, INWIN = 5, INIBL = 7, ISHFTS = 4, IACC22 = 2
+
+ All tests for DHS passed the threshold ( 1764 tests run)
+
+
+ NEP: NB = 3, NBMIN = 2, NX = 9, INMIN= 15, INWIN = 3, INIBL = 3, ISHFTS = 2, IACC22 = 0
+
+ All tests for DHS passed the threshold ( 1764 tests run)
+
+
+ NEP: NB = 20, NBMIN = 2, NX = 1, INMIN= 11, INWIN = 2, INIBL = 200, ISHFTS = 1, IACC22 = 1
+
+ All tests for DHS passed the threshold ( 1764 tests run)
+
+
+ End of tests
+ Total time used = .40 seconds
+
+ Tests of DSBTRD
+ (reduction of a symmetric band matrix to tridiagonal form)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 5 20
+ N: 5 20
+ K: 0 1 2 5 16
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ DSB routines passed the tests of the error exits ( 36 tests done)
+
+ All tests for DSB passed the threshold ( 540 tests run)
+
+
+ End of tests
+ Total time used = .02 seconds
+
+ Tests of the Symmetric Eigenvalue Problem routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 20
+ N: 0 1 2 3 5 20
+ NB: 1 3 3 3 10
+ NBMIN: 2 2 2 2 2
+ NX: 1 0 5 9 1
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 50.00
+
+
+ DST routines passed the tests of the error exits (147 tests done)
+
+
+ SEP: NB = 1, NBMIN = 2, NX = 1
+
+ All tests for DST passed the threshold ( 4662 tests run)
+
+ All tests for DST drivers passed the threshold ( 14256 tests run)
+
+
+ SEP: NB = 3, NBMIN = 2, NX = 0
+
+ DST -- Real Symmetric eigenvalue problem
+ Matrix types (see DCHKST for details):
+
+ Special Matrices:
+ 1=Zero matrix. 5=Diagonal: clustered entries.
+ 2=Identity matrix. 6=Diagonal: large, evenly spaced.
+ 3=Diagonal: evenly spaced entries. 7=Diagonal: small, evenly spaced.
+ 4=Diagonal: geometr. spaced entries.
+ Dense Symmetric Matrices:
+ 8=Evenly spaced eigenvals. 12=Small, evenly spaced eigenvals.
+ 9=Geometrically spaced eigenvals. 13=Matrix with random O(1) entries.
+ 10=Clustered eigenvalues. 14=Matrix with large random entries.
+ 11=Large, evenly spaced eigenvals. 15=Matrix with small random entries.
+ 16=Positive definite, evenly spaced eigenvalues
+ 17=Positive definite, geometrically spaced eigenvlaues
+ 18=Positive definite, clustered eigenvalues
+ 19=Positive definite, small evenly spaced eigenvalues
+ 20=Positive definite, large evenly spaced eigenvalues
+ 21=Diagonally dominant tridiagonal, geometrically spaced eigenvalues
+
+Test performed: see DCHKST for details.
+
+ N= 20, seed= 529,1367, 510,2109, type 9, test(36)= 52.9
+ DST: 1 out of 4662 tests failed to pass the threshold
+
+ All tests for DST drivers passed the threshold ( 14256 tests run)
+
+
+ SEP: NB = 3, NBMIN = 2, NX = 5
+
+ DST -- Real Symmetric eigenvalue problem
+ Matrix types (see DCHKST for details):
+
+ Special Matrices:
+ 1=Zero matrix. 5=Diagonal: clustered entries.
+ 2=Identity matrix. 6=Diagonal: large, evenly spaced.
+ 3=Diagonal: evenly spaced entries. 7=Diagonal: small, evenly spaced.
+ 4=Diagonal: geometr. spaced entries.
+ Dense Symmetric Matrices:
+ 8=Evenly spaced eigenvals. 12=Small, evenly spaced eigenvals.
+ 9=Geometrically spaced eigenvals. 13=Matrix with random O(1) entries.
+ 10=Clustered eigenvalues. 14=Matrix with large random entries.
+ 11=Large, evenly spaced eigenvals. 15=Matrix with small random entries.
+ 16=Positive definite, evenly spaced eigenvalues
+ 17=Positive definite, geometrically spaced eigenvlaues
+ 18=Positive definite, clustered eigenvalues
+ 19=Positive definite, small evenly spaced eigenvalues
+ 20=Positive definite, large evenly spaced eigenvalues
+ 21=Diagonally dominant tridiagonal, geometrically spaced eigenvalues
+
+Test performed: see DCHKST for details.
+
+ N= 20, seed=2989,1119,3793,1781, type 9, test(36)= 65.5
+ DST: 1 out of 4662 tests failed to pass the threshold
+
+ All tests for DST drivers passed the threshold ( 14256 tests run)
+
+
+ SEP: NB = 3, NBMIN = 2, NX = 9
+
+ All tests for DST passed the threshold ( 4662 tests run)
+
+ All tests for DST drivers passed the threshold ( 14256 tests run)
+
+
+ SEP: NB = 10, NBMIN = 2, NX = 1
+
+ All tests for DST passed the threshold ( 4662 tests run)
+
+ DST -- Real Symmetric eigenvalue problem
+ Matrix types (see xDRVST for details):
+
+ Special Matrices:
+ 1=Zero matrix. 5=Diagonal: clustered entries.
+ 2=Identity matrix. 6=Diagonal: large, evenly spaced.
+ 3=Diagonal: evenly spaced entries. 7=Diagonal: small, evenly spaced.
+ 4=Diagonal: geometr. spaced entries.
+ Dense Symmetric Matrices:
+ 8=Evenly spaced eigenvals. 12=Small, evenly spaced eigenvals.
+ 9=Geometrically spaced eigenvals. 13=Matrix with random O(1) entries.
+ 10=Clustered eigenvalues. 14=Matrix with large random entries.
+ 11=Large, evenly spaced eigenvals. 15=Matrix with small random entries.
+
+ Tests performed: See sdrvst.f
+ Matrix order= 20, type= 9, seed= 756,3061,3397,1433, result 125 is 476.13
+ DST drivers: 1 out of 14256 tests failed to pass the threshold
+
+
+ End of tests
+ Total time used = 2.72 seconds
+
+ Tests of the Symmetric Eigenvalue Problem routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10 16
+ N: 0 1 2 3 5 10 16
+ NB: 1 3 20
+ NBMIN: 2 2 2
+ NX: 1 1 1
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+
+ DSG: NB = 1, NBMIN = 2, NX = 1
+
+ All tests for DSG passed the threshold (10290 tests run)
+
+
+ DSG: NB = 3, NBMIN = 2, NX = 1
+
+ All tests for DSG passed the threshold (10290 tests run)
+
+
+ DSG: NB = 20, NBMIN = 2, NX = 1
+
+ All tests for DSG passed the threshold (10290 tests run)
+
+
+ End of tests
+ Total time used = 3.07 seconds
+
+ Tests of the DOUBLE PRECISION LAPACK DSGESV/DSPOSV routines
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M : 0 1 2 13 17 45 78 91 101 120
+ 132
+ NRHS: 1 2 15 16
+
+ Routines pass computational tests if test ratio is less than 30.00
+
+ Relative machine (single precision) underflow is taken to be .117549E-37
+ Relative machine (single precision) overflow is taken to be .340282E+39
+ Relative machine (single precision) precision is taken to be .596046E-07
+
+ Relative machine (double precision) underflow is taken to be .222507-307
+ Relative machine (double precision) overflow is taken to be .179769+309
+ Relative machine (double precision) precision is taken to be .111022E-15
+
+
+ DSGESV drivers passed the tests of the error exits
+
+ All tests for DSGESV routines passed the threshold ( 324 tests run)
+
+ DSPOSV drivers passed the tests of the error exits
+
+ All tests for DSPOSV routines passed the threshold ( 488 tests run)
+
+ End of tests
+ Total time used = 4.07 seconds
+
+ Tests of the Singular Value Decomposition routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 0 0 1 1 1 2 2 3 3
+ 3 10 10 16 16 30 30 40 40
+ N: 0 1 3 0 1 2 0 1 0 1
+ 3 10 16 10 16 30 40 30 40
+ NB: 1 3 3 3 20
+ NBMIN: 2 2 2 2 2
+ NX: 1 0 5 9 1
+ NS: 2 0 2 2 2
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 35.00
+
+
+ DBD routines passed the tests of the error exits ( 43 tests done)
+
+ DGESVD passed the tests of the error exits ( 8 tests done)
+ DGESDD passed the tests of the error exits ( 6 tests done)
+
+
+ SVD: NB = 1, NBMIN = 2, NX = 1, NRHS = 2
+
+ All tests for DBD routines passed the threshold ( 5510 tests run)
+
+ All tests for DBD drivers passed the threshold ( 8360 tests run)
+
+
+ SVD: NB = 3, NBMIN = 2, NX = 0, NRHS = 0
+
+ All tests for DBD routines passed the threshold ( 5510 tests run)
+
+ All tests for DBD drivers passed the threshold ( 8360 tests run)
+
+
+ SVD: NB = 3, NBMIN = 2, NX = 5, NRHS = 2
+
+ All tests for DBD routines passed the threshold ( 5510 tests run)
+
+ All tests for DBD drivers passed the threshold ( 8360 tests run)
+
+
+ SVD: NB = 3, NBMIN = 2, NX = 9, NRHS = 2
+
+ All tests for DBD routines passed the threshold ( 5510 tests run)
+
+ All tests for DBD drivers passed the threshold ( 8360 tests run)
+
+
+ SVD: NB = 20, NBMIN = 2, NX = 1, NRHS = 2
+
+ All tests for DBD routines passed the threshold ( 5510 tests run)
+
+ All tests for DBD drivers passed the threshold ( 8360 tests run)
+
+
+ End of tests
+ Total time used = 21.60 seconds
+
+ Tests of the DOUBLE PRECISION LAPACK routines
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M : 0 1 2 3 5 10 50
+ N : 0 1 2 3 5 10 50
+ NRHS: 1 2 15
+ NB : 1 3 3 3 20
+ NX : 1 0 5 9 1
+ RANK: 30 50 90
+
+ Routines pass computational tests if test ratio is less than 30.00
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+
+ DGE routines passed the tests of the error exits
+
+ All tests for DGE routines passed the threshold ( 3653 tests run)
+
+ DGE drivers passed the tests of the error exits
+
+ All tests for DGE drivers passed the threshold ( 4866 tests run)
+
+ DGB routines passed the tests of the error exits
+
+ All tests for DGB routines passed the threshold ( 28938 tests run)
+
+ DGB drivers passed the tests of the error exits
+
+ All tests for DGB drivers passed the threshold ( 30969 tests run)
+
+ DGT routines passed the tests of the error exits
+
+ All tests for DGT routines passed the threshold ( 2694 tests run)
+
+ DGT drivers passed the tests of the error exits
+
+ All tests for DGT drivers passed the threshold ( 2033 tests run)
+
+ DPO routines passed the tests of the error exits
+
+ All tests for DPO routines passed the threshold ( 1628 tests run)
+
+ DPO drivers passed the tests of the error exits
+
+ All tests for DPO drivers passed the threshold ( 1910 tests run)
+
+ DPS routines passed the tests of the error exits
+
+ All tests for DPS routines passed the threshold ( 150 tests run)
+
+ DPP routines passed the tests of the error exits
+
+ All tests for DPP routines passed the threshold ( 1332 tests run)
+
+ DPP drivers passed the tests of the error exits
+
+ All tests for DPP drivers passed the threshold ( 1910 tests run)
+
+ DPB routines passed the tests of the error exits
+
+ All tests for DPB routines passed the threshold ( 3458 tests run)
+
+ DPB drivers passed the tests of the error exits
+
+ All tests for DPB drivers passed the threshold ( 4750 tests run)
+
+ DPT routines passed the tests of the error exits
+
+ All tests for DPT routines passed the threshold ( 953 tests run)
+
+ DPT drivers passed the tests of the error exits
+
+ All tests for DPT drivers passed the threshold ( 788 tests run)
+
+ DSY routines passed the tests of the error exits
+
+ All tests for DSY routines passed the threshold ( 1624 tests run)
+
+ DSY drivers passed the tests of the error exits
+
+ All tests for DSY drivers passed the threshold ( 1072 tests run)
+
+ DSP routines passed the tests of the error exits
+
+ All tests for DSP routines passed the threshold ( 1404 tests run)
+
+ DSP drivers passed the tests of the error exits
+
+ All tests for DSP drivers passed the threshold ( 1072 tests run)
+
+ DTR routines passed the tests of the error exits
+
+ All tests for DTR routines passed the threshold ( 7672 tests run)
+
+ DTP routines passed the tests of the error exits
+
+ All tests for DTP routines passed the threshold ( 7392 tests run)
+
+ DTB routines passed the tests of the error exits
+
+ All tests for DTB routines passed the threshold ( 19888 tests run)
+
+ DQR routines passed the tests of the error exits
+
+ All tests for DQR routines passed the threshold ( 30744 tests run)
+
+ DRQ routines passed the tests of the error exits
+
+ All tests for DRQ routines passed the threshold ( 28784 tests run)
+
+ DLQ routines passed the tests of the error exits
+
+ All tests for DLQ routines passed the threshold ( 30744 tests run)
+
+ DQL routines passed the tests of the error exits
+
+ All tests for DQL routines passed the threshold ( 28784 tests run)
+
+ DQP routines passed the tests of the error exits
+
+ All tests for DQP routines passed the threshold ( 882 tests run)
+
+ All tests for DQ3 routines passed the threshold ( 4410 tests run)
+
+ DTZ routines passed the tests of the error exits
+
+ All tests for DTZ routines passed the threshold ( 504 tests run)
+
+ DLS routines passed the tests of the error exits
+
+ All tests for DLS drivers passed the threshold ( 65268 tests run)
+
+ All tests for DEQ routines passed the threshold
+
+ End of tests
+ Total time used = 16.17 seconds
+
+
+ Tests of the DOUBLE PRECISION LAPACK RFP routines
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ N : 0 1 2 3 5 6 10 11 50
+ NRHS: 1 2 15
+ TYPE: 1 2 3 4 5 6 7 8 9
+
+ Routines pass computational tests if test ratio is less than 30.00
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ DOUBLE PRECISION RFP routines passed the tests of the error exits
+
+ All tests for DPF drivers passed the threshold ( 2352 tests run)
+ All tests for DLANSF auxiliary routine passed the threshold ( 432 tests run)
+ All tests for the RFP convertion routines passed ( 72 tests run)
+ All tests for DTFSM auxiliary routine passed the threshold ( 7776 tests run)
+ All tests for DSFRK auxiliary routine passed the threshold ( 2592 tests run)
+
+ End of tests
+ Total time used = 1.63 seconds
+
+ .. test output of SGEBAK ..
+ value of largest test error = .197E+01
+ example number where info is not zero = 0
+ example number having largest error = 7
+ number of examples where info is not 0 = 0
+ total number of examples tested = 7
+
+
+ End of tests
+ Total time used = .00 seconds
+
+ .. test output of SGEBAL ..
+ value of largest test error = .000E+00
+ example number where info is not zero = 0
+ example number where ILO or IHI wrong = 0
+ example number having largest error = 0
+ number of examples where info is not 0 = 0
+ total number of examples tested = 13
+
+
+ End of tests
+ Total time used = .00 seconds
+
+ Tests of SGBBRD
+ (reduction of a general band matrix to real bidiagonal form)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 0 0 0 1 1 1 1 2 2
+ 2 2 3 3 3 3 10 10 16 16
+ N: 0 1 2 3 0 1 2 3 0 1
+ 2 3 0 1 2 3 10 16 10 16
+ K: 0 1 2 3 16
+ NS: 1 2
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+
+ SBB: NRHS = 1
+
+ All tests for SBB passed the threshold ( 3000 tests run)
+
+
+ SBB: NRHS = 2
+
+ All tests for SBB passed the threshold ( 3000 tests run)
+
+
+ End of tests
+ Total time used = .08 seconds
+
+ Tests of the Nonsymmetric eigenproblem condition estimation routines
+ SLALN2, SLASY2, SLANV2, SLAEXC, STRSYL, STREXC, STRSNA, STRSEN, SLAQTR
+
+ Relative machine precision (EPS) = .119209E-06
+ Safe minimum (SFMIN) = .117549E-37
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ SEC routines passed the tests of the error exits ( 35 tests done)
+
+ All tests for SEC routines passed the threshold (501251 tests run)
+
+
+ End of tests
+ Total time used = 1.43 seconds
+
+
+ Tests of the Nonsymmetric Eigenvalue Problem Driver
+ SGEEV (eigenvalues and eigevectors)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10
+ N: 0 1 2 3 5 10
+ NB: 3
+ NBMIN: 3
+ NX: 1
+ INMIN: 11
+ INWIN: 4
+ INIBL: 8
+ ISHFTS: 2
+ IACC22: 0
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ SEV routines passed the tests of the error exits ( 7 tests done)
+
+ All tests for SEV passed the threshold ( 924 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Nonsymmetric Eigenvalue Problem Driver
+ SGEES (Schur form)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10
+ N: 0 1 2 3 5 10
+ NB: 3
+ NBMIN: 3
+ NX: 1
+ INMIN: 11
+ INWIN: 4
+ INIBL: 8
+ ISHFTS: 2
+ IACC22: 0
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ SES routines passed the tests of the error exits ( 6 tests done)
+
+ All tests for SES passed the threshold ( 3276 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Nonsymmetric Eigenvalue Problem Expert Driver
+ SGEEVX (eigenvalues, eigenvectors and condition numbers)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10
+ N: 0 1 2 3 5 10
+ NB: 3
+ NBMIN: 3
+ NX: 1
+ INMIN: 11
+ INWIN: 4
+ INIBL: 8
+ ISHFTS: 2
+ IACC22: 0
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ SVX routines passed the tests of the error exits ( 11 tests done)
+
+ All tests for SVX passed the threshold ( 5274 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Nonsymmetric Eigenvalue Problem Expert Driver
+ SGEESX (Schur form and condition numbers)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10
+ N: 0 1 2 3 5 10
+ NB: 3
+ NBMIN: 3
+ NX: 1
+ INMIN: 11
+ INWIN: 4
+ INIBL: 8
+ ISHFTS: 2
+ IACC22: 0
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ SSX routines passed the tests of the error exits ( 7 tests done)
+
+ All tests for SSX passed the threshold ( 3508 tests run)
+
+ -----------------------------------------------------------------------
+
+
+ End of tests
+ Total time used = .67 seconds
+
+ .. test output of SGGBAK ..
+ value of largest test error = .524E+00
+ example number where SGGBAL info is not 0 = 0
+ example number where SGGBAK(L) info is not 0 = 0
+ example number where SGGBAK(R) info is not 0 = 0
+ example number having largest error = 5
+ number of examples where info is not 0 = 0
+ total number of examples tested = 8
+
+
+ End of tests
+ Total time used = .00 seconds
+
+ .. test output of SGGBAL ..
+ value of largest test error = .200E-05
+ example number where info is not zero = 0
+ example number where ILO or IHI wrong = 0
+ example number having largest error = 8
+ number of examples where info is not 0 = 0
+ total number of examples tested = 8
+
+
+ End of tests
+ Total time used = .00 seconds
+
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Driver SGGES
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 2 6 10 12 20
+ N: 2 6 10 12 20
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ SGS routines passed the tests of the error exits ( 87 tests done)
+
+ All tests for SGS drivers passed the threshold ( 1560 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Driver SGGEV
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 2 6 8 10 15 20
+ N: 2 6 8 10 15 20
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ SGV routines passed the tests of the error exits ( 87 tests done)
+
+ All tests for SGV drivers passed the threshold ( 1092 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Expert Driver SGGESX
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ N: 2
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ SGX routines passed the tests of the error exits ( 87 tests done)
+
+ All tests for SGX drivers passed the threshold ( 150 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Expert Driver SGGESX
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ N: 0
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ SGX routines passed the tests of the error exits ( 87 tests done)
+
+ All tests for SGX drivers passed the threshold ( 20 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Expert Driver SGGEVX
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ N: 5
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ SXV routines passed the tests of the error exits ( 87 tests done)
+
+ SXV -- Real Expert Eigenvalue/vector problem driver
+ Matrix types:
+
+ TYPE 1: Da is diagonal, Db is identity,
+ A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1)
+ YH and X are left and right eigenvectors.
+
+ TYPE 2: Da is quasi-diagonal, Db is identity,
+ A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1)
+ YH and X are left and right eigenvectors.
+
+
+ Tests performed:
+ a is alpha, b is beta, l is a left eigenvector,
+ r is a right eigenvector and ' means transpose.
+ 1 = max | ( b A - a B )' l | / const.
+ 2 = max | ( b A - a B ) r | / const.
+ 3 = max ( Sest/Stru, Stru/Sest ) over all eigenvalues
+ 4 = max( DIFest/DIFtru, DIFtru/DIFest ) over the 1st and 5th eigenvectors
+
+ Type= 2, IWA= 2, IWB= 1, IWX= 4, IWY= 2, result 4 is 8.389E+06
+ Type= 2, IWA= 5, IWB= 1, IWX= 1, IWY= 1, result 4 is 1448.18
+ Type= 2, IWA= 5, IWB= 1, IWX= 1, IWY= 2, result 4 is 1373.16
+ Type= 2, IWA= 5, IWB= 1, IWX= 1, IWY= 3, result 4 is 763.73
+ Type= 2, IWA= 5, IWB= 1, IWX= 1, IWY= 4, result 4 is 103.81
+ Type= 2, IWA= 5, IWB= 1, IWX= 2, IWY= 1, result 4 is 1373.18
+ Type= 2, IWA= 5, IWB= 1, IWX= 2, IWY= 2, result 4 is 1336.23
+ Type= 2, IWA= 5, IWB= 1, IWX= 2, IWY= 3, result 4 is 762.27
+ Type= 2, IWA= 5, IWB= 1, IWX= 2, IWY= 4, result 4 is 103.82
+ Type= 2, IWA= 5, IWB= 1, IWX= 3, IWY= 1, result 4 is 763.75
+ Type= 2, IWA= 5, IWB= 1, IWX= 3, IWY= 2, result 4 is 762.29
+ Type= 2, IWA= 5, IWB= 1, IWX= 3, IWY= 3, result 4 is 615.15
+ Type= 2, IWA= 5, IWB= 1, IWX= 3, IWY= 4, result 4 is 103.48
+ Type= 2, IWA= 5, IWB= 1, IWX= 4, IWY= 1, result 4 is 103.81
+ Type= 2, IWA= 5, IWB= 1, IWX= 4, IWY= 2, result 4 is 103.82
+ Type= 2, IWA= 5, IWB= 1, IWX= 4, IWY= 3, result 4 is 103.48
+ Type= 2, IWA= 5, IWB= 2, IWX= 1, IWY= 1, result 4 is 1342.99
+ Type= 2, IWA= 5, IWB= 2, IWX= 1, IWY= 2, result 4 is 1273.42
+ Type= 2, IWA= 5, IWB= 2, IWX= 1, IWY= 3, result 4 is 708.25
+ Type= 2, IWA= 5, IWB= 2, IWX= 2, IWY= 1, result 4 is 1273.43
+ Type= 2, IWA= 5, IWB= 2, IWX= 2, IWY= 2, result 4 is 1239.17
+ Type= 2, IWA= 5, IWB= 2, IWX= 2, IWY= 3, result 4 is 706.90
+ Type= 2, IWA= 5, IWB= 2, IWX= 3, IWY= 1, result 4 is 708.27
+ Type= 2, IWA= 5, IWB= 2, IWX= 3, IWY= 2, result 4 is 706.92
+ Type= 2, IWA= 5, IWB= 2, IWX= 3, IWY= 3, result 4 is 570.47
+ Type= 2, IWA= 5, IWB= 3, IWX= 1, IWY= 1, result 4 is 750.89
+ Type= 2, IWA= 5, IWB= 3, IWX= 1, IWY= 2, result 4 is 711.99
+ Type= 2, IWA= 5, IWB= 3, IWX= 1, IWY= 3, result 4 is 396.00
+ Type= 2, IWA= 5, IWB= 3, IWX= 2, IWY= 1, result 4 is 712.00
+ Type= 2, IWA= 5, IWB= 3, IWX= 2, IWY= 2, result 4 is 692.84
+ Type= 2, IWA= 5, IWB= 3, IWX= 2, IWY= 3, result 4 is 395.24
+ Type= 2, IWA= 5, IWB= 3, IWX= 3, IWY= 1, result 4 is 396.01
+ Type= 2, IWA= 5, IWB= 3, IWX= 3, IWY= 2, result 4 is 395.25
+ Type= 2, IWA= 5, IWB= 3, IWX= 3, IWY= 3, result 4 is 318.96
+ Type= 2, IWA= 5, IWB= 4, IWX= 1, IWY= 1, result 4 is 161.25
+ Type= 2, IWA= 5, IWB= 4, IWX= 1, IWY= 2, result 4 is 152.94
+ Type= 2, IWA= 5, IWB= 4, IWX= 2, IWY= 1, result 4 is 152.94
+ Type= 2, IWA= 5, IWB= 4, IWX= 2, IWY= 2, result 4 is 148.82
+ SXV drivers: 38 out of 5000 tests failed to pass the threshold
+
+ -----------------------------------------------------------------------
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Expert Driver SGGEVX
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ N: 0
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ SXV routines passed the tests of the error exits ( 87 tests done)
+
+ All tests for SXV drivers passed the threshold ( 8 tests run)
+
+ -----------------------------------------------------------------------
+
+
+ End of tests
+ Total time used = .62 seconds
+
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10 16
+ N: 0 1 2 3 5 10 16
+ NB: 1 1 2 2
+ NBMIN: 40 40 2 2
+ NS: 2 4 2 4
+ MAXB: 40 40 2 2
+ NBCOL: 40 40 2 2
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ SGG routines passed the tests of the error exits ( 27 tests done)
+
+
+ SGG: NB = 1, NBMIN = 40, NS = 2, MAXB = 40, NBCOL = 40
+
+ All tests for SGG passed the threshold ( 2184 tests run)
+
+ All tests for SGG drivers passed the threshold ( 1274 tests run)
+
+
+ SGG: NB = 1, NBMIN = 40, NS = 4, MAXB = 40, NBCOL = 40
+
+ All tests for SGG passed the threshold ( 2184 tests run)
+
+ All tests for SGG drivers passed the threshold ( 1274 tests run)
+
+
+ SGG: NB = 2, NBMIN = 2, NS = 2, MAXB = 2, NBCOL = 2
+
+ All tests for SGG passed the threshold ( 2184 tests run)
+
+ All tests for SGG drivers passed the threshold ( 1274 tests run)
+
+
+ SGG: NB = 2, NBMIN = 2, NS = 4, MAXB = 2, NBCOL = 2
+
+ All tests for SGG passed the threshold ( 2184 tests run)
+
+ All tests for SGG drivers passed the threshold ( 1274 tests run)
+
+
+ End of tests
+ Total time used = .47 seconds
+
+
+ Tests of the Generalized Linear Regression Model routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 5 8 15 20 40
+ P: 9 0 15 12 15 30
+ N: 5 5 10 25 30 40
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ GLM routines passed the tests of the error exits ( 8 tests done)
+
+ All tests for GLM routines passed the threshold ( 48 tests run)
+
+
+ End of tests
+ Total time used = .03 seconds
+
+
+ Tests of the Generalized QR and RQ routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 3 10
+ P: 0 5 20
+ N: 0 3 30
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ GQR routines passed the tests of the error exits ( 12 tests done)
+
+ All tests for GQR routines passed the threshold ( 1728 tests run)
+
+
+ End of tests
+ Total time used = .08 seconds
+
+
+ Tests of the Generalized Singular Value Decomposition routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 5 9 10 20 12 12 40
+ P: 4 0 12 14 10 10 20 15
+ N: 3 10 15 12 8 20 8 20
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ GSV routines passed the tests of the error exits ( 33 tests done)
+
+ All tests for GSV routines passed the threshold ( 384 tests run)
+
+
+ End of tests
+ Total time used = .05 seconds
+
+
+ Tests of the Linear Least Squares routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 6 0 5 8 10 30
+ P: 0 5 5 5 8 20
+ N: 5 5 6 8 12 40
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ LSE routines passed the tests of the error exits ( 8 tests done)
+
+ All tests for LSE routines passed the threshold ( 96 tests run)
+
+
+ End of tests
+ Total time used = .02 seconds
+
+ Tests of the Nonsymmetric Eigenvalue Problem routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10 16
+ N: 0 1 2 3 5 10 16
+ NB: 1 3 3 3 20
+ NBMIN: 2 2 2 2 2
+ NX: 1 0 5 9 1
+ INMIN: 11 12 11 15 11
+ INWIN: 2 3 5 3 2
+ INIBL: 0 5 7 3 200
+ ISHFTS: 1 2 4 2 1
+ IACC22: 0 1 2 0 1
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ SHS routines passed the tests of the error exits ( 66 tests done)
+
+
+ NEP: NB = 1, NBMIN = 2, NX = 1, INMIN= 11, INWIN = 2, INIBL = 0, ISHFTS = 1, IACC22 = 0
+
+ All tests for SHS passed the threshold ( 1764 tests run)
+
+
+ NEP: NB = 3, NBMIN = 2, NX = 0, INMIN= 12, INWIN = 3, INIBL = 5, ISHFTS = 2, IACC22 = 1
+
+ All tests for SHS passed the threshold ( 1764 tests run)
+
+
+ NEP: NB = 3, NBMIN = 2, NX = 5, INMIN= 11, INWIN = 5, INIBL = 7, ISHFTS = 4, IACC22 = 2
+
+ All tests for SHS passed the threshold ( 1764 tests run)
+
+
+ NEP: NB = 3, NBMIN = 2, NX = 9, INMIN= 15, INWIN = 3, INIBL = 3, ISHFTS = 2, IACC22 = 0
+
+ All tests for SHS passed the threshold ( 1764 tests run)
+
+
+ NEP: NB = 20, NBMIN = 2, NX = 1, INMIN= 11, INWIN = 2, INIBL = 200, ISHFTS = 1, IACC22 = 1
+
+ All tests for SHS passed the threshold ( 1764 tests run)
+
+
+ End of tests
+ Total time used = .37 seconds
+
+ Tests of SSBTRD
+ (reduction of a symmetric band matrix to tridiagonal form)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 5 20
+ N: 5 20
+ K: 0 1 2 5 16
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ SSB routines passed the tests of the error exits ( 36 tests done)
+
+ All tests for SSB passed the threshold ( 540 tests run)
+
+
+ End of tests
+ Total time used = .02 seconds
+
+ Tests of the Symmetric Eigenvalue Problem routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 20
+ N: 0 1 2 3 5 20
+ NB: 1 3 3 3 10
+ NBMIN: 2 2 2 2 2
+ NX: 1 0 5 9 1
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 50.00
+
+
+ SST routines passed the tests of the error exits (147 tests done)
+
+
+ SEP: NB = 1, NBMIN = 2, NX = 1
+
+ All tests for SST passed the threshold ( 4662 tests run)
+
+ All tests for SST drivers passed the threshold ( 14256 tests run)
+
+
+ SEP: NB = 3, NBMIN = 2, NX = 0
+
+ All tests for SST passed the threshold ( 4662 tests run)
+
+ All tests for SST drivers passed the threshold ( 14256 tests run)
+
+
+ SEP: NB = 3, NBMIN = 2, NX = 5
+
+ All tests for SST passed the threshold ( 4662 tests run)
+
+ All tests for SST drivers passed the threshold ( 14256 tests run)
+
+
+ SEP: NB = 3, NBMIN = 2, NX = 9
+
+ All tests for SST passed the threshold ( 4662 tests run)
+
+ All tests for SST drivers passed the threshold ( 14256 tests run)
+
+
+ SEP: NB = 10, NBMIN = 2, NX = 1
+
+ All tests for SST passed the threshold ( 4662 tests run)
+
+ All tests for SST drivers passed the threshold ( 14256 tests run)
+
+
+ End of tests
+ Total time used = 2.43 seconds
+
+ Tests of the Symmetric Eigenvalue Problem routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10 16
+ N: 0 1 2 3 5 10 16
+ NB: 1 3 20
+ NBMIN: 2 2 2
+ NX: 1 1 1
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+
+ SSG: NB = 1, NBMIN = 2, NX = 1
+
+ All tests for SSG passed the threshold (10290 tests run)
+
+
+ SSG: NB = 3, NBMIN = 2, NX = 1
+
+ All tests for SSG passed the threshold (10290 tests run)
+
+
+ SSG: NB = 20, NBMIN = 2, NX = 1
+
+ All tests for SSG passed the threshold (10290 tests run)
+
+
+ End of tests
+ Total time used = 2.43 seconds
+
+ Tests of the Singular Value Decomposition routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 0 0 1 1 1 2 2 3 3
+ 3 10 10 16 16 30 30 40 40
+ N: 0 1 3 0 1 2 0 1 0 1
+ 3 10 16 10 16 30 40 30 40
+ NB: 1 3 3 3 20
+ NBMIN: 2 2 2 2 2
+ NX: 1 0 5 9 1
+ NS: 2 0 2 2 2
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ Routines pass computational tests if test ratio is less than 35.00
+
+
+ SBD routines passed the tests of the error exits ( 43 tests done)
+
+
+
+ SVD: NB = 1, NBMIN = 2, NX = 1, NRHS = 2
+
+ All tests for SBD routines passed the threshold ( 5510 tests run)
+
+ All tests for SBD drivers passed the threshold ( 8360 tests run)
+
+
+ SVD: NB = 3, NBMIN = 2, NX = 0, NRHS = 0
+
+ All tests for SBD routines passed the threshold ( 5510 tests run)
+
+ All tests for SBD drivers passed the threshold ( 8360 tests run)
+
+
+ SVD: NB = 3, NBMIN = 2, NX = 5, NRHS = 2
+
+ All tests for SBD routines passed the threshold ( 5510 tests run)
+
+ All tests for SBD drivers passed the threshold ( 8360 tests run)
+
+
+ SVD: NB = 3, NBMIN = 2, NX = 9, NRHS = 2
+
+ All tests for SBD routines passed the threshold ( 5510 tests run)
+
+ All tests for SBD drivers passed the threshold ( 8360 tests run)
+
+
+ SVD: NB = 20, NBMIN = 2, NX = 1, NRHS = 2
+
+ All tests for SBD routines passed the threshold ( 5510 tests run)
+
+ All tests for SBD drivers passed the threshold ( 8360 tests run)
+
+
+ End of tests
+ Total time used = 18.90 seconds
+
+ Tests of the REAL LAPACK routines
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M : 0 1 2 3 5 10 50
+ N : 0 1 2 3 5 10 50
+ NRHS: 1 2 15
+ NB : 1 3 3 3 20
+ NX : 1 0 5 9 1
+ RANK: 30 50 90
+
+ Routines pass computational tests if test ratio is less than 30.00
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+
+ SGE routines passed the tests of the error exits
+
+ All tests for SGE routines passed the threshold ( 3653 tests run)
+
+ SGE drivers passed the tests of the error exits
+
+ All tests for SGE drivers passed the threshold ( 4866 tests run)
+
+ SGB routines passed the tests of the error exits
+
+ All tests for SGB routines passed the threshold ( 28938 tests run)
+
+ SGB drivers passed the tests of the error exits
+
+ All tests for SGB drivers passed the threshold ( 30969 tests run)
+
+ SGT routines passed the tests of the error exits
+
+ All tests for SGT routines passed the threshold ( 2694 tests run)
+
+ SGT drivers passed the tests of the error exits
+
+ All tests for SGT drivers passed the threshold ( 2033 tests run)
+
+ SPO routines passed the tests of the error exits
+
+ All tests for SPO routines passed the threshold ( 1628 tests run)
+
+ SPO drivers passed the tests of the error exits
+
+ All tests for SPO drivers passed the threshold ( 1910 tests run)
+
+ SPS routines passed the tests of the error exits
+
+ All tests for SPS routines passed the threshold ( 150 tests run)
+
+ SPP routines passed the tests of the error exits
+
+ All tests for SPP routines passed the threshold ( 1332 tests run)
+
+ SPP drivers passed the tests of the error exits
+
+ All tests for SPP drivers passed the threshold ( 1910 tests run)
+
+ SPB routines passed the tests of the error exits
+
+ All tests for SPB routines passed the threshold ( 3458 tests run)
+
+ SPB drivers passed the tests of the error exits
+
+ All tests for SPB drivers passed the threshold ( 4750 tests run)
+
+ SPT routines passed the tests of the error exits
+
+ All tests for SPT routines passed the threshold ( 953 tests run)
+
+ SPT drivers passed the tests of the error exits
+
+ All tests for SPT drivers passed the threshold ( 788 tests run)
+
+ SSY routines passed the tests of the error exits
+
+ All tests for SSY routines passed the threshold ( 1624 tests run)
+
+ SSY drivers passed the tests of the error exits
+
+ All tests for SSY drivers passed the threshold ( 1072 tests run)
+
+ SSP routines passed the tests of the error exits
+
+ All tests for SSP routines passed the threshold ( 1404 tests run)
+
+ SSP drivers passed the tests of the error exits
+
+ All tests for SSP drivers passed the threshold ( 1072 tests run)
+
+ STR routines passed the tests of the error exits
+
+ All tests for STR routines passed the threshold ( 7672 tests run)
+
+ STP routines passed the tests of the error exits
+
+ All tests for STP routines passed the threshold ( 7392 tests run)
+
+ STB routines passed the tests of the error exits
+
+ All tests for STB routines passed the threshold ( 19888 tests run)
+
+ SQR routines passed the tests of the error exits
+
+ All tests for SQR routines passed the threshold ( 30744 tests run)
+
+ SRQ routines passed the tests of the error exits
+
+ All tests for SRQ routines passed the threshold ( 30744 tests run)
+
+ SLQ routines passed the tests of the error exits
+
+ All tests for SLQ routines passed the threshold ( 30744 tests run)
+
+ SQL routines passed the tests of the error exits
+
+ All tests for SQL routines passed the threshold ( 30744 tests run)
+
+ SQP routines passed the tests of the error exits
+
+ All tests for SQP routines passed the threshold ( 882 tests run)
+
+ All tests for SQ3 routines passed the threshold ( 4410 tests run)
+
+ STZ routines passed the tests of the error exits
+
+ All tests for STZ routines passed the threshold ( 504 tests run)
+
+ SLS routines passed the tests of the error exits
+
+ All tests for SLS drivers passed the threshold ( 65268 tests run)
+
+ All tests for SEQ routines passed the threshold
+
+ End of tests
+ Total time used = 16.98 seconds
+
+
+ Tests of the REAL LAPACK RFP routines
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ N : 0 1 2 3 5 6 10 11 50
+ NRHS: 1 2 15
+ TYPE: 1 2 3 4 5 6 7 8 9
+
+ Routines pass computational tests if test ratio is less than 30.00
+
+ Relative machine underflow is taken to be .117549E-37
+ Relative machine overflow is taken to be .340282E+39
+ Relative machine precision is taken to be .596046E-07
+
+ REAL RFP routines passed the tests of the error exits
+
+ All tests for SPF drivers passed the threshold ( 2352 tests run)
+ All tests for SLANSF auxiliary routine passed the threshold ( 432 tests run)
+ All tests for the RFP convertion routines passed ( 72 tests run)
+ All tests for STFSM auxiliary routine passed the threshold ( 7776 tests run)
+ All tests for SSFRK auxiliary routine passed the threshold ( 2592 tests run)
+
+ End of tests
+ Total time used = 1.72 seconds
+
+ .. test output of ZGEBAK ..
+ value of largest test error = .189E+01
+ example number where info is not zero = 0
+ example number having largest error = 5
+ number of examples where info is not 0 = 0
+ total number of examples tested = 7
+
+
+ End of tests
+ Total time used = .00 seconds
+
+ .. test output of ZGEBAL ..
+ value of largest test error = .000E+00
+ example number where info is not zero = 0
+ example number where ILO or IHI wrong = 0
+ example number having largest error = 0
+ number of examples where info is not 0 = 0
+ total number of examples tested = 13
+
+
+ End of tests
+ Total time used = .00 seconds
+
+ Tests of ZGBBRD
+ (reduction of a general band matrix to real bidiagonal form)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 0 0 0 1 1 1 1 2 2
+ 2 2 3 3 3 3 10 10 16 16
+ N: 0 1 2 3 0 1 2 3 0 1
+ 2 3 0 1 2 3 10 16 10 16
+ K: 0 1 2 3 16
+ NS: 1 2
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+
+ ZBB: NRHS = 1
+
+ All tests for ZBB passed the threshold ( 3000 tests run)
+
+
+ ZBB: NRHS = 2
+
+ All tests for ZBB passed the threshold ( 3000 tests run)
+
+
+ End of tests
+ Total time used = .20 seconds
+
+ Tests of the COMPLEX*16 LAPACK ZCGESV/ZCPOSV routines
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M : 0 1 2 13 17 45 78 91 101 120
+ 132
+ NRHS: 1 2 15 16
+
+ Routines pass computational tests if test ratio is less than 30.00
+
+ Relative machine (single precision) underflow is taken to be .117549E-37
+ Relative machine (single precision) overflow is taken to be .340282E+39
+ Relative machine (single precision) precision is taken to be .596046E-07
+
+ Relative machine (double precision) underflow is taken to be .222507-307
+ Relative machine (double precision) overflow is taken to be .179769+309
+ Relative machine (double precision) precision is taken to be .111022E-15
+
+
+ ZCGESV drivers passed the tests of the error exits
+
+ All tests for ZCGESV routines passed the threshold ( 324 tests run)
+
+ ZCPOSV drivers passed the tests of the error exits
+
+ All tests for ZCPOSV routines passed the threshold ( 488 tests run)
+
+ End of tests
+ Total time used = 10.10 seconds
+
+ Tests of the Nonsymmetric eigenproblem condition estimation routines
+ ZTRSYL, CTREXC, CTRSNA, CTRSEN
+
+ Relative machine precision (EPS) = .222045E-15
+ Safe minimum (SFMIN) = .222507-307
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ ZEC routines passed the tests of the error exits ( 33 tests done)
+
+ All tests for ZEC routines passed the threshold ( 5966 tests run)
+
+
+ End of tests
+ Total time used = .08 seconds
+
+
+ Tests of the Nonsymmetric Eigenvalue Problem Driver
+ ZGEES (Schur form)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10
+ N: 0 1 2 3 5 10
+ NB: 3
+ NBMIN: 3
+ NX: 1
+ INMIN: 11
+ INWIN: 4
+ INIBL: 8
+ ISHFTS: 2
+ IACC22: 0
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ ZGEES passed the tests of the error exits ( 6 tests done)
+
+ All tests for ZES passed the threshold ( 3276 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Nonsymmetric Eigenvalue Problem Driver
+ ZGEEV (eigenvalues and eigevectors)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10
+ N: 0 1 2 3 5 10
+ NB: 3
+ NBMIN: 3
+ NX: 1
+ INMIN: 11
+ INWIN: 4
+ INIBL: 8
+ ISHFTS: 2
+ IACC22: 0
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ ZGEEV passed the tests of the error exits ( 7 tests done)
+
+ All tests for ZEV passed the threshold ( 924 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Nonsymmetric Eigenvalue Problem Expert Driver
+ ZGEESX (Schur form and condition numbers)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10
+ N: 0 1 2 3 5 10
+ NB: 3
+ NBMIN: 3
+ NX: 1
+ INMIN: 11
+ INWIN: 4
+ INIBL: 8
+ ISHFTS: 2
+ IACC22: 0
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ ZGEESX passed the tests of the error exits ( 7 tests done)
+
+ All tests for ZSX passed the threshold ( 3406 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Nonsymmetric Eigenvalue Problem Expert Driver
+ ZGEEVX (eigenvalues, eigenvectors and condition numbers)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10
+ N: 0 1 2 3 5 10
+ NB: 3
+ NBMIN: 3
+ NX: 1
+ INMIN: 11
+ INWIN: 4
+ INIBL: 8
+ ISHFTS: 2
+ IACC22: 0
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ ZGEEVX passed the tests of the error exits ( 10 tests done)
+
+ All tests for ZVX passed the threshold ( 5172 tests run)
+
+ -----------------------------------------------------------------------
+
+
+ End of tests
+ Total time used = 1.33 seconds
+
+ .. test output of ZGGBAK ..
+ value of largest test error = .741E+00
+ example number where ZGGBAL info is not 0 = 0
+ example number where ZGGBAK(L) info is not 0 = 0
+ example number where ZGGBAK(R) info is not 0 = 0
+ example number having largest error = 6
+ number of examples where info is not 0 = 0
+ total number of examples tested = 10
+
+
+ End of tests
+ Total time used = .00 seconds
+
+ .. test output of ZGGBAL ..
+ ratio of largest test error = .246E-01
+ example number where info is not zero = 0
+ example number where ILO or IHI is wrong = 0
+ example number having largest error = 6
+ number of examples where info is not 0 = 0
+ total number of examples tested = 10
+
+
+ End of tests
+ Total time used = .00 seconds
+
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Driver ZGGEV
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 2 6 8 10 12 20
+ N: 2 6 8 10 12 20
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ ZGV routines passed the tests of the error exits ( 85 tests done)
+
+ All tests for ZGV drivers passed the threshold ( 1092 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Driver ZGGES
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 2 6 10 12 20
+ N: 2 6 10 12 20
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ ZGS routines passed the tests of the error exits ( 85 tests done)
+
+ All tests for ZGS drivers passed the threshold ( 1560 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Expert Driver ZGGESX
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ N: 2
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ ZGX routines passed the tests of the error exits ( 85 tests done)
+
+ All tests for CGX drivers passed the threshold ( 150 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Expert Driver ZGGEVX
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ N: 6
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ ZXV routines passed the tests of the error exits ( 85 tests done)
+
+ ZXV -- Complex Expert Eigenvalue/vector problem driver
+ Matrix types:
+
+ TYPE 1: Da is diagonal, Db is identity,
+ A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1)
+ YH and X are left and right eigenvectors.
+
+ TYPE 2: Da is quasi-diagonal, Db is identity,
+ A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1)
+ YH and X are left and right eigenvectors.
+
+
+ Tests performed:
+ a is alpha, b is beta, l is a left eigenvector,
+ r is a right eigenvector and ' means transpose.
+ 1 = max | ( b A - a B )' l | / const.
+ 2 = max | ( b A - a B ) r | / const.
+ 3 = max ( Sest/Stru, Stru/Sest ) over all eigenvalues
+ 4 = max( DIFest/DIFtru, DIFtru/DIFest ) over the 1st and 5th eigenvectors
+
+ Type= 2, IWA= 1, IWB= 1, IWX= 1, IWY= 5, result 4 is 2364.97
+ Type= 2, IWA= 1, IWB= 1, IWX= 2, IWY= 5, result 4 is 2279.60
+ Type= 2, IWA= 1, IWB= 1, IWX= 3, IWY= 5, result 4 is 1515.40
+ Type= 2, IWA= 1, IWB= 1, IWX= 4, IWY= 5, result 4 is 255.93
+ Type= 2, IWA= 1, IWB= 1, IWX= 5, IWY= 1, result 4 is 2423.59
+ Type= 2, IWA= 1, IWB= 1, IWX= 5, IWY= 2, result 4 is 2495.73
+ Type= 2, IWA= 1, IWB= 1, IWX= 5, IWY= 3, result 4 is 2161.03
+ Type= 2, IWA= 1, IWB= 1, IWX= 5, IWY= 4, result 4 is 249.60
+ Type= 2, IWA= 5, IWB= 1, IWX= 1, IWY= 5, result 4 is 5116.24
+ Type= 2, IWA= 5, IWB= 1, IWX= 2, IWY= 5, result 4 is 5165.55
+ Type= 2, IWA= 5, IWB= 1, IWX= 3, IWY= 5, result 4 is 5537.38
+ Type= 2, IWA= 5, IWB= 1, IWX= 4, IWY= 5, result 4 is 2582.12
+ Type= 2, IWA= 5, IWB= 2, IWX= 1, IWY= 5, result 4 is 4661.56
+ Type= 2, IWA= 5, IWB= 2, IWX= 2, IWY= 5, result 4 is 4702.62
+ Type= 2, IWA= 5, IWB= 2, IWX= 3, IWY= 5, result 4 is 5019.81
+ Type= 2, IWA= 5, IWB= 2, IWX= 4, IWY= 5, result 4 is 2578.92
+ Type= 2, IWA= 5, IWB= 3, IWX= 1, IWY= 5, result 4 is 2582.14
+ Type= 2, IWA= 5, IWB= 3, IWX= 2, IWY= 5, result 4 is 2594.89
+ Type= 2, IWA= 5, IWB= 3, IWX= 3, IWY= 5, result 4 is 2702.29
+ Type= 2, IWA= 5, IWB= 3, IWX= 4, IWY= 5, result 4 is 2310.95
+ Type= 2, IWA= 5, IWB= 4, IWX= 1, IWY= 5, result 4 is 470.90
+ Type= 2, IWA= 5, IWB= 4, IWX= 2, IWY= 5, result 4 is 471.32
+ Type= 2, IWA= 5, IWB= 4, IWX= 3, IWY= 5, result 4 is 475.13
+ Type= 2, IWA= 5, IWB= 4, IWX= 4, IWY= 5, result 4 is 507.92
+ ZXV drivers: 24 out of 5000 tests failed to pass the threshold
+
+ -----------------------------------------------------------------------
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Expert Driver ZGGESX
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ N: 0
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ ZGX routines passed the tests of the error exits ( 85 tests done)
+
+ All tests for CGX drivers passed the threshold ( 20 tests run)
+
+ -----------------------------------------------------------------------
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem Expert Driver ZGGEVX
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ N: 0
+ NB: 1
+ NBMIN: 1
+ NX: 1
+ NS: 2
+ MAXB: 1
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 10.00
+
+
+ ZXV routines passed the tests of the error exits ( 85 tests done)
+
+ All tests for ZXV drivers passed the threshold ( 8 tests run)
+
+ -----------------------------------------------------------------------
+
+
+ End of tests
+ Total time used = 1.07 seconds
+
+
+ Tests of the Generalized Nonsymmetric Eigenvalue Problem routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10 16
+ N: 0 1 2 3 5 10 16
+ NB: 1 1 2 2
+ NBMIN: 40 40 2 2
+ NS: 2 4 2 4
+ MAXB: 40 40 2 2
+ NBCOL: 40 40 2 2
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ ZGG routines passed the tests of the error exits ( 27 tests done)
+
+
+ ZGG: NB = 1, NBMIN = 40, NS = 2, MAXB = 40, NBCOL = 40
+
+ All tests for ZGG passed the threshold ( 2184 tests run)
+
+ All tests for ZGG drivers passed the threshold ( 1274 tests run)
+
+
+ ZGG: NB = 1, NBMIN = 40, NS = 4, MAXB = 40, NBCOL = 40
+
+ All tests for ZGG passed the threshold ( 2184 tests run)
+
+ All tests for ZGG drivers passed the threshold ( 1274 tests run)
+
+
+ ZGG: NB = 2, NBMIN = 2, NS = 2, MAXB = 2, NBCOL = 2
+
+ All tests for ZGG passed the threshold ( 2184 tests run)
+
+ All tests for ZGG drivers passed the threshold ( 1274 tests run)
+
+
+ ZGG: NB = 2, NBMIN = 2, NS = 4, MAXB = 2, NBCOL = 2
+
+ All tests for ZGG passed the threshold ( 2184 tests run)
+
+ All tests for ZGG drivers passed the threshold ( 1274 tests run)
+
+
+ End of tests
+ Total time used = 1.25 seconds
+
+
+ Tests of the Generalized Linear Regression Model routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 5 8 15 20 40
+ P: 9 0 15 12 15 30
+ N: 5 5 10 25 30 40
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ GLM routines passed the tests of the error exits ( 8 tests done)
+
+ All tests for GLM routines passed the threshold ( 48 tests run)
+
+
+ End of tests
+ Total time used = .07 seconds
+
+
+ Tests of the Generalized QR and RQ routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 3 10
+ P: 0 5 20
+ N: 0 3 30
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ GQR routines passed the tests of the error exits ( 12 tests done)
+
+ All tests for GQR routines passed the threshold ( 1728 tests run)
+
+
+ End of tests
+ Total time used = .23 seconds
+
+
+ Tests of the Generalized Singular Value Decomposition routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 5 9 10 20 12 12 40
+ P: 4 0 12 14 10 10 20 15
+ N: 3 10 15 12 8 20 8 20
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ GSV routines passed the tests of the error exits ( 33 tests done)
+
+ All tests for GSV routines passed the threshold ( 384 tests run)
+
+
+ End of tests
+ Total time used = .15 seconds
+
+
+ Tests of the Linear Least Squares routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 6 0 5 8 10 30
+ P: 0 5 5 5 8 20
+ N: 5 5 6 8 12 40
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ LSE routines passed the tests of the error exits ( 8 tests done)
+
+ All tests for LSE routines passed the threshold ( 96 tests run)
+
+
+ End of tests
+ Total time used = .03 seconds
+
+ Tests of the Nonsymmetric Eigenvalue Problem routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10 16
+ N: 0 1 2 3 5 10 16
+ NB: 1 3 3 3 20
+ NBMIN: 2 2 2 2 2
+ NX: 1 0 5 9 1
+ INMIN: 11 12 11 15 11
+ INWIN: 2 3 5 3 2
+ INIBL: 0 5 7 3 200
+ ISHFTS: 1 2 4 2 1
+ IACC22: 0 1 2 0 1
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ ZHS routines passed the tests of the error exits ( 66 tests done)
+
+
+ NEP: NB = 1, NBMIN = 2, NX = 1, INMIN= 11, INWIN = 2, INIBL = 0, ISHFTS = 1, IACC22 = 0
+
+ All tests for ZHS passed the threshold ( 2058 tests run)
+
+
+ NEP: NB = 3, NBMIN = 2, NX = 0, INMIN= 12, INWIN = 3, INIBL = 5, ISHFTS = 2, IACC22 = 1
+
+ All tests for ZHS passed the threshold ( 2058 tests run)
+
+
+ NEP: NB = 3, NBMIN = 2, NX = 5, INMIN= 11, INWIN = 5, INIBL = 7, ISHFTS = 4, IACC22 = 2
+
+ All tests for ZHS passed the threshold ( 2058 tests run)
+
+
+ NEP: NB = 3, NBMIN = 2, NX = 9, INMIN= 15, INWIN = 3, INIBL = 3, ISHFTS = 2, IACC22 = 0
+
+ All tests for ZHS passed the threshold ( 2058 tests run)
+
+
+ NEP: NB = 20, NBMIN = 2, NX = 1, INMIN= 11, INWIN = 2, INIBL = 200, ISHFTS = 1, IACC22 = 1
+
+ All tests for ZHS passed the threshold ( 2058 tests run)
+
+
+ End of tests
+ Total time used = 1.00 seconds
+
+ Tests of ZHBTRD
+ (reduction of a Hermitian band matrix to real tridiagonal form)
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 5 20
+ N: 5 20
+ K: 0 1 2 5 16
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+ ZHB routines passed the tests of the error exits ( 38 tests done)
+
+ All tests for ZHB passed the threshold ( 540 tests run)
+
+
+ End of tests
+ Total time used = .05 seconds
+
+ Tests of the Hermitian Eigenvalue Problem routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 20
+ N: 0 1 2 3 5 20
+ NB: 1 3 3 3 10
+ NBMIN: 2 2 2 2 2
+ NX: 1 0 5 9 1
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 50.00
+
+
+ ZST routines passed the tests of the error exits (114 tests done)
+
+
+ SEP: NB = 1, NBMIN = 2, NX = 1
+
+ ZST -- Complex Hermitian eigenvalue problem
+ Matrix types (see ZCHKST for details):
+
+ Special Matrices:
+ 1=Zero matrix. 5=Diagonal: clustered entries.
+ 2=Identity matrix. 6=Diagonal: large, evenly spaced.
+ 3=Diagonal: evenly spaced entries. 7=Diagonal: small, evenly spaced.
+ 4=Diagonal: geometr. spaced entries.
+ Dense Hermitian Matrices:
+ 8=Evenly spaced eigenvals. 12=Small, evenly spaced eigenvals.
+ 9=Geometrically spaced eigenvals. 13=Matrix with random O(1) entries.
+ 10=Clustered eigenvalues. 14=Matrix with large random entries.
+ 11=Large, evenly spaced eigenvals. 15=Matrix with small random entries.
+ 16=Positive definite, evenly spaced eigenvalues
+ 17=Positive definite, geometrically spaced eigenvlaues
+ 18=Positive definite, clustered eigenvalues
+ 19=Positive definite, small evenly spaced eigenvalues
+ 20=Positive definite, large evenly spaced eigenvalues
+ 21=Diagonally dominant tridiagonal, geometrically spaced eigenvalues
+
+Test performed: see ZCHKST for details.
+
+ Matrix order= 20, type= 9, seed=3514, 529,1470,3001, result 36 is 67.81
+ ZST: 1 out of 4662 tests failed to pass the threshold
+
+ All tests for ZST drivers passed the threshold ( 11664 tests run)
+
+
+ SEP: NB = 3, NBMIN = 2, NX = 0
+
+ All tests for ZST passed the threshold ( 4662 tests run)
+
+ All tests for ZST drivers passed the threshold ( 11664 tests run)
+
+
+ SEP: NB = 3, NBMIN = 2, NX = 5
+
+ All tests for ZST passed the threshold ( 4662 tests run)
+
+ All tests for ZST drivers passed the threshold ( 11664 tests run)
+
+
+ SEP: NB = 3, NBMIN = 2, NX = 9
+
+ All tests for ZST passed the threshold ( 4662 tests run)
+
+ All tests for ZST drivers passed the threshold ( 11664 tests run)
+
+
+ SEP: NB = 10, NBMIN = 2, NX = 1
+
+ All tests for ZST passed the threshold ( 4662 tests run)
+
+ All tests for ZST drivers passed the threshold ( 11664 tests run)
+
+
+ End of tests
+ Total time used = 4.87 seconds
+
+ Tests of the Hermitian Eigenvalue Problem routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 1 2 3 5 10 16
+ N: 0 1 2 3 5 10 16
+ NB: 1 3 20
+ NBMIN: 2 2 2
+ NX: 1 1 1
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 20.00
+
+
+
+ ZSG: NB = 1, NBMIN = 2, NX = 1
+
+ All tests for ZSG passed the threshold (10290 tests run)
+
+
+ ZSG: NB = 3, NBMIN = 2, NX = 1
+
+ All tests for ZSG passed the threshold (10290 tests run)
+
+
+ ZSG: NB = 20, NBMIN = 2, NX = 1
+
+ All tests for ZSG passed the threshold (10290 tests run)
+
+
+ End of tests
+ Total time used = 4.87 seconds
+
+ Tests of the Singular Value Decomposition routines
+
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M: 0 0 0 1 1 1 2 2 3 3
+ 3 10 10 16 16 30 30 40 40
+ N: 0 1 3 0 1 2 0 1 0 1
+ 3 10 16 10 16 30 40 30 40
+ NB: 1 3 3 3 20
+ NBMIN: 2 2 2 2 2
+ NX: 1 0 5 9 1
+ NS: 2 0 2 2 2
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ Routines pass computational tests if test ratio is less than 35.00
+
+
+ ZBD routines passed the tests of the error exits ( 35 tests done)
+
+ ZGESVD passed the tests of the error exits ( 8 tests done)
+ ZGESDD passed the tests of the error exits ( 6 tests done)
+
+
+ SVD: NB = 1, NBMIN = 2, NX = 1, NRHS = 2
+
+ All tests for ZBD routines passed the threshold ( 4085 tests run)
+
+ All tests for ZBD drivers passed the threshold ( 4840 tests run)
+
+
+ SVD: NB = 3, NBMIN = 2, NX = 0, NRHS = 0
+
+ All tests for ZBD routines passed the threshold ( 4085 tests run)
+
+ All tests for ZBD drivers passed the threshold ( 4840 tests run)
+
+
+ SVD: NB = 3, NBMIN = 2, NX = 5, NRHS = 2
+
+ All tests for ZBD routines passed the threshold ( 4085 tests run)
+
+ All tests for ZBD drivers passed the threshold ( 4840 tests run)
+
+
+ SVD: NB = 3, NBMIN = 2, NX = 9, NRHS = 2
+
+ All tests for ZBD routines passed the threshold ( 4085 tests run)
+
+ All tests for ZBD drivers passed the threshold ( 4840 tests run)
+
+
+ SVD: NB = 20, NBMIN = 2, NX = 1, NRHS = 2
+
+ All tests for ZBD routines passed the threshold ( 4085 tests run)
+
+ All tests for ZBD drivers passed the threshold ( 4840 tests run)
+
+
+ End of tests
+ Total time used = 34.85 seconds
+
+ Tests of the COMPLEX*16 LAPACK routines
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ M : 0 1 2 3 5 10 50
+ N : 0 1 2 3 5 10 50
+ NRHS: 1 2 15
+ NB : 1 3 3 3 20
+ NX : 1 0 5 9 1
+ RANK: 30 50 90
+
+ Routines pass computational tests if test ratio is less than 30.00
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+
+ ZGE routines passed the tests of the error exits
+
+ All tests for ZGE routines passed the threshold ( 3653 tests run)
+
+ ZGE drivers passed the tests of the error exits
+
+ All tests for ZGE drivers passed the threshold ( 4866 tests run)
+
+ ZGB routines passed the tests of the error exits
+
+ All tests for ZGB routines passed the threshold ( 28938 tests run)
+
+ ZGB drivers passed the tests of the error exits
+
+ All tests for ZGB drivers passed the threshold ( 30969 tests run)
+
+ ZGT routines passed the tests of the error exits
+
+ All tests for ZGT routines passed the threshold ( 2694 tests run)
+
+ ZGT drivers passed the tests of the error exits
+
+ All tests for ZGT drivers passed the threshold ( 2033 tests run)
+
+ ZPO routines passed the tests of the error exits
+
+ All tests for ZPO routines passed the threshold ( 1628 tests run)
+
+ ZPO drivers passed the tests of the error exits
+
+ All tests for ZPO drivers passed the threshold ( 1910 tests run)
+
+ ZPS routines passed the tests of the error exits
+
+ All tests for ZPS routines passed the threshold ( 150 tests run)
+
+ ZPP routines passed the tests of the error exits
+
+ All tests for ZPP routines passed the threshold ( 1332 tests run)
+
+ ZPP drivers passed the tests of the error exits
+
+ All tests for ZPP drivers passed the threshold ( 1910 tests run)
+
+ ZPB routines passed the tests of the error exits
+
+ All tests for ZPB routines passed the threshold ( 3458 tests run)
+
+ ZPB drivers passed the tests of the error exits
+
+ All tests for ZPB drivers passed the threshold ( 4750 tests run)
+
+ ZPT routines passed the tests of the error exits
+
+ All tests for ZPT routines passed the threshold ( 1778 tests run)
+
+ ZPT drivers passed the tests of the error exits
+
+ All tests for ZPT drivers passed the threshold ( 788 tests run)
+
+ ZHE routines passed the tests of the error exits
+
+ All tests for ZHE routines passed the threshold ( 1624 tests run)
+
+ ZHE drivers passed the tests of the error exits
+
+ All tests for ZHE drivers passed the threshold ( 1072 tests run)
+
+ ZHP routines passed the tests of the error exits
+
+ All tests for ZHP routines passed the threshold ( 1404 tests run)
+
+ ZHP drivers passed the tests of the error exits
+
+ All tests for ZHP drivers passed the threshold ( 1072 tests run)
+
+ ZSY routines passed the tests of the error exits
+
+ All tests for ZSY routines passed the threshold ( 1864 tests run)
+
+ ZSY drivers passed the tests of the error exits
+
+ All tests for ZSY drivers passed the threshold ( 1240 tests run)
+
+ ZSP routines passed the tests of the error exits
+
+ All tests for ZSP routines passed the threshold ( 1620 tests run)
+
+ ZSP drivers passed the tests of the error exits
+
+ All tests for ZSP drivers passed the threshold ( 1240 tests run)
+
+ ZTR routines passed the tests of the error exits
+
+ All tests for ZTR routines passed the threshold ( 7672 tests run)
+
+ ZTP routines passed the tests of the error exits
+
+ All tests for ZTP routines passed the threshold ( 7392 tests run)
+
+ ZTB routines passed the tests of the error exits
+
+ All tests for ZTB routines passed the threshold ( 19888 tests run)
+
+ ZQR routines passed the tests of the error exits
+
+ All tests for ZQR routines passed the threshold ( 30744 tests run)
+
+ ZRQ routines passed the tests of the error exits
+
+ All tests for ZRQ routines passed the threshold ( 28784 tests run)
+
+ ZLQ routines passed the tests of the error exits
+
+ All tests for ZLQ routines passed the threshold ( 30744 tests run)
+
+ ZQL routines passed the tests of the error exits
+
+ All tests for ZQL routines passed the threshold ( 28784 tests run)
+
+ ZQP routines passed the tests of the error exits
+
+ All tests for ZQP routines passed the threshold ( 882 tests run)
+
+ All tests for ZQ3 routines passed the threshold ( 4410 tests run)
+
+ ZTZ routines passed the tests of the error exits
+
+ All tests for ZTZ routines passed the threshold ( 504 tests run)
+
+ ZLS routines passed the tests of the error exits
+
+ All tests for ZLS drivers passed the threshold ( 65268 tests run)
+
+ All tests for ZEQ routines passed the threshold
+
+ End of tests
+ Total time used = 49.30 seconds
+
+
+ Tests of the COMPLEX*16 LAPACK RFP routines
+ LAPACK VERSION 3.2.0
+
+ The following parameter values will be used:
+ N : 0 1 2 3 5 6 10 11 50
+ NRHS: 1 2 15
+ TYPE: 1 2 3 4 5 6 7 8 9
+
+ Routines pass computational tests if test ratio is less than 30.00
+
+ Relative machine underflow is taken to be .222507-307
+ Relative machine overflow is taken to be .179769+309
+ Relative machine precision is taken to be .111022E-15
+
+ COMPLEX*16 RFP routines passed the tests of the error exits
+
+ All tests for ZPF drivers passed the threshold ( 2352 tests run)
+ All tests for ZLANHF auxiliary routine passed the threshold ( 432 tests run)
+ All tests for the RFP convertion routines passed ( 72 tests run)
+ All tests for ZTFSM auxiliary routine passed the threshold ( 7776 tests run)
+ All tests for ZHFRK auxiliary routine passed the threshold ( 2592 tests run)
+
+ End of tests
+ Total time used = 6.10 seconds
+
diff --git a/TESTING/runtest.cmake b/TESTING/runtest.cmake
new file mode 100644
index 0000000..49fd9ad
--- /dev/null
+++ b/TESTING/runtest.cmake
@@ -0,0 +1,31 @@
+# Replace INTDIR with the value of $ENV{CMAKE_CONFIG_TYPE} that is set
+# by ctest when -C Debug|Releaes|etc is given, and INDIR is passed
+# in from the main cmake run and is the variable that is used
+# by the build system to specify the build directory
+if(NOT "${INTDIR}" STREQUAL ".")
+ set(TEST_ORIG "${TEST}")
+ string(REPLACE "${INTDIR}" "$ENV{CMAKE_CONFIG_TYPE}" TEST "${TEST}")
+ if("$ENV{CMAKE_CONFIG_TYPE}" STREQUAL "")
+ if(NOT EXISTS "${TEST}")
+ message("Warning: CMAKE_CONFIG_TYPE not defined did you forget the -C option for ctest?")
+ message(FATAL_ERROR "Could not find test executable: ${TEST_ORIG}")
+ endif()
+ endif()
+endif()
+set(ARGS )
+if(DEFINED OUTPUT)
+ set(ARGS OUTPUT_FILE "${OUTPUT}" ERROR_FILE "${OUTPUT}.err")
+endif()
+if(DEFINED INPUT)
+ list(APPEND ARGS INPUT_FILE "${INPUT}")
+endif()
+message("Running: ${TEST}")
+message("ARGS= ${ARGS}")
+execute_process(COMMAND "${TEST}"
+ ${ARGS}
+ RESULT_VARIABLE RET)
+# if the test does not return 0, then fail it
+if(NOT ${RET} EQUAL 0)
+ message(FATAL_ERROR "Test ${TEST} returned ${RET}")
+endif()
+message( "Test ${TEST} returned ${RET}")
\ No newline at end of file
diff --git a/TESTING/sbak.in b/TESTING/sbak.in
new file mode 100644
index 0000000..8bfeda3
--- /dev/null
+++ b/TESTING/sbak.in
@@ -0,0 +1,130 @@
+SBK: Tests SGEBAK
+ 5 1 1
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01
+
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
+
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
+
+ 5 1 1
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+
+ 0.1000E+01 0.1000E+01 0.1000E+01 -0.6667E+00 -0.4167E-01
+ 0.0000E+00 -0.2500E+00 -0.6667E+00 0.1000E+01 0.1667E+00
+ 0.0000E+00 0.0000E+00 0.2222E+00 -0.1000E+01 -0.5000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.5000E+00 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 -0.1000E+01
+
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 -0.1000E+01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.5000E+00 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.2222E+00 -0.1000E+01 -0.5000E+00
+ 0.0000E+00 -0.2500E+00 -0.6667E+00 0.1000E+01 0.1667E+00
+ 0.1000E+01 0.1000E+01 0.1000E+01 -0.6667E+00 -0.4167E-01
+
+ 5 1 1
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.0000E+00 -0.6000E-17 -0.6000E-17 -0.6000E-17 -0.6000E-17
+ 0.0000E+00 0.0000E+00 0.3600E-34 0.3600E-34 0.3600E-34
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.3600E-34 0.3600E-34 0.3600E-34
+ 0.0000E+00 -0.6000E-17 -0.6000E-17 -0.6000E-17 -0.6000E-17
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+
+ 6 4 6
+ 0.4000E+01 0.3000E+01 0.5000E+01 0.1000E+03 0.1000E+00 0.1000E+01
+
+ 0.1000E+01 0.1336E-05 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.0000E+00 0.1000E+01 0.0000E+00 -0.3001E-10 -0.3252E-04 0.1305E-01
+ 0.0000E+00 0.0000E+00 -0.8330E-02 0.8929E-09 -0.6712E-04 0.6687E-04
+ 0.0000E+00 0.0000E+00 0.0000E+00 -0.4455E-05 -0.3355E-02 0.3345E-02
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.4455E-06 -0.3356E-01 0.3344E-01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.4411E-09 0.1011E+00 0.1008E+00
+
+ 0.0000E+00 0.0000E+00 0.0000E+00 -0.4455E-03 -0.3355E+00 0.3345E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.4455E-07 -0.3356E-02 0.3344E-02
+ 0.0000E+00 0.1000E+01 0.0000E+00 -0.3001E-10 -0.3252E-04 0.1305E-01
+ 0.1000E+01 0.1336E-05 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.0000E+00 0.0000E+00 -0.8330E-02 0.8929E-09 -0.6712E-04 0.6687E-04
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.4411E-09 0.1011E+00 0.1008E+00
+
+ 5 1 5
+ 0.1000E+03 0.1000E+00 0.1000E-01 0.1000E+01 0.1000E+02
+
+ 0.1366E-03 -0.6829E-04 0.1252E-03 0.1000E+01 0.1950E-14
+ 0.1000E+01 0.1000E+01 -0.2776E-16 0.3601E-05 -0.6073E-17
+ 0.2736E+00 -0.1363E+00 0.2503E+00 -0.3322E-05 -0.2000E-02
+ 0.6909E-02 -0.3443E-02 0.6196E-02 0.1666E-01 0.1000E+01
+ 0.3899E+00 -0.2033E+00 -0.3420E+00 -0.1000E-02 0.6000E-14
+
+ 0.1366E-01 -0.6829E-02 0.1252E-01 0.1000E+03 0.1950E-12
+ 0.1000E+00 0.1000E+00 -0.2776E-17 0.3601E-06 -0.6073E-18
+ 0.2736E-02 -0.1363E-02 0.2503E-02 -0.3322E-07 -0.2000E-04
+ 0.6909E-02 -0.3443E-02 0.6196E-02 0.1666E-01 0.1000E+01
+ 0.3899E+01 -0.2033E+01 -0.3420E+01 -0.1000E-01 0.6000E-13
+
+ 6 2 5
+ 0.3000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.4000E+01
+
+ 0.1000E+01 0.1000E+01 0.2776E-15 -0.2405E-16 0.0000E+00 0.1000E+01
+ 0.0000E+00 0.7500E+00 0.1000E+01 0.8520E-01 0.0000E+00 -0.1520E-16
+ 0.0000E+00 0.7500E+00 -0.8093E+00 0.1000E+01 0.0000E+00 -0.1520E-16
+ 0.0000E+00 0.7500E+00 -0.9533E-01 -0.5426E+00 0.1000E+01 -0.1520E-16
+ 0.0000E+00 0.7500E+00 -0.9533E-01 -0.5426E+00 -0.1000E+01 -0.1520E-16
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.4559E-16
+
+ 0.0000E+00 0.7500E+00 -0.8093E+00 0.1000E+01 0.0000E+00 -0.1520E-16
+ 0.0000E+00 0.7500E+00 0.1000E+01 0.8520E-01 0.0000E+00 -0.1520E-16
+ 0.1000E+01 0.1000E+01 0.2776E-15 -0.2405E-16 0.0000E+00 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.4559E-16
+ 0.0000E+00 0.7500E+00 -0.9533E-01 -0.5426E+00 -0.1000E+01 -0.1520E-16
+ 0.0000E+00 0.7500E+00 -0.9533E-01 -0.5426E+00 0.1000E+01 -0.1520E-16
+
+ 7 2 5
+ 0.3000E+01 0.1000E-02 0.1000E-01 0.1000E+02 0.1000E+00 0.1000E+01
+ 0.6000E+01
+
+ 0.1000E+01 -0.1105E-01 0.3794E-01 -0.9378E-01 -0.3481E-01 0.4465E+00
+ -0.3602E-01
+ 0.0000E+00 -0.4556E+00 -0.4545E+00 0.1000E+01 0.4639E+00 -0.6512E+00
+ 0.4781E+00
+ 0.0000E+00 -0.2734E+00 -0.7946E+00 0.6303E+00 0.1000E+01 -0.6279E+00
+ 0.1000E+01
+ 0.0000E+00 0.1000E+01 -0.6939E-17 0.4259E-01 -0.6495E+00 -0.5581E+00
+ -0.6452E+00
+ 0.0000E+00 -0.3904E+00 -0.4029E+00 -0.1685E+00 -0.9429E+00 0.1000E+01
+ -0.9371E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 -0.2558E+00
+ 0.3308E-03
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ -0.1985E-02
+
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 -0.2558E+00
+ 0.3308E-03
+ 0.0000E+00 -0.4556E-03 -0.4545E-03 0.1000E-02 0.4639E-03 -0.6512E-03
+ 0.4781E-03
+ 0.1000E+01 -0.1105E-01 0.3794E-01 -0.9378E-01 -0.3481E-01 0.4465E+00
+ -0.3602E-01
+ 0.0000E+00 0.1000E+02 -0.6939E-16 0.4259E+00 -0.6495E+01 -0.5581E+01
+ -0.6452E+01
+ 0.0000E+00 -0.3904E-01 -0.4029E-01 -0.1685E-01 -0.9429E-01 0.1000E+00
+ -0.9371E-01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ -0.1985E-02
+ 0.0000E+00 -0.2734E-02 -0.7946E-02 0.6303E-02 0.1000E-01 -0.6279E-02
+ 0.1000E-01
+
+ 0 0 0
diff --git a/TESTING/sbal.in b/TESTING/sbal.in
new file mode 100644
index 0000000..9f7cfd5
--- /dev/null
+++ b/TESTING/sbal.in
@@ -0,0 +1,213 @@
+SBL: Tests SGEBAL
+ 5
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.3000E+01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.4000E+01 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.5000E+01
+
+ 1 1
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.3000E+01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.4000E+01 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.5000E+01
+
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01
+
+ 5
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.1000E+01 0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.0000E+00 0.0000E+00
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.0000E+00
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01
+
+ 1 1
+ 0.5000E+01 0.4000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+ 0.0000E+00 0.4000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.3000E+01 0.2000E+01 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.2000E+01 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
+
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+
+ 5
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.1000E+01 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.1000E+01 0.1000E+01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01
+
+ 1 1
+ 0.1000E+01 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.1000E+01 0.1000E+01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
+
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+ 4
+ 0.0000E+00 0.2000E+01 0.1000E+00 0.0000E+00
+ 0.2000E+01 0.0000E+00 0.0000E+00 0.1000E+00
+ 0.1000E+03 0.0000E+00 0.0000E+00 0.2000E+01
+ 0.0000E+00 0.1000E+03 0.2000E+01 0.0000E+00
+
+ 1 4
+ 0.0000E-03 2.0000E+00 3.2000E+00 0.0000E-03
+ 2.0000E+00 0.0000E-03 0.0000E-03 3.2000E+00
+ 3.1250E+00 0.0000E-03 0.0000E-03 2.0000E+00
+ 0.0000E-03 3.1250E+00 2.0000E+00 0.0000E-03
+
+ 62.5000E-03 62.5000E-03 2.0000E+00 2.0000E+00
+
+ 6
+ 0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1024E+04
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1280E+03
+ 0.0000E+00 0.2000E+01 0.3000E+04 0.0000E+00 0.0000E+00 0.2000E+01
+ 0.1280E+03 0.4000E+01 0.4000E-02 0.5000E+01 0.6000E+03 0.8000E+01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.2000E-02 0.2000E+01
+ 0.8000E+01 0.8192E+04 0.0000E+00 0.0000E+00 0.0000E+00 0.2000E+01
+
+ 4 6
+ 0.5000E+01 0.4000E-02 0.6000E+03 0.1024E+04 0.5000E+00 0.8000E+01
+ 0.0000E+00 0.3000E+04 0.0000E+00 0.0000E+00 0.2500E+00 0.2000E+01
+ 0.0000E+00 0.0000E+00 0.2000E-02 0.0000E+00 0.0000E+00 0.2000E+01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.2000E+01 0.0000E+00 0.1280E+03
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1024E+04
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.6400E+02 0.1024E+04 0.2000E+01
+
+ 0.4000E+01 0.3000E+01 0.5000E+01 0.8000E+01 0.1250E+00 0.1000E+01
+
+ 5
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.8000E+01
+ 0.0000E+00 0.2000E+01 0.8192E+04 0.2000E+01 0.4000E+01
+ 0.2500E-03 0.1250E-03 0.4000E+01 0.0000E+00 0.6400E+02
+ 0.0000E+00 0.2000E+01 0.1024E+04 0.4000E+01 0.8000E+01
+ 0.0000E+00 0.8192E+04 0.0000E+00 0.0000E+00 0.8000E+01
+
+ 1 5
+ 1.0000E+00 0.0000E-03 0.0000E-03 0.0000E-03 250.0000E-03
+ 0.0000E-03 2.0000E+00 1.0240E+03 16.0000E+00 16.0000E+00
+ 256.0000E-03 1.0000E-03 4.0000E+00 0.0000E-03 2.0480E+03
+ 0.0000E-03 250.0000E-03 16.0000E+00 4.0000E+00 4.0000E+00
+ 0.0000E-03 2.0480E+03 0.0000E-03 0.0000E-03 8.0000E+00
+
+ 64.0000E+00 500.0000E-03 62.5000E-03 4.0000E+00 2.0000E+00
+
+ 4
+ 0.1000E+01 0.1000E+07 0.1000E+07 0.1000E+07
+ -0.2000E+07 0.3000E+01 0.2000E-05 0.3000E-05
+ -0.3000E+07 0.0000E+00 0.1000E-05 0.2000E+01
+ 0.1000E+07 0.0000E+00 0.3000E-05 0.4000E+07
+
+ 1 4
+ 1.0000E+00 1.0000E+06 2.0000E+06 1.0000E+06
+ -2.0000E+06 3.0000E+00 4.0000E-06 3.0000E-06
+ -1.5000E+06 0.0000E-03 1.0000E-06 1.0000E+00
+ 1.0000E+06 0.0000E-03 6.0000E-06 4.0000E+06
+
+ 1.0000E+00 1.0000E+00 2.0000E+00 1.0000E+00
+
+ 4
+ 0.1000E+01 0.1000E+05 0.1000E+05 0.1000E+05
+ -0.2000E+05 0.3000E+01 0.2000E-02 0.3000E-02
+ 0.0000E+00 0.2000E+01 0.0000E+00 -0.3000E+05
+ 0.0000E+00 0.0000E+00 0.1000E+05 0.0000E+00
+
+ 1 4
+ 1.0000E+00 10.0000E+03 10.0000E+03 5.0000E+03
+ -20.0000E+03 3.0000E+00 2.0000E-03 1.5000E-03
+ 0.0000E-03 2.0000E+00 0.0000E-03 -15.0000E+03
+ 0.0000E-03 0.0000E-03 20.0000E+03 0.0000E-03
+
+ 1.0000E+00 1.0000E+00 1.0000E+00 500.0000E-03
+
+ 5
+ 0.1000E+01 0.5120E+03 0.4096E+04 3.2768E+04 2.62144E+05
+ 0.8000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.8000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.8000E+01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.8000E+01 0.0000E+00
+
+ 1 5
+ 1.0000E+00 32.0000E+00 32.0000E+00 32.0000E+000 32.0000E+00
+ 128.0000E+00 0.0000E-03 0.0000E-03 0.0000E-003 0.0000E-03
+ 0.0000E-03 64.0000E+00 0.0000E-03 0.0000E-003 0.0000E-03
+ 0.0000E-03 0.0000E-03 64.0000E+00 0.0000E-003 0.0000E-03
+ 0.0000E-03 0.0000E-03 0.0000E-03 64.0000E+000 0.0000E-03
+
+ 256.0000E+00 16.0000E+00 2.0000E+00 250.0000E-03 31.2500E-03
+
+ 6
+ 0.1000E+01 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00
+ 0.1000E+01 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
+
+ 2 5
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
+
+ 0.3000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.4000E+01
+
+ 7
+ 0.6000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00
+ 0.0000E+00 0.4000E+01 0.0000E+00 0.2500E-03 0.1250E-01 0.2000E-01 0.1250E+00
+ 0.1000E+01 0.1280E+03 0.6400E+02 0.0000E+00 0.0000E+00 -0.2000E+01 0.1600E+02
+ 0.0000E+00 1.6384E+04 0.0000E+00 0.1000E+01 -0.4000E+03 0.2560E+03 -0.4000E+04
+ -0.2000E+01 -0.2560E+03 0.0000E+00 0.1250E-01 0.2000E+01 0.2000E+01 0.3200E+02
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.8000E+01 0.0000E+00 0.4000E-02 0.1250E+00 -0.2000E+00 0.3000E+01
+
+ 2 5
+ 6.4000E+01 2.5000E-01 5.00000E-01 0.0000E+00 0.0000E+00 1.0000E+00 -2.0000E+00
+ 0.0000E+00 4.0000E+00 2.00000E+00 4.0960E+00 1.6000E+00 0.0000E+00 1.0240E+01
+ 0.0000E+00 5.0000E-01 3.00000E+00 4.0960E+00 1.0000E+00 0.0000E+00 -6.4000E+00
+ 0.0000E+00 1.0000E+00 -3.90625E+00 1.0000E+00 -3.1250E+00 0.0000E+00 8.0000E+00
+ 0.0000E+00 -2.0000E+00 4.00000E+00 1.6000E+00 2.0000E+00 -8.0000E+00 8.0000E+00
+ 0.0000E+00 0.0000E+00 0.00000E+00 0.0000E+00 0.0000E+00 6.0000E+00 1.0000E+00
+ 0.0000E+00 0.0000E+00 0.00000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+
+ 3.0000E+00 1.953125E-03 3.1250E-02 3.2000E+01 2.5000E-01 1.0000E+00 6.0000E+00
+
+ 5
+ 0.1000E+04 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+06
+ 0.9000E+01 0.0000E+00 0.2000E-03 0.1000E+01 0.3000E+01
+ 0.0000E+00 -0.3000E+03 0.2000E+01 0.1000E+01 0.1000E+01
+ 0.9000E+01 0.2000E-02 0.1000E+01 0.1000E+01 -0.1000E+04
+ 0.6000E+01 0.2000E+03 0.1000E+01 0.6000E+03 0.3000E+01
+
+ 1 5
+ 1.0000E+03 3.1250E-02 3.7500E-01 6.2500E-02 3.90625E+03
+ 5.7600E+02 0.0000E+00 1.6000E-03 1.0000E+00 1.5000E+00
+ 0.0000E+00 -3.7500E+01 2.0000E+00 1.2500E-01 6.2500E-02
+ 5.7600E+02 2.0000E-03 8.0000E+00 1.0000E+00 -5.0000E+02
+ 7.6800E+02 4.0000E+02 1.6000E+01 1.2000E+03 3.0000E+00
+
+ 1.2800E+02 2.0000E+00 1.6000E+01 2.0000E+00 1.0000E+00
+
+ 5
+ 1.0000E+00 1.0000E+15 0.0000E+00 0.0000E+00 0.0000E+00
+ 1.0000E-15 1.0000E+00 1.0000E+15 0.0000E+00 0.0000E+00
+ 0.0000E+00 1.0000E-15 1.0000E+00 1.0000E+15 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E-15 1.0000E+00 1.0000E+15
+ 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E-15 1.0000E+00
+
+ 1 5
+
+ 1.0000000E+00 7.1054273E+00 0.0000000E+00 0.0000000E+00 0.0000000E+00
+ 1.4073749E-01 1.0000000E+00 3.5527136E+00 0.0000000E+00 0.0000000E+00
+ 0.0000000E+00 2.8147498E-01 1.0000000E+00 1.7763568E+00 0.0000000E+00
+ 0.0000000E+00 0.0000000E+00 5.6294996E-01 1.0000000E+00 8.8817841E-01
+ 0.0000000E+00 0.0000000E+00 0.0000000E+00 1.1258999E+00 1.0000000E+00
+
+ 5.0706024E+30 3.6028797E+16 1.2800000E+02 2.2737368E-13 2.0194839E-28
+
+
+ 0
diff --git a/TESTING/sbb.in b/TESTING/sbb.in
new file mode 100644
index 0000000..0f1ee51
--- /dev/null
+++ b/TESTING/sbb.in
@@ -0,0 +1,12 @@
+SBB: Data file for testing banded Singular Value Decomposition routines
+20 Number of values of M
+0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 10 10 16 16 Values of M
+0 1 2 3 0 1 2 3 0 1 2 3 0 1 2 3 10 16 10 16 Values of N
+5 Number of values of K
+0 1 2 3 16 Values of K (band width)
+2 Number of values of NRHS
+1 2 Values of NRHS
+20.0 Threshold value
+F Put T to test the error exits
+1 Code to interpret the seed
+SBB 15
diff --git a/TESTING/sec.in b/TESTING/sec.in
new file mode 100644
index 0000000..441e23d
--- /dev/null
+++ b/TESTING/sec.in
@@ -0,0 +1,950 @@
+SEC Key indicating type of input
+20.0 Threshold value for test ratios
+ 8 2 7
+ 1.0E+00 1.0E+00 1.1E+00 1.3E+00 2.0E+00 3.0E+00 -4.7E+00 3.3E+00
+ -1.0E+00 1.0E+00 3.7E+00 7.9E+00 4.0E+00 5.3E+00 3.3E+00 -9.0E-01
+ 0.0E+00 0.0E+00 2.0E+00 -3.0E+00 3.4E+00 6.5E+00 5.2E+00 1.8E+00
+ 0.0E+00 0.0E+00 4.0E+00 2.0E+00 -5.3E+00 -8.9E+00 -2.0E-01 -5.0E-01
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 4.2E+00 2.0E+00 3.3E+00 2.3E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -3.7E+00 4.2E+00 9.9E+00 8.8E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 9.9E+00 8.8E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -9.9E+00 9.9E+00
+ 8 7 2
+ 1.0E+00 1.0E+00 1.1E+00 1.3E+00 2.0E+00 3.0E+00 -4.7E+00 3.3E+00
+ -1.0E+00 1.0E+00 3.7E+00 7.9E+00 4.0E+00 5.3E+00 3.3E+00 -9.0E-01
+ 0.0E+00 0.0E+00 2.0E+00 -3.0E+00 3.4E+00 6.5E+00 5.2E+00 1.8E+00
+ 0.0E+00 0.0E+00 4.0E+00 2.0E+00 -5.3E+00 -8.9E+00 -2.0E-01 -5.0E-01
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 4.2E+00 2.0E+00 3.3E+00 2.3E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -3.7E+00 4.2E+00 9.9E+00 8.8E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 9.9E+00 8.8E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -9.9E+00 9.9E+00
+ 8 1 7
+ 1.0E+00 1.0E+00 1.1E+00 1.3E+00 2.0E+00 3.0E+00 -4.7E+00 3.3E+00
+ 0.0E+00 1.0E+00 3.7E+00 7.9E+00 4.0E+00 5.3E+00 3.3E+00 -9.0E-01
+ 0.0E+00 0.0E+00 2.0E+00 -3.0E+00 3.4E+00 6.5E+00 5.2E+00 1.8E+00
+ 0.0E+00 0.0E+00 4.0E+00 2.0E+00 -5.3E+00 -8.9E+00 -2.0E-01 -5.0E-01
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 4.2E+00 2.0E+00 3.3E+00 2.3E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 4.2E+00 9.9E+00 8.8E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 9.9E+00 8.8E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -9.9E+00 9.9E+00
+ 8 8 2
+ 1.0E+00 1.0E+00 1.1E+00 1.3E+00 2.0E+00 3.0E+00 -4.7E+00 3.3E+00
+ -1.1E+00 1.0E+00 3.7E+00 7.9E+00 4.0E+00 5.3E+00 3.3E+00 -9.0E-01
+ 0.0E+00 0.0E+00 2.0E+00 -3.0E+00 3.4E+00 6.5E+00 5.2E+00 1.8E+00
+ 0.0E+00 0.0E+00 0.0E+00 2.0E+00 -5.3E+00 -8.9E+00 -2.0E-01 -5.0E-01
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 4.2E+00 2.0E+00 3.3E+00 2.3E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -3.7E+00 4.2E+00 9.9E+00 8.8E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 9.9E+00 8.8E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 9.9E+00
+ 7 2 7
+ 1.1E+00 1.0E-16 2.7E+00 3.3E+00 2.3E+00 3.4E+00 5.6E+00
+ -1.0E-16 1.1E+00 4.2E+00 5.1E+00 -1.0E-01 -2.0E-01 -3.0E-01
+ 0.0E+00 0.0E+00 2.3E+00 1.0E+00 1.0E+02 1.0E+03 1.0E+02
+ 0.0E+00 0.0E+00 0.0E+00 3.9E+00 3.2E+00 6.5E+00 3.2E+00
+ 0.0E+00 0.0E+00 0.0E+00 -9.0E-01 3.9E+00 6.3E+00 3.0E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 6.3E+00 3.0E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -9.0E-01 6.3E+00
+ 7 2 7
+ 1.1E+00 1.0E-16 2.7E+00 3.3E+00 2.3E+00 3.4E+00 5.6E+00
+ -1.0E-16 1.1E+00 4.2E+00 5.1E+00 -1.0E-01 -2.0E-01 -3.0E-01
+ 0.0E+00 0.0E+00 2.3E+00 1.0E+00 1.0E+02 1.0E+03 1.0E+02
+ 0.0E+00 0.0E+00 0.0E+00 3.9E+00 3.2E-15 6.5E+00 3.2E+00
+ 0.0E+00 0.0E+00 0.0E+00 -9.0E-16 3.9E+00 6.3E+00 3.0E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 6.3E+00 3.0E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 6.4E+00
+ 7 2 7
+ 1.1E+00 1.0E-16 2.7E+00 3.3E+00 2.3E+00 3.4E+00 5.6E+00
+ -1.0E-16 1.1E+00 4.2E+00 5.1E+00 -1.0E-01 -2.0E-01 -3.0E-01
+ 0.0E+00 0.0E+00 2.3E+00 1.0E+00 1.0E+02 1.0E+03 1.0E+02
+ 0.0E+00 0.0E+00 0.0E+00 3.9E+00 3.2E-15 6.5E+00 3.2E+00
+ 0.0E+00 0.0E+00 0.0E+00 -9.0E-16 3.9E+00 6.3E+00 3.0E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 6.3E+00 3.0E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -9.0E-21 6.3E+00
+ 7 1 7
+ 1.1E+00 1.0E-16 2.7E+00 3.3E+00 2.3E+00 3.4E+00 5.6E+00
+ 0.0E+00 1.1E+00 4.2E+00 5.1E+00 -1.0E-01 -2.0E-01 -3.0E-01
+ 0.0E+00 0.0E+00 2.3E+00 1.0E+00 1.0E+02 1.0E+03 1.0E+02
+ 0.0E+00 0.0E+00 0.0E+00 3.9E+00 3.2E-15 6.5E+00 3.2E+00
+ 0.0E+00 0.0E+00 0.0E+00 -9.0E-16 3.9E+00 6.3E+00 3.0E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 6.3E+00 3.0E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -9.0E-21 6.3E+00
+ 7 1 7
+ 1.1E+00 -1.1E+00 2.7E+00 3.3E+00 2.3E+00 3.4E+00 5.6E+00
+ 2.3E+00 1.1E+00 4.2E+00 5.1E+00 -1.0E-01 -2.0E-01 -3.0E-01
+ 0.0E+00 0.0E+00 2.3E+00 1.0E+00 1.0E+02 1.0E+03 1.0E+02
+ 0.0E+00 0.0E+00 0.0E+00 3.9E+00 3.2E+00 6.5E+00 3.2E+00
+ 0.0E+00 0.0E+00 0.0E+00 -9.0E-21 3.9E+00 6.3E+00 3.0E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 6.3E+00 3.0E-20
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -9.0E-21 6.3E+00
+ 7 7 2
+ 6.3E+00 3.0E+00 2.7E+00 3.3E+00 2.3E+00 3.4E+00 5.6E+00
+ -9.0E-01 6.3E+00 4.2E+00 5.1E+00 -1.0E-01 -2.0E-01 -3.0E-01
+ 0.0E+00 0.0E+00 2.3E+00 1.0E+00 1.0E+02 1.0E+03 1.0E+02
+ 0.0E+00 0.0E+00 0.0E+00 3.9E+00 3.2E+00 6.5E+00 3.2E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 3.8E+00 6.3E+00 3.0E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 1.1E+00 1.4E-20
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -1.6E-20 1.1E+00
+ 7 7 2
+ 6.3E+00 3.0E+00 2.7E+00 3.3E+00 2.3E+00 3.4E+00 5.6E+00
+ -9.0E-01 6.3E+00 4.2E+00 5.1E+00 -1.0E-01 -2.0E-01 -3.0E-01
+ 0.0E+00 0.0E+00 2.3E+00 1.0E+00 1.0E+02 1.0E+03 1.0E+02
+ 0.0E+00 0.0E+00 0.0E+00 3.9E+00 3.2E+00 6.5E+00 3.2E+00
+ 0.0E+00 0.0E+00 0.0E+00 -9.0E-01 3.9E+00 6.3E+00 3.0E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 1.1E+00 1.4E-20
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -1.6E-20 1.1E+00
+ 7 7 2
+ 1.1E+00 1.0E-16 2.7E+00 3.3E+00 2.3E+00 3.4E+00 5.6E+00
+ -1.0E-16 1.1E+00 4.2E+00 5.1E+00 -1.0E-01 -2.0E-01 -3.0E-01
+ 0.0E+00 0.0E+00 2.3E+00 1.0E+00 1.0E+02 1.0E+03 1.0E+02
+ 0.0E+00 0.0E+00 0.0E+00 3.9E+00 3.2E-15 6.5E+00 3.2E+00
+ 0.0E+00 0.0E+00 0.0E+00 -9.0E-16 3.9E+00 6.3E+00 3.0E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 6.3E+00 3.0E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -9.0E-21 6.3E+00
+ 7 7 1
+ 1.1E+00 1.0E-16 2.7E+06 3.3E+00 2.3E+00 3.4E+00 5.6E+00
+ 0.0E+00 1.1E+00 4.2E+06 5.1E+00 -1.0E-01 -2.0E-01 -3.0E-01
+ 0.0E+00 0.0E+00 2.3E+00 1.0E+07 1.0E+08 1.0E+03 1.0E+02
+ 0.0E+00 0.0E+00 0.0E+00 3.9E+00 3.2E-15 6.5E+04 3.2E+00
+ 0.0E+00 0.0E+00 0.0E+00 -9.0E-16 3.9E+00 6.3E+03 3.0E+05
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 6.3E+00 3.0E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -9.0E-21 6.3E+00
+ 8 8 1
+ 1.1E+00 -1.0E-16 2.7E+06 2.3E+04 3.3E+00 2.3E+00 3.4E+00 5.6E+00
+ 1.0E-16 1.1E+00 4.2E+06 -1.0E-01 5.1E+00 -1.0E-01 -2.0E-01 -3.0E-01
+ 0.0E+00 0.0E+00 2.3E+00 1.1E-16 1.0E+07 1.0E+08 1.0E+03 1.0E+02
+ 0.0E+00 0.0E+00 -1.1E-13 2.3E+00 1.0E+07 1.0E+08 1.0E+03 1.0E+02
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 3.9E+00 3.2E-15 6.5E+04 3.2E+00
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -9.0E-16 3.9E+00 6.3E+03 3.0E+05
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 6.3E+00 3.0E-20
+ 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 0.0E+00 -9.0E-21 6.3E+00
+ 0 0 0
+ 1
+ 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 1
+ 1.0000E+00
+ 1.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 2
+ 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 2
+ 3.0000E+00 2.0000E+00
+ 2.0000E+00 3.0000E+00
+ 1.0000E+00 0.0000E+00 1.0000E+00 4.0000E+00
+ 5.0000E+00 0.0000E+00 1.0000E+00 4.0000E+00
+ 2
+ 3.0000E+00 -2.0000E+00
+ 2.0000E+00 3.0000E+00
+ 3.0000E+00 2.0000E+00 1.0000E+00 4.0000E+00
+ 3.0000E+00 -2.0000E+00 1.0000E+00 4.0000E+00
+ 6
+ 1.0000E-07 -1.0000E-07 1.0000E+00 1.1000E+00 2.3000E+00 3.7000E+00
+ 3.0000E-07 1.0000E-07 1.0000E+00 1.0000E+00 -1.3000E+00 -7.7000E+00
+ 0.0000E+00 0.0000E+00 3.0000E-07 1.0000E-07 2.2000E+00 3.3000E+00
+ 0.0000E+00 0.0000E+00 -1.0000E-07 3.0000E-07 1.8000E+00 1.6000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 4.0000E-06 5.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 3.0000E+00 4.0000E-06
+ -3.8730E+00 0.0000E+00 6.9855E-01 2.2823E+00
+ 1.0000E-07 1.7321E-07 9.7611E-08 5.0060E-14
+ 1.0000E-07 -1.7321E-07 9.7611E-08 5.0060E-14
+ 3.0000E-07 1.0000E-07 1.0000E-07 9.4094E-14
+ 3.0000E-07 -1.0000E-07 1.0000E-07 9.4094E-14
+ 3.8730E+00 0.0000E+00 4.0659E-01 1.5283E+00
+ 4
+ 7.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00
+ -1.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00
+ -1.0000E+00 1.0000E+00 5.0000E+00 -3.0000E+00
+ 1.0000E+00 -1.0000E+00 3.0000E+00 3.0000E+00
+ 3.9603E+00 4.0425E-02 1.1244E-05 3.1179E-05
+ 3.9603E+00 -4.0425E-02 1.1244E-05 3.1179E-05
+ 4.0397E+00 3.8854E-02 1.0807E-05 2.9981E-05
+ 4.0397E+00 -3.8854E-02 1.0807E-05 2.9981E-05
+ 5
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
+ 0.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
+ 0.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
+ 0.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
+ 0.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
+ 5
+ 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
+ 1.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
+ 1.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
+ 1.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
+ 1.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
+ 1.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
+ 6
+ 1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 6
+ 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 6
+ 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 2.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 3.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 4.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 5.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 6.0000E+00
+ 1.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 2.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 3.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 4.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 5.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 6.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 4
+ 9.4480E-01 6.7670E-01 6.9080E-01 5.9650E-01
+ 5.8760E-01 8.6420E-01 6.7690E-01 7.2600E-02
+ 7.2560E-01 1.9430E-01 9.6870E-01 2.8310E-01
+ 2.8490E-01 5.8000E-02 4.8450E-01 7.3610E-01
+ 2.4326E-01 2.1409E-01 8.7105E-01 3.5073E-01
+ 2.4326E-01 -2.1409E-01 8.7105E-01 3.5073E-01
+ 7.4091E-01 0.0000E+00 9.8194E-01 4.6989E-01
+ 2.2864E+00 0.0000E+00 9.7723E-01 1.5455E+00
+ 6
+ 5.0410E-01 6.6520E-01 7.7190E-01 6.3870E-01 5.9550E-01 6.1310E-01
+ 1.5740E-01 3.7340E-01 5.9840E-01 1.5470E-01 9.4270E-01 6.5900E-02
+ 4.4170E-01 7.2300E-02 1.5440E-01 5.4920E-01 8.7000E-03 3.0040E-01
+ 2.0080E-01 6.0800E-01 3.0340E-01 8.4390E-01 2.3900E-01 5.7680E-01
+ 9.3610E-01 7.4130E-01 1.4440E-01 1.7860E-01 1.4280E-01 7.2630E-01
+ 5.5990E-01 9.3360E-01 7.8000E-02 4.0930E-01 6.7140E-01 5.6170E-01
+ -5.2278E-01 0.0000E+00 2.7888E-01 1.1793E-01
+ -3.5380E-01 0.0000E+00 3.5427E-01 6.8911E-02
+ -8.0876E-03 0.0000E+00 3.4558E-01 1.3489E-01
+ 3.4760E-01 3.0525E-01 5.4661E-01 1.7729E-01
+ 3.4760E-01 -3.0525E-01 5.4661E-01 1.7729E-01
+ 2.7698E+00 0.0000E+00 9.6635E-01 1.8270E+00
+ 5
+ 2.0000E-03 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 1.0000E-03 1.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 -1.0000E-03 1.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 -2.0000E-03 1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ -2.0000E-03 0.0000E+00 2.4000E-11 2.3952E-11
+ -1.0000E-03 0.0000E+00 6.0000E-12 5.9940E-12
+ 0.0000E+00 0.0000E+00 4.0000E-12 3.9920E-12
+ 1.0000E-03 0.0000E+00 6.0000E-12 5.9940E-12
+ 2.0000E-03 0.0000E+00 2.4000E-11 2.3952E-11
+ 10
+ 4.8630E-01 9.1260E-01 2.1900E-02 6.0110E-01 1.4050E-01 2.0840E-01
+ 8.2640E-01 8.4410E-01 3.1420E-01 8.6750E-01
+ 7.1500E-01 2.6480E-01 8.8510E-01 2.6150E-01 5.9520E-01 4.7800E-01
+ 7.6730E-01 4.6110E-01 5.7320E-01 7.7000E-03
+ 2.1210E-01 5.5080E-01 5.2350E-01 3.0810E-01 6.6020E-01 2.8900E-01
+ 2.3140E-01 2.2790E-01 9.6600E-02 1.0910E-01
+ 7.1510E-01 8.5790E-01 5.7710E-01 5.1140E-01 1.9010E-01 9.0810E-01
+ 6.0090E-01 7.1980E-01 1.0640E-01 8.6840E-01
+ 5.6800E-01 2.8100E-02 4.0140E-01 6.3150E-01 1.1480E-01 7.5800E-02
+ 9.4230E-01 7.2030E-01 3.6850E-01 1.7430E-01
+ 7.7210E-01 3.0280E-01 5.5640E-01 9.9980E-01 3.6520E-01 5.2580E-01
+ 3.7030E-01 6.7790E-01 9.9350E-01 5.0270E-01
+ 7.3960E-01 4.5600E-02 7.4740E-01 9.2880E-01 2.2000E-03 8.2600E-02
+ 3.6340E-01 4.9120E-01 9.4050E-01 3.8910E-01
+ 5.6370E-01 8.5540E-01 3.2100E-02 2.6380E-01 3.6090E-01 6.4970E-01
+ 8.4690E-01 9.3500E-01 3.7000E-02 2.9170E-01
+ 8.6560E-01 6.3270E-01 3.5620E-01 6.3560E-01 2.7360E-01 6.5120E-01
+ 1.0220E-01 2.8880E-01 5.7620E-01 4.0790E-01
+ 5.3320E-01 4.1210E-01 7.2870E-01 2.3110E-01 6.8300E-01 7.3860E-01
+ 8.1800E-01 9.8150E-01 8.0550E-01 2.5660E-01
+ -4.6121E-01 7.2657E-01 4.7781E-01 1.5842E-01
+ -4.6121E-01 -7.2657E-01 4.7781E-01 1.5842E-01
+ -4.5164E-01 0.0000E+00 4.6034E-01 1.9931E-01
+ -1.4922E-01 4.8255E-01 4.7500E-01 9.1686E-02
+ -1.4922E-01 -4.8255E-01 4.7500E-01 9.1686E-02
+ 3.3062E-02 0.0000E+00 2.9729E-01 8.2469E-02
+ 3.0849E-01 1.1953E-01 4.2947E-01 3.9688E-02
+ 3.0849E-01 -1.1953E-01 4.2947E-01 3.9688E-02
+ 5.4509E-01 0.0000E+00 7.0777E-01 1.5033E-01
+ 5.0352E+00 0.0000E+00 9.7257E-01 3.5548E+00
+ 4
+ -3.8730E-01 3.6560E-01 3.1200E-02 -5.8340E-01
+ 5.5230E-01 -1.1854E+00 9.8330E-01 7.6670E-01
+ 1.6746E+00 -1.9900E-02 -1.8293E+00 5.7180E-01
+ -5.2500E-01 3.5340E-01 -2.7210E-01 -8.8300E-02
+ -1.8952E+00 7.5059E-01 8.1913E-01 7.7090E-01
+ -1.8952E+00 -7.5059E-01 8.1913E-01 7.7090E-01
+ -9.5162E-02 0.0000E+00 8.0499E-01 4.9037E-01
+ 3.9520E-01 0.0000E+00 9.8222E-01 4.9037E-01
+ 6
+ -1.0777E+00 1.7027E+00 2.6510E-01 8.5160E-01 1.0121E+00 2.5710E-01
+ -1.3400E-02 3.9030E-01 -1.2680E+00 2.7530E-01 -3.2350E-01 -1.3844E+00
+ 1.5230E-01 3.0680E-01 8.7330E-01 -3.3410E-01 -4.8310E-01 -1.5416E+00
+ 1.4470E-01 -6.0570E-01 3.1900E-02 -1.0905E+00 -8.3700E-02 6.2410E-01
+ -7.6510E-01 -1.7889E+00 -1.5069E+00 -6.0210E-01 5.2170E-01 6.4700E-01
+ 8.1940E-01 2.1100E-01 5.4320E-01 7.5610E-01 1.7130E-01 5.5400E-01
+ -1.7029E+00 0.0000E+00 6.7909E-01 6.7220E-01
+ -1.0307E+00 0.0000E+00 7.2671E-01 2.0436E-01
+ 2.8487E-01 1.2101E+00 3.9757E-01 4.9797E-01
+ 2.8487E-01 -1.2101E+00 3.9757E-01 4.9797E-01
+ 1.1675E+00 4.6631E-01 4.2334E-01 1.9048E-01
+ 1.1675E+00 -4.6631E-01 4.2334E-01 1.9048E-01
+ 10
+ -1.0639E+00 1.6120E-01 1.5620E-01 3.4360E-01 -6.7480E-01 1.6598E+00
+ 6.4650E-01 -7.8630E-01 -2.6100E-01 7.0190E-01
+ -8.4400E-01 -2.2439E+00 1.8800E+00 -1.0005E+00 7.4500E-02 -1.6156E+00
+ 2.8220E-01 8.5600E-01 1.3497E+00 -1.5883E+00
+ 1.5988E+00 1.1758E+00 1.2398E+00 1.1173E+00 2.1500E-01 4.3140E-01
+ 1.8500E-01 7.9470E-01 6.6260E-01 8.6460E-01
+ -2.2960E-01 1.2442E+00 2.3242E+00 -5.0690E-01 -7.5160E-01 -5.4370E-01
+ -2.5990E-01 1.2830E+00 -1.1067E+00 -1.1150E-01
+ -3.6040E-01 4.0420E-01 6.1240E-01 -1.2164E+00 -9.4650E-01 -3.1460E-01
+ 1.8310E-01 7.3710E-01 1.4278E+00 2.9220E-01
+ 4.6150E-01 3.8740E-01 -4.2900E-02 -9.3600E-01 7.1160E-01 -8.2590E-01
+ -1.7640E+00 -9.4660E-01 1.8202E+00 -2.5480E-01
+ 1.2934E+00 -9.7550E-01 6.7480E-01 -1.0481E+00 -1.8442E+00 -5.4600E-02
+ 7.4050E-01 6.1000E-03 1.2430E+00 -1.8490E-01
+ -3.4710E-01 -9.5800E-01 1.6530E-01 9.1300E-02 -5.2010E-01 -1.1832E+00
+ 8.5410E-01 -2.3200E-01 -1.6155E+00 5.5180E-01
+ 1.0190E+00 -6.8240E-01 8.0850E-01 2.5950E-01 -3.7580E-01 -1.8825E+00
+ 1.6473E+00 -6.5920E-01 8.0250E-01 -4.9000E-03
+ 1.2670E+00 -4.2400E-02 8.9570E-01 -1.6770E-01 1.4620E-01 9.8800E-01
+ -2.3170E-01 -1.4483E+00 -5.8200E-02 1.9700E-02
+ -2.6992E+00 9.0387E-01 6.4005E-01 4.1615E-01
+ -2.6992E+00 -9.0387E-01 6.4005E-01 4.1615E-01
+ -2.4366E+00 0.0000E+00 6.9083E-01 2.5476E-01
+ -1.2882E+00 8.8930E-01 5.3435E-01 6.0878E-01
+ -1.2882E+00 -8.8930E-01 5.3435E-01 6.0878E-01
+ 9.0275E-01 0.0000E+00 2.9802E-01 4.7530E-01
+ 9.0442E-01 2.5661E+00 7.3193E-01 6.2016E-01
+ 9.0442E-01 -2.5661E+00 7.3193E-01 6.2016E-01
+ 1.6774E+00 0.0000E+00 3.0743E-01 4.1726E-01
+ 3.0060E+00 0.0000E+00 8.5623E-01 4.3175E-01
+ 4
+ -1.2298E+00 -2.3142E+00 -6.9800E-02 1.0523E+00
+ 2.0390E-01 -1.2298E+00 8.0500E-02 9.7860E-01
+ 0.0000E+00 0.0000E+00 2.5600E-01 -8.9100E-01
+ 0.0000E+00 0.0000E+00 2.7480E-01 2.5600E-01
+ -1.2298E+00 6.8692E-01 4.7136E-01 7.1772E-01
+ -1.2298E+00 -6.8692E-01 4.7136E-01 7.1772E-01
+ 2.5600E-01 4.9482E-01 8.0960E-01 5.1408E-01
+ 2.5600E-01 -4.9482E-01 8.0960E-01 5.1408E-01
+ 6
+ 5.9930E-01 1.9372E+00 -1.6160E-01 -1.4602E+00 6.0180E-01 2.7120E+00
+ -2.2049E+00 5.9930E-01 -1.0679E+00 1.9405E+00 -1.4400E+00 -2.2110E-01
+ 0.0000E+00 0.0000E+00 -2.4567E+00 -6.8650E-01 -1.9101E+00 6.4960E-01
+ 0.0000E+00 0.0000E+00 0.0000E+00 7.3620E-01 3.9700E-01 -1.5190E-01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 -1.0034E+00 1.1954E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 -1.3400E-01 -1.0034E+00
+ -2.4567E+00 0.0000E+00 4.7091E-01 8.5788E-01
+ -1.0034E+00 4.0023E-01 3.6889E-01 1.8909E-01
+ -1.0034E+00 -4.0023E-01 3.6889E-01 1.8909E-01
+ 5.9930E-01 2.0667E+00 5.8849E-01 1.3299E+00
+ 5.9930E-01 -2.0667E+00 5.8849E-01 1.3299E+00
+ 7.3620E-01 0.0000E+00 6.0845E-01 9.6725E-01
+ 4
+ 1.0000E-04 1.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 -1.0000E-04 1.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E-02 1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 -5.0000E-03
+ -5.0000E-03 0.0000E+00 3.7485E-07 3.6932E-07
+ -1.0000E-04 0.0000E+00 9.8979E-09 9.8493E-09
+ 1.0000E-04 0.0000E+00 1.0098E-08 1.0046E-08
+ 1.0000E-02 0.0000E+00 1.4996E-06 1.4773E-06
+ 3
+ 2.0000E-06 1.0000E+00 -2.0000E+00
+ 1.0000E-06 -2.0000E+00 4.0000E+00
+ 0.0000E+00 1.0000E+00 -2.0000E+00
+ -4.0000E+00 0.0000E+00 7.3030E-01 4.0000E+00
+ 0.0000E+00 0.0000E+00 7.2801E-01 1.3726E-06
+ 2.2096E-06 0.0000E+00 8.2763E-01 2.2096E-06
+ 6
+ 2.4080E-01 6.5530E-01 9.1660E-01 5.0300E-02 2.8490E-01 2.4080E-01
+ 6.9070E-01 9.7000E-01 1.4020E-01 5.7820E-01 6.7670E-01 6.9070E-01
+ 1.0620E-01 3.8000E-02 7.0540E-01 2.4320E-01 8.6420E-01 1.0620E-01
+ 2.6400E-01 9.8800E-02 1.7800E-02 9.4480E-01 1.9430E-01 2.6400E-01
+ 7.0340E-01 2.5600E-01 2.6110E-01 5.8760E-01 5.8000E-02 7.0340E-01
+ 4.0210E-01 5.5980E-01 1.3580E-01 7.2560E-01 6.9080E-01 4.0210E-01
+ -3.4008E-01 3.2133E-01 5.7839E-01 2.0310E-01
+ -3.4008E-01 -3.2133E-01 5.7839E-01 2.0310E-01
+ -1.6998E-07 0.0000E+00 4.9641E-01 2.1574E-01
+ 7.2311E-01 5.9389E-02 7.0039E-01 4.1945E-02
+ 7.2311E-01 -5.9389E-02 7.0039E-01 4.1945E-02
+ 2.5551E+00 0.0000E+00 9.2518E-01 1.7390E+00
+ 6
+ 3.4800E+00 -2.9900E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ -4.9000E-01 2.4800E+00 -1.9900E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 -4.9000E-01 1.4800E+00 -9.9000E-01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 -9.9000E-01 1.4800E+00 -4.9000E-01 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 -1.9900E+00 2.4800E+00 -4.9000E-01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 -2.9900E+00 3.4800E+00
+ 1.3034E-02 0.0000E+00 7.5301E-01 6.0533E-01
+ 1.1294E+00 0.0000E+00 6.0479E-01 2.8613E-01
+ 2.0644E+00 0.0000E+00 5.4665E-01 1.7376E-01
+ 2.8388E+00 0.0000E+00 4.2771E-01 3.0915E-01
+ 4.3726E+00 0.0000E+00 6.6370E-01 7.6443E-02
+ 4.4618E+00 0.0000E+00 5.7388E-01 8.9227E-02
+ 6
+ 0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
+ 1.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00
+ -1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ -1.7321E+00 0.0000E+00 8.6603E-01 7.2597E-01
+ -1.0000E+00 0.0000E+00 5.0000E-01 2.6417E-01
+ 0.0000E+00 0.0000E+00 2.9582E-31 1.4600E-07
+ 0.0000E+00 0.0000E+00 2.9582E-31 6.2446E-08
+ 1.0000E+00 0.0000E+00 5.0000E-01 2.6417E-01
+ 1.7321E+00 0.0000E+00 8.6603E-01 3.7896E-01
+ 6
+ 3.5345E-01 9.3023E-01 7.4679E-02 -1.0059E-02 4.6698E-02 -4.3480E-02
+ 9.3545E-01 -3.5147E-01 -2.8216E-02 3.8008E-03 -1.7644E-02 1.6428E-02
+ 0.0000E+00 -1.0555E-01 7.5211E-01 -1.0131E-01 4.7030E-01 -4.3789E-01
+ 0.0000E+00 0.0000E+00 6.5419E-01 1.1779E-01 -5.4678E-01 5.0911E-01
+ 0.0000E+00 0.0000E+00 0.0000E+00 -9.8780E-01 -1.1398E-01 1.0612E-01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 6.8144E-01 7.3187E-01
+ -9.9980E-01 1.9645E-02 1.0000E+00 3.9290E-02
+ -9.9980E-01 -1.9645E-02 1.0000E+00 3.9290E-02
+ 7.4539E-01 6.6663E-01 1.0000E+00 5.2120E-01
+ 7.4539E-01 -6.6663E-01 1.0000E+00 5.2120E-01
+ 9.9929E-01 3.7545E-02 1.0000E+00 7.5089E-02
+ 9.9929E-01 -3.7545E-02 1.0000E+00 7.5089E-02
+ 6
+ 1.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00
+ 5.0000E-01 3.3330E-01 2.5000E-01 2.0000E-01 1.6670E-01 1.4290E-01
+ 3.3330E-01 2.5000E-01 2.0000E-01 1.6670E-01 1.4290E-01 1.2500E-01
+ 2.5000E-01 2.0000E-01 1.6670E-01 1.4290E-01 1.2500E-01 1.1110E-01
+ 2.0000E-01 1.6670E-01 1.4290E-01 1.2500E-01 1.1110E-01 1.0000E-01
+ 1.6670E-01 1.4290E-01 1.2500E-01 1.1110E-01 1.0000E-01 9.0900E-02
+ -2.2135E-01 0.0000E+00 4.0841E-01 1.6605E-01
+ -3.1956E-02 0.0000E+00 3.7927E-01 3.0531E-02
+ -8.5031E-04 0.0000E+00 6.2793E-01 7.8195E-04
+ -5.8584E-05 0.0000E+00 8.1156E-01 7.2478E-05
+ 1.3895E-05 0.0000E+00 9.7087E-01 7.2478E-05
+ 2.1324E+00 0.0000E+00 8.4325E-01 1.8048E+00
+ 12
+ 1.2000E+01 1.1000E+01 1.0000E+01 9.0000E+00 8.0000E+00 7.0000E+00
+ 6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
+ 1.1000E+01 1.1000E+01 1.0000E+01 9.0000E+00 8.0000E+00 7.0000E+00
+ 6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
+ 0.0000E+00 1.0000E+01 1.0000E+01 9.0000E+00 8.0000E+00 7.0000E+00
+ 6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
+ 0.0000E+00 0.0000E+00 9.0000E+00 9.0000E+00 8.0000E+00 7.0000E+00
+ 6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 8.0000E+00 8.0000E+00 7.0000E+00
+ 6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 7.0000E+00 7.0000E+00
+ 6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 6.0000E+00
+ 6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 5.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 4.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 3.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 2.0000E+00 2.0000E+00 1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ -2.8234E-02 0.0000E+00 2.8690E-06 3.2094E-06
+ 7.2587E-02 9.0746E-02 1.5885E-06 9.9934E-07
+ 7.2587E-02 -9.0746E-02 1.5885E-06 9.9934E-07
+ 1.8533E-01 0.0000E+00 6.5757E-07 7.8673E-07
+ 2.8828E-01 0.0000E+00 1.8324E-06 2.0796E-06
+ 6.4315E-01 0.0000E+00 6.8640E-05 6.1058E-05
+ 1.5539E+00 0.0000E+00 4.6255E-03 6.4028E-03
+ 3.5119E+00 0.0000E+00 1.4447E-01 1.9470E-01
+ 6.9615E+00 0.0000E+00 5.8447E-01 1.2016E+00
+ 1.2311E+01 0.0000E+00 3.1823E-01 1.4273E+00
+ 2.0199E+01 0.0000E+00 2.0079E-01 2.4358E+00
+ 3.2229E+01 0.0000E+00 3.0424E-01 5.6865E+00
+ 6
+ 0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 5.0000E+00 0.0000E+00 2.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 4.0000E+00 0.0000E+00 3.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 3.0000E+00 0.0000E+00 4.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 2.0000E+00 0.0000E+00 5.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ -5.0000E+00 0.0000E+00 8.2295E-01 1.2318E+00
+ -3.0000E+00 0.0000E+00 7.2281E-01 7.5970E-01
+ -1.0000E+00 0.0000E+00 6.2854E-01 6.9666E-01
+ 1.0000E+00 0.0000E+00 6.2854E-01 6.9666E-01
+ 3.0000E+00 0.0000E+00 7.2281E-01 7.5970E-01
+ 5.0000E+00 0.0000E+00 8.2295E-01 1.2318E+00
+ 6
+ 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
+ -1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
+ -1.0000E+00 -1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
+ -1.0000E+00 -1.0000E+00 -1.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00
+ -1.0000E+00 -1.0000E+00 -1.0000E+00 -1.0000E+00 1.0000E+00 1.0000E+00
+ -1.0000E+00 -1.0000E+00 -1.0000E+00 -1.0000E+00 -1.0000E+00 1.0000E+00
+ 8.0298E-02 2.4187E+00 8.9968E-01 1.5236E+00
+ 8.0298E-02 -2.4187E+00 8.9968E-01 1.5236E+00
+ 1.4415E+00 6.2850E-01 9.6734E-01 4.2793E-01
+ 1.4415E+00 -6.2850E-01 9.6734E-01 4.2793E-01
+ 1.4782E+00 1.5638E-01 9.7605E-01 2.2005E-01
+ 1.4782E+00 -1.5638E-01 9.7605E-01 2.2005E-01
+ 6
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
+ 1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 0.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00
+ 1.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00
+ 1.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00
+ 0.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00
+ -3.5343E-02 7.4812E-01 3.9345E-01 1.8415E-01
+ -3.5343E-02 -7.4812E-01 3.9345E-01 1.8415E-01
+ 5.8440E-07 0.0000E+00 2.8868E-01 1.7003E-01
+ 6.4087E-01 7.2822E-01 4.5013E-01 2.9425E-01
+ 6.4087E-01 -7.2822E-01 4.5013E-01 2.9425E-01
+ 3.7889E+00 0.0000E+00 9.6305E-01 2.2469E+00
+ 6
+ 1.0000E+00 4.0112E+00 1.2750E+01 4.0213E+01 1.2656E+02 3.9788E+02
+ 1.0000E+00 3.2616E+00 1.0629E+01 3.3342E+01 1.0479E+02 3.2936E+02
+ 1.0000E+00 3.1500E+00 9.8006E+00 3.0630E+01 9.6164E+01 3.0215E+02
+ 1.0000E+00 3.2755E+00 1.0420E+01 3.2957E+01 1.0374E+02 3.2616E+02
+ 1.0000E+00 2.8214E+00 8.4558E+00 2.6296E+01 8.2443E+01 2.5893E+02
+ 1.0000E+00 2.6406E+00 8.3565E+00 2.6558E+01 8.3558E+01 2.6268E+02
+ -5.3220E-01 0.0000E+00 5.3287E-01 3.8557E-01
+ -1.0118E-01 0.0000E+00 7.2342E-01 9.1303E-02
+ -9.8749E-03 0.0000E+00 7.3708E-01 1.1032E-02
+ 2.9861E-03 0.0000E+00 4.4610E-01 1.2861E-02
+ 1.8075E-01 0.0000E+00 4.2881E-01 1.7378E-01
+ 3.9260E+02 0.0000E+00 4.8057E-01 3.9201E+02
+ 8
+ 0.0000E+00 4.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00
+ 1.0000E+00 0.0000E+00 4.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00
+ 0.0000E+00 1.0000E+00 0.0000E+00 4.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 4.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 4.0000E+00
+ 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 4.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
+ 0.0000E+00 4.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 1.0000E+00 0.0000E+00
+ -3.7588E+00 0.0000E+00 1.2253E-01 1.2978E-01
+ -3.0642E+00 0.0000E+00 4.9811E-02 8.0162E-02
+ -2.0000E+00 0.0000E+00 3.6914E-02 8.2942E-02
+ -6.9459E-01 0.0000E+00 3.3328E-02 1.3738E-01
+ 6.9459E-01 0.0000E+00 3.3328E-02 1.1171E-01
+ 2.0000E+00 0.0000E+00 3.6914E-02 7.2156E-02
+ 3.0642E+00 0.0000E+00 4.9811E-02 6.8352E-02
+ 3.7588E+00 0.0000E+00 1.2253E-01 1.1527E-01
+ 6
+ 8.5000E+00 -1.0472E+01 2.8944E+00 -1.5279E+00 1.1056E+00 -5.0000E-01
+ 2.6180E+00 -1.1708E+00 -2.0000E+00 8.9440E-01 -6.1800E-01 2.7640E-01
+ -7.2360E-01 2.0000E+00 -1.7080E-01 -1.6180E+00 8.9440E-01 -3.8200E-01
+ 3.8200E-01 -8.9440E-01 1.6180E+00 1.7080E-01 -2.0000E+00 7.2360E-01
+ -2.7640E-01 6.1800E-01 -8.9440E-01 2.0000E+00 1.1708E+00 -2.6180E+00
+ 5.0000E-01 -1.1056E+00 1.5279E+00 -2.8944E+00 1.0472E+01 -8.5000E+00
+ -5.8930E-01 0.0000E+00 1.7357E-04 2.8157E-04
+ -2.7627E-01 4.9852E-01 1.7486E-04 1.6704E-04
+ -2.7627E-01 -4.9852E-01 1.7486E-04 1.6704E-04
+ 2.7509E-01 5.0059E-01 1.7635E-04 1.6828E-04
+ 2.7509E-01 -5.0059E-01 1.7635E-04 1.6828E-04
+ 5.9167E-01 0.0000E+00 1.7623E-04 3.0778E-04
+ 4
+ 4.0000E+00 -5.0000E+00 0.0000E+00 3.0000E+00
+ 0.0000E+00 4.0000E+00 -3.0000E+00 -5.0000E+00
+ 5.0000E+00 -3.0000E+00 4.0000E+00 0.0000E+00
+ 3.0000E+00 0.0000E+00 5.0000E+00 4.0000E+00
+ 1.0000E+00 5.0000E+00 1.0000E+00 4.3333E+00
+ 1.0000E+00 -5.0000E+00 1.0000E+00 4.3333E+00
+ 2.0000E+00 0.0000E+00 1.0000E+00 4.3333E+00
+ 1.2000E+01 0.0000E+00 1.0000E+00 9.1250E+00
+ 5
+ 1.5000E+01 1.1000E+01 6.0000E+00 -9.0000E+00 -1.5000E+01
+ 1.0000E+00 3.0000E+00 9.0000E+00 -3.0000E+00 -8.0000E+00
+ 7.0000E+00 6.0000E+00 6.0000E+00 -3.0000E+00 -1.1000E+01
+ 7.0000E+00 7.0000E+00 5.0000E+00 -3.0000E+00 -1.1000E+01
+ 1.7000E+01 1.2000E+01 5.0000E+00 -1.0000E+01 -1.6000E+01
+ -9.9999E-01 0.0000E+00 2.1768E-01 5.2263E-01
+ 1.4980E+00 3.5752E+00 3.9966E-04 6.0947E-03
+ 1.4980E+00 -3.5752E+00 3.9966E-04 6.0947E-03
+ 1.5020E+00 3.5662E+00 3.9976E-04 6.0960E-03
+ 1.5020E+00 -3.5662E+00 3.9976E-04 6.0960E-03
+ 6
+ -9.0000E+00 2.1000E+01 -1.5000E+01 4.0000E+00 2.0000E+00 0.0000E+00
+ -1.0000E+01 2.1000E+01 -1.4000E+01 4.0000E+00 2.0000E+00 0.0000E+00
+ -8.0000E+00 1.6000E+01 -1.1000E+01 4.0000E+00 2.0000E+00 0.0000E+00
+ -6.0000E+00 1.2000E+01 -9.0000E+00 3.0000E+00 3.0000E+00 0.0000E+00
+ -4.0000E+00 8.0000E+00 -6.0000E+00 0.0000E+00 5.0000E+00 0.0000E+00
+ -2.0000E+00 4.0000E+00 -3.0000E+00 0.0000E+00 1.0000E+00 3.0000E+00
+ 1.0000E+00 6.2559E-04 6.4875E-05 5.0367E-04
+ 1.0000E+00 -6.2559E-04 6.4875E-05 5.0367E-04
+ 2.0000E+00 1.0001E+00 5.4076E-02 2.3507E-01
+ 2.0000E+00 -1.0001E+00 5.4076E-02 2.3507E-01
+ 3.0000E+00 0.0000E+00 8.6149E-01 5.4838E-07
+ 3.0000E+00 0.0000E+00 1.2425E-01 1.2770E-06
+ 10
+ 1.0000E+00 1.0000E+00 1.0000E+00 -2.0000E+00 1.0000E+00 -1.0000E+00
+ 2.0000E+00 -2.0000E+00 4.0000E+00 -3.0000E+00
+ -1.0000E+00 2.0000E+00 3.0000E+00 -4.0000E+00 2.0000E+00 -2.0000E+00
+ 4.0000E+00 -4.0000E+00 8.0000E+00 -6.0000E+00
+ -1.0000E+00 0.0000E+00 5.0000E+00 -5.0000E+00 3.0000E+00 -3.0000E+00
+ 6.0000E+00 -6.0000E+00 1.2000E+01 -9.0000E+00
+ -1.0000E+00 0.0000E+00 3.0000E+00 -4.0000E+00 4.0000E+00 -4.0000E+00
+ 8.0000E+00 -8.0000E+00 1.6000E+01 -1.2000E+01
+ -1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 5.0000E+00 -4.0000E+00
+ 1.0000E+01 -1.0000E+01 2.0000E+01 -1.5000E+01
+ -1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 2.0000E+00 -2.0000E+00
+ 1.2000E+01 -1.2000E+01 2.4000E+01 -1.8000E+01
+ -1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 2.0000E+00 -5.0000E+00
+ 1.5000E+01 -1.3000E+01 2.8000E+01 -2.1000E+01
+ -1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 2.0000E+00 -5.0000E+00
+ 1.2000E+01 -1.1000E+01 3.2000E+01 -2.4000E+01
+ -1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 2.0000E+00 -5.0000E+00
+ 1.2000E+01 -1.4000E+01 3.7000E+01 -2.6000E+01
+ -1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 2.0000E+00 -5.0000E+00
+ 1.2000E+01 -1.4000E+01 3.6000E+01 -2.5000E+01
+ 1.0000E+00 0.0000E+00 3.6037E-02 7.9613E-02
+ 1.9867E+00 0.0000E+00 7.4283E-05 7.4025E-06
+ 2.0000E+00 2.5052E-03 1.4346E-04 6.7839E-07
+ 2.0000E+00 -2.5052E-03 1.4346E-04 6.7839E-07
+ 2.0067E+00 1.1763E-02 6.7873E-05 5.7496E-06
+ 2.0067E+00 -1.1763E-02 6.7873E-05 5.7496E-06
+ 2.9970E+00 0.0000E+00 9.2779E-05 2.6519E-06
+ 3.0000E+00 8.7028E-04 2.7358E-04 1.9407E-07
+ 3.0000E+00 -8.7028E-04 2.7358E-04 1.9407E-07
+ 3.0030E+00 0.0000E+00 9.2696E-05 2.6477E-06
+ 0
+ 1 1
+ 1
+ 0.00000E+00
+ 1.00000E+00 0.00000E+00
+ 1 1
+ 1
+ 1.00000E+00
+ 1.00000E+00 1.00000E+00
+ 6 3
+ 4 5 6
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 1.00000E+00 4.43734E-31
+ 6 3
+ 4 5 6
+ 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
+ 1.00000E+00 1.19209E-07
+ 6 3
+ 4 5 6
+ 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
+ 4.01235E-36 3.20988E-36
+ 6 3
+ 4 5 6
+ 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00
+ 4.01235E-36 3.20988E-36
+ 6 3
+ 4 5 6
+ 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 2.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 3.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 4.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 5.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 6.00000E+00
+ 1.00000E+00 1.00000E+00
+ 2 1
+ 1
+ 1.00000E+00 2.00000E+00
+ 0.00000E+00 3.00000E+00
+ 7.07107E-01 2.00000E+00
+ 4 2
+ 1 2
+ 8.52400E-01 5.61100E-01 7.04300E-01 9.54000E-01
+ 2.79800E-01 7.21600E-01 9.61300E-01 3.58200E-01
+ 7.08100E-01 4.09400E-01 2.25000E-01 9.51800E-01
+ 5.54300E-01 5.22000E-01 6.86000E-01 3.07000E-02
+ 7.22196E-01 4.63943E-01
+ 7 6
+ 1 2 3 4 5 6
+ 7.81800E-01 5.65700E-01 7.62100E-01 7.43600E-01 2.55300E-01 4.10000E-01
+ 1.34000E-02
+ 6.45800E-01 2.66600E-01 5.51000E-01 8.31800E-01 9.27100E-01 6.20900E-01
+ 7.83900E-01
+ 1.31600E-01 4.91400E-01 1.77100E-01 1.96400E-01 1.08500E-01 9.27000E-01
+ 2.24700E-01
+ 6.41000E-01 4.68900E-01 9.65900E-01 8.88400E-01 3.76900E-01 9.67300E-01
+ 6.18300E-01
+ 8.38200E-01 8.74300E-01 4.50700E-01 9.44200E-01 7.75500E-01 9.67600E-01
+ 7.83100E-01
+ 3.25900E-01 7.38900E-01 8.30200E-01 4.52100E-01 3.01500E-01 2.13300E-01
+ 8.43400E-01
+ 5.24400E-01 5.01600E-01 7.52900E-01 3.83800E-01 8.47900E-01 9.12800E-01
+ 5.77000E-01
+ 9.43220E-01 3.20530E+00
+ 4 2
+ 2 3
+ -9.85900E-01 1.47840E+00 -1.33600E-01 -2.95970E+00
+ -4.33700E-01 -6.54000E-01 -7.15500E-01 1.23760E+00
+ -7.36300E-01 -1.97680E+00 -1.95100E-01 3.43200E-01
+ 6.41400E-01 -1.40880E+00 6.39400E-01 8.58000E-02
+ 5.22869E-01 5.45530E-01
+ 7 5
+ 1 2 3 4 5
+ 2.72840E+00 2.15200E-01 -1.05200E+00 -2.44600E-01 -6.53000E-02 3.90500E-01
+ 1.40980E+00
+ 9.75300E-01 6.51500E-01 -4.76200E-01 5.42100E-01 6.20900E-01 4.75900E-01
+ -1.44930E+00
+ -9.05200E-01 1.79000E-01 -7.08600E-01 4.62100E-01 1.05800E+00 2.24260E+00
+ 1.58260E+00
+ -7.17900E-01 -2.53400E-01 -4.73900E-01 -1.08100E+00 4.13800E-01 -9.50000E-02
+ 1.45300E-01
+ -1.37990E+00 -1.06490E+00 1.25580E+00 7.80100E-01 -6.40500E-01 -8.61000E-02
+ 8.30000E-02
+ 2.84900E-01 -1.29900E-01 4.80000E-02 -2.58600E-01 4.18900E-01 1.37680E+00
+ 8.20800E-01
+ -5.44200E-01 9.74900E-01 9.55800E-01 1.23700E-01 1.09020E+00 -1.40600E-01
+ 1.90960E+00
+ 6.04729E-01 9.00391E-01
+ 6 4
+ 3 4 5 6
+ 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00
+ 1.00000E-06 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 5.00000E-01
+ 4.89525E-05 4.56492E-05
+ 8 4
+ 1 2 3 4
+ 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 1.00000E+01 0.00000E+00
+ 1.00000E+01 0.00000E+00
+ 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 1.00000E+01
+ 1.00000E+01 0.00000E+00
+ 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 1.00000E+01
+ 1.00000E+01 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 1.00000E+01
+ 0.00000E+00 1.00000E+01
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 5.00000E-01 1.00000E+00
+ 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 5.00000E-01
+ 1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 5.00000E-01 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 5.00000E-01
+ 9.56158E-05 4.14317E-05
+ 9 3
+ 1 2 3
+ 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 7.50000E-01 1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 7.50000E-01 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 7.50000E-01
+ 1.00000E+00 5.55801E-07
+ 10 4
+ 1 2 3 4
+ 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 8.75000E-01 1.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 8.75000E-01 1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 8.75000E-01 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 8.75000E-01
+ 1.00000E+00 1.16972E-10
+ 12 6
+ 1 2 3 4 5 6
+ 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 1.00000E+01 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 1.00000E+01 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 1.00000E+01 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+01 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+01 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+01
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 9.37500E-01 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 9.37500E-01 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 9.37500E-01 1.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 9.37500E-01 1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 9.37500E-01 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 9.37500E-01
+ 1.85655E-10 2.20147E-16
+ 12 7
+ 6 7 8 9 10 11 12
+ 1.20000E+01 1.10000E+01 1.00000E+01 9.00000E+00 8.00000E+00 7.00000E+00
+ 6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
+ 1.10000E+01 1.10000E+01 1.00000E+01 9.00000E+00 8.00000E+00 7.00000E+00
+ 6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
+ 0.00000E+00 1.00000E+01 1.00000E+01 9.00000E+00 8.00000E+00 7.00000E+00
+ 6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 9.00000E+00 9.00000E+00 8.00000E+00 7.00000E+00
+ 6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 8.00000E+00 8.00000E+00 7.00000E+00
+ 6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 7.00000E+00 7.00000E+00
+ 6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 6.00000E+00
+ 6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 5.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 4.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 3.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 2.00000E+00 2.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00
+ 6.92558E-05 5.52606E-05
+ 3 1
+ 1
+ 2.00000E-06 1.00000E+00 -2.00000E+00
+ 1.00000E-06 -2.00000E+00 4.00000E+00
+ 0.00000E+00 1.00000E+00 -2.00000E+00
+ 7.30297E-01 4.00000E+00
+ 5 1
+ 3
+ 2.00000E-03 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 1.00000E-03 1.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 -1.00000E-03 1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 -2.00000E-03 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 3.99999E-12 3.99201E-12
+ 6 4
+ 1 2 3 5
+ 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 1.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
+ 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00
+ 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00
+ 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00
+ 2.93294E-01 1.63448E-01
+ 6 2
+ 3 4
+ 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
+ 1.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 1.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 1.00000E+00
+ -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00
+ 3.97360E-01 3.58295E-01
+ 6 3
+ 3 4 5
+ 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00
+ 5.00000E-01 3.33300E-01 2.50000E-01 2.00000E-01 1.66700E-01 1.42900E-01
+ 3.33300E-01 2.50000E-01 2.00000E-01 1.66700E-01 1.42900E-01 1.25000E-01
+ 2.50000E-01 2.00000E-01 1.66700E-01 1.42900E-01 1.25000E-01 1.11100E-01
+ 2.00000E-01 1.66700E-01 1.42900E-01 1.25000E-01 1.11100E-01 1.00000E-01
+ 1.66700E-01 1.42900E-01 1.25000E-01 1.11100E-01 1.00000E-01 9.09000E-02
+ 7.28934E-01 1.24624E-02
+ 5 1
+ 1
+ 1.50000E+01 1.10000E+01 6.00000E+00 -9.00000E+00 -1.50000E+01
+ 1.00000E+00 3.00000E+00 9.00000E+00 -3.00000E+00 -8.00000E+00
+ 7.00000E+00 6.00000E+00 6.00000E+00 -3.00000E+00 -1.10000E+01
+ 7.00000E+00 7.00000E+00 5.00000E+00 -3.00000E+00 -1.10000E+01
+ 1.70000E+01 1.20000E+01 5.00000E+00 -1.00000E+01 -1.60000E+01
+ 2.17680E-01 5.22626E-01
+ 6 2
+ 1 2
+ -9.00000E+00 2.10000E+01 -1.50000E+01 4.00000E+00 2.00000E+00 0.00000E+00
+ -1.00000E+01 2.10000E+01 -1.40000E+01 4.00000E+00 2.00000E+00 0.00000E+00
+ -8.00000E+00 1.60000E+01 -1.10000E+01 4.00000E+00 2.00000E+00 0.00000E+00
+ -6.00000E+00 1.20000E+01 -9.00000E+00 3.00000E+00 3.00000E+00 0.00000E+00
+ -4.00000E+00 8.00000E+00 -6.00000E+00 0.00000E+00 5.00000E+00 0.00000E+00
+ -2.00000E+00 4.00000E+00 -3.00000E+00 0.00000E+00 1.00000E+00 3.00000E+00
+ 6.78904E-02 4.22005E-02
+ 10 1
+ 1
+ 1.00000E+00 1.00000E+00 1.00000E+00 -2.00000E+00 1.00000E+00 -1.00000E+00
+ 2.00000E+00 -2.00000E+00 4.00000E+00 -3.00000E+00
+ -1.00000E+00 2.00000E+00 3.00000E+00 -4.00000E+00 2.00000E+00 -2.00000E+00
+ 4.00000E+00 -4.00000E+00 8.00000E+00 -6.00000E+00
+ -1.00000E+00 0.00000E+00 5.00000E+00 -5.00000E+00 3.00000E+00 -3.00000E+00
+ 6.00000E+00 -6.00000E+00 1.20000E+01 -9.00000E+00
+ -1.00000E+00 0.00000E+00 3.00000E+00 -4.00000E+00 4.00000E+00 -4.00000E+00
+ 8.00000E+00 -8.00000E+00 1.60000E+01 -1.20000E+01
+ -1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 5.00000E+00 -4.00000E+00
+ 1.00000E+01 -1.00000E+01 2.00000E+01 -1.50000E+01
+ -1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 2.00000E+00 -2.00000E+00
+ 1.20000E+01 -1.20000E+01 2.40000E+01 -1.80000E+01
+ -1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 2.00000E+00 -5.00000E+00
+ 1.50000E+01 -1.30000E+01 2.80000E+01 -2.10000E+01
+ -1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 2.00000E+00 -5.00000E+00
+ 1.20000E+01 -1.10000E+01 3.20000E+01 -2.40000E+01
+ -1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 2.00000E+00 -5.00000E+00
+ 1.20000E+01 -1.40000E+01 3.70000E+01 -2.60000E+01
+ -1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 2.00000E+00 -5.00000E+00
+ 1.20000E+01 -1.40000E+01 3.60000E+01 -2.50000E+01
+ 3.60372E-02 7.96134E-02
+ 0 0
diff --git a/TESTING/sed.in b/TESTING/sed.in
new file mode 100644
index 0000000..2a0a4f7
--- /dev/null
+++ b/TESTING/sed.in
@@ -0,0 +1,865 @@
+SEV Data file for the Real Nonsymmetric Eigenvalue Driver
+6 Number of matrix dimensions
+0 1 2 3 5 10 20 Matrix dimensions
+3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
+20.0 Threshold for test ratios
+T
+2 Read another line with random number generator seed
+2518 3899 995 397 Seed for random number generator
+SEV 21 Use all matrix types
+SES Data file for the Real Nonsymmetric Schur Form Driver
+6 Number of matrix dimensions
+0 1 2 3 5 10 20 Matrix dimensions
+3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
+20.0 Threshold for test ratios
+T
+2 Read another line with random number generator seed
+2518 3899 995 397 Seed for random number generator
+SES 21 Use all matrix types
+SVX Data file for the Real Nonsymmetric Eigenvalue Expert Driver
+6 Number of matrix dimensions
+0 1 2 3 5 10 20 Matrix dimensions
+3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
+20.0 Threshold for test ratios
+T
+2 Read another line with random number generator seed
+2518 3899 995 397 Seed for random number generator
+SVX 21 Use all matrix types
+ 1
+ 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 1
+ 1.0000E+00
+ 1.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 2
+ 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 2
+ 3.0000E+00 2.0000E+00
+ 2.0000E+00 3.0000E+00
+ 1.0000E+00 0.0000E+00 1.0000E+00 4.0000E+00
+ 5.0000E+00 0.0000E+00 1.0000E+00 4.0000E+00
+ 2
+ 3.0000E+00 -2.0000E+00
+ 2.0000E+00 3.0000E+00
+ 3.0000E+00 2.0000E+00 1.0000E+00 4.0000E+00
+ 3.0000E+00 -2.0000E+00 1.0000E+00 4.0000E+00
+ 6
+ 1.0000E-07 -1.0000E-07 1.0000E+00 1.1000E+00 2.3000E+00 3.7000E+00
+ 3.0000E-07 1.0000E-07 1.0000E+00 1.0000E+00 -1.3000E+00 -7.7000E+00
+ 0.0000E+00 0.0000E+00 3.0000E-07 1.0000E-07 2.2000E+00 3.3000E+00
+ 0.0000E+00 0.0000E+00 -1.0000E-07 3.0000E-07 1.8000E+00 1.6000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 4.0000E-06 5.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 3.0000E+00 4.0000E-06
+ -3.8730E+00 0.0000E+00 6.9855E-01 2.2823E+00
+ 1.0000E-07 1.7321E-07 9.7611E-08 5.0060E-14
+ 1.0000E-07 -1.7321E-07 9.7611E-08 5.0060E-14
+ 3.0000E-07 1.0000E-07 1.0000E-07 9.4094E-14
+ 3.0000E-07 -1.0000E-07 1.0000E-07 9.4094E-14
+ 3.8730E+00 0.0000E+00 4.0659E-01 1.5283E+00
+ 4
+ 7.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00
+ -1.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00
+ -1.0000E+00 1.0000E+00 5.0000E+00 -3.0000E+00
+ 1.0000E+00 -1.0000E+00 3.0000E+00 3.0000E+00
+ 3.9603E+00 4.0425E-02 1.1244E-05 3.1179E-05
+ 3.9603E+00 -4.0425E-02 1.1244E-05 3.1179E-05
+ 4.0397E+00 3.8854E-02 1.0807E-05 2.9981E-05
+ 4.0397E+00 -3.8854E-02 1.0807E-05 2.9981E-05
+ 5
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
+ 0.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
+ 0.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
+ 0.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
+ 0.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
+ 5
+ 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
+ 1.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
+ 1.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
+ 1.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
+ 1.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
+ 1.0000E+00 0.0000E+00 1.0000E+00 1.9722E-31
+ 6
+ 1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 6
+ 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 1.0000E+00 0.0000E+00 2.4074E-35 2.4074E-35
+ 6
+ 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 2.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 3.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 4.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 5.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 6.0000E+00
+ 1.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 2.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 3.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 4.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 5.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 6.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 4
+ 9.4480E-01 6.7670E-01 6.9080E-01 5.9650E-01
+ 5.8760E-01 8.6420E-01 6.7690E-01 7.2600E-02
+ 7.2560E-01 1.9430E-01 9.6870E-01 2.8310E-01
+ 2.8490E-01 5.8000E-02 4.8450E-01 7.3610E-01
+ 2.4326E-01 2.1409E-01 8.7105E-01 3.5073E-01
+ 2.4326E-01 -2.1409E-01 8.7105E-01 3.5073E-01
+ 7.4091E-01 0.0000E+00 9.8194E-01 4.6989E-01
+ 2.2864E+00 0.0000E+00 9.7723E-01 1.5455E+00
+ 6
+ 5.0410E-01 6.6520E-01 7.7190E-01 6.3870E-01 5.9550E-01 6.1310E-01
+ 1.5740E-01 3.7340E-01 5.9840E-01 1.5470E-01 9.4270E-01 6.5900E-02
+ 4.4170E-01 7.2300E-02 1.5440E-01 5.4920E-01 8.7000E-03 3.0040E-01
+ 2.0080E-01 6.0800E-01 3.0340E-01 8.4390E-01 2.3900E-01 5.7680E-01
+ 9.3610E-01 7.4130E-01 1.4440E-01 1.7860E-01 1.4280E-01 7.2630E-01
+ 5.5990E-01 9.3360E-01 7.8000E-02 4.0930E-01 6.7140E-01 5.6170E-01
+ -5.2278E-01 0.0000E+00 2.7888E-01 1.1793E-01
+ -3.5380E-01 0.0000E+00 3.5427E-01 6.8911E-02
+ -8.0876E-03 0.0000E+00 3.4558E-01 1.3489E-01
+ 3.4760E-01 3.0525E-01 5.4661E-01 1.7729E-01
+ 3.4760E-01 -3.0525E-01 5.4661E-01 1.7729E-01
+ 2.7698E+00 0.0000E+00 9.6635E-01 1.8270E+00
+ 5
+ 2.0000E-03 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 1.0000E-03 1.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 -1.0000E-03 1.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 -2.0000E-03 1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ -2.0000E-03 0.0000E+00 2.4000E-11 2.3952E-11
+ -1.0000E-03 0.0000E+00 6.0000E-12 5.9940E-12
+ 0.0000E+00 0.0000E+00 4.0000E-12 3.9920E-12
+ 1.0000E-03 0.0000E+00 6.0000E-12 5.9940E-12
+ 2.0000E-03 0.0000E+00 2.4000E-11 2.3952E-11
+ 10
+ 4.8630E-01 9.1260E-01 2.1900E-02 6.0110E-01 1.4050E-01 2.0840E-01
+ 8.2640E-01 8.4410E-01 3.1420E-01 8.6750E-01
+ 7.1500E-01 2.6480E-01 8.8510E-01 2.6150E-01 5.9520E-01 4.7800E-01
+ 7.6730E-01 4.6110E-01 5.7320E-01 7.7000E-03
+ 2.1210E-01 5.5080E-01 5.2350E-01 3.0810E-01 6.6020E-01 2.8900E-01
+ 2.3140E-01 2.2790E-01 9.6600E-02 1.0910E-01
+ 7.1510E-01 8.5790E-01 5.7710E-01 5.1140E-01 1.9010E-01 9.0810E-01
+ 6.0090E-01 7.1980E-01 1.0640E-01 8.6840E-01
+ 5.6800E-01 2.8100E-02 4.0140E-01 6.3150E-01 1.1480E-01 7.5800E-02
+ 9.4230E-01 7.2030E-01 3.6850E-01 1.7430E-01
+ 7.7210E-01 3.0280E-01 5.5640E-01 9.9980E-01 3.6520E-01 5.2580E-01
+ 3.7030E-01 6.7790E-01 9.9350E-01 5.0270E-01
+ 7.3960E-01 4.5600E-02 7.4740E-01 9.2880E-01 2.2000E-03 8.2600E-02
+ 3.6340E-01 4.9120E-01 9.4050E-01 3.8910E-01
+ 5.6370E-01 8.5540E-01 3.2100E-02 2.6380E-01 3.6090E-01 6.4970E-01
+ 8.4690E-01 9.3500E-01 3.7000E-02 2.9170E-01
+ 8.6560E-01 6.3270E-01 3.5620E-01 6.3560E-01 2.7360E-01 6.5120E-01
+ 1.0220E-01 2.8880E-01 5.7620E-01 4.0790E-01
+ 5.3320E-01 4.1210E-01 7.2870E-01 2.3110E-01 6.8300E-01 7.3860E-01
+ 8.1800E-01 9.8150E-01 8.0550E-01 2.5660E-01
+ -4.6121E-01 7.2657E-01 4.7781E-01 1.5842E-01
+ -4.6121E-01 -7.2657E-01 4.7781E-01 1.5842E-01
+ -4.5164E-01 0.0000E+00 4.6034E-01 1.9931E-01
+ -1.4922E-01 4.8255E-01 4.7500E-01 9.1686E-02
+ -1.4922E-01 -4.8255E-01 4.7500E-01 9.1686E-02
+ 3.3062E-02 0.0000E+00 2.9729E-01 8.2469E-02
+ 3.0849E-01 1.1953E-01 4.2947E-01 3.9688E-02
+ 3.0849E-01 -1.1953E-01 4.2947E-01 3.9688E-02
+ 5.4509E-01 0.0000E+00 7.0777E-01 1.5033E-01
+ 5.0352E+00 0.0000E+00 9.7257E-01 3.5548E+00
+ 4
+ -3.8730E-01 3.6560E-01 3.1200E-02 -5.8340E-01
+ 5.5230E-01 -1.1854E+00 9.8330E-01 7.6670E-01
+ 1.6746E+00 -1.9900E-02 -1.8293E+00 5.7180E-01
+ -5.2500E-01 3.5340E-01 -2.7210E-01 -8.8300E-02
+ -1.8952E+00 7.5059E-01 8.1913E-01 7.7090E-01
+ -1.8952E+00 -7.5059E-01 8.1913E-01 7.7090E-01
+ -9.5162E-02 0.0000E+00 8.0499E-01 4.9037E-01
+ 3.9520E-01 0.0000E+00 9.8222E-01 4.9037E-01
+ 6
+ -1.0777E+00 1.7027E+00 2.6510E-01 8.5160E-01 1.0121E+00 2.5710E-01
+ -1.3400E-02 3.9030E-01 -1.2680E+00 2.7530E-01 -3.2350E-01 -1.3844E+00
+ 1.5230E-01 3.0680E-01 8.7330E-01 -3.3410E-01 -4.8310E-01 -1.5416E+00
+ 1.4470E-01 -6.0570E-01 3.1900E-02 -1.0905E+00 -8.3700E-02 6.2410E-01
+ -7.6510E-01 -1.7889E+00 -1.5069E+00 -6.0210E-01 5.2170E-01 6.4700E-01
+ 8.1940E-01 2.1100E-01 5.4320E-01 7.5610E-01 1.7130E-01 5.5400E-01
+ -1.7029E+00 0.0000E+00 6.7909E-01 6.7220E-01
+ -1.0307E+00 0.0000E+00 7.2671E-01 2.0436E-01
+ 2.8487E-01 1.2101E+00 3.9757E-01 4.9797E-01
+ 2.8487E-01 -1.2101E+00 3.9757E-01 4.9797E-01
+ 1.1675E+00 4.6631E-01 4.2334E-01 1.9048E-01
+ 1.1675E+00 -4.6631E-01 4.2334E-01 1.9048E-01
+ 10
+ -1.0639E+00 1.6120E-01 1.5620E-01 3.4360E-01 -6.7480E-01 1.6598E+00
+ 6.4650E-01 -7.8630E-01 -2.6100E-01 7.0190E-01
+ -8.4400E-01 -2.2439E+00 1.8800E+00 -1.0005E+00 7.4500E-02 -1.6156E+00
+ 2.8220E-01 8.5600E-01 1.3497E+00 -1.5883E+00
+ 1.5988E+00 1.1758E+00 1.2398E+00 1.1173E+00 2.1500E-01 4.3140E-01
+ 1.8500E-01 7.9470E-01 6.6260E-01 8.6460E-01
+ -2.2960E-01 1.2442E+00 2.3242E+00 -5.0690E-01 -7.5160E-01 -5.4370E-01
+ -2.5990E-01 1.2830E+00 -1.1067E+00 -1.1150E-01
+ -3.6040E-01 4.0420E-01 6.1240E-01 -1.2164E+00 -9.4650E-01 -3.1460E-01
+ 1.8310E-01 7.3710E-01 1.4278E+00 2.9220E-01
+ 4.6150E-01 3.8740E-01 -4.2900E-02 -9.3600E-01 7.1160E-01 -8.2590E-01
+ -1.7640E+00 -9.4660E-01 1.8202E+00 -2.5480E-01
+ 1.2934E+00 -9.7550E-01 6.7480E-01 -1.0481E+00 -1.8442E+00 -5.4600E-02
+ 7.4050E-01 6.1000E-03 1.2430E+00 -1.8490E-01
+ -3.4710E-01 -9.5800E-01 1.6530E-01 9.1300E-02 -5.2010E-01 -1.1832E+00
+ 8.5410E-01 -2.3200E-01 -1.6155E+00 5.5180E-01
+ 1.0190E+00 -6.8240E-01 8.0850E-01 2.5950E-01 -3.7580E-01 -1.8825E+00
+ 1.6473E+00 -6.5920E-01 8.0250E-01 -4.9000E-03
+ 1.2670E+00 -4.2400E-02 8.9570E-01 -1.6770E-01 1.4620E-01 9.8800E-01
+ -2.3170E-01 -1.4483E+00 -5.8200E-02 1.9700E-02
+ -2.6992E+00 9.0387E-01 6.4005E-01 4.1615E-01
+ -2.6992E+00 -9.0387E-01 6.4005E-01 4.1615E-01
+ -2.4366E+00 0.0000E+00 6.9083E-01 2.5476E-01
+ -1.2882E+00 8.8930E-01 5.3435E-01 6.0878E-01
+ -1.2882E+00 -8.8930E-01 5.3435E-01 6.0878E-01
+ 9.0275E-01 0.0000E+00 2.9802E-01 4.7530E-01
+ 9.0442E-01 2.5661E+00 7.3193E-01 6.2016E-01
+ 9.0442E-01 -2.5661E+00 7.3193E-01 6.2016E-01
+ 1.6774E+00 0.0000E+00 3.0743E-01 4.1726E-01
+ 3.0060E+00 0.0000E+00 8.5623E-01 4.3175E-01
+ 4
+ -1.2298E+00 -2.3142E+00 -6.9800E-02 1.0523E+00
+ 2.0390E-01 -1.2298E+00 8.0500E-02 9.7860E-01
+ 0.0000E+00 0.0000E+00 2.5600E-01 -8.9100E-01
+ 0.0000E+00 0.0000E+00 2.7480E-01 2.5600E-01
+ -1.2298E+00 6.8692E-01 4.7136E-01 7.1772E-01
+ -1.2298E+00 -6.8692E-01 4.7136E-01 7.1772E-01
+ 2.5600E-01 4.9482E-01 8.0960E-01 5.1408E-01
+ 2.5600E-01 -4.9482E-01 8.0960E-01 5.1408E-01
+ 6
+ 5.9930E-01 1.9372E+00 -1.6160E-01 -1.4602E+00 6.0180E-01 2.7120E+00
+ -2.2049E+00 5.9930E-01 -1.0679E+00 1.9405E+00 -1.4400E+00 -2.2110E-01
+ 0.0000E+00 0.0000E+00 -2.4567E+00 -6.8650E-01 -1.9101E+00 6.4960E-01
+ 0.0000E+00 0.0000E+00 0.0000E+00 7.3620E-01 3.9700E-01 -1.5190E-01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 -1.0034E+00 1.1954E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 -1.3400E-01 -1.0034E+00
+ -2.4567E+00 0.0000E+00 4.7091E-01 8.5788E-01
+ -1.0034E+00 4.0023E-01 3.6889E-01 1.8909E-01
+ -1.0034E+00 -4.0023E-01 3.6889E-01 1.8909E-01
+ 5.9930E-01 2.0667E+00 5.8849E-01 1.3299E+00
+ 5.9930E-01 -2.0667E+00 5.8849E-01 1.3299E+00
+ 7.3620E-01 0.0000E+00 6.0845E-01 9.6725E-01
+ 4
+ 1.0000E-04 1.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 -1.0000E-04 1.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E-02 1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 -5.0000E-03
+ -5.0000E-03 0.0000E+00 3.7485E-07 3.6932E-07
+ -1.0000E-04 0.0000E+00 9.8979E-09 9.8493E-09
+ 1.0000E-04 0.0000E+00 1.0098E-08 1.0046E-08
+ 1.0000E-02 0.0000E+00 1.4996E-06 1.4773E-06
+ 3
+ 2.0000E-06 1.0000E+00 -2.0000E+00
+ 1.0000E-06 -2.0000E+00 4.0000E+00
+ 0.0000E+00 1.0000E+00 -2.0000E+00
+ -4.0000E+00 0.0000E+00 7.3030E-01 4.0000E+00
+ 0.0000E+00 0.0000E+00 7.2801E-01 1.3726E-06
+ 2.2096E-06 0.0000E+00 8.2763E-01 2.2096E-06
+ 6
+ 2.4080E-01 6.5530E-01 9.1660E-01 5.0300E-02 2.8490E-01 2.4080E-01
+ 6.9070E-01 9.7000E-01 1.4020E-01 5.7820E-01 6.7670E-01 6.9070E-01
+ 1.0620E-01 3.8000E-02 7.0540E-01 2.4320E-01 8.6420E-01 1.0620E-01
+ 2.6400E-01 9.8800E-02 1.7800E-02 9.4480E-01 1.9430E-01 2.6400E-01
+ 7.0340E-01 2.5600E-01 2.6110E-01 5.8760E-01 5.8000E-02 7.0340E-01
+ 4.0210E-01 5.5980E-01 1.3580E-01 7.2560E-01 6.9080E-01 4.0210E-01
+ -3.4008E-01 3.2133E-01 5.7839E-01 2.0310E-01
+ -3.4008E-01 -3.2133E-01 5.7839E-01 2.0310E-01
+ -1.6998E-07 0.0000E+00 4.9641E-01 2.1574E-01
+ 7.2311E-01 5.9389E-02 7.0039E-01 4.1945E-02
+ 7.2311E-01 -5.9389E-02 7.0039E-01 4.1945E-02
+ 2.5551E+00 0.0000E+00 9.2518E-01 1.7390E+00
+ 6
+ 3.4800E+00 -2.9900E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ -4.9000E-01 2.4800E+00 -1.9900E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 -4.9000E-01 1.4800E+00 -9.9000E-01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 -9.9000E-01 1.4800E+00 -4.9000E-01 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 -1.9900E+00 2.4800E+00 -4.9000E-01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 -2.9900E+00 3.4800E+00
+ 1.3034E-02 0.0000E+00 7.5301E-01 6.0533E-01
+ 1.1294E+00 0.0000E+00 6.0479E-01 2.8613E-01
+ 2.0644E+00 0.0000E+00 5.4665E-01 1.7376E-01
+ 2.8388E+00 0.0000E+00 4.2771E-01 3.0915E-01
+ 4.3726E+00 0.0000E+00 6.6370E-01 7.6443E-02
+ 4.4618E+00 0.0000E+00 5.7388E-01 8.9227E-02
+ 6
+ 0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
+ 1.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00
+ -1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ -1.7321E+00 0.0000E+00 8.6603E-01 7.2597E-01
+ -1.0000E+00 0.0000E+00 5.0000E-01 2.6417E-01
+ 0.0000E+00 0.0000E+00 2.9582E-31 1.4600E-07
+ 0.0000E+00 0.0000E+00 2.9582E-31 6.2446E-08
+ 1.0000E+00 0.0000E+00 5.0000E-01 2.6417E-01
+ 1.7321E+00 0.0000E+00 8.6603E-01 3.7896E-01
+ 6
+ 3.5345E-01 9.3023E-01 7.4679E-02 -1.0059E-02 4.6698E-02 -4.3480E-02
+ 9.3545E-01 -3.5147E-01 -2.8216E-02 3.8008E-03 -1.7644E-02 1.6428E-02
+ 0.0000E+00 -1.0555E-01 7.5211E-01 -1.0131E-01 4.7030E-01 -4.3789E-01
+ 0.0000E+00 0.0000E+00 6.5419E-01 1.1779E-01 -5.4678E-01 5.0911E-01
+ 0.0000E+00 0.0000E+00 0.0000E+00 -9.8780E-01 -1.1398E-01 1.0612E-01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 6.8144E-01 7.3187E-01
+ -9.9980E-01 1.9645E-02 1.0000E+00 3.9290E-02
+ -9.9980E-01 -1.9645E-02 1.0000E+00 3.9290E-02
+ 7.4539E-01 6.6663E-01 1.0000E+00 5.2120E-01
+ 7.4539E-01 -6.6663E-01 1.0000E+00 5.2120E-01
+ 9.9929E-01 3.7545E-02 1.0000E+00 7.5089E-02
+ 9.9929E-01 -3.7545E-02 1.0000E+00 7.5089E-02
+ 6
+ 1.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00
+ 5.0000E-01 3.3330E-01 2.5000E-01 2.0000E-01 1.6670E-01 1.4290E-01
+ 3.3330E-01 2.5000E-01 2.0000E-01 1.6670E-01 1.4290E-01 1.2500E-01
+ 2.5000E-01 2.0000E-01 1.6670E-01 1.4290E-01 1.2500E-01 1.1110E-01
+ 2.0000E-01 1.6670E-01 1.4290E-01 1.2500E-01 1.1110E-01 1.0000E-01
+ 1.6670E-01 1.4290E-01 1.2500E-01 1.1110E-01 1.0000E-01 9.0900E-02
+ -2.2135E-01 0.0000E+00 4.0841E-01 1.6605E-01
+ -3.1956E-02 0.0000E+00 3.7927E-01 3.0531E-02
+ -8.5031E-04 0.0000E+00 6.2793E-01 7.8195E-04
+ -5.8584E-05 0.0000E+00 8.1156E-01 7.2478E-05
+ 1.3895E-05 0.0000E+00 9.7087E-01 7.2478E-05
+ 2.1324E+00 0.0000E+00 8.4325E-01 1.8048E+00
+ 12
+ 1.2000E+01 1.1000E+01 1.0000E+01 9.0000E+00 8.0000E+00 7.0000E+00
+ 6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
+ 1.1000E+01 1.1000E+01 1.0000E+01 9.0000E+00 8.0000E+00 7.0000E+00
+ 6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
+ 0.0000E+00 1.0000E+01 1.0000E+01 9.0000E+00 8.0000E+00 7.0000E+00
+ 6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
+ 0.0000E+00 0.0000E+00 9.0000E+00 9.0000E+00 8.0000E+00 7.0000E+00
+ 6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 8.0000E+00 8.0000E+00 7.0000E+00
+ 6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 7.0000E+00 7.0000E+00
+ 6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 6.0000E+00
+ 6.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 5.0000E+00 5.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 4.0000E+00 4.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 3.0000E+00 3.0000E+00 2.0000E+00 1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 2.0000E+00 2.0000E+00 1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ -2.8234E-02 0.0000E+00 2.8690E-06 3.2094E-06
+ 7.2587E-02 9.0746E-02 1.5885E-06 9.9934E-07
+ 7.2587E-02 -9.0746E-02 1.5885E-06 9.9934E-07
+ 1.8533E-01 0.0000E+00 6.5757E-07 7.8673E-07
+ 2.8828E-01 0.0000E+00 1.8324E-06 2.0796E-06
+ 6.4315E-01 0.0000E+00 6.8640E-05 6.1058E-05
+ 1.5539E+00 0.0000E+00 4.6255E-03 6.4028E-03
+ 3.5119E+00 0.0000E+00 1.4447E-01 1.9470E-01
+ 6.9615E+00 0.0000E+00 5.8447E-01 1.2016E+00
+ 1.2311E+01 0.0000E+00 3.1823E-01 1.4273E+00
+ 2.0199E+01 0.0000E+00 2.0079E-01 2.4358E+00
+ 3.2229E+01 0.0000E+00 3.0424E-01 5.6865E+00
+ 6
+ 0.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 5.0000E+00 0.0000E+00 2.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 4.0000E+00 0.0000E+00 3.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 3.0000E+00 0.0000E+00 4.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 2.0000E+00 0.0000E+00 5.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ -5.0000E+00 0.0000E+00 8.2295E-01 1.2318E+00
+ -3.0000E+00 0.0000E+00 7.2281E-01 7.5970E-01
+ -1.0000E+00 0.0000E+00 6.2854E-01 6.9666E-01
+ 1.0000E+00 0.0000E+00 6.2854E-01 6.9666E-01
+ 3.0000E+00 0.0000E+00 7.2281E-01 7.5970E-01
+ 5.0000E+00 0.0000E+00 8.2295E-01 1.2318E+00
+ 6
+ 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
+ -1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
+ -1.0000E+00 -1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
+ -1.0000E+00 -1.0000E+00 -1.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00
+ -1.0000E+00 -1.0000E+00 -1.0000E+00 -1.0000E+00 1.0000E+00 1.0000E+00
+ -1.0000E+00 -1.0000E+00 -1.0000E+00 -1.0000E+00 -1.0000E+00 1.0000E+00
+ 8.0298E-02 2.4187E+00 8.9968E-01 1.5236E+00
+ 8.0298E-02 -2.4187E+00 8.9968E-01 1.5236E+00
+ 1.4415E+00 6.2850E-01 9.6734E-01 4.2793E-01
+ 1.4415E+00 -6.2850E-01 9.6734E-01 4.2793E-01
+ 1.4782E+00 1.5638E-01 9.7605E-01 2.2005E-01
+ 1.4782E+00 -1.5638E-01 9.7605E-01 2.2005E-01
+ 6
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
+ 1.0000E+00 1.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00
+ 0.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00
+ 1.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00
+ 1.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00 0.0000E+00
+ 0.0000E+00 1.0000E+00 0.0000E+00 1.0000E+00 1.0000E+00 1.0000E+00
+ -3.5343E-02 7.4812E-01 3.9345E-01 1.8415E-01
+ -3.5343E-02 -7.4812E-01 3.9345E-01 1.8415E-01
+ 5.8440E-07 0.0000E+00 2.8868E-01 1.7003E-01
+ 6.4087E-01 7.2822E-01 4.5013E-01 2.9425E-01
+ 6.4087E-01 -7.2822E-01 4.5013E-01 2.9425E-01
+ 3.7889E+00 0.0000E+00 9.6305E-01 2.2469E+00
+ 6
+ 1.0000E+00 4.0112E+00 1.2750E+01 4.0213E+01 1.2656E+02 3.9788E+02
+ 1.0000E+00 3.2616E+00 1.0629E+01 3.3342E+01 1.0479E+02 3.2936E+02
+ 1.0000E+00 3.1500E+00 9.8006E+00 3.0630E+01 9.6164E+01 3.0215E+02
+ 1.0000E+00 3.2755E+00 1.0420E+01 3.2957E+01 1.0374E+02 3.2616E+02
+ 1.0000E+00 2.8214E+00 8.4558E+00 2.6296E+01 8.2443E+01 2.5893E+02
+ 1.0000E+00 2.6406E+00 8.3565E+00 2.6558E+01 8.3558E+01 2.6268E+02
+ -5.3220E-01 0.0000E+00 5.3287E-01 3.8557E-01
+ -1.0118E-01 0.0000E+00 7.2342E-01 9.1303E-02
+ -9.8749E-03 0.0000E+00 7.3708E-01 1.1032E-02
+ 2.9861E-03 0.0000E+00 4.4610E-01 1.2861E-02
+ 1.8075E-01 0.0000E+00 4.2881E-01 1.7378E-01
+ 3.9260E+02 0.0000E+00 4.8057E-01 3.9201E+02
+ 8
+ 0.0000E+00 4.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00
+ 1.0000E+00 0.0000E+00 4.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00
+ 0.0000E+00 1.0000E+00 0.0000E+00 4.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 4.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00 4.0000E+00
+ 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00 0.0000E+00
+ 4.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
+ 0.0000E+00 4.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 1.0000E+00 0.0000E+00
+ -3.7588E+00 0.0000E+00 1.2253E-01 1.2978E-01
+ -3.0642E+00 0.0000E+00 4.9811E-02 8.0162E-02
+ -2.0000E+00 0.0000E+00 3.6914E-02 8.2942E-02
+ -6.9459E-01 0.0000E+00 3.3328E-02 1.3738E-01
+ 6.9459E-01 0.0000E+00 3.3328E-02 1.1171E-01
+ 2.0000E+00 0.0000E+00 3.6914E-02 7.2156E-02
+ 3.0642E+00 0.0000E+00 4.9811E-02 6.8352E-02
+ 3.7588E+00 0.0000E+00 1.2253E-01 1.1527E-01
+ 6
+ 8.5000E+00 -1.0472E+01 2.8944E+00 -1.5279E+00 1.1056E+00 -5.0000E-01
+ 2.6180E+00 -1.1708E+00 -2.0000E+00 8.9440E-01 -6.1800E-01 2.7640E-01
+ -7.2360E-01 2.0000E+00 -1.7080E-01 -1.6180E+00 8.9440E-01 -3.8200E-01
+ 3.8200E-01 -8.9440E-01 1.6180E+00 1.7080E-01 -2.0000E+00 7.2360E-01
+ -2.7640E-01 6.1800E-01 -8.9440E-01 2.0000E+00 1.1708E+00 -2.6180E+00
+ 5.0000E-01 -1.1056E+00 1.5279E+00 -2.8944E+00 1.0472E+01 -8.5000E+00
+ -5.8930E-01 0.0000E+00 1.7357E-04 2.8157E-04
+ -2.7627E-01 4.9852E-01 1.7486E-04 1.6704E-04
+ -2.7627E-01 -4.9852E-01 1.7486E-04 1.6704E-04
+ 2.7509E-01 5.0059E-01 1.7635E-04 1.6828E-04
+ 2.7509E-01 -5.0059E-01 1.7635E-04 1.6828E-04
+ 5.9167E-01 0.0000E+00 1.7623E-04 3.0778E-04
+ 4
+ 4.0000E+00 -5.0000E+00 0.0000E+00 3.0000E+00
+ 0.0000E+00 4.0000E+00 -3.0000E+00 -5.0000E+00
+ 5.0000E+00 -3.0000E+00 4.0000E+00 0.0000E+00
+ 3.0000E+00 0.0000E+00 5.0000E+00 4.0000E+00
+ 1.0000E+00 5.0000E+00 1.0000E+00 4.3333E+00
+ 1.0000E+00 -5.0000E+00 1.0000E+00 4.3333E+00
+ 2.0000E+00 0.0000E+00 1.0000E+00 4.3333E+00
+ 1.2000E+01 0.0000E+00 1.0000E+00 9.1250E+00
+ 5
+ 1.5000E+01 1.1000E+01 6.0000E+00 -9.0000E+00 -1.5000E+01
+ 1.0000E+00 3.0000E+00 9.0000E+00 -3.0000E+00 -8.0000E+00
+ 7.0000E+00 6.0000E+00 6.0000E+00 -3.0000E+00 -1.1000E+01
+ 7.0000E+00 7.0000E+00 5.0000E+00 -3.0000E+00 -1.1000E+01
+ 1.7000E+01 1.2000E+01 5.0000E+00 -1.0000E+01 -1.6000E+01
+ -9.9999E-01 0.0000E+00 2.1768E-01 5.2263E-01
+ 1.4980E+00 3.5752E+00 3.9966E-04 6.0947E-03
+ 1.4980E+00 -3.5752E+00 3.9966E-04 6.0947E-03
+ 1.5020E+00 3.5662E+00 3.9976E-04 6.0960E-03
+ 1.5020E+00 -3.5662E+00 3.9976E-04 6.0960E-03
+ 6
+ -9.0000E+00 2.1000E+01 -1.5000E+01 4.0000E+00 2.0000E+00 0.0000E+00
+ -1.0000E+01 2.1000E+01 -1.4000E+01 4.0000E+00 2.0000E+00 0.0000E+00
+ -8.0000E+00 1.6000E+01 -1.1000E+01 4.0000E+00 2.0000E+00 0.0000E+00
+ -6.0000E+00 1.2000E+01 -9.0000E+00 3.0000E+00 3.0000E+00 0.0000E+00
+ -4.0000E+00 8.0000E+00 -6.0000E+00 0.0000E+00 5.0000E+00 0.0000E+00
+ -2.0000E+00 4.0000E+00 -3.0000E+00 0.0000E+00 1.0000E+00 3.0000E+00
+ 1.0000E+00 6.2559E-04 6.4875E-05 5.0367E-04
+ 1.0000E+00 -6.2559E-04 6.4875E-05 5.0367E-04
+ 2.0000E+00 1.0001E+00 5.4076E-02 2.3507E-01
+ 2.0000E+00 -1.0001E+00 5.4076E-02 2.3507E-01
+ 3.0000E+00 0.0000E+00 8.6149E-01 5.4838E-07
+ 3.0000E+00 0.0000E+00 1.2425E-01 1.2770E-06
+ 10
+ 1.0000E+00 1.0000E+00 1.0000E+00 -2.0000E+00 1.0000E+00 -1.0000E+00
+ 2.0000E+00 -2.0000E+00 4.0000E+00 -3.0000E+00
+ -1.0000E+00 2.0000E+00 3.0000E+00 -4.0000E+00 2.0000E+00 -2.0000E+00
+ 4.0000E+00 -4.0000E+00 8.0000E+00 -6.0000E+00
+ -1.0000E+00 0.0000E+00 5.0000E+00 -5.0000E+00 3.0000E+00 -3.0000E+00
+ 6.0000E+00 -6.0000E+00 1.2000E+01 -9.0000E+00
+ -1.0000E+00 0.0000E+00 3.0000E+00 -4.0000E+00 4.0000E+00 -4.0000E+00
+ 8.0000E+00 -8.0000E+00 1.6000E+01 -1.2000E+01
+ -1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 5.0000E+00 -4.0000E+00
+ 1.0000E+01 -1.0000E+01 2.0000E+01 -1.5000E+01
+ -1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 2.0000E+00 -2.0000E+00
+ 1.2000E+01 -1.2000E+01 2.4000E+01 -1.8000E+01
+ -1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 2.0000E+00 -5.0000E+00
+ 1.5000E+01 -1.3000E+01 2.8000E+01 -2.1000E+01
+ -1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 2.0000E+00 -5.0000E+00
+ 1.2000E+01 -1.1000E+01 3.2000E+01 -2.4000E+01
+ -1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 2.0000E+00 -5.0000E+00
+ 1.2000E+01 -1.4000E+01 3.7000E+01 -2.6000E+01
+ -1.0000E+00 0.0000E+00 3.0000E+00 -6.0000E+00 2.0000E+00 -5.0000E+00
+ 1.2000E+01 -1.4000E+01 3.6000E+01 -2.5000E+01
+ 1.0000E+00 0.0000E+00 3.6037E-02 7.9613E-02
+ 1.9867E+00 0.0000E+00 7.4283E-05 7.4025E-06
+ 2.0000E+00 2.5052E-03 1.4346E-04 6.7839E-07
+ 2.0000E+00 -2.5052E-03 1.4346E-04 6.7839E-07
+ 2.0067E+00 1.1763E-02 6.7873E-05 5.7496E-06
+ 2.0067E+00 -1.1763E-02 6.7873E-05 5.7496E-06
+ 2.9970E+00 0.0000E+00 9.2779E-05 2.6519E-06
+ 3.0000E+00 8.7028E-04 2.7358E-04 1.9407E-07
+ 3.0000E+00 -8.7028E-04 2.7358E-04 1.9407E-07
+ 3.0030E+00 0.0000E+00 9.2696E-05 2.6477E-06
+ 0
+SSX Data file for the Real Nonsymmetric Schur Form Expert Driver
+6 Number of matrix dimensions
+0 1 2 3 5 10 20 Matrix dimensions
+3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
+20.0 Threshold for test ratios
+T
+2 Read another line with random number generator seed
+2518 3899 995 397 Seed for random number generator
+SSX 21 Use all matrix types
+ 1 1
+ 1
+ 0.00000E+00
+ 1.00000E+00 0.00000E+00
+ 1 1
+ 1
+ 1.00000E+00
+ 1.00000E+00 1.00000E+00
+ 6 6
+ 1 2 3 4 5 6
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 1.00000E+00 4.43734E-31
+ 6 0
+ 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
+ 1.00000E+00 1.00000E+00
+ 6 6
+ 1 2 3 4 5 6
+ 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
+ 1.00000E+00 2.00000E+00
+ 6 1
+ 1
+ 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00
+ 1.00000E+00 2.00000E+00
+ 6 3
+ 4 5 6
+ 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 2.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 3.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 4.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 5.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 6.00000E+00
+ 1.00000E+00 1.00000E+00
+ 2 1
+ 1
+ 1.00000E+00 2.00000E+00
+ 0.00000E+00 3.00000E+00
+ 7.07107E-01 2.00000E+00
+ 4 2
+ 1 2
+ 8.52400E-01 5.61100E-01 7.04300E-01 9.54000E-01
+ 2.79800E-01 7.21600E-01 9.61300E-01 3.58200E-01
+ 7.08100E-01 4.09400E-01 2.25000E-01 9.51800E-01
+ 5.54300E-01 5.22000E-01 6.86000E-01 3.07000E-02
+ 7.22196E-01 4.63943E-01
+ 7 6
+ 1 2 3 4 5 6
+ 7.81800E-01 5.65700E-01 7.62100E-01 7.43600E-01 2.55300E-01 4.10000E-01
+ 1.34000E-02
+ 6.45800E-01 2.66600E-01 5.51000E-01 8.31800E-01 9.27100E-01 6.20900E-01
+ 7.83900E-01
+ 1.31600E-01 4.91400E-01 1.77100E-01 1.96400E-01 1.08500E-01 9.27000E-01
+ 2.24700E-01
+ 6.41000E-01 4.68900E-01 9.65900E-01 8.88400E-01 3.76900E-01 9.67300E-01
+ 6.18300E-01
+ 8.38200E-01 8.74300E-01 4.50700E-01 9.44200E-01 7.75500E-01 9.67600E-01
+ 7.83100E-01
+ 3.25900E-01 7.38900E-01 8.30200E-01 4.52100E-01 3.01500E-01 2.13300E-01
+ 8.43400E-01
+ 5.24400E-01 5.01600E-01 7.52900E-01 3.83800E-01 8.47900E-01 9.12800E-01
+ 5.77000E-01
+ 9.43220E-01 3.20530E+00
+ 4 2
+ 2 3
+ -9.85900E-01 1.47840E+00 -1.33600E-01 -2.95970E+00
+ -4.33700E-01 -6.54000E-01 -7.15500E-01 1.23760E+00
+ -7.36300E-01 -1.97680E+00 -1.95100E-01 3.43200E-01
+ 6.41400E-01 -1.40880E+00 6.39400E-01 8.58000E-02
+ 5.22869E-01 5.45530E-01
+ 7 5
+ 1 2 3 4 5
+ 2.72840E+00 2.15200E-01 -1.05200E+00 -2.44600E-01 -6.53000E-02 3.90500E-01
+ 1.40980E+00
+ 9.75300E-01 6.51500E-01 -4.76200E-01 5.42100E-01 6.20900E-01 4.75900E-01
+ -1.44930E+00
+ -9.05200E-01 1.79000E-01 -7.08600E-01 4.62100E-01 1.05800E+00 2.24260E+00
+ 1.58260E+00
+ -7.17900E-01 -2.53400E-01 -4.73900E-01 -1.08100E+00 4.13800E-01 -9.50000E-02
+ 1.45300E-01
+ -1.37990E+00 -1.06490E+00 1.25580E+00 7.80100E-01 -6.40500E-01 -8.61000E-02
+ 8.30000E-02
+ 2.84900E-01 -1.29900E-01 4.80000E-02 -2.58600E-01 4.18900E-01 1.37680E+00
+ 8.20800E-01
+ -5.44200E-01 9.74900E-01 9.55800E-01 1.23700E-01 1.09020E+00 -1.40600E-01
+ 1.90960E+00
+ 6.04729E-01 9.00391E-01
+ 6 4
+ 3 4 5 6
+ 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00
+ 1.00000E-06 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 5.00000E-01
+ 4.89525E-05 4.56492E-05
+ 8 4
+ 1 2 3 4
+ 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 1.00000E+01 0.00000E+00
+ 1.00000E+01 0.00000E+00
+ 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 1.00000E+01
+ 1.00000E+01 0.00000E+00
+ 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 1.00000E+01
+ 1.00000E+01 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 1.00000E+01
+ 0.00000E+00 1.00000E+01
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 5.00000E-01 1.00000E+00
+ 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 5.00000E-01
+ 1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 5.00000E-01 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 5.00000E-01
+ 9.56158E-05 4.14317E-05
+ 9 3
+ 1 2 3
+ 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 7.50000E-01 1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 7.50000E-01 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 7.50000E-01
+ 1.00000E+00 5.55801E-07
+ 10 4
+ 1 2 3 4
+ 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 8.75000E-01 1.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 8.75000E-01 1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 8.75000E-01 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 8.75000E-01
+ 1.00000E+00 1.16972E-10
+ 12 6
+ 1 2 3 4 5 6
+ 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 1.00000E+01 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 1.00000E+01 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 1.00000E+01 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+01 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 -1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+01 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+01
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 9.37500E-01 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 9.37500E-01 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 9.37500E-01 1.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 9.37500E-01 1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 9.37500E-01 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 9.37500E-01
+ 1.85655E-10 2.20147E-16
+ 12 7
+ 6 7 8 9 10 11 12
+ 1.20000E+01 1.10000E+01 1.00000E+01 9.00000E+00 8.00000E+00 7.00000E+00
+ 6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
+ 1.10000E+01 1.10000E+01 1.00000E+01 9.00000E+00 8.00000E+00 7.00000E+00
+ 6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
+ 0.00000E+00 1.00000E+01 1.00000E+01 9.00000E+00 8.00000E+00 7.00000E+00
+ 6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 9.00000E+00 9.00000E+00 8.00000E+00 7.00000E+00
+ 6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 8.00000E+00 8.00000E+00 7.00000E+00
+ 6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 7.00000E+00 7.00000E+00
+ 6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 6.00000E+00
+ 6.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 5.00000E+00 5.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 4.00000E+00 4.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 3.00000E+00 3.00000E+00 2.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 2.00000E+00 2.00000E+00 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 1.00000E+00
+ 6.92558E-05 5.52606E-05
+ 3 1
+ 1
+ 2.00000E-06 1.00000E+00 -2.00000E+00
+ 1.00000E-06 -2.00000E+00 4.00000E+00
+ 0.00000E+00 1.00000E+00 -2.00000E+00
+ 7.30297E-01 4.00000E+00
+ 5 1
+ 3
+ 2.00000E-03 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 1.00000E-03 1.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 -1.00000E-03 1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 -2.00000E-03 1.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 3.99999E-12 3.99201E-12
+ 6 4
+ 1 2 3 5
+ 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 1.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
+ 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 0.00000E+00
+ 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00
+ 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00
+ 2.93294E-01 1.63448E-01
+ 6 2
+ 3 4
+ 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00
+ 1.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 1.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00
+ 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00 1.00000E+00
+ -1.00000E+00 0.00000E+00 0.00000E+00 0.00000E+00 1.00000E+00 0.00000E+00
+ 3.97360E-01 3.58295E-01
+ 6 3
+ 3 4 5
+ 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00 1.00000E+00
+ 5.00000E-01 3.33300E-01 2.50000E-01 2.00000E-01 1.66700E-01 1.42900E-01
+ 3.33300E-01 2.50000E-01 2.00000E-01 1.66700E-01 1.42900E-01 1.25000E-01
+ 2.50000E-01 2.00000E-01 1.66700E-01 1.42900E-01 1.25000E-01 1.11100E-01
+ 2.00000E-01 1.66700E-01 1.42900E-01 1.25000E-01 1.11100E-01 1.00000E-01
+ 1.66700E-01 1.42900E-01 1.25000E-01 1.11100E-01 1.00000E-01 9.09000E-02
+ 7.28934E-01 1.24624E-02
+ 5 1
+ 1
+ 1.50000E+01 1.10000E+01 6.00000E+00 -9.00000E+00 -1.50000E+01
+ 1.00000E+00 3.00000E+00 9.00000E+00 -3.00000E+00 -8.00000E+00
+ 7.00000E+00 6.00000E+00 6.00000E+00 -3.00000E+00 -1.10000E+01
+ 7.00000E+00 7.00000E+00 5.00000E+00 -3.00000E+00 -1.10000E+01
+ 1.70000E+01 1.20000E+01 5.00000E+00 -1.00000E+01 -1.60000E+01
+ 2.17680E-01 5.22626E-01
+ 6 2
+ 1 2
+ -9.00000E+00 2.10000E+01 -1.50000E+01 4.00000E+00 2.00000E+00 0.00000E+00
+ -1.00000E+01 2.10000E+01 -1.40000E+01 4.00000E+00 2.00000E+00 0.00000E+00
+ -8.00000E+00 1.60000E+01 -1.10000E+01 4.00000E+00 2.00000E+00 0.00000E+00
+ -6.00000E+00 1.20000E+01 -9.00000E+00 3.00000E+00 3.00000E+00 0.00000E+00
+ -4.00000E+00 8.00000E+00 -6.00000E+00 0.00000E+00 5.00000E+00 0.00000E+00
+ -2.00000E+00 4.00000E+00 -3.00000E+00 0.00000E+00 1.00000E+00 3.00000E+00
+ 6.78904E-02 4.22005E-02
+ 10 1
+ 1
+ 1.00000E+00 1.00000E+00 1.00000E+00 -2.00000E+00 1.00000E+00 -1.00000E+00
+ 2.00000E+00 -2.00000E+00 4.00000E+00 -3.00000E+00
+ -1.00000E+00 2.00000E+00 3.00000E+00 -4.00000E+00 2.00000E+00 -2.00000E+00
+ 4.00000E+00 -4.00000E+00 8.00000E+00 -6.00000E+00
+ -1.00000E+00 0.00000E+00 5.00000E+00 -5.00000E+00 3.00000E+00 -3.00000E+00
+ 6.00000E+00 -6.00000E+00 1.20000E+01 -9.00000E+00
+ -1.00000E+00 0.00000E+00 3.00000E+00 -4.00000E+00 4.00000E+00 -4.00000E+00
+ 8.00000E+00 -8.00000E+00 1.60000E+01 -1.20000E+01
+ -1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 5.00000E+00 -4.00000E+00
+ 1.00000E+01 -1.00000E+01 2.00000E+01 -1.50000E+01
+ -1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 2.00000E+00 -2.00000E+00
+ 1.20000E+01 -1.20000E+01 2.40000E+01 -1.80000E+01
+ -1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 2.00000E+00 -5.00000E+00
+ 1.50000E+01 -1.30000E+01 2.80000E+01 -2.10000E+01
+ -1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 2.00000E+00 -5.00000E+00
+ 1.20000E+01 -1.10000E+01 3.20000E+01 -2.40000E+01
+ -1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 2.00000E+00 -5.00000E+00
+ 1.20000E+01 -1.40000E+01 3.70000E+01 -2.60000E+01
+ -1.00000E+00 0.00000E+00 3.00000E+00 -6.00000E+00 2.00000E+00 -5.00000E+00
+ 1.20000E+01 -1.40000E+01 3.60000E+01 -2.50000E+01
+ 3.60372E-02 7.96134E-02
+ 0 0
diff --git a/TESTING/sep.in b/TESTING/sep.in
new file mode 100644
index 0000000..24fae47
--- /dev/null
+++ b/TESTING/sep.in
@@ -0,0 +1,13 @@
+SEP: Data file for testing Symmetric Eigenvalue Problem routines
+6 Number of values of N
+0 1 2 3 5 20 Values of N (dimension)
+5 Number of values of NB
+1 3 3 3 10 Values of NB (blocksize)
+2 2 2 2 2 Values of NBMIN (minimum blocksize)
+1 0 5 9 1 Values of NX (crossover point)
+50.0 Threshold value
+T Put T to test the LAPACK routines
+T Put T to test the driver routines
+T Put T to test the error exits
+1 Code to interpret the seed
+SEP 21
diff --git a/TESTING/sgbak.in b/TESTING/sgbak.in
new file mode 100644
index 0000000..6e6622a
--- /dev/null
+++ b/TESTING/sgbak.in
@@ -0,0 +1,266 @@
+SGK: Tests SGGBAK
+ 6 3
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.3000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.4000E+01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.5000E+01 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.6000E+01
+
+ 0.6000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.5000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.4000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.3000E+01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.2000E+01 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
+
+ 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.2000E+01 0.2000E+01 0.2000E+01
+ 0.3000E+01 0.3000E+01 0.3000E+01
+ 0.4000E+01 0.4000E+01 0.4000E+01
+ 0.5000E+01 0.5000E+01 0.5000E+01
+ 0.6000E+01 0.6000E+01 0.6000E+01
+
+ -0.1000E+01 -0.1000E+01 -0.1000E+01
+ -0.2000E+01 -0.2000E+01 -0.2000E+01
+ -0.3000E+01 -0.3000E+01 -0.3000E+01
+ -0.4000E+01 -0.4000E+01 -0.4000E+01
+ -0.5000E+01 -0.5000E+01 -0.5000E+01
+ -0.6000E+01 -0.6000E+01 -0.6000E+01
+
+ 6 3
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.2000E+01 0.2100E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.3000E+01 0.3100E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.4000E+01 0.4100E+01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.5000E+01 0.5100E+01 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.6000E+01 0.6100E+01
+
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.3000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.4000E+01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.5000E+01 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.6000E+01
+
+ 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.2000E+01 0.2000E+01 0.2000E+01
+ 0.3000E+01 0.3000E+01 0.3000E+01
+ 0.4000E+01 0.4000E+01 0.4000E+01
+ 0.5000E+01 0.5000E+01 0.5000E+01
+ 0.6000E+01 0.6000E+01 0.6000E+01
+
+ -0.1000E+01 -0.1000E+01 -0.1000E+01
+ -0.2000E+01 -0.2000E+01 -0.2000E+01
+ -0.3000E+01 -0.3000E+01 -0.3000E+01
+ -0.4000E+01 -0.4000E+01 -0.4000E+01
+ -0.5000E+01 -0.5000E+01 -0.5000E+01
+ -0.6000E+01 -0.6000E+01 -0.6000E+01
+
+ 5 5
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.1000E+01 0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.0000E+00 0.0000E+00
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.0000E+00
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01
+
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
+
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.2000E+01 0.2000E+01 0.2000E+01 0.2000E+01 0.2000E+01
+ 0.3000E+01 0.3000E+01 0.3000E+01 0.3000E+01 0.3000E+01
+ 0.4000E+01 0.4000E+01 0.4000E+01 0.4000E+01 0.4000E+01
+ 0.5000E+01 0.5000E+01 0.5000E+01 0.5000E+01 0.5000E+01
+
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.2000E+01 0.2000E+01 0.2000E+01 0.2000E+01 0.2000E+01
+ 0.3000E+01 0.3000E+01 0.3000E+01 0.3000E+01 0.3000E+01
+ 0.4000E+01 0.4000E+01 0.4000E+01 0.4000E+01 0.4000E+01
+ 0.5000E+01 0.5000E+01 0.5000E+01 0.5000E+01 0.5000E+01
+
+ 6 5
+ 0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11
+ 0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+
+ 0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11
+ 0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+
+ 0.1000E+01 0.2000E+01 -0.3000E+01 0.4000E+01 0.5000E+01
+ 0.8000E+01 0.9000E+01 0.0000E+00 0.9000E+01 0.2000E+01
+ 0.0000E+00 -0.9000E+01 0.2000E+01 0.1000E+01 0.1000E+01
+ 0.8000E+01 0.2000E+01 0.1000E+01 0.0000E+00 0.2000E+01
+ 0.0000E+00 0.3000E+01 0.2000E+01 0.1000E+01 0.1000E+01
+ 0.2000E+01 0.1000E+01 0.9000E+01 0.0000E+00 0.1000E+01
+
+ 0.1000E+01 -0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01
+ -0.8000E+01 0.9000E+01 0.0000E+00 0.9000E+01 0.2000E+01
+ 0.0000E+00 0.9000E+01 0.2000E+01 0.1000E+01 0.1000E+01
+ 0.8000E+01 0.2000E+01 0.1000E+01 0.0000E+00 0.2000E+01
+ 0.0000E+00 0.3000E+01 0.2000E+01 0.1000E+01 0.1000E+01
+ 0.2000E+01 0.8000E+01 0.9000E+01 0.0000E+00 0.1000E+01
+
+ 6 2
+ 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E-05 0.1000E+07
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E-05 0.1000E-05
+ 0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+07 0.1000E+07
+
+ 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E-05 0.1000E+07
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E-05 0.1000E-05
+ 0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+07 0.1000E+07
+
+ 0.1000E+01 0.1000E+01
+ 0.2000E+01 0.2000E+01
+ 0.3000E+01 0.3000E+01
+ 0.4000E+01 0.4000E+01
+ 0.5000E+01 0.5000E+01
+ 0.6000E+01 0.6000E+01
+
+ 0.1100E+01 0.1100E+01
+ 0.2200E+01 0.2200E+01
+ 0.3300E+01 0.3300E+01
+ 0.4400E+01 0.4400E+01
+ 0.5500E+01 0.5500E+01
+ 0.6600E+01 0.6600E+01
+
+ 7 3
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.1000E+01
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.1000E+01
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+
+ 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.2000E+01 0.2000E+01 0.2000E+01
+ 0.3000E+01 0.3000E+01 0.3000E+01
+ 0.4000E+01 0.4000E+01 0.4000E+01
+ 0.5000E+01 0.5000E+01 0.5000E+01
+ 0.6000E+01 0.6000E+01 0.6000E+01
+ 0.7000E+01 0.7000E+01 0.7000E+01
+
+ -0.1000E+01 -0.1000E+01 -0.1000E+01
+ -0.2000E+01 -0.2000E+01 -0.2000E+01
+ -0.3000E+01 -0.3000E+01 -0.3000E+01
+ -0.4000E+01 -0.4000E+01 -0.4000E+01
+ -0.5000E+01 -0.5000E+01 -0.5000E+01
+ -0.6000E+01 -0.6000E+01 -0.6000E+01
+ -0.7000E+01 -0.7000E+01 -0.7000E+01
+
+ 7 3
+ 0.0000E+00 0.1000E+04 0.0000E+00 0.1000E+04 0.1000E+04 0.1000E+04
+ 0.1000E-04
+ 0.0000E+00 0.1000E-04 0.1000E+04 0.1000E-04 0.1000E-04 0.1000E+04
+ 0.1000E+04
+ 0.1000E+04 0.1000E+04 0.1000E-04 0.1000E+04 0.1000E+04 0.1000E+04
+ 0.1000E+04
+ 0.0000E+00 0.1000E-04 0.0000E+00 0.1000E+00 0.1000E+04 0.1000E-04
+ 0.1000E+04
+ 0.0000E+00 0.1000E+04 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00
+ 0.0000E+00 0.4000E-04 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.1000E-04
+ 0.0000E+00 0.1000E+04 0.0000E+00 0.1000E+04 0.1000E+04 0.1000E-04
+ 0.1000E+04
+
+ 0.0000E+00 0.1000E-01 0.0000E+00 0.1000E+04 0.1000E-04 0.1000E+04
+ 0.1000E+04
+ 0.0000E+00 0.1000E+04 0.1000E+04 0.1000E+04 0.1000E+04 0.1000E+00
+ 0.1000E+04
+ 0.1000E+04 0.1000E+04 0.1000E+04 0.1000E+04 0.1000E-04 0.1000E+04
+ 0.1000E+04
+ 0.0000E+00 0.4000E-01 0.0000E+00 0.1000E+04 0.1000E+01 0.1000E+04
+ 0.1000E+04
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.1000E+01
+ 0.0000E+00 0.1000E-04 0.0000E+00 0.1000E+04 0.1000E+01 0.1000E+01
+ 0.1000E-04
+
+ 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.2000E+01 0.2000E+01 0.2000E+01
+ 0.3000E+01 0.3000E+01 0.3000E+01
+ 0.4000E+01 0.4000E+01 0.4000E+01
+ 0.5000E+01 0.5000E+01 0.5000E+01
+ 0.6000E+01 0.6000E+01 0.6000E+01
+ 0.7000E+01 0.7000E+01 0.7000E+01
+
+ 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.2000E+01 0.2000E+01 0.2000E+01
+ 0.3000E+01 0.3000E+01 0.3000E+01
+ 0.4000E+01 0.4000E+01 0.4000E+01
+ 0.5000E+01 0.5000E+01 0.5000E+01
+ 0.6000E+01 0.6000E+01 0.6000E+01
+ 0.7000E+01 0.7000E+01 0.7000E+01
+
+ 6 2
+ -0.2000E+02 -0.1000E+05 -0.2000E+01 -0.1000E+07 -0.1000E+02 -0.2000E+06
+ 0.6000E-02 0.4000E+01 0.6000E-03 0.2000E+03 0.3000E-02 0.3000E+02
+ -0.2000E+00 -0.3000E+03 -0.4000E-01 -0.1000E+05 0.0000E+00 0.3000E+04
+ 0.6000E-04 0.4000E-01 0.9000E-05 0.9000E+01 0.3000E-04 0.5000E+00
+ 0.6000E-01 0.5000E+02 0.8000E-02 -0.4000E+04 0.8000E-01 0.0000E+00
+ 0.0000E+00 0.1000E+04 0.7000E+00 -0.2000E+06 0.1300E+02 -0.6000E+05
+
+ -0.2000E+02 -0.1000E+05 0.2000E+01 -0.2000E+07 0.1000E+02 -0.1000E+06
+ 0.5000E-02 0.3000E+01 -0.2000E-03 0.4000E+03 -0.1000E-02 0.3000E+02
+ 0.0000E+00 -0.1000E+03 -0.8000E-01 0.2000E+05 -0.4000E+00 0.0000E+00
+ 0.5000E-04 0.3000E-01 0.2000E-05 0.4000E+01 0.2000E-04 0.1000E+00
+ 0.4000E-01 0.3000E+02 -0.1000E-02 0.3000E+04 -0.1000E-01 0.6000E+03
+ -0.1000E+01 0.0000E+00 0.4000E+00 -0.1000E+06 0.4000E+01 0.2000E+05
+
+ 0.1000E+01 0.1000E+01
+ 0.2000E+01 0.2000E+01
+ 0.3000E+01 0.3000E+01
+ 0.4000E+01 0.4000E+01
+ 0.5000E+01 0.5000E+01
+ 0.6000E+01 0.6000E+01
+
+ 0.1000E+02 0.1000E+02
+ 0.2000E+02 0.2000E+02
+ 0.3000E+02 0.3000E+02
+ 0.4000E+02 0.4000E+02
+ 0.5000E+02 0.5000E+02
+ 0.6000E+02 0.6000E+02
+
+0 0
diff --git a/TESTING/sgbal.in b/TESTING/sgbal.in
new file mode 100644
index 0000000..c4edce3
--- /dev/null
+++ b/TESTING/sgbal.in
@@ -0,0 +1,304 @@
+SGL: Tests SGGBAL
+ 6
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.3000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.4000E+01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.5000E+01 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.6000E+01
+
+ 0.6000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.5000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.4000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.3000E+01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.2000E+01 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
+
+ 1 1
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.3000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.4000E+01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.5000E+01 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.6000E+01
+
+ 0.6000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.5000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.4000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.3000E+01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.2000E+01 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
+
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01 0.6000E+01
+
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01 0.6000E+01
+
+ 6
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.1000E+01 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.1000E+01 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01
+
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
+
+ 1 1
+ 0.1000E+01 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.1000E+01 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
+
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
+
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+
+ 6
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.1000E+01 0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.0000E+00 0.0000E+00
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01 0.0000E+00
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01 0.6000E+01
+
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.1000E+01 0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.0000E+00 0.0000E+00
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01 0.0000E+00
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01 0.6000E+01
+
+ 1 1
+ 0.6000E+01 0.5000E+01 0.4000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+ 0.0000E+00 0.5000E+01 0.4000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.4000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.3000E+01 0.2000E+01 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.2000E+01 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
+
+ 0.6000E+01 0.5000E+01 0.4000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+ 0.0000E+00 0.5000E+01 0.4000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.4000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.3000E+01 0.2000E+01 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.2000E+01 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
+
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+
+ 5
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.1000E+01 0.2000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.0000E+00 0.0000E+00
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.0000E+00
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.4000E+01 0.5000E+01
+
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
+
+ 1 1
+ 0.5000E+01 0.4000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+ 0.0000E+00 0.4000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.3000E+01 0.2000E+01 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.2000E+01 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
+
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
+
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+
+ 0.1000E+01 0.2000E+01 0.3000E+01 0.2000E+01 0.1000E+01
+
+ 6
+ 0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11
+ 0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+
+ 0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11
+ 0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11 0.1000E+11
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11 0.1000E+11
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11 0.1000E+11
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+11
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+
+ 1 6
+ 0.1000E-03 0.1000E+05 0.1000E+04 0.1000E+02 0.1000E+00 0.1000E-01
+ 0.1000E-02 0.1000E-04 0.1000E+05 0.1000E+03 0.1000E+01 0.1000E+00
+ 0.1000E+00 0.1000E-02 0.1000E-03 0.1000E+05 0.1000E+03 0.1000E+02
+ 0.1000E+02 0.1000E+00 0.1000E-01 0.1000E-03 0.1000E+05 0.1000E+04
+ 0.1000E+03 0.1000E+01 0.1000E+00 0.1000E-02 0.1000E-04 0.1000E+05
+ 0.1000E+05 0.1000E+03 0.1000E+02 0.1000E+00 0.1000E-02 0.1000E-03
+
+ 0.1000E-03 0.1000E+05 0.1000E+04 0.1000E+02 0.1000E+00 0.1000E-01
+ 0.1000E-02 0.1000E-04 0.1000E+05 0.1000E+03 0.1000E+01 0.1000E+00
+ 0.1000E+00 0.1000E-02 0.1000E-03 0.1000E+05 0.1000E+03 0.1000E+02
+ 0.1000E+02 0.1000E+00 0.1000E-01 0.1000E-03 0.1000E+05 0.1000E+04
+ 0.1000E+03 0.1000E+01 0.1000E+00 0.1000E-02 0.1000E-04 0.1000E+05
+ 0.1000E+05 0.1000E+03 0.1000E+02 0.1000E+00 0.1000E-02 0.1000E-03
+
+ 0.1000E-05 0.1000E-04 0.1000E-02 0.1000E+00 0.1000E+01 0.1000E+03
+
+ 0.1000E+03 0.1000E+01 0.1000E+00 0.1000E-02 0.1000E-04 0.1000E-05
+
+ 6
+ 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E-05 0.1000E+07
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E-05 0.1000E-05
+ 0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+07 0.1000E+07
+
+ 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E-05 0.1000E+07
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E-05 0.1000E-05
+ 0.1000E+07 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+07 0.1000E+07
+
+ 4 6
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E-04 0.1000E+04 0.1000E+00
+ 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E-04 0.1000E+04 0.1000E+00
+ 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E-04 0.1000E+04 0.1000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E-03 0.1000E+05
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+05 0.1000E+01 0.1000E-03
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E-03 0.1000E+05 0.1000E+01
+
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E-04 0.1000E+04 0.1000E+00
+ 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E-04 0.1000E+04 0.1000E+00
+ 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E-04 0.1000E+04 0.1000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E-03 0.1000E+05
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+05 0.1000E+01 0.1000E-03
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E-03 0.1000E+05 0.1000E+01
+
+ 0.4000E+01 0.4000E+01 0.4000E+01 0.1000E+00 0.1000E+04 0.1000E-04
+
+ 0.2000E+01 0.3000E+01 0.4000E+01 0.1000E-04 0.1000E+04 0.1000E+00
+
+ 7
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.1000E+01
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.0000E+00
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.1000E+01
+ 0.0000E+00 0.1000E+01 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+
+ 3 5
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.1000E+01
+
+ 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.1000E+01 0.1000E+01 0.1000E+01 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.1000E+01
+ 0.1000E+01
+ 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00 0.0000E+00
+ 0.1000E+01
+
+ 0.3000E+01 0.2000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.6000E+01
+ 0.5000E+01
+
+ 0.1000E+01 0.3000E+01 0.1000E+01 0.1000E+01 0.1000E+01 0.2000E+01
+ 0.2000E+01
+
+ 6
+ -0.2000E+02 -0.1000E+05 -0.2000E+01 -0.1000E+07 -0.1000E+02 -0.2000E+06
+ 0.6000E-02 0.4000E+01 0.6000E-03 0.2000E+03 0.3000E-02 0.3000E+02
+ -0.2000E+00 -0.3000E+03 -0.4000E-01 -0.1000E+05 0.0000E+00 0.3000E+04
+ 0.6000E-04 0.4000E-01 0.9000E-05 0.9000E+01 0.3000E-04 0.5000E+00
+ 0.6000E-01 0.5000E+02 0.8000E-02 -0.4000E+04 0.8000E-01 0.0000E+00
+ 0.0000E+00 0.1000E+04 0.7000E+00 -0.2000E+06 0.1300E+02 -0.6000E+05
+
+ -0.2000E+02 -0.1000E+05 0.2000E+01 -0.2000E+07 0.1000E+02 -0.1000E+06
+ 0.5000E-02 0.3000E+01 -0.2000E-03 0.4000E+03 -0.1000E-02 0.3000E+02
+ 0.0000E+00 -0.1000E+03 -0.8000E-01 0.2000E+05 -0.4000E+00 0.0000E+00
+ 0.5000E-04 0.3000E-01 0.2000E-05 0.4000E+01 0.2000E-04 0.1000E+00
+ 0.4000E-01 0.3000E+02 -0.1000E-02 0.3000E+04 -0.1000E-01 0.6000E+03
+ -0.1000E+01 0.0000E+00 0.4000E+00 -0.1000E+06 0.4000E+01 0.2000E+05
+
+ 1 6
+ -0.2000E+00 -0.1000E+01 -0.2000E+00 -0.1000E+01 -0.1000E+01 -0.2000E+01
+ 0.6000E+00 0.4000E+01 0.6000E+00 0.2000E+01 0.3000E+01 0.3000E+01
+ -0.2000E+00 -0.3000E+01 -0.4000E+00 -0.1000E+01 0.0000E+00 0.3000E+01
+ 0.6000E+00 0.4000E+01 0.9000E+00 0.9000E+01 0.3000E+01 0.5000E+01
+ 0.6000E+00 0.5000E+01 0.8000E+00 -0.4000E+01 0.8000E+01 0.0000E+00
+ 0.0000E+00 0.1000E+01 0.7000E+00 -0.2000E+01 0.1300E+02 -0.6000E+01
+
+ -0.2000E+00 -0.1000E+01 0.2000E+00 -0.2000E+01 0.1000E+01 -0.1000E+01
+ 0.5000E+00 0.3000E+01 -0.2000E+00 0.4000E+01 -0.1000E+01 0.3000E+01
+ 0.0000E+00 -0.1000E+01 -0.8000E+00 0.2000E+01 -0.4000E+01 0.0000E+00
+ 0.5000E+00 0.3000E+01 0.2000E+00 0.4000E+01 0.2000E+01 0.1000E+01
+ 0.4000E+00 0.3000E+01 -0.1000E+00 0.3000E+01 -0.1000E+01 0.6000E+01
+ -0.1000E+00 0.0000E+00 0.4000E+00 -0.1000E+01 0.4000E+01 0.2000E+01
+
+ 0.1000E-02 0.1000E+02 0.1000E+00 0.1000E+04 0.1000E+01 0.1000E-01
+
+ 0.1000E+02 0.1000E+00 0.1000E+03 0.1000E-02 0.1000E+03 0.1000E-01
+
+0
diff --git a/TESTING/sgd.in b/TESTING/sgd.in
new file mode 100644
index 0000000..79a70bc
--- /dev/null
+++ b/TESTING/sgd.in
@@ -0,0 +1,86 @@
+SGS Data for the Real Nonsymmetric Schur Form Driver
+5 Number of matrix dimensions
+2 6 10 12 20 30 Matrix dimensions
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+SGS 26 Test all 26 matrix types
+SGV Data for the Real Nonsymmetric Eigenvalue Problem Driver
+6 Number of matrix dimensions
+2 6 8 10 15 20 Matrix dimensions
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold value
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+SGV 26 Test all 26 matrix types
+SGX Data for the Real Nonsymmetric Schur Form Expert Driver
+2 Largest matrix dimension (0 <= NSIZE <= 5)
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+SGX Data for the Real Nonsymmetric Schur Form Expert Driver
+0 Largest matrix dimension (0 <= NSIZE <= 5)
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+ 4
+ 2
+ 8.0000E+00 4.0000E+00 -1.3000E+01 4.0000E+00 Input matrix A
+ 0.0000E+00 7.0000E+00 -2.4000E+01 -3.0000E+00
+ 0.0000E+00 0.0000E+00 3.0000E+00 -5.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 1.6000E+01
+ 9.0000E+00 -1.0000E+00 1.0000E+00 -6.0000E+00 Input matrix B
+ 0.0000E+00 4.0000E+00 1.6000E+01 -2.4000E+01
+ 0.0000E+00 0.0000E+00 -1.1000E+01 6.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 4.0000E+00
+ 2.5901E-01 1.7592E+00 Condition #'s for cluster selected from lower 2x2
+ 4
+ 2
+ 1.0000E+00 2.0000E+00 3.0000E+00 4.0000E+00 Input matrix A
+ 0.0000E+00 5.0000E+00 6.0000E+00 7.0000E+00
+ 0.0000E+00 0.0000E+00 8.0000E+00 9.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+01
+ -1.0000E+00 -1.0000E+00 -1.0000E+00 -1.0000E+00 Input matrix B
+ 0.0000E+00 -1.0000E+00 -1.0000E+00 -1.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 -1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
+ 9.8173E-01 6.3649E-01 Condition #'s for cluster selected from lower 2x2
+0
+SXV Data for the Real Nonsymmetric Eigenvalue Expert Driver
+5 Largest matrix dimension
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+SXV Data for the Real Nonsymmetric Eigenvalue Expert Driver
+0 Largest matrix dimension
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+ 4
+ 8.0000E+00 4.0000E+00 -1.3000E+01 4.0000E+00 Input matrix A
+ 0.0000E+00 7.0000E+00 -2.4000E+01 -3.0000E+00
+ 0.0000E+00 0.0000E+00 3.0000E+00 -5.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 1.6000E+01
+ 9.0000E+00 -1.0000E+00 1.0000E+00 -6.0000E+00 Input matrix B
+ 0.0000E+00 4.0000E+00 1.6000E+01 -2.4000E+01
+ 0.0000E+00 0.0000E+00 -1.1000E+01 6.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 4.0000E+00
+ 3.1476E+00 2.5286E+00 4.2241E+00 3.4160E+00 eigenvalue condition #'s
+ 6.7340E-01 1.1380E+00 3.5424E+00 9.5917E-01 eigenvector condition #'s
+ 4
+ 1.0000E+00 2.0000E+00 3.0000E+00 4.0000E+00 Input matrix A
+ 0.0000E+00 5.0000E+00 6.0000E+00 7.0000E+00
+ 0.0000E+00 0.0000E+00 8.0000E+00 9.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+01
+ -1.0000E+00 -1.0000E+00 -1.0000E+00 -1.0000E+00 Input matrix B
+ 0.0000E+00 -1.0000E+00 -1.0000E+00 -1.0000E+00
+ 0.0000E+00 0.0000E+00 1.0000E+00 -1.0000E+00
+ 0.0000E+00 0.0000E+00 0.0000E+00 1.0000E+00
+ 1.3639E+00 4.0417E+00 6.4089E-01 6.8030E-01 eigenvalue condition #'s
+ 7.6064E-01 8.4964E-01 1.1222E-01 1.1499E-01 eigenvector condition #'s
+0
diff --git a/TESTING/sgg.in b/TESTING/sgg.in
new file mode 100644
index 0000000..367f961
--- /dev/null
+++ b/TESTING/sgg.in
@@ -0,0 +1,15 @@
+SGG: Data file for testing Nonsymmetric Eigenvalue Problem routines
+7 Number of values of N
+0 1 2 3 5 10 16 Values of N (dimension)
+4 Number of parameter values
+1 1 2 2 Values of NB (blocksize)
+40 40 2 2 Values of NBMIN (minimum blocksize)
+2 4 2 4 Values of NSHIFT (no. of shifts)
+40 40 2 2 Values of MAXB (multishift crossover pt)
+40 40 2 2 Values of NBCOL (minimum col. dimension)
+20.0 Threshold value
+T Put T to test the LAPACK routines
+T Put T to test the driver routines
+T Put T to test the error exits
+1 Code to interpret the seed
+SGG 26
diff --git a/TESTING/ssb.in b/TESTING/ssb.in
new file mode 100644
index 0000000..2cc333f
--- /dev/null
+++ b/TESTING/ssb.in
@@ -0,0 +1,9 @@
+SSB: Data file for testing Symmetric Eigenvalue Problem routines
+2 Number of values of N
+5 20 Values of N (dimension)
+5 Number of values of K
+0 1 2 5 16 Values of K (band width)
+20.0 Threshold value
+T Put T to test the error exits
+1 Code to interpret the seed
+SSB 15
diff --git a/TESTING/ssg.in b/TESTING/ssg.in
new file mode 100644
index 0000000..bd99c05
--- /dev/null
+++ b/TESTING/ssg.in
@@ -0,0 +1,13 @@
+SSG: Data file for testing Generalized Symmetric Eigenvalue Problem routines
+7 Number of values of N
+0 1 2 3 5 10 16 Values of N (dimension)
+3 Number of values of NB
+1 3 20 Values of NB (blocksize)
+2 2 2 Values of NBMIN (minimum blocksize)
+1 1 1 Values of NX (crossover point)
+20.0 Threshold value
+T Put T to test the LAPACK routines
+T Put T to test the driver routines
+T Put T to test the error exits
+1 Code to interpret the seed
+SSG 21
diff --git a/TESTING/stest.in b/TESTING/stest.in
new file mode 100644
index 0000000..c9c96b8
--- /dev/null
+++ b/TESTING/stest.in
@@ -0,0 +1,37 @@
+Data file for testing REAL LAPACK linear eqn. routines
+7 Number of values of M
+0 1 2 3 5 10 50 Values of M (row dimension)
+7 Number of values of N
+0 1 2 3 5 10 50 Values of N (column dimension)
+3 Number of values of NRHS
+1 2 15 Values of NRHS (number of right hand sides)
+5 Number of values of NB
+1 3 3 3 20 Values of NB (the blocksize)
+1 0 5 9 1 Values of NX (crossover point)
+3 Number of values of RANK
+30 50 90 Values of rank (as a % of N)
+30.0 Threshold value of test ratio
+T Put T to test the LAPACK routines
+T Put T to test the driver routines
+T Put T to test the error exits
+SGE 11 List types on next line if 0 < NTYPES < 11
+SGB 8 List types on next line if 0 < NTYPES < 8
+SGT 12 List types on next line if 0 < NTYPES < 12
+SPO 9 List types on next line if 0 < NTYPES < 9
+SPS 9 List types on next line if 0 < NTYPES < 9
+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
+SSY 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
+STB 17 List types on next line if 0 < NTYPES < 17
+SQR 8 List types on next line if 0 < NTYPES < 8
+SRQ 8 List types on next line if 0 < NTYPES < 8
+SLQ 8 List types on next line if 0 < NTYPES < 8
+SQL 8 List types on next line if 0 < NTYPES < 8
+SQP 6 List types on next line if 0 < NTYPES < 6
+STZ 3 List types on next line if 0 < NTYPES < 3
+SLS 6 List types on next line if 0 < NTYPES < 6
+SEQ
diff --git a/TESTING/stest_rfp.in b/TESTING/stest_rfp.in
new file mode 100644
index 0000000..08dbf83
--- /dev/null
+++ b/TESTING/stest_rfp.in
@@ -0,0 +1,9 @@
+Data file for testing REAL LAPACK linear equation routines RFP format
+9 Number of values of N (at most 9)
+0 1 2 3 5 6 10 11 50 Values of N
+3 Number of values of NRHS (at most 9)
+1 2 15 Values of NRHS (number of right hand sides)
+9 Number of matrix types (list types on next line if 0 < NTYPES < 9)
+1 2 3 4 5 6 7 8 9 Matrix Types
+30.0 Threshold value of test ratio
+T Put T to test the error exits
diff --git a/TESTING/svd.in b/TESTING/svd.in
new file mode 100644
index 0000000..fb8e069
--- /dev/null
+++ b/TESTING/svd.in
@@ -0,0 +1,15 @@
+SVD: Data file for testing Singular Value Decomposition routines
+19 Number of values of M
+0 0 0 1 1 1 2 2 3 3 3 10 10 16 16 30 30 40 40 Values of M
+0 1 3 0 1 2 0 1 0 1 3 10 16 10 16 30 40 30 40 Values of N
+5 Number of parameter values
+1 3 3 3 20 Values of NB (blocksize)
+2 2 2 2 2 Values of NBMIN (minimum blocksize)
+1 0 5 9 1 Values of NX (crossover point)
+2 0 2 2 2 Values of NRHS
+35.0 Threshold value
+T Put T to test the LAPACK routines
+T Put T to test the driver routines
+T Put T to test the error exits
+1 Code to interpret the seed
+SVD 16
diff --git a/TESTING/zbak.in b/TESTING/zbak.in
new file mode 100644
index 0000000..624df47
--- /dev/null
+++ b/TESTING/zbak.in
@@ -0,0 +1,208 @@
+ZBK: Tests ZGEBAK
+ 5 1 1
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01
+
+(0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00)
+
+(0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00)
+
+ 5 1 1
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+(0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00)
+(-.66667D+00,0.00000D+00) (-.41667D-01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (-.25000D+00,0.00000D+00) (-.66667D+00,0.00000D+00)
+(0.10000D+01,0.00000D+00) (0.16667D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.22222D+00,0.00000D+00)
+(-.10000D+01,0.00000D+00) (-.50000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.50000D+00,0.00000D+00) (0.10000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (-.10000D+01,0.00000D+00)
+
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (-.10000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.50000D+00,0.00000D+00) (0.10000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.22222D+00,0.00000D+00)
+(-.10000D+01,0.00000D+00) (-.50000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (-.25000D+00,0.00000D+00) (-.66667D+00,0.00000D+00)
+(0.10000D+01,0.00000D+00) (0.16667D+00,0.00000D+00)
+(0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00)
+(-.66667D+00,0.00000D+00) (-.41667D-01,0.00000D+00)
+
+ 5 1 1
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+(0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00)
+(0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (-.60000D-17,0.00000D+00) (-.60000D-17,0.00000D+00)
+(-.60000D-17,0.00000D+00) (-.60000D-17,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.36000D-34,0.00000D+00)
+(0.36000D-34,0.00000D+00) (0.36000D-34,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.36000D-34,0.00000D+00)
+(0.36000D-34,0.00000D+00) (0.36000D-34,0.00000D+00)
+(0.00000D+00,0.00000D+00) (-.60000D-17,0.00000D+00) (-.60000D-17,0.00000D+00)
+(-.60000D-17,0.00000D+00) (-.60000D-17,0.00000D+00)
+(0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00)
+(0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00)
+
+ 6 4 6
+ 0.4000D+01 0.3000D+01 0.5000D+01 0.1000D+03 0.1000D+00 0.1000D+01
+
+(0.10000D+01,0.00000D+00) (0.13356D-05,0.00000D+00) (0.10000D+01,0.00000D+00)
+(0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00)
+(-.30007D-10,0.00000D+00) (-.32523D-04,0.00000D+00) (0.13050D-01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (-.83300D-02,0.00000D+00)
+(0.89289D-09,0.00000D+00) (-.67123D-04,0.00000D+00) (0.66874D-04,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(-.44554D-05,0.00000D+00) (-.33550D-02,0.00000D+00) (0.33448D-02,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.44554D-06,0.00000D+00) (-.33561D-01,0.00000D+00) (0.33437D-01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.44113D-09,0.00000D+00) (0.10115D+00,0.00000D+00) (0.10084D+00,0.00000D+00)
+
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(-.44554D-03,0.00000D+00) (-.33550D+00,0.00000D+00) (0.33448D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.44554D-07,0.00000D+00) (-.33561D-02,0.00000D+00) (0.33437D-02,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00)
+(-.30007D-10,0.00000D+00) (-.32523D-04,0.00000D+00) (0.13050D-01,0.00000D+00)
+(0.10000D+01,0.00000D+00) (0.13356D-05,0.00000D+00) (0.10000D+01,0.00000D+00)
+(0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (-.83300D-02,0.00000D+00)
+(0.89289D-09,0.00000D+00) (-.67123D-04,0.00000D+00) (0.66874D-04,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.44113D-09,0.00000D+00) (0.10115D+00,0.00000D+00) (0.10084D+00,0.00000D+00)
+
+ 5 1 5
+ 0.1000D+03 0.1000D+00 0.1000D-01 0.1000D+01 0.1000D+02
+
+(0.13663D-03,0.00000D+00) (-.68290D-04,0.00000D+00) (0.12516D-03,0.00000D+00)
+(0.10000D+01,0.00000D+00) (0.19503D-14,0.00000D+00)
+(0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) (-.27756D-16,0.00000D+00)
+(0.36012D-05,0.00000D+00) (-.60728D-17,0.00000D+00)
+(0.27355D+00,0.00000D+00) (-.13627D+00,0.00000D+00) (0.25030D+00,0.00000D+00)
+(-.33221D-05,0.00000D+00) (-.20000D-02,0.00000D+00)
+(0.69088D-02,0.00000D+00) (-.34434D-02,0.00000D+00) (0.61959D-02,0.00000D+00)
+(0.16661D-01,0.00000D+00) (0.10000D+01,0.00000D+00)
+(0.38988D+00,0.00000D+00) (-.20327D+00,0.00000D+00) (-.34200D+00,0.00000D+00)
+(-.10000D-02,0.00000D+00) (0.60004D-14,0.00000D+00)
+
+(0.13663D-01,0.00000D+00) (-.68290D-02,0.00000D+00) (0.12516D-01,0.00000D+00)
+(0.10000D+03,0.00000D+00) (0.19503D-12,0.00000D+00)
+(0.10000D+00,0.00000D+00) (0.10000D+00,0.00000D+00) (-.27756D-17,0.00000D+00)
+(0.36012D-06,0.00000D+00) (-.60728D-18,0.00000D+00)
+(0.27355D-02,0.00000D+00) (-.13627D-02,0.00000D+00) (0.25030D-02,0.00000D+00)
+(-.33221D-07,0.00000D+00) (-.20000D-04,0.00000D+00)
+(0.69088D-02,0.00000D+00) (-.34434D-02,0.00000D+00) (0.61959D-02,0.00000D+00)
+(0.16661D-01,0.00000D+00) (0.10000D+01,0.00000D+00)
+(0.38988D+01,0.00000D+00) (-.20327D+01,0.00000D+00) (-.34200D+01,0.00000D+00)
+(-.10000D-01,0.00000D+00) (0.60004D-13,0.00000D+00)
+
+ 6 2 5
+ 0.3000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.4000D+01
+
+(0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) (0.27764D-15,0.00000D+00)
+(-.24046D-16,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.75000D+00,0.00000D+00) (0.10000D+01,0.00000D+00)
+(0.85197D-01,0.00000D+00) (0.00000D+00,0.00000D+00) (-.15196D-16,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.75000D+00,0.00000D+00) (-.80934D+00,0.00000D+00)
+(0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (-.15196D-16,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.75000D+00,0.00000D+00) (-.95328D-01,0.00000D+00)
+(-.54260D+00,0.00000D+00) (0.10000D+01,0.00000D+00) (-.15196D-16,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.75000D+00,0.00000D+00) (-.95328D-01,0.00000D+00)
+(-.54260D+00,0.00000D+00) (-.10000D+01,0.00000D+00) (-.15196D-16,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.45588D-16,0.00000D+00)
+
+(0.00000D+00,0.00000D+00) (0.75000D+00,0.00000D+00) (-.80934D+00,0.00000D+00)
+(0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (-.15196D-16,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.75000D+00,0.00000D+00) (0.10000D+01,0.00000D+00)
+(0.85197D-01,0.00000D+00) (0.00000D+00,0.00000D+00) (-.15196D-16,0.00000D+00)
+(0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00) (0.27764D-15,0.00000D+00)
+(-.24046D-16,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.45588D-16,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.75000D+00,0.00000D+00) (-.95328D-01,0.00000D+00)
+(-.54260D+00,0.00000D+00) (-.10000D+01,0.00000D+00) (-.15196D-16,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.75000D+00,0.00000D+00) (-.95328D-01,0.00000D+00)
+(-.54260D+00,0.00000D+00) (0.10000D+01,0.00000D+00) (-.15196D-16,0.00000D+00)
+
+ 7 2 5
+ 0.3000D+01 0.1000D-02 0.1000D-01 0.1000D+02 0.1000D+00 0.1000D+01
+ 0.6000D+01
+
+(0.10000D+01,0.00000D+00) (-.11048D-01,0.00000D+00) (0.37942D-01,0.00000D+00)
+(-.93781D-01,0.00000D+00) (-.34815D-01,0.00000D+00) (0.44651D+00,0.00000D+00)
+(-.36016D-01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (-.45564D+00,0.00000D+00) (-.45447D+00,0.00000D+00)
+(0.10000D+01,0.00000D+00) (0.46394D+00,0.00000D+00) (-.65116D+00,0.00000D+00)
+(0.47808D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (-.27336D+00,0.00000D+00) (-.79459D+00,0.00000D+00)
+(0.63028D+00,0.00000D+00) (0.10000D+01,0.00000D+00) (-.62791D+00,0.00000D+00)
+(0.10000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) (-.69389D-17,0.00000D+00)
+(0.42585D-01,0.00000D+00) (-.64954D+00,0.00000D+00) (-.55814D+00,0.00000D+00)
+(-.64516D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (-.39041D+00,0.00000D+00) (-.40294D+00,0.00000D+00)
+(-.16849D+00,0.00000D+00) (-.94294D+00,0.00000D+00) (0.10000D+01,0.00000D+00)
+(-.93714D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (-.25581D+00,0.00000D+00)
+(0.33085D-03,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(-.19851D-02,0.00000D+00)
+
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (-.25581D+00,0.00000D+00)
+(0.33085D-03,0.00000D+00)
+(0.00000D+00,0.00000D+00) (-.45564D-03,0.00000D+00) (-.45447D-03,0.00000D+00)
+(0.10000D-02,0.00000D+00) (0.46394D-03,0.00000D+00) (-.65116D-03,0.00000D+00)
+(0.47808D-03,0.00000D+00)
+(0.10000D+01,0.00000D+00) (-.11048D-01,0.00000D+00) (0.37942D-01,0.00000D+00)
+(-.93781D-01,0.00000D+00) (-.34815D-01,0.00000D+00) (0.44651D+00,0.00000D+00)
+(-.36016D-01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.10000D+02,0.00000D+00) (-.69389D-16,0.00000D+00)
+(0.42585D+00,0.00000D+00) (-.64954D+01,0.00000D+00) (-.55814D+01,0.00000D+00)
+(-.64516D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (-.39041D-01,0.00000D+00) (-.40294D-01,0.00000D+00)
+(-.16849D-01,0.00000D+00) (-.94294D-01,0.00000D+00) (0.10000D+00,0.00000D+00)
+(-.93714D-01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(-.19851D-02,0.00000D+00)
+(0.00000D+00,0.00000D+00) (-.27336D-02,0.00000D+00) (-.79459D-02,0.00000D+00)
+(0.63028D-02,0.00000D+00) (0.10000D-01,0.00000D+00) (-.62791D-02,0.00000D+00)
+(0.10000D-01,0.00000D+00)
+
+0 0 0
diff --git a/TESTING/zbal.in b/TESTING/zbal.in
new file mode 100644
index 0000000..c742723
--- /dev/null
+++ b/TESTING/zbal.in
@@ -0,0 +1,355 @@
+ZBL: Tests ZGEBAL
+ 5
+(0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.20000D+01,0.10000D+01) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.30000D+01,0.30000D+01)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.40000D+01,0.10000D+01) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.50000D+01,0.50000D+01)
+
+ 1 1
+(0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.20000D+01,0.10000D+01) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.30000D+01,0.30000D+01)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.40000D+01,0.10000D+01) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.50000D+01,0.50000D+01)
+
+ 0.10000D+01 0.20000D+01 0.30000D+01 0.40000D+01 0.50000D+01
+
+ 5
+(0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.10000D+01,0.10000D+01) (0.20000D+01,0.20000D+01) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.10000D+01,0.10000D+01) (0.20000D+01,0.20000D+01) (0.30000D+01,0.30000D+01)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.10000D+01,0.10000D+01) (0.20000D+01,0.20000D+01) (0.30000D+01,0.30000D+01)
+(0.40000D+01,0.40000D+01) (0.00000D+00,0.00000D+00)
+(0.10000D+01,0.10000D+01) (0.20000D+01,0.20000D+01) (0.30000D+01,0.30000D+01)
+(0.40000D+01,0.40000D+01) (0.50000D+01,0.50000D+01)
+
+ 1 1
+(0.50000D+01,0.50000D+01) (0.40000D+01,0.40000D+01) (0.30000D+01,0.30000D+01)
+(0.20000D+01,0.20000D+01) (0.10000D+01,0.10000D+01)
+(0.00000D+00,0.00000D+00) (0.40000D+01,0.40000D+01) (0.30000D+01,0.30000D+01)
+(0.20000D+01,0.20000D+01) (0.10000D+01,0.10000D+01)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.30000D+01,0.30000D+01)
+(0.20000D+01,0.20000D+01) (0.10000D+01,0.10000D+01)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.20000D+01,0.20000D+01) (0.10000D+01,0.10000D+01)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.10000D+01,0.10000D+01)
+
+ 0.10000D+01 0.20000D+01 0.30000D+01 0.20000D+01 0.10000D+01
+
+ 5
+(0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.10000D+01,0.00000D+00) (0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00) (0.10000D+01,0.10000D+01)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00)
+(0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.10000D+01,0.00000D+00) (0.10000D+01,0.10000D+01)
+
+ 1 1
+(0.10000D+01,0.10000D+01) (0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.10000D+01,0.10000D+01) (0.10000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+01,0.10000D+01)
+(0.10000D+01,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.10000D+01,0.10000D+01) (0.10000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.10000D+01,0.10000D+01)
+
+ 0.10000D+01 0.20000D+01 0.30000D+01 0.20000D+01 0.10000D+01
+
+ 4
+(0.00000D+00,0.00000D+00) (0.20000D+01,0.00000D+00) (0.10000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00)
+(0.20000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.10000D+00,0.00000D+00)
+(0.10000D+03,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.20000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.10000D+03,0.00000D+00) (0.20000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00)
+
+ 1 4
+(0.0000D+00,0.00000D+00) (0.2000D+01,0.00000D+00) (0.3200D+01,0.00000D+00)
+(0.000D+00,0.00000D+00)
+(0.2000D+01,0.00000D+00) (0.0000D+00,0.00000D+00) (0.0000D+00,0.00000D+00)
+(0.3200D+01,0.00000D+00)
+(0.3125D+01,0.00000D+00) (0.0000D+00,0.00000D+00) (0.0000D+00,0.00000D+00)
+(0.2000D+01,0.00000D+00)
+(0.0000D+00,0.00000D+00) (0.3125D+01,0.00000D+00) (0.2000D+01,0.00000D+00)
+(0.0000D+00,0.00000D+00)
+
+6.25000D-02 6.25000D-02 2.00000D+00 2.00000D+00
+
+ 6
+(0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10240D+04,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.12800D+03,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.20000D+01,0.10000D+01) (0.30000D+04,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.20000D+01,0.00000D+00)
+(0.00000D+00,0.12800D+03) (0.40000D+01,0.00000D+00) (0.40000D-02,0.00000D+00)
+(0.50000D+01,0.00000D+00) (0.60000D+03,0.00000D+00) (0.80000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.20000D-02) (0.20000D+01,0.00000D+00)
+(0.80000D+01,0.00000D+00) (0.00000D+00,0.81920D+04) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.20000D+01,0.00000D+00)
+
+ 4 6
+(0.50000D+01,0.00000D+00) (0.40000D-02,0.00000D+00) (0.60000D+03,0.00000D+00)
+(0.00000D+00,0.10240D+04) (0.50000D+00,0.00000D+00) (0.80000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.30000D+04,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.25000D+00,0.12500D+00) (0.20000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.20000D-02)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.20000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) (0.12800D+03,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10240D+04,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.64000D+02,0.00000D+00) (0.00000D+00,0.10240D+04) (0.20000D+01,0.00000D+00)
+
+ 0.40000D+01 0.30000D+01 0.50000D+01 0.80000D+01 0.12500D+00 0.10000D+01
+
+ 5
+(0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.80000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.20000D+01,0.10000D+01) (0.81920D+04,0.00000D+00)
+(0.20000D+01,0.00000D+00) (0.40000D+01,0.00000D+00)
+(0.25000D-03,0.00000D+00) (0.12500D-03,0.00000D+00) (0.40000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.64000D+02,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.20000D+01,0.00000D+00) (0.10240D+04,0.10240D+01)
+(0.40000D+01,0.00000D+00) (0.80000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.81920D+04) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.80000D+01,0.00000D+00)
+
+ 1 5
+ ( 1.0000D+000, 1.0000D+000) ( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00)
+( 0.0000D-003,0.00000D+00) (250.0000D-003,0.00000D+00)
+ ( 0.0000D-003,0.00000D+00) ( 2.0000D+000, 1.0000D+000) ( 1.0240D+003,0.00000D+00)
+ ( 16.0000D+000,0.00000D+00) ( 16.0000D+000,0.00000D+00)
+ (256.0000D-003,0.00000D+00) ( 1.0000D-003,0.00000D+00) ( 4.0000D+000,0.00000D+00)
+ ( 0.0000D-003,0.00000D+00) ( 2.0480D+003,0.00000D+00)
+ ( 0.0000D-003,0.00000D+00) (250.0000D-003,0.00000D+00) ( 16.0000D+000,16.0000D-003)
+ ( 4.0000D+000,0.00000D+00) ( 4.0000D+000,0.00000D+00)
+ ( 0.0000D-003,0.00000D+00) ( 0.0000D-003, 2.0480D+003) ( 0.0000D-003,0.00000D+00)
+ ( 0.0000D-003,0.00000D+00) ( 8.0000D+000,0.00000D+00)
+
+ 64.0000D+000 500.0000D-003 62.5000D-003 4.0000D+000 2.0000D+000
+
+ 4
+(0.10000D+01,0.10000D+01) (0.10000D+07,0.00000D+00) (0.10000D+07,0.00000D+00)
+(0.10000D+07,0.00000D+00)
+(-.20000D+07,0.00000D+00) (0.30000D+01,0.10000D+01) (0.20000D-05,0.00000D+00)
+(0.30000D-05,0.00000D+00)
+(-.30000D+07,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D-05,0.10000D+01)
+(0.20000D+01,0.00000D+00)
+(0.10000D+07,0.00000D+00) (0.00000D+00,0.00000D+00) (0.30000D-05,0.00000D+00)
+(0.40000D+07,0.10000D+01)
+
+ 1 4
+
+ ( 1.0000D+000, 1.0000D+000) ( 1.0000D+006,0.00000D+00) ( 2.0000D+006,0.00000D+00) ( 1.0000D+006,0.00000D+00) (250.0000D-003,0.00000D+00)
+ ( -2.0000D+006,0.00000D+00) ( 3.0000D+000, 1.0000D+000) ( 4.0000D-006,0.00000D+00) ( 3.0000D-006,0.00000D+00) ( 16.0000D+000,0.00000D+00)
+ ( -1.5000D+006,0.00000D+00) ( 0.0000D-003,0.00000D+00) ( 1.0000D-006, 1.0000D+000) ( 1.0000D+000,0.00000D+00) ( 2.0480D+003,0.00000D+00)
+ ( 1.0000D+006,0.00000D+00) ( 0.0000D-003,0.00000D+00) ( 6.0000D-006,0.00000D+00) ( 4.0000D+006, 1.0000D+000) ( 4.0000D+000,0.00000D+00)
+
+ 1.0000D+000 1.0000D+000 2.0000D+000 1.0000D+000
+
+ 4
+(0.10000D+01,0.00000D+00) (0.00000D+00,0.10000D+05) (0.00000D+00,0.10000D+05)
+(0.00000D+00,0.10000D+05)
+(-.20000D+05,0.00000D+00) (0.30000D+01,0.00000D+00) (0.20000D-02,0.00000D+00)
+(0.30000D-02,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.20000D+01,0.10000D+01) (0.00000D+00,0.00000D+00)
+(-.30000D+05,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+05,0.00000D+00)
+(0.00000D+00,0.00000D+00)
+
+ 1 4
+ ( 1.0000D+000,0.00000D+00) ( 0.0000D-003,10.0000D+003) (0.0000D-003,10.0000D+003) (0.0000D-003,5.0000D+003) (250.0000D-003,0.00000D+00)
+ (-20.0000D+003,0.00000D+00) ( 3.0000D+000,0.00000D+00) ( 2.0000D-003,0.00000D+00) ( 1.5000D-003,0.00000D+00) ( 16.0000D+000,0.00000D+00)
+ ( 0.0000D-003,0.00000D+00) ( 2.0000D+000, 1.0000D+000) ( 0.0000D-003,0.00000D+00) (-15.0000D+003,0.00000D+00) ( 2.0480D+003,0.00000D+00)
+ ( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00) ( 20.0000D+003,0.00000D+00) ( 0.0000D-003,0.00000D+00) ( 4.0000D+000,0.00000D+00)
+
+ 1.0000D+000 1.0000D+000 1.0000D+000 500.0000D-003
+ 5
+(0.10000D+01,0.00000D+00) (0.51200D+03,0.00000D+00) (0.40960D+04,0.00000D+00)
+(0.32768D+05,0.00000D+00) (2.62144D+05,0.00000D+00)
+(0.80000D+01,0.80000D+01) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.80000D+01,0.80000D+01) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.80000D+01,0.80000D+01)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.80000D+01,0.80000D+01) (0.00000D+00,0.00000D+00)
+
+ 1 5
+ ( 1.0000D+000,0.00000D+00) ( 64.0000D+000,0.00000D+00) ( 64.0000D+000,0.00000D+00)
+( 64.0000D+000,0.00000D+00) ( 64.0000D+000,0.00000D+00)
+ ( 64.0000D+000,64.0000D+000) ( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00)
+( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00)
+ ( 0.0000D-003,0.00000D+00) ( 64.0000D+000,64.0000D+000) ( 0.0000D-003,0.00000D+00)
+( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00)
+ ( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00) ( 64.0000D+000,64.0000D+000)
+( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00)
+ ( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00) ( 0.0000D-003,0.00000D+00)
+( 64.0000D+000,64.0000D+000) ( 0.0000D-003,0.00000D+00)
+
+ 128.0000D+000 16.0000D+000 2.0000D+000 250.0000D-003 31.2500D-003
+
+ 6
+(0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00)
+(0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01)
+(0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00)
+(0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01)
+(0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01)
+(0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00)
+(0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01)
+(0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01) (0.00000D+00,0.00000D+00)
+(0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01)
+
+ 2 5
+(0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01)
+(0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01)
+(0.00000D+00,0.00000D+00) (0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01)
+(0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01)
+(0.00000D+00,0.00000D+00) (0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01)
+(0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01)
+(0.00000D+00,0.00000D+00) (0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01)
+(0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01)
+(0.00000D+00,0.00000D+00) (0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01)
+(0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01) (0.10000D+01,0.10000D+01)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+01,0.10000D+01)
+
+ 0.30000D+01 0.10000D+01 0.10000D+01 0.10000D+01 0.10000D+01 0.40000D+01
+
+ 7
+(0.60000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.10000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.40000D+01,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.25000D-03,0.00000D+00) (0.12500D-01,0.00000D+00) (0.20000D-01,0.00000D+00)
+(0.12500D+00,0.00000D+00)
+(0.10000D+01,0.00000D+00) (0.12800D+03,0.00000D+00) (0.64000D+02,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (-.20000D+01,0.00000D+00)
+(0.16000D+02,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.16384D+05,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.10000D+01,0.00000D+00) (-.40000D+03,0.00000D+00) (0.25600D+03,0.00000D+00)
+(-.40000D+04,0.00000D+00)
+(-.20000D+01,0.00000D+00) (-.25600D+03,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.12500D-01,0.00000D+00) (0.20000D+01,0.00000D+00) (0.20000D+01,0.00000D+00)
+(0.32000D+02,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00)
+(0.00000D+00,0.00000D+00) (0.80000D+01,0.00000D+00) (0.00000D+00,0.00000D+00)
+(0.40000D-02,0.00000D+00) (0.12500D+00,0.00000D+00) (-.20000D+00,0.00000D+00)
+(0.30000D+01,0.00000D+00)
+
+ 2 5
+ (6.4000D+01,0.00000D+00) (2.5000D-01,0.00000D+00) (5.00000D-01,0.00000D+00)
+ (0.0000D+00,0.00000D+00) (0.0000D+00,0.00000D+00) (1.0000D+00,0.00000D+00)
+ (-2.0000D+00,0.00000D+00)
+ (0.0000D+00,0.00000D+00) (4.0000D+00,0.00000D+00) (2.00000D+00,0.00000D+00)
+ (4.0960D+00,0.00000D+00) (1.6000D+00,0.00000D+00) (0.0000D+00,0.00000D+00)
+ (1.0240D+01,0.00000D+00)
+ (0.0000D+00,0.00000D+00) (5.0000D-01,0.00000D+00) (3.00000D+00,0.00000D+00)
+ (4.0960D+00,0.00000D+00) (1.0000D+00,0.00000D+00) (0.0000D+00,0.00000D+00)
+ (-6.4000D+00,0.00000D+00)
+ (0.0000D+00,0.00000D+00) (1.0000D+00,0.00000D+00) (-3.90625D+00,0.00000D+00)
+ (1.0000D+00,0.00000D+00) (-3.1250D+00,0.00000D+00) (0.0000D+00,0.00000D+00)
+ (8.0000D+00,0.00000D+00)
+ (0.0000D+00,0.00000D+00) (-2.0000D+00,0.00000D+00) (4.00000D+00,0.00000D+00)
+ (1.6000D+00,0.00000D+00) (2.0000D+00,0.00000D+00) (-8.0000D+00,0.00000D+00)
+ (8.0000D+00,0.00000D+00)
+ (0.0000D+00,0.00000D+00) (0.0000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+ (0.0000D+00,0.00000D+00) (0.0000D+00,0.00000D+00) (6.0000D+00,0.00000D+00)
+ (1.0000D+00,0.00000D+00)
+ (0.0000D+00,0.00000D+00) (0.0000D+00,0.00000D+00) (0.00000D+00,0.00000D+00)
+ (0.0000D+00,0.00000D+00) (0.0000D+00,0.00000D+00) (0.0000D+00,0.00000D+00)
+ (0.0000D+00,0.00000D+00)
+
+ 3.0000D+00 1.953125D-03 3.1250D-02 3.2000D+01 2.5000D-01 1.0000D+00 6.0000D+00
+
+ 5
+(0.10000D+04,0.00000D+00) (0.20000D+01,0.00000D+00) (0.30000D+01,0.00000D+00)
+(0.40000D+01,0.00000D+00) (0.50000D+06,0.00000D+00)
+(0.90000D+01,0.00000D+00) (0.00000D+00,0.00000D+00) (0.20000D-03,0.00000D+00)
+(0.10000D+01,0.00000D+00) (0.30000D+01,0.00000D+00)
+(0.00000D+00,0.00000D+00) (-.30000D+03,0.00000D+00) (0.20000D+01,0.00000D+00)
+(0.10000D+01,0.00000D+00) (0.10000D+01,0.00000D+00)
+(0.90000D+01,0.00000D+00) (0.20000D-02,0.00000D+00) (0.10000D+01,0.00000D+00)
+(0.10000D+01,0.00000D+00) (-.10000D+04,0.00000D+00)
+(0.60000D+01,0.00000D+00) (0.20000D+03,0.00000D+00) (0.10000D+01,0.00000D+00)
+(0.60000D+03,0.00000D+00) (0.30000D+01,0.00000D+00)
+
+ 1 5
+ (1.0000D+03,0.00000D+00) (3.1250D-02,0.00000D+00) (3.7500D-01,0.00000D+00)
+(6.2500D-02,0.00000D+00) (3.90625D+03,0.00000D+00)
+ (5.7600D+02,0.00000D+00) (0.0000D+00,0.00000D+00) (1.6000D-03,0.00000D+00)
+(1.0000D+00,0.00000D+00) (1.5000D+00,0.00000D+00)
+ (0.0000D+00,0.00000D+00) (-3.7500D+01,0.00000D+00) (2.0000D+00,0.00000D+00)
+(1.2500D-01,0.00000D+00) (6.2500D-02,0.00000D+00)
+ (5.7600D+02,0.00000D+00) (2.0000D-03,0.00000D+00) (8.0000D+00,0.00000D+00)
+(1.0000D+00,0.00000D+00) (-5.0000D+02,0.00000D+00)
+ (7.6800D+02,0.00000D+00) (4.0000D+02,0.00000D+00) (1.6000D+01,0.00000D+00)
+(1.2000D+03,0.00000D+00) (3.0000D+00,0.00000D+00)
+
+ 1.2800D+02 2.0000D+00 1.6000D+01 2.0000D+00 1.0000D+00
+
+ 6
+(1.0000D+00,0.0000D+00) (1.0000D+120,0.0000D+00) (0.0000D+00,0.0000D+00)
+(0.0000D+00,0.0000D+00) (0.0000D+00 ,0.0000D+00) (0.0000D+00,0.0000D+00)
+(1.0000D-120,0.0000D+00) (1.0000D+00,0.0000D+00) (1.0000D+120,0.0000D+00)
+(0.0000D+00,0.0000D+00) (0.0000D+00,0.0000D+00) (0.0000D+00,0.0000D+00)
+(0.0000D+00,0.0000D+00) (1.0000D-120,0.0000D+00) (1.0000D+00,0.0000D+00)
+(1.0000D+120,0.0000D+00) (0.0000D+00,0.0000D+00) (0.0000D+00,0.0000D+00)
+(0.0000D+00,0.0000D+00) (0.0000D+00,0.0000D+00) (1.0000D-120,0.0000D+00)
+(1.0000D+00,0.0000D+00) (1.0000D+120,0.0000D+00) (0.0000D+00,0.0000D+00)
+(0.0000D+00,0.0000D+00) (0.0000D+00,0.0000D+00) (0.0000D+00,0.0000D+00)
+(1.0000D-120,0.0000D+00) (1.0000D+00,0.0000D+00) (1.0000D+120,0.0000D+00)
+(0.0000D+00,0.0000D+00) (0.0000D+00,0.0000D+00) (0.0000D+00,0.0000D+00)
+(0.0000D+00,0.0000D+00) (1.0000D-120,0.0000D+00) (1.0000D+00,0.0000D+00)
+ 1 6
+
+ (1.000000000000000000D+00,0.0000D+00) (6.344854593289122931D+03,0.0000D+00) (0.000000000000000000D+00,0.0000D+00)
+ (0.000000000000000000D+00,0.0000D+00) (0.000000000000000000D+00,0.0000D+00) (0.000000000000000000D+00,0.0000D+00)
+ (1.576080247855779135D-04,0.0000D+00) (1.000000000000000000D+00,0.0000D+00) (6.344854593289122931D+03,0.0000D+00)
+ (0.000000000000000000D+00,0.0000D+00) (0.000000000000000000D+00,0.0000D+00) (0.000000000000000000D+00,0.0000D+00)
+ (0.000000000000000000D+00,0.0000D+00) (1.576080247855779135D-04,0.0000D+00) (1.000000000000000000D+00,0.0000D+00)
+ (3.172427296644561466D+03,0.0000D+00) (0.000000000000000000D+00,0.0000D+00) (0.000000000000000000D+00,0.0000D+00)
+ (0.000000000000000000D+00,0.0000D+00) (0.000000000000000000D+00,0.0000D+00) (3.152160495711558270D-04,0.0000D+00)
+ (1.000000000000000000D+00,0.0000D+00) (1.586213648322280733D+03,0.0000D+00) (0.000000000000000000D+00,0.0000D+00)
+ (0.000000000000000000D+00,0.0000D+00) (0.000000000000000000D+00,0.0000D+00) (0.000000000000000000D+00,0.0000D+00)
+ (6.304320991423116539D-04,0.0000D+00) (1.000000000000000000D+00,0.0000D+00) (1.586213648322280733D+03,0.0000D+00)
+ ( 0.000000000000000000D+00,0.0000D+00) ( 0.000000000000000000D+00,0.0000D+00) (0.000000000000000000D+00,0.0000D+00)
+ (0.000000000000000000D+00,0.0000D+00) (6.304320991423116539D-04,0.0000D+00) (1.000000000000000000D+00,0.0000D+00)
+
+ 2.494800386918399765D+291 1.582914569427869018D+175 1.004336277661868922D+59 3.186183822264904554D-58 5.053968264940243633D-175 8.016673440035891112D-292
+
+
+0
diff --git a/TESTING/zbb.in b/TESTING/zbb.in
new file mode 100644
index 0000000..51e54e9
--- /dev/null
+++ b/TESTING/zbb.in
@@ -0,0 +1,12 @@
+ZBB: Data file for testing banded Singular Value Decomposition routines
+20 Number of values of M
+0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 10 10 16 16 Values of M
+0 1 2 3 0 1 2 3 0 1 2 3 0 1 2 3 10 16 10 16 Values of N
+5 Number of values of K
+0 1 2 3 16 Values of K (band width)
+2 Number of values of NRHS
+1 2 Values of NRHS
+20.0 Threshold value
+F Put T to test the error exits
+1 Code to interpret the seed
+ZBB 15
diff --git a/TESTING/zctest.in b/TESTING/zctest.in
new file mode 100644
index 0000000..ef88cc0
--- /dev/null
+++ b/TESTING/zctest.in
@@ -0,0 +1,10 @@
+Data file for testing ZCGESV/ZCPOSV LAPACK routines
+11 Number of values of M
+0 1 2 13 17 45 78 91 101 120 132 Values of M (row dimension)
+4 Number of values of NRHS
+1 2 15 16 Values of NRHS (number of right hand sides)
+30.0 Threshold value of test ratio
+T Put T to test the driver routine
+T Put T to test the error exits
+ZGE 11 Number of matrix types to be tested, list types on next line if 0 < NTYPES < 11
+ZPO 9 Number of matrix types to be tested, list types on next line if 0 < NTYPES < 9
diff --git a/TESTING/zec.in b/TESTING/zec.in
new file mode 100644
index 0000000..32a1b89
--- /dev/null
+++ b/TESTING/zec.in
@@ -0,0 +1,517 @@
+ZEC Key indicating type of input
+20.0D0 Threshold value for test ratios
+ 1 1
+( 2.0D0, 0.0D0)
+( 2.0D0, 0.0D0)
+( 1.0D0, 1.0D0)
+ 1 3
+( 1.0D0, 1.0D0)
+( 1.0D0, 1.0D0) ( 1.0D0, 1.0D0) ( 1.0D0, 1.0D0)
+( 0.0D0, 0.0D0) ( 1.5D0, 1.5D0) ( 2.0D0, 1.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 2.0D0, 2.0D0)
+( 2.0D0, 1.0D0) ( 2.0D0, 1.0D0) ( 9.0D0, 0.0D0)
+ 4 4
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 2.0D0, 0.0D0) ( 1.0D0, 3.0D0)
+( 2.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 8.0D0, 9.0D0) ( 2.0D0, 2.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 7.0D0) ( 0.0D0, 0.0D0) ( 2.0D0, 0.0D0) ( 1.0D0, 0.0D0)
+ 4 4
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+ 4 4
+( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0)
+( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0)
+( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0)
+ 4 4
+( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0)
+(-1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) (-1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) (-1.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) (-1.0D0, 0.0D0)
+( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0)
+ 4 4
+( 1.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 0.0D0, 1.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 1.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0)
+(-1.0D0, 1.0D0) ( 0.0D0, 1.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 1.0D0)
+( 0.0D0, 0.0D0) (-1.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) (-1.0D0, 0.0D0) ( 0.0D0, 1.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) (-1.0D0, 0.0D0)
+( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0)
+ 4 3
+( 0.0621D0, 0.7054D0) ( 0.1062D0, 0.0503D0) ( 0.6553D0, 0.5876D0) ( 0.2560D0, 0.8642D0)
+( 0.0D0, 0.0D0) ( 0.2640D0, 0.5782D0) ( 0.9700D0, 0.7256D0) ( 0.5598D0, 0.1943D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0380D0, 0.2849D0) ( 0.9166D0, 0.0580D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.1402D0, 0.6908D0)
+( 0.6769D0, 0.6219D0) ( 0.5965D0, 0.0505D0) ( 0.7361D0, 0.5069D0)
+( 0.0D0, 0.0D0) ( 0.0726D0, 0.7195D0) ( 0.2531D0, 0.9764D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.3481D0, 0.5602D0)
+( 0.9110D0, 0.7001D0) ( 0.1821D0, 0.5406D0) ( 0.8879D0, 0.5813D0)
+( 0.0728D0, 0.5887D0) ( 0.3271D0, 0.5647D0) ( 0.3793D0, 0.1667D0)
+( 0.1729D0, 0.6041D0) ( 0.9368D0, 0.3514D0) ( 0.8149D0, 0.3535D0)
+( 0.3785D0, 0.7924D0) ( 0.6588D0, 0.8646D0) ( 0.1353D0, 0.8362D0)
+ 6 5
+( 3.0D0, 5.0D0) ( 3.0D0, 22.0D0) ( 2.0D0, 3.0D0) ( 2.0D0, 3.0D0)
+( 3.0D0, 3.0D0) (311.D0, 2.0D0)
+( 0.0D0, 0.0D0) (-3.0D0, 5.0D0) ( 3.0D0, 2.0D0) ( 2.0D0, 3.0D0)
+( 2.0D0, 3.0D0) (11.0D0, 2.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 3.0D0, 2.0D0) ( 2.0D0, 3.0D0)
+( 2.0D0, 3.0D0) ( 1.0D0, -2.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) (-33.D0, 2.0D0)
+( 2.0D0, 3.0D0) ( 1.0D0, 2.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+(-22.D0, 3.0D0) ( 1.0D0, 2.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 2.0D0, -3.0D0)
+( 9.0D0, 0.0D0) ( 2.0D0, 0.0D0) (-12.D0, 0.0D0) ( 1.0D0, 0.0D0)
+( 3.0D0, 0.0D0)
+( 0.0D0, 0.0D0) (-19.D0, 0.0D0) ( 12.D0, 0.0D0) ( 1.0D0, 0.0D0)
+( 3.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 98.D0, 0.0D0) (11.0D0, 0.0D0)
+( 3.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) (13.0D0, 0.0D0)
+(11.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+(13.0D0, 0.0D0)
+( 3.0D0, -5.0D0) ( 3.0D0, 22.0D0) ( 2.0D0, 31.0D0) ( 2.0D0, 3.0D0)
+( 3.0D0, 3.0D0)
+( 0.0D0, 0.0D0) (-3.0D0, 5.0D0) ( 33.D0, 22.0D0) ( 2.0D0, 3.0D0)
+(-2.0D0, 3.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) (-3.0D0, 2.0D0) ( 2.0D0, 3.0D0)
+( 2.0D0, -3.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) (-33.D0, 2.0D0)
+( 2.0D0, 3.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+(-22.D0, 3.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, -2.0D0)
+ 0 0
+ 1 1 1
+( 0.0D0, 0.0D0)
+ 3 1 3
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+ 4 4 1
+( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0)
+ 4 4 1
+( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 2.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 3.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 4.0D0, 0.0D0)
+ 4 1 4
+(12.0D0, 0.0D0) ( 0.0D0, 20.0D0) (-2.0D0, 0.0D0) (10.0D0, 0.0D0)
+( 0.0D0, 0.0D0) (20.0D0, 0.0D0) ( 2.0D0, -1.0D0) ( 0.0D0, 0.9D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 3.0D0, 0.0D0) ( 0.8D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 8.0D0, 0.0D0)
+ 5 5 1
+( 1.0D0, 1.0D0) ( 2.0D0, -1.0D0) ( 2.0D0, -3.0D0) (12.0D0, 3.0D0)
+( 2.0D0, 39.0D0)
+( 0.0D0, 0.0D0) ( 2.0D0, 3.0D0) ( 2.0D0, 3.0D0) ( 2.0D0, 13.0D0)
+( 2.0D0, 31.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) (-2.0D0, 3.0D0) ( 2.0D0, 3.0D0)
+(12.0D0, 3.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 2.0D0, -3.0D0)
+(-2.0D0, 3.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 2.0D0, 3.0D0)
+ 4 4 1
+( 0.0621D0, 0.7054D0) ( 0.1062D0, 0.0503D0) ( 0.6553D0, 0.5876D0) ( 0.2560D0, 0.8642D0)
+( 0.0D0, 0.0D0) ( 0.2640D0, 0.5782D0) ( 0.9700D0, 0.7256D0) ( 0.5598D0, 0.1943D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0380D0, 0.2849D0) ( 0.9166D0, 0.0580D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.1402D0, 0.6908D0)
+ 6 5 3
+( 10.0D0, 1.0D0) ( 10.0D0, 0.0D0) ( 30.0D0, 0.0D0) ( 0.0D0, 1.0D0)
+( 10.0D0, 1.0D0) ( 10.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 20.0D0, 1.0D0) ( 30.0D0, 0.0D0) ( 20.0D0, 1.0D0)
+( 0.0D0,-1.0D0) ( 0.0D0,-10.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 30.0D0, 1.0D0) ( 0.0D0, 0.0D0)
+( 2.0D0, 0.0D0) ( 0.0D0, 20.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 40.0D0, 1.0D0)
+( 0.0D0,-10.0D0) ( -30.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 50.0D0, 1.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 60.0D0, 1.0D0)
+ 0 0 0
+ 1 0
+( 0.0D0, 0.0D0)
+ 0.0D0 0.0D0 1.0D0 0.0D0
+ 1 0
+( 0.0D0, 1.0D0)
+ 0.0D0 1.0D0 1.0D0 1.0D0
+ 2 0
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+ 0.0D0 0.0D0 1.0D0 0.0D0
+ 0.0D0 0.0D0 1.0D0 0.0D0
+ 2 0
+( 3.0D0, 0.0D0) ( 2.0D0, 0.0D0)
+( 2.0D0, 0.0D0) ( 3.0D0, 0.0D0)
+ 1.0D0 0.0D0 1.0D0 4.0D0
+ 5.0D0 0.0D0 1.0D0 4.0D0
+ 2 0
+( 3.0D0, 0.0D0) ( 0.0D0, 2.0D0)
+( 0.0D0, 2.0D0) ( 3.0D0, 0.0D0)
+ 3.0D0 2.0D0 1.0D0 4.0D0
+ 3.0D0 -2.0D0 1.0D0 4.0D0
+ 5 0
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+ 0.0D0 0.0D0 1.0D0 0.0D0
+ 0.0D0 0.0D0 1.0D0 0.0D0
+ 0.0D0 0.0D0 1.0D0 0.0D0
+ 0.0D0 0.0D0 1.0D0 0.0D0
+ 0.0D0 0.0D0 1.0D0 0.0D0
+ 5 0
+( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0)
+ 1.0D0 0.0D0 1.0D0 0.0D0
+ 1.0D0 0.0D0 1.0D0 0.0D0
+ 1.0D0 0.0D0 1.0D0 0.0D0
+ 1.0D0 0.0D0 1.0D0 0.0D0
+ 1.0D0 0.0D0 1.0D0 0.0D0
+ 5 0
+( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 2.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 3.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 4.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 5.0D0, 0.0D0)
+ 1.0D0 0.0D0 1.0D0 1.0D0
+ 2.0D0 0.0D0 1.0D0 1.0D0
+ 3.0D0 0.0D0 1.0D0 1.0D0
+ 4.0D0 0.0D0 1.0D0 1.0D0
+ 5.0D0 0.0D0 1.0D0 1.0D0
+ 6 0
+( 0.0D0, 1.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 1.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 1.0D0)
+ 0.0D0 1.0D0 1.1921D-07 0.0D0
+ 0.0D0 1.0D0 2.4074D-35 0.0D0
+ 0.0D0 1.0D0 2.4074D-35 0.0D0
+ 0.0D0 1.0D0 2.4074D-35 0.0D0
+ 0.0D0 1.0D0 2.4074D-35 0.0D0
+ 0.0D0 1.0D0 1.1921D-07 0.0D0
+ 6 0
+( 0.0D0, 1.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 1.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 1.0D0)
+ 0.0D0 1.0D0 1.1921D-07 0.0D0
+ 0.0D0 1.0D0 2.4074D-35 0.0D0
+ 0.0D0 1.0D0 2.4074D-35 0.0D0
+ 0.0D0 1.0D0 2.4074D-35 0.0D0
+ 0.0D0 1.0D0 2.4074D-35 0.0D0
+ 0.0D0 1.0D0 1.1921D-07 0.0D0
+ 4 0
+( 9.4480D-01, 1.0D0) ( 6.7670D-01, 1.0D0) ( 6.9080D-01, 1.0D0) ( 5.9650D-01, 1.0D0)
+( 5.8760D-01, 1.0D0) ( 8.6420D-01, 1.0D0) ( 6.7690D-01, 1.0D0) ( 7.2600D-02, 1.0D0)
+( 7.2560D-01, 1.0D0) ( 1.9430D-01, 1.0D0) ( 9.6870D-01, 1.0D0) ( 2.8310D-01, 1.0D0)
+( 2.8490D-01, 1.0D0) ( 5.8000D-02, 1.0D0) ( 4.8450D-01, 1.0D0) ( 7.3610D-01, 1.0D0)
+ 2.6014D-01 -1.7813D-01 8.5279D-01 3.2881D-01
+ 2.8961D-01 2.0772D-01 8.4871D-01 3.2358D-01
+ 7.3990D-01 -4.6522D-04 9.7398D-01 3.4994D-01
+ 2.2242D+00 3.9709D+00 9.8325D-01 4.1429D+00
+ 4 0
+( 2.1130D-01, 9.9330D-01) ( 8.0960D-01, 4.2370D-01) ( 4.8320D-01, 1.1670D-01) ( 6.5380D-01, 4.9430D-01)
+( 8.2400D-02, 8.3600D-01) ( 8.4740D-01, 2.6130D-01) ( 6.1350D-01, 6.2500D-01) ( 4.8990D-01, 3.6500D-02)
+( 7.5990D-01, 7.4690D-01) ( 4.5240D-01, 2.4030D-01) ( 2.7490D-01, 5.5100D-01) ( 7.7410D-01, 2.2600D-01)
+( 8.7000D-03, 3.7800D-02) ( 8.0750D-01, 3.4050D-01) ( 8.8070D-01, 3.5500D-01) ( 9.6260D-01, 8.1590D-01)
+ -6.2157D-01 6.0607D-01 8.7533D-01 8.1980D-01
+ 2.8890D-01 -2.6354D-01 8.2538D-01 8.1086D-01
+ 3.8017D-01 5.4217D-01 7.4771D-01 7.0323D-01
+ 2.2487D+00 1.7368D+00 9.2372D-01 2.2178D+00
+ 3 0
+( 1.0D0, 2.0D0) ( 3.0D0, 4.0D0) ( 2.1D1, 2.2D1)
+( 4.3D1, 4.4D1) ( 1.3D1, 1.4D1) ( 1.5D1, 1.6D1)
+( 5.0D0, 6.0D0) ( 7.0D0, 8.0D0) ( 2.5D1, 2.6D1)
+ -7.4775D+00 6.8803D+00 3.9550D-01 1.6583D+01
+ 6.7009D+00 -7.8760D+00 3.9828D-01 1.6312D+01
+ 3.9777D+01 4.2996D+01 7.9686D-01 3.7399D+01
+ 4 0
+( 5.0D0, 9.0D0) ( 5.0D0, 5.0D0) (-6.0D0,-6.0D0) (-7.0D0,-7.0D0)
+( 3.0D0, 3.0D0) ( 6.0D0, 1.0D1) (-5.0D0,-5.0D0) (-6.0D0,-6.0D0)
+( 2.0D0, 2.0D0) ( 3.0D0, 3.0D0) (-1.0D0, 3.0D0) (-5.0D0,-5.0D0)
+( 1.0D0, 1.0D0) ( 2.0D0, 2.0D0) (-3.0D0,-3.0D0) ( 0.0D0, 4.0D0)
+ 1.0D0 5.0D0 2.1822D-01 7.4651D-01
+ 2.0D0 6.0D0 2.1822D-01 3.0893D-01
+ 3.0D0 7.0D0 2.1822D-01 1.8315D-01
+ 4.0D0 8.0D0 2.1822D-01 6.6350D-01
+ 4 0
+( 3.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 2.0D0)
+( 1.0D0, 0.0D0) ( 3.0D0, 0.0D0) ( 0.0D0,-2.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 2.0D0) ( 1.0D0, 0.0D0) ( 1.0D0, 0.0D0)
+( 0.0D0,-2.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 1.0D0, 0.0D0)
+ -8.2843D-01 1.6979D-07 1.0D0 8.2843D-01
+ 4.1744D-07 7.1526D-08 1.0D0 8.2843D-01
+ 4.0D0 1.6690D-07 1.0D0 8.2843D-01
+ 4.8284D+00 6.8633D-08 1.0D0 8.2843D-01
+ 4 0
+( 7.0D0, 0.0D0) ( 3.0D0, 0.0D0) ( 1.0D0, 2.0D0) (-1.0D0, 2.0D0)
+( 3.0D0, 0.0D0) ( 7.0D0, 0.0D0) ( 1.0D0,-2.0D0) (-1.0D0,-2.0D0)
+( 1.0D0,-2.0D0) ( 1.0D0, 2.0D0) ( 7.0D0, 0.0D0) (-3.0D0, 0.0D0)
+(-1.0D0,-2.0D0) (-2.0D0, 2.0D0) (-3.0D0, 0.0D0) ( 7.0D0, 0.0D0)
+ -8.0767D-03 -2.5211D-01 9.9864D-01 7.7961D+00
+ 7.7723D+00 2.4349D-01 7.0272D-01 3.3337D-01
+ 8.0D0 -3.4273D-07 7.0711D-01 3.3337D-01
+ 1.2236D+01 8.6188D-03 9.9021D-01 3.9429D+00
+ 5 0
+( 1.0D0, 2.0D0) ( 3.0D0, 4.0D0) ( 2.1D1, 2.2D1) ( 2.3D1, 2.4D1) ( 4.1D1, 4.2D1)
+( 4.3D1, 4.4D1) ( 1.3D1, 1.4D1) ( 1.5D1, 1.6D1) ( 3.3D1, 3.4D1) ( 3.5D1, 3.6D1)
+( 5.0D0, 6.0D0) ( 7.0D0, 8.0D0) ( 2.5D1, 2.6D1) ( 2.7D1, 2.8D1) ( 4.5D1, 4.6D1)
+( 4.7D1, 4.8D1) ( 1.7D1, 1.8D1) ( 1.9D1, 2.0D1) ( 3.7D1, 3.8D1) ( 3.9D1, 4.0D1)
+( 9.0D0, 1.0D1) ( 1.1D1, 1.2D1) ( 2.9D1, 3.0D1) ( 3.1D1, 3.2D1) ( 4.9D1, 5.0D1)
+ -9.4600D+00 7.2802D+00 3.1053D-01 1.1937D+01
+ -7.7912D-06 -1.2743D-05 2.9408D-01 1.6030D-05
+ -7.3042D-06 3.2789D-06 7.2259D-01 6.7794D-06
+ 7.0733D+00 -9.5584D+00 3.0911D-01 1.1891D+01
+ 1.2739D+02 1.3228D+02 9.2770D-01 1.2111D+02
+ 3 0
+( 1.0D0, 1.0D0) (-1.0D0,-1.0D0) ( 2.0D0, 2.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 2.0D0, 0.0D0)
+( 0.0D0, 0.0D0) (-1.0D0, 0.0D0) ( 3.0D0, 1.0D0)
+ 1.0D0 1.0D0 3.0151D-01 0.0D0
+ 1.0D0 1.0D0 3.1623D-01 0.0D0
+ 2.0D0 1.0D0 2.2361D-01 1.0D0
+ 4 1
+(-4.0D0,-2.0D0) (-5.0D0,-6.0D0) (-2.0D0,-6.0D0) ( 0.0D0,-2.0D0)
+( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+ -9.9883D-01 -1.0006D+00 1.3180D-04 2.4106D-04
+-1.0012D+00 -9.9945D-01 1.3140D-04 2.4041D-04
+ -9.9947D-01 -6.8325D-04 1.3989D-04 8.7487D-05
+-1.0005D+00 6.8556D-04 1.4010D-04 8.7750D-05
+ 7 0
+( 2.0D0, 4.0D0) ( 1.0D0, 1.0D0) ( 6.0D0, 2.0D0) ( 3.0D0, 3.0D0) ( 5.0D0, 5.0D0) ( 2.0D0, 6.0D0) ( 1.0D0, 1.0D0)
+( 1.0D0, 2.0D0) ( 1.0D0, 3.0D0) ( 3.0D0, 1.0D0) ( 5.0D0,-4.0D0) ( 1.0D0, 1.0D0) ( 7.0D0, 2.0D0) ( 2.0D0, 3.0D0)
+( 0.0D0, 0.0D0) ( 3.0D0,-2.0D0) ( 1.0D0, 1.0D0) ( 6.0D0, 3.0D0) ( 2.0D0, 1.0D0) ( 1.0D0, 4.0D0) ( 2.0D0, 1.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 2.0D0, 3.0D0) ( 3.0D0, 1.0D0) ( 1.0D0, 2.0D0) ( 2.0D0, 2.0D0) ( 3.0D0, 1.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 2.0D0,-1.0D0) ( 2.0D0, 2.0D0) ( 3.0D0, 1.0D0) ( 1.0D0, 3.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0,-1.0D0) ( 2.0D0, 1.0D0) ( 2.0D0, 2.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 2.0D0,-2.0D0) ( 1.0D0, 1.0D0)
+ -2.7081D+00 -2.8029D+00 6.9734D-01 3.9279D+00
+-1.1478D+00 8.0176D-01 6.5772D-01 9.4243D-01
+ -8.0109D-01 4.9694D+00 4.6751D-01 1.3779D+00
+ 9.9492D-01 3.1688D+00 3.5095D-01 5.9845D-01
+ 2.0809D+00 1.9341D+00 4.9042D-01 3.9035D-01
+ 5.3138D+00 1.2242D+00 3.0213D-01 7.1268D-01
+ 8.2674D+00 3.7047D+00 2.8270D-01 3.2849D+00
+ 5 1
+( 0.0D0, 5.0D0) ( 1.0D0, 2.0D0) ( 2.0D0, 3.0D0) (-3.0D0, 6.0D0) ( 6.0D0, 0.0D0)
+(-1.0D0, 2.0D0) ( 0.0D0, 6.0D0) ( 4.0D0, 5.0D0) (-3.0D0,-2.0D0) ( 5.0D0, 0.0D0)
+(-2.0D0, 3.0D0) (-4.0D0, 5.0D0) ( 0.0D0, 7.0D0) ( 3.0D0, 0.0D0) ( 2.0D0, 0.0D0)
+( 3.0D0, 6.0D0) ( 3.0D0,-2.0D0) (-3.0D0, 0.0D0) ( 0.0D0,-5.0D0) ( 2.0D0, 1.0D0)
+(-6.0D0, 0.0D0) (-5.0D0, 0.0D0) (-2.0D0, 0.0D0) (-2.0D0, 1.0D0) ( 0.0D0, 2.0D0)
+ -4.1735D-08 -1.0734D+01 1.0D0 7.7345D+00
+ -2.6397D-07 -2.9991D+00 1.0D0 4.5989D+00
+ 1.4565D-07 1.5998D+00 1.0D0 4.5989D+00
+ -4.4369D-07 9.3159D+00 1.0D0 7.7161D+00
+ 4.0937D-09 1.7817D+01 1.0D0 8.5013D+00
+ 3 0
+( 2.0D0, 0.0D0) ( 0.0D0,-1.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 1.0D0) ( 2.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 3.0D0, 0.0D0)
+ 1.0D0 0.0D0 1.0D0 2.0D0
+ 3.0D0 0.0D0 1.0D0 0.0D0
+ 3.0D0 0.0D0 1.0D0 0.0D0
+ 0 0
+ 1 1 0
+ 1
+( 0.0D0, 0.0D0)
+ 1.0D0 0.0D0
+ 1 1 0
+ 1
+( 1.0D0, 0.0D0)
+ 1.0D0 1.0D0
+ 5 3 0
+ 2 3 4
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+ 1.0D0 2.9582D-31
+ 5 3 0
+ 1 3 5
+( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0)
+ 1.0D0 1.1921D-07
+ 5 2 0
+ 2 4
+( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 2.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 3.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 4.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 5.0D0, 0.0D0)
+ 1.0D0 1.0D0
+ 6 3 1
+ 3 4 6
+( 0.0D0, 1.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 1.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 1.0D0)
+ 4.0124D-36 3.2099D-36
+ 6 3 0
+ 1 3 5
+( 0.0D0, 1.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 1.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 1.0D0)
+ 4.0124D-36 3.2099D-36
+ 4 2 0
+ 3 4
+( 9.4480D-01, 1.0D0) ( 6.7670D-01, 1.0D0) ( 6.9080D-01, 1.0D0) ( 5.9650D-01, 1.0D0)
+( 5.8760D-01, 1.0D0) ( 8.6420D-01, 1.0D0) ( 6.7690D-01, 1.0D0) ( 7.2600D-02, 1.0D0)
+( 7.2560D-01, 1.0D0) ( 1.9430D-01, 1.0D0) ( 9.6870D-01, 1.0D0) ( 2.8310D-01, 1.0D0)
+( 2.8490D-01, 1.0D0) ( 5.8000D-02, 1.0D0) ( 4.8450D-01, 1.0D0) ( 7.3610D-01, 1.0D0)
+ 9.6350D-01 3.3122D-01
+ 4 2 0
+ 2 3
+( 2.1130D-01, 9.9330D-01) ( 8.0960D-01, 4.2370D-01) ( 4.8320D-01, 1.1670D-01) ( 6.5380D-01, 4.9430D-01)
+( 8.2400D-02, 8.3600D-01) ( 8.4740D-01, 2.6130D-01) ( 6.1350D-01, 6.2500D-01) ( 4.8990D-01, 3.6500D-02)
+( 7.5990D-01, 7.4690D-01) ( 4.5240D-01, 2.4030D-01) ( 2.7490D-01, 5.5100D-01) ( 7.7410D-01, 2.2600D-01)
+( 8.7000D-03, 3.7800D-02) ( 8.0750D-01, 3.4050D-01) ( 8.8070D-01, 3.5500D-01) ( 9.6260D-01, 8.1590D-01)
+ 8.4053D-01 7.4754D-01
+ 3 2 0
+ 2 3
+( 1.0D0, 2.0D0) ( 3.0D0, 4.0D0) ( 2.1D1, 2.2D1)
+( 4.3D1, 4.4D1) ( 1.3D1, 1.4D1) ( 1.5D1, 1.6D1)
+( 5.0D0, 6.0D0) ( 7.0D0, 8.0D0) ( 2.5D1, 2.6D1)
+ 3.9550D-01 2.0464D+01
+ 4 2 0
+ 1 3
+( 5.0D0, 9.0D0) ( 5.0D0, 5.0D0) (-6.0D0,-6.0D0) (-7.0D0,-7.0D0)
+( 3.0D0, 3.0D0) ( 6.0D0, 1.0D1) (-5.0D0,-5.0D0) (-6.0D0,-6.0D0)
+( 2.0D0, 2.0D0) ( 3.0D0, 3.0D0) (-1.0D0, 3.0D0) (-5.0D0,-5.0D0)
+( 1.0D0, 1.0D0) ( 2.0D0, 2.0D0) (-3.0D0,-3.0D0) ( 0.0D0, 4.0D0)
+ 3.3333D-01 1.2569D-01
+ 4 3 0
+ 1 3 4
+( 3.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 2.0D0)
+( 1.0D0, 0.0D0) ( 3.0D0, 0.0D0) ( 0.0D0,-2.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 2.0D0) ( 1.0D0, 0.0D0) ( 1.0D0, 0.0D0)
+( 0.0D0,-2.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 1.0D0, 0.0D0)
+ 1.0D0 8.2843D-01
+ 4 2 0
+ 2 3
+( 7.0D0, 0.0D0) ( 3.0D0, 0.0D0) ( 1.0D0, 2.0D0) (-1.0D0, 2.0D0)
+( 3.0D0, 0.0D0) ( 7.0D0, 0.0D0) ( 1.0D0,-2.0D0) (-1.0D0,-2.0D0)
+( 1.0D0,-2.0D0) ( 1.0D0, 2.0D0) ( 7.0D0, 0.0D0) (-3.0D0, 0.0D0)
+(-1.0D0,-2.0D0) (-2.0D0, 2.0D0) (-3.0D0, 0.0D0) ( 7.0D0, 0.0D0)
+ 9.8985D-01 4.1447D+00
+ 5 2 1
+ 2 3
+( 1.0D0, 2.0D0) ( 3.0D0, 4.0D0) ( 2.1D1, 2.2D1) ( 2.3D1, 2.4D1) ( 4.1D1, 4.2D1)
+( 4.3D1, 4.4D1) ( 1.3D1, 1.4D1) ( 1.5D1, 1.6D1) ( 3.3D1, 3.4D1) ( 3.5D1, 3.6D1)
+( 5.0D0, 6.0D0) ( 7.0D0, 8.0D0) ( 2.5D1, 2.6D1) ( 2.7D1, 2.8D1) ( 4.5D1, 4.6D1)
+( 4.7D1, 4.8D1) ( 1.7D1, 1.8D1) ( 1.9D1, 2.0D1) ( 3.7D1, 3.8D1) ( 3.9D1, 4.0D1)
+( 9.0D0, 1.0D1) ( 1.1D1, 1.2D1) ( 2.9D1, 3.0D1) ( 3.1D1, 3.2D1) ( 4.9D1, 5.0D1)
+ 3.1088D-01 4.6912D+00
+ 3 2 0
+ 1 2
+( 1.0D0, 1.0D0) (-1.0D0,-1.0D0) ( 2.0D0, 2.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 2.0D0, 0.0D0)
+( 0.0D0, 0.0D0) (-1.0D0, 0.0D0) ( 3.0D0, 1.0D0)
+ 2.2361D-01 1.0D0
+ 4 2 1
+ 1 3
+(-4.0D0,-2.0D0) (-5.0D0,-6.0D0) (-2.0D0,-6.0D0) ( 0.0D0,-2.0D0)
+( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+ 7.2803D-05 1.1947D-04
+ 7 4 0
+ 1 4 6 7
+( 2.0D0, 4.0D0) ( 1.0D0, 1.0D0) ( 6.0D0, 2.0D0) ( 3.0D0, 3.0D0) ( 5.0D0, 5.0D0) ( 2.0D0, 6.0D0) ( 1.0D0, 1.0D0)
+( 1.0D0, 2.0D0) ( 1.0D0, 3.0D0) ( 3.0D0, 1.0D0) ( 5.0D0,-4.0D0) ( 1.0D0, 1.0D0) ( 7.0D0, 2.0D0) ( 2.0D0, 3.0D0)
+( 0.0D0, 0.0D0) ( 3.0D0,-2.0D0) ( 1.0D0, 1.0D0) ( 6.0D0, 3.0D0) ( 2.0D0, 1.0D0) ( 1.0D0, 4.0D0) ( 2.0D0, 1.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 2.0D0, 3.0D0) ( 3.0D0, 1.0D0) ( 1.0D0, 2.0D0) ( 2.0D0, 2.0D0) ( 3.0D0, 1.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 2.0D0,-1.0D0) ( 2.0D0, 2.0D0) ( 3.0D0, 1.0D0) ( 1.0D0, 3.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 1.0D0,-1.0D0) ( 2.0D0, 1.0D0) ( 2.0D0, 2.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 2.0D0,-2.0D0) ( 1.0D0, 1.0D0)
+ 3.7241D-01 5.2080D-01
+ 5 3 1
+ 1 3 5
+( 0.0D0, 5.0D0) ( 1.0D0, 2.0D0) ( 2.0D0, 3.0D0) (-3.0D0, 6.0D0) ( 6.0D0, 0.0D0)
+(-1.0D0, 2.0D0) ( 0.0D0, 6.0D0) ( 4.0D0, 5.0D0) (-3.0D0,-2.0D0) ( 5.0D0, 0.0D0)
+(-2.0D0, 3.0D0) (-4.0D0, 5.0D0) ( 0.0D0, 7.0D0) ( 3.0D0, 0.0D0) ( 2.0D0, 0.0D0)
+( 3.0D0, 6.0D0) ( 3.0D0,-2.0D0) (-3.0D0, 0.0D0) ( 0.0D0,-5.0D0) ( 2.0D0, 1.0D0)
+(-6.0D0, 0.0D0) (-5.0D0, 0.0D0) (-2.0D0, 0.0D0) (-2.0D0, 1.0D0) ( 0.0D0, 2.0D0)
+ 1.0D0 4.5989D+00
+ 8 4 1
+ 1 2 3 4
+( 0.0D0, 1.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 1.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 2.0D0) ( 2.0D0, 0.0D0) ( 0.0D0, 2.0D0) ( 2.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 1.0D0, 0.0D0) ( 0.0D0, 3.0D0) ( 3.0D0, 0.0D0) ( 0.0D0, 3.0D0) ( 3.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 1.0D0) ( 0.0D0, 4.0D0) ( 4.0D0, 0.0D0) ( 0.0D0, 4.0D0) ( 4.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 9.5D-1) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 9.5D-1) ( 1.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 9.5D-1) ( 1.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 0.0D0, 9.5D-1)
+ 9.5269D-12 2.9360D-11
+ 3 2 0
+ 2 3
+( 2.0D0, 0.0D0) ( 0.0D0,-1.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 1.0D0) ( 2.0D0, 0.0D0) ( 0.0D0, 0.0D0)
+( 0.0D0, 0.0D0) ( 0.0D0, 0.0D0) ( 3.0D0, 0.0D0)
+ 1.0D0 2.0D0
+ 0 0 0
diff --git a/TESTING/zed.in b/TESTING/zed.in
new file mode 100644
index 0000000..880ae19
--- /dev/null
+++ b/TESTING/zed.in
@@ -0,0 +1,1023 @@
+ZES Data for the Complex Nonsymmetric Schur Form Driver
+6 Number of matrix dimensions
+0 1 2 3 5 10 20 Matrix dimensions
+3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
+20.0 Threshold for test ratios
+T
+2 Read another line with random number generator seed
+2518 3899 995 397 Seed for random number generator
+ZES 21 Use all matrix types
+ZEV Data for the Complex Nonsymmetric Eigenvalue Driver
+6 Number of matrix dimensions
+0 1 2 3 5 10 20 Matrix dimensions
+3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
+20.0 Threshold for test ratios
+T
+2 Read another line with random number generator seed
+2518 3899 995 397 Seed for random number generator
+ZEV 21 Use all matrix types
+ZSX Data for the Complex Nonsymmetric Schur Form Expert Driver
+6 Number of matrix dimensions
+0 1 2 3 5 10 20 Matrix dimensions
+3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
+20.0 Threshold for test ratios
+T
+2 Read another line with random number generator seed
+2518 3899 995 397 Seed for random number generator
+ZSX 21 Use all matrix types
+ 1 1 0
+ 1
+( 0.0000D+00, 0.0000D+00)
+ 1.0000D+00 0.0000D+00
+ 1 1 0
+ 1
+( 1.0000D+00, 0.0000D+00)
+ 1.0000D+00 1.0000D+00
+ 5 3 0
+ 2 3 4
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+ 1.0000D+00 2.9582D-31
+ 5 3 0
+ 1 3 5
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+ 1.0000D+00 1.0000D+00
+ 5 2 0
+ 2 4
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 2.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 3.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 4.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 5.0000D+00, 0.0000D+00)
+ 1.0000D+00 1.0000D+00
+ 6 3 1
+ 3 4 6
+( 0.0000D+00, 1.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+ 1.0000D+00 2.0000D+00
+ 6 3 0
+ 1 3 5
+( 0.0000D+00, 1.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+ 1.0000D+00 2.0000D+00
+ 4 2 0
+ 3 4
+( 9.4480D-01, 1.0000D+00)
+( 6.7670D-01, 1.0000D+00)
+( 6.9080D-01, 1.0000D+00)
+( 5.9650D-01, 1.0000D+00)
+( 5.8760D-01, 1.0000D+00)
+( 8.6420D-01, 1.0000D+00)
+( 6.7690D-01, 1.0000D+00)
+( 7.2600D-02, 1.0000D+00)
+( 7.2560D-01, 1.0000D+00)
+( 1.9430D-01, 1.0000D+00)
+( 9.6870D-01, 1.0000D+00)
+( 2.8310D-01, 1.0000D+00)
+( 2.8490D-01, 1.0000D+00)
+( 5.8000D-02, 1.0000D+00)
+( 4.8450D-01, 1.0000D+00)
+( 7.3610D-01, 1.0000D+00)
+ 9.6350D-01 3.3122D-01
+ 4 2 0
+ 2 3
+( 2.1130D-01, 9.9330D-01)
+( 8.0960D-01, 4.2370D-01)
+( 4.8320D-01, 1.1670D-01)
+( 6.5380D-01, 4.9430D-01)
+( 8.2400D-02, 8.3600D-01)
+( 8.4740D-01, 2.6130D-01)
+( 6.1350D-01, 6.2500D-01)
+( 4.8990D-01, 3.6500D-02)
+( 7.5990D-01, 7.4690D-01)
+( 4.5240D-01, 2.4030D-01)
+( 2.7490D-01, 5.5100D-01)
+( 7.7410D-01, 2.2600D-01)
+( 8.7000D-03, 3.7800D-02)
+( 8.0750D-01, 3.4050D-01)
+( 8.8070D-01, 3.5500D-01)
+( 9.6260D-01, 8.1590D-01)
+ 8.4053D-01 7.4754D-01
+ 3 2 0
+ 2 3
+( 1.0000D+00, 2.0000D+00)
+( 3.0000D+00, 4.0000D+00)
+( 2.1000D+01, 2.2000D+01)
+( 4.3000D+01, 4.4000D+01)
+( 1.3000D+01, 1.4000D+01)
+( 1.5000D+01, 1.6000D+01)
+( 5.0000D+00, 6.0000D+00)
+( 7.0000D+00, 8.0000D+00)
+( 2.5000D+01, 2.6000D+01)
+ 3.9550D-01 2.0464D+01
+ 4 2 0
+ 1 3
+( 5.0000D+00, 9.0000D+00)
+( 5.0000D+00, 5.0000D+00)
+(-6.0000D+00,-6.0000D+00)
+(-7.0000D+00,-7.0000D+00)
+( 3.0000D+00, 3.0000D+00)
+( 6.0000D+00, 1.0000D+01)
+(-5.0000D+00,-5.0000D+00)
+(-6.0000D+00,-6.0000D+00)
+( 2.0000D+00, 2.0000D+00)
+( 3.0000D+00, 3.0000D+00)
+(-1.0000D+00, 3.0000D+00)
+(-5.0000D+00,-5.0000D+00)
+( 1.0000D+00, 1.0000D+00)
+( 2.0000D+00, 2.0000D+00)
+(-3.0000D+00,-3.0000D+00)
+( 0.0000D+00, 4.0000D+00)
+ 3.3333D-01 1.2569D-01
+ 4 3 0
+ 1 3 4
+( 3.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 2.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 3.0000D+00, 0.0000D+00)
+( 0.0000D+00,-2.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 2.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00,-2.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+ 1.0000D+00 8.2843D-01
+ 4 2 0
+ 2 3
+( 7.0000D+00, 0.0000D+00)
+( 3.0000D+00, 0.0000D+00)
+( 1.0000D+00, 2.0000D+00)
+(-1.0000D+00, 2.0000D+00)
+( 3.0000D+00, 0.0000D+00)
+( 7.0000D+00, 0.0000D+00)
+( 1.0000D+00,-2.0000D+00)
+(-1.0000D+00,-2.0000D+00)
+( 1.0000D+00,-2.0000D+00)
+( 1.0000D+00, 2.0000D+00)
+( 7.0000D+00, 0.0000D+00)
+(-3.0000D+00, 0.0000D+00)
+(-1.0000D+00,-2.0000D+00)
+(-2.0000D+00, 2.0000D+00)
+(-3.0000D+00, 0.0000D+00)
+( 7.0000D+00, 0.0000D+00)
+ 9.8985D-01 4.1447D+00
+ 5 2 1
+ 2 3
+( 1.0000D+00, 2.0000D+00)
+( 3.0000D+00, 4.0000D+00)
+( 2.1000D+01, 2.2000D+01)
+( 2.3000D+01, 2.4000D+01)
+( 4.1000D+01, 4.2000D+01)
+( 4.3000D+01, 4.4000D+01)
+( 1.3000D+01, 1.4000D+01)
+( 1.5000D+01, 1.6000D+01)
+( 3.3000D+01, 3.4000D+01)
+( 3.5000D+01, 3.6000D+01)
+( 5.0000D+00, 6.0000D+00)
+( 7.0000D+00, 8.0000D+00)
+( 2.5000D+01, 2.6000D+01)
+( 2.7000D+01, 2.8000D+01)
+( 4.5000D+01, 4.6000D+01)
+( 4.7000D+01, 4.8000D+01)
+( 1.7000D+01, 1.8000D+01)
+( 1.9000D+01, 2.0000D+01)
+( 3.7000D+01, 3.8000D+01)
+( 3.9000D+01, 4.0000D+01)
+( 9.0000D+00, 1.0000D+01)
+( 1.1000D+01, 1.2000D+01)
+( 2.9000D+01, 3.0000D+01)
+( 3.1000D+01, 3.2000D+01)
+( 4.9000D+01, 5.0000D+01)
+ 3.1088D-01 4.6912D+00
+ 3 2 0
+ 1 2
+( 1.0000D+00, 1.0000D+00)
+(-1.0000D+00,-1.0000D+00)
+( 2.0000D+00, 2.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 2.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+(-1.0000D+00, 0.0000D+00)
+( 3.0000D+00, 1.0000D+00)
+ 2.2361D-01 1.0000D+00
+ 4 2 1
+ 1 3
+(-4.0000D+00,-2.0000D+00)
+(-5.0000D+00,-6.0000D+00)
+(-2.0000D+00,-6.0000D+00)
+( 0.0000D+00,-2.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+ 7.2803D-05 1.1947D-04
+ 7 4 0
+ 1 4 6 7
+( 2.0000D+00, 4.0000D+00)
+( 1.0000D+00, 1.0000D+00)
+( 6.0000D+00, 2.0000D+00)
+( 3.0000D+00, 3.0000D+00)
+( 5.0000D+00, 5.0000D+00)
+( 2.0000D+00, 6.0000D+00)
+( 1.0000D+00, 1.0000D+00)
+( 1.0000D+00, 2.0000D+00)
+( 1.0000D+00, 3.0000D+00)
+( 3.0000D+00, 1.0000D+00)
+( 5.0000D+00,-4.0000D+00)
+( 1.0000D+00, 1.0000D+00)
+( 7.0000D+00, 2.0000D+00)
+( 2.0000D+00, 3.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 3.0000D+00,-2.0000D+00)
+( 1.0000D+00, 1.0000D+00)
+( 6.0000D+00, 3.0000D+00)
+( 2.0000D+00, 1.0000D+00)
+( 1.0000D+00, 4.0000D+00)
+( 2.0000D+00, 1.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 2.0000D+00, 3.0000D+00)
+( 3.0000D+00, 1.0000D+00)
+( 1.0000D+00, 2.0000D+00)
+( 2.0000D+00, 2.0000D+00)
+( 3.0000D+00, 1.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 2.0000D+00,-1.0000D+00)
+( 2.0000D+00, 2.0000D+00)
+( 3.0000D+00, 1.0000D+00)
+( 1.0000D+00, 3.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00,-1.0000D+00)
+( 2.0000D+00, 1.0000D+00)
+( 2.0000D+00, 2.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 2.0000D+00,-2.0000D+00)
+( 1.0000D+00, 1.0000D+00)
+ 3.7241D-01 5.2080D-01
+ 5 3 1
+ 1 3 5
+( 0.0000D+00, 5.0000D+00)
+( 1.0000D+00, 2.0000D+00)
+( 2.0000D+00, 3.0000D+00)
+(-3.0000D+00, 6.0000D+00)
+( 6.0000D+00, 0.0000D+00)
+(-1.0000D+00, 2.0000D+00)
+( 0.0000D+00, 6.0000D+00)
+( 4.0000D+00, 5.0000D+00)
+(-3.0000D+00,-2.0000D+00)
+( 5.0000D+00, 0.0000D+00)
+(-2.0000D+00, 3.0000D+00)
+(-4.0000D+00, 5.0000D+00)
+( 0.0000D+00, 7.0000D+00)
+( 3.0000D+00, 0.0000D+00)
+( 2.0000D+00, 0.0000D+00)
+( 3.0000D+00, 6.0000D+00)
+( 3.0000D+00,-2.0000D+00)
+(-3.0000D+00, 0.0000D+00)
+( 0.0000D+00,-5.0000D+00)
+( 2.0000D+00, 1.0000D+00)
+(-6.0000D+00, 0.0000D+00)
+(-5.0000D+00, 0.0000D+00)
+(-2.0000D+00, 0.0000D+00)
+(-2.0000D+00, 1.0000D+00)
+( 0.0000D+00, 2.0000D+00)
+ 1.0000D+00 4.5989D+00
+ 8 4 1
+ 1 2 3 4
+( 0.0000D+00, 1.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 2.0000D+00)
+( 2.0000D+00, 0.0000D+00)
+( 0.0000D+00, 2.0000D+00)
+( 2.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 3.0000D+00)
+( 3.0000D+00, 0.0000D+00)
+( 0.0000D+00, 3.0000D+00)
+( 3.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 0.0000D+00, 4.0000D+00)
+( 4.0000D+00, 0.0000D+00)
+( 0.0000D+00, 4.0000D+00)
+( 4.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 9.5000D-01)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 9.5000D-01)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 9.5000D-01)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 9.5000D-01)
+ 9.5269D-12 2.9360D-11
+ 3 2 0
+ 2 3
+( 2.0000D+00, 0.0000D+00)
+( 0.0000D+00,-1.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 2.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 3.0000D+00, 0.0000D+00)
+ 1.0000D+00 2.0000D+00
+ 0 0 0
+ZVX Data for Complex Nonsymmetric Eigenvalue Expert Driver
+6 Number of matrix dimensions
+0 1 2 3 5 10 20 Matrix dimensions
+3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
+20.0 Threshold for test ratios
+T
+2 Read another line with random number generator seed
+2518 3899 995 397 Seed for random number generator
+ZVX 21 Use all matrix types
+ 1 0
+( 0.0000D+00, 0.0000D+00)
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 1 0
+( 0.0000D+00, 1.0000D+00)
+ 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
+ 2 0
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 2 0
+( 3.0000D+00, 0.0000D+00)
+( 2.0000D+00, 0.0000D+00)
+( 2.0000D+00, 0.0000D+00)
+( 3.0000D+00, 0.0000D+00)
+ 1.0000D+00 0.0000D+00 1.0000D+00 4.0000D+00
+ 5.0000D+00 0.0000D+00 1.0000D+00 4.0000D+00
+ 2 0
+( 3.0000D+00, 0.0000D+00)
+( 0.0000D+00, 2.0000D+00)
+( 0.0000D+00, 2.0000D+00)
+( 3.0000D+00, 0.0000D+00)
+ 3.0000D+00 2.0000D+00 1.0000D+00 4.0000D+00
+ 3.0000D+00 -2.0000D+00 1.0000D+00 4.0000D+00
+ 5 0
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 5 0
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+ 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 5 0
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 2.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 3.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 4.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 5.0000D+00, 0.0000D+00)
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 2.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 3.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 4.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 5.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 6 0
+( 0.0000D+00, 1.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+ 0.0000D+00 1.0000D+00 1.1921D-07 0.0000D+00
+ 0.0000D+00 1.0000D+00 2.4074D-35 0.0000D+00
+ 0.0000D+00 1.0000D+00 2.4074D-35 0.0000D+00
+ 0.0000D+00 1.0000D+00 2.4074D-35 0.0000D+00
+ 0.0000D+00 1.0000D+00 2.4074D-35 0.0000D+00
+ 0.0000D+00 1.0000D+00 1.1921D-07 0.0000D+00
+ 6 0
+( 0.0000D+00, 1.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+ 0.0000D+00 1.0000D+00 1.1921D-07 0.0000D+00
+ 0.0000D+00 1.0000D+00 2.4074D-35 0.0000D+00
+ 0.0000D+00 1.0000D+00 2.4074D-35 0.0000D+00
+ 0.0000D+00 1.0000D+00 2.4074D-35 0.0000D+00
+ 0.0000D+00 1.0000D+00 2.4074D-35 0.0000D+00
+ 0.0000D+00 1.0000D+00 1.1921D-07 0.0000D+00
+ 4 0
+( 9.4480D-01, 1.0000D+00)
+( 6.7670D-01, 1.0000D+00)
+( 6.9080D-01, 1.0000D+00)
+( 5.9650D-01, 1.0000D+00)
+( 5.8760D-01, 1.0000D+00)
+( 8.6420D-01, 1.0000D+00)
+( 6.7690D-01, 1.0000D+00)
+( 7.2600D-02, 1.0000D+00)
+( 7.2560D-01, 1.0000D+00)
+( 1.9430D-01, 1.0000D+00)
+( 9.6870D-01, 1.0000D+00)
+( 2.8310D-01, 1.0000D+00)
+( 2.8490D-01, 1.0000D+00)
+( 5.8000D-02, 1.0000D+00)
+( 4.8450D-01, 1.0000D+00)
+( 7.3610D-01, 1.0000D+00)
+ 2.6014D-01 -1.7813D-01 8.5279D-01 3.2881D-01
+ 2.8961D-01 2.0772D-01 8.4871D-01 3.2358D-01
+ 7.3990D-01 -4.6522D-04 9.7398D-01 3.4994D-01
+ 2.2242D+00 3.9709D+00 9.8325D-01 4.1429D+00
+ 4 0
+( 2.1130D-01, 9.9330D-01)
+( 8.0960D-01, 4.2370D-01)
+( 4.8320D-01, 1.1670D-01)
+( 6.5380D-01, 4.9430D-01)
+( 8.2400D-02, 8.3600D-01)
+( 8.4740D-01, 2.6130D-01)
+( 6.1350D-01, 6.2500D-01)
+( 4.8990D-01, 3.6500D-02)
+( 7.5990D-01, 7.4690D-01)
+( 4.5240D-01, 2.4030D-01)
+( 2.7490D-01, 5.5100D-01)
+( 7.7410D-01, 2.2600D-01)
+( 8.7000D-03, 3.7800D-02)
+( 8.0750D-01, 3.4050D-01)
+( 8.8070D-01, 3.5500D-01)
+( 9.6260D-01, 8.1590D-01)
+ -6.2157D-01 6.0607D-01 8.7533D-01 8.1980D-01
+ 2.8890D-01 -2.6354D-01 8.2538D-01 8.1086D-01
+ 3.8017D-01 5.4217D-01 7.4771D-01 7.0323D-01
+ 2.2487D+00 1.7368D+00 9.2372D-01 2.2178D+00
+ 3 0
+( 1.0000D+00, 2.0000D+00)
+( 3.0000D+00, 4.0000D+00)
+( 2.1000D+01, 2.2000D+01)
+( 4.3000D+01, 4.4000D+01)
+( 1.3000D+01, 1.4000D+01)
+( 1.5000D+01, 1.6000D+01)
+( 5.0000D+00, 6.0000D+00)
+( 7.0000D+00, 8.0000D+00)
+( 2.5000D+01, 2.6000D+01)
+ -7.4775D+00 6.8803D+00 3.9550D-01 1.6583D+01
+ 6.7009D+00 -7.8760D+00 3.9828D-01 1.6312D+01
+ 3.9777D+01 4.2996D+01 7.9686D-01 3.7399D+01
+ 4 0
+( 5.0000D+00, 9.0000D+00)
+( 5.0000D+00, 5.0000D+00)
+(-6.0000D+00,-6.0000D+00)
+(-7.0000D+00,-7.0000D+00)
+( 3.0000D+00, 3.0000D+00)
+( 6.0000D+00, 1.0000D+01)
+(-5.0000D+00,-5.0000D+00)
+(-6.0000D+00,-6.0000D+00)
+( 2.0000D+00, 2.0000D+00)
+( 3.0000D+00, 3.0000D+00)
+(-1.0000D+00, 3.0000D+00)
+(-5.0000D+00,-5.0000D+00)
+( 1.0000D+00, 1.0000D+00)
+( 2.0000D+00, 2.0000D+00)
+(-3.0000D+00,-3.0000D+00)
+( 0.0000D+00, 4.0000D+00)
+ 1.0000D+00 5.0000D+00 2.1822D-01 7.4651D-01
+ 2.0000D+00 6.0000D+00 2.1822D-01 3.0893D-01
+ 3.0000D+00 7.0000D+00 2.1822D-01 1.8315D-01
+ 4.0000D+00 8.0000D+00 2.1822D-01 6.6350D-01
+ 4 0
+( 3.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 2.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 3.0000D+00, 0.0000D+00)
+( 0.0000D+00,-2.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 2.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00,-2.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+ -8.2843D-01 1.6979D-07 1.0000D+00 8.2843D-01
+ 4.1744D-07 7.1526D-08 1.0000D+00 8.2843D-01
+ 4.0000D+00 1.6690D-07 1.0000D+00 8.2843D-01
+ 4.8284D+00 6.8633D-08 1.0000D+00 8.2843D-01
+ 4 0
+( 7.0000D+00, 0.0000D+00)
+( 3.0000D+00, 0.0000D+00)
+( 1.0000D+00, 2.0000D+00)
+(-1.0000D+00, 2.0000D+00)
+( 3.0000D+00, 0.0000D+00)
+( 7.0000D+00, 0.0000D+00)
+( 1.0000D+00,-2.0000D+00)
+(-1.0000D+00,-2.0000D+00)
+( 1.0000D+00,-2.0000D+00)
+( 1.0000D+00, 2.0000D+00)
+( 7.0000D+00, 0.0000D+00)
+(-3.0000D+00, 0.0000D+00)
+(-1.0000D+00,-2.0000D+00)
+(-2.0000D+00, 2.0000D+00)
+(-3.0000D+00, 0.0000D+00)
+( 7.0000D+00, 0.0000D+00)
+ -8.0767D-03 -2.5211D-01 9.9864D-01 7.7961D+00
+ 7.7723D+00 2.4349D-01 7.0272D-01 3.3337D-01
+ 8.0000D+00 -3.4273D-07 7.0711D-01 3.3337D-01
+ 1.2236D+01 8.6188D-03 9.9021D-01 3.9429D+00
+ 5 0
+( 1.0000D+00, 2.0000D+00)
+( 3.0000D+00, 4.0000D+00)
+( 2.1000D+01, 2.2000D+01)
+( 2.3000D+01, 2.4000D+01)
+( 4.1000D+01, 4.2000D+01)
+( 4.3000D+01, 4.4000D+01)
+( 1.3000D+01, 1.4000D+01)
+( 1.5000D+01, 1.6000D+01)
+( 3.3000D+01, 3.4000D+01)
+( 3.5000D+01, 3.6000D+01)
+( 5.0000D+00, 6.0000D+00)
+( 7.0000D+00, 8.0000D+00)
+( 2.5000D+01, 2.6000D+01)
+( 2.7000D+01, 2.8000D+01)
+( 4.5000D+01, 4.6000D+01)
+( 4.7000D+01, 4.8000D+01)
+( 1.7000D+01, 1.8000D+01)
+( 1.9000D+01, 2.0000D+01)
+( 3.7000D+01, 3.8000D+01)
+( 3.9000D+01, 4.0000D+01)
+( 9.0000D+00, 1.0000D+01)
+( 1.1000D+01, 1.2000D+01)
+( 2.9000D+01, 3.0000D+01)
+( 3.1000D+01, 3.2000D+01)
+( 4.9000D+01, 5.0000D+01)
+ -9.4600D+00 7.2802D+00 3.1053D-01 1.1937D+01
+ -7.7912D-06 -1.2743D-05 2.9408D-01 1.6030D-05
+ -7.3042D-06 3.2789D-06 7.2259D-01 6.7794D-06
+ 7.0733D+00 -9.5584D+00 3.0911D-01 1.1891D+01
+ 1.2739D+02 1.3228D+02 9.2770D-01 1.2111D+02
+ 3 0
+( 1.0000D+00, 1.0000D+00)
+(-1.0000D+00,-1.0000D+00)
+( 2.0000D+00, 2.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 2.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+(-1.0000D+00, 0.0000D+00)
+( 3.0000D+00, 1.0000D+00)
+ 1.0000D+00 1.0000D+00 3.0151D-01 0.0000D+00
+ 1.0000D+00 1.0000D+00 3.1623D-01 0.0000D+00
+ 2.0000D+00 1.0000D+00 2.2361D-01 1.0000D+00
+ 4 1
+(-4.0000D+00,-2.0000D+00)
+(-5.0000D+00,-6.0000D+00)
+(-2.0000D+00,-6.0000D+00)
+( 0.0000D+00,-2.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+ -9.9883D-01 -1.0006D+00 1.3180D-04 2.4106D-04
+ -1.0012D+00 -9.9945D-01 1.3140D-04 2.4041D-04
+ -9.9947D-01 -6.8325D-04 1.3989D-04 8.7487D-05
+ -1.0005D+00 6.8556D-04 1.4010D-04 8.7750D-05
+ 7 0
+( 2.0000D+00, 4.0000D+00)
+( 1.0000D+00, 1.0000D+00)
+( 6.0000D+00, 2.0000D+00)
+( 3.0000D+00, 3.0000D+00)
+( 5.0000D+00, 5.0000D+00)
+( 2.0000D+00, 6.0000D+00)
+( 1.0000D+00, 1.0000D+00)
+( 1.0000D+00, 2.0000D+00)
+( 1.0000D+00, 3.0000D+00)
+( 3.0000D+00, 1.0000D+00)
+( 5.0000D+00,-4.0000D+00)
+( 1.0000D+00, 1.0000D+00)
+( 7.0000D+00, 2.0000D+00)
+( 2.0000D+00, 3.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 3.0000D+00,-2.0000D+00)
+( 1.0000D+00, 1.0000D+00)
+( 6.0000D+00, 3.0000D+00)
+( 2.0000D+00, 1.0000D+00)
+( 1.0000D+00, 4.0000D+00)
+( 2.0000D+00, 1.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 2.0000D+00, 3.0000D+00)
+( 3.0000D+00, 1.0000D+00)
+( 1.0000D+00, 2.0000D+00)
+( 2.0000D+00, 2.0000D+00)
+( 3.0000D+00, 1.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 2.0000D+00,-1.0000D+00)
+( 2.0000D+00, 2.0000D+00)
+( 3.0000D+00, 1.0000D+00)
+( 1.0000D+00, 3.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00,-1.0000D+00)
+( 2.0000D+00, 1.0000D+00)
+( 2.0000D+00, 2.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 2.0000D+00,-2.0000D+00)
+( 1.0000D+00, 1.0000D+00)
+ -2.7081D+00 -2.8029D+00 6.9734D-01 3.9279D+00
+ -1.1478D+00 8.0176D-01 6.5772D-01 9.4243D-01
+ -8.0109D-01 4.9694D+00 4.6751D-01 1.3779D+00
+ 9.9492D-01 3.1688D+00 3.5095D-01 5.9845D-01
+ 2.0809D+00 1.9341D+00 4.9042D-01 3.9035D-01
+ 5.3138D+00 1.2242D+00 3.0213D-01 7.1268D-01
+ 8.2674D+00 3.7047D+00 2.8270D-01 3.2849D+00
+ 5 1
+( 0.0000D+00, 5.0000D+00)
+( 1.0000D+00, 2.0000D+00)
+( 2.0000D+00, 3.0000D+00)
+(-3.0000D+00, 6.0000D+00)
+( 6.0000D+00, 0.0000D+00)
+(-1.0000D+00, 2.0000D+00)
+( 0.0000D+00, 6.0000D+00)
+( 4.0000D+00, 5.0000D+00)
+(-3.0000D+00,-2.0000D+00)
+( 5.0000D+00, 0.0000D+00)
+(-2.0000D+00, 3.0000D+00)
+(-4.0000D+00, 5.0000D+00)
+( 0.0000D+00, 7.0000D+00)
+( 3.0000D+00, 0.0000D+00)
+( 2.0000D+00, 0.0000D+00)
+( 3.0000D+00, 6.0000D+00)
+( 3.0000D+00,-2.0000D+00)
+(-3.0000D+00, 0.0000D+00)
+( 0.0000D+00,-5.0000D+00)
+( 2.0000D+00, 1.0000D+00)
+(-6.0000D+00, 0.0000D+00)
+(-5.0000D+00, 0.0000D+00)
+(-2.0000D+00, 0.0000D+00)
+(-2.0000D+00, 1.0000D+00)
+( 0.0000D+00, 2.0000D+00)
+ -4.1735D-08 -1.0734D+01 1.0000D+00 7.7345D+00
+ -2.6397D-07 -2.9991D+00 1.0000D+00 4.5989D+00
+ 1.4565D-07 1.5998D+00 1.0000D+00 4.5989D+00
+ -4.4369D-07 9.3159D+00 1.0000D+00 7.7161D+00
+ 4.0937D-09 1.7817D+01 1.0000D+00 8.5013D+00
+ 3 0
+( 2.0000D+00, 0.0000D+00)
+( 0.0000D+00,-1.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 1.0000D+00)
+( 2.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 3.0000D+00, 0.0000D+00)
+ 1.0000D+00 0.0000D+00 1.0000D+00 2.0000D+00
+ 3.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 3.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 0 0
diff --git a/TESTING/zgbak.in b/TESTING/zgbak.in
new file mode 100644
index 0000000..e11d502
--- /dev/null
+++ b/TESTING/zgbak.in
@@ -0,0 +1,446 @@
+ZGK: Tests ZGGBAK
+ 6 3
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.2000D+01, 0.2000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.3000D+01, 0.3000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.4000D+01, 0.4000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.5000D+01, 0.5000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.6000D+01, 0.6000D+01)
+
+( 0.6000D+01, 0.6000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.5000D+01, 0.5000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.4000D+01, 0.4000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.3000D+01, 0.3000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.2000D+01, 0.2000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.2000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.3000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.4000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.5000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.6000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+
+(-0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+(-0.2000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+(-0.3000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+(-0.4000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+(-0.5000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+(-0.6000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+
+ 6 2
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) (
+( 0.2000D+01, 0.2000D+01) ( 0.2000D+01, 0.2000D+01) (
+( 0.3000D+01, 0.3000D+01) ( 0.3000D+01, 0.3000D+01) (
+( 0.4000D+01, 0.4000D+01) ( 0.4000D+01, 0.4000D+01) (
+( 0.5000D+01, 0.5000D+01) ( 0.5000D+01, 0.5000D+01) (
+( 0.6000D+01, 0.6000D+01) ( 0.6000D+01, 0.6000D+01) (
+
+(-0.1000D+01,-0.1000D+01) (-0.1000D+01,-0.1000D+01) (
+(-0.2000D+01,-0.2000D+01) (-0.2000D+01,-0.2000D+01) (
+(-0.3000D+01,-0.3000D+01) (-0.3000D+01,-0.3000D+01) (
+(-0.4000D+01,-0.4000D+01) (-0.4000D+01,-0.4000D+01) (
+(-0.5000D+01,-0.5000D+01) (-0.5000D+01,-0.5000D+01) (
+(-0.6000D+01,-0.6000D+01) (-0.6000D+01,-0.6000D+01) (
+
+ 6 3
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.4000D+01, 0.4000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.4000D+01, 0.4000D+01) ( 0.5000D+01, 0.5000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.4000D+01, 0.4000D+01) ( 0.5000D+01, 0.5000D+01) ( 0.6000D+01, 0.6000D+01)
+
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.4000D+01, 0.4000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.4000D+01, 0.4000D+01) ( 0.5000D+01, 0.5000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.4000D+01, 0.4000D+01) ( 0.5000D+01, 0.5000D+01) ( 0.6000D+01, 0.6000D+01)
+
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.2000D+01, 0.2000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.2000D+01, 0.2000D+01)
+( 0.3000D+01, 0.3000D+01) ( 0.3000D+01, 0.3000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.4000D+01, 0.4000D+01) ( 0.4000D+01, 0.4000D+01) ( 0.4000D+01, 0.4000D+01)
+( 0.5000D+01, 0.5000D+01) ( 0.5000D+01, 0.5000D+01) ( 0.5000D+01, 0.5000D+01)
+( 0.6000D+01, 0.6000D+01) ( 0.6000D+01, 0.6000D+01) ( 0.6000D+01, 0.6000D+01)
+
+(-0.1000D+01,-0.1000D+01) (-0.1000D+01,-0.1000D+01) (-0.1000D+01,-0.1000D+01)
+(-0.2000D+01,-0.2000D+01) (-0.2000D+01,-0.2000D+01) (-0.2000D+01,-0.2000D+01)
+(-0.3000D+01,-0.3000D+01) (-0.3000D+01,-0.3000D+01) (-0.3000D+01,-0.3000D+01)
+(-0.4000D+01,-0.4000D+01) (-0.4000D+01,-0.4000D+01) (-0.4000D+01,-0.4000D+01)
+(-0.5000D+01,-0.5000D+01) (-0.5000D+01,-0.5000D+01) (-0.5000D+01,-0.5000D+01)
+(-0.6000D+01,-0.6000D+01) (-0.6000D+01,-0.6000D+01) (-0.6000D+01,-0.6000D+01)
+
+ 5 3
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) (
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) (
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) (
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.4000D+01, 0.4000D+01) ( 0.0000D+00, 0.0000D+00) (
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.4000D+01, 0.4000D+01) ( 0.5000D+01, 0.5000D+01) (
+
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) (
+
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.2000D+01, 0.2000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.2000D+01, 0.2000D+01)
+( 0.3000D+01, 0.3000D+01) ( 0.3000D+01, 0.3000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.4000D+01, 0.4000D+01) ( 0.4000D+01, 0.4000D+01) ( 0.4000D+01, 0.4000D+01)
+( 0.5000D+01, 0.5000D+01) ( 0.5000D+01, 0.5000D+01) ( 0.5000D+01, 0.5000D+01)
+
+(-0.1000D+01,-0.1000D+01) (-0.1000D+01,-0.1000D+01) (-0.1000D+01,-0.1000D+01)
+(-0.2000D+01,-0.2000D+01) (-0.2000D+01,-0.2000D+01) (-0.2000D+01,-0.2000D+01)
+(-0.3000D+01,-0.3000D+01) (-0.3000D+01,-0.3000D+01) (-0.3000D+01,-0.3000D+01)
+(-0.4000D+01,-0.4000D+01) (-0.4000D+01,-0.4000D+01) (-0.4000D+01,-0.4000D+01)
+(-0.5000D+01,-0.5000D+01) (-0.5000D+01,-0.5000D+01) (-0.5000D+01,-0.5000D+01)
+
+ 6 3
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+
+( 0.1000D+05, 0.1000D+05) ( 0.1000D+05, 0.1000D+05) ( 0.1000D+05, 0.1000D+05)
+( 0.2000D+05, 0.2000D+05) ( 0.2000D+05, 0.2000D+05) ( 0.2000D+05, 0.2000D+05)
+( 0.3000D+05, 0.3000D+05) ( 0.3000D+05, 0.3000D+05) ( 0.3000D+05, 0.3000D+05)
+( 0.4000D+05, 0.4000D+05) ( 0.4000D+05, 0.4000D+05) ( 0.4000D+05, 0.4000D+05)
+( 0.5000D+05, 0.5000D+05) ( 0.5000D+05, 0.5000D+05) ( 0.5000D+05, 0.5000D+05)
+( 0.6000D+05, 0.6000D+05) ( 0.6000D+05, 0.6000D+05) ( 0.6000D+05, 0.6000D+05)
+
+(-0.1000D+05,-0.1000D+05) (-0.1000D+05,-0.1000D+05) (-0.1000D+05,-0.1000D+05)
+(-0.2000D+05,-0.2000D+05) (-0.2000D+05,-0.2000D+05) (-0.2000D+05,-0.2000D+05)
+(-0.3000D+05,-0.3000D+05) (-0.3000D+05,-0.3000D+05) (-0.3000D+05,-0.3000D+05)
+(-0.4000D+05,-0.4000D+05) (-0.4000D+05,-0.4000D+05) (-0.4000D+05,-0.4000D+05)
+(-0.5000D+05,-0.5000D+05) (-0.5000D+05,-0.5000D+05) (-0.5000D+05,-0.5000D+05)
+(-0.6000D+05,-0.6000D+05) (-0.6000D+05,-0.6000D+05) (-0.6000D+05,-0.6000D+05)
+
+ 6 3
+( 0.1000D+01, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+07, 0.1000D+07) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D-05, 0.1000D-05) ( 0.1000D+07, 0.1000D+07)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+07, 0.1000D+07) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D-05, 0.1000D-05) ( 0.1000D-05, 0.1000D-05)
+( 0.1000D+07, 0.1000D+07) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+07, 0.1000D+07) ( 0.1000D+07, 0.1000D+07)
+
+( 0.1000D+01, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+07, 0.1000D+07) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D-05, 0.1000D-05) ( 0.1000D+07, 0.1000D+07)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+07, 0.1000D+07) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D-05, 0.1000D-05) ( 0.1000D-05, 0.1000D-05)
+( 0.1000D+07, 0.1000D+07) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+07, 0.1000D+07) ( 0.1000D+07, 0.1000D+07)
+
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.2000D+01, 0.2000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.2000D+01, 0.2000D+01)
+( 0.3000D+01, 0.3000D+01) ( 0.3000D+01, 0.3000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.4000D+01, 0.4000D+01) ( 0.4000D+01, 0.4000D+01) ( 0.4000D+01, 0.4000D+01)
+( 0.5000D+01, 0.5000D+01) ( 0.5000D+01, 0.5000D+01) ( 0.5000D+01, 0.5000D+01)
+( 0.6000D+01, 0.6000D+01) ( 0.6000D+01, 0.6000D+01) ( 0.6000D+01, 0.6000D+01)
+
+(-0.1000D+01,-0.1000D+01) (-0.1000D+01,-0.1000D+01) (-0.1000D+01,-0.1000D+01)
+(-0.2000D+01,-0.2000D+01) (-0.2000D+01,-0.2000D+01) (-0.2000D+01,-0.2000D+01)
+(-0.3000D+01,-0.3000D+01) (-0.3000D+01,-0.3000D+01) (-0.3000D+01,-0.3000D+01)
+(-0.4000D+01,-0.4000D+01) (-0.4000D+01,-0.4000D+01) (-0.4000D+01,-0.4000D+01)
+(-0.5000D+01,-0.5000D+01) (-0.5000D+01,-0.5000D+01) (-0.5000D+01,-0.5000D+01)
+(-0.6000D+01,-0.6000D+01) (-0.6000D+01,-0.6000D+01) (-0.6000D+01,-0.6000D+01)
+
+ 7 2
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) (
+( 0.2000D+01, 0.2000D+01) ( 0.2000D+01, 0.2000D+01) (
+( 0.3000D+01, 0.3000D+01) ( 0.3000D+01, 0.3000D+01) (
+( 0.4000D+01, 0.4000D+01) ( 0.4000D+01, 0.4000D+01) (
+( 0.5000D+01, 0.5000D+01) ( 0.5000D+01, 0.5000D+01) (
+( 0.6000D+01, 0.6000D+01) ( 0.6000D+01, 0.6000D+01) (
+( 0.7000D+01, 0.7000D+01) ( 0.7000D+01, 0.7000D+01) (
+
+(-0.1000D+01,-0.1000D+01) (-0.1000D+01,-0.1000D+01) (
+(-0.2000D+01,-0.2000D+01) (-0.2000D+01,-0.2000D+01) (
+(-0.3000D+01,-0.3000D+01) (-0.3000D+01,-0.3000D+01) (
+(-0.4000D+01,-0.4000D+01) (-0.4000D+01,-0.4000D+01) (
+(-0.5000D+01,-0.5000D+01) (-0.5000D+01,-0.5000D+01) (
+(-0.6000D+01,-0.6000D+01) (-0.6000D+01,-0.6000D+01) (
+(-0.7000D+01,-0.7000D+01) (-0.7000D+01,-0.7000D+01) (
+
+ 7 3
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+06, 0.1000D+06) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+06, 0.1000D+06) ( 0.1000D+06, 0.1000D+06) ( 0.1000D+06, 0.1000D+06)
+( 0.1000D-04, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D-04, 0.1000D-04) ( 0.1000D+06, 0.1000D+06)
+( 0.1000D-03, 0.1000D-03) ( 0.1000D-04, 0.0000D+00) ( 0.1000D+06, 0.1000D+06)
+( 0.1000D+06, 0.1000D+06) (
+( 0.1000D+06, 0.1000D+06) ( 0.1000D+06, 0.1000D+06) ( 0.1000D-04, 0.1000D-04)
+( 0.1000D+06, 0.1000D+01) ( 0.1000D+06, 0.1000D+01) ( 0.1000D+06, 0.1000D+06)
+( 0.1000D+04, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D-03, 0.1000D-04) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+00, 0.1000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.1000D-03, 0.1000D-03)
+( 0.1000D+06, 0.1000D+06) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+06, 0.1000D+06) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D-04, 0.1000D-04) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D-04, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+02, 0.1000D+02) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+06, 0.1000D+06) ( 0.1000D+06, 0.1000D+06) ( 0.1000D-04, 0.1000D-04)
+( 0.1000D+03, 0.0000D+00) (
+
+( 0.0000D+00, 0.0000D+00) ( 0.1000D-01, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+06, 0.1000D+06) ( 0.1000D-04, 0.0000D+00) ( 0.1000D+06, 0.1000D+06)
+( 0.1000D+06, 0.1000D+06) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+06, 0.1000D+06) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+06, 0.1000D+06) ( 0.1000D+06, 0.1000D+06) ( 0.1000D+00, 0.0000D+00)
+( 0.1000D+03, 0.0000D+00) (
+( 0.1000D+06, 0.1000D+06) ( 0.1000D+03, 0.0000D+00) ( 0.1000D+04, 0.0000D+00)
+( 0.1000D+04, 0.0000D+00) ( 0.1000D-03, 0.1000D-04) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D-04, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+06, 0.1000D+06) ( 0.1000D+06, 0.1000D+06) ( 0.1000D+06, 0.1000D+06)
+( 0.1000D+06, 0.1000D+06) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+06, 0.1000D+06) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+06, 0.1000D+06) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+06, 0.1000D+06) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D-03, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+06, 0.1000D+06) ( 0.1000D+06, 0.1000D+06) ( 0.1000D+06, 0.1000D+06)
+( 0.1000D-03, 0.1000D-04) (
+
+( 0.1000D-04, 0.1000D-04) ( 0.1000D-04, 0.1000D-04) ( 0.1000D-04, 0.1000D-04)
+( 0.2000D-04, 0.2000D-04) ( 0.2000D-04, 0.2000D-04) ( 0.2000D-04, 0.2000D-04)
+( 0.3000D-04, 0.3000D-04) ( 0.3000D-04, 0.3000D-04) ( 0.3000D-04, 0.3000D-04)
+( 0.4000D-04, 0.4000D-04) ( 0.4000D-04, 0.4000D-04) ( 0.4000D-04, 0.4000D-04)
+( 0.5000D-04, 0.5000D-04) ( 0.5000D-04, 0.5000D-04) ( 0.5000D-04, 0.5000D-04)
+( 0.6000D-04, 0.6000D-04) ( 0.6000D-04, 0.6000D-04) ( 0.6000D-04, 0.6000D-04)
+( 0.7000D-04, 0.7000D-04) ( 0.7000D-04, 0.7000D-04) ( 0.7000D-04, 0.7000D-04)
+
+(-0.1000D-04,-0.1000D-04) (-0.1000D-04,-0.1000D-04) (-0.1000D-04,-0.1000D-04)
+(-0.2000D-04,-0.2000D-04) (-0.2000D-04,-0.2000D-04) (-0.2000D-04,-0.2000D-04)
+(-0.3000D-04,-0.3000D-04) (-0.3000D-04,-0.3000D-04) (-0.3000D-04,-0.3000D-04)
+(-0.4000D-04,-0.4000D-04) (-0.4000D-04,-0.4000D-04) (-0.4000D-04,-0.4000D-04)
+(-0.5000D-04,-0.5000D-04) (-0.5000D-04,-0.5000D-04) (-0.5000D-04,-0.5000D-04)
+(-0.6000D-04,-0.6000D-04) (-0.6000D-04,-0.6000D-04) (-0.6000D-04,-0.6000D-04)
+(-0.7000D-04,-0.7000D-04) (-0.7000D-04,-0.7000D-04) (-0.7000D-04,-0.7000D-04)
+
+ 6 3
+(-0.2000D+02, 0.1000D+01) (-0.1000D+04, 0.1000D+04) (-0.2000D+01, 0.0000D+00)
+(-0.1000D+04, 0.0000D+00) (-0.1000D+02, 0.0000D+00) (-0.2000D+04, 0.1000D+04)
+( 0.6000D-04, 0.0000D+00) ( 0.4000D+01, 0.0000D+00) ( 0.6000D-02, 0.0000D+00)
+( 0.2000D+03, 0.0000D+00) ( 0.3000D-04, 0.0000D+00) ( 0.3000D+02, 0.0000D+00)
+(-0.2000D+00, 0.0000D+00) (-0.3000D+03, 0.0000D+00) (-0.4000D-01, 0.0000D+00)
+(-0.1000D+04, 0.1000D+04) ( 0.0000D+00, 0.0000D+00) ( 0.3000D+04, 0.1000D+04)
+( 0.6000D-04, 0.0000D+00) ( 0.4000D-01, 0.0000D+00) ( 0.9000D-02, 0.0000D+00)
+( 0.9000D+01, 0.0000D+00) ( 0.3000D-04, 0.0000D+00) ( 0.5000D+00, 0.0000D+00)
+( 0.6000D-01, 0.0000D+00) ( 0.5000D+02, 0.0000D+00) ( 0.8000D-04, 0.0000D+00)
+(-0.4000D+04, 0.0000D+00) ( 0.8000D-01, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+04, 0.1000D+04) ( 0.7000D+00, 0.0000D+00)
+(-0.2000D+04, 0.1000D+04) ( 0.1300D+02, 0.0000D+00) (-0.6000D+04, 0.1000D+04)
+
+(-0.2000D+02, 0.0000D+00) (-0.1000D+04, 0.1000D+04) ( 0.2000D+01, 0.0000D+00)
+(-0.2000D+04, 0.0000D+00) ( 0.1000D+02, 0.0000D+00) (-0.1000D+04, 0.1000D+04)
+( 0.5000D-04, 0.0000D+00) ( 0.3000D+01, 0.0000D+00) (-0.2000D-02, 0.0000D+00)
+( 0.4000D+03, 0.0000D+00) (-0.1000D-04, 0.0000D+00) ( 0.3000D+02, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) (-0.1000D+03, 0.0000D+00) (-0.8000D-01, 0.0000D+00)
+( 0.2000D+04, 0.0000D+00) (-0.4000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.5000D-04, 0.0000D+00) ( 0.3000D-01, 0.0000D+00) ( 0.2000D-02, 0.0000D+00)
+( 0.4000D+01, 0.0000D+00) ( 0.2000D-04, 0.0000D+00) ( 0.1000D+00, 0.0000D+00)
+( 0.4000D-01, 0.0000D+00) ( 0.3000D+02, 0.0000D+00) (-0.1000D-04, 0.0000D+00)
+( 0.3000D+04, 0.0000D+00) (-0.1000D-01, 0.0000D+00) ( 0.6000D+03, 0.0000D+00)
+(-0.1000D+01, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.4000D+00, 0.0000D+00)
+(-0.1000D+04, 0.1000D+04) ( 0.4000D+01, 0.0000D+00) ( 0.2000D+04, 0.0000D+00)
+
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+
+(-0.1000D+01,-0.1000D+01) (-0.1000D+01,-0.1000D+01) (-0.1000D+01,-0.1000D+01)
+(-0.1000D+01,-0.1000D+01) (-0.1000D+01,-0.1000D+01) (-0.1000D+01,-0.1000D+01)
+(-0.1000D+01,-0.1000D+01) (-0.1000D+01,-0.1000D+01) (-0.1000D+01,-0.1000D+01)
+(-0.1000D+01,-0.1000D+01) (-0.1000D+01,-0.1000D+01) (-0.1000D+01,-0.1000D+01)
+(-0.1000D+01,-0.1000D+01) (-0.1000D+01,-0.1000D+01) (-0.1000D+01,-0.1000D+01)
+(-0.1000D+01,-0.1000D+01) (-0.1000D+01,-0.1000D+01) (-0.1000D+01,-0.1000D+01)
+
+ 6 3
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.2000D+01, 0.2000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.2000D+01, 0.2000D+01)
+( 0.3000D+01, 0.3000D+01) ( 0.3000D+01, 0.3000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.4000D+01, 0.4000D+01) ( 0.4000D+01, 0.4000D+01) ( 0.4000D+01, 0.4000D+01)
+( 0.5000D+01, 0.5000D+01) ( 0.5000D+01, 0.5000D+01) ( 0.5000D+01, 0.5000D+01)
+( 0.6000D+01, 0.6000D+01) ( 0.6000D+01, 0.6000D+01) ( 0.6000D+01, 0.6000D+01)
+
+(-0.1000D+01,-0.1000D+01) (-0.1000D+01,-0.1000D+01) (-0.1000D+01,-0.1000D+01)
+(-0.2000D+01,-0.2000D+01) (-0.2000D+01,-0.2000D+01) (-0.2000D+01,-0.2000D+01)
+(-0.3000D+01,-0.3000D+01) (-0.3000D+01,-0.3000D+01) (-0.3000D+01,-0.3000D+01)
+(-0.4000D+01,-0.4000D+01) (-0.4000D+01,-0.4000D+01) (-0.4000D+01,-0.4000D+01)
+(-0.5000D+01,-0.5000D+01) (-0.5000D+01,-0.5000D+01) (-0.5000D+01,-0.5000D+01)
+(-0.6000D+01,-0.6000D+01) (-0.6000D+01,-0.6000D+01) (-0.6000D+01,-0.6000D+01)
+
+0 0
diff --git a/TESTING/zgbal.in b/TESTING/zgbal.in
new file mode 100644
index 0000000..51b1164
--- /dev/null
+++ b/TESTING/zgbal.in
@@ -0,0 +1,660 @@
+ZGL: Tests ZGGBAL
+ 6
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.2000D+01, 0.2000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.3000D+01, 0.3000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.4000D+01, 0.4000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.5000D+01, 0.5000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.6000D+01, 0.6000D+01)
+
+( 0.6000D+01, 0.6000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.5000D+01, 0.5000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.4000D+01, 0.4000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.3000D+01, 0.3000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.2000D+01, 0.2000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+
+ 1 1
+
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.2000D+01, 0.2000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.3000D+01, 0.3000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.4000D+01, 0.4000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.5000D+01, 0.5000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.6000D+01, 0.6000D+01)
+
+( 0.6000D+01, 0.6000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.5000D+01, 0.5000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.4000D+01, 0.4000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.3000D+01, 0.3000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.2000D+01, 0.2000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01 0.6000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01 0.6000D+01
+
+ 6
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+
+ 1 1
+
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 6
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.4000D+01, 0.4000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.4000D+01, 0.4000D+01) ( 0.5000D+01, 0.5000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.4000D+01, 0.4000D+01) ( 0.5000D+01, 0.5000D+01) ( 0.6000D+01, 0.6000D+01)
+
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.4000D+01, 0.4000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.4000D+01, 0.4000D+01) ( 0.5000D+01, 0.5000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.4000D+01, 0.4000D+01) ( 0.5000D+01, 0.5000D+01) ( 0.6000D+01, 0.6000D+01)
+
+ 1 1
+
+( 0.6000D+01, 0.6000D+01) ( 0.5000D+01, 0.5000D+01) ( 0.4000D+01, 0.4000D+01)
+( 0.3000D+01, 0.3000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.5000D+01, 0.5000D+01) ( 0.4000D+01, 0.4000D+01)
+( 0.3000D+01, 0.3000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.4000D+01, 0.4000D+01)
+( 0.3000D+01, 0.3000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.3000D+01, 0.3000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.2000D+01, 0.2000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+
+( 0.6000D+01, 0.6000D+01) ( 0.5000D+01, 0.5000D+01) ( 0.4000D+01, 0.4000D+01)
+( 0.3000D+01, 0.3000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.5000D+01, 0.5000D+01) ( 0.4000D+01, 0.4000D+01)
+( 0.3000D+01, 0.3000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.4000D+01, 0.4000D+01)
+( 0.3000D+01, 0.3000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.3000D+01, 0.3000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.2000D+01, 0.2000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 5
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) (
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) (
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) (
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.4000D+01, 0.4000D+01) ( 0.0000D+00, 0.0000D+00) (
+( 0.1000D+01, 0.1000D+01) ( 0.2000D+01, 0.2000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.4000D+01, 0.4000D+01) ( 0.5000D+01, 0.5000D+01) (
+
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) (
+
+ 1 1
+
+( 0.5000D+01, 0.5000D+01) ( 0.4000D+01, 0.4000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.2000D+01, 0.2000D+01) ( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.4000D+01, 0.4000D+01) ( 0.3000D+01, 0.3000D+01)
+( 0.2000D+01, 0.2000D+01) ( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.3000D+01, 0.3000D+01)
+( 0.2000D+01, 0.2000D+01) ( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.2000D+01, 0.2000D+01) ( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) (
+
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) (
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 6
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+12, 0.1000D+12) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+12, 0.1000D+12)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+
+ 1 6
+
+( 0.1000D-04, 0.0000D+00) ( 0.1000D+05, 0.1000D+05) ( 0.1000D+04, 0.1000D+04)
+( 0.1000D+02, 0.1000D+02) ( 0.1000D+00, 0.1000D+00) ( 0.1000D-02, 0.1000D-02)
+( 0.1000D-02, 0.0000D+00) ( 0.1000D-04, 0.0000D+00) ( 0.1000D+06, 0.1000D+06)
+( 0.1000D+04, 0.1000D+04) ( 0.1000D+02, 0.1000D+02) ( 0.1000D+00, 0.1000D+00)
+( 0.1000D+00, 0.0000D+00) ( 0.1000D-02, 0.0000D+00) ( 0.1000D-03, 0.0000D+00)
+( 0.1000D+06, 0.1000D+06) ( 0.1000D+04, 0.1000D+04) ( 0.1000D+02, 0.1000D+02)
+( 0.1000D+02, 0.0000D+00) ( 0.1000D+00, 0.0000D+00) ( 0.1000D-01, 0.0000D+00)
+( 0.1000D-03, 0.0000D+00) ( 0.1000D+06, 0.1000D+06) ( 0.1000D+04, 0.1000D+04)
+( 0.1000D+03, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+00, 0.0000D+00)
+( 0.1000D-02, 0.0000D+00) ( 0.1000D-04, 0.0000D+00) ( 0.1000D+05, 0.1000D+05)
+( 0.1000D+05, 0.0000D+00) ( 0.1000D+03, 0.0000D+00) ( 0.1000D+02, 0.0000D+00)
+( 0.1000D+00, 0.0000D+00) ( 0.1000D-02, 0.0000D+00) ( 0.1000D-04, 0.0000D+00)
+
+( 0.1000D-04, 0.0000D+00) ( 0.1000D+05, 0.1000D+05) ( 0.1000D+04, 0.1000D+04)
+( 0.1000D+02, 0.1000D+02) ( 0.1000D+00, 0.1000D+00) ( 0.1000D-02, 0.1000D-02)
+( 0.1000D-02, 0.0000D+00) ( 0.1000D-04, 0.0000D+00) ( 0.1000D+06, 0.1000D+06)
+( 0.1000D+04, 0.1000D+04) ( 0.1000D+02, 0.1000D+02) ( 0.1000D+00, 0.1000D+00)
+( 0.1000D+00, 0.0000D+00) ( 0.1000D-02, 0.0000D+00) ( 0.1000D-03, 0.0000D+00)
+( 0.1000D+06, 0.1000D+06) ( 0.1000D+04, 0.1000D+04) ( 0.1000D+02, 0.1000D+02)
+( 0.1000D+02, 0.0000D+00) ( 0.1000D+00, 0.0000D+00) ( 0.1000D-01, 0.0000D+00)
+( 0.1000D-03, 0.0000D+00) ( 0.1000D+06, 0.1000D+06) ( 0.1000D+04, 0.1000D+04)
+( 0.1000D+03, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+00, 0.0000D+00)
+( 0.1000D-02, 0.0000D+00) ( 0.1000D-04, 0.0000D+00) ( 0.1000D+05, 0.1000D+05)
+( 0.1000D+05, 0.0000D+00) ( 0.1000D+03, 0.0000D+00) ( 0.1000D+02, 0.0000D+00)
+( 0.1000D+00, 0.0000D+00) ( 0.1000D-02, 0.0000D+00) ( 0.1000D-04, 0.0000D+00)
+
+ 0.1000D-06 0.1000D-04 0.1000D-02 0.1000D+00 0.1000D+01 0.1000D+03
+
+ 0.1000D+03 0.1000D+01 0.1000D+00 0.1000D-02 0.1000D-04 0.1000D-06
+
+ 6
+( 0.1000D+01, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+07, 0.1000D+07) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D-05, 0.1000D-05) ( 0.1000D+07, 0.1000D+07)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+07, 0.1000D+07) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D-05, 0.1000D-05) ( 0.1000D-05, 0.1000D-05)
+( 0.1000D+07, 0.1000D+07) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+07, 0.1000D+07) ( 0.1000D+07, 0.1000D+07)
+
+( 0.1000D+01, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+07, 0.1000D+07) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D-05, 0.1000D-05) ( 0.1000D+07, 0.1000D+07)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+07, 0.1000D+07) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D-05, 0.1000D-05) ( 0.1000D-05, 0.1000D-05)
+( 0.1000D+07, 0.1000D+07) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+07, 0.1000D+07) ( 0.1000D+07, 0.1000D+07)
+
+ 4 6
+
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D-04, 0.0000D+00) ( 0.1000D+04, 0.0000D+00) ( 0.1000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D-04, 0.0000D+00) ( 0.1000D+04, 0.0000D+00) ( 0.1000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D-04, 0.0000D+00) ( 0.1000D+04, 0.0000D+00) ( 0.1000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D-03, 0.1000D-03) ( 0.1000D+05, 0.1000D+05)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+05, 0.1000D+05) ( 0.1000D+01, 0.1000D+01) ( 0.1000D-03, 0.1000D-03)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D-03, 0.1000D-03) ( 0.1000D+05, 0.1000D+05) ( 0.1000D+01, 0.1000D+01)
+
+( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D-04, 0.0000D+00) ( 0.1000D+04, 0.0000D+00) ( 0.1000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D-04, 0.0000D+00) ( 0.1000D+04, 0.0000D+00) ( 0.1000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D-04, 0.0000D+00) ( 0.1000D+04, 0.0000D+00) ( 0.1000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D-03, 0.1000D-03) ( 0.1000D+05, 0.1000D+05)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+05, 0.1000D+05) ( 0.1000D+01, 0.1000D+01) ( 0.1000D-03, 0.1000D-03)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D-03, 0.1000D-03) ( 0.1000D+05, 0.1000D+05) ( 0.1000D+01, 0.1000D+01)
+
+ 0.4000D+01 0.4000D+01 0.4000D+01 0.1000D+00 0.1000D+04 0.1000D-04
+
+ 0.2000D+01 0.3000D+01 0.4000D+01 0.1000D-04 0.1000D+04 0.1000D+00
+
+ 7
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+
+ 3 5
+
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) (
+
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+01, 0.1000D+01) (
+
+ 0.3000D+01 0.2000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.6000D+01
+ 0.5000D+01
+
+ 0.1000D+01 0.3000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.2000D+01
+ 0.2000D+01
+
+ 7
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+06, 0.1000D+06) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+06, 0.1000D+06) ( 0.1000D+06, 0.1000D+06) ( 0.1000D+06, 0.1000D+06)
+( 0.1000D-02, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D-04, 0.1000D-04) ( 0.1000D+06, 0.1000D+06)
+( 0.1000D-03, 0.1000D-03) ( 0.1000D-02, 0.0000D+00) ( 0.1000D+06, 0.1000D+06)
+( 0.1000D+06, 0.1000D+06) (
+( 0.1000D+06, 0.1000D+06) ( 0.1000D+06, 0.1000D+06) ( 0.1000D-02, 0.1000D-02)
+( 0.1000D+06, 0.1000D+01) ( 0.1000D+06, 0.1000D+01) ( 0.1000D+06, 0.1000D+06)
+( 0.1000D+04, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D-03, 0.1000D-04) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+00, 0.1000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.1000D-03, 0.1000D-03)
+( 0.1000D+06, 0.1000D+06) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+06, 0.1000D+06) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D-02, 0.1000D-02) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D-04, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+02, 0.1000D+02) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+06, 0.1000D+06) ( 0.1000D+06, 0.1000D+06) ( 0.1000D-02, 0.1000D-02)
+( 0.1000D+03, 0.0000D+00) (
+
+( 0.0000D+00, 0.0000D+00) ( 0.1000D-01, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+06, 0.1000D+06) ( 0.1000D-02, 0.0000D+00) ( 0.1000D+06, 0.1000D+06)
+( 0.1000D+06, 0.1000D+06) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+06, 0.1000D+06) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+06, 0.1000D+06) ( 0.1000D+06, 0.1000D+06) ( 0.1000D+00, 0.0000D+00)
+( 0.1000D+03, 0.0000D+00) (
+( 0.1000D+06, 0.1000D+06) ( 0.1000D+03, 0.0000D+00) ( 0.1000D+04, 0.0000D+00)
+( 0.1000D+04, 0.0000D+00) ( 0.1000D-03, 0.1000D-02) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D-04, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+06, 0.1000D+06) ( 0.1000D+06, 0.1000D+06) ( 0.1000D+06, 0.1000D+06)
+( 0.1000D+06, 0.1000D+06) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+06, 0.1000D+06) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+06, 0.1000D+06) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+06, 0.1000D+06) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D-03, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+06, 0.1000D+06) ( 0.1000D+06, 0.1000D+06) ( 0.1000D+06, 0.1000D+06)
+( 0.1000D-03, 0.1000D-02) (
+
+ 3 5
+
+( 0.1000D+06, 0.1000D+06) ( 0.1000D-02, 0.1000D-02) ( 0.1000D+05, 0.1000D+05)
+( 0.1000D+03, 0.1000D-02) ( 0.1000D+05, 0.1000D+00) ( 0.1000D+04, 0.0000D+00)
+( 0.1000D+06, 0.1000D+06) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+06, 0.1000D+06) ( 0.1000D+05, 0.1000D+05)
+( 0.1000D-06, 0.1000D-06) ( 0.1000D-03, 0.0000D+00) ( 0.1000D+06, 0.1000D+06)
+( 0.1000D-04, 0.1000D-04) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+03, 0.1000D+03)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+03, 0.1000D+03) ( 0.1000D-04, 0.0000D+00)
+( 0.1000D+04, 0.1000D+04) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D-04, 0.1000D-04)
+( 0.1000D-03, 0.1000D-03) ( 0.1000D+00, 0.1000D+00) ( 0.1000D+06, 0.1000D+06)
+( 0.1000D-03, 0.1000D-04) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D-05, 0.1000D-05)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+03, 0.1000D+03) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+00, 0.1000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D-04, 0.0000D+00)
+( 0.1000D-02, 0.1000D-02) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+06, 0.1000D+06) (
+
+( 0.1000D+06, 0.1000D+06) ( 0.1000D+04, 0.0000D+00) ( 0.1000D+00, 0.0000D+00)
+( 0.1000D+01, 0.0000D+00) ( 0.1000D-04, 0.1000D-03) ( 0.1000D+01, 0.0000D+00)
+( 0.1000D+03, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) ( 0.1000D-01, 0.0000D+00)
+( 0.1000D+03, 0.1000D+03) ( 0.1000D+05, 0.1000D+05) ( 0.1000D+03, 0.0000D+00)
+( 0.1000D+06, 0.1000D+06) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+03, 0.1000D+03)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D-05, 0.0000D+00) ( 0.1000D+04, 0.1000D+04)
+( 0.1000D-03, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+05, 0.1000D+05)
+( 0.1000D+03, 0.1000D+03) ( 0.1000D+05, 0.1000D+05) ( 0.1000D+06, 0.1000D+06)
+( 0.1000D-04, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+03, 0.1000D+03)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+03, 0.1000D+03) ( 0.1000D-05, 0.1000D-04)
+( 0.1000D-05, 0.0000D+00) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+06, 0.1000D+06)
+( 0.1000D+06, 0.1000D+06) (
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.1000D+06, 0.1000D+06) (
+
+ 0.3000D+01 0.2000D+01 0.1000D-01 0.1000D+01 0.1000D-01 0.6000D+01
+ 0.5000D+01
+
+ 0.1000D+01 0.3000D+01 0.1000D+00 0.1000D-02 0.1000D+00 0.2000D+01
+ 0.2000D+01
+
+ 6
+(-0.2000D+02, 0.1000D+01) (-0.1000D+05, 0.1000D+05) (-0.2000D+01, 0.0000D+00)
+(-0.1000D+07, 0.0000D+00) (-0.1000D+02, 0.0000D+00) (-0.2000D+06, 0.1000D+06)
+( 0.6000D-02, 0.0000D+00) ( 0.4000D+01, 0.0000D+00) ( 0.6000D-03, 0.0000D+00)
+( 0.2000D+03, 0.0000D+00) ( 0.3000D-02, 0.0000D+00) ( 0.3000D+02, 0.0000D+00)
+(-0.2000D+00, 0.0000D+00) (-0.3000D+03, 0.0000D+00) (-0.4000D-01, 0.0000D+00)
+(-0.1000D+05, 0.1000D+05) ( 0.0000D+00, 0.0000D+00) ( 0.3000D+04, 0.1000D+04)
+( 0.6000D-04, 0.0000D+00) ( 0.4000D-01, 0.0000D+00) ( 0.9000D-05, 0.0000D+00)
+( 0.9000D+01, 0.0000D+00) ( 0.3000D-04, 0.0000D+00) ( 0.5000D+00, 0.0000D+00)
+( 0.6000D-01, 0.0000D+00) ( 0.5000D+02, 0.0000D+00) ( 0.8000D-02, 0.0000D+00)
+(-0.4000D+04, 0.0000D+00) ( 0.8000D-01, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+04, 0.1000D+04) ( 0.7000D+00, 0.0000D+00)
+(-0.2000D+06, 0.1000D+06) ( 0.1300D+02, 0.0000D+00) (-0.6000D+05, 0.1000D+05)
+
+(-0.2000D+02, 0.0000D+00) (-0.1000D+05, 0.1000D+05) ( 0.2000D+01, 0.0000D+00)
+(-0.2000D+07, 0.0000D+00) ( 0.1000D+02, 0.0000D+00) (-0.1000D+06, 0.1000D+06)
+( 0.5000D-02, 0.0000D+00) ( 0.3000D+01, 0.0000D+00) (-0.2000D-03, 0.0000D+00)
+( 0.4000D+03, 0.0000D+00) (-0.1000D-02, 0.0000D+00) ( 0.3000D+02, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) (-0.1000D+03, 0.0000D+00) (-0.8000D-01, 0.0000D+00)
+( 0.2000D+05, 0.0000D+00) (-0.4000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.5000D-04, 0.0000D+00) ( 0.3000D-01, 0.0000D+00) ( 0.2000D-05, 0.0000D+00)
+( 0.4000D+01, 0.0000D+00) ( 0.2000D-04, 0.0000D+00) ( 0.1000D+00, 0.0000D+00)
+( 0.4000D-01, 0.0000D+00) ( 0.3000D+02, 0.0000D+00) (-0.1000D-02, 0.0000D+00)
+( 0.3000D+04, 0.0000D+00) (-0.1000D-01, 0.0000D+00) ( 0.6000D+03, 0.0000D+00)
+(-0.1000D+01, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.4000D+00, 0.0000D+00)
+(-0.1000D+06, 0.1000D+06) ( 0.4000D+01, 0.0000D+00) ( 0.2000D+05, 0.0000D+00)
+
+ 1 6
+
+(-0.2000D+00, 0.1000D-01) (-0.1000D+01, 0.1000D+01) (-0.2000D+00, 0.0000D+00)
+(-0.1000D+01, 0.0000D+00) (-0.1000D+01, 0.0000D+00) (-0.2000D+00, 0.1000D+00)
+( 0.6000D+00, 0.0000D+00) ( 0.4000D+01, 0.0000D+00) ( 0.6000D+00, 0.0000D+00)
+( 0.2000D+01, 0.0000D+00) ( 0.3000D+01, 0.0000D+00) ( 0.3000D+00, 0.0000D+00)
+(-0.2000D+00, 0.0000D+00) (-0.3000D+01, 0.0000D+00) (-0.4000D+00, 0.0000D+00)
+(-0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.3000D+00, 0.1000D+00)
+( 0.6000D+00, 0.0000D+00) ( 0.4000D+01, 0.0000D+00) ( 0.9000D+00, 0.0000D+00)
+( 0.9000D+01, 0.0000D+00) ( 0.3000D+01, 0.0000D+00) ( 0.5000D+00, 0.0000D+00)
+( 0.6000D+00, 0.0000D+00) ( 0.5000D+01, 0.0000D+00) ( 0.8000D+00, 0.0000D+00)
+(-0.4000D+01, 0.0000D+00) ( 0.8000D+01, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.7000D+00, 0.0000D+00)
+(-0.2000D+01, 0.1000D+01) ( 0.1300D+02, 0.0000D+00) (-0.6000D+00, 0.1000D+00)
+
+(-0.2000D+00, 0.0000D+00) (-0.1000D+01, 0.1000D+01) ( 0.2000D+00, 0.0000D+00)
+(-0.2000D+01, 0.0000D+00) ( 0.1000D+01, 0.0000D+00) (-0.1000D+00, 0.1000D+00)
+( 0.5000D+00, 0.0000D+00) ( 0.3000D+01, 0.0000D+00) (-0.2000D+00, 0.0000D+00)
+( 0.4000D+01, 0.0000D+00) (-0.1000D+01, 0.0000D+00) ( 0.3000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) (-0.1000D+01, 0.0000D+00) (-0.8000D+00, 0.0000D+00)
+( 0.2000D+01, 0.0000D+00) (-0.4000D+01, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.5000D+00, 0.0000D+00) ( 0.3000D+01, 0.0000D+00) ( 0.2000D+00, 0.0000D+00)
+( 0.4000D+01, 0.0000D+00) ( 0.2000D+01, 0.0000D+00) ( 0.1000D+00, 0.0000D+00)
+( 0.4000D+00, 0.0000D+00) ( 0.3000D+01, 0.0000D+00) (-0.1000D+00, 0.0000D+00)
+( 0.3000D+01, 0.0000D+00) (-0.1000D+01, 0.0000D+00) ( 0.6000D+00, 0.0000D+00)
+(-0.1000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.4000D+00, 0.0000D+00)
+(-0.1000D+01, 0.1000D+01) ( 0.4000D+01, 0.0000D+00) ( 0.2000D+00, 0.0000D+00)
+
+ 0.1000D-02 0.1000D+02 0.1000D+00 0.1000D+04 0.1000D+01 0.1000D-01
+
+ 0.1000D+02 0.1000D+00 0.1000D+03 0.1000D-02 0.1000D+03 0.1000D-02
+
+ 6
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.0000D+00, 0.0000D+00)
+
+ 3 4
+
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01) ( 0.1000D+01, 0.1000D+01)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00) ( 0.0000D+00, 0.0000D+00) ( 0.1000D+01, 0.1000D+01)
+
+ 0.1000D+01 0.2000D+01 0.1000D+01 0.1000D+01 0.5000D+01 0.6000D+01
+
+ 0.2000D+01 0.2000D+01 0.1000D+01 0.1000D+01 0.5000D+01 0.5000D+01
+
+0
diff --git a/TESTING/zgd.in b/TESTING/zgd.in
new file mode 100644
index 0000000..e92782a
--- /dev/null
+++ b/TESTING/zgd.in
@@ -0,0 +1,182 @@
+ZGV Data for the Complex Nonsymmetric Eigenvalue Driver
+6 Number of matrix dimensions
+2 6 8 10 12 20 Matrix dimensions
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+ZGV 26 Test all 26 matrix types
+ZGS Data for the Complex Nonsymmetric Schur Form Driver
+5 Number of matrix dimensions
+2 6 10 12 20 30 Matrix dimensions
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+ZGS 26 Test all 26 matrix types
+ZGX Data for the Complex Nonsymmetric Schur Form Expert Driver
+2 Largest matrix dimension (0 <= NSIZE <= 5)
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+ZXV Data for the Complex Nonsymmetric Eigenvalue Expert Driver
+6 Number of matrix dimensions
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+ZGX Data for the Complex Nonsymmetric Schur Form Expert Driver
+0 Number of matrix dimensions
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+ 4
+ 2
+( 2.0000D+00, 6.0000D+00)
+( 2.0000D+00, 5.0000D+00)
+( 3.0000D+00,-1.0000D+01)
+( 4.0000D+00, 7.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 9.0000D+00, 2.0000D+00)
+( 1.6000D+01,-2.4000D+01)
+( 7.0000D+00,-7.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 8.0000D+00,-3.0000D+00)
+( 9.0000D+00,-8.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+01,-1.6000D+01)
+(-9.0000D+00, 1.0000D+00)
+(-1.0000D+00,-8.0000D+00)
+(-1.0000D+00, 1.0000D+01)
+( 2.0000D+00,-6.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+(-1.0000D+00, 4.0000D+00)
+( 1.0000D+00, 1.6000D+01)
+(-6.0000D+00, 4.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00,-1.4000D+01)
+(-1.0000D+00, 6.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 8.0000D+00, 4.0000D+00)
+ 7.6883D-02 2.1007D-01 Condition #'s for cluster selected from lower 2x2
+ 4
+ 2
+( 1.0000D+00, 8.0000D+00)
+( 2.0000D+00, 4.0000D+00)
+( 3.0000D+00,-1.3000D+01)
+( 4.0000D+00, 4.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 5.0000D+00, 7.0000D+00)
+( 6.0000D+00,-2.4000D+01)
+( 7.0000D+00,-3.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 8.0000D+00, 3.0000D+00)
+( 9.0000D+00,-5.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+01, 1.6000D+01)
+(-1.0000D+00, 9.0000D+00)
+(-1.0000D+00,-1.0000D+00)
+(-1.0000D+00, 1.0000D+00)
+(-1.0000D+00,-6.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+(-1.0000D+00, 4.0000D+00)
+(-1.0000D+00, 1.6000D+01)
+(-1.0000D+00,-2.4000D+01)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00,-1.1000D+01)
+(-1.0000D+00, 6.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 4.0000D+00)
+ 4.2067D-01 4.9338D+00 Condition #'s for cluster selected from lower 2x2
+0
+ZXV Data for the Complex Nonsymmetric Eigenvalue Expert Driver
+0 Number of matrix dimensions
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+ 4
+( 2.0000D+00, 6.0000D+00)
+( 2.0000D+00, 5.0000D+00)
+( 3.0000D+00,-1.0000D+01)
+( 4.0000D+00, 7.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 9.0000D+00, 2.0000D+00)
+( 1.6000D+01,-2.4000D+01)
+( 7.0000D+00,-7.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 8.0000D+00,-3.0000D+00)
+( 9.0000D+00,-8.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+01,-1.6000D+01)
+(-9.0000D+00, 1.0000D+00)
+(-1.0000D+00,-8.0000D+00)
+(-1.0000D+00, 1.0000D+01)
+( 2.0000D+00,-6.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+(-1.0000D+00, 4.0000D+00)
+( 1.0000D+00, 1.6000D+01)
+(-6.0000D+00, 4.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00,-1.4000D+01)
+(-1.0000D+00, 6.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 8.0000D+00, 4.0000D+00)
+ 5.2612D+00 8.0058D-01 1.4032D+00 4.0073D+00 condition #'s for eigenvalues
+ 1.1787D+00 3.3139D+00 1.1835D+00 2.0777D+00 condition #'s for eigenvectors
+ 4
+( 1.0000D+00, 8.0000D+00)
+( 2.0000D+00, 4.0000D+00)
+( 3.0000D+00,-1.3000D+01)
+( 4.0000D+00, 4.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 5.0000D+00, 7.0000D+00)
+( 6.0000D+00,-2.4000D+01)
+( 7.0000D+00,-3.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 8.0000D+00, 3.0000D+00)
+( 9.0000D+00,-5.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+01, 1.6000D+01)
+(-1.0000D+00, 9.0000D+00)
+(-1.0000D+00,-1.0000D+00)
+(-1.0000D+00, 1.0000D+00)
+(-1.0000D+00,-6.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+(-1.0000D+00, 4.0000D+00)
+(-1.0000D+00, 1.6000D+01)
+(-1.0000D+00,-2.4000D+01)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00,-1.1000D+01)
+(-1.0000D+00, 6.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 0.0000D+00, 0.0000D+00)
+( 1.0000D+00, 4.0000D+00)
+ 4.9068D+00 1.6813D+00 3.4636D+00 5.2436D+00 condition #'s for eigenvalues
+ 1.0386D+00 1.4728D+00 2.0029D+00 9.8365D-01 condition #'s for eigenvectors
+0
diff --git a/TESTING/zgg.in b/TESTING/zgg.in
new file mode 100644
index 0000000..3937629
--- /dev/null
+++ b/TESTING/zgg.in
@@ -0,0 +1,15 @@
+ZGG: Data file for testing Nonsymmetric Eigenvalue Problem routines
+7 Number of values of N
+0 1 2 3 5 10 16 Values of N (dimension)
+4 Number of parameter values
+1 1 2 2 Values of NB (blocksize)
+40 40 2 2 Values of NBMIN (minimum blocksize)
+2 4 2 4 Values of NSHIFT (no. of shifts)
+40 40 2 2 Values of MAXB (multishift crossover pt)
+40 40 2 2 Values of NBCOL (minimum col. dimension)
+20.0 Threshold value
+T Put T to test the LAPACK routines
+T Put T to test the driver routines
+T Put T to test the error exits
+1 Code to interpret the seed
+ZGG 26
diff --git a/TESTING/zsb.in b/TESTING/zsb.in
new file mode 100644
index 0000000..fb454b3
--- /dev/null
+++ b/TESTING/zsb.in
@@ -0,0 +1,9 @@
+ZHB: Data file for testing Hermitian Eigenvalue Problem routines
+2 Number of values of N
+5 20 Values of N (dimension)
+5 Number of values of K
+0 1 2 5 16 Values of K (band width)
+20.0 Threshold value
+T Put T to test the error exits
+1 Code to interpret the seed
+ZHB 15
diff --git a/TESTING/zsg.in b/TESTING/zsg.in
new file mode 100644
index 0000000..89226e8
--- /dev/null
+++ b/TESTING/zsg.in
@@ -0,0 +1,13 @@
+ZSG: Data file for testing Generalized Hermitian Eigenvalue Problem routines
+7 Number of values of N
+0 1 2 3 5 10 16 Values of N (dimension)
+3 Number of values of NB
+1 3 20 Values of NB (blocksize)
+2 2 2 Values of NBMIN (minimum blocksize)
+1 1 1 Values of NX (crossover point)
+20.0 Threshold value
+T Put T to test the LAPACK routines
+T Put T to test the driver routines
+T Put T to test the error exits
+1 Code to interpret the seed
+ZSG 21
diff --git a/TESTING/ztest.in b/TESTING/ztest.in
new file mode 100644
index 0000000..d0920bb
--- /dev/null
+++ b/TESTING/ztest.in
@@ -0,0 +1,39 @@
+Data file for testing COMPLEX*16 LAPACK linear equation routines
+7 Number of values of M
+0 1 2 3 5 10 50 Values of M (row dimension)
+7 Number of values of N
+0 1 2 3 5 10 50 Values of N (column dimension)
+3 Number of values of NRHS
+1 2 15 Values of NRHS (number of right hand sides)
+5 Number of values of NB
+1 3 3 3 20 Values of NB (the blocksize)
+1 0 5 9 1 Values of NX (crossover point)
+3 Number of values of RANK
+30 50 90 Values of rank (as a % of N)
+30.0 Threshold value of test ratio
+T Put T to test the LAPACK routines
+T Put T to test the driver routines
+T Put T to test the error exits
+ZGE 11 List types on next line if 0 < NTYPES < 11
+ZGB 8 List types on next line if 0 < NTYPES < 8
+ZGT 12 List types on next line if 0 < NTYPES < 12
+ZPO 9 List types on next line if 0 < NTYPES < 9
+ZPS 9 List types on next line if 0 < NTYPES < 9
+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
+ZHE 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
+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
+ZTB 17 List types on next line if 0 < NTYPES < 17
+ZQR 8 List types on next line if 0 < NTYPES < 8
+ZRQ 8 List types on next line if 0 < NTYPES < 8
+ZLQ 8 List types on next line if 0 < NTYPES < 8
+ZQL 8 List types on next line if 0 < NTYPES < 8
+ZQP 6 List types on next line if 0 < NTYPES < 6
+ZTZ 3 List types on next line if 0 < NTYPES < 3
+ZLS 6 List types on next line if 0 < NTYPES < 6
+ZEQ
diff --git a/TESTING/ztest_rfp.in b/TESTING/ztest_rfp.in
new file mode 100644
index 0000000..83b0eb2
--- /dev/null
+++ b/TESTING/ztest_rfp.in
@@ -0,0 +1,9 @@
+Data file for testing COMPLEX*16 LAPACK linear equation routines RFP format
+9 Number of values of N (at most 9)
+0 1 2 3 5 6 10 11 50 Values of N
+3 Number of values of NRHS (at most 9)
+1 2 15 Values of NRHS (number of right hand sides)
+9 Number of matrix types (list types on next line if 0 < NTYPES < 9)
+1 2 3 4 5 6 7 8 9 Matrix Types
+30.0 Threshold value of test ratio
+T Put T to test the error exits
diff --git a/clapack-config-version.cmake.in b/clapack-config-version.cmake.in
new file mode 100644
index 0000000..5cbdd8f
--- /dev/null
+++ b/clapack-config-version.cmake.in
@@ -0,0 +1,8 @@
+set(PACKAGE_VERSION "@CLAPACK_VERSION@")
+if(NOT ${PACKAGE_FIND_VERSION} VERSION_GREATER ${PACKAGE_VERSION})
+ set(PACKAGE_VERSION_COMPATIBLE 1)
+ if(${PACKAGE_FIND_VERSION} VERSION_EQUAL ${PACKAGE_VERSION})
+ set(PACKAGE_VERSION_EXACT 1)
+ endif()
+endif()
+
diff --git a/clapack-config.cmake.in b/clapack-config.cmake.in
new file mode 100644
index 0000000..cd19f1d
--- /dev/null
+++ b/clapack-config.cmake.in
@@ -0,0 +1 @@
+include("@CLAPACK_BINARY_DIR@/clapack-targets.cmake")
diff --git a/clapack_build.cmake b/clapack_build.cmake
new file mode 100644
index 0000000..6fd30ad
--- /dev/null
+++ b/clapack_build.cmake
@@ -0,0 +1,238 @@
+cmake_minimum_required(VERSION 2.6)
+
+if("${CTEST_SCRIPT_ARG}" MATCHES "GCov")
+ message("Setting up for GCov Coverage")
+ set(gcov 1)
+ find_program(CTEST_COVERAGE_COMMAND gcov)
+ set(cov_options "-fprofile-arcs -ftest-coverage")
+ set(ENV{CFLAGS} "-fprofile-arcs -ftest-coverage")
+ set(ENV{LDFLAGS} "-fprofile-arcs -ftest-coverage")
+endif()
+
+# set default compilers for UNIX gcc/g++
+if(UNIX)
+ if(NOT compiler)
+ set(compiler gcc)
+ endif(NOT compiler)
+ if(NOT c_compiler)
+ set(c_compiler gcc)
+ endif(NOT c_compiler)
+ if(NOT full_compiler)
+ set(full_compiler g++)
+ endif(NOT full_compiler)
+endif(UNIX)
+
+if(EXISTS "/proc/cpuinfo")
+ set(parallel 1)
+ file(STRINGS "/proc/cpuinfo" CPUINFO)
+ foreach(line ${CPUINFO})
+ if("${line}" MATCHES processor)
+ math(EXPR parallel "${parallel} + 1")
+ endif()
+ endforeach(line)
+endif()
+
+if(WIN32)
+ set(VSLOCATIONS
+ "[HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\VisualStudio\\6.0\\Setup;VsCommonDir]/MSDev98/Bin"
+ "[HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\VisualStudio\\7.0\\Setup\\VS;EnvironmentDirectory]"
+ "[HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\VisualStudio\\7.1\\Setup\\VS;EnvironmentDirectory]"
+ "[HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\VisualStudio\\8.0;InstallDir]"
+ "[HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\VisualStudio\\8.0\\Setup;Dbghelp_path]"
+ "[HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\VisualStudio\\9.0\\Setup\\VS;EnvironmentDirectory]"
+ )
+ set(GENERATORS
+ "Visual Studio 6"
+ "Visual Studio 7"
+ "Visual Studio 7 .NET 2003"
+ "Visual Studio 8 2005"
+ "Visual Studio 8 2005"
+ "Visual Studio 9 2008"
+ )
+ set(vstype 0)
+ foreach(p ${VSLOCATIONS})
+ get_filename_component(VSPATH ${p} PATH)
+ if(NOT "${VSPATH}" STREQUAL "/" AND EXISTS "${VSPATH}")
+ message(" found VS install = ${VSPATH}")
+ set(genIndex ${vstype})
+ endif()
+ math(EXPR vstype "${vstype} +1")
+ endforeach()
+ if(NOT DEFINED genIndex)
+ message(FATAL_ERROR "Could not find installed visual stuido")
+ endif()
+ list(GET GENERATORS ${genIndex} GENERATOR)
+ set(CTEST_CMAKE_GENERATOR "${GENERATOR}")
+ message("${CTEST_CMAKE_GENERATOR} - found")
+ set(ENV{CMAKE_CONFIG_TYPE} "Release")
+ set(compiler cl)
+ set(hostname $ENV{COMPUTERNAME})
+else()
+ find_program(HOSTNAME NAMES hostname)
+ find_program(UNAME NAMES uname)
+
+# Get the build name and hostname
+ exec_program(${HOSTNAME} ARGS OUTPUT_VARIABLE hostname)
+string(REGEX REPLACE "[/\\\\+<> #]" "-" hostname "${hostname}")
+endif()
+
+message("HOSTNAME: ${hostname}")
+# default to parallel 1
+if(NOT DEFINED parallel)
+ set(parallel 1)
+endif(NOT DEFINED parallel)
+
+# find CVS
+find_program(SVN svn PATHS $ENV{HOME}/bin /vol/local/bin)
+if(NOT SVN)
+ message(FATAL_ERROR "SVN not found")
+endif()
+
+set(CTEST_UPDATE_COMMAND ${SVN})
+macro(getuname name flag)
+ exec_program("${UNAME}" ARGS "${flag}" OUTPUT_VARIABLE "${name}")
+ string(REGEX REPLACE "[/\\\\+<> #]" "-" "${name}" "${${name}}")
+ string(REGEX REPLACE "^(......|.....|....|...|..|.).*" "\\1" "${name}" "${${name}}")
+endmacro(getuname)
+if(WIN32)
+ set(osname "")
+ set(osver "$ENV{OS}")
+ set(cpu $ENV{PROCESSOR_ARCHITECTURE})
+ set(osrel "")
+else()
+ getuname(osname -s)
+ getuname(osver -v)
+ getuname(osrel -r)
+ getuname(cpu -m)
+endif()
+if("${osname}" MATCHES Darwin)
+ find_program(SW_VER sw_vers)
+ execute_process(COMMAND "${SW_VER}" -productVersion OUTPUT_VARIABLE osver)
+ string(REPLACE "\n" "" osver "${osver}")
+ set(osname "MacOSX")
+ set(osrel "")
+ if("${cpu}" MATCHES "Power")
+ set(cpu "ppc")
+ endif("${cpu}" MATCHES "Power")
+endif("${osname}" MATCHES Darwin)
+
+if(NOT compiler)
+ message(FATAL_ERROR "compiler must be set")
+endif(NOT compiler)
+
+
+set(BUILDNAME "${osname}${osver}${osrel}${cpu}-${compiler}")
+if(gcov)
+ set(BUILDNAME "${BUILDNAME}-gcov")
+endif()
+message("BUILDNAME: ${BUILDNAME}")
+
+# this is the cvs module name that should be checked out
+set (CTEST_MODULE_NAME clapack)
+set (CTEST_DIR_NAME "${CTEST_MODULE_NAME}SVN")
+
+# Settings:
+message("NOSPACES = ${NOSPACES}")
+if(NOSPACES)
+ set(CTEST_DASHBOARD_ROOT "$ENV{HOME}/Dashboards/MyTests-${BUILDNAME}")
+else(NOSPACES)
+ set(CTEST_DASHBOARD_ROOT "$ENV{HOME}/Dashboards/My Tests-${BUILDNAME}")
+endif(NOSPACES)
+set(CTEST_SITE "${hostname}")
+set(CTEST_BUILD_NAME "${BUILDNAME}")
+set(CTEST_TEST_TIMEOUT "1500")
+
+# CVS command and the checkout command
+if(NOT EXISTS "${CTEST_DASHBOARD_ROOT}/${CTEST_DIR_NAME}")
+ set(CTEST_CHECKOUT_COMMAND
+ "\"${CTEST_UPDATE_COMMAND}\" co https://icl.eecs.utk.edu/svn/lapack-dev/clapack/trunk ${CTEST_DIR_NAME}")
+endif(NOT EXISTS "${CTEST_DASHBOARD_ROOT}/${CTEST_DIR_NAME}")
+
+# Set the generator and build configuration
+if(NOT DEFINED CTEST_CMAKE_GENERATOR)
+ set(CTEST_CMAKE_GENERATOR "Unix Makefiles")
+endif(NOT DEFINED CTEST_CMAKE_GENERATOR)
+set(CTEST_PROJECT_NAME "CLAPACK")
+if(gcov)
+ set(CTEST_BUILD_CONFIGURATION "Debug")
+else()
+ set(CTEST_BUILD_CONFIGURATION "Release")
+endif()
+
+# Extra special variables
+set(ENV{DISPLAY} "")
+if(CTEST_CMAKE_GENERATOR MATCHES Makefiles)
+ set(ENV{CC} "${c_compiler}")
+ set(ENV{FC} "${f_compiler}")
+ set(ENV{CXX} "${full_compiler}")
+endif(CTEST_CMAKE_GENERATOR MATCHES Makefiles)
+
+#----------------------------------------------------------------------------------
+# Should not need to edit under this line
+#----------------------------------------------------------------------------------
+
+# if you do not want to use the default location for a
+# dashboard then set this variable to the directory
+# the dashboard should be in
+make_directory("${CTEST_DASHBOARD_ROOT}")
+# these are the the name of the source and binary directory on disk.
+# They will be appended to DASHBOARD_ROOT
+set(CTEST_SOURCE_DIRECTORY "${CTEST_DASHBOARD_ROOT}/${CTEST_DIR_NAME}")
+set(CTEST_BINARY_DIRECTORY "${CTEST_SOURCE_DIRECTORY}-${CTEST_BUILD_NAME}")
+set(CTEST_NOTES_FILES "${CTEST_NOTES_FILES}"
+ "${CMAKE_CURRENT_LIST_FILE}"
+ )
+
+# check for parallel
+if(parallel GREATER 1)
+ if(NOT CTEST_BUILD_COMMAND)
+ set(CTEST_BUILD_COMMAND "make -j${parallel} -i")
+ endif(NOT CTEST_BUILD_COMMAND)
+
+ message("Use parallel build")
+ message("CTEST_BUILD_COMMAND: ${CTEST_BUILD_COMMAND}")
+ message("CTEST_CONFIGURE_COMMAND: ${CTEST_CONFIGURE_COMMAND}")
+endif(parallel GREATER 1)
+
+##########################################################################
+# wipe the binary dir
+message("Remove binary directory...")
+ctest_empty_binary_directory("${CTEST_BINARY_DIRECTORY}")
+
+message("CTest Directory: ${CTEST_DASHBOARD_ROOT}")
+message("Initial checkout: ${CTEST_CVS_CHECKOUT}")
+message("Initial cmake: ${CTEST_CMAKE_COMMAND}")
+message("CTest command: ${CTEST_COMMAND}")
+
+# this is the initial cache to use for the binary tree, be careful to escape
+# any quotes inside of this string if you use it
+file(WRITE "${CTEST_BINARY_DIRECTORY}/CMakeCache.txt" "
+SITE:STRING=${hostname}
+BUILDNAME:STRING=${BUILDNAME}
+DART_ROOT:PATH=
+SVNCOMMAND:FILEPATH=${CTEST_UPDATE_COMMAND}
+DROP_METHOD:STRING=https
+DART_TESTING_TIMEOUT:STRING=${CTEST_TEST_TIMEOUT}
+")
+
+message("Start dashboard...")
+ctest_start(Nightly)
+message(" Update")
+ctest_update(SOURCE "${CTEST_SOURCE_DIRECTORY}" RETURN_VALUE res)
+message(" Configure")
+ctest_configure(BUILD "${CTEST_BINARY_DIRECTORY}" RETURN_VALUE res)
+message("read custom files after configure")
+ctest_read_custom_files("${CTEST_BINARY_DIRECTORY}")
+message(" Build")
+ctest_build(BUILD "${CTEST_BINARY_DIRECTORY}" RETURN_VALUE res)
+message(" Test")
+ctest_test(BUILD "${CTEST_BINARY_DIRECTORY}" RETURN_VALUE res)
+if(gcov)
+ message(" Coverage")
+ ctest_coverage(BUILD "${CTEST_BINARY_DIRECTORY}")
+endif()
+message(" Submit")
+ctest_submit(RETURN_VALUE res)
+message(" All done")
+
+
diff --git a/make.inc.example b/make.inc.example
new file mode 100644
index 0000000..0ac8bbb
--- /dev/null
+++ b/make.inc.example
@@ -0,0 +1,79 @@
+# -*- Makefile -*-
+####################################################################
+# LAPACK make include file. #
+# LAPACK, Version 3.2.1 #
+# June 2009 #
+####################################################################
+#
+# See the INSTALL/ directory for more examples.
+#
+SHELL = /bin/sh
+#
+# The machine (platform) identifier to append to the library names
+#
+PLAT = _LINUX
+#
+# Modify the FORTRAN and OPTS definitions to refer to the
+# compiler and desired compiler options for your machine. NOOPT
+# refers to the compiler options desired when NO OPTIMIZATION is
+# selected. Define LOADER and LOADOPTS to refer to the loader
+# and desired load options for your machine.
+#
+#######################################################
+# This is used to compile C libary
+CC = gcc
+# if no wrapping of the blas library is needed, uncomment next line
+#CC = gcc -DNO_BLAS_WRAP
+CFLAGS = -O3
+LOADER = gcc
+LOADOPTS =
+NOOPT = -O0
+DRVCFLAGS = $(CFLAGS)
+F2CCFLAGS = $(CFLAGS)
+#######################################################################
+
+#
+# Timer for the SECOND and DSECND routines
+#
+# Default : SECOND and DSECND will use a call to the EXTERNAL FUNCTION ETIME
+# TIMER = EXT_ETIME
+# For RS6K : SECOND and DSECND will use a call to the EXTERNAL FUNCTION ETIME_
+# TIMER = EXT_ETIME_
+# For gfortran compiler: SECOND and DSECND will use a call to the INTERNAL FUNCTION ETIME
+# TIMER = INT_ETIME
+# If your Fortran compiler does not provide etime (like Nag Fortran Compiler, etc...)
+# SECOND and DSECND will use a call to the Fortran standard INTERNAL FUNCTION CPU_TIME
+TIMER = INT_CPU_TIME
+# If neither of this works...you can use the NONE value... In that case, SECOND and DSECND will always return 0
+# TIMER = NONE
+#
+# The archiver and the flag(s) to use when building archive (library)
+# If you system has no ranlib, set RANLIB = echo.
+#
+ARCH = ar
+ARCHFLAGS= cr
+RANLIB = ranlib
+#
+# The location of BLAS library for linking the testing programs.
+# The target's machine-specific, optimized BLAS library should be
+# used whenever possible.
+#
+BLASLIB = ../../blas$(PLAT).a
+#
+# Location of the extended-precision BLAS (XBLAS) Fortran library
+# used for building and testing extended-precision routines. The
+# relevant routines will be compiled and XBLAS will be linked only if
+# USEXBLAS is defined.
+#
+# USEXBLAS = Yes
+XBLASLIB =
+# XBLASLIB = -lxblas
+#
+# Names of generated libraries.
+#
+LAPACKLIB = lapack$(PLAT).a
+F2CLIB = ../../F2CLIBS/libf2c.a
+TMGLIB = tmglib$(PLAT).a
+EIGSRCLIB = eigsrc$(PLAT).a
+LINSRCLIB = linsrc$(PLAT).a
+F2CLIB = ../../F2CLIBS/libf2c.a
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-science/packages/clapack.git
More information about the debian-science-commits
mailing list